diff --git a/ocaml/fstar-lib/FStar_BaseTypes.ml b/ocaml/fstar-lib/FStarC_BaseTypes.ml similarity index 100% rename from ocaml/fstar-lib/FStar_BaseTypes.ml rename to ocaml/fstar-lib/FStarC_BaseTypes.ml diff --git a/ocaml/fstar-lib/FStar_BigInt.ml b/ocaml/fstar-lib/FStarC_BigInt.ml similarity index 100% rename from ocaml/fstar-lib/FStar_BigInt.ml rename to ocaml/fstar-lib/FStarC_BigInt.ml diff --git a/ocaml/fstar-lib/FStarC_Compiler_Bytes.ml b/ocaml/fstar-lib/FStarC_Compiler_Bytes.ml new file mode 100644 index 00000000000..d79b5e31963 --- /dev/null +++ b/ocaml/fstar-lib/FStarC_Compiler_Bytes.ml @@ -0,0 +1,111 @@ +let b0 n = (n land 0xFF) +let b1 n = ((n lsr 8) land 0xFF) +let b2 n = ((n lsr 16) land 0xFF) +let b3 n = ((n lsr 24) land 0xFF) + +let dWw1 n = BatInt64.to_int (BatInt64.logand (BatInt64.shift_right n 32) 0xFFFFFFFFL) +let dWw0 n = BatInt64.to_int (BatInt64.logand n 0xFFFFFFFFL) + +type bytes = int array + +let f_encode f (b:bytes) = String.concat "" (Array.to_list (Array.map f b)) +let length (b:bytes) = BatArray.length b +let get (b:bytes) n = Z.of_int (BatArray.get b (Z.to_int n)) +let make (f : _ -> Z.t) n = BatArray.init (Z.to_int n) (fun i -> Z.to_int (f (Z.of_int i))) +let zero_create n : bytes = BatArray.create n 0 + +let sub ( b:bytes) s l = BatArray.sub b s l +let set = BatArray.set +let blit (a:bytes) b c d e = BatArray.blit a b c d e +let string_as_unicode_bytes (s:string) = FStarC_Compiler_Util.unicode_of_string s +let utf8_bytes_as_string (b:bytes) = FStarC_Compiler_Util.string_of_unicode b +let unicode_bytes_as_string (b:bytes) = FStarC_Compiler_Util.string_of_unicode b +let compare (b1:bytes) (b2:bytes) = compare b1 b2 + +let to_intarray (b:bytes) = b +let of_intarray (arr:int array) = arr + +let string_as_utf8_bytes (s:string) = FStarC_Compiler_Util.unicode_of_string s + +let append (b1: bytes) (b2:bytes) = BatArray.append b1 b2 + +type bytebuf = + { mutable bbArray: bytes; + mutable bbCurrent: int } + +module Bytebuf = struct + let create sz = + { bbArray=zero_create sz; + bbCurrent = 0; } + + let ensure_bytebuf buf new_size = + let old_buf_size = BatArray.length buf.bbArray in + if new_size > old_buf_size then ( + let old = buf.bbArray in + buf.bbArray <- zero_create (max new_size (old_buf_size * 2)); + blit old 0 buf.bbArray 0 buf.bbCurrent + ) + + let close buf = sub buf.bbArray 0 buf.bbCurrent + + let emit_int_as_byte buf i = + let new_size = buf.bbCurrent + 1 in + ensure_bytebuf buf new_size; + set buf.bbArray buf.bbCurrent i; + buf.bbCurrent <- new_size + + let emit_byte buf (b:char) = emit_int_as_byte buf (int_of_char b) + let emit_bool_as_byte buf (b:bool) = emit_int_as_byte buf (if b then 1 else 0) + + let emit_bytes buf i = + let n = length i in + let new_size = buf.bbCurrent + n in + ensure_bytebuf buf new_size; + blit i 0 buf.bbArray buf.bbCurrent n; + buf.bbCurrent <- new_size + + let emit_i32_as_u16 buf n = + let new_size = buf.bbCurrent + 2 in + ensure_bytebuf buf new_size; + set buf.bbArray buf.bbCurrent (b0 n); + set buf.bbArray (buf.bbCurrent + 1) (b1 n); + buf.bbCurrent <- new_size + + (* let emit_u16 buf (x:uint16) = emit_i32_as_u16 buf (BatInt64.to_int x) *) + + let fixup_i32 bb pos n = + set bb.bbArray pos (b0 n); + set bb.bbArray (pos + 1) (b1 n); + set bb.bbArray (pos + 2) (b2 n); + set bb.bbArray (pos + 3) (b3 n) + + let emit_i32 buf n = + let new_size = buf.bbCurrent + 4 in + ensure_bytebuf buf new_size; + fixup_i32 buf buf.bbCurrent n; + buf.bbCurrent <- new_size + + let emit_i64 buf x = + emit_i32 buf (dWw0 x); + emit_i32 buf (dWw1 x) + + let emit_intarray_as_bytes buf arr = + let n = BatArray.length arr in + let new_size = buf.bbCurrent + n in + ensure_bytebuf buf new_size; + let bbarr = buf.bbArray in + let bbbase = buf.bbCurrent in + for i= 0 to n - 1 do set bbarr (bbbase + i) (BatArray.get arr i) done; + buf.bbCurrent <- new_size + + let length bb = bb.bbCurrent + let position bb = bb.bbCurrent + +end + +let create i = Bytebuf.create i +let close t = Bytebuf.close t +let emit_int_as_byte t i = Bytebuf.emit_int_as_byte t (Z.to_int i) +let emit_bytes t b = Bytebuf.emit_bytes t b + +let length x = Z.of_int (length x) diff --git a/ocaml/fstar-lib/FStar_Compiler_Effect.ml b/ocaml/fstar-lib/FStarC_Compiler_Effect.ml similarity index 100% rename from ocaml/fstar-lib/FStar_Compiler_Effect.ml rename to ocaml/fstar-lib/FStarC_Compiler_Effect.ml diff --git a/ocaml/fstar-lib/FStarC_Compiler_Hints.ml b/ocaml/fstar-lib/FStarC_Compiler_Hints.ml new file mode 100644 index 00000000000..85f40c7f926 --- /dev/null +++ b/ocaml/fstar-lib/FStarC_Compiler_Hints.ml @@ -0,0 +1,118 @@ +open FStarC_Json + +(** Hints. *) +type hint = { + hint_name:string; + hint_index:Z.t; + fuel:Z.t; + ifuel:Z.t; + unsat_core:string list option; + query_elapsed_time:Z.t; + hash:string option +} + +type hints = hint option list + +type hints_db = { + module_digest:string; + hints: hints +} + +type hints_read_result = + | HintsOK of hints_db + | MalformedJson + | UnableToOpen + +let write_hints (filename: string) (hints: hints_db): unit = + let json = `List [ + `String hints.module_digest; + `List (List.map (function + | None -> `Null + | Some { hint_name; hint_index; fuel; ifuel; unsat_core; query_elapsed_time; hash } -> + `List [ + `String hint_name; + `Int (Z.to_int hint_index); + `Int (Z.to_int fuel); + `Int (Z.to_int ifuel); + (match unsat_core with + | None -> `Null + | Some strings -> + `List (List.map (fun s -> `String s) strings)); + `Int (Z.to_int query_elapsed_time); + `String (match hash with | Some(h) -> h | _ -> "") + ] + ) hints.hints) + ] in + let channel = open_out_bin filename in + BatPervasives.finally + (fun () -> close_out channel) + (fun channel -> Yojson.Safe.pretty_to_channel channel json) + channel + +let read_hints (filename: string) : hints_read_result = + let mk_hint nm ix fuel ifuel unsat_core time hash_opt = { + hint_name = nm; + hint_index = Z.of_int ix; + fuel = Z.of_int fuel; + ifuel = Z.of_int ifuel; + unsat_core = begin + match unsat_core with + | `Null -> + None + | `List strings -> + Some (List.map (function + | `String s -> s + | _ -> raise Exit) + strings) + | _ -> + raise Exit + end; + query_elapsed_time = Z.of_int time; + hash = hash_opt + } + in + try + let chan = open_in filename in + let json = Yojson.Safe.from_channel chan in + close_in chan; + HintsOK ( + match json with + | `List [ + `String module_digest; + `List hints + ] -> { + module_digest; + hints = List.map (function + | `Null -> None + | `List [ `String hint_name; + `Int hint_index; + `Int fuel; + `Int ifuel; + unsat_core; + `Int query_elapsed_time ] -> + (* This case is for dealing with old-style hint files + that lack a query-hashes field. We should remove this + case once we definitively remove support for old hints *) + Some (mk_hint hint_name hint_index fuel ifuel unsat_core query_elapsed_time None) + | `List [ `String hint_name; + `Int hint_index; + `Int fuel; + `Int ifuel; + unsat_core; + `Int query_elapsed_time; + `String hash ] -> + let hash_opt = if hash <> "" then Some(hash) else None in + Some (mk_hint hint_name hint_index fuel ifuel unsat_core query_elapsed_time hash_opt) + | _ -> + raise Exit + ) hints + } + | _ -> + raise Exit + ) + with + | Exit -> + MalformedJson + | Sys_error _ -> + UnableToOpen + diff --git a/ocaml/fstar-lib/FStar_Compiler_List.ml b/ocaml/fstar-lib/FStarC_Compiler_List.ml similarity index 100% rename from ocaml/fstar-lib/FStar_Compiler_List.ml rename to ocaml/fstar-lib/FStarC_Compiler_List.ml diff --git a/ocaml/fstar-lib/FStar_Compiler_Plugins_Base.ml b/ocaml/fstar-lib/FStarC_Compiler_Plugins_Base.ml similarity index 100% rename from ocaml/fstar-lib/FStar_Compiler_Plugins_Base.ml rename to ocaml/fstar-lib/FStarC_Compiler_Plugins_Base.ml diff --git a/ocaml/fstar-lib/FStarC_Compiler_Range.ml b/ocaml/fstar-lib/FStarC_Compiler_Range.ml new file mode 100644 index 00000000000..7d3435eed24 --- /dev/null +++ b/ocaml/fstar-lib/FStarC_Compiler_Range.ml @@ -0,0 +1,2 @@ +include FStarC_Compiler_Range_Type +include FStarC_Compiler_Range_Ops diff --git a/ocaml/fstar-lib/FStar_Compiler_String.ml b/ocaml/fstar-lib/FStarC_Compiler_String.ml similarity index 100% rename from ocaml/fstar-lib/FStar_Compiler_String.ml rename to ocaml/fstar-lib/FStarC_Compiler_String.ml diff --git a/ocaml/fstar-lib/FStarC_Compiler_Util.ml b/ocaml/fstar-lib/FStarC_Compiler_Util.ml new file mode 100644 index 00000000000..a79418b5617 --- /dev/null +++ b/ocaml/fstar-lib/FStarC_Compiler_Util.ml @@ -0,0 +1,1165 @@ +open FStarC_Json + +let max_int = Z.of_int max_int +let is_letter c = if c > 255 then false else BatChar.is_letter (BatChar.chr c) +let is_digit c = if c > 255 then false else BatChar.is_digit (BatChar.chr c) +let is_letter_or_digit c = is_letter c || is_digit c +let is_symbol c = if c > 255 then false else BatChar.is_symbol (BatChar.chr c) + +(* Modeled after: Char.IsPunctuation in .NET + (http://www.dotnetperls.com/char-ispunctuation) +*) +let is_punctuation c = List.mem c [33; 34; 35; 37; 38; 39; 40; 41; 42; 44; 45; 46; 47; 58; 59; 63; 64; 91; 92; 93; 95; 123; 125] +(*'!','"','#','%','&','\'','(',')','*',',','-','.','/',':',';','?','@','[','\\',']','_','{','}'*) + +let return_all x = x + +type time = float +let now () = BatUnix.gettimeofday () +let now_ms () = Z.of_int (int_of_float (now () *. 1000.0)) +let time_diff (t1:time) (t2:time) : float * Prims.int = + let n = t2 -. t1 in + n, + Z.of_float (n *. 1000.0) +let record_time f = + let start = now () in + let res = f () in + let _, elapsed = time_diff start (now()) in + res, elapsed +let get_file_last_modification_time f = (BatUnix.stat f).BatUnix.st_mtime +let is_before t1 t2 = compare t1 t2 < 0 +let string_of_time = string_of_float + +exception Impos + +let cur_sigint_handler : Sys.signal_behavior ref = + ref Sys.Signal_default + +exception SigInt +type sigint_handler = Sys.signal_behavior + +let sigint_handler_f f = Sys.Signal_handle f + +let sigint_ignore: sigint_handler = + Sys.Signal_ignore + +let sigint_delay = ref 0 +let sigint_pending = ref false + +let raise_sigint _ = + sigint_pending := false; + raise SigInt + +let raise_sigint_maybe_delay _ = + (* This function should not do anything complicated, lest it cause deadlocks. + * Calling print_string, for example, can cause a deadlock (print_string → + * caml_flush → process_pending_signals → caml_execute_signal → raise_sigint → + * print_string → caml_io_mutex_lock ⇒ deadlock) *) + if !sigint_delay = 0 + then raise_sigint () + else sigint_pending := true + +let sigint_raise: sigint_handler = + Sys.Signal_handle raise_sigint_maybe_delay + +let get_sigint_handler () = + !cur_sigint_handler + +let set_sigint_handler sigint_handler = + cur_sigint_handler := sigint_handler; + Sys.set_signal Sys.sigint !cur_sigint_handler + +let with_sigint_handler handler f = + let original_handler = !cur_sigint_handler in + BatPervasives.finally + (fun () -> Sys.set_signal Sys.sigint original_handler) + (fun () -> set_sigint_handler handler; f ()) + () + +(* Re export this type, it's mentioned in the interface for this module. *) +type out_channel = Stdlib.out_channel + +let stderr = Stdlib.stderr +let stdout = Stdlib.stdout + +let open_file_for_writing (fn : string) = Stdlib.open_out_bin fn +let open_file_for_appending (fn : string) = Stdlib.open_out_gen [Open_append; Open_wronly; Open_creat; Open_binary] 0o644 fn +let close_out_channel (c : out_channel) = Stdlib.close_out c + +let flush (c:out_channel) : unit = Stdlib.flush c + +let append_to_file (c:out_channel) s = Printf.fprintf c "%s\n" s; flush c + +type proc = + {pid: int; + inc : in_channel; (* in == where we read from, so the process's stdout *) + errc : in_channel; (* the process's stderr *) + outc : out_channel; (* the process's stdin *) + mutable killed : bool; + stop_marker: (string -> bool) option; + id : string; + prog : string; + start_time : time} + +let all_procs : (proc list) ref = ref [] + +let lock () = () +let release () = () +let sleep n = Thread.delay ((Z.to_float n) /. 1000.) + +let mlock = Mutex.create () + +let monitor_enter _ = Mutex.lock mlock +let monitor_exit _ = Mutex.unlock mlock +let monitor_wait _ = () +let monitor_pulse _ = () +let current_tid _ = Z.zero + +let atomically f = (* This function only protects against signals *) + let finalizer () = + decr sigint_delay; + if !sigint_pending && !sigint_delay = 0 then + raise_sigint () in + let body f = + incr sigint_delay; f () in + BatPervasives.finally finalizer body f + +let with_monitor _ f x = atomically (fun () -> + monitor_enter (); + BatPervasives.finally monitor_exit f x) + +let spawn f = + let _ = Thread.create f () in () + +let stack_dump () = Printexc.raw_backtrace_to_string (Printexc.get_callstack 1000) + +(* On the OCaml side it would make more sense to take stop_marker in + ask_process, but the F# side isn't built that way *) +let start_process' + (id: string) (prog: string) (args: string list) + (stop_marker: (string -> bool) option) : proc = + let (stdin_r, stdin_w) = Unix.pipe () in + let (stdout_r, stdout_w) = Unix.pipe () in + let (stderr_r, stderr_w) = Unix.pipe () in + Unix.set_close_on_exec stdin_w; + Unix.set_close_on_exec stdout_r; + Unix.set_close_on_exec stderr_r; + let pid = Unix.create_process prog (Array.of_list (prog :: args)) stdin_r stdout_w stderr_w in + Unix.close stdin_r; + Unix.close stdout_w; + Unix.close stderr_w; + let proc = { pid = pid; + id = prog ^ ":" ^ id; + prog = prog; + inc = Unix.in_channel_of_descr stdout_r; + errc = Unix.in_channel_of_descr stderr_r; + outc = Unix.out_channel_of_descr stdin_w; + stop_marker = stop_marker; + killed = false; + start_time = now()} in + (* print_string ("Started process " ^ proc.id ^ "\n" ^ (stack_dump())); *) + all_procs := proc :: !all_procs; + proc + +let start_process + (id: string) (prog: string) (args: string list) + (stop_marker: string -> bool) : proc = + start_process' id prog args (Some stop_marker) + +let rec waitpid_ignore_signals pid = + try ignore (Unix.waitpid [] pid) + with Unix.Unix_error (Unix.EINTR, _, _) -> + waitpid_ignore_signals pid + +let kill_process (p: proc) = + if not p.killed then begin + (* Close the fds directly: close_in and close_out both call `flush`, + potentially forcing us to wait until p starts reading again. They + might have been closed already (e.g. `run_process`), so we + just `attempt` it. *) + let attempt f = + try f () with | _ -> () + in + attempt (fun () -> Unix.close (Unix.descr_of_in_channel p.inc)); + attempt (fun () -> Unix.close (Unix.descr_of_in_channel p.errc)); + attempt (fun () -> Unix.close (Unix.descr_of_out_channel p.outc)); + (try Unix.kill p.pid Sys.sigkill + with Unix.Unix_error (Unix.ESRCH, _, _) -> ()); + (* Avoid zombie processes (Unix.close_process does the same thing. *) + waitpid_ignore_signals p.pid; + (* print_string ("Killed process " ^ p.id ^ "\n" ^ (stack_dump())); *) + p.killed <- true + end + +let kill_all () = + BatList.iter kill_process !all_procs + +let proc_prog (p:proc) : string = p.prog + +let process_read_all_output (p: proc) = + (* Pass cleanup:false because kill_process closes both fds already. *) + BatIO.read_all (BatIO.input_channel ~autoclose:true ~cleanup:false p.inc) + + +let channel_read_all_nonblock (c: in_channel) : string = + let buffer = Bytes.create 8192 in + let fd = Unix.descr_of_in_channel c in + let rec aux (idx:int) (rem:int) = + if rem <= 0 then idx + else ( + let rd, _, _ = Unix.select [fd] [] [] 0.0 in + if rd = [] then idx + else ( + let n = Unix.read fd buffer idx rem in + if n <= 0 + then idx + else aux (idx+n) (rem-n) + ) + ) + in + let len = aux 0 1024 in + Bytes.sub_string buffer 0 len + +(** Feed `stdin` to `p`, and call `reader_fn` in a separate thread to read the + response. + + Signal handling makes this function fairly hairy. The usual design is to + launch a reader thread, then write to the process on the main thread and use + `Thread.join` to wait for the reader to complete. + + When we get a signal, Caml routes it to either of the threads. If it + reaches the reader thread, we're good: the reader thread is most likely + waiting in input_line at that point, and input_line polls for signals fairly + frequently. If the signal reaches the writer (main) thread, on the other + hand, we're toast: `Thread.join` isn't interruptible, so Caml will save the + signal until the child thread exits and `join` returns, and at that point the + Z3 query is complete and the signal is useless. + + There are three possible solutions to this problem: + 1. Use an interruptible version of Thread.join written in C + 2. Ensure that signals are always delivered to the reader thread + 3. Use a different synchronization mechanism between the reader and the writer. + + Option 1 is bad because building F* doesn't currently require a C compiler. + Option 2 is easy to implement with `Unix.sigprocmask`, but that isn't + available on Windows. Option 3 is what the code below does: it uses a pipe + and a 1-byte write as a way for the writer thread to wait on the reader + thread. That's why `reader_fn` is passed a `signal_exit` function. + + If a SIGINT reaches the reader, it should still call `signal_exit`. If + a SIGINT reaches the writer, it should make sure that the reader exits. + These two things are the responsibility of the caller of this function. **) + +let process_read_async p stdin reader_fn = + let fd_r, fd_w = Unix.pipe () in + BatPervasives.finally (fun () -> Unix.close fd_w; Unix.close fd_r) + (fun () -> + let wait_for_exit () = + ignore (Unix.read fd_r (Bytes.create 1) 0 1) in + let signal_exit () = + try ignore (Unix.write fd_w (Bytes.create 1) 0 1) + with (* ‘write’ will fail if called after the finalizer above *) + | Unix.Unix_error (Unix.EBADF, _, _) -> () in + + let write_input = function + | Some str -> output_string p.outc str; flush p.outc + | None -> () in + + (* In the following we can get a signal at any point; it's the caller's + responsibility to ensure that reader_fn will exit in that case *) + let t = Thread.create reader_fn signal_exit in + write_input stdin; + wait_for_exit (); + Thread.join t) () + +let run_process (id: string) (prog: string) (args: string list) (stdin: string option): string = + let p = start_process' id prog args None in + (match stdin with + | None -> () + | Some str -> + try output_string p.outc str with + | Sys_error _ -> () (* FIXME: check for "Broken pipe". In that case this is fine, process must have finished without reading input *) + | e -> raise e + ); + (try flush p.outc with | _ -> ()); (* only _attempt_ to flush, so we don't get an exception if the process is finished *) + (try close_out p.outc with | _ -> ()); (* idem *) + let s = process_read_all_output p in + kill_process p; + s + +let system_run (cmd:string) : Z.t = Z.of_int (Sys.command cmd) + +type read_result = EOF | SIGINT + +let handle_stderr (p:proc) (h : string -> unit) = + (* Read stderr and call the handler if anything is in there. *) + let se = channel_read_all_nonblock p.errc in + if se <> "" then + h (BatString.trim se) + +let ask_process + (p: proc) (stdin: string) + (exn_handler: unit -> string) + (stderr_handler : string -> unit) + : string = + let result = ref None in + let out = Buffer.create 16 in + let stop_marker = BatOption.default (fun s -> false) p.stop_marker in + + let reader_fn signal_fn = + let rec loop p out = + let line = BatString.trim (input_line p.inc) in (* raises EOF *) + if not (stop_marker line) then + (Buffer.add_string out (line ^ "\n"); loop p out) in + (try loop p out + with | SigInt -> result := Some SIGINT + | End_of_file -> result := Some EOF); + signal_fn () in + + try + (* Check stderr both before and after asking. Note: this does + * not handle the case when the process prints something to stderr + * and then hangs. We will stay in the process_read_async call without + * ever handling the output. To properly handle that, we could + * use a separate thread, but then all stderr_handler functions need + * to take locks. Since this is not a problem for now, we just avoid + * this complexity. *) + handle_stderr p stderr_handler; + process_read_async p (Some stdin) reader_fn; + handle_stderr p stderr_handler; + (match !result with + | Some EOF -> kill_process p; Buffer.add_string out (exn_handler ()) + | Some SIGINT -> raise SigInt + | None -> ()); + Buffer.contents out + with e -> (* Ensure that reader_fn gets an EOF and exits *) + kill_process p; raise e + +let get_file_extension (fn:string) : string = snd (BatString.rsplit fn ".") +let is_path_absolute path_str = + let open Batteries.Incubator in + let open BatPathGen.OfString in + let path_str' = of_string path_str in + is_absolute path_str' +let join_paths path_str0 path_str1 = + let open Batteries.Incubator in + let open BatPathGen.OfString in + let open BatPathGen.OfString.Operators in + to_string ((of_string path_str0) //@ (of_string path_str1)) + +let normalize_file_path (path_str:string) = + let open Batteries.Incubator in + let open BatPathGen.OfString in + let open BatPathGen.OfString.Operators in + to_string + (normalize_in_tree + (let path = of_string path_str in + if is_absolute path then + path + else + let pwd = of_string (BatSys.getcwd ()) in + pwd //@ path)) + +type stream_reader = BatIO.input +let open_stdin () = BatIO.stdin +let read_line s = + try + Some (BatIO.read_line s) + with + _ -> None +let nread (s:stream_reader) (n:Z.t) = + try + Some (BatIO.nread s (Z.to_int n)) + with + _ -> None + +let poll_stdin (f:float) = + try + let ready_fds, _, _ = Unix.select [Unix.stdin] [] [] f in + match ready_fds with + | [] -> false + | _ -> true + with + | _ -> false + +type string_builder = BatBuffer.t +let new_string_builder () = BatBuffer.create 256 +let clear_string_builder b = BatBuffer.clear b +let string_of_string_builder b = BatBuffer.contents b +let string_builder_append b s = BatBuffer.add_string b s + +let message_of_exn (e:exn) = Printexc.to_string e +let trace_of_exn (e:exn) = Printexc.get_backtrace () + +module StringOps = + struct + type t = string + let equal (x:t) (y:t) = x=y + let compare (x:t) (y:t) = BatString.compare x y + let hash (x:t) = BatHashtbl.hash x + end + +module StringHashtbl = BatHashtbl.Make(StringOps) +module StringMap = BatMap.Make(StringOps) + +type 'value smap = 'value StringHashtbl.t +let smap_create (i:Z.t) : 'value smap = StringHashtbl.create (Z.to_int i) +let smap_clear (s:('value smap)) = StringHashtbl.clear s +let smap_add (m:'value smap) k (v:'value) = StringHashtbl.replace m k v +let smap_of_list (l: (string * 'value) list) = + let s = StringHashtbl.create (BatList.length l) in + FStar_List.iter (fun (x,y) -> smap_add s x y) l; + s +let smap_try_find (m:'value smap) k = StringHashtbl.find_option m k +let smap_fold (m:'value smap) f a = StringHashtbl.fold f m a +let smap_remove (m:'value smap) k = StringHashtbl.remove m k +let smap_keys (m:'value smap) = smap_fold m (fun k _ acc -> k::acc) [] +let smap_copy (m:'value smap) = StringHashtbl.copy m +let smap_size (m:'value smap) = StringHashtbl.length m +let smap_iter (m:'value smap) f = StringHashtbl.iter f m + +exception PSMap_Found +type 'value psmap = 'value StringMap.t +let psmap_empty (_: unit) : 'value psmap = StringMap.empty +let psmap_add (map: 'value psmap) (key: string) (value: 'value) = StringMap.add key value map +let psmap_find_default (map: 'value psmap) (key: string) (dflt: 'value) = + StringMap.find_default dflt key map +let psmap_try_find (map: 'value psmap) (key: string) = + StringMap.Exceptionless.find key map +let psmap_fold (m:'value psmap) f a = StringMap.fold f m a +let psmap_find_map (m:'value psmap) f = + let res = ref None in + let upd k v = + let r = f k v in + if r <> None then (res := r; raise PSMap_Found) in + (try StringMap.iter upd m with PSMap_Found -> ()); + !res +let psmap_modify (m: 'value psmap) (k: string) (upd: 'value option -> 'value) = + StringMap.modify_opt k (fun vopt -> Some (upd vopt)) m + +let psmap_merge (m1: 'value psmap) (m2: 'value psmap) : 'value psmap = + psmap_fold m1 (fun k v m -> psmap_add m k v) m2 + +let psmap_remove (m: 'value psmap) (key:string) + : 'value psmap = StringMap.remove key m + +module ZHashtbl = BatHashtbl.Make(Z) +module ZMap = BatMap.Make(Z) + +type 'value imap = 'value ZHashtbl.t +let imap_create (i:Z.t) : 'value imap = ZHashtbl.create (Z.to_int i) +let imap_clear (s:('value imap)) = ZHashtbl.clear s +let imap_add (m:'value imap) k (v:'value) = ZHashtbl.replace m k v +let imap_of_list (l: (Z.t * 'value) list) = + let s = ZHashtbl.create (BatList.length l) in + FStar_List.iter (fun (x,y) -> imap_add s x y) l; + s +let imap_try_find (m:'value imap) k = ZHashtbl.find_option m k +let imap_fold (m:'value imap) f a = ZHashtbl.fold f m a +let imap_remove (m:'value imap) k = ZHashtbl.remove m k +let imap_keys (m:'value imap) = imap_fold m (fun k _ acc -> k::acc) [] +let imap_copy (m:'value imap) = ZHashtbl.copy m + +type 'value pimap = 'value ZMap.t +let pimap_empty (_: unit) : 'value pimap = ZMap.empty +let pimap_add (map: 'value pimap) (key: Z.t) (value: 'value) = ZMap.add key value map +let pimap_find_default (map: 'value pimap) (key: Z.t) (dflt: 'value) = + ZMap.find_default dflt key map +let pimap_try_find (map: 'value pimap) (key: Z.t) = + ZMap.Exceptionless.find key map +let pimap_fold (m:'value pimap) f a = ZMap.fold f m a + +(* restore pre-2.11 BatString.nsplit behavior, + see https://github.com/ocaml-batteries-team/batteries-included/issues/845 *) +let batstring_nsplit s t = + if s = "" then [] else BatString.split_on_string t s + +let format (fmt:string) (args:string list) = + let frags = batstring_nsplit fmt "%s" in + if BatList.length frags <> BatList.length args + 1 then + failwith ("Not enough arguments to format string " ^fmt^ " : expected " ^ (Stdlib.string_of_int (BatList.length frags)) ^ " got [" ^ (BatString.concat ", " args) ^ "] frags are [" ^ (BatString.concat ", " frags) ^ "]") + else + let sbldr = new_string_builder () in + string_builder_append sbldr (List.hd frags); + BatList.iter2 + (fun frag arg -> string_builder_append sbldr arg; + string_builder_append sbldr frag) + (List.tl frags) args; + string_of_string_builder sbldr + +let format1 f a = format f [a] +let format2 f a b = format f [a;b] +let format3 f a b c = format f [a;b;c] +let format4 f a b c d = format f [a;b;c;d] +let format5 f a b c d e = format f [a;b;c;d;e] +let format6 f a b c d e g = format f [a;b;c;d;e;g] + +let flush_stdout () = flush stdout + +let stdout_isatty () = Some (Unix.isatty Unix.stdout) + +(* NOTE: this is deciding whether or not to color by looking + at stdout_isatty(), which may be a wrong choice if + we're instead outputting to stderr. e.g. + fstar.exe Blah.fst 2>errlog + will colorize the errors in the file if stdout is not + also redirected. +*) +let colorize s colors = + match colors with + | (c1,c2) -> + match stdout_isatty () with + | Some true -> format3 "%s%s%s" c1 s c2 + | _ -> s + +let colorize_bold s = + match stdout_isatty () with + | Some true -> format3 "%s%s%s" "\x1b[39;1m" s "\x1b[0m" + | _ -> s + +let colorize_red s = + match stdout_isatty () with + | Some true -> format3 "%s%s%s" "\x1b[31;1m" s "\x1b[0m" + | _ -> s + +let colorize_yellow s = + match stdout_isatty () with + | Some true -> format3 "%s%s%s" "\x1b[33;1m" s "\x1b[0m" + | _ -> s + +let colorize_cyan s = + match stdout_isatty () with + | Some true -> format3 "%s%s%s" "\x1b[36;1m" s "\x1b[0m" + | _ -> s + +let colorize_green s = + match stdout_isatty () with + | Some true -> format3 "%s%s%s" "\x1b[32;1m" s "\x1b[0m" + | _ -> s + +let colorize_magenta s = + match stdout_isatty () with + | Some true -> format3 "%s%s%s" "\x1b[35;1m" s "\x1b[0m" + | _ -> s + +let pr = Printf.printf +let spr = Printf.sprintf +let fpr = Printf.fprintf + +type printer = { + printer_prinfo: string -> unit; + printer_prwarning: string -> unit; + printer_prerror: string -> unit; + printer_prgeneric: string -> (unit -> string) -> (unit -> json) -> unit +} + +let default_printer = + { printer_prinfo = (fun s -> pr "%s" s; flush stdout); + printer_prwarning = (fun s -> fpr stderr "%s" (colorize_yellow s); flush stdout; flush stderr); + printer_prerror = (fun s -> fpr stderr "%s" (colorize_red s); flush stdout; flush stderr); + printer_prgeneric = fun label get_string get_json -> pr "%s: %s" label (get_string ())} + +let current_printer = ref default_printer +let set_printer printer = current_printer := printer + +let print_raw s = set_binary_mode_out stdout true; pr "%s" s; flush stdout +let print_string s = (!current_printer).printer_prinfo s +let print_generic label to_string to_json a = (!current_printer).printer_prgeneric label (fun () -> to_string a) (fun () -> to_json a) +let print_any s = (!current_printer).printer_prinfo (Marshal.to_string s []) +let strcat s1 s2 = s1 ^ s2 +let concat_l sep (l:string list) = BatString.concat sep l + +let string_of_unicode (bytes:int array) = + BatArray.fold_left (fun acc b -> acc^(BatUTF8.init 1 (fun _ -> BatUChar.of_int b))) "" bytes +let unicode_of_string (string:string) = + let n = BatUTF8.length string in + let t = Array.make n 0 in + let i = ref 0 in + BatUTF8.iter (fun c -> t.(!i) <- BatUChar.code c; incr i) string; + t +let base64_encode s = BatBase64.str_encode s +let base64_decode s = BatBase64.str_decode s +let char_of_int i = Z.to_int i +let int_of_string = Z.of_string +let safe_int_of_string x = + if x = "" then None else + try Some (int_of_string x) with Invalid_argument _ -> None +let int_of_char x = Z.of_int x +let int_of_byte x = x +let int_of_uint8 x = Z.of_int (Char.code x) +let uint16_of_int i = Z.to_int i +let byte_of_char c = c + +let float_of_string s = float_of_string s +let float_of_byte b = float_of_int (Char.code b) +let float_of_int32 = float_of_int +let float_of_int64 = BatInt64.to_float + +let int_of_int32 i = i +let int32_of_int i = BatInt32.of_int i + +let string_of_int = Z.to_string +let string_of_bool = string_of_bool +let string_of_int32 = BatInt32.to_string +let string_of_int64 = BatInt64.to_string +let string_of_float = string_of_float +let string_of_char i = BatUTF8.init 1 (fun _ -> BatUChar.chr i) +let hex_string_of_byte (i:int) = + let hs = spr "%x" i in + if (String.length hs = 1) then "0" ^ hs + else hs +let string_of_bytes = string_of_unicode +let bytes_of_string = unicode_of_string +let starts_with = BatString.starts_with +let trim_string = BatString.trim +let ends_with = BatString.ends_with +let char_at s index = BatUChar.code (BatUTF8.get s (Z.to_int index)) +let is_upper c = 65 <= c && c <= 90 +let contains (s1:string) (s2:string) = BatString.exists s1 s2 +let substring_from s index = BatString.tail s (Z.to_int index) +let substring s i j = BatString.sub s (Z.to_int i) (Z.to_int j) +let replace_char (s:string) c1 c2 = + let c1, c2 = BatUChar.chr c1, BatUChar.chr c2 in + BatUTF8.map (fun x -> if x = c1 then c2 else x) s +let replace_chars (s:string) c (by:string) = + BatString.replace_chars (fun x -> if x = Char.chr c then by else BatString.of_char x) s +let hashcode s = Z.of_int (StringOps.hash s) +let compare s1 s2 = Z.of_int (BatString.compare s1 s2) +let split s sep = BatString.split_on_string sep s +let splitlines s = split s "\n" + +let iof = int_of_float +let foi = float_of_int + +let print1 a b = print_string (format1 a b) +let print2 a b c = print_string (format2 a b c) +let print3 a b c d = print_string (format3 a b c d) +let print4 a b c d e = print_string (format4 a b c d e) +let print5 a b c d e f = print_string (format5 a b c d e f) +let print6 a b c d e f g = print_string (format6 a b c d e f g) +let print fmt args = print_string (format fmt args) + +let print_error s = (!current_printer).printer_prerror s +let print1_error a b = print_error (format1 a b) +let print2_error a b c = print_error (format2 a b c) +let print3_error a b c d = print_error (format3 a b c d) + +let print_warning s = (!current_printer).printer_prwarning s +let print1_warning a b = print_warning (format1 a b) +let print2_warning a b c = print_warning (format2 a b c) +let print3_warning a b c d = print_warning (format3 a b c d) + +let fprint (oc:out_channel) fmt args : unit = Printf.fprintf oc "%s" (format fmt args) + +[@@deriving yojson,show] + +let is_left = function + | FStar_Pervasives.Inl _ -> true + | _ -> false + +let is_right = function + | FStar_Pervasives.Inr _ -> true + | _ -> false + +let left = function + | FStar_Pervasives.Inl x -> x + | _ -> failwith "Not in left" +let right = function + | FStar_Pervasives.Inr x -> x + | _ -> failwith "Not in right" + +let (-<-) f g x = f (g x) + +let find_dup f l = + let rec aux = function + | hd::tl -> + let hds, tl' = BatList.partition (f hd) tl in + (match hds with + | [] -> aux tl' + | _ -> Some hd) + | _ -> None in + aux l + +let nodups f l = match find_dup f l with | None -> true | _ -> false + +let remove_dups f l = + let rec aux out = function + | hd::tl -> let _, tl' = BatList.partition (f hd) tl in aux (hd::out) tl' + | _ -> out in + aux [] l + +let is_none = function + | None -> true + | Some _ -> false + +let is_some = function + | None -> false + | Some _ -> true + +let must = function + | Some x -> x + | None -> failwith "Empty option" + +let dflt x = function + | None -> x + | Some x -> x + +let find_opt f l = + let rec aux = function + | [] -> None + | hd::tl -> if f hd then Some hd else aux tl in + aux l + +(* JP: why so many duplicates? :'( *) +let sort_with = FStar_List.sortWith + +let bind_opt opt f = + match opt with + | None -> None + | Some x -> f x + +let catch_opt opt f = + match opt with + | Some x -> opt + | None -> f () + +let map_opt opt f = + match opt with + | None -> None + | Some x -> Some (f x) + +let iter_opt opt f = + ignore (map_opt opt f) + +let rec find_map l f = + match l with + | [] -> None + | x::tl -> + match f x with + | None -> find_map tl f + | y -> y + +let try_find f l = BatList.find_opt f l + +let try_find_index f l = + let rec aux i = function + | [] -> None + | hd::tl -> if f hd then Some (Z.of_int i) else aux (i+1) tl in + aux 0 l + +let fold_map f state s = + let fold (state, acc) x = + let state, v = f state x in (state, v :: acc) in + let (state, rs) = BatList.fold_left fold (state, []) s in + (state, BatList.rev rs) + +let choose_map f state s = + let fold (state, acc) x = + match f state x with + | state, None -> (state, acc) + | state, Some v -> (state, v :: acc) in + let (state, rs) = BatList.fold_left fold (state, []) s in + (state, BatList.rev rs) + +let for_all f l = BatList.for_all f l +let for_some f l = BatList.exists f l +let forall_exists rel l1 l2 = + for_all (fun x -> for_some (rel x) l2) l1 +let multiset_equiv rel l1 l2 = + BatList.length l1 = BatList.length l2 && forall_exists rel l1 l2 +let take p l = + let rec take_aux acc = function + | [] -> l, [] + | x::xs when p x -> take_aux (x::acc) xs + | x::xs -> List.rev acc, x::xs + in take_aux [] l + +let rec fold_flatten f acc l = + match l with + | [] -> acc + | x :: xs -> let acc, xs' = f acc x in fold_flatten f acc (xs' @ xs) + +let add_unique f x l = + if for_some (f x) l then + l + else + x::l + +let first_N n l = + let n = Z.to_int n in + let rec f acc i l = + if i = n then BatList.rev acc,l else + match l with + | h::tl -> f (h::acc) (i+1) tl + | _ -> failwith "firstN" + in + f [] 0 l + +let nth_tail n l = + let rec aux n l = + if n=0 then l else aux (n - 1) (BatList.tl l) + in + aux (Z.to_int n) l + +let prefix l = + match BatList.rev l with + | hd::tl -> BatList.rev tl, hd + | _ -> failwith "impossible" + +let prefix_until f l = + let rec aux prefix = function + | [] -> None + | hd::tl -> + if f hd then Some (BatList.rev prefix, hd, tl) + else aux (hd::prefix) tl in + aux [] l + +let string_to_ascii_bytes (s:string) : char array = + BatArray.of_list (BatString.explode s) +let ascii_bytes_to_string (b:char array) : string = + BatString.implode (BatArray.to_list b) +let mk_ref a = FStar_ST.alloc a + +let write_file (fn:string) s = + let fh = open_file_for_writing fn in + append_to_file fh s; + close_out_channel fh + +let copy_file input_name output_name = + (* see https://ocaml.github.io/ocamlunix/ocamlunix.html#sec33 *) + let open Unix in + let buffer_size = 8192 in + let buffer = Bytes.create buffer_size in + let fd_in = openfile input_name [O_RDONLY] 0 in + let fd_out = openfile output_name [O_WRONLY; O_CREAT; O_TRUNC] 0o666 in + let rec copy_loop () = + match read fd_in buffer 0 buffer_size with + | 0 -> () + | r -> ignore (write fd_out buffer 0 r); copy_loop () + in + copy_loop (); + close fd_in; + close fd_out +let delete_file (fn:string) = Sys.remove fn +let file_get_contents f = + let ic = open_in_bin f in + let l = in_channel_length ic in + let s = really_input_string ic l in + close_in ic; + s +let file_get_lines f = + let ic = open_in f in + let rec aux accu = + let l = + try + Some (input_line ic) + with + | End_of_file -> None + in + match l with + | None -> accu + | Some l -> aux (l::accu) + in + let l = aux [] in + close_in ic; + List.rev l +let concat_dir_filename d f = Filename.concat d f + +let slash_code : int = + BatUChar.code (BatUChar.of_char '/') + +let rec dropWhile f xs = + match xs with + | [] -> [] + | x::xs -> + if f x + then dropWhile f xs + else x::xs + +let path_parent (fn : string) : string = + let cs = FStar_String.split [slash_code] fn in + (* ^ Components of the path *) + let cs = cs |> List.rev |> dropWhile (fun s -> s = "") |> List.rev in + (* ^ Remove empty trailing components, so we interpret a/b/c/ as a/b/c *) + (* Remove last component to get parent and concat. *) + FStar_String.concat "/" (FStar_List.init cs) + +let rec __mkdir clean mkparents nm = + let remove_all_in_dir nm = + let open Sys in + Array.iter remove (Array.map (concat_dir_filename nm) (readdir nm)) in + let open Unix in + (match Sys.os_type with + | "Unix" -> ignore (umask 0o002) + | _ -> (* unimplemented*) ()); + try Unix.mkdir nm 0o777 + with + | Unix_error (EEXIST, _, _) -> + if clean then remove_all_in_dir nm + + (* failed due to nonexisting directory, mkparents is true, and nm has a slash: + attempt to recursively create parent and retry. *) + | Unix_error (ENOENT, _, _) when mkparents && FStar_String.index_of nm slash_code <> (Z.of_int (-1)) -> + __mkdir false true (path_parent nm); + Unix.mkdir nm 0o777 + +let mkdir = __mkdir + +let for_range lo hi f = + for i = Z.to_int lo to Z.to_int hi do + f (Z.of_int i) + done + + +let incr r = FStar_ST.(Z.(write r (read r + one))) +let decr r = FStar_ST.(Z.(write r (read r - one))) +let geq (i:int) (j:int) = i >= j + +let exec_name = Sys.executable_name +let get_exec_dir () = Filename.dirname (Sys.executable_name) +let get_cmd_args () = Array.to_list Sys.argv +let expand_environment_variable x = try Some (Sys.getenv x) with Not_found -> None + +let physical_equality (x:'a) (y:'a) = x == y +let check_sharing a b msg = if physical_equality a b then print1 "Sharing OK: %s\n" msg else print1 "Sharing broken in %s\n" msg + +type oWriter = { + write_byte: char -> unit; + write_bool: bool -> unit; + write_int: int -> unit; + write_int32: int32 -> unit; + write_int64: int64 -> unit; + write_char: char -> unit; + write_double: float -> unit; + write_bytearray: char array -> unit; + write_string: string -> unit; + + close: unit -> unit +} + +type oReader = { + read_byte: unit -> char; + read_bool: unit -> bool; + read_int: unit -> int; + read_int32: unit -> int32; + read_int64: unit -> int64; + read_char: unit -> char; + read_double: unit -> float; + read_bytearray: unit -> char array; + read_string: unit -> string; + + close: unit -> unit +} + +module MkoReader = struct + let read_byte r x = r.read_byte x + let read_bool r x = r.read_bool x + let read_int r x = r.read_int32 x + let read_int32 r x = r.read_int32 x + let read_int64 r x = r.read_int64 x + let read_char r x = r.read_char x + let read_double r x = r.read_double x + let read_bytearray r x = r.read_bytearray x + let read_string r x = r.read_string x + + let close r x = r.close x +end + +module MkoWriter = struct + let write_byte w x = w.write_byte x + let write_bool w x = w.write_bool x + let write_int w x = w.write_int32 x + let write_int32 w x = w.write_int32 x + let write_int64 w x = w.write_int64 x + let write_char w x = w.write_char x + let write_double w x = w.write_double x + let write_bytearray w x = w.write_bytearray x + let write_string w x = w.write_string x + + let close w x = w.close x +end + +(* + * TODO: these functions need to be filled in + *) +let get_owriter (filename:string) : oWriter = { + write_byte = (fun _ -> ()); + write_bool = (fun _ -> ()); + write_int = (fun _ -> ()); + write_int32 = (fun _ -> ()); + write_int64 = (fun _ -> ()); + write_char = (fun _ -> ()); + write_double = (fun _ -> ()); + write_bytearray = (fun _ -> ()); + write_string = (fun _ -> ()); + + close = (fun _ -> ()); +} + +let get_oreader (filename:string) : oReader = { + read_byte = (fun _ -> 'a'); + read_bool = (fun _ -> true); + read_int = (fun _ -> 0); + read_int32 = (fun _ -> failwith "NYI"); + read_int64 = (fun _ -> 0L); + read_char = (fun _ -> 'a'); + read_double = (fun _ -> 0.0); + read_bytearray = (fun _ -> [||]); + read_string = (fun _ -> ""); + + close = (fun _ -> ()); +} + +let getcwd = Sys.getcwd + +let readdir dir = "." :: ".." :: Array.to_list (Sys.readdir dir) + +let paths_to_same_file f g = + let open Unix in + let { st_dev = i; st_ino = j } = stat f in + let { st_dev = i'; st_ino = j' } = stat g in + (i,j) = (i',j') + +let file_exists = Sys.file_exists +(* Sys.is_directory raises Sys_error if the path does not exist *) +let is_directory f = Sys.file_exists f && Sys.is_directory f + + +let basename = Filename.basename +let dirname = Filename.dirname +let print_endline = print_endline + +let map_option f opt = BatOption.map f opt + +let save_value_to_file (fname:string) value = + (* BatFile.with_file_out uses Unix.openfile (which isn't available in + js_of_ocaml) instead of Pervasives.open_out, so we don't use it here. *) + let channel = open_out_bin fname in + BatPervasives.finally + (fun () -> close_out channel) + (fun channel -> output_value channel value) + channel + +let load_value_from_file (fname:string) = + (* BatFile.with_file_in uses Unix.openfile (which isn't available in + js_of_ocaml) instead of Pervasives.open_in, so we don't use it here. *) + try + let channel = open_in_bin fname in + BatPervasives.finally + (fun () -> close_in channel) + (fun channel -> Some (input_value channel)) + channel + with | _ -> None + +let save_2values_to_file (fname:string) value1 value2 = + try + let channel = open_out_bin fname in + BatPervasives.finally + (fun () -> close_out channel) + (fun channel -> + output_value channel value1; + output_value channel value2) + channel + with + | e -> delete_file fname; + raise e + +let load_2values_from_file (fname:string) = + try + let channel = open_in_bin fname in + BatPervasives.finally + (fun () -> close_in channel) + (fun channel -> + let v1 = input_value channel in + let v2 = input_value channel in + Some (v1, v2)) + channel + with | _ -> None + +let print_exn e = + Printexc.to_string e + +let digest_of_file = + let cache = smap_create (Z.of_int 101) in + fun (fname:string) -> + match smap_try_find cache fname with + | Some dig -> dig + | None -> + let dig = BatDigest.file fname in + smap_add cache fname dig; + dig + +let digest_of_string (s:string) = + BatDigest.to_hex (BatDigest.string s) + +(* Precondition: file exists *) +let touch_file (fname:string) : unit = + (* Sets access and modification times to current time *) + Unix.utimes fname 0.0 0.0 + +let ensure_decimal s = Z.to_string (Z.of_string s) + +let measure_execution_time tag f = + let t = Sys.time () in + let retv = f () in + print2 "Execution time of %s: %s ms\n" tag (string_of_float (1000.0 *. (Sys.time() -. t))); + retv + +let return_execution_time f = + let t1 = Sys.time () in + let retv = f () in + let t2 = Sys.time () in + (retv, 1000.0 *. (t2 -. t1)) + +(* Outside of this file the reference to FStar_Util.ref must use the following combinators *) +(* Export it at the end of the file so that we don't break other internal uses of ref *) +type 'a ref = 'a FStar_Monotonic_Heap.ref +let read = FStar_ST.read +let write = FStar_ST.write +let (!) = FStar_ST.read +let (:=) = FStar_ST.write + +let marshal (x:'a) : string = Marshal.to_string x [] +let unmarshal (x:string) : 'a = Marshal.from_string x 0 + +type signedness = | Unsigned | Signed +type width = | Int8 | Int16 | Int32 | Int64 + +let rec z_pow2 n = + if n = Z.zero then Z.one + else Z.mul (Z.of_string "2") (z_pow2 (Z.sub n Z.one)) + +let bounds signedness width = + let n = + match width with + | Int8 -> Z.of_string "8" + | Int16 -> Z.of_string "16" + | Int32 -> Z.of_string "32" + | Int64 -> Z.of_string "64" + in + let lower, upper = + match signedness with + | Unsigned -> + Z.zero, Z.sub (z_pow2 n) Z.one + | Signed -> + let upper = z_pow2 (Z.sub n Z.one) in + Z.neg upper, Z.sub upper Z.one + in + lower, upper + +let within_bounds repr signedness width = + let lower, upper = bounds signedness width in + let value = Z.of_string (ensure_decimal repr) in + Z.leq lower value && Z.leq value upper + +let print_array (f: 'a -> string) + (s: 'a array) + : string + = let ls = Array.fold_left (fun out a -> f a :: out) [] s in + format1 "[| %s |]" (String.concat "; " (List.rev ls)) + +let array_of_list (l:'a list) = FStar_ImmutableArray_Base.of_list l + +let array_length (l:'a FStar_ImmutableArray_Base.t) = FStar_ImmutableArray_Base.length l + +let array_index (l:'a FStar_ImmutableArray_Base.t) (i:Z.t) = FStar_ImmutableArray_Base.index l i diff --git a/ocaml/fstar-lib/FStar_Dyn.ml b/ocaml/fstar-lib/FStarC_Dyn.ml similarity index 100% rename from ocaml/fstar-lib/FStar_Dyn.ml rename to ocaml/fstar-lib/FStarC_Dyn.ml diff --git a/ocaml/fstar-lib/FStarC_Extraction_ML_PrintML.ml b/ocaml/fstar-lib/FStarC_Extraction_ML_PrintML.ml new file mode 100644 index 00000000000..b83f5ce0ab2 --- /dev/null +++ b/ocaml/fstar-lib/FStarC_Extraction_ML_PrintML.ml @@ -0,0 +1,544 @@ +open List +open Lexing +open Ppxlib_ast +open Astlib.Ast_500.Parsetree +open Location +open Pprintast +open Ast_helper +open Astlib.Ast_500.Asttypes +open Longident + +open FStarC_Extraction_ML_Syntax + +(* Global state used for the name of the ML module being pprinted. + current_module is only set once in build_ast and read once in + path_to_ident. This is done in order to avoid clutter. *) +let current_module = ref "" + + +let flatmap f l = map f l |> List.flatten +let opt_to_list = function Some x -> [x] | None -> [] + + +let no_position : Lexing.position = + {pos_fname = ""; pos_lnum = 0; pos_bol = 0; pos_cnum = 0} + +let no_location : Location.t = + {loc_start = no_position; loc_end = no_position; loc_ghost = false} + +let no_attrs: attributes = [] + + +(* functions for generating names and paths *) +let mk_sym s: string Location.loc = {txt=s; loc=no_location} + +let mk_sym_lident s: Longident.t Location.loc = {txt=s; loc=no_location} + +let mk_lident name = Lident name |> mk_sym_lident + +let mk_typ_name s = + (* remove an apostrophe from beginning of type name *) + match (BatString.sub s 0 1) with + | "'" -> BatString.tail s 1 + | _ -> s + +let rec path_to_string ((l, sym): mlpath): string = + match l with + | [] -> sym + | (hd::tl) -> BatString.concat "_" [hd; path_to_string (tl, sym)] + +let split_path (l1: string list) (l2: string list): (string list * string list) option = + let rec split_aux l1 l2 = + match l2 with + | [] -> Some l1 + | hd2::tl2 when BatString.equal hd2 (hd l1) -> split_aux (tl l1) tl2 + | _ -> None + in + if (length l1 >= length l2) then + match split_aux l1 l2 with + | None -> None + | Some l1' -> Some (l1', l2) + else None + +let path_to_ident ((l, sym): mlpath): Longident.t Asttypes.loc = + let codegen_libs = FStarC_Options.codegen_libs() in + match l with + | [] -> mk_lident sym + | hd::tl -> + let m_name = !current_module in + let suffix, prefix = + try BatList.find_map (split_path l) codegen_libs with + | Not_found -> l, [] + in + let path_abbrev = BatString.concat "_" suffix in + if (prefix = [] && BatString.equal m_name path_abbrev) then + (* remove circular references *) + mk_lident sym + else + match prefix with + | [] -> Ldot(Lident path_abbrev, sym) |> mk_sym_lident + | p_hd::p_tl -> + let q = fold_left (fun x y -> Ldot (x,y)) (Lident p_hd) p_tl in + (match path_abbrev with + | "" -> Ldot(q, sym) |> mk_sym_lident + | _ -> Ldot(Ldot(q, path_abbrev), sym) |> mk_sym_lident) + +let mk_top_mllb (e: mlexpr): mllb = + {mllb_name="_"; + mllb_tysc=None; + mllb_add_unit=false; + mllb_def=e; + mllb_meta=[]; + mllb_attrs=[]; + print_typ=false } + +(* Find the try_with in the default effect module. For instance this can be +FStar.All.try_with (for most users) or FStarC.Compiler.Effect.try_with (during +bootstrapping with "--MLish --MLish_effect FStarC.Compiler.Effect"). *) +let try_with_ident () = + let lid = FStarC_Parser_Const.try_with_lid () in + let ns = FStarC_Ident.ns_of_lid lid in + let id = FStarC_Ident.ident_of_lid lid in + path_to_ident (List.map FStarC_Ident.string_of_id ns, FStarC_Ident.string_of_id id) + +(* For integer constants (not 0/1) in this range we will use Prims.of_int + * Outside this range we will use string parsing to allow arbitrary sized + * integers. + * Using int_zero/int_one removes int processing to create the Z.t + * Using of_int removes string processing to create the Z.t + *) +let max_of_int_const = Z.of_int 65535 +let min_of_int_const = Z.of_int (-65536) + +(* mapping functions from F* ML AST to Parsetree *) +let build_constant (c: mlconstant): Parsetree.constant = + let stdint_module (s:FStarC_Const.signedness) (w:FStarC_Const.width) : string = + let sign = match s with + | FStarC_Const.Signed -> "Int" + | FStarC_Const.Unsigned -> "Uint" in + let with_w ws = BatString.concat "" ["Stdint."; sign; ws] in + match w with + | FStarC_Const.Int8 -> with_w "8" + | FStarC_Const.Int16 -> with_w "16" + | FStarC_Const.Int32 -> with_w "32" + | FStarC_Const.Int64 -> with_w "64" + | FStarC_Const.Sizet -> with_w "64" in + match c with + | MLC_Int (v, None) -> + let s = match Z.of_string v with + | x when x = Z.zero -> "Prims.int_zero" + | x when x = Z.one -> "Prims.int_one" + | x when (min_of_int_const < x) && (x < max_of_int_const) -> + BatString.concat v ["(Prims.of_int ("; "))"] + | x -> + BatString.concat v ["(Prims.parse_int \""; "\")"] in + Const.integer s + (* Special case for UInt8, as it's realized as OCaml built-in int type *) + | MLC_Int (v, Some (FStarC_Const.Unsigned, FStarC_Const.Int8)) -> + Const.integer v + | MLC_Int (v, Some (s, w)) -> + let s = match Z.of_string v with + | x when x = Z.zero -> + BatString.concat "" [stdint_module s w; ".zero"] + | x when x = Z.one -> + BatString.concat "" [stdint_module s w; ".one"] + | x when (min_of_int_const < x) && (x < max_of_int_const) -> + BatString.concat "" ["("; stdint_module s w; ".of_int ("; v; "))"] + | x -> + BatString.concat "" ["("; stdint_module s w; ".of_string \""; v; "\")"] in + Const.integer s + | MLC_Float v -> Const.float (string_of_float v) + | MLC_Char v -> Const.int v + | MLC_String v -> Const.string v + | MLC_Bytes _ -> failwith "Case not handled" (* do we need this? *) + | _ -> failwith "Case not handled" + +let build_constant_expr (c: mlconstant): expression = + match c with + | MLC_Unit -> Exp.construct (mk_lident "()") None + | MLC_Bool b -> + let id = if b then "true" else "false" in + Exp.construct (mk_lident id) None + | _ -> Exp.constant (build_constant c) + +let build_constant_pat (c: mlconstant): pattern_desc = + match c with + | MLC_Unit -> Ppat_construct (mk_lident "()", None) + | MLC_Bool b -> + let id = if b then "true" else "false" in + Ppat_construct (mk_lident id, None) + | _ -> Ppat_constant (build_constant c) + +let rec build_pattern (p: mlpattern): pattern = + match p with + | MLP_Wild -> Pat.any () + | MLP_Const c -> build_constant_pat c |> Pat.mk + | MLP_Var sym -> Pat.var (mk_sym sym) + | MLP_CTor args -> build_constructor_pat args |> Pat.mk + | MLP_Branch l -> + (match l with + | [pat] -> build_pattern pat + | (pat1::tl) -> Pat.or_ (build_pattern pat1) (build_pattern (MLP_Branch tl)) + | [] -> failwith "Empty branch shouldn't happen") + | MLP_Record (path, l) -> + let fs = map (fun (x,y) -> (path_to_ident (path, x), build_pattern y)) l in + Pat.record fs Open (* does the closed flag matter? *) + | MLP_Tuple l -> Pat.tuple (map build_pattern l) + +and build_constructor_pat ((path, sym), p) = + let (path', name) = + (* resugaring the Cons and Nil from Prims *) + (match path with + | ["Prims"] -> + (match sym with + | "Cons" -> ([], "::") + | "Nil" -> ([], "[]") + | x -> (path, x)) + | _ -> (path, sym)) in + match p with + | [] -> + Ppat_construct (path_to_ident (path', name), None) + | [pat] -> + Ppat_construct (path_to_ident (path', name), Some ([], build_pattern pat)) + | pats -> + let inner = Pat.tuple (map build_pattern pats) in + Ppat_construct (path_to_ident(path', name), Some ([], inner)) + +let rec build_core_type ?(annots = []) (ty: mlty): core_type = + let t = + match ty with + | MLTY_Var sym -> Typ.mk (Ptyp_var (mk_typ_name sym)) + | MLTY_Fun (ty1, tag, ty2) -> + let c_ty1 = build_core_type ty1 in + let c_ty2 = build_core_type ty2 in + let label = Nolabel in + Typ.mk (Ptyp_arrow (label,c_ty1,c_ty2)) + | MLTY_Named (tys, (path, sym)) -> + let c_tys = map build_core_type tys in + let p = path_to_ident (path, sym) in + let ty = Typ.mk (Ptyp_constr (p, c_tys)) in + (match path with + | ["FStar"; "Pervasives"; "Native"] -> + (* A special case for tuples, so they are displayed as + * ('a * 'b) instead of ('a,'b) FStarC_Pervasives_Native.tuple2 + * VD: Should other types named "tupleXX" where XX does not represent + * the arity of the tuple be added to FStar.Pervasives.Native, + * the condition below might need to be more specific. *) + if BatString.starts_with sym "tuple" then + Typ.mk (Ptyp_tuple (map build_core_type tys)) + else + ty + | _ -> ty) + | MLTY_Tuple tys -> Typ.mk (Ptyp_tuple (map build_core_type tys)) + | MLTY_Top -> Typ.mk (Ptyp_constr (mk_lident "Obj.t", [])) + | MLTY_Erased -> Typ.mk (Ptyp_constr (mk_lident "unit", [])) + in + if annots = [] + then t + else Typ.mk (Ptyp_poly (annots, t)) + +let build_binding_pattern ?ty (sym : mlident) : pattern = + let p = Pat.mk (Ppat_var (mk_sym sym)) in + match ty with + | None -> p + | Some ty -> Pat.mk (Ppat_constraint (p, ty)) + +let resugar_prims_ops path: expression = + (match path with + | (["Prims"], "op_Addition") -> mk_lident "+" + | (["Prims"], "op_Subtraction") -> mk_lident "-" + | (["Prims"], "op_Multiply") -> mk_lident "*" + | (["Prims"], "op_Division") -> mk_lident "/" + | (["Prims"], "op_Equality") -> mk_lident "=" + | (["Prims"], "op_Colon_Equals") -> mk_lident ":=" + | (["Prims"], "op_disEquality") -> mk_lident "<>" + | (["Prims"], "op_AmpAmp") -> mk_lident "&&" + | (["Prims"], "op_BarBar") -> mk_lident "||" + | (["Prims"], "op_LessThanOrEqual") -> mk_lident "<=" + | (["Prims"], "op_GreaterThanOrEqual") -> mk_lident ">=" + | (["Prims"], "op_LessThan") -> mk_lident "<" + | (["Prims"], "op_GreaterThan") -> mk_lident ">" + | (["Prims"], "op_Modulus") -> mk_lident "mod" + | (["Prims"], "op_Minus") -> mk_lident "~-" + | path -> path_to_ident path) + |> Exp.ident + +let resugar_if_stmts ep cases = + if List.length cases = 2 then + let case1 = List.hd cases in + let case2 = BatList.last cases in + (match case1.pc_lhs.ppat_desc with + | Ppat_construct({txt=Lident "true"}, None) -> + Exp.ifthenelse ep case1.pc_rhs (Some case2.pc_rhs) + | _ -> Exp.match_ ep cases) + else + Exp.match_ ep cases + +let rec build_expr (e: mlexpr): expression = + match e.expr with + | MLE_Const c -> build_constant_expr c + | MLE_Var sym -> Exp.ident (mk_lident sym) + | MLE_Name path -> + (match path with + | (["Prims"], op) -> resugar_prims_ops path + | _ -> Exp.ident (path_to_ident path)) + | MLE_Let ((flavour, lbs), expr) -> + let recf = match flavour with + | Rec -> Recursive + | NonRec -> Nonrecursive in + let val_bindings = map (build_binding false) lbs in + Exp.let_ recf val_bindings (build_expr expr) + | MLE_App (e, es) -> + let args = map (fun x -> (Nolabel, build_expr x)) es in + let f = build_expr e in + resugar_app f args es + | MLE_TApp (e, ts) -> + build_expr e + | MLE_Fun (l, e) -> build_fun l e + | MLE_Match (e, branches) -> + let ep = build_expr e in + let cases = map build_case branches in + resugar_if_stmts ep cases + | MLE_Coerce (e, _, _) -> + let r = Exp.ident (mk_lident "Obj.magic") in + Exp.apply r [(Nolabel, build_expr e)] + | MLE_CTor args -> build_constructor_expr args + | MLE_Seq args -> build_seq args + | MLE_Tuple l -> Exp.tuple (map build_expr l) + | MLE_Record (path, _, l) -> + let fields = map (fun (x,y) -> (path_to_ident(path, x), build_expr y)) l in + Exp.record fields None + | MLE_Proj (e, path) -> + Exp.field (build_expr e) (path_to_ident (path)) + (* MLE_If always desugared to match? *) + | MLE_If (e, e1, e2) -> + Exp.ifthenelse (build_expr e) (build_expr e1) (BatOption.map build_expr e2) + | MLE_Raise (path, es) -> + let r = Exp.ident (mk_lident "raise") in + let args = map (fun x -> (Nolabel, build_expr x)) es in + Exp.apply r args + | MLE_Try (e, cs) -> + Exp.try_ (build_expr e) (map build_case cs) + +and resugar_app f args es: expression = + match f.pexp_desc with + | Pexp_ident x when x = try_with_ident () -> + (* resugar try_with to a try...with + try_with : (unit -> ML 'a) -> (exn -> ML 'a) -> ML 'a *) + assert (length es == 2); + let s, cs = BatList.first es, BatList.last es in + (* We have FStar.All.try_with s cs, with s : unit -> ML 'a + * and cs : exn -> ML 'a + * + * We need to create an OCaml try..with, with a body and a + * set of cases for catching the exception. + * + * For the body, we simply translate `s ()` and we're done. + * + * For the cases, we can't a similar trick, so we try to reverse-engineer + * the shape of the term in order to obtain a proper set. See get_variants. *) + + let body = Exp.apply (build_expr s) [(Nolabel, build_expr ml_unit)] in + let variants = get_variants cs in + Exp.try_ body variants + + | _ -> Exp.apply f args + +and get_variants (e : mlexpr) : Parsetree.case list = + match e.expr with + | MLE_Fun ([{mlbinder_name=id}], e) -> + (match e.expr with + | MLE_Match ({expr = MLE_Var id'}, branches) when id = id' -> + map build_case branches + | _ -> + [build_case (MLP_Var id, None, e)] + ) + | _ -> failwith "Cannot resugar FStar.All.try_with (3)" + +and build_seq args = + match args with + | [hd] -> build_expr hd + | hd::tl -> Exp.sequence (build_expr hd) (build_seq tl) + | [] -> failwith "Empty sequence should never happen" + +and build_constructor_expr ((path, sym), exp): expression = + let path', name = + (match path, sym with + | ["Prims"], "Cons" -> ([], "::") + | ["Prims"], "Nil" -> ([], "[]") + | path, x -> (path, x)) in + match exp with + | [] -> Exp.construct (path_to_ident(path', name)) None + | [e] -> + Exp.construct (path_to_ident(path', name)) (Some (build_expr e)) + | es -> + let inner = Exp.tuple (map build_expr es) in + Exp.construct (path_to_ident(path', name)) (Some inner) + +and build_fun l e = + match l with + | ({mlbinder_name=id; mlbinder_ty=ty}::tl) -> + let p = build_binding_pattern id in + Exp.fun_ Nolabel None p (build_fun tl e) + | [] -> build_expr e + +and build_case ((lhs, guard, rhs): mlbranch): case = + {pc_lhs = (build_pattern lhs); + pc_guard = BatOption.map build_expr guard; + pc_rhs = (build_expr rhs)} + +and build_binding (toplevel: bool) (lb: mllb): value_binding = + (* Add a constraint on the binding (ie. an annotation) for top-level lets *) + let mk1 s = mkloc (String.sub s 1 (String.length s - 1)) none in + let ty = + match lb.mllb_tysc with + | None -> None + | Some ts -> + if lb.print_typ && toplevel + then let vars = List.map mk1 (ty_param_names (fst ts)) in + let ty = snd ts in + Some (build_core_type ~annots:vars ty) + else None + in + let e = build_expr lb.mllb_def in + let p = build_binding_pattern ?ty:ty lb.mllb_name in + (Vb.mk p e) + +let build_label_decl (sym, ty): label_declaration = + Type.field (mk_sym sym) (build_core_type ty) + +let build_constructor_decl (sym, tys): constructor_declaration = + let tys = List.map snd tys in + let args = if BatList.is_empty tys then None else + Some (Pcstr_tuple (map build_core_type tys)) in + Type.constructor ?args:args (mk_sym sym) + +let build_ty_kind (b: mltybody): type_kind = + match b with + | MLTD_Abbrev ty -> Ptype_abstract + | MLTD_Record l -> Ptype_record (map build_label_decl l) + | MLTD_DType l -> Ptype_variant (map build_constructor_decl l) + +let build_ty_manifest (b: mltybody): core_type option= + match b with + | MLTD_Abbrev ty -> Some (build_core_type ty) + | MLTD_Record l -> None + | MLTD_DType l -> None + + +let skip_type_defn (current_module:string) (type_name:string) :bool = + current_module = "FStar_Pervasives" && type_name = "option" + +let type_metadata (md : metadata): attributes option = + let deriving = BatList.filter_map (function + | PpxDerivingShow | PpxDerivingShowConstant _ -> Some "show" + | PpxDerivingYoJson -> Some "yojson" + | _ -> None + ) md in + if List.length deriving > 0 then + let str = String.concat "," deriving in + Some [ { + attr_name = mk_sym "deriving"; + attr_payload = PStr [Str.eval (Exp.ident (mk_lident str))]; + attr_loc = no_location } + ] + else + None + +let add_deriving_const (md: metadata) (ptype_manifest: core_type option): core_type option = + match List.filter (function PpxDerivingShowConstant _ -> true | _ -> false) md with + | [PpxDerivingShowConstant s] -> + let e = Exp.apply (Exp.ident (path_to_ident (["Format"], "pp_print_string"))) [(Nolabel, Exp.ident (mk_lident "fmt")); (Nolabel, Exp.constant (Const.string s))] in + let deriving_const = { + attr_name = mk_sym "printer"; + attr_payload = PStr [Str.eval (Exp.fun_ Nolabel None (build_binding_pattern "fmt") (Exp.fun_ Nolabel None (Pat.any ()) e))]; + attr_loc = no_location } in + BatOption.map (fun x -> {x with ptyp_attributes=[deriving_const]}) ptype_manifest + | _ -> ptype_manifest + +let build_one_tydecl ({tydecl_name=x; + tydecl_ignored=mangle_opt; + tydecl_parameters=tparams; + tydecl_meta=attrs; + tydecl_defn=body}: one_mltydecl): type_declaration = + let ptype_name = match mangle_opt with + | Some y -> mk_sym y + | None -> mk_sym x in + let ptype_params = Some (map (fun sym -> Typ.mk (Ptyp_var (mk_typ_name sym)), (NoVariance, NoInjectivity)) (ty_param_names tparams)) in + let (ptype_manifest: core_type option) = + BatOption.map_default build_ty_manifest None body |> add_deriving_const attrs in + let ptype_kind = Some (BatOption.map_default build_ty_kind Ptype_abstract body) in + let ptype_attrs = type_metadata attrs in + Type.mk ?params:ptype_params ?kind:ptype_kind ?manifest:ptype_manifest ?attrs:ptype_attrs ptype_name + +let build_tydecl (td: mltydecl): structure_item_desc option = + let recf = Recursive in + let type_declarations = map build_one_tydecl td in + if type_declarations = [] then None else Some (Pstr_type (recf, type_declarations)) + +let build_exn (sym, tys): type_exception = + let tys = List.map snd tys in + let name = mk_sym sym in + let args = Some (Pcstr_tuple (map build_core_type tys)) in + let ctor = Te.decl ?args:args name in + Te.mk_exception ctor + +let build_module1 path (m1: mlmodule1): structure_item option = + match m1.mlmodule1_m with + | MLM_Ty tydecl -> + (match build_tydecl tydecl with + | Some t -> Some (Str.mk t) + | None -> None) + | MLM_Let (flav, mllbs) -> + let recf = match flav with | Rec -> Recursive | NonRec -> Nonrecursive in + let bindings = map (build_binding true) mllbs in + Some (Str.value recf bindings) + | MLM_Exn exn -> Some (Str.exception_ (build_exn exn)) + | MLM_Top expr -> + let lb = mk_top_mllb expr in + let binding = build_binding true lb in + Some (Str.value Nonrecursive [binding]) + | MLM_Loc (p, f) -> None + +let build_m path (md: (mlsig * mlmodule) option) : structure = + match md with + | Some(s, m) -> + let open_prims = + Str.open_ (Opn.mk ?override:(Some Fresh) (Mod.ident (mk_lident "Prims"))) in + open_prims::(map (build_module1 path) m |> flatmap opt_to_list) + | None -> [] + +let build_ast (out_dir: string option) (ext: string) (ml: mllib) = + match ml with + | MLLib l -> + map (fun (p, md, _) -> + let m = path_to_string p in + current_module := m; + let name = BatString.concat "" [m; ext] in + let path = (match out_dir with + | Some out -> BatString.concat "/" [out; name] + | None -> name) in + (path, build_m path md)) l + + +(* printing the AST to the correct path *) +let print_module ((path, m): string * structure) = + Format.set_formatter_out_channel (open_out_bin path); + structure Format.std_formatter m; + Format.pp_print_flush Format.std_formatter () + +let print (out_dir: string option) (ext: string) (ml: mllib) = + match ext with + | ".ml" -> + (* Use this printer for OCaml extraction *) + let ast = build_ast out_dir ext ml in + iter print_module ast + | ".fs" -> + (* Use the old printer for F# extraction *) + let new_doc = FStarC_Extraction_ML_Code.doc_of_mllib ml in + iter (fun (n, d) -> + FStarC_Compiler_Util.write_file + (FStarC_Options.prepend_output_dir (BatString.concat "" [n;ext])) + (FStarC_Extraction_ML_Code.pretty (Prims.parse_int "120") d) + ) new_doc + | _ -> failwith "Unrecognized extension" diff --git a/ocaml/fstar-lib/FStar_Getopt.ml b/ocaml/fstar-lib/FStarC_Getopt.ml similarity index 100% rename from ocaml/fstar-lib/FStar_Getopt.ml rename to ocaml/fstar-lib/FStarC_Getopt.ml diff --git a/ocaml/fstar-lib/FStarC_Hash.ml b/ocaml/fstar-lib/FStarC_Hash.ml new file mode 100644 index 00000000000..4a6947e7364 --- /dev/null +++ b/ocaml/fstar-lib/FStarC_Hash.ml @@ -0,0 +1,74 @@ +module BU = FStarC_Compiler_Util +module Z = FStarC_BigInt + +type hash_code = int + +let cmp_hash (x:hash_code) (y:hash_code) : Z.t = Z.of_int (x-y) + +let of_int (i:Z.t) = Z.to_int i +let of_string (s:string) = BatHashtbl.hash s + +(* This function is taken from Bob Jenkins' + http://burtleburtle.net/bob/hash/doobs.html + + It's defined there as a mix on 32 bit integers. + + I'm abusing it here by using it on OCaml's 63 bit + integers. + + But it seems to work well, at least in comparison + to some simpler mixes that I tried. E.g., using + this mix taken from Lean (src/runtime/hash.h) + +uint64 hash(uint64 h1, uint64 h2) { + h2 -= h1; h2 ^= (h1 << 16); + h1 -= h2; h2 ^= (h1 << 32); + h2 -= h1; h2 ^= (h1 << 20); + return h2; +} + + But, it produces many collisions, see, e.g., in + tests/FStar.Tests.Pars.test_hashes +*) +let mix (a: hash_code) (b:hash_code) = + let c = 11 in + (* a -= b; a -= c; a ^= (c >> 13); *) + let a = a - b in + let a = a - c in + (* skip this step since c lsr 13 = 0 *) + (* let a = a lxor (c lsr 13) in *) + (* b -= c; b -= a; b ^= (a << 8); *) + let b = b - c in + let b = b - a in + let b = b lxor (a lsl 8) in + (* c -= a; c -= b; c ^= (b >> 13); *) + let c = c - a in + let c = c - b in + let c = c lxor (b lsr 13) in + (* a -= b; a -= c; a ^= (c >> 12); *) + let a = a - b in + let a = a - c in + let a = a lxor (c lsr 12) in + (* b -= c; b -= a; b ^= (a << 16); *) + let b = b - c in + let b = b - a in + let b = b lxor (a lsl 16) in + (* c -= a; c -= b; c ^= (b >> 5); *) + let c = c - a in + let c = c - b in + let c = c lxor (b lsr 5) in + (* a -= b; a -= c; a ^= (c >> 3); *) + let a = a - b in + let a = a - c in + let a = a lxor (c lsr 3) in + (* b -= c; b -= a; b ^= (a << 10); *) + let b = b - c in + let b = b - a in + let b = b lxor (a lsl 10) in + (* c -= a; c -= b; c ^= (b >> 15); *) + let c = c - a in + let c = c - b in + let c = c lxor (b lsr 15) in + c + +let string_of_hash_code h = string_of_int h diff --git a/ocaml/fstar-lib/FStar_Json.ml b/ocaml/fstar-lib/FStarC_Json.ml similarity index 100% rename from ocaml/fstar-lib/FStar_Json.ml rename to ocaml/fstar-lib/FStarC_Json.ml diff --git a/ocaml/fstar-lib/FStarC_Parser_LexFStar.ml b/ocaml/fstar-lib/FStarC_Parser_LexFStar.ml new file mode 100644 index 00000000000..e4ef505d01f --- /dev/null +++ b/ocaml/fstar-lib/FStarC_Parser_LexFStar.ml @@ -0,0 +1,717 @@ +open FStarC_Parser_Parse +open FStarC_Parser_Util + +module Option = BatOption +module String = BatString +module Hashtbl = BatHashtbl +module Sedlexing = FStarC_Sedlexing +module L = Sedlexing +module E = FStarC_Errors +module Codes = FStarC_Errors_Codes + +let ba_of_string s = Array.init (String.length s) (fun i -> Char.code (String.get s i)) +let array_trim_both a n m = Array.sub a n (Array.length a - n - m) +let string_trim_both s n m = BatString.sub s n (String.length s - (n+m)) +let trim_both lexbuf n m = string_trim_both (L.lexeme lexbuf) n m +let utrim_both lexbuf n m = array_trim_both (L.ulexeme lexbuf) n m +let trim_right lexbuf n = trim_both lexbuf 0 n +let trim_left lexbuf n = trim_both lexbuf n 0 + +let unescape (a:int array) : int = + match a.(0) with + | 92 (* \ *) -> + (match a.(1) with + | 48 (*0*) -> 0 + | 98 (*b*) -> 8 + | 116 (*t*) -> 9 + | 110 (*n*) -> 10 + | 118 (*v*) -> 11 + | 102 (*f*) -> 12 + | 114 (*r*) -> 13 + | 117 (*u*) -> + let s = FStarC_Parser_Utf8.from_int_array a 2 4 in + int_of_string ("0x"^s) + | 120 (*x*) -> + let s = FStarC_Parser_Utf8.from_int_array a 2 2 in + int_of_string ("0x"^s) + | c -> c) + | c -> c + +let keywords = Hashtbl.create 0 +let constructors = Hashtbl.create 0 +let operators = Hashtbl.create 0 + +let () = + Hashtbl.add keywords "attributes" ATTRIBUTES ; + Hashtbl.add keywords "noeq" NOEQUALITY ; + Hashtbl.add keywords "unopteq" UNOPTEQUALITY ; + Hashtbl.add keywords "and" AND ; + Hashtbl.add keywords "assert" ASSERT ; + Hashtbl.add keywords "assume" ASSUME ; + Hashtbl.add keywords "begin" BEGIN ; + Hashtbl.add keywords "by" BY ; + Hashtbl.add keywords "calc" CALC ; + Hashtbl.add keywords "class" CLASS ; + Hashtbl.add keywords "default" DEFAULT ; + Hashtbl.add keywords "decreases" DECREASES ; + Hashtbl.add keywords "effect" EFFECT ; + Hashtbl.add keywords "eliminate" ELIM; + Hashtbl.add keywords "else" ELSE ; + Hashtbl.add keywords "end" END ; + Hashtbl.add keywords "ensures" ENSURES ; + Hashtbl.add keywords "exception" EXCEPTION ; + Hashtbl.add keywords "exists" (EXISTS false); + Hashtbl.add keywords "false" FALSE ; + Hashtbl.add keywords "friend" FRIEND ; + Hashtbl.add keywords "forall" (FORALL false); + Hashtbl.add keywords "fun" FUN ; + Hashtbl.add keywords "λ" FUN ; + Hashtbl.add keywords "function" FUNCTION ; + Hashtbl.add keywords "if" IF ; + Hashtbl.add keywords "in" IN ; + Hashtbl.add keywords "include" INCLUDE ; + Hashtbl.add keywords "inline" INLINE ; + Hashtbl.add keywords "inline_for_extraction" INLINE_FOR_EXTRACTION ; + Hashtbl.add keywords "instance" INSTANCE ; + Hashtbl.add keywords "introduce" INTRO ; + Hashtbl.add keywords "irreducible" IRREDUCIBLE ; + Hashtbl.add keywords "let" (LET false) ; + Hashtbl.add keywords "logic" LOGIC ; + Hashtbl.add keywords "match" MATCH ; + Hashtbl.add keywords "returns" RETURNS ; + Hashtbl.add keywords "as" AS ; + Hashtbl.add keywords "module" MODULE ; + Hashtbl.add keywords "new" NEW ; + Hashtbl.add keywords "new_effect" NEW_EFFECT ; + Hashtbl.add keywords "layered_effect" LAYERED_EFFECT ; + Hashtbl.add keywords "polymonadic_bind" POLYMONADIC_BIND ; + Hashtbl.add keywords "polymonadic_subcomp" POLYMONADIC_SUBCOMP ; + Hashtbl.add keywords "noextract" NOEXTRACT ; + Hashtbl.add keywords "of" OF ; + Hashtbl.add keywords "open" OPEN ; + Hashtbl.add keywords "opaque" OPAQUE ; + Hashtbl.add keywords "private" PRIVATE ; + Hashtbl.add keywords "quote" QUOTE ; + Hashtbl.add keywords "range_of" RANGE_OF ; + Hashtbl.add keywords "rec" REC ; + Hashtbl.add keywords "reifiable" REIFIABLE ; + Hashtbl.add keywords "reify" REIFY ; + Hashtbl.add keywords "reflectable" REFLECTABLE ; + Hashtbl.add keywords "requires" REQUIRES ; + Hashtbl.add keywords "set_range_of" SET_RANGE_OF; + Hashtbl.add keywords "sub_effect" SUB_EFFECT ; + Hashtbl.add keywords "synth" SYNTH ; + Hashtbl.add keywords "then" THEN ; + Hashtbl.add keywords "total" TOTAL ; + Hashtbl.add keywords "true" TRUE ; + Hashtbl.add keywords "try" TRY ; + Hashtbl.add keywords "type" TYPE ; + Hashtbl.add keywords "unfold" UNFOLD ; + Hashtbl.add keywords "unfoldable" UNFOLDABLE ; + Hashtbl.add keywords "val" VAL ; + Hashtbl.add keywords "when" WHEN ; + Hashtbl.add keywords "with" WITH ; + Hashtbl.add keywords "_" UNDERSCORE ; + Hashtbl.add keywords "α" (TVAR "a") ; + Hashtbl.add keywords "β" (TVAR "b") ; + Hashtbl.add keywords "γ" (TVAR "c") ; + Hashtbl.add keywords "δ" (TVAR "d") ; + Hashtbl.add keywords "ε" (TVAR "e") ; + Hashtbl.add keywords "φ" (TVAR "f") ; + Hashtbl.add keywords "χ" (TVAR "g") ; + Hashtbl.add keywords "η" (TVAR "h") ; + Hashtbl.add keywords "ι" (TVAR "i") ; + Hashtbl.add keywords "κ" (TVAR "k") ; + Hashtbl.add keywords "μ" (TVAR "m") ; + Hashtbl.add keywords "ν" (TVAR "n") ; + Hashtbl.add keywords "π" (TVAR "p") ; + Hashtbl.add keywords "θ" (TVAR "q") ; + Hashtbl.add keywords "ρ" (TVAR "r") ; + Hashtbl.add keywords "σ" (TVAR "s") ; + Hashtbl.add keywords "τ" (TVAR "t") ; + Hashtbl.add keywords "ψ" (TVAR "u") ; + Hashtbl.add keywords "ω" (TVAR "w") ; + Hashtbl.add keywords "ξ" (TVAR "x") ; + Hashtbl.add keywords "ζ" (TVAR "z") ; + Hashtbl.add constructors "ℕ" (IDENT "nat"); + Hashtbl.add constructors "ℤ" (IDENT "int"); + Hashtbl.add constructors "𝔹" (IDENT "bool"); + let l = + ["~", TILDE "~"; + "-", MINUS; + "/\\", CONJUNCTION; + "\\/", DISJUNCTION; + "<:", SUBTYPE; + "$:", EQUALTYPE; + "<@", SUBKIND; + "(|", LENS_PAREN_LEFT; + "|)", LENS_PAREN_RIGHT; + "#", HASH; + "u#", UNIV_HASH; + "&", AMP; + "()", LPAREN_RPAREN; + "(", LPAREN; + ")", RPAREN; + ",", COMMA; + "~>", SQUIGGLY_RARROW; + "->", RARROW; + "<--", LONG_LEFT_ARROW; + "<-", LARROW; + "<==>", IFF; + "==>", IMPLIES; + ".", DOT; + "?.", QMARK_DOT; + "?", QMARK; + ".[", DOT_LBRACK; + ".(|", DOT_LENS_PAREN_LEFT; + ".(", DOT_LPAREN; + ".[|", DOT_LBRACK_BAR; + "{:pattern", LBRACE_COLON_PATTERN; + "{:well-founded", LBRACE_COLON_WELL_FOUNDED; + "returns$", RETURNS_EQ; + ":", COLON; + "::", COLON_COLON; + ":=", COLON_EQUALS; + ";", SEMICOLON; + "=", EQUALS; + "%[", PERCENT_LBRACK; + "!{", BANG_LBRACE; + "[@@@", LBRACK_AT_AT_AT; + "[@@", LBRACK_AT_AT; + "[@", LBRACK_AT; + "[", LBRACK; + "[|", LBRACK_BAR; + "{|", LBRACE_BAR; + "|>", PIPE_RIGHT; + "]", RBRACK; + "|]", BAR_RBRACK; + "|}", BAR_RBRACE; + "{", LBRACE; + "|", BAR; + "}", RBRACE; + "$", DOLLAR; + (* New Unicode equivalents *) + "∀", (FORALL false); + "∃", (EXISTS false); + "⊤", NAME "True"; + "⊥", NAME "False"; + "⟹", IMPLIES; + "⟺", IFF; + "→", RARROW; + "←", LARROW; + "⟵", LONG_LEFT_ARROW; + "↝", SQUIGGLY_RARROW; + "≔", COLON_EQUALS; + "∧", CONJUNCTION; + "∨", DISJUNCTION; + "¬", TILDE "~"; + "⸬", COLON_COLON; + "▹", PIPE_RIGHT; + "÷", OPINFIX3 "÷"; + "‖", OPINFIX0a "||"; + "×", IDENT "op_Multiply"; + "∗", OPINFIX3 "*"; + "⇒", OPINFIX0c "=>"; + "≥", OPINFIX0c ">="; + "≤", OPINFIX0c "<="; + "≠", OPINFIX0c "<>"; + "≪", OPINFIX0c "<<"; + "◃", OPINFIX0c "<|"; + "±", OPPREFIX "±"; + "∁", OPPREFIX "∁"; + "∂", OPPREFIX "∂"; + "√", OPPREFIX "√"; + ] in + List.iter (fun (k,v) -> Hashtbl.add operators k v) l + +let current_range lexbuf = + FStarC_Parser_Util.mksyn_range (fst (L.range lexbuf)) (snd (L.range lexbuf)) + +let fail lexbuf (e, msg) = + let m = current_range lexbuf in + E.raise_error_text m e msg + +type delimiters = { angle:int ref; paren:int ref; } +let n_typ_apps = ref 0 + +let is_typ_app_gt () = + if !n_typ_apps > 0 + then (decr n_typ_apps; true) + else false + +let rec mknewline n lexbuf = + if n = 0 then () + else (L.new_line lexbuf; mknewline (n-1) lexbuf) + +let clean_number x = String.strip ~chars:"uzyslLUnIN" x + +(* Try to trim each line of [comment] by the ammount of space + on the first line of the comment if possible *) +(* TODO : apply this to FSDOC too *) +let maybe_trim_lines start_column comment = + if start_column = 0 then comment + else + let comment_lines = String.split_on_char '\n' comment in + let ensures_empty_prefix k s = + let j = min k (String.length s - 1) in + let rec aux i = if i > j then k else if s.[i] <> ' ' then i else aux (i+1) in + aux 0 in + let trim_width = List.fold_left ensures_empty_prefix start_column comment_lines in + String.concat "\n" (List.map (fun s -> String.tail s trim_width) comment_lines) + +let comment_buffer = Buffer.create 128 +let blob_buffer = Buffer.create 128 +let use_lang_buffer = Buffer.create 128 + +let start_comment lexbuf = + Buffer.add_string comment_buffer "(*" ; + (false, comment_buffer, fst (L.range lexbuf)) + +let terminate_comment buffer startpos lexbuf = + let endpos = snd (L.range lexbuf) in + Buffer.add_string buffer "*)" ; + let comment = Buffer.contents buffer in + let comment = maybe_trim_lines (startpos.Lexing.pos_cnum - startpos.Lexing.pos_bol) comment in + Buffer.clear buffer; + add_comment (comment, FStarC_Parser_Util.mksyn_range startpos endpos) + +let push_one_line_comment pre lexbuf = + let startpos, endpos = L.range lexbuf in + assert (startpos.Lexing.pos_lnum = endpos.Lexing.pos_lnum); + add_comment (pre ^ L.lexeme lexbuf, FStarC_Parser_Util.mksyn_range startpos endpos) + +(** Unicode class definitions + Auto-generated from http:/ /www.unicode.org/Public/8.0.0/ucd/UnicodeData.txt **) +(** Ll **) +let u_lower = [%sedlex.regexp? ll] +(** Lu *) +let u_upper = [%sedlex.regexp? lu] +(** Lo *) +let u_other = [%sedlex.regexp? lo] +(** Lm *) +let u_modifier = [%sedlex.regexp? lm] +(** Lt *) +let u_title = [%sedlex.regexp? lt] +(** Zs *) +let u_space = [%sedlex.regexp? zs] +(** These are not unicode spaces but we accept as whitespace in F* source (e.g. tab and BOM) *) +let u_space_extra = [%sedlex.regexp? '\t' | '\x0B' | '\x0C' | '\xA0' | 0xfeff] +(** Zl and Zp *) +let u_line_sep = [%sedlex.regexp? zl] +let u_par_sep = [%sedlex.regexp? zp] +(** Sm math symbols *) +let u_math = [%sedlex.regexp? sm] +let u_math_ascii = [%sedlex.regexp? 0x002b | 0x003c .. 0x003e | 0x007c | 0x007e] +let u_math_nonascii = [%sedlex.regexp? Sub(u_math, u_math_ascii)] +(** Sc currency *) +let u_currency = [%sedlex.regexp? sc] +(** Sk *) +let u_modifier_symbol = [%sedlex.regexp? sk] +(** So *) +let u_other_symbol = [%sedlex.regexp? so] +(** Nd *) +let u_decimal_digit = [%sedlex.regexp? nd] +(** Nl *) +let u_digit_letter = [%sedlex.regexp? nl] +(** No *) +let u_other_digit = [%sedlex.regexp? no] +(** Pd *) +let u_punct_hyphen = [%sedlex.regexp? pd] +(** Ps *) +let u_punct_obra = [%sedlex.regexp? ps] +(** Pe *) +let u_punct_cbra = [%sedlex.regexp? pe] +(** Pi *) +let u_punct_oquot = [%sedlex.regexp? pi] +(** Pf *) +let u_punct_cquot = [%sedlex.regexp? pf] +(** Pc *) +let u_punct_connect = [%sedlex.regexp? pc] +(** Po *) +let u_punct_other = [%sedlex.regexp? po] +(** Mn *) +let u_mod_nospace = [%sedlex.regexp? mn] +(** Mc *) +let u_mod = [%sedlex.regexp? mc] +(** Me *) +let u_mod_enclose = [%sedlex.regexp? me] +(** Cc *) +let u_ascii_control = [%sedlex.regexp? cc] +(** Cf *) +let u_format_control = [%sedlex.regexp? cf] +(** Co *) +let u_private_use = [%sedlex.regexp? co] +(** Cs *) +let u_surrogate = [%sedlex.regexp? cs] + +(* -------------------------------------------------------------------- *) +let lower = [%sedlex.regexp? u_lower] +let upper = [%sedlex.regexp? u_upper | u_title] +let letter = [%sedlex.regexp? u_lower | u_upper | u_other | u_modifier] +let digit = [%sedlex.regexp? '0'..'9'] +let hex = [%sedlex.regexp? '0'..'9' | 'A'..'F' | 'a'..'f'] + +(* -------------------------------------------------------------------- *) +let anywhite = [%sedlex.regexp? u_space | u_space_extra] +let newline = [%sedlex.regexp? "\r\n" | 10 | 13 | 0x2028 | 0x2029] + +(* -------------------------------------------------------------------- *) +let op_char = [%sedlex.regexp? Chars "!$%&*+-.<>=?^|~:@#\\/"] + +(* op_token must be splt into seperate regular expressions to prevent + compliation from hanging *) +let op_token_1 = [%sedlex.regexp? "~" | "-" | "/\\" | "\\/" | "<:" | "$:" | "<@" | "(|" | "|)" | "#" ] +let op_token_2 = [%sedlex.regexp? "u#" | "&" | "()" | "(" | ")" | "," | "~>" | "->" | "<--" ] +let op_token_3 = [%sedlex.regexp? "<-" | "<==>" | "==>" | "." | "?." | "?" | ".[|" | ".[" | ".(|" | ".(" ] +let op_token_4 = [%sedlex.regexp? "$" | "{:pattern" | "{:well-founded" | ":" | "::" | ":=" | ";;" | ";" | "=" | "%[" | "returns$" ] +let op_token_5 = [%sedlex.regexp? "!{" | "[@@@" | "[@@" | "[@" | "[|" | "{|" | "[" | "|>" | "]" | "|]" | "|}" | "{" | "|" | "}" ] + +(* -------------------------------------------------------------------- *) +let xinteger = + [%sedlex.regexp? + ( '0', ('x'| 'X'), Plus hex + | '0', ('o'| 'O'), Plus ('0' .. '7') + | '0', ('b'| 'B'), Plus ('0' .. '1') )] +let integer = [%sedlex.regexp? Plus digit] +let any_integer = [%sedlex.regexp? xinteger | integer] +let unsigned = [%sedlex.regexp? Chars "uU"] +let int8 = [%sedlex.regexp? any_integer, 'y'] +let uint8 = [%sedlex.regexp? any_integer, unsigned, 'y'] +let int16 = [%sedlex.regexp? any_integer, 's'] +let uint16 = [%sedlex.regexp? any_integer, unsigned, 's'] +let int32 = [%sedlex.regexp? any_integer, 'l'] +let uint32 = [%sedlex.regexp? any_integer, unsigned, 'l'] +let int64 = [%sedlex.regexp? any_integer, 'L'] +let uint64 = [%sedlex.regexp? any_integer, unsigned, 'L'] +let char8 = [%sedlex.regexp? any_integer, 'z'] +let sizet = [%sedlex.regexp? any_integer, "sz"] + +let floatp = [%sedlex.regexp? Plus digit, '.', Star digit] +let floate = [%sedlex.regexp? Plus digit, Opt ('.', Star digit), Chars "eE", Opt (Chars "+-"), Plus digit] +let real = [%sedlex.regexp? floatp, 'R'] +let ieee64 = [%sedlex.regexp? floatp | floate] +let xieee64 = [%sedlex.regexp? xinteger, 'L', 'F'] +let range = [%sedlex.regexp? Plus digit, '.', '.', Plus digit] + +let op_prefix = [%sedlex.regexp? Chars "!~?"] +let op_infix0a = [%sedlex.regexp? Chars "|"] (* left *) +let op_infix0b = [%sedlex.regexp? Chars "&"] (* left *) +let op_infix0c = [%sedlex.regexp? Chars "=<>"] (* left *) +let op_infix0c_nogt = [%sedlex.regexp? Chars "=<"] (* left *) +let op_infix0d = [%sedlex.regexp? Chars "$"] (* left *) + +let op_infix0 = [%sedlex.regexp? op_infix0a | op_infix0b | op_infix0c | op_infix0d] +let op_infix1 = [%sedlex.regexp? Chars "@^"] (* right *) +let op_infix2 = [%sedlex.regexp? Chars "+-"] (* left *) +let op_infix3 = [%sedlex.regexp? Chars "*/%"] (* left *) +let symbolchar = [%sedlex.regexp? op_prefix | op_infix0 | op_infix1 | op_infix2 | op_infix3 | Chars ".:"] +let uoperator = [%sedlex.regexp? u_math_nonascii] + +(* -------------------------------------------------------------------- *) +let escape_char = [%sedlex.regexp? '\\', (Chars "\\\"'bfntrv0" | "x", hex, hex | "u", hex, hex, hex, hex)] +let char = [%sedlex.regexp? Compl '\\' | escape_char] + +(* -------------------------------------------------------------------- *) +let constructor_start_char = [%sedlex.regexp? upper] +let ident_start_char = [%sedlex.regexp? lower | '_'] +let ident_char = [%sedlex.regexp? letter | digit | '\'' | '_'] +let tvar_char = [%sedlex.regexp? letter | digit | '\'' | '_'] + +let constructor = [%sedlex.regexp? constructor_start_char, Star ident_char] +let ident = [%sedlex.regexp? ident_start_char, Star ident_char] +let tvar = [%sedlex.regexp? '\'', (ident_start_char | constructor_start_char), Star tvar_char] + +(* [ensure_no_comment lexbuf next] takes a [lexbuf] and [next], a + continuation. It is to be called after a regexp was matched, to + ensure match text does not contain any comment start. + + If the match [s] contains a comment start (an occurence of [//]) + then we place the lexer at that comment start. We continue with + [next s], [s] being either the whole match, or the chunk before + [//]. +*) +let ensure_no_comment lexbuf (next: string -> token): token = + let s = L.lexeme lexbuf in + next (try let before, _after = BatString.split s "//" in + (* rollback to the begining of the match *) + L.rollback lexbuf; + (* skip [n] characters in the lexer, with [n] being [hd]'s len *) + BatString.iter (fun _ -> let _ = L.next lexbuf in ()) before; + before with | Not_found -> s) + +let rec token lexbuf = +match%sedlex lexbuf with + | "%splice" -> SPLICE + | "%splice_t" -> SPLICET + | "```", ident -> + let s = L.lexeme lexbuf in + let name = BatString.lchop ~n:3 s in + Buffer.clear blob_buffer; + let snap = Sedlexing.snapshot lexbuf in + let pos = L.current_pos lexbuf in + uninterpreted_blob snap name pos blob_buffer lexbuf + | "`%" -> BACKTICK_PERC + | "`#" -> BACKTICK_HASH + | "`@" -> BACKTICK_AT + | "#lang-", ident -> ( + let s = L.lexeme lexbuf in + let lang_name = BatString.lchop ~n:6 s in + let snap = Sedlexing.snapshot lexbuf in + Buffer.clear use_lang_buffer; + let pos = L.current_pos lexbuf in + use_lang_blob snap lang_name pos use_lang_buffer lexbuf + ) + + | "seq![" -> SEQ_BANG_LBRACK + + | "#show-options" -> PRAGMA_SHOW_OPTIONS + | "#set-options" -> PRAGMA_SET_OPTIONS + | "#reset-options" -> PRAGMA_RESET_OPTIONS + | "#push-options" -> PRAGMA_PUSH_OPTIONS + | "#pop-options" -> PRAGMA_POP_OPTIONS + | "#restart-solver" -> PRAGMA_RESTART_SOLVER + | "#print-effects-graph" -> PRAGMA_PRINT_EFFECTS_GRAPH + | "__SOURCE_FILE__" -> STRING (L.source_file lexbuf) + | "__LINE__" -> INT (string_of_int (L.current_line lexbuf), false) + + | Plus anywhite -> token lexbuf + | newline -> L.new_line lexbuf; token lexbuf + + (* Must appear before tvar to avoid 'a <-> 'a' conflict *) + | ('\'', char, '\'') -> CHAR (unescape (utrim_both lexbuf 1 1)) + | ('\'', char, '\'', 'B') -> CHAR (unescape (utrim_both lexbuf 1 2)) + | '`' -> BACKTICK + + | "match", Plus op_char -> + ensure_no_comment lexbuf (fun s -> + match BatString.lchop ~n:5 s with + | "" -> MATCH + | s -> MATCH_OP s + ) + + | "if", Plus op_char -> + ensure_no_comment lexbuf (fun s -> + match BatString.lchop ~n:2 s with + | "" -> IF + | s -> IF_OP s + ) + + | "let", Plus op_char -> + ensure_no_comment lexbuf (fun s -> + match BatString.lchop ~n:3 s with + | "" -> LET false + | s -> LET_OP s + ) + + | "exists", Plus op_char -> + ensure_no_comment lexbuf (fun s -> + match BatString.lchop ~n:6 s with + | "" -> EXISTS false + | s -> EXISTS_OP s + ) + + | "∃", Plus op_char -> + ensure_no_comment lexbuf (fun s -> + match BatString.lchop ~n:1 s with + | "" -> EXISTS false + | s -> EXISTS_OP s + ) + + | "forall", Plus op_char -> + ensure_no_comment lexbuf (fun s -> + match BatString.lchop ~n:6 s with + | "" -> FORALL false + | s -> FORALL_OP s + ) + + | "∀", Plus op_char -> + ensure_no_comment lexbuf (fun s -> + match BatString.lchop ~n:1 s with + | "" -> FORALL false + | s -> FORALL_OP s + ) + + | "and", Plus op_char -> + ensure_no_comment lexbuf (fun s -> + match BatString.lchop ~n:3 s with + | "" -> AND + | s -> AND_OP s + ) + + | ";", Plus op_char -> + ensure_no_comment lexbuf (fun s -> + match BatString.lchop ~n:1 s with + | "" -> SEMICOLON + | s -> SEMICOLON_OP (Some s) + ) + + | ";;" -> SEMICOLON_OP None + + | ident -> let id = L.lexeme lexbuf in + if FStarC_Compiler_Util.starts_with id FStarC_Ident.reserved_prefix + then FStarC_Errors.raise_error_text (current_range lexbuf) Codes.Fatal_ReservedPrefix + (FStarC_Ident.reserved_prefix ^ " is a reserved prefix for an identifier"); + Hashtbl.find_option keywords id |> Option.default (IDENT id) + | constructor -> let id = L.lexeme lexbuf in + Hashtbl.find_option constructors id |> Option.default (NAME id) + + | tvar -> TVAR (L.lexeme lexbuf) + | (integer | xinteger) -> INT (clean_number (L.lexeme lexbuf), false) + | (uint8 | char8) -> + let c = clean_number (L.lexeme lexbuf) in + let cv = int_of_string c in + if cv < 0 || cv > 255 then fail lexbuf (Codes.Fatal_SyntaxError, "Out-of-range character literal") + else UINT8 (c) + | int8 -> INT8 (clean_number (L.lexeme lexbuf), false) + | uint16 -> UINT16 (clean_number (L.lexeme lexbuf)) + | int16 -> INT16 (clean_number (L.lexeme lexbuf), false) + | uint32 -> UINT32 (clean_number (L.lexeme lexbuf)) + | int32 -> INT32 (clean_number (L.lexeme lexbuf), false) + | uint64 -> UINT64 (clean_number (L.lexeme lexbuf)) + | int64 -> INT64 (clean_number (L.lexeme lexbuf), false) + | sizet -> SIZET (clean_number (L.lexeme lexbuf)) + | range -> RANGE (L.lexeme lexbuf) + | real -> REAL(trim_right lexbuf 1) + | (integer | xinteger | ieee64 | xieee64), Plus ident_char -> + fail lexbuf (Codes.Fatal_SyntaxError, "This is not a valid numeric literal: " ^ L.lexeme lexbuf) + + | "(*" -> + let inner, buffer, startpos = start_comment lexbuf in + comment inner buffer startpos lexbuf + + | "// IN F*:" -> token lexbuf + | "//" -> + (* Only match on "//" to allow the longest-match rule to catch IN F*. This + * creates a lexing conflict with op_infix3 which is caught below. *) + one_line_comment (L.lexeme lexbuf) lexbuf + + | '"' -> string (Buffer.create 0) lexbuf.Sedlexing.start_p lexbuf + + | '`', '`', (Plus (Compl ('`' | 10 | 13 | 0x2028 | 0x2029) | '`', Compl ('`' | 10 | 13 | 0x2028 | 0x2029))), '`', '`' -> + IDENT (trim_both lexbuf 2 2) + + (* Pipe operators have special treatment in the parser. *) + | "<|" -> PIPE_LEFT + | "|>" -> PIPE_RIGHT + + | op_token_1 + | op_token_2 + | op_token_3 + | op_token_4 + | op_token_5 -> L.lexeme lexbuf |> Hashtbl.find operators + + | "<" -> OPINFIX0c("<") + | ">" -> if is_typ_app_gt () + then TYP_APP_GREATER + else begin match%sedlex lexbuf with + | Star symbolchar -> ensure_no_comment lexbuf (fun s -> OPINFIX0c (">" ^ s)) + | _ -> assert false end + + (* Operators. *) + | op_prefix, Star symbolchar -> ensure_no_comment lexbuf (fun s -> OPPREFIX s) + | op_infix0a, Star symbolchar -> ensure_no_comment lexbuf (fun s -> OPINFIX0a s) + | op_infix0b, Star symbolchar -> ensure_no_comment lexbuf (fun s -> OPINFIX0b s) + | op_infix0c_nogt, Star symbolchar -> ensure_no_comment lexbuf (fun s -> OPINFIX0c s) + | op_infix0d, Star symbolchar -> ensure_no_comment lexbuf (fun s -> OPINFIX0d s) + | op_infix1, Star symbolchar -> ensure_no_comment lexbuf (fun s -> OPINFIX1 s) + | op_infix2, Star symbolchar -> ensure_no_comment lexbuf (fun s -> OPINFIX2 s) + | op_infix3, Star symbolchar -> ensure_no_comment lexbuf (function + | "" -> one_line_comment "" lexbuf + | s -> OPINFIX3 s + ) + | "**" , Star symbolchar -> ensure_no_comment lexbuf (fun s -> OPINFIX4 s) + + (* Unicode Operators *) + | uoperator -> let id = L.lexeme lexbuf in + Hashtbl.find_option operators id |> Option.default (OPINFIX4 id) + + | ".[]<-" -> OP_MIXFIX_ASSIGNMENT (L.lexeme lexbuf) + | ".()<-" -> OP_MIXFIX_ASSIGNMENT (L.lexeme lexbuf) + | ".(||)<-" -> OP_MIXFIX_ASSIGNMENT (L.lexeme lexbuf) + | ".[||]<-" -> OP_MIXFIX_ASSIGNMENT (L.lexeme lexbuf) + | ".[]" -> OP_MIXFIX_ACCESS (L.lexeme lexbuf) + | ".()" -> OP_MIXFIX_ACCESS (L.lexeme lexbuf) + | ".(||)" -> OP_MIXFIX_ACCESS (L.lexeme lexbuf) + | ".[||]" -> OP_MIXFIX_ACCESS (L.lexeme lexbuf) + + | eof -> EOF + | _ -> fail lexbuf (Codes.Fatal_SyntaxError, "unexpected char") + +and one_line_comment pre lexbuf = +match%sedlex lexbuf with + | Star (Compl (10 | 13 | 0x2028 | 0x2029)) -> push_one_line_comment pre lexbuf; token lexbuf + | _ -> assert false + +and string buffer start_pos lexbuf = +match%sedlex lexbuf with + | '\\', newline, Star anywhite -> L.new_line lexbuf; string buffer start_pos lexbuf + | newline -> + Buffer.add_string buffer (L.lexeme lexbuf); + L.new_line lexbuf; string buffer start_pos lexbuf + | escape_char -> + Buffer.add_string buffer (BatUTF8.init 1 (fun _ -> unescape (L.ulexeme lexbuf) |> BatUChar.chr)); + string buffer start_pos lexbuf + | '"' -> + (* position info must be set since the start of the string *) + lexbuf.Sedlexing.start_p <- start_pos; + STRING (Buffer.contents buffer) + | eof -> fail lexbuf (Codes.Fatal_SyntaxError, "unterminated string") + | any -> + Buffer.add_string buffer (L.lexeme lexbuf); + string buffer start_pos lexbuf + | _ -> assert false + +and comment inner buffer startpos lexbuf = +match%sedlex lexbuf with + | "(*" -> + Buffer.add_string buffer "(*" ; + let _ = comment true buffer startpos lexbuf in + comment inner buffer startpos lexbuf + | newline -> + L.new_line lexbuf; + Buffer.add_string buffer (L.lexeme lexbuf); + comment inner buffer startpos lexbuf + | "*)" -> + terminate_comment buffer startpos lexbuf; + if inner then EOF else token lexbuf + | eof -> + terminate_comment buffer startpos lexbuf; EOF + | any -> + Buffer.add_string buffer (L.lexeme lexbuf); + comment inner buffer startpos lexbuf + | _ -> assert false + +and uninterpreted_blob snap name pos buffer lexbuf = +match %sedlex lexbuf with + | "```" -> + BLOB(name, Buffer.contents buffer, pos, snap) + | eof -> + E.raise_error_text (current_range lexbuf) Codes.Fatal_SyntaxError + "Syntax error: unterminated extension syntax" + | newline -> + L.new_line lexbuf; + Buffer.add_string buffer (L.lexeme lexbuf); + uninterpreted_blob snap name pos buffer lexbuf + | any -> + Buffer.add_string buffer (L.lexeme lexbuf); + uninterpreted_blob snap name pos buffer lexbuf + | _ -> assert false + +and use_lang_blob snap name pos buffer lexbuf = +match %sedlex lexbuf with + | eof -> + L.rollback lexbuf; (* leave the eof to be consumed later *) + USE_LANG_BLOB(name, Buffer.contents buffer, pos, snap) + | newline -> + L.new_line lexbuf; + Buffer.add_string buffer (L.lexeme lexbuf); + use_lang_blob snap name pos buffer lexbuf + | any -> + Buffer.add_string buffer (L.lexeme lexbuf); + use_lang_blob snap name pos buffer lexbuf + | _ -> assert false + +and ignore_endline lexbuf = +match%sedlex lexbuf with + | Star ' ', newline -> token lexbuf + | _ -> assert false diff --git a/ocaml/fstar-lib/FStarC_Parser_Parse.mly b/ocaml/fstar-lib/FStarC_Parser_Parse.mly new file mode 100644 index 00000000000..ccf4d38af78 --- /dev/null +++ b/ocaml/fstar-lib/FStarC_Parser_Parse.mly @@ -0,0 +1,1730 @@ +%{ +(* + Menhir reports the following warnings: + + Warning: 5 states have shift/reduce conflicts. + Warning: 6 shift/reduce conflicts were arbitrarily resolved. + Warning: 221 end-of-stream conflicts were arbitrarily resolved. + + If you're editing this file, be sure to not increase the warnings, + except if you have a really good reason. + + The shift-reduce conflicts are natural in an ML-style language. E.g., + there are S-R conflicts with dangling elses, with a non-delimited match where + the BAR is dangling etc. + + Note: Some symbols are marked public, so that we can reuse this parser from + the parser for the Pulse DSL in FStarLang/steel. + +*) +(* (c) Microsoft Corporation. All rights reserved *) +open Prims +open FStar_Pervasives +open FStarC_Errors +open FStarC_Compiler_List +open FStarC_Compiler_Util +open FStarC_Compiler_Range + +(* TODO : these files should be deprecated and removed *) +open FStarC_Parser_Const +open FStarC_Parser_AST +open FStarC_Const +open FStarC_Ident + +(* Shorthands *) +let rr = FStarC_Parser_Util.translate_range +let rr2 = FStarC_Parser_Util.translate_range2 + +let logic_qualifier_deprecation_warning = + "logic qualifier is deprecated, please remove it from the source program. In case your program verifies with the qualifier annotated but not without it, please try to minimize the example and file a github issue." + +let mk_meta_tac m = Meta m + +let old_attribute_syntax_warning = + "The `[@ ...]` syntax of attributes is deprecated. \ + Use `[@@ a1; a2; ...; an]`, a semi-colon separated list of attributes, instead" + +let do_notation_deprecation_warning = + "The lightweight do notation [x <-- y; z] or [x ;; z] is deprecated, use let operators (i.e. [let* x = y in z] or [y ;* z], [*] being any sequence of operator characters) instead." + +let none_to_empty_list x = + match x with + | None -> [] + | Some l -> l + +let parse_extension_blob (extension_name:string) + (s:string) + (blob_range:range) + (extension_syntax_start:range) : FStarC_Parser_AST.decl' = + DeclSyntaxExtension (extension_name, s, blob_range, extension_syntax_start) + +let parse_use_lang_blob (extension_name:string) + (s:string) + (blob_range:range) + (extension_syntax_start:range) +: FStarC_Parser_AST.decl list += FStarC_Parser_AST_Util.parse_extension_lang extension_name s extension_syntax_start + +%} + +%token STRING +%token IDENT +%token NAME +%token TVAR +%token TILDE + +/* bool indicates if INT8 was 'bad' max_int+1, e.g. '128' */ +%token INT8 +%token INT16 +%token INT32 +%token INT64 +%token INT +%token RANGE + +%token UINT8 +%token UINT16 +%token UINT32 +%token UINT64 +%token SIZET +%token REAL +%token CHAR +%token LET +%token LET_OP +%token AND_OP +%token MATCH_OP +%token IF_OP +%token EXISTS +%token EXISTS_OP +%token FORALL +%token FORALL_OP + + +/* [SEMICOLON_OP] encodes either: +- [;;], which used to be SEMICOLON_SEMICOLON, or +- [;], with a sequence of [op_char] (see FStarC_Parser_LexFStar). +*/ +%token SEMICOLON_OP + +%token ASSUME NEW LOGIC ATTRIBUTES +%token IRREDUCIBLE UNFOLDABLE INLINE OPAQUE UNFOLD INLINE_FOR_EXTRACTION +%token NOEXTRACT +%token NOEQUALITY UNOPTEQUALITY +%token PRAGMA_SHOW_OPTIONS PRAGMA_SET_OPTIONS PRAGMA_RESET_OPTIONS PRAGMA_PUSH_OPTIONS PRAGMA_POP_OPTIONS PRAGMA_RESTART_SOLVER PRAGMA_PRINT_EFFECTS_GRAPH +%token TYP_APP_LESS TYP_APP_GREATER SUBTYPE EQUALTYPE SUBKIND BY +%token AND ASSERT SYNTH BEGIN ELSE END +%token EXCEPTION FALSE FUN FUNCTION IF IN MODULE DEFAULT +%token MATCH OF +%token FRIEND OPEN REC THEN TRUE TRY TYPE CALC CLASS INSTANCE EFFECT VAL +%token INTRO ELIM +%token INCLUDE +%token WHEN AS RETURNS RETURNS_EQ WITH HASH AMP LPAREN RPAREN LPAREN_RPAREN COMMA LONG_LEFT_ARROW LARROW RARROW +%token IFF IMPLIES CONJUNCTION DISJUNCTION +%token DOT COLON COLON_COLON SEMICOLON +%token QMARK_DOT +%token QMARK +%token EQUALS PERCENT_LBRACK LBRACK_AT LBRACK_AT_AT LBRACK_AT_AT_AT DOT_LBRACK +%token DOT_LENS_PAREN_LEFT DOT_LPAREN DOT_LBRACK_BAR LBRACK LBRACK_BAR LBRACE_BAR LBRACE BANG_LBRACE +%token BAR_RBRACK BAR_RBRACE UNDERSCORE LENS_PAREN_LEFT LENS_PAREN_RIGHT +%token SEQ_BANG_LBRACK +%token BAR RBRACK RBRACE DOLLAR +%token PRIVATE REIFIABLE REFLECTABLE REIFY RANGE_OF SET_RANGE_OF LBRACE_COLON_PATTERN +%token PIPE_LEFT PIPE_RIGHT +%token NEW_EFFECT SUB_EFFECT LAYERED_EFFECT POLYMONADIC_BIND POLYMONADIC_SUBCOMP SPLICE SPLICET SQUIGGLY_RARROW TOTAL +%token REQUIRES ENSURES DECREASES LBRACE_COLON_WELL_FOUNDED +%token MINUS COLON_EQUALS QUOTE BACKTICK_AT BACKTICK_HASH +%token BACKTICK UNIV_HASH +%token BACKTICK_PERC + +%token OPPREFIX OPINFIX0a OPINFIX0b OPINFIX0c OPINFIX0d OPINFIX1 OPINFIX2 OPINFIX3 OPINFIX4 +%token OP_MIXFIX_ASSIGNMENT OP_MIXFIX_ACCESS +%token BLOB +%token USE_LANG_BLOB + +/* These are artificial */ +%token EOF + +%nonassoc THEN +%nonassoc ELSE + +%nonassoc ASSERT +%nonassoc EQUALTYPE +%nonassoc SUBTYPE +%nonassoc BY + +%right COLON_COLON +%right AMP + +%nonassoc COLON_EQUALS +%left OPINFIX0a +%left OPINFIX0b +%left OPINFIX0c EQUALS +%left OPINFIX0d +%left PIPE_RIGHT +%right PIPE_LEFT +%right OPINFIX1 +%left OPINFIX2 MINUS QUOTE +%left OPINFIX3 +%left BACKTICK +%right OPINFIX4 + +%start inputFragment +%start term +%start warn_error_list +%start oneDeclOrEOF +%type inputFragment +%type <(FStarC_Parser_AST.decl list * FStarC_Sedlexing.snap option) option> oneDeclOrEOF +%type term +%type lident +%type <(FStarC_Errors_Codes.error_flag * string) list> warn_error_list +%% + +(* inputFragment is used at the same time for whole files and fragment of codes (for interactive mode) *) +inputFragment: + | decls=list(decl) EOF + { + as_frag (List.flatten decls) + } + +oneDeclOrEOF: + | EOF { None } + | ds=idecl { Some ds } + +idecl: + | d=decl snap=startOfNextDeclToken + { d, snap } + +%public +startOfNextDeclToken: + | EOF { None } + | pragmaStartToken { None } + | LBRACK_AT { None } (* Attribute start *) + | LBRACK_AT_AT { None } (* Attribute start *) + | qualifier { None } + | CLASS { None } + | INSTANCE { None } + | OPEN { None } + | FRIEND { None } + | INCLUDE { None } + | MODULE { None } + | TYPE { None } + | EFFECT { None } + | LET { None } + | VAL { None } + | SPLICE { None } + | SPLICET { None } + | EXCEPTION { None } + | NEW_EFFECT { None } + | LAYERED_EFFECT { None } + | SUB_EFFECT { None } + | POLYMONADIC_BIND { None } + | POLYMONADIC_SUBCOMP { None } + | b=BLOB { let _, _, _, snap = b in Some snap } + | b=USE_LANG_BLOB { let _, _, _, snap = b in Some snap } + +pragmaStartToken: + | PRAGMA_SHOW_OPTIONS + { () } + | PRAGMA_SET_OPTIONS + { () } + | PRAGMA_RESET_OPTIONS + { () } + | PRAGMA_PUSH_OPTIONS + { () } + | PRAGMA_POP_OPTIONS + { () } + | PRAGMA_RESTART_SOLVER + { () } + | PRAGMA_PRINT_EFFECTS_GRAPH + { () } + +/******************************************************************************/ +/* Top level declarations */ +/******************************************************************************/ + +pragma: + | PRAGMA_SHOW_OPTIONS + { ShowOptions } + | PRAGMA_SET_OPTIONS s=string + { SetOptions s } + | PRAGMA_RESET_OPTIONS s_opt=string? + { ResetOptions s_opt } + | PRAGMA_PUSH_OPTIONS s_opt=string? + { PushOptions s_opt } + | PRAGMA_POP_OPTIONS + { PopOptions } + | PRAGMA_RESTART_SOLVER + { RestartSolver } + | PRAGMA_PRINT_EFFECTS_GRAPH + { PrintEffectsGraph } + +attribute: + | LBRACK_AT x = list(atomicTerm) RBRACK + { + let _ = + match x with + | _::_::_ -> + log_issue_text (rr $loc) Warning_DeprecatedAttributeSyntax old_attribute_syntax_warning + | _ -> () in + x + } + | LBRACK_AT_AT x = semiColonTermList RBRACK + { x } + +%public +decoration: + | x=attribute + { DeclAttributes x } + | x=qualifier + { Qualifier x } + +%public +decl: + | ASSUME lid=uident COLON phi=formula + { [mk_decl (Assume(lid, phi)) (rr $loc) [ Qualifier Assumption ]] } + + | blob=USE_LANG_BLOB + { + let ext_name, contents, pos, snap = blob in + (* blob_range is the full range of the blob, starting from the #lang pragma *) + let blob_range = rr (snd snap, snd $loc) in + (* extension_syntax_start_range is where the extension syntax starts not including + the "#lang ident" prefix *) + let extension_syntax_start_range = (rr (pos, pos)) in + let ds = parse_use_lang_blob ext_name contents blob_range extension_syntax_start_range in + mk_decl (UseLangDecls ext_name) extension_syntax_start_range [] :: ds + } + + | ds=list(decoration) decl=rawDecl + { [mk_decl decl (rr $loc(decl)) ds] } + + | ds=list(decoration) decl=typeclassDecl + { let (decl, extra_attrs) = decl in + let d = mk_decl decl (rr $loc(decl)) ds in + [{ d with attrs = extra_attrs @ d.attrs }] + } + +%public +noDecorationDecl: + | ASSUME lid=uident COLON phi=formula + { [mk_decl (Assume(lid, phi)) (rr $loc) [ Qualifier Assumption ]] } + + | blob=USE_LANG_BLOB + { + let ext_name, contents, pos, snap = blob in + (* blob_range is the full range of the blob, starting from the #lang pragma *) + let blob_range = rr (snd snap, snd $loc) in + (* extension_syntax_start_range is where the extension syntax starts not including + the "#lang ident" prefix *) + let extension_syntax_start_range = (rr (pos, pos)) in + let ds = parse_use_lang_blob ext_name contents blob_range extension_syntax_start_range in + mk_decl (UseLangDecls ext_name) extension_syntax_start_range [] :: ds + } + +%public +decoratableDecl: + | decl=rawDecl + { [mk_decl decl (rr $loc(decl)) []] } + + | decl=typeclassDecl + { let (decl, extra_attrs) = decl in + let d = mk_decl decl (rr $loc(decl)) [] in + [{ d with attrs = extra_attrs }] + } + + +typeclassDecl: + | CLASS tcdef=typeDecl + { + (* Only a single type decl allowed, but construct it the same as for multiple ones. + * Only difference is the `true` below marking that this a class so desugaring + * adds the needed %splice. *) + let d = Tycon (false, true, [tcdef]) in + + (* No attrs yet, but perhaps we want a `class` attribute *) + (d, []) + } + + | INSTANCE q=letqualifier lb=letbinding + { + (* Making a single letbinding *) + let r = rr $loc in + let lbs = focusLetBindings [lb] r in (* lbs is a singleton really *) + let d = TopLevelLet(q, lbs) in + + (* Slapping a `tcinstance` attribute to it *) + let at = mk_term (Var tcinstance_lid) r Type_level in + + (d, [at]) + } + + | INSTANCE VAL lid=lidentOrOperator bs=binders COLON t=typ + { + (* Some duplication from rawDecl... *) + let r = rr $loc in + let t = match bs with + | [] -> t + | bs -> mk_term (Product(bs, t)) (rr2 $loc(bs) $loc(t)) Type_level + in + let d = Val(lid, t) in + (* Slapping a `tcinstance` attribute to it *) + let at = mk_term (Var tcinstance_lid) r Type_level in + + (d, [at]) + } + +restriction: + | LBRACE ids=separated_list(COMMA, id=ident renamed=option(AS id=ident {id} ) {(id, renamed)}) RBRACE + { FStarC_Syntax_Syntax.AllowList ids } + | { FStarC_Syntax_Syntax.Unrestricted } + +rawDecl: + | p=pragma + { Pragma p } + | OPEN uid=quident r=restriction + { Open (uid, r) } + | FRIEND uid=quident + { Friend uid } + | INCLUDE uid=quident r=restriction + { Include (uid, r) } + | MODULE UNDERSCORE EQUALS uid=quident + { Open (uid, FStarC_Syntax_Syntax.AllowList []) } + | MODULE uid1=uident EQUALS uid2=quident + { ModuleAbbrev(uid1, uid2) } + | MODULE q=qlident + { raise_error_text (rr $loc(q)) Fatal_SyntaxError "Syntax error: expected a module name" } + | MODULE uid=quident + { TopLevelModule uid } + | TYPE tcdefs=separated_nonempty_list(AND,typeDecl) + { Tycon (false, false, tcdefs) } + | EFFECT uid=uident tparams=typars EQUALS t=typ + { Tycon(true, false, [(TyconAbbrev(uid, tparams, None, t))]) } + | LET q=letqualifier lbs=separated_nonempty_list(AND, letbinding) + { + let r = rr $loc in + let lbs = focusLetBindings lbs r in + if q <> Rec && List.length lbs <> 1 + then raise_error_text r Fatal_MultipleLetBinding "Unexpected multiple let-binding (Did you forget some rec qualifier ?)"; + TopLevelLet(q, lbs) + } + | VAL c=constant + { + (* This is just to provide a better error than "syntax error" *) + raise_error_text (rr $loc) Fatal_SyntaxError "Syntax error: constants are not allowed in val declarations" + } + | VAL lid=lidentOrOperator bs=binders COLON t=typ + { + let t = match bs with + | [] -> t + | bs -> mk_term (Product(bs, t)) (rr2 $loc(bs) $loc(t)) Type_level + in Val(lid, t) + } + | SPLICE LBRACK ids=separated_list(SEMICOLON, ident) RBRACK t=thunk(atomicTerm) + { Splice (false, ids, t) } + | SPLICET LBRACK ids=separated_list(SEMICOLON, ident) RBRACK t=atomicTerm + { Splice (true, ids, t) } + | EXCEPTION lid=uident t_opt=option(OF t=typ {t}) + { Exception(lid, t_opt) } + | NEW_EFFECT ne=newEffect + { NewEffect ne } + | LAYERED_EFFECT ne=effectDefinition + { LayeredEffect ne } + | EFFECT ne=layeredEffectDefinition + { LayeredEffect ne } + | SUB_EFFECT se=subEffect + { SubEffect se } + | POLYMONADIC_BIND b=polymonadic_bind + { Polymonadic_bind b } + | POLYMONADIC_SUBCOMP c=polymonadic_subcomp + { Polymonadic_subcomp c } + | blob=BLOB + { + let ext_name, contents, pos, snap = blob in + (* blob_range is the full range of the blob, including the enclosing ``` *) + let blob_range = rr (snd snap, snd $loc) in + (* extension_syntax_start_range is where the extension syntax starts not including + the "```ident" prefix *) + let extension_syntax_start_range = (rr (pos, pos)) in + parse_extension_blob ext_name contents blob_range extension_syntax_start_range + } + + +typeDecl: + (* TODO : change to lident with stratify *) + | lid=ident tparams=typars ascr_opt=ascribeKind? tcdef=typeDefinition + { tcdef lid tparams ascr_opt } + +typars: + | x=tvarinsts { x } + | x=binders { x } + +tvarinsts: + | TYP_APP_LESS tvs=separated_nonempty_list(COMMA, tvar) TYP_APP_GREATER + { map (fun tv -> mk_binder (TVariable(tv)) (range_of_id tv) Kind None) tvs } + +%inline recordDefinition: + | LBRACE record_field_decls=right_flexible_nonempty_list(SEMICOLON, recordFieldDecl) RBRACE + { record_field_decls } + +typeDefinition: + | { (fun id binders kopt -> check_id id; TyconAbstract(id, binders, kopt)) } + | EQUALS t=typ + { (fun id binders kopt -> check_id id; TyconAbbrev(id, binders, kopt, t)) } + /* A documentation on the first branch creates a conflict with { x with a = ... }/{ a = ... } */ + | EQUALS attrs_opt=ioption(binderAttributes) record_field_decls=recordDefinition + { (fun id binders kopt -> check_id id; TyconRecord(id, binders, kopt, none_to_empty_list attrs_opt, record_field_decls)) } + (* having the first BAR optional using left-flexible list creates a s/r on FSDOC since any decl can be preceded by a FSDOC *) + | EQUALS ct_decls=list(constructorDecl) + { (fun id binders kopt -> check_id id; TyconVariant(id, binders, kopt, ct_decls)) } + +recordFieldDecl: + | qualified_lid=aqualifiedWithAttrs(lidentOrOperator) COLON t=typ + { + let (qual, attrs), lid = qualified_lid in + (lid, qual, attrs, t) + } + +constructorPayload: + | COLON t=typ {VpArbitrary t} + | OF t=typ {VpOfNotation t} + | fields=recordDefinition opt=option(COLON t=typ {t}) {VpRecord(fields, opt)} + +constructorDecl: + | BAR attrs_opt=ioption(binderAttributes) + uid=uident + payload=option(constructorPayload) + { uid, payload, none_to_empty_list attrs_opt } + +attr_letbinding: + | attr=ioption(attribute) AND lb=letbinding + { attr, lb } + +letoperatorbinding: + | pat=tuplePattern ascr_opt=ascribeTyp? tm=option(EQUALS tm=term {tm}) + { + let h tm + = ( ( match ascr_opt with + | None -> pat + | Some t -> mk_pattern (PatAscribed(pat, t)) (rr2 $loc(pat) $loc(ascr_opt)) ) + , tm) + in + match pat.pat, tm with + | _ , Some tm -> h tm + | PatVar (v, _, _), None -> + let v = lid_of_ns_and_id [] v in + h (mk_term (Var v) (rr $loc(pat)) Expr) + | _ -> raise_error_text (rr $loc(ascr_opt)) Fatal_SyntaxError "Syntax error: let-punning expects a name, not a pattern" + } + +letbinding: + | focus_opt=maybeFocus lid=lidentOrOperator lbp=nonempty_list(patternOrMultibinder) ascr_opt=ascribeTyp? EQUALS tm=term + { + let pat = mk_pattern (PatVar(lid, None, [])) (rr $loc(lid)) in + let pat = mk_pattern (PatApp (pat, flatten lbp)) (rr2 $loc(focus_opt) $loc(lbp)) in + let pos = rr2 $loc(focus_opt) $loc(tm) in + match ascr_opt with + | None -> (focus_opt, (pat, tm)) + | Some t -> (focus_opt, (mk_pattern (PatAscribed(pat, t)) pos, tm)) + } + | focus_opt=maybeFocus pat=tuplePattern ascr=ascribeTyp eq=EQUALS tm=term + { focus_opt, (mk_pattern (PatAscribed(pat, ascr)) (rr2 $loc(focus_opt) $loc(eq)), tm) } + | focus_opt=maybeFocus pat=tuplePattern EQUALS tm=term + { focus_opt, (pat, tm) } + +/******************************************************************************/ +/* Effects */ +/******************************************************************************/ + +newEffect: + | ed=effectRedefinition + | ed=effectDefinition + { ed } + +effectRedefinition: + | lid=uident EQUALS t=simpleTerm + { RedefineEffect(lid, [], t) } + +effectDefinition: + | LBRACE lid=uident bs=binders COLON typ=tmArrow(tmNoEq) + WITH eds=separated_nonempty_list(SEMICOLON, effectDecl) + RBRACE + { DefineEffect(lid, bs, typ, eds) } + +layeredEffectDefinition: + | LBRACE lid=uident bs=binders WITH r=tmNoEq RBRACE + { + let typ = (* bs -> Effect *) + let first_b, last_b = + match bs with + | [] -> + raise_error_text (range_of_id lid) Fatal_SyntaxError + "Syntax error: unexpected empty binders list in the layered effect definition" + | _ -> hd bs, last bs in + let r = union_ranges first_b.brange last_b.brange in + mk_term (Product (bs, mk_term (Name (lid_of_str "Effect")) r Type_level)) r Type_level in + let rec decls (r:term) = + match r.tm with + | Paren r -> decls r + | Record (None, flds) -> + flds |> List.map (fun (lid, t) -> + mk_decl (Tycon (false, + false, + [TyconAbbrev (ident_of_lid lid, [], None, t)])) + t.range []) + | _ -> + raise_error_text r.range Fatal_SyntaxError + "Syntax error: layered effect combinators should be declared as a record" + in + DefineEffect (lid, [], typ, decls r) } + +effectDecl: + | lid=lident action_params=binders EQUALS t=simpleTerm + { mk_decl (Tycon (false, false, [TyconAbbrev(lid, action_params, None, t)])) (rr $loc) [] } + +subEffect: + | src_eff=quident SQUIGGLY_RARROW tgt_eff=quident EQUALS lift=simpleTerm + { { msource = src_eff; mdest = tgt_eff; lift_op = NonReifiableLift lift; braced=false } } + | src_eff=quident SQUIGGLY_RARROW tgt_eff=quident + LBRACE + lift1=separated_pair(IDENT, EQUALS, simpleTerm) + lift2_opt=ioption(separated_pair(SEMICOLON id=IDENT {id}, EQUALS, simpleTerm)) + /* might be nice for homogeneity if possible : ioption(SEMICOLON) */ + RBRACE + { + match lift2_opt with + | None -> + begin match lift1 with + | ("lift", lift) -> + { msource = src_eff; mdest = tgt_eff; lift_op = LiftForFree lift; braced=true } + | ("lift_wp", lift_wp) -> + { msource = src_eff; mdest = tgt_eff; lift_op = NonReifiableLift lift_wp; braced=true } + | _ -> + raise_error_text (rr $loc) Fatal_UnexpectedIdentifier "Unexpected identifier; expected {'lift', and possibly 'lift_wp'}" + end + | Some (id2, tm2) -> + let (id1, tm1) = lift1 in + let lift, lift_wp = match (id1, id2) with + | "lift_wp", "lift" -> tm1, tm2 + | "lift", "lift_wp" -> tm2, tm1 + | _ -> raise_error_text (rr $loc) Fatal_UnexpectedIdentifier "Unexpected identifier; expected {'lift', 'lift_wp'}" + in + { msource = src_eff; mdest = tgt_eff; lift_op = ReifiableLift (lift, lift_wp); braced=true } + } + +polymonadic_bind: + | LPAREN m_eff=quident COMMA n_eff=quident RPAREN PIPE_RIGHT p_eff=quident EQUALS bind=simpleTerm + { (m_eff, n_eff, p_eff, bind) } + +polymonadic_subcomp: + | m_eff=quident SUBTYPE n_eff=quident EQUALS subcomp=simpleTerm + { (m_eff, n_eff, subcomp) } + + +/******************************************************************************/ +/* Qualifiers, tags, ... */ +/******************************************************************************/ + +qualifier: + | ASSUME { Assumption } + | INLINE { + raise_error_text (rr $loc) Fatal_InlineRenamedAsUnfold + "The 'inline' qualifier has been renamed to 'unfold'" + } + | UNFOLDABLE { + raise_error_text (rr $loc) Fatal_UnfoldableDeprecated + "The 'unfoldable' qualifier is no longer denotable; it is the default qualifier so just omit it" + } + | INLINE_FOR_EXTRACTION { + Inline_for_extraction + } + | UNFOLD { + Unfold_for_unification_and_vcgen + } + | IRREDUCIBLE { Irreducible } + | NOEXTRACT { NoExtract } + | DEFAULT { DefaultEffect } + | TOTAL { TotalEffect } + | PRIVATE { Private } + + | NOEQUALITY { Noeq } + | UNOPTEQUALITY { Unopteq } + | NEW { New } + | LOGIC { log_issue_text (rr $loc) Warning_logicqualifier logic_qualifier_deprecation_warning; + Logic } + | OPAQUE { Opaque } + | REIFIABLE { Reifiable } + | REFLECTABLE { Reflectable } + +maybeFocus: + | b=boption(SQUIGGLY_RARROW) { b } + +letqualifier: + | REC { Rec } + | { NoLetQualifier } + +(* + * AR: this should be generalized to: + * (a) allow attributes on non-implicit binders + * note that in the [@@ case, we choose the Implicit aqual + *) +aqual: + | HASH LBRACK t=thunk(term) RBRACK { mk_meta_tac t } + | HASH { Implicit } + | DOLLAR { Equality } + +binderAttributes: + | LBRACK_AT_AT_AT t=semiColonTermList RBRACK { t } + +/******************************************************************************/ +/* Patterns, binders */ +/******************************************************************************/ + +(* disjunction should be allowed in nested patterns *) +disjunctivePattern: + | pats=separated_nonempty_list(BAR, tuplePattern) { pats } + +%public +tuplePattern: + | pats=separated_nonempty_list(COMMA, constructorPattern) + { match pats with | [x] -> x | l -> mk_pattern (PatTuple (l, false)) (rr $loc) } + +constructorPattern: + | pat=constructorPattern COLON_COLON pats=constructorPattern + { mk_pattern (consPat (rr $loc(pats)) pat pats) (rr $loc) } + | uid=quident args=nonempty_list(atomicPattern) + { + let head_pat = mk_pattern (PatName uid) (rr $loc(uid)) in + mk_pattern (PatApp (head_pat, args)) (rr $loc) + } + | pat=atomicPattern + { pat } + +atomicPattern: + | LPAREN pat=tuplePattern COLON t=simpleArrow phi_opt=refineOpt RPAREN + { + let pos_t = rr2 $loc(pat) $loc(t) in + let pos = rr $loc in + mkRefinedPattern pat t true phi_opt pos_t pos + } + | LBRACK pats=separated_list(SEMICOLON, tuplePattern) RBRACK + { mk_pattern (PatList pats) (rr2 $loc($1) $loc($3)) } + | LBRACE record_pat=right_flexible_list(SEMICOLON, fieldPattern) RBRACE + { mk_pattern (PatRecord record_pat) (rr $loc) } + | LENS_PAREN_LEFT pat0=constructorPattern COMMA pats=separated_nonempty_list(COMMA, constructorPattern) LENS_PAREN_RIGHT + { mk_pattern (PatTuple(pat0::pats, true)) (rr $loc) } + | LPAREN pat=tuplePattern RPAREN { pat } + | tv=tvar { mk_pattern (PatTvar (tv, None, [])) (rr $loc(tv)) } + | LPAREN op=operator RPAREN + { mk_pattern (PatOp op) (rr $loc) } + | UNDERSCORE + { mk_pattern (PatWild (None, [])) (rr $loc) } + | HASH UNDERSCORE + { mk_pattern (PatWild (Some Implicit, [])) (rr $loc) } + | c=constant + { mk_pattern (PatConst c) (rr $loc(c)) } + | tok=MINUS c=constant + { let r = rr2 $loc(tok) $loc(c) in + let c = + match c with + | Const_int (s, swopt) -> + (match swopt with + | None + | Some (Signed, _) -> Const_int ("-" ^ s, swopt) + | _ -> raise_error_text r Fatal_SyntaxError "Syntax_error: negative integer constant with unsigned width") + | _ -> raise_error_text r Fatal_SyntaxError "Syntax_error: negative constant that is not an integer" + in + mk_pattern (PatConst c) r } + | BACKTICK_PERC q=atomicTerm + { mk_pattern (PatVQuote q) (rr $loc) } + | qual_id=aqualifiedWithAttrs(lident) + { + let (aqual, attrs), lid = qual_id in + mk_pattern (PatVar (lid, aqual, attrs)) (rr $loc(qual_id)) } + | uid=quident + { mk_pattern (PatName uid) (rr $loc(uid)) } + +fieldPattern: + | p = separated_pair(qlident, EQUALS, tuplePattern) + { p } + | lid=qlident + { lid, mk_pattern (PatVar (ident_of_lid lid, None, [])) (rr $loc(lid)) } + + (* (x : t) is already covered by atomicPattern *) + (* we do *NOT* allow _ in multibinder () since it creates reduce/reduce conflicts when*) + (* preprocessing to ocamlyacc/fsyacc (which is expected since the macro are expanded) *) +patternOrMultibinder: + | LBRACE_BAR id=lidentOrUnderscore COLON t=simpleArrow BAR_RBRACE + { let r = rr $loc in + let w = mk_pattern (PatVar (id, Some TypeClassArg, [])) r in + let asc = (t, None) in + [mk_pattern (PatAscribed(w, asc)) r] + } + + | LBRACE_BAR t=simpleArrow BAR_RBRACE + { let r = rr $loc in + let id = gen r in + let w = mk_pattern (PatVar (id, Some TypeClassArg, [])) r in + let asc = (t, None) in + [mk_pattern (PatAscribed(w, asc)) r] + } + | pat=atomicPattern { [pat] } + | LPAREN qual_id0=aqualifiedWithAttrs(lident) qual_ids=nonempty_list(aqualifiedWithAttrs(lident)) COLON t=simpleArrow r=refineOpt RPAREN + { + let pos = rr $loc in + let t_pos = rr $loc(t) in + let qual_ids = qual_id0 :: qual_ids in + List.map (fun ((aq, attrs), x) -> mkRefinedPattern (mk_pattern (PatVar (x, aq, attrs)) pos) t false r t_pos pos) qual_ids + } + +binder: + | aqualifiedWithAttrs_lid=aqualifiedWithAttrs(lidentOrUnderscore) + { + let (q, attrs), lid = aqualifiedWithAttrs_lid in + mk_binder_with_attrs (Variable lid) (rr $loc(aqualifiedWithAttrs_lid)) Type_level q attrs + } + + | tv=tvar { mk_binder (TVariable tv) (rr $loc) Kind None } + (* small regression here : fun (=x : t) ... is not accepted anymore *) + +%public +multiBinder: + | LBRACE_BAR id=lidentOrUnderscore COLON t=simpleArrow BAR_RBRACE + { let r = rr $loc in + [mk_binder (Annotated (id, t)) r Type_level (Some TypeClassArg)] + } + + | LBRACE_BAR t=simpleArrow BAR_RBRACE + { let r = rr $loc in + let id = gen r in + [mk_binder (Annotated (id, t)) r Type_level (Some TypeClassArg)] + } + + | LPAREN qual_ids=nonempty_list(aqualifiedWithAttrs(lidentOrUnderscore)) COLON t=simpleArrow r=refineOpt RPAREN + { + let should_bind_var = match qual_ids with | [ _ ] -> true | _ -> false in + List.map (fun ((q, attrs), x) -> + mkRefinedBinder x t should_bind_var r (rr $loc) q attrs) qual_ids + } + + | LPAREN_RPAREN + { + let r = rr $loc in + let unit_t = mk_term (Var (lid_of_ids [(mk_ident("unit", r))])) r Un in + [mk_binder (Annotated (gen r, unit_t)) r Un None] + } + + | b=binder { [b] } + +%public +binders: bss=list(bs=multiBinder {bs}) { flatten bss } + +aqualifiedWithAttrs(X): + | aq=aqual attrs=binderAttributes x=X { (Some aq, attrs), x } + | aq=aqual x=X { (Some aq, []), x } + | attrs=binderAttributes x=X { (None, attrs), x } + | x=X { (None, []), x } + +/******************************************************************************/ +/* Identifiers, module paths */ +/******************************************************************************/ + +%public +qlident: + | ids=path(lident) { lid_of_ids ids } + +%public +quident: + | ids=path(uident) { lid_of_ids ids } + +path(Id): + | id=Id { [id] } + | uid=uident DOT p=path(Id) { uid::p } + +ident: + | x=lident { x } + | x=uident { x } + +qlidentOrOperator: + | qid=qlident { qid } + | LPAREN id=operator RPAREN + { lid_of_ns_and_id [] (id_of_text (compile_op' (string_of_id id) (range_of_id id))) } + +%inline lidentOrOperator: + | id=lident { id } + | LPAREN id=operator RPAREN + { mk_ident (compile_op' (string_of_id id) (range_of_id id), range_of_id id) } + +matchMaybeOp: + | MATCH {None} + | op=MATCH_OP { Some (mk_ident ("let" ^ op, rr $loc(op))) } + +ifMaybeOp: + | IF {None} + | op=IF_OP { Some (mk_ident ("let" ^ op, rr $loc(op))) } + +%public +lidentOrUnderscore: + | id=IDENT { mk_ident(id, rr $loc(id))} + | UNDERSCORE { gen (rr $loc) } + +%public +lident: + | id=IDENT { mk_ident(id, rr $loc(id))} + +uident: + | id=NAME { mk_ident(id, rr $loc(id)) } + +tvar: + | tv=TVAR { mk_ident(tv, rr $loc(tv)) } + + +/******************************************************************************/ +/* Types and terms */ +/******************************************************************************/ + +thunk(X): | t=X { mk_term (Abs ([mk_pattern (PatWild (None, [])) (rr $loc)], t)) (rr $loc) Expr } + +thunk2(X): + | t=X + { let u = mk_term (Const Const_unit) (rr $loc) Expr in + let t = mk_term (Seq (u, t)) (rr $loc) Expr in + mk_term (Abs ([mk_pattern (PatWild (None, [])) (rr $loc)], t)) (rr $loc) Expr } + +ascribeTyp: + | COLON t=tmArrow(tmNoEq) tacopt=option(BY tactic=thunk(trailingTerm) {tactic}) { t, tacopt } + +(* Remove for stratify *) +ascribeKind: + | COLON k=kind { k } + +(* Remove for stratify *) +kind: + | t=tmArrow(tmNoEq) { {t with level=Kind} } + + +term: + | e=noSeqTerm + { e } + | e1=noSeqTerm SEMICOLON e2=term + { mk_term (Seq(e1, e2)) (rr2 $loc(e1) $loc(e2)) Expr } +(* Added this form for sequencing; *) +(* but it results in an additional shift/reduce conflict *) +(* ... which is actually be benign, since the same conflict already *) +(* exists for the previous production *) + | e1=noSeqTerm op=SEMICOLON_OP e2=term + { let t = match op with + | Some op -> + let op = mk_ident ("let" ^ op, rr $loc(op)) in + let pat = mk_pattern (PatWild(None, [])) (rr $loc(op)) in + LetOperator ([(op, pat, e1)], e2) + | None -> + log_issue_text (rr $loc) Warning_DeprecatedLightDoNotation do_notation_deprecation_warning; + Bind(gen (rr $loc(op)), e1, e2) + in mk_term t (rr2 $loc(e1) $loc(e2)) Expr + } + | x=lidentOrUnderscore LONG_LEFT_ARROW e1=noSeqTerm SEMICOLON e2=term + { log_issue_text (rr $loc) Warning_DeprecatedLightDoNotation do_notation_deprecation_warning; + mk_term (Bind(x, e1, e2)) (rr2 $loc(x) $loc(e2)) Expr } + +match_returning: + | as_opt=option(AS i=lident {i}) RETURNS t=tmIff {as_opt,t,false} + | as_opt=option(AS i=lident {i}) RETURNS_EQ t=tmIff {as_opt,t,true} + +%public +noSeqTerm: + | t=typ { t } + | e=tmIff SUBTYPE t=tmIff + { mk_term (Ascribed(e,{t with level=Expr},None,false)) (rr $loc(e)) Expr } + | e=tmIff SUBTYPE t=tmIff BY tactic=thunk(typ) + { mk_term (Ascribed(e,{t with level=Expr},Some tactic,false)) (rr2 $loc(e) $loc(tactic)) Expr } + | e=tmIff EQUALTYPE t=tmIff + { + log_issue_text (rr $loc) Warning_BleedingEdge_Feature + "Equality type ascriptions is an experimental feature subject to redesign in the future"; + mk_term (Ascribed(e,{t with level=Expr},None,true)) (rr $loc(e)) Expr + } + | e=tmIff EQUALTYPE t=tmIff BY tactic=thunk(typ) + { + log_issue_text (rr $loc) Warning_BleedingEdge_Feature + "Equality type ascriptions is an experimental feature subject to redesign in the future"; + mk_term (Ascribed(e,{t with level=Expr},Some tactic,true)) (rr2 $loc(e) $loc(tactic)) Expr + } + | e1=atomicTermNotQUident op_expr=dotOperator LARROW e3=noSeqTerm + { + let (op, e2, _) = op_expr in + let opid = mk_ident (string_of_id op ^ "<-", range_of_id op) in + mk_term (Op(opid, [ e1; e2; e3 ])) (rr2 $loc(e1) $loc(e3)) Expr + } + | REQUIRES t=typ + { mk_term (Requires(t, None)) (rr2 $loc($1) $loc(t)) Type_level } + | ENSURES t=typ + { mk_term (Ensures(t, None)) (rr2 $loc($1) $loc(t)) Type_level } + | DECREASES t=typ + { mk_term (Decreases (t, None)) (rr2 $loc($1) $loc(t)) Type_level } + | DECREASES LBRACE_COLON_WELL_FOUNDED t=noSeqTerm RBRACE + (* + * decreases clause with relation is written as e1 e2, + * where e1 is a relation and e2 is a term + * + * this is parsed as an app node, so we destruct the app node + *) + { match t.tm with + | App (t1, t2, _) -> + let ot = mk_term (WFOrder (t1, t2)) (rr2 $loc(t) $loc(t)) Type_level in + mk_term (Decreases (ot, None)) (rr2 $loc($1) $loc($4)) Type_level + | _ -> + raise_error_text (rr $loc(t)) Fatal_SyntaxError + "Syntax error: To use well-founded relations, write e1 e2" + } + + | ATTRIBUTES es=nonempty_list(atomicTerm) + { mk_term (Attributes es) (rr2 $loc($1) $loc(es)) Type_level } + | op=ifMaybeOp e1=noSeqTerm ret_opt=option(match_returning) THEN e2=noSeqTerm ELSE e3=noSeqTerm + { mk_term (If(e1, op, ret_opt, e2, e3)) (rr2 $loc(op) $loc(e3)) Expr } + | op=ifMaybeOp e1=noSeqTerm ret_opt=option(match_returning) THEN e2=noSeqTerm + { + let e3 = mk_term (Const Const_unit) (rr2 $loc(op) $loc(e2)) Expr in + mk_term (If(e1, op, ret_opt, e2, e3)) (rr2 $loc(op) $loc(e2)) Expr + } + | TRY e1=term WITH pbs=left_flexible_nonempty_list(BAR, patternBranch) + { + let branches = focusBranches (pbs) (rr2 $loc($1) $loc(pbs)) in + mk_term (TryWith(e1, branches)) (rr2 $loc($1) $loc(pbs)) Expr + } + | op=matchMaybeOp e=term ret_opt=option(match_returning) WITH pbs=left_flexible_list(BAR, pb=patternBranch {pb}) + { + let branches = focusBranches pbs (rr2 $loc(op) $loc(pbs)) in + mk_term (Match(e, op, ret_opt, branches)) (rr2 $loc(op) $loc(pbs)) Expr + } + | LET OPEN t=term IN e=term + { + match t.tm with + | Ascribed(r, rty, None, _) -> + mk_term (LetOpenRecord(r, rty, e)) (rr2 $loc($1) $loc(e)) Expr + + | Name uid -> + mk_term (LetOpen(uid, e)) (rr2 $loc($1) $loc(e)) Expr + + | _ -> + raise_error_text (rr $loc(t)) Fatal_SyntaxError + "Syntax error: local opens expects either opening\n\ + a module or namespace using `let open T in e`\n\ + or, a record type with `let open e <: t in e'`" + } + + | attrs=ioption(attribute) + LET q=letqualifier lb=letbinding lbs=list(attr_letbinding) IN e=term + { + let lbs = (attrs, lb)::lbs in + let lbs = focusAttrLetBindings lbs (rr2 $loc(q) $loc(lb)) in + mk_term (Let(q, lbs, e)) (rr $loc) Expr + } + | op=let_op b=letoperatorbinding lbs=list(op=and_op b=letoperatorbinding {(op, b)}) IN e=term + { let lbs = (op, b)::lbs in + mk_term (LetOperator ( List.map (fun (op, (pat, tm)) -> (op, pat, tm)) lbs + , e)) (rr2 $loc(op) $loc(e)) Expr + } + | FUNCTION pbs=left_flexible_nonempty_list(BAR, patternBranch) + { + let branches = focusBranches pbs (rr2 $loc($1) $loc(pbs)) in + mk_function branches (rr $loc) (rr2 $loc($1) $loc(pbs)) + } + | a=ASSUME e=noSeqTerm + { let a = set_lid_range assume_lid (rr $loc(a)) in + mkExplicitApp (mk_term (Var a) (rr $loc(a)) Expr) [e] (rr $loc) + } + + | a=ASSERT e=noSeqTerm + { + let a = set_lid_range assert_lid (rr $loc(a)) in + mkExplicitApp (mk_term (Var a) (rr $loc(a)) Expr) [e] (rr $loc) + } + + | a=ASSERT e=noSeqTerm BY tactic=thunk2(typ) + { + let a = set_lid_range assert_by_tactic_lid (rr $loc(a)) in + mkExplicitApp (mk_term (Var a) (rr $loc(a)) Expr) [e; tactic] (rr $loc) + } + + | u=UNDERSCORE BY tactic=thunk(atomicTerm) + { + let a = set_lid_range synth_lid (rr $loc(u)) in + mkExplicitApp (mk_term (Var a) (rr $loc(u)) Expr) [tactic] (rr $loc) + } + + | s=SYNTH tactic=atomicTerm + { + let a = set_lid_range synth_lid (rr $loc(s)) in + mkExplicitApp (mk_term (Var a) (rr $loc(s)) Expr) [tactic] (rr $loc) + } + + | CALC rel=atomicTerm LBRACE init=noSeqTerm SEMICOLON steps=list(calcStep) RBRACE + { + mk_term (CalcProof (rel, init, steps)) (rr2 $loc($1) $loc($7)) Expr + } + + | INTRO FORALL bs=binders DOT p=noSeqTerm WITH e=noSeqTerm + { + mk_term (IntroForall(bs, p, e)) (rr2 $loc($1) $loc(e)) Expr + } + + | INTRO EXISTS bs=binders DOT p=noSeqTerm WITH vs=list(atomicTerm) AND e=noSeqTerm + { + if List.length bs <> List.length vs + then raise_error_text (rr $loc(vs)) Fatal_SyntaxError "Syntax error: expected instantiations for all binders" + else mk_term (IntroExists(bs, p, vs, e)) (rr2 $loc($1) $loc(e)) Expr + } + + | INTRO p=tmFormula IMPLIES q=tmFormula WITH y=singleBinder DOT e=noSeqTerm + { + mk_term (IntroImplies(p, q, y, e)) (rr2 $loc($1) $loc(e)) Expr + } + + | INTRO p=tmFormula DISJUNCTION q=tmConjunction WITH lr=NAME e=noSeqTerm + { + let b = + if lr = "Left" then true + else if lr = "Right" then false + else raise_error_text (rr $loc(lr)) Fatal_SyntaxError "Syntax error: _intro_ \\/ expects either 'Left' or 'Right'" + in + mk_term (IntroOr(b, p, q, e)) (rr2 $loc($1) $loc(e)) Expr + } + + | INTRO p=tmConjunction CONJUNCTION q=tmTuple WITH e1=noSeqTerm AND e2=noSeqTerm + { + mk_term (IntroAnd(p, q, e1, e2)) (rr2 $loc($1) $loc(e2)) Expr + } + + | ELIM FORALL xs=binders DOT p=noSeqTerm WITH vs=list(atomicTerm) + { + mk_term (ElimForall(xs, p, vs)) (rr2 $loc($1) $loc(vs)) Expr + } + + | ELIM EXISTS bs=binders DOT p=noSeqTerm RETURNS q=noSeqTerm WITH y=singleBinder DOT e=noSeqTerm + { + mk_term (ElimExists(bs, p, q, y, e)) (rr2 $loc($1) $loc(e)) Expr + } + + | ELIM p=tmFormula IMPLIES q=tmFormula WITH e=noSeqTerm + { + mk_term (ElimImplies(p, q, e)) (rr2 $loc($1) $loc(e)) Expr + } + + | ELIM p=tmFormula DISJUNCTION q=tmConjunction RETURNS r=noSeqTerm WITH x=singleBinder DOT e1=noSeqTerm AND y=singleBinder DOT e2=noSeqTerm + { + mk_term (ElimOr(p, q, r, x, e1, y, e2)) (rr2 $loc($1) $loc(e2)) Expr + } + + | ELIM p=tmConjunction CONJUNCTION q=tmTuple RETURNS r=noSeqTerm WITH xs=binders DOT e=noSeqTerm + { + match xs with + | [x;y] -> mk_term (ElimAnd(p, q, r, x, y, e)) (rr2 $loc($1) $loc(e)) Expr + } + +singleBinder: + | bs=binders + { + match bs with + | [b] -> b + | _ -> raise_error_text (rr $loc(bs)) Fatal_SyntaxError "Syntax error: expected a single binder" + } + +calcRel: + | i=binop_name { mk_term (Op (i, [])) (rr $loc(i)) Expr } + | BACKTICK id=qlident BACKTICK { mk_term (Var id) (rr $loc) Un } + | t=atomicTerm { t } + +calcStep: + | rel=calcRel LBRACE justif=option(term) RBRACE next=noSeqTerm SEMICOLON + { + let justif = + match justif with + | Some t -> t + | None -> mk_term (Const Const_unit) (rr2 $loc($2) $loc($4)) Expr + in + CalcStep (rel, justif, next) + } + +%inline +typ: + | t=simpleTerm { t } + +%public +%inline quantifier: + | FORALL { fun x -> QForall x } + | EXISTS { fun x -> QExists x} + | op=FORALL_OP + { + let op = mk_ident("forall" ^ op, rr $loc(op)) in + fun (x,y,z) -> QuantOp (op, x, y, z) + } + | op=EXISTS_OP + { + let op = mk_ident("exists" ^ op, rr $loc(op)) in + fun (x,y,z) -> QuantOp (op, x, y, z) + } + +%public +trigger: + | { [] } + | LBRACE_COLON_PATTERN pats=disjunctivePats RBRACE { pats } + +disjunctivePats: + | pats=separated_nonempty_list(DISJUNCTION, conjunctivePat) { pats } + +conjunctivePat: + | pats=separated_nonempty_list(SEMICOLON, appTerm) { pats } + +%inline simpleTerm: + | e=tmIff { e } + +maybeFocusArrow: + | RARROW { false } + | SQUIGGLY_RARROW { true } + +patternBranch: + | pat=disjunctivePattern when_opt=maybeWhen focus=maybeFocusArrow e=term + { + let pat = match pat with + | [p] -> p + | ps -> mk_pattern (PatOr ps) (rr2 $loc(pat) $loc(pat)) + in + (focus, (pat, when_opt, e)) + } + +%inline maybeWhen: + | { None } + | WHEN e=tmFormula { Some e } + + + +tmIff: + | e1=tmImplies tok=IFF e2=tmIff + { mk_term (Op(mk_ident("<==>", rr $loc(tok)), [e1; e2])) (rr2 $loc(e1) $loc(e2)) Formula } + | e=tmImplies { e } + +tmImplies: + | e1=tmArrow(tmFormula) tok=IMPLIES e2=tmImplies + { mk_term (Op(mk_ident("==>", rr $loc(tok)), [e1; e2])) (rr2 $loc(e1) $loc(e2)) Formula } + | e=tmArrow(tmFormula) + { e } + + +(* Tm : either tmFormula, containing EQUALS or tmNoEq, without EQUALS *) +tmArrow(Tm): + | dom=tmArrowDomain(Tm) RARROW tgt=tmArrow(Tm) + { + let ((aq_opt, attrs), dom_tm) = dom in + let b = match extract_named_refinement true dom_tm with + | None -> mk_binder_with_attrs (NoName dom_tm) (rr $loc(dom)) Un aq_opt attrs + | Some (x, t, f) -> mkRefinedBinder x t true f (rr2 $loc(dom) $loc(dom)) aq_opt attrs + in + mk_term (Product([b], tgt)) (rr2 $loc(dom) $loc(tgt)) Un + } + | e=Tm { e } + +simpleArrow: + | dom=simpleArrowDomain RARROW tgt=simpleArrow + { + let ((aq_opt, attrs), dom_tm) = dom in + let b = match extract_named_refinement true dom_tm with + | None -> mk_binder_with_attrs (NoName dom_tm) (rr $loc(dom)) Un aq_opt attrs + | Some (x, t, f) -> mkRefinedBinder x t true f (rr2 $loc(dom) $loc(dom)) aq_opt attrs + in + mk_term (Product([b], tgt)) (rr2 $loc(dom) $loc(tgt)) Un + } + | e=tmEqNoRefinement { e } + +simpleArrowDomain: + | LBRACE_BAR t=tmEqNoRefinement BAR_RBRACE { ((Some TypeClassArg, []), t) } + | aq_opt=ioption(aqual) attrs_opt=ioption(binderAttributes) dom_tm=tmEqNoRefinement { (aq_opt, none_to_empty_list attrs_opt), dom_tm } + +(* Tm already accounts for ( term ), we need to add an explicit case for (#Tm), (#[@@@...]Tm) and ([@@@...]Tm) *) +%inline tmArrowDomain(Tm): + | LBRACE_BAR t=Tm BAR_RBRACE { ((Some TypeClassArg, []), t) } + | LPAREN q=aqual attrs_opt=ioption(binderAttributes) dom_tm=Tm RPAREN { (Some q, none_to_empty_list attrs_opt), dom_tm } + | LPAREN attrs=binderAttributes dom_tm=Tm RPAREN { (None, attrs), dom_tm } + | aq_opt=ioption(aqual) attrs_opt=ioption(binderAttributes) dom_tm=Tm { (aq_opt, none_to_empty_list attrs_opt), dom_tm } + +tmFormula: + | e1=tmFormula tok=DISJUNCTION e2=tmConjunction + { mk_term (Op(mk_ident("\\/", rr $loc(tok)), [e1;e2])) (rr2 $loc(e1) $loc(e2)) Formula } + | e=tmConjunction { e } + +tmConjunction: + | e1=tmConjunction tok=CONJUNCTION e2=tmTuple + { mk_term (Op(mk_ident("/\\", rr $loc(tok)), [e1;e2])) (rr2 $loc(e1) $loc(e2)) Formula } + | e=tmTuple { e } + +tmTuple: + | el=separated_nonempty_list(COMMA, tmEq) + { + match el with + | [x] -> x + | components -> mkTuple components (rr2 $loc(el) $loc(el)) + } + + + +%public +tmEqWith(X): + | e1=tmEqWith(X) tok=EQUALS e2=tmEqWith(X) + { mk_term (Op(mk_ident("=", rr $loc(tok)), [e1; e2])) (rr $loc) Un} + (* non-associativity of COLON_EQUALS is currently not well handled by fsyacc which reports a s/r conflict *) + (* see https:/ /github.com/fsprojects/FsLexYacc/issues/39 *) + | e1=tmEqWith(X) tok=COLON_EQUALS e2=tmEqWith(X) + { mk_term (Op(mk_ident(":=", rr $loc(tok)), [e1; e2])) (rr $loc) Un} + + | e1=tmEqWith(X) op=PIPE_LEFT e2=tmEqWith(X) + { mk_term (Op(mk_ident("<|", rr $loc(op)), [e1; e2])) (rr $loc) Un} + + | e1=tmEqWith(X) op=PIPE_RIGHT e2=tmEqWith(X) + { mk_term (Op(mk_ident("|>", rr $loc(op)), [e1; e2])) (rr $loc) Un} + + + | e1=tmEqWith(X) op=operatorInfix0ad12 e2=tmEqWith(X) + { mk_term (Op(op, [e1; e2])) (rr2 $loc(e1) $loc(e2)) Un} + | e1=tmEqWith(X) tok=MINUS e2=tmEqWith(X) + { mk_term (Op(mk_ident("-", rr $loc(tok)), [e1; e2])) (rr $loc) Un} + | tok=MINUS e=tmEqWith(X) + { mk_uminus e (rr $loc(tok)) (rr $loc) Expr } + | QUOTE e=tmEqWith(X) + { mk_term (Quote (e, Dynamic)) (rr $loc) Un } + | BACKTICK e=tmEqWith(X) + { mk_term (Quote (e, Static)) (rr $loc) Un } + | BACKTICK_AT e=atomicTerm + { let q = mk_term (Quote (e, Dynamic)) (rr $loc) Un in + mk_term (Antiquote q) (rr $loc) Un } + | BACKTICK_HASH e=atomicTerm + { mk_term (Antiquote e) (rr $loc) Un } + | e=tmNoEqWith(X) + { e } + +%inline recordTerm: + | LBRACE e=recordExp RBRACE { e } + +tmNoEqWith(X): + | e1=tmNoEqWith(X) COLON_COLON e2=tmNoEqWith(X) + { consTerm (rr $loc) e1 e2 } + | e1=tmNoEqWith(X) AMP e2=tmNoEqWith(X) + { + let dom = + match extract_named_refinement false e1 with + | Some (x, t, f) -> + let dom = mkRefinedBinder x t true f (rr $loc(e1)) None [] in + Inl dom + | _ -> + Inr e1 + in + let tail = e2 in + let dom, res = + match tail.tm with + | Sum(dom', res) -> dom::dom', res + | _ -> [dom], tail + in + mk_term (Sum(dom, res)) (rr2 $loc(e1) $loc(e2)) Type_level + } + | e1=tmNoEqWith(X) op=OPINFIX3 e2=tmNoEqWith(X) + { mk_term (Op(mk_ident(op, rr $loc(op)), [e1; e2])) (rr $loc) Un} + | e1=tmNoEqWith(X) BACKTICK op=tmNoEqWith(X) BACKTICK e2=tmNoEqWith(X) + { mkApp op [ e1, Infix; e2, Nothing ] (rr $loc) } + | e1=tmNoEqWith(X) op=OPINFIX4 e2=tmNoEqWith(X) + { mk_term (Op(mk_ident(op, rr $loc(op)), [e1; e2])) (rr $loc) Un} + | e=recordTerm { e } + | BACKTICK_PERC e=atomicTerm + { mk_term (VQuote e) (rr $loc) Un } + | op=TILDE e=atomicTerm + { mk_term (Op(mk_ident (op, rr $loc(op)), [e])) (rr $loc) Formula } + | e=X { e } + +binop_name: + | o=OPINFIX0a { mk_ident (o, rr $loc) } + | o=OPINFIX0b { mk_ident (o, rr $loc) } + | o=OPINFIX0c { mk_ident (o, rr $loc) } + | o=EQUALS { mk_ident ("=", rr $loc) } + | o=OPINFIX0d { mk_ident (o, rr $loc) } + | o=OPINFIX1 { mk_ident (o, rr $loc) } + | o=OPINFIX2 { mk_ident (o, rr $loc) } + | o=OPINFIX3 { mk_ident (o, rr $loc) } + | o=OPINFIX4 { mk_ident (o, rr $loc) } + | o=IMPLIES { mk_ident ("==>", rr $loc) } + | o=CONJUNCTION { mk_ident ("/\\", rr $loc) } + | o=DISJUNCTION { mk_ident ("\\/", rr $loc) } + | o=IFF { mk_ident ("<==>", rr $loc) } + | o=COLON_EQUALS { mk_ident (":=", rr $loc) } + | o=COLON_COLON { mk_ident ("::", rr $loc) } + | o=OP_MIXFIX_ASSIGNMENT { mk_ident (o, rr $loc) } + | o=OP_MIXFIX_ACCESS { mk_ident (o, rr $loc) } + +tmEqNoRefinement: + | e=tmEqWith(appTermNoRecordExp) { e } + +tmEq: + | e=tmEqWith(tmRefinement) { e } + +tmNoEq: + | e=tmNoEqWith(tmRefinement) { e } + +tmRefinement: + | id=lidentOrUnderscore COLON e=appTermNoRecordExp phi_opt=refineOpt + { + let t = match phi_opt with + | None -> NamedTyp(id, e) + | Some phi -> Refine(mk_binder (Annotated(id, e)) (rr2 $loc(id) $loc(e)) Type_level None, phi) + in mk_term t (rr2 $loc(id) $loc(phi_opt)) Type_level + } + | e=appTerm { e } + +refineOpt: + | phi_opt=option(LBRACE phi=formula RBRACE {phi}) {phi_opt} + +%inline formula: + | e=noSeqTerm { {e with level=Formula} } + +%public +recordExp: + | record_fields=right_flexible_nonempty_list(SEMICOLON, simpleDef) + { mk_term (Record (None, record_fields)) (rr $loc(record_fields)) Expr } + | e=appTerm WITH record_fields=right_flexible_nonempty_list(SEMICOLON, simpleDef) + { mk_term (Record (Some e, record_fields)) (rr2 $loc(e) $loc(record_fields)) Expr } + +simpleDef: + | e=separated_pair(qlidentOrOperator, EQUALS, noSeqTerm) { e } + | lid=qlidentOrOperator { lid, mk_term (Name (lid_of_ids [ ident_of_lid lid ])) (rr $loc(lid)) Un } + +appTermArgs: + | h=maybeHash a=onlyTrailingTerm { [h, a] } + | h=maybeHash a=indexingTerm rest=appTermArgs { (h, a) :: rest } + | h=maybeHash a=recordTerm rest=appTermArgs { (h, a) :: rest } + | a=universe rest=appTermArgs { a :: rest } + | { [] } + +appTermCommon(args): + | head=indexingTerm args=args + { mkApp head (map (fun (x,y) -> (y,x)) args) (rr2 $loc(head) $loc(args)) } + +%public +appTerm: + | t=onlyTrailingTerm { t } + | t=appTermCommon(appTermArgs) { t } + +appTermArgsNoRecordExp: + | h=maybeHash a=indexingTerm rest=appTermArgsNoRecordExp { (h, a) :: rest } + | a=universe rest=appTermArgsNoRecordExp { a :: rest } + | { [] } + +%public +appTermNoRecordExp: + | t=appTermCommon(appTermArgsNoRecordExp) {t} + +%inline maybeHash: + | { Nothing } + | HASH { Hash } + +%public +indexingTerm: + | e1=atomicTermNotQUident op_exprs=nonempty_list(dotOperator) + { + List.fold_left (fun e1 (op, e2, r) -> + mk_term (Op(op, [ e1; e2 ])) (union_ranges e1.range r) Expr) + e1 op_exprs + } + | e=atomicTerm + { e } + +%public +atomicTerm: + | x=atomicTermNotQUident + { x } + | x=atomicTermQUident + { x } + | x=opPrefixTerm(atomicTermQUident) + { x } + +trailingTerm: + | x=atomicTerm + { x } + | x=onlyTrailingTerm + { x } + +onlyTrailingTerm: + | FUN pats=nonempty_list(patternOrMultibinder) RARROW e=term + { mk_term (Abs(flatten pats, e)) (rr2 $loc($1) $loc(e)) Un } + | q=quantifier bs=binders DOT trigger=trigger e=term + { + match bs with + | [] -> + raise_error_text (rr2 $loc(q) $loc($3)) Fatal_MissingQuantifierBinder "Missing binders for a quantifier" + | _ -> + let idents = idents_of_binders bs (rr2 $loc(q) $loc($3)) in + mk_term (q (bs, (idents, trigger), e)) (rr2 $loc(q) $loc(e)) Formula + } + +atomicTermQUident: + | id=quident + { + let t = Name id in + let e = mk_term t (rr $loc(id)) Un in + e + } + | id=quident DOT_LPAREN t=term RPAREN + { + mk_term (LetOpen (id, t)) (rr2 $loc(id) $loc($4)) Expr + } + +atomicTermNotQUident: + | UNDERSCORE { mk_term Wild (rr $loc) Un } + | tv=tvar { mk_term (Tvar tv) (rr $loc) Type_level } + | c=constant { mk_term (Const c) (rr $loc) Expr } + | x=opPrefixTerm(atomicTermNotQUident) + { x } + | LPAREN op=operator RPAREN + { mk_term (Op(op, [])) (rr2 $loc($1) $loc($3)) Un } + | LENS_PAREN_LEFT e0=tmEq COMMA el=separated_nonempty_list(COMMA, tmEq) LENS_PAREN_RIGHT + { mkDTuple (e0::el) (rr2 $loc($1) $loc($5)) } + | e=projectionLHS field_projs=list(DOT id=qlident {id}) + { fold_left (fun e lid -> mk_term (Project(e, lid)) (rr2 $loc(e) $loc(field_projs)) Expr ) e field_projs } + | BEGIN e=term END + { e } + +(* Tm: atomicTermQUident or atomicTermNotQUident *) +opPrefixTerm(Tm): + | op=OPPREFIX e=Tm + { mk_term (Op(mk_ident(op, rr $loc(op)), [e])) (rr2 $loc(op) $loc(e)) Expr } + + +projectionLHS: + | e=qidentWithTypeArgs(qlident, option(fsTypeArgs)) + { e } + | e=qidentWithTypeArgs(quident, some(fsTypeArgs)) + { e } + | LPAREN e=term sort_opt=option(pair(hasSort, simpleTerm)) RPAREN + { + (* Note: we have to keep the parentheses here. Consider t * u * v. This + * is parsed as Op2( *, Op2( *, t, u), v). The desugaring phase then looks + * up * and figures out that it hasn't been overridden, meaning that + * it's a tuple type, and proceeds to flatten out the whole tuple. Now + * consider (t * u) * v. We keep the Paren node, which prevents the + * flattening from happening, hence ensuring the proper type is + * generated. *) + let e1 = match sort_opt with + | None -> e + | Some (level, t) -> mk_term (Ascribed(e,{t with level=level},None,false)) (rr2 $loc($1) $loc($4)) level + in mk_term (Paren e1) (rr2 $loc($1) $loc($4)) (e.level) + } + | LBRACK es=semiColonTermList RBRACK + { mkListLit (rr2 $loc($1) $loc($3)) es } + | SEQ_BANG_LBRACK es=semiColonTermList RBRACK + { mkSeqLit (rr2 $loc($1) $loc($3)) es } + | PERCENT_LBRACK es=semiColonTermList RBRACK + { mk_term (LexList es) (rr2 $loc($1) $loc($3)) Type_level } + | BANG_LBRACE es=separated_list(COMMA, appTerm) RBRACE + { mkRefSet (rr2 $loc($1) $loc($3)) es } + | ns=quident QMARK_DOT id=lident + { mk_term (Projector (ns, id)) (rr2 $loc(ns) $loc(id)) Expr } + | lid=quident QMARK + { mk_term (Discrim lid) (rr2 $loc(lid) $loc($2)) Un } + +fsTypeArgs: + | TYP_APP_LESS targs=separated_nonempty_list(COMMA, atomicTerm) TYP_APP_GREATER + {targs} + +(* Qid : quident or qlident. + TypeArgs : option(fsTypeArgs) or someFsTypeArgs. *) +qidentWithTypeArgs(Qid,TypeArgs): + | id=Qid targs_opt=TypeArgs + { + let t = if is_name id then Name id else Var id in + let e = mk_term t (rr $loc(id)) Un in + match targs_opt with + | None -> e + | Some targs -> mkFsTypApp e targs (rr2 $loc(id) $loc(targs_opt)) + } + +hasSort: + (* | SUBTYPE { Expr } *) + | SUBKIND { Type_level } (* Remove with stratify *) + + (* use flexible_list *) +%inline semiColonTermList: + | l=right_flexible_list(SEMICOLON, noSeqTerm) { l } + +constant: + | LPAREN_RPAREN { Const_unit } + | n=INT + { + if snd n then + log_issue_text (rr $loc) Error_OutOfRange "This number is outside the allowable range for representable integer constants"; + Const_int (fst n, None) + } + | c=CHAR { Const_char c } + | s=STRING { Const_string (s, rr $loc) } + | TRUE { Const_bool true } + | FALSE { Const_bool false } + | r=REAL { Const_real r } + | n=UINT8 { Const_int (n, Some (Unsigned, Int8)) } + | n=INT8 + { + if snd n then + log_issue_text (rr $loc) Error_OutOfRange "This number is outside the allowable range for 8-bit signed integers"; + Const_int (fst n, Some (Signed, Int8)) + } + | n=UINT16 { Const_int (n, Some (Unsigned, Int16)) } + | n=INT16 + { + if snd n then + log_issue_text (rr $loc) Error_OutOfRange "This number is outside the allowable range for 16-bit signed integers"; + Const_int (fst n, Some (Signed, Int16)) + } + | n=UINT32 { Const_int (n, Some (Unsigned, Int32)) } + | n=INT32 + { + if snd n then + log_issue_text (rr $loc) Error_OutOfRange "This number is outside the allowable range for 32-bit signed integers"; + Const_int (fst n, Some (Signed, Int32)) + } + | n=UINT64 { Const_int (n, Some (Unsigned, Int64)) } + | n=INT64 + { + if snd n then + log_issue_text (rr $loc) Error_OutOfRange "This number is outside the allowable range for 64-bit signed integers"; + Const_int (fst n, Some (Signed, Int64)) + } + | n=SIZET { Const_int (n, Some (Unsigned, Sizet)) } + (* TODO : What about reflect ? There is also a constant representing it *) + | REIFY { Const_reify None } + | RANGE_OF { Const_range_of } + | SET_RANGE_OF { Const_set_range_of } + + +universe: + | UNIV_HASH ua=atomicUniverse { (UnivApp, ua) } + +universeFrom: + | ua=atomicUniverse { ua } + | u1=universeFrom op_plus=OPINFIX2 u2=universeFrom + { + if op_plus <> "+" + then log_issue_text (rr $loc(u1)) Error_OpPlusInUniverse ("The operator " ^ op_plus ^ " was found in universe context." + ^ "The only allowed operator in that context is +."); + mk_term (Op(mk_ident (op_plus, rr $loc(op_plus)), [u1 ; u2])) (rr2 $loc(u1) $loc(u2)) Expr + } + | max=ident us=nonempty_list(atomicUniverse) + { + if string_of_id max <> string_of_lid max_lid + then log_issue_text (rr $loc(max)) Error_InvalidUniverseVar ("A lower case ident " ^ string_of_id max ^ + " was found in a universe context. " ^ + "It should be either max or a universe variable 'usomething."); + let max = mk_term (Var (lid_of_ids [max])) (rr $loc(max)) Expr in + mkApp max (map (fun u -> u, Nothing) us) (rr $loc) + } + +atomicUniverse: + | UNDERSCORE + { mk_term Wild (rr $loc) Expr } + | n=INT + { + if snd n then + log_issue_text (rr $loc) Error_OutOfRange ("This number is outside the allowable range for representable integer constants"); + mk_term (Const (Const_int (fst n, None))) (rr $loc(n)) Expr + } + | u=lident { mk_term (Uvar u) (range_of_id u) Expr } + | LPAREN u=universeFrom RPAREN + { u (*mk_term (Paren u) (rr2 $loc($1) $loc($3)) Expr*) } + +warn_error_list: + | e=warn_error EOF { e } + +warn_error: + | f=flag r=range + { [(f, r)] } + | f=flag r=range e=warn_error + { (f, r) :: e } + +flag: + | op=OPINFIX1 + { if op = "@" then CAlwaysError else failwith (format1 "unexpected token %s in warn-error list" op)} + | op=OPINFIX2 + { if op = "+" then CWarning else failwith (format1 "unexpected token %s in warn-error list" op)} + | MINUS + { CSilent } + +range: + | i=INT + { format2 "%s..%s" (fst i) (fst i) } + | r=RANGE + { r } + + +/******************************************************************************/ +/* Miscellanous, tools */ +/******************************************************************************/ + +string: + | s=STRING { s } + +%inline operator: + | op=OPPREFIX { mk_ident (op, rr $loc) } + | op=binop_name { op } + | op=TILDE { mk_ident (op, rr $loc) } + | op=and_op {op} + | op=let_op {op} + | op=quantifier_op {op} + +%inline quantifier_op: + | op=EXISTS_OP { mk_ident ("exists" ^ op, rr $loc) } + | op=FORALL_OP { mk_ident ("forall" ^ op, rr $loc) } + +%inline and_op: + | op=AND_OP { mk_ident ("and" ^ op, rr $loc) } +%inline let_op: + | op=LET_OP { mk_ident ("let" ^ op, rr $loc) } + +/* These infix operators have a lower precedence than EQUALS */ +%inline operatorInfix0ad12: + | op=OPINFIX0a + | op=OPINFIX0b + | op=OPINFIX0c + | op=OPINFIX0d + | op=OPINFIX1 + | op=OPINFIX2 + { mk_ident (op, rr $loc) } + +%inline dotOperator: + | op=DOT_LPAREN e=term RPAREN { mk_ident (".()", rr $loc(op)), e, rr2 $loc(op) $loc($3) } + | op=DOT_LBRACK e=term RBRACK { mk_ident (".[]", rr $loc(op)), e, rr2 $loc(op) $loc($3) } + | op=DOT_LBRACK_BAR e=term BAR_RBRACK { mk_ident (".[||]", rr $loc(op)), e, rr2 $loc(op) $loc($3) } + | op=DOT_LENS_PAREN_LEFT e=term LENS_PAREN_RIGHT { mk_ident (".(||)", rr $loc(op)), e, rr2 $loc(op) $loc($3) } + +some(X): + | x=X { Some x } + +right_flexible_list(SEP, X): + | { [] } + | x=X { [x] } + | x=X SEP xs=right_flexible_list(SEP, X) { x :: xs } + +right_flexible_nonempty_list(SEP, X): + | x=X { [x] } + | x=X SEP xs=right_flexible_list(SEP, X) { x :: xs } + +reverse_left_flexible_list(delim, X): +| (* nothing *) + { [] } +| x = X + { [x] } +| xs = reverse_left_flexible_list(delim, X) delim x = X + { x :: xs } + +%inline left_flexible_list(delim, X): + xs = reverse_left_flexible_list(delim, X) + { List.rev xs } + +reverse_left_flexible_nonempty_list(delim, X): +| ioption(delim) x = X + { [x] } +| xs = reverse_left_flexible_nonempty_list(delim, X) delim x = X + { x :: xs } + +%inline left_flexible_nonempty_list(delim, X): + xs = reverse_left_flexible_nonempty_list(delim, X) + { List.rev xs } diff --git a/ocaml/fstar-lib/FStarC_Parser_ParseIt.ml b/ocaml/fstar-lib/FStarC_Parser_ParseIt.ml new file mode 100644 index 00000000000..44af2a46cfc --- /dev/null +++ b/ocaml/fstar-lib/FStarC_Parser_ParseIt.ml @@ -0,0 +1,452 @@ +module U = FStarC_Compiler_Util +open FStarC_Errors +open FStarC_Syntax_Syntax +open Lexing +open FStarC_Sedlexing +open FStarC_Errors_Codes +module Codes = FStarC_Errors_Codes +module Msg = FStarC_Errors_Msg + +type filename = string + +type input_frag = { + frag_fname:filename; + frag_text:string; + frag_line:Prims.int; + frag_col:Prims.int +} + +let resetLexbufPos filename lexbuf = + lexbuf.cur_p <- { + pos_fname= filename; + pos_cnum = 0; + pos_bol = 0; + pos_lnum = 1 } + +let setLexbufPos filename lexbuf line col = + lexbuf.cur_p <- { + pos_fname= filename; + pos_cnum = col; + pos_bol = 0; + pos_lnum = line } + +module Path = BatPathGen.OfString + +let find_file filename = + match FStarC_Find.find_file filename with + | Some s -> + s + | None -> + raise_error_text FStarC_Compiler_Range.dummyRange Fatal_ModuleOrFileNotFound (U.format1 "Unable to find file: %s\n" filename) + +let vfs_entries : (U.time * string) U.smap = U.smap_create (Z.of_int 1) + +let read_vfs_entry fname = + U.smap_try_find vfs_entries (U.normalize_file_path fname) + +let add_vfs_entry fname contents = + U.smap_add vfs_entries (U.normalize_file_path fname) (U.now (), contents) + +let get_file_last_modification_time filename = + match read_vfs_entry filename with + | Some (mtime, _contents) -> mtime + | None -> U.get_file_last_modification_time filename + +let read_physical_file (filename: string) = + (* BatFile.with_file_in uses Unix.openfile (which isn't available in + js_of_ocaml) instead of Pervasives.open_in, so we don't use it here. *) + try + let channel = open_in_bin filename in + BatPervasives.finally + (fun () -> close_in channel) + (fun channel -> really_input_string channel (in_channel_length channel)) + channel + with e -> + raise_error_text FStarC_Compiler_Range.dummyRange Fatal_UnableToReadFile (U.format1 "Unable to read file %s\n" filename) + +let read_file (filename:string) = + let debug = FStarC_Compiler_Debug.any () in + match read_vfs_entry filename with + | Some (_mtime, contents) -> + if debug then U.print1 "Reading in-memory file %s\n" filename; + filename, contents + | None -> + let filename = find_file filename in + if debug then U.print1 "Opening file %s\n" filename; + filename, read_physical_file filename + +let fs_extensions = [".fs"; ".fsi"] +let fst_extensions = [".fst"; ".fsti"] +let interface_extensions = [".fsti"; ".fsi"] + +let valid_extensions () = + fst_extensions @ if FStarC_Options.ml_ish () then fs_extensions else [] + +let has_extension file extensions = + FStar_List.existsb (U.ends_with file) extensions + +let check_extension fn = + if (not (has_extension fn (valid_extensions ()))) then + let message = U.format1 "Unrecognized extension '%s'" fn in + raise_error_text FStarC_Compiler_Range.dummyRange Fatal_UnrecognizedExtension + (if has_extension fn fs_extensions + then message ^ " (pass --MLish to process .fs and .fsi files)" + else message) + +type parse_frag = + | Filename of filename + | Toplevel of input_frag + | Incremental of input_frag + | Fragment of input_frag + +type parse_error = (Codes.error_code * Msg.error_message * FStarC_Compiler_Range.range) + + +type code_fragment = { + range: FStarC_Compiler_Range.range; + code: string; +} + +type 'a incremental_result = + ('a * code_fragment) list * (string * FStarC_Compiler_Range.range) list * parse_error option + +type parse_result = + | ASTFragment of (FStarC_Parser_AST.inputFragment * (string * FStarC_Compiler_Range.range) list) + | IncrementalFragment of FStarC_Parser_AST.decl incremental_result + | Term of FStarC_Parser_AST.term + | ParseError of parse_error + +module BU = FStarC_Compiler_Util +module Range = FStarC_Compiler_Range +module MHL = MenhirLib.Convert + +let range_of_positions filename start fin = + let start_pos = FStarC_Parser_Util.pos_of_lexpos start in + let end_pos = FStarC_Parser_Util.pos_of_lexpos fin in + FStarC_Compiler_Range.mk_range filename start_pos end_pos + +let err_of_parse_error filename lexbuf tag = + let pos = lexbuf.cur_p in + let tag = + match tag with + | None -> "Syntax error" + | Some tag -> tag + in + Fatal_SyntaxError, + Msg.mkmsg tag, + range_of_positions filename pos pos + +let string_of_lexpos lp = + let r = range_of_positions "" lp lp in + FStarC_Compiler_Range.string_of_range r + +let parse_incremental_decls + filename + (contents:string) + lexbuf + (lexer:unit -> 'token * Lexing.position * Lexing.position) + (range_of: 'semantic_value -> FStarC_Compiler_Range.range) + (parse_one: + (Lexing.lexbuf -> 'token) -> + Lexing.lexbuf -> + ('semantic_value list * FStarC_Sedlexing.snap option) option) +: 'semantic_value list * parse_error option += let parse_one = MenhirLib.Convert.Simplified.traditional2revised parse_one in + let err_of_parse_error tag = err_of_parse_error filename lexbuf tag in + let open FStar_Pervasives in + let push_decls ds decls = List.fold_left (fun decls d -> d::decls) decls ds in + let rec parse decls = + let start_pos = current_pos lexbuf in + let d = + try + (* Reset the gensym between decls, to ensure determinism, + otherwise, every _ is parsed as different name *) + FStarC_GenSym.reset_gensym(); + Inl (parse_one lexer) + with + | FStarC_Errors.Error(e, msg, r, ctx) -> + Inr (e, msg, r) + + | e -> + Inr (err_of_parse_error None) + in + match d with + | Inl None -> + List.rev decls, None + | Inl (Some (ds, snap_opt)) -> + (* The parser may advance the lexer beyond the decls last token. + E.g., in `let f x = 0 let g = 1`, we will have parsed the decl for `f` + but the lexer will have advanced to `let ^ g ...` since the + parser will have looked ahead. + Rollback the lexer one token for declarations whose syntax + requires such lookahead to complete a production. + *) + let _ = + match snap_opt with + | None -> + rollback lexbuf + | Some p -> + restore_snapshot lexbuf p + in + parse (push_decls ds decls) + | Inr err -> + List.rev decls, Some err + in + parse [] + +let contents_at contents = + let lines = U.splitlines contents in + let split_line_at_col line col = + if col > 0 + then ( + (* Don't index directly into the string, since this is a UTF-8 string. + Convert first to a list of characters, index into that, and then convert + back to a string *) + let chars = FStar_String.list_of_string line in + if col <= List.length chars + then ( + let prefix, suffix = FStarC_Compiler_Util.first_N (Z.of_int col) chars in + Some (FStar_String.string_of_list prefix, + FStar_String.string_of_list suffix) + ) + else ( + None + ) + ) + else None + in + let line_from_col line pos = + match split_line_at_col line pos with + | None -> None + | Some (_, p) -> Some p + in + let line_to_col line pos = + match split_line_at_col line pos with + | None -> None + | Some (p, _) -> Some p + in + (* Find the raw content of the input from the line of the start_pos to the end_pos. + This is used by Interactive.Incremental to record exactly the raw content of the + fragment that was checked *) + fun (range:Range.range) -> + (* discard all lines until the start line *) + let start_pos = Range.start_of_range range in + let end_pos = Range.end_of_range range in + let start_line = Z.to_int (Range.line_of_pos start_pos) in + let start_col = Z.to_int (Range.col_of_pos start_pos) in + let end_line = Z.to_int (Range.line_of_pos end_pos) in + let end_col = Z.to_int (Range.col_of_pos end_pos) in + let suffix = + FStarC_Compiler_Util.nth_tail + (Z.of_int (if start_line > 0 then start_line - 1 else 0)) + lines + in + (* Take all the lines between the start and end lines *) + let text, rest = + FStarC_Compiler_Util.first_N + (Z.of_int (end_line - start_line)) + suffix + in + let text = + match text with + | first_line::rest -> ( + match line_from_col first_line start_col with + | Some s -> s :: rest + | _ -> text + ) + | _ -> text + in + let text = + (* For the last line itself, take the prefix of it up to the character of the end_pos *) + match rest with + | last::_ -> ( + match line_to_col last end_col with + | None -> text + | Some last -> + (* The last line is also the first line *) + match text with + | [] -> ( + match line_from_col last start_col with + | None -> [last] + | Some l -> [l] + ) + | _ -> text @ [last] + ) + | _ -> text + in + { range; + code = FStar_String.concat "\n" text } + + +let parse_incremental_fragment + filename + (contents:string) + lexbuf + (lexer:unit -> 'token * Lexing.position * Lexing.position) + (range_of: 'semantic_value -> FStarC_Compiler_Range.range) + (parse_one: + (Lexing.lexbuf -> 'token) -> + Lexing.lexbuf -> + ('semantic_value list * FStarC_Sedlexing.snap option) option) +: 'semantic_value incremental_result += let res = parse_incremental_decls filename contents lexbuf lexer range_of parse_one in + let comments = FStarC_Parser_Util.flush_comments () in + let contents_at = contents_at contents in + let decls, err_opt = res in + let decls = List.map (fun d -> d, contents_at (range_of d)) decls in + decls, comments, err_opt + +let parse_fstar_incrementally +: FStarC_Parser_AST_Util.extension_lang_parser += let f = + fun (s:string) (r:FStarC_Compiler_Range.range) -> + let open FStar_Pervasives in + let open FStarC_Compiler_Range in + let lexbuf = + create s + (file_of_range r) + (Z.to_int (line_of_pos (start_of_range r))) + (Z.to_int (col_of_pos (start_of_range r))) + in + let filename = file_of_range r in + let contents = s in + let lexer () = + let tok = FStarC_Parser_LexFStar.token lexbuf in + (tok, lexbuf.start_p, lexbuf.cur_p) + in + try + let decls, err_opt = + parse_incremental_decls + filename + contents + lexbuf + lexer + (fun (d:FStarC_Parser_AST.decl) -> d.drange) + FStarC_Parser_Parse.oneDeclOrEOF + in + match err_opt with + | None -> Inr decls + | Some (_, msg, r) -> + let open FStarC_Parser_AST in + let err_decl = mk_decl Unparseable r [] in + Inr (decls @ [err_decl]) + with + | FStarC_Errors.Error(e, msg, r, _ctx) -> + let msg = FStarC_Errors_Msg.rendermsg msg in + let err : FStarC_Parser_AST_Util.error_message = { message = msg; range = r } in + Inl err + | e -> + let pos = FStarC_Parser_Util.pos_of_lexpos (lexbuf.cur_p) in + let r = FStarC_Compiler_Range.mk_range filename pos pos in + let err : FStarC_Parser_AST_Util.error_message = { message = "Syntax error parsing #lang-fstar block: "; range = r } in + Inl err + in + { parse_decls = f } +let _ = FStarC_Parser_AST_Util.register_extension_lang_parser "fstar" parse_fstar_incrementally + +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_Compiler_Range.mk_pos s.frag_line s.frag_col in + let rng = FStarC_Compiler_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 + | FStarC_Errors.Error(e, msg, r, _ctx) -> + ParseError (e, msg, r) + +let parse (lang_opt:lang_opts) fn = + 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_Compiler_Range.dummyRange Fatal_InvalidUTF8Encoding (U.format1 "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 + (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 match modul with + | FStarC_Parser_AST.Module(l,d) -> + FStar_Pervasives.Inl (FStarC_Parser_AST.Interface(l, d, true)) + | _ -> failwith "Impossible" + 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) + + +(** Parsing of command-line error/warning/silent flags. *) +let parse_warn_error s = + let user_flags = + if s = "" + then [] + else + let lexbuf = FStarC_Sedlexing.create s "" 0 (String.length s) in + let lexer() = let tok = FStarC_Parser_LexFStar.token lexbuf in + (tok, lexbuf.start_p, lexbuf.cur_p) + in + try + MenhirLib.Convert.Simplified.traditional2revised FStarC_Parser_Parse.warn_error_list lexer + with e -> + failwith (U.format1 "Malformed warn-error list: %s" s) + in + FStarC_Errors.update_flags user_flags diff --git a/ocaml/fstar-lib/FStarC_Parser_ParseIt.mli b/ocaml/fstar-lib/FStarC_Parser_ParseIt.mli new file mode 100644 index 00000000000..01cb2edb5e4 --- /dev/null +++ b/ocaml/fstar-lib/FStarC_Parser_ParseIt.mli @@ -0,0 +1,58 @@ +module U = FStarC_Compiler_Util +open FStarC_Errors +open FStarC_Syntax_Syntax +open Lexing +open FStarC_Sedlexing +module Codes = FStarC_Errors_Codes +module Msg = FStarC_Errors_Msg + +type filename = string + +type input_frag = { + frag_fname:filename; + frag_text:string; + frag_line:Prims.int; + frag_col:Prims.int +} + +val read_vfs_entry : string -> (U.time * string) option +val add_vfs_entry: string -> string -> unit +val get_file_last_modification_time: string -> U.time + +type parse_frag = + | Filename of filename + | Toplevel of input_frag + | Incremental of input_frag + | Fragment of input_frag + +type parse_error = (Codes.error_code * Msg.error_message * FStarC_Compiler_Range.range) + +type code_fragment = { + range : FStarC_Compiler_Range.range; + code: string; +} + +type parse_result = + | ASTFragment of (FStarC_Parser_AST.inputFragment * (string * FStarC_Compiler_Range.range) list) + | IncrementalFragment of ((FStarC_Parser_AST.decl * code_fragment) list * (string * FStarC_Compiler_Range.range) list * parse_error option) + | Term of FStarC_Parser_AST.term + | ParseError of parse_error + +val parse_incremental_decls : + (*filename*)string -> + (*contents*)string -> + FStarC_Sedlexing.lexbuf -> + (unit -> 'token * Lexing.position * Lexing.position) -> + ('semantic_value -> FStarC_Compiler_Range.range) -> + ((Lexing.lexbuf -> 'token) -> Lexing.lexbuf -> + ('semantic_value list * FStarC_Sedlexing.snap option) option) -> +'semantic_value list * parse_error option + +type lang_opts = string option +val parse: lang_opts -> parse_frag -> parse_result + +val find_file: string -> string + +val parse_warn_error: string -> Codes.error_setting list + +val parse_fstar_incrementally: FStarC_Parser_AST_Util.extension_lang_parser diff --git a/ocaml/fstar-lib/FStar_Parser_Utf8.ml b/ocaml/fstar-lib/FStarC_Parser_Utf8.ml similarity index 100% rename from ocaml/fstar-lib/FStar_Parser_Utf8.ml rename to ocaml/fstar-lib/FStarC_Parser_Utf8.ml diff --git a/ocaml/fstar-lib/FStarC_Parser_Util.ml b/ocaml/fstar-lib/FStarC_Parser_Util.ml new file mode 100644 index 00000000000..c6c03febb0f --- /dev/null +++ b/ocaml/fstar-lib/FStarC_Parser_Util.ml @@ -0,0 +1,44 @@ +open FStarC_Compiler_Range +open Lexing + +(* This brings into scope enough the translation of F# type names into the + * corresponding OCaml type names; the reason for that is that we massage + * parse.fsy (using sed) into parse.mly; but, we don't rename types. *) +include FStarC_BaseTypes +type single = float +type decimal = int +type bytes = byte array + +let parseState = () + +let pos_of_lexpos (p:position) = + mk_pos (Z.of_int p.pos_lnum) (Z.of_int (p.pos_cnum - p.pos_bol)) + +let mksyn_range (p1:position) p2 = + mk_range p1.pos_fname (pos_of_lexpos p1) (pos_of_lexpos p2) + +let translate_range (pos : Lexing.position * Lexing.position) = + mksyn_range (fst pos) (snd pos) + +let translate_range2 (pos1 : Lexing.position * Lexing.position) (pos2 : Lexing.position * Lexing.position) = + mksyn_range (fst pos1) (snd pos2) + +exception WrappedError of exn * range +exception ReportedError +exception StopProcessing + +let warningHandler = ref (fun (e:exn) -> + FStarC_Compiler_Util.print_string "no warning handler installed\n" ; + FStarC_Compiler_Util.print_any e; ()) +let errorHandler = ref (fun (e:exn) -> + FStarC_Compiler_Util.print_string "no warning handler installed\n" ; + FStarC_Compiler_Util.print_any e; ()) +let errorAndWarningCount = ref 0 +let errorR exn = incr errorAndWarningCount; match exn with StopProcessing | ReportedError -> raise exn | _ -> !errorHandler exn +let warning exn = incr errorAndWarningCount; match exn with StopProcessing | ReportedError -> raise exn | _ -> !warningHandler exn + +let comments : (string * FStarC_Compiler_Range.range) list ref = ref [] +let add_comment x = comments := x :: !comments +let flush_comments () = + let lexed_comments = !comments in + comments := []; lexed_comments diff --git a/ocaml/fstar-lib/FStar_Platform.ml b/ocaml/fstar-lib/FStarC_Platform.ml similarity index 100% rename from ocaml/fstar-lib/FStar_Platform.ml rename to ocaml/fstar-lib/FStarC_Platform.ml diff --git a/ocaml/fstar-lib/FStar_Pprint.ml b/ocaml/fstar-lib/FStarC_Pprint.ml similarity index 100% rename from ocaml/fstar-lib/FStar_Pprint.ml rename to ocaml/fstar-lib/FStarC_Pprint.ml diff --git a/ocaml/fstar-lib/FStarC_Reflection_Types.ml b/ocaml/fstar-lib/FStarC_Reflection_Types.ml new file mode 100644 index 00000000000..f0a3c0a42da --- /dev/null +++ b/ocaml/fstar-lib/FStarC_Reflection_Types.ml @@ -0,0 +1,26 @@ +open FStar_All + +(* TODO: make this an F* module, no need to drop to OCaml for this *) + +type binder = FStarC_Syntax_Syntax.binder +type bv = FStarC_Syntax_Syntax.bv +type namedv = bv +type term = FStarC_Syntax_Syntax.term +type env = FStarC_TypeChecker_Env.env +type fv = FStarC_Syntax_Syntax.fv +type comp = FStarC_Syntax_Syntax.comp +type sigelt = FStarC_Syntax_Syntax.sigelt +type ctx_uvar_and_subst = FStarC_Syntax_Syntax.ctx_uvar_and_subst +type optionstate = FStarC_Options.optionstate +type letbinding = FStarC_Syntax_Syntax.letbinding + +type universe_uvar = FStarC_Syntax_Syntax.universe_uvar +type universe = FStarC_Syntax_Syntax.universe + +type name = string list +type ident = FStarC_Ident.ident +type univ_name = ident +type typ = term +type binders = binder list +type match_returns_ascription = FStarC_Syntax_Syntax.match_returns_ascription +type decls = sigelt list diff --git a/ocaml/fstar-lib/FStarC_Sedlexing.ml b/ocaml/fstar-lib/FStarC_Sedlexing.ml new file mode 100644 index 00000000000..eb4520bd949 --- /dev/null +++ b/ocaml/fstar-lib/FStarC_Sedlexing.ml @@ -0,0 +1,126 @@ +(** +A custom version of Sedlexing enhanced with +lc, bol and fname position tracking and +specialized for UTF-8 string inputs +(the parser driver always reads whole files) +**) + +exception Error + +module L = Lexing +type pos = L.position + +type lexbuf = { + buf: int array; + len: int; + + mutable cur: int; + mutable cur_p: pos; + mutable start: int; + mutable start_p: pos; + + mutable mark: int; + mutable mark_p: pos; + mutable mark_val: int; +} + +let get_buf lb = lb.buf +let get_cur lb = lb.cur +let get_start lb = lb.start + +(* N.B. the offsets are for interactive mode + we want to ble able to interpret a fragment as if it was part + of a larger file and report absolute error positions *) +let create (s:string) fn loffset coffset = + let a = FStarC_Parser_Utf8.to_int_array s 0 (String.length s) in + let start_p = { + L.pos_fname = fn; + L.pos_cnum = coffset; + L.pos_bol = 0; + L.pos_lnum = loffset; } + in { + buf = a; + len = Array.length a; + + cur = 0; + cur_p = start_p; + + start = 0; + start_p = start_p; + + mark = 0; + mark_p = start_p; + mark_val = 0; + } + +let current_pos b = b.cur_p + +let start b = + b.mark <- b.cur; + b.mark_val <- (-1); + b.mark_p <- b.cur_p; + b.start <- b.cur; + b.start_p <- b.cur_p + +let mark b i = + b.mark <- b.cur; + b.mark_p <- b.cur_p; + b.mark_val <- i + +let backtrack b = + b.cur <- b.mark; + b.cur_p <- b.mark_p; + b.mark_val + +type snap = int * pos + +let snapshot b = b.start, b.start_p +let restore_snapshot b (cur, cur_p) = + b.cur <- cur; + b.cur_p <- cur_p + +let next b = + if b.cur = b.len then None + else + let c = b.buf.(b.cur) in + (b.cur <- b.cur + 1; + b.cur_p <- {b.cur_p with L.pos_cnum = b.cur_p.L.pos_cnum + 1}; Some (Uchar.of_int c)) + +let new_line b = + b.cur_p <- { b.cur_p with + L.pos_lnum = b.cur_p.L.pos_lnum + 1; + L.pos_bol = b.cur_p.L.pos_cnum; + } + +let range b = (b.start_p, b.cur_p) + +let ulexeme lexbuf = + Array.sub lexbuf.buf lexbuf.start (lexbuf.cur - lexbuf.start) + +let rollback b = + b.cur <- b.start; + b.cur_p <- b.start_p + +let lexeme lexbuf = + FStarC_Parser_Utf8.from_int_array lexbuf.buf lexbuf.start (lexbuf.cur - lexbuf.start) + +let lookahead b pos = + if b.len <= pos then "" + else FStarC_Parser_Utf8.from_int_array b.buf pos (b.len - pos) + +let source_file b = + b.cur_p.L.pos_fname + +let current_line b = + b.cur_p.Lexing.pos_lnum + +(* Since sedlex 2.4, we need to expose Sedlexing.__private_next_int + (see #2343) + + From https://github.com/ocaml-communi-ty/sedlex/blob/268c553f474457574e22701679d68f66aa771551/src/lib/sedlexing.mli#L154-L161 + [next] and [__private__next_int] have the same doc description, + the only difference is the return type *) +let __private__next_int b = + match next b with + | Some v -> Uchar.to_int v + | None -> -1 diff --git a/ocaml/fstar-lib/FStarC_StringBuffer.ml b/ocaml/fstar-lib/FStarC_StringBuffer.ml new file mode 100644 index 00000000000..a35ba05d3a4 --- /dev/null +++ b/ocaml/fstar-lib/FStarC_StringBuffer.ml @@ -0,0 +1,7 @@ +(* See FStar.StringBuffer.fsi *) +type t = Buffer.t +let create (i:FStarC_BigInt.t) = Buffer.create (FStarC_BigInt.to_int i) +let add s t = Buffer.add_string t s; t +let contents = Buffer.contents +let clear t = Buffer.clear t; t +let output_channel = Buffer.output_buffer diff --git a/ocaml/fstar-lib/FStarC_Syntax_TermHashTable.ml b/ocaml/fstar-lib/FStarC_Syntax_TermHashTable.ml new file mode 100644 index 00000000000..3e018dd7a62 --- /dev/null +++ b/ocaml/fstar-lib/FStarC_Syntax_TermHashTable.ml @@ -0,0 +1,73 @@ +module S = FStarC_Syntax_Syntax +module P = FStarC_Profiling +module BU = FStarC_Compiler_Util +let now () = BatUnix.gettimeofday () +let record_time f = + let start = now () in + let res = f () in + let elapsed = (now()) -. start in + res, int_of_float (elapsed *. 1000.0) +let eq_term_ctr = ref (0, 0) +let num_eq_term_calls = ref (0, 0) +let incr (r:(int * int) ref) (time:int) = let n, t = !r in r := (n + 1, time + t) +module HashKey = + struct + type t = S.term + let equal (x:t) (y:t) = FStarC_Syntax_Hash.equal_term x y +(* This function is often hot. Its useful to enable the profiling code when debugging + P.profile (fun _ -> + let res, time = record_time (fun _ -> FStarC_Syntax_Hash.equal_term x y) in + incr num_eq_term_calls time; + if res + then ( incr eq_term_ctr time; true ) + else ( false)) + None + "FStar.Syntax.TermHashTable.equal" +*) + let hash (x:t) = FStarC_Syntax_Hash.ext_hash_term x +(* P.profile (fun _ -> + None + "FStar.Syntax.TermHashTable.hash" +*) + end +module HT = BatHashtbl.Make(HashKey) + +type 'a hashtable = 'a HT.t + +let create (n:Z.t) = HT.create (Z.to_int n) +module Print = FStarC_Syntax_Print + +let insert (key: S.term) (v:'a) (ht:'a hashtable) = HT.add ht key v + +let lookup (key: S.term) (ht:'a hashtable) : 'a option = + try + let l = HT.find ht key in + Some l + with + | Not_found -> None + +let reset_counters (x:'a hashtable) = + eq_term_ctr := (0,0); + num_eq_term_calls := (0,0) + +let clear (x:'a hashtable) = + HT.clear x; + reset_counters x + +let print_stats (x:'a hashtable) : unit = + let stats = HT.stats x in + let string_of_ctr ctr = let n, t = !ctr in BU.format2 "%s in %s ms" (string_of_int n) (string_of_int t) in + BU.print4 "THT Statistics { num_bindings = %s; max_bucket_length = %s; num_eq_term_calls = %s; eq_term_ctr = %s }\n" + (string_of_int stats.num_bindings) + (string_of_int stats.max_bucket_length) + (string_of_ctr num_eq_term_calls) + (string_of_ctr eq_term_ctr) + +(* Histogram + (BatString.concat "; " + (List.map (function Some x -> x) + (List.filter + (function None -> false | _ -> true) + (Array.to_list ( + (Array.mapi (fun i n -> if n = 0 then None else Some ("(" ^ (string_of_int i) ^", "^ (string_of_int n)^ ")")) stats.bucket_histogram)))))) +*) diff --git a/ocaml/fstar-lib/FStarC_Tactics_Native.ml b/ocaml/fstar-lib/FStarC_Tactics_Native.ml new file mode 100644 index 00000000000..10c405034fb --- /dev/null +++ b/ocaml/fstar-lib/FStarC_Tactics_Native.ml @@ -0,0 +1,102 @@ +open FStarC_Compiler_Range +open FStarC_Tactics_Types +open FStarC_Tactics_Result +open FStarC_Tactics_Monad +open FStarC_Syntax_Syntax + +module N = FStarC_TypeChecker_Normalize +module C = FStarC_TypeChecker_Cfg +module BU = FStarC_Compiler_Util +module NBETerm = FStarC_TypeChecker_NBETerm +module O = FStarC_Options +module PO = FStarC_TypeChecker_Primops +module POB = FStarC_TypeChecker_Primops_Base + +(* These definitions are ≡ to the ones generated by F*'s extraction of the + tactic effect. We need them here to break a circular dependency between the + compiler and ulib (cf. tactics meeting of 2017-08-03). *) +type 'a __tac = FStarC_Tactics_Types.proofstate -> 'a __result + +let r = dummyRange + +type itac = + POB.psc -> FStarC_Syntax_Embeddings_Base.norm_cb -> universes -> args -> term option +type nbe_itac = + NBETerm.nbe_cbs -> universes -> NBETerm.args -> NBETerm.t option + +type native_primitive_step = + { name: FStarC_Ident.lid; + arity: Prims.int; + strong_reduction_ok: bool; + tactic: itac} + +let perr s = if FStarC_Compiler_Debug.any () then BU.print_error s +let perr1 s x = if FStarC_Compiler_Debug.any () then BU.print1_error s x + +let compiled_tactics: native_primitive_step list ref = ref [] + +let list_all () = + if FStarC_Options.no_plugins () + then [] + else !compiled_tactics + +let register_plugin (s: string) (arity: Prims.int) (t: itac) (n:nbe_itac) = + let step = + { POB.name=FStarC_Ident.lid_of_str s; + POB.arity=arity; + POB.auto_reflect=None; + POB.strong_reduction_ok=true; + POB.requires_binder_substitution = false; + POB.renorm_after = false; + POB.interpretation=t; + POB.univ_arity=Z.of_int 0; + POB.interpretation_nbe=n; + } + in + FStarC_TypeChecker_Cfg.register_plugin step; + (* perr1 "Registered plugin %s\n" s; *) + () + +let register_tactic (s: string) (arity: Prims.int) (t: itac)= + let step = + { name=FStarC_Ident.lid_of_str s; + arity = arity; + strong_reduction_ok=true; + tactic=t } in + compiled_tactics := step :: !compiled_tactics; + (* perr1 "Registered tactic %s\n" s; *) + () + +let bump (f : 'b -> 'c) (g : 'a -> 'b) : 'a -> 'c = + fun x -> f (g x) + +let from_tactic_0 (tau: 'b __tac) : 'b tac = + (fun (ps: proofstate) -> + (* perr "Entering native tactic\n"; *) + tau ps) |> mk_tac + +let from_tactic_1 t = bump from_tactic_0 t +let from_tactic_2 t = bump from_tactic_1 t +let from_tactic_3 t = bump from_tactic_2 t +let from_tactic_4 t = bump from_tactic_3 t +let from_tactic_5 t = bump from_tactic_4 t +let from_tactic_6 t = bump from_tactic_5 t +let from_tactic_7 t = bump from_tactic_6 t +let from_tactic_8 t = bump from_tactic_7 t +let from_tactic_9 t = bump from_tactic_8 t +let from_tactic_10 t = bump from_tactic_9 t +let from_tactic_11 t = bump from_tactic_10 t +let from_tactic_12 t = bump from_tactic_11 t +let from_tactic_13 t = bump from_tactic_12 t +let from_tactic_14 t = bump from_tactic_13 t +let from_tactic_15 t = bump from_tactic_14 t +let from_tactic_16 t = bump from_tactic_15 t +let from_tactic_17 t = bump from_tactic_16 t +let from_tactic_18 t = bump from_tactic_17 t +let from_tactic_19 t = bump from_tactic_18 t +let from_tactic_20 t = bump from_tactic_19 t +let from_tactic_21 t = bump from_tactic_20 t +let from_tactic_22 t = bump from_tactic_21 t +let from_tactic_23 t = bump from_tactic_22 t +let from_tactic_24 t = bump from_tactic_23 t +let from_tactic_25 t = bump from_tactic_24 t diff --git a/ocaml/fstar-lib/FStarC_Tactics_V1_Builtins.ml b/ocaml/fstar-lib/FStarC_Tactics_V1_Builtins.ml new file mode 100644 index 00000000000..b6ace620316 --- /dev/null +++ b/ocaml/fstar-lib/FStarC_Tactics_V1_Builtins.ml @@ -0,0 +1,144 @@ +open Prims +open FStar_Pervasives_Native +open FStar_Pervasives +open FStarC_Tactics_Result +open FStarC_Tactics_Types +open FStar_Tactics_Effect + +module N = FStarC_TypeChecker_Normalize +module E = FStar_Tactics_Effect +module B = FStarC_Tactics_V1_Basic +module TM = FStarC_Tactics_Monad +module CTRW = FStarC_Tactics_CtrlRewrite +module RT = FStarC_Reflection_Types +module RD = FStarC_Reflection_V1_Data +module EMB = FStarC_Syntax_Embeddings +module EMBBase = FStarC_Syntax_Embeddings_Base +module NBET = FStarC_TypeChecker_NBETerm + +type 'a __tac = ('a, unit) E.tac_repr + +let interpret_tac (t: 'a TM.tac) (ps: proofstate): 'a __result = + TM.run t ps + +let uninterpret_tac (t: 'a __tac) (ps: proofstate): 'a __result = + t ps + +let to_tac_0 (t: 'a __tac): 'a TM.tac = + (fun (ps: proofstate) -> + uninterpret_tac t ps) |> TM.mk_tac + +let to_tac_1 (t: 'b -> 'a __tac): 'b -> 'a TM.tac = fun x -> + (fun (ps: proofstate) -> + uninterpret_tac (t x) ps) |> TM.mk_tac + +let from_tac_1 (t: 'a -> 'b TM.tac): 'a -> 'b __tac = + fun (x: 'a) -> + fun (ps: proofstate) -> + let m = t x in + interpret_tac m ps + +let from_tac_2 (t: 'a -> 'b -> 'c TM.tac): 'a -> 'b -> 'c __tac = + fun (x: 'a) -> + fun (y: 'b) -> + fun (ps: proofstate) -> + let m = t x y in + interpret_tac m ps + +let from_tac_3 (t: 'a -> 'b -> 'c -> 'd TM.tac): 'a -> 'b -> 'c -> 'd __tac = + fun (x: 'a) -> + fun (y: 'b) -> + fun (z: 'c) -> + fun (ps: proofstate) -> + let m = t x y z in + interpret_tac m ps + +let from_tac_4 (t: 'a -> 'b -> 'c -> 'd -> 'e TM.tac): 'a -> 'b -> 'c -> 'd -> 'e __tac = + fun (x: 'a) -> + fun (y: 'b) -> + fun (z: 'c) -> + fun (w: 'd) -> + fun (ps: proofstate) -> + let m = t x y z w in + interpret_tac m ps + +(* Pointing to the internal primitives *) +let set_goals = from_tac_1 TM.set_goals +let set_smt_goals = from_tac_1 TM.set_smt_goals +let top_env = from_tac_1 B.top_env +let fresh = from_tac_1 B.fresh +let refine_intro = from_tac_1 B.refine_intro +let tc = from_tac_2 B.tc +let tcc = from_tac_2 B.tcc +let unshelve = from_tac_1 B.unshelve +let unquote = fun t -> failwith "Sorry, unquote does not work in compiled tactics" +let norm = fun s -> from_tac_1 B.norm s +let norm_term_env = fun e s -> from_tac_3 B.norm_term_env e s +let norm_binder_type = fun s -> from_tac_2 B.norm_binder_type s +let intro = from_tac_1 B.intro +let intro_rec = from_tac_1 B.intro_rec +let rename_to = from_tac_2 B.rename_to +let revert = from_tac_1 B.revert +let binder_retype = from_tac_1 B.binder_retype +let clear_top = from_tac_1 B.clear_top +let clear = from_tac_1 B.clear +let rewrite = from_tac_1 B.rewrite +let t_exact = from_tac_3 B.t_exact +let t_apply = from_tac_4 B.t_apply +let t_apply_lemma = from_tac_3 B.t_apply_lemma +let print = from_tac_1 B.print +let debugging = from_tac_1 B.debugging +let dump = from_tac_1 B.dump +let dump_all = from_tac_2 B.dump_all +let dump_uvars_of = from_tac_2 B.dump_uvars_of +let t_trefl = from_tac_1 B.t_trefl +let dup = from_tac_1 B.dup +let prune = from_tac_1 B.prune +let addns = from_tac_1 B.addns +let t_destruct = from_tac_1 B.t_destruct +let set_options = from_tac_1 B.set_options +let uvar_env = from_tac_2 B.uvar_env +let ghost_uvar_env = from_tac_2 B.ghost_uvar_env +let unify_env = from_tac_3 B.unify_env +let unify_guard_env = from_tac_3 B.unify_guard_env +let match_env = from_tac_3 B.match_env +let launch_process = from_tac_3 B.launch_process +let fresh_bv_named = from_tac_1 B.fresh_bv_named +let change = from_tac_1 B.change +let get_guard_policy = from_tac_1 B.get_guard_policy +let set_guard_policy = from_tac_1 B.set_guard_policy +let lax_on = from_tac_1 B.lax_on +let tadmit_t = from_tac_1 B.tadmit_t +let join = from_tac_1 B.join +let inspect = from_tac_1 B.inspect +let pack = from_tac_1 B.pack +let pack_curried = from_tac_1 B.pack_curried +let curms = from_tac_1 B.curms +let set_urgency = from_tac_1 B.set_urgency +let t_commute_applied_match = from_tac_1 B.t_commute_applied_match +let gather_or_solve_explicit_guards_for_resolved_goals = from_tac_1 B.gather_explicit_guards_for_resolved_goals +let string_to_term = from_tac_2 B.string_to_term +let push_bv_dsenv = from_tac_2 B.push_bv_dsenv +let term_to_string = from_tac_1 B.term_to_string +let comp_to_string = from_tac_1 B.comp_to_string +let range_to_string = from_tac_1 B.range_to_string +let term_eq_old = from_tac_2 B.term_eq_old + +let with_compat_pre_core (n:Prims.int) (f: unit -> 'a __tac) : 'a __tac = + from_tac_2 B.with_compat_pre_core n (to_tac_0 (f ())) + +let get_vconfig = from_tac_1 B.get_vconfig +let set_vconfig = from_tac_1 B.set_vconfig +let t_smt_sync = from_tac_1 B.t_smt_sync +let free_uvars = from_tac_1 B.free_uvars + +(* The handlers need to "embed" their argument. *) +let catch (t: unit -> 'a __tac): ((exn, 'a) either) __tac = from_tac_1 TM.catch (to_tac_0 (t ())) +let recover (t: unit -> 'a __tac): ((exn, 'a) either) __tac = from_tac_1 TM.recover (to_tac_0 (t ())) + +let ctrl_rewrite + (d : direction) + (t1 : RT.term -> (bool * ctrl_flag) __tac) + (t2 : unit -> unit __tac) + : unit __tac + = from_tac_3 CTRW.ctrl_rewrite d (to_tac_1 t1) (to_tac_0 (t2 ())) diff --git a/ocaml/fstar-lib/FStarC_Tactics_V2_Builtins.ml b/ocaml/fstar-lib/FStarC_Tactics_V2_Builtins.ml new file mode 100644 index 00000000000..51ea88a8c6e --- /dev/null +++ b/ocaml/fstar-lib/FStarC_Tactics_V2_Builtins.ml @@ -0,0 +1,183 @@ +open Prims +open FStar_Pervasives_Native +open FStar_Pervasives +open FStarC_Tactics_Result +open FStarC_Tactics_Types +open FStar_Tactics_Effect + +module N = FStarC_TypeChecker_Normalize +module E = FStar_Tactics_Effect +module B = FStarC_Tactics_V2_Basic +module TM = FStarC_Tactics_Monad +module CTRW = FStarC_Tactics_CtrlRewrite +module RT = FStarC_Reflection_Types +module RD = FStarC_Reflection_Data +module EMB = FStarC_Syntax_Embeddings +module EMB_Base = FStarC_Syntax_Embeddings_Base +module NBET = FStarC_TypeChecker_NBETerm + +type 'a __tac = ('a, unit) E.tac_repr + +let interpret_tac (s:string) (t: 'a TM.tac) (ps: proofstate): 'a __result = + FStarC_Errors.with_ctx + ("While running primitive " ^ s ^ " (called from within a plugin)") + (fun () -> TM.run t ps) + +let uninterpret_tac (t: 'a __tac) (ps: proofstate): 'a __result = + t ps + +let to_tac_0 (t: 'a __tac): 'a TM.tac = + (fun (ps: proofstate) -> + uninterpret_tac t ps) |> TM.mk_tac + +let to_tac_1 (t: 'b -> 'a __tac): 'b -> 'a TM.tac = fun x -> + (fun (ps: proofstate) -> + uninterpret_tac (t x) ps) |> TM.mk_tac + +let from_tac_1 s (t: 'a -> 'r TM.tac): 'a -> 'r __tac = + fun (xa: 'a) (ps : proofstate) -> + let m = t xa in + interpret_tac s m ps + +let from_tac_2 s (t: 'a -> 'b -> 'r TM.tac): 'a -> 'b -> 'r __tac = + fun (xa: 'a) (xb: 'b) (ps : proofstate) -> + let m = t xa xb in + interpret_tac s m ps + +let from_tac_3 s (t: 'a -> 'b -> 'c -> 'r TM.tac): 'a -> 'b -> 'c -> 'r __tac = + fun (xa: 'a) (xb: 'b) (xc: 'c) (ps : proofstate) -> + let m = t xa xb xc in + interpret_tac s m ps + +let from_tac_4 s (t: 'a -> 'b -> 'c -> 'd -> 'r TM.tac): 'a -> 'b -> 'c -> 'd -> 'r __tac = + fun (xa: 'a) (xb: 'b) (xc: 'c) (xd: 'd) (ps : proofstate) -> + let m = t xa xb xc xd in + interpret_tac s m ps + +let from_tac_5 s (t: 'a -> 'b -> 'c -> 'd -> 'e -> 'r TM.tac): 'a -> 'b -> 'c -> 'd -> 'e -> 'r __tac = + fun (xa: 'a) (xb: 'b) (xc: 'c) (xd: 'd) (xe: 'e) (ps : proofstate) -> + let m = t xa xb xc xd xe in + interpret_tac s m ps + + +(* Pointing to the internal primitives *) +let compress = from_tac_1 "B.compress" B.compress +let set_goals = from_tac_1 "TM.set_goals" TM.set_goals +let set_smt_goals = from_tac_1 "TM.set_smt_goals" TM.set_smt_goals +let top_env = from_tac_1 "B.top_env" B.top_env +let fresh = from_tac_1 "B.fresh" B.fresh +let refine_intro = from_tac_1 "B.refine_intro" B.refine_intro +let tc = from_tac_2 "B.tc" B.tc +let tcc = from_tac_2 "B.tcc" B.tcc +let unshelve = from_tac_1 "B.unshelve" B.unshelve +let unquote = fun t -> failwith "Sorry, unquote does not work in compiled tactics" +let norm = fun s -> from_tac_1 "B.norm" B.norm s +let norm_term_env = fun e s -> from_tac_3 "B.norm_term_env" B.norm_term_env e s +let norm_binding_type = fun s -> from_tac_2 "B.norm_binding_type" B.norm_binding_type s +let intro = from_tac_1 "B.intro" B.intro +let intros = from_tac_1 "B.intros" B.intros +let intro_rec = from_tac_1 "B.intro_rec" B.intro_rec +let rename_to = from_tac_2 "B.rename_to" B.rename_to +let revert = from_tac_1 "B.revert" B.revert +let var_retype = from_tac_1 "B.var_retype" B.var_retype +let clear_top = from_tac_1 "B.clear_top" B.clear_top +let clear = from_tac_1 "B.clear" B.clear +let rewrite = from_tac_1 "B.rewrite" B.rewrite +let grewrite = from_tac_2 "B.grewrite" B.grewrite +let t_exact = from_tac_3 "B.t_exact" B.t_exact +let t_apply = from_tac_4 "B.t_apply" B.t_apply +let t_apply_lemma = from_tac_3 "B.t_apply_lemma" B.t_apply_lemma +let print = from_tac_1 "B.print" B.print +let debugging = from_tac_1 "B.debugging" B.debugging +let ide = from_tac_1 "B.ide" B.ide +let dump = from_tac_1 "B.dump" B.dump +let dump_all = from_tac_2 "B.dump_all" B.dump_all +let dump_uvars_of = from_tac_2 "B.dump_uvars_of" B.dump_uvars_of +let t_trefl = from_tac_1 "B.t_trefl" B.t_trefl +let dup = from_tac_1 "B.dup" B.dup +let prune = from_tac_1 "B.prune" B.prune +let addns = from_tac_1 "B.addns" B.addns +let t_destruct = from_tac_1 "B.t_destruct" B.t_destruct +let set_options = from_tac_1 "B.set_options" B.set_options +let uvar_env = from_tac_2 "B.uvar_env" B.uvar_env +let ghost_uvar_env = from_tac_2 "B.ghost_uvar_env" B.ghost_uvar_env +let unify_env = from_tac_3 "B.unify_env" B.unify_env +let unify_guard_env = from_tac_3 "B.unify_guard_env" B.unify_guard_env +let match_env = from_tac_3 "B.match_env" B.match_env +let launch_process = from_tac_3 "B.launch_process" B.launch_process +let fresh_bv_named = from_tac_1 "B.fresh_bv_named" B.fresh_bv_named +let change = from_tac_1 "B.change" B.change +let get_guard_policy = from_tac_1 "B.get_guard_policy" B.get_guard_policy +let set_guard_policy = from_tac_1 "B.set_guard_policy" B.set_guard_policy +let lax_on = from_tac_1 "B.lax_on" B.lax_on +let tadmit_t = from_tac_1 "B.tadmit_t" B.tadmit_t +let join = from_tac_1 "B.join" B.join +let curms = from_tac_1 "B.curms" B.curms +let set_urgency = from_tac_1 "B.set_urgency" B.set_urgency +let set_dump_on_failure = from_tac_1 "B.set_dump_on_failure" B.set_dump_on_failure +let t_commute_applied_match = from_tac_1 "B.t_commute_applied_match" B.t_commute_applied_match +let gather_or_solve_explicit_guards_for_resolved_goals = from_tac_1 "B.gather_explicit_guards_for_resolved_goals" B.gather_explicit_guards_for_resolved_goals +let string_to_term = from_tac_2 "B.string_to_term" B.string_to_term +let push_bv_dsenv = from_tac_2 "B.push_bv_dsenv" B.push_bv_dsenv +let term_to_string = from_tac_1 "B.term_to_string" B.term_to_string +let comp_to_string = from_tac_1 "B.comp_to_string" B.comp_to_string +let term_to_doc = from_tac_1 "B.term_to_doc" B.term_to_doc +let comp_to_doc = from_tac_1 "B.comp_to_doc" B.comp_to_doc +let range_to_string = from_tac_1 "B.range_to_string" B.range_to_string +let term_eq_old = from_tac_2 "B.term_eq_old" B.term_eq_old + +let with_compat_pre_core (n:Prims.int) (f: unit -> 'a __tac) : 'a __tac = + from_tac_2 "B.with_compat_pre_core" B.with_compat_pre_core n (to_tac_0 (f ())) + +let get_vconfig = from_tac_1 "B.get_vconfig" B.get_vconfig +let set_vconfig = from_tac_1 "B.set_vconfig" B.set_vconfig +let t_smt_sync = from_tac_1 "B.t_smt_sync" B.t_smt_sync +let free_uvars = from_tac_1 "B.free_uvars" B.free_uvars +let all_ext_options = from_tac_1 "B.all_ext_options" B.all_ext_options +let ext_getv = from_tac_1 "B.ext_getv" B.ext_getv +let ext_getns = from_tac_1 "B.ext_getns" B.ext_getns + +let alloc x = from_tac_1 "B.alloc" B.alloc x +let read r = from_tac_1 "B.read" B.read r +let write r x = from_tac_2 "B.write" B.write r x + +type ('env, 't) prop_validity_token = unit +type ('env, 'sc, 't, 'pats, 'bnds) match_complete_token = unit + +let is_non_informative = from_tac_2 "B.refl_is_non_informative" B.refl_is_non_informative +let check_subtyping = from_tac_3 "B.refl_check_subtyping" B.refl_check_subtyping +let t_check_equiv = from_tac_5 "B.t_refl_check_equiv" B.t_refl_check_equiv +let core_compute_term_type = from_tac_2 "B.refl_core_compute_term_type" B.refl_core_compute_term_type +let core_check_term = from_tac_4 "B.refl_core_check_term" B.refl_core_check_term +let core_check_term_at_type = from_tac_3 "B.refl_core_check_term_at_type" B.refl_core_check_term_at_type +let check_match_complete = from_tac_4 "B.refl_check_match_complete" B.refl_check_match_complete +let tc_term = from_tac_2 "B.refl_tc_term" B.refl_tc_term +let universe_of = from_tac_2 "B.refl_universe_of" B.refl_universe_of +let check_prop_validity = from_tac_2 "B.refl_check_prop_validity" B.refl_check_prop_validity +let instantiate_implicits = from_tac_3 "B.refl_instantiate_implicits" B.refl_instantiate_implicits +let try_unify = from_tac_4 "B.refl_try_unify" B.refl_try_unify +let maybe_relate_after_unfolding = from_tac_3 "B.refl_maybe_relate_after_unfolding" B.refl_maybe_relate_after_unfolding +let maybe_unfold_head = from_tac_2 "B.refl_maybe_unfold_head" B.refl_maybe_unfold_head +let norm_well_typed_term = from_tac_3 "B.norm_well_typed_term" B.refl_norm_well_typed_term + +let push_open_namespace = from_tac_2 "B.push_open_namespace" B.push_open_namespace +let push_module_abbrev = from_tac_3 "B.push_module_abbrev" B.push_module_abbrev +let resolve_name = from_tac_2 "B.resolve_name" B.resolve_name +let log_issues = from_tac_1 "B.log_issues" B.log_issues + +(* The handlers need to "embed" their argument. *) +let catch (t: unit -> 'a __tac): ((exn, 'a) either) __tac = from_tac_1 "TM.catch" TM.catch (to_tac_0 (t ())) +let recover (t: unit -> 'a __tac): ((exn, 'a) either) __tac = from_tac_1 "TM.recover" TM.recover (to_tac_0 (t ())) + +let ctrl_rewrite + (d : direction) + (t1 : RT.term -> (bool * ctrl_flag) __tac) + (t2 : unit -> unit __tac) + : unit __tac + = from_tac_3 "ctrl_rewrite" CTRW.ctrl_rewrite d (to_tac_1 t1) (to_tac_0 (t2 ())) + +let call_subtac g (t : unit -> unit __tac) u ty = + let t = to_tac_1 t () in + from_tac_4 "B.call_subtac" B.call_subtac g t u ty + +let call_subtac_tm = from_tac_4 "B.call_subtac_tm" B.call_subtac_tm diff --git a/ocaml/fstar-lib/FStarC_Unionfind.ml b/ocaml/fstar-lib/FStarC_Unionfind.ml new file mode 100644 index 00000000000..aa13f1e8d8d --- /dev/null +++ b/ocaml/fstar-lib/FStarC_Unionfind.ml @@ -0,0 +1,161 @@ +(* Persistent union-find implementation adapted from + https://www.lri.fr/~filliatr/puf/ *) + +open FStarC_Compiler_Effect +open FStarC_Compiler_Util + +(* Persistent arrays *) +type 'a pa_t = 'a data ref +and 'a data = + | PArray of 'a array + | PDiff of int * 'a * 'a pa_t + +let pa_create n v = mk_ref (PArray (Array.make n v)) + +let pa_init n f = mk_ref (PArray (Array.init n f)) + +let rec pa_rerootk t k = match !t with + | PArray _ -> k () + | PDiff (i, v, t') -> + pa_rerootk t' (fun () -> begin match !t' with + | PArray a -> + let v' = a.(i) in + a.(i) <- v; + t := PArray a; + t' := PDiff (i, v', t) + | PDiff _ -> failwith "Impossible" end; k()) + +let pa_reroot t = pa_rerootk t (fun () -> ()) + +let pa_get t i = match !t with + | PArray a -> a.(i) + | PDiff _ -> + pa_reroot t; + begin match !t with + | PArray a -> a.(i) + | PDiff _ -> failwith "Impossible" end + +let pa_set (t: 'a pa_t) (i: int) (v: 'a): 'a pa_t = + pa_reroot t; + match !t with + | PArray a -> + let old = a.(i) in + a.(i) <- v; + let res = mk_ref (PArray a) in + t := PDiff (i, old, res); + res + | PDiff _ -> failwith "Impossible" + +(* apply impure function from Array to a persistent array *) +let impure f t = + pa_reroot t; + match !t with PArray a -> f a | PDiff _ -> failwith "Impossible" + +let pa_length t = impure Array.length t + +(* double the array whenever its bounds are reached *) +let pa_new t x l empty = + pa_reroot t; + match !t with + | PArray a -> + if (pa_length t == l) then begin + let arr_tail = Array.make l empty in + arr_tail.(0) <- x; + t := PArray (Array.append a arr_tail) + end else + a.(l) <- x + | PDiff _ -> failwith "Impossible" + + +(* Union-find implementation based on persistent arrays *) +type 'a puf = { + (* array of parents of each node + contains either path or root element *) + mutable parent: (int, 'a) FStar_Pervasives.either pa_t; (* mutable to allow path compression *) + ranks: int pa_t; + (* keep track of how many elements are allocated in the array *) + count: int ref +} +type 'a p_uvar = P of int + [@printer fun fmt x -> Format.pp_print_string fmt "!!!"] + [@@deriving yojson,show] + (* failwith "cannot pretty-print a unification variable" *) + +let puf_empty () = + { parent = pa_create 2 (FStar_Pervasives.Inl (-1)) ; + ranks = pa_create 2 0; + count = mk_ref 0 } + +let puf_fresh (h: 'a puf) (x: 'a): 'a p_uvar = + let count = !(h.count) in + pa_new h.parent (FStar_Pervasives.Inr x) count (FStar_Pervasives.Inl (-1)); + pa_new h.ranks 0 count 0; + h.count := count + 1; + P count + +(* implements path compression, returns new array *) +let rec puf_find_aux f i = + match (pa_get f i) with + | FStar_Pervasives.Inl fi -> + let f, r, id = puf_find_aux f fi in + let f = pa_set f i (FStar_Pervasives.Inl id) in + f, r, id + | FStar_Pervasives.Inr x -> f, FStar_Pervasives.Inr x, i + +(* return both rep and previous version of parent array *) +let puf_find_i (h: 'a puf) (x: 'a p_uvar) = + let x = match x with | P a -> a in + let f, rx, i = puf_find_aux h.parent x in + h.parent <- f; + match rx with + | FStar_Pervasives.Inr r -> r, i + | FStar_Pervasives.Inl _ -> failwith "Impossible" + +(* only return the equivalence class *) +let puf_id' (h:'a puf) (x:'a p_uvar) : int = + let _, i = puf_find_i h x in + i + +let puf_id (h: 'a puf) (x: 'a p_uvar): Prims.int = + Z.of_int (puf_id' h x) + +let puf_unique_id (x: 'a p_uvar): Prims.int = + match x with + | P a -> Z.of_int a + +let puf_fromid (_:'a puf) (id : Prims.int) : 'a p_uvar = + P (Z.to_int id) + +(* only return the rep *) +let puf_find (h: 'a puf) (x: 'a p_uvar) = + let v, _ = puf_find_i h x in + v + +let puf_equivalent (h:'a puf) (x:'a p_uvar) (y:'a p_uvar) = + (puf_id' h x) = (puf_id' h y) + +let puf_change (h:'a puf) (x:'a p_uvar) (v:'a) : 'a puf = + let i = puf_id' h x in + let hp = pa_set h.parent i (FStar_Pervasives.Inr v) in + { h with parent = hp} + +let puf_union (h: 'a puf) (x: 'a p_uvar) (y: 'a p_uvar) = + let ix = puf_id' h x in + let iy = puf_id' h y in + if ix!=iy then begin + let rxc = pa_get h.ranks ix in + let ryc = pa_get h.ranks iy in + if rxc > ryc then + { parent = pa_set h.parent iy (FStar_Pervasives.Inl ix); + ranks = h.ranks; + count = h.count} + else if rxc < ryc then + { parent = pa_set h.parent ix (FStar_Pervasives.Inl iy); + ranks = h.ranks; + count = h.count} + else + { parent = pa_set h.parent iy (FStar_Pervasives.Inl ix); + ranks = pa_set h.ranks ix (rxc+1); + count = h.count } + end else + h diff --git a/ocaml/fstar-lib/FStar_Compiler_Bytes.ml b/ocaml/fstar-lib/FStar_Compiler_Bytes.ml deleted file mode 100644 index e74591b57a6..00000000000 --- a/ocaml/fstar-lib/FStar_Compiler_Bytes.ml +++ /dev/null @@ -1,111 +0,0 @@ -let b0 n = (n land 0xFF) -let b1 n = ((n lsr 8) land 0xFF) -let b2 n = ((n lsr 16) land 0xFF) -let b3 n = ((n lsr 24) land 0xFF) - -let dWw1 n = BatInt64.to_int (BatInt64.logand (BatInt64.shift_right n 32) 0xFFFFFFFFL) -let dWw0 n = BatInt64.to_int (BatInt64.logand n 0xFFFFFFFFL) - -type bytes = int array - -let f_encode f (b:bytes) = String.concat "" (Array.to_list (Array.map f b)) -let length (b:bytes) = BatArray.length b -let get (b:bytes) n = Z.of_int (BatArray.get b (Z.to_int n)) -let make (f : _ -> Z.t) n = BatArray.init (Z.to_int n) (fun i -> Z.to_int (f (Z.of_int i))) -let zero_create n : bytes = BatArray.create n 0 - -let sub ( b:bytes) s l = BatArray.sub b s l -let set = BatArray.set -let blit (a:bytes) b c d e = BatArray.blit a b c d e -let string_as_unicode_bytes (s:string) = FStar_Compiler_Util.unicode_of_string s -let utf8_bytes_as_string (b:bytes) = FStar_Compiler_Util.string_of_unicode b -let unicode_bytes_as_string (b:bytes) = FStar_Compiler_Util.string_of_unicode b -let compare (b1:bytes) (b2:bytes) = compare b1 b2 - -let to_intarray (b:bytes) = b -let of_intarray (arr:int array) = arr - -let string_as_utf8_bytes (s:string) = FStar_Compiler_Util.unicode_of_string s - -let append (b1: bytes) (b2:bytes) = BatArray.append b1 b2 - -type bytebuf = - { mutable bbArray: bytes; - mutable bbCurrent: int } - -module Bytebuf = struct - let create sz = - { bbArray=zero_create sz; - bbCurrent = 0; } - - let ensure_bytebuf buf new_size = - let old_buf_size = BatArray.length buf.bbArray in - if new_size > old_buf_size then ( - let old = buf.bbArray in - buf.bbArray <- zero_create (max new_size (old_buf_size * 2)); - blit old 0 buf.bbArray 0 buf.bbCurrent - ) - - let close buf = sub buf.bbArray 0 buf.bbCurrent - - let emit_int_as_byte buf i = - let new_size = buf.bbCurrent + 1 in - ensure_bytebuf buf new_size; - set buf.bbArray buf.bbCurrent i; - buf.bbCurrent <- new_size - - let emit_byte buf (b:char) = emit_int_as_byte buf (int_of_char b) - let emit_bool_as_byte buf (b:bool) = emit_int_as_byte buf (if b then 1 else 0) - - let emit_bytes buf i = - let n = length i in - let new_size = buf.bbCurrent + n in - ensure_bytebuf buf new_size; - blit i 0 buf.bbArray buf.bbCurrent n; - buf.bbCurrent <- new_size - - let emit_i32_as_u16 buf n = - let new_size = buf.bbCurrent + 2 in - ensure_bytebuf buf new_size; - set buf.bbArray buf.bbCurrent (b0 n); - set buf.bbArray (buf.bbCurrent + 1) (b1 n); - buf.bbCurrent <- new_size - - (* let emit_u16 buf (x:uint16) = emit_i32_as_u16 buf (BatInt64.to_int x) *) - - let fixup_i32 bb pos n = - set bb.bbArray pos (b0 n); - set bb.bbArray (pos + 1) (b1 n); - set bb.bbArray (pos + 2) (b2 n); - set bb.bbArray (pos + 3) (b3 n) - - let emit_i32 buf n = - let new_size = buf.bbCurrent + 4 in - ensure_bytebuf buf new_size; - fixup_i32 buf buf.bbCurrent n; - buf.bbCurrent <- new_size - - let emit_i64 buf x = - emit_i32 buf (dWw0 x); - emit_i32 buf (dWw1 x) - - let emit_intarray_as_bytes buf arr = - let n = BatArray.length arr in - let new_size = buf.bbCurrent + n in - ensure_bytebuf buf new_size; - let bbarr = buf.bbArray in - let bbbase = buf.bbCurrent in - for i= 0 to n - 1 do set bbarr (bbbase + i) (BatArray.get arr i) done; - buf.bbCurrent <- new_size - - let length bb = bb.bbCurrent - let position bb = bb.bbCurrent - -end - -let create i = Bytebuf.create i -let close t = Bytebuf.close t -let emit_int_as_byte t i = Bytebuf.emit_int_as_byte t (Z.to_int i) -let emit_bytes t b = Bytebuf.emit_bytes t b - -let length x = Z.of_int (length x) diff --git a/ocaml/fstar-lib/FStar_Compiler_Hints.ml b/ocaml/fstar-lib/FStar_Compiler_Hints.ml deleted file mode 100644 index d8d96dffb33..00000000000 --- a/ocaml/fstar-lib/FStar_Compiler_Hints.ml +++ /dev/null @@ -1,118 +0,0 @@ -open FStar_Json - -(** Hints. *) -type hint = { - hint_name:string; - hint_index:Z.t; - fuel:Z.t; - ifuel:Z.t; - unsat_core:string list option; - query_elapsed_time:Z.t; - hash:string option -} - -type hints = hint option list - -type hints_db = { - module_digest:string; - hints: hints -} - -type hints_read_result = - | HintsOK of hints_db - | MalformedJson - | UnableToOpen - -let write_hints (filename: string) (hints: hints_db): unit = - let json = `List [ - `String hints.module_digest; - `List (List.map (function - | None -> `Null - | Some { hint_name; hint_index; fuel; ifuel; unsat_core; query_elapsed_time; hash } -> - `List [ - `String hint_name; - `Int (Z.to_int hint_index); - `Int (Z.to_int fuel); - `Int (Z.to_int ifuel); - (match unsat_core with - | None -> `Null - | Some strings -> - `List (List.map (fun s -> `String s) strings)); - `Int (Z.to_int query_elapsed_time); - `String (match hash with | Some(h) -> h | _ -> "") - ] - ) hints.hints) - ] in - let channel = open_out_bin filename in - BatPervasives.finally - (fun () -> close_out channel) - (fun channel -> Yojson.Safe.pretty_to_channel channel json) - channel - -let read_hints (filename: string) : hints_read_result = - let mk_hint nm ix fuel ifuel unsat_core time hash_opt = { - hint_name = nm; - hint_index = Z.of_int ix; - fuel = Z.of_int fuel; - ifuel = Z.of_int ifuel; - unsat_core = begin - match unsat_core with - | `Null -> - None - | `List strings -> - Some (List.map (function - | `String s -> s - | _ -> raise Exit) - strings) - | _ -> - raise Exit - end; - query_elapsed_time = Z.of_int time; - hash = hash_opt - } - in - try - let chan = open_in filename in - let json = Yojson.Safe.from_channel chan in - close_in chan; - HintsOK ( - match json with - | `List [ - `String module_digest; - `List hints - ] -> { - module_digest; - hints = List.map (function - | `Null -> None - | `List [ `String hint_name; - `Int hint_index; - `Int fuel; - `Int ifuel; - unsat_core; - `Int query_elapsed_time ] -> - (* This case is for dealing with old-style hint files - that lack a query-hashes field. We should remove this - case once we definitively remove support for old hints *) - Some (mk_hint hint_name hint_index fuel ifuel unsat_core query_elapsed_time None) - | `List [ `String hint_name; - `Int hint_index; - `Int fuel; - `Int ifuel; - unsat_core; - `Int query_elapsed_time; - `String hash ] -> - let hash_opt = if hash <> "" then Some(hash) else None in - Some (mk_hint hint_name hint_index fuel ifuel unsat_core query_elapsed_time hash_opt) - | _ -> - raise Exit - ) hints - } - | _ -> - raise Exit - ) - with - | Exit -> - MalformedJson - | Sys_error _ -> - UnableToOpen - diff --git a/ocaml/fstar-lib/FStar_Compiler_Range.ml b/ocaml/fstar-lib/FStar_Compiler_Range.ml deleted file mode 100644 index f9ae291abeb..00000000000 --- a/ocaml/fstar-lib/FStar_Compiler_Range.ml +++ /dev/null @@ -1,2 +0,0 @@ -include FStar_Compiler_Range_Type -include FStar_Compiler_Range_Ops diff --git a/ocaml/fstar-lib/FStar_Compiler_Util.ml b/ocaml/fstar-lib/FStar_Compiler_Util.ml deleted file mode 100644 index 3910c68f776..00000000000 --- a/ocaml/fstar-lib/FStar_Compiler_Util.ml +++ /dev/null @@ -1,1165 +0,0 @@ -open FStar_Json - -let max_int = Z.of_int max_int -let is_letter c = if c > 255 then false else BatChar.is_letter (BatChar.chr c) -let is_digit c = if c > 255 then false else BatChar.is_digit (BatChar.chr c) -let is_letter_or_digit c = is_letter c || is_digit c -let is_symbol c = if c > 255 then false else BatChar.is_symbol (BatChar.chr c) - -(* Modeled after: Char.IsPunctuation in .NET - (http://www.dotnetperls.com/char-ispunctuation) -*) -let is_punctuation c = List.mem c [33; 34; 35; 37; 38; 39; 40; 41; 42; 44; 45; 46; 47; 58; 59; 63; 64; 91; 92; 93; 95; 123; 125] -(*'!','"','#','%','&','\'','(',')','*',',','-','.','/',':',';','?','@','[','\\',']','_','{','}'*) - -let return_all x = x - -type time = float -let now () = BatUnix.gettimeofday () -let now_ms () = Z.of_int (int_of_float (now () *. 1000.0)) -let time_diff (t1:time) (t2:time) : float * Prims.int = - let n = t2 -. t1 in - n, - Z.of_float (n *. 1000.0) -let record_time f = - let start = now () in - let res = f () in - let _, elapsed = time_diff start (now()) in - res, elapsed -let get_file_last_modification_time f = (BatUnix.stat f).BatUnix.st_mtime -let is_before t1 t2 = compare t1 t2 < 0 -let string_of_time = string_of_float - -exception Impos - -let cur_sigint_handler : Sys.signal_behavior ref = - ref Sys.Signal_default - -exception SigInt -type sigint_handler = Sys.signal_behavior - -let sigint_handler_f f = Sys.Signal_handle f - -let sigint_ignore: sigint_handler = - Sys.Signal_ignore - -let sigint_delay = ref 0 -let sigint_pending = ref false - -let raise_sigint _ = - sigint_pending := false; - raise SigInt - -let raise_sigint_maybe_delay _ = - (* This function should not do anything complicated, lest it cause deadlocks. - * Calling print_string, for example, can cause a deadlock (print_string → - * caml_flush → process_pending_signals → caml_execute_signal → raise_sigint → - * print_string → caml_io_mutex_lock ⇒ deadlock) *) - if !sigint_delay = 0 - then raise_sigint () - else sigint_pending := true - -let sigint_raise: sigint_handler = - Sys.Signal_handle raise_sigint_maybe_delay - -let get_sigint_handler () = - !cur_sigint_handler - -let set_sigint_handler sigint_handler = - cur_sigint_handler := sigint_handler; - Sys.set_signal Sys.sigint !cur_sigint_handler - -let with_sigint_handler handler f = - let original_handler = !cur_sigint_handler in - BatPervasives.finally - (fun () -> Sys.set_signal Sys.sigint original_handler) - (fun () -> set_sigint_handler handler; f ()) - () - -(* Re export this type, it's mentioned in the interface for this module. *) -type out_channel = Stdlib.out_channel - -let stderr = Stdlib.stderr -let stdout = Stdlib.stdout - -let open_file_for_writing (fn : string) = Stdlib.open_out_bin fn -let open_file_for_appending (fn : string) = Stdlib.open_out_gen [Open_append; Open_wronly; Open_creat; Open_binary] 0o644 fn -let close_out_channel (c : out_channel) = Stdlib.close_out c - -let flush (c:out_channel) : unit = Stdlib.flush c - -let append_to_file (c:out_channel) s = Printf.fprintf c "%s\n" s; flush c - -type proc = - {pid: int; - inc : in_channel; (* in == where we read from, so the process's stdout *) - errc : in_channel; (* the process's stderr *) - outc : out_channel; (* the process's stdin *) - mutable killed : bool; - stop_marker: (string -> bool) option; - id : string; - prog : string; - start_time : time} - -let all_procs : (proc list) ref = ref [] - -let lock () = () -let release () = () -let sleep n = Thread.delay ((Z.to_float n) /. 1000.) - -let mlock = Mutex.create () - -let monitor_enter _ = Mutex.lock mlock -let monitor_exit _ = Mutex.unlock mlock -let monitor_wait _ = () -let monitor_pulse _ = () -let current_tid _ = Z.zero - -let atomically f = (* This function only protects against signals *) - let finalizer () = - decr sigint_delay; - if !sigint_pending && !sigint_delay = 0 then - raise_sigint () in - let body f = - incr sigint_delay; f () in - BatPervasives.finally finalizer body f - -let with_monitor _ f x = atomically (fun () -> - monitor_enter (); - BatPervasives.finally monitor_exit f x) - -let spawn f = - let _ = Thread.create f () in () - -let stack_dump () = Printexc.raw_backtrace_to_string (Printexc.get_callstack 1000) - -(* On the OCaml side it would make more sense to take stop_marker in - ask_process, but the F# side isn't built that way *) -let start_process' - (id: string) (prog: string) (args: string list) - (stop_marker: (string -> bool) option) : proc = - let (stdin_r, stdin_w) = Unix.pipe () in - let (stdout_r, stdout_w) = Unix.pipe () in - let (stderr_r, stderr_w) = Unix.pipe () in - Unix.set_close_on_exec stdin_w; - Unix.set_close_on_exec stdout_r; - Unix.set_close_on_exec stderr_r; - let pid = Unix.create_process prog (Array.of_list (prog :: args)) stdin_r stdout_w stderr_w in - Unix.close stdin_r; - Unix.close stdout_w; - Unix.close stderr_w; - let proc = { pid = pid; - id = prog ^ ":" ^ id; - prog = prog; - inc = Unix.in_channel_of_descr stdout_r; - errc = Unix.in_channel_of_descr stderr_r; - outc = Unix.out_channel_of_descr stdin_w; - stop_marker = stop_marker; - killed = false; - start_time = now()} in - (* print_string ("Started process " ^ proc.id ^ "\n" ^ (stack_dump())); *) - all_procs := proc :: !all_procs; - proc - -let start_process - (id: string) (prog: string) (args: string list) - (stop_marker: string -> bool) : proc = - start_process' id prog args (Some stop_marker) - -let rec waitpid_ignore_signals pid = - try ignore (Unix.waitpid [] pid) - with Unix.Unix_error (Unix.EINTR, _, _) -> - waitpid_ignore_signals pid - -let kill_process (p: proc) = - if not p.killed then begin - (* Close the fds directly: close_in and close_out both call `flush`, - potentially forcing us to wait until p starts reading again. They - might have been closed already (e.g. `run_process`), so we - just `attempt` it. *) - let attempt f = - try f () with | _ -> () - in - attempt (fun () -> Unix.close (Unix.descr_of_in_channel p.inc)); - attempt (fun () -> Unix.close (Unix.descr_of_in_channel p.errc)); - attempt (fun () -> Unix.close (Unix.descr_of_out_channel p.outc)); - (try Unix.kill p.pid Sys.sigkill - with Unix.Unix_error (Unix.ESRCH, _, _) -> ()); - (* Avoid zombie processes (Unix.close_process does the same thing. *) - waitpid_ignore_signals p.pid; - (* print_string ("Killed process " ^ p.id ^ "\n" ^ (stack_dump())); *) - p.killed <- true - end - -let kill_all () = - BatList.iter kill_process !all_procs - -let proc_prog (p:proc) : string = p.prog - -let process_read_all_output (p: proc) = - (* Pass cleanup:false because kill_process closes both fds already. *) - BatIO.read_all (BatIO.input_channel ~autoclose:true ~cleanup:false p.inc) - - -let channel_read_all_nonblock (c: in_channel) : string = - let buffer = Bytes.create 8192 in - let fd = Unix.descr_of_in_channel c in - let rec aux (idx:int) (rem:int) = - if rem <= 0 then idx - else ( - let rd, _, _ = Unix.select [fd] [] [] 0.0 in - if rd = [] then idx - else ( - let n = Unix.read fd buffer idx rem in - if n <= 0 - then idx - else aux (idx+n) (rem-n) - ) - ) - in - let len = aux 0 1024 in - Bytes.sub_string buffer 0 len - -(** Feed `stdin` to `p`, and call `reader_fn` in a separate thread to read the - response. - - Signal handling makes this function fairly hairy. The usual design is to - launch a reader thread, then write to the process on the main thread and use - `Thread.join` to wait for the reader to complete. - - When we get a signal, Caml routes it to either of the threads. If it - reaches the reader thread, we're good: the reader thread is most likely - waiting in input_line at that point, and input_line polls for signals fairly - frequently. If the signal reaches the writer (main) thread, on the other - hand, we're toast: `Thread.join` isn't interruptible, so Caml will save the - signal until the child thread exits and `join` returns, and at that point the - Z3 query is complete and the signal is useless. - - There are three possible solutions to this problem: - 1. Use an interruptible version of Thread.join written in C - 2. Ensure that signals are always delivered to the reader thread - 3. Use a different synchronization mechanism between the reader and the writer. - - Option 1 is bad because building F* doesn't currently require a C compiler. - Option 2 is easy to implement with `Unix.sigprocmask`, but that isn't - available on Windows. Option 3 is what the code below does: it uses a pipe - and a 1-byte write as a way for the writer thread to wait on the reader - thread. That's why `reader_fn` is passed a `signal_exit` function. - - If a SIGINT reaches the reader, it should still call `signal_exit`. If - a SIGINT reaches the writer, it should make sure that the reader exits. - These two things are the responsibility of the caller of this function. **) - -let process_read_async p stdin reader_fn = - let fd_r, fd_w = Unix.pipe () in - BatPervasives.finally (fun () -> Unix.close fd_w; Unix.close fd_r) - (fun () -> - let wait_for_exit () = - ignore (Unix.read fd_r (Bytes.create 1) 0 1) in - let signal_exit () = - try ignore (Unix.write fd_w (Bytes.create 1) 0 1) - with (* ‘write’ will fail if called after the finalizer above *) - | Unix.Unix_error (Unix.EBADF, _, _) -> () in - - let write_input = function - | Some str -> output_string p.outc str; flush p.outc - | None -> () in - - (* In the following we can get a signal at any point; it's the caller's - responsibility to ensure that reader_fn will exit in that case *) - let t = Thread.create reader_fn signal_exit in - write_input stdin; - wait_for_exit (); - Thread.join t) () - -let run_process (id: string) (prog: string) (args: string list) (stdin: string option): string = - let p = start_process' id prog args None in - (match stdin with - | None -> () - | Some str -> - try output_string p.outc str with - | Sys_error _ -> () (* FIXME: check for "Broken pipe". In that case this is fine, process must have finished without reading input *) - | e -> raise e - ); - (try flush p.outc with | _ -> ()); (* only _attempt_ to flush, so we don't get an exception if the process is finished *) - (try close_out p.outc with | _ -> ()); (* idem *) - let s = process_read_all_output p in - kill_process p; - s - -let system_run (cmd:string) : Z.t = Z.of_int (Sys.command cmd) - -type read_result = EOF | SIGINT - -let handle_stderr (p:proc) (h : string -> unit) = - (* Read stderr and call the handler if anything is in there. *) - let se = channel_read_all_nonblock p.errc in - if se <> "" then - h (BatString.trim se) - -let ask_process - (p: proc) (stdin: string) - (exn_handler: unit -> string) - (stderr_handler : string -> unit) - : string = - let result = ref None in - let out = Buffer.create 16 in - let stop_marker = BatOption.default (fun s -> false) p.stop_marker in - - let reader_fn signal_fn = - let rec loop p out = - let line = BatString.trim (input_line p.inc) in (* raises EOF *) - if not (stop_marker line) then - (Buffer.add_string out (line ^ "\n"); loop p out) in - (try loop p out - with | SigInt -> result := Some SIGINT - | End_of_file -> result := Some EOF); - signal_fn () in - - try - (* Check stderr both before and after asking. Note: this does - * not handle the case when the process prints something to stderr - * and then hangs. We will stay in the process_read_async call without - * ever handling the output. To properly handle that, we could - * use a separate thread, but then all stderr_handler functions need - * to take locks. Since this is not a problem for now, we just avoid - * this complexity. *) - handle_stderr p stderr_handler; - process_read_async p (Some stdin) reader_fn; - handle_stderr p stderr_handler; - (match !result with - | Some EOF -> kill_process p; Buffer.add_string out (exn_handler ()) - | Some SIGINT -> raise SigInt - | None -> ()); - Buffer.contents out - with e -> (* Ensure that reader_fn gets an EOF and exits *) - kill_process p; raise e - -let get_file_extension (fn:string) : string = snd (BatString.rsplit fn ".") -let is_path_absolute path_str = - let open Batteries.Incubator in - let open BatPathGen.OfString in - let path_str' = of_string path_str in - is_absolute path_str' -let join_paths path_str0 path_str1 = - let open Batteries.Incubator in - let open BatPathGen.OfString in - let open BatPathGen.OfString.Operators in - to_string ((of_string path_str0) //@ (of_string path_str1)) - -let normalize_file_path (path_str:string) = - let open Batteries.Incubator in - let open BatPathGen.OfString in - let open BatPathGen.OfString.Operators in - to_string - (normalize_in_tree - (let path = of_string path_str in - if is_absolute path then - path - else - let pwd = of_string (BatSys.getcwd ()) in - pwd //@ path)) - -type stream_reader = BatIO.input -let open_stdin () = BatIO.stdin -let read_line s = - try - Some (BatIO.read_line s) - with - _ -> None -let nread (s:stream_reader) (n:Z.t) = - try - Some (BatIO.nread s (Z.to_int n)) - with - _ -> None - -let poll_stdin (f:float) = - try - let ready_fds, _, _ = Unix.select [Unix.stdin] [] [] f in - match ready_fds with - | [] -> false - | _ -> true - with - | _ -> false - -type string_builder = BatBuffer.t -let new_string_builder () = BatBuffer.create 256 -let clear_string_builder b = BatBuffer.clear b -let string_of_string_builder b = BatBuffer.contents b -let string_builder_append b s = BatBuffer.add_string b s - -let message_of_exn (e:exn) = Printexc.to_string e -let trace_of_exn (e:exn) = Printexc.get_backtrace () - -module StringOps = - struct - type t = string - let equal (x:t) (y:t) = x=y - let compare (x:t) (y:t) = BatString.compare x y - let hash (x:t) = BatHashtbl.hash x - end - -module StringHashtbl = BatHashtbl.Make(StringOps) -module StringMap = BatMap.Make(StringOps) - -type 'value smap = 'value StringHashtbl.t -let smap_create (i:Z.t) : 'value smap = StringHashtbl.create (Z.to_int i) -let smap_clear (s:('value smap)) = StringHashtbl.clear s -let smap_add (m:'value smap) k (v:'value) = StringHashtbl.replace m k v -let smap_of_list (l: (string * 'value) list) = - let s = StringHashtbl.create (BatList.length l) in - FStar_List.iter (fun (x,y) -> smap_add s x y) l; - s -let smap_try_find (m:'value smap) k = StringHashtbl.find_option m k -let smap_fold (m:'value smap) f a = StringHashtbl.fold f m a -let smap_remove (m:'value smap) k = StringHashtbl.remove m k -let smap_keys (m:'value smap) = smap_fold m (fun k _ acc -> k::acc) [] -let smap_copy (m:'value smap) = StringHashtbl.copy m -let smap_size (m:'value smap) = StringHashtbl.length m -let smap_iter (m:'value smap) f = StringHashtbl.iter f m - -exception PSMap_Found -type 'value psmap = 'value StringMap.t -let psmap_empty (_: unit) : 'value psmap = StringMap.empty -let psmap_add (map: 'value psmap) (key: string) (value: 'value) = StringMap.add key value map -let psmap_find_default (map: 'value psmap) (key: string) (dflt: 'value) = - StringMap.find_default dflt key map -let psmap_try_find (map: 'value psmap) (key: string) = - StringMap.Exceptionless.find key map -let psmap_fold (m:'value psmap) f a = StringMap.fold f m a -let psmap_find_map (m:'value psmap) f = - let res = ref None in - let upd k v = - let r = f k v in - if r <> None then (res := r; raise PSMap_Found) in - (try StringMap.iter upd m with PSMap_Found -> ()); - !res -let psmap_modify (m: 'value psmap) (k: string) (upd: 'value option -> 'value) = - StringMap.modify_opt k (fun vopt -> Some (upd vopt)) m - -let psmap_merge (m1: 'value psmap) (m2: 'value psmap) : 'value psmap = - psmap_fold m1 (fun k v m -> psmap_add m k v) m2 - -let psmap_remove (m: 'value psmap) (key:string) - : 'value psmap = StringMap.remove key m - -module ZHashtbl = BatHashtbl.Make(Z) -module ZMap = BatMap.Make(Z) - -type 'value imap = 'value ZHashtbl.t -let imap_create (i:Z.t) : 'value imap = ZHashtbl.create (Z.to_int i) -let imap_clear (s:('value imap)) = ZHashtbl.clear s -let imap_add (m:'value imap) k (v:'value) = ZHashtbl.replace m k v -let imap_of_list (l: (Z.t * 'value) list) = - let s = ZHashtbl.create (BatList.length l) in - FStar_List.iter (fun (x,y) -> imap_add s x y) l; - s -let imap_try_find (m:'value imap) k = ZHashtbl.find_option m k -let imap_fold (m:'value imap) f a = ZHashtbl.fold f m a -let imap_remove (m:'value imap) k = ZHashtbl.remove m k -let imap_keys (m:'value imap) = imap_fold m (fun k _ acc -> k::acc) [] -let imap_copy (m:'value imap) = ZHashtbl.copy m - -type 'value pimap = 'value ZMap.t -let pimap_empty (_: unit) : 'value pimap = ZMap.empty -let pimap_add (map: 'value pimap) (key: Z.t) (value: 'value) = ZMap.add key value map -let pimap_find_default (map: 'value pimap) (key: Z.t) (dflt: 'value) = - ZMap.find_default dflt key map -let pimap_try_find (map: 'value pimap) (key: Z.t) = - ZMap.Exceptionless.find key map -let pimap_fold (m:'value pimap) f a = ZMap.fold f m a - -(* restore pre-2.11 BatString.nsplit behavior, - see https://github.com/ocaml-batteries-team/batteries-included/issues/845 *) -let batstring_nsplit s t = - if s = "" then [] else BatString.split_on_string t s - -let format (fmt:string) (args:string list) = - let frags = batstring_nsplit fmt "%s" in - if BatList.length frags <> BatList.length args + 1 then - failwith ("Not enough arguments to format string " ^fmt^ " : expected " ^ (Stdlib.string_of_int (BatList.length frags)) ^ " got [" ^ (BatString.concat ", " args) ^ "] frags are [" ^ (BatString.concat ", " frags) ^ "]") - else - let sbldr = new_string_builder () in - string_builder_append sbldr (List.hd frags); - BatList.iter2 - (fun frag arg -> string_builder_append sbldr arg; - string_builder_append sbldr frag) - (List.tl frags) args; - string_of_string_builder sbldr - -let format1 f a = format f [a] -let format2 f a b = format f [a;b] -let format3 f a b c = format f [a;b;c] -let format4 f a b c d = format f [a;b;c;d] -let format5 f a b c d e = format f [a;b;c;d;e] -let format6 f a b c d e g = format f [a;b;c;d;e;g] - -let flush_stdout () = flush stdout - -let stdout_isatty () = Some (Unix.isatty Unix.stdout) - -(* NOTE: this is deciding whether or not to color by looking - at stdout_isatty(), which may be a wrong choice if - we're instead outputting to stderr. e.g. - fstar.exe Blah.fst 2>errlog - will colorize the errors in the file if stdout is not - also redirected. -*) -let colorize s colors = - match colors with - | (c1,c2) -> - match stdout_isatty () with - | Some true -> format3 "%s%s%s" c1 s c2 - | _ -> s - -let colorize_bold s = - match stdout_isatty () with - | Some true -> format3 "%s%s%s" "\x1b[39;1m" s "\x1b[0m" - | _ -> s - -let colorize_red s = - match stdout_isatty () with - | Some true -> format3 "%s%s%s" "\x1b[31;1m" s "\x1b[0m" - | _ -> s - -let colorize_yellow s = - match stdout_isatty () with - | Some true -> format3 "%s%s%s" "\x1b[33;1m" s "\x1b[0m" - | _ -> s - -let colorize_cyan s = - match stdout_isatty () with - | Some true -> format3 "%s%s%s" "\x1b[36;1m" s "\x1b[0m" - | _ -> s - -let colorize_green s = - match stdout_isatty () with - | Some true -> format3 "%s%s%s" "\x1b[32;1m" s "\x1b[0m" - | _ -> s - -let colorize_magenta s = - match stdout_isatty () with - | Some true -> format3 "%s%s%s" "\x1b[35;1m" s "\x1b[0m" - | _ -> s - -let pr = Printf.printf -let spr = Printf.sprintf -let fpr = Printf.fprintf - -type printer = { - printer_prinfo: string -> unit; - printer_prwarning: string -> unit; - printer_prerror: string -> unit; - printer_prgeneric: string -> (unit -> string) -> (unit -> json) -> unit -} - -let default_printer = - { printer_prinfo = (fun s -> pr "%s" s; flush stdout); - printer_prwarning = (fun s -> fpr stderr "%s" (colorize_yellow s); flush stdout; flush stderr); - printer_prerror = (fun s -> fpr stderr "%s" (colorize_red s); flush stdout; flush stderr); - printer_prgeneric = fun label get_string get_json -> pr "%s: %s" label (get_string ())} - -let current_printer = ref default_printer -let set_printer printer = current_printer := printer - -let print_raw s = set_binary_mode_out stdout true; pr "%s" s; flush stdout -let print_string s = (!current_printer).printer_prinfo s -let print_generic label to_string to_json a = (!current_printer).printer_prgeneric label (fun () -> to_string a) (fun () -> to_json a) -let print_any s = (!current_printer).printer_prinfo (Marshal.to_string s []) -let strcat s1 s2 = s1 ^ s2 -let concat_l sep (l:string list) = BatString.concat sep l - -let string_of_unicode (bytes:int array) = - BatArray.fold_left (fun acc b -> acc^(BatUTF8.init 1 (fun _ -> BatUChar.of_int b))) "" bytes -let unicode_of_string (string:string) = - let n = BatUTF8.length string in - let t = Array.make n 0 in - let i = ref 0 in - BatUTF8.iter (fun c -> t.(!i) <- BatUChar.code c; incr i) string; - t -let base64_encode s = BatBase64.str_encode s -let base64_decode s = BatBase64.str_decode s -let char_of_int i = Z.to_int i -let int_of_string = Z.of_string -let safe_int_of_string x = - if x = "" then None else - try Some (int_of_string x) with Invalid_argument _ -> None -let int_of_char x = Z.of_int x -let int_of_byte x = x -let int_of_uint8 x = Z.of_int (Char.code x) -let uint16_of_int i = Z.to_int i -let byte_of_char c = c - -let float_of_string s = float_of_string s -let float_of_byte b = float_of_int (Char.code b) -let float_of_int32 = float_of_int -let float_of_int64 = BatInt64.to_float - -let int_of_int32 i = i -let int32_of_int i = BatInt32.of_int i - -let string_of_int = Z.to_string -let string_of_bool = string_of_bool -let string_of_int32 = BatInt32.to_string -let string_of_int64 = BatInt64.to_string -let string_of_float = string_of_float -let string_of_char i = BatUTF8.init 1 (fun _ -> BatUChar.chr i) -let hex_string_of_byte (i:int) = - let hs = spr "%x" i in - if (String.length hs = 1) then "0" ^ hs - else hs -let string_of_bytes = string_of_unicode -let bytes_of_string = unicode_of_string -let starts_with = BatString.starts_with -let trim_string = BatString.trim -let ends_with = BatString.ends_with -let char_at s index = BatUChar.code (BatUTF8.get s (Z.to_int index)) -let is_upper c = 65 <= c && c <= 90 -let contains (s1:string) (s2:string) = BatString.exists s1 s2 -let substring_from s index = BatString.tail s (Z.to_int index) -let substring s i j = BatString.sub s (Z.to_int i) (Z.to_int j) -let replace_char (s:string) c1 c2 = - let c1, c2 = BatUChar.chr c1, BatUChar.chr c2 in - BatUTF8.map (fun x -> if x = c1 then c2 else x) s -let replace_chars (s:string) c (by:string) = - BatString.replace_chars (fun x -> if x = Char.chr c then by else BatString.of_char x) s -let hashcode s = Z.of_int (StringOps.hash s) -let compare s1 s2 = Z.of_int (BatString.compare s1 s2) -let split s sep = BatString.split_on_string sep s -let splitlines s = split s "\n" - -let iof = int_of_float -let foi = float_of_int - -let print1 a b = print_string (format1 a b) -let print2 a b c = print_string (format2 a b c) -let print3 a b c d = print_string (format3 a b c d) -let print4 a b c d e = print_string (format4 a b c d e) -let print5 a b c d e f = print_string (format5 a b c d e f) -let print6 a b c d e f g = print_string (format6 a b c d e f g) -let print fmt args = print_string (format fmt args) - -let print_error s = (!current_printer).printer_prerror s -let print1_error a b = print_error (format1 a b) -let print2_error a b c = print_error (format2 a b c) -let print3_error a b c d = print_error (format3 a b c d) - -let print_warning s = (!current_printer).printer_prwarning s -let print1_warning a b = print_warning (format1 a b) -let print2_warning a b c = print_warning (format2 a b c) -let print3_warning a b c d = print_warning (format3 a b c d) - -let fprint (oc:out_channel) fmt args : unit = Printf.fprintf oc "%s" (format fmt args) - -[@@deriving yojson,show] - -let is_left = function - | FStar_Pervasives.Inl _ -> true - | _ -> false - -let is_right = function - | FStar_Pervasives.Inr _ -> true - | _ -> false - -let left = function - | FStar_Pervasives.Inl x -> x - | _ -> failwith "Not in left" -let right = function - | FStar_Pervasives.Inr x -> x - | _ -> failwith "Not in right" - -let (-<-) f g x = f (g x) - -let find_dup f l = - let rec aux = function - | hd::tl -> - let hds, tl' = BatList.partition (f hd) tl in - (match hds with - | [] -> aux tl' - | _ -> Some hd) - | _ -> None in - aux l - -let nodups f l = match find_dup f l with | None -> true | _ -> false - -let remove_dups f l = - let rec aux out = function - | hd::tl -> let _, tl' = BatList.partition (f hd) tl in aux (hd::out) tl' - | _ -> out in - aux [] l - -let is_none = function - | None -> true - | Some _ -> false - -let is_some = function - | None -> false - | Some _ -> true - -let must = function - | Some x -> x - | None -> failwith "Empty option" - -let dflt x = function - | None -> x - | Some x -> x - -let find_opt f l = - let rec aux = function - | [] -> None - | hd::tl -> if f hd then Some hd else aux tl in - aux l - -(* JP: why so many duplicates? :'( *) -let sort_with = FStar_List.sortWith - -let bind_opt opt f = - match opt with - | None -> None - | Some x -> f x - -let catch_opt opt f = - match opt with - | Some x -> opt - | None -> f () - -let map_opt opt f = - match opt with - | None -> None - | Some x -> Some (f x) - -let iter_opt opt f = - ignore (map_opt opt f) - -let rec find_map l f = - match l with - | [] -> None - | x::tl -> - match f x with - | None -> find_map tl f - | y -> y - -let try_find f l = BatList.find_opt f l - -let try_find_index f l = - let rec aux i = function - | [] -> None - | hd::tl -> if f hd then Some (Z.of_int i) else aux (i+1) tl in - aux 0 l - -let fold_map f state s = - let fold (state, acc) x = - let state, v = f state x in (state, v :: acc) in - let (state, rs) = BatList.fold_left fold (state, []) s in - (state, BatList.rev rs) - -let choose_map f state s = - let fold (state, acc) x = - match f state x with - | state, None -> (state, acc) - | state, Some v -> (state, v :: acc) in - let (state, rs) = BatList.fold_left fold (state, []) s in - (state, BatList.rev rs) - -let for_all f l = BatList.for_all f l -let for_some f l = BatList.exists f l -let forall_exists rel l1 l2 = - for_all (fun x -> for_some (rel x) l2) l1 -let multiset_equiv rel l1 l2 = - BatList.length l1 = BatList.length l2 && forall_exists rel l1 l2 -let take p l = - let rec take_aux acc = function - | [] -> l, [] - | x::xs when p x -> take_aux (x::acc) xs - | x::xs -> List.rev acc, x::xs - in take_aux [] l - -let rec fold_flatten f acc l = - match l with - | [] -> acc - | x :: xs -> let acc, xs' = f acc x in fold_flatten f acc (xs' @ xs) - -let add_unique f x l = - if for_some (f x) l then - l - else - x::l - -let first_N n l = - let n = Z.to_int n in - let rec f acc i l = - if i = n then BatList.rev acc,l else - match l with - | h::tl -> f (h::acc) (i+1) tl - | _ -> failwith "firstN" - in - f [] 0 l - -let nth_tail n l = - let rec aux n l = - if n=0 then l else aux (n - 1) (BatList.tl l) - in - aux (Z.to_int n) l - -let prefix l = - match BatList.rev l with - | hd::tl -> BatList.rev tl, hd - | _ -> failwith "impossible" - -let prefix_until f l = - let rec aux prefix = function - | [] -> None - | hd::tl -> - if f hd then Some (BatList.rev prefix, hd, tl) - else aux (hd::prefix) tl in - aux [] l - -let string_to_ascii_bytes (s:string) : char array = - BatArray.of_list (BatString.explode s) -let ascii_bytes_to_string (b:char array) : string = - BatString.implode (BatArray.to_list b) -let mk_ref a = FStar_ST.alloc a - -let write_file (fn:string) s = - let fh = open_file_for_writing fn in - append_to_file fh s; - close_out_channel fh - -let copy_file input_name output_name = - (* see https://ocaml.github.io/ocamlunix/ocamlunix.html#sec33 *) - let open Unix in - let buffer_size = 8192 in - let buffer = Bytes.create buffer_size in - let fd_in = openfile input_name [O_RDONLY] 0 in - let fd_out = openfile output_name [O_WRONLY; O_CREAT; O_TRUNC] 0o666 in - let rec copy_loop () = - match read fd_in buffer 0 buffer_size with - | 0 -> () - | r -> ignore (write fd_out buffer 0 r); copy_loop () - in - copy_loop (); - close fd_in; - close fd_out -let delete_file (fn:string) = Sys.remove fn -let file_get_contents f = - let ic = open_in_bin f in - let l = in_channel_length ic in - let s = really_input_string ic l in - close_in ic; - s -let file_get_lines f = - let ic = open_in f in - let rec aux accu = - let l = - try - Some (input_line ic) - with - | End_of_file -> None - in - match l with - | None -> accu - | Some l -> aux (l::accu) - in - let l = aux [] in - close_in ic; - List.rev l -let concat_dir_filename d f = Filename.concat d f - -let slash_code : int = - BatUChar.code (BatUChar.of_char '/') - -let rec dropWhile f xs = - match xs with - | [] -> [] - | x::xs -> - if f x - then dropWhile f xs - else x::xs - -let path_parent (fn : string) : string = - let cs = FStar_String.split [slash_code] fn in - (* ^ Components of the path *) - let cs = cs |> List.rev |> dropWhile (fun s -> s = "") |> List.rev in - (* ^ Remove empty trailing components, so we interpret a/b/c/ as a/b/c *) - (* Remove last component to get parent and concat. *) - FStar_String.concat "/" (FStar_List.init cs) - -let rec __mkdir clean mkparents nm = - let remove_all_in_dir nm = - let open Sys in - Array.iter remove (Array.map (concat_dir_filename nm) (readdir nm)) in - let open Unix in - (match Sys.os_type with - | "Unix" -> ignore (umask 0o002) - | _ -> (* unimplemented*) ()); - try Unix.mkdir nm 0o777 - with - | Unix_error (EEXIST, _, _) -> - if clean then remove_all_in_dir nm - - (* failed due to nonexisting directory, mkparents is true, and nm has a slash: - attempt to recursively create parent and retry. *) - | Unix_error (ENOENT, _, _) when mkparents && FStar_String.index_of nm slash_code <> (Z.of_int (-1)) -> - __mkdir false true (path_parent nm); - Unix.mkdir nm 0o777 - -let mkdir = __mkdir - -let for_range lo hi f = - for i = Z.to_int lo to Z.to_int hi do - f (Z.of_int i) - done - - -let incr r = FStar_ST.(Z.(write r (read r + one))) -let decr r = FStar_ST.(Z.(write r (read r - one))) -let geq (i:int) (j:int) = i >= j - -let exec_name = Sys.executable_name -let get_exec_dir () = Filename.dirname (Sys.executable_name) -let get_cmd_args () = Array.to_list Sys.argv -let expand_environment_variable x = try Some (Sys.getenv x) with Not_found -> None - -let physical_equality (x:'a) (y:'a) = x == y -let check_sharing a b msg = if physical_equality a b then print1 "Sharing OK: %s\n" msg else print1 "Sharing broken in %s\n" msg - -type oWriter = { - write_byte: char -> unit; - write_bool: bool -> unit; - write_int: int -> unit; - write_int32: int32 -> unit; - write_int64: int64 -> unit; - write_char: char -> unit; - write_double: float -> unit; - write_bytearray: char array -> unit; - write_string: string -> unit; - - close: unit -> unit -} - -type oReader = { - read_byte: unit -> char; - read_bool: unit -> bool; - read_int: unit -> int; - read_int32: unit -> int32; - read_int64: unit -> int64; - read_char: unit -> char; - read_double: unit -> float; - read_bytearray: unit -> char array; - read_string: unit -> string; - - close: unit -> unit -} - -module MkoReader = struct - let read_byte r x = r.read_byte x - let read_bool r x = r.read_bool x - let read_int r x = r.read_int32 x - let read_int32 r x = r.read_int32 x - let read_int64 r x = r.read_int64 x - let read_char r x = r.read_char x - let read_double r x = r.read_double x - let read_bytearray r x = r.read_bytearray x - let read_string r x = r.read_string x - - let close r x = r.close x -end - -module MkoWriter = struct - let write_byte w x = w.write_byte x - let write_bool w x = w.write_bool x - let write_int w x = w.write_int32 x - let write_int32 w x = w.write_int32 x - let write_int64 w x = w.write_int64 x - let write_char w x = w.write_char x - let write_double w x = w.write_double x - let write_bytearray w x = w.write_bytearray x - let write_string w x = w.write_string x - - let close w x = w.close x -end - -(* - * TODO: these functions need to be filled in - *) -let get_owriter (filename:string) : oWriter = { - write_byte = (fun _ -> ()); - write_bool = (fun _ -> ()); - write_int = (fun _ -> ()); - write_int32 = (fun _ -> ()); - write_int64 = (fun _ -> ()); - write_char = (fun _ -> ()); - write_double = (fun _ -> ()); - write_bytearray = (fun _ -> ()); - write_string = (fun _ -> ()); - - close = (fun _ -> ()); -} - -let get_oreader (filename:string) : oReader = { - read_byte = (fun _ -> 'a'); - read_bool = (fun _ -> true); - read_int = (fun _ -> 0); - read_int32 = (fun _ -> failwith "NYI"); - read_int64 = (fun _ -> 0L); - read_char = (fun _ -> 'a'); - read_double = (fun _ -> 0.0); - read_bytearray = (fun _ -> [||]); - read_string = (fun _ -> ""); - - close = (fun _ -> ()); -} - -let getcwd = Sys.getcwd - -let readdir dir = "." :: ".." :: Array.to_list (Sys.readdir dir) - -let paths_to_same_file f g = - let open Unix in - let { st_dev = i; st_ino = j } = stat f in - let { st_dev = i'; st_ino = j' } = stat g in - (i,j) = (i',j') - -let file_exists = Sys.file_exists -(* Sys.is_directory raises Sys_error if the path does not exist *) -let is_directory f = Sys.file_exists f && Sys.is_directory f - - -let basename = Filename.basename -let dirname = Filename.dirname -let print_endline = print_endline - -let map_option f opt = BatOption.map f opt - -let save_value_to_file (fname:string) value = - (* BatFile.with_file_out uses Unix.openfile (which isn't available in - js_of_ocaml) instead of Pervasives.open_out, so we don't use it here. *) - let channel = open_out_bin fname in - BatPervasives.finally - (fun () -> close_out channel) - (fun channel -> output_value channel value) - channel - -let load_value_from_file (fname:string) = - (* BatFile.with_file_in uses Unix.openfile (which isn't available in - js_of_ocaml) instead of Pervasives.open_in, so we don't use it here. *) - try - let channel = open_in_bin fname in - BatPervasives.finally - (fun () -> close_in channel) - (fun channel -> Some (input_value channel)) - channel - with | _ -> None - -let save_2values_to_file (fname:string) value1 value2 = - try - let channel = open_out_bin fname in - BatPervasives.finally - (fun () -> close_out channel) - (fun channel -> - output_value channel value1; - output_value channel value2) - channel - with - | e -> delete_file fname; - raise e - -let load_2values_from_file (fname:string) = - try - let channel = open_in_bin fname in - BatPervasives.finally - (fun () -> close_in channel) - (fun channel -> - let v1 = input_value channel in - let v2 = input_value channel in - Some (v1, v2)) - channel - with | _ -> None - -let print_exn e = - Printexc.to_string e - -let digest_of_file = - let cache = smap_create (Z.of_int 101) in - fun (fname:string) -> - match smap_try_find cache fname with - | Some dig -> dig - | None -> - let dig = BatDigest.file fname in - smap_add cache fname dig; - dig - -let digest_of_string (s:string) = - BatDigest.to_hex (BatDigest.string s) - -(* Precondition: file exists *) -let touch_file (fname:string) : unit = - (* Sets access and modification times to current time *) - Unix.utimes fname 0.0 0.0 - -let ensure_decimal s = Z.to_string (Z.of_string s) - -let measure_execution_time tag f = - let t = Sys.time () in - let retv = f () in - print2 "Execution time of %s: %s ms\n" tag (string_of_float (1000.0 *. (Sys.time() -. t))); - retv - -let return_execution_time f = - let t1 = Sys.time () in - let retv = f () in - let t2 = Sys.time () in - (retv, 1000.0 *. (t2 -. t1)) - -(* Outside of this file the reference to FStar_Util.ref must use the following combinators *) -(* Export it at the end of the file so that we don't break other internal uses of ref *) -type 'a ref = 'a FStar_Monotonic_Heap.ref -let read = FStar_ST.read -let write = FStar_ST.write -let (!) = FStar_ST.read -let (:=) = FStar_ST.write - -let marshal (x:'a) : string = Marshal.to_string x [] -let unmarshal (x:string) : 'a = Marshal.from_string x 0 - -type signedness = | Unsigned | Signed -type width = | Int8 | Int16 | Int32 | Int64 - -let rec z_pow2 n = - if n = Z.zero then Z.one - else Z.mul (Z.of_string "2") (z_pow2 (Z.sub n Z.one)) - -let bounds signedness width = - let n = - match width with - | Int8 -> Z.of_string "8" - | Int16 -> Z.of_string "16" - | Int32 -> Z.of_string "32" - | Int64 -> Z.of_string "64" - in - let lower, upper = - match signedness with - | Unsigned -> - Z.zero, Z.sub (z_pow2 n) Z.one - | Signed -> - let upper = z_pow2 (Z.sub n Z.one) in - Z.neg upper, Z.sub upper Z.one - in - lower, upper - -let within_bounds repr signedness width = - let lower, upper = bounds signedness width in - let value = Z.of_string (ensure_decimal repr) in - Z.leq lower value && Z.leq value upper - -let print_array (f: 'a -> string) - (s: 'a array) - : string - = let ls = Array.fold_left (fun out a -> f a :: out) [] s in - format1 "[| %s |]" (String.concat "; " (List.rev ls)) - -let array_of_list (l:'a list) = FStar_ImmutableArray_Base.of_list l - -let array_length (l:'a FStar_ImmutableArray_Base.t) = FStar_ImmutableArray_Base.length l - -let array_index (l:'a FStar_ImmutableArray_Base.t) (i:Z.t) = FStar_ImmutableArray_Base.index l i diff --git a/ocaml/fstar-lib/FStar_Extraction_ML_PrintML.ml b/ocaml/fstar-lib/FStar_Extraction_ML_PrintML.ml deleted file mode 100644 index 5ca4c70e418..00000000000 --- a/ocaml/fstar-lib/FStar_Extraction_ML_PrintML.ml +++ /dev/null @@ -1,544 +0,0 @@ -open List -open Lexing -open Ppxlib_ast -open Astlib.Ast_500.Parsetree -open Location -open Pprintast -open Ast_helper -open Astlib.Ast_500.Asttypes -open Longident - -open FStar_Extraction_ML_Syntax - -(* Global state used for the name of the ML module being pprinted. - current_module is only set once in build_ast and read once in - path_to_ident. This is done in order to avoid clutter. *) -let current_module = ref "" - - -let flatmap f l = map f l |> List.flatten -let opt_to_list = function Some x -> [x] | None -> [] - - -let no_position : Lexing.position = - {pos_fname = ""; pos_lnum = 0; pos_bol = 0; pos_cnum = 0} - -let no_location : Location.t = - {loc_start = no_position; loc_end = no_position; loc_ghost = false} - -let no_attrs: attributes = [] - - -(* functions for generating names and paths *) -let mk_sym s: string Location.loc = {txt=s; loc=no_location} - -let mk_sym_lident s: Longident.t Location.loc = {txt=s; loc=no_location} - -let mk_lident name = Lident name |> mk_sym_lident - -let mk_typ_name s = - (* remove an apostrophe from beginning of type name *) - match (BatString.sub s 0 1) with - | "'" -> BatString.tail s 1 - | _ -> s - -let rec path_to_string ((l, sym): mlpath): string = - match l with - | [] -> sym - | (hd::tl) -> BatString.concat "_" [hd; path_to_string (tl, sym)] - -let split_path (l1: string list) (l2: string list): (string list * string list) option = - let rec split_aux l1 l2 = - match l2 with - | [] -> Some l1 - | hd2::tl2 when BatString.equal hd2 (hd l1) -> split_aux (tl l1) tl2 - | _ -> None - in - if (length l1 >= length l2) then - match split_aux l1 l2 with - | None -> None - | Some l1' -> Some (l1', l2) - else None - -let path_to_ident ((l, sym): mlpath): Longident.t Asttypes.loc = - let codegen_libs = FStar_Options.codegen_libs() in - match l with - | [] -> mk_lident sym - | hd::tl -> - let m_name = !current_module in - let suffix, prefix = - try BatList.find_map (split_path l) codegen_libs with - | Not_found -> l, [] - in - let path_abbrev = BatString.concat "_" suffix in - if (prefix = [] && BatString.equal m_name path_abbrev) then - (* remove circular references *) - mk_lident sym - else - match prefix with - | [] -> Ldot(Lident path_abbrev, sym) |> mk_sym_lident - | p_hd::p_tl -> - let q = fold_left (fun x y -> Ldot (x,y)) (Lident p_hd) p_tl in - (match path_abbrev with - | "" -> Ldot(q, sym) |> mk_sym_lident - | _ -> Ldot(Ldot(q, path_abbrev), sym) |> mk_sym_lident) - -let mk_top_mllb (e: mlexpr): mllb = - {mllb_name="_"; - mllb_tysc=None; - mllb_add_unit=false; - mllb_def=e; - mllb_meta=[]; - mllb_attrs=[]; - print_typ=false } - -(* Find the try_with in the default effect module. For instance this can be -FStar.All.try_with (for most users) or FStarC.Compiler.Effect.try_with (during -bootstrapping with "--MLish --MLish_effect FStarC.Compiler.Effect"). *) -let try_with_ident () = - let lid = FStar_Parser_Const.try_with_lid () in - let ns = FStar_Ident.ns_of_lid lid in - let id = FStar_Ident.ident_of_lid lid in - path_to_ident (List.map FStar_Ident.string_of_id ns, FStar_Ident.string_of_id id) - -(* For integer constants (not 0/1) in this range we will use Prims.of_int - * Outside this range we will use string parsing to allow arbitrary sized - * integers. - * Using int_zero/int_one removes int processing to create the Z.t - * Using of_int removes string processing to create the Z.t - *) -let max_of_int_const = Z.of_int 65535 -let min_of_int_const = Z.of_int (-65536) - -(* mapping functions from F* ML AST to Parsetree *) -let build_constant (c: mlconstant): Parsetree.constant = - let stdint_module (s:FStar_Const.signedness) (w:FStar_Const.width) : string = - let sign = match s with - | FStar_Const.Signed -> "Int" - | FStar_Const.Unsigned -> "Uint" in - let with_w ws = BatString.concat "" ["Stdint."; sign; ws] in - match w with - | FStar_Const.Int8 -> with_w "8" - | FStar_Const.Int16 -> with_w "16" - | FStar_Const.Int32 -> with_w "32" - | FStar_Const.Int64 -> with_w "64" - | FStar_Const.Sizet -> with_w "64" in - match c with - | MLC_Int (v, None) -> - let s = match Z.of_string v with - | x when x = Z.zero -> "Prims.int_zero" - | x when x = Z.one -> "Prims.int_one" - | x when (min_of_int_const < x) && (x < max_of_int_const) -> - BatString.concat v ["(Prims.of_int ("; "))"] - | x -> - BatString.concat v ["(Prims.parse_int \""; "\")"] in - Const.integer s - (* Special case for UInt8, as it's realized as OCaml built-in int type *) - | MLC_Int (v, Some (FStar_Const.Unsigned, FStar_Const.Int8)) -> - Const.integer v - | MLC_Int (v, Some (s, w)) -> - let s = match Z.of_string v with - | x when x = Z.zero -> - BatString.concat "" [stdint_module s w; ".zero"] - | x when x = Z.one -> - BatString.concat "" [stdint_module s w; ".one"] - | x when (min_of_int_const < x) && (x < max_of_int_const) -> - BatString.concat "" ["("; stdint_module s w; ".of_int ("; v; "))"] - | x -> - BatString.concat "" ["("; stdint_module s w; ".of_string \""; v; "\")"] in - Const.integer s - | MLC_Float v -> Const.float (string_of_float v) - | MLC_Char v -> Const.int v - | MLC_String v -> Const.string v - | MLC_Bytes _ -> failwith "Case not handled" (* do we need this? *) - | _ -> failwith "Case not handled" - -let build_constant_expr (c: mlconstant): expression = - match c with - | MLC_Unit -> Exp.construct (mk_lident "()") None - | MLC_Bool b -> - let id = if b then "true" else "false" in - Exp.construct (mk_lident id) None - | _ -> Exp.constant (build_constant c) - -let build_constant_pat (c: mlconstant): pattern_desc = - match c with - | MLC_Unit -> Ppat_construct (mk_lident "()", None) - | MLC_Bool b -> - let id = if b then "true" else "false" in - Ppat_construct (mk_lident id, None) - | _ -> Ppat_constant (build_constant c) - -let rec build_pattern (p: mlpattern): pattern = - match p with - | MLP_Wild -> Pat.any () - | MLP_Const c -> build_constant_pat c |> Pat.mk - | MLP_Var sym -> Pat.var (mk_sym sym) - | MLP_CTor args -> build_constructor_pat args |> Pat.mk - | MLP_Branch l -> - (match l with - | [pat] -> build_pattern pat - | (pat1::tl) -> Pat.or_ (build_pattern pat1) (build_pattern (MLP_Branch tl)) - | [] -> failwith "Empty branch shouldn't happen") - | MLP_Record (path, l) -> - let fs = map (fun (x,y) -> (path_to_ident (path, x), build_pattern y)) l in - Pat.record fs Open (* does the closed flag matter? *) - | MLP_Tuple l -> Pat.tuple (map build_pattern l) - -and build_constructor_pat ((path, sym), p) = - let (path', name) = - (* resugaring the Cons and Nil from Prims *) - (match path with - | ["Prims"] -> - (match sym with - | "Cons" -> ([], "::") - | "Nil" -> ([], "[]") - | x -> (path, x)) - | _ -> (path, sym)) in - match p with - | [] -> - Ppat_construct (path_to_ident (path', name), None) - | [pat] -> - Ppat_construct (path_to_ident (path', name), Some ([], build_pattern pat)) - | pats -> - let inner = Pat.tuple (map build_pattern pats) in - Ppat_construct (path_to_ident(path', name), Some ([], inner)) - -let rec build_core_type ?(annots = []) (ty: mlty): core_type = - let t = - match ty with - | MLTY_Var sym -> Typ.mk (Ptyp_var (mk_typ_name sym)) - | MLTY_Fun (ty1, tag, ty2) -> - let c_ty1 = build_core_type ty1 in - let c_ty2 = build_core_type ty2 in - let label = Nolabel in - Typ.mk (Ptyp_arrow (label,c_ty1,c_ty2)) - | MLTY_Named (tys, (path, sym)) -> - let c_tys = map build_core_type tys in - let p = path_to_ident (path, sym) in - let ty = Typ.mk (Ptyp_constr (p, c_tys)) in - (match path with - | ["FStar"; "Pervasives"; "Native"] -> - (* A special case for tuples, so they are displayed as - * ('a * 'b) instead of ('a,'b) FStar_Pervasives_Native.tuple2 - * VD: Should other types named "tupleXX" where XX does not represent - * the arity of the tuple be added to FStar.Pervasives.Native, - * the condition below might need to be more specific. *) - if BatString.starts_with sym "tuple" then - Typ.mk (Ptyp_tuple (map build_core_type tys)) - else - ty - | _ -> ty) - | MLTY_Tuple tys -> Typ.mk (Ptyp_tuple (map build_core_type tys)) - | MLTY_Top -> Typ.mk (Ptyp_constr (mk_lident "Obj.t", [])) - | MLTY_Erased -> Typ.mk (Ptyp_constr (mk_lident "unit", [])) - in - if annots = [] - then t - else Typ.mk (Ptyp_poly (annots, t)) - -let build_binding_pattern ?ty (sym : mlident) : pattern = - let p = Pat.mk (Ppat_var (mk_sym sym)) in - match ty with - | None -> p - | Some ty -> Pat.mk (Ppat_constraint (p, ty)) - -let resugar_prims_ops path: expression = - (match path with - | (["Prims"], "op_Addition") -> mk_lident "+" - | (["Prims"], "op_Subtraction") -> mk_lident "-" - | (["Prims"], "op_Multiply") -> mk_lident "*" - | (["Prims"], "op_Division") -> mk_lident "/" - | (["Prims"], "op_Equality") -> mk_lident "=" - | (["Prims"], "op_Colon_Equals") -> mk_lident ":=" - | (["Prims"], "op_disEquality") -> mk_lident "<>" - | (["Prims"], "op_AmpAmp") -> mk_lident "&&" - | (["Prims"], "op_BarBar") -> mk_lident "||" - | (["Prims"], "op_LessThanOrEqual") -> mk_lident "<=" - | (["Prims"], "op_GreaterThanOrEqual") -> mk_lident ">=" - | (["Prims"], "op_LessThan") -> mk_lident "<" - | (["Prims"], "op_GreaterThan") -> mk_lident ">" - | (["Prims"], "op_Modulus") -> mk_lident "mod" - | (["Prims"], "op_Minus") -> mk_lident "~-" - | path -> path_to_ident path) - |> Exp.ident - -let resugar_if_stmts ep cases = - if List.length cases = 2 then - let case1 = List.hd cases in - let case2 = BatList.last cases in - (match case1.pc_lhs.ppat_desc with - | Ppat_construct({txt=Lident "true"}, None) -> - Exp.ifthenelse ep case1.pc_rhs (Some case2.pc_rhs) - | _ -> Exp.match_ ep cases) - else - Exp.match_ ep cases - -let rec build_expr (e: mlexpr): expression = - match e.expr with - | MLE_Const c -> build_constant_expr c - | MLE_Var sym -> Exp.ident (mk_lident sym) - | MLE_Name path -> - (match path with - | (["Prims"], op) -> resugar_prims_ops path - | _ -> Exp.ident (path_to_ident path)) - | MLE_Let ((flavour, lbs), expr) -> - let recf = match flavour with - | Rec -> Recursive - | NonRec -> Nonrecursive in - let val_bindings = map (build_binding false) lbs in - Exp.let_ recf val_bindings (build_expr expr) - | MLE_App (e, es) -> - let args = map (fun x -> (Nolabel, build_expr x)) es in - let f = build_expr e in - resugar_app f args es - | MLE_TApp (e, ts) -> - build_expr e - | MLE_Fun (l, e) -> build_fun l e - | MLE_Match (e, branches) -> - let ep = build_expr e in - let cases = map build_case branches in - resugar_if_stmts ep cases - | MLE_Coerce (e, _, _) -> - let r = Exp.ident (mk_lident "Obj.magic") in - Exp.apply r [(Nolabel, build_expr e)] - | MLE_CTor args -> build_constructor_expr args - | MLE_Seq args -> build_seq args - | MLE_Tuple l -> Exp.tuple (map build_expr l) - | MLE_Record (path, _, l) -> - let fields = map (fun (x,y) -> (path_to_ident(path, x), build_expr y)) l in - Exp.record fields None - | MLE_Proj (e, path) -> - Exp.field (build_expr e) (path_to_ident (path)) - (* MLE_If always desugared to match? *) - | MLE_If (e, e1, e2) -> - Exp.ifthenelse (build_expr e) (build_expr e1) (BatOption.map build_expr e2) - | MLE_Raise (path, es) -> - let r = Exp.ident (mk_lident "raise") in - let args = map (fun x -> (Nolabel, build_expr x)) es in - Exp.apply r args - | MLE_Try (e, cs) -> - Exp.try_ (build_expr e) (map build_case cs) - -and resugar_app f args es: expression = - match f.pexp_desc with - | Pexp_ident x when x = try_with_ident () -> - (* resugar try_with to a try...with - try_with : (unit -> ML 'a) -> (exn -> ML 'a) -> ML 'a *) - assert (length es == 2); - let s, cs = BatList.first es, BatList.last es in - (* We have FStar.All.try_with s cs, with s : unit -> ML 'a - * and cs : exn -> ML 'a - * - * We need to create an OCaml try..with, with a body and a - * set of cases for catching the exception. - * - * For the body, we simply translate `s ()` and we're done. - * - * For the cases, we can't a similar trick, so we try to reverse-engineer - * the shape of the term in order to obtain a proper set. See get_variants. *) - - let body = Exp.apply (build_expr s) [(Nolabel, build_expr ml_unit)] in - let variants = get_variants cs in - Exp.try_ body variants - - | _ -> Exp.apply f args - -and get_variants (e : mlexpr) : Parsetree.case list = - match e.expr with - | MLE_Fun ([{mlbinder_name=id}], e) -> - (match e.expr with - | MLE_Match ({expr = MLE_Var id'}, branches) when id = id' -> - map build_case branches - | _ -> - [build_case (MLP_Var id, None, e)] - ) - | _ -> failwith "Cannot resugar FStar.All.try_with (3)" - -and build_seq args = - match args with - | [hd] -> build_expr hd - | hd::tl -> Exp.sequence (build_expr hd) (build_seq tl) - | [] -> failwith "Empty sequence should never happen" - -and build_constructor_expr ((path, sym), exp): expression = - let path', name = - (match path, sym with - | ["Prims"], "Cons" -> ([], "::") - | ["Prims"], "Nil" -> ([], "[]") - | path, x -> (path, x)) in - match exp with - | [] -> Exp.construct (path_to_ident(path', name)) None - | [e] -> - Exp.construct (path_to_ident(path', name)) (Some (build_expr e)) - | es -> - let inner = Exp.tuple (map build_expr es) in - Exp.construct (path_to_ident(path', name)) (Some inner) - -and build_fun l e = - match l with - | ({mlbinder_name=id; mlbinder_ty=ty}::tl) -> - let p = build_binding_pattern id in - Exp.fun_ Nolabel None p (build_fun tl e) - | [] -> build_expr e - -and build_case ((lhs, guard, rhs): mlbranch): case = - {pc_lhs = (build_pattern lhs); - pc_guard = BatOption.map build_expr guard; - pc_rhs = (build_expr rhs)} - -and build_binding (toplevel: bool) (lb: mllb): value_binding = - (* Add a constraint on the binding (ie. an annotation) for top-level lets *) - let mk1 s = mkloc (String.sub s 1 (String.length s - 1)) none in - let ty = - match lb.mllb_tysc with - | None -> None - | Some ts -> - if lb.print_typ && toplevel - then let vars = List.map mk1 (ty_param_names (fst ts)) in - let ty = snd ts in - Some (build_core_type ~annots:vars ty) - else None - in - let e = build_expr lb.mllb_def in - let p = build_binding_pattern ?ty:ty lb.mllb_name in - (Vb.mk p e) - -let build_label_decl (sym, ty): label_declaration = - Type.field (mk_sym sym) (build_core_type ty) - -let build_constructor_decl (sym, tys): constructor_declaration = - let tys = List.map snd tys in - let args = if BatList.is_empty tys then None else - Some (Pcstr_tuple (map build_core_type tys)) in - Type.constructor ?args:args (mk_sym sym) - -let build_ty_kind (b: mltybody): type_kind = - match b with - | MLTD_Abbrev ty -> Ptype_abstract - | MLTD_Record l -> Ptype_record (map build_label_decl l) - | MLTD_DType l -> Ptype_variant (map build_constructor_decl l) - -let build_ty_manifest (b: mltybody): core_type option= - match b with - | MLTD_Abbrev ty -> Some (build_core_type ty) - | MLTD_Record l -> None - | MLTD_DType l -> None - - -let skip_type_defn (current_module:string) (type_name:string) :bool = - current_module = "FStar_Pervasives" && type_name = "option" - -let type_metadata (md : metadata): attributes option = - let deriving = BatList.filter_map (function - | PpxDerivingShow | PpxDerivingShowConstant _ -> Some "show" - | PpxDerivingYoJson -> Some "yojson" - | _ -> None - ) md in - if List.length deriving > 0 then - let str = String.concat "," deriving in - Some [ { - attr_name = mk_sym "deriving"; - attr_payload = PStr [Str.eval (Exp.ident (mk_lident str))]; - attr_loc = no_location } - ] - else - None - -let add_deriving_const (md: metadata) (ptype_manifest: core_type option): core_type option = - match List.filter (function PpxDerivingShowConstant _ -> true | _ -> false) md with - | [PpxDerivingShowConstant s] -> - let e = Exp.apply (Exp.ident (path_to_ident (["Format"], "pp_print_string"))) [(Nolabel, Exp.ident (mk_lident "fmt")); (Nolabel, Exp.constant (Const.string s))] in - let deriving_const = { - attr_name = mk_sym "printer"; - attr_payload = PStr [Str.eval (Exp.fun_ Nolabel None (build_binding_pattern "fmt") (Exp.fun_ Nolabel None (Pat.any ()) e))]; - attr_loc = no_location } in - BatOption.map (fun x -> {x with ptyp_attributes=[deriving_const]}) ptype_manifest - | _ -> ptype_manifest - -let build_one_tydecl ({tydecl_name=x; - tydecl_ignored=mangle_opt; - tydecl_parameters=tparams; - tydecl_meta=attrs; - tydecl_defn=body}: one_mltydecl): type_declaration = - let ptype_name = match mangle_opt with - | Some y -> mk_sym y - | None -> mk_sym x in - let ptype_params = Some (map (fun sym -> Typ.mk (Ptyp_var (mk_typ_name sym)), (NoVariance, NoInjectivity)) (ty_param_names tparams)) in - let (ptype_manifest: core_type option) = - BatOption.map_default build_ty_manifest None body |> add_deriving_const attrs in - let ptype_kind = Some (BatOption.map_default build_ty_kind Ptype_abstract body) in - let ptype_attrs = type_metadata attrs in - Type.mk ?params:ptype_params ?kind:ptype_kind ?manifest:ptype_manifest ?attrs:ptype_attrs ptype_name - -let build_tydecl (td: mltydecl): structure_item_desc option = - let recf = Recursive in - let type_declarations = map build_one_tydecl td in - if type_declarations = [] then None else Some (Pstr_type (recf, type_declarations)) - -let build_exn (sym, tys): type_exception = - let tys = List.map snd tys in - let name = mk_sym sym in - let args = Some (Pcstr_tuple (map build_core_type tys)) in - let ctor = Te.decl ?args:args name in - Te.mk_exception ctor - -let build_module1 path (m1: mlmodule1): structure_item option = - match m1.mlmodule1_m with - | MLM_Ty tydecl -> - (match build_tydecl tydecl with - | Some t -> Some (Str.mk t) - | None -> None) - | MLM_Let (flav, mllbs) -> - let recf = match flav with | Rec -> Recursive | NonRec -> Nonrecursive in - let bindings = map (build_binding true) mllbs in - Some (Str.value recf bindings) - | MLM_Exn exn -> Some (Str.exception_ (build_exn exn)) - | MLM_Top expr -> - let lb = mk_top_mllb expr in - let binding = build_binding true lb in - Some (Str.value Nonrecursive [binding]) - | MLM_Loc (p, f) -> None - -let build_m path (md: (mlsig * mlmodule) option) : structure = - match md with - | Some(s, m) -> - let open_prims = - Str.open_ (Opn.mk ?override:(Some Fresh) (Mod.ident (mk_lident "Prims"))) in - open_prims::(map (build_module1 path) m |> flatmap opt_to_list) - | None -> [] - -let build_ast (out_dir: string option) (ext: string) (ml: mllib) = - match ml with - | MLLib l -> - map (fun (p, md, _) -> - let m = path_to_string p in - current_module := m; - let name = BatString.concat "" [m; ext] in - let path = (match out_dir with - | Some out -> BatString.concat "/" [out; name] - | None -> name) in - (path, build_m path md)) l - - -(* printing the AST to the correct path *) -let print_module ((path, m): string * structure) = - Format.set_formatter_out_channel (open_out_bin path); - structure Format.std_formatter m; - Format.pp_print_flush Format.std_formatter () - -let print (out_dir: string option) (ext: string) (ml: mllib) = - match ext with - | ".ml" -> - (* Use this printer for OCaml extraction *) - let ast = build_ast out_dir ext ml in - iter print_module ast - | ".fs" -> - (* Use the old printer for F# extraction *) - let new_doc = FStar_Extraction_ML_Code.doc_of_mllib ml in - iter (fun (n, d) -> - FStar_Compiler_Util.write_file - (FStar_Options.prepend_output_dir (BatString.concat "" [n;ext])) - (FStar_Extraction_ML_Code.pretty (Prims.parse_int "120") d) - ) new_doc - | _ -> failwith "Unrecognized extension" diff --git a/ocaml/fstar-lib/FStar_Hash.ml b/ocaml/fstar-lib/FStar_Hash.ml deleted file mode 100644 index dc2652b5339..00000000000 --- a/ocaml/fstar-lib/FStar_Hash.ml +++ /dev/null @@ -1,74 +0,0 @@ -module BU = FStar_Compiler_Util -module Z = FStar_BigInt - -type hash_code = int - -let cmp_hash (x:hash_code) (y:hash_code) : Z.t = Z.of_int (x-y) - -let of_int (i:Z.t) = Z.to_int i -let of_string (s:string) = BatHashtbl.hash s - -(* This function is taken from Bob Jenkins' - http://burtleburtle.net/bob/hash/doobs.html - - It's defined there as a mix on 32 bit integers. - - I'm abusing it here by using it on OCaml's 63 bit - integers. - - But it seems to work well, at least in comparison - to some simpler mixes that I tried. E.g., using - this mix taken from Lean (src/runtime/hash.h) - -uint64 hash(uint64 h1, uint64 h2) { - h2 -= h1; h2 ^= (h1 << 16); - h1 -= h2; h2 ^= (h1 << 32); - h2 -= h1; h2 ^= (h1 << 20); - return h2; -} - - But, it produces many collisions, see, e.g., in - tests/FStar.Tests.Pars.test_hashes -*) -let mix (a: hash_code) (b:hash_code) = - let c = 11 in - (* a -= b; a -= c; a ^= (c >> 13); *) - let a = a - b in - let a = a - c in - (* skip this step since c lsr 13 = 0 *) - (* let a = a lxor (c lsr 13) in *) - (* b -= c; b -= a; b ^= (a << 8); *) - let b = b - c in - let b = b - a in - let b = b lxor (a lsl 8) in - (* c -= a; c -= b; c ^= (b >> 13); *) - let c = c - a in - let c = c - b in - let c = c lxor (b lsr 13) in - (* a -= b; a -= c; a ^= (c >> 12); *) - let a = a - b in - let a = a - c in - let a = a lxor (c lsr 12) in - (* b -= c; b -= a; b ^= (a << 16); *) - let b = b - c in - let b = b - a in - let b = b lxor (a lsl 16) in - (* c -= a; c -= b; c ^= (b >> 5); *) - let c = c - a in - let c = c - b in - let c = c lxor (b lsr 5) in - (* a -= b; a -= c; a ^= (c >> 3); *) - let a = a - b in - let a = a - c in - let a = a lxor (c lsr 3) in - (* b -= c; b -= a; b ^= (a << 10); *) - let b = b - c in - let b = b - a in - let b = b lxor (a lsl 10) in - (* c -= a; c -= b; c ^= (b >> 15); *) - let c = c - a in - let c = c - b in - let c = c lxor (b lsr 15) in - c - -let string_of_hash_code h = string_of_int h diff --git a/ocaml/fstar-lib/FStar_Issue.ml b/ocaml/fstar-lib/FStar_Issue.ml index bbc187cbf66..09fb6a51837 100644 --- a/ocaml/fstar-lib/FStar_Issue.ml +++ b/ocaml/fstar-lib/FStar_Issue.ml @@ -1,8 +1,8 @@ -type issue_level = FStar_Errors.issue_level -type issue = FStar_Errors.issue +type issue_level = FStarC_Errors.issue_level +type issue = FStarC_Errors.issue type issue_level_string = string -open FStar_Errors +open FStarC_Errors let string_of_level (i:issue_level) = match i with @@ -28,11 +28,11 @@ let mk_issue_level (i:issue_level_string) | "Info" -> EInfo | "Warning" -> EWarning -let render_issue (i:issue) : string = FStar_Errors.format_issue i +let render_issue (i:issue) : string = FStarC_Errors.format_issue i let mk_issue_doc (i:issue_level_string) - (msg:FStar_Pprint.document list) - (range:FStar_Compiler_Range.range option) + (msg:FStarC_Pprint.document list) + (range:FStarC_Compiler_Range.range option) (number:Z.t option) (ctx:string list) = { issue_level = mk_issue_level i; @@ -44,11 +44,11 @@ let mk_issue_doc (i:issue_level_string) (* repeated... could be extracted *) let mk_issue (i:issue_level_string) (msg:string) - (range:FStar_Compiler_Range.range option) + (range:FStarC_Compiler_Range.range option) (number:Z.t option) (ctx:string list) = { issue_level = mk_issue_level i; - issue_msg = [FStar_Pprint.arbitrary_string msg]; + issue_msg = [FStarC_Pprint.arbitrary_string msg]; issue_range = range; issue_number = number; issue_ctx = ctx } diff --git a/ocaml/fstar-lib/FStar_Parser_LexFStar.ml b/ocaml/fstar-lib/FStar_Parser_LexFStar.ml deleted file mode 100644 index 1cd316bae94..00000000000 --- a/ocaml/fstar-lib/FStar_Parser_LexFStar.ml +++ /dev/null @@ -1,717 +0,0 @@ -open FStar_Parser_Parse -open FStar_Parser_Util - -module Option = BatOption -module String = BatString -module Hashtbl = BatHashtbl -module Sedlexing = FStar_Sedlexing -module L = Sedlexing -module E = FStar_Errors -module Codes = FStar_Errors_Codes - -let ba_of_string s = Array.init (String.length s) (fun i -> Char.code (String.get s i)) -let array_trim_both a n m = Array.sub a n (Array.length a - n - m) -let string_trim_both s n m = BatString.sub s n (String.length s - (n+m)) -let trim_both lexbuf n m = string_trim_both (L.lexeme lexbuf) n m -let utrim_both lexbuf n m = array_trim_both (L.ulexeme lexbuf) n m -let trim_right lexbuf n = trim_both lexbuf 0 n -let trim_left lexbuf n = trim_both lexbuf n 0 - -let unescape (a:int array) : int = - match a.(0) with - | 92 (* \ *) -> - (match a.(1) with - | 48 (*0*) -> 0 - | 98 (*b*) -> 8 - | 116 (*t*) -> 9 - | 110 (*n*) -> 10 - | 118 (*v*) -> 11 - | 102 (*f*) -> 12 - | 114 (*r*) -> 13 - | 117 (*u*) -> - let s = FStar_Parser_Utf8.from_int_array a 2 4 in - int_of_string ("0x"^s) - | 120 (*x*) -> - let s = FStar_Parser_Utf8.from_int_array a 2 2 in - int_of_string ("0x"^s) - | c -> c) - | c -> c - -let keywords = Hashtbl.create 0 -let constructors = Hashtbl.create 0 -let operators = Hashtbl.create 0 - -let () = - Hashtbl.add keywords "attributes" ATTRIBUTES ; - Hashtbl.add keywords "noeq" NOEQUALITY ; - Hashtbl.add keywords "unopteq" UNOPTEQUALITY ; - Hashtbl.add keywords "and" AND ; - Hashtbl.add keywords "assert" ASSERT ; - Hashtbl.add keywords "assume" ASSUME ; - Hashtbl.add keywords "begin" BEGIN ; - Hashtbl.add keywords "by" BY ; - Hashtbl.add keywords "calc" CALC ; - Hashtbl.add keywords "class" CLASS ; - Hashtbl.add keywords "default" DEFAULT ; - Hashtbl.add keywords "decreases" DECREASES ; - Hashtbl.add keywords "effect" EFFECT ; - Hashtbl.add keywords "eliminate" ELIM; - Hashtbl.add keywords "else" ELSE ; - Hashtbl.add keywords "end" END ; - Hashtbl.add keywords "ensures" ENSURES ; - Hashtbl.add keywords "exception" EXCEPTION ; - Hashtbl.add keywords "exists" (EXISTS false); - Hashtbl.add keywords "false" FALSE ; - Hashtbl.add keywords "friend" FRIEND ; - Hashtbl.add keywords "forall" (FORALL false); - Hashtbl.add keywords "fun" FUN ; - Hashtbl.add keywords "λ" FUN ; - Hashtbl.add keywords "function" FUNCTION ; - Hashtbl.add keywords "if" IF ; - Hashtbl.add keywords "in" IN ; - Hashtbl.add keywords "include" INCLUDE ; - Hashtbl.add keywords "inline" INLINE ; - Hashtbl.add keywords "inline_for_extraction" INLINE_FOR_EXTRACTION ; - Hashtbl.add keywords "instance" INSTANCE ; - Hashtbl.add keywords "introduce" INTRO ; - Hashtbl.add keywords "irreducible" IRREDUCIBLE ; - Hashtbl.add keywords "let" (LET false) ; - Hashtbl.add keywords "logic" LOGIC ; - Hashtbl.add keywords "match" MATCH ; - Hashtbl.add keywords "returns" RETURNS ; - Hashtbl.add keywords "as" AS ; - Hashtbl.add keywords "module" MODULE ; - Hashtbl.add keywords "new" NEW ; - Hashtbl.add keywords "new_effect" NEW_EFFECT ; - Hashtbl.add keywords "layered_effect" LAYERED_EFFECT ; - Hashtbl.add keywords "polymonadic_bind" POLYMONADIC_BIND ; - Hashtbl.add keywords "polymonadic_subcomp" POLYMONADIC_SUBCOMP ; - Hashtbl.add keywords "noextract" NOEXTRACT ; - Hashtbl.add keywords "of" OF ; - Hashtbl.add keywords "open" OPEN ; - Hashtbl.add keywords "opaque" OPAQUE ; - Hashtbl.add keywords "private" PRIVATE ; - Hashtbl.add keywords "quote" QUOTE ; - Hashtbl.add keywords "range_of" RANGE_OF ; - Hashtbl.add keywords "rec" REC ; - Hashtbl.add keywords "reifiable" REIFIABLE ; - Hashtbl.add keywords "reify" REIFY ; - Hashtbl.add keywords "reflectable" REFLECTABLE ; - Hashtbl.add keywords "requires" REQUIRES ; - Hashtbl.add keywords "set_range_of" SET_RANGE_OF; - Hashtbl.add keywords "sub_effect" SUB_EFFECT ; - Hashtbl.add keywords "synth" SYNTH ; - Hashtbl.add keywords "then" THEN ; - Hashtbl.add keywords "total" TOTAL ; - Hashtbl.add keywords "true" TRUE ; - Hashtbl.add keywords "try" TRY ; - Hashtbl.add keywords "type" TYPE ; - Hashtbl.add keywords "unfold" UNFOLD ; - Hashtbl.add keywords "unfoldable" UNFOLDABLE ; - Hashtbl.add keywords "val" VAL ; - Hashtbl.add keywords "when" WHEN ; - Hashtbl.add keywords "with" WITH ; - Hashtbl.add keywords "_" UNDERSCORE ; - Hashtbl.add keywords "α" (TVAR "a") ; - Hashtbl.add keywords "β" (TVAR "b") ; - Hashtbl.add keywords "γ" (TVAR "c") ; - Hashtbl.add keywords "δ" (TVAR "d") ; - Hashtbl.add keywords "ε" (TVAR "e") ; - Hashtbl.add keywords "φ" (TVAR "f") ; - Hashtbl.add keywords "χ" (TVAR "g") ; - Hashtbl.add keywords "η" (TVAR "h") ; - Hashtbl.add keywords "ι" (TVAR "i") ; - Hashtbl.add keywords "κ" (TVAR "k") ; - Hashtbl.add keywords "μ" (TVAR "m") ; - Hashtbl.add keywords "ν" (TVAR "n") ; - Hashtbl.add keywords "π" (TVAR "p") ; - Hashtbl.add keywords "θ" (TVAR "q") ; - Hashtbl.add keywords "ρ" (TVAR "r") ; - Hashtbl.add keywords "σ" (TVAR "s") ; - Hashtbl.add keywords "τ" (TVAR "t") ; - Hashtbl.add keywords "ψ" (TVAR "u") ; - Hashtbl.add keywords "ω" (TVAR "w") ; - Hashtbl.add keywords "ξ" (TVAR "x") ; - Hashtbl.add keywords "ζ" (TVAR "z") ; - Hashtbl.add constructors "ℕ" (IDENT "nat"); - Hashtbl.add constructors "ℤ" (IDENT "int"); - Hashtbl.add constructors "𝔹" (IDENT "bool"); - let l = - ["~", TILDE "~"; - "-", MINUS; - "/\\", CONJUNCTION; - "\\/", DISJUNCTION; - "<:", SUBTYPE; - "$:", EQUALTYPE; - "<@", SUBKIND; - "(|", LENS_PAREN_LEFT; - "|)", LENS_PAREN_RIGHT; - "#", HASH; - "u#", UNIV_HASH; - "&", AMP; - "()", LPAREN_RPAREN; - "(", LPAREN; - ")", RPAREN; - ",", COMMA; - "~>", SQUIGGLY_RARROW; - "->", RARROW; - "<--", LONG_LEFT_ARROW; - "<-", LARROW; - "<==>", IFF; - "==>", IMPLIES; - ".", DOT; - "?.", QMARK_DOT; - "?", QMARK; - ".[", DOT_LBRACK; - ".(|", DOT_LENS_PAREN_LEFT; - ".(", DOT_LPAREN; - ".[|", DOT_LBRACK_BAR; - "{:pattern", LBRACE_COLON_PATTERN; - "{:well-founded", LBRACE_COLON_WELL_FOUNDED; - "returns$", RETURNS_EQ; - ":", COLON; - "::", COLON_COLON; - ":=", COLON_EQUALS; - ";", SEMICOLON; - "=", EQUALS; - "%[", PERCENT_LBRACK; - "!{", BANG_LBRACE; - "[@@@", LBRACK_AT_AT_AT; - "[@@", LBRACK_AT_AT; - "[@", LBRACK_AT; - "[", LBRACK; - "[|", LBRACK_BAR; - "{|", LBRACE_BAR; - "|>", PIPE_RIGHT; - "]", RBRACK; - "|]", BAR_RBRACK; - "|}", BAR_RBRACE; - "{", LBRACE; - "|", BAR; - "}", RBRACE; - "$", DOLLAR; - (* New Unicode equivalents *) - "∀", (FORALL false); - "∃", (EXISTS false); - "⊤", NAME "True"; - "⊥", NAME "False"; - "⟹", IMPLIES; - "⟺", IFF; - "→", RARROW; - "←", LARROW; - "⟵", LONG_LEFT_ARROW; - "↝", SQUIGGLY_RARROW; - "≔", COLON_EQUALS; - "∧", CONJUNCTION; - "∨", DISJUNCTION; - "¬", TILDE "~"; - "⸬", COLON_COLON; - "▹", PIPE_RIGHT; - "÷", OPINFIX3 "÷"; - "‖", OPINFIX0a "||"; - "×", IDENT "op_Multiply"; - "∗", OPINFIX3 "*"; - "⇒", OPINFIX0c "=>"; - "≥", OPINFIX0c ">="; - "≤", OPINFIX0c "<="; - "≠", OPINFIX0c "<>"; - "≪", OPINFIX0c "<<"; - "◃", OPINFIX0c "<|"; - "±", OPPREFIX "±"; - "∁", OPPREFIX "∁"; - "∂", OPPREFIX "∂"; - "√", OPPREFIX "√"; - ] in - List.iter (fun (k,v) -> Hashtbl.add operators k v) l - -let current_range lexbuf = - FStar_Parser_Util.mksyn_range (fst (L.range lexbuf)) (snd (L.range lexbuf)) - -let fail lexbuf (e, msg) = - let m = current_range lexbuf in - E.raise_error_text m e msg - -type delimiters = { angle:int ref; paren:int ref; } -let n_typ_apps = ref 0 - -let is_typ_app_gt () = - if !n_typ_apps > 0 - then (decr n_typ_apps; true) - else false - -let rec mknewline n lexbuf = - if n = 0 then () - else (L.new_line lexbuf; mknewline (n-1) lexbuf) - -let clean_number x = String.strip ~chars:"uzyslLUnIN" x - -(* Try to trim each line of [comment] by the ammount of space - on the first line of the comment if possible *) -(* TODO : apply this to FSDOC too *) -let maybe_trim_lines start_column comment = - if start_column = 0 then comment - else - let comment_lines = String.split_on_char '\n' comment in - let ensures_empty_prefix k s = - let j = min k (String.length s - 1) in - let rec aux i = if i > j then k else if s.[i] <> ' ' then i else aux (i+1) in - aux 0 in - let trim_width = List.fold_left ensures_empty_prefix start_column comment_lines in - String.concat "\n" (List.map (fun s -> String.tail s trim_width) comment_lines) - -let comment_buffer = Buffer.create 128 -let blob_buffer = Buffer.create 128 -let use_lang_buffer = Buffer.create 128 - -let start_comment lexbuf = - Buffer.add_string comment_buffer "(*" ; - (false, comment_buffer, fst (L.range lexbuf)) - -let terminate_comment buffer startpos lexbuf = - let endpos = snd (L.range lexbuf) in - Buffer.add_string buffer "*)" ; - let comment = Buffer.contents buffer in - let comment = maybe_trim_lines (startpos.Lexing.pos_cnum - startpos.Lexing.pos_bol) comment in - Buffer.clear buffer; - add_comment (comment, FStar_Parser_Util.mksyn_range startpos endpos) - -let push_one_line_comment pre lexbuf = - let startpos, endpos = L.range lexbuf in - assert (startpos.Lexing.pos_lnum = endpos.Lexing.pos_lnum); - add_comment (pre ^ L.lexeme lexbuf, FStar_Parser_Util.mksyn_range startpos endpos) - -(** Unicode class definitions - Auto-generated from http:/ /www.unicode.org/Public/8.0.0/ucd/UnicodeData.txt **) -(** Ll **) -let u_lower = [%sedlex.regexp? ll] -(** Lu *) -let u_upper = [%sedlex.regexp? lu] -(** Lo *) -let u_other = [%sedlex.regexp? lo] -(** Lm *) -let u_modifier = [%sedlex.regexp? lm] -(** Lt *) -let u_title = [%sedlex.regexp? lt] -(** Zs *) -let u_space = [%sedlex.regexp? zs] -(** These are not unicode spaces but we accept as whitespace in F* source (e.g. tab and BOM) *) -let u_space_extra = [%sedlex.regexp? '\t' | '\x0B' | '\x0C' | '\xA0' | 0xfeff] -(** Zl and Zp *) -let u_line_sep = [%sedlex.regexp? zl] -let u_par_sep = [%sedlex.regexp? zp] -(** Sm math symbols *) -let u_math = [%sedlex.regexp? sm] -let u_math_ascii = [%sedlex.regexp? 0x002b | 0x003c .. 0x003e | 0x007c | 0x007e] -let u_math_nonascii = [%sedlex.regexp? Sub(u_math, u_math_ascii)] -(** Sc currency *) -let u_currency = [%sedlex.regexp? sc] -(** Sk *) -let u_modifier_symbol = [%sedlex.regexp? sk] -(** So *) -let u_other_symbol = [%sedlex.regexp? so] -(** Nd *) -let u_decimal_digit = [%sedlex.regexp? nd] -(** Nl *) -let u_digit_letter = [%sedlex.regexp? nl] -(** No *) -let u_other_digit = [%sedlex.regexp? no] -(** Pd *) -let u_punct_hyphen = [%sedlex.regexp? pd] -(** Ps *) -let u_punct_obra = [%sedlex.regexp? ps] -(** Pe *) -let u_punct_cbra = [%sedlex.regexp? pe] -(** Pi *) -let u_punct_oquot = [%sedlex.regexp? pi] -(** Pf *) -let u_punct_cquot = [%sedlex.regexp? pf] -(** Pc *) -let u_punct_connect = [%sedlex.regexp? pc] -(** Po *) -let u_punct_other = [%sedlex.regexp? po] -(** Mn *) -let u_mod_nospace = [%sedlex.regexp? mn] -(** Mc *) -let u_mod = [%sedlex.regexp? mc] -(** Me *) -let u_mod_enclose = [%sedlex.regexp? me] -(** Cc *) -let u_ascii_control = [%sedlex.regexp? cc] -(** Cf *) -let u_format_control = [%sedlex.regexp? cf] -(** Co *) -let u_private_use = [%sedlex.regexp? co] -(** Cs *) -let u_surrogate = [%sedlex.regexp? cs] - -(* -------------------------------------------------------------------- *) -let lower = [%sedlex.regexp? u_lower] -let upper = [%sedlex.regexp? u_upper | u_title] -let letter = [%sedlex.regexp? u_lower | u_upper | u_other | u_modifier] -let digit = [%sedlex.regexp? '0'..'9'] -let hex = [%sedlex.regexp? '0'..'9' | 'A'..'F' | 'a'..'f'] - -(* -------------------------------------------------------------------- *) -let anywhite = [%sedlex.regexp? u_space | u_space_extra] -let newline = [%sedlex.regexp? "\r\n" | 10 | 13 | 0x2028 | 0x2029] - -(* -------------------------------------------------------------------- *) -let op_char = [%sedlex.regexp? Chars "!$%&*+-.<>=?^|~:@#\\/"] - -(* op_token must be splt into seperate regular expressions to prevent - compliation from hanging *) -let op_token_1 = [%sedlex.regexp? "~" | "-" | "/\\" | "\\/" | "<:" | "$:" | "<@" | "(|" | "|)" | "#" ] -let op_token_2 = [%sedlex.regexp? "u#" | "&" | "()" | "(" | ")" | "," | "~>" | "->" | "<--" ] -let op_token_3 = [%sedlex.regexp? "<-" | "<==>" | "==>" | "." | "?." | "?" | ".[|" | ".[" | ".(|" | ".(" ] -let op_token_4 = [%sedlex.regexp? "$" | "{:pattern" | "{:well-founded" | ":" | "::" | ":=" | ";;" | ";" | "=" | "%[" | "returns$" ] -let op_token_5 = [%sedlex.regexp? "!{" | "[@@@" | "[@@" | "[@" | "[|" | "{|" | "[" | "|>" | "]" | "|]" | "|}" | "{" | "|" | "}" ] - -(* -------------------------------------------------------------------- *) -let xinteger = - [%sedlex.regexp? - ( '0', ('x'| 'X'), Plus hex - | '0', ('o'| 'O'), Plus ('0' .. '7') - | '0', ('b'| 'B'), Plus ('0' .. '1') )] -let integer = [%sedlex.regexp? Plus digit] -let any_integer = [%sedlex.regexp? xinteger | integer] -let unsigned = [%sedlex.regexp? Chars "uU"] -let int8 = [%sedlex.regexp? any_integer, 'y'] -let uint8 = [%sedlex.regexp? any_integer, unsigned, 'y'] -let int16 = [%sedlex.regexp? any_integer, 's'] -let uint16 = [%sedlex.regexp? any_integer, unsigned, 's'] -let int32 = [%sedlex.regexp? any_integer, 'l'] -let uint32 = [%sedlex.regexp? any_integer, unsigned, 'l'] -let int64 = [%sedlex.regexp? any_integer, 'L'] -let uint64 = [%sedlex.regexp? any_integer, unsigned, 'L'] -let char8 = [%sedlex.regexp? any_integer, 'z'] -let sizet = [%sedlex.regexp? any_integer, "sz"] - -let floatp = [%sedlex.regexp? Plus digit, '.', Star digit] -let floate = [%sedlex.regexp? Plus digit, Opt ('.', Star digit), Chars "eE", Opt (Chars "+-"), Plus digit] -let real = [%sedlex.regexp? floatp, 'R'] -let ieee64 = [%sedlex.regexp? floatp | floate] -let xieee64 = [%sedlex.regexp? xinteger, 'L', 'F'] -let range = [%sedlex.regexp? Plus digit, '.', '.', Plus digit] - -let op_prefix = [%sedlex.regexp? Chars "!~?"] -let op_infix0a = [%sedlex.regexp? Chars "|"] (* left *) -let op_infix0b = [%sedlex.regexp? Chars "&"] (* left *) -let op_infix0c = [%sedlex.regexp? Chars "=<>"] (* left *) -let op_infix0c_nogt = [%sedlex.regexp? Chars "=<"] (* left *) -let op_infix0d = [%sedlex.regexp? Chars "$"] (* left *) - -let op_infix0 = [%sedlex.regexp? op_infix0a | op_infix0b | op_infix0c | op_infix0d] -let op_infix1 = [%sedlex.regexp? Chars "@^"] (* right *) -let op_infix2 = [%sedlex.regexp? Chars "+-"] (* left *) -let op_infix3 = [%sedlex.regexp? Chars "*/%"] (* left *) -let symbolchar = [%sedlex.regexp? op_prefix | op_infix0 | op_infix1 | op_infix2 | op_infix3 | Chars ".:"] -let uoperator = [%sedlex.regexp? u_math_nonascii] - -(* -------------------------------------------------------------------- *) -let escape_char = [%sedlex.regexp? '\\', (Chars "\\\"'bfntrv0" | "x", hex, hex | "u", hex, hex, hex, hex)] -let char = [%sedlex.regexp? Compl '\\' | escape_char] - -(* -------------------------------------------------------------------- *) -let constructor_start_char = [%sedlex.regexp? upper] -let ident_start_char = [%sedlex.regexp? lower | '_'] -let ident_char = [%sedlex.regexp? letter | digit | '\'' | '_'] -let tvar_char = [%sedlex.regexp? letter | digit | '\'' | '_'] - -let constructor = [%sedlex.regexp? constructor_start_char, Star ident_char] -let ident = [%sedlex.regexp? ident_start_char, Star ident_char] -let tvar = [%sedlex.regexp? '\'', (ident_start_char | constructor_start_char), Star tvar_char] - -(* [ensure_no_comment lexbuf next] takes a [lexbuf] and [next], a - continuation. It is to be called after a regexp was matched, to - ensure match text does not contain any comment start. - - If the match [s] contains a comment start (an occurence of [//]) - then we place the lexer at that comment start. We continue with - [next s], [s] being either the whole match, or the chunk before - [//]. -*) -let ensure_no_comment lexbuf (next: string -> token): token = - let s = L.lexeme lexbuf in - next (try let before, _after = BatString.split s "//" in - (* rollback to the begining of the match *) - L.rollback lexbuf; - (* skip [n] characters in the lexer, with [n] being [hd]'s len *) - BatString.iter (fun _ -> let _ = L.next lexbuf in ()) before; - before with | Not_found -> s) - -let rec token lexbuf = -match%sedlex lexbuf with - | "%splice" -> SPLICE - | "%splice_t" -> SPLICET - | "```", ident -> - let s = L.lexeme lexbuf in - let name = BatString.lchop ~n:3 s in - Buffer.clear blob_buffer; - let snap = Sedlexing.snapshot lexbuf in - let pos = L.current_pos lexbuf in - uninterpreted_blob snap name pos blob_buffer lexbuf - | "`%" -> BACKTICK_PERC - | "`#" -> BACKTICK_HASH - | "`@" -> BACKTICK_AT - | "#lang-", ident -> ( - let s = L.lexeme lexbuf in - let lang_name = BatString.lchop ~n:6 s in - let snap = Sedlexing.snapshot lexbuf in - Buffer.clear use_lang_buffer; - let pos = L.current_pos lexbuf in - use_lang_blob snap lang_name pos use_lang_buffer lexbuf - ) - - | "seq![" -> SEQ_BANG_LBRACK - - | "#show-options" -> PRAGMA_SHOW_OPTIONS - | "#set-options" -> PRAGMA_SET_OPTIONS - | "#reset-options" -> PRAGMA_RESET_OPTIONS - | "#push-options" -> PRAGMA_PUSH_OPTIONS - | "#pop-options" -> PRAGMA_POP_OPTIONS - | "#restart-solver" -> PRAGMA_RESTART_SOLVER - | "#print-effects-graph" -> PRAGMA_PRINT_EFFECTS_GRAPH - | "__SOURCE_FILE__" -> STRING (L.source_file lexbuf) - | "__LINE__" -> INT (string_of_int (L.current_line lexbuf), false) - - | Plus anywhite -> token lexbuf - | newline -> L.new_line lexbuf; token lexbuf - - (* Must appear before tvar to avoid 'a <-> 'a' conflict *) - | ('\'', char, '\'') -> CHAR (unescape (utrim_both lexbuf 1 1)) - | ('\'', char, '\'', 'B') -> CHAR (unescape (utrim_both lexbuf 1 2)) - | '`' -> BACKTICK - - | "match", Plus op_char -> - ensure_no_comment lexbuf (fun s -> - match BatString.lchop ~n:5 s with - | "" -> MATCH - | s -> MATCH_OP s - ) - - | "if", Plus op_char -> - ensure_no_comment lexbuf (fun s -> - match BatString.lchop ~n:2 s with - | "" -> IF - | s -> IF_OP s - ) - - | "let", Plus op_char -> - ensure_no_comment lexbuf (fun s -> - match BatString.lchop ~n:3 s with - | "" -> LET false - | s -> LET_OP s - ) - - | "exists", Plus op_char -> - ensure_no_comment lexbuf (fun s -> - match BatString.lchop ~n:6 s with - | "" -> EXISTS false - | s -> EXISTS_OP s - ) - - | "∃", Plus op_char -> - ensure_no_comment lexbuf (fun s -> - match BatString.lchop ~n:1 s with - | "" -> EXISTS false - | s -> EXISTS_OP s - ) - - | "forall", Plus op_char -> - ensure_no_comment lexbuf (fun s -> - match BatString.lchop ~n:6 s with - | "" -> FORALL false - | s -> FORALL_OP s - ) - - | "∀", Plus op_char -> - ensure_no_comment lexbuf (fun s -> - match BatString.lchop ~n:1 s with - | "" -> FORALL false - | s -> FORALL_OP s - ) - - | "and", Plus op_char -> - ensure_no_comment lexbuf (fun s -> - match BatString.lchop ~n:3 s with - | "" -> AND - | s -> AND_OP s - ) - - | ";", Plus op_char -> - ensure_no_comment lexbuf (fun s -> - match BatString.lchop ~n:1 s with - | "" -> SEMICOLON - | s -> SEMICOLON_OP (Some s) - ) - - | ";;" -> SEMICOLON_OP None - - | ident -> let id = L.lexeme lexbuf in - if FStar_Compiler_Util.starts_with id FStar_Ident.reserved_prefix - then FStar_Errors.raise_error_text (current_range lexbuf) Codes.Fatal_ReservedPrefix - (FStar_Ident.reserved_prefix ^ " is a reserved prefix for an identifier"); - Hashtbl.find_option keywords id |> Option.default (IDENT id) - | constructor -> let id = L.lexeme lexbuf in - Hashtbl.find_option constructors id |> Option.default (NAME id) - - | tvar -> TVAR (L.lexeme lexbuf) - | (integer | xinteger) -> INT (clean_number (L.lexeme lexbuf), false) - | (uint8 | char8) -> - let c = clean_number (L.lexeme lexbuf) in - let cv = int_of_string c in - if cv < 0 || cv > 255 then fail lexbuf (Codes.Fatal_SyntaxError, "Out-of-range character literal") - else UINT8 (c) - | int8 -> INT8 (clean_number (L.lexeme lexbuf), false) - | uint16 -> UINT16 (clean_number (L.lexeme lexbuf)) - | int16 -> INT16 (clean_number (L.lexeme lexbuf), false) - | uint32 -> UINT32 (clean_number (L.lexeme lexbuf)) - | int32 -> INT32 (clean_number (L.lexeme lexbuf), false) - | uint64 -> UINT64 (clean_number (L.lexeme lexbuf)) - | int64 -> INT64 (clean_number (L.lexeme lexbuf), false) - | sizet -> SIZET (clean_number (L.lexeme lexbuf)) - | range -> RANGE (L.lexeme lexbuf) - | real -> REAL(trim_right lexbuf 1) - | (integer | xinteger | ieee64 | xieee64), Plus ident_char -> - fail lexbuf (Codes.Fatal_SyntaxError, "This is not a valid numeric literal: " ^ L.lexeme lexbuf) - - | "(*" -> - let inner, buffer, startpos = start_comment lexbuf in - comment inner buffer startpos lexbuf - - | "// IN F*:" -> token lexbuf - | "//" -> - (* Only match on "//" to allow the longest-match rule to catch IN F*. This - * creates a lexing conflict with op_infix3 which is caught below. *) - one_line_comment (L.lexeme lexbuf) lexbuf - - | '"' -> string (Buffer.create 0) lexbuf.Sedlexing.start_p lexbuf - - | '`', '`', (Plus (Compl ('`' | 10 | 13 | 0x2028 | 0x2029) | '`', Compl ('`' | 10 | 13 | 0x2028 | 0x2029))), '`', '`' -> - IDENT (trim_both lexbuf 2 2) - - (* Pipe operators have special treatment in the parser. *) - | "<|" -> PIPE_LEFT - | "|>" -> PIPE_RIGHT - - | op_token_1 - | op_token_2 - | op_token_3 - | op_token_4 - | op_token_5 -> L.lexeme lexbuf |> Hashtbl.find operators - - | "<" -> OPINFIX0c("<") - | ">" -> if is_typ_app_gt () - then TYP_APP_GREATER - else begin match%sedlex lexbuf with - | Star symbolchar -> ensure_no_comment lexbuf (fun s -> OPINFIX0c (">" ^ s)) - | _ -> assert false end - - (* Operators. *) - | op_prefix, Star symbolchar -> ensure_no_comment lexbuf (fun s -> OPPREFIX s) - | op_infix0a, Star symbolchar -> ensure_no_comment lexbuf (fun s -> OPINFIX0a s) - | op_infix0b, Star symbolchar -> ensure_no_comment lexbuf (fun s -> OPINFIX0b s) - | op_infix0c_nogt, Star symbolchar -> ensure_no_comment lexbuf (fun s -> OPINFIX0c s) - | op_infix0d, Star symbolchar -> ensure_no_comment lexbuf (fun s -> OPINFIX0d s) - | op_infix1, Star symbolchar -> ensure_no_comment lexbuf (fun s -> OPINFIX1 s) - | op_infix2, Star symbolchar -> ensure_no_comment lexbuf (fun s -> OPINFIX2 s) - | op_infix3, Star symbolchar -> ensure_no_comment lexbuf (function - | "" -> one_line_comment "" lexbuf - | s -> OPINFIX3 s - ) - | "**" , Star symbolchar -> ensure_no_comment lexbuf (fun s -> OPINFIX4 s) - - (* Unicode Operators *) - | uoperator -> let id = L.lexeme lexbuf in - Hashtbl.find_option operators id |> Option.default (OPINFIX4 id) - - | ".[]<-" -> OP_MIXFIX_ASSIGNMENT (L.lexeme lexbuf) - | ".()<-" -> OP_MIXFIX_ASSIGNMENT (L.lexeme lexbuf) - | ".(||)<-" -> OP_MIXFIX_ASSIGNMENT (L.lexeme lexbuf) - | ".[||]<-" -> OP_MIXFIX_ASSIGNMENT (L.lexeme lexbuf) - | ".[]" -> OP_MIXFIX_ACCESS (L.lexeme lexbuf) - | ".()" -> OP_MIXFIX_ACCESS (L.lexeme lexbuf) - | ".(||)" -> OP_MIXFIX_ACCESS (L.lexeme lexbuf) - | ".[||]" -> OP_MIXFIX_ACCESS (L.lexeme lexbuf) - - | eof -> EOF - | _ -> fail lexbuf (Codes.Fatal_SyntaxError, "unexpected char") - -and one_line_comment pre lexbuf = -match%sedlex lexbuf with - | Star (Compl (10 | 13 | 0x2028 | 0x2029)) -> push_one_line_comment pre lexbuf; token lexbuf - | _ -> assert false - -and string buffer start_pos lexbuf = -match%sedlex lexbuf with - | '\\', newline, Star anywhite -> L.new_line lexbuf; string buffer start_pos lexbuf - | newline -> - Buffer.add_string buffer (L.lexeme lexbuf); - L.new_line lexbuf; string buffer start_pos lexbuf - | escape_char -> - Buffer.add_string buffer (BatUTF8.init 1 (fun _ -> unescape (L.ulexeme lexbuf) |> BatUChar.chr)); - string buffer start_pos lexbuf - | '"' -> - (* position info must be set since the start of the string *) - lexbuf.Sedlexing.start_p <- start_pos; - STRING (Buffer.contents buffer) - | eof -> fail lexbuf (Codes.Fatal_SyntaxError, "unterminated string") - | any -> - Buffer.add_string buffer (L.lexeme lexbuf); - string buffer start_pos lexbuf - | _ -> assert false - -and comment inner buffer startpos lexbuf = -match%sedlex lexbuf with - | "(*" -> - Buffer.add_string buffer "(*" ; - let _ = comment true buffer startpos lexbuf in - comment inner buffer startpos lexbuf - | newline -> - L.new_line lexbuf; - Buffer.add_string buffer (L.lexeme lexbuf); - comment inner buffer startpos lexbuf - | "*)" -> - terminate_comment buffer startpos lexbuf; - if inner then EOF else token lexbuf - | eof -> - terminate_comment buffer startpos lexbuf; EOF - | any -> - Buffer.add_string buffer (L.lexeme lexbuf); - comment inner buffer startpos lexbuf - | _ -> assert false - -and uninterpreted_blob snap name pos buffer lexbuf = -match %sedlex lexbuf with - | "```" -> - BLOB(name, Buffer.contents buffer, pos, snap) - | eof -> - E.raise_error_text (current_range lexbuf) Codes.Fatal_SyntaxError - "Syntax error: unterminated extension syntax" - | newline -> - L.new_line lexbuf; - Buffer.add_string buffer (L.lexeme lexbuf); - uninterpreted_blob snap name pos buffer lexbuf - | any -> - Buffer.add_string buffer (L.lexeme lexbuf); - uninterpreted_blob snap name pos buffer lexbuf - | _ -> assert false - -and use_lang_blob snap name pos buffer lexbuf = -match %sedlex lexbuf with - | eof -> - L.rollback lexbuf; (* leave the eof to be consumed later *) - USE_LANG_BLOB(name, Buffer.contents buffer, pos, snap) - | newline -> - L.new_line lexbuf; - Buffer.add_string buffer (L.lexeme lexbuf); - use_lang_blob snap name pos buffer lexbuf - | any -> - Buffer.add_string buffer (L.lexeme lexbuf); - use_lang_blob snap name pos buffer lexbuf - | _ -> assert false - -and ignore_endline lexbuf = -match%sedlex lexbuf with - | Star ' ', newline -> token lexbuf - | _ -> assert false diff --git a/ocaml/fstar-lib/FStar_Parser_Parse.mly b/ocaml/fstar-lib/FStar_Parser_Parse.mly deleted file mode 100644 index b2508a25891..00000000000 --- a/ocaml/fstar-lib/FStar_Parser_Parse.mly +++ /dev/null @@ -1,1730 +0,0 @@ -%{ -(* - Menhir reports the following warnings: - - Warning: 5 states have shift/reduce conflicts. - Warning: 6 shift/reduce conflicts were arbitrarily resolved. - Warning: 221 end-of-stream conflicts were arbitrarily resolved. - - If you're editing this file, be sure to not increase the warnings, - except if you have a really good reason. - - The shift-reduce conflicts are natural in an ML-style language. E.g., - there are S-R conflicts with dangling elses, with a non-delimited match where - the BAR is dangling etc. - - Note: Some symbols are marked public, so that we can reuse this parser from - the parser for the Pulse DSL in FStarLang/steel. - -*) -(* (c) Microsoft Corporation. All rights reserved *) -open Prims -open FStar_Pervasives -open FStar_Errors -open FStar_Compiler_List -open FStar_Compiler_Util -open FStar_Compiler_Range - -(* TODO : these files should be deprecated and removed *) -open FStar_Parser_Const -open FStar_Parser_AST -open FStar_Const -open FStar_Ident - -(* Shorthands *) -let rr = FStar_Parser_Util.translate_range -let rr2 = FStar_Parser_Util.translate_range2 - -let logic_qualifier_deprecation_warning = - "logic qualifier is deprecated, please remove it from the source program. In case your program verifies with the qualifier annotated but not without it, please try to minimize the example and file a github issue." - -let mk_meta_tac m = Meta m - -let old_attribute_syntax_warning = - "The `[@ ...]` syntax of attributes is deprecated. \ - Use `[@@ a1; a2; ...; an]`, a semi-colon separated list of attributes, instead" - -let do_notation_deprecation_warning = - "The lightweight do notation [x <-- y; z] or [x ;; z] is deprecated, use let operators (i.e. [let* x = y in z] or [y ;* z], [*] being any sequence of operator characters) instead." - -let none_to_empty_list x = - match x with - | None -> [] - | Some l -> l - -let parse_extension_blob (extension_name:string) - (s:string) - (blob_range:range) - (extension_syntax_start:range) : FStar_Parser_AST.decl' = - DeclSyntaxExtension (extension_name, s, blob_range, extension_syntax_start) - -let parse_use_lang_blob (extension_name:string) - (s:string) - (blob_range:range) - (extension_syntax_start:range) -: FStar_Parser_AST.decl list -= FStar_Parser_AST_Util.parse_extension_lang extension_name s extension_syntax_start - -%} - -%token STRING -%token IDENT -%token NAME -%token TVAR -%token TILDE - -/* bool indicates if INT8 was 'bad' max_int+1, e.g. '128' */ -%token INT8 -%token INT16 -%token INT32 -%token INT64 -%token INT -%token RANGE - -%token UINT8 -%token UINT16 -%token UINT32 -%token UINT64 -%token SIZET -%token REAL -%token CHAR -%token LET -%token LET_OP -%token AND_OP -%token MATCH_OP -%token IF_OP -%token EXISTS -%token EXISTS_OP -%token FORALL -%token FORALL_OP - - -/* [SEMICOLON_OP] encodes either: -- [;;], which used to be SEMICOLON_SEMICOLON, or -- [;], with a sequence of [op_char] (see FStar_Parser_LexFStar). -*/ -%token SEMICOLON_OP - -%token ASSUME NEW LOGIC ATTRIBUTES -%token IRREDUCIBLE UNFOLDABLE INLINE OPAQUE UNFOLD INLINE_FOR_EXTRACTION -%token NOEXTRACT -%token NOEQUALITY UNOPTEQUALITY -%token PRAGMA_SHOW_OPTIONS PRAGMA_SET_OPTIONS PRAGMA_RESET_OPTIONS PRAGMA_PUSH_OPTIONS PRAGMA_POP_OPTIONS PRAGMA_RESTART_SOLVER PRAGMA_PRINT_EFFECTS_GRAPH -%token TYP_APP_LESS TYP_APP_GREATER SUBTYPE EQUALTYPE SUBKIND BY -%token AND ASSERT SYNTH BEGIN ELSE END -%token EXCEPTION FALSE FUN FUNCTION IF IN MODULE DEFAULT -%token MATCH OF -%token FRIEND OPEN REC THEN TRUE TRY TYPE CALC CLASS INSTANCE EFFECT VAL -%token INTRO ELIM -%token INCLUDE -%token WHEN AS RETURNS RETURNS_EQ WITH HASH AMP LPAREN RPAREN LPAREN_RPAREN COMMA LONG_LEFT_ARROW LARROW RARROW -%token IFF IMPLIES CONJUNCTION DISJUNCTION -%token DOT COLON COLON_COLON SEMICOLON -%token QMARK_DOT -%token QMARK -%token EQUALS PERCENT_LBRACK LBRACK_AT LBRACK_AT_AT LBRACK_AT_AT_AT DOT_LBRACK -%token DOT_LENS_PAREN_LEFT DOT_LPAREN DOT_LBRACK_BAR LBRACK LBRACK_BAR LBRACE_BAR LBRACE BANG_LBRACE -%token BAR_RBRACK BAR_RBRACE UNDERSCORE LENS_PAREN_LEFT LENS_PAREN_RIGHT -%token SEQ_BANG_LBRACK -%token BAR RBRACK RBRACE DOLLAR -%token PRIVATE REIFIABLE REFLECTABLE REIFY RANGE_OF SET_RANGE_OF LBRACE_COLON_PATTERN -%token PIPE_LEFT PIPE_RIGHT -%token NEW_EFFECT SUB_EFFECT LAYERED_EFFECT POLYMONADIC_BIND POLYMONADIC_SUBCOMP SPLICE SPLICET SQUIGGLY_RARROW TOTAL -%token REQUIRES ENSURES DECREASES LBRACE_COLON_WELL_FOUNDED -%token MINUS COLON_EQUALS QUOTE BACKTICK_AT BACKTICK_HASH -%token BACKTICK UNIV_HASH -%token BACKTICK_PERC - -%token OPPREFIX OPINFIX0a OPINFIX0b OPINFIX0c OPINFIX0d OPINFIX1 OPINFIX2 OPINFIX3 OPINFIX4 -%token OP_MIXFIX_ASSIGNMENT OP_MIXFIX_ACCESS -%token BLOB -%token USE_LANG_BLOB - -/* These are artificial */ -%token EOF - -%nonassoc THEN -%nonassoc ELSE - -%nonassoc ASSERT -%nonassoc EQUALTYPE -%nonassoc SUBTYPE -%nonassoc BY - -%right COLON_COLON -%right AMP - -%nonassoc COLON_EQUALS -%left OPINFIX0a -%left OPINFIX0b -%left OPINFIX0c EQUALS -%left OPINFIX0d -%left PIPE_RIGHT -%right PIPE_LEFT -%right OPINFIX1 -%left OPINFIX2 MINUS QUOTE -%left OPINFIX3 -%left BACKTICK -%right OPINFIX4 - -%start inputFragment -%start term -%start warn_error_list -%start oneDeclOrEOF -%type inputFragment -%type <(FStar_Parser_AST.decl list * FStar_Sedlexing.snap option) option> oneDeclOrEOF -%type term -%type lident -%type <(FStar_Errors_Codes.error_flag * string) list> warn_error_list -%% - -(* inputFragment is used at the same time for whole files and fragment of codes (for interactive mode) *) -inputFragment: - | decls=list(decl) EOF - { - as_frag (List.flatten decls) - } - -oneDeclOrEOF: - | EOF { None } - | ds=idecl { Some ds } - -idecl: - | d=decl snap=startOfNextDeclToken - { d, snap } - -%public -startOfNextDeclToken: - | EOF { None } - | pragmaStartToken { None } - | LBRACK_AT { None } (* Attribute start *) - | LBRACK_AT_AT { None } (* Attribute start *) - | qualifier { None } - | CLASS { None } - | INSTANCE { None } - | OPEN { None } - | FRIEND { None } - | INCLUDE { None } - | MODULE { None } - | TYPE { None } - | EFFECT { None } - | LET { None } - | VAL { None } - | SPLICE { None } - | SPLICET { None } - | EXCEPTION { None } - | NEW_EFFECT { None } - | LAYERED_EFFECT { None } - | SUB_EFFECT { None } - | POLYMONADIC_BIND { None } - | POLYMONADIC_SUBCOMP { None } - | b=BLOB { let _, _, _, snap = b in Some snap } - | b=USE_LANG_BLOB { let _, _, _, snap = b in Some snap } - -pragmaStartToken: - | PRAGMA_SHOW_OPTIONS - { () } - | PRAGMA_SET_OPTIONS - { () } - | PRAGMA_RESET_OPTIONS - { () } - | PRAGMA_PUSH_OPTIONS - { () } - | PRAGMA_POP_OPTIONS - { () } - | PRAGMA_RESTART_SOLVER - { () } - | PRAGMA_PRINT_EFFECTS_GRAPH - { () } - -/******************************************************************************/ -/* Top level declarations */ -/******************************************************************************/ - -pragma: - | PRAGMA_SHOW_OPTIONS - { ShowOptions } - | PRAGMA_SET_OPTIONS s=string - { SetOptions s } - | PRAGMA_RESET_OPTIONS s_opt=string? - { ResetOptions s_opt } - | PRAGMA_PUSH_OPTIONS s_opt=string? - { PushOptions s_opt } - | PRAGMA_POP_OPTIONS - { PopOptions } - | PRAGMA_RESTART_SOLVER - { RestartSolver } - | PRAGMA_PRINT_EFFECTS_GRAPH - { PrintEffectsGraph } - -attribute: - | LBRACK_AT x = list(atomicTerm) RBRACK - { - let _ = - match x with - | _::_::_ -> - log_issue_text (rr $loc) Warning_DeprecatedAttributeSyntax old_attribute_syntax_warning - | _ -> () in - x - } - | LBRACK_AT_AT x = semiColonTermList RBRACK - { x } - -%public -decoration: - | x=attribute - { DeclAttributes x } - | x=qualifier - { Qualifier x } - -%public -decl: - | ASSUME lid=uident COLON phi=formula - { [mk_decl (Assume(lid, phi)) (rr $loc) [ Qualifier Assumption ]] } - - | blob=USE_LANG_BLOB - { - let ext_name, contents, pos, snap = blob in - (* blob_range is the full range of the blob, starting from the #lang pragma *) - let blob_range = rr (snd snap, snd $loc) in - (* extension_syntax_start_range is where the extension syntax starts not including - the "#lang ident" prefix *) - let extension_syntax_start_range = (rr (pos, pos)) in - let ds = parse_use_lang_blob ext_name contents blob_range extension_syntax_start_range in - mk_decl (UseLangDecls ext_name) extension_syntax_start_range [] :: ds - } - - | ds=list(decoration) decl=rawDecl - { [mk_decl decl (rr $loc(decl)) ds] } - - | ds=list(decoration) decl=typeclassDecl - { let (decl, extra_attrs) = decl in - let d = mk_decl decl (rr $loc(decl)) ds in - [{ d with attrs = extra_attrs @ d.attrs }] - } - -%public -noDecorationDecl: - | ASSUME lid=uident COLON phi=formula - { [mk_decl (Assume(lid, phi)) (rr $loc) [ Qualifier Assumption ]] } - - | blob=USE_LANG_BLOB - { - let ext_name, contents, pos, snap = blob in - (* blob_range is the full range of the blob, starting from the #lang pragma *) - let blob_range = rr (snd snap, snd $loc) in - (* extension_syntax_start_range is where the extension syntax starts not including - the "#lang ident" prefix *) - let extension_syntax_start_range = (rr (pos, pos)) in - let ds = parse_use_lang_blob ext_name contents blob_range extension_syntax_start_range in - mk_decl (UseLangDecls ext_name) extension_syntax_start_range [] :: ds - } - -%public -decoratableDecl: - | decl=rawDecl - { [mk_decl decl (rr $loc(decl)) []] } - - | decl=typeclassDecl - { let (decl, extra_attrs) = decl in - let d = mk_decl decl (rr $loc(decl)) [] in - [{ d with attrs = extra_attrs }] - } - - -typeclassDecl: - | CLASS tcdef=typeDecl - { - (* Only a single type decl allowed, but construct it the same as for multiple ones. - * Only difference is the `true` below marking that this a class so desugaring - * adds the needed %splice. *) - let d = Tycon (false, true, [tcdef]) in - - (* No attrs yet, but perhaps we want a `class` attribute *) - (d, []) - } - - | INSTANCE q=letqualifier lb=letbinding - { - (* Making a single letbinding *) - let r = rr $loc in - let lbs = focusLetBindings [lb] r in (* lbs is a singleton really *) - let d = TopLevelLet(q, lbs) in - - (* Slapping a `tcinstance` attribute to it *) - let at = mk_term (Var tcinstance_lid) r Type_level in - - (d, [at]) - } - - | INSTANCE VAL lid=lidentOrOperator bs=binders COLON t=typ - { - (* Some duplication from rawDecl... *) - let r = rr $loc in - let t = match bs with - | [] -> t - | bs -> mk_term (Product(bs, t)) (rr2 $loc(bs) $loc(t)) Type_level - in - let d = Val(lid, t) in - (* Slapping a `tcinstance` attribute to it *) - let at = mk_term (Var tcinstance_lid) r Type_level in - - (d, [at]) - } - -restriction: - | LBRACE ids=separated_list(COMMA, id=ident renamed=option(AS id=ident {id} ) {(id, renamed)}) RBRACE - { FStar_Syntax_Syntax.AllowList ids } - | { FStar_Syntax_Syntax.Unrestricted } - -rawDecl: - | p=pragma - { Pragma p } - | OPEN uid=quident r=restriction - { Open (uid, r) } - | FRIEND uid=quident - { Friend uid } - | INCLUDE uid=quident r=restriction - { Include (uid, r) } - | MODULE UNDERSCORE EQUALS uid=quident - { Open (uid, FStar_Syntax_Syntax.AllowList []) } - | MODULE uid1=uident EQUALS uid2=quident - { ModuleAbbrev(uid1, uid2) } - | MODULE q=qlident - { raise_error_text (rr $loc(q)) Fatal_SyntaxError "Syntax error: expected a module name" } - | MODULE uid=quident - { TopLevelModule uid } - | TYPE tcdefs=separated_nonempty_list(AND,typeDecl) - { Tycon (false, false, tcdefs) } - | EFFECT uid=uident tparams=typars EQUALS t=typ - { Tycon(true, false, [(TyconAbbrev(uid, tparams, None, t))]) } - | LET q=letqualifier lbs=separated_nonempty_list(AND, letbinding) - { - let r = rr $loc in - let lbs = focusLetBindings lbs r in - if q <> Rec && List.length lbs <> 1 - then raise_error_text r Fatal_MultipleLetBinding "Unexpected multiple let-binding (Did you forget some rec qualifier ?)"; - TopLevelLet(q, lbs) - } - | VAL c=constant - { - (* This is just to provide a better error than "syntax error" *) - raise_error_text (rr $loc) Fatal_SyntaxError "Syntax error: constants are not allowed in val declarations" - } - | VAL lid=lidentOrOperator bs=binders COLON t=typ - { - let t = match bs with - | [] -> t - | bs -> mk_term (Product(bs, t)) (rr2 $loc(bs) $loc(t)) Type_level - in Val(lid, t) - } - | SPLICE LBRACK ids=separated_list(SEMICOLON, ident) RBRACK t=thunk(atomicTerm) - { Splice (false, ids, t) } - | SPLICET LBRACK ids=separated_list(SEMICOLON, ident) RBRACK t=atomicTerm - { Splice (true, ids, t) } - | EXCEPTION lid=uident t_opt=option(OF t=typ {t}) - { Exception(lid, t_opt) } - | NEW_EFFECT ne=newEffect - { NewEffect ne } - | LAYERED_EFFECT ne=effectDefinition - { LayeredEffect ne } - | EFFECT ne=layeredEffectDefinition - { LayeredEffect ne } - | SUB_EFFECT se=subEffect - { SubEffect se } - | POLYMONADIC_BIND b=polymonadic_bind - { Polymonadic_bind b } - | POLYMONADIC_SUBCOMP c=polymonadic_subcomp - { Polymonadic_subcomp c } - | blob=BLOB - { - let ext_name, contents, pos, snap = blob in - (* blob_range is the full range of the blob, including the enclosing ``` *) - let blob_range = rr (snd snap, snd $loc) in - (* extension_syntax_start_range is where the extension syntax starts not including - the "```ident" prefix *) - let extension_syntax_start_range = (rr (pos, pos)) in - parse_extension_blob ext_name contents blob_range extension_syntax_start_range - } - - -typeDecl: - (* TODO : change to lident with stratify *) - | lid=ident tparams=typars ascr_opt=ascribeKind? tcdef=typeDefinition - { tcdef lid tparams ascr_opt } - -typars: - | x=tvarinsts { x } - | x=binders { x } - -tvarinsts: - | TYP_APP_LESS tvs=separated_nonempty_list(COMMA, tvar) TYP_APP_GREATER - { map (fun tv -> mk_binder (TVariable(tv)) (range_of_id tv) Kind None) tvs } - -%inline recordDefinition: - | LBRACE record_field_decls=right_flexible_nonempty_list(SEMICOLON, recordFieldDecl) RBRACE - { record_field_decls } - -typeDefinition: - | { (fun id binders kopt -> check_id id; TyconAbstract(id, binders, kopt)) } - | EQUALS t=typ - { (fun id binders kopt -> check_id id; TyconAbbrev(id, binders, kopt, t)) } - /* A documentation on the first branch creates a conflict with { x with a = ... }/{ a = ... } */ - | EQUALS attrs_opt=ioption(binderAttributes) record_field_decls=recordDefinition - { (fun id binders kopt -> check_id id; TyconRecord(id, binders, kopt, none_to_empty_list attrs_opt, record_field_decls)) } - (* having the first BAR optional using left-flexible list creates a s/r on FSDOC since any decl can be preceded by a FSDOC *) - | EQUALS ct_decls=list(constructorDecl) - { (fun id binders kopt -> check_id id; TyconVariant(id, binders, kopt, ct_decls)) } - -recordFieldDecl: - | qualified_lid=aqualifiedWithAttrs(lidentOrOperator) COLON t=typ - { - let (qual, attrs), lid = qualified_lid in - (lid, qual, attrs, t) - } - -constructorPayload: - | COLON t=typ {VpArbitrary t} - | OF t=typ {VpOfNotation t} - | fields=recordDefinition opt=option(COLON t=typ {t}) {VpRecord(fields, opt)} - -constructorDecl: - | BAR attrs_opt=ioption(binderAttributes) - uid=uident - payload=option(constructorPayload) - { uid, payload, none_to_empty_list attrs_opt } - -attr_letbinding: - | attr=ioption(attribute) AND lb=letbinding - { attr, lb } - -letoperatorbinding: - | pat=tuplePattern ascr_opt=ascribeTyp? tm=option(EQUALS tm=term {tm}) - { - let h tm - = ( ( match ascr_opt with - | None -> pat - | Some t -> mk_pattern (PatAscribed(pat, t)) (rr2 $loc(pat) $loc(ascr_opt)) ) - , tm) - in - match pat.pat, tm with - | _ , Some tm -> h tm - | PatVar (v, _, _), None -> - let v = lid_of_ns_and_id [] v in - h (mk_term (Var v) (rr $loc(pat)) Expr) - | _ -> raise_error_text (rr $loc(ascr_opt)) Fatal_SyntaxError "Syntax error: let-punning expects a name, not a pattern" - } - -letbinding: - | focus_opt=maybeFocus lid=lidentOrOperator lbp=nonempty_list(patternOrMultibinder) ascr_opt=ascribeTyp? EQUALS tm=term - { - let pat = mk_pattern (PatVar(lid, None, [])) (rr $loc(lid)) in - let pat = mk_pattern (PatApp (pat, flatten lbp)) (rr2 $loc(focus_opt) $loc(lbp)) in - let pos = rr2 $loc(focus_opt) $loc(tm) in - match ascr_opt with - | None -> (focus_opt, (pat, tm)) - | Some t -> (focus_opt, (mk_pattern (PatAscribed(pat, t)) pos, tm)) - } - | focus_opt=maybeFocus pat=tuplePattern ascr=ascribeTyp eq=EQUALS tm=term - { focus_opt, (mk_pattern (PatAscribed(pat, ascr)) (rr2 $loc(focus_opt) $loc(eq)), tm) } - | focus_opt=maybeFocus pat=tuplePattern EQUALS tm=term - { focus_opt, (pat, tm) } - -/******************************************************************************/ -/* Effects */ -/******************************************************************************/ - -newEffect: - | ed=effectRedefinition - | ed=effectDefinition - { ed } - -effectRedefinition: - | lid=uident EQUALS t=simpleTerm - { RedefineEffect(lid, [], t) } - -effectDefinition: - | LBRACE lid=uident bs=binders COLON typ=tmArrow(tmNoEq) - WITH eds=separated_nonempty_list(SEMICOLON, effectDecl) - RBRACE - { DefineEffect(lid, bs, typ, eds) } - -layeredEffectDefinition: - | LBRACE lid=uident bs=binders WITH r=tmNoEq RBRACE - { - let typ = (* bs -> Effect *) - let first_b, last_b = - match bs with - | [] -> - raise_error_text (range_of_id lid) Fatal_SyntaxError - "Syntax error: unexpected empty binders list in the layered effect definition" - | _ -> hd bs, last bs in - let r = union_ranges first_b.brange last_b.brange in - mk_term (Product (bs, mk_term (Name (lid_of_str "Effect")) r Type_level)) r Type_level in - let rec decls (r:term) = - match r.tm with - | Paren r -> decls r - | Record (None, flds) -> - flds |> List.map (fun (lid, t) -> - mk_decl (Tycon (false, - false, - [TyconAbbrev (ident_of_lid lid, [], None, t)])) - t.range []) - | _ -> - raise_error_text r.range Fatal_SyntaxError - "Syntax error: layered effect combinators should be declared as a record" - in - DefineEffect (lid, [], typ, decls r) } - -effectDecl: - | lid=lident action_params=binders EQUALS t=simpleTerm - { mk_decl (Tycon (false, false, [TyconAbbrev(lid, action_params, None, t)])) (rr $loc) [] } - -subEffect: - | src_eff=quident SQUIGGLY_RARROW tgt_eff=quident EQUALS lift=simpleTerm - { { msource = src_eff; mdest = tgt_eff; lift_op = NonReifiableLift lift; braced=false } } - | src_eff=quident SQUIGGLY_RARROW tgt_eff=quident - LBRACE - lift1=separated_pair(IDENT, EQUALS, simpleTerm) - lift2_opt=ioption(separated_pair(SEMICOLON id=IDENT {id}, EQUALS, simpleTerm)) - /* might be nice for homogeneity if possible : ioption(SEMICOLON) */ - RBRACE - { - match lift2_opt with - | None -> - begin match lift1 with - | ("lift", lift) -> - { msource = src_eff; mdest = tgt_eff; lift_op = LiftForFree lift; braced=true } - | ("lift_wp", lift_wp) -> - { msource = src_eff; mdest = tgt_eff; lift_op = NonReifiableLift lift_wp; braced=true } - | _ -> - raise_error_text (rr $loc) Fatal_UnexpectedIdentifier "Unexpected identifier; expected {'lift', and possibly 'lift_wp'}" - end - | Some (id2, tm2) -> - let (id1, tm1) = lift1 in - let lift, lift_wp = match (id1, id2) with - | "lift_wp", "lift" -> tm1, tm2 - | "lift", "lift_wp" -> tm2, tm1 - | _ -> raise_error_text (rr $loc) Fatal_UnexpectedIdentifier "Unexpected identifier; expected {'lift', 'lift_wp'}" - in - { msource = src_eff; mdest = tgt_eff; lift_op = ReifiableLift (lift, lift_wp); braced=true } - } - -polymonadic_bind: - | LPAREN m_eff=quident COMMA n_eff=quident RPAREN PIPE_RIGHT p_eff=quident EQUALS bind=simpleTerm - { (m_eff, n_eff, p_eff, bind) } - -polymonadic_subcomp: - | m_eff=quident SUBTYPE n_eff=quident EQUALS subcomp=simpleTerm - { (m_eff, n_eff, subcomp) } - - -/******************************************************************************/ -/* Qualifiers, tags, ... */ -/******************************************************************************/ - -qualifier: - | ASSUME { Assumption } - | INLINE { - raise_error_text (rr $loc) Fatal_InlineRenamedAsUnfold - "The 'inline' qualifier has been renamed to 'unfold'" - } - | UNFOLDABLE { - raise_error_text (rr $loc) Fatal_UnfoldableDeprecated - "The 'unfoldable' qualifier is no longer denotable; it is the default qualifier so just omit it" - } - | INLINE_FOR_EXTRACTION { - Inline_for_extraction - } - | UNFOLD { - Unfold_for_unification_and_vcgen - } - | IRREDUCIBLE { Irreducible } - | NOEXTRACT { NoExtract } - | DEFAULT { DefaultEffect } - | TOTAL { TotalEffect } - | PRIVATE { Private } - - | NOEQUALITY { Noeq } - | UNOPTEQUALITY { Unopteq } - | NEW { New } - | LOGIC { log_issue_text (rr $loc) Warning_logicqualifier logic_qualifier_deprecation_warning; - Logic } - | OPAQUE { Opaque } - | REIFIABLE { Reifiable } - | REFLECTABLE { Reflectable } - -maybeFocus: - | b=boption(SQUIGGLY_RARROW) { b } - -letqualifier: - | REC { Rec } - | { NoLetQualifier } - -(* - * AR: this should be generalized to: - * (a) allow attributes on non-implicit binders - * note that in the [@@ case, we choose the Implicit aqual - *) -aqual: - | HASH LBRACK t=thunk(term) RBRACK { mk_meta_tac t } - | HASH { Implicit } - | DOLLAR { Equality } - -binderAttributes: - | LBRACK_AT_AT_AT t=semiColonTermList RBRACK { t } - -/******************************************************************************/ -/* Patterns, binders */ -/******************************************************************************/ - -(* disjunction should be allowed in nested patterns *) -disjunctivePattern: - | pats=separated_nonempty_list(BAR, tuplePattern) { pats } - -%public -tuplePattern: - | pats=separated_nonempty_list(COMMA, constructorPattern) - { match pats with | [x] -> x | l -> mk_pattern (PatTuple (l, false)) (rr $loc) } - -constructorPattern: - | pat=constructorPattern COLON_COLON pats=constructorPattern - { mk_pattern (consPat (rr $loc(pats)) pat pats) (rr $loc) } - | uid=quident args=nonempty_list(atomicPattern) - { - let head_pat = mk_pattern (PatName uid) (rr $loc(uid)) in - mk_pattern (PatApp (head_pat, args)) (rr $loc) - } - | pat=atomicPattern - { pat } - -atomicPattern: - | LPAREN pat=tuplePattern COLON t=simpleArrow phi_opt=refineOpt RPAREN - { - let pos_t = rr2 $loc(pat) $loc(t) in - let pos = rr $loc in - mkRefinedPattern pat t true phi_opt pos_t pos - } - | LBRACK pats=separated_list(SEMICOLON, tuplePattern) RBRACK - { mk_pattern (PatList pats) (rr2 $loc($1) $loc($3)) } - | LBRACE record_pat=right_flexible_list(SEMICOLON, fieldPattern) RBRACE - { mk_pattern (PatRecord record_pat) (rr $loc) } - | LENS_PAREN_LEFT pat0=constructorPattern COMMA pats=separated_nonempty_list(COMMA, constructorPattern) LENS_PAREN_RIGHT - { mk_pattern (PatTuple(pat0::pats, true)) (rr $loc) } - | LPAREN pat=tuplePattern RPAREN { pat } - | tv=tvar { mk_pattern (PatTvar (tv, None, [])) (rr $loc(tv)) } - | LPAREN op=operator RPAREN - { mk_pattern (PatOp op) (rr $loc) } - | UNDERSCORE - { mk_pattern (PatWild (None, [])) (rr $loc) } - | HASH UNDERSCORE - { mk_pattern (PatWild (Some Implicit, [])) (rr $loc) } - | c=constant - { mk_pattern (PatConst c) (rr $loc(c)) } - | tok=MINUS c=constant - { let r = rr2 $loc(tok) $loc(c) in - let c = - match c with - | Const_int (s, swopt) -> - (match swopt with - | None - | Some (Signed, _) -> Const_int ("-" ^ s, swopt) - | _ -> raise_error_text r Fatal_SyntaxError "Syntax_error: negative integer constant with unsigned width") - | _ -> raise_error_text r Fatal_SyntaxError "Syntax_error: negative constant that is not an integer" - in - mk_pattern (PatConst c) r } - | BACKTICK_PERC q=atomicTerm - { mk_pattern (PatVQuote q) (rr $loc) } - | qual_id=aqualifiedWithAttrs(lident) - { - let (aqual, attrs), lid = qual_id in - mk_pattern (PatVar (lid, aqual, attrs)) (rr $loc(qual_id)) } - | uid=quident - { mk_pattern (PatName uid) (rr $loc(uid)) } - -fieldPattern: - | p = separated_pair(qlident, EQUALS, tuplePattern) - { p } - | lid=qlident - { lid, mk_pattern (PatVar (ident_of_lid lid, None, [])) (rr $loc(lid)) } - - (* (x : t) is already covered by atomicPattern *) - (* we do *NOT* allow _ in multibinder () since it creates reduce/reduce conflicts when*) - (* preprocessing to ocamlyacc/fsyacc (which is expected since the macro are expanded) *) -patternOrMultibinder: - | LBRACE_BAR id=lidentOrUnderscore COLON t=simpleArrow BAR_RBRACE - { let r = rr $loc in - let w = mk_pattern (PatVar (id, Some TypeClassArg, [])) r in - let asc = (t, None) in - [mk_pattern (PatAscribed(w, asc)) r] - } - - | LBRACE_BAR t=simpleArrow BAR_RBRACE - { let r = rr $loc in - let id = gen r in - let w = mk_pattern (PatVar (id, Some TypeClassArg, [])) r in - let asc = (t, None) in - [mk_pattern (PatAscribed(w, asc)) r] - } - | pat=atomicPattern { [pat] } - | LPAREN qual_id0=aqualifiedWithAttrs(lident) qual_ids=nonempty_list(aqualifiedWithAttrs(lident)) COLON t=simpleArrow r=refineOpt RPAREN - { - let pos = rr $loc in - let t_pos = rr $loc(t) in - let qual_ids = qual_id0 :: qual_ids in - List.map (fun ((aq, attrs), x) -> mkRefinedPattern (mk_pattern (PatVar (x, aq, attrs)) pos) t false r t_pos pos) qual_ids - } - -binder: - | aqualifiedWithAttrs_lid=aqualifiedWithAttrs(lidentOrUnderscore) - { - let (q, attrs), lid = aqualifiedWithAttrs_lid in - mk_binder_with_attrs (Variable lid) (rr $loc(aqualifiedWithAttrs_lid)) Type_level q attrs - } - - | tv=tvar { mk_binder (TVariable tv) (rr $loc) Kind None } - (* small regression here : fun (=x : t) ... is not accepted anymore *) - -%public -multiBinder: - | LBRACE_BAR id=lidentOrUnderscore COLON t=simpleArrow BAR_RBRACE - { let r = rr $loc in - [mk_binder (Annotated (id, t)) r Type_level (Some TypeClassArg)] - } - - | LBRACE_BAR t=simpleArrow BAR_RBRACE - { let r = rr $loc in - let id = gen r in - [mk_binder (Annotated (id, t)) r Type_level (Some TypeClassArg)] - } - - | LPAREN qual_ids=nonempty_list(aqualifiedWithAttrs(lidentOrUnderscore)) COLON t=simpleArrow r=refineOpt RPAREN - { - let should_bind_var = match qual_ids with | [ _ ] -> true | _ -> false in - List.map (fun ((q, attrs), x) -> - mkRefinedBinder x t should_bind_var r (rr $loc) q attrs) qual_ids - } - - | LPAREN_RPAREN - { - let r = rr $loc in - let unit_t = mk_term (Var (lid_of_ids [(mk_ident("unit", r))])) r Un in - [mk_binder (Annotated (gen r, unit_t)) r Un None] - } - - | b=binder { [b] } - -%public -binders: bss=list(bs=multiBinder {bs}) { flatten bss } - -aqualifiedWithAttrs(X): - | aq=aqual attrs=binderAttributes x=X { (Some aq, attrs), x } - | aq=aqual x=X { (Some aq, []), x } - | attrs=binderAttributes x=X { (None, attrs), x } - | x=X { (None, []), x } - -/******************************************************************************/ -/* Identifiers, module paths */ -/******************************************************************************/ - -%public -qlident: - | ids=path(lident) { lid_of_ids ids } - -%public -quident: - | ids=path(uident) { lid_of_ids ids } - -path(Id): - | id=Id { [id] } - | uid=uident DOT p=path(Id) { uid::p } - -ident: - | x=lident { x } - | x=uident { x } - -qlidentOrOperator: - | qid=qlident { qid } - | LPAREN id=operator RPAREN - { lid_of_ns_and_id [] (id_of_text (compile_op' (string_of_id id) (range_of_id id))) } - -%inline lidentOrOperator: - | id=lident { id } - | LPAREN id=operator RPAREN - { mk_ident (compile_op' (string_of_id id) (range_of_id id), range_of_id id) } - -matchMaybeOp: - | MATCH {None} - | op=MATCH_OP { Some (mk_ident ("let" ^ op, rr $loc(op))) } - -ifMaybeOp: - | IF {None} - | op=IF_OP { Some (mk_ident ("let" ^ op, rr $loc(op))) } - -%public -lidentOrUnderscore: - | id=IDENT { mk_ident(id, rr $loc(id))} - | UNDERSCORE { gen (rr $loc) } - -%public -lident: - | id=IDENT { mk_ident(id, rr $loc(id))} - -uident: - | id=NAME { mk_ident(id, rr $loc(id)) } - -tvar: - | tv=TVAR { mk_ident(tv, rr $loc(tv)) } - - -/******************************************************************************/ -/* Types and terms */ -/******************************************************************************/ - -thunk(X): | t=X { mk_term (Abs ([mk_pattern (PatWild (None, [])) (rr $loc)], t)) (rr $loc) Expr } - -thunk2(X): - | t=X - { let u = mk_term (Const Const_unit) (rr $loc) Expr in - let t = mk_term (Seq (u, t)) (rr $loc) Expr in - mk_term (Abs ([mk_pattern (PatWild (None, [])) (rr $loc)], t)) (rr $loc) Expr } - -ascribeTyp: - | COLON t=tmArrow(tmNoEq) tacopt=option(BY tactic=thunk(trailingTerm) {tactic}) { t, tacopt } - -(* Remove for stratify *) -ascribeKind: - | COLON k=kind { k } - -(* Remove for stratify *) -kind: - | t=tmArrow(tmNoEq) { {t with level=Kind} } - - -term: - | e=noSeqTerm - { e } - | e1=noSeqTerm SEMICOLON e2=term - { mk_term (Seq(e1, e2)) (rr2 $loc(e1) $loc(e2)) Expr } -(* Added this form for sequencing; *) -(* but it results in an additional shift/reduce conflict *) -(* ... which is actually be benign, since the same conflict already *) -(* exists for the previous production *) - | e1=noSeqTerm op=SEMICOLON_OP e2=term - { let t = match op with - | Some op -> - let op = mk_ident ("let" ^ op, rr $loc(op)) in - let pat = mk_pattern (PatWild(None, [])) (rr $loc(op)) in - LetOperator ([(op, pat, e1)], e2) - | None -> - log_issue_text (rr $loc) Warning_DeprecatedLightDoNotation do_notation_deprecation_warning; - Bind(gen (rr $loc(op)), e1, e2) - in mk_term t (rr2 $loc(e1) $loc(e2)) Expr - } - | x=lidentOrUnderscore LONG_LEFT_ARROW e1=noSeqTerm SEMICOLON e2=term - { log_issue_text (rr $loc) Warning_DeprecatedLightDoNotation do_notation_deprecation_warning; - mk_term (Bind(x, e1, e2)) (rr2 $loc(x) $loc(e2)) Expr } - -match_returning: - | as_opt=option(AS i=lident {i}) RETURNS t=tmIff {as_opt,t,false} - | as_opt=option(AS i=lident {i}) RETURNS_EQ t=tmIff {as_opt,t,true} - -%public -noSeqTerm: - | t=typ { t } - | e=tmIff SUBTYPE t=tmIff - { mk_term (Ascribed(e,{t with level=Expr},None,false)) (rr $loc(e)) Expr } - | e=tmIff SUBTYPE t=tmIff BY tactic=thunk(typ) - { mk_term (Ascribed(e,{t with level=Expr},Some tactic,false)) (rr2 $loc(e) $loc(tactic)) Expr } - | e=tmIff EQUALTYPE t=tmIff - { - log_issue_text (rr $loc) Warning_BleedingEdge_Feature - "Equality type ascriptions is an experimental feature subject to redesign in the future"; - mk_term (Ascribed(e,{t with level=Expr},None,true)) (rr $loc(e)) Expr - } - | e=tmIff EQUALTYPE t=tmIff BY tactic=thunk(typ) - { - log_issue_text (rr $loc) Warning_BleedingEdge_Feature - "Equality type ascriptions is an experimental feature subject to redesign in the future"; - mk_term (Ascribed(e,{t with level=Expr},Some tactic,true)) (rr2 $loc(e) $loc(tactic)) Expr - } - | e1=atomicTermNotQUident op_expr=dotOperator LARROW e3=noSeqTerm - { - let (op, e2, _) = op_expr in - let opid = mk_ident (string_of_id op ^ "<-", range_of_id op) in - mk_term (Op(opid, [ e1; e2; e3 ])) (rr2 $loc(e1) $loc(e3)) Expr - } - | REQUIRES t=typ - { mk_term (Requires(t, None)) (rr2 $loc($1) $loc(t)) Type_level } - | ENSURES t=typ - { mk_term (Ensures(t, None)) (rr2 $loc($1) $loc(t)) Type_level } - | DECREASES t=typ - { mk_term (Decreases (t, None)) (rr2 $loc($1) $loc(t)) Type_level } - | DECREASES LBRACE_COLON_WELL_FOUNDED t=noSeqTerm RBRACE - (* - * decreases clause with relation is written as e1 e2, - * where e1 is a relation and e2 is a term - * - * this is parsed as an app node, so we destruct the app node - *) - { match t.tm with - | App (t1, t2, _) -> - let ot = mk_term (WFOrder (t1, t2)) (rr2 $loc(t) $loc(t)) Type_level in - mk_term (Decreases (ot, None)) (rr2 $loc($1) $loc($4)) Type_level - | _ -> - raise_error_text (rr $loc(t)) Fatal_SyntaxError - "Syntax error: To use well-founded relations, write e1 e2" - } - - | ATTRIBUTES es=nonempty_list(atomicTerm) - { mk_term (Attributes es) (rr2 $loc($1) $loc(es)) Type_level } - | op=ifMaybeOp e1=noSeqTerm ret_opt=option(match_returning) THEN e2=noSeqTerm ELSE e3=noSeqTerm - { mk_term (If(e1, op, ret_opt, e2, e3)) (rr2 $loc(op) $loc(e3)) Expr } - | op=ifMaybeOp e1=noSeqTerm ret_opt=option(match_returning) THEN e2=noSeqTerm - { - let e3 = mk_term (Const Const_unit) (rr2 $loc(op) $loc(e2)) Expr in - mk_term (If(e1, op, ret_opt, e2, e3)) (rr2 $loc(op) $loc(e2)) Expr - } - | TRY e1=term WITH pbs=left_flexible_nonempty_list(BAR, patternBranch) - { - let branches = focusBranches (pbs) (rr2 $loc($1) $loc(pbs)) in - mk_term (TryWith(e1, branches)) (rr2 $loc($1) $loc(pbs)) Expr - } - | op=matchMaybeOp e=term ret_opt=option(match_returning) WITH pbs=left_flexible_list(BAR, pb=patternBranch {pb}) - { - let branches = focusBranches pbs (rr2 $loc(op) $loc(pbs)) in - mk_term (Match(e, op, ret_opt, branches)) (rr2 $loc(op) $loc(pbs)) Expr - } - | LET OPEN t=term IN e=term - { - match t.tm with - | Ascribed(r, rty, None, _) -> - mk_term (LetOpenRecord(r, rty, e)) (rr2 $loc($1) $loc(e)) Expr - - | Name uid -> - mk_term (LetOpen(uid, e)) (rr2 $loc($1) $loc(e)) Expr - - | _ -> - raise_error_text (rr $loc(t)) Fatal_SyntaxError - "Syntax error: local opens expects either opening\n\ - a module or namespace using `let open T in e`\n\ - or, a record type with `let open e <: t in e'`" - } - - | attrs=ioption(attribute) - LET q=letqualifier lb=letbinding lbs=list(attr_letbinding) IN e=term - { - let lbs = (attrs, lb)::lbs in - let lbs = focusAttrLetBindings lbs (rr2 $loc(q) $loc(lb)) in - mk_term (Let(q, lbs, e)) (rr $loc) Expr - } - | op=let_op b=letoperatorbinding lbs=list(op=and_op b=letoperatorbinding {(op, b)}) IN e=term - { let lbs = (op, b)::lbs in - mk_term (LetOperator ( List.map (fun (op, (pat, tm)) -> (op, pat, tm)) lbs - , e)) (rr2 $loc(op) $loc(e)) Expr - } - | FUNCTION pbs=left_flexible_nonempty_list(BAR, patternBranch) - { - let branches = focusBranches pbs (rr2 $loc($1) $loc(pbs)) in - mk_function branches (rr $loc) (rr2 $loc($1) $loc(pbs)) - } - | a=ASSUME e=noSeqTerm - { let a = set_lid_range assume_lid (rr $loc(a)) in - mkExplicitApp (mk_term (Var a) (rr $loc(a)) Expr) [e] (rr $loc) - } - - | a=ASSERT e=noSeqTerm - { - let a = set_lid_range assert_lid (rr $loc(a)) in - mkExplicitApp (mk_term (Var a) (rr $loc(a)) Expr) [e] (rr $loc) - } - - | a=ASSERT e=noSeqTerm BY tactic=thunk2(typ) - { - let a = set_lid_range assert_by_tactic_lid (rr $loc(a)) in - mkExplicitApp (mk_term (Var a) (rr $loc(a)) Expr) [e; tactic] (rr $loc) - } - - | u=UNDERSCORE BY tactic=thunk(atomicTerm) - { - let a = set_lid_range synth_lid (rr $loc(u)) in - mkExplicitApp (mk_term (Var a) (rr $loc(u)) Expr) [tactic] (rr $loc) - } - - | s=SYNTH tactic=atomicTerm - { - let a = set_lid_range synth_lid (rr $loc(s)) in - mkExplicitApp (mk_term (Var a) (rr $loc(s)) Expr) [tactic] (rr $loc) - } - - | CALC rel=atomicTerm LBRACE init=noSeqTerm SEMICOLON steps=list(calcStep) RBRACE - { - mk_term (CalcProof (rel, init, steps)) (rr2 $loc($1) $loc($7)) Expr - } - - | INTRO FORALL bs=binders DOT p=noSeqTerm WITH e=noSeqTerm - { - mk_term (IntroForall(bs, p, e)) (rr2 $loc($1) $loc(e)) Expr - } - - | INTRO EXISTS bs=binders DOT p=noSeqTerm WITH vs=list(atomicTerm) AND e=noSeqTerm - { - if List.length bs <> List.length vs - then raise_error_text (rr $loc(vs)) Fatal_SyntaxError "Syntax error: expected instantiations for all binders" - else mk_term (IntroExists(bs, p, vs, e)) (rr2 $loc($1) $loc(e)) Expr - } - - | INTRO p=tmFormula IMPLIES q=tmFormula WITH y=singleBinder DOT e=noSeqTerm - { - mk_term (IntroImplies(p, q, y, e)) (rr2 $loc($1) $loc(e)) Expr - } - - | INTRO p=tmFormula DISJUNCTION q=tmConjunction WITH lr=NAME e=noSeqTerm - { - let b = - if lr = "Left" then true - else if lr = "Right" then false - else raise_error_text (rr $loc(lr)) Fatal_SyntaxError "Syntax error: _intro_ \\/ expects either 'Left' or 'Right'" - in - mk_term (IntroOr(b, p, q, e)) (rr2 $loc($1) $loc(e)) Expr - } - - | INTRO p=tmConjunction CONJUNCTION q=tmTuple WITH e1=noSeqTerm AND e2=noSeqTerm - { - mk_term (IntroAnd(p, q, e1, e2)) (rr2 $loc($1) $loc(e2)) Expr - } - - | ELIM FORALL xs=binders DOT p=noSeqTerm WITH vs=list(atomicTerm) - { - mk_term (ElimForall(xs, p, vs)) (rr2 $loc($1) $loc(vs)) Expr - } - - | ELIM EXISTS bs=binders DOT p=noSeqTerm RETURNS q=noSeqTerm WITH y=singleBinder DOT e=noSeqTerm - { - mk_term (ElimExists(bs, p, q, y, e)) (rr2 $loc($1) $loc(e)) Expr - } - - | ELIM p=tmFormula IMPLIES q=tmFormula WITH e=noSeqTerm - { - mk_term (ElimImplies(p, q, e)) (rr2 $loc($1) $loc(e)) Expr - } - - | ELIM p=tmFormula DISJUNCTION q=tmConjunction RETURNS r=noSeqTerm WITH x=singleBinder DOT e1=noSeqTerm AND y=singleBinder DOT e2=noSeqTerm - { - mk_term (ElimOr(p, q, r, x, e1, y, e2)) (rr2 $loc($1) $loc(e2)) Expr - } - - | ELIM p=tmConjunction CONJUNCTION q=tmTuple RETURNS r=noSeqTerm WITH xs=binders DOT e=noSeqTerm - { - match xs with - | [x;y] -> mk_term (ElimAnd(p, q, r, x, y, e)) (rr2 $loc($1) $loc(e)) Expr - } - -singleBinder: - | bs=binders - { - match bs with - | [b] -> b - | _ -> raise_error_text (rr $loc(bs)) Fatal_SyntaxError "Syntax error: expected a single binder" - } - -calcRel: - | i=binop_name { mk_term (Op (i, [])) (rr $loc(i)) Expr } - | BACKTICK id=qlident BACKTICK { mk_term (Var id) (rr $loc) Un } - | t=atomicTerm { t } - -calcStep: - | rel=calcRel LBRACE justif=option(term) RBRACE next=noSeqTerm SEMICOLON - { - let justif = - match justif with - | Some t -> t - | None -> mk_term (Const Const_unit) (rr2 $loc($2) $loc($4)) Expr - in - CalcStep (rel, justif, next) - } - -%inline -typ: - | t=simpleTerm { t } - -%public -%inline quantifier: - | FORALL { fun x -> QForall x } - | EXISTS { fun x -> QExists x} - | op=FORALL_OP - { - let op = mk_ident("forall" ^ op, rr $loc(op)) in - fun (x,y,z) -> QuantOp (op, x, y, z) - } - | op=EXISTS_OP - { - let op = mk_ident("exists" ^ op, rr $loc(op)) in - fun (x,y,z) -> QuantOp (op, x, y, z) - } - -%public -trigger: - | { [] } - | LBRACE_COLON_PATTERN pats=disjunctivePats RBRACE { pats } - -disjunctivePats: - | pats=separated_nonempty_list(DISJUNCTION, conjunctivePat) { pats } - -conjunctivePat: - | pats=separated_nonempty_list(SEMICOLON, appTerm) { pats } - -%inline simpleTerm: - | e=tmIff { e } - -maybeFocusArrow: - | RARROW { false } - | SQUIGGLY_RARROW { true } - -patternBranch: - | pat=disjunctivePattern when_opt=maybeWhen focus=maybeFocusArrow e=term - { - let pat = match pat with - | [p] -> p - | ps -> mk_pattern (PatOr ps) (rr2 $loc(pat) $loc(pat)) - in - (focus, (pat, when_opt, e)) - } - -%inline maybeWhen: - | { None } - | WHEN e=tmFormula { Some e } - - - -tmIff: - | e1=tmImplies tok=IFF e2=tmIff - { mk_term (Op(mk_ident("<==>", rr $loc(tok)), [e1; e2])) (rr2 $loc(e1) $loc(e2)) Formula } - | e=tmImplies { e } - -tmImplies: - | e1=tmArrow(tmFormula) tok=IMPLIES e2=tmImplies - { mk_term (Op(mk_ident("==>", rr $loc(tok)), [e1; e2])) (rr2 $loc(e1) $loc(e2)) Formula } - | e=tmArrow(tmFormula) - { e } - - -(* Tm : either tmFormula, containing EQUALS or tmNoEq, without EQUALS *) -tmArrow(Tm): - | dom=tmArrowDomain(Tm) RARROW tgt=tmArrow(Tm) - { - let ((aq_opt, attrs), dom_tm) = dom in - let b = match extract_named_refinement true dom_tm with - | None -> mk_binder_with_attrs (NoName dom_tm) (rr $loc(dom)) Un aq_opt attrs - | Some (x, t, f) -> mkRefinedBinder x t true f (rr2 $loc(dom) $loc(dom)) aq_opt attrs - in - mk_term (Product([b], tgt)) (rr2 $loc(dom) $loc(tgt)) Un - } - | e=Tm { e } - -simpleArrow: - | dom=simpleArrowDomain RARROW tgt=simpleArrow - { - let ((aq_opt, attrs), dom_tm) = dom in - let b = match extract_named_refinement true dom_tm with - | None -> mk_binder_with_attrs (NoName dom_tm) (rr $loc(dom)) Un aq_opt attrs - | Some (x, t, f) -> mkRefinedBinder x t true f (rr2 $loc(dom) $loc(dom)) aq_opt attrs - in - mk_term (Product([b], tgt)) (rr2 $loc(dom) $loc(tgt)) Un - } - | e=tmEqNoRefinement { e } - -simpleArrowDomain: - | LBRACE_BAR t=tmEqNoRefinement BAR_RBRACE { ((Some TypeClassArg, []), t) } - | aq_opt=ioption(aqual) attrs_opt=ioption(binderAttributes) dom_tm=tmEqNoRefinement { (aq_opt, none_to_empty_list attrs_opt), dom_tm } - -(* Tm already accounts for ( term ), we need to add an explicit case for (#Tm), (#[@@@...]Tm) and ([@@@...]Tm) *) -%inline tmArrowDomain(Tm): - | LBRACE_BAR t=Tm BAR_RBRACE { ((Some TypeClassArg, []), t) } - | LPAREN q=aqual attrs_opt=ioption(binderAttributes) dom_tm=Tm RPAREN { (Some q, none_to_empty_list attrs_opt), dom_tm } - | LPAREN attrs=binderAttributes dom_tm=Tm RPAREN { (None, attrs), dom_tm } - | aq_opt=ioption(aqual) attrs_opt=ioption(binderAttributes) dom_tm=Tm { (aq_opt, none_to_empty_list attrs_opt), dom_tm } - -tmFormula: - | e1=tmFormula tok=DISJUNCTION e2=tmConjunction - { mk_term (Op(mk_ident("\\/", rr $loc(tok)), [e1;e2])) (rr2 $loc(e1) $loc(e2)) Formula } - | e=tmConjunction { e } - -tmConjunction: - | e1=tmConjunction tok=CONJUNCTION e2=tmTuple - { mk_term (Op(mk_ident("/\\", rr $loc(tok)), [e1;e2])) (rr2 $loc(e1) $loc(e2)) Formula } - | e=tmTuple { e } - -tmTuple: - | el=separated_nonempty_list(COMMA, tmEq) - { - match el with - | [x] -> x - | components -> mkTuple components (rr2 $loc(el) $loc(el)) - } - - - -%public -tmEqWith(X): - | e1=tmEqWith(X) tok=EQUALS e2=tmEqWith(X) - { mk_term (Op(mk_ident("=", rr $loc(tok)), [e1; e2])) (rr $loc) Un} - (* non-associativity of COLON_EQUALS is currently not well handled by fsyacc which reports a s/r conflict *) - (* see https:/ /github.com/fsprojects/FsLexYacc/issues/39 *) - | e1=tmEqWith(X) tok=COLON_EQUALS e2=tmEqWith(X) - { mk_term (Op(mk_ident(":=", rr $loc(tok)), [e1; e2])) (rr $loc) Un} - - | e1=tmEqWith(X) op=PIPE_LEFT e2=tmEqWith(X) - { mk_term (Op(mk_ident("<|", rr $loc(op)), [e1; e2])) (rr $loc) Un} - - | e1=tmEqWith(X) op=PIPE_RIGHT e2=tmEqWith(X) - { mk_term (Op(mk_ident("|>", rr $loc(op)), [e1; e2])) (rr $loc) Un} - - - | e1=tmEqWith(X) op=operatorInfix0ad12 e2=tmEqWith(X) - { mk_term (Op(op, [e1; e2])) (rr2 $loc(e1) $loc(e2)) Un} - | e1=tmEqWith(X) tok=MINUS e2=tmEqWith(X) - { mk_term (Op(mk_ident("-", rr $loc(tok)), [e1; e2])) (rr $loc) Un} - | tok=MINUS e=tmEqWith(X) - { mk_uminus e (rr $loc(tok)) (rr $loc) Expr } - | QUOTE e=tmEqWith(X) - { mk_term (Quote (e, Dynamic)) (rr $loc) Un } - | BACKTICK e=tmEqWith(X) - { mk_term (Quote (e, Static)) (rr $loc) Un } - | BACKTICK_AT e=atomicTerm - { let q = mk_term (Quote (e, Dynamic)) (rr $loc) Un in - mk_term (Antiquote q) (rr $loc) Un } - | BACKTICK_HASH e=atomicTerm - { mk_term (Antiquote e) (rr $loc) Un } - | e=tmNoEqWith(X) - { e } - -%inline recordTerm: - | LBRACE e=recordExp RBRACE { e } - -tmNoEqWith(X): - | e1=tmNoEqWith(X) COLON_COLON e2=tmNoEqWith(X) - { consTerm (rr $loc) e1 e2 } - | e1=tmNoEqWith(X) AMP e2=tmNoEqWith(X) - { - let dom = - match extract_named_refinement false e1 with - | Some (x, t, f) -> - let dom = mkRefinedBinder x t true f (rr $loc(e1)) None [] in - Inl dom - | _ -> - Inr e1 - in - let tail = e2 in - let dom, res = - match tail.tm with - | Sum(dom', res) -> dom::dom', res - | _ -> [dom], tail - in - mk_term (Sum(dom, res)) (rr2 $loc(e1) $loc(e2)) Type_level - } - | e1=tmNoEqWith(X) op=OPINFIX3 e2=tmNoEqWith(X) - { mk_term (Op(mk_ident(op, rr $loc(op)), [e1; e2])) (rr $loc) Un} - | e1=tmNoEqWith(X) BACKTICK op=tmNoEqWith(X) BACKTICK e2=tmNoEqWith(X) - { mkApp op [ e1, Infix; e2, Nothing ] (rr $loc) } - | e1=tmNoEqWith(X) op=OPINFIX4 e2=tmNoEqWith(X) - { mk_term (Op(mk_ident(op, rr $loc(op)), [e1; e2])) (rr $loc) Un} - | e=recordTerm { e } - | BACKTICK_PERC e=atomicTerm - { mk_term (VQuote e) (rr $loc) Un } - | op=TILDE e=atomicTerm - { mk_term (Op(mk_ident (op, rr $loc(op)), [e])) (rr $loc) Formula } - | e=X { e } - -binop_name: - | o=OPINFIX0a { mk_ident (o, rr $loc) } - | o=OPINFIX0b { mk_ident (o, rr $loc) } - | o=OPINFIX0c { mk_ident (o, rr $loc) } - | o=EQUALS { mk_ident ("=", rr $loc) } - | o=OPINFIX0d { mk_ident (o, rr $loc) } - | o=OPINFIX1 { mk_ident (o, rr $loc) } - | o=OPINFIX2 { mk_ident (o, rr $loc) } - | o=OPINFIX3 { mk_ident (o, rr $loc) } - | o=OPINFIX4 { mk_ident (o, rr $loc) } - | o=IMPLIES { mk_ident ("==>", rr $loc) } - | o=CONJUNCTION { mk_ident ("/\\", rr $loc) } - | o=DISJUNCTION { mk_ident ("\\/", rr $loc) } - | o=IFF { mk_ident ("<==>", rr $loc) } - | o=COLON_EQUALS { mk_ident (":=", rr $loc) } - | o=COLON_COLON { mk_ident ("::", rr $loc) } - | o=OP_MIXFIX_ASSIGNMENT { mk_ident (o, rr $loc) } - | o=OP_MIXFIX_ACCESS { mk_ident (o, rr $loc) } - -tmEqNoRefinement: - | e=tmEqWith(appTermNoRecordExp) { e } - -tmEq: - | e=tmEqWith(tmRefinement) { e } - -tmNoEq: - | e=tmNoEqWith(tmRefinement) { e } - -tmRefinement: - | id=lidentOrUnderscore COLON e=appTermNoRecordExp phi_opt=refineOpt - { - let t = match phi_opt with - | None -> NamedTyp(id, e) - | Some phi -> Refine(mk_binder (Annotated(id, e)) (rr2 $loc(id) $loc(e)) Type_level None, phi) - in mk_term t (rr2 $loc(id) $loc(phi_opt)) Type_level - } - | e=appTerm { e } - -refineOpt: - | phi_opt=option(LBRACE phi=formula RBRACE {phi}) {phi_opt} - -%inline formula: - | e=noSeqTerm { {e with level=Formula} } - -%public -recordExp: - | record_fields=right_flexible_nonempty_list(SEMICOLON, simpleDef) - { mk_term (Record (None, record_fields)) (rr $loc(record_fields)) Expr } - | e=appTerm WITH record_fields=right_flexible_nonempty_list(SEMICOLON, simpleDef) - { mk_term (Record (Some e, record_fields)) (rr2 $loc(e) $loc(record_fields)) Expr } - -simpleDef: - | e=separated_pair(qlidentOrOperator, EQUALS, noSeqTerm) { e } - | lid=qlidentOrOperator { lid, mk_term (Name (lid_of_ids [ ident_of_lid lid ])) (rr $loc(lid)) Un } - -appTermArgs: - | h=maybeHash a=onlyTrailingTerm { [h, a] } - | h=maybeHash a=indexingTerm rest=appTermArgs { (h, a) :: rest } - | h=maybeHash a=recordTerm rest=appTermArgs { (h, a) :: rest } - | a=universe rest=appTermArgs { a :: rest } - | { [] } - -appTermCommon(args): - | head=indexingTerm args=args - { mkApp head (map (fun (x,y) -> (y,x)) args) (rr2 $loc(head) $loc(args)) } - -%public -appTerm: - | t=onlyTrailingTerm { t } - | t=appTermCommon(appTermArgs) { t } - -appTermArgsNoRecordExp: - | h=maybeHash a=indexingTerm rest=appTermArgsNoRecordExp { (h, a) :: rest } - | a=universe rest=appTermArgsNoRecordExp { a :: rest } - | { [] } - -%public -appTermNoRecordExp: - | t=appTermCommon(appTermArgsNoRecordExp) {t} - -%inline maybeHash: - | { Nothing } - | HASH { Hash } - -%public -indexingTerm: - | e1=atomicTermNotQUident op_exprs=nonempty_list(dotOperator) - { - List.fold_left (fun e1 (op, e2, r) -> - mk_term (Op(op, [ e1; e2 ])) (union_ranges e1.range r) Expr) - e1 op_exprs - } - | e=atomicTerm - { e } - -%public -atomicTerm: - | x=atomicTermNotQUident - { x } - | x=atomicTermQUident - { x } - | x=opPrefixTerm(atomicTermQUident) - { x } - -trailingTerm: - | x=atomicTerm - { x } - | x=onlyTrailingTerm - { x } - -onlyTrailingTerm: - | FUN pats=nonempty_list(patternOrMultibinder) RARROW e=term - { mk_term (Abs(flatten pats, e)) (rr2 $loc($1) $loc(e)) Un } - | q=quantifier bs=binders DOT trigger=trigger e=term - { - match bs with - | [] -> - raise_error_text (rr2 $loc(q) $loc($3)) Fatal_MissingQuantifierBinder "Missing binders for a quantifier" - | _ -> - let idents = idents_of_binders bs (rr2 $loc(q) $loc($3)) in - mk_term (q (bs, (idents, trigger), e)) (rr2 $loc(q) $loc(e)) Formula - } - -atomicTermQUident: - | id=quident - { - let t = Name id in - let e = mk_term t (rr $loc(id)) Un in - e - } - | id=quident DOT_LPAREN t=term RPAREN - { - mk_term (LetOpen (id, t)) (rr2 $loc(id) $loc($4)) Expr - } - -atomicTermNotQUident: - | UNDERSCORE { mk_term Wild (rr $loc) Un } - | tv=tvar { mk_term (Tvar tv) (rr $loc) Type_level } - | c=constant { mk_term (Const c) (rr $loc) Expr } - | x=opPrefixTerm(atomicTermNotQUident) - { x } - | LPAREN op=operator RPAREN - { mk_term (Op(op, [])) (rr2 $loc($1) $loc($3)) Un } - | LENS_PAREN_LEFT e0=tmEq COMMA el=separated_nonempty_list(COMMA, tmEq) LENS_PAREN_RIGHT - { mkDTuple (e0::el) (rr2 $loc($1) $loc($5)) } - | e=projectionLHS field_projs=list(DOT id=qlident {id}) - { fold_left (fun e lid -> mk_term (Project(e, lid)) (rr2 $loc(e) $loc(field_projs)) Expr ) e field_projs } - | BEGIN e=term END - { e } - -(* Tm: atomicTermQUident or atomicTermNotQUident *) -opPrefixTerm(Tm): - | op=OPPREFIX e=Tm - { mk_term (Op(mk_ident(op, rr $loc(op)), [e])) (rr2 $loc(op) $loc(e)) Expr } - - -projectionLHS: - | e=qidentWithTypeArgs(qlident, option(fsTypeArgs)) - { e } - | e=qidentWithTypeArgs(quident, some(fsTypeArgs)) - { e } - | LPAREN e=term sort_opt=option(pair(hasSort, simpleTerm)) RPAREN - { - (* Note: we have to keep the parentheses here. Consider t * u * v. This - * is parsed as Op2( *, Op2( *, t, u), v). The desugaring phase then looks - * up * and figures out that it hasn't been overridden, meaning that - * it's a tuple type, and proceeds to flatten out the whole tuple. Now - * consider (t * u) * v. We keep the Paren node, which prevents the - * flattening from happening, hence ensuring the proper type is - * generated. *) - let e1 = match sort_opt with - | None -> e - | Some (level, t) -> mk_term (Ascribed(e,{t with level=level},None,false)) (rr2 $loc($1) $loc($4)) level - in mk_term (Paren e1) (rr2 $loc($1) $loc($4)) (e.level) - } - | LBRACK es=semiColonTermList RBRACK - { mkListLit (rr2 $loc($1) $loc($3)) es } - | SEQ_BANG_LBRACK es=semiColonTermList RBRACK - { mkSeqLit (rr2 $loc($1) $loc($3)) es } - | PERCENT_LBRACK es=semiColonTermList RBRACK - { mk_term (LexList es) (rr2 $loc($1) $loc($3)) Type_level } - | BANG_LBRACE es=separated_list(COMMA, appTerm) RBRACE - { mkRefSet (rr2 $loc($1) $loc($3)) es } - | ns=quident QMARK_DOT id=lident - { mk_term (Projector (ns, id)) (rr2 $loc(ns) $loc(id)) Expr } - | lid=quident QMARK - { mk_term (Discrim lid) (rr2 $loc(lid) $loc($2)) Un } - -fsTypeArgs: - | TYP_APP_LESS targs=separated_nonempty_list(COMMA, atomicTerm) TYP_APP_GREATER - {targs} - -(* Qid : quident or qlident. - TypeArgs : option(fsTypeArgs) or someFsTypeArgs. *) -qidentWithTypeArgs(Qid,TypeArgs): - | id=Qid targs_opt=TypeArgs - { - let t = if is_name id then Name id else Var id in - let e = mk_term t (rr $loc(id)) Un in - match targs_opt with - | None -> e - | Some targs -> mkFsTypApp e targs (rr2 $loc(id) $loc(targs_opt)) - } - -hasSort: - (* | SUBTYPE { Expr } *) - | SUBKIND { Type_level } (* Remove with stratify *) - - (* use flexible_list *) -%inline semiColonTermList: - | l=right_flexible_list(SEMICOLON, noSeqTerm) { l } - -constant: - | LPAREN_RPAREN { Const_unit } - | n=INT - { - if snd n then - log_issue_text (rr $loc) Error_OutOfRange "This number is outside the allowable range for representable integer constants"; - Const_int (fst n, None) - } - | c=CHAR { Const_char c } - | s=STRING { Const_string (s, rr $loc) } - | TRUE { Const_bool true } - | FALSE { Const_bool false } - | r=REAL { Const_real r } - | n=UINT8 { Const_int (n, Some (Unsigned, Int8)) } - | n=INT8 - { - if snd n then - log_issue_text (rr $loc) Error_OutOfRange "This number is outside the allowable range for 8-bit signed integers"; - Const_int (fst n, Some (Signed, Int8)) - } - | n=UINT16 { Const_int (n, Some (Unsigned, Int16)) } - | n=INT16 - { - if snd n then - log_issue_text (rr $loc) Error_OutOfRange "This number is outside the allowable range for 16-bit signed integers"; - Const_int (fst n, Some (Signed, Int16)) - } - | n=UINT32 { Const_int (n, Some (Unsigned, Int32)) } - | n=INT32 - { - if snd n then - log_issue_text (rr $loc) Error_OutOfRange "This number is outside the allowable range for 32-bit signed integers"; - Const_int (fst n, Some (Signed, Int32)) - } - | n=UINT64 { Const_int (n, Some (Unsigned, Int64)) } - | n=INT64 - { - if snd n then - log_issue_text (rr $loc) Error_OutOfRange "This number is outside the allowable range for 64-bit signed integers"; - Const_int (fst n, Some (Signed, Int64)) - } - | n=SIZET { Const_int (n, Some (Unsigned, Sizet)) } - (* TODO : What about reflect ? There is also a constant representing it *) - | REIFY { Const_reify None } - | RANGE_OF { Const_range_of } - | SET_RANGE_OF { Const_set_range_of } - - -universe: - | UNIV_HASH ua=atomicUniverse { (UnivApp, ua) } - -universeFrom: - | ua=atomicUniverse { ua } - | u1=universeFrom op_plus=OPINFIX2 u2=universeFrom - { - if op_plus <> "+" - then log_issue_text (rr $loc(u1)) Error_OpPlusInUniverse ("The operator " ^ op_plus ^ " was found in universe context." - ^ "The only allowed operator in that context is +."); - mk_term (Op(mk_ident (op_plus, rr $loc(op_plus)), [u1 ; u2])) (rr2 $loc(u1) $loc(u2)) Expr - } - | max=ident us=nonempty_list(atomicUniverse) - { - if string_of_id max <> string_of_lid max_lid - then log_issue_text (rr $loc(max)) Error_InvalidUniverseVar ("A lower case ident " ^ string_of_id max ^ - " was found in a universe context. " ^ - "It should be either max or a universe variable 'usomething."); - let max = mk_term (Var (lid_of_ids [max])) (rr $loc(max)) Expr in - mkApp max (map (fun u -> u, Nothing) us) (rr $loc) - } - -atomicUniverse: - | UNDERSCORE - { mk_term Wild (rr $loc) Expr } - | n=INT - { - if snd n then - log_issue_text (rr $loc) Error_OutOfRange ("This number is outside the allowable range for representable integer constants"); - mk_term (Const (Const_int (fst n, None))) (rr $loc(n)) Expr - } - | u=lident { mk_term (Uvar u) (range_of_id u) Expr } - | LPAREN u=universeFrom RPAREN - { u (*mk_term (Paren u) (rr2 $loc($1) $loc($3)) Expr*) } - -warn_error_list: - | e=warn_error EOF { e } - -warn_error: - | f=flag r=range - { [(f, r)] } - | f=flag r=range e=warn_error - { (f, r) :: e } - -flag: - | op=OPINFIX1 - { if op = "@" then CAlwaysError else failwith (format1 "unexpected token %s in warn-error list" op)} - | op=OPINFIX2 - { if op = "+" then CWarning else failwith (format1 "unexpected token %s in warn-error list" op)} - | MINUS - { CSilent } - -range: - | i=INT - { format2 "%s..%s" (fst i) (fst i) } - | r=RANGE - { r } - - -/******************************************************************************/ -/* Miscellanous, tools */ -/******************************************************************************/ - -string: - | s=STRING { s } - -%inline operator: - | op=OPPREFIX { mk_ident (op, rr $loc) } - | op=binop_name { op } - | op=TILDE { mk_ident (op, rr $loc) } - | op=and_op {op} - | op=let_op {op} - | op=quantifier_op {op} - -%inline quantifier_op: - | op=EXISTS_OP { mk_ident ("exists" ^ op, rr $loc) } - | op=FORALL_OP { mk_ident ("forall" ^ op, rr $loc) } - -%inline and_op: - | op=AND_OP { mk_ident ("and" ^ op, rr $loc) } -%inline let_op: - | op=LET_OP { mk_ident ("let" ^ op, rr $loc) } - -/* These infix operators have a lower precedence than EQUALS */ -%inline operatorInfix0ad12: - | op=OPINFIX0a - | op=OPINFIX0b - | op=OPINFIX0c - | op=OPINFIX0d - | op=OPINFIX1 - | op=OPINFIX2 - { mk_ident (op, rr $loc) } - -%inline dotOperator: - | op=DOT_LPAREN e=term RPAREN { mk_ident (".()", rr $loc(op)), e, rr2 $loc(op) $loc($3) } - | op=DOT_LBRACK e=term RBRACK { mk_ident (".[]", rr $loc(op)), e, rr2 $loc(op) $loc($3) } - | op=DOT_LBRACK_BAR e=term BAR_RBRACK { mk_ident (".[||]", rr $loc(op)), e, rr2 $loc(op) $loc($3) } - | op=DOT_LENS_PAREN_LEFT e=term LENS_PAREN_RIGHT { mk_ident (".(||)", rr $loc(op)), e, rr2 $loc(op) $loc($3) } - -some(X): - | x=X { Some x } - -right_flexible_list(SEP, X): - | { [] } - | x=X { [x] } - | x=X SEP xs=right_flexible_list(SEP, X) { x :: xs } - -right_flexible_nonempty_list(SEP, X): - | x=X { [x] } - | x=X SEP xs=right_flexible_list(SEP, X) { x :: xs } - -reverse_left_flexible_list(delim, X): -| (* nothing *) - { [] } -| x = X - { [x] } -| xs = reverse_left_flexible_list(delim, X) delim x = X - { x :: xs } - -%inline left_flexible_list(delim, X): - xs = reverse_left_flexible_list(delim, X) - { List.rev xs } - -reverse_left_flexible_nonempty_list(delim, X): -| ioption(delim) x = X - { [x] } -| xs = reverse_left_flexible_nonempty_list(delim, X) delim x = X - { x :: xs } - -%inline left_flexible_nonempty_list(delim, X): - xs = reverse_left_flexible_nonempty_list(delim, X) - { List.rev xs } diff --git a/ocaml/fstar-lib/FStar_Parser_ParseIt.ml b/ocaml/fstar-lib/FStar_Parser_ParseIt.ml deleted file mode 100644 index 36e7e148419..00000000000 --- a/ocaml/fstar-lib/FStar_Parser_ParseIt.ml +++ /dev/null @@ -1,452 +0,0 @@ -module U = FStar_Compiler_Util -open FStar_Errors -open FStar_Syntax_Syntax -open Lexing -open FStar_Sedlexing -open FStar_Errors_Codes -module Codes = FStar_Errors_Codes -module Msg = FStar_Errors_Msg - -type filename = string - -type input_frag = { - frag_fname:filename; - frag_text:string; - frag_line:Prims.int; - frag_col:Prims.int -} - -let resetLexbufPos filename lexbuf = - lexbuf.cur_p <- { - pos_fname= filename; - pos_cnum = 0; - pos_bol = 0; - pos_lnum = 1 } - -let setLexbufPos filename lexbuf line col = - lexbuf.cur_p <- { - pos_fname= filename; - pos_cnum = col; - pos_bol = 0; - pos_lnum = line } - -module Path = BatPathGen.OfString - -let find_file filename = - match FStar_Find.find_file filename with - | Some s -> - s - | None -> - raise_error_text FStar_Compiler_Range.dummyRange Fatal_ModuleOrFileNotFound (U.format1 "Unable to find file: %s\n" filename) - -let vfs_entries : (U.time * string) U.smap = U.smap_create (Z.of_int 1) - -let read_vfs_entry fname = - U.smap_try_find vfs_entries (U.normalize_file_path fname) - -let add_vfs_entry fname contents = - U.smap_add vfs_entries (U.normalize_file_path fname) (U.now (), contents) - -let get_file_last_modification_time filename = - match read_vfs_entry filename with - | Some (mtime, _contents) -> mtime - | None -> U.get_file_last_modification_time filename - -let read_physical_file (filename: string) = - (* BatFile.with_file_in uses Unix.openfile (which isn't available in - js_of_ocaml) instead of Pervasives.open_in, so we don't use it here. *) - try - let channel = open_in_bin filename in - BatPervasives.finally - (fun () -> close_in channel) - (fun channel -> really_input_string channel (in_channel_length channel)) - channel - with e -> - raise_error_text FStar_Compiler_Range.dummyRange Fatal_UnableToReadFile (U.format1 "Unable to read file %s\n" filename) - -let read_file (filename:string) = - let debug = FStar_Compiler_Debug.any () in - match read_vfs_entry filename with - | Some (_mtime, contents) -> - if debug then U.print1 "Reading in-memory file %s\n" filename; - filename, contents - | None -> - let filename = find_file filename in - if debug then U.print1 "Opening file %s\n" filename; - filename, read_physical_file filename - -let fs_extensions = [".fs"; ".fsi"] -let fst_extensions = [".fst"; ".fsti"] -let interface_extensions = [".fsti"; ".fsi"] - -let valid_extensions () = - fst_extensions @ if FStar_Options.ml_ish () then fs_extensions else [] - -let has_extension file extensions = - FStar_List.existsb (U.ends_with file) extensions - -let check_extension fn = - if (not (has_extension fn (valid_extensions ()))) then - let message = U.format1 "Unrecognized extension '%s'" fn in - raise_error_text FStar_Compiler_Range.dummyRange Fatal_UnrecognizedExtension - (if has_extension fn fs_extensions - then message ^ " (pass --MLish to process .fs and .fsi files)" - else message) - -type parse_frag = - | Filename of filename - | Toplevel of input_frag - | Incremental of input_frag - | Fragment of input_frag - -type parse_error = (Codes.error_code * Msg.error_message * FStar_Compiler_Range.range) - - -type code_fragment = { - range: FStar_Compiler_Range.range; - code: string; -} - -type 'a incremental_result = - ('a * code_fragment) list * (string * FStar_Compiler_Range.range) list * parse_error option - -type parse_result = - | ASTFragment of (FStar_Parser_AST.inputFragment * (string * FStar_Compiler_Range.range) list) - | IncrementalFragment of FStar_Parser_AST.decl incremental_result - | Term of FStar_Parser_AST.term - | ParseError of parse_error - -module BU = FStar_Compiler_Util -module Range = FStar_Compiler_Range -module MHL = MenhirLib.Convert - -let range_of_positions filename start fin = - let start_pos = FStar_Parser_Util.pos_of_lexpos start in - let end_pos = FStar_Parser_Util.pos_of_lexpos fin in - FStar_Compiler_Range.mk_range filename start_pos end_pos - -let err_of_parse_error filename lexbuf tag = - let pos = lexbuf.cur_p in - let tag = - match tag with - | None -> "Syntax error" - | Some tag -> tag - in - Fatal_SyntaxError, - Msg.mkmsg tag, - range_of_positions filename pos pos - -let string_of_lexpos lp = - let r = range_of_positions "" lp lp in - FStar_Compiler_Range.string_of_range r - -let parse_incremental_decls - filename - (contents:string) - lexbuf - (lexer:unit -> 'token * Lexing.position * Lexing.position) - (range_of: 'semantic_value -> FStar_Compiler_Range.range) - (parse_one: - (Lexing.lexbuf -> 'token) -> - Lexing.lexbuf -> - ('semantic_value list * FStar_Sedlexing.snap option) option) -: 'semantic_value list * parse_error option -= let parse_one = MenhirLib.Convert.Simplified.traditional2revised parse_one in - let err_of_parse_error tag = err_of_parse_error filename lexbuf tag in - let open FStar_Pervasives in - let push_decls ds decls = List.fold_left (fun decls d -> d::decls) decls ds in - let rec parse decls = - let start_pos = current_pos lexbuf in - let d = - try - (* Reset the gensym between decls, to ensure determinism, - otherwise, every _ is parsed as different name *) - FStar_GenSym.reset_gensym(); - Inl (parse_one lexer) - with - | FStar_Errors.Error(e, msg, r, ctx) -> - Inr (e, msg, r) - - | e -> - Inr (err_of_parse_error None) - in - match d with - | Inl None -> - List.rev decls, None - | Inl (Some (ds, snap_opt)) -> - (* The parser may advance the lexer beyond the decls last token. - E.g., in `let f x = 0 let g = 1`, we will have parsed the decl for `f` - but the lexer will have advanced to `let ^ g ...` since the - parser will have looked ahead. - Rollback the lexer one token for declarations whose syntax - requires such lookahead to complete a production. - *) - let _ = - match snap_opt with - | None -> - rollback lexbuf - | Some p -> - restore_snapshot lexbuf p - in - parse (push_decls ds decls) - | Inr err -> - List.rev decls, Some err - in - parse [] - -let contents_at contents = - let lines = U.splitlines contents in - let split_line_at_col line col = - if col > 0 - then ( - (* Don't index directly into the string, since this is a UTF-8 string. - Convert first to a list of characters, index into that, and then convert - back to a string *) - let chars = FStar_String.list_of_string line in - if col <= List.length chars - then ( - let prefix, suffix = FStar_Compiler_Util.first_N (Z.of_int col) chars in - Some (FStar_String.string_of_list prefix, - FStar_String.string_of_list suffix) - ) - else ( - None - ) - ) - else None - in - let line_from_col line pos = - match split_line_at_col line pos with - | None -> None - | Some (_, p) -> Some p - in - let line_to_col line pos = - match split_line_at_col line pos with - | None -> None - | Some (p, _) -> Some p - in - (* Find the raw content of the input from the line of the start_pos to the end_pos. - This is used by Interactive.Incremental to record exactly the raw content of the - fragment that was checked *) - fun (range:Range.range) -> - (* discard all lines until the start line *) - let start_pos = Range.start_of_range range in - let end_pos = Range.end_of_range range in - let start_line = Z.to_int (Range.line_of_pos start_pos) in - let start_col = Z.to_int (Range.col_of_pos start_pos) in - let end_line = Z.to_int (Range.line_of_pos end_pos) in - let end_col = Z.to_int (Range.col_of_pos end_pos) in - let suffix = - FStar_Compiler_Util.nth_tail - (Z.of_int (if start_line > 0 then start_line - 1 else 0)) - lines - in - (* Take all the lines between the start and end lines *) - let text, rest = - FStar_Compiler_Util.first_N - (Z.of_int (end_line - start_line)) - suffix - in - let text = - match text with - | first_line::rest -> ( - match line_from_col first_line start_col with - | Some s -> s :: rest - | _ -> text - ) - | _ -> text - in - let text = - (* For the last line itself, take the prefix of it up to the character of the end_pos *) - match rest with - | last::_ -> ( - match line_to_col last end_col with - | None -> text - | Some last -> - (* The last line is also the first line *) - match text with - | [] -> ( - match line_from_col last start_col with - | None -> [last] - | Some l -> [l] - ) - | _ -> text @ [last] - ) - | _ -> text - in - { range; - code = FStar_String.concat "\n" text } - - -let parse_incremental_fragment - filename - (contents:string) - lexbuf - (lexer:unit -> 'token * Lexing.position * Lexing.position) - (range_of: 'semantic_value -> FStar_Compiler_Range.range) - (parse_one: - (Lexing.lexbuf -> 'token) -> - Lexing.lexbuf -> - ('semantic_value list * FStar_Sedlexing.snap option) option) -: 'semantic_value incremental_result -= let res = parse_incremental_decls filename contents lexbuf lexer range_of parse_one in - let comments = FStar_Parser_Util.flush_comments () in - let contents_at = contents_at contents in - let decls, err_opt = res in - let decls = List.map (fun d -> d, contents_at (range_of d)) decls in - decls, comments, err_opt - -let parse_fstar_incrementally -: FStar_Parser_AST_Util.extension_lang_parser -= let f = - fun (s:string) (r:FStar_Compiler_Range.range) -> - let open FStar_Pervasives in - let open FStar_Compiler_Range in - let lexbuf = - create s - (file_of_range r) - (Z.to_int (line_of_pos (start_of_range r))) - (Z.to_int (col_of_pos (start_of_range r))) - in - let filename = file_of_range r in - let contents = s in - let lexer () = - let tok = FStar_Parser_LexFStar.token lexbuf in - (tok, lexbuf.start_p, lexbuf.cur_p) - in - try - let decls, err_opt = - parse_incremental_decls - filename - contents - lexbuf - lexer - (fun (d:FStar_Parser_AST.decl) -> d.drange) - FStar_Parser_Parse.oneDeclOrEOF - in - match err_opt with - | None -> Inr decls - | Some (_, msg, r) -> - let open FStar_Parser_AST in - let err_decl = mk_decl Unparseable r [] in - Inr (decls @ [err_decl]) - with - | FStar_Errors.Error(e, msg, r, _ctx) -> - let msg = FStar_Errors_Msg.rendermsg msg in - let err : FStar_Parser_AST_Util.error_message = { message = msg; range = r } in - Inl err - | e -> - let pos = FStar_Parser_Util.pos_of_lexpos (lexbuf.cur_p) in - let r = FStar_Compiler_Range.mk_range filename pos pos in - let err : FStar_Parser_AST_Util.error_message = { message = "Syntax error parsing #lang-fstar block: "; range = r } in - Inl err - in - { parse_decls = f } -let _ = FStar_Parser_AST_Util.register_extension_lang_parser "fstar" parse_fstar_incrementally - -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 = FStar_Compiler_Range.mk_pos s.frag_line s.frag_col in - let rng = FStar_Compiler_Range.mk_range s.frag_fname frag_pos frag_pos in - let decls = FStar_Parser_AST_Util.parse_extension_lang lang s.frag_text rng in - let comments = FStar_Parser_Util.flush_comments () in - ASTFragment (Inr decls, comments) - with - | FStar_Errors.Error(e, msg, r, _ctx) -> - ParseError (e, msg, r) - -let parse (lang_opt:lang_opts) fn = - FStar_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 FStar_Compiler_Range.dummyRange Fatal_InvalidUTF8Encoding (U.format1 "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 = FStar_Parser_LexFStar.token lexbuf in - (tok, lexbuf.start_p, lexbuf.cur_p) - in - try - match fn with - | Filename _ - | Toplevel _ -> begin - let fileOrFragment = - MenhirLib.Convert.Simplified.traditional2revised FStar_Parser_Parse.inputFragment lexer - in - let frags = match fileOrFragment with - | FStar_Pervasives.Inl modul -> - if has_extension filename interface_extensions - then match modul with - | FStar_Parser_AST.Module(l,d) -> - FStar_Pervasives.Inl (FStar_Parser_AST.Interface(l, d, true)) - | _ -> failwith "Impossible" - else FStar_Pervasives.Inl modul - | _ -> fileOrFragment - in ASTFragment (frags, FStar_Parser_Util.flush_comments ()) - end - - | Incremental i -> - let decls, comments, err_opt = - parse_incremental_fragment - filename - i.frag_text - lexbuf - lexer - (fun (d:FStar_Parser_AST.decl) -> d.drange) - FStar_Parser_Parse.oneDeclOrEOF - in - IncrementalFragment(decls, comments, err_opt) - - | Fragment _ -> - Term (MenhirLib.Convert.Simplified.traditional2revised FStar_Parser_Parse.term lexer) - with - | FStar_Errors.Empty_frag -> - ASTFragment (FStar_Pervasives.Inr [], []) - - | FStar_Errors.Error(e, msg, r, _ctx) -> - ParseError (e, msg, r) - - | e -> - (* - | Parsing.Parse_error as _e - | FStar_Parser_Parse.MenhirBasics.Error as _e -> - *) - ParseError (err_of_parse_error filename lexbuf None) - - -(** Parsing of command-line error/warning/silent flags. *) -let parse_warn_error s = - let user_flags = - if s = "" - then [] - else - let lexbuf = FStar_Sedlexing.create s "" 0 (String.length s) in - let lexer() = let tok = FStar_Parser_LexFStar.token lexbuf in - (tok, lexbuf.start_p, lexbuf.cur_p) - in - try - MenhirLib.Convert.Simplified.traditional2revised FStar_Parser_Parse.warn_error_list lexer - with e -> - failwith (U.format1 "Malformed warn-error list: %s" s) - in - FStar_Errors.update_flags user_flags diff --git a/ocaml/fstar-lib/FStar_Parser_ParseIt.mli b/ocaml/fstar-lib/FStar_Parser_ParseIt.mli deleted file mode 100644 index 0f36caa21f3..00000000000 --- a/ocaml/fstar-lib/FStar_Parser_ParseIt.mli +++ /dev/null @@ -1,58 +0,0 @@ -module U = FStar_Compiler_Util -open FStar_Errors -open FStar_Syntax_Syntax -open Lexing -open FStar_Sedlexing -module Codes = FStar_Errors_Codes -module Msg = FStar_Errors_Msg - -type filename = string - -type input_frag = { - frag_fname:filename; - frag_text:string; - frag_line:Prims.int; - frag_col:Prims.int -} - -val read_vfs_entry : string -> (U.time * string) option -val add_vfs_entry: string -> string -> unit -val get_file_last_modification_time: string -> U.time - -type parse_frag = - | Filename of filename - | Toplevel of input_frag - | Incremental of input_frag - | Fragment of input_frag - -type parse_error = (Codes.error_code * Msg.error_message * FStar_Compiler_Range.range) - -type code_fragment = { - range : FStar_Compiler_Range.range; - code: string; -} - -type parse_result = - | ASTFragment of (FStar_Parser_AST.inputFragment * (string * FStar_Compiler_Range.range) list) - | IncrementalFragment of ((FStar_Parser_AST.decl * code_fragment) list * (string * FStar_Compiler_Range.range) list * parse_error option) - | Term of FStar_Parser_AST.term - | ParseError of parse_error - -val parse_incremental_decls : - (*filename*)string -> - (*contents*)string -> - FStar_Sedlexing.lexbuf -> - (unit -> 'token * Lexing.position * Lexing.position) -> - ('semantic_value -> FStar_Compiler_Range.range) -> - ((Lexing.lexbuf -> 'token) -> Lexing.lexbuf -> - ('semantic_value list * FStar_Sedlexing.snap option) option) -> -'semantic_value list * parse_error option - -type lang_opts = string option -val parse: lang_opts -> parse_frag -> parse_result - -val find_file: string -> string - -val parse_warn_error: string -> Codes.error_setting list - -val parse_fstar_incrementally: FStar_Parser_AST_Util.extension_lang_parser diff --git a/ocaml/fstar-lib/FStar_Parser_Util.ml b/ocaml/fstar-lib/FStar_Parser_Util.ml deleted file mode 100644 index 1efa5917605..00000000000 --- a/ocaml/fstar-lib/FStar_Parser_Util.ml +++ /dev/null @@ -1,44 +0,0 @@ -open FStar_Compiler_Range -open Lexing - -(* This brings into scope enough the translation of F# type names into the - * corresponding OCaml type names; the reason for that is that we massage - * parse.fsy (using sed) into parse.mly; but, we don't rename types. *) -include FStar_BaseTypes -type single = float -type decimal = int -type bytes = byte array - -let parseState = () - -let pos_of_lexpos (p:position) = - mk_pos (Z.of_int p.pos_lnum) (Z.of_int (p.pos_cnum - p.pos_bol)) - -let mksyn_range (p1:position) p2 = - mk_range p1.pos_fname (pos_of_lexpos p1) (pos_of_lexpos p2) - -let translate_range (pos : Lexing.position * Lexing.position) = - mksyn_range (fst pos) (snd pos) - -let translate_range2 (pos1 : Lexing.position * Lexing.position) (pos2 : Lexing.position * Lexing.position) = - mksyn_range (fst pos1) (snd pos2) - -exception WrappedError of exn * range -exception ReportedError -exception StopProcessing - -let warningHandler = ref (fun (e:exn) -> - FStar_Compiler_Util.print_string "no warning handler installed\n" ; - FStar_Compiler_Util.print_any e; ()) -let errorHandler = ref (fun (e:exn) -> - FStar_Compiler_Util.print_string "no warning handler installed\n" ; - FStar_Compiler_Util.print_any e; ()) -let errorAndWarningCount = ref 0 -let errorR exn = incr errorAndWarningCount; match exn with StopProcessing | ReportedError -> raise exn | _ -> !errorHandler exn -let warning exn = incr errorAndWarningCount; match exn with StopProcessing | ReportedError -> raise exn | _ -> !warningHandler exn - -let comments : (string * FStar_Compiler_Range.range) list ref = ref [] -let add_comment x = comments := x :: !comments -let flush_comments () = - let lexed_comments = !comments in - comments := []; lexed_comments diff --git a/ocaml/fstar-lib/FStar_Range.ml b/ocaml/fstar-lib/FStar_Range.ml index e58e2d5aa94..d7f3f16d42e 100644 --- a/ocaml/fstar-lib/FStar_Range.ml +++ b/ocaml/fstar-lib/FStar_Range.ml @@ -1,9 +1,9 @@ -type __range = FStar_Compiler_Range_Type.range +type __range = FStarC_Compiler_Range_Type.range type range = __range -let mk_range f a b c d = FStar_Compiler_Range_Type.mk_range f {line=a;col=b} {line=c;col=d} +let mk_range f a b c d = FStarC_Compiler_Range_Type.mk_range f {line=a;col=b} {line=c;col=d} let range_0 : range = let z = Prims.parse_int "0" in mk_range "dummy" z z z z -let join_range r1 r2 = FStar_Compiler_Range_Ops.union_ranges r1 r2 +let join_range r1 r2 = FStarC_Compiler_Range_Ops.union_ranges r1 r2 let explode (r:__range) = (r.use_range.file_name, diff --git a/ocaml/fstar-lib/FStar_Reflection_Types.ml b/ocaml/fstar-lib/FStar_Reflection_Types.ml deleted file mode 100644 index 667f19bc6a2..00000000000 --- a/ocaml/fstar-lib/FStar_Reflection_Types.ml +++ /dev/null @@ -1,26 +0,0 @@ -open FStar_All - -(* TODO: make this an F* module, no need to drop to OCaml for this *) - -type binder = FStar_Syntax_Syntax.binder -type bv = FStar_Syntax_Syntax.bv -type namedv = bv -type term = FStar_Syntax_Syntax.term -type env = FStar_TypeChecker_Env.env -type fv = FStar_Syntax_Syntax.fv -type comp = FStar_Syntax_Syntax.comp -type sigelt = FStar_Syntax_Syntax.sigelt -type ctx_uvar_and_subst = FStar_Syntax_Syntax.ctx_uvar_and_subst -type optionstate = FStar_Options.optionstate -type letbinding = FStar_Syntax_Syntax.letbinding - -type universe_uvar = FStar_Syntax_Syntax.universe_uvar -type universe = FStar_Syntax_Syntax.universe - -type name = string list -type ident = FStar_Ident.ident -type univ_name = ident -type typ = term -type binders = binder list -type match_returns_ascription = FStar_Syntax_Syntax.match_returns_ascription -type decls = sigelt list diff --git a/ocaml/fstar-lib/FStar_Reflection_Typing_Builtins.ml b/ocaml/fstar-lib/FStar_Reflection_Typing_Builtins.ml index b929def737b..1a0e98d571b 100644 --- a/ocaml/fstar-lib/FStar_Reflection_Typing_Builtins.ml +++ b/ocaml/fstar-lib/FStar_Reflection_Typing_Builtins.ml @@ -1,31 +1,31 @@ -open FStar_Syntax_Syntax -open FStar_Reflection_Types -module R = FStar_Compiler_Range +open FStarC_Syntax_Syntax +open FStarC_Reflection_Types +module R = FStarC_Compiler_Range let dummy_range = R.dummyRange -let underscore = FStar_Ident.mk_ident ("_", R.dummyRange) +let underscore = FStarC_Ident.mk_ident ("_", R.dummyRange) let int_as_bv (n:Prims.int) = { ppname = underscore; index = n; sort = tun} let open_term (t:term) (v:Prims.int) : term = let subst = DB (Z.zero, int_as_bv v) in - FStar_Syntax_Subst.subst [subst] t + FStarC_Syntax_Subst.subst [subst] t let close_term (t:term) (v:Prims.int) : term = let subst = NM (int_as_bv v, Z.zero) in - FStar_Syntax_Subst.subst [subst] t + FStarC_Syntax_Subst.subst [subst] t let open_with (t:term) (v:term) : term = let neg = int_as_bv (Z.of_int (-1)) in (* a temporary non-clashing name *) - let opened_t = FStar_Syntax_Subst.subst [DB(Z.zero, neg)] t in + let opened_t = FStarC_Syntax_Subst.subst [DB(Z.zero, neg)] t in (* gets substituted away immediately *) - FStar_Syntax_Subst.subst [NT(neg, v)] opened_t + FStarC_Syntax_Subst.subst [NT(neg, v)] opened_t let rename (t:term) (x:Prims.int) (y:Prims.int) : term - = FStar_Syntax_Subst.subst [NT(int_as_bv x, bv_to_name (int_as_bv y))] t + = FStarC_Syntax_Subst.subst [NT(int_as_bv x, bv_to_name (int_as_bv y))] t diff --git a/ocaml/fstar-lib/FStar_Sedlexing.ml b/ocaml/fstar-lib/FStar_Sedlexing.ml deleted file mode 100644 index 0c1e6baa1f2..00000000000 --- a/ocaml/fstar-lib/FStar_Sedlexing.ml +++ /dev/null @@ -1,126 +0,0 @@ -(** -A custom version of Sedlexing enhanced with -lc, bol and fname position tracking and -specialized for UTF-8 string inputs -(the parser driver always reads whole files) -**) - -exception Error - -module L = Lexing -type pos = L.position - -type lexbuf = { - buf: int array; - len: int; - - mutable cur: int; - mutable cur_p: pos; - mutable start: int; - mutable start_p: pos; - - mutable mark: int; - mutable mark_p: pos; - mutable mark_val: int; -} - -let get_buf lb = lb.buf -let get_cur lb = lb.cur -let get_start lb = lb.start - -(* N.B. the offsets are for interactive mode - we want to ble able to interpret a fragment as if it was part - of a larger file and report absolute error positions *) -let create (s:string) fn loffset coffset = - let a = FStar_Parser_Utf8.to_int_array s 0 (String.length s) in - let start_p = { - L.pos_fname = fn; - L.pos_cnum = coffset; - L.pos_bol = 0; - L.pos_lnum = loffset; } - in { - buf = a; - len = Array.length a; - - cur = 0; - cur_p = start_p; - - start = 0; - start_p = start_p; - - mark = 0; - mark_p = start_p; - mark_val = 0; - } - -let current_pos b = b.cur_p - -let start b = - b.mark <- b.cur; - b.mark_val <- (-1); - b.mark_p <- b.cur_p; - b.start <- b.cur; - b.start_p <- b.cur_p - -let mark b i = - b.mark <- b.cur; - b.mark_p <- b.cur_p; - b.mark_val <- i - -let backtrack b = - b.cur <- b.mark; - b.cur_p <- b.mark_p; - b.mark_val - -type snap = int * pos - -let snapshot b = b.start, b.start_p -let restore_snapshot b (cur, cur_p) = - b.cur <- cur; - b.cur_p <- cur_p - -let next b = - if b.cur = b.len then None - else - let c = b.buf.(b.cur) in - (b.cur <- b.cur + 1; - b.cur_p <- {b.cur_p with L.pos_cnum = b.cur_p.L.pos_cnum + 1}; Some (Uchar.of_int c)) - -let new_line b = - b.cur_p <- { b.cur_p with - L.pos_lnum = b.cur_p.L.pos_lnum + 1; - L.pos_bol = b.cur_p.L.pos_cnum; - } - -let range b = (b.start_p, b.cur_p) - -let ulexeme lexbuf = - Array.sub lexbuf.buf lexbuf.start (lexbuf.cur - lexbuf.start) - -let rollback b = - b.cur <- b.start; - b.cur_p <- b.start_p - -let lexeme lexbuf = - FStar_Parser_Utf8.from_int_array lexbuf.buf lexbuf.start (lexbuf.cur - lexbuf.start) - -let lookahead b pos = - if b.len <= pos then "" - else FStar_Parser_Utf8.from_int_array b.buf pos (b.len - pos) - -let source_file b = - b.cur_p.L.pos_fname - -let current_line b = - b.cur_p.Lexing.pos_lnum - -(* Since sedlex 2.4, we need to expose Sedlexing.__private_next_int - (see #2343) - - From https://github.com/ocaml-communi-ty/sedlex/blob/268c553f474457574e22701679d68f66aa771551/src/lib/sedlexing.mli#L154-L161 - [next] and [__private__next_int] have the same doc description, - the only difference is the return type *) -let __private__next_int b = - match next b with - | Some v -> Uchar.to_int v - | None -> -1 diff --git a/ocaml/fstar-lib/FStar_StringBuffer.ml b/ocaml/fstar-lib/FStar_StringBuffer.ml deleted file mode 100644 index 895b14ea975..00000000000 --- a/ocaml/fstar-lib/FStar_StringBuffer.ml +++ /dev/null @@ -1,7 +0,0 @@ -(* See FStar.StringBuffer.fsi *) -type t = Buffer.t -let create (i:FStar_BigInt.t) = Buffer.create (FStar_BigInt.to_int i) -let add s t = Buffer.add_string t s; t -let contents = Buffer.contents -let clear t = Buffer.clear t; t -let output_channel = Buffer.output_buffer diff --git a/ocaml/fstar-lib/FStar_Syntax_TermHashTable.ml b/ocaml/fstar-lib/FStar_Syntax_TermHashTable.ml deleted file mode 100644 index 5425f08f488..00000000000 --- a/ocaml/fstar-lib/FStar_Syntax_TermHashTable.ml +++ /dev/null @@ -1,73 +0,0 @@ -module S = FStar_Syntax_Syntax -module P = FStar_Profiling -module BU = FStar_Compiler_Util -let now () = BatUnix.gettimeofday () -let record_time f = - let start = now () in - let res = f () in - let elapsed = (now()) -. start in - res, int_of_float (elapsed *. 1000.0) -let eq_term_ctr = ref (0, 0) -let num_eq_term_calls = ref (0, 0) -let incr (r:(int * int) ref) (time:int) = let n, t = !r in r := (n + 1, time + t) -module HashKey = - struct - type t = S.term - let equal (x:t) (y:t) = FStar_Syntax_Hash.equal_term x y -(* This function is often hot. Its useful to enable the profiling code when debugging - P.profile (fun _ -> - let res, time = record_time (fun _ -> FStar_Syntax_Hash.equal_term x y) in - incr num_eq_term_calls time; - if res - then ( incr eq_term_ctr time; true ) - else ( false)) - None - "FStar.Syntax.TermHashTable.equal" -*) - let hash (x:t) = FStar_Syntax_Hash.ext_hash_term x -(* P.profile (fun _ -> - None - "FStar.Syntax.TermHashTable.hash" -*) - end -module HT = BatHashtbl.Make(HashKey) - -type 'a hashtable = 'a HT.t - -let create (n:Z.t) = HT.create (Z.to_int n) -module Print = FStar_Syntax_Print - -let insert (key: S.term) (v:'a) (ht:'a hashtable) = HT.add ht key v - -let lookup (key: S.term) (ht:'a hashtable) : 'a option = - try - let l = HT.find ht key in - Some l - with - | Not_found -> None - -let reset_counters (x:'a hashtable) = - eq_term_ctr := (0,0); - num_eq_term_calls := (0,0) - -let clear (x:'a hashtable) = - HT.clear x; - reset_counters x - -let print_stats (x:'a hashtable) : unit = - let stats = HT.stats x in - let string_of_ctr ctr = let n, t = !ctr in BU.format2 "%s in %s ms" (string_of_int n) (string_of_int t) in - BU.print4 "THT Statistics { num_bindings = %s; max_bucket_length = %s; num_eq_term_calls = %s; eq_term_ctr = %s }\n" - (string_of_int stats.num_bindings) - (string_of_int stats.max_bucket_length) - (string_of_ctr num_eq_term_calls) - (string_of_ctr eq_term_ctr) - -(* Histogram - (BatString.concat "; " - (List.map (function Some x -> x) - (List.filter - (function None -> false | _ -> true) - (Array.to_list ( - (Array.mapi (fun i n -> if n = 0 then None else Some ("(" ^ (string_of_int i) ^", "^ (string_of_int n)^ ")")) stats.bucket_histogram)))))) -*) diff --git a/ocaml/fstar-lib/FStar_Tactics_Native.ml b/ocaml/fstar-lib/FStar_Tactics_Native.ml deleted file mode 100644 index df1cc6729e1..00000000000 --- a/ocaml/fstar-lib/FStar_Tactics_Native.ml +++ /dev/null @@ -1,102 +0,0 @@ -open FStar_Compiler_Range -open FStar_Tactics_Types -open FStar_Tactics_Result -open FStar_Tactics_Monad -open FStar_Syntax_Syntax - -module N = FStar_TypeChecker_Normalize -module C = FStar_TypeChecker_Cfg -module BU = FStar_Compiler_Util -module NBETerm = FStar_TypeChecker_NBETerm -module O = FStar_Options -module PO = FStar_TypeChecker_Primops -module POB = FStar_TypeChecker_Primops_Base - -(* These definitions are ≡ to the ones generated by F*'s extraction of the - tactic effect. We need them here to break a circular dependency between the - compiler and ulib (cf. tactics meeting of 2017-08-03). *) -type 'a __tac = FStar_Tactics_Types.proofstate -> 'a __result - -let r = dummyRange - -type itac = - POB.psc -> FStar_Syntax_Embeddings_Base.norm_cb -> universes -> args -> term option -type nbe_itac = - NBETerm.nbe_cbs -> universes -> NBETerm.args -> NBETerm.t option - -type native_primitive_step = - { name: FStar_Ident.lid; - arity: Prims.int; - strong_reduction_ok: bool; - tactic: itac} - -let perr s = if FStar_Compiler_Debug.any () then BU.print_error s -let perr1 s x = if FStar_Compiler_Debug.any () then BU.print1_error s x - -let compiled_tactics: native_primitive_step list ref = ref [] - -let list_all () = - if FStar_Options.no_plugins () - then [] - else !compiled_tactics - -let register_plugin (s: string) (arity: Prims.int) (t: itac) (n:nbe_itac) = - let step = - { POB.name=FStar_Ident.lid_of_str s; - POB.arity=arity; - POB.auto_reflect=None; - POB.strong_reduction_ok=true; - POB.requires_binder_substitution = false; - POB.renorm_after = false; - POB.interpretation=t; - POB.univ_arity=Z.of_int 0; - POB.interpretation_nbe=n; - } - in - FStar_TypeChecker_Cfg.register_plugin step; - (* perr1 "Registered plugin %s\n" s; *) - () - -let register_tactic (s: string) (arity: Prims.int) (t: itac)= - let step = - { name=FStar_Ident.lid_of_str s; - arity = arity; - strong_reduction_ok=true; - tactic=t } in - compiled_tactics := step :: !compiled_tactics; - (* perr1 "Registered tactic %s\n" s; *) - () - -let bump (f : 'b -> 'c) (g : 'a -> 'b) : 'a -> 'c = - fun x -> f (g x) - -let from_tactic_0 (tau: 'b __tac) : 'b tac = - (fun (ps: proofstate) -> - (* perr "Entering native tactic\n"; *) - tau ps) |> mk_tac - -let from_tactic_1 t = bump from_tactic_0 t -let from_tactic_2 t = bump from_tactic_1 t -let from_tactic_3 t = bump from_tactic_2 t -let from_tactic_4 t = bump from_tactic_3 t -let from_tactic_5 t = bump from_tactic_4 t -let from_tactic_6 t = bump from_tactic_5 t -let from_tactic_7 t = bump from_tactic_6 t -let from_tactic_8 t = bump from_tactic_7 t -let from_tactic_9 t = bump from_tactic_8 t -let from_tactic_10 t = bump from_tactic_9 t -let from_tactic_11 t = bump from_tactic_10 t -let from_tactic_12 t = bump from_tactic_11 t -let from_tactic_13 t = bump from_tactic_12 t -let from_tactic_14 t = bump from_tactic_13 t -let from_tactic_15 t = bump from_tactic_14 t -let from_tactic_16 t = bump from_tactic_15 t -let from_tactic_17 t = bump from_tactic_16 t -let from_tactic_18 t = bump from_tactic_17 t -let from_tactic_19 t = bump from_tactic_18 t -let from_tactic_20 t = bump from_tactic_19 t -let from_tactic_21 t = bump from_tactic_20 t -let from_tactic_22 t = bump from_tactic_21 t -let from_tactic_23 t = bump from_tactic_22 t -let from_tactic_24 t = bump from_tactic_23 t -let from_tactic_25 t = bump from_tactic_24 t diff --git a/ocaml/fstar-lib/FStar_Tactics_V1_Builtins.ml b/ocaml/fstar-lib/FStar_Tactics_V1_Builtins.ml deleted file mode 100644 index f326735c12b..00000000000 --- a/ocaml/fstar-lib/FStar_Tactics_V1_Builtins.ml +++ /dev/null @@ -1,144 +0,0 @@ -open Prims -open FStar_Pervasives_Native -open FStar_Pervasives -open FStar_Tactics_Result -open FStar_Tactics_Types -open FStar_Tactics_Effect - -module N = FStar_TypeChecker_Normalize -module E = FStar_Tactics_Effect -module B = FStar_Tactics_V1_Basic -module TM = FStar_Tactics_Monad -module CTRW = FStar_Tactics_CtrlRewrite -module RT = FStar_Reflection_Types -module RD = FStar_Reflection_V1_Data -module EMB = FStar_Syntax_Embeddings -module EMBBase = FStar_Syntax_Embeddings_Base -module NBET = FStar_TypeChecker_NBETerm - -type 'a __tac = ('a, unit) E.tac_repr - -let interpret_tac (t: 'a TM.tac) (ps: proofstate): 'a __result = - TM.run t ps - -let uninterpret_tac (t: 'a __tac) (ps: proofstate): 'a __result = - t ps - -let to_tac_0 (t: 'a __tac): 'a TM.tac = - (fun (ps: proofstate) -> - uninterpret_tac t ps) |> TM.mk_tac - -let to_tac_1 (t: 'b -> 'a __tac): 'b -> 'a TM.tac = fun x -> - (fun (ps: proofstate) -> - uninterpret_tac (t x) ps) |> TM.mk_tac - -let from_tac_1 (t: 'a -> 'b TM.tac): 'a -> 'b __tac = - fun (x: 'a) -> - fun (ps: proofstate) -> - let m = t x in - interpret_tac m ps - -let from_tac_2 (t: 'a -> 'b -> 'c TM.tac): 'a -> 'b -> 'c __tac = - fun (x: 'a) -> - fun (y: 'b) -> - fun (ps: proofstate) -> - let m = t x y in - interpret_tac m ps - -let from_tac_3 (t: 'a -> 'b -> 'c -> 'd TM.tac): 'a -> 'b -> 'c -> 'd __tac = - fun (x: 'a) -> - fun (y: 'b) -> - fun (z: 'c) -> - fun (ps: proofstate) -> - let m = t x y z in - interpret_tac m ps - -let from_tac_4 (t: 'a -> 'b -> 'c -> 'd -> 'e TM.tac): 'a -> 'b -> 'c -> 'd -> 'e __tac = - fun (x: 'a) -> - fun (y: 'b) -> - fun (z: 'c) -> - fun (w: 'd) -> - fun (ps: proofstate) -> - let m = t x y z w in - interpret_tac m ps - -(* Pointing to the internal primitives *) -let set_goals = from_tac_1 TM.set_goals -let set_smt_goals = from_tac_1 TM.set_smt_goals -let top_env = from_tac_1 B.top_env -let fresh = from_tac_1 B.fresh -let refine_intro = from_tac_1 B.refine_intro -let tc = from_tac_2 B.tc -let tcc = from_tac_2 B.tcc -let unshelve = from_tac_1 B.unshelve -let unquote = fun t -> failwith "Sorry, unquote does not work in compiled tactics" -let norm = fun s -> from_tac_1 B.norm s -let norm_term_env = fun e s -> from_tac_3 B.norm_term_env e s -let norm_binder_type = fun s -> from_tac_2 B.norm_binder_type s -let intro = from_tac_1 B.intro -let intro_rec = from_tac_1 B.intro_rec -let rename_to = from_tac_2 B.rename_to -let revert = from_tac_1 B.revert -let binder_retype = from_tac_1 B.binder_retype -let clear_top = from_tac_1 B.clear_top -let clear = from_tac_1 B.clear -let rewrite = from_tac_1 B.rewrite -let t_exact = from_tac_3 B.t_exact -let t_apply = from_tac_4 B.t_apply -let t_apply_lemma = from_tac_3 B.t_apply_lemma -let print = from_tac_1 B.print -let debugging = from_tac_1 B.debugging -let dump = from_tac_1 B.dump -let dump_all = from_tac_2 B.dump_all -let dump_uvars_of = from_tac_2 B.dump_uvars_of -let t_trefl = from_tac_1 B.t_trefl -let dup = from_tac_1 B.dup -let prune = from_tac_1 B.prune -let addns = from_tac_1 B.addns -let t_destruct = from_tac_1 B.t_destruct -let set_options = from_tac_1 B.set_options -let uvar_env = from_tac_2 B.uvar_env -let ghost_uvar_env = from_tac_2 B.ghost_uvar_env -let unify_env = from_tac_3 B.unify_env -let unify_guard_env = from_tac_3 B.unify_guard_env -let match_env = from_tac_3 B.match_env -let launch_process = from_tac_3 B.launch_process -let fresh_bv_named = from_tac_1 B.fresh_bv_named -let change = from_tac_1 B.change -let get_guard_policy = from_tac_1 B.get_guard_policy -let set_guard_policy = from_tac_1 B.set_guard_policy -let lax_on = from_tac_1 B.lax_on -let tadmit_t = from_tac_1 B.tadmit_t -let join = from_tac_1 B.join -let inspect = from_tac_1 B.inspect -let pack = from_tac_1 B.pack -let pack_curried = from_tac_1 B.pack_curried -let curms = from_tac_1 B.curms -let set_urgency = from_tac_1 B.set_urgency -let t_commute_applied_match = from_tac_1 B.t_commute_applied_match -let gather_or_solve_explicit_guards_for_resolved_goals = from_tac_1 B.gather_explicit_guards_for_resolved_goals -let string_to_term = from_tac_2 B.string_to_term -let push_bv_dsenv = from_tac_2 B.push_bv_dsenv -let term_to_string = from_tac_1 B.term_to_string -let comp_to_string = from_tac_1 B.comp_to_string -let range_to_string = from_tac_1 B.range_to_string -let term_eq_old = from_tac_2 B.term_eq_old - -let with_compat_pre_core (n:Prims.int) (f: unit -> 'a __tac) : 'a __tac = - from_tac_2 B.with_compat_pre_core n (to_tac_0 (f ())) - -let get_vconfig = from_tac_1 B.get_vconfig -let set_vconfig = from_tac_1 B.set_vconfig -let t_smt_sync = from_tac_1 B.t_smt_sync -let free_uvars = from_tac_1 B.free_uvars - -(* The handlers need to "embed" their argument. *) -let catch (t: unit -> 'a __tac): ((exn, 'a) either) __tac = from_tac_1 TM.catch (to_tac_0 (t ())) -let recover (t: unit -> 'a __tac): ((exn, 'a) either) __tac = from_tac_1 TM.recover (to_tac_0 (t ())) - -let ctrl_rewrite - (d : direction) - (t1 : RT.term -> (bool * ctrl_flag) __tac) - (t2 : unit -> unit __tac) - : unit __tac - = from_tac_3 CTRW.ctrl_rewrite d (to_tac_1 t1) (to_tac_0 (t2 ())) diff --git a/ocaml/fstar-lib/FStar_Tactics_V2_Builtins.ml b/ocaml/fstar-lib/FStar_Tactics_V2_Builtins.ml deleted file mode 100644 index d00dc177d17..00000000000 --- a/ocaml/fstar-lib/FStar_Tactics_V2_Builtins.ml +++ /dev/null @@ -1,183 +0,0 @@ -open Prims -open FStar_Pervasives_Native -open FStar_Pervasives -open FStar_Tactics_Result -open FStar_Tactics_Types -open FStar_Tactics_Effect - -module N = FStar_TypeChecker_Normalize -module E = FStar_Tactics_Effect -module B = FStar_Tactics_V2_Basic -module TM = FStar_Tactics_Monad -module CTRW = FStar_Tactics_CtrlRewrite -module RT = FStar_Reflection_Types -module RD = FStar_Reflection_Data -module EMB = FStar_Syntax_Embeddings -module EMB_Base = FStar_Syntax_Embeddings_Base -module NBET = FStar_TypeChecker_NBETerm - -type 'a __tac = ('a, unit) E.tac_repr - -let interpret_tac (s:string) (t: 'a TM.tac) (ps: proofstate): 'a __result = - FStar_Errors.with_ctx - ("While running primitive " ^ s ^ " (called from within a plugin)") - (fun () -> TM.run t ps) - -let uninterpret_tac (t: 'a __tac) (ps: proofstate): 'a __result = - t ps - -let to_tac_0 (t: 'a __tac): 'a TM.tac = - (fun (ps: proofstate) -> - uninterpret_tac t ps) |> TM.mk_tac - -let to_tac_1 (t: 'b -> 'a __tac): 'b -> 'a TM.tac = fun x -> - (fun (ps: proofstate) -> - uninterpret_tac (t x) ps) |> TM.mk_tac - -let from_tac_1 s (t: 'a -> 'r TM.tac): 'a -> 'r __tac = - fun (xa: 'a) (ps : proofstate) -> - let m = t xa in - interpret_tac s m ps - -let from_tac_2 s (t: 'a -> 'b -> 'r TM.tac): 'a -> 'b -> 'r __tac = - fun (xa: 'a) (xb: 'b) (ps : proofstate) -> - let m = t xa xb in - interpret_tac s m ps - -let from_tac_3 s (t: 'a -> 'b -> 'c -> 'r TM.tac): 'a -> 'b -> 'c -> 'r __tac = - fun (xa: 'a) (xb: 'b) (xc: 'c) (ps : proofstate) -> - let m = t xa xb xc in - interpret_tac s m ps - -let from_tac_4 s (t: 'a -> 'b -> 'c -> 'd -> 'r TM.tac): 'a -> 'b -> 'c -> 'd -> 'r __tac = - fun (xa: 'a) (xb: 'b) (xc: 'c) (xd: 'd) (ps : proofstate) -> - let m = t xa xb xc xd in - interpret_tac s m ps - -let from_tac_5 s (t: 'a -> 'b -> 'c -> 'd -> 'e -> 'r TM.tac): 'a -> 'b -> 'c -> 'd -> 'e -> 'r __tac = - fun (xa: 'a) (xb: 'b) (xc: 'c) (xd: 'd) (xe: 'e) (ps : proofstate) -> - let m = t xa xb xc xd xe in - interpret_tac s m ps - - -(* Pointing to the internal primitives *) -let compress = from_tac_1 "B.compress" B.compress -let set_goals = from_tac_1 "TM.set_goals" TM.set_goals -let set_smt_goals = from_tac_1 "TM.set_smt_goals" TM.set_smt_goals -let top_env = from_tac_1 "B.top_env" B.top_env -let fresh = from_tac_1 "B.fresh" B.fresh -let refine_intro = from_tac_1 "B.refine_intro" B.refine_intro -let tc = from_tac_2 "B.tc" B.tc -let tcc = from_tac_2 "B.tcc" B.tcc -let unshelve = from_tac_1 "B.unshelve" B.unshelve -let unquote = fun t -> failwith "Sorry, unquote does not work in compiled tactics" -let norm = fun s -> from_tac_1 "B.norm" B.norm s -let norm_term_env = fun e s -> from_tac_3 "B.norm_term_env" B.norm_term_env e s -let norm_binding_type = fun s -> from_tac_2 "B.norm_binding_type" B.norm_binding_type s -let intro = from_tac_1 "B.intro" B.intro -let intros = from_tac_1 "B.intros" B.intros -let intro_rec = from_tac_1 "B.intro_rec" B.intro_rec -let rename_to = from_tac_2 "B.rename_to" B.rename_to -let revert = from_tac_1 "B.revert" B.revert -let var_retype = from_tac_1 "B.var_retype" B.var_retype -let clear_top = from_tac_1 "B.clear_top" B.clear_top -let clear = from_tac_1 "B.clear" B.clear -let rewrite = from_tac_1 "B.rewrite" B.rewrite -let grewrite = from_tac_2 "B.grewrite" B.grewrite -let t_exact = from_tac_3 "B.t_exact" B.t_exact -let t_apply = from_tac_4 "B.t_apply" B.t_apply -let t_apply_lemma = from_tac_3 "B.t_apply_lemma" B.t_apply_lemma -let print = from_tac_1 "B.print" B.print -let debugging = from_tac_1 "B.debugging" B.debugging -let ide = from_tac_1 "B.ide" B.ide -let dump = from_tac_1 "B.dump" B.dump -let dump_all = from_tac_2 "B.dump_all" B.dump_all -let dump_uvars_of = from_tac_2 "B.dump_uvars_of" B.dump_uvars_of -let t_trefl = from_tac_1 "B.t_trefl" B.t_trefl -let dup = from_tac_1 "B.dup" B.dup -let prune = from_tac_1 "B.prune" B.prune -let addns = from_tac_1 "B.addns" B.addns -let t_destruct = from_tac_1 "B.t_destruct" B.t_destruct -let set_options = from_tac_1 "B.set_options" B.set_options -let uvar_env = from_tac_2 "B.uvar_env" B.uvar_env -let ghost_uvar_env = from_tac_2 "B.ghost_uvar_env" B.ghost_uvar_env -let unify_env = from_tac_3 "B.unify_env" B.unify_env -let unify_guard_env = from_tac_3 "B.unify_guard_env" B.unify_guard_env -let match_env = from_tac_3 "B.match_env" B.match_env -let launch_process = from_tac_3 "B.launch_process" B.launch_process -let fresh_bv_named = from_tac_1 "B.fresh_bv_named" B.fresh_bv_named -let change = from_tac_1 "B.change" B.change -let get_guard_policy = from_tac_1 "B.get_guard_policy" B.get_guard_policy -let set_guard_policy = from_tac_1 "B.set_guard_policy" B.set_guard_policy -let lax_on = from_tac_1 "B.lax_on" B.lax_on -let tadmit_t = from_tac_1 "B.tadmit_t" B.tadmit_t -let join = from_tac_1 "B.join" B.join -let curms = from_tac_1 "B.curms" B.curms -let set_urgency = from_tac_1 "B.set_urgency" B.set_urgency -let set_dump_on_failure = from_tac_1 "B.set_dump_on_failure" B.set_dump_on_failure -let t_commute_applied_match = from_tac_1 "B.t_commute_applied_match" B.t_commute_applied_match -let gather_or_solve_explicit_guards_for_resolved_goals = from_tac_1 "B.gather_explicit_guards_for_resolved_goals" B.gather_explicit_guards_for_resolved_goals -let string_to_term = from_tac_2 "B.string_to_term" B.string_to_term -let push_bv_dsenv = from_tac_2 "B.push_bv_dsenv" B.push_bv_dsenv -let term_to_string = from_tac_1 "B.term_to_string" B.term_to_string -let comp_to_string = from_tac_1 "B.comp_to_string" B.comp_to_string -let term_to_doc = from_tac_1 "B.term_to_doc" B.term_to_doc -let comp_to_doc = from_tac_1 "B.comp_to_doc" B.comp_to_doc -let range_to_string = from_tac_1 "B.range_to_string" B.range_to_string -let term_eq_old = from_tac_2 "B.term_eq_old" B.term_eq_old - -let with_compat_pre_core (n:Prims.int) (f: unit -> 'a __tac) : 'a __tac = - from_tac_2 "B.with_compat_pre_core" B.with_compat_pre_core n (to_tac_0 (f ())) - -let get_vconfig = from_tac_1 "B.get_vconfig" B.get_vconfig -let set_vconfig = from_tac_1 "B.set_vconfig" B.set_vconfig -let t_smt_sync = from_tac_1 "B.t_smt_sync" B.t_smt_sync -let free_uvars = from_tac_1 "B.free_uvars" B.free_uvars -let all_ext_options = from_tac_1 "B.all_ext_options" B.all_ext_options -let ext_getv = from_tac_1 "B.ext_getv" B.ext_getv -let ext_getns = from_tac_1 "B.ext_getns" B.ext_getns - -let alloc x = from_tac_1 "B.alloc" B.alloc x -let read r = from_tac_1 "B.read" B.read r -let write r x = from_tac_2 "B.write" B.write r x - -type ('env, 't) prop_validity_token = unit -type ('env, 'sc, 't, 'pats, 'bnds) match_complete_token = unit - -let is_non_informative = from_tac_2 "B.refl_is_non_informative" B.refl_is_non_informative -let check_subtyping = from_tac_3 "B.refl_check_subtyping" B.refl_check_subtyping -let t_check_equiv = from_tac_5 "B.t_refl_check_equiv" B.t_refl_check_equiv -let core_compute_term_type = from_tac_2 "B.refl_core_compute_term_type" B.refl_core_compute_term_type -let core_check_term = from_tac_4 "B.refl_core_check_term" B.refl_core_check_term -let core_check_term_at_type = from_tac_3 "B.refl_core_check_term_at_type" B.refl_core_check_term_at_type -let check_match_complete = from_tac_4 "B.refl_check_match_complete" B.refl_check_match_complete -let tc_term = from_tac_2 "B.refl_tc_term" B.refl_tc_term -let universe_of = from_tac_2 "B.refl_universe_of" B.refl_universe_of -let check_prop_validity = from_tac_2 "B.refl_check_prop_validity" B.refl_check_prop_validity -let instantiate_implicits = from_tac_3 "B.refl_instantiate_implicits" B.refl_instantiate_implicits -let try_unify = from_tac_4 "B.refl_try_unify" B.refl_try_unify -let maybe_relate_after_unfolding = from_tac_3 "B.refl_maybe_relate_after_unfolding" B.refl_maybe_relate_after_unfolding -let maybe_unfold_head = from_tac_2 "B.refl_maybe_unfold_head" B.refl_maybe_unfold_head -let norm_well_typed_term = from_tac_3 "B.norm_well_typed_term" B.refl_norm_well_typed_term - -let push_open_namespace = from_tac_2 "B.push_open_namespace" B.push_open_namespace -let push_module_abbrev = from_tac_3 "B.push_module_abbrev" B.push_module_abbrev -let resolve_name = from_tac_2 "B.resolve_name" B.resolve_name -let log_issues = from_tac_1 "B.log_issues" B.log_issues - -(* The handlers need to "embed" their argument. *) -let catch (t: unit -> 'a __tac): ((exn, 'a) either) __tac = from_tac_1 "TM.catch" TM.catch (to_tac_0 (t ())) -let recover (t: unit -> 'a __tac): ((exn, 'a) either) __tac = from_tac_1 "TM.recover" TM.recover (to_tac_0 (t ())) - -let ctrl_rewrite - (d : direction) - (t1 : RT.term -> (bool * ctrl_flag) __tac) - (t2 : unit -> unit __tac) - : unit __tac - = from_tac_3 "ctrl_rewrite" CTRW.ctrl_rewrite d (to_tac_1 t1) (to_tac_0 (t2 ())) - -let call_subtac g (t : unit -> unit __tac) u ty = - let t = to_tac_1 t () in - from_tac_4 "B.call_subtac" B.call_subtac g t u ty - -let call_subtac_tm = from_tac_4 "B.call_subtac_tm" B.call_subtac_tm diff --git a/ocaml/fstar-lib/FStar_Unionfind.ml b/ocaml/fstar-lib/FStar_Unionfind.ml deleted file mode 100644 index 3b451d1fa28..00000000000 --- a/ocaml/fstar-lib/FStar_Unionfind.ml +++ /dev/null @@ -1,161 +0,0 @@ -(* Persistent union-find implementation adapted from - https://www.lri.fr/~filliatr/puf/ *) - -open FStar_Compiler_Effect -open FStar_Compiler_Util - -(* Persistent arrays *) -type 'a pa_t = 'a data ref -and 'a data = - | PArray of 'a array - | PDiff of int * 'a * 'a pa_t - -let pa_create n v = mk_ref (PArray (Array.make n v)) - -let pa_init n f = mk_ref (PArray (Array.init n f)) - -let rec pa_rerootk t k = match !t with - | PArray _ -> k () - | PDiff (i, v, t') -> - pa_rerootk t' (fun () -> begin match !t' with - | PArray a -> - let v' = a.(i) in - a.(i) <- v; - t := PArray a; - t' := PDiff (i, v', t) - | PDiff _ -> failwith "Impossible" end; k()) - -let pa_reroot t = pa_rerootk t (fun () -> ()) - -let pa_get t i = match !t with - | PArray a -> a.(i) - | PDiff _ -> - pa_reroot t; - begin match !t with - | PArray a -> a.(i) - | PDiff _ -> failwith "Impossible" end - -let pa_set (t: 'a pa_t) (i: int) (v: 'a): 'a pa_t = - pa_reroot t; - match !t with - | PArray a -> - let old = a.(i) in - a.(i) <- v; - let res = mk_ref (PArray a) in - t := PDiff (i, old, res); - res - | PDiff _ -> failwith "Impossible" - -(* apply impure function from Array to a persistent array *) -let impure f t = - pa_reroot t; - match !t with PArray a -> f a | PDiff _ -> failwith "Impossible" - -let pa_length t = impure Array.length t - -(* double the array whenever its bounds are reached *) -let pa_new t x l empty = - pa_reroot t; - match !t with - | PArray a -> - if (pa_length t == l) then begin - let arr_tail = Array.make l empty in - arr_tail.(0) <- x; - t := PArray (Array.append a arr_tail) - end else - a.(l) <- x - | PDiff _ -> failwith "Impossible" - - -(* Union-find implementation based on persistent arrays *) -type 'a puf = { - (* array of parents of each node - contains either path or root element *) - mutable parent: (int, 'a) FStar_Pervasives.either pa_t; (* mutable to allow path compression *) - ranks: int pa_t; - (* keep track of how many elements are allocated in the array *) - count: int ref -} -type 'a p_uvar = P of int - [@printer fun fmt x -> Format.pp_print_string fmt "!!!"] - [@@deriving yojson,show] - (* failwith "cannot pretty-print a unification variable" *) - -let puf_empty () = - { parent = pa_create 2 (FStar_Pervasives.Inl (-1)) ; - ranks = pa_create 2 0; - count = mk_ref 0 } - -let puf_fresh (h: 'a puf) (x: 'a): 'a p_uvar = - let count = !(h.count) in - pa_new h.parent (FStar_Pervasives.Inr x) count (FStar_Pervasives.Inl (-1)); - pa_new h.ranks 0 count 0; - h.count := count + 1; - P count - -(* implements path compression, returns new array *) -let rec puf_find_aux f i = - match (pa_get f i) with - | FStar_Pervasives.Inl fi -> - let f, r, id = puf_find_aux f fi in - let f = pa_set f i (FStar_Pervasives.Inl id) in - f, r, id - | FStar_Pervasives.Inr x -> f, FStar_Pervasives.Inr x, i - -(* return both rep and previous version of parent array *) -let puf_find_i (h: 'a puf) (x: 'a p_uvar) = - let x = match x with | P a -> a in - let f, rx, i = puf_find_aux h.parent x in - h.parent <- f; - match rx with - | FStar_Pervasives.Inr r -> r, i - | FStar_Pervasives.Inl _ -> failwith "Impossible" - -(* only return the equivalence class *) -let puf_id' (h:'a puf) (x:'a p_uvar) : int = - let _, i = puf_find_i h x in - i - -let puf_id (h: 'a puf) (x: 'a p_uvar): Prims.int = - Z.of_int (puf_id' h x) - -let puf_unique_id (x: 'a p_uvar): Prims.int = - match x with - | P a -> Z.of_int a - -let puf_fromid (_:'a puf) (id : Prims.int) : 'a p_uvar = - P (Z.to_int id) - -(* only return the rep *) -let puf_find (h: 'a puf) (x: 'a p_uvar) = - let v, _ = puf_find_i h x in - v - -let puf_equivalent (h:'a puf) (x:'a p_uvar) (y:'a p_uvar) = - (puf_id' h x) = (puf_id' h y) - -let puf_change (h:'a puf) (x:'a p_uvar) (v:'a) : 'a puf = - let i = puf_id' h x in - let hp = pa_set h.parent i (FStar_Pervasives.Inr v) in - { h with parent = hp} - -let puf_union (h: 'a puf) (x: 'a p_uvar) (y: 'a p_uvar) = - let ix = puf_id' h x in - let iy = puf_id' h y in - if ix!=iy then begin - let rxc = pa_get h.ranks ix in - let ryc = pa_get h.ranks iy in - if rxc > ryc then - { parent = pa_set h.parent iy (FStar_Pervasives.Inl ix); - ranks = h.ranks; - count = h.count} - else if rxc < ryc then - { parent = pa_set h.parent ix (FStar_Pervasives.Inl iy); - ranks = h.ranks; - count = h.count} - else - { parent = pa_set h.parent iy (FStar_Pervasives.Inl ix); - ranks = pa_set h.ranks ix (rxc+1); - count = h.count } - end else - h diff --git a/ocaml/fstar-lib/dune b/ocaml/fstar-lib/dune index 5b0ce9311f2..0cdcbcb2982 100644 --- a/ocaml/fstar-lib/dune +++ b/ocaml/fstar-lib/dune @@ -25,15 +25,15 @@ ) (menhir - (modules FStar_Parser_Parse)) + (modules FStarC_Parser_Parse)) (rule - (target FStar_Version.ml) + (target FStarC_Version.ml) (deps (:script make_fstar_version.sh) (:version ../../version.txt)) (action (progn (copy %{version} version.txt) (with-stdout-to - FStar_Version.ml + FStarC_Version.ml (run bash %{script}))))) diff --git a/ocaml/fstar-lib/generated/FStarC_Basefiles.ml b/ocaml/fstar-lib/generated/FStarC_Basefiles.ml new file mode 100644 index 00000000000..489f17db22d --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Basefiles.ml @@ -0,0 +1,35 @@ +open Prims +let (must_find : Prims.string -> Prims.string) = + fun fn -> + let uu___ = FStarC_Find.find_file fn in + match uu___ with + | FStar_Pervasives_Native.Some f -> f + | FStar_Pervasives_Native.None -> + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Compiler_Util.format1 + "Unable to find required file \"%s\" in the module search path." + fn in + FStarC_Errors_Msg.text uu___3 in + [uu___2] in + FStarC_Errors.raise_error0 FStarC_Errors_Codes.Fatal_ModuleNotFound + () (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___1) +let (prims : unit -> Prims.string) = + fun uu___ -> + let uu___1 = FStarC_Options.custom_prims () in + match uu___1 with + | FStar_Pervasives_Native.Some fn -> fn + | FStar_Pervasives_Native.None -> must_find "Prims.fst" +let (prims_basename : unit -> Prims.string) = + fun uu___ -> let uu___1 = prims () in FStarC_Compiler_Util.basename uu___1 +let (pervasives : unit -> Prims.string) = + fun uu___ -> must_find "FStar.Pervasives.fsti" +let (pervasives_basename : unit -> Prims.string) = + fun uu___ -> + let uu___1 = pervasives () in FStarC_Compiler_Util.basename uu___1 +let (pervasives_native_basename : unit -> Prims.string) = + fun uu___ -> + let uu___1 = must_find "FStar.Pervasives.Native.fst" in + FStarC_Compiler_Util.basename uu___1 \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_CheckedFiles.ml b/ocaml/fstar-lib/generated/FStarC_CheckedFiles.ml new file mode 100644 index 00000000000..f233a7b6417 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_CheckedFiles.ml @@ -0,0 +1,614 @@ +open Prims +let (dbg : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "CheckedFiles" +let (cache_version_number : Prims.int) = (Prims.of_int (72)) +type tc_result = + { + checked_module: FStarC_Syntax_Syntax.modul ; + mii: FStarC_Syntax_DsEnv.module_inclusion_info ; + smt_decls: + (FStarC_SMTEncoding_Term.decls_t * FStarC_SMTEncoding_Env.fvar_binding + Prims.list) + ; + tc_time: Prims.int ; + extraction_time: Prims.int } +let (__proj__Mktc_result__item__checked_module : + tc_result -> FStarC_Syntax_Syntax.modul) = + fun projectee -> + match projectee with + | { checked_module; mii; smt_decls; tc_time; extraction_time;_} -> + checked_module +let (__proj__Mktc_result__item__mii : + tc_result -> FStarC_Syntax_DsEnv.module_inclusion_info) = + fun projectee -> + match projectee with + | { checked_module; mii; smt_decls; tc_time; extraction_time;_} -> mii +let (__proj__Mktc_result__item__smt_decls : + tc_result -> + (FStarC_SMTEncoding_Term.decls_t * FStarC_SMTEncoding_Env.fvar_binding + Prims.list)) + = + fun projectee -> + match projectee with + | { checked_module; mii; smt_decls; tc_time; extraction_time;_} -> + smt_decls +let (__proj__Mktc_result__item__tc_time : tc_result -> Prims.int) = + fun projectee -> + match projectee with + | { checked_module; mii; smt_decls; tc_time; extraction_time;_} -> + tc_time +let (__proj__Mktc_result__item__extraction_time : tc_result -> Prims.int) = + fun projectee -> + match projectee with + | { checked_module; mii; smt_decls; tc_time; extraction_time;_} -> + extraction_time +type checked_file_entry_stage1 = + { + version: Prims.int ; + digest: Prims.string ; + parsing_data: FStarC_Parser_Dep.parsing_data } +let (__proj__Mkchecked_file_entry_stage1__item__version : + checked_file_entry_stage1 -> Prims.int) = + fun projectee -> + match projectee with | { version; digest; parsing_data;_} -> version +let (__proj__Mkchecked_file_entry_stage1__item__digest : + checked_file_entry_stage1 -> Prims.string) = + fun projectee -> + match projectee with | { version; digest; parsing_data;_} -> digest +let (__proj__Mkchecked_file_entry_stage1__item__parsing_data : + checked_file_entry_stage1 -> FStarC_Parser_Dep.parsing_data) = + fun projectee -> + match projectee with | { version; digest; parsing_data;_} -> parsing_data +type checked_file_entry_stage2 = + { + deps_dig: (Prims.string * Prims.string) Prims.list ; + tc_res: tc_result } +let (__proj__Mkchecked_file_entry_stage2__item__deps_dig : + checked_file_entry_stage2 -> (Prims.string * Prims.string) Prims.list) = + fun projectee -> match projectee with | { deps_dig; tc_res;_} -> deps_dig +let (__proj__Mkchecked_file_entry_stage2__item__tc_res : + checked_file_entry_stage2 -> tc_result) = + fun projectee -> match projectee with | { deps_dig; tc_res;_} -> tc_res +type tc_result_t = + | Unknown + | Invalid of Prims.string + | Valid of Prims.string +let (uu___is_Unknown : tc_result_t -> Prims.bool) = + fun projectee -> match projectee with | Unknown -> true | uu___ -> false +let (uu___is_Invalid : tc_result_t -> Prims.bool) = + fun projectee -> match projectee with | Invalid _0 -> true | uu___ -> false +let (__proj__Invalid__item___0 : tc_result_t -> Prims.string) = + fun projectee -> match projectee with | Invalid _0 -> _0 +let (uu___is_Valid : tc_result_t -> Prims.bool) = + fun projectee -> match projectee with | Valid _0 -> true | uu___ -> false +let (__proj__Valid__item___0 : tc_result_t -> Prims.string) = + fun projectee -> match projectee with | Valid _0 -> _0 +let (uu___0 : tc_result_t FStarC_Class_Show.showable) = + { + FStarC_Class_Show.show = + (fun uu___ -> + match uu___ with + | Unknown -> "Unknown" + | Invalid s -> + let uu___1 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_string) s in + Prims.strcat "Invalid " uu___1 + | Valid s -> + let uu___1 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_string) s in + Prims.strcat "Valid " uu___1) + } +type cache_t = + (tc_result_t * (Prims.string, FStarC_Parser_Dep.parsing_data) + FStar_Pervasives.either) +let (mcache : cache_t FStarC_Compiler_Util.smap) = + FStarC_Compiler_Util.smap_create (Prims.of_int (50)) +let (hash_dependences : + FStarC_Parser_Dep.deps -> + Prims.string -> + (Prims.string, (Prims.string * Prims.string) Prims.list) + FStar_Pervasives.either) + = + fun deps -> + fun fn -> + let fn1 = + let uu___ = FStarC_Find.find_file fn in + match uu___ with + | FStar_Pervasives_Native.Some fn2 -> fn2 + | uu___1 -> fn in + let module_name = FStarC_Parser_Dep.lowercase_module_name fn1 in + let source_hash = FStarC_Compiler_Util.digest_of_file fn1 in + let has_interface = + let uu___ = FStarC_Parser_Dep.interface_of deps module_name in + FStarC_Compiler_Option.isSome uu___ in + let interface_checked_file_name = + let uu___ = + (FStarC_Parser_Dep.is_implementation fn1) && has_interface in + if uu___ + then + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Parser_Dep.interface_of deps module_name in + FStarC_Compiler_Util.must uu___3 in + FStarC_Parser_Dep.cache_file_name uu___2 in + FStar_Pervasives_Native.Some uu___1 + else FStar_Pervasives_Native.None in + let binary_deps = + let uu___ = FStarC_Parser_Dep.deps_of deps fn1 in + FStarC_Compiler_List.filter + (fun fn2 -> + let uu___1 = + (FStarC_Parser_Dep.is_interface fn2) && + (let uu___2 = FStarC_Parser_Dep.lowercase_module_name fn2 in + uu___2 = module_name) in + Prims.op_Negation uu___1) uu___ in + let binary_deps1 = + FStarC_Compiler_List.sortWith + (fun fn11 -> + fun fn2 -> + let uu___ = FStarC_Parser_Dep.lowercase_module_name fn11 in + let uu___1 = FStarC_Parser_Dep.lowercase_module_name fn2 in + FStarC_Compiler_String.compare uu___ uu___1) binary_deps in + let maybe_add_iface_hash out = + match interface_checked_file_name with + | FStar_Pervasives_Native.None -> + FStar_Pervasives.Inr (("source", source_hash) :: out) + | FStar_Pervasives_Native.Some iface -> + let uu___ = FStarC_Compiler_Util.smap_try_find mcache iface in + (match uu___ with + | FStar_Pervasives_Native.None -> + let msg = + FStarC_Compiler_Util.format1 + "hash_dependences::the interface checked file %s does not exist\n" + iface in + ((let uu___2 = FStarC_Compiler_Effect.op_Bang dbg in + if uu___2 + then FStarC_Compiler_Util.print1 "%s\n" msg + else ()); + FStar_Pervasives.Inl msg) + | FStar_Pervasives_Native.Some (Invalid msg, uu___1) -> + FStar_Pervasives.Inl msg + | FStar_Pervasives_Native.Some (Valid h, uu___1) -> + FStar_Pervasives.Inr (("source", source_hash) :: + ("interface", h) :: out) + | FStar_Pervasives_Native.Some (Unknown, uu___1) -> + let uu___2 = + FStarC_Compiler_Util.format1 + "Impossible: unknown entry in the mcache for interface %s\n" + iface in + failwith uu___2) in + let rec hash_deps out uu___ = + match uu___ with + | [] -> maybe_add_iface_hash out + | fn2::deps1 -> + let cache_fn = FStarC_Parser_Dep.cache_file_name fn2 in + let digest = + let uu___1 = FStarC_Compiler_Util.smap_try_find mcache cache_fn in + match uu___1 with + | FStar_Pervasives_Native.None -> + let msg = + FStarC_Compiler_Util.format2 + "For dependency %s, cache file %s is not loaded" fn2 + cache_fn in + ((let uu___3 = FStarC_Compiler_Effect.op_Bang dbg in + if uu___3 + then FStarC_Compiler_Util.print1 "%s\n" msg + else ()); + FStar_Pervasives.Inl msg) + | FStar_Pervasives_Native.Some (Invalid msg, uu___2) -> + FStar_Pervasives.Inl msg + | FStar_Pervasives_Native.Some (Valid dig, uu___2) -> + FStar_Pervasives.Inr dig + | FStar_Pervasives_Native.Some (Unknown, uu___2) -> + let uu___3 = + FStarC_Compiler_Util.format2 + "Impossible: unknown entry in the cache for dependence %s of module %s" + fn2 module_name in + failwith uu___3 in + (match digest with + | FStar_Pervasives.Inl msg -> FStar_Pervasives.Inl msg + | FStar_Pervasives.Inr dig -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Parser_Dep.lowercase_module_name fn2 in + (uu___3, dig) in + uu___2 :: out in + hash_deps uu___1 deps1) in + hash_deps [] binary_deps1 +let (load_checked_file : Prims.string -> Prims.string -> cache_t) = + fun fn -> + fun checked_fn -> + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg in + if uu___1 + then + FStarC_Compiler_Util.print1 + "Trying to load checked file result %s\n" checked_fn + else ()); + (let elt = FStarC_Compiler_Util.smap_try_find mcache checked_fn in + if FStarC_Compiler_Util.is_some elt + then FStarC_Compiler_Util.must elt + else + (let add_and_return elt1 = + FStarC_Compiler_Util.smap_add mcache checked_fn elt1; elt1 in + if Prims.op_Negation (FStarC_Compiler_Util.file_exists checked_fn) + then + let msg = + FStarC_Compiler_Util.format1 "checked file %s does not exist" + checked_fn in + add_and_return ((Invalid msg), (FStar_Pervasives.Inl msg)) + else + (let entry = FStarC_Compiler_Util.load_value_from_file checked_fn in + match entry with + | FStar_Pervasives_Native.None -> + let msg = + FStarC_Compiler_Util.format1 "checked file %s is corrupt" + checked_fn in + add_and_return ((Invalid msg), (FStar_Pervasives.Inl msg)) + | FStar_Pervasives_Native.Some x -> + if x.version <> cache_version_number + then + let msg = + FStarC_Compiler_Util.format1 + "checked file %s has incorrect version" checked_fn in + add_and_return ((Invalid msg), (FStar_Pervasives.Inl msg)) + else + (let current_digest = + FStarC_Compiler_Util.digest_of_file fn in + if x.digest <> current_digest + then + ((let uu___5 = FStarC_Compiler_Effect.op_Bang dbg in + if uu___5 + then + FStarC_Compiler_Util.print4 + "Checked file %s is stale since incorrect digest of %s, expected: %s, found: %s\n" + checked_fn fn current_digest x.digest + else ()); + (let msg = + FStarC_Compiler_Util.format2 + "checked file %s is stale (digest mismatch for %s)" + checked_fn fn in + add_and_return + ((Invalid msg), (FStar_Pervasives.Inl msg)))) + else + add_and_return + (Unknown, (FStar_Pervasives.Inr (x.parsing_data))))))) +let (load_tc_result : + Prims.string -> + ((Prims.string * Prims.string) Prims.list * tc_result) + FStar_Pervasives_Native.option) + = + fun checked_fn -> + let entry = FStarC_Compiler_Util.load_2values_from_file checked_fn in + match entry with + | FStar_Pervasives_Native.Some (uu___, s2) -> + FStar_Pervasives_Native.Some ((s2.deps_dig), (s2.tc_res)) + | uu___ -> FStar_Pervasives_Native.None +let (load_checked_file_with_tc_result : + FStarC_Parser_Dep.deps -> + Prims.string -> + Prims.string -> (Prims.string, tc_result) FStar_Pervasives.either) + = + fun deps -> + fun fn -> + fun checked_fn -> + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg in + if uu___1 + then + FStarC_Compiler_Util.print1 + "Trying to load checked file with tc result %s\n" checked_fn + else ()); + (let load_tc_result' fn1 = + let uu___1 = load_tc_result fn1 in + match uu___1 with + | FStar_Pervasives_Native.Some x -> x + | FStar_Pervasives_Native.None -> + failwith + "Impossible! if first phase of loading was unknown, it should have succeeded" in + let elt = load_checked_file fn checked_fn in + match elt with + | (Invalid msg, uu___1) -> FStar_Pervasives.Inl msg + | (Valid uu___1, uu___2) -> + let uu___3 = + let uu___4 = load_tc_result' checked_fn in + FStar_Pervasives_Native.snd uu___4 in + FStar_Pervasives.Inr uu___3 + | (Unknown, parsing_data) -> + let uu___1 = hash_dependences deps fn in + (match uu___1 with + | FStar_Pervasives.Inl msg -> + let elt1 = ((Invalid msg), parsing_data) in + (FStarC_Compiler_Util.smap_add mcache checked_fn elt1; + FStar_Pervasives.Inl msg) + | FStar_Pervasives.Inr deps_dig' -> + let uu___2 = load_tc_result' checked_fn in + (match uu___2 with + | (deps_dig, tc_result1) -> + if deps_dig = deps_dig' + then + let elt1 = + let uu___3 = + let uu___4 = + FStarC_Compiler_Util.digest_of_file checked_fn in + Valid uu___4 in + (uu___3, parsing_data) in + (FStarC_Compiler_Util.smap_add mcache checked_fn + elt1; + (let validate_iface_cache uu___4 = + let iface = + let uu___5 = + FStarC_Parser_Dep.lowercase_module_name fn in + FStarC_Parser_Dep.interface_of deps uu___5 in + match iface with + | FStar_Pervasives_Native.None -> () + | FStar_Pervasives_Native.Some iface1 -> + (try + (fun uu___5 -> + match () with + | () -> + let iface_checked_fn = + FStarC_Parser_Dep.cache_file_name + iface1 in + let uu___6 = + FStarC_Compiler_Util.smap_try_find + mcache iface_checked_fn in + (match uu___6 with + | FStar_Pervasives_Native.Some + (Unknown, parsing_data1) -> + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Compiler_Util.digest_of_file + iface_checked_fn in + Valid uu___9 in + (uu___8, parsing_data1) in + FStarC_Compiler_Util.smap_add + mcache iface_checked_fn + uu___7 + | uu___7 -> ())) () + with | uu___5 -> ()) in + validate_iface_cache (); + FStar_Pervasives.Inr tc_result1)) + else + ((let uu___5 = FStarC_Compiler_Effect.op_Bang dbg in + if uu___5 + then + ((let uu___7 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length deps_dig') in + let uu___8 = + FStarC_Parser_Dep.print_digest deps_dig' in + let uu___9 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length deps_dig) in + let uu___10 = + FStarC_Parser_Dep.print_digest deps_dig in + FStarC_Compiler_Util.print4 + "FAILING to load.\nExpected (%s) hashes:\n%s\n\nGot (%s) hashes:\n\t%s\n" + uu___7 uu___8 uu___9 uu___10); + if + (FStarC_Compiler_List.length deps_dig) = + (FStarC_Compiler_List.length deps_dig') + then + FStarC_Compiler_List.iter2 + (fun uu___7 -> + fun uu___8 -> + match (uu___7, uu___8) with + | ((x, y), (x', y')) -> + if (x <> x') || (y <> y') + then + let uu___9 = + FStarC_Parser_Dep.print_digest + [(x, y)] in + let uu___10 = + FStarC_Parser_Dep.print_digest + [(x', y')] in + FStarC_Compiler_Util.print2 + "Differ at: Expected %s\n Got %s\n" + uu___9 uu___10 + else ()) deps_dig deps_dig' + else ()) + else ()); + (let msg = + FStarC_Compiler_Util.format1 + "checked file %s is stale (dependence hash mismatch, use --debug yes for more details)" + checked_fn in + let elt1 = + ((Invalid msg), (FStar_Pervasives.Inl msg)) in + FStarC_Compiler_Util.smap_add mcache checked_fn + elt1; + FStar_Pervasives.Inl msg))))) +let (load_parsing_data_from_cache : + Prims.string -> + FStarC_Parser_Dep.parsing_data FStar_Pervasives_Native.option) + = + fun file_name -> + FStarC_Errors.with_ctx + (Prims.strcat "While loading parsing data from " file_name) + (fun uu___ -> + let cache_file = + try + (fun uu___1 -> + match () with + | () -> + let uu___2 = FStarC_Parser_Dep.cache_file_name file_name in + FStar_Pervasives_Native.Some uu___2) () + with | uu___1 -> FStar_Pervasives_Native.None in + match cache_file with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some cache_file1 -> + let uu___1 = load_checked_file file_name cache_file1 in + (match uu___1 with + | (uu___2, FStar_Pervasives.Inl msg) -> + FStar_Pervasives_Native.None + | (uu___2, FStar_Pervasives.Inr data) -> + FStar_Pervasives_Native.Some data)) +let (load_module_from_cache : + FStarC_TypeChecker_Env.env -> + Prims.string -> tc_result FStar_Pervasives_Native.option) + = + let already_failed = FStarC_Compiler_Util.mk_ref false in + fun env -> + fun fn -> + FStarC_Errors.with_ctx + (Prims.strcat "While loading module from file " fn) + (fun uu___ -> + let load_it fn1 uu___1 = + let cache_file = FStarC_Parser_Dep.cache_file_name fn1 in + let fail msg cache_file1 = + let suppress_warning = + (FStarC_Options.should_check_file fn1) || + (FStarC_Compiler_Effect.op_Bang already_failed) in + if Prims.op_Negation suppress_warning + then + (FStarC_Compiler_Effect.op_Colon_Equals already_failed true; + (let uu___3 = + let uu___4 = + FStarC_Compiler_Range_Type.mk_pos Prims.int_zero + Prims.int_zero in + let uu___5 = + FStarC_Compiler_Range_Type.mk_pos Prims.int_zero + Prims.int_zero in + FStarC_Compiler_Range_Type.mk_range fn1 uu___4 uu___5 in + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Compiler_Util.format3 + "Unable to load %s since %s; will recheck %s (suppressing this warning for further modules)" + cache_file1 msg fn1 in + FStarC_Errors_Msg.text uu___6 in + [uu___5] in + FStarC_Errors.log_issue + FStarC_Class_HasRange.hasRange_range uu___3 + FStarC_Errors_Codes.Warning_CachedFile () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___4))) + else () in + let uu___2 = + let uu___3 = FStarC_TypeChecker_Env.dep_graph env in + load_checked_file_with_tc_result uu___3 fn1 cache_file in + match uu___2 with + | FStar_Pervasives.Inl msg -> + (fail msg cache_file; FStar_Pervasives_Native.None) + | FStar_Pervasives.Inr tc_result1 -> + ((let uu___4 = FStarC_Compiler_Effect.op_Bang dbg in + if uu___4 + then + FStarC_Compiler_Util.print1 + "Successfully loaded module from checked file %s\n" + cache_file + else ()); + FStar_Pervasives_Native.Some tc_result1) in + let load_with_profiling fn1 = + FStarC_Profiling.profile (load_it fn1) + FStar_Pervasives_Native.None "FStarC.CheckedFiles" in + let i_fn_opt = + let uu___1 = FStarC_TypeChecker_Env.dep_graph env in + let uu___2 = FStarC_Parser_Dep.lowercase_module_name fn in + FStarC_Parser_Dep.interface_of uu___1 uu___2 in + let uu___1 = + (FStarC_Parser_Dep.is_implementation fn) && + (FStarC_Compiler_Util.is_some i_fn_opt) in + if uu___1 + then + let i_fn = FStarC_Compiler_Util.must i_fn_opt in + let i_tc = load_with_profiling i_fn in + match i_tc with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some uu___2 -> load_with_profiling fn + else load_with_profiling fn) +let (store_values_to_cache : + Prims.string -> + checked_file_entry_stage1 -> checked_file_entry_stage2 -> unit) + = + fun cache_file -> + fun stage1 -> + fun stage2 -> + FStarC_Errors.with_ctx + (Prims.strcat "While writing checked file " cache_file) + (fun uu___ -> + FStarC_Compiler_Util.save_2values_to_file cache_file stage1 + stage2) +let (store_module_to_cache : + FStarC_TypeChecker_Env.env -> + Prims.string -> FStarC_Parser_Dep.parsing_data -> tc_result -> unit) + = + fun env -> + fun fn -> + fun parsing_data -> + fun tc_result1 -> + let uu___ = + (FStarC_Options.cache_checked_modules ()) && + (let uu___1 = FStarC_Options.cache_off () in + Prims.op_Negation uu___1) in + if uu___ + then + let cache_file = FStarC_Parser_Dep.cache_file_name fn in + let digest = + let uu___1 = FStarC_TypeChecker_Env.dep_graph env in + hash_dependences uu___1 fn in + match digest with + | FStar_Pervasives.Inr hashes -> + let tc_result2 = + { + checked_module = (tc_result1.checked_module); + mii = (tc_result1.mii); + smt_decls = (tc_result1.smt_decls); + tc_time = Prims.int_zero; + extraction_time = Prims.int_zero + } in + let stage1 = + let uu___1 = FStarC_Compiler_Util.digest_of_file fn in + { + version = cache_version_number; + digest = uu___1; + parsing_data + } in + let stage2 = { deps_dig = hashes; tc_res = tc_result2 } in + store_values_to_cache cache_file stage1 stage2 + | FStar_Pervasives.Inl msg -> + let uu___1 = + let uu___2 = + FStarC_Compiler_Range_Type.mk_pos Prims.int_zero + Prims.int_zero in + let uu___3 = + FStarC_Compiler_Range_Type.mk_pos Prims.int_zero + Prims.int_zero in + FStarC_Compiler_Range_Type.mk_range fn uu___2 uu___3 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Compiler_Util.format1 + "Checked file %s was not written." cache_file in + FStarC_Errors_Msg.text uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Pprint.doc_of_string "Reason:" in + let uu___7 = FStarC_Errors_Msg.text msg in + FStarC_Pprint.prefix (Prims.of_int (2)) Prims.int_one + uu___6 uu___7 in + [uu___5] in + uu___3 :: uu___4 in + FStarC_Errors.log_issue FStarC_Class_HasRange.hasRange_range + uu___1 FStarC_Errors_Codes.Warning_FileNotWritten () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___2) + else () +let (unsafe_raw_load_checked_file : + Prims.string -> + (FStarC_Parser_Dep.parsing_data * Prims.string Prims.list * tc_result) + FStar_Pervasives_Native.option) + = + fun checked_fn -> + let entry = FStarC_Compiler_Util.load_2values_from_file checked_fn in + match entry with + | FStar_Pervasives_Native.Some (s1, s2) -> + let uu___ = + let uu___1 = + FStarC_Compiler_List.map FStar_Pervasives_Native.fst s2.deps_dig in + ((s1.parsing_data), uu___1, (s2.tc_res)) in + FStar_Pervasives_Native.Some uu___ + | uu___ -> FStar_Pervasives_Native.None \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Class_Binders.ml b/ocaml/fstar-lib/generated/FStarC_Class_Binders.ml new file mode 100644 index 00000000000..a12ce53f992 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Class_Binders.ml @@ -0,0 +1,80 @@ +open Prims +type 'a hasNames = + { + freeNames: 'a -> FStarC_Syntax_Syntax.bv FStarC_Compiler_FlatSet.flat_set } +let __proj__MkhasNames__item__freeNames : + 'a . + 'a hasNames -> + 'a -> FStarC_Syntax_Syntax.bv FStarC_Compiler_FlatSet.flat_set + = fun projectee -> match projectee with | { freeNames;_} -> freeNames +let freeNames : + 'a . + 'a hasNames -> + 'a -> FStarC_Syntax_Syntax.bv FStarC_Compiler_FlatSet.flat_set + = + fun projectee -> + match projectee with | { freeNames = freeNames1;_} -> freeNames1 +type 'a hasBinders = + { + boundNames: 'a -> FStarC_Syntax_Syntax.bv FStarC_Compiler_FlatSet.flat_set } +let __proj__MkhasBinders__item__boundNames : + 'a . + 'a hasBinders -> + 'a -> FStarC_Syntax_Syntax.bv FStarC_Compiler_FlatSet.flat_set + = fun projectee -> match projectee with | { boundNames;_} -> boundNames +let boundNames : + 'a . + 'a hasBinders -> + 'a -> FStarC_Syntax_Syntax.bv FStarC_Compiler_FlatSet.flat_set + = + fun projectee -> + match projectee with | { boundNames = boundNames1;_} -> boundNames1 +let (hasNames_term : FStarC_Syntax_Syntax.term hasNames) = + { freeNames = FStarC_Syntax_Free.names } +let (hasNames_comp : FStarC_Syntax_Syntax.comp hasNames) = + { + freeNames = + (fun c -> + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total t -> FStarC_Syntax_Free.names t + | FStarC_Syntax_Syntax.GTotal t -> FStarC_Syntax_Free.names t + | FStarC_Syntax_Syntax.Comp ct -> + let uu___ = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) ()) in + let uu___1 = + let uu___2 = + FStarC_Syntax_Free.names ct.FStarC_Syntax_Syntax.result_typ in + let uu___3 = + FStarC_Compiler_List.map + (fun uu___4 -> + match uu___4 with + | (a, uu___5) -> FStarC_Syntax_Free.names a) + ct.FStarC_Syntax_Syntax.effect_args in + uu___2 :: uu___3 in + FStarC_Compiler_List.fold_left + (fun uu___3 -> + fun uu___2 -> + (Obj.magic + (FStarC_Class_Setlike.union () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)))) uu___3 uu___2) + uu___ uu___1) + } +let (hasBinders_list_bv : FStarC_Syntax_Syntax.bv Prims.list hasBinders) = + { + boundNames = + (fun uu___ -> + (Obj.magic + (FStarC_Class_Setlike.from_list () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)))) uu___) + } +let (hasBinders_set_bv : + FStarC_Syntax_Syntax.bv FStarC_Compiler_FlatSet.flat_set hasBinders) = + { boundNames = (fun x -> x) } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Class_Deq.ml b/ocaml/fstar-lib/generated/FStarC_Class_Deq.ml similarity index 100% rename from ocaml/fstar-lib/generated/FStar_Class_Deq.ml rename to ocaml/fstar-lib/generated/FStarC_Class_Deq.ml diff --git a/ocaml/fstar-lib/generated/FStarC_Class_HasRange.ml b/ocaml/fstar-lib/generated/FStarC_Class_HasRange.ml new file mode 100644 index 00000000000..ec548c455b6 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Class_HasRange.ml @@ -0,0 +1,19 @@ +open Prims +type 'a hasRange = + { + pos: 'a -> FStarC_Compiler_Range_Type.range ; + setPos: FStarC_Compiler_Range_Type.range -> 'a -> 'a } +let __proj__MkhasRange__item__pos : + 'a . 'a hasRange -> 'a -> FStarC_Compiler_Range_Type.range = + fun projectee -> match projectee with | { pos; setPos;_} -> pos +let __proj__MkhasRange__item__setPos : + 'a . 'a hasRange -> FStarC_Compiler_Range_Type.range -> 'a -> 'a = + fun projectee -> match projectee with | { pos; setPos;_} -> setPos +let pos : 'a . 'a hasRange -> 'a -> FStarC_Compiler_Range_Type.range = + fun projectee -> match projectee with | { pos = pos1; setPos;_} -> pos1 +let setPos : 'a . 'a hasRange -> FStarC_Compiler_Range_Type.range -> 'a -> 'a + = + fun projectee -> + match projectee with | { pos = pos1; setPos = setPos1;_} -> setPos1 +let (hasRange_range : FStarC_Compiler_Range_Type.range hasRange) = + { pos = (fun x -> x); setPos = (fun r -> fun uu___ -> r) } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Class_Hashable.ml b/ocaml/fstar-lib/generated/FStarC_Class_Hashable.ml new file mode 100644 index 00000000000..a4ad9f9938e --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Class_Hashable.ml @@ -0,0 +1,196 @@ +open Prims +type 'a hashable = { + hash: 'a -> FStarC_Hash.hash_code } +let __proj__Mkhashable__item__hash : + 'a . 'a hashable -> 'a -> FStarC_Hash.hash_code = + fun projectee -> match projectee with | { hash;_} -> hash +let hash : 'a . 'a hashable -> 'a -> FStarC_Hash.hash_code = + fun projectee -> match projectee with | { hash = hash1;_} -> hash1 +let (showable_hash_code : FStarC_Hash.hash_code FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = FStarC_Hash.string_of_hash_code } +let (eq_hash_code : FStarC_Hash.hash_code FStarC_Class_Deq.deq) = + { FStarC_Class_Deq.op_Equals_Question = (=) } +let (ord_hash_code : FStarC_Hash.hash_code FStarC_Class_Ord.ord) = + { + FStarC_Class_Ord.super = eq_hash_code; + FStarC_Class_Ord.cmp = + (fun x -> + fun y -> + let uu___ = FStarC_Hash.cmp_hash x y in + FStarC_Compiler_Order.order_from_int uu___) + } +let (hashable_int : Prims.int hashable) = { hash = FStarC_Hash.of_int } +let (hashable_string : Prims.string hashable) = + { hash = FStarC_Hash.of_string } +let (hashable_bool : Prims.bool hashable) = + { + hash = + (fun b -> + if b + then FStarC_Hash.of_int Prims.int_one + else FStarC_Hash.of_int (Prims.of_int (2))) + } +let hashable_list : 'a . 'a hashable -> 'a Prims.list hashable = + fun uu___ -> + { + hash = + (fun xs -> + let uu___1 = FStarC_Hash.of_int Prims.int_zero in + FStarC_Compiler_List.fold_left + (fun h -> + fun x -> + let uu___2 = hash uu___ x in FStarC_Hash.mix h uu___2) + uu___1 xs) + } +let hashable_option : + 'a . 'a hashable -> 'a FStar_Pervasives_Native.option hashable = + fun uu___ -> + { + hash = + (fun x -> + match x with + | FStar_Pervasives_Native.None -> + FStarC_Hash.of_int Prims.int_zero + | FStar_Pervasives_Native.Some x1 -> + let uu___1 = FStarC_Hash.of_int Prims.int_one in + let uu___2 = hash uu___ x1 in FStarC_Hash.mix uu___1 uu___2) + } +let hashable_either : + 'a 'b . + 'a hashable -> 'b hashable -> ('a, 'b) FStar_Pervasives.either hashable + = + fun uu___ -> + fun uu___1 -> + { + hash = + (fun x -> + match x with + | FStar_Pervasives.Inl a1 -> + let uu___2 = FStarC_Hash.of_int Prims.int_zero in + let uu___3 = hash uu___ a1 in FStarC_Hash.mix uu___2 uu___3 + | FStar_Pervasives.Inr b1 -> + let uu___2 = FStarC_Hash.of_int Prims.int_one in + let uu___3 = hash uu___1 b1 in FStarC_Hash.mix uu___2 uu___3) + } +let hashable_tuple2 : + 'a 'b . 'a hashable -> 'b hashable -> ('a * 'b) hashable = + fun uu___ -> + fun uu___1 -> + { + hash = + (fun uu___2 -> + match uu___2 with + | (a1, b1) -> + let uu___3 = hash uu___ a1 in + let uu___4 = hash uu___1 b1 in FStarC_Hash.mix uu___3 uu___4) + } +let hashable_tuple3 : + 'a 'b 'c . + 'a hashable -> 'b hashable -> 'c hashable -> ('a * 'b * 'c) hashable + = + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + { + hash = + (fun uu___3 -> + match uu___3 with + | (a1, b1, c1) -> + let uu___4 = + let uu___5 = hash uu___ a1 in + let uu___6 = hash uu___1 b1 in + FStarC_Hash.mix uu___5 uu___6 in + let uu___5 = hash uu___2 c1 in + FStarC_Hash.mix uu___4 uu___5) + } +let hashable_tuple4 : + 'a 'b 'c 'd . + 'a hashable -> + 'b hashable -> + 'c hashable -> 'd hashable -> ('a * 'b * 'c * 'd) hashable + = + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + { + hash = + (fun uu___4 -> + match uu___4 with + | (a1, b1, c1, d1) -> + let uu___5 = + let uu___6 = + let uu___7 = hash uu___ a1 in + let uu___8 = hash uu___1 b1 in + FStarC_Hash.mix uu___7 uu___8 in + let uu___7 = hash uu___2 c1 in + FStarC_Hash.mix uu___6 uu___7 in + let uu___6 = hash uu___3 d1 in + FStarC_Hash.mix uu___5 uu___6) + } +let hashable_tuple5 : + 'a 'b 'c 'd 'e . + 'a hashable -> + 'b hashable -> + 'c hashable -> + 'd hashable -> 'e hashable -> ('a * 'b * 'c * 'd * 'e) hashable + = + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun uu___4 -> + { + hash = + (fun uu___5 -> + match uu___5 with + | (a1, b1, c1, d1, e1) -> + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = hash uu___ a1 in + let uu___10 = hash uu___1 b1 in + FStarC_Hash.mix uu___9 uu___10 in + let uu___9 = hash uu___2 c1 in + FStarC_Hash.mix uu___8 uu___9 in + let uu___8 = hash uu___3 d1 in + FStarC_Hash.mix uu___7 uu___8 in + let uu___7 = hash uu___4 e1 in + FStarC_Hash.mix uu___6 uu___7) + } +let hashable_tuple6 : + 'a 'b 'c 'd 'e 'f . + 'a hashable -> + 'b hashable -> + 'c hashable -> + 'd hashable -> + 'e hashable -> + 'f hashable -> ('a * 'b * 'c * 'd * 'e * 'f) hashable + = + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun uu___4 -> + fun uu___5 -> + { + hash = + (fun uu___6 -> + match uu___6 with + | (a1, b1, c1, d1, e1, f1) -> + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = hash uu___ a1 in + let uu___12 = hash uu___1 b1 in + FStarC_Hash.mix uu___11 uu___12 in + let uu___11 = hash uu___2 c1 in + FStarC_Hash.mix uu___10 uu___11 in + let uu___10 = hash uu___3 d1 in + FStarC_Hash.mix uu___9 uu___10 in + let uu___9 = hash uu___4 e1 in + FStarC_Hash.mix uu___8 uu___9 in + let uu___8 = hash uu___5 f1 in + FStarC_Hash.mix uu___7 uu___8) + } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Class_Listlike.ml b/ocaml/fstar-lib/generated/FStarC_Class_Listlike.ml similarity index 100% rename from ocaml/fstar-lib/generated/FStar_Class_Listlike.ml rename to ocaml/fstar-lib/generated/FStarC_Class_Listlike.ml diff --git a/ocaml/fstar-lib/generated/FStarC_Class_Monad.ml b/ocaml/fstar-lib/generated/FStarC_Class_Monad.ml new file mode 100644 index 00000000000..5f8a9fd3d74 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Class_Monad.ml @@ -0,0 +1,202 @@ +open Prims +type 'm monad = + { + return: unit -> Obj.t -> 'm ; + op_let_Bang: unit -> unit -> 'm -> (Obj.t -> 'm) -> 'm } +let __proj__Mkmonad__item__return : 'm . 'm monad -> unit -> Obj.t -> 'm = + fun projectee -> match projectee with | { return; op_let_Bang;_} -> return +let __proj__Mkmonad__item__op_let_Bang : + 'm . 'm monad -> unit -> unit -> 'm -> (Obj.t -> 'm) -> 'm = + fun projectee -> + match projectee with | { return; op_let_Bang;_} -> op_let_Bang +let return : 'm . 'm monad -> unit -> Obj.t -> 'm = + fun projectee -> + match projectee with | { return = return1; op_let_Bang;_} -> return1 +let op_let_Bang : 'm . 'm monad -> unit -> unit -> 'm -> (Obj.t -> 'm) -> 'm + = + fun projectee -> + match projectee with + | { return = return1; op_let_Bang = op_let_Bang1;_} -> op_let_Bang1 +let (monad_option : unit FStar_Pervasives_Native.option monad) = + { + return = + (fun uu___1 -> + fun uu___ -> + (fun a -> fun x -> Obj.magic (FStar_Pervasives_Native.Some x)) + uu___1 uu___); + op_let_Bang = + (fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun uu___1 -> + fun uu___ -> Obj.magic FStarC_Compiler_Util.bind_opt) + uu___3 uu___2 uu___1 uu___) + } +let (monad_list : unit Prims.list monad) = + { + return = + (fun uu___1 -> + fun uu___ -> (fun a -> fun x -> Obj.magic [x]) uu___1 uu___); + op_let_Bang = + (fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun a -> + fun b -> + fun x -> + let x = Obj.magic x in + fun f -> + let f = Obj.magic f in + Obj.magic (FStarC_Compiler_List.concatMap f x)) + uu___3 uu___2 uu___1 uu___) + } +let rec mapM : + 'm . 'm monad -> unit -> unit -> (Obj.t -> 'm) -> Obj.t Prims.list -> 'm = + fun uu___ -> + fun a -> + fun b -> + fun f -> + fun l -> + match l with + | [] -> return uu___ () (Obj.magic []) + | x::xs -> + let uu___1 = f x in + op_let_Bang uu___ () () uu___1 + (fun y -> + let uu___2 = mapM uu___ () () f xs in + op_let_Bang uu___ () () uu___2 + (fun uu___3 -> + (fun ys -> + let ys = Obj.magic ys in + Obj.magic + (return uu___ () (Obj.magic (y :: ys)))) + uu___3)) +let mapMi : + 'm . + 'm monad -> + unit -> unit -> (Prims.int -> Obj.t -> 'm) -> Obj.t Prims.list -> 'm + = + fun uu___ -> + fun a -> + fun b -> + fun f -> + fun l -> + let rec mapMi_go i f1 l1 = + match l1 with + | [] -> return uu___ () (Obj.magic []) + | x::xs -> + let uu___1 = f1 i x in + op_let_Bang uu___ () () uu___1 + (fun y -> + let uu___2 = mapMi_go (i + Prims.int_one) f1 xs in + op_let_Bang uu___ () () uu___2 + (fun uu___3 -> + (fun ys -> + let ys = Obj.magic ys in + Obj.magic + (return uu___ () (Obj.magic (y :: ys)))) + uu___3)) in + mapMi_go Prims.int_zero f l +let map_optM : + 'm . + 'm monad -> + unit -> + unit -> (Obj.t -> 'm) -> Obj.t FStar_Pervasives_Native.option -> 'm + = + fun uu___ -> + fun a -> + fun b -> + fun f -> + fun l -> + match l with + | FStar_Pervasives_Native.None -> + return uu___ () (Obj.magic FStar_Pervasives_Native.None) + | FStar_Pervasives_Native.Some x -> + let uu___1 = f x in + op_let_Bang uu___ () () uu___1 + (fun x1 -> + return uu___ () + (Obj.magic (FStar_Pervasives_Native.Some x1))) +let rec iterM : + 'm . 'm monad -> unit -> (Obj.t -> 'm) -> Obj.t Prims.list -> 'm = + fun uu___ -> + fun a -> + fun f -> + fun l -> + match l with + | [] -> return uu___ () (Obj.repr ()) + | x::xs -> + let uu___1 = f x in + op_let_Bang uu___ () () uu___1 + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + Obj.magic (iterM uu___ () f xs)) uu___2) +let rec foldM_left : + 'm . + 'm monad -> + unit -> + unit -> (Obj.t -> Obj.t -> 'm) -> Obj.t -> Obj.t Prims.list -> 'm + = + fun uu___ -> + fun a -> + fun b -> + fun f -> + fun e -> + fun xs -> + match xs with + | [] -> return uu___ () e + | x::xs1 -> + let uu___1 = f e x in + op_let_Bang uu___ () () uu___1 + (fun e' -> foldM_left uu___ () () f e' xs1) +let rec foldM_right : + 'm . + 'm monad -> + unit -> + unit -> (Obj.t -> Obj.t -> 'm) -> Obj.t Prims.list -> Obj.t -> 'm + = + fun uu___ -> + fun a -> + fun b -> + fun f -> + fun xs -> + fun e -> + match xs with + | [] -> return uu___ () e + | x::xs1 -> + let uu___1 = foldM_right uu___ () () f xs1 e in + op_let_Bang uu___ () () uu___1 (fun e' -> f x e') +let op_Less_Dollar_Greater : + 'm . 'm monad -> unit -> unit -> (Obj.t -> Obj.t) -> 'm -> 'm = + fun uu___ -> + fun a -> + fun b -> + fun f -> + fun x -> + op_let_Bang uu___ () () x + (fun v -> let uu___1 = f v in return uu___ () uu___1) +let op_Less_Star_Greater : 'm . 'm monad -> unit -> unit -> 'm -> 'm -> 'm = + fun uu___ -> + fun a -> + fun b -> + fun ff -> + fun x -> + op_let_Bang uu___ () () ff + (fun uu___1 -> + (fun f -> + let f = Obj.magic f in + Obj.magic + (op_let_Bang uu___ () () x + (fun v -> let uu___1 = f v in return uu___ () uu___1))) + uu___1) +let fmap : 'm . 'm monad -> unit -> unit -> (Obj.t -> Obj.t) -> 'm -> 'm = + fun uu___ -> + fun a -> + fun b -> + fun f -> + fun m1 -> + op_let_Bang uu___ () () m1 + (fun v -> let uu___1 = f v in return uu___ () uu___1) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Class_Monoid.ml b/ocaml/fstar-lib/generated/FStarC_Class_Monoid.ml new file mode 100644 index 00000000000..b8d8399695b --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Class_Monoid.ml @@ -0,0 +1,27 @@ +open Prims +type 'a monoid = { + mzero: 'a ; + mplus: 'a -> 'a -> 'a } +let __proj__Mkmonoid__item__mzero : 'a . 'a monoid -> 'a = + fun projectee -> match projectee with | { mzero; mplus;_} -> mzero +let __proj__Mkmonoid__item__mplus : 'a . 'a monoid -> 'a -> 'a -> 'a = + fun projectee -> match projectee with | { mzero; mplus;_} -> mplus +let mzero : 'a . 'a monoid -> 'a = + fun projectee -> + match projectee with | { mzero = mzero1; mplus;_} -> mzero1 +let mplus : 'a . 'a monoid -> 'a -> 'a -> 'a = + fun projectee -> + match projectee with | { mzero = mzero1; mplus = mplus1;_} -> mplus1 +let op_Plus_Plus : 'a . 'a monoid -> 'a -> 'a -> 'a = + fun uu___ -> mplus uu___ +let msum : 'a . 'a monoid -> 'a Prims.list -> 'a = + fun uu___ -> + fun xs -> FStarC_Compiler_List.fold_left (mplus uu___) (mzero uu___) xs +let (monoid_int : Prims.int monoid) = + { mzero = Prims.int_zero; mplus = (fun x -> fun y -> x + y) } +let (monoid_string : Prims.string monoid) = + { mzero = ""; mplus = (fun x -> fun y -> Prims.strcat x y) } +let monoid_list : 'a . unit -> 'a Prims.list monoid = + fun uu___ -> + { mzero = []; mplus = (fun x -> fun y -> FStarC_Compiler_List.op_At x y) + } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Class_Ord.ml b/ocaml/fstar-lib/generated/FStarC_Class_Ord.ml new file mode 100644 index 00000000000..9faa8a487bb --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Class_Ord.ml @@ -0,0 +1,277 @@ +open Prims +type 'a ord = + { + super: 'a FStarC_Class_Deq.deq ; + cmp: 'a -> 'a -> FStarC_Compiler_Order.order } +let __proj__Mkord__item__super : 'a . 'a ord -> 'a FStarC_Class_Deq.deq = + fun projectee -> match projectee with | { super; cmp;_} -> super +let __proj__Mkord__item__cmp : + 'a . 'a ord -> 'a -> 'a -> FStarC_Compiler_Order.order = + fun projectee -> match projectee with | { super; cmp;_} -> cmp +let super : 'a . 'a ord -> 'a FStarC_Class_Deq.deq = + fun projectee -> match projectee with | { super = super1; cmp;_} -> super1 +let cmp : 'a . 'a ord -> 'a -> 'a -> FStarC_Compiler_Order.order = + fun projectee -> + match projectee with | { super = super1; cmp = cmp1;_} -> cmp1 +let op_Less_Question : 'a . 'a ord -> 'a -> 'a -> Prims.bool = + fun uu___ -> + fun x -> + fun y -> + let uu___1 = cmp uu___ x y in uu___1 = FStarC_Compiler_Order.Lt +let op_Less_Equals_Question : 'a . 'a ord -> 'a -> 'a -> Prims.bool = + fun uu___ -> + fun x -> + fun y -> + let uu___1 = cmp uu___ x y in uu___1 <> FStarC_Compiler_Order.Gt +let op_Greater_Question : 'a . 'a ord -> 'a -> 'a -> Prims.bool = + fun uu___ -> + fun x -> + fun y -> + let uu___1 = cmp uu___ x y in uu___1 = FStarC_Compiler_Order.Gt +let op_Greater_Equals_Question : 'a . 'a ord -> 'a -> 'a -> Prims.bool = + fun uu___ -> + fun x -> + fun y -> + let uu___1 = cmp uu___ x y in uu___1 <> FStarC_Compiler_Order.Lt +let min : 'a . 'a ord -> 'a -> 'a -> 'a = + fun uu___ -> + fun x -> + fun y -> + let uu___1 = op_Less_Equals_Question uu___ x y in + if uu___1 then x else y +let max : 'a . 'a ord -> 'a -> 'a -> 'a = + fun uu___ -> + fun x -> + fun y -> + let uu___1 = op_Greater_Equals_Question uu___ x y in + if uu___1 then x else y +let ord_eq : 'a . 'a ord -> 'a FStarC_Class_Deq.deq = fun d -> d.super +let rec insert : 'a . 'a ord -> 'a -> 'a Prims.list -> 'a Prims.list = + fun uu___ -> + fun x -> + fun xs -> + match xs with + | [] -> [x] + | y::ys -> + let uu___1 = op_Less_Equals_Question uu___ x y in + if uu___1 + then x :: y :: ys + else (let uu___3 = insert uu___ x ys in y :: uu___3) +let rec sort : 'a . 'a ord -> 'a Prims.list -> 'a Prims.list = + fun uu___ -> + fun xs -> + match xs with + | [] -> [] + | x::xs1 -> let uu___1 = sort uu___ xs1 in insert uu___ x uu___1 +let dedup : 'a . 'a ord -> 'a Prims.list -> 'a Prims.list = + fun uu___ -> + fun xs -> + let out = + FStarC_Compiler_List.fold_left + (fun out1 -> + fun x -> + let uu___1 = + FStarC_Compiler_List.existsb + (fun y -> + FStarC_Class_Deq.op_Equals_Question (ord_eq uu___) x y) + out1 in + if uu___1 then out1 else x :: out1) [] xs in + FStarC_Compiler_List.rev out +let (ord_int : Prims.int ord) = + { super = FStarC_Class_Deq.deq_int; cmp = FStarC_Compiler_Order.compare_int + } +let (ord_bool : Prims.bool ord) = + { + super = FStarC_Class_Deq.deq_bool; + cmp = FStarC_Compiler_Order.compare_bool + } +let (ord_unit : unit ord) = + { + super = FStarC_Class_Deq.deq_unit; + cmp = (fun uu___ -> fun uu___1 -> FStarC_Compiler_Order.Eq) + } +let (ord_string : Prims.string ord) = + { + super = FStarC_Class_Deq.deq_string; + cmp = + (fun x -> + fun y -> + FStarC_Compiler_Order.order_from_int + (FStarC_Compiler_String.compare x y)) + } +let ord_option : 'a . 'a ord -> 'a FStar_Pervasives_Native.option ord = + fun d -> + { + super = (FStarC_Class_Deq.deq_option (ord_eq d)); + cmp = + (fun x -> + fun y -> + match (x, y) with + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) + -> FStarC_Compiler_Order.Eq + | (FStar_Pervasives_Native.Some uu___, + FStar_Pervasives_Native.None) -> FStarC_Compiler_Order.Gt + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.Some + uu___) -> FStarC_Compiler_Order.Lt + | (FStar_Pervasives_Native.Some x1, FStar_Pervasives_Native.Some + y1) -> cmp d x1 y1) + } +let ord_list : 'a . 'a ord -> 'a Prims.list ord = + fun d -> + { + super = (FStarC_Class_Deq.deq_list (ord_eq d)); + cmp = + (fun l1 -> fun l2 -> FStarC_Compiler_Order.compare_list l1 l2 (cmp d)) + } +let ord_either : + 'a 'b . 'a ord -> 'b ord -> ('a, 'b) FStar_Pervasives.either ord = + fun d1 -> + fun d2 -> + { + super = (FStarC_Class_Deq.deq_either (ord_eq d1) (ord_eq d2)); + cmp = + (fun x -> + fun y -> + match (x, y) with + | (FStar_Pervasives.Inl uu___, FStar_Pervasives.Inr uu___1) -> + FStarC_Compiler_Order.Lt + | (FStar_Pervasives.Inr uu___, FStar_Pervasives.Inl uu___1) -> + FStarC_Compiler_Order.Gt + | (FStar_Pervasives.Inl x1, FStar_Pervasives.Inl y1) -> + cmp d1 x1 y1 + | (FStar_Pervasives.Inr x1, FStar_Pervasives.Inr y1) -> + cmp d2 x1 y1) + } +let ord_tuple2 : 'a 'b . 'a ord -> 'b ord -> ('a * 'b) ord = + fun d1 -> + fun d2 -> + { + super = (FStarC_Class_Deq.deq_tuple2 (ord_eq d1) (ord_eq d2)); + cmp = + (fun uu___ -> + fun uu___1 -> + match (uu___, uu___1) with + | ((x1, x2), (y1, y2)) -> + let uu___2 = cmp d1 x1 y1 in + FStarC_Compiler_Order.lex uu___2 + (fun uu___3 -> cmp d2 x2 y2)) + } +let ord_tuple3 : 'a 'b 'c . 'a ord -> 'b ord -> 'c ord -> ('a * 'b * 'c) ord + = + fun d1 -> + fun d2 -> + fun d3 -> + { + super = + (FStarC_Class_Deq.deq_tuple3 (ord_eq d1) (ord_eq d2) (ord_eq d3)); + cmp = + (fun uu___ -> + fun uu___1 -> + match (uu___, uu___1) with + | ((x1, x2, x3), (y1, y2, y3)) -> + let uu___2 = cmp d1 x1 y1 in + FStarC_Compiler_Order.lex uu___2 + (fun uu___3 -> + let uu___4 = cmp d2 x2 y2 in + FStarC_Compiler_Order.lex uu___4 + (fun uu___5 -> cmp d3 x3 y3))) + } +let ord_tuple4 : + 'a 'b 'c 'd . + 'a ord -> 'b ord -> 'c ord -> 'd ord -> ('a * 'b * 'c * 'd) ord + = + fun d1 -> + fun d2 -> + fun d3 -> + fun d4 -> + { + super = + (FStarC_Class_Deq.deq_tuple4 (ord_eq d1) (ord_eq d2) + (ord_eq d3) (ord_eq d4)); + cmp = + (fun uu___ -> + fun uu___1 -> + match (uu___, uu___1) with + | ((x1, x2, x3, x4), (y1, y2, y3, y4)) -> + let uu___2 = cmp d1 x1 y1 in + FStarC_Compiler_Order.lex uu___2 + (fun uu___3 -> + let uu___4 = cmp d2 x2 y2 in + FStarC_Compiler_Order.lex uu___4 + (fun uu___5 -> + let uu___6 = cmp d3 x3 y3 in + FStarC_Compiler_Order.lex uu___6 + (fun uu___7 -> cmp d4 x4 y4)))) + } +let ord_tuple5 : + 'a 'b 'c 'd 'e . + 'a ord -> + 'b ord -> 'c ord -> 'd ord -> 'e ord -> ('a * 'b * 'c * 'd * 'e) ord + = + fun d1 -> + fun d2 -> + fun d3 -> + fun d4 -> + fun d5 -> + { + super = + (FStarC_Class_Deq.deq_tuple5 (ord_eq d1) (ord_eq d2) + (ord_eq d3) (ord_eq d4) (ord_eq d5)); + cmp = + (fun uu___ -> + fun uu___1 -> + match (uu___, uu___1) with + | ((x1, x2, x3, x4, x5), (y1, y2, y3, y4, y5)) -> + let uu___2 = cmp d1 x1 y1 in + FStarC_Compiler_Order.lex uu___2 + (fun uu___3 -> + let uu___4 = cmp d2 x2 y2 in + FStarC_Compiler_Order.lex uu___4 + (fun uu___5 -> + let uu___6 = cmp d3 x3 y3 in + FStarC_Compiler_Order.lex uu___6 + (fun uu___7 -> + let uu___8 = cmp d4 x4 y4 in + FStarC_Compiler_Order.lex uu___8 + (fun uu___9 -> cmp d5 x5 y5))))) + } +let ord_tuple6 : + 'a 'b 'c 'd 'e 'f . + 'a ord -> + 'b ord -> + 'c ord -> + 'd ord -> 'e ord -> 'f ord -> ('a * 'b * 'c * 'd * 'e * 'f) ord + = + fun d1 -> + fun d2 -> + fun d3 -> + fun d4 -> + fun d5 -> + fun d6 -> + { + super = + (FStarC_Class_Deq.deq_tuple6 (ord_eq d1) (ord_eq d2) + (ord_eq d3) (ord_eq d4) (ord_eq d5) (ord_eq d6)); + cmp = + (fun uu___ -> + fun uu___1 -> + match (uu___, uu___1) with + | ((x1, x2, x3, x4, x5, x6), (y1, y2, y3, y4, y5, y6)) + -> + let uu___2 = cmp d1 x1 y1 in + FStarC_Compiler_Order.lex uu___2 + (fun uu___3 -> + let uu___4 = cmp d2 x2 y2 in + FStarC_Compiler_Order.lex uu___4 + (fun uu___5 -> + let uu___6 = cmp d3 x3 y3 in + FStarC_Compiler_Order.lex uu___6 + (fun uu___7 -> + let uu___8 = cmp d4 x4 y4 in + FStarC_Compiler_Order.lex uu___8 + (fun uu___9 -> + let uu___10 = cmp d5 x5 y5 in + FStarC_Compiler_Order.lex + uu___10 + (fun uu___11 -> cmp d6 x6 y6)))))) + } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Class_PP.ml b/ocaml/fstar-lib/generated/FStarC_Class_PP.ml new file mode 100644 index 00000000000..ae1b7f20d41 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Class_PP.ml @@ -0,0 +1,234 @@ +open Prims +type 'a pretty = { + pp: 'a -> FStarC_Pprint.document } +let __proj__Mkpretty__item__pp : + 'a . 'a pretty -> 'a -> FStarC_Pprint.document = + fun projectee -> match projectee with | { pp;_} -> pp +let pp : 'a . 'a pretty -> 'a -> FStarC_Pprint.document = + fun projectee -> match projectee with | { pp = pp1;_} -> pp1 +let (gparens : FStarC_Pprint.document -> FStarC_Pprint.document) = + fun a -> + let uu___ = + let uu___1 = FStarC_Pprint.parens a in + FStarC_Pprint.nest (Prims.of_int (2)) uu___1 in + FStarC_Pprint.group uu___ +let (gbrackets : FStarC_Pprint.document -> FStarC_Pprint.document) = + fun a -> + let uu___ = + let uu___1 = FStarC_Pprint.brackets a in + FStarC_Pprint.nest (Prims.of_int (2)) uu___1 in + FStarC_Pprint.group uu___ +let (pp_unit : unit pretty) = + { pp = (fun uu___ -> FStarC_Pprint.doc_of_string "()") } +let (pp_int : Prims.int pretty) = + { pp = (fun x -> FStarC_Pprint.doc_of_string (Prims.string_of_int x)) } +let (pp_bool : Prims.bool pretty) = { pp = FStarC_Pprint.doc_of_bool } +let pp_list : 'a . 'a pretty -> 'a Prims.list pretty = + fun uu___ -> + { + pp = + (fun l -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Pprint.break_ Prims.int_one in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.semi uu___3 in + FStarC_Pprint.flow_map uu___2 (pp uu___) l in + gbrackets uu___1) + } +let pp_option : 'a . 'a pretty -> 'a FStar_Pervasives_Native.option pretty = + fun uu___ -> + { + pp = + (fun o -> + match o with + | FStar_Pervasives_Native.Some v -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Pprint.doc_of_string "Some" in + let uu___4 = pp uu___ v in + FStarC_Pprint.op_Hat_Slash_Hat uu___3 uu___4 in + FStarC_Pprint.nest (Prims.of_int (2)) uu___2 in + FStarC_Pprint.group uu___1 + | FStar_Pervasives_Native.None -> + FStarC_Pprint.doc_of_string "None") + } +let pp_either : + 'a 'b . 'a pretty -> 'b pretty -> ('a, 'b) FStar_Pervasives.either pretty = + fun uu___ -> + fun uu___1 -> + { + pp = + (fun e -> + let uu___2 = + let uu___3 = + match e with + | FStar_Pervasives.Inl x -> + let uu___4 = FStarC_Pprint.doc_of_string "Inl" in + let uu___5 = pp uu___ x in + FStarC_Pprint.op_Hat_Slash_Hat uu___4 uu___5 + | FStar_Pervasives.Inr x -> + let uu___4 = FStarC_Pprint.doc_of_string "Inr" in + let uu___5 = pp uu___1 x in + FStarC_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in + FStarC_Pprint.nest (Prims.of_int (2)) uu___3 in + FStarC_Pprint.group uu___2) + } +let (comma_space : FStarC_Pprint.document) = + let uu___ = FStarC_Pprint.break_ Prims.int_one in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.comma uu___ +let pp_tuple2 : 'a 'b . 'a pretty -> 'b pretty -> ('a * 'b) pretty = + fun uu___ -> + fun uu___1 -> + { + pp = + (fun uu___2 -> + match uu___2 with + | (x1, x2) -> + let uu___3 = + let uu___4 = + let uu___5 = pp uu___ x1 in + let uu___6 = let uu___7 = pp uu___1 x2 in [uu___7] in + uu___5 :: uu___6 in + FStarC_Pprint.separate comma_space uu___4 in + gparens uu___3) + } +let pp_tuple3 : + 'a 'b 'c . 'a pretty -> 'b pretty -> 'c pretty -> ('a * 'b * 'c) pretty = + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + { + pp = + (fun uu___3 -> + match uu___3 with + | (x1, x2, x3) -> + let uu___4 = + let uu___5 = + let uu___6 = pp uu___ x1 in + let uu___7 = + let uu___8 = pp uu___1 x2 in + let uu___9 = let uu___10 = pp uu___2 x3 in [uu___10] in + uu___8 :: uu___9 in + uu___6 :: uu___7 in + FStarC_Pprint.separate comma_space uu___5 in + gparens uu___4) + } +let pp_tuple4 : + 'a 'b 'c 'd . + 'a pretty -> + 'b pretty -> 'c pretty -> 'd pretty -> ('a * 'b * 'c * 'd) pretty + = + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + { + pp = + (fun uu___4 -> + match uu___4 with + | (x1, x2, x3, x4) -> + let uu___5 = + let uu___6 = + let uu___7 = pp uu___ x1 in + let uu___8 = + let uu___9 = pp uu___1 x2 in + let uu___10 = + let uu___11 = pp uu___2 x3 in + let uu___12 = + let uu___13 = pp uu___3 x4 in [uu___13] in + uu___11 :: uu___12 in + uu___9 :: uu___10 in + uu___7 :: uu___8 in + FStarC_Pprint.separate comma_space uu___6 in + gparens uu___5) + } +let pp_tuple5 : + 'a 'b 'c 'd 'e . + 'a pretty -> + 'b pretty -> + 'c pretty -> + 'd pretty -> 'e pretty -> ('a * 'b * 'c * 'd * 'e) pretty + = + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun uu___4 -> + { + pp = + (fun uu___5 -> + match uu___5 with + | (x1, x2, x3, x4, x5) -> + let uu___6 = + let uu___7 = + let uu___8 = pp uu___ x1 in + let uu___9 = + let uu___10 = pp uu___1 x2 in + let uu___11 = + let uu___12 = pp uu___2 x3 in + let uu___13 = + let uu___14 = pp uu___3 x4 in + let uu___15 = + let uu___16 = pp uu___4 x5 in [uu___16] in + uu___14 :: uu___15 in + uu___12 :: uu___13 in + uu___10 :: uu___11 in + uu___8 :: uu___9 in + FStarC_Pprint.separate comma_space uu___7 in + gparens uu___6) + } +let pp_tuple6 : + 'a 'b 'c 'd 'e 'f . + 'a pretty -> + 'b pretty -> + 'c pretty -> + 'd pretty -> + 'e pretty -> 'f pretty -> ('a * 'b * 'c * 'd * 'e * 'f) pretty + = + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun uu___4 -> + fun uu___5 -> + { + pp = + (fun uu___6 -> + match uu___6 with + | (x1, x2, x3, x4, x5, x6) -> + let uu___7 = + let uu___8 = + let uu___9 = pp uu___ x1 in + let uu___10 = + let uu___11 = pp uu___1 x2 in + let uu___12 = + let uu___13 = pp uu___2 x3 in + let uu___14 = + let uu___15 = pp uu___3 x4 in + let uu___16 = + let uu___17 = pp uu___4 x5 in + let uu___18 = + let uu___19 = pp uu___5 x6 in + [uu___19] in + uu___17 :: uu___18 in + uu___15 :: uu___16 in + uu___13 :: uu___14 in + uu___11 :: uu___12 in + uu___9 :: uu___10 in + FStarC_Pprint.separate comma_space uu___8 in + gparens uu___7) + } +let pretty_from_showable : 'a . 'a FStarC_Class_Show.showable -> 'a pretty = + fun uu___ -> + { + pp = + (fun x -> + let uu___1 = FStarC_Class_Show.show uu___ x in + FStarC_Pprint.arbitrary_string uu___1) + } +let showable_from_pretty : 'a . 'a pretty -> 'a FStarC_Class_Show.showable = + fun uu___ -> + { + FStarC_Class_Show.show = + (fun x -> let uu___1 = pp uu___ x in FStarC_Pprint.render uu___1) + } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Class_Setlike.ml b/ocaml/fstar-lib/generated/FStarC_Class_Setlike.ml similarity index 100% rename from ocaml/fstar-lib/generated/FStar_Class_Setlike.ml rename to ocaml/fstar-lib/generated/FStarC_Class_Setlike.ml diff --git a/ocaml/fstar-lib/generated/FStarC_Class_Show.ml b/ocaml/fstar-lib/generated/FStarC_Class_Show.ml new file mode 100644 index 00000000000..61bf22f3465 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Class_Show.ml @@ -0,0 +1,200 @@ +open Prims +type 'a showable = { + show: 'a -> Prims.string } +let __proj__Mkshowable__item__show : 'a . 'a showable -> 'a -> Prims.string = + fun projectee -> match projectee with | { show;_} -> show +let show : 'a . 'a showable -> 'a -> Prims.string = + fun projectee -> match projectee with | { show = show1;_} -> show1 +let printableshow : 'a . 'a FStar_Class_Printable.printable -> 'a showable = + fun uu___ -> { show = (FStar_Class_Printable.to_string uu___) } +let show_list : 'a . 'a showable -> 'a Prims.list showable = + fun uu___ -> { show = ((FStarC_Common.string_of_list ()) (show uu___)) } +let show_option : + 'a . 'a showable -> 'a FStar_Pervasives_Native.option showable = + fun uu___ -> { show = (FStarC_Common.string_of_option (show uu___)) } +let show_either : + 'a 'b . + 'a showable -> 'b showable -> ('a, 'b) FStar_Pervasives.either showable + = + fun uu___ -> + fun uu___1 -> + { + show = + (fun uu___2 -> + match uu___2 with + | FStar_Pervasives.Inl x -> + let uu___3 = show uu___ x in Prims.strcat "Inl " uu___3 + | FStar_Pervasives.Inr y -> + let uu___3 = show uu___1 y in Prims.strcat "Inr " uu___3) + } +let show_tuple2 : 'a 'b . 'a showable -> 'b showable -> ('a * 'b) showable = + fun uu___ -> + fun uu___1 -> + { + show = + (fun uu___2 -> + match uu___2 with + | (x1, x2) -> + let uu___3 = + let uu___4 = show uu___ x1 in + let uu___5 = + let uu___6 = + let uu___7 = show uu___1 x2 in Prims.strcat uu___7 ")" in + Prims.strcat ", " uu___6 in + Prims.strcat uu___4 uu___5 in + Prims.strcat "(" uu___3) + } +let show_tuple3 : + 'a 'b 'c . + 'a showable -> 'b showable -> 'c showable -> ('a * 'b * 'c) showable + = + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + { + show = + (fun uu___3 -> + match uu___3 with + | (x1, x2, x3) -> + let uu___4 = + let uu___5 = show uu___ x1 in + let uu___6 = + let uu___7 = + let uu___8 = show uu___1 x2 in + let uu___9 = + let uu___10 = + let uu___11 = show uu___2 x3 in + Prims.strcat uu___11 ")" in + Prims.strcat ", " uu___10 in + Prims.strcat uu___8 uu___9 in + Prims.strcat ", " uu___7 in + Prims.strcat uu___5 uu___6 in + Prims.strcat "(" uu___4) + } +let show_tuple4 : + 'a 'b 'c 'd . + 'a showable -> + 'b showable -> + 'c showable -> 'd showable -> ('a * 'b * 'c * 'd) showable + = + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + { + show = + (fun uu___4 -> + match uu___4 with + | (x1, x2, x3, x4) -> + let uu___5 = + let uu___6 = show uu___ x1 in + let uu___7 = + let uu___8 = + let uu___9 = show uu___1 x2 in + let uu___10 = + let uu___11 = + let uu___12 = show uu___2 x3 in + let uu___13 = + let uu___14 = + let uu___15 = show uu___3 x4 in + Prims.strcat uu___15 ")" in + Prims.strcat ", " uu___14 in + Prims.strcat uu___12 uu___13 in + Prims.strcat ", " uu___11 in + Prims.strcat uu___9 uu___10 in + Prims.strcat ", " uu___8 in + Prims.strcat uu___6 uu___7 in + Prims.strcat "(" uu___5) + } +let show_tuple5 : + 'a 'b 'c 'd 'e . + 'a showable -> + 'b showable -> + 'c showable -> + 'd showable -> 'e showable -> ('a * 'b * 'c * 'd * 'e) showable + = + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun uu___4 -> + { + show = + (fun uu___5 -> + match uu___5 with + | (x1, x2, x3, x4, x5) -> + let uu___6 = + let uu___7 = show uu___ x1 in + let uu___8 = + let uu___9 = + let uu___10 = show uu___1 x2 in + let uu___11 = + let uu___12 = + let uu___13 = show uu___2 x3 in + let uu___14 = + let uu___15 = + let uu___16 = show uu___3 x4 in + let uu___17 = + let uu___18 = + let uu___19 = show uu___4 x5 in + Prims.strcat uu___19 ")" in + Prims.strcat ", " uu___18 in + Prims.strcat uu___16 uu___17 in + Prims.strcat ", " uu___15 in + Prims.strcat uu___13 uu___14 in + Prims.strcat ", " uu___12 in + Prims.strcat uu___10 uu___11 in + Prims.strcat ", " uu___9 in + Prims.strcat uu___7 uu___8 in + Prims.strcat "(" uu___6) + } +let show_tuple6 : + 'a 'b 'c 'd 'e 'f . + 'a showable -> + 'b showable -> + 'c showable -> + 'd showable -> + 'e showable -> + 'f showable -> ('a * 'b * 'c * 'd * 'e * 'f) showable + = + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun uu___4 -> + fun uu___5 -> + { + show = + (fun uu___6 -> + match uu___6 with + | (x1, x2, x3, x4, x5, x6) -> + let uu___7 = + let uu___8 = show uu___ x1 in + let uu___9 = + let uu___10 = + let uu___11 = show uu___1 x2 in + let uu___12 = + let uu___13 = + let uu___14 = show uu___2 x3 in + let uu___15 = + let uu___16 = + let uu___17 = show uu___3 x4 in + let uu___18 = + let uu___19 = + let uu___20 = show uu___4 x5 in + let uu___21 = + let uu___22 = + let uu___23 = show uu___5 x6 in + Prims.strcat uu___23 ")" in + Prims.strcat ", " uu___22 in + Prims.strcat uu___20 uu___21 in + Prims.strcat ", " uu___19 in + Prims.strcat uu___17 uu___18 in + Prims.strcat ", " uu___16 in + Prims.strcat uu___14 uu___15 in + Prims.strcat ", " uu___13 in + Prims.strcat uu___11 uu___12 in + Prims.strcat ", " uu___10 in + Prims.strcat uu___8 uu___9 in + Prims.strcat "(" uu___7) + } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Class_Tagged.ml b/ocaml/fstar-lib/generated/FStarC_Class_Tagged.ml similarity index 100% rename from ocaml/fstar-lib/generated/FStar_Class_Tagged.ml rename to ocaml/fstar-lib/generated/FStarC_Class_Tagged.ml diff --git a/ocaml/fstar-lib/generated/FStarC_Common.ml b/ocaml/fstar-lib/generated/FStarC_Common.ml new file mode 100644 index 00000000000..302c8079d4b --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Common.ml @@ -0,0 +1,185 @@ +open Prims +let (has_cygpath : Prims.bool) = + try + (fun uu___ -> + match () with + | () -> + let t_out = + FStarC_Compiler_Util.run_process "has_cygpath" "which" + ["cygpath"] FStar_Pervasives_Native.None in + (FStarC_Compiler_Util.trim_string t_out) = "/usr/bin/cygpath") () + with | uu___ -> false +let (try_convert_file_name_to_mixed : Prims.string -> Prims.string) = + let cache = FStarC_Compiler_Util.smap_create (Prims.of_int (20)) in + fun s -> + if has_cygpath && (FStarC_Compiler_Util.starts_with s "/") + then + let uu___ = FStarC_Compiler_Util.smap_try_find cache s in + match uu___ with + | FStar_Pervasives_Native.Some s1 -> s1 + | FStar_Pervasives_Native.None -> + let label = "try_convert_file_name_to_mixed" in + let out = + let uu___1 = + FStarC_Compiler_Util.run_process label "cygpath" ["-m"; s] + FStar_Pervasives_Native.None in + FStarC_Compiler_Util.trim_string uu___1 in + (FStarC_Compiler_Util.smap_add cache s out; out) + else s +let snapshot : + 'a 'b 'c . + ('a -> 'b) -> + 'c Prims.list FStarC_Compiler_Effect.ref -> 'a -> (Prims.int * 'b) + = + fun push -> + fun stackref -> + fun arg -> + FStarC_Compiler_Util.atomically + (fun uu___ -> + let len = + let uu___1 = FStarC_Compiler_Effect.op_Bang stackref in + FStarC_Compiler_List.length uu___1 in + let arg' = push arg in (len, arg')) +let rollback : + 'a 'c . + (unit -> 'a) -> + 'c Prims.list FStarC_Compiler_Effect.ref -> + Prims.int FStar_Pervasives_Native.option -> 'a + = + fun pop -> + fun stackref -> + fun depth -> + let rec aux n = + if n <= Prims.int_zero + then failwith "Too many pops" + else + if n = Prims.int_one + then pop () + else ((let uu___3 = pop () in ()); aux (n - Prims.int_one)) in + let curdepth = + let uu___ = FStarC_Compiler_Effect.op_Bang stackref in + FStarC_Compiler_List.length uu___ in + let n = + match depth with + | FStar_Pervasives_Native.Some d -> curdepth - d + | FStar_Pervasives_Native.None -> Prims.int_one in + FStarC_Compiler_Util.atomically (fun uu___ -> aux n) +let raise_failed_assertion : 'uuuuu . Prims.string -> 'uuuuu = + fun msg -> + let uu___ = FStarC_Compiler_Util.format1 "Assertion failed: %s" msg in + failwith uu___ +let (runtime_assert : Prims.bool -> Prims.string -> unit) = + fun b -> + fun msg -> if Prims.op_Negation b then raise_failed_assertion msg else () +let __string_of_list : + 'a . Prims.string -> ('a -> Prims.string) -> 'a Prims.list -> Prims.string + = + fun delim -> + fun f -> + fun l -> + match l with + | [] -> "[]" + | x::xs -> + let strb = FStarC_Compiler_Util.new_string_builder () in + (FStarC_Compiler_Util.string_builder_append strb "["; + (let uu___2 = f x in + FStarC_Compiler_Util.string_builder_append strb uu___2); + FStarC_Compiler_List.iter + (fun x1 -> + FStarC_Compiler_Util.string_builder_append strb delim; + (let uu___4 = f x1 in + FStarC_Compiler_Util.string_builder_append strb uu___4)) + xs; + FStarC_Compiler_Util.string_builder_append strb "]"; + FStarC_Compiler_Util.string_of_string_builder strb) +let string_of_list : + 'uuuuu . + unit -> ('uuuuu -> Prims.string) -> 'uuuuu Prims.list -> Prims.string + = fun uu___ -> __string_of_list ", " +let string_of_list' : + 'uuuuu . + unit -> ('uuuuu -> Prims.string) -> 'uuuuu Prims.list -> Prims.string + = fun uu___ -> __string_of_list "; " +let list_of_option : 'a . 'a FStar_Pervasives_Native.option -> 'a Prims.list + = + fun o -> + match o with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some x -> [x] +let string_of_option : + 'uuuuu . + ('uuuuu -> Prims.string) -> + 'uuuuu FStar_Pervasives_Native.option -> Prims.string + = + fun f -> + fun uu___ -> + match uu___ with + | FStar_Pervasives_Native.None -> "None" + | FStar_Pervasives_Native.Some x -> + let uu___1 = f x in Prims.strcat "Some " uu___1 +let tabulate : 'a . Prims.int -> (Prims.int -> 'a) -> 'a Prims.list = + fun n -> + fun f -> + let rec aux i = + if i < n + then + let uu___ = f i in + let uu___1 = aux (i + Prims.int_one) in uu___ :: uu___1 + else [] in + aux Prims.int_zero +let rec max_prefix : + 'a . ('a -> Prims.bool) -> 'a Prims.list -> ('a Prims.list * 'a Prims.list) + = + fun f -> + fun xs -> + match xs with + | [] -> ([], []) + | x::xs1 when f x -> + let uu___ = max_prefix f xs1 in + (match uu___ with | (l, r) -> ((x :: l), r)) + | x::xs1 -> ([], (x :: xs1)) +let max_suffix : + 'a . ('a -> Prims.bool) -> 'a Prims.list -> ('a Prims.list * 'a Prims.list) + = + fun f -> + fun xs -> + let rec aux acc xs1 = + match xs1 with + | [] -> (acc, []) + | x::xs2 when f x -> aux (x :: acc) xs2 + | x::xs2 -> (acc, (x :: xs2)) in + let uu___ = aux [] (FStarC_Compiler_List.rev xs) in + match uu___ with | (xs1, ys) -> ((FStarC_Compiler_List.rev ys), xs1) +let rec eq_list : + 'a . + ('a -> 'a -> Prims.bool) -> 'a Prims.list -> 'a Prims.list -> Prims.bool + = + fun f -> + fun l1 -> + fun l2 -> + match (l1, l2) with + | ([], []) -> true + | ([], uu___) -> false + | (uu___, []) -> false + | (x1::t1, x2::t2) -> (f x1 x2) && (eq_list f t1 t2) +let psmap_to_list : + 'uuuuu . + 'uuuuu FStarC_Compiler_Util.psmap -> (Prims.string * 'uuuuu) Prims.list + = + fun m -> + FStarC_Compiler_Util.psmap_fold m + (fun k -> fun v -> fun a -> (k, v) :: a) [] +let psmap_keys : + 'uuuuu . 'uuuuu FStarC_Compiler_Util.psmap -> Prims.string Prims.list = + fun m -> + FStarC_Compiler_Util.psmap_fold m (fun k -> fun v -> fun a -> k :: a) [] +let psmap_values : + 'uuuuu . 'uuuuu FStarC_Compiler_Util.psmap -> 'uuuuu Prims.list = + fun m -> + FStarC_Compiler_Util.psmap_fold m (fun k -> fun v -> fun a -> v :: a) [] +let option_to_list : + 'uuuuu . 'uuuuu FStar_Pervasives_Native.option -> 'uuuuu Prims.list = + fun uu___ -> + match uu___ with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some x -> [x] \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Compiler_CList.ml b/ocaml/fstar-lib/generated/FStarC_Compiler_CList.ml new file mode 100644 index 00000000000..a7b0317d714 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Compiler_CList.ml @@ -0,0 +1,140 @@ +open Prims +type 'a clist = + | CNil + | CCons of 'a * 'a clist + | CCat of 'a clist * 'a clist +let uu___is_CNil : 'a . 'a clist -> Prims.bool = + fun projectee -> match projectee with | CNil -> true | uu___ -> false +let uu___is_CCons : 'a . 'a clist -> Prims.bool = + fun projectee -> + match projectee with | CCons (_0, _1) -> true | uu___ -> false +let __proj__CCons__item___0 : 'a . 'a clist -> 'a = + fun projectee -> match projectee with | CCons (_0, _1) -> _0 +let __proj__CCons__item___1 : 'a . 'a clist -> 'a clist = + fun projectee -> match projectee with | CCons (_0, _1) -> _1 +let uu___is_CCat : 'a . 'a clist -> Prims.bool = + fun projectee -> + match projectee with | CCat (_0, _1) -> true | uu___ -> false +let __proj__CCat__item___0 : 'a . 'a clist -> 'a clist = + fun projectee -> match projectee with | CCat (_0, _1) -> _0 +let __proj__CCat__item___1 : 'a . 'a clist -> 'a clist = + fun projectee -> match projectee with | CCat (_0, _1) -> _1 +type 'a t = 'a clist +let ccat : 'a . 'a clist -> 'a clist -> 'a clist = + fun xs -> + fun ys -> + match (xs, ys) with + | (CNil, uu___) -> ys + | (uu___, CNil) -> xs + | uu___ -> CCat (xs, ys) +let rec view : 'a . 'a clist -> ('a, 'a clist) FStarC_Class_Listlike.view_t = + fun l -> + match l with + | CNil -> FStarC_Class_Listlike.VNil + | CCons (x, xs) -> FStarC_Class_Listlike.VCons (x, xs) + | CCat (CCat (xs, ys), zs) -> view (CCat (xs, (CCat (ys, zs)))) + | CCat (xs, ys) -> + (match view xs with + | FStarC_Class_Listlike.VNil -> view ys + | FStarC_Class_Listlike.VCons (x, xs') -> + FStarC_Class_Listlike.VCons (x, (CCat (xs', ys)))) +let listlike_clist : 'a . unit -> ('a, 'a t) FStarC_Class_Listlike.listlike = + fun uu___ -> + { + FStarC_Class_Listlike.empty = CNil; + FStarC_Class_Listlike.cons = + (fun uu___1 -> fun uu___2 -> CCons (uu___1, uu___2)); + FStarC_Class_Listlike.view = view + } +let monoid_clist : 'a . unit -> 'a t FStarC_Class_Monoid.monoid = + fun uu___ -> + { FStarC_Class_Monoid.mzero = CNil; FStarC_Class_Monoid.mplus = ccat } +let showable_clist : + 'a . 'a FStarC_Class_Show.showable -> 'a t FStarC_Class_Show.showable = + fun uu___ -> + { + FStarC_Class_Show.show = + (fun l -> + let uu___1 = FStarC_Class_Listlike.to_list (listlike_clist ()) l in + FStarC_Class_Show.show (FStarC_Class_Show.show_list uu___) uu___1) + } +let eq_clist : 'a . 'a FStarC_Class_Deq.deq -> 'a t FStarC_Class_Deq.deq = + fun d -> + { + FStarC_Class_Deq.op_Equals_Question = + (fun l1 -> + fun l2 -> + let uu___ = FStarC_Class_Listlike.to_list (listlike_clist ()) l1 in + let uu___1 = + FStarC_Class_Listlike.to_list (listlike_clist ()) l2 in + FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Deq.deq_list d) uu___ uu___1) + } +let ord_clist : 'a . 'a FStarC_Class_Ord.ord -> 'a t FStarC_Class_Ord.ord = + fun d -> + { + FStarC_Class_Ord.super = (eq_clist (FStarC_Class_Ord.ord_eq d)); + FStarC_Class_Ord.cmp = + (fun l1 -> + fun l2 -> + let uu___ = FStarC_Class_Listlike.to_list (listlike_clist ()) l1 in + let uu___1 = + FStarC_Class_Listlike.to_list (listlike_clist ()) l2 in + FStarC_Class_Ord.cmp (FStarC_Class_Ord.ord_list d) uu___ uu___1) + } +let rec map : 'a 'b . ('a -> 'b) -> 'a clist -> 'b clist = + fun f -> + fun l -> + match l with + | CNil -> CNil + | CCons (x, xs) -> + let uu___ = f x in let uu___1 = map f xs in CCons (uu___, uu___1) + | CCat (xs, ys) -> + let uu___ = map f xs in let uu___1 = map f ys in ccat uu___ uu___1 +let rec existsb : 'a . ('a -> Prims.bool) -> 'a clist -> Prims.bool = + fun p -> + fun l -> + match l with + | CNil -> false + | CCons (x, xs) -> (p x) || (existsb p xs) + | CCat (xs, ys) -> (existsb p xs) || (existsb p ys) +let rec for_all : 'a . ('a -> Prims.bool) -> 'a clist -> Prims.bool = + fun p -> + fun l -> + match l with + | CNil -> true + | CCons (x, xs) -> (p x) && (for_all p xs) + | CCat (xs, ys) -> (for_all p xs) && (for_all p ys) +let rec partition : + 'a . ('a -> Prims.bool) -> 'a clist -> ('a clist * 'a clist) = + fun p -> + fun l -> + match l with + | CNil -> (CNil, CNil) + | CCons (x, xs) -> + let uu___ = partition p xs in + (match uu___ with + | (ys, zs) -> + let uu___1 = p x in + if uu___1 + then ((CCons (x, ys)), zs) + else (ys, (CCons (x, zs)))) + | CCat (xs, ys) -> + let uu___ = partition p xs in + (match uu___ with + | (ys1, zs) -> + let uu___1 = partition p ys1 in + (match uu___1 with + | (us, vs) -> + let uu___2 = ccat ys1 us in + let uu___3 = ccat zs vs in (uu___2, uu___3))) +let rec collect : 'a 'b . ('a -> 'b clist) -> 'a clist -> 'b clist = + fun f -> + fun l -> + match l with + | CNil -> CNil + | CCons (x, xs) -> + let uu___ = f x in let uu___1 = collect f xs in ccat uu___ uu___1 + | CCat (xs, ys) -> + let uu___ = collect f xs in + let uu___1 = collect f ys in ccat uu___ uu___1 \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Compiler_Debug.ml b/ocaml/fstar-lib/generated/FStarC_Compiler_Debug.ml new file mode 100644 index 00000000000..8c6382c1517 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Compiler_Debug.ml @@ -0,0 +1,151 @@ +open Prims +let (anyref : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref false +let (_debug_all : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref false +let (toggle_list : + (Prims.string * Prims.bool FStarC_Compiler_Effect.ref) Prims.list + FStarC_Compiler_Effect.ref) + = FStarC_Compiler_Util.mk_ref [] +type saved_state = + { + toggles: (Prims.string * Prims.bool) Prims.list ; + any: Prims.bool ; + all: Prims.bool } +let (__proj__Mksaved_state__item__toggles : + saved_state -> (Prims.string * Prims.bool) Prims.list) = + fun projectee -> match projectee with | { toggles; any; all;_} -> toggles +let (__proj__Mksaved_state__item__any : saved_state -> Prims.bool) = + fun projectee -> match projectee with | { toggles; any; all;_} -> any +let (__proj__Mksaved_state__item__all : saved_state -> Prims.bool) = + fun projectee -> match projectee with | { toggles; any; all;_} -> all +let (snapshot : unit -> saved_state) = + fun uu___ -> + let uu___1 = + let uu___2 = FStarC_Compiler_Effect.op_Bang toggle_list in + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with + | (k, r) -> + let uu___4 = FStarC_Compiler_Effect.op_Bang r in (k, uu___4)) + uu___2 in + let uu___2 = FStarC_Compiler_Effect.op_Bang anyref in + let uu___3 = FStarC_Compiler_Effect.op_Bang _debug_all in + { toggles = uu___1; any = uu___2; all = uu___3 } +let (register_toggle : Prims.string -> Prims.bool FStarC_Compiler_Effect.ref) + = + fun k -> + let r = FStarC_Compiler_Util.mk_ref false in + (let uu___1 = FStarC_Compiler_Effect.op_Bang _debug_all in + if uu___1 then FStarC_Compiler_Effect.op_Colon_Equals r true else ()); + (let uu___2 = + let uu___3 = FStarC_Compiler_Effect.op_Bang toggle_list in (k, r) :: + uu___3 in + FStarC_Compiler_Effect.op_Colon_Equals toggle_list uu___2); + r +let (get_toggle : Prims.string -> Prims.bool FStarC_Compiler_Effect.ref) = + fun k -> + let uu___ = + let uu___1 = FStarC_Compiler_Effect.op_Bang toggle_list in + FStarC_Compiler_List.tryFind + (fun uu___2 -> match uu___2 with | (k', uu___3) -> k = k') uu___1 in + match uu___ with + | FStar_Pervasives_Native.Some (uu___1, r) -> r + | FStar_Pervasives_Native.None -> register_toggle k +let (restore : saved_state -> unit) = + fun snapshot1 -> + (let uu___1 = FStarC_Compiler_Effect.op_Bang toggle_list in + FStarC_Compiler_List.iter + (fun uu___2 -> + match uu___2 with + | (uu___3, r) -> FStarC_Compiler_Effect.op_Colon_Equals r false) + uu___1); + FStarC_Compiler_List.iter + (fun uu___2 -> + match uu___2 with + | (k, b) -> + let r = get_toggle k in + FStarC_Compiler_Effect.op_Colon_Equals r b) snapshot1.toggles; + FStarC_Compiler_Effect.op_Colon_Equals anyref snapshot1.any; + FStarC_Compiler_Effect.op_Colon_Equals _debug_all snapshot1.all +let (list_all_toggles : unit -> Prims.string Prims.list) = + fun uu___ -> + let uu___1 = FStarC_Compiler_Effect.op_Bang toggle_list in + FStarC_Compiler_List.map FStar_Pervasives_Native.fst uu___1 +let (any : unit -> Prims.bool) = + fun uu___ -> + (FStarC_Compiler_Effect.op_Bang anyref) || + (FStarC_Compiler_Effect.op_Bang _debug_all) +let (tag : Prims.string -> unit) = + fun s -> + let uu___ = any () in + if uu___ + then + FStarC_Compiler_Util.print_string + (Prims.strcat "DEBUG:" (Prims.strcat s "\n")) + else () +let (enable : unit -> unit) = + fun uu___ -> FStarC_Compiler_Effect.op_Colon_Equals anyref true +let (dbg_level : Prims.int FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref Prims.int_zero +let (low : unit -> Prims.bool) = + fun uu___ -> + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_level in + uu___1 >= Prims.int_one) || (FStarC_Compiler_Effect.op_Bang _debug_all) +let (medium : unit -> Prims.bool) = + fun uu___ -> + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_level in + uu___1 >= (Prims.of_int (2))) || + (FStarC_Compiler_Effect.op_Bang _debug_all) +let (high : unit -> Prims.bool) = + fun uu___ -> + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_level in + uu___1 >= (Prims.of_int (3))) || + (FStarC_Compiler_Effect.op_Bang _debug_all) +let (extreme : unit -> Prims.bool) = + fun uu___ -> + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_level in + uu___1 >= (Prims.of_int (4))) || + (FStarC_Compiler_Effect.op_Bang _debug_all) +let (set_level_low : unit -> unit) = + fun uu___ -> FStarC_Compiler_Effect.op_Colon_Equals dbg_level Prims.int_one +let (set_level_medium : unit -> unit) = + fun uu___ -> + FStarC_Compiler_Effect.op_Colon_Equals dbg_level (Prims.of_int (2)) +let (set_level_high : unit -> unit) = + fun uu___ -> + FStarC_Compiler_Effect.op_Colon_Equals dbg_level (Prims.of_int (3)) +let (set_level_extreme : unit -> unit) = + fun uu___ -> + FStarC_Compiler_Effect.op_Colon_Equals dbg_level (Prims.of_int (4)) +let (enable_toggles : Prims.string Prims.list -> unit) = + fun keys -> + if Prims.uu___is_Cons keys then enable () else (); + FStarC_Compiler_List.iter + (fun k -> + if k = "Low" + then set_level_low () + else + if k = "Medium" + then set_level_medium () + else + if k = "High" + then set_level_high () + else + if k = "Extreme" + then set_level_extreme () + else + (let t = get_toggle k in + FStarC_Compiler_Effect.op_Colon_Equals t true)) keys +let (disable_all : unit -> unit) = + fun uu___ -> + FStarC_Compiler_Effect.op_Colon_Equals anyref false; + FStarC_Compiler_Effect.op_Colon_Equals dbg_level Prims.int_zero; + (let uu___3 = FStarC_Compiler_Effect.op_Bang toggle_list in + FStarC_Compiler_List.iter + (fun uu___4 -> + match uu___4 with + | (uu___5, r) -> FStarC_Compiler_Effect.op_Colon_Equals r false) + uu___3) +let (set_debug_all : unit -> unit) = + fun uu___ -> FStarC_Compiler_Effect.op_Colon_Equals _debug_all true \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Compiler_FlatSet.ml b/ocaml/fstar-lib/generated/FStarC_Compiler_FlatSet.ml new file mode 100644 index 00000000000..f13282afffc --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Compiler_FlatSet.ml @@ -0,0 +1,140 @@ +open Prims +type 't flat_set = 't Prims.list +type 'a t = 'a flat_set +let rec add : + 'a . 'a FStarC_Class_Ord.ord -> 'a -> 'a flat_set -> 'a flat_set = + fun uu___ -> + fun x -> + fun s -> + match s with + | [] -> [x] + | y::yy -> + let uu___1 = + FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq uu___) x y in + if uu___1 + then s + else (let uu___3 = add uu___ x yy in y :: uu___3) +let empty : 'a . unit -> 'a flat_set = fun uu___ -> [] +let from_list : 'a . 'a FStarC_Class_Ord.ord -> 'a Prims.list -> 'a flat_set + = fun uu___ -> fun xs -> FStarC_Class_Ord.dedup uu___ xs +let mem : 'a . 'a FStarC_Class_Ord.ord -> 'a -> 'a flat_set -> Prims.bool = + fun uu___ -> + fun x -> + fun s -> + FStarC_Compiler_List.existsb + (fun y -> + FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq uu___) x y) s +let singleton : 'a . 'a FStarC_Class_Ord.ord -> 'a -> 'a flat_set = + fun uu___ -> fun x -> [x] +let is_empty : 'a . 'a flat_set -> Prims.bool = fun s -> Prims.uu___is_Nil s +let addn : + 'a . 'a FStarC_Class_Ord.ord -> 'a Prims.list -> 'a flat_set -> 'a flat_set + = + fun uu___ -> + fun xs -> fun ys -> FStarC_Compiler_List.fold_right (add uu___) xs ys +let rec remove : + 'a . 'a FStarC_Class_Ord.ord -> 'a -> 'a flat_set -> 'a flat_set = + fun uu___ -> + fun x -> + fun s -> + match s with + | [] -> [] + | y::yy -> + let uu___1 = + FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq uu___) x y in + if uu___1 + then yy + else (let uu___3 = remove uu___ x yy in y :: uu___3) +let elems : 'a . 'a flat_set -> 'a Prims.list = fun s -> s +let for_all : 'a . ('a -> Prims.bool) -> 'a flat_set -> Prims.bool = + fun p -> + fun s -> let uu___ = elems s in FStarC_Compiler_List.for_all p uu___ +let for_any : 'a . ('a -> Prims.bool) -> 'a flat_set -> Prims.bool = + fun p -> + fun s -> let uu___ = elems s in FStarC_Compiler_List.existsb p uu___ +let subset : + 'a . 'a FStarC_Class_Ord.ord -> 'a flat_set -> 'a flat_set -> Prims.bool = + fun uu___ -> fun s1 -> fun s2 -> for_all (fun y -> mem uu___ y s2) s1 +let equal : + 'a . 'a FStarC_Class_Ord.ord -> 'a flat_set -> 'a flat_set -> Prims.bool = + fun uu___ -> + fun s1 -> + fun s2 -> + let uu___1 = FStarC_Class_Ord.sort uu___ s1 in + let uu___2 = FStarC_Class_Ord.sort uu___ s2 in + FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq (FStarC_Class_Ord.ord_list uu___)) uu___1 + uu___2 +let union : + 'a . 'a FStarC_Class_Ord.ord -> 'a flat_set -> 'a flat_set -> 'a flat_set = + fun uu___ -> + fun s1 -> + fun s2 -> + FStarC_Compiler_List.fold_left (fun s -> fun x -> add uu___ x s) s1 + s2 +let inter : + 'a . 'a FStarC_Class_Ord.ord -> 'a flat_set -> 'a flat_set -> 'a flat_set = + fun uu___ -> + fun s1 -> + fun s2 -> FStarC_Compiler_List.filter (fun y -> mem uu___ y s2) s1 +let diff : + 'a . 'a FStarC_Class_Ord.ord -> 'a flat_set -> 'a flat_set -> 'a flat_set = + fun uu___ -> + fun s1 -> + fun s2 -> + FStarC_Compiler_List.filter + (fun y -> let uu___1 = mem uu___ y s2 in Prims.op_Negation uu___1) + s1 +let collect : + 'a 'b . + 'b FStarC_Class_Ord.ord -> + ('a -> 'b flat_set) -> 'a Prims.list -> 'b flat_set + = + fun uu___ -> + fun f -> + fun l -> + let uu___1 = empty () in + FStarC_Compiler_List.fold_right + (fun x -> fun acc -> let uu___2 = f x in union uu___ uu___2 acc) l + uu___1 +let showable_set : + 'a . + 'a FStarC_Class_Ord.ord -> + 'a FStarC_Class_Show.showable -> 'a flat_set FStarC_Class_Show.showable + = + fun uu___ -> + fun uu___1 -> + { + FStarC_Class_Show.show = + (fun s -> + let uu___2 = elems s in + FStarC_Class_Show.show (FStarC_Class_Show.show_list uu___1) + uu___2) + } +let setlike_flat_set : + 'a . + 'a FStarC_Class_Ord.ord -> ('a, 'a flat_set) FStarC_Class_Setlike.setlike + = + fun uu___ -> + { + FStarC_Class_Setlike.empty = empty; + FStarC_Class_Setlike.singleton = (singleton uu___); + FStarC_Class_Setlike.is_empty = is_empty; + FStarC_Class_Setlike.add = (add uu___); + FStarC_Class_Setlike.remove = (remove uu___); + FStarC_Class_Setlike.mem = (mem uu___); + FStarC_Class_Setlike.equal = (equal uu___); + FStarC_Class_Setlike.subset = (subset uu___); + FStarC_Class_Setlike.union = (union uu___); + FStarC_Class_Setlike.inter = (inter uu___); + FStarC_Class_Setlike.diff = (diff uu___); + FStarC_Class_Setlike.for_all = for_all; + FStarC_Class_Setlike.for_any = for_any; + FStarC_Class_Setlike.elems = elems; + FStarC_Class_Setlike.collect = (collect uu___); + FStarC_Class_Setlike.from_list = (from_list uu___); + FStarC_Class_Setlike.addn = (addn uu___) + } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Compiler_MachineInts.ml b/ocaml/fstar-lib/generated/FStarC_Compiler_MachineInts.ml new file mode 100644 index 00000000000..59e3087d9e3 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Compiler_MachineInts.ml @@ -0,0 +1,344 @@ +open Prims +type machint_kind = + | Int8 + | Int16 + | Int32 + | Int64 + | UInt8 + | UInt16 + | UInt32 + | UInt64 + | UInt128 + | SizeT +let (uu___is_Int8 : machint_kind -> Prims.bool) = + fun projectee -> match projectee with | Int8 -> true | uu___ -> false +let (uu___is_Int16 : machint_kind -> Prims.bool) = + fun projectee -> match projectee with | Int16 -> true | uu___ -> false +let (uu___is_Int32 : machint_kind -> Prims.bool) = + fun projectee -> match projectee with | Int32 -> true | uu___ -> false +let (uu___is_Int64 : machint_kind -> Prims.bool) = + fun projectee -> match projectee with | Int64 -> true | uu___ -> false +let (uu___is_UInt8 : machint_kind -> Prims.bool) = + fun projectee -> match projectee with | UInt8 -> true | uu___ -> false +let (uu___is_UInt16 : machint_kind -> Prims.bool) = + fun projectee -> match projectee with | UInt16 -> true | uu___ -> false +let (uu___is_UInt32 : machint_kind -> Prims.bool) = + fun projectee -> match projectee with | UInt32 -> true | uu___ -> false +let (uu___is_UInt64 : machint_kind -> Prims.bool) = + fun projectee -> match projectee with | UInt64 -> true | uu___ -> false +let (uu___is_UInt128 : machint_kind -> Prims.bool) = + fun projectee -> match projectee with | UInt128 -> true | uu___ -> false +let (uu___is_SizeT : machint_kind -> Prims.bool) = + fun projectee -> match projectee with | SizeT -> true | uu___ -> false +let (all_machint_kinds : machint_kind Prims.list) = + [Int8; Int16; Int32; Int64; UInt8; UInt16; UInt32; UInt64; UInt128; SizeT] +let (is_unsigned : machint_kind -> Prims.bool) = + fun k -> + match k with + | Int8 -> false + | Int16 -> false + | Int32 -> false + | Int64 -> false + | UInt8 -> true + | UInt16 -> true + | UInt32 -> true + | UInt64 -> true + | UInt128 -> true + | SizeT -> true +let (is_signed : machint_kind -> Prims.bool) = + fun k -> let uu___ = is_unsigned k in Prims.op_Negation uu___ +let (width : machint_kind -> Prims.int) = + fun k -> + match k with + | Int8 -> (Prims.of_int (8)) + | Int16 -> (Prims.of_int (16)) + | Int32 -> (Prims.of_int (32)) + | Int64 -> (Prims.of_int (64)) + | UInt8 -> (Prims.of_int (8)) + | UInt16 -> (Prims.of_int (16)) + | UInt32 -> (Prims.of_int (32)) + | UInt64 -> (Prims.of_int (64)) + | UInt128 -> (Prims.of_int (128)) + | SizeT -> (Prims.of_int (64)) +let (module_name_for : machint_kind -> Prims.string) = + fun k -> + match k with + | Int8 -> "Int8" + | Int16 -> "Int16" + | Int32 -> "Int32" + | Int64 -> "Int64" + | UInt8 -> "UInt8" + | UInt16 -> "UInt16" + | UInt32 -> "UInt32" + | UInt64 -> "UInt64" + | UInt128 -> "UInt128" + | SizeT -> "SizeT" +let (mask : machint_kind -> FStarC_BigInt.t) = + fun k -> + let uu___ = width k in + match uu___ with + | uu___1 when uu___1 = (Prims.of_int (8)) -> FStarC_BigInt.of_hex "ff" + | uu___1 when uu___1 = (Prims.of_int (16)) -> FStarC_BigInt.of_hex "ffff" + | uu___1 when uu___1 = (Prims.of_int (32)) -> + FStarC_BigInt.of_hex "ffffffff" + | uu___1 when uu___1 = (Prims.of_int (64)) -> + FStarC_BigInt.of_hex "ffffffffffffffff" + | uu___1 when uu___1 = (Prims.of_int (128)) -> + FStarC_BigInt.of_hex "ffffffffffffffffffffffffffffffff" +let (int_to_t_lid_for : machint_kind -> FStarC_Ident.lid) = + fun k -> + let path = + let uu___ = + let uu___1 = module_name_for k in + let uu___2 = + let uu___3 = + let uu___4 = is_unsigned k in + if uu___4 then "uint_to_t" else "int_to_t" in + [uu___3] in + uu___1 :: uu___2 in + "FStar" :: uu___ in + FStarC_Ident.lid_of_path path FStarC_Compiler_Range_Type.dummyRange +let (int_to_t_for : machint_kind -> FStarC_Syntax_Syntax.term) = + fun k -> + let lid = int_to_t_lid_for k in + FStarC_Syntax_Syntax.fvar lid FStar_Pervasives_Native.None +let (__int_to_t_lid_for : machint_kind -> FStarC_Ident.lid) = + fun k -> + let path = + let uu___ = + let uu___1 = module_name_for k in + let uu___2 = + let uu___3 = + let uu___4 = is_unsigned k in + if uu___4 then "__uint_to_t" else "__int_to_t" in + [uu___3] in + uu___1 :: uu___2 in + "FStar" :: uu___ in + FStarC_Ident.lid_of_path path FStarC_Compiler_Range_Type.dummyRange +let (__int_to_t_for : machint_kind -> FStarC_Syntax_Syntax.term) = + fun k -> + let lid = __int_to_t_lid_for k in + FStarC_Syntax_Syntax.fvar lid FStar_Pervasives_Native.None +type 'k machint = + | Mk of FStarC_BigInt.t * FStarC_Syntax_Syntax.meta_source_info + FStar_Pervasives_Native.option +let (uu___is_Mk : machint_kind -> unit machint -> Prims.bool) = + fun k -> fun projectee -> true +let (__proj__Mk__item___0 : machint_kind -> unit machint -> FStarC_BigInt.t) + = fun k -> fun projectee -> match projectee with | Mk (_0, _1) -> _0 +let (__proj__Mk__item___1 : + machint_kind -> + unit machint -> + FStarC_Syntax_Syntax.meta_source_info FStar_Pervasives_Native.option) + = fun k -> fun projectee -> match projectee with | Mk (_0, _1) -> _1 +let (mk : + machint_kind -> + FStarC_BigInt.t -> + FStarC_Syntax_Syntax.meta_source_info FStar_Pervasives_Native.option -> + unit machint) + = fun k -> fun x -> fun m -> Mk (x, m) +let (v : machint_kind -> unit machint -> FStarC_BigInt.t) = + fun k -> fun x -> let uu___ = x in match uu___ with | Mk (v1, uu___1) -> v1 +let (meta : + machint_kind -> + unit machint -> + FStarC_Syntax_Syntax.meta_source_info FStar_Pervasives_Native.option) + = + fun k -> + fun x -> let uu___ = x in match uu___ with | Mk (uu___1, meta1) -> meta1 +let (make_as : + machint_kind -> unit machint -> FStarC_BigInt.t -> unit machint) = + fun k -> fun x -> fun z -> let uu___ = meta k x in Mk (z, uu___) +let (showable_bounded_k : + machint_kind -> unit machint FStarC_Class_Show.showable) = + fun k -> + { + FStarC_Class_Show.show = + (fun uu___ -> + match uu___ with + | Mk (x, m) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_BigInt.to_int_fs x in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) uu___3 in + let uu___3 = + let uu___4 = module_name_for k in Prims.strcat "@@" uu___4 in + Prims.strcat uu___2 uu___3 in + Prims.strcat "machine integer " uu___1) + } +let (e_machint : + machint_kind -> unit machint FStarC_Syntax_Embeddings_Base.embedding) = + fun k -> + let with_meta_ds r t m = + match m with + | FStar_Pervasives_Native.None -> t + | FStar_Pervasives_Native.Some m1 -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 = t; + FStarC_Syntax_Syntax.meta = + (FStarC_Syntax_Syntax.Meta_desugared m1) + }) r in + let em x rng shadow cb = + let uu___ = x in + match uu___ with + | Mk (i, m) -> + let it = + let uu___1 = + FStarC_Syntax_Embeddings_Base.embed + FStarC_Syntax_Embeddings.e_int i in + uu___1 rng FStar_Pervasives_Native.None cb in + let int_to_t = int_to_t_for k in + let t = + let uu___1 = + let uu___2 = FStarC_Syntax_Syntax.as_arg it in [uu___2] in + FStarC_Syntax_Syntax.mk_Tm_app int_to_t uu___1 rng in + with_meta_ds rng t m in + let un uu___1 uu___ = + (fun t -> + fun cb -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress t in + uu___2.FStarC_Syntax_Syntax.n in + match uu___1 with + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t1; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_desugared m;_} + -> (t1, (FStar_Pervasives_Native.Some m)) + | uu___2 -> (t, FStar_Pervasives_Native.None) in + match uu___ with + | (t1, m) -> + let t2 = FStarC_Syntax_Util.unmeta_safe t1 in + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress t2 in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = hd; + FStarC_Syntax_Syntax.args = (a, uu___2)::[];_} + when + (let uu___3 = int_to_t_lid_for k in + FStarC_Syntax_Util.is_fvar uu___3 hd) || + (let uu___3 = __int_to_t_lid_for k in + FStarC_Syntax_Util.is_fvar uu___3 hd) + -> + Obj.magic + (Obj.repr + (let a1 = FStarC_Syntax_Util.unlazy_emb a in + let uu___3 = + FStarC_Syntax_Embeddings_Base.try_unembed + FStarC_Syntax_Embeddings.e_int a1 cb in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () + (Obj.magic uu___3) + (fun uu___4 -> + (fun a2 -> + let a2 = Obj.magic a2 in + Obj.magic + (FStar_Pervasives_Native.Some + (Mk (a2, m)))) uu___4))) + | uu___2 -> Obj.magic (Obj.repr FStar_Pervasives_Native.None))) + uu___1 uu___ in + FStarC_Syntax_Embeddings_Base.mk_emb_full em un + (fun uu___ -> + let uu___1 = + let uu___2 = + let uu___3 = let uu___4 = module_name_for k in [uu___4; "t"] in + "FStar" :: uu___3 in + FStarC_Ident.lid_of_path uu___2 + FStarC_Compiler_Range_Type.dummyRange in + FStarC_Syntax_Syntax.fvar uu___1 FStar_Pervasives_Native.None) + (fun uu___ -> "boundedint") + (fun uu___ -> FStarC_Syntax_Syntax.ET_abstract) +let (nbe_machint : + machint_kind -> unit machint FStarC_TypeChecker_NBETerm.embedding) = + fun k -> + let with_meta_ds t m = + match m with + | FStar_Pervasives_Native.None -> t + | FStar_Pervasives_Native.Some m1 -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Thunk.mk + (fun uu___3 -> FStarC_Syntax_Syntax.Meta_desugared m1) in + (t, uu___2) in + FStarC_TypeChecker_NBETerm.Meta uu___1 in + FStarC_TypeChecker_NBETerm.mk_t uu___ in + let em cbs x = + let uu___ = x in + match uu___ with + | Mk (i, m) -> + let it = + FStarC_TypeChecker_NBETerm.embed FStarC_TypeChecker_NBETerm.e_int + cbs i in + let int_to_t args = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = __int_to_t_lid_for k in + FStarC_Syntax_Syntax.lid_as_fv uu___4 + FStar_Pervasives_Native.None in + (uu___3, [], args) in + FStarC_TypeChecker_NBETerm.FV uu___2 in + FStarC_TypeChecker_NBETerm.mk_t uu___1 in + let t = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.as_arg it in [uu___2] in + int_to_t uu___1 in + with_meta_ds t m in + let un uu___1 uu___ = + (fun cbs -> + fun a -> + let uu___ = + match a.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Meta (t, tm) -> + let uu___1 = FStarC_Thunk.force tm in + (match uu___1 with + | FStarC_Syntax_Syntax.Meta_desugared m -> + (t, (FStar_Pervasives_Native.Some m)) + | uu___2 -> (a, FStar_Pervasives_Native.None)) + | uu___1 -> (a, FStar_Pervasives_Native.None) in + match uu___ with + | (a1, m) -> + (match a1.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.FV (fv1, [], (a2, uu___1)::[]) + when + let uu___2 = int_to_t_lid_for k in + FStarC_Ident.lid_equals + (fv1.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + uu___2 + -> + Obj.magic + (Obj.repr + (let uu___2 = + FStarC_TypeChecker_NBETerm.unembed + FStarC_TypeChecker_NBETerm.e_int cbs a2 in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () + (Obj.magic uu___2) + (fun uu___3 -> + (fun a3 -> + let a3 = Obj.magic a3 in + Obj.magic + (FStar_Pervasives_Native.Some + (Mk (a3, m)))) uu___3))) + | uu___1 -> Obj.magic (Obj.repr FStar_Pervasives_Native.None))) + uu___1 uu___ in + FStarC_TypeChecker_NBETerm.mk_emb em un + (fun uu___ -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = let uu___5 = module_name_for k in [uu___5; "t"] in + "FStar" :: uu___4 in + FStarC_Ident.lid_of_path uu___3 + FStarC_Compiler_Range_Type.dummyRange in + FStarC_Syntax_Syntax.lid_as_fv uu___2 FStar_Pervasives_Native.None in + FStarC_TypeChecker_NBETerm.mkFV uu___1 [] []) + (fun uu___ -> FStarC_Syntax_Syntax.ET_abstract) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Compiler_Misc.ml b/ocaml/fstar-lib/generated/FStarC_Compiler_Misc.ml new file mode 100644 index 00000000000..878c4f94841 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Compiler_Misc.ml @@ -0,0 +1,21 @@ +open Prims +let (compare_version : + Prims.string -> Prims.string -> FStarC_Compiler_Order.order) = + fun v1 -> + fun v2 -> + let cs1 = + FStarC_Compiler_List.map FStarC_Compiler_Util.int_of_string + (FStarC_Compiler_String.split [46] v1) in + let cs2 = + FStarC_Compiler_List.map FStarC_Compiler_Util.int_of_string + (FStarC_Compiler_String.split [46] v2) in + FStarC_Compiler_Order.compare_list cs1 cs2 + FStarC_Compiler_Order.compare_int +let (version_gt : Prims.string -> Prims.string -> Prims.bool) = + fun v1 -> + fun v2 -> + let uu___ = compare_version v1 v2 in uu___ = FStarC_Compiler_Order.Gt +let (version_ge : Prims.string -> Prims.string -> Prims.bool) = + fun v1 -> + fun v2 -> + let uu___ = compare_version v1 v2 in uu___ <> FStarC_Compiler_Order.Lt \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Compiler_Option.ml b/ocaml/fstar-lib/generated/FStarC_Compiler_Option.ml similarity index 100% rename from ocaml/fstar-lib/generated/FStar_Compiler_Option.ml rename to ocaml/fstar-lib/generated/FStarC_Compiler_Option.ml diff --git a/ocaml/fstar-lib/generated/FStar_Compiler_Order.ml b/ocaml/fstar-lib/generated/FStarC_Compiler_Order.ml similarity index 100% rename from ocaml/fstar-lib/generated/FStar_Compiler_Order.ml rename to ocaml/fstar-lib/generated/FStarC_Compiler_Order.ml diff --git a/ocaml/fstar-lib/generated/FStarC_Compiler_Path.ml b/ocaml/fstar-lib/generated/FStarC_Compiler_Path.ml new file mode 100644 index 00000000000..ca3738842b4 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Compiler_Path.ml @@ -0,0 +1,29 @@ +open Prims +type 'a path = 'a Prims.list +type ('a, 'qual) forest = (('a path * 'qual) Prims.list * 'qual) +let rec is_under : + 'a . 'a FStarC_Class_Deq.deq -> 'a path -> 'a path -> Prims.bool = + fun uu___ -> + fun p1 -> + fun p2 -> + match (p1, p2) with + | (uu___1, []) -> true + | ([], uu___1) -> false + | (h1::t1, h2::t2) -> + (FStarC_Class_Deq.op_Equals_Question uu___ h1 h2) && + (is_under uu___ t1 t2) +let search_forest : + 'a 'q . 'a FStarC_Class_Deq.deq -> 'a path -> ('a, 'q) forest -> 'q = + fun uu___ -> + fun p -> + fun f -> + let uu___1 = f in + match uu___1 with + | (roots, def) -> + let rec aux roots1 = + match roots1 with + | [] -> def + | (r, q1)::rs -> + let uu___2 = is_under uu___ p r in + if uu___2 then q1 else aux rs in + aux roots \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Compiler_Plugins.ml b/ocaml/fstar-lib/generated/FStarC_Compiler_Plugins.ml new file mode 100644 index 00000000000..280207791cd --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Compiler_Plugins.ml @@ -0,0 +1,197 @@ +open Prims +let (loaded : Prims.string Prims.list FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref [] +let (pout : Prims.string -> unit) = + fun s -> + let uu___ = FStarC_Compiler_Debug.any () in + if uu___ then FStarC_Compiler_Util.print_string s else () +let (pout1 : Prims.string -> Prims.string -> unit) = + fun s -> + fun x -> + let uu___ = FStarC_Compiler_Debug.any () in + if uu___ then FStarC_Compiler_Util.print1 s x else () +let (perr : Prims.string -> unit) = + fun s -> + let uu___ = FStarC_Compiler_Debug.any () in + if uu___ then FStarC_Compiler_Util.print_error s else () +let (perr1 : Prims.string -> Prims.string -> unit) = + fun s -> + fun x -> + let uu___ = FStarC_Compiler_Debug.any () in + if uu___ then FStarC_Compiler_Util.print1_error s x else () +let (dynlink : Prims.string -> unit) = + fun fname -> + let uu___ = + let uu___1 = FStarC_Compiler_Effect.op_Bang loaded in + FStarC_Compiler_List.mem fname uu___1 in + if uu___ + then pout1 "Plugin %s already loaded, skipping\n" fname + else + (pout (Prims.strcat "Attempting to load " (Prims.strcat fname "\n")); + (try + (fun uu___4 -> + match () with + | () -> FStarC_Compiler_Plugins_Base.dynlink_loadfile fname) () + with + | FStarC_Compiler_Plugins_Base.DynlinkError e -> + ((let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Compiler_Util.format1 + "Failed to load plugin file %s" fname in + FStarC_Errors_Msg.text uu___8 in + let uu___8 = + let uu___9 = + let uu___10 = FStarC_Errors_Msg.text "Reason:" in + let uu___11 = FStarC_Errors_Msg.text e in + FStarC_Pprint.prefix (Prims.of_int (2)) Prims.int_one + uu___10 uu___11 in + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_Errors.errno + FStarC_Errors_Codes.Error_PluginDynlink in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) uu___14 in + FStarC_Compiler_Util.format1 + "Remove the `--load` option or use `--warn_error -%s` to ignore and continue." + uu___13 in + FStarC_Errors_Msg.text uu___12 in + [uu___11] in + uu___9 :: uu___10 in + uu___7 :: uu___8 in + FStarC_Errors.log_issue0 + FStarC_Errors_Codes.Error_PluginDynlink () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___6)); + FStarC_Errors.stop_if_err ())); + (let uu___5 = + let uu___6 = FStarC_Compiler_Effect.op_Bang loaded in fname :: + uu___6 in + FStarC_Compiler_Effect.op_Colon_Equals loaded uu___5); + pout1 "Loaded %s\n" fname) +let (load_plugin : Prims.string -> unit) = fun tac -> dynlink tac +let (load_plugins : Prims.string Prims.list -> unit) = + fun tacs -> FStarC_Compiler_List.iter load_plugin tacs +let (load_plugins_dir : Prims.string -> unit) = + fun dir -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Compiler_Util.readdir dir in + FStarC_Compiler_List.filter + (fun s -> + ((FStarC_Compiler_String.length s) >= (Prims.of_int (5))) && + ((FStar_String.sub s + ((FStarC_Compiler_String.length s) - (Prims.of_int (5))) + (Prims.of_int (5))) + = ".cmxs")) uu___2 in + FStarC_Compiler_List.map + (fun s -> Prims.strcat dir (Prims.strcat "/" s)) uu___1 in + load_plugins uu___ +let (compile_modules : Prims.string -> Prims.string Prims.list -> unit) = + fun dir -> + fun ms -> + let compile m = + let packages = ["fstar.lib"] in + let pkg pname = Prims.strcat "-package " pname in + let args = + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Compiler_List.map pkg packages in + FStar_List_Tot_Base.append uu___3 + ["-o"; Prims.strcat m ".cmxs"; Prims.strcat m ".ml"] in + FStar_List_Tot_Base.append ["-w"; "-8-11-20-21-26-28"] uu___2 in + FStar_List_Tot_Base.append ["-I"; dir] uu___1 in + FStar_List_Tot_Base.append ["ocamlopt"; "-shared"] uu___ in + let ocamlpath_sep = + match FStarC_Platform.system with + | FStarC_Platform.Windows -> ";" + | FStarC_Platform.Posix -> ":" in + let old_ocamlpath = + let uu___ = + FStarC_Compiler_Util.expand_environment_variable "OCAMLPATH" in + match uu___ with + | FStar_Pervasives_Native.Some s -> s + | FStar_Pervasives_Native.None -> "" in + let env_setter = + FStarC_Compiler_Util.format5 + "env OCAMLPATH=\"%s/../lib/%s%s/%s%s\"" + FStarC_Options.fstar_bin_directory ocamlpath_sep + FStarC_Options.fstar_bin_directory ocamlpath_sep old_ocamlpath in + let cmd = + FStarC_Compiler_String.concat " " (env_setter :: "ocamlfind" :: + args) in + let rc = FStarC_Compiler_Util.system_run cmd in + if rc <> Prims.int_zero + then + let uu___ = + let uu___1 = + FStarC_Errors_Msg.text "Failed to compile native tactic." in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) rc in + FStarC_Compiler_Util.format2 + "Command\n`%s`\nreturned with exit code %s" cmd uu___5 in + FStarC_Errors_Msg.text uu___4 in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_FailToCompileNativeTactic () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___) + else () in + try + (fun uu___ -> + match () with + | () -> + let uu___1 = + FStarC_Compiler_List.map + (fun m -> Prims.strcat dir (Prims.strcat "/" m)) ms in + FStarC_Compiler_List.iter compile uu___1) () + with + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_Compiler_Util.print_exn uu___ in + FStarC_Compiler_Util.format1 + "Failed to load native tactic: %s\n" uu___3 in + perr uu___2); + FStarC_Compiler_Effect.raise uu___) +let (autoload_plugin : Prims.string -> Prims.bool) = + fun ext -> + let uu___ = + let uu___1 = FStarC_Options_Ext.get "noautoload" in uu___1 <> "" in + if uu___ + then false + else + ((let uu___3 = FStarC_Compiler_Debug.any () in + if uu___3 + then + FStarC_Compiler_Util.print1 + "Trying to find a plugin for extension %s\n" ext + else ()); + (let uu___3 = FStarC_Find.find_file (Prims.strcat ext ".cmxs") in + match uu___3 with + | FStar_Pervasives_Native.Some fn -> + let uu___4 = + let uu___5 = FStarC_Compiler_Effect.op_Bang loaded in + FStarC_Compiler_List.mem fn uu___5 in + if uu___4 + then false + else + ((let uu___7 = FStarC_Compiler_Debug.any () in + if uu___7 + then + FStarC_Compiler_Util.print1 "Autoloading plugin %s ...\n" + fn + else ()); + load_plugin fn; + true) + | FStar_Pervasives_Native.None -> false)) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Compiler_RBSet.ml b/ocaml/fstar-lib/generated/FStarC_Compiler_RBSet.ml new file mode 100644 index 00000000000..ed36aa37c18 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Compiler_RBSet.ml @@ -0,0 +1,230 @@ +open Prims +type color = + | R + | B +let (uu___is_R : color -> Prims.bool) = + fun projectee -> match projectee with | R -> true | uu___ -> false +let (uu___is_B : color -> Prims.bool) = + fun projectee -> match projectee with | B -> true | uu___ -> false +type 'a rbset = + | L + | N of (color * 'a rbset * 'a * 'a rbset) +let uu___is_L : 'a . 'a rbset -> Prims.bool = + fun projectee -> match projectee with | L -> true | uu___ -> false +let uu___is_N : 'a . 'a rbset -> Prims.bool = + fun projectee -> match projectee with | N _0 -> true | uu___ -> false +let __proj__N__item___0 : 'a . 'a rbset -> (color * 'a rbset * 'a * 'a rbset) + = fun projectee -> match projectee with | N _0 -> _0 +type 'a t = 'a rbset +let empty : 'uuuuu . unit -> 'uuuuu rbset = fun uu___ -> L +let singleton : 'a . 'a -> 'a rbset = fun x -> N (R, L, x, L) +let is_empty : 'uuuuu . unit -> 'uuuuu rbset -> Prims.bool = + fun uu___ -> uu___is_L +let balance : + 'uuuuu . color -> 'uuuuu rbset -> 'uuuuu -> 'uuuuu rbset -> 'uuuuu rbset = + fun c -> + fun l -> + fun x -> + fun r -> + match (c, l, x, r) with + | (B, N (R, N (R, a, x1, b), y, c1), z, d) -> + N (R, (N (B, a, x1, b)), y, (N (B, c1, z, d))) + | (B, a, x1, N (R, N (R, b, y, c1), z, d)) -> + N (R, (N (B, a, x1, b)), y, (N (B, c1, z, d))) + | (B, N (R, a, x1, N (R, b, y, c1)), z, d) -> + N (R, (N (B, a, x1, b)), y, (N (B, c1, z, d))) + | (B, a, x1, N (R, b, y, N (R, c1, z, d))) -> + N (R, (N (B, a, x1, b)), y, (N (B, c1, z, d))) + | (c1, l1, x1, r1) -> N (c1, l1, x1, r1) +let blackroot : 'a . 'a rbset -> 'a rbset = + fun t1 -> match t1 with | N (uu___, l, x, r) -> N (B, l, x, r) +let add : 'a . 'a FStarC_Class_Ord.ord -> 'a -> 'a rbset -> 'a rbset = + fun uu___ -> + fun x -> + fun s -> + let rec add' s1 = + match s1 with + | L -> N (R, L, x, L) + | N (c, a1, y, b) -> + let uu___1 = FStarC_Class_Ord.op_Less_Question uu___ x y in + if uu___1 + then let uu___2 = add' a1 in balance c uu___2 y b + else + (let uu___3 = FStarC_Class_Ord.op_Greater_Question uu___ x y in + if uu___3 + then let uu___4 = add' b in balance c a1 y uu___4 + else s1) in + let uu___1 = add' s in blackroot uu___1 +let rec extract_min : + 'a . 'a FStarC_Class_Ord.ord -> 'a rbset -> ('a rbset * 'a) = + fun uu___ -> + fun t1 -> + match t1 with + | N (uu___1, L, x, r) -> (r, x) + | N (c, a1, x, b) -> + let uu___1 = extract_min uu___ a1 in + (match uu___1 with | (a', y) -> ((balance c a' x b), y)) +let rec remove : 'a . 'a FStarC_Class_Ord.ord -> 'a -> 'a rbset -> 'a rbset = + fun uu___ -> + fun x -> + fun t1 -> + match t1 with + | L -> L + | N (c, l, y, r) -> + let uu___1 = FStarC_Class_Ord.op_Less_Question uu___ x y in + if uu___1 + then let uu___2 = remove uu___ x l in balance c uu___2 y r + else + (let uu___3 = FStarC_Class_Ord.op_Greater_Question uu___ x y in + if uu___3 + then let uu___4 = remove uu___ x r in balance c l y uu___4 + else + if uu___is_L r + then l + else + (let uu___6 = extract_min uu___ r in + match uu___6 with | (r', y') -> balance c l y' r')) +let rec mem : 'a . 'a FStarC_Class_Ord.ord -> 'a -> 'a rbset -> Prims.bool = + fun uu___ -> + fun x -> + fun s -> + match s with + | L -> false + | N (uu___1, a1, y, b) -> + let uu___2 = FStarC_Class_Ord.op_Less_Question uu___ x y in + if uu___2 + then mem uu___ x a1 + else + (let uu___4 = FStarC_Class_Ord.op_Greater_Question uu___ x y in + if uu___4 then mem uu___ x b else true) +let rec elems : 'a . 'a rbset -> 'a Prims.list = + fun s -> + match s with + | L -> [] + | N (uu___, a1, x, b) -> + let uu___1 = elems a1 in + let uu___2 = + let uu___3 = elems b in FStar_List_Tot_Base.append [x] uu___3 in + FStar_List_Tot_Base.append uu___1 uu___2 +let equal : + 'a . 'a FStarC_Class_Ord.ord -> 'a rbset -> 'a rbset -> Prims.bool = + fun uu___ -> + fun s1 -> + fun s2 -> + let uu___1 = elems s1 in + let uu___2 = elems s2 in + FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq (FStarC_Class_Ord.ord_list uu___)) uu___1 + uu___2 +let rec union : + 'a . 'a FStarC_Class_Ord.ord -> 'a rbset -> 'a rbset -> 'a rbset = + fun uu___ -> + fun s1 -> + fun s2 -> + match s1 with + | L -> s2 + | N (c, a1, x, b) -> + let uu___1 = let uu___2 = add uu___ x s2 in union uu___ b uu___2 in + union uu___ a1 uu___1 +let inter : 'a . 'a FStarC_Class_Ord.ord -> 'a rbset -> 'a rbset -> 'a rbset + = + fun uu___ -> + fun s1 -> + fun s2 -> + let rec aux s11 acc = + match s11 with + | L -> acc + | N (uu___1, a1, x, b) -> + let uu___2 = mem uu___ x s2 in + if uu___2 + then + let uu___3 = let uu___4 = aux b acc in aux a1 uu___4 in + add uu___ x uu___3 + else (let uu___4 = aux b acc in aux a1 uu___4) in + aux s1 L +let rec diff : + 'a . 'a FStarC_Class_Ord.ord -> 'a rbset -> 'a rbset -> 'a rbset = + fun uu___ -> + fun s1 -> + fun s2 -> + match s2 with + | L -> s1 + | N (uu___1, a1, x, b) -> + let uu___2 = + let uu___3 = remove uu___ x s1 in diff uu___ uu___3 a1 in + diff uu___ uu___2 b +let rec subset : + 'a . 'a FStarC_Class_Ord.ord -> 'a rbset -> 'a rbset -> Prims.bool = + fun uu___ -> + fun s1 -> + fun s2 -> + match s1 with + | L -> true + | N (uu___1, a1, x, b) -> + ((mem uu___ x s2) && (subset uu___ a1 s2)) && (subset uu___ b s2) +let rec for_all : 'a . ('a -> Prims.bool) -> 'a rbset -> Prims.bool = + fun p -> + fun s -> + match s with + | L -> true + | N (uu___, a1, x, b) -> ((p x) && (for_all p a1)) && (for_all p b) +let rec for_any : 'a . ('a -> Prims.bool) -> 'a rbset -> Prims.bool = + fun p -> + fun s -> + match s with + | L -> false + | N (uu___, a1, x, b) -> ((p x) || (for_any p a1)) || (for_any p b) +let from_list : 'a . 'a FStarC_Class_Ord.ord -> 'a Prims.list -> 'a rbset = + fun uu___ -> + fun xs -> + FStarC_Compiler_List.fold_left (fun s -> fun e -> add uu___ e s) L xs +let addn : + 'a . 'a FStarC_Class_Ord.ord -> 'a Prims.list -> 'a rbset -> 'a rbset = + fun uu___ -> + fun xs -> + fun s -> + FStarC_Compiler_List.fold_left (fun s1 -> fun e -> add uu___ e s1) s + xs +let collect : + 'a . + 'a FStarC_Class_Ord.ord -> ('a -> 'a rbset) -> 'a Prims.list -> 'a rbset + = + fun uu___ -> + fun f -> + fun l -> + FStarC_Compiler_List.fold_left + (fun s -> fun e -> let uu___1 = f e in union uu___ uu___1 s) L l +let setlike_rbset : + 'a . 'a FStarC_Class_Ord.ord -> ('a, 'a t) FStarC_Class_Setlike.setlike = + fun uu___ -> + { + FStarC_Class_Setlike.empty = empty; + FStarC_Class_Setlike.singleton = singleton; + FStarC_Class_Setlike.is_empty = (is_empty ()); + FStarC_Class_Setlike.add = (add uu___); + FStarC_Class_Setlike.remove = (remove uu___); + FStarC_Class_Setlike.mem = (mem uu___); + FStarC_Class_Setlike.equal = (equal uu___); + FStarC_Class_Setlike.subset = (subset uu___); + FStarC_Class_Setlike.union = (union uu___); + FStarC_Class_Setlike.inter = (inter uu___); + FStarC_Class_Setlike.diff = (diff uu___); + FStarC_Class_Setlike.for_all = for_all; + FStarC_Class_Setlike.for_any = for_any; + FStarC_Class_Setlike.elems = elems; + FStarC_Class_Setlike.collect = (collect uu___); + FStarC_Class_Setlike.from_list = (from_list uu___); + FStarC_Class_Setlike.addn = (addn uu___) + } +let showable_rbset : + 'a . 'a FStarC_Class_Show.showable -> 'a t FStarC_Class_Show.showable = + fun uu___ -> + { + FStarC_Class_Show.show = + (fun s -> + let uu___1 = + let uu___2 = elems s in + FStarC_Class_Show.show (FStarC_Class_Show.show_list uu___) + uu___2 in + Prims.strcat "RBSet " uu___1) + } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Compiler_Range_Ops.ml b/ocaml/fstar-lib/generated/FStarC_Compiler_Range_Ops.ml new file mode 100644 index 00000000000..cf25997322d --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Compiler_Range_Ops.ml @@ -0,0 +1,313 @@ +open Prims +let (union_rng : + FStarC_Compiler_Range_Type.rng -> + FStarC_Compiler_Range_Type.rng -> FStarC_Compiler_Range_Type.rng) + = + fun r1 -> + fun r2 -> + if + r1.FStarC_Compiler_Range_Type.file_name <> + r2.FStarC_Compiler_Range_Type.file_name + then r2 + else + (let start_pos = + FStarC_Class_Ord.min FStarC_Compiler_Range_Type.ord_pos + r1.FStarC_Compiler_Range_Type.start_pos + r2.FStarC_Compiler_Range_Type.start_pos in + let end_pos = + FStarC_Class_Ord.max FStarC_Compiler_Range_Type.ord_pos + r1.FStarC_Compiler_Range_Type.end_pos + r2.FStarC_Compiler_Range_Type.end_pos in + FStarC_Compiler_Range_Type.mk_rng + r1.FStarC_Compiler_Range_Type.file_name start_pos end_pos) +let (union_ranges : + FStarC_Compiler_Range_Type.range -> + FStarC_Compiler_Range_Type.range -> FStarC_Compiler_Range_Type.range) + = + fun r1 -> + fun r2 -> + let uu___ = + union_rng r1.FStarC_Compiler_Range_Type.def_range + r2.FStarC_Compiler_Range_Type.def_range in + let uu___1 = + union_rng r1.FStarC_Compiler_Range_Type.use_range + r2.FStarC_Compiler_Range_Type.use_range in + { + FStarC_Compiler_Range_Type.def_range = uu___; + FStarC_Compiler_Range_Type.use_range = uu___1 + } +let (rng_included : + FStarC_Compiler_Range_Type.rng -> + FStarC_Compiler_Range_Type.rng -> Prims.bool) + = + fun r1 -> + fun r2 -> + if + r1.FStarC_Compiler_Range_Type.file_name <> + r2.FStarC_Compiler_Range_Type.file_name + then false + else + (FStarC_Class_Ord.op_Less_Equals_Question + FStarC_Compiler_Range_Type.ord_pos + r2.FStarC_Compiler_Range_Type.start_pos + r1.FStarC_Compiler_Range_Type.start_pos) + && + (FStarC_Class_Ord.op_Greater_Equals_Question + FStarC_Compiler_Range_Type.ord_pos + r2.FStarC_Compiler_Range_Type.end_pos + r1.FStarC_Compiler_Range_Type.end_pos) +let (string_of_pos : FStarC_Compiler_Range_Type.pos -> Prims.string) = + fun pos -> + let uu___ = + FStarC_Compiler_Util.string_of_int pos.FStarC_Compiler_Range_Type.line in + let uu___1 = + FStarC_Compiler_Util.string_of_int pos.FStarC_Compiler_Range_Type.col in + FStarC_Compiler_Util.format2 "%s,%s" uu___ uu___1 +let (string_of_file_name : Prims.string -> Prims.string) = + fun f -> + let uu___ = + let uu___1 = FStarC_Options_Ext.get "fstar:no_absolute_paths" in + uu___1 = "1" in + if uu___ + then FStarC_Compiler_Util.basename f + else + (let uu___2 = FStarC_Options.ide () in + if uu___2 + then + try + (fun uu___3 -> + match () with + | () -> + let uu___4 = + let uu___5 = FStarC_Compiler_Util.basename f in + FStarC_Find.find_file uu___5 in + (match uu___4 with + | FStar_Pervasives_Native.None -> f + | FStar_Pervasives_Native.Some absolute_path -> + absolute_path)) () + with | uu___3 -> f + else f) +let (file_of_range : FStarC_Compiler_Range_Type.range -> Prims.string) = + fun r -> + let f = + (r.FStarC_Compiler_Range_Type.def_range).FStarC_Compiler_Range_Type.file_name in + string_of_file_name f +let (set_file_of_range : + FStarC_Compiler_Range_Type.range -> + Prims.string -> FStarC_Compiler_Range_Type.range) + = + fun r -> + fun f -> + { + FStarC_Compiler_Range_Type.def_range = + (let uu___ = r.FStarC_Compiler_Range_Type.def_range in + { + FStarC_Compiler_Range_Type.file_name = f; + FStarC_Compiler_Range_Type.start_pos = + (uu___.FStarC_Compiler_Range_Type.start_pos); + FStarC_Compiler_Range_Type.end_pos = + (uu___.FStarC_Compiler_Range_Type.end_pos) + }); + FStarC_Compiler_Range_Type.use_range = + (r.FStarC_Compiler_Range_Type.use_range) + } +let (string_of_rng : FStarC_Compiler_Range_Type.rng -> Prims.string) = + fun r -> + let uu___ = string_of_file_name r.FStarC_Compiler_Range_Type.file_name in + let uu___1 = string_of_pos r.FStarC_Compiler_Range_Type.start_pos in + let uu___2 = string_of_pos r.FStarC_Compiler_Range_Type.end_pos in + FStarC_Compiler_Util.format3 "%s(%s-%s)" uu___ uu___1 uu___2 +let (string_of_def_range : FStarC_Compiler_Range_Type.range -> Prims.string) + = fun r -> string_of_rng r.FStarC_Compiler_Range_Type.def_range +let (string_of_use_range : FStarC_Compiler_Range_Type.range -> Prims.string) + = fun r -> string_of_rng r.FStarC_Compiler_Range_Type.use_range +let (string_of_range : FStarC_Compiler_Range_Type.range -> Prims.string) = + fun r -> string_of_def_range r +let (start_of_range : + FStarC_Compiler_Range_Type.range -> FStarC_Compiler_Range_Type.pos) = + fun r -> + (r.FStarC_Compiler_Range_Type.def_range).FStarC_Compiler_Range_Type.start_pos +let (end_of_range : + FStarC_Compiler_Range_Type.range -> FStarC_Compiler_Range_Type.pos) = + fun r -> + (r.FStarC_Compiler_Range_Type.def_range).FStarC_Compiler_Range_Type.end_pos +let (file_of_use_range : FStarC_Compiler_Range_Type.range -> Prims.string) = + fun r -> + (r.FStarC_Compiler_Range_Type.use_range).FStarC_Compiler_Range_Type.file_name +let (start_of_use_range : + FStarC_Compiler_Range_Type.range -> FStarC_Compiler_Range_Type.pos) = + fun r -> + (r.FStarC_Compiler_Range_Type.use_range).FStarC_Compiler_Range_Type.start_pos +let (end_of_use_range : + FStarC_Compiler_Range_Type.range -> FStarC_Compiler_Range_Type.pos) = + fun r -> + (r.FStarC_Compiler_Range_Type.use_range).FStarC_Compiler_Range_Type.end_pos +let (line_of_pos : FStarC_Compiler_Range_Type.pos -> Prims.int) = + fun p -> p.FStarC_Compiler_Range_Type.line +let (col_of_pos : FStarC_Compiler_Range_Type.pos -> Prims.int) = + fun p -> p.FStarC_Compiler_Range_Type.col +let (end_range : + FStarC_Compiler_Range_Type.range -> FStarC_Compiler_Range_Type.range) = + fun r -> + FStarC_Compiler_Range_Type.mk_range + (r.FStarC_Compiler_Range_Type.def_range).FStarC_Compiler_Range_Type.file_name + (r.FStarC_Compiler_Range_Type.def_range).FStarC_Compiler_Range_Type.end_pos + (r.FStarC_Compiler_Range_Type.def_range).FStarC_Compiler_Range_Type.end_pos +let (compare_rng : + FStarC_Compiler_Range_Type.rng -> + FStarC_Compiler_Range_Type.rng -> Prims.int) + = + fun r1 -> + fun r2 -> + let fcomp = + FStar_String.compare r1.FStarC_Compiler_Range_Type.file_name + r2.FStarC_Compiler_Range_Type.file_name in + if fcomp = Prims.int_zero + then + let start1 = r1.FStarC_Compiler_Range_Type.start_pos in + let start2 = r2.FStarC_Compiler_Range_Type.start_pos in + let lcomp = + start1.FStarC_Compiler_Range_Type.line - + start2.FStarC_Compiler_Range_Type.line in + (if lcomp = Prims.int_zero + then + start1.FStarC_Compiler_Range_Type.col - + start2.FStarC_Compiler_Range_Type.col + else lcomp) + else fcomp +let (compare : + FStarC_Compiler_Range_Type.range -> + FStarC_Compiler_Range_Type.range -> Prims.int) + = + fun r1 -> + fun r2 -> + compare_rng r1.FStarC_Compiler_Range_Type.def_range + r2.FStarC_Compiler_Range_Type.def_range +let (compare_use_range : + FStarC_Compiler_Range_Type.range -> + FStarC_Compiler_Range_Type.range -> Prims.int) + = + fun r1 -> + fun r2 -> + compare_rng r1.FStarC_Compiler_Range_Type.use_range + r2.FStarC_Compiler_Range_Type.use_range +let (range_before_pos : + FStarC_Compiler_Range_Type.range -> + FStarC_Compiler_Range_Type.pos -> Prims.bool) + = + fun m1 -> + fun p -> + let uu___ = end_of_range m1 in + FStarC_Class_Ord.op_Greater_Equals_Question + FStarC_Compiler_Range_Type.ord_pos p uu___ +let (end_of_line : + FStarC_Compiler_Range_Type.pos -> FStarC_Compiler_Range_Type.pos) = + fun p -> + { + FStarC_Compiler_Range_Type.line = (p.FStarC_Compiler_Range_Type.line); + FStarC_Compiler_Range_Type.col = FStarC_Compiler_Util.max_int + } +let (extend_to_end_of_line : + FStarC_Compiler_Range_Type.range -> FStarC_Compiler_Range_Type.range) = + fun r -> + let uu___ = file_of_range r in + let uu___1 = start_of_range r in + let uu___2 = let uu___3 = end_of_range r in end_of_line uu___3 in + FStarC_Compiler_Range_Type.mk_range uu___ uu___1 uu___2 +let (json_of_pos : FStarC_Compiler_Range_Type.pos -> FStarC_Json.json) = + fun pos -> + let uu___ = + let uu___1 = let uu___2 = line_of_pos pos in FStarC_Json.JsonInt uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = col_of_pos pos in FStarC_Json.JsonInt uu___4 in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Json.JsonList uu___ +let (json_of_range_fields : + Prims.string -> + FStarC_Compiler_Range_Type.pos -> + FStarC_Compiler_Range_Type.pos -> FStarC_Json.json) + = + fun file -> + fun b -> + fun e -> + let uu___ = + let uu___1 = + let uu___2 = let uu___3 = json_of_pos b in ("beg", uu___3) in + let uu___3 = + let uu___4 = let uu___5 = json_of_pos e in ("end", uu___5) in + [uu___4] in + uu___2 :: uu___3 in + ("fname", (FStarC_Json.JsonStr file)) :: uu___1 in + FStarC_Json.JsonAssoc uu___ +let (json_of_use_range : + FStarC_Compiler_Range_Type.range -> FStarC_Json.json) = + fun r -> + let uu___ = file_of_use_range r in + let uu___1 = start_of_use_range r in + let uu___2 = end_of_use_range r in + json_of_range_fields uu___ uu___1 uu___2 +let (json_of_def_range : + FStarC_Compiler_Range_Type.range -> FStarC_Json.json) = + fun r -> + let uu___ = file_of_range r in + let uu___1 = start_of_range r in + let uu___2 = end_of_range r in json_of_range_fields uu___ uu___1 uu___2 +let (intersect_rng : + FStarC_Compiler_Range_Type.rng -> + FStarC_Compiler_Range_Type.rng -> FStarC_Compiler_Range_Type.rng) + = + fun r1 -> + fun r2 -> + if + r1.FStarC_Compiler_Range_Type.file_name <> + r2.FStarC_Compiler_Range_Type.file_name + then r2 + else + (let start_pos = + FStarC_Class_Ord.max FStarC_Compiler_Range_Type.ord_pos + r1.FStarC_Compiler_Range_Type.start_pos + r2.FStarC_Compiler_Range_Type.start_pos in + let end_pos = + FStarC_Class_Ord.min FStarC_Compiler_Range_Type.ord_pos + r1.FStarC_Compiler_Range_Type.end_pos + r2.FStarC_Compiler_Range_Type.end_pos in + let uu___1 = + FStarC_Class_Ord.op_Greater_Equals_Question + FStarC_Compiler_Range_Type.ord_pos start_pos end_pos in + if uu___1 + then r2 + else + FStarC_Compiler_Range_Type.mk_rng + r1.FStarC_Compiler_Range_Type.file_name start_pos end_pos) +let (intersect_ranges : + FStarC_Compiler_Range_Type.range -> + FStarC_Compiler_Range_Type.range -> FStarC_Compiler_Range_Type.range) + = + fun r1 -> + fun r2 -> + let uu___ = + intersect_rng r1.FStarC_Compiler_Range_Type.def_range + r2.FStarC_Compiler_Range_Type.def_range in + let uu___1 = + intersect_rng r1.FStarC_Compiler_Range_Type.use_range + r2.FStarC_Compiler_Range_Type.use_range in + { + FStarC_Compiler_Range_Type.def_range = uu___; + FStarC_Compiler_Range_Type.use_range = uu___1 + } +let (bound_range : + FStarC_Compiler_Range_Type.range -> + FStarC_Compiler_Range_Type.range -> FStarC_Compiler_Range_Type.range) + = fun r -> fun bound -> intersect_ranges r bound +let (showable_range : + FStarC_Compiler_Range_Type.range FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = string_of_range } +let (pretty_range : FStarC_Compiler_Range_Type.range FStarC_Class_PP.pretty) + = + { + FStarC_Class_PP.pp = + (fun r -> + let uu___ = string_of_range r in FStarC_Pprint.doc_of_string uu___) + } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Compiler_Range_Type.ml b/ocaml/fstar-lib/generated/FStarC_Compiler_Range_Type.ml new file mode 100644 index 00000000000..93f704953a4 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Compiler_Range_Type.ml @@ -0,0 +1,104 @@ +open Prims +type file_name = Prims.string[@@deriving yojson,show] +type pos = { + line: Prims.int ; + col: Prims.int }[@@deriving yojson,show] +let (__proj__Mkpos__item__line : pos -> Prims.int) = + fun projectee -> match projectee with | { line; col;_} -> line +let (__proj__Mkpos__item__col : pos -> Prims.int) = + fun projectee -> match projectee with | { line; col;_} -> col +let (max : Prims.int -> Prims.int -> Prims.int) = + fun i -> fun j -> if i < j then j else i +let (compare_pos : pos -> pos -> FStarC_Compiler_Order.order) = + fun p1 -> + fun p2 -> + let uu___ = + FStarC_Class_Ord.cmp FStarC_Class_Ord.ord_int p1.line p2.line in + FStarC_Compiler_Order.lex uu___ + (fun uu___1 -> + FStarC_Class_Ord.cmp FStarC_Class_Ord.ord_int p1.col p2.col) +let (deq_pos : pos FStarC_Class_Deq.deq) = + { FStarC_Class_Deq.op_Equals_Question = (=) } +let (ord_pos : pos FStarC_Class_Ord.ord) = + { FStarC_Class_Ord.super = deq_pos; FStarC_Class_Ord.cmp = compare_pos } +type rng = { + file_name: file_name ; + start_pos: pos ; + end_pos: pos }[@@deriving yojson,show] +let (__proj__Mkrng__item__file_name : rng -> file_name) = + fun projectee -> + match projectee with + | { file_name = file_name1; start_pos; end_pos;_} -> file_name1 +let (__proj__Mkrng__item__start_pos : rng -> pos) = + fun projectee -> + match projectee with + | { file_name = file_name1; start_pos; end_pos;_} -> start_pos +let (__proj__Mkrng__item__end_pos : rng -> pos) = + fun projectee -> + match projectee with + | { file_name = file_name1; start_pos; end_pos;_} -> end_pos +type range = { + def_range: rng ; + use_range: rng }[@@deriving yojson,show] +let (__proj__Mkrange__item__def_range : range -> rng) = + fun projectee -> + match projectee with | { def_range; use_range;_} -> def_range +let (__proj__Mkrange__item__use_range : range -> rng) = + fun projectee -> + match projectee with | { def_range; use_range;_} -> use_range +let (dummy_pos : pos) = { line = Prims.int_zero; col = Prims.int_zero } +let (dummy_rng : rng) = + { file_name = "dummy"; start_pos = dummy_pos; end_pos = dummy_pos } +let (dummyRange : range) = { def_range = dummy_rng; use_range = dummy_rng } +let (use_range : range -> rng) = fun r -> r.use_range +let (def_range : range -> rng) = fun r -> r.def_range +let (range_of_rng : rng -> rng -> range) = + fun d -> fun u -> { def_range = d; use_range = u } +let (set_use_range : range -> rng -> range) = + fun r2 -> + fun use_rng -> + if use_rng <> dummy_rng + then { def_range = (r2.def_range); use_range = use_rng } + else r2 +let (set_def_range : range -> rng -> range) = + fun r2 -> + fun def_rng -> + if def_rng <> dummy_rng + then { def_range = def_rng; use_range = (r2.use_range) } + else r2 +let (mk_pos : Prims.int -> Prims.int -> pos) = + fun l -> + fun c -> { line = (max Prims.int_zero l); col = (max Prims.int_zero c) } +let (mk_rng : Prims.string -> pos -> pos -> rng) = + fun file_name1 -> + fun start_pos -> + fun end_pos -> { file_name = file_name1; start_pos; end_pos } +let (mk_range : Prims.string -> pos -> pos -> range) = + fun f -> fun b -> fun e -> let r = mk_rng f b e in range_of_rng r r +let (json_of_pos : pos -> FStarC_Json.json) = + fun r -> + FStarC_Json.JsonAssoc + [("line", (FStarC_Json.JsonInt (r.line))); + ("col", (FStarC_Json.JsonInt (r.col)))] +let (json_of_rng : rng -> FStarC_Json.json) = + fun r -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = json_of_pos r.start_pos in ("start_pos", uu___3) in + let uu___3 = + let uu___4 = + let uu___5 = json_of_pos r.end_pos in ("end_pos", uu___5) in + [uu___4] in + uu___2 :: uu___3 in + ("file_name", (FStarC_Json.JsonStr (r.file_name))) :: uu___1 in + FStarC_Json.JsonAssoc uu___ +let (json_of_range : range -> FStarC_Json.json) = + fun r -> + let uu___ = + let uu___1 = let uu___2 = json_of_rng r.def_range in ("def", uu___2) in + let uu___2 = + let uu___3 = let uu___4 = json_of_rng r.use_range in ("use", uu___4) in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Json.JsonAssoc uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Compiler_Real.ml b/ocaml/fstar-lib/generated/FStarC_Compiler_Real.ml similarity index 100% rename from ocaml/fstar-lib/generated/FStar_Compiler_Real.ml rename to ocaml/fstar-lib/generated/FStarC_Compiler_Real.ml diff --git a/ocaml/fstar-lib/generated/FStar_Compiler_Sealed.ml b/ocaml/fstar-lib/generated/FStarC_Compiler_Sealed.ml similarity index 100% rename from ocaml/fstar-lib/generated/FStar_Compiler_Sealed.ml rename to ocaml/fstar-lib/generated/FStarC_Compiler_Sealed.ml diff --git a/ocaml/fstar-lib/generated/FStarC_Compiler_Writer.ml b/ocaml/fstar-lib/generated/FStarC_Compiler_Writer.ml new file mode 100644 index 00000000000..f73cb815ab7 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Compiler_Writer.ml @@ -0,0 +1,69 @@ +open Prims +type ('m, 'uuuuu, 'a) writer = + | Wr of ('m * 'a) +let uu___is_Wr : + 'm . + 'm FStarC_Class_Monoid.monoid -> + unit -> ('m, unit, Obj.t) writer -> Prims.bool + = fun uu___ -> fun a -> fun projectee -> true +let __proj__Wr__item___0 : + 'm . + 'm FStarC_Class_Monoid.monoid -> + unit -> ('m, unit, Obj.t) writer -> ('m * Obj.t) + = fun uu___ -> fun a -> fun projectee -> match projectee with | Wr _0 -> _0 +let writer_return : + 'm . + 'm FStarC_Class_Monoid.monoid -> + unit -> Obj.t -> ('m, unit, Obj.t) writer + = fun uu___ -> fun a -> fun x -> Wr ((FStarC_Class_Monoid.mzero uu___), x) +let run_writer : + 'm . + 'm FStarC_Class_Monoid.monoid -> + unit -> ('m, unit, Obj.t) writer -> ('m * Obj.t) + = + fun uu___ -> + fun a -> + fun x -> let uu___1 = x in match uu___1 with | Wr (m1, x1) -> (m1, x1) +let writer_bind : + 'm . + 'm FStarC_Class_Monoid.monoid -> + unit -> + unit -> + ('m, unit, Obj.t) writer -> + (Obj.t -> ('m, unit, Obj.t) writer) -> ('m, unit, Obj.t) writer + = + fun uu___ -> + fun a -> + fun b -> + fun x -> + fun f -> + let uu___1 = x in + match uu___1 with + | Wr (a1, x1) -> + let uu___2 = f x1 in + (match uu___2 with + | Wr (b1, y) -> + let uu___3 = + let uu___4 = FStarC_Class_Monoid.mplus uu___ a1 b1 in + (uu___4, y) in + Wr uu___3) +let monad_writer : + 'm . + 'm FStarC_Class_Monoid.monoid -> + ('m, unit, unit) writer FStarC_Class_Monad.monad + = + fun d -> + { + FStarC_Class_Monad.return = + (fun uu___1 -> + fun uu___ -> (Obj.magic (writer_return d)) uu___1 uu___); + FStarC_Class_Monad.op_let_Bang = + (fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (Obj.magic (writer_bind d)) uu___3 uu___2 uu___1 uu___) + } +let emit : + 'm . 'm FStarC_Class_Monoid.monoid -> 'm -> ('m, unit, unit) writer = + fun uu___ -> fun x -> Wr (x, ()) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Const.ml b/ocaml/fstar-lib/generated/FStarC_Const.ml new file mode 100644 index 00000000000..3b14e9d8a0d --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Const.ml @@ -0,0 +1,149 @@ +open Prims +type signedness = + | Unsigned + | Signed [@@deriving yojson,show] +let (uu___is_Unsigned : signedness -> Prims.bool) = + fun projectee -> match projectee with | Unsigned -> true | uu___ -> false +let (uu___is_Signed : signedness -> Prims.bool) = + fun projectee -> match projectee with | Signed -> true | uu___ -> false +type width = + | Int8 + | Int16 + | Int32 + | Int64 + | Sizet [@@deriving yojson,show] +let (uu___is_Int8 : width -> Prims.bool) = + fun projectee -> match projectee with | Int8 -> true | uu___ -> false +let (uu___is_Int16 : width -> Prims.bool) = + fun projectee -> match projectee with | Int16 -> true | uu___ -> false +let (uu___is_Int32 : width -> Prims.bool) = + fun projectee -> match projectee with | Int32 -> true | uu___ -> false +let (uu___is_Int64 : width -> Prims.bool) = + fun projectee -> match projectee with | Int64 -> true | uu___ -> false +let (uu___is_Sizet : width -> Prims.bool) = + fun projectee -> match projectee with | Sizet -> true | uu___ -> false +type sconst = + | Const_effect + | Const_unit + | Const_bool of Prims.bool + | Const_int of (Prims.string * (signedness * width) + FStar_Pervasives_Native.option) + | Const_char of FStarC_BaseTypes.char + | Const_real of Prims.string + | Const_string of (Prims.string * FStarC_Compiler_Range_Type.range) + | Const_range_of + | Const_set_range_of + | Const_range of FStarC_Compiler_Range_Type.range + | Const_reify of FStarC_Ident.lid FStar_Pervasives_Native.option + | Const_reflect of FStarC_Ident.lid [@@deriving yojson,show] +let (uu___is_Const_effect : sconst -> Prims.bool) = + fun projectee -> + match projectee with | Const_effect -> true | uu___ -> false +let (uu___is_Const_unit : sconst -> Prims.bool) = + fun projectee -> match projectee with | Const_unit -> true | uu___ -> false +let (uu___is_Const_bool : sconst -> Prims.bool) = + fun projectee -> + match projectee with | Const_bool _0 -> true | uu___ -> false +let (__proj__Const_bool__item___0 : sconst -> Prims.bool) = + fun projectee -> match projectee with | Const_bool _0 -> _0 +let (uu___is_Const_int : sconst -> Prims.bool) = + fun projectee -> + match projectee with | Const_int _0 -> true | uu___ -> false +let (__proj__Const_int__item___0 : + sconst -> + (Prims.string * (signedness * width) FStar_Pervasives_Native.option)) + = fun projectee -> match projectee with | Const_int _0 -> _0 +let (uu___is_Const_char : sconst -> Prims.bool) = + fun projectee -> + match projectee with | Const_char _0 -> true | uu___ -> false +let (__proj__Const_char__item___0 : sconst -> FStarC_BaseTypes.char) = + fun projectee -> match projectee with | Const_char _0 -> _0 +let (uu___is_Const_real : sconst -> Prims.bool) = + fun projectee -> + match projectee with | Const_real _0 -> true | uu___ -> false +let (__proj__Const_real__item___0 : sconst -> Prims.string) = + fun projectee -> match projectee with | Const_real _0 -> _0 +let (uu___is_Const_string : sconst -> Prims.bool) = + fun projectee -> + match projectee with | Const_string _0 -> true | uu___ -> false +let (__proj__Const_string__item___0 : + sconst -> (Prims.string * FStarC_Compiler_Range_Type.range)) = + fun projectee -> match projectee with | Const_string _0 -> _0 +let (uu___is_Const_range_of : sconst -> Prims.bool) = + fun projectee -> + match projectee with | Const_range_of -> true | uu___ -> false +let (uu___is_Const_set_range_of : sconst -> Prims.bool) = + fun projectee -> + match projectee with | Const_set_range_of -> true | uu___ -> false +let (uu___is_Const_range : sconst -> Prims.bool) = + fun projectee -> + match projectee with | Const_range _0 -> true | uu___ -> false +let (__proj__Const_range__item___0 : + sconst -> FStarC_Compiler_Range_Type.range) = + fun projectee -> match projectee with | Const_range _0 -> _0 +let (uu___is_Const_reify : sconst -> Prims.bool) = + fun projectee -> + match projectee with | Const_reify _0 -> true | uu___ -> false +let (__proj__Const_reify__item___0 : + sconst -> FStarC_Ident.lid FStar_Pervasives_Native.option) = + fun projectee -> match projectee with | Const_reify _0 -> _0 +let (uu___is_Const_reflect : sconst -> Prims.bool) = + fun projectee -> + match projectee with | Const_reflect _0 -> true | uu___ -> false +let (__proj__Const_reflect__item___0 : sconst -> FStarC_Ident.lid) = + fun projectee -> match projectee with | Const_reflect _0 -> _0 +let (eq_const : sconst -> sconst -> Prims.bool) = + fun c1 -> + fun c2 -> + match (c1, c2) with + | (Const_int (s1, o1), Const_int (s2, o2)) -> + (let uu___ = FStarC_Compiler_Util.ensure_decimal s1 in + let uu___1 = FStarC_Compiler_Util.ensure_decimal s2 in + uu___ = uu___1) && (o1 = o2) + | (Const_string (a, uu___), Const_string (b, uu___1)) -> a = b + | (Const_reflect l1, Const_reflect l2) -> FStarC_Ident.lid_equals l1 l2 + | (Const_reify uu___, Const_reify uu___1) -> true + | uu___ -> c1 = c2 +let rec (pow2 : FStarC_BigInt.bigint -> FStarC_BigInt.bigint) = + fun x -> + let uu___ = FStarC_BigInt.eq_big_int x FStarC_BigInt.zero in + if uu___ + then FStarC_BigInt.one + else + (let uu___2 = let uu___3 = FStarC_BigInt.pred_big_int x in pow2 uu___3 in + FStarC_BigInt.mult_big_int FStarC_BigInt.two uu___2) +let (bounds : + signedness -> width -> (FStarC_BigInt.bigint * FStarC_BigInt.bigint)) = + fun signedness1 -> + fun width1 -> + let n = + match width1 with + | Int8 -> FStarC_BigInt.big_int_of_string "8" + | Int16 -> FStarC_BigInt.big_int_of_string "16" + | Int32 -> FStarC_BigInt.big_int_of_string "32" + | Int64 -> FStarC_BigInt.big_int_of_string "64" + | Sizet -> FStarC_BigInt.big_int_of_string "16" in + let uu___ = + match signedness1 with + | Unsigned -> + let uu___1 = + let uu___2 = pow2 n in FStarC_BigInt.pred_big_int uu___2 in + (FStarC_BigInt.zero, uu___1) + | Signed -> + let upper = + let uu___1 = FStarC_BigInt.pred_big_int n in pow2 uu___1 in + let uu___1 = FStarC_BigInt.minus_big_int upper in + let uu___2 = FStarC_BigInt.pred_big_int upper in (uu___1, uu___2) in + match uu___ with | (lower, upper) -> (lower, upper) +let (within_bounds : Prims.string -> signedness -> width -> Prims.bool) = + fun repr -> + fun signedness1 -> + fun width1 -> + let uu___ = bounds signedness1 width1 in + match uu___ with + | (lower, upper) -> + let value = + let uu___1 = FStarC_Compiler_Util.ensure_decimal repr in + FStarC_BigInt.big_int_of_string uu___1 in + (FStarC_BigInt.le_big_int lower value) && + (FStarC_BigInt.le_big_int value upper) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Defensive.ml b/ocaml/fstar-lib/generated/FStarC_Defensive.ml new file mode 100644 index 00000000000..0ff3953569b --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Defensive.ml @@ -0,0 +1,138 @@ +open Prims +let (pp_bv : FStarC_Syntax_Syntax.bv FStarC_Class_PP.pretty) = + { + FStarC_Class_PP.pp = + (fun bv -> + let uu___ = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_bv bv in + FStarC_Pprint.arbitrary_string uu___) + } +let pp_set : + 'a . + 'a FStarC_Class_Ord.ord -> + 'a FStarC_Class_PP.pretty -> + 'a FStarC_Compiler_FlatSet.t FStarC_Class_PP.pretty + = + fun uu___ -> + fun uu___1 -> + { + FStarC_Class_PP.pp = + (fun s -> + let doclist ds = + let uu___2 = FStarC_Pprint.doc_of_string "[]" in + let uu___3 = + let uu___4 = FStarC_Pprint.break_ Prims.int_one in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.semi uu___4 in + FStarC_Pprint.surround_separate (Prims.of_int (2)) + Prims.int_zero uu___2 FStarC_Pprint.lbracket uu___3 + FStarC_Pprint.rbracket ds in + let uu___2 = + let uu___3 = + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set uu___)) + (Obj.magic s) in + FStarC_Compiler_List.map (FStarC_Class_PP.pp uu___1) uu___3 in + doclist uu___2) + } +let __def_check_scoped : + 'envut 'thingut . + 'envut FStarC_Class_Binders.hasBinders -> + 'thingut FStarC_Class_Binders.hasNames -> + 'thingut FStarC_Class_PP.pretty -> + FStarC_Compiler_Range_Type.range -> + Prims.string -> 'envut -> 'thingut -> unit + = + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun rng -> + fun msg -> + fun env -> + fun thing -> + let free = FStarC_Class_Binders.freeNames uu___1 thing in + let scope = FStarC_Class_Binders.boundNames uu___ env in + let uu___3 = + let uu___4 = + FStarC_Class_Setlike.subset () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) (Obj.magic free) + (Obj.magic scope) in + Prims.op_Negation uu___4 in + if uu___3 + then + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Errors_Msg.text + "Internal: term is not well-scoped " in + let uu___7 = + let uu___8 = FStarC_Pprint.doc_of_string msg in + FStarC_Pprint.parens uu___8 in + FStarC_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Errors_Msg.text "t =" in + let uu___9 = FStarC_Class_PP.pp uu___2 thing in + FStarC_Pprint.op_Hat_Slash_Hat uu___8 uu___9 in + let uu___8 = + let uu___9 = + let uu___10 = FStarC_Errors_Msg.text "FVs =" in + let uu___11 = + FStarC_Class_PP.pp + (pp_set FStarC_Syntax_Syntax.ord_bv pp_bv) free in + FStarC_Pprint.op_Hat_Slash_Hat uu___10 uu___11 in + let uu___10 = + let uu___11 = + let uu___12 = FStarC_Errors_Msg.text "Scope =" in + let uu___13 = + FStarC_Class_PP.pp + (pp_set FStarC_Syntax_Syntax.ord_bv pp_bv) + scope in + FStarC_Pprint.op_Hat_Slash_Hat uu___12 uu___13 in + let uu___12 = + let uu___13 = + let uu___14 = FStarC_Errors_Msg.text "Diff =" in + let uu___15 = + let uu___16 = + Obj.magic + (FStarC_Class_Setlike.diff () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) + (Obj.magic free) (Obj.magic scope)) in + FStarC_Class_PP.pp + (pp_set FStarC_Syntax_Syntax.ord_bv pp_bv) + uu___16 in + FStarC_Pprint.op_Hat_Slash_Hat uu___14 uu___15 in + [uu___13] in + uu___11 :: uu___12 in + uu___9 :: uu___10 in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + FStarC_Errors.log_issue + FStarC_Class_HasRange.hasRange_range rng + FStarC_Errors_Codes.Warning_Defensive () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___4) + else () +let def_check_scoped : + 'envut 'thingut . + 'envut FStarC_Class_Binders.hasBinders -> + 'thingut FStarC_Class_Binders.hasNames -> + 'thingut FStarC_Class_PP.pretty -> + FStarC_Compiler_Range_Type.range -> + Prims.string -> 'envut -> 'thingut -> unit + = + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun rng -> + fun msg -> + fun env -> + fun thing -> + let uu___3 = FStarC_Options.defensive () in + if uu___3 + then __def_check_scoped uu___ uu___1 uu___2 rng msg env thing + else () \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Dependencies.ml b/ocaml/fstar-lib/generated/FStarC_Dependencies.ml new file mode 100644 index 00000000000..9411005f246 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Dependencies.ml @@ -0,0 +1,21 @@ +open Prims +let (find_deps_if_needed : + Prims.string Prims.list -> + (Prims.string -> + FStarC_Parser_Dep.parsing_data FStar_Pervasives_Native.option) + -> (Prims.string Prims.list * FStarC_Parser_Dep.deps)) + = + fun files -> + fun get_parsing_data_from_cache -> + let uu___ = FStarC_Parser_Dep.collect files get_parsing_data_from_cache in + match uu___ with + | (all_files, deps) -> + (match all_files with + | [] -> + (FStarC_Errors.log_issue0 + FStarC_Errors_Codes.Error_DependencyAnalysisFailed () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Dependency analysis failed; reverting to using only the files provided"); + (files, deps)) + | uu___1 -> ((FStarC_Compiler_List.rev all_files), deps)) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Errors.ml b/ocaml/fstar-lib/generated/FStarC_Errors.ml new file mode 100644 index 00000000000..94bbc0d9866 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Errors.ml @@ -0,0 +1,1209 @@ +open Prims +let (fallback_range : + FStarC_Compiler_Range_Type.range FStar_Pervasives_Native.option + FStarC_Compiler_Effect.ref) + = FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None +let (error_range_bound : + FStarC_Compiler_Range_Type.range FStar_Pervasives_Native.option + FStarC_Compiler_Effect.ref) + = FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None +let with_error_bound : + 'a . FStarC_Compiler_Range_Type.range -> (unit -> 'a) -> 'a = + fun r -> + fun f -> + let old = FStarC_Compiler_Effect.op_Bang error_range_bound in + FStarC_Compiler_Effect.op_Colon_Equals error_range_bound + (FStar_Pervasives_Native.Some r); + (let res = f () in + FStarC_Compiler_Effect.op_Colon_Equals error_range_bound old; res) +exception Invalid_warn_error_setting of Prims.string +let (uu___is_Invalid_warn_error_setting : Prims.exn -> Prims.bool) = + fun projectee -> + match projectee with + | Invalid_warn_error_setting uu___ -> true + | uu___ -> false +let (__proj__Invalid_warn_error_setting__item__uu___ : + Prims.exn -> Prims.string) = + fun projectee -> + match projectee with | Invalid_warn_error_setting uu___ -> uu___ +let lookup_error : + 'uuuuu 'uuuuu1 'uuuuu2 . + ('uuuuu * 'uuuuu1 * 'uuuuu2) Prims.list -> + 'uuuuu -> ('uuuuu * 'uuuuu1 * 'uuuuu2) + = + fun settings -> + fun e -> + let uu___ = + FStarC_Compiler_Util.try_find + (fun uu___1 -> match uu___1 with | (v, uu___2, i) -> e = v) + settings in + match uu___ with + | FStar_Pervasives_Native.Some i -> i + | FStar_Pervasives_Native.None -> + failwith "Impossible: unrecognized error" +let lookup_error_range : + 'uuuuu 'uuuuu1 . + ('uuuuu * 'uuuuu1 * Prims.int) Prims.list -> + (Prims.int * Prims.int) -> ('uuuuu * 'uuuuu1 * Prims.int) Prims.list + = + fun settings -> + fun uu___ -> + match uu___ with + | (l, h) -> + let uu___1 = + FStarC_Compiler_List.partition + (fun uu___2 -> + match uu___2 with + | (uu___3, uu___4, i) -> (l <= i) && (i <= h)) settings in + (match uu___1 with | (matches, uu___2) -> matches) +let (error_number : FStarC_Errors_Codes.error_setting -> Prims.int) = + fun uu___ -> match uu___ with | (uu___1, uu___2, i) -> i +let (errno : FStarC_Errors_Codes.error_code -> Prims.int) = + fun e -> + let uu___ = lookup_error FStarC_Errors_Codes.default_settings e in + error_number uu___ +let (warn_on_use_errno : Prims.int) = + errno FStarC_Errors_Codes.Warning_WarnOnUse +let (defensive_errno : Prims.int) = + errno FStarC_Errors_Codes.Warning_Defensive +let (call_to_erased_errno : Prims.int) = + errno FStarC_Errors_Codes.Error_CallToErased +let (update_flags : + (FStarC_Errors_Codes.error_flag * Prims.string) Prims.list -> + FStarC_Errors_Codes.error_setting Prims.list) + = + fun l -> + let set_one_flag i flag default_flag = + match (flag, default_flag) with + | (FStarC_Errors_Codes.CWarning, FStarC_Errors_Codes.CAlwaysError) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Compiler_Util.string_of_int i in + FStarC_Compiler_Util.format1 + "cannot turn error %s into warning" uu___2 in + Invalid_warn_error_setting uu___1 in + FStarC_Compiler_Effect.raise uu___ + | (FStarC_Errors_Codes.CError, FStarC_Errors_Codes.CAlwaysError) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Compiler_Util.string_of_int i in + FStarC_Compiler_Util.format1 + "cannot turn error %s into warning" uu___2 in + Invalid_warn_error_setting uu___1 in + FStarC_Compiler_Effect.raise uu___ + | (FStarC_Errors_Codes.CSilent, FStarC_Errors_Codes.CAlwaysError) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Compiler_Util.string_of_int i in + FStarC_Compiler_Util.format1 "cannot silence error %s" uu___2 in + Invalid_warn_error_setting uu___1 in + FStarC_Compiler_Effect.raise uu___ + | (FStarC_Errors_Codes.CSilent, FStarC_Errors_Codes.CFatal) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Compiler_Util.string_of_int i in + FStarC_Compiler_Util.format1 + "cannot change the error level of fatal error %s" uu___2 in + Invalid_warn_error_setting uu___1 in + FStarC_Compiler_Effect.raise uu___ + | (FStarC_Errors_Codes.CWarning, FStarC_Errors_Codes.CFatal) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Compiler_Util.string_of_int i in + FStarC_Compiler_Util.format1 + "cannot change the error level of fatal error %s" uu___2 in + Invalid_warn_error_setting uu___1 in + FStarC_Compiler_Effect.raise uu___ + | (FStarC_Errors_Codes.CError, FStarC_Errors_Codes.CFatal) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Compiler_Util.string_of_int i in + FStarC_Compiler_Util.format1 + "cannot change the error level of fatal error %s" uu___2 in + Invalid_warn_error_setting uu___1 in + FStarC_Compiler_Effect.raise uu___ + | (FStarC_Errors_Codes.CAlwaysError, FStarC_Errors_Codes.CFatal) -> + FStarC_Errors_Codes.CFatal + | uu___ -> flag in + let set_flag_for_range uu___ = + match uu___ with + | (flag, range) -> + let errs = + lookup_error_range FStarC_Errors_Codes.default_settings range in + FStarC_Compiler_List.map + (fun uu___1 -> + match uu___1 with + | (v, default_flag, i) -> + let uu___2 = set_one_flag i flag default_flag in + (v, uu___2, i)) errs in + let compute_range uu___ = + match uu___ with + | (flag, s) -> + let r = FStarC_Compiler_Util.split s ".." in + let uu___1 = + match r with + | r1::r2::[] -> + let uu___2 = FStarC_Compiler_Util.int_of_string r1 in + let uu___3 = FStarC_Compiler_Util.int_of_string r2 in + (uu___2, uu___3) + | uu___2 -> + let uu___3 = + let uu___4 = + FStarC_Compiler_Util.format1 + "Malformed warn-error range %s" s in + Invalid_warn_error_setting uu___4 in + FStarC_Compiler_Effect.raise uu___3 in + (match uu___1 with | (l1, h) -> (flag, (l1, h))) in + let error_range_settings = + FStarC_Compiler_List.map compute_range (FStarC_Compiler_List.rev l) in + let uu___ = + FStarC_Compiler_List.collect set_flag_for_range error_range_settings in + FStarC_Compiler_List.op_At uu___ FStarC_Errors_Codes.default_settings +type error = + (FStarC_Errors_Codes.error_code * FStarC_Errors_Msg.error_message * + FStarC_Compiler_Range_Type.range * Prims.string Prims.list) +type issue_level = + | ENotImplemented + | EInfo + | EWarning + | EError +let (uu___is_ENotImplemented : issue_level -> Prims.bool) = + fun projectee -> + match projectee with | ENotImplemented -> true | uu___ -> false +let (uu___is_EInfo : issue_level -> Prims.bool) = + fun projectee -> match projectee with | EInfo -> true | uu___ -> false +let (uu___is_EWarning : issue_level -> Prims.bool) = + fun projectee -> match projectee with | EWarning -> true | uu___ -> false +let (uu___is_EError : issue_level -> Prims.bool) = + fun projectee -> match projectee with | EError -> true | uu___ -> false +exception Error of error +let (uu___is_Error : Prims.exn -> Prims.bool) = + fun projectee -> + match projectee with | Error uu___ -> true | uu___ -> false +let (__proj__Error__item__uu___ : Prims.exn -> error) = + fun projectee -> match projectee with | Error uu___ -> uu___ +exception Warning of error +let (uu___is_Warning : Prims.exn -> Prims.bool) = + fun projectee -> + match projectee with | Warning uu___ -> true | uu___ -> false +let (__proj__Warning__item__uu___ : Prims.exn -> error) = + fun projectee -> match projectee with | Warning uu___ -> uu___ +exception Stop +let (uu___is_Stop : Prims.exn -> Prims.bool) = + fun projectee -> match projectee with | Stop -> true | uu___ -> false +exception Empty_frag +let (uu___is_Empty_frag : Prims.exn -> Prims.bool) = + fun projectee -> match projectee with | Empty_frag -> true | uu___ -> false +let (json_of_issue_level : issue_level -> FStarC_Json.json) = + fun level -> + FStarC_Json.JsonStr + (match level with + | ENotImplemented -> "NotImplemented" + | EInfo -> "Info" + | EWarning -> "Warning" + | EError -> "Error") +type issue = + { + issue_msg: FStarC_Errors_Msg.error_message ; + issue_level: issue_level ; + issue_range: + FStarC_Compiler_Range_Type.range FStar_Pervasives_Native.option ; + issue_number: Prims.int FStar_Pervasives_Native.option ; + issue_ctx: Prims.string Prims.list } +let (__proj__Mkissue__item__issue_msg : + issue -> FStarC_Errors_Msg.error_message) = + fun projectee -> + match projectee with + | { issue_msg; issue_level = issue_level1; issue_range; issue_number; + issue_ctx;_} -> issue_msg +let (__proj__Mkissue__item__issue_level : issue -> issue_level) = + fun projectee -> + match projectee with + | { issue_msg; issue_level = issue_level1; issue_range; issue_number; + issue_ctx;_} -> issue_level1 +let (__proj__Mkissue__item__issue_range : + issue -> FStarC_Compiler_Range_Type.range FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { issue_msg; issue_level = issue_level1; issue_range; issue_number; + issue_ctx;_} -> issue_range +let (__proj__Mkissue__item__issue_number : + issue -> Prims.int FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { issue_msg; issue_level = issue_level1; issue_range; issue_number; + issue_ctx;_} -> issue_number +let (__proj__Mkissue__item__issue_ctx : issue -> Prims.string Prims.list) = + fun projectee -> + match projectee with + | { issue_msg; issue_level = issue_level1; issue_range; issue_number; + issue_ctx;_} -> issue_ctx +let (json_of_issue : issue -> FStarC_Json.json) = + fun issue1 -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Errors_Msg.json_of_error_message issue1.issue_msg in + ("msg", uu___2) in + let uu___2 = + let uu___3 = + let uu___4 = json_of_issue_level issue1.issue_level in + ("level", uu___4) in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + Obj.magic + (FStarC_Class_Monad.op_Less_Dollar_Greater + FStarC_Class_Monad.monad_option () () + (fun uu___8 -> + (Obj.magic FStarC_Compiler_Range_Type.json_of_range) + uu___8) (Obj.magic issue1.issue_range)) in + FStarC_Compiler_Util.dflt FStarC_Json.JsonNull uu___7 in + ("range", uu___6) in + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + Obj.magic + (FStarC_Class_Monad.op_Less_Dollar_Greater + FStarC_Class_Monad.monad_option () () + (fun uu___10 -> + (fun uu___10 -> + let uu___10 = Obj.magic uu___10 in + Obj.magic (FStarC_Json.JsonInt uu___10)) uu___10) + (Obj.magic issue1.issue_number)) in + FStarC_Compiler_Util.dflt FStarC_Json.JsonNull uu___9 in + ("number", uu___8) in + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + Obj.magic + (FStarC_Class_Monad.op_Less_Dollar_Greater + FStarC_Class_Monad.monad_list () () + (fun uu___12 -> + (fun uu___12 -> + let uu___12 = Obj.magic uu___12 in + Obj.magic (FStarC_Json.JsonStr uu___12)) + uu___12) (Obj.magic issue1.issue_ctx)) in + FStarC_Json.JsonList uu___11 in + ("ctx", uu___10) in + [uu___9] in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Json.JsonAssoc uu___ +type error_handler = + { + eh_name: Prims.string ; + eh_add_one: issue -> unit ; + eh_count_errors: unit -> Prims.int ; + eh_report: unit -> issue Prims.list ; + eh_clear: unit -> unit } +let (__proj__Mkerror_handler__item__eh_name : error_handler -> Prims.string) + = + fun projectee -> + match projectee with + | { eh_name; eh_add_one; eh_count_errors; eh_report; eh_clear;_} -> + eh_name +let (__proj__Mkerror_handler__item__eh_add_one : + error_handler -> issue -> unit) = + fun projectee -> + match projectee with + | { eh_name; eh_add_one; eh_count_errors; eh_report; eh_clear;_} -> + eh_add_one +let (__proj__Mkerror_handler__item__eh_count_errors : + error_handler -> unit -> Prims.int) = + fun projectee -> + match projectee with + | { eh_name; eh_add_one; eh_count_errors; eh_report; eh_clear;_} -> + eh_count_errors +let (__proj__Mkerror_handler__item__eh_report : + error_handler -> unit -> issue Prims.list) = + fun projectee -> + match projectee with + | { eh_name; eh_add_one; eh_count_errors; eh_report; eh_clear;_} -> + eh_report +let (__proj__Mkerror_handler__item__eh_clear : error_handler -> unit -> unit) + = + fun projectee -> + match projectee with + | { eh_name; eh_add_one; eh_count_errors; eh_report; eh_clear;_} -> + eh_clear +let (ctx_doc : Prims.string Prims.list -> FStarC_Pprint.document) = + fun ctx -> + let uu___ = FStarC_Options.error_contexts () in + if uu___ + then + let uu___1 = + FStarC_Compiler_List.map + (fun s -> + let uu___2 = + let uu___3 = FStarC_Pprint.doc_of_string "> " in + let uu___4 = FStarC_Pprint.doc_of_string s in + FStarC_Pprint.op_Hat_Hat uu___3 uu___4 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline uu___2) ctx in + FStarC_Pprint.concat uu___1 + else FStarC_Pprint.empty +let (issue_message : issue -> FStarC_Errors_Msg.error_message) = + fun i -> + let uu___ = let uu___1 = ctx_doc i.issue_ctx in [uu___1] in + FStarC_Compiler_List.op_At i.issue_msg uu___ +let (string_of_issue_level : issue_level -> Prims.string) = + fun il -> + match il with + | EInfo -> "Info" + | EWarning -> "Warning" + | EError -> "Error" + | ENotImplemented -> "Feature not yet implemented: " +let (issue_level_of_string : Prims.string -> issue_level) = + fun uu___ -> + match uu___ with + | "Info" -> EInfo + | "Warning" -> EWarning + | "Error" -> EError + | uu___1 -> ENotImplemented +let optional_def : + 'a . + ('a -> FStarC_Pprint.document) -> + FStarC_Pprint.document -> + 'a FStar_Pervasives_Native.option -> FStarC_Pprint.document + = + fun f -> + fun def -> + fun o -> + match o with + | FStar_Pervasives_Native.Some x -> f x + | FStar_Pervasives_Native.None -> def +let (format_issue' : Prims.bool -> issue -> Prims.string) = + fun print_hdr -> + fun issue1 -> + let level_header = + let uu___ = string_of_issue_level issue1.issue_level in + FStarC_Pprint.doc_of_string uu___ in + let num_opt = + if (issue1.issue_level = EError) || (issue1.issue_level = EWarning) + then + let uu___ = FStarC_Pprint.blank Prims.int_one in + let uu___1 = + let uu___2 = FStarC_Pprint.doc_of_string "" in + optional_def + (fun n -> + let uu___3 = FStarC_Compiler_Util.string_of_int n in + FStarC_Pprint.doc_of_string uu___3) uu___2 + issue1.issue_number in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 + else FStarC_Pprint.empty in + let r = issue1.issue_range in + let atrng = + match r with + | FStar_Pervasives_Native.Some r1 when + r1 <> FStarC_Compiler_Range_Type.dummyRange -> + let uu___ = FStarC_Pprint.blank Prims.int_one in + let uu___1 = + let uu___2 = FStarC_Pprint.doc_of_string "at" in + let uu___3 = + let uu___4 = FStarC_Pprint.blank Prims.int_one in + let uu___5 = + let uu___6 = + FStarC_Compiler_Range_Ops.string_of_use_range r1 in + FStarC_Pprint.doc_of_string uu___6 in + FStarC_Pprint.op_Hat_Hat uu___4 uu___5 in + FStarC_Pprint.op_Hat_Hat uu___2 uu___3 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 + | uu___ -> FStarC_Pprint.empty in + let hdr = + if print_hdr + then + let uu___ = FStarC_Pprint.doc_of_string "*" in + let uu___1 = + let uu___2 = FStarC_Pprint.blank Prims.int_one in + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Pprint.doc_of_string ":" in + FStarC_Pprint.op_Hat_Hat uu___7 FStarC_Pprint.hardline in + FStarC_Pprint.op_Hat_Hat atrng uu___6 in + FStarC_Pprint.op_Hat_Hat num_opt uu___5 in + FStarC_Pprint.op_Hat_Hat level_header uu___4 in + FStarC_Pprint.op_Hat_Hat uu___2 uu___3 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 + else FStarC_Pprint.empty in + let seealso = + match r with + | FStar_Pervasives_Native.Some r1 when + (let uu___ = FStarC_Compiler_Range_Type.def_range r1 in + let uu___1 = FStarC_Compiler_Range_Type.use_range r1 in + uu___ <> uu___1) && + (let uu___ = FStarC_Compiler_Range_Type.def_range r1 in + let uu___1 = + FStarC_Compiler_Range_Type.def_range + FStarC_Compiler_Range_Type.dummyRange in + uu___ <> uu___1) + -> + let uu___ = FStarC_Pprint.doc_of_string "See also" in + let uu___1 = + let uu___2 = FStarC_Pprint.blank Prims.int_one in + let uu___3 = + let uu___4 = FStarC_Compiler_Range_Ops.string_of_range r1 in + FStarC_Pprint.doc_of_string uu___4 in + FStarC_Pprint.op_Hat_Hat uu___2 uu___3 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 + | uu___ -> FStarC_Pprint.empty in + let ctx = + match issue1.issue_ctx with + | h::t when FStarC_Options.error_contexts () -> + let d1 s = + let uu___ = FStarC_Pprint.doc_of_string "> " in + let uu___1 = FStarC_Pprint.doc_of_string s in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 in + let uu___ = d1 h in + FStarC_Compiler_List.fold_left + (fun l -> + fun r1 -> + let uu___1 = + let uu___2 = d1 r1 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline uu___2 in + FStarC_Pprint.op_Hat_Hat l uu___1) uu___ t + | uu___ -> FStarC_Pprint.empty in + let subdoc = FStarC_Errors_Msg.subdoc' print_hdr in + let mainmsg = + let uu___ = + FStarC_Compiler_List.map + (fun d -> let uu___1 = FStarC_Pprint.group d in subdoc uu___1) + issue1.issue_msg in + FStarC_Pprint.concat uu___ in + let doc = + let uu___ = + let uu___1 = + let uu___2 = subdoc seealso in + let uu___3 = subdoc ctx in FStarC_Pprint.op_Hat_Hat uu___2 uu___3 in + FStarC_Pprint.op_Hat_Hat mainmsg uu___1 in + FStarC_Pprint.op_Hat_Hat hdr uu___ in + FStarC_Errors_Msg.renderdoc doc +let (format_issue : issue -> Prims.string) = + fun issue1 -> format_issue' true issue1 +let (print_issue_json : issue -> unit) = + fun issue1 -> + let uu___ = + let uu___1 = json_of_issue issue1 in FStarC_Json.string_of_json uu___1 in + FStarC_Compiler_Util.print1_error "%s\n" uu___ +let (print_issue_rendered : issue -> unit) = + fun issue1 -> + let printer = + match issue1.issue_level with + | EInfo -> + (fun s -> + let uu___ = FStarC_Compiler_Util.colorize_cyan s in + FStarC_Compiler_Util.print_string uu___) + | EWarning -> FStarC_Compiler_Util.print_warning + | EError -> FStarC_Compiler_Util.print_error + | ENotImplemented -> FStarC_Compiler_Util.print_error in + let uu___ = let uu___1 = format_issue issue1 in Prims.strcat uu___1 "\n" in + printer uu___ +let (print_issue : issue -> unit) = + fun issue1 -> + let uu___ = FStarC_Options.message_format () in + match uu___ with + | FStarC_Options.Human -> print_issue_rendered issue1 + | FStarC_Options.Json -> print_issue_json issue1 +let (compare_issues : issue -> issue -> Prims.int) = + fun i1 -> + fun i2 -> + match ((i1.issue_range), (i2.issue_range)) with + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> + Prims.int_zero + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.Some uu___) -> + (Prims.of_int (-1)) + | (FStar_Pervasives_Native.Some uu___, FStar_Pervasives_Native.None) -> + Prims.int_one + | (FStar_Pervasives_Native.Some r1, FStar_Pervasives_Native.Some r2) -> + FStarC_Compiler_Range_Ops.compare_use_range r1 r2 +let (dummy_ide_rng : FStarC_Compiler_Range_Type.rng) = + let uu___ = FStarC_Compiler_Range_Type.mk_pos Prims.int_one Prims.int_zero in + let uu___1 = FStarC_Compiler_Range_Type.mk_pos Prims.int_one Prims.int_zero in + FStarC_Compiler_Range_Type.mk_rng "" uu___ uu___1 +let (maybe_bound_rng : + FStarC_Compiler_Range_Type.range -> FStarC_Compiler_Range_Type.range) = + fun r -> + let uu___ = FStarC_Compiler_Effect.op_Bang error_range_bound in + match uu___ with + | FStar_Pervasives_Native.Some r' -> + FStarC_Compiler_Range_Ops.bound_range r r' + | FStar_Pervasives_Native.None -> r +let (fixup_issue_range : issue -> issue) = + fun i -> + let rng = + match i.issue_range with + | FStar_Pervasives_Native.None -> + FStarC_Compiler_Effect.op_Bang fallback_range + | FStar_Pervasives_Native.Some range -> + let use_rng = FStarC_Compiler_Range_Type.use_range range in + let use_rng' = + if + (use_rng <> FStarC_Compiler_Range_Type.dummy_rng) && + (use_rng <> dummy_ide_rng) + then use_rng + else + (let uu___1 = + let uu___2 = FStarC_Compiler_Effect.op_Bang fallback_range in + FStar_Pervasives_Native.uu___is_Some uu___2 in + if uu___1 + then + let uu___2 = + let uu___3 = FStarC_Compiler_Effect.op_Bang fallback_range in + FStar_Pervasives_Native.__proj__Some__item__v uu___3 in + FStarC_Compiler_Range_Type.use_range uu___2 + else use_rng) in + let uu___ = FStarC_Compiler_Range_Type.set_use_range range use_rng' in + FStar_Pervasives_Native.Some uu___ in + let uu___ = FStarC_Compiler_Util.map_opt rng maybe_bound_rng in + { + issue_msg = (i.issue_msg); + issue_level = (i.issue_level); + issue_range = uu___; + issue_number = (i.issue_number); + issue_ctx = (i.issue_ctx) + } +let (mk_default_handler : Prims.bool -> error_handler) = + fun print -> + let issues = FStarC_Compiler_Util.mk_ref [] in + let err_count = FStarC_Compiler_Util.mk_ref Prims.int_zero in + let add_one e = + if e.issue_level = EError + then + (let uu___1 = + let uu___2 = FStarC_Compiler_Effect.op_Bang err_count in + Prims.int_one + uu___2 in + FStarC_Compiler_Effect.op_Colon_Equals err_count uu___1) + else (); + (match e.issue_level with + | EInfo when print -> print_issue e + | uu___2 when print && (FStarC_Compiler_Debug.any ()) -> print_issue e + | uu___2 -> + let uu___3 = + let uu___4 = FStarC_Compiler_Effect.op_Bang issues in e :: + uu___4 in + FStarC_Compiler_Effect.op_Colon_Equals issues uu___3); + (let uu___3 = + (FStarC_Options.defensive_abort ()) && + (e.issue_number = (FStar_Pervasives_Native.Some defensive_errno)) in + if uu___3 then failwith "Aborting due to --defensive abort" else ()) in + let count_errors uu___ = FStarC_Compiler_Effect.op_Bang err_count in + let report uu___ = + let unique_issues = + let uu___1 = FStarC_Compiler_Effect.op_Bang issues in + FStarC_Compiler_Util.remove_dups (fun i0 -> fun i1 -> i0 = i1) uu___1 in + let sorted_unique_issues = + FStarC_Compiler_List.sortWith compare_issues unique_issues in + if print + then FStarC_Compiler_List.iter print_issue sorted_unique_issues + else (); + sorted_unique_issues in + let clear uu___ = + FStarC_Compiler_Effect.op_Colon_Equals issues []; + FStarC_Compiler_Effect.op_Colon_Equals err_count Prims.int_zero in + let uu___ = + let uu___1 = + let uu___2 = FStarC_Compiler_Util.string_of_bool print in + Prims.strcat uu___2 ")" in + Prims.strcat "default handler (print=" uu___1 in + { + eh_name = uu___; + eh_add_one = add_one; + eh_count_errors = count_errors; + eh_report = report; + eh_clear = clear + } +let (default_handler : error_handler) = mk_default_handler true +let (current_handler : error_handler FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref default_handler +let (mk_issue : + issue_level -> + FStarC_Compiler_Range_Type.range FStar_Pervasives_Native.option -> + FStarC_Errors_Msg.error_message -> + Prims.int FStar_Pervasives_Native.option -> + Prims.string Prims.list -> issue) + = + fun level -> + fun range -> + fun msg -> + fun n -> + fun ctx -> + { + issue_msg = msg; + issue_level = level; + issue_range = range; + issue_number = n; + issue_ctx = ctx + } +let (get_err_count : unit -> Prims.int) = + fun uu___ -> + let uu___1 = FStarC_Compiler_Effect.op_Bang current_handler in + uu___1.eh_count_errors () +let (wrapped_eh_add_one : error_handler -> issue -> unit) = + fun h -> + fun issue1 -> + let issue2 = fixup_issue_range issue1 in + h.eh_add_one issue2; + if issue2.issue_level <> EInfo + then + ((let uu___2 = + let uu___3 = + FStarC_Compiler_Effect.op_Bang FStarC_Options.abort_counter in + uu___3 - Prims.int_one in + FStarC_Compiler_Effect.op_Colon_Equals FStarC_Options.abort_counter + uu___2); + (let uu___2 = + let uu___3 = + FStarC_Compiler_Effect.op_Bang FStarC_Options.abort_counter in + uu___3 = Prims.int_zero in + if uu___2 then failwith "Aborting due to --abort_on" else ())) + else () +let (add_one : issue -> unit) = + fun issue1 -> + FStarC_Compiler_Util.atomically + (fun uu___ -> + let uu___1 = FStarC_Compiler_Effect.op_Bang current_handler in + wrapped_eh_add_one uu___1 issue1) +let (add_many : issue Prims.list -> unit) = + fun issues -> + FStarC_Compiler_Util.atomically + (fun uu___ -> + let uu___1 = + let uu___2 = FStarC_Compiler_Effect.op_Bang current_handler in + wrapped_eh_add_one uu___2 in + FStarC_Compiler_List.iter uu___1 issues) +let (add_issues : issue Prims.list -> unit) = fun issues -> add_many issues +let (report_all : unit -> issue Prims.list) = + fun uu___ -> + let uu___1 = FStarC_Compiler_Effect.op_Bang current_handler in + uu___1.eh_report () +let (clear : unit -> unit) = + fun uu___ -> + let uu___1 = FStarC_Compiler_Effect.op_Bang current_handler in + uu___1.eh_clear () +let (set_handler : error_handler -> unit) = + fun handler -> + let issues = report_all () in + clear (); + FStarC_Compiler_Effect.op_Colon_Equals current_handler handler; + add_many issues +type error_context_t = + { + push: Prims.string -> unit ; + pop: unit -> Prims.string ; + clear: unit -> unit ; + get: unit -> Prims.string Prims.list ; + set: Prims.string Prims.list -> unit } +let (__proj__Mkerror_context_t__item__push : + error_context_t -> Prims.string -> unit) = + fun projectee -> + match projectee with | { push; pop; clear = clear1; get; set;_} -> push +let (__proj__Mkerror_context_t__item__pop : + error_context_t -> unit -> Prims.string) = + fun projectee -> + match projectee with | { push; pop; clear = clear1; get; set;_} -> pop +let (__proj__Mkerror_context_t__item__clear : + error_context_t -> unit -> unit) = + fun projectee -> + match projectee with | { push; pop; clear = clear1; get; set;_} -> clear1 +let (__proj__Mkerror_context_t__item__get : + error_context_t -> unit -> Prims.string Prims.list) = + fun projectee -> + match projectee with | { push; pop; clear = clear1; get; set;_} -> get +let (__proj__Mkerror_context_t__item__set : + error_context_t -> Prims.string Prims.list -> unit) = + fun projectee -> + match projectee with | { push; pop; clear = clear1; get; set;_} -> set +let (error_context : error_context_t) = + let ctxs = FStarC_Compiler_Util.mk_ref [] in + let push s = + let uu___ = + let uu___1 = FStarC_Compiler_Effect.op_Bang ctxs in s :: uu___1 in + FStarC_Compiler_Effect.op_Colon_Equals ctxs uu___ in + let pop s = + let uu___ = FStarC_Compiler_Effect.op_Bang ctxs in + match uu___ with + | h::t -> (FStarC_Compiler_Effect.op_Colon_Equals ctxs t; h) + | uu___1 -> failwith "cannot pop error prefix..." in + let clear1 uu___ = FStarC_Compiler_Effect.op_Colon_Equals ctxs [] in + let get uu___ = FStarC_Compiler_Effect.op_Bang ctxs in + let set c = FStarC_Compiler_Effect.op_Colon_Equals ctxs c in + { push; pop; clear = clear1; get; set } +let (get_ctx : unit -> Prims.string Prims.list) = + fun uu___ -> error_context.get () +let (maybe_add_backtrace : + FStarC_Errors_Msg.error_message -> FStarC_Errors_Msg.error_message) = + fun msg -> + let uu___ = FStarC_Options.trace_error () in + if uu___ + then + let uu___1 = + let uu___2 = FStarC_Errors_Msg.backtrace_doc () in [uu___2] in + FStarC_Compiler_List.op_At msg uu___1 + else msg +let (warn_unsafe_options : + FStarC_Compiler_Range_Type.range FStar_Pervasives_Native.option -> + Prims.string -> unit) + = + fun rng_opt -> + fun msg -> + let uu___ = FStarC_Options.report_assumes () in + match uu___ with + | FStar_Pervasives_Native.Some "warn" -> + let uu___1 = + let uu___2 = + FStarC_Errors_Msg.mkmsg + (Prims.strcat "Every use of this option triggers a warning: " + msg) in + mk_issue EWarning rng_opt uu___2 + (FStar_Pervasives_Native.Some warn_on_use_errno) [] in + add_one uu___1 + | FStar_Pervasives_Native.Some "error" -> + let uu___1 = + let uu___2 = + FStarC_Errors_Msg.mkmsg + (Prims.strcat "Every use of this option triggers an error: " + msg) in + mk_issue EError rng_opt uu___2 + (FStar_Pervasives_Native.Some warn_on_use_errno) [] in + add_one uu___1 + | uu___1 -> () +let (set_option_warning_callback_range : + FStarC_Compiler_Range_Type.range FStar_Pervasives_Native.option -> unit) = + fun ropt -> + FStarC_Options.set_option_warning_callback (warn_unsafe_options ropt) +let (uu___0 : + (((Prims.string -> FStarC_Errors_Codes.error_setting Prims.list) -> unit) * + (unit -> FStarC_Errors_Codes.error_setting Prims.list))) + = + let parser_callback = + FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None in + let error_flags = FStarC_Compiler_Util.smap_create (Prims.of_int (10)) in + let set_error_flags uu___ = + let parse s = + let uu___1 = FStarC_Compiler_Effect.op_Bang parser_callback in + match uu___1 with + | FStar_Pervasives_Native.None -> + failwith "Callback for parsing warn_error strings is not set" + | FStar_Pervasives_Native.Some f -> f s in + let we = FStarC_Options.warn_error () in + try + (fun uu___1 -> + match () with + | () -> + let r = parse we in + (FStarC_Compiler_Util.smap_add error_flags we + (FStar_Pervasives_Native.Some r); + FStarC_Getopt.Success)) () + with + | Invalid_warn_error_setting msg -> + (FStarC_Compiler_Util.smap_add error_flags we + FStar_Pervasives_Native.None; + FStarC_Getopt.Error + (Prims.strcat "Invalid --warn_error setting: " + (Prims.strcat msg "\n"))) in + let get_error_flags uu___ = + let we = FStarC_Options.warn_error () in + let uu___1 = FStarC_Compiler_Util.smap_try_find error_flags we in + match uu___1 with + | FStar_Pervasives_Native.Some (FStar_Pervasives_Native.Some w) -> w + | uu___2 -> FStarC_Errors_Codes.default_settings in + let set_callbacks f = + FStarC_Compiler_Effect.op_Colon_Equals parser_callback + (FStar_Pervasives_Native.Some f); + FStarC_Options.set_error_flags_callback set_error_flags; + FStarC_Options.set_option_warning_callback + (warn_unsafe_options FStar_Pervasives_Native.None) in + (set_callbacks, get_error_flags) +let (t_set_parse_warn_error : + (Prims.string -> FStarC_Errors_Codes.error_setting Prims.list) -> unit) = + match uu___0 with + | (t_set_parse_warn_error1, error_flags) -> t_set_parse_warn_error1 +let (error_flags : unit -> FStarC_Errors_Codes.error_setting Prims.list) = + match uu___0 with | (t_set_parse_warn_error1, error_flags1) -> error_flags1 +let (set_parse_warn_error : + (Prims.string -> FStarC_Errors_Codes.error_setting Prims.list) -> unit) = + t_set_parse_warn_error +let (lookup : + FStarC_Errors_Codes.error_code -> FStarC_Errors_Codes.error_setting) = + fun err -> + let flags = error_flags () in + let uu___ = lookup_error flags err in + match uu___ with + | (v, level, i) -> + let with_level level1 = (v, level1, i) in + (match v with + | FStarC_Errors_Codes.Warning_Defensive when + (FStarC_Options.defensive_error ()) || + (FStarC_Options.defensive_abort ()) + -> with_level FStarC_Errors_Codes.CAlwaysError + | FStarC_Errors_Codes.Warning_WarnOnUse -> + let level' = + let uu___1 = FStarC_Options.report_assumes () in + match uu___1 with + | FStar_Pervasives_Native.None -> level + | FStar_Pervasives_Native.Some "warn" -> + (match level with + | FStarC_Errors_Codes.CSilent -> + FStarC_Errors_Codes.CWarning + | uu___2 -> level) + | FStar_Pervasives_Native.Some "error" -> + (match level with + | FStarC_Errors_Codes.CWarning -> + FStarC_Errors_Codes.CError + | FStarC_Errors_Codes.CSilent -> + FStarC_Errors_Codes.CError + | uu___2 -> level) + | FStar_Pervasives_Native.Some uu___2 -> level in + with_level level' + | uu___1 -> with_level level) +let (log_issue_ctx : + FStarC_Compiler_Range_Type.range -> + (FStarC_Errors_Codes.error_code * FStarC_Errors_Msg.error_message) -> + Prims.string Prims.list -> unit) + = + fun r -> + fun uu___ -> + fun ctx -> + match uu___ with + | (e, msg) -> + let msg1 = maybe_add_backtrace msg in + let uu___1 = lookup e in + (match uu___1 with + | (uu___2, FStarC_Errors_Codes.CAlwaysError, errno1) -> + add_one + (mk_issue EError (FStar_Pervasives_Native.Some r) msg1 + (FStar_Pervasives_Native.Some errno1) ctx) + | (uu___2, FStarC_Errors_Codes.CError, errno1) -> + add_one + (mk_issue EError (FStar_Pervasives_Native.Some r) msg1 + (FStar_Pervasives_Native.Some errno1) ctx) + | (uu___2, FStarC_Errors_Codes.CWarning, errno1) -> + add_one + (mk_issue EWarning (FStar_Pervasives_Native.Some r) msg1 + (FStar_Pervasives_Native.Some errno1) ctx) + | (uu___2, FStarC_Errors_Codes.CSilent, uu___3) -> () + | (uu___2, FStarC_Errors_Codes.CFatal, errno1) -> + let i = + mk_issue EError (FStar_Pervasives_Native.Some r) msg1 + (FStar_Pervasives_Native.Some errno1) ctx in + let uu___3 = FStarC_Options.ide () in + if uu___3 + then add_one i + else + (let uu___5 = + let uu___6 = format_issue i in + Prims.strcat + "don't use log_issue to report fatal error, should use raise_error: " + uu___6 in + failwith uu___5)) +let info : + 'posut . + 'posut FStarC_Class_HasRange.hasRange -> + 'posut -> + unit -> Obj.t FStarC_Errors_Msg.is_error_message -> Obj.t -> unit + = + fun uu___ -> + fun r -> + fun uu___1 -> + fun uu___2 -> + fun msg -> + let rng = FStarC_Class_HasRange.pos uu___ r in + let msg1 = FStarC_Errors_Msg.to_doc_list uu___2 msg in + let msg2 = maybe_add_backtrace msg1 in + let ctx = get_ctx () in + add_one + (mk_issue EInfo (FStar_Pervasives_Native.Some rng) msg2 + FStar_Pervasives_Native.None ctx) +let diag : + 'posut . + 'posut FStarC_Class_HasRange.hasRange -> + 'posut -> + unit -> Obj.t FStarC_Errors_Msg.is_error_message -> Obj.t -> unit + = + fun uu___ -> + fun r -> + fun uu___1 -> + fun uu___2 -> + fun msg -> + let uu___3 = FStarC_Compiler_Debug.any () in + if uu___3 then info uu___ r () uu___2 msg else () +let raise_error : + 'a 'posut . + 'posut FStarC_Class_HasRange.hasRange -> + 'posut -> + FStarC_Errors_Codes.error_code -> + unit -> Obj.t FStarC_Errors_Msg.is_error_message -> Obj.t -> 'a + = + fun uu___ -> + fun r -> + fun e -> + fun uu___1 -> + fun uu___2 -> + fun msg -> + let rng = FStarC_Class_HasRange.pos uu___ r in + let msg1 = FStarC_Errors_Msg.to_doc_list uu___2 msg in + let uu___3 = + let uu___4 = + let uu___5 = maybe_add_backtrace msg1 in + let uu___6 = error_context.get () in + (e, uu___5, rng, uu___6) in + Error uu___4 in + FStarC_Compiler_Effect.raise uu___3 +let log_issue : + 'posut . + 'posut FStarC_Class_HasRange.hasRange -> + 'posut -> + FStarC_Errors_Codes.error_code -> + unit -> Obj.t FStarC_Errors_Msg.is_error_message -> Obj.t -> unit + = + fun uu___ -> + fun r -> + fun e -> + fun uu___1 -> + fun uu___2 -> + fun msg -> + let rng = FStarC_Class_HasRange.pos uu___ r in + let msg1 = FStarC_Errors_Msg.to_doc_list uu___2 msg in + let ctx = error_context.get () in + log_issue_ctx rng (e, msg1) ctx +let raise_error0 : + 'a . + FStarC_Errors_Codes.error_code -> + unit -> Obj.t FStarC_Errors_Msg.is_error_message -> Obj.t -> 'a + = + fun e -> + fun uu___ -> + fun uu___1 -> + fun msg -> + raise_error FStarC_Class_HasRange.hasRange_range + FStarC_Compiler_Range_Type.dummyRange e () uu___1 msg +let (log_issue0 : + FStarC_Errors_Codes.error_code -> + unit -> Obj.t FStarC_Errors_Msg.is_error_message -> Obj.t -> unit) + = + fun e -> + fun uu___ -> + fun uu___1 -> + fun msg -> + log_issue FStarC_Class_HasRange.hasRange_range + FStarC_Compiler_Range_Type.dummyRange e () uu___1 msg +let diag0 : 't . 't FStarC_Errors_Msg.is_error_message -> 't -> unit = + fun uu___ -> + fun msg -> + diag FStarC_Class_HasRange.hasRange_range + FStarC_Compiler_Range_Type.dummyRange () (Obj.magic uu___) + (Obj.magic msg) +let (add_errors : error Prims.list -> unit) = + fun errs -> + FStarC_Compiler_Util.atomically + (fun uu___ -> + FStarC_Compiler_List.iter + (fun uu___1 -> + match uu___1 with + | (e, msg, r, ctx) -> log_issue_ctx r (e, msg) ctx) errs) +let (issue_of_exn : Prims.exn -> issue FStar_Pervasives_Native.option) = + fun e -> + match e with + | Error (e1, msg, r, ctx) -> + let errno1 = let uu___ = lookup e1 in error_number uu___ in + FStar_Pervasives_Native.Some + (mk_issue EError (FStar_Pervasives_Native.Some r) msg + (FStar_Pervasives_Native.Some errno1) ctx) + | uu___ -> FStar_Pervasives_Native.None +let (err_exn : Prims.exn -> unit) = + fun exn -> + if exn = Stop + then () + else + (let uu___1 = issue_of_exn exn in + match uu___1 with + | FStar_Pervasives_Native.Some issue1 -> add_one issue1 + | FStar_Pervasives_Native.None -> FStarC_Compiler_Effect.raise exn) +let (handleable : Prims.exn -> Prims.bool) = + fun uu___ -> + match uu___ with | Error uu___1 -> true | Stop -> true | uu___1 -> false +let (stop_if_err : unit -> unit) = + fun uu___ -> + let uu___1 = let uu___2 = get_err_count () in uu___2 > Prims.int_zero in + if uu___1 then FStarC_Compiler_Effect.raise Stop else () +let with_ctx : 'a . Prims.string -> (unit -> 'a) -> 'a = + fun s -> + fun f -> + error_context.push s; + (let r = + let uu___1 = FStarC_Options.trace_error () in + if uu___1 + then let uu___2 = f () in FStar_Pervasives.Inr uu___2 + else + (try + (fun uu___3 -> + match () with + | () -> let uu___4 = f () in FStar_Pervasives.Inr uu___4) () + with + | FStarC_Compiler_Effect.Failure msg -> + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = error_context.get () in ctx_doc uu___9 in + [uu___8] in + FStarC_Errors_Msg.rendermsg uu___7 in + Prims.strcat msg uu___6 in + FStarC_Compiler_Effect.Failure uu___5 in + FStar_Pervasives.Inl uu___4 + | ex -> FStar_Pervasives.Inl ex) in + (let uu___2 = error_context.pop () in ()); + (match r with + | FStar_Pervasives.Inr r1 -> r1 + | FStar_Pervasives.Inl e -> FStarC_Compiler_Effect.raise e)) +let with_ctx_if : 'a . Prims.bool -> Prims.string -> (unit -> 'a) -> 'a = + fun b -> fun s -> fun f -> if b then with_ctx s f else f () +let catch_errors_aux : + 'a . + (unit -> 'a) -> + (issue Prims.list * issue Prims.list * 'a + FStar_Pervasives_Native.option) + = + fun f -> + let newh = mk_default_handler false in + let old = FStarC_Compiler_Effect.op_Bang current_handler in + FStarC_Compiler_Effect.op_Colon_Equals current_handler newh; + (let finally_restore uu___1 = + let all_issues = newh.eh_report () in + FStarC_Compiler_Effect.op_Colon_Equals current_handler old; + (let uu___3 = + FStarC_Compiler_List.partition (fun i -> i.issue_level = EError) + all_issues in + match uu___3 with | (errs, rest) -> (errs, rest)) in + let r = + try + (fun uu___1 -> + match () with + | () -> let uu___2 = f () in FStar_Pervasives_Native.Some uu___2) + () + with + | uu___1 -> + if handleable uu___1 + then (err_exn uu___1; FStar_Pervasives_Native.None) + else + (let uu___2 = finally_restore () in + FStarC_Compiler_Effect.raise uu___1) in + let uu___1 = finally_restore () in + match uu___1 with | (errs, rest) -> (errs, rest, r)) +let no_ctx : 'a . (unit -> 'a) -> 'a = + fun f -> + let save = error_context.get () in + error_context.clear (); (let res = f () in error_context.set save; res) +let catch_errors : + 'a . (unit -> 'a) -> (issue Prims.list * 'a FStar_Pervasives_Native.option) + = + fun f -> + let uu___ = catch_errors_aux f in + match uu___ with + | (errs, rest, r) -> + ((let uu___2 = + let uu___3 = FStarC_Compiler_Effect.op_Bang current_handler in + uu___3.eh_add_one in + FStarC_Compiler_List.iter uu___2 rest); + (errs, r)) +let catch_errors_and_ignore_rest : + 'a . (unit -> 'a) -> (issue Prims.list * 'a FStar_Pervasives_Native.option) + = + fun f -> + let uu___ = catch_errors_aux f in + match uu___ with + | (errs, rest, r) -> + ((let uu___2 = + let uu___3 = FStarC_Compiler_Effect.op_Bang current_handler in + uu___3.eh_add_one in + let uu___3 = + FStarC_Compiler_List.filter (fun i -> i.issue_level = EInfo) rest in + FStarC_Compiler_List.iter uu___2 uu___3); + (errs, r)) +let (find_multiset_discrepancy : + Prims.int Prims.list -> + Prims.int Prims.list -> + (Prims.int * Prims.int * Prims.int) FStar_Pervasives_Native.option) + = + fun l1 -> + fun l2 -> + let sort = FStarC_Compiler_List.sortWith (fun x -> fun y -> x - y) in + let rec collect l = + match l with + | [] -> [] + | hd::tl -> + let uu___ = collect tl in + (match uu___ with + | [] -> [(hd, Prims.int_one)] + | (h, n)::t -> + if h = hd + then (h, (n + Prims.int_one)) :: t + else (hd, Prims.int_one) :: (h, n) :: t) in + let l11 = let uu___ = sort l1 in collect uu___ in + let l21 = let uu___ = sort l2 in collect uu___ in + let rec aux l12 l22 = + match (l12, l22) with + | ([], []) -> FStar_Pervasives_Native.None + | ((e, n)::uu___, []) -> + FStar_Pervasives_Native.Some (e, n, Prims.int_zero) + | ([], (e, n)::uu___) -> + FStar_Pervasives_Native.Some (e, Prims.int_zero, n) + | ((hd1, n1)::tl1, (hd2, n2)::tl2) -> + if hd1 < hd2 + then FStar_Pervasives_Native.Some (hd1, n1, Prims.int_zero) + else + if hd1 > hd2 + then FStar_Pervasives_Native.Some (hd2, Prims.int_zero, n2) + else + if n1 <> n2 + then FStar_Pervasives_Native.Some (hd1, n1, n2) + else aux tl1 tl2 in + aux l11 l21 +let raise_error_doc : + 'a . + FStarC_Compiler_Range_Type.range -> + FStarC_Errors_Codes.error_code -> FStarC_Errors_Msg.error_message -> 'a + = + fun rng -> + fun code -> + fun msg -> + raise_error FStarC_Class_HasRange.hasRange_range rng code () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic msg) +let (log_issue_doc : + FStarC_Compiler_Range_Type.range -> + FStarC_Errors_Codes.error_code -> FStarC_Errors_Msg.error_message -> unit) + = + fun rng -> + fun code -> + fun msg -> + log_issue FStarC_Class_HasRange.hasRange_range rng code () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic msg) +let raise_error_text : + 'a . + FStarC_Compiler_Range_Type.range -> + FStarC_Errors_Codes.error_code -> Prims.string -> 'a + = + fun rng -> + fun code -> + fun msg -> + raise_error FStarC_Class_HasRange.hasRange_range rng code () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic msg) +let (log_issue_text : + FStarC_Compiler_Range_Type.range -> + FStarC_Errors_Codes.error_code -> Prims.string -> unit) + = + fun rng -> + fun code -> + fun msg -> + log_issue FStarC_Class_HasRange.hasRange_range rng code () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic msg) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Errors_Codes.ml b/ocaml/fstar-lib/generated/FStarC_Errors_Codes.ml similarity index 100% rename from ocaml/fstar-lib/generated/FStar_Errors_Codes.ml rename to ocaml/fstar-lib/generated/FStarC_Errors_Codes.ml diff --git a/ocaml/fstar-lib/generated/FStarC_Errors_Msg.ml b/ocaml/fstar-lib/generated/FStarC_Errors_Msg.ml new file mode 100644 index 00000000000..9edd2bec618 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Errors_Msg.ml @@ -0,0 +1,103 @@ +open Prims +type error_message = FStarC_Pprint.document Prims.list +type 't is_error_message = { + to_doc_list: 't -> error_message } +let __proj__Mkis_error_message__item__to_doc_list : + 't . 't is_error_message -> 't -> error_message = + fun projectee -> match projectee with | { to_doc_list;_} -> to_doc_list +let to_doc_list : 't . 't is_error_message -> 't -> error_message = + fun projectee -> + match projectee with | { to_doc_list = to_doc_list1;_} -> to_doc_list1 +let (is_error_message_string : Prims.string is_error_message) = + { + to_doc_list = + (fun s -> let uu___ = FStarC_Pprint.arbitrary_string s in [uu___]) + } +let (is_error_message_list_doc : + FStarC_Pprint.document Prims.list is_error_message) = + { to_doc_list = (fun x -> x) } +let (vconcat : FStarC_Pprint.document Prims.list -> FStarC_Pprint.document) = + fun ds -> + match ds with + | h::t -> + FStarC_Compiler_List.fold_left + (fun l -> + fun r -> + let uu___ = FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline r in + FStarC_Pprint.op_Hat_Hat l uu___) h t + | [] -> FStarC_Pprint.empty +let (text : Prims.string -> FStarC_Pprint.document) = + fun s -> + let uu___ = FStarC_Pprint.break_ Prims.int_one in + let uu___1 = FStarC_Pprint.words s in FStarC_Pprint.flow uu___ uu___1 +let (sublist : + FStarC_Pprint.document -> + FStarC_Pprint.document Prims.list -> FStarC_Pprint.document) + = + fun h -> + fun ds -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Compiler_List.map + (fun d -> FStarC_Pprint.op_Hat_Hat h d) ds in + vconcat uu___3 in + FStarC_Pprint.align uu___2 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline uu___1 in + FStarC_Pprint.nest (Prims.of_int (2)) uu___ +let (bulleted : FStarC_Pprint.document Prims.list -> FStarC_Pprint.document) + = + fun ds -> let uu___ = FStarC_Pprint.doc_of_string "- " in sublist uu___ ds +let (mkmsg : Prims.string -> error_message) = + fun s -> let uu___ = FStarC_Pprint.arbitrary_string s in [uu___] +let (renderdoc : FStarC_Pprint.document -> Prims.string) = + fun d -> + let one = FStarC_Compiler_Util.float_of_string "1.0" in + FStarC_Pprint.pretty_string one (Prims.of_int (80)) d +let (backtrace_doc : unit -> FStarC_Pprint.document) = + fun uu___ -> + let s = FStarC_Compiler_Util.stack_dump () in + let uu___1 = text "Stack trace:" in + let uu___2 = + FStarC_Pprint.arbitrary_string (FStarC_Compiler_Util.trim_string s) in + FStarC_Pprint.op_Hat_Slash_Hat uu___1 uu___2 +let (subdoc' : + Prims.bool -> FStarC_Pprint.document -> FStarC_Pprint.document) = + fun indent -> + fun d -> + if d = FStarC_Pprint.empty + then FStarC_Pprint.empty + else + (let uu___1 = + if indent + then FStarC_Pprint.blank (Prims.of_int (2)) + else FStarC_Pprint.empty in + let uu___2 = + let uu___3 = FStarC_Pprint.doc_of_string "-" in + let uu___4 = + let uu___5 = FStarC_Pprint.blank Prims.int_one in + let uu___6 = + let uu___7 = FStarC_Pprint.align d in + FStarC_Pprint.op_Hat_Hat uu___7 FStarC_Pprint.hardline in + FStarC_Pprint.op_Hat_Hat uu___5 uu___6 in + FStarC_Pprint.op_Hat_Hat uu___3 uu___4 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2) +let (subdoc : FStarC_Pprint.document -> FStarC_Pprint.document) = + fun d -> subdoc' true d +let (rendermsg : error_message -> Prims.string) = + fun ds -> + let uu___ = + let uu___1 = + FStarC_Compiler_List.map + (fun d -> let uu___2 = FStarC_Pprint.group d in subdoc uu___2) ds in + FStarC_Pprint.concat uu___1 in + renderdoc uu___ +let (json_of_error_message : + FStarC_Pprint.document Prims.list -> FStarC_Json.json) = + fun err_msg -> + let uu___ = + FStarC_Compiler_List.map + (fun doc -> let uu___1 = renderdoc doc in FStarC_Json.JsonStr uu___1) + err_msg in + FStarC_Json.JsonList uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Extraction_Krml.ml b/ocaml/fstar-lib/generated/FStarC_Extraction_Krml.ml new file mode 100644 index 00000000000..4c70aedc2ac --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Extraction_Krml.ml @@ -0,0 +1,4022 @@ +open Prims +type version = Prims.int +let (current_version : version) = (Prims.of_int (31)) +type decl = + | DGlobal of (flag Prims.list * (Prims.string Prims.list * Prims.string) * + Prims.int * typ * expr) + | DFunction of (cc FStar_Pervasives_Native.option * flag Prims.list * + Prims.int * typ * (Prims.string Prims.list * Prims.string) * binder + Prims.list * expr) + | DTypeAlias of ((Prims.string Prims.list * Prims.string) * flag Prims.list + * Prims.int * typ) + | DTypeFlat of ((Prims.string Prims.list * Prims.string) * flag Prims.list + * Prims.int * (Prims.string * (typ * Prims.bool)) Prims.list) + | DUnusedRetainedForBackwardsCompat of (cc FStar_Pervasives_Native.option * + flag Prims.list * (Prims.string Prims.list * Prims.string) * typ) + | DTypeVariant of ((Prims.string Prims.list * Prims.string) * flag + Prims.list * Prims.int * (Prims.string * (Prims.string * (typ * + Prims.bool)) Prims.list) Prims.list) + | DTypeAbstractStruct of (Prims.string Prims.list * Prims.string) + | DExternal of (cc FStar_Pervasives_Native.option * flag Prims.list * + (Prims.string Prims.list * Prims.string) * typ * Prims.string Prims.list) + | DUntaggedUnion of ((Prims.string Prims.list * Prims.string) * flag + Prims.list * Prims.int * (Prims.string * typ) Prims.list) +and cc = + | StdCall + | CDecl + | FastCall +and flag = + | Private + | WipeBody + | CInline + | Substitute + | GCType + | Comment of Prims.string + | MustDisappear + | Const of Prims.string + | Prologue of Prims.string + | Epilogue of Prims.string + | Abstract + | IfDef + | Macro + | Deprecated of Prims.string + | CNoInline +and lifetime = + | Eternal + | Stack + | ManuallyManaged +and expr = + | EBound of Prims.int + | EQualified of (Prims.string Prims.list * Prims.string) + | EConstant of (width * Prims.string) + | EUnit + | EApp of (expr * expr Prims.list) + | ETypApp of (expr * typ Prims.list) + | ELet of (binder * expr * expr) + | EIfThenElse of (expr * expr * expr) + | ESequence of expr Prims.list + | EAssign of (expr * expr) + | EBufCreate of (lifetime * expr * expr) + | EBufRead of (expr * expr) + | EBufWrite of (expr * expr * expr) + | EBufSub of (expr * expr) + | EBufBlit of (expr * expr * expr * expr * expr) + | EMatch of (expr * (pattern * expr) Prims.list) + | EOp of (op * width) + | ECast of (expr * typ) + | EPushFrame + | EPopFrame + | EBool of Prims.bool + | EAny + | EAbort + | EReturn of expr + | EFlat of (typ * (Prims.string * expr) Prims.list) + | EField of (typ * expr * Prims.string) + | EWhile of (expr * expr) + | EBufCreateL of (lifetime * expr Prims.list) + | ETuple of expr Prims.list + | ECons of (typ * Prims.string * expr Prims.list) + | EBufFill of (expr * expr * expr) + | EString of Prims.string + | EFun of (binder Prims.list * expr * typ) + | EAbortS of Prims.string + | EBufFree of expr + | EBufCreateNoInit of (lifetime * expr) + | EAbortT of (Prims.string * typ) + | EComment of (Prims.string * expr * Prims.string) + | EStandaloneComment of Prims.string + | EAddrOf of expr + | EBufNull of typ + | EBufDiff of (expr * expr) +and op = + | Add + | AddW + | Sub + | SubW + | Div + | DivW + | Mult + | MultW + | Mod + | BOr + | BAnd + | BXor + | BShiftL + | BShiftR + | BNot + | Eq + | Neq + | Lt + | Lte + | Gt + | Gte + | And + | Or + | Xor + | Not +and pattern = + | PUnit + | PBool of Prims.bool + | PVar of binder + | PCons of (Prims.string * pattern Prims.list) + | PTuple of pattern Prims.list + | PRecord of (Prims.string * pattern) Prims.list + | PConstant of (width * Prims.string) +and width = + | UInt8 + | UInt16 + | UInt32 + | UInt64 + | Int8 + | Int16 + | Int32 + | Int64 + | Bool + | CInt + | SizeT + | PtrdiffT +and binder = + { + name: Prims.string ; + typ: typ ; + mut: Prims.bool ; + meta: flag Prims.list } +and typ = + | TInt of width + | TBuf of typ + | TUnit + | TQualified of (Prims.string Prims.list * Prims.string) + | TBool + | TAny + | TArrow of (typ * typ) + | TBound of Prims.int + | TApp of ((Prims.string Prims.list * Prims.string) * typ Prims.list) + | TTuple of typ Prims.list + | TConstBuf of typ + | TArray of (typ * (width * Prims.string)) +let (uu___is_DGlobal : decl -> Prims.bool) = + fun projectee -> match projectee with | DGlobal _0 -> true | uu___ -> false +let (__proj__DGlobal__item___0 : + decl -> + (flag Prims.list * (Prims.string Prims.list * Prims.string) * Prims.int * + typ * expr)) + = fun projectee -> match projectee with | DGlobal _0 -> _0 +let (uu___is_DFunction : decl -> Prims.bool) = + fun projectee -> + match projectee with | DFunction _0 -> true | uu___ -> false +let (__proj__DFunction__item___0 : + decl -> + (cc FStar_Pervasives_Native.option * flag Prims.list * Prims.int * typ * + (Prims.string Prims.list * Prims.string) * binder Prims.list * expr)) + = fun projectee -> match projectee with | DFunction _0 -> _0 +let (uu___is_DTypeAlias : decl -> Prims.bool) = + fun projectee -> + match projectee with | DTypeAlias _0 -> true | uu___ -> false +let (__proj__DTypeAlias__item___0 : + decl -> + ((Prims.string Prims.list * Prims.string) * flag Prims.list * Prims.int * + typ)) + = fun projectee -> match projectee with | DTypeAlias _0 -> _0 +let (uu___is_DTypeFlat : decl -> Prims.bool) = + fun projectee -> + match projectee with | DTypeFlat _0 -> true | uu___ -> false +let (__proj__DTypeFlat__item___0 : + decl -> + ((Prims.string Prims.list * Prims.string) * flag Prims.list * Prims.int * + (Prims.string * (typ * Prims.bool)) Prims.list)) + = fun projectee -> match projectee with | DTypeFlat _0 -> _0 +let (uu___is_DUnusedRetainedForBackwardsCompat : decl -> Prims.bool) = + fun projectee -> + match projectee with + | DUnusedRetainedForBackwardsCompat _0 -> true + | uu___ -> false +let (__proj__DUnusedRetainedForBackwardsCompat__item___0 : + decl -> + (cc FStar_Pervasives_Native.option * flag Prims.list * (Prims.string + Prims.list * Prims.string) * typ)) + = + fun projectee -> + match projectee with | DUnusedRetainedForBackwardsCompat _0 -> _0 +let (uu___is_DTypeVariant : decl -> Prims.bool) = + fun projectee -> + match projectee with | DTypeVariant _0 -> true | uu___ -> false +let (__proj__DTypeVariant__item___0 : + decl -> + ((Prims.string Prims.list * Prims.string) * flag Prims.list * Prims.int * + (Prims.string * (Prims.string * (typ * Prims.bool)) Prims.list) + Prims.list)) + = fun projectee -> match projectee with | DTypeVariant _0 -> _0 +let (uu___is_DTypeAbstractStruct : decl -> Prims.bool) = + fun projectee -> + match projectee with | DTypeAbstractStruct _0 -> true | uu___ -> false +let (__proj__DTypeAbstractStruct__item___0 : + decl -> (Prims.string Prims.list * Prims.string)) = + fun projectee -> match projectee with | DTypeAbstractStruct _0 -> _0 +let (uu___is_DExternal : decl -> Prims.bool) = + fun projectee -> + match projectee with | DExternal _0 -> true | uu___ -> false +let (__proj__DExternal__item___0 : + decl -> + (cc FStar_Pervasives_Native.option * flag Prims.list * (Prims.string + Prims.list * Prims.string) * typ * Prims.string Prims.list)) + = fun projectee -> match projectee with | DExternal _0 -> _0 +let (uu___is_DUntaggedUnion : decl -> Prims.bool) = + fun projectee -> + match projectee with | DUntaggedUnion _0 -> true | uu___ -> false +let (__proj__DUntaggedUnion__item___0 : + decl -> + ((Prims.string Prims.list * Prims.string) * flag Prims.list * Prims.int * + (Prims.string * typ) Prims.list)) + = fun projectee -> match projectee with | DUntaggedUnion _0 -> _0 +let (uu___is_StdCall : cc -> Prims.bool) = + fun projectee -> match projectee with | StdCall -> true | uu___ -> false +let (uu___is_CDecl : cc -> Prims.bool) = + fun projectee -> match projectee with | CDecl -> true | uu___ -> false +let (uu___is_FastCall : cc -> Prims.bool) = + fun projectee -> match projectee with | FastCall -> true | uu___ -> false +let (uu___is_Private : flag -> Prims.bool) = + fun projectee -> match projectee with | Private -> true | uu___ -> false +let (uu___is_WipeBody : flag -> Prims.bool) = + fun projectee -> match projectee with | WipeBody -> true | uu___ -> false +let (uu___is_CInline : flag -> Prims.bool) = + fun projectee -> match projectee with | CInline -> true | uu___ -> false +let (uu___is_Substitute : flag -> Prims.bool) = + fun projectee -> match projectee with | Substitute -> true | uu___ -> false +let (uu___is_GCType : flag -> Prims.bool) = + fun projectee -> match projectee with | GCType -> true | uu___ -> false +let (uu___is_Comment : flag -> Prims.bool) = + fun projectee -> match projectee with | Comment _0 -> true | uu___ -> false +let (__proj__Comment__item___0 : flag -> Prims.string) = + fun projectee -> match projectee with | Comment _0 -> _0 +let (uu___is_MustDisappear : flag -> Prims.bool) = + fun projectee -> + match projectee with | MustDisappear -> true | uu___ -> false +let (uu___is_Const : flag -> Prims.bool) = + fun projectee -> match projectee with | Const _0 -> true | uu___ -> false +let (__proj__Const__item___0 : flag -> Prims.string) = + fun projectee -> match projectee with | Const _0 -> _0 +let (uu___is_Prologue : flag -> Prims.bool) = + fun projectee -> + match projectee with | Prologue _0 -> true | uu___ -> false +let (__proj__Prologue__item___0 : flag -> Prims.string) = + fun projectee -> match projectee with | Prologue _0 -> _0 +let (uu___is_Epilogue : flag -> Prims.bool) = + fun projectee -> + match projectee with | Epilogue _0 -> true | uu___ -> false +let (__proj__Epilogue__item___0 : flag -> Prims.string) = + fun projectee -> match projectee with | Epilogue _0 -> _0 +let (uu___is_Abstract : flag -> Prims.bool) = + fun projectee -> match projectee with | Abstract -> true | uu___ -> false +let (uu___is_IfDef : flag -> Prims.bool) = + fun projectee -> match projectee with | IfDef -> true | uu___ -> false +let (uu___is_Macro : flag -> Prims.bool) = + fun projectee -> match projectee with | Macro -> true | uu___ -> false +let (uu___is_Deprecated : flag -> Prims.bool) = + fun projectee -> + match projectee with | Deprecated _0 -> true | uu___ -> false +let (__proj__Deprecated__item___0 : flag -> Prims.string) = + fun projectee -> match projectee with | Deprecated _0 -> _0 +let (uu___is_CNoInline : flag -> Prims.bool) = + fun projectee -> match projectee with | CNoInline -> true | uu___ -> false +let (uu___is_Eternal : lifetime -> Prims.bool) = + fun projectee -> match projectee with | Eternal -> true | uu___ -> false +let (uu___is_Stack : lifetime -> Prims.bool) = + fun projectee -> match projectee with | Stack -> true | uu___ -> false +let (uu___is_ManuallyManaged : lifetime -> Prims.bool) = + fun projectee -> + match projectee with | ManuallyManaged -> true | uu___ -> false +let (uu___is_EBound : expr -> Prims.bool) = + fun projectee -> match projectee with | EBound _0 -> true | uu___ -> false +let (__proj__EBound__item___0 : expr -> Prims.int) = + fun projectee -> match projectee with | EBound _0 -> _0 +let (uu___is_EQualified : expr -> Prims.bool) = + fun projectee -> + match projectee with | EQualified _0 -> true | uu___ -> false +let (__proj__EQualified__item___0 : + expr -> (Prims.string Prims.list * Prims.string)) = + fun projectee -> match projectee with | EQualified _0 -> _0 +let (uu___is_EConstant : expr -> Prims.bool) = + fun projectee -> + match projectee with | EConstant _0 -> true | uu___ -> false +let (__proj__EConstant__item___0 : expr -> (width * Prims.string)) = + fun projectee -> match projectee with | EConstant _0 -> _0 +let (uu___is_EUnit : expr -> Prims.bool) = + fun projectee -> match projectee with | EUnit -> true | uu___ -> false +let (uu___is_EApp : expr -> Prims.bool) = + fun projectee -> match projectee with | EApp _0 -> true | uu___ -> false +let (__proj__EApp__item___0 : expr -> (expr * expr Prims.list)) = + fun projectee -> match projectee with | EApp _0 -> _0 +let (uu___is_ETypApp : expr -> Prims.bool) = + fun projectee -> match projectee with | ETypApp _0 -> true | uu___ -> false +let (__proj__ETypApp__item___0 : expr -> (expr * typ Prims.list)) = + fun projectee -> match projectee with | ETypApp _0 -> _0 +let (uu___is_ELet : expr -> Prims.bool) = + fun projectee -> match projectee with | ELet _0 -> true | uu___ -> false +let (__proj__ELet__item___0 : expr -> (binder * expr * expr)) = + fun projectee -> match projectee with | ELet _0 -> _0 +let (uu___is_EIfThenElse : expr -> Prims.bool) = + fun projectee -> + match projectee with | EIfThenElse _0 -> true | uu___ -> false +let (__proj__EIfThenElse__item___0 : expr -> (expr * expr * expr)) = + fun projectee -> match projectee with | EIfThenElse _0 -> _0 +let (uu___is_ESequence : expr -> Prims.bool) = + fun projectee -> + match projectee with | ESequence _0 -> true | uu___ -> false +let (__proj__ESequence__item___0 : expr -> expr Prims.list) = + fun projectee -> match projectee with | ESequence _0 -> _0 +let (uu___is_EAssign : expr -> Prims.bool) = + fun projectee -> match projectee with | EAssign _0 -> true | uu___ -> false +let (__proj__EAssign__item___0 : expr -> (expr * expr)) = + fun projectee -> match projectee with | EAssign _0 -> _0 +let (uu___is_EBufCreate : expr -> Prims.bool) = + fun projectee -> + match projectee with | EBufCreate _0 -> true | uu___ -> false +let (__proj__EBufCreate__item___0 : expr -> (lifetime * expr * expr)) = + fun projectee -> match projectee with | EBufCreate _0 -> _0 +let (uu___is_EBufRead : expr -> Prims.bool) = + fun projectee -> + match projectee with | EBufRead _0 -> true | uu___ -> false +let (__proj__EBufRead__item___0 : expr -> (expr * expr)) = + fun projectee -> match projectee with | EBufRead _0 -> _0 +let (uu___is_EBufWrite : expr -> Prims.bool) = + fun projectee -> + match projectee with | EBufWrite _0 -> true | uu___ -> false +let (__proj__EBufWrite__item___0 : expr -> (expr * expr * expr)) = + fun projectee -> match projectee with | EBufWrite _0 -> _0 +let (uu___is_EBufSub : expr -> Prims.bool) = + fun projectee -> match projectee with | EBufSub _0 -> true | uu___ -> false +let (__proj__EBufSub__item___0 : expr -> (expr * expr)) = + fun projectee -> match projectee with | EBufSub _0 -> _0 +let (uu___is_EBufBlit : expr -> Prims.bool) = + fun projectee -> + match projectee with | EBufBlit _0 -> true | uu___ -> false +let (__proj__EBufBlit__item___0 : expr -> (expr * expr * expr * expr * expr)) + = fun projectee -> match projectee with | EBufBlit _0 -> _0 +let (uu___is_EMatch : expr -> Prims.bool) = + fun projectee -> match projectee with | EMatch _0 -> true | uu___ -> false +let (__proj__EMatch__item___0 : expr -> (expr * (pattern * expr) Prims.list)) + = fun projectee -> match projectee with | EMatch _0 -> _0 +let (uu___is_EOp : expr -> Prims.bool) = + fun projectee -> match projectee with | EOp _0 -> true | uu___ -> false +let (__proj__EOp__item___0 : expr -> (op * width)) = + fun projectee -> match projectee with | EOp _0 -> _0 +let (uu___is_ECast : expr -> Prims.bool) = + fun projectee -> match projectee with | ECast _0 -> true | uu___ -> false +let (__proj__ECast__item___0 : expr -> (expr * typ)) = + fun projectee -> match projectee with | ECast _0 -> _0 +let (uu___is_EPushFrame : expr -> Prims.bool) = + fun projectee -> match projectee with | EPushFrame -> true | uu___ -> false +let (uu___is_EPopFrame : expr -> Prims.bool) = + fun projectee -> match projectee with | EPopFrame -> true | uu___ -> false +let (uu___is_EBool : expr -> Prims.bool) = + fun projectee -> match projectee with | EBool _0 -> true | uu___ -> false +let (__proj__EBool__item___0 : expr -> Prims.bool) = + fun projectee -> match projectee with | EBool _0 -> _0 +let (uu___is_EAny : expr -> Prims.bool) = + fun projectee -> match projectee with | EAny -> true | uu___ -> false +let (uu___is_EAbort : expr -> Prims.bool) = + fun projectee -> match projectee with | EAbort -> true | uu___ -> false +let (uu___is_EReturn : expr -> Prims.bool) = + fun projectee -> match projectee with | EReturn _0 -> true | uu___ -> false +let (__proj__EReturn__item___0 : expr -> expr) = + fun projectee -> match projectee with | EReturn _0 -> _0 +let (uu___is_EFlat : expr -> Prims.bool) = + fun projectee -> match projectee with | EFlat _0 -> true | uu___ -> false +let (__proj__EFlat__item___0 : + expr -> (typ * (Prims.string * expr) Prims.list)) = + fun projectee -> match projectee with | EFlat _0 -> _0 +let (uu___is_EField : expr -> Prims.bool) = + fun projectee -> match projectee with | EField _0 -> true | uu___ -> false +let (__proj__EField__item___0 : expr -> (typ * expr * Prims.string)) = + fun projectee -> match projectee with | EField _0 -> _0 +let (uu___is_EWhile : expr -> Prims.bool) = + fun projectee -> match projectee with | EWhile _0 -> true | uu___ -> false +let (__proj__EWhile__item___0 : expr -> (expr * expr)) = + fun projectee -> match projectee with | EWhile _0 -> _0 +let (uu___is_EBufCreateL : expr -> Prims.bool) = + fun projectee -> + match projectee with | EBufCreateL _0 -> true | uu___ -> false +let (__proj__EBufCreateL__item___0 : expr -> (lifetime * expr Prims.list)) = + fun projectee -> match projectee with | EBufCreateL _0 -> _0 +let (uu___is_ETuple : expr -> Prims.bool) = + fun projectee -> match projectee with | ETuple _0 -> true | uu___ -> false +let (__proj__ETuple__item___0 : expr -> expr Prims.list) = + fun projectee -> match projectee with | ETuple _0 -> _0 +let (uu___is_ECons : expr -> Prims.bool) = + fun projectee -> match projectee with | ECons _0 -> true | uu___ -> false +let (__proj__ECons__item___0 : + expr -> (typ * Prims.string * expr Prims.list)) = + fun projectee -> match projectee with | ECons _0 -> _0 +let (uu___is_EBufFill : expr -> Prims.bool) = + fun projectee -> + match projectee with | EBufFill _0 -> true | uu___ -> false +let (__proj__EBufFill__item___0 : expr -> (expr * expr * expr)) = + fun projectee -> match projectee with | EBufFill _0 -> _0 +let (uu___is_EString : expr -> Prims.bool) = + fun projectee -> match projectee with | EString _0 -> true | uu___ -> false +let (__proj__EString__item___0 : expr -> Prims.string) = + fun projectee -> match projectee with | EString _0 -> _0 +let (uu___is_EFun : expr -> Prims.bool) = + fun projectee -> match projectee with | EFun _0 -> true | uu___ -> false +let (__proj__EFun__item___0 : expr -> (binder Prims.list * expr * typ)) = + fun projectee -> match projectee with | EFun _0 -> _0 +let (uu___is_EAbortS : expr -> Prims.bool) = + fun projectee -> match projectee with | EAbortS _0 -> true | uu___ -> false +let (__proj__EAbortS__item___0 : expr -> Prims.string) = + fun projectee -> match projectee with | EAbortS _0 -> _0 +let (uu___is_EBufFree : expr -> Prims.bool) = + fun projectee -> + match projectee with | EBufFree _0 -> true | uu___ -> false +let (__proj__EBufFree__item___0 : expr -> expr) = + fun projectee -> match projectee with | EBufFree _0 -> _0 +let (uu___is_EBufCreateNoInit : expr -> Prims.bool) = + fun projectee -> + match projectee with | EBufCreateNoInit _0 -> true | uu___ -> false +let (__proj__EBufCreateNoInit__item___0 : expr -> (lifetime * expr)) = + fun projectee -> match projectee with | EBufCreateNoInit _0 -> _0 +let (uu___is_EAbortT : expr -> Prims.bool) = + fun projectee -> match projectee with | EAbortT _0 -> true | uu___ -> false +let (__proj__EAbortT__item___0 : expr -> (Prims.string * typ)) = + fun projectee -> match projectee with | EAbortT _0 -> _0 +let (uu___is_EComment : expr -> Prims.bool) = + fun projectee -> + match projectee with | EComment _0 -> true | uu___ -> false +let (__proj__EComment__item___0 : + expr -> (Prims.string * expr * Prims.string)) = + fun projectee -> match projectee with | EComment _0 -> _0 +let (uu___is_EStandaloneComment : expr -> Prims.bool) = + fun projectee -> + match projectee with | EStandaloneComment _0 -> true | uu___ -> false +let (__proj__EStandaloneComment__item___0 : expr -> Prims.string) = + fun projectee -> match projectee with | EStandaloneComment _0 -> _0 +let (uu___is_EAddrOf : expr -> Prims.bool) = + fun projectee -> match projectee with | EAddrOf _0 -> true | uu___ -> false +let (__proj__EAddrOf__item___0 : expr -> expr) = + fun projectee -> match projectee with | EAddrOf _0 -> _0 +let (uu___is_EBufNull : expr -> Prims.bool) = + fun projectee -> + match projectee with | EBufNull _0 -> true | uu___ -> false +let (__proj__EBufNull__item___0 : expr -> typ) = + fun projectee -> match projectee with | EBufNull _0 -> _0 +let (uu___is_EBufDiff : expr -> Prims.bool) = + fun projectee -> + match projectee with | EBufDiff _0 -> true | uu___ -> false +let (__proj__EBufDiff__item___0 : expr -> (expr * expr)) = + fun projectee -> match projectee with | EBufDiff _0 -> _0 +let (uu___is_Add : op -> Prims.bool) = + fun projectee -> match projectee with | Add -> true | uu___ -> false +let (uu___is_AddW : op -> Prims.bool) = + fun projectee -> match projectee with | AddW -> true | uu___ -> false +let (uu___is_Sub : op -> Prims.bool) = + fun projectee -> match projectee with | Sub -> true | uu___ -> false +let (uu___is_SubW : op -> Prims.bool) = + fun projectee -> match projectee with | SubW -> true | uu___ -> false +let (uu___is_Div : op -> Prims.bool) = + fun projectee -> match projectee with | Div -> true | uu___ -> false +let (uu___is_DivW : op -> Prims.bool) = + fun projectee -> match projectee with | DivW -> true | uu___ -> false +let (uu___is_Mult : op -> Prims.bool) = + fun projectee -> match projectee with | Mult -> true | uu___ -> false +let (uu___is_MultW : op -> Prims.bool) = + fun projectee -> match projectee with | MultW -> true | uu___ -> false +let (uu___is_Mod : op -> Prims.bool) = + fun projectee -> match projectee with | Mod -> true | uu___ -> false +let (uu___is_BOr : op -> Prims.bool) = + fun projectee -> match projectee with | BOr -> true | uu___ -> false +let (uu___is_BAnd : op -> Prims.bool) = + fun projectee -> match projectee with | BAnd -> true | uu___ -> false +let (uu___is_BXor : op -> Prims.bool) = + fun projectee -> match projectee with | BXor -> true | uu___ -> false +let (uu___is_BShiftL : op -> Prims.bool) = + fun projectee -> match projectee with | BShiftL -> true | uu___ -> false +let (uu___is_BShiftR : op -> Prims.bool) = + fun projectee -> match projectee with | BShiftR -> true | uu___ -> false +let (uu___is_BNot : op -> Prims.bool) = + fun projectee -> match projectee with | BNot -> true | uu___ -> false +let (uu___is_Eq : op -> Prims.bool) = + fun projectee -> match projectee with | Eq -> true | uu___ -> false +let (uu___is_Neq : op -> Prims.bool) = + fun projectee -> match projectee with | Neq -> true | uu___ -> false +let (uu___is_Lt : op -> Prims.bool) = + fun projectee -> match projectee with | Lt -> true | uu___ -> false +let (uu___is_Lte : op -> Prims.bool) = + fun projectee -> match projectee with | Lte -> true | uu___ -> false +let (uu___is_Gt : op -> Prims.bool) = + fun projectee -> match projectee with | Gt -> true | uu___ -> false +let (uu___is_Gte : op -> Prims.bool) = + fun projectee -> match projectee with | Gte -> true | uu___ -> false +let (uu___is_And : op -> Prims.bool) = + fun projectee -> match projectee with | And -> true | uu___ -> false +let (uu___is_Or : op -> Prims.bool) = + fun projectee -> match projectee with | Or -> true | uu___ -> false +let (uu___is_Xor : op -> Prims.bool) = + fun projectee -> match projectee with | Xor -> true | uu___ -> false +let (uu___is_Not : op -> Prims.bool) = + fun projectee -> match projectee with | Not -> true | uu___ -> false +let (uu___is_PUnit : pattern -> Prims.bool) = + fun projectee -> match projectee with | PUnit -> true | uu___ -> false +let (uu___is_PBool : pattern -> Prims.bool) = + fun projectee -> match projectee with | PBool _0 -> true | uu___ -> false +let (__proj__PBool__item___0 : pattern -> Prims.bool) = + fun projectee -> match projectee with | PBool _0 -> _0 +let (uu___is_PVar : pattern -> Prims.bool) = + fun projectee -> match projectee with | PVar _0 -> true | uu___ -> false +let (__proj__PVar__item___0 : pattern -> binder) = + fun projectee -> match projectee with | PVar _0 -> _0 +let (uu___is_PCons : pattern -> Prims.bool) = + fun projectee -> match projectee with | PCons _0 -> true | uu___ -> false +let (__proj__PCons__item___0 : + pattern -> (Prims.string * pattern Prims.list)) = + fun projectee -> match projectee with | PCons _0 -> _0 +let (uu___is_PTuple : pattern -> Prims.bool) = + fun projectee -> match projectee with | PTuple _0 -> true | uu___ -> false +let (__proj__PTuple__item___0 : pattern -> pattern Prims.list) = + fun projectee -> match projectee with | PTuple _0 -> _0 +let (uu___is_PRecord : pattern -> Prims.bool) = + fun projectee -> match projectee with | PRecord _0 -> true | uu___ -> false +let (__proj__PRecord__item___0 : + pattern -> (Prims.string * pattern) Prims.list) = + fun projectee -> match projectee with | PRecord _0 -> _0 +let (uu___is_PConstant : pattern -> Prims.bool) = + fun projectee -> + match projectee with | PConstant _0 -> true | uu___ -> false +let (__proj__PConstant__item___0 : pattern -> (width * Prims.string)) = + fun projectee -> match projectee with | PConstant _0 -> _0 +let (uu___is_UInt8 : width -> Prims.bool) = + fun projectee -> match projectee with | UInt8 -> true | uu___ -> false +let (uu___is_UInt16 : width -> Prims.bool) = + fun projectee -> match projectee with | UInt16 -> true | uu___ -> false +let (uu___is_UInt32 : width -> Prims.bool) = + fun projectee -> match projectee with | UInt32 -> true | uu___ -> false +let (uu___is_UInt64 : width -> Prims.bool) = + fun projectee -> match projectee with | UInt64 -> true | uu___ -> false +let (uu___is_Int8 : width -> Prims.bool) = + fun projectee -> match projectee with | Int8 -> true | uu___ -> false +let (uu___is_Int16 : width -> Prims.bool) = + fun projectee -> match projectee with | Int16 -> true | uu___ -> false +let (uu___is_Int32 : width -> Prims.bool) = + fun projectee -> match projectee with | Int32 -> true | uu___ -> false +let (uu___is_Int64 : width -> Prims.bool) = + fun projectee -> match projectee with | Int64 -> true | uu___ -> false +let (uu___is_Bool : width -> Prims.bool) = + fun projectee -> match projectee with | Bool -> true | uu___ -> false +let (uu___is_CInt : width -> Prims.bool) = + fun projectee -> match projectee with | CInt -> true | uu___ -> false +let (uu___is_SizeT : width -> Prims.bool) = + fun projectee -> match projectee with | SizeT -> true | uu___ -> false +let (uu___is_PtrdiffT : width -> Prims.bool) = + fun projectee -> match projectee with | PtrdiffT -> true | uu___ -> false +let (__proj__Mkbinder__item__name : binder -> Prims.string) = + fun projectee -> + match projectee with | { name; typ = typ1; mut; meta;_} -> name +let (__proj__Mkbinder__item__typ : binder -> typ) = + fun projectee -> + match projectee with | { name; typ = typ1; mut; meta;_} -> typ1 +let (__proj__Mkbinder__item__mut : binder -> Prims.bool) = + fun projectee -> + match projectee with | { name; typ = typ1; mut; meta;_} -> mut +let (__proj__Mkbinder__item__meta : binder -> flag Prims.list) = + fun projectee -> + match projectee with | { name; typ = typ1; mut; meta;_} -> meta +let (uu___is_TInt : typ -> Prims.bool) = + fun projectee -> match projectee with | TInt _0 -> true | uu___ -> false +let (__proj__TInt__item___0 : typ -> width) = + fun projectee -> match projectee with | TInt _0 -> _0 +let (uu___is_TBuf : typ -> Prims.bool) = + fun projectee -> match projectee with | TBuf _0 -> true | uu___ -> false +let (__proj__TBuf__item___0 : typ -> typ) = + fun projectee -> match projectee with | TBuf _0 -> _0 +let (uu___is_TUnit : typ -> Prims.bool) = + fun projectee -> match projectee with | TUnit -> true | uu___ -> false +let (uu___is_TQualified : typ -> Prims.bool) = + fun projectee -> + match projectee with | TQualified _0 -> true | uu___ -> false +let (__proj__TQualified__item___0 : + typ -> (Prims.string Prims.list * Prims.string)) = + fun projectee -> match projectee with | TQualified _0 -> _0 +let (uu___is_TBool : typ -> Prims.bool) = + fun projectee -> match projectee with | TBool -> true | uu___ -> false +let (uu___is_TAny : typ -> Prims.bool) = + fun projectee -> match projectee with | TAny -> true | uu___ -> false +let (uu___is_TArrow : typ -> Prims.bool) = + fun projectee -> match projectee with | TArrow _0 -> true | uu___ -> false +let (__proj__TArrow__item___0 : typ -> (typ * typ)) = + fun projectee -> match projectee with | TArrow _0 -> _0 +let (uu___is_TBound : typ -> Prims.bool) = + fun projectee -> match projectee with | TBound _0 -> true | uu___ -> false +let (__proj__TBound__item___0 : typ -> Prims.int) = + fun projectee -> match projectee with | TBound _0 -> _0 +let (uu___is_TApp : typ -> Prims.bool) = + fun projectee -> match projectee with | TApp _0 -> true | uu___ -> false +let (__proj__TApp__item___0 : + typ -> ((Prims.string Prims.list * Prims.string) * typ Prims.list)) = + fun projectee -> match projectee with | TApp _0 -> _0 +let (uu___is_TTuple : typ -> Prims.bool) = + fun projectee -> match projectee with | TTuple _0 -> true | uu___ -> false +let (__proj__TTuple__item___0 : typ -> typ Prims.list) = + fun projectee -> match projectee with | TTuple _0 -> _0 +let (uu___is_TConstBuf : typ -> Prims.bool) = + fun projectee -> + match projectee with | TConstBuf _0 -> true | uu___ -> false +let (__proj__TConstBuf__item___0 : typ -> typ) = + fun projectee -> match projectee with | TConstBuf _0 -> _0 +let (uu___is_TArray : typ -> Prims.bool) = + fun projectee -> match projectee with | TArray _0 -> true | uu___ -> false +let (__proj__TArray__item___0 : typ -> (typ * (width * Prims.string))) = + fun projectee -> match projectee with | TArray _0 -> _0 +type ident = Prims.string +type fields_t = (Prims.string * (typ * Prims.bool)) Prims.list +type branches_t = + (Prims.string * (Prims.string * (typ * Prims.bool)) Prims.list) Prims.list +type fsdoc = Prims.string +type branch = (pattern * expr) +type branches = (pattern * expr) Prims.list +type constant = (width * Prims.string) +type var = Prims.int +type lident = (Prims.string Prims.list * Prims.string) +let (pretty_width : width FStarC_Class_PP.pretty) = + { + FStarC_Class_PP.pp = + (fun uu___ -> + match uu___ with + | UInt8 -> FStarC_Pprint.doc_of_string "UInt8" + | UInt16 -> FStarC_Pprint.doc_of_string "UInt16" + | UInt32 -> FStarC_Pprint.doc_of_string "UInt32" + | UInt64 -> FStarC_Pprint.doc_of_string "UInt64" + | Int8 -> FStarC_Pprint.doc_of_string "Int8" + | Int16 -> FStarC_Pprint.doc_of_string "Int16" + | Int32 -> FStarC_Pprint.doc_of_string "Int32" + | Int64 -> FStarC_Pprint.doc_of_string "Int64" + | Bool -> FStarC_Pprint.doc_of_string "Bool" + | CInt -> FStarC_Pprint.doc_of_string "CInt" + | SizeT -> FStarC_Pprint.doc_of_string "SizeT" + | PtrdiffT -> FStarC_Pprint.doc_of_string "PtrdiffT") + } +let (record_string : + (Prims.string * Prims.string) Prims.list -> Prims.string) = + fun fs -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with + | (f, s) -> Prims.strcat f (Prims.strcat " = " s)) fs in + FStarC_Compiler_String.concat "; " uu___2 in + Prims.strcat uu___1 "}" in + Prims.strcat "{" uu___ +let (ctor : + Prims.string -> FStarC_Pprint.document Prims.list -> FStarC_Pprint.document) + = + fun n -> + fun args -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Pprint.break_ Prims.int_one in + let uu___4 = + let uu___5 = FStarC_Pprint.doc_of_string n in uu___5 :: args in + FStarC_Pprint.flow uu___3 uu___4 in + FStarC_Pprint.parens uu___2 in + FStarC_Pprint.group uu___1 in + FStarC_Pprint.nest (Prims.of_int (2)) uu___ +let pp_list' : + 'a . + ('a -> FStarC_Pprint.document) -> 'a Prims.list -> FStarC_Pprint.document + = + fun f -> + fun xs -> + (FStarC_Class_PP.pp_list { FStarC_Class_PP.pp = f }).FStarC_Class_PP.pp + xs +let rec (typ_to_doc : typ -> FStarC_Pprint.document) = + fun t -> + match t with + | TInt w -> + let uu___ = + let uu___1 = FStarC_Class_PP.pp pretty_width w in [uu___1] in + ctor "TInt" uu___ + | TBuf t1 -> + let uu___ = let uu___1 = typ_to_doc t1 in [uu___1] in + ctor "TBuf" uu___ + | TUnit -> FStarC_Pprint.doc_of_string "TUnit" + | TQualified x -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_tuple2 + (FStarC_Class_Show.show_list + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_string)) + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_string)) x in + FStarC_Pprint.doc_of_string uu___2 in + [uu___1] in + ctor "TQualified" uu___ + | TBool -> FStarC_Pprint.doc_of_string "TBool" + | TAny -> FStarC_Pprint.doc_of_string "TAny" + | TArrow (t1, t2) -> + let uu___ = + let uu___1 = typ_to_doc t1 in + let uu___2 = let uu___3 = typ_to_doc t2 in [uu___3] in uu___1 :: + uu___2 in + ctor "TArrow" uu___ + | TBound x -> + let uu___ = + let uu___1 = FStarC_Class_PP.pp FStarC_Class_PP.pp_int x in + [uu___1] in + ctor "TBound" uu___ + | TApp (x, xs) -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_tuple2 + (FStarC_Class_Show.show_list + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_string)) + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_string)) x in + FStarC_Pprint.doc_of_string uu___2 in + let uu___2 = let uu___3 = pp_list' typ_to_doc xs in [uu___3] in + uu___1 :: uu___2 in + ctor "TApp" uu___ + | TTuple ts -> + let uu___ = let uu___1 = pp_list' typ_to_doc ts in [uu___1] in + ctor "TTuple" uu___ + | TConstBuf t1 -> + let uu___ = let uu___1 = typ_to_doc t1 in [uu___1] in + ctor "TConstBuf" uu___ + | TArray (t1, c) -> + let uu___ = + let uu___1 = typ_to_doc t1 in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Class_PP.pp pretty_width + (FStar_Pervasives_Native.fst c) in + let uu___7 = + let uu___8 = + FStarC_Pprint.doc_of_string + (FStar_Pervasives_Native.snd c) in + [uu___8] in + uu___6 :: uu___7 in + FStarC_Pprint.separate FStarC_Pprint.comma uu___5 in + FStarC_Pprint.parens uu___4 in + [uu___3] in + uu___1 :: uu___2 in + ctor "TArray" uu___ +let (pretty_typ : typ FStarC_Class_PP.pretty) = + { FStarC_Class_PP.pp = typ_to_doc } +let (pretty_string : Prims.string FStarC_Class_PP.pretty) = + { + FStarC_Class_PP.pp = + (fun s -> + let uu___ = FStarC_Pprint.doc_of_string s in + FStarC_Pprint.dquotes uu___) + } +let (pretty_flag : flag FStarC_Class_PP.pretty) = + { + FStarC_Class_PP.pp = + (fun uu___ -> + match uu___ with + | Private -> FStarC_Pprint.doc_of_string "Private" + | WipeBody -> FStarC_Pprint.doc_of_string "WipeBody" + | CInline -> FStarC_Pprint.doc_of_string "CInline" + | Substitute -> FStarC_Pprint.doc_of_string "Substitute" + | GCType -> FStarC_Pprint.doc_of_string "GCType" + | Comment s -> + let uu___1 = + let uu___2 = FStarC_Class_PP.pp pretty_string s in [uu___2] in + ctor "Comment" uu___1 + | MustDisappear -> FStarC_Pprint.doc_of_string "MustDisappear" + | Const s -> + let uu___1 = + let uu___2 = FStarC_Class_PP.pp pretty_string s in [uu___2] in + ctor "Const" uu___1 + | Prologue s -> + let uu___1 = + let uu___2 = FStarC_Class_PP.pp pretty_string s in [uu___2] in + ctor "Prologue" uu___1 + | Epilogue s -> + let uu___1 = + let uu___2 = FStarC_Class_PP.pp pretty_string s in [uu___2] in + ctor "Epilogue" uu___1 + | Abstract -> FStarC_Pprint.doc_of_string "Abstract" + | IfDef -> FStarC_Pprint.doc_of_string "IfDef" + | Macro -> FStarC_Pprint.doc_of_string "Macro" + | Deprecated s -> + let uu___1 = + let uu___2 = FStarC_Class_PP.pp pretty_string s in [uu___2] in + ctor "Deprecated" uu___1 + | CNoInline -> FStarC_Pprint.doc_of_string "CNoInline") + } +let (spaced : FStarC_Pprint.document -> FStarC_Pprint.document) = + fun a -> + let uu___ = FStarC_Pprint.break_ Prims.int_one in + let uu___1 = + let uu___2 = FStarC_Pprint.break_ Prims.int_one in + FStarC_Pprint.op_Hat_Hat a uu___2 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 +let (record : FStarC_Pprint.document Prims.list -> FStarC_Pprint.document) = + fun fs -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Pprint.break_ Prims.int_one in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.semi uu___5 in + FStarC_Pprint.separate uu___4 fs in + spaced uu___3 in + FStarC_Pprint.braces uu___2 in + FStarC_Pprint.nest (Prims.of_int (2)) uu___1 in + FStarC_Pprint.group uu___ +let (fld : Prims.string -> FStarC_Pprint.document -> FStarC_Pprint.document) + = + fun n -> + fun v -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Pprint.doc_of_string (Prims.strcat n " =") in + FStarC_Pprint.op_Hat_Slash_Hat uu___2 v in + FStarC_Pprint.nest (Prims.of_int (2)) uu___1 in + FStarC_Pprint.group uu___ +let (pretty_binder : binder FStarC_Class_PP.pretty) = + { + FStarC_Class_PP.pp = + (fun b -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Class_PP.pp pretty_string b.name in + fld "name" uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Class_PP.pp pretty_typ b.typ in + fld "typ" uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Class_PP.pp FStarC_Class_PP.pp_bool b.mut in + fld "mut" uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Class_PP.pp (FStarC_Class_PP.pp_list pretty_flag) + b.meta in + fld "meta" uu___8 in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + record uu___) + } +let (pretty_lifetime : lifetime FStarC_Class_PP.pretty) = + { + FStarC_Class_PP.pp = + (fun uu___ -> + match uu___ with + | Eternal -> FStarC_Pprint.doc_of_string "Eternal" + | Stack -> FStarC_Pprint.doc_of_string "Stack" + | ManuallyManaged -> FStarC_Pprint.doc_of_string "ManuallyManaged") + } +let (pretty_op : op FStarC_Class_PP.pretty) = + { + FStarC_Class_PP.pp = + (fun uu___ -> + match uu___ with + | Add -> FStarC_Pprint.doc_of_string "Add" + | AddW -> FStarC_Pprint.doc_of_string "AddW" + | Sub -> FStarC_Pprint.doc_of_string "Sub" + | SubW -> FStarC_Pprint.doc_of_string "SubW" + | Div -> FStarC_Pprint.doc_of_string "Div" + | DivW -> FStarC_Pprint.doc_of_string "DivW" + | Mult -> FStarC_Pprint.doc_of_string "Mult" + | MultW -> FStarC_Pprint.doc_of_string "MultW" + | Mod -> FStarC_Pprint.doc_of_string "Mod" + | BOr -> FStarC_Pprint.doc_of_string "BOr" + | BAnd -> FStarC_Pprint.doc_of_string "BAnd" + | BXor -> FStarC_Pprint.doc_of_string "BXor" + | BShiftL -> FStarC_Pprint.doc_of_string "BShiftL" + | BShiftR -> FStarC_Pprint.doc_of_string "BShiftR" + | BNot -> FStarC_Pprint.doc_of_string "BNot" + | Eq -> FStarC_Pprint.doc_of_string "Eq" + | Neq -> FStarC_Pprint.doc_of_string "Neq" + | Lt -> FStarC_Pprint.doc_of_string "Lt" + | Lte -> FStarC_Pprint.doc_of_string "Lte" + | Gt -> FStarC_Pprint.doc_of_string "Gt" + | Gte -> FStarC_Pprint.doc_of_string "Gte" + | And -> FStarC_Pprint.doc_of_string "And" + | Or -> FStarC_Pprint.doc_of_string "Or" + | Xor -> FStarC_Pprint.doc_of_string "Xor" + | Not -> FStarC_Pprint.doc_of_string "Not") + } +let (pretty_cc : cc FStarC_Class_PP.pretty) = + { + FStarC_Class_PP.pp = + (fun uu___ -> + match uu___ with + | StdCall -> FStarC_Pprint.doc_of_string "StdCall" + | CDecl -> FStarC_Pprint.doc_of_string "CDecl" + | FastCall -> FStarC_Pprint.doc_of_string "FastCall") + } +let rec (pattern_to_doc : pattern -> FStarC_Pprint.document) = + fun p -> + match p with + | PUnit -> FStarC_Pprint.doc_of_string "PUnit" + | PBool b -> + let uu___ = + let uu___1 = FStarC_Class_PP.pp FStarC_Class_PP.pp_bool b in + [uu___1] in + ctor "PBool" uu___ + | PVar b -> + let uu___ = + let uu___1 = FStarC_Class_PP.pp pretty_binder b in [uu___1] in + ctor "PVar" uu___ + | PCons (x, ps) -> + let uu___ = + let uu___1 = FStarC_Class_PP.pp pretty_string x in + let uu___2 = let uu___3 = pp_list' pattern_to_doc ps in [uu___3] in + uu___1 :: uu___2 in + ctor "PCons" uu___ + | PTuple ps -> + let uu___ = let uu___1 = pp_list' pattern_to_doc ps in [uu___1] in + ctor "PTuple" uu___ + | PRecord fs -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with + | (s, p1) -> + let uu___4 = pattern_to_doc p1 in fld s uu___4) fs in + record uu___2 in + [uu___1] in + ctor "PRecord" uu___ + | PConstant c -> + let uu___ = + let uu___1 = + FStarC_Class_PP.pp + (FStarC_Class_PP.pp_tuple2 pretty_width pretty_string) c in + [uu___1] in + ctor "PConstant" uu___ +let (pretty_pattern : pattern FStarC_Class_PP.pretty) = + { FStarC_Class_PP.pp = pattern_to_doc } +let rec (decl_to_doc : decl -> FStarC_Pprint.document) = + fun d -> + match d with + | DGlobal (fs, x, i, t, e) -> + let uu___ = + let uu___1 = + FStarC_Class_PP.pp (FStarC_Class_PP.pp_list pretty_flag) fs in + let uu___2 = + let uu___3 = + FStarC_Class_PP.pp + (FStarC_Class_PP.pp_tuple2 + (FStarC_Class_PP.pp_list pretty_string) pretty_string) x in + let uu___4 = + let uu___5 = FStarC_Class_PP.pp FStarC_Class_PP.pp_int i in + let uu___6 = + let uu___7 = FStarC_Class_PP.pp pretty_typ t in + let uu___8 = let uu___9 = expr_to_doc e in [uu___9] in uu___7 + :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + ctor "DGlobal" uu___ + | DFunction (cc1, fs, i, t, x, bs, e) -> + let uu___ = + let uu___1 = + FStarC_Class_PP.pp (FStarC_Class_PP.pp_option pretty_cc) cc1 in + let uu___2 = + let uu___3 = + FStarC_Class_PP.pp (FStarC_Class_PP.pp_list pretty_flag) fs in + let uu___4 = + let uu___5 = FStarC_Class_PP.pp FStarC_Class_PP.pp_int i in + let uu___6 = + let uu___7 = FStarC_Class_PP.pp pretty_typ t in + let uu___8 = + let uu___9 = + FStarC_Class_PP.pp + (FStarC_Class_PP.pp_tuple2 + (FStarC_Class_PP.pp_list pretty_string) + pretty_string) x in + let uu___10 = + let uu___11 = + FStarC_Class_PP.pp + (FStarC_Class_PP.pp_list pretty_binder) bs in + let uu___12 = let uu___13 = expr_to_doc e in [uu___13] in + uu___11 :: uu___12 in + uu___9 :: uu___10 in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + ctor "DFunction" uu___ + | DTypeAlias (x, fs, i, t) -> + let uu___ = + let uu___1 = + FStarC_Class_PP.pp + (FStarC_Class_PP.pp_tuple2 + (FStarC_Class_PP.pp_list pretty_string) pretty_string) x in + let uu___2 = + let uu___3 = + FStarC_Class_PP.pp (FStarC_Class_PP.pp_list pretty_flag) fs in + let uu___4 = + let uu___5 = FStarC_Class_PP.pp FStarC_Class_PP.pp_int i in + let uu___6 = + let uu___7 = FStarC_Class_PP.pp pretty_typ t in [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + ctor "DTypeAlias" uu___ + | DTypeFlat (x, fs, i, f) -> + let uu___ = + let uu___1 = + FStarC_Class_PP.pp + (FStarC_Class_PP.pp_tuple2 + (FStarC_Class_PP.pp_list pretty_string) pretty_string) x in + let uu___2 = + let uu___3 = + FStarC_Class_PP.pp (FStarC_Class_PP.pp_list pretty_flag) fs in + let uu___4 = + let uu___5 = FStarC_Class_PP.pp FStarC_Class_PP.pp_int i in + let uu___6 = + let uu___7 = + FStarC_Class_PP.pp + (FStarC_Class_PP.pp_list + (FStarC_Class_PP.pp_tuple2 pretty_string + (FStarC_Class_PP.pp_tuple2 pretty_typ + FStarC_Class_PP.pp_bool))) f in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + ctor "DTypeFlat" uu___ + | DUnusedRetainedForBackwardsCompat (cc1, fs, x, t) -> + let uu___ = + let uu___1 = + FStarC_Class_PP.pp (FStarC_Class_PP.pp_option pretty_cc) cc1 in + let uu___2 = + let uu___3 = + FStarC_Class_PP.pp (FStarC_Class_PP.pp_list pretty_flag) fs in + let uu___4 = + let uu___5 = + FStarC_Class_PP.pp + (FStarC_Class_PP.pp_tuple2 + (FStarC_Class_PP.pp_list pretty_string) pretty_string) x in + let uu___6 = + let uu___7 = FStarC_Class_PP.pp pretty_typ t in [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + ctor "DUnusedRetainedForBackwardsCompat" uu___ + | DTypeVariant (x, fs, i, bs) -> + let uu___ = + let uu___1 = + FStarC_Class_PP.pp + (FStarC_Class_PP.pp_tuple2 + (FStarC_Class_PP.pp_list pretty_string) pretty_string) x in + let uu___2 = + let uu___3 = + FStarC_Class_PP.pp (FStarC_Class_PP.pp_list pretty_flag) fs in + let uu___4 = + let uu___5 = FStarC_Class_PP.pp FStarC_Class_PP.pp_int i in + let uu___6 = + let uu___7 = + FStarC_Class_PP.pp + (FStarC_Class_PP.pp_list + (FStarC_Class_PP.pp_tuple2 pretty_string + (FStarC_Class_PP.pp_list + (FStarC_Class_PP.pp_tuple2 pretty_string + (FStarC_Class_PP.pp_tuple2 pretty_typ + FStarC_Class_PP.pp_bool))))) bs in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + ctor "DTypeVariant" uu___ + | DTypeAbstractStruct x -> + let uu___ = + let uu___1 = + FStarC_Class_PP.pp + (FStarC_Class_PP.pp_tuple2 + (FStarC_Class_PP.pp_list pretty_string) pretty_string) x in + [uu___1] in + ctor "DTypeAbstractStruct" uu___ + | DExternal (cc1, fs, x, t, xs) -> + let uu___ = + let uu___1 = + FStarC_Class_PP.pp (FStarC_Class_PP.pp_option pretty_cc) cc1 in + let uu___2 = + let uu___3 = + FStarC_Class_PP.pp (FStarC_Class_PP.pp_list pretty_flag) fs in + let uu___4 = + let uu___5 = + FStarC_Class_PP.pp + (FStarC_Class_PP.pp_tuple2 + (FStarC_Class_PP.pp_list pretty_string) pretty_string) x in + let uu___6 = + let uu___7 = FStarC_Class_PP.pp pretty_typ t in + let uu___8 = + let uu___9 = + FStarC_Class_PP.pp + (FStarC_Class_PP.pp_list pretty_string) xs in + [uu___9] in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + ctor "DExternal" uu___ + | DUntaggedUnion (x, fs, i, xs) -> + let uu___ = + let uu___1 = + FStarC_Class_PP.pp + (FStarC_Class_PP.pp_tuple2 + (FStarC_Class_PP.pp_list pretty_string) pretty_string) x in + let uu___2 = + let uu___3 = + FStarC_Class_PP.pp (FStarC_Class_PP.pp_list pretty_flag) fs in + let uu___4 = + let uu___5 = FStarC_Class_PP.pp FStarC_Class_PP.pp_int i in + let uu___6 = + let uu___7 = + FStarC_Class_PP.pp + (FStarC_Class_PP.pp_list + (FStarC_Class_PP.pp_tuple2 pretty_string pretty_typ)) + xs in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + ctor "DUntaggedUnion" uu___ +and (expr_to_doc : expr -> FStarC_Pprint.document) = + fun e -> + match e with + | EBound x -> + let uu___ = + let uu___1 = FStarC_Class_PP.pp FStarC_Class_PP.pp_int x in + [uu___1] in + ctor "EBound" uu___ + | EQualified x -> + let uu___ = + let uu___1 = + FStarC_Class_PP.pp + (FStarC_Class_PP.pp_tuple2 + (FStarC_Class_PP.pp_list pretty_string) pretty_string) x in + [uu___1] in + ctor "EQualified" uu___ + | EConstant x -> + let uu___ = + let uu___1 = + FStarC_Class_PP.pp + (FStarC_Class_PP.pp_tuple2 pretty_width pretty_string) x in + [uu___1] in + ctor "EConstant" uu___ + | EUnit -> FStarC_Pprint.doc_of_string "EUnit" + | EApp (x, xs) -> + let uu___ = + let uu___1 = expr_to_doc x in + let uu___2 = let uu___3 = pp_list' expr_to_doc xs in [uu___3] in + uu___1 :: uu___2 in + ctor "EApp" uu___ + | ETypApp (x, xs) -> + let uu___ = + let uu___1 = expr_to_doc x in + let uu___2 = + let uu___3 = + FStarC_Class_PP.pp (FStarC_Class_PP.pp_list pretty_typ) xs in + [uu___3] in + uu___1 :: uu___2 in + ctor "ETypApp" uu___ + | ELet (x, y, z) -> + let uu___ = + let uu___1 = FStarC_Class_PP.pp pretty_binder x in + let uu___2 = + let uu___3 = expr_to_doc y in + let uu___4 = let uu___5 = expr_to_doc z in [uu___5] in uu___3 :: + uu___4 in + uu___1 :: uu___2 in + ctor "ELet" uu___ + | EIfThenElse (x, y, z) -> + let uu___ = + let uu___1 = expr_to_doc x in + let uu___2 = + let uu___3 = expr_to_doc y in + let uu___4 = let uu___5 = expr_to_doc z in [uu___5] in uu___3 :: + uu___4 in + uu___1 :: uu___2 in + ctor "EIfThenElse" uu___ + | ESequence xs -> + let uu___ = let uu___1 = pp_list' expr_to_doc xs in [uu___1] in + ctor "ESequence" uu___ + | EAssign (x, y) -> + let uu___ = + let uu___1 = expr_to_doc x in + let uu___2 = let uu___3 = expr_to_doc y in [uu___3] in uu___1 :: + uu___2 in + ctor "EAssign" uu___ + | EBufCreate (x, y, z) -> + let uu___ = + let uu___1 = FStarC_Class_PP.pp pretty_lifetime x in + let uu___2 = + let uu___3 = expr_to_doc y in + let uu___4 = let uu___5 = expr_to_doc z in [uu___5] in uu___3 :: + uu___4 in + uu___1 :: uu___2 in + ctor "EBufCreate" uu___ + | EBufRead (x, y) -> + let uu___ = + let uu___1 = expr_to_doc x in + let uu___2 = let uu___3 = expr_to_doc y in [uu___3] in uu___1 :: + uu___2 in + ctor "EBufRead" uu___ + | EBufWrite (x, y, z) -> + let uu___ = + let uu___1 = expr_to_doc x in + let uu___2 = + let uu___3 = expr_to_doc y in + let uu___4 = let uu___5 = expr_to_doc z in [uu___5] in uu___3 :: + uu___4 in + uu___1 :: uu___2 in + ctor "EBufWrite" uu___ + | EBufSub (x, y) -> + let uu___ = + let uu___1 = expr_to_doc x in + let uu___2 = let uu___3 = expr_to_doc y in [uu___3] in uu___1 :: + uu___2 in + ctor "EBufSub" uu___ + | EBufBlit (x, y, z, a, b) -> + let uu___ = + let uu___1 = expr_to_doc x in + let uu___2 = + let uu___3 = expr_to_doc y in + let uu___4 = + let uu___5 = expr_to_doc z in + let uu___6 = + let uu___7 = expr_to_doc a in + let uu___8 = let uu___9 = expr_to_doc b in [uu___9] in uu___7 + :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + ctor "EBufBlit" uu___ + | EMatch (x, bs) -> + let uu___ = + let uu___1 = expr_to_doc x in + let uu___2 = let uu___3 = pp_list' pp_branch bs in [uu___3] in + uu___1 :: uu___2 in + ctor "EMatch" uu___ + | EOp (x, y) -> + let uu___ = + let uu___1 = FStarC_Class_PP.pp pretty_op x in + let uu___2 = + let uu___3 = FStarC_Class_PP.pp pretty_width y in [uu___3] in + uu___1 :: uu___2 in + ctor "EOp" uu___ + | ECast (x, y) -> + let uu___ = + let uu___1 = expr_to_doc x in + let uu___2 = + let uu___3 = FStarC_Class_PP.pp pretty_typ y in [uu___3] in + uu___1 :: uu___2 in + ctor "ECast" uu___ + | EPushFrame -> FStarC_Pprint.doc_of_string "EPushFrame" + | EPopFrame -> FStarC_Pprint.doc_of_string "EPopFrame" + | EBool x -> + let uu___ = + let uu___1 = FStarC_Class_PP.pp FStarC_Class_PP.pp_bool x in + [uu___1] in + ctor "EBool" uu___ + | EAny -> FStarC_Pprint.doc_of_string "EAny" + | EAbort -> FStarC_Pprint.doc_of_string "EAbort" + | EReturn x -> + let uu___ = let uu___1 = expr_to_doc x in [uu___1] in + ctor "EReturn" uu___ + | EFlat (x, xs) -> + let uu___ = + let uu___1 = FStarC_Class_PP.pp pretty_typ x in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Compiler_List.map + (fun uu___5 -> + match uu___5 with + | (s, e1) -> let uu___6 = expr_to_doc e1 in fld s uu___6) + xs in + record uu___4 in + [uu___3] in + uu___1 :: uu___2 in + ctor "EFlat" uu___ + | EField (x, y, z) -> + let uu___ = + let uu___1 = FStarC_Class_PP.pp pretty_typ x in + let uu___2 = + let uu___3 = expr_to_doc y in + let uu___4 = + let uu___5 = FStarC_Class_PP.pp pretty_string z in [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + ctor "EField" uu___ + | EWhile (x, y) -> + let uu___ = + let uu___1 = expr_to_doc x in + let uu___2 = let uu___3 = expr_to_doc y in [uu___3] in uu___1 :: + uu___2 in + ctor "EWhile" uu___ + | EBufCreateL (x, xs) -> + let uu___ = + let uu___1 = FStarC_Class_PP.pp pretty_lifetime x in + let uu___2 = let uu___3 = pp_list' expr_to_doc xs in [uu___3] in + uu___1 :: uu___2 in + ctor "EBufCreateL" uu___ + | ETuple xs -> + let uu___ = let uu___1 = pp_list' expr_to_doc xs in [uu___1] in + ctor "ETuple" uu___ + | ECons (x, y, xs) -> + let uu___ = + let uu___1 = FStarC_Class_PP.pp pretty_typ x in + let uu___2 = + let uu___3 = FStarC_Class_PP.pp pretty_string y in + let uu___4 = let uu___5 = pp_list' expr_to_doc xs in [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + ctor "ECons" uu___ + | EBufFill (x, y, z) -> + let uu___ = + let uu___1 = expr_to_doc x in + let uu___2 = + let uu___3 = expr_to_doc y in + let uu___4 = let uu___5 = expr_to_doc z in [uu___5] in uu___3 :: + uu___4 in + uu___1 :: uu___2 in + ctor "EBufFill" uu___ + | EString x -> + let uu___ = + let uu___1 = FStarC_Class_PP.pp pretty_string x in [uu___1] in + ctor "EString" uu___ + | EFun (xs, y, z) -> + let uu___ = + let uu___1 = pp_list' (FStarC_Class_PP.pp pretty_binder) xs in + let uu___2 = + let uu___3 = expr_to_doc y in + let uu___4 = + let uu___5 = FStarC_Class_PP.pp pretty_typ z in [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + ctor "EFun" uu___ + | EAbortS x -> + let uu___ = + let uu___1 = FStarC_Class_PP.pp pretty_string x in [uu___1] in + ctor "EAbortS" uu___ + | EBufFree x -> + let uu___ = let uu___1 = expr_to_doc x in [uu___1] in + ctor "EBufFree" uu___ + | EBufCreateNoInit (x, y) -> + let uu___ = + let uu___1 = FStarC_Class_PP.pp pretty_lifetime x in + let uu___2 = let uu___3 = expr_to_doc y in [uu___3] in uu___1 :: + uu___2 in + ctor "EBufCreateNoInit" uu___ + | EAbortT (x, y) -> + let uu___ = + let uu___1 = FStarC_Class_PP.pp pretty_string x in + let uu___2 = + let uu___3 = FStarC_Class_PP.pp pretty_typ y in [uu___3] in + uu___1 :: uu___2 in + ctor "EAbortT" uu___ + | EComment (x, y, z) -> + let uu___ = + let uu___1 = FStarC_Class_PP.pp pretty_string x in + let uu___2 = + let uu___3 = expr_to_doc y in + let uu___4 = + let uu___5 = FStarC_Class_PP.pp pretty_string z in [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + ctor "EComment" uu___ + | EStandaloneComment x -> + let uu___ = + let uu___1 = FStarC_Class_PP.pp pretty_string x in [uu___1] in + ctor "EStandaloneComment" uu___ + | EAddrOf x -> + let uu___ = let uu___1 = expr_to_doc x in [uu___1] in + ctor "EAddrOf" uu___ + | EBufNull x -> + let uu___ = let uu___1 = FStarC_Class_PP.pp pretty_typ x in [uu___1] in + ctor "EBufNull" uu___ + | EBufDiff (x, y) -> + let uu___ = + let uu___1 = expr_to_doc x in + let uu___2 = let uu___3 = expr_to_doc y in [uu___3] in uu___1 :: + uu___2 in + ctor "EBufDiff" uu___ +and (pp_branch : branch -> FStarC_Pprint.document) = + fun b -> + let uu___ = b in + match uu___ with + | (p, e) -> + let uu___1 = + let uu___2 = FStarC_Class_PP.pp pretty_pattern p in + let uu___3 = + let uu___4 = expr_to_doc e in + FStarC_Pprint.op_Hat_Slash_Hat FStarC_Pprint.comma uu___4 in + FStarC_Pprint.op_Hat_Hat uu___2 uu___3 in + FStarC_Pprint.parens uu___1 +let (pretty_decl : decl FStarC_Class_PP.pretty) = + { FStarC_Class_PP.pp = decl_to_doc } +let (showable_decl : decl FStarC_Class_Show.showable) = + FStarC_Class_PP.showable_from_pretty pretty_decl +type program = decl Prims.list +type file = (Prims.string * program) +type binary_format = (version * file Prims.list) +let fst3 : 'uuuuu 'uuuuu1 'uuuuu2 . ('uuuuu * 'uuuuu1 * 'uuuuu2) -> 'uuuuu = + fun uu___ -> match uu___ with | (x, uu___1, uu___2) -> x +let snd3 : 'uuuuu 'uuuuu1 'uuuuu2 . ('uuuuu * 'uuuuu1 * 'uuuuu2) -> 'uuuuu1 = + fun uu___ -> match uu___ with | (uu___1, x, uu___2) -> x +let thd3 : 'uuuuu 'uuuuu1 'uuuuu2 . ('uuuuu * 'uuuuu1 * 'uuuuu2) -> 'uuuuu2 = + fun uu___ -> match uu___ with | (uu___1, uu___2, x) -> x +let (mk_width : Prims.string -> width FStar_Pervasives_Native.option) = + fun uu___ -> + match uu___ with + | "UInt8" -> FStar_Pervasives_Native.Some UInt8 + | "UInt16" -> FStar_Pervasives_Native.Some UInt16 + | "UInt32" -> FStar_Pervasives_Native.Some UInt32 + | "UInt64" -> FStar_Pervasives_Native.Some UInt64 + | "Int8" -> FStar_Pervasives_Native.Some Int8 + | "Int16" -> FStar_Pervasives_Native.Some Int16 + | "Int32" -> FStar_Pervasives_Native.Some Int32 + | "Int64" -> FStar_Pervasives_Native.Some Int64 + | "SizeT" -> FStar_Pervasives_Native.Some SizeT + | "PtrdiffT" -> FStar_Pervasives_Native.Some PtrdiffT + | uu___1 -> FStar_Pervasives_Native.None +let (mk_bool_op : Prims.string -> op FStar_Pervasives_Native.option) = + fun uu___ -> + match uu___ with + | "op_Negation" -> FStar_Pervasives_Native.Some Not + | "op_AmpAmp" -> FStar_Pervasives_Native.Some And + | "op_BarBar" -> FStar_Pervasives_Native.Some Or + | "op_Equality" -> FStar_Pervasives_Native.Some Eq + | "op_disEquality" -> FStar_Pervasives_Native.Some Neq + | uu___1 -> FStar_Pervasives_Native.None +let (is_bool_op : Prims.string -> Prims.bool) = + fun op1 -> (mk_bool_op op1) <> FStar_Pervasives_Native.None +let (mk_op : Prims.string -> op FStar_Pervasives_Native.option) = + fun uu___ -> + match uu___ with + | "add" -> FStar_Pervasives_Native.Some Add + | "op_Plus_Hat" -> FStar_Pervasives_Native.Some Add + | "add_underspec" -> FStar_Pervasives_Native.Some Add + | "add_mod" -> FStar_Pervasives_Native.Some AddW + | "op_Plus_Percent_Hat" -> FStar_Pervasives_Native.Some AddW + | "sub" -> FStar_Pervasives_Native.Some Sub + | "op_Subtraction_Hat" -> FStar_Pervasives_Native.Some Sub + | "sub_underspec" -> FStar_Pervasives_Native.Some Sub + | "sub_mod" -> FStar_Pervasives_Native.Some SubW + | "op_Subtraction_Percent_Hat" -> FStar_Pervasives_Native.Some SubW + | "mul" -> FStar_Pervasives_Native.Some Mult + | "op_Star_Hat" -> FStar_Pervasives_Native.Some Mult + | "mul_underspec" -> FStar_Pervasives_Native.Some Mult + | "mul_mod" -> FStar_Pervasives_Native.Some MultW + | "op_Star_Percent_Hat" -> FStar_Pervasives_Native.Some MultW + | "div" -> FStar_Pervasives_Native.Some Div + | "op_Slash_Hat" -> FStar_Pervasives_Native.Some Div + | "div_mod" -> FStar_Pervasives_Native.Some DivW + | "op_Slash_Percent_Hat" -> FStar_Pervasives_Native.Some DivW + | "rem" -> FStar_Pervasives_Native.Some Mod + | "op_Percent_Hat" -> FStar_Pervasives_Native.Some Mod + | "logor" -> FStar_Pervasives_Native.Some BOr + | "op_Bar_Hat" -> FStar_Pervasives_Native.Some BOr + | "logxor" -> FStar_Pervasives_Native.Some BXor + | "op_Hat_Hat" -> FStar_Pervasives_Native.Some BXor + | "logand" -> FStar_Pervasives_Native.Some BAnd + | "op_Amp_Hat" -> FStar_Pervasives_Native.Some BAnd + | "lognot" -> FStar_Pervasives_Native.Some BNot + | "shift_right" -> FStar_Pervasives_Native.Some BShiftR + | "op_Greater_Greater_Hat" -> FStar_Pervasives_Native.Some BShiftR + | "shift_left" -> FStar_Pervasives_Native.Some BShiftL + | "op_Less_Less_Hat" -> FStar_Pervasives_Native.Some BShiftL + | "eq" -> FStar_Pervasives_Native.Some Eq + | "op_Equals_Hat" -> FStar_Pervasives_Native.Some Eq + | "op_Greater_Hat" -> FStar_Pervasives_Native.Some Gt + | "gt" -> FStar_Pervasives_Native.Some Gt + | "op_Greater_Equals_Hat" -> FStar_Pervasives_Native.Some Gte + | "gte" -> FStar_Pervasives_Native.Some Gte + | "op_Less_Hat" -> FStar_Pervasives_Native.Some Lt + | "lt" -> FStar_Pervasives_Native.Some Lt + | "op_Less_Equals_Hat" -> FStar_Pervasives_Native.Some Lte + | "lte" -> FStar_Pervasives_Native.Some Lte + | uu___1 -> FStar_Pervasives_Native.None +let (is_op : Prims.string -> Prims.bool) = + fun op1 -> (mk_op op1) <> FStar_Pervasives_Native.None +let (is_machine_int : Prims.string -> Prims.bool) = + fun m -> (mk_width m) <> FStar_Pervasives_Native.None +type env = + { + uenv: FStarC_Extraction_ML_UEnv.uenv ; + names: name Prims.list ; + names_t: Prims.string Prims.list ; + module_name: Prims.string Prims.list } +and name = { + pretty: Prims.string } +let (__proj__Mkenv__item__uenv : env -> FStarC_Extraction_ML_UEnv.uenv) = + fun projectee -> + match projectee with | { uenv; names; names_t; module_name;_} -> uenv +let (__proj__Mkenv__item__names : env -> name Prims.list) = + fun projectee -> + match projectee with | { uenv; names; names_t; module_name;_} -> names +let (__proj__Mkenv__item__names_t : env -> Prims.string Prims.list) = + fun projectee -> + match projectee with | { uenv; names; names_t; module_name;_} -> names_t +let (__proj__Mkenv__item__module_name : env -> Prims.string Prims.list) = + fun projectee -> + match projectee with + | { uenv; names; names_t; module_name;_} -> module_name +let (__proj__Mkname__item__pretty : name -> Prims.string) = + fun projectee -> match projectee with | { pretty;_} -> pretty +let (empty : + FStarC_Extraction_ML_UEnv.uenv -> Prims.string Prims.list -> env) = + fun uenv -> + fun module_name -> { uenv; names = []; names_t = []; module_name } +let (extend : env -> Prims.string -> env) = + fun env1 -> + fun x -> + { + uenv = (env1.uenv); + names = ({ pretty = x } :: (env1.names)); + names_t = (env1.names_t); + module_name = (env1.module_name) + } +let (extend_t : env -> Prims.string -> env) = + fun env1 -> + fun x -> + { + uenv = (env1.uenv); + names = (env1.names); + names_t = (x :: (env1.names_t)); + module_name = (env1.module_name) + } +let (find_name : env -> Prims.string -> name) = + fun env1 -> + fun x -> + let uu___ = + FStarC_Compiler_List.tryFind (fun name1 -> name1.pretty = x) + env1.names in + match uu___ with + | FStar_Pervasives_Native.Some name1 -> name1 + | FStar_Pervasives_Native.None -> + failwith "internal error: name not found" +let (find : env -> Prims.string -> Prims.int) = + fun env1 -> + fun x -> + try + (fun uu___ -> + match () with + | () -> + FStarC_Compiler_List.index (fun name1 -> name1.pretty = x) + env1.names) () + with + | uu___ -> + let uu___1 = + FStarC_Compiler_Util.format1 + "Internal error: name not found %s\n" x in + failwith uu___1 +let (find_t : env -> Prims.string -> Prims.int) = + fun env1 -> + fun x -> + try + (fun uu___ -> + match () with + | () -> + FStarC_Compiler_List.index (fun name1 -> name1 = x) + env1.names_t) () + with + | uu___ -> + let uu___1 = + FStarC_Compiler_Util.format1 + "Internal error: name not found %s\n" x in + failwith uu___1 +let (add_binders : + env -> FStarC_Extraction_ML_Syntax.mlbinder Prims.list -> env) = + fun env1 -> + fun bs -> + FStarC_Compiler_List.fold_left + (fun env2 -> + fun uu___ -> + match uu___ with + | { FStarC_Extraction_ML_Syntax.mlbinder_name = mlbinder_name; + FStarC_Extraction_ML_Syntax.mlbinder_ty = uu___1; + FStarC_Extraction_ML_Syntax.mlbinder_attrs = uu___2;_} -> + extend env2 mlbinder_name) env1 bs +let (list_elements : + FStarC_Extraction_ML_Syntax.mlexpr -> + FStarC_Extraction_ML_Syntax.mlexpr Prims.list) + = + fun e -> + let lopt = FStarC_Extraction_ML_Util.list_elements e in + match lopt with + | FStar_Pervasives_Native.None -> + failwith "Argument of FStar.Buffer.createL is not a list literal!" + | FStar_Pervasives_Native.Some l -> l +let (translate_flags : + FStarC_Extraction_ML_Syntax.meta Prims.list -> flag Prims.list) = + fun flags -> + FStarC_Compiler_List.choose + (fun uu___ -> + match uu___ with + | FStarC_Extraction_ML_Syntax.Private -> + FStar_Pervasives_Native.Some Private + | FStarC_Extraction_ML_Syntax.NoExtract -> + FStar_Pervasives_Native.Some WipeBody + | FStarC_Extraction_ML_Syntax.CInline -> + FStar_Pervasives_Native.Some CInline + | FStarC_Extraction_ML_Syntax.CNoInline -> + FStar_Pervasives_Native.Some CNoInline + | FStarC_Extraction_ML_Syntax.Substitute -> + FStar_Pervasives_Native.Some Substitute + | FStarC_Extraction_ML_Syntax.GCType -> + FStar_Pervasives_Native.Some GCType + | FStarC_Extraction_ML_Syntax.Comment s -> + FStar_Pervasives_Native.Some (Comment s) + | FStarC_Extraction_ML_Syntax.StackInline -> + FStar_Pervasives_Native.Some MustDisappear + | FStarC_Extraction_ML_Syntax.CConst s -> + FStar_Pervasives_Native.Some (Const s) + | FStarC_Extraction_ML_Syntax.CPrologue s -> + FStar_Pervasives_Native.Some (Prologue s) + | FStarC_Extraction_ML_Syntax.CEpilogue s -> + FStar_Pervasives_Native.Some (Epilogue s) + | FStarC_Extraction_ML_Syntax.CAbstract -> + FStar_Pervasives_Native.Some Abstract + | FStarC_Extraction_ML_Syntax.CIfDef -> + FStar_Pervasives_Native.Some IfDef + | FStarC_Extraction_ML_Syntax.CMacro -> + FStar_Pervasives_Native.Some Macro + | FStarC_Extraction_ML_Syntax.Deprecated s -> + FStar_Pervasives_Native.Some (Deprecated s) + | uu___1 -> FStar_Pervasives_Native.None) flags +let (translate_cc : + FStarC_Extraction_ML_Syntax.meta Prims.list -> + cc FStar_Pervasives_Native.option) + = + fun flags -> + let uu___ = + FStarC_Compiler_List.choose + (fun uu___1 -> + match uu___1 with + | FStarC_Extraction_ML_Syntax.CCConv s -> + FStar_Pervasives_Native.Some s + | uu___2 -> FStar_Pervasives_Native.None) flags in + match uu___ with + | "stdcall"::[] -> FStar_Pervasives_Native.Some StdCall + | "fastcall"::[] -> FStar_Pervasives_Native.Some FastCall + | "cdecl"::[] -> FStar_Pervasives_Native.Some CDecl + | uu___1 -> FStar_Pervasives_Native.None +let (generate_is_null : typ -> expr -> expr) = + fun t -> + fun x -> + let dummy = UInt64 in + EApp ((ETypApp ((EOp (Eq, dummy)), [TBuf t])), [x; EBufNull t]) +exception NotSupportedByKrmlExtension +let (uu___is_NotSupportedByKrmlExtension : Prims.exn -> Prims.bool) = + fun projectee -> + match projectee with + | NotSupportedByKrmlExtension -> true + | uu___ -> false +type translate_type_without_decay_t = + env -> FStarC_Extraction_ML_Syntax.mlty -> typ +let (ref_translate_type_without_decay : + translate_type_without_decay_t FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref + (fun uu___ -> + fun uu___1 -> FStarC_Compiler_Effect.raise NotSupportedByKrmlExtension) +let (register_pre_translate_type_without_decay : + translate_type_without_decay_t -> unit) = + fun f -> + let before = + FStarC_Compiler_Effect.op_Bang ref_translate_type_without_decay in + let after e t = + try (fun uu___ -> match () with | () -> f e t) () + with | NotSupportedByKrmlExtension -> before e t in + FStarC_Compiler_Effect.op_Colon_Equals ref_translate_type_without_decay + after +let (register_post_translate_type_without_decay : + translate_type_without_decay_t -> unit) = + fun f -> + let before = + FStarC_Compiler_Effect.op_Bang ref_translate_type_without_decay in + let after e t = + try (fun uu___ -> match () with | () -> before e t) () + with | NotSupportedByKrmlExtension -> f e t in + FStarC_Compiler_Effect.op_Colon_Equals ref_translate_type_without_decay + after +let (translate_type_without_decay : + env -> FStarC_Extraction_ML_Syntax.mlty -> typ) = + fun env1 -> + fun t -> + let uu___ = + FStarC_Compiler_Effect.op_Bang ref_translate_type_without_decay in + uu___ env1 t +type translate_type_t = env -> FStarC_Extraction_ML_Syntax.mlty -> typ +let (ref_translate_type : translate_type_t FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref + (fun uu___ -> + fun uu___1 -> FStarC_Compiler_Effect.raise NotSupportedByKrmlExtension) +let (register_pre_translate_type : translate_type_t -> unit) = + fun f -> + let before = FStarC_Compiler_Effect.op_Bang ref_translate_type in + let after e t = + try (fun uu___ -> match () with | () -> f e t) () + with | NotSupportedByKrmlExtension -> before e t in + FStarC_Compiler_Effect.op_Colon_Equals ref_translate_type after +let (register_post_translate_type : translate_type_t -> unit) = + fun f -> + let before = FStarC_Compiler_Effect.op_Bang ref_translate_type in + let after e t = + try (fun uu___ -> match () with | () -> before e t) () + with | NotSupportedByKrmlExtension -> f e t in + FStarC_Compiler_Effect.op_Colon_Equals ref_translate_type after +let (translate_type : env -> FStarC_Extraction_ML_Syntax.mlty -> typ) = + fun env1 -> + fun t -> + let uu___ = FStarC_Compiler_Effect.op_Bang ref_translate_type in + uu___ env1 t +type translate_expr_t = env -> FStarC_Extraction_ML_Syntax.mlexpr -> expr +let (ref_translate_expr : translate_expr_t FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref + (fun uu___ -> + fun uu___1 -> FStarC_Compiler_Effect.raise NotSupportedByKrmlExtension) +let (register_pre_translate_expr : translate_expr_t -> unit) = + fun f -> + let before = FStarC_Compiler_Effect.op_Bang ref_translate_expr in + let after e t = + try (fun uu___ -> match () with | () -> f e t) () + with | NotSupportedByKrmlExtension -> before e t in + FStarC_Compiler_Effect.op_Colon_Equals ref_translate_expr after +let (register_post_translate_expr : translate_expr_t -> unit) = + fun f -> + let before = FStarC_Compiler_Effect.op_Bang ref_translate_expr in + let after e t = + try (fun uu___ -> match () with | () -> before e t) () + with | NotSupportedByKrmlExtension -> f e t in + FStarC_Compiler_Effect.op_Colon_Equals ref_translate_expr after +let (translate_expr : env -> FStarC_Extraction_ML_Syntax.mlexpr -> expr) = + fun env1 -> + fun e -> + let uu___ = FStarC_Compiler_Effect.op_Bang ref_translate_expr in + uu___ env1 e +type translate_type_decl_t = + env -> + FStarC_Extraction_ML_Syntax.one_mltydecl -> + decl FStar_Pervasives_Native.option +let (ref_translate_type_decl : + translate_type_decl_t FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref + (fun uu___ -> + fun uu___1 -> FStarC_Compiler_Effect.raise NotSupportedByKrmlExtension) +let (register_pre_translate_type_decl : translate_type_decl_t -> unit) = + fun f -> + let before = FStarC_Compiler_Effect.op_Bang ref_translate_type_decl in + let after e t = + try (fun uu___ -> match () with | () -> f e t) () + with | NotSupportedByKrmlExtension -> before e t in + FStarC_Compiler_Effect.op_Colon_Equals ref_translate_type_decl after +let (register_post_translate_type_decl : translate_type_decl_t -> unit) = + fun f -> + let before = FStarC_Compiler_Effect.op_Bang ref_translate_type_decl in + let after e t = + try (fun uu___ -> match () with | () -> before e t) () + with | NotSupportedByKrmlExtension -> f e t in + FStarC_Compiler_Effect.op_Colon_Equals ref_translate_type_decl after +let (translate_type_decl : + env -> + FStarC_Extraction_ML_Syntax.one_mltydecl -> + decl FStar_Pervasives_Native.option) + = + fun env1 -> + fun ty -> + if + FStarC_Compiler_List.mem FStarC_Extraction_ML_Syntax.NoExtract + ty.FStarC_Extraction_ML_Syntax.tydecl_meta + then FStar_Pervasives_Native.None + else + (let uu___1 = FStarC_Compiler_Effect.op_Bang ref_translate_type_decl in + uu___1 env1 ty) +let rec (translate_type_without_decay' : + env -> FStarC_Extraction_ML_Syntax.mlty -> typ) = + fun env1 -> + fun t -> + match t with + | FStarC_Extraction_ML_Syntax.MLTY_Tuple [] -> TAny + | FStarC_Extraction_ML_Syntax.MLTY_Top -> TAny + | FStarC_Extraction_ML_Syntax.MLTY_Var name1 -> + let uu___ = find_t env1 name1 in TBound uu___ + | FStarC_Extraction_ML_Syntax.MLTY_Fun (t1, uu___, t2) -> + let uu___1 = + let uu___2 = translate_type_without_decay env1 t1 in + let uu___3 = translate_type_without_decay env1 t2 in + (uu___2, uu___3) in + TArrow uu___1 + | FStarC_Extraction_ML_Syntax.MLTY_Erased -> TUnit + | FStarC_Extraction_ML_Syntax.MLTY_Named ([], p) when + let uu___ = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___ = "Prims.unit" -> TUnit + | FStarC_Extraction_ML_Syntax.MLTY_Named ([], p) when + let uu___ = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___ = "Prims.bool" -> TBool + | FStarC_Extraction_ML_Syntax.MLTY_Named ([], ("FStar"::m::[], "t")) + when is_machine_int m -> + let uu___ = FStarC_Compiler_Util.must (mk_width m) in TInt uu___ + | FStarC_Extraction_ML_Syntax.MLTY_Named ([], ("FStar"::m::[], "t'")) + when is_machine_int m -> + let uu___ = FStarC_Compiler_Util.must (mk_width m) in TInt uu___ + | FStarC_Extraction_ML_Syntax.MLTY_Named ([], p) when + let uu___ = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___ = "FStar.Monotonic.HyperStack.mem" -> TUnit + | FStarC_Extraction_ML_Syntax.MLTY_Named (uu___::arg::uu___1::[], p) + when + (((let uu___2 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___2 = "FStar.Monotonic.HyperStack.s_mref") || + (let uu___2 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___2 = "FStar.Monotonic.HyperHeap.mrref")) + || + (let uu___2 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___2 = "FStar.HyperStack.ST.m_rref")) + || + (let uu___2 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___2 = "FStar.HyperStack.ST.s_mref") + -> + let uu___2 = translate_type_without_decay env1 arg in TBuf uu___2 + | FStarC_Extraction_ML_Syntax.MLTY_Named (arg::uu___::[], p) when + ((((((((((let uu___1 = + FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___1 = "FStar.Monotonic.HyperStack.mreference") || + (let uu___1 = + FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___1 = "FStar.Monotonic.HyperStack.mstackref")) + || + (let uu___1 = + FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___1 = "FStar.Monotonic.HyperStack.mref")) + || + (let uu___1 = + FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___1 = "FStar.Monotonic.HyperStack.mmmstackref")) + || + (let uu___1 = + FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___1 = "FStar.Monotonic.HyperStack.mmmref")) + || + (let uu___1 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___1 = "FStar.Monotonic.Heap.mref")) + || + (let uu___1 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___1 = "FStar.HyperStack.ST.mreference")) + || + (let uu___1 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___1 = "FStar.HyperStack.ST.mstackref")) + || + (let uu___1 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___1 = "FStar.HyperStack.ST.mref")) + || + (let uu___1 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___1 = "FStar.HyperStack.ST.mmmstackref")) + || + (let uu___1 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___1 = "FStar.HyperStack.ST.mmmref") + -> + let uu___1 = translate_type_without_decay env1 arg in TBuf uu___1 + | FStarC_Extraction_ML_Syntax.MLTY_Named (arg::uu___::uu___1::[], p) + when + let uu___2 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___2 = "LowStar.Monotonic.Buffer.mbuffer" -> + let uu___2 = translate_type_without_decay env1 arg in TBuf uu___2 + | FStarC_Extraction_ML_Syntax.MLTY_Named (arg::[], p) when + (let uu___ = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___ = "LowStar.ConstBuffer.const_buffer") || false + -> + let uu___ = translate_type_without_decay env1 arg in + TConstBuf uu___ + | FStarC_Extraction_ML_Syntax.MLTY_Named (arg::[], p) when + ((((((((((((((let uu___ = + FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___ = "FStar.Buffer.buffer") || + (let uu___ = + FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___ = "LowStar.Buffer.buffer")) + || + (let uu___ = + FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___ = "LowStar.ImmutableBuffer.ibuffer")) + || + (let uu___ = + FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___ = "LowStar.UninitializedBuffer.ubuffer")) + || + (let uu___ = + FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___ = "FStar.HyperStack.reference")) + || + (let uu___ = + FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___ = "FStar.HyperStack.stackref")) + || + (let uu___ = + FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___ = "FStar.HyperStack.ref")) + || + (let uu___ = + FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___ = "FStar.HyperStack.mmstackref")) + || + (let uu___ = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___ = "FStar.HyperStack.mmref")) + || + (let uu___ = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___ = "FStar.HyperStack.ST.reference")) + || + (let uu___ = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___ = "FStar.HyperStack.ST.stackref")) + || + (let uu___ = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___ = "FStar.HyperStack.ST.ref")) + || + (let uu___ = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___ = "FStar.HyperStack.ST.mmstackref")) + || + (let uu___ = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___ = "FStar.HyperStack.ST.mmref")) + || false + -> let uu___ = translate_type_without_decay env1 arg in TBuf uu___ + | FStarC_Extraction_ML_Syntax.MLTY_Named (uu___::arg::[], p) when + (let uu___1 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___1 = "FStar.HyperStack.s_ref") || + (let uu___1 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___1 = "FStar.HyperStack.ST.s_ref") + -> + let uu___1 = translate_type_without_decay env1 arg in TBuf uu___1 + | FStarC_Extraction_ML_Syntax.MLTY_Named (arg::[], p) when + let uu___ = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___ = "FStar.Universe.raise_t" -> + translate_type_without_decay env1 arg + | FStarC_Extraction_ML_Syntax.MLTY_Named (uu___::[], p) when + let uu___1 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___1 = "FStar.Ghost.erased" -> TAny + | FStarC_Extraction_ML_Syntax.MLTY_Named ([], (path, type_name)) -> + TQualified (path, type_name) + | FStarC_Extraction_ML_Syntax.MLTY_Named (args, (ns, t1)) when + ((ns = ["Prims"]) || (ns = ["FStar"; "Pervasives"; "Native"])) && + (FStarC_Compiler_Util.starts_with t1 "tuple") + -> + let uu___ = + FStarC_Compiler_List.map (translate_type_without_decay env1) args in + TTuple uu___ + | FStarC_Extraction_ML_Syntax.MLTY_Named (args, lid) -> + if (FStarC_Compiler_List.length args) > Prims.int_zero + then + let uu___ = + let uu___1 = + FStarC_Compiler_List.map (translate_type_without_decay env1) + args in + (lid, uu___1) in + TApp uu___ + else TQualified lid + | FStarC_Extraction_ML_Syntax.MLTY_Tuple ts -> + let uu___ = + FStarC_Compiler_List.map (translate_type_without_decay env1) ts in + TTuple uu___ +and (translate_type' : env -> FStarC_Extraction_ML_Syntax.mlty -> typ) = + fun env1 -> fun t -> translate_type_without_decay env1 t +and (translate_binders : + env -> FStarC_Extraction_ML_Syntax.mlbinder Prims.list -> binder Prims.list) + = fun env1 -> fun bs -> FStarC_Compiler_List.map (translate_binder env1) bs +and (translate_binder : + env -> FStarC_Extraction_ML_Syntax.mlbinder -> binder) = + fun env1 -> + fun uu___ -> + match uu___ with + | { FStarC_Extraction_ML_Syntax.mlbinder_name = mlbinder_name; + FStarC_Extraction_ML_Syntax.mlbinder_ty = mlbinder_ty; + FStarC_Extraction_ML_Syntax.mlbinder_attrs = mlbinder_attrs;_} -> + let uu___1 = translate_type env1 mlbinder_ty in + { name = mlbinder_name; typ = uu___1; mut = false; meta = [] } +and (translate_expr' : env -> FStarC_Extraction_ML_Syntax.mlexpr -> expr) = + fun env1 -> + fun e -> + match e.FStarC_Extraction_ML_Syntax.expr with + | FStarC_Extraction_ML_Syntax.MLE_Tuple [] -> EUnit + | FStarC_Extraction_ML_Syntax.MLE_Const c -> translate_constant c + | FStarC_Extraction_ML_Syntax.MLE_Var name1 -> + let uu___ = find env1 name1 in EBound uu___ + | FStarC_Extraction_ML_Syntax.MLE_Name ("FStar"::m::[], op1) when + (is_machine_int m) && (is_op op1) -> + let uu___ = + let uu___1 = FStarC_Compiler_Util.must (mk_op op1) in + let uu___2 = FStarC_Compiler_Util.must (mk_width m) in + (uu___1, uu___2) in + EOp uu___ + | FStarC_Extraction_ML_Syntax.MLE_Name ("Prims"::[], op1) when + is_bool_op op1 -> + let uu___ = + let uu___1 = FStarC_Compiler_Util.must (mk_bool_op op1) in + (uu___1, Bool) in + EOp uu___ + | FStarC_Extraction_ML_Syntax.MLE_Name n -> EQualified n + | FStarC_Extraction_ML_Syntax.MLE_Let + ((flavor, + { FStarC_Extraction_ML_Syntax.mllb_name = name1; + FStarC_Extraction_ML_Syntax.mllb_tysc = + FStar_Pervasives_Native.Some ([], typ1); + FStarC_Extraction_ML_Syntax.mllb_add_unit = add_unit; + FStarC_Extraction_ML_Syntax.mllb_def = body; + FStarC_Extraction_ML_Syntax.mllb_attrs = uu___; + FStarC_Extraction_ML_Syntax.mllb_meta = flags; + FStarC_Extraction_ML_Syntax.print_typ = print;_}::[]), + continuation) + -> + let binder1 = + let uu___1 = translate_type env1 typ1 in + let uu___2 = translate_flags flags in + { name = name1; typ = uu___1; mut = false; meta = uu___2 } in + let body1 = translate_expr env1 body in + let env2 = extend env1 name1 in + let continuation1 = translate_expr env2 continuation in + ELet (binder1, body1, continuation1) + | FStarC_Extraction_ML_Syntax.MLE_Match (expr1, branches1) -> + let uu___ = + let uu___1 = translate_expr env1 expr1 in + let uu___2 = translate_branches env1 branches1 in + (uu___1, uu___2) in + EMatch uu___ + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + t::[]); + FStarC_Extraction_ML_Syntax.mlty = uu___2; + FStarC_Extraction_ML_Syntax.loc = uu___3;_}, + arg::[]) + when + let uu___4 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___4 = "FStarC.Dyn.undyn" -> + let uu___4 = + let uu___5 = translate_expr env1 arg in + let uu___6 = translate_type env1 t in (uu___5, uu___6) in + ECast uu___4 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + uu___5) + when + let uu___6 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___6 = "Prims.admit" -> EAbort + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + t::[]); + FStarC_Extraction_ML_Syntax.mlty = uu___2; + FStarC_Extraction_ML_Syntax.loc = uu___3;_}, + { + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Const + (FStarC_Extraction_ML_Syntax.MLC_String s); + FStarC_Extraction_ML_Syntax.mlty = uu___4; + FStarC_Extraction_ML_Syntax.loc = uu___5;_}::[]) + when + let uu___6 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___6 = "LowStar.Failure.failwith" -> + let uu___6 = let uu___7 = translate_type env1 t in (s, uu___7) in + EAbortT uu___6 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + arg::[]) + when + ((let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "FStar.HyperStack.All.failwith") || + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "FStar.Error.unexpected")) + || + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "FStar.Error.unreachable") + -> + (match arg with + | { + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Const + (FStarC_Extraction_ML_Syntax.MLC_String msg); + FStarC_Extraction_ML_Syntax.mlty = uu___5; + FStarC_Extraction_ML_Syntax.loc = uu___6;_} -> EAbortS msg + | uu___5 -> + let print_nm = (["FStar"; "HyperStack"; "IO"], "print_string") in + let print = + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.MLTY_Top + (FStarC_Extraction_ML_Syntax.MLE_Name print_nm) in + let print1 = + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.MLTY_Top + (FStarC_Extraction_ML_Syntax.MLE_App (print, [arg])) in + let t = translate_expr env1 print1 in ESequence [t; EAbort]) + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + e1::[]) + when + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.ToFStarBuffer.new_to_old_st") || + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.ToFStarBuffer.old_to_new_st") + -> translate_expr env1 e1 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + e1::e2::[]) + when + ((((let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "FStar.Buffer.index") || + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "FStar.Buffer.op_Array_Access")) + || + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.Monotonic.Buffer.index")) + || + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.UninitializedBuffer.uindex")) + || + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.ConstBuffer.index") + -> + let uu___5 = + let uu___6 = translate_expr env1 e1 in + let uu___7 = translate_expr env1 e2 in (uu___6, uu___7) in + EBufRead uu___5 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + e1::[]) + when + let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "FStar.HyperStack.ST.op_Bang" -> + let uu___5 = + let uu___6 = translate_expr env1 e1 in + (uu___6, (EQualified (["C"], "_zero_for_deref"))) in + EBufRead uu___5 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + arg::[]) + when + let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "FStar.Universe.raise_val" -> translate_expr env1 arg + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + arg::[]) + when + let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "FStar.Universe.downgrade_val" -> translate_expr env1 arg + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + e1::e2::[]) + when + ((let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "FStar.Buffer.create") || + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.Monotonic.Buffer.malloca")) + || + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.ImmutableBuffer.ialloca") + -> + let uu___5 = + let uu___6 = translate_expr env1 e1 in + let uu___7 = translate_expr env1 e2 in (Stack, uu___6, uu___7) in + EBufCreate uu___5 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + elen::[]) + when + let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.UninitializedBuffer.ualloca" -> + let uu___5 = + let uu___6 = translate_expr env1 elen in (Stack, uu___6) in + EBufCreateNoInit uu___5 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + init::[]) + when + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "FStar.HyperStack.ST.salloc") || false + -> + let uu___5 = + let uu___6 = translate_expr env1 init in + (Stack, uu___6, (EConstant (UInt32, "1"))) in + EBufCreate uu___5 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + e2::[]) + when + ((let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "FStar.Buffer.createL") || + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.Monotonic.Buffer.malloca_of_list")) + || + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.ImmutableBuffer.ialloca_of_list") + -> + let uu___5 = + let uu___6 = + let uu___7 = list_elements e2 in + FStarC_Compiler_List.map (translate_expr env1) uu___7 in + (Stack, uu___6) in + EBufCreateL uu___5 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + _erid::e2::[]) + when + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.Monotonic.Buffer.mgcmalloc_of_list") || + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.ImmutableBuffer.igcmalloc_of_list") + -> + let uu___5 = + let uu___6 = + let uu___7 = list_elements e2 in + FStarC_Compiler_List.map (translate_expr env1) uu___7 in + (Eternal, uu___6) in + EBufCreateL uu___5 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + _rid::init::[]) + when + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "FStar.HyperStack.ST.ralloc") || + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "FStar.HyperStack.ST.ralloc_drgn") + -> + let uu___5 = + let uu___6 = translate_expr env1 init in + (Eternal, uu___6, (EConstant (UInt32, "1"))) in + EBufCreate uu___5 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + _e0::e1::e2::[]) + when + ((let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "FStar.Buffer.rcreate") || + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.Monotonic.Buffer.mgcmalloc")) + || + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.ImmutableBuffer.igcmalloc") + -> + let uu___5 = + let uu___6 = translate_expr env1 e1 in + let uu___7 = translate_expr env1 e2 in (Eternal, uu___6, uu___7) in + EBufCreate uu___5 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + uu___5) + when + (((((let uu___6 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___6 = "LowStar.Monotonic.Buffer.mgcmalloc_and_blit") || + (let uu___6 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___6 = "LowStar.Monotonic.Buffer.mmalloc_and_blit")) + || + (let uu___6 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___6 = "LowStar.Monotonic.Buffer.malloca_and_blit")) + || + (let uu___6 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___6 = "LowStar.ImmutableBuffer.igcmalloc_and_blit")) + || + (let uu___6 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___6 = "LowStar.ImmutableBuffer.imalloc_and_blit")) + || + (let uu___6 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___6 = "LowStar.ImmutableBuffer.ialloca_and_blit") + -> + EAbortS + "alloc_and_blit family of functions are not yet supported downstream" + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + _erid::elen::[]) + when + let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.UninitializedBuffer.ugcmalloc" -> + let uu___5 = + let uu___6 = translate_expr env1 elen in (Eternal, uu___6) in + EBufCreateNoInit uu___5 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + _rid::init::[]) + when + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "FStar.HyperStack.ST.ralloc_mm") || + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "FStar.HyperStack.ST.ralloc_drgn_mm") + -> + let uu___5 = + let uu___6 = translate_expr env1 init in + (ManuallyManaged, uu___6, (EConstant (UInt32, "1"))) in + EBufCreate uu___5 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + _e0::e1::e2::[]) + when + (((let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "FStar.Buffer.rcreate_mm") || + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.Monotonic.Buffer.mmalloc")) + || + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.Monotonic.Buffer.mmalloc")) + || + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.ImmutableBuffer.imalloc") + -> + let uu___5 = + let uu___6 = translate_expr env1 e1 in + let uu___7 = translate_expr env1 e2 in + (ManuallyManaged, uu___6, uu___7) in + EBufCreate uu___5 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + _erid::elen::[]) + when + let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.UninitializedBuffer.umalloc" -> + let uu___5 = + let uu___6 = translate_expr env1 elen in + (ManuallyManaged, uu___6) in + EBufCreateNoInit uu___5 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + e2::[]) + when + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "FStar.HyperStack.ST.rfree") || false + -> let uu___5 = translate_expr env1 e2 in EBufFree uu___5 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + e2::[]) + when + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "FStar.Buffer.rfree") || + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.Monotonic.Buffer.free") + -> let uu___5 = translate_expr env1 e2 in EBufFree uu___5 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + e1::e2::_e3::[]) + when + let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "FStar.Buffer.sub" -> + let uu___5 = + let uu___6 = translate_expr env1 e1 in + let uu___7 = translate_expr env1 e2 in (uu___6, uu___7) in + EBufSub uu___5 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + e1::e2::_e3::[]) + when + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.Monotonic.Buffer.msub") || + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.ConstBuffer.sub") + -> + let uu___5 = + let uu___6 = translate_expr env1 e1 in + let uu___7 = translate_expr env1 e2 in (uu___6, uu___7) in + EBufSub uu___5 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + e1::e2::[]) + when + let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "FStar.Buffer.join" -> translate_expr env1 e1 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + e1::e2::[]) + when + let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "FStar.Buffer.offset" -> + let uu___5 = + let uu___6 = translate_expr env1 e1 in + let uu___7 = translate_expr env1 e2 in (uu___6, uu___7) in + EBufSub uu___5 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + e1::e2::[]) + when + let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.Monotonic.Buffer.moffset" -> + let uu___5 = + let uu___6 = translate_expr env1 e1 in + let uu___7 = translate_expr env1 e2 in (uu___6, uu___7) in + EBufSub uu___5 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + e1::e2::e3::[]) + when + (((let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "FStar.Buffer.upd") || + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "FStar.Buffer.op_Array_Assignment")) + || + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.Monotonic.Buffer.upd'")) + || + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.UninitializedBuffer.uupd") + -> + let uu___5 = + let uu___6 = translate_expr env1 e1 in + let uu___7 = translate_expr env1 e2 in + let uu___8 = translate_expr env1 e3 in (uu___6, uu___7, uu___8) in + EBufWrite uu___5 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + e1::e2::[]) + when + let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "FStar.HyperStack.ST.op_Colon_Equals" -> + let uu___5 = + let uu___6 = translate_expr env1 e1 in + let uu___7 = translate_expr env1 e2 in + (uu___6, (EQualified (["C"], "_zero_for_deref")), uu___7) in + EBufWrite uu___5 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2::[]) + when + (let uu___3 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___3 = "FStar.HyperStack.ST.push_frame") || false + -> EPushFrame + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2::[]) + when + let uu___3 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___3 = "FStar.HyperStack.ST.pop_frame" -> EPopFrame + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + e1::e2::e3::e4::e5::[]) + when + ((let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "FStar.Buffer.blit") || + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.Monotonic.Buffer.blit")) + || + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.UninitializedBuffer.ublit") + -> + let uu___5 = + let uu___6 = translate_expr env1 e1 in + let uu___7 = translate_expr env1 e2 in + let uu___8 = translate_expr env1 e3 in + let uu___9 = translate_expr env1 e4 in + let uu___10 = translate_expr env1 e5 in + (uu___6, uu___7, uu___8, uu___9, uu___10) in + EBufBlit uu___5 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + e1::e2::e3::[]) + when + let s = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + (s = "FStar.Buffer.fill") || (s = "LowStar.Monotonic.Buffer.fill") + -> + let uu___5 = + let uu___6 = translate_expr env1 e1 in + let uu___7 = translate_expr env1 e2 in + let uu___8 = translate_expr env1 e3 in (uu___6, uu___7, uu___8) in + EBufFill uu___5 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2::[]) + when + let uu___3 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___3 = "FStar.HyperStack.ST.get" -> EUnit + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + _rid::[]) + when + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "FStar.HyperStack.ST.free_drgn") || + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "FStar.HyperStack.ST.new_drgn") + -> EUnit + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + _ebuf::_eseq::[]) + when + (((let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.Monotonic.Buffer.witness_p") || + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.Monotonic.Buffer.recall_p")) + || + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.ImmutableBuffer.witness_contents")) + || + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.ImmutableBuffer.recall_contents") + -> EUnit + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + e1::[]) + when + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.ConstBuffer.of_buffer") || + (let uu___5 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___5 = "LowStar.ConstBuffer.of_ibuffer") + -> translate_expr env1 e1 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + t::[]); + FStarC_Extraction_ML_Syntax.mlty = uu___2; + FStarC_Extraction_ML_Syntax.loc = uu___3;_}, + _eqal::e1::[]) + when + let uu___4 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___4 = "LowStar.ConstBuffer.of_qbuf" -> + let uu___4 = + let uu___5 = translate_expr env1 e1 in + let uu___6 = + let uu___7 = translate_type env1 t in TConstBuf uu___7 in + (uu___5, uu___6) in + ECast uu___4 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + t::[]); + FStarC_Extraction_ML_Syntax.mlty = uu___2; + FStarC_Extraction_ML_Syntax.loc = uu___3;_}, + e1::[]) + when + ((let uu___4 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___4 = "LowStar.ConstBuffer.cast") || + (let uu___4 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___4 = "LowStar.ConstBuffer.to_buffer")) + || + (let uu___4 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___4 = "LowStar.ConstBuffer.to_ibuffer") + -> + let uu___4 = + let uu___5 = translate_expr env1 e1 in + let uu___6 = let uu___7 = translate_type env1 t in TBuf uu___7 in + (uu___5, uu___6) in + ECast uu___4 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + e1::[]) + when + let uu___2 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___2 = "Obj.repr" -> + let uu___2 = let uu___3 = translate_expr env1 e1 in (uu___3, TAny) in + ECast uu___2 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name ("FStar"::m::[], op1); + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + args) + when (is_machine_int m) && (is_op op1) -> + let uu___2 = FStarC_Compiler_Util.must (mk_width m) in + let uu___3 = FStarC_Compiler_Util.must (mk_op op1) in + mk_op_app env1 uu___2 uu___3 args + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name ("Prims"::[], op1); + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + args) + when is_bool_op op1 -> + let uu___2 = FStarC_Compiler_Util.must (mk_bool_op op1) in + mk_op_app env1 Bool uu___2 args + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name + ("FStar"::m::[], "int_to_t"); + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + { + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Const + (FStarC_Extraction_ML_Syntax.MLC_Int + (c, FStar_Pervasives_Native.None)); + FStarC_Extraction_ML_Syntax.mlty = uu___2; + FStarC_Extraction_ML_Syntax.loc = uu___3;_}::[]) + when is_machine_int m -> + let uu___4 = + let uu___5 = FStarC_Compiler_Util.must (mk_width m) in + (uu___5, c) in + EConstant uu___4 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name + ("FStar"::m::[], "uint_to_t"); + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + { + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Const + (FStarC_Extraction_ML_Syntax.MLC_Int + (c, FStar_Pervasives_Native.None)); + FStarC_Extraction_ML_Syntax.mlty = uu___2; + FStarC_Extraction_ML_Syntax.loc = uu___3;_}::[]) + when is_machine_int m -> + let uu___4 = + let uu___5 = FStarC_Compiler_Util.must (mk_width m) in + (uu___5, c) in + EConstant uu___4 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name + ("C"::[], "string_of_literal"); + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + { FStarC_Extraction_ML_Syntax.expr = e1; + FStarC_Extraction_ML_Syntax.mlty = uu___2; + FStarC_Extraction_ML_Syntax.loc = uu___3;_}::[]) + -> + (match e1 with + | FStarC_Extraction_ML_Syntax.MLE_Const + (FStarC_Extraction_ML_Syntax.MLC_String s) -> EString s + | uu___4 -> + failwith + "Cannot extract string_of_literal applied to a non-literal") + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name + ("C"::"Compat"::"String"::[], "of_literal"); + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + { FStarC_Extraction_ML_Syntax.expr = e1; + FStarC_Extraction_ML_Syntax.mlty = uu___2; + FStarC_Extraction_ML_Syntax.loc = uu___3;_}::[]) + -> + (match e1 with + | FStarC_Extraction_ML_Syntax.MLE_Const + (FStarC_Extraction_ML_Syntax.MLC_String s) -> EString s + | uu___4 -> + failwith + "Cannot extract string_of_literal applied to a non-literal") + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name + ("C"::"String"::[], "of_literal"); + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + { FStarC_Extraction_ML_Syntax.expr = e1; + FStarC_Extraction_ML_Syntax.mlty = uu___2; + FStarC_Extraction_ML_Syntax.loc = uu___3;_}::[]) + -> + (match e1 with + | FStarC_Extraction_ML_Syntax.MLE_Const + (FStarC_Extraction_ML_Syntax.MLC_String s) -> EString s + | uu___4 -> + failwith + "Cannot extract string_of_literal applied to a non-literal") + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + { FStarC_Extraction_ML_Syntax.expr = ebefore; + FStarC_Extraction_ML_Syntax.mlty = uu___5; + FStarC_Extraction_ML_Syntax.loc = uu___6;_}::e1::{ + FStarC_Extraction_ML_Syntax.expr + = eafter; + FStarC_Extraction_ML_Syntax.mlty + = uu___7; + FStarC_Extraction_ML_Syntax.loc + = uu___8;_}::[]) + when + let uu___9 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___9 = "LowStar.Comment.comment_gen" -> + (match (ebefore, eafter) with + | (FStarC_Extraction_ML_Syntax.MLE_Const + (FStarC_Extraction_ML_Syntax.MLC_String sbefore), + FStarC_Extraction_ML_Syntax.MLE_Const + (FStarC_Extraction_ML_Syntax.MLC_String safter)) -> + (if FStarC_Compiler_Util.contains sbefore "*/" + then failwith "Before Comment contains end-of-comment marker" + else (); + if FStarC_Compiler_Util.contains safter "*/" + then failwith "After Comment contains end-of-comment marker" + else (); + (let uu___11 = + let uu___12 = translate_expr env1 e1 in + (sbefore, uu___12, safter) in + EComment uu___11)) + | uu___9 -> + failwith "Cannot extract comment applied to a non-literal") + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + { FStarC_Extraction_ML_Syntax.expr = e1; + FStarC_Extraction_ML_Syntax.mlty = uu___2; + FStarC_Extraction_ML_Syntax.loc = uu___3;_}::[]) + when + let uu___4 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___4 = "LowStar.Comment.comment" -> + (match e1 with + | FStarC_Extraction_ML_Syntax.MLE_Const + (FStarC_Extraction_ML_Syntax.MLC_String s) -> + (if FStarC_Compiler_Util.contains s "*/" + then + failwith + "Standalone Comment contains end-of-comment marker" + else (); + EStandaloneComment s) + | uu___4 -> + failwith "Cannot extract comment applied to a non-literal") + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name + ("LowStar"::"Literal"::[], "buffer_of_literal"); + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + { FStarC_Extraction_ML_Syntax.expr = e1; + FStarC_Extraction_ML_Syntax.mlty = uu___2; + FStarC_Extraction_ML_Syntax.loc = uu___3;_}::[]) + -> + (match e1 with + | FStarC_Extraction_ML_Syntax.MLE_Const + (FStarC_Extraction_ML_Syntax.MLC_String s) -> + ECast ((EString s), (TBuf (TInt UInt8))) + | uu___4 -> + failwith + "Cannot extract buffer_of_literal applied to a non-literal") + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name + ("FStar"::"Int"::"Cast"::[], c); + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + arg::[]) + -> + let is_known_type = + (((((((FStarC_Compiler_Util.starts_with c "uint8") || + (FStarC_Compiler_Util.starts_with c "uint16")) + || (FStarC_Compiler_Util.starts_with c "uint32")) + || (FStarC_Compiler_Util.starts_with c "uint64")) + || (FStarC_Compiler_Util.starts_with c "int8")) + || (FStarC_Compiler_Util.starts_with c "int16")) + || (FStarC_Compiler_Util.starts_with c "int32")) + || (FStarC_Compiler_Util.starts_with c "int64") in + if (FStarC_Compiler_Util.ends_with c "uint64") && is_known_type + then + let uu___2 = + let uu___3 = translate_expr env1 arg in (uu___3, (TInt UInt64)) in + ECast uu___2 + else + if (FStarC_Compiler_Util.ends_with c "uint32") && is_known_type + then + (let uu___3 = + let uu___4 = translate_expr env1 arg in + (uu___4, (TInt UInt32)) in + ECast uu___3) + else + if (FStarC_Compiler_Util.ends_with c "uint16") && is_known_type + then + (let uu___4 = + let uu___5 = translate_expr env1 arg in + (uu___5, (TInt UInt16)) in + ECast uu___4) + else + if + (FStarC_Compiler_Util.ends_with c "uint8") && is_known_type + then + (let uu___5 = + let uu___6 = translate_expr env1 arg in + (uu___6, (TInt UInt8)) in + ECast uu___5) + else + if + (FStarC_Compiler_Util.ends_with c "int64") && + is_known_type + then + (let uu___6 = + let uu___7 = translate_expr env1 arg in + (uu___7, (TInt Int64)) in + ECast uu___6) + else + if + (FStarC_Compiler_Util.ends_with c "int32") && + is_known_type + then + (let uu___7 = + let uu___8 = translate_expr env1 arg in + (uu___8, (TInt Int32)) in + ECast uu___7) + else + if + (FStarC_Compiler_Util.ends_with c "int16") && + is_known_type + then + (let uu___8 = + let uu___9 = translate_expr env1 arg in + (uu___9, (TInt Int16)) in + ECast uu___8) + else + if + (FStarC_Compiler_Util.ends_with c "int8") && + is_known_type + then + (let uu___9 = + let uu___10 = translate_expr env1 arg in + (uu___10, (TInt Int8)) in + ECast uu___9) + else + (let uu___10 = + let uu___11 = + let uu___12 = translate_expr env1 arg in + [uu___12] in + ((EQualified (["FStar"; "Int"; "Cast"], c)), + uu___11) in + EApp uu___10) + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + arg::[]) + when + (((let uu___2 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___2 = "FStar.SizeT.uint16_to_sizet") || + (let uu___2 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___2 = "FStar.SizeT.uint32_to_sizet")) + || + (let uu___2 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___2 = "FStar.SizeT.uint64_to_sizet")) + || + (let uu___2 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___2 = "FStar.PtrdiffT.ptrdifft_to_sizet") + -> + let uu___2 = + let uu___3 = translate_expr env1 arg in (uu___3, (TInt SizeT)) in + ECast uu___2 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + arg::[]) + when + let uu___2 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___2 = "FStar.SizeT.sizet_to_uint32" -> + let uu___2 = + let uu___3 = translate_expr env1 arg in (uu___3, (TInt UInt32)) in + ECast uu___2 + | FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + arg::[]) + when + let uu___2 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___2 = "FStar.SizeT.sizet_to_uint64" -> + let uu___2 = + let uu___3 = translate_expr env1 arg in (uu___3, (TInt UInt64)) in + ECast uu___2 + | FStarC_Extraction_ML_Syntax.MLE_App (head, args) -> + let uu___ = + let uu___1 = translate_expr env1 head in + let uu___2 = FStarC_Compiler_List.map (translate_expr env1) args in + (uu___1, uu___2) in + EApp uu___ + | FStarC_Extraction_ML_Syntax.MLE_TApp (head, ty_args) -> + let uu___ = + let uu___1 = translate_expr env1 head in + let uu___2 = + FStarC_Compiler_List.map (translate_type env1) ty_args in + (uu___1, uu___2) in + ETypApp uu___ + | FStarC_Extraction_ML_Syntax.MLE_Coerce (e1, t_from, t_to) -> + let uu___ = + let uu___1 = translate_expr env1 e1 in + let uu___2 = translate_type env1 t_to in (uu___1, uu___2) in + ECast uu___ + | FStarC_Extraction_ML_Syntax.MLE_Record (uu___, uu___1, fields) -> + let uu___2 = + let uu___3 = assert_lid env1 e.FStarC_Extraction_ML_Syntax.mlty in + let uu___4 = + FStarC_Compiler_List.map + (fun uu___5 -> + match uu___5 with + | (field, expr1) -> + let uu___6 = translate_expr env1 expr1 in + (field, uu___6)) fields in + (uu___3, uu___4) in + EFlat uu___2 + | FStarC_Extraction_ML_Syntax.MLE_Proj (e1, path) -> + let uu___ = + let uu___1 = assert_lid env1 e1.FStarC_Extraction_ML_Syntax.mlty in + let uu___2 = translate_expr env1 e1 in + (uu___1, uu___2, (FStar_Pervasives_Native.snd path)) in + EField uu___ + | FStarC_Extraction_ML_Syntax.MLE_Let uu___ -> + let uu___1 = + let uu___2 = + FStarC_Extraction_ML_Code.string_of_mlexpr ([], "") e in + FStarC_Compiler_Util.format1 + "todo: translate_expr [MLE_Let] (expr is: %s)" uu___2 in + failwith uu___1 + | FStarC_Extraction_ML_Syntax.MLE_App (head, uu___) -> + let uu___1 = + let uu___2 = + FStarC_Extraction_ML_Code.string_of_mlexpr ([], "") head in + FStarC_Compiler_Util.format1 + "todo: translate_expr [MLE_App] (head is: %s)" uu___2 in + failwith uu___1 + | FStarC_Extraction_ML_Syntax.MLE_Seq seqs -> + let uu___ = FStarC_Compiler_List.map (translate_expr env1) seqs in + ESequence uu___ + | FStarC_Extraction_ML_Syntax.MLE_Tuple es -> + let uu___ = FStarC_Compiler_List.map (translate_expr env1) es in + ETuple uu___ + | FStarC_Extraction_ML_Syntax.MLE_CTor ((uu___, cons), es) -> + let uu___1 = + let uu___2 = assert_lid env1 e.FStarC_Extraction_ML_Syntax.mlty in + let uu___3 = FStarC_Compiler_List.map (translate_expr env1) es in + (uu___2, cons, uu___3) in + ECons uu___1 + | FStarC_Extraction_ML_Syntax.MLE_Fun (bs, body) -> + let binders = translate_binders env1 bs in + let env2 = add_binders env1 bs in + let uu___ = + let uu___1 = translate_expr env2 body in + let uu___2 = + translate_type env2 body.FStarC_Extraction_ML_Syntax.mlty in + (binders, uu___1, uu___2) in + EFun uu___ + | FStarC_Extraction_ML_Syntax.MLE_If (e1, e2, e3) -> + let uu___ = + let uu___1 = translate_expr env1 e1 in + let uu___2 = translate_expr env1 e2 in + let uu___3 = + match e3 with + | FStar_Pervasives_Native.None -> EUnit + | FStar_Pervasives_Native.Some e31 -> translate_expr env1 e31 in + (uu___1, uu___2, uu___3) in + EIfThenElse uu___ + | FStarC_Extraction_ML_Syntax.MLE_Raise uu___ -> + failwith "todo: translate_expr [MLE_Raise]" + | FStarC_Extraction_ML_Syntax.MLE_Try uu___ -> + failwith "todo: translate_expr [MLE_Try]" + | FStarC_Extraction_ML_Syntax.MLE_Coerce uu___ -> + failwith "todo: translate_expr [MLE_Coerce]" +and (assert_lid : env -> FStarC_Extraction_ML_Syntax.mlty -> typ) = + fun env1 -> + fun t -> + match t with + | FStarC_Extraction_ML_Syntax.MLTY_Named (ts, lid) -> + if (FStarC_Compiler_List.length ts) > Prims.int_zero + then + let uu___ = + let uu___1 = FStarC_Compiler_List.map (translate_type env1) ts in + (lid, uu___1) in + TApp uu___ + else TQualified lid + | uu___ -> + let uu___1 = + let uu___2 = FStarC_Extraction_ML_Code.string_of_mlty ([], "") t in + FStarC_Compiler_Util.format1 + "invalid argument: expected MLTY_Named, got %s" uu___2 in + failwith uu___1 +and (translate_branches : + env -> + (FStarC_Extraction_ML_Syntax.mlpattern * + FStarC_Extraction_ML_Syntax.mlexpr FStar_Pervasives_Native.option * + FStarC_Extraction_ML_Syntax.mlexpr) Prims.list -> + (pattern * expr) Prims.list) + = + fun env1 -> + fun branches1 -> + FStarC_Compiler_List.map (translate_branch env1) branches1 +and (translate_branch : + env -> + (FStarC_Extraction_ML_Syntax.mlpattern * + FStarC_Extraction_ML_Syntax.mlexpr FStar_Pervasives_Native.option * + FStarC_Extraction_ML_Syntax.mlexpr) -> (pattern * expr)) + = + fun env1 -> + fun uu___ -> + match uu___ with + | (pat, guard, expr1) -> + if guard = FStar_Pervasives_Native.None + then + let uu___1 = translate_pat env1 pat in + (match uu___1 with + | (env2, pat1) -> + let uu___2 = translate_expr env2 expr1 in (pat1, uu___2)) + else failwith "todo: translate_branch" +and (translate_width : + (FStarC_Const.signedness * FStarC_Const.width) + FStar_Pervasives_Native.option -> width) + = + fun uu___ -> + match uu___ with + | FStar_Pervasives_Native.None -> CInt + | FStar_Pervasives_Native.Some (FStarC_Const.Signed, FStarC_Const.Int8) + -> Int8 + | FStar_Pervasives_Native.Some (FStarC_Const.Signed, FStarC_Const.Int16) + -> Int16 + | FStar_Pervasives_Native.Some (FStarC_Const.Signed, FStarC_Const.Int32) + -> Int32 + | FStar_Pervasives_Native.Some (FStarC_Const.Signed, FStarC_Const.Int64) + -> Int64 + | FStar_Pervasives_Native.Some (FStarC_Const.Unsigned, FStarC_Const.Int8) + -> UInt8 + | FStar_Pervasives_Native.Some + (FStarC_Const.Unsigned, FStarC_Const.Int16) -> UInt16 + | FStar_Pervasives_Native.Some + (FStarC_Const.Unsigned, FStarC_Const.Int32) -> UInt32 + | FStar_Pervasives_Native.Some + (FStarC_Const.Unsigned, FStarC_Const.Int64) -> UInt64 + | FStar_Pervasives_Native.Some + (FStarC_Const.Unsigned, FStarC_Const.Sizet) -> SizeT +and (translate_pat : + env -> FStarC_Extraction_ML_Syntax.mlpattern -> (env * pattern)) = + fun env1 -> + fun p -> + match p with + | FStarC_Extraction_ML_Syntax.MLP_Const + (FStarC_Extraction_ML_Syntax.MLC_Unit) -> (env1, PUnit) + | FStarC_Extraction_ML_Syntax.MLP_Const + (FStarC_Extraction_ML_Syntax.MLC_Bool b) -> (env1, (PBool b)) + | FStarC_Extraction_ML_Syntax.MLP_Const + (FStarC_Extraction_ML_Syntax.MLC_Int (s, sw)) -> + let uu___ = + let uu___1 = let uu___2 = translate_width sw in (uu___2, s) in + PConstant uu___1 in + (env1, uu___) + | FStarC_Extraction_ML_Syntax.MLP_Var name1 -> + let env2 = extend env1 name1 in + (env2, (PVar { name = name1; typ = TAny; mut = false; meta = [] })) + | FStarC_Extraction_ML_Syntax.MLP_Wild -> + let env2 = extend env1 "_" in + (env2, (PVar { name = "_"; typ = TAny; mut = false; meta = [] })) + | FStarC_Extraction_ML_Syntax.MLP_CTor ((uu___, cons), ps) -> + let uu___1 = + FStarC_Compiler_List.fold_left + (fun uu___2 -> + fun p1 -> + match uu___2 with + | (env2, acc) -> + let uu___3 = translate_pat env2 p1 in + (match uu___3 with | (env3, p2) -> (env3, (p2 :: acc)))) + (env1, []) ps in + (match uu___1 with + | (env2, ps1) -> + (env2, (PCons (cons, (FStarC_Compiler_List.rev ps1))))) + | FStarC_Extraction_ML_Syntax.MLP_Record (uu___, ps) -> + let uu___1 = + FStarC_Compiler_List.fold_left + (fun uu___2 -> + fun uu___3 -> + match (uu___2, uu___3) with + | ((env2, acc), (field, p1)) -> + let uu___4 = translate_pat env2 p1 in + (match uu___4 with + | (env3, p2) -> (env3, ((field, p2) :: acc)))) + (env1, []) ps in + (match uu___1 with + | (env2, ps1) -> (env2, (PRecord (FStarC_Compiler_List.rev ps1)))) + | FStarC_Extraction_ML_Syntax.MLP_Tuple ps -> + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun p1 -> + match uu___1 with + | (env2, acc) -> + let uu___2 = translate_pat env2 p1 in + (match uu___2 with | (env3, p2) -> (env3, (p2 :: acc)))) + (env1, []) ps in + (match uu___ with + | (env2, ps1) -> (env2, (PTuple (FStarC_Compiler_List.rev ps1)))) + | FStarC_Extraction_ML_Syntax.MLP_Const uu___ -> + failwith "todo: translate_pat [MLP_Const]" + | FStarC_Extraction_ML_Syntax.MLP_Branch uu___ -> + failwith "todo: translate_pat [MLP_Branch]" +and (translate_constant : FStarC_Extraction_ML_Syntax.mlconstant -> expr) = + fun c -> + match c with + | FStarC_Extraction_ML_Syntax.MLC_Unit -> EUnit + | FStarC_Extraction_ML_Syntax.MLC_Bool b -> EBool b + | FStarC_Extraction_ML_Syntax.MLC_String s -> + ((let uu___1 = + FStarC_Compiler_Util.for_some + (fun c1 -> c1 = (FStar_Char.char_of_int Prims.int_zero)) + (FStar_String.list_of_string s) in + if uu___1 + then + let uu___2 = + FStarC_Compiler_Util.format1 + "Refusing to translate a string literal that contains a null character: %s" + s in + failwith uu___2 + else ()); + EString s) + | FStarC_Extraction_ML_Syntax.MLC_Char c1 -> + let i = FStarC_Compiler_Util.int_of_char c1 in + let s = FStarC_Compiler_Util.string_of_int i in + let c2 = EConstant (CInt, s) in + let char_of_int = EQualified (["FStar"; "Char"], "char_of_int") in + EApp (char_of_int, [c2]) + | FStarC_Extraction_ML_Syntax.MLC_Int + (s, FStar_Pervasives_Native.Some (sg, wd)) -> + let uu___ = + let uu___1 = + translate_width (FStar_Pervasives_Native.Some (sg, wd)) in + (uu___1, s) in + EConstant uu___ + | FStarC_Extraction_ML_Syntax.MLC_Float uu___ -> + failwith "todo: translate_expr [MLC_Float]" + | FStarC_Extraction_ML_Syntax.MLC_Bytes uu___ -> + failwith "todo: translate_expr [MLC_Bytes]" + | FStarC_Extraction_ML_Syntax.MLC_Int (s, FStar_Pervasives_Native.None) + -> EConstant (CInt, s) +and (mk_op_app : + env -> width -> op -> FStarC_Extraction_ML_Syntax.mlexpr Prims.list -> expr) + = + fun env1 -> + fun w -> + fun op1 -> + fun args -> + let uu___ = + let uu___1 = FStarC_Compiler_List.map (translate_expr env1) args in + ((EOp (op1, w)), uu___1) in + EApp uu___ +let (translate_type_decl' : + env -> + FStarC_Extraction_ML_Syntax.one_mltydecl -> + decl FStar_Pervasives_Native.option) + = + fun env1 -> + fun ty -> + match ty with + | { FStarC_Extraction_ML_Syntax.tydecl_assumed = assumed; + FStarC_Extraction_ML_Syntax.tydecl_name = name1; + FStarC_Extraction_ML_Syntax.tydecl_ignored = uu___; + FStarC_Extraction_ML_Syntax.tydecl_parameters = args; + FStarC_Extraction_ML_Syntax.tydecl_meta = flags; + FStarC_Extraction_ML_Syntax.tydecl_defn = + FStar_Pervasives_Native.Some + (FStarC_Extraction_ML_Syntax.MLTD_Abbrev t);_} + -> + let name2 = ((env1.module_name), name1) in + let env2 = + FStarC_Compiler_List.fold_left + (fun env3 -> + fun uu___1 -> + match uu___1 with + | { + FStarC_Extraction_ML_Syntax.ty_param_name = + ty_param_name; + FStarC_Extraction_ML_Syntax.ty_param_attrs = uu___2;_} + -> extend_t env3 ty_param_name) env1 args in + if + assumed && + (FStarC_Compiler_List.mem FStarC_Extraction_ML_Syntax.CAbstract + flags) + then FStar_Pervasives_Native.Some (DTypeAbstractStruct name2) + else + if assumed + then + (let name3 = FStarC_Extraction_ML_Syntax.string_of_mlpath name2 in + FStarC_Compiler_Util.print1_warning + "Not extracting type definition %s to KaRaMeL (assumed type)\n" + name3; + FStar_Pervasives_Native.None) + else + (let uu___3 = + let uu___4 = + let uu___5 = translate_flags flags in + let uu___6 = translate_type env2 t in + (name2, uu___5, (FStarC_Compiler_List.length args), + uu___6) in + DTypeAlias uu___4 in + FStar_Pervasives_Native.Some uu___3) + | { FStarC_Extraction_ML_Syntax.tydecl_assumed = uu___; + FStarC_Extraction_ML_Syntax.tydecl_name = name1; + FStarC_Extraction_ML_Syntax.tydecl_ignored = uu___1; + FStarC_Extraction_ML_Syntax.tydecl_parameters = args; + FStarC_Extraction_ML_Syntax.tydecl_meta = flags; + FStarC_Extraction_ML_Syntax.tydecl_defn = + FStar_Pervasives_Native.Some + (FStarC_Extraction_ML_Syntax.MLTD_Record fields);_} + -> + let name2 = ((env1.module_name), name1) in + let env2 = + FStarC_Compiler_List.fold_left + (fun env3 -> + fun uu___2 -> + match uu___2 with + | { + FStarC_Extraction_ML_Syntax.ty_param_name = + ty_param_name; + FStarC_Extraction_ML_Syntax.ty_param_attrs = uu___3;_} + -> extend_t env3 ty_param_name) env1 args in + let uu___2 = + let uu___3 = + let uu___4 = translate_flags flags in + let uu___5 = + FStarC_Compiler_List.map + (fun uu___6 -> + match uu___6 with + | (f, t) -> + let uu___7 = + let uu___8 = translate_type_without_decay env2 t in + (uu___8, false) in + (f, uu___7)) fields in + (name2, uu___4, (FStarC_Compiler_List.length args), uu___5) in + DTypeFlat uu___3 in + FStar_Pervasives_Native.Some uu___2 + | { FStarC_Extraction_ML_Syntax.tydecl_assumed = uu___; + FStarC_Extraction_ML_Syntax.tydecl_name = name1; + FStarC_Extraction_ML_Syntax.tydecl_ignored = uu___1; + FStarC_Extraction_ML_Syntax.tydecl_parameters = args; + FStarC_Extraction_ML_Syntax.tydecl_meta = flags; + FStarC_Extraction_ML_Syntax.tydecl_defn = + FStar_Pervasives_Native.Some + (FStarC_Extraction_ML_Syntax.MLTD_DType branches1);_} + -> + let name2 = ((env1.module_name), name1) in + let flags1 = translate_flags flags in + let env2 = + let uu___2 = FStarC_Extraction_ML_Syntax.ty_param_names args in + FStarC_Compiler_List.fold_left extend_t env1 uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Compiler_List.map + (fun uu___5 -> + match uu___5 with + | (cons, ts) -> + let uu___6 = + FStarC_Compiler_List.map + (fun uu___7 -> + match uu___7 with + | (name3, t) -> + let uu___8 = + let uu___9 = + translate_type_without_decay env2 t in + (uu___9, false) in + (name3, uu___8)) ts in + (cons, uu___6)) branches1 in + (name2, flags1, (FStarC_Compiler_List.length args), uu___4) in + DTypeVariant uu___3 in + FStar_Pervasives_Native.Some uu___2 + | { FStarC_Extraction_ML_Syntax.tydecl_assumed = uu___; + FStarC_Extraction_ML_Syntax.tydecl_name = name1; + FStarC_Extraction_ML_Syntax.tydecl_ignored = uu___1; + FStarC_Extraction_ML_Syntax.tydecl_parameters = uu___2; + FStarC_Extraction_ML_Syntax.tydecl_meta = uu___3; + FStarC_Extraction_ML_Syntax.tydecl_defn = uu___4;_} -> + ((let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Compiler_Util.format1 + "Error extracting type definition %s to KaRaMeL." name1 in + FStarC_Errors_Msg.text uu___8 in + [uu___7] in + FStarC_Errors.log_issue0 + FStarC_Errors_Codes.Warning_DefinitionNotTranslated () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___6)); + FStar_Pervasives_Native.None) +let (translate_let' : + env -> + FStarC_Extraction_ML_Syntax.mlletflavor -> + FStarC_Extraction_ML_Syntax.mllb -> decl FStar_Pervasives_Native.option) + = + fun env1 -> + fun flavor -> + fun lb -> + match lb with + | { FStarC_Extraction_ML_Syntax.mllb_name = name1; + FStarC_Extraction_ML_Syntax.mllb_tysc = + FStar_Pervasives_Native.Some (tvars, t0); + FStarC_Extraction_ML_Syntax.mllb_add_unit = uu___; + FStarC_Extraction_ML_Syntax.mllb_def = e; + FStarC_Extraction_ML_Syntax.mllb_attrs = uu___1; + FStarC_Extraction_ML_Syntax.mllb_meta = meta; + FStarC_Extraction_ML_Syntax.print_typ = uu___2;_} when + FStarC_Compiler_Util.for_some + (fun uu___3 -> + match uu___3 with + | FStarC_Extraction_ML_Syntax.Assumed -> true + | uu___4 -> false) meta + -> + let name2 = ((env1.module_name), name1) in + let arg_names = + match e.FStarC_Extraction_ML_Syntax.expr with + | FStarC_Extraction_ML_Syntax.MLE_Fun (bs, uu___3) -> + FStarC_Compiler_List.map + (fun uu___4 -> + match uu___4 with + | { + FStarC_Extraction_ML_Syntax.mlbinder_name = + mlbinder_name; + FStarC_Extraction_ML_Syntax.mlbinder_ty = uu___5; + FStarC_Extraction_ML_Syntax.mlbinder_attrs = + uu___6;_} + -> mlbinder_name) bs + | uu___3 -> [] in + if (FStarC_Compiler_List.length tvars) = Prims.int_zero + then + let uu___3 = + let uu___4 = + let uu___5 = translate_cc meta in + let uu___6 = translate_flags meta in + let uu___7 = translate_type env1 t0 in + (uu___5, uu___6, name2, uu___7, arg_names) in + DExternal uu___4 in + FStar_Pervasives_Native.Some uu___3 + else + ((let uu___5 = + FStarC_Extraction_ML_Syntax.string_of_mlpath name2 in + FStarC_Compiler_Util.print1_warning + "Not extracting %s to KaRaMeL (polymorphic assumes are not supported)\n" + uu___5); + FStar_Pervasives_Native.None) + | { FStarC_Extraction_ML_Syntax.mllb_name = name1; + FStarC_Extraction_ML_Syntax.mllb_tysc = + FStar_Pervasives_Native.Some (tvars, t0); + FStarC_Extraction_ML_Syntax.mllb_add_unit = uu___; + FStarC_Extraction_ML_Syntax.mllb_def = + { + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Fun (args, body); + FStarC_Extraction_ML_Syntax.mlty = uu___1; + FStarC_Extraction_ML_Syntax.loc = uu___2;_}; + FStarC_Extraction_ML_Syntax.mllb_attrs = uu___3; + FStarC_Extraction_ML_Syntax.mllb_meta = meta; + FStarC_Extraction_ML_Syntax.print_typ = uu___4;_} -> + if + FStarC_Compiler_List.mem FStarC_Extraction_ML_Syntax.NoExtract + meta + then FStar_Pervasives_Native.None + else + (let env2 = + if flavor = FStarC_Extraction_ML_Syntax.Rec + then extend env1 name1 + else env1 in + let env3 = + let uu___6 = + FStarC_Extraction_ML_Syntax.ty_param_names tvars in + FStarC_Compiler_List.fold_left + (fun env4 -> fun name2 -> extend_t env4 name2) env2 uu___6 in + let rec find_return_type eff i uu___6 = + match uu___6 with + | FStarC_Extraction_ML_Syntax.MLTY_Fun (uu___7, eff1, t) + when i > Prims.int_zero -> + find_return_type eff1 (i - Prims.int_one) t + | t -> (i, eff, t) in + let name2 = ((env3.module_name), name1) in + let uu___6 = + find_return_type FStarC_Extraction_ML_Syntax.E_PURE + (FStarC_Compiler_List.length args) t0 in + match uu___6 with + | (i, eff, t) -> + (if i > Prims.int_zero + then + (let msg = + "function type annotation has less arrows than the number of arguments; please mark the return type abbreviation as inline_for_extraction" in + let uu___8 = + FStarC_Extraction_ML_Syntax.string_of_mlpath name2 in + FStarC_Compiler_Util.print2_warning + "Not extracting %s to KaRaMeL (%s)\n" uu___8 msg) + else (); + (let t1 = translate_type env3 t in + let binders = translate_binders env3 args in + let env4 = add_binders env3 args in + let cc1 = translate_cc meta in + let meta1 = + match (eff, t1) with + | (FStarC_Extraction_ML_Syntax.E_ERASABLE, uu___8) -> + let uu___9 = translate_flags meta in MustDisappear + :: uu___9 + | (FStarC_Extraction_ML_Syntax.E_PURE, TUnit) -> + let uu___8 = translate_flags meta in MustDisappear + :: uu___8 + | uu___8 -> translate_flags meta in + try + (fun uu___8 -> + match () with + | () -> + let body1 = translate_expr env4 body in + FStar_Pervasives_Native.Some + (DFunction + (cc1, meta1, + (FStarC_Compiler_List.length tvars), t1, + name2, binders, body1))) () + with + | uu___8 -> + let msg = FStarC_Compiler_Util.print_exn uu___8 in + ((let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Extraction_ML_Syntax.string_of_mlpath + name2 in + FStarC_Compiler_Util.format1 + "Error while extracting %s to KaRaMeL." + uu___13 in + FStarC_Errors_Msg.text uu___12 in + let uu___12 = + let uu___13 = + FStarC_Pprint.arbitrary_string msg in + [uu___13] in + uu___11 :: uu___12 in + FStarC_Errors.log_issue0 + FStarC_Errors_Codes.Warning_FunctionNotExtacted + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___10)); + (let msg1 = + Prims.strcat + "This function was not extracted:\n" msg in + FStar_Pervasives_Native.Some + (DFunction + (cc1, meta1, + (FStarC_Compiler_List.length tvars), t1, + name2, binders, (EAbortS msg1)))))))) + | { FStarC_Extraction_ML_Syntax.mllb_name = name1; + FStarC_Extraction_ML_Syntax.mllb_tysc = + FStar_Pervasives_Native.Some (tvars, t); + FStarC_Extraction_ML_Syntax.mllb_add_unit = uu___; + FStarC_Extraction_ML_Syntax.mllb_def = expr1; + FStarC_Extraction_ML_Syntax.mllb_attrs = uu___1; + FStarC_Extraction_ML_Syntax.mllb_meta = meta; + FStarC_Extraction_ML_Syntax.print_typ = uu___2;_} -> + if + FStarC_Compiler_List.mem FStarC_Extraction_ML_Syntax.NoExtract + meta + then FStar_Pervasives_Native.None + else + (let meta1 = translate_flags meta in + let env2 = + let uu___4 = + FStarC_Extraction_ML_Syntax.ty_param_names tvars in + FStarC_Compiler_List.fold_left + (fun env3 -> fun name2 -> extend_t env3 name2) env1 uu___4 in + let t1 = translate_type env2 t in + let name2 = ((env2.module_name), name1) in + try + (fun uu___4 -> + match () with + | () -> + let expr2 = translate_expr env2 expr1 in + FStar_Pervasives_Native.Some + (DGlobal + (meta1, name2, + (FStarC_Compiler_List.length tvars), t1, + expr2))) () + with + | uu___4 -> + ((let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Extraction_ML_Syntax.string_of_mlpath + name2 in + FStarC_Compiler_Util.format1 + "Error extracting %s to KaRaMeL." uu___9 in + FStarC_Errors_Msg.text uu___8 in + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Compiler_Util.print_exn uu___4 in + FStarC_Pprint.arbitrary_string uu___10 in + [uu___9] in + uu___7 :: uu___8 in + FStarC_Errors.log_issue0 + FStarC_Errors_Codes.Warning_DefinitionNotTranslated () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___6)); + FStar_Pervasives_Native.Some + (DGlobal + (meta1, name2, (FStarC_Compiler_List.length tvars), + t1, EAny)))) + | { FStarC_Extraction_ML_Syntax.mllb_name = name1; + FStarC_Extraction_ML_Syntax.mllb_tysc = ts; + FStarC_Extraction_ML_Syntax.mllb_add_unit = uu___; + FStarC_Extraction_ML_Syntax.mllb_def = uu___1; + FStarC_Extraction_ML_Syntax.mllb_attrs = uu___2; + FStarC_Extraction_ML_Syntax.mllb_meta = uu___3; + FStarC_Extraction_ML_Syntax.print_typ = uu___4;_} -> + ((let uu___6 = + FStarC_Compiler_Util.format1 "Not extracting %s to KaRaMeL\n" + name1 in + FStarC_Errors.log_issue0 + FStarC_Errors_Codes.Warning_DefinitionNotTranslated () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___6)); + (match ts with + | FStar_Pervasives_Native.Some (tps, t) -> + let uu___7 = + let uu___8 = + FStarC_Extraction_ML_Syntax.ty_param_names tps in + FStarC_Compiler_String.concat ", " uu___8 in + let uu___8 = + FStarC_Extraction_ML_Code.string_of_mlty ([], "") t in + FStarC_Compiler_Util.print2 + "Type scheme is: forall %s. %s\n" uu___7 uu___8 + | FStar_Pervasives_Native.None -> ()); + FStar_Pervasives_Native.None) +type translate_let_t = + env -> + FStarC_Extraction_ML_Syntax.mlletflavor -> + FStarC_Extraction_ML_Syntax.mllb -> decl FStar_Pervasives_Native.option +let (ref_translate_let : translate_let_t FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref translate_let' +let (register_pre_translate_let : translate_let_t -> unit) = + fun f -> + let before = FStarC_Compiler_Effect.op_Bang ref_translate_let in + let after e fl lb = + try (fun uu___ -> match () with | () -> f e fl lb) () + with | NotSupportedByKrmlExtension -> before e fl lb in + FStarC_Compiler_Effect.op_Colon_Equals ref_translate_let after +let (translate_let : + env -> + FStarC_Extraction_ML_Syntax.mlletflavor -> + FStarC_Extraction_ML_Syntax.mllb -> decl FStar_Pervasives_Native.option) + = + fun env1 -> + fun flavor -> + fun lb -> + let uu___ = FStarC_Compiler_Effect.op_Bang ref_translate_let in + uu___ env1 flavor lb +let (translate_decl : + env -> FStarC_Extraction_ML_Syntax.mlmodule1 -> decl Prims.list) = + fun env1 -> + fun d -> + match d.FStarC_Extraction_ML_Syntax.mlmodule1_m with + | FStarC_Extraction_ML_Syntax.MLM_Let (flavor, lbs) -> + FStarC_Compiler_List.choose (translate_let env1 flavor) lbs + | FStarC_Extraction_ML_Syntax.MLM_Loc uu___ -> [] + | FStarC_Extraction_ML_Syntax.MLM_Ty tys -> + FStarC_Compiler_List.choose (translate_type_decl env1) tys + | FStarC_Extraction_ML_Syntax.MLM_Top uu___ -> + failwith "todo: translate_decl [MLM_Top]" + | FStarC_Extraction_ML_Syntax.MLM_Exn (m, uu___) -> + (FStarC_Compiler_Util.print1_warning + "Not extracting exception %s to KaRaMeL (exceptions unsupported)\n" + m; + []) +let (translate_module : + FStarC_Extraction_ML_UEnv.uenv -> + (FStarC_Extraction_ML_Syntax.mlpath * (FStarC_Extraction_ML_Syntax.mlsig + * FStarC_Extraction_ML_Syntax.mlmodule) FStar_Pervasives_Native.option + * FStarC_Extraction_ML_Syntax.mllib) -> file) + = + fun uenv -> + fun m -> + let uu___ = m in + match uu___ with + | (module_name, modul, uu___1) -> + let module_name1 = + FStarC_Compiler_List.op_At + (FStar_Pervasives_Native.fst module_name) + [FStar_Pervasives_Native.snd module_name] in + let program1 = + match modul with + | FStar_Pervasives_Native.Some (_signature, decls) -> + FStarC_Compiler_List.collect + (translate_decl (empty uenv module_name1)) decls + | uu___2 -> + failwith "Unexpected standalone interface or nested modules" in + ((FStarC_Compiler_String.concat "_" module_name1), program1) +let (translate : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Extraction_ML_Syntax.mllib -> file Prims.list) + = + fun ue -> + fun uu___ -> + match uu___ with + | FStarC_Extraction_ML_Syntax.MLLib modules -> + FStarC_Compiler_List.filter_map + (fun m -> + let m_name = + let uu___1 = m in + match uu___1 with + | (path, uu___2, uu___3) -> + FStarC_Extraction_ML_Syntax.string_of_mlpath path in + try + (fun uu___1 -> + match () with + | () -> + ((let uu___3 = + let uu___4 = FStarC_Options.silent () in + Prims.op_Negation uu___4 in + if uu___3 + then + FStarC_Compiler_Util.print1 + "Attempting to translate module %s\n" m_name + else ()); + (let uu___3 = translate_module ue m in + FStar_Pervasives_Native.Some uu___3))) () + with + | uu___1 -> + ((let uu___3 = FStarC_Compiler_Util.print_exn uu___1 in + FStarC_Compiler_Util.print2 + "Unable to translate module: %s because:\n %s\n" + m_name uu___3); + FStar_Pervasives_Native.None)) modules +let (uu___0 : unit) = + register_post_translate_type_without_decay translate_type_without_decay'; + register_post_translate_type translate_type'; + register_post_translate_type_decl translate_type_decl'; + register_post_translate_expr translate_expr' \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Extraction_ML_Code.ml b/ocaml/fstar-lib/generated/FStarC_Extraction_ML_Code.ml new file mode 100644 index 00000000000..c69daff1fdb --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Extraction_ML_Code.ml @@ -0,0 +1,1450 @@ +open Prims +type doc = + | Doc of Prims.string +let (uu___is_Doc : doc -> Prims.bool) = fun projectee -> true +let (__proj__Doc__item___0 : doc -> Prims.string) = + fun projectee -> match projectee with | Doc _0 -> _0 +type assoc = + | ILeft + | IRight + | Left + | Right + | NonAssoc +let (uu___is_ILeft : assoc -> Prims.bool) = + fun projectee -> match projectee with | ILeft -> true | uu___ -> false +let (uu___is_IRight : assoc -> Prims.bool) = + fun projectee -> match projectee with | IRight -> true | uu___ -> false +let (uu___is_Left : assoc -> Prims.bool) = + fun projectee -> match projectee with | Left -> true | uu___ -> false +let (uu___is_Right : assoc -> Prims.bool) = + fun projectee -> match projectee with | Right -> true | uu___ -> false +let (uu___is_NonAssoc : assoc -> Prims.bool) = + fun projectee -> match projectee with | NonAssoc -> true | uu___ -> false +type fixity = + | Prefix + | Postfix + | Infix of assoc +let (uu___is_Prefix : fixity -> Prims.bool) = + fun projectee -> match projectee with | Prefix -> true | uu___ -> false +let (uu___is_Postfix : fixity -> Prims.bool) = + fun projectee -> match projectee with | Postfix -> true | uu___ -> false +let (uu___is_Infix : fixity -> Prims.bool) = + fun projectee -> match projectee with | Infix _0 -> true | uu___ -> false +let (__proj__Infix__item___0 : fixity -> assoc) = + fun projectee -> match projectee with | Infix _0 -> _0 +type opprec = (Prims.int * fixity) +type level = (opprec * assoc) +let (t_prio_fun : (Prims.int * fixity)) = + ((Prims.of_int (10)), (Infix Right)) +let (t_prio_tpl : (Prims.int * fixity)) = + ((Prims.of_int (20)), (Infix NonAssoc)) +let (t_prio_name : (Prims.int * fixity)) = ((Prims.of_int (30)), Postfix) +let (e_bin_prio_lambda : (Prims.int * fixity)) = ((Prims.of_int (5)), Prefix) +let (e_bin_prio_if : (Prims.int * fixity)) = ((Prims.of_int (15)), Prefix) +let (e_bin_prio_letin : (Prims.int * fixity)) = ((Prims.of_int (19)), Prefix) +let (e_bin_prio_or : (Prims.int * fixity)) = + ((Prims.of_int (20)), (Infix Left)) +let (e_bin_prio_and : (Prims.int * fixity)) = + ((Prims.of_int (25)), (Infix Left)) +let (e_bin_prio_eq : (Prims.int * fixity)) = + ((Prims.of_int (27)), (Infix NonAssoc)) +let (e_bin_prio_order : (Prims.int * fixity)) = + ((Prims.of_int (29)), (Infix NonAssoc)) +let (e_bin_prio_op1 : (Prims.int * fixity)) = + ((Prims.of_int (30)), (Infix Left)) +let (e_bin_prio_op2 : (Prims.int * fixity)) = + ((Prims.of_int (40)), (Infix Left)) +let (e_bin_prio_op3 : (Prims.int * fixity)) = + ((Prims.of_int (50)), (Infix Left)) +let (e_bin_prio_op4 : (Prims.int * fixity)) = + ((Prims.of_int (60)), (Infix Left)) +let (e_bin_prio_comb : (Prims.int * fixity)) = + ((Prims.of_int (70)), (Infix Left)) +let (e_bin_prio_seq : (Prims.int * fixity)) = + ((Prims.of_int (100)), (Infix Left)) +let (e_app_prio : (Prims.int * fixity)) = + ((Prims.of_int (10000)), (Infix Left)) +let (min_op_prec : (Prims.int * fixity)) = + ((Prims.of_int (-1)), (Infix NonAssoc)) +let (max_op_prec : (Prims.int * fixity)) = + (FStarC_Compiler_Util.max_int, (Infix NonAssoc)) +let (empty : doc) = Doc "" +let (hardline : doc) = Doc "\n" +let (text : Prims.string -> doc) = fun s -> Doc s +let (num : Prims.int -> doc) = + fun i -> let uu___ = FStarC_Compiler_Util.string_of_int i in Doc uu___ +let (break1 : doc) = text " " +let (enclose : doc -> doc -> doc -> doc) = + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + match (uu___, uu___1, uu___2) with + | (Doc l, Doc r, Doc x) -> Doc (Prims.strcat l (Prims.strcat x r)) +let (cbrackets : doc -> doc) = + fun uu___ -> + match uu___ with | Doc d -> enclose (text "{") (text "}") (Doc d) +let (parens : doc -> doc) = + fun uu___ -> + match uu___ with | Doc d -> enclose (text "(") (text ")") (Doc d) +let (cat : doc -> doc -> doc) = + fun uu___ -> + fun uu___1 -> + match (uu___, uu___1) with + | (Doc d1, Doc d2) -> Doc (Prims.strcat d1 d2) +let (reduce : doc Prims.list -> doc) = + fun docs -> FStarC_Compiler_List.fold_left cat empty docs +let (combine : doc -> doc Prims.list -> doc) = + fun uu___ -> + fun docs -> + match uu___ with + | Doc sep -> + let select uu___1 = + match uu___1 with + | Doc d -> + if d = "" + then FStar_Pervasives_Native.None + else FStar_Pervasives_Native.Some d in + let docs1 = FStarC_Compiler_List.choose select docs in + Doc (FStarC_Compiler_String.concat sep docs1) +let (reduce1 : doc Prims.list -> doc) = fun docs -> combine break1 docs +let (hbox : doc -> doc) = fun d -> d +let rec in_ns : 'a . ('a Prims.list * 'a Prims.list) -> Prims.bool = + fun x -> + match x with + | ([], uu___) -> true + | (x1::t1, x2::t2) when x1 = x2 -> in_ns (t1, t2) + | (uu___, uu___1) -> false +let (path_of_ns : + FStarC_Extraction_ML_Syntax.mlsymbol -> + Prims.string Prims.list -> Prims.string Prims.list) + = + fun currentModule -> + fun ns -> + let ns' = FStarC_Extraction_ML_Util.flatten_ns ns in + if ns' = currentModule + then [] + else + (let cg_libs = FStarC_Options.codegen_libs () in + let ns_len = FStarC_Compiler_List.length ns in + let found = + FStarC_Compiler_Util.find_map cg_libs + (fun cg_path -> + let cg_len = FStarC_Compiler_List.length cg_path in + if (FStarC_Compiler_List.length cg_path) < ns_len + then + let uu___1 = FStarC_Compiler_Util.first_N cg_len ns in + match uu___1 with + | (pfx, sfx) -> + (if pfx = cg_path + then + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Extraction_ML_Util.flatten_ns sfx in + [uu___4] in + FStarC_Compiler_List.op_At pfx uu___3 in + FStar_Pervasives_Native.Some uu___2 + else FStar_Pervasives_Native.None) + else FStar_Pervasives_Native.None) in + match found with + | FStar_Pervasives_Native.None -> [ns'] + | FStar_Pervasives_Native.Some x -> x) +let (mlpath_of_mlpath : + FStarC_Extraction_ML_Syntax.mlsymbol -> + FStarC_Extraction_ML_Syntax.mlpath -> FStarC_Extraction_ML_Syntax.mlpath) + = + fun currentModule -> + fun x -> + let uu___ = FStarC_Extraction_ML_Syntax.string_of_mlpath x in + match uu___ with + | "Prims.Some" -> ([], "Some") + | "Prims.None" -> ([], "None") + | uu___1 -> + let uu___2 = x in + (match uu___2 with + | (ns, x1) -> + let uu___3 = path_of_ns currentModule ns in (uu___3, x1)) +let (ptsym_of_symbol : + FStarC_Extraction_ML_Syntax.mlsymbol -> + FStarC_Extraction_ML_Syntax.mlsymbol) + = + fun s -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Compiler_String.get s Prims.int_zero in + FStar_Char.lowercase uu___2 in + let uu___2 = FStarC_Compiler_String.get s Prims.int_zero in + uu___1 <> uu___2 in + if uu___ then Prims.strcat "l__" s else s +let (ptsym : + FStarC_Extraction_ML_Syntax.mlsymbol -> + FStarC_Extraction_ML_Syntax.mlpath -> + FStarC_Extraction_ML_Syntax.mlsymbol) + = + fun currentModule -> + fun mlp -> + if FStarC_Compiler_List.isEmpty (FStar_Pervasives_Native.fst mlp) + then ptsym_of_symbol (FStar_Pervasives_Native.snd mlp) + else + (let uu___1 = mlpath_of_mlpath currentModule mlp in + match uu___1 with + | (p, s) -> + let uu___2 = + let uu___3 = let uu___4 = ptsym_of_symbol s in [uu___4] in + FStarC_Compiler_List.op_At p uu___3 in + FStarC_Compiler_String.concat "." uu___2) +let (ptctor : + FStarC_Extraction_ML_Syntax.mlsymbol -> + FStarC_Extraction_ML_Syntax.mlpath -> + FStarC_Extraction_ML_Syntax.mlsymbol) + = + fun currentModule -> + fun mlp -> + let uu___ = mlpath_of_mlpath currentModule mlp in + match uu___ with + | (p, s) -> + let s1 = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Compiler_String.get s Prims.int_zero in + FStar_Char.uppercase uu___3 in + let uu___3 = FStarC_Compiler_String.get s Prims.int_zero in + uu___2 <> uu___3 in + if uu___1 then Prims.strcat "U__" s else s in + FStarC_Compiler_String.concat "." + (FStarC_Compiler_List.op_At p [s1]) +let (infix_prim_ops : + (Prims.string * (Prims.int * fixity) * Prims.string) Prims.list) = + [("op_Addition", e_bin_prio_op1, "+"); + ("op_Subtraction", e_bin_prio_op1, "-"); + ("op_Multiply", e_bin_prio_op1, "*"); + ("op_Division", e_bin_prio_op1, "/"); + ("op_Equality", e_bin_prio_eq, "="); + ("op_Colon_Equals", e_bin_prio_eq, ":="); + ("op_disEquality", e_bin_prio_eq, "<>"); + ("op_AmpAmp", e_bin_prio_and, "&&"); + ("op_BarBar", e_bin_prio_or, "||"); + ("op_LessThanOrEqual", e_bin_prio_order, "<="); + ("op_GreaterThanOrEqual", e_bin_prio_order, ">="); + ("op_LessThan", e_bin_prio_order, "<"); + ("op_GreaterThan", e_bin_prio_order, ">"); + ("op_Modulus", e_bin_prio_order, "mod")] +let (prim_uni_ops : unit -> (Prims.string * Prims.string) Prims.list) = + fun uu___ -> + let op_minus = + let uu___1 = FStarC_Extraction_ML_Util.codegen_fsharp () in + if uu___1 then "-" else "~-" in + [("op_Negation", "not"); + ("op_Minus", op_minus); + ("op_Bang", "Support.ST.read")] +let prim_types : 'uuuuu . unit -> 'uuuuu Prims.list = fun uu___ -> [] +let (prim_constructors : (Prims.string * Prims.string) Prims.list) = + [("Some", "Some"); ("None", "None"); ("Nil", "[]"); ("Cons", "::")] +let (is_prims_ns : + FStarC_Extraction_ML_Syntax.mlsymbol Prims.list -> Prims.bool) = + fun ns -> (ns = ["Prims"]) || (ns = ["Prims"]) +let (as_bin_op : + FStarC_Extraction_ML_Syntax.mlpath -> + (FStarC_Extraction_ML_Syntax.mlsymbol * (Prims.int * fixity) * + Prims.string) FStar_Pervasives_Native.option) + = + fun uu___ -> + match uu___ with + | (ns, x) -> + if is_prims_ns ns + then + FStarC_Compiler_List.tryFind + (fun uu___1 -> match uu___1 with | (y, uu___2, uu___3) -> x = y) + infix_prim_ops + else FStar_Pervasives_Native.None +let (is_bin_op : FStarC_Extraction_ML_Syntax.mlpath -> Prims.bool) = + fun p -> let uu___ = as_bin_op p in uu___ <> FStar_Pervasives_Native.None +let (as_uni_op : + FStarC_Extraction_ML_Syntax.mlpath -> + (FStarC_Extraction_ML_Syntax.mlsymbol * Prims.string) + FStar_Pervasives_Native.option) + = + fun uu___ -> + match uu___ with + | (ns, x) -> + if is_prims_ns ns + then + let uu___1 = prim_uni_ops () in + FStarC_Compiler_List.tryFind + (fun uu___2 -> match uu___2 with | (y, uu___3) -> x = y) uu___1 + else FStar_Pervasives_Native.None +let (is_uni_op : FStarC_Extraction_ML_Syntax.mlpath -> Prims.bool) = + fun p -> let uu___ = as_uni_op p in uu___ <> FStar_Pervasives_Native.None +let (is_standard_type : FStarC_Extraction_ML_Syntax.mlpath -> Prims.bool) = + fun p -> false +let (as_standard_constructor : + FStarC_Extraction_ML_Syntax.mlpath -> + (FStarC_Extraction_ML_Syntax.mlsymbol * Prims.string) + FStar_Pervasives_Native.option) + = + fun uu___ -> + match uu___ with + | (ns, x) -> + if is_prims_ns ns + then + FStarC_Compiler_List.tryFind + (fun uu___1 -> match uu___1 with | (y, uu___2) -> x = y) + prim_constructors + else FStar_Pervasives_Native.None +let (is_standard_constructor : + FStarC_Extraction_ML_Syntax.mlpath -> Prims.bool) = + fun p -> + let uu___ = as_standard_constructor p in + uu___ <> FStar_Pervasives_Native.None +let (maybe_paren : + ((Prims.int * fixity) * assoc) -> (Prims.int * fixity) -> doc -> doc) = + fun uu___ -> + fun inner -> + fun doc1 -> + match uu___ with + | (outer, side) -> + let noparens _inner _outer side1 = + let uu___1 = _inner in + match uu___1 with + | (pi, fi) -> + let uu___2 = _outer in + (match uu___2 with + | (po, fo) -> + (pi > po) || + ((match (fi, side1) with + | (Postfix, Left) -> true + | (Prefix, Right) -> true + | (Infix (Left), Left) -> + (pi = po) && (fo = (Infix Left)) + | (Infix (Right), Right) -> + (pi = po) && (fo = (Infix Right)) + | (Infix (Left), ILeft) -> + (pi = po) && (fo = (Infix Left)) + | (Infix (Right), IRight) -> + (pi = po) && (fo = (Infix Right)) + | (uu___3, NonAssoc) -> (pi = po) && (fi = fo) + | (uu___3, uu___4) -> false))) in + if noparens inner outer side then doc1 else parens doc1 +let (escape_byte_hex : FStarC_BaseTypes.byte -> Prims.string) = + fun x -> Prims.strcat "\\x" (FStarC_Compiler_Util.hex_string_of_byte x) +let (escape_char_hex : FStarC_BaseTypes.char -> Prims.string) = + fun x -> escape_byte_hex (FStarC_Compiler_Util.byte_of_char x) +let (escape_or : + (FStarC_BaseTypes.char -> Prims.string) -> + FStarC_BaseTypes.char -> Prims.string) + = + fun fallback -> + fun uu___ -> + if uu___ = 92 + then "\\\\" + else + if uu___ = 32 + then " " + else + if uu___ = 8 + then "\\b" + else + if uu___ = 9 + then "\\t" + else + if uu___ = 13 + then "\\r" + else + if uu___ = 10 + then "\\n" + else + if uu___ = 39 + then "\\'" + else + if uu___ = 34 + then "\\\"" + else + if FStarC_Compiler_Util.is_letter_or_digit uu___ + then FStarC_Compiler_Util.string_of_char uu___ + else + if FStarC_Compiler_Util.is_punctuation uu___ + then FStarC_Compiler_Util.string_of_char uu___ + else + if FStarC_Compiler_Util.is_symbol uu___ + then FStarC_Compiler_Util.string_of_char uu___ + else fallback uu___ +let (string_of_mlconstant : + FStarC_Extraction_ML_Syntax.mlconstant -> Prims.string) = + fun sctt -> + match sctt with + | FStarC_Extraction_ML_Syntax.MLC_Unit -> "()" + | FStarC_Extraction_ML_Syntax.MLC_Bool (true) -> "true" + | FStarC_Extraction_ML_Syntax.MLC_Bool (false) -> "false" + | FStarC_Extraction_ML_Syntax.MLC_Char c -> + let uu___ = FStarC_Extraction_ML_Util.codegen_fsharp () in + if uu___ + then + Prims.strcat "'" + (Prims.strcat (FStarC_Compiler_Util.string_of_char c) "'") + else + (let nc = FStar_Char.int_of_char c in + let uu___2 = FStarC_Compiler_Util.string_of_int nc in + Prims.strcat uu___2 + (if + ((nc >= (Prims.of_int (32))) && (nc = (Prims.of_int (127)))) + && (nc < (Prims.of_int (34))) + then + Prims.strcat " (*" + (Prims.strcat (FStarC_Compiler_Util.string_of_char c) "*)") + else "")) + | FStarC_Extraction_ML_Syntax.MLC_Int + (s, FStar_Pervasives_Native.Some + (FStarC_Const.Signed, FStarC_Const.Int32)) + -> Prims.strcat s "l" + | FStarC_Extraction_ML_Syntax.MLC_Int + (s, FStar_Pervasives_Native.Some + (FStarC_Const.Signed, FStarC_Const.Int64)) + -> Prims.strcat s "L" + | FStarC_Extraction_ML_Syntax.MLC_Int + (s, FStar_Pervasives_Native.Some (uu___, FStarC_Const.Int8)) -> s + | FStarC_Extraction_ML_Syntax.MLC_Int + (s, FStar_Pervasives_Native.Some (uu___, FStarC_Const.Int16)) -> s + | FStarC_Extraction_ML_Syntax.MLC_Int + (v, FStar_Pervasives_Native.Some (uu___, FStarC_Const.Sizet)) -> + let z = Prims.strcat "(Prims.parse_int \"" (Prims.strcat v "\")") in + Prims.strcat "(FStar_SizeT.uint_to_t (" (Prims.strcat z "))") + | FStarC_Extraction_ML_Syntax.MLC_Int + (v, FStar_Pervasives_Native.Some (s, w)) -> + let sign = + match s with + | FStarC_Const.Signed -> "Int" + | FStarC_Const.Unsigned -> "UInt" in + let ws = + match w with + | FStarC_Const.Int8 -> "8" + | FStarC_Const.Int16 -> "16" + | FStarC_Const.Int32 -> "32" + | FStarC_Const.Int64 -> "64" in + let z = Prims.strcat "(Prims.parse_int \"" (Prims.strcat v "\")") in + let u = + match s with + | FStarC_Const.Signed -> "" + | FStarC_Const.Unsigned -> "u" in + Prims.strcat "(FStar_" + (Prims.strcat sign + (Prims.strcat ws + (Prims.strcat "." + (Prims.strcat u + (Prims.strcat "int_to_t (" (Prims.strcat z "))")))))) + | FStarC_Extraction_ML_Syntax.MLC_Int (s, FStar_Pervasives_Native.None) + -> Prims.strcat "(Prims.parse_int \"" (Prims.strcat s "\")") + | FStarC_Extraction_ML_Syntax.MLC_Float d -> + FStarC_Compiler_Util.string_of_float d + | FStarC_Extraction_ML_Syntax.MLC_Bytes bytes -> + let uu___ = + let uu___1 = FStarC_Compiler_Bytes.f_encode escape_byte_hex bytes in + Prims.strcat uu___1 "\"" in + Prims.strcat "\"" uu___ + | FStarC_Extraction_ML_Syntax.MLC_String chars -> + let uu___ = + let uu___1 = + FStarC_Compiler_String.collect + (escape_or FStarC_Compiler_Util.string_of_char) chars in + Prims.strcat uu___1 "\"" in + Prims.strcat "\"" uu___ + | uu___ -> failwith "TODO: extract integer constants properly into OCaml" +let (string_of_etag : FStarC_Extraction_ML_Syntax.e_tag -> Prims.string) = + fun uu___ -> + match uu___ with + | FStarC_Extraction_ML_Syntax.E_PURE -> "" + | FStarC_Extraction_ML_Syntax.E_ERASABLE -> "Erased" + | FStarC_Extraction_ML_Syntax.E_IMPURE -> "Impure" +let rec (doc_of_mltype' : + FStarC_Extraction_ML_Syntax.mlsymbol -> + level -> FStarC_Extraction_ML_Syntax.mlty -> doc) + = + fun currentModule -> + fun outer -> + fun ty -> + match ty with + | FStarC_Extraction_ML_Syntax.MLTY_Var x -> + let escape_tyvar s = + if FStarC_Compiler_Util.starts_with s "'_" + then FStarC_Compiler_Util.replace_char s 95 117 + else s in + text (escape_tyvar x) + | FStarC_Extraction_ML_Syntax.MLTY_Tuple tys -> + let doc1 = + FStarC_Compiler_List.map + (doc_of_mltype currentModule (t_prio_tpl, Left)) tys in + let doc2 = + let uu___ = + let uu___1 = combine (text " * ") doc1 in hbox uu___1 in + parens uu___ in + doc2 + | FStarC_Extraction_ML_Syntax.MLTY_Named (args, name) -> + let args1 = + match args with + | [] -> empty + | arg::[] -> + doc_of_mltype currentModule (t_prio_name, Left) arg + | uu___ -> + let args2 = + FStarC_Compiler_List.map + (doc_of_mltype currentModule (min_op_prec, NonAssoc)) + args in + let uu___1 = + let uu___2 = combine (text ", ") args2 in hbox uu___2 in + parens uu___1 in + let name1 = ptsym currentModule name in + let uu___ = reduce1 [args1; text name1] in hbox uu___ + | FStarC_Extraction_ML_Syntax.MLTY_Fun (t1, et, t2) -> + let d1 = doc_of_mltype currentModule (t_prio_fun, Left) t1 in + let d2 = doc_of_mltype currentModule (t_prio_fun, Right) t2 in + let uu___ = + let uu___1 = reduce1 [d1; text " -> "; d2] in hbox uu___1 in + maybe_paren outer t_prio_fun uu___ + | FStarC_Extraction_ML_Syntax.MLTY_Top -> + let uu___ = FStarC_Extraction_ML_Util.codegen_fsharp () in + if uu___ then text "obj" else text "Obj.t" + | FStarC_Extraction_ML_Syntax.MLTY_Erased -> text "unit" +and (doc_of_mltype : + FStarC_Extraction_ML_Syntax.mlsymbol -> + level -> FStarC_Extraction_ML_Syntax.mlty -> doc) + = + fun currentModule -> + fun outer -> + fun ty -> + let uu___ = FStarC_Extraction_ML_Util.resugar_mlty ty in + doc_of_mltype' currentModule outer uu___ +let rec (doc_of_expr : + FStarC_Extraction_ML_Syntax.mlsymbol -> + level -> FStarC_Extraction_ML_Syntax.mlexpr -> doc) + = + fun currentModule -> + fun outer -> + fun e -> + match e.FStarC_Extraction_ML_Syntax.expr with + | FStarC_Extraction_ML_Syntax.MLE_Coerce (e1, t, t') -> + let doc1 = doc_of_expr currentModule (min_op_prec, NonAssoc) e1 in + let uu___ = FStarC_Extraction_ML_Util.codegen_fsharp () in + if uu___ + then + let uu___1 = reduce [text "Prims.unsafe_coerce "; doc1] in + parens uu___1 + else + (let uu___2 = reduce [text "Obj.magic "; parens doc1] in + parens uu___2) + | FStarC_Extraction_ML_Syntax.MLE_Seq es -> + let docs = + FStarC_Compiler_List.map + (doc_of_expr currentModule (min_op_prec, NonAssoc)) es in + let docs1 = + FStarC_Compiler_List.map + (fun d -> reduce [d; text ";"; hardline]) docs in + let uu___ = reduce docs1 in parens uu___ + | FStarC_Extraction_ML_Syntax.MLE_Const c -> + let uu___ = string_of_mlconstant c in text uu___ + | FStarC_Extraction_ML_Syntax.MLE_Var x -> text x + | FStarC_Extraction_ML_Syntax.MLE_Name path -> + let uu___ = ptsym currentModule path in text uu___ + | FStarC_Extraction_ML_Syntax.MLE_Record (path, uu___, fields) -> + let for1 uu___1 = + match uu___1 with + | (name, e1) -> + let doc1 = + doc_of_expr currentModule (min_op_prec, NonAssoc) e1 in + let uu___2 = + let uu___3 = + let uu___4 = ptsym currentModule (path, name) in + text uu___4 in + [uu___3; text "="; doc1] in + reduce1 uu___2 in + let uu___1 = + let uu___2 = FStarC_Compiler_List.map for1 fields in + combine (text "; ") uu___2 in + cbrackets uu___1 + | FStarC_Extraction_ML_Syntax.MLE_CTor (ctor, []) -> + let name = + let uu___ = is_standard_constructor ctor in + if uu___ + then + let uu___1 = + let uu___2 = as_standard_constructor ctor in + FStarC_Compiler_Option.get uu___2 in + FStar_Pervasives_Native.snd uu___1 + else ptctor currentModule ctor in + text name + | FStarC_Extraction_ML_Syntax.MLE_CTor (ctor, args) -> + let name = + let uu___ = is_standard_constructor ctor in + if uu___ + then + let uu___1 = + let uu___2 = as_standard_constructor ctor in + FStarC_Compiler_Option.get uu___2 in + FStar_Pervasives_Native.snd uu___1 + else ptctor currentModule ctor in + let args1 = + FStarC_Compiler_List.map + (doc_of_expr currentModule (min_op_prec, NonAssoc)) args in + let doc1 = + match (name, args1) with + | ("::", x::xs::[]) -> reduce [parens x; text "::"; xs] + | (uu___, uu___1) -> + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = combine (text ", ") args1 in + parens uu___5 in + [uu___4] in + (text name) :: uu___3 in + reduce1 uu___2 in + maybe_paren outer e_app_prio doc1 + | FStarC_Extraction_ML_Syntax.MLE_Tuple es -> + let docs = + FStarC_Compiler_List.map + (fun x -> + let uu___ = + doc_of_expr currentModule (min_op_prec, NonAssoc) x in + parens uu___) es in + let docs1 = let uu___ = combine (text ", ") docs in parens uu___ in + docs1 + | FStarC_Extraction_ML_Syntax.MLE_Let ((rec_, lets), body) -> + let pre = + if + e.FStarC_Extraction_ML_Syntax.loc <> + FStarC_Extraction_ML_Syntax.dummy_loc + then + let uu___ = + let uu___1 = + let uu___2 = doc_of_loc e.FStarC_Extraction_ML_Syntax.loc in + [uu___2] in + hardline :: uu___1 in + reduce uu___ + else empty in + let doc1 = doc_of_lets currentModule (rec_, false, lets) in + let body1 = + doc_of_expr currentModule (min_op_prec, NonAssoc) body in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = reduce1 [text "in"; body1] in [uu___4] in + doc1 :: uu___3 in + pre :: uu___2 in + combine hardline uu___1 in + parens uu___ + | FStarC_Extraction_ML_Syntax.MLE_App (e1, args) -> + (match ((e1.FStarC_Extraction_ML_Syntax.expr), args) with + | (FStarC_Extraction_ML_Syntax.MLE_Name p, + { + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Fun + (uu___::[], scrutinee); + FStarC_Extraction_ML_Syntax.mlty = uu___1; + FStarC_Extraction_ML_Syntax.loc = uu___2;_}::{ + FStarC_Extraction_ML_Syntax.expr + = + FStarC_Extraction_ML_Syntax.MLE_Fun + ({ + FStarC_Extraction_ML_Syntax.mlbinder_name + = arg; + FStarC_Extraction_ML_Syntax.mlbinder_ty + = uu___3; + FStarC_Extraction_ML_Syntax.mlbinder_attrs + = uu___4;_}::[], + possible_match); + FStarC_Extraction_ML_Syntax.mlty + = uu___5; + FStarC_Extraction_ML_Syntax.loc + = uu___6;_}::[]) + when + (let uu___7 = FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___7 = "FStarC.Compiler.Effect.try_with") || + (let uu___7 = + FStarC_Extraction_ML_Syntax.string_of_mlpath p in + uu___7 = "FStar.All.try_with") + -> + let branches = + match possible_match with + | { + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Match + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Var arg'; + FStarC_Extraction_ML_Syntax.mlty = uu___7; + FStarC_Extraction_ML_Syntax.loc = uu___8;_}, + branches1); + FStarC_Extraction_ML_Syntax.mlty = uu___9; + FStarC_Extraction_ML_Syntax.loc = uu___10;_} when + arg = arg' -> branches1 + | e2 -> + [(FStarC_Extraction_ML_Syntax.MLP_Wild, + FStar_Pervasives_Native.None, e2)] in + doc_of_expr currentModule outer + { + FStarC_Extraction_ML_Syntax.expr = + (FStarC_Extraction_ML_Syntax.MLE_Try + (scrutinee, branches)); + FStarC_Extraction_ML_Syntax.mlty = + (possible_match.FStarC_Extraction_ML_Syntax.mlty); + FStarC_Extraction_ML_Syntax.loc = + (possible_match.FStarC_Extraction_ML_Syntax.loc) + } + | (FStarC_Extraction_ML_Syntax.MLE_Name p, e11::e2::[]) when + is_bin_op p -> doc_of_binop currentModule p e11 e2 + | (FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + unitVal::[]), + e11::e2::[]) when + (is_bin_op p) && + (unitVal = FStarC_Extraction_ML_Syntax.ml_unit) + -> doc_of_binop currentModule p e11 e2 + | (FStarC_Extraction_ML_Syntax.MLE_Name p, e11::[]) when + is_uni_op p -> doc_of_uniop currentModule p e11 + | (FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name p; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + unitVal::[]), + e11::[]) when + (is_uni_op p) && + (unitVal = FStarC_Extraction_ML_Syntax.ml_unit) + -> doc_of_uniop currentModule p e11 + | uu___ -> + let e2 = doc_of_expr currentModule (e_app_prio, ILeft) e1 in + let args1 = + FStarC_Compiler_List.map + (doc_of_expr currentModule (e_app_prio, IRight)) args in + let uu___1 = reduce1 (e2 :: args1) in parens uu___1) + | FStarC_Extraction_ML_Syntax.MLE_Proj (e1, f) -> + let e2 = doc_of_expr currentModule (min_op_prec, NonAssoc) e1 in + let doc1 = + let uu___ = FStarC_Extraction_ML_Util.codegen_fsharp () in + if uu___ + then + reduce [e2; text "."; text (FStar_Pervasives_Native.snd f)] + else + (let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = ptsym currentModule f in text uu___6 in + [uu___5] in + (text ".") :: uu___4 in + e2 :: uu___3 in + reduce uu___2) in + doc1 + | FStarC_Extraction_ML_Syntax.MLE_Fun (ids, body) -> + let bvar_annot x xt = + let uu___ = FStarC_Extraction_ML_Util.codegen_fsharp () in + if uu___ + then + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + match xt with + | FStar_Pervasives_Native.Some xxt -> + let uu___5 = + let uu___6 = + let uu___7 = + doc_of_mltype currentModule outer xxt in + [uu___7] in + (text " : ") :: uu___6 in + reduce1 uu___5 + | uu___5 -> text "" in + [uu___4; text ")"] in + (text x) :: uu___3 in + (text "(") :: uu___2 in + reduce1 uu___1 + else text x in + let ids1 = + FStarC_Compiler_List.map + (fun uu___ -> + match uu___ with + | { FStarC_Extraction_ML_Syntax.mlbinder_name = x; + FStarC_Extraction_ML_Syntax.mlbinder_ty = xt; + FStarC_Extraction_ML_Syntax.mlbinder_attrs = uu___1;_} + -> bvar_annot x (FStar_Pervasives_Native.Some xt)) ids in + let body1 = + doc_of_expr currentModule (min_op_prec, NonAssoc) body in + let doc1 = + let uu___ = + let uu___1 = + let uu___2 = reduce1 ids1 in [uu___2; text "->"; body1] in + (text "fun") :: uu___1 in + reduce1 uu___ in + parens doc1 + | FStarC_Extraction_ML_Syntax.MLE_If + (cond, e1, FStar_Pervasives_Native.None) -> + let cond1 = + doc_of_expr currentModule (min_op_prec, NonAssoc) cond in + let doc1 = + let uu___ = + let uu___1 = + reduce1 [text "if"; cond1; text "then"; text "begin"] in + let uu___2 = + let uu___3 = + doc_of_expr currentModule (min_op_prec, NonAssoc) e1 in + [uu___3; text "end"] in + uu___1 :: uu___2 in + combine hardline uu___ in + maybe_paren outer e_bin_prio_if doc1 + | FStarC_Extraction_ML_Syntax.MLE_If + (cond, e1, FStar_Pervasives_Native.Some e2) -> + let cond1 = + doc_of_expr currentModule (min_op_prec, NonAssoc) cond in + let doc1 = + let uu___ = + let uu___1 = + reduce1 [text "if"; cond1; text "then"; text "begin"] in + let uu___2 = + let uu___3 = + doc_of_expr currentModule (min_op_prec, NonAssoc) e1 in + let uu___4 = + let uu___5 = + reduce1 [text "end"; text "else"; text "begin"] in + let uu___6 = + let uu___7 = + doc_of_expr currentModule (min_op_prec, NonAssoc) e2 in + [uu___7; text "end"] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + combine hardline uu___ in + maybe_paren outer e_bin_prio_if doc1 + | FStarC_Extraction_ML_Syntax.MLE_Match (cond, pats) -> + let cond1 = + doc_of_expr currentModule (min_op_prec, NonAssoc) cond in + let pats1 = + FStarC_Compiler_List.map (doc_of_branch currentModule) pats in + let doc1 = + let uu___ = reduce1 [text "match"; parens cond1; text "with"] in + uu___ :: pats1 in + let doc2 = combine hardline doc1 in parens doc2 + | FStarC_Extraction_ML_Syntax.MLE_Raise (exn, []) -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = ptctor currentModule exn in text uu___3 in + [uu___2] in + (text "raise") :: uu___1 in + reduce1 uu___ + | FStarC_Extraction_ML_Syntax.MLE_Raise (exn, args) -> + let args1 = + FStarC_Compiler_List.map + (doc_of_expr currentModule (min_op_prec, NonAssoc)) args in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = ptctor currentModule exn in text uu___3 in + let uu___3 = + let uu___4 = + let uu___5 = combine (text ", ") args1 in parens uu___5 in + [uu___4] in + uu___2 :: uu___3 in + (text "raise") :: uu___1 in + reduce1 uu___ + | FStarC_Extraction_ML_Syntax.MLE_Try (e1, pats) -> + let uu___ = + let uu___1 = + let uu___2 = + doc_of_expr currentModule (min_op_prec, NonAssoc) e1 in + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Compiler_List.map + (doc_of_branch currentModule) pats in + combine hardline uu___6 in + [uu___5] in + (text "with") :: uu___4 in + uu___2 :: uu___3 in + (text "try") :: uu___1 in + combine hardline uu___ + | FStarC_Extraction_ML_Syntax.MLE_TApp (head, ty_args) -> + doc_of_expr currentModule outer head +and (doc_of_binop : + FStarC_Extraction_ML_Syntax.mlsymbol -> + FStarC_Extraction_ML_Syntax.mlpath -> + FStarC_Extraction_ML_Syntax.mlexpr -> + FStarC_Extraction_ML_Syntax.mlexpr -> doc) + = + fun currentModule -> + fun p -> + fun e1 -> + fun e2 -> + let uu___ = + let uu___1 = as_bin_op p in FStarC_Compiler_Option.get uu___1 in + match uu___ with + | (uu___1, prio, txt) -> + let e11 = doc_of_expr currentModule (prio, Left) e1 in + let e21 = doc_of_expr currentModule (prio, Right) e2 in + let doc1 = reduce1 [e11; text txt; e21] in parens doc1 +and (doc_of_uniop : + FStarC_Extraction_ML_Syntax.mlsymbol -> + FStarC_Extraction_ML_Syntax.mlpath -> + FStarC_Extraction_ML_Syntax.mlexpr -> doc) + = + fun currentModule -> + fun p -> + fun e1 -> + let uu___ = + let uu___1 = as_uni_op p in FStarC_Compiler_Option.get uu___1 in + match uu___ with + | (uu___1, txt) -> + let e11 = doc_of_expr currentModule (min_op_prec, NonAssoc) e1 in + let doc1 = reduce1 [text txt; parens e11] in parens doc1 +and (doc_of_pattern : + FStarC_Extraction_ML_Syntax.mlsymbol -> + FStarC_Extraction_ML_Syntax.mlpattern -> doc) + = + fun currentModule -> + fun pattern -> + match pattern with + | FStarC_Extraction_ML_Syntax.MLP_Wild -> text "_" + | FStarC_Extraction_ML_Syntax.MLP_Const c -> + let uu___ = string_of_mlconstant c in text uu___ + | FStarC_Extraction_ML_Syntax.MLP_Var x -> text x + | FStarC_Extraction_ML_Syntax.MLP_Record (path, fields) -> + let for1 uu___ = + match uu___ with + | (name, p) -> + let uu___1 = + let uu___2 = + let uu___3 = ptsym currentModule (path, name) in + text uu___3 in + let uu___3 = + let uu___4 = + let uu___5 = doc_of_pattern currentModule p in [uu___5] in + (text "=") :: uu___4 in + uu___2 :: uu___3 in + reduce1 uu___1 in + let uu___ = + let uu___1 = FStarC_Compiler_List.map for1 fields in + combine (text "; ") uu___1 in + cbrackets uu___ + | FStarC_Extraction_ML_Syntax.MLP_CTor (ctor, []) -> + let name = + let uu___ = is_standard_constructor ctor in + if uu___ + then + let uu___1 = + let uu___2 = as_standard_constructor ctor in + FStarC_Compiler_Option.get uu___2 in + FStar_Pervasives_Native.snd uu___1 + else ptctor currentModule ctor in + text name + | FStarC_Extraction_ML_Syntax.MLP_CTor (ctor, pats) -> + let name = + let uu___ = is_standard_constructor ctor in + if uu___ + then + let uu___1 = + let uu___2 = as_standard_constructor ctor in + FStarC_Compiler_Option.get uu___2 in + FStar_Pervasives_Native.snd uu___1 + else ptctor currentModule ctor in + let doc1 = + match (name, pats) with + | ("::", x::xs::[]) -> + let uu___ = + let uu___1 = + let uu___2 = doc_of_pattern currentModule x in + parens uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = doc_of_pattern currentModule xs in + [uu___4] in + (text "::") :: uu___3 in + uu___1 :: uu___2 in + reduce uu___ + | (uu___, (FStarC_Extraction_ML_Syntax.MLP_Tuple uu___1)::[]) -> + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Compiler_List.hd pats in + doc_of_pattern currentModule uu___5 in + [uu___4] in + (text name) :: uu___3 in + reduce1 uu___2 + | uu___ -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Compiler_List.map + (doc_of_pattern currentModule) pats in + combine (text ", ") uu___5 in + parens uu___4 in + [uu___3] in + (text name) :: uu___2 in + reduce1 uu___1 in + maybe_paren (min_op_prec, NonAssoc) e_app_prio doc1 + | FStarC_Extraction_ML_Syntax.MLP_Tuple ps -> + let ps1 = + FStarC_Compiler_List.map (doc_of_pattern currentModule) ps in + let uu___ = combine (text ", ") ps1 in parens uu___ + | FStarC_Extraction_ML_Syntax.MLP_Branch ps -> + let ps1 = + FStarC_Compiler_List.map (doc_of_pattern currentModule) ps in + let ps2 = FStarC_Compiler_List.map parens ps1 in + combine (text " | ") ps2 +and (doc_of_branch : + FStarC_Extraction_ML_Syntax.mlsymbol -> + FStarC_Extraction_ML_Syntax.mlbranch -> doc) + = + fun currentModule -> + fun uu___ -> + match uu___ with + | (p, cond, e) -> + let case = + match cond with + | FStar_Pervasives_Native.None -> + let uu___1 = + let uu___2 = + let uu___3 = doc_of_pattern currentModule p in [uu___3] in + (text "|") :: uu___2 in + reduce1 uu___1 + | FStar_Pervasives_Native.Some c -> + let c1 = doc_of_expr currentModule (min_op_prec, NonAssoc) c in + let uu___1 = + let uu___2 = + let uu___3 = doc_of_pattern currentModule p in + [uu___3; text "when"; c1] in + (text "|") :: uu___2 in + reduce1 uu___1 in + let uu___1 = + let uu___2 = reduce1 [case; text "->"; text "begin"] in + let uu___3 = + let uu___4 = + doc_of_expr currentModule (min_op_prec, NonAssoc) e in + [uu___4; text "end"] in + uu___2 :: uu___3 in + combine hardline uu___1 +and (doc_of_lets : + FStarC_Extraction_ML_Syntax.mlsymbol -> + (FStarC_Extraction_ML_Syntax.mlletflavor * Prims.bool * + FStarC_Extraction_ML_Syntax.mllb Prims.list) -> doc) + = + fun currentModule -> + fun uu___ -> + match uu___ with + | (rec_, top_level, lets) -> + let for1 uu___1 = + match uu___1 with + | { FStarC_Extraction_ML_Syntax.mllb_name = name; + FStarC_Extraction_ML_Syntax.mllb_tysc = tys; + FStarC_Extraction_ML_Syntax.mllb_add_unit = uu___2; + FStarC_Extraction_ML_Syntax.mllb_def = e; + FStarC_Extraction_ML_Syntax.mllb_attrs = uu___3; + FStarC_Extraction_ML_Syntax.mllb_meta = uu___4; + FStarC_Extraction_ML_Syntax.print_typ = pt;_} -> + let e1 = doc_of_expr currentModule (min_op_prec, NonAssoc) e in + let ids = [] in + let ty_annot = + if Prims.op_Negation pt + then text "" + else + (let uu___6 = + (FStarC_Extraction_ML_Util.codegen_fsharp ()) && + ((rec_ = FStarC_Extraction_ML_Syntax.Rec) || + top_level) in + if uu___6 + then + match tys with + | FStar_Pervasives_Native.Some + (uu___7::uu___8, uu___9) -> text "" + | FStar_Pervasives_Native.None -> text "" + | FStar_Pervasives_Native.Some ([], ty) -> + let ty1 = + doc_of_mltype currentModule + (min_op_prec, NonAssoc) ty in + reduce1 [text ":"; ty1] + else + if top_level + then + (match tys with + | FStar_Pervasives_Native.None -> text "" + | FStar_Pervasives_Native.Some ([], ty) -> + let ty1 = + doc_of_mltype currentModule + (min_op_prec, NonAssoc) ty in + reduce1 [text ":"; ty1] + | FStar_Pervasives_Native.Some (vs, ty) -> + let ty1 = + doc_of_mltype currentModule + (min_op_prec, NonAssoc) ty in + let vars = + let uu___8 = + let uu___9 = + FStarC_Extraction_ML_Syntax.ty_param_names + vs in + FStarC_Compiler_List.map + (fun x -> + doc_of_mltype currentModule + (min_op_prec, NonAssoc) + (FStarC_Extraction_ML_Syntax.MLTY_Var + x)) uu___9 in + reduce1 uu___8 in + reduce1 [text ":"; vars; text "."; ty1]) + else text "") in + let uu___5 = + let uu___6 = + let uu___7 = reduce1 ids in + [uu___7; ty_annot; text "="; e1] in + (text name) :: uu___6 in + reduce1 uu___5 in + let letdoc = + if rec_ = FStarC_Extraction_ML_Syntax.Rec + then reduce1 [text "let"; text "rec"] + else text "let" in + let lets1 = FStarC_Compiler_List.map for1 lets in + let lets2 = + FStarC_Compiler_List.mapi + (fun i -> + fun doc1 -> + reduce1 + [if i = Prims.int_zero then letdoc else text "and"; + doc1]) lets1 in + combine hardline lets2 +and (doc_of_loc : FStarC_Extraction_ML_Syntax.mlloc -> doc) = + fun uu___ -> + match uu___ with + | (lineno, file) -> + let uu___1 = + ((FStarC_Options.no_location_info ()) || + (FStarC_Extraction_ML_Util.codegen_fsharp ())) + || (file = " dummy") in + if uu___1 + then empty + else + (let file1 = FStarC_Compiler_Util.basename file in + let uu___3 = + let uu___4 = + let uu___5 = num lineno in + [uu___5; text (Prims.strcat "\"" (Prims.strcat file1 "\""))] in + (text "#") :: uu___4 in + reduce1 uu___3) +let (doc_of_mltydecl : + FStarC_Extraction_ML_Syntax.mlsymbol -> + FStarC_Extraction_ML_Syntax.mltydecl -> doc) + = + fun currentModule -> + fun decls -> + let for1 uu___ = + match uu___ with + | { FStarC_Extraction_ML_Syntax.tydecl_assumed = uu___1; + FStarC_Extraction_ML_Syntax.tydecl_name = x; + FStarC_Extraction_ML_Syntax.tydecl_ignored = mangle_opt; + FStarC_Extraction_ML_Syntax.tydecl_parameters = tparams; + FStarC_Extraction_ML_Syntax.tydecl_meta = uu___2; + FStarC_Extraction_ML_Syntax.tydecl_defn = body;_} -> + let x1 = + match mangle_opt with + | FStar_Pervasives_Native.None -> x + | FStar_Pervasives_Native.Some y -> y in + let tparams1 = + let tparams2 = + FStarC_Extraction_ML_Syntax.ty_param_names tparams in + match tparams2 with + | [] -> empty + | x2::[] -> text x2 + | uu___3 -> + let doc1 = + FStarC_Compiler_List.map (fun x2 -> text x2) tparams2 in + let uu___4 = combine (text ", ") doc1 in parens uu___4 in + let forbody body1 = + match body1 with + | FStarC_Extraction_ML_Syntax.MLTD_Abbrev ty -> + doc_of_mltype currentModule (min_op_prec, NonAssoc) ty + | FStarC_Extraction_ML_Syntax.MLTD_Record fields -> + let forfield uu___3 = + match uu___3 with + | (name, ty) -> + let name1 = text name in + let ty1 = + doc_of_mltype currentModule (min_op_prec, NonAssoc) + ty in + reduce1 [name1; text ":"; ty1] in + let uu___3 = + let uu___4 = FStarC_Compiler_List.map forfield fields in + combine (text "; ") uu___4 in + cbrackets uu___3 + | FStarC_Extraction_ML_Syntax.MLTD_DType ctors -> + let forctor uu___3 = + match uu___3 with + | (name, tys) -> + let uu___4 = FStarC_Compiler_List.split tys in + (match uu___4 with + | (_names, tys1) -> + (match tys1 with + | [] -> text name + | uu___5 -> + let tys2 = + FStarC_Compiler_List.map + (doc_of_mltype currentModule + (t_prio_tpl, Left)) tys1 in + let tys3 = combine (text " * ") tys2 in + reduce1 [text name; text "of"; tys3])) in + let ctors1 = FStarC_Compiler_List.map forctor ctors in + let ctors2 = + FStarC_Compiler_List.map (fun d -> reduce1 [text "|"; d]) + ctors1 in + combine hardline ctors2 in + let doc1 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = ptsym currentModule ([], x1) in text uu___6 in + [uu___5] in + tparams1 :: uu___4 in + reduce1 uu___3 in + (match body with + | FStar_Pervasives_Native.None -> doc1 + | FStar_Pervasives_Native.Some body1 -> + let body2 = forbody body1 in + let uu___3 = + let uu___4 = reduce1 [doc1; text "="] in [uu___4; body2] in + combine hardline uu___3) in + let doc1 = FStarC_Compiler_List.map for1 decls in + let doc2 = + if (FStarC_Compiler_List.length doc1) > Prims.int_zero + then + let uu___ = + let uu___1 = + let uu___2 = combine (text " \n and ") doc1 in [uu___2] in + (text "type") :: uu___1 in + reduce1 uu___ + else text "" in + doc2 +let rec (doc_of_sig1 : + FStarC_Extraction_ML_Syntax.mlsymbol -> + FStarC_Extraction_ML_Syntax.mlsig1 -> doc) + = + fun currentModule -> + fun s -> + match s with + | FStarC_Extraction_ML_Syntax.MLS_Mod (x, subsig) -> + let uu___ = + let uu___1 = reduce1 [text "module"; text x; text "="] in + let uu___2 = + let uu___3 = doc_of_sig currentModule subsig in + let uu___4 = let uu___5 = reduce1 [text "end"] in [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + combine hardline uu___ + | FStarC_Extraction_ML_Syntax.MLS_Exn (x, []) -> + reduce1 [text "exception"; text x] + | FStarC_Extraction_ML_Syntax.MLS_Exn (x, args) -> + let args1 = + FStarC_Compiler_List.map + (doc_of_mltype currentModule (min_op_prec, NonAssoc)) args in + let args2 = let uu___ = combine (text " * ") args1 in parens uu___ in + reduce1 [text "exception"; text x; text "of"; args2] + | FStarC_Extraction_ML_Syntax.MLS_Val (x, (uu___, ty)) -> + let ty1 = doc_of_mltype currentModule (min_op_prec, NonAssoc) ty in + reduce1 [text "val"; text x; text ": "; ty1] + | FStarC_Extraction_ML_Syntax.MLS_Ty decls -> + doc_of_mltydecl currentModule decls +and (doc_of_sig : + FStarC_Extraction_ML_Syntax.mlsymbol -> + FStarC_Extraction_ML_Syntax.mlsig -> doc) + = + fun currentModule -> + fun s -> + let docs = FStarC_Compiler_List.map (doc_of_sig1 currentModule) s in + let docs1 = + FStarC_Compiler_List.map (fun x -> reduce [x; hardline; hardline]) + docs in + reduce docs1 +let (doc_of_mod1 : + FStarC_Extraction_ML_Syntax.mlsymbol -> + FStarC_Extraction_ML_Syntax.mlmodule1 -> doc) + = + fun currentModule -> + fun m -> + match m.FStarC_Extraction_ML_Syntax.mlmodule1_m with + | FStarC_Extraction_ML_Syntax.MLM_Exn (x, []) -> + reduce1 [text "exception"; text x] + | FStarC_Extraction_ML_Syntax.MLM_Exn (x, args) -> + let args1 = + FStarC_Compiler_List.map FStar_Pervasives_Native.snd args in + let args2 = + FStarC_Compiler_List.map + (doc_of_mltype currentModule (min_op_prec, NonAssoc)) args1 in + let args3 = let uu___ = combine (text " * ") args2 in parens uu___ in + reduce1 [text "exception"; text x; text "of"; args3] + | FStarC_Extraction_ML_Syntax.MLM_Ty decls -> + doc_of_mltydecl currentModule decls + | FStarC_Extraction_ML_Syntax.MLM_Let (rec_, lets) -> + doc_of_lets currentModule (rec_, true, lets) + | FStarC_Extraction_ML_Syntax.MLM_Top e -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + doc_of_expr currentModule (min_op_prec, NonAssoc) e in + [uu___4] in + (text "=") :: uu___3 in + (text "_") :: uu___2 in + (text "let") :: uu___1 in + reduce1 uu___ + | FStarC_Extraction_ML_Syntax.MLM_Loc loc -> doc_of_loc loc +let (doc_of_mod : + FStarC_Extraction_ML_Syntax.mlsymbol -> + FStarC_Extraction_ML_Syntax.mlmodule -> doc) + = + fun currentModule -> + fun m -> + let docs = + FStarC_Compiler_List.map + (fun x -> + let doc1 = doc_of_mod1 currentModule x in + [doc1; + (match x.FStarC_Extraction_ML_Syntax.mlmodule1_m with + | FStarC_Extraction_ML_Syntax.MLM_Loc uu___ -> empty + | uu___ -> hardline); + hardline]) m in + reduce (FStarC_Compiler_List.flatten docs) +let (doc_of_mllib_r : + FStarC_Extraction_ML_Syntax.mllib -> (Prims.string * doc) Prims.list) = + fun uu___ -> + match uu___ with + | FStarC_Extraction_ML_Syntax.MLLib mllib -> + let rec for1_sig uu___1 = + match uu___1 with + | (x, sigmod, FStarC_Extraction_ML_Syntax.MLLib sub) -> + let x1 = FStarC_Extraction_ML_Util.flatten_mlpath x in + let head = + reduce1 [text "module"; text x1; text ":"; text "sig"] in + let tail = reduce1 [text "end"] in + let doc1 = + FStarC_Compiler_Option.map + (fun uu___2 -> + match uu___2 with | (s, uu___3) -> doc_of_sig x1 s) + sigmod in + let sub1 = FStarC_Compiler_List.map for1_sig sub in + let sub2 = + FStarC_Compiler_List.map + (fun x2 -> reduce [x2; hardline; hardline]) sub1 in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = reduce sub2 in [uu___5; cat tail hardline] in + (match doc1 with + | FStar_Pervasives_Native.None -> empty + | FStar_Pervasives_Native.Some s -> cat s hardline) :: + uu___4 in + (cat head hardline) :: uu___3 in + reduce uu___2 + and for1_mod istop uu___1 = + match uu___1 with + | (mod_name, sigmod, FStarC_Extraction_ML_Syntax.MLLib sub) -> + let target_mod_name = + FStarC_Extraction_ML_Util.flatten_mlpath mod_name in + let maybe_open_pervasives = + match mod_name with + | ("FStar"::[], "Pervasives") -> [] + | uu___2 -> + let pervasives = + FStarC_Extraction_ML_Util.flatten_mlpath + (["FStar"], "Pervasives") in + [hardline; text (Prims.strcat "open " pervasives)] in + let head = + let uu___2 = + let uu___3 = FStarC_Extraction_ML_Util.codegen_fsharp () in + if uu___3 + then [text "module"; text target_mod_name] + else + if Prims.op_Negation istop + then + [text "module"; + text target_mod_name; + text "="; + text "struct"] + else [] in + reduce1 uu___2 in + let tail = + if Prims.op_Negation istop + then reduce1 [text "end"] + else reduce1 [] in + let doc1 = + FStarC_Compiler_Option.map + (fun uu___2 -> + match uu___2 with + | (uu___3, m) -> doc_of_mod target_mod_name m) sigmod in + let sub1 = FStarC_Compiler_List.map (for1_mod false) sub in + let sub2 = + FStarC_Compiler_List.map + (fun x -> reduce [x; hardline; hardline]) sub1 in + let prefix = + let uu___2 = FStarC_Extraction_ML_Util.codegen_fsharp () in + if uu___2 then [cat (text "#light \"off\"") hardline] else [] in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = reduce sub2 in + [uu___8; cat tail hardline] in + (match doc1 with + | FStar_Pervasives_Native.None -> empty + | FStar_Pervasives_Native.Some s -> cat s hardline) + :: uu___7 in + hardline :: uu___6 in + FStarC_Compiler_List.op_At maybe_open_pervasives uu___5 in + FStarC_Compiler_List.op_At + [head; hardline; text "open Prims"] uu___4 in + FStarC_Compiler_List.op_At prefix uu___3 in + reduce uu___2 in + let docs = + FStarC_Compiler_List.map + (fun uu___1 -> + match uu___1 with + | (x, s, m) -> + let uu___2 = FStarC_Extraction_ML_Util.flatten_mlpath x in + let uu___3 = for1_mod true (x, s, m) in (uu___2, uu___3)) + mllib in + docs +let (pretty : Prims.int -> doc -> Prims.string) = + fun sz -> fun uu___ -> match uu___ with | Doc doc1 -> doc1 +let (doc_of_mllib : + FStarC_Extraction_ML_Syntax.mllib -> (Prims.string * doc) Prims.list) = + fun mllib -> doc_of_mllib_r mllib +let (string_of_mlexpr : + FStarC_Extraction_ML_Syntax.mlpath -> + FStarC_Extraction_ML_Syntax.mlexpr -> Prims.string) + = + fun cmod -> + fun e -> + let doc1 = + let uu___ = FStarC_Extraction_ML_Util.flatten_mlpath cmod in + doc_of_expr uu___ (min_op_prec, NonAssoc) e in + pretty Prims.int_zero doc1 +let (string_of_mlty : + FStarC_Extraction_ML_Syntax.mlpath -> + FStarC_Extraction_ML_Syntax.mlty -> Prims.string) + = + fun cmod -> + fun e -> + let doc1 = + let uu___ = FStarC_Extraction_ML_Util.flatten_mlpath cmod in + doc_of_mltype uu___ (min_op_prec, NonAssoc) e in + pretty Prims.int_zero doc1 +let (showable_mlexpr : + FStarC_Extraction_ML_Syntax.mlexpr FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = (string_of_mlexpr ([], "")) } +let (showable_mlty : + FStarC_Extraction_ML_Syntax.mlty FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = (string_of_mlty ([], "")) } +let (showable_etag : + FStarC_Extraction_ML_Syntax.e_tag FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = string_of_etag } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Extraction_ML_Modul.ml b/ocaml/fstar-lib/generated/FStarC_Extraction_ML_Modul.ml new file mode 100644 index 00000000000..80b1942419c --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Extraction_ML_Modul.ml @@ -0,0 +1,3217 @@ +open Prims +let (dbg_ExtractionReify : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "ExtractionReify" +type tydef_declaration = + (FStarC_Extraction_ML_Syntax.mlsymbol * + FStarC_Extraction_ML_Syntax.metadata * Prims.int) +type iface = + { + iface_module_name: FStarC_Extraction_ML_Syntax.mlpath ; + iface_bindings: + (FStarC_Syntax_Syntax.fv * FStarC_Extraction_ML_UEnv.exp_binding) + Prims.list + ; + iface_tydefs: + (FStarC_Extraction_ML_UEnv.tydef, tydef_declaration) + FStar_Pervasives.either Prims.list + ; + iface_type_names: + (FStarC_Syntax_Syntax.fv * FStarC_Extraction_ML_Syntax.mlpath) Prims.list } +let (__proj__Mkiface__item__iface_module_name : + iface -> FStarC_Extraction_ML_Syntax.mlpath) = + fun projectee -> + match projectee with + | { iface_module_name; iface_bindings; iface_tydefs; iface_type_names;_} + -> iface_module_name +let (__proj__Mkiface__item__iface_bindings : + iface -> + (FStarC_Syntax_Syntax.fv * FStarC_Extraction_ML_UEnv.exp_binding) + Prims.list) + = + fun projectee -> + match projectee with + | { iface_module_name; iface_bindings; iface_tydefs; iface_type_names;_} + -> iface_bindings +let (__proj__Mkiface__item__iface_tydefs : + iface -> + (FStarC_Extraction_ML_UEnv.tydef, tydef_declaration) + FStar_Pervasives.either Prims.list) + = + fun projectee -> + match projectee with + | { iface_module_name; iface_bindings; iface_tydefs; iface_type_names;_} + -> iface_tydefs +let (__proj__Mkiface__item__iface_type_names : + iface -> + (FStarC_Syntax_Syntax.fv * FStarC_Extraction_ML_Syntax.mlpath) Prims.list) + = + fun projectee -> + match projectee with + | { iface_module_name; iface_bindings; iface_tydefs; iface_type_names;_} + -> iface_type_names +type extension_sigelt_extractor = + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.sigelt -> + FStarC_Dyn.dyn -> + (FStarC_Extraction_ML_Syntax.mlmodule, Prims.string) + FStar_Pervasives.either +type extension_sigelt_iface_extractor = + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.sigelt -> + FStarC_Dyn.dyn -> + ((FStarC_Extraction_ML_UEnv.uenv * iface), Prims.string) + FStar_Pervasives.either +type extension_extractor = + { + extract_sigelt: extension_sigelt_extractor ; + extract_sigelt_iface: extension_sigelt_iface_extractor } +let (__proj__Mkextension_extractor__item__extract_sigelt : + extension_extractor -> extension_sigelt_extractor) = + fun projectee -> + match projectee with + | { extract_sigelt; extract_sigelt_iface;_} -> extract_sigelt +let (__proj__Mkextension_extractor__item__extract_sigelt_iface : + extension_extractor -> extension_sigelt_iface_extractor) = + fun projectee -> + match projectee with + | { extract_sigelt; extract_sigelt_iface;_} -> extract_sigelt_iface +let (extension_extractor_table : + extension_extractor FStarC_Compiler_Util.smap) = + FStarC_Compiler_Util.smap_create (Prims.of_int (20)) +let (register_extension_extractor : + Prims.string -> extension_extractor -> unit) = + fun ext -> + fun callback -> + FStarC_Compiler_Util.smap_add extension_extractor_table ext callback +let (lookup_extension_extractor : + Prims.string -> extension_extractor FStar_Pervasives_Native.option) = + fun ext -> + let do1 uu___ = + FStarC_Compiler_Util.smap_try_find extension_extractor_table ext in + let uu___ = do1 () in + match uu___ with + | FStar_Pervasives_Native.None -> + let uu___1 = FStarC_Compiler_Plugins.autoload_plugin ext in + if uu___1 then do1 () else FStar_Pervasives_Native.None + | r -> r +type env_t = FStarC_Extraction_ML_UEnv.uenv +let (fail_exp : + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun lid -> + fun t -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Parser_Const.failwith_lid () in + FStarC_Syntax_Syntax.fvar uu___3 FStar_Pervasives_Native.None in + let uu___3 = + let uu___4 = FStarC_Syntax_Syntax.iarg t in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident lid in + Prims.strcat "Not yet implemented: " uu___12 in + (uu___11, FStarC_Compiler_Range_Type.dummyRange) in + FStarC_Const.Const_string uu___10 in + FStarC_Syntax_Syntax.Tm_constant uu___9 in + FStarC_Syntax_Syntax.mk uu___8 + FStarC_Compiler_Range_Type.dummyRange in + FStarC_Syntax_Syntax.as_arg uu___7 in + [uu___6] in + uu___4 :: uu___5 in + { + FStarC_Syntax_Syntax.hd = uu___2; + FStarC_Syntax_Syntax.args = uu___3 + } in + FStarC_Syntax_Syntax.Tm_app uu___1 in + FStarC_Syntax_Syntax.mk uu___ FStarC_Compiler_Range_Type.dummyRange +let (always_fail : + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.letbinding) + = + fun lid -> + fun t -> + let imp = + let uu___ = FStarC_Syntax_Util.arrow_formals t in + match uu___ with + | ([], t1) -> + let b = + let uu___1 = + FStarC_Syntax_Syntax.gen_bv "_" FStar_Pervasives_Native.None + t1 in + FStarC_Syntax_Syntax.mk_binder uu___1 in + let uu___1 = fail_exp lid t1 in + FStarC_Syntax_Util.abs [b] uu___1 FStar_Pervasives_Native.None + | (bs, t1) -> + let uu___1 = fail_exp lid t1 in + FStarC_Syntax_Util.abs bs uu___1 FStar_Pervasives_Native.None in + let lb = + let uu___ = + let uu___1 = + FStarC_Syntax_Syntax.lid_as_fv lid FStar_Pervasives_Native.None in + FStar_Pervasives.Inr uu___1 in + let uu___1 = FStarC_Parser_Const.effect_ML_lid () in + { + FStarC_Syntax_Syntax.lbname = uu___; + FStarC_Syntax_Syntax.lbunivs = []; + FStarC_Syntax_Syntax.lbtyp = t; + FStarC_Syntax_Syntax.lbeff = uu___1; + FStarC_Syntax_Syntax.lbdef = imp; + FStarC_Syntax_Syntax.lbattrs = []; + FStarC_Syntax_Syntax.lbpos = (imp.FStarC_Syntax_Syntax.pos) + } in + lb +let as_pair : 'uuuuu . 'uuuuu Prims.list -> ('uuuuu * 'uuuuu) = + fun uu___ -> + match uu___ with + | a::b::[] -> (a, b) + | uu___1 -> failwith "Expected a list with 2 elements" +let (flag_of_qual : + FStarC_Syntax_Syntax.qualifier -> + FStarC_Extraction_ML_Syntax.meta FStar_Pervasives_Native.option) + = + fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.Assumption -> + FStar_Pervasives_Native.Some FStarC_Extraction_ML_Syntax.Assumed + | FStarC_Syntax_Syntax.Private -> + FStar_Pervasives_Native.Some FStarC_Extraction_ML_Syntax.Private + | FStarC_Syntax_Syntax.NoExtract -> + FStar_Pervasives_Native.Some FStarC_Extraction_ML_Syntax.NoExtract + | uu___1 -> FStar_Pervasives_Native.None +let rec (extract_meta : + FStarC_Syntax_Syntax.term -> + FStarC_Extraction_ML_Syntax.meta FStar_Pervasives_Native.option) + = + fun x -> + let uu___ = FStarC_Syntax_Subst.compress x in + match uu___ with + | { FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar fv; + FStarC_Syntax_Syntax.pos = uu___1; + FStarC_Syntax_Syntax.vars = uu___2; + FStarC_Syntax_Syntax.hash_code = uu___3;_} -> + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.lid_of_fv fv in + FStarC_Ident.string_of_lid uu___5 in + (match uu___4 with + | "FStar.Pervasives.PpxDerivingShow" -> + FStar_Pervasives_Native.Some + FStarC_Extraction_ML_Syntax.PpxDerivingShow + | "FStar.Pervasives.PpxDerivingYoJson" -> + FStar_Pervasives_Native.Some + FStarC_Extraction_ML_Syntax.PpxDerivingYoJson + | "FStar.Pervasives.CInline" -> + FStar_Pervasives_Native.Some FStarC_Extraction_ML_Syntax.CInline + | "FStar.Pervasives.CNoInline" -> + FStar_Pervasives_Native.Some + FStarC_Extraction_ML_Syntax.CNoInline + | "FStar.Pervasives.Substitute" -> + FStar_Pervasives_Native.Some + FStarC_Extraction_ML_Syntax.Substitute + | "FStar.Pervasives.Gc" -> + FStar_Pervasives_Native.Some FStarC_Extraction_ML_Syntax.GCType + | "FStar.Pervasives.CAbstractStruct" -> + FStar_Pervasives_Native.Some + FStarC_Extraction_ML_Syntax.CAbstract + | "FStar.Pervasives.CIfDef" -> + FStar_Pervasives_Native.Some FStarC_Extraction_ML_Syntax.CIfDef + | "FStar.Pervasives.CMacro" -> + FStar_Pervasives_Native.Some FStarC_Extraction_ML_Syntax.CMacro + | "Prims.deprecated" -> + FStar_Pervasives_Native.Some + (FStarC_Extraction_ML_Syntax.Deprecated "") + | uu___5 -> FStar_Pervasives_Native.None) + | { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar fv; + FStarC_Syntax_Syntax.pos = uu___1; + FStarC_Syntax_Syntax.vars = uu___2; + FStarC_Syntax_Syntax.hash_code = uu___3;_}; + FStarC_Syntax_Syntax.args = + ({ + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_string (s, uu___4)); + FStarC_Syntax_Syntax.pos = uu___5; + FStarC_Syntax_Syntax.vars = uu___6; + FStarC_Syntax_Syntax.hash_code = uu___7;_}, + uu___8)::[];_}; + FStarC_Syntax_Syntax.pos = uu___9; + FStarC_Syntax_Syntax.vars = uu___10; + FStarC_Syntax_Syntax.hash_code = uu___11;_} -> + let uu___12 = + let uu___13 = FStarC_Syntax_Syntax.lid_of_fv fv in + FStarC_Ident.string_of_lid uu___13 in + (match uu___12 with + | "FStar.Pervasives.PpxDerivingShowConstant" -> + FStar_Pervasives_Native.Some + (FStarC_Extraction_ML_Syntax.PpxDerivingShowConstant s) + | "FStar.Pervasives.Comment" -> + FStar_Pervasives_Native.Some + (FStarC_Extraction_ML_Syntax.Comment s) + | "FStar.Pervasives.CPrologue" -> + FStar_Pervasives_Native.Some + (FStarC_Extraction_ML_Syntax.CPrologue s) + | "FStar.Pervasives.CEpilogue" -> + FStar_Pervasives_Native.Some + (FStarC_Extraction_ML_Syntax.CEpilogue s) + | "FStar.Pervasives.CConst" -> + FStar_Pervasives_Native.Some + (FStarC_Extraction_ML_Syntax.CConst s) + | "FStar.Pervasives.CCConv" -> + FStar_Pervasives_Native.Some + (FStarC_Extraction_ML_Syntax.CCConv s) + | "Prims.deprecated" -> + FStar_Pervasives_Native.Some + (FStarC_Extraction_ML_Syntax.Deprecated s) + | uu___13 -> FStar_Pervasives_Native.None) + | { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_string ("KrmlPrivate", uu___1)); + FStarC_Syntax_Syntax.pos = uu___2; + FStarC_Syntax_Syntax.vars = uu___3; + FStarC_Syntax_Syntax.hash_code = uu___4;_} -> + FStar_Pervasives_Native.Some FStarC_Extraction_ML_Syntax.Private + | { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_string ("c_inline", uu___1)); + FStarC_Syntax_Syntax.pos = uu___2; + FStarC_Syntax_Syntax.vars = uu___3; + FStarC_Syntax_Syntax.hash_code = uu___4;_} -> + FStar_Pervasives_Native.Some FStarC_Extraction_ML_Syntax.CInline + | { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_string ("substitute", uu___1)); + FStarC_Syntax_Syntax.pos = uu___2; + FStarC_Syntax_Syntax.vars = uu___3; + FStarC_Syntax_Syntax.hash_code = uu___4;_} -> + FStar_Pervasives_Native.Some FStarC_Extraction_ML_Syntax.Substitute + | { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = x1; + FStarC_Syntax_Syntax.meta = uu___1;_}; + FStarC_Syntax_Syntax.pos = uu___2; + FStarC_Syntax_Syntax.vars = uu___3; + FStarC_Syntax_Syntax.hash_code = uu___4;_} -> extract_meta x1 + | uu___1 -> + let uu___2 = FStarC_Syntax_Util.head_and_args x in + (match uu___2 with + | (head, args) -> + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Subst.compress head in + uu___5.FStarC_Syntax_Syntax.n in + (uu___4, args) in + (match uu___3 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, uu___4::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.remove_unused_type_parameters_lid + -> + let uu___5 = + let uu___6 = + FStarC_ToSyntax_ToSyntax.parse_attr_with_list false x + FStarC_Parser_Const.remove_unused_type_parameters_lid in + FStar_Pervasives_Native.fst uu___6 in + (match uu___5 with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some l -> + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Syntax_Syntax.range_of_fv fv in + (l, uu___8) in + FStarC_Extraction_ML_Syntax.RemoveUnusedTypeParameters + uu___7 in + FStar_Pervasives_Native.Some uu___6) + | uu___4 -> FStar_Pervasives_Native.None)) +let (extract_metadata : + FStarC_Syntax_Syntax.term Prims.list -> + FStarC_Extraction_ML_Syntax.meta Prims.list) + = fun metas -> FStarC_Compiler_List.choose extract_meta metas +let (binders_as_mlty_binders : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.binder Prims.list -> + (FStarC_Extraction_ML_UEnv.uenv * FStarC_Extraction_ML_Syntax.ty_param + Prims.list)) + = + fun env -> + fun bs -> + FStarC_Compiler_Util.fold_map + (fun env1 -> + fun uu___ -> + match uu___ with + | { FStarC_Syntax_Syntax.binder_bv = bv; + FStarC_Syntax_Syntax.binder_qual = uu___1; + FStarC_Syntax_Syntax.binder_positivity = uu___2; + FStarC_Syntax_Syntax.binder_attrs = binder_attrs;_} -> + let env2 = FStarC_Extraction_ML_UEnv.extend_ty env1 bv false in + let ty_param_name = + let uu___3 = FStarC_Extraction_ML_UEnv.lookup_bv env2 bv in + match uu___3 with + | FStar_Pervasives.Inl ty -> + ty.FStarC_Extraction_ML_UEnv.ty_b_name + | uu___4 -> failwith "Impossible" in + let ty_param_attrs = + FStarC_Compiler_List.map + (fun attr -> + let uu___3 = + FStarC_Extraction_ML_Term.term_as_mlexpr env2 attr in + match uu___3 with | (e, uu___4, uu___5) -> e) + binder_attrs in + (env2, + { + FStarC_Extraction_ML_Syntax.ty_param_name = + ty_param_name; + FStarC_Extraction_ML_Syntax.ty_param_attrs = + ty_param_attrs + })) env bs +type data_constructor = + { + dname: FStarC_Ident.lident ; + dtyp: FStarC_Syntax_Syntax.typ } +let (__proj__Mkdata_constructor__item__dname : + data_constructor -> FStarC_Ident.lident) = + fun projectee -> match projectee with | { dname; dtyp;_} -> dname +let (__proj__Mkdata_constructor__item__dtyp : + data_constructor -> FStarC_Syntax_Syntax.typ) = + fun projectee -> match projectee with | { dname; dtyp;_} -> dtyp +type inductive_family = + { + ifv: FStarC_Syntax_Syntax.fv ; + iname: FStarC_Ident.lident ; + iparams: FStarC_Syntax_Syntax.binders ; + ityp: FStarC_Syntax_Syntax.term ; + idatas: data_constructor Prims.list ; + iquals: FStarC_Syntax_Syntax.qualifier Prims.list ; + imetadata: FStarC_Extraction_ML_Syntax.metadata } +let (__proj__Mkinductive_family__item__ifv : + inductive_family -> FStarC_Syntax_Syntax.fv) = + fun projectee -> + match projectee with + | { ifv; iname; iparams; ityp; idatas; iquals; imetadata;_} -> ifv +let (__proj__Mkinductive_family__item__iname : + inductive_family -> FStarC_Ident.lident) = + fun projectee -> + match projectee with + | { ifv; iname; iparams; ityp; idatas; iquals; imetadata;_} -> iname +let (__proj__Mkinductive_family__item__iparams : + inductive_family -> FStarC_Syntax_Syntax.binders) = + fun projectee -> + match projectee with + | { ifv; iname; iparams; ityp; idatas; iquals; imetadata;_} -> iparams +let (__proj__Mkinductive_family__item__ityp : + inductive_family -> FStarC_Syntax_Syntax.term) = + fun projectee -> + match projectee with + | { ifv; iname; iparams; ityp; idatas; iquals; imetadata;_} -> ityp +let (__proj__Mkinductive_family__item__idatas : + inductive_family -> data_constructor Prims.list) = + fun projectee -> + match projectee with + | { ifv; iname; iparams; ityp; idatas; iquals; imetadata;_} -> idatas +let (__proj__Mkinductive_family__item__iquals : + inductive_family -> FStarC_Syntax_Syntax.qualifier Prims.list) = + fun projectee -> + match projectee with + | { ifv; iname; iparams; ityp; idatas; iquals; imetadata;_} -> iquals +let (__proj__Mkinductive_family__item__imetadata : + inductive_family -> FStarC_Extraction_ML_Syntax.metadata) = + fun projectee -> + match projectee with + | { ifv; iname; iparams; ityp; idatas; iquals; imetadata;_} -> imetadata +let (print_ifamily : inductive_family -> unit) = + fun i -> + let uu___ = FStarC_Class_Show.show FStarC_Ident.showable_lident i.iname in + let uu___1 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list FStarC_Syntax_Print.showable_binder) + i.iparams in + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term i.ityp in + let uu___3 = + let uu___4 = + FStarC_Compiler_List.map + (fun d -> + let uu___5 = + FStarC_Class_Show.show FStarC_Ident.showable_lident d.dname in + let uu___6 = + let uu___7 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + d.dtyp in + Prims.strcat " : " uu___7 in + Prims.strcat uu___5 uu___6) i.idatas in + FStarC_Compiler_String.concat "\n\t\t" uu___4 in + FStarC_Compiler_Util.print4 "\n\t%s %s : %s { %s }\n" uu___ uu___1 uu___2 + uu___3 +let (bundle_as_inductive_families : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.sigelt Prims.list -> + FStarC_Syntax_Syntax.qualifier Prims.list -> + (FStarC_Extraction_ML_UEnv.uenv * inductive_family Prims.list)) + = + fun env -> + fun ses -> + fun quals -> + let uu___ = + FStarC_Compiler_Util.fold_map + (fun env1 -> + fun se -> + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = l; + FStarC_Syntax_Syntax.us = us; + FStarC_Syntax_Syntax.params = bs; + FStarC_Syntax_Syntax.num_uniform_params = uu___1; + FStarC_Syntax_Syntax.t = t; + FStarC_Syntax_Syntax.mutuals = uu___2; + FStarC_Syntax_Syntax.ds = datas; + FStarC_Syntax_Syntax.injective_type_params = uu___3;_} + -> + let uu___4 = FStarC_Syntax_Subst.open_univ_vars us t in + (match uu___4 with + | (_us, t1) -> + let uu___5 = FStarC_Syntax_Subst.open_term bs t1 in + (match uu___5 with + | (bs1, t2) -> + let datas1 = + FStarC_Compiler_List.collect + (fun se1 -> + match se1.FStarC_Syntax_Syntax.sigel + with + | FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = d; + FStarC_Syntax_Syntax.us1 = us1; + FStarC_Syntax_Syntax.t1 = t3; + FStarC_Syntax_Syntax.ty_lid = l'; + FStarC_Syntax_Syntax.num_ty_params + = nparams; + FStarC_Syntax_Syntax.mutuals1 = + uu___6; + FStarC_Syntax_Syntax.injective_type_params1 + = uu___7;_} + when FStarC_Ident.lid_equals l l' + -> + let uu___8 = + FStarC_Syntax_Subst.open_univ_vars + us1 t3 in + (match uu___8 with + | (_us1, t4) -> + let uu___9 = + FStarC_Syntax_Util.arrow_formals + t4 in + (match uu___9 with + | (bs', body) -> + let uu___10 = + FStarC_Compiler_Util.first_N + (FStarC_Compiler_List.length + bs1) bs' in + (match uu___10 with + | (bs_params, rest) -> + let subst = + FStarC_Compiler_List.map2 + (fun uu___11 -> + fun uu___12 + -> + match + (uu___11, + uu___12) + with + | ({ + FStarC_Syntax_Syntax.binder_bv + = b'; + FStarC_Syntax_Syntax.binder_qual + = uu___13; + FStarC_Syntax_Syntax.binder_positivity + = uu___14; + FStarC_Syntax_Syntax.binder_attrs + = uu___15;_}, + { + FStarC_Syntax_Syntax.binder_bv + = b; + FStarC_Syntax_Syntax.binder_qual + = uu___16; + FStarC_Syntax_Syntax.binder_positivity + = uu___17; + FStarC_Syntax_Syntax.binder_attrs + = uu___18;_}) + -> + let uu___19 + = + let uu___20 + = + FStarC_Syntax_Syntax.bv_to_name + b in + (b', + uu___20) in + FStarC_Syntax_Syntax.NT + uu___19) + bs_params bs1 in + let t5 = + let uu___11 = + let uu___12 = + FStarC_Syntax_Syntax.mk_Total + body in + FStarC_Syntax_Util.arrow + rest uu___12 in + FStarC_Syntax_Subst.subst + subst uu___11 in + [{ + dname = d; + dtyp = t5 + }]))) + | uu___6 -> []) ses in + let metadata = + let uu___6 = + extract_metadata + se.FStarC_Syntax_Syntax.sigattrs in + let uu___7 = + FStarC_Compiler_List.choose flag_of_qual + quals in + FStarC_Compiler_List.op_At uu___6 uu___7 in + let fv = + FStarC_Syntax_Syntax.lid_as_fv l + FStar_Pervasives_Native.None in + let uu___6 = + FStarC_Extraction_ML_UEnv.extend_type_name + env1 fv in + (match uu___6 with + | (uu___7, env2) -> + (env2, + [{ + ifv = fv; + iname = l; + iparams = bs1; + ityp = t2; + idatas = datas1; + iquals = + (se.FStarC_Syntax_Syntax.sigquals); + imetadata = metadata + }])))) + | uu___1 -> (env1, [])) env ses in + match uu___ with + | (env1, ifams) -> (env1, (FStarC_Compiler_List.flatten ifams)) +let (empty_iface : iface) = + { + iface_module_name = ([], ""); + iface_bindings = []; + iface_tydefs = []; + iface_type_names = [] + } +let (iface_of_bindings : + (FStarC_Syntax_Syntax.fv * FStarC_Extraction_ML_UEnv.exp_binding) + Prims.list -> iface) + = + fun fvs -> + { + iface_module_name = (empty_iface.iface_module_name); + iface_bindings = fvs; + iface_tydefs = (empty_iface.iface_tydefs); + iface_type_names = (empty_iface.iface_type_names) + } +let (iface_of_tydefs : FStarC_Extraction_ML_UEnv.tydef Prims.list -> iface) = + fun tds -> + let uu___ = + FStarC_Compiler_List.map (fun uu___1 -> FStar_Pervasives.Inl uu___1) + tds in + let uu___1 = + FStarC_Compiler_List.map + (fun td -> + let uu___2 = FStarC_Extraction_ML_UEnv.tydef_fv td in + let uu___3 = FStarC_Extraction_ML_UEnv.tydef_mlpath td in + (uu___2, uu___3)) tds in + { + iface_module_name = (empty_iface.iface_module_name); + iface_bindings = (empty_iface.iface_bindings); + iface_tydefs = uu___; + iface_type_names = uu___1 + } +let (iface_of_type_names : + (FStarC_Syntax_Syntax.fv * FStarC_Extraction_ML_Syntax.mlpath) Prims.list + -> iface) + = + fun fvs -> + { + iface_module_name = (empty_iface.iface_module_name); + iface_bindings = (empty_iface.iface_bindings); + iface_tydefs = (empty_iface.iface_tydefs); + iface_type_names = fvs + } +let (iface_union : iface -> iface -> iface) = + fun if1 -> + fun if2 -> + let uu___ = if1.iface_module_name in + { + iface_module_name = uu___; + iface_bindings = + (FStarC_Compiler_List.op_At if1.iface_bindings if2.iface_bindings); + iface_tydefs = + (FStarC_Compiler_List.op_At if1.iface_tydefs if2.iface_tydefs); + iface_type_names = + (FStarC_Compiler_List.op_At if1.iface_type_names + if2.iface_type_names) + } +let (iface_union_l : iface Prims.list -> iface) = + fun ifs -> FStarC_Compiler_List.fold_right iface_union ifs empty_iface +let (string_of_mlpath : FStarC_Extraction_ML_Syntax.mlpath -> Prims.string) = + fun p -> + FStarC_Compiler_String.concat ". " + (FStarC_Compiler_List.op_At (FStar_Pervasives_Native.fst p) + [FStar_Pervasives_Native.snd p]) +let tscheme_to_string : + 'uuuuu . + FStarC_Extraction_ML_Syntax.mlpath -> + ('uuuuu * FStarC_Extraction_ML_Syntax.mlty) -> Prims.string + = + fun cm -> + fun ts -> + FStarC_Extraction_ML_Code.string_of_mlty cm + (FStar_Pervasives_Native.snd ts) +let (print_exp_binding : + FStarC_Extraction_ML_Syntax.mlpath -> + FStarC_Extraction_ML_UEnv.exp_binding -> Prims.string) + = + fun cm -> + fun e -> + let uu___ = + FStarC_Extraction_ML_Code.string_of_mlexpr cm + e.FStarC_Extraction_ML_UEnv.exp_b_expr in + let uu___1 = + tscheme_to_string cm e.FStarC_Extraction_ML_UEnv.exp_b_tscheme in + FStarC_Compiler_Util.format3 + "{\n\texp_b_name = %s\n\texp_b_expr = %s\n\texp_b_tscheme = %s }" + e.FStarC_Extraction_ML_UEnv.exp_b_name uu___ uu___1 +let (print_binding : + FStarC_Extraction_ML_Syntax.mlpath -> + (FStarC_Syntax_Syntax.fv * FStarC_Extraction_ML_UEnv.exp_binding) -> + Prims.string) + = + fun cm -> + fun uu___ -> + match uu___ with + | (fv, exp_binding) -> + let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_fv fv in + let uu___2 = print_exp_binding cm exp_binding in + FStarC_Compiler_Util.format2 "(%s, %s)" uu___1 uu___2 +let print_tydef : + 'uuuuu 'uuuuu1 . + FStarC_Extraction_ML_Syntax.mlpath -> + (FStarC_Extraction_ML_UEnv.tydef, (Prims.string * 'uuuuu * 'uuuuu1)) + FStar_Pervasives.either -> Prims.string + = + fun cm -> + fun tydef -> + let uu___ = + match tydef with + | FStar_Pervasives.Inl tydef1 -> + let uu___1 = + let uu___2 = FStarC_Extraction_ML_UEnv.tydef_fv tydef1 in + FStarC_Class_Show.show FStarC_Syntax_Print.showable_fv uu___2 in + let uu___2 = + let uu___3 = FStarC_Extraction_ML_UEnv.tydef_def tydef1 in + tscheme_to_string cm uu___3 in + (uu___1, uu___2) + | FStar_Pervasives.Inr (p, uu___1, uu___2) -> (p, "None") in + match uu___ with + | (name, defn) -> FStarC_Compiler_Util.format2 "(%s, %s)" name defn +let (iface_to_string : iface -> Prims.string) = + fun iface1 -> + let cm = iface1.iface_module_name in + let print_type_name uu___ = + match uu___ with + | (tn, uu___1) -> + FStarC_Class_Show.show FStarC_Syntax_Print.showable_fv tn in + let uu___ = + let uu___1 = + FStarC_Compiler_List.map (print_binding cm) iface1.iface_bindings in + FStarC_Compiler_String.concat "\n" uu___1 in + let uu___1 = + let uu___2 = + FStarC_Compiler_List.map (print_tydef cm) iface1.iface_tydefs in + FStarC_Compiler_String.concat "\n" uu___2 in + let uu___2 = + let uu___3 = + FStarC_Compiler_List.map print_type_name iface1.iface_type_names in + FStarC_Compiler_String.concat "\n" uu___3 in + FStarC_Compiler_Util.format4 + "Interface %s = {\niface_bindings=\n%s;\n\niface_tydefs=\n%s;\n\niface_type_names=%s;\n}" + (string_of_mlpath iface1.iface_module_name) uu___ uu___1 uu___2 +let (gamma_to_string : FStarC_Extraction_ML_UEnv.uenv -> Prims.string) = + fun env -> + let cm = FStarC_Extraction_ML_UEnv.current_module_of_uenv env in + let gamma = + let uu___ = FStarC_Extraction_ML_UEnv.bindings_of_uenv env in + FStarC_Compiler_List.collect + (fun uu___1 -> + match uu___1 with + | FStarC_Extraction_ML_UEnv.Fv (b, e) -> [(b, e)] + | uu___2 -> []) uu___ in + let uu___ = + let uu___1 = FStarC_Compiler_List.map (print_binding cm) gamma in + FStarC_Compiler_String.concat "\n" uu___1 in + FStarC_Compiler_Util.format1 "Gamma = {\n %s }" uu___ +let (extract_attrs : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.attribute Prims.list -> + FStarC_Extraction_ML_Syntax.mlattribute Prims.list) + = + fun env -> + fun attrs -> + FStarC_Compiler_List.map + (fun attr -> + let uu___ = FStarC_Extraction_ML_Term.term_as_mlexpr env attr in + match uu___ with | (e, uu___1, uu___2) -> e) attrs +let (extract_typ_abbrev : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.qualifier Prims.list -> + FStarC_Syntax_Syntax.attribute Prims.list -> + FStarC_Syntax_Syntax.letbinding -> + (env_t * iface * FStarC_Extraction_ML_Syntax.mlmodule1 Prims.list)) + = + fun env -> + fun quals -> + fun attrs -> + fun lb -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Extraction_ML_UEnv.tcenv_of_uenv env in + FStarC_TypeChecker_Env.open_universes_in uu___2 + lb.FStarC_Syntax_Syntax.lbunivs + [lb.FStarC_Syntax_Syntax.lbdef; + lb.FStarC_Syntax_Syntax.lbtyp] in + match uu___1 with + | (tcenv, uu___2, def_typ) -> + let uu___3 = as_pair def_typ in (tcenv, uu___3) in + match uu___ with + | (tcenv, (lbdef, lbtyp)) -> + let lbtyp1 = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.ForExtraction] tcenv lbtyp in + let lbdef1 = + FStarC_TypeChecker_Normalize.eta_expand_with_type tcenv lbdef + lbtyp1 in + let fv = + FStarC_Compiler_Util.right lb.FStarC_Syntax_Syntax.lbname in + let lid = + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + let def = + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress lbdef1 in + FStarC_Syntax_Util.unmeta uu___2 in + FStarC_Syntax_Util.un_uinst uu___1 in + let def1 = + match def.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_abs uu___1 -> + FStarC_Extraction_ML_Term.normalize_abs def + | uu___1 -> def in + let uu___1 = + match def1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs; + FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = uu___2;_} + -> FStarC_Syntax_Subst.open_term bs body + | uu___2 -> ([], def1) in + (match uu___1 with + | (bs, body) -> + let assumed = + FStarC_Compiler_Util.for_some + (fun uu___2 -> + match uu___2 with + | FStarC_Syntax_Syntax.Assumption -> true + | uu___3 -> false) quals in + let uu___2 = binders_as_mlty_binders env bs in + (match uu___2 with + | (env1, ml_bs) -> + let body1 = + let uu___3 = + FStarC_Extraction_ML_Term.term_as_mlty env1 body in + FStarC_Extraction_ML_Util.eraseTypeDeep + (FStarC_Extraction_ML_Util.udelta_unfold env1) + uu___3 in + let metadata = + let has_val_decl = + FStarC_Extraction_ML_UEnv.has_tydef_declaration + env lid in + let meta = + let uu___3 = extract_metadata attrs in + let uu___4 = + FStarC_Compiler_List.choose flag_of_qual quals in + FStarC_Compiler_List.op_At uu___3 uu___4 in + if has_val_decl + then + let uu___3 = + let uu___4 = FStarC_Ident.range_of_lid lid in + FStarC_Extraction_ML_Syntax.HasValDecl uu___4 in + uu___3 :: meta + else meta in + let tyscheme = (ml_bs, body1) in + let uu___3 = + let uu___4 = + FStarC_Compiler_Util.for_some + (fun uu___5 -> + match uu___5 with + | FStarC_Syntax_Syntax.Assumption -> true + | FStarC_Syntax_Syntax.New -> true + | uu___6 -> false) quals in + if uu___4 + then + let uu___5 = + FStarC_Extraction_ML_UEnv.extend_type_name env + fv in + match uu___5 with + | (mlp, env2) -> + (mlp, (iface_of_type_names [(fv, mlp)]), + env2) + else + (let uu___6 = + FStarC_Extraction_ML_UEnv.extend_tydef env fv + tyscheme metadata in + match uu___6 with + | (td, mlp, env2) -> + let uu___7 = iface_of_tydefs [td] in + (mlp, uu___7, env2)) in + (match uu___3 with + | (mlpath, iface1, env2) -> + let td = + { + FStarC_Extraction_ML_Syntax.tydecl_assumed = + assumed; + FStarC_Extraction_ML_Syntax.tydecl_name = + (FStar_Pervasives_Native.snd mlpath); + FStarC_Extraction_ML_Syntax.tydecl_ignored = + FStar_Pervasives_Native.None; + FStarC_Extraction_ML_Syntax.tydecl_parameters + = ml_bs; + FStarC_Extraction_ML_Syntax.tydecl_meta = + metadata; + FStarC_Extraction_ML_Syntax.tydecl_defn = + (FStar_Pervasives_Native.Some + (FStarC_Extraction_ML_Syntax.MLTD_Abbrev + body1)) + } in + let loc_mlmodule1 = + let uu___4 = + let uu___5 = FStarC_Ident.range_of_lid lid in + FStarC_Extraction_ML_Util.mlloc_of_range + uu___5 in + FStarC_Extraction_ML_Syntax.MLM_Loc uu___4 in + let ty_mlmodule1 = + FStarC_Extraction_ML_Syntax.MLM_Ty [td] in + let def2 = + let uu___4 = + FStarC_Extraction_ML_Syntax.mk_mlmodule1 + loc_mlmodule1 in + let uu___5 = + let uu___6 = + let uu___7 = extract_attrs env2 attrs in + FStarC_Extraction_ML_Syntax.mk_mlmodule1_with_attrs + ty_mlmodule1 uu___7 in + [uu___6] in + uu___4 :: uu___5 in + (env2, iface1, def2)))) +let (extract_let_rec_type : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.qualifier Prims.list -> + FStarC_Syntax_Syntax.attribute Prims.list -> + FStarC_Syntax_Syntax.letbinding -> + (env_t * iface * FStarC_Extraction_ML_Syntax.mlmodule1 Prims.list)) + = + fun env -> + fun quals -> + fun attrs -> + fun lb -> + let lbtyp = + let uu___ = FStarC_Extraction_ML_UEnv.tcenv_of_uenv env in + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.AllowUnboundUniverses; + FStarC_TypeChecker_Env.EraseUniverses; + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.ForExtraction] uu___ + lb.FStarC_Syntax_Syntax.lbtyp in + let uu___ = FStarC_Syntax_Util.arrow_formals lbtyp in + match uu___ with + | (bs, uu___1) -> + let uu___2 = binders_as_mlty_binders env bs in + (match uu___2 with + | (env1, ml_bs) -> + let fv = + FStarC_Compiler_Util.right + lb.FStarC_Syntax_Syntax.lbname in + let lid = + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + let body = FStarC_Extraction_ML_Syntax.MLTY_Top in + let metadata = + let uu___3 = extract_metadata attrs in + let uu___4 = + FStarC_Compiler_List.choose flag_of_qual quals in + FStarC_Compiler_List.op_At uu___3 uu___4 in + let assumed = false in + let tscheme = (ml_bs, body) in + let uu___3 = + FStarC_Extraction_ML_UEnv.extend_tydef env fv tscheme + metadata in + (match uu___3 with + | (tydef, mlp, env2) -> + let td = + { + FStarC_Extraction_ML_Syntax.tydecl_assumed = + assumed; + FStarC_Extraction_ML_Syntax.tydecl_name = + (FStar_Pervasives_Native.snd mlp); + FStarC_Extraction_ML_Syntax.tydecl_ignored = + FStar_Pervasives_Native.None; + FStarC_Extraction_ML_Syntax.tydecl_parameters = + ml_bs; + FStarC_Extraction_ML_Syntax.tydecl_meta = + metadata; + FStarC_Extraction_ML_Syntax.tydecl_defn = + (FStar_Pervasives_Native.Some + (FStarC_Extraction_ML_Syntax.MLTD_Abbrev + body)) + } in + let loc_mlmodule1 = + let uu___4 = + let uu___5 = FStarC_Ident.range_of_lid lid in + FStarC_Extraction_ML_Util.mlloc_of_range uu___5 in + FStarC_Extraction_ML_Syntax.MLM_Loc uu___4 in + let td_mlmodule1 = + FStarC_Extraction_ML_Syntax.MLM_Ty [td] in + let def = + let uu___4 = + FStarC_Extraction_ML_Syntax.mk_mlmodule1 + loc_mlmodule1 in + let uu___5 = + let uu___6 = + let uu___7 = extract_attrs env2 attrs in + FStarC_Extraction_ML_Syntax.mk_mlmodule1_with_attrs + td_mlmodule1 uu___7 in + [uu___6] in + uu___4 :: uu___5 in + let iface1 = iface_of_tydefs [tydef] in + (env2, iface1, def))) +let (extract_bundle_iface : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.sigelt -> (env_t * iface)) + = + fun env -> + fun se -> + let extract_ctor env_iparams ml_tyvars env1 ctor = + let mlt = + let uu___ = + FStarC_Extraction_ML_Term.term_as_mlty env_iparams ctor.dtyp in + FStarC_Extraction_ML_Util.eraseTypeDeep + (FStarC_Extraction_ML_Util.udelta_unfold env_iparams) uu___ in + let tys = (ml_tyvars, mlt) in + let fvv = + FStarC_Syntax_Syntax.lid_as_fv ctor.dname + FStar_Pervasives_Native.None in + let uu___ = FStarC_Extraction_ML_UEnv.extend_fv env1 fvv tys false in + match uu___ with | (env2, uu___1, b) -> (env2, (fvv, b)) in + let extract_one_family env1 ind = + let uu___ = binders_as_mlty_binders env1 ind.iparams in + match uu___ with + | (env_iparams, vars) -> + let uu___1 = + FStarC_Compiler_Util.fold_map (extract_ctor env_iparams vars) + env1 ind.idatas in + (match uu___1 with + | (env2, ctors) -> + let env3 = + let uu___2 = + FStarC_Compiler_Util.find_opt + (fun uu___3 -> + match uu___3 with + | FStarC_Syntax_Syntax.RecordType uu___4 -> true + | uu___4 -> false) ind.iquals in + match uu___2 with + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.RecordType (ns, ids)) -> + let g = + FStarC_Compiler_List.fold_right + (fun id -> + fun g1 -> + let uu___3 = + FStarC_Extraction_ML_UEnv.extend_record_field_name + g1 ((ind.iname), id) in + match uu___3 with | (uu___4, g2) -> g2) ids + env2 in + g + | uu___3 -> env2 in + (env3, ctors)) in + match ((se.FStarC_Syntax_Syntax.sigel), + (se.FStarC_Syntax_Syntax.sigquals)) + with + | (FStarC_Syntax_Syntax.Sig_bundle + { + FStarC_Syntax_Syntax.ses = + { + FStarC_Syntax_Syntax.sigel = FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = l; + FStarC_Syntax_Syntax.us1 = uu___; + FStarC_Syntax_Syntax.t1 = t; + FStarC_Syntax_Syntax.ty_lid = uu___1; + FStarC_Syntax_Syntax.num_ty_params = uu___2; + FStarC_Syntax_Syntax.mutuals1 = uu___3; + FStarC_Syntax_Syntax.injective_type_params1 = uu___4;_}; + FStarC_Syntax_Syntax.sigrng = uu___5; + FStarC_Syntax_Syntax.sigquals = uu___6; + FStarC_Syntax_Syntax.sigmeta = uu___7; + FStarC_Syntax_Syntax.sigattrs = uu___8; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___9; + FStarC_Syntax_Syntax.sigopts = uu___10;_}::[]; + FStarC_Syntax_Syntax.lids = uu___11;_}, + (FStarC_Syntax_Syntax.ExceptionConstructor)::[]) -> + let uu___12 = extract_ctor env [] env { dname = l; dtyp = t } in + (match uu___12 with + | (env1, ctor) -> (env1, (iface_of_bindings [ctor]))) + | (FStarC_Syntax_Syntax.Sig_bundle + { FStarC_Syntax_Syntax.ses = ses; + FStarC_Syntax_Syntax.lids = uu___;_}, + quals) -> + let uu___1 = + FStarC_Syntax_Util.has_attribute se.FStarC_Syntax_Syntax.sigattrs + FStarC_Parser_Const.erasable_attr in + if uu___1 + then (env, empty_iface) + else + (let uu___3 = bundle_as_inductive_families env ses quals in + match uu___3 with + | (env1, ifams) -> + let uu___4 = + FStarC_Compiler_Util.fold_map extract_one_family env1 + ifams in + (match uu___4 with + | (env2, td) -> + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Compiler_List.map + (fun x -> + let uu___8 = + FStarC_Extraction_ML_UEnv.mlpath_of_lident + env2 x.iname in + ((x.ifv), uu___8)) ifams in + iface_of_type_names uu___7 in + iface_union uu___6 + (iface_of_bindings + (FStarC_Compiler_List.flatten td)) in + (env2, uu___5))) + | uu___ -> failwith "Unexpected signature element" +let (extract_type_declaration : + FStarC_Extraction_ML_UEnv.uenv -> + Prims.bool -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.qualifier Prims.list -> + FStarC_Syntax_Syntax.term Prims.list -> + FStarC_Syntax_Syntax.univ_name Prims.list -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + (env_t * iface * FStarC_Extraction_ML_Syntax.mlmodule1 + Prims.list)) + = + fun g -> + fun is_interface_val -> + fun lid -> + fun quals -> + fun attrs -> + fun univs -> + fun t -> + let uu___ = + let uu___1 = + FStarC_Compiler_Util.for_some + (fun uu___2 -> + match uu___2 with + | FStarC_Syntax_Syntax.Assumption -> true + | uu___3 -> false) quals in + Prims.op_Negation uu___1 in + if uu___ + then + let g1 = + FStarC_Extraction_ML_UEnv.extend_with_tydef_declaration g + lid in + (g1, empty_iface, []) + else + (let uu___2 = FStarC_Syntax_Util.arrow_formals t in + match uu___2 with + | (bs, uu___3) -> + let fv = + FStarC_Syntax_Syntax.lid_as_fv lid + FStar_Pervasives_Native.None in + let lb = + let uu___4 = + FStarC_Syntax_Util.abs bs + FStarC_Syntax_Syntax.t_unit + FStar_Pervasives_Native.None in + { + FStarC_Syntax_Syntax.lbname = + (FStar_Pervasives.Inr fv); + FStarC_Syntax_Syntax.lbunivs = univs; + FStarC_Syntax_Syntax.lbtyp = t; + FStarC_Syntax_Syntax.lbeff = + FStarC_Parser_Const.effect_Tot_lid; + FStarC_Syntax_Syntax.lbdef = uu___4; + FStarC_Syntax_Syntax.lbattrs = attrs; + FStarC_Syntax_Syntax.lbpos = + (t.FStarC_Syntax_Syntax.pos) + } in + let uu___4 = extract_typ_abbrev g quals attrs lb in + (match uu___4 with + | (g1, iface1, mods) -> + let iface2 = + if is_interface_val + then + let mlp = + FStarC_Extraction_ML_UEnv.mlpath_of_lident + g1 lid in + let meta = extract_metadata attrs in + { + iface_module_name = + (empty_iface.iface_module_name); + iface_bindings = + (empty_iface.iface_bindings); + iface_tydefs = + [FStar_Pervasives.Inr + ((FStar_Pervasives_Native.snd mlp), + meta, + (FStarC_Compiler_List.length bs))]; + iface_type_names = + (empty_iface.iface_type_names) + } + else iface1 in + (g1, iface2, mods))) +let (extract_reifiable_effect : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.eff_decl -> + (FStarC_Extraction_ML_UEnv.uenv * iface * + FStarC_Extraction_ML_Syntax.mlmodule1 Prims.list)) + = + fun g -> + fun ed -> + let extend_iface lid mlp exp exp_binding = + let fv = + FStarC_Syntax_Syntax.lid_as_fv lid FStar_Pervasives_Native.None in + let lb = + { + FStarC_Extraction_ML_Syntax.mllb_name = + (FStar_Pervasives_Native.snd mlp); + FStarC_Extraction_ML_Syntax.mllb_tysc = + FStar_Pervasives_Native.None; + FStarC_Extraction_ML_Syntax.mllb_add_unit = false; + FStarC_Extraction_ML_Syntax.mllb_def = exp; + FStarC_Extraction_ML_Syntax.mllb_attrs = []; + FStarC_Extraction_ML_Syntax.mllb_meta = []; + FStarC_Extraction_ML_Syntax.print_typ = false + } in + let uu___ = + FStarC_Extraction_ML_Syntax.mk_mlmodule1 + (FStarC_Extraction_ML_Syntax.MLM_Let + (FStarC_Extraction_ML_Syntax.NonRec, [lb])) in + ((iface_of_bindings [(fv, exp_binding)]), uu___) in + let rec extract_fv tm = + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_ExtractionReify in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term tm in + FStarC_Compiler_Util.print1 "extract_fv term: %s\n" uu___2 + else ()); + (let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress tm in + uu___2.FStarC_Syntax_Syntax.n in + match uu___1 with + | FStarC_Syntax_Syntax.Tm_uinst (tm1, uu___2) -> extract_fv tm1 + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let mlp = + FStarC_Extraction_ML_UEnv.mlpath_of_lident g + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + let uu___2 = + FStarC_Extraction_ML_UEnv.lookup_fv + tm.FStarC_Syntax_Syntax.pos g fv in + (match uu___2 with + | { FStarC_Extraction_ML_UEnv.exp_b_name = uu___3; + FStarC_Extraction_ML_UEnv.exp_b_expr = uu___4; + FStarC_Extraction_ML_UEnv.exp_b_tscheme = tysc; + FStarC_Extraction_ML_UEnv.exp_b_eff = uu___5;_} -> + let uu___6 = + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.MLTY_Top + (FStarC_Extraction_ML_Syntax.MLE_Name mlp) in + (uu___6, tysc)) + | uu___2 -> + let uu___3 = + let uu___4 = + FStarC_Compiler_Range_Ops.string_of_range + tm.FStarC_Syntax_Syntax.pos in + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term tm in + FStarC_Compiler_Util.format2 "(%s) Not an fv: %s" uu___4 + uu___5 in + failwith uu___3) in + let extract_action g1 a = + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_ExtractionReify in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + a.FStarC_Syntax_Syntax.action_typ in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + a.FStarC_Syntax_Syntax.action_defn in + FStarC_Compiler_Util.print2 "Action type %s and term %s\n" uu___2 + uu___3 + else ()); + (let lbname = + let uu___1 = + FStarC_Syntax_Syntax.new_bv + (FStar_Pervasives_Native.Some + ((a.FStarC_Syntax_Syntax.action_defn).FStarC_Syntax_Syntax.pos)) + FStarC_Syntax_Syntax.tun in + FStar_Pervasives.Inl uu___1 in + let lb = + FStarC_Syntax_Syntax.mk_lb + (lbname, (a.FStarC_Syntax_Syntax.action_univs), + FStarC_Parser_Const.effect_Tot_lid, + (a.FStarC_Syntax_Syntax.action_typ), + (a.FStarC_Syntax_Syntax.action_defn), [], + ((a.FStarC_Syntax_Syntax.action_defn).FStarC_Syntax_Syntax.pos)) in + let lbs = (false, [lb]) in + let action_lb = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = lbs; + FStarC_Syntax_Syntax.body1 = + FStarC_Syntax_Util.exp_false_bool + }) + (a.FStarC_Syntax_Syntax.action_defn).FStarC_Syntax_Syntax.pos in + let uu___1 = FStarC_Extraction_ML_Term.term_as_mlexpr g1 action_lb in + match uu___1 with + | (a_let, uu___2, ty) -> + let uu___3 = + match a_let.FStarC_Extraction_ML_Syntax.expr with + | FStarC_Extraction_ML_Syntax.MLE_Let + ((uu___4, mllb::[]), uu___5) -> + (match mllb.FStarC_Extraction_ML_Syntax.mllb_tysc with + | FStar_Pervasives_Native.Some tysc -> + ((mllb.FStarC_Extraction_ML_Syntax.mllb_def), tysc) + | FStar_Pervasives_Native.None -> + failwith "No type scheme") + | uu___4 -> failwith "Impossible" in + (match uu___3 with + | (exp, tysc) -> + let uu___4 = + FStarC_Extraction_ML_UEnv.extend_with_action_name g1 ed a + tysc in + (match uu___4 with + | (a_nm, a_lid, exp_b, g2) -> + ((let uu___6 = + FStarC_Compiler_Effect.op_Bang dbg_ExtractionReify in + if uu___6 + then + let uu___7 = + FStarC_Extraction_ML_Code.string_of_mlexpr a_nm + a_let in + FStarC_Compiler_Util.print1 + "Extracted action term: %s\n" uu___7 + else ()); + (let uu___7 = + FStarC_Compiler_Effect.op_Bang dbg_ExtractionReify in + if uu___7 + then + ((let uu___9 = + FStarC_Extraction_ML_Code.string_of_mlty a_nm + (FStar_Pervasives_Native.snd tysc) in + FStarC_Compiler_Util.print1 + "Extracted action type: %s\n" uu___9); + (let uu___9 = + FStarC_Extraction_ML_Syntax.ty_param_names + (FStar_Pervasives_Native.fst tysc) in + FStarC_Compiler_List.iter + (fun x -> + FStarC_Compiler_Util.print1 + "and binders: %s\n" x) uu___9)) + else ()); + (let uu___7 = extend_iface a_lid a_nm exp exp_b in + match uu___7 with + | (iface1, impl) -> (g2, (iface1, impl))))))) in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Util.get_return_repr ed in + FStarC_Compiler_Util.must uu___4 in + FStar_Pervasives_Native.snd uu___3 in + extract_fv uu___2 in + match uu___1 with + | (return_tm, ty_sc) -> + let uu___2 = + FStarC_Extraction_ML_UEnv.extend_with_monad_op_name g ed + "return" ty_sc in + (match uu___2 with + | (return_nm, return_lid, return_b, g1) -> + let uu___3 = + extend_iface return_lid return_nm return_tm return_b in + (match uu___3 with | (iface1, impl) -> (g1, iface1, impl))) in + match uu___ with + | (g1, return_iface, return_decl) -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Util.get_bind_repr ed in + FStarC_Compiler_Util.must uu___5 in + FStar_Pervasives_Native.snd uu___4 in + extract_fv uu___3 in + match uu___2 with + | (bind_tm, ty_sc) -> + let uu___3 = + FStarC_Extraction_ML_UEnv.extend_with_monad_op_name g1 ed + "bind" ty_sc in + (match uu___3 with + | (bind_nm, bind_lid, bind_b, g2) -> + let uu___4 = + extend_iface bind_lid bind_nm bind_tm bind_b in + (match uu___4 with + | (iface1, impl) -> (g2, iface1, impl))) in + (match uu___1 with + | (g2, bind_iface, bind_decl) -> + let uu___2 = + FStarC_Compiler_Util.fold_map extract_action g2 + ed.FStarC_Syntax_Syntax.actions in + (match uu___2 with + | (g3, actions) -> + let uu___3 = FStarC_Compiler_List.unzip actions in + (match uu___3 with + | (actions_iface, actions1) -> + let uu___4 = + iface_union_l (return_iface :: bind_iface :: + actions_iface) in + (g3, uu___4, (return_decl :: bind_decl :: actions1))))) +let (should_split_let_rec_types_and_terms : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.letbinding Prims.list -> Prims.bool) + = + fun env -> + fun lbs -> + let rec is_homogeneous out lbs1 = + match lbs1 with + | [] -> true + | lb::lbs_tail -> + let is_type = + FStarC_Extraction_ML_Term.is_arity env + lb.FStarC_Syntax_Syntax.lbtyp in + (match out with + | FStar_Pervasives_Native.None -> + is_homogeneous (FStar_Pervasives_Native.Some is_type) + lbs_tail + | FStar_Pervasives_Native.Some b when b = is_type -> + is_homogeneous (FStar_Pervasives_Native.Some is_type) + lbs_tail + | uu___ -> false) in + let uu___ = is_homogeneous FStar_Pervasives_Native.None lbs in + Prims.op_Negation uu___ +let (split_let_rec_types_and_terms : + FStarC_Syntax_Syntax.sigelt -> + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.letbinding Prims.list -> + FStarC_Syntax_Syntax.sigelt Prims.list) + = + fun se -> + fun env -> + fun lbs -> + let rec aux out mutuals lbs1 = + match lbs1 with + | [] -> (out, mutuals) + | lb::lbs_tail -> + let uu___ = aux out mutuals lbs_tail in + (match uu___ with + | (out1, mutuals1) -> + let uu___1 = + let uu___2 = + FStarC_Extraction_ML_Term.is_arity env + lb.FStarC_Syntax_Syntax.lbtyp in + Prims.op_Negation uu___2 in + if uu___1 + then (out1, (lb :: mutuals1)) + else + (let uu___3 = + FStarC_Syntax_Util.abs_formals_maybe_unascribe_body + true lb.FStarC_Syntax_Syntax.lbdef in + match uu___3 with + | (formals, body, rc_opt) -> + let body1 = + FStarC_Syntax_Syntax.tconst + FStarC_Parser_Const.c_true_lid in + let lbdef = + FStarC_Syntax_Util.abs formals body1 + FStar_Pervasives_Native.None in + let lb1 = + { + FStarC_Syntax_Syntax.lbname = + (lb.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = + (lb.FStarC_Syntax_Syntax.lbtyp); + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = lbdef; + FStarC_Syntax_Syntax.lbattrs = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + } in + let se1 = + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_let + { + FStarC_Syntax_Syntax.lbs1 = + (false, [lb1]); + FStarC_Syntax_Syntax.lids1 = [] + }); + FStarC_Syntax_Syntax.sigrng = + (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se.FStarC_Syntax_Syntax.sigopts) + } in + ((se1 :: out1), mutuals1))) in + let uu___ = aux [] [] lbs in + match uu___ with + | (sigs, lbs1) -> + let lb = + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Compiler_List.map + (fun lb1 -> + let uu___4 = + FStarC_Compiler_Util.right + lb1.FStarC_Syntax_Syntax.lbname in + FStarC_Syntax_Syntax.lid_of_fv uu___4) lbs1 in + { + FStarC_Syntax_Syntax.lbs1 = (true, lbs1); + FStarC_Syntax_Syntax.lids1 = uu___3 + } in + FStarC_Syntax_Syntax.Sig_let uu___2 in + { + FStarC_Syntax_Syntax.sigel = uu___1; + FStarC_Syntax_Syntax.sigrng = + (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se.FStarC_Syntax_Syntax.sigopts) + } in + let sigs1 = FStarC_Compiler_List.op_At sigs [lb] in sigs1 +let (extract_let_rec_types : + FStarC_Syntax_Syntax.sigelt -> + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.letbinding Prims.list -> + (FStarC_Extraction_ML_UEnv.uenv * iface * + FStarC_Extraction_ML_Syntax.mlmodule1 Prims.list)) + = + fun se -> + fun env -> + fun lbs -> + let uu___ = + FStarC_Compiler_Util.for_some + (fun lb -> + let uu___1 = + FStarC_Extraction_ML_Term.is_arity env + lb.FStarC_Syntax_Syntax.lbtyp in + Prims.op_Negation uu___1) lbs in + if uu___ + then failwith "Impossible: mixed mutual types and terms" + else + (let uu___2 = + FStarC_Compiler_List.fold_left + (fun uu___3 -> + fun lb -> + match uu___3 with + | (env1, iface_opt, impls) -> + let uu___4 = + extract_let_rec_type env1 + se.FStarC_Syntax_Syntax.sigquals + se.FStarC_Syntax_Syntax.sigattrs lb in + (match uu___4 with + | (env2, iface1, impl) -> + let iface_opt1 = + match iface_opt with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.Some iface1 + | FStar_Pervasives_Native.Some iface' -> + let uu___5 = iface_union iface' iface1 in + FStar_Pervasives_Native.Some uu___5 in + (env2, iface_opt1, (impl :: impls)))) + (env, FStar_Pervasives_Native.None, []) lbs in + match uu___2 with + | (env1, iface_opt, impls) -> + let uu___3 = FStarC_Compiler_Option.get iface_opt in + (env1, uu___3, + (FStarC_Compiler_List.flatten + (FStarC_Compiler_List.rev impls)))) +let (get_noextract_to : + FStarC_Syntax_Syntax.sigelt -> + FStarC_Options.codegen_t FStar_Pervasives_Native.option -> Prims.bool) + = + fun se -> + fun backend -> + FStarC_Compiler_Util.for_some + (fun uu___ -> + let uu___1 = FStarC_Syntax_Util.head_and_args uu___ in + match uu___1 with + | (hd, args) -> + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.compress hd in + uu___4.FStarC_Syntax_Syntax.n in + (uu___3, args) in + (match uu___2 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, (a, uu___3)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.noextract_to_attr + -> + let uu___4 = + FStarC_Syntax_Embeddings_Base.try_unembed + FStarC_Syntax_Embeddings.e_string a + FStarC_Syntax_Embeddings_Base.id_norm_cb in + (match uu___4 with + | FStar_Pervasives_Native.Some s -> + (FStarC_Compiler_Option.isSome backend) && + (let uu___5 = FStarC_Options.parse_codegen s in + uu___5 = backend) + | FStar_Pervasives_Native.None -> false) + | uu___3 -> false)) se.FStarC_Syntax_Syntax.sigattrs +let (sigelt_has_noextract : FStarC_Syntax_Syntax.sigelt -> Prims.bool) = + fun se -> + let has_noextract_qualifier = + FStarC_Compiler_List.contains FStarC_Syntax_Syntax.NoExtract + se.FStarC_Syntax_Syntax.sigquals in + let has_noextract_attribute = + let uu___ = FStarC_Options.codegen () in get_noextract_to se uu___ in + let uu___ = FStarC_Options.codegen () in + match uu___ with + | FStar_Pervasives_Native.Some (FStarC_Options.Krml) -> + has_noextract_qualifier && has_noextract_attribute + | uu___1 -> has_noextract_qualifier || has_noextract_attribute +let (karamel_fixup_qual : + FStarC_Syntax_Syntax.sigelt -> FStarC_Syntax_Syntax.sigelt) = + fun se -> + let uu___ = + ((let uu___1 = FStarC_Options.codegen () in + uu___1 = (FStar_Pervasives_Native.Some FStarC_Options.Krml)) && + (get_noextract_to se + (FStar_Pervasives_Native.Some FStarC_Options.Krml))) + && + (Prims.op_Negation + (FStarC_Compiler_List.contains FStarC_Syntax_Syntax.NoExtract + se.FStarC_Syntax_Syntax.sigquals)) in + if uu___ + then + { + FStarC_Syntax_Syntax.sigel = (se.FStarC_Syntax_Syntax.sigel); + FStarC_Syntax_Syntax.sigrng = (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = (FStarC_Syntax_Syntax.NoExtract :: + (se.FStarC_Syntax_Syntax.sigquals)); + FStarC_Syntax_Syntax.sigmeta = (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = (se.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = (se.FStarC_Syntax_Syntax.sigopts) + } + else se +let (mark_sigelt_erased : + FStarC_Syntax_Syntax.sigelt -> + FStarC_Extraction_ML_UEnv.uenv -> FStarC_Extraction_ML_UEnv.uenv) + = + fun se -> + fun g -> + FStarC_Extraction_ML_UEnv.debug g + (fun u -> + let uu___1 = FStarC_Syntax_Print.sigelt_to_string_short se in + FStarC_Compiler_Util.print1 ">>>> NOT extracting %s \n" uu___1); + FStarC_Compiler_List.fold_right + (fun lid -> + fun g1 -> + let uu___1 = + FStarC_Syntax_Syntax.lid_as_fv lid + FStar_Pervasives_Native.None in + FStarC_Extraction_ML_UEnv.extend_erased_fv g1 uu___1) + (FStarC_Syntax_Util.lids_of_sigelt se) g +let (fixup_sigelt_extract_as : + FStarC_Syntax_Syntax.sigelt -> FStarC_Syntax_Syntax.sigelt) = + fun se -> + let uu___ = + let uu___1 = + FStarC_Compiler_Util.find_map se.FStarC_Syntax_Syntax.sigattrs + FStarC_TypeChecker_Normalize.is_extract_as_attr in + ((se.FStarC_Syntax_Syntax.sigel), uu___1) in + match uu___ with + | (FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (uu___1, lb::[]); + FStarC_Syntax_Syntax.lids1 = lids;_}, + FStar_Pervasives_Native.Some impl) -> + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_let + { + FStarC_Syntax_Syntax.lbs1 = + (true, + [{ + FStarC_Syntax_Syntax.lbname = + (lb.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = + (lb.FStarC_Syntax_Syntax.lbtyp); + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = impl; + FStarC_Syntax_Syntax.lbattrs = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + }]); + FStarC_Syntax_Syntax.lids1 = lids + }); + FStarC_Syntax_Syntax.sigrng = (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = (se.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = (se.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = (se.FStarC_Syntax_Syntax.sigopts) + } + | uu___1 -> se +let rec (extract_sigelt_iface : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.sigelt -> (FStarC_Extraction_ML_UEnv.uenv * iface)) + = + fun g -> + fun se -> + let uu___ = sigelt_has_noextract se in + if uu___ + then let g1 = mark_sigelt_erased se g in (g1, empty_iface) + else + (let se1 = karamel_fixup_qual se in + let se2 = fixup_sigelt_extract_as se1 in + match se2.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_bundle uu___2 -> + extract_bundle_iface g se2 + | FStarC_Syntax_Syntax.Sig_inductive_typ uu___2 -> + extract_bundle_iface g se2 + | FStarC_Syntax_Syntax.Sig_datacon uu___2 -> + extract_bundle_iface g se2 + | FStarC_Syntax_Syntax.Sig_declare_typ + { FStarC_Syntax_Syntax.lid2 = lid; + FStarC_Syntax_Syntax.us2 = univs; + FStarC_Syntax_Syntax.t2 = t;_} + when FStarC_Extraction_ML_Term.is_arity g t -> + let uu___2 = + extract_type_declaration g true lid + se2.FStarC_Syntax_Syntax.sigquals + se2.FStarC_Syntax_Syntax.sigattrs univs t in + (match uu___2 with | (env, iface1, uu___3) -> (env, iface1)) + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (false, lb::[]); + FStarC_Syntax_Syntax.lids1 = uu___2;_} + when + FStarC_Extraction_ML_Term.is_arity g + lb.FStarC_Syntax_Syntax.lbtyp + -> + let uu___3 = + FStarC_Compiler_Util.for_some + (fun uu___4 -> + match uu___4 with + | FStarC_Syntax_Syntax.Projector uu___5 -> true + | uu___5 -> false) se2.FStarC_Syntax_Syntax.sigquals in + if uu___3 + then (g, empty_iface) + else + (let uu___5 = + extract_typ_abbrev g se2.FStarC_Syntax_Syntax.sigquals + se2.FStarC_Syntax_Syntax.sigattrs lb in + match uu___5 with | (env, iface1, uu___6) -> (env, iface1)) + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (true, lbs); + FStarC_Syntax_Syntax.lids1 = uu___2;_} + when should_split_let_rec_types_and_terms g lbs -> + let ses = split_let_rec_types_and_terms se2 g lbs in + let iface1 = + let uu___3 = + FStarC_Extraction_ML_UEnv.current_module_of_uenv g in + { + iface_module_name = uu___3; + iface_bindings = (empty_iface.iface_bindings); + iface_tydefs = (empty_iface.iface_tydefs); + iface_type_names = (empty_iface.iface_type_names) + } in + FStarC_Compiler_List.fold_left + (fun uu___3 -> + fun se3 -> + match uu___3 with + | (g1, out) -> + let uu___4 = extract_sigelt_iface g1 se3 in + (match uu___4 with + | (g2, mls) -> + let uu___5 = iface_union out mls in (g2, uu___5))) + (g, iface1) ses + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (true, lbs); + FStarC_Syntax_Syntax.lids1 = uu___2;_} + when + FStarC_Compiler_Util.for_some + (fun lb -> + FStarC_Extraction_ML_Term.is_arity g + lb.FStarC_Syntax_Syntax.lbtyp) lbs + -> + let uu___3 = extract_let_rec_types se2 g lbs in + (match uu___3 with | (env, iface1, uu___4) -> (env, iface1)) + | FStarC_Syntax_Syntax.Sig_declare_typ + { FStarC_Syntax_Syntax.lid2 = lid; + FStarC_Syntax_Syntax.us2 = uu___2; + FStarC_Syntax_Syntax.t2 = t;_} + -> + let quals = se2.FStarC_Syntax_Syntax.sigquals in + let uu___3 = + (FStarC_Compiler_List.contains FStarC_Syntax_Syntax.Assumption + quals) + && + (let uu___4 = + let uu___5 = FStarC_Extraction_ML_UEnv.tcenv_of_uenv g in + FStarC_TypeChecker_Util.must_erase_for_extraction uu___5 + t in + Prims.op_Negation uu___4) in + if uu___3 + then + let uu___4 = + let uu___5 = + let uu___6 = let uu___7 = always_fail lid t in [uu___7] in + (false, uu___6) in + FStarC_Extraction_ML_Term.extract_lb_iface g uu___5 in + (match uu___4 with + | (g1, bindings) -> (g1, (iface_of_bindings bindings))) + else (g, empty_iface) + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (false, lb::[]); + FStarC_Syntax_Syntax.lids1 = uu___2;_} + when + Prims.uu___is_Cons + (se2.FStarC_Syntax_Syntax.sigmeta).FStarC_Syntax_Syntax.sigmeta_extension_data + -> + let uu___3 = + FStarC_Compiler_List.tryPick + (fun uu___4 -> + match uu___4 with + | (ext, blob) -> + let uu___5 = lookup_extension_extractor ext in + (match uu___5 with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some extractor -> + FStar_Pervasives_Native.Some + (ext, blob, extractor))) + (se2.FStarC_Syntax_Syntax.sigmeta).FStarC_Syntax_Syntax.sigmeta_extension_data in + (match uu___3 with + | FStar_Pervasives_Native.None -> + let uu___4 = + FStarC_Extraction_ML_Term.extract_lb_iface g + (false, [lb]) in + (match uu___4 with + | (g1, bindings) -> (g1, (iface_of_bindings bindings))) + | FStar_Pervasives_Native.Some (ext, blob, extractor) -> + let res = extractor.extract_sigelt_iface g se2 blob in + (match res with + | FStar_Pervasives.Inl res1 -> res1 + | FStar_Pervasives.Inr err -> + let uu___4 = + FStarC_Compiler_Util.format2 + "Extension %s failed to extract iface: %s" ext err in + FStarC_Errors.raise_error + FStarC_Syntax_Syntax.has_range_sigelt se2 + FStarC_Errors_Codes.Fatal_ExtractionUnsupported () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4))) + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = lbs; + FStarC_Syntax_Syntax.lids1 = uu___2;_} + -> + let uu___3 = FStarC_Extraction_ML_Term.extract_lb_iface g lbs in + (match uu___3 with + | (g1, bindings) -> (g1, (iface_of_bindings bindings))) + | FStarC_Syntax_Syntax.Sig_assume uu___2 -> (g, empty_iface) + | FStarC_Syntax_Syntax.Sig_sub_effect uu___2 -> (g, empty_iface) + | FStarC_Syntax_Syntax.Sig_effect_abbrev uu___2 -> (g, empty_iface) + | FStarC_Syntax_Syntax.Sig_polymonadic_bind uu___2 -> + (g, empty_iface) + | FStarC_Syntax_Syntax.Sig_polymonadic_subcomp uu___2 -> + (g, empty_iface) + | FStarC_Syntax_Syntax.Sig_pragma p -> + (FStarC_Syntax_Util.process_pragma p + se2.FStarC_Syntax_Syntax.sigrng; + (g, empty_iface)) + | FStarC_Syntax_Syntax.Sig_splice uu___2 -> + failwith "impossible: trying to extract splice" + | FStarC_Syntax_Syntax.Sig_fail uu___2 -> + failwith "impossible: trying to extract Sig_fail" + | FStarC_Syntax_Syntax.Sig_new_effect ed -> + let uu___2 = + (let uu___3 = + let uu___4 = FStarC_Extraction_ML_UEnv.tcenv_of_uenv g in + FStarC_TypeChecker_Util.effect_extraction_mode uu___4 + ed.FStarC_Syntax_Syntax.mname in + uu___3 = FStarC_Syntax_Syntax.Extract_reify) && + (FStarC_Compiler_List.isEmpty + ed.FStarC_Syntax_Syntax.binders) in + if uu___2 + then + let uu___3 = extract_reifiable_effect g ed in + (match uu___3 with | (env, iface1, uu___4) -> (env, iface1)) + else (g, empty_iface)) +let (extract_iface' : + env_t -> + FStarC_Syntax_Syntax.modul -> (FStarC_Extraction_ML_UEnv.uenv * iface)) + = + fun g -> + fun modul -> + let uu___ = FStarC_Options.interactive () in + if uu___ + then (g, empty_iface) + else + (let uu___2 = FStarC_Options.restore_cmd_line_options true in + let decls = modul.FStarC_Syntax_Syntax.declarations in + let iface1 = + let uu___3 = FStarC_Extraction_ML_UEnv.current_module_of_uenv g in + { + iface_module_name = uu___3; + iface_bindings = (empty_iface.iface_bindings); + iface_tydefs = (empty_iface.iface_tydefs); + iface_type_names = (empty_iface.iface_type_names) + } in + let res = + FStarC_Compiler_List.fold_left + (fun uu___3 -> + fun se -> + match uu___3 with + | (g1, iface2) -> + let uu___4 = extract_sigelt_iface g1 se in + (match uu___4 with + | (g2, iface') -> + let uu___5 = iface_union iface2 iface' in + (g2, uu___5))) (g, iface1) decls in + (let uu___4 = FStarC_Options.restore_cmd_line_options true in ()); + res) +let (extract_iface : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.modul -> (FStarC_Extraction_ML_UEnv.uenv * iface)) + = + fun g -> + fun modul -> + let uu___ = + FStarC_Syntax_Unionfind.with_uf_enabled + (fun uu___1 -> + let uu___2 = FStarC_Compiler_Debug.any () in + if uu___2 + then + let uu___3 = + let uu___4 = + FStarC_Ident.string_of_lid modul.FStarC_Syntax_Syntax.name in + FStarC_Compiler_Util.format1 "Extracted interface of %s" + uu___4 in + FStarC_Compiler_Util.measure_execution_time uu___3 + (fun uu___4 -> extract_iface' g modul) + else extract_iface' g modul) in + match uu___ with + | (g1, iface1) -> + let uu___1 = + FStarC_Extraction_ML_UEnv.with_typars_env g1 + (fun e -> + let iface_tydefs = + FStarC_Compiler_List.map + (fun uu___2 -> + match uu___2 with + | FStar_Pervasives.Inl td -> + let uu___3 = + let uu___4 = + FStarC_Extraction_ML_UEnv.tydef_mlpath td in + FStar_Pervasives_Native.snd uu___4 in + let uu___4 = + FStarC_Extraction_ML_UEnv.tydef_meta td in + let uu___5 = + let uu___6 = + FStarC_Extraction_ML_UEnv.tydef_def td in + FStar_Pervasives.Inl uu___6 in + (uu___3, uu___4, uu___5) + | FStar_Pervasives.Inr (p, m, n) -> + (p, m, (FStar_Pervasives.Inr n))) + iface1.iface_tydefs in + let uu___2 = + FStarC_Extraction_ML_UEnv.extend_with_module_name g1 + modul.FStarC_Syntax_Syntax.name in + match uu___2 with + | (module_name, uu___3) -> + let e1 = + FStarC_Extraction_ML_RemoveUnusedParameters.set_current_module + e module_name in + FStarC_Extraction_ML_RemoveUnusedParameters.elim_tydefs + e1 iface_tydefs) in + (match uu___1 with + | (g2, uu___2) -> + let uu___3 = FStarC_Extraction_ML_UEnv.exit_module g2 in + (uu___3, iface1)) +let (extract_bundle : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.sigelt -> + (FStarC_Extraction_ML_UEnv.uenv * FStarC_Extraction_ML_Syntax.mlmodule1 + Prims.list)) + = + fun env -> + fun se -> + let extract_ctor env_iparams ml_tyvars env1 ctor = + let mlt = + let uu___ = + FStarC_Extraction_ML_Term.term_as_mlty env_iparams ctor.dtyp in + FStarC_Extraction_ML_Util.eraseTypeDeep + (FStarC_Extraction_ML_Util.udelta_unfold env_iparams) uu___ in + let steps = + [FStarC_TypeChecker_Env.Inlining; + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.EraseUniverses; + FStarC_TypeChecker_Env.AllowUnboundUniverses; + FStarC_TypeChecker_Env.ForExtraction] in + let names = + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Extraction_ML_UEnv.tcenv_of_uenv env_iparams in + FStarC_TypeChecker_Normalize.normalize steps uu___3 ctor.dtyp in + FStarC_Syntax_Subst.compress uu___2 in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = uu___1;_} + -> + FStarC_Compiler_List.map + (fun uu___2 -> + match uu___2 with + | { + FStarC_Syntax_Syntax.binder_bv = + { FStarC_Syntax_Syntax.ppname = ppname; + FStarC_Syntax_Syntax.index = uu___3; + FStarC_Syntax_Syntax.sort = uu___4;_}; + FStarC_Syntax_Syntax.binder_qual = uu___5; + FStarC_Syntax_Syntax.binder_positivity = uu___6; + FStarC_Syntax_Syntax.binder_attrs = uu___7;_} -> + FStarC_Ident.string_of_id ppname) bs + | uu___1 -> [] in + let tys = (ml_tyvars, mlt) in + let fvv = + FStarC_Syntax_Syntax.lid_as_fv ctor.dname + FStar_Pervasives_Native.None in + let uu___ = FStarC_Extraction_ML_UEnv.extend_fv env1 fvv tys false in + match uu___ with + | (env2, mls, uu___1) -> + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Extraction_ML_Util.argTypes mlt in + FStarC_Compiler_List.zip names uu___4 in + (mls, uu___3) in + (env2, uu___2) in + let extract_one_family env1 ind = + let uu___ = binders_as_mlty_binders env1 ind.iparams in + match uu___ with + | (env_iparams, vars) -> + let uu___1 = + FStarC_Compiler_Util.fold_map (extract_ctor env_iparams vars) + env1 ind.idatas in + (match uu___1 with + | (env2, ctors) -> + let uu___2 = FStarC_Syntax_Util.arrow_formals ind.ityp in + (match uu___2 with + | (indices, uu___3) -> + let ml_params = + let uu___4 = + FStarC_Compiler_List.mapi + (fun i -> + fun uu___5 -> + let uu___6 = + let uu___7 = + FStarC_Compiler_Util.string_of_int i in + Prims.strcat "'dummyV" uu___7 in + { + FStarC_Extraction_ML_Syntax.ty_param_name + = uu___6; + FStarC_Extraction_ML_Syntax.ty_param_attrs + = [] + }) indices in + FStarC_Compiler_List.append vars uu___4 in + let uu___4 = + let uu___5 = + FStarC_Compiler_Util.find_opt + (fun uu___6 -> + match uu___6 with + | FStarC_Syntax_Syntax.RecordType uu___7 -> + true + | uu___7 -> false) ind.iquals in + match uu___5 with + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.RecordType (ns, ids)) -> + let uu___6 = FStarC_Compiler_List.hd ctors in + (match uu___6 with + | (uu___7, c_ty) -> + let uu___8 = + FStarC_Compiler_List.fold_right2 + (fun id -> + fun uu___9 -> + fun uu___10 -> + match (uu___9, uu___10) with + | ((uu___11, ty), (fields, g)) -> + let uu___12 = + FStarC_Extraction_ML_UEnv.extend_record_field_name + g ((ind.iname), id) in + (match uu___12 with + | (mlid, g1) -> + (((mlid, ty) :: fields), + g1))) ids c_ty + ([], env2) in + (match uu___8 with + | (fields, g) -> + ((FStar_Pervasives_Native.Some + (FStarC_Extraction_ML_Syntax.MLTD_Record + fields)), g))) + | uu___6 when + (FStarC_Compiler_List.length ctors) = + Prims.int_zero + -> (FStar_Pervasives_Native.None, env2) + | uu___6 -> + ((FStar_Pervasives_Native.Some + (FStarC_Extraction_ML_Syntax.MLTD_DType ctors)), + env2) in + (match uu___4 with + | (tbody, env3) -> + let td = + let uu___5 = + let uu___6 = + FStarC_Extraction_ML_UEnv.mlpath_of_lident + env3 ind.iname in + FStar_Pervasives_Native.snd uu___6 in + { + FStarC_Extraction_ML_Syntax.tydecl_assumed = + false; + FStarC_Extraction_ML_Syntax.tydecl_name = + uu___5; + FStarC_Extraction_ML_Syntax.tydecl_ignored = + FStar_Pervasives_Native.None; + FStarC_Extraction_ML_Syntax.tydecl_parameters + = ml_params; + FStarC_Extraction_ML_Syntax.tydecl_meta = + (ind.imetadata); + FStarC_Extraction_ML_Syntax.tydecl_defn = + tbody + } in + (env3, td)))) in + let mlattrs = extract_attrs env se.FStarC_Syntax_Syntax.sigattrs in + match ((se.FStarC_Syntax_Syntax.sigel), + (se.FStarC_Syntax_Syntax.sigquals)) + with + | (FStarC_Syntax_Syntax.Sig_bundle + { + FStarC_Syntax_Syntax.ses = + { + FStarC_Syntax_Syntax.sigel = FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = l; + FStarC_Syntax_Syntax.us1 = uu___; + FStarC_Syntax_Syntax.t1 = t; + FStarC_Syntax_Syntax.ty_lid = uu___1; + FStarC_Syntax_Syntax.num_ty_params = uu___2; + FStarC_Syntax_Syntax.mutuals1 = uu___3; + FStarC_Syntax_Syntax.injective_type_params1 = uu___4;_}; + FStarC_Syntax_Syntax.sigrng = uu___5; + FStarC_Syntax_Syntax.sigquals = uu___6; + FStarC_Syntax_Syntax.sigmeta = uu___7; + FStarC_Syntax_Syntax.sigattrs = uu___8; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___9; + FStarC_Syntax_Syntax.sigopts = uu___10;_}::[]; + FStarC_Syntax_Syntax.lids = uu___11;_}, + (FStarC_Syntax_Syntax.ExceptionConstructor)::[]) -> + let uu___12 = extract_ctor env [] env { dname = l; dtyp = t } in + (match uu___12 with + | (env1, ctor) -> + let uu___13 = + let uu___14 = + FStarC_Extraction_ML_Syntax.mk_mlmodule1_with_attrs + (FStarC_Extraction_ML_Syntax.MLM_Exn ctor) mlattrs in + [uu___14] in + (env1, uu___13)) + | (FStarC_Syntax_Syntax.Sig_bundle + { FStarC_Syntax_Syntax.ses = ses; + FStarC_Syntax_Syntax.lids = uu___;_}, + quals) -> + let uu___1 = + FStarC_Syntax_Util.has_attribute se.FStarC_Syntax_Syntax.sigattrs + FStarC_Parser_Const.erasable_attr in + if uu___1 + then (env, []) + else + (let uu___3 = bundle_as_inductive_families env ses quals in + match uu___3 with + | (env1, ifams) -> + let uu___4 = + FStarC_Compiler_Util.fold_map extract_one_family env1 + ifams in + (match uu___4 with + | (env2, td) -> + let uu___5 = + let uu___6 = + FStarC_Extraction_ML_Syntax.mk_mlmodule1_with_attrs + (FStarC_Extraction_ML_Syntax.MLM_Ty td) mlattrs in + [uu___6] in + (env2, uu___5))) + | uu___ -> failwith "Unexpected signature element" +let (lb_is_irrelevant : + env_t -> FStarC_Syntax_Syntax.letbinding -> Prims.bool) = + fun g -> + fun lb -> + ((let uu___ = FStarC_Extraction_ML_UEnv.tcenv_of_uenv g in + FStarC_TypeChecker_Env.non_informative uu___ + lb.FStarC_Syntax_Syntax.lbtyp) + && + (let uu___ = + FStarC_Extraction_ML_Term.is_arity g + lb.FStarC_Syntax_Syntax.lbtyp in + Prims.op_Negation uu___)) + && + (FStarC_Syntax_Util.is_pure_or_ghost_effect + lb.FStarC_Syntax_Syntax.lbeff) +let (lb_is_tactic : env_t -> FStarC_Syntax_Syntax.letbinding -> Prims.bool) = + fun g -> + fun lb -> + let uu___ = + FStarC_Syntax_Util.is_pure_effect lb.FStarC_Syntax_Syntax.lbeff in + if uu___ + then + let uu___1 = + FStarC_Syntax_Util.arrow_formals_comp_ln + lb.FStarC_Syntax_Syntax.lbtyp in + match uu___1 with + | (bs, c) -> + let c_eff_name = + let uu___2 = FStarC_Extraction_ML_UEnv.tcenv_of_uenv g in + FStarC_TypeChecker_Env.norm_eff_name uu___2 + (FStarC_Syntax_Util.comp_effect_name c) in + FStarC_Ident.lid_equals c_eff_name + FStarC_Parser_Const.effect_TAC_lid + else false +let rec (extract_sig : + env_t -> + FStarC_Syntax_Syntax.sigelt -> + (env_t * FStarC_Extraction_ML_Syntax.mlmodule1 Prims.list)) + = + fun g -> + fun se -> + let uu___ = + let uu___1 = FStarC_Syntax_Print.sigelt_to_string_short se in + FStarC_Compiler_Util.format1 + "While extracting top-level definition `%s`" uu___1 in + FStarC_Errors.with_ctx uu___ + (fun uu___1 -> + FStarC_Extraction_ML_UEnv.debug g + (fun u -> + let uu___3 = FStarC_Syntax_Print.sigelt_to_string_short se in + FStarC_Compiler_Util.print1 ">>>> extract_sig %s \n" uu___3); + (let uu___3 = sigelt_has_noextract se in + if uu___3 + then let g1 = mark_sigelt_erased se g in (g1, []) + else + (let se1 = karamel_fixup_qual se in + let se2 = fixup_sigelt_extract_as se1 in + match se2.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_bundle uu___5 -> + let uu___6 = extract_bundle g se2 in + (match uu___6 with + | (g1, ses) -> + let uu___7 = + let uu___8 = + FStarC_Extraction_ML_RegEmb.maybe_register_plugin + g1 se2 in + FStarC_Compiler_List.op_At ses uu___8 in + (g1, uu___7)) + | FStarC_Syntax_Syntax.Sig_inductive_typ uu___5 -> + let uu___6 = extract_bundle g se2 in + (match uu___6 with + | (g1, ses) -> + let uu___7 = + let uu___8 = + FStarC_Extraction_ML_RegEmb.maybe_register_plugin + g1 se2 in + FStarC_Compiler_List.op_At ses uu___8 in + (g1, uu___7)) + | FStarC_Syntax_Syntax.Sig_datacon uu___5 -> + let uu___6 = extract_bundle g se2 in + (match uu___6 with + | (g1, ses) -> + let uu___7 = + let uu___8 = + FStarC_Extraction_ML_RegEmb.maybe_register_plugin + g1 se2 in + FStarC_Compiler_List.op_At ses uu___8 in + (g1, uu___7)) + | FStarC_Syntax_Syntax.Sig_new_effect ed when + let uu___5 = FStarC_Extraction_ML_UEnv.tcenv_of_uenv g in + FStarC_TypeChecker_Env.is_reifiable_effect uu___5 + ed.FStarC_Syntax_Syntax.mname + -> + let uu___5 = extract_reifiable_effect g ed in + (match uu___5 with | (env, _iface, impl) -> (env, impl)) + | FStarC_Syntax_Syntax.Sig_splice uu___5 -> + failwith "impossible: trying to extract splice" + | FStarC_Syntax_Syntax.Sig_fail uu___5 -> + failwith "impossible: trying to extract Sig_fail" + | FStarC_Syntax_Syntax.Sig_new_effect uu___5 -> (g, []) + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (uu___5, lbs); + FStarC_Syntax_Syntax.lids1 = uu___6;_} + when FStarC_Compiler_List.for_all (lb_is_irrelevant g) lbs + -> (g, []) + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (uu___5, lbs); + FStarC_Syntax_Syntax.lids1 = uu___6;_} + when + (let uu___7 = FStarC_Options.codegen () in + uu___7 <> + (FStar_Pervasives_Native.Some FStarC_Options.Plugin)) + && (FStarC_Compiler_List.for_all (lb_is_tactic g) lbs) + -> (g, []) + | FStarC_Syntax_Syntax.Sig_declare_typ + { FStarC_Syntax_Syntax.lid2 = lid; + FStarC_Syntax_Syntax.us2 = univs; + FStarC_Syntax_Syntax.t2 = t;_} + when FStarC_Extraction_ML_Term.is_arity g t -> + let uu___5 = + extract_type_declaration g false lid + se2.FStarC_Syntax_Syntax.sigquals + se2.FStarC_Syntax_Syntax.sigattrs univs t in + (match uu___5 with | (env, uu___6, impl) -> (env, impl)) + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (false, lb::[]); + FStarC_Syntax_Syntax.lids1 = uu___5;_} + when + FStarC_Extraction_ML_Term.is_arity g + lb.FStarC_Syntax_Syntax.lbtyp + -> + let uu___6 = + FStarC_Compiler_Util.for_some + (fun uu___7 -> + match uu___7 with + | FStarC_Syntax_Syntax.Projector uu___8 -> true + | uu___8 -> false) + se2.FStarC_Syntax_Syntax.sigquals in + if uu___6 + then (g, []) + else + (let uu___8 = + extract_typ_abbrev g + se2.FStarC_Syntax_Syntax.sigquals + se2.FStarC_Syntax_Syntax.sigattrs lb in + match uu___8 with | (env, uu___9, impl) -> (env, impl)) + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (true, lbs); + FStarC_Syntax_Syntax.lids1 = uu___5;_} + when should_split_let_rec_types_and_terms g lbs -> + let ses = split_let_rec_types_and_terms se2 g lbs in + FStarC_Compiler_List.fold_left + (fun uu___6 -> + fun se3 -> + match uu___6 with + | (g1, out) -> + let uu___7 = extract_sig g1 se3 in + (match uu___7 with + | (g2, mls) -> + (g2, (FStarC_Compiler_List.op_At out mls)))) + (g, []) ses + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (true, lbs); + FStarC_Syntax_Syntax.lids1 = uu___5;_} + when + FStarC_Compiler_Util.for_some + (fun lb -> + FStarC_Extraction_ML_Term.is_arity g + lb.FStarC_Syntax_Syntax.lbtyp) lbs + -> + let uu___6 = extract_let_rec_types se2 g lbs in + (match uu___6 with | (env, uu___7, impl) -> (env, impl)) + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (false, lb::[]); + FStarC_Syntax_Syntax.lids1 = uu___5;_} + when + Prims.uu___is_Cons + (se2.FStarC_Syntax_Syntax.sigmeta).FStarC_Syntax_Syntax.sigmeta_extension_data + -> + let uu___6 = + FStarC_Compiler_List.tryPick + (fun uu___7 -> + match uu___7 with + | (ext, blob) -> + let uu___8 = lookup_extension_extractor ext in + (match uu___8 with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some extractor -> + FStar_Pervasives_Native.Some + (ext, blob, extractor))) + (se2.FStarC_Syntax_Syntax.sigmeta).FStarC_Syntax_Syntax.sigmeta_extension_data in + (match uu___6 with + | FStar_Pervasives_Native.None -> extract_sig_let g se2 + | FStar_Pervasives_Native.Some (ext, blob, extractor) -> + let uu___7 = extractor.extract_sigelt g se2 blob in + (match uu___7 with + | FStar_Pervasives.Inl decls -> + let meta = + extract_metadata + se2.FStarC_Syntax_Syntax.sigattrs in + let mlattrs = + extract_attrs g + se2.FStarC_Syntax_Syntax.sigattrs in + FStarC_Compiler_List.fold_left + (fun uu___8 -> + fun d -> + match uu___8 with + | (g1, decls1) -> + (match d.FStarC_Extraction_ML_Syntax.mlmodule1_m + with + | FStarC_Extraction_ML_Syntax.MLM_Let + (maybe_rec, mllb::[]) -> + let uu___9 = + let uu___10 = + FStarC_Compiler_Util.must + mllb.FStarC_Extraction_ML_Syntax.mllb_tysc in + FStarC_Extraction_ML_UEnv.extend_lb + g1 + lb.FStarC_Syntax_Syntax.lbname + lb.FStarC_Syntax_Syntax.lbtyp + uu___10 + mllb.FStarC_Extraction_ML_Syntax.mllb_add_unit in + (match uu___9 with + | (g2, mlid, uu___10) -> + let mllb1 = + { + FStarC_Extraction_ML_Syntax.mllb_name + = mlid; + FStarC_Extraction_ML_Syntax.mllb_tysc + = + (mllb.FStarC_Extraction_ML_Syntax.mllb_tysc); + FStarC_Extraction_ML_Syntax.mllb_add_unit + = + (mllb.FStarC_Extraction_ML_Syntax.mllb_add_unit); + FStarC_Extraction_ML_Syntax.mllb_def + = + (mllb.FStarC_Extraction_ML_Syntax.mllb_def); + FStarC_Extraction_ML_Syntax.mllb_attrs + = mlattrs; + FStarC_Extraction_ML_Syntax.mllb_meta + = meta; + FStarC_Extraction_ML_Syntax.print_typ + = + (mllb.FStarC_Extraction_ML_Syntax.print_typ) + } in + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Extraction_ML_Syntax.mk_mlmodule1_with_attrs + (FStarC_Extraction_ML_Syntax.MLM_Let + (maybe_rec, + [mllb1])) + mlattrs in + [uu___13] in + FStarC_Compiler_List.op_At + decls1 uu___12 in + (g2, uu___11)) + | uu___9 -> + let uu___10 = + let uu___11 = + FStarC_Class_Show.show + FStarC_Extraction_ML_Syntax.showable_mlmodule1 + d in + FStarC_Compiler_Util.format1 + "Unexpected ML decl returned by the extension: %s" + uu___11 in + failwith uu___10)) (g, []) decls + | FStar_Pervasives.Inr err -> + let uu___8 = + FStarC_Compiler_Util.format2 + "Extension %s failed to extract term: %s" + ext err in + FStarC_Errors.raise_error + FStarC_Syntax_Syntax.has_range_sigelt se2 + FStarC_Errors_Codes.Fatal_ExtractionUnsupported + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___8))) + | FStarC_Syntax_Syntax.Sig_let uu___5 -> extract_sig_let g se2 + | FStarC_Syntax_Syntax.Sig_declare_typ + { FStarC_Syntax_Syntax.lid2 = lid; + FStarC_Syntax_Syntax.us2 = uu___5; + FStarC_Syntax_Syntax.t2 = t;_} + -> + let quals = se2.FStarC_Syntax_Syntax.sigquals in + let uu___6 = + (FStarC_Compiler_List.contains + FStarC_Syntax_Syntax.Assumption quals) + && + (let uu___7 = + let uu___8 = + FStarC_Extraction_ML_UEnv.tcenv_of_uenv g in + FStarC_TypeChecker_Util.must_erase_for_extraction + uu___8 t in + Prims.op_Negation uu___7) in + if uu___6 + then + let always_fail1 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = always_fail lid t in [uu___11] in + (false, uu___10) in + { + FStarC_Syntax_Syntax.lbs1 = uu___9; + FStarC_Syntax_Syntax.lids1 = [] + } in + FStarC_Syntax_Syntax.Sig_let uu___8 in + { + FStarC_Syntax_Syntax.sigel = uu___7; + FStarC_Syntax_Syntax.sigrng = + (se2.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se2.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se2.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se2.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se2.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se2.FStarC_Syntax_Syntax.sigopts) + } in + let uu___7 = extract_sig g always_fail1 in + (match uu___7 with + | (g1, mlm) -> + let uu___8 = + FStarC_Compiler_Util.find_map quals + (fun uu___9 -> + match uu___9 with + | FStarC_Syntax_Syntax.Discriminator l -> + FStar_Pervasives_Native.Some l + | uu___10 -> FStar_Pervasives_Native.None) in + (match uu___8 with + | FStar_Pervasives_Native.Some l -> + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Extraction_ML_Util.mlloc_of_range + se2.FStarC_Syntax_Syntax.sigrng in + FStarC_Extraction_ML_Syntax.MLM_Loc + uu___12 in + FStarC_Extraction_ML_Syntax.mk_mlmodule1 + uu___11 in + let uu___11 = + let uu___12 = + FStarC_Extraction_ML_Term.ind_discriminator_body + g1 lid l in + [uu___12] in + uu___10 :: uu___11 in + (g1, uu___9) + | uu___9 -> + let uu___10 = + FStarC_Compiler_Util.find_map quals + (fun uu___11 -> + match uu___11 with + | FStarC_Syntax_Syntax.Projector + (l, uu___12) -> + FStar_Pervasives_Native.Some l + | uu___12 -> + FStar_Pervasives_Native.None) in + (match uu___10 with + | FStar_Pervasives_Native.Some uu___11 -> + (g1, []) + | uu___11 -> (g1, mlm)))) + else (g, []) + | FStarC_Syntax_Syntax.Sig_assume uu___5 -> (g, []) + | FStarC_Syntax_Syntax.Sig_sub_effect uu___5 -> (g, []) + | FStarC_Syntax_Syntax.Sig_effect_abbrev uu___5 -> (g, []) + | FStarC_Syntax_Syntax.Sig_polymonadic_bind uu___5 -> (g, []) + | FStarC_Syntax_Syntax.Sig_polymonadic_subcomp uu___5 -> + (g, []) + | FStarC_Syntax_Syntax.Sig_pragma p -> + (FStarC_Syntax_Util.process_pragma p + se2.FStarC_Syntax_Syntax.sigrng; + (g, []))))) +and (extract_sig_let : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.sigelt -> + (FStarC_Extraction_ML_UEnv.uenv * FStarC_Extraction_ML_Syntax.mlmodule1 + Prims.list)) + = + fun g -> + fun se -> + if + Prims.op_Negation + (FStarC_Syntax_Syntax.uu___is_Sig_let se.FStarC_Syntax_Syntax.sigel) + then failwith "Impossible: should only be called with Sig_let" + else + (let uu___1 = se.FStarC_Syntax_Syntax.sigel in + match uu___1 with + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = lbs; + FStarC_Syntax_Syntax.lids1 = uu___2;_} + -> + let attrs = se.FStarC_Syntax_Syntax.sigattrs in + let quals = se.FStarC_Syntax_Syntax.sigquals in + let maybe_postprocess_lbs lbs1 = + let post_tau = + let uu___3 = + FStarC_Syntax_Util.extract_attr' + FStarC_Parser_Const.postprocess_extr_with attrs in + match uu___3 with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some + (uu___4, (tau, FStar_Pervasives_Native.None)::uu___5) -> + FStar_Pervasives_Native.Some tau + | FStar_Pervasives_Native.Some uu___4 -> + (FStarC_Errors.log_issue + FStarC_Syntax_Syntax.has_range_sigelt se + FStarC_Errors_Codes.Warning_UnrecognizedAttribute () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Ill-formed application of 'postprocess_for_extraction_with'"); + FStar_Pervasives_Native.None) in + let postprocess_lb tau lb = + let env = FStarC_Extraction_ML_UEnv.tcenv_of_uenv g in + let lbdef = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_TypeChecker_Env.current_module env in + FStarC_Ident.string_of_lid uu___5 in + FStar_Pervasives_Native.Some uu___4 in + FStarC_Profiling.profile + (fun uu___4 -> + FStarC_TypeChecker_Env.postprocess env tau + lb.FStarC_Syntax_Syntax.lbtyp + lb.FStarC_Syntax_Syntax.lbdef) uu___3 + "FStarC.Extraction.ML.Module.post_process_for_extraction" in + { + FStarC_Syntax_Syntax.lbname = + (lb.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = + (lb.FStarC_Syntax_Syntax.lbtyp); + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = lbdef; + FStarC_Syntax_Syntax.lbattrs = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + } in + match post_tau with + | FStar_Pervasives_Native.None -> lbs1 + | FStar_Pervasives_Native.Some tau -> + let uu___3 = + FStarC_Compiler_List.map (postprocess_lb tau) + (FStar_Pervasives_Native.snd lbs1) in + ((FStar_Pervasives_Native.fst lbs1), uu___3) in + let maybe_normalize_for_extraction lbs1 = + let norm_steps = + let uu___3 = + FStarC_Syntax_Util.extract_attr' + FStarC_Parser_Const.normalize_for_extraction_lid attrs in + match uu___3 with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some + (uu___4, (steps, FStar_Pervasives_Native.None)::uu___5) + -> + let steps1 = + let uu___6 = FStarC_Extraction_ML_UEnv.tcenv_of_uenv g in + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.Zeta; + FStarC_TypeChecker_Env.Iota; + FStarC_TypeChecker_Env.Primops] uu___6 steps in + let uu___6 = + FStarC_TypeChecker_Primops_Base.try_unembed_simple + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_norm_step) steps1 in + (match uu___6 with + | FStar_Pervasives_Native.Some steps2 -> + let uu___7 = + FStarC_TypeChecker_Cfg.translate_norm_steps + steps2 in + FStar_Pervasives_Native.Some uu___7 + | uu___7 -> + ((let uu___9 = + let uu___10 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term steps1 in + FStarC_Compiler_Util.format1 + "Ill-formed application of 'normalize_for_extraction': normalization steps '%s' could not be interpreted" + uu___10 in + FStarC_Errors.log_issue + FStarC_Syntax_Syntax.has_range_sigelt se + FStarC_Errors_Codes.Warning_UnrecognizedAttribute + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___9)); + FStar_Pervasives_Native.None)) + | FStar_Pervasives_Native.Some uu___4 -> + (FStarC_Errors.log_issue + FStarC_Syntax_Syntax.has_range_sigelt se + FStarC_Errors_Codes.Warning_UnrecognizedAttribute () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Ill-formed application of 'normalize_for_extraction'"); + FStar_Pervasives_Native.None) in + let norm_one_lb steps lb = + let env = FStarC_Extraction_ML_UEnv.tcenv_of_uenv g in + let env1 = + { + FStarC_TypeChecker_Env.solver = + (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = true; + FStarC_TypeChecker_Env.core_check = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env.FStarC_TypeChecker_Env.missing_decl) + } in + let lbd = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_TypeChecker_Env.current_module env1 in + FStarC_Ident.string_of_lid uu___5 in + FStar_Pervasives_Native.Some uu___4 in + FStarC_Profiling.profile + (fun uu___4 -> + FStarC_TypeChecker_Normalize.normalize steps env1 + lb.FStarC_Syntax_Syntax.lbdef) uu___3 + "FStarC.Extraction.ML.Module.normalize_for_extraction" in + { + FStarC_Syntax_Syntax.lbname = + (lb.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = + (lb.FStarC_Syntax_Syntax.lbtyp); + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = lbd; + FStarC_Syntax_Syntax.lbattrs = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + } in + match norm_steps with + | FStar_Pervasives_Native.None -> lbs1 + | FStar_Pervasives_Native.Some steps -> + let uu___3 = + FStarC_Compiler_List.map (norm_one_lb steps) + (FStar_Pervasives_Native.snd lbs1) in + ((FStar_Pervasives_Native.fst lbs1), uu___3) in + let uu___3 = + let lbs1 = + let uu___4 = maybe_postprocess_lbs lbs in + maybe_normalize_for_extraction uu___4 in + let uu___4 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = lbs1; + FStarC_Syntax_Syntax.body1 = + FStarC_Syntax_Util.exp_false_bool + }) se.FStarC_Syntax_Syntax.sigrng in + FStarC_Extraction_ML_Term.term_as_mlexpr g uu___4 in + (match uu___3 with + | (ml_let, uu___4, uu___5) -> + let mlattrs = + extract_attrs g se.FStarC_Syntax_Syntax.sigattrs in + (match ml_let.FStarC_Extraction_ML_Syntax.expr with + | FStarC_Extraction_ML_Syntax.MLE_Let + ((flavor, bindings), uu___6) -> + let flags = + FStarC_Compiler_List.choose flag_of_qual quals in + let flags' = extract_metadata attrs in + let uu___7 = + FStarC_Compiler_List.fold_left2 + (fun uu___8 -> + fun ml_lb -> + fun uu___9 -> + match (uu___8, uu___9) with + | ((env, ml_lbs), + { FStarC_Syntax_Syntax.lbname = lbname; + FStarC_Syntax_Syntax.lbunivs = uu___10; + FStarC_Syntax_Syntax.lbtyp = t; + FStarC_Syntax_Syntax.lbeff = uu___11; + FStarC_Syntax_Syntax.lbdef = uu___12; + FStarC_Syntax_Syntax.lbattrs = uu___13; + FStarC_Syntax_Syntax.lbpos = uu___14;_}) + -> + if + FStarC_Compiler_List.contains + FStarC_Extraction_ML_Syntax.Erased + ml_lb.FStarC_Extraction_ML_Syntax.mllb_meta + then (env, ml_lbs) + else + (let lb_lid = + let uu___16 = + let uu___17 = + FStarC_Compiler_Util.right + lbname in + uu___17.FStarC_Syntax_Syntax.fv_name in + uu___16.FStarC_Syntax_Syntax.v in + let flags'' = + let uu___16 = + let uu___17 = + FStarC_Syntax_Subst.compress t in + uu___17.FStarC_Syntax_Syntax.n in + match uu___16 with + | FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 = + uu___17; + FStarC_Syntax_Syntax.comp = + { + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Comp + { + FStarC_Syntax_Syntax.comp_univs + = uu___18; + FStarC_Syntax_Syntax.effect_name + = e; + FStarC_Syntax_Syntax.result_typ + = uu___19; + FStarC_Syntax_Syntax.effect_args + = uu___20; + FStarC_Syntax_Syntax.flags + = uu___21;_}; + FStarC_Syntax_Syntax.pos + = uu___22; + FStarC_Syntax_Syntax.vars + = uu___23; + FStarC_Syntax_Syntax.hash_code + = uu___24;_};_} + when + let uu___25 = + FStarC_Ident.string_of_lid e in + uu___25 = + "FStar.HyperStack.ST.StackInline" + -> + [FStarC_Extraction_ML_Syntax.StackInline] + | uu___17 -> [] in + let meta = + FStarC_Compiler_List.op_At flags + (FStarC_Compiler_List.op_At + flags' flags'') in + let ml_lb1 = + { + FStarC_Extraction_ML_Syntax.mllb_name + = + (ml_lb.FStarC_Extraction_ML_Syntax.mllb_name); + FStarC_Extraction_ML_Syntax.mllb_tysc + = + (ml_lb.FStarC_Extraction_ML_Syntax.mllb_tysc); + FStarC_Extraction_ML_Syntax.mllb_add_unit + = + (ml_lb.FStarC_Extraction_ML_Syntax.mllb_add_unit); + FStarC_Extraction_ML_Syntax.mllb_def + = + (ml_lb.FStarC_Extraction_ML_Syntax.mllb_def); + FStarC_Extraction_ML_Syntax.mllb_attrs + = mlattrs; + FStarC_Extraction_ML_Syntax.mllb_meta + = meta; + FStarC_Extraction_ML_Syntax.print_typ + = + (ml_lb.FStarC_Extraction_ML_Syntax.print_typ) + } in + let uu___16 = + let uu___17 = + FStarC_Compiler_Util.for_some + (fun uu___18 -> + match uu___18 with + | FStarC_Syntax_Syntax.Projector + uu___19 -> true + | uu___19 -> false) quals in + if uu___17 + then + let uu___18 = + let uu___19 = + FStarC_Compiler_Util.right + lbname in + let uu___20 = + FStarC_Compiler_Util.must + ml_lb1.FStarC_Extraction_ML_Syntax.mllb_tysc in + FStarC_Extraction_ML_UEnv.extend_fv + env uu___19 uu___20 + ml_lb1.FStarC_Extraction_ML_Syntax.mllb_add_unit in + match uu___18 with + | (env1, mls, uu___19) -> + (env1, + { + FStarC_Extraction_ML_Syntax.mllb_name + = mls; + FStarC_Extraction_ML_Syntax.mllb_tysc + = + (ml_lb1.FStarC_Extraction_ML_Syntax.mllb_tysc); + FStarC_Extraction_ML_Syntax.mllb_add_unit + = + (ml_lb1.FStarC_Extraction_ML_Syntax.mllb_add_unit); + FStarC_Extraction_ML_Syntax.mllb_def + = + (ml_lb1.FStarC_Extraction_ML_Syntax.mllb_def); + FStarC_Extraction_ML_Syntax.mllb_attrs + = + (ml_lb1.FStarC_Extraction_ML_Syntax.mllb_attrs); + FStarC_Extraction_ML_Syntax.mllb_meta + = + (ml_lb1.FStarC_Extraction_ML_Syntax.mllb_meta); + FStarC_Extraction_ML_Syntax.print_typ + = + (ml_lb1.FStarC_Extraction_ML_Syntax.print_typ) + }) + else + (let uu___19 = + let uu___20 = + FStarC_Compiler_Util.must + ml_lb1.FStarC_Extraction_ML_Syntax.mllb_tysc in + FStarC_Extraction_ML_UEnv.extend_lb + env lbname t uu___20 + ml_lb1.FStarC_Extraction_ML_Syntax.mllb_add_unit in + match uu___19 with + | (env1, uu___20, uu___21) -> + (env1, ml_lb1)) in + match uu___16 with + | (g1, ml_lb2) -> + (g1, (ml_lb2 :: ml_lbs)))) + (g, []) bindings (FStar_Pervasives_Native.snd lbs) in + (match uu___7 with + | (g1, ml_lbs') -> + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Extraction_ML_Util.mlloc_of_range + se.FStarC_Syntax_Syntax.sigrng in + FStarC_Extraction_ML_Syntax.MLM_Loc + uu___12 in + FStarC_Extraction_ML_Syntax.mk_mlmodule1 + uu___11 in + let uu___11 = + let uu___12 = + FStarC_Extraction_ML_Syntax.mk_mlmodule1_with_attrs + (FStarC_Extraction_ML_Syntax.MLM_Let + (flavor, + (FStarC_Compiler_List.rev ml_lbs'))) + mlattrs in + [uu___12] in + uu___10 :: uu___11 in + let uu___10 = + FStarC_Extraction_ML_RegEmb.maybe_register_plugin + g1 se in + FStarC_Compiler_List.op_At uu___9 uu___10 in + (g1, uu___8)) + | uu___6 -> + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Extraction_ML_UEnv.current_module_of_uenv + g in + FStarC_Extraction_ML_Code.string_of_mlexpr uu___9 + ml_let in + FStarC_Compiler_Util.format1 + "Impossible: Translated a let to a non-let: %s" + uu___8 in + failwith uu___7))) +let (extract' : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.modul -> + (FStarC_Extraction_ML_UEnv.uenv * FStarC_Extraction_ML_Syntax.mllib + FStar_Pervasives_Native.option)) + = + fun g -> + fun m -> + let uu___ = FStarC_Options.restore_cmd_line_options true in + let uu___1 = + FStarC_Extraction_ML_UEnv.extend_with_module_name g + m.FStarC_Syntax_Syntax.name in + match uu___1 with + | (name, g1) -> + let g2 = + let uu___2 = + let uu___3 = FStarC_Extraction_ML_UEnv.tcenv_of_uenv g1 in + FStarC_TypeChecker_Env.set_current_module uu___3 + m.FStarC_Syntax_Syntax.name in + FStarC_Extraction_ML_UEnv.set_tcenv g1 uu___2 in + let g3 = FStarC_Extraction_ML_UEnv.set_current_module g2 name in + let uu___2 = + FStarC_Compiler_Util.fold_map + (fun g4 -> + fun se -> + let uu___3 = FStarC_Compiler_Debug.any () in + if uu___3 + then + let nm = + let uu___4 = + FStarC_Compiler_List.map FStarC_Ident.string_of_lid + (FStarC_Syntax_Util.lids_of_sigelt se) in + FStarC_Compiler_String.concat ", " uu___4 in + (FStarC_Compiler_Util.print1 + "+++About to extract {%s}\n" nm; + (let r = + let uu___5 = + FStarC_Compiler_Util.format1 "---Extracted {%s}" + nm in + FStarC_Compiler_Util.measure_execution_time uu___5 + (fun uu___6 -> extract_sig g4 se) in + (let uu___6 = + FStarC_Class_Show.show + FStarC_Extraction_ML_Syntax.showable_mlmodule + (FStar_Pervasives_Native.snd r) in + FStarC_Compiler_Util.print1 "Extraction result: %s\n" + uu___6); + r)) + else extract_sig g4 se) g3 + m.FStarC_Syntax_Syntax.declarations in + (match uu___2 with + | (g4, sigs) -> + let mlm = FStarC_Compiler_List.flatten sigs in + let is_karamel = + let uu___3 = FStarC_Options.codegen () in + uu___3 = (FStar_Pervasives_Native.Some FStarC_Options.Krml) in + let uu___3 = + (let uu___4 = + FStarC_Ident.string_of_lid m.FStarC_Syntax_Syntax.name in + uu___4 <> "Prims") && + (is_karamel || + (Prims.op_Negation m.FStarC_Syntax_Syntax.is_interface)) in + if uu___3 + then + ((let uu___5 = + let uu___6 = FStarC_Options.silent () in + Prims.op_Negation uu___6 in + if uu___5 + then + let uu___6 = + FStarC_Ident.string_of_lid m.FStarC_Syntax_Syntax.name in + FStarC_Compiler_Util.print1 "Extracted module %s\n" + uu___6 + else ()); + (g4, + (FStar_Pervasives_Native.Some + (FStarC_Extraction_ML_Syntax.MLLib + [(name, (FStar_Pervasives_Native.Some ([], mlm)), + (FStarC_Extraction_ML_Syntax.MLLib []))])))) + else (g4, FStar_Pervasives_Native.None)) +let (extract : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.modul -> + (FStarC_Extraction_ML_UEnv.uenv * FStarC_Extraction_ML_Syntax.mllib + FStar_Pervasives_Native.option)) + = + fun g -> + fun m -> + (let uu___1 = FStarC_Options.restore_cmd_line_options true in ()); + (let tgt = + let uu___1 = FStarC_Options.codegen () in + match uu___1 with + | FStar_Pervasives_Native.None -> + failwith "Impossible: We're in extract, codegen must be set!" + | FStar_Pervasives_Native.Some t -> t in + (let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Ident.string_of_lid m.FStarC_Syntax_Syntax.name in + FStarC_Options.should_extract uu___4 tgt in + Prims.op_Negation uu___3 in + if uu___2 + then + let uu___3 = + let uu___4 = + FStarC_Ident.string_of_lid m.FStarC_Syntax_Syntax.name in + FStarC_Compiler_Util.format1 + "Extract called on a module %s that should not be extracted" + uu___4 in + failwith uu___3 + else ()); + (let uu___2 = FStarC_Options.interactive () in + if uu___2 + then (g, FStar_Pervasives_Native.None) + else + (let nm = FStarC_Ident.string_of_lid m.FStarC_Syntax_Syntax.name in + let uu___4 = + FStarC_Syntax_Unionfind.with_uf_enabled + (fun uu___5 -> + FStarC_Errors.with_ctx + (Prims.strcat "While extracting module " nm) + (fun uu___6 -> + FStarC_Profiling.profile (fun uu___7 -> extract' g m) + (FStar_Pervasives_Native.Some nm) + "FStarC.Extraction.ML.Modul.extract")) in + match uu___4 with + | (g1, mllib) -> + let uu___5 = + match mllib with + | FStar_Pervasives_Native.None -> (g1, mllib) + | FStar_Pervasives_Native.Some mllib1 -> + let uu___6 = + FStarC_Extraction_ML_UEnv.with_typars_env g1 + (fun e -> + FStarC_Extraction_ML_RemoveUnusedParameters.elim_mllib + e mllib1) in + (match uu___6 with + | (g2, mllib2) -> + (g2, (FStar_Pervasives_Native.Some mllib2))) in + (match uu___5 with + | (g2, mllib1) -> + ((let uu___7 = + FStarC_Options.restore_cmd_line_options true in + ()); + (let uu___7 = FStarC_Extraction_ML_UEnv.exit_module g2 in + (uu___7, mllib1))))))) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Extraction_ML_RegEmb.ml b/ocaml/fstar-lib/generated/FStarC_Extraction_ML_RegEmb.ml new file mode 100644 index 00000000000..641bc0fdc1b --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Extraction_ML_RegEmb.ml @@ -0,0 +1,2419 @@ +open Prims +exception NoEmbedding of Prims.string +let (uu___is_NoEmbedding : Prims.exn -> Prims.bool) = + fun projectee -> + match projectee with | NoEmbedding uu___ -> true | uu___ -> false +let (__proj__NoEmbedding__item__uu___ : Prims.exn -> Prims.string) = + fun projectee -> match projectee with | NoEmbedding uu___ -> uu___ +exception Unsupported of Prims.string +let (uu___is_Unsupported : Prims.exn -> Prims.bool) = + fun projectee -> + match projectee with | Unsupported uu___ -> true | uu___ -> false +let (__proj__Unsupported__item__uu___ : Prims.exn -> Prims.string) = + fun projectee -> match projectee with | Unsupported uu___ -> uu___ +let splitlast : 'uuuuu . 'uuuuu Prims.list -> ('uuuuu Prims.list * 'uuuuu) = + fun s -> + let uu___ = FStarC_Compiler_List.rev s in + match uu___ with | x::xs -> ((FStarC_Compiler_List.rev xs), x) +let (mk : + FStarC_Extraction_ML_Syntax.mlexpr' -> FStarC_Extraction_ML_Syntax.mlexpr) + = + fun e -> + FStarC_Extraction_ML_Syntax.with_ty FStarC_Extraction_ML_Syntax.MLTY_Top + e +let (ml_name : FStarC_Ident.lid -> FStarC_Extraction_ML_Syntax.mlexpr) = + fun l -> + let s = FStarC_Ident.path_of_lid l in + let uu___ = splitlast s in + match uu___ with + | (ns, id) -> mk (FStarC_Extraction_ML_Syntax.MLE_Name (ns, id)) +let (ml_name' : Prims.string -> FStarC_Extraction_ML_Syntax.mlexpr) = + fun s -> let uu___ = FStarC_Ident.lid_of_str s in ml_name uu___ +let (ml_ctor : + FStarC_Ident.lid -> + FStarC_Extraction_ML_Syntax.mlexpr Prims.list -> + FStarC_Extraction_ML_Syntax.mlexpr) + = + fun l -> + fun args -> + let s = FStarC_Ident.path_of_lid l in + let uu___ = splitlast s in + match uu___ with + | (ns, id) -> + mk (FStarC_Extraction_ML_Syntax.MLE_CTor ((ns, id), args)) +let (ml_record : + FStarC_Ident.lid -> + (Prims.string * FStarC_Extraction_ML_Syntax.mlexpr) Prims.list -> + FStarC_Extraction_ML_Syntax.mlexpr) + = + fun l -> + fun args -> + let s = FStarC_Ident.path_of_lid l in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Ident.ident_of_lid l in + FStarC_Ident.string_of_id uu___3 in + ([], uu___2, args) in + FStarC_Extraction_ML_Syntax.MLE_Record uu___1 in + mk uu___ +let (mk_binder : + FStarC_Extraction_ML_Syntax.mlident -> + FStarC_Extraction_ML_Syntax.mlty -> FStarC_Extraction_ML_Syntax.mlbinder) + = + fun x -> + fun t -> + { + FStarC_Extraction_ML_Syntax.mlbinder_name = x; + FStarC_Extraction_ML_Syntax.mlbinder_ty = t; + FStarC_Extraction_ML_Syntax.mlbinder_attrs = [] + } +let (ml_lam : + FStarC_Extraction_ML_Syntax.mlident -> + FStarC_Extraction_ML_Syntax.mlexpr -> FStarC_Extraction_ML_Syntax.mlexpr) + = + fun nm -> + fun e -> + mk + (FStarC_Extraction_ML_Syntax.MLE_Fun + ([mk_binder nm FStarC_Extraction_ML_Syntax.MLTY_Top], e)) +let (ml_none : FStarC_Extraction_ML_Syntax.mlexpr) = + mk + (FStarC_Extraction_ML_Syntax.MLE_Name + (["FStar"; "Pervasives"; "Native"], "None")) +let (ml_some : FStarC_Extraction_ML_Syntax.mlexpr) = + mk + (FStarC_Extraction_ML_Syntax.MLE_Name + (["FStar"; "Pervasives"; "Native"], "Some")) +let (s_tdataconstr : FStarC_Extraction_ML_Syntax.mlexpr) = + mk + (FStarC_Extraction_ML_Syntax.MLE_Name + (splitlast ["FStarC"; "Syntax"; "Syntax"; "tdataconstr"])) +let (mk_app : FStarC_Extraction_ML_Syntax.mlexpr) = + mk + (FStarC_Extraction_ML_Syntax.MLE_Name + (splitlast ["FStarC"; "Syntax"; "Util"; "mk_app"])) +let (tm_fvar : FStarC_Extraction_ML_Syntax.mlexpr) = + mk + (FStarC_Extraction_ML_Syntax.MLE_Name + (splitlast ["FStarC"; "Syntax"; "Syntax"; "Tm_fvar"])) +let (fv_eq_lid : FStarC_Extraction_ML_Syntax.mlexpr) = + mk + (FStarC_Extraction_ML_Syntax.MLE_Name + (splitlast ["FStarC"; "Syntax"; "Syntax"; "fv_eq_lid"])) +let (lid_of_str : FStarC_Extraction_ML_Syntax.mlexpr) = + mk + (FStarC_Extraction_ML_Syntax.MLE_Name + (splitlast ["FStarC"; "Ident"; "lid_of_str"])) +let (nil_lid : FStarC_Ident.lident) = FStarC_Ident.lid_of_str "Prims.Nil" +let (cons_lid : FStarC_Ident.lident) = FStarC_Ident.lid_of_str "Prims.Cons" +let (embed : FStarC_Extraction_ML_Syntax.mlexpr) = + mk + (FStarC_Extraction_ML_Syntax.MLE_Name + (splitlast + ["FStarC"; "Syntax"; "Embeddings"; "Base"; "extracted_embed"])) +let (unembed : FStarC_Extraction_ML_Syntax.mlexpr) = + mk + (FStarC_Extraction_ML_Syntax.MLE_Name + (splitlast + ["FStarC"; "Syntax"; "Embeddings"; "Base"; "extracted_unembed"])) +let (bind_opt : FStarC_Extraction_ML_Syntax.mlexpr) = + mk + (FStarC_Extraction_ML_Syntax.MLE_Name + (splitlast ["FStarC"; "Compiler"; "Util"; "bind_opt"])) +let (ml_nbe_unsupported : FStarC_Extraction_ML_Syntax.mlexpr) = + let hd = + mk + (FStarC_Extraction_ML_Syntax.MLE_Name + (["FStarC"; "TypeChecker"; "NBETerm"], "e_unsupported")) in + mk + (FStarC_Extraction_ML_Syntax.MLE_App + (hd, [FStarC_Extraction_ML_Syntax.ml_unit])) +let (ml_magic : FStarC_Extraction_ML_Syntax.mlexpr) = + mk + (FStarC_Extraction_ML_Syntax.MLE_Coerce + (FStarC_Extraction_ML_Syntax.ml_unit, + FStarC_Extraction_ML_Syntax.MLTY_Top, + FStarC_Extraction_ML_Syntax.MLTY_Top)) +let (as_name : + FStarC_Extraction_ML_Syntax.mlpath -> FStarC_Extraction_ML_Syntax.mlexpr) = + fun mlp -> + FStarC_Extraction_ML_Syntax.with_ty FStarC_Extraction_ML_Syntax.MLTY_Top + (FStarC_Extraction_ML_Syntax.MLE_Name mlp) +let (ml_failwith : Prims.string -> FStarC_Extraction_ML_Syntax.mlexpr) = + fun s -> + let uu___ = + let uu___1 = + let uu___2 = as_name ([], "failwith") in + let uu___3 = + let uu___4 = + mk + (FStarC_Extraction_ML_Syntax.MLE_Const + (FStarC_Extraction_ML_Syntax.MLC_String s)) in + [uu___4] in + (uu___2, uu___3) in + FStarC_Extraction_ML_Syntax.MLE_App uu___1 in + mk uu___ +let rec (as_ml_list : + FStarC_Extraction_ML_Syntax.mlexpr Prims.list -> + FStarC_Extraction_ML_Syntax.mlexpr) + = + fun ts -> + match ts with + | [] -> ml_ctor nil_lid [] + | t::ts1 -> + let uu___ = + let uu___1 = let uu___2 = as_ml_list ts1 in [uu___2] in t :: uu___1 in + ml_ctor cons_lid uu___ +let rec (pats_to_list_pat : + FStarC_Extraction_ML_Syntax.mlpattern Prims.list -> + FStarC_Extraction_ML_Syntax.mlpattern) + = + fun vs -> + match vs with + | [] -> FStarC_Extraction_ML_Syntax.MLP_CTor ((["Prims"], "Nil"), []) + | p::ps -> + let uu___ = + let uu___1 = + let uu___2 = let uu___3 = pats_to_list_pat ps in [uu___3] in p :: + uu___2 in + ((["Prims"], "Cons"), uu___1) in + FStarC_Extraction_ML_Syntax.MLP_CTor uu___ +let (fresh : Prims.string -> Prims.string) = + let r = FStarC_Compiler_Util.mk_ref Prims.int_zero in + fun s -> + let v = FStarC_Compiler_Effect.op_Bang r in + FStarC_Compiler_Effect.op_Colon_Equals r (v + Prims.int_one); + Prims.strcat s (Prims.strcat "_" (Prims.string_of_int v)) +let (not_implemented_warning : + FStarC_Compiler_Range_Type.range -> Prims.string -> Prims.string -> unit) = + fun r -> + fun t -> + fun msg -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Compiler_Util.format1 + "Plugin `%s' can not run natively because:" t in + FStarC_Errors_Msg.text uu___3 in + let uu___3 = FStarC_Errors_Msg.text msg in + FStarC_Pprint.prefix (Prims.of_int (2)) Prims.int_one uu___2 + uu___3 in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Errors_Msg.text "Use --warn_error -" in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Errors.lookup + FStarC_Errors_Codes.Warning_PluginNotImplemented in + FStarC_Errors.error_number uu___8 in + FStarC_Class_PP.pp FStarC_Class_PP.pp_int uu___7 in + let uu___7 = FStarC_Errors_Msg.text "to carry on." in + FStarC_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in + FStarC_Pprint.op_Hat_Hat uu___4 uu___5 in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Errors.log_issue FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Warning_PluginNotImplemented () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___) +type embedding_data = + { + arity: Prims.int ; + syn_emb: FStarC_Ident.lid ; + nbe_emb: FStarC_Ident.lid FStar_Pervasives_Native.option } +let (__proj__Mkembedding_data__item__arity : embedding_data -> Prims.int) = + fun projectee -> + match projectee with | { arity; syn_emb; nbe_emb;_} -> arity +let (__proj__Mkembedding_data__item__syn_emb : + embedding_data -> FStarC_Ident.lid) = + fun projectee -> + match projectee with | { arity; syn_emb; nbe_emb;_} -> syn_emb +let (__proj__Mkembedding_data__item__nbe_emb : + embedding_data -> FStarC_Ident.lid FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with | { arity; syn_emb; nbe_emb;_} -> nbe_emb +let (builtin_embeddings : (FStarC_Ident.lident * embedding_data) Prims.list) + = + let syn_emb_lid s = + FStarC_Ident.lid_of_path ["FStarC"; "Syntax"; "Embeddings"; s] + FStarC_Compiler_Range_Type.dummyRange in + let nbe_emb_lid s = + FStarC_Ident.lid_of_path ["FStarC"; "TypeChecker"; "NBETerm"; s] + FStarC_Compiler_Range_Type.dummyRange in + let refl_emb_lid s = + FStarC_Ident.lid_of_path ["FStarC"; "Reflection"; "V2"; "Embeddings"; s] + FStarC_Compiler_Range_Type.dummyRange in + let nbe_refl_emb_lid s = + FStarC_Ident.lid_of_path + ["FStarC"; "Reflection"; "V2"; "NBEEmbeddings"; s] + FStarC_Compiler_Range_Type.dummyRange in + let uu___ = + let uu___1 = + let uu___2 = syn_emb_lid "e_int" in + let uu___3 = + let uu___4 = nbe_emb_lid "e_int" in + FStar_Pervasives_Native.Some uu___4 in + { arity = Prims.int_zero; syn_emb = uu___2; nbe_emb = uu___3 } in + (FStarC_Parser_Const.int_lid, uu___1) in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = syn_emb_lid "e_bool" in + let uu___5 = + let uu___6 = nbe_emb_lid "e_bool" in + FStar_Pervasives_Native.Some uu___6 in + { arity = Prims.int_zero; syn_emb = uu___4; nbe_emb = uu___5 } in + (FStarC_Parser_Const.bool_lid, uu___3) in + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = syn_emb_lid "e_unit" in + let uu___7 = + let uu___8 = nbe_emb_lid "e_unit" in + FStar_Pervasives_Native.Some uu___8 in + { arity = Prims.int_zero; syn_emb = uu___6; nbe_emb = uu___7 } in + (FStarC_Parser_Const.unit_lid, uu___5) in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = syn_emb_lid "e_string" in + let uu___9 = + let uu___10 = nbe_emb_lid "e_string" in + FStar_Pervasives_Native.Some uu___10 in + { arity = Prims.int_zero; syn_emb = uu___8; nbe_emb = uu___9 } in + (FStarC_Parser_Const.string_lid, uu___7) in + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = syn_emb_lid "e_norm_step" in + let uu___11 = + let uu___12 = nbe_emb_lid "e_norm_step" in + FStar_Pervasives_Native.Some uu___12 in + { arity = Prims.int_zero; syn_emb = uu___10; nbe_emb = uu___11 + } in + (FStarC_Parser_Const.norm_step_lid, uu___9) in + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = syn_emb_lid "e___range" in + let uu___13 = + let uu___14 = nbe_emb_lid "e___range" in + FStar_Pervasives_Native.Some uu___14 in + { + arity = Prims.int_zero; + syn_emb = uu___12; + nbe_emb = uu___13 + } in + (FStarC_Parser_Const.__range_lid, uu___11) in + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = syn_emb_lid "e_vconfig" in + let uu___15 = + let uu___16 = nbe_emb_lid "e_vconfig" in + FStar_Pervasives_Native.Some uu___16 in + { + arity = Prims.int_zero; + syn_emb = uu___14; + nbe_emb = uu___15 + } in + (FStarC_Parser_Const.vconfig_lid, uu___13) in + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = syn_emb_lid "e_list" in + let uu___17 = + let uu___18 = nbe_emb_lid "e_list" in + FStar_Pervasives_Native.Some uu___18 in + { + arity = Prims.int_one; + syn_emb = uu___16; + nbe_emb = uu___17 + } in + (FStarC_Parser_Const.list_lid, uu___15) in + let uu___15 = + let uu___16 = + let uu___17 = + let uu___18 = syn_emb_lid "e_option" in + let uu___19 = + let uu___20 = nbe_emb_lid "e_option" in + FStar_Pervasives_Native.Some uu___20 in + { + arity = Prims.int_one; + syn_emb = uu___18; + nbe_emb = uu___19 + } in + (FStarC_Parser_Const.option_lid, uu___17) in + let uu___17 = + let uu___18 = + let uu___19 = + let uu___20 = syn_emb_lid "e_sealed" in + let uu___21 = + let uu___22 = nbe_emb_lid "e_sealed" in + FStar_Pervasives_Native.Some uu___22 in + { + arity = Prims.int_one; + syn_emb = uu___20; + nbe_emb = uu___21 + } in + (FStarC_Parser_Const.sealed_lid, uu___19) in + let uu___19 = + let uu___20 = + let uu___21 = + FStarC_Parser_Const.mk_tuple_lid (Prims.of_int (2)) + FStarC_Compiler_Range_Type.dummyRange in + let uu___22 = + let uu___23 = syn_emb_lid "e_tuple2" in + let uu___24 = + let uu___25 = nbe_emb_lid "e_tuple2" in + FStar_Pervasives_Native.Some uu___25 in + { + arity = (Prims.of_int (2)); + syn_emb = uu___23; + nbe_emb = uu___24 + } in + (uu___21, uu___22) in + let uu___21 = + let uu___22 = + let uu___23 = + FStarC_Parser_Const.mk_tuple_lid + (Prims.of_int (3)) + FStarC_Compiler_Range_Type.dummyRange in + let uu___24 = + let uu___25 = syn_emb_lid "e_tuple3" in + let uu___26 = + let uu___27 = nbe_emb_lid "e_tuple3" in + FStar_Pervasives_Native.Some uu___27 in + { + arity = (Prims.of_int (3)); + syn_emb = uu___25; + nbe_emb = uu___26 + } in + (uu___23, uu___24) in + let uu___23 = + let uu___24 = + let uu___25 = + let uu___26 = syn_emb_lid "e_either" in + let uu___27 = + let uu___28 = nbe_emb_lid "e_either" in + FStar_Pervasives_Native.Some uu___28 in + { + arity = (Prims.of_int (2)); + syn_emb = uu___26; + nbe_emb = uu___27 + } in + (FStarC_Parser_Const.either_lid, uu___25) in + let uu___25 = + let uu___26 = + let uu___27 = + FStarC_Reflection_V2_Constants.fstar_refl_types_lid + "namedv" in + let uu___28 = + let uu___29 = refl_emb_lid "e_namedv" in + let uu___30 = + let uu___31 = nbe_refl_emb_lid "e_namedv" in + FStar_Pervasives_Native.Some uu___31 in + { + arity = Prims.int_zero; + syn_emb = uu___29; + nbe_emb = uu___30 + } in + (uu___27, uu___28) in + let uu___27 = + let uu___28 = + let uu___29 = + FStarC_Reflection_V2_Constants.fstar_refl_types_lid + "bv" in + let uu___30 = + let uu___31 = refl_emb_lid "e_bv" in + let uu___32 = + let uu___33 = nbe_refl_emb_lid "e_bv" in + FStar_Pervasives_Native.Some uu___33 in + { + arity = Prims.int_zero; + syn_emb = uu___31; + nbe_emb = uu___32 + } in + (uu___29, uu___30) in + let uu___29 = + let uu___30 = + let uu___31 = + FStarC_Reflection_V2_Constants.fstar_refl_types_lid + "binder" in + let uu___32 = + let uu___33 = refl_emb_lid "e_binder" in + let uu___34 = + let uu___35 = + nbe_refl_emb_lid "e_binder" in + FStar_Pervasives_Native.Some uu___35 in + { + arity = Prims.int_zero; + syn_emb = uu___33; + nbe_emb = uu___34 + } in + (uu___31, uu___32) in + let uu___31 = + let uu___32 = + let uu___33 = + FStarC_Reflection_V2_Constants.fstar_refl_types_lid + "term" in + let uu___34 = + let uu___35 = refl_emb_lid "e_term" in + let uu___36 = + let uu___37 = + nbe_refl_emb_lid "e_term" in + FStar_Pervasives_Native.Some uu___37 in + { + arity = Prims.int_zero; + syn_emb = uu___35; + nbe_emb = uu___36 + } in + (uu___33, uu___34) in + let uu___33 = + let uu___34 = + let uu___35 = + FStarC_Reflection_V2_Constants.fstar_refl_types_lid + "env" in + let uu___36 = + let uu___37 = refl_emb_lid "e_env" in + let uu___38 = + let uu___39 = + nbe_refl_emb_lid "e_env" in + FStar_Pervasives_Native.Some + uu___39 in + { + arity = Prims.int_zero; + syn_emb = uu___37; + nbe_emb = uu___38 + } in + (uu___35, uu___36) in + let uu___35 = + let uu___36 = + let uu___37 = + FStarC_Reflection_V2_Constants.fstar_refl_types_lid + "fv" in + let uu___38 = + let uu___39 = refl_emb_lid "e_fv" in + let uu___40 = + let uu___41 = + nbe_refl_emb_lid "e_fv" in + FStar_Pervasives_Native.Some + uu___41 in + { + arity = Prims.int_zero; + syn_emb = uu___39; + nbe_emb = uu___40 + } in + (uu___37, uu___38) in + let uu___37 = + let uu___38 = + let uu___39 = + FStarC_Reflection_V2_Constants.fstar_refl_types_lid + "comp" in + let uu___40 = + let uu___41 = + refl_emb_lid "e_comp" in + let uu___42 = + let uu___43 = + nbe_refl_emb_lid "e_comp" in + FStar_Pervasives_Native.Some + uu___43 in + { + arity = Prims.int_zero; + syn_emb = uu___41; + nbe_emb = uu___42 + } in + (uu___39, uu___40) in + let uu___39 = + let uu___40 = + let uu___41 = + FStarC_Reflection_V2_Constants.fstar_refl_types_lid + "sigelt" in + let uu___42 = + let uu___43 = + refl_emb_lid "e_sigelt" in + let uu___44 = + let uu___45 = + nbe_refl_emb_lid "e_sigelt" in + FStar_Pervasives_Native.Some + uu___45 in + { + arity = Prims.int_zero; + syn_emb = uu___43; + nbe_emb = uu___44 + } in + (uu___41, uu___42) in + let uu___41 = + let uu___42 = + let uu___43 = + FStarC_Reflection_V2_Constants.fstar_refl_types_lid + "ctx_uvar_and_subst" in + let uu___44 = + let uu___45 = + refl_emb_lid + "e_ctx_uvar_and_subst" in + let uu___46 = + let uu___47 = + nbe_refl_emb_lid + "e_ctx_uvar_and_subst" in + FStar_Pervasives_Native.Some + uu___47 in + { + arity = Prims.int_zero; + syn_emb = uu___45; + nbe_emb = uu___46 + } in + (uu___43, uu___44) in + let uu___43 = + let uu___44 = + let uu___45 = + FStarC_Reflection_V2_Constants.fstar_refl_types_lid + "letbinding" in + let uu___46 = + let uu___47 = + refl_emb_lid + "e_letbinding" in + let uu___48 = + let uu___49 = + nbe_refl_emb_lid + "e_letbinding" in + FStar_Pervasives_Native.Some + uu___49 in + { + arity = Prims.int_zero; + syn_emb = uu___47; + nbe_emb = uu___48 + } in + (uu___45, uu___46) in + let uu___45 = + let uu___46 = + let uu___47 = + FStarC_Reflection_V2_Constants.fstar_refl_types_lid + "ident" in + let uu___48 = + let uu___49 = + refl_emb_lid "e_ident" in + let uu___50 = + let uu___51 = + nbe_refl_emb_lid + "e_ident" in + FStar_Pervasives_Native.Some + uu___51 in + { + arity = Prims.int_zero; + syn_emb = uu___49; + nbe_emb = uu___50 + } in + (uu___47, uu___48) in + let uu___47 = + let uu___48 = + let uu___49 = + FStarC_Reflection_V2_Constants.fstar_refl_types_lid + "universe_uvar" in + let uu___50 = + let uu___51 = + refl_emb_lid + "e_universe_uvar" in + let uu___52 = + let uu___53 = + nbe_refl_emb_lid + "e_universe_uvar" in + FStar_Pervasives_Native.Some + uu___53 in + { + arity = + Prims.int_zero; + syn_emb = uu___51; + nbe_emb = uu___52 + } in + (uu___49, uu___50) in + let uu___49 = + let uu___50 = + let uu___51 = + FStarC_Reflection_V2_Constants.fstar_refl_types_lid + "universe" in + let uu___52 = + let uu___53 = + refl_emb_lid + "e_universe" in + let uu___54 = + let uu___55 = + nbe_refl_emb_lid + "e_universe" in + FStar_Pervasives_Native.Some + uu___55 in + { + arity = + Prims.int_zero; + syn_emb = uu___53; + nbe_emb = uu___54 + } in + (uu___51, uu___52) in + let uu___51 = + let uu___52 = + let uu___53 = + FStarC_Reflection_V2_Constants.fstar_refl_data_lid + "vconst" in + let uu___54 = + let uu___55 = + refl_emb_lid + "e_vconst" in + let uu___56 = + let uu___57 = + nbe_refl_emb_lid + "e_vconst" in + FStar_Pervasives_Native.Some + uu___57 in + { + arity = + Prims.int_zero; + syn_emb = uu___55; + nbe_emb = uu___56 + } in + (uu___53, uu___54) in + let uu___53 = + let uu___54 = + let uu___55 = + FStarC_Reflection_V2_Constants.fstar_refl_data_lid + "aqualv" in + let uu___56 = + let uu___57 = + refl_emb_lid + "e_aqualv" in + let uu___58 = + let uu___59 = + nbe_refl_emb_lid + "e_aqualv" in + FStar_Pervasives_Native.Some + uu___59 in + { + arity = + Prims.int_zero; + syn_emb = + uu___57; + nbe_emb = + uu___58 + } in + (uu___55, uu___56) in + let uu___55 = + let uu___56 = + let uu___57 = + FStarC_Reflection_V2_Constants.fstar_refl_data_lid + "pattern" in + let uu___58 = + let uu___59 = + refl_emb_lid + "e_pattern" in + let uu___60 = + let uu___61 = + nbe_refl_emb_lid + "e_pattern" in + FStar_Pervasives_Native.Some + uu___61 in + { + arity = + Prims.int_zero; + syn_emb = + uu___59; + nbe_emb = + uu___60 + } in + (uu___57, + uu___58) in + let uu___57 = + let uu___58 = + let uu___59 = + FStarC_Reflection_V2_Constants.fstar_refl_data_lid + "namedv_view" in + let uu___60 = + let uu___61 = + refl_emb_lid + "e_namedv_view" in + let uu___62 = + let uu___63 + = + nbe_refl_emb_lid + "e_namedv_view" in + FStar_Pervasives_Native.Some + uu___63 in + { + arity = + Prims.int_zero; + syn_emb = + uu___61; + nbe_emb = + uu___62 + } in + (uu___59, + uu___60) in + let uu___59 = + let uu___60 = + let uu___61 = + FStarC_Reflection_V2_Constants.fstar_refl_data_lid + "bv_view" in + let uu___62 = + let uu___63 + = + refl_emb_lid + "e_bv_view" in + let uu___64 + = + let uu___65 + = + nbe_refl_emb_lid + "e_bv_view" in + FStar_Pervasives_Native.Some + uu___65 in + { + arity = + Prims.int_zero; + syn_emb = + uu___63; + nbe_emb = + uu___64 + } in + (uu___61, + uu___62) in + let uu___61 = + let uu___62 = + let uu___63 + = + FStarC_Reflection_V2_Constants.fstar_refl_data_lid + "binder_view" in + let uu___64 + = + let uu___65 + = + refl_emb_lid + "e_binder_view" in + let uu___66 + = + let uu___67 + = + nbe_refl_emb_lid + "e_binder_view" in + FStar_Pervasives_Native.Some + uu___67 in + { + arity = + Prims.int_zero; + syn_emb = + uu___65; + nbe_emb = + uu___66 + } in + (uu___63, + uu___64) in + let uu___63 = + let uu___64 + = + let uu___65 + = + FStarC_Reflection_V2_Constants.fstar_refl_data_lid + "binding" in + let uu___66 + = + let uu___67 + = + refl_emb_lid + "e_binding" in + let uu___68 + = + let uu___69 + = + nbe_refl_emb_lid + "e_binding" in + FStar_Pervasives_Native.Some + uu___69 in + { + arity = + Prims.int_zero; + syn_emb = + uu___67; + nbe_emb = + uu___68 + } in + (uu___65, + uu___66) in + let uu___65 + = + let uu___66 + = + let uu___67 + = + FStarC_Reflection_V2_Constants.fstar_refl_data_lid + "universe_view" in + let uu___68 + = + let uu___69 + = + refl_emb_lid + "e_universe_view" in + let uu___70 + = + let uu___71 + = + nbe_refl_emb_lid + "e_universe_view" in + FStar_Pervasives_Native.Some + uu___71 in + { + arity = + Prims.int_zero; + syn_emb = + uu___69; + nbe_emb = + uu___70 + } in + (uu___67, + uu___68) in + let uu___67 + = + let uu___68 + = + let uu___69 + = + FStarC_Reflection_V2_Constants.fstar_refl_data_lid + "term_view" in + let uu___70 + = + let uu___71 + = + refl_emb_lid + "e_term_view" in + let uu___72 + = + let uu___73 + = + nbe_refl_emb_lid + "e_term_view" in + FStar_Pervasives_Native.Some + uu___73 in + { + arity = + Prims.int_zero; + syn_emb = + uu___71; + nbe_emb = + uu___72 + } in + (uu___69, + uu___70) in + let uu___69 + = + let uu___70 + = + let uu___71 + = + FStarC_Reflection_V2_Constants.fstar_refl_data_lid + "comp_view" in + let uu___72 + = + let uu___73 + = + refl_emb_lid + "e_comp_view" in + let uu___74 + = + let uu___75 + = + nbe_refl_emb_lid + "e_comp_view" in + FStar_Pervasives_Native.Some + uu___75 in + { + arity = + Prims.int_zero; + syn_emb = + uu___73; + nbe_emb = + uu___74 + } in + (uu___71, + uu___72) in + let uu___71 + = + let uu___72 + = + let uu___73 + = + FStarC_Reflection_V2_Constants.fstar_refl_data_lid + "lb_view" in + let uu___74 + = + let uu___75 + = + refl_emb_lid + "e_lb_view" in + let uu___76 + = + let uu___77 + = + nbe_refl_emb_lid + "e_lb_view" in + FStar_Pervasives_Native.Some + uu___77 in + { + arity = + Prims.int_zero; + syn_emb = + uu___75; + nbe_emb = + uu___76 + } in + (uu___73, + uu___74) in + let uu___73 + = + let uu___74 + = + let uu___75 + = + FStarC_Reflection_V2_Constants.fstar_refl_data_lid + "sigelt_view" in + let uu___76 + = + let uu___77 + = + refl_emb_lid + "e_sigelt_view" in + let uu___78 + = + let uu___79 + = + nbe_refl_emb_lid + "e_sigelt_view" in + FStar_Pervasives_Native.Some + uu___79 in + { + arity = + Prims.int_zero; + syn_emb = + uu___77; + nbe_emb = + uu___78 + } in + (uu___75, + uu___76) in + let uu___75 + = + let uu___76 + = + let uu___77 + = + FStarC_Reflection_V2_Constants.fstar_refl_data_lid + "qualifier" in + let uu___78 + = + let uu___79 + = + refl_emb_lid + "e_qualifier" in + let uu___80 + = + let uu___81 + = + nbe_refl_emb_lid + "e_qualifier" in + FStar_Pervasives_Native.Some + uu___81 in + { + arity = + Prims.int_zero; + syn_emb = + uu___79; + nbe_emb = + uu___80 + } in + (uu___77, + uu___78) in + [uu___76] in + uu___74 + :: + uu___75 in + uu___72 + :: + uu___73 in + uu___70 + :: + uu___71 in + uu___68 + :: + uu___69 in + uu___66 + :: + uu___67 in + uu___64 :: + uu___65 in + uu___62 :: + uu___63 in + uu___60 :: + uu___61 in + uu___58 :: + uu___59 in + uu___56 :: uu___57 in + uu___54 :: uu___55 in + uu___52 :: uu___53 in + uu___50 :: uu___51 in + uu___48 :: uu___49 in + uu___46 :: uu___47 in + uu___44 :: uu___45 in + uu___42 :: uu___43 in + uu___40 :: uu___41 in + uu___38 :: uu___39 in + uu___36 :: uu___37 in + uu___34 :: uu___35 in + uu___32 :: uu___33 in + uu___30 :: uu___31 in + uu___28 :: uu___29 in + uu___26 :: uu___27 in + uu___24 :: uu___25 in + uu___22 :: uu___23 in + uu___20 :: uu___21 in + uu___18 :: uu___19 in + uu___16 :: uu___17 in + uu___14 :: uu___15 in + uu___12 :: uu___13 in + uu___10 :: uu___11 in + uu___8 :: uu___9 in + uu___6 :: uu___7 in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + uu___ :: uu___1 +let (dbg_plugin : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Plugins" +let (local_fv_embeddings : + (FStarC_Ident.lident * embedding_data) Prims.list + FStarC_Compiler_Effect.ref) + = FStarC_Compiler_Util.mk_ref [] +let (register_embedding : FStarC_Ident.lident -> embedding_data -> unit) = + fun l -> + fun d -> + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_plugin in + if uu___1 + then + let uu___2 = FStarC_Ident.string_of_lid l in + FStarC_Compiler_Util.print1 "Registering local embedding for %s\n" + uu___2 + else ()); + (let uu___1 = + let uu___2 = FStarC_Compiler_Effect.op_Bang local_fv_embeddings in + (l, d) :: uu___2 in + FStarC_Compiler_Effect.op_Colon_Equals local_fv_embeddings uu___1) +let (list_local : unit -> (FStarC_Ident.lident * embedding_data) Prims.list) + = fun uu___ -> FStarC_Compiler_Effect.op_Bang local_fv_embeddings +let (find_fv_embedding' : + FStarC_Ident.lident -> embedding_data FStar_Pervasives_Native.option) = + fun l -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Compiler_Effect.op_Bang local_fv_embeddings in + FStarC_Compiler_List.op_At uu___2 builtin_embeddings in + FStarC_Compiler_List.find + (fun uu___2 -> + match uu___2 with | (l', uu___3) -> FStarC_Ident.lid_equals l l') + uu___1 in + match uu___ with + | FStar_Pervasives_Native.Some (uu___1, data) -> + FStar_Pervasives_Native.Some data + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None +let (find_fv_embedding : FStarC_Ident.lident -> embedding_data) = + fun l -> + let uu___ = find_fv_embedding' l in + match uu___ with + | FStar_Pervasives_Native.Some data -> data + | FStar_Pervasives_Native.None -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Ident.string_of_lid l in + Prims.strcat "Embedding not defined for type " uu___3 in + NoEmbedding uu___2 in + FStarC_Compiler_Effect.raise uu___1 +type embedding_kind = + | SyntaxTerm + | NBETerm +let (uu___is_SyntaxTerm : embedding_kind -> Prims.bool) = + fun projectee -> match projectee with | SyntaxTerm -> true | uu___ -> false +let (uu___is_NBETerm : embedding_kind -> Prims.bool) = + fun projectee -> match projectee with | NBETerm -> true | uu___ -> false +let rec (embedding_for : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lid Prims.list -> + embedding_kind -> + (FStarC_Syntax_Syntax.bv * Prims.string) Prims.list -> + FStarC_Syntax_Syntax.term -> FStarC_Extraction_ML_Syntax.mlexpr) + = + fun tcenv -> + fun mutuals -> + fun k -> + fun env -> + fun t -> + let str_to_name s = as_name ([], s) in + let emb_arrow e1 e2 = + let comb = + match k with + | SyntaxTerm -> + mk + (FStarC_Extraction_ML_Syntax.MLE_Name + (["FStarC"; "Syntax"; "Embeddings"], "e_arrow")) + | NBETerm -> + mk + (FStarC_Extraction_ML_Syntax.MLE_Name + (["FStarC"; "TypeChecker"; "NBETerm"], "e_arrow")) in + mk (FStarC_Extraction_ML_Syntax.MLE_App (comb, [e1; e2])) in + let find_env_entry bv uu___ = + match uu___ with + | (bv', uu___1) -> FStarC_Syntax_Syntax.bv_eq bv bv' in + let t1 = FStarC_TypeChecker_Normalize.unfold_whnf tcenv t in + let t2 = FStarC_Syntax_Util.un_uinst t1 in + let t3 = FStarC_Syntax_Subst.compress t2 in + match t3.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_name bv when + FStarC_Compiler_Util.for_some (find_env_entry bv) env -> + let comb = + match k with + | SyntaxTerm -> + mk + (FStarC_Extraction_ML_Syntax.MLE_Name + (["FStarC"; "Syntax"; "Embeddings"], "mk_any_emb")) + | NBETerm -> + mk + (FStarC_Extraction_ML_Syntax.MLE_Name + (["FStarC"; "TypeChecker"; "NBETerm"], + "mk_any_emb")) in + let s = + let uu___ = + let uu___1 = + FStarC_Compiler_Util.find_opt (find_env_entry bv) env in + FStarC_Compiler_Util.must uu___1 in + FStar_Pervasives_Native.snd uu___ in + let uu___ = + let uu___1 = + let uu___2 = let uu___3 = str_to_name s in [uu___3] in + (comb, uu___2) in + FStarC_Extraction_ML_Syntax.MLE_App uu___1 in + mk uu___ + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x; + FStarC_Syntax_Syntax.phi = uu___;_} + -> + embedding_for tcenv mutuals k env x.FStarC_Syntax_Syntax.sort + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t4; + FStarC_Syntax_Syntax.asc = uu___; + FStarC_Syntax_Syntax.eff_opt = uu___1;_} + -> embedding_for tcenv mutuals k env t4 + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = b::[]; + FStarC_Syntax_Syntax.comp = c;_} + when FStarC_Syntax_Util.is_pure_comp c -> + let uu___ = FStarC_Syntax_Subst.open_comp [b] c in + (match uu___ with + | (b1::[], c1) -> + let t0 = + (b1.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + let t11 = FStarC_Syntax_Util.comp_result c1 in + let uu___1 = embedding_for tcenv mutuals k env t0 in + let uu___2 = embedding_for tcenv mutuals k env t11 in + emb_arrow uu___1 uu___2) + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = b::more::bs; + FStarC_Syntax_Syntax.comp = c;_} + -> + let tail = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 = (more :: bs); + FStarC_Syntax_Syntax.comp = c + }) t3.FStarC_Syntax_Syntax.pos in + let t4 = + let uu___ = + let uu___1 = + let uu___2 = FStarC_Syntax_Syntax.mk_Total tail in + { + FStarC_Syntax_Syntax.bs1 = [b]; + FStarC_Syntax_Syntax.comp = uu___2 + } in + FStarC_Syntax_Syntax.Tm_arrow uu___1 in + FStarC_Syntax_Syntax.mk uu___ t3.FStarC_Syntax_Syntax.pos in + embedding_for tcenv mutuals k env t4 + | FStarC_Syntax_Syntax.Tm_app uu___ -> + let uu___1 = FStarC_Syntax_Util.head_and_args t3 in + (match uu___1 with + | (head, args) -> + let e_head = embedding_for tcenv mutuals k env head in + let e_args = + FStarC_Compiler_List.map + (fun uu___2 -> + match uu___2 with + | (t4, uu___3) -> + embedding_for tcenv mutuals k env t4) args in + mk + (FStarC_Extraction_ML_Syntax.MLE_App (e_head, e_args))) + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Compiler_List.existsb + (FStarC_Ident.lid_equals + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v) + mutuals + -> + let head = + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Ident.ident_of_lid + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + FStarC_Ident.string_of_id uu___3 in + Prims.strcat "__knot_e_" uu___2 in + FStarC_Extraction_ML_Syntax.MLE_Var uu___1 in + mk uu___ in + mk + (FStarC_Extraction_ML_Syntax.MLE_App + (head, [FStarC_Extraction_ML_Syntax.ml_unit])) + | FStarC_Syntax_Syntax.Tm_fvar fv when + let uu___ = + find_fv_embedding' + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + FStar_Pervasives_Native.uu___is_Some uu___ -> + let emb_data = + find_fv_embedding + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + (match k with + | SyntaxTerm -> ml_name emb_data.syn_emb + | NBETerm -> + (match emb_data.nbe_emb with + | FStar_Pervasives_Native.Some lid -> ml_name lid + | FStar_Pervasives_Native.None -> ml_nbe_unsupported)) + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_TypeChecker_Env.fv_has_attr tcenv fv + FStarC_Parser_Const.plugin_attr + -> + (match k with + | SyntaxTerm -> + let lid = + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + let uu___ = + let uu___1 = + let uu___2 = FStarC_Ident.ns_of_lid lid in + FStarC_Compiler_List.map FStarC_Ident.string_of_id + uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Ident.ident_of_lid lid in + FStarC_Ident.string_of_id uu___4 in + Prims.strcat "e_" uu___3 in + (uu___1, uu___2) in + as_name uu___ + | NBETerm -> ml_nbe_unsupported) + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t3 in + FStarC_Compiler_Util.format1 + "Embedding not defined for name `%s'" uu___2 in + NoEmbedding uu___1 in + FStarC_Compiler_Effect.raise uu___ + | uu___ -> + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t3 in + let uu___4 = + FStarC_Class_Tagged.tag_of + FStarC_Syntax_Syntax.tagged_term t3 in + FStarC_Compiler_Util.format2 + "Cannot embed type `%s' (%s)" uu___3 uu___4 in + NoEmbedding uu___2 in + FStarC_Compiler_Effect.raise uu___1 +type wrapped_term = + (FStarC_Extraction_ML_Syntax.mlexpr * FStarC_Extraction_ML_Syntax.mlexpr * + Prims.int * Prims.bool) +let (interpret_plugin_as_term_fun : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.fv -> + FStarC_Syntax_Syntax.typ -> + Prims.int FStar_Pervasives_Native.option -> + FStarC_Extraction_ML_Syntax.mlexpr' -> + (FStarC_Extraction_ML_Syntax.mlexpr * + FStarC_Extraction_ML_Syntax.mlexpr * Prims.int * Prims.bool) + FStar_Pervasives_Native.option) + = + fun env -> + fun fv -> + fun t -> + fun arity_opt -> + fun ml_fv -> + let fv_lid = + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + let tcenv = FStarC_Extraction_ML_UEnv.tcenv_of_uenv env in + let t1 = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.EraseUniverses; + FStarC_TypeChecker_Env.AllowUnboundUniverses; + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.ForExtraction] tcenv t in + let as_name1 mlp = + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.MLTY_Top + (FStarC_Extraction_ML_Syntax.MLE_Name mlp) in + let lid_to_name l = + let uu___ = + let uu___1 = FStarC_Extraction_ML_UEnv.mlpath_of_lident env l in + FStarC_Extraction_ML_Syntax.MLE_Name uu___1 in + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.MLTY_Top uu___ in + let str_to_name s = as_name1 ([], s) in + let fv_lid_embedded = + let uu___ = + let uu___1 = + let uu___2 = as_name1 (["FStarC_Ident"], "lid_of_str") in + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Ident.string_of_lid fv_lid in + FStarC_Extraction_ML_Syntax.MLC_String uu___7 in + FStarC_Extraction_ML_Syntax.MLE_Const uu___6 in + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.MLTY_Top uu___5 in + [uu___4] in + (uu___2, uu___3) in + FStarC_Extraction_ML_Syntax.MLE_App uu___1 in + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.MLTY_Top uu___ in + let mk_tactic_interpretation l arity = + if arity > FStarC_Tactics_InterpFuns.max_tac_arity + then + FStarC_Compiler_Effect.raise + (NoEmbedding + "tactic plugins can only take up to 20 arguments") + else + (let idroot = + match l with + | SyntaxTerm -> "mk_tactic_interpretation_" + | NBETerm -> "mk_nbe_tactic_interpretation_" in + as_name1 + (["FStarC_Tactics_InterpFuns"], + (Prims.strcat idroot (Prims.string_of_int arity)))) in + let mk_from_tactic l arity = + let idroot = + match l with + | SyntaxTerm -> "from_tactic_" + | NBETerm -> "from_nbe_tactic_" in + as_name1 + (["FStarC_Tactics_Native"], + (Prims.strcat idroot (Prims.string_of_int arity))) in + let mk_arrow_as_prim_step k arity = + let modul = + match k with + | SyntaxTerm -> ["FStarC"; "Syntax"; "Embeddings"] + | NBETerm -> ["FStarC"; "TypeChecker"; "NBETerm"] in + as_name1 + (modul, + (Prims.strcat "arrow_as_prim_step_" + (Prims.string_of_int arity))) in + let abstract_tvars tvar_names body = + match tvar_names with + | [] -> + let body1 = + let uu___ = + let uu___1 = + let uu___2 = + as_name1 + (["FStarC_Syntax_Embeddings"], "debug_wrap") in + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Ident.string_of_lid fv_lid in + FStarC_Extraction_ML_Syntax.MLC_String uu___7 in + FStarC_Extraction_ML_Syntax.MLE_Const uu___6 in + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.MLTY_Top uu___5 in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = str_to_name "args" in + [uu___11] in + (body, uu___10) in + FStarC_Extraction_ML_Syntax.MLE_App uu___9 in + mk uu___8 in + ml_lam "_" uu___7 in + [uu___6] in + uu___4 :: uu___5 in + (uu___2, uu___3) in + FStarC_Extraction_ML_Syntax.MLE_App uu___1 in + mk uu___ in + ml_lam "args" body1 + | uu___ -> + let args_tail = + FStarC_Extraction_ML_Syntax.MLP_Var "args_tail" in + let mk_cons hd_pat tail_pat = + FStarC_Extraction_ML_Syntax.MLP_CTor + ((["Prims"], "Cons"), [hd_pat; tail_pat]) in + let fst_pat v = + FStarC_Extraction_ML_Syntax.MLP_Tuple + [FStarC_Extraction_ML_Syntax.MLP_Var v; + FStarC_Extraction_ML_Syntax.MLP_Wild] in + let pattern = + FStarC_Compiler_List.fold_right + (fun hd_var -> mk_cons (fst_pat hd_var)) tvar_names + args_tail in + let branch = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = as_name1 ([], "args_tail") in + [uu___5] in + (body, uu___4) in + FStarC_Extraction_ML_Syntax.MLE_App uu___3 in + mk uu___2 in + (pattern, FStar_Pervasives_Native.None, uu___1) in + let default_branch = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = str_to_name "failwith" in + let uu___5 = + let uu___6 = + mk + (FStarC_Extraction_ML_Syntax.MLE_Const + (FStarC_Extraction_ML_Syntax.MLC_String + "arity mismatch")) in + [uu___6] in + (uu___4, uu___5) in + FStarC_Extraction_ML_Syntax.MLE_App uu___3 in + mk uu___2 in + (FStarC_Extraction_ML_Syntax.MLP_Wild, + FStar_Pervasives_Native.None, uu___1) in + let body1 = + let uu___1 = + let uu___2 = + let uu___3 = as_name1 ([], "args") in + (uu___3, [branch; default_branch]) in + FStarC_Extraction_ML_Syntax.MLE_Match uu___2 in + mk uu___1 in + let body2 = + let uu___1 = + let uu___2 = + let uu___3 = + as_name1 + (["FStarC_Syntax_Embeddings"], "debug_wrap") in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Ident.string_of_lid fv_lid in + FStarC_Extraction_ML_Syntax.MLC_String uu___8 in + FStarC_Extraction_ML_Syntax.MLE_Const uu___7 in + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.MLTY_Top uu___6 in + let uu___6 = + let uu___7 = ml_lam "_" body1 in [uu___7] in + uu___5 :: uu___6 in + (uu___3, uu___4) in + FStarC_Extraction_ML_Syntax.MLE_App uu___2 in + mk uu___1 in + ml_lam "args" body2 in + let uu___ = FStarC_Syntax_Util.arrow_formals_comp t1 in + match uu___ with + | (bs, c) -> + let uu___1 = + match arity_opt with + | FStar_Pervasives_Native.None -> (bs, c) + | FStar_Pervasives_Native.Some n -> + let n_bs = FStarC_Compiler_List.length bs in + if n = n_bs + then (bs, c) + else + if n < n_bs + then + (let uu___3 = FStarC_Compiler_Util.first_N n bs in + match uu___3 with + | (bs1, rest) -> + let c1 = + let uu___4 = FStarC_Syntax_Util.arrow rest c in + FStarC_Syntax_Syntax.mk_Total uu___4 in + (bs1, c1)) + else + (let msg = + let uu___4 = FStarC_Ident.string_of_lid fv_lid in + let uu___5 = + FStarC_Compiler_Util.string_of_int n in + let uu___6 = + FStarC_Compiler_Util.string_of_int n_bs in + FStarC_Compiler_Util.format3 + "Embedding not defined for %s; expected arity at least %s; got %s" + uu___4 uu___5 uu___6 in + FStarC_Compiler_Effect.raise (NoEmbedding msg)) in + (match uu___1 with + | (bs1, c1) -> + let result_typ = FStarC_Syntax_Util.comp_result c1 in + let arity = FStarC_Compiler_List.length bs1 in + let uu___2 = + let uu___3 = + FStarC_Compiler_Util.prefix_until + (fun uu___4 -> + match uu___4 with + | { FStarC_Syntax_Syntax.binder_bv = b; + FStarC_Syntax_Syntax.binder_qual = uu___5; + FStarC_Syntax_Syntax.binder_positivity = + uu___6; + FStarC_Syntax_Syntax.binder_attrs = uu___7;_} + -> + let uu___8 = + let uu___9 = + FStarC_Syntax_Subst.compress + b.FStarC_Syntax_Syntax.sort in + uu___9.FStarC_Syntax_Syntax.n in + (match uu___8 with + | FStarC_Syntax_Syntax.Tm_type uu___9 -> + false + | uu___9 -> true)) bs1 in + match uu___3 with + | FStar_Pervasives_Native.None -> (bs1, []) + | FStar_Pervasives_Native.Some (tvars, x, rest) -> + (tvars, (x :: rest)) in + (match uu___2 with + | (type_vars, bs2) -> + let tvar_arity = + FStarC_Compiler_List.length type_vars in + let non_tvar_arity = + FStarC_Compiler_List.length bs2 in + let tvar_names = + FStarC_Compiler_List.mapi + (fun i -> + fun tv -> + Prims.strcat "tv_" (Prims.string_of_int i)) + type_vars in + let tvar_context = + FStarC_Compiler_List.map2 + (fun b -> + fun nm -> + ((b.FStarC_Syntax_Syntax.binder_bv), nm)) + type_vars tvar_names in + let rec aux loc accum_embeddings bs3 = + match bs3 with + | [] -> + let arg_unembeddings = + FStarC_Compiler_List.rev accum_embeddings in + let res_embedding = + embedding_for tcenv [] loc tvar_context + result_typ in + let fv_lid1 = + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + let uu___3 = + FStarC_Syntax_Util.is_pure_comp c1 in + if uu___3 + then + let cb = str_to_name "cb" in + let us = str_to_name "us" in + let embed_fun_N = + mk_arrow_as_prim_step loc non_tvar_arity in + let args = + let uu___4 = + let uu___5 = + let uu___6 = lid_to_name fv_lid1 in + [uu___6; fv_lid_embedded; cb; us] in + res_embedding :: uu___5 in + FStarC_Compiler_List.op_At + arg_unembeddings uu___4 in + let fun_embedding = + mk + (FStarC_Extraction_ML_Syntax.MLE_App + (embed_fun_N, args)) in + let tabs = + abstract_tvars tvar_names fun_embedding in + let cb_tabs = + let uu___4 = ml_lam "us" tabs in + ml_lam "cb" uu___4 in + let uu___4 = + if loc = NBETerm + then cb_tabs + else ml_lam "_psc" cb_tabs in + (uu___4, arity, true) + else + (let uu___5 = + let uu___6 = + FStarC_TypeChecker_Env.norm_eff_name + tcenv + (FStarC_Syntax_Util.comp_effect_name + c1) in + FStarC_Ident.lid_equals uu___6 + FStarC_Parser_Const.effect_TAC_lid in + if uu___5 + then + let h = + mk_tactic_interpretation loc + non_tvar_arity in + let tac_fun = + let uu___6 = + let uu___7 = + let uu___8 = + mk_from_tactic loc + non_tvar_arity in + let uu___9 = + let uu___10 = + lid_to_name fv_lid1 in + [uu___10] in + (uu___8, uu___9) in + FStarC_Extraction_ML_Syntax.MLE_App + uu___7 in + mk uu___6 in + let psc = str_to_name "psc" in + let ncb = str_to_name "ncb" in + let us = str_to_name "us" in + let all_args = str_to_name "args" in + let args = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Ident.string_of_lid + fv_lid1 in + Prims.strcat uu___11 + " (plugin)" in + FStarC_Extraction_ML_Syntax.MLC_String + uu___10 in + FStarC_Extraction_ML_Syntax.MLE_Const + uu___9 in + mk uu___8 in + [uu___7] in + FStarC_Compiler_List.op_At uu___6 + (FStarC_Compiler_List.op_At + [tac_fun] + (FStarC_Compiler_List.op_At + arg_unembeddings + [res_embedding; psc; ncb; us])) in + let tabs = + match tvar_names with + | [] -> + let uu___6 = + mk + (FStarC_Extraction_ML_Syntax.MLE_App + (h, + (FStarC_Compiler_List.op_At + args [all_args]))) in + ml_lam "args" uu___6 + | uu___6 -> + let uu___7 = + mk + (FStarC_Extraction_ML_Syntax.MLE_App + (h, args)) in + abstract_tvars tvar_names uu___7 in + let uu___6 = + let uu___7 = + let uu___8 = ml_lam "us" tabs in + ml_lam "ncb" uu___8 in + ml_lam "psc" uu___7 in + (uu___6, (arity + Prims.int_one), false) + else + (let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t1 in + Prims.strcat + "Plugins not defined for type " + uu___9 in + NoEmbedding uu___8 in + FStarC_Compiler_Effect.raise uu___7)) + | { FStarC_Syntax_Syntax.binder_bv = b; + FStarC_Syntax_Syntax.binder_qual = uu___3; + FStarC_Syntax_Syntax.binder_positivity = + uu___4; + FStarC_Syntax_Syntax.binder_attrs = uu___5;_}::bs4 + -> + let uu___6 = + let uu___7 = + embedding_for tcenv [] loc tvar_context + b.FStarC_Syntax_Syntax.sort in + uu___7 :: accum_embeddings in + aux loc uu___6 bs4 in + (try + (fun uu___3 -> + match () with + | () -> + let uu___4 = aux SyntaxTerm [] bs2 in + (match uu___4 with + | (w, a, b) -> + let uu___5 = aux NBETerm [] bs2 in + (match uu___5 with + | (w', uu___6, uu___7) -> + FStar_Pervasives_Native.Some + (w, w', a, b)))) () + with + | NoEmbedding msg -> + ((let uu___5 = + FStarC_Ident.range_of_lid + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_fv fv in + not_implemented_warning uu___5 uu___6 msg); + FStar_Pervasives_Native.None)))) +let (mk_unembed : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lid Prims.list -> + FStarC_Extraction_ML_Syntax.mlpath Prims.list + FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.sigelt Prims.list -> + FStarC_Extraction_ML_Syntax.mlexpr) + = + fun tcenv -> + fun mutuals -> + fun record_fields -> + fun ctors -> + let e_branches = FStarC_Compiler_Util.mk_ref [] in + let arg_v = fresh "tm" in + FStarC_Compiler_List.iter + (fun ctor -> + match ctor.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = lid; + FStarC_Syntax_Syntax.us1 = us; + FStarC_Syntax_Syntax.t1 = t; + FStarC_Syntax_Syntax.ty_lid = ty_lid; + FStarC_Syntax_Syntax.num_ty_params = num_ty_params; + FStarC_Syntax_Syntax.mutuals1 = uu___1; + FStarC_Syntax_Syntax.injective_type_params1 = uu___2;_} + -> + let fv = fresh "fv" in + let uu___3 = FStarC_Syntax_Util.arrow_formals t in + (match uu___3 with + | (bs, c) -> + let vs = + FStarC_Compiler_List.map + (fun b -> + let uu___4 = + let uu___5 = + FStarC_Ident.string_of_id + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.ppname in + fresh uu___5 in + (uu___4, + ((b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort))) + bs in + let pat_s = + let uu___4 = + let uu___5 = FStarC_Ident.string_of_lid lid in + FStarC_Extraction_ML_Syntax.MLC_String uu___5 in + FStarC_Extraction_ML_Syntax.MLP_Const uu___4 in + let pat_args = + let uu___4 = + FStarC_Compiler_List.map + (fun uu___5 -> + match uu___5 with + | (v, uu___6) -> + FStarC_Extraction_ML_Syntax.MLP_Var v) + vs in + pats_to_list_pat uu___4 in + let pat_both = + FStarC_Extraction_ML_Syntax.MLP_Tuple + [pat_s; pat_args] in + let ret = + match record_fields with + | FStar_Pervasives_Native.Some fields -> + let uu___4 = + FStarC_Compiler_List.map2 + (fun uu___5 -> + fun fld -> + match uu___5 with + | (v, uu___6) -> + let uu___7 = + mk + (FStarC_Extraction_ML_Syntax.MLE_Var + v) in + ((FStar_Pervasives_Native.snd fld), + uu___7)) vs fields in + ml_record lid uu___4 + | FStar_Pervasives_Native.None -> + let uu___4 = + FStarC_Compiler_List.map + (fun uu___5 -> + match uu___5 with + | (v, uu___6) -> + mk + (FStarC_Extraction_ML_Syntax.MLE_Var + v)) vs in + ml_ctor lid uu___4 in + let ret1 = + mk + (FStarC_Extraction_ML_Syntax.MLE_App + (ml_some, [ret])) in + let body = + FStarC_Compiler_List.fold_right + (fun uu___4 -> + fun body1 -> + match uu___4 with + | (v, ty) -> + let body2 = + mk + (FStarC_Extraction_ML_Syntax.MLE_Fun + ([mk_binder v + FStarC_Extraction_ML_Syntax.MLTY_Top], + body1)) in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + embedding_for tcenv + mutuals SyntaxTerm [] + ty in + let uu___13 = + let uu___14 = + mk + (FStarC_Extraction_ML_Syntax.MLE_Var + v) in + [uu___14] in + uu___12 :: uu___13 in + (unembed, uu___11) in + FStarC_Extraction_ML_Syntax.MLE_App + uu___10 in + mk uu___9 in + [uu___8; body2] in + (bind_opt, uu___7) in + FStarC_Extraction_ML_Syntax.MLE_App + uu___6 in + mk uu___5) vs ret1 in + let br = + (pat_both, FStar_Pervasives_Native.None, body) in + let uu___4 = + let uu___5 = + FStarC_Compiler_Effect.op_Bang e_branches in + br :: uu___5 in + FStarC_Compiler_Effect.op_Colon_Equals e_branches + uu___4) + | uu___1 -> failwith "impossible, filter above") ctors; + (let nomatch = + (FStarC_Extraction_ML_Syntax.MLP_Wild, + FStar_Pervasives_Native.None, ml_none) in + let branches = + let uu___1 = + let uu___2 = FStarC_Compiler_Effect.op_Bang e_branches in + nomatch :: uu___2 in + FStarC_Compiler_List.rev uu___1 in + let sc = mk (FStarC_Extraction_ML_Syntax.MLE_Var arg_v) in + let def = + mk (FStarC_Extraction_ML_Syntax.MLE_Match (sc, branches)) in + let lam = + mk + (FStarC_Extraction_ML_Syntax.MLE_Fun + ([mk_binder arg_v FStarC_Extraction_ML_Syntax.MLTY_Top], + def)) in + lam) +let (mk_embed : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lid Prims.list -> + FStarC_Extraction_ML_Syntax.mlpath Prims.list + FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.sigelt Prims.list -> + FStarC_Extraction_ML_Syntax.mlexpr) + = + fun tcenv -> + fun mutuals -> + fun record_fields -> + fun ctors -> + let e_branches = FStarC_Compiler_Util.mk_ref [] in + let arg_v = fresh "tm" in + FStarC_Compiler_List.iter + (fun ctor -> + match ctor.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = lid; + FStarC_Syntax_Syntax.us1 = us; + FStarC_Syntax_Syntax.t1 = t; + FStarC_Syntax_Syntax.ty_lid = ty_lid; + FStarC_Syntax_Syntax.num_ty_params = num_ty_params; + FStarC_Syntax_Syntax.mutuals1 = uu___1; + FStarC_Syntax_Syntax.injective_type_params1 = uu___2;_} + -> + let fv = fresh "fv" in + let uu___3 = FStarC_Syntax_Util.arrow_formals t in + (match uu___3 with + | (bs, c) -> + let vs = + FStarC_Compiler_List.map + (fun b -> + let uu___4 = + let uu___5 = + FStarC_Ident.string_of_id + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.ppname in + fresh uu___5 in + (uu___4, + ((b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort))) + bs in + let pat = + match record_fields with + | FStar_Pervasives_Native.Some fields -> + let uu___4 = + let uu___5 = + FStarC_Compiler_List.map2 + (fun v -> + fun fld -> + ((FStar_Pervasives_Native.snd fld), + (FStarC_Extraction_ML_Syntax.MLP_Var + (FStar_Pervasives_Native.fst v)))) + vs fields in + ([], uu___5) in + FStarC_Extraction_ML_Syntax.MLP_Record uu___4 + | FStar_Pervasives_Native.None -> + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Ident.path_of_lid lid in + splitlast uu___6 in + let uu___6 = + FStarC_Compiler_List.map + (fun v -> + FStarC_Extraction_ML_Syntax.MLP_Var + (FStar_Pervasives_Native.fst v)) vs in + (uu___5, uu___6) in + FStarC_Extraction_ML_Syntax.MLP_CTor uu___4 in + let fvar = s_tdataconstr in + let lid_of_str1 = lid_of_str in + let head = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_Ident.string_of_lid + lid in + FStarC_Extraction_ML_Syntax.MLC_String + uu___14 in + FStarC_Extraction_ML_Syntax.MLE_Const + uu___13 in + mk uu___12 in + [uu___11] in + (lid_of_str1, uu___10) in + FStarC_Extraction_ML_Syntax.MLE_App + uu___9 in + mk uu___8 in + [uu___7] in + (fvar, uu___6) in + FStarC_Extraction_ML_Syntax.MLE_App uu___5 in + mk uu___4 in + let mk_mk_app t1 ts = + let ts1 = + FStarC_Compiler_List.map + (fun t2 -> + mk + (FStarC_Extraction_ML_Syntax.MLE_Tuple + [t2; ml_none])) ts in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = as_ml_list ts1 in [uu___8] in + t1 :: uu___7 in + (mk_app, uu___6) in + FStarC_Extraction_ML_Syntax.MLE_App uu___5 in + mk uu___4 in + let args = + FStarC_Compiler_List.map + (fun uu___4 -> + match uu___4 with + | (v, ty) -> + let vt = + mk + (FStarC_Extraction_ML_Syntax.MLE_Var v) in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + embedding_for tcenv mutuals + SyntaxTerm [] ty in + [uu___8; vt] in + (embed, uu___7) in + FStarC_Extraction_ML_Syntax.MLE_App + uu___6 in + mk uu___5) vs in + let ret = mk_mk_app head args in + let br = (pat, FStar_Pervasives_Native.None, ret) in + let uu___4 = + let uu___5 = + FStarC_Compiler_Effect.op_Bang e_branches in + br :: uu___5 in + FStarC_Compiler_Effect.op_Colon_Equals e_branches + uu___4) + | uu___1 -> failwith "impossible, filter above") ctors; + (let branches = + let uu___1 = FStarC_Compiler_Effect.op_Bang e_branches in + FStarC_Compiler_List.rev uu___1 in + let sc = mk (FStarC_Extraction_ML_Syntax.MLE_Var arg_v) in + let def = + mk (FStarC_Extraction_ML_Syntax.MLE_Match (sc, branches)) in + let lam = + mk + (FStarC_Extraction_ML_Syntax.MLE_Fun + ([mk_binder arg_v FStarC_Extraction_ML_Syntax.MLTY_Top], + def)) in + lam) +let (__do_handle_plugin : + FStarC_Extraction_ML_UEnv.uenv -> + Prims.int FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.sigelt -> + FStarC_Extraction_ML_Syntax.mlmodule1 Prims.list) + = + fun g -> + fun arity_opt -> + fun se -> + let r = se.FStarC_Syntax_Syntax.sigrng in + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = lbs; + FStarC_Syntax_Syntax.lids1 = uu___;_} + -> + let mk_registration lb = + let fv = + FStarC_Compiler_Util.right lb.FStarC_Syntax_Syntax.lbname in + let fv_lid = + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + let fv_t = lb.FStarC_Syntax_Syntax.lbtyp in + let ml_name_str = + let uu___1 = + let uu___2 = FStarC_Ident.string_of_lid fv_lid in + FStarC_Extraction_ML_Syntax.MLC_String uu___2 in + FStarC_Extraction_ML_Syntax.MLE_Const uu___1 in + let uu___1 = + interpret_plugin_as_term_fun g fv fv_t arity_opt ml_name_str in + match uu___1 with + | FStar_Pervasives_Native.Some + (interp, nbe_interp, arity, plugin) -> + let uu___2 = + if plugin + then + ((["FStarC_Tactics_Native"], "register_plugin"), + [interp; nbe_interp]) + else + ((["FStarC_Tactics_Native"], "register_tactic"), + [interp]) in + (match uu___2 with + | (register, args) -> + let h = + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.MLTY_Top + (FStarC_Extraction_ML_Syntax.MLE_Name register) in + let arity1 = + FStarC_Extraction_ML_Syntax.MLE_Const + (FStarC_Extraction_ML_Syntax.MLC_Int + ((Prims.string_of_int arity), + FStar_Pervasives_Native.None)) in + let app = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = mk ml_name_str in + let uu___8 = + let uu___9 = mk arity1 in [uu___9] in + uu___7 :: uu___8 in + FStarC_Compiler_List.op_At uu___6 args in + (h, uu___5) in + FStarC_Extraction_ML_Syntax.MLE_App uu___4 in + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.MLTY_Top uu___3 in + let uu___3 = + FStarC_Extraction_ML_Syntax.mk_mlmodule1 + (FStarC_Extraction_ML_Syntax.MLM_Top app) in + [uu___3]) + | FStar_Pervasives_Native.None -> [] in + FStarC_Compiler_List.collect mk_registration + (FStar_Pervasives_Native.snd lbs) + | FStarC_Syntax_Syntax.Sig_bundle + { FStarC_Syntax_Syntax.ses = ses; + FStarC_Syntax_Syntax.lids = uu___;_} + -> + let mutual_sigelts = + FStarC_Compiler_List.filter + (fun se1 -> + match se1.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_inductive_typ uu___1 -> true + | uu___1 -> false) ses in + let mutual_lids = + FStarC_Compiler_List.map + (fun se1 -> + match se1.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = lid; + FStarC_Syntax_Syntax.us = uu___1; + FStarC_Syntax_Syntax.params = uu___2; + FStarC_Syntax_Syntax.num_uniform_params = uu___3; + FStarC_Syntax_Syntax.t = uu___4; + FStarC_Syntax_Syntax.mutuals = uu___5; + FStarC_Syntax_Syntax.ds = uu___6; + FStarC_Syntax_Syntax.injective_type_params = uu___7;_} + -> lid) mutual_sigelts in + let proc_one typ_sigelt = + let uu___1 = typ_sigelt.FStarC_Syntax_Syntax.sigel in + match uu___1 with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = tlid; + FStarC_Syntax_Syntax.us = uu___2; + FStarC_Syntax_Syntax.params = ps; + FStarC_Syntax_Syntax.num_uniform_params = uu___3; + FStarC_Syntax_Syntax.t = uu___4; + FStarC_Syntax_Syntax.mutuals = uu___5; + FStarC_Syntax_Syntax.ds = uu___6; + FStarC_Syntax_Syntax.injective_type_params = uu___7;_} + -> + (if (FStarC_Compiler_List.length ps) > Prims.int_zero + then + FStarC_Compiler_Effect.raise + (Unsupported "parameters on inductive") + else (); + (let ns = FStarC_Ident.ns_of_lid tlid in + let name = + let uu___9 = + let uu___10 = FStarC_Ident.ids_of_lid tlid in + FStarC_Compiler_List.last uu___10 in + FStarC_Ident.string_of_id uu___9 in + let ctors = + FStarC_Compiler_List.filter + (fun se1 -> + match se1.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = uu___9; + FStarC_Syntax_Syntax.us1 = uu___10; + FStarC_Syntax_Syntax.t1 = uu___11; + FStarC_Syntax_Syntax.ty_lid = ty_lid; + FStarC_Syntax_Syntax.num_ty_params = uu___12; + FStarC_Syntax_Syntax.mutuals1 = uu___13; + FStarC_Syntax_Syntax.injective_type_params1 + = uu___14;_} + -> FStarC_Ident.lid_equals ty_lid tlid + | uu___9 -> false) ses in + let ml_name1 = + let uu___9 = + let uu___10 = + let uu___11 = FStarC_Ident.string_of_lid tlid in + FStarC_Extraction_ML_Syntax.MLC_String uu___11 in + FStarC_Extraction_ML_Syntax.MLE_Const uu___10 in + mk uu___9 in + let record_fields = + let uu___9 = + FStarC_Compiler_List.find + (fun uu___10 -> + match uu___10 with + | FStarC_Syntax_Syntax.RecordType uu___11 -> + true + | uu___11 -> false) + typ_sigelt.FStarC_Syntax_Syntax.sigquals in + match uu___9 with + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.RecordType (uu___10, b)) -> + let uu___11 = + FStarC_Compiler_List.map + (fun f -> + FStarC_Extraction_ML_UEnv.lookup_record_field_name + g (tlid, f)) b in + FStar_Pervasives_Native.Some uu___11 + | uu___10 -> FStar_Pervasives_Native.None in + let tcenv = FStarC_Extraction_ML_UEnv.tcenv_of_uenv g in + let ml_unembed = + mk_unembed tcenv mutual_lids record_fields ctors in + let ml_embed = + mk_embed tcenv mutual_lids record_fields ctors in + let def = + let uu___9 = + let uu___10 = + let uu___11 = + mk + (FStarC_Extraction_ML_Syntax.MLE_Name + (["FStarC"; "Syntax"; "Embeddings"; "Base"], + "mk_extracted_embedding")) in + (uu___11, [ml_name1; ml_unembed; ml_embed]) in + FStarC_Extraction_ML_Syntax.MLE_App uu___10 in + mk uu___9 in + let def1 = + mk + (FStarC_Extraction_ML_Syntax.MLE_Fun + ([mk_binder "_" + FStarC_Extraction_ML_Syntax.MLTY_Erased], def)) in + let lb = + { + FStarC_Extraction_ML_Syntax.mllb_name = + (Prims.strcat "__knot_e_" name); + FStarC_Extraction_ML_Syntax.mllb_tysc = + FStar_Pervasives_Native.None; + FStarC_Extraction_ML_Syntax.mllb_add_unit = false; + FStarC_Extraction_ML_Syntax.mllb_def = def1; + FStarC_Extraction_ML_Syntax.mllb_attrs = []; + FStarC_Extraction_ML_Syntax.mllb_meta = []; + FStarC_Extraction_ML_Syntax.print_typ = false + } in + (let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Ident.mk_ident + ((Prims.strcat "e_" name), + FStarC_Compiler_Range_Type.dummyRange) in + FStarC_Ident.lid_of_ns_and_id ns uu___12 in + { + arity = Prims.int_zero; + syn_emb = uu___11; + nbe_emb = FStar_Pervasives_Native.None + } in + register_embedding tlid uu___10); + [lb])) in + let lbs = FStarC_Compiler_List.concatMap proc_one mutual_sigelts in + let unthunking = + FStarC_Compiler_List.concatMap + (fun se1 -> + let tlid = + match se1.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = tlid1; + FStarC_Syntax_Syntax.us = uu___1; + FStarC_Syntax_Syntax.params = uu___2; + FStarC_Syntax_Syntax.num_uniform_params = uu___3; + FStarC_Syntax_Syntax.t = uu___4; + FStarC_Syntax_Syntax.mutuals = uu___5; + FStarC_Syntax_Syntax.ds = uu___6; + FStarC_Syntax_Syntax.injective_type_params = + uu___7;_} + -> tlid1 in + let name = + let uu___1 = + let uu___2 = FStarC_Ident.ids_of_lid tlid in + FStarC_Compiler_List.last uu___2 in + FStarC_Ident.string_of_id uu___1 in + let app = + let head = + mk + (FStarC_Extraction_ML_Syntax.MLE_Var + (Prims.strcat "__knot_e_" name)) in + mk + (FStarC_Extraction_ML_Syntax.MLE_App + (head, [FStarC_Extraction_ML_Syntax.ml_unit])) in + let lb = + { + FStarC_Extraction_ML_Syntax.mllb_name = + (Prims.strcat "e_" name); + FStarC_Extraction_ML_Syntax.mllb_tysc = + FStar_Pervasives_Native.None; + FStarC_Extraction_ML_Syntax.mllb_add_unit = false; + FStarC_Extraction_ML_Syntax.mllb_def = app; + FStarC_Extraction_ML_Syntax.mllb_attrs = []; + FStarC_Extraction_ML_Syntax.mllb_meta = []; + FStarC_Extraction_ML_Syntax.print_typ = false + } in + let uu___1 = + FStarC_Extraction_ML_Syntax.mk_mlmodule1 + (FStarC_Extraction_ML_Syntax.MLM_Let + (FStarC_Extraction_ML_Syntax.NonRec, [lb])) in + [uu___1]) mutual_sigelts in + let uu___1 = + let uu___2 = + FStarC_Extraction_ML_Syntax.mk_mlmodule1 + (FStarC_Extraction_ML_Syntax.MLM_Let + (FStarC_Extraction_ML_Syntax.Rec, lbs)) in + [uu___2] in + FStarC_Compiler_List.op_At uu___1 unthunking + | uu___ -> [] +let (do_handle_plugin : + FStarC_Extraction_ML_UEnv.uenv -> + Prims.int FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.sigelt -> + FStarC_Extraction_ML_Syntax.mlmodule1 Prims.list) + = + fun g -> + fun arity_opt -> + fun se -> + try + (fun uu___ -> + match () with | () -> __do_handle_plugin g arity_opt se) () + with + | Unsupported msg -> + ((let uu___2 = + let uu___3 = FStarC_Syntax_Print.sigelt_to_string_short se in + FStarC_Compiler_Util.format2 + "Could not generate a plugin for %s, reason = %s" uu___3 + msg in + FStarC_Errors.log_issue FStarC_Syntax_Syntax.has_range_sigelt + se FStarC_Errors_Codes.Warning_PluginNotImplemented () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + []) + | NoEmbedding msg -> + ((let uu___2 = FStarC_Syntax_Print.sigelt_to_string_short se in + not_implemented_warning se.FStarC_Syntax_Syntax.sigrng uu___2 + msg); + []) +let (maybe_register_plugin : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.sigelt -> + FStarC_Extraction_ML_Syntax.mlmodule1 Prims.list) + = + fun g -> + fun se -> + let plugin_with_arity attrs = + FStarC_Compiler_Util.find_map attrs + (fun t -> + let uu___ = FStarC_Syntax_Util.head_and_args t in + match uu___ with + | (head, args) -> + let uu___1 = + let uu___2 = + FStarC_Syntax_Util.is_fvar + FStarC_Parser_Const.plugin_attr head in + Prims.op_Negation uu___2 in + if uu___1 + then FStar_Pervasives_Native.None + else + (match args with + | (a, uu___3)::[] -> + let nopt = + FStarC_Syntax_Embeddings_Base.unembed + FStarC_Syntax_Embeddings.e_fsint a + FStarC_Syntax_Embeddings_Base.id_norm_cb in + FStar_Pervasives_Native.Some nopt + | uu___3 -> + FStar_Pervasives_Native.Some + FStar_Pervasives_Native.None)) in + let uu___ = + let uu___1 = FStarC_Options.codegen () in + uu___1 <> (FStar_Pervasives_Native.Some FStarC_Options.Plugin) in + if uu___ + then [] + else + (let uu___2 = plugin_with_arity se.FStarC_Syntax_Syntax.sigattrs in + match uu___2 with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some uu___3 when + FStarC_Compiler_List.existsb + (fun uu___4 -> + match uu___4 with + | FStarC_Syntax_Syntax.Projector uu___5 -> true + | FStarC_Syntax_Syntax.Discriminator uu___5 -> true + | uu___5 -> false) se.FStarC_Syntax_Syntax.sigquals + -> [] + | FStar_Pervasives_Native.Some arity_opt -> + do_handle_plugin g arity_opt se) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Extraction_ML_RemoveUnusedParameters.ml b/ocaml/fstar-lib/generated/FStarC_Extraction_ML_RemoveUnusedParameters.ml new file mode 100644 index 00000000000..bcda2b53f14 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Extraction_ML_RemoveUnusedParameters.ml @@ -0,0 +1,694 @@ +open Prims +type argument_tag = + | Retain + | Omit +let (uu___is_Retain : argument_tag -> Prims.bool) = + fun projectee -> match projectee with | Retain -> true | uu___ -> false +let (uu___is_Omit : argument_tag -> Prims.bool) = + fun projectee -> match projectee with | Omit -> true | uu___ -> false +type entry = argument_tag Prims.list +type env_t = + { + current_module: FStarC_Extraction_ML_Syntax.mlsymbol Prims.list ; + tydef_map: entry FStarC_Compiler_Util.psmap } +let (__proj__Mkenv_t__item__current_module : + env_t -> FStarC_Extraction_ML_Syntax.mlsymbol Prims.list) = + fun projectee -> + match projectee with | { current_module; tydef_map;_} -> current_module +let (__proj__Mkenv_t__item__tydef_map : + env_t -> entry FStarC_Compiler_Util.psmap) = + fun projectee -> + match projectee with | { current_module; tydef_map;_} -> tydef_map +let (initial_env : env_t) = + let uu___ = FStarC_Compiler_Util.psmap_empty () in + { current_module = []; tydef_map = uu___ } +type tydef = + (FStarC_Extraction_ML_Syntax.mlsymbol * + FStarC_Extraction_ML_Syntax.metadata * + (FStarC_Extraction_ML_Syntax.mltyscheme, Prims.int) + FStar_Pervasives.either) +let (extend_env : + env_t -> FStarC_Extraction_ML_Syntax.mlsymbol -> entry -> env_t) = + fun env -> + fun i -> + fun e -> + let uu___ = + let uu___1 = + FStarC_Extraction_ML_Syntax.string_of_mlpath + ((env.current_module), i) in + FStarC_Compiler_Util.psmap_add env.tydef_map uu___1 e in + { current_module = (env.current_module); tydef_map = uu___ } +let (lookup_tyname : + env_t -> + FStarC_Extraction_ML_Syntax.mlpath -> + entry FStar_Pervasives_Native.option) + = + fun env -> + fun name -> + let uu___ = FStarC_Extraction_ML_Syntax.string_of_mlpath name in + FStarC_Compiler_Util.psmap_try_find env.tydef_map uu___ +type var_set = FStarC_Extraction_ML_Syntax.mlident FStarC_Compiler_RBSet.t +let (empty_var_set : Prims.string FStarC_Compiler_RBSet.t) = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset FStarC_Class_Ord.ord_string)) + ()) +let rec (freevars_of_mlty' : + var_set -> FStarC_Extraction_ML_Syntax.mlty -> var_set) = + fun uu___1 -> + fun uu___ -> + (fun vars -> + fun t -> + match t with + | FStarC_Extraction_ML_Syntax.MLTY_Var i -> + Obj.magic + (Obj.repr + (FStarC_Class_Setlike.add () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) i (Obj.magic vars))) + | FStarC_Extraction_ML_Syntax.MLTY_Fun (t0, uu___, t1) -> + Obj.magic + (Obj.repr + (let uu___1 = freevars_of_mlty' vars t0 in + freevars_of_mlty' uu___1 t1)) + | FStarC_Extraction_ML_Syntax.MLTY_Named (tys, uu___) -> + Obj.magic + (Obj.repr + (FStarC_Compiler_List.fold_left freevars_of_mlty' vars + tys)) + | FStarC_Extraction_ML_Syntax.MLTY_Tuple tys -> + Obj.magic + (Obj.repr + (FStarC_Compiler_List.fold_left freevars_of_mlty' vars + tys)) + | uu___ -> Obj.magic (Obj.repr vars)) uu___1 uu___ +let (freevars_of_mlty : FStarC_Extraction_ML_Syntax.mlty -> var_set) = + freevars_of_mlty' empty_var_set +let rec (elim_mlty : + env_t -> + FStarC_Extraction_ML_Syntax.mlty -> FStarC_Extraction_ML_Syntax.mlty) + = + fun env -> + fun mlty -> + match mlty with + | FStarC_Extraction_ML_Syntax.MLTY_Var uu___ -> mlty + | FStarC_Extraction_ML_Syntax.MLTY_Fun (t0, e, t1) -> + let uu___ = + let uu___1 = elim_mlty env t0 in + let uu___2 = elim_mlty env t1 in (uu___1, e, uu___2) in + FStarC_Extraction_ML_Syntax.MLTY_Fun uu___ + | FStarC_Extraction_ML_Syntax.MLTY_Named (args, name) -> + let args1 = FStarC_Compiler_List.map (elim_mlty env) args in + let uu___ = lookup_tyname env name in + (match uu___ with + | FStar_Pervasives_Native.None -> + FStarC_Extraction_ML_Syntax.MLTY_Named (args1, name) + | FStar_Pervasives_Native.Some entry1 -> + (if + (FStarC_Compiler_List.length entry1) <> + (FStarC_Compiler_List.length args1) + then + failwith + "Impossible: arity mismatch between definition and use" + else (); + (let args2 = + FStarC_Compiler_List.fold_right2 + (fun arg -> + fun tag -> + fun out -> + match tag with + | Retain -> arg :: out + | uu___2 -> out) args1 entry1 [] in + FStarC_Extraction_ML_Syntax.MLTY_Named (args2, name)))) + | FStarC_Extraction_ML_Syntax.MLTY_Tuple tys -> + let uu___ = FStarC_Compiler_List.map (elim_mlty env) tys in + FStarC_Extraction_ML_Syntax.MLTY_Tuple uu___ + | FStarC_Extraction_ML_Syntax.MLTY_Top -> mlty + | FStarC_Extraction_ML_Syntax.MLTY_Erased -> mlty +let rec (elim_mlexpr' : + env_t -> + FStarC_Extraction_ML_Syntax.mlexpr' -> + FStarC_Extraction_ML_Syntax.mlexpr') + = + fun env -> + fun e -> + match e with + | FStarC_Extraction_ML_Syntax.MLE_Const uu___ -> e + | FStarC_Extraction_ML_Syntax.MLE_Var uu___ -> e + | FStarC_Extraction_ML_Syntax.MLE_Name uu___ -> e + | FStarC_Extraction_ML_Syntax.MLE_Let (lb, e1) -> + let uu___ = + let uu___1 = elim_letbinding env lb in + let uu___2 = elim_mlexpr env e1 in (uu___1, uu___2) in + FStarC_Extraction_ML_Syntax.MLE_Let uu___ + | FStarC_Extraction_ML_Syntax.MLE_App (e1, es) -> + let uu___ = + let uu___1 = elim_mlexpr env e1 in + let uu___2 = FStarC_Compiler_List.map (elim_mlexpr env) es in + (uu___1, uu___2) in + FStarC_Extraction_ML_Syntax.MLE_App uu___ + | FStarC_Extraction_ML_Syntax.MLE_TApp (e1, tys) -> + let uu___ = + let uu___1 = FStarC_Compiler_List.map (elim_mlty env) tys in + (e1, uu___1) in + FStarC_Extraction_ML_Syntax.MLE_TApp uu___ + | FStarC_Extraction_ML_Syntax.MLE_Fun (bvs, e1) -> + let uu___ = + let uu___1 = + FStarC_Compiler_List.map + (fun b -> + let uu___2 = + elim_mlty env b.FStarC_Extraction_ML_Syntax.mlbinder_ty in + let uu___3 = + FStarC_Compiler_List.map (elim_mlexpr env) + b.FStarC_Extraction_ML_Syntax.mlbinder_attrs in + { + FStarC_Extraction_ML_Syntax.mlbinder_name = + (b.FStarC_Extraction_ML_Syntax.mlbinder_name); + FStarC_Extraction_ML_Syntax.mlbinder_ty = uu___2; + FStarC_Extraction_ML_Syntax.mlbinder_attrs = uu___3 + }) bvs in + let uu___2 = elim_mlexpr env e1 in (uu___1, uu___2) in + FStarC_Extraction_ML_Syntax.MLE_Fun uu___ + | FStarC_Extraction_ML_Syntax.MLE_Match (e1, branches) -> + let uu___ = + let uu___1 = elim_mlexpr env e1 in + let uu___2 = FStarC_Compiler_List.map (elim_branch env) branches in + (uu___1, uu___2) in + FStarC_Extraction_ML_Syntax.MLE_Match uu___ + | FStarC_Extraction_ML_Syntax.MLE_Coerce (e1, t0, t1) -> + let uu___ = + let uu___1 = elim_mlexpr env e1 in + let uu___2 = elim_mlty env t0 in + let uu___3 = elim_mlty env t1 in (uu___1, uu___2, uu___3) in + FStarC_Extraction_ML_Syntax.MLE_Coerce uu___ + | FStarC_Extraction_ML_Syntax.MLE_CTor (l, es) -> + let uu___ = + let uu___1 = FStarC_Compiler_List.map (elim_mlexpr env) es in + (l, uu___1) in + FStarC_Extraction_ML_Syntax.MLE_CTor uu___ + | FStarC_Extraction_ML_Syntax.MLE_Seq es -> + let uu___ = FStarC_Compiler_List.map (elim_mlexpr env) es in + FStarC_Extraction_ML_Syntax.MLE_Seq uu___ + | FStarC_Extraction_ML_Syntax.MLE_Tuple es -> + let uu___ = FStarC_Compiler_List.map (elim_mlexpr env) es in + FStarC_Extraction_ML_Syntax.MLE_Tuple uu___ + | FStarC_Extraction_ML_Syntax.MLE_Record (syms, nm, fields) -> + let uu___ = + let uu___1 = + FStarC_Compiler_List.map + (fun uu___2 -> + match uu___2 with + | (s, e1) -> + let uu___3 = elim_mlexpr env e1 in (s, uu___3)) fields in + (syms, nm, uu___1) in + FStarC_Extraction_ML_Syntax.MLE_Record uu___ + | FStarC_Extraction_ML_Syntax.MLE_Proj (e1, p) -> + let uu___ = let uu___1 = elim_mlexpr env e1 in (uu___1, p) in + FStarC_Extraction_ML_Syntax.MLE_Proj uu___ + | FStarC_Extraction_ML_Syntax.MLE_If (e1, e11, e2_opt) -> + let uu___ = + let uu___1 = elim_mlexpr env e1 in + let uu___2 = elim_mlexpr env e11 in + let uu___3 = + FStarC_Compiler_Util.map_opt e2_opt (elim_mlexpr env) in + (uu___1, uu___2, uu___3) in + FStarC_Extraction_ML_Syntax.MLE_If uu___ + | FStarC_Extraction_ML_Syntax.MLE_Raise (p, es) -> + let uu___ = + let uu___1 = FStarC_Compiler_List.map (elim_mlexpr env) es in + (p, uu___1) in + FStarC_Extraction_ML_Syntax.MLE_Raise uu___ + | FStarC_Extraction_ML_Syntax.MLE_Try (e1, branches) -> + let uu___ = + let uu___1 = elim_mlexpr env e1 in + let uu___2 = FStarC_Compiler_List.map (elim_branch env) branches in + (uu___1, uu___2) in + FStarC_Extraction_ML_Syntax.MLE_Try uu___ +and (elim_letbinding : + env_t -> + (FStarC_Extraction_ML_Syntax.mlletflavor * + FStarC_Extraction_ML_Syntax.mllb Prims.list) -> + (FStarC_Extraction_ML_Syntax.mlletflavor * + FStarC_Extraction_ML_Syntax.mllb Prims.list)) + = + fun env -> + fun uu___ -> + match uu___ with + | (flavor, lbs) -> + let elim_one_lb lb = + let ts = + FStarC_Compiler_Util.map_opt + lb.FStarC_Extraction_ML_Syntax.mllb_tysc + (fun uu___1 -> + match uu___1 with + | (vars, t) -> + let uu___2 = elim_mlty env t in (vars, uu___2)) in + let expr = + elim_mlexpr env lb.FStarC_Extraction_ML_Syntax.mllb_def in + { + FStarC_Extraction_ML_Syntax.mllb_name = + (lb.FStarC_Extraction_ML_Syntax.mllb_name); + FStarC_Extraction_ML_Syntax.mllb_tysc = ts; + FStarC_Extraction_ML_Syntax.mllb_add_unit = + (lb.FStarC_Extraction_ML_Syntax.mllb_add_unit); + FStarC_Extraction_ML_Syntax.mllb_def = expr; + FStarC_Extraction_ML_Syntax.mllb_attrs = + (lb.FStarC_Extraction_ML_Syntax.mllb_attrs); + FStarC_Extraction_ML_Syntax.mllb_meta = + (lb.FStarC_Extraction_ML_Syntax.mllb_meta); + FStarC_Extraction_ML_Syntax.print_typ = + (lb.FStarC_Extraction_ML_Syntax.print_typ) + } in + let uu___1 = FStarC_Compiler_List.map elim_one_lb lbs in + (flavor, uu___1) +and (elim_branch : + env_t -> + (FStarC_Extraction_ML_Syntax.mlpattern * + FStarC_Extraction_ML_Syntax.mlexpr FStar_Pervasives_Native.option * + FStarC_Extraction_ML_Syntax.mlexpr) -> + (FStarC_Extraction_ML_Syntax.mlpattern * + FStarC_Extraction_ML_Syntax.mlexpr FStar_Pervasives_Native.option * + FStarC_Extraction_ML_Syntax.mlexpr)) + = + fun env -> + fun uu___ -> + match uu___ with + | (pat, wopt, e) -> + let uu___1 = FStarC_Compiler_Util.map_opt wopt (elim_mlexpr env) in + let uu___2 = elim_mlexpr env e in (pat, uu___1, uu___2) +and (elim_mlexpr : + env_t -> + FStarC_Extraction_ML_Syntax.mlexpr -> FStarC_Extraction_ML_Syntax.mlexpr) + = + fun env -> + fun e -> + let uu___ = elim_mlexpr' env e.FStarC_Extraction_ML_Syntax.expr in + let uu___1 = elim_mlty env e.FStarC_Extraction_ML_Syntax.mlty in + { + FStarC_Extraction_ML_Syntax.expr = uu___; + FStarC_Extraction_ML_Syntax.mlty = uu___1; + FStarC_Extraction_ML_Syntax.loc = (e.FStarC_Extraction_ML_Syntax.loc) + } +exception Drop_tydef +let (uu___is_Drop_tydef : Prims.exn -> Prims.bool) = + fun projectee -> match projectee with | Drop_tydef -> true | uu___ -> false +let (elim_tydef : + env_t -> + Prims.string -> + FStarC_Extraction_ML_Syntax.meta Prims.list -> + FStarC_Extraction_ML_Syntax.ty_param Prims.list -> + FStarC_Extraction_ML_Syntax.mlty -> + (env_t * (Prims.string * FStarC_Extraction_ML_Syntax.meta + Prims.list * FStarC_Extraction_ML_Syntax.ty_param Prims.list * + FStarC_Extraction_ML_Syntax.mlty))) + = + fun env -> + fun name -> + fun metadata -> + fun parameters -> + fun mlty -> + let val_decl_range = + FStarC_Compiler_Util.find_map metadata + (fun uu___ -> + match uu___ with + | FStarC_Extraction_ML_Syntax.HasValDecl r -> + FStar_Pervasives_Native.Some r + | uu___1 -> FStar_Pervasives_Native.None) in + let remove_typars_list = + FStarC_Compiler_Util.try_find + (fun uu___ -> + match uu___ with + | FStarC_Extraction_ML_Syntax.RemoveUnusedTypeParameters + uu___1 -> true + | uu___1 -> false) metadata in + let range_of_tydef = + match remove_typars_list with + | FStar_Pervasives_Native.None -> + FStarC_Compiler_Range_Type.dummyRange + | FStar_Pervasives_Native.Some + (FStarC_Extraction_ML_Syntax.RemoveUnusedTypeParameters + (uu___, r)) -> r in + let must_eliminate i = + match remove_typars_list with + | FStar_Pervasives_Native.Some + (FStarC_Extraction_ML_Syntax.RemoveUnusedTypeParameters + (l, r)) -> FStarC_Compiler_List.contains i l + | uu___ -> false in + let can_eliminate i = + match (val_decl_range, remove_typars_list) with + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) + -> true + | uu___ -> false in + let mlty1 = elim_mlty env mlty in + let freevars = freevars_of_mlty mlty1 in + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun param -> + match uu___1 with + | (i, params, entry1) -> + let p = + param.FStarC_Extraction_ML_Syntax.ty_param_name in + let uu___2 = + FStarC_Class_Setlike.mem () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) p + (Obj.magic freevars) in + if uu___2 + then + (if must_eliminate i + then + (let uu___4 = + FStarC_Compiler_Util.format2 + "Expected parameter %s of %s to be unused in its definition and eliminated" + p name in + FStarC_Errors.log_issue + FStarC_Class_HasRange.hasRange_range + range_of_tydef + FStarC_Errors_Codes.Error_RemoveUnusedTypeParameter + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4)) + else (); + ((i + Prims.int_one), (param :: params), (Retain + :: entry1))) + else + if (can_eliminate i) || (must_eliminate i) + then + ((i + Prims.int_one), params, (Omit :: entry1)) + else + (let uu___5 = + let uu___6 = FStarC_Options.codegen () in + uu___6 = + (FStar_Pervasives_Native.Some + FStarC_Options.FSharp) in + if uu___5 + then + let range = + match val_decl_range with + | FStar_Pervasives_Native.Some r -> r + | uu___6 -> range_of_tydef in + ((let uu___7 = + let uu___8 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + i in + let uu___9 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + i in + FStarC_Compiler_Util.format3 + "Parameter %s of %s is unused and must be eliminated for F#; add `[@@ remove_unused_type_parameters [%s; ...]]` to the interface signature; \nThis type definition is being dropped" + uu___8 name uu___9 in + FStarC_Errors.log_issue + FStarC_Class_HasRange.hasRange_range + range + FStarC_Errors_Codes.Error_RemoveUnusedTypeParameter + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___7)); + FStarC_Compiler_Effect.raise Drop_tydef) + else + ((i + Prims.int_one), (param :: params), + (Retain :: entry1)))) + (Prims.int_zero, [], []) parameters in + match uu___ with + | (uu___1, parameters1, entry1) -> + let uu___2 = + extend_env env name (FStarC_Compiler_List.rev entry1) in + (uu___2, + (name, metadata, (FStarC_Compiler_List.rev parameters1), + mlty1)) +let (elim_tydef_or_decl : env_t -> tydef -> (env_t * tydef)) = + fun env -> + fun td -> + match td with + | (name, metadata, FStar_Pervasives.Inr arity) -> + let remove_typars_list = + FStarC_Compiler_Util.try_find + (fun uu___ -> + match uu___ with + | FStarC_Extraction_ML_Syntax.RemoveUnusedTypeParameters + uu___1 -> true + | uu___1 -> false) metadata in + (match remove_typars_list with + | FStar_Pervasives_Native.None -> (env, td) + | FStar_Pervasives_Native.Some + (FStarC_Extraction_ML_Syntax.RemoveUnusedTypeParameters + (l, r)) -> + let must_eliminate i = FStarC_Compiler_List.contains i l in + let rec aux i = + if i = arity + then [] + else + if must_eliminate i + then + (let uu___1 = aux (i + Prims.int_one) in Omit :: uu___1) + else + (let uu___2 = aux (i + Prims.int_one) in Retain :: + uu___2) in + let entries = aux Prims.int_zero in + let uu___ = extend_env env name entries in (uu___, td)) + | (name, metadata, FStar_Pervasives.Inl (parameters, mlty)) -> + let uu___ = elim_tydef env name metadata parameters mlty in + (match uu___ with + | (env1, (name1, meta, params, mlty1)) -> + (env1, (name1, meta, (FStar_Pervasives.Inl (params, mlty1))))) +let (elim_tydefs : env_t -> tydef Prims.list -> (env_t * tydef Prims.list)) = + fun env -> + fun tds -> + let uu___ = + let uu___1 = FStarC_Options.codegen () in + uu___1 <> (FStar_Pervasives_Native.Some FStarC_Options.FSharp) in + if uu___ + then (env, tds) + else + (let uu___2 = + FStarC_Compiler_List.fold_left + (fun uu___3 -> + fun td -> + match uu___3 with + | (env1, out) -> + (try + (fun uu___4 -> + match () with + | () -> + let uu___5 = elim_tydef_or_decl env1 td in + (match uu___5 with + | (env2, td1) -> (env2, (td1 :: out)))) () + with | Drop_tydef -> (env1, out))) (env, []) tds in + match uu___2 with + | (env1, tds1) -> (env1, (FStarC_Compiler_List.rev tds1))) +let (elim_one_mltydecl : + env_t -> + FStarC_Extraction_ML_Syntax.one_mltydecl -> + (env_t * FStarC_Extraction_ML_Syntax.one_mltydecl)) + = + fun env -> + fun td -> + let uu___ = td in + match uu___ with + | { FStarC_Extraction_ML_Syntax.tydecl_assumed = uu___1; + FStarC_Extraction_ML_Syntax.tydecl_name = name; + FStarC_Extraction_ML_Syntax.tydecl_ignored = uu___2; + FStarC_Extraction_ML_Syntax.tydecl_parameters = parameters; + FStarC_Extraction_ML_Syntax.tydecl_meta = meta; + FStarC_Extraction_ML_Syntax.tydecl_defn = body;_} -> + let elim_td td1 = + match td1 with + | FStarC_Extraction_ML_Syntax.MLTD_Abbrev mlty -> + let uu___3 = elim_tydef env name meta parameters mlty in + (match uu___3 with + | (env1, (name1, uu___4, parameters1, mlty1)) -> + (env1, parameters1, + (FStarC_Extraction_ML_Syntax.MLTD_Abbrev mlty1))) + | FStarC_Extraction_ML_Syntax.MLTD_Record fields -> + let uu___3 = + let uu___4 = + FStarC_Compiler_List.map + (fun uu___5 -> + match uu___5 with + | (name1, ty) -> + let uu___6 = elim_mlty env ty in (name1, uu___6)) + fields in + FStarC_Extraction_ML_Syntax.MLTD_Record uu___4 in + (env, parameters, uu___3) + | FStarC_Extraction_ML_Syntax.MLTD_DType inductive -> + let uu___3 = + let uu___4 = + FStarC_Compiler_List.map + (fun uu___5 -> + match uu___5 with + | (i, constrs) -> + let uu___6 = + FStarC_Compiler_List.map + (fun uu___7 -> + match uu___7 with + | (constr, ty) -> + let uu___8 = elim_mlty env ty in + (constr, uu___8)) constrs in + (i, uu___6)) inductive in + FStarC_Extraction_ML_Syntax.MLTD_DType uu___4 in + (env, parameters, uu___3) in + let uu___3 = + match body with + | FStar_Pervasives_Native.None -> (env, parameters, body) + | FStar_Pervasives_Native.Some td1 -> + let uu___4 = elim_td td1 in + (match uu___4 with + | (env1, parameters1, td2) -> + (env1, parameters1, (FStar_Pervasives_Native.Some td2))) in + (match uu___3 with + | (env1, parameters1, body1) -> + (env1, + { + FStarC_Extraction_ML_Syntax.tydecl_assumed = + (td.FStarC_Extraction_ML_Syntax.tydecl_assumed); + FStarC_Extraction_ML_Syntax.tydecl_name = + (td.FStarC_Extraction_ML_Syntax.tydecl_name); + FStarC_Extraction_ML_Syntax.tydecl_ignored = + (td.FStarC_Extraction_ML_Syntax.tydecl_ignored); + FStarC_Extraction_ML_Syntax.tydecl_parameters = + parameters1; + FStarC_Extraction_ML_Syntax.tydecl_meta = + (td.FStarC_Extraction_ML_Syntax.tydecl_meta); + FStarC_Extraction_ML_Syntax.tydecl_defn = body1 + })) +let (elim_module : + env_t -> + FStarC_Extraction_ML_Syntax.mlmodule1 Prims.list -> + (env_t * FStarC_Extraction_ML_Syntax.mlmodule1 Prims.list)) + = + fun env -> + fun m -> + let elim_module1 env1 m1 = + match m1.FStarC_Extraction_ML_Syntax.mlmodule1_m with + | FStarC_Extraction_ML_Syntax.MLM_Ty td -> + let uu___ = + FStarC_Compiler_Util.fold_map elim_one_mltydecl env1 td in + (match uu___ with + | (env2, td1) -> + (env2, + { + FStarC_Extraction_ML_Syntax.mlmodule1_m = + (FStarC_Extraction_ML_Syntax.MLM_Ty td1); + FStarC_Extraction_ML_Syntax.mlmodule1_attrs = + (m1.FStarC_Extraction_ML_Syntax.mlmodule1_attrs) + })) + | FStarC_Extraction_ML_Syntax.MLM_Let lb -> + let uu___ = + let uu___1 = + let uu___2 = elim_letbinding env1 lb in + FStarC_Extraction_ML_Syntax.MLM_Let uu___2 in + { + FStarC_Extraction_ML_Syntax.mlmodule1_m = uu___1; + FStarC_Extraction_ML_Syntax.mlmodule1_attrs = + (m1.FStarC_Extraction_ML_Syntax.mlmodule1_attrs) + } in + (env1, uu___) + | FStarC_Extraction_ML_Syntax.MLM_Exn (name, sym_tys) -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Compiler_List.map + (fun uu___4 -> + match uu___4 with + | (s, t) -> + let uu___5 = elim_mlty env1 t in (s, uu___5)) + sym_tys in + (name, uu___3) in + FStarC_Extraction_ML_Syntax.MLM_Exn uu___2 in + { + FStarC_Extraction_ML_Syntax.mlmodule1_m = uu___1; + FStarC_Extraction_ML_Syntax.mlmodule1_attrs = + (m1.FStarC_Extraction_ML_Syntax.mlmodule1_attrs) + } in + (env1, uu___) + | FStarC_Extraction_ML_Syntax.MLM_Top e -> + let uu___ = + let uu___1 = + let uu___2 = elim_mlexpr env1 e in + FStarC_Extraction_ML_Syntax.MLM_Top uu___2 in + { + FStarC_Extraction_ML_Syntax.mlmodule1_m = uu___1; + FStarC_Extraction_ML_Syntax.mlmodule1_attrs = + (m1.FStarC_Extraction_ML_Syntax.mlmodule1_attrs) + } in + (env1, uu___) + | uu___ -> (env1, m1) in + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun m1 -> + match uu___1 with + | (env1, out) -> + (try + (fun uu___2 -> + match () with + | () -> + let uu___3 = elim_module1 env1 m1 in + (match uu___3 with + | (env2, m2) -> (env2, (m2 :: out)))) () + with | Drop_tydef -> (env1, out))) (env, []) m in + match uu___ with | (env1, m1) -> (env1, (FStarC_Compiler_List.rev m1)) +let (set_current_module : + env_t -> FStarC_Extraction_ML_Syntax.mlpath -> env_t) = + fun e -> + fun n -> + let curmod = + FStarC_Compiler_List.op_At (FStar_Pervasives_Native.fst n) + [FStar_Pervasives_Native.snd n] in + { current_module = curmod; tydef_map = (e.tydef_map) } +let (elim_mllib : + env_t -> + FStarC_Extraction_ML_Syntax.mllib -> + (env_t * FStarC_Extraction_ML_Syntax.mllib)) + = + fun env -> + fun m -> + let uu___ = + let uu___1 = FStarC_Options.codegen () in + uu___1 <> (FStar_Pervasives_Native.Some FStarC_Options.FSharp) in + if uu___ + then (env, m) + else + (let uu___2 = m in + match uu___2 with + | FStarC_Extraction_ML_Syntax.MLLib libs -> + let elim_one_lib env1 lib = + let uu___3 = lib in + match uu___3 with + | (name, sig_mod, _libs) -> + let env2 = set_current_module env1 name in + let uu___4 = + match sig_mod with + | FStar_Pervasives_Native.Some (sig_, mod_) -> + let uu___5 = elim_module env2 mod_ in + (match uu___5 with + | (env3, mod_1) -> + ((FStar_Pervasives_Native.Some (sig_, mod_1)), + env3)) + | FStar_Pervasives_Native.None -> + (FStar_Pervasives_Native.None, env2) in + (match uu___4 with + | (sig_mod1, env3) -> (env3, (name, sig_mod1, _libs))) in + let uu___3 = FStarC_Compiler_Util.fold_map elim_one_lib env libs in + (match uu___3 with + | (env1, libs1) -> + (env1, (FStarC_Extraction_ML_Syntax.MLLib libs1)))) +let (elim_mllibs : + FStarC_Extraction_ML_Syntax.mllib Prims.list -> + FStarC_Extraction_ML_Syntax.mllib Prims.list) + = + fun l -> + let uu___ = FStarC_Compiler_Util.fold_map elim_mllib initial_env l in + FStar_Pervasives_Native.snd uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Extraction_ML_Syntax.ml b/ocaml/fstar-lib/generated/FStarC_Extraction_ML_Syntax.ml new file mode 100644 index 00000000000..2e01a6f1cc6 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Extraction_ML_Syntax.ml @@ -0,0 +1,1323 @@ +open Prims +type mlsymbol = Prims.string +type mlident = mlsymbol +type mlpath = (mlsymbol Prims.list * mlsymbol) +let (krml_keywords : Prims.string Prims.list) = [] +let (ocamlkeywords : Prims.string Prims.list) = + ["and"; + "as"; + "assert"; + "asr"; + "begin"; + "class"; + "constraint"; + "do"; + "done"; + "downto"; + "else"; + "end"; + "exception"; + "external"; + "false"; + "for"; + "fun"; + "function"; + "functor"; + "if"; + "in"; + "include"; + "inherit"; + "initializer"; + "land"; + "lazy"; + "let"; + "lor"; + "lsl"; + "lsr"; + "lxor"; + "match"; + "method"; + "mod"; + "module"; + "mutable"; + "new"; + "object"; + "of"; + "open"; + "or"; + "private"; + "rec"; + "sig"; + "struct"; + "then"; + "to"; + "true"; + "try"; + "type"; + "val"; + "virtual"; + "when"; + "while"; + "with"; + "nonrec"] +let (fsharpkeywords : Prims.string Prims.list) = + ["abstract"; + "and"; + "as"; + "assert"; + "base"; + "begin"; + "class"; + "default"; + "delegate"; + "do"; + "done"; + "downcast"; + "downto"; + "elif"; + "else"; + "end"; + "exception"; + "extern"; + "false"; + "finally"; + "fixed"; + "for"; + "fun"; + "function"; + "global"; + "if"; + "in"; + "inherit"; + "inline"; + "interface"; + "internal"; + "lazy"; + "let"; + "let!"; + "match"; + "member"; + "module"; + "mutable"; + "namespace"; + "new"; + "not"; + "null"; + "of"; + "open"; + "or"; + "override"; + "private"; + "public"; + "rec"; + "return"; + "return!"; + "select"; + "static"; + "struct"; + "then"; + "to"; + "true"; + "try"; + "type"; + "upcast"; + "use"; + "use!"; + "val"; + "void"; + "when"; + "while"; + "with"; + "yield"; + "yield!"; + "asr"; + "land"; + "lor"; + "lsl"; + "lsr"; + "lxor"; + "mod"; + "sig"; + "atomic"; + "break"; + "checked"; + "component"; + "const"; + "constraint"; + "constructor"; + "continue"; + "eager"; + "event"; + "external"; + "fixed"; + "functor"; + "include"; + "method"; + "mixin"; + "object"; + "parallel"; + "process"; + "protected"; + "pure"; + "sealed"; + "tailcall"; + "trait"; + "virtual"; + "volatile"] +let (string_of_mlpath : mlpath -> Prims.string) = + fun uu___ -> + match uu___ with + | (p, s) -> + FStarC_Compiler_String.concat "." (FStarC_Compiler_List.op_At p [s]) +type mlidents = mlident Prims.list +type mlsymbols = mlsymbol Prims.list +type e_tag = + | E_PURE + | E_ERASABLE + | E_IMPURE +let (uu___is_E_PURE : e_tag -> Prims.bool) = + fun projectee -> match projectee with | E_PURE -> true | uu___ -> false +let (uu___is_E_ERASABLE : e_tag -> Prims.bool) = + fun projectee -> match projectee with | E_ERASABLE -> true | uu___ -> false +let (uu___is_E_IMPURE : e_tag -> Prims.bool) = + fun projectee -> match projectee with | E_IMPURE -> true | uu___ -> false +type mlloc = (Prims.int * Prims.string) +let (dummy_loc : mlloc) = (Prims.int_zero, "") +type mlty = + | MLTY_Var of mlident + | MLTY_Fun of (mlty * e_tag * mlty) + | MLTY_Named of (mlty Prims.list * mlpath) + | MLTY_Tuple of mlty Prims.list + | MLTY_Top + | MLTY_Erased +let (uu___is_MLTY_Var : mlty -> Prims.bool) = + fun projectee -> + match projectee with | MLTY_Var _0 -> true | uu___ -> false +let (__proj__MLTY_Var__item___0 : mlty -> mlident) = + fun projectee -> match projectee with | MLTY_Var _0 -> _0 +let (uu___is_MLTY_Fun : mlty -> Prims.bool) = + fun projectee -> + match projectee with | MLTY_Fun _0 -> true | uu___ -> false +let (__proj__MLTY_Fun__item___0 : mlty -> (mlty * e_tag * mlty)) = + fun projectee -> match projectee with | MLTY_Fun _0 -> _0 +let (uu___is_MLTY_Named : mlty -> Prims.bool) = + fun projectee -> + match projectee with | MLTY_Named _0 -> true | uu___ -> false +let (__proj__MLTY_Named__item___0 : mlty -> (mlty Prims.list * mlpath)) = + fun projectee -> match projectee with | MLTY_Named _0 -> _0 +let (uu___is_MLTY_Tuple : mlty -> Prims.bool) = + fun projectee -> + match projectee with | MLTY_Tuple _0 -> true | uu___ -> false +let (__proj__MLTY_Tuple__item___0 : mlty -> mlty Prims.list) = + fun projectee -> match projectee with | MLTY_Tuple _0 -> _0 +let (uu___is_MLTY_Top : mlty -> Prims.bool) = + fun projectee -> match projectee with | MLTY_Top -> true | uu___ -> false +let (uu___is_MLTY_Erased : mlty -> Prims.bool) = + fun projectee -> + match projectee with | MLTY_Erased -> true | uu___ -> false +type mlconstant = + | MLC_Unit + | MLC_Bool of Prims.bool + | MLC_Int of (Prims.string * (FStarC_Const.signedness * FStarC_Const.width) + FStar_Pervasives_Native.option) + | MLC_Float of FStarC_BaseTypes.float + | MLC_Char of FStarC_BaseTypes.char + | MLC_String of Prims.string + | MLC_Bytes of FStarC_BaseTypes.byte Prims.array +let (uu___is_MLC_Unit : mlconstant -> Prims.bool) = + fun projectee -> match projectee with | MLC_Unit -> true | uu___ -> false +let (uu___is_MLC_Bool : mlconstant -> Prims.bool) = + fun projectee -> + match projectee with | MLC_Bool _0 -> true | uu___ -> false +let (__proj__MLC_Bool__item___0 : mlconstant -> Prims.bool) = + fun projectee -> match projectee with | MLC_Bool _0 -> _0 +let (uu___is_MLC_Int : mlconstant -> Prims.bool) = + fun projectee -> match projectee with | MLC_Int _0 -> true | uu___ -> false +let (__proj__MLC_Int__item___0 : + mlconstant -> + (Prims.string * (FStarC_Const.signedness * FStarC_Const.width) + FStar_Pervasives_Native.option)) + = fun projectee -> match projectee with | MLC_Int _0 -> _0 +let (uu___is_MLC_Float : mlconstant -> Prims.bool) = + fun projectee -> + match projectee with | MLC_Float _0 -> true | uu___ -> false +let (__proj__MLC_Float__item___0 : mlconstant -> FStarC_BaseTypes.float) = + fun projectee -> match projectee with | MLC_Float _0 -> _0 +let (uu___is_MLC_Char : mlconstant -> Prims.bool) = + fun projectee -> + match projectee with | MLC_Char _0 -> true | uu___ -> false +let (__proj__MLC_Char__item___0 : mlconstant -> FStarC_BaseTypes.char) = + fun projectee -> match projectee with | MLC_Char _0 -> _0 +let (uu___is_MLC_String : mlconstant -> Prims.bool) = + fun projectee -> + match projectee with | MLC_String _0 -> true | uu___ -> false +let (__proj__MLC_String__item___0 : mlconstant -> Prims.string) = + fun projectee -> match projectee with | MLC_String _0 -> _0 +let (uu___is_MLC_Bytes : mlconstant -> Prims.bool) = + fun projectee -> + match projectee with | MLC_Bytes _0 -> true | uu___ -> false +let (__proj__MLC_Bytes__item___0 : + mlconstant -> FStarC_BaseTypes.byte Prims.array) = + fun projectee -> match projectee with | MLC_Bytes _0 -> _0 +type mlpattern = + | MLP_Wild + | MLP_Const of mlconstant + | MLP_Var of mlident + | MLP_CTor of (mlpath * mlpattern Prims.list) + | MLP_Branch of mlpattern Prims.list + | MLP_Record of (mlsymbol Prims.list * (mlsymbol * mlpattern) Prims.list) + | MLP_Tuple of mlpattern Prims.list +let (uu___is_MLP_Wild : mlpattern -> Prims.bool) = + fun projectee -> match projectee with | MLP_Wild -> true | uu___ -> false +let (uu___is_MLP_Const : mlpattern -> Prims.bool) = + fun projectee -> + match projectee with | MLP_Const _0 -> true | uu___ -> false +let (__proj__MLP_Const__item___0 : mlpattern -> mlconstant) = + fun projectee -> match projectee with | MLP_Const _0 -> _0 +let (uu___is_MLP_Var : mlpattern -> Prims.bool) = + fun projectee -> match projectee with | MLP_Var _0 -> true | uu___ -> false +let (__proj__MLP_Var__item___0 : mlpattern -> mlident) = + fun projectee -> match projectee with | MLP_Var _0 -> _0 +let (uu___is_MLP_CTor : mlpattern -> Prims.bool) = + fun projectee -> + match projectee with | MLP_CTor _0 -> true | uu___ -> false +let (__proj__MLP_CTor__item___0 : + mlpattern -> (mlpath * mlpattern Prims.list)) = + fun projectee -> match projectee with | MLP_CTor _0 -> _0 +let (uu___is_MLP_Branch : mlpattern -> Prims.bool) = + fun projectee -> + match projectee with | MLP_Branch _0 -> true | uu___ -> false +let (__proj__MLP_Branch__item___0 : mlpattern -> mlpattern Prims.list) = + fun projectee -> match projectee with | MLP_Branch _0 -> _0 +let (uu___is_MLP_Record : mlpattern -> Prims.bool) = + fun projectee -> + match projectee with | MLP_Record _0 -> true | uu___ -> false +let (__proj__MLP_Record__item___0 : + mlpattern -> (mlsymbol Prims.list * (mlsymbol * mlpattern) Prims.list)) = + fun projectee -> match projectee with | MLP_Record _0 -> _0 +let (uu___is_MLP_Tuple : mlpattern -> Prims.bool) = + fun projectee -> + match projectee with | MLP_Tuple _0 -> true | uu___ -> false +let (__proj__MLP_Tuple__item___0 : mlpattern -> mlpattern Prims.list) = + fun projectee -> match projectee with | MLP_Tuple _0 -> _0 +type meta = + | Mutable + | Assumed + | Private + | NoExtract + | CInline + | Substitute + | GCType + | PpxDerivingShow + | PpxDerivingShowConstant of Prims.string + | PpxDerivingYoJson + | Comment of Prims.string + | StackInline + | CPrologue of Prims.string + | CEpilogue of Prims.string + | CConst of Prims.string + | CCConv of Prims.string + | Erased + | CAbstract + | CIfDef + | CMacro + | Deprecated of Prims.string + | RemoveUnusedTypeParameters of (Prims.int Prims.list * + FStarC_Compiler_Range_Type.range) + | HasValDecl of FStarC_Compiler_Range_Type.range + | CNoInline +let (uu___is_Mutable : meta -> Prims.bool) = + fun projectee -> match projectee with | Mutable -> true | uu___ -> false +let (uu___is_Assumed : meta -> Prims.bool) = + fun projectee -> match projectee with | Assumed -> true | uu___ -> false +let (uu___is_Private : meta -> Prims.bool) = + fun projectee -> match projectee with | Private -> true | uu___ -> false +let (uu___is_NoExtract : meta -> Prims.bool) = + fun projectee -> match projectee with | NoExtract -> true | uu___ -> false +let (uu___is_CInline : meta -> Prims.bool) = + fun projectee -> match projectee with | CInline -> true | uu___ -> false +let (uu___is_Substitute : meta -> Prims.bool) = + fun projectee -> match projectee with | Substitute -> true | uu___ -> false +let (uu___is_GCType : meta -> Prims.bool) = + fun projectee -> match projectee with | GCType -> true | uu___ -> false +let (uu___is_PpxDerivingShow : meta -> Prims.bool) = + fun projectee -> + match projectee with | PpxDerivingShow -> true | uu___ -> false +let (uu___is_PpxDerivingShowConstant : meta -> Prims.bool) = + fun projectee -> + match projectee with + | PpxDerivingShowConstant _0 -> true + | uu___ -> false +let (__proj__PpxDerivingShowConstant__item___0 : meta -> Prims.string) = + fun projectee -> match projectee with | PpxDerivingShowConstant _0 -> _0 +let (uu___is_PpxDerivingYoJson : meta -> Prims.bool) = + fun projectee -> + match projectee with | PpxDerivingYoJson -> true | uu___ -> false +let (uu___is_Comment : meta -> Prims.bool) = + fun projectee -> match projectee with | Comment _0 -> true | uu___ -> false +let (__proj__Comment__item___0 : meta -> Prims.string) = + fun projectee -> match projectee with | Comment _0 -> _0 +let (uu___is_StackInline : meta -> Prims.bool) = + fun projectee -> + match projectee with | StackInline -> true | uu___ -> false +let (uu___is_CPrologue : meta -> Prims.bool) = + fun projectee -> + match projectee with | CPrologue _0 -> true | uu___ -> false +let (__proj__CPrologue__item___0 : meta -> Prims.string) = + fun projectee -> match projectee with | CPrologue _0 -> _0 +let (uu___is_CEpilogue : meta -> Prims.bool) = + fun projectee -> + match projectee with | CEpilogue _0 -> true | uu___ -> false +let (__proj__CEpilogue__item___0 : meta -> Prims.string) = + fun projectee -> match projectee with | CEpilogue _0 -> _0 +let (uu___is_CConst : meta -> Prims.bool) = + fun projectee -> match projectee with | CConst _0 -> true | uu___ -> false +let (__proj__CConst__item___0 : meta -> Prims.string) = + fun projectee -> match projectee with | CConst _0 -> _0 +let (uu___is_CCConv : meta -> Prims.bool) = + fun projectee -> match projectee with | CCConv _0 -> true | uu___ -> false +let (__proj__CCConv__item___0 : meta -> Prims.string) = + fun projectee -> match projectee with | CCConv _0 -> _0 +let (uu___is_Erased : meta -> Prims.bool) = + fun projectee -> match projectee with | Erased -> true | uu___ -> false +let (uu___is_CAbstract : meta -> Prims.bool) = + fun projectee -> match projectee with | CAbstract -> true | uu___ -> false +let (uu___is_CIfDef : meta -> Prims.bool) = + fun projectee -> match projectee with | CIfDef -> true | uu___ -> false +let (uu___is_CMacro : meta -> Prims.bool) = + fun projectee -> match projectee with | CMacro -> true | uu___ -> false +let (uu___is_Deprecated : meta -> Prims.bool) = + fun projectee -> + match projectee with | Deprecated _0 -> true | uu___ -> false +let (__proj__Deprecated__item___0 : meta -> Prims.string) = + fun projectee -> match projectee with | Deprecated _0 -> _0 +let (uu___is_RemoveUnusedTypeParameters : meta -> Prims.bool) = + fun projectee -> + match projectee with + | RemoveUnusedTypeParameters _0 -> true + | uu___ -> false +let (__proj__RemoveUnusedTypeParameters__item___0 : + meta -> (Prims.int Prims.list * FStarC_Compiler_Range_Type.range)) = + fun projectee -> match projectee with | RemoveUnusedTypeParameters _0 -> _0 +let (uu___is_HasValDecl : meta -> Prims.bool) = + fun projectee -> + match projectee with | HasValDecl _0 -> true | uu___ -> false +let (__proj__HasValDecl__item___0 : meta -> FStarC_Compiler_Range_Type.range) + = fun projectee -> match projectee with | HasValDecl _0 -> _0 +let (uu___is_CNoInline : meta -> Prims.bool) = + fun projectee -> match projectee with | CNoInline -> true | uu___ -> false +type metadata = meta Prims.list +type mlletflavor = + | Rec + | NonRec +let (uu___is_Rec : mlletflavor -> Prims.bool) = + fun projectee -> match projectee with | Rec -> true | uu___ -> false +let (uu___is_NonRec : mlletflavor -> Prims.bool) = + fun projectee -> match projectee with | NonRec -> true | uu___ -> false +type mlbinder = + { + mlbinder_name: mlident ; + mlbinder_ty: mlty ; + mlbinder_attrs: mlexpr Prims.list } +and mlexpr' = + | MLE_Const of mlconstant + | MLE_Var of mlident + | MLE_Name of mlpath + | MLE_Let of ((mlletflavor * mllb Prims.list) * mlexpr) + | MLE_App of (mlexpr * mlexpr Prims.list) + | MLE_TApp of (mlexpr * mlty Prims.list) + | MLE_Fun of (mlbinder Prims.list * mlexpr) + | MLE_Match of (mlexpr * (mlpattern * mlexpr FStar_Pervasives_Native.option + * mlexpr) Prims.list) + | MLE_Coerce of (mlexpr * mlty * mlty) + | MLE_CTor of (mlpath * mlexpr Prims.list) + | MLE_Seq of mlexpr Prims.list + | MLE_Tuple of mlexpr Prims.list + | MLE_Record of (mlsymbol Prims.list * mlsymbol * (mlsymbol * mlexpr) + Prims.list) + | MLE_Proj of (mlexpr * mlpath) + | MLE_If of (mlexpr * mlexpr * mlexpr FStar_Pervasives_Native.option) + | MLE_Raise of (mlpath * mlexpr Prims.list) + | MLE_Try of (mlexpr * (mlpattern * mlexpr FStar_Pervasives_Native.option * + mlexpr) Prims.list) +and mlexpr = { + expr: mlexpr' ; + mlty: mlty ; + loc: mlloc } +and mllb = + { + mllb_name: mlident ; + mllb_tysc: (ty_param Prims.list * mlty) FStar_Pervasives_Native.option ; + mllb_add_unit: Prims.bool ; + mllb_def: mlexpr ; + mllb_attrs: mlexpr Prims.list ; + mllb_meta: metadata ; + print_typ: Prims.bool } +and ty_param = { + ty_param_name: mlident ; + ty_param_attrs: mlexpr Prims.list } +let (__proj__Mkmlbinder__item__mlbinder_name : mlbinder -> mlident) = + fun projectee -> + match projectee with + | { mlbinder_name; mlbinder_ty; mlbinder_attrs;_} -> mlbinder_name +let (__proj__Mkmlbinder__item__mlbinder_ty : mlbinder -> mlty) = + fun projectee -> + match projectee with + | { mlbinder_name; mlbinder_ty; mlbinder_attrs;_} -> mlbinder_ty +let (__proj__Mkmlbinder__item__mlbinder_attrs : + mlbinder -> mlexpr Prims.list) = + fun projectee -> + match projectee with + | { mlbinder_name; mlbinder_ty; mlbinder_attrs;_} -> mlbinder_attrs +let (uu___is_MLE_Const : mlexpr' -> Prims.bool) = + fun projectee -> + match projectee with | MLE_Const _0 -> true | uu___ -> false +let (__proj__MLE_Const__item___0 : mlexpr' -> mlconstant) = + fun projectee -> match projectee with | MLE_Const _0 -> _0 +let (uu___is_MLE_Var : mlexpr' -> Prims.bool) = + fun projectee -> match projectee with | MLE_Var _0 -> true | uu___ -> false +let (__proj__MLE_Var__item___0 : mlexpr' -> mlident) = + fun projectee -> match projectee with | MLE_Var _0 -> _0 +let (uu___is_MLE_Name : mlexpr' -> Prims.bool) = + fun projectee -> + match projectee with | MLE_Name _0 -> true | uu___ -> false +let (__proj__MLE_Name__item___0 : mlexpr' -> mlpath) = + fun projectee -> match projectee with | MLE_Name _0 -> _0 +let (uu___is_MLE_Let : mlexpr' -> Prims.bool) = + fun projectee -> match projectee with | MLE_Let _0 -> true | uu___ -> false +let (__proj__MLE_Let__item___0 : + mlexpr' -> ((mlletflavor * mllb Prims.list) * mlexpr)) = + fun projectee -> match projectee with | MLE_Let _0 -> _0 +let (uu___is_MLE_App : mlexpr' -> Prims.bool) = + fun projectee -> match projectee with | MLE_App _0 -> true | uu___ -> false +let (__proj__MLE_App__item___0 : mlexpr' -> (mlexpr * mlexpr Prims.list)) = + fun projectee -> match projectee with | MLE_App _0 -> _0 +let (uu___is_MLE_TApp : mlexpr' -> Prims.bool) = + fun projectee -> + match projectee with | MLE_TApp _0 -> true | uu___ -> false +let (__proj__MLE_TApp__item___0 : mlexpr' -> (mlexpr * mlty Prims.list)) = + fun projectee -> match projectee with | MLE_TApp _0 -> _0 +let (uu___is_MLE_Fun : mlexpr' -> Prims.bool) = + fun projectee -> match projectee with | MLE_Fun _0 -> true | uu___ -> false +let (__proj__MLE_Fun__item___0 : mlexpr' -> (mlbinder Prims.list * mlexpr)) = + fun projectee -> match projectee with | MLE_Fun _0 -> _0 +let (uu___is_MLE_Match : mlexpr' -> Prims.bool) = + fun projectee -> + match projectee with | MLE_Match _0 -> true | uu___ -> false +let (__proj__MLE_Match__item___0 : + mlexpr' -> + (mlexpr * (mlpattern * mlexpr FStar_Pervasives_Native.option * mlexpr) + Prims.list)) + = fun projectee -> match projectee with | MLE_Match _0 -> _0 +let (uu___is_MLE_Coerce : mlexpr' -> Prims.bool) = + fun projectee -> + match projectee with | MLE_Coerce _0 -> true | uu___ -> false +let (__proj__MLE_Coerce__item___0 : mlexpr' -> (mlexpr * mlty * mlty)) = + fun projectee -> match projectee with | MLE_Coerce _0 -> _0 +let (uu___is_MLE_CTor : mlexpr' -> Prims.bool) = + fun projectee -> + match projectee with | MLE_CTor _0 -> true | uu___ -> false +let (__proj__MLE_CTor__item___0 : mlexpr' -> (mlpath * mlexpr Prims.list)) = + fun projectee -> match projectee with | MLE_CTor _0 -> _0 +let (uu___is_MLE_Seq : mlexpr' -> Prims.bool) = + fun projectee -> match projectee with | MLE_Seq _0 -> true | uu___ -> false +let (__proj__MLE_Seq__item___0 : mlexpr' -> mlexpr Prims.list) = + fun projectee -> match projectee with | MLE_Seq _0 -> _0 +let (uu___is_MLE_Tuple : mlexpr' -> Prims.bool) = + fun projectee -> + match projectee with | MLE_Tuple _0 -> true | uu___ -> false +let (__proj__MLE_Tuple__item___0 : mlexpr' -> mlexpr Prims.list) = + fun projectee -> match projectee with | MLE_Tuple _0 -> _0 +let (uu___is_MLE_Record : mlexpr' -> Prims.bool) = + fun projectee -> + match projectee with | MLE_Record _0 -> true | uu___ -> false +let (__proj__MLE_Record__item___0 : + mlexpr' -> + (mlsymbol Prims.list * mlsymbol * (mlsymbol * mlexpr) Prims.list)) + = fun projectee -> match projectee with | MLE_Record _0 -> _0 +let (uu___is_MLE_Proj : mlexpr' -> Prims.bool) = + fun projectee -> + match projectee with | MLE_Proj _0 -> true | uu___ -> false +let (__proj__MLE_Proj__item___0 : mlexpr' -> (mlexpr * mlpath)) = + fun projectee -> match projectee with | MLE_Proj _0 -> _0 +let (uu___is_MLE_If : mlexpr' -> Prims.bool) = + fun projectee -> match projectee with | MLE_If _0 -> true | uu___ -> false +let (__proj__MLE_If__item___0 : + mlexpr' -> (mlexpr * mlexpr * mlexpr FStar_Pervasives_Native.option)) = + fun projectee -> match projectee with | MLE_If _0 -> _0 +let (uu___is_MLE_Raise : mlexpr' -> Prims.bool) = + fun projectee -> + match projectee with | MLE_Raise _0 -> true | uu___ -> false +let (__proj__MLE_Raise__item___0 : mlexpr' -> (mlpath * mlexpr Prims.list)) = + fun projectee -> match projectee with | MLE_Raise _0 -> _0 +let (uu___is_MLE_Try : mlexpr' -> Prims.bool) = + fun projectee -> match projectee with | MLE_Try _0 -> true | uu___ -> false +let (__proj__MLE_Try__item___0 : + mlexpr' -> + (mlexpr * (mlpattern * mlexpr FStar_Pervasives_Native.option * mlexpr) + Prims.list)) + = fun projectee -> match projectee with | MLE_Try _0 -> _0 +let (__proj__Mkmlexpr__item__expr : mlexpr -> mlexpr') = + fun projectee -> + match projectee with | { expr; mlty = mlty1; loc;_} -> expr +let (__proj__Mkmlexpr__item__mlty : mlexpr -> mlty) = + fun projectee -> + match projectee with | { expr; mlty = mlty1; loc;_} -> mlty1 +let (__proj__Mkmlexpr__item__loc : mlexpr -> mlloc) = + fun projectee -> match projectee with | { expr; mlty = mlty1; loc;_} -> loc +let (__proj__Mkmllb__item__mllb_name : mllb -> mlident) = + fun projectee -> + match projectee with + | { mllb_name; mllb_tysc; mllb_add_unit; mllb_def; mllb_attrs; mllb_meta; + print_typ;_} -> mllb_name +let (__proj__Mkmllb__item__mllb_tysc : + mllb -> (ty_param Prims.list * mlty) FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { mllb_name; mllb_tysc; mllb_add_unit; mllb_def; mllb_attrs; mllb_meta; + print_typ;_} -> mllb_tysc +let (__proj__Mkmllb__item__mllb_add_unit : mllb -> Prims.bool) = + fun projectee -> + match projectee with + | { mllb_name; mllb_tysc; mllb_add_unit; mllb_def; mllb_attrs; mllb_meta; + print_typ;_} -> mllb_add_unit +let (__proj__Mkmllb__item__mllb_def : mllb -> mlexpr) = + fun projectee -> + match projectee with + | { mllb_name; mllb_tysc; mllb_add_unit; mllb_def; mllb_attrs; mllb_meta; + print_typ;_} -> mllb_def +let (__proj__Mkmllb__item__mllb_attrs : mllb -> mlexpr Prims.list) = + fun projectee -> + match projectee with + | { mllb_name; mllb_tysc; mllb_add_unit; mllb_def; mllb_attrs; mllb_meta; + print_typ;_} -> mllb_attrs +let (__proj__Mkmllb__item__mllb_meta : mllb -> metadata) = + fun projectee -> + match projectee with + | { mllb_name; mllb_tysc; mllb_add_unit; mllb_def; mllb_attrs; mllb_meta; + print_typ;_} -> mllb_meta +let (__proj__Mkmllb__item__print_typ : mllb -> Prims.bool) = + fun projectee -> + match projectee with + | { mllb_name; mllb_tysc; mllb_add_unit; mllb_def; mllb_attrs; mllb_meta; + print_typ;_} -> print_typ +let (__proj__Mkty_param__item__ty_param_name : ty_param -> mlident) = + fun projectee -> + match projectee with + | { ty_param_name; ty_param_attrs;_} -> ty_param_name +let (__proj__Mkty_param__item__ty_param_attrs : + ty_param -> mlexpr Prims.list) = + fun projectee -> + match projectee with + | { ty_param_name; ty_param_attrs;_} -> ty_param_attrs +type mlbranch = (mlpattern * mlexpr FStar_Pervasives_Native.option * mlexpr) +type mlletbinding = (mlletflavor * mllb Prims.list) +type mlattribute = mlexpr +type mltyscheme = (ty_param Prims.list * mlty) +type mltybody = + | MLTD_Abbrev of mlty + | MLTD_Record of (mlsymbol * mlty) Prims.list + | MLTD_DType of (mlsymbol * (mlsymbol * mlty) Prims.list) Prims.list +let (uu___is_MLTD_Abbrev : mltybody -> Prims.bool) = + fun projectee -> + match projectee with | MLTD_Abbrev _0 -> true | uu___ -> false +let (__proj__MLTD_Abbrev__item___0 : mltybody -> mlty) = + fun projectee -> match projectee with | MLTD_Abbrev _0 -> _0 +let (uu___is_MLTD_Record : mltybody -> Prims.bool) = + fun projectee -> + match projectee with | MLTD_Record _0 -> true | uu___ -> false +let (__proj__MLTD_Record__item___0 : + mltybody -> (mlsymbol * mlty) Prims.list) = + fun projectee -> match projectee with | MLTD_Record _0 -> _0 +let (uu___is_MLTD_DType : mltybody -> Prims.bool) = + fun projectee -> + match projectee with | MLTD_DType _0 -> true | uu___ -> false +let (__proj__MLTD_DType__item___0 : + mltybody -> (mlsymbol * (mlsymbol * mlty) Prims.list) Prims.list) = + fun projectee -> match projectee with | MLTD_DType _0 -> _0 +type one_mltydecl = + { + tydecl_assumed: Prims.bool ; + tydecl_name: mlsymbol ; + tydecl_ignored: mlsymbol FStar_Pervasives_Native.option ; + tydecl_parameters: ty_param Prims.list ; + tydecl_meta: metadata ; + tydecl_defn: mltybody FStar_Pervasives_Native.option } +let (__proj__Mkone_mltydecl__item__tydecl_assumed : + one_mltydecl -> Prims.bool) = + fun projectee -> + match projectee with + | { tydecl_assumed; tydecl_name; tydecl_ignored; tydecl_parameters; + tydecl_meta; tydecl_defn;_} -> tydecl_assumed +let (__proj__Mkone_mltydecl__item__tydecl_name : one_mltydecl -> mlsymbol) = + fun projectee -> + match projectee with + | { tydecl_assumed; tydecl_name; tydecl_ignored; tydecl_parameters; + tydecl_meta; tydecl_defn;_} -> tydecl_name +let (__proj__Mkone_mltydecl__item__tydecl_ignored : + one_mltydecl -> mlsymbol FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { tydecl_assumed; tydecl_name; tydecl_ignored; tydecl_parameters; + tydecl_meta; tydecl_defn;_} -> tydecl_ignored +let (__proj__Mkone_mltydecl__item__tydecl_parameters : + one_mltydecl -> ty_param Prims.list) = + fun projectee -> + match projectee with + | { tydecl_assumed; tydecl_name; tydecl_ignored; tydecl_parameters; + tydecl_meta; tydecl_defn;_} -> tydecl_parameters +let (__proj__Mkone_mltydecl__item__tydecl_meta : one_mltydecl -> metadata) = + fun projectee -> + match projectee with + | { tydecl_assumed; tydecl_name; tydecl_ignored; tydecl_parameters; + tydecl_meta; tydecl_defn;_} -> tydecl_meta +let (__proj__Mkone_mltydecl__item__tydecl_defn : + one_mltydecl -> mltybody FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { tydecl_assumed; tydecl_name; tydecl_ignored; tydecl_parameters; + tydecl_meta; tydecl_defn;_} -> tydecl_defn +type mltydecl = one_mltydecl Prims.list +type mlmodule1' = + | MLM_Ty of mltydecl + | MLM_Let of mlletbinding + | MLM_Exn of (mlsymbol * (mlsymbol * mlty) Prims.list) + | MLM_Top of mlexpr + | MLM_Loc of mlloc +let (uu___is_MLM_Ty : mlmodule1' -> Prims.bool) = + fun projectee -> match projectee with | MLM_Ty _0 -> true | uu___ -> false +let (__proj__MLM_Ty__item___0 : mlmodule1' -> mltydecl) = + fun projectee -> match projectee with | MLM_Ty _0 -> _0 +let (uu___is_MLM_Let : mlmodule1' -> Prims.bool) = + fun projectee -> match projectee with | MLM_Let _0 -> true | uu___ -> false +let (__proj__MLM_Let__item___0 : mlmodule1' -> mlletbinding) = + fun projectee -> match projectee with | MLM_Let _0 -> _0 +let (uu___is_MLM_Exn : mlmodule1' -> Prims.bool) = + fun projectee -> match projectee with | MLM_Exn _0 -> true | uu___ -> false +let (__proj__MLM_Exn__item___0 : + mlmodule1' -> (mlsymbol * (mlsymbol * mlty) Prims.list)) = + fun projectee -> match projectee with | MLM_Exn _0 -> _0 +let (uu___is_MLM_Top : mlmodule1' -> Prims.bool) = + fun projectee -> match projectee with | MLM_Top _0 -> true | uu___ -> false +let (__proj__MLM_Top__item___0 : mlmodule1' -> mlexpr) = + fun projectee -> match projectee with | MLM_Top _0 -> _0 +let (uu___is_MLM_Loc : mlmodule1' -> Prims.bool) = + fun projectee -> match projectee with | MLM_Loc _0 -> true | uu___ -> false +let (__proj__MLM_Loc__item___0 : mlmodule1' -> mlloc) = + fun projectee -> match projectee with | MLM_Loc _0 -> _0 +type mlmodule1 = + { + mlmodule1_m: mlmodule1' ; + mlmodule1_attrs: mlattribute Prims.list } +let (__proj__Mkmlmodule1__item__mlmodule1_m : mlmodule1 -> mlmodule1') = + fun projectee -> + match projectee with | { mlmodule1_m; mlmodule1_attrs;_} -> mlmodule1_m +let (__proj__Mkmlmodule1__item__mlmodule1_attrs : + mlmodule1 -> mlattribute Prims.list) = + fun projectee -> + match projectee with + | { mlmodule1_m; mlmodule1_attrs;_} -> mlmodule1_attrs +let (mk_mlmodule1 : mlmodule1' -> mlmodule1) = + fun m -> { mlmodule1_m = m; mlmodule1_attrs = [] } +let (mk_mlmodule1_with_attrs : + mlmodule1' -> mlattribute Prims.list -> mlmodule1) = + fun m -> fun attrs -> { mlmodule1_m = m; mlmodule1_attrs = attrs } +type mlmodule = mlmodule1 Prims.list +type mlsig1 = + | MLS_Mod of (mlsymbol * mlsig1 Prims.list) + | MLS_Ty of mltydecl + | MLS_Val of (mlsymbol * mltyscheme) + | MLS_Exn of (mlsymbol * mlty Prims.list) +let (uu___is_MLS_Mod : mlsig1 -> Prims.bool) = + fun projectee -> match projectee with | MLS_Mod _0 -> true | uu___ -> false +let (__proj__MLS_Mod__item___0 : mlsig1 -> (mlsymbol * mlsig1 Prims.list)) = + fun projectee -> match projectee with | MLS_Mod _0 -> _0 +let (uu___is_MLS_Ty : mlsig1 -> Prims.bool) = + fun projectee -> match projectee with | MLS_Ty _0 -> true | uu___ -> false +let (__proj__MLS_Ty__item___0 : mlsig1 -> mltydecl) = + fun projectee -> match projectee with | MLS_Ty _0 -> _0 +let (uu___is_MLS_Val : mlsig1 -> Prims.bool) = + fun projectee -> match projectee with | MLS_Val _0 -> true | uu___ -> false +let (__proj__MLS_Val__item___0 : mlsig1 -> (mlsymbol * mltyscheme)) = + fun projectee -> match projectee with | MLS_Val _0 -> _0 +let (uu___is_MLS_Exn : mlsig1 -> Prims.bool) = + fun projectee -> match projectee with | MLS_Exn _0 -> true | uu___ -> false +let (__proj__MLS_Exn__item___0 : mlsig1 -> (mlsymbol * mlty Prims.list)) = + fun projectee -> match projectee with | MLS_Exn _0 -> _0 +type mlsig = mlsig1 Prims.list +let (with_ty_loc : mlty -> mlexpr' -> mlloc -> mlexpr) = + fun t -> fun e -> fun l -> { expr = e; mlty = t; loc = l } +let (with_ty : mlty -> mlexpr' -> mlexpr) = + fun t -> fun e -> with_ty_loc t e dummy_loc +type mllib = + | MLLib of (mlpath * (mlsig * mlmodule) FStar_Pervasives_Native.option * + mllib) Prims.list +let (uu___is_MLLib : mllib -> Prims.bool) = fun projectee -> true +let (__proj__MLLib__item___0 : + mllib -> + (mlpath * (mlsig * mlmodule) FStar_Pervasives_Native.option * mllib) + Prims.list) + = fun projectee -> match projectee with | MLLib _0 -> _0 +let (ml_unit_ty : mlty) = MLTY_Erased +let (ml_bool_ty : mlty) = MLTY_Named ([], (["Prims"], "bool")) +let (ml_int_ty : mlty) = MLTY_Named ([], (["Prims"], "int")) +let (ml_string_ty : mlty) = MLTY_Named ([], (["Prims"], "string")) +let (ml_unit : mlexpr) = with_ty ml_unit_ty (MLE_Const MLC_Unit) +let (apply_obj_repr : mlexpr -> mlty -> mlexpr) = + fun x -> + fun t -> + let repr_name = + let uu___ = + let uu___1 = FStarC_Options.codegen () in + uu___1 = (FStar_Pervasives_Native.Some FStarC_Options.FSharp) in + if uu___ then MLE_Name ([], "box") else MLE_Name (["Obj"], "repr") in + let obj_repr = with_ty (MLTY_Fun (t, E_PURE, MLTY_Top)) repr_name in + with_ty_loc MLTY_Top (MLE_App (obj_repr, [x])) x.loc +let (ty_param_names : ty_param Prims.list -> Prims.string Prims.list) = + fun tys -> + FStarC_Compiler_List.map + (fun uu___ -> + match uu___ with + | { ty_param_name; ty_param_attrs = uu___1;_} -> ty_param_name) tys +let (push_unit : e_tag -> mltyscheme -> mltyscheme) = + fun eff -> + fun ts -> + let uu___ = ts in + match uu___ with | (vs, ty) -> (vs, (MLTY_Fun (ml_unit_ty, eff, ty))) +let (pop_unit : mltyscheme -> (e_tag * mltyscheme)) = + fun ts -> + let uu___ = ts in + match uu___ with + | (vs, ty) -> + (match ty with + | MLTY_Fun (l, eff, t) -> + if l = ml_unit_ty + then (eff, (vs, t)) + else failwith "unexpected: pop_unit: domain was not unit" + | uu___1 -> failwith "unexpected: pop_unit: not a function type") +let (ctor' : + Prims.string -> FStarC_Pprint.document Prims.list -> FStarC_Pprint.document) + = + fun n -> + fun args -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Pprint.break_ Prims.int_one in + let uu___4 = + let uu___5 = FStarC_Pprint.doc_of_string n in uu___5 :: args in + FStarC_Pprint.flow uu___3 uu___4 in + FStarC_Pprint.parens uu___2 in + FStarC_Pprint.group uu___1 in + FStarC_Pprint.nest (Prims.of_int (2)) uu___ +let (ctor : Prims.string -> FStarC_Pprint.document -> FStarC_Pprint.document) + = + fun n -> + fun arg -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Pprint.doc_of_string n in + FStarC_Pprint.op_Hat_Slash_Hat uu___3 arg in + FStarC_Pprint.parens uu___2 in + FStarC_Pprint.group uu___1 in + FStarC_Pprint.nest (Prims.of_int (2)) uu___ +let rec (mlty_to_doc : mlty -> FStarC_Pprint.document) = + fun t -> + match t with + | MLTY_Var v -> FStarC_Pprint.doc_of_string v + | MLTY_Fun (t1, uu___, t2) -> + let uu___1 = + let uu___2 = mlty_to_doc t1 in + let uu___3 = + let uu___4 = FStarC_Pprint.doc_of_string "->" in + let uu___5 = let uu___6 = mlty_to_doc t2 in [uu___6] in uu___4 :: + uu___5 in + uu___2 :: uu___3 in + ctor' "" uu___1 + | MLTY_Named (ts, p) -> + let uu___ = + let uu___1 = FStarC_Compiler_List.map mlty_to_doc ts in + let uu___2 = + let uu___3 = + let uu___4 = string_of_mlpath p in + FStarC_Pprint.doc_of_string uu___4 in + [uu___3] in + FStarC_Compiler_List.op_At uu___1 uu___2 in + ctor' "" uu___ + | MLTY_Tuple ts -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Pprint.doc_of_string " *" in + let uu___3 = FStarC_Pprint.break_ Prims.int_one in + FStarC_Pprint.op_Hat_Hat uu___2 uu___3 in + FStarC_Pprint.flow_map uu___1 mlty_to_doc ts in + ctor "" uu___ + | MLTY_Top -> FStarC_Pprint.doc_of_string "MLTY_Top" + | MLTY_Erased -> FStarC_Pprint.doc_of_string "MLTY_Erased" +let (mlty_to_string : mlty -> Prims.string) = + fun t -> let uu___ = mlty_to_doc t in FStarC_Pprint.render uu___ +let (mltyscheme_to_doc : mltyscheme -> FStarC_Pprint.document) = + fun tsc -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Pprint.break_ Prims.int_one in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.comma uu___4 in + let uu___4 = ty_param_names (FStar_Pervasives_Native.fst tsc) in + FStarC_Pprint.flow_map uu___3 FStarC_Pprint.doc_of_string uu___4 in + FStarC_Pprint.brackets uu___2 in + let uu___2 = + let uu___3 = FStarC_Pprint.doc_of_string "," in + let uu___4 = mlty_to_doc (FStar_Pervasives_Native.snd tsc) in + FStarC_Pprint.op_Hat_Slash_Hat uu___3 uu___4 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + ctor "" uu___ +let (mltyscheme_to_string : mltyscheme -> Prims.string) = + fun tsc -> let uu___ = mltyscheme_to_doc tsc in FStarC_Pprint.render uu___ +let (pair : + FStarC_Pprint.document -> FStarC_Pprint.document -> FStarC_Pprint.document) + = + fun a -> + fun b -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Pprint.op_Hat_Slash_Hat FStarC_Pprint.comma b in + FStarC_Pprint.op_Hat_Hat a uu___2 in + FStarC_Pprint.parens uu___1 in + FStarC_Pprint.group uu___ +let (triple : + FStarC_Pprint.document -> + FStarC_Pprint.document -> + FStarC_Pprint.document -> FStarC_Pprint.document) + = + fun a -> + fun b -> + fun c -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Pprint.op_Hat_Slash_Hat FStarC_Pprint.comma c in + FStarC_Pprint.op_Hat_Hat b uu___4 in + FStarC_Pprint.op_Hat_Slash_Hat FStarC_Pprint.comma uu___3 in + FStarC_Pprint.op_Hat_Hat a uu___2 in + FStarC_Pprint.parens uu___1 in + FStarC_Pprint.group uu___ +let (ctor2 : + Prims.string -> + FStarC_Pprint.document -> + FStarC_Pprint.document -> FStarC_Pprint.document) + = fun n -> fun a -> fun b -> let uu___ = pair a b in ctor n uu___ +let list_to_doc : + 't . + 't Prims.list -> ('t -> FStarC_Pprint.document) -> FStarC_Pprint.document + = + fun xs -> + fun f -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Pprint.break_ Prims.int_one in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.semi uu___4 in + FStarC_Pprint.flow_map uu___3 f xs in + FStarC_Pprint.brackets uu___2 in + FStarC_Pprint.group uu___1 in + FStarC_Pprint.nest (Prims.of_int (2)) uu___ +let option_to_doc : + 't . + 't FStar_Pervasives_Native.option -> + ('t -> FStarC_Pprint.document) -> FStarC_Pprint.document + = + fun x -> + fun f -> + match x with + | FStar_Pervasives_Native.Some x1 -> + let uu___ = + let uu___1 = FStarC_Pprint.doc_of_string "Some" in + let uu___2 = f x1 in FStarC_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | FStar_Pervasives_Native.None -> FStarC_Pprint.doc_of_string "None" +let (spaced : FStarC_Pprint.document -> FStarC_Pprint.document) = + fun a -> + let uu___ = FStarC_Pprint.break_ Prims.int_one in + let uu___1 = + let uu___2 = FStarC_Pprint.break_ Prims.int_one in + FStarC_Pprint.op_Hat_Hat a uu___2 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 +let (record : FStarC_Pprint.document Prims.list -> FStarC_Pprint.document) = + fun fs -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Pprint.break_ Prims.int_one in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.semi uu___5 in + FStarC_Pprint.separate uu___4 fs in + spaced uu___3 in + FStarC_Pprint.braces uu___2 in + FStarC_Pprint.nest (Prims.of_int (2)) uu___1 in + FStarC_Pprint.group uu___ +let (fld : Prims.string -> FStarC_Pprint.document -> FStarC_Pprint.document) + = + fun n -> + fun v -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Pprint.doc_of_string (Prims.strcat n " =") in + FStarC_Pprint.op_Hat_Slash_Hat uu___2 v in + FStarC_Pprint.nest (Prims.of_int (2)) uu___1 in + FStarC_Pprint.group uu___ +let rec (mlexpr_to_doc : mlexpr -> FStarC_Pprint.document) = + fun e -> + match e.expr with + | MLE_Const c -> + let uu___ = mlconstant_to_doc c in ctor "MLE_Const" uu___ + | MLE_Var x -> + let uu___ = FStarC_Pprint.doc_of_string x in ctor "MLE_Var" uu___ + | MLE_Name (p, x) -> + let uu___ = + FStarC_Pprint.doc_of_string (FStarC_Compiler_String.concat "." p) in + let uu___1 = FStarC_Pprint.doc_of_string x in + ctor2 "MLE_Name" uu___ uu___1 + | MLE_Let (lbs, e1) -> + let uu___ = mlletbinding_to_doc lbs in + let uu___1 = mlexpr_to_doc e1 in ctor2 "MLE_Let" uu___ uu___1 + | MLE_App (e1, es) -> + let uu___ = mlexpr_to_doc e1 in + let uu___1 = list_to_doc es mlexpr_to_doc in + ctor2 "MLE_App" uu___ uu___1 + | MLE_TApp (e1, ts) -> + let uu___ = mlexpr_to_doc e1 in + let uu___1 = list_to_doc ts mlty_to_doc in + ctor2 "MLE_TApp" uu___ uu___1 + | MLE_Fun (bs, e1) -> + let uu___ = + list_to_doc bs + (fun b -> + let uu___1 = FStarC_Pprint.doc_of_string b.mlbinder_name in + let uu___2 = mlty_to_doc b.mlbinder_ty in pair uu___1 uu___2) in + let uu___1 = mlexpr_to_doc e1 in ctor2 "MLE_Fun" uu___ uu___1 + | MLE_Match (e1, bs) -> + let uu___ = mlexpr_to_doc e1 in + let uu___1 = list_to_doc bs mlbranch_to_doc in + ctor2 "MLE_Match" uu___ uu___1 + | MLE_Coerce (e1, t1, t2) -> + let uu___ = + let uu___1 = mlexpr_to_doc e1 in + let uu___2 = mlty_to_doc t1 in + let uu___3 = mlty_to_doc t2 in triple uu___1 uu___2 uu___3 in + ctor "MLE_Coerce" uu___ + | MLE_CTor (p, es) -> + let uu___ = + let uu___1 = string_of_mlpath p in + FStarC_Pprint.doc_of_string uu___1 in + let uu___1 = list_to_doc es mlexpr_to_doc in + ctor2 "MLE_CTor" uu___ uu___1 + | MLE_Seq es -> + let uu___ = list_to_doc es mlexpr_to_doc in ctor "MLE_Seq" uu___ + | MLE_Tuple es -> + let uu___ = list_to_doc es mlexpr_to_doc in ctor "MLE_Tuple" uu___ + | MLE_Record (p, n, es) -> + let uu___ = + list_to_doc (FStarC_Compiler_List.op_At p [n]) + FStarC_Pprint.doc_of_string in + let uu___1 = + list_to_doc es + (fun uu___2 -> + match uu___2 with + | (x, e1) -> + let uu___3 = FStarC_Pprint.doc_of_string x in + let uu___4 = mlexpr_to_doc e1 in pair uu___3 uu___4) in + ctor2 "MLE_Record" uu___ uu___1 + | MLE_Proj (e1, p) -> + let uu___ = mlexpr_to_doc e1 in + let uu___1 = + let uu___2 = string_of_mlpath p in + FStarC_Pprint.doc_of_string uu___2 in + ctor2 "MLE_Proj" uu___ uu___1 + | MLE_If (e1, e2, e3) -> + let uu___ = + let uu___1 = mlexpr_to_doc e1 in + let uu___2 = mlexpr_to_doc e2 in + let uu___3 = option_to_doc e3 mlexpr_to_doc in + triple uu___1 uu___2 uu___3 in + ctor "MLE_If" uu___ + | MLE_Raise (p, es) -> + let uu___ = + let uu___1 = string_of_mlpath p in + FStarC_Pprint.doc_of_string uu___1 in + let uu___1 = list_to_doc es mlexpr_to_doc in + ctor2 "MLE_Raise" uu___ uu___1 + | MLE_Try (e1, bs) -> + let uu___ = mlexpr_to_doc e1 in + let uu___1 = list_to_doc bs mlbranch_to_doc in + ctor2 "MLE_Try" uu___ uu___1 +and (mlbranch_to_doc : + (mlpattern * mlexpr FStar_Pervasives_Native.option * mlexpr) -> + FStarC_Pprint.document) + = + fun uu___ -> + match uu___ with + | (p, e1, e2) -> + let uu___1 = mlpattern_to_doc p in + let uu___2 = option_to_doc e1 mlexpr_to_doc in + let uu___3 = mlexpr_to_doc e2 in triple uu___1 uu___2 uu___3 +and (mlletbinding_to_doc : + (mlletflavor * mllb Prims.list) -> FStarC_Pprint.document) = + fun lbs -> + let uu___ = + let uu___1 = + FStarC_Pprint.doc_of_string + (match FStar_Pervasives_Native.__proj__Mktuple2__item___1 lbs with + | Rec -> "Rec" + | NonRec -> "NonRec") in + let uu___2 = + let uu___3 = FStarC_Pprint.doc_of_string ", " in + let uu___4 = + list_to_doc + (FStar_Pervasives_Native.__proj__Mktuple2__item___2 lbs) + mllb_to_doc in + FStarC_Pprint.op_Hat_Hat uu___3 uu___4 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + FStarC_Pprint.parens uu___ +and (mllb_to_doc : mllb -> FStarC_Pprint.document) = + fun lb -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Pprint.doc_of_string lb.mllb_name in + fld "mllb_name" uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = list_to_doc lb.mllb_attrs mlexpr_to_doc in + fld "mllb_attrs" uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + option_to_doc lb.mllb_tysc + (fun uu___7 -> + match uu___7 with | (uu___8, t) -> mlty_to_doc t) in + fld "mllb_tysc" uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Compiler_Util.string_of_bool lb.mllb_add_unit in + FStarC_Pprint.doc_of_string uu___9 in + fld "mllb_add_unit" uu___8 in + let uu___8 = + let uu___9 = + let uu___10 = mlexpr_to_doc lb.mllb_def in + fld "mllb_def" uu___10 in + [uu___9] in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + record uu___ +and (mlconstant_to_doc : mlconstant -> FStarC_Pprint.document) = + fun mlc -> + match mlc with + | MLC_Unit -> FStarC_Pprint.doc_of_string "MLC_Unit" + | MLC_Bool b -> + let uu___ = + let uu___1 = FStarC_Compiler_Util.string_of_bool b in + FStarC_Pprint.doc_of_string uu___1 in + ctor "MLC_Bool" uu___ + | MLC_Int (s, FStar_Pervasives_Native.None) -> + let uu___ = FStarC_Pprint.doc_of_string s in ctor "MLC_Int" uu___ + | MLC_Int (s, FStar_Pervasives_Native.Some (s1, s2)) -> + let uu___ = + let uu___1 = FStarC_Pprint.doc_of_string s in + triple uu___1 FStarC_Pprint.underscore FStarC_Pprint.underscore in + ctor "MLC_Int" uu___ + | MLC_Float f -> ctor "MLC_Float" FStarC_Pprint.underscore + | MLC_Char c -> ctor "MLC_Char" FStarC_Pprint.underscore + | MLC_String s -> + let uu___ = FStarC_Pprint.doc_of_string s in ctor "MLC_String" uu___ + | MLC_Bytes b -> ctor "MLC_Bytes" FStarC_Pprint.underscore +and (mlpattern_to_doc : mlpattern -> FStarC_Pprint.document) = + fun mlp -> + match mlp with + | MLP_Wild -> FStarC_Pprint.doc_of_string "MLP_Wild" + | MLP_Const c -> + let uu___ = mlconstant_to_doc c in ctor "MLP_Const" uu___ + | MLP_Var x -> + let uu___ = FStarC_Pprint.doc_of_string x in ctor "MLP_Var" uu___ + | MLP_CTor (p, ps) -> + let uu___ = + let uu___1 = string_of_mlpath p in + FStarC_Pprint.doc_of_string uu___1 in + let uu___1 = list_to_doc ps mlpattern_to_doc in + ctor2 "MLP_CTor" uu___ uu___1 + | MLP_Branch ps -> + let uu___ = list_to_doc ps mlpattern_to_doc in + ctor "MLP_Branch" uu___ + | MLP_Record (path, fields) -> + let uu___ = + FStarC_Pprint.doc_of_string + (FStarC_Compiler_String.concat "." path) in + let uu___1 = + list_to_doc fields + (fun uu___2 -> + match uu___2 with + | (x, p) -> + let uu___3 = FStarC_Pprint.doc_of_string x in + let uu___4 = mlpattern_to_doc p in pair uu___3 uu___4) in + ctor2 "MLP_Record" uu___ uu___1 + | MLP_Tuple ps -> + let uu___ = list_to_doc ps mlpattern_to_doc in ctor "MLP_Tuple" uu___ +let (mlbranch_to_string : mlbranch -> Prims.string) = + fun b -> let uu___ = mlbranch_to_doc b in FStarC_Pprint.render uu___ +let (mlletbinding_to_string : mlletbinding -> Prims.string) = + fun lb -> let uu___ = mlletbinding_to_doc lb in FStarC_Pprint.render uu___ +let (mllb_to_string : mllb -> Prims.string) = + fun lb -> let uu___ = mllb_to_doc lb in FStarC_Pprint.render uu___ +let (mlpattern_to_string : mlpattern -> Prims.string) = + fun p -> let uu___ = mlpattern_to_doc p in FStarC_Pprint.render uu___ +let (mlconstant_to_string : mlconstant -> Prims.string) = + fun c -> let uu___ = mlconstant_to_doc c in FStarC_Pprint.render uu___ +let (mlexpr_to_string : mlexpr -> Prims.string) = + fun e -> let uu___ = mlexpr_to_doc e in FStarC_Pprint.render uu___ +let (mltybody_to_doc : mltybody -> FStarC_Pprint.document) = + fun d -> + match d with + | MLTD_Abbrev mlty1 -> + let uu___ = mlty_to_doc mlty1 in ctor "MLTD_Abbrev" uu___ + | MLTD_Record l -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Pprint.break_ Prims.int_one in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.semi uu___6 in + FStarC_Pprint.flow_map uu___5 + (fun uu___6 -> + match uu___6 with + | (x, t) -> + let uu___7 = FStarC_Pprint.doc_of_string x in + let uu___8 = mlty_to_doc t in pair uu___7 uu___8) + l in + spaced uu___4 in + FStarC_Pprint.braces uu___3 in + FStarC_Pprint.nest (Prims.of_int (2)) uu___2 in + FStarC_Pprint.group uu___1 in + ctor "MLTD_Record" uu___ + | MLTD_DType l -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Pprint.break_ Prims.int_one in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.semi uu___6 in + FStarC_Pprint.flow_map uu___5 + (fun uu___6 -> + match uu___6 with + | (x, l1) -> + let uu___7 = FStarC_Pprint.doc_of_string x in + let uu___8 = + list_to_doc l1 + (fun uu___9 -> + match uu___9 with + | (x1, t) -> + let uu___10 = + FStarC_Pprint.doc_of_string x1 in + let uu___11 = mlty_to_doc t in + pair uu___10 uu___11) in + pair uu___7 uu___8) l in + spaced uu___4 in + FStarC_Pprint.brackets uu___3 in + FStarC_Pprint.nest (Prims.of_int (2)) uu___2 in + FStarC_Pprint.group uu___1 in + ctor "MLTD_DType" uu___ +let (mltybody_to_string : mltybody -> Prims.string) = + fun d -> let uu___ = mltybody_to_doc d in FStarC_Pprint.render uu___ +let (one_mltydecl_to_doc : one_mltydecl -> FStarC_Pprint.document) = + fun d -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Pprint.doc_of_string d.tydecl_name in + fld "tydecl_name" uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = ty_param_names d.tydecl_parameters in + FStarC_Compiler_String.concat "," uu___6 in + FStarC_Pprint.doc_of_string uu___5 in + fld "tydecl_parameters" uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = option_to_doc d.tydecl_defn mltybody_to_doc in + fld "tydecl_defn" uu___6 in + [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + record uu___ +let (one_mltydecl_to_string : one_mltydecl -> Prims.string) = + fun d -> let uu___ = one_mltydecl_to_doc d in FStarC_Pprint.render uu___ +let (mlmodule1_to_doc : mlmodule1 -> FStarC_Pprint.document) = + fun m -> + let uu___ = + match m.mlmodule1_m with + | MLM_Ty d -> + let uu___1 = FStarC_Pprint.doc_of_string "MLM_Ty " in + let uu___2 = list_to_doc d one_mltydecl_to_doc in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 + | MLM_Let l -> + let uu___1 = FStarC_Pprint.doc_of_string "MLM_Let " in + let uu___2 = mlletbinding_to_doc l in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 + | MLM_Exn (s, l) -> + let uu___1 = FStarC_Pprint.doc_of_string "MLM_Exn" in + let uu___2 = + let uu___3 = FStarC_Pprint.doc_of_string s in + let uu___4 = + list_to_doc l + (fun uu___5 -> + match uu___5 with + | (x, t) -> + let uu___6 = FStarC_Pprint.doc_of_string x in + let uu___7 = mlty_to_doc t in pair uu___6 uu___7) in + pair uu___3 uu___4 in + FStarC_Pprint.op_Hat_Slash_Hat uu___1 uu___2 + | MLM_Top e -> + let uu___1 = FStarC_Pprint.doc_of_string "MLM_Top" in + let uu___2 = mlexpr_to_doc e in + FStarC_Pprint.op_Hat_Slash_Hat uu___1 uu___2 + | MLM_Loc _mlloc -> FStarC_Pprint.doc_of_string "MLM_Loc" in + FStarC_Pprint.group uu___ +let (mlmodule1_to_string : mlmodule1 -> Prims.string) = + fun m -> let uu___ = mlmodule1_to_doc m in FStarC_Pprint.render uu___ +let (mlmodule_to_doc : mlmodule -> FStarC_Pprint.document) = + fun m -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Pprint.break_ Prims.int_one in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.semi uu___4 in + FStarC_Pprint.separate_map uu___3 mlmodule1_to_doc m in + spaced uu___2 in + FStarC_Pprint.brackets uu___1 in + FStarC_Pprint.group uu___ +let (mlmodule_to_string : mlmodule -> Prims.string) = + fun m -> let uu___ = mlmodule_to_doc m in FStarC_Pprint.render uu___ +let (showable_mlty : mlty FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = mlty_to_string } +let (showable_mlconstant : mlconstant FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = mlconstant_to_string } +let (showable_mlexpr : mlexpr FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = mlexpr_to_string } +let (showable_mlmodule1 : mlmodule1 FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = mlmodule1_to_string } +let (showable_mlmodule : mlmodule FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = mlmodule_to_string } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Extraction_ML_Term.ml b/ocaml/fstar-lib/generated/FStarC_Extraction_ML_Term.ml new file mode 100644 index 00000000000..9c061fdb14b --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Extraction_ML_Term.ml @@ -0,0 +1,4600 @@ +open Prims +let (dbg_Extraction : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Extraction" +let (dbg_ExtractionNorm : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "ExtractionNorm" +exception Un_extractable +let (uu___is_Un_extractable : Prims.exn -> Prims.bool) = + fun projectee -> + match projectee with | Un_extractable -> true | uu___ -> false +let (type_leq : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Extraction_ML_Syntax.mlty -> + FStarC_Extraction_ML_Syntax.mlty -> Prims.bool) + = + fun g -> + fun t1 -> + fun t2 -> + FStarC_Extraction_ML_Util.type_leq + (FStarC_Extraction_ML_Util.udelta_unfold g) t1 t2 +let (type_leq_c : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Extraction_ML_Syntax.mlexpr FStar_Pervasives_Native.option -> + FStarC_Extraction_ML_Syntax.mlty -> + FStarC_Extraction_ML_Syntax.mlty -> + (Prims.bool * FStarC_Extraction_ML_Syntax.mlexpr + FStar_Pervasives_Native.option)) + = + fun g -> + fun t1 -> + fun t2 -> + FStarC_Extraction_ML_Util.type_leq_c + (FStarC_Extraction_ML_Util.udelta_unfold g) t1 t2 +let (eraseTypeDeep : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Extraction_ML_Syntax.mlty -> FStarC_Extraction_ML_Syntax.mlty) + = + fun g -> + fun t -> + FStarC_Extraction_ML_Util.eraseTypeDeep + (FStarC_Extraction_ML_Util.udelta_unfold g) t +let err_ill_typed_application : + 'uuuuu . + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.term -> + FStarC_Extraction_ML_Syntax.mlexpr -> + FStarC_Syntax_Syntax.args -> + FStarC_Extraction_ML_Syntax.mlty -> 'uuuuu + = + fun env -> + fun t -> + fun mlhead -> + fun args -> + fun ty -> + let uu___ = + let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + let uu___2 = + let uu___3 = + FStarC_Extraction_ML_UEnv.current_module_of_uenv env in + FStarC_Extraction_ML_Code.string_of_mlexpr uu___3 mlhead in + let uu___3 = + let uu___4 = + FStarC_Extraction_ML_UEnv.current_module_of_uenv env in + FStarC_Extraction_ML_Code.string_of_mlty uu___4 ty in + let uu___4 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + (FStarC_Class_Show.show_tuple2 + FStarC_Syntax_Print.showable_term + FStarC_Syntax_Print.showable_aqual)) args in + FStarC_Compiler_Util.format4 + "Ill-typed application: source application is %s \n translated prefix to %s at type %s\n remaining args are %s\n" + uu___1 uu___2 uu___3 uu___4 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) t + FStarC_Errors_Codes.Fatal_IllTyped () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___) +let err_ill_typed_erasure : + 'uuuuu . + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Compiler_Range_Type.range -> + FStarC_Extraction_ML_Syntax.mlty -> 'uuuuu + = + fun env -> + fun pos -> + fun ty -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Extraction_ML_UEnv.current_module_of_uenv env in + FStarC_Extraction_ML_Code.string_of_mlty uu___2 ty in + FStarC_Compiler_Util.format1 + "Erased value found where a value of type %s was expected" uu___1 in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range pos + FStarC_Errors_Codes.Fatal_IllTyped () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___) +let err_value_restriction : 'uuuuu . FStarC_Syntax_Syntax.term -> 'uuuuu = + fun t -> + let uu___ = + let uu___1 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t in + let uu___2 = FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.format2 + "Refusing to generalize because of the value restriction: (%s) %s" + uu___1 uu___2 in + FStarC_Errors.raise_error (FStarC_Syntax_Syntax.has_range_syntax ()) t + FStarC_Errors_Codes.Fatal_ValueRestriction () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) (Obj.magic uu___) +let (err_unexpected_eff : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.term -> + FStarC_Extraction_ML_Syntax.mlty -> + FStarC_Extraction_ML_Syntax.e_tag -> + FStarC_Extraction_ML_Syntax.e_tag -> unit) + = + fun env -> + fun t -> + fun ty -> + fun f0 -> + fun f1 -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Errors_Msg.text "For expression" in + let uu___4 = + FStarC_Class_PP.pp FStarC_Syntax_Print.pretty_term t in + FStarC_Pprint.prefix (Prims.of_int (4)) Prims.int_one + uu___3 uu___4 in + let uu___3 = + let uu___4 = FStarC_Errors_Msg.text "of type" in + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Extraction_ML_UEnv.current_module_of_uenv env in + FStarC_Extraction_ML_Code.string_of_mlty uu___7 ty in + FStarC_Pprint.arbitrary_string uu___6 in + FStarC_Pprint.prefix (Prims.of_int (4)) Prims.int_one + uu___4 uu___5 in + FStarC_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Errors_Msg.text "Expected effect" in + let uu___6 = + let uu___7 = FStarC_Extraction_ML_Util.eff_to_string f0 in + FStarC_Pprint.arbitrary_string uu___7 in + FStarC_Pprint.prefix (Prims.of_int (4)) Prims.int_one + uu___5 uu___6 in + let uu___5 = + let uu___6 = FStarC_Errors_Msg.text "got effect" in + let uu___7 = + let uu___8 = FStarC_Extraction_ML_Util.eff_to_string f1 in + FStarC_Pprint.arbitrary_string uu___8 in + FStarC_Pprint.prefix (Prims.of_int (4)) Prims.int_one + uu___6 uu___7 in + FStarC_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Errors.log_issue + (FStarC_Syntax_Syntax.has_range_syntax ()) t + FStarC_Errors_Codes.Warning_ExtractionUnexpectedEffect () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___) +let err_cannot_extract_effect : + 'uuuuu . + FStarC_Ident.lident -> + FStarC_Compiler_Range_Type.range -> + Prims.string -> Prims.string -> 'uuuuu + = + fun l -> + fun r -> + fun reason -> + fun ctxt -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Ident.string_of_lid l in + FStarC_Compiler_Util.format3 + "Cannot extract effect %s because %s (when extracting %s)" + uu___3 reason ctxt in + FStarC_Errors_Msg.text uu___2 in + [uu___1] in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_UnexpectedEffect () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___) +let (effect_as_etag : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Ident.lident -> FStarC_Extraction_ML_Syntax.e_tag) + = + let cache = FStarC_Compiler_Util.smap_create (Prims.of_int (20)) in + let rec delta_norm_eff g l = + let uu___ = + let uu___1 = FStarC_Ident.string_of_lid l in + FStarC_Compiler_Util.smap_try_find cache uu___1 in + match uu___ with + | FStar_Pervasives_Native.Some l1 -> l1 + | FStar_Pervasives_Native.None -> + let res = + let uu___1 = + let uu___2 = FStarC_Extraction_ML_UEnv.tcenv_of_uenv g in + FStarC_TypeChecker_Env.lookup_effect_abbrev uu___2 + [FStarC_Syntax_Syntax.U_zero] l in + match uu___1 with + | FStar_Pervasives_Native.None -> l + | FStar_Pervasives_Native.Some (uu___2, c) -> + delta_norm_eff g (FStarC_Syntax_Util.comp_effect_name c) in + ((let uu___2 = FStarC_Ident.string_of_lid l in + FStarC_Compiler_Util.smap_add cache uu___2 res); + res) in + fun g -> + fun l -> + let l1 = delta_norm_eff g l in + let uu___ = + FStarC_Ident.lid_equals l1 FStarC_Parser_Const.effect_PURE_lid in + if uu___ + then FStarC_Extraction_ML_Syntax.E_PURE + else + (let uu___2 = + let uu___3 = FStarC_Extraction_ML_UEnv.tcenv_of_uenv g in + FStarC_TypeChecker_Env.is_erasable_effect uu___3 l1 in + if uu___2 + then FStarC_Extraction_ML_Syntax.E_ERASABLE + else + (let ed_opt = + let uu___4 = FStarC_Extraction_ML_UEnv.tcenv_of_uenv g in + FStarC_TypeChecker_Env.effect_decl_opt uu___4 l1 in + match ed_opt with + | FStar_Pervasives_Native.Some (ed, qualifiers) -> + let uu___4 = + let uu___5 = FStarC_Extraction_ML_UEnv.tcenv_of_uenv g in + FStarC_TypeChecker_Env.is_reifiable_effect uu___5 + ed.FStarC_Syntax_Syntax.mname in + if uu___4 + then FStarC_Extraction_ML_Syntax.E_PURE + else FStarC_Extraction_ML_Syntax.E_IMPURE + | FStar_Pervasives_Native.None -> + FStarC_Extraction_ML_Syntax.E_IMPURE)) +let rec (is_arity_aux : + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.term -> Prims.bool) = + fun tcenv -> + fun t -> + let t1 = FStarC_Syntax_Util.unmeta t in + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t1 in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_unknown -> + let uu___1 = + let uu___2 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t1 in + FStarC_Compiler_Util.format1 "Impossible: is_arity (%s)" uu___2 in + failwith uu___1 + | FStarC_Syntax_Syntax.Tm_delayed uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t1 in + FStarC_Compiler_Util.format1 "Impossible: is_arity (%s)" uu___3 in + failwith uu___2 + | FStarC_Syntax_Syntax.Tm_ascribed uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t1 in + FStarC_Compiler_Util.format1 "Impossible: is_arity (%s)" uu___3 in + failwith uu___2 + | FStarC_Syntax_Syntax.Tm_meta uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t1 in + FStarC_Compiler_Util.format1 "Impossible: is_arity (%s)" uu___3 in + failwith uu___2 + | FStarC_Syntax_Syntax.Tm_lazy i -> + let uu___1 = FStarC_Syntax_Util.unfold_lazy i in + is_arity_aux tcenv uu___1 + | FStarC_Syntax_Syntax.Tm_uvar uu___1 -> false + | FStarC_Syntax_Syntax.Tm_constant uu___1 -> false + | FStarC_Syntax_Syntax.Tm_name uu___1 -> false + | FStarC_Syntax_Syntax.Tm_quoted uu___1 -> false + | FStarC_Syntax_Syntax.Tm_bvar uu___1 -> false + | FStarC_Syntax_Syntax.Tm_type uu___1 -> true + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = uu___1; + FStarC_Syntax_Syntax.comp = c;_} + -> is_arity_aux tcenv (FStarC_Syntax_Util.comp_result c) + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let topt = + FStarC_TypeChecker_Env.lookup_definition + [FStarC_TypeChecker_Env.Unfold + FStarC_Syntax_Syntax.delta_constant] tcenv + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + (match topt with + | FStar_Pervasives_Native.None -> false + | FStar_Pervasives_Native.Some (uu___1, t2) -> + is_arity_aux tcenv t2) + | FStarC_Syntax_Syntax.Tm_app uu___1 -> + let uu___2 = FStarC_Syntax_Util.head_and_args t1 in + (match uu___2 with | (head, uu___3) -> is_arity_aux tcenv head) + | FStarC_Syntax_Syntax.Tm_uinst (head, uu___1) -> + is_arity_aux tcenv head + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x; FStarC_Syntax_Syntax.phi = uu___1;_} + -> is_arity_aux tcenv x.FStarC_Syntax_Syntax.sort + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = uu___1; + FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = uu___2;_} + -> is_arity_aux tcenv body + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = uu___1; + FStarC_Syntax_Syntax.body1 = body;_} + -> is_arity_aux tcenv body + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = uu___1; + FStarC_Syntax_Syntax.ret_opt = uu___2; + FStarC_Syntax_Syntax.brs = branches; + FStarC_Syntax_Syntax.rc_opt1 = uu___3;_} + -> + (match branches with + | (uu___4, uu___5, e)::uu___6 -> is_arity_aux tcenv e + | uu___4 -> false) +let (is_arity : + FStarC_Extraction_ML_UEnv.uenv -> FStarC_Syntax_Syntax.term -> Prims.bool) + = + fun env -> + fun t -> + let uu___ = FStarC_Extraction_ML_UEnv.tcenv_of_uenv env in + is_arity_aux uu___ t +let (push_tcenv_binders : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.binders -> FStarC_Extraction_ML_UEnv.uenv) + = + fun u -> + fun bs -> + let tcenv = FStarC_Extraction_ML_UEnv.tcenv_of_uenv u in + let tcenv1 = FStarC_TypeChecker_Env.push_binders tcenv bs in + FStarC_Extraction_ML_UEnv.set_tcenv u tcenv1 +let rec (is_type_aux : + FStarC_Extraction_ML_UEnv.uenv -> FStarC_Syntax_Syntax.term -> Prims.bool) + = + fun env -> + fun t -> + let t1 = FStarC_Syntax_Subst.compress t in + match t1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_delayed uu___ -> + let uu___1 = + let uu___2 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t1 in + FStarC_Compiler_Util.format1 "Impossible: %s" uu___2 in + failwith uu___1 + | FStarC_Syntax_Syntax.Tm_unknown -> + let uu___ = + let uu___1 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t1 in + FStarC_Compiler_Util.format1 "Impossible: %s" uu___1 in + failwith uu___ + | FStarC_Syntax_Syntax.Tm_lazy i -> + let uu___ = FStarC_Syntax_Util.unfold_lazy i in + is_type_aux env uu___ + | FStarC_Syntax_Syntax.Tm_constant uu___ -> false + | FStarC_Syntax_Syntax.Tm_type uu___ -> true + | FStarC_Syntax_Syntax.Tm_refine uu___ -> true + | FStarC_Syntax_Syntax.Tm_arrow uu___ -> true + | FStarC_Syntax_Syntax.Tm_fvar fv when + let uu___ = FStarC_Parser_Const.failwith_lid () in + FStarC_Syntax_Syntax.fv_eq_lid fv uu___ -> false + | FStarC_Syntax_Syntax.Tm_fvar fv -> + FStarC_Extraction_ML_UEnv.is_type_name env fv + | FStarC_Syntax_Syntax.Tm_uvar (u, s) -> + let t2 = FStarC_Syntax_Util.ctx_uvar_typ u in + let uu___ = FStarC_Syntax_Subst.subst' s t2 in is_arity env uu___ + | FStarC_Syntax_Syntax.Tm_bvar + { FStarC_Syntax_Syntax.ppname = uu___; + FStarC_Syntax_Syntax.index = uu___1; + FStarC_Syntax_Syntax.sort = t2;_} + -> is_arity env t2 + | FStarC_Syntax_Syntax.Tm_name x -> + let g = FStarC_Extraction_ML_UEnv.tcenv_of_uenv env in + let uu___ = FStarC_TypeChecker_Env.try_lookup_bv g x in + (match uu___ with + | FStar_Pervasives_Native.Some (t2, uu___1) -> is_arity env t2 + | uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Tagged.tag_of + FStarC_Syntax_Syntax.tagged_term t1 in + FStarC_Compiler_Util.format1 + "Extraction: variable not found: %s" uu___3 in + failwith uu___2) + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t2; FStarC_Syntax_Syntax.asc = uu___; + FStarC_Syntax_Syntax.eff_opt = uu___1;_} + -> is_type_aux env t2 + | FStarC_Syntax_Syntax.Tm_uinst (t2, uu___) -> is_type_aux env t2 + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs; FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = uu___;_} + -> + let uu___1 = FStarC_Syntax_Subst.open_term bs body in + (match uu___1 with + | (bs1, body1) -> + let env1 = push_tcenv_binders env bs1 in + is_type_aux env1 body1) + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (false, lb::[]); + FStarC_Syntax_Syntax.body1 = body;_} + -> + let x = FStarC_Compiler_Util.left lb.FStarC_Syntax_Syntax.lbname in + let uu___ = + let uu___1 = + let uu___2 = FStarC_Syntax_Syntax.mk_binder x in [uu___2] in + FStarC_Syntax_Subst.open_term uu___1 body in + (match uu___ with + | (bs, body1) -> + let env1 = push_tcenv_binders env bs in is_type_aux env1 body1) + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (uu___, lbs); + FStarC_Syntax_Syntax.body1 = body;_} + -> + let uu___1 = FStarC_Syntax_Subst.open_let_rec lbs body in + (match uu___1 with + | (lbs1, body1) -> + let env1 = + let uu___2 = + FStarC_Compiler_List.map + (fun lb -> + let uu___3 = + FStarC_Compiler_Util.left + lb.FStarC_Syntax_Syntax.lbname in + FStarC_Syntax_Syntax.mk_binder uu___3) lbs1 in + push_tcenv_binders env uu___2 in + is_type_aux env1 body1) + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = uu___; + FStarC_Syntax_Syntax.ret_opt = uu___1; + FStarC_Syntax_Syntax.brs = branches; + FStarC_Syntax_Syntax.rc_opt1 = uu___2;_} + -> + (match branches with + | b::uu___3 -> + let uu___4 = FStarC_Syntax_Subst.open_branch b in + (match uu___4 with + | (pat, uu___5, e) -> + let uu___6 = + let uu___7 = + FStarC_Extraction_ML_UEnv.tcenv_of_uenv env in + FStarC_TypeChecker_PatternUtils.raw_pat_as_exp uu___7 + pat in + (match uu___6 with + | FStar_Pervasives_Native.None -> false + | FStar_Pervasives_Native.Some (uu___7, bvs) -> + let binders = + FStarC_Compiler_List.map + (fun bv -> FStarC_Syntax_Syntax.mk_binder bv) + bvs in + let env1 = push_tcenv_binders env binders in + is_type_aux env1 e)) + | uu___3 -> false) + | FStarC_Syntax_Syntax.Tm_quoted uu___ -> false + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t2; + FStarC_Syntax_Syntax.meta = uu___;_} + -> is_type_aux env t2 + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = uu___;_} + -> is_type_aux env head +let (is_type : + FStarC_Extraction_ML_UEnv.uenv -> FStarC_Syntax_Syntax.term -> Prims.bool) + = + fun env -> + fun t -> + FStarC_Extraction_ML_UEnv.debug env + (fun uu___1 -> + let uu___2 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.print2 "checking is_type (%s) %s\n" uu___2 + uu___3); + (let b = is_type_aux env t in + FStarC_Extraction_ML_UEnv.debug env + (fun uu___2 -> + if b + then + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + let uu___4 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t in + FStarC_Compiler_Util.print2 "yes, is_type %s (%s)\n" uu___3 + uu___4 + else + (let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + let uu___5 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term + t in + FStarC_Compiler_Util.print2 "not a type %s (%s)\n" uu___4 + uu___5)); + b) +let (is_type_binder : + FStarC_Extraction_ML_UEnv.uenv -> FStarC_Syntax_Syntax.binder -> Prims.bool) + = + fun env -> + fun x -> + is_arity env + (x.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort +let (is_constructor : FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_fvar + { FStarC_Syntax_Syntax.fv_name = uu___1; + FStarC_Syntax_Syntax.fv_qual = FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Data_ctor);_} + -> true + | FStarC_Syntax_Syntax.Tm_fvar + { FStarC_Syntax_Syntax.fv_name = uu___1; + FStarC_Syntax_Syntax.fv_qual = FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Record_ctor uu___2);_} + -> true + | uu___1 -> false +let rec (is_fstar_value : FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_constant uu___1 -> true + | FStarC_Syntax_Syntax.Tm_bvar uu___1 -> true + | FStarC_Syntax_Syntax.Tm_fvar uu___1 -> true + | FStarC_Syntax_Syntax.Tm_abs uu___1 -> true + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head; FStarC_Syntax_Syntax.args = args;_} + -> + let uu___1 = is_constructor head in + if uu___1 + then + FStarC_Compiler_List.for_all + (fun uu___2 -> + match uu___2 with | (te, uu___3) -> is_fstar_value te) args + else false + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t1; + FStarC_Syntax_Syntax.meta = uu___1;_} + -> is_fstar_value t1 + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t1; FStarC_Syntax_Syntax.asc = uu___1; + FStarC_Syntax_Syntax.eff_opt = uu___2;_} + -> is_fstar_value t1 + | uu___1 -> false +let rec (is_ml_value : FStarC_Extraction_ML_Syntax.mlexpr -> Prims.bool) = + fun e -> + match e.FStarC_Extraction_ML_Syntax.expr with + | FStarC_Extraction_ML_Syntax.MLE_Const uu___ -> true + | FStarC_Extraction_ML_Syntax.MLE_Var uu___ -> true + | FStarC_Extraction_ML_Syntax.MLE_Name uu___ -> true + | FStarC_Extraction_ML_Syntax.MLE_Fun uu___ -> true + | FStarC_Extraction_ML_Syntax.MLE_CTor (uu___, exps) -> + FStarC_Compiler_Util.for_all is_ml_value exps + | FStarC_Extraction_ML_Syntax.MLE_Tuple exps -> + FStarC_Compiler_Util.for_all is_ml_value exps + | FStarC_Extraction_ML_Syntax.MLE_Record (uu___, uu___1, fields) -> + FStarC_Compiler_Util.for_all + (fun uu___2 -> match uu___2 with | (uu___3, e1) -> is_ml_value e1) + fields + | FStarC_Extraction_ML_Syntax.MLE_TApp (h, uu___) -> is_ml_value h + | uu___ -> false +let (normalize_abs : FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun t0 -> + let rec aux bs t copt = + let t1 = FStarC_Syntax_Subst.compress t in + match t1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs'; FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = copt1;_} + -> aux (FStarC_Compiler_List.op_At bs bs') body copt1 + | uu___ -> + let e' = FStarC_Syntax_Util.unascribe t1 in + let uu___1 = FStarC_Syntax_Util.is_fun e' in + if uu___1 + then aux bs e' copt + else FStarC_Syntax_Util.abs bs e' copt in + aux [] t0 FStar_Pervasives_Native.None +let (unit_binder : unit -> FStarC_Syntax_Syntax.binder) = + fun uu___ -> + let uu___1 = + FStarC_Syntax_Syntax.new_bv FStar_Pervasives_Native.None + FStarC_Syntax_Syntax.t_unit in + FStarC_Syntax_Syntax.mk_binder uu___1 +let (check_pats_for_ite : + (FStarC_Syntax_Syntax.pat * FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option * FStarC_Syntax_Syntax.term) Prims.list -> + (Prims.bool * FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option * + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option)) + = + fun l -> + let def = + (false, FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) in + if (FStarC_Compiler_List.length l) <> (Prims.of_int (2)) + then def + else + (let uu___1 = FStarC_Compiler_List.hd l in + match uu___1 with + | (p1, w1, e1) -> + let uu___2 = + let uu___3 = FStarC_Compiler_List.tl l in + FStarC_Compiler_List.hd uu___3 in + (match uu___2 with + | (p2, w2, e2) -> + (match (w1, w2, (p1.FStarC_Syntax_Syntax.v), + (p2.FStarC_Syntax_Syntax.v)) + with + | (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None, + FStarC_Syntax_Syntax.Pat_constant + (FStarC_Const.Const_bool (true)), + FStarC_Syntax_Syntax.Pat_constant + (FStarC_Const.Const_bool (false))) -> + (true, (FStar_Pervasives_Native.Some e1), + (FStar_Pervasives_Native.Some e2)) + | (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None, + FStarC_Syntax_Syntax.Pat_constant + (FStarC_Const.Const_bool (false)), + FStarC_Syntax_Syntax.Pat_constant + (FStarC_Const.Const_bool (true))) -> + (true, (FStar_Pervasives_Native.Some e2), + (FStar_Pervasives_Native.Some e1)) + | uu___3 -> def))) +let (instantiate_tyscheme : + FStarC_Extraction_ML_Syntax.mltyscheme -> + FStarC_Extraction_ML_Syntax.mlty Prims.list -> + FStarC_Extraction_ML_Syntax.mlty) + = fun s -> fun args -> FStarC_Extraction_ML_Util.subst s args +let (fresh_mlidents : + FStarC_Extraction_ML_Syntax.mlty Prims.list -> + FStarC_Extraction_ML_UEnv.uenv -> + ((FStarC_Extraction_ML_Syntax.mlident * + FStarC_Extraction_ML_Syntax.mlty) Prims.list * + FStarC_Extraction_ML_UEnv.uenv)) + = + fun ts -> + fun g -> + let uu___ = + FStarC_Compiler_List.fold_right + (fun t -> + fun uu___1 -> + match uu___1 with + | (uenv, vs) -> + let uu___2 = FStarC_Extraction_ML_UEnv.new_mlident uenv in + (match uu___2 with | (uenv1, v) -> (uenv1, ((v, t) :: vs)))) + ts (g, []) in + match uu___ with | (g1, vs_ts) -> (vs_ts, g1) +let (fresh_binders : + FStarC_Extraction_ML_Syntax.mlty Prims.list -> + FStarC_Extraction_ML_UEnv.uenv -> + (FStarC_Extraction_ML_Syntax.mlbinder Prims.list * + FStarC_Extraction_ML_UEnv.uenv)) + = + fun ts -> + fun g -> + let uu___ = fresh_mlidents ts g in + match uu___ with + | (vs_ts, g1) -> + let uu___1 = + FStarC_Compiler_List.map + (fun uu___2 -> + match uu___2 with + | (v, t) -> + { + FStarC_Extraction_ML_Syntax.mlbinder_name = v; + FStarC_Extraction_ML_Syntax.mlbinder_ty = t; + FStarC_Extraction_ML_Syntax.mlbinder_attrs = [] + }) vs_ts in + (uu___1, g1) +let (instantiate_maybe_partial : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Extraction_ML_Syntax.mlexpr -> + FStarC_Extraction_ML_Syntax.e_tag -> + FStarC_Extraction_ML_Syntax.mltyscheme -> + FStarC_Extraction_ML_Syntax.mlty Prims.list -> + (FStarC_Extraction_ML_Syntax.mlexpr * + FStarC_Extraction_ML_Syntax.e_tag * + FStarC_Extraction_ML_Syntax.mlty)) + = + fun g -> + fun e -> + fun eff -> + fun s -> + fun tyargs -> + let uu___ = s in + match uu___ with + | (vars, t) -> + let n_vars = FStarC_Compiler_List.length vars in + let n_args = FStarC_Compiler_List.length tyargs in + if n_args = n_vars + then + (if n_args = Prims.int_zero + then (e, eff, t) + else + (let ts = instantiate_tyscheme (vars, t) tyargs in + let tapp = + { + FStarC_Extraction_ML_Syntax.expr = + (FStarC_Extraction_ML_Syntax.MLE_TApp (e, tyargs)); + FStarC_Extraction_ML_Syntax.mlty = ts; + FStarC_Extraction_ML_Syntax.loc = + (e.FStarC_Extraction_ML_Syntax.loc) + } in + (tapp, eff, ts))) + else + if n_args < n_vars + then + (let extra_tyargs = + let uu___2 = FStarC_Compiler_Util.first_N n_args vars in + match uu___2 with + | (uu___3, rest_vars) -> + FStarC_Compiler_List.map + (fun uu___4 -> + FStarC_Extraction_ML_Syntax.MLTY_Erased) + rest_vars in + let tyargs1 = + FStarC_Compiler_List.op_At tyargs extra_tyargs in + let ts = instantiate_tyscheme (vars, t) tyargs1 in + let tapp = + { + FStarC_Extraction_ML_Syntax.expr = + (FStarC_Extraction_ML_Syntax.MLE_TApp (e, tyargs1)); + FStarC_Extraction_ML_Syntax.mlty = ts; + FStarC_Extraction_ML_Syntax.loc = + (e.FStarC_Extraction_ML_Syntax.loc) + } in + let t1 = + FStarC_Compiler_List.fold_left + (fun out -> + fun t2 -> + FStarC_Extraction_ML_Syntax.MLTY_Fun + (t2, FStarC_Extraction_ML_Syntax.E_PURE, out)) + ts extra_tyargs in + let uu___2 = fresh_binders extra_tyargs g in + match uu___2 with + | (vs_ts, g1) -> + let f = + FStarC_Extraction_ML_Syntax.with_ty t1 + (FStarC_Extraction_ML_Syntax.MLE_Fun + (vs_ts, tapp)) in + (f, eff, t1)) + else + failwith + "Impossible: instantiate_maybe_partial called with too many arguments" +let (eta_expand : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Extraction_ML_Syntax.mlty -> + FStarC_Extraction_ML_Syntax.mlexpr -> + FStarC_Extraction_ML_Syntax.mlexpr) + = + fun g -> + fun t -> + fun e -> + let uu___ = FStarC_Extraction_ML_Util.doms_and_cod t in + match uu___ with + | (ts, r) -> + if ts = [] + then e + else + (let uu___2 = fresh_binders ts g in + match uu___2 with + | (vs_ts, g1) -> + let vs_es = + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with + | { FStarC_Extraction_ML_Syntax.mlbinder_name = v; + FStarC_Extraction_ML_Syntax.mlbinder_ty = t1; + FStarC_Extraction_ML_Syntax.mlbinder_attrs = + uu___4;_} + -> + FStarC_Extraction_ML_Syntax.with_ty t1 + (FStarC_Extraction_ML_Syntax.MLE_Var v)) + vs_ts in + let body = + FStarC_Extraction_ML_Syntax.with_ty r + (FStarC_Extraction_ML_Syntax.MLE_App (e, vs_es)) in + FStarC_Extraction_ML_Syntax.with_ty t + (FStarC_Extraction_ML_Syntax.MLE_Fun (vs_ts, body))) +let (default_value_for_ty : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Extraction_ML_Syntax.mlty -> FStarC_Extraction_ML_Syntax.mlexpr) + = + fun g -> + fun t -> + let uu___ = FStarC_Extraction_ML_Util.doms_and_cod t in + match uu___ with + | (ts, r) -> + let body r1 = + let r2 = + let uu___1 = FStarC_Extraction_ML_Util.udelta_unfold g r1 in + match uu___1 with + | FStar_Pervasives_Native.None -> r1 + | FStar_Pervasives_Native.Some r3 -> r3 in + match r2 with + | FStarC_Extraction_ML_Syntax.MLTY_Erased -> + FStarC_Extraction_ML_Syntax.ml_unit + | FStarC_Extraction_ML_Syntax.MLTY_Top -> + FStarC_Extraction_ML_Syntax.apply_obj_repr + FStarC_Extraction_ML_Syntax.ml_unit + FStarC_Extraction_ML_Syntax.MLTY_Erased + | uu___1 -> + FStarC_Extraction_ML_Syntax.with_ty r2 + (FStarC_Extraction_ML_Syntax.MLE_Coerce + (FStarC_Extraction_ML_Syntax.ml_unit, + FStarC_Extraction_ML_Syntax.MLTY_Erased, r2)) in + if ts = [] + then body r + else + (let uu___2 = fresh_binders ts g in + match uu___2 with + | (vs_ts, g1) -> + let uu___3 = + let uu___4 = let uu___5 = body r in (vs_ts, uu___5) in + FStarC_Extraction_ML_Syntax.MLE_Fun uu___4 in + FStarC_Extraction_ML_Syntax.with_ty t uu___3) +let (maybe_eta_expand_coercion : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Extraction_ML_Syntax.mlty -> + FStarC_Extraction_ML_Syntax.mlexpr -> + FStarC_Extraction_ML_Syntax.mlexpr) + = + fun g -> + fun expect -> + fun e -> + let uu___ = + let uu___1 = FStarC_Options.codegen () in + uu___1 = (FStar_Pervasives_Native.Some FStarC_Options.Krml) in + if uu___ then e else eta_expand g expect e +let (apply_coercion : + FStarC_Compiler_Range_Type.range -> + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Extraction_ML_Syntax.mlexpr -> + FStarC_Extraction_ML_Syntax.mlty -> + FStarC_Extraction_ML_Syntax.mlty -> + FStarC_Extraction_ML_Syntax.mlexpr) + = + fun pos -> + fun g -> + fun e -> + fun ty -> + fun expect -> + (let uu___1 = FStarC_Extraction_ML_Util.codegen_fsharp () in + if uu___1 + then + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Extraction_ML_UEnv.current_module_of_uenv g in + FStarC_Extraction_ML_Code.string_of_mlty uu___4 ty in + let uu___4 = + let uu___5 = + FStarC_Extraction_ML_UEnv.current_module_of_uenv g in + FStarC_Extraction_ML_Code.string_of_mlty uu___5 expect in + FStarC_Compiler_Util.format2 + "Inserted an unsafe type coercion in generated code from %s to %s; this may be unsound in F#" + uu___3 uu___4 in + FStarC_Errors.log_issue FStarC_Class_HasRange.hasRange_range + pos FStarC_Errors_Codes.Warning_NoMagicInFSharp () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2) + else ()); + (let mk_fun binder body = + match body.FStarC_Extraction_ML_Syntax.expr with + | FStarC_Extraction_ML_Syntax.MLE_Fun (binders, body1) -> + FStarC_Extraction_ML_Syntax.MLE_Fun + ((binder :: binders), body1) + | uu___1 -> + FStarC_Extraction_ML_Syntax.MLE_Fun ([binder], body) in + let rec aux e1 ty1 expect1 = + let coerce_branch uu___1 = + match uu___1 with + | (pat, w, b) -> + let uu___2 = aux b ty1 expect1 in (pat, w, uu___2) in + let rec undelta mlty = + let uu___1 = FStarC_Extraction_ML_Util.udelta_unfold g mlty in + match uu___1 with + | FStar_Pervasives_Native.Some t -> undelta t + | FStar_Pervasives_Native.None -> mlty in + let uu___1 = + let uu___2 = undelta expect1 in + ((e1.FStarC_Extraction_ML_Syntax.expr), ty1, uu___2) in + match uu___1 with + | (FStarC_Extraction_ML_Syntax.MLE_Fun (arg::rest, body), + FStarC_Extraction_ML_Syntax.MLTY_Fun (t0, uu___2, t1), + FStarC_Extraction_ML_Syntax.MLTY_Fun (s0, uu___3, s1)) -> + let body1 = + match rest with + | [] -> body + | uu___4 -> + FStarC_Extraction_ML_Syntax.with_ty t1 + (FStarC_Extraction_ML_Syntax.MLE_Fun (rest, body)) in + let body2 = aux body1 t1 s1 in + let uu___4 = type_leq g s0 t0 in + if uu___4 + then + FStarC_Extraction_ML_Syntax.with_ty expect1 + (mk_fun arg body2) + else + (let lb = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Extraction_ML_Syntax.with_ty s0 + (FStarC_Extraction_ML_Syntax.MLE_Var + (arg.FStarC_Extraction_ML_Syntax.mlbinder_name)) in + (uu___9, s0, t0) in + FStarC_Extraction_ML_Syntax.MLE_Coerce uu___8 in + FStarC_Extraction_ML_Syntax.with_ty t0 uu___7 in + { + FStarC_Extraction_ML_Syntax.mllb_name = + (arg.FStarC_Extraction_ML_Syntax.mlbinder_name); + FStarC_Extraction_ML_Syntax.mllb_tysc = + (FStar_Pervasives_Native.Some ([], t0)); + FStarC_Extraction_ML_Syntax.mllb_add_unit = false; + FStarC_Extraction_ML_Syntax.mllb_def = uu___6; + FStarC_Extraction_ML_Syntax.mllb_attrs = []; + FStarC_Extraction_ML_Syntax.mllb_meta = []; + FStarC_Extraction_ML_Syntax.print_typ = false + } in + let body3 = + FStarC_Extraction_ML_Syntax.with_ty s1 + (FStarC_Extraction_ML_Syntax.MLE_Let + ((FStarC_Extraction_ML_Syntax.NonRec, [lb]), + body2)) in + FStarC_Extraction_ML_Syntax.with_ty expect1 + (mk_fun + { + FStarC_Extraction_ML_Syntax.mlbinder_name = + (arg.FStarC_Extraction_ML_Syntax.mlbinder_name); + FStarC_Extraction_ML_Syntax.mlbinder_ty = s0; + FStarC_Extraction_ML_Syntax.mlbinder_attrs = [] + } body3)) + | (FStarC_Extraction_ML_Syntax.MLE_Let (lbs, body), uu___2, + uu___3) -> + let uu___4 = + let uu___5 = + let uu___6 = aux body ty1 expect1 in (lbs, uu___6) in + FStarC_Extraction_ML_Syntax.MLE_Let uu___5 in + FStarC_Extraction_ML_Syntax.with_ty expect1 uu___4 + | (FStarC_Extraction_ML_Syntax.MLE_Match (s, branches), + uu___2, uu___3) -> + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Compiler_List.map coerce_branch branches in + (s, uu___6) in + FStarC_Extraction_ML_Syntax.MLE_Match uu___5 in + FStarC_Extraction_ML_Syntax.with_ty expect1 uu___4 + | (FStarC_Extraction_ML_Syntax.MLE_If (s, b1, b2_opt), uu___2, + uu___3) -> + let uu___4 = + let uu___5 = + let uu___6 = aux b1 ty1 expect1 in + let uu___7 = + FStarC_Compiler_Util.map_opt b2_opt + (fun b2 -> aux b2 ty1 expect1) in + (s, uu___6, uu___7) in + FStarC_Extraction_ML_Syntax.MLE_If uu___5 in + FStarC_Extraction_ML_Syntax.with_ty expect1 uu___4 + | (FStarC_Extraction_ML_Syntax.MLE_Seq es, uu___2, uu___3) -> + let uu___4 = FStarC_Compiler_Util.prefix es in + (match uu___4 with + | (prefix, last) -> + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = aux last ty1 expect1 in [uu___8] in + FStarC_Compiler_List.op_At prefix uu___7 in + FStarC_Extraction_ML_Syntax.MLE_Seq uu___6 in + FStarC_Extraction_ML_Syntax.with_ty expect1 uu___5) + | (FStarC_Extraction_ML_Syntax.MLE_Try (s, branches), uu___2, + uu___3) -> + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Compiler_List.map coerce_branch branches in + (s, uu___6) in + FStarC_Extraction_ML_Syntax.MLE_Try uu___5 in + FStarC_Extraction_ML_Syntax.with_ty expect1 uu___4 + | uu___2 -> + FStarC_Extraction_ML_Syntax.with_ty expect1 + (FStarC_Extraction_ML_Syntax.MLE_Coerce + (e1, ty1, expect1)) in + aux e ty expect) +let (maybe_coerce : + FStarC_Compiler_Range_Type.range -> + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Extraction_ML_Syntax.mlexpr -> + FStarC_Extraction_ML_Syntax.mlty -> + FStarC_Extraction_ML_Syntax.mlty -> + FStarC_Extraction_ML_Syntax.mlexpr) + = + fun pos -> + fun g -> + fun e -> + fun ty -> + fun expect -> + let ty1 = eraseTypeDeep g ty in + let uu___ = + type_leq_c g (FStar_Pervasives_Native.Some e) ty1 expect in + match uu___ with + | (true, FStar_Pervasives_Native.Some e') -> e' + | uu___1 -> + (match ty1 with + | FStarC_Extraction_ML_Syntax.MLTY_Erased -> + default_value_for_ty g expect + | uu___2 -> + let uu___3 = + let uu___4 = + FStarC_Extraction_ML_Util.erase_effect_annotations + ty1 in + let uu___5 = + FStarC_Extraction_ML_Util.erase_effect_annotations + expect in + type_leq g uu___4 uu___5 in + if uu___3 + then + (FStarC_Extraction_ML_UEnv.debug g + (fun uu___5 -> + let uu___6 = + let uu___7 = + FStarC_Extraction_ML_UEnv.current_module_of_uenv + g in + FStarC_Extraction_ML_Code.string_of_mlexpr + uu___7 e in + let uu___7 = + let uu___8 = + FStarC_Extraction_ML_UEnv.current_module_of_uenv + g in + FStarC_Extraction_ML_Code.string_of_mlty + uu___8 ty1 in + FStarC_Compiler_Util.print2 + "\n Effect mismatch on type of %s : %s\n" + uu___6 uu___7); + e) + else + (FStarC_Extraction_ML_UEnv.debug g + (fun uu___6 -> + let uu___7 = + let uu___8 = + FStarC_Extraction_ML_UEnv.current_module_of_uenv + g in + FStarC_Extraction_ML_Code.string_of_mlexpr + uu___8 e in + let uu___8 = + let uu___9 = + FStarC_Extraction_ML_UEnv.current_module_of_uenv + g in + FStarC_Extraction_ML_Code.string_of_mlty + uu___9 ty1 in + let uu___9 = + let uu___10 = + FStarC_Extraction_ML_UEnv.current_module_of_uenv + g in + FStarC_Extraction_ML_Code.string_of_mlty + uu___10 expect in + FStarC_Compiler_Util.print3 + "\n (*needed to coerce expression \n %s \n of type \n %s \n to type \n %s *) \n" + uu___7 uu___8 uu___9); + (let uu___6 = apply_coercion pos g e ty1 expect in + maybe_eta_expand_coercion g expect uu___6))) +let (bv_as_mlty : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.bv -> FStarC_Extraction_ML_Syntax.mlty) + = + fun g -> + fun bv -> + let uu___ = FStarC_Extraction_ML_UEnv.lookup_bv g bv in + match uu___ with + | FStar_Pervasives.Inl ty_b -> ty_b.FStarC_Extraction_ML_UEnv.ty_b_ty + | uu___1 -> FStarC_Extraction_ML_Syntax.MLTY_Top +let (extraction_norm_steps : FStarC_TypeChecker_Env.step Prims.list) = + let extraction_norm_steps_core = + [FStarC_TypeChecker_Env.AllowUnboundUniverses; + FStarC_TypeChecker_Env.EraseUniverses; + FStarC_TypeChecker_Env.Inlining; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.Exclude FStarC_TypeChecker_Env.Zeta; + FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.Unascribe; + FStarC_TypeChecker_Env.ForExtraction] in + let extraction_norm_steps_nbe = FStarC_TypeChecker_Env.NBE :: + extraction_norm_steps_core in + let uu___ = FStarC_Options.use_nbe_for_extraction () in + if uu___ then extraction_norm_steps_nbe else extraction_norm_steps_core +let (normalize_for_extraction : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun env -> + fun e -> + let uu___ = FStarC_Extraction_ML_UEnv.tcenv_of_uenv env in + FStarC_TypeChecker_Normalize.normalize extraction_norm_steps uu___ e +let maybe_reify_comp : + 'uuuuu . + 'uuuuu -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.comp -> FStarC_Syntax_Syntax.term + = + fun g -> + fun env -> + fun c -> + let uu___ = + FStarC_TypeChecker_Util.effect_extraction_mode env + (FStarC_Syntax_Util.comp_effect_name c) in + match uu___ with + | FStarC_Syntax_Syntax.Extract_reify -> + let uu___1 = + FStarC_TypeChecker_Env.reify_comp env c + FStarC_Syntax_Syntax.U_unknown in + FStarC_TypeChecker_Normalize.normalize extraction_norm_steps env + uu___1 + | FStarC_Syntax_Syntax.Extract_primitive -> + FStarC_Syntax_Util.comp_result c + | FStarC_Syntax_Syntax.Extract_none s -> + let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_comp c in + err_cannot_extract_effect (FStarC_Syntax_Util.comp_effect_name c) + c.FStarC_Syntax_Syntax.pos s uu___1 +let (maybe_reify_term : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Ident.lident -> FStarC_Syntax_Syntax.term) + = + fun env -> + fun t -> + fun l -> + let uu___ = FStarC_TypeChecker_Util.effect_extraction_mode env l in + match uu___ with + | FStarC_Syntax_Syntax.Extract_reify -> + let uu___1 = + FStarC_Syntax_Util.mk_reify t (FStar_Pervasives_Native.Some l) in + FStarC_TypeChecker_Util.norm_reify env + [FStarC_TypeChecker_Env.Inlining; + FStarC_TypeChecker_Env.ForExtraction; + FStarC_TypeChecker_Env.Unascribe] uu___1 + | FStarC_Syntax_Syntax.Extract_primitive -> t + | FStarC_Syntax_Syntax.Extract_none s -> + let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + err_cannot_extract_effect l t.FStarC_Syntax_Syntax.pos s uu___1 +let (has_extract_as_impure_effect : + FStarC_Extraction_ML_UEnv.uenv -> FStarC_Syntax_Syntax.fv -> Prims.bool) = + fun g -> + fun fv -> + let uu___ = FStarC_Extraction_ML_UEnv.tcenv_of_uenv g in + FStarC_TypeChecker_Env.fv_has_attr uu___ fv + FStarC_Parser_Const.extract_as_impure_effect_lid +let (head_of_type_is_extract_as_impure_effect : + FStarC_Extraction_ML_UEnv.uenv -> FStarC_Syntax_Syntax.term -> Prims.bool) + = + fun g -> + fun t -> + let uu___ = FStarC_Syntax_Util.head_and_args t in + match uu___ with + | (hd, uu___1) -> + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst hd in + uu___3.FStarC_Syntax_Syntax.n in + (match uu___2 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + has_extract_as_impure_effect g fv + | uu___3 -> false) +let rec (translate_term_to_mlty : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.term -> FStarC_Extraction_ML_Syntax.mlty) + = + fun g -> + fun t0 -> + let arg_as_mlty g1 uu___ = + match uu___ with + | (a, uu___1) -> + let uu___2 = is_type g1 a in + if uu___2 + then translate_term_to_mlty g1 a + else FStarC_Extraction_ML_Syntax.MLTY_Erased in + let fv_app_as_mlty g1 fv args = + let uu___ = + let uu___1 = FStarC_Extraction_ML_UEnv.is_fv_type g1 fv in + Prims.op_Negation uu___1 in + if uu___ + then FStarC_Extraction_ML_Syntax.MLTY_Top + else + (let uu___2 = has_extract_as_impure_effect g1 fv in + if uu___2 + then + let uu___3 = args in + match uu___3 with + | (a, uu___4)::uu___5 -> translate_term_to_mlty g1 a + else + (let uu___4 = + let uu___5 = + let uu___6 = FStarC_Extraction_ML_UEnv.tcenv_of_uenv g1 in + FStarC_TypeChecker_Env.lookup_lid uu___6 + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + match uu___5 with + | ((uu___6, fvty), uu___7) -> + let fvty1 = + let uu___8 = FStarC_Extraction_ML_UEnv.tcenv_of_uenv g1 in + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.ForExtraction] uu___8 fvty in + FStarC_Syntax_Util.arrow_formals fvty1 in + match uu___4 with + | (formals, uu___5) -> + let mlargs = FStarC_Compiler_List.map (arg_as_mlty g1) args in + let mlargs1 = + let n_args = FStarC_Compiler_List.length args in + if (FStarC_Compiler_List.length formals) > n_args + then + let uu___6 = + FStarC_Compiler_Util.first_N n_args formals in + match uu___6 with + | (uu___7, rest) -> + let uu___8 = + FStarC_Compiler_List.map + (fun uu___9 -> + FStarC_Extraction_ML_Syntax.MLTY_Erased) + rest in + FStarC_Compiler_List.op_At mlargs uu___8 + else mlargs in + let nm = + FStarC_Extraction_ML_UEnv.mlpath_of_lident g1 + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + FStarC_Extraction_ML_Syntax.MLTY_Named (mlargs1, nm))) in + let aux env t = + let t1 = FStarC_Syntax_Subst.compress t in + match t1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_type uu___ -> + FStarC_Extraction_ML_Syntax.MLTY_Erased + | FStarC_Syntax_Syntax.Tm_bvar uu___ -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.format1 "Impossible: Unexpected term %s" + uu___2 in + failwith uu___1 + | FStarC_Syntax_Syntax.Tm_delayed uu___ -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.format1 "Impossible: Unexpected term %s" + uu___2 in + failwith uu___1 + | FStarC_Syntax_Syntax.Tm_unknown -> + let uu___ = + let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.format1 "Impossible: Unexpected term %s" + uu___1 in + failwith uu___ + | FStarC_Syntax_Syntax.Tm_lazy i -> + let uu___ = FStarC_Syntax_Util.unfold_lazy i in + translate_term_to_mlty env uu___ + | FStarC_Syntax_Syntax.Tm_constant uu___ -> + FStarC_Extraction_ML_Syntax.MLTY_Top + | FStarC_Syntax_Syntax.Tm_quoted uu___ -> + FStarC_Extraction_ML_Syntax.MLTY_Top + | FStarC_Syntax_Syntax.Tm_uvar uu___ -> + FStarC_Extraction_ML_Syntax.MLTY_Top + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t2; + FStarC_Syntax_Syntax.meta = uu___;_} + -> translate_term_to_mlty env t2 + | FStarC_Syntax_Syntax.Tm_refine + { + FStarC_Syntax_Syntax.b = + { FStarC_Syntax_Syntax.ppname = uu___; + FStarC_Syntax_Syntax.index = uu___1; + FStarC_Syntax_Syntax.sort = t2;_}; + FStarC_Syntax_Syntax.phi = uu___2;_} + -> translate_term_to_mlty env t2 + | FStarC_Syntax_Syntax.Tm_uinst (t2, uu___) -> + translate_term_to_mlty env t2 + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t2; FStarC_Syntax_Syntax.asc = uu___; + FStarC_Syntax_Syntax.eff_opt = uu___1;_} + -> translate_term_to_mlty env t2 + | FStarC_Syntax_Syntax.Tm_name bv -> bv_as_mlty env bv + | FStarC_Syntax_Syntax.Tm_fvar fv -> fv_app_as_mlty env fv [] + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; FStarC_Syntax_Syntax.comp = c;_} + -> + let uu___ = FStarC_Syntax_Subst.open_comp bs c in + (match uu___ with + | (bs1, c1) -> + let uu___1 = binders_as_ml_binders env bs1 in + (match uu___1 with + | (mlbs, env1) -> + let codom = + let uu___2 = + FStarC_Extraction_ML_UEnv.tcenv_of_uenv env1 in + maybe_reify_comp env1 uu___2 c1 in + let t_ret = translate_term_to_mlty env1 codom in + let etag = + effect_as_etag env1 + (FStarC_Syntax_Util.comp_effect_name c1) in + let etag1 = + if etag = FStarC_Extraction_ML_Syntax.E_IMPURE + then etag + else + (let uu___3 = + head_of_type_is_extract_as_impure_effect env1 + codom in + if uu___3 + then FStarC_Extraction_ML_Syntax.E_IMPURE + else etag) in + let uu___2 = + FStarC_Compiler_List.fold_right + (fun uu___3 -> + fun uu___4 -> + match (uu___3, uu___4) with + | ((uu___5, t2), (tag, t')) -> + (FStarC_Extraction_ML_Syntax.E_PURE, + (FStarC_Extraction_ML_Syntax.MLTY_Fun + (t2, tag, t')))) mlbs (etag1, t_ret) in + (match uu___2 with | (uu___3, t2) -> t2))) + | FStarC_Syntax_Syntax.Tm_app uu___ -> + let uu___1 = FStarC_Syntax_Util.head_and_args_full t1 in + (match uu___1 with + | (head, args) -> + let res = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Util.un_uinst head in + uu___4.FStarC_Syntax_Syntax.n in + (uu___3, args) in + match uu___2 with + | (FStarC_Syntax_Syntax.Tm_name bv, uu___3) -> + bv_as_mlty env bv + | (FStarC_Syntax_Syntax.Tm_fvar fv, uu___3::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.steel_memory_inv_lid + -> + translate_term_to_mlty env FStarC_Syntax_Syntax.t_unit + | (FStarC_Syntax_Syntax.Tm_fvar fv, uu___3) -> + fv_app_as_mlty env fv args + | uu___3 -> FStarC_Extraction_ML_Syntax.MLTY_Top in + res) + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs; FStarC_Syntax_Syntax.body = ty; + FStarC_Syntax_Syntax.rc_opt = uu___;_} + -> + let uu___1 = FStarC_Syntax_Subst.open_term bs ty in + (match uu___1 with + | (bs1, ty1) -> + let uu___2 = binders_as_ml_binders env bs1 in + (match uu___2 with + | (bts, env1) -> translate_term_to_mlty env1 ty1)) + | FStarC_Syntax_Syntax.Tm_let uu___ -> + FStarC_Extraction_ML_Syntax.MLTY_Top + | FStarC_Syntax_Syntax.Tm_match uu___ -> + FStarC_Extraction_ML_Syntax.MLTY_Top in + let rec is_top_ty t = + match t with + | FStarC_Extraction_ML_Syntax.MLTY_Top -> true + | FStarC_Extraction_ML_Syntax.MLTY_Named uu___ -> + let uu___1 = FStarC_Extraction_ML_Util.udelta_unfold g t in + (match uu___1 with + | FStar_Pervasives_Native.None -> false + | FStar_Pervasives_Native.Some t1 -> is_top_ty t1) + | uu___ -> false in + let uu___ = + let uu___1 = FStarC_Extraction_ML_UEnv.tcenv_of_uenv g in + FStarC_TypeChecker_Util.must_erase_for_extraction uu___1 t0 in + if uu___ + then FStarC_Extraction_ML_Syntax.MLTY_Erased + else + (let mlt = aux g t0 in + let uu___2 = is_top_ty mlt in + if uu___2 then FStarC_Extraction_ML_Syntax.MLTY_Top else mlt) +and (binders_as_ml_binders : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.binders -> + ((FStarC_Extraction_ML_Syntax.mlident * + FStarC_Extraction_ML_Syntax.mlty) Prims.list * + FStarC_Extraction_ML_UEnv.uenv)) + = + fun g -> + fun bs -> + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun b -> + match uu___1 with + | (ml_bs, env) -> + let uu___2 = is_type_binder g b in + if uu___2 + then + let b1 = b.FStarC_Syntax_Syntax.binder_bv in + let env1 = + FStarC_Extraction_ML_UEnv.extend_ty env b1 true in + let ml_b = + let uu___3 = + FStarC_Extraction_ML_UEnv.lookup_ty env1 b1 in + uu___3.FStarC_Extraction_ML_UEnv.ty_b_name in + let ml_b1 = + (ml_b, FStarC_Extraction_ML_Syntax.ml_unit_ty) in + ((ml_b1 :: ml_bs), env1) + else + (let b1 = b.FStarC_Syntax_Syntax.binder_bv in + let t = + translate_term_to_mlty env + b1.FStarC_Syntax_Syntax.sort in + let uu___4 = + FStarC_Extraction_ML_UEnv.extend_bv env b1 ([], t) + false false in + match uu___4 with + | (env1, b2, uu___5) -> + let ml_b = (b2, t) in ((ml_b :: ml_bs), env1))) + ([], g) bs in + match uu___ with + | (ml_bs, env) -> ((FStarC_Compiler_List.rev ml_bs), env) +let (term_as_mlty : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.term -> FStarC_Extraction_ML_Syntax.mlty) + = + fun g -> + fun t0 -> + let t = + let uu___ = FStarC_Extraction_ML_UEnv.tcenv_of_uenv g in + FStarC_TypeChecker_Normalize.normalize extraction_norm_steps uu___ t0 in + translate_term_to_mlty g t +let (mk_MLE_Seq : + FStarC_Extraction_ML_Syntax.mlexpr -> + FStarC_Extraction_ML_Syntax.mlexpr -> FStarC_Extraction_ML_Syntax.mlexpr') + = + fun e1 -> + fun e2 -> + match ((e1.FStarC_Extraction_ML_Syntax.expr), + (e2.FStarC_Extraction_ML_Syntax.expr)) + with + | (FStarC_Extraction_ML_Syntax.MLE_Seq es1, + FStarC_Extraction_ML_Syntax.MLE_Seq es2) -> + FStarC_Extraction_ML_Syntax.MLE_Seq + (FStarC_Compiler_List.op_At es1 es2) + | (FStarC_Extraction_ML_Syntax.MLE_Seq es1, uu___) -> + FStarC_Extraction_ML_Syntax.MLE_Seq + (FStarC_Compiler_List.op_At es1 [e2]) + | (uu___, FStarC_Extraction_ML_Syntax.MLE_Seq es2) -> + FStarC_Extraction_ML_Syntax.MLE_Seq (e1 :: es2) + | uu___ -> FStarC_Extraction_ML_Syntax.MLE_Seq [e1; e2] +let (mk_MLE_Let : + Prims.bool -> + FStarC_Extraction_ML_Syntax.mlletbinding -> + FStarC_Extraction_ML_Syntax.mlexpr -> + FStarC_Extraction_ML_Syntax.mlexpr') + = + fun top_level -> + fun lbs -> + fun body -> + match lbs with + | (FStarC_Extraction_ML_Syntax.NonRec, lb::[]) when + Prims.op_Negation top_level -> + (match lb.FStarC_Extraction_ML_Syntax.mllb_tysc with + | FStar_Pervasives_Native.Some ([], t) when + t = FStarC_Extraction_ML_Syntax.ml_unit_ty -> + if + body.FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.ml_unit.FStarC_Extraction_ML_Syntax.expr + then + (lb.FStarC_Extraction_ML_Syntax.mllb_def).FStarC_Extraction_ML_Syntax.expr + else + (match body.FStarC_Extraction_ML_Syntax.expr with + | FStarC_Extraction_ML_Syntax.MLE_Var x when + x = lb.FStarC_Extraction_ML_Syntax.mllb_name -> + (lb.FStarC_Extraction_ML_Syntax.mllb_def).FStarC_Extraction_ML_Syntax.expr + | uu___1 when + (lb.FStarC_Extraction_ML_Syntax.mllb_def).FStarC_Extraction_ML_Syntax.expr + = + FStarC_Extraction_ML_Syntax.ml_unit.FStarC_Extraction_ML_Syntax.expr + -> body.FStarC_Extraction_ML_Syntax.expr + | uu___1 -> + mk_MLE_Seq lb.FStarC_Extraction_ML_Syntax.mllb_def + body) + | uu___ -> FStarC_Extraction_ML_Syntax.MLE_Let (lbs, body)) + | uu___ -> FStarC_Extraction_ML_Syntax.MLE_Let (lbs, body) +let record_fields : + 'a . + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Ident.lident -> + FStarC_Ident.ident Prims.list -> + 'a Prims.list -> + (FStarC_Extraction_ML_Syntax.mlsymbol * 'a) Prims.list + = + fun g -> + fun ty -> + fun fns -> + fun xs -> + let fns1 = + FStarC_Compiler_List.map + (fun x -> + FStarC_Extraction_ML_UEnv.lookup_record_field_name g (ty, x)) + fns in + FStarC_Compiler_List.map2 + (fun uu___ -> fun x -> match uu___ with | (p, s) -> (s, x)) fns1 + xs +let (resugar_pat : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.fv_qual FStar_Pervasives_Native.option -> + FStarC_Extraction_ML_Syntax.mlpattern -> + FStarC_Extraction_ML_Syntax.mlpattern) + = + fun g -> + fun q -> + fun p -> + match p with + | FStarC_Extraction_ML_Syntax.MLP_CTor (d, pats) -> + let uu___ = FStarC_Extraction_ML_Util.is_xtuple d in + (match uu___ with + | FStar_Pervasives_Native.Some n -> + FStarC_Extraction_ML_Syntax.MLP_Tuple pats + | uu___1 -> + (match q with + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Record_ctor (ty, fns)) -> + let path = + let uu___2 = FStarC_Ident.ns_of_lid ty in + FStarC_Compiler_List.map FStarC_Ident.string_of_id + uu___2 in + let fs = record_fields g ty fns pats in + let path1 = + FStarC_Extraction_ML_UEnv.no_fstar_stubs_ns path in + FStarC_Extraction_ML_Syntax.MLP_Record (path1, fs) + | uu___2 -> p)) + | uu___ -> p +let rec (extract_one_pat : + Prims.bool -> + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.pat -> + FStarC_Extraction_ML_Syntax.mlty -> + (FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.term -> + (FStarC_Extraction_ML_Syntax.mlexpr * + FStarC_Extraction_ML_Syntax.e_tag * + FStarC_Extraction_ML_Syntax.mlty)) + -> + (FStarC_Extraction_ML_UEnv.uenv * + (FStarC_Extraction_ML_Syntax.mlpattern * + FStarC_Extraction_ML_Syntax.mlexpr Prims.list) + FStar_Pervasives_Native.option * Prims.bool)) + = + fun imp -> + fun g -> + fun p -> + fun expected_ty -> + fun term_as_mlexpr -> + let ok t = + match expected_ty with + | FStarC_Extraction_ML_Syntax.MLTY_Top -> false + | uu___ -> + let ok1 = type_leq g t expected_ty in + (if Prims.op_Negation ok1 + then + FStarC_Extraction_ML_UEnv.debug g + (fun uu___2 -> + let uu___3 = + let uu___4 = + FStarC_Extraction_ML_UEnv.current_module_of_uenv + g in + FStarC_Extraction_ML_Code.string_of_mlty uu___4 + expected_ty in + let uu___4 = + let uu___5 = + FStarC_Extraction_ML_UEnv.current_module_of_uenv + g in + FStarC_Extraction_ML_Code.string_of_mlty uu___5 t in + FStarC_Compiler_Util.print2 + "Expected pattern type %s; got pattern type %s\n" + uu___3 uu___4) + else (); + ok1) in + match p.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_constant (FStarC_Const.Const_int + (c, swopt)) when + let uu___ = FStarC_Options.codegen () in + uu___ <> (FStar_Pervasives_Native.Some FStarC_Options.Krml) + -> + let uu___ = + match swopt with + | FStar_Pervasives_Native.None -> + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Extraction_ML_Util.mlconst_of_const + p.FStarC_Syntax_Syntax.p + (FStarC_Const.Const_int + (c, FStar_Pervasives_Native.None)) in + FStarC_Extraction_ML_Syntax.MLE_Const uu___3 in + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.ml_int_ty uu___2 in + (uu___1, FStarC_Extraction_ML_Syntax.ml_int_ty) + | FStar_Pervasives_Native.Some sw -> + let source_term = + let uu___1 = + let uu___2 = + FStarC_Extraction_ML_UEnv.tcenv_of_uenv g in + uu___2.FStarC_TypeChecker_Env.dsenv in + FStarC_ToSyntax_ToSyntax.desugar_machine_integer + uu___1 c sw FStarC_Compiler_Range_Type.dummyRange in + let uu___1 = term_as_mlexpr g source_term in + (match uu___1 with + | (mlterm, uu___2, mlty) -> (mlterm, mlty)) in + (match uu___ with + | (mlc, ml_ty) -> + let uu___1 = FStarC_Extraction_ML_UEnv.new_mlident g in + (match uu___1 with + | (g1, x) -> + let x_exp = + let x_exp1 = + FStarC_Extraction_ML_Syntax.with_ty expected_ty + (FStarC_Extraction_ML_Syntax.MLE_Var x) in + let coerce x1 = + FStarC_Extraction_ML_Syntax.with_ty ml_ty + (FStarC_Extraction_ML_Syntax.MLE_Coerce + (x1, ml_ty, expected_ty)) in + match expected_ty with + | FStarC_Extraction_ML_Syntax.MLTY_Top -> + coerce x_exp1 + | uu___2 -> + let uu___3 = ok ml_ty in + if uu___3 then x_exp1 else coerce x_exp1 in + let when_clause = + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.ml_bool_ty + (FStarC_Extraction_ML_Syntax.MLE_App + (FStarC_Extraction_ML_Util.prims_op_equality, + [x_exp; mlc])) in + let uu___2 = ok ml_ty in + (g1, + (FStar_Pervasives_Native.Some + ((FStarC_Extraction_ML_Syntax.MLP_Var x), + [when_clause])), uu___2))) + | FStarC_Syntax_Syntax.Pat_constant s -> + let t = + let uu___ = FStarC_Extraction_ML_UEnv.tcenv_of_uenv g in + FStarC_TypeChecker_TcTerm.tc_constant uu___ + FStarC_Compiler_Range_Type.dummyRange s in + let mlty = term_as_mlty g t in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Extraction_ML_Util.mlconst_of_const + p.FStarC_Syntax_Syntax.p s in + FStarC_Extraction_ML_Syntax.MLP_Const uu___3 in + (uu___2, []) in + FStar_Pervasives_Native.Some uu___1 in + let uu___1 = ok mlty in (g, uu___, uu___1) + | FStarC_Syntax_Syntax.Pat_var x -> + let uu___ = + FStarC_Extraction_ML_UEnv.extend_bv g x ([], expected_ty) + false imp in + (match uu___ with + | (g1, x1, uu___1) -> + (g1, + (if imp + then FStar_Pervasives_Native.None + else + FStar_Pervasives_Native.Some + ((FStarC_Extraction_ML_Syntax.MLP_Var x1), [])), + true)) + | FStarC_Syntax_Syntax.Pat_dot_term uu___ -> + (g, FStar_Pervasives_Native.None, true) + | FStarC_Syntax_Syntax.Pat_cons (f, uu___, pats) -> + let uu___1 = + let uu___2 = + FStarC_Extraction_ML_UEnv.try_lookup_fv + p.FStarC_Syntax_Syntax.p g f in + match uu___2 with + | FStar_Pervasives_Native.Some + { FStarC_Extraction_ML_UEnv.exp_b_name = uu___3; + FStarC_Extraction_ML_UEnv.exp_b_expr = + { + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name n; + FStarC_Extraction_ML_Syntax.mlty = uu___4; + FStarC_Extraction_ML_Syntax.loc = uu___5;_}; + FStarC_Extraction_ML_UEnv.exp_b_tscheme = ttys; + FStarC_Extraction_ML_UEnv.exp_b_eff = uu___6;_} + -> (n, ttys) + | FStar_Pervasives_Native.Some uu___3 -> + failwith "Expected a constructor" + | FStar_Pervasives_Native.None -> + let uu___3 = + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_fv f in + FStarC_Compiler_Util.format1 + "Cannot extract this pattern, the %s constructor was erased" + uu___4 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + (f.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.p + FStarC_Errors_Codes.Error_ErasedCtor () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___3) in + (match uu___1 with + | (d, tys) -> + let nTyVars = + FStarC_Compiler_List.length + (FStar_Pervasives_Native.fst tys) in + let uu___2 = FStarC_Compiler_Util.first_N nTyVars pats in + (match uu___2 with + | (tysVarPats, restPats) -> + let f_ty = + let mlty_args = + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with + | (p1, uu___4) -> + (match expected_ty with + | FStarC_Extraction_ML_Syntax.MLTY_Top + -> + FStarC_Extraction_ML_Syntax.MLTY_Top + | uu___5 -> + (match p1.FStarC_Syntax_Syntax.v + with + | FStarC_Syntax_Syntax.Pat_dot_term + (FStar_Pervasives_Native.Some + t) -> term_as_mlty g t + | uu___6 -> + FStarC_Extraction_ML_Syntax.MLTY_Top))) + tysVarPats in + let f_ty1 = + FStarC_Extraction_ML_Util.subst tys mlty_args in + FStarC_Extraction_ML_Util.uncurry_mlty_fun f_ty1 in + (FStarC_Extraction_ML_UEnv.debug g + (fun uu___4 -> + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_fv f in + let uu___6 = + let uu___7 = f_ty in + match uu___7 with + | (args, t) -> + let args1 = + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Extraction_ML_UEnv.current_module_of_uenv + g in + FStarC_Extraction_ML_Code.string_of_mlty + uu___10 in + FStarC_Compiler_List.map uu___9 + args in + FStarC_Compiler_String.concat " -> " + uu___8 in + let res = + let uu___8 = + FStarC_Extraction_ML_UEnv.current_module_of_uenv + g in + FStarC_Extraction_ML_Code.string_of_mlty + uu___8 t in + FStarC_Compiler_Util.format2 "%s -> %s" + args1 res in + FStarC_Compiler_Util.print2 + "@@@Expected type of pattern with head = %s is %s\n" + uu___5 uu___6); + (let uu___4 = + FStarC_Compiler_Util.fold_map + (fun g1 -> + fun uu___5 -> + match uu___5 with + | (p1, imp1) -> + let uu___6 = + extract_one_pat true g1 p1 + FStarC_Extraction_ML_Syntax.MLTY_Top + term_as_mlexpr in + (match uu___6 with + | (g2, p2, uu___7) -> (g2, p2))) g + tysVarPats in + match uu___4 with + | (g1, tyMLPats) -> + let uu___5 = + FStarC_Compiler_Util.fold_map + (fun uu___6 -> + fun uu___7 -> + match (uu___6, uu___7) with + | ((g2, f_ty1, ok1), (p1, imp1)) -> + let uu___8 = + match f_ty1 with + | (hd::rest, res) -> + ((rest, res), hd) + | uu___9 -> + (([], + FStarC_Extraction_ML_Syntax.MLTY_Top), + FStarC_Extraction_ML_Syntax.MLTY_Top) in + (match uu___8 with + | (f_ty2, expected_arg_ty) -> + let uu___9 = + extract_one_pat false g2 + p1 expected_arg_ty + term_as_mlexpr in + (match uu___9 with + | (g3, p2, ok') -> + ((g3, f_ty2, + (ok1 && ok')), p2)))) + (g1, f_ty, true) restPats in + (match uu___5 with + | ((g2, f_ty1, sub_pats_ok), restMLPats) -> + let uu___6 = + let uu___7 = + FStarC_Compiler_List.collect + (fun uu___8 -> + match uu___8 with + | FStar_Pervasives_Native.Some + x -> [x] + | uu___9 -> []) + (FStarC_Compiler_List.append + tyMLPats restMLPats) in + FStarC_Compiler_List.split uu___7 in + (match uu___6 with + | (mlPats, when_clauses) -> + let pat_ty_compat = + match f_ty1 with + | ([], t) -> ok t + | uu___7 -> false in + let uu___7 = + let uu___8 = + let uu___9 = + resugar_pat g2 + f.FStarC_Syntax_Syntax.fv_qual + (FStarC_Extraction_ML_Syntax.MLP_CTor + (d, mlPats)) in + (uu___9, + (FStarC_Compiler_List.flatten + when_clauses)) in + FStar_Pervasives_Native.Some + uu___8 in + (g2, uu___7, + (sub_pats_ok && pat_ty_compat)))))))) +let (extract_pat : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.pat -> + FStarC_Extraction_ML_Syntax.mlty -> + (FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.term -> + (FStarC_Extraction_ML_Syntax.mlexpr * + FStarC_Extraction_ML_Syntax.e_tag * + FStarC_Extraction_ML_Syntax.mlty)) + -> + (FStarC_Extraction_ML_UEnv.uenv * + (FStarC_Extraction_ML_Syntax.mlpattern * + FStarC_Extraction_ML_Syntax.mlexpr + FStar_Pervasives_Native.option) Prims.list * Prims.bool)) + = + fun g -> + fun p -> + fun expected_t -> + fun term_as_mlexpr -> + let extract_one_pat1 g1 p1 expected_t1 = + let uu___ = + extract_one_pat false g1 p1 expected_t1 term_as_mlexpr in + match uu___ with + | (g2, FStar_Pervasives_Native.Some (x, v), b) -> (g2, (x, v), b) + | uu___1 -> failwith "Impossible: Unable to translate pattern" in + let mk_when_clause whens = + match whens with + | [] -> FStar_Pervasives_Native.None + | hd::tl -> + let uu___ = + FStarC_Compiler_List.fold_left + FStarC_Extraction_ML_Util.conjoin hd tl in + FStar_Pervasives_Native.Some uu___ in + let uu___ = extract_one_pat1 g p expected_t in + match uu___ with + | (g1, (p1, whens), b) -> + let when_clause = mk_when_clause whens in + (g1, [(p1, when_clause)], b) +let (maybe_eta_data_and_project_record : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.fv_qual FStar_Pervasives_Native.option -> + FStarC_Extraction_ML_Syntax.mlty -> + FStarC_Extraction_ML_Syntax.mlexpr -> + FStarC_Extraction_ML_Syntax.mlexpr) + = + fun g -> + fun qual -> + fun residualType -> + fun mlAppExpr -> + let rec eta_args g1 more_args t = + match t with + | FStarC_Extraction_ML_Syntax.MLTY_Fun (t0, uu___, t1) -> + let uu___1 = FStarC_Extraction_ML_UEnv.new_mlident g1 in + (match uu___1 with + | (g2, x) -> + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Extraction_ML_Syntax.with_ty t0 + (FStarC_Extraction_ML_Syntax.MLE_Var x) in + ((x, t0), uu___4) in + uu___3 :: more_args in + eta_args g2 uu___2 t1) + | FStarC_Extraction_ML_Syntax.MLTY_Named (uu___, uu___1) -> + ((FStarC_Compiler_List.rev more_args), t) + | uu___ -> + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Extraction_ML_UEnv.current_module_of_uenv g1 in + FStarC_Extraction_ML_Code.string_of_mlexpr uu___3 + mlAppExpr in + let uu___3 = + let uu___4 = + FStarC_Extraction_ML_UEnv.current_module_of_uenv g1 in + FStarC_Extraction_ML_Code.string_of_mlty uu___4 t in + FStarC_Compiler_Util.format2 + "Impossible: Head type is not an arrow: (%s : %s)" uu___2 + uu___3 in + failwith uu___1 in + let as_record qual1 e = + match ((e.FStarC_Extraction_ML_Syntax.expr), qual1) with + | (FStarC_Extraction_ML_Syntax.MLE_CTor (uu___, args), + FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Record_ctor + (tyname, fields))) -> + let path = + let uu___1 = FStarC_Ident.ns_of_lid tyname in + FStarC_Compiler_List.map FStarC_Ident.string_of_id uu___1 in + let fields1 = record_fields g tyname fields args in + let path1 = FStarC_Extraction_ML_UEnv.no_fstar_stubs_ns path in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Ident.ident_of_lid tyname in + FStarC_Ident.string_of_id uu___4 in + (path1, uu___3, fields1) in + FStarC_Extraction_ML_Syntax.MLE_Record uu___2 in + FStarC_Extraction_ML_Syntax.with_ty + e.FStarC_Extraction_ML_Syntax.mlty uu___1 + | uu___ -> e in + let resugar_and_maybe_eta qual1 e = + let uu___ = eta_args g [] residualType in + match uu___ with + | (eargs, tres) -> + (match eargs with + | [] -> + let uu___1 = as_record qual1 e in + FStarC_Extraction_ML_Util.resugar_exp uu___1 + | uu___1 -> + let uu___2 = FStarC_Compiler_List.unzip eargs in + (match uu___2 with + | (binders, eargs1) -> + (match e.FStarC_Extraction_ML_Syntax.expr with + | FStarC_Extraction_ML_Syntax.MLE_CTor + (head, args) -> + let body = + let uu___3 = + let uu___4 = + FStarC_Extraction_ML_Syntax.with_ty tres + (FStarC_Extraction_ML_Syntax.MLE_CTor + (head, + (FStarC_Compiler_List.op_At args + eargs1))) in + as_record qual1 uu___4 in + FStarC_Extraction_ML_Util.resugar_exp uu___3 in + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Compiler_List.map + (fun uu___6 -> + match uu___6 with + | (x, t) -> + { + FStarC_Extraction_ML_Syntax.mlbinder_name + = x; + FStarC_Extraction_ML_Syntax.mlbinder_ty + = t; + FStarC_Extraction_ML_Syntax.mlbinder_attrs + = [] + }) binders in + (uu___5, body) in + FStarC_Extraction_ML_Syntax.MLE_Fun uu___4 in + FStarC_Extraction_ML_Syntax.with_ty + e.FStarC_Extraction_ML_Syntax.mlty uu___3 + | uu___3 -> + failwith "Impossible: Not a constructor"))) in + match ((mlAppExpr.FStarC_Extraction_ML_Syntax.expr), qual) with + | (uu___, FStar_Pervasives_Native.None) -> mlAppExpr + | (FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name mlp; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + mle::args), + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Record_projector (constrname, f))) -> + let fn = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Extraction_ML_UEnv.tcenv_of_uenv g in + FStarC_TypeChecker_Env.typ_of_datacon uu___4 constrname in + (uu___3, f) in + FStarC_Extraction_ML_UEnv.lookup_record_field_name g uu___2 in + let proj = FStarC_Extraction_ML_Syntax.MLE_Proj (mle, fn) in + let e = + match args with + | [] -> proj + | uu___2 -> + let uu___3 = + let uu___4 = + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.MLTY_Top proj in + (uu___4, args) in + FStarC_Extraction_ML_Syntax.MLE_App uu___3 in + FStarC_Extraction_ML_Syntax.with_ty + mlAppExpr.FStarC_Extraction_ML_Syntax.mlty e + | (FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name mlp; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + mle::args), + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Record_projector (constrname, f))) -> + let fn = + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Extraction_ML_UEnv.tcenv_of_uenv g in + FStarC_TypeChecker_Env.typ_of_datacon uu___7 constrname in + (uu___6, f) in + FStarC_Extraction_ML_UEnv.lookup_record_field_name g uu___5 in + let proj = FStarC_Extraction_ML_Syntax.MLE_Proj (mle, fn) in + let e = + match args with + | [] -> proj + | uu___5 -> + let uu___6 = + let uu___7 = + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.MLTY_Top proj in + (uu___7, args) in + FStarC_Extraction_ML_Syntax.MLE_App uu___6 in + FStarC_Extraction_ML_Syntax.with_ty + mlAppExpr.FStarC_Extraction_ML_Syntax.mlty e + | (FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name mlp; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + mlargs), + FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Data_ctor)) + -> + let uu___2 = + FStarC_Extraction_ML_Syntax.with_ty + mlAppExpr.FStarC_Extraction_ML_Syntax.mlty + (FStarC_Extraction_ML_Syntax.MLE_CTor (mlp, mlargs)) in + resugar_and_maybe_eta qual uu___2 + | (FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name mlp; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + mlargs), + FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Record_ctor + uu___2)) -> + let uu___3 = + FStarC_Extraction_ML_Syntax.with_ty + mlAppExpr.FStarC_Extraction_ML_Syntax.mlty + (FStarC_Extraction_ML_Syntax.MLE_CTor (mlp, mlargs)) in + resugar_and_maybe_eta qual uu___3 + | (FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name mlp; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + mlargs), + FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Data_ctor)) + -> + let uu___5 = + FStarC_Extraction_ML_Syntax.with_ty + mlAppExpr.FStarC_Extraction_ML_Syntax.mlty + (FStarC_Extraction_ML_Syntax.MLE_CTor (mlp, mlargs)) in + resugar_and_maybe_eta qual uu___5 + | (FStarC_Extraction_ML_Syntax.MLE_App + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name mlp; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2); + FStarC_Extraction_ML_Syntax.mlty = uu___3; + FStarC_Extraction_ML_Syntax.loc = uu___4;_}, + mlargs), + FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Record_ctor + uu___5)) -> + let uu___6 = + FStarC_Extraction_ML_Syntax.with_ty + mlAppExpr.FStarC_Extraction_ML_Syntax.mlty + (FStarC_Extraction_ML_Syntax.MLE_CTor (mlp, mlargs)) in + resugar_and_maybe_eta qual uu___6 + | (FStarC_Extraction_ML_Syntax.MLE_Name mlp, + FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Data_ctor)) + -> + let uu___ = + FStarC_Extraction_ML_Syntax.with_ty + mlAppExpr.FStarC_Extraction_ML_Syntax.mlty + (FStarC_Extraction_ML_Syntax.MLE_CTor (mlp, [])) in + resugar_and_maybe_eta qual uu___ + | (FStarC_Extraction_ML_Syntax.MLE_Name mlp, + FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Record_ctor + uu___)) -> + let uu___1 = + FStarC_Extraction_ML_Syntax.with_ty + mlAppExpr.FStarC_Extraction_ML_Syntax.mlty + (FStarC_Extraction_ML_Syntax.MLE_CTor (mlp, [])) in + resugar_and_maybe_eta qual uu___1 + | (FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name mlp; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2), + FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Data_ctor)) + -> + let uu___3 = + FStarC_Extraction_ML_Syntax.with_ty + mlAppExpr.FStarC_Extraction_ML_Syntax.mlty + (FStarC_Extraction_ML_Syntax.MLE_CTor (mlp, [])) in + resugar_and_maybe_eta qual uu___3 + | (FStarC_Extraction_ML_Syntax.MLE_TApp + ({ + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Name mlp; + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_}, + uu___2), + FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Record_ctor + uu___3)) -> + let uu___4 = + FStarC_Extraction_ML_Syntax.with_ty + mlAppExpr.FStarC_Extraction_ML_Syntax.mlty + (FStarC_Extraction_ML_Syntax.MLE_CTor (mlp, [])) in + resugar_and_maybe_eta qual uu___4 + | uu___ -> mlAppExpr +let (maybe_promote_effect : + FStarC_Extraction_ML_Syntax.mlexpr -> + FStarC_Extraction_ML_Syntax.e_tag -> + FStarC_Extraction_ML_Syntax.mlty -> + (FStarC_Extraction_ML_Syntax.mlexpr * + FStarC_Extraction_ML_Syntax.e_tag)) + = + fun ml_e -> + fun tag -> + fun t -> + match (tag, t) with + | (FStarC_Extraction_ML_Syntax.E_ERASABLE, + FStarC_Extraction_ML_Syntax.MLTY_Erased) -> + (FStarC_Extraction_ML_Syntax.ml_unit, + FStarC_Extraction_ML_Syntax.E_PURE) + | (FStarC_Extraction_ML_Syntax.E_PURE, + FStarC_Extraction_ML_Syntax.MLTY_Erased) -> + (FStarC_Extraction_ML_Syntax.ml_unit, + FStarC_Extraction_ML_Syntax.E_PURE) + | uu___ -> (ml_e, tag) +type lb_sig = + (FStarC_Syntax_Syntax.lbname * FStarC_Extraction_ML_Syntax.e_tag * + (FStarC_Syntax_Syntax.typ * (FStarC_Syntax_Syntax.binders * + FStarC_Extraction_ML_Syntax.mltyscheme)) * Prims.bool * Prims.bool * + FStarC_Syntax_Syntax.term) +let rec (extract_lb_sig : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.letbindings -> lb_sig Prims.list) + = + fun g -> + fun lbs -> + let maybe_generalize uu___ = + match uu___ with + | { FStarC_Syntax_Syntax.lbname = lbname_; + FStarC_Syntax_Syntax.lbunivs = uu___1; + FStarC_Syntax_Syntax.lbtyp = lbtyp; + FStarC_Syntax_Syntax.lbeff = lbeff; + FStarC_Syntax_Syntax.lbdef = lbdef; + FStarC_Syntax_Syntax.lbattrs = lbattrs; + FStarC_Syntax_Syntax.lbpos = uu___2;_} -> + let has_c_inline = + FStarC_Syntax_Util.has_attribute lbattrs + FStarC_Parser_Const.c_inline_attr in + let f_e = effect_as_etag g lbeff in + let lbtyp1 = FStarC_Syntax_Subst.compress lbtyp in + let no_gen uu___3 = + let expected_t = term_as_mlty g lbtyp1 in + (lbname_, f_e, (lbtyp1, ([], ([], expected_t))), false, + has_c_inline, lbdef) in + let uu___3 = + let uu___4 = FStarC_Extraction_ML_UEnv.tcenv_of_uenv g in + FStarC_TypeChecker_Util.must_erase_for_extraction uu___4 lbtyp1 in + if uu___3 + then + (lbname_, f_e, + (lbtyp1, ([], ([], FStarC_Extraction_ML_Syntax.MLTY_Erased))), + false, has_c_inline, lbdef) + else + (match lbtyp1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = c;_} + when + let uu___5 = FStarC_Compiler_List.hd bs in + is_type_binder g uu___5 -> + let uu___5 = FStarC_Syntax_Subst.open_comp bs c in + (match uu___5 with + | (bs1, c1) -> + let etag_of_comp c2 = + effect_as_etag g + (FStarC_Syntax_Util.comp_effect_name c2) in + let uu___6 = + let uu___7 = + FStarC_Compiler_Util.prefix_until + (fun x -> + let uu___8 = is_type_binder g x in + Prims.op_Negation uu___8) bs1 in + match uu___7 with + | FStar_Pervasives_Native.None -> + let uu___8 = etag_of_comp c1 in + (bs1, uu___8, + (FStarC_Syntax_Util.comp_result c1)) + | FStar_Pervasives_Native.Some (bs2, b, rest) -> + let uu___8 = + FStarC_Syntax_Util.arrow (b :: rest) c1 in + (bs2, FStarC_Extraction_ML_Syntax.E_PURE, + uu___8) in + (match uu___6 with + | (tbinders, eff_body, tbody) -> + let n_tbinders = + FStarC_Compiler_List.length tbinders in + let lbdef1 = + let uu___7 = normalize_abs lbdef in + FStarC_Syntax_Util.unmeta uu___7 in + let tbinders_as_ty_params env = + FStarC_Compiler_List.map + (fun uu___7 -> + match uu___7 with + | { FStarC_Syntax_Syntax.binder_bv = x; + FStarC_Syntax_Syntax.binder_qual = + uu___8; + FStarC_Syntax_Syntax.binder_positivity + = uu___9; + FStarC_Syntax_Syntax.binder_attrs = + binder_attrs;_} + -> + let uu___10 = + let uu___11 = + FStarC_Extraction_ML_UEnv.lookup_ty + env x in + uu___11.FStarC_Extraction_ML_UEnv.ty_b_name in + let uu___11 = + FStarC_Compiler_List.map + (fun attr -> + let uu___12 = + term_as_mlexpr g attr in + match uu___12 with + | (e, uu___13, uu___14) -> e) + binder_attrs in + { + FStarC_Extraction_ML_Syntax.ty_param_name + = uu___10; + FStarC_Extraction_ML_Syntax.ty_param_attrs + = uu___11 + }) in + (match lbdef1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs2; + FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = copt;_} + -> + let uu___7 = + FStarC_Syntax_Subst.open_term bs2 body in + (match uu___7 with + | (bs3, body1) -> + if + n_tbinders <= + (FStarC_Compiler_List.length bs3) + then + let uu___8 = + FStarC_Compiler_Util.first_N + n_tbinders bs3 in + (match uu___8 with + | (targs, rest_args) -> + let expected_source_ty = + let s = + FStarC_Compiler_List.map2 + (fun uu___9 -> + fun uu___10 -> + match (uu___9, + uu___10) + with + | ({ + FStarC_Syntax_Syntax.binder_bv + = x; + FStarC_Syntax_Syntax.binder_qual + = uu___11; + FStarC_Syntax_Syntax.binder_positivity + = uu___12; + FStarC_Syntax_Syntax.binder_attrs + = uu___13;_}, + { + FStarC_Syntax_Syntax.binder_bv + = y; + FStarC_Syntax_Syntax.binder_qual + = uu___14; + FStarC_Syntax_Syntax.binder_positivity + = uu___15; + FStarC_Syntax_Syntax.binder_attrs + = uu___16;_}) + -> + let uu___17 = + let uu___18 = + FStarC_Syntax_Syntax.bv_to_name + y in + (x, uu___18) in + FStarC_Syntax_Syntax.NT + uu___17) + tbinders targs in + FStarC_Syntax_Subst.subst s + tbody in + let env = + FStarC_Compiler_List.fold_left + (fun env1 -> + fun uu___9 -> + match uu___9 with + | { + FStarC_Syntax_Syntax.binder_bv + = a; + FStarC_Syntax_Syntax.binder_qual + = uu___10; + FStarC_Syntax_Syntax.binder_positivity + = uu___11; + FStarC_Syntax_Syntax.binder_attrs + = uu___12;_} + -> + FStarC_Extraction_ML_UEnv.extend_ty + env1 a false) g + targs in + let expected_t = + term_as_mlty env + expected_source_ty in + let polytype = + let uu___9 = + tbinders_as_ty_params env + targs in + (uu___9, expected_t) in + let add_unit = + match rest_args with + | [] -> + (let uu___9 = + is_fstar_value body1 in + Prims.op_Negation uu___9) + || + (let uu___9 = + FStarC_Syntax_Util.is_pure_comp + c1 in + Prims.op_Negation + uu___9) + | uu___9 -> false in + let rest_args1 = + if add_unit + then + let uu___9 = unit_binder () in + uu___9 :: rest_args + else rest_args in + let polytype1 = + if add_unit + then + FStarC_Extraction_ML_Syntax.push_unit + eff_body polytype + else polytype in + let body2 = + FStarC_Syntax_Util.abs + rest_args1 body1 copt in + (lbname_, f_e, + (lbtyp1, (targs, polytype1)), + add_unit, has_c_inline, + body2)) + else + failwith "Not enough type binders") + | FStarC_Syntax_Syntax.Tm_uinst uu___7 -> + let env = + FStarC_Compiler_List.fold_left + (fun env1 -> + fun uu___8 -> + match uu___8 with + | { + FStarC_Syntax_Syntax.binder_bv + = a; + FStarC_Syntax_Syntax.binder_qual + = uu___9; + FStarC_Syntax_Syntax.binder_positivity + = uu___10; + FStarC_Syntax_Syntax.binder_attrs + = uu___11;_} + -> + FStarC_Extraction_ML_UEnv.extend_ty + env1 a false) g tbinders in + let expected_t = term_as_mlty env tbody in + let polytype = + let uu___8 = + tbinders_as_ty_params env tbinders in + (uu___8, expected_t) in + let args = + FStarC_Compiler_List.map + (fun uu___8 -> + match uu___8 with + | { + FStarC_Syntax_Syntax.binder_bv = + bv; + FStarC_Syntax_Syntax.binder_qual + = uu___9; + FStarC_Syntax_Syntax.binder_positivity + = uu___10; + FStarC_Syntax_Syntax.binder_attrs + = uu___11;_} + -> + let uu___12 = + FStarC_Syntax_Syntax.bv_to_name + bv in + FStarC_Syntax_Syntax.as_arg + uu___12) tbinders in + let e = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = lbdef1; + FStarC_Syntax_Syntax.args = args + }) lbdef1.FStarC_Syntax_Syntax.pos in + (lbname_, f_e, + (lbtyp1, (tbinders, polytype)), false, + has_c_inline, e) + | FStarC_Syntax_Syntax.Tm_fvar uu___7 -> + let env = + FStarC_Compiler_List.fold_left + (fun env1 -> + fun uu___8 -> + match uu___8 with + | { + FStarC_Syntax_Syntax.binder_bv + = a; + FStarC_Syntax_Syntax.binder_qual + = uu___9; + FStarC_Syntax_Syntax.binder_positivity + = uu___10; + FStarC_Syntax_Syntax.binder_attrs + = uu___11;_} + -> + FStarC_Extraction_ML_UEnv.extend_ty + env1 a false) g tbinders in + let expected_t = term_as_mlty env tbody in + let polytype = + let uu___8 = + tbinders_as_ty_params env tbinders in + (uu___8, expected_t) in + let args = + FStarC_Compiler_List.map + (fun uu___8 -> + match uu___8 with + | { + FStarC_Syntax_Syntax.binder_bv = + bv; + FStarC_Syntax_Syntax.binder_qual + = uu___9; + FStarC_Syntax_Syntax.binder_positivity + = uu___10; + FStarC_Syntax_Syntax.binder_attrs + = uu___11;_} + -> + let uu___12 = + FStarC_Syntax_Syntax.bv_to_name + bv in + FStarC_Syntax_Syntax.as_arg + uu___12) tbinders in + let e = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = lbdef1; + FStarC_Syntax_Syntax.args = args + }) lbdef1.FStarC_Syntax_Syntax.pos in + (lbname_, f_e, + (lbtyp1, (tbinders, polytype)), false, + has_c_inline, e) + | FStarC_Syntax_Syntax.Tm_name uu___7 -> + let env = + FStarC_Compiler_List.fold_left + (fun env1 -> + fun uu___8 -> + match uu___8 with + | { + FStarC_Syntax_Syntax.binder_bv + = a; + FStarC_Syntax_Syntax.binder_qual + = uu___9; + FStarC_Syntax_Syntax.binder_positivity + = uu___10; + FStarC_Syntax_Syntax.binder_attrs + = uu___11;_} + -> + FStarC_Extraction_ML_UEnv.extend_ty + env1 a false) g tbinders in + let expected_t = term_as_mlty env tbody in + let polytype = + let uu___8 = + tbinders_as_ty_params env tbinders in + (uu___8, expected_t) in + let args = + FStarC_Compiler_List.map + (fun uu___8 -> + match uu___8 with + | { + FStarC_Syntax_Syntax.binder_bv = + bv; + FStarC_Syntax_Syntax.binder_qual + = uu___9; + FStarC_Syntax_Syntax.binder_positivity + = uu___10; + FStarC_Syntax_Syntax.binder_attrs + = uu___11;_} + -> + let uu___12 = + FStarC_Syntax_Syntax.bv_to_name + bv in + FStarC_Syntax_Syntax.as_arg + uu___12) tbinders in + let e = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = lbdef1; + FStarC_Syntax_Syntax.args = args + }) lbdef1.FStarC_Syntax_Syntax.pos in + (lbname_, f_e, + (lbtyp1, (tbinders, polytype)), false, + has_c_inline, e) + | uu___7 -> err_value_restriction lbdef1))) + | uu___5 -> no_gen ()) in + FStarC_Compiler_List.map maybe_generalize + (FStar_Pervasives_Native.snd lbs) +and (extract_lb_iface : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.letbindings -> + (FStarC_Extraction_ML_UEnv.uenv * (FStarC_Syntax_Syntax.fv * + FStarC_Extraction_ML_UEnv.exp_binding) Prims.list)) + = + fun g -> + fun lbs -> + let is_top = + FStarC_Syntax_Syntax.is_top_level (FStar_Pervasives_Native.snd lbs) in + let is_rec = + (Prims.op_Negation is_top) && (FStar_Pervasives_Native.fst lbs) in + let lbs1 = extract_lb_sig g lbs in + FStarC_Compiler_Util.fold_map + (fun env -> + fun uu___ -> + match uu___ with + | (lbname, _e_tag, (typ, (_binders, mltyscheme)), add_unit, + _has_c_inline, _body) -> + let uu___1 = + FStarC_Extraction_ML_UEnv.extend_lb env lbname typ + mltyscheme add_unit in + (match uu___1 with + | (env1, uu___2, exp_binding) -> + let uu___3 = + let uu___4 = FStarC_Compiler_Util.right lbname in + (uu___4, exp_binding) in + (env1, uu___3))) g lbs1 +and (check_term_as_mlexpr : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.term -> + FStarC_Extraction_ML_Syntax.e_tag -> + FStarC_Extraction_ML_Syntax.mlty -> + (FStarC_Extraction_ML_Syntax.mlexpr * + FStarC_Extraction_ML_Syntax.mlty)) + = + fun g -> + fun e -> + fun f -> + fun ty -> + FStarC_Extraction_ML_UEnv.debug g + (fun uu___1 -> + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + let uu___3 = + let uu___4 = + FStarC_Extraction_ML_UEnv.current_module_of_uenv g in + FStarC_Extraction_ML_Code.string_of_mlty uu___4 ty in + let uu___4 = FStarC_Extraction_ML_Util.eff_to_string f in + FStarC_Compiler_Util.print3 + "Checking %s at type %s and eff %s\n" uu___2 uu___3 uu___4); + (match (f, ty) with + | (FStarC_Extraction_ML_Syntax.E_ERASABLE, uu___1) -> + (FStarC_Extraction_ML_Syntax.ml_unit, + FStarC_Extraction_ML_Syntax.MLTY_Erased) + | (FStarC_Extraction_ML_Syntax.E_PURE, + FStarC_Extraction_ML_Syntax.MLTY_Erased) -> + (FStarC_Extraction_ML_Syntax.ml_unit, + FStarC_Extraction_ML_Syntax.MLTY_Erased) + | uu___1 -> + let uu___2 = term_as_mlexpr g e in + (match uu___2 with + | (ml_e, tag, t) -> + (FStarC_Extraction_ML_UEnv.debug g + (fun uu___4 -> + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term e in + let uu___6 = + let uu___7 = + FStarC_Extraction_ML_UEnv.current_module_of_uenv + g in + FStarC_Extraction_ML_Code.string_of_mlexpr uu___7 + ml_e in + let uu___7 = + FStarC_Extraction_ML_Util.eff_to_string tag in + let uu___8 = + let uu___9 = + FStarC_Extraction_ML_UEnv.current_module_of_uenv + g in + FStarC_Extraction_ML_Code.string_of_mlty uu___9 t in + FStarC_Compiler_Util.print4 + "Extracted %s to %s at eff %s and type %s\n" + uu___5 uu___6 uu___7 uu___8); + (let uu___4 = FStarC_Extraction_ML_Util.eff_leq tag f in + if uu___4 + then + let uu___5 = + maybe_coerce e.FStarC_Syntax_Syntax.pos g ml_e t ty in + (uu___5, ty) + else + (match (tag, f, ty) with + | (FStarC_Extraction_ML_Syntax.E_ERASABLE, + FStarC_Extraction_ML_Syntax.E_PURE, + FStarC_Extraction_ML_Syntax.MLTY_Erased) -> + let uu___6 = + maybe_coerce e.FStarC_Syntax_Syntax.pos g ml_e + t ty in + (uu___6, ty) + | uu___6 -> + (err_unexpected_eff g e ty f tag; + (let uu___8 = + maybe_coerce e.FStarC_Syntax_Syntax.pos g + ml_e t ty in + (uu___8, ty)))))))) +and (term_as_mlexpr : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.term -> + (FStarC_Extraction_ML_Syntax.mlexpr * FStarC_Extraction_ML_Syntax.e_tag + * FStarC_Extraction_ML_Syntax.mlty)) + = + fun g -> + fun e -> + let uu___ = term_as_mlexpr' g e in + match uu___ with + | (e1, f, t) -> + let uu___1 = maybe_promote_effect e1 f t in + (match uu___1 with | (e2, f1) -> (e2, f1, t)) +and (term_as_mlexpr' : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Syntax_Syntax.term -> + (FStarC_Extraction_ML_Syntax.mlexpr * FStarC_Extraction_ML_Syntax.e_tag + * FStarC_Extraction_ML_Syntax.mlty)) + = + fun g -> + fun top -> + let top1 = FStarC_Syntax_Subst.compress top in + FStarC_Extraction_ML_UEnv.debug g + (fun u -> + let uu___1 = + let uu___2 = + FStarC_Compiler_Range_Ops.string_of_range + top1.FStarC_Syntax_Syntax.pos in + let uu___3 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term + top1 in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term top1 in + FStarC_Compiler_Util.format3 "%s: term_as_mlexpr' (%s) : %s \n" + uu___2 uu___3 uu___4 in + FStarC_Compiler_Util.print_string uu___1); + (let is_match t = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress t in + FStarC_Syntax_Util.unascribe uu___3 in + uu___2.FStarC_Syntax_Syntax.n in + match uu___1 with + | FStarC_Syntax_Syntax.Tm_match uu___2 -> true + | uu___2 -> false in + let should_apply_to_match_branches = + FStarC_Compiler_List.for_all + (fun uu___1 -> + match uu___1 with + | (t, uu___2) -> + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.compress t in + uu___4.FStarC_Syntax_Syntax.n in + (match uu___3 with + | FStarC_Syntax_Syntax.Tm_name uu___4 -> true + | FStarC_Syntax_Syntax.Tm_fvar uu___4 -> true + | FStarC_Syntax_Syntax.Tm_constant uu___4 -> true + | uu___4 -> false)) in + let apply_to_match_branches head args = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress head in + FStarC_Syntax_Util.unascribe uu___3 in + uu___2.FStarC_Syntax_Syntax.n in + match uu___1 with + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = scrutinee; + FStarC_Syntax_Syntax.ret_opt = uu___2; + FStarC_Syntax_Syntax.brs = branches; + FStarC_Syntax_Syntax.rc_opt1 = uu___3;_} + -> + let branches1 = + FStarC_Compiler_List.map + (fun uu___4 -> + match uu___4 with + | (pat, when_opt, body) -> + (pat, when_opt, + { + FStarC_Syntax_Syntax.n = + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = body; + FStarC_Syntax_Syntax.args = args + }); + FStarC_Syntax_Syntax.pos = + (body.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = + (body.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (body.FStarC_Syntax_Syntax.hash_code) + })) branches in + { + FStarC_Syntax_Syntax.n = + (FStarC_Syntax_Syntax.Tm_match + { + FStarC_Syntax_Syntax.scrutinee = scrutinee; + FStarC_Syntax_Syntax.ret_opt = + FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.brs = branches1; + FStarC_Syntax_Syntax.rc_opt1 = + FStar_Pervasives_Native.None + }); + FStarC_Syntax_Syntax.pos = (head.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = (head.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (head.FStarC_Syntax_Syntax.hash_code) + } + | uu___2 -> + failwith + "Impossible! cannot apply args to match branches if head is not a match" in + let t = FStarC_Syntax_Subst.compress top1 in + match t.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_unknown -> + let uu___1 = + let uu___2 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t in + FStarC_Compiler_Util.format1 "Impossible: Unexpected term: %s" + uu___2 in + failwith uu___1 + | FStarC_Syntax_Syntax.Tm_delayed uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t in + FStarC_Compiler_Util.format1 "Impossible: Unexpected term: %s" + uu___3 in + failwith uu___2 + | FStarC_Syntax_Syntax.Tm_uvar uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t in + FStarC_Compiler_Util.format1 "Impossible: Unexpected term: %s" + uu___3 in + failwith uu___2 + | FStarC_Syntax_Syntax.Tm_bvar uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t in + FStarC_Compiler_Util.format1 "Impossible: Unexpected term: %s" + uu___3 in + failwith uu___2 + | FStarC_Syntax_Syntax.Tm_lazy i -> + let uu___1 = FStarC_Syntax_Util.unfold_lazy i in + term_as_mlexpr g uu___1 + | FStarC_Syntax_Syntax.Tm_type uu___1 -> + (FStarC_Extraction_ML_Syntax.ml_unit, + FStarC_Extraction_ML_Syntax.E_PURE, + FStarC_Extraction_ML_Syntax.ml_unit_ty) + | FStarC_Syntax_Syntax.Tm_refine uu___1 -> + (FStarC_Extraction_ML_Syntax.ml_unit, + FStarC_Extraction_ML_Syntax.E_PURE, + FStarC_Extraction_ML_Syntax.ml_unit_ty) + | FStarC_Syntax_Syntax.Tm_arrow uu___1 -> + (FStarC_Extraction_ML_Syntax.ml_unit, + FStarC_Extraction_ML_Syntax.E_PURE, + FStarC_Extraction_ML_Syntax.ml_unit_ty) + | FStarC_Syntax_Syntax.Tm_quoted + (qt, + { + FStarC_Syntax_Syntax.qkind = FStarC_Syntax_Syntax.Quote_dynamic; + FStarC_Syntax_Syntax.antiquotations = uu___1;_}) + -> + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Parser_Const.failwith_lid () in + FStarC_Syntax_Syntax.lid_as_fv uu___4 + FStar_Pervasives_Native.None in + FStarC_Extraction_ML_UEnv.lookup_fv t.FStarC_Syntax_Syntax.pos g + uu___3 in + (match uu___2 with + | { FStarC_Extraction_ML_UEnv.exp_b_name = uu___3; + FStarC_Extraction_ML_UEnv.exp_b_expr = fw; + FStarC_Extraction_ML_UEnv.exp_b_tscheme = uu___4; + FStarC_Extraction_ML_UEnv.exp_b_eff = uu___5;_} -> + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.ml_string_ty + (FStarC_Extraction_ML_Syntax.MLE_Const + (FStarC_Extraction_ML_Syntax.MLC_String + "Cannot evaluate open quotation at runtime")) in + [uu___10] in + (fw, uu___9) in + FStarC_Extraction_ML_Syntax.MLE_App uu___8 in + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.ml_int_ty uu___7 in + (uu___6, FStarC_Extraction_ML_Syntax.E_PURE, + FStarC_Extraction_ML_Syntax.ml_int_ty)) + | FStarC_Syntax_Syntax.Tm_quoted + (qt, + { FStarC_Syntax_Syntax.qkind = FStarC_Syntax_Syntax.Quote_static; + FStarC_Syntax_Syntax.antiquotations = (shift, aqs);_}) + -> + let uu___1 = FStarC_Reflection_V2_Builtins.inspect_ln qt in + (match uu___1 with + | FStarC_Reflection_V2_Data.Tv_BVar bv -> + if bv.FStarC_Syntax_Syntax.index < shift + then + let tv' = FStarC_Reflection_V2_Data.Tv_BVar bv in + let tv = + let uu___2 = + FStarC_Syntax_Embeddings_Base.embed + FStarC_Reflection_V2_Embeddings.e_term_view tv' in + uu___2 t.FStarC_Syntax_Syntax.pos + FStar_Pervasives_Native.None + FStarC_Syntax_Embeddings_Base.id_norm_cb in + let t1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.as_arg tv in [uu___3] in + FStarC_Syntax_Util.mk_app + (FStarC_Reflection_V2_Constants.refl_constant_term + FStarC_Reflection_V2_Constants.fstar_refl_pack_ln) + uu___2 in + term_as_mlexpr g t1 + else + (let tm = FStarC_Syntax_Syntax.lookup_aq bv (shift, aqs) in + term_as_mlexpr g tm) + | tv -> + let tv1 = + let uu___2 = + let uu___3 = + FStarC_Reflection_V2_Embeddings.e_term_view_aq + (shift, aqs) in + FStarC_Syntax_Embeddings_Base.embed uu___3 tv in + uu___2 t.FStarC_Syntax_Syntax.pos + FStar_Pervasives_Native.None + FStarC_Syntax_Embeddings_Base.id_norm_cb in + let t1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.as_arg tv1 in [uu___3] in + FStarC_Syntax_Util.mk_app + (FStarC_Reflection_V2_Constants.refl_constant_term + FStarC_Reflection_V2_Constants.fstar_refl_pack_ln) + uu___2 in + term_as_mlexpr g t1) + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t1; + FStarC_Syntax_Syntax.meta = FStarC_Syntax_Syntax.Meta_monadic + (m, uu___1);_} + -> + let t2 = FStarC_Syntax_Subst.compress t1 in + (match t2.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (false, lb::[]); + FStarC_Syntax_Syntax.body1 = body;_} + when + FStarC_Compiler_Util.is_left lb.FStarC_Syntax_Syntax.lbname + -> + let tcenv = FStarC_Extraction_ML_UEnv.tcenv_of_uenv g in + let uu___2 = + let uu___3 = FStarC_TypeChecker_Env.effect_decl_opt tcenv m in + FStarC_Compiler_Util.must uu___3 in + (match uu___2 with + | (ed, qualifiers) -> + let uu___3 = + let uu___4 = + FStarC_TypeChecker_Util.effect_extraction_mode tcenv + ed.FStarC_Syntax_Syntax.mname in + uu___4 = FStarC_Syntax_Syntax.Extract_primitive in + if uu___3 + then term_as_mlexpr g t2 + else + (let uu___5 = + let uu___6 = + FStarC_Ident.string_of_lid + ed.FStarC_Syntax_Syntax.mname in + FStarC_Compiler_Util.format1 + "This should not happen (should have been handled at Tm_abs level for effect %s)" + uu___6 in + failwith uu___5)) + | uu___2 -> term_as_mlexpr g t2) + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t1; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_monadic_lift (m1, _m2, _ty);_} + when + let uu___1 = effect_as_etag g m1 in + uu___1 = FStarC_Extraction_ML_Syntax.E_ERASABLE -> + (FStarC_Extraction_ML_Syntax.ml_unit, + FStarC_Extraction_ML_Syntax.E_ERASABLE, + FStarC_Extraction_ML_Syntax.MLTY_Erased) + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t1; + FStarC_Syntax_Syntax.meta = FStarC_Syntax_Syntax.Meta_desugared + (FStarC_Syntax_Syntax.Machine_integer (signedness, width));_} + -> + let t2 = FStarC_Syntax_Subst.compress t1 in + let t3 = FStarC_Syntax_Util.unascribe t2 in + (match t3.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = hd; + FStarC_Syntax_Syntax.args = (x, uu___1)::[];_} + -> + let x1 = FStarC_Syntax_Subst.compress x in + let x2 = FStarC_Syntax_Util.unascribe x1 in + (match x2.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_constant (FStarC_Const.Const_int + (repr, uu___2)) -> + let uu___3 = + let uu___4 = FStarC_Extraction_ML_UEnv.tcenv_of_uenv g in + FStarC_TypeChecker_TcTerm.typeof_tot_or_gtot_term + uu___4 t3 true in + (match uu___3 with + | (uu___4, ty, uu___5) -> + let ml_ty = term_as_mlty g ty in + let ml_const = + FStarC_Const.Const_int + (repr, + (FStar_Pervasives_Native.Some + (signedness, width))) in + let uu___6 = + let uu___7 = + FStarC_Extraction_ML_Util.mlexpr_of_const + t3.FStarC_Syntax_Syntax.pos ml_const in + FStarC_Extraction_ML_Syntax.with_ty ml_ty uu___7 in + (uu___6, FStarC_Extraction_ML_Syntax.E_PURE, ml_ty)) + | uu___2 -> term_as_mlexpr g t3) + | uu___1 -> term_as_mlexpr g t3) + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t1; + FStarC_Syntax_Syntax.meta = uu___1;_} + -> term_as_mlexpr g t1 + | FStarC_Syntax_Syntax.Tm_uinst (t1, uu___1) -> term_as_mlexpr g t1 + | FStarC_Syntax_Syntax.Tm_constant c -> + let tcenv = FStarC_Extraction_ML_UEnv.tcenv_of_uenv g in + let uu___1 = + FStarC_TypeChecker_TcTerm.typeof_tot_or_gtot_term tcenv t true in + (match uu___1 with + | (uu___2, ty, uu___3) -> + let uu___4 = + FStarC_TypeChecker_Util.must_erase_for_extraction tcenv ty in + if uu___4 + then + (FStarC_Extraction_ML_Syntax.ml_unit, + FStarC_Extraction_ML_Syntax.E_PURE, + FStarC_Extraction_ML_Syntax.MLTY_Erased) + else + (let ml_ty = term_as_mlty g ty in + let uu___6 = + let uu___7 = + FStarC_Extraction_ML_Util.mlexpr_of_const + t.FStarC_Syntax_Syntax.pos c in + FStarC_Extraction_ML_Syntax.with_ty ml_ty uu___7 in + (uu___6, FStarC_Extraction_ML_Syntax.E_PURE, ml_ty))) + | FStarC_Syntax_Syntax.Tm_name uu___1 -> + let uu___2 = is_type g t in + if uu___2 + then + (FStarC_Extraction_ML_Syntax.ml_unit, + FStarC_Extraction_ML_Syntax.E_PURE, + FStarC_Extraction_ML_Syntax.ml_unit_ty) + else + (let uu___4 = FStarC_Extraction_ML_UEnv.lookup_term g t in + match uu___4 with + | (FStar_Pervasives.Inl uu___5, uu___6) -> + (FStarC_Extraction_ML_Syntax.ml_unit, + FStarC_Extraction_ML_Syntax.E_PURE, + FStarC_Extraction_ML_Syntax.ml_unit_ty) + | (FStar_Pervasives.Inr + { FStarC_Extraction_ML_UEnv.exp_b_name = uu___5; + FStarC_Extraction_ML_UEnv.exp_b_expr = x; + FStarC_Extraction_ML_UEnv.exp_b_tscheme = mltys; + FStarC_Extraction_ML_UEnv.exp_b_eff = etag;_}, + qual) -> + (match mltys with + | ([], t1) when + t1 = FStarC_Extraction_ML_Syntax.ml_unit_ty -> + (FStarC_Extraction_ML_Syntax.ml_unit, etag, t1) + | ([], t1) -> + let uu___6 = + maybe_eta_data_and_project_record g qual t1 x in + (uu___6, etag, t1) + | uu___6 -> instantiate_maybe_partial g x etag mltys [])) + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let uu___1 = is_type g t in + if uu___1 + then + (FStarC_Extraction_ML_Syntax.ml_unit, + FStarC_Extraction_ML_Syntax.E_PURE, + FStarC_Extraction_ML_Syntax.ml_unit_ty) + else + (let uu___3 = + FStarC_Extraction_ML_UEnv.try_lookup_fv + t.FStarC_Syntax_Syntax.pos g fv in + match uu___3 with + | FStar_Pervasives_Native.None -> + (FStarC_Extraction_ML_Syntax.ml_unit, + FStarC_Extraction_ML_Syntax.E_PURE, + FStarC_Extraction_ML_Syntax.MLTY_Erased) + | FStar_Pervasives_Native.Some + { FStarC_Extraction_ML_UEnv.exp_b_name = uu___4; + FStarC_Extraction_ML_UEnv.exp_b_expr = x; + FStarC_Extraction_ML_UEnv.exp_b_tscheme = mltys; + FStarC_Extraction_ML_UEnv.exp_b_eff = uu___5;_} + -> + (FStarC_Extraction_ML_UEnv.debug g + (fun uu___7 -> + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_fv fv in + let uu___9 = + FStarC_Class_Show.show + FStarC_Extraction_ML_Code.showable_mlexpr x in + let uu___10 = + FStarC_Class_Show.show + FStarC_Extraction_ML_Code.showable_mlty + (FStar_Pervasives_Native.snd mltys) in + FStarC_Compiler_Util.print3 + "looked up %s: got %s at %s \n" uu___8 uu___9 + uu___10); + (match mltys with + | ([], t1) when + t1 = FStarC_Extraction_ML_Syntax.ml_unit_ty -> + (FStarC_Extraction_ML_Syntax.ml_unit, + FStarC_Extraction_ML_Syntax.E_PURE, t1) + | ([], t1) -> + let uu___7 = + maybe_eta_data_and_project_record g + fv.FStarC_Syntax_Syntax.fv_qual t1 x in + (uu___7, FStarC_Extraction_ML_Syntax.E_PURE, t1) + | uu___7 -> + instantiate_maybe_partial g x + FStarC_Extraction_ML_Syntax.E_PURE mltys []))) + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs; FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = rcopt;_} + -> + let uu___1 = FStarC_Syntax_Subst.open_term bs body in + (match uu___1 with + | (bs1, body1) -> + let uu___2 = binders_as_ml_binders g bs1 in + (match uu___2 with + | (ml_bs, env) -> + let ml_bs1 = + FStarC_Compiler_List.map2 + (fun uu___3 -> + fun b -> + match uu___3 with + | (x, t1) -> + let uu___4 = + FStarC_Compiler_List.map + (fun attr -> + let uu___5 = term_as_mlexpr env attr in + match uu___5 with + | (e, uu___6, uu___7) -> e) + b.FStarC_Syntax_Syntax.binder_attrs in + { + FStarC_Extraction_ML_Syntax.mlbinder_name + = x; + FStarC_Extraction_ML_Syntax.mlbinder_ty = + t1; + FStarC_Extraction_ML_Syntax.mlbinder_attrs + = uu___4 + }) ml_bs bs1 in + let body2 = + match rcopt with + | FStar_Pervasives_Native.Some rc -> + let uu___3 = + FStarC_Extraction_ML_UEnv.tcenv_of_uenv env in + maybe_reify_term uu___3 body1 + rc.FStarC_Syntax_Syntax.residual_effect + | FStar_Pervasives_Native.None -> + (FStarC_Extraction_ML_UEnv.debug g + (fun uu___4 -> + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term body1 in + FStarC_Compiler_Util.print1 + "No computation type for: %s\n" uu___5); + body1) in + let uu___3 = term_as_mlexpr env body2 in + (match uu___3 with + | (ml_body, f, t1) -> + let uu___4 = + FStarC_Compiler_List.fold_right + (fun uu___5 -> + fun uu___6 -> + match (uu___5, uu___6) with + | ({ + FStarC_Extraction_ML_Syntax.mlbinder_name + = uu___7; + FStarC_Extraction_ML_Syntax.mlbinder_ty + = targ; + FStarC_Extraction_ML_Syntax.mlbinder_attrs + = uu___8;_}, + (f1, t2)) -> + (FStarC_Extraction_ML_Syntax.E_PURE, + (FStarC_Extraction_ML_Syntax.MLTY_Fun + (targ, f1, t2)))) ml_bs1 + (f, t1) in + (match uu___4 with + | (f1, tfun) -> + let uu___5 = + FStarC_Extraction_ML_Syntax.with_ty tfun + (FStarC_Extraction_ML_Syntax.MLE_Fun + (ml_bs1, ml_body)) in + (uu___5, f1, tfun))))) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_range_of); + FStarC_Syntax_Syntax.pos = uu___1; + FStarC_Syntax_Syntax.vars = uu___2; + FStarC_Syntax_Syntax.hash_code = uu___3;_}; + FStarC_Syntax_Syntax.args = (a1, uu___4)::[];_} + -> + let ty = + let uu___5 = + FStarC_Syntax_Syntax.tabbrev FStarC_Parser_Const.range_lid in + term_as_mlty g uu___5 in + let uu___5 = + let uu___6 = + FStarC_Extraction_ML_Util.mlexpr_of_range + a1.FStarC_Syntax_Syntax.pos in + FStarC_Extraction_ML_Syntax.with_ty ty uu___6 in + (uu___5, FStarC_Extraction_ML_Syntax.E_PURE, ty) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_set_range_of); + FStarC_Syntax_Syntax.pos = uu___1; + FStarC_Syntax_Syntax.vars = uu___2; + FStarC_Syntax_Syntax.hash_code = uu___3;_}; + FStarC_Syntax_Syntax.args = (t1, uu___4)::(r, uu___5)::[];_} + -> term_as_mlexpr g t1 + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_reflect uu___1); + FStarC_Syntax_Syntax.pos = uu___2; + FStarC_Syntax_Syntax.vars = uu___3; + FStarC_Syntax_Syntax.hash_code = uu___4;_}; + FStarC_Syntax_Syntax.args = uu___5;_} + -> + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Parser_Const.failwith_lid () in + FStarC_Syntax_Syntax.lid_as_fv uu___8 + FStar_Pervasives_Native.None in + FStarC_Extraction_ML_UEnv.lookup_fv t.FStarC_Syntax_Syntax.pos g + uu___7 in + (match uu___6 with + | { FStarC_Extraction_ML_UEnv.exp_b_name = uu___7; + FStarC_Extraction_ML_UEnv.exp_b_expr = fw; + FStarC_Extraction_ML_UEnv.exp_b_tscheme = uu___8; + FStarC_Extraction_ML_UEnv.exp_b_eff = uu___9;_} -> + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.ml_string_ty + (FStarC_Extraction_ML_Syntax.MLE_Const + (FStarC_Extraction_ML_Syntax.MLC_String + "Extraction of reflect is not supported")) in + [uu___14] in + (fw, uu___13) in + FStarC_Extraction_ML_Syntax.MLE_App uu___12 in + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.ml_int_ty uu___11 in + (uu___10, FStarC_Extraction_ML_Syntax.E_PURE, + FStarC_Extraction_ML_Syntax.ml_int_ty)) + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = args;_} + when (is_match head) && (should_apply_to_match_branches args) -> + let uu___1 = apply_to_match_branches head args in + term_as_mlexpr g uu___1 + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = args;_} + -> + let is_total rc = + (FStarC_Ident.lid_equals rc.FStarC_Syntax_Syntax.residual_effect + FStarC_Parser_Const.effect_Tot_lid) + || + (FStarC_Compiler_List.existsb + (fun uu___1 -> + match uu___1 with + | FStarC_Syntax_Syntax.TOTAL -> true + | uu___2 -> false) + rc.FStarC_Syntax_Syntax.residual_flags) in + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress head in + FStarC_Syntax_Util.unascribe uu___3 in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs; + FStarC_Syntax_Syntax.body = uu___2; + FStarC_Syntax_Syntax.rc_opt = rc;_} + -> + let uu___3 = + let uu___4 = FStarC_Extraction_ML_UEnv.tcenv_of_uenv g in + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Iota; + FStarC_TypeChecker_Env.Zeta; + FStarC_TypeChecker_Env.EraseUniverses; + FStarC_TypeChecker_Env.AllowUnboundUniverses; + FStarC_TypeChecker_Env.ForExtraction] uu___4 t in + term_as_mlexpr g uu___3 + | FStarC_Syntax_Syntax.Tm_constant (FStarC_Const.Const_reify + lopt) -> + (match lopt with + | FStar_Pervasives_Native.Some l -> + let e = + let uu___2 = FStarC_Extraction_ML_UEnv.tcenv_of_uenv g in + let uu___3 = + let uu___4 = FStarC_Compiler_List.hd args in + FStar_Pervasives_Native.fst uu___4 in + maybe_reify_term uu___2 uu___3 l in + let tm = + let uu___2 = FStarC_TypeChecker_Util.remove_reify e in + let uu___3 = FStarC_Compiler_List.tl args in + FStarC_Syntax_Syntax.mk_Tm_app uu___2 uu___3 + t.FStarC_Syntax_Syntax.pos in + term_as_mlexpr g tm + | FStar_Pervasives_Native.None -> + let uu___2 = + let uu___3 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term top1 in + FStarC_Compiler_Util.format1 + "Cannot extract %s (reify effect is not set)" uu___3 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) top1 + FStarC_Errors_Codes.Fatal_ExtractionUnsupported () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)) + | uu___2 -> + let rec extract_app is_data uu___3 uu___4 restArgs = + match (uu___3, uu___4) with + | ((mlhead, mlargs_f), (f, t1)) -> + let mk_head uu___5 = + let mlargs = + FStarC_Compiler_List.map + FStar_Pervasives_Native.fst + (FStarC_Compiler_List.rev mlargs_f) in + FStarC_Extraction_ML_Syntax.with_ty t1 + (FStarC_Extraction_ML_Syntax.MLE_App + (mlhead, mlargs)) in + (FStarC_Extraction_ML_UEnv.debug g + (fun uu___6 -> + let uu___7 = + let uu___8 = + FStarC_Extraction_ML_UEnv.current_module_of_uenv + g in + let uu___9 = mk_head () in + FStarC_Extraction_ML_Code.string_of_mlexpr + uu___8 uu___9 in + let uu___8 = + let uu___9 = + FStarC_Extraction_ML_UEnv.current_module_of_uenv + g in + FStarC_Extraction_ML_Code.string_of_mlty uu___9 + t1 in + let uu___9 = + match restArgs with + | [] -> "none" + | (hd, uu___10)::uu___11 -> + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term hd in + FStarC_Compiler_Util.print3 + "extract_app ml_head=%s type of head = %s, next arg = %s\n" + uu___7 uu___8 uu___9); + (match (restArgs, t1) with + | ([], uu___6) -> + let app = + let uu___7 = mk_head () in + maybe_eta_data_and_project_record g is_data t1 + uu___7 in + (app, f, t1) + | ((arg, uu___6)::rest, + FStarC_Extraction_ML_Syntax.MLTY_Fun + (formal_t, f', t2)) when + (is_type g arg) && + (type_leq g formal_t + FStarC_Extraction_ML_Syntax.ml_unit_ty) + -> + let uu___7 = + let uu___8 = + FStarC_Extraction_ML_Util.join + arg.FStarC_Syntax_Syntax.pos f f' in + (uu___8, t2) in + extract_app is_data + (mlhead, + ((FStarC_Extraction_ML_Syntax.ml_unit, + FStarC_Extraction_ML_Syntax.E_PURE) :: + mlargs_f)) uu___7 rest + | ((e0, uu___6)::rest, + FStarC_Extraction_ML_Syntax.MLTY_Fun + (tExpected, f', t2)) -> + let r = e0.FStarC_Syntax_Syntax.pos in + let expected_effect = + let uu___7 = + (FStarC_Options.lax ()) && + (FStarC_TypeChecker_Util.short_circuit_head + head) in + if uu___7 + then FStarC_Extraction_ML_Syntax.E_IMPURE + else FStarC_Extraction_ML_Syntax.E_PURE in + let uu___7 = + check_term_as_mlexpr g e0 expected_effect + tExpected in + (match uu___7 with + | (e01, tInferred) -> + let uu___8 = + let uu___9 = + FStarC_Extraction_ML_Util.join_l r + [f; f'] in + (uu___9, t2) in + extract_app is_data + (mlhead, ((e01, expected_effect) :: + mlargs_f)) uu___8 rest) + | uu___6 -> + let uu___7 = + FStarC_Extraction_ML_Util.udelta_unfold g t1 in + (match uu___7 with + | FStar_Pervasives_Native.Some t2 -> + extract_app is_data (mlhead, mlargs_f) + (f, t2) restArgs + | FStar_Pervasives_Native.None -> + (match t1 with + | FStarC_Extraction_ML_Syntax.MLTY_Erased + -> + (FStarC_Extraction_ML_Syntax.ml_unit, + FStarC_Extraction_ML_Syntax.E_PURE, + t1) + | FStarC_Extraction_ML_Syntax.MLTY_Top -> + let t2 = + FStarC_Compiler_List.fold_right + (fun t3 -> + fun out -> + FStarC_Extraction_ML_Syntax.MLTY_Fun + (FStarC_Extraction_ML_Syntax.MLTY_Top, + FStarC_Extraction_ML_Syntax.E_PURE, + out)) restArgs + FStarC_Extraction_ML_Syntax.MLTY_Top in + let mlhead1 = + let mlargs = + FStarC_Compiler_List.map + FStar_Pervasives_Native.fst + (FStarC_Compiler_List.rev + mlargs_f) in + let head1 = + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.MLTY_Top + (FStarC_Extraction_ML_Syntax.MLE_App + (mlhead, mlargs)) in + maybe_coerce + top1.FStarC_Syntax_Syntax.pos g + head1 + FStarC_Extraction_ML_Syntax.MLTY_Top + t2 in + extract_app is_data (mlhead1, []) + (f, t2) restArgs + | uu___8 -> + let mlhead1 = + let mlargs = + FStarC_Compiler_List.map + FStar_Pervasives_Native.fst + (FStarC_Compiler_List.rev + mlargs_f) in + let head1 = + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.MLTY_Top + (FStarC_Extraction_ML_Syntax.MLE_App + (mlhead, mlargs)) in + maybe_coerce + top1.FStarC_Syntax_Syntax.pos g + head1 + FStarC_Extraction_ML_Syntax.MLTY_Top + t1 in + err_ill_typed_application g top1 + mlhead1 restArgs t1)))) in + let extract_app_maybe_projector is_data mlhead uu___3 args1 = + match uu___3 with + | (f, t1) -> + (match is_data with + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Record_projector uu___4) -> + let rec remove_implicits args2 f1 t2 = + match (args2, t2) with + | ((a0, FStar_Pervasives_Native.Some + { + FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = + uu___5;_})::args3, + FStarC_Extraction_ML_Syntax.MLTY_Fun + (uu___6, f', t3)) -> + let uu___7 = + FStarC_Extraction_ML_Util.join + a0.FStarC_Syntax_Syntax.pos f1 f' in + remove_implicits args3 uu___7 t3 + | uu___5 -> (args2, f1, t2) in + let uu___5 = remove_implicits args1 f t1 in + (match uu___5 with + | (args2, f1, t2) -> + extract_app is_data (mlhead, []) (f1, t2) + args2) + | uu___4 -> + extract_app is_data (mlhead, []) (f, t1) args1) in + let extract_app_with_instantiations uu___3 = + let head1 = FStarC_Syntax_Util.un_uinst head in + match head1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_name uu___4 -> + let uu___5 = + let uu___6 = + FStarC_Extraction_ML_UEnv.lookup_term g head1 in + match uu___6 with + | (FStar_Pervasives.Inr exp_b, q) -> + (FStarC_Extraction_ML_UEnv.debug g + (fun uu___8 -> + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head1 in + let uu___10 = + FStarC_Class_Show.show + FStarC_Extraction_ML_Code.showable_mlexpr + exp_b.FStarC_Extraction_ML_UEnv.exp_b_expr in + let uu___11 = + FStarC_Class_Show.show + FStarC_Extraction_ML_Code.showable_mlty + (FStar_Pervasives_Native.snd + exp_b.FStarC_Extraction_ML_UEnv.exp_b_tscheme) in + let uu___12 = + FStarC_Class_Show.show + FStarC_Extraction_ML_Code.showable_etag + exp_b.FStarC_Extraction_ML_UEnv.exp_b_eff in + FStarC_Compiler_Util.print4 + "@@@looked up %s: got %s at %s with eff <%s>\n" + uu___9 uu___10 uu___11 uu___12); + (((exp_b.FStarC_Extraction_ML_UEnv.exp_b_expr), + (exp_b.FStarC_Extraction_ML_UEnv.exp_b_tscheme), + (exp_b.FStarC_Extraction_ML_UEnv.exp_b_eff)), + q)) + | uu___7 -> failwith "FIXME Ty" in + (match uu___5 with + | ((head_ml, (vars, t1), head_eff), qual) -> + let has_typ_apps = + match args with + | (a, uu___6)::uu___7 -> is_type g a + | uu___6 -> false in + let uu___6 = + let n = FStarC_Compiler_List.length vars in + let uu___7 = + if (FStarC_Compiler_List.length args) <= n + then + let uu___8 = + FStarC_Compiler_List.map + (fun uu___9 -> + match uu___9 with + | (x, uu___10) -> term_as_mlty g x) + args in + (uu___8, []) + else + (let uu___9 = + FStarC_Compiler_Util.first_N n args in + match uu___9 with + | (prefix, rest) -> + let uu___10 = + FStarC_Compiler_List.map + (fun uu___11 -> + match uu___11 with + | (x, uu___12) -> + term_as_mlty g x) prefix in + (uu___10, rest)) in + match uu___7 with + | (provided_type_args, rest) -> + let uu___8 = + match head_ml.FStarC_Extraction_ML_Syntax.expr + with + | FStarC_Extraction_ML_Syntax.MLE_Name + uu___9 -> + let uu___10 = + instantiate_maybe_partial g head_ml + head_eff (vars, t1) + provided_type_args in + (match uu___10 with + | (head2, eff, t2) -> + (head2, eff, t2)) + | FStarC_Extraction_ML_Syntax.MLE_Var + uu___9 -> + let uu___10 = + instantiate_maybe_partial g head_ml + head_eff (vars, t1) + provided_type_args in + (match uu___10 with + | (head2, eff, t2) -> + (head2, eff, t2)) + | FStarC_Extraction_ML_Syntax.MLE_App + (head2, + { + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Const + (FStarC_Extraction_ML_Syntax.MLC_Unit); + FStarC_Extraction_ML_Syntax.mlty = + uu___9; + FStarC_Extraction_ML_Syntax.loc = + uu___10;_}::[]) + -> + let uu___11 = + instantiate_maybe_partial g head2 + head_eff (vars, t1) + provided_type_args in + (match uu___11 with + | (head3, eff, t2) -> + let uu___12 = + FStarC_Extraction_ML_Syntax.with_ty + t2 + (FStarC_Extraction_ML_Syntax.MLE_App + (head3, + [FStarC_Extraction_ML_Syntax.ml_unit])) in + (uu___12, eff, t2)) + | uu___9 -> + failwith + "Impossible: Unexpected head term" in + (match uu___8 with + | (head2, head_eff1, t2) -> + (head2, head_eff1, t2, rest)) in + (match uu___6 with + | (head_ml1, head_eff1, head_t, args1) -> + (match args1 with + | [] -> + let uu___7 = + maybe_eta_data_and_project_record g + qual head_t head_ml1 in + (uu___7, head_eff1, head_t) + | uu___7 -> + extract_app_maybe_projector qual + head_ml1 (head_eff1, head_t) args1))) + | FStarC_Syntax_Syntax.Tm_fvar uu___4 -> + let uu___5 = + let uu___6 = + FStarC_Extraction_ML_UEnv.lookup_term g head1 in + match uu___6 with + | (FStar_Pervasives.Inr exp_b, q) -> + (FStarC_Extraction_ML_UEnv.debug g + (fun uu___8 -> + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head1 in + let uu___10 = + FStarC_Class_Show.show + FStarC_Extraction_ML_Code.showable_mlexpr + exp_b.FStarC_Extraction_ML_UEnv.exp_b_expr in + let uu___11 = + FStarC_Class_Show.show + FStarC_Extraction_ML_Code.showable_mlty + (FStar_Pervasives_Native.snd + exp_b.FStarC_Extraction_ML_UEnv.exp_b_tscheme) in + let uu___12 = + FStarC_Class_Show.show + FStarC_Extraction_ML_Code.showable_etag + exp_b.FStarC_Extraction_ML_UEnv.exp_b_eff in + FStarC_Compiler_Util.print4 + "@@@looked up %s: got %s at %s with eff <%s>\n" + uu___9 uu___10 uu___11 uu___12); + (((exp_b.FStarC_Extraction_ML_UEnv.exp_b_expr), + (exp_b.FStarC_Extraction_ML_UEnv.exp_b_tscheme), + (exp_b.FStarC_Extraction_ML_UEnv.exp_b_eff)), + q)) + | uu___7 -> failwith "FIXME Ty" in + (match uu___5 with + | ((head_ml, (vars, t1), head_eff), qual) -> + let has_typ_apps = + match args with + | (a, uu___6)::uu___7 -> is_type g a + | uu___6 -> false in + let uu___6 = + let n = FStarC_Compiler_List.length vars in + let uu___7 = + if (FStarC_Compiler_List.length args) <= n + then + let uu___8 = + FStarC_Compiler_List.map + (fun uu___9 -> + match uu___9 with + | (x, uu___10) -> term_as_mlty g x) + args in + (uu___8, []) + else + (let uu___9 = + FStarC_Compiler_Util.first_N n args in + match uu___9 with + | (prefix, rest) -> + let uu___10 = + FStarC_Compiler_List.map + (fun uu___11 -> + match uu___11 with + | (x, uu___12) -> + term_as_mlty g x) prefix in + (uu___10, rest)) in + match uu___7 with + | (provided_type_args, rest) -> + let uu___8 = + match head_ml.FStarC_Extraction_ML_Syntax.expr + with + | FStarC_Extraction_ML_Syntax.MLE_Name + uu___9 -> + let uu___10 = + instantiate_maybe_partial g head_ml + head_eff (vars, t1) + provided_type_args in + (match uu___10 with + | (head2, eff, t2) -> + (head2, eff, t2)) + | FStarC_Extraction_ML_Syntax.MLE_Var + uu___9 -> + let uu___10 = + instantiate_maybe_partial g head_ml + head_eff (vars, t1) + provided_type_args in + (match uu___10 with + | (head2, eff, t2) -> + (head2, eff, t2)) + | FStarC_Extraction_ML_Syntax.MLE_App + (head2, + { + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Const + (FStarC_Extraction_ML_Syntax.MLC_Unit); + FStarC_Extraction_ML_Syntax.mlty = + uu___9; + FStarC_Extraction_ML_Syntax.loc = + uu___10;_}::[]) + -> + let uu___11 = + instantiate_maybe_partial g head2 + head_eff (vars, t1) + provided_type_args in + (match uu___11 with + | (head3, eff, t2) -> + let uu___12 = + FStarC_Extraction_ML_Syntax.with_ty + t2 + (FStarC_Extraction_ML_Syntax.MLE_App + (head3, + [FStarC_Extraction_ML_Syntax.ml_unit])) in + (uu___12, eff, t2)) + | uu___9 -> + failwith + "Impossible: Unexpected head term" in + (match uu___8 with + | (head2, head_eff1, t2) -> + (head2, head_eff1, t2, rest)) in + (match uu___6 with + | (head_ml1, head_eff1, head_t, args1) -> + (match args1 with + | [] -> + let uu___7 = + maybe_eta_data_and_project_record g + qual head_t head_ml1 in + (uu___7, head_eff1, head_t) + | uu___7 -> + extract_app_maybe_projector qual + head_ml1 (head_eff1, head_t) args1))) + | uu___4 -> + let uu___5 = term_as_mlexpr g head1 in + (match uu___5 with + | (head2, f, t1) -> + extract_app_maybe_projector + FStar_Pervasives_Native.None head2 (f, t1) args) in + let uu___3 = is_type g t in + if uu___3 + then + (FStarC_Extraction_ML_Syntax.ml_unit, + FStarC_Extraction_ML_Syntax.E_PURE, + FStarC_Extraction_ML_Syntax.ml_unit_ty) + else + (let uu___5 = + let uu___6 = FStarC_Syntax_Util.un_uinst head in + uu___6.FStarC_Syntax_Syntax.n in + match uu___5 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let uu___6 = + FStarC_Extraction_ML_UEnv.try_lookup_fv + t.FStarC_Syntax_Syntax.pos g fv in + (match uu___6 with + | FStar_Pervasives_Native.None -> + (FStarC_Extraction_ML_Syntax.ml_unit, + FStarC_Extraction_ML_Syntax.E_PURE, + FStarC_Extraction_ML_Syntax.MLTY_Erased) + | uu___7 -> extract_app_with_instantiations ()) + | uu___6 -> extract_app_with_instantiations ())) + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = e0; + FStarC_Syntax_Syntax.asc = (tc, uu___1, uu___2); + FStarC_Syntax_Syntax.eff_opt = f;_} + -> + let t1 = + match tc with + | FStar_Pervasives.Inl t2 -> term_as_mlty g t2 + | FStar_Pervasives.Inr c -> + let uu___3 = + let uu___4 = FStarC_Extraction_ML_UEnv.tcenv_of_uenv g in + maybe_reify_comp g uu___4 c in + term_as_mlty g uu___3 in + let f1 = + match f with + | FStar_Pervasives_Native.None -> + failwith "Ascription node with an empty effect label" + | FStar_Pervasives_Native.Some l -> effect_as_etag g l in + let uu___3 = check_term_as_mlexpr g e0 f1 t1 in + (match uu___3 with | (e, t2) -> (e, f1, t2)) + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (false, lb::[]); + FStarC_Syntax_Syntax.body1 = e';_} + when + (let uu___1 = FStarC_Syntax_Syntax.is_top_level [lb] in + Prims.op_Negation uu___1) && + (let uu___1 = + FStarC_Syntax_Util.get_attribute + FStarC_Parser_Const.rename_let_attr + lb.FStarC_Syntax_Syntax.lbattrs in + FStarC_Compiler_Util.is_some uu___1) + -> + let b = + let uu___1 = + FStarC_Compiler_Util.left lb.FStarC_Syntax_Syntax.lbname in + FStarC_Syntax_Syntax.mk_binder uu___1 in + let uu___1 = FStarC_Syntax_Subst.open_term_1 b e' in + (match uu___1 with + | ({ FStarC_Syntax_Syntax.binder_bv = x; + FStarC_Syntax_Syntax.binder_qual = uu___2; + FStarC_Syntax_Syntax.binder_positivity = uu___3; + FStarC_Syntax_Syntax.binder_attrs = uu___4;_}, + body) -> + let suggested_name = + let attr = + FStarC_Syntax_Util.get_attribute + FStarC_Parser_Const.rename_let_attr + lb.FStarC_Syntax_Syntax.lbattrs in + match attr with + | FStar_Pervasives_Native.Some ((str, uu___5)::[]) -> + let uu___6 = + let uu___7 = FStarC_Syntax_Subst.compress str in + uu___7.FStarC_Syntax_Syntax.n in + (match uu___6 with + | FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_string (s, uu___7)) when + s <> "" -> + let id = + let uu___8 = + let uu___9 = + FStarC_Syntax_Syntax.range_of_bv x in + (s, uu___9) in + FStarC_Ident.mk_ident uu___8 in + let bv = + { + FStarC_Syntax_Syntax.ppname = id; + FStarC_Syntax_Syntax.index = Prims.int_zero; + FStarC_Syntax_Syntax.sort = + (x.FStarC_Syntax_Syntax.sort) + } in + let bv1 = FStarC_Syntax_Syntax.freshen_bv bv in + FStar_Pervasives_Native.Some bv1 + | uu___7 -> + (FStarC_Errors.log_issue + (FStarC_Syntax_Syntax.has_range_syntax ()) top1 + FStarC_Errors_Codes.Warning_UnrecognizedAttribute + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Ignoring ill-formed application of `rename_let`"); + FStar_Pervasives_Native.None)) + | FStar_Pervasives_Native.Some uu___5 -> + (FStarC_Errors.log_issue + (FStarC_Syntax_Syntax.has_range_syntax ()) top1 + FStarC_Errors_Codes.Warning_UnrecognizedAttribute () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Ignoring ill-formed application of `rename_let`"); + FStar_Pervasives_Native.None) + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None in + let remove_attr attrs = + let uu___5 = + FStarC_Compiler_List.partition + (fun attr -> + let uu___6 = + FStarC_Syntax_Util.get_attribute + FStarC_Parser_Const.rename_let_attr [attr] in + FStarC_Compiler_Util.is_some uu___6) + lb.FStarC_Syntax_Syntax.lbattrs in + match uu___5 with | (uu___6, other_attrs) -> other_attrs in + let maybe_rewritten_let = + match suggested_name with + | FStar_Pervasives_Native.None -> + let other_attrs = + remove_attr lb.FStarC_Syntax_Syntax.lbattrs in + FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = + (false, + [{ + FStarC_Syntax_Syntax.lbname = + (lb.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = + (lb.FStarC_Syntax_Syntax.lbtyp); + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = + (lb.FStarC_Syntax_Syntax.lbdef); + FStarC_Syntax_Syntax.lbattrs = other_attrs; + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + }]); + FStarC_Syntax_Syntax.body1 = e' + } + | FStar_Pervasives_Native.Some y -> + let other_attrs = + remove_attr lb.FStarC_Syntax_Syntax.lbattrs in + let rename = + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Syntax_Syntax.bv_to_name y in + (x, uu___7) in + FStarC_Syntax_Syntax.NT uu___6 in + [uu___5] in + let body1 = + let uu___5 = + let uu___6 = FStarC_Syntax_Syntax.mk_binder y in + [uu___6] in + let uu___6 = FStarC_Syntax_Subst.subst rename body in + FStarC_Syntax_Subst.close uu___5 uu___6 in + let lb1 = + { + FStarC_Syntax_Syntax.lbname = + (FStar_Pervasives.Inl y); + FStarC_Syntax_Syntax.lbunivs = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = + (lb.FStarC_Syntax_Syntax.lbtyp); + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = + (lb.FStarC_Syntax_Syntax.lbdef); + FStarC_Syntax_Syntax.lbattrs = other_attrs; + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + } in + FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = (false, [lb1]); + FStarC_Syntax_Syntax.body1 = body1 + } in + let top2 = + { + FStarC_Syntax_Syntax.n = maybe_rewritten_let; + FStarC_Syntax_Syntax.pos = + (top1.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = + (top1.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (top1.FStarC_Syntax_Syntax.hash_code) + } in + term_as_mlexpr' g top2) + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (is_rec, lbs); + FStarC_Syntax_Syntax.body1 = e';_} + -> + let top_level = FStarC_Syntax_Syntax.is_top_level lbs in + let uu___1 = + if is_rec + then FStarC_Syntax_Subst.open_let_rec lbs e' + else + (let uu___3 = FStarC_Syntax_Syntax.is_top_level lbs in + if uu___3 + then (lbs, e') + else + (let lb = FStarC_Compiler_List.hd lbs in + let x = + let uu___5 = + FStarC_Compiler_Util.left + lb.FStarC_Syntax_Syntax.lbname in + FStarC_Syntax_Syntax.freshen_bv uu___5 in + let lb1 = + { + FStarC_Syntax_Syntax.lbname = (FStar_Pervasives.Inl x); + FStarC_Syntax_Syntax.lbunivs = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = + (lb.FStarC_Syntax_Syntax.lbtyp); + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = + (lb.FStarC_Syntax_Syntax.lbdef); + FStarC_Syntax_Syntax.lbattrs = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + } in + let e'1 = + FStarC_Syntax_Subst.subst + [FStarC_Syntax_Syntax.DB (Prims.int_zero, x)] e' in + ([lb1], e'1))) in + (match uu___1 with + | (lbs1, e'1) -> + let lbs2 = + if top_level + then + let tcenv = + let uu___2 = FStarC_Extraction_ML_UEnv.tcenv_of_uenv g in + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Extraction_ML_UEnv.current_module_of_uenv + g in + FStar_Pervasives_Native.fst uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Extraction_ML_UEnv.current_module_of_uenv + g in + FStar_Pervasives_Native.snd uu___8 in + [uu___7] in + FStarC_Compiler_List.op_At uu___5 uu___6 in + FStarC_Ident.lid_of_path uu___4 + FStarC_Compiler_Range_Type.dummyRange in + FStarC_TypeChecker_Env.set_current_module uu___2 uu___3 in + FStarC_Compiler_List.map + (fun lb -> + let lbdef = + let norm_call uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_TypeChecker_Env.current_module + tcenv in + FStarC_Ident.string_of_lid uu___5 in + FStar_Pervasives_Native.Some uu___4 in + FStarC_Profiling.profile + (fun uu___4 -> + FStarC_TypeChecker_Normalize.normalize + (FStarC_TypeChecker_Env.PureSubtermsWithinComputations + :: FStarC_TypeChecker_Env.Reify :: + extraction_norm_steps) tcenv + lb.FStarC_Syntax_Syntax.lbdef) uu___3 + "FStarC.Extraction.ML.Term.normalize_lb_def" in + let uu___2 = + (FStarC_Compiler_Effect.op_Bang dbg_Extraction) + || + (FStarC_Compiler_Effect.op_Bang + dbg_ExtractionNorm) in + if uu___2 + then + ((let uu___4 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_either + FStarC_Syntax_Print.showable_bv + FStarC_Syntax_Print.showable_fv) + lb.FStarC_Syntax_Syntax.lbname in + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + lb.FStarC_Syntax_Syntax.lbdef in + FStarC_Compiler_Util.print2 + "Starting to normalize top-level let %s = %s\n" + uu___4 uu___5); + (let a = norm_call () in + (let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term a in + FStarC_Compiler_Util.print1 + "Normalized to %s\n" uu___5); + a)) + else norm_call () in + { + FStarC_Syntax_Syntax.lbname = + (lb.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = + (lb.FStarC_Syntax_Syntax.lbtyp); + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = lbdef; + FStarC_Syntax_Syntax.lbattrs = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + }) lbs1 + else lbs1 in + let check_lb env nm_sig = + let uu___2 = nm_sig in + match uu___2 with + | (nm, + (_lbname, f, (_t, (targs, polytype)), add_unit, + has_c_inline, e)) -> + let env1 = + FStarC_Compiler_List.fold_left + (fun env2 -> + fun uu___3 -> + match uu___3 with + | { FStarC_Syntax_Syntax.binder_bv = a; + FStarC_Syntax_Syntax.binder_qual = uu___4; + FStarC_Syntax_Syntax.binder_positivity = + uu___5; + FStarC_Syntax_Syntax.binder_attrs = uu___6;_} + -> + FStarC_Extraction_ML_UEnv.extend_ty env2 a + false) env targs in + let expected_t = FStar_Pervasives_Native.snd polytype in + let uu___3 = check_term_as_mlexpr env1 e f expected_t in + (match uu___3 with + | (e1, ty) -> + let uu___4 = maybe_promote_effect e1 f expected_t in + (match uu___4 with + | (e2, f1) -> + let meta = + match (f1, ty) with + | (FStarC_Extraction_ML_Syntax.E_PURE, + FStarC_Extraction_ML_Syntax.MLTY_Erased) + -> [FStarC_Extraction_ML_Syntax.Erased] + | (FStarC_Extraction_ML_Syntax.E_ERASABLE, + FStarC_Extraction_ML_Syntax.MLTY_Erased) + -> [FStarC_Extraction_ML_Syntax.Erased] + | uu___5 -> [] in + let meta1 = + if has_c_inline + then FStarC_Extraction_ML_Syntax.CInline :: + meta + else meta in + (f1, + { + FStarC_Extraction_ML_Syntax.mllb_name = + nm; + FStarC_Extraction_ML_Syntax.mllb_tysc = + (FStar_Pervasives_Native.Some polytype); + FStarC_Extraction_ML_Syntax.mllb_add_unit + = add_unit; + FStarC_Extraction_ML_Syntax.mllb_def = e2; + FStarC_Extraction_ML_Syntax.mllb_attrs = + []; + FStarC_Extraction_ML_Syntax.mllb_meta = + meta1; + FStarC_Extraction_ML_Syntax.print_typ = + true + }))) in + let lbs3 = extract_lb_sig g (is_rec, lbs2) in + let uu___2 = + FStarC_Compiler_List.fold_right + (fun lb -> + fun uu___3 -> + match uu___3 with + | (env, lbs4, env_burn) -> + let uu___4 = lb in + (match uu___4 with + | (lbname, uu___5, (t1, (uu___6, polytype)), + add_unit, _has_c_inline, uu___7) -> + let uu___8 = + FStarC_Extraction_ML_UEnv.extend_lb env + lbname t1 polytype add_unit in + (match uu___8 with + | (env1, nm, uu___9) -> + let env_burn1 = + let uu___10 = + let uu___11 = + FStarC_Options.codegen () in + uu___11 <> + (FStar_Pervasives_Native.Some + FStarC_Options.Krml) in + if uu___10 + then + FStarC_Extraction_ML_UEnv.burn_name + env_burn nm + else env_burn in + (env1, ((nm, lb) :: lbs4), env_burn1)))) + lbs3 (g, [], g) in + (match uu___2 with + | (env_body, lbs4, env_burn) -> + let env_def = if is_rec then env_body else env_burn in + let lbs5 = + FStarC_Compiler_List.map (check_lb env_def) lbs4 in + let e'_rng = e'1.FStarC_Syntax_Syntax.pos in + let uu___3 = term_as_mlexpr env_body e'1 in + (match uu___3 with + | (e'2, f', t') -> + let f = + let uu___4 = + let uu___5 = + FStarC_Compiler_List.map + FStar_Pervasives_Native.fst lbs5 in + f' :: uu___5 in + FStarC_Extraction_ML_Util.join_l e'_rng uu___4 in + let is_rec1 = + if is_rec = true + then FStarC_Extraction_ML_Syntax.Rec + else FStarC_Extraction_ML_Syntax.NonRec in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Compiler_List.map + FStar_Pervasives_Native.snd lbs5 in + (is_rec1, uu___7) in + mk_MLE_Let top_level uu___6 e'2 in + let uu___6 = + FStarC_Extraction_ML_Util.mlloc_of_range + t.FStarC_Syntax_Syntax.pos in + FStarC_Extraction_ML_Syntax.with_ty_loc t' uu___5 + uu___6 in + (uu___4, f, t')))) + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = scrutinee; + FStarC_Syntax_Syntax.ret_opt = uu___1; + FStarC_Syntax_Syntax.brs = pats; + FStarC_Syntax_Syntax.rc_opt1 = uu___2;_} + -> + let uu___3 = term_as_mlexpr g scrutinee in + (match uu___3 with + | (e, f_e, t_e) -> + let uu___4 = check_pats_for_ite pats in + (match uu___4 with + | (b, then_e, else_e) -> + let no_lift x t1 = x in + if b + then + (match (then_e, else_e) with + | (FStar_Pervasives_Native.Some then_e1, + FStar_Pervasives_Native.Some else_e1) -> + let uu___5 = term_as_mlexpr g then_e1 in + (match uu___5 with + | (then_mle, f_then, t_then) -> + let uu___6 = term_as_mlexpr g else_e1 in + (match uu___6 with + | (else_mle, f_else, t_else) -> + let uu___7 = + let uu___8 = type_leq g t_then t_else in + if uu___8 + then (t_else, no_lift) + else + (let uu___10 = + type_leq g t_else t_then in + if uu___10 + then (t_then, no_lift) + else + (FStarC_Extraction_ML_Syntax.MLTY_Top, + FStarC_Extraction_ML_Syntax.apply_obj_repr)) in + (match uu___7 with + | (t_branch, maybe_lift) -> + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + maybe_lift then_mle t_then in + let uu___12 = + let uu___13 = + maybe_lift else_mle + t_else in + FStar_Pervasives_Native.Some + uu___13 in + (e, uu___11, uu___12) in + FStarC_Extraction_ML_Syntax.MLE_If + uu___10 in + FStarC_Extraction_ML_Syntax.with_ty + t_branch uu___9 in + let uu___9 = + FStarC_Extraction_ML_Util.join + then_e1.FStarC_Syntax_Syntax.pos + f_then f_else in + (uu___8, uu___9, t_branch)))) + | uu___5 -> + failwith + "ITE pats matched but then and else expressions not found?") + else + (let uu___6 = + FStarC_Compiler_Util.fold_map + (fun compat -> + fun br -> + let uu___7 = + FStarC_Syntax_Subst.open_branch br in + match uu___7 with + | (pat, when_opt, branch) -> + let uu___8 = + extract_pat g pat t_e term_as_mlexpr in + (match uu___8 with + | (env, p, pat_t_compat) -> + let uu___9 = + match when_opt with + | FStar_Pervasives_Native.None -> + (FStar_Pervasives_Native.None, + FStarC_Extraction_ML_Syntax.E_PURE) + | FStar_Pervasives_Native.Some w + -> + let w_pos = + w.FStarC_Syntax_Syntax.pos in + let uu___10 = + term_as_mlexpr env w in + (match uu___10 with + | (w1, f_w, t_w) -> + let w2 = + maybe_coerce w_pos env + w1 t_w + FStarC_Extraction_ML_Syntax.ml_bool_ty in + ((FStar_Pervasives_Native.Some + w2), f_w)) in + (match uu___9 with + | (when_opt1, f_when) -> + let uu___10 = + term_as_mlexpr env branch in + (match uu___10 with + | (mlbranch, f_branch, + t_branch) -> + let uu___11 = + FStarC_Compiler_List.map + (fun uu___12 -> + match uu___12 with + | (p1, wopt) -> + let when_clause + = + FStarC_Extraction_ML_Util.conjoin_opt + wopt + when_opt1 in + (p1, + (when_clause, + f_when), + (mlbranch, + f_branch, + t_branch))) + p in + ((compat && pat_t_compat), + uu___11))))) true pats in + match uu___6 with + | (pat_t_compat, mlbranches) -> + let mlbranches1 = + FStarC_Compiler_List.flatten mlbranches in + let e1 = + if pat_t_compat + then e + else + (FStarC_Extraction_ML_UEnv.debug g + (fun uu___9 -> + let uu___10 = + let uu___11 = + FStarC_Extraction_ML_UEnv.current_module_of_uenv + g in + FStarC_Extraction_ML_Code.string_of_mlexpr + uu___11 e in + let uu___11 = + let uu___12 = + FStarC_Extraction_ML_UEnv.current_module_of_uenv + g in + FStarC_Extraction_ML_Code.string_of_mlty + uu___12 t_e in + FStarC_Compiler_Util.print2 + "Coercing scrutinee %s from type %s because pattern type is incompatible\n" + uu___10 uu___11); + FStarC_Extraction_ML_Syntax.with_ty t_e + (FStarC_Extraction_ML_Syntax.MLE_Coerce + (e, t_e, + FStarC_Extraction_ML_Syntax.MLTY_Top))) in + (match mlbranches1 with + | [] -> + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Parser_Const.failwith_lid () in + FStarC_Syntax_Syntax.lid_as_fv uu___9 + FStar_Pervasives_Native.None in + FStarC_Extraction_ML_UEnv.lookup_fv + t.FStarC_Syntax_Syntax.pos g uu___8 in + (match uu___7 with + | { + FStarC_Extraction_ML_UEnv.exp_b_name = + uu___8; + FStarC_Extraction_ML_UEnv.exp_b_expr = + fw; + FStarC_Extraction_ML_UEnv.exp_b_tscheme + = uu___9; + FStarC_Extraction_ML_UEnv.exp_b_eff = + uu___10;_} + -> + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.ml_string_ty + (FStarC_Extraction_ML_Syntax.MLE_Const + (FStarC_Extraction_ML_Syntax.MLC_String + "unreachable")) in + [uu___15] in + (fw, uu___14) in + FStarC_Extraction_ML_Syntax.MLE_App + uu___13 in + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.ml_int_ty + uu___12 in + (uu___11, + FStarC_Extraction_ML_Syntax.E_PURE, + FStarC_Extraction_ML_Syntax.ml_int_ty)) + | (uu___7, uu___8, (uu___9, f_first, t_first))::rest + -> + let uu___10 = + FStarC_Compiler_List.fold_left + (fun uu___11 -> + fun uu___12 -> + match (uu___11, uu___12) with + | ((topt, f), + (uu___13, uu___14, + (uu___15, f_branch, t_branch))) + -> + let f1 = + FStarC_Extraction_ML_Util.join + top1.FStarC_Syntax_Syntax.pos + f f_branch in + let topt1 = + match topt with + | FStar_Pervasives_Native.None + -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some + t1 -> + let uu___16 = + type_leq g t1 t_branch in + if uu___16 + then + FStar_Pervasives_Native.Some + t_branch + else + (let uu___18 = + type_leq g t_branch + t1 in + if uu___18 + then + FStar_Pervasives_Native.Some + t1 + else + FStar_Pervasives_Native.None) in + (topt1, f1)) + ((FStar_Pervasives_Native.Some t_first), + f_first) rest in + (match uu___10 with + | (topt, f_match) -> + let mlbranches2 = + FStarC_Compiler_List.map + (fun uu___11 -> + match uu___11 with + | (p, (wopt, uu___12), + (b1, uu___13, t1)) -> + let b2 = + match topt with + | FStar_Pervasives_Native.None + -> + FStarC_Extraction_ML_Syntax.apply_obj_repr + b1 t1 + | FStar_Pervasives_Native.Some + uu___14 -> b1 in + (p, wopt, b2)) mlbranches1 in + let t_match = + match topt with + | FStar_Pervasives_Native.None -> + FStarC_Extraction_ML_Syntax.MLTY_Top + | FStar_Pervasives_Native.Some t1 -> + t1 in + let uu___11 = + FStarC_Extraction_ML_Syntax.with_ty + t_match + (FStarC_Extraction_ML_Syntax.MLE_Match + (e1, mlbranches2)) in + (uu___11, f_match, t_match))))))) +let (ind_discriminator_body : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Ident.lident -> + FStarC_Ident.lident -> FStarC_Extraction_ML_Syntax.mlmodule1) + = + fun env -> + fun discName -> + fun constrName -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Extraction_ML_UEnv.tcenv_of_uenv env in + FStarC_TypeChecker_Env.lookup_lid uu___2 discName in + FStar_Pervasives_Native.fst uu___1 in + match uu___ with + | (uu___1, fstar_disc_type) -> + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.compress fstar_disc_type in + uu___4.FStarC_Syntax_Syntax.n in + match uu___3 with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = binders; + FStarC_Syntax_Syntax.comp = uu___4;_} + -> + let binders1 = + FStarC_Compiler_List.filter + (fun uu___5 -> + match uu___5 with + | { FStarC_Syntax_Syntax.binder_bv = uu___6; + FStarC_Syntax_Syntax.binder_qual = + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Implicit uu___7); + FStarC_Syntax_Syntax.binder_positivity = uu___8; + FStarC_Syntax_Syntax.binder_attrs = uu___9;_} -> + true + | uu___6 -> false) binders in + FStarC_Compiler_List.fold_right + (fun uu___5 -> + fun uu___6 -> + match uu___6 with + | (g, vs) -> + let uu___7 = + FStarC_Extraction_ML_UEnv.new_mlident g in + (match uu___7 with + | (g1, v) -> + (g1, + ((v, + FStarC_Extraction_ML_Syntax.MLTY_Top) + :: vs)))) binders1 (env, []) + | uu___4 -> failwith "Discriminator must be a function" in + (match uu___2 with + | (g, wildcards) -> + let uu___3 = FStarC_Extraction_ML_UEnv.new_mlident g in + (match uu___3 with + | (g1, mlid) -> + let targ = FStarC_Extraction_ML_Syntax.MLTY_Top in + let disc_ty = FStarC_Extraction_ML_Syntax.MLTY_Top in + let discrBody = + let bs = + FStarC_Compiler_List.map + (fun uu___4 -> + match uu___4 with + | (x, t) -> + { + FStarC_Extraction_ML_Syntax.mlbinder_name + = x; + FStarC_Extraction_ML_Syntax.mlbinder_ty + = t; + FStarC_Extraction_ML_Syntax.mlbinder_attrs + = [] + }) + (FStarC_Compiler_List.op_At wildcards + [(mlid, targ)]) in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Extraction_ML_Syntax.with_ty targ + (FStarC_Extraction_ML_Syntax.MLE_Name + ([], mlid)) in + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_Extraction_ML_UEnv.mlpath_of_lident + g1 constrName in + (uu___14, + [FStarC_Extraction_ML_Syntax.MLP_Wild]) in + FStarC_Extraction_ML_Syntax.MLP_CTor + uu___13 in + let uu___13 = + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.ml_bool_ty + (FStarC_Extraction_ML_Syntax.MLE_Const + (FStarC_Extraction_ML_Syntax.MLC_Bool + true)) in + (uu___12, FStar_Pervasives_Native.None, + uu___13) in + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.ml_bool_ty + (FStarC_Extraction_ML_Syntax.MLE_Const + (FStarC_Extraction_ML_Syntax.MLC_Bool + false)) in + (FStarC_Extraction_ML_Syntax.MLP_Wild, + FStar_Pervasives_Native.None, + uu___14) in + [uu___13] in + uu___11 :: uu___12 in + (uu___9, uu___10) in + FStarC_Extraction_ML_Syntax.MLE_Match uu___8 in + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.ml_bool_ty uu___7 in + (bs, uu___6) in + FStarC_Extraction_ML_Syntax.MLE_Fun uu___5 in + FStarC_Extraction_ML_Syntax.with_ty disc_ty uu___4 in + let uu___4 = + FStarC_Extraction_ML_UEnv.mlpath_of_lident env + discName in + (match uu___4 with + | (uu___5, name) -> + FStarC_Extraction_ML_Syntax.mk_mlmodule1 + (FStarC_Extraction_ML_Syntax.MLM_Let + (FStarC_Extraction_ML_Syntax.NonRec, + [{ + FStarC_Extraction_ML_Syntax.mllb_name = + name; + FStarC_Extraction_ML_Syntax.mllb_tysc = + FStar_Pervasives_Native.None; + FStarC_Extraction_ML_Syntax.mllb_add_unit + = false; + FStarC_Extraction_ML_Syntax.mllb_def = + discrBody; + FStarC_Extraction_ML_Syntax.mllb_attrs = + []; + FStarC_Extraction_ML_Syntax.mllb_meta = + []; + FStarC_Extraction_ML_Syntax.print_typ = + false + }]))))) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Extraction_ML_UEnv.ml b/ocaml/fstar-lib/generated/FStarC_Extraction_ML_UEnv.ml new file mode 100644 index 00000000000..b4a1184f365 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Extraction_ML_UEnv.ml @@ -0,0 +1,1219 @@ +open Prims +type ty_binding = + { + ty_b_name: FStarC_Extraction_ML_Syntax.mlident ; + ty_b_ty: FStarC_Extraction_ML_Syntax.mlty } +let (__proj__Mkty_binding__item__ty_b_name : + ty_binding -> FStarC_Extraction_ML_Syntax.mlident) = + fun projectee -> + match projectee with | { ty_b_name; ty_b_ty;_} -> ty_b_name +let (__proj__Mkty_binding__item__ty_b_ty : + ty_binding -> FStarC_Extraction_ML_Syntax.mlty) = + fun projectee -> match projectee with | { ty_b_name; ty_b_ty;_} -> ty_b_ty +type exp_binding = + { + exp_b_name: FStarC_Extraction_ML_Syntax.mlident ; + exp_b_expr: FStarC_Extraction_ML_Syntax.mlexpr ; + exp_b_tscheme: FStarC_Extraction_ML_Syntax.mltyscheme ; + exp_b_eff: FStarC_Extraction_ML_Syntax.e_tag } +let (__proj__Mkexp_binding__item__exp_b_name : + exp_binding -> FStarC_Extraction_ML_Syntax.mlident) = + fun projectee -> + match projectee with + | { exp_b_name; exp_b_expr; exp_b_tscheme; exp_b_eff;_} -> exp_b_name +let (__proj__Mkexp_binding__item__exp_b_expr : + exp_binding -> FStarC_Extraction_ML_Syntax.mlexpr) = + fun projectee -> + match projectee with + | { exp_b_name; exp_b_expr; exp_b_tscheme; exp_b_eff;_} -> exp_b_expr +let (__proj__Mkexp_binding__item__exp_b_tscheme : + exp_binding -> FStarC_Extraction_ML_Syntax.mltyscheme) = + fun projectee -> + match projectee with + | { exp_b_name; exp_b_expr; exp_b_tscheme; exp_b_eff;_} -> exp_b_tscheme +let (__proj__Mkexp_binding__item__exp_b_eff : + exp_binding -> FStarC_Extraction_ML_Syntax.e_tag) = + fun projectee -> + match projectee with + | { exp_b_name; exp_b_expr; exp_b_tscheme; exp_b_eff;_} -> exp_b_eff +type ty_or_exp_b = (ty_binding, exp_binding) FStar_Pervasives.either +type binding = + | Bv of (FStarC_Syntax_Syntax.bv * ty_or_exp_b) + | Fv of (FStarC_Syntax_Syntax.fv * exp_binding) + | ErasedFv of FStarC_Syntax_Syntax.fv +let (uu___is_Bv : binding -> Prims.bool) = + fun projectee -> match projectee with | Bv _0 -> true | uu___ -> false +let (__proj__Bv__item___0 : + binding -> (FStarC_Syntax_Syntax.bv * ty_or_exp_b)) = + fun projectee -> match projectee with | Bv _0 -> _0 +let (uu___is_Fv : binding -> Prims.bool) = + fun projectee -> match projectee with | Fv _0 -> true | uu___ -> false +let (__proj__Fv__item___0 : + binding -> (FStarC_Syntax_Syntax.fv * exp_binding)) = + fun projectee -> match projectee with | Fv _0 -> _0 +let (uu___is_ErasedFv : binding -> Prims.bool) = + fun projectee -> + match projectee with | ErasedFv _0 -> true | uu___ -> false +let (__proj__ErasedFv__item___0 : binding -> FStarC_Syntax_Syntax.fv) = + fun projectee -> match projectee with | ErasedFv _0 -> _0 +type tydef = + { + tydef_fv: FStarC_Syntax_Syntax.fv ; + tydef_mlmodule_name: FStarC_Extraction_ML_Syntax.mlsymbol Prims.list ; + tydef_name: FStarC_Extraction_ML_Syntax.mlsymbol ; + tydef_meta: FStarC_Extraction_ML_Syntax.metadata ; + tydef_def: FStarC_Extraction_ML_Syntax.mltyscheme } +let (__proj__Mktydef__item__tydef_fv : tydef -> FStarC_Syntax_Syntax.fv) = + fun projectee -> + match projectee with + | { tydef_fv; tydef_mlmodule_name; tydef_name; tydef_meta; tydef_def;_} + -> tydef_fv +let (__proj__Mktydef__item__tydef_mlmodule_name : + tydef -> FStarC_Extraction_ML_Syntax.mlsymbol Prims.list) = + fun projectee -> + match projectee with + | { tydef_fv; tydef_mlmodule_name; tydef_name; tydef_meta; tydef_def;_} + -> tydef_mlmodule_name +let (__proj__Mktydef__item__tydef_name : + tydef -> FStarC_Extraction_ML_Syntax.mlsymbol) = + fun projectee -> + match projectee with + | { tydef_fv; tydef_mlmodule_name; tydef_name; tydef_meta; tydef_def;_} + -> tydef_name +let (__proj__Mktydef__item__tydef_meta : + tydef -> FStarC_Extraction_ML_Syntax.metadata) = + fun projectee -> + match projectee with + | { tydef_fv; tydef_mlmodule_name; tydef_name; tydef_meta; tydef_def;_} + -> tydef_meta +let (__proj__Mktydef__item__tydef_def : + tydef -> FStarC_Extraction_ML_Syntax.mltyscheme) = + fun projectee -> + match projectee with + | { tydef_fv; tydef_mlmodule_name; tydef_name; tydef_meta; tydef_def;_} + -> tydef_def +let (tydef_fv : tydef -> FStarC_Syntax_Syntax.fv) = fun td -> td.tydef_fv +let (tydef_meta : tydef -> FStarC_Extraction_ML_Syntax.metadata) = + fun td -> td.tydef_meta +let (tydef_def : tydef -> FStarC_Extraction_ML_Syntax.mltyscheme) = + fun td -> td.tydef_def +let (tydef_mlpath : tydef -> FStarC_Extraction_ML_Syntax.mlpath) = + fun td -> ((td.tydef_mlmodule_name), (td.tydef_name)) +type uenv = + { + env_tcenv: FStarC_TypeChecker_Env.env ; + env_bindings: binding Prims.list ; + env_mlident_map: + FStarC_Extraction_ML_Syntax.mlident FStarC_Compiler_Util.psmap ; + env_remove_typars: FStarC_Extraction_ML_RemoveUnusedParameters.env_t ; + mlpath_of_lid: + FStarC_Extraction_ML_Syntax.mlpath FStarC_Compiler_Util.psmap ; + env_fieldname_map: + FStarC_Extraction_ML_Syntax.mlident FStarC_Compiler_Util.psmap ; + mlpath_of_fieldname: + FStarC_Extraction_ML_Syntax.mlpath FStarC_Compiler_Util.psmap ; + tydefs: tydef Prims.list ; + type_names: + (FStarC_Syntax_Syntax.fv * FStarC_Extraction_ML_Syntax.mlpath) Prims.list ; + tydef_declarations: Prims.bool FStarC_Compiler_Util.psmap ; + currentModule: FStarC_Extraction_ML_Syntax.mlpath } +let (__proj__Mkuenv__item__env_tcenv : uenv -> FStarC_TypeChecker_Env.env) = + fun projectee -> + match projectee with + | { env_tcenv; env_bindings; env_mlident_map; env_remove_typars; + mlpath_of_lid; env_fieldname_map; mlpath_of_fieldname; tydefs; + type_names; tydef_declarations; currentModule;_} -> env_tcenv +let (__proj__Mkuenv__item__env_bindings : uenv -> binding Prims.list) = + fun projectee -> + match projectee with + | { env_tcenv; env_bindings; env_mlident_map; env_remove_typars; + mlpath_of_lid; env_fieldname_map; mlpath_of_fieldname; tydefs; + type_names; tydef_declarations; currentModule;_} -> env_bindings +let (__proj__Mkuenv__item__env_mlident_map : + uenv -> FStarC_Extraction_ML_Syntax.mlident FStarC_Compiler_Util.psmap) = + fun projectee -> + match projectee with + | { env_tcenv; env_bindings; env_mlident_map; env_remove_typars; + mlpath_of_lid; env_fieldname_map; mlpath_of_fieldname; tydefs; + type_names; tydef_declarations; currentModule;_} -> env_mlident_map +let (__proj__Mkuenv__item__env_remove_typars : + uenv -> FStarC_Extraction_ML_RemoveUnusedParameters.env_t) = + fun projectee -> + match projectee with + | { env_tcenv; env_bindings; env_mlident_map; env_remove_typars; + mlpath_of_lid; env_fieldname_map; mlpath_of_fieldname; tydefs; + type_names; tydef_declarations; currentModule;_} -> env_remove_typars +let (__proj__Mkuenv__item__mlpath_of_lid : + uenv -> FStarC_Extraction_ML_Syntax.mlpath FStarC_Compiler_Util.psmap) = + fun projectee -> + match projectee with + | { env_tcenv; env_bindings; env_mlident_map; env_remove_typars; + mlpath_of_lid; env_fieldname_map; mlpath_of_fieldname; tydefs; + type_names; tydef_declarations; currentModule;_} -> mlpath_of_lid +let (__proj__Mkuenv__item__env_fieldname_map : + uenv -> FStarC_Extraction_ML_Syntax.mlident FStarC_Compiler_Util.psmap) = + fun projectee -> + match projectee with + | { env_tcenv; env_bindings; env_mlident_map; env_remove_typars; + mlpath_of_lid; env_fieldname_map; mlpath_of_fieldname; tydefs; + type_names; tydef_declarations; currentModule;_} -> env_fieldname_map +let (__proj__Mkuenv__item__mlpath_of_fieldname : + uenv -> FStarC_Extraction_ML_Syntax.mlpath FStarC_Compiler_Util.psmap) = + fun projectee -> + match projectee with + | { env_tcenv; env_bindings; env_mlident_map; env_remove_typars; + mlpath_of_lid; env_fieldname_map; mlpath_of_fieldname; tydefs; + type_names; tydef_declarations; currentModule;_} -> + mlpath_of_fieldname +let (__proj__Mkuenv__item__tydefs : uenv -> tydef Prims.list) = + fun projectee -> + match projectee with + | { env_tcenv; env_bindings; env_mlident_map; env_remove_typars; + mlpath_of_lid; env_fieldname_map; mlpath_of_fieldname; tydefs; + type_names; tydef_declarations; currentModule;_} -> tydefs +let (__proj__Mkuenv__item__type_names : + uenv -> + (FStarC_Syntax_Syntax.fv * FStarC_Extraction_ML_Syntax.mlpath) Prims.list) + = + fun projectee -> + match projectee with + | { env_tcenv; env_bindings; env_mlident_map; env_remove_typars; + mlpath_of_lid; env_fieldname_map; mlpath_of_fieldname; tydefs; + type_names; tydef_declarations; currentModule;_} -> type_names +let (__proj__Mkuenv__item__tydef_declarations : + uenv -> Prims.bool FStarC_Compiler_Util.psmap) = + fun projectee -> + match projectee with + | { env_tcenv; env_bindings; env_mlident_map; env_remove_typars; + mlpath_of_lid; env_fieldname_map; mlpath_of_fieldname; tydefs; + type_names; tydef_declarations; currentModule;_} -> + tydef_declarations +let (__proj__Mkuenv__item__currentModule : + uenv -> FStarC_Extraction_ML_Syntax.mlpath) = + fun projectee -> + match projectee with + | { env_tcenv; env_bindings; env_mlident_map; env_remove_typars; + mlpath_of_lid; env_fieldname_map; mlpath_of_fieldname; tydefs; + type_names; tydef_declarations; currentModule;_} -> currentModule +let (tcenv_of_uenv : uenv -> FStarC_TypeChecker_Env.env) = + fun u -> u.env_tcenv +let (set_tcenv : uenv -> FStarC_TypeChecker_Env.env -> uenv) = + fun u -> + fun t -> + { + env_tcenv = t; + env_bindings = (u.env_bindings); + env_mlident_map = (u.env_mlident_map); + env_remove_typars = (u.env_remove_typars); + mlpath_of_lid = (u.mlpath_of_lid); + env_fieldname_map = (u.env_fieldname_map); + mlpath_of_fieldname = (u.mlpath_of_fieldname); + tydefs = (u.tydefs); + type_names = (u.type_names); + tydef_declarations = (u.tydef_declarations); + currentModule = (u.currentModule) + } +let (current_module_of_uenv : uenv -> FStarC_Extraction_ML_Syntax.mlpath) = + fun u -> u.currentModule +let (set_current_module : uenv -> FStarC_Extraction_ML_Syntax.mlpath -> uenv) + = + fun u -> + fun m -> + { + env_tcenv = (u.env_tcenv); + env_bindings = (u.env_bindings); + env_mlident_map = (u.env_mlident_map); + env_remove_typars = (u.env_remove_typars); + mlpath_of_lid = (u.mlpath_of_lid); + env_fieldname_map = (u.env_fieldname_map); + mlpath_of_fieldname = (u.mlpath_of_fieldname); + tydefs = (u.tydefs); + type_names = (u.type_names); + tydef_declarations = (u.tydef_declarations); + currentModule = m + } +let with_typars_env : + 'a . + uenv -> + (FStarC_Extraction_ML_RemoveUnusedParameters.env_t -> + (FStarC_Extraction_ML_RemoveUnusedParameters.env_t * 'a)) + -> (uenv * 'a) + = + fun u -> + fun f -> + let uu___ = f u.env_remove_typars in + match uu___ with + | (e, x) -> + ({ + env_tcenv = (u.env_tcenv); + env_bindings = (u.env_bindings); + env_mlident_map = (u.env_mlident_map); + env_remove_typars = e; + mlpath_of_lid = (u.mlpath_of_lid); + env_fieldname_map = (u.env_fieldname_map); + mlpath_of_fieldname = (u.mlpath_of_fieldname); + tydefs = (u.tydefs); + type_names = (u.type_names); + tydef_declarations = (u.tydef_declarations); + currentModule = (u.currentModule) + }, x) +let (bindings_of_uenv : uenv -> binding Prims.list) = fun u -> u.env_bindings +let (dbg : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Extraction" +let (debug : uenv -> (unit -> unit) -> unit) = + fun g -> + fun f -> + let c = FStarC_Extraction_ML_Syntax.string_of_mlpath g.currentModule in + let uu___ = FStarC_Compiler_Effect.op_Bang dbg in + if uu___ then f () else () +let (print_mlpath_map : uenv -> Prims.string) = + fun g -> + let string_of_mlpath mlp = + Prims.strcat + (FStarC_Compiler_String.concat "." (FStar_Pervasives_Native.fst mlp)) + (Prims.strcat "." (FStar_Pervasives_Native.snd mlp)) in + let entries = + FStarC_Compiler_Util.psmap_fold g.mlpath_of_lid + (fun key -> + fun value -> + fun entries1 -> + let uu___ = + FStarC_Compiler_Util.format2 "%s -> %s" key + (string_of_mlpath value) in + uu___ :: entries1) [] in + FStarC_Compiler_String.concat "\n" entries +let (lookup_fv_generic : + uenv -> + FStarC_Syntax_Syntax.fv -> + (Prims.bool, exp_binding) FStar_Pervasives.either) + = + fun g -> + fun fv -> + let v = + FStarC_Compiler_Util.find_map g.env_bindings + (fun uu___ -> + match uu___ with + | Fv (fv', t) when FStarC_Syntax_Syntax.fv_eq fv fv' -> + FStar_Pervasives_Native.Some (FStar_Pervasives.Inr t) + | ErasedFv fv' when FStarC_Syntax_Syntax.fv_eq fv fv' -> + FStar_Pervasives_Native.Some (FStar_Pervasives.Inl true) + | uu___1 -> FStar_Pervasives_Native.None) in + match v with + | FStar_Pervasives_Native.Some r -> r + | FStar_Pervasives_Native.None -> FStar_Pervasives.Inl false +let (try_lookup_fv : + FStarC_Compiler_Range_Type.range -> + uenv -> + FStarC_Syntax_Syntax.fv -> exp_binding FStar_Pervasives_Native.option) + = + fun r -> + fun g -> + fun fv -> + let uu___ = lookup_fv_generic g fv in + match uu___ with + | FStar_Pervasives.Inr r1 -> FStar_Pervasives_Native.Some r1 + | FStar_Pervasives.Inl (true) -> + ((let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_fv + fv in + FStarC_Compiler_Util.format1 + "Will not extract reference to variable `%s` since it has the `noextract` qualifier." + uu___5 in + FStarC_Errors_Msg.text uu___4 in + let uu___4 = + let uu___5 = + FStarC_Errors_Msg.text + "Either remove its qualifier or add it to this definition." in + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Compiler_Util.string_of_int + FStarC_Errors.call_to_erased_errno in + FStarC_Compiler_Util.format1 + "This error can be ignored with `--warn_error -%s`." + uu___9 in + FStarC_Errors_Msg.text uu___8 in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + FStarC_Errors.log_issue FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Error_CallToErased () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) + | FStar_Pervasives.Inl (false) -> FStar_Pervasives_Native.None +let (lookup_fv : + FStarC_Compiler_Range_Type.range -> + uenv -> FStarC_Syntax_Syntax.fv -> exp_binding) + = + fun r -> + fun g -> + fun fv -> + let uu___ = lookup_fv_generic g fv in + match uu___ with + | FStar_Pervasives.Inr t -> t + | FStar_Pervasives.Inl b -> + let uu___1 = + let uu___2 = + FStarC_Compiler_Range_Ops.string_of_range + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.p in + let uu___3 = + FStarC_Class_Show.show FStarC_Ident.showable_lident + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + let uu___4 = FStarC_Compiler_Util.string_of_bool b in + FStarC_Compiler_Util.format3 + "Internal error: (%s) free variable %s not found during extraction (erased=%s)\n" + uu___2 uu___3 uu___4 in + failwith uu___1 +let (lookup_bv : uenv -> FStarC_Syntax_Syntax.bv -> ty_or_exp_b) = + fun g -> + fun bv -> + let x = + FStarC_Compiler_Util.find_map g.env_bindings + (fun uu___ -> + match uu___ with + | Bv (bv', r) when FStarC_Syntax_Syntax.bv_eq bv bv' -> + FStar_Pervasives_Native.Some r + | uu___1 -> FStar_Pervasives_Native.None) in + match x with + | FStar_Pervasives_Native.None -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Ident.range_of_id bv.FStarC_Syntax_Syntax.ppname in + FStarC_Compiler_Range_Ops.string_of_range uu___2 in + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_bv bv in + FStarC_Compiler_Util.format2 "(%s) bound Variable %s not found\n" + uu___1 uu___2 in + failwith uu___ + | FStar_Pervasives_Native.Some y -> y +let (lookup_term : + uenv -> + FStarC_Syntax_Syntax.term -> + (ty_or_exp_b * FStarC_Syntax_Syntax.fv_qual + FStar_Pervasives_Native.option)) + = + fun g -> + fun t -> + match t.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_name x -> + let uu___ = lookup_bv g x in (uu___, FStar_Pervasives_Native.None) + | FStarC_Syntax_Syntax.Tm_fvar x -> + let uu___ = + let uu___1 = lookup_fv t.FStarC_Syntax_Syntax.pos g x in + FStar_Pervasives.Inr uu___1 in + (uu___, (x.FStarC_Syntax_Syntax.fv_qual)) + | uu___ -> failwith "Impossible: lookup_term for a non-name" +let (lookup_ty : uenv -> FStarC_Syntax_Syntax.bv -> ty_binding) = + fun g -> + fun x -> + let uu___ = lookup_bv g x in + match uu___ with + | FStar_Pervasives.Inl ty -> ty + | uu___1 -> failwith "Expected a type name" +let (lookup_tydef : + uenv -> + FStarC_Extraction_ML_Syntax.mlpath -> + FStarC_Extraction_ML_Syntax.mltyscheme FStar_Pervasives_Native.option) + = + fun env -> + fun uu___ -> + match uu___ with + | (module_name, ty_name) -> + FStarC_Compiler_Util.find_map env.tydefs + (fun tydef1 -> + if + (ty_name = tydef1.tydef_name) && + (module_name = tydef1.tydef_mlmodule_name) + then FStar_Pervasives_Native.Some (tydef1.tydef_def) + else FStar_Pervasives_Native.None) +let (has_tydef_declaration : uenv -> FStarC_Ident.lident -> Prims.bool) = + fun u -> + fun l -> + let uu___ = + let uu___1 = FStarC_Ident.string_of_lid l in + FStarC_Compiler_Util.psmap_try_find u.tydef_declarations uu___1 in + match uu___ with + | FStar_Pervasives_Native.None -> false + | FStar_Pervasives_Native.Some b -> b +let (mlpath_of_lident : + uenv -> FStarC_Ident.lident -> FStarC_Extraction_ML_Syntax.mlpath) = + fun g -> + fun x -> + let uu___ = + let uu___1 = FStarC_Ident.string_of_lid x in + FStarC_Compiler_Util.psmap_try_find g.mlpath_of_lid uu___1 in + match uu___ with + | FStar_Pervasives_Native.None -> + (debug g + (fun uu___2 -> + (let uu___4 = FStarC_Ident.string_of_lid x in + FStarC_Compiler_Util.print1 "Identifier not found: %s" + uu___4); + (let uu___4 = print_mlpath_map g in + FStarC_Compiler_Util.print1 "Env is \n%s\n" uu___4)); + (let uu___2 = + let uu___3 = FStarC_Ident.string_of_lid x in + Prims.strcat "Identifier not found: " uu___3 in + failwith uu___2)) + | FStar_Pervasives_Native.Some mlp -> mlp +let (is_type_name : uenv -> FStarC_Syntax_Syntax.fv -> Prims.bool) = + fun g -> + fun fv -> + FStarC_Compiler_Util.for_some + (fun uu___ -> + match uu___ with | (x, uu___1) -> FStarC_Syntax_Syntax.fv_eq fv x) + g.type_names +let (is_fv_type : uenv -> FStarC_Syntax_Syntax.fv -> Prims.bool) = + fun g -> + fun fv -> + (is_type_name g fv) || + (FStarC_Compiler_Util.for_some + (fun tydef1 -> FStarC_Syntax_Syntax.fv_eq fv tydef1.tydef_fv) + g.tydefs) +let (no_fstar_stubs_ns : + FStarC_Extraction_ML_Syntax.mlsymbol Prims.list -> + FStarC_Extraction_ML_Syntax.mlsymbol Prims.list) + = + fun ns -> + let pl = + let uu___ = FStarC_Options.codegen () in + uu___ = (FStar_Pervasives_Native.Some FStarC_Options.Plugin) in + match ns with + | "Prims"::[] when pl -> ["Prims"] + | "FStar"::"Stubs"::rest when pl -> "FStarC" :: rest + | "FStar"::"Stubs"::rest -> "FStar" :: rest + | uu___ -> ns +let (no_fstar_stubs : + FStarC_Extraction_ML_Syntax.mlpath -> FStarC_Extraction_ML_Syntax.mlpath) = + fun p -> + let uu___ = p in + match uu___ with + | (ns, id) -> let ns1 = no_fstar_stubs_ns ns in (ns1, id) +let (lookup_record_field_name : + uenv -> + (FStarC_Ident.lident * FStarC_Ident.ident) -> + FStarC_Extraction_ML_Syntax.mlpath) + = + fun g -> + fun uu___ -> + match uu___ with + | (type_name, fn) -> + let key = + let uu___1 = + let uu___2 = FStarC_Ident.ids_of_lid type_name in + FStarC_Compiler_List.op_At uu___2 [fn] in + FStarC_Ident.lid_of_ids uu___1 in + let uu___1 = + let uu___2 = FStarC_Ident.string_of_lid key in + FStarC_Compiler_Util.psmap_try_find g.mlpath_of_fieldname uu___2 in + (match uu___1 with + | FStar_Pervasives_Native.None -> + let uu___2 = + let uu___3 = FStarC_Ident.string_of_lid key in + Prims.strcat "Field name not found: " uu___3 in + failwith uu___2 + | FStar_Pervasives_Native.Some mlp -> + let uu___2 = mlp in + (match uu___2 with + | (ns, id) -> + let uu___3 = + let uu___4 = FStarC_Options.codegen () in + uu___4 = + (FStar_Pervasives_Native.Some FStarC_Options.Plugin) in + if uu___3 + then + let uu___4 = + FStarC_Compiler_List.filter (fun s -> s <> "Stubs") + ns in + (uu___4, id) + else (ns, id))) +let (initial_mlident_map : unit -> Prims.string FStarC_Compiler_Util.psmap) = + let map = FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None in + fun uu___ -> + let uu___1 = FStarC_Compiler_Effect.op_Bang map in + match uu___1 with + | FStar_Pervasives_Native.Some m -> m + | FStar_Pervasives_Native.None -> + let m = + let uu___2 = + let uu___3 = FStarC_Options.codegen () in + match uu___3 with + | FStar_Pervasives_Native.Some (FStarC_Options.FSharp) -> + FStarC_Extraction_ML_Syntax.fsharpkeywords + | FStar_Pervasives_Native.Some (FStarC_Options.OCaml) -> + FStarC_Extraction_ML_Syntax.ocamlkeywords + | FStar_Pervasives_Native.Some (FStarC_Options.Plugin) -> + FStarC_Extraction_ML_Syntax.ocamlkeywords + | FStar_Pervasives_Native.Some (FStarC_Options.Krml) -> + FStarC_Extraction_ML_Syntax.krml_keywords + | FStar_Pervasives_Native.Some (FStarC_Options.Extension) -> [] + | FStar_Pervasives_Native.None -> [] in + let uu___3 = FStarC_Compiler_Util.psmap_empty () in + FStarC_Compiler_List.fold_right + (fun x -> fun m1 -> FStarC_Compiler_Util.psmap_add m1 x "") + uu___2 uu___3 in + (FStarC_Compiler_Effect.op_Colon_Equals map + (FStar_Pervasives_Native.Some m); + m) +let (rename_conventional : Prims.string -> Prims.bool -> Prims.string) = + fun s -> + fun is_local_type_variable -> + let cs = FStar_String.list_of_string s in + let sanitize_typ uu___ = + let valid_rest c = FStarC_Compiler_Util.is_letter_or_digit c in + let aux cs1 = + FStarC_Compiler_List.map + (fun x -> let uu___1 = valid_rest x in if uu___1 then x else 117) + cs1 in + let uu___1 = let uu___2 = FStarC_Compiler_List.hd cs in uu___2 = 39 in + if uu___1 + then + let uu___2 = FStarC_Compiler_List.hd cs in + let uu___3 = + let uu___4 = FStarC_Compiler_List.tail cs in aux uu___4 in + uu___2 :: uu___3 + else (let uu___3 = aux cs in 39 :: uu___3) in + let sanitize_term uu___ = + let valid c = + ((FStarC_Compiler_Util.is_letter_or_digit c) || (c = 95)) || + (c = 39) in + let cs' = + FStarC_Compiler_List.fold_right + (fun c -> + fun cs1 -> + let uu___1 = + let uu___2 = valid c in if uu___2 then [c] else [95; 95] in + FStarC_Compiler_List.op_At uu___1 cs1) cs [] in + match cs' with + | c::cs1 when (FStarC_Compiler_Util.is_digit c) || (c = 39) -> 95 :: + c :: cs1 + | uu___1 -> cs in + let uu___ = + if is_local_type_variable then sanitize_typ () else sanitize_term () in + FStar_String.string_of_list uu___ +let (root_name_of_bv : + FStarC_Syntax_Syntax.bv -> FStarC_Extraction_ML_Syntax.mlident) = + fun x -> + let uu___ = + (let uu___1 = FStarC_Ident.string_of_id x.FStarC_Syntax_Syntax.ppname in + FStarC_Compiler_Util.starts_with uu___1 FStarC_Ident.reserved_prefix) + || (FStarC_Syntax_Syntax.is_null_bv x) in + if uu___ + then FStarC_Ident.reserved_prefix + else FStarC_Ident.string_of_id x.FStarC_Syntax_Syntax.ppname +let (find_uniq : + Prims.string FStarC_Compiler_Util.psmap -> + Prims.string -> + Prims.bool -> (Prims.string * Prims.string FStarC_Compiler_Util.psmap)) + = + fun ml_ident_map -> + fun root_name -> + fun is_local_type_variable -> + let rec aux i root_name1 = + let target_mlident = + if i = Prims.int_zero + then root_name1 + else + (let uu___1 = FStarC_Compiler_Util.string_of_int i in + Prims.strcat root_name1 uu___1) in + let uu___ = + FStarC_Compiler_Util.psmap_try_find ml_ident_map target_mlident in + match uu___ with + | FStar_Pervasives_Native.Some x -> + aux (i + Prims.int_one) root_name1 + | FStar_Pervasives_Native.None -> + let map = + FStarC_Compiler_Util.psmap_add ml_ident_map target_mlident "" in + (target_mlident, map) in + let mlident = rename_conventional root_name is_local_type_variable in + if is_local_type_variable + then + let uu___ = + let uu___1 = + FStarC_Compiler_Util.substring_from mlident Prims.int_one in + aux Prims.int_zero uu___1 in + match uu___ with | (nm, map) -> ((Prims.strcat "'" nm), map) + else aux Prims.int_zero mlident +let (mlns_of_lid : + FStarC_Ident.lident -> FStarC_Extraction_ML_Syntax.mlsymbol Prims.list) = + fun x -> + let uu___ = + let uu___1 = FStarC_Ident.ns_of_lid x in + FStarC_Compiler_List.map FStarC_Ident.string_of_id uu___1 in + no_fstar_stubs_ns uu___ +let (new_mlpath_of_lident : + uenv -> FStarC_Ident.lident -> (FStarC_Extraction_ML_Syntax.mlpath * uenv)) + = + fun g -> + fun x -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Parser_Const.failwith_lid () in + FStarC_Ident.lid_equals x uu___2 in + if uu___1 + then + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Ident.ident_of_lid x in + FStarC_Ident.string_of_id uu___4 in + ([], uu___3) in + (uu___2, g) + else + (let uu___3 = + let uu___4 = + let uu___5 = FStarC_Ident.ident_of_lid x in + FStarC_Ident.string_of_id uu___5 in + find_uniq g.env_mlident_map uu___4 false in + match uu___3 with + | (name, map) -> + let g1 = + { + env_tcenv = (g.env_tcenv); + env_bindings = (g.env_bindings); + env_mlident_map = map; + env_remove_typars = (g.env_remove_typars); + mlpath_of_lid = (g.mlpath_of_lid); + env_fieldname_map = (g.env_fieldname_map); + mlpath_of_fieldname = (g.mlpath_of_fieldname); + tydefs = (g.tydefs); + type_names = (g.type_names); + tydef_declarations = (g.tydef_declarations); + currentModule = (g.currentModule) + } in + let uu___4 = let uu___5 = mlns_of_lid x in (uu___5, name) in + (uu___4, g1)) in + match uu___ with + | (mlp, g1) -> + let g2 = + let uu___1 = + let uu___2 = FStarC_Ident.string_of_lid x in + FStarC_Compiler_Util.psmap_add g1.mlpath_of_lid uu___2 mlp in + { + env_tcenv = (g1.env_tcenv); + env_bindings = (g1.env_bindings); + env_mlident_map = (g1.env_mlident_map); + env_remove_typars = (g1.env_remove_typars); + mlpath_of_lid = uu___1; + env_fieldname_map = (g1.env_fieldname_map); + mlpath_of_fieldname = (g1.mlpath_of_fieldname); + tydefs = (g1.tydefs); + type_names = (g1.type_names); + tydef_declarations = (g1.tydef_declarations); + currentModule = (g1.currentModule) + } in + (mlp, g2) +let (extend_ty : uenv -> FStarC_Syntax_Syntax.bv -> Prims.bool -> uenv) = + fun g -> + fun a -> + fun map_to_top -> + let is_local_type_variable = Prims.op_Negation map_to_top in + let uu___ = + let uu___1 = root_name_of_bv a in + find_uniq g.env_mlident_map uu___1 is_local_type_variable in + match uu___ with + | (ml_a, mlident_map) -> + let mapped_to = + if map_to_top + then FStarC_Extraction_ML_Syntax.MLTY_Top + else FStarC_Extraction_ML_Syntax.MLTY_Var ml_a in + let gamma = + (Bv + (a, + (FStar_Pervasives.Inl + { ty_b_name = ml_a; ty_b_ty = mapped_to }))) + :: (g.env_bindings) in + let tcenv = FStarC_TypeChecker_Env.push_bv g.env_tcenv a in + { + env_tcenv = tcenv; + env_bindings = gamma; + env_mlident_map = mlident_map; + env_remove_typars = (g.env_remove_typars); + mlpath_of_lid = (g.mlpath_of_lid); + env_fieldname_map = (g.env_fieldname_map); + mlpath_of_fieldname = (g.mlpath_of_fieldname); + tydefs = (g.tydefs); + type_names = (g.type_names); + tydef_declarations = (g.tydef_declarations); + currentModule = (g.currentModule) + } +let (extend_bv : + uenv -> + FStarC_Syntax_Syntax.bv -> + FStarC_Extraction_ML_Syntax.mltyscheme -> + Prims.bool -> + Prims.bool -> + (uenv * FStarC_Extraction_ML_Syntax.mlident * exp_binding)) + = + fun g -> + fun x -> + fun t_x -> + fun add_unit -> + fun mk_unit -> + let ml_ty = + match t_x with + | ([], t) -> t + | uu___ -> FStarC_Extraction_ML_Syntax.MLTY_Top in + let uu___ = + let uu___1 = root_name_of_bv x in + find_uniq g.env_mlident_map uu___1 false in + match uu___ with + | (mlident, mlident_map) -> + let mlx = FStarC_Extraction_ML_Syntax.MLE_Var mlident in + let mlx1 = + if mk_unit + then FStarC_Extraction_ML_Syntax.ml_unit + else + if add_unit + then + (let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.MLTY_Top mlx in + (uu___4, [FStarC_Extraction_ML_Syntax.ml_unit]) in + FStarC_Extraction_ML_Syntax.MLE_App uu___3 in + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.MLTY_Top uu___2) + else FStarC_Extraction_ML_Syntax.with_ty ml_ty mlx in + let uu___1 = + if add_unit + then FStarC_Extraction_ML_Syntax.pop_unit t_x + else (FStarC_Extraction_ML_Syntax.E_PURE, t_x) in + (match uu___1 with + | (eff, t_x1) -> + let exp_binding1 = + { + exp_b_name = mlident; + exp_b_expr = mlx1; + exp_b_tscheme = t_x1; + exp_b_eff = eff + } in + let gamma = + (Bv (x, (FStar_Pervasives.Inr exp_binding1))) :: + (g.env_bindings) in + let tcenv = + let uu___2 = FStarC_Syntax_Syntax.binders_of_list [x] in + FStarC_TypeChecker_Env.push_binders g.env_tcenv uu___2 in + ({ + env_tcenv = tcenv; + env_bindings = gamma; + env_mlident_map = mlident_map; + env_remove_typars = (g.env_remove_typars); + mlpath_of_lid = (g.mlpath_of_lid); + env_fieldname_map = (g.env_fieldname_map); + mlpath_of_fieldname = (g.mlpath_of_fieldname); + tydefs = (g.tydefs); + type_names = (g.type_names); + tydef_declarations = (g.tydef_declarations); + currentModule = (g.currentModule) + }, mlident, exp_binding1)) +let (burn_name : uenv -> FStarC_Extraction_ML_Syntax.mlident -> uenv) = + fun g -> + fun i -> + let uu___ = FStarC_Compiler_Util.psmap_add g.env_mlident_map i "" in + { + env_tcenv = (g.env_tcenv); + env_bindings = (g.env_bindings); + env_mlident_map = uu___; + env_remove_typars = (g.env_remove_typars); + mlpath_of_lid = (g.mlpath_of_lid); + env_fieldname_map = (g.env_fieldname_map); + mlpath_of_fieldname = (g.mlpath_of_fieldname); + tydefs = (g.tydefs); + type_names = (g.type_names); + tydef_declarations = (g.tydef_declarations); + currentModule = (g.currentModule) + } +let (new_mlident : uenv -> (uenv * FStarC_Extraction_ML_Syntax.mlident)) = + fun g -> + let ml_ty = FStarC_Extraction_ML_Syntax.MLTY_Top in + let x = + FStarC_Syntax_Syntax.new_bv FStar_Pervasives_Native.None + FStarC_Syntax_Syntax.tun in + let uu___ = + extend_bv g x ([], FStarC_Extraction_ML_Syntax.MLTY_Top) false false in + match uu___ with | (g1, id, uu___1) -> (g1, id) +let (extend_fv : + uenv -> + FStarC_Syntax_Syntax.fv -> + FStarC_Extraction_ML_Syntax.mltyscheme -> + Prims.bool -> + (uenv * FStarC_Extraction_ML_Syntax.mlident * exp_binding)) + = + fun g -> + fun x -> + fun t_x -> + fun add_unit -> + let rec mltyFvars t = + match t with + | FStarC_Extraction_ML_Syntax.MLTY_Var x1 -> [x1] + | FStarC_Extraction_ML_Syntax.MLTY_Fun (t1, f, t2) -> + let uu___ = mltyFvars t1 in + let uu___1 = mltyFvars t2 in + FStarC_Compiler_List.append uu___ uu___1 + | FStarC_Extraction_ML_Syntax.MLTY_Named (args, path) -> + FStarC_Compiler_List.collect mltyFvars args + | FStarC_Extraction_ML_Syntax.MLTY_Tuple ts -> + FStarC_Compiler_List.collect mltyFvars ts + | FStarC_Extraction_ML_Syntax.MLTY_Top -> [] + | FStarC_Extraction_ML_Syntax.MLTY_Erased -> [] in + let rec subsetMlidents la lb = + match la with + | h::tla -> + (FStarC_Compiler_List.contains h lb) && + (subsetMlidents tla lb) + | [] -> true in + let tySchemeIsClosed tys = + let uu___ = mltyFvars (FStar_Pervasives_Native.snd tys) in + let uu___1 = + FStarC_Extraction_ML_Syntax.ty_param_names + (FStar_Pervasives_Native.fst tys) in + subsetMlidents uu___ uu___1 in + let uu___ = tySchemeIsClosed t_x in + if uu___ + then + let ml_ty = + match t_x with + | ([], t) -> t + | uu___1 -> FStarC_Extraction_ML_Syntax.MLTY_Top in + let uu___1 = + new_mlpath_of_lident g + (x.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + match uu___1 with + | (mlpath, g1) -> + let mlsymbol = FStar_Pervasives_Native.snd mlpath in + let mly = FStarC_Extraction_ML_Syntax.MLE_Name mlpath in + let mly1 = + if add_unit + then + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.MLTY_Top mly in + (uu___4, [FStarC_Extraction_ML_Syntax.ml_unit]) in + FStarC_Extraction_ML_Syntax.MLE_App uu___3 in + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.MLTY_Top uu___2 + else FStarC_Extraction_ML_Syntax.with_ty ml_ty mly in + let uu___2 = + if add_unit + then FStarC_Extraction_ML_Syntax.pop_unit t_x + else (FStarC_Extraction_ML_Syntax.E_PURE, t_x) in + (match uu___2 with + | (eff, t_x1) -> + let exp_binding1 = + { + exp_b_name = mlsymbol; + exp_b_expr = mly1; + exp_b_tscheme = t_x1; + exp_b_eff = eff + } in + let gamma = (Fv (x, exp_binding1)) :: (g1.env_bindings) in + let mlident_map = + FStarC_Compiler_Util.psmap_add g1.env_mlident_map + mlsymbol "" in + ({ + env_tcenv = (g1.env_tcenv); + env_bindings = gamma; + env_mlident_map = mlident_map; + env_remove_typars = (g1.env_remove_typars); + mlpath_of_lid = (g1.mlpath_of_lid); + env_fieldname_map = (g1.env_fieldname_map); + mlpath_of_fieldname = (g1.mlpath_of_fieldname); + tydefs = (g1.tydefs); + type_names = (g1.type_names); + tydef_declarations = (g1.tydef_declarations); + currentModule = (g1.currentModule) + }, mlsymbol, exp_binding1)) + else + (let uu___2 = + let uu___3 = + FStarC_Extraction_ML_Syntax.mltyscheme_to_string t_x in + FStarC_Compiler_Util.format1 "freevars found (%s)" uu___3 in + failwith uu___2) +let (extend_erased_fv : uenv -> FStarC_Syntax_Syntax.fv -> uenv) = + fun g -> + fun f -> + { + env_tcenv = (g.env_tcenv); + env_bindings = ((ErasedFv f) :: (g.env_bindings)); + env_mlident_map = (g.env_mlident_map); + env_remove_typars = (g.env_remove_typars); + mlpath_of_lid = (g.mlpath_of_lid); + env_fieldname_map = (g.env_fieldname_map); + mlpath_of_fieldname = (g.mlpath_of_fieldname); + tydefs = (g.tydefs); + type_names = (g.type_names); + tydef_declarations = (g.tydef_declarations); + currentModule = (g.currentModule) + } +let (extend_lb : + uenv -> + FStarC_Syntax_Syntax.lbname -> + FStarC_Syntax_Syntax.typ -> + FStarC_Extraction_ML_Syntax.mltyscheme -> + Prims.bool -> + (uenv * FStarC_Extraction_ML_Syntax.mlident * exp_binding)) + = + fun g -> + fun l -> + fun t -> + fun t_x -> + fun add_unit -> + match l with + | FStar_Pervasives.Inl x -> extend_bv g x t_x add_unit false + | FStar_Pervasives.Inr f -> extend_fv g f t_x add_unit +let (extend_tydef : + uenv -> + FStarC_Syntax_Syntax.fv -> + FStarC_Extraction_ML_Syntax.mltyscheme -> + FStarC_Extraction_ML_Syntax.metadata -> + (tydef * FStarC_Extraction_ML_Syntax.mlpath * uenv)) + = + fun g -> + fun fv -> + fun ts -> + fun meta -> + let uu___ = + new_mlpath_of_lident g + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + match uu___ with + | (name, g1) -> + let tydef1 = + { + tydef_fv = fv; + tydef_mlmodule_name = (FStar_Pervasives_Native.fst name); + tydef_name = (FStar_Pervasives_Native.snd name); + tydef_meta = meta; + tydef_def = ts + } in + (tydef1, name, + { + env_tcenv = (g1.env_tcenv); + env_bindings = (g1.env_bindings); + env_mlident_map = (g1.env_mlident_map); + env_remove_typars = (g1.env_remove_typars); + mlpath_of_lid = (g1.mlpath_of_lid); + env_fieldname_map = (g1.env_fieldname_map); + mlpath_of_fieldname = (g1.mlpath_of_fieldname); + tydefs = (tydef1 :: (g1.tydefs)); + type_names = ((fv, name) :: (g1.type_names)); + tydef_declarations = (g1.tydef_declarations); + currentModule = (g1.currentModule) + }) +let (extend_with_tydef_declaration : uenv -> FStarC_Ident.lident -> uenv) = + fun u -> + fun l -> + let uu___ = + let uu___1 = FStarC_Ident.string_of_lid l in + FStarC_Compiler_Util.psmap_add u.tydef_declarations uu___1 true in + { + env_tcenv = (u.env_tcenv); + env_bindings = (u.env_bindings); + env_mlident_map = (u.env_mlident_map); + env_remove_typars = (u.env_remove_typars); + mlpath_of_lid = (u.mlpath_of_lid); + env_fieldname_map = (u.env_fieldname_map); + mlpath_of_fieldname = (u.mlpath_of_fieldname); + tydefs = (u.tydefs); + type_names = (u.type_names); + tydef_declarations = uu___; + currentModule = (u.currentModule) + } +let (extend_type_name : + uenv -> + FStarC_Syntax_Syntax.fv -> (FStarC_Extraction_ML_Syntax.mlpath * uenv)) + = + fun g -> + fun fv -> + let uu___ = + new_mlpath_of_lident g + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + match uu___ with + | (name, g1) -> + (name, + { + env_tcenv = (g1.env_tcenv); + env_bindings = (g1.env_bindings); + env_mlident_map = (g1.env_mlident_map); + env_remove_typars = (g1.env_remove_typars); + mlpath_of_lid = (g1.mlpath_of_lid); + env_fieldname_map = (g1.env_fieldname_map); + mlpath_of_fieldname = (g1.mlpath_of_fieldname); + tydefs = (g1.tydefs); + type_names = ((fv, name) :: (g1.type_names)); + tydef_declarations = (g1.tydef_declarations); + currentModule = (g1.currentModule) + }) +let (extend_with_monad_op_name : + uenv -> + FStarC_Syntax_Syntax.eff_decl -> + Prims.string -> + FStarC_Extraction_ML_Syntax.mltyscheme -> + (FStarC_Extraction_ML_Syntax.mlpath * FStarC_Ident.lident * + exp_binding * uenv)) + = + fun g -> + fun ed -> + fun nm -> + fun ts -> + let lid = + let uu___ = FStarC_Ident.id_of_text nm in + FStarC_Syntax_Util.mk_field_projector_name_from_ident + ed.FStarC_Syntax_Syntax.mname uu___ in + let uu___ = + let uu___1 = + FStarC_Syntax_Syntax.lid_as_fv lid FStar_Pervasives_Native.None in + extend_fv g uu___1 ts false in + match uu___ with + | (g1, mlid, exp_b) -> + let mlp = let uu___1 = mlns_of_lid lid in (uu___1, mlid) in + (mlp, lid, exp_b, g1) +let (extend_with_action_name : + uenv -> + FStarC_Syntax_Syntax.eff_decl -> + FStarC_Syntax_Syntax.action -> + FStarC_Extraction_ML_Syntax.mltyscheme -> + (FStarC_Extraction_ML_Syntax.mlpath * FStarC_Ident.lident * + exp_binding * uenv)) + = + fun g -> + fun ed -> + fun a -> + fun ts -> + let nm = + let uu___ = + FStarC_Ident.ident_of_lid a.FStarC_Syntax_Syntax.action_name in + FStarC_Ident.string_of_id uu___ in + let module_name = + FStarC_Ident.ns_of_lid ed.FStarC_Syntax_Syntax.mname in + let lid = + let uu___ = + let uu___1 = + let uu___2 = FStarC_Ident.id_of_text nm in [uu___2] in + FStarC_Compiler_List.op_At module_name uu___1 in + FStarC_Ident.lid_of_ids uu___ in + let uu___ = + let uu___1 = + FStarC_Syntax_Syntax.lid_as_fv lid FStar_Pervasives_Native.None in + extend_fv g uu___1 ts false in + match uu___ with + | (g1, mlid, exp_b) -> + let mlp = let uu___1 = mlns_of_lid lid in (uu___1, mlid) in + (mlp, lid, exp_b, g1) +let (extend_record_field_name : + uenv -> + (FStarC_Ident.lident * FStarC_Ident.ident) -> + (FStarC_Extraction_ML_Syntax.mlident * uenv)) + = + fun g -> + fun uu___ -> + match uu___ with + | (type_name, fn) -> + let key = + let uu___1 = + let uu___2 = FStarC_Ident.ids_of_lid type_name in + FStarC_Compiler_List.op_At uu___2 [fn] in + FStarC_Ident.lid_of_ids uu___1 in + let uu___1 = + let uu___2 = FStarC_Ident.string_of_id fn in + find_uniq g.env_fieldname_map uu___2 false in + (match uu___1 with + | (name, fieldname_map) -> + let ns = mlns_of_lid type_name in + let mlp = (ns, name) in + let mlp1 = no_fstar_stubs mlp in + let g1 = + let uu___2 = + let uu___3 = FStarC_Ident.string_of_lid key in + FStarC_Compiler_Util.psmap_add g.mlpath_of_fieldname + uu___3 mlp1 in + { + env_tcenv = (g.env_tcenv); + env_bindings = (g.env_bindings); + env_mlident_map = (g.env_mlident_map); + env_remove_typars = (g.env_remove_typars); + mlpath_of_lid = (g.mlpath_of_lid); + env_fieldname_map = fieldname_map; + mlpath_of_fieldname = uu___2; + tydefs = (g.tydefs); + type_names = (g.type_names); + tydef_declarations = (g.tydef_declarations); + currentModule = (g.currentModule) + } in + (name, g1)) +let (extend_with_module_name : + uenv -> FStarC_Ident.lident -> (FStarC_Extraction_ML_Syntax.mlpath * uenv)) + = + fun g -> + fun m -> + let ns = mlns_of_lid m in + let p = + let uu___ = FStarC_Ident.ident_of_lid m in + FStarC_Ident.string_of_id uu___ in + ((ns, p), g) +let (exit_module : uenv -> uenv) = + fun g -> + let uu___ = initial_mlident_map () in + let uu___1 = initial_mlident_map () in + { + env_tcenv = (g.env_tcenv); + env_bindings = (g.env_bindings); + env_mlident_map = uu___; + env_remove_typars = (g.env_remove_typars); + mlpath_of_lid = (g.mlpath_of_lid); + env_fieldname_map = uu___1; + mlpath_of_fieldname = (g.mlpath_of_fieldname); + tydefs = (g.tydefs); + type_names = (g.type_names); + tydef_declarations = (g.tydef_declarations); + currentModule = (g.currentModule) + } +let (new_uenv : FStarC_TypeChecker_Env.env -> uenv) = + fun e -> + let env = + let uu___ = initial_mlident_map () in + let uu___1 = FStarC_Compiler_Util.psmap_empty () in + let uu___2 = initial_mlident_map () in + let uu___3 = FStarC_Compiler_Util.psmap_empty () in + let uu___4 = FStarC_Compiler_Util.psmap_empty () in + { + env_tcenv = e; + env_bindings = []; + env_mlident_map = uu___; + env_remove_typars = + FStarC_Extraction_ML_RemoveUnusedParameters.initial_env; + mlpath_of_lid = uu___1; + env_fieldname_map = uu___2; + mlpath_of_fieldname = uu___3; + tydefs = []; + type_names = []; + tydef_declarations = uu___4; + currentModule = ([], "") + } in + let a = "'a" in + let failwith_ty = + ([{ + FStarC_Extraction_ML_Syntax.ty_param_name = a; + FStarC_Extraction_ML_Syntax.ty_param_attrs = [] + }], + (FStarC_Extraction_ML_Syntax.MLTY_Fun + ((FStarC_Extraction_ML_Syntax.MLTY_Named + ([], (["Prims"], "string"))), + FStarC_Extraction_ML_Syntax.E_IMPURE, + (FStarC_Extraction_ML_Syntax.MLTY_Var a)))) in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Parser_Const.failwith_lid () in + FStarC_Syntax_Syntax.lid_as_fv uu___3 FStar_Pervasives_Native.None in + FStar_Pervasives.Inr uu___2 in + extend_lb env uu___1 FStarC_Syntax_Syntax.tun failwith_ty false in + match uu___ with | (g, uu___1, uu___2) -> g \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Extraction_ML_Util.ml b/ocaml/fstar-lib/generated/FStarC_Extraction_ML_Util.ml new file mode 100644 index 00000000000..b17379e28fc --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Extraction_ML_Util.ml @@ -0,0 +1,740 @@ +open Prims +let (codegen_fsharp : unit -> Prims.bool) = + fun uu___ -> + let uu___1 = FStarC_Options.codegen () in + uu___1 = (FStar_Pervasives_Native.Some FStarC_Options.FSharp) +let pruneNones : + 'a . 'a FStar_Pervasives_Native.option Prims.list -> 'a Prims.list = + fun l -> + FStarC_Compiler_List.fold_right + (fun x -> + fun ll -> + match x with + | FStar_Pervasives_Native.Some xs -> xs :: ll + | FStar_Pervasives_Native.None -> ll) l [] +let (mk_range_mle : FStarC_Extraction_ML_Syntax.mlexpr) = + FStarC_Extraction_ML_Syntax.with_ty FStarC_Extraction_ML_Syntax.MLTY_Top + (FStarC_Extraction_ML_Syntax.MLE_Name (["FStar"; "Range"], "mk_range")) +let (dummy_range_mle : FStarC_Extraction_ML_Syntax.mlexpr) = + FStarC_Extraction_ML_Syntax.with_ty FStarC_Extraction_ML_Syntax.MLTY_Top + (FStarC_Extraction_ML_Syntax.MLE_Name (["FStar"; "Range"], "dummyRange")) +let (mlconst_of_const' : + FStarC_Const.sconst -> FStarC_Extraction_ML_Syntax.mlconstant) = + fun sctt -> + match sctt with + | FStarC_Const.Const_effect -> failwith "Unsupported constant" + | FStarC_Const.Const_range uu___ -> FStarC_Extraction_ML_Syntax.MLC_Unit + | FStarC_Const.Const_unit -> FStarC_Extraction_ML_Syntax.MLC_Unit + | FStarC_Const.Const_char c -> FStarC_Extraction_ML_Syntax.MLC_Char c + | FStarC_Const.Const_int (s, i) -> + FStarC_Extraction_ML_Syntax.MLC_Int (s, i) + | FStarC_Const.Const_bool b -> FStarC_Extraction_ML_Syntax.MLC_Bool b + | FStarC_Const.Const_string (s, uu___) -> + FStarC_Extraction_ML_Syntax.MLC_String s + | FStarC_Const.Const_range_of -> + failwith "Unhandled constant: range_of/set_range_of" + | FStarC_Const.Const_set_range_of -> + failwith "Unhandled constant: range_of/set_range_of" + | FStarC_Const.Const_real uu___ -> + failwith "Unhandled constant: real/reify/reflect" + | FStarC_Const.Const_reify uu___ -> + failwith "Unhandled constant: real/reify/reflect" + | FStarC_Const.Const_reflect uu___ -> + failwith "Unhandled constant: real/reify/reflect" +let (mlconst_of_const : + FStarC_Compiler_Range_Type.range -> + FStarC_Const.sconst -> FStarC_Extraction_ML_Syntax.mlconstant) + = + fun p -> + fun c -> + try (fun uu___ -> match () with | () -> mlconst_of_const' c) () + with + | uu___ -> + let uu___1 = + let uu___2 = FStarC_Compiler_Range_Ops.string_of_range p in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_const c in + FStarC_Compiler_Util.format2 + "(%s) Failed to translate constant %s " uu___2 uu___3 in + failwith uu___1 +let (mlexpr_of_range : + FStarC_Compiler_Range_Type.range -> FStarC_Extraction_ML_Syntax.mlexpr') = + fun r -> + let cint i = + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Compiler_Util.string_of_int i in + (uu___3, FStar_Pervasives_Native.None) in + FStarC_Extraction_ML_Syntax.MLC_Int uu___2 in + FStarC_Extraction_ML_Syntax.MLE_Const uu___1 in + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.ml_int_ty uu___ in + let cstr s = + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.ml_string_ty + (FStarC_Extraction_ML_Syntax.MLE_Const + (FStarC_Extraction_ML_Syntax.MLC_String s)) in + let drop_path = FStarC_Compiler_Util.basename in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Compiler_Range_Ops.file_of_range r in + drop_path uu___4 in + cstr uu___3 in + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Compiler_Range_Ops.start_of_range r in + FStarC_Compiler_Range_Ops.line_of_pos uu___6 in + cint uu___5 in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Compiler_Range_Ops.start_of_range r in + FStarC_Compiler_Range_Ops.col_of_pos uu___8 in + cint uu___7 in + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = FStarC_Compiler_Range_Ops.end_of_range r in + FStarC_Compiler_Range_Ops.line_of_pos uu___10 in + cint uu___9 in + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = FStarC_Compiler_Range_Ops.end_of_range r in + FStarC_Compiler_Range_Ops.col_of_pos uu___12 in + cint uu___11 in + [uu___10] in + uu___8 :: uu___9 in + uu___6 :: uu___7 in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + (mk_range_mle, uu___1) in + FStarC_Extraction_ML_Syntax.MLE_App uu___ +let (mlexpr_of_const : + FStarC_Compiler_Range_Type.range -> + FStarC_Const.sconst -> FStarC_Extraction_ML_Syntax.mlexpr') + = + fun p -> + fun c -> + match c with + | FStarC_Const.Const_range r -> mlexpr_of_range r + | uu___ -> + let uu___1 = mlconst_of_const p c in + FStarC_Extraction_ML_Syntax.MLE_Const uu___1 +let rec (subst_aux : + (FStarC_Extraction_ML_Syntax.mlident * FStarC_Extraction_ML_Syntax.mlty) + Prims.list -> + FStarC_Extraction_ML_Syntax.mlty -> FStarC_Extraction_ML_Syntax.mlty) + = + fun subst -> + fun t -> + match t with + | FStarC_Extraction_ML_Syntax.MLTY_Var x -> + let uu___ = + FStarC_Compiler_Util.find_opt + (fun uu___1 -> match uu___1 with | (y, uu___2) -> y = x) subst in + (match uu___ with + | FStar_Pervasives_Native.Some ts -> + FStar_Pervasives_Native.snd ts + | FStar_Pervasives_Native.None -> t) + | FStarC_Extraction_ML_Syntax.MLTY_Fun (t1, f, t2) -> + let uu___ = + let uu___1 = subst_aux subst t1 in + let uu___2 = subst_aux subst t2 in (uu___1, f, uu___2) in + FStarC_Extraction_ML_Syntax.MLTY_Fun uu___ + | FStarC_Extraction_ML_Syntax.MLTY_Named (args, path) -> + let uu___ = + let uu___1 = FStarC_Compiler_List.map (subst_aux subst) args in + (uu___1, path) in + FStarC_Extraction_ML_Syntax.MLTY_Named uu___ + | FStarC_Extraction_ML_Syntax.MLTY_Tuple ts -> + let uu___ = FStarC_Compiler_List.map (subst_aux subst) ts in + FStarC_Extraction_ML_Syntax.MLTY_Tuple uu___ + | FStarC_Extraction_ML_Syntax.MLTY_Top -> t + | FStarC_Extraction_ML_Syntax.MLTY_Erased -> t +let (try_subst : + FStarC_Extraction_ML_Syntax.mltyscheme -> + FStarC_Extraction_ML_Syntax.mlty Prims.list -> + FStarC_Extraction_ML_Syntax.mlty FStar_Pervasives_Native.option) + = + fun uu___ -> + fun args -> + match uu___ with + | (formals, t) -> + if + (FStarC_Compiler_List.length formals) <> + (FStarC_Compiler_List.length args) + then FStar_Pervasives_Native.None + else + (let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Extraction_ML_Syntax.ty_param_names formals in + FStarC_Compiler_List.zip uu___4 args in + subst_aux uu___3 t in + FStar_Pervasives_Native.Some uu___2) +let (subst : + (FStarC_Extraction_ML_Syntax.ty_param Prims.list * + FStarC_Extraction_ML_Syntax.mlty) -> + FStarC_Extraction_ML_Syntax.mlty Prims.list -> + FStarC_Extraction_ML_Syntax.mlty) + = + fun ts -> + fun args -> + let uu___ = try_subst ts args in + match uu___ with + | FStar_Pervasives_Native.None -> + failwith + "Substitution must be fully applied (see GitHub issue #490)" + | FStar_Pervasives_Native.Some t -> t +let (udelta_unfold : + FStarC_Extraction_ML_UEnv.uenv -> + FStarC_Extraction_ML_Syntax.mlty -> + FStarC_Extraction_ML_Syntax.mlty FStar_Pervasives_Native.option) + = + fun g -> + fun uu___ -> + match uu___ with + | FStarC_Extraction_ML_Syntax.MLTY_Named (args, n) -> + let uu___1 = FStarC_Extraction_ML_UEnv.lookup_tydef g n in + (match uu___1 with + | FStar_Pervasives_Native.Some ts -> + let uu___2 = try_subst ts args in + (match uu___2 with + | FStar_Pervasives_Native.None -> + let uu___3 = + let uu___4 = + FStarC_Extraction_ML_Syntax.string_of_mlpath n in + let uu___5 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length args) in + let uu___6 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length + (FStar_Pervasives_Native.fst ts)) in + FStarC_Compiler_Util.format3 + "Substitution must be fully applied; got an application of %s with %s args whereas %s were expected (see GitHub issue #490)" + uu___4 uu___5 uu___6 in + failwith uu___3 + | FStar_Pervasives_Native.Some r -> + FStar_Pervasives_Native.Some r) + | uu___2 -> FStar_Pervasives_Native.None) + | uu___1 -> FStar_Pervasives_Native.None +let (eff_leq : + FStarC_Extraction_ML_Syntax.e_tag -> + FStarC_Extraction_ML_Syntax.e_tag -> Prims.bool) + = + fun f -> + fun f' -> + match (f, f') with + | (FStarC_Extraction_ML_Syntax.E_PURE, uu___) -> true + | (FStarC_Extraction_ML_Syntax.E_ERASABLE, + FStarC_Extraction_ML_Syntax.E_ERASABLE) -> true + | (FStarC_Extraction_ML_Syntax.E_IMPURE, + FStarC_Extraction_ML_Syntax.E_IMPURE) -> true + | uu___ -> false +let (eff_to_string : FStarC_Extraction_ML_Syntax.e_tag -> Prims.string) = + fun uu___ -> + match uu___ with + | FStarC_Extraction_ML_Syntax.E_PURE -> "Pure" + | FStarC_Extraction_ML_Syntax.E_ERASABLE -> "Erasable" + | FStarC_Extraction_ML_Syntax.E_IMPURE -> "Impure" +let (join : + FStarC_Compiler_Range_Type.range -> + FStarC_Extraction_ML_Syntax.e_tag -> + FStarC_Extraction_ML_Syntax.e_tag -> FStarC_Extraction_ML_Syntax.e_tag) + = + fun r -> + fun f -> + fun f' -> + match (f, f') with + | (FStarC_Extraction_ML_Syntax.E_IMPURE, + FStarC_Extraction_ML_Syntax.E_PURE) -> + FStarC_Extraction_ML_Syntax.E_IMPURE + | (FStarC_Extraction_ML_Syntax.E_PURE, + FStarC_Extraction_ML_Syntax.E_IMPURE) -> + FStarC_Extraction_ML_Syntax.E_IMPURE + | (FStarC_Extraction_ML_Syntax.E_IMPURE, + FStarC_Extraction_ML_Syntax.E_IMPURE) -> + FStarC_Extraction_ML_Syntax.E_IMPURE + | (FStarC_Extraction_ML_Syntax.E_ERASABLE, + FStarC_Extraction_ML_Syntax.E_ERASABLE) -> + FStarC_Extraction_ML_Syntax.E_ERASABLE + | (FStarC_Extraction_ML_Syntax.E_PURE, + FStarC_Extraction_ML_Syntax.E_ERASABLE) -> + FStarC_Extraction_ML_Syntax.E_ERASABLE + | (FStarC_Extraction_ML_Syntax.E_ERASABLE, + FStarC_Extraction_ML_Syntax.E_PURE) -> + FStarC_Extraction_ML_Syntax.E_ERASABLE + | (FStarC_Extraction_ML_Syntax.E_PURE, + FStarC_Extraction_ML_Syntax.E_PURE) -> + FStarC_Extraction_ML_Syntax.E_PURE + | uu___ -> + let uu___1 = + let uu___2 = FStarC_Compiler_Range_Ops.string_of_range r in + let uu___3 = eff_to_string f in + let uu___4 = eff_to_string f' in + FStarC_Compiler_Util.format3 + "Impossible (%s): Inconsistent effects %s and %s" uu___2 + uu___3 uu___4 in + failwith uu___1 +let (join_l : + FStarC_Compiler_Range_Type.range -> + FStarC_Extraction_ML_Syntax.e_tag Prims.list -> + FStarC_Extraction_ML_Syntax.e_tag) + = + fun r -> + fun fs -> + FStarC_Compiler_List.fold_left (join r) + FStarC_Extraction_ML_Syntax.E_PURE fs +let (mk_ty_fun : + FStarC_Extraction_ML_Syntax.mlbinder Prims.list -> + FStarC_Extraction_ML_Syntax.mlty -> FStarC_Extraction_ML_Syntax.mlty) + = + FStarC_Compiler_List.fold_right + (fun uu___ -> + fun t -> + match uu___ with + | { FStarC_Extraction_ML_Syntax.mlbinder_name = uu___1; + FStarC_Extraction_ML_Syntax.mlbinder_ty = mlbinder_ty; + FStarC_Extraction_ML_Syntax.mlbinder_attrs = uu___2;_} -> + FStarC_Extraction_ML_Syntax.MLTY_Fun + (mlbinder_ty, FStarC_Extraction_ML_Syntax.E_PURE, t)) +type unfold_t = + FStarC_Extraction_ML_Syntax.mlty -> + FStarC_Extraction_ML_Syntax.mlty FStar_Pervasives_Native.option +let rec (type_leq_c : + unfold_t -> + FStarC_Extraction_ML_Syntax.mlexpr FStar_Pervasives_Native.option -> + FStarC_Extraction_ML_Syntax.mlty -> + FStarC_Extraction_ML_Syntax.mlty -> + (Prims.bool * FStarC_Extraction_ML_Syntax.mlexpr + FStar_Pervasives_Native.option)) + = + fun unfold_ty -> + fun e -> + fun t -> + fun t' -> + match (t, t') with + | (FStarC_Extraction_ML_Syntax.MLTY_Var x, + FStarC_Extraction_ML_Syntax.MLTY_Var y) -> + if x = y + then (true, e) + else (false, FStar_Pervasives_Native.None) + | (FStarC_Extraction_ML_Syntax.MLTY_Fun (t1, f, t2), + FStarC_Extraction_ML_Syntax.MLTY_Fun (t1', f', t2')) -> + let mk_fun xs body = + match xs with + | [] -> body + | uu___ -> + let e1 = + match body.FStarC_Extraction_ML_Syntax.expr with + | FStarC_Extraction_ML_Syntax.MLE_Fun (ys, body1) -> + FStarC_Extraction_ML_Syntax.MLE_Fun + ((FStarC_Compiler_List.op_At xs ys), body1) + | uu___1 -> + FStarC_Extraction_ML_Syntax.MLE_Fun (xs, body) in + let uu___1 = + mk_ty_fun xs body.FStarC_Extraction_ML_Syntax.mlty in + FStarC_Extraction_ML_Syntax.with_ty uu___1 e1 in + (match e with + | FStar_Pervasives_Native.Some + { + FStarC_Extraction_ML_Syntax.expr = + FStarC_Extraction_ML_Syntax.MLE_Fun (x::xs, body); + FStarC_Extraction_ML_Syntax.mlty = uu___; + FStarC_Extraction_ML_Syntax.loc = uu___1;_} + -> + let uu___2 = (type_leq unfold_ty t1' t1) && (eff_leq f f') in + if uu___2 + then + (if + (f = FStarC_Extraction_ML_Syntax.E_PURE) && + (f' = FStarC_Extraction_ML_Syntax.E_ERASABLE) + then + let uu___3 = type_leq unfold_ty t2 t2' in + (if uu___3 + then + let body1 = + let uu___4 = + type_leq unfold_ty t2 + FStarC_Extraction_ML_Syntax.ml_unit_ty in + if uu___4 + then FStarC_Extraction_ML_Syntax.ml_unit + else + FStarC_Extraction_ML_Syntax.with_ty t2' + (FStarC_Extraction_ML_Syntax.MLE_Coerce + (FStarC_Extraction_ML_Syntax.ml_unit, + FStarC_Extraction_ML_Syntax.ml_unit_ty, + t2')) in + let uu___4 = + let uu___5 = + let uu___6 = + mk_ty_fun [x] + body1.FStarC_Extraction_ML_Syntax.mlty in + FStarC_Extraction_ML_Syntax.with_ty uu___6 + (FStarC_Extraction_ML_Syntax.MLE_Fun + ([x], body1)) in + FStar_Pervasives_Native.Some uu___5 in + (true, uu___4) + else (false, FStar_Pervasives_Native.None)) + else + (let uu___4 = + let uu___5 = + let uu___6 = mk_fun xs body in + FStar_Pervasives_Native.Some uu___6 in + type_leq_c unfold_ty uu___5 t2 t2' in + match uu___4 with + | (ok, body1) -> + let res = + match body1 with + | FStar_Pervasives_Native.Some body2 -> + let uu___5 = mk_fun [x] body2 in + FStar_Pervasives_Native.Some uu___5 + | uu___5 -> FStar_Pervasives_Native.None in + (ok, res))) + else (false, FStar_Pervasives_Native.None) + | uu___ -> + let uu___1 = + ((type_leq unfold_ty t1' t1) && (eff_leq f f')) && + (type_leq unfold_ty t2 t2') in + if uu___1 + then (true, e) + else (false, FStar_Pervasives_Native.None)) + | (FStarC_Extraction_ML_Syntax.MLTY_Named (args, path), + FStarC_Extraction_ML_Syntax.MLTY_Named (args', path')) -> + if path = path' + then + let uu___ = + FStarC_Compiler_List.forall2 (type_leq unfold_ty) args + args' in + (if uu___ + then (true, e) + else (false, FStar_Pervasives_Native.None)) + else + (let uu___1 = unfold_ty t in + match uu___1 with + | FStar_Pervasives_Native.Some t1 -> + type_leq_c unfold_ty e t1 t' + | FStar_Pervasives_Native.None -> + let uu___2 = unfold_ty t' in + (match uu___2 with + | FStar_Pervasives_Native.None -> + (false, FStar_Pervasives_Native.None) + | FStar_Pervasives_Native.Some t'1 -> + type_leq_c unfold_ty e t t'1)) + | (FStarC_Extraction_ML_Syntax.MLTY_Tuple ts, + FStarC_Extraction_ML_Syntax.MLTY_Tuple ts') -> + let uu___ = + FStarC_Compiler_List.forall2 (type_leq unfold_ty) ts ts' in + if uu___ + then (true, e) + else (false, FStar_Pervasives_Native.None) + | (FStarC_Extraction_ML_Syntax.MLTY_Top, + FStarC_Extraction_ML_Syntax.MLTY_Top) -> (true, e) + | (FStarC_Extraction_ML_Syntax.MLTY_Named uu___, uu___1) -> + let uu___2 = unfold_ty t in + (match uu___2 with + | FStar_Pervasives_Native.Some t1 -> + type_leq_c unfold_ty e t1 t' + | uu___3 -> (false, FStar_Pervasives_Native.None)) + | (uu___, FStarC_Extraction_ML_Syntax.MLTY_Named uu___1) -> + let uu___2 = unfold_ty t' in + (match uu___2 with + | FStar_Pervasives_Native.Some t'1 -> + type_leq_c unfold_ty e t t'1 + | uu___3 -> (false, FStar_Pervasives_Native.None)) + | (FStarC_Extraction_ML_Syntax.MLTY_Erased, + FStarC_Extraction_ML_Syntax.MLTY_Erased) -> (true, e) + | uu___ -> (false, FStar_Pervasives_Native.None) +and (type_leq : + unfold_t -> + FStarC_Extraction_ML_Syntax.mlty -> + FStarC_Extraction_ML_Syntax.mlty -> Prims.bool) + = + fun g -> + fun t1 -> + fun t2 -> + let uu___ = type_leq_c g FStar_Pervasives_Native.None t1 t2 in + FStar_Pervasives_Native.fst uu___ +let rec (erase_effect_annotations : + FStarC_Extraction_ML_Syntax.mlty -> FStarC_Extraction_ML_Syntax.mlty) = + fun t -> + match t with + | FStarC_Extraction_ML_Syntax.MLTY_Fun (t1, f, t2) -> + let uu___ = + let uu___1 = erase_effect_annotations t1 in + let uu___2 = erase_effect_annotations t2 in + (uu___1, FStarC_Extraction_ML_Syntax.E_PURE, uu___2) in + FStarC_Extraction_ML_Syntax.MLTY_Fun uu___ + | uu___ -> t +let is_type_abstraction : + 'a 'b 'c . (('a, 'b) FStar_Pervasives.either * 'c) Prims.list -> Prims.bool + = + fun uu___ -> + match uu___ with + | (FStar_Pervasives.Inl uu___1, uu___2)::uu___3 -> true + | uu___1 -> false +let (is_xtuple : + (Prims.string Prims.list * Prims.string) -> + Prims.int FStar_Pervasives_Native.option) + = + fun uu___ -> + match uu___ with + | (ns, n) -> + let uu___1 = + let uu___2 = + FStarC_Compiler_Util.concat_l "." + (FStarC_Compiler_List.op_At ns [n]) in + FStarC_Parser_Const.is_tuple_datacon_string uu___2 in + if uu___1 + then + let uu___2 = + let uu___3 = FStarC_Compiler_Util.char_at n (Prims.of_int (7)) in + FStarC_Compiler_Util.int_of_char uu___3 in + FStar_Pervasives_Native.Some uu___2 + else FStar_Pervasives_Native.None +let (resugar_exp : + FStarC_Extraction_ML_Syntax.mlexpr -> FStarC_Extraction_ML_Syntax.mlexpr) = + fun e -> + match e.FStarC_Extraction_ML_Syntax.expr with + | FStarC_Extraction_ML_Syntax.MLE_CTor (mlp, args) -> + let uu___ = is_xtuple mlp in + (match uu___ with + | FStar_Pervasives_Native.Some n -> + FStarC_Extraction_ML_Syntax.with_ty + e.FStarC_Extraction_ML_Syntax.mlty + (FStarC_Extraction_ML_Syntax.MLE_Tuple args) + | uu___1 -> e) + | uu___ -> e +let (record_field_path : + FStarC_Ident.lident Prims.list -> Prims.string Prims.list) = + fun uu___ -> + match uu___ with + | f::uu___1 -> + let uu___2 = + let uu___3 = FStarC_Ident.ns_of_lid f in + FStarC_Compiler_Util.prefix uu___3 in + (match uu___2 with + | (ns, uu___3) -> + FStarC_Compiler_List.map + (fun id -> FStarC_Ident.string_of_id id) ns) + | uu___1 -> failwith "impos" +let record_fields : + 'a . + FStarC_Ident.lident Prims.list -> + 'a Prims.list -> (Prims.string * 'a) Prims.list + = + fun fs -> + fun vs -> + FStarC_Compiler_List.map2 + (fun f -> + fun e -> + let uu___ = + let uu___1 = FStarC_Ident.ident_of_lid f in + FStarC_Ident.string_of_id uu___1 in + (uu___, e)) fs vs +let (is_xtuple_ty : + (Prims.string Prims.list * Prims.string) -> + Prims.int FStar_Pervasives_Native.option) + = + fun uu___ -> + match uu___ with + | (ns, n) -> + let uu___1 = + let uu___2 = + FStarC_Compiler_Util.concat_l "." + (FStarC_Compiler_List.op_At ns [n]) in + FStarC_Parser_Const.is_tuple_constructor_string uu___2 in + if uu___1 + then + let uu___2 = + let uu___3 = FStarC_Compiler_Util.char_at n (Prims.of_int (5)) in + FStarC_Compiler_Util.int_of_char uu___3 in + FStar_Pervasives_Native.Some uu___2 + else FStar_Pervasives_Native.None +let (resugar_mlty : + FStarC_Extraction_ML_Syntax.mlty -> FStarC_Extraction_ML_Syntax.mlty) = + fun t -> + match t with + | FStarC_Extraction_ML_Syntax.MLTY_Named (args, mlp) -> + let uu___ = is_xtuple_ty mlp in + (match uu___ with + | FStar_Pervasives_Native.Some n -> + FStarC_Extraction_ML_Syntax.MLTY_Tuple args + | uu___1 -> t) + | uu___ -> t +let (flatten_ns : Prims.string Prims.list -> Prims.string) = + fun ns -> FStarC_Compiler_String.concat "_" ns +let (flatten_mlpath : + (Prims.string Prims.list * Prims.string) -> Prims.string) = + fun uu___ -> + match uu___ with + | (ns, n) -> + FStarC_Compiler_String.concat "_" (FStarC_Compiler_List.op_At ns [n]) +let (ml_module_name_of_lid : FStarC_Ident.lident -> Prims.string) = + fun l -> + let mlp = + let uu___ = + let uu___1 = FStarC_Ident.ns_of_lid l in + FStarC_Compiler_List.map FStarC_Ident.string_of_id uu___1 in + let uu___1 = + let uu___2 = FStarC_Ident.ident_of_lid l in + FStarC_Ident.string_of_id uu___2 in + (uu___, uu___1) in + flatten_mlpath mlp +let rec (erasableType : + unfold_t -> FStarC_Extraction_ML_Syntax.mlty -> Prims.bool) = + fun unfold_ty -> + fun t -> + let erasableTypeNoDelta t1 = + if t1 = FStarC_Extraction_ML_Syntax.ml_unit_ty + then true + else + (match t1 with + | FStarC_Extraction_ML_Syntax.MLTY_Named + (uu___1, ("FStar"::"Ghost"::[], "erased")) -> true + | FStarC_Extraction_ML_Syntax.MLTY_Named + (uu___1, ("FStar"::"Tactics"::"Effect"::[], "tactic")) -> + let uu___2 = FStarC_Options.codegen () in + uu___2 <> (FStar_Pervasives_Native.Some FStarC_Options.Plugin) + | uu___1 -> false) in + let uu___ = erasableTypeNoDelta t in + if uu___ + then true + else + (let uu___2 = unfold_ty t in + match uu___2 with + | FStar_Pervasives_Native.Some t1 -> erasableType unfold_ty t1 + | FStar_Pervasives_Native.None -> false) +let rec (eraseTypeDeep : + unfold_t -> + FStarC_Extraction_ML_Syntax.mlty -> FStarC_Extraction_ML_Syntax.mlty) + = + fun unfold_ty -> + fun t -> + match t with + | FStarC_Extraction_ML_Syntax.MLTY_Fun (tyd, etag, tycd) -> + if etag = FStarC_Extraction_ML_Syntax.E_PURE + then + let uu___ = + let uu___1 = eraseTypeDeep unfold_ty tyd in + let uu___2 = eraseTypeDeep unfold_ty tycd in + (uu___1, etag, uu___2) in + FStarC_Extraction_ML_Syntax.MLTY_Fun uu___ + else t + | FStarC_Extraction_ML_Syntax.MLTY_Named (lty, mlp) -> + let uu___ = erasableType unfold_ty t in + if uu___ + then FStarC_Extraction_ML_Syntax.MLTY_Erased + else + (let uu___2 = + let uu___3 = + FStarC_Compiler_List.map (eraseTypeDeep unfold_ty) lty in + (uu___3, mlp) in + FStarC_Extraction_ML_Syntax.MLTY_Named uu___2) + | FStarC_Extraction_ML_Syntax.MLTY_Tuple lty -> + let uu___ = FStarC_Compiler_List.map (eraseTypeDeep unfold_ty) lty in + FStarC_Extraction_ML_Syntax.MLTY_Tuple uu___ + | uu___ -> t +let (prims_op_equality : FStarC_Extraction_ML_Syntax.mlexpr) = + FStarC_Extraction_ML_Syntax.with_ty FStarC_Extraction_ML_Syntax.MLTY_Top + (FStarC_Extraction_ML_Syntax.MLE_Name (["Prims"], "op_Equality")) +let (prims_op_amp_amp : FStarC_Extraction_ML_Syntax.mlexpr) = + let uu___ = + mk_ty_fun + [{ + FStarC_Extraction_ML_Syntax.mlbinder_name = "x"; + FStarC_Extraction_ML_Syntax.mlbinder_ty = + FStarC_Extraction_ML_Syntax.ml_bool_ty; + FStarC_Extraction_ML_Syntax.mlbinder_attrs = [] + }; + { + FStarC_Extraction_ML_Syntax.mlbinder_name = "y"; + FStarC_Extraction_ML_Syntax.mlbinder_ty = + FStarC_Extraction_ML_Syntax.ml_bool_ty; + FStarC_Extraction_ML_Syntax.mlbinder_attrs = [] + }] FStarC_Extraction_ML_Syntax.ml_bool_ty in + FStarC_Extraction_ML_Syntax.with_ty uu___ + (FStarC_Extraction_ML_Syntax.MLE_Name (["Prims"], "op_AmpAmp")) +let (conjoin : + FStarC_Extraction_ML_Syntax.mlexpr -> + FStarC_Extraction_ML_Syntax.mlexpr -> FStarC_Extraction_ML_Syntax.mlexpr) + = + fun e1 -> + fun e2 -> + FStarC_Extraction_ML_Syntax.with_ty + FStarC_Extraction_ML_Syntax.ml_bool_ty + (FStarC_Extraction_ML_Syntax.MLE_App (prims_op_amp_amp, [e1; e2])) +let (conjoin_opt : + FStarC_Extraction_ML_Syntax.mlexpr FStar_Pervasives_Native.option -> + FStarC_Extraction_ML_Syntax.mlexpr FStar_Pervasives_Native.option -> + FStarC_Extraction_ML_Syntax.mlexpr FStar_Pervasives_Native.option) + = + fun e1 -> + fun e2 -> + match (e1, e2) with + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> + FStar_Pervasives_Native.None + | (FStar_Pervasives_Native.Some x, FStar_Pervasives_Native.None) -> + FStar_Pervasives_Native.Some x + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.Some x) -> + FStar_Pervasives_Native.Some x + | (FStar_Pervasives_Native.Some x, FStar_Pervasives_Native.Some y) -> + let uu___ = conjoin x y in FStar_Pervasives_Native.Some uu___ +let (mlloc_of_range : + FStarC_Compiler_Range_Type.range -> (Prims.int * Prims.string)) = + fun r -> + let pos = FStarC_Compiler_Range_Ops.start_of_range r in + let line = FStarC_Compiler_Range_Ops.line_of_pos pos in + let uu___ = FStarC_Compiler_Range_Ops.file_of_range r in (line, uu___) +let rec (doms_and_cod : + FStarC_Extraction_ML_Syntax.mlty -> + (FStarC_Extraction_ML_Syntax.mlty Prims.list * + FStarC_Extraction_ML_Syntax.mlty)) + = + fun t -> + match t with + | FStarC_Extraction_ML_Syntax.MLTY_Fun (a, uu___, b) -> + let uu___1 = doms_and_cod b in + (match uu___1 with | (ds, c) -> ((a :: ds), c)) + | uu___ -> ([], t) +let (argTypes : + FStarC_Extraction_ML_Syntax.mlty -> + FStarC_Extraction_ML_Syntax.mlty Prims.list) + = fun t -> let uu___ = doms_and_cod t in FStar_Pervasives_Native.fst uu___ +let rec (uncurry_mlty_fun : + FStarC_Extraction_ML_Syntax.mlty -> + (FStarC_Extraction_ML_Syntax.mlty Prims.list * + FStarC_Extraction_ML_Syntax.mlty)) + = + fun t -> + match t with + | FStarC_Extraction_ML_Syntax.MLTY_Fun (a, uu___, b) -> + let uu___1 = uncurry_mlty_fun b in + (match uu___1 with | (args, res) -> ((a :: args), res)) + | uu___ -> ([], t) +let (list_elements : + FStarC_Extraction_ML_Syntax.mlexpr -> + FStarC_Extraction_ML_Syntax.mlexpr Prims.list + FStar_Pervasives_Native.option) + = + fun e -> + let rec list_elements1 acc e1 = + match e1.FStarC_Extraction_ML_Syntax.expr with + | FStarC_Extraction_ML_Syntax.MLE_CTor + (("Prims"::[], "Cons"), hd::tl::[]) -> + list_elements1 (hd :: acc) tl + | FStarC_Extraction_ML_Syntax.MLE_CTor (("Prims"::[], "Nil"), []) -> + FStar_Pervasives_Native.Some (FStarC_Compiler_List.rev acc) + | FStarC_Extraction_ML_Syntax.MLE_CTor + (("Prims"::[], "Cons"), hd::tl::[]) -> + list_elements1 (hd :: acc) tl + | FStarC_Extraction_ML_Syntax.MLE_CTor (("Prims"::[], "Nil"), []) -> + FStar_Pervasives_Native.Some (FStarC_Compiler_List.rev acc) + | uu___ -> FStar_Pervasives_Native.None in + list_elements1 [] e \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Find.ml b/ocaml/fstar-lib/generated/FStarC_Find.ml new file mode 100644 index 00000000000..fe43cc592ff --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Find.ml @@ -0,0 +1,39 @@ +open Prims +let (find_file : Prims.string -> Prims.string FStar_Pervasives_Native.option) + = + let file_map = FStarC_Compiler_Util.smap_create (Prims.of_int (100)) in + fun filename -> + let uu___ = FStarC_Compiler_Util.smap_try_find file_map filename in + match uu___ with + | FStar_Pervasives_Native.Some f -> f + | FStar_Pervasives_Native.None -> + let result = + try + (fun uu___1 -> + match () with + | () -> + let uu___2 = + FStarC_Compiler_Util.is_path_absolute filename in + if uu___2 + then + (if FStarC_Compiler_Util.file_exists filename + then FStar_Pervasives_Native.Some filename + else FStar_Pervasives_Native.None) + else + (let uu___4 = + let uu___5 = FStarC_Options.include_path () in + FStar_List_Tot_Base.rev uu___5 in + FStarC_Compiler_Util.find_map uu___4 + (fun p -> + let path = + if p = "." + then filename + else FStarC_Compiler_Util.join_paths p filename in + if FStarC_Compiler_Util.file_exists path + then FStar_Pervasives_Native.Some path + else FStar_Pervasives_Native.None))) () + with | uu___1 -> FStar_Pervasives_Native.None in + (if FStar_Pervasives_Native.uu___is_Some result + then FStarC_Compiler_Util.smap_add file_map filename result + else (); + result) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_GenSym.ml b/ocaml/fstar-lib/generated/FStarC_GenSym.ml new file mode 100644 index 00000000000..a58e412d22e --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_GenSym.ml @@ -0,0 +1,20 @@ +open Prims +let (gensym_st : Prims.int FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref Prims.int_zero +let (next_id : unit -> Prims.int) = + fun uu___ -> + let r = FStarC_Compiler_Effect.op_Bang gensym_st in + FStarC_Compiler_Effect.op_Colon_Equals gensym_st (r + Prims.int_one); r +let (reset_gensym : unit -> unit) = + fun uu___ -> + FStarC_Compiler_Effect.op_Colon_Equals gensym_st Prims.int_zero +let with_frozen_gensym : 'a . (unit -> 'a) -> 'a = + fun f -> + let v = FStarC_Compiler_Effect.op_Bang gensym_st in + let r = + try (fun uu___ -> match () with | () -> f ()) () + with + | uu___ -> + (FStarC_Compiler_Effect.op_Colon_Equals gensym_st v; + FStarC_Compiler_Effect.raise uu___) in + FStarC_Compiler_Effect.op_Colon_Equals gensym_st v; r \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Ident.ml b/ocaml/fstar-lib/generated/FStarC_Ident.ml new file mode 100644 index 00000000000..078307e82b0 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Ident.ml @@ -0,0 +1,161 @@ +open Prims +type ident = + { + idText: Prims.string ; + idRange: FStarC_Compiler_Range_Type.range }[@@deriving yojson,show] +let (__proj__Mkident__item__idText : ident -> Prims.string) = + fun projectee -> match projectee with | { idText; idRange;_} -> idText +let (__proj__Mkident__item__idRange : + ident -> FStarC_Compiler_Range_Type.range) = + fun projectee -> match projectee with | { idText; idRange;_} -> idRange +type path = Prims.string Prims.list[@@deriving yojson,show] +type ipath = ident Prims.list[@@deriving yojson,show] +type lident = + { + ns: ipath ; + ident: ident ; + nsstr: Prims.string ; + str: Prims.string }[@@deriving yojson,show] +let (__proj__Mklident__item__ns : lident -> ipath) = + fun projectee -> + match projectee with | { ns; ident = ident1; nsstr; str;_} -> ns +let (__proj__Mklident__item__ident : lident -> ident) = + fun projectee -> + match projectee with | { ns; ident = ident1; nsstr; str;_} -> ident1 +let (__proj__Mklident__item__nsstr : lident -> Prims.string) = + fun projectee -> + match projectee with | { ns; ident = ident1; nsstr; str;_} -> nsstr +let (__proj__Mklident__item__str : lident -> Prims.string) = + fun projectee -> + match projectee with | { ns; ident = ident1; nsstr; str;_} -> str +let (mk_ident : (Prims.string * FStarC_Compiler_Range_Type.range) -> ident) = + fun uu___ -> + match uu___ with | (text, range) -> { idText = text; idRange = range } +let (set_id_range : FStarC_Compiler_Range_Type.range -> ident -> ident) = + fun r -> fun i -> { idText = (i.idText); idRange = r } +let (reserved_prefix : Prims.string) = "uu___" +let (gen' : Prims.string -> FStarC_Compiler_Range_Type.range -> ident) = + fun s -> + fun r -> + let i = FStarC_GenSym.next_id () in + mk_ident ((Prims.strcat s (Prims.string_of_int i)), r) +let (gen : FStarC_Compiler_Range_Type.range -> ident) = + fun r -> gen' reserved_prefix r +let (ident_of_lid : lident -> ident) = fun l -> l.ident +let (range_of_id : ident -> FStarC_Compiler_Range_Type.range) = + fun id -> id.idRange +let (id_of_text : Prims.string -> ident) = + fun str -> mk_ident (str, FStarC_Compiler_Range_Type.dummyRange) +let (string_of_id : ident -> Prims.string) = fun id -> id.idText +let (text_of_path : path -> Prims.string) = + fun path1 -> FStarC_Compiler_Util.concat_l "." path1 +let (path_of_text : Prims.string -> path) = + fun text -> FStar_String.split [46] text +let (path_of_ns : ipath -> path) = + fun ns -> FStarC_Compiler_List.map string_of_id ns +let (path_of_lid : lident -> path) = + fun lid -> + FStarC_Compiler_List.map string_of_id + (FStarC_Compiler_List.op_At lid.ns [lid.ident]) +let (ns_of_lid : lident -> ipath) = fun lid -> lid.ns +let (ids_of_lid : lident -> ipath) = + fun lid -> FStarC_Compiler_List.op_At lid.ns [lid.ident] +let (lid_of_ns_and_id : ipath -> ident -> lident) = + fun ns -> + fun id -> + let nsstr = + let uu___ = FStarC_Compiler_List.map string_of_id ns in + text_of_path uu___ in + { + ns; + ident = id; + nsstr; + str = + (if nsstr = "" + then id.idText + else Prims.strcat nsstr (Prims.strcat "." id.idText)) + } +let (lid_of_ids : ipath -> lident) = + fun ids -> + let uu___ = FStarC_Compiler_Util.prefix ids in + match uu___ with | (ns, id) -> lid_of_ns_and_id ns id +let (lid_of_str : Prims.string -> lident) = + fun str -> + let uu___ = + FStarC_Compiler_List.map id_of_text + (FStarC_Compiler_Util.split str ".") in + lid_of_ids uu___ +let (lid_of_path : path -> FStarC_Compiler_Range_Type.range -> lident) = + fun path1 -> + fun pos -> + let ids = FStarC_Compiler_List.map (fun s -> mk_ident (s, pos)) path1 in + lid_of_ids ids +let (text_of_lid : lident -> Prims.string) = fun lid -> lid.str +let (lid_equals : lident -> lident -> Prims.bool) = + fun l1 -> fun l2 -> l1.str = l2.str +let (ident_equals : ident -> ident -> Prims.bool) = + fun id1 -> fun id2 -> id1.idText = id2.idText +type lid = lident[@@deriving yojson,show] +let (range_of_lid : lident -> FStarC_Compiler_Range_Type.range) = + fun lid1 -> range_of_id lid1.ident +let (set_lid_range : lident -> FStarC_Compiler_Range_Type.range -> lident) = + fun l -> + fun r -> + { + ns = (l.ns); + ident = + (let uu___ = l.ident in { idText = (uu___.idText); idRange = r }); + nsstr = (l.nsstr); + str = (l.str) + } +let (lid_add_suffix : lident -> Prims.string -> lident) = + fun l -> + fun s -> + let path1 = path_of_lid l in + let uu___ = range_of_lid l in + lid_of_path (FStarC_Compiler_List.op_At path1 [s]) uu___ +let (ml_path_of_lid : lident -> Prims.string) = + fun lid1 -> + let uu___ = + let uu___1 = path_of_ns lid1.ns in + let uu___2 = let uu___3 = string_of_id lid1.ident in [uu___3] in + FStarC_Compiler_List.op_At uu___1 uu___2 in + FStar_String.concat "_" uu___ +let (string_of_lid : lident -> Prims.string) = fun lid1 -> lid1.str +let (qual_id : lident -> ident -> lident) = + fun lid1 -> + fun id -> + let uu___ = + lid_of_ids (FStarC_Compiler_List.op_At lid1.ns [lid1.ident; id]) in + let uu___1 = range_of_id id in set_lid_range uu___ uu___1 +let (nsstr : lident -> Prims.string) = fun l -> l.nsstr +let (showable_ident : ident FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = string_of_id } +let (showable_lident : lident FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = string_of_lid } +let (pretty_ident : ident FStarC_Class_PP.pretty) = + FStarC_Class_PP.pretty_from_showable showable_ident +let (pretty_lident : lident FStarC_Class_PP.pretty) = + FStarC_Class_PP.pretty_from_showable showable_lident +let (hasrange_ident : ident FStarC_Class_HasRange.hasRange) = + { + FStarC_Class_HasRange.pos = range_of_id; + FStarC_Class_HasRange.setPos = + (fun rng -> fun id -> { idText = (id.idText); idRange = rng }) + } +let (hasrange_lident : lident FStarC_Class_HasRange.hasRange) = + { + FStarC_Class_HasRange.pos = + (fun lid1 -> FStarC_Class_HasRange.pos hasrange_ident lid1.ident); + FStarC_Class_HasRange.setPos = + (fun rng -> + fun id -> + let uu___ = + FStarC_Class_HasRange.setPos hasrange_ident rng id.ident in + { ns = (id.ns); ident = uu___; nsstr = (id.nsstr); str = (id.str) + }) + } +let (deq_ident : ident FStarC_Class_Deq.deq) = + { FStarC_Class_Deq.op_Equals_Question = ident_equals } +let (deq_lident : lident FStarC_Class_Deq.deq) = + { FStarC_Class_Deq.op_Equals_Question = lid_equals } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Interactive_CompletionTable.ml b/ocaml/fstar-lib/generated/FStarC_Interactive_CompletionTable.ml new file mode 100644 index 00000000000..4195850c42c --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Interactive_CompletionTable.ml @@ -0,0 +1,889 @@ +open Prims +let (string_compare : Prims.string -> Prims.string -> Prims.int) = + fun s1 -> fun s2 -> FStarC_Compiler_String.compare s1 s2 +type 'a heap = + | EmptyHeap + | Heap of ('a * 'a heap Prims.list) +let uu___is_EmptyHeap : 'a . 'a heap -> Prims.bool = + fun projectee -> match projectee with | EmptyHeap -> true | uu___ -> false +let uu___is_Heap : 'a . 'a heap -> Prims.bool = + fun projectee -> match projectee with | Heap _0 -> true | uu___ -> false +let __proj__Heap__item___0 : 'a . 'a heap -> ('a * 'a heap Prims.list) = + fun projectee -> match projectee with | Heap _0 -> _0 +let heap_merge : + 'uuuuu . + ('uuuuu -> 'uuuuu -> Prims.int) -> + 'uuuuu heap -> 'uuuuu heap -> 'uuuuu heap + = + fun cmp -> + fun h1 -> + fun h2 -> + match (h1, h2) with + | (EmptyHeap, h) -> h + | (h, EmptyHeap) -> h + | (Heap (v1, hh1), Heap (v2, hh2)) -> + let uu___ = let uu___1 = cmp v1 v2 in uu___1 < Prims.int_zero in + if uu___ then Heap (v1, (h2 :: hh1)) else Heap (v2, (h1 :: hh2)) +let heap_insert : + 'uuuuu . + ('uuuuu -> 'uuuuu -> Prims.int) -> 'uuuuu heap -> 'uuuuu -> 'uuuuu heap + = fun cmp -> fun h -> fun v -> heap_merge cmp (Heap (v, [])) h +let rec heap_merge_pairs : + 'uuuuu . + ('uuuuu -> 'uuuuu -> Prims.int) -> 'uuuuu heap Prims.list -> 'uuuuu heap + = + fun cmp -> + fun uu___ -> + match uu___ with + | [] -> EmptyHeap + | h::[] -> h + | h1::h2::hh -> + let uu___1 = heap_merge cmp h1 h2 in + let uu___2 = heap_merge_pairs cmp hh in + heap_merge cmp uu___1 uu___2 +let heap_peek : 'uuuuu . 'uuuuu heap -> 'uuuuu FStar_Pervasives_Native.option + = + fun uu___ -> + match uu___ with + | EmptyHeap -> FStar_Pervasives_Native.None + | Heap (v, uu___1) -> FStar_Pervasives_Native.Some v +let heap_pop : + 'uuuuu . + ('uuuuu -> 'uuuuu -> Prims.int) -> + 'uuuuu heap -> ('uuuuu * 'uuuuu heap) FStar_Pervasives_Native.option + = + fun cmp -> + fun uu___ -> + match uu___ with + | EmptyHeap -> FStar_Pervasives_Native.None + | Heap (v, hh) -> + let uu___1 = let uu___2 = heap_merge_pairs cmp hh in (v, uu___2) in + FStar_Pervasives_Native.Some uu___1 +let heap_from_list : + 'uuuuu . + ('uuuuu -> 'uuuuu -> Prims.int) -> 'uuuuu Prims.list -> 'uuuuu heap + = + fun cmp -> + fun values -> + FStarC_Compiler_List.fold_left (heap_insert cmp) EmptyHeap values +let push_nodup : + 'uuuuu . + ('uuuuu -> Prims.string) -> + 'uuuuu -> 'uuuuu Prims.list -> 'uuuuu Prims.list + = + fun key_fn -> + fun x -> + fun uu___ -> + match uu___ with + | [] -> [x] + | h::t -> + let uu___1 = + let uu___2 = + let uu___3 = key_fn x in + let uu___4 = key_fn h in string_compare uu___3 uu___4 in + uu___2 = Prims.int_zero in + if uu___1 then h :: t else x :: h :: t +let rec add_priorities : + 'uuuuu . + Prims.int -> + (Prims.int * 'uuuuu) Prims.list -> + 'uuuuu Prims.list -> (Prims.int * 'uuuuu) Prims.list + = + fun n -> + fun acc -> + fun uu___ -> + match uu___ with + | [] -> acc + | h::t -> add_priorities (n + Prims.int_one) ((n, h) :: acc) t +let merge_increasing_lists_rev : + 'a . ('a -> Prims.string) -> 'a Prims.list Prims.list -> 'a Prims.list = + fun key_fn -> + fun lists -> + let cmp v1 v2 = + match (v1, v2) with + | ((uu___, []), uu___1) -> failwith "impossible" + | (uu___, (uu___1, [])) -> failwith "impossible" + | ((pr1, h1::uu___), (pr2, h2::uu___1)) -> + let cmp_h = + let uu___2 = key_fn h1 in + let uu___3 = key_fn h2 in string_compare uu___2 uu___3 in + if cmp_h <> Prims.int_zero then cmp_h else pr1 - pr2 in + let rec aux lists1 acc = + let uu___ = heap_pop cmp lists1 in + match uu___ with + | FStar_Pervasives_Native.None -> acc + | FStar_Pervasives_Native.Some ((pr, []), uu___1) -> + failwith "impossible" + | FStar_Pervasives_Native.Some ((pr, v::[]), lists2) -> + let uu___1 = push_nodup key_fn v acc in aux lists2 uu___1 + | FStar_Pervasives_Native.Some ((pr, v::tl), lists2) -> + let uu___1 = heap_insert cmp lists2 (pr, tl) in + let uu___2 = push_nodup key_fn v acc in aux uu___1 uu___2 in + let lists1 = FStarC_Compiler_List.filter (fun x -> x <> []) lists in + match lists1 with + | [] -> [] + | l::[] -> FStarC_Compiler_List.rev l + | uu___ -> + let lists2 = add_priorities Prims.int_zero [] lists1 in + let uu___1 = heap_from_list cmp lists2 in aux uu___1 [] +type 'a btree = + | StrEmpty + | StrBranch of (Prims.string * 'a * 'a btree * 'a btree) +let uu___is_StrEmpty : 'a . 'a btree -> Prims.bool = + fun projectee -> match projectee with | StrEmpty -> true | uu___ -> false +let uu___is_StrBranch : 'a . 'a btree -> Prims.bool = + fun projectee -> + match projectee with | StrBranch _0 -> true | uu___ -> false +let __proj__StrBranch__item___0 : + 'a . 'a btree -> (Prims.string * 'a * 'a btree * 'a btree) = + fun projectee -> match projectee with | StrBranch _0 -> _0 +let rec btree_to_list_rev : + 'a . + 'a btree -> + (Prims.string * 'a) Prims.list -> (Prims.string * 'a) Prims.list + = + fun btree1 -> + fun acc -> + match btree1 with + | StrEmpty -> acc + | StrBranch (key, value, lbt, rbt) -> + let uu___ = + let uu___1 = btree_to_list_rev lbt acc in (key, value) :: uu___1 in + btree_to_list_rev rbt uu___ +let rec btree_from_list : + 'a . + (Prims.string * 'a) Prims.list -> + Prims.int -> ('a btree * (Prims.string * 'a) Prims.list) + = + fun nodes -> + fun size -> + if size = Prims.int_zero + then (StrEmpty, nodes) + else + (let lbt_size = size / (Prims.of_int (2)) in + let rbt_size = (size - lbt_size) - Prims.int_one in + let uu___1 = btree_from_list nodes lbt_size in + match uu___1 with + | (lbt, nodes_left) -> + (match nodes_left with + | [] -> failwith "Invalid size passed to btree_from_list" + | (k, v)::nodes_left1 -> + let uu___2 = btree_from_list nodes_left1 rbt_size in + (match uu___2 with + | (rbt, nodes_left2) -> + ((StrBranch (k, v, lbt, rbt)), nodes_left2)))) +let rec btree_insert_replace : + 'a . 'a btree -> Prims.string -> 'a -> 'a btree = + fun bt -> + fun k -> + fun v -> + match bt with + | StrEmpty -> StrBranch (k, v, StrEmpty, StrEmpty) + | StrBranch (k', v', lbt, rbt) -> + let cmp = string_compare k k' in + if cmp < Prims.int_zero + then + let uu___ = + let uu___1 = btree_insert_replace lbt k v in + (k', v', uu___1, rbt) in + StrBranch uu___ + else + if cmp > Prims.int_zero + then + (let uu___1 = + let uu___2 = btree_insert_replace rbt k v in + (k', v', lbt, uu___2) in + StrBranch uu___1) + else StrBranch (k', v, lbt, rbt) +let rec btree_find_exact : + 'a . 'a btree -> Prims.string -> 'a FStar_Pervasives_Native.option = + fun bt -> + fun k -> + match bt with + | StrEmpty -> FStar_Pervasives_Native.None + | StrBranch (k', v, lbt, rbt) -> + let cmp = string_compare k k' in + if cmp < Prims.int_zero + then btree_find_exact lbt k + else + if cmp > Prims.int_zero + then btree_find_exact rbt k + else FStar_Pervasives_Native.Some v +let rec btree_extract_min : + 'a . + 'a btree -> (Prims.string * 'a * 'a btree) FStar_Pervasives_Native.option + = + fun bt -> + match bt with + | StrEmpty -> FStar_Pervasives_Native.None + | StrBranch (k, v, StrEmpty, rbt) -> + FStar_Pervasives_Native.Some (k, v, rbt) + | StrBranch (uu___, uu___1, lbt, uu___2) -> btree_extract_min lbt +let rec btree_remove : 'a . 'a btree -> Prims.string -> 'a btree = + fun bt -> + fun k -> + match bt with + | StrEmpty -> StrEmpty + | StrBranch (k', v, lbt, rbt) -> + let cmp = string_compare k k' in + if cmp < Prims.int_zero + then + let uu___ = + let uu___1 = btree_remove lbt k in (k', v, uu___1, rbt) in + StrBranch uu___ + else + if cmp > Prims.int_zero + then + (let uu___1 = + let uu___2 = btree_remove rbt k in (k', v, lbt, uu___2) in + StrBranch uu___1) + else + (match lbt with + | StrEmpty -> bt + | uu___2 -> + let uu___3 = btree_extract_min rbt in + (match uu___3 with + | FStar_Pervasives_Native.None -> lbt + | FStar_Pervasives_Native.Some + (rbt_min_k, rbt_min_v, rbt') -> + StrBranch (rbt_min_k, rbt_min_v, lbt, rbt'))) +type prefix_match = + { + prefix: Prims.string FStar_Pervasives_Native.option ; + completion: Prims.string } +let (__proj__Mkprefix_match__item__prefix : + prefix_match -> Prims.string FStar_Pervasives_Native.option) = + fun projectee -> match projectee with | { prefix; completion;_} -> prefix +let (__proj__Mkprefix_match__item__completion : prefix_match -> Prims.string) + = + fun projectee -> + match projectee with | { prefix; completion;_} -> completion +type path_elem = { + imports: Prims.string Prims.list ; + segment: prefix_match } +let (__proj__Mkpath_elem__item__imports : + path_elem -> Prims.string Prims.list) = + fun projectee -> match projectee with | { imports; segment;_} -> imports +let (__proj__Mkpath_elem__item__segment : path_elem -> prefix_match) = + fun projectee -> match projectee with | { imports; segment;_} -> segment +type path = path_elem Prims.list +let (matched_prefix_of_path_elem : + path_elem -> Prims.string FStar_Pervasives_Native.option) = + fun elem -> (elem.segment).prefix +type query = Prims.string Prims.list +type ns_info = { + ns_name: Prims.string ; + ns_loaded: Prims.bool } +let (__proj__Mkns_info__item__ns_name : ns_info -> Prims.string) = + fun projectee -> match projectee with | { ns_name; ns_loaded;_} -> ns_name +let (__proj__Mkns_info__item__ns_loaded : ns_info -> Prims.bool) = + fun projectee -> + match projectee with | { ns_name; ns_loaded;_} -> ns_loaded +type mod_info = + { + mod_name: Prims.string ; + mod_path: Prims.string ; + mod_loaded: Prims.bool } +let (__proj__Mkmod_info__item__mod_name : mod_info -> Prims.string) = + fun projectee -> + match projectee with | { mod_name; mod_path; mod_loaded;_} -> mod_name +let (__proj__Mkmod_info__item__mod_path : mod_info -> Prims.string) = + fun projectee -> + match projectee with | { mod_name; mod_path; mod_loaded;_} -> mod_path +let (__proj__Mkmod_info__item__mod_loaded : mod_info -> Prims.bool) = + fun projectee -> + match projectee with | { mod_name; mod_path; mod_loaded;_} -> mod_loaded +let (mk_path_el : Prims.string Prims.list -> prefix_match -> path_elem) = + fun imports -> fun segment -> { imports; segment } +let btree_find_prefix : + 'a . 'a btree -> Prims.string -> (prefix_match * 'a) Prims.list = + fun bt -> + fun prefix -> + let rec aux bt1 prefix1 acc = + match bt1 with + | StrEmpty -> acc + | StrBranch (k, v, lbt, rbt) -> + let cmp = string_compare k prefix1 in + let include_middle = FStarC_Compiler_Util.starts_with k prefix1 in + let explore_right = (cmp <= Prims.int_zero) || include_middle in + let explore_left = cmp > Prims.int_zero in + let matches = if explore_right then aux rbt prefix1 acc else acc in + let matches1 = + if include_middle + then + ({ + prefix = (FStar_Pervasives_Native.Some prefix1); + completion = k + }, v) + :: matches + else matches in + let matches2 = + if explore_left then aux lbt prefix1 matches1 else matches1 in + matches2 in + aux bt prefix [] +let rec btree_fold : + 'a 'b . 'a btree -> (Prims.string -> 'a -> 'b -> 'b) -> 'b -> 'b = + fun bt -> + fun f -> + fun acc -> + match bt with + | StrEmpty -> acc + | StrBranch (k, v, lbt, rbt) -> + let uu___ = let uu___1 = btree_fold rbt f acc in f k v uu___1 in + btree_fold lbt f uu___ +let (query_to_string : Prims.string Prims.list -> Prims.string) = + fun q -> FStarC_Compiler_String.concat "." q +type 'a name_collection = + | Names of 'a btree + | ImportedNames of (Prims.string * 'a name_collection Prims.list) +let uu___is_Names : 'a . 'a name_collection -> Prims.bool = + fun projectee -> match projectee with | Names _0 -> true | uu___ -> false +let __proj__Names__item___0 : 'a . 'a name_collection -> 'a btree = + fun projectee -> match projectee with | Names _0 -> _0 +let uu___is_ImportedNames : 'a . 'a name_collection -> Prims.bool = + fun projectee -> + match projectee with | ImportedNames _0 -> true | uu___ -> false +let __proj__ImportedNames__item___0 : + 'a . 'a name_collection -> (Prims.string * 'a name_collection Prims.list) = + fun projectee -> match projectee with | ImportedNames _0 -> _0 +type 'a names = 'a name_collection Prims.list +type 'a trie = { + bindings: 'a names ; + namespaces: 'a trie names } +let __proj__Mktrie__item__bindings : 'a . 'a trie -> 'a names = + fun projectee -> + match projectee with | { bindings; namespaces;_} -> bindings +let __proj__Mktrie__item__namespaces : 'a . 'a trie -> 'a trie names = + fun projectee -> + match projectee with | { bindings; namespaces;_} -> namespaces +let trie_empty : 'uuuuu . unit -> 'uuuuu trie = + fun uu___ -> { bindings = []; namespaces = [] } +let rec names_find_exact : + 'a . 'a names -> Prims.string -> 'a FStar_Pervasives_Native.option = + fun names1 -> + fun ns -> + let uu___ = + match names1 with + | [] -> (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) + | (Names bt)::names2 -> + let uu___1 = btree_find_exact bt ns in + (uu___1, (FStar_Pervasives_Native.Some names2)) + | (ImportedNames (uu___1, names2))::more_names -> + let uu___2 = names_find_exact names2 ns in + (uu___2, (FStar_Pervasives_Native.Some more_names)) in + match uu___ with + | (result, names2) -> + (match (result, names2) with + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.Some + scopes) -> names_find_exact scopes ns + | uu___1 -> result) +let rec trie_descend_exact : + 'a . 'a trie -> query -> 'a trie FStar_Pervasives_Native.option = + fun tr -> + fun query1 -> + match query1 with + | [] -> FStar_Pervasives_Native.Some tr + | ns::query2 -> + let uu___ = names_find_exact tr.namespaces ns in + FStarC_Compiler_Util.bind_opt uu___ + (fun scope -> trie_descend_exact scope query2) +let rec trie_find_exact : + 'a . 'a trie -> query -> 'a FStar_Pervasives_Native.option = + fun tr -> + fun query1 -> + match query1 with + | [] -> failwith "Empty query in trie_find_exact" + | name::[] -> names_find_exact tr.bindings name + | ns::query2 -> + let uu___ = names_find_exact tr.namespaces ns in + FStarC_Compiler_Util.bind_opt uu___ + (fun scope -> trie_find_exact scope query2) +let names_insert : 'a . 'a names -> Prims.string -> 'a -> 'a names = + fun name_collections -> + fun id -> + fun v -> + let uu___ = + match name_collections with + | (Names bt)::tl -> (bt, tl) + | uu___1 -> (StrEmpty, name_collections) in + match uu___ with + | (bt, name_collections1) -> + let uu___1 = + let uu___2 = btree_insert_replace bt id v in Names uu___2 in + uu___1 :: name_collections1 +let rec namespaces_mutate : + 'a . + 'a trie names -> + Prims.string -> + query -> + query -> + ('a trie -> + Prims.string -> query -> query -> 'a trie names -> 'a trie) + -> ('a trie -> query -> 'a trie) -> 'a trie names + = + fun namespaces -> + fun ns -> + fun q -> + fun rev_acc -> + fun mut_node -> + fun mut_leaf -> + let trie1 = + let uu___ = names_find_exact namespaces ns in + FStarC_Compiler_Util.dflt (trie_empty ()) uu___ in + let uu___ = trie_mutate trie1 q rev_acc mut_node mut_leaf in + names_insert namespaces ns uu___ +and trie_mutate : + 'a . + 'a trie -> + query -> + query -> + ('a trie -> + Prims.string -> query -> query -> 'a trie names -> 'a trie) + -> ('a trie -> query -> 'a trie) -> 'a trie + = + fun tr -> + fun q -> + fun rev_acc -> + fun mut_node -> + fun mut_leaf -> + match q with + | [] -> mut_leaf tr rev_acc + | id::q1 -> + let ns' = + namespaces_mutate tr.namespaces id q1 (id :: rev_acc) + mut_node mut_leaf in + mut_node tr id q1 rev_acc ns' +let trie_mutate_leaf : + 'a . 'a trie -> query -> ('a trie -> query -> 'a trie) -> 'a trie = + fun tr -> + fun query1 -> + trie_mutate tr query1 [] + (fun tr1 -> + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun namespaces -> { bindings = (tr1.bindings); namespaces }) +let trie_insert : 'a . 'a trie -> query -> Prims.string -> 'a -> 'a trie = + fun tr -> + fun ns_query -> + fun id -> + fun v -> + trie_mutate_leaf tr ns_query + (fun tr1 -> + fun uu___ -> + let uu___1 = names_insert tr1.bindings id v in + { bindings = uu___1; namespaces = (tr1.namespaces) }) +let trie_import : + 'a . + 'a trie -> + query -> + query -> ('a trie -> 'a trie -> Prims.string -> 'a trie) -> 'a trie + = + fun tr -> + fun host_query -> + fun included_query -> + fun mutator -> + let label = query_to_string included_query in + let included_trie = + let uu___ = trie_descend_exact tr included_query in + FStarC_Compiler_Util.dflt (trie_empty ()) uu___ in + trie_mutate_leaf tr host_query + (fun tr1 -> fun uu___ -> mutator tr1 included_trie label) +let trie_include : 'a . 'a trie -> query -> query -> 'a trie = + fun tr -> + fun host_query -> + fun included_query -> + trie_import tr host_query included_query + (fun tr1 -> + fun inc -> + fun label -> + { + bindings = ((ImportedNames (label, (inc.bindings))) :: + (tr1.bindings)); + namespaces = (tr1.namespaces) + }) +let trie_open_namespace : 'a . 'a trie -> query -> query -> 'a trie = + fun tr -> + fun host_query -> + fun included_query -> + trie_import tr host_query included_query + (fun tr1 -> + fun inc -> + fun label -> + { + bindings = (tr1.bindings); + namespaces = ((ImportedNames (label, (inc.namespaces))) :: + (tr1.namespaces)) + }) +let trie_add_alias : + 'a . 'a trie -> Prims.string -> query -> query -> 'a trie = + fun tr -> + fun key -> + fun host_query -> + fun included_query -> + trie_import tr host_query included_query + (fun tr1 -> + fun inc -> + fun label -> + trie_mutate_leaf tr1 [key] + (fun _ignored_overwritten_trie -> + fun uu___ -> + { + bindings = + [ImportedNames (label, (inc.bindings))]; + namespaces = [] + })) +let names_revmap : + 'a 'b . + ('a btree -> 'b) -> 'a names -> (Prims.string Prims.list * 'b) Prims.list + = + fun fn -> + fun name_collections -> + let rec aux acc imports name_collections1 = + FStarC_Compiler_List.fold_left + (fun acc1 -> + fun uu___ -> + match uu___ with + | Names bt -> + let uu___1 = let uu___2 = fn bt in (imports, uu___2) in + uu___1 :: acc1 + | ImportedNames (nm, name_collections2) -> + aux acc1 (nm :: imports) name_collections2) acc + name_collections1 in + aux [] [] name_collections +let btree_find_all : + 'a . + Prims.string FStar_Pervasives_Native.option -> + 'a btree -> (prefix_match * 'a) Prims.list + = + fun prefix -> + fun bt -> + btree_fold bt + (fun k -> + fun tr -> fun acc -> ({ prefix; completion = k }, tr) :: acc) [] +type name_search_term = + | NSTAll + | NSTNone + | NSTPrefix of Prims.string +let (uu___is_NSTAll : name_search_term -> Prims.bool) = + fun projectee -> match projectee with | NSTAll -> true | uu___ -> false +let (uu___is_NSTNone : name_search_term -> Prims.bool) = + fun projectee -> match projectee with | NSTNone -> true | uu___ -> false +let (uu___is_NSTPrefix : name_search_term -> Prims.bool) = + fun projectee -> + match projectee with | NSTPrefix _0 -> true | uu___ -> false +let (__proj__NSTPrefix__item___0 : name_search_term -> Prims.string) = + fun projectee -> match projectee with | NSTPrefix _0 -> _0 +let names_find_rev : + 'a . 'a names -> name_search_term -> (path_elem * 'a) Prims.list = + fun names1 -> + fun id -> + let matching_values_per_collection_with_imports = + match id with + | NSTNone -> [] + | NSTAll -> + names_revmap (btree_find_all FStar_Pervasives_Native.None) names1 + | NSTPrefix "" -> + names_revmap (btree_find_all (FStar_Pervasives_Native.Some "")) + names1 + | NSTPrefix id1 -> + names_revmap (fun bt -> btree_find_prefix bt id1) names1 in + let matching_values_per_collection = + FStarC_Compiler_List.map + (fun uu___ -> + match uu___ with + | (imports, matches) -> + FStarC_Compiler_List.map + (fun uu___1 -> + match uu___1 with + | (segment, v) -> ((mk_path_el imports segment), v)) + matches) matching_values_per_collection_with_imports in + merge_increasing_lists_rev + (fun uu___ -> + match uu___ with + | (path_el, uu___1) -> (path_el.segment).completion) + matching_values_per_collection +let rec trie_find_prefix' : + 'a . + 'a trie -> + path -> query -> (path * 'a) Prims.list -> (path * 'a) Prims.list + = + fun tr -> + fun path_acc -> + fun query1 -> + fun acc -> + let uu___ = + match query1 with + | [] -> (NSTAll, NSTAll, []) + | id::[] -> ((NSTPrefix id), (NSTPrefix id), []) + | ns::query2 -> ((NSTPrefix ns), NSTNone, query2) in + match uu___ with + | (ns_search_term, bindings_search_term, query2) -> + let matching_namespaces_rev = + names_find_rev tr.namespaces ns_search_term in + let acc_with_recursive_bindings = + FStarC_Compiler_List.fold_left + (fun acc1 -> + fun uu___1 -> + match uu___1 with + | (path_el, trie1) -> + trie_find_prefix' trie1 (path_el :: path_acc) + query2 acc1) acc matching_namespaces_rev in + let matching_bindings_rev = + names_find_rev tr.bindings bindings_search_term in + FStarC_Compiler_List.rev_map_onto + (fun uu___1 -> + match uu___1 with + | (path_el, v) -> + ((FStarC_Compiler_List.rev (path_el :: path_acc)), v)) + matching_bindings_rev acc_with_recursive_bindings +let trie_find_prefix : 'a . 'a trie -> query -> (path * 'a) Prims.list = + fun tr -> fun query1 -> trie_find_prefix' tr [] query1 [] +let (mod_name : mod_info -> Prims.string) = fun md -> md.mod_name +type mod_symbol = + | Module of mod_info + | Namespace of ns_info +let (uu___is_Module : mod_symbol -> Prims.bool) = + fun projectee -> match projectee with | Module _0 -> true | uu___ -> false +let (__proj__Module__item___0 : mod_symbol -> mod_info) = + fun projectee -> match projectee with | Module _0 -> _0 +let (uu___is_Namespace : mod_symbol -> Prims.bool) = + fun projectee -> + match projectee with | Namespace _0 -> true | uu___ -> false +let (__proj__Namespace__item___0 : mod_symbol -> ns_info) = + fun projectee -> match projectee with | Namespace _0 -> _0 +type lid_symbol = FStarC_Ident.lid +type symbol = + | ModOrNs of mod_symbol + | Lid of lid_symbol +let (uu___is_ModOrNs : symbol -> Prims.bool) = + fun projectee -> match projectee with | ModOrNs _0 -> true | uu___ -> false +let (__proj__ModOrNs__item___0 : symbol -> mod_symbol) = + fun projectee -> match projectee with | ModOrNs _0 -> _0 +let (uu___is_Lid : symbol -> Prims.bool) = + fun projectee -> match projectee with | Lid _0 -> true | uu___ -> false +let (__proj__Lid__item___0 : symbol -> lid_symbol) = + fun projectee -> match projectee with | Lid _0 -> _0 +type table = { + tbl_lids: lid_symbol trie ; + tbl_mods: mod_symbol trie } +let (__proj__Mktable__item__tbl_lids : table -> lid_symbol trie) = + fun projectee -> match projectee with | { tbl_lids; tbl_mods;_} -> tbl_lids +let (__proj__Mktable__item__tbl_mods : table -> mod_symbol trie) = + fun projectee -> match projectee with | { tbl_lids; tbl_mods;_} -> tbl_mods +let (empty : table) = + { tbl_lids = (trie_empty ()); tbl_mods = (trie_empty ()) } +let (insert : table -> query -> Prims.string -> lid_symbol -> table) = + fun tbl -> + fun host_query -> + fun id -> + fun c -> + let uu___ = trie_insert tbl.tbl_lids host_query id c in + { tbl_lids = uu___; tbl_mods = (tbl.tbl_mods) } +let (register_alias : table -> Prims.string -> query -> query -> table) = + fun tbl -> + fun key -> + fun host_query -> + fun included_query -> + let uu___ = + trie_add_alias tbl.tbl_lids key host_query included_query in + { tbl_lids = uu___; tbl_mods = (tbl.tbl_mods) } +let (register_include : table -> query -> query -> table) = + fun tbl -> + fun host_query -> + fun included_query -> + let uu___ = trie_include tbl.tbl_lids host_query included_query in + { tbl_lids = uu___; tbl_mods = (tbl.tbl_mods) } +let (register_open : table -> Prims.bool -> query -> query -> table) = + fun tbl -> + fun is_module -> + fun host_query -> + fun included_query -> + if is_module + then register_include tbl host_query included_query + else + (let uu___1 = + trie_open_namespace tbl.tbl_lids host_query included_query in + { tbl_lids = uu___1; tbl_mods = (tbl.tbl_mods) }) +let (register_module_path : + table -> Prims.bool -> Prims.string -> query -> table) = + fun tbl -> + fun loaded -> + fun path1 -> + fun mod_query -> + let ins_ns id bindings full_name loaded1 = + let uu___ = + let uu___1 = names_find_exact bindings id in (uu___1, loaded1) in + match uu___ with + | (FStar_Pervasives_Native.None, uu___1) -> + names_insert bindings id + (Namespace { ns_name = full_name; ns_loaded = loaded1 }) + | (FStar_Pervasives_Native.Some (Namespace + { ns_name = uu___1; ns_loaded = false;_}), true) -> + names_insert bindings id + (Namespace { ns_name = full_name; ns_loaded = loaded1 }) + | (FStar_Pervasives_Native.Some uu___1, uu___2) -> bindings in + let ins_mod id bindings full_name loaded1 = + names_insert bindings id + (Module + { + mod_name = full_name; + mod_path = path1; + mod_loaded = loaded1 + }) in + let name_of_revq query1 = + FStarC_Compiler_String.concat "." + (FStarC_Compiler_List.rev query1) in + let ins id q revq bindings loaded1 = + let name = name_of_revq (id :: revq) in + match q with + | [] -> ins_mod id bindings name loaded1 + | uu___ -> ins_ns id bindings name loaded1 in + let uu___ = + trie_mutate tbl.tbl_mods mod_query [] + (fun tr -> + fun id -> + fun q -> + fun revq -> + fun namespaces -> + let uu___1 = ins id q revq tr.bindings loaded in + { bindings = uu___1; namespaces }) + (fun tr -> fun uu___1 -> tr) in + { tbl_lids = (tbl.tbl_lids); tbl_mods = uu___ } +let (string_of_path : path -> Prims.string) = + fun path1 -> + let uu___ = + FStarC_Compiler_List.map (fun el -> (el.segment).completion) path1 in + FStarC_Compiler_String.concat "." uu___ +let (match_length_of_path : path -> Prims.int) = + fun path1 -> + let uu___ = + FStarC_Compiler_List.fold_left + (fun acc -> + fun elem -> + let uu___1 = acc in + match uu___1 with + | (acc_len, uu___2) -> + (match (elem.segment).prefix with + | FStar_Pervasives_Native.Some prefix -> + let completion_len = + FStarC_Compiler_String.length + (elem.segment).completion in + (((acc_len + Prims.int_one) + completion_len), + (prefix, completion_len)) + | FStar_Pervasives_Native.None -> acc)) + (Prims.int_zero, ("", Prims.int_zero)) path1 in + match uu___ with + | (length, (last_prefix, last_completion_length)) -> + ((length - Prims.int_one) - last_completion_length) + + (FStarC_Compiler_String.length last_prefix) +let (first_import_of_path : + path -> Prims.string FStar_Pervasives_Native.option) = + fun path1 -> + match path1 with + | [] -> FStar_Pervasives_Native.None + | { imports; segment = uu___;_}::uu___1 -> + FStarC_Compiler_List.last_opt imports +let (alist_of_ns_info : + ns_info -> (Prims.string * FStarC_Json.json) Prims.list) = + fun ns_info1 -> + [("name", (FStarC_Json.JsonStr (ns_info1.ns_name))); + ("loaded", (FStarC_Json.JsonBool (ns_info1.ns_loaded)))] +let (alist_of_mod_info : + mod_info -> (Prims.string * FStarC_Json.json) Prims.list) = + fun mod_info1 -> + [("name", (FStarC_Json.JsonStr (mod_info1.mod_name))); + ("path", (FStarC_Json.JsonStr (mod_info1.mod_path))); + ("loaded", (FStarC_Json.JsonBool (mod_info1.mod_loaded)))] +type completion_result = + { + completion_match_length: Prims.int ; + completion_candidate: Prims.string ; + completion_annotation: Prims.string } +let (__proj__Mkcompletion_result__item__completion_match_length : + completion_result -> Prims.int) = + fun projectee -> + match projectee with + | { completion_match_length; completion_candidate; + completion_annotation;_} -> completion_match_length +let (__proj__Mkcompletion_result__item__completion_candidate : + completion_result -> Prims.string) = + fun projectee -> + match projectee with + | { completion_match_length; completion_candidate; + completion_annotation;_} -> completion_candidate +let (__proj__Mkcompletion_result__item__completion_annotation : + completion_result -> Prims.string) = + fun projectee -> + match projectee with + | { completion_match_length; completion_candidate; + completion_annotation;_} -> completion_annotation +let (json_of_completion_result : completion_result -> FStarC_Json.json) = + fun result -> + FStarC_Json.JsonList + [FStarC_Json.JsonInt (result.completion_match_length); + FStarC_Json.JsonStr (result.completion_annotation); + FStarC_Json.JsonStr (result.completion_candidate)] +let completion_result_of_lid : 'uuuuu . (path * 'uuuuu) -> completion_result + = + fun uu___ -> + match uu___ with + | (path1, _lid) -> + let uu___1 = match_length_of_path path1 in + let uu___2 = string_of_path path1 in + let uu___3 = + let uu___4 = first_import_of_path path1 in + FStarC_Compiler_Util.dflt "" uu___4 in + { + completion_match_length = uu___1; + completion_candidate = uu___2; + completion_annotation = uu___3 + } +let (completion_result_of_mod : + Prims.string -> Prims.bool -> path -> completion_result) = + fun annot -> + fun loaded -> + fun path1 -> + let uu___ = match_length_of_path path1 in + let uu___1 = string_of_path path1 in + let uu___2 = + FStarC_Compiler_Util.format1 (if loaded then " %s " else "(%s)") + annot in + { + completion_match_length = uu___; + completion_candidate = uu___1; + completion_annotation = uu___2 + } +let (completion_result_of_ns_or_mod : + (path * mod_symbol) -> completion_result) = + fun uu___ -> + match uu___ with + | (path1, symb) -> + (match symb with + | Module + { mod_name = uu___1; mod_path = uu___2; mod_loaded = loaded;_} + -> completion_result_of_mod "mod" loaded path1 + | Namespace { ns_name = uu___1; ns_loaded = loaded;_} -> + completion_result_of_mod "ns" loaded path1) +let (find_module_or_ns : + table -> query -> mod_symbol FStar_Pervasives_Native.option) = + fun tbl -> fun query1 -> trie_find_exact tbl.tbl_mods query1 +let (autocomplete_lid : table -> query -> completion_result Prims.list) = + fun tbl -> + fun query1 -> + let uu___ = trie_find_prefix tbl.tbl_lids query1 in + FStarC_Compiler_List.map completion_result_of_lid uu___ +let (autocomplete_mod_or_ns : + table -> + query -> + ((path * mod_symbol) -> + (path * mod_symbol) FStar_Pervasives_Native.option) + -> completion_result Prims.list) + = + fun tbl -> + fun query1 -> + fun filter -> + let uu___ = + let uu___1 = trie_find_prefix tbl.tbl_mods query1 in + FStarC_Compiler_List.filter_map filter uu___1 in + FStarC_Compiler_List.map completion_result_of_ns_or_mod uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Interactive_Ide.ml b/ocaml/fstar-lib/generated/FStarC_Interactive_Ide.ml new file mode 100644 index 00000000000..a797aca766f --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Interactive_Ide.ml @@ -0,0 +1,3141 @@ +open Prims +let (dbg : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "IDE" +let with_captured_errors' : + 'uuuuu . + FStarC_TypeChecker_Env.env -> + FStarC_Compiler_Util.sigint_handler -> + (FStarC_TypeChecker_Env.env -> 'uuuuu FStar_Pervasives_Native.option) + -> 'uuuuu FStar_Pervasives_Native.option + = + fun env -> + fun sigint_handler -> + fun f -> + try + (fun uu___ -> + match () with + | () -> + FStarC_Compiler_Util.with_sigint_handler sigint_handler + (fun uu___1 -> f env)) () + with + | FStarC_Compiler_Effect.Failure msg -> + let msg1 = + Prims.strcat "ASSERTION FAILURE: " + (Prims.strcat msg + "\nF* may be in an inconsistent state.\nPlease file a bug report, ideally with a minimized version of the program that triggered the error.") in + (FStarC_Errors.log_issue FStarC_TypeChecker_Env.hasRange_env env + FStarC_Errors_Codes.Error_IDEAssertionFailure () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic msg1); + FStar_Pervasives_Native.None) + | FStarC_Compiler_Util.SigInt -> + (FStarC_Compiler_Util.print_string "Interrupted"; + FStar_Pervasives_Native.None) + | FStarC_Errors.Error (e, msg, r, ctx) -> + (FStarC_TypeChecker_Err.add_errors env [(e, msg, r, ctx)]; + FStar_Pervasives_Native.None) + | FStarC_Errors.Stop -> FStar_Pervasives_Native.None +let with_captured_errors : + 'uuuuu . + FStarC_TypeChecker_Env.env -> + FStarC_Compiler_Util.sigint_handler -> + (FStarC_TypeChecker_Env.env -> 'uuuuu FStar_Pervasives_Native.option) + -> 'uuuuu FStar_Pervasives_Native.option + = + fun env -> + fun sigint_handler -> + fun f -> + let uu___ = FStarC_Options.trace_error () in + if uu___ then f env else with_captured_errors' env sigint_handler f +type env_t = FStarC_TypeChecker_Env.env +let (repl_current_qid : + Prims.string FStar_Pervasives_Native.option FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None +let (nothing_left_to_pop : + FStarC_Interactive_Ide_Types.repl_state -> Prims.bool) = + fun st -> + let uu___ = + let uu___1 = + FStarC_Compiler_Effect.op_Bang + FStarC_Interactive_PushHelper.repl_stack in + FStarC_Compiler_List.length uu___1 in + uu___ = + (FStarC_Compiler_List.length + st.FStarC_Interactive_Ide_Types.repl_deps_stack) +let (run_repl_transaction : + FStarC_Interactive_Ide_Types.repl_state -> + FStarC_Interactive_Ide_Types.push_kind FStar_Pervasives_Native.option -> + Prims.bool -> + FStarC_Interactive_Ide_Types.repl_task -> + (Prims.bool * FStarC_Interactive_Ide_Types.repl_state)) + = + fun st -> + fun push_kind -> + fun must_rollback -> + fun task -> + let st1 = + FStarC_Interactive_PushHelper.push_repl "run_repl_transaction" + push_kind task st in + let uu___ = + FStarC_Interactive_PushHelper.track_name_changes + st1.FStarC_Interactive_Ide_Types.repl_env in + match uu___ with + | (env, finish_name_tracking) -> + let check_success uu___1 = + (let uu___2 = FStarC_Errors.get_err_count () in + uu___2 = Prims.int_zero) && + (Prims.op_Negation must_rollback) in + let uu___1 = + let uu___2 = + with_captured_errors env FStarC_Compiler_Util.sigint_raise + (fun env1 -> + let uu___3 = + FStarC_Interactive_PushHelper.run_repl_task + st1.FStarC_Interactive_Ide_Types.repl_curmod env1 + task st1.FStarC_Interactive_Ide_Types.repl_lang in + FStar_Pervasives_Native.Some uu___3) in + match uu___2 with + | FStar_Pervasives_Native.Some (curmod, env1, lds) when + check_success () -> (curmod, env1, true, lds) + | uu___3 -> + ((st1.FStarC_Interactive_Ide_Types.repl_curmod), env, + false, []) in + (match uu___1 with + | (curmod, env1, success, lds) -> + let uu___2 = finish_name_tracking env1 in + (match uu___2 with + | (env2, name_events) -> + let st2 = + if success + then + let st3 = + { + FStarC_Interactive_Ide_Types.repl_line = + (st1.FStarC_Interactive_Ide_Types.repl_line); + FStarC_Interactive_Ide_Types.repl_column = + (st1.FStarC_Interactive_Ide_Types.repl_column); + FStarC_Interactive_Ide_Types.repl_fname = + (st1.FStarC_Interactive_Ide_Types.repl_fname); + FStarC_Interactive_Ide_Types.repl_deps_stack + = + (st1.FStarC_Interactive_Ide_Types.repl_deps_stack); + FStarC_Interactive_Ide_Types.repl_curmod = + curmod; + FStarC_Interactive_Ide_Types.repl_env = env2; + FStarC_Interactive_Ide_Types.repl_stdin = + (st1.FStarC_Interactive_Ide_Types.repl_stdin); + FStarC_Interactive_Ide_Types.repl_names = + (st1.FStarC_Interactive_Ide_Types.repl_names); + FStarC_Interactive_Ide_Types.repl_buffered_input_queries + = + (st1.FStarC_Interactive_Ide_Types.repl_buffered_input_queries); + FStarC_Interactive_Ide_Types.repl_lang = + (FStarC_Compiler_List.op_At + (FStarC_Compiler_List.rev lds) + st1.FStarC_Interactive_Ide_Types.repl_lang) + } in + FStarC_Interactive_PushHelper.commit_name_tracking + st3 name_events + else + FStarC_Interactive_PushHelper.pop_repl + "run_repl_transaction" st1 in + (success, st2))) +let (run_repl_ld_transactions : + FStarC_Interactive_Ide_Types.repl_state -> + FStarC_Interactive_Ide_Types.repl_task Prims.list -> + (FStarC_Interactive_Ide_Types.repl_task -> unit) -> + (FStarC_Interactive_Ide_Types.repl_state, + FStarC_Interactive_Ide_Types.repl_state) FStar_Pervasives.either) + = + fun st -> + fun tasks -> + fun progress_callback -> + let debug verb task = + let uu___ = FStarC_Compiler_Effect.op_Bang dbg in + if uu___ + then + let uu___1 = + FStarC_Interactive_Ide_Types.string_of_repl_task task in + FStarC_Compiler_Util.print2 "%s %s" verb uu___1 + else () in + let rec revert_many st1 uu___ = + match uu___ with + | [] -> st1 + | (_id, (task, _st'))::entries -> + (debug "Reverting" task; + (let st' = + FStarC_Interactive_PushHelper.pop_repl + "run_repl_ls_transactions" st1 in + let dep_graph = + FStarC_TypeChecker_Env.dep_graph + st1.FStarC_Interactive_Ide_Types.repl_env in + let st'1 = + let uu___3 = + FStarC_TypeChecker_Env.set_dep_graph + st'.FStarC_Interactive_Ide_Types.repl_env dep_graph in + { + FStarC_Interactive_Ide_Types.repl_line = + (st'.FStarC_Interactive_Ide_Types.repl_line); + FStarC_Interactive_Ide_Types.repl_column = + (st'.FStarC_Interactive_Ide_Types.repl_column); + FStarC_Interactive_Ide_Types.repl_fname = + (st'.FStarC_Interactive_Ide_Types.repl_fname); + FStarC_Interactive_Ide_Types.repl_deps_stack = + (st'.FStarC_Interactive_Ide_Types.repl_deps_stack); + FStarC_Interactive_Ide_Types.repl_curmod = + (st'.FStarC_Interactive_Ide_Types.repl_curmod); + FStarC_Interactive_Ide_Types.repl_env = uu___3; + FStarC_Interactive_Ide_Types.repl_stdin = + (st'.FStarC_Interactive_Ide_Types.repl_stdin); + FStarC_Interactive_Ide_Types.repl_names = + (st'.FStarC_Interactive_Ide_Types.repl_names); + FStarC_Interactive_Ide_Types.repl_buffered_input_queries + = + (st'.FStarC_Interactive_Ide_Types.repl_buffered_input_queries); + FStarC_Interactive_Ide_Types.repl_lang = + (st'.FStarC_Interactive_Ide_Types.repl_lang) + } in + revert_many st'1 entries)) in + let rec aux st1 tasks1 previous = + match (tasks1, previous) with + | ([], []) -> FStar_Pervasives.Inl st1 + | (task::tasks2, []) -> + (debug "Loading" task; + progress_callback task; + (let uu___3 = FStarC_Options.restore_cmd_line_options false in + ()); + (let timestamped_task = + FStarC_Interactive_PushHelper.update_task_timestamps task in + let push_kind = + let uu___3 = FStarC_Options.lax () in + if uu___3 + then FStarC_Interactive_Ide_Types.LaxCheck + else FStarC_Interactive_Ide_Types.FullCheck in + let uu___3 = + run_repl_transaction st1 + (FStar_Pervasives_Native.Some push_kind) false + timestamped_task in + match uu___3 with + | (success, st2) -> + if success + then + let uu___4 = + let uu___5 = + FStarC_Compiler_Effect.op_Bang + FStarC_Interactive_PushHelper.repl_stack in + { + FStarC_Interactive_Ide_Types.repl_line = + (st2.FStarC_Interactive_Ide_Types.repl_line); + FStarC_Interactive_Ide_Types.repl_column = + (st2.FStarC_Interactive_Ide_Types.repl_column); + FStarC_Interactive_Ide_Types.repl_fname = + (st2.FStarC_Interactive_Ide_Types.repl_fname); + FStarC_Interactive_Ide_Types.repl_deps_stack = + uu___5; + FStarC_Interactive_Ide_Types.repl_curmod = + (st2.FStarC_Interactive_Ide_Types.repl_curmod); + FStarC_Interactive_Ide_Types.repl_env = + (st2.FStarC_Interactive_Ide_Types.repl_env); + FStarC_Interactive_Ide_Types.repl_stdin = + (st2.FStarC_Interactive_Ide_Types.repl_stdin); + FStarC_Interactive_Ide_Types.repl_names = + (st2.FStarC_Interactive_Ide_Types.repl_names); + FStarC_Interactive_Ide_Types.repl_buffered_input_queries + = + (st2.FStarC_Interactive_Ide_Types.repl_buffered_input_queries); + FStarC_Interactive_Ide_Types.repl_lang = + (st2.FStarC_Interactive_Ide_Types.repl_lang) + } in + aux uu___4 tasks2 [] + else FStar_Pervasives.Inr st2)) + | (task::tasks2, prev::previous1) when + let uu___ = + FStarC_Interactive_PushHelper.update_task_timestamps task in + (FStar_Pervasives_Native.fst (FStar_Pervasives_Native.snd prev)) + = uu___ + -> (debug "Skipping" task; aux st1 tasks2 previous1) + | (tasks2, previous1) -> + let uu___ = revert_many st1 previous1 in aux uu___ tasks2 [] in + aux st tasks + (FStarC_Compiler_List.rev + st.FStarC_Interactive_Ide_Types.repl_deps_stack) +let (wrap_js_failure : + Prims.string -> + Prims.string -> FStarC_Json.json -> FStarC_Interactive_Ide_Types.query) + = + fun qid -> + fun expected -> + fun got -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Interactive_JsonHelper.json_debug got in + FStarC_Compiler_Util.format2 + "JSON decoding failed: expected %s, got %s" expected uu___2 in + FStarC_Interactive_Ide_Types.ProtocolViolation uu___1 in + { + FStarC_Interactive_Ide_Types.qq = uu___; + FStarC_Interactive_Ide_Types.qid = qid + } +let (unpack_interactive_query : + FStarC_Json.json -> FStarC_Interactive_Ide_Types.query) = + fun json -> + let assoc errloc key a = + let uu___ = FStarC_Interactive_JsonHelper.try_assoc key a in + match uu___ with + | FStar_Pervasives_Native.Some v -> v + | FStar_Pervasives_Native.None -> + let uu___1 = + let uu___2 = + FStarC_Compiler_Util.format2 "Missing key [%s] in %s." key + errloc in + FStarC_Interactive_JsonHelper.InvalidQuery uu___2 in + FStarC_Compiler_Effect.raise uu___1 in + let request = FStarC_Interactive_JsonHelper.js_assoc json in + let qid = + let uu___ = assoc "query" "query-id" request in + FStarC_Interactive_JsonHelper.js_str uu___ in + try + (fun uu___ -> + match () with + | () -> + let query = + let uu___1 = assoc "query" "query" request in + FStarC_Interactive_JsonHelper.js_str uu___1 in + let args = + let uu___1 = assoc "query" "args" request in + FStarC_Interactive_JsonHelper.js_assoc uu___1 in + let arg k = assoc "[args]" k args in + let try_arg k = + let uu___1 = FStarC_Interactive_JsonHelper.try_assoc k args in + match uu___1 with + | FStar_Pervasives_Native.Some (FStarC_Json.JsonNull) -> + FStar_Pervasives_Native.None + | other -> other in + let read_position err loc = + let uu___1 = + let uu___2 = assoc err "filename" loc in + FStarC_Interactive_JsonHelper.js_str uu___2 in + let uu___2 = + let uu___3 = assoc err "line" loc in + FStarC_Interactive_JsonHelper.js_int uu___3 in + let uu___3 = + let uu___4 = assoc err "column" loc in + FStarC_Interactive_JsonHelper.js_int uu___4 in + (uu___1, uu___2, uu___3) in + let read_to_position uu___1 = + let to_pos = + let uu___2 = arg "to-position" in + FStarC_Interactive_JsonHelper.js_assoc uu___2 in + let uu___2 = + let uu___3 = assoc "to-position.line" "line" to_pos in + FStarC_Interactive_JsonHelper.js_int uu___3 in + let uu___3 = + let uu___4 = assoc "to-position.column" "column" to_pos in + FStarC_Interactive_JsonHelper.js_int uu___4 in + ("", uu___2, uu___3) in + let parse_full_buffer_kind kind = + match kind with + | "full" -> FStarC_Interactive_Ide_Types.Full + | "lax" -> FStarC_Interactive_Ide_Types.Lax + | "cache" -> FStarC_Interactive_Ide_Types.Cache + | "reload-deps" -> FStarC_Interactive_Ide_Types.ReloadDeps + | "verify-to-position" -> + let uu___1 = read_to_position () in + FStarC_Interactive_Ide_Types.VerifyToPosition uu___1 + | "lax-to-position" -> + let uu___1 = read_to_position () in + FStarC_Interactive_Ide_Types.LaxToPosition uu___1 + | uu___1 -> + FStarC_Compiler_Effect.raise + (FStarC_Interactive_JsonHelper.InvalidQuery + "Invalid full-buffer kind") in + let uu___1 = + match query with + | "exit" -> FStarC_Interactive_Ide_Types.Exit + | "pop" -> FStarC_Interactive_Ide_Types.Pop + | "describe-protocol" -> + FStarC_Interactive_Ide_Types.DescribeProtocol + | "describe-repl" -> FStarC_Interactive_Ide_Types.DescribeRepl + | "segment" -> + let uu___2 = + let uu___3 = arg "code" in + FStarC_Interactive_JsonHelper.js_str uu___3 in + FStarC_Interactive_Ide_Types.Segment uu___2 + | "peek" -> + let uu___2 = + let uu___3 = + let uu___4 = arg "kind" in + FStarC_Interactive_Ide_Types.js_pushkind uu___4 in + let uu___4 = + let uu___5 = arg "line" in + FStarC_Interactive_JsonHelper.js_int uu___5 in + let uu___5 = + let uu___6 = arg "column" in + FStarC_Interactive_JsonHelper.js_int uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = arg "code" in + FStarC_Interactive_JsonHelper.js_str uu___8 in + FStar_Pervasives.Inl uu___7 in + { + FStarC_Interactive_Ide_Types.push_kind = uu___3; + FStarC_Interactive_Ide_Types.push_line = uu___4; + FStarC_Interactive_Ide_Types.push_column = uu___5; + FStarC_Interactive_Ide_Types.push_peek_only = + (query = "peek"); + FStarC_Interactive_Ide_Types.push_code_or_decl = + uu___6 + } in + FStarC_Interactive_Ide_Types.Push uu___2 + | "push" -> + let uu___2 = + let uu___3 = + let uu___4 = arg "kind" in + FStarC_Interactive_Ide_Types.js_pushkind uu___4 in + let uu___4 = + let uu___5 = arg "line" in + FStarC_Interactive_JsonHelper.js_int uu___5 in + let uu___5 = + let uu___6 = arg "column" in + FStarC_Interactive_JsonHelper.js_int uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = arg "code" in + FStarC_Interactive_JsonHelper.js_str uu___8 in + FStar_Pervasives.Inl uu___7 in + { + FStarC_Interactive_Ide_Types.push_kind = uu___3; + FStarC_Interactive_Ide_Types.push_line = uu___4; + FStarC_Interactive_Ide_Types.push_column = uu___5; + FStarC_Interactive_Ide_Types.push_peek_only = + (query = "peek"); + FStarC_Interactive_Ide_Types.push_code_or_decl = + uu___6 + } in + FStarC_Interactive_Ide_Types.Push uu___2 + | "push-partial-checked-file" -> + let uu___2 = + let uu___3 = arg "until-lid" in + FStarC_Interactive_JsonHelper.js_str uu___3 in + FStarC_Interactive_Ide_Types.PushPartialCheckedFile uu___2 + | "full-buffer" -> + let uu___2 = + let uu___3 = + let uu___4 = arg "code" in + FStarC_Interactive_JsonHelper.js_str uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = arg "kind" in + FStarC_Interactive_JsonHelper.js_str uu___6 in + parse_full_buffer_kind uu___5 in + let uu___5 = + let uu___6 = arg "with-symbols" in + FStarC_Interactive_JsonHelper.js_bool uu___6 in + (uu___3, uu___4, uu___5) in + FStarC_Interactive_Ide_Types.FullBuffer uu___2 + | "autocomplete" -> + let uu___2 = + let uu___3 = + let uu___4 = arg "partial-symbol" in + FStarC_Interactive_JsonHelper.js_str uu___4 in + let uu___4 = + let uu___5 = try_arg "context" in + FStarC_Interactive_Ide_Types.js_optional_completion_context + uu___5 in + (uu___3, uu___4) in + FStarC_Interactive_Ide_Types.AutoComplete uu___2 + | "lookup" -> + let uu___2 = + let uu___3 = + let uu___4 = arg "symbol" in + FStarC_Interactive_JsonHelper.js_str uu___4 in + let uu___4 = + let uu___5 = try_arg "context" in + FStarC_Interactive_Ide_Types.js_optional_lookup_context + uu___5 in + let uu___5 = + let uu___6 = + let uu___7 = try_arg "location" in + FStarC_Compiler_Util.map_option + FStarC_Interactive_JsonHelper.js_assoc uu___7 in + FStarC_Compiler_Util.map_option + (read_position "[location]") uu___6 in + let uu___6 = + let uu___7 = arg "requested-info" in + FStarC_Interactive_JsonHelper.js_list + FStarC_Interactive_JsonHelper.js_str uu___7 in + let uu___7 = try_arg "symbol-range" in + (uu___3, uu___4, uu___5, uu___6, uu___7) in + FStarC_Interactive_Ide_Types.Lookup uu___2 + | "compute" -> + let uu___2 = + let uu___3 = + let uu___4 = arg "term" in + FStarC_Interactive_JsonHelper.js_str uu___4 in + let uu___4 = + let uu___5 = try_arg "rules" in + FStarC_Compiler_Util.map_option + (FStarC_Interactive_JsonHelper.js_list + FStarC_Interactive_Ide_Types.js_reductionrule) + uu___5 in + (uu___3, uu___4) in + FStarC_Interactive_Ide_Types.Compute uu___2 + | "search" -> + let uu___2 = + let uu___3 = arg "terms" in + FStarC_Interactive_JsonHelper.js_str uu___3 in + FStarC_Interactive_Ide_Types.Search uu___2 + | "vfs-add" -> + let uu___2 = + let uu___3 = + let uu___4 = try_arg "filename" in + FStarC_Compiler_Util.map_option + FStarC_Interactive_JsonHelper.js_str uu___4 in + let uu___4 = + let uu___5 = arg "contents" in + FStarC_Interactive_JsonHelper.js_str uu___5 in + (uu___3, uu___4) in + FStarC_Interactive_Ide_Types.VfsAdd uu___2 + | "format" -> + let uu___2 = + let uu___3 = arg "code" in + FStarC_Interactive_JsonHelper.js_str uu___3 in + FStarC_Interactive_Ide_Types.Format uu___2 + | "restart-solver" -> + FStarC_Interactive_Ide_Types.RestartSolver + | "cancel" -> + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = arg "cancel-line" in + FStarC_Interactive_JsonHelper.js_int uu___5 in + let uu___5 = + let uu___6 = arg "cancel-column" in + FStarC_Interactive_JsonHelper.js_int uu___6 in + ("", uu___4, uu___5) in + FStar_Pervasives_Native.Some uu___3 in + FStarC_Interactive_Ide_Types.Cancel uu___2 + | uu___2 -> + let uu___3 = + FStarC_Compiler_Util.format1 "Unknown query '%s'" query in + FStarC_Interactive_Ide_Types.ProtocolViolation uu___3 in + { + FStarC_Interactive_Ide_Types.qq = uu___1; + FStarC_Interactive_Ide_Types.qid = qid + }) () + with + | FStarC_Interactive_JsonHelper.InvalidQuery msg -> + { + FStarC_Interactive_Ide_Types.qq = + (FStarC_Interactive_Ide_Types.ProtocolViolation msg); + FStarC_Interactive_Ide_Types.qid = qid + } + | FStarC_Interactive_JsonHelper.UnexpectedJsonType (expected, got) -> + wrap_js_failure qid expected got +let (deserialize_interactive_query : + FStarC_Json.json -> FStarC_Interactive_Ide_Types.query) = + fun js_query -> + try + (fun uu___ -> match () with | () -> unpack_interactive_query js_query) + () + with + | FStarC_Interactive_JsonHelper.InvalidQuery msg -> + { + FStarC_Interactive_Ide_Types.qq = + (FStarC_Interactive_Ide_Types.ProtocolViolation msg); + FStarC_Interactive_Ide_Types.qid = "?" + } + | FStarC_Interactive_JsonHelper.UnexpectedJsonType (expected, got) -> + wrap_js_failure "?" expected got +let (parse_interactive_query : + Prims.string -> FStarC_Interactive_Ide_Types.query) = + fun query_str -> + let uu___ = FStarC_Json.json_of_string query_str in + match uu___ with + | FStar_Pervasives_Native.None -> + { + FStarC_Interactive_Ide_Types.qq = + (FStarC_Interactive_Ide_Types.ProtocolViolation + "Json parsing failed."); + FStarC_Interactive_Ide_Types.qid = "?" + } + | FStar_Pervasives_Native.Some request -> + deserialize_interactive_query request +let (buffer_input_queries : + FStarC_Interactive_Ide_Types.repl_state -> + FStarC_Interactive_Ide_Types.repl_state) + = + fun st -> + let rec aux qs st1 = + let done1 qs1 st2 = + { + FStarC_Interactive_Ide_Types.repl_line = + (st2.FStarC_Interactive_Ide_Types.repl_line); + FStarC_Interactive_Ide_Types.repl_column = + (st2.FStarC_Interactive_Ide_Types.repl_column); + FStarC_Interactive_Ide_Types.repl_fname = + (st2.FStarC_Interactive_Ide_Types.repl_fname); + FStarC_Interactive_Ide_Types.repl_deps_stack = + (st2.FStarC_Interactive_Ide_Types.repl_deps_stack); + FStarC_Interactive_Ide_Types.repl_curmod = + (st2.FStarC_Interactive_Ide_Types.repl_curmod); + FStarC_Interactive_Ide_Types.repl_env = + (st2.FStarC_Interactive_Ide_Types.repl_env); + FStarC_Interactive_Ide_Types.repl_stdin = + (st2.FStarC_Interactive_Ide_Types.repl_stdin); + FStarC_Interactive_Ide_Types.repl_names = + (st2.FStarC_Interactive_Ide_Types.repl_names); + FStarC_Interactive_Ide_Types.repl_buffered_input_queries = + (FStarC_Compiler_List.op_At + st2.FStarC_Interactive_Ide_Types.repl_buffered_input_queries + (FStarC_Compiler_List.rev qs1)); + FStarC_Interactive_Ide_Types.repl_lang = + (st2.FStarC_Interactive_Ide_Types.repl_lang) + } in + let uu___ = + let uu___1 = + FStarC_Compiler_Util.poll_stdin + (FStarC_Compiler_Util.float_of_string "0.0") in + Prims.op_Negation uu___1 in + if uu___ + then done1 qs st1 + else + (let uu___2 = + FStarC_Compiler_Util.read_line + st1.FStarC_Interactive_Ide_Types.repl_stdin in + match uu___2 with + | FStar_Pervasives_Native.None -> done1 qs st1 + | FStar_Pervasives_Native.Some line -> + let q = parse_interactive_query line in + (match q.FStarC_Interactive_Ide_Types.qq with + | FStarC_Interactive_Ide_Types.Cancel uu___3 -> + { + FStarC_Interactive_Ide_Types.repl_line = + (st1.FStarC_Interactive_Ide_Types.repl_line); + FStarC_Interactive_Ide_Types.repl_column = + (st1.FStarC_Interactive_Ide_Types.repl_column); + FStarC_Interactive_Ide_Types.repl_fname = + (st1.FStarC_Interactive_Ide_Types.repl_fname); + FStarC_Interactive_Ide_Types.repl_deps_stack = + (st1.FStarC_Interactive_Ide_Types.repl_deps_stack); + FStarC_Interactive_Ide_Types.repl_curmod = + (st1.FStarC_Interactive_Ide_Types.repl_curmod); + FStarC_Interactive_Ide_Types.repl_env = + (st1.FStarC_Interactive_Ide_Types.repl_env); + FStarC_Interactive_Ide_Types.repl_stdin = + (st1.FStarC_Interactive_Ide_Types.repl_stdin); + FStarC_Interactive_Ide_Types.repl_names = + (st1.FStarC_Interactive_Ide_Types.repl_names); + FStarC_Interactive_Ide_Types.repl_buffered_input_queries + = [q]; + FStarC_Interactive_Ide_Types.repl_lang = + (st1.FStarC_Interactive_Ide_Types.repl_lang) + } + | uu___3 -> aux (q :: qs) st1)) in + aux [] st +let (read_interactive_query : + FStarC_Interactive_Ide_Types.repl_state -> + (FStarC_Interactive_Ide_Types.query * + FStarC_Interactive_Ide_Types.repl_state)) + = + fun st -> + match st.FStarC_Interactive_Ide_Types.repl_buffered_input_queries with + | [] -> + let uu___ = + FStarC_Compiler_Util.read_line + st.FStarC_Interactive_Ide_Types.repl_stdin in + (match uu___ with + | FStar_Pervasives_Native.None -> + FStarC_Compiler_Effect.exit Prims.int_zero + | FStar_Pervasives_Native.Some line -> + let uu___1 = parse_interactive_query line in (uu___1, st)) + | q::qs -> + (q, + { + FStarC_Interactive_Ide_Types.repl_line = + (st.FStarC_Interactive_Ide_Types.repl_line); + FStarC_Interactive_Ide_Types.repl_column = + (st.FStarC_Interactive_Ide_Types.repl_column); + FStarC_Interactive_Ide_Types.repl_fname = + (st.FStarC_Interactive_Ide_Types.repl_fname); + FStarC_Interactive_Ide_Types.repl_deps_stack = + (st.FStarC_Interactive_Ide_Types.repl_deps_stack); + FStarC_Interactive_Ide_Types.repl_curmod = + (st.FStarC_Interactive_Ide_Types.repl_curmod); + FStarC_Interactive_Ide_Types.repl_env = + (st.FStarC_Interactive_Ide_Types.repl_env); + FStarC_Interactive_Ide_Types.repl_stdin = + (st.FStarC_Interactive_Ide_Types.repl_stdin); + FStarC_Interactive_Ide_Types.repl_names = + (st.FStarC_Interactive_Ide_Types.repl_names); + FStarC_Interactive_Ide_Types.repl_buffered_input_queries = qs; + FStarC_Interactive_Ide_Types.repl_lang = + (st.FStarC_Interactive_Ide_Types.repl_lang) + }) +let json_of_opt : + 'uuuuu . + ('uuuuu -> FStarC_Json.json) -> + 'uuuuu FStar_Pervasives_Native.option -> FStarC_Json.json + = + fun json_of_a -> + fun opt_a -> + let uu___ = FStarC_Compiler_Util.map_option json_of_a opt_a in + FStarC_Compiler_Util.dflt FStarC_Json.JsonNull uu___ +let (alist_of_symbol_lookup_result : + FStarC_Interactive_QueryHelper.sl_reponse -> + Prims.string -> + FStarC_Json.json FStar_Pervasives_Native.option -> + (Prims.string * FStarC_Json.json) Prims.list) + = + fun lr -> + fun symbol -> + fun symrange_opt -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + json_of_opt FStarC_Compiler_Range_Ops.json_of_def_range + lr.FStarC_Interactive_QueryHelper.slr_def_range in + ("defined-at", uu___3) in + let uu___3 = + let uu___4 = + let uu___5 = + json_of_opt (fun uu___6 -> FStarC_Json.JsonStr uu___6) + lr.FStarC_Interactive_QueryHelper.slr_typ in + ("type", uu___5) in + let uu___5 = + let uu___6 = + let uu___7 = + json_of_opt (fun uu___8 -> FStarC_Json.JsonStr uu___8) + lr.FStarC_Interactive_QueryHelper.slr_doc in + ("documentation", uu___7) in + let uu___7 = + let uu___8 = + let uu___9 = + json_of_opt + (fun uu___10 -> FStarC_Json.JsonStr uu___10) + lr.FStarC_Interactive_QueryHelper.slr_def in + ("definition", uu___9) in + [uu___8] in + uu___6 :: uu___7 in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + ("name", + (FStarC_Json.JsonStr (lr.FStarC_Interactive_QueryHelper.slr_name))) + :: uu___1 in + let uu___1 = + match symrange_opt with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some symrange -> + let uu___2 = + let uu___3 = json_of_opt (fun x -> x) symrange_opt in + ("symbol-range", uu___3) in + [uu___2; ("symbol", (FStarC_Json.JsonStr symbol))] in + FStarC_Compiler_List.op_At uu___ uu___1 +let (alist_of_protocol_info : (Prims.string * FStarC_Json.json) Prims.list) = + let js_version = + FStarC_Json.JsonInt + FStarC_Interactive_Ide_Types.interactive_protocol_vernum in + let js_features = + let uu___ = + FStarC_Compiler_List.map (fun uu___1 -> FStarC_Json.JsonStr uu___1) + FStarC_Interactive_Ide_Types.interactive_protocol_features in + FStarC_Json.JsonList uu___ in + [("version", js_version); ("features", js_features)] +type fstar_option_permission_level = + | OptSet + | OptReadOnly +let (uu___is_OptSet : fstar_option_permission_level -> Prims.bool) = + fun projectee -> match projectee with | OptSet -> true | uu___ -> false +let (uu___is_OptReadOnly : fstar_option_permission_level -> Prims.bool) = + fun projectee -> + match projectee with | OptReadOnly -> true | uu___ -> false +let (string_of_option_permission_level : + fstar_option_permission_level -> Prims.string) = + fun uu___ -> match uu___ with | OptSet -> "" | OptReadOnly -> "read-only" +type fstar_option = + { + opt_name: Prims.string ; + opt_sig: Prims.string ; + opt_value: FStarC_Options.option_val ; + opt_default: FStarC_Options.option_val ; + opt_type: FStarC_Options.opt_type ; + opt_snippets: Prims.string Prims.list ; + opt_documentation: Prims.string FStar_Pervasives_Native.option ; + opt_permission_level: fstar_option_permission_level } +let (__proj__Mkfstar_option__item__opt_name : fstar_option -> Prims.string) = + fun projectee -> + match projectee with + | { opt_name; opt_sig; opt_value; opt_default; opt_type; opt_snippets; + opt_documentation; opt_permission_level;_} -> opt_name +let (__proj__Mkfstar_option__item__opt_sig : fstar_option -> Prims.string) = + fun projectee -> + match projectee with + | { opt_name; opt_sig; opt_value; opt_default; opt_type; opt_snippets; + opt_documentation; opt_permission_level;_} -> opt_sig +let (__proj__Mkfstar_option__item__opt_value : + fstar_option -> FStarC_Options.option_val) = + fun projectee -> + match projectee with + | { opt_name; opt_sig; opt_value; opt_default; opt_type; opt_snippets; + opt_documentation; opt_permission_level;_} -> opt_value +let (__proj__Mkfstar_option__item__opt_default : + fstar_option -> FStarC_Options.option_val) = + fun projectee -> + match projectee with + | { opt_name; opt_sig; opt_value; opt_default; opt_type; opt_snippets; + opt_documentation; opt_permission_level;_} -> opt_default +let (__proj__Mkfstar_option__item__opt_type : + fstar_option -> FStarC_Options.opt_type) = + fun projectee -> + match projectee with + | { opt_name; opt_sig; opt_value; opt_default; opt_type; opt_snippets; + opt_documentation; opt_permission_level;_} -> opt_type +let (__proj__Mkfstar_option__item__opt_snippets : + fstar_option -> Prims.string Prims.list) = + fun projectee -> + match projectee with + | { opt_name; opt_sig; opt_value; opt_default; opt_type; opt_snippets; + opt_documentation; opt_permission_level;_} -> opt_snippets +let (__proj__Mkfstar_option__item__opt_documentation : + fstar_option -> Prims.string FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { opt_name; opt_sig; opt_value; opt_default; opt_type; opt_snippets; + opt_documentation; opt_permission_level;_} -> opt_documentation +let (__proj__Mkfstar_option__item__opt_permission_level : + fstar_option -> fstar_option_permission_level) = + fun projectee -> + match projectee with + | { opt_name; opt_sig; opt_value; opt_default; opt_type; opt_snippets; + opt_documentation; opt_permission_level;_} -> opt_permission_level +let rec (kind_of_fstar_option_type : FStarC_Options.opt_type -> Prims.string) + = + fun uu___ -> + match uu___ with + | FStarC_Options.Const uu___1 -> "flag" + | FStarC_Options.IntStr uu___1 -> "int" + | FStarC_Options.BoolStr -> "bool" + | FStarC_Options.PathStr uu___1 -> "path" + | FStarC_Options.SimpleStr uu___1 -> "string" + | FStarC_Options.EnumStr uu___1 -> "enum" + | FStarC_Options.OpenEnumStr uu___1 -> "open enum" + | FStarC_Options.PostProcessed (uu___1, typ) -> + kind_of_fstar_option_type typ + | FStarC_Options.Accumulated typ -> kind_of_fstar_option_type typ + | FStarC_Options.ReverseAccumulated typ -> kind_of_fstar_option_type typ + | FStarC_Options.WithSideEffect (uu___1, typ) -> + kind_of_fstar_option_type typ +let (snippets_of_fstar_option : + Prims.string -> FStarC_Options.opt_type -> Prims.string Prims.list) = + fun name -> + fun typ -> + let mk_field field_name = + Prims.strcat "${" (Prims.strcat field_name "}") in + let mk_snippet name1 argstring = + Prims.strcat "--" + (Prims.strcat name1 + (if argstring <> "" then Prims.strcat " " argstring else "")) in + let rec arg_snippets_of_type typ1 = + match typ1 with + | FStarC_Options.Const uu___ -> [""] + | FStarC_Options.BoolStr -> ["true"; "false"] + | FStarC_Options.IntStr desc -> [mk_field desc] + | FStarC_Options.PathStr desc -> [mk_field desc] + | FStarC_Options.SimpleStr desc -> [mk_field desc] + | FStarC_Options.EnumStr strs -> strs + | FStarC_Options.OpenEnumStr (strs, desc) -> + FStarC_Compiler_List.op_At strs [mk_field desc] + | FStarC_Options.PostProcessed (uu___, elem_spec) -> + arg_snippets_of_type elem_spec + | FStarC_Options.Accumulated elem_spec -> + arg_snippets_of_type elem_spec + | FStarC_Options.ReverseAccumulated elem_spec -> + arg_snippets_of_type elem_spec + | FStarC_Options.WithSideEffect (uu___, elem_spec) -> + arg_snippets_of_type elem_spec in + let uu___ = arg_snippets_of_type typ in + FStarC_Compiler_List.map (mk_snippet name) uu___ +let rec (json_of_fstar_option_value : + FStarC_Options.option_val -> FStarC_Json.json) = + fun uu___ -> + match uu___ with + | FStarC_Options.Bool b -> FStarC_Json.JsonBool b + | FStarC_Options.String s -> FStarC_Json.JsonStr s + | FStarC_Options.Path s -> FStarC_Json.JsonStr s + | FStarC_Options.Int n -> FStarC_Json.JsonInt n + | FStarC_Options.List vs -> + let uu___1 = FStarC_Compiler_List.map json_of_fstar_option_value vs in + FStarC_Json.JsonList uu___1 + | FStarC_Options.Unset -> FStarC_Json.JsonNull +let (alist_of_fstar_option : + fstar_option -> (Prims.string * FStarC_Json.json) Prims.list) = + fun opt -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = json_of_fstar_option_value opt.opt_value in + ("value", uu___3) in + let uu___3 = + let uu___4 = + let uu___5 = json_of_fstar_option_value opt.opt_default in + ("default", uu___5) in + let uu___5 = + let uu___6 = + let uu___7 = + json_of_opt (fun uu___8 -> FStarC_Json.JsonStr uu___8) + opt.opt_documentation in + ("documentation", uu___7) in + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = kind_of_fstar_option_type opt.opt_type in + FStarC_Json.JsonStr uu___10 in + ("type", uu___9) in + [uu___8; + ("permission-level", + (FStarC_Json.JsonStr + (string_of_option_permission_level + opt.opt_permission_level)))] in + uu___6 :: uu___7 in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + ("signature", (FStarC_Json.JsonStr (opt.opt_sig))) :: uu___1 in + ("name", (FStarC_Json.JsonStr (opt.opt_name))) :: uu___ +let (json_of_fstar_option : fstar_option -> FStarC_Json.json) = + fun opt -> + let uu___ = alist_of_fstar_option opt in FStarC_Json.JsonAssoc uu___ +let (json_of_response : + Prims.string -> + FStarC_Interactive_Ide_Types.query_status -> + FStarC_Json.json -> FStarC_Json.json) + = + fun qid -> + fun status -> + fun response -> + let qid1 = FStarC_Json.JsonStr qid in + let status1 = + match status with + | FStarC_Interactive_Ide_Types.QueryOK -> + FStarC_Json.JsonStr "success" + | FStarC_Interactive_Ide_Types.QueryNOK -> + FStarC_Json.JsonStr "failure" + | FStarC_Interactive_Ide_Types.QueryViolatesProtocol -> + FStarC_Json.JsonStr "protocol-violation" in + FStarC_Json.JsonAssoc + [("kind", (FStarC_Json.JsonStr "response")); + ("query-id", qid1); + ("status", status1); + ("response", response)] +let (write_response : + Prims.string -> + FStarC_Interactive_Ide_Types.query_status -> FStarC_Json.json -> unit) + = + fun qid -> + fun status -> + fun response -> + FStarC_Interactive_JsonHelper.write_json + (json_of_response qid status response) +let (json_of_message : Prims.string -> FStarC_Json.json -> FStarC_Json.json) + = + fun level -> + fun js_contents -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Compiler_Effect.op_Bang repl_current_qid in + json_of_opt (fun uu___5 -> FStarC_Json.JsonStr uu___5) uu___4 in + ("query-id", uu___3) in + [uu___2; + ("level", (FStarC_Json.JsonStr level)); + ("contents", js_contents)] in + ("kind", (FStarC_Json.JsonStr "message")) :: uu___1 in + FStarC_Json.JsonAssoc uu___ +let forward_message : + 'uuuuu . + (FStarC_Json.json -> 'uuuuu) -> + Prims.string -> FStarC_Json.json -> 'uuuuu + = + fun callback -> + fun level -> + fun contents -> + let uu___ = json_of_message level contents in callback uu___ +let (json_of_hello : FStarC_Json.json) = + let js_version = + FStarC_Json.JsonInt + FStarC_Interactive_Ide_Types.interactive_protocol_vernum in + let js_features = + let uu___ = + FStarC_Compiler_List.map (fun uu___1 -> FStarC_Json.JsonStr uu___1) + FStarC_Interactive_Ide_Types.interactive_protocol_features in + FStarC_Json.JsonList uu___ in + FStarC_Json.JsonAssoc (("kind", (FStarC_Json.JsonStr "protocol-info")) :: + alist_of_protocol_info) +let (write_hello : unit -> unit) = + fun uu___ -> FStarC_Interactive_JsonHelper.write_json json_of_hello +let (sig_of_fstar_option : + Prims.string -> FStarC_Options.opt_type -> Prims.string) = + fun name -> + fun typ -> + let flag = Prims.strcat "--" name in + let uu___ = FStarC_Options.desc_of_opt_type typ in + match uu___ with + | FStar_Pervasives_Native.None -> flag + | FStar_Pervasives_Native.Some arg_sig -> + Prims.strcat flag (Prims.strcat " " arg_sig) +let (fstar_options_list_cache : fstar_option Prims.list) = + let defaults = FStarC_Compiler_Util.smap_of_list FStarC_Options.defaults in + let uu___ = + FStarC_Compiler_List.filter_map + (fun uu___1 -> + match uu___1 with + | (_shortname, name, typ, doc) -> + let uu___2 = FStarC_Compiler_Util.smap_try_find defaults name in + FStarC_Compiler_Util.map_option + (fun default_value -> + let uu___3 = sig_of_fstar_option name typ in + let uu___4 = snippets_of_fstar_option name typ in + let uu___5 = + if doc = FStarC_Pprint.empty + then FStar_Pervasives_Native.None + else + (let uu___7 = FStarC_Errors_Msg.renderdoc doc in + FStar_Pervasives_Native.Some uu___7) in + let uu___6 = + let uu___7 = FStarC_Options.settable name in + if uu___7 then OptSet else OptReadOnly in + { + opt_name = name; + opt_sig = uu___3; + opt_value = FStarC_Options.Unset; + opt_default = default_value; + opt_type = typ; + opt_snippets = uu___4; + opt_documentation = uu___5; + opt_permission_level = uu___6 + }) uu___2) FStarC_Options.all_specs_with_types in + FStarC_Compiler_List.sortWith + (fun o1 -> + fun o2 -> + FStarC_Compiler_String.compare + (FStarC_Compiler_String.lowercase o1.opt_name) + (FStarC_Compiler_String.lowercase o2.opt_name)) uu___ +let (fstar_options_map_cache : fstar_option FStarC_Compiler_Util.smap) = + let cache = FStarC_Compiler_Util.smap_create (Prims.of_int (50)) in + FStarC_Compiler_List.iter + (fun opt -> FStarC_Compiler_Util.smap_add cache opt.opt_name opt) + fstar_options_list_cache; + cache +let (update_option : fstar_option -> fstar_option) = + fun opt -> + let uu___ = FStarC_Options.get_option opt.opt_name in + { + opt_name = (opt.opt_name); + opt_sig = (opt.opt_sig); + opt_value = uu___; + opt_default = (opt.opt_default); + opt_type = (opt.opt_type); + opt_snippets = (opt.opt_snippets); + opt_documentation = (opt.opt_documentation); + opt_permission_level = (opt.opt_permission_level) + } +let (current_fstar_options : + (fstar_option -> Prims.bool) -> fstar_option Prims.list) = + fun filter -> + let uu___ = FStarC_Compiler_List.filter filter fstar_options_list_cache in + FStarC_Compiler_List.map update_option uu___ +let (trim_option_name : Prims.string -> (Prims.string * Prims.string)) = + fun opt_name -> + let opt_prefix = "--" in + if FStarC_Compiler_Util.starts_with opt_name opt_prefix + then + let uu___ = + FStarC_Compiler_Util.substring_from opt_name + (FStarC_Compiler_String.length opt_prefix) in + (opt_prefix, uu___) + else ("", opt_name) +let (json_of_repl_state : + FStarC_Interactive_Ide_Types.repl_state -> FStarC_Json.json) = + fun st -> + let filenames uu___ = + match uu___ with + | (uu___1, (task, uu___2)) -> + (match task with + | FStarC_Interactive_Ide_Types.LDInterleaved (intf, impl) -> + [intf.FStarC_Interactive_Ide_Types.tf_fname; + impl.FStarC_Interactive_Ide_Types.tf_fname] + | FStarC_Interactive_Ide_Types.LDSingle intf_or_impl -> + [intf_or_impl.FStarC_Interactive_Ide_Types.tf_fname] + | FStarC_Interactive_Ide_Types.LDInterfaceOfCurrentFile intf -> + [intf.FStarC_Interactive_Ide_Types.tf_fname] + | uu___3 -> []) in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Compiler_List.concatMap filenames + st.FStarC_Interactive_Ide_Types.repl_deps_stack in + FStarC_Compiler_List.map + (fun uu___5 -> FStarC_Json.JsonStr uu___5) uu___4 in + FStarC_Json.JsonList uu___3 in + ("loaded-dependencies", uu___2) in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = current_fstar_options (fun uu___7 -> true) in + FStarC_Compiler_List.map json_of_fstar_option uu___6 in + FStarC_Json.JsonList uu___5 in + ("options", uu___4) in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Json.JsonAssoc uu___ +let run_exit : + 'uuuuu 'uuuuu1 . + 'uuuuu -> + ((FStarC_Interactive_Ide_Types.query_status * FStarC_Json.json) * + ('uuuuu1, Prims.int) FStar_Pervasives.either) + = + fun st -> + ((FStarC_Interactive_Ide_Types.QueryOK, FStarC_Json.JsonNull), + (FStar_Pervasives.Inr Prims.int_zero)) +let run_describe_protocol : + 'uuuuu 'uuuuu1 . + 'uuuuu -> + ((FStarC_Interactive_Ide_Types.query_status * FStarC_Json.json) * + ('uuuuu, 'uuuuu1) FStar_Pervasives.either) + = + fun st -> + ((FStarC_Interactive_Ide_Types.QueryOK, + (FStarC_Json.JsonAssoc alist_of_protocol_info)), + (FStar_Pervasives.Inl st)) +let run_describe_repl : + 'uuuuu . + FStarC_Interactive_Ide_Types.repl_state -> + ((FStarC_Interactive_Ide_Types.query_status * FStarC_Json.json) * + (FStarC_Interactive_Ide_Types.repl_state, 'uuuuu) + FStar_Pervasives.either) + = + fun st -> + let uu___ = + let uu___1 = json_of_repl_state st in + (FStarC_Interactive_Ide_Types.QueryOK, uu___1) in + (uu___, (FStar_Pervasives.Inl st)) +let run_protocol_violation : + 'uuuuu 'uuuuu1 . + 'uuuuu -> + Prims.string -> + ((FStarC_Interactive_Ide_Types.query_status * FStarC_Json.json) * + ('uuuuu, 'uuuuu1) FStar_Pervasives.either) + = + fun st -> + fun message -> + ((FStarC_Interactive_Ide_Types.QueryViolatesProtocol, + (FStarC_Json.JsonStr message)), (FStar_Pervasives.Inl st)) +let run_generic_error : + 'uuuuu 'uuuuu1 . + 'uuuuu -> + Prims.string -> + ((FStarC_Interactive_Ide_Types.query_status * FStarC_Json.json) * + ('uuuuu, 'uuuuu1) FStar_Pervasives.either) + = + fun st -> + fun message -> + ((FStarC_Interactive_Ide_Types.QueryNOK, (FStarC_Json.JsonStr message)), + (FStar_Pervasives.Inl st)) +let (collect_errors : unit -> FStarC_Errors.issue Prims.list) = + fun uu___ -> + let errors = FStarC_Errors.report_all () in + FStarC_Errors.clear (); errors +let run_segment : + 'uuuuu . + FStarC_Interactive_Ide_Types.repl_state -> + Prims.string -> + ((FStarC_Interactive_Ide_Types.query_status * FStarC_Json.json) * + (FStarC_Interactive_Ide_Types.repl_state, 'uuuuu) + FStar_Pervasives.either) + = + fun st -> + fun code -> + let frag = + { + FStarC_Parser_ParseIt.frag_fname = ""; + FStarC_Parser_ParseIt.frag_text = code; + FStarC_Parser_ParseIt.frag_line = Prims.int_one; + FStarC_Parser_ParseIt.frag_col = Prims.int_zero + } in + let collect_decls uu___ = + let uu___1 = + FStarC_Parser_Driver.parse_fragment FStar_Pervasives_Native.None + frag in + match uu___1 with + | FStarC_Parser_Driver.Empty -> [] + | FStarC_Parser_Driver.Decls decls -> decls + | FStarC_Parser_Driver.Modul (FStarC_Parser_AST.Module + (uu___2, decls)) -> decls + | FStarC_Parser_Driver.Modul (FStarC_Parser_AST.Interface + (uu___2, decls, uu___3)) -> decls in + let uu___ = + with_captured_errors st.FStarC_Interactive_Ide_Types.repl_env + FStarC_Compiler_Util.sigint_ignore + (fun uu___1 -> + let uu___2 = collect_decls () in + FStar_Pervasives_Native.Some uu___2) in + match uu___ with + | FStar_Pervasives_Native.None -> + let errors = + let uu___1 = collect_errors () in + FStarC_Compiler_List.map + FStarC_Interactive_Ide_Types.json_of_issue uu___1 in + ((FStarC_Interactive_Ide_Types.QueryNOK, + (FStarC_Json.JsonList errors)), (FStar_Pervasives.Inl st)) + | FStar_Pervasives_Native.Some decls -> + let json_of_decl decl = + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Compiler_Range_Ops.json_of_def_range + decl.FStarC_Parser_AST.drange in + ("def_range", uu___3) in + [uu___2] in + FStarC_Json.JsonAssoc uu___1 in + let js_decls = + let uu___1 = FStarC_Compiler_List.map json_of_decl decls in + FStarC_Json.JsonList uu___1 in + ((FStarC_Interactive_Ide_Types.QueryOK, + (FStarC_Json.JsonAssoc [("decls", js_decls)])), + (FStar_Pervasives.Inl st)) +let run_vfs_add : + 'uuuuu . + FStarC_Interactive_Ide_Types.repl_state -> + Prims.string FStar_Pervasives_Native.option -> + Prims.string -> + ((FStarC_Interactive_Ide_Types.query_status * FStarC_Json.json) * + (FStarC_Interactive_Ide_Types.repl_state, 'uuuuu) + FStar_Pervasives.either) + = + fun st -> + fun opt_fname -> + fun contents -> + let fname = + FStarC_Compiler_Util.dflt + st.FStarC_Interactive_Ide_Types.repl_fname opt_fname in + FStarC_Parser_ParseIt.add_vfs_entry fname contents; + ((FStarC_Interactive_Ide_Types.QueryOK, FStarC_Json.JsonNull), + (FStar_Pervasives.Inl st)) +let run_pop : + 'uuuuu . + FStarC_Interactive_Ide_Types.repl_state -> + ((FStarC_Interactive_Ide_Types.query_status * FStarC_Json.json) * + (FStarC_Interactive_Ide_Types.repl_state, 'uuuuu) + FStar_Pervasives.either) + = + fun st -> + let uu___ = nothing_left_to_pop st in + if uu___ + then + ((FStarC_Interactive_Ide_Types.QueryNOK, + (FStarC_Json.JsonStr "Too many pops")), (FStar_Pervasives.Inl st)) + else + (let st' = FStarC_Interactive_PushHelper.pop_repl "pop_query" st in + ((FStarC_Interactive_Ide_Types.QueryOK, FStarC_Json.JsonNull), + (FStar_Pervasives.Inl st'))) +let (write_progress : + Prims.string FStar_Pervasives_Native.option -> + (Prims.string * FStarC_Json.json) Prims.list -> unit) + = + fun stage -> + fun contents_alist -> + let stage1 = + match stage with + | FStar_Pervasives_Native.Some s -> FStarC_Json.JsonStr s + | FStar_Pervasives_Native.None -> FStarC_Json.JsonNull in + let js_contents = ("stage", stage1) :: contents_alist in + let uu___ = + json_of_message "progress" (FStarC_Json.JsonAssoc js_contents) in + FStarC_Interactive_JsonHelper.write_json uu___ +let (write_error : (Prims.string * FStarC_Json.json) Prims.list -> unit) = + fun contents -> + let uu___ = json_of_message "error" (FStarC_Json.JsonAssoc contents) in + FStarC_Interactive_JsonHelper.write_json uu___ +let (write_repl_ld_task_progress : + FStarC_Interactive_Ide_Types.repl_task -> unit) = + fun task -> + match task with + | FStarC_Interactive_Ide_Types.LDInterleaved (uu___, tf) -> + let modname = + FStarC_Parser_Dep.module_name_of_file + tf.FStarC_Interactive_Ide_Types.tf_fname in + write_progress (FStar_Pervasives_Native.Some "loading-dependency") + [("modname", (FStarC_Json.JsonStr modname))] + | FStarC_Interactive_Ide_Types.LDSingle tf -> + let modname = + FStarC_Parser_Dep.module_name_of_file + tf.FStarC_Interactive_Ide_Types.tf_fname in + write_progress (FStar_Pervasives_Native.Some "loading-dependency") + [("modname", (FStarC_Json.JsonStr modname))] + | FStarC_Interactive_Ide_Types.LDInterfaceOfCurrentFile tf -> + let modname = + FStarC_Parser_Dep.module_name_of_file + tf.FStarC_Interactive_Ide_Types.tf_fname in + write_progress (FStar_Pervasives_Native.Some "loading-dependency") + [("modname", (FStarC_Json.JsonStr modname))] + | uu___ -> () +let (load_deps : + FStarC_Interactive_Ide_Types.repl_state -> + ((FStarC_Interactive_Ide_Types.repl_state * Prims.string Prims.list), + FStarC_Interactive_Ide_Types.repl_state) FStar_Pervasives.either) + = + fun st -> + let uu___ = + with_captured_errors st.FStarC_Interactive_Ide_Types.repl_env + FStarC_Compiler_Util.sigint_ignore + (fun _env -> + let uu___1 = + FStarC_Interactive_PushHelper.deps_and_repl_ld_tasks_of_our_file + st.FStarC_Interactive_Ide_Types.repl_fname in + FStar_Pervasives_Native.Some uu___1) in + match uu___ with + | FStar_Pervasives_Native.None -> FStar_Pervasives.Inr st + | FStar_Pervasives_Native.Some (deps, tasks, dep_graph) -> + let st1 = + let uu___1 = + FStarC_TypeChecker_Env.set_dep_graph + st.FStarC_Interactive_Ide_Types.repl_env dep_graph in + { + FStarC_Interactive_Ide_Types.repl_line = + (st.FStarC_Interactive_Ide_Types.repl_line); + FStarC_Interactive_Ide_Types.repl_column = + (st.FStarC_Interactive_Ide_Types.repl_column); + FStarC_Interactive_Ide_Types.repl_fname = + (st.FStarC_Interactive_Ide_Types.repl_fname); + FStarC_Interactive_Ide_Types.repl_deps_stack = + (st.FStarC_Interactive_Ide_Types.repl_deps_stack); + FStarC_Interactive_Ide_Types.repl_curmod = + (st.FStarC_Interactive_Ide_Types.repl_curmod); + FStarC_Interactive_Ide_Types.repl_env = uu___1; + FStarC_Interactive_Ide_Types.repl_stdin = + (st.FStarC_Interactive_Ide_Types.repl_stdin); + FStarC_Interactive_Ide_Types.repl_names = + (st.FStarC_Interactive_Ide_Types.repl_names); + FStarC_Interactive_Ide_Types.repl_buffered_input_queries = + (st.FStarC_Interactive_Ide_Types.repl_buffered_input_queries); + FStarC_Interactive_Ide_Types.repl_lang = + (st.FStarC_Interactive_Ide_Types.repl_lang) + } in + let uu___1 = + run_repl_ld_transactions st1 tasks write_repl_ld_task_progress in + (match uu___1 with + | FStar_Pervasives.Inr st2 -> + (write_progress FStar_Pervasives_Native.None []; + FStar_Pervasives.Inr st2) + | FStar_Pervasives.Inl st2 -> + (write_progress FStar_Pervasives_Native.None []; + FStar_Pervasives.Inl (st2, deps))) +let (rephrase_dependency_error : FStarC_Errors.issue -> FStarC_Errors.issue) + = + fun issue -> + let uu___ = + let uu___1 = + FStarC_Errors_Msg.text + "Error while computing or loading dependencies" in + uu___1 :: (issue.FStarC_Errors.issue_msg) in + { + FStarC_Errors.issue_msg = uu___; + FStarC_Errors.issue_level = (issue.FStarC_Errors.issue_level); + FStarC_Errors.issue_range = (issue.FStarC_Errors.issue_range); + FStarC_Errors.issue_number = (issue.FStarC_Errors.issue_number); + FStarC_Errors.issue_ctx = (issue.FStarC_Errors.issue_ctx) + } +let (write_full_buffer_fragment_progress : + FStarC_Interactive_Incremental.fragment_progress -> unit) = + fun di -> + let json_of_code_fragment cf = + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Compiler_Range_Ops.json_of_def_range + cf.FStarC_Parser_ParseIt.range in + ("range", uu___2) in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Compiler_Util.digest_of_string + cf.FStarC_Parser_ParseIt.code in + FStarC_Json.JsonStr uu___5 in + ("code-digest", uu___4) in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Json.JsonAssoc uu___ in + match di with + | FStarC_Interactive_Incremental.FullBufferStarted -> + write_progress (FStar_Pervasives_Native.Some "full-buffer-started") + [] + | FStarC_Interactive_Incremental.FragmentStarted d -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Compiler_Range_Ops.json_of_def_range + d.FStarC_Parser_AST.drange in + ("ranges", uu___2) in + [uu___1] in + write_progress + (FStar_Pervasives_Native.Some "full-buffer-fragment-started") uu___ + | FStarC_Interactive_Incremental.FragmentSuccess + (d, cf, FStarC_Interactive_Ide_Types.FullCheck) -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Compiler_Range_Ops.json_of_def_range + d.FStarC_Parser_AST.drange in + ("ranges", uu___2) in + let uu___2 = + let uu___3 = + let uu___4 = json_of_code_fragment cf in + ("code-fragment", uu___4) in + [uu___3] in + uu___1 :: uu___2 in + write_progress + (FStar_Pervasives_Native.Some "full-buffer-fragment-ok") uu___ + | FStarC_Interactive_Incremental.FragmentSuccess + (d, cf, FStarC_Interactive_Ide_Types.LaxCheck) -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Compiler_Range_Ops.json_of_def_range + d.FStarC_Parser_AST.drange in + ("ranges", uu___2) in + let uu___2 = + let uu___3 = + let uu___4 = json_of_code_fragment cf in + ("code-fragment", uu___4) in + [uu___3] in + uu___1 :: uu___2 in + write_progress + (FStar_Pervasives_Native.Some "full-buffer-fragment-lax-ok") uu___ + | FStarC_Interactive_Incremental.FragmentFailed d -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Compiler_Range_Ops.json_of_def_range + d.FStarC_Parser_AST.drange in + ("ranges", uu___2) in + [uu___1] in + write_progress + (FStar_Pervasives_Native.Some "full-buffer-fragment-failed") uu___ + | FStarC_Interactive_Incremental.FragmentError issues -> + let qid = + let uu___ = FStarC_Compiler_Effect.op_Bang repl_current_qid in + match uu___ with + | FStar_Pervasives_Native.None -> "unknown" + | FStar_Pervasives_Native.Some q -> q in + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Compiler_List.map + FStarC_Interactive_Ide_Types.json_of_issue issues in + FStarC_Json.JsonList uu___2 in + json_of_response qid FStarC_Interactive_Ide_Types.QueryNOK uu___1 in + FStarC_Interactive_JsonHelper.write_json uu___ + | FStarC_Interactive_Incremental.FullBufferFinished -> + write_progress (FStar_Pervasives_Native.Some "full-buffer-finished") + [] +let (trunc_modul : + FStarC_Syntax_Syntax.modul -> + (FStarC_Syntax_Syntax.sigelt -> Prims.bool) -> + (Prims.bool * FStarC_Syntax_Syntax.modul)) + = + fun m -> + fun pred -> + let rec filter decls acc = + match decls with + | [] -> (false, (FStarC_Compiler_List.rev acc)) + | d::ds -> + let uu___ = pred d in + if uu___ + then (true, (FStarC_Compiler_List.rev acc)) + else filter ds (d :: acc) in + let uu___ = filter m.FStarC_Syntax_Syntax.declarations [] in + match uu___ with + | (found, decls) -> + (found, + { + FStarC_Syntax_Syntax.name = (m.FStarC_Syntax_Syntax.name); + FStarC_Syntax_Syntax.declarations = decls; + FStarC_Syntax_Syntax.is_interface = + (m.FStarC_Syntax_Syntax.is_interface) + }) +let (load_partial_checked_file : + FStarC_TypeChecker_Env.env -> + Prims.string -> + Prims.string -> + (FStarC_TypeChecker_Env.env * FStarC_Syntax_Syntax.modul)) + = + fun env -> + fun filename -> + fun until_lid -> + let uu___ = FStarC_CheckedFiles.load_module_from_cache env filename in + match uu___ with + | FStar_Pervasives_Native.None -> + failwith (Prims.strcat "cannot find checked file for " filename) + | FStar_Pervasives_Native.Some tc_result -> + let uu___1 = + FStarC_Universal.with_dsenv_of_tcenv env + (fun ds -> + let uu___2 = + FStarC_Syntax_DsEnv.set_current_module ds + (tc_result.FStarC_CheckedFiles.checked_module).FStarC_Syntax_Syntax.name in + ((), uu___2)) in + (match uu___1 with + | (uu___2, env1) -> + let uu___3 = + FStarC_Universal.with_dsenv_of_tcenv env1 + (fun ds -> + let uu___4 = + FStarC_Syntax_DsEnv.set_iface_decls ds + (tc_result.FStarC_CheckedFiles.checked_module).FStarC_Syntax_Syntax.name + [] in + ((), uu___4)) in + (match uu___3 with + | (uu___4, env2) -> + let pred se = + let rec pred1 lids = + match lids with + | [] -> false + | lid::lids1 -> + let uu___5 = + let uu___6 = FStarC_Ident.string_of_lid lid in + uu___6 = until_lid in + if uu___5 then true else pred1 lids1 in + pred1 (FStarC_Syntax_Util.lids_of_sigelt se) in + let uu___5 = + trunc_modul + tc_result.FStarC_CheckedFiles.checked_module pred in + (match uu___5 with + | (found_decl, m) -> + if Prims.op_Negation found_decl + then + failwith + (Prims.strcat + "did not find declaration with lident " + until_lid) + else + (let uu___7 = + let uu___8 = + FStarC_ToSyntax_ToSyntax.add_partial_modul_to_env + m tc_result.FStarC_CheckedFiles.mii + (FStarC_TypeChecker_Normalize.erase_universes + env2) in + FStarC_Universal.with_dsenv_of_tcenv env2 + uu___8 in + match uu___7 with + | (uu___8, env3) -> + let env4 = + FStarC_TypeChecker_Tc.load_partial_checked_module + env3 m in + let uu___9 = + FStarC_Universal.with_dsenv_of_tcenv env4 + (fun ds -> + let uu___10 = + FStarC_Syntax_DsEnv.set_current_module + ds m.FStarC_Syntax_Syntax.name in + ((), uu___10)) in + (match uu___9 with + | (uu___10, env5) -> + let env6 = + FStarC_TypeChecker_Env.set_current_module + env5 m.FStarC_Syntax_Syntax.name in + ((let uu___12 = + FStarC_SMTEncoding_Encode.encode_modul + env6 m in + ()); + (env6, m))))))) +let (run_load_partial_file : + FStarC_Interactive_Ide_Types.repl_state -> + Prims.string -> + ((FStarC_Interactive_Ide_Types.query_status * FStarC_Json.json) * + (FStarC_Interactive_Ide_Types.repl_state, Prims.int) + FStar_Pervasives.either)) + = + fun st -> + fun decl_name -> + let uu___ = load_deps st in + match uu___ with + | FStar_Pervasives.Inr st1 -> + let errors = + let uu___1 = collect_errors () in + FStarC_Compiler_List.map rephrase_dependency_error uu___1 in + let js_errors = + FStarC_Compiler_List.map + FStarC_Interactive_Ide_Types.json_of_issue errors in + ((FStarC_Interactive_Ide_Types.QueryNOK, + (FStarC_Json.JsonList js_errors)), (FStar_Pervasives.Inl st1)) + | FStar_Pervasives.Inl (st1, deps) -> + let st2 = + FStarC_Interactive_PushHelper.push_repl "load partial file" + (FStar_Pervasives_Native.Some + FStarC_Interactive_Ide_Types.FullCheck) + FStarC_Interactive_Ide_Types.Noop st1 in + let env = st2.FStarC_Interactive_Ide_Types.repl_env in + let uu___1 = + with_captured_errors env FStarC_Compiler_Util.sigint_raise + (fun env1 -> + let uu___2 = + load_partial_checked_file env1 + st2.FStarC_Interactive_Ide_Types.repl_fname decl_name in + FStar_Pervasives_Native.Some uu___2) in + (match uu___1 with + | FStar_Pervasives_Native.Some (env1, curmod) when + let uu___2 = FStarC_Errors.get_err_count () in + uu___2 = Prims.int_zero -> + let st3 = + { + FStarC_Interactive_Ide_Types.repl_line = + (st2.FStarC_Interactive_Ide_Types.repl_line); + FStarC_Interactive_Ide_Types.repl_column = + (st2.FStarC_Interactive_Ide_Types.repl_column); + FStarC_Interactive_Ide_Types.repl_fname = + (st2.FStarC_Interactive_Ide_Types.repl_fname); + FStarC_Interactive_Ide_Types.repl_deps_stack = + (st2.FStarC_Interactive_Ide_Types.repl_deps_stack); + FStarC_Interactive_Ide_Types.repl_curmod = + (FStar_Pervasives_Native.Some curmod); + FStarC_Interactive_Ide_Types.repl_env = env1; + FStarC_Interactive_Ide_Types.repl_stdin = + (st2.FStarC_Interactive_Ide_Types.repl_stdin); + FStarC_Interactive_Ide_Types.repl_names = + (st2.FStarC_Interactive_Ide_Types.repl_names); + FStarC_Interactive_Ide_Types.repl_buffered_input_queries = + (st2.FStarC_Interactive_Ide_Types.repl_buffered_input_queries); + FStarC_Interactive_Ide_Types.repl_lang = + (st2.FStarC_Interactive_Ide_Types.repl_lang) + } in + ((FStarC_Interactive_Ide_Types.QueryOK, + (FStarC_Json.JsonList [])), (FStar_Pervasives.Inl st3)) + | uu___2 -> + let json_error_list = + let uu___3 = collect_errors () in + FStarC_Compiler_List.map + FStarC_Interactive_Ide_Types.json_of_issue uu___3 in + let json_errors = FStarC_Json.JsonList json_error_list in + let st3 = + FStarC_Interactive_PushHelper.pop_repl "load partial file" + st2 in + ((FStarC_Interactive_Ide_Types.QueryNOK, json_errors), + (FStar_Pervasives.Inl st3))) +let (run_push_without_deps : + FStarC_Interactive_Ide_Types.repl_state -> + FStarC_Interactive_Ide_Types.push_query -> + ((FStarC_Interactive_Ide_Types.query_status * FStarC_Json.json) * + (FStarC_Interactive_Ide_Types.repl_state, Prims.int) + FStar_Pervasives.either)) + = + fun st -> + fun query -> + let set_flychecking_flag st1 flag = + { + FStarC_Interactive_Ide_Types.repl_line = + (st1.FStarC_Interactive_Ide_Types.repl_line); + FStarC_Interactive_Ide_Types.repl_column = + (st1.FStarC_Interactive_Ide_Types.repl_column); + FStarC_Interactive_Ide_Types.repl_fname = + (st1.FStarC_Interactive_Ide_Types.repl_fname); + FStarC_Interactive_Ide_Types.repl_deps_stack = + (st1.FStarC_Interactive_Ide_Types.repl_deps_stack); + FStarC_Interactive_Ide_Types.repl_curmod = + (st1.FStarC_Interactive_Ide_Types.repl_curmod); + FStarC_Interactive_Ide_Types.repl_env = + (let uu___ = st1.FStarC_Interactive_Ide_Types.repl_env in + { + FStarC_TypeChecker_Env.solver = + (uu___.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (uu___.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (uu___.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (uu___.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (uu___.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (uu___.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (uu___.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (uu___.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (uu___.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (uu___.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (uu___.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (uu___.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (uu___.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (uu___.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (uu___.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (uu___.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (uu___.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (uu___.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (uu___.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (uu___.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (uu___.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (uu___.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = flag; + FStarC_TypeChecker_Env.uvar_subtyping = + (uu___.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (uu___.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (uu___.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (uu___.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (uu___.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (uu___.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (uu___.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (uu___.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (uu___.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (uu___.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (uu___.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (uu___.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (uu___.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (uu___.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (uu___.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (uu___.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (uu___.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (uu___.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (uu___.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (uu___.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (uu___.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (uu___.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (uu___.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (uu___.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (uu___.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (uu___.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (uu___.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (uu___.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (uu___.FStarC_TypeChecker_Env.missing_decl) + }); + FStarC_Interactive_Ide_Types.repl_stdin = + (st1.FStarC_Interactive_Ide_Types.repl_stdin); + FStarC_Interactive_Ide_Types.repl_names = + (st1.FStarC_Interactive_Ide_Types.repl_names); + FStarC_Interactive_Ide_Types.repl_buffered_input_queries = + (st1.FStarC_Interactive_Ide_Types.repl_buffered_input_queries); + FStarC_Interactive_Ide_Types.repl_lang = + (st1.FStarC_Interactive_Ide_Types.repl_lang) + } in + let uu___ = query in + match uu___ with + | { FStarC_Interactive_Ide_Types.push_kind = push_kind; + FStarC_Interactive_Ide_Types.push_line = line; + FStarC_Interactive_Ide_Types.push_column = column; + FStarC_Interactive_Ide_Types.push_peek_only = peek_only; + FStarC_Interactive_Ide_Types.push_code_or_decl = code_or_decl;_} -> + ((let uu___2 = FStarC_Options.ide_id_info_off () in + if uu___2 + then + FStarC_TypeChecker_Env.toggle_id_info + st.FStarC_Interactive_Ide_Types.repl_env false + else + FStarC_TypeChecker_Env.toggle_id_info + st.FStarC_Interactive_Ide_Types.repl_env true); + (let frag = + match code_or_decl with + | FStar_Pervasives.Inl text -> + FStar_Pervasives.Inl + { + FStarC_Parser_ParseIt.frag_fname = ""; + FStarC_Parser_ParseIt.frag_text = text; + FStarC_Parser_ParseIt.frag_line = line; + FStarC_Parser_ParseIt.frag_col = column + } + | FStar_Pervasives.Inr (decl, _code) -> + FStar_Pervasives.Inr decl in + let st1 = set_flychecking_flag st peek_only in + let uu___2 = + run_repl_transaction st1 + (FStar_Pervasives_Native.Some push_kind) peek_only + (FStarC_Interactive_Ide_Types.PushFragment + (frag, push_kind, [])) in + match uu___2 with + | (success, st2) -> + let st3 = set_flychecking_flag st2 false in + let status = + if success || peek_only + then FStarC_Interactive_Ide_Types.QueryOK + else FStarC_Interactive_Ide_Types.QueryNOK in + let errs = collect_errors () in + let has_error = + FStarC_Compiler_List.existsb + (fun i -> + match i.FStarC_Errors.issue_level with + | FStarC_Errors.EError -> true + | FStarC_Errors.ENotImplemented -> true + | uu___3 -> false) errs in + ((match code_or_decl with + | FStar_Pervasives.Inr (d, s) -> + if Prims.op_Negation has_error + then + write_full_buffer_fragment_progress + (FStarC_Interactive_Incremental.FragmentSuccess + (d, s, push_kind)) + else + write_full_buffer_fragment_progress + (FStarC_Interactive_Incremental.FragmentFailed d) + | uu___4 -> ()); + (let json_errors = + let uu___4 = + FStarC_Compiler_List.map + FStarC_Interactive_Ide_Types.json_of_issue errs in + FStarC_Json.JsonList uu___4 in + (match (errs, status) with + | (uu___5::uu___6, FStarC_Interactive_Ide_Types.QueryOK) + -> + FStarC_Interactive_PushHelper.add_issues_to_push_fragment + [json_errors] + | uu___5 -> ()); + (let st4 = + if success + then + { + FStarC_Interactive_Ide_Types.repl_line = line; + FStarC_Interactive_Ide_Types.repl_column = column; + FStarC_Interactive_Ide_Types.repl_fname = + (st3.FStarC_Interactive_Ide_Types.repl_fname); + FStarC_Interactive_Ide_Types.repl_deps_stack = + (st3.FStarC_Interactive_Ide_Types.repl_deps_stack); + FStarC_Interactive_Ide_Types.repl_curmod = + (st3.FStarC_Interactive_Ide_Types.repl_curmod); + FStarC_Interactive_Ide_Types.repl_env = + (st3.FStarC_Interactive_Ide_Types.repl_env); + FStarC_Interactive_Ide_Types.repl_stdin = + (st3.FStarC_Interactive_Ide_Types.repl_stdin); + FStarC_Interactive_Ide_Types.repl_names = + (st3.FStarC_Interactive_Ide_Types.repl_names); + FStarC_Interactive_Ide_Types.repl_buffered_input_queries + = + (st3.FStarC_Interactive_Ide_Types.repl_buffered_input_queries); + FStarC_Interactive_Ide_Types.repl_lang = + (st3.FStarC_Interactive_Ide_Types.repl_lang) + } + else st3 in + ((status, json_errors), (FStar_Pervasives.Inl st4))))))) +let (run_push_with_deps : + FStarC_Interactive_Ide_Types.repl_state -> + FStarC_Interactive_Ide_Types.push_query -> + ((FStarC_Interactive_Ide_Types.query_status * FStarC_Json.json) * + (FStarC_Interactive_Ide_Types.repl_state, Prims.int) + FStar_Pervasives.either)) + = + fun st -> + fun query -> + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg in + if uu___1 + then FStarC_Compiler_Util.print_string "Reloading dependencies" + else ()); + FStarC_TypeChecker_Env.toggle_id_info + st.FStarC_Interactive_Ide_Types.repl_env false; + (let uu___2 = load_deps st in + match uu___2 with + | FStar_Pervasives.Inr st1 -> + let errors = + let uu___3 = collect_errors () in + FStarC_Compiler_List.map rephrase_dependency_error uu___3 in + let js_errors = + FStarC_Compiler_List.map + FStarC_Interactive_Ide_Types.json_of_issue errors in + ((FStarC_Interactive_Ide_Types.QueryNOK, + (FStarC_Json.JsonList js_errors)), (FStar_Pervasives.Inl st1)) + | FStar_Pervasives.Inl (st1, deps) -> + ((let uu___4 = FStarC_Options.restore_cmd_line_options false in ()); + (let names = + FStarC_Interactive_PushHelper.add_module_completions + st1.FStarC_Interactive_Ide_Types.repl_fname deps + st1.FStarC_Interactive_Ide_Types.repl_names in + run_push_without_deps + { + FStarC_Interactive_Ide_Types.repl_line = + (st1.FStarC_Interactive_Ide_Types.repl_line); + FStarC_Interactive_Ide_Types.repl_column = + (st1.FStarC_Interactive_Ide_Types.repl_column); + FStarC_Interactive_Ide_Types.repl_fname = + (st1.FStarC_Interactive_Ide_Types.repl_fname); + FStarC_Interactive_Ide_Types.repl_deps_stack = + (st1.FStarC_Interactive_Ide_Types.repl_deps_stack); + FStarC_Interactive_Ide_Types.repl_curmod = + (st1.FStarC_Interactive_Ide_Types.repl_curmod); + FStarC_Interactive_Ide_Types.repl_env = + (st1.FStarC_Interactive_Ide_Types.repl_env); + FStarC_Interactive_Ide_Types.repl_stdin = + (st1.FStarC_Interactive_Ide_Types.repl_stdin); + FStarC_Interactive_Ide_Types.repl_names = names; + FStarC_Interactive_Ide_Types.repl_buffered_input_queries = + (st1.FStarC_Interactive_Ide_Types.repl_buffered_input_queries); + FStarC_Interactive_Ide_Types.repl_lang = + (st1.FStarC_Interactive_Ide_Types.repl_lang) + } query))) +let (run_push : + FStarC_Interactive_Ide_Types.repl_state -> + FStarC_Interactive_Ide_Types.push_query -> + ((FStarC_Interactive_Ide_Types.query_status * FStarC_Json.json) * + (FStarC_Interactive_Ide_Types.repl_state, Prims.int) + FStar_Pervasives.either)) + = + fun st -> + fun query -> + let uu___ = nothing_left_to_pop st in + if uu___ + then run_push_with_deps st query + else run_push_without_deps st query +let (run_symbol_lookup : + FStarC_Interactive_Ide_Types.repl_state -> + Prims.string -> + FStarC_Interactive_QueryHelper.position FStar_Pervasives_Native.option + -> + Prims.string Prims.list -> + FStarC_Json.json FStar_Pervasives_Native.option -> + (Prims.string, + (Prims.string * (Prims.string * FStarC_Json.json) Prims.list)) + FStar_Pervasives.either) + = + fun st -> + fun symbol -> + fun pos_opt -> + fun requested_info -> + fun symbol_range_opt -> + let uu___ = + FStarC_Interactive_QueryHelper.symlookup + st.FStarC_Interactive_Ide_Types.repl_env symbol pos_opt + requested_info in + match uu___ with + | FStar_Pervasives_Native.None -> + FStar_Pervasives.Inl "Symbol not found" + | FStar_Pervasives_Native.Some result -> + let uu___1 = + let uu___2 = + alist_of_symbol_lookup_result result symbol + symbol_range_opt in + ("symbol", uu___2) in + FStar_Pervasives.Inr uu___1 +let (run_option_lookup : + Prims.string -> + (Prims.string, + (Prims.string * (Prims.string * FStarC_Json.json) Prims.list)) + FStar_Pervasives.either) + = + fun opt_name -> + let uu___ = trim_option_name opt_name in + match uu___ with + | (uu___1, trimmed_name) -> + let uu___2 = + FStarC_Compiler_Util.smap_try_find fstar_options_map_cache + trimmed_name in + (match uu___2 with + | FStar_Pervasives_Native.None -> + FStar_Pervasives.Inl (Prims.strcat "Unknown option:" opt_name) + | FStar_Pervasives_Native.Some opt -> + let uu___3 = + let uu___4 = + let uu___5 = update_option opt in + alist_of_fstar_option uu___5 in + ("option", uu___4) in + FStar_Pervasives.Inr uu___3) +let (run_module_lookup : + FStarC_Interactive_Ide_Types.repl_state -> + Prims.string -> + (Prims.string, + (Prims.string * (Prims.string * FStarC_Json.json) Prims.list)) + FStar_Pervasives.either) + = + fun st -> + fun symbol -> + let query = FStarC_Compiler_Util.split symbol "." in + let uu___ = + FStarC_Interactive_CompletionTable.find_module_or_ns + st.FStarC_Interactive_Ide_Types.repl_names query in + match uu___ with + | FStar_Pervasives_Native.None -> + FStar_Pervasives.Inl "No such module or namespace" + | FStar_Pervasives_Native.Some + (FStarC_Interactive_CompletionTable.Module mod_info) -> + let uu___1 = + let uu___2 = + FStarC_Interactive_CompletionTable.alist_of_mod_info mod_info in + ("module", uu___2) in + FStar_Pervasives.Inr uu___1 + | FStar_Pervasives_Native.Some + (FStarC_Interactive_CompletionTable.Namespace ns_info) -> + let uu___1 = + let uu___2 = + FStarC_Interactive_CompletionTable.alist_of_ns_info ns_info in + ("namespace", uu___2) in + FStar_Pervasives.Inr uu___1 +let (run_code_lookup : + FStarC_Interactive_Ide_Types.repl_state -> + Prims.string -> + FStarC_Interactive_QueryHelper.position FStar_Pervasives_Native.option + -> + Prims.string Prims.list -> + FStarC_Json.json FStar_Pervasives_Native.option -> + (Prims.string, + (Prims.string * (Prims.string * FStarC_Json.json) Prims.list)) + FStar_Pervasives.either) + = + fun st -> + fun symbol -> + fun pos_opt -> + fun requested_info -> + fun symrange_opt -> + let uu___ = + run_symbol_lookup st symbol pos_opt requested_info symrange_opt in + match uu___ with + | FStar_Pervasives.Inr alist -> FStar_Pervasives.Inr alist + | FStar_Pervasives.Inl uu___1 -> + let uu___2 = run_module_lookup st symbol in + (match uu___2 with + | FStar_Pervasives.Inr alist -> FStar_Pervasives.Inr alist + | FStar_Pervasives.Inl err_msg -> + FStar_Pervasives.Inl + "No such symbol, module, or namespace.") +let (run_lookup' : + FStarC_Interactive_Ide_Types.repl_state -> + Prims.string -> + FStarC_Interactive_Ide_Types.lookup_context -> + FStarC_Interactive_QueryHelper.position + FStar_Pervasives_Native.option -> + Prims.string Prims.list -> + FStarC_Json.json FStar_Pervasives_Native.option -> + (Prims.string, + (Prims.string * (Prims.string * FStarC_Json.json) Prims.list)) + FStar_Pervasives.either) + = + fun st -> + fun symbol -> + fun context -> + fun pos_opt -> + fun requested_info -> + fun symrange -> + match context with + | FStarC_Interactive_Ide_Types.LKSymbolOnly -> + run_symbol_lookup st symbol pos_opt requested_info symrange + | FStarC_Interactive_Ide_Types.LKModule -> + run_module_lookup st symbol + | FStarC_Interactive_Ide_Types.LKOption -> + run_option_lookup symbol + | FStarC_Interactive_Ide_Types.LKCode -> + run_code_lookup st symbol pos_opt requested_info symrange +let run_lookup : + 'uuuuu . + FStarC_Interactive_Ide_Types.repl_state -> + Prims.string -> + FStarC_Interactive_Ide_Types.lookup_context -> + FStarC_Interactive_QueryHelper.position + FStar_Pervasives_Native.option -> + Prims.string Prims.list -> + FStarC_Json.json FStar_Pervasives_Native.option -> + ((FStarC_Interactive_Ide_Types.query_status * + FStarC_Json.json Prims.list) * + (FStarC_Interactive_Ide_Types.repl_state, 'uuuuu) + FStar_Pervasives.either) + = + fun st -> + fun symbol -> + fun context -> + fun pos_opt -> + fun requested_info -> + fun symrange -> + try + (fun uu___ -> + match () with + | () -> + let uu___1 = + run_lookup' st symbol context pos_opt requested_info + symrange in + (match uu___1 with + | FStar_Pervasives.Inl err_msg -> + (match symrange with + | FStar_Pervasives_Native.None -> + ((FStarC_Interactive_Ide_Types.QueryNOK, + [FStarC_Json.JsonStr err_msg]), + (FStar_Pervasives.Inl st)) + | uu___2 -> + ((FStarC_Interactive_Ide_Types.QueryOK, []), + (FStar_Pervasives.Inl st))) + | FStar_Pervasives.Inr (kind, info) -> + ((FStarC_Interactive_Ide_Types.QueryOK, + [FStarC_Json.JsonAssoc + (("kind", (FStarC_Json.JsonStr kind)) :: + info)]), (FStar_Pervasives.Inl st)))) () + with + | uu___ -> + ((FStarC_Interactive_Ide_Types.QueryOK, + [FStarC_Json.JsonStr + (Prims.strcat "Lookup of " + (Prims.strcat symbol " failed"))]), + (FStar_Pervasives.Inl st)) +let run_code_autocomplete : + 'uuuuu . + FStarC_Interactive_Ide_Types.repl_state -> + Prims.string -> + ((FStarC_Interactive_Ide_Types.query_status * FStarC_Json.json) * + (FStarC_Interactive_Ide_Types.repl_state, 'uuuuu) + FStar_Pervasives.either) + = + fun st -> + fun search_term -> + let result = + FStarC_Interactive_QueryHelper.ck_completion st search_term in + let results = + match result with + | [] -> result + | uu___ -> + let result_correlator = + { + FStarC_Interactive_CompletionTable.completion_match_length = + Prims.int_zero; + FStarC_Interactive_CompletionTable.completion_candidate = + search_term; + FStarC_Interactive_CompletionTable.completion_annotation = + "" + } in + FStarC_Compiler_List.op_At result [result_correlator] in + let js = + FStarC_Compiler_List.map + FStarC_Interactive_CompletionTable.json_of_completion_result + results in + ((FStarC_Interactive_Ide_Types.QueryOK, (FStarC_Json.JsonList js)), + (FStar_Pervasives.Inl st)) +let run_module_autocomplete : + 'uuuuu 'uuuuu1 'uuuuu2 . + FStarC_Interactive_Ide_Types.repl_state -> + Prims.string -> + 'uuuuu -> + 'uuuuu1 -> + ((FStarC_Interactive_Ide_Types.query_status * FStarC_Json.json) * + (FStarC_Interactive_Ide_Types.repl_state, 'uuuuu2) + FStar_Pervasives.either) + = + fun st -> + fun search_term -> + fun modules -> + fun namespaces -> + let needle = FStarC_Compiler_Util.split search_term "." in + let mods_and_nss = + FStarC_Interactive_CompletionTable.autocomplete_mod_or_ns + st.FStarC_Interactive_Ide_Types.repl_names needle + (fun uu___ -> FStar_Pervasives_Native.Some uu___) in + let json = + FStarC_Compiler_List.map + FStarC_Interactive_CompletionTable.json_of_completion_result + mods_and_nss in + ((FStarC_Interactive_Ide_Types.QueryOK, + (FStarC_Json.JsonList json)), (FStar_Pervasives.Inl st)) +let candidates_of_fstar_option : + 'uuuuu . + Prims.int -> + 'uuuuu -> + fstar_option -> + FStarC_Interactive_CompletionTable.completion_result Prims.list + = + fun match_len -> + fun is_reset -> + fun opt -> + let uu___ = + match opt.opt_permission_level with + | OptSet -> (true, "") + | OptReadOnly -> (false, "read-only") in + match uu___ with + | (may_set, explanation) -> + let opt_type = kind_of_fstar_option_type opt.opt_type in + let annot = + if may_set + then opt_type + else + Prims.strcat "(" + (Prims.strcat explanation + (Prims.strcat " " (Prims.strcat opt_type ")"))) in + FStarC_Compiler_List.map + (fun snippet -> + { + FStarC_Interactive_CompletionTable.completion_match_length + = match_len; + FStarC_Interactive_CompletionTable.completion_candidate = + snippet; + FStarC_Interactive_CompletionTable.completion_annotation = + annot + }) opt.opt_snippets +let run_option_autocomplete : + 'uuuuu 'uuuuu1 'uuuuu2 . + 'uuuuu -> + Prims.string -> + 'uuuuu1 -> + ((FStarC_Interactive_Ide_Types.query_status * FStarC_Json.json) * + ('uuuuu, 'uuuuu2) FStar_Pervasives.either) + = + fun st -> + fun search_term -> + fun is_reset -> + let uu___ = trim_option_name search_term in + match uu___ with + | ("--", trimmed_name) -> + let matcher opt = + FStarC_Compiler_Util.starts_with opt.opt_name trimmed_name in + let options = current_fstar_options matcher in + let match_len = FStarC_Compiler_String.length search_term in + let collect_candidates = + candidates_of_fstar_option match_len is_reset in + let results = + FStarC_Compiler_List.concatMap collect_candidates options in + let json = + FStarC_Compiler_List.map + FStarC_Interactive_CompletionTable.json_of_completion_result + results in + ((FStarC_Interactive_Ide_Types.QueryOK, + (FStarC_Json.JsonList json)), (FStar_Pervasives.Inl st)) + | (uu___1, uu___2) -> + ((FStarC_Interactive_Ide_Types.QueryNOK, + (FStarC_Json.JsonStr "Options should start with '--'")), + (FStar_Pervasives.Inl st)) +let run_autocomplete : + 'uuuuu . + FStarC_Interactive_Ide_Types.repl_state -> + Prims.string -> + FStarC_Interactive_Ide_Types.completion_context -> + ((FStarC_Interactive_Ide_Types.query_status * FStarC_Json.json) * + (FStarC_Interactive_Ide_Types.repl_state, 'uuuuu) + FStar_Pervasives.either) + = + fun st -> + fun search_term -> + fun context -> + match context with + | FStarC_Interactive_Ide_Types.CKCode -> + run_code_autocomplete st search_term + | FStarC_Interactive_Ide_Types.CKOption is_reset -> + run_option_autocomplete st search_term is_reset + | FStarC_Interactive_Ide_Types.CKModuleOrNamespace + (modules, namespaces) -> + run_module_autocomplete st search_term modules namespaces +let run_and_rewind : + 'uuuuu 'uuuuu1 . + FStarC_Interactive_Ide_Types.repl_state -> + 'uuuuu -> + (FStarC_Interactive_Ide_Types.repl_state -> 'uuuuu) -> + ('uuuuu * (FStarC_Interactive_Ide_Types.repl_state, 'uuuuu1) + FStar_Pervasives.either) + = + fun st -> + fun sigint_default -> + fun task -> + let st1 = + FStarC_Interactive_PushHelper.push_repl "run_and_rewind" + (FStar_Pervasives_Native.Some + FStarC_Interactive_Ide_Types.FullCheck) + FStarC_Interactive_Ide_Types.Noop st in + let results = + try + (fun uu___ -> + match () with + | () -> + FStarC_Compiler_Util.with_sigint_handler + FStarC_Compiler_Util.sigint_raise + (fun uu___1 -> + let uu___2 = task st1 in FStar_Pervasives.Inl uu___2)) + () + with + | FStarC_Compiler_Util.SigInt -> + FStar_Pervasives.Inl sigint_default + | e -> FStar_Pervasives.Inr e in + let st2 = FStarC_Interactive_PushHelper.pop_repl "run_and_rewind" st1 in + match results with + | FStar_Pervasives.Inl results1 -> + (results1, (FStar_Pervasives.Inl st2)) + | FStar_Pervasives.Inr e -> FStarC_Compiler_Effect.raise e +let run_with_parsed_and_tc_term : + 'uuuuu 'uuuuu1 'uuuuu2 . + FStarC_Interactive_Ide_Types.repl_state -> + Prims.string -> + 'uuuuu -> + 'uuuuu1 -> + (FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Interactive_Ide_Types.query_status * + FStarC_Json.json)) + -> + ((FStarC_Interactive_Ide_Types.query_status * FStarC_Json.json) + * (FStarC_Interactive_Ide_Types.repl_state, 'uuuuu2) + FStar_Pervasives.either) + = + fun st -> + fun term -> + fun line -> + fun column -> + fun continuation -> + let dummy_let_fragment term1 = + let dummy_decl = + FStarC_Compiler_Util.format1 "let __compute_dummy__ = (%s)" + term1 in + { + FStarC_Parser_ParseIt.frag_fname = " input"; + FStarC_Parser_ParseIt.frag_text = dummy_decl; + FStarC_Parser_ParseIt.frag_line = Prims.int_zero; + FStarC_Parser_ParseIt.frag_col = Prims.int_zero + } in + let find_let_body ses = + match ses with + | { + FStarC_Syntax_Syntax.sigel = FStarC_Syntax_Syntax.Sig_let + { + FStarC_Syntax_Syntax.lbs1 = + (uu___, + { FStarC_Syntax_Syntax.lbname = uu___1; + FStarC_Syntax_Syntax.lbunivs = univs; + FStarC_Syntax_Syntax.lbtyp = uu___2; + FStarC_Syntax_Syntax.lbeff = uu___3; + FStarC_Syntax_Syntax.lbdef = def; + FStarC_Syntax_Syntax.lbattrs = uu___4; + FStarC_Syntax_Syntax.lbpos = uu___5;_}::[]); + FStarC_Syntax_Syntax.lids1 = uu___6;_}; + FStarC_Syntax_Syntax.sigrng = uu___7; + FStarC_Syntax_Syntax.sigquals = uu___8; + FStarC_Syntax_Syntax.sigmeta = uu___9; + FStarC_Syntax_Syntax.sigattrs = uu___10; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___11; + FStarC_Syntax_Syntax.sigopts = uu___12;_}::[] -> + FStar_Pervasives_Native.Some (univs, def) + | uu___ -> FStar_Pervasives_Native.None in + let parse frag = + let uu___ = + FStarC_Parser_ParseIt.parse FStar_Pervasives_Native.None + (FStarC_Parser_ParseIt.Incremental frag) in + match uu___ with + | FStarC_Parser_ParseIt.IncrementalFragment + (decls, uu___1, _err) -> + let uu___2 = + FStarC_Compiler_List.map FStar_Pervasives_Native.fst + decls in + FStar_Pervasives_Native.Some uu___2 + | uu___1 -> FStar_Pervasives_Native.None in + let desugar env decls = + let uu___ = + let uu___1 = FStarC_ToSyntax_ToSyntax.decls_to_sigelts decls in + uu___1 env.FStarC_TypeChecker_Env.dsenv in + FStar_Pervasives_Native.fst uu___ in + let typecheck tcenv decls = + let uu___ = FStarC_TypeChecker_Tc.tc_decls tcenv decls in + match uu___ with | (ses, uu___1) -> ses in + run_and_rewind st + (FStarC_Interactive_Ide_Types.QueryNOK, + (FStarC_Json.JsonStr "Computation interrupted")) + (fun st1 -> + let tcenv = st1.FStarC_Interactive_Ide_Types.repl_env in + let frag = dummy_let_fragment term in + let uu___ = parse frag in + match uu___ with + | FStar_Pervasives_Native.None -> + (FStarC_Interactive_Ide_Types.QueryNOK, + (FStarC_Json.JsonStr "Could not parse this term")) + | FStar_Pervasives_Native.Some decls -> + let aux uu___1 = + let decls1 = desugar tcenv decls in + let ses = typecheck tcenv decls1 in + match find_let_body ses with + | FStar_Pervasives_Native.None -> + (FStarC_Interactive_Ide_Types.QueryNOK, + (FStarC_Json.JsonStr + "Typechecking yielded an unexpected term")) + | FStar_Pervasives_Native.Some (univs, def) -> + let uu___2 = + FStarC_Syntax_Subst.open_univ_vars univs def in + (match uu___2 with + | (univs1, def1) -> + let tcenv1 = + FStarC_TypeChecker_Env.push_univ_vars tcenv + univs1 in + continuation tcenv1 def1) in + let uu___1 = FStarC_Options.trace_error () in + if uu___1 + then aux () + else + (try (fun uu___3 -> match () with | () -> aux ()) () + with + | uu___3 -> + let uu___4 = FStarC_Errors.issue_of_exn uu___3 in + (match uu___4 with + | FStar_Pervasives_Native.Some issue -> + let uu___5 = + let uu___6 = + FStarC_Errors.format_issue issue in + FStarC_Json.JsonStr uu___6 in + (FStarC_Interactive_Ide_Types.QueryNOK, + uu___5) + | FStar_Pervasives_Native.None -> + FStarC_Compiler_Effect.raise uu___3))) +let run_compute : + 'uuuuu . + FStarC_Interactive_Ide_Types.repl_state -> + Prims.string -> + FStarC_TypeChecker_Env.step Prims.list FStar_Pervasives_Native.option + -> + ((FStarC_Interactive_Ide_Types.query_status * FStarC_Json.json) * + (FStarC_Interactive_Ide_Types.repl_state, 'uuuuu) + FStar_Pervasives.either) + = + fun st -> + fun term -> + fun rules -> + let rules1 = + FStarC_Compiler_List.op_At + (match rules with + | FStar_Pervasives_Native.Some rules2 -> rules2 + | FStar_Pervasives_Native.None -> + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Iota; + FStarC_TypeChecker_Env.Zeta; + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant]) + [FStarC_TypeChecker_Env.Inlining; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.DontUnfoldAttr + [FStarC_Parser_Const.tac_opaque_attr]; + FStarC_TypeChecker_Env.Primops] in + let normalize_term tcenv rules2 t = + FStarC_TypeChecker_Normalize.normalize rules2 tcenv t in + run_with_parsed_and_tc_term st term Prims.int_zero Prims.int_zero + (fun tcenv -> + fun def -> + let normalized = normalize_term tcenv rules1 def in + let uu___ = + let uu___1 = + FStarC_Interactive_QueryHelper.term_to_string tcenv + normalized in + FStarC_Json.JsonStr uu___1 in + (FStarC_Interactive_Ide_Types.QueryOK, uu___)) +type search_term' = + | NameContainsStr of Prims.string + | TypeContainsLid of FStarC_Ident.lid +and search_term = { + st_negate: Prims.bool ; + st_term: search_term' } +let (uu___is_NameContainsStr : search_term' -> Prims.bool) = + fun projectee -> + match projectee with | NameContainsStr _0 -> true | uu___ -> false +let (__proj__NameContainsStr__item___0 : search_term' -> Prims.string) = + fun projectee -> match projectee with | NameContainsStr _0 -> _0 +let (uu___is_TypeContainsLid : search_term' -> Prims.bool) = + fun projectee -> + match projectee with | TypeContainsLid _0 -> true | uu___ -> false +let (__proj__TypeContainsLid__item___0 : search_term' -> FStarC_Ident.lid) = + fun projectee -> match projectee with | TypeContainsLid _0 -> _0 +let (__proj__Mksearch_term__item__st_negate : search_term -> Prims.bool) = + fun projectee -> + match projectee with | { st_negate; st_term;_} -> st_negate +let (__proj__Mksearch_term__item__st_term : search_term -> search_term') = + fun projectee -> match projectee with | { st_negate; st_term;_} -> st_term +let (st_cost : search_term' -> Prims.int) = + fun uu___ -> + match uu___ with + | NameContainsStr str -> - (FStarC_Compiler_String.length str) + | TypeContainsLid lid -> Prims.int_one +type search_candidate = + { + sc_lid: FStarC_Ident.lid ; + sc_typ: + FStarC_Syntax_Syntax.typ FStar_Pervasives_Native.option + FStarC_Compiler_Effect.ref + ; + sc_fvars: + FStarC_Ident.lid FStarC_Compiler_RBSet.t FStar_Pervasives_Native.option + FStarC_Compiler_Effect.ref + } +let (__proj__Mksearch_candidate__item__sc_lid : + search_candidate -> FStarC_Ident.lid) = + fun projectee -> + match projectee with | { sc_lid; sc_typ; sc_fvars;_} -> sc_lid +let (__proj__Mksearch_candidate__item__sc_typ : + search_candidate -> + FStarC_Syntax_Syntax.typ FStar_Pervasives_Native.option + FStarC_Compiler_Effect.ref) + = + fun projectee -> + match projectee with | { sc_lid; sc_typ; sc_fvars;_} -> sc_typ +let (__proj__Mksearch_candidate__item__sc_fvars : + search_candidate -> + FStarC_Ident.lid FStarC_Compiler_RBSet.t FStar_Pervasives_Native.option + FStarC_Compiler_Effect.ref) + = + fun projectee -> + match projectee with | { sc_lid; sc_typ; sc_fvars;_} -> sc_fvars +let (sc_of_lid : FStarC_Ident.lid -> search_candidate) = + fun lid -> + let uu___ = FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None in + let uu___1 = FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None in + { sc_lid = lid; sc_typ = uu___; sc_fvars = uu___1 } +let (sc_typ : + FStarC_TypeChecker_Env.env -> search_candidate -> FStarC_Syntax_Syntax.typ) + = + fun tcenv -> + fun sc -> + let uu___ = FStarC_Compiler_Effect.op_Bang sc.sc_typ in + match uu___ with + | FStar_Pervasives_Native.Some t -> t + | FStar_Pervasives_Native.None -> + let typ = + let uu___1 = + FStarC_TypeChecker_Env.try_lookup_lid tcenv sc.sc_lid in + match uu___1 with + | FStar_Pervasives_Native.None -> + FStarC_Syntax_Syntax.mk FStarC_Syntax_Syntax.Tm_unknown + FStarC_Compiler_Range_Type.dummyRange + | FStar_Pervasives_Native.Some ((uu___2, typ1), uu___3) -> typ1 in + (FStarC_Compiler_Effect.op_Colon_Equals sc.sc_typ + (FStar_Pervasives_Native.Some typ); + typ) +let (sc_fvars : + FStarC_TypeChecker_Env.env -> + search_candidate -> FStarC_Ident.lident FStarC_Compiler_RBSet.t) + = + fun tcenv -> + fun sc -> + let uu___ = FStarC_Compiler_Effect.op_Bang sc.sc_fvars in + match uu___ with + | FStar_Pervasives_Native.Some fv -> fv + | FStar_Pervasives_Native.None -> + let fv = + let uu___1 = sc_typ tcenv sc in FStarC_Syntax_Free.fvars uu___1 in + (FStarC_Compiler_Effect.op_Colon_Equals sc.sc_fvars + (FStar_Pervasives_Native.Some fv); + fv) +let (json_of_search_result : + FStarC_TypeChecker_Env.env -> search_candidate -> FStarC_Json.json) = + fun tcenv -> + fun sc -> + let typ_str = + let uu___ = sc_typ tcenv sc in + FStarC_Interactive_QueryHelper.term_to_string tcenv uu___ in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Syntax_DsEnv.shorten_lid + tcenv.FStarC_TypeChecker_Env.dsenv sc.sc_lid in + FStarC_Ident.string_of_lid uu___4 in + FStarC_Json.JsonStr uu___3 in + ("lid", uu___2) in + [uu___1; ("type", (FStarC_Json.JsonStr typ_str))] in + FStarC_Json.JsonAssoc uu___ +exception InvalidSearch of Prims.string +let (uu___is_InvalidSearch : Prims.exn -> Prims.bool) = + fun projectee -> + match projectee with | InvalidSearch uu___ -> true | uu___ -> false +let (__proj__InvalidSearch__item__uu___ : Prims.exn -> Prims.string) = + fun projectee -> match projectee with | InvalidSearch uu___ -> uu___ +let run_search : + 'uuuuu . + FStarC_Interactive_Ide_Types.repl_state -> + Prims.string -> + ((FStarC_Interactive_Ide_Types.query_status * FStarC_Json.json) * + (FStarC_Interactive_Ide_Types.repl_state, 'uuuuu) + FStar_Pervasives.either) + = + fun st -> + fun search_str -> + let tcenv = st.FStarC_Interactive_Ide_Types.repl_env in + let st_matches candidate term = + let found = + match term.st_term with + | NameContainsStr str -> + let uu___ = FStarC_Ident.string_of_lid candidate.sc_lid in + FStarC_Compiler_Util.contains uu___ str + | TypeContainsLid lid -> + let uu___ = sc_fvars tcenv candidate in + FStarC_Class_Setlike.mem () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Syntax.ord_fv)) lid (Obj.magic uu___) in + found <> term.st_negate in + let parse search_str1 = + let parse_one term = + let negate = FStarC_Compiler_Util.starts_with term "-" in + let term1 = + if negate + then FStarC_Compiler_Util.substring_from term Prims.int_one + else term in + let beg_quote = FStarC_Compiler_Util.starts_with term1 "\"" in + let end_quote = FStarC_Compiler_Util.ends_with term1 "\"" in + let strip_quotes str = + if (FStarC_Compiler_String.length str) < (Prims.of_int (2)) + then + FStarC_Compiler_Effect.raise + (InvalidSearch "Empty search term") + else + FStarC_Compiler_Util.substring str Prims.int_one + ((FStarC_Compiler_String.length term1) - (Prims.of_int (2))) in + let parsed = + if beg_quote <> end_quote + then + let uu___ = + let uu___1 = + FStarC_Compiler_Util.format1 + "Improperly quoted search term: %s" term1 in + InvalidSearch uu___1 in + FStarC_Compiler_Effect.raise uu___ + else + if beg_quote + then + (let uu___1 = strip_quotes term1 in NameContainsStr uu___1) + else + (let lid = FStarC_Ident.lid_of_str term1 in + let uu___2 = + FStarC_Syntax_DsEnv.resolve_to_fully_qualified_name + tcenv.FStarC_TypeChecker_Env.dsenv lid in + match uu___2 with + | FStar_Pervasives_Native.None -> + let uu___3 = + let uu___4 = + FStarC_Compiler_Util.format1 + "Unknown identifier: %s" term1 in + InvalidSearch uu___4 in + FStarC_Compiler_Effect.raise uu___3 + | FStar_Pervasives_Native.Some lid1 -> TypeContainsLid lid1) in + { st_negate = negate; st_term = parsed } in + let terms = + FStarC_Compiler_List.map parse_one + (FStarC_Compiler_Util.split search_str1 " ") in + let cmp x y = (st_cost x.st_term) - (st_cost y.st_term) in + FStarC_Compiler_Util.sort_with cmp terms in + let pprint_one term = + let uu___ = + match term.st_term with + | NameContainsStr s -> FStarC_Compiler_Util.format1 "\"%s\"" s + | TypeContainsLid l -> + let uu___1 = FStarC_Ident.string_of_lid l in + FStarC_Compiler_Util.format1 "%s" uu___1 in + Prims.strcat (if term.st_negate then "-" else "") uu___ in + let results = + try + (fun uu___ -> + match () with + | () -> + let terms = parse search_str in + let all_lidents = FStarC_TypeChecker_Env.lidents tcenv in + let all_candidates = + FStarC_Compiler_List.map sc_of_lid all_lidents in + let matches_all candidate = + FStarC_Compiler_List.for_all (st_matches candidate) terms in + let cmp r1 r2 = + let uu___1 = FStarC_Ident.string_of_lid r1.sc_lid in + let uu___2 = FStarC_Ident.string_of_lid r2.sc_lid in + FStarC_Compiler_Util.compare uu___1 uu___2 in + let results1 = + FStarC_Compiler_List.filter matches_all all_candidates in + let sorted = FStarC_Compiler_Util.sort_with cmp results1 in + let js = + FStarC_Compiler_List.map (json_of_search_result tcenv) + sorted in + (match results1 with + | [] -> + let kwds = + let uu___1 = + FStarC_Compiler_List.map pprint_one terms in + FStarC_Compiler_Util.concat_l " " uu___1 in + let uu___1 = + let uu___2 = + FStarC_Compiler_Util.format1 + "No results found for query [%s]" kwds in + InvalidSearch uu___2 in + FStarC_Compiler_Effect.raise uu___1 + | uu___1 -> + (FStarC_Interactive_Ide_Types.QueryOK, + (FStarC_Json.JsonList js)))) () + with + | InvalidSearch s -> + (FStarC_Interactive_Ide_Types.QueryNOK, (FStarC_Json.JsonStr s)) in + (results, (FStar_Pervasives.Inl st)) +let run_format_code : + 'uuuuu . + FStarC_Interactive_Ide_Types.repl_state -> + Prims.string -> + ((FStarC_Interactive_Ide_Types.query_status * FStarC_Json.json) * + (FStarC_Interactive_Ide_Types.repl_state, 'uuuuu) + FStar_Pervasives.either) + = + fun st -> + fun code -> + let code_or_err = FStarC_Interactive_Incremental.format_code st code in + match code_or_err with + | FStar_Pervasives.Inl code1 -> + let result = + FStarC_Json.JsonAssoc + [("formatted-code", (FStarC_Json.JsonStr code1))] in + ((FStarC_Interactive_Ide_Types.QueryOK, result), + (FStar_Pervasives.Inl st)) + | FStar_Pervasives.Inr issue -> + let result = + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Compiler_List.map + FStarC_Interactive_Ide_Types.json_of_issue issue in + FStarC_Json.JsonList uu___3 in + ("formatted-code-issue", uu___2) in + [uu___1] in + FStarC_Json.JsonAssoc uu___ in + ((FStarC_Interactive_Ide_Types.QueryNOK, result), + (FStar_Pervasives.Inl st)) +let (as_json_list : + ((FStarC_Interactive_Ide_Types.query_status * FStarC_Json.json) * + (FStarC_Interactive_Ide_Types.repl_state, Prims.int) + FStar_Pervasives.either) -> + ((FStarC_Interactive_Ide_Types.query_status * FStarC_Json.json + Prims.list) * (FStarC_Interactive_Ide_Types.repl_state, Prims.int) + FStar_Pervasives.either)) + = + fun q -> let uu___ = q in match uu___ with | ((q1, j), s) -> ((q1, [j]), s) +type run_query_result = + ((FStarC_Interactive_Ide_Types.query_status * FStarC_Json.json Prims.list) + * (FStarC_Interactive_Ide_Types.repl_state, Prims.int) + FStar_Pervasives.either) +let (maybe_cancel_queries : + FStarC_Interactive_Ide_Types.repl_state -> + FStarC_Interactive_Ide_Types.query Prims.list -> + (FStarC_Interactive_Ide_Types.query Prims.list * + FStarC_Interactive_Ide_Types.repl_state)) + = + fun st -> + fun l -> + let log_cancellation l1 = + let uu___ = FStarC_Compiler_Effect.op_Bang dbg in + if uu___ + then + FStarC_Compiler_List.iter + (fun q -> + let uu___1 = FStarC_Interactive_Ide_Types.query_to_string q in + FStarC_Compiler_Util.print1 "Cancelling query: %s\n" uu___1) + l1 + else () in + match st.FStarC_Interactive_Ide_Types.repl_buffered_input_queries with + | { + FStarC_Interactive_Ide_Types.qq = + FStarC_Interactive_Ide_Types.Cancel p; + FStarC_Interactive_Ide_Types.qid = uu___;_}::rest -> + let st1 = + { + FStarC_Interactive_Ide_Types.repl_line = + (st.FStarC_Interactive_Ide_Types.repl_line); + FStarC_Interactive_Ide_Types.repl_column = + (st.FStarC_Interactive_Ide_Types.repl_column); + FStarC_Interactive_Ide_Types.repl_fname = + (st.FStarC_Interactive_Ide_Types.repl_fname); + FStarC_Interactive_Ide_Types.repl_deps_stack = + (st.FStarC_Interactive_Ide_Types.repl_deps_stack); + FStarC_Interactive_Ide_Types.repl_curmod = + (st.FStarC_Interactive_Ide_Types.repl_curmod); + FStarC_Interactive_Ide_Types.repl_env = + (st.FStarC_Interactive_Ide_Types.repl_env); + FStarC_Interactive_Ide_Types.repl_stdin = + (st.FStarC_Interactive_Ide_Types.repl_stdin); + FStarC_Interactive_Ide_Types.repl_names = + (st.FStarC_Interactive_Ide_Types.repl_names); + FStarC_Interactive_Ide_Types.repl_buffered_input_queries = rest; + FStarC_Interactive_Ide_Types.repl_lang = + (st.FStarC_Interactive_Ide_Types.repl_lang) + } in + (match p with + | FStar_Pervasives_Native.None -> (log_cancellation l; ([], st1)) + | FStar_Pervasives_Native.Some p1 -> + let query_ahead_of p2 q = + let uu___1 = p2 in + match uu___1 with + | (uu___2, l1, c) -> + (match q.FStarC_Interactive_Ide_Types.qq with + | FStarC_Interactive_Ide_Types.Push pq -> + pq.FStarC_Interactive_Ide_Types.push_line >= l1 + | uu___3 -> false) in + let l1 = + let uu___1 = + FStarC_Compiler_Util.prefix_until (query_ahead_of p1) l in + match uu___1 with + | FStar_Pervasives_Native.None -> l + | FStar_Pervasives_Native.Some (l2, q, qs) -> + (log_cancellation (q :: qs); l2) in + (l1, st1)) + | uu___ -> (l, st) +let rec (fold_query : + (FStarC_Interactive_Ide_Types.repl_state -> + FStarC_Interactive_Ide_Types.query -> run_query_result) + -> + FStarC_Interactive_Ide_Types.query Prims.list -> + FStarC_Interactive_Ide_Types.repl_state -> run_query_result) + = + fun f -> + fun l -> + fun st -> + match l with + | [] -> + ((FStarC_Interactive_Ide_Types.QueryOK, []), + (FStar_Pervasives.Inl st)) + | q::l1 -> + let uu___ = f st q in + (match uu___ with + | ((status, responses), st') -> + (FStarC_Compiler_List.iter + (write_response q.FStarC_Interactive_Ide_Types.qid status) + responses; + (match (status, st') with + | (FStarC_Interactive_Ide_Types.QueryOK, + FStar_Pervasives.Inl st1) -> + let st2 = buffer_input_queries st1 in + let uu___2 = maybe_cancel_queries st2 l1 in + (match uu___2 with | (l2, st3) -> fold_query f l2 st3) + | uu___2 -> ((status, []), st')))) +let (validate_query : + FStarC_Interactive_Ide_Types.repl_state -> + FStarC_Interactive_Ide_Types.query -> FStarC_Interactive_Ide_Types.query) + = + fun st -> + fun q -> + match q.FStarC_Interactive_Ide_Types.qq with + | FStarC_Interactive_Ide_Types.Push + { + FStarC_Interactive_Ide_Types.push_kind = + FStarC_Interactive_Ide_Types.SyntaxCheck; + FStarC_Interactive_Ide_Types.push_line = uu___; + FStarC_Interactive_Ide_Types.push_column = uu___1; + FStarC_Interactive_Ide_Types.push_peek_only = false; + FStarC_Interactive_Ide_Types.push_code_or_decl = uu___2;_} + -> + { + FStarC_Interactive_Ide_Types.qq = + (FStarC_Interactive_Ide_Types.ProtocolViolation + "Cannot use 'kind': 'syntax' with 'query': 'push'"); + FStarC_Interactive_Ide_Types.qid = + (q.FStarC_Interactive_Ide_Types.qid) + } + | uu___ -> + (match st.FStarC_Interactive_Ide_Types.repl_curmod with + | FStar_Pervasives_Native.None when + FStarC_Interactive_Ide_Types.query_needs_current_module + q.FStarC_Interactive_Ide_Types.qq + -> + { + FStarC_Interactive_Ide_Types.qq = + (FStarC_Interactive_Ide_Types.GenericError + "Current module unset"); + FStarC_Interactive_Ide_Types.qid = + (q.FStarC_Interactive_Ide_Types.qid) + } + | uu___1 -> q) +let rec (run_query : + FStarC_Interactive_Ide_Types.repl_state -> + FStarC_Interactive_Ide_Types.query -> + ((FStarC_Interactive_Ide_Types.query_status * FStarC_Json.json + Prims.list) * (FStarC_Interactive_Ide_Types.repl_state, Prims.int) + FStar_Pervasives.either)) + = + fun st -> + fun q -> + match q.FStarC_Interactive_Ide_Types.qq with + | FStarC_Interactive_Ide_Types.Exit -> as_json_list (run_exit st) + | FStarC_Interactive_Ide_Types.DescribeProtocol -> + as_json_list (run_describe_protocol st) + | FStarC_Interactive_Ide_Types.DescribeRepl -> + let uu___ = run_describe_repl st in as_json_list uu___ + | FStarC_Interactive_Ide_Types.GenericError message -> + as_json_list (run_generic_error st message) + | FStarC_Interactive_Ide_Types.ProtocolViolation query -> + as_json_list (run_protocol_violation st query) + | FStarC_Interactive_Ide_Types.Segment c -> + let uu___ = run_segment st c in as_json_list uu___ + | FStarC_Interactive_Ide_Types.VfsAdd (fname, contents) -> + let uu___ = run_vfs_add st fname contents in as_json_list uu___ + | FStarC_Interactive_Ide_Types.Push pquery -> + let uu___ = run_push st pquery in as_json_list uu___ + | FStarC_Interactive_Ide_Types.PushPartialCheckedFile decl_name -> + let uu___ = run_load_partial_file st decl_name in + as_json_list uu___ + | FStarC_Interactive_Ide_Types.Pop -> + let uu___ = run_pop st in as_json_list uu___ + | FStarC_Interactive_Ide_Types.FullBuffer + (code, full_kind, with_symbols) -> + (write_full_buffer_fragment_progress + FStarC_Interactive_Incremental.FullBufferStarted; + (let uu___1 = + FStarC_Interactive_Incremental.run_full_buffer st + q.FStarC_Interactive_Ide_Types.qid code full_kind + with_symbols write_full_buffer_fragment_progress in + match uu___1 with + | (queries, issues) -> + (FStarC_Compiler_List.iter + (write_response q.FStarC_Interactive_Ide_Types.qid + FStarC_Interactive_Ide_Types.QueryOK) issues; + (let res = fold_query validate_and_run_query queries st in + write_full_buffer_fragment_progress + FStarC_Interactive_Incremental.FullBufferFinished; + res)))) + | FStarC_Interactive_Ide_Types.AutoComplete (search_term1, context) -> + let uu___ = run_autocomplete st search_term1 context in + as_json_list uu___ + | FStarC_Interactive_Ide_Types.Lookup + (symbol, context, pos_opt, rq_info, symrange) -> + run_lookup st symbol context pos_opt rq_info symrange + | FStarC_Interactive_Ide_Types.Compute (term, rules) -> + let uu___ = run_compute st term rules in as_json_list uu___ + | FStarC_Interactive_Ide_Types.Search term -> + let uu___ = run_search st term in as_json_list uu___ + | FStarC_Interactive_Ide_Types.Callback f -> f st + | FStarC_Interactive_Ide_Types.Format code -> + let uu___ = run_format_code st code in as_json_list uu___ + | FStarC_Interactive_Ide_Types.RestartSolver -> + (((st.FStarC_Interactive_Ide_Types.repl_env).FStarC_TypeChecker_Env.solver).FStarC_TypeChecker_Env.refresh + FStar_Pervasives_Native.None; + ((FStarC_Interactive_Ide_Types.QueryOK, []), + (FStar_Pervasives.Inl st))) + | FStarC_Interactive_Ide_Types.Cancel uu___ -> + ((FStarC_Interactive_Ide_Types.QueryOK, []), + (FStar_Pervasives.Inl st)) +and (validate_and_run_query : + FStarC_Interactive_Ide_Types.repl_state -> + FStarC_Interactive_Ide_Types.query -> run_query_result) + = + fun st -> + fun query -> + let query1 = validate_query st query in + FStarC_Compiler_Effect.op_Colon_Equals repl_current_qid + (FStar_Pervasives_Native.Some + (query1.FStarC_Interactive_Ide_Types.qid)); + (let uu___2 = FStarC_Compiler_Effect.op_Bang dbg in + if uu___2 + then + let uu___3 = FStarC_Interactive_Ide_Types.query_to_string query1 in + FStarC_Compiler_Util.print2 "Running query %s: %s\n" + query1.FStarC_Interactive_Ide_Types.qid uu___3 + else ()); + run_query st query1 +let (js_repl_eval : + FStarC_Interactive_Ide_Types.repl_state -> + FStarC_Interactive_Ide_Types.query -> + (FStarC_Json.json Prims.list * + (FStarC_Interactive_Ide_Types.repl_state, Prims.int) + FStar_Pervasives.either)) + = + fun st -> + fun query -> + let uu___ = validate_and_run_query st query in + match uu___ with + | ((status, responses), st_opt) -> + let js_responses = + FStarC_Compiler_List.map + (json_of_response query.FStarC_Interactive_Ide_Types.qid status) + responses in + (js_responses, st_opt) +let (js_repl_eval_js : + FStarC_Interactive_Ide_Types.repl_state -> + FStarC_Json.json -> + (FStarC_Json.json Prims.list * + (FStarC_Interactive_Ide_Types.repl_state, Prims.int) + FStar_Pervasives.either)) + = + fun st -> + fun query_js -> + let uu___ = deserialize_interactive_query query_js in + js_repl_eval st uu___ +let (js_repl_eval_str : + FStarC_Interactive_Ide_Types.repl_state -> + Prims.string -> + (Prims.string Prims.list * (FStarC_Interactive_Ide_Types.repl_state, + Prims.int) FStar_Pervasives.either)) + = + fun st -> + fun query_str -> + let uu___ = + let uu___1 = parse_interactive_query query_str in + js_repl_eval st uu___1 in + match uu___ with + | (js_response, st_opt) -> + let uu___1 = + FStarC_Compiler_List.map FStarC_Json.string_of_json js_response in + (uu___1, st_opt) +let (js_repl_init_opts : unit -> unit) = + fun uu___ -> + let uu___1 = FStarC_Options.parse_cmd_line () in + match uu___1 with + | (res, fnames) -> + (match res with + | FStarC_Getopt.Error msg -> + failwith (Prims.strcat "repl_init: " msg) + | FStarC_Getopt.Help -> failwith "repl_init: --help unexpected" + | FStarC_Getopt.Success -> + (match fnames with + | [] -> + failwith + "repl_init: No file name given in --ide invocation" + | h::uu___2::uu___3 -> + failwith + "repl_init: Too many file names given in --ide invocation" + | uu___2 -> ())) +let rec (go : FStarC_Interactive_Ide_Types.repl_state -> Prims.int) = + fun st -> + let uu___ = read_interactive_query st in + match uu___ with + | (query, st1) -> + let uu___1 = validate_and_run_query st1 query in + (match uu___1 with + | ((status, responses), state_opt) -> + (FStarC_Compiler_List.iter + (write_response query.FStarC_Interactive_Ide_Types.qid status) + responses; + (match state_opt with + | FStar_Pervasives.Inl st' -> go st' + | FStar_Pervasives.Inr exitcode -> exitcode))) +let (interactive_error_handler : FStarC_Errors.error_handler) = + let issues = FStarC_Compiler_Util.mk_ref [] in + let add_one e = + let uu___ = + let uu___1 = FStarC_Compiler_Effect.op_Bang issues in e :: uu___1 in + FStarC_Compiler_Effect.op_Colon_Equals issues uu___ in + let count_errors uu___ = + let issues1 = + let uu___1 = FStarC_Compiler_Effect.op_Bang issues in + FStarC_Compiler_Util.remove_dups (fun i0 -> fun i1 -> i0 = i1) uu___1 in + let uu___1 = + FStarC_Compiler_List.filter + (fun e -> e.FStarC_Errors.issue_level = FStarC_Errors.EError) issues1 in + FStarC_Compiler_List.length uu___1 in + let report uu___ = + let uu___1 = + let uu___2 = FStarC_Compiler_Effect.op_Bang issues in + FStarC_Compiler_Util.remove_dups (fun i0 -> fun i1 -> i0 = i1) uu___2 in + FStarC_Compiler_List.sortWith FStarC_Errors.compare_issues uu___1 in + let clear uu___ = FStarC_Compiler_Effect.op_Colon_Equals issues [] in + { + FStarC_Errors.eh_name = "interactive error handler"; + FStarC_Errors.eh_add_one = add_one; + FStarC_Errors.eh_count_errors = count_errors; + FStarC_Errors.eh_report = report; + FStarC_Errors.eh_clear = clear + } +let (interactive_printer : + (FStarC_Json.json -> unit) -> FStarC_Compiler_Util.printer) = + fun printer -> + { + FStarC_Compiler_Util.printer_prinfo = + (fun s -> forward_message printer "info" (FStarC_Json.JsonStr s)); + FStarC_Compiler_Util.printer_prwarning = + (fun s -> forward_message printer "warning" (FStarC_Json.JsonStr s)); + FStarC_Compiler_Util.printer_prerror = + (fun s -> forward_message printer "error" (FStarC_Json.JsonStr s)); + FStarC_Compiler_Util.printer_prgeneric = + (fun label -> + fun get_string -> + fun get_json -> + let uu___ = get_json () in forward_message printer label uu___) + } +let (install_ide_mode_hooks : (FStarC_Json.json -> unit) -> unit) = + fun printer -> + FStarC_Compiler_Util.set_printer (interactive_printer printer); + FStarC_Errors.set_handler interactive_error_handler +let (build_initial_repl_state : + Prims.string -> FStarC_Interactive_Ide_Types.repl_state) = + fun filename -> + let env = FStarC_Universal.init_env FStarC_Parser_Dep.empty_deps in + let env1 = + FStarC_TypeChecker_Env.set_range env + FStarC_Interactive_Ide_Types.initial_range in + FStarC_Options.set_ide_filename filename; + (let uu___1 = FStarC_Compiler_Util.open_stdin () in + { + FStarC_Interactive_Ide_Types.repl_line = Prims.int_one; + FStarC_Interactive_Ide_Types.repl_column = Prims.int_zero; + FStarC_Interactive_Ide_Types.repl_fname = filename; + FStarC_Interactive_Ide_Types.repl_deps_stack = []; + FStarC_Interactive_Ide_Types.repl_curmod = + FStar_Pervasives_Native.None; + FStarC_Interactive_Ide_Types.repl_env = env1; + FStarC_Interactive_Ide_Types.repl_stdin = uu___1; + FStarC_Interactive_Ide_Types.repl_names = + FStarC_Interactive_CompletionTable.empty; + FStarC_Interactive_Ide_Types.repl_buffered_input_queries = []; + FStarC_Interactive_Ide_Types.repl_lang = [] + }) +let interactive_mode' : + 'uuuuu . FStarC_Interactive_Ide_Types.repl_state -> 'uuuuu = + fun init_st -> + write_hello (); + (let exit_code = + let uu___1 = + (FStarC_Options.record_hints ()) || (FStarC_Options.use_hints ()) in + if uu___1 + then + let uu___2 = + let uu___3 = FStarC_Options.file_list () in + FStarC_Compiler_List.hd uu___3 in + FStarC_SMTEncoding_Solver.with_hints_db uu___2 + (fun uu___3 -> go init_st) + else go init_st in + FStarC_Compiler_Effect.exit exit_code) +let (interactive_mode : Prims.string -> unit) = + fun filename -> + install_ide_mode_hooks FStarC_Interactive_JsonHelper.write_json; + FStarC_Compiler_Util.set_sigint_handler + FStarC_Compiler_Util.sigint_ignore; + (let uu___3 = + let uu___4 = FStarC_Options.codegen () in + FStarC_Compiler_Option.isSome uu___4 in + if uu___3 + then + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_IDEIgnoreCodeGen + () (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "--ide: ignoring --codegen") + else ()); + (let init = build_initial_repl_state filename in + let uu___3 = FStarC_Options.trace_error () in + if uu___3 + then interactive_mode' init + else + (try (fun uu___5 -> match () with | () -> interactive_mode' init) () + with + | uu___5 -> + (FStarC_Errors.set_handler FStarC_Errors.default_handler; + FStarC_Compiler_Effect.raise uu___5))) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Interactive_Ide_Types.ml b/ocaml/fstar-lib/generated/FStarC_Interactive_Ide_Types.ml new file mode 100644 index 00000000000..c665d45ff21 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Interactive_Ide_Types.ml @@ -0,0 +1,693 @@ +open Prims +let (initial_range : FStarC_Compiler_Range_Type.range) = + let uu___ = FStarC_Compiler_Range_Type.mk_pos Prims.int_one Prims.int_zero in + let uu___1 = FStarC_Compiler_Range_Type.mk_pos Prims.int_one Prims.int_zero in + FStarC_Compiler_Range_Type.mk_range "" uu___ uu___1 +type completion_context = + | CKCode + | CKOption of Prims.bool + | CKModuleOrNamespace of (Prims.bool * Prims.bool) +let (uu___is_CKCode : completion_context -> Prims.bool) = + fun projectee -> match projectee with | CKCode -> true | uu___ -> false +let (uu___is_CKOption : completion_context -> Prims.bool) = + fun projectee -> + match projectee with | CKOption _0 -> true | uu___ -> false +let (__proj__CKOption__item___0 : completion_context -> Prims.bool) = + fun projectee -> match projectee with | CKOption _0 -> _0 +let (uu___is_CKModuleOrNamespace : completion_context -> Prims.bool) = + fun projectee -> + match projectee with | CKModuleOrNamespace _0 -> true | uu___ -> false +let (__proj__CKModuleOrNamespace__item___0 : + completion_context -> (Prims.bool * Prims.bool)) = + fun projectee -> match projectee with | CKModuleOrNamespace _0 -> _0 +type lookup_context = + | LKSymbolOnly + | LKModule + | LKOption + | LKCode +let (uu___is_LKSymbolOnly : lookup_context -> Prims.bool) = + fun projectee -> + match projectee with | LKSymbolOnly -> true | uu___ -> false +let (uu___is_LKModule : lookup_context -> Prims.bool) = + fun projectee -> match projectee with | LKModule -> true | uu___ -> false +let (uu___is_LKOption : lookup_context -> Prims.bool) = + fun projectee -> match projectee with | LKOption -> true | uu___ -> false +let (uu___is_LKCode : lookup_context -> Prims.bool) = + fun projectee -> match projectee with | LKCode -> true | uu___ -> false +type position = (Prims.string * Prims.int * Prims.int) +type push_kind = + | SyntaxCheck + | LaxCheck + | FullCheck +let (uu___is_SyntaxCheck : push_kind -> Prims.bool) = + fun projectee -> + match projectee with | SyntaxCheck -> true | uu___ -> false +let (uu___is_LaxCheck : push_kind -> Prims.bool) = + fun projectee -> match projectee with | LaxCheck -> true | uu___ -> false +let (uu___is_FullCheck : push_kind -> Prims.bool) = + fun projectee -> match projectee with | FullCheck -> true | uu___ -> false +type push_query = + { + push_kind: push_kind ; + push_line: Prims.int ; + push_column: Prims.int ; + push_peek_only: Prims.bool ; + push_code_or_decl: + (Prims.string, + (FStarC_Parser_AST.decl * FStarC_Parser_ParseIt.code_fragment)) + FStar_Pervasives.either + } +let (__proj__Mkpush_query__item__push_kind : push_query -> push_kind) = + fun projectee -> + match projectee with + | { push_kind = push_kind1; push_line; push_column; push_peek_only; + push_code_or_decl;_} -> push_kind1 +let (__proj__Mkpush_query__item__push_line : push_query -> Prims.int) = + fun projectee -> + match projectee with + | { push_kind = push_kind1; push_line; push_column; push_peek_only; + push_code_or_decl;_} -> push_line +let (__proj__Mkpush_query__item__push_column : push_query -> Prims.int) = + fun projectee -> + match projectee with + | { push_kind = push_kind1; push_line; push_column; push_peek_only; + push_code_or_decl;_} -> push_column +let (__proj__Mkpush_query__item__push_peek_only : push_query -> Prims.bool) = + fun projectee -> + match projectee with + | { push_kind = push_kind1; push_line; push_column; push_peek_only; + push_code_or_decl;_} -> push_peek_only +let (__proj__Mkpush_query__item__push_code_or_decl : + push_query -> + (Prims.string, + (FStarC_Parser_AST.decl * FStarC_Parser_ParseIt.code_fragment)) + FStar_Pervasives.either) + = + fun projectee -> + match projectee with + | { push_kind = push_kind1; push_line; push_column; push_peek_only; + push_code_or_decl;_} -> push_code_or_decl +type lookup_symbol_range = FStarC_Json.json +type query_status = + | QueryOK + | QueryNOK + | QueryViolatesProtocol +let (uu___is_QueryOK : query_status -> Prims.bool) = + fun projectee -> match projectee with | QueryOK -> true | uu___ -> false +let (uu___is_QueryNOK : query_status -> Prims.bool) = + fun projectee -> match projectee with | QueryNOK -> true | uu___ -> false +let (uu___is_QueryViolatesProtocol : query_status -> Prims.bool) = + fun projectee -> + match projectee with | QueryViolatesProtocol -> true | uu___ -> false +type repl_depth_t = (FStarC_TypeChecker_Env.tcenv_depth_t * Prims.int) +type optmod_t = FStarC_Syntax_Syntax.modul FStar_Pervasives_Native.option +type timed_fname = + { + tf_fname: Prims.string ; + tf_modtime: FStarC_Compiler_Util.time } +let (__proj__Mktimed_fname__item__tf_fname : timed_fname -> Prims.string) = + fun projectee -> + match projectee with | { tf_fname; tf_modtime;_} -> tf_fname +let (__proj__Mktimed_fname__item__tf_modtime : + timed_fname -> FStarC_Compiler_Util.time) = + fun projectee -> + match projectee with | { tf_fname; tf_modtime;_} -> tf_modtime +type repl_task = + | LDInterleaved of (timed_fname * timed_fname) + | LDSingle of timed_fname + | LDInterfaceOfCurrentFile of timed_fname + | PushFragment of ((FStarC_Parser_ParseIt.input_frag, + FStarC_Parser_AST.decl) FStar_Pervasives.either * push_kind * + FStarC_Json.json Prims.list) + | Noop +let (uu___is_LDInterleaved : repl_task -> Prims.bool) = + fun projectee -> + match projectee with | LDInterleaved _0 -> true | uu___ -> false +let (__proj__LDInterleaved__item___0 : + repl_task -> (timed_fname * timed_fname)) = + fun projectee -> match projectee with | LDInterleaved _0 -> _0 +let (uu___is_LDSingle : repl_task -> Prims.bool) = + fun projectee -> + match projectee with | LDSingle _0 -> true | uu___ -> false +let (__proj__LDSingle__item___0 : repl_task -> timed_fname) = + fun projectee -> match projectee with | LDSingle _0 -> _0 +let (uu___is_LDInterfaceOfCurrentFile : repl_task -> Prims.bool) = + fun projectee -> + match projectee with + | LDInterfaceOfCurrentFile _0 -> true + | uu___ -> false +let (__proj__LDInterfaceOfCurrentFile__item___0 : repl_task -> timed_fname) = + fun projectee -> match projectee with | LDInterfaceOfCurrentFile _0 -> _0 +let (uu___is_PushFragment : repl_task -> Prims.bool) = + fun projectee -> + match projectee with | PushFragment _0 -> true | uu___ -> false +let (__proj__PushFragment__item___0 : + repl_task -> + ((FStarC_Parser_ParseIt.input_frag, FStarC_Parser_AST.decl) + FStar_Pervasives.either * push_kind * FStarC_Json.json Prims.list)) + = fun projectee -> match projectee with | PushFragment _0 -> _0 +let (uu___is_Noop : repl_task -> Prims.bool) = + fun projectee -> match projectee with | Noop -> true | uu___ -> false +type full_buffer_request_kind = + | Full + | Lax + | Cache + | ReloadDeps + | VerifyToPosition of position + | LaxToPosition of position +let (uu___is_Full : full_buffer_request_kind -> Prims.bool) = + fun projectee -> match projectee with | Full -> true | uu___ -> false +let (uu___is_Lax : full_buffer_request_kind -> Prims.bool) = + fun projectee -> match projectee with | Lax -> true | uu___ -> false +let (uu___is_Cache : full_buffer_request_kind -> Prims.bool) = + fun projectee -> match projectee with | Cache -> true | uu___ -> false +let (uu___is_ReloadDeps : full_buffer_request_kind -> Prims.bool) = + fun projectee -> match projectee with | ReloadDeps -> true | uu___ -> false +let (uu___is_VerifyToPosition : full_buffer_request_kind -> Prims.bool) = + fun projectee -> + match projectee with | VerifyToPosition _0 -> true | uu___ -> false +let (__proj__VerifyToPosition__item___0 : + full_buffer_request_kind -> position) = + fun projectee -> match projectee with | VerifyToPosition _0 -> _0 +let (uu___is_LaxToPosition : full_buffer_request_kind -> Prims.bool) = + fun projectee -> + match projectee with | LaxToPosition _0 -> true | uu___ -> false +let (__proj__LaxToPosition__item___0 : full_buffer_request_kind -> position) + = fun projectee -> match projectee with | LaxToPosition _0 -> _0 +type query' = + | Exit + | DescribeProtocol + | DescribeRepl + | Segment of Prims.string + | Pop + | Push of push_query + | PushPartialCheckedFile of Prims.string + | VfsAdd of (Prims.string FStar_Pervasives_Native.option * Prims.string) + | AutoComplete of (Prims.string * completion_context) + | Lookup of (Prims.string * lookup_context * position + FStar_Pervasives_Native.option * Prims.string Prims.list * + lookup_symbol_range FStar_Pervasives_Native.option) + | Compute of (Prims.string * FStarC_TypeChecker_Env.step Prims.list + FStar_Pervasives_Native.option) + | Search of Prims.string + | GenericError of Prims.string + | ProtocolViolation of Prims.string + | FullBuffer of (Prims.string * full_buffer_request_kind * Prims.bool) + | Callback of + (repl_state -> + ((query_status * FStarC_Json.json Prims.list) * (repl_state, Prims.int) + FStar_Pervasives.either)) + + | Format of Prims.string + | RestartSolver + | Cancel of position FStar_Pervasives_Native.option +and query = { + qq: query' ; + qid: Prims.string } +and repl_state = + { + repl_line: Prims.int ; + repl_column: Prims.int ; + repl_fname: Prims.string ; + repl_deps_stack: (repl_depth_t * (repl_task * repl_state)) Prims.list ; + repl_curmod: optmod_t ; + repl_env: FStarC_TypeChecker_Env.env ; + repl_stdin: FStarC_Compiler_Util.stream_reader ; + repl_names: FStarC_Interactive_CompletionTable.table ; + repl_buffered_input_queries: query Prims.list ; + repl_lang: FStarC_Universal.lang_decls_t } +let (uu___is_Exit : query' -> Prims.bool) = + fun projectee -> match projectee with | Exit -> true | uu___ -> false +let (uu___is_DescribeProtocol : query' -> Prims.bool) = + fun projectee -> + match projectee with | DescribeProtocol -> true | uu___ -> false +let (uu___is_DescribeRepl : query' -> Prims.bool) = + fun projectee -> + match projectee with | DescribeRepl -> true | uu___ -> false +let (uu___is_Segment : query' -> Prims.bool) = + fun projectee -> match projectee with | Segment _0 -> true | uu___ -> false +let (__proj__Segment__item___0 : query' -> Prims.string) = + fun projectee -> match projectee with | Segment _0 -> _0 +let (uu___is_Pop : query' -> Prims.bool) = + fun projectee -> match projectee with | Pop -> true | uu___ -> false +let (uu___is_Push : query' -> Prims.bool) = + fun projectee -> match projectee with | Push _0 -> true | uu___ -> false +let (__proj__Push__item___0 : query' -> push_query) = + fun projectee -> match projectee with | Push _0 -> _0 +let (uu___is_PushPartialCheckedFile : query' -> Prims.bool) = + fun projectee -> + match projectee with | PushPartialCheckedFile _0 -> true | uu___ -> false +let (__proj__PushPartialCheckedFile__item___0 : query' -> Prims.string) = + fun projectee -> match projectee with | PushPartialCheckedFile _0 -> _0 +let (uu___is_VfsAdd : query' -> Prims.bool) = + fun projectee -> match projectee with | VfsAdd _0 -> true | uu___ -> false +let (__proj__VfsAdd__item___0 : + query' -> (Prims.string FStar_Pervasives_Native.option * Prims.string)) = + fun projectee -> match projectee with | VfsAdd _0 -> _0 +let (uu___is_AutoComplete : query' -> Prims.bool) = + fun projectee -> + match projectee with | AutoComplete _0 -> true | uu___ -> false +let (__proj__AutoComplete__item___0 : + query' -> (Prims.string * completion_context)) = + fun projectee -> match projectee with | AutoComplete _0 -> _0 +let (uu___is_Lookup : query' -> Prims.bool) = + fun projectee -> match projectee with | Lookup _0 -> true | uu___ -> false +let (__proj__Lookup__item___0 : + query' -> + (Prims.string * lookup_context * position FStar_Pervasives_Native.option + * Prims.string Prims.list * lookup_symbol_range + FStar_Pervasives_Native.option)) + = fun projectee -> match projectee with | Lookup _0 -> _0 +let (uu___is_Compute : query' -> Prims.bool) = + fun projectee -> match projectee with | Compute _0 -> true | uu___ -> false +let (__proj__Compute__item___0 : + query' -> + (Prims.string * FStarC_TypeChecker_Env.step Prims.list + FStar_Pervasives_Native.option)) + = fun projectee -> match projectee with | Compute _0 -> _0 +let (uu___is_Search : query' -> Prims.bool) = + fun projectee -> match projectee with | Search _0 -> true | uu___ -> false +let (__proj__Search__item___0 : query' -> Prims.string) = + fun projectee -> match projectee with | Search _0 -> _0 +let (uu___is_GenericError : query' -> Prims.bool) = + fun projectee -> + match projectee with | GenericError _0 -> true | uu___ -> false +let (__proj__GenericError__item___0 : query' -> Prims.string) = + fun projectee -> match projectee with | GenericError _0 -> _0 +let (uu___is_ProtocolViolation : query' -> Prims.bool) = + fun projectee -> + match projectee with | ProtocolViolation _0 -> true | uu___ -> false +let (__proj__ProtocolViolation__item___0 : query' -> Prims.string) = + fun projectee -> match projectee with | ProtocolViolation _0 -> _0 +let (uu___is_FullBuffer : query' -> Prims.bool) = + fun projectee -> + match projectee with | FullBuffer _0 -> true | uu___ -> false +let (__proj__FullBuffer__item___0 : + query' -> (Prims.string * full_buffer_request_kind * Prims.bool)) = + fun projectee -> match projectee with | FullBuffer _0 -> _0 +let (uu___is_Callback : query' -> Prims.bool) = + fun projectee -> + match projectee with | Callback _0 -> true | uu___ -> false +let (__proj__Callback__item___0 : + query' -> + repl_state -> + ((query_status * FStarC_Json.json Prims.list) * (repl_state, Prims.int) + FStar_Pervasives.either)) + = fun projectee -> match projectee with | Callback _0 -> _0 +let (uu___is_Format : query' -> Prims.bool) = + fun projectee -> match projectee with | Format _0 -> true | uu___ -> false +let (__proj__Format__item___0 : query' -> Prims.string) = + fun projectee -> match projectee with | Format _0 -> _0 +let (uu___is_RestartSolver : query' -> Prims.bool) = + fun projectee -> + match projectee with | RestartSolver -> true | uu___ -> false +let (uu___is_Cancel : query' -> Prims.bool) = + fun projectee -> match projectee with | Cancel _0 -> true | uu___ -> false +let (__proj__Cancel__item___0 : + query' -> position FStar_Pervasives_Native.option) = + fun projectee -> match projectee with | Cancel _0 -> _0 +let (__proj__Mkquery__item__qq : query -> query') = + fun projectee -> match projectee with | { qq; qid;_} -> qq +let (__proj__Mkquery__item__qid : query -> Prims.string) = + fun projectee -> match projectee with | { qq; qid;_} -> qid +let (__proj__Mkrepl_state__item__repl_line : repl_state -> Prims.int) = + fun projectee -> + match projectee with + | { repl_line; repl_column; repl_fname; repl_deps_stack; repl_curmod; + repl_env; repl_stdin; repl_names; repl_buffered_input_queries; + repl_lang;_} -> repl_line +let (__proj__Mkrepl_state__item__repl_column : repl_state -> Prims.int) = + fun projectee -> + match projectee with + | { repl_line; repl_column; repl_fname; repl_deps_stack; repl_curmod; + repl_env; repl_stdin; repl_names; repl_buffered_input_queries; + repl_lang;_} -> repl_column +let (__proj__Mkrepl_state__item__repl_fname : repl_state -> Prims.string) = + fun projectee -> + match projectee with + | { repl_line; repl_column; repl_fname; repl_deps_stack; repl_curmod; + repl_env; repl_stdin; repl_names; repl_buffered_input_queries; + repl_lang;_} -> repl_fname +let (__proj__Mkrepl_state__item__repl_deps_stack : + repl_state -> (repl_depth_t * (repl_task * repl_state)) Prims.list) = + fun projectee -> + match projectee with + | { repl_line; repl_column; repl_fname; repl_deps_stack; repl_curmod; + repl_env; repl_stdin; repl_names; repl_buffered_input_queries; + repl_lang;_} -> repl_deps_stack +let (__proj__Mkrepl_state__item__repl_curmod : repl_state -> optmod_t) = + fun projectee -> + match projectee with + | { repl_line; repl_column; repl_fname; repl_deps_stack; repl_curmod; + repl_env; repl_stdin; repl_names; repl_buffered_input_queries; + repl_lang;_} -> repl_curmod +let (__proj__Mkrepl_state__item__repl_env : + repl_state -> FStarC_TypeChecker_Env.env) = + fun projectee -> + match projectee with + | { repl_line; repl_column; repl_fname; repl_deps_stack; repl_curmod; + repl_env; repl_stdin; repl_names; repl_buffered_input_queries; + repl_lang;_} -> repl_env +let (__proj__Mkrepl_state__item__repl_stdin : + repl_state -> FStarC_Compiler_Util.stream_reader) = + fun projectee -> + match projectee with + | { repl_line; repl_column; repl_fname; repl_deps_stack; repl_curmod; + repl_env; repl_stdin; repl_names; repl_buffered_input_queries; + repl_lang;_} -> repl_stdin +let (__proj__Mkrepl_state__item__repl_names : + repl_state -> FStarC_Interactive_CompletionTable.table) = + fun projectee -> + match projectee with + | { repl_line; repl_column; repl_fname; repl_deps_stack; repl_curmod; + repl_env; repl_stdin; repl_names; repl_buffered_input_queries; + repl_lang;_} -> repl_names +let (__proj__Mkrepl_state__item__repl_buffered_input_queries : + repl_state -> query Prims.list) = + fun projectee -> + match projectee with + | { repl_line; repl_column; repl_fname; repl_deps_stack; repl_curmod; + repl_env; repl_stdin; repl_names; repl_buffered_input_queries; + repl_lang;_} -> repl_buffered_input_queries +let (__proj__Mkrepl_state__item__repl_lang : + repl_state -> FStarC_Universal.lang_decls_t) = + fun projectee -> + match projectee with + | { repl_line; repl_column; repl_fname; repl_deps_stack; repl_curmod; + repl_env; repl_stdin; repl_names; repl_buffered_input_queries; + repl_lang;_} -> repl_lang +type callback_t = + repl_state -> + ((query_status * FStarC_Json.json Prims.list) * (repl_state, Prims.int) + FStar_Pervasives.either) +type repl_stack_entry_t = (repl_depth_t * (repl_task * repl_state)) +type repl_stack_t = (repl_depth_t * (repl_task * repl_state)) Prims.list +type grepl_state = + { + grepl_repls: repl_state FStarC_Compiler_Util.psmap ; + grepl_stdin: FStarC_Compiler_Util.stream_reader } +let (__proj__Mkgrepl_state__item__grepl_repls : + grepl_state -> repl_state FStarC_Compiler_Util.psmap) = + fun projectee -> + match projectee with | { grepl_repls; grepl_stdin;_} -> grepl_repls +let (__proj__Mkgrepl_state__item__grepl_stdin : + grepl_state -> FStarC_Compiler_Util.stream_reader) = + fun projectee -> + match projectee with | { grepl_repls; grepl_stdin;_} -> grepl_stdin +let (t0 : FStarC_Compiler_Util.time) = FStarC_Compiler_Util.now () +let (dummy_tf_of_fname : Prims.string -> timed_fname) = + fun fname -> { tf_fname = fname; tf_modtime = t0 } +let (string_of_timed_fname : timed_fname -> Prims.string) = + fun uu___ -> + match uu___ with + | { tf_fname = fname; tf_modtime = modtime;_} -> + if modtime = t0 + then FStarC_Compiler_Util.format1 "{ %s }" fname + else + (let uu___2 = FStarC_Compiler_Util.string_of_time modtime in + FStarC_Compiler_Util.format2 "{ %s; %s }" fname uu___2) +let (string_of_repl_task : repl_task -> Prims.string) = + fun uu___ -> + match uu___ with + | LDInterleaved (intf, impl) -> + let uu___1 = string_of_timed_fname intf in + let uu___2 = string_of_timed_fname impl in + FStarC_Compiler_Util.format2 "LDInterleaved (%s, %s)" uu___1 uu___2 + | LDSingle intf_or_impl -> + let uu___1 = string_of_timed_fname intf_or_impl in + FStarC_Compiler_Util.format1 "LDSingle %s" uu___1 + | LDInterfaceOfCurrentFile intf -> + let uu___1 = string_of_timed_fname intf in + FStarC_Compiler_Util.format1 "LDInterfaceOfCurrentFile %s" uu___1 + | PushFragment (FStar_Pervasives.Inl frag, uu___1, uu___2) -> + FStarC_Compiler_Util.format1 "PushFragment { code = %s }" + frag.FStarC_Parser_ParseIt.frag_text + | PushFragment (FStar_Pervasives.Inr d, uu___1, uu___2) -> + let uu___3 = FStarC_Class_Show.show FStarC_Parser_AST.showable_decl d in + FStarC_Compiler_Util.format1 "PushFragment { decl = %s }" uu___3 + | Noop -> "Noop {}" +let (string_of_repl_stack_entry : repl_stack_entry_t -> Prims.string) = + fun uu___ -> + match uu___ with + | ((depth, i), (task, state)) -> + let uu___1 = + let uu___2 = FStarC_Compiler_Util.string_of_int i in + let uu___3 = let uu___4 = string_of_repl_task task in [uu___4] in + uu___2 :: uu___3 in + FStarC_Compiler_Util.format "{depth=%s; task=%s}" uu___1 +let (string_of_repl_stack : repl_stack_entry_t Prims.list -> Prims.string) = + fun s -> + let uu___ = FStarC_Compiler_List.map string_of_repl_stack_entry s in + FStarC_Compiler_String.concat ";\n\t\t" uu___ +let (repl_state_to_string : repl_state -> Prims.string) = + fun r -> + let uu___ = + let uu___1 = FStarC_Compiler_Util.string_of_int r.repl_line in + let uu___2 = + let uu___3 = FStarC_Compiler_Util.string_of_int r.repl_column in + let uu___4 = + let uu___5 = + let uu___6 = + match r.repl_curmod with + | FStar_Pervasives_Native.None -> "None" + | FStar_Pervasives_Native.Some m -> + FStarC_Ident.string_of_lid m.FStarC_Syntax_Syntax.name in + let uu___7 = + let uu___8 = string_of_repl_stack r.repl_deps_stack in [uu___8] in + uu___6 :: uu___7 in + (r.repl_fname) :: uu___5 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Compiler_Util.format + "{\n\trepl_line=%s;\n\trepl_column=%s;\n\trepl_fname=%s;\n\trepl_cur_mod=%s;\n\t\\ \n repl_deps_stack={%s}\n}" + uu___ +let (push_query_to_string : push_query -> Prims.string) = + fun pq -> + let pk = + match pq.push_kind with + | SyntaxCheck -> "SyntaxCheck" + | LaxCheck -> "LaxCheck" + | FullCheck -> "FullCheck" in + let code_or_decl = + match pq.push_code_or_decl with + | FStar_Pervasives.Inl code -> code + | FStar_Pervasives.Inr (_decl, code) -> code.FStarC_Parser_ParseIt.code in + let uu___ = + let uu___1 = + let uu___2 = FStarC_Compiler_Util.string_of_int pq.push_line in + let uu___3 = + let uu___4 = FStarC_Compiler_Util.string_of_int pq.push_column in + let uu___5 = + let uu___6 = + FStarC_Compiler_Util.string_of_bool pq.push_peek_only in + [uu___6; code_or_decl] in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + pk :: uu___1 in + FStarC_Compiler_Util.format + "{ push_kind = %s; push_line = %s; push_column = %s; push_peek_only = %s; push_code_or_decl = %s }" + uu___ +let (query_to_string : query -> Prims.string) = + fun q -> + match q.qq with + | Exit -> "Exit" + | DescribeProtocol -> "DescribeProtocol" + | DescribeRepl -> "DescribeRepl" + | Segment uu___ -> "Segment" + | Pop -> "Pop" + | Push pq -> + let uu___ = + let uu___1 = push_query_to_string pq in Prims.strcat uu___1 ")" in + Prims.strcat "(Push " uu___ + | PushPartialCheckedFile d -> + Prims.strcat "(PushPartialCheckedFile " (Prims.strcat d ")") + | VfsAdd uu___ -> "VfsAdd" + | AutoComplete uu___ -> "AutoComplete" + | Lookup (s, _lc, pos, features, _sr) -> + let uu___ = + match pos with + | FStar_Pervasives_Native.None -> "None" + | FStar_Pervasives_Native.Some (f, i, j) -> + let uu___1 = FStarC_Compiler_Util.string_of_int i in + let uu___2 = FStarC_Compiler_Util.string_of_int j in + FStarC_Compiler_Util.format3 "(%s, %s, %s)" f uu___1 uu___2 in + FStarC_Compiler_Util.format3 "(Lookup %s %s [%s])" s uu___ + (FStarC_Compiler_String.concat "; " features) + | Compute uu___ -> "Compute" + | Search uu___ -> "Search" + | GenericError uu___ -> "GenericError" + | ProtocolViolation uu___ -> "ProtocolViolation" + | FullBuffer uu___ -> "FullBuffer" + | Callback uu___ -> "Callback" + | Format uu___ -> "Format" + | RestartSolver -> "RestartSolver" + | Cancel uu___ -> "Cancel" +let (query_needs_current_module : query' -> Prims.bool) = + fun uu___ -> + match uu___ with + | Exit -> false + | DescribeProtocol -> false + | DescribeRepl -> false + | Segment uu___1 -> false + | Pop -> false + | Push + { push_kind = uu___1; push_line = uu___2; push_column = uu___3; + push_peek_only = false; push_code_or_decl = uu___4;_} + -> false + | VfsAdd uu___1 -> false + | GenericError uu___1 -> false + | ProtocolViolation uu___1 -> false + | PushPartialCheckedFile uu___1 -> false + | FullBuffer uu___1 -> false + | Callback uu___1 -> false + | Format uu___1 -> false + | RestartSolver -> false + | Cancel uu___1 -> false + | Push uu___1 -> true + | AutoComplete uu___1 -> true + | Lookup uu___1 -> true + | Compute uu___1 -> true + | Search uu___1 -> true +let (interactive_protocol_vernum : Prims.int) = (Prims.of_int (2)) +let (interactive_protocol_features : Prims.string Prims.list) = + ["autocomplete"; + "autocomplete/context"; + "compute"; + "compute/reify"; + "compute/pure-subterms"; + "describe-protocol"; + "describe-repl"; + "exit"; + "lookup"; + "lookup/context"; + "lookup/documentation"; + "lookup/definition"; + "peek"; + "pop"; + "push"; + "push-partial-checked-file"; + "search"; + "segment"; + "vfs-add"; + "tactic-ranges"; + "interrupt"; + "progress"; + "full-buffer"; + "format"; + "restart-solver"; + "cancel"] +let (json_of_issue_level : FStarC_Errors.issue_level -> FStarC_Json.json) = + fun i -> + FStarC_Json.JsonStr + (match i with + | FStarC_Errors.ENotImplemented -> "not-implemented" + | FStarC_Errors.EInfo -> "info" + | FStarC_Errors.EWarning -> "warning" + | FStarC_Errors.EError -> "error") +let (json_of_issue : FStarC_Errors.issue -> FStarC_Json.json) = + fun issue -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Errors.format_issue' false issue in + FStarC_Json.JsonStr uu___5 in + ("message", uu___4) in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + match issue.FStarC_Errors.issue_range with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some r -> + let uu___9 = + FStarC_Compiler_Range_Ops.json_of_use_range r in + [uu___9] in + let uu___9 = + match issue.FStarC_Errors.issue_range with + | FStar_Pervasives_Native.Some r when + let uu___10 = FStarC_Compiler_Range_Type.def_range r in + let uu___11 = FStarC_Compiler_Range_Type.use_range r in + uu___10 <> uu___11 -> + let uu___10 = + FStarC_Compiler_Range_Ops.json_of_def_range r in + [uu___10] + | uu___10 -> [] in + FStarC_Compiler_List.op_At uu___8 uu___9 in + FStarC_Json.JsonList uu___7 in + ("ranges", uu___6) in + [uu___5] in + uu___3 :: uu___4 in + FStarC_Compiler_List.op_At + (match issue.FStarC_Errors.issue_number with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some n -> + [("number", (FStarC_Json.JsonInt n))]) uu___2 in + FStarC_Compiler_List.op_At + [("level", (json_of_issue_level issue.FStarC_Errors.issue_level))] + uu___1 in + FStarC_Json.JsonAssoc uu___ +let (js_pushkind : FStarC_Json.json -> push_kind) = + fun s -> + let uu___ = FStarC_Interactive_JsonHelper.js_str s in + match uu___ with + | "syntax" -> SyntaxCheck + | "lax" -> LaxCheck + | "full" -> FullCheck + | uu___1 -> FStarC_Interactive_JsonHelper.js_fail "push_kind" s +let (js_reductionrule : FStarC_Json.json -> FStarC_TypeChecker_Env.step) = + fun s -> + let uu___ = FStarC_Interactive_JsonHelper.js_str s in + match uu___ with + | "beta" -> FStarC_TypeChecker_Env.Beta + | "delta" -> + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant + | "iota" -> FStarC_TypeChecker_Env.Iota + | "zeta" -> FStarC_TypeChecker_Env.Zeta + | "reify" -> FStarC_TypeChecker_Env.Reify + | "pure-subterms" -> + FStarC_TypeChecker_Env.PureSubtermsWithinComputations + | uu___1 -> FStarC_Interactive_JsonHelper.js_fail "reduction rule" s +let (js_optional_completion_context : + FStarC_Json.json FStar_Pervasives_Native.option -> completion_context) = + fun k -> + match k with + | FStar_Pervasives_Native.None -> CKCode + | FStar_Pervasives_Native.Some k1 -> + let uu___ = FStarC_Interactive_JsonHelper.js_str k1 in + (match uu___ with + | "symbol" -> CKCode + | "code" -> CKCode + | "set-options" -> CKOption false + | "reset-options" -> CKOption true + | "open" -> CKModuleOrNamespace (true, true) + | "let-open" -> CKModuleOrNamespace (true, true) + | "include" -> CKModuleOrNamespace (true, false) + | "module-alias" -> CKModuleOrNamespace (true, false) + | uu___1 -> + FStarC_Interactive_JsonHelper.js_fail + "completion context (code, set-options, reset-options, open, let-open, include, module-alias)" + k1) +let (js_optional_lookup_context : + FStarC_Json.json FStar_Pervasives_Native.option -> lookup_context) = + fun k -> + match k with + | FStar_Pervasives_Native.None -> LKSymbolOnly + | FStar_Pervasives_Native.Some k1 -> + let uu___ = FStarC_Interactive_JsonHelper.js_str k1 in + (match uu___ with + | "symbol-only" -> LKSymbolOnly + | "code" -> LKCode + | "set-options" -> LKOption + | "reset-options" -> LKOption + | "open" -> LKModule + | "let-open" -> LKModule + | "include" -> LKModule + | "module-alias" -> LKModule + | uu___1 -> + FStarC_Interactive_JsonHelper.js_fail + "lookup context (symbol-only, code, set-options, reset-options, open, let-open, include, module-alias)" + k1) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Interactive_Incremental.ml b/ocaml/fstar-lib/generated/FStarC_Interactive_Incremental.ml new file mode 100644 index 00000000000..b13b043b82a --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Interactive_Incremental.ml @@ -0,0 +1,588 @@ +open Prims +type fragment_progress = + | FullBufferStarted + | FragmentStarted of FStarC_Parser_AST.decl + | FragmentSuccess of (FStarC_Parser_AST.decl * + FStarC_Parser_ParseIt.code_fragment * + FStarC_Interactive_Ide_Types.push_kind) + | FragmentFailed of FStarC_Parser_AST.decl + | FragmentError of FStarC_Errors.issue Prims.list + | FullBufferFinished +let (uu___is_FullBufferStarted : fragment_progress -> Prims.bool) = + fun projectee -> + match projectee with | FullBufferStarted -> true | uu___ -> false +let (uu___is_FragmentStarted : fragment_progress -> Prims.bool) = + fun projectee -> + match projectee with | FragmentStarted _0 -> true | uu___ -> false +let (__proj__FragmentStarted__item___0 : + fragment_progress -> FStarC_Parser_AST.decl) = + fun projectee -> match projectee with | FragmentStarted _0 -> _0 +let (uu___is_FragmentSuccess : fragment_progress -> Prims.bool) = + fun projectee -> + match projectee with | FragmentSuccess _0 -> true | uu___ -> false +let (__proj__FragmentSuccess__item___0 : + fragment_progress -> + (FStarC_Parser_AST.decl * FStarC_Parser_ParseIt.code_fragment * + FStarC_Interactive_Ide_Types.push_kind)) + = fun projectee -> match projectee with | FragmentSuccess _0 -> _0 +let (uu___is_FragmentFailed : fragment_progress -> Prims.bool) = + fun projectee -> + match projectee with | FragmentFailed _0 -> true | uu___ -> false +let (__proj__FragmentFailed__item___0 : + fragment_progress -> FStarC_Parser_AST.decl) = + fun projectee -> match projectee with | FragmentFailed _0 -> _0 +let (uu___is_FragmentError : fragment_progress -> Prims.bool) = + fun projectee -> + match projectee with | FragmentError _0 -> true | uu___ -> false +let (__proj__FragmentError__item___0 : + fragment_progress -> FStarC_Errors.issue Prims.list) = + fun projectee -> match projectee with | FragmentError _0 -> _0 +let (uu___is_FullBufferFinished : fragment_progress -> Prims.bool) = + fun projectee -> + match projectee with | FullBufferFinished -> true | uu___ -> false +type qid = (Prims.string * Prims.int) +type 'a qst = qid -> ('a * qid) +let return : 'a . 'a -> 'a qst = fun x -> fun q -> (x, q) +let op_let_Bang : 'a 'b . 'a qst -> ('a -> 'b qst) -> 'b qst = + fun f -> + fun g -> + fun q -> + let uu___ = f q in + match uu___ with | (x, q') -> let uu___1 = g x in uu___1 q' +let run_qst : 'a . 'a qst -> Prims.string -> 'a = + fun f -> + fun q -> + let uu___ = f (q, Prims.int_zero) in FStar_Pervasives_Native.fst uu___ +let rec map : 'a 'b . ('a -> 'b qst) -> 'a Prims.list -> 'b Prims.list qst = + fun f -> + fun l -> + match l with + | [] -> return [] + | hd::tl -> + let uu___ = f hd in + op_let_Bang uu___ + (fun hd1 -> + let uu___1 = map f tl in + op_let_Bang uu___1 (fun tl1 -> return (hd1 :: tl1))) +let (shift_qid : qid -> Prims.int -> (Prims.string * Prims.int)) = + fun q -> + fun i -> + ((FStar_Pervasives_Native.fst q), + ((FStar_Pervasives_Native.snd q) + i)) +let (next_qid : qid qst) = + fun q -> let q1 = shift_qid q Prims.int_one in (q1, q1) +let (get_qid : qid qst) = fun q -> (q, q) +let (as_query : + FStarC_Interactive_Ide_Types.query' -> + FStarC_Interactive_Ide_Types.query qst) + = + fun q -> + op_let_Bang next_qid + (fun uu___ -> + match uu___ with + | (qid_prefix, i) -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Compiler_Util.string_of_int i in + Prims.strcat "." uu___4 in + Prims.strcat qid_prefix uu___3 in + { + FStarC_Interactive_Ide_Types.qq = q; + FStarC_Interactive_Ide_Types.qid = uu___2 + } in + return uu___1) +let (dump_symbols_for_lid : + FStarC_Ident.lident -> FStarC_Interactive_Ide_Types.query qst) = + fun l -> + let r = FStarC_Ident.range_of_lid l in + let start_pos = FStarC_Compiler_Range_Ops.start_of_range r in + let end_pos = FStarC_Compiler_Range_Ops.end_of_range r in + let start_line = FStarC_Compiler_Range_Ops.line_of_pos start_pos in + let start_col = FStarC_Compiler_Range_Ops.col_of_pos start_pos in + let end_line = FStarC_Compiler_Range_Ops.line_of_pos end_pos in + let end_col = FStarC_Compiler_Range_Ops.col_of_pos end_pos in + let position = ("", start_line, start_col) in + let uu___ = + let uu___1 = + let uu___2 = FStarC_Ident.string_of_lid l in + (uu___2, FStarC_Interactive_Ide_Types.LKCode, + (FStar_Pervasives_Native.Some position), + ["type"; "documentation"; "defined-at"], + (FStar_Pervasives_Native.Some + (FStarC_Json.JsonAssoc + [("fname", (FStarC_Json.JsonStr "")); + ("beg", + (FStarC_Json.JsonList + [FStarC_Json.JsonInt start_line; + FStarC_Json.JsonInt start_col])); + ("end", + (FStarC_Json.JsonList + [FStarC_Json.JsonInt end_line; + FStarC_Json.JsonInt end_col]))]))) in + FStarC_Interactive_Ide_Types.Lookup uu___1 in + as_query uu___ +let (dump_symbols : + FStarC_Parser_AST.decl -> FStarC_Interactive_Ide_Types.query Prims.list qst) + = + fun d -> + let ls = FStarC_Parser_AST_Util.lidents_of_decl d in + map dump_symbols_for_lid ls +let (push_decl : + FStarC_Interactive_Ide_Types.push_kind -> + Prims.bool -> + (fragment_progress -> unit) -> + (FStarC_Parser_AST.decl * FStarC_Parser_ParseIt.code_fragment) -> + FStarC_Interactive_Ide_Types.query Prims.list qst) + = + fun push_kind -> + fun with_symbols -> + fun write_full_buffer_fragment_progress -> + fun ds -> + let uu___ = ds in + match uu___ with + | (d, s) -> + let pq = + let uu___1 = + let uu___2 = + FStarC_Compiler_Range_Ops.start_of_range + d.FStarC_Parser_AST.drange in + FStarC_Compiler_Range_Ops.line_of_pos uu___2 in + let uu___2 = + let uu___3 = + FStarC_Compiler_Range_Ops.start_of_range + d.FStarC_Parser_AST.drange in + FStarC_Compiler_Range_Ops.col_of_pos uu___3 in + { + FStarC_Interactive_Ide_Types.push_kind = push_kind; + FStarC_Interactive_Ide_Types.push_line = uu___1; + FStarC_Interactive_Ide_Types.push_column = uu___2; + FStarC_Interactive_Ide_Types.push_peek_only = false; + FStarC_Interactive_Ide_Types.push_code_or_decl = + (FStar_Pervasives.Inr ds) + } in + let progress st = + write_full_buffer_fragment_progress (FragmentStarted d); + ((FStarC_Interactive_Ide_Types.QueryOK, []), + (FStar_Pervasives.Inl st)) in + let uu___1 = + as_query (FStarC_Interactive_Ide_Types.Callback progress) in + op_let_Bang uu___1 + (fun cb -> + let uu___2 = + as_query (FStarC_Interactive_Ide_Types.Push pq) in + op_let_Bang uu___2 + (fun push -> + if with_symbols + then + let uu___3 = dump_symbols d in + op_let_Bang uu___3 + (fun lookups -> + return + (FStarC_Compiler_List.op_At [cb; push] + lookups)) + else return [cb; push])) +let (push_decls : + FStarC_Interactive_Ide_Types.push_kind -> + Prims.bool -> + (fragment_progress -> unit) -> + (FStarC_Parser_AST.decl * FStarC_Parser_ParseIt.code_fragment) + Prims.list -> FStarC_Interactive_Ide_Types.query Prims.list qst) + = + fun push_kind -> + fun with_symbols -> + fun write_full_buffer_fragment_progress -> + fun ds -> + let uu___ = + map + (push_decl push_kind with_symbols + write_full_buffer_fragment_progress) ds in + op_let_Bang uu___ + (fun qs -> return (FStarC_Compiler_List.flatten qs)) +let (pop_entries : + FStarC_Interactive_Ide_Types.repl_stack_entry_t Prims.list -> + FStarC_Interactive_Ide_Types.query Prims.list qst) + = fun e -> map (fun uu___ -> as_query FStarC_Interactive_Ide_Types.Pop) e +let repl_task : + 'uuuuu 'uuuuu1 'uuuuu2 . ('uuuuu * ('uuuuu1 * 'uuuuu2)) -> 'uuuuu1 = + fun uu___ -> match uu___ with | (uu___1, (p, uu___2)) -> p +let (inspect_repl_stack : + FStarC_Interactive_Ide_Types.repl_stack_t -> + (FStarC_Parser_AST.decl * FStarC_Parser_ParseIt.code_fragment) Prims.list + -> + FStarC_Interactive_Ide_Types.push_kind -> + Prims.bool -> + (fragment_progress -> unit) -> + (FStarC_Interactive_Ide_Types.query Prims.list * FStarC_Json.json + Prims.list) qst) + = + fun s -> + fun ds -> + fun push_kind -> + fun with_symbols -> + fun write_full_buffer_fragment_progress -> + let entries = FStarC_Compiler_List.rev s in + let push_decls1 = + push_decls push_kind with_symbols + write_full_buffer_fragment_progress in + let uu___ = + FStarC_Compiler_Util.prefix_until + (fun uu___1 -> + match uu___1 with + | (uu___2, + (FStarC_Interactive_Ide_Types.PushFragment uu___3, + uu___4)) -> true + | uu___2 -> false) entries in + match uu___ with + | FStar_Pervasives_Native.None -> + let uu___1 = push_decls1 ds in + op_let_Bang uu___1 (fun ds1 -> return (ds1, [])) + | FStar_Pervasives_Native.Some (prefix, first_push, rest) -> + let entries1 = first_push :: rest in + let repl_task1 uu___1 = + match uu___1 with | (uu___2, (p, uu___3)) -> p in + let rec matching_prefix accum lookups entries2 ds1 = + match (entries2, ds1) with + | ([], []) -> return (lookups, accum) + | (e::entries3, d::ds2) -> + (match repl_task1 e with + | FStarC_Interactive_Ide_Types.Noop -> + matching_prefix accum lookups entries3 (d :: ds2) + | FStarC_Interactive_Ide_Types.PushFragment + (FStar_Pervasives.Inl frag, uu___1, uu___2) -> + let uu___3 = pop_entries (e :: entries3) in + op_let_Bang uu___3 + (fun pops -> + let uu___4 = push_decls1 (d :: ds2) in + op_let_Bang uu___4 + (fun pushes -> + return + ((FStarC_Compiler_List.op_At lookups + (FStarC_Compiler_List.op_At pops + pushes)), accum))) + | FStarC_Interactive_Ide_Types.PushFragment + (FStar_Pervasives.Inr d', pk, issues) -> + let uu___1 = + FStarC_Parser_AST_Util.eq_decl + (FStar_Pervasives_Native.fst d) d' in + if uu___1 + then + let uu___2 = d in + (match uu___2 with + | (d1, s1) -> + (write_full_buffer_fragment_progress + (FragmentSuccess (d1, s1, pk)); + if with_symbols + then + (let uu___4 = dump_symbols d1 in + op_let_Bang uu___4 + (fun lookups' -> + matching_prefix + (FStarC_Compiler_List.op_At + issues accum) + (FStarC_Compiler_List.op_At + lookups' lookups) entries3 + ds2)) + else + matching_prefix + (FStarC_Compiler_List.op_At issues + accum) lookups entries3 ds2)) + else + (let uu___3 = pop_entries (e :: entries3) in + op_let_Bang uu___3 + (fun pops -> + let uu___4 = push_decls1 (d :: ds2) in + op_let_Bang uu___4 + (fun pushes -> + return + ((FStarC_Compiler_List.op_At pops + (FStarC_Compiler_List.op_At + lookups pushes)), accum))))) + | ([], ds2) -> + let uu___1 = push_decls1 ds2 in + op_let_Bang uu___1 + (fun pushes -> + return + ((FStarC_Compiler_List.op_At lookups pushes), + accum)) + | (es, []) -> + let uu___1 = pop_entries es in + op_let_Bang uu___1 + (fun pops -> + return + ((FStarC_Compiler_List.op_At lookups pops), + accum)) in + matching_prefix [] [] entries1 ds +let reload_deps : + 'uuuuu 'uuuuu1 . + ('uuuuu * (FStarC_Interactive_Ide_Types.repl_task * 'uuuuu1)) Prims.list + -> FStarC_Interactive_Ide_Types.query Prims.list qst + = + fun repl_stack -> + let pop_until_deps entries = + let uu___ = + FStarC_Compiler_Util.prefix_until + (fun e -> + match repl_task e with + | FStarC_Interactive_Ide_Types.PushFragment uu___1 -> false + | FStarC_Interactive_Ide_Types.Noop -> false + | uu___1 -> true) entries in + match uu___ with + | FStar_Pervasives_Native.None -> return [] + | FStar_Pervasives_Native.Some (prefix, uu___1, uu___2) -> + let uu___3 = as_query FStarC_Interactive_Ide_Types.Pop in + op_let_Bang uu___3 + (fun pop -> + let uu___4 = + FStarC_Compiler_List.map (fun uu___5 -> pop) prefix in + return uu___4) in + pop_until_deps repl_stack +let (parse_code : + FStarC_Parser_ParseIt.lang_opts -> + Prims.string -> FStarC_Parser_ParseIt.parse_result) + = + fun lang -> + fun code -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Compiler_Range_Ops.file_of_range + FStarC_Interactive_Ide_Types.initial_range in + let uu___3 = + let uu___4 = + FStarC_Compiler_Range_Ops.start_of_range + FStarC_Interactive_Ide_Types.initial_range in + FStarC_Compiler_Range_Ops.line_of_pos uu___4 in + let uu___4 = + let uu___5 = + FStarC_Compiler_Range_Ops.start_of_range + FStarC_Interactive_Ide_Types.initial_range in + FStarC_Compiler_Range_Ops.col_of_pos uu___5 in + { + FStarC_Parser_ParseIt.frag_fname = uu___2; + FStarC_Parser_ParseIt.frag_text = code; + FStarC_Parser_ParseIt.frag_line = uu___3; + FStarC_Parser_ParseIt.frag_col = uu___4 + } in + FStarC_Parser_ParseIt.Incremental uu___1 in + FStarC_Parser_ParseIt.parse lang uu___ +let (syntax_issue : + (FStarC_Errors_Codes.error_code * FStarC_Errors_Msg.error_message * + FStarC_Compiler_Range_Type.range) -> FStarC_Errors.issue) + = + fun uu___ -> + match uu___ with + | (raw_error, msg, range) -> + let uu___1 = FStarC_Errors.lookup raw_error in + (match uu___1 with + | (uu___2, uu___3, num) -> + let issue = + { + FStarC_Errors.issue_msg = msg; + FStarC_Errors.issue_level = FStarC_Errors.EError; + FStarC_Errors.issue_range = + (FStar_Pervasives_Native.Some range); + FStarC_Errors.issue_number = + (FStar_Pervasives_Native.Some num); + FStarC_Errors.issue_ctx = [] + } in + issue) +let (run_full_buffer : + FStarC_Interactive_Ide_Types.repl_state -> + Prims.string -> + Prims.string -> + FStarC_Interactive_Ide_Types.full_buffer_request_kind -> + Prims.bool -> + (fragment_progress -> unit) -> + (FStarC_Interactive_Ide_Types.query Prims.list * + FStarC_Json.json Prims.list)) + = + fun st -> + fun qid1 -> + fun code -> + fun request_type -> + fun with_symbols -> + fun write_full_buffer_fragment_progress -> + let parse_result = parse_code FStar_Pervasives_Native.None code in + let log_syntax_issues err = + match err with + | FStar_Pervasives_Native.None -> () + | FStar_Pervasives_Native.Some err1 -> + let issue = syntax_issue err1 in + write_full_buffer_fragment_progress + (FragmentError [issue]) in + let filter_decls decls = + match request_type with + | FStarC_Interactive_Ide_Types.VerifyToPosition + (uu___, line, _col) -> + FStarC_Compiler_List.filter + (fun uu___1 -> + match uu___1 with + | (d, uu___2) -> + let start = + FStarC_Compiler_Range_Ops.start_of_range + d.FStarC_Parser_AST.drange in + let start_line = + FStarC_Compiler_Range_Ops.line_of_pos start in + start_line <= line) decls + | FStarC_Interactive_Ide_Types.LaxToPosition + (uu___, line, _col) -> + FStarC_Compiler_List.filter + (fun uu___1 -> + match uu___1 with + | (d, uu___2) -> + let start = + FStarC_Compiler_Range_Ops.start_of_range + d.FStarC_Parser_AST.drange in + let start_line = + FStarC_Compiler_Range_Ops.line_of_pos start in + start_line <= line) decls + | uu___ -> decls in + let qs = + match parse_result with + | FStarC_Parser_ParseIt.IncrementalFragment + (decls, uu___, err_opt) -> + ((let uu___2 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length decls) in + FStarC_Compiler_Util.print1 "Parsed %s declarations\n" + uu___2); + (match (request_type, decls) with + | (FStarC_Interactive_Ide_Types.ReloadDeps, d::uu___2) + -> + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Compiler_Effect.op_Bang + FStarC_Interactive_PushHelper.repl_stack in + reload_deps uu___5 in + op_let_Bang uu___4 + (fun queries -> + let uu___5 = + push_decl + FStarC_Interactive_Ide_Types.FullCheck + with_symbols + write_full_buffer_fragment_progress d in + op_let_Bang uu___5 + (fun push_mod -> + return + ((FStarC_Compiler_List.op_At queries + push_mod), []))) in + run_qst uu___3 qid1 + | uu___2 -> + let decls1 = filter_decls decls in + let push_kind = + match request_type with + | FStarC_Interactive_Ide_Types.LaxToPosition + uu___3 -> + FStarC_Interactive_Ide_Types.LaxCheck + | FStarC_Interactive_Ide_Types.Lax -> + FStarC_Interactive_Ide_Types.LaxCheck + | uu___3 -> + FStarC_Interactive_Ide_Types.FullCheck in + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Compiler_Effect.op_Bang + FStarC_Interactive_PushHelper.repl_stack in + inspect_repl_stack uu___5 decls1 push_kind + with_symbols + write_full_buffer_fragment_progress in + run_qst uu___4 qid1 in + (match uu___3 with + | (queries, issues) -> + (if + request_type <> + FStarC_Interactive_Ide_Types.Cache + then log_syntax_issues err_opt + else (); + (let uu___6 = FStarC_Compiler_Debug.any () in + if uu___6 + then + let uu___7 = + let uu___8 = + FStarC_Compiler_List.map + FStarC_Interactive_Ide_Types.query_to_string + queries in + FStarC_Compiler_String.concat "\n" + uu___8 in + FStarC_Compiler_Util.print1 + "Generating queries\n%s\n" uu___7 + else ()); + if + request_type <> + FStarC_Interactive_Ide_Types.Cache + then (queries, issues) + else ([], issues))))) + | FStarC_Parser_ParseIt.ParseError err -> + (if request_type = FStarC_Interactive_Ide_Types.Full + then + log_syntax_issues (FStar_Pervasives_Native.Some err) + else (); + ([], [])) + | uu___ -> failwith "Unexpected parse result" in + qs +let (format_code : + FStarC_Interactive_Ide_Types.repl_state -> + Prims.string -> + (Prims.string, FStarC_Errors.issue Prims.list) FStar_Pervasives.either) + = + fun st -> + fun code -> + let maybe_lang = + match st.FStarC_Interactive_Ide_Types.repl_lang with + | [] -> FStar_Pervasives_Native.None + | { FStarC_Parser_AST.d = FStarC_Parser_AST.UseLangDecls l; + FStarC_Parser_AST.drange = uu___; + FStarC_Parser_AST.quals = uu___1; + FStarC_Parser_AST.attrs = uu___2; + FStarC_Parser_AST.interleaved = uu___3;_}::uu___4 -> + FStar_Pervasives_Native.Some l in + let parse_result = parse_code maybe_lang code in + match parse_result with + | FStarC_Parser_ParseIt.IncrementalFragment + (decls, comments, FStar_Pervasives_Native.None) -> + let doc_to_string doc = + FStarC_Pprint.pretty_string + (FStarC_Compiler_Util.float_of_string "1.0") + (Prims.of_int (100)) doc in + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun uu___2 -> + match (uu___1, uu___2) with + | ((out, comments1), (d, uu___3)) -> + let uu___4 = + FStarC_Parser_ToDocument.decl_with_comments_to_document + d comments1 in + (match uu___4 with + | (doc, comments2) -> + let uu___5 = + let uu___6 = doc_to_string doc in uu___6 :: out in + (uu___5, comments2))) + ([], (FStarC_Compiler_List.rev comments)) decls in + (match uu___ with + | (formatted_code_rev, leftover_comments) -> + let code1 = + FStarC_Compiler_String.concat "\n\n" + (FStarC_Compiler_List.rev formatted_code_rev) in + let formatted_code = + match leftover_comments with + | [] -> code1 + | uu___1 -> + let doc = + FStarC_Parser_ToDocument.comments_to_document + leftover_comments in + let uu___2 = + let uu___3 = doc_to_string doc in + Prims.strcat "\n\n" uu___3 in + Prims.strcat code1 uu___2 in + FStar_Pervasives.Inl formatted_code) + | FStarC_Parser_ParseIt.IncrementalFragment + (uu___, uu___1, FStar_Pervasives_Native.Some err) -> + let uu___2 = let uu___3 = syntax_issue err in [uu___3] in + FStar_Pervasives.Inr uu___2 + | FStarC_Parser_ParseIt.ParseError err -> + let uu___ = let uu___1 = syntax_issue err in [uu___1] in + FStar_Pervasives.Inr uu___ + | uu___ -> failwith "Unexpected parse result" \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Interactive_JsonHelper.ml b/ocaml/fstar-lib/generated/FStarC_Interactive_JsonHelper.ml new file mode 100644 index 00000000000..2662a42050d --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Interactive_JsonHelper.ml @@ -0,0 +1,751 @@ +open Prims +type assoct = (Prims.string * FStarC_Json.json) Prims.list +let (try_assoc : + Prims.string -> assoct -> FStarC_Json.json FStar_Pervasives_Native.option) + = + fun key -> + fun d -> + let uu___ = + FStarC_Compiler_Util.try_find + (fun uu___1 -> match uu___1 with | (k, uu___2) -> k = key) d in + FStarC_Compiler_Util.map_option FStar_Pervasives_Native.snd uu___ +exception MissingKey of Prims.string +let (uu___is_MissingKey : Prims.exn -> Prims.bool) = + fun projectee -> + match projectee with | MissingKey uu___ -> true | uu___ -> false +let (__proj__MissingKey__item__uu___ : Prims.exn -> Prims.string) = + fun projectee -> match projectee with | MissingKey uu___ -> uu___ +exception InvalidQuery of Prims.string +let (uu___is_InvalidQuery : Prims.exn -> Prims.bool) = + fun projectee -> + match projectee with | InvalidQuery uu___ -> true | uu___ -> false +let (__proj__InvalidQuery__item__uu___ : Prims.exn -> Prims.string) = + fun projectee -> match projectee with | InvalidQuery uu___ -> uu___ +exception UnexpectedJsonType of (Prims.string * FStarC_Json.json) +let (uu___is_UnexpectedJsonType : Prims.exn -> Prims.bool) = + fun projectee -> + match projectee with | UnexpectedJsonType uu___ -> true | uu___ -> false +let (__proj__UnexpectedJsonType__item__uu___ : + Prims.exn -> (Prims.string * FStarC_Json.json)) = + fun projectee -> match projectee with | UnexpectedJsonType uu___ -> uu___ +exception MalformedHeader +let (uu___is_MalformedHeader : Prims.exn -> Prims.bool) = + fun projectee -> + match projectee with | MalformedHeader -> true | uu___ -> false +exception InputExhausted +let (uu___is_InputExhausted : Prims.exn -> Prims.bool) = + fun projectee -> + match projectee with | InputExhausted -> true | uu___ -> false +let (assoc : Prims.string -> assoct -> FStarC_Json.json) = + fun key -> + fun a -> + let uu___ = try_assoc key a in + match uu___ with + | FStar_Pervasives_Native.Some v -> v + | FStar_Pervasives_Native.None -> + let uu___1 = + let uu___2 = FStarC_Compiler_Util.format1 "Missing key [%s]" key in + MissingKey uu___2 in + FStarC_Compiler_Effect.raise uu___1 +let (write_json : FStarC_Json.json -> unit) = + fun js -> + (let uu___1 = FStarC_Json.string_of_json js in + FStarC_Compiler_Util.print_raw uu___1); + FStarC_Compiler_Util.print_raw "\n" +let (write_jsonrpc : FStarC_Json.json -> unit) = + fun js -> + let js_str = FStarC_Json.string_of_json js in + let len = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_String.length js_str) in + let uu___ = + FStarC_Compiler_Util.format2 "Content-Length: %s\r\n\r\n%s" len js_str in + FStarC_Compiler_Util.print_raw uu___ +let js_fail : 'a . Prims.string -> FStarC_Json.json -> 'a = + fun expected -> + fun got -> + FStarC_Compiler_Effect.raise (UnexpectedJsonType (expected, got)) +let (js_int : FStarC_Json.json -> Prims.int) = + fun uu___ -> + match uu___ with + | FStarC_Json.JsonInt i -> i + | other -> js_fail "int" other +let (js_bool : FStarC_Json.json -> Prims.bool) = + fun uu___ -> + match uu___ with + | FStarC_Json.JsonBool b -> b + | other -> js_fail "int" other +let (js_str : FStarC_Json.json -> Prims.string) = + fun uu___ -> + match uu___ with + | FStarC_Json.JsonStr s -> s + | other -> js_fail "string" other +let js_list : + 'a . (FStarC_Json.json -> 'a) -> FStarC_Json.json -> 'a Prims.list = + fun k -> + fun uu___ -> + match uu___ with + | FStarC_Json.JsonList l -> FStarC_Compiler_List.map k l + | other -> js_fail "list" other +let (js_assoc : FStarC_Json.json -> assoct) = + fun uu___ -> + match uu___ with + | FStarC_Json.JsonAssoc a -> a + | other -> js_fail "dictionary" other +let (js_str_int : FStarC_Json.json -> Prims.int) = + fun uu___ -> + match uu___ with + | FStarC_Json.JsonInt i -> i + | FStarC_Json.JsonStr s -> FStarC_Compiler_Util.int_of_string s + | other -> js_fail "string or int" other +let (arg : Prims.string -> assoct -> FStarC_Json.json) = + fun k -> + fun r -> + let uu___ = let uu___1 = assoc "params" r in js_assoc uu___1 in + assoc k uu___ +let (uri_to_path : Prims.string -> Prims.string) = + fun u -> + let uu___ = + let uu___1 = + FStarC_Compiler_Util.substring u (Prims.of_int (9)) + (Prims.of_int (3)) in + uu___1 = "%3A" in + if uu___ + then + let uu___1 = + FStarC_Compiler_Util.substring u (Prims.of_int (8)) Prims.int_one in + let uu___2 = FStarC_Compiler_Util.substring_from u (Prims.of_int (12)) in + FStarC_Compiler_Util.format2 "%s:%s" uu___1 uu___2 + else FStarC_Compiler_Util.substring_from u (Prims.of_int (7)) +type completion_context = + { + trigger_kind: Prims.int ; + trigger_char: Prims.string FStar_Pervasives_Native.option } +let (__proj__Mkcompletion_context__item__trigger_kind : + completion_context -> Prims.int) = + fun projectee -> + match projectee with | { trigger_kind; trigger_char;_} -> trigger_kind +let (__proj__Mkcompletion_context__item__trigger_char : + completion_context -> Prims.string FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with | { trigger_kind; trigger_char;_} -> trigger_char +let (path_to_uri : Prims.string -> Prims.string) = + fun u -> + let uu___ = + let uu___1 = FStarC_Compiler_Util.char_at u Prims.int_one in + uu___1 = 58 in + if uu___ + then + let rest = + let uu___1 = FStarC_Compiler_Util.substring_from u (Prims.of_int (2)) in + FStarC_Compiler_Util.replace_char uu___1 92 47 in + let uu___1 = + FStarC_Compiler_Util.substring u Prims.int_zero Prims.int_one in + FStarC_Compiler_Util.format2 "file:///%s%3A%s" uu___1 rest + else FStarC_Compiler_Util.format1 "file://%s" u +let (js_compl_context : FStarC_Json.json -> completion_context) = + fun uu___ -> + match uu___ with + | FStarC_Json.JsonAssoc a -> + let uu___1 = let uu___2 = assoc "triggerKind" a in js_int uu___2 in + let uu___2 = + let uu___3 = try_assoc "triggerChar" a in + FStarC_Compiler_Util.map_option js_str uu___3 in + { trigger_kind = uu___1; trigger_char = uu___2 } + | other -> js_fail "dictionary" other +type txdoc_item = + { + fname: Prims.string ; + langId: Prims.string ; + version: Prims.int ; + text: Prims.string } +let (__proj__Mktxdoc_item__item__fname : txdoc_item -> Prims.string) = + fun projectee -> + match projectee with | { fname; langId; version; text;_} -> fname +let (__proj__Mktxdoc_item__item__langId : txdoc_item -> Prims.string) = + fun projectee -> + match projectee with | { fname; langId; version; text;_} -> langId +let (__proj__Mktxdoc_item__item__version : txdoc_item -> Prims.int) = + fun projectee -> + match projectee with | { fname; langId; version; text;_} -> version +let (__proj__Mktxdoc_item__item__text : txdoc_item -> Prims.string) = + fun projectee -> + match projectee with | { fname; langId; version; text;_} -> text +let (js_txdoc_item : FStarC_Json.json -> txdoc_item) = + fun uu___ -> + match uu___ with + | FStarC_Json.JsonAssoc a -> + let arg1 k = assoc k a in + let uu___1 = + let uu___2 = let uu___3 = arg1 "uri" in js_str uu___3 in + uri_to_path uu___2 in + let uu___2 = let uu___3 = arg1 "languageId" in js_str uu___3 in + let uu___3 = let uu___4 = arg1 "version" in js_int uu___4 in + let uu___4 = let uu___5 = arg1 "text" in js_str uu___5 in + { fname = uu___1; langId = uu___2; version = uu___3; text = uu___4 } + | other -> js_fail "dictionary" other +type txdoc_pos = { + path: Prims.string ; + line: Prims.int ; + col: Prims.int } +let (__proj__Mktxdoc_pos__item__path : txdoc_pos -> Prims.string) = + fun projectee -> match projectee with | { path; line; col;_} -> path +let (__proj__Mktxdoc_pos__item__line : txdoc_pos -> Prims.int) = + fun projectee -> match projectee with | { path; line; col;_} -> line +let (__proj__Mktxdoc_pos__item__col : txdoc_pos -> Prims.int) = + fun projectee -> match projectee with | { path; line; col;_} -> col +let (js_txdoc_id : assoct -> Prims.string) = + fun r -> + let uu___ = + let uu___1 = + let uu___2 = let uu___3 = arg "textDocument" r in js_assoc uu___3 in + assoc "uri" uu___2 in + js_str uu___1 in + uri_to_path uu___ +let (js_txdoc_pos : assoct -> txdoc_pos) = + fun r -> + let pos = let uu___ = arg "position" r in js_assoc uu___ in + let uu___ = js_txdoc_id r in + let uu___1 = let uu___2 = assoc "line" pos in js_int uu___2 in + let uu___2 = let uu___3 = assoc "character" pos in js_int uu___3 in + { path = uu___; line = uu___1; col = uu___2 } +type workspace_folder = { + wk_uri: Prims.string ; + wk_name: Prims.string } +let (__proj__Mkworkspace_folder__item__wk_uri : + workspace_folder -> Prims.string) = + fun projectee -> match projectee with | { wk_uri; wk_name;_} -> wk_uri +let (__proj__Mkworkspace_folder__item__wk_name : + workspace_folder -> Prims.string) = + fun projectee -> match projectee with | { wk_uri; wk_name;_} -> wk_name +type wsch_event = { + added: workspace_folder ; + removed: workspace_folder } +let (__proj__Mkwsch_event__item__added : wsch_event -> workspace_folder) = + fun projectee -> match projectee with | { added; removed;_} -> added +let (__proj__Mkwsch_event__item__removed : wsch_event -> workspace_folder) = + fun projectee -> match projectee with | { added; removed;_} -> removed +let (js_wsch_event : FStarC_Json.json -> wsch_event) = + fun uu___ -> + match uu___ with + | FStarC_Json.JsonAssoc a -> + let added' = let uu___1 = assoc "added" a in js_assoc uu___1 in + let removed' = let uu___1 = assoc "removed" a in js_assoc uu___1 in + let uu___1 = + let uu___2 = let uu___3 = assoc "uri" added' in js_str uu___3 in + let uu___3 = let uu___4 = assoc "name" added' in js_str uu___4 in + { wk_uri = uu___2; wk_name = uu___3 } in + let uu___2 = + let uu___3 = let uu___4 = assoc "uri" removed' in js_str uu___4 in + let uu___4 = let uu___5 = assoc "name" removed' in js_str uu___5 in + { wk_uri = uu___3; wk_name = uu___4 } in + { added = uu___1; removed = uu___2 } + | other -> js_fail "dictionary" other +let (js_contentch : FStarC_Json.json -> Prims.string) = + fun uu___ -> + match uu___ with + | FStarC_Json.JsonList l -> + let uu___1 = + FStarC_Compiler_List.map + (fun uu___2 -> + match uu___2 with + | FStarC_Json.JsonAssoc a -> + let uu___3 = assoc "text" a in js_str uu___3) l in + FStarC_Compiler_List.hd uu___1 + | other -> js_fail "dictionary" other +type lquery = + | Initialize of (Prims.int * Prims.string) + | Initialized + | Shutdown + | Exit + | Cancel of Prims.int + | FolderChange of wsch_event + | ChangeConfig + | ChangeWatch + | Symbol of Prims.string + | ExecCommand of Prims.string + | DidOpen of txdoc_item + | DidChange of (Prims.string * Prims.string) + | WillSave of Prims.string + | WillSaveWait of Prims.string + | DidSave of (Prims.string * Prims.string) + | DidClose of Prims.string + | Completion of (txdoc_pos * completion_context) + | Resolve + | Hover of txdoc_pos + | SignatureHelp of txdoc_pos + | Declaration of txdoc_pos + | Definition of txdoc_pos + | TypeDefinition of txdoc_pos + | Implementation of txdoc_pos + | References + | DocumentHighlight of txdoc_pos + | DocumentSymbol + | CodeAction + | CodeLens + | CodeLensResolve + | DocumentLink + | DocumentLinkResolve + | DocumentColor + | ColorPresentation + | Formatting + | RangeFormatting + | TypeFormatting + | Rename + | PrepareRename of txdoc_pos + | FoldingRange + | BadProtocolMsg of Prims.string +let (uu___is_Initialize : lquery -> Prims.bool) = + fun projectee -> + match projectee with | Initialize _0 -> true | uu___ -> false +let (__proj__Initialize__item___0 : lquery -> (Prims.int * Prims.string)) = + fun projectee -> match projectee with | Initialize _0 -> _0 +let (uu___is_Initialized : lquery -> Prims.bool) = + fun projectee -> + match projectee with | Initialized -> true | uu___ -> false +let (uu___is_Shutdown : lquery -> Prims.bool) = + fun projectee -> match projectee with | Shutdown -> true | uu___ -> false +let (uu___is_Exit : lquery -> Prims.bool) = + fun projectee -> match projectee with | Exit -> true | uu___ -> false +let (uu___is_Cancel : lquery -> Prims.bool) = + fun projectee -> match projectee with | Cancel _0 -> true | uu___ -> false +let (__proj__Cancel__item___0 : lquery -> Prims.int) = + fun projectee -> match projectee with | Cancel _0 -> _0 +let (uu___is_FolderChange : lquery -> Prims.bool) = + fun projectee -> + match projectee with | FolderChange _0 -> true | uu___ -> false +let (__proj__FolderChange__item___0 : lquery -> wsch_event) = + fun projectee -> match projectee with | FolderChange _0 -> _0 +let (uu___is_ChangeConfig : lquery -> Prims.bool) = + fun projectee -> + match projectee with | ChangeConfig -> true | uu___ -> false +let (uu___is_ChangeWatch : lquery -> Prims.bool) = + fun projectee -> + match projectee with | ChangeWatch -> true | uu___ -> false +let (uu___is_Symbol : lquery -> Prims.bool) = + fun projectee -> match projectee with | Symbol _0 -> true | uu___ -> false +let (__proj__Symbol__item___0 : lquery -> Prims.string) = + fun projectee -> match projectee with | Symbol _0 -> _0 +let (uu___is_ExecCommand : lquery -> Prims.bool) = + fun projectee -> + match projectee with | ExecCommand _0 -> true | uu___ -> false +let (__proj__ExecCommand__item___0 : lquery -> Prims.string) = + fun projectee -> match projectee with | ExecCommand _0 -> _0 +let (uu___is_DidOpen : lquery -> Prims.bool) = + fun projectee -> match projectee with | DidOpen _0 -> true | uu___ -> false +let (__proj__DidOpen__item___0 : lquery -> txdoc_item) = + fun projectee -> match projectee with | DidOpen _0 -> _0 +let (uu___is_DidChange : lquery -> Prims.bool) = + fun projectee -> + match projectee with | DidChange _0 -> true | uu___ -> false +let (__proj__DidChange__item___0 : lquery -> (Prims.string * Prims.string)) = + fun projectee -> match projectee with | DidChange _0 -> _0 +let (uu___is_WillSave : lquery -> Prims.bool) = + fun projectee -> + match projectee with | WillSave _0 -> true | uu___ -> false +let (__proj__WillSave__item___0 : lquery -> Prims.string) = + fun projectee -> match projectee with | WillSave _0 -> _0 +let (uu___is_WillSaveWait : lquery -> Prims.bool) = + fun projectee -> + match projectee with | WillSaveWait _0 -> true | uu___ -> false +let (__proj__WillSaveWait__item___0 : lquery -> Prims.string) = + fun projectee -> match projectee with | WillSaveWait _0 -> _0 +let (uu___is_DidSave : lquery -> Prims.bool) = + fun projectee -> match projectee with | DidSave _0 -> true | uu___ -> false +let (__proj__DidSave__item___0 : lquery -> (Prims.string * Prims.string)) = + fun projectee -> match projectee with | DidSave _0 -> _0 +let (uu___is_DidClose : lquery -> Prims.bool) = + fun projectee -> + match projectee with | DidClose _0 -> true | uu___ -> false +let (__proj__DidClose__item___0 : lquery -> Prims.string) = + fun projectee -> match projectee with | DidClose _0 -> _0 +let (uu___is_Completion : lquery -> Prims.bool) = + fun projectee -> + match projectee with | Completion _0 -> true | uu___ -> false +let (__proj__Completion__item___0 : + lquery -> (txdoc_pos * completion_context)) = + fun projectee -> match projectee with | Completion _0 -> _0 +let (uu___is_Resolve : lquery -> Prims.bool) = + fun projectee -> match projectee with | Resolve -> true | uu___ -> false +let (uu___is_Hover : lquery -> Prims.bool) = + fun projectee -> match projectee with | Hover _0 -> true | uu___ -> false +let (__proj__Hover__item___0 : lquery -> txdoc_pos) = + fun projectee -> match projectee with | Hover _0 -> _0 +let (uu___is_SignatureHelp : lquery -> Prims.bool) = + fun projectee -> + match projectee with | SignatureHelp _0 -> true | uu___ -> false +let (__proj__SignatureHelp__item___0 : lquery -> txdoc_pos) = + fun projectee -> match projectee with | SignatureHelp _0 -> _0 +let (uu___is_Declaration : lquery -> Prims.bool) = + fun projectee -> + match projectee with | Declaration _0 -> true | uu___ -> false +let (__proj__Declaration__item___0 : lquery -> txdoc_pos) = + fun projectee -> match projectee with | Declaration _0 -> _0 +let (uu___is_Definition : lquery -> Prims.bool) = + fun projectee -> + match projectee with | Definition _0 -> true | uu___ -> false +let (__proj__Definition__item___0 : lquery -> txdoc_pos) = + fun projectee -> match projectee with | Definition _0 -> _0 +let (uu___is_TypeDefinition : lquery -> Prims.bool) = + fun projectee -> + match projectee with | TypeDefinition _0 -> true | uu___ -> false +let (__proj__TypeDefinition__item___0 : lquery -> txdoc_pos) = + fun projectee -> match projectee with | TypeDefinition _0 -> _0 +let (uu___is_Implementation : lquery -> Prims.bool) = + fun projectee -> + match projectee with | Implementation _0 -> true | uu___ -> false +let (__proj__Implementation__item___0 : lquery -> txdoc_pos) = + fun projectee -> match projectee with | Implementation _0 -> _0 +let (uu___is_References : lquery -> Prims.bool) = + fun projectee -> match projectee with | References -> true | uu___ -> false +let (uu___is_DocumentHighlight : lquery -> Prims.bool) = + fun projectee -> + match projectee with | DocumentHighlight _0 -> true | uu___ -> false +let (__proj__DocumentHighlight__item___0 : lquery -> txdoc_pos) = + fun projectee -> match projectee with | DocumentHighlight _0 -> _0 +let (uu___is_DocumentSymbol : lquery -> Prims.bool) = + fun projectee -> + match projectee with | DocumentSymbol -> true | uu___ -> false +let (uu___is_CodeAction : lquery -> Prims.bool) = + fun projectee -> match projectee with | CodeAction -> true | uu___ -> false +let (uu___is_CodeLens : lquery -> Prims.bool) = + fun projectee -> match projectee with | CodeLens -> true | uu___ -> false +let (uu___is_CodeLensResolve : lquery -> Prims.bool) = + fun projectee -> + match projectee with | CodeLensResolve -> true | uu___ -> false +let (uu___is_DocumentLink : lquery -> Prims.bool) = + fun projectee -> + match projectee with | DocumentLink -> true | uu___ -> false +let (uu___is_DocumentLinkResolve : lquery -> Prims.bool) = + fun projectee -> + match projectee with | DocumentLinkResolve -> true | uu___ -> false +let (uu___is_DocumentColor : lquery -> Prims.bool) = + fun projectee -> + match projectee with | DocumentColor -> true | uu___ -> false +let (uu___is_ColorPresentation : lquery -> Prims.bool) = + fun projectee -> + match projectee with | ColorPresentation -> true | uu___ -> false +let (uu___is_Formatting : lquery -> Prims.bool) = + fun projectee -> match projectee with | Formatting -> true | uu___ -> false +let (uu___is_RangeFormatting : lquery -> Prims.bool) = + fun projectee -> + match projectee with | RangeFormatting -> true | uu___ -> false +let (uu___is_TypeFormatting : lquery -> Prims.bool) = + fun projectee -> + match projectee with | TypeFormatting -> true | uu___ -> false +let (uu___is_Rename : lquery -> Prims.bool) = + fun projectee -> match projectee with | Rename -> true | uu___ -> false +let (uu___is_PrepareRename : lquery -> Prims.bool) = + fun projectee -> + match projectee with | PrepareRename _0 -> true | uu___ -> false +let (__proj__PrepareRename__item___0 : lquery -> txdoc_pos) = + fun projectee -> match projectee with | PrepareRename _0 -> _0 +let (uu___is_FoldingRange : lquery -> Prims.bool) = + fun projectee -> + match projectee with | FoldingRange -> true | uu___ -> false +let (uu___is_BadProtocolMsg : lquery -> Prims.bool) = + fun projectee -> + match projectee with | BadProtocolMsg _0 -> true | uu___ -> false +let (__proj__BadProtocolMsg__item___0 : lquery -> Prims.string) = + fun projectee -> match projectee with | BadProtocolMsg _0 -> _0 +type lsp_query = + { + query_id: Prims.int FStar_Pervasives_Native.option ; + q: lquery } +let (__proj__Mklsp_query__item__query_id : + lsp_query -> Prims.int FStar_Pervasives_Native.option) = + fun projectee -> match projectee with | { query_id; q;_} -> query_id +let (__proj__Mklsp_query__item__q : lsp_query -> lquery) = + fun projectee -> match projectee with | { query_id; q;_} -> q +type error_code = + | ParseError + | InvalidRequest + | MethodNotFound + | InvalidParams + | InternalError + | ServerErrorStart + | ServerErrorEnd + | ServerNotInitialized + | UnknownErrorCode + | RequestCancelled + | ContentModified +let (uu___is_ParseError : error_code -> Prims.bool) = + fun projectee -> match projectee with | ParseError -> true | uu___ -> false +let (uu___is_InvalidRequest : error_code -> Prims.bool) = + fun projectee -> + match projectee with | InvalidRequest -> true | uu___ -> false +let (uu___is_MethodNotFound : error_code -> Prims.bool) = + fun projectee -> + match projectee with | MethodNotFound -> true | uu___ -> false +let (uu___is_InvalidParams : error_code -> Prims.bool) = + fun projectee -> + match projectee with | InvalidParams -> true | uu___ -> false +let (uu___is_InternalError : error_code -> Prims.bool) = + fun projectee -> + match projectee with | InternalError -> true | uu___ -> false +let (uu___is_ServerErrorStart : error_code -> Prims.bool) = + fun projectee -> + match projectee with | ServerErrorStart -> true | uu___ -> false +let (uu___is_ServerErrorEnd : error_code -> Prims.bool) = + fun projectee -> + match projectee with | ServerErrorEnd -> true | uu___ -> false +let (uu___is_ServerNotInitialized : error_code -> Prims.bool) = + fun projectee -> + match projectee with | ServerNotInitialized -> true | uu___ -> false +let (uu___is_UnknownErrorCode : error_code -> Prims.bool) = + fun projectee -> + match projectee with | UnknownErrorCode -> true | uu___ -> false +let (uu___is_RequestCancelled : error_code -> Prims.bool) = + fun projectee -> + match projectee with | RequestCancelled -> true | uu___ -> false +let (uu___is_ContentModified : error_code -> Prims.bool) = + fun projectee -> + match projectee with | ContentModified -> true | uu___ -> false +type rng = + { + rng_start: (Prims.int * Prims.int) ; + rng_end: (Prims.int * Prims.int) } +let (__proj__Mkrng__item__rng_start : rng -> (Prims.int * Prims.int)) = + fun projectee -> + match projectee with | { rng_start; rng_end;_} -> rng_start +let (__proj__Mkrng__item__rng_end : rng -> (Prims.int * Prims.int)) = + fun projectee -> match projectee with | { rng_start; rng_end;_} -> rng_end +let (js_rng : FStarC_Json.json -> rng) = + fun uu___ -> + match uu___ with + | FStarC_Json.JsonAssoc a -> + let st = assoc "start" a in + let fin = assoc "end" a in + let l = assoc "line" in + let c = assoc "character" in + let uu___1 = + let uu___2 = + let uu___3 = let uu___4 = js_assoc st in l uu___4 in + js_int uu___3 in + let uu___3 = + let uu___4 = let uu___5 = js_assoc st in c uu___5 in + js_int uu___4 in + (uu___2, uu___3) in + let uu___2 = + let uu___3 = + let uu___4 = let uu___5 = js_assoc fin in l uu___5 in + js_int uu___4 in + let uu___4 = + let uu___5 = let uu___6 = js_assoc st in c uu___6 in + js_int uu___5 in + (uu___3, uu___4) in + { rng_start = uu___1; rng_end = uu___2 } + | other -> js_fail "dictionary" other +let (errorcode_to_int : error_code -> Prims.int) = + fun uu___ -> + match uu___ with + | ParseError -> (Prims.of_int (-32700)) + | InvalidRequest -> (Prims.of_int (-32600)) + | MethodNotFound -> (Prims.of_int (-32601)) + | InvalidParams -> (Prims.of_int (-32602)) + | InternalError -> (Prims.of_int (-32603)) + | ServerErrorStart -> (Prims.of_int (-32099)) + | ServerErrorEnd -> (Prims.of_int (-32000)) + | ServerNotInitialized -> (Prims.of_int (-32002)) + | UnknownErrorCode -> (Prims.of_int (-32001)) + | RequestCancelled -> (Prims.of_int (-32800)) + | ContentModified -> (Prims.of_int (-32801)) +let (json_debug : FStarC_Json.json -> Prims.string) = + fun uu___ -> + match uu___ with + | FStarC_Json.JsonNull -> "null" + | FStarC_Json.JsonBool b -> + FStarC_Compiler_Util.format1 "bool (%s)" + (if b then "true" else "false") + | FStarC_Json.JsonInt i -> + let uu___1 = FStarC_Compiler_Util.string_of_int i in + FStarC_Compiler_Util.format1 "int (%s)" uu___1 + | FStarC_Json.JsonStr s -> FStarC_Compiler_Util.format1 "string (%s)" s + | FStarC_Json.JsonList uu___1 -> "list (...)" + | FStarC_Json.JsonAssoc uu___1 -> "dictionary (...)" +let (wrap_jsfail : + Prims.int FStar_Pervasives_Native.option -> + Prims.string -> FStarC_Json.json -> lsp_query) + = + fun qid -> + fun expected -> + fun got -> + let uu___ = + let uu___1 = + let uu___2 = json_debug got in + FStarC_Compiler_Util.format2 + "JSON decoding failed: expected %s, got %s" expected uu___2 in + BadProtocolMsg uu___1 in + { query_id = qid; q = uu___ } +let (resultResponse : + FStarC_Json.json -> assoct FStar_Pervasives_Native.option) = + fun r -> FStar_Pervasives_Native.Some [("result", r)] +let (errorResponse : + FStarC_Json.json -> assoct FStar_Pervasives_Native.option) = + fun r -> FStar_Pervasives_Native.Some [("error", r)] +let (nullResponse : assoct FStar_Pervasives_Native.option) = + resultResponse FStarC_Json.JsonNull +let (json_of_response : + Prims.int FStar_Pervasives_Native.option -> assoct -> FStarC_Json.json) = + fun qid -> + fun response -> + match qid with + | FStar_Pervasives_Native.Some i -> + FStarC_Json.JsonAssoc + (FStarC_Compiler_List.op_At + [("jsonrpc", (FStarC_Json.JsonStr "2.0")); + ("id", (FStarC_Json.JsonInt i))] response) + | FStar_Pervasives_Native.None -> + FStarC_Json.JsonAssoc + (FStarC_Compiler_List.op_At + [("jsonrpc", (FStarC_Json.JsonStr "2.0"))] response) +let (js_resperr : error_code -> Prims.string -> FStarC_Json.json) = + fun err -> + fun msg -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = errorcode_to_int err in FStarC_Json.JsonInt uu___3 in + ("code", uu___2) in + [uu___1; ("message", (FStarC_Json.JsonStr msg))] in + FStarC_Json.JsonAssoc uu___ +let (wrap_content_szerr : Prims.string -> lsp_query) = + fun m -> + { query_id = FStar_Pervasives_Native.None; q = (BadProtocolMsg m) } +let (js_servcap : FStarC_Json.json) = + FStarC_Json.JsonAssoc + [("capabilities", + (FStarC_Json.JsonAssoc + [("textDocumentSync", + (FStarC_Json.JsonAssoc + [("openClose", (FStarC_Json.JsonBool true)); + ("change", (FStarC_Json.JsonInt Prims.int_one)); + ("willSave", (FStarC_Json.JsonBool false)); + ("willSaveWaitUntil", (FStarC_Json.JsonBool false)); + ("save", + (FStarC_Json.JsonAssoc + [("includeText", (FStarC_Json.JsonBool true))]))])); + ("hoverProvider", (FStarC_Json.JsonBool true)); + ("completionProvider", (FStarC_Json.JsonAssoc [])); + ("signatureHelpProvider", (FStarC_Json.JsonAssoc [])); + ("definitionProvider", (FStarC_Json.JsonBool true)); + ("typeDefinitionProvider", (FStarC_Json.JsonBool false)); + ("implementationProvider", (FStarC_Json.JsonBool false)); + ("referencesProvider", (FStarC_Json.JsonBool false)); + ("documentSymbolProvider", (FStarC_Json.JsonBool false)); + ("workspaceSymbolProvider", (FStarC_Json.JsonBool false)); + ("codeActionProvider", (FStarC_Json.JsonBool false))]))] +let (js_pos : FStarC_Compiler_Range_Type.pos -> FStarC_Json.json) = + fun p -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Compiler_Range_Ops.line_of_pos p in + uu___4 - Prims.int_one in + FStarC_Json.JsonInt uu___3 in + ("line", uu___2) in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Compiler_Range_Ops.col_of_pos p in + FStarC_Json.JsonInt uu___5 in + ("character", uu___4) in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Json.JsonAssoc uu___ +let (js_range : FStarC_Compiler_Range_Type.range -> FStarC_Json.json) = + fun r -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Compiler_Range_Ops.start_of_range r in + js_pos uu___3 in + ("start", uu___2) in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Compiler_Range_Ops.end_of_range r in + js_pos uu___5 in + ("end", uu___4) in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Json.JsonAssoc uu___ +let (js_dummyrange : FStarC_Json.json) = + FStarC_Json.JsonAssoc + [("start", + (FStarC_Json.JsonAssoc + [("line", (FStarC_Json.JsonInt Prims.int_zero)); + ("character", (FStarC_Json.JsonInt Prims.int_zero)); + ("end", + (FStarC_Json.JsonAssoc + [("line", (FStarC_Json.JsonInt Prims.int_zero)); + ("character", (FStarC_Json.JsonInt Prims.int_zero))]))]))] +let (js_loclink : FStarC_Compiler_Range_Type.range -> FStarC_Json.json) = + fun r -> + let s = js_range r in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Compiler_Range_Ops.file_of_range r in + path_to_uri uu___6 in + FStarC_Json.JsonStr uu___5 in + ("targetUri", uu___4) in + [uu___3; ("targetRange", s); ("targetSelectionRange", s)] in + FStarC_Json.JsonAssoc uu___2 in + [uu___1] in + FStarC_Json.JsonList uu___ +let (pos_munge : txdoc_pos -> (Prims.string * Prims.int * Prims.int)) = + fun pos -> ((pos.path), (pos.line + Prims.int_one), (pos.col)) +let (js_diag : + Prims.string -> + Prims.string -> + FStarC_Compiler_Range_Type.range FStar_Pervasives_Native.option -> + assoct) + = + fun fname -> + fun msg -> + fun r -> + let r' = + match r with + | FStar_Pervasives_Native.Some r1 -> js_range r1 + | FStar_Pervasives_Native.None -> js_dummyrange in + let ds = + ("diagnostics", + (FStarC_Json.JsonList + [FStarC_Json.JsonAssoc + [("range", r'); ("message", (FStarC_Json.JsonStr msg))]])) in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = path_to_uri fname in + FStarC_Json.JsonStr uu___6 in + ("uri", uu___5) in + [uu___4; ds] in + FStarC_Json.JsonAssoc uu___3 in + ("params", uu___2) in + [uu___1] in + ("method", (FStarC_Json.JsonStr "textDocument/publishDiagnostics")) + :: uu___ +let (js_diag_clear : Prims.string -> assoct) = + fun fname -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = path_to_uri fname in FStarC_Json.JsonStr uu___6 in + ("uri", uu___5) in + [uu___4; ("diagnostics", (FStarC_Json.JsonList []))] in + FStarC_Json.JsonAssoc uu___3 in + ("params", uu___2) in + [uu___1] in + ("method", (FStarC_Json.JsonStr "textDocument/publishDiagnostics")) :: + uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Interactive_Legacy.ml b/ocaml/fstar-lib/generated/FStarC_Interactive_Legacy.ml new file mode 100644 index 00000000000..5b41b45f47c --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Interactive_Legacy.ml @@ -0,0 +1,971 @@ +open Prims +let (tc_one_file : + Prims.string Prims.list -> + FStarC_TypeChecker_Env.env -> + ((Prims.string FStar_Pervasives_Native.option * Prims.string) * + FStarC_TypeChecker_Env.env_t * Prims.string Prims.list)) + = + fun remaining -> + fun env -> + let uu___ = + match remaining with + | intf::impl::remaining1 when + FStarC_Universal.needs_interleaving intf impl -> + let uu___1 = + FStarC_Universal.tc_one_file_for_ide env + (FStar_Pervasives_Native.Some intf) impl + FStarC_Parser_Dep.empty_parsing_data in + (match uu___1 with + | (uu___2, env1) -> + (((FStar_Pervasives_Native.Some intf), impl), env1, + remaining1)) + | intf_or_impl::remaining1 -> + let uu___1 = + FStarC_Universal.tc_one_file_for_ide env + FStar_Pervasives_Native.None intf_or_impl + FStarC_Parser_Dep.empty_parsing_data in + (match uu___1 with + | (uu___2, env1) -> + ((FStar_Pervasives_Native.None, intf_or_impl), env1, + remaining1)) + | [] -> failwith "Impossible" in + match uu___ with + | ((intf, impl), env1, remaining1) -> ((intf, impl), env1, remaining1) +type env_t = FStarC_TypeChecker_Env.env +type modul_t = FStarC_Syntax_Syntax.modul FStar_Pervasives_Native.option +type stack_t = (env_t * modul_t) Prims.list +let (pop : FStarC_TypeChecker_Env.env -> Prims.string -> unit) = + fun env -> + fun msg -> + (let uu___1 = FStarC_TypeChecker_Tc.pop_context env msg in ()); + FStarC_Options.pop () +let (push_with_kind : + FStarC_TypeChecker_Env.env -> + Prims.bool -> Prims.bool -> Prims.string -> FStarC_TypeChecker_Env.env) + = + fun env -> + fun lax -> + fun restore_cmd_line_options -> + fun msg -> + let env1 = + { + FStarC_TypeChecker_Env.solver = + (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = lax; + FStarC_TypeChecker_Env.lax_universes = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env.FStarC_TypeChecker_Env.missing_decl) + } in + let res = FStarC_TypeChecker_Tc.push_context env1 msg in + FStarC_Options.push (); + if restore_cmd_line_options + then + (let uu___2 = FStarC_Options.restore_cmd_line_options false in ()) + else (); + res +let (check_frag : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.modul FStar_Pervasives_Native.option -> + (FStarC_Parser_ParseIt.input_frag * FStarC_Universal.lang_decls_t) -> + (FStarC_Syntax_Syntax.modul FStar_Pervasives_Native.option * + FStarC_TypeChecker_Env.env * Prims.int) + FStar_Pervasives_Native.option) + = + fun env -> + fun curmod -> + fun frag -> + try + (fun uu___ -> + match () with + | () -> + let uu___1 = + FStarC_Universal.tc_one_fragment curmod env + (FStar_Pervasives.Inl frag) in + (match uu___1 with + | (m, env1, uu___2) -> + let uu___3 = + let uu___4 = FStarC_Errors.get_err_count () in + (m, env1, uu___4) in + FStar_Pervasives_Native.Some uu___3)) () + with + | FStarC_Errors.Error (e, msg, r, ctx) when + let uu___1 = FStarC_Options.trace_error () in + Prims.op_Negation uu___1 -> + (FStarC_TypeChecker_Err.add_errors env [(e, msg, r, ctx)]; + FStar_Pervasives_Native.None) +let (report_fail : unit -> unit) = + fun uu___ -> + (let uu___2 = FStarC_Errors.report_all () in ()); FStarC_Errors.clear () +type input_chunks = + | Push of (Prims.bool * Prims.int * Prims.int) + | Pop of Prims.string + | Code of (Prims.string * (Prims.string * Prims.string)) + | Info of (Prims.string * Prims.bool * (Prims.string * Prims.int * + Prims.int) FStar_Pervasives_Native.option) + | Completions of Prims.string +let (uu___is_Push : input_chunks -> Prims.bool) = + fun projectee -> match projectee with | Push _0 -> true | uu___ -> false +let (__proj__Push__item___0 : + input_chunks -> (Prims.bool * Prims.int * Prims.int)) = + fun projectee -> match projectee with | Push _0 -> _0 +let (uu___is_Pop : input_chunks -> Prims.bool) = + fun projectee -> match projectee with | Pop _0 -> true | uu___ -> false +let (__proj__Pop__item___0 : input_chunks -> Prims.string) = + fun projectee -> match projectee with | Pop _0 -> _0 +let (uu___is_Code : input_chunks -> Prims.bool) = + fun projectee -> match projectee with | Code _0 -> true | uu___ -> false +let (__proj__Code__item___0 : + input_chunks -> (Prims.string * (Prims.string * Prims.string))) = + fun projectee -> match projectee with | Code _0 -> _0 +let (uu___is_Info : input_chunks -> Prims.bool) = + fun projectee -> match projectee with | Info _0 -> true | uu___ -> false +let (__proj__Info__item___0 : + input_chunks -> + (Prims.string * Prims.bool * (Prims.string * Prims.int * Prims.int) + FStar_Pervasives_Native.option)) + = fun projectee -> match projectee with | Info _0 -> _0 +let (uu___is_Completions : input_chunks -> Prims.bool) = + fun projectee -> + match projectee with | Completions _0 -> true | uu___ -> false +let (__proj__Completions__item___0 : input_chunks -> Prims.string) = + fun projectee -> match projectee with | Completions _0 -> _0 +type interactive_state = + { + chunk: FStarC_Compiler_Util.string_builder ; + stdin: + FStarC_Compiler_Util.stream_reader FStar_Pervasives_Native.option + FStarC_Compiler_Effect.ref + ; + buffer: input_chunks Prims.list FStarC_Compiler_Effect.ref ; + log: + FStarC_Compiler_Util.out_channel FStar_Pervasives_Native.option + FStarC_Compiler_Effect.ref + } +let (__proj__Mkinteractive_state__item__chunk : + interactive_state -> FStarC_Compiler_Util.string_builder) = + fun projectee -> + match projectee with | { chunk; stdin; buffer; log;_} -> chunk +let (__proj__Mkinteractive_state__item__stdin : + interactive_state -> + FStarC_Compiler_Util.stream_reader FStar_Pervasives_Native.option + FStarC_Compiler_Effect.ref) + = + fun projectee -> + match projectee with | { chunk; stdin; buffer; log;_} -> stdin +let (__proj__Mkinteractive_state__item__buffer : + interactive_state -> input_chunks Prims.list FStarC_Compiler_Effect.ref) = + fun projectee -> + match projectee with | { chunk; stdin; buffer; log;_} -> buffer +let (__proj__Mkinteractive_state__item__log : + interactive_state -> + FStarC_Compiler_Util.out_channel FStar_Pervasives_Native.option + FStarC_Compiler_Effect.ref) + = + fun projectee -> + match projectee with | { chunk; stdin; buffer; log;_} -> log +let (the_interactive_state : interactive_state) = + let uu___ = FStarC_Compiler_Util.new_string_builder () in + let uu___1 = FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None in + let uu___2 = FStarC_Compiler_Util.mk_ref [] in + let uu___3 = FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None in + { chunk = uu___; stdin = uu___1; buffer = uu___2; log = uu___3 } +let rec (read_chunk : unit -> input_chunks) = + fun uu___ -> + let s = the_interactive_state in + let log = + let uu___1 = FStarC_Compiler_Debug.any () in + if uu___1 + then + let transcript = + let uu___2 = FStarC_Compiler_Effect.op_Bang s.log in + match uu___2 with + | FStar_Pervasives_Native.Some transcript1 -> transcript1 + | FStar_Pervasives_Native.None -> + let transcript1 = + FStarC_Compiler_Util.open_file_for_writing "transcript" in + (FStarC_Compiler_Effect.op_Colon_Equals s.log + (FStar_Pervasives_Native.Some transcript1); + transcript1) in + fun line -> + (FStarC_Compiler_Util.append_to_file transcript line; + FStarC_Compiler_Util.flush transcript) + else (fun uu___3 -> ()) in + let stdin = + let uu___1 = FStarC_Compiler_Effect.op_Bang s.stdin in + match uu___1 with + | FStar_Pervasives_Native.Some i -> i + | FStar_Pervasives_Native.None -> + let i = FStarC_Compiler_Util.open_stdin () in + (FStarC_Compiler_Effect.op_Colon_Equals s.stdin + (FStar_Pervasives_Native.Some i); + i) in + let line = + let uu___1 = FStarC_Compiler_Util.read_line stdin in + match uu___1 with + | FStar_Pervasives_Native.None -> + FStarC_Compiler_Effect.exit Prims.int_zero + | FStar_Pervasives_Native.Some l -> l in + log line; + (let l = FStarC_Compiler_Util.trim_string line in + if FStarC_Compiler_Util.starts_with l "#end" + then + let responses = + match FStarC_Compiler_Util.split l " " with + | uu___2::ok::fail::[] -> (ok, fail) + | uu___2 -> ("ok", "fail") in + let str = FStarC_Compiler_Util.string_of_string_builder s.chunk in + (FStarC_Compiler_Util.clear_string_builder s.chunk; + Code (str, responses)) + else + if FStarC_Compiler_Util.starts_with l "#pop" + then (FStarC_Compiler_Util.clear_string_builder s.chunk; Pop l) + else + if FStarC_Compiler_Util.starts_with l "#push" + then + (FStarC_Compiler_Util.clear_string_builder s.chunk; + (let lc_lax = + let uu___5 = + FStarC_Compiler_Util.substring_from l + (FStarC_Compiler_String.length "#push") in + FStarC_Compiler_Util.trim_string uu___5 in + let lc = + match FStarC_Compiler_Util.split lc_lax " " with + | l1::c::"#lax"::[] -> + let uu___5 = FStarC_Compiler_Util.int_of_string l1 in + let uu___6 = FStarC_Compiler_Util.int_of_string c in + (true, uu___5, uu___6) + | l1::c::[] -> + let uu___5 = FStarC_Compiler_Util.int_of_string l1 in + let uu___6 = FStarC_Compiler_Util.int_of_string c in + (false, uu___5, uu___6) + | uu___5 -> + (FStarC_Errors.log_issue0 + FStarC_Errors_Codes.Warning_WrongErrorLocation () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + (Prims.strcat + "Error locations may be wrong, unrecognized string after #push: " + lc_lax)); + (false, Prims.int_one, Prims.int_zero)) in + Push lc)) + else + if FStarC_Compiler_Util.starts_with l "#info " + then + (match FStarC_Compiler_Util.split l " " with + | uu___5::symbol::[] -> + (FStarC_Compiler_Util.clear_string_builder s.chunk; + Info (symbol, true, FStar_Pervasives_Native.None)) + | uu___5::symbol::file::row::col::[] -> + (FStarC_Compiler_Util.clear_string_builder s.chunk; + (let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Compiler_Util.int_of_string row in + let uu___11 = + FStarC_Compiler_Util.int_of_string col in + (file, uu___10, uu___11) in + FStar_Pervasives_Native.Some uu___9 in + (symbol, false, uu___8) in + Info uu___7)) + | uu___5 -> + (FStarC_Errors.log_issue0 + FStarC_Errors_Codes.Error_IDEUnrecognized () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + (Prims.strcat "Unrecognized \"#info\" request: " l)); + FStarC_Compiler_Effect.exit Prims.int_one)) + else + if FStarC_Compiler_Util.starts_with l "#completions " + then + (match FStarC_Compiler_Util.split l " " with + | uu___6::prefix::"#"::[] -> + (FStarC_Compiler_Util.clear_string_builder s.chunk; + Completions prefix) + | uu___6 -> + (FStarC_Errors.log_issue0 + FStarC_Errors_Codes.Error_IDEUnrecognized () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + (Prims.strcat + "Unrecognized \"#completions\" request: " l)); + FStarC_Compiler_Effect.exit Prims.int_one)) + else + if l = "#finish" + then FStarC_Compiler_Effect.exit Prims.int_zero + else + (FStarC_Compiler_Util.string_builder_append s.chunk line; + FStarC_Compiler_Util.string_builder_append s.chunk "\n"; + read_chunk ())) +let (shift_chunk : unit -> input_chunks) = + fun uu___ -> + let s = the_interactive_state in + let uu___1 = FStarC_Compiler_Effect.op_Bang s.buffer in + match uu___1 with + | [] -> read_chunk () + | chunk::chunks -> + (FStarC_Compiler_Effect.op_Colon_Equals s.buffer chunks; chunk) +let (fill_buffer : unit -> unit) = + fun uu___ -> + let s = the_interactive_state in + let uu___1 = + let uu___2 = FStarC_Compiler_Effect.op_Bang s.buffer in + let uu___3 = let uu___4 = read_chunk () in [uu___4] in + FStarC_Compiler_List.op_At uu___2 uu___3 in + FStarC_Compiler_Effect.op_Colon_Equals s.buffer uu___1 +let (deps_of_our_file : + Prims.string -> + (Prims.string Prims.list * Prims.string FStar_Pervasives_Native.option * + FStarC_Parser_Dep.deps)) + = + fun filename -> + let uu___ = + FStarC_Dependencies.find_deps_if_needed [filename] + FStarC_CheckedFiles.load_parsing_data_from_cache in + match uu___ with + | (deps, dep_graph) -> + let uu___1 = + FStarC_Compiler_List.partition + (fun x -> + let uu___2 = FStarC_Parser_Dep.lowercase_module_name x in + let uu___3 = FStarC_Parser_Dep.lowercase_module_name filename in + uu___2 <> uu___3) deps in + (match uu___1 with + | (deps1, same_name) -> + let maybe_intf = + match same_name with + | intf::impl::[] -> + ((let uu___3 = + (let uu___4 = FStarC_Parser_Dep.is_interface intf in + Prims.op_Negation uu___4) || + (let uu___4 = + FStarC_Parser_Dep.is_implementation impl in + Prims.op_Negation uu___4) in + if uu___3 + then + let uu___4 = + FStarC_Compiler_Util.format2 + "Found %s and %s but not an interface + implementation" + intf impl in + FStarC_Errors.log_issue0 + FStarC_Errors_Codes.Warning_MissingInterfaceOrImplementation + () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4) + else ()); + FStar_Pervasives_Native.Some intf) + | impl::[] -> FStar_Pervasives_Native.None + | uu___2 -> + ((let uu___4 = + FStarC_Compiler_Util.format1 + "Unexpected: ended up with %s" + (FStarC_Compiler_String.concat " " same_name) in + FStarC_Errors.log_issue0 + FStarC_Errors_Codes.Warning_UnexpectedFile () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4)); + FStar_Pervasives_Native.None) in + (deps1, maybe_intf, dep_graph)) +type m_timestamps = + (Prims.string FStar_Pervasives_Native.option * Prims.string * + FStarC_Compiler_Util.time FStar_Pervasives_Native.option * + FStarC_Compiler_Util.time) Prims.list +let rec (tc_deps : + modul_t -> + stack_t -> + FStarC_TypeChecker_Env.env -> + Prims.string Prims.list -> + m_timestamps -> + (stack_t * FStarC_TypeChecker_Env.env * m_timestamps)) + = + fun m -> + fun stack -> + fun env -> + fun remaining -> + fun ts -> + match remaining with + | [] -> (stack, env, ts) + | uu___ -> + let stack1 = (env, m) :: stack in + let env1 = + let uu___1 = FStarC_Options.lax () in + push_with_kind env uu___1 true "typecheck_modul" in + let uu___1 = tc_one_file remaining env1 in + (match uu___1 with + | ((intf, impl), env2, remaining1) -> + let uu___2 = + let intf_t = + match intf with + | FStar_Pervasives_Native.Some intf1 -> + let uu___3 = + FStarC_Parser_ParseIt.get_file_last_modification_time + intf1 in + FStar_Pervasives_Native.Some uu___3 + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None in + let impl_t = + FStarC_Parser_ParseIt.get_file_last_modification_time + impl in + (intf_t, impl_t) in + (match uu___2 with + | (intf_t, impl_t) -> + tc_deps m stack1 env2 remaining1 + ((intf, impl, intf_t, impl_t) :: ts))) +let (update_deps : + Prims.string -> + modul_t -> + stack_t -> env_t -> m_timestamps -> (stack_t * env_t * m_timestamps)) + = + fun filename -> + fun m -> + fun stk -> + fun env -> + fun ts -> + let is_stale intf impl intf_t impl_t = + let impl_mt = + FStarC_Parser_ParseIt.get_file_last_modification_time impl in + (FStarC_Compiler_Util.is_before impl_t impl_mt) || + (match (intf, intf_t) with + | (FStar_Pervasives_Native.Some intf1, + FStar_Pervasives_Native.Some intf_t1) -> + let intf_mt = + FStarC_Parser_ParseIt.get_file_last_modification_time + intf1 in + FStarC_Compiler_Util.is_before intf_t1 intf_mt + | (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None) -> false + | (uu___, uu___1) -> + failwith + "Impossible, if the interface is None, the timestamp entry should also be None") in + let rec iterate depnames st env' ts1 good_stack good_ts = + let match_dep depnames1 intf impl = + match intf with + | FStar_Pervasives_Native.None -> + (match depnames1 with + | dep::depnames' -> + if dep = impl + then (true, depnames') + else (false, depnames1) + | uu___ -> (false, depnames1)) + | FStar_Pervasives_Native.Some intf1 -> + (match depnames1 with + | depintf::dep::depnames' -> + if (depintf = intf1) && (dep = impl) + then (true, depnames') + else (false, depnames1) + | uu___ -> (false, depnames1)) in + let rec pop_tc_and_stack env1 stack ts2 = + match ts2 with + | [] -> env1 + | uu___::ts3 -> + (pop env1 ""; + (let uu___2 = + let uu___3 = FStarC_Compiler_List.hd stack in + let uu___4 = FStarC_Compiler_List.tl stack in + (uu___3, uu___4) in + match uu___2 with + | ((env2, uu___3), stack1) -> + pop_tc_and_stack env2 stack1 ts3)) in + match ts1 with + | ts_elt::ts' -> + let uu___ = ts_elt in + (match uu___ with + | (intf, impl, intf_t, impl_t) -> + let uu___1 = match_dep depnames intf impl in + (match uu___1 with + | (b, depnames') -> + let uu___2 = + (Prims.op_Negation b) || + (is_stale intf impl intf_t impl_t) in + if uu___2 + then + let env1 = + pop_tc_and_stack env' + (FStarC_Compiler_List.rev_append st []) ts1 in + tc_deps m good_stack env1 depnames good_ts + else + (let uu___4 = + let uu___5 = FStarC_Compiler_List.hd st in + let uu___6 = FStarC_Compiler_List.tl st in + (uu___5, uu___6) in + match uu___4 with + | (stack_elt, st') -> + iterate depnames' st' env' ts' (stack_elt + :: good_stack) (ts_elt :: good_ts)))) + | [] -> tc_deps m good_stack env' depnames good_ts in + let uu___ = deps_of_our_file filename in + match uu___ with + | (filenames, uu___1, dep_graph) -> + iterate filenames (FStarC_Compiler_List.rev_append stk []) + env (FStarC_Compiler_List.rev_append ts []) [] [] +let (format_info : + FStarC_TypeChecker_Env.env -> + Prims.string -> + FStarC_Syntax_Syntax.term -> + FStarC_Compiler_Range_Type.range -> + Prims.string FStar_Pervasives_Native.option -> Prims.string) + = + fun env -> + fun name -> + fun typ -> + fun range -> + fun doc -> + let uu___ = FStarC_Compiler_Range_Ops.string_of_range range in + let uu___1 = FStarC_TypeChecker_Normalize.term_to_string env typ in + let uu___2 = + match doc with + | FStar_Pervasives_Native.Some docstring -> + FStarC_Compiler_Util.format1 "#doc %s" docstring + | FStar_Pervasives_Native.None -> "" in + FStarC_Compiler_Util.format4 "(defined at %s) %s: %s%s" uu___ + name uu___1 uu___2 +let rec (go : + (Prims.int * Prims.int) -> + Prims.string -> stack_t -> modul_t -> env_t -> m_timestamps -> unit) + = + fun line_col -> + fun filename -> + fun stack -> + fun curmod -> + fun env -> + fun ts -> + let uu___ = shift_chunk () in + match uu___ with + | Info (symbol, fqn_only, pos_opt) -> + let info_at_pos_opt = + match pos_opt with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (file, row, col) -> + FStarC_TypeChecker_Err.info_at_pos env file row col in + let info_opt = + match info_at_pos_opt with + | FStar_Pervasives_Native.Some uu___1 -> info_at_pos_opt + | FStar_Pervasives_Native.None -> + if symbol = "" + then FStar_Pervasives_Native.None + else + (let lid = + let uu___2 = + FStarC_Compiler_List.map + FStarC_Ident.id_of_text + (FStarC_Compiler_Util.split symbol ".") in + FStarC_Ident.lid_of_ids uu___2 in + let lid1 = + if fqn_only + then lid + else + (let uu___3 = + FStarC_Syntax_DsEnv.resolve_to_fully_qualified_name + env.FStarC_TypeChecker_Env.dsenv lid in + match uu___3 with + | FStar_Pervasives_Native.None -> lid + | FStar_Pervasives_Native.Some lid2 -> lid2) in + let uu___2 = + FStarC_TypeChecker_Env.try_lookup_lid env lid1 in + FStarC_Compiler_Util.map_option + (fun uu___3 -> + match uu___3 with + | ((uu___4, typ), r) -> + ((FStar_Pervasives.Inr lid1), typ, r)) + uu___2) in + ((match info_opt with + | FStar_Pervasives_Native.None -> + FStarC_Compiler_Util.print_string "\n#done-nok\n" + | FStar_Pervasives_Native.Some (name_or_lid, typ, rng) -> + let uu___2 = + match name_or_lid with + | FStar_Pervasives.Inl name -> + (name, FStar_Pervasives_Native.None) + | FStar_Pervasives.Inr lid -> + let uu___3 = FStarC_Ident.string_of_lid lid in + (uu___3, FStar_Pervasives_Native.None) in + (match uu___2 with + | (name, doc) -> + let uu___3 = format_info env name typ rng doc in + FStarC_Compiler_Util.print1 "%s\n#done-ok\n" + uu___3)); + go line_col filename stack curmod env ts) + | Completions search_term -> + let rec measure_anchored_match search_term1 candidate = + match (search_term1, candidate) with + | ([], uu___1) -> + FStar_Pervasives_Native.Some ([], Prims.int_zero) + | (uu___1, []) -> FStar_Pervasives_Native.None + | (hs::ts1, hc::tc) -> + let hc_text = FStarC_Ident.string_of_id hc in + if FStarC_Compiler_Util.starts_with hc_text hs + then + (match ts1 with + | [] -> + FStar_Pervasives_Native.Some + (candidate, + (FStarC_Compiler_String.length hs)) + | uu___1 -> + let uu___2 = measure_anchored_match ts1 tc in + FStarC_Compiler_Util.map_option + (fun uu___3 -> + match uu___3 with + | (matched, len) -> + ((hc :: matched), + (((FStarC_Compiler_String.length + hc_text) + + Prims.int_one) + + len))) uu___2) + else FStar_Pervasives_Native.None in + let rec locate_match needle candidate = + let uu___1 = measure_anchored_match needle candidate in + match uu___1 with + | FStar_Pervasives_Native.Some (matched, n) -> + FStar_Pervasives_Native.Some ([], matched, n) + | FStar_Pervasives_Native.None -> + (match candidate with + | [] -> FStar_Pervasives_Native.None + | hc::tc -> + let uu___2 = locate_match needle tc in + FStarC_Compiler_Util.map_option + (fun uu___3 -> + match uu___3 with + | (prefix, matched, len) -> + ((hc :: prefix), matched, len)) uu___2) in + let str_of_ids ids = + let uu___1 = + FStarC_Compiler_List.map FStarC_Ident.string_of_id ids in + FStarC_Compiler_Util.concat_l "." uu___1 in + let match_lident_against needle lident = + let uu___1 = + let uu___2 = FStarC_Ident.ns_of_lid lident in + let uu___3 = + let uu___4 = FStarC_Ident.ident_of_lid lident in + [uu___4] in + FStarC_Compiler_List.op_At uu___2 uu___3 in + locate_match needle uu___1 in + let shorten_namespace uu___1 = + match uu___1 with + | (prefix, matched, match_len) -> + let naked_match = + match matched with + | uu___2::[] -> true + | uu___2 -> false in + let uu___2 = + FStarC_Syntax_DsEnv.shorten_module_path + env.FStarC_TypeChecker_Env.dsenv prefix + naked_match in + (match uu___2 with + | (stripped_ns, shortened) -> + let uu___3 = str_of_ids shortened in + let uu___4 = str_of_ids matched in + let uu___5 = str_of_ids stripped_ns in + (uu___3, uu___4, uu___5, match_len)) in + let prepare_candidate uu___1 = + match uu___1 with + | (prefix, matched, stripped_ns, match_len) -> + if prefix = "" + then (matched, stripped_ns, match_len) + else + ((Prims.strcat prefix (Prims.strcat "." matched)), + stripped_ns, + (((FStarC_Compiler_String.length prefix) + + match_len) + + Prims.int_one)) in + let needle = FStarC_Compiler_Util.split search_term "." in + let all_lidents_in_env = FStarC_TypeChecker_Env.lidents env in + let matches = + let case_a_find_transitive_includes orig_ns m id = + let exported_names = + FStarC_Syntax_DsEnv.transitive_exported_ids + env.FStarC_TypeChecker_Env.dsenv m in + let matched_length = + FStarC_Compiler_List.fold_left + (fun out -> + fun s -> + ((FStarC_Compiler_String.length s) + out) + + Prims.int_one) + (FStarC_Compiler_String.length id) orig_ns in + FStarC_Compiler_List.filter_map + (fun n -> + if FStarC_Compiler_Util.starts_with n id + then + let lid = + let uu___1 = FStarC_Ident.ids_of_lid m in + let uu___2 = FStarC_Ident.id_of_text n in + FStarC_Ident.lid_of_ns_and_id uu___1 uu___2 in + let uu___1 = + FStarC_Syntax_DsEnv.resolve_to_fully_qualified_name + env.FStarC_TypeChecker_Env.dsenv lid in + FStarC_Compiler_Option.map + (fun fqn -> + let uu___2 = + let uu___3 = + FStarC_Compiler_List.map + FStarC_Ident.id_of_text orig_ns in + let uu___4 = + let uu___5 = + FStarC_Ident.ident_of_lid fqn in + [uu___5] in + FStarC_Compiler_List.op_At uu___3 uu___4 in + ([], uu___2, matched_length)) uu___1 + else FStar_Pervasives_Native.None) exported_names in + let case_b_find_matches_in_env uu___1 = + let matches1 = + FStarC_Compiler_List.filter_map + (match_lident_against needle) all_lidents_in_env in + FStarC_Compiler_List.filter + (fun uu___2 -> + match uu___2 with + | (ns, id, uu___3) -> + let uu___4 = + let uu___5 = FStarC_Ident.lid_of_ids id in + FStarC_Syntax_DsEnv.resolve_to_fully_qualified_name + env.FStarC_TypeChecker_Env.dsenv uu___5 in + (match uu___4 with + | FStar_Pervasives_Native.None -> false + | FStar_Pervasives_Native.Some l -> + let uu___5 = + FStarC_Ident.lid_of_ids + (FStarC_Compiler_List.op_At ns id) in + FStarC_Ident.lid_equals l uu___5)) + matches1 in + let uu___1 = FStarC_Compiler_Util.prefix needle in + match uu___1 with + | (ns, id) -> + let matched_ids = + match ns with + | [] -> case_b_find_matches_in_env () + | uu___2 -> + let l = + FStarC_Ident.lid_of_path ns + FStarC_Compiler_Range_Type.dummyRange in + let uu___3 = + FStarC_Syntax_DsEnv.resolve_module_name + env.FStarC_TypeChecker_Env.dsenv l true in + (match uu___3 with + | FStar_Pervasives_Native.None -> + case_b_find_matches_in_env () + | FStar_Pervasives_Native.Some m -> + case_a_find_transitive_includes ns m id) in + FStarC_Compiler_List.map + (fun x -> + let uu___2 = shorten_namespace x in + prepare_candidate uu___2) matched_ids in + ((let uu___2 = + FStarC_Compiler_Util.sort_with + (fun uu___3 -> + fun uu___4 -> + match (uu___3, uu___4) with + | ((cd1, ns1, uu___5), (cd2, ns2, uu___6)) -> + (match FStarC_Compiler_String.compare cd1 + cd2 + with + | uu___7 when uu___7 = Prims.int_zero -> + FStarC_Compiler_String.compare ns1 ns2 + | n -> n)) matches in + FStarC_Compiler_List.iter + (fun uu___3 -> + match uu___3 with + | (candidate, ns, match_len) -> + let uu___4 = + FStarC_Compiler_Util.string_of_int match_len in + FStarC_Compiler_Util.print3 "%s %s %s \n" uu___4 + ns candidate) uu___2); + FStarC_Compiler_Util.print_string "#done-ok\n"; + go line_col filename stack curmod env ts) + | Pop msg -> + (pop env msg; + (let uu___2 = + match stack with + | [] -> + (FStarC_Errors.log_issue0 + FStarC_Errors_Codes.Error_IDETooManyPops () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "Too many pops"); + FStarC_Compiler_Effect.exit Prims.int_one) + | hd::tl -> (hd, tl) in + match uu___2 with + | ((env1, curmod1), stack1) -> + go line_col filename stack1 curmod1 env1 ts)) + | Push (lax, l, c) -> + let uu___1 = + if + (FStarC_Compiler_List.length stack) = + (FStarC_Compiler_List.length ts) + then + let uu___2 = update_deps filename curmod stack env ts in + (true, uu___2) + else (false, (stack, env, ts)) in + (match uu___1 with + | (restore_cmd_line_options, (stack1, env1, ts1)) -> + let stack2 = (env1, curmod) :: stack1 in + let env2 = + push_with_kind env1 lax restore_cmd_line_options + "#push" in + go (l, c) filename stack2 curmod env2 ts1) + | Code (text, (ok, fail)) -> + let fail1 curmod1 tcenv = + report_fail (); + FStarC_Compiler_Util.print1 "%s\n" fail; + go line_col filename stack curmod1 tcenv ts in + let frag = + { + FStarC_Parser_ParseIt.frag_fname = " input"; + FStarC_Parser_ParseIt.frag_text = text; + FStarC_Parser_ParseIt.frag_line = + (FStar_Pervasives_Native.fst line_col); + FStarC_Parser_ParseIt.frag_col = + (FStar_Pervasives_Native.snd line_col) + } in + let res = check_frag env curmod (frag, []) in + (match res with + | FStar_Pervasives_Native.Some (curmod1, env1, n_errs) -> + if n_errs = Prims.int_zero + then + (FStarC_Compiler_Util.print1 "\n%s\n" ok; + go line_col filename stack curmod1 env1 ts) + else fail1 curmod1 env1 + | uu___1 -> fail1 curmod env) +let (interactive_mode : Prims.string -> unit) = + fun filename -> + (let uu___1 = + let uu___2 = FStarC_Options.codegen () in + FStarC_Compiler_Option.isSome uu___2 in + if uu___1 + then + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_IDEIgnoreCodeGen + () (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Code-generation is not supported in interactive mode, ignoring the codegen flag") + else ()); + (let uu___1 = deps_of_our_file filename in + match uu___1 with + | (filenames, maybe_intf, dep_graph) -> + let env = FStarC_Universal.init_env dep_graph in + let uu___2 = + tc_deps FStar_Pervasives_Native.None [] env filenames [] in + (match uu___2 with + | (stack, env1, ts) -> + let initial_range = + let uu___3 = + FStarC_Compiler_Range_Type.mk_pos Prims.int_one + Prims.int_zero in + let uu___4 = + FStarC_Compiler_Range_Type.mk_pos Prims.int_one + Prims.int_zero in + FStarC_Compiler_Range_Type.mk_range filename uu___3 uu___4 in + let env2 = FStarC_TypeChecker_Env.set_range env1 initial_range in + let env3 = + match maybe_intf with + | FStar_Pervasives_Native.Some intf -> + FStarC_Universal.load_interface_decls env2 intf + | FStar_Pervasives_Native.None -> env2 in + let uu___3 = + (FStarC_Options.record_hints ()) || + (FStarC_Options.use_hints ()) in + if uu___3 + then + let uu___4 = + let uu___5 = FStarC_Options.file_list () in + FStarC_Compiler_List.hd uu___5 in + FStarC_SMTEncoding_Solver.with_hints_db uu___4 + (fun uu___5 -> + go (Prims.int_one, Prims.int_zero) filename stack + FStar_Pervasives_Native.None env3 ts) + else + go (Prims.int_one, Prims.int_zero) filename stack + FStar_Pervasives_Native.None env3 ts)) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Interactive_Lsp.ml b/ocaml/fstar-lib/generated/FStarC_Interactive_Lsp.ml new file mode 100644 index 00000000000..47e631734d8 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Interactive_Lsp.ml @@ -0,0 +1,521 @@ +open Prims +let (unpack_lsp_query : + (Prims.string * FStarC_Json.json) Prims.list -> + FStarC_Interactive_JsonHelper.lsp_query) + = + fun r -> + let qid = + let uu___ = FStarC_Interactive_JsonHelper.try_assoc "id" r in + FStarC_Compiler_Util.map_option + FStarC_Interactive_JsonHelper.js_str_int uu___ in + try + (fun uu___ -> + match () with + | () -> + let method1 = + let uu___1 = FStarC_Interactive_JsonHelper.assoc "method" r in + FStarC_Interactive_JsonHelper.js_str uu___1 in + let uu___1 = + match method1 with + | "initialize" -> + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Interactive_JsonHelper.arg "processId" r in + FStarC_Interactive_JsonHelper.js_int uu___4 in + let uu___4 = + let uu___5 = + FStarC_Interactive_JsonHelper.arg "rootUri" r in + FStarC_Interactive_JsonHelper.js_str uu___5 in + (uu___3, uu___4) in + FStarC_Interactive_JsonHelper.Initialize uu___2 + | "initialized" -> FStarC_Interactive_JsonHelper.Initialized + | "shutdown" -> FStarC_Interactive_JsonHelper.Shutdown + | "exit" -> FStarC_Interactive_JsonHelper.Exit + | "$/cancelRequest" -> + let uu___2 = + let uu___3 = FStarC_Interactive_JsonHelper.arg "id" r in + FStarC_Interactive_JsonHelper.js_str_int uu___3 in + FStarC_Interactive_JsonHelper.Cancel uu___2 + | "workspace/didChangeWorkspaceFolders" -> + let uu___2 = + let uu___3 = FStarC_Interactive_JsonHelper.arg "event" r in + FStarC_Interactive_JsonHelper.js_wsch_event uu___3 in + FStarC_Interactive_JsonHelper.FolderChange uu___2 + | "workspace/didChangeConfiguration" -> + FStarC_Interactive_JsonHelper.ChangeConfig + | "workspace/didChangeWatchedFiles" -> + FStarC_Interactive_JsonHelper.ChangeWatch + | "workspace/symbol" -> + let uu___2 = + let uu___3 = FStarC_Interactive_JsonHelper.arg "query" r in + FStarC_Interactive_JsonHelper.js_str uu___3 in + FStarC_Interactive_JsonHelper.Symbol uu___2 + | "workspace/executeCommand" -> + let uu___2 = + let uu___3 = + FStarC_Interactive_JsonHelper.arg "command" r in + FStarC_Interactive_JsonHelper.js_str uu___3 in + FStarC_Interactive_JsonHelper.ExecCommand uu___2 + | "textDocument/didOpen" -> + let uu___2 = + let uu___3 = + FStarC_Interactive_JsonHelper.arg "textDocument" r in + FStarC_Interactive_JsonHelper.js_txdoc_item uu___3 in + FStarC_Interactive_JsonHelper.DidOpen uu___2 + | "textDocument/didChange" -> + let uu___2 = + let uu___3 = FStarC_Interactive_JsonHelper.js_txdoc_id r in + let uu___4 = + let uu___5 = + FStarC_Interactive_JsonHelper.arg "contentChanges" r in + FStarC_Interactive_JsonHelper.js_contentch uu___5 in + (uu___3, uu___4) in + FStarC_Interactive_JsonHelper.DidChange uu___2 + | "textDocument/willSave" -> + let uu___2 = FStarC_Interactive_JsonHelper.js_txdoc_id r in + FStarC_Interactive_JsonHelper.WillSave uu___2 + | "textDocument/willSaveWaitUntil" -> + let uu___2 = FStarC_Interactive_JsonHelper.js_txdoc_id r in + FStarC_Interactive_JsonHelper.WillSaveWait uu___2 + | "textDocument/didSave" -> + let uu___2 = + let uu___3 = FStarC_Interactive_JsonHelper.js_txdoc_id r in + let uu___4 = + let uu___5 = + FStarC_Interactive_JsonHelper.arg "text" r in + FStarC_Interactive_JsonHelper.js_str uu___5 in + (uu___3, uu___4) in + FStarC_Interactive_JsonHelper.DidSave uu___2 + | "textDocument/didClose" -> + let uu___2 = FStarC_Interactive_JsonHelper.js_txdoc_id r in + FStarC_Interactive_JsonHelper.DidClose uu___2 + | "textDocument/completion" -> + let uu___2 = + let uu___3 = + FStarC_Interactive_JsonHelper.js_txdoc_pos r in + let uu___4 = + let uu___5 = + FStarC_Interactive_JsonHelper.arg "context" r in + FStarC_Interactive_JsonHelper.js_compl_context uu___5 in + (uu___3, uu___4) in + FStarC_Interactive_JsonHelper.Completion uu___2 + | "completionItem/resolve" -> + FStarC_Interactive_JsonHelper.Resolve + | "textDocument/hover" -> + let uu___2 = FStarC_Interactive_JsonHelper.js_txdoc_pos r in + FStarC_Interactive_JsonHelper.Hover uu___2 + | "textDocument/signatureHelp" -> + let uu___2 = FStarC_Interactive_JsonHelper.js_txdoc_pos r in + FStarC_Interactive_JsonHelper.SignatureHelp uu___2 + | "textDocument/declaration" -> + let uu___2 = FStarC_Interactive_JsonHelper.js_txdoc_pos r in + FStarC_Interactive_JsonHelper.Declaration uu___2 + | "textDocument/definition" -> + let uu___2 = FStarC_Interactive_JsonHelper.js_txdoc_pos r in + FStarC_Interactive_JsonHelper.Definition uu___2 + | "textDocument/typeDefinition" -> + let uu___2 = FStarC_Interactive_JsonHelper.js_txdoc_pos r in + FStarC_Interactive_JsonHelper.TypeDefinition uu___2 + | "textDocument/implementation" -> + let uu___2 = FStarC_Interactive_JsonHelper.js_txdoc_pos r in + FStarC_Interactive_JsonHelper.Implementation uu___2 + | "textDocument/references" -> + FStarC_Interactive_JsonHelper.References + | "textDocument/documentHighlight" -> + let uu___2 = FStarC_Interactive_JsonHelper.js_txdoc_pos r in + FStarC_Interactive_JsonHelper.DocumentHighlight uu___2 + | "textDocument/documentSymbol" -> + FStarC_Interactive_JsonHelper.DocumentSymbol + | "textDocument/codeAction" -> + FStarC_Interactive_JsonHelper.CodeAction + | "textDocument/codeLens" -> + FStarC_Interactive_JsonHelper.CodeLens + | "codeLens/resolve" -> + FStarC_Interactive_JsonHelper.CodeLensResolve + | "textDocument/documentLink" -> + FStarC_Interactive_JsonHelper.DocumentLink + | "documentLink/resolve" -> + FStarC_Interactive_JsonHelper.DocumentLinkResolve + | "textDocument/documentColor" -> + FStarC_Interactive_JsonHelper.DocumentColor + | "textDocument/colorPresentation" -> + FStarC_Interactive_JsonHelper.ColorPresentation + | "textDocument/formatting" -> + FStarC_Interactive_JsonHelper.Formatting + | "textDocument/rangeFormatting" -> + FStarC_Interactive_JsonHelper.RangeFormatting + | "textDocument/onTypeFormatting" -> + FStarC_Interactive_JsonHelper.TypeFormatting + | "textDocument/rename" -> + FStarC_Interactive_JsonHelper.Rename + | "textDocument/prepareRename" -> + let uu___2 = FStarC_Interactive_JsonHelper.js_txdoc_pos r in + FStarC_Interactive_JsonHelper.PrepareRename uu___2 + | "textDocument/foldingRange" -> + FStarC_Interactive_JsonHelper.FoldingRange + | m -> + let uu___2 = + FStarC_Compiler_Util.format1 "Unknown method '%s'" m in + FStarC_Interactive_JsonHelper.BadProtocolMsg uu___2 in + { + FStarC_Interactive_JsonHelper.query_id = qid; + FStarC_Interactive_JsonHelper.q = uu___1 + }) () + with + | FStarC_Interactive_JsonHelper.MissingKey msg -> + { + FStarC_Interactive_JsonHelper.query_id = qid; + FStarC_Interactive_JsonHelper.q = + (FStarC_Interactive_JsonHelper.BadProtocolMsg msg) + } + | FStarC_Interactive_JsonHelper.UnexpectedJsonType (expected, got) -> + FStarC_Interactive_JsonHelper.wrap_jsfail qid expected got +let (deserialize_lsp_query : + FStarC_Json.json -> FStarC_Interactive_JsonHelper.lsp_query) = + fun js_query -> + try + (fun uu___ -> + match () with + | () -> + let uu___1 = FStarC_Interactive_JsonHelper.js_assoc js_query in + unpack_lsp_query uu___1) () + with + | FStarC_Interactive_JsonHelper.UnexpectedJsonType (expected, got) -> + FStarC_Interactive_JsonHelper.wrap_jsfail + FStar_Pervasives_Native.None expected got +let (parse_lsp_query : + Prims.string -> FStarC_Interactive_JsonHelper.lsp_query) = + fun query_str -> + let uu___1 = FStarC_Json.json_of_string query_str in + match uu___1 with + | FStar_Pervasives_Native.None -> + { + FStarC_Interactive_JsonHelper.query_id = + FStar_Pervasives_Native.None; + FStarC_Interactive_JsonHelper.q = + (FStarC_Interactive_JsonHelper.BadProtocolMsg + "Json parsing failed") + } + | FStar_Pervasives_Native.Some request -> deserialize_lsp_query request +let (repl_state_init : + Prims.string -> FStarC_Interactive_Ide_Types.repl_state) = + fun fname -> + let intial_range = + let uu___ = + FStarC_Compiler_Range_Type.mk_pos Prims.int_one Prims.int_zero in + let uu___1 = + FStarC_Compiler_Range_Type.mk_pos Prims.int_one Prims.int_zero in + FStarC_Compiler_Range_Type.mk_range fname uu___ uu___1 in + let env = FStarC_Universal.init_env FStarC_Parser_Dep.empty_deps in + let env1 = FStarC_TypeChecker_Env.set_range env intial_range in + let uu___ = FStarC_Compiler_Util.open_stdin () in + { + FStarC_Interactive_Ide_Types.repl_line = Prims.int_one; + FStarC_Interactive_Ide_Types.repl_column = Prims.int_zero; + FStarC_Interactive_Ide_Types.repl_fname = fname; + FStarC_Interactive_Ide_Types.repl_deps_stack = []; + FStarC_Interactive_Ide_Types.repl_curmod = FStar_Pervasives_Native.None; + FStarC_Interactive_Ide_Types.repl_env = env1; + FStarC_Interactive_Ide_Types.repl_stdin = uu___; + FStarC_Interactive_Ide_Types.repl_names = + FStarC_Interactive_CompletionTable.empty; + FStarC_Interactive_Ide_Types.repl_buffered_input_queries = []; + FStarC_Interactive_Ide_Types.repl_lang = [] + } +type optresponse = + FStarC_Interactive_JsonHelper.assoct FStar_Pervasives_Native.option +type either_gst_exit = + (FStarC_Interactive_Ide_Types.grepl_state, Prims.int) + FStar_Pervasives.either +let (invoke_full_lax : + FStarC_Interactive_Ide_Types.grepl_state -> + Prims.string -> + Prims.string -> Prims.bool -> (optresponse * either_gst_exit)) + = + fun gst -> + fun fname -> + fun text -> + fun force -> + let aux uu___ = + FStarC_Parser_ParseIt.add_vfs_entry fname text; + (let uu___2 = + let uu___3 = repl_state_init fname in + FStarC_Interactive_PushHelper.full_lax text uu___3 in + match uu___2 with + | (diag, st') -> + let repls = + FStarC_Compiler_Util.psmap_add + gst.FStarC_Interactive_Ide_Types.grepl_repls fname st' in + let diag1 = + if FStarC_Compiler_Util.is_some diag + then diag + else + (let uu___4 = + FStarC_Interactive_JsonHelper.js_diag_clear fname in + FStar_Pervasives_Native.Some uu___4) in + (diag1, + (FStar_Pervasives.Inl + { + FStarC_Interactive_Ide_Types.grepl_repls = repls; + FStarC_Interactive_Ide_Types.grepl_stdin = + (gst.FStarC_Interactive_Ide_Types.grepl_stdin) + }))) in + let uu___ = + FStarC_Compiler_Util.psmap_try_find + gst.FStarC_Interactive_Ide_Types.grepl_repls fname in + match uu___ with + | FStar_Pervasives_Native.Some uu___1 -> + if force + then aux () + else (FStar_Pervasives_Native.None, (FStar_Pervasives.Inl gst)) + | FStar_Pervasives_Native.None -> aux () +let (run_query : + FStarC_Interactive_Ide_Types.grepl_state -> + FStarC_Interactive_JsonHelper.lquery -> (optresponse * either_gst_exit)) + = + fun gst -> + fun q -> + match q with + | FStarC_Interactive_JsonHelper.Initialize (uu___, uu___1) -> + let uu___2 = + FStarC_Interactive_JsonHelper.resultResponse + FStarC_Interactive_JsonHelper.js_servcap in + (uu___2, (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.Initialized -> + (FStar_Pervasives_Native.None, (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.Shutdown -> + (FStarC_Interactive_JsonHelper.nullResponse, + (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.Exit -> + (FStar_Pervasives_Native.None, + (FStar_Pervasives.Inr Prims.int_zero)) + | FStarC_Interactive_JsonHelper.Cancel id -> + (FStar_Pervasives_Native.None, (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.FolderChange evt -> + (FStarC_Interactive_JsonHelper.nullResponse, + (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.ChangeConfig -> + (FStarC_Interactive_JsonHelper.nullResponse, + (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.ChangeWatch -> + (FStar_Pervasives_Native.None, (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.Symbol sym -> + (FStarC_Interactive_JsonHelper.nullResponse, + (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.ExecCommand cmd -> + (FStarC_Interactive_JsonHelper.nullResponse, + (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.DidOpen + { FStarC_Interactive_JsonHelper.fname = f; + FStarC_Interactive_JsonHelper.langId = uu___; + FStarC_Interactive_JsonHelper.version = uu___1; + FStarC_Interactive_JsonHelper.text = t;_} + -> invoke_full_lax gst f t false + | FStarC_Interactive_JsonHelper.DidChange (txid, content) -> + (FStarC_Parser_ParseIt.add_vfs_entry txid content; + (FStar_Pervasives_Native.None, (FStar_Pervasives.Inl gst))) + | FStarC_Interactive_JsonHelper.WillSave txid -> + (FStar_Pervasives_Native.None, (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.WillSaveWait txid -> + (FStarC_Interactive_JsonHelper.nullResponse, + (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.DidSave (f, t) -> + invoke_full_lax gst f t true + | FStarC_Interactive_JsonHelper.DidClose txid -> + (FStar_Pervasives_Native.None, (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.Completion (txpos, ctx) -> + let uu___ = + FStarC_Compiler_Util.psmap_try_find + gst.FStarC_Interactive_Ide_Types.grepl_repls + txpos.FStarC_Interactive_JsonHelper.path in + (match uu___ with + | FStar_Pervasives_Native.Some st -> + let uu___1 = + FStarC_Interactive_QueryHelper.complookup st txpos in + (uu___1, (FStar_Pervasives.Inl gst)) + | FStar_Pervasives_Native.None -> + (FStarC_Interactive_JsonHelper.nullResponse, + (FStar_Pervasives.Inl gst))) + | FStarC_Interactive_JsonHelper.Resolve -> + (FStarC_Interactive_JsonHelper.nullResponse, + (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.Hover txpos -> + let uu___ = + FStarC_Compiler_Util.psmap_try_find + gst.FStarC_Interactive_Ide_Types.grepl_repls + txpos.FStarC_Interactive_JsonHelper.path in + (match uu___ with + | FStar_Pervasives_Native.Some st -> + let uu___1 = + FStarC_Interactive_QueryHelper.hoverlookup + st.FStarC_Interactive_Ide_Types.repl_env txpos in + (uu___1, (FStar_Pervasives.Inl gst)) + | FStar_Pervasives_Native.None -> + (FStarC_Interactive_JsonHelper.nullResponse, + (FStar_Pervasives.Inl gst))) + | FStarC_Interactive_JsonHelper.SignatureHelp txpos -> + (FStarC_Interactive_JsonHelper.nullResponse, + (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.Declaration txpos -> + (FStarC_Interactive_JsonHelper.nullResponse, + (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.Definition txpos -> + let uu___ = + FStarC_Compiler_Util.psmap_try_find + gst.FStarC_Interactive_Ide_Types.grepl_repls + txpos.FStarC_Interactive_JsonHelper.path in + (match uu___ with + | FStar_Pervasives_Native.Some st -> + let uu___1 = + FStarC_Interactive_QueryHelper.deflookup + st.FStarC_Interactive_Ide_Types.repl_env txpos in + (uu___1, (FStar_Pervasives.Inl gst)) + | FStar_Pervasives_Native.None -> + (FStarC_Interactive_JsonHelper.nullResponse, + (FStar_Pervasives.Inl gst))) + | FStarC_Interactive_JsonHelper.TypeDefinition txpos -> + (FStarC_Interactive_JsonHelper.nullResponse, + (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.Implementation txpos -> + (FStarC_Interactive_JsonHelper.nullResponse, + (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.References -> + (FStarC_Interactive_JsonHelper.nullResponse, + (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.DocumentHighlight txpos -> + (FStarC_Interactive_JsonHelper.nullResponse, + (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.DocumentSymbol -> + (FStarC_Interactive_JsonHelper.nullResponse, + (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.CodeAction -> + (FStarC_Interactive_JsonHelper.nullResponse, + (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.CodeLens -> + (FStarC_Interactive_JsonHelper.nullResponse, + (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.CodeLensResolve -> + (FStarC_Interactive_JsonHelper.nullResponse, + (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.DocumentLink -> + (FStarC_Interactive_JsonHelper.nullResponse, + (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.DocumentLinkResolve -> + (FStarC_Interactive_JsonHelper.nullResponse, + (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.DocumentColor -> + (FStarC_Interactive_JsonHelper.nullResponse, + (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.ColorPresentation -> + (FStarC_Interactive_JsonHelper.nullResponse, + (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.Formatting -> + (FStarC_Interactive_JsonHelper.nullResponse, + (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.RangeFormatting -> + (FStarC_Interactive_JsonHelper.nullResponse, + (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.TypeFormatting -> + (FStarC_Interactive_JsonHelper.nullResponse, + (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.Rename -> + (FStarC_Interactive_JsonHelper.nullResponse, + (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.PrepareRename txpos -> + (FStarC_Interactive_JsonHelper.nullResponse, + (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.FoldingRange -> + (FStarC_Interactive_JsonHelper.nullResponse, + (FStar_Pervasives.Inl gst)) + | FStarC_Interactive_JsonHelper.BadProtocolMsg msg -> + let uu___ = + let uu___1 = + FStarC_Interactive_JsonHelper.js_resperr + FStarC_Interactive_JsonHelper.MethodNotFound msg in + FStarC_Interactive_JsonHelper.errorResponse uu___1 in + (uu___, (FStar_Pervasives.Inl gst)) +let rec (parse_header_len : + FStarC_Compiler_Util.stream_reader -> Prims.int -> Prims.int) = + fun stream -> + fun len -> + let uu___ = FStarC_Compiler_Util.read_line stream in + match uu___ with + | FStar_Pervasives_Native.Some s -> + if FStarC_Compiler_Util.starts_with s "Content-Length: " + then + let uu___1 = + let uu___2 = + FStarC_Compiler_Util.substring_from s (Prims.of_int (16)) in + FStarC_Compiler_Util.safe_int_of_string uu___2 in + (match uu___1 with + | FStar_Pervasives_Native.Some new_len -> + parse_header_len stream new_len + | FStar_Pervasives_Native.None -> + FStarC_Compiler_Effect.raise + FStarC_Interactive_JsonHelper.MalformedHeader) + else + if FStarC_Compiler_Util.starts_with s "Content-Type: " + then parse_header_len stream len + else + if s = "" + then len + else + FStarC_Compiler_Effect.raise + FStarC_Interactive_JsonHelper.MalformedHeader + | FStar_Pervasives_Native.None -> + FStarC_Compiler_Effect.raise + FStarC_Interactive_JsonHelper.InputExhausted +let rec (read_lsp_query : + FStarC_Compiler_Util.stream_reader -> + FStarC_Interactive_JsonHelper.lsp_query) + = + fun stream -> + try + (fun uu___ -> + match () with + | () -> + let n = parse_header_len stream Prims.int_zero in + let uu___1 = FStarC_Compiler_Util.nread stream n in + (match uu___1 with + | FStar_Pervasives_Native.Some s -> parse_lsp_query s + | FStar_Pervasives_Native.None -> + let uu___2 = + let uu___3 = FStarC_Compiler_Util.string_of_int n in + FStarC_Compiler_Util.format1 "Could not read %s bytes" + uu___3 in + FStarC_Interactive_JsonHelper.wrap_content_szerr uu___2)) + () + with + | FStarC_Interactive_JsonHelper.MalformedHeader -> + (FStarC_Compiler_Util.print_error "[E] Malformed Content Header\n"; + read_lsp_query stream) + | FStarC_Interactive_JsonHelper.InputExhausted -> read_lsp_query stream +let rec (go : FStarC_Interactive_Ide_Types.grepl_state -> Prims.int) = + fun gst -> + let query = read_lsp_query gst.FStarC_Interactive_Ide_Types.grepl_stdin in + let uu___ = run_query gst query.FStarC_Interactive_JsonHelper.q in + match uu___ with + | (r, state_opt) -> + ((match r with + | FStar_Pervasives_Native.Some response -> + let response' = + FStarC_Interactive_JsonHelper.json_of_response + query.FStarC_Interactive_JsonHelper.query_id response in + FStarC_Interactive_JsonHelper.write_jsonrpc response' + | FStar_Pervasives_Native.None -> ()); + (match state_opt with + | FStar_Pervasives.Inl gst' -> go gst' + | FStar_Pervasives.Inr exitcode -> exitcode)) +let (start_server : unit -> unit) = + fun uu___ -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Compiler_Util.psmap_empty () in + let uu___4 = FStarC_Compiler_Util.open_stdin () in + { + FStarC_Interactive_Ide_Types.grepl_repls = uu___3; + FStarC_Interactive_Ide_Types.grepl_stdin = uu___4 + } in + go uu___2 in + FStarC_Compiler_Effect.exit uu___1 \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Interactive_PushHelper.ml b/ocaml/fstar-lib/generated/FStarC_Interactive_PushHelper.ml new file mode 100644 index 00000000000..088f376c974 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Interactive_PushHelper.ml @@ -0,0 +1,960 @@ +open Prims +type ctx_depth_t = + (Prims.int * Prims.int * FStarC_TypeChecker_Env.solver_depth_t * Prims.int) +type deps_t = FStarC_Parser_Dep.deps +type either_replst = + (FStarC_Interactive_Ide_Types.repl_state, + FStarC_Interactive_Ide_Types.repl_state) FStar_Pervasives.either +type name_tracking_event = + | NTAlias of (FStarC_Ident.lid * FStarC_Ident.ident * FStarC_Ident.lid) + | NTOpen of (FStarC_Ident.lid * + FStarC_Syntax_Syntax.open_module_or_namespace) + | NTInclude of (FStarC_Ident.lid * FStarC_Ident.lid) + | NTBinding of (FStarC_Syntax_Syntax.binding, + FStarC_TypeChecker_Env.sig_binding) FStar_Pervasives.either +let (uu___is_NTAlias : name_tracking_event -> Prims.bool) = + fun projectee -> match projectee with | NTAlias _0 -> true | uu___ -> false +let (__proj__NTAlias__item___0 : + name_tracking_event -> + (FStarC_Ident.lid * FStarC_Ident.ident * FStarC_Ident.lid)) + = fun projectee -> match projectee with | NTAlias _0 -> _0 +let (uu___is_NTOpen : name_tracking_event -> Prims.bool) = + fun projectee -> match projectee with | NTOpen _0 -> true | uu___ -> false +let (__proj__NTOpen__item___0 : + name_tracking_event -> + (FStarC_Ident.lid * FStarC_Syntax_Syntax.open_module_or_namespace)) + = fun projectee -> match projectee with | NTOpen _0 -> _0 +let (uu___is_NTInclude : name_tracking_event -> Prims.bool) = + fun projectee -> + match projectee with | NTInclude _0 -> true | uu___ -> false +let (__proj__NTInclude__item___0 : + name_tracking_event -> (FStarC_Ident.lid * FStarC_Ident.lid)) = + fun projectee -> match projectee with | NTInclude _0 -> _0 +let (uu___is_NTBinding : name_tracking_event -> Prims.bool) = + fun projectee -> + match projectee with | NTBinding _0 -> true | uu___ -> false +let (__proj__NTBinding__item___0 : + name_tracking_event -> + (FStarC_Syntax_Syntax.binding, FStarC_TypeChecker_Env.sig_binding) + FStar_Pervasives.either) + = fun projectee -> match projectee with | NTBinding _0 -> _0 +let (repl_stack : + FStarC_Interactive_Ide_Types.repl_stack_t FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref [] +let (set_check_kind : + FStarC_TypeChecker_Env.env_t -> + FStarC_Interactive_Ide_Types.push_kind -> FStarC_TypeChecker_Env.env_t) + = + fun env -> + fun check_kind -> + let uu___ = + (check_kind = FStarC_Interactive_Ide_Types.LaxCheck) || + (FStarC_Options.lax ()) in + let uu___1 = + FStarC_Syntax_DsEnv.set_syntax_only env.FStarC_TypeChecker_Env.dsenv + (check_kind = FStarC_Interactive_Ide_Types.SyntaxCheck) in + { + FStarC_TypeChecker_Env.solver = (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = (env.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = uu___; + FStarC_TypeChecker_Env.lax_universes = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = uu___1; + FStarC_TypeChecker_Env.nbe = (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env.FStarC_TypeChecker_Env.missing_decl) + } +let (repl_ld_tasks_of_deps : + Prims.string Prims.list -> + FStarC_Interactive_Ide_Types.repl_task Prims.list -> + FStarC_Interactive_Ide_Types.repl_task Prims.list) + = + fun deps -> + fun final_tasks -> + let wrap fname = + let uu___ = FStarC_Compiler_Util.now () in + { + FStarC_Interactive_Ide_Types.tf_fname = fname; + FStarC_Interactive_Ide_Types.tf_modtime = uu___ + } in + let rec aux deps1 final_tasks1 = + match deps1 with + | intf::impl::deps' when + FStarC_Universal.needs_interleaving intf impl -> + let uu___ = + let uu___1 = + let uu___2 = wrap intf in + let uu___3 = wrap impl in (uu___2, uu___3) in + FStarC_Interactive_Ide_Types.LDInterleaved uu___1 in + let uu___1 = aux deps' final_tasks1 in uu___ :: uu___1 + | intf_or_impl::deps' -> + let uu___ = + let uu___1 = wrap intf_or_impl in + FStarC_Interactive_Ide_Types.LDSingle uu___1 in + let uu___1 = aux deps' final_tasks1 in uu___ :: uu___1 + | [] -> final_tasks1 in + aux deps final_tasks +let (deps_and_repl_ld_tasks_of_our_file : + Prims.string -> + (Prims.string Prims.list * FStarC_Interactive_Ide_Types.repl_task + Prims.list * deps_t)) + = + fun filename -> + let get_mod_name fname = FStarC_Parser_Dep.lowercase_module_name fname in + let our_mod_name = get_mod_name filename in + let has_our_mod_name f = + let uu___ = get_mod_name f in uu___ = our_mod_name in + let parse_data_cache = FStarC_CheckedFiles.load_parsing_data_from_cache in + let uu___ = + FStarC_Dependencies.find_deps_if_needed [filename] parse_data_cache in + match uu___ with + | (deps, dep_graph) -> + let uu___1 = FStarC_Compiler_List.partition has_our_mod_name deps in + (match uu___1 with + | (same_name, real_deps) -> + let intf_tasks = + match same_name with + | intf::impl::[] -> + ((let uu___3 = + let uu___4 = FStarC_Parser_Dep.is_interface intf in + Prims.op_Negation uu___4 in + if uu___3 + then + let uu___4 = + FStarC_Compiler_Util.format1 + "Expecting an interface, got %s" intf in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_MissingInterface () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4) + else ()); + (let uu___4 = + let uu___5 = FStarC_Parser_Dep.is_implementation impl in + Prims.op_Negation uu___5 in + if uu___4 + then + let uu___5 = + FStarC_Compiler_Util.format1 + "Expecting an implementation, got %s" impl in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_MissingImplementation () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___5) + else ()); + (let uu___4 = + let uu___5 = + let uu___6 = FStarC_Compiler_Util.now () in + { + FStarC_Interactive_Ide_Types.tf_fname = intf; + FStarC_Interactive_Ide_Types.tf_modtime = uu___6 + } in + FStarC_Interactive_Ide_Types.LDInterfaceOfCurrentFile + uu___5 in + [uu___4])) + | impl::[] -> [] + | uu___2 -> + let mods_str = FStarC_Compiler_String.concat " " same_name in + let message = "Too many or too few files matching %s: %s" in + ((let uu___4 = + FStarC_Compiler_Util.format message + [our_mod_name; mods_str] in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_TooManyOrTooFewFileMatch () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4)); + []) in + let tasks = repl_ld_tasks_of_deps real_deps intf_tasks in + (real_deps, tasks, dep_graph)) +let (snapshot_env : + FStarC_TypeChecker_Env.env -> + Prims.string -> + (FStarC_Interactive_Ide_Types.repl_depth_t * + FStarC_TypeChecker_Env.env_t)) + = + fun env -> + fun msg -> + let uu___ = FStarC_TypeChecker_Tc.snapshot_context env msg in + match uu___ with + | (ctx_depth, env1) -> + let uu___1 = FStarC_Options.snapshot () in + (match uu___1 with + | (opt_depth, ()) -> ((ctx_depth, opt_depth), env1)) +let (push_repl : + Prims.string -> + FStarC_Interactive_Ide_Types.push_kind FStar_Pervasives_Native.option -> + FStarC_Interactive_Ide_Types.repl_task -> + FStarC_Interactive_Ide_Types.repl_state -> + FStarC_Interactive_Ide_Types.repl_state) + = + fun msg -> + fun push_kind_opt -> + fun task -> + fun st -> + let uu___ = + snapshot_env st.FStarC_Interactive_Ide_Types.repl_env msg in + match uu___ with + | (depth, env) -> + ((let uu___2 = + let uu___3 = FStarC_Compiler_Effect.op_Bang repl_stack in + (depth, (task, st)) :: uu___3 in + FStarC_Compiler_Effect.op_Colon_Equals repl_stack uu___2); + (match push_kind_opt with + | FStar_Pervasives_Native.None -> st + | FStar_Pervasives_Native.Some push_kind -> + let uu___2 = set_check_kind env push_kind in + { + FStarC_Interactive_Ide_Types.repl_line = + (st.FStarC_Interactive_Ide_Types.repl_line); + FStarC_Interactive_Ide_Types.repl_column = + (st.FStarC_Interactive_Ide_Types.repl_column); + FStarC_Interactive_Ide_Types.repl_fname = + (st.FStarC_Interactive_Ide_Types.repl_fname); + FStarC_Interactive_Ide_Types.repl_deps_stack = + (st.FStarC_Interactive_Ide_Types.repl_deps_stack); + FStarC_Interactive_Ide_Types.repl_curmod = + (st.FStarC_Interactive_Ide_Types.repl_curmod); + FStarC_Interactive_Ide_Types.repl_env = uu___2; + FStarC_Interactive_Ide_Types.repl_stdin = + (st.FStarC_Interactive_Ide_Types.repl_stdin); + FStarC_Interactive_Ide_Types.repl_names = + (st.FStarC_Interactive_Ide_Types.repl_names); + FStarC_Interactive_Ide_Types.repl_buffered_input_queries + = + (st.FStarC_Interactive_Ide_Types.repl_buffered_input_queries); + FStarC_Interactive_Ide_Types.repl_lang = + (st.FStarC_Interactive_Ide_Types.repl_lang) + })) +let (add_issues_to_push_fragment : FStarC_Json.json Prims.list -> unit) = + fun issues -> + let uu___ = FStarC_Compiler_Effect.op_Bang repl_stack in + match uu___ with + | (depth, + (FStarC_Interactive_Ide_Types.PushFragment (frag, push_kind, i), st))::rest + -> + let pf = + FStarC_Interactive_Ide_Types.PushFragment + (frag, push_kind, (FStarC_Compiler_List.op_At issues i)) in + FStarC_Compiler_Effect.op_Colon_Equals repl_stack ((depth, (pf, st)) + :: rest) + | uu___1 -> () +let (rollback_env : + FStarC_TypeChecker_Env.solver_t -> + Prims.string -> + ((Prims.int * Prims.int * FStarC_TypeChecker_Env.solver_depth_t * + Prims.int) * Prims.int) -> FStarC_TypeChecker_Env.env) + = + fun solver -> + fun msg -> + fun uu___ -> + match uu___ with + | (ctx_depth, opt_depth) -> + let env = + FStarC_TypeChecker_Tc.rollback_context solver msg + (FStar_Pervasives_Native.Some ctx_depth) in + (FStarC_Options.rollback (FStar_Pervasives_Native.Some opt_depth); + env) +let (pop_repl : + Prims.string -> + FStarC_Interactive_Ide_Types.repl_state -> + FStarC_Interactive_Ide_Types.repl_state) + = + fun msg -> + fun st -> + let uu___ = FStarC_Compiler_Effect.op_Bang repl_stack in + match uu___ with + | [] -> failwith "Too many pops" + | (depth, (uu___1, st'))::stack_tl -> + let env = + rollback_env + (st.FStarC_Interactive_Ide_Types.repl_env).FStarC_TypeChecker_Env.solver + msg depth in + (FStarC_Compiler_Effect.op_Colon_Equals repl_stack stack_tl; + (let uu___4 = + FStarC_Compiler_Util.physical_equality env + st'.FStarC_Interactive_Ide_Types.repl_env in + FStarC_Common.runtime_assert uu___4 "Inconsistent stack state"); + st') +let (tc_one : + FStarC_TypeChecker_Env.env_t -> + Prims.string FStar_Pervasives_Native.option -> + Prims.string -> FStarC_TypeChecker_Env.env_t) + = + fun env -> + fun intf_opt -> + fun modf -> + let parse_data = + let uu___ = FStarC_TypeChecker_Env.dep_graph env in + FStarC_Parser_Dep.parsing_data_of uu___ modf in + let uu___ = + FStarC_Universal.tc_one_file_for_ide env intf_opt modf parse_data in + match uu___ with | (uu___1, env1) -> env1 +let (run_repl_task : + FStarC_Interactive_Ide_Types.optmod_t -> + FStarC_TypeChecker_Env.env_t -> + FStarC_Interactive_Ide_Types.repl_task -> + FStarC_Universal.lang_decls_t -> + (FStarC_Interactive_Ide_Types.optmod_t * + FStarC_TypeChecker_Env.env_t * FStarC_Universal.lang_decls_t)) + = + fun curmod -> + fun env -> + fun task -> + fun lds -> + match task with + | FStarC_Interactive_Ide_Types.LDInterleaved (intf, impl) -> + let uu___ = + tc_one env + (FStar_Pervasives_Native.Some + (intf.FStarC_Interactive_Ide_Types.tf_fname)) + impl.FStarC_Interactive_Ide_Types.tf_fname in + (curmod, uu___, []) + | FStarC_Interactive_Ide_Types.LDSingle intf_or_impl -> + let uu___ = + tc_one env FStar_Pervasives_Native.None + intf_or_impl.FStarC_Interactive_Ide_Types.tf_fname in + (curmod, uu___, []) + | FStarC_Interactive_Ide_Types.LDInterfaceOfCurrentFile intf -> + let uu___ = + FStarC_Universal.load_interface_decls env + intf.FStarC_Interactive_Ide_Types.tf_fname in + (curmod, uu___, []) + | FStarC_Interactive_Ide_Types.PushFragment (frag, uu___, uu___1) + -> + let frag1 = + match frag with + | FStar_Pervasives.Inl frag2 -> + FStar_Pervasives.Inl (frag2, lds) + | FStar_Pervasives.Inr decl -> FStar_Pervasives.Inr decl in + let uu___2 = FStarC_Universal.tc_one_fragment curmod env frag1 in + (match uu___2 with | (o, e, langs) -> (o, e, langs)) + | FStarC_Interactive_Ide_Types.Noop -> (curmod, env, []) +let (query_of_ids : + FStarC_Ident.ident Prims.list -> FStarC_Interactive_CompletionTable.query) + = fun ids -> FStarC_Compiler_List.map FStarC_Ident.string_of_id ids +let (query_of_lid : + FStarC_Ident.lident -> FStarC_Interactive_CompletionTable.query) = + fun lid -> + let uu___ = + let uu___1 = FStarC_Ident.ns_of_lid lid in + let uu___2 = let uu___3 = FStarC_Ident.ident_of_lid lid in [uu___3] in + FStarC_Compiler_List.op_At uu___1 uu___2 in + query_of_ids uu___ +let (update_names_from_event : + Prims.string -> + FStarC_Interactive_CompletionTable.table -> + name_tracking_event -> FStarC_Interactive_CompletionTable.table) + = + fun cur_mod_str -> + fun table -> + fun evt -> + let is_cur_mod lid = + let uu___ = FStarC_Ident.string_of_lid lid in uu___ = cur_mod_str in + match evt with + | NTAlias (host, id, included) -> + let uu___ = is_cur_mod host in + if uu___ + then + let uu___1 = FStarC_Ident.string_of_id id in + let uu___2 = query_of_lid included in + FStarC_Interactive_CompletionTable.register_alias table uu___1 + [] uu___2 + else table + | NTOpen (host, (included, kind, uu___)) -> + let uu___1 = is_cur_mod host in + if uu___1 + then + let uu___2 = query_of_lid included in + FStarC_Interactive_CompletionTable.register_open table + (kind = FStarC_Syntax_Syntax.Open_module) [] uu___2 + else table + | NTInclude (host, included) -> + let uu___ = + let uu___1 = is_cur_mod host in + if uu___1 then [] else query_of_lid host in + let uu___1 = query_of_lid included in + FStarC_Interactive_CompletionTable.register_include table uu___ + uu___1 + | NTBinding binding -> + let lids = + match binding with + | FStar_Pervasives.Inl (FStarC_Syntax_Syntax.Binding_lid + (lid, uu___)) -> [lid] + | FStar_Pervasives.Inr (lids1, uu___) -> lids1 + | uu___ -> [] in + FStarC_Compiler_List.fold_left + (fun tbl -> + fun lid -> + let ns_query = + let uu___ = + let uu___1 = FStarC_Ident.nsstr lid in + uu___1 = cur_mod_str in + if uu___ + then [] + else + (let uu___2 = FStarC_Ident.ns_of_lid lid in + query_of_ids uu___2) in + let uu___ = + let uu___1 = FStarC_Ident.ident_of_lid lid in + FStarC_Ident.string_of_id uu___1 in + FStarC_Interactive_CompletionTable.insert tbl ns_query + uu___ lid) table lids +let (commit_name_tracking' : + FStarC_Syntax_Syntax.modul FStar_Pervasives_Native.option -> + FStarC_Interactive_CompletionTable.table -> + name_tracking_event Prims.list -> + FStarC_Interactive_CompletionTable.table) + = + fun cur_mod -> + fun names -> + fun name_events -> + let cur_mod_str = + match cur_mod with + | FStar_Pervasives_Native.None -> "" + | FStar_Pervasives_Native.Some md -> + let uu___ = FStarC_Syntax_Syntax.mod_name md in + FStarC_Ident.string_of_lid uu___ in + let updater = update_names_from_event cur_mod_str in + FStarC_Compiler_List.fold_left updater names name_events +let (commit_name_tracking : + FStarC_Interactive_Ide_Types.repl_state -> + name_tracking_event Prims.list -> FStarC_Interactive_Ide_Types.repl_state) + = + fun st -> + fun name_events -> + let names = + commit_name_tracking' st.FStarC_Interactive_Ide_Types.repl_curmod + st.FStarC_Interactive_Ide_Types.repl_names name_events in + { + FStarC_Interactive_Ide_Types.repl_line = + (st.FStarC_Interactive_Ide_Types.repl_line); + FStarC_Interactive_Ide_Types.repl_column = + (st.FStarC_Interactive_Ide_Types.repl_column); + FStarC_Interactive_Ide_Types.repl_fname = + (st.FStarC_Interactive_Ide_Types.repl_fname); + FStarC_Interactive_Ide_Types.repl_deps_stack = + (st.FStarC_Interactive_Ide_Types.repl_deps_stack); + FStarC_Interactive_Ide_Types.repl_curmod = + (st.FStarC_Interactive_Ide_Types.repl_curmod); + FStarC_Interactive_Ide_Types.repl_env = + (st.FStarC_Interactive_Ide_Types.repl_env); + FStarC_Interactive_Ide_Types.repl_stdin = + (st.FStarC_Interactive_Ide_Types.repl_stdin); + FStarC_Interactive_Ide_Types.repl_names = names; + FStarC_Interactive_Ide_Types.repl_buffered_input_queries = + (st.FStarC_Interactive_Ide_Types.repl_buffered_input_queries); + FStarC_Interactive_Ide_Types.repl_lang = + (st.FStarC_Interactive_Ide_Types.repl_lang) + } +let (fresh_name_tracking_hooks : + unit -> + (name_tracking_event Prims.list FStarC_Compiler_Effect.ref * + FStarC_Syntax_DsEnv.dsenv_hooks * FStarC_TypeChecker_Env.tcenv_hooks)) + = + fun uu___ -> + let events = FStarC_Compiler_Util.mk_ref [] in + let push_event evt = + let uu___1 = + let uu___2 = FStarC_Compiler_Effect.op_Bang events in evt :: uu___2 in + FStarC_Compiler_Effect.op_Colon_Equals events uu___1 in + let uu___1 = + FStarC_Syntax_DsEnv.mk_dsenv_hooks + (fun dsenv -> + fun op -> + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_DsEnv.current_module dsenv in + (uu___4, op) in + NTOpen uu___3 in + push_event uu___2) + (fun dsenv -> + fun ns -> + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_DsEnv.current_module dsenv in + (uu___4, ns) in + NTInclude uu___3 in + push_event uu___2) + (fun dsenv -> + fun x -> + fun l -> + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_DsEnv.current_module dsenv in + (uu___4, x, l) in + NTAlias uu___3 in + push_event uu___2) in + (events, uu___1, + { + FStarC_TypeChecker_Env.tc_push_in_gamma_hook = + (fun uu___2 -> fun s -> push_event (NTBinding s)) + }) +let (track_name_changes : + FStarC_TypeChecker_Env.env_t -> + (FStarC_TypeChecker_Env.env_t * + (FStarC_TypeChecker_Env.env_t -> + (FStarC_TypeChecker_Env.env_t * name_tracking_event Prims.list)))) + = + fun env -> + let set_hooks dshooks tchooks env1 = + let uu___ = + FStarC_Universal.with_dsenv_of_tcenv env1 + (fun dsenv -> + let uu___1 = FStarC_Syntax_DsEnv.set_ds_hooks dsenv dshooks in + ((), uu___1)) in + match uu___ with + | ((), tcenv') -> FStarC_TypeChecker_Env.set_tc_hooks tcenv' tchooks in + let uu___ = + let uu___1 = + FStarC_Syntax_DsEnv.ds_hooks env.FStarC_TypeChecker_Env.dsenv in + let uu___2 = FStarC_TypeChecker_Env.tc_hooks env in (uu___1, uu___2) in + match uu___ with + | (old_dshooks, old_tchooks) -> + let uu___1 = fresh_name_tracking_hooks () in + (match uu___1 with + | (events, new_dshooks, new_tchooks) -> + let uu___2 = set_hooks new_dshooks new_tchooks env in + (uu___2, + ((fun env1 -> + let uu___3 = set_hooks old_dshooks old_tchooks env1 in + let uu___4 = + let uu___5 = FStarC_Compiler_Effect.op_Bang events in + FStarC_Compiler_List.rev uu___5 in + (uu___3, uu___4))))) +let (repl_tx : + FStarC_Interactive_Ide_Types.repl_state -> + FStarC_Interactive_Ide_Types.push_kind -> + FStarC_Interactive_Ide_Types.repl_task -> + (FStarC_Interactive_JsonHelper.assoct FStar_Pervasives_Native.option + * FStarC_Interactive_Ide_Types.repl_state)) + = + fun st -> + fun push_kind -> + fun task -> + try + (fun uu___ -> + match () with + | () -> + let st1 = + push_repl "repl_tx" + (FStar_Pervasives_Native.Some push_kind) task st in + let uu___1 = + track_name_changes + st1.FStarC_Interactive_Ide_Types.repl_env in + (match uu___1 with + | (env, finish_name_tracking) -> + let uu___2 = + run_repl_task + st1.FStarC_Interactive_Ide_Types.repl_curmod env + task st1.FStarC_Interactive_Ide_Types.repl_lang in + (match uu___2 with + | (curmod, env1, lds) -> + let st2 = + { + FStarC_Interactive_Ide_Types.repl_line = + (st1.FStarC_Interactive_Ide_Types.repl_line); + FStarC_Interactive_Ide_Types.repl_column = + (st1.FStarC_Interactive_Ide_Types.repl_column); + FStarC_Interactive_Ide_Types.repl_fname = + (st1.FStarC_Interactive_Ide_Types.repl_fname); + FStarC_Interactive_Ide_Types.repl_deps_stack = + (st1.FStarC_Interactive_Ide_Types.repl_deps_stack); + FStarC_Interactive_Ide_Types.repl_curmod = + curmod; + FStarC_Interactive_Ide_Types.repl_env = env1; + FStarC_Interactive_Ide_Types.repl_stdin = + (st1.FStarC_Interactive_Ide_Types.repl_stdin); + FStarC_Interactive_Ide_Types.repl_names = + (st1.FStarC_Interactive_Ide_Types.repl_names); + FStarC_Interactive_Ide_Types.repl_buffered_input_queries + = + (st1.FStarC_Interactive_Ide_Types.repl_buffered_input_queries); + FStarC_Interactive_Ide_Types.repl_lang = + (FStarC_Compiler_List.op_At + (FStarC_Compiler_List.rev lds) + st1.FStarC_Interactive_Ide_Types.repl_lang) + } in + let uu___3 = finish_name_tracking env1 in + (match uu___3 with + | (env2, name_events) -> + let uu___4 = + commit_name_tracking st2 name_events in + (FStar_Pervasives_Native.None, uu___4))))) () + with + | FStarC_Compiler_Effect.Failure msg -> + let uu___1 = + let uu___2 = + FStarC_Interactive_JsonHelper.js_diag + st.FStarC_Interactive_Ide_Types.repl_fname msg + FStar_Pervasives_Native.None in + FStar_Pervasives_Native.Some uu___2 in + (uu___1, st) + | FStarC_Compiler_Util.SigInt -> + (FStarC_Compiler_Util.print_error "[E] Interrupt"; + (FStar_Pervasives_Native.None, st)) + | FStarC_Errors.Error (e, msg, r, _ctx) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Errors_Msg.rendermsg msg in + FStarC_Interactive_JsonHelper.js_diag + st.FStarC_Interactive_Ide_Types.repl_fname uu___3 + (FStar_Pervasives_Native.Some r) in + FStar_Pervasives_Native.Some uu___2 in + (uu___1, st) + | FStarC_Errors.Stop -> + (FStarC_Compiler_Util.print_error "[E] Stop"; + (FStar_Pervasives_Native.None, st)) +let (tf_of_fname : Prims.string -> FStarC_Interactive_Ide_Types.timed_fname) + = + fun fname -> + let uu___ = FStarC_Parser_ParseIt.get_file_last_modification_time fname in + { + FStarC_Interactive_Ide_Types.tf_fname = fname; + FStarC_Interactive_Ide_Types.tf_modtime = uu___ + } +let (update_task_timestamps : + FStarC_Interactive_Ide_Types.repl_task -> + FStarC_Interactive_Ide_Types.repl_task) + = + fun uu___ -> + match uu___ with + | FStarC_Interactive_Ide_Types.LDInterleaved (intf, impl) -> + let uu___1 = + let uu___2 = tf_of_fname intf.FStarC_Interactive_Ide_Types.tf_fname in + let uu___3 = tf_of_fname impl.FStarC_Interactive_Ide_Types.tf_fname in + (uu___2, uu___3) in + FStarC_Interactive_Ide_Types.LDInterleaved uu___1 + | FStarC_Interactive_Ide_Types.LDSingle intf_or_impl -> + let uu___1 = + tf_of_fname intf_or_impl.FStarC_Interactive_Ide_Types.tf_fname in + FStarC_Interactive_Ide_Types.LDSingle uu___1 + | FStarC_Interactive_Ide_Types.LDInterfaceOfCurrentFile intf -> + let uu___1 = tf_of_fname intf.FStarC_Interactive_Ide_Types.tf_fname in + FStarC_Interactive_Ide_Types.LDInterfaceOfCurrentFile uu___1 + | other -> other +let (repl_ldtx : + FStarC_Interactive_Ide_Types.repl_state -> + FStarC_Interactive_Ide_Types.repl_task Prims.list -> either_replst) + = + fun st -> + fun tasks -> + let rec revert_many st1 uu___ = + match uu___ with + | [] -> st1 + | (_id, (task, _st'))::entries -> + let st' = pop_repl "repl_ldtx" st1 in + let dep_graph = + FStarC_TypeChecker_Env.dep_graph + st1.FStarC_Interactive_Ide_Types.repl_env in + let st'1 = + let uu___1 = + FStarC_TypeChecker_Env.set_dep_graph + st'.FStarC_Interactive_Ide_Types.repl_env dep_graph in + { + FStarC_Interactive_Ide_Types.repl_line = + (st'.FStarC_Interactive_Ide_Types.repl_line); + FStarC_Interactive_Ide_Types.repl_column = + (st'.FStarC_Interactive_Ide_Types.repl_column); + FStarC_Interactive_Ide_Types.repl_fname = + (st'.FStarC_Interactive_Ide_Types.repl_fname); + FStarC_Interactive_Ide_Types.repl_deps_stack = + (st'.FStarC_Interactive_Ide_Types.repl_deps_stack); + FStarC_Interactive_Ide_Types.repl_curmod = + (st'.FStarC_Interactive_Ide_Types.repl_curmod); + FStarC_Interactive_Ide_Types.repl_env = uu___1; + FStarC_Interactive_Ide_Types.repl_stdin = + (st'.FStarC_Interactive_Ide_Types.repl_stdin); + FStarC_Interactive_Ide_Types.repl_names = + (st'.FStarC_Interactive_Ide_Types.repl_names); + FStarC_Interactive_Ide_Types.repl_buffered_input_queries = + (st'.FStarC_Interactive_Ide_Types.repl_buffered_input_queries); + FStarC_Interactive_Ide_Types.repl_lang = + (st'.FStarC_Interactive_Ide_Types.repl_lang) + } in + revert_many st'1 entries in + let rec aux st1 tasks1 previous = + match (tasks1, previous) with + | ([], []) -> FStar_Pervasives.Inl st1 + | (task::tasks2, []) -> + let timestamped_task = update_task_timestamps task in + let uu___ = + repl_tx st1 FStarC_Interactive_Ide_Types.LaxCheck + timestamped_task in + (match uu___ with + | (diag, st2) -> + if Prims.op_Negation (FStarC_Compiler_Util.is_some diag) + then + let uu___1 = + let uu___2 = FStarC_Compiler_Effect.op_Bang repl_stack in + { + FStarC_Interactive_Ide_Types.repl_line = + (st2.FStarC_Interactive_Ide_Types.repl_line); + FStarC_Interactive_Ide_Types.repl_column = + (st2.FStarC_Interactive_Ide_Types.repl_column); + FStarC_Interactive_Ide_Types.repl_fname = + (st2.FStarC_Interactive_Ide_Types.repl_fname); + FStarC_Interactive_Ide_Types.repl_deps_stack = uu___2; + FStarC_Interactive_Ide_Types.repl_curmod = + (st2.FStarC_Interactive_Ide_Types.repl_curmod); + FStarC_Interactive_Ide_Types.repl_env = + (st2.FStarC_Interactive_Ide_Types.repl_env); + FStarC_Interactive_Ide_Types.repl_stdin = + (st2.FStarC_Interactive_Ide_Types.repl_stdin); + FStarC_Interactive_Ide_Types.repl_names = + (st2.FStarC_Interactive_Ide_Types.repl_names); + FStarC_Interactive_Ide_Types.repl_buffered_input_queries + = + (st2.FStarC_Interactive_Ide_Types.repl_buffered_input_queries); + FStarC_Interactive_Ide_Types.repl_lang = + (st2.FStarC_Interactive_Ide_Types.repl_lang) + } in + aux uu___1 tasks2 [] + else FStar_Pervasives.Inr st2) + | (task::tasks2, prev::previous1) when + let uu___ = update_task_timestamps task in + (FStar_Pervasives_Native.fst (FStar_Pervasives_Native.snd prev)) + = uu___ + -> aux st1 tasks2 previous1 + | (tasks2, previous1) -> + let uu___ = revert_many st1 previous1 in aux uu___ tasks2 [] in + aux st tasks + (FStarC_Compiler_List.rev + st.FStarC_Interactive_Ide_Types.repl_deps_stack) +let (ld_deps : + FStarC_Interactive_Ide_Types.repl_state -> + ((FStarC_Interactive_Ide_Types.repl_state * Prims.string Prims.list), + FStarC_Interactive_Ide_Types.repl_state) FStar_Pervasives.either) + = + fun st -> + try + (fun uu___ -> + match () with + | () -> + let uu___1 = + deps_and_repl_ld_tasks_of_our_file + st.FStarC_Interactive_Ide_Types.repl_fname in + (match uu___1 with + | (deps, tasks, dep_graph) -> + let st1 = + let uu___2 = + FStarC_TypeChecker_Env.set_dep_graph + st.FStarC_Interactive_Ide_Types.repl_env dep_graph in + { + FStarC_Interactive_Ide_Types.repl_line = + (st.FStarC_Interactive_Ide_Types.repl_line); + FStarC_Interactive_Ide_Types.repl_column = + (st.FStarC_Interactive_Ide_Types.repl_column); + FStarC_Interactive_Ide_Types.repl_fname = + (st.FStarC_Interactive_Ide_Types.repl_fname); + FStarC_Interactive_Ide_Types.repl_deps_stack = + (st.FStarC_Interactive_Ide_Types.repl_deps_stack); + FStarC_Interactive_Ide_Types.repl_curmod = + (st.FStarC_Interactive_Ide_Types.repl_curmod); + FStarC_Interactive_Ide_Types.repl_env = uu___2; + FStarC_Interactive_Ide_Types.repl_stdin = + (st.FStarC_Interactive_Ide_Types.repl_stdin); + FStarC_Interactive_Ide_Types.repl_names = + (st.FStarC_Interactive_Ide_Types.repl_names); + FStarC_Interactive_Ide_Types.repl_buffered_input_queries + = + (st.FStarC_Interactive_Ide_Types.repl_buffered_input_queries); + FStarC_Interactive_Ide_Types.repl_lang = + (st.FStarC_Interactive_Ide_Types.repl_lang) + } in + let uu___2 = repl_ldtx st1 tasks in + (match uu___2 with + | FStar_Pervasives.Inr st2 -> FStar_Pervasives.Inr st2 + | FStar_Pervasives.Inl st2 -> + FStar_Pervasives.Inl (st2, deps)))) () + with + | FStarC_Errors.Error (e, msg, _rng, ctx) -> + ((let uu___2 = FStarC_Errors_Msg.rendermsg msg in + FStarC_Compiler_Util.print1_error "[E] Failed to load deps. %s" + uu___2); + FStar_Pervasives.Inr st) + | exn -> + ((let uu___2 = FStarC_Compiler_Util.message_of_exn exn in + FStarC_Compiler_Util.print1_error + "[E] Failed to load deps. Message: %s" uu___2); + FStar_Pervasives.Inr st) +let (add_module_completions : + Prims.string -> + Prims.string Prims.list -> + FStarC_Interactive_CompletionTable.table -> + FStarC_Interactive_CompletionTable.table) + = + fun this_fname -> + fun deps -> + fun table -> + let capitalize str = + if str = "" + then str + else + (let first = + FStarC_Compiler_String.substring str Prims.int_zero + Prims.int_one in + let uu___1 = + FStarC_Compiler_String.substring str Prims.int_one + ((FStarC_Compiler_String.length str) - Prims.int_one) in + Prims.strcat (FStarC_Compiler_String.uppercase first) uu___1) in + let mods = FStarC_Parser_Dep.build_inclusion_candidates_list () in + let loaded_mods_set = + let uu___ = FStarC_Compiler_Util.psmap_empty () in + let uu___1 = + let uu___2 = FStarC_Basefiles.prims () in uu___2 :: deps in + FStarC_Compiler_List.fold_left + (fun acc -> + fun dep -> + let uu___2 = FStarC_Parser_Dep.lowercase_module_name dep in + FStarC_Compiler_Util.psmap_add acc uu___2 true) uu___ uu___1 in + let loaded modname = + FStarC_Compiler_Util.psmap_find_default loaded_mods_set modname + false in + let this_mod_key = FStarC_Parser_Dep.lowercase_module_name this_fname in + FStarC_Compiler_List.fold_left + (fun table1 -> + fun uu___ -> + match uu___ with + | (modname, mod_path) -> + let mod_key = FStarC_Compiler_String.lowercase modname in + if this_mod_key = mod_key + then table1 + else + (let ns_query = + let uu___2 = capitalize modname in + FStarC_Compiler_Util.split uu___2 "." in + let uu___2 = loaded mod_key in + FStarC_Interactive_CompletionTable.register_module_path + table1 uu___2 mod_path ns_query)) table + (FStarC_Compiler_List.rev mods) +let (full_lax : + Prims.string -> + FStarC_Interactive_Ide_Types.repl_state -> + (FStarC_Interactive_JsonHelper.assoct FStar_Pervasives_Native.option * + FStarC_Interactive_Ide_Types.repl_state)) + = + fun text -> + fun st -> + FStarC_TypeChecker_Env.toggle_id_info + st.FStarC_Interactive_Ide_Types.repl_env true; + (let frag = + { + FStarC_Parser_ParseIt.frag_fname = + (st.FStarC_Interactive_Ide_Types.repl_fname); + FStarC_Parser_ParseIt.frag_text = text; + FStarC_Parser_ParseIt.frag_line = Prims.int_one; + FStarC_Parser_ParseIt.frag_col = Prims.int_zero + } in + let uu___1 = ld_deps st in + match uu___1 with + | FStar_Pervasives.Inl (st1, deps) -> + let names = + add_module_completions + st1.FStarC_Interactive_Ide_Types.repl_fname deps + st1.FStarC_Interactive_Ide_Types.repl_names in + repl_tx + { + FStarC_Interactive_Ide_Types.repl_line = + (st1.FStarC_Interactive_Ide_Types.repl_line); + FStarC_Interactive_Ide_Types.repl_column = + (st1.FStarC_Interactive_Ide_Types.repl_column); + FStarC_Interactive_Ide_Types.repl_fname = + (st1.FStarC_Interactive_Ide_Types.repl_fname); + FStarC_Interactive_Ide_Types.repl_deps_stack = + (st1.FStarC_Interactive_Ide_Types.repl_deps_stack); + FStarC_Interactive_Ide_Types.repl_curmod = + (st1.FStarC_Interactive_Ide_Types.repl_curmod); + FStarC_Interactive_Ide_Types.repl_env = + (st1.FStarC_Interactive_Ide_Types.repl_env); + FStarC_Interactive_Ide_Types.repl_stdin = + (st1.FStarC_Interactive_Ide_Types.repl_stdin); + FStarC_Interactive_Ide_Types.repl_names = names; + FStarC_Interactive_Ide_Types.repl_buffered_input_queries = + (st1.FStarC_Interactive_Ide_Types.repl_buffered_input_queries); + FStarC_Interactive_Ide_Types.repl_lang = + (st1.FStarC_Interactive_Ide_Types.repl_lang) + } FStarC_Interactive_Ide_Types.LaxCheck + (FStarC_Interactive_Ide_Types.PushFragment + ((FStar_Pervasives.Inl frag), + FStarC_Interactive_Ide_Types.LaxCheck, [])) + | FStar_Pervasives.Inr st1 -> (FStar_Pervasives_Native.None, st1)) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Interactive_QueryHelper.ml b/ocaml/fstar-lib/generated/FStarC_Interactive_QueryHelper.ml new file mode 100644 index 00000000000..f09de694ab1 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Interactive_QueryHelper.ml @@ -0,0 +1,304 @@ +open Prims +type position = (Prims.string * Prims.int * Prims.int) +type sl_reponse = + { + slr_name: Prims.string ; + slr_def_range: + FStarC_Compiler_Range_Type.range FStar_Pervasives_Native.option ; + slr_typ: Prims.string FStar_Pervasives_Native.option ; + slr_doc: Prims.string FStar_Pervasives_Native.option ; + slr_def: Prims.string FStar_Pervasives_Native.option } +let (__proj__Mksl_reponse__item__slr_name : sl_reponse -> Prims.string) = + fun projectee -> + match projectee with + | { slr_name; slr_def_range; slr_typ; slr_doc; slr_def;_} -> slr_name +let (__proj__Mksl_reponse__item__slr_def_range : + sl_reponse -> + FStarC_Compiler_Range_Type.range FStar_Pervasives_Native.option) + = + fun projectee -> + match projectee with + | { slr_name; slr_def_range; slr_typ; slr_doc; slr_def;_} -> + slr_def_range +let (__proj__Mksl_reponse__item__slr_typ : + sl_reponse -> Prims.string FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { slr_name; slr_def_range; slr_typ; slr_doc; slr_def;_} -> slr_typ +let (__proj__Mksl_reponse__item__slr_doc : + sl_reponse -> Prims.string FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { slr_name; slr_def_range; slr_typ; slr_doc; slr_def;_} -> slr_doc +let (__proj__Mksl_reponse__item__slr_def : + sl_reponse -> Prims.string FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { slr_name; slr_def_range; slr_typ; slr_doc; slr_def;_} -> slr_def +let with_printed_effect_args : 'uuuuu . (unit -> 'uuuuu) -> 'uuuuu = + fun k -> + FStarC_Options.with_saved_options + (fun uu___ -> + FStarC_Options.set_option "print_effect_args" + (FStarC_Options.Bool true); + k ()) +let (term_to_string : + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.term -> Prims.string) = + fun tcenv -> + fun t -> + with_printed_effect_args + (fun uu___ -> FStarC_TypeChecker_Normalize.term_to_string tcenv t) +let (sigelt_to_string : + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.sigelt -> Prims.string) + = + fun tcenv -> + fun se -> + with_printed_effect_args + (fun uu___ -> + let uu___1 = + FStarC_Syntax_DsEnv.set_current_module + tcenv.FStarC_TypeChecker_Env.dsenv + tcenv.FStarC_TypeChecker_Env.curmodule in + FStarC_Syntax_Print.sigelt_to_string' uu___1 se) +let (symlookup : + FStarC_TypeChecker_Env.env -> + Prims.string -> + position FStar_Pervasives_Native.option -> + Prims.string Prims.list -> sl_reponse FStar_Pervasives_Native.option) + = + fun tcenv -> + fun symbol -> + fun pos_opt -> + fun requested_info -> + let info_of_lid_str lid_str = + let lid = + let uu___ = + FStarC_Compiler_List.map FStarC_Ident.id_of_text + (FStarC_Compiler_Util.split lid_str ".") in + FStarC_Ident.lid_of_ids uu___ in + let lid1 = + let uu___ = + FStarC_Syntax_DsEnv.resolve_to_fully_qualified_name + tcenv.FStarC_TypeChecker_Env.dsenv lid in + FStarC_Compiler_Util.dflt lid uu___ in + let uu___ = FStarC_TypeChecker_Env.try_lookup_lid tcenv lid1 in + FStarC_Compiler_Util.map_option + (fun uu___1 -> + match uu___1 with + | ((uu___2, typ), r) -> + ((FStar_Pervasives.Inr lid1), typ, r)) uu___ in + let docs_of_lid lid = FStar_Pervasives_Native.None in + let def_of_lid lid = + let uu___ = FStarC_TypeChecker_Env.lookup_qname tcenv lid in + FStarC_Compiler_Util.bind_opt uu___ + (fun uu___1 -> + match uu___1 with + | (FStar_Pervasives.Inr (se, uu___2), uu___3) -> + let uu___4 = sigelt_to_string tcenv se in + FStar_Pervasives_Native.Some uu___4 + | uu___2 -> FStar_Pervasives_Native.None) in + let info_at_pos_opt = + FStarC_Compiler_Util.bind_opt pos_opt + (fun uu___ -> + match uu___ with + | (file, row, col) -> + FStarC_TypeChecker_Err.info_at_pos tcenv file row col) in + let info_opt = + match info_at_pos_opt with + | FStar_Pervasives_Native.Some uu___ -> info_at_pos_opt + | FStar_Pervasives_Native.None -> + if symbol = "" + then FStar_Pervasives_Native.None + else info_of_lid_str symbol in + match info_opt with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (name_or_lid, typ, rng) -> + let name = + match name_or_lid with + | FStar_Pervasives.Inl name1 -> name1 + | FStar_Pervasives.Inr lid -> FStarC_Ident.string_of_lid lid in + let str_of_opt uu___ = + match uu___ with + | FStar_Pervasives_Native.None -> "" + | FStar_Pervasives_Native.Some s -> s in + let typ_str = + if FStarC_Compiler_List.mem "type" requested_info + then + let uu___ = term_to_string tcenv typ in + FStar_Pervasives_Native.Some uu___ + else FStar_Pervasives_Native.None in + let doc_str = + match name_or_lid with + | FStar_Pervasives.Inr lid when + FStarC_Compiler_List.mem "documentation" requested_info + -> docs_of_lid lid + | uu___ -> FStar_Pervasives_Native.None in + let def_str = + match name_or_lid with + | FStar_Pervasives.Inr lid when + FStarC_Compiler_List.mem "definition" requested_info -> + def_of_lid lid + | uu___ -> FStar_Pervasives_Native.None in + let def_range = + if FStarC_Compiler_List.mem "defined-at" requested_info + then FStar_Pervasives_Native.Some rng + else FStar_Pervasives_Native.None in + FStar_Pervasives_Native.Some + { + slr_name = name; + slr_def_range = def_range; + slr_typ = typ_str; + slr_doc = doc_str; + slr_def = def_str + } +let mod_filter : + 'uuuuu . + ('uuuuu * FStarC_Interactive_CompletionTable.mod_symbol) -> + ('uuuuu * FStarC_Interactive_CompletionTable.mod_symbol) + FStar_Pervasives_Native.option + = + fun uu___ -> + match uu___ with + | (uu___1, FStarC_Interactive_CompletionTable.Namespace uu___2) -> + FStar_Pervasives_Native.None + | (uu___1, FStarC_Interactive_CompletionTable.Module + { FStarC_Interactive_CompletionTable.mod_name = uu___2; + FStarC_Interactive_CompletionTable.mod_path = uu___3; + FStarC_Interactive_CompletionTable.mod_loaded = true;_}) + -> FStar_Pervasives_Native.None + | (pth, FStarC_Interactive_CompletionTable.Module md) -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Interactive_CompletionTable.mod_name md in + Prims.strcat uu___5 "." in + { + FStarC_Interactive_CompletionTable.mod_name = uu___4; + FStarC_Interactive_CompletionTable.mod_path = + (md.FStarC_Interactive_CompletionTable.mod_path); + FStarC_Interactive_CompletionTable.mod_loaded = + (md.FStarC_Interactive_CompletionTable.mod_loaded) + } in + FStarC_Interactive_CompletionTable.Module uu___3 in + (pth, uu___2) in + FStar_Pervasives_Native.Some uu___1 +let (ck_completion : + FStarC_Interactive_Ide_Types.repl_state -> + Prims.string -> + FStarC_Interactive_CompletionTable.completion_result Prims.list) + = + fun st -> + fun search_term -> + let needle = FStarC_Compiler_Util.split search_term "." in + let mods_and_nss = + FStarC_Interactive_CompletionTable.autocomplete_mod_or_ns + st.FStarC_Interactive_Ide_Types.repl_names needle mod_filter in + let lids = + FStarC_Interactive_CompletionTable.autocomplete_lid + st.FStarC_Interactive_Ide_Types.repl_names needle in + FStarC_Compiler_List.op_At lids mods_and_nss +let (deflookup : + FStarC_TypeChecker_Env.env -> + FStarC_Interactive_JsonHelper.txdoc_pos -> + FStarC_Interactive_JsonHelper.assoct FStar_Pervasives_Native.option) + = + fun env -> + fun pos -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Interactive_JsonHelper.pos_munge pos in + FStar_Pervasives_Native.Some uu___2 in + symlookup env "" uu___1 ["defined-at"] in + match uu___ with + | FStar_Pervasives_Native.Some + { slr_name = uu___1; + slr_def_range = FStar_Pervasives_Native.Some r; slr_typ = uu___2; + slr_doc = uu___3; slr_def = uu___4;_} + -> + let uu___5 = FStarC_Interactive_JsonHelper.js_loclink r in + FStarC_Interactive_JsonHelper.resultResponse uu___5 + | uu___1 -> FStarC_Interactive_JsonHelper.nullResponse +let (hoverlookup : + FStarC_TypeChecker_Env.env -> + FStarC_Interactive_JsonHelper.txdoc_pos -> + FStarC_Interactive_JsonHelper.assoct FStar_Pervasives_Native.option) + = + fun env -> + fun pos -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Interactive_JsonHelper.pos_munge pos in + FStar_Pervasives_Native.Some uu___2 in + symlookup env "" uu___1 ["type"; "definition"] in + match uu___ with + | FStar_Pervasives_Native.Some + { slr_name = n; slr_def_range = uu___1; + slr_typ = FStar_Pervasives_Native.Some t; slr_doc = uu___2; + slr_def = FStar_Pervasives_Native.Some d;_} + -> + let hovertxt = + FStarC_Compiler_Util.format2 + "```fstar\n%s\n````\n---\n```fstar\n%s\n```" t d in + FStarC_Interactive_JsonHelper.resultResponse + (FStarC_Json.JsonAssoc + [("contents", + (FStarC_Json.JsonAssoc + [("kind", (FStarC_Json.JsonStr "markdown")); + ("value", (FStarC_Json.JsonStr hovertxt))]))]) + | uu___1 -> FStarC_Interactive_JsonHelper.nullResponse +let (complookup : + FStarC_Interactive_Ide_Types.repl_state -> + FStarC_Interactive_JsonHelper.txdoc_pos -> + FStarC_Interactive_JsonHelper.assoct FStar_Pervasives_Native.option) + = + fun st -> + fun pos -> + let uu___ = FStarC_Interactive_JsonHelper.pos_munge pos in + match uu___ with + | (file, row, current_col) -> + let uu___1 = FStarC_Parser_ParseIt.read_vfs_entry file in + (match uu___1 with + | FStar_Pervasives_Native.Some (uu___2, text) -> + let rec find_col l = + match l with + | [] -> Prims.int_zero + | h::t -> + if + (h = 32) && + ((FStarC_Compiler_List.length t) < current_col) + then (FStarC_Compiler_List.length t) + Prims.int_one + else find_col t in + let str = + FStarC_Compiler_List.nth + (FStarC_Compiler_Util.splitlines text) + (row - Prims.int_one) in + let explode s = + let rec exp i l = + if i < Prims.int_zero + then l + else + (let uu___4 = + let uu___5 = FStarC_Compiler_String.get s i in uu___5 + :: l in + exp (i - Prims.int_one) uu___4) in + exp ((FStarC_Compiler_String.length s) - Prims.int_one) [] in + let begin_col = + let uu___3 = + let uu___4 = explode str in + FStarC_Compiler_List.rev uu___4 in + find_col uu___3 in + let term = + FStarC_Compiler_Util.substring str begin_col + (current_col - begin_col) in + let items = ck_completion st term in + let l = + FStarC_Compiler_List.map + (fun r -> + FStarC_Json.JsonAssoc + [("label", + (FStarC_Json.JsonStr + (r.FStarC_Interactive_CompletionTable.completion_candidate)))]) + items in + FStarC_Interactive_JsonHelper.resultResponse + (FStarC_Json.JsonList l)) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Main.ml b/ocaml/fstar-lib/generated/FStarC_Main.ml new file mode 100644 index 00000000000..3950fdeb9b0 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Main.ml @@ -0,0 +1,613 @@ +open Prims +let (uu___0 : unit) = FStarC_Version.dummy () +let (process_args : + unit -> (FStarC_Getopt.parse_cmdline_res * Prims.string Prims.list)) = + fun uu___ -> FStarC_Options.parse_cmd_line () +let (cleanup : unit -> unit) = fun uu___ -> FStarC_Compiler_Util.kill_all () +let (finished_message : + (Prims.bool * FStarC_Ident.lident) Prims.list -> Prims.int -> unit) = + fun fmods -> + fun errs -> + let print_to = + if errs > Prims.int_zero + then FStarC_Compiler_Util.print_error + else FStarC_Compiler_Util.print_string in + let uu___ = + let uu___1 = FStarC_Options.silent () in Prims.op_Negation uu___1 in + if uu___ + then + (FStarC_Compiler_List.iter + (fun uu___2 -> + match uu___2 with + | (iface, name) -> + let tag = + if iface then "i'face (or impl+i'face)" else "module" in + let uu___3 = + let uu___4 = FStarC_Ident.string_of_lid name in + FStarC_Options.should_print_message uu___4 in + if uu___3 + then + let uu___4 = + let uu___5 = FStarC_Ident.string_of_lid name in + FStarC_Compiler_Util.format2 "Verified %s: %s\n" tag + uu___5 in + print_to uu___4 + else ()) fmods; + if errs > Prims.int_zero + then + (if errs = Prims.int_one + then + FStarC_Compiler_Util.print_error + "1 error was reported (see above)\n" + else + (let uu___3 = FStarC_Compiler_Util.string_of_int errs in + FStarC_Compiler_Util.print1_error + "%s errors were reported (see above)\n" uu___3)) + else + (let uu___3 = + FStarC_Compiler_Util.colorize_bold + "All verification conditions discharged successfully" in + FStarC_Compiler_Util.print1 "%s\n" uu___3)) + else () +let (report_errors : (Prims.bool * FStarC_Ident.lident) Prims.list -> unit) = + fun fmods -> + (let uu___1 = FStarC_Errors.report_all () in ()); + (let nerrs = FStarC_Errors.get_err_count () in + if nerrs > Prims.int_zero + then + (finished_message fmods nerrs; + FStarC_Compiler_Effect.exit Prims.int_one) + else ()) +let (load_native_tactics : unit -> unit) = + fun uu___ -> + let modules_to_load = + let uu___1 = FStarC_Options.load () in + FStarC_Compiler_List.map FStarC_Ident.lid_of_str uu___1 in + let cmxs_to_load = + let uu___1 = FStarC_Options.load_cmxs () in + FStarC_Compiler_List.map FStarC_Ident.lid_of_str uu___1 in + let ml_module_name m = FStarC_Extraction_ML_Util.ml_module_name_of_lid m in + let ml_file m = + let uu___1 = ml_module_name m in Prims.strcat uu___1 ".ml" in + let cmxs_file m = + let cmxs = let uu___1 = ml_module_name m in Prims.strcat uu___1 ".cmxs" in + let uu___1 = FStarC_Find.find_file cmxs in + match uu___1 with + | FStar_Pervasives_Native.Some f -> f + | FStar_Pervasives_Native.None -> + if FStarC_Compiler_List.contains m cmxs_to_load + then + let uu___2 = + FStarC_Compiler_Util.format1 "Could not find %s to load" cmxs in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_FailToCompileNativeTactic () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2) + else + (let uu___3 = + let uu___4 = ml_file m in FStarC_Find.find_file uu___4 in + match uu___3 with + | FStar_Pervasives_Native.None -> + let uu___4 = + let uu___5 = ml_file m in + FStarC_Compiler_Util.format1 + "Failed to compile native tactic; extracted module %s not found" + uu___5 in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_FailToCompileNativeTactic () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4) + | FStar_Pervasives_Native.Some ml -> + let dir = FStarC_Compiler_Util.dirname ml in + ((let uu___5 = let uu___6 = ml_module_name m in [uu___6] in + FStarC_Compiler_Plugins.compile_modules dir uu___5); + (let uu___5 = FStarC_Find.find_file cmxs in + match uu___5 with + | FStar_Pervasives_Native.None -> + let uu___6 = + FStarC_Compiler_Util.format1 + "Failed to compile native tactic; compiled object %s not found" + cmxs in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_FailToCompileNativeTactic + () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___6) + | FStar_Pervasives_Native.Some f -> f))) in + let cmxs_files = + FStarC_Compiler_List.map cmxs_file + (FStarC_Compiler_List.op_At modules_to_load cmxs_to_load) in + (let uu___2 = FStarC_Compiler_Debug.any () in + if uu___2 + then + FStarC_Compiler_Util.print1 "Will try to load cmxs files: [%s]\n" + (FStarC_Compiler_String.concat ", " cmxs_files) + else ()); + FStarC_Compiler_Plugins.load_plugins cmxs_files; + (let uu___4 = FStarC_Options.use_native_tactics () in + FStarC_Compiler_Util.iter_opt uu___4 + FStarC_Compiler_Plugins.load_plugins_dir) +let (fstar_files : + Prims.string Prims.list FStar_Pervasives_Native.option + FStarC_Compiler_Effect.ref) + = FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None +let go : 'uuuuu . 'uuuuu -> unit = + fun uu___ -> + let uu___1 = process_args () in + match uu___1 with + | (res, filenames) -> + ((let uu___3 = FStarC_Options.trace_error () in + if uu___3 + then + let h = FStarC_Compiler_Util.get_sigint_handler () in + let h' s = + FStarC_Compiler_Debug.enable (); + FStarC_Options.set_option "error_contexts" + (FStarC_Options.Bool true); + (let uu___7 = + let uu___8 = FStarC_Errors_Msg.text "GOT SIGINT! Exiting" in + [uu___8] in + FStarC_Errors.diag FStarC_Class_HasRange.hasRange_range + FStarC_Compiler_Range_Type.dummyRange () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___7)); + FStarC_Compiler_Effect.exit Prims.int_one in + let uu___4 = FStarC_Compiler_Util.sigint_handler_f h' in + FStarC_Compiler_Util.set_sigint_handler uu___4 + else ()); + (match res with + | FStarC_Getopt.Empty -> + (FStarC_Options.display_usage (); + FStarC_Compiler_Effect.exit Prims.int_one) + | FStarC_Getopt.Help -> + (FStarC_Options.display_usage (); + FStarC_Compiler_Effect.exit Prims.int_zero) + | FStarC_Getopt.Error msg -> + (FStarC_Compiler_Util.print_error msg; + FStarC_Compiler_Effect.exit Prims.int_one) + | uu___3 when FStarC_Options.print_cache_version () -> + ((let uu___5 = + FStarC_Compiler_Util.string_of_int + FStarC_CheckedFiles.cache_version_number in + FStarC_Compiler_Util.print1 "F* cache version number: %s\n" + uu___5); + FStarC_Compiler_Effect.exit Prims.int_zero) + | FStarC_Getopt.Success -> + (FStarC_Compiler_Effect.op_Colon_Equals fstar_files + (FStar_Pervasives_Native.Some filenames); + (let uu___5 = FStarC_Compiler_Debug.any () in + if uu___5 + then + (FStarC_Compiler_Util.print1 "- F* executable: %s\n" + FStarC_Compiler_Util.exec_name; + FStarC_Compiler_Util.print1 "- F* exec dir: %s\n" + FStarC_Options.fstar_bin_directory; + (let uu___9 = + let uu___10 = FStarC_Options.lib_root () in + FStarC_Compiler_Util.dflt "" uu___10 in + FStarC_Compiler_Util.print1 "- Library root: %s\n" uu___9); + (let uu___10 = + let uu___11 = FStarC_Options.include_path () in + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_string)) + uu___11 in + FStarC_Compiler_Util.print1 "- Full include path: %s\n" + uu___10); + FStarC_Compiler_Util.print_string "\n") + else ()); + load_native_tactics (); + FStarC_Syntax_Unionfind.set_ro (); + (let uu___7 = + let uu___8 = FStarC_Options.dep () in + uu___8 <> FStar_Pervasives_Native.None in + if uu___7 + then + let uu___8 = + FStarC_Parser_Dep.collect filenames + FStarC_CheckedFiles.load_parsing_data_from_cache in + match uu___8 with + | (uu___9, deps) -> + (FStarC_Parser_Dep.print deps; report_errors []) + else + (let uu___9 = + (FStarC_Options.print ()) || + (FStarC_Options.print_in_place ()) in + if uu___9 + then + (if FStarC_Platform.is_fstar_compiler_using_ocaml + then + let printing_mode = + let uu___10 = FStarC_Options.print () in + if uu___10 + then FStarC_Prettyprint.FromTempToStdout + else FStarC_Prettyprint.FromTempToFile in + FStarC_Prettyprint.generate printing_mode filenames + else + failwith + "You seem to be using the F#-generated version ofthe compiler ; \\o\n reindenting is not known to work yet with this version") + else + (let uu___11 = + let uu___12 = FStarC_Options.read_checked_file () in + FStar_Pervasives_Native.uu___is_Some uu___12 in + if uu___11 + then + let path = + let uu___12 = FStarC_Options.read_checked_file () in + FStar_Pervasives_Native.__proj__Some__item__v + uu___12 in + let env = + FStarC_Universal.init_env + FStarC_Parser_Dep.empty_deps in + let res1 = FStarC_CheckedFiles.load_tc_result path in + match res1 with + | FStar_Pervasives_Native.None -> + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_Errors_Msg.text + "Could not read checked file:" in + let uu___15 = + FStarC_Pprint.doc_of_string path in + FStarC_Pprint.op_Hat_Slash_Hat uu___14 + uu___15 in + [uu___13] in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_ModuleOrFileNotFound + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___12) + | FStar_Pervasives_Native.Some (uu___12, tcr) -> + let uu___13 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_modul + tcr.FStarC_CheckedFiles.checked_module in + FStarC_Compiler_Util.print1 "%s\n" uu___13 + else + (let uu___13 = FStarC_Options.list_plugins () in + if uu___13 + then + let ps = FStarC_TypeChecker_Cfg.list_plugins () in + let ts = + FStarC_Tactics_Interpreter.native_tactics_steps + () in + ((let uu___15 = + let uu___16 = + FStarC_Compiler_List.map + (fun p -> + let uu___17 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + p.FStarC_TypeChecker_Primops_Base.name in + Prims.strcat " " uu___17) ps in + FStarC_Compiler_String.concat "\n" uu___16 in + FStarC_Compiler_Util.print1 + "Registered plugins:\n%s\n" uu___15); + (let uu___16 = + let uu___17 = + FStarC_Compiler_List.map + (fun p -> + let uu___18 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + p.FStarC_TypeChecker_Primops_Base.name in + Prims.strcat " " uu___18) ts in + FStarC_Compiler_String.concat "\n" uu___17 in + FStarC_Compiler_Util.print1 + "Registered tactic plugins:\n%s\n" uu___16)) + else + (let uu___15 = FStarC_Options.locate () in + if uu___15 + then + ((let uu___17 = + let uu___18 = + FStarC_Compiler_Util.get_exec_dir () in + FStarC_Compiler_Util.normalize_file_path + uu___18 in + FStarC_Compiler_Util.print1 "%s\n" uu___17); + FStarC_Compiler_Effect.exit Prims.int_zero) + else + (let uu___17 = FStarC_Options.locate_lib () in + if uu___17 + then + let uu___18 = FStarC_Options.lib_root () in + match uu___18 with + | FStar_Pervasives_Native.None -> + (FStarC_Compiler_Util.print_error + "No library found (is --no_default_includes set?)\n"; + FStarC_Compiler_Effect.exit + Prims.int_one) + | FStar_Pervasives_Native.Some s -> + ((let uu___20 = + FStarC_Compiler_Util.normalize_file_path + s in + FStarC_Compiler_Util.print1 "%s\n" + uu___20); + FStarC_Compiler_Effect.exit + Prims.int_zero) + else + (let uu___19 = + FStarC_Options.locate_ocaml () in + if uu___19 + then + ((let uu___21 = + let uu___22 = + let uu___23 = + FStarC_Compiler_Util.get_exec_dir + () in + Prims.strcat uu___23 "/../lib" in + FStarC_Compiler_Util.normalize_file_path + uu___22 in + FStarC_Compiler_Util.print1 "%s\n" + uu___21); + FStarC_Compiler_Effect.exit + Prims.int_zero) + else + (let uu___21 = + let uu___22 = + FStarC_Options.read_krml_file () in + FStar_Pervasives_Native.uu___is_Some + uu___22 in + if uu___21 + then + let path = + let uu___22 = + FStarC_Options.read_krml_file () in + FStar_Pervasives_Native.__proj__Some__item__v + uu___22 in + let uu___22 = + FStarC_Compiler_Util.load_value_from_file + path in + match uu___22 with + | FStar_Pervasives_Native.None -> + let uu___23 = + let uu___24 = + let uu___25 = + FStarC_Errors_Msg.text + "Could not read krml file:" in + let uu___26 = + FStarC_Pprint.doc_of_string + path in + FStarC_Pprint.op_Hat_Slash_Hat + uu___25 uu___26 in + [uu___24] in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_ModuleOrFileNotFound + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___23) + | FStar_Pervasives_Native.Some + (version, files) -> + ((let uu___24 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + version in + FStarC_Compiler_Util.print1 + "Karamel format version: %s\n" + uu___24); + FStarC_Compiler_List.iter + (fun uu___24 -> + match uu___24 with + | (name, decls) -> + (FStarC_Compiler_Util.print1 + "%s:\n" name; + FStarC_Compiler_List.iter + (fun d -> + let uu___26 = + FStarC_Class_Show.show + FStarC_Extraction_Krml.showable_decl + d in + FStarC_Compiler_Util.print1 + " %s\n" uu___26) + decls)) files) + else + (let uu___23 = + FStarC_Options.lsp_server () in + if uu___23 + then + FStarC_Interactive_Lsp.start_server + () + else + (let uu___25 = + FStarC_Options.interactive () in + if uu___25 + then + (FStarC_Syntax_Unionfind.set_rw + (); + (match filenames with + | [] -> + (FStarC_Errors.log_issue0 + FStarC_Errors_Codes.Error_MissingFileName + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "--ide: Name of current file missing in command line invocation\n"); + FStarC_Compiler_Effect.exit + Prims.int_one) + | uu___27::uu___28::uu___29 -> + (FStarC_Errors.log_issue0 + FStarC_Errors_Codes.Error_TooManyFiles + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "--ide: Too many files in command line invocation\n"); + FStarC_Compiler_Effect.exit + Prims.int_one) + | filename::[] -> + let uu___27 = + FStarC_Options.legacy_interactive + () in + if uu___27 + then + FStarC_Interactive_Legacy.interactive_mode + filename + else + FStarC_Interactive_Ide.interactive_mode + filename)) + else + if + (FStarC_Compiler_List.length + filenames) + >= Prims.int_one + then + (let uu___27 = + FStarC_Dependencies.find_deps_if_needed + filenames + FStarC_CheckedFiles.load_parsing_data_from_cache in + match uu___27 with + | (filenames1, dep_graph) -> + let uu___28 = + FStarC_Universal.batch_mode_tc + filenames1 dep_graph in + (match uu___28 with + | (tcrs, env, cleanup1) + -> + ((let uu___30 = + cleanup1 env in + ()); + (let module_names = + FStarC_Compiler_List.map + (fun tcr -> + FStarC_Universal.module_or_interface_name + tcr.FStarC_CheckedFiles.checked_module) + tcrs in + report_errors + module_names; + finished_message + module_names + Prims.int_zero)))) + else + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Error_MissingFileName + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "No file provided")))))))))))))) +let (lazy_chooser : + FStarC_Syntax_Syntax.lazy_kind -> + FStarC_Syntax_Syntax.lazyinfo -> FStarC_Syntax_Syntax.term) + = + fun k -> + fun i -> + match k with + | FStarC_Syntax_Syntax.BadLazy -> + failwith "lazy chooser: got a BadLazy" + | FStarC_Syntax_Syntax.Lazy_bv -> + FStarC_Reflection_V2_Embeddings.unfold_lazy_bv i + | FStarC_Syntax_Syntax.Lazy_namedv -> + FStarC_Reflection_V2_Embeddings.unfold_lazy_namedv i + | FStarC_Syntax_Syntax.Lazy_binder -> + FStarC_Reflection_V2_Embeddings.unfold_lazy_binder i + | FStarC_Syntax_Syntax.Lazy_letbinding -> + FStarC_Reflection_V2_Embeddings.unfold_lazy_letbinding i + | FStarC_Syntax_Syntax.Lazy_optionstate -> + FStarC_Reflection_V2_Embeddings.unfold_lazy_optionstate i + | FStarC_Syntax_Syntax.Lazy_fvar -> + FStarC_Reflection_V2_Embeddings.unfold_lazy_fvar i + | FStarC_Syntax_Syntax.Lazy_comp -> + FStarC_Reflection_V2_Embeddings.unfold_lazy_comp i + | FStarC_Syntax_Syntax.Lazy_env -> + FStarC_Reflection_V2_Embeddings.unfold_lazy_env i + | FStarC_Syntax_Syntax.Lazy_sigelt -> + FStarC_Reflection_V2_Embeddings.unfold_lazy_sigelt i + | FStarC_Syntax_Syntax.Lazy_universe -> + FStarC_Reflection_V2_Embeddings.unfold_lazy_universe i + | FStarC_Syntax_Syntax.Lazy_proofstate -> + FStarC_Tactics_Embedding.unfold_lazy_proofstate i + | FStarC_Syntax_Syntax.Lazy_goal -> + FStarC_Tactics_Embedding.unfold_lazy_goal i + | FStarC_Syntax_Syntax.Lazy_doc -> + FStarC_Reflection_V2_Embeddings.unfold_lazy_doc i + | FStarC_Syntax_Syntax.Lazy_uvar -> + FStarC_Syntax_Util.exp_string "((uvar))" + | FStarC_Syntax_Syntax.Lazy_universe_uvar -> + FStarC_Syntax_Util.exp_string "((universe_uvar))" + | FStarC_Syntax_Syntax.Lazy_issue -> + FStarC_Syntax_Util.exp_string "((issue))" + | FStarC_Syntax_Syntax.Lazy_ident -> + FStarC_Syntax_Util.exp_string "((ident))" + | FStarC_Syntax_Syntax.Lazy_tref -> + FStarC_Syntax_Util.exp_string "((tref))" + | FStarC_Syntax_Syntax.Lazy_embedding (uu___, t) -> + FStarC_Thunk.force t + | FStarC_Syntax_Syntax.Lazy_extension s -> + let uu___ = FStarC_Compiler_Util.format1 "((extension %s))" s in + FStarC_Syntax_Util.exp_string uu___ +let (setup_hooks : unit -> unit) = + fun uu___ -> + FStarC_Compiler_Effect.op_Colon_Equals + FStarC_Syntax_DsEnv.ugly_sigelt_to_string_hook + (FStarC_Class_Show.show FStarC_Syntax_Print.showable_sigelt); + FStarC_Errors.set_parse_warn_error FStarC_Parser_ParseIt.parse_warn_error; + FStarC_Compiler_Effect.op_Colon_Equals FStarC_Syntax_Syntax.lazy_chooser + (FStar_Pervasives_Native.Some lazy_chooser); + FStarC_Compiler_Effect.op_Colon_Equals FStarC_Syntax_Util.tts_f + (FStar_Pervasives_Native.Some + (FStarC_Class_Show.show FStarC_Syntax_Print.showable_term)); + FStarC_Compiler_Effect.op_Colon_Equals FStarC_Syntax_Util.ttd_f + (FStar_Pervasives_Native.Some + (FStarC_Class_PP.pp FStarC_Syntax_Print.pretty_term)); + FStarC_Compiler_Effect.op_Colon_Equals + FStarC_TypeChecker_Normalize.unembed_binder_knot + (FStar_Pervasives_Native.Some FStarC_Reflection_V2_Embeddings.e_binder); + FStarC_Compiler_List.iter + FStarC_Tactics_Interpreter.register_tactic_primitive_step + FStarC_Tactics_V1_Primops.ops; + FStarC_Compiler_List.iter + FStarC_Tactics_Interpreter.register_tactic_primitive_step + FStarC_Tactics_V2_Primops.ops +let (handle_error : Prims.exn -> unit) = + fun e -> + (let uu___1 = FStarC_Errors.handleable e in + if uu___1 then FStarC_Errors.err_exn e else ()); + (let uu___2 = FStarC_Options.trace_error () in + if uu___2 + then + let uu___3 = FStarC_Compiler_Util.message_of_exn e in + let uu___4 = FStarC_Compiler_Util.trace_of_exn e in + FStarC_Compiler_Util.print2_error "Unexpected error\n%s\n%s\n" uu___3 + uu___4 + else + (let uu___4 = + let uu___5 = FStarC_Errors.handleable e in Prims.op_Negation uu___5 in + if uu___4 + then + let uu___5 = FStarC_Compiler_Util.message_of_exn e in + FStarC_Compiler_Util.print1_error + "Unexpected error; please file a bug report, ideally with a minimized version of the source program that triggered the error.\n%s\n" + uu___5 + else ())); + cleanup (); + report_errors [] +let main : 'uuuuu . unit -> 'uuuuu = + fun uu___ -> + try + (fun uu___1 -> + match () with + | () -> + (setup_hooks (); + (let uu___3 = FStarC_Compiler_Util.record_time go in + match uu___3 with + | (uu___4, time) -> + ((let uu___6 = FStarC_Options.query_stats () in + if uu___6 + then + let uu___7 = FStarC_Compiler_Util.string_of_int time in + let uu___8 = + let uu___9 = FStarC_Getopt.cmdline () in + FStarC_Compiler_String.concat " " uu___9 in + FStarC_Compiler_Util.print2_error + "TOTAL TIME %s ms: %s\n" uu___7 uu___8 + else ()); + cleanup (); + FStarC_Compiler_Effect.exit Prims.int_zero)))) () + with + | uu___1 -> + (handle_error uu___1; FStarC_Compiler_Effect.exit Prims.int_one) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Options.ml b/ocaml/fstar-lib/generated/FStarC_Options.ml new file mode 100644 index 00000000000..f37ffcc1b50 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Options.ml @@ -0,0 +1,5089 @@ +open Prims +type codegen_t = + | OCaml + | FSharp + | Krml + | Plugin + | Extension +let (uu___is_OCaml : codegen_t -> Prims.bool) = + fun projectee -> match projectee with | OCaml -> true | uu___ -> false +let (uu___is_FSharp : codegen_t -> Prims.bool) = + fun projectee -> match projectee with | FSharp -> true | uu___ -> false +let (uu___is_Krml : codegen_t -> Prims.bool) = + fun projectee -> match projectee with | Krml -> true | uu___ -> false +let (uu___is_Plugin : codegen_t -> Prims.bool) = + fun projectee -> match projectee with | Plugin -> true | uu___ -> false +let (uu___is_Extension : codegen_t -> Prims.bool) = + fun projectee -> match projectee with | Extension -> true | uu___ -> false +type split_queries_t = + | No + | OnFailure + | Always +let (uu___is_No : split_queries_t -> Prims.bool) = + fun projectee -> match projectee with | No -> true | uu___ -> false +let (uu___is_OnFailure : split_queries_t -> Prims.bool) = + fun projectee -> match projectee with | OnFailure -> true | uu___ -> false +let (uu___is_Always : split_queries_t -> Prims.bool) = + fun projectee -> match projectee with | Always -> true | uu___ -> false +type message_format_t = + | Json + | Human +let (uu___is_Json : message_format_t -> Prims.bool) = + fun projectee -> match projectee with | Json -> true | uu___ -> false +let (uu___is_Human : message_format_t -> Prims.bool) = + fun projectee -> match projectee with | Human -> true | uu___ -> false +type option_val = + | Bool of Prims.bool + | String of Prims.string + | Path of Prims.string + | Int of Prims.int + | List of option_val Prims.list + | Unset +let (uu___is_Bool : option_val -> Prims.bool) = + fun projectee -> match projectee with | Bool _0 -> true | uu___ -> false +let (__proj__Bool__item___0 : option_val -> Prims.bool) = + fun projectee -> match projectee with | Bool _0 -> _0 +let (uu___is_String : option_val -> Prims.bool) = + fun projectee -> match projectee with | String _0 -> true | uu___ -> false +let (__proj__String__item___0 : option_val -> Prims.string) = + fun projectee -> match projectee with | String _0 -> _0 +let (uu___is_Path : option_val -> Prims.bool) = + fun projectee -> match projectee with | Path _0 -> true | uu___ -> false +let (__proj__Path__item___0 : option_val -> Prims.string) = + fun projectee -> match projectee with | Path _0 -> _0 +let (uu___is_Int : option_val -> Prims.bool) = + fun projectee -> match projectee with | Int _0 -> true | uu___ -> false +let (__proj__Int__item___0 : option_val -> Prims.int) = + fun projectee -> match projectee with | Int _0 -> _0 +let (uu___is_List : option_val -> Prims.bool) = + fun projectee -> match projectee with | List _0 -> true | uu___ -> false +let (__proj__List__item___0 : option_val -> option_val Prims.list) = + fun projectee -> match projectee with | List _0 -> _0 +let (uu___is_Unset : option_val -> Prims.bool) = + fun projectee -> match projectee with | Unset -> true | uu___ -> false +type optionstate = option_val FStarC_Compiler_Util.psmap +type opt_type = + | Const of option_val + | IntStr of Prims.string + | BoolStr + | PathStr of Prims.string + | SimpleStr of Prims.string + | EnumStr of Prims.string Prims.list + | OpenEnumStr of (Prims.string Prims.list * Prims.string) + | PostProcessed of ((option_val -> option_val) * opt_type) + | Accumulated of opt_type + | ReverseAccumulated of opt_type + | WithSideEffect of ((unit -> unit) * opt_type) +let (uu___is_Const : opt_type -> Prims.bool) = + fun projectee -> match projectee with | Const _0 -> true | uu___ -> false +let (__proj__Const__item___0 : opt_type -> option_val) = + fun projectee -> match projectee with | Const _0 -> _0 +let (uu___is_IntStr : opt_type -> Prims.bool) = + fun projectee -> match projectee with | IntStr _0 -> true | uu___ -> false +let (__proj__IntStr__item___0 : opt_type -> Prims.string) = + fun projectee -> match projectee with | IntStr _0 -> _0 +let (uu___is_BoolStr : opt_type -> Prims.bool) = + fun projectee -> match projectee with | BoolStr -> true | uu___ -> false +let (uu___is_PathStr : opt_type -> Prims.bool) = + fun projectee -> match projectee with | PathStr _0 -> true | uu___ -> false +let (__proj__PathStr__item___0 : opt_type -> Prims.string) = + fun projectee -> match projectee with | PathStr _0 -> _0 +let (uu___is_SimpleStr : opt_type -> Prims.bool) = + fun projectee -> + match projectee with | SimpleStr _0 -> true | uu___ -> false +let (__proj__SimpleStr__item___0 : opt_type -> Prims.string) = + fun projectee -> match projectee with | SimpleStr _0 -> _0 +let (uu___is_EnumStr : opt_type -> Prims.bool) = + fun projectee -> match projectee with | EnumStr _0 -> true | uu___ -> false +let (__proj__EnumStr__item___0 : opt_type -> Prims.string Prims.list) = + fun projectee -> match projectee with | EnumStr _0 -> _0 +let (uu___is_OpenEnumStr : opt_type -> Prims.bool) = + fun projectee -> + match projectee with | OpenEnumStr _0 -> true | uu___ -> false +let (__proj__OpenEnumStr__item___0 : + opt_type -> (Prims.string Prims.list * Prims.string)) = + fun projectee -> match projectee with | OpenEnumStr _0 -> _0 +let (uu___is_PostProcessed : opt_type -> Prims.bool) = + fun projectee -> + match projectee with | PostProcessed _0 -> true | uu___ -> false +let (__proj__PostProcessed__item___0 : + opt_type -> ((option_val -> option_val) * opt_type)) = + fun projectee -> match projectee with | PostProcessed _0 -> _0 +let (uu___is_Accumulated : opt_type -> Prims.bool) = + fun projectee -> + match projectee with | Accumulated _0 -> true | uu___ -> false +let (__proj__Accumulated__item___0 : opt_type -> opt_type) = + fun projectee -> match projectee with | Accumulated _0 -> _0 +let (uu___is_ReverseAccumulated : opt_type -> Prims.bool) = + fun projectee -> + match projectee with | ReverseAccumulated _0 -> true | uu___ -> false +let (__proj__ReverseAccumulated__item___0 : opt_type -> opt_type) = + fun projectee -> match projectee with | ReverseAccumulated _0 -> _0 +let (uu___is_WithSideEffect : opt_type -> Prims.bool) = + fun projectee -> + match projectee with | WithSideEffect _0 -> true | uu___ -> false +let (__proj__WithSideEffect__item___0 : + opt_type -> ((unit -> unit) * opt_type)) = + fun projectee -> match projectee with | WithSideEffect _0 -> _0 +let (debug_embedding : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref false +let (eager_embedding : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref false +let (__unit_tests__ : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref false +let (__unit_tests : unit -> Prims.bool) = + fun uu___ -> FStarC_Compiler_Effect.op_Bang __unit_tests__ +let (__set_unit_tests : unit -> unit) = + fun uu___ -> FStarC_Compiler_Effect.op_Colon_Equals __unit_tests__ true +let (__clear_unit_tests : unit -> unit) = + fun uu___ -> FStarC_Compiler_Effect.op_Colon_Equals __unit_tests__ false +let (as_bool : option_val -> Prims.bool) = + fun uu___ -> + match uu___ with + | Bool b -> b + | uu___1 -> failwith "Impos: expected Bool" +let (as_int : option_val -> Prims.int) = + fun uu___ -> + match uu___ with | Int b -> b | uu___1 -> failwith "Impos: expected Int" +let (as_string : option_val -> Prims.string) = + fun uu___ -> + match uu___ with + | String b -> b + | Path b -> FStarC_Common.try_convert_file_name_to_mixed b + | uu___1 -> failwith "Impos: expected String" +let (as_list' : option_val -> option_val Prims.list) = + fun uu___ -> + match uu___ with + | List ts -> ts + | uu___1 -> failwith "Impos: expected List" +let as_list : + 'uuuuu . (option_val -> 'uuuuu) -> option_val -> 'uuuuu Prims.list = + fun as_t -> + fun x -> let uu___ = as_list' x in FStarC_Compiler_List.map as_t uu___ +let as_option : + 'uuuuu . + (option_val -> 'uuuuu) -> + option_val -> 'uuuuu FStar_Pervasives_Native.option + = + fun as_t -> + fun uu___ -> + match uu___ with + | Unset -> FStar_Pervasives_Native.None + | v -> let uu___1 = as_t v in FStar_Pervasives_Native.Some uu___1 +let (as_comma_string_list : option_val -> Prims.string Prims.list) = + fun uu___ -> + match uu___ with + | List ls -> + let uu___1 = + FStarC_Compiler_List.map + (fun l -> + let uu___2 = as_string l in + FStarC_Compiler_Util.split uu___2 ",") ls in + FStarC_Compiler_List.flatten uu___1 + | uu___1 -> failwith "Impos: expected String (comma list)" +let copy_optionstate : + 'uuuuu . + 'uuuuu FStarC_Compiler_Util.smap -> 'uuuuu FStarC_Compiler_Util.smap + = fun m -> FStarC_Compiler_Util.smap_copy m +type history1 = + (FStarC_Compiler_Debug.saved_state * FStarC_Options_Ext.ext_state * + optionstate) +let (fstar_options : optionstate FStarC_Compiler_Effect.ref) = + let uu___ = FStarC_Compiler_Util.psmap_empty () in + FStarC_Compiler_Util.mk_ref uu___ +let (history : history1 Prims.list Prims.list FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref [] +let (peek : unit -> optionstate) = + fun uu___ -> FStarC_Compiler_Effect.op_Bang fstar_options +let (internal_push : unit -> unit) = + fun uu___ -> + let uu___1 = FStarC_Compiler_Effect.op_Bang history in + match uu___1 with + | lev1::rest -> + let newhd = + let uu___2 = FStarC_Compiler_Debug.snapshot () in + let uu___3 = FStarC_Options_Ext.save () in + let uu___4 = FStarC_Compiler_Effect.op_Bang fstar_options in + (uu___2, uu___3, uu___4) in + FStarC_Compiler_Effect.op_Colon_Equals history ((newhd :: lev1) :: + rest) +let (internal_pop : unit -> Prims.bool) = + fun uu___ -> + let uu___1 = FStarC_Compiler_Effect.op_Bang history in + match uu___1 with + | lev1::rest -> + (match lev1 with + | [] -> false + | (dbg, ext, opts)::lev1' -> + (FStarC_Compiler_Debug.restore dbg; + FStarC_Options_Ext.restore ext; + FStarC_Compiler_Effect.op_Colon_Equals fstar_options opts; + FStarC_Compiler_Effect.op_Colon_Equals history (lev1' :: rest); + true)) +let (push : unit -> unit) = + fun uu___ -> + internal_push (); + (let uu___2 = FStarC_Compiler_Effect.op_Bang history in + match uu___2 with + | lev1::uu___3 -> + ((let uu___5 = + let uu___6 = FStarC_Compiler_Effect.op_Bang history in lev1 :: + uu___6 in + FStarC_Compiler_Effect.op_Colon_Equals history uu___5); + (let uu___6 = internal_pop () in ()))) +let (pop : unit -> unit) = + fun uu___ -> + let uu___1 = FStarC_Compiler_Effect.op_Bang history in + match uu___1 with + | [] -> failwith "TOO MANY POPS!" + | uu___2::levs -> + (FStarC_Compiler_Effect.op_Colon_Equals history levs; + (let uu___4 = + let uu___5 = internal_pop () in Prims.op_Negation uu___5 in + if uu___4 then failwith "aaa!!!" else ())) +let (set : optionstate -> unit) = + fun o -> FStarC_Compiler_Effect.op_Colon_Equals fstar_options o +let (depth : unit -> Prims.int) = + fun uu___ -> + let uu___1 = FStarC_Compiler_Effect.op_Bang history in + match uu___1 with | lev::uu___2 -> FStarC_Compiler_List.length lev +let (snapshot : unit -> (Prims.int * unit)) = + fun uu___ -> FStarC_Common.snapshot push history () +let (rollback : Prims.int FStar_Pervasives_Native.option -> unit) = + fun depth1 -> FStarC_Common.rollback pop history depth1 +let (set_option : Prims.string -> option_val -> unit) = + fun k -> + fun v -> + let map = peek () in + if k = "report_assumes" + then + let uu___ = FStarC_Compiler_Util.psmap_try_find map k in + match uu___ with + | FStar_Pervasives_Native.Some (String "error") -> () + | uu___1 -> + let uu___2 = FStarC_Compiler_Util.psmap_add map k v in + FStarC_Compiler_Effect.op_Colon_Equals fstar_options uu___2 + else + (let uu___1 = FStarC_Compiler_Util.psmap_add map k v in + FStarC_Compiler_Effect.op_Colon_Equals fstar_options uu___1) +let (set_option' : (Prims.string * option_val) -> unit) = + fun uu___ -> match uu___ with | (k, v) -> set_option k v +let (set_admit_smt_queries : Prims.bool -> unit) = + fun b -> set_option "admit_smt_queries" (Bool b) +let (defaults : (Prims.string * option_val) Prims.list) = + [("abort_on", (Int Prims.int_zero)); + ("admit_smt_queries", (Bool false)); + ("admit_except", Unset); + ("disallow_unification_guards", (Bool false)); + ("already_cached", Unset); + ("cache_checked_modules", (Bool false)); + ("cache_dir", Unset); + ("cache_off", (Bool false)); + ("compat_pre_core", Unset); + ("compat_pre_typed_indexed_effects", (Bool false)); + ("print_cache_version", (Bool false)); + ("cmi", (Bool false)); + ("codegen", Unset); + ("codegen-lib", (List [])); + ("defensive", (String "no")); + ("debug", (List [])); + ("debug_all", (Bool false)); + ("debug_all_modules", (Bool false)); + ("dep", Unset); + ("detail_errors", (Bool false)); + ("detail_hint_replay", (Bool false)); + ("dump_module", (List [])); + ("eager_subtyping", (Bool false)); + ("error_contexts", (Bool false)); + ("expose_interfaces", (Bool false)); + ("message_format", (String "human")); + ("ext", Unset); + ("extract", Unset); + ("extract_all", (Bool false)); + ("extract_module", (List [])); + ("extract_namespace", (List [])); + ("full_context_dependency", (Bool true)); + ("hide_uvar_nums", (Bool false)); + ("hint_hook", Unset); + ("hint_info", (Bool false)); + ("hint_dir", Unset); + ("hint_file", Unset); + ("in", (Bool false)); + ("ide", (Bool false)); + ("ide_id_info_off", (Bool false)); + ("lsp", (Bool false)); + ("include", (List [])); + ("print", (Bool false)); + ("print_in_place", (Bool false)); + ("force", (Bool false)); + ("fuel", Unset); + ("ifuel", Unset); + ("initial_fuel", (Int (Prims.of_int (2)))); + ("initial_ifuel", (Int Prims.int_one)); + ("keep_query_captions", (Bool true)); + ("lax", (Bool false)); + ("load", (List [])); + ("load_cmxs", (List [])); + ("log_queries", (Bool false)); + ("log_failing_queries", (Bool false)); + ("log_types", (Bool false)); + ("max_fuel", (Int (Prims.of_int (8)))); + ("max_ifuel", (Int (Prims.of_int (2)))); + ("MLish", (Bool false)); + ("MLish_effect", (String "FStar.Compiler.Effect")); + ("no_default_includes", (Bool false)); + ("no_extract", (List [])); + ("no_location_info", (Bool false)); + ("no_smt", (Bool false)); + ("no_plugins", (Bool false)); + ("no_tactics", (Bool false)); + ("normalize_pure_terms_for_extraction", (Bool false)); + ("krmloutput", Unset); + ("odir", Unset); + ("output_deps_to", Unset); + ("prims", Unset); + ("pretype", (Bool true)); + ("prims_ref", Unset); + ("print_bound_var_types", (Bool false)); + ("print_effect_args", (Bool false)); + ("print_expected_failures", (Bool false)); + ("print_full_names", (Bool false)); + ("print_implicits", (Bool false)); + ("print_universes", (Bool false)); + ("print_z3_statistics", (Bool false)); + ("prn", (Bool false)); + ("proof_recovery", (Bool false)); + ("quake", (Int Prims.int_zero)); + ("quake_lo", (Int Prims.int_one)); + ("quake_hi", (Int Prims.int_one)); + ("quake_keep", (Bool false)); + ("query_cache", (Bool false)); + ("query_stats", (Bool false)); + ("read_checked_file", Unset); + ("list_plugins", (Bool false)); + ("locate", (Bool false)); + ("locate_lib", (Bool false)); + ("locate_ocaml", (Bool false)); + ("read_krml_file", Unset); + ("record_hints", (Bool false)); + ("record_options", (Bool false)); + ("report_assumes", Unset); + ("retry", (Bool false)); + ("reuse_hint_for", Unset); + ("silent", (Bool false)); + ("smt", Unset); + ("smtencoding.elim_box", (Bool false)); + ("smtencoding.nl_arith_repr", (String "boxwrap")); + ("smtencoding.l_arith_repr", (String "boxwrap")); + ("smtencoding.valid_intro", (Bool true)); + ("smtencoding.valid_elim", (Bool false)); + ("split_queries", (String "on_failure")); + ("tactics_failhard", (Bool false)); + ("tactics_info", (Bool false)); + ("tactic_raw_binders", (Bool false)); + ("tactic_trace", (Bool false)); + ("tactic_trace_d", (Int Prims.int_zero)); + ("tcnorm", (Bool true)); + ("timing", (Bool false)); + ("trace_error", (Bool false)); + ("ugly", (Bool false)); + ("unthrottle_inductives", (Bool false)); + ("unsafe_tactic_exec", (Bool false)); + ("use_native_tactics", Unset); + ("use_eq_at_higher_order", (Bool false)); + ("use_hints", (Bool false)); + ("use_hint_hashes", (Bool false)); + ("using_facts_from", Unset); + ("verify_module", (List [])); + ("warn_default_effects", (Bool false)); + ("z3refresh", (Bool false)); + ("z3rlimit", (Int (Prims.of_int (5)))); + ("z3rlimit_factor", (Int Prims.int_one)); + ("z3seed", (Int Prims.int_zero)); + ("z3cliopt", (List [])); + ("z3smtopt", (List [])); + ("z3version", (String "4.8.5")); + ("__no_positivity", (Bool false)); + ("__tactics_nbe", (Bool false)); + ("warn_error", (List [])); + ("use_nbe", (Bool false)); + ("use_nbe_for_extraction", (Bool false)); + ("trivial_pre_for_unannotated_effectful_fns", (Bool true)); + ("profile_group_by_decl", (Bool false)); + ("profile_component", Unset); + ("profile", Unset)] +let (init : unit -> unit) = + fun uu___ -> + FStarC_Compiler_Debug.disable_all (); + FStarC_Options_Ext.reset (); + (let uu___4 = FStarC_Compiler_Util.psmap_empty () in + FStarC_Compiler_Effect.op_Colon_Equals fstar_options uu___4); + FStarC_Compiler_List.iter set_option' defaults +let (clear : unit -> unit) = + fun uu___ -> FStarC_Compiler_Effect.op_Colon_Equals history [[]]; init () +let (uu___0 : unit) = clear () +let (get_option : Prims.string -> option_val) = + fun s -> + let uu___ = + let uu___1 = peek () in FStarC_Compiler_Util.psmap_try_find uu___1 s in + match uu___ with + | FStar_Pervasives_Native.None -> + let uu___1 = + let uu___2 = FStarC_Compiler_String.op_Hat s " not found" in + FStarC_Compiler_String.op_Hat "Impossible: option " uu___2 in + failwith uu___1 + | FStar_Pervasives_Native.Some s1 -> s1 +let rec (option_val_to_string : option_val -> Prims.string) = + fun v -> + match v with + | Bool b -> + let uu___ = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) b in + FStarC_Compiler_String.op_Hat "Bool " uu___ + | String s -> + let uu___ = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_string) s in + FStarC_Compiler_String.op_Hat "String " uu___ + | Path s -> + let uu___ = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_string) s in + FStarC_Compiler_String.op_Hat "Path " uu___ + | Int i -> + let uu___ = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) i in + FStarC_Compiler_String.op_Hat "Int " uu___ + | List vs -> + let uu___ = (FStarC_Common.string_of_list ()) option_val_to_string vs in + FStarC_Compiler_String.op_Hat "List " uu___ + | Unset -> "Unset" +let (showable_option_val : option_val FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = option_val_to_string } +let rec (eq_option_val : option_val -> option_val -> Prims.bool) = + fun v1 -> + fun v2 -> + match (v1, v2) with + | (Bool x1, Bool x2) -> + FStarC_Class_Deq.op_Equals_Question FStarC_Class_Deq.deq_bool x1 x2 + | (String x1, String x2) -> + FStarC_Class_Deq.op_Equals_Question FStarC_Class_Deq.deq_string x1 + x2 + | (Path x1, Path x2) -> + FStarC_Class_Deq.op_Equals_Question FStarC_Class_Deq.deq_string x1 + x2 + | (Int x1, Int x2) -> + FStarC_Class_Deq.op_Equals_Question FStarC_Class_Deq.deq_int x1 x2 + | (Unset, Unset) -> true + | (List x1, List x2) -> FStarC_Common.eq_list eq_option_val x1 x2 + | (uu___, uu___1) -> false +let (deq_option_val : option_val FStarC_Class_Deq.deq) = + { FStarC_Class_Deq.op_Equals_Question = eq_option_val } +let rec list_try_find : + 'a 'b . + 'a FStarC_Class_Deq.deq -> + 'a -> ('a * 'b) Prims.list -> 'b FStar_Pervasives_Native.option + = + fun uu___ -> + fun k -> + fun l -> + match l with + | [] -> FStar_Pervasives_Native.None + | (k', v')::l' -> + let uu___1 = FStarC_Class_Deq.op_Equals_Question uu___ k k' in + if uu___1 + then FStar_Pervasives_Native.Some v' + else list_try_find uu___ k l' +let (show_options : unit -> Prims.string) = + fun uu___ -> + let s = peek () in + let kvs = + let uu___1 = FStarC_Common.psmap_keys s in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Class_Monad.monad_list () () + (Obj.magic uu___1) + (fun uu___2 -> + (fun k -> + let k = Obj.magic k in + if k = "verify_module" + then Obj.magic (Obj.repr []) + else + Obj.magic + (Obj.repr + (let v = + let uu___3 = + FStarC_Compiler_Util.psmap_try_find s k in + FStarC_Compiler_Util.must uu___3 in + let v0 = + list_try_find FStarC_Class_Deq.deq_string k + defaults in + let uu___3 = + FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Deq.deq_option deq_option_val) v0 + (FStar_Pervasives_Native.Some v) in + if uu___3 + then Obj.repr [] + else + Obj.repr + (FStarC_Class_Monad.return + FStarC_Class_Monad.monad_list () + (Obj.magic (k, v)))))) uu___2)) in + let rec show_optionval v = + match v with + | String s1 -> + let uu___1 = FStarC_Compiler_String.op_Hat s1 "\"" in + FStarC_Compiler_String.op_Hat "\"" uu___1 + | Bool b -> + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) b + | Int i -> + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) i + | Path s1 -> s1 + | List s1 -> + let uu___1 = FStarC_Compiler_List.map show_optionval s1 in + FStarC_Compiler_String.concat "," uu___1 + | Unset -> "" in + let show1 uu___1 = + match uu___1 with + | (k, v) -> + let uu___2 = show_optionval v in + FStarC_Compiler_Util.format2 "--%s %s" k uu___2 in + let uu___1 = FStarC_Compiler_List.map show1 kvs in + FStarC_Compiler_String.concat "\n" uu___1 +let (set_verification_options : optionstate -> unit) = + fun o -> + let verifopts = + ["initial_fuel"; + "max_fuel"; + "initial_ifuel"; + "max_ifuel"; + "detail_errors"; + "detail_hint_replay"; + "no_smt"; + "quake"; + "retry"; + "smtencoding.elim_box"; + "smtencoding.nl_arith_repr"; + "smtencoding.l_arith_repr"; + "smtencoding.valid_intro"; + "smtencoding.valid_elim"; + "tcnorm"; + "no_plugins"; + "no_tactics"; + "z3cliopt"; + "z3smtopt"; + "z3refresh"; + "z3rlimit"; + "z3rlimit_factor"; + "z3seed"; + "z3version"; + "trivial_pre_for_unannotated_effectful_fns"] in + FStarC_Compiler_List.iter + (fun k -> + let uu___ = + let uu___1 = FStarC_Compiler_Util.psmap_try_find o k in + FStarC_Compiler_Util.must uu___1 in + set_option k uu___) verifopts +let lookup_opt : 'uuuuu . Prims.string -> (option_val -> 'uuuuu) -> 'uuuuu = + fun s -> fun c -> let uu___ = get_option s in c uu___ +let (get_abort_on : unit -> Prims.int) = + fun uu___ -> lookup_opt "abort_on" as_int +let (get_admit_smt_queries : unit -> Prims.bool) = + fun uu___ -> lookup_opt "admit_smt_queries" as_bool +let (get_admit_except : unit -> Prims.string FStar_Pervasives_Native.option) + = fun uu___ -> lookup_opt "admit_except" (as_option as_string) +let (get_compat_pre_core : unit -> Prims.int FStar_Pervasives_Native.option) + = fun uu___ -> lookup_opt "compat_pre_core" (as_option as_int) +let (get_compat_pre_typed_indexed_effects : unit -> Prims.bool) = + fun uu___ -> lookup_opt "compat_pre_typed_indexed_effects" as_bool +let (get_disallow_unification_guards : unit -> Prims.bool) = + fun uu___ -> lookup_opt "disallow_unification_guards" as_bool +let (get_already_cached : + unit -> Prims.string Prims.list FStar_Pervasives_Native.option) = + fun uu___ -> lookup_opt "already_cached" (as_option (as_list as_string)) +let (get_cache_checked_modules : unit -> Prims.bool) = + fun uu___ -> lookup_opt "cache_checked_modules" as_bool +let (get_cache_dir : unit -> Prims.string FStar_Pervasives_Native.option) = + fun uu___ -> lookup_opt "cache_dir" (as_option as_string) +let (get_cache_off : unit -> Prims.bool) = + fun uu___ -> lookup_opt "cache_off" as_bool +let (get_print_cache_version : unit -> Prims.bool) = + fun uu___ -> lookup_opt "print_cache_version" as_bool +let (get_cmi : unit -> Prims.bool) = fun uu___ -> lookup_opt "cmi" as_bool +let (get_codegen : unit -> Prims.string FStar_Pervasives_Native.option) = + fun uu___ -> lookup_opt "codegen" (as_option as_string) +let (get_codegen_lib : unit -> Prims.string Prims.list) = + fun uu___ -> lookup_opt "codegen-lib" (as_list as_string) +let (get_defensive : unit -> Prims.string) = + fun uu___ -> lookup_opt "defensive" as_string +let (get_dep : unit -> Prims.string FStar_Pervasives_Native.option) = + fun uu___ -> lookup_opt "dep" (as_option as_string) +let (get_detail_errors : unit -> Prims.bool) = + fun uu___ -> lookup_opt "detail_errors" as_bool +let (get_detail_hint_replay : unit -> Prims.bool) = + fun uu___ -> lookup_opt "detail_hint_replay" as_bool +let (get_dump_module : unit -> Prims.string Prims.list) = + fun uu___ -> lookup_opt "dump_module" (as_list as_string) +let (get_eager_subtyping : unit -> Prims.bool) = + fun uu___ -> lookup_opt "eager_subtyping" as_bool +let (get_error_contexts : unit -> Prims.bool) = + fun uu___ -> lookup_opt "error_contexts" as_bool +let (get_expose_interfaces : unit -> Prims.bool) = + fun uu___ -> lookup_opt "expose_interfaces" as_bool +let (get_message_format : unit -> Prims.string) = + fun uu___ -> lookup_opt "message_format" as_string +let (get_extract : + unit -> Prims.string Prims.list FStar_Pervasives_Native.option) = + fun uu___ -> lookup_opt "extract" (as_option (as_list as_string)) +let (get_extract_module : unit -> Prims.string Prims.list) = + fun uu___ -> lookup_opt "extract_module" (as_list as_string) +let (get_extract_namespace : unit -> Prims.string Prims.list) = + fun uu___ -> lookup_opt "extract_namespace" (as_list as_string) +let (get_force : unit -> Prims.bool) = + fun uu___ -> lookup_opt "force" as_bool +let (get_hide_uvar_nums : unit -> Prims.bool) = + fun uu___ -> lookup_opt "hide_uvar_nums" as_bool +let (get_hint_info : unit -> Prims.bool) = + fun uu___ -> lookup_opt "hint_info" as_bool +let (get_hint_dir : unit -> Prims.string FStar_Pervasives_Native.option) = + fun uu___ -> lookup_opt "hint_dir" (as_option as_string) +let (get_hint_file : unit -> Prims.string FStar_Pervasives_Native.option) = + fun uu___ -> lookup_opt "hint_file" (as_option as_string) +let (get_in : unit -> Prims.bool) = fun uu___ -> lookup_opt "in" as_bool +let (get_ide : unit -> Prims.bool) = fun uu___ -> lookup_opt "ide" as_bool +let (get_ide_id_info_off : unit -> Prims.bool) = + fun uu___ -> lookup_opt "ide_id_info_off" as_bool +let (get_lsp : unit -> Prims.bool) = fun uu___ -> lookup_opt "lsp" as_bool +let (get_include : unit -> Prims.string Prims.list) = + fun uu___ -> lookup_opt "include" (as_list as_string) +let (get_print : unit -> Prims.bool) = + fun uu___ -> lookup_opt "print" as_bool +let (get_print_in_place : unit -> Prims.bool) = + fun uu___ -> lookup_opt "print_in_place" as_bool +let (get_initial_fuel : unit -> Prims.int) = + fun uu___ -> lookup_opt "initial_fuel" as_int +let (get_initial_ifuel : unit -> Prims.int) = + fun uu___ -> lookup_opt "initial_ifuel" as_int +let (get_keep_query_captions : unit -> Prims.bool) = + fun uu___ -> lookup_opt "keep_query_captions" as_bool +let (get_lax : unit -> Prims.bool) = fun uu___ -> lookup_opt "lax" as_bool +let (get_load : unit -> Prims.string Prims.list) = + fun uu___ -> lookup_opt "load" (as_list as_string) +let (get_load_cmxs : unit -> Prims.string Prims.list) = + fun uu___ -> lookup_opt "load_cmxs" (as_list as_string) +let (get_log_queries : unit -> Prims.bool) = + fun uu___ -> lookup_opt "log_queries" as_bool +let (get_log_failing_queries : unit -> Prims.bool) = + fun uu___ -> lookup_opt "log_failing_queries" as_bool +let (get_log_types : unit -> Prims.bool) = + fun uu___ -> lookup_opt "log_types" as_bool +let (get_max_fuel : unit -> Prims.int) = + fun uu___ -> lookup_opt "max_fuel" as_int +let (get_max_ifuel : unit -> Prims.int) = + fun uu___ -> lookup_opt "max_ifuel" as_int +let (get_MLish : unit -> Prims.bool) = + fun uu___ -> lookup_opt "MLish" as_bool +let (get_MLish_effect : unit -> Prims.string) = + fun uu___ -> lookup_opt "MLish_effect" as_string +let (get_no_default_includes : unit -> Prims.bool) = + fun uu___ -> lookup_opt "no_default_includes" as_bool +let (get_no_extract : unit -> Prims.string Prims.list) = + fun uu___ -> lookup_opt "no_extract" (as_list as_string) +let (get_no_location_info : unit -> Prims.bool) = + fun uu___ -> lookup_opt "no_location_info" as_bool +let (get_no_plugins : unit -> Prims.bool) = + fun uu___ -> lookup_opt "no_plugins" as_bool +let (get_no_smt : unit -> Prims.bool) = + fun uu___ -> lookup_opt "no_smt" as_bool +let (get_normalize_pure_terms_for_extraction : unit -> Prims.bool) = + fun uu___ -> lookup_opt "normalize_pure_terms_for_extraction" as_bool +let (get_krmloutput : unit -> Prims.string FStar_Pervasives_Native.option) = + fun uu___ -> lookup_opt "krmloutput" (as_option as_string) +let (get_odir : unit -> Prims.string FStar_Pervasives_Native.option) = + fun uu___ -> lookup_opt "odir" (as_option as_string) +let (get_output_deps_to : + unit -> Prims.string FStar_Pervasives_Native.option) = + fun uu___ -> lookup_opt "output_deps_to" (as_option as_string) +let (get_ugly : unit -> Prims.bool) = fun uu___ -> lookup_opt "ugly" as_bool +let (get_prims : unit -> Prims.string FStar_Pervasives_Native.option) = + fun uu___ -> lookup_opt "prims" (as_option as_string) +let (get_print_bound_var_types : unit -> Prims.bool) = + fun uu___ -> lookup_opt "print_bound_var_types" as_bool +let (get_print_effect_args : unit -> Prims.bool) = + fun uu___ -> lookup_opt "print_effect_args" as_bool +let (get_print_expected_failures : unit -> Prims.bool) = + fun uu___ -> lookup_opt "print_expected_failures" as_bool +let (get_print_full_names : unit -> Prims.bool) = + fun uu___ -> lookup_opt "print_full_names" as_bool +let (get_print_implicits : unit -> Prims.bool) = + fun uu___ -> lookup_opt "print_implicits" as_bool +let (get_print_universes : unit -> Prims.bool) = + fun uu___ -> lookup_opt "print_universes" as_bool +let (get_print_z3_statistics : unit -> Prims.bool) = + fun uu___ -> lookup_opt "print_z3_statistics" as_bool +let (get_prn : unit -> Prims.bool) = fun uu___ -> lookup_opt "prn" as_bool +let (get_proof_recovery : unit -> Prims.bool) = + fun uu___ -> lookup_opt "proof_recovery" as_bool +let (get_quake_lo : unit -> Prims.int) = + fun uu___ -> lookup_opt "quake_lo" as_int +let (get_quake_hi : unit -> Prims.int) = + fun uu___ -> lookup_opt "quake_hi" as_int +let (get_quake_keep : unit -> Prims.bool) = + fun uu___ -> lookup_opt "quake_keep" as_bool +let (get_query_cache : unit -> Prims.bool) = + fun uu___ -> lookup_opt "query_cache" as_bool +let (get_query_stats : unit -> Prims.bool) = + fun uu___ -> lookup_opt "query_stats" as_bool +let (get_read_checked_file : + unit -> Prims.string FStar_Pervasives_Native.option) = + fun uu___ -> lookup_opt "read_checked_file" (as_option as_string) +let (get_read_krml_file : + unit -> Prims.string FStar_Pervasives_Native.option) = + fun uu___ -> lookup_opt "read_krml_file" (as_option as_string) +let (get_list_plugins : unit -> Prims.bool) = + fun uu___ -> lookup_opt "list_plugins" as_bool +let (get_locate : unit -> Prims.bool) = + fun uu___ -> lookup_opt "locate" as_bool +let (get_locate_lib : unit -> Prims.bool) = + fun uu___ -> lookup_opt "locate_lib" as_bool +let (get_locate_ocaml : unit -> Prims.bool) = + fun uu___ -> lookup_opt "locate_ocaml" as_bool +let (get_record_hints : unit -> Prims.bool) = + fun uu___ -> lookup_opt "record_hints" as_bool +let (get_record_options : unit -> Prims.bool) = + fun uu___ -> lookup_opt "record_options" as_bool +let (get_retry : unit -> Prims.bool) = + fun uu___ -> lookup_opt "retry" as_bool +let (get_reuse_hint_for : + unit -> Prims.string FStar_Pervasives_Native.option) = + fun uu___ -> lookup_opt "reuse_hint_for" (as_option as_string) +let (get_report_assumes : + unit -> Prims.string FStar_Pervasives_Native.option) = + fun uu___ -> lookup_opt "report_assumes" (as_option as_string) +let (get_silent : unit -> Prims.bool) = + fun uu___ -> lookup_opt "silent" as_bool +let (get_smt : unit -> Prims.string FStar_Pervasives_Native.option) = + fun uu___ -> lookup_opt "smt" (as_option as_string) +let (get_smtencoding_elim_box : unit -> Prims.bool) = + fun uu___ -> lookup_opt "smtencoding.elim_box" as_bool +let (get_smtencoding_nl_arith_repr : unit -> Prims.string) = + fun uu___ -> lookup_opt "smtencoding.nl_arith_repr" as_string +let (get_smtencoding_l_arith_repr : unit -> Prims.string) = + fun uu___ -> lookup_opt "smtencoding.l_arith_repr" as_string +let (get_smtencoding_valid_intro : unit -> Prims.bool) = + fun uu___ -> lookup_opt "smtencoding.valid_intro" as_bool +let (get_smtencoding_valid_elim : unit -> Prims.bool) = + fun uu___ -> lookup_opt "smtencoding.valid_elim" as_bool +let (get_split_queries : unit -> Prims.string) = + fun uu___ -> lookup_opt "split_queries" as_string +let (get_tactic_raw_binders : unit -> Prims.bool) = + fun uu___ -> lookup_opt "tactic_raw_binders" as_bool +let (get_tactics_failhard : unit -> Prims.bool) = + fun uu___ -> lookup_opt "tactics_failhard" as_bool +let (get_tactics_info : unit -> Prims.bool) = + fun uu___ -> lookup_opt "tactics_info" as_bool +let (get_tactic_trace : unit -> Prims.bool) = + fun uu___ -> lookup_opt "tactic_trace" as_bool +let (get_tactic_trace_d : unit -> Prims.int) = + fun uu___ -> lookup_opt "tactic_trace_d" as_int +let (get_tactics_nbe : unit -> Prims.bool) = + fun uu___ -> lookup_opt "__tactics_nbe" as_bool +let (get_tcnorm : unit -> Prims.bool) = + fun uu___ -> lookup_opt "tcnorm" as_bool +let (get_timing : unit -> Prims.bool) = + fun uu___ -> lookup_opt "timing" as_bool +let (get_trace_error : unit -> Prims.bool) = + fun uu___ -> lookup_opt "trace_error" as_bool +let (get_unthrottle_inductives : unit -> Prims.bool) = + fun uu___ -> lookup_opt "unthrottle_inductives" as_bool +let (get_unsafe_tactic_exec : unit -> Prims.bool) = + fun uu___ -> lookup_opt "unsafe_tactic_exec" as_bool +let (get_use_eq_at_higher_order : unit -> Prims.bool) = + fun uu___ -> lookup_opt "use_eq_at_higher_order" as_bool +let (get_use_hints : unit -> Prims.bool) = + fun uu___ -> lookup_opt "use_hints" as_bool +let (get_use_hint_hashes : unit -> Prims.bool) = + fun uu___ -> lookup_opt "use_hint_hashes" as_bool +let (get_use_native_tactics : + unit -> Prims.string FStar_Pervasives_Native.option) = + fun uu___ -> lookup_opt "use_native_tactics" (as_option as_string) +let (get_no_tactics : unit -> Prims.bool) = + fun uu___ -> lookup_opt "no_tactics" as_bool +let (get_using_facts_from : + unit -> Prims.string Prims.list FStar_Pervasives_Native.option) = + fun uu___ -> lookup_opt "using_facts_from" (as_option (as_list as_string)) +let (get_verify_module : unit -> Prims.string Prims.list) = + fun uu___ -> lookup_opt "verify_module" (as_list as_string) +let (get_version : unit -> Prims.bool) = + fun uu___ -> lookup_opt "version" as_bool +let (get_warn_default_effects : unit -> Prims.bool) = + fun uu___ -> lookup_opt "warn_default_effects" as_bool +let (get_z3cliopt : unit -> Prims.string Prims.list) = + fun uu___ -> lookup_opt "z3cliopt" (as_list as_string) +let (get_z3smtopt : unit -> Prims.string Prims.list) = + fun uu___ -> lookup_opt "z3smtopt" (as_list as_string) +let (get_z3refresh : unit -> Prims.bool) = + fun uu___ -> lookup_opt "z3refresh" as_bool +let (get_z3rlimit : unit -> Prims.int) = + fun uu___ -> lookup_opt "z3rlimit" as_int +let (get_z3rlimit_factor : unit -> Prims.int) = + fun uu___ -> lookup_opt "z3rlimit_factor" as_int +let (get_z3seed : unit -> Prims.int) = + fun uu___ -> lookup_opt "z3seed" as_int +let (get_z3version : unit -> Prims.string) = + fun uu___ -> lookup_opt "z3version" as_string +let (get_no_positivity : unit -> Prims.bool) = + fun uu___ -> lookup_opt "__no_positivity" as_bool +let (get_warn_error : unit -> Prims.string Prims.list) = + fun uu___ -> lookup_opt "warn_error" (as_list as_string) +let (get_use_nbe : unit -> Prims.bool) = + fun uu___ -> lookup_opt "use_nbe" as_bool +let (get_use_nbe_for_extraction : unit -> Prims.bool) = + fun uu___ -> lookup_opt "use_nbe_for_extraction" as_bool +let (get_trivial_pre_for_unannotated_effectful_fns : unit -> Prims.bool) = + fun uu___ -> lookup_opt "trivial_pre_for_unannotated_effectful_fns" as_bool +let (get_profile : + unit -> Prims.string Prims.list FStar_Pervasives_Native.option) = + fun uu___ -> lookup_opt "profile" (as_option (as_list as_string)) +let (get_profile_group_by_decl : unit -> Prims.bool) = + fun uu___ -> lookup_opt "profile_group_by_decl" as_bool +let (get_profile_component : + unit -> Prims.string Prims.list FStar_Pervasives_Native.option) = + fun uu___ -> lookup_opt "profile_component" (as_option (as_list as_string)) +let (_version : Prims.string FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref "" +let (_platform : Prims.string FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref "" +let (_compiler : Prims.string FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref "" +let (_date : Prims.string FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref " not set" +let (_commit : Prims.string FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref "" +let (display_version : unit -> unit) = + fun uu___ -> + let uu___1 = + let uu___2 = FStarC_Compiler_Effect.op_Bang _version in + let uu___3 = FStarC_Compiler_Effect.op_Bang _platform in + let uu___4 = FStarC_Compiler_Effect.op_Bang _compiler in + let uu___5 = FStarC_Compiler_Effect.op_Bang _date in + let uu___6 = FStarC_Compiler_Effect.op_Bang _commit in + FStarC_Compiler_Util.format5 + "F* %s\nplatform=%s\ncompiler=%s\ndate=%s\ncommit=%s\n" uu___2 uu___3 + uu___4 uu___5 uu___6 in + FStarC_Compiler_Util.print_string uu___1 +let (display_debug_keys : unit -> unit) = + fun uu___ -> + let keys = FStarC_Compiler_Debug.list_all_toggles () in + let uu___1 = + FStarC_Compiler_List.sortWith FStarC_Compiler_String.compare keys in + FStarC_Compiler_List.iter + (fun s -> + let uu___2 = FStarC_Compiler_String.op_Hat s "\n" in + FStarC_Compiler_Util.print_string uu___2) uu___1 +let (display_usage_aux : + (FStarC_Getopt.opt * FStarC_Pprint.document) Prims.list -> unit) = + fun specs -> + let text s = + let uu___ = FStarC_Pprint.break_ Prims.int_one in + let uu___1 = FStarC_Pprint.words s in FStarC_Pprint.flow uu___ uu___1 in + let bold_doc d = + let uu___ = + let uu___1 = FStarC_Compiler_Util.stdout_isatty () in + uu___1 = (FStar_Pervasives_Native.Some true) in + if uu___ + then + let uu___1 = FStarC_Pprint.fancystring "\027[39;1m" Prims.int_zero in + let uu___2 = + let uu___3 = FStarC_Pprint.fancystring "\027[0m" Prims.int_zero in + FStarC_Pprint.op_Hat_Hat d uu___3 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 + else d in + let d = + let uu___ = + FStarC_Pprint.doc_of_string + "fstar.exe [options] file[s] [@respfile...]" in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Compiler_Util.colorize_bold "@" in + FStarC_Compiler_Util.format1 + " %srespfile: read command-line options from respfile\n" + uu___4 in + FStarC_Pprint.doc_of_string uu___3 in + let uu___3 = + FStarC_Compiler_List.fold_right + (fun uu___4 -> + fun rest -> + match uu___4 with + | ((short, flag, p), explain) -> + let arg = + match p with + | FStarC_Getopt.ZeroArgs uu___5 -> FStarC_Pprint.empty + | FStarC_Getopt.OneArg (uu___5, argname) -> + let uu___6 = FStarC_Pprint.blank Prims.int_one in + let uu___7 = FStarC_Pprint.doc_of_string argname in + FStarC_Pprint.op_Hat_Hat uu___6 uu___7 in + let short_opt = + if short <> FStarC_Getopt.noshort + then + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Compiler_String.make Prims.int_one + short in + FStarC_Compiler_String.op_Hat "-" uu___8 in + FStarC_Pprint.doc_of_string uu___7 in + FStarC_Pprint.op_Hat_Hat uu___6 arg in + [uu___5] + else [] in + let long_opt = + if flag <> "" + then + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Compiler_String.op_Hat "--" flag in + FStarC_Pprint.doc_of_string uu___7 in + FStarC_Pprint.op_Hat_Hat uu___6 arg in + [uu___5] + else [] in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = FStarC_Pprint.blank Prims.int_one in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.comma + uu___9 in + FStarC_Pprint.separate uu___8 + (FStarC_Compiler_List.op_At short_opt long_opt) in + bold_doc uu___7 in + FStarC_Pprint.group uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Pprint.blank (Prims.of_int (4)) in + let uu___11 = FStarC_Pprint.align explain in + FStarC_Pprint.op_Hat_Hat uu___10 uu___11 in + FStarC_Pprint.group uu___9 in + let uu___9 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline + rest in + FStarC_Pprint.op_Hat_Hat uu___8 uu___9 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline uu___7 in + FStarC_Pprint.op_Hat_Hat uu___5 uu___6) specs + FStarC_Pprint.empty in + FStarC_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in + FStarC_Pprint.op_Hat_Slash_Hat uu___ uu___1 in + let uu___ = + FStarC_Pprint.pretty_string + (FStarC_Compiler_Util.float_of_string "1.0") (Prims.of_int (80)) d in + FStarC_Compiler_Util.print_string uu___ +let (mk_spec : + (FStarC_BaseTypes.char * Prims.string * option_val + FStarC_Getopt.opt_variant) -> FStarC_Getopt.opt) + = + fun o -> + let uu___ = o in + match uu___ with + | (ns, name, arg) -> + let arg1 = + match arg with + | FStarC_Getopt.ZeroArgs f -> + let g uu___1 = let uu___2 = f () in set_option name uu___2 in + FStarC_Getopt.ZeroArgs g + | FStarC_Getopt.OneArg (f, d) -> + let g x = let uu___1 = f x in set_option name uu___1 in + FStarC_Getopt.OneArg (g, d) in + (ns, name, arg1) +let (accumulated_option : Prims.string -> option_val -> option_val) = + fun name -> + fun value -> + let prev_values = + let uu___ = lookup_opt name (as_option as_list') in + FStarC_Compiler_Util.dflt [] uu___ in + List (value :: prev_values) +let (reverse_accumulated_option : Prims.string -> option_val -> option_val) = + fun name -> + fun value -> + let prev_values = + let uu___ = lookup_opt name (as_option as_list') in + FStarC_Compiler_Util.dflt [] uu___ in + List (FStarC_Compiler_List.op_At prev_values [value]) +let accumulate_string : + 'uuuuu . Prims.string -> ('uuuuu -> Prims.string) -> 'uuuuu -> unit = + fun name -> + fun post_processor -> + fun value -> + let uu___ = + let uu___1 = let uu___2 = post_processor value in String uu___2 in + accumulated_option name uu___1 in + set_option name uu___ +let (add_extract_module : Prims.string -> unit) = + fun s -> + accumulate_string "extract_module" FStarC_Compiler_String.lowercase s +let (add_extract_namespace : Prims.string -> unit) = + fun s -> + accumulate_string "extract_namespace" FStarC_Compiler_String.lowercase s +let (add_verify_module : Prims.string -> unit) = + fun s -> + accumulate_string "verify_module" FStarC_Compiler_String.lowercase s +exception InvalidArgument of Prims.string +let (uu___is_InvalidArgument : Prims.exn -> Prims.bool) = + fun projectee -> + match projectee with | InvalidArgument uu___ -> true | uu___ -> false +let (__proj__InvalidArgument__item__uu___ : Prims.exn -> Prims.string) = + fun projectee -> match projectee with | InvalidArgument uu___ -> uu___ +let rec (parse_opt_val : + Prims.string -> opt_type -> Prims.string -> option_val) = + fun opt_name -> + fun typ -> + fun str_val -> + try + (fun uu___ -> + match () with + | () -> + (match typ with + | Const c -> c + | IntStr uu___1 -> + let uu___2 = + FStarC_Compiler_Util.safe_int_of_string str_val in + (match uu___2 with + | FStar_Pervasives_Native.Some v -> Int v + | FStar_Pervasives_Native.None -> + FStarC_Compiler_Effect.raise + (InvalidArgument opt_name)) + | BoolStr -> + let uu___1 = + if str_val = "true" + then true + else + if str_val = "false" + then false + else + FStarC_Compiler_Effect.raise + (InvalidArgument opt_name) in + Bool uu___1 + | PathStr uu___1 -> Path str_val + | SimpleStr uu___1 -> String str_val + | EnumStr strs -> + if FStarC_Compiler_List.mem str_val strs + then String str_val + else + FStarC_Compiler_Effect.raise + (InvalidArgument opt_name) + | OpenEnumStr uu___1 -> String str_val + | PostProcessed (pp, elem_spec) -> + let uu___1 = parse_opt_val opt_name elem_spec str_val in + pp uu___1 + | Accumulated elem_spec -> + let v = parse_opt_val opt_name elem_spec str_val in + accumulated_option opt_name v + | ReverseAccumulated elem_spec -> + let v = parse_opt_val opt_name elem_spec str_val in + reverse_accumulated_option opt_name v + | WithSideEffect (side_effect, elem_spec) -> + (side_effect (); + parse_opt_val opt_name elem_spec str_val))) () + with + | InvalidArgument opt_name1 -> + let uu___1 = + FStarC_Compiler_Util.format1 "Invalid argument to --%s" + opt_name1 in + failwith uu___1 +let rec (desc_of_opt_type : + opt_type -> Prims.string FStar_Pervasives_Native.option) = + fun typ -> + let desc_of_enum cases = + FStar_Pervasives_Native.Some (FStarC_Compiler_String.concat "|" cases) in + match typ with + | Const c -> FStar_Pervasives_Native.None + | IntStr desc -> FStar_Pervasives_Native.Some desc + | BoolStr -> desc_of_enum ["true"; "false"] + | PathStr desc -> FStar_Pervasives_Native.Some desc + | SimpleStr desc -> FStar_Pervasives_Native.Some desc + | EnumStr strs -> desc_of_enum strs + | OpenEnumStr (strs, desc) -> + desc_of_enum (FStarC_Compiler_List.op_At strs [desc]) + | PostProcessed (uu___, elem_spec) -> desc_of_opt_type elem_spec + | Accumulated elem_spec -> desc_of_opt_type elem_spec + | ReverseAccumulated elem_spec -> desc_of_opt_type elem_spec + | WithSideEffect (uu___, elem_spec) -> desc_of_opt_type elem_spec +let (arg_spec_of_opt_type : + Prims.string -> opt_type -> option_val FStarC_Getopt.opt_variant) = + fun opt_name -> + fun typ -> + let wrap s = + let uu___ = FStarC_Compiler_String.op_Hat s ">" in + FStarC_Compiler_String.op_Hat "<" uu___ in + let parser = parse_opt_val opt_name typ in + let uu___ = desc_of_opt_type typ in + match uu___ with + | FStar_Pervasives_Native.None -> + FStarC_Getopt.ZeroArgs ((fun uu___1 -> parser "")) + | FStar_Pervasives_Native.Some desc -> + let desc1 = wrap desc in FStarC_Getopt.OneArg (parser, desc1) +let (pp_validate_dir : option_val -> option_val) = + fun p -> + let pp = as_string p in FStarC_Compiler_Util.mkdir false true pp; p +let (pp_lowercase : option_val -> option_val) = + fun s -> + let uu___ = + let uu___1 = as_string s in FStarC_Compiler_String.lowercase uu___1 in + String uu___ +let (abort_counter : Prims.int FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref Prims.int_zero +let (interp_quake_arg : Prims.string -> (Prims.int * Prims.int * Prims.bool)) + = + fun s -> + let ios = FStarC_Compiler_Util.int_of_string in + match FStarC_Compiler_Util.split s "/" with + | f::[] -> + let uu___ = ios f in let uu___1 = ios f in (uu___, uu___1, false) + | f1::f2::[] -> + if f2 = "k" + then + let uu___ = ios f1 in let uu___1 = ios f1 in (uu___, uu___1, true) + else + (let uu___1 = ios f1 in + let uu___2 = ios f2 in (uu___1, uu___2, false)) + | f1::f2::k::[] -> + if k = "k" + then + let uu___ = ios f1 in let uu___1 = ios f2 in (uu___, uu___1, true) + else failwith "unexpected value for --quake" + | uu___ -> failwith "unexpected value for --quake" +let (uu___1 : (((Prims.string -> unit) -> unit) * (Prims.string -> unit))) = + let cb = FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None in + let set1 f = + FStarC_Compiler_Effect.op_Colon_Equals cb + (FStar_Pervasives_Native.Some f) in + let call msg = + let uu___ = FStarC_Compiler_Effect.op_Bang cb in + match uu___ with + | FStar_Pervasives_Native.None -> () + | FStar_Pervasives_Native.Some f -> f msg in + (set1, call) +let (set_option_warning_callback_aux : (Prims.string -> unit) -> unit) = + match uu___1 with + | (set_option_warning_callback_aux1, option_warning_callback) -> + set_option_warning_callback_aux1 +let (option_warning_callback : Prims.string -> unit) = + match uu___1 with + | (set_option_warning_callback_aux1, option_warning_callback1) -> + option_warning_callback1 +let (set_option_warning_callback : (Prims.string -> unit) -> unit) = + fun f -> set_option_warning_callback_aux f +let rec (specs_with_types : + Prims.bool -> + (FStarC_BaseTypes.char * Prims.string * opt_type * + FStarC_Pprint.document) Prims.list) + = + fun warn_unsafe -> + let text s = + let uu___ = FStarC_Pprint.break_ Prims.int_one in + let uu___2 = FStarC_Pprint.words s in FStarC_Pprint.flow uu___ uu___2 in + let uu___ = + let uu___2 = + text + "Abort on the n-th error or warning raised. Useful in combination with --trace_error. Count starts at 1, use 0 to disable. (default 0)" in + (FStarC_Getopt.noshort, "abort_on", + (PostProcessed + ((fun uu___3 -> + match uu___3 with + | Int x -> + (FStarC_Compiler_Effect.op_Colon_Equals abort_counter x; + Int x) + | x -> failwith "?"), (IntStr "non-negative integer"))), + uu___2) in + let uu___2 = + let uu___3 = + let uu___4 = text "Admit SMT queries, unsafe! (default 'false')" in + (FStarC_Getopt.noshort, "admit_smt_queries", + (WithSideEffect + ((fun uu___5 -> + if warn_unsafe + then option_warning_callback "admit_smt_queries" + else ()), BoolStr)), uu___4) in + let uu___4 = + let uu___5 = + let uu___6 = + text + "Admit all queries, except those with label ( symbol, id))(e.g. --admit_except '(FStar.Fin.pigeonhole, 1)' or --admit_except FStar.Fin.pigeonhole)" in + (FStarC_Getopt.noshort, "admit_except", + (WithSideEffect + ((fun uu___7 -> + if warn_unsafe + then option_warning_callback "admit_except" + else ()), (SimpleStr "[symbol|(symbol, id)]"))), uu___6) in + let uu___6 = + let uu___7 = + let uu___8 = + text + "Retain behavior of the tactic engine prior to the introduction of FStarC.TypeChecker.Core (0 is most permissive, 2 is least permissive)" in + (FStarC_Getopt.noshort, "compat_pre_core", (IntStr "0, 1, 2"), + uu___8) in + let uu___8 = + let uu___9 = + let uu___10 = text "Retain untyped indexed effects implicits" in + (FStarC_Getopt.noshort, "compat_pre_typed_indexed_effects", + (Const (Bool true)), uu___10) in + let uu___10 = + let uu___11 = + let uu___12 = + text + "Fail if the SMT guard are produced when the tactic engine re-checks solutions produced by the unifier (default 'false')" in + (FStarC_Getopt.noshort, "disallow_unification_guards", + BoolStr, uu___12) in + let uu___12 = + let uu___13 = + let uu___14 = + text + "Expects all modules whose names or namespaces match the provided options to already have valid .checked files in the include path" in + (FStarC_Getopt.noshort, "already_cached", + (Accumulated + (SimpleStr + "One or more space-separated occurrences of '[+|-]( * | namespace | module)'")), + uu___14) in + let uu___14 = + let uu___15 = + let uu___16 = + text + "Write a '.checked' file for each module after verification and read from it if present, instead of re-verifying" in + (FStarC_Getopt.noshort, "cache_checked_modules", + (Const (Bool true)), uu___16) in + let uu___16 = + let uu___17 = + let uu___18 = + text + "Read and write .checked and .checked.lax in directory dir" in + (FStarC_Getopt.noshort, "cache_dir", + (PostProcessed (pp_validate_dir, (PathStr "dir"))), + uu___18) in + let uu___18 = + let uu___19 = + let uu___20 = + text "Do not read or write any .checked files" in + (FStarC_Getopt.noshort, "cache_off", + (Const (Bool true)), uu___20) in + let uu___20 = + let uu___21 = + let uu___22 = + text + "Print the version for .checked files and exit." in + (FStarC_Getopt.noshort, "print_cache_version", + (Const (Bool true)), uu___22) in + let uu___22 = + let uu___23 = + let uu___24 = + text + "Inline across module interfaces during extraction (aka. cross-module inlining)" in + (FStarC_Getopt.noshort, "cmi", + (Const (Bool true)), uu___24) in + let uu___24 = + let uu___25 = + let uu___26 = + text + "Generate code for further compilation to executable code, or build a compiler plugin" in + (FStarC_Getopt.noshort, "codegen", + (EnumStr + ["OCaml"; + "FSharp"; + "krml"; + "Plugin"; + "Extension"]), uu___26) in + let uu___26 = + let uu___27 = + let uu___28 = + text + "External runtime library (i.e. M.N.x extracts to M.N.X instead of M_N.x)" in + (FStarC_Getopt.noshort, "codegen-lib", + (Accumulated (SimpleStr "namespace")), + uu___28) in + let uu___28 = + let uu___29 = + let uu___30 = + text + "Enable general debugging, i.e. increase verbosity." in + (100, "", + (PostProcessed + ((fun o -> + FStarC_Compiler_Debug.enable (); o), + (Const (Bool true)))), uu___30) in + let uu___30 = + let uu___31 = + let uu___32 = + text + "Enable specific debug toggles (comma-separated list of debug keys)" in + (FStarC_Getopt.noshort, "debug", + (PostProcessed + ((fun o -> + let keys = + as_comma_string_list o in + FStarC_Compiler_Debug.enable_toggles + keys; + o), + (ReverseAccumulated + (SimpleStr "debug toggles")))), + uu___32) in + let uu___32 = + let uu___33 = + let uu___34 = + text + "Enable all debug toggles. WARNING: this will cause a lot of output!" in + (FStarC_Getopt.noshort, "debug_all", + (PostProcessed + ((fun o -> + match o with + | Bool (true) -> + (FStarC_Compiler_Debug.set_debug_all + (); + o) + | uu___35 -> failwith "?"), + (Const (Bool true)))), uu___34) in + let uu___34 = + let uu___35 = + let uu___36 = + text + "Enable to make the effect of --debug apply to every module processed by the compiler, including dependencies." in + (FStarC_Getopt.noshort, + "debug_all_modules", + (Const (Bool true)), uu___36) in + let uu___36 = + let uu___37 = + let uu___38 = + let uu___39 = + text + "Enable several internal sanity checks, useful to track bugs and report issues." in + let uu___40 = + let uu___41 = + let uu___42 = + let uu___43 = + text + "if 'no', no checks are performed" in + let uu___44 = + let uu___45 = + text + "if 'warn', checks are performed and raise a warning when they fail" in + let uu___46 = + let uu___47 = + text + "if 'error, like 'warn', but the compiler raises a hard error instead" in + let uu___48 = + let uu___49 = + text + "if 'abort, like 'warn', but the compiler immediately aborts on an error" in + [uu___49] in + uu___47 :: uu___48 in + uu___45 :: uu___46 in + uu___43 :: uu___44 in + FStarC_Errors_Msg.bulleted + uu___42 in + let uu___42 = + text "(default 'no')" in + FStarC_Pprint.op_Hat_Slash_Hat + uu___41 uu___42 in + FStarC_Pprint.op_Hat_Hat uu___39 + uu___40 in + (FStarC_Getopt.noshort, + "defensive", + (EnumStr + ["no"; + "warn"; + "error"; + "abort"]), uu___38) in + let uu___38 = + let uu___39 = + let uu___40 = + let uu___41 = + text + "Output the transitive closure of the full dependency graph in three formats:" in + let uu___42 = + let uu___43 = + let uu___44 = + text + "'graph': a format suitable the 'dot' tool from 'GraphViz'" in + let uu___45 = + let uu___46 = + text + "'full': a format suitable for 'make', including dependences for producing .ml and .krml files" in + let uu___47 = + let uu___48 = + text + "'make': (deprecated) a format suitable for 'make', including only dependences among source files" in + [uu___48] in + uu___46 :: uu___47 in + uu___44 :: uu___45 in + FStarC_Errors_Msg.bulleted + uu___43 in + FStarC_Pprint.op_Hat_Hat + uu___41 uu___42 in + (FStarC_Getopt.noshort, "dep", + (EnumStr + ["make"; + "graph"; + "full"; + "raw"]), uu___40) in + let uu___40 = + let uu___41 = + let uu___42 = + text + "Emit a detailed error report by asking the SMT solver many queries; will take longer" in + (FStarC_Getopt.noshort, + "detail_errors", + (Const (Bool true)), uu___42) in + let uu___42 = + let uu___43 = + let uu___44 = + text + "Emit a detailed report for proof whose unsat core fails to replay" in + (FStarC_Getopt.noshort, + "detail_hint_replay", + (Const (Bool true)), + uu___44) in + let uu___44 = + let uu___45 = + let uu___46 = + text + "Print out this module as it passes through the compiler pipeline" in + (FStarC_Getopt.noshort, + "dump_module", + (Accumulated + (SimpleStr + "module_name")), + uu___46) in + let uu___46 = + let uu___47 = + let uu___48 = + text + "Try to solve subtyping constraints at each binder (loses precision but may be slightly more efficient)" in + (FStarC_Getopt.noshort, + "eager_subtyping", + (Const (Bool true)), + uu___48) in + let uu___48 = + let uu___49 = + let uu___50 = + text + "Print context information for each error or warning raised (default false)" in + (FStarC_Getopt.noshort, + "error_contexts", + BoolStr, uu___50) in + let uu___50 = + let uu___51 = + let uu___52 = + text + "These options are set in extensions option map. Keys are usually namespaces separated by \":\". E.g., 'pulse:verbose=1;my:extension:option=xyz;foo:bar=baz'. These options are typically interpreted by extensions. Any later use of --ext over the same key overrides the old value. An entry 'e' that is not of the form 'a=b' is treated as 'e=1', i.e., 'e' associated with string \"1\"." in + (FStarC_Getopt.noshort, + "ext", + (PostProcessed + ((fun o -> + let parse_ext + s = + let exts = + FStarC_Compiler_Util.split + s ";" in + FStarC_Compiler_List.collect + (fun s1 + -> + match + FStarC_Compiler_Util.split + s1 "=" + with + | + k::v::[] + -> + [(k, v)] + | + uu___53 + -> + [ + (s1, "1")]) + exts in + (let uu___54 + = + let uu___55 + = + as_comma_string_list + o in + FStarC_Compiler_List.collect + parse_ext + uu___55 in + FStarC_Compiler_List.iter + ( + fun + uu___55 + -> + match uu___55 + with + | + (k, v) -> + FStarC_Options_Ext.set + k v) + uu___54); + o), + (ReverseAccumulated + (SimpleStr + "extension knobs")))), + uu___52) in + let uu___52 = + let uu___53 = + let uu___54 = + text + "Extract only those modules whose names or namespaces match the provided options. 'TargetName' ranges over {OCaml, krml, FSharp, Plugin, Extension}. A 'ModuleSelector' is a space or comma-separated list of '[+|-]( * | namespace | module)'. For example --extract 'OCaml:A -A.B' --extract 'krml:A -A.C' --extract '*' means for OCaml, extract everything in the A namespace only except A.B; for krml, extract everything in the A namespace only except A.C; for everything else, extract everything. Note, the '+' is optional: --extract '+A' and --extract 'A' mean the same thing. Note also that '--extract A' applies both to a module named 'A' and to any module in the 'A' namespace Multiple uses of this option accumulate, e.g., --extract A --extract B is interpreted as --extract 'A B'." in + (FStarC_Getopt.noshort, + "extract", + (Accumulated + (SimpleStr + "One or more semicolon separated occurrences of '[TargetName:]ModuleSelector'")), + uu___54) in + let uu___54 = + let uu___55 = + let uu___56 = + text + "Deprecated: use --extract instead; Only extract the specified modules (instead of the possibly-partial dependency graph)" in + (FStarC_Getopt.noshort, + "extract_module", + (Accumulated + (PostProcessed + (pp_lowercase, + (SimpleStr + "module_name")))), + uu___56) in + let uu___56 = + let uu___57 = + let uu___58 = + text + "Deprecated: use --extract instead; Only extract modules in the specified namespace" in + (FStarC_Getopt.noshort, + "extract_namespace", + (Accumulated + (PostProcessed + (pp_lowercase, + (SimpleStr + "namespace name")))), + uu___58) in + let uu___58 = + let uu___59 = + let uu___60 = + text + "Explicitly break the abstraction imposed by the interface of any implementation file that appears on the command line (use with care!)" in + (FStarC_Getopt.noshort, + "expose_interfaces", + (Const + (Bool + true)), + uu___60) in + let uu___60 = + let uu___61 = + let uu___62 + = + text + "Format of the messages emitted by F* (default `human`)" in + (FStarC_Getopt.noshort, + "message_format", + ( + EnumStr + ["human"; + "json"]), + uu___62) in + let uu___62 = + let uu___63 + = + let uu___64 + = + text + "Don't print unification variable numbers" in + (FStarC_Getopt.noshort, + "hide_uvar_nums", + (Const + (Bool + true)), + uu___64) in + let uu___64 + = + let uu___65 + = + let uu___66 + = + text + "Read/write hints to dir/module_name.hints (instead of placing hint-file alongside source file)" in + (FStarC_Getopt.noshort, + "hint_dir", + (PostProcessed + (pp_validate_dir, + (PathStr + "dir"))), + uu___66) in + let uu___66 + = + let uu___67 + = + let uu___68 + = + text + "Read/write hints to path (instead of module-specific hints files; overrides hint_dir)" in + (FStarC_Getopt.noshort, + "hint_file", + (PathStr + "path"), + uu___68) in + let uu___68 + = + let uu___69 + = + let uu___70 + = + text + "Print information regarding hints (deprecated; use --query_stats instead)" in + (FStarC_Getopt.noshort, + "hint_info", + (Const + (Bool + true)), + uu___70) in + let uu___70 + = + let uu___71 + = + let uu___72 + = + text + "Legacy interactive mode; reads input from stdin" in + (FStarC_Getopt.noshort, + "in", + (Const + (Bool + true)), + uu___72) in + let uu___72 + = + let uu___73 + = + let uu___74 + = + text + "JSON-based interactive mode for IDEs" in + (FStarC_Getopt.noshort, + "ide", + (Const + (Bool + true)), + uu___74) in + let uu___74 + = + let uu___75 + = + let uu___76 + = + text + "Disable identifier tables in IDE mode (temporary workaround useful in Steel)" in + (FStarC_Getopt.noshort, + "ide_id_info_off", + (Const + (Bool + true)), + uu___76) in + let uu___76 + = + let uu___77 + = + let uu___78 + = + text + "Language Server Protocol-based interactive mode for IDEs" in + (FStarC_Getopt.noshort, + "lsp", + (Const + (Bool + true)), + uu___78) in + let uu___78 + = + let uu___79 + = + let uu___80 + = + text + "A directory in which to search for files included on the command line" in + (FStarC_Getopt.noshort, + "include", + (ReverseAccumulated + (PathStr + "path")), + uu___80) in + let uu___80 + = + let uu___81 + = + let uu___82 + = + text + "Parses and prettyprints the files included on the command line" in + (FStarC_Getopt.noshort, + "print", + (Const + (Bool + true)), + uu___82) in + let uu___82 + = + let uu___83 + = + let uu___84 + = + text + "Parses and prettyprints in place the files included on the command line" in + (FStarC_Getopt.noshort, + "print_in_place", + (Const + (Bool + true)), + uu___84) in + let uu___84 + = + let uu___85 + = + let uu___86 + = + text + "Force checking the files given as arguments even if they have valid checked files" in + (102, + "force", + (Const + (Bool + true)), + uu___86) in + let uu___86 + = + let uu___87 + = + let uu___88 + = + text + "Set initial_fuel and max_fuel at once" in + (FStarC_Getopt.noshort, + "fuel", + (PostProcessed + ((fun + uu___89 + -> + match uu___89 + with + | + String s + -> + let p f = + let uu___90 + = + FStarC_Compiler_Util.int_of_string + f in + Int + uu___90 in + let uu___90 + = + match + FStarC_Compiler_Util.split + s "," + with + | + f::[] -> + (f, f) + | + f1::f2::[] + -> + (f1, f2) + | + uu___91 + -> + failwith + "unexpected value for --fuel" in + (match uu___90 + with + | + (min, + max) -> + (( + let uu___92 + = p min in + set_option + "initial_fuel" + uu___92); + (let uu___93 + = p max in + set_option + "max_fuel" + uu___93); + String s)) + | + uu___90 + -> + failwith + "impos"), + (SimpleStr + "non-negative integer or pair of non-negative integers"))), + uu___88) in + let uu___88 + = + let uu___89 + = + let uu___90 + = + text + "Set initial_ifuel and max_ifuel at once" in + (FStarC_Getopt.noshort, + "ifuel", + (PostProcessed + ((fun + uu___91 + -> + match uu___91 + with + | + String s + -> + let p f = + let uu___92 + = + FStarC_Compiler_Util.int_of_string + f in + Int + uu___92 in + let uu___92 + = + match + FStarC_Compiler_Util.split + s "," + with + | + f::[] -> + (f, f) + | + f1::f2::[] + -> + (f1, f2) + | + uu___93 + -> + failwith + "unexpected value for --ifuel" in + (match uu___92 + with + | + (min, + max) -> + (( + let uu___94 + = p min in + set_option + "initial_ifuel" + uu___94); + (let uu___95 + = p max in + set_option + "max_ifuel" + uu___95); + String s)) + | + uu___92 + -> + failwith + "impos"), + (SimpleStr + "non-negative integer or pair of non-negative integers"))), + uu___90) in + let uu___90 + = + let uu___91 + = + let uu___92 + = + text + "Number of unrolling of recursive functions to try initially (default 2)" in + (FStarC_Getopt.noshort, + "initial_fuel", + (IntStr + "non-negative integer"), + uu___92) in + let uu___92 + = + let uu___93 + = + let uu___94 + = + text + "Number of unrolling of inductive datatypes to try at first (default 1)" in + (FStarC_Getopt.noshort, + "initial_ifuel", + (IntStr + "non-negative integer"), + uu___94) in + let uu___94 + = + let uu___95 + = + let uu___96 + = + text + "Retain comments in the logged SMT queries (requires --log_queries or --log_failing_queries; default true)" in + (FStarC_Getopt.noshort, + "keep_query_captions", + BoolStr, + uu___96) in + let uu___96 + = + let uu___97 + = + let uu___98 + = + text + "Run the lax-type checker only (admit all verification conditions)" in + (FStarC_Getopt.noshort, + "lax", + (WithSideEffect + ((fun + uu___99 + -> + if + warn_unsafe + then + option_warning_callback + "lax" + else ()), + (Const + (Bool + true)))), + uu___98) in + let uu___98 + = + let uu___99 + = + let uu___100 + = + text + "Load OCaml module, compiling it if necessary" in + (FStarC_Getopt.noshort, + "load", + (ReverseAccumulated + (PathStr + "module")), + uu___100) in + let uu___100 + = + let uu___101 + = + let uu___102 + = + text + "Load compiled module, fails hard if the module is not already compiled" in + (FStarC_Getopt.noshort, + "load_cmxs", + (ReverseAccumulated + (PathStr + "module")), + uu___102) in + let uu___102 + = + let uu___103 + = + let uu___104 + = + text + "Print types computed for data/val/let-bindings" in + (FStarC_Getopt.noshort, + "log_types", + (Const + (Bool + true)), + uu___104) in + let uu___104 + = + let uu___105 + = + let uu___106 + = + text + "Log the Z3 queries in several queries-*.smt2 files, as we go" in + (FStarC_Getopt.noshort, + "log_queries", + (Const + (Bool + true)), + uu___106) in + let uu___106 + = + let uu___107 + = + let uu___108 + = + text + "As --log_queries, but only save the failing queries. Each query is\n saved in its own file regardless of whether they were checked during the\n same invocation. The SMT2 file names begin with \"failedQueries\"" in + (FStarC_Getopt.noshort, + "log_failing_queries", + (Const + (Bool + true)), + uu___108) in + let uu___108 + = + let uu___109 + = + let uu___110 + = + text + "Number of unrolling of recursive functions to try at most (default 8)" in + (FStarC_Getopt.noshort, + "max_fuel", + (IntStr + "non-negative integer"), + uu___110) in + let uu___110 + = + let uu___111 + = + let uu___112 + = + text + "Number of unrolling of inductive datatypes to try at most (default 2)" in + (FStarC_Getopt.noshort, + "max_ifuel", + (IntStr + "non-negative integer"), + uu___112) in + let uu___112 + = + let uu___113 + = + let uu___114 + = + text + "Trigger various specializations for compiling the F* compiler itself (not meant for user code)" in + (FStarC_Getopt.noshort, + "MLish", + (Const + (Bool + true)), + uu___114) in + let uu___114 + = + let uu___115 + = + let uu___116 + = + text + "Set the default effect *module* for --MLish (default: FStar.Compiler.Effect)" in + (FStarC_Getopt.noshort, + "MLish_effect", + (SimpleStr + "module_name"), + uu___116) in + let uu___116 + = + let uu___117 + = + let uu___118 + = + text + "Ignore the default module search paths" in + (FStarC_Getopt.noshort, + "no_default_includes", + (Const + (Bool + true)), + uu___118) in + let uu___118 + = + let uu___119 + = + let uu___120 + = + text + "Deprecated: use --extract instead; Do not extract code from this module" in + (FStarC_Getopt.noshort, + "no_extract", + (Accumulated + (PathStr + "module name")), + uu___120) in + let uu___120 + = + let uu___121 + = + let uu___122 + = + text + "Suppress location information in the generated OCaml output (only relevant with --codegen OCaml)" in + (FStarC_Getopt.noshort, + "no_location_info", + (Const + (Bool + true)), + uu___122) in + let uu___122 + = + let uu___123 + = + let uu___124 + = + text + "Do not send any queries to the SMT solver, and fail on them instead" in + (FStarC_Getopt.noshort, + "no_smt", + (Const + (Bool + true)), + uu___124) in + let uu___124 + = + let uu___125 + = + let uu___126 + = + text + "Extract top-level pure terms after normalizing them. This can lead to very large code, but can result in more partial evaluation and compile-time specialization." in + (FStarC_Getopt.noshort, + "normalize_pure_terms_for_extraction", + (Const + (Bool + true)), + uu___126) in + let uu___126 + = + let uu___127 + = + let uu___128 + = + text + "Place KaRaMeL extraction output in file . The path can be relative or absolute and does not dependon the --odir option." in + (FStarC_Getopt.noshort, + "krmloutput", + (PathStr + "filename"), + uu___128) in + let uu___128 + = + let uu___129 + = + let uu___130 + = + text + "Place output in directory dir" in + (FStarC_Getopt.noshort, + "odir", + (PostProcessed + (pp_validate_dir, + (PathStr + "dir"))), + uu___130) in + let uu___130 + = + let uu___131 + = + let uu___132 + = + text + "Output the result of --dep into this file instead of to standard output." in + (FStarC_Getopt.noshort, + "output_deps_to", + (PathStr + "file"), + uu___132) in + let uu___132 + = + let uu___133 + = + let uu___134 + = + text + "Use a custom Prims.fst file. Do not use if you do not know exactly what you're doing." in + (FStarC_Getopt.noshort, + "prims", + (PathStr + "file"), + uu___134) in + let uu___134 + = + let uu___135 + = + let uu___136 + = + text + "Print the types of bound variables" in + (FStarC_Getopt.noshort, + "print_bound_var_types", + (Const + (Bool + true)), + uu___136) in + let uu___136 + = + let uu___137 + = + let uu___138 + = + text + "Print inferred predicate transformers for all computation types" in + (FStarC_Getopt.noshort, + "print_effect_args", + (Const + (Bool + true)), + uu___138) in + let uu___138 + = + let uu___139 + = + let uu___140 + = + text + "Print the errors generated by declarations marked with expect_failure, useful for debugging error locations" in + (FStarC_Getopt.noshort, + "print_expected_failures", + (Const + (Bool + true)), + uu___140) in + let uu___140 + = + let uu___141 + = + let uu___142 + = + text + "Print full names of variables" in + (FStarC_Getopt.noshort, + "print_full_names", + (Const + (Bool + true)), + uu___142) in + let uu___142 + = + let uu___143 + = + let uu___144 + = + text + "Print implicit arguments" in + (FStarC_Getopt.noshort, + "print_implicits", + (Const + (Bool + true)), + uu___144) in + let uu___144 + = + let uu___145 + = + let uu___146 + = + text + "Print universes" in + (FStarC_Getopt.noshort, + "print_universes", + (Const + (Bool + true)), + uu___146) in + let uu___146 + = + let uu___147 + = + let uu___148 + = + text + "Print Z3 statistics for each SMT query (details such as relevant modules, facts, etc. for each proof)" in + (FStarC_Getopt.noshort, + "print_z3_statistics", + (Const + (Bool + true)), + uu___148) in + let uu___148 + = + let uu___149 + = + let uu___150 + = + text + "Print full names (deprecated; use --print_full_names instead)" in + (FStarC_Getopt.noshort, + "prn", + (Const + (Bool + true)), + uu___150) in + let uu___150 + = + let uu___151 + = + let uu___152 + = + text + "Proof recovery mode: before failing an SMT query, retry 3 times, increasing rlimits. If the query goes through after retrying, verification will succeed, but a warning will be emitted. This feature is useful to restore a project after some change to its libraries or F* upgrade. Importantly, then, this option cannot be used in a pragma (#set-options, etc)." in + (FStarC_Getopt.noshort, + "proof_recovery", + (Const + (Bool + true)), + uu___152) in + let uu___152 + = + let uu___153 + = + let uu___154 + = + let uu___155 + = + text + "Repeats SMT queries to check for robustness" in + let uu___156 + = + let uu___157 + = + let uu___158 + = + let uu___159 + = + text + "--quake N/M repeats each query checks that it succeeds at least N out of M times, aborting early if possible" in + let uu___160 + = + let uu___161 + = + text + "--quake N/M/k works as above, except it will unconditionally run M times" in + let uu___162 + = + let uu___163 + = + text + "--quake N is an alias for --quake N/N" in + let uu___164 + = + let uu___165 + = + text + "--quake N/k is an alias for --quake N/N/k" in + [uu___165] in + uu___163 + :: + uu___164 in + uu___161 + :: + uu___162 in + uu___159 + :: + uu___160 in + FStarC_Errors_Msg.bulleted + uu___158 in + let uu___158 + = + text + "Using --quake disables --retry. When quake testing, queries are not splitted for error reporting unless '--split_queries always' is given. Queries from the smt_sync tactic are not quake-tested." in + FStarC_Pprint.op_Hat_Hat + uu___157 + uu___158 in + FStarC_Pprint.op_Hat_Hat + uu___155 + uu___156 in + (FStarC_Getopt.noshort, + "quake", + (PostProcessed + ((fun + uu___155 + -> + match uu___155 + with + | + String s + -> + let uu___156 + = + interp_quake_arg + s in + (match uu___156 + with + | + (min, + max, k) + -> + (set_option + "quake_lo" + (Int min); + set_option + "quake_hi" + (Int max); + set_option + "quake_keep" + (Bool k); + set_option + "retry" + (Bool + false); + String s)) + | + uu___156 + -> + failwith + "impos"), + (SimpleStr + "positive integer or pair of positive integers"))), + uu___154) in + let uu___154 + = + let uu___155 + = + let uu___156 + = + text + "Keep a running cache of SMT queries to make verification faster. Only available in the interactive mode. NOTE: This feature is experimental and potentially unsound! Hence why\n it is not allowed in batch mode (where it is also less useful). If you\n find a query that is mistakenly accepted with the cache, please\n report a bug to the F* issue tracker on GitHub." in + (FStarC_Getopt.noshort, + "query_cache", + (Const + (Bool + true)), + uu___156) in + let uu___156 + = + let uu___157 + = + let uu___158 + = + text + "Print SMT query statistics" in + (FStarC_Getopt.noshort, + "query_stats", + (Const + (Bool + true)), + uu___158) in + let uu___158 + = + let uu___159 + = + let uu___160 + = + text + "Read a checked file and dump it to standard output." in + (FStarC_Getopt.noshort, + "read_checked_file", + (PathStr + "path"), + uu___160) in + let uu___160 + = + let uu___161 + = + let uu___162 + = + text + "Read a Karamel binary file and dump it to standard output." in + (FStarC_Getopt.noshort, + "read_krml_file", + (PathStr + "path"), + uu___162) in + let uu___162 + = + let uu___163 + = + let uu___164 + = + text + "Record a database of hints for efficient proof replay" in + (FStarC_Getopt.noshort, + "record_hints", + (Const + (Bool + true)), + uu___164) in + let uu___164 + = + let uu___165 + = + let uu___166 + = + text + "Record the state of options used to check each sigelt, useful for the `check_with` attribute and metaprogramming. Note that this implies a performance hit and increases the size of checked files." in + (FStarC_Getopt.noshort, + "record_options", + (Const + (Bool + true)), + uu___166) in + let uu___166 + = + let uu___167 + = + let uu___168 + = + text + "Retry each SMT query N times and succeed on the first try. Using --retry disables --quake." in + (FStarC_Getopt.noshort, + "retry", + (PostProcessed + ((fun + uu___169 + -> + match uu___169 + with + | + Int i -> + (set_option + "quake_lo" + (Int + Prims.int_one); + set_option + "quake_hi" + (Int i); + set_option + "quake_keep" + (Bool + false); + set_option + "retry" + (Bool + true); + Bool true) + | + uu___170 + -> + failwith + "impos"), + (IntStr + "positive integer"))), + uu___168) in + let uu___168 + = + let uu___169 + = + let uu___170 + = + text + "Optimistically, attempt using the recorded hint for toplevel_name (a top-level name in the current module) when trying to verify some other term 'g'" in + (FStarC_Getopt.noshort, + "reuse_hint_for", + (SimpleStr + "toplevel_name"), + uu___170) in + let uu___170 + = + let uu___171 + = + let uu___172 + = + text + "Report every use of an escape hatch, include assume, admit, etc." in + (FStarC_Getopt.noshort, + "report_assumes", + (EnumStr + ["warn"; + "error"]), + uu___172) in + let uu___172 + = + let uu___173 + = + let uu___174 + = + text + "Disable all non-critical output" in + (FStarC_Getopt.noshort, + "silent", + (Const + (Bool + true)), + uu___174) in + let uu___174 + = + let uu___175 + = + let uu___176 + = + text + "Path to the Z3 SMT solver (we could eventually support other solvers)" in + (FStarC_Getopt.noshort, + "smt", + (PathStr + "path"), + uu___176) in + let uu___176 + = + let uu___177 + = + let uu___178 + = + text + "Toggle a peephole optimization that eliminates redundant uses of boxing/unboxing in the SMT encoding (default 'false')" in + (FStarC_Getopt.noshort, + "smtencoding.elim_box", + BoolStr, + uu___178) in + let uu___178 + = + let uu___179 + = + let uu___180 + = + let uu___181 + = + text + "Control the representation of non-linear arithmetic functions in the SMT encoding:" in + let uu___182 + = + let uu___183 + = + let uu___184 + = + let uu___185 + = + text + "if 'boxwrap' use 'Prims.op_Multiply, Prims.op_Division, Prims.op_Modulus'" in + let uu___186 + = + let uu___187 + = + text + "if 'native' use '*, div, mod'" in + let uu___188 + = + let uu___189 + = + text + "if 'wrapped' use '_mul, _div, _mod : Int*Int -> Int'" in + [uu___189] in + uu___187 + :: + uu___188 in + uu___185 + :: + uu___186 in + FStarC_Errors_Msg.bulleted + uu___184 in + let uu___184 + = + text + "(default 'boxwrap')" in + FStarC_Pprint.op_Hat_Hat + uu___183 + uu___184 in + FStarC_Pprint.op_Hat_Hat + uu___181 + uu___182 in + (FStarC_Getopt.noshort, + "smtencoding.nl_arith_repr", + (EnumStr + ["native"; + "wrapped"; + "boxwrap"]), + uu___180) in + let uu___180 + = + let uu___181 + = + let uu___182 + = + let uu___183 + = + text + "Toggle the representation of linear arithmetic functions in the SMT encoding:" in + let uu___184 + = + let uu___185 + = + let uu___186 + = + let uu___187 + = + text + "if 'boxwrap', use 'Prims.op_Addition, Prims.op_Subtraction, Prims.op_Minus'" in + let uu___188 + = + let uu___189 + = + text + "if 'native', use '+, -, -'" in + [uu___189] in + uu___187 + :: + uu___188 in + FStarC_Errors_Msg.bulleted + uu___186 in + let uu___186 + = + text + "(default 'boxwrap')" in + FStarC_Pprint.op_Hat_Hat + uu___185 + uu___186 in + FStarC_Pprint.op_Hat_Hat + uu___183 + uu___184 in + (FStarC_Getopt.noshort, + "smtencoding.l_arith_repr", + (EnumStr + ["native"; + "boxwrap"]), + uu___182) in + let uu___182 + = + let uu___183 + = + let uu___184 + = + text + "Include an axiom in the SMT encoding to introduce proof-irrelevance from a constructive proof" in + (FStarC_Getopt.noshort, + "smtencoding.valid_intro", + BoolStr, + uu___184) in + let uu___184 + = + let uu___185 + = + let uu___186 + = + text + "Include an axiom in the SMT encoding to eliminate proof-irrelevance into the existence of a proof witness" in + (FStarC_Getopt.noshort, + "smtencoding.valid_elim", + BoolStr, + uu___186) in + let uu___186 + = + let uu___187 + = + let uu___188 + = + let uu___189 + = + text + "Split SMT verification conditions into several separate queries, one per goal. Helps with localizing errors." in + let uu___190 + = + let uu___191 + = + let uu___192 + = + text + "Use 'no' to disable (this may reduce the quality of error messages)." in + let uu___193 + = + let uu___194 + = + text + "Use 'on_failure' to split queries and retry when discharging fails (the default)" in + let uu___195 + = + let uu___196 + = + text + "Use 'yes' to always split." in + [uu___196] in + uu___194 + :: + uu___195 in + uu___192 + :: + uu___193 in + FStarC_Errors_Msg.bulleted + uu___191 in + FStarC_Pprint.op_Hat_Hat + uu___189 + uu___190 in + (FStarC_Getopt.noshort, + "split_queries", + (EnumStr + ["no"; + "on_failure"; + "always"]), + uu___188) in + let uu___188 + = + let uu___189 + = + let uu___190 + = + text + "Do not use the lexical scope of tactics to improve binder names" in + (FStarC_Getopt.noshort, + "tactic_raw_binders", + (Const + (Bool + true)), + uu___190) in + let uu___190 + = + let uu___191 + = + let uu___192 + = + text + "Do not recover from metaprogramming errors, and abort if one occurs" in + (FStarC_Getopt.noshort, + "tactics_failhard", + (Const + (Bool + true)), + uu___192) in + let uu___192 + = + let uu___193 + = + let uu___194 + = + text + "Print some rough information on tactics, such as the time they take to run" in + (FStarC_Getopt.noshort, + "tactics_info", + (Const + (Bool + true)), + uu___194) in + let uu___194 + = + let uu___195 + = + let uu___196 + = + text + "Print a depth-indexed trace of tactic execution (Warning: very verbose)" in + (FStarC_Getopt.noshort, + "tactic_trace", + (Const + (Bool + true)), + uu___196) in + let uu___196 + = + let uu___197 + = + let uu___198 + = + text + "Trace tactics up to a certain binding depth" in + (FStarC_Getopt.noshort, + "tactic_trace_d", + (IntStr + "positive_integer"), + uu___198) in + let uu___198 + = + let uu___199 + = + let uu___200 + = + text + "Use NBE to evaluate metaprograms (experimental)" in + (FStarC_Getopt.noshort, + "__tactics_nbe", + (Const + (Bool + true)), + uu___200) in + let uu___200 + = + let uu___201 + = + let uu___202 + = + text + "Attempt to normalize definitions marked as tcnorm (default 'true')" in + (FStarC_Getopt.noshort, + "tcnorm", + BoolStr, + uu___202) in + let uu___202 + = + let uu___203 + = + let uu___204 + = + text + "Print the time it takes to verify each top-level definition. This is just an alias for an invocation of the profiler, so it may not work well if combined with --profile. In particular, it implies --profile_group_by_decl." in + (FStarC_Getopt.noshort, + "timing", + (Const + (Bool + true)), + uu___204) in + let uu___204 + = + let uu___205 + = + let uu___206 + = + text + "Attach stack traces on errors" in + (FStarC_Getopt.noshort, + "trace_error", + (Const + (Bool + true)), + uu___206) in + let uu___206 + = + let uu___207 + = + let uu___208 + = + text + "Emit output formatted for debugging" in + (FStarC_Getopt.noshort, + "ugly", + (Const + (Bool + true)), + uu___208) in + let uu___208 + = + let uu___209 + = + let uu___210 + = + text + "Let the SMT solver unfold inductive types to arbitrary depths (may affect verifier performance)" in + (FStarC_Getopt.noshort, + "unthrottle_inductives", + (Const + (Bool + true)), + uu___210) in + let uu___210 + = + let uu___211 + = + let uu___212 + = + text + "Allow tactics to run external processes. WARNING: checking an untrusted F* file while using this option can have disastrous effects." in + (FStarC_Getopt.noshort, + "unsafe_tactic_exec", + (Const + (Bool + true)), + uu___212) in + let uu___212 + = + let uu___213 + = + let uu___214 + = + text + "Use equality constraints when comparing higher-order types (Temporary)" in + (FStarC_Getopt.noshort, + "use_eq_at_higher_order", + (Const + (Bool + true)), + uu___214) in + let uu___214 + = + let uu___215 + = + let uu___216 + = + text + "Use a previously recorded hints database for proof replay" in + (FStarC_Getopt.noshort, + "use_hints", + (Const + (Bool + true)), + uu___216) in + let uu___216 + = + let uu___217 + = + let uu___218 + = + text + "Admit queries if their hash matches the hash recorded in the hints database" in + (FStarC_Getopt.noshort, + "use_hint_hashes", + (Const + (Bool + true)), + uu___218) in + let uu___218 + = + let uu___219 + = + let uu___220 + = + text + "Use compiled tactics from path" in + (FStarC_Getopt.noshort, + "use_native_tactics", + (PathStr + "path"), + uu___220) in + let uu___220 + = + let uu___221 + = + let uu___222 + = + text + "Do not run plugins natively and interpret them as usual instead" in + (FStarC_Getopt.noshort, + "no_plugins", + (Const + (Bool + true)), + uu___222) in + let uu___222 + = + let uu___223 + = + let uu___224 + = + text + "Do not run the tactic engine before discharging a VC" in + (FStarC_Getopt.noshort, + "no_tactics", + (Const + (Bool + true)), + uu___224) in + let uu___224 + = + let uu___225 + = + let uu___226 + = + text + "Prunes the context to include only the facts from the given namespace or fact id. Facts can be include or excluded using the [+|-] qualifier. For example --using_facts_from '* -FStarC.Reflection +FStarC.Compiler.List -FStarC.Compiler.List.Tot' will remove all facts from FStarC.Compiler.List.Tot.*, retain all remaining facts from FStarC.Compiler.List.*, remove all facts from FStarC.Reflection.*, and retain all the rest. Note, the '+' is optional: --using_facts_from 'FStarC.Compiler.List' is equivalent to --using_facts_from '+FStarC.Compiler.List'. Multiple uses of this option accumulate, e.g., --using_facts_from A --using_facts_from B is interpreted as --using_facts_from A^B." in + (FStarC_Getopt.noshort, + "using_facts_from", + (ReverseAccumulated + (SimpleStr + "One or more space-separated occurrences of '[+|-]( * | namespace | fact id)'")), + uu___226) in + let uu___226 + = + let uu___227 + = + let uu___228 + = + text + "This does nothing and will be removed" in + (FStarC_Getopt.noshort, + "__temp_fast_implicits", + (Const + (Bool + true)), + uu___228) in + let uu___228 + = + let uu___229 + = + let uu___230 + = + text + "Display version number" in + (118, + "version", + (WithSideEffect + ((fun + uu___231 + -> + display_version + (); + FStarC_Compiler_Effect.exit + Prims.int_zero), + (Const + (Bool + true)))), + uu___230) in + let uu___230 + = + let uu___231 + = + let uu___232 + = + text + "Warn when (a -> b) is desugared to (a -> Tot b)" in + (FStarC_Getopt.noshort, + "warn_default_effects", + (Const + (Bool + true)), + uu___232) in + let uu___232 + = + let uu___233 + = + let uu___234 + = + text + "Z3 command line options" in + (FStarC_Getopt.noshort, + "z3cliopt", + (ReverseAccumulated + (SimpleStr + "option")), + uu___234) in + let uu___234 + = + let uu___235 + = + let uu___236 + = + text + "Z3 options in smt2 format" in + (FStarC_Getopt.noshort, + "z3smtopt", + (ReverseAccumulated + (SimpleStr + "option")), + uu___236) in + let uu___236 + = + let uu___237 + = + let uu___238 + = + text + "Restart Z3 after each query; useful for ensuring proof robustness" in + (FStarC_Getopt.noshort, + "z3refresh", + (Const + (Bool + true)), + uu___238) in + let uu___238 + = + let uu___239 + = + let uu___240 + = + text + "Set the Z3 per-query resource limit (default 5 units, taking roughtly 5s)" in + (FStarC_Getopt.noshort, + "z3rlimit", + (IntStr + "positive_integer"), + uu___240) in + let uu___240 + = + let uu___241 + = + let uu___242 + = + text + "Set the Z3 per-query resource limit multiplier. This is useful when, say, regenerating hints and you want to be more lax. (default 1)" in + (FStarC_Getopt.noshort, + "z3rlimit_factor", + (IntStr + "positive_integer"), + uu___242) in + let uu___242 + = + let uu___243 + = + let uu___244 + = + text + "Set the Z3 random seed (default 0)" in + (FStarC_Getopt.noshort, + "z3seed", + (IntStr + "positive_integer"), + uu___244) in + let uu___244 + = + let uu___245 + = + let uu___246 + = + text + "Set the version of Z3 that is to be used. Default: 4.8.5" in + (FStarC_Getopt.noshort, + "z3version", + (SimpleStr + "version"), + uu___246) in + let uu___246 + = + let uu___247 + = + let uu___248 + = + text + "Don't check positivity of inductive types" in + (FStarC_Getopt.noshort, + "__no_positivity", + (WithSideEffect + ((fun + uu___249 + -> + if + warn_unsafe + then + option_warning_callback + "__no_positivity" + else ()), + (Const + (Bool + true)))), + uu___248) in + let uu___248 + = + let uu___249 + = + let uu___250 + = + let uu___251 + = + text + "The [-warn_error] option follows the OCaml syntax, namely:" in + let uu___252 + = + let uu___253 + = + let uu___254 + = + text + "[r] is a range of warnings (either a number [n], or a range [n..n])" in + let uu___255 + = + let uu___256 + = + text + "[-r] silences range [r]" in + let uu___257 + = + let uu___258 + = + text + "[+r] enables range [r] as warnings (NOTE: \"enabling\" an error will downgrade it to a warning)" in + let uu___259 + = + let uu___260 + = + text + "[@r] makes range [r] fatal." in + [uu___260] in + uu___258 + :: + uu___259 in + uu___256 + :: + uu___257 in + uu___254 + :: + uu___255 in + FStarC_Errors_Msg.bulleted + uu___253 in + FStarC_Pprint.op_Hat_Hat + uu___251 + uu___252 in + (FStarC_Getopt.noshort, + "warn_error", + (ReverseAccumulated + (SimpleStr + "")), + uu___250) in + let uu___250 + = + let uu___251 + = + let uu___252 + = + text + "Use normalization by evaluation as the default normalization strategy (default 'false')" in + (FStarC_Getopt.noshort, + "use_nbe", + BoolStr, + uu___252) in + let uu___252 + = + let uu___253 + = + let uu___254 + = + text + "Use normalization by evaluation for normalizing terms before extraction (default 'false')" in + (FStarC_Getopt.noshort, + "use_nbe_for_extraction", + BoolStr, + uu___254) in + let uu___254 + = + let uu___255 + = + let uu___256 + = + text + "Enforce trivial preconditions for unannotated effectful functions (default 'true')" in + (FStarC_Getopt.noshort, + "trivial_pre_for_unannotated_effectful_fns", + BoolStr, + uu___256) in + let uu___256 + = + let uu___257 + = + let uu___258 + = + text + "Debug messages for embeddings/unembeddings of natively compiled terms" in + (FStarC_Getopt.noshort, + "__debug_embedding", + (WithSideEffect + ((fun + uu___259 + -> + FStarC_Compiler_Effect.op_Colon_Equals + debug_embedding + true), + (Const + (Bool + true)))), + uu___258) in + let uu___258 + = + let uu___259 + = + let uu___260 + = + text + "Eagerly embed and unembed terms to primitive operations and plugins: not recommended except for benchmarking" in + (FStarC_Getopt.noshort, + "eager_embedding", + (WithSideEffect + ((fun + uu___261 + -> + FStarC_Compiler_Effect.op_Colon_Equals + eager_embedding + true), + (Const + (Bool + true)))), + uu___260) in + let uu___260 + = + let uu___261 + = + let uu___262 + = + text + "Emit profiles grouped by declaration rather than by module" in + (FStarC_Getopt.noshort, + "profile_group_by_decl", + (Const + (Bool + true)), + uu___262) in + let uu___262 + = + let uu___263 + = + let uu___264 + = + text + "Specific source locations in the compiler are instrumented with profiling counters. Pass `--profile_component FStarC.TypeChecker` to enable all counters in the FStarC.TypeChecker namespace. This option is a module or namespace selector, like many other options (e.g., `--extract`)" in + (FStarC_Getopt.noshort, + "profile_component", + (Accumulated + (SimpleStr + "One or more space-separated occurrences of '[+|-]( * | namespace | module | identifier)'")), + uu___264) in + let uu___264 + = + let uu___265 + = + let uu___266 + = + text + "Profiling can be enabled when the compiler is processing a given set of source modules. Pass `--profile FStar.Pervasives` to enable profiling when the compiler is processing any module in FStar.Pervasives. This option is a module or namespace selector, like many other options (e.g., `--extract`)" in + (FStarC_Getopt.noshort, + "profile", + (Accumulated + (SimpleStr + "One or more space-separated occurrences of '[+|-]( * | namespace | module)'")), + uu___266) in + let uu___266 + = + let uu___267 + = + let uu___268 + = + text + "Display this information" in + (104, + "help", + (WithSideEffect + ((fun + uu___269 + -> + ( + let uu___271 + = + specs + warn_unsafe in + display_usage_aux + uu___271); + FStarC_Compiler_Effect.exit + Prims.int_zero), + (Const + (Bool + true)))), + uu___268) in + let uu___268 + = + let uu___269 + = + let uu___270 + = + text + "List all debug keys and exit" in + (FStarC_Getopt.noshort, + "list_debug_keys", + (WithSideEffect + ((fun + uu___271 + -> + display_debug_keys + (); + FStarC_Compiler_Effect.exit + Prims.int_zero), + (Const + (Bool + true)))), + uu___270) in + let uu___270 + = + let uu___271 + = + let uu___272 + = + text + "List all registered plugins and exit" in + (FStarC_Getopt.noshort, + "list_plugins", + (Const + (Bool + true)), + uu___272) in + let uu___272 + = + let uu___273 + = + let uu___274 + = + text + "Print the root of the F* installation and exit" in + (FStarC_Getopt.noshort, + "locate", + (Const + (Bool + true)), + uu___274) in + let uu___274 + = + let uu___275 + = + let uu___276 + = + text + "Print the root of the F* library and exit" in + (FStarC_Getopt.noshort, + "locate_lib", + (Const + (Bool + true)), + uu___276) in + let uu___276 + = + let uu___277 + = + let uu___278 + = + text + "Print the root of the built OCaml F* library and exit" in + (FStarC_Getopt.noshort, + "locate_ocaml", + (Const + (Bool + true)), + uu___278) in + [uu___277] in + uu___275 + :: + uu___276 in + uu___273 + :: + uu___274 in + uu___271 + :: + uu___272 in + uu___269 + :: + uu___270 in + uu___267 + :: + uu___268 in + uu___265 + :: + uu___266 in + uu___263 + :: + uu___264 in + uu___261 + :: + uu___262 in + uu___259 + :: + uu___260 in + uu___257 + :: + uu___258 in + uu___255 + :: + uu___256 in + uu___253 + :: + uu___254 in + uu___251 + :: + uu___252 in + uu___249 + :: + uu___250 in + uu___247 + :: + uu___248 in + uu___245 + :: + uu___246 in + uu___243 + :: + uu___244 in + uu___241 + :: + uu___242 in + uu___239 + :: + uu___240 in + uu___237 + :: + uu___238 in + uu___235 + :: + uu___236 in + uu___233 + :: + uu___234 in + uu___231 + :: + uu___232 in + uu___229 + :: + uu___230 in + uu___227 + :: + uu___228 in + uu___225 + :: + uu___226 in + uu___223 + :: + uu___224 in + uu___221 + :: + uu___222 in + uu___219 + :: + uu___220 in + uu___217 + :: + uu___218 in + uu___215 + :: + uu___216 in + uu___213 + :: + uu___214 in + uu___211 + :: + uu___212 in + uu___209 + :: + uu___210 in + uu___207 + :: + uu___208 in + uu___205 + :: + uu___206 in + uu___203 + :: + uu___204 in + uu___201 + :: + uu___202 in + uu___199 + :: + uu___200 in + uu___197 + :: + uu___198 in + uu___195 + :: + uu___196 in + uu___193 + :: + uu___194 in + uu___191 + :: + uu___192 in + uu___189 + :: + uu___190 in + uu___187 + :: + uu___188 in + uu___185 + :: + uu___186 in + uu___183 + :: + uu___184 in + uu___181 + :: + uu___182 in + uu___179 + :: + uu___180 in + uu___177 + :: + uu___178 in + uu___175 + :: + uu___176 in + uu___173 + :: + uu___174 in + uu___171 + :: + uu___172 in + uu___169 + :: + uu___170 in + uu___167 + :: + uu___168 in + uu___165 + :: + uu___166 in + uu___163 + :: + uu___164 in + uu___161 + :: + uu___162 in + uu___159 + :: + uu___160 in + uu___157 + :: + uu___158 in + uu___155 + :: + uu___156 in + uu___153 + :: + uu___154 in + uu___151 + :: + uu___152 in + uu___149 + :: + uu___150 in + uu___147 + :: + uu___148 in + uu___145 + :: + uu___146 in + uu___143 + :: + uu___144 in + uu___141 + :: + uu___142 in + uu___139 + :: + uu___140 in + uu___137 + :: + uu___138 in + uu___135 + :: + uu___136 in + uu___133 + :: + uu___134 in + uu___131 + :: + uu___132 in + uu___129 + :: + uu___130 in + uu___127 + :: + uu___128 in + uu___125 + :: + uu___126 in + uu___123 + :: + uu___124 in + uu___121 + :: + uu___122 in + uu___119 + :: + uu___120 in + uu___117 + :: + uu___118 in + uu___115 + :: + uu___116 in + uu___113 + :: + uu___114 in + uu___111 + :: + uu___112 in + uu___109 + :: + uu___110 in + uu___107 + :: + uu___108 in + uu___105 + :: + uu___106 in + uu___103 + :: + uu___104 in + uu___101 + :: + uu___102 in + uu___99 + :: + uu___100 in + uu___97 + :: + uu___98 in + uu___95 + :: + uu___96 in + uu___93 + :: + uu___94 in + uu___91 + :: + uu___92 in + uu___89 + :: + uu___90 in + uu___87 + :: + uu___88 in + uu___85 + :: + uu___86 in + uu___83 + :: + uu___84 in + uu___81 + :: + uu___82 in + uu___79 + :: + uu___80 in + uu___77 + :: + uu___78 in + uu___75 + :: + uu___76 in + uu___73 + :: + uu___74 in + uu___71 + :: + uu___72 in + uu___69 + :: + uu___70 in + uu___67 + :: + uu___68 in + uu___65 + :: + uu___66 in + uu___63 :: + uu___64 in + uu___61 :: + uu___62 in + uu___59 :: + uu___60 in + uu___57 :: + uu___58 in + uu___55 :: uu___56 in + uu___53 :: uu___54 in + uu___51 :: uu___52 in + uu___49 :: uu___50 in + uu___47 :: uu___48 in + uu___45 :: uu___46 in + uu___43 :: uu___44 in + uu___41 :: uu___42 in + uu___39 :: uu___40 in + uu___37 :: uu___38 in + uu___35 :: uu___36 in + uu___33 :: uu___34 in + uu___31 :: uu___32 in + uu___29 :: uu___30 in + uu___27 :: uu___28 in + uu___25 :: uu___26 in + uu___23 :: uu___24 in + uu___21 :: uu___22 in + uu___19 :: uu___20 in + uu___17 :: uu___18 in + uu___15 :: uu___16 in + uu___13 :: uu___14 in + uu___11 :: uu___12 in + uu___9 :: uu___10 in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___ :: uu___2 +and (specs : + Prims.bool -> (FStarC_Getopt.opt * FStarC_Pprint.document) Prims.list) = + fun warn_unsafe -> + let uu___ = specs_with_types warn_unsafe in + FStarC_Compiler_List.map + (fun uu___2 -> + match uu___2 with + | (short, long, typ, doc) -> + let uu___3 = + let uu___4 = + let uu___5 = arg_spec_of_opt_type long typ in + (short, long, uu___5) in + mk_spec uu___4 in + (uu___3, doc)) uu___ +let (settable : Prims.string -> Prims.bool) = + fun uu___ -> + match uu___ with + | "__temp_fast_implicits" -> true + | "abort_on" -> true + | "admit_except" -> true + | "admit_smt_queries" -> true + | "compat_pre_core" -> true + | "compat_pre_typed_indexed_effects" -> true + | "disallow_unification_guards" -> true + | "debug" -> true + | "debug_all" -> true + | "debug_all_modules" -> true + | "defensive" -> true + | "detail_errors" -> true + | "detail_hint_replay" -> true + | "eager_subtyping" -> true + | "error_contexts" -> true + | "hide_uvar_nums" -> true + | "hint_dir" -> true + | "hint_file" -> true + | "hint_info" -> true + | "fuel" -> true + | "ext" -> true + | "ifuel" -> true + | "initial_fuel" -> true + | "initial_ifuel" -> true + | "ide_id_info_off" -> true + | "keep_query_captions" -> true + | "load" -> true + | "load_cmxs" -> true + | "log_queries" -> true + | "log_failing_queries" -> true + | "log_types" -> true + | "max_fuel" -> true + | "max_ifuel" -> true + | "no_plugins" -> true + | "__no_positivity" -> true + | "normalize_pure_terms_for_extraction" -> true + | "no_smt" -> true + | "no_tactics" -> true + | "print_bound_var_types" -> true + | "print_effect_args" -> true + | "print_expected_failures" -> true + | "print_full_names" -> true + | "print_implicits" -> true + | "print_universes" -> true + | "print_z3_statistics" -> true + | "prn" -> true + | "quake_lo" -> true + | "quake_hi" -> true + | "quake_keep" -> true + | "quake" -> true + | "query_cache" -> true + | "query_stats" -> true + | "record_options" -> true + | "retry" -> true + | "reuse_hint_for" -> true + | "report_assumes" -> true + | "silent" -> true + | "smtencoding.elim_box" -> true + | "smtencoding.l_arith_repr" -> true + | "smtencoding.nl_arith_repr" -> true + | "smtencoding.valid_intro" -> true + | "smtencoding.valid_elim" -> true + | "split_queries" -> true + | "tactic_raw_binders" -> true + | "tactics_failhard" -> true + | "tactics_info" -> true + | "__tactics_nbe" -> true + | "tactic_trace" -> true + | "tactic_trace_d" -> true + | "tcnorm" -> true + | "timing" -> true + | "trace_error" -> true + | "ugly" -> true + | "unthrottle_inductives" -> true + | "use_eq_at_higher_order" -> true + | "using_facts_from" -> true + | "warn_error" -> true + | "z3cliopt" -> true + | "z3smtopt" -> true + | "z3refresh" -> true + | "z3rlimit" -> true + | "z3rlimit_factor" -> true + | "z3seed" -> true + | "z3version" -> true + | "trivial_pre_for_unannotated_effectful_fns" -> true + | "profile_group_by_decl" -> true + | "profile_component" -> true + | "profile" -> true + | uu___2 -> false +let (all_specs : (FStarC_Getopt.opt * FStarC_Pprint.document) Prims.list) = + specs true +let (all_specs_getopt : FStarC_Getopt.opt Prims.list) = + FStarC_Compiler_List.map FStar_Pervasives_Native.fst all_specs +let (all_specs_with_types : + (FStarC_BaseTypes.char * Prims.string * opt_type * FStarC_Pprint.document) + Prims.list) + = specs_with_types true +let (settable_specs : + ((FStarC_BaseTypes.char * Prims.string * unit FStarC_Getopt.opt_variant) * + FStarC_Pprint.document) Prims.list) + = + FStarC_Compiler_List.filter + (fun uu___ -> + match uu___ with | ((uu___2, x, uu___3), uu___4) -> settable x) + all_specs +let (uu___2 : + (((unit -> FStarC_Getopt.parse_cmdline_res) -> unit) * + (unit -> FStarC_Getopt.parse_cmdline_res))) + = + let callback = FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None in + let set1 f = + FStarC_Compiler_Effect.op_Colon_Equals callback + (FStar_Pervasives_Native.Some f) in + let call uu___ = + let uu___3 = FStarC_Compiler_Effect.op_Bang callback in + match uu___3 with + | FStar_Pervasives_Native.None -> + failwith "Error flags callback not yet set" + | FStar_Pervasives_Native.Some f -> f () in + (set1, call) +let (set_error_flags_callback_aux : + (unit -> FStarC_Getopt.parse_cmdline_res) -> unit) = + match uu___2 with + | (set_error_flags_callback_aux1, set_error_flags) -> + set_error_flags_callback_aux1 +let (set_error_flags : unit -> FStarC_Getopt.parse_cmdline_res) = + match uu___2 with + | (set_error_flags_callback_aux1, set_error_flags1) -> set_error_flags1 +let (set_error_flags_callback : + (unit -> FStarC_Getopt.parse_cmdline_res) -> unit) = + set_error_flags_callback_aux +let (display_usage : unit -> unit) = fun uu___ -> display_usage_aux all_specs +let (fstar_bin_directory : Prims.string) = + FStarC_Compiler_Util.get_exec_dir () +let (file_list_ : Prims.string Prims.list FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref [] +let rec (parse_filename_arg : + FStarC_Getopt.opt Prims.list -> + Prims.bool -> Prims.string -> FStarC_Getopt.parse_cmdline_res) + = + fun specs1 -> + fun enable_filenames -> + fun arg -> + if FStarC_Compiler_Util.starts_with arg "@" + then + let filename = + FStarC_Compiler_Util.substring_from arg Prims.int_one in + let lines = FStarC_Compiler_Util.file_get_lines filename in + FStarC_Getopt.parse_list specs1 + (parse_filename_arg specs1 enable_filenames) lines + else + (if enable_filenames + then + (let uu___4 = + let uu___5 = FStarC_Compiler_Effect.op_Bang file_list_ in + FStarC_Compiler_List.op_At uu___5 [arg] in + FStarC_Compiler_Effect.op_Colon_Equals file_list_ uu___4) + else (); + FStarC_Getopt.Success) +let (parse_cmd_line : + unit -> (FStarC_Getopt.parse_cmdline_res * Prims.string Prims.list)) = + fun uu___ -> + let res = + FStarC_Getopt.parse_cmdline all_specs_getopt + (parse_filename_arg all_specs_getopt true) in + let res1 = + if res = FStarC_Getopt.Success then set_error_flags () else res in + let uu___3 = + let uu___4 = FStarC_Compiler_Effect.op_Bang file_list_ in + FStarC_Compiler_List.map FStarC_Common.try_convert_file_name_to_mixed + uu___4 in + (res1, uu___3) +let (file_list : unit -> Prims.string Prims.list) = + fun uu___ -> FStarC_Compiler_Effect.op_Bang file_list_ +let (restore_cmd_line_options : + Prims.bool -> FStarC_Getopt.parse_cmdline_res) = + fun should_clear -> + let old_verify_module = get_verify_module () in + if should_clear then clear () else init (); + (let specs1 = + let uu___3 = specs false in + FStarC_Compiler_List.map FStar_Pervasives_Native.fst uu___3 in + let r = + FStarC_Getopt.parse_cmdline specs1 (parse_filename_arg specs1 false) in + (let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Compiler_List.map (fun uu___7 -> String uu___7) + old_verify_module in + List uu___6 in + ("verify_module", uu___5) in + set_option' uu___4); + r) +let (module_name_of_file_name : Prims.string -> Prims.string) = + fun f -> + let f1 = FStarC_Compiler_Util.basename f in + let f2 = + let uu___ = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Compiler_Util.get_file_extension f1 in + FStarC_Compiler_String.length uu___5 in + (FStarC_Compiler_String.length f1) - uu___4 in + uu___3 - Prims.int_one in + FStarC_Compiler_String.substring f1 Prims.int_zero uu___ in + FStarC_Compiler_String.lowercase f2 +let (should_check : Prims.string -> Prims.bool) = + fun m -> + let l = get_verify_module () in + FStarC_Compiler_List.contains (FStarC_Compiler_String.lowercase m) l +let (should_verify : Prims.string -> Prims.bool) = + fun m -> + (let uu___ = get_lax () in Prims.op_Negation uu___) && (should_check m) +let (should_check_file : Prims.string -> Prims.bool) = + fun fn -> let uu___ = module_name_of_file_name fn in should_check uu___ +let (should_verify_file : Prims.string -> Prims.bool) = + fun fn -> let uu___ = module_name_of_file_name fn in should_verify uu___ +let (module_name_eq : Prims.string -> Prims.string -> Prims.bool) = + fun m1 -> + fun m2 -> + (FStarC_Compiler_String.lowercase m1) = + (FStarC_Compiler_String.lowercase m2) +let (should_print_message : Prims.string -> Prims.bool) = + fun m -> + let uu___ = should_verify m in if uu___ then m <> "Prims" else false +let (read_fstar_include : + Prims.string -> Prims.string Prims.list FStar_Pervasives_Native.option) = + fun fn -> + try + (fun uu___ -> + match () with + | () -> + let s = FStarC_Compiler_Util.file_get_contents fn in + let subdirs = + FStarC_Compiler_List.filter + (fun s1 -> + (s1 <> "") && + (let uu___3 = + let uu___4 = + FStarC_Compiler_String.get s1 Prims.int_zero in + uu___4 = 35 in + Prims.op_Negation uu___3)) + (FStarC_Compiler_String.split [10] s) in + FStar_Pervasives_Native.Some subdirs) () + with + | uu___ -> + ((let uu___4 = FStarC_Compiler_String.op_Hat "Could not read " fn in + failwith uu___4); + FStar_Pervasives_Native.None) +let rec (expand_include_d : Prims.string -> Prims.string Prims.list) = + fun dirname -> + let dot_inc_path = FStarC_Compiler_String.op_Hat dirname "/fstar.include" in + if FStarC_Compiler_Util.file_exists dot_inc_path + then + let subdirs = + let uu___ = read_fstar_include dot_inc_path in + FStar_Pervasives_Native.__proj__Some__item__v uu___ in + let uu___ = + FStarC_Compiler_List.collect + (fun subd -> + let uu___3 = + let uu___4 = FStarC_Compiler_String.op_Hat "/" subd in + FStarC_Compiler_String.op_Hat dirname uu___4 in + expand_include_d uu___3) subdirs in + dirname :: uu___ + else [dirname] +let (expand_include_ds : Prims.string Prims.list -> Prims.string Prims.list) + = fun dirnames -> FStarC_Compiler_List.collect expand_include_d dirnames +let (lib_root : unit -> Prims.string FStar_Pervasives_Native.option) = + fun uu___ -> + let uu___3 = get_no_default_includes () in + if uu___3 + then FStar_Pervasives_Native.None + else + (let uu___5 = + FStarC_Compiler_Util.expand_environment_variable "FSTAR_LIB" in + match uu___5 with + | FStar_Pervasives_Native.Some s -> FStar_Pervasives_Native.Some s + | FStar_Pervasives_Native.None -> + let uu___6 = + let uu___7 = + FStarC_Compiler_String.op_Hat fstar_bin_directory "/../ulib" in + FStarC_Compiler_Util.file_exists uu___7 in + if uu___6 + then + let uu___7 = + FStarC_Compiler_String.op_Hat fstar_bin_directory "/../ulib" in + FStar_Pervasives_Native.Some uu___7 + else + (let uu___8 = + let uu___9 = + FStarC_Compiler_String.op_Hat fstar_bin_directory + "/../lib/fstar" in + FStarC_Compiler_Util.file_exists uu___9 in + if uu___8 + then + let uu___9 = + FStarC_Compiler_String.op_Hat fstar_bin_directory + "/../lib/fstar" in + FStar_Pervasives_Native.Some uu___9 + else FStar_Pervasives_Native.None)) +let (lib_paths : unit -> Prims.string Prims.list) = + fun uu___ -> + let uu___3 = + let uu___4 = lib_root () in FStarC_Common.option_to_list uu___4 in + expand_include_ds uu___3 +let (include_path : unit -> Prims.string Prims.list) = + fun uu___ -> + let cache_dir = + let uu___3 = get_cache_dir () in + match uu___3 with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some c -> [c] in + let include_paths = + let uu___3 = get_include () in expand_include_ds uu___3 in + let uu___3 = + let uu___4 = lib_paths () in + let uu___5 = + let uu___6 = expand_include_d "." in + FStarC_Compiler_List.op_At include_paths uu___6 in + FStarC_Compiler_List.op_At uu___4 uu___5 in + FStarC_Compiler_List.op_At cache_dir uu___3 +let (custom_prims : unit -> Prims.string FStar_Pervasives_Native.option) = + fun uu___ -> get_prims () +let (prepend_output_dir : Prims.string -> Prims.string) = + fun fname -> + let uu___ = get_odir () in + match uu___ with + | FStar_Pervasives_Native.None -> fname + | FStar_Pervasives_Native.Some x -> + FStarC_Compiler_Util.join_paths x fname +let (prepend_cache_dir : Prims.string -> Prims.string) = + fun fpath -> + let uu___ = get_cache_dir () in + match uu___ with + | FStar_Pervasives_Native.None -> fpath + | FStar_Pervasives_Native.Some x -> + let uu___3 = FStarC_Compiler_Util.basename fpath in + FStarC_Compiler_Util.join_paths x uu___3 +let (path_of_text : Prims.string -> Prims.string Prims.list) = + fun text -> FStarC_Compiler_String.split [46] text +let (parse_settings : + Prims.string Prims.list -> + (Prims.string Prims.list * Prims.bool) Prims.list) + = + fun ns -> + let cache = FStarC_Compiler_Util.smap_create (Prims.of_int (31)) in + let with_cache f s = + let uu___ = FStarC_Compiler_Util.smap_try_find cache s in + match uu___ with + | FStar_Pervasives_Native.Some s1 -> s1 + | FStar_Pervasives_Native.None -> + let res = f s in (FStarC_Compiler_Util.smap_add cache s res; res) in + let parse_one_setting s = + if s = "*" + then ([], true) + else + if s = "-*" + then ([], false) + else + if FStarC_Compiler_Util.starts_with s "-" + then + (let path = + let uu___4 = + FStarC_Compiler_Util.substring_from s Prims.int_one in + path_of_text uu___4 in + (path, false)) + else + (let s1 = + if FStarC_Compiler_Util.starts_with s "+" + then FStarC_Compiler_Util.substring_from s Prims.int_one + else s in + ((path_of_text s1), true)) in + let uu___ = + FStarC_Compiler_List.collect + (fun s -> + let s1 = FStarC_Compiler_Util.trim_string s in + if s1 = "" + then [] + else + with_cache + (fun s2 -> + let s3 = FStarC_Compiler_Util.replace_char s2 32 44 in + let uu___4 = + let uu___5 = + FStarC_Compiler_List.concatMap + (fun s4 -> FStarC_Compiler_Util.split s4 ",") + (FStarC_Compiler_Util.splitlines s3) in + FStarC_Compiler_List.filter (fun s4 -> s4 <> "") uu___5 in + FStarC_Compiler_List.map parse_one_setting uu___4) s1) ns in + FStarC_Compiler_List.rev uu___ +let (admit_smt_queries : unit -> Prims.bool) = + fun uu___ -> get_admit_smt_queries () +let (admit_except : unit -> Prims.string FStar_Pervasives_Native.option) = + fun uu___ -> get_admit_except () +let (compat_pre_core_should_register : unit -> Prims.bool) = + fun uu___ -> + let uu___3 = get_compat_pre_core () in + match uu___3 with + | FStar_Pervasives_Native.Some uu___4 when uu___4 = Prims.int_zero -> + false + | uu___4 -> true +let (compat_pre_core_should_check : unit -> Prims.bool) = + fun uu___ -> + let uu___3 = get_compat_pre_core () in + match uu___3 with + | FStar_Pervasives_Native.Some uu___4 when uu___4 = Prims.int_zero -> + false + | FStar_Pervasives_Native.Some uu___4 when uu___4 = Prims.int_one -> + false + | uu___4 -> true +let (compat_pre_core_set : unit -> Prims.bool) = + fun uu___ -> + let uu___3 = get_compat_pre_core () in + match uu___3 with + | FStar_Pervasives_Native.None -> false + | uu___4 -> true +let (compat_pre_typed_indexed_effects : unit -> Prims.bool) = + fun uu___ -> get_compat_pre_typed_indexed_effects () +let (disallow_unification_guards : unit -> Prims.bool) = + fun uu___ -> get_disallow_unification_guards () +let (cache_checked_modules : unit -> Prims.bool) = + fun uu___ -> get_cache_checked_modules () +let (cache_off : unit -> Prims.bool) = fun uu___ -> get_cache_off () +let (print_cache_version : unit -> Prims.bool) = + fun uu___ -> get_print_cache_version () +let (cmi : unit -> Prims.bool) = fun uu___ -> get_cmi () +let (parse_codegen : + Prims.string -> codegen_t FStar_Pervasives_Native.option) = + fun uu___ -> + match uu___ with + | "OCaml" -> FStar_Pervasives_Native.Some OCaml + | "FSharp" -> FStar_Pervasives_Native.Some FSharp + | "krml" -> FStar_Pervasives_Native.Some Krml + | "Plugin" -> FStar_Pervasives_Native.Some Plugin + | "Extension" -> FStar_Pervasives_Native.Some Extension + | uu___3 -> FStar_Pervasives_Native.None +let (print_codegen : codegen_t -> Prims.string) = + fun uu___ -> + match uu___ with + | OCaml -> "OCaml" + | FSharp -> "FSharp" + | Krml -> "krml" + | Plugin -> "Plugin" + | Extension -> "Extension" +let (codegen : unit -> codegen_t FStar_Pervasives_Native.option) = + fun uu___ -> + let uu___3 = get_codegen () in + FStarC_Compiler_Util.map_opt uu___3 + (fun s -> + let uu___4 = parse_codegen s in FStarC_Compiler_Util.must uu___4) +let (codegen_libs : unit -> Prims.string Prims.list Prims.list) = + fun uu___ -> + let uu___3 = get_codegen_lib () in + FStarC_Compiler_List.map (fun x -> FStarC_Compiler_Util.split x ".") + uu___3 +let (profile_group_by_decl : unit -> Prims.bool) = + fun uu___ -> get_profile_group_by_decl () +let (defensive : unit -> Prims.bool) = + fun uu___ -> let uu___3 = get_defensive () in uu___3 <> "no" +let (defensive_error : unit -> Prims.bool) = + fun uu___ -> let uu___3 = get_defensive () in uu___3 = "error" +let (defensive_abort : unit -> Prims.bool) = + fun uu___ -> let uu___3 = get_defensive () in uu___3 = "abort" +let (dep : unit -> Prims.string FStar_Pervasives_Native.option) = + fun uu___ -> get_dep () +let (detail_errors : unit -> Prims.bool) = fun uu___ -> get_detail_errors () +let (detail_hint_replay : unit -> Prims.bool) = + fun uu___ -> get_detail_hint_replay () +let (any_dump_module : unit -> Prims.bool) = + fun uu___ -> let uu___3 = get_dump_module () in Prims.uu___is_Cons uu___3 +let (dump_module : Prims.string -> Prims.bool) = + fun s -> + let uu___ = get_dump_module () in + FStarC_Compiler_List.existsb (module_name_eq s) uu___ +let (eager_subtyping : unit -> Prims.bool) = + fun uu___ -> get_eager_subtyping () +let (error_contexts : unit -> Prims.bool) = + fun uu___ -> get_error_contexts () +let (expose_interfaces : unit -> Prims.bool) = + fun uu___ -> get_expose_interfaces () +let (message_format : unit -> message_format_t) = + fun uu___ -> + let uu___3 = get_message_format () in + match uu___3 with + | "human" -> Human + | "json" -> Json + | illegal -> + let uu___4 = + let uu___5 = + FStarC_Compiler_String.op_Hat illegal + "`. This should be impossible: `message_format` was supposed to be validated." in + FStarC_Compiler_String.op_Hat + "print_issue: option `message_format` was expected to be `human` or `json`, not `" + uu___5 in + failwith uu___4 +let (force : unit -> Prims.bool) = fun uu___ -> get_force () +let (full_context_dependency : unit -> Prims.bool) = fun uu___ -> true +let (hide_uvar_nums : unit -> Prims.bool) = + fun uu___ -> get_hide_uvar_nums () +let (hint_info : unit -> Prims.bool) = + fun uu___ -> (get_hint_info ()) || (get_query_stats ()) +let (hint_dir : unit -> Prims.string FStar_Pervasives_Native.option) = + fun uu___ -> get_hint_dir () +let (hint_file : unit -> Prims.string FStar_Pervasives_Native.option) = + fun uu___ -> get_hint_file () +let (hint_file_for_src : Prims.string -> Prims.string) = + fun src_filename -> + let uu___ = hint_file () in + match uu___ with + | FStar_Pervasives_Native.Some fn -> fn + | FStar_Pervasives_Native.None -> + let file_name = + let uu___3 = hint_dir () in + match uu___3 with + | FStar_Pervasives_Native.Some dir -> + let uu___4 = FStarC_Compiler_Util.basename src_filename in + FStarC_Compiler_Util.concat_dir_filename dir uu___4 + | uu___4 -> src_filename in + FStarC_Compiler_Util.format1 "%s.hints" file_name +let (ide : unit -> Prims.bool) = fun uu___ -> get_ide () +let (ide_id_info_off : unit -> Prims.bool) = + fun uu___ -> get_ide_id_info_off () +let (ide_file_name_st : + ((Prims.string -> unit) * + (unit -> Prims.string FStar_Pervasives_Native.option))) + = + let v = FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None in + let set1 f = + let uu___ = FStarC_Compiler_Effect.op_Bang v in + match uu___ with + | FStar_Pervasives_Native.None -> + FStarC_Compiler_Effect.op_Colon_Equals v + (FStar_Pervasives_Native.Some f) + | FStar_Pervasives_Native.Some uu___3 -> + failwith "ide_file_name_st already set" in + let get uu___ = FStarC_Compiler_Effect.op_Bang v in (set1, get) +let (set_ide_filename : Prims.string -> unit) = + FStar_Pervasives_Native.fst ide_file_name_st +let (ide_filename : unit -> Prims.string FStar_Pervasives_Native.option) = + FStar_Pervasives_Native.snd ide_file_name_st +let (print : unit -> Prims.bool) = fun uu___ -> get_print () +let (print_in_place : unit -> Prims.bool) = + fun uu___ -> get_print_in_place () +let (initial_fuel : unit -> Prims.int) = + fun uu___ -> + let uu___3 = get_initial_fuel () in + let uu___4 = get_max_fuel () in Prims.min uu___3 uu___4 +let (initial_ifuel : unit -> Prims.int) = + fun uu___ -> + let uu___3 = get_initial_ifuel () in + let uu___4 = get_max_ifuel () in Prims.min uu___3 uu___4 +let (interactive : unit -> Prims.bool) = + fun uu___ -> ((get_in ()) || (get_ide ())) || (get_lsp ()) +let (lax : unit -> Prims.bool) = fun uu___ -> get_lax () +let (load : unit -> Prims.string Prims.list) = fun uu___ -> get_load () +let (load_cmxs : unit -> Prims.string Prims.list) = + fun uu___ -> get_load_cmxs () +let (legacy_interactive : unit -> Prims.bool) = fun uu___ -> get_in () +let (lsp_server : unit -> Prims.bool) = fun uu___ -> get_lsp () +let (log_queries : unit -> Prims.bool) = fun uu___ -> get_log_queries () +let (log_failing_queries : unit -> Prims.bool) = + fun uu___ -> get_log_failing_queries () +let (keep_query_captions : unit -> Prims.bool) = + fun uu___ -> + (get_keep_query_captions ()) && + ((log_queries ()) || (log_failing_queries ())) +let (log_types : unit -> Prims.bool) = fun uu___ -> get_log_types () +let (max_fuel : unit -> Prims.int) = fun uu___ -> get_max_fuel () +let (max_ifuel : unit -> Prims.int) = fun uu___ -> get_max_ifuel () +let (ml_ish : unit -> Prims.bool) = fun uu___ -> get_MLish () +let (ml_ish_effect : unit -> Prims.string) = fun uu___ -> get_MLish_effect () +let (set_ml_ish : unit -> unit) = fun uu___ -> set_option "MLish" (Bool true) +let (no_default_includes : unit -> Prims.bool) = + fun uu___ -> get_no_default_includes () +let (no_extract : Prims.string -> Prims.bool) = + fun s -> + let uu___ = get_no_extract () in + FStarC_Compiler_List.existsb (module_name_eq s) uu___ +let (normalize_pure_terms_for_extraction : unit -> Prims.bool) = + fun uu___ -> get_normalize_pure_terms_for_extraction () +let (no_location_info : unit -> Prims.bool) = + fun uu___ -> get_no_location_info () +let (no_plugins : unit -> Prims.bool) = fun uu___ -> get_no_plugins () +let (no_smt : unit -> Prims.bool) = fun uu___ -> get_no_smt () +let (krmloutput : unit -> Prims.string FStar_Pervasives_Native.option) = + fun uu___ -> get_krmloutput () +let (output_dir : unit -> Prims.string FStar_Pervasives_Native.option) = + fun uu___ -> get_odir () +let (output_deps_to : unit -> Prims.string FStar_Pervasives_Native.option) = + fun uu___ -> get_output_deps_to () +let (ugly : unit -> Prims.bool) = fun uu___ -> get_ugly () +let (print_bound_var_types : unit -> Prims.bool) = + fun uu___ -> get_print_bound_var_types () +let (print_effect_args : unit -> Prims.bool) = + fun uu___ -> get_print_effect_args () +let (print_expected_failures : unit -> Prims.bool) = + fun uu___ -> get_print_expected_failures () +let (print_implicits : unit -> Prims.bool) = + fun uu___ -> get_print_implicits () +let (print_real_names : unit -> Prims.bool) = + fun uu___ -> (get_prn ()) || (get_print_full_names ()) +let (print_universes : unit -> Prims.bool) = + fun uu___ -> get_print_universes () +let (print_z3_statistics : unit -> Prims.bool) = + fun uu___ -> get_print_z3_statistics () +let (proof_recovery : unit -> Prims.bool) = + fun uu___ -> get_proof_recovery () +let (quake_lo : unit -> Prims.int) = fun uu___ -> get_quake_lo () +let (quake_hi : unit -> Prims.int) = fun uu___ -> get_quake_hi () +let (quake_keep : unit -> Prims.bool) = fun uu___ -> get_quake_keep () +let (query_cache : unit -> Prims.bool) = fun uu___ -> get_query_cache () +let (query_stats : unit -> Prims.bool) = fun uu___ -> get_query_stats () +let (read_checked_file : unit -> Prims.string FStar_Pervasives_Native.option) + = fun uu___ -> get_read_checked_file () +let (list_plugins : unit -> Prims.bool) = fun uu___ -> get_list_plugins () +let (locate : unit -> Prims.bool) = fun uu___ -> get_locate () +let (locate_lib : unit -> Prims.bool) = fun uu___ -> get_locate_lib () +let (locate_ocaml : unit -> Prims.bool) = fun uu___ -> get_locate_ocaml () +let (read_krml_file : unit -> Prims.string FStar_Pervasives_Native.option) = + fun uu___ -> get_read_krml_file () +let (record_hints : unit -> Prims.bool) = fun uu___ -> get_record_hints () +let (record_options : unit -> Prims.bool) = + fun uu___ -> get_record_options () +let (retry : unit -> Prims.bool) = fun uu___ -> get_retry () +let (reuse_hint_for : unit -> Prims.string FStar_Pervasives_Native.option) = + fun uu___ -> get_reuse_hint_for () +let (report_assumes : unit -> Prims.string FStar_Pervasives_Native.option) = + fun uu___ -> get_report_assumes () +let (silent : unit -> Prims.bool) = fun uu___ -> get_silent () +let (smt : unit -> Prims.string FStar_Pervasives_Native.option) = + fun uu___ -> get_smt () +let (smtencoding_elim_box : unit -> Prims.bool) = + fun uu___ -> get_smtencoding_elim_box () +let (smtencoding_nl_arith_native : unit -> Prims.bool) = + fun uu___ -> + let uu___3 = get_smtencoding_nl_arith_repr () in uu___3 = "native" +let (smtencoding_nl_arith_wrapped : unit -> Prims.bool) = + fun uu___ -> + let uu___3 = get_smtencoding_nl_arith_repr () in uu___3 = "wrapped" +let (smtencoding_nl_arith_default : unit -> Prims.bool) = + fun uu___ -> + let uu___3 = get_smtencoding_nl_arith_repr () in uu___3 = "boxwrap" +let (smtencoding_l_arith_native : unit -> Prims.bool) = + fun uu___ -> + let uu___3 = get_smtencoding_l_arith_repr () in uu___3 = "native" +let (smtencoding_l_arith_default : unit -> Prims.bool) = + fun uu___ -> + let uu___3 = get_smtencoding_l_arith_repr () in uu___3 = "boxwrap" +let (smtencoding_valid_intro : unit -> Prims.bool) = + fun uu___ -> get_smtencoding_valid_intro () +let (smtencoding_valid_elim : unit -> Prims.bool) = + fun uu___ -> get_smtencoding_valid_elim () +let (parse_split_queries : + Prims.string -> split_queries_t FStar_Pervasives_Native.option) = + fun s -> + match s with + | "no" -> FStar_Pervasives_Native.Some No + | "on_failure" -> FStar_Pervasives_Native.Some OnFailure + | "always" -> FStar_Pervasives_Native.Some Always + | uu___ -> FStar_Pervasives_Native.None +let (split_queries : unit -> split_queries_t) = + fun uu___ -> + let uu___3 = + let uu___4 = get_split_queries () in parse_split_queries uu___4 in + FStarC_Compiler_Util.must uu___3 +let (tactic_raw_binders : unit -> Prims.bool) = + fun uu___ -> get_tactic_raw_binders () +let (tactics_failhard : unit -> Prims.bool) = + fun uu___ -> get_tactics_failhard () +let (tactics_info : unit -> Prims.bool) = fun uu___ -> get_tactics_info () +let (tactic_trace : unit -> Prims.bool) = fun uu___ -> get_tactic_trace () +let (tactic_trace_d : unit -> Prims.int) = fun uu___ -> get_tactic_trace_d () +let (tactics_nbe : unit -> Prims.bool) = fun uu___ -> get_tactics_nbe () +let (tcnorm : unit -> Prims.bool) = fun uu___ -> get_tcnorm () +let (timing : unit -> Prims.bool) = fun uu___ -> get_timing () +let (trace_error : unit -> Prims.bool) = fun uu___ -> get_trace_error () +let (unthrottle_inductives : unit -> Prims.bool) = + fun uu___ -> get_unthrottle_inductives () +let (unsafe_tactic_exec : unit -> Prims.bool) = + fun uu___ -> get_unsafe_tactic_exec () +let (use_eq_at_higher_order : unit -> Prims.bool) = + fun uu___ -> get_use_eq_at_higher_order () +let (use_hints : unit -> Prims.bool) = fun uu___ -> get_use_hints () +let (use_hint_hashes : unit -> Prims.bool) = + fun uu___ -> get_use_hint_hashes () +let (use_native_tactics : + unit -> Prims.string FStar_Pervasives_Native.option) = + fun uu___ -> get_use_native_tactics () +let (use_tactics : unit -> Prims.bool) = + fun uu___ -> let uu___3 = get_no_tactics () in Prims.op_Negation uu___3 +let (using_facts_from : + unit -> (Prims.string Prims.list * Prims.bool) Prims.list) = + fun uu___ -> + let uu___3 = get_using_facts_from () in + match uu___3 with + | FStar_Pervasives_Native.None -> [([], true)] + | FStar_Pervasives_Native.Some ns -> parse_settings ns +let (warn_default_effects : unit -> Prims.bool) = + fun uu___ -> get_warn_default_effects () +let (warn_error : unit -> Prims.string) = + fun uu___ -> + let uu___3 = get_warn_error () in + FStarC_Compiler_String.concat " " uu___3 +let (z3_cliopt : unit -> Prims.string Prims.list) = + fun uu___ -> get_z3cliopt () +let (z3_smtopt : unit -> Prims.string Prims.list) = + fun uu___ -> get_z3smtopt () +let (z3_refresh : unit -> Prims.bool) = fun uu___ -> get_z3refresh () +let (z3_rlimit : unit -> Prims.int) = fun uu___ -> get_z3rlimit () +let (z3_rlimit_factor : unit -> Prims.int) = + fun uu___ -> get_z3rlimit_factor () +let (z3_seed : unit -> Prims.int) = fun uu___ -> get_z3seed () +let (z3_version : unit -> Prims.string) = fun uu___ -> get_z3version () +let (no_positivity : unit -> Prims.bool) = fun uu___ -> get_no_positivity () +let (use_nbe : unit -> Prims.bool) = fun uu___ -> get_use_nbe () +let (use_nbe_for_extraction : unit -> Prims.bool) = + fun uu___ -> get_use_nbe_for_extraction () +let (trivial_pre_for_unannotated_effectful_fns : unit -> Prims.bool) = + fun uu___ -> get_trivial_pre_for_unannotated_effectful_fns () +let (debug_keys : unit -> Prims.string Prims.list) = + fun uu___ -> lookup_opt "debug" as_comma_string_list +let (debug_all : unit -> Prims.bool) = + fun uu___ -> lookup_opt "debug_all" as_bool +let (debug_all_modules : unit -> Prims.bool) = + fun uu___ -> lookup_opt "debug_all_modules" as_bool +let with_saved_options : 'a . (unit -> 'a) -> 'a = + fun f -> + let uu___ = let uu___3 = trace_error () in Prims.op_Negation uu___3 in + if uu___ + then + (push (); + (let r = + try + (fun uu___4 -> + match () with + | () -> let uu___5 = f () in FStar_Pervasives.Inr uu___5) () + with | uu___4 -> FStar_Pervasives.Inl uu___4 in + pop (); + (match r with + | FStar_Pervasives.Inr v -> v + | FStar_Pervasives.Inl ex -> FStarC_Compiler_Effect.raise ex))) + else (push (); (let retv = f () in pop (); retv)) +let (module_matches_namespace_filter : + Prims.string -> Prims.string Prims.list -> Prims.bool) = + fun m -> + fun filter -> + let m1 = FStarC_Compiler_String.lowercase m in + let setting = parse_settings filter in + let m_components = path_of_text m1 in + let rec matches_path m_components1 path = + match (m_components1, path) with + | (uu___, []) -> true + | (m2::ms, p::ps) -> + (m2 = (FStarC_Compiler_String.lowercase p)) && + (matches_path ms ps) + | uu___ -> false in + let uu___ = + FStarC_Compiler_Util.try_find + (fun uu___3 -> + match uu___3 with + | (path, uu___4) -> matches_path m_components path) setting in + match uu___ with + | FStar_Pervasives_Native.None -> false + | FStar_Pervasives_Native.Some (uu___3, flag) -> flag +let (matches_namespace_filter_opt : + Prims.string -> + Prims.string Prims.list FStar_Pervasives_Native.option -> Prims.bool) + = + fun m -> + fun uu___ -> + match uu___ with + | FStar_Pervasives_Native.None -> false + | FStar_Pervasives_Native.Some filter -> + module_matches_namespace_filter m filter +type parsed_extract_setting = + { + target_specific_settings: (codegen_t * Prims.string) Prims.list ; + default_settings: Prims.string FStar_Pervasives_Native.option } +let (__proj__Mkparsed_extract_setting__item__target_specific_settings : + parsed_extract_setting -> (codegen_t * Prims.string) Prims.list) = + fun projectee -> + match projectee with + | { target_specific_settings; default_settings;_} -> + target_specific_settings +let (__proj__Mkparsed_extract_setting__item__default_settings : + parsed_extract_setting -> Prims.string FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { target_specific_settings; default_settings;_} -> default_settings +let (print_pes : parsed_extract_setting -> Prims.string) = + fun pes -> + let uu___ = + let uu___3 = + FStarC_Compiler_List.map + (fun uu___4 -> + match uu___4 with + | (tgt, s) -> + FStarC_Compiler_Util.format2 "(%s, %s)" (print_codegen tgt) + s) pes.target_specific_settings in + FStarC_Compiler_String.concat "; " uu___3 in + FStarC_Compiler_Util.format2 + "{ target_specific_settings = %s;\n\t\n default_settings = %s }" + uu___ + (match pes.default_settings with + | FStar_Pervasives_Native.None -> "None" + | FStar_Pervasives_Native.Some s -> s) +let (find_setting_for_target : + codegen_t -> + (codegen_t * Prims.string) Prims.list -> + Prims.string FStar_Pervasives_Native.option) + = + fun tgt -> + fun s -> + let uu___ = + FStarC_Compiler_Util.try_find + (fun uu___3 -> match uu___3 with | (x, uu___4) -> x = tgt) s in + match uu___ with + | FStar_Pervasives_Native.Some (uu___3, s1) -> + FStar_Pervasives_Native.Some s1 + | uu___3 -> FStar_Pervasives_Native.None +let (extract_settings : + unit -> parsed_extract_setting FStar_Pervasives_Native.option) = + let memo = + FStarC_Compiler_Util.mk_ref (FStar_Pervasives_Native.None, false) in + let merge_parsed_extract_settings p0 p1 = + let merge_setting s0 s1 = + match (s0, s1) with + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> + FStar_Pervasives_Native.None + | (FStar_Pervasives_Native.Some p, FStar_Pervasives_Native.None) -> + FStar_Pervasives_Native.Some p + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.Some p) -> + FStar_Pervasives_Native.Some p + | (FStar_Pervasives_Native.Some p01, FStar_Pervasives_Native.Some p11) + -> + let uu___ = + let uu___3 = FStarC_Compiler_String.op_Hat "," p11 in + FStarC_Compiler_String.op_Hat p01 uu___3 in + FStar_Pervasives_Native.Some uu___ in + let merge_target tgt = + let uu___ = + let uu___3 = find_setting_for_target tgt p0.target_specific_settings in + let uu___4 = find_setting_for_target tgt p1.target_specific_settings in + merge_setting uu___3 uu___4 in + match uu___ with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some x -> [(tgt, x)] in + let uu___ = + FStarC_Compiler_List.collect merge_target + [OCaml; FSharp; Krml; Plugin; Extension] in + let uu___3 = merge_setting p0.default_settings p1.default_settings in + { target_specific_settings = uu___; default_settings = uu___3 } in + fun uu___ -> + let uu___3 = FStarC_Compiler_Effect.op_Bang memo in + match uu___3 with + | (result, set1) -> + let fail msg = + display_usage (); + (let uu___5 = + FStarC_Compiler_Util.format1 + "Could not parse '%s' passed to the --extract option" msg in + failwith uu___5) in + if set1 + then result + else + (let uu___5 = get_extract () in + match uu___5 with + | FStar_Pervasives_Native.None -> + (FStarC_Compiler_Effect.op_Colon_Equals memo + (FStar_Pervasives_Native.None, true); + FStar_Pervasives_Native.None) + | FStar_Pervasives_Native.Some extract_settings1 -> + let parse_one_setting extract_setting = + let tgt_specific_settings = + FStarC_Compiler_Util.split extract_setting ";" in + let split_one t_setting = + match FStarC_Compiler_Util.split t_setting ":" with + | default_setting::[] -> + FStar_Pervasives.Inr + (FStarC_Compiler_Util.trim_string default_setting) + | target::setting::[] -> + let target1 = FStarC_Compiler_Util.trim_string target in + let uu___6 = parse_codegen target1 in + (match uu___6 with + | FStar_Pervasives_Native.None -> fail target1 + | FStar_Pervasives_Native.Some tgt -> + FStar_Pervasives.Inl + (tgt, + (FStarC_Compiler_Util.trim_string setting)) + | uu___7 -> fail t_setting) in + let settings = + FStarC_Compiler_List.map split_one tgt_specific_settings in + let fail_duplicate msg tgt = + display_usage (); + (let uu___7 = + FStarC_Compiler_Util.format2 + "Could not parse '%s'; multiple setting for %s target" + msg tgt in + failwith uu___7) in + let pes = + FStarC_Compiler_List.fold_right + (fun setting -> + fun out -> + match setting with + | FStar_Pervasives.Inr def -> + (match out.default_settings with + | FStar_Pervasives_Native.None -> + { + target_specific_settings = + (out.target_specific_settings); + default_settings = + (FStar_Pervasives_Native.Some def) + } + | FStar_Pervasives_Native.Some uu___6 -> + fail_duplicate def "default") + | FStar_Pervasives.Inl (target, setting1) -> + let uu___6 = + FStarC_Compiler_Util.try_find + (fun uu___7 -> + match uu___7 with + | (x, uu___8) -> x = target) + out.target_specific_settings in + (match uu___6 with + | FStar_Pervasives_Native.None -> + { + target_specific_settings = + ((target, setting1) :: + (out.target_specific_settings)); + default_settings = + (out.default_settings) + } + | FStar_Pervasives_Native.Some uu___7 -> + fail_duplicate setting1 + (print_codegen target))) settings + { + target_specific_settings = []; + default_settings = FStar_Pervasives_Native.None + } in + pes in + let empty_pes = + { + target_specific_settings = []; + default_settings = FStar_Pervasives_Native.None + } in + let pes = + FStarC_Compiler_List.fold_right + (fun setting -> + fun pes1 -> + let uu___6 = parse_one_setting setting in + merge_parsed_extract_settings pes1 uu___6) + extract_settings1 empty_pes in + (FStarC_Compiler_Effect.op_Colon_Equals memo + ((FStar_Pervasives_Native.Some pes), true); + FStar_Pervasives_Native.Some pes)) +let (should_extract : Prims.string -> codegen_t -> Prims.bool) = + fun m -> + fun tgt -> + let m1 = FStarC_Compiler_String.lowercase m in + if m1 = "prims" + then false + else + (let uu___3 = extract_settings () in + match uu___3 with + | FStar_Pervasives_Native.Some pes -> + ((let uu___5 = + let uu___6 = get_no_extract () in + let uu___7 = get_extract_namespace () in + let uu___8 = get_extract_module () in + (uu___6, uu___7, uu___8) in + match uu___5 with + | ([], [], []) -> () + | uu___6 -> + failwith + "Incompatible options: --extract cannot be used with --no_extract, --extract_namespace or --extract_module"); + (let tsetting = + let uu___5 = + find_setting_for_target tgt pes.target_specific_settings in + match uu___5 with + | FStar_Pervasives_Native.Some s -> s + | FStar_Pervasives_Native.None -> + (match pes.default_settings with + | FStar_Pervasives_Native.Some s -> s + | FStar_Pervasives_Native.None -> "*") in + module_matches_namespace_filter m1 [tsetting])) + | FStar_Pervasives_Native.None -> + let should_extract_namespace m2 = + let uu___4 = get_extract_namespace () in + match uu___4 with + | [] -> false + | ns -> + FStarC_Compiler_Util.for_some + (fun n -> + FStarC_Compiler_Util.starts_with m2 + (FStarC_Compiler_String.lowercase n)) ns in + let should_extract_module m2 = + let uu___4 = get_extract_module () in + match uu___4 with + | [] -> false + | l -> + FStarC_Compiler_Util.for_some + (fun n -> (FStarC_Compiler_String.lowercase n) = m2) l in + (let uu___4 = no_extract m1 in Prims.op_Negation uu___4) && + (let uu___4 = + let uu___5 = get_extract_namespace () in + let uu___6 = get_extract_module () in (uu___5, uu___6) in + (match uu___4 with + | ([], []) -> true + | uu___5 -> + (should_extract_namespace m1) || + (should_extract_module m1)))) +let (should_be_already_cached : Prims.string -> Prims.bool) = + fun m -> + (let uu___ = should_check m in Prims.op_Negation uu___) && + (let uu___ = get_already_cached () in + match uu___ with + | FStar_Pervasives_Native.None -> false + | FStar_Pervasives_Native.Some already_cached_setting -> + module_matches_namespace_filter m already_cached_setting) +let (profile_enabled : + Prims.string FStar_Pervasives_Native.option -> Prims.string -> Prims.bool) + = + fun modul_opt -> + fun phase -> + match modul_opt with + | FStar_Pervasives_Native.None -> + let uu___ = get_profile_component () in + matches_namespace_filter_opt phase uu___ + | FStar_Pervasives_Native.Some modul -> + ((let uu___ = get_profile () in + matches_namespace_filter_opt modul uu___) && + (let uu___ = get_profile_component () in + matches_namespace_filter_opt phase uu___)) + || + (((timing ()) && + (phase = "FStarC.TypeChecker.Tc.process_one_decl")) + && (should_check modul)) +exception File_argument of Prims.string +let (uu___is_File_argument : Prims.exn -> Prims.bool) = + fun projectee -> + match projectee with | File_argument uu___ -> true | uu___ -> false +let (__proj__File_argument__item__uu___ : Prims.exn -> Prims.string) = + fun projectee -> match projectee with | File_argument uu___ -> uu___ +let (set_options : Prims.string -> FStarC_Getopt.parse_cmdline_res) = + fun s -> + try + (fun uu___ -> + match () with + | () -> + if s = "" + then FStarC_Getopt.Success + else + (let settable_specs1 = + FStarC_Compiler_List.map FStar_Pervasives_Native.fst + settable_specs in + let res = + FStarC_Getopt.parse_string settable_specs1 + (fun s1 -> + FStarC_Compiler_Effect.raise (File_argument s1); + FStarC_Getopt.Error "set_options with file argument") + s in + if res = FStarC_Getopt.Success + then set_error_flags () + else res)) () + with + | File_argument s1 -> + let uu___3 = + FStarC_Compiler_Util.format1 "File %s is not a valid option" s1 in + FStarC_Getopt.Error uu___3 +let with_options : 'a . Prims.string -> (unit -> 'a) -> 'a = + fun s -> + fun f -> + with_saved_options + (fun uu___ -> (let uu___4 = set_options s in ()); f ()) +let (get_vconfig : unit -> FStarC_VConfig.vconfig) = + fun uu___ -> + let vcfg = + let uu___3 = get_initial_fuel () in + let uu___4 = get_max_fuel () in + let uu___5 = get_initial_ifuel () in + let uu___6 = get_max_ifuel () in + let uu___7 = get_detail_errors () in + let uu___8 = get_detail_hint_replay () in + let uu___9 = get_no_smt () in + let uu___10 = get_quake_lo () in + let uu___11 = get_quake_hi () in + let uu___12 = get_quake_keep () in + let uu___13 = get_retry () in + let uu___14 = get_smtencoding_elim_box () in + let uu___15 = get_smtencoding_nl_arith_repr () in + let uu___16 = get_smtencoding_l_arith_repr () in + let uu___17 = get_smtencoding_valid_intro () in + let uu___18 = get_smtencoding_valid_elim () in + let uu___19 = get_tcnorm () in + let uu___20 = get_no_plugins () in + let uu___21 = get_no_tactics () in + let uu___22 = get_z3cliopt () in + let uu___23 = get_z3smtopt () in + let uu___24 = get_z3refresh () in + let uu___25 = get_z3rlimit () in + let uu___26 = get_z3rlimit_factor () in + let uu___27 = get_z3seed () in + let uu___28 = get_z3version () in + let uu___29 = get_trivial_pre_for_unannotated_effectful_fns () in + let uu___30 = get_reuse_hint_for () in + { + FStarC_VConfig.initial_fuel = uu___3; + FStarC_VConfig.max_fuel = uu___4; + FStarC_VConfig.initial_ifuel = uu___5; + FStarC_VConfig.max_ifuel = uu___6; + FStarC_VConfig.detail_errors = uu___7; + FStarC_VConfig.detail_hint_replay = uu___8; + FStarC_VConfig.no_smt = uu___9; + FStarC_VConfig.quake_lo = uu___10; + FStarC_VConfig.quake_hi = uu___11; + FStarC_VConfig.quake_keep = uu___12; + FStarC_VConfig.retry = uu___13; + FStarC_VConfig.smtencoding_elim_box = uu___14; + FStarC_VConfig.smtencoding_nl_arith_repr = uu___15; + FStarC_VConfig.smtencoding_l_arith_repr = uu___16; + FStarC_VConfig.smtencoding_valid_intro = uu___17; + FStarC_VConfig.smtencoding_valid_elim = uu___18; + FStarC_VConfig.tcnorm = uu___19; + FStarC_VConfig.no_plugins = uu___20; + FStarC_VConfig.no_tactics = uu___21; + FStarC_VConfig.z3cliopt = uu___22; + FStarC_VConfig.z3smtopt = uu___23; + FStarC_VConfig.z3refresh = uu___24; + FStarC_VConfig.z3rlimit = uu___25; + FStarC_VConfig.z3rlimit_factor = uu___26; + FStarC_VConfig.z3seed = uu___27; + FStarC_VConfig.z3version = uu___28; + FStarC_VConfig.trivial_pre_for_unannotated_effectful_fns = uu___29; + FStarC_VConfig.reuse_hint_for = uu___30 + } in + vcfg +let (set_vconfig : FStarC_VConfig.vconfig -> unit) = + fun vcfg -> + let option_as tag o = + match o with + | FStar_Pervasives_Native.None -> Unset + | FStar_Pervasives_Native.Some s -> tag s in + set_option "initial_fuel" (Int (vcfg.FStarC_VConfig.initial_fuel)); + set_option "max_fuel" (Int (vcfg.FStarC_VConfig.max_fuel)); + set_option "initial_ifuel" (Int (vcfg.FStarC_VConfig.initial_ifuel)); + set_option "max_ifuel" (Int (vcfg.FStarC_VConfig.max_ifuel)); + set_option "detail_errors" (Bool (vcfg.FStarC_VConfig.detail_errors)); + set_option "detail_hint_replay" + (Bool (vcfg.FStarC_VConfig.detail_hint_replay)); + set_option "no_smt" (Bool (vcfg.FStarC_VConfig.no_smt)); + set_option "quake_lo" (Int (vcfg.FStarC_VConfig.quake_lo)); + set_option "quake_hi" (Int (vcfg.FStarC_VConfig.quake_hi)); + set_option "quake_keep" (Bool (vcfg.FStarC_VConfig.quake_keep)); + set_option "retry" (Bool (vcfg.FStarC_VConfig.retry)); + set_option "smtencoding.elim_box" + (Bool (vcfg.FStarC_VConfig.smtencoding_elim_box)); + set_option "smtencoding.nl_arith_repr" + (String (vcfg.FStarC_VConfig.smtencoding_nl_arith_repr)); + set_option "smtencoding.l_arith_repr" + (String (vcfg.FStarC_VConfig.smtencoding_l_arith_repr)); + set_option "smtencoding.valid_intro" + (Bool (vcfg.FStarC_VConfig.smtencoding_valid_intro)); + set_option "smtencoding.valid_elim" + (Bool (vcfg.FStarC_VConfig.smtencoding_valid_elim)); + set_option "tcnorm" (Bool (vcfg.FStarC_VConfig.tcnorm)); + set_option "no_plugins" (Bool (vcfg.FStarC_VConfig.no_plugins)); + set_option "no_tactics" (Bool (vcfg.FStarC_VConfig.no_tactics)); + (let uu___22 = + let uu___23 = + FStarC_Compiler_List.map (fun uu___24 -> String uu___24) + vcfg.FStarC_VConfig.z3cliopt in + List uu___23 in + set_option "z3cliopt" uu___22); + (let uu___23 = + let uu___24 = + FStarC_Compiler_List.map (fun uu___25 -> String uu___25) + vcfg.FStarC_VConfig.z3smtopt in + List uu___24 in + set_option "z3smtopt" uu___23); + set_option "z3refresh" (Bool (vcfg.FStarC_VConfig.z3refresh)); + set_option "z3rlimit" (Int (vcfg.FStarC_VConfig.z3rlimit)); + set_option "z3rlimit_factor" (Int (vcfg.FStarC_VConfig.z3rlimit_factor)); + set_option "z3seed" (Int (vcfg.FStarC_VConfig.z3seed)); + set_option "z3version" (String (vcfg.FStarC_VConfig.z3version)); + set_option "trivial_pre_for_unannotated_effectful_fns" + (Bool (vcfg.FStarC_VConfig.trivial_pre_for_unannotated_effectful_fns)); + (let uu___30 = + option_as (fun uu___31 -> String uu___31) + vcfg.FStarC_VConfig.reuse_hint_for in + set_option "reuse_hint_for" uu___30) +let (showable_codegen_t : codegen_t FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = print_codegen } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Options_Ext.ml b/ocaml/fstar-lib/generated/FStarC_Options_Ext.ml new file mode 100644 index 00000000000..85d0582fcc0 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Options_Ext.ml @@ -0,0 +1,67 @@ +open Prims +type key = Prims.string +type value = Prims.string +type ext_state = + | E of Prims.string FStarC_Compiler_Util.psmap +let (uu___is_E : ext_state -> Prims.bool) = fun projectee -> true +let (__proj__E__item__map : + ext_state -> Prims.string FStarC_Compiler_Util.psmap) = + fun projectee -> match projectee with | E map -> map +let (cur_state : ext_state FStarC_Compiler_Effect.ref) = + let uu___ = let uu___1 = FStarC_Compiler_Util.psmap_empty () in E uu___1 in + FStarC_Compiler_Util.mk_ref uu___ +let (set : key -> value -> unit) = + fun k -> + fun v -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Compiler_Effect.op_Bang cur_state in + __proj__E__item__map uu___3 in + FStarC_Compiler_Util.psmap_add uu___2 k v in + E uu___1 in + FStarC_Compiler_Effect.op_Colon_Equals cur_state uu___ +let (get : key -> value) = + fun k -> + let r = + let uu___ = + let uu___1 = + let uu___2 = FStarC_Compiler_Effect.op_Bang cur_state in + __proj__E__item__map uu___2 in + FStarC_Compiler_Util.psmap_try_find uu___1 k in + match uu___ with + | FStar_Pervasives_Native.None -> "" + | FStar_Pervasives_Native.Some v -> v in + r +let (is_prefix : Prims.string -> Prims.string -> Prims.bool) = + fun s1 -> + fun s2 -> + let l1 = FStarC_Compiler_String.length s1 in + let l2 = FStarC_Compiler_String.length s2 in + (l2 >= l1) && + (let uu___ = FStarC_Compiler_String.substring s2 Prims.int_zero l1 in + uu___ = s1) +let (getns : Prims.string -> (key * value) Prims.list) = + fun ns -> + let f k v acc = + let uu___ = is_prefix (Prims.strcat ns ":") k in + if uu___ then (k, v) :: acc else acc in + let uu___ = + let uu___1 = FStarC_Compiler_Effect.op_Bang cur_state in + __proj__E__item__map uu___1 in + FStarC_Compiler_Util.psmap_fold uu___ f [] +let (all : unit -> (key * value) Prims.list) = + fun uu___ -> + let f k v acc = (k, v) :: acc in + let uu___1 = + let uu___2 = FStarC_Compiler_Effect.op_Bang cur_state in + __proj__E__item__map uu___2 in + FStarC_Compiler_Util.psmap_fold uu___1 f [] +let (save : unit -> ext_state) = + fun uu___ -> FStarC_Compiler_Effect.op_Bang cur_state +let (restore : ext_state -> unit) = + fun s -> FStarC_Compiler_Effect.op_Colon_Equals cur_state s +let (reset : unit -> unit) = + fun uu___ -> + let uu___1 = let uu___2 = FStarC_Compiler_Util.psmap_empty () in E uu___2 in + FStarC_Compiler_Effect.op_Colon_Equals cur_state uu___1 \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Parser_AST.ml b/ocaml/fstar-lib/generated/FStarC_Parser_AST.ml new file mode 100644 index 00000000000..542a9c6ab88 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Parser_AST.ml @@ -0,0 +1,2782 @@ +open Prims +type level = + | Un + | Expr + | Type_level + | Kind + | Formula +let (uu___is_Un : level -> Prims.bool) = + fun projectee -> match projectee with | Un -> true | uu___ -> false +let (uu___is_Expr : level -> Prims.bool) = + fun projectee -> match projectee with | Expr -> true | uu___ -> false +let (uu___is_Type_level : level -> Prims.bool) = + fun projectee -> match projectee with | Type_level -> true | uu___ -> false +let (uu___is_Kind : level -> Prims.bool) = + fun projectee -> match projectee with | Kind -> true | uu___ -> false +let (uu___is_Formula : level -> Prims.bool) = + fun projectee -> match projectee with | Formula -> true | uu___ -> false +type let_qualifier = + | NoLetQualifier + | Rec +let (uu___is_NoLetQualifier : let_qualifier -> Prims.bool) = + fun projectee -> + match projectee with | NoLetQualifier -> true | uu___ -> false +let (uu___is_Rec : let_qualifier -> Prims.bool) = + fun projectee -> match projectee with | Rec -> true | uu___ -> false +type quote_kind = + | Static + | Dynamic +let (uu___is_Static : quote_kind -> Prims.bool) = + fun projectee -> match projectee with | Static -> true | uu___ -> false +let (uu___is_Dynamic : quote_kind -> Prims.bool) = + fun projectee -> match projectee with | Dynamic -> true | uu___ -> false +type term' = + | Wild + | Const of FStarC_Const.sconst + | Op of (FStarC_Ident.ident * term Prims.list) + | Tvar of FStarC_Ident.ident + | Uvar of FStarC_Ident.ident + | Var of FStarC_Ident.lid + | Name of FStarC_Ident.lid + | Projector of (FStarC_Ident.lid * FStarC_Ident.ident) + | Construct of (FStarC_Ident.lid * (term * imp) Prims.list) + | Abs of (pattern Prims.list * term) + | Function of ((pattern * term FStar_Pervasives_Native.option * term) + Prims.list * FStarC_Compiler_Range_Type.range) + | App of (term * term * imp) + | Let of (let_qualifier * (term Prims.list FStar_Pervasives_Native.option * + (pattern * term)) Prims.list * term) + | LetOperator of ((FStarC_Ident.ident * pattern * term) Prims.list * term) + + | LetOpen of (FStarC_Ident.lid * term) + | LetOpenRecord of (term * term * term) + | Seq of (term * term) + | Bind of (FStarC_Ident.ident * term * term) + | If of (term * FStarC_Ident.ident FStar_Pervasives_Native.option * + (FStarC_Ident.ident FStar_Pervasives_Native.option * term * Prims.bool) + FStar_Pervasives_Native.option * term * term) + | Match of (term * FStarC_Ident.ident FStar_Pervasives_Native.option * + (FStarC_Ident.ident FStar_Pervasives_Native.option * term * Prims.bool) + FStar_Pervasives_Native.option * (pattern * term + FStar_Pervasives_Native.option * term) Prims.list) + | TryWith of (term * (pattern * term FStar_Pervasives_Native.option * term) + Prims.list) + | Ascribed of (term * term * term FStar_Pervasives_Native.option * + Prims.bool) + | Record of (term FStar_Pervasives_Native.option * (FStarC_Ident.lid * + term) Prims.list) + | Project of (term * FStarC_Ident.lid) + | Product of (binder Prims.list * term) + | Sum of ((binder, term) FStar_Pervasives.either Prims.list * term) + | QForall of (binder Prims.list * (FStarC_Ident.ident Prims.list * term + Prims.list Prims.list) * term) + | QExists of (binder Prims.list * (FStarC_Ident.ident Prims.list * term + Prims.list Prims.list) * term) + | QuantOp of (FStarC_Ident.ident * binder Prims.list * (FStarC_Ident.ident + Prims.list * term Prims.list Prims.list) * term) + | Refine of (binder * term) + | NamedTyp of (FStarC_Ident.ident * term) + | Paren of term + | Requires of (term * Prims.string FStar_Pervasives_Native.option) + | Ensures of (term * Prims.string FStar_Pervasives_Native.option) + | LexList of term Prims.list + | WFOrder of (term * term) + | Decreases of (term * Prims.string FStar_Pervasives_Native.option) + | Labeled of (term * Prims.string * Prims.bool) + | Discrim of FStarC_Ident.lid + | Attributes of term Prims.list + | Antiquote of term + | Quote of (term * quote_kind) + | VQuote of term + | CalcProof of (term * term * calc_step Prims.list) + | IntroForall of (binder Prims.list * term * term) + | IntroExists of (binder Prims.list * term * term Prims.list * term) + | IntroImplies of (term * term * binder * term) + | IntroOr of (Prims.bool * term * term * term) + | IntroAnd of (term * term * term * term) + | ElimForall of (binder Prims.list * term * term Prims.list) + | ElimExists of (binder Prims.list * term * term * binder * term) + | ElimImplies of (term * term * term) + | ElimOr of (term * term * term * binder * term * binder * term) + | ElimAnd of (term * term * term * binder * binder * term) + | ListLiteral of term Prims.list + | SeqLiteral of term Prims.list +and term = + { + tm: term' ; + range: FStarC_Compiler_Range_Type.range ; + level: level } +and calc_step = + | CalcStep of (term * term * term) +and binder' = + | Variable of FStarC_Ident.ident + | TVariable of FStarC_Ident.ident + | Annotated of (FStarC_Ident.ident * term) + | TAnnotated of (FStarC_Ident.ident * term) + | NoName of term +and binder = + { + b: binder' ; + brange: FStarC_Compiler_Range_Type.range ; + blevel: level ; + aqual: arg_qualifier FStar_Pervasives_Native.option ; + battributes: term Prims.list } +and pattern' = + | PatWild of (arg_qualifier FStar_Pervasives_Native.option * term + Prims.list) + | PatConst of FStarC_Const.sconst + | PatApp of (pattern * pattern Prims.list) + | PatVar of (FStarC_Ident.ident * arg_qualifier + FStar_Pervasives_Native.option * term Prims.list) + | PatName of FStarC_Ident.lid + | PatTvar of (FStarC_Ident.ident * arg_qualifier + FStar_Pervasives_Native.option * term Prims.list) + | PatList of pattern Prims.list + | PatTuple of (pattern Prims.list * Prims.bool) + | PatRecord of (FStarC_Ident.lid * pattern) Prims.list + | PatAscribed of (pattern * (term * term FStar_Pervasives_Native.option)) + | PatOr of pattern Prims.list + | PatOp of FStarC_Ident.ident + | PatVQuote of term +and pattern = { + pat: pattern' ; + prange: FStarC_Compiler_Range_Type.range } +and arg_qualifier = + | Implicit + | Equality + | Meta of term + | TypeClassArg +and imp = + | FsTypApp + | Hash + | UnivApp + | HashBrace of term + | Infix + | Nothing +let (uu___is_Wild : term' -> Prims.bool) = + fun projectee -> match projectee with | Wild -> true | uu___ -> false +let (uu___is_Const : term' -> Prims.bool) = + fun projectee -> match projectee with | Const _0 -> true | uu___ -> false +let (__proj__Const__item___0 : term' -> FStarC_Const.sconst) = + fun projectee -> match projectee with | Const _0 -> _0 +let (uu___is_Op : term' -> Prims.bool) = + fun projectee -> match projectee with | Op _0 -> true | uu___ -> false +let (__proj__Op__item___0 : term' -> (FStarC_Ident.ident * term Prims.list)) + = fun projectee -> match projectee with | Op _0 -> _0 +let (uu___is_Tvar : term' -> Prims.bool) = + fun projectee -> match projectee with | Tvar _0 -> true | uu___ -> false +let (__proj__Tvar__item___0 : term' -> FStarC_Ident.ident) = + fun projectee -> match projectee with | Tvar _0 -> _0 +let (uu___is_Uvar : term' -> Prims.bool) = + fun projectee -> match projectee with | Uvar _0 -> true | uu___ -> false +let (__proj__Uvar__item___0 : term' -> FStarC_Ident.ident) = + fun projectee -> match projectee with | Uvar _0 -> _0 +let (uu___is_Var : term' -> Prims.bool) = + fun projectee -> match projectee with | Var _0 -> true | uu___ -> false +let (__proj__Var__item___0 : term' -> FStarC_Ident.lid) = + fun projectee -> match projectee with | Var _0 -> _0 +let (uu___is_Name : term' -> Prims.bool) = + fun projectee -> match projectee with | Name _0 -> true | uu___ -> false +let (__proj__Name__item___0 : term' -> FStarC_Ident.lid) = + fun projectee -> match projectee with | Name _0 -> _0 +let (uu___is_Projector : term' -> Prims.bool) = + fun projectee -> + match projectee with | Projector _0 -> true | uu___ -> false +let (__proj__Projector__item___0 : + term' -> (FStarC_Ident.lid * FStarC_Ident.ident)) = + fun projectee -> match projectee with | Projector _0 -> _0 +let (uu___is_Construct : term' -> Prims.bool) = + fun projectee -> + match projectee with | Construct _0 -> true | uu___ -> false +let (__proj__Construct__item___0 : + term' -> (FStarC_Ident.lid * (term * imp) Prims.list)) = + fun projectee -> match projectee with | Construct _0 -> _0 +let (uu___is_Abs : term' -> Prims.bool) = + fun projectee -> match projectee with | Abs _0 -> true | uu___ -> false +let (__proj__Abs__item___0 : term' -> (pattern Prims.list * term)) = + fun projectee -> match projectee with | Abs _0 -> _0 +let (uu___is_Function : term' -> Prims.bool) = + fun projectee -> + match projectee with | Function _0 -> true | uu___ -> false +let (__proj__Function__item___0 : + term' -> + ((pattern * term FStar_Pervasives_Native.option * term) Prims.list * + FStarC_Compiler_Range_Type.range)) + = fun projectee -> match projectee with | Function _0 -> _0 +let (uu___is_App : term' -> Prims.bool) = + fun projectee -> match projectee with | App _0 -> true | uu___ -> false +let (__proj__App__item___0 : term' -> (term * term * imp)) = + fun projectee -> match projectee with | App _0 -> _0 +let (uu___is_Let : term' -> Prims.bool) = + fun projectee -> match projectee with | Let _0 -> true | uu___ -> false +let (__proj__Let__item___0 : + term' -> + (let_qualifier * (term Prims.list FStar_Pervasives_Native.option * + (pattern * term)) Prims.list * term)) + = fun projectee -> match projectee with | Let _0 -> _0 +let (uu___is_LetOperator : term' -> Prims.bool) = + fun projectee -> + match projectee with | LetOperator _0 -> true | uu___ -> false +let (__proj__LetOperator__item___0 : + term' -> ((FStarC_Ident.ident * pattern * term) Prims.list * term)) = + fun projectee -> match projectee with | LetOperator _0 -> _0 +let (uu___is_LetOpen : term' -> Prims.bool) = + fun projectee -> match projectee with | LetOpen _0 -> true | uu___ -> false +let (__proj__LetOpen__item___0 : term' -> (FStarC_Ident.lid * term)) = + fun projectee -> match projectee with | LetOpen _0 -> _0 +let (uu___is_LetOpenRecord : term' -> Prims.bool) = + fun projectee -> + match projectee with | LetOpenRecord _0 -> true | uu___ -> false +let (__proj__LetOpenRecord__item___0 : term' -> (term * term * term)) = + fun projectee -> match projectee with | LetOpenRecord _0 -> _0 +let (uu___is_Seq : term' -> Prims.bool) = + fun projectee -> match projectee with | Seq _0 -> true | uu___ -> false +let (__proj__Seq__item___0 : term' -> (term * term)) = + fun projectee -> match projectee with | Seq _0 -> _0 +let (uu___is_Bind : term' -> Prims.bool) = + fun projectee -> match projectee with | Bind _0 -> true | uu___ -> false +let (__proj__Bind__item___0 : term' -> (FStarC_Ident.ident * term * term)) = + fun projectee -> match projectee with | Bind _0 -> _0 +let (uu___is_If : term' -> Prims.bool) = + fun projectee -> match projectee with | If _0 -> true | uu___ -> false +let (__proj__If__item___0 : + term' -> + (term * FStarC_Ident.ident FStar_Pervasives_Native.option * + (FStarC_Ident.ident FStar_Pervasives_Native.option * term * Prims.bool) + FStar_Pervasives_Native.option * term * term)) + = fun projectee -> match projectee with | If _0 -> _0 +let (uu___is_Match : term' -> Prims.bool) = + fun projectee -> match projectee with | Match _0 -> true | uu___ -> false +let (__proj__Match__item___0 : + term' -> + (term * FStarC_Ident.ident FStar_Pervasives_Native.option * + (FStarC_Ident.ident FStar_Pervasives_Native.option * term * Prims.bool) + FStar_Pervasives_Native.option * (pattern * term + FStar_Pervasives_Native.option * term) Prims.list)) + = fun projectee -> match projectee with | Match _0 -> _0 +let (uu___is_TryWith : term' -> Prims.bool) = + fun projectee -> match projectee with | TryWith _0 -> true | uu___ -> false +let (__proj__TryWith__item___0 : + term' -> + (term * (pattern * term FStar_Pervasives_Native.option * term) + Prims.list)) + = fun projectee -> match projectee with | TryWith _0 -> _0 +let (uu___is_Ascribed : term' -> Prims.bool) = + fun projectee -> + match projectee with | Ascribed _0 -> true | uu___ -> false +let (__proj__Ascribed__item___0 : + term' -> (term * term * term FStar_Pervasives_Native.option * Prims.bool)) + = fun projectee -> match projectee with | Ascribed _0 -> _0 +let (uu___is_Record : term' -> Prims.bool) = + fun projectee -> match projectee with | Record _0 -> true | uu___ -> false +let (__proj__Record__item___0 : + term' -> + (term FStar_Pervasives_Native.option * (FStarC_Ident.lid * term) + Prims.list)) + = fun projectee -> match projectee with | Record _0 -> _0 +let (uu___is_Project : term' -> Prims.bool) = + fun projectee -> match projectee with | Project _0 -> true | uu___ -> false +let (__proj__Project__item___0 : term' -> (term * FStarC_Ident.lid)) = + fun projectee -> match projectee with | Project _0 -> _0 +let (uu___is_Product : term' -> Prims.bool) = + fun projectee -> match projectee with | Product _0 -> true | uu___ -> false +let (__proj__Product__item___0 : term' -> (binder Prims.list * term)) = + fun projectee -> match projectee with | Product _0 -> _0 +let (uu___is_Sum : term' -> Prims.bool) = + fun projectee -> match projectee with | Sum _0 -> true | uu___ -> false +let (__proj__Sum__item___0 : + term' -> ((binder, term) FStar_Pervasives.either Prims.list * term)) = + fun projectee -> match projectee with | Sum _0 -> _0 +let (uu___is_QForall : term' -> Prims.bool) = + fun projectee -> match projectee with | QForall _0 -> true | uu___ -> false +let (__proj__QForall__item___0 : + term' -> + (binder Prims.list * (FStarC_Ident.ident Prims.list * term Prims.list + Prims.list) * term)) + = fun projectee -> match projectee with | QForall _0 -> _0 +let (uu___is_QExists : term' -> Prims.bool) = + fun projectee -> match projectee with | QExists _0 -> true | uu___ -> false +let (__proj__QExists__item___0 : + term' -> + (binder Prims.list * (FStarC_Ident.ident Prims.list * term Prims.list + Prims.list) * term)) + = fun projectee -> match projectee with | QExists _0 -> _0 +let (uu___is_QuantOp : term' -> Prims.bool) = + fun projectee -> match projectee with | QuantOp _0 -> true | uu___ -> false +let (__proj__QuantOp__item___0 : + term' -> + (FStarC_Ident.ident * binder Prims.list * (FStarC_Ident.ident Prims.list + * term Prims.list Prims.list) * term)) + = fun projectee -> match projectee with | QuantOp _0 -> _0 +let (uu___is_Refine : term' -> Prims.bool) = + fun projectee -> match projectee with | Refine _0 -> true | uu___ -> false +let (__proj__Refine__item___0 : term' -> (binder * term)) = + fun projectee -> match projectee with | Refine _0 -> _0 +let (uu___is_NamedTyp : term' -> Prims.bool) = + fun projectee -> + match projectee with | NamedTyp _0 -> true | uu___ -> false +let (__proj__NamedTyp__item___0 : term' -> (FStarC_Ident.ident * term)) = + fun projectee -> match projectee with | NamedTyp _0 -> _0 +let (uu___is_Paren : term' -> Prims.bool) = + fun projectee -> match projectee with | Paren _0 -> true | uu___ -> false +let (__proj__Paren__item___0 : term' -> term) = + fun projectee -> match projectee with | Paren _0 -> _0 +let (uu___is_Requires : term' -> Prims.bool) = + fun projectee -> + match projectee with | Requires _0 -> true | uu___ -> false +let (__proj__Requires__item___0 : + term' -> (term * Prims.string FStar_Pervasives_Native.option)) = + fun projectee -> match projectee with | Requires _0 -> _0 +let (uu___is_Ensures : term' -> Prims.bool) = + fun projectee -> match projectee with | Ensures _0 -> true | uu___ -> false +let (__proj__Ensures__item___0 : + term' -> (term * Prims.string FStar_Pervasives_Native.option)) = + fun projectee -> match projectee with | Ensures _0 -> _0 +let (uu___is_LexList : term' -> Prims.bool) = + fun projectee -> match projectee with | LexList _0 -> true | uu___ -> false +let (__proj__LexList__item___0 : term' -> term Prims.list) = + fun projectee -> match projectee with | LexList _0 -> _0 +let (uu___is_WFOrder : term' -> Prims.bool) = + fun projectee -> match projectee with | WFOrder _0 -> true | uu___ -> false +let (__proj__WFOrder__item___0 : term' -> (term * term)) = + fun projectee -> match projectee with | WFOrder _0 -> _0 +let (uu___is_Decreases : term' -> Prims.bool) = + fun projectee -> + match projectee with | Decreases _0 -> true | uu___ -> false +let (__proj__Decreases__item___0 : + term' -> (term * Prims.string FStar_Pervasives_Native.option)) = + fun projectee -> match projectee with | Decreases _0 -> _0 +let (uu___is_Labeled : term' -> Prims.bool) = + fun projectee -> match projectee with | Labeled _0 -> true | uu___ -> false +let (__proj__Labeled__item___0 : term' -> (term * Prims.string * Prims.bool)) + = fun projectee -> match projectee with | Labeled _0 -> _0 +let (uu___is_Discrim : term' -> Prims.bool) = + fun projectee -> match projectee with | Discrim _0 -> true | uu___ -> false +let (__proj__Discrim__item___0 : term' -> FStarC_Ident.lid) = + fun projectee -> match projectee with | Discrim _0 -> _0 +let (uu___is_Attributes : term' -> Prims.bool) = + fun projectee -> + match projectee with | Attributes _0 -> true | uu___ -> false +let (__proj__Attributes__item___0 : term' -> term Prims.list) = + fun projectee -> match projectee with | Attributes _0 -> _0 +let (uu___is_Antiquote : term' -> Prims.bool) = + fun projectee -> + match projectee with | Antiquote _0 -> true | uu___ -> false +let (__proj__Antiquote__item___0 : term' -> term) = + fun projectee -> match projectee with | Antiquote _0 -> _0 +let (uu___is_Quote : term' -> Prims.bool) = + fun projectee -> match projectee with | Quote _0 -> true | uu___ -> false +let (__proj__Quote__item___0 : term' -> (term * quote_kind)) = + fun projectee -> match projectee with | Quote _0 -> _0 +let (uu___is_VQuote : term' -> Prims.bool) = + fun projectee -> match projectee with | VQuote _0 -> true | uu___ -> false +let (__proj__VQuote__item___0 : term' -> term) = + fun projectee -> match projectee with | VQuote _0 -> _0 +let (uu___is_CalcProof : term' -> Prims.bool) = + fun projectee -> + match projectee with | CalcProof _0 -> true | uu___ -> false +let (__proj__CalcProof__item___0 : + term' -> (term * term * calc_step Prims.list)) = + fun projectee -> match projectee with | CalcProof _0 -> _0 +let (uu___is_IntroForall : term' -> Prims.bool) = + fun projectee -> + match projectee with | IntroForall _0 -> true | uu___ -> false +let (__proj__IntroForall__item___0 : + term' -> (binder Prims.list * term * term)) = + fun projectee -> match projectee with | IntroForall _0 -> _0 +let (uu___is_IntroExists : term' -> Prims.bool) = + fun projectee -> + match projectee with | IntroExists _0 -> true | uu___ -> false +let (__proj__IntroExists__item___0 : + term' -> (binder Prims.list * term * term Prims.list * term)) = + fun projectee -> match projectee with | IntroExists _0 -> _0 +let (uu___is_IntroImplies : term' -> Prims.bool) = + fun projectee -> + match projectee with | IntroImplies _0 -> true | uu___ -> false +let (__proj__IntroImplies__item___0 : term' -> (term * term * binder * term)) + = fun projectee -> match projectee with | IntroImplies _0 -> _0 +let (uu___is_IntroOr : term' -> Prims.bool) = + fun projectee -> match projectee with | IntroOr _0 -> true | uu___ -> false +let (__proj__IntroOr__item___0 : term' -> (Prims.bool * term * term * term)) + = fun projectee -> match projectee with | IntroOr _0 -> _0 +let (uu___is_IntroAnd : term' -> Prims.bool) = + fun projectee -> + match projectee with | IntroAnd _0 -> true | uu___ -> false +let (__proj__IntroAnd__item___0 : term' -> (term * term * term * term)) = + fun projectee -> match projectee with | IntroAnd _0 -> _0 +let (uu___is_ElimForall : term' -> Prims.bool) = + fun projectee -> + match projectee with | ElimForall _0 -> true | uu___ -> false +let (__proj__ElimForall__item___0 : + term' -> (binder Prims.list * term * term Prims.list)) = + fun projectee -> match projectee with | ElimForall _0 -> _0 +let (uu___is_ElimExists : term' -> Prims.bool) = + fun projectee -> + match projectee with | ElimExists _0 -> true | uu___ -> false +let (__proj__ElimExists__item___0 : + term' -> (binder Prims.list * term * term * binder * term)) = + fun projectee -> match projectee with | ElimExists _0 -> _0 +let (uu___is_ElimImplies : term' -> Prims.bool) = + fun projectee -> + match projectee with | ElimImplies _0 -> true | uu___ -> false +let (__proj__ElimImplies__item___0 : term' -> (term * term * term)) = + fun projectee -> match projectee with | ElimImplies _0 -> _0 +let (uu___is_ElimOr : term' -> Prims.bool) = + fun projectee -> match projectee with | ElimOr _0 -> true | uu___ -> false +let (__proj__ElimOr__item___0 : + term' -> (term * term * term * binder * term * binder * term)) = + fun projectee -> match projectee with | ElimOr _0 -> _0 +let (uu___is_ElimAnd : term' -> Prims.bool) = + fun projectee -> match projectee with | ElimAnd _0 -> true | uu___ -> false +let (__proj__ElimAnd__item___0 : + term' -> (term * term * term * binder * binder * term)) = + fun projectee -> match projectee with | ElimAnd _0 -> _0 +let (uu___is_ListLiteral : term' -> Prims.bool) = + fun projectee -> + match projectee with | ListLiteral _0 -> true | uu___ -> false +let (__proj__ListLiteral__item___0 : term' -> term Prims.list) = + fun projectee -> match projectee with | ListLiteral _0 -> _0 +let (uu___is_SeqLiteral : term' -> Prims.bool) = + fun projectee -> + match projectee with | SeqLiteral _0 -> true | uu___ -> false +let (__proj__SeqLiteral__item___0 : term' -> term Prims.list) = + fun projectee -> match projectee with | SeqLiteral _0 -> _0 +let (__proj__Mkterm__item__tm : term -> term') = + fun projectee -> + match projectee with | { tm; range; level = level1;_} -> tm +let (__proj__Mkterm__item__range : term -> FStarC_Compiler_Range_Type.range) + = + fun projectee -> + match projectee with | { tm; range; level = level1;_} -> range +let (__proj__Mkterm__item__level : term -> level) = + fun projectee -> + match projectee with | { tm; range; level = level1;_} -> level1 +let (uu___is_CalcStep : calc_step -> Prims.bool) = fun projectee -> true +let (__proj__CalcStep__item___0 : calc_step -> (term * term * term)) = + fun projectee -> match projectee with | CalcStep _0 -> _0 +let (uu___is_Variable : binder' -> Prims.bool) = + fun projectee -> + match projectee with | Variable _0 -> true | uu___ -> false +let (__proj__Variable__item___0 : binder' -> FStarC_Ident.ident) = + fun projectee -> match projectee with | Variable _0 -> _0 +let (uu___is_TVariable : binder' -> Prims.bool) = + fun projectee -> + match projectee with | TVariable _0 -> true | uu___ -> false +let (__proj__TVariable__item___0 : binder' -> FStarC_Ident.ident) = + fun projectee -> match projectee with | TVariable _0 -> _0 +let (uu___is_Annotated : binder' -> Prims.bool) = + fun projectee -> + match projectee with | Annotated _0 -> true | uu___ -> false +let (__proj__Annotated__item___0 : binder' -> (FStarC_Ident.ident * term)) = + fun projectee -> match projectee with | Annotated _0 -> _0 +let (uu___is_TAnnotated : binder' -> Prims.bool) = + fun projectee -> + match projectee with | TAnnotated _0 -> true | uu___ -> false +let (__proj__TAnnotated__item___0 : binder' -> (FStarC_Ident.ident * term)) = + fun projectee -> match projectee with | TAnnotated _0 -> _0 +let (uu___is_NoName : binder' -> Prims.bool) = + fun projectee -> match projectee with | NoName _0 -> true | uu___ -> false +let (__proj__NoName__item___0 : binder' -> term) = + fun projectee -> match projectee with | NoName _0 -> _0 +let (__proj__Mkbinder__item__b : binder -> binder') = + fun projectee -> + match projectee with | { b; brange; blevel; aqual; battributes;_} -> b +let (__proj__Mkbinder__item__brange : + binder -> FStarC_Compiler_Range_Type.range) = + fun projectee -> + match projectee with + | { b; brange; blevel; aqual; battributes;_} -> brange +let (__proj__Mkbinder__item__blevel : binder -> level) = + fun projectee -> + match projectee with + | { b; brange; blevel; aqual; battributes;_} -> blevel +let (__proj__Mkbinder__item__aqual : + binder -> arg_qualifier FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { b; brange; blevel; aqual; battributes;_} -> aqual +let (__proj__Mkbinder__item__battributes : binder -> term Prims.list) = + fun projectee -> + match projectee with + | { b; brange; blevel; aqual; battributes;_} -> battributes +let (uu___is_PatWild : pattern' -> Prims.bool) = + fun projectee -> match projectee with | PatWild _0 -> true | uu___ -> false +let (__proj__PatWild__item___0 : + pattern' -> + (arg_qualifier FStar_Pervasives_Native.option * term Prims.list)) + = fun projectee -> match projectee with | PatWild _0 -> _0 +let (uu___is_PatConst : pattern' -> Prims.bool) = + fun projectee -> + match projectee with | PatConst _0 -> true | uu___ -> false +let (__proj__PatConst__item___0 : pattern' -> FStarC_Const.sconst) = + fun projectee -> match projectee with | PatConst _0 -> _0 +let (uu___is_PatApp : pattern' -> Prims.bool) = + fun projectee -> match projectee with | PatApp _0 -> true | uu___ -> false +let (__proj__PatApp__item___0 : pattern' -> (pattern * pattern Prims.list)) = + fun projectee -> match projectee with | PatApp _0 -> _0 +let (uu___is_PatVar : pattern' -> Prims.bool) = + fun projectee -> match projectee with | PatVar _0 -> true | uu___ -> false +let (__proj__PatVar__item___0 : + pattern' -> + (FStarC_Ident.ident * arg_qualifier FStar_Pervasives_Native.option * term + Prims.list)) + = fun projectee -> match projectee with | PatVar _0 -> _0 +let (uu___is_PatName : pattern' -> Prims.bool) = + fun projectee -> match projectee with | PatName _0 -> true | uu___ -> false +let (__proj__PatName__item___0 : pattern' -> FStarC_Ident.lid) = + fun projectee -> match projectee with | PatName _0 -> _0 +let (uu___is_PatTvar : pattern' -> Prims.bool) = + fun projectee -> match projectee with | PatTvar _0 -> true | uu___ -> false +let (__proj__PatTvar__item___0 : + pattern' -> + (FStarC_Ident.ident * arg_qualifier FStar_Pervasives_Native.option * term + Prims.list)) + = fun projectee -> match projectee with | PatTvar _0 -> _0 +let (uu___is_PatList : pattern' -> Prims.bool) = + fun projectee -> match projectee with | PatList _0 -> true | uu___ -> false +let (__proj__PatList__item___0 : pattern' -> pattern Prims.list) = + fun projectee -> match projectee with | PatList _0 -> _0 +let (uu___is_PatTuple : pattern' -> Prims.bool) = + fun projectee -> + match projectee with | PatTuple _0 -> true | uu___ -> false +let (__proj__PatTuple__item___0 : + pattern' -> (pattern Prims.list * Prims.bool)) = + fun projectee -> match projectee with | PatTuple _0 -> _0 +let (uu___is_PatRecord : pattern' -> Prims.bool) = + fun projectee -> + match projectee with | PatRecord _0 -> true | uu___ -> false +let (__proj__PatRecord__item___0 : + pattern' -> (FStarC_Ident.lid * pattern) Prims.list) = + fun projectee -> match projectee with | PatRecord _0 -> _0 +let (uu___is_PatAscribed : pattern' -> Prims.bool) = + fun projectee -> + match projectee with | PatAscribed _0 -> true | uu___ -> false +let (__proj__PatAscribed__item___0 : + pattern' -> (pattern * (term * term FStar_Pervasives_Native.option))) = + fun projectee -> match projectee with | PatAscribed _0 -> _0 +let (uu___is_PatOr : pattern' -> Prims.bool) = + fun projectee -> match projectee with | PatOr _0 -> true | uu___ -> false +let (__proj__PatOr__item___0 : pattern' -> pattern Prims.list) = + fun projectee -> match projectee with | PatOr _0 -> _0 +let (uu___is_PatOp : pattern' -> Prims.bool) = + fun projectee -> match projectee with | PatOp _0 -> true | uu___ -> false +let (__proj__PatOp__item___0 : pattern' -> FStarC_Ident.ident) = + fun projectee -> match projectee with | PatOp _0 -> _0 +let (uu___is_PatVQuote : pattern' -> Prims.bool) = + fun projectee -> + match projectee with | PatVQuote _0 -> true | uu___ -> false +let (__proj__PatVQuote__item___0 : pattern' -> term) = + fun projectee -> match projectee with | PatVQuote _0 -> _0 +let (__proj__Mkpattern__item__pat : pattern -> pattern') = + fun projectee -> match projectee with | { pat; prange;_} -> pat +let (__proj__Mkpattern__item__prange : + pattern -> FStarC_Compiler_Range_Type.range) = + fun projectee -> match projectee with | { pat; prange;_} -> prange +let (uu___is_Implicit : arg_qualifier -> Prims.bool) = + fun projectee -> match projectee with | Implicit -> true | uu___ -> false +let (uu___is_Equality : arg_qualifier -> Prims.bool) = + fun projectee -> match projectee with | Equality -> true | uu___ -> false +let (uu___is_Meta : arg_qualifier -> Prims.bool) = + fun projectee -> match projectee with | Meta _0 -> true | uu___ -> false +let (__proj__Meta__item___0 : arg_qualifier -> term) = + fun projectee -> match projectee with | Meta _0 -> _0 +let (uu___is_TypeClassArg : arg_qualifier -> Prims.bool) = + fun projectee -> + match projectee with | TypeClassArg -> true | uu___ -> false +let (uu___is_FsTypApp : imp -> Prims.bool) = + fun projectee -> match projectee with | FsTypApp -> true | uu___ -> false +let (uu___is_Hash : imp -> Prims.bool) = + fun projectee -> match projectee with | Hash -> true | uu___ -> false +let (uu___is_UnivApp : imp -> Prims.bool) = + fun projectee -> match projectee with | UnivApp -> true | uu___ -> false +let (uu___is_HashBrace : imp -> Prims.bool) = + fun projectee -> + match projectee with | HashBrace _0 -> true | uu___ -> false +let (__proj__HashBrace__item___0 : imp -> term) = + fun projectee -> match projectee with | HashBrace _0 -> _0 +let (uu___is_Infix : imp -> Prims.bool) = + fun projectee -> match projectee with | Infix -> true | uu___ -> false +let (uu___is_Nothing : imp -> Prims.bool) = + fun projectee -> match projectee with | Nothing -> true | uu___ -> false +type match_returns_annotation = + (FStarC_Ident.ident FStar_Pervasives_Native.option * term * Prims.bool) +type patterns = (FStarC_Ident.ident Prims.list * term Prims.list Prims.list) +type attributes_ = term Prims.list +type branch = (pattern * term FStar_Pervasives_Native.option * term) +type aqual = arg_qualifier FStar_Pervasives_Native.option +let (hasRange_term : term FStarC_Class_HasRange.hasRange) = + { + FStarC_Class_HasRange.pos = (fun t -> t.range); + FStarC_Class_HasRange.setPos = + (fun r -> fun t -> { tm = (t.tm); range = r; level = (t.level) }) + } +let (hasRange_pattern : pattern FStarC_Class_HasRange.hasRange) = + { + FStarC_Class_HasRange.pos = (fun p -> p.prange); + FStarC_Class_HasRange.setPos = + (fun r -> fun p -> { pat = (p.pat); prange = r }) + } +let (hasRange_binder : binder FStarC_Class_HasRange.hasRange) = + { + FStarC_Class_HasRange.pos = (fun b -> b.brange); + FStarC_Class_HasRange.setPos = + (fun r -> + fun b -> + { + b = (b.b); + brange = r; + blevel = (b.blevel); + aqual = (b.aqual); + battributes = (b.battributes) + }) + } +type knd = term +type typ = term +type expr = term +type tycon_record = + (FStarC_Ident.ident * aqual * attributes_ * term) Prims.list +type constructor_payload = + | VpOfNotation of typ + | VpArbitrary of typ + | VpRecord of (tycon_record * typ FStar_Pervasives_Native.option) +let (uu___is_VpOfNotation : constructor_payload -> Prims.bool) = + fun projectee -> + match projectee with | VpOfNotation _0 -> true | uu___ -> false +let (__proj__VpOfNotation__item___0 : constructor_payload -> typ) = + fun projectee -> match projectee with | VpOfNotation _0 -> _0 +let (uu___is_VpArbitrary : constructor_payload -> Prims.bool) = + fun projectee -> + match projectee with | VpArbitrary _0 -> true | uu___ -> false +let (__proj__VpArbitrary__item___0 : constructor_payload -> typ) = + fun projectee -> match projectee with | VpArbitrary _0 -> _0 +let (uu___is_VpRecord : constructor_payload -> Prims.bool) = + fun projectee -> + match projectee with | VpRecord _0 -> true | uu___ -> false +let (__proj__VpRecord__item___0 : + constructor_payload -> (tycon_record * typ FStar_Pervasives_Native.option)) + = fun projectee -> match projectee with | VpRecord _0 -> _0 +type tycon = + | TyconAbstract of (FStarC_Ident.ident * binder Prims.list * knd + FStar_Pervasives_Native.option) + | TyconAbbrev of (FStarC_Ident.ident * binder Prims.list * knd + FStar_Pervasives_Native.option * term) + | TyconRecord of (FStarC_Ident.ident * binder Prims.list * knd + FStar_Pervasives_Native.option * attributes_ * tycon_record) + | TyconVariant of (FStarC_Ident.ident * binder Prims.list * knd + FStar_Pervasives_Native.option * (FStarC_Ident.ident * constructor_payload + FStar_Pervasives_Native.option * attributes_) Prims.list) +let (uu___is_TyconAbstract : tycon -> Prims.bool) = + fun projectee -> + match projectee with | TyconAbstract _0 -> true | uu___ -> false +let (__proj__TyconAbstract__item___0 : + tycon -> + (FStarC_Ident.ident * binder Prims.list * knd + FStar_Pervasives_Native.option)) + = fun projectee -> match projectee with | TyconAbstract _0 -> _0 +let (uu___is_TyconAbbrev : tycon -> Prims.bool) = + fun projectee -> + match projectee with | TyconAbbrev _0 -> true | uu___ -> false +let (__proj__TyconAbbrev__item___0 : + tycon -> + (FStarC_Ident.ident * binder Prims.list * knd + FStar_Pervasives_Native.option * term)) + = fun projectee -> match projectee with | TyconAbbrev _0 -> _0 +let (uu___is_TyconRecord : tycon -> Prims.bool) = + fun projectee -> + match projectee with | TyconRecord _0 -> true | uu___ -> false +let (__proj__TyconRecord__item___0 : + tycon -> + (FStarC_Ident.ident * binder Prims.list * knd + FStar_Pervasives_Native.option * attributes_ * tycon_record)) + = fun projectee -> match projectee with | TyconRecord _0 -> _0 +let (uu___is_TyconVariant : tycon -> Prims.bool) = + fun projectee -> + match projectee with | TyconVariant _0 -> true | uu___ -> false +let (__proj__TyconVariant__item___0 : + tycon -> + (FStarC_Ident.ident * binder Prims.list * knd + FStar_Pervasives_Native.option * (FStarC_Ident.ident * + constructor_payload FStar_Pervasives_Native.option * attributes_) + Prims.list)) + = fun projectee -> match projectee with | TyconVariant _0 -> _0 +type qualifier = + | Private + | Noeq + | Unopteq + | Assumption + | DefaultEffect + | TotalEffect + | Effect_qual + | New + | Inline + | Visible + | Unfold_for_unification_and_vcgen + | Inline_for_extraction + | Irreducible + | NoExtract + | Reifiable + | Reflectable + | Opaque + | Logic +let (uu___is_Private : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Private -> true | uu___ -> false +let (uu___is_Noeq : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Noeq -> true | uu___ -> false +let (uu___is_Unopteq : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Unopteq -> true | uu___ -> false +let (uu___is_Assumption : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Assumption -> true | uu___ -> false +let (uu___is_DefaultEffect : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | DefaultEffect -> true | uu___ -> false +let (uu___is_TotalEffect : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | TotalEffect -> true | uu___ -> false +let (uu___is_Effect_qual : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | Effect_qual -> true | uu___ -> false +let (uu___is_New : qualifier -> Prims.bool) = + fun projectee -> match projectee with | New -> true | uu___ -> false +let (uu___is_Inline : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Inline -> true | uu___ -> false +let (uu___is_Visible : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Visible -> true | uu___ -> false +let (uu___is_Unfold_for_unification_and_vcgen : qualifier -> Prims.bool) = + fun projectee -> + match projectee with + | Unfold_for_unification_and_vcgen -> true + | uu___ -> false +let (uu___is_Inline_for_extraction : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | Inline_for_extraction -> true | uu___ -> false +let (uu___is_Irreducible : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | Irreducible -> true | uu___ -> false +let (uu___is_NoExtract : qualifier -> Prims.bool) = + fun projectee -> match projectee with | NoExtract -> true | uu___ -> false +let (uu___is_Reifiable : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Reifiable -> true | uu___ -> false +let (uu___is_Reflectable : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | Reflectable -> true | uu___ -> false +let (uu___is_Opaque : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Opaque -> true | uu___ -> false +let (uu___is_Logic : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Logic -> true | uu___ -> false +type qualifiers = qualifier Prims.list +type decoration = + | Qualifier of qualifier + | DeclAttributes of term Prims.list +let (uu___is_Qualifier : decoration -> Prims.bool) = + fun projectee -> + match projectee with | Qualifier _0 -> true | uu___ -> false +let (__proj__Qualifier__item___0 : decoration -> qualifier) = + fun projectee -> match projectee with | Qualifier _0 -> _0 +let (uu___is_DeclAttributes : decoration -> Prims.bool) = + fun projectee -> + match projectee with | DeclAttributes _0 -> true | uu___ -> false +let (__proj__DeclAttributes__item___0 : decoration -> term Prims.list) = + fun projectee -> match projectee with | DeclAttributes _0 -> _0 +type lift_op = + | NonReifiableLift of term + | ReifiableLift of (term * term) + | LiftForFree of term +let (uu___is_NonReifiableLift : lift_op -> Prims.bool) = + fun projectee -> + match projectee with | NonReifiableLift _0 -> true | uu___ -> false +let (__proj__NonReifiableLift__item___0 : lift_op -> term) = + fun projectee -> match projectee with | NonReifiableLift _0 -> _0 +let (uu___is_ReifiableLift : lift_op -> Prims.bool) = + fun projectee -> + match projectee with | ReifiableLift _0 -> true | uu___ -> false +let (__proj__ReifiableLift__item___0 : lift_op -> (term * term)) = + fun projectee -> match projectee with | ReifiableLift _0 -> _0 +let (uu___is_LiftForFree : lift_op -> Prims.bool) = + fun projectee -> + match projectee with | LiftForFree _0 -> true | uu___ -> false +let (__proj__LiftForFree__item___0 : lift_op -> term) = + fun projectee -> match projectee with | LiftForFree _0 -> _0 +type lift = + { + msource: FStarC_Ident.lid ; + mdest: FStarC_Ident.lid ; + lift_op: lift_op ; + braced: Prims.bool } +let (__proj__Mklift__item__msource : lift -> FStarC_Ident.lid) = + fun projectee -> + match projectee with + | { msource; mdest; lift_op = lift_op1; braced;_} -> msource +let (__proj__Mklift__item__mdest : lift -> FStarC_Ident.lid) = + fun projectee -> + match projectee with + | { msource; mdest; lift_op = lift_op1; braced;_} -> mdest +let (__proj__Mklift__item__lift_op : lift -> lift_op) = + fun projectee -> + match projectee with + | { msource; mdest; lift_op = lift_op1; braced;_} -> lift_op1 +let (__proj__Mklift__item__braced : lift -> Prims.bool) = + fun projectee -> + match projectee with + | { msource; mdest; lift_op = lift_op1; braced;_} -> braced +type pragma = + | ShowOptions + | SetOptions of Prims.string + | ResetOptions of Prims.string FStar_Pervasives_Native.option + | PushOptions of Prims.string FStar_Pervasives_Native.option + | PopOptions + | RestartSolver + | PrintEffectsGraph +let (uu___is_ShowOptions : pragma -> Prims.bool) = + fun projectee -> + match projectee with | ShowOptions -> true | uu___ -> false +let (uu___is_SetOptions : pragma -> Prims.bool) = + fun projectee -> + match projectee with | SetOptions _0 -> true | uu___ -> false +let (__proj__SetOptions__item___0 : pragma -> Prims.string) = + fun projectee -> match projectee with | SetOptions _0 -> _0 +let (uu___is_ResetOptions : pragma -> Prims.bool) = + fun projectee -> + match projectee with | ResetOptions _0 -> true | uu___ -> false +let (__proj__ResetOptions__item___0 : + pragma -> Prims.string FStar_Pervasives_Native.option) = + fun projectee -> match projectee with | ResetOptions _0 -> _0 +let (uu___is_PushOptions : pragma -> Prims.bool) = + fun projectee -> + match projectee with | PushOptions _0 -> true | uu___ -> false +let (__proj__PushOptions__item___0 : + pragma -> Prims.string FStar_Pervasives_Native.option) = + fun projectee -> match projectee with | PushOptions _0 -> _0 +let (uu___is_PopOptions : pragma -> Prims.bool) = + fun projectee -> match projectee with | PopOptions -> true | uu___ -> false +let (uu___is_RestartSolver : pragma -> Prims.bool) = + fun projectee -> + match projectee with | RestartSolver -> true | uu___ -> false +let (uu___is_PrintEffectsGraph : pragma -> Prims.bool) = + fun projectee -> + match projectee with | PrintEffectsGraph -> true | uu___ -> false +type dep_scan_callbacks = + { + scan_term: term -> unit ; + scan_binder: binder -> unit ; + scan_pattern: pattern -> unit ; + add_lident: FStarC_Ident.lident -> unit ; + add_open: FStarC_Ident.lident -> unit } +let (__proj__Mkdep_scan_callbacks__item__scan_term : + dep_scan_callbacks -> term -> unit) = + fun projectee -> + match projectee with + | { scan_term; scan_binder; scan_pattern; add_lident; add_open;_} -> + scan_term +let (__proj__Mkdep_scan_callbacks__item__scan_binder : + dep_scan_callbacks -> binder -> unit) = + fun projectee -> + match projectee with + | { scan_term; scan_binder; scan_pattern; add_lident; add_open;_} -> + scan_binder +let (__proj__Mkdep_scan_callbacks__item__scan_pattern : + dep_scan_callbacks -> pattern -> unit) = + fun projectee -> + match projectee with + | { scan_term; scan_binder; scan_pattern; add_lident; add_open;_} -> + scan_pattern +let (__proj__Mkdep_scan_callbacks__item__add_lident : + dep_scan_callbacks -> FStarC_Ident.lident -> unit) = + fun projectee -> + match projectee with + | { scan_term; scan_binder; scan_pattern; add_lident; add_open;_} -> + add_lident +let (__proj__Mkdep_scan_callbacks__item__add_open : + dep_scan_callbacks -> FStarC_Ident.lident -> unit) = + fun projectee -> + match projectee with + | { scan_term; scan_binder; scan_pattern; add_lident; add_open;_} -> + add_open +type to_be_desugared = + { + lang_name: Prims.string ; + blob: FStarC_Dyn.dyn ; + idents: FStarC_Ident.ident Prims.list ; + to_string: FStarC_Dyn.dyn -> Prims.string ; + eq: FStarC_Dyn.dyn -> FStarC_Dyn.dyn -> Prims.bool ; + dep_scan: dep_scan_callbacks -> FStarC_Dyn.dyn -> unit } +let (__proj__Mkto_be_desugared__item__lang_name : + to_be_desugared -> Prims.string) = + fun projectee -> + match projectee with + | { lang_name; blob; idents; to_string; eq; dep_scan;_} -> lang_name +let (__proj__Mkto_be_desugared__item__blob : + to_be_desugared -> FStarC_Dyn.dyn) = + fun projectee -> + match projectee with + | { lang_name; blob; idents; to_string; eq; dep_scan;_} -> blob +let (__proj__Mkto_be_desugared__item__idents : + to_be_desugared -> FStarC_Ident.ident Prims.list) = + fun projectee -> + match projectee with + | { lang_name; blob; idents; to_string; eq; dep_scan;_} -> idents +let (__proj__Mkto_be_desugared__item__to_string : + to_be_desugared -> FStarC_Dyn.dyn -> Prims.string) = + fun projectee -> + match projectee with + | { lang_name; blob; idents; to_string; eq; dep_scan;_} -> to_string +let (__proj__Mkto_be_desugared__item__eq : + to_be_desugared -> FStarC_Dyn.dyn -> FStarC_Dyn.dyn -> Prims.bool) = + fun projectee -> + match projectee with + | { lang_name; blob; idents; to_string; eq; dep_scan;_} -> eq +let (__proj__Mkto_be_desugared__item__dep_scan : + to_be_desugared -> dep_scan_callbacks -> FStarC_Dyn.dyn -> unit) = + fun projectee -> + match projectee with + | { lang_name; blob; idents; to_string; eq; dep_scan;_} -> dep_scan +type decl' = + | TopLevelModule of FStarC_Ident.lid + | Open of (FStarC_Ident.lid * FStarC_Syntax_Syntax.restriction) + | Friend of FStarC_Ident.lid + | Include of (FStarC_Ident.lid * FStarC_Syntax_Syntax.restriction) + | ModuleAbbrev of (FStarC_Ident.ident * FStarC_Ident.lid) + | TopLevelLet of (let_qualifier * (pattern * term) Prims.list) + | Tycon of (Prims.bool * Prims.bool * tycon Prims.list) + | Val of (FStarC_Ident.ident * term) + | Exception of (FStarC_Ident.ident * term FStar_Pervasives_Native.option) + | NewEffect of effect_decl + | LayeredEffect of effect_decl + | SubEffect of lift + | Polymonadic_bind of (FStarC_Ident.lid * FStarC_Ident.lid * + FStarC_Ident.lid * term) + | Polymonadic_subcomp of (FStarC_Ident.lid * FStarC_Ident.lid * term) + | Pragma of pragma + | Assume of (FStarC_Ident.ident * term) + | Splice of (Prims.bool * FStarC_Ident.ident Prims.list * term) + | DeclSyntaxExtension of (Prims.string * Prims.string * + FStarC_Compiler_Range_Type.range * FStarC_Compiler_Range_Type.range) + | UseLangDecls of Prims.string + | DeclToBeDesugared of to_be_desugared + | Unparseable +and decl = + { + d: decl' ; + drange: FStarC_Compiler_Range_Type.range ; + quals: qualifiers ; + attrs: attributes_ ; + interleaved: Prims.bool } +and effect_decl = + | DefineEffect of (FStarC_Ident.ident * binder Prims.list * term * decl + Prims.list) + | RedefineEffect of (FStarC_Ident.ident * binder Prims.list * term) +let (uu___is_TopLevelModule : decl' -> Prims.bool) = + fun projectee -> + match projectee with | TopLevelModule _0 -> true | uu___ -> false +let (__proj__TopLevelModule__item___0 : decl' -> FStarC_Ident.lid) = + fun projectee -> match projectee with | TopLevelModule _0 -> _0 +let (uu___is_Open : decl' -> Prims.bool) = + fun projectee -> match projectee with | Open _0 -> true | uu___ -> false +let (__proj__Open__item___0 : + decl' -> (FStarC_Ident.lid * FStarC_Syntax_Syntax.restriction)) = + fun projectee -> match projectee with | Open _0 -> _0 +let (uu___is_Friend : decl' -> Prims.bool) = + fun projectee -> match projectee with | Friend _0 -> true | uu___ -> false +let (__proj__Friend__item___0 : decl' -> FStarC_Ident.lid) = + fun projectee -> match projectee with | Friend _0 -> _0 +let (uu___is_Include : decl' -> Prims.bool) = + fun projectee -> match projectee with | Include _0 -> true | uu___ -> false +let (__proj__Include__item___0 : + decl' -> (FStarC_Ident.lid * FStarC_Syntax_Syntax.restriction)) = + fun projectee -> match projectee with | Include _0 -> _0 +let (uu___is_ModuleAbbrev : decl' -> Prims.bool) = + fun projectee -> + match projectee with | ModuleAbbrev _0 -> true | uu___ -> false +let (__proj__ModuleAbbrev__item___0 : + decl' -> (FStarC_Ident.ident * FStarC_Ident.lid)) = + fun projectee -> match projectee with | ModuleAbbrev _0 -> _0 +let (uu___is_TopLevelLet : decl' -> Prims.bool) = + fun projectee -> + match projectee with | TopLevelLet _0 -> true | uu___ -> false +let (__proj__TopLevelLet__item___0 : + decl' -> (let_qualifier * (pattern * term) Prims.list)) = + fun projectee -> match projectee with | TopLevelLet _0 -> _0 +let (uu___is_Tycon : decl' -> Prims.bool) = + fun projectee -> match projectee with | Tycon _0 -> true | uu___ -> false +let (__proj__Tycon__item___0 : + decl' -> (Prims.bool * Prims.bool * tycon Prims.list)) = + fun projectee -> match projectee with | Tycon _0 -> _0 +let (uu___is_Val : decl' -> Prims.bool) = + fun projectee -> match projectee with | Val _0 -> true | uu___ -> false +let (__proj__Val__item___0 : decl' -> (FStarC_Ident.ident * term)) = + fun projectee -> match projectee with | Val _0 -> _0 +let (uu___is_Exception : decl' -> Prims.bool) = + fun projectee -> + match projectee with | Exception _0 -> true | uu___ -> false +let (__proj__Exception__item___0 : + decl' -> (FStarC_Ident.ident * term FStar_Pervasives_Native.option)) = + fun projectee -> match projectee with | Exception _0 -> _0 +let (uu___is_NewEffect : decl' -> Prims.bool) = + fun projectee -> + match projectee with | NewEffect _0 -> true | uu___ -> false +let (__proj__NewEffect__item___0 : decl' -> effect_decl) = + fun projectee -> match projectee with | NewEffect _0 -> _0 +let (uu___is_LayeredEffect : decl' -> Prims.bool) = + fun projectee -> + match projectee with | LayeredEffect _0 -> true | uu___ -> false +let (__proj__LayeredEffect__item___0 : decl' -> effect_decl) = + fun projectee -> match projectee with | LayeredEffect _0 -> _0 +let (uu___is_SubEffect : decl' -> Prims.bool) = + fun projectee -> + match projectee with | SubEffect _0 -> true | uu___ -> false +let (__proj__SubEffect__item___0 : decl' -> lift) = + fun projectee -> match projectee with | SubEffect _0 -> _0 +let (uu___is_Polymonadic_bind : decl' -> Prims.bool) = + fun projectee -> + match projectee with | Polymonadic_bind _0 -> true | uu___ -> false +let (__proj__Polymonadic_bind__item___0 : + decl' -> (FStarC_Ident.lid * FStarC_Ident.lid * FStarC_Ident.lid * term)) = + fun projectee -> match projectee with | Polymonadic_bind _0 -> _0 +let (uu___is_Polymonadic_subcomp : decl' -> Prims.bool) = + fun projectee -> + match projectee with | Polymonadic_subcomp _0 -> true | uu___ -> false +let (__proj__Polymonadic_subcomp__item___0 : + decl' -> (FStarC_Ident.lid * FStarC_Ident.lid * term)) = + fun projectee -> match projectee with | Polymonadic_subcomp _0 -> _0 +let (uu___is_Pragma : decl' -> Prims.bool) = + fun projectee -> match projectee with | Pragma _0 -> true | uu___ -> false +let (__proj__Pragma__item___0 : decl' -> pragma) = + fun projectee -> match projectee with | Pragma _0 -> _0 +let (uu___is_Assume : decl' -> Prims.bool) = + fun projectee -> match projectee with | Assume _0 -> true | uu___ -> false +let (__proj__Assume__item___0 : decl' -> (FStarC_Ident.ident * term)) = + fun projectee -> match projectee with | Assume _0 -> _0 +let (uu___is_Splice : decl' -> Prims.bool) = + fun projectee -> match projectee with | Splice _0 -> true | uu___ -> false +let (__proj__Splice__item___0 : + decl' -> (Prims.bool * FStarC_Ident.ident Prims.list * term)) = + fun projectee -> match projectee with | Splice _0 -> _0 +let (uu___is_DeclSyntaxExtension : decl' -> Prims.bool) = + fun projectee -> + match projectee with | DeclSyntaxExtension _0 -> true | uu___ -> false +let (__proj__DeclSyntaxExtension__item___0 : + decl' -> + (Prims.string * Prims.string * FStarC_Compiler_Range_Type.range * + FStarC_Compiler_Range_Type.range)) + = fun projectee -> match projectee with | DeclSyntaxExtension _0 -> _0 +let (uu___is_UseLangDecls : decl' -> Prims.bool) = + fun projectee -> + match projectee with | UseLangDecls _0 -> true | uu___ -> false +let (__proj__UseLangDecls__item___0 : decl' -> Prims.string) = + fun projectee -> match projectee with | UseLangDecls _0 -> _0 +let (uu___is_DeclToBeDesugared : decl' -> Prims.bool) = + fun projectee -> + match projectee with | DeclToBeDesugared _0 -> true | uu___ -> false +let (__proj__DeclToBeDesugared__item___0 : decl' -> to_be_desugared) = + fun projectee -> match projectee with | DeclToBeDesugared _0 -> _0 +let (uu___is_Unparseable : decl' -> Prims.bool) = + fun projectee -> + match projectee with | Unparseable -> true | uu___ -> false +let (__proj__Mkdecl__item__d : decl -> decl') = + fun projectee -> + match projectee with | { d; drange; quals; attrs; interleaved;_} -> d +let (__proj__Mkdecl__item__drange : decl -> FStarC_Compiler_Range_Type.range) + = + fun projectee -> + match projectee with + | { d; drange; quals; attrs; interleaved;_} -> drange +let (__proj__Mkdecl__item__quals : decl -> qualifiers) = + fun projectee -> + match projectee with | { d; drange; quals; attrs; interleaved;_} -> quals +let (__proj__Mkdecl__item__attrs : decl -> attributes_) = + fun projectee -> + match projectee with | { d; drange; quals; attrs; interleaved;_} -> attrs +let (__proj__Mkdecl__item__interleaved : decl -> Prims.bool) = + fun projectee -> + match projectee with + | { d; drange; quals; attrs; interleaved;_} -> interleaved +let (uu___is_DefineEffect : effect_decl -> Prims.bool) = + fun projectee -> + match projectee with | DefineEffect _0 -> true | uu___ -> false +let (__proj__DefineEffect__item___0 : + effect_decl -> + (FStarC_Ident.ident * binder Prims.list * term * decl Prims.list)) + = fun projectee -> match projectee with | DefineEffect _0 -> _0 +let (uu___is_RedefineEffect : effect_decl -> Prims.bool) = + fun projectee -> + match projectee with | RedefineEffect _0 -> true | uu___ -> false +let (__proj__RedefineEffect__item___0 : + effect_decl -> (FStarC_Ident.ident * binder Prims.list * term)) = + fun projectee -> match projectee with | RedefineEffect _0 -> _0 +let (hasRange_decl : decl FStarC_Class_HasRange.hasRange) = + { + FStarC_Class_HasRange.pos = (fun d -> d.drange); + FStarC_Class_HasRange.setPos = + (fun r -> + fun d -> + { + d = (d.d); + drange = r; + quals = (d.quals); + attrs = (d.attrs); + interleaved = (d.interleaved) + }) + } +type modul = + | Module of (FStarC_Ident.lid * decl Prims.list) + | Interface of (FStarC_Ident.lid * decl Prims.list * Prims.bool) +let (uu___is_Module : modul -> Prims.bool) = + fun projectee -> match projectee with | Module _0 -> true | uu___ -> false +let (__proj__Module__item___0 : + modul -> (FStarC_Ident.lid * decl Prims.list)) = + fun projectee -> match projectee with | Module _0 -> _0 +let (uu___is_Interface : modul -> Prims.bool) = + fun projectee -> + match projectee with | Interface _0 -> true | uu___ -> false +let (__proj__Interface__item___0 : + modul -> (FStarC_Ident.lid * decl Prims.list * Prims.bool)) = + fun projectee -> match projectee with | Interface _0 -> _0 +type file = modul +type inputFragment = (file, decl Prims.list) FStar_Pervasives.either +let (lid_of_modul : modul -> FStarC_Ident.lid) = + fun m -> + match m with + | Module (lid, uu___) -> lid + | Interface (lid, uu___, uu___1) -> lid +let (check_id : FStarC_Ident.ident -> unit) = + fun id -> + let first_char = + let uu___ = FStarC_Ident.string_of_id id in + FStarC_Compiler_String.substring uu___ Prims.int_zero Prims.int_one in + if + Prims.op_Negation + ((FStarC_Compiler_String.lowercase first_char) = first_char) + then + let uu___ = + let uu___1 = FStarC_Class_Show.show FStarC_Ident.showable_ident id in + FStarC_Compiler_Util.format1 + "Invalid identifer '%s'; expected a symbol that begins with a lower-case character" + uu___1 in + FStarC_Errors.raise_error FStarC_Ident.hasrange_ident id + FStarC_Errors_Codes.Fatal_InvalidIdentifier () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___) + else () +let at_most_one : + 'uuuuu . + Prims.string -> + FStarC_Compiler_Range_Type.range -> + 'uuuuu Prims.list -> 'uuuuu FStar_Pervasives_Native.option + = + fun s -> + fun r -> + fun l -> + match l with + | x::[] -> FStar_Pervasives_Native.Some x + | [] -> FStar_Pervasives_Native.None + | uu___ -> + let uu___1 = + FStarC_Compiler_Util.format1 + "At most one %s is allowed on declarations" s in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_MoreThanOneDeclaration () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) +let (mk_binder_with_attrs : + binder' -> + FStarC_Compiler_Range_Type.range -> + level -> aqual -> term Prims.list -> binder) + = + fun b -> + fun r -> + fun l -> + fun i -> + fun attrs -> + { b; brange = r; blevel = l; aqual = i; battributes = attrs } +let (mk_binder : + binder' -> FStarC_Compiler_Range_Type.range -> level -> aqual -> binder) = + fun b -> fun r -> fun l -> fun i -> mk_binder_with_attrs b r l i [] +let (mk_term : term' -> FStarC_Compiler_Range_Type.range -> level -> term) = + fun t -> fun r -> fun l -> { tm = t; range = r; level = l } +let (mk_uminus : + term -> + FStarC_Compiler_Range_Type.range -> + FStarC_Compiler_Range_Type.range -> level -> term) + = + fun t -> + fun rminus -> + fun r -> + fun l -> + let t1 = + match t.tm with + | Const (FStarC_Const.Const_int + (s, FStar_Pervasives_Native.Some + (FStarC_Const.Signed, width))) + -> + Const + (FStarC_Const.Const_int + ((Prims.strcat "-" s), + (FStar_Pervasives_Native.Some + (FStarC_Const.Signed, width)))) + | uu___ -> + let uu___1 = + let uu___2 = FStarC_Ident.mk_ident ("-", rminus) in + (uu___2, [t]) in + Op uu___1 in + mk_term t1 r l +let (mk_pattern : pattern' -> FStarC_Compiler_Range_Type.range -> pattern) = + fun p -> fun r -> { pat = p; prange = r } +let (un_curry_abs : pattern Prims.list -> term -> term') = + fun ps -> + fun body -> + match body.tm with + | Abs (p', body') -> Abs ((FStarC_Compiler_List.op_At ps p'), body') + | uu___ -> Abs (ps, body) +let (mk_function : + branch Prims.list -> + FStarC_Compiler_Range_Type.range -> + FStarC_Compiler_Range_Type.range -> term) + = + fun branches -> + fun r1 -> fun r2 -> mk_term (Function (branches, r1)) r2 Expr +let (un_function : + pattern -> term -> (pattern * term) FStar_Pervasives_Native.option) = + fun p -> + fun tm -> + match ((p.pat), (tm.tm)) with + | (PatVar uu___, Abs (pats, body)) -> + let uu___1 = + let uu___2 = mk_pattern (PatApp (p, pats)) p.prange in + (uu___2, body) in + FStar_Pervasives_Native.Some uu___1 + | uu___ -> FStar_Pervasives_Native.None +let (mkApp : + term -> (term * imp) Prims.list -> FStarC_Compiler_Range_Type.range -> term) + = + fun t -> + fun args -> + fun r -> + match args with + | [] -> t + | uu___ -> + (match t.tm with + | Name s -> mk_term (Construct (s, args)) r Un + | uu___1 -> + FStarC_Compiler_List.fold_left + (fun t1 -> + fun uu___2 -> + match uu___2 with + | (a, imp1) -> mk_term (App (t1, a, imp1)) r Un) t + args) +let (consPat : + FStarC_Compiler_Range_Type.range -> pattern -> pattern -> pattern') = + fun r -> + fun hd -> + fun tl -> + let uu___ = + let uu___1 = mk_pattern (PatName FStarC_Parser_Const.cons_lid) r in + (uu___1, [hd; tl]) in + PatApp uu___ +let (consTerm : FStarC_Compiler_Range_Type.range -> term -> term -> term) = + fun r -> + fun hd -> + fun tl -> + mk_term + (Construct + (FStarC_Parser_Const.cons_lid, [(hd, Nothing); (tl, Nothing)])) + r Expr +let (mkListLit : FStarC_Compiler_Range_Type.range -> term Prims.list -> term) + = fun r -> fun elts -> mk_term (ListLiteral elts) r Expr +let (mkSeqLit : FStarC_Compiler_Range_Type.range -> term Prims.list -> term) + = fun r -> fun elts -> mk_term (SeqLiteral elts) r Expr +let (unit_const : FStarC_Compiler_Range_Type.range -> term) = + fun r -> mk_term (Const FStarC_Const.Const_unit) r Expr +let (ml_comp : term -> term) = + fun t -> + let lid = FStarC_Parser_Const.effect_ML_lid () in + let ml = mk_term (Name lid) t.range Expr in + let t1 = mk_term (App (ml, t, Nothing)) t.range Expr in t1 +let (tot_comp : term -> term) = + fun t -> + let ml = mk_term (Name FStarC_Parser_Const.effect_Tot_lid) t.range Expr in + let t1 = mk_term (App (ml, t, Nothing)) t.range Expr in t1 +let (mkRefSet : FStarC_Compiler_Range_Type.range -> term Prims.list -> term) + = + fun r -> + fun elts -> + let uu___ = + (FStarC_Parser_Const.set_empty, FStarC_Parser_Const.set_singleton, + FStarC_Parser_Const.set_union, + FStarC_Parser_Const.heap_addr_of_lid) in + match uu___ with + | (empty_lid, singleton_lid, union_lid, addr_of_lid) -> + let empty = + let uu___1 = + let uu___2 = FStarC_Ident.set_lid_range empty_lid r in + Var uu___2 in + mk_term uu___1 r Expr in + let addr_of = + let uu___1 = + let uu___2 = FStarC_Ident.set_lid_range addr_of_lid r in + Var uu___2 in + mk_term uu___1 r Expr in + let singleton = + let uu___1 = + let uu___2 = FStarC_Ident.set_lid_range singleton_lid r in + Var uu___2 in + mk_term uu___1 r Expr in + let union = + let uu___1 = + let uu___2 = FStarC_Ident.set_lid_range union_lid r in + Var uu___2 in + mk_term uu___1 r Expr in + FStarC_Compiler_List.fold_right + (fun e -> + fun tl -> + let e1 = mkApp addr_of [(e, Nothing)] r in + let single_e = mkApp singleton [(e1, Nothing)] r in + mkApp union [(single_e, Nothing); (tl, Nothing)] r) elts + empty +let (mkExplicitApp : + term -> term Prims.list -> FStarC_Compiler_Range_Type.range -> term) = + fun t -> + fun args -> + fun r -> + match args with + | [] -> t + | uu___ -> + (match t.tm with + | Name s -> + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Compiler_List.map (fun a -> (a, Nothing)) args in + (s, uu___3) in + Construct uu___2 in + mk_term uu___1 r Un + | uu___1 -> + FStarC_Compiler_List.fold_left + (fun t1 -> fun a -> mk_term (App (t1, a, Nothing)) r Un) t + args) +let (mkAdmitMagic : FStarC_Compiler_Range_Type.range -> term) = + fun r -> + let admit = + let admit_name = + let uu___ = + let uu___1 = + FStarC_Ident.set_lid_range FStarC_Parser_Const.admit_lid r in + Var uu___1 in + mk_term uu___ r Expr in + let uu___ = let uu___1 = unit_const r in [uu___1] in + mkExplicitApp admit_name uu___ r in + let magic = + let magic_name = + let uu___ = + let uu___1 = + FStarC_Ident.set_lid_range FStarC_Parser_Const.magic_lid r in + Var uu___1 in + mk_term uu___ r Expr in + let uu___ = let uu___1 = unit_const r in [uu___1] in + mkExplicitApp magic_name uu___ r in + let admit_magic = mk_term (Seq (admit, magic)) r Expr in admit_magic +let mkWildAdmitMagic : + 'uuuuu . + FStarC_Compiler_Range_Type.range -> + (pattern * 'uuuuu FStar_Pervasives_Native.option * term) + = + fun r -> + let uu___ = mk_pattern (PatWild (FStar_Pervasives_Native.None, [])) r in + let uu___1 = mkAdmitMagic r in + (uu___, FStar_Pervasives_Native.None, uu___1) +let focusBranches : + 'uuuuu . + (Prims.bool * (pattern * 'uuuuu FStar_Pervasives_Native.option * term)) + Prims.list -> + FStarC_Compiler_Range_Type.range -> + (pattern * 'uuuuu FStar_Pervasives_Native.option * term) Prims.list + = + fun branches -> + fun r -> + let should_filter = + FStarC_Compiler_Util.for_some FStar_Pervasives_Native.fst branches in + if should_filter + then + (FStarC_Errors.log_issue FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Warning_Filtered () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "Focusing on only some cases"); + (let focussed = + let uu___1 = + FStarC_Compiler_List.filter FStar_Pervasives_Native.fst + branches in + FStarC_Compiler_List.map FStar_Pervasives_Native.snd uu___1 in + let uu___1 = let uu___2 = mkWildAdmitMagic r in [uu___2] in + FStarC_Compiler_List.op_At focussed uu___1)) + else FStarC_Compiler_List.map FStar_Pervasives_Native.snd branches +let (focusLetBindings : + (Prims.bool * (pattern * term)) Prims.list -> + FStarC_Compiler_Range_Type.range -> (pattern * term) Prims.list) + = + fun lbs -> + fun r -> + let should_filter = + FStarC_Compiler_Util.for_some FStar_Pervasives_Native.fst lbs in + if should_filter + then + (FStarC_Errors.log_issue FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Warning_Filtered () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Focusing on only some cases in this (mutually) recursive definition"); + FStarC_Compiler_List.map + (fun uu___1 -> + match uu___1 with + | (f, lb) -> + if f + then lb + else + (let uu___3 = mkAdmitMagic r in + ((FStar_Pervasives_Native.fst lb), uu___3))) lbs) + else FStarC_Compiler_List.map FStar_Pervasives_Native.snd lbs +let (focusAttrLetBindings : + (attributes_ FStar_Pervasives_Native.option * (Prims.bool * (pattern * + term))) Prims.list -> + FStarC_Compiler_Range_Type.range -> + (attributes_ FStar_Pervasives_Native.option * (pattern * term)) + Prims.list) + = + fun lbs -> + fun r -> + let should_filter = + FStarC_Compiler_Util.for_some + (fun uu___ -> match uu___ with | (attr, (focus, uu___1)) -> focus) + lbs in + if should_filter + then + (FStarC_Errors.log_issue FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Warning_Filtered () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Focusing on only some cases in this (mutually) recursive definition"); + FStarC_Compiler_List.map + (fun uu___1 -> + match uu___1 with + | (attr, (f, lb)) -> + if f + then (attr, lb) + else + (let uu___3 = + let uu___4 = mkAdmitMagic r in + ((FStar_Pervasives_Native.fst lb), uu___4) in + (attr, uu___3))) lbs) + else + FStarC_Compiler_List.map + (fun uu___1 -> + match uu___1 with | (attr, (uu___2, lb)) -> (attr, lb)) lbs +let (mkFsTypApp : + term -> term Prims.list -> FStarC_Compiler_Range_Type.range -> term) = + fun t -> + fun args -> + fun r -> + let uu___ = FStarC_Compiler_List.map (fun a -> (a, FsTypApp)) args in + mkApp t uu___ r +let (mkTuple : term Prims.list -> FStarC_Compiler_Range_Type.range -> term) = + fun args -> + fun r -> + let cons = + FStarC_Parser_Const.mk_tuple_data_lid + (FStarC_Compiler_List.length args) r in + let uu___ = mk_term (Name cons) r Expr in + let uu___1 = FStarC_Compiler_List.map (fun x -> (x, Nothing)) args in + mkApp uu___ uu___1 r +let (mkDTuple : term Prims.list -> FStarC_Compiler_Range_Type.range -> term) + = + fun args -> + fun r -> + let cons = + FStarC_Parser_Const.mk_dtuple_data_lid + (FStarC_Compiler_List.length args) r in + let uu___ = mk_term (Name cons) r Expr in + let uu___1 = FStarC_Compiler_List.map (fun x -> (x, Nothing)) args in + mkApp uu___ uu___1 r +let (mkRefinedBinder : + FStarC_Ident.ident -> + term -> + Prims.bool -> + term FStar_Pervasives_Native.option -> + FStarC_Compiler_Range_Type.range -> + aqual -> term Prims.list -> binder) + = + fun id -> + fun t -> + fun should_bind_var -> + fun refopt -> + fun m -> + fun implicit -> + fun attrs -> + let b = + mk_binder_with_attrs (Annotated (id, t)) m Type_level + implicit attrs in + match refopt with + | FStar_Pervasives_Native.None -> b + | FStar_Pervasives_Native.Some phi -> + if should_bind_var + then + let uu___ = + let uu___1 = + let uu___2 = mk_term (Refine (b, phi)) m Type_level in + (id, uu___2) in + Annotated uu___1 in + mk_binder_with_attrs uu___ m Type_level implicit attrs + else + (let x = FStarC_Ident.gen t.range in + let b1 = + mk_binder_with_attrs (Annotated (x, t)) m Type_level + implicit attrs in + let uu___1 = + let uu___2 = + let uu___3 = + mk_term (Refine (b1, phi)) m Type_level in + (id, uu___3) in + Annotated uu___2 in + mk_binder_with_attrs uu___1 m Type_level implicit + attrs) +let (mkRefinedPattern : + pattern -> + term -> + Prims.bool -> + term FStar_Pervasives_Native.option -> + FStarC_Compiler_Range_Type.range -> + FStarC_Compiler_Range_Type.range -> pattern) + = + fun pat -> + fun t -> + fun should_bind_pat -> + fun phi_opt -> + fun t_range -> + fun range -> + let t1 = + match phi_opt with + | FStar_Pervasives_Native.None -> t + | FStar_Pervasives_Native.Some phi -> + if should_bind_pat + then + (match pat.pat with + | PatVar (x, uu___, attrs) -> + let uu___1 = + let uu___2 = + let uu___3 = + mk_binder_with_attrs (Annotated (x, t)) + t_range Type_level + FStar_Pervasives_Native.None attrs in + (uu___3, phi) in + Refine uu___2 in + mk_term uu___1 range Type_level + | uu___ -> + let x = FStarC_Ident.gen t_range in + let phi1 = + let x_var = + let uu___1 = + let uu___2 = FStarC_Ident.lid_of_ids [x] in + Var uu___2 in + mk_term uu___1 phi.range Formula in + let pat_branch = + (pat, FStar_Pervasives_Native.None, phi) in + let otherwise_branch = + let uu___1 = + mk_pattern + (PatWild + (FStar_Pervasives_Native.None, [])) + phi.range in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Ident.lid_of_path ["False"] + phi.range in + Name uu___4 in + mk_term uu___3 phi.range Formula in + (uu___1, FStar_Pervasives_Native.None, uu___2) in + mk_term + (Match + (x_var, FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None, + [pat_branch; otherwise_branch])) + phi.range Formula in + let uu___1 = + let uu___2 = + let uu___3 = + mk_binder (Annotated (x, t)) t_range + Type_level FStar_Pervasives_Native.None in + (uu___3, phi1) in + Refine uu___2 in + mk_term uu___1 range Type_level) + else + (let x = FStarC_Ident.gen t.range in + let uu___1 = + let uu___2 = + let uu___3 = + mk_binder (Annotated (x, t)) t_range Type_level + FStar_Pervasives_Native.None in + (uu___3, phi) in + Refine uu___2 in + mk_term uu___1 range Type_level) in + mk_pattern + (PatAscribed (pat, (t1, FStar_Pervasives_Native.None))) range +let rec (extract_named_refinement : + Prims.bool -> + term -> + (FStarC_Ident.ident * term * term FStar_Pervasives_Native.option) + FStar_Pervasives_Native.option) + = + fun remove_parens -> + fun t1 -> + match t1.tm with + | NamedTyp (x, t) -> + FStar_Pervasives_Native.Some (x, t, FStar_Pervasives_Native.None) + | Refine + ({ b = Annotated (x, t); brange = uu___; blevel = uu___1; + aqual = uu___2; battributes = uu___3;_}, + t') + -> + FStar_Pervasives_Native.Some + (x, t, (FStar_Pervasives_Native.Some t')) + | Paren t when remove_parens -> + extract_named_refinement remove_parens t + | uu___ -> FStar_Pervasives_Native.None +let rec (as_mlist : + ((FStarC_Ident.lid * decl) * decl Prims.list) -> decl Prims.list -> modul) + = + fun cur -> + fun ds -> + let uu___ = cur in + match uu___ with + | ((m_name, m_decl), cur1) -> + (match ds with + | [] -> + Module (m_name, (m_decl :: (FStarC_Compiler_List.rev cur1))) + | d::ds1 -> + (match d.d with + | TopLevelModule m' -> + FStarC_Errors.raise_error hasRange_decl d + FStarC_Errors_Codes.Fatal_UnexpectedModuleDeclaration + () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "Unexpected module declaration") + | uu___1 -> as_mlist ((m_name, m_decl), (d :: cur1)) ds1)) +let (as_frag : decl Prims.list -> inputFragment) = + fun ds -> + let uu___ = + match ds with + | d::ds1 -> (d, ds1) + | [] -> FStarC_Compiler_Effect.raise FStarC_Errors.Empty_frag in + match uu___ with + | (d, ds1) -> + (match d.d with + | TopLevelModule m -> + let m1 = as_mlist ((m, d), []) ds1 in FStar_Pervasives.Inl m1 + | uu___1 -> + let ds2 = d :: ds1 in + (FStarC_Compiler_List.iter + (fun uu___3 -> + match uu___3 with + | { d = TopLevelModule uu___4; drange = r; quals = uu___5; + attrs = uu___6; interleaved = uu___7;_} -> + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_UnexpectedModuleDeclaration + () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "Unexpected module declaration") + | uu___4 -> ()) ds2; + FStar_Pervasives.Inr ds2)) +let (strip_prefix : + Prims.string -> Prims.string -> Prims.string FStar_Pervasives_Native.option) + = + fun prefix -> + fun s -> + if FStarC_Compiler_Util.starts_with s prefix + then + let uu___ = + FStarC_Compiler_Util.substring_from s + (FStarC_Compiler_String.length prefix) in + FStar_Pervasives_Native.Some uu___ + else FStar_Pervasives_Native.None +let (compile_op : + Prims.int -> + Prims.string -> FStarC_Compiler_Range_Type.range -> Prims.string) + = + fun arity -> + fun s -> + fun r -> + let name_of_char uu___ = + match uu___ with + | 38 -> "Amp" + | 64 -> "At" + | 43 -> "Plus" + | 45 when arity = Prims.int_one -> "Minus" + | 45 -> "Subtraction" + | 126 -> "Tilde" + | 47 -> "Slash" + | 92 -> "Backslash" + | 60 -> "Less" + | 61 -> "Equals" + | 62 -> "Greater" + | 95 -> "Underscore" + | 124 -> "Bar" + | 33 -> "Bang" + | 94 -> "Hat" + | 37 -> "Percent" + | 42 -> "Star" + | 63 -> "Question" + | 58 -> "Colon" + | 36 -> "Dollar" + | 46 -> "Dot" + | c -> + let uu___1 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_Util.int_of_char c) in + Prims.strcat "u" uu___1 in + match s with + | ".[]<-" -> "op_String_Assignment" + | ".()<-" -> "op_Array_Assignment" + | ".[||]<-" -> "op_Brack_Lens_Assignment" + | ".(||)<-" -> "op_Lens_Assignment" + | ".[]" -> "op_String_Access" + | ".()" -> "op_Array_Access" + | ".[||]" -> "op_Brack_Lens_Access" + | ".(||)" -> "op_Lens_Access" + | uu___ -> + let uu___1 = + if + (FStarC_Compiler_Util.starts_with s "let") || + (FStarC_Compiler_Util.starts_with s "and") + then + let uu___2 = + let uu___3 = + FStarC_Compiler_Util.substring s Prims.int_zero + (Prims.of_int (3)) in + Prims.strcat uu___3 "_" in + let uu___3 = + FStarC_Compiler_Util.substring_from s (Prims.of_int (3)) in + (uu___2, uu___3) + else + if + (FStarC_Compiler_Util.starts_with s "exists") || + (FStarC_Compiler_Util.starts_with s "forall") + then + (let uu___3 = + let uu___4 = + FStarC_Compiler_Util.substring s Prims.int_zero + (Prims.of_int (6)) in + Prims.strcat uu___4 "_" in + let uu___4 = + FStarC_Compiler_Util.substring_from s (Prims.of_int (6)) in + (uu___3, uu___4)) + else ("", s) in + (match uu___1 with + | (prefix, s1) -> + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Compiler_String.list_of_string s1 in + FStarC_Compiler_List.map name_of_char uu___5 in + FStarC_Compiler_String.concat "_" uu___4 in + Prims.strcat prefix uu___3 in + Prims.strcat "op_" uu___2) +let (compile_op' : + Prims.string -> FStarC_Compiler_Range_Type.range -> Prims.string) = + fun s -> fun r -> compile_op (Prims.of_int (-1)) s r +let (string_to_op : + Prims.string -> + (Prims.string * Prims.int FStar_Pervasives_Native.option) + FStar_Pervasives_Native.option) + = + fun s -> + let name_of_op s1 = + match s1 with + | "Amp" -> + FStar_Pervasives_Native.Some ("&", FStar_Pervasives_Native.None) + | "At" -> + FStar_Pervasives_Native.Some ("@", FStar_Pervasives_Native.None) + | "Plus" -> + FStar_Pervasives_Native.Some + ("+", (FStar_Pervasives_Native.Some (Prims.of_int (2)))) + | "Minus" -> + FStar_Pervasives_Native.Some ("-", FStar_Pervasives_Native.None) + | "Subtraction" -> + FStar_Pervasives_Native.Some + ("-", (FStar_Pervasives_Native.Some (Prims.of_int (2)))) + | "Tilde" -> + FStar_Pervasives_Native.Some ("~", FStar_Pervasives_Native.None) + | "Slash" -> + FStar_Pervasives_Native.Some + ("/", (FStar_Pervasives_Native.Some (Prims.of_int (2)))) + | "Backslash" -> + FStar_Pervasives_Native.Some ("\\", FStar_Pervasives_Native.None) + | "Less" -> + FStar_Pervasives_Native.Some + ("<", (FStar_Pervasives_Native.Some (Prims.of_int (2)))) + | "Equals" -> + FStar_Pervasives_Native.Some ("=", FStar_Pervasives_Native.None) + | "Greater" -> + FStar_Pervasives_Native.Some + (">", (FStar_Pervasives_Native.Some (Prims.of_int (2)))) + | "Underscore" -> + FStar_Pervasives_Native.Some ("_", FStar_Pervasives_Native.None) + | "Bar" -> + FStar_Pervasives_Native.Some ("|", FStar_Pervasives_Native.None) + | "Bang" -> + FStar_Pervasives_Native.Some ("!", FStar_Pervasives_Native.None) + | "Hat" -> + FStar_Pervasives_Native.Some ("^", FStar_Pervasives_Native.None) + | "Percent" -> + FStar_Pervasives_Native.Some ("%", FStar_Pervasives_Native.None) + | "Star" -> + FStar_Pervasives_Native.Some ("*", FStar_Pervasives_Native.None) + | "Question" -> + FStar_Pervasives_Native.Some ("?", FStar_Pervasives_Native.None) + | "Colon" -> + FStar_Pervasives_Native.Some (":", FStar_Pervasives_Native.None) + | "Dollar" -> + FStar_Pervasives_Native.Some ("$", FStar_Pervasives_Native.None) + | "Dot" -> + FStar_Pervasives_Native.Some (".", FStar_Pervasives_Native.None) + | "let" -> + FStar_Pervasives_Native.Some (s1, FStar_Pervasives_Native.None) + | "and" -> + FStar_Pervasives_Native.Some (s1, FStar_Pervasives_Native.None) + | "forall" -> + FStar_Pervasives_Native.Some (s1, FStar_Pervasives_Native.None) + | "exists" -> + FStar_Pervasives_Native.Some (s1, FStar_Pervasives_Native.None) + | uu___ -> FStar_Pervasives_Native.None in + match s with + | "op_String_Assignment" -> + FStar_Pervasives_Native.Some (".[]<-", FStar_Pervasives_Native.None) + | "op_Array_Assignment" -> + FStar_Pervasives_Native.Some (".()<-", FStar_Pervasives_Native.None) + | "op_Brack_Lens_Assignment" -> + FStar_Pervasives_Native.Some + (".[||]<-", FStar_Pervasives_Native.None) + | "op_Lens_Assignment" -> + FStar_Pervasives_Native.Some + (".(||)<-", FStar_Pervasives_Native.None) + | "op_String_Access" -> + FStar_Pervasives_Native.Some (".[]", FStar_Pervasives_Native.None) + | "op_Array_Access" -> + FStar_Pervasives_Native.Some (".()", FStar_Pervasives_Native.None) + | "op_Brack_Lens_Access" -> + FStar_Pervasives_Native.Some (".[||]", FStar_Pervasives_Native.None) + | "op_Lens_Access" -> + FStar_Pervasives_Native.Some (".(||)", FStar_Pervasives_Native.None) + | uu___ -> + if FStarC_Compiler_Util.starts_with s "op_" + then + let frags = + let uu___1 = + FStarC_Compiler_Util.substring_from s + (FStarC_Compiler_String.length "op_") in + FStarC_Compiler_Util.split uu___1 "_" in + (match frags with + | op::[] -> + if FStarC_Compiler_Util.starts_with op "u" + then + let uu___1 = + let uu___2 = + FStarC_Compiler_Util.substring_from op Prims.int_one in + FStarC_Compiler_Util.safe_int_of_string uu___2 in + FStarC_Compiler_Util.map_opt uu___1 + (fun op1 -> + ((FStarC_Compiler_Util.string_of_char + (FStarC_Compiler_Util.char_of_int op1)), + FStar_Pervasives_Native.None)) + else name_of_op op + | uu___1 -> + let maybeop = + let uu___2 = FStarC_Compiler_List.map name_of_op frags in + FStarC_Compiler_List.fold_left + (fun acc -> + fun x -> + match acc with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some acc1 -> + (match x with + | FStar_Pervasives_Native.Some (op, uu___3) -> + FStar_Pervasives_Native.Some + (Prims.strcat acc1 op) + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None)) + (FStar_Pervasives_Native.Some "") uu___2 in + FStarC_Compiler_Util.map_opt maybeop + (fun o -> (o, FStar_Pervasives_Native.None))) + else FStar_Pervasives_Native.None +let (string_of_fsdoc : + (Prims.string * (Prims.string * Prims.string) Prims.list) -> Prims.string) + = + fun uu___ -> + match uu___ with + | (comment, keywords) -> + let uu___1 = + let uu___2 = + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with + | (k, v) -> Prims.strcat k (Prims.strcat "->" v)) keywords in + FStarC_Compiler_String.concat "," uu___2 in + Prims.strcat comment uu___1 +let (string_of_let_qualifier : let_qualifier -> Prims.string) = + fun uu___ -> match uu___ with | NoLetQualifier -> "" | Rec -> "rec" +let to_string_l : + 'uuuuu . + Prims.string -> + ('uuuuu -> Prims.string) -> 'uuuuu Prims.list -> Prims.string + = + fun sep -> + fun f -> + fun l -> + let uu___ = FStarC_Compiler_List.map f l in + FStarC_Compiler_String.concat sep uu___ +let (imp_to_string : imp -> Prims.string) = + fun uu___ -> match uu___ with | Hash -> "#" | uu___1 -> "" +let rec (term_to_string : term -> Prims.string) = + fun x -> + match x.tm with + | Wild -> "_" + | LexList l -> + let uu___ = + match l with + | [] -> " " + | hd::tl -> + let uu___1 = term_to_string hd in + FStarC_Compiler_List.fold_left + (fun s -> + fun t -> + let uu___2 = + let uu___3 = term_to_string t in + Prims.strcat "; " uu___3 in + Prims.strcat s uu___2) uu___1 tl in + FStarC_Compiler_Util.format1 "%[%s]" uu___ + | Decreases (t, uu___) -> + let uu___1 = term_to_string t in + FStarC_Compiler_Util.format1 "(decreases %s)" uu___1 + | Requires (t, uu___) -> + let uu___1 = term_to_string t in + FStarC_Compiler_Util.format1 "(requires %s)" uu___1 + | Ensures (t, uu___) -> + let uu___1 = term_to_string t in + FStarC_Compiler_Util.format1 "(ensures %s)" uu___1 + | Labeled (t, l, uu___) -> + let uu___1 = term_to_string t in + FStarC_Compiler_Util.format2 "(labeled %s %s)" l uu___1 + | Const c -> FStarC_Parser_Const.const_to_string c + | Op (s, xs) -> + let uu___ = FStarC_Ident.string_of_id s in + let uu___1 = + let uu___2 = + FStarC_Compiler_List.map (fun x1 -> term_to_string x1) xs in + FStarC_Compiler_String.concat ", " uu___2 in + FStarC_Compiler_Util.format2 "%s(%s)" uu___ uu___1 + | Tvar id -> FStarC_Ident.string_of_id id + | Uvar id -> FStarC_Ident.string_of_id id + | Var l -> FStarC_Ident.string_of_lid l + | Name l -> FStarC_Ident.string_of_lid l + | Projector (rec_lid, field_id) -> + let uu___ = FStarC_Ident.string_of_lid rec_lid in + let uu___1 = FStarC_Ident.string_of_id field_id in + FStarC_Compiler_Util.format2 "%s?.%s" uu___ uu___1 + | Construct (l, args) -> + let uu___ = FStarC_Ident.string_of_lid l in + let uu___1 = + to_string_l " " + (fun uu___2 -> + match uu___2 with + | (a, imp1) -> + let uu___3 = term_to_string a in + FStarC_Compiler_Util.format2 "%s%s" (imp_to_string imp1) + uu___3) args in + FStarC_Compiler_Util.format2 "(%s %s)" uu___ uu___1 + | Function (branches, r) -> + let uu___ = + to_string_l " | " + (fun uu___1 -> + match uu___1 with + | (p, w, e) -> + let uu___2 = pat_to_string p in + let uu___3 = term_to_string e in + FStarC_Compiler_Util.format2 "%s -> %s" uu___2 uu___3) + branches in + FStarC_Compiler_Util.format1 "(function %s)" uu___ + | Abs (pats, t) -> + let uu___ = to_string_l " " pat_to_string pats in + let uu___1 = term_to_string t in + FStarC_Compiler_Util.format2 "(fun %s -> %s)" uu___ uu___1 + | App (t1, t2, imp1) -> + let uu___ = term_to_string t1 in + let uu___1 = term_to_string t2 in + FStarC_Compiler_Util.format3 "%s %s%s" uu___ (imp_to_string imp1) + uu___1 + | Let (Rec, (a, (p, b))::lbs, body) -> + let uu___ = attrs_opt_to_string a in + let uu___1 = + let uu___2 = pat_to_string p in + let uu___3 = term_to_string b in + FStarC_Compiler_Util.format2 "%s=%s" uu___2 uu___3 in + let uu___2 = + to_string_l " " + (fun uu___3 -> + match uu___3 with + | (a1, (p1, b1)) -> + let uu___4 = attrs_opt_to_string a1 in + let uu___5 = pat_to_string p1 in + let uu___6 = term_to_string b1 in + FStarC_Compiler_Util.format3 "%sand %s=%s" uu___4 uu___5 + uu___6) lbs in + let uu___3 = term_to_string body in + FStarC_Compiler_Util.format4 "%slet rec %s%s in %s" uu___ uu___1 + uu___2 uu___3 + | Let (q, (attrs, (pat, tm))::[], body) -> + let uu___ = attrs_opt_to_string attrs in + let uu___1 = string_of_let_qualifier q in + let uu___2 = pat_to_string pat in + let uu___3 = term_to_string tm in + let uu___4 = term_to_string body in + FStarC_Compiler_Util.format5 "%slet %s %s = %s in %s" uu___ uu___1 + uu___2 uu___3 uu___4 + | Let (uu___, uu___1, uu___2) -> + FStarC_Errors.raise_error hasRange_term x + FStarC_Errors_Codes.Fatal_EmptySurfaceLet () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "Internal error: found an invalid surface Let") + | LetOpen (lid, t) -> + let uu___ = FStarC_Ident.string_of_lid lid in + let uu___1 = term_to_string t in + FStarC_Compiler_Util.format2 "let open %s in %s" uu___ uu___1 + | Seq (t1, t2) -> + let uu___ = term_to_string t1 in + let uu___1 = term_to_string t2 in + FStarC_Compiler_Util.format2 "%s; %s" uu___ uu___1 + | Bind (id, t1, t2) -> + let uu___ = FStarC_Ident.string_of_id id in + let uu___1 = term_to_string t1 in + let uu___2 = term_to_string t2 in + FStarC_Compiler_Util.format3 "%s <- %s; %s" uu___ uu___1 uu___2 + | If (t1, op_opt, ret_opt, t2, t3) -> + let uu___ = + match op_opt with + | FStar_Pervasives_Native.Some op -> FStarC_Ident.string_of_id op + | FStar_Pervasives_Native.None -> "" in + let uu___1 = term_to_string t1 in + let uu___2 = + match ret_opt with + | FStar_Pervasives_Native.None -> "" + | FStar_Pervasives_Native.Some (as_opt, ret, use_eq) -> + let s = if use_eq then "returns$" else "returns" in + let uu___3 = + match as_opt with + | FStar_Pervasives_Native.None -> "" + | FStar_Pervasives_Native.Some as_ident -> + let uu___4 = FStarC_Ident.string_of_id as_ident in + FStarC_Compiler_Util.format1 " as %s " uu___4 in + let uu___4 = term_to_string ret in + FStarC_Compiler_Util.format3 "%s%s %s " uu___3 s uu___4 in + let uu___3 = term_to_string t2 in + let uu___4 = term_to_string t3 in + FStarC_Compiler_Util.format5 "if%s %s %sthen %s else %s" uu___ uu___1 + uu___2 uu___3 uu___4 + | Match (t, op_opt, ret_opt, branches) -> + try_or_match_to_string x t branches op_opt ret_opt + | TryWith (t, branches) -> + try_or_match_to_string x t branches FStar_Pervasives_Native.None + FStar_Pervasives_Native.None + | Ascribed (t1, t2, FStar_Pervasives_Native.None, flag) -> + let s = if flag then "$:" else "<:" in + let uu___ = term_to_string t1 in + let uu___1 = term_to_string t2 in + FStarC_Compiler_Util.format3 "(%s %s %s)" uu___ s uu___1 + | Ascribed (t1, t2, FStar_Pervasives_Native.Some tac, flag) -> + let s = if flag then "$:" else "<:" in + let uu___ = term_to_string t1 in + let uu___1 = term_to_string t2 in + let uu___2 = term_to_string tac in + FStarC_Compiler_Util.format4 "(%s %s %s by %s)" uu___ s uu___1 uu___2 + | Record (FStar_Pervasives_Native.Some e, fields) -> + let uu___ = term_to_string e in + let uu___1 = + to_string_l " " + (fun uu___2 -> + match uu___2 with + | (l, e1) -> + let uu___3 = FStarC_Ident.string_of_lid l in + let uu___4 = term_to_string e1 in + FStarC_Compiler_Util.format2 "%s=%s" uu___3 uu___4) fields in + FStarC_Compiler_Util.format2 "{%s with %s}" uu___ uu___1 + | Record (FStar_Pervasives_Native.None, fields) -> + let uu___ = + to_string_l " " + (fun uu___1 -> + match uu___1 with + | (l, e) -> + let uu___2 = FStarC_Ident.string_of_lid l in + let uu___3 = term_to_string e in + FStarC_Compiler_Util.format2 "%s=%s" uu___2 uu___3) fields in + FStarC_Compiler_Util.format1 "{%s}" uu___ + | Project (e, l) -> + let uu___ = term_to_string e in + let uu___1 = FStarC_Ident.string_of_lid l in + FStarC_Compiler_Util.format2 "%s.%s" uu___ uu___1 + | Product ([], t) -> term_to_string t + | Product (b::hd::tl, t) -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = mk_term (Product ((hd :: tl), t)) x.range x.level in + ([b], uu___3) in + Product uu___2 in + mk_term uu___1 x.range x.level in + term_to_string uu___ + | Product (b::[], t) when x.level = Type_level -> + let uu___ = binder_to_string b in + let uu___1 = term_to_string t in + FStarC_Compiler_Util.format2 "%s -> %s" uu___ uu___1 + | Product (b::[], t) when x.level = Kind -> + let uu___ = binder_to_string b in + let uu___1 = term_to_string t in + FStarC_Compiler_Util.format2 "%s => %s" uu___ uu___1 + | Sum (binders, t) -> + let uu___ = + FStarC_Compiler_List.map + (fun uu___1 -> + match uu___1 with + | FStar_Pervasives.Inl b -> binder_to_string b + | FStar_Pervasives.Inr t1 -> term_to_string t1) + (FStarC_Compiler_List.op_At binders [FStar_Pervasives.Inr t]) in + FStarC_Compiler_String.concat " & " uu___ + | QForall (bs, (uu___, pats), t) -> + let uu___1 = to_string_l " " binder_to_string bs in + let uu___2 = + to_string_l " \\/ " (to_string_l "; " term_to_string) pats in + let uu___3 = term_to_string t in + FStarC_Compiler_Util.format3 "forall %s.{:pattern %s} %s" uu___1 + uu___2 uu___3 + | QExists (bs, (uu___, pats), t) -> + let uu___1 = to_string_l " " binder_to_string bs in + let uu___2 = + to_string_l " \\/ " (to_string_l "; " term_to_string) pats in + let uu___3 = term_to_string t in + FStarC_Compiler_Util.format3 "exists %s.{:pattern %s} %s" uu___1 + uu___2 uu___3 + | QuantOp (i, bs, (uu___, []), t) -> + let uu___1 = FStarC_Ident.string_of_id i in + let uu___2 = to_string_l " " binder_to_string bs in + let uu___3 = term_to_string t in + FStarC_Compiler_Util.format3 "%s %s. %s" uu___1 uu___2 uu___3 + | QuantOp (i, bs, (uu___, pats), t) -> + let uu___1 = FStarC_Ident.string_of_id i in + let uu___2 = to_string_l " " binder_to_string bs in + let uu___3 = + to_string_l " \\/ " (to_string_l "; " term_to_string) pats in + let uu___4 = term_to_string t in + FStarC_Compiler_Util.format4 "%s %s.{:pattern %s} %s" uu___1 uu___2 + uu___3 uu___4 + | Refine (b, t) -> + let uu___ = binder_to_string b in + let uu___1 = term_to_string t in + FStarC_Compiler_Util.format2 "%s:{%s}" uu___ uu___1 + | NamedTyp (x1, t) -> + let uu___ = FStarC_Ident.string_of_id x1 in + let uu___1 = term_to_string t in + FStarC_Compiler_Util.format2 "%s:%s" uu___ uu___1 + | Paren t -> + let uu___ = term_to_string t in + FStarC_Compiler_Util.format1 "(%s)" uu___ + | Product (bs, t) -> + let uu___ = + let uu___1 = FStarC_Compiler_List.map binder_to_string bs in + FStarC_Compiler_String.concat "," uu___1 in + let uu___1 = term_to_string t in + FStarC_Compiler_Util.format2 "Unidentified product: [%s] %s" uu___ + uu___1 + | Discrim lid -> + let uu___ = FStarC_Ident.string_of_lid lid in + FStarC_Compiler_Util.format1 "%s?" uu___ + | Attributes ts -> + let uu___ = + let uu___1 = FStarC_Compiler_List.map term_to_string ts in + FStarC_Compiler_String.concat " " uu___1 in + FStarC_Compiler_Util.format1 "(attributes %s)" uu___ + | Antiquote t -> + let uu___ = term_to_string t in + FStarC_Compiler_Util.format1 "(`#%s)" uu___ + | Quote (t, Static) -> + let uu___ = term_to_string t in + FStarC_Compiler_Util.format1 "(`(%s))" uu___ + | Quote (t, Dynamic) -> + let uu___ = term_to_string t in + FStarC_Compiler_Util.format1 "quote (%s)" uu___ + | VQuote t -> + let uu___ = term_to_string t in + FStarC_Compiler_Util.format1 "`%%%s" uu___ + | CalcProof (rel, init, steps) -> + let uu___ = term_to_string rel in + let uu___1 = term_to_string init in + let uu___2 = + let uu___3 = FStarC_Compiler_List.map calc_step_to_string steps in + FStarC_Compiler_String.concat " " uu___3 in + FStarC_Compiler_Util.format3 "calc (%s) { %s %s }" uu___ uu___1 + uu___2 + | ElimForall (bs, t, vs) -> + let uu___ = binders_to_string " " bs in + let uu___1 = term_to_string t in + let uu___2 = + let uu___3 = FStarC_Compiler_List.map term_to_string vs in + FStarC_Compiler_String.concat " " uu___3 in + FStarC_Compiler_Util.format3 "_elim_ forall %s. %s using %s" uu___ + uu___1 uu___2 + | ElimExists (bs, p, q, b, e) -> + let uu___ = binders_to_string " " bs in + let uu___1 = term_to_string p in + let uu___2 = term_to_string q in + let uu___3 = binder_to_string b in + let uu___4 = term_to_string e in + FStarC_Compiler_Util.format5 + "_elim_ exists %s. %s _to_ %s\n\\with %s. %s" uu___ uu___1 uu___2 + uu___3 uu___4 + | ElimImplies (p, q, e) -> + let uu___ = term_to_string p in + let uu___1 = term_to_string q in + let uu___2 = term_to_string e in + FStarC_Compiler_Util.format3 "_elim_ %s ==> %s with %s" uu___ uu___1 + uu___2 + | ElimOr (p, q, r, x1, e, y, e') -> + let uu___ = + let uu___1 = term_to_string p in + let uu___2 = + let uu___3 = term_to_string q in + let uu___4 = + let uu___5 = term_to_string r in + let uu___6 = + let uu___7 = binder_to_string x1 in + let uu___8 = + let uu___9 = term_to_string e in + let uu___10 = + let uu___11 = binder_to_string y in + let uu___12 = + let uu___13 = term_to_string e' in [uu___13] in + uu___11 :: uu___12 in + uu___9 :: uu___10 in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Compiler_Util.format + "_elim_ %s \\/ %s _to_ %s\n\\with %s. %s\n\\and %s.%s" uu___ + | ElimAnd (p, q, r, x1, y, e) -> + let uu___ = + let uu___1 = term_to_string p in + let uu___2 = + let uu___3 = term_to_string q in + let uu___4 = + let uu___5 = term_to_string r in + let uu___6 = + let uu___7 = binder_to_string x1 in + let uu___8 = + let uu___9 = binder_to_string y in + let uu___10 = let uu___11 = term_to_string e in [uu___11] in + uu___9 :: uu___10 in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Compiler_Util.format + "_elim_ %s /\\ %s _to_ %s\n\\with %s %s. %s" uu___ + | IntroForall (xs, p, e) -> + let uu___ = binders_to_string " " xs in + let uu___1 = term_to_string p in + let uu___2 = term_to_string e in + FStarC_Compiler_Util.format3 "_intro_ forall %s. %s with %s" uu___ + uu___1 uu___2 + | IntroExists (xs, t, vs, e) -> + let uu___ = binders_to_string " " xs in + let uu___1 = term_to_string t in + let uu___2 = + let uu___3 = FStarC_Compiler_List.map term_to_string vs in + FStarC_Compiler_String.concat " " uu___3 in + let uu___3 = term_to_string e in + FStarC_Compiler_Util.format4 "_intro_ exists %s. %s using %s with %s" + uu___ uu___1 uu___2 uu___3 + | IntroImplies (p, q, x1, e) -> + let uu___ = term_to_string p in + let uu___1 = term_to_string q in + let uu___2 = binder_to_string x1 in + let uu___3 = term_to_string p in + FStarC_Compiler_Util.format4 "_intro_ %s ==> %s with %s. %s" uu___ + uu___1 uu___2 uu___3 + | IntroOr (b, p, q, r) -> + let uu___ = term_to_string p in + let uu___1 = term_to_string q in + let uu___2 = term_to_string r in + FStarC_Compiler_Util.format4 "_intro_ %s \\/ %s using %s with %s" + uu___ uu___1 (if b then "Left" else "Right") uu___2 + | IntroAnd (p, q, e1, e2) -> + let uu___ = term_to_string p in + let uu___1 = term_to_string q in + let uu___2 = term_to_string e1 in + let uu___3 = term_to_string e2 in + FStarC_Compiler_Util.format4 "_intro_ %s /\\ %s with %s and %s" uu___ + uu___1 uu___2 uu___3 + | ListLiteral ts -> + let uu___ = to_string_l "; " term_to_string ts in + FStarC_Compiler_Util.format1 "[%s]" uu___ + | SeqLiteral ts -> + let uu___ = to_string_l "; " term_to_string ts in + FStarC_Compiler_Util.format1 "seq![%s]" uu___ +and (binders_to_string : Prims.string -> binder Prims.list -> Prims.string) = + fun sep -> + fun bs -> + let uu___ = FStarC_Compiler_List.map binder_to_string bs in + FStarC_Compiler_String.concat sep uu___ +and (try_or_match_to_string : + term -> + term -> + (pattern * term FStar_Pervasives_Native.option * term) Prims.list -> + FStarC_Ident.ident FStar_Pervasives_Native.option -> + (FStarC_Ident.ident FStar_Pervasives_Native.option * term * + Prims.bool) FStar_Pervasives_Native.option -> Prims.string) + = + fun x -> + fun scrutinee -> + fun branches -> + fun op_opt -> + fun ret_opt -> + let s = + match x.tm with + | Match uu___ -> "match" + | TryWith uu___ -> "try" + | uu___ -> failwith "impossible" in + let uu___ = + match op_opt with + | FStar_Pervasives_Native.Some op -> + FStarC_Ident.string_of_id op + | FStar_Pervasives_Native.None -> "" in + let uu___1 = term_to_string scrutinee in + let uu___2 = + match ret_opt with + | FStar_Pervasives_Native.None -> "" + | FStar_Pervasives_Native.Some (as_opt, ret, use_eq) -> + let s1 = if use_eq then "returns$" else "returns" in + let uu___3 = + match as_opt with + | FStar_Pervasives_Native.None -> "" + | FStar_Pervasives_Native.Some as_ident -> + let uu___4 = FStarC_Ident.string_of_id as_ident in + FStarC_Compiler_Util.format1 "as %s " uu___4 in + let uu___4 = term_to_string ret in + FStarC_Compiler_Util.format3 "%s%s %s " s1 uu___3 uu___4 in + let uu___3 = + to_string_l " | " + (fun uu___4 -> + match uu___4 with + | (p, w, e) -> + let uu___5 = pat_to_string p in + let uu___6 = + match w with + | FStar_Pervasives_Native.None -> "" + | FStar_Pervasives_Native.Some e1 -> + let uu___7 = term_to_string e1 in + FStarC_Compiler_Util.format1 "when %s" uu___7 in + let uu___7 = term_to_string e in + FStarC_Compiler_Util.format3 "%s %s -> %s" uu___5 + uu___6 uu___7) branches in + FStarC_Compiler_Util.format5 "%s%s %s %swith %s" s uu___ uu___1 + uu___2 uu___3 +and (calc_step_to_string : calc_step -> Prims.string) = + fun uu___ -> + match uu___ with + | CalcStep (rel, just, next) -> + let uu___1 = term_to_string rel in + let uu___2 = term_to_string just in + let uu___3 = term_to_string next in + FStarC_Compiler_Util.format3 "%s{ %s } %s" uu___1 uu___2 uu___3 +and (binder_to_string : binder -> Prims.string) = + fun x -> + let pr x1 = + let s = + match x1.b with + | Variable i -> FStarC_Ident.string_of_id i + | TVariable i -> + let uu___ = FStarC_Ident.string_of_id i in + FStarC_Compiler_Util.format1 "%s:_" uu___ + | TAnnotated (i, t) -> + let uu___ = FStarC_Ident.string_of_id i in + let uu___1 = term_to_string t in + FStarC_Compiler_Util.format2 "%s:%s" uu___ uu___1 + | Annotated (i, t) -> + let uu___ = FStarC_Ident.string_of_id i in + let uu___1 = term_to_string t in + FStarC_Compiler_Util.format2 "%s:%s" uu___ uu___1 + | NoName t -> term_to_string t in + let uu___ = aqual_to_string x1.aqual in + let uu___1 = attr_list_to_string x1.battributes in + FStarC_Compiler_Util.format3 "%s%s%s" uu___ uu___1 s in + match x.aqual with + | FStar_Pervasives_Native.Some (TypeClassArg) -> + let uu___ = let uu___1 = pr x in Prims.strcat uu___1 " |}" in + Prims.strcat "{| " uu___ + | uu___ -> pr x +and (aqual_to_string : + arg_qualifier FStar_Pervasives_Native.option -> Prims.string) = + fun uu___ -> + match uu___ with + | FStar_Pervasives_Native.Some (Equality) -> "$" + | FStar_Pervasives_Native.Some (Implicit) -> "#" + | FStar_Pervasives_Native.None -> "" + | FStar_Pervasives_Native.Some (Meta uu___1) -> + failwith "aqual_to_strings: meta arg qualifier?" + | FStar_Pervasives_Native.Some (TypeClassArg) -> + failwith "aqual_to_strings: meta arg qualifier?" +and (attr_list_to_string : term Prims.list -> Prims.string) = + fun uu___ -> + match uu___ with + | [] -> "" + | l -> attrs_opt_to_string (FStar_Pervasives_Native.Some l) +and (pat_to_string : pattern -> Prims.string) = + fun x -> + match x.pat with + | PatWild (FStar_Pervasives_Native.None, attrs) -> + let uu___ = attr_list_to_string attrs in Prims.strcat uu___ "_" + | PatWild (uu___, attrs) -> + let uu___1 = + let uu___2 = attr_list_to_string attrs in Prims.strcat uu___2 "_" in + Prims.strcat "#" uu___1 + | PatConst c -> FStarC_Parser_Const.const_to_string c + | PatVQuote t -> + let uu___ = term_to_string t in + FStarC_Compiler_Util.format1 "`%%%s" uu___ + | PatApp (p, ps) -> + let uu___ = pat_to_string p in + let uu___1 = to_string_l " " pat_to_string ps in + FStarC_Compiler_Util.format2 "(%s %s)" uu___ uu___1 + | PatTvar (i, aq, attrs) -> + let uu___ = aqual_to_string aq in + let uu___1 = attr_list_to_string attrs in + let uu___2 = FStarC_Ident.string_of_id i in + FStarC_Compiler_Util.format3 "%s%s%s" uu___ uu___1 uu___2 + | PatVar (i, aq, attrs) -> + let uu___ = aqual_to_string aq in + let uu___1 = attr_list_to_string attrs in + let uu___2 = FStarC_Ident.string_of_id i in + FStarC_Compiler_Util.format3 "%s%s%s" uu___ uu___1 uu___2 + | PatName l -> FStarC_Ident.string_of_lid l + | PatList l -> + let uu___ = to_string_l "; " pat_to_string l in + FStarC_Compiler_Util.format1 "[%s]" uu___ + | PatTuple (l, false) -> + let uu___ = to_string_l ", " pat_to_string l in + FStarC_Compiler_Util.format1 "(%s)" uu___ + | PatTuple (l, true) -> + let uu___ = to_string_l ", " pat_to_string l in + FStarC_Compiler_Util.format1 "(|%s|)" uu___ + | PatRecord l -> + let uu___ = + to_string_l "; " + (fun uu___1 -> + match uu___1 with + | (f, e) -> + let uu___2 = FStarC_Ident.string_of_lid f in + let uu___3 = pat_to_string e in + FStarC_Compiler_Util.format2 "%s=%s" uu___2 uu___3) l in + FStarC_Compiler_Util.format1 "{%s}" uu___ + | PatOr l -> to_string_l "|\n " pat_to_string l + | PatOp op -> + let uu___ = FStarC_Ident.string_of_id op in + FStarC_Compiler_Util.format1 "(%s)" uu___ + | PatAscribed (p, (t, FStar_Pervasives_Native.None)) -> + let uu___ = pat_to_string p in + let uu___1 = term_to_string t in + FStarC_Compiler_Util.format2 "(%s:%s)" uu___ uu___1 + | PatAscribed (p, (t, FStar_Pervasives_Native.Some tac)) -> + let uu___ = pat_to_string p in + let uu___1 = term_to_string t in + let uu___2 = term_to_string tac in + FStarC_Compiler_Util.format3 "(%s:%s by %s)" uu___ uu___1 uu___2 +and (attrs_opt_to_string : + term Prims.list FStar_Pervasives_Native.option -> Prims.string) = + fun uu___ -> + match uu___ with + | FStar_Pervasives_Native.None -> "" + | FStar_Pervasives_Native.Some attrs -> + let uu___1 = + let uu___2 = FStarC_Compiler_List.map term_to_string attrs in + FStarC_Compiler_String.concat "; " uu___2 in + FStarC_Compiler_Util.format1 "[@ %s]" uu___1 +let rec (head_id_of_pat : pattern -> FStarC_Ident.lident Prims.list) = + fun p -> + match p.pat with + | PatName l -> [l] + | PatVar (i, uu___, uu___1) -> + let uu___2 = FStarC_Ident.lid_of_ids [i] in [uu___2] + | PatApp (p1, uu___) -> head_id_of_pat p1 + | PatAscribed (p1, uu___) -> head_id_of_pat p1 + | uu___ -> [] +let (lids_of_let : + (pattern * term) Prims.list -> FStarC_Ident.lident Prims.list) = + fun defs -> + FStarC_Compiler_List.collect + (fun uu___ -> match uu___ with | (p, uu___1) -> head_id_of_pat p) defs +let (id_of_tycon : tycon -> Prims.string) = + fun uu___ -> + match uu___ with + | TyconAbstract (i, uu___1, uu___2) -> FStarC_Ident.string_of_id i + | TyconAbbrev (i, uu___1, uu___2, uu___3) -> FStarC_Ident.string_of_id i + | TyconRecord (i, uu___1, uu___2, uu___3, uu___4) -> + FStarC_Ident.string_of_id i + | TyconVariant (i, uu___1, uu___2, uu___3) -> FStarC_Ident.string_of_id i +let (string_of_pragma : pragma -> Prims.string) = + fun uu___ -> + match uu___ with + | ShowOptions -> "show-options" + | SetOptions s -> FStarC_Compiler_Util.format1 "set-options \"%s\"" s + | ResetOptions s -> + FStarC_Compiler_Util.format1 "reset-options \"%s\"" + (FStarC_Compiler_Util.dflt "" s) + | PushOptions s -> + FStarC_Compiler_Util.format1 "push-options \"%s\"" + (FStarC_Compiler_Util.dflt "" s) + | PopOptions -> "pop-options" + | RestartSolver -> "restart-solver" + | PrintEffectsGraph -> "print-effects-graph" +let (restriction_to_string : + FStarC_Syntax_Syntax.restriction -> Prims.string) = + fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.Unrestricted -> "" + | FStarC_Syntax_Syntax.AllowList allow_list -> + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Compiler_List.map + (fun uu___4 -> + match uu___4 with + | (id, renamed) -> + let uu___5 = FStarC_Ident.string_of_id id in + let uu___6 = + let uu___7 = + FStarC_Compiler_Util.map_opt renamed + (fun renamed1 -> + let uu___8 = + FStarC_Ident.string_of_id renamed1 in + Prims.strcat " as " uu___8) in + FStarC_Compiler_Util.dflt "" uu___7 in + Prims.strcat uu___5 uu___6) allow_list in + FStarC_Compiler_String.concat ", " uu___3 in + Prims.strcat uu___2 "}" in + Prims.strcat " {" uu___1 +let rec (decl_to_string : decl -> Prims.string) = + fun d -> + match d.d with + | TopLevelModule l -> + let uu___ = FStarC_Ident.string_of_lid l in + Prims.strcat "module " uu___ + | Open (l, r) -> + let uu___ = + let uu___1 = FStarC_Ident.string_of_lid l in + let uu___2 = restriction_to_string r in Prims.strcat uu___1 uu___2 in + Prims.strcat "open " uu___ + | Friend l -> + let uu___ = FStarC_Ident.string_of_lid l in + Prims.strcat "friend " uu___ + | Include (l, r) -> + let uu___ = + let uu___1 = FStarC_Ident.string_of_lid l in + let uu___2 = restriction_to_string r in Prims.strcat uu___1 uu___2 in + Prims.strcat "include " uu___ + | ModuleAbbrev (i, l) -> + let uu___ = FStarC_Ident.string_of_id i in + let uu___1 = FStarC_Ident.string_of_lid l in + FStarC_Compiler_Util.format2 "module %s = %s" uu___ uu___1 + | TopLevelLet (uu___, pats) -> + let uu___1 = + let uu___2 = + let uu___3 = lids_of_let pats in + FStarC_Compiler_List.map (fun l -> FStarC_Ident.string_of_lid l) + uu___3 in + FStarC_Compiler_String.concat ", " uu___2 in + Prims.strcat "let " uu___1 + | Assume (i, uu___) -> + let uu___1 = FStarC_Ident.string_of_id i in + Prims.strcat "assume " uu___1 + | Tycon (uu___, uu___1, tys) -> + let uu___2 = + let uu___3 = FStarC_Compiler_List.map id_of_tycon tys in + FStarC_Compiler_String.concat ", " uu___3 in + Prims.strcat "type " uu___2 + | Val (i, uu___) -> + let uu___1 = FStarC_Ident.string_of_id i in + Prims.strcat "val " uu___1 + | Exception (i, uu___) -> + let uu___1 = FStarC_Ident.string_of_id i in + Prims.strcat "exception " uu___1 + | NewEffect (DefineEffect (i, uu___, uu___1, uu___2)) -> + let uu___3 = FStarC_Ident.string_of_id i in + Prims.strcat "new_effect " uu___3 + | NewEffect (RedefineEffect (i, uu___, uu___1)) -> + let uu___2 = FStarC_Ident.string_of_id i in + Prims.strcat "new_effect " uu___2 + | LayeredEffect (DefineEffect (i, uu___, uu___1, uu___2)) -> + let uu___3 = FStarC_Ident.string_of_id i in + Prims.strcat "layered_effect " uu___3 + | LayeredEffect (RedefineEffect (i, uu___, uu___1)) -> + let uu___2 = FStarC_Ident.string_of_id i in + Prims.strcat "layered_effect " uu___2 + | Polymonadic_bind (l1, l2, l3, uu___) -> + let uu___1 = FStarC_Ident.string_of_lid l1 in + let uu___2 = FStarC_Ident.string_of_lid l2 in + let uu___3 = FStarC_Ident.string_of_lid l3 in + FStarC_Compiler_Util.format3 "polymonadic_bind (%s, %s) |> %s" uu___1 + uu___2 uu___3 + | Polymonadic_subcomp (l1, l2, uu___) -> + let uu___1 = FStarC_Ident.string_of_lid l1 in + let uu___2 = FStarC_Ident.string_of_lid l2 in + FStarC_Compiler_Util.format2 "polymonadic_subcomp %s <: %s" uu___1 + uu___2 + | Splice (is_typed, ids, t) -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Compiler_List.map + (fun i -> FStarC_Ident.string_of_id i) ids in + FStarC_Compiler_String.concat ";" uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = term_to_string t in Prims.strcat uu___6 ")" in + Prims.strcat "] (" uu___5 in + Prims.strcat uu___3 uu___4 in + Prims.strcat "[" uu___2 in + Prims.strcat (if is_typed then "_t" else "") uu___1 in + Prims.strcat "splice" uu___ + | SubEffect uu___ -> "sub_effect" + | Pragma p -> + let uu___ = string_of_pragma p in Prims.strcat "pragma #" uu___ + | DeclSyntaxExtension (id, content, uu___, uu___1) -> + Prims.strcat "```" + (Prims.strcat id (Prims.strcat "\n" (Prims.strcat content "\n```"))) + | DeclToBeDesugared tbs -> + let uu___ = + let uu___1 = tbs.to_string tbs.blob in Prims.strcat uu___1 ")" in + Prims.strcat "(to_be_desugared: " uu___ + | UseLangDecls str -> FStarC_Compiler_Util.format1 "#lang-%s" str + | Unparseable -> "unparseable" +let (modul_to_string : modul -> Prims.string) = + fun m -> + match m with + | Module (uu___, decls) -> + let uu___1 = FStarC_Compiler_List.map decl_to_string decls in + FStarC_Compiler_String.concat "\n" uu___1 + | Interface (uu___, decls, uu___1) -> + let uu___2 = FStarC_Compiler_List.map decl_to_string decls in + FStarC_Compiler_String.concat "\n" uu___2 +let (decl_is_val : FStarC_Ident.ident -> decl -> Prims.bool) = + fun id -> + fun decl1 -> + match decl1.d with + | Val (id', uu___) -> FStarC_Ident.ident_equals id id' + | uu___ -> false +let (thunk : term -> term) = + fun ens -> + let wildpat = + mk_pattern (PatWild (FStar_Pervasives_Native.None, [])) ens.range in + mk_term (Abs ([wildpat], ens)) ens.range Expr +let (ident_of_binder : + FStarC_Compiler_Range_Type.range -> binder -> FStarC_Ident.ident) = + fun r -> + fun b -> + match b.b with + | Variable i -> i + | TVariable i -> i + | Annotated (i, uu___) -> i + | TAnnotated (i, uu___) -> i + | NoName uu___ -> + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_MissingQuantifierBinder () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "Wildcard binders in quantifiers are not allowed") +let (idents_of_binders : + binder Prims.list -> + FStarC_Compiler_Range_Type.range -> FStarC_Ident.ident Prims.list) + = fun bs -> fun r -> FStarC_Compiler_List.map (ident_of_binder r) bs +let (showable_decl : decl FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = decl_to_string } +let (showable_term : term FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = term_to_string } +let (add_decorations : decl -> decoration Prims.list -> decl) = + fun d -> + fun decorations -> + let decorations1 = + let uu___ = + FStarC_Compiler_List.partition uu___is_DeclAttributes decorations in + match uu___ with + | (attrs, quals) -> + let attrs1 = + match (attrs, (d.attrs)) with + | (attrs2, []) -> attrs2 + | ((DeclAttributes a)::[], attrs2) -> + [DeclAttributes (FStarC_Compiler_List.op_At a attrs2)] + | ([], attrs2) -> [DeclAttributes attrs2] + | uu___1 -> + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Compiler_List.map + (fun uu___5 -> + match uu___5 with + | DeclAttributes a -> + FStarC_Class_Show.show + (FStarC_Class_Show.show_list showable_term) + a + | uu___6 -> "") attrs in + FStarC_Compiler_String.concat ", " uu___4 in + let uu___4 = + let uu___5 = + FStarC_Compiler_List.map + (FStarC_Class_Show.show showable_term) d.attrs in + FStarC_Compiler_String.concat ", " uu___5 in + FStarC_Compiler_Util.format2 + "At most one attribute set is allowed on declarations\n got %s;\n and %s" + uu___3 uu___4 in + FStarC_Errors.raise_error hasRange_decl d + FStarC_Errors_Codes.Fatal_MoreThanOneDeclaration () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2) in + let uu___1 = + FStarC_Compiler_List.map (fun uu___2 -> Qualifier uu___2) + d.quals in + FStarC_Compiler_List.op_At uu___1 + (FStarC_Compiler_List.op_At quals attrs1) in + let attributes_1 = + let uu___ = + FStarC_Compiler_List.choose + (fun uu___1 -> + match uu___1 with + | DeclAttributes a -> FStar_Pervasives_Native.Some a + | uu___2 -> FStar_Pervasives_Native.None) decorations1 in + at_most_one "attribute set" d.drange uu___ in + let attributes_2 = FStarC_Compiler_Util.dflt [] attributes_1 in + let qualifiers1 = + FStarC_Compiler_List.choose + (fun uu___ -> + match uu___ with + | Qualifier q -> FStar_Pervasives_Native.Some q + | uu___1 -> FStar_Pervasives_Native.None) decorations1 in + { + d = (d.d); + drange = (d.drange); + quals = qualifiers1; + attrs = attributes_2; + interleaved = (d.interleaved) + } +let (mk_decl : + decl' -> FStarC_Compiler_Range_Type.range -> decoration Prims.list -> decl) + = + fun d -> + fun r -> + fun decorations -> + let d1 = + { d; drange = r; quals = []; attrs = []; interleaved = false } in + add_decorations d1 decorations \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Parser_AST_Util.ml b/ocaml/fstar-lib/generated/FStarC_Parser_AST_Util.ml new file mode 100644 index 00000000000..4ece69e79bd --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Parser_AST_Util.ml @@ -0,0 +1,1253 @@ +open Prims +let (eq_ident : FStarC_Ident.ident -> FStarC_Ident.ident -> Prims.bool) = + fun i1 -> fun i2 -> FStarC_Ident.ident_equals i1 i2 +let eq_list : + 'a . + ('a -> 'a -> Prims.bool) -> 'a Prims.list -> 'a Prims.list -> Prims.bool + = + fun f -> + fun t1 -> + fun t2 -> + ((FStarC_Compiler_List.length t1) = (FStarC_Compiler_List.length t2)) + && (FStarC_Compiler_List.forall2 f t1 t2) +let eq_option : + 'a . + ('a -> 'a -> Prims.bool) -> + 'a FStar_Pervasives_Native.option -> + 'a FStar_Pervasives_Native.option -> Prims.bool + = + fun f -> + fun t1 -> + fun t2 -> + match (t1, t2) with + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> + true + | (FStar_Pervasives_Native.Some t11, FStar_Pervasives_Native.Some + t21) -> f t11 t21 + | uu___ -> false +let (eq_sconst : FStarC_Const.sconst -> FStarC_Const.sconst -> Prims.bool) = + fun c1 -> + fun c2 -> + match (c1, c2) with + | (FStarC_Const.Const_effect, FStarC_Const.Const_effect) -> true + | (FStarC_Const.Const_unit, FStarC_Const.Const_unit) -> true + | (FStarC_Const.Const_bool b1, FStarC_Const.Const_bool b2) -> b1 = b2 + | (FStarC_Const.Const_int (s1, sw1), FStarC_Const.Const_int (s2, sw2)) + -> (s1 = s2) && (sw1 = sw2) + | (FStarC_Const.Const_char c11, FStarC_Const.Const_char c21) -> + c11 = c21 + | (FStarC_Const.Const_string (s1, uu___), FStarC_Const.Const_string + (s2, uu___1)) -> s1 = s2 + | (FStarC_Const.Const_real s1, FStarC_Const.Const_real s2) -> s1 = s2 + | (FStarC_Const.Const_range r1, FStarC_Const.Const_range r2) -> r1 = r2 + | (FStarC_Const.Const_reify uu___, FStarC_Const.Const_reify uu___1) -> + true + | (FStarC_Const.Const_reflect l1, FStarC_Const.Const_reflect l2) -> + FStarC_Ident.lid_equals l1 l2 + | uu___ -> false +let rec (eq_term : + FStarC_Parser_AST.term -> FStarC_Parser_AST.term -> Prims.bool) = + fun t1 -> + fun t2 -> eq_term' t1.FStarC_Parser_AST.tm t2.FStarC_Parser_AST.tm +and (eq_terms : + FStarC_Parser_AST.term Prims.list -> + FStarC_Parser_AST.term Prims.list -> Prims.bool) + = fun t1 -> fun t2 -> eq_list eq_term t1 t2 +and (eq_arg : + (FStarC_Parser_AST.term * FStarC_Parser_AST.imp) -> + (FStarC_Parser_AST.term * FStarC_Parser_AST.imp) -> Prims.bool) + = + fun t1 -> + fun t2 -> + let uu___ = t1 in + match uu___ with + | (t11, a1) -> + let uu___1 = t2 in + (match uu___1 with + | (t21, a2) -> (eq_term t11 t21) && (eq_imp a1 a2)) +and (eq_imp : FStarC_Parser_AST.imp -> FStarC_Parser_AST.imp -> Prims.bool) = + fun i1 -> + fun i2 -> + match (i1, i2) with + | (FStarC_Parser_AST.FsTypApp, FStarC_Parser_AST.FsTypApp) -> true + | (FStarC_Parser_AST.Hash, FStarC_Parser_AST.Hash) -> true + | (FStarC_Parser_AST.UnivApp, FStarC_Parser_AST.UnivApp) -> true + | (FStarC_Parser_AST.Infix, FStarC_Parser_AST.Infix) -> true + | (FStarC_Parser_AST.Nothing, FStarC_Parser_AST.Nothing) -> true + | (FStarC_Parser_AST.HashBrace t1, FStarC_Parser_AST.HashBrace t2) -> + eq_term t1 t2 + | uu___ -> false +and (eq_args : + (FStarC_Parser_AST.term * FStarC_Parser_AST.imp) Prims.list -> + (FStarC_Parser_AST.term * FStarC_Parser_AST.imp) Prims.list -> Prims.bool) + = fun t1 -> fun t2 -> eq_list eq_arg t1 t2 +and (eq_arg_qualifier : + FStarC_Parser_AST.arg_qualifier -> + FStarC_Parser_AST.arg_qualifier -> Prims.bool) + = + fun arg_qualifier1 -> + fun arg_qualifier2 -> + match (arg_qualifier1, arg_qualifier2) with + | (FStarC_Parser_AST.Implicit, FStarC_Parser_AST.Implicit) -> true + | (FStarC_Parser_AST.Equality, FStarC_Parser_AST.Equality) -> true + | (FStarC_Parser_AST.Meta t1, FStarC_Parser_AST.Meta t2) -> + eq_term t1 t2 + | (FStarC_Parser_AST.TypeClassArg, FStarC_Parser_AST.TypeClassArg) -> + true + | uu___ -> false +and (eq_pattern : + FStarC_Parser_AST.pattern -> FStarC_Parser_AST.pattern -> Prims.bool) = + fun p1 -> + fun p2 -> eq_pattern' p1.FStarC_Parser_AST.pat p2.FStarC_Parser_AST.pat +and (eq_aqual : + FStarC_Parser_AST.arg_qualifier FStar_Pervasives_Native.option -> + FStarC_Parser_AST.arg_qualifier FStar_Pervasives_Native.option -> + Prims.bool) + = fun a1 -> fun a2 -> eq_option eq_arg_qualifier a1 a2 +and (eq_pattern' : + FStarC_Parser_AST.pattern' -> FStarC_Parser_AST.pattern' -> Prims.bool) = + fun p1 -> + fun p2 -> + match (p1, p2) with + | (FStarC_Parser_AST.PatWild (q1, a1), FStarC_Parser_AST.PatWild + (q2, a2)) -> (eq_aqual q1 q2) && (eq_terms a1 a2) + | (FStarC_Parser_AST.PatConst s1, FStarC_Parser_AST.PatConst s2) -> + eq_sconst s1 s2 + | (FStarC_Parser_AST.PatApp (p11, ps1), FStarC_Parser_AST.PatApp + (p21, ps2)) -> (eq_pattern p11 p21) && (eq_list eq_pattern ps1 ps2) + | (FStarC_Parser_AST.PatTvar (i1, aq1, as1), FStarC_Parser_AST.PatTvar + (i2, aq2, as2)) -> + ((FStarC_Ident.ident_equals i1 i2) && (eq_aqual aq1 aq2)) && + (eq_terms as1 as2) + | (FStarC_Parser_AST.PatVar (i1, aq1, as1), FStarC_Parser_AST.PatVar + (i2, aq2, as2)) -> + ((FStarC_Ident.ident_equals i1 i2) && (eq_aqual aq1 aq2)) && + (eq_terms as1 as2) + | (FStarC_Parser_AST.PatName l1, FStarC_Parser_AST.PatName l2) -> + FStarC_Ident.lid_equals l1 l2 + | (FStarC_Parser_AST.PatOr ps1, FStarC_Parser_AST.PatOr ps2) -> + eq_list eq_pattern ps1 ps2 + | (FStarC_Parser_AST.PatList ps1, FStarC_Parser_AST.PatList ps2) -> + eq_list eq_pattern ps1 ps2 + | (FStarC_Parser_AST.PatTuple (ps1, b1), FStarC_Parser_AST.PatTuple + (ps2, b2)) -> (eq_list eq_pattern ps1 ps2) && (b1 = b2) + | (FStarC_Parser_AST.PatRecord ps1, FStarC_Parser_AST.PatRecord ps2) -> + eq_list + (fun uu___ -> + fun uu___1 -> + match (uu___, uu___1) with + | ((l1, p11), (l2, p21)) -> + (FStarC_Ident.lid_equals l1 l2) && (eq_pattern p11 p21)) + ps1 ps2 + | (FStarC_Parser_AST.PatAscribed (p11, (t1, topt1)), + FStarC_Parser_AST.PatAscribed (p21, (t2, topt2))) -> + ((eq_pattern p11 p21) && (eq_term t1 t2)) && + (eq_option eq_term topt1 topt2) + | (FStarC_Parser_AST.PatOp i1, FStarC_Parser_AST.PatOp i2) -> + eq_ident i1 i2 + | (FStarC_Parser_AST.PatVQuote t1, FStarC_Parser_AST.PatVQuote t2) -> + eq_term t1 t2 + | uu___ -> false +and (eq_term' : + FStarC_Parser_AST.term' -> FStarC_Parser_AST.term' -> Prims.bool) = + fun t1 -> + fun t2 -> + match (t1, t2) with + | (FStarC_Parser_AST.Wild, FStarC_Parser_AST.Wild) -> true + | (FStarC_Parser_AST.Const s1, FStarC_Parser_AST.Const s2) -> + FStarC_Const.eq_const s1 s2 + | (FStarC_Parser_AST.Op (i1, ts1), FStarC_Parser_AST.Op (i2, ts2)) -> + (eq_ident i1 i2) && (eq_terms ts1 ts2) + | (FStarC_Parser_AST.Tvar i1, FStarC_Parser_AST.Tvar i2) -> + eq_ident i1 i2 + | (FStarC_Parser_AST.Uvar i1, FStarC_Parser_AST.Uvar i2) -> + eq_ident i1 i2 + | (FStarC_Parser_AST.Var l1, FStarC_Parser_AST.Var l2) -> + FStarC_Ident.lid_equals l1 l2 + | (FStarC_Parser_AST.Name l1, FStarC_Parser_AST.Name l2) -> + FStarC_Ident.lid_equals l1 l2 + | (FStarC_Parser_AST.Projector (l1, i1), FStarC_Parser_AST.Projector + (l2, i2)) -> + (FStarC_Ident.lid_equals l1 l2) && + (FStarC_Ident.ident_equals i1 i2) + | (FStarC_Parser_AST.Construct (l1, args1), FStarC_Parser_AST.Construct + (l2, args2)) -> + (FStarC_Ident.lid_equals l1 l2) && (eq_args args1 args2) + | (FStarC_Parser_AST.Function (brs1, _r1), FStarC_Parser_AST.Function + (brs2, _r2)) -> eq_list eq_branch brs1 brs2 + | (FStarC_Parser_AST.Abs (ps1, t11), FStarC_Parser_AST.Abs (ps2, t21)) + -> (eq_list eq_pattern ps1 ps2) && (eq_term t11 t21) + | (FStarC_Parser_AST.App (h1, t11, i1), FStarC_Parser_AST.App + (h2, t21, i2)) -> + ((eq_term h1 h2) && (eq_term t11 t21)) && (eq_imp i1 i2) + | (FStarC_Parser_AST.Let (lq1, defs1, t11), FStarC_Parser_AST.Let + (lq2, defs2, t21)) -> + ((lq1 = lq2) && + (eq_list + (fun uu___ -> + fun uu___1 -> + match (uu___, uu___1) with + | ((o1, (p1, t12)), (o2, (p2, t22))) -> + ((eq_option eq_terms o1 o2) && (eq_pattern p1 p2)) + && (eq_term t12 t22)) defs1 defs2)) + && (eq_term t11 t21) + | (FStarC_Parser_AST.LetOperator (defs1, t11), + FStarC_Parser_AST.LetOperator (defs2, t21)) -> + (eq_list + (fun uu___ -> + fun uu___1 -> + match (uu___, uu___1) with + | ((i1, ps1, t12), (i2, ps2, t22)) -> + ((eq_ident i1 i2) && (eq_pattern ps1 ps2)) && + (eq_term t12 t22)) defs1 defs2) + && (eq_term t11 t21) + | (FStarC_Parser_AST.LetOpen (l1, t11), FStarC_Parser_AST.LetOpen + (l2, t21)) -> (FStarC_Ident.lid_equals l1 l2) && (eq_term t11 t21) + | (FStarC_Parser_AST.LetOpenRecord (t11, t21, t3), + FStarC_Parser_AST.LetOpenRecord (t4, t5, t6)) -> + ((eq_term t11 t4) && (eq_term t21 t5)) && (eq_term t3 t6) + | (FStarC_Parser_AST.Seq (t11, t21), FStarC_Parser_AST.Seq (t3, t4)) -> + (eq_term t11 t3) && (eq_term t21 t4) + | (FStarC_Parser_AST.Bind (i1, t11, t21), FStarC_Parser_AST.Bind + (i2, t3, t4)) -> + ((FStarC_Ident.ident_equals i1 i2) && (eq_term t11 t3)) && + (eq_term t21 t4) + | (FStarC_Parser_AST.If (t11, i1, mra1, t21, t3), FStarC_Parser_AST.If + (t4, i2, mra2, t5, t6)) -> + ((((eq_term t11 t4) && (eq_option eq_ident i1 i2)) && + (eq_option eq_match_returns_annotation mra1 mra2)) + && (eq_term t21 t5)) + && (eq_term t3 t6) + | (FStarC_Parser_AST.Match (t11, i1, mra1, bs1), + FStarC_Parser_AST.Match (t21, i2, mra2, bs2)) -> + (((eq_term t11 t21) && (eq_option eq_ident i1 i2)) && + (eq_option eq_match_returns_annotation mra1 mra2)) + && (eq_list eq_branch bs1 bs2) + | (FStarC_Parser_AST.TryWith (t11, bs1), FStarC_Parser_AST.TryWith + (t21, bs2)) -> (eq_term t11 t21) && (eq_list eq_branch bs1 bs2) + | (FStarC_Parser_AST.Ascribed (t11, t21, topt1, b1), + FStarC_Parser_AST.Ascribed (t3, t4, topt2, b2)) -> + (((eq_term t11 t3) && (eq_term t21 t4)) && + (eq_option eq_term topt1 topt2)) + && (b1 = b2) + | (FStarC_Parser_AST.Record (topt1, fs1), FStarC_Parser_AST.Record + (topt2, fs2)) -> + (eq_option eq_term topt1 topt2) && + (eq_list + (fun uu___ -> + fun uu___1 -> + match (uu___, uu___1) with + | ((l1, t11), (l2, t21)) -> + (FStarC_Ident.lid_equals l1 l2) && (eq_term t11 t21)) + fs1 fs2) + | (FStarC_Parser_AST.Project (t11, l1), FStarC_Parser_AST.Project + (t21, l2)) -> (eq_term t11 t21) && (FStarC_Ident.lid_equals l1 l2) + | (FStarC_Parser_AST.Product (bs1, t11), FStarC_Parser_AST.Product + (bs2, t21)) -> (eq_list eq_binder bs1 bs2) && (eq_term t11 t21) + | (FStarC_Parser_AST.Sum (bs1, t11), FStarC_Parser_AST.Sum (bs2, t21)) + -> + (eq_list + (fun b1 -> + fun b2 -> + match (b1, b2) with + | (FStar_Pervasives.Inl b11, FStar_Pervasives.Inl b21) -> + eq_binder b11 b21 + | (FStar_Pervasives.Inr t12, FStar_Pervasives.Inr t22) -> + eq_term t12 t22 + | (FStar_Pervasives.Inl uu___, FStar_Pervasives.Inr uu___1) + -> false + | (FStar_Pervasives.Inr uu___, FStar_Pervasives.Inl uu___1) + -> false) bs1 bs2) + && (eq_term t11 t21) + | (FStarC_Parser_AST.QForall (bs1, ps1, t11), FStarC_Parser_AST.QForall + (bs2, ps2, t21)) -> + let eq_ps uu___ uu___1 = + match (uu___, uu___1) with + | ((is1, ts1), (is2, ts2)) -> + (eq_list eq_ident is1 is2) && + (eq_list (eq_list eq_term) ts1 ts2) in + ((eq_list eq_binder bs1 bs2) && (eq_ps ps1 ps2)) && + (eq_term t11 t21) + | (FStarC_Parser_AST.QExists (bs1, ps1, t11), FStarC_Parser_AST.QExists + (bs2, ps2, t21)) -> + let eq_ps uu___ uu___1 = + match (uu___, uu___1) with + | ((is1, ts1), (is2, ts2)) -> + (eq_list eq_ident is1 is2) && + (eq_list (eq_list eq_term) ts1 ts2) in + ((eq_list eq_binder bs1 bs2) && (eq_ps ps1 ps2)) && + (eq_term t11 t21) + | (FStarC_Parser_AST.QuantOp (i1, bs1, ps1, t11), + FStarC_Parser_AST.QuantOp (i2, bs2, ps2, t21)) -> + let eq_ps uu___ uu___1 = + match (uu___, uu___1) with + | ((is1, ts1), (is2, ts2)) -> + (eq_list eq_ident is1 is2) && + (eq_list (eq_list eq_term) ts1 ts2) in + (((FStarC_Ident.ident_equals i1 i2) && (eq_list eq_binder bs1 bs2)) + && (eq_ps ps1 ps2)) + && (eq_term t11 t21) + | (FStarC_Parser_AST.Refine (t11, t21), FStarC_Parser_AST.Refine + (t3, t4)) -> (eq_binder t11 t3) && (eq_term t21 t4) + | (FStarC_Parser_AST.NamedTyp (i1, t11), FStarC_Parser_AST.NamedTyp + (i2, t21)) -> (eq_ident i1 i2) && (eq_term t11 t21) + | (FStarC_Parser_AST.Paren t11, FStarC_Parser_AST.Paren t21) -> + eq_term t11 t21 + | (FStarC_Parser_AST.Requires (t11, s1), FStarC_Parser_AST.Requires + (t21, s2)) -> (eq_term t11 t21) && (eq_option (=) s1 s2) + | (FStarC_Parser_AST.Ensures (t11, s1), FStarC_Parser_AST.Ensures + (t21, s2)) -> (eq_term t11 t21) && (eq_option (=) s1 s2) + | (FStarC_Parser_AST.LexList ts1, FStarC_Parser_AST.LexList ts2) -> + eq_list eq_term ts1 ts2 + | (FStarC_Parser_AST.WFOrder (t11, t21), FStarC_Parser_AST.WFOrder + (t3, t4)) -> (eq_term t11 t3) && (eq_term t21 t4) + | (FStarC_Parser_AST.Decreases (t11, s1), FStarC_Parser_AST.Decreases + (t21, s2)) -> (eq_term t11 t21) && (eq_option (=) s1 s2) + | (FStarC_Parser_AST.Labeled (t11, s1, b1), FStarC_Parser_AST.Labeled + (t21, s2, b2)) -> ((eq_term t11 t21) && (s1 = s2)) && (b1 = b2) + | (FStarC_Parser_AST.Discrim l1, FStarC_Parser_AST.Discrim l2) -> + FStarC_Ident.lid_equals l1 l2 + | (FStarC_Parser_AST.Attributes ts1, FStarC_Parser_AST.Attributes ts2) + -> eq_list eq_term ts1 ts2 + | (FStarC_Parser_AST.Antiquote t11, FStarC_Parser_AST.Antiquote t21) -> + eq_term t11 t21 + | (FStarC_Parser_AST.Quote (t11, k1), FStarC_Parser_AST.Quote + (t21, k2)) -> (eq_term t11 t21) && (k1 = k2) + | (FStarC_Parser_AST.VQuote t11, FStarC_Parser_AST.VQuote t21) -> + eq_term t11 t21 + | (FStarC_Parser_AST.CalcProof (t11, t21, cs1), + FStarC_Parser_AST.CalcProof (t3, t4, cs2)) -> + ((eq_term t11 t3) && (eq_term t21 t4)) && + (eq_list eq_calc_step cs1 cs2) + | (FStarC_Parser_AST.IntroForall (bs1, t11, t21), + FStarC_Parser_AST.IntroForall (bs2, t3, t4)) -> + ((eq_list eq_binder bs1 bs2) && (eq_term t11 t3)) && + (eq_term t21 t4) + | (FStarC_Parser_AST.IntroExists (bs1, t11, ts1, t21), + FStarC_Parser_AST.IntroExists (bs2, t3, ts2, t4)) -> + (((eq_list eq_binder bs1 bs2) && (eq_term t11 t3)) && + (eq_list eq_term ts1 ts2)) + && (eq_term t21 t4) + | (FStarC_Parser_AST.IntroImplies (t11, t21, b1, t3), + FStarC_Parser_AST.IntroImplies (t4, t5, b2, t6)) -> + (((eq_term t11 t4) && (eq_term t21 t5)) && (eq_binder b1 b2)) && + (eq_term t3 t6) + | (FStarC_Parser_AST.IntroOr (b1, t11, t21, t3), + FStarC_Parser_AST.IntroOr (b2, t4, t5, t6)) -> + (((b1 = b2) && (eq_term t11 t4)) && (eq_term t21 t5)) && + (eq_term t3 t6) + | (FStarC_Parser_AST.IntroAnd (t11, t21, t3, t4), + FStarC_Parser_AST.IntroAnd (t5, t6, t7, t8)) -> + (((eq_term t11 t5) && (eq_term t21 t6)) && (eq_term t3 t7)) && + (eq_term t4 t8) + | (FStarC_Parser_AST.ElimForall (bs1, t11, ts1), + FStarC_Parser_AST.ElimForall (bs2, t21, ts2)) -> + ((eq_list eq_binder bs1 bs2) && (eq_term t11 t21)) && + (eq_list eq_term ts1 ts2) + | (FStarC_Parser_AST.ElimExists (bs1, t11, t21, b1, t3), + FStarC_Parser_AST.ElimExists (bs2, t4, t5, b2, t6)) -> + ((((eq_list eq_binder bs1 bs2) && (eq_term t11 t4)) && + (eq_term t21 t5)) + && (eq_binder b1 b2)) + && (eq_term t3 t6) + | (FStarC_Parser_AST.ElimImplies (t11, t21, t3), + FStarC_Parser_AST.ElimImplies (t4, t5, t6)) -> + ((eq_term t11 t4) && (eq_term t21 t5)) && (eq_term t3 t6) + | (FStarC_Parser_AST.ElimOr (t11, t21, t3, b1, t4, b2, t5), + FStarC_Parser_AST.ElimOr (t6, t7, t8, b3, t9, b4, t10)) -> + ((((((eq_term t11 t6) && (eq_term t21 t7)) && (eq_term t3 t8)) && + (eq_binder b1 b3)) + && (eq_term t4 t9)) + && (eq_binder b2 b4)) + && (eq_term t5 t10) + | (FStarC_Parser_AST.ElimAnd (t11, t21, t3, b1, b2, t4), + FStarC_Parser_AST.ElimAnd (t5, t6, t7, b3, b4, t8)) -> + (((((eq_term t11 t5) && (eq_term t21 t6)) && (eq_term t3 t7)) && + (eq_binder b1 b3)) + && (eq_binder b2 b4)) + && (eq_term t4 t8) + | (FStarC_Parser_AST.ListLiteral ts1, FStarC_Parser_AST.ListLiteral + ts2) -> eq_list eq_term ts1 ts2 + | (FStarC_Parser_AST.SeqLiteral ts1, FStarC_Parser_AST.SeqLiteral ts2) + -> eq_list eq_term ts1 ts2 + | uu___ -> false +and (eq_calc_step : + FStarC_Parser_AST.calc_step -> FStarC_Parser_AST.calc_step -> Prims.bool) = + fun uu___ -> + fun uu___1 -> + match (uu___, uu___1) with + | (FStarC_Parser_AST.CalcStep (t1, t2, t3), FStarC_Parser_AST.CalcStep + (t4, t5, t6)) -> + ((eq_term t1 t4) && (eq_term t2 t5)) && (eq_term t3 t6) +and (eq_binder : + FStarC_Parser_AST.binder -> FStarC_Parser_AST.binder -> Prims.bool) = + fun b1 -> + fun b2 -> + ((eq_binder' b1.FStarC_Parser_AST.b b2.FStarC_Parser_AST.b) && + (eq_aqual b1.FStarC_Parser_AST.aqual b2.FStarC_Parser_AST.aqual)) + && + (eq_list eq_term b1.FStarC_Parser_AST.battributes + b2.FStarC_Parser_AST.battributes) +and (eq_binder' : + FStarC_Parser_AST.binder' -> FStarC_Parser_AST.binder' -> Prims.bool) = + fun b1 -> + fun b2 -> + match (b1, b2) with + | (FStarC_Parser_AST.Variable i1, FStarC_Parser_AST.Variable i2) -> + eq_ident i1 i2 + | (FStarC_Parser_AST.TVariable i1, FStarC_Parser_AST.TVariable i2) -> + eq_ident i1 i2 + | (FStarC_Parser_AST.Annotated (i1, t1), FStarC_Parser_AST.Annotated + (i2, t2)) -> (eq_ident i1 i2) && (eq_term t1 t2) + | (FStarC_Parser_AST.TAnnotated (i1, t1), FStarC_Parser_AST.TAnnotated + (i2, t2)) -> (eq_ident i1 i2) && (eq_term t1 t2) + | (FStarC_Parser_AST.NoName t1, FStarC_Parser_AST.NoName t2) -> + eq_term t1 t2 + | uu___ -> false +and (eq_match_returns_annotation : + (FStarC_Ident.ident FStar_Pervasives_Native.option * FStarC_Parser_AST.term + * Prims.bool) -> + (FStarC_Ident.ident FStar_Pervasives_Native.option * + FStarC_Parser_AST.term * Prims.bool) -> Prims.bool) + = + fun uu___ -> + fun uu___1 -> + match (uu___, uu___1) with + | ((i1, t1, b1), (i2, t2, b2)) -> + ((eq_option eq_ident i1 i2) && (eq_term t1 t2)) && (b1 = b2) +and (eq_branch : + (FStarC_Parser_AST.pattern * FStarC_Parser_AST.term + FStar_Pervasives_Native.option * FStarC_Parser_AST.term) -> + (FStarC_Parser_AST.pattern * FStarC_Parser_AST.term + FStar_Pervasives_Native.option * FStarC_Parser_AST.term) -> Prims.bool) + = + fun uu___ -> + fun uu___1 -> + match (uu___, uu___1) with + | ((p1, o1, t1), (p2, o2, t2)) -> + ((eq_pattern p1 p2) && (eq_option eq_term o1 o2)) && + (eq_term t1 t2) +let (eq_tycon_record : + FStarC_Parser_AST.tycon_record -> + FStarC_Parser_AST.tycon_record -> Prims.bool) + = + fun t1 -> + fun t2 -> + eq_list + (fun uu___ -> + fun uu___1 -> + match (uu___, uu___1) with + | ((i1, a1, a2, t11), (i2, a3, a4, t21)) -> + (((eq_ident i1 i2) && (eq_aqual a1 a3)) && + (eq_list eq_term a2 a4)) + && (eq_term t11 t21)) t1 t2 +let (eq_constructor_payload : + FStarC_Parser_AST.constructor_payload -> + FStarC_Parser_AST.constructor_payload -> Prims.bool) + = + fun t1 -> + fun t2 -> + match (t1, t2) with + | (FStarC_Parser_AST.VpOfNotation t11, FStarC_Parser_AST.VpOfNotation + t21) -> eq_term t11 t21 + | (FStarC_Parser_AST.VpArbitrary t11, FStarC_Parser_AST.VpArbitrary + t21) -> eq_term t11 t21 + | (FStarC_Parser_AST.VpRecord (r1, k1), FStarC_Parser_AST.VpRecord + (r2, k2)) -> (eq_tycon_record r1 r2) && (eq_option eq_term k1 k2) + | uu___ -> false +let (eq_tycon : + FStarC_Parser_AST.tycon -> FStarC_Parser_AST.tycon -> Prims.bool) = + fun t1 -> + fun t2 -> + match (t1, t2) with + | (FStarC_Parser_AST.TyconAbstract (i1, bs1, k1), + FStarC_Parser_AST.TyconAbstract (i2, bs2, k2)) -> + ((eq_ident i1 i2) && (eq_list eq_binder bs1 bs2)) && + (eq_option eq_term k1 k2) + | (FStarC_Parser_AST.TyconAbbrev (i1, bs1, k1, t11), + FStarC_Parser_AST.TyconAbbrev (i2, bs2, k2, t21)) -> + (((eq_ident i1 i2) && (eq_list eq_binder bs1 bs2)) && + (eq_option eq_term k1 k2)) + && (eq_term t11 t21) + | (FStarC_Parser_AST.TyconRecord (i1, bs1, k1, a1, r1), + FStarC_Parser_AST.TyconRecord (i2, bs2, k2, a2, r2)) -> + ((((eq_ident i1 i2) && (eq_list eq_binder bs1 bs2)) && + (eq_option eq_term k1 k2)) + && (eq_list eq_term a1 a2)) + && (eq_tycon_record r1 r2) + | (FStarC_Parser_AST.TyconVariant (i1, bs1, k1, cs1), + FStarC_Parser_AST.TyconVariant (i2, bs2, k2, cs2)) -> + (((eq_ident i1 i2) && (eq_list eq_binder bs1 bs2)) && + (eq_option eq_term k1 k2)) + && + (eq_list + (fun uu___ -> + fun uu___1 -> + match (uu___, uu___1) with + | ((i11, o1, a1), (i21, o2, a2)) -> + ((eq_ident i11 i21) && + (eq_option eq_constructor_payload o1 o2)) + && (eq_list eq_term a1 a2)) cs1 cs2) + | uu___ -> false +let (eq_lid : FStarC_Ident.lident -> FStarC_Ident.lident -> Prims.bool) = + FStarC_Ident.lid_equals +let (eq_lift : + FStarC_Parser_AST.lift -> FStarC_Parser_AST.lift -> Prims.bool) = + fun t1 -> + fun t2 -> + ((eq_lid t1.FStarC_Parser_AST.msource t2.FStarC_Parser_AST.msource) && + (eq_lid t1.FStarC_Parser_AST.mdest t2.FStarC_Parser_AST.mdest)) + && + (match ((t1.FStarC_Parser_AST.lift_op), + (t2.FStarC_Parser_AST.lift_op)) + with + | (FStarC_Parser_AST.NonReifiableLift t11, + FStarC_Parser_AST.NonReifiableLift t21) -> eq_term t11 t21 + | (FStarC_Parser_AST.ReifiableLift (t11, t21), + FStarC_Parser_AST.ReifiableLift (t3, t4)) -> + (eq_term t11 t3) && (eq_term t21 t4) + | (FStarC_Parser_AST.LiftForFree t11, FStarC_Parser_AST.LiftForFree + t21) -> eq_term t11 t21 + | uu___ -> false) +let (eq_pragma : + FStarC_Parser_AST.pragma -> FStarC_Parser_AST.pragma -> Prims.bool) = + fun t1 -> + fun t2 -> + match (t1, t2) with + | (FStarC_Parser_AST.SetOptions s1, FStarC_Parser_AST.SetOptions s2) -> + s1 = s2 + | (FStarC_Parser_AST.ResetOptions s1, FStarC_Parser_AST.ResetOptions + s2) -> eq_option (fun s11 -> fun s21 -> s11 = s21) s1 s2 + | (FStarC_Parser_AST.PushOptions s1, FStarC_Parser_AST.PushOptions s2) + -> eq_option (fun s11 -> fun s21 -> s11 = s21) s1 s2 + | (FStarC_Parser_AST.PopOptions, FStarC_Parser_AST.PopOptions) -> true + | (FStarC_Parser_AST.RestartSolver, FStarC_Parser_AST.RestartSolver) -> + true + | (FStarC_Parser_AST.PrintEffectsGraph, + FStarC_Parser_AST.PrintEffectsGraph) -> true + | uu___ -> false +let (eq_qualifier : + FStarC_Parser_AST.qualifier -> FStarC_Parser_AST.qualifier -> Prims.bool) = + fun t1 -> + fun t2 -> + match (t1, t2) with + | (FStarC_Parser_AST.Private, FStarC_Parser_AST.Private) -> true + | (FStarC_Parser_AST.Noeq, FStarC_Parser_AST.Noeq) -> true + | (FStarC_Parser_AST.Unopteq, FStarC_Parser_AST.Unopteq) -> true + | (FStarC_Parser_AST.Assumption, FStarC_Parser_AST.Assumption) -> true + | (FStarC_Parser_AST.DefaultEffect, FStarC_Parser_AST.DefaultEffect) -> + true + | (FStarC_Parser_AST.TotalEffect, FStarC_Parser_AST.TotalEffect) -> + true + | (FStarC_Parser_AST.Effect_qual, FStarC_Parser_AST.Effect_qual) -> + true + | (FStarC_Parser_AST.New, FStarC_Parser_AST.New) -> true + | (FStarC_Parser_AST.Inline, FStarC_Parser_AST.Inline) -> true + | (FStarC_Parser_AST.Visible, FStarC_Parser_AST.Visible) -> true + | (FStarC_Parser_AST.Unfold_for_unification_and_vcgen, + FStarC_Parser_AST.Unfold_for_unification_and_vcgen) -> true + | (FStarC_Parser_AST.Inline_for_extraction, + FStarC_Parser_AST.Inline_for_extraction) -> true + | (FStarC_Parser_AST.Irreducible, FStarC_Parser_AST.Irreducible) -> + true + | (FStarC_Parser_AST.NoExtract, FStarC_Parser_AST.NoExtract) -> true + | (FStarC_Parser_AST.Reifiable, FStarC_Parser_AST.Reifiable) -> true + | (FStarC_Parser_AST.Reflectable, FStarC_Parser_AST.Reflectable) -> + true + | (FStarC_Parser_AST.Opaque, FStarC_Parser_AST.Opaque) -> true + | (FStarC_Parser_AST.Logic, FStarC_Parser_AST.Logic) -> true + | uu___ -> false +let (eq_qualifiers : + FStarC_Parser_AST.qualifiers -> FStarC_Parser_AST.qualifiers -> Prims.bool) + = fun t1 -> fun t2 -> eq_list eq_qualifier t1 t2 +let (eq_restriction : + FStarC_Syntax_Syntax.restriction -> + FStarC_Syntax_Syntax.restriction -> Prims.bool) + = + fun restriction1 -> + fun restriction2 -> + match (restriction1, restriction2) with + | (FStarC_Syntax_Syntax.Unrestricted, + FStarC_Syntax_Syntax.Unrestricted) -> true + | (FStarC_Syntax_Syntax.AllowList l1, FStarC_Syntax_Syntax.AllowList + l2) -> + let eq_tuple eq_fst eq_snd uu___ uu___1 = + match (uu___, uu___1) with + | ((a, b), (c, d)) -> (eq_fst a c) && (eq_snd b d) in + eq_list (eq_tuple eq_ident (eq_option eq_ident)) l1 l2 +let rec (eq_decl' : + FStarC_Parser_AST.decl' -> FStarC_Parser_AST.decl' -> Prims.bool) = + fun d1 -> + fun d2 -> + match (d1, d2) with + | (FStarC_Parser_AST.TopLevelModule lid1, + FStarC_Parser_AST.TopLevelModule lid2) -> eq_lid lid1 lid2 + | (FStarC_Parser_AST.Open (lid1, restriction1), FStarC_Parser_AST.Open + (lid2, restriction2)) -> + (eq_lid lid1 lid2) && (eq_restriction restriction1 restriction2) + | (FStarC_Parser_AST.Friend lid1, FStarC_Parser_AST.Friend lid2) -> + eq_lid lid1 lid2 + | (FStarC_Parser_AST.Include (lid1, restriction1), + FStarC_Parser_AST.Include (lid2, restriction2)) -> + (eq_lid lid1 lid2) && (eq_restriction restriction1 restriction2) + | (FStarC_Parser_AST.ModuleAbbrev (i1, lid1), + FStarC_Parser_AST.ModuleAbbrev (i2, lid2)) -> + (eq_ident i1 i2) && (eq_lid lid1 lid2) + | (FStarC_Parser_AST.TopLevelLet (lq1, pats1), + FStarC_Parser_AST.TopLevelLet (lq2, pats2)) -> + (lq1 = lq2) && + (eq_list + (fun uu___ -> + fun uu___1 -> + match (uu___, uu___1) with + | ((p1, t1), (p2, t2)) -> + (eq_pattern p1 p2) && (eq_term t1 t2)) pats1 pats2) + | (FStarC_Parser_AST.Tycon (b1, b2, tcs1), FStarC_Parser_AST.Tycon + (b3, b4, tcs2)) -> + ((b1 = b3) && (b2 = b4)) && (eq_list eq_tycon tcs1 tcs2) + | (FStarC_Parser_AST.Val (i1, t1), FStarC_Parser_AST.Val (i2, t2)) -> + (eq_ident i1 i2) && (eq_term t1 t2) + | (FStarC_Parser_AST.Exception (i1, t1), FStarC_Parser_AST.Exception + (i2, t2)) -> (eq_ident i1 i2) && (eq_option eq_term t1 t2) + | (FStarC_Parser_AST.NewEffect ed1, FStarC_Parser_AST.NewEffect ed2) -> + eq_effect_decl ed1 ed2 + | (FStarC_Parser_AST.LayeredEffect ed1, FStarC_Parser_AST.LayeredEffect + ed2) -> eq_effect_decl ed1 ed2 + | (FStarC_Parser_AST.SubEffect l1, FStarC_Parser_AST.SubEffect l2) -> + eq_lift l1 l2 + | (FStarC_Parser_AST.Polymonadic_bind (lid1, lid2, lid3, t1), + FStarC_Parser_AST.Polymonadic_bind (lid4, lid5, lid6, t2)) -> + (((eq_lid lid1 lid4) && (eq_lid lid2 lid5)) && (eq_lid lid3 lid6)) + && (eq_term t1 t2) + | (FStarC_Parser_AST.Polymonadic_subcomp (lid1, lid2, t1), + FStarC_Parser_AST.Polymonadic_subcomp (lid3, lid4, t2)) -> + ((eq_lid lid1 lid3) && (eq_lid lid2 lid4)) && (eq_term t1 t2) + | (FStarC_Parser_AST.Pragma p1, FStarC_Parser_AST.Pragma p2) -> + eq_pragma p1 p2 + | (FStarC_Parser_AST.Assume (i1, t1), FStarC_Parser_AST.Assume + (i2, t2)) -> (eq_ident i1 i2) && (eq_term t1 t2) + | (FStarC_Parser_AST.Splice (is_typed1, is1, t1), + FStarC_Parser_AST.Splice (is_typed2, is2, t2)) -> + ((is_typed1 = is_typed2) && (eq_list eq_ident is1 is2)) && + (eq_term t1 t2) + | (FStarC_Parser_AST.DeclSyntaxExtension (s1, t1, uu___, uu___1), + FStarC_Parser_AST.DeclSyntaxExtension (s2, t2, uu___2, uu___3)) -> + (s1 = s2) && (t1 = t2) + | (FStarC_Parser_AST.UseLangDecls p1, FStarC_Parser_AST.UseLangDecls + p2) -> p1 = p2 + | (FStarC_Parser_AST.DeclToBeDesugared tbs1, + FStarC_Parser_AST.DeclToBeDesugared tbs2) -> + (tbs1.FStarC_Parser_AST.lang_name = + tbs2.FStarC_Parser_AST.lang_name) + && + (tbs1.FStarC_Parser_AST.eq tbs1.FStarC_Parser_AST.blob + tbs2.FStarC_Parser_AST.blob) + | uu___ -> false +and (eq_effect_decl : + FStarC_Parser_AST.effect_decl -> + FStarC_Parser_AST.effect_decl -> Prims.bool) + = + fun t1 -> + fun t2 -> + match (t1, t2) with + | (FStarC_Parser_AST.DefineEffect (i1, bs1, t11, ds1), + FStarC_Parser_AST.DefineEffect (i2, bs2, t21, ds2)) -> + (((eq_ident i1 i2) && (eq_list eq_binder bs1 bs2)) && + (eq_term t11 t21)) + && (eq_list eq_decl ds1 ds2) + | (FStarC_Parser_AST.RedefineEffect (i1, bs1, t11), + FStarC_Parser_AST.RedefineEffect (i2, bs2, t21)) -> + ((eq_ident i1 i2) && (eq_list eq_binder bs1 bs2)) && + (eq_term t11 t21) + | uu___ -> false +and (eq_decl : + FStarC_Parser_AST.decl -> FStarC_Parser_AST.decl -> Prims.bool) = + fun d1 -> + fun d2 -> + ((eq_decl' d1.FStarC_Parser_AST.d d2.FStarC_Parser_AST.d) && + (eq_list eq_qualifier d1.FStarC_Parser_AST.quals + d2.FStarC_Parser_AST.quals)) + && + (eq_list eq_term d1.FStarC_Parser_AST.attrs + d2.FStarC_Parser_AST.attrs) +let concat_map : + 'uuuuu 'uuuuu1 . + unit -> + ('uuuuu -> 'uuuuu1 Prims.list) -> + 'uuuuu Prims.list -> 'uuuuu1 Prims.list + = fun uu___ -> FStarC_Compiler_List.collect +let opt_map : + 'uuuuu 'a . + ('a -> 'uuuuu Prims.list) -> + 'a FStar_Pervasives_Native.option -> 'uuuuu Prims.list + = + fun f -> + fun x -> + match x with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some x1 -> f x1 +let rec (lidents_of_term : + FStarC_Parser_AST.term -> FStarC_Ident.lident Prims.list) = + fun t -> lidents_of_term' t.FStarC_Parser_AST.tm +and (lidents_of_term' : + FStarC_Parser_AST.term' -> FStarC_Ident.lident Prims.list) = + fun t -> + match t with + | FStarC_Parser_AST.Wild -> [] + | FStarC_Parser_AST.Const uu___ -> [] + | FStarC_Parser_AST.Op (s, ts) -> (concat_map ()) lidents_of_term ts + | FStarC_Parser_AST.Tvar uu___ -> [] + | FStarC_Parser_AST.Uvar uu___ -> [] + | FStarC_Parser_AST.Var lid -> [lid] + | FStarC_Parser_AST.Name lid -> [lid] + | FStarC_Parser_AST.Projector (lid, uu___) -> [lid] + | FStarC_Parser_AST.Construct (lid, ts) -> + let uu___ = + (concat_map ()) + (fun uu___1 -> + match uu___1 with | (t1, uu___2) -> lidents_of_term t1) ts in + lid :: uu___ + | FStarC_Parser_AST.Function (brs, uu___) -> + (concat_map ()) lidents_of_branch brs + | FStarC_Parser_AST.Abs (ps, t1) -> + let uu___ = (concat_map ()) lidents_of_pattern ps in + let uu___1 = lidents_of_term t1 in + FStarC_Compiler_List.op_At uu___ uu___1 + | FStarC_Parser_AST.App (t1, t2, uu___) -> + let uu___1 = lidents_of_term t1 in + let uu___2 = lidents_of_term t2 in + FStarC_Compiler_List.op_At uu___1 uu___2 + | FStarC_Parser_AST.Let (uu___, lbs, t1) -> + let uu___1 = + (concat_map ()) + (fun uu___2 -> + match uu___2 with + | (uu___3, (p, t2)) -> + let uu___4 = lidents_of_pattern p in + let uu___5 = lidents_of_term t2 in + FStarC_Compiler_List.op_At uu___4 uu___5) lbs in + let uu___2 = lidents_of_term t1 in + FStarC_Compiler_List.op_At uu___1 uu___2 + | FStarC_Parser_AST.LetOperator (lbs, t1) -> + let uu___ = + (concat_map ()) + (fun uu___1 -> + match uu___1 with + | (uu___2, p, t2) -> + let uu___3 = lidents_of_pattern p in + let uu___4 = lidents_of_term t2 in + FStarC_Compiler_List.op_At uu___3 uu___4) lbs in + let uu___1 = lidents_of_term t1 in + FStarC_Compiler_List.op_At uu___ uu___1 + | FStarC_Parser_AST.LetOpen (lid, t1) -> + let uu___ = lidents_of_term t1 in lid :: uu___ + | FStarC_Parser_AST.LetOpenRecord (t1, t2, t3) -> + let uu___ = lidents_of_term t1 in + let uu___1 = + let uu___2 = lidents_of_term t2 in + let uu___3 = lidents_of_term t3 in + FStarC_Compiler_List.op_At uu___2 uu___3 in + FStarC_Compiler_List.op_At uu___ uu___1 + | FStarC_Parser_AST.Seq (t1, t2) -> + let uu___ = lidents_of_term t1 in + let uu___1 = lidents_of_term t2 in + FStarC_Compiler_List.op_At uu___ uu___1 + | FStarC_Parser_AST.Bind (uu___, t1, t2) -> + let uu___1 = lidents_of_term t1 in + let uu___2 = lidents_of_term t2 in + FStarC_Compiler_List.op_At uu___1 uu___2 + | FStarC_Parser_AST.If (t1, uu___, uu___1, t2, t3) -> + let uu___2 = lidents_of_term t1 in + let uu___3 = + let uu___4 = lidents_of_term t2 in + let uu___5 = lidents_of_term t3 in + FStarC_Compiler_List.op_At uu___4 uu___5 in + FStarC_Compiler_List.op_At uu___2 uu___3 + | FStarC_Parser_AST.Match (t1, uu___, uu___1, bs) -> + let uu___2 = lidents_of_term t1 in + let uu___3 = (concat_map ()) lidents_of_branch bs in + FStarC_Compiler_List.op_At uu___2 uu___3 + | FStarC_Parser_AST.TryWith (t1, bs) -> + let uu___ = lidents_of_term t1 in + let uu___1 = (concat_map ()) lidents_of_branch bs in + FStarC_Compiler_List.op_At uu___ uu___1 + | FStarC_Parser_AST.Ascribed (t1, t2, uu___, uu___1) -> + let uu___2 = lidents_of_term t1 in + let uu___3 = lidents_of_term t2 in + FStarC_Compiler_List.op_At uu___2 uu___3 + | FStarC_Parser_AST.Record (t1, ts) -> + let uu___ = + (concat_map ()) + (fun uu___1 -> + match uu___1 with | (uu___2, t2) -> lidents_of_term t2) ts in + let uu___1 = opt_map lidents_of_term t1 in + FStarC_Compiler_List.op_At uu___ uu___1 + | FStarC_Parser_AST.Project (t1, uu___) -> lidents_of_term t1 + | FStarC_Parser_AST.Product (ts, t1) -> + let uu___ = (concat_map ()) lidents_of_binder ts in + let uu___1 = lidents_of_term t1 in + FStarC_Compiler_List.op_At uu___ uu___1 + | FStarC_Parser_AST.Sum (ts, t1) -> + let uu___ = + (concat_map ()) + (fun uu___1 -> + match uu___1 with + | FStar_Pervasives.Inl b -> lidents_of_binder b + | FStar_Pervasives.Inr t2 -> lidents_of_term t2) ts in + let uu___1 = lidents_of_term t1 in + FStarC_Compiler_List.op_At uu___ uu___1 + | FStarC_Parser_AST.QForall (bs, _pats, t1) -> lidents_of_term t1 + | FStarC_Parser_AST.QExists (bs, _pats, t1) -> lidents_of_term t1 + | FStarC_Parser_AST.QuantOp (i, bs, pats, t1) -> lidents_of_term t1 + | FStarC_Parser_AST.Refine (b, t1) -> lidents_of_term t1 + | FStarC_Parser_AST.NamedTyp (i, t1) -> lidents_of_term t1 + | FStarC_Parser_AST.Paren t1 -> lidents_of_term t1 + | FStarC_Parser_AST.Requires (t1, uu___) -> lidents_of_term t1 + | FStarC_Parser_AST.Ensures (t1, uu___) -> lidents_of_term t1 + | FStarC_Parser_AST.LexList ts -> (concat_map ()) lidents_of_term ts + | FStarC_Parser_AST.WFOrder (t1, t2) -> + let uu___ = lidents_of_term t1 in + let uu___1 = lidents_of_term t2 in + FStarC_Compiler_List.op_At uu___ uu___1 + | FStarC_Parser_AST.Decreases (t1, uu___) -> lidents_of_term t1 + | FStarC_Parser_AST.Labeled (t1, uu___, uu___1) -> lidents_of_term t1 + | FStarC_Parser_AST.Discrim lid -> [lid] + | FStarC_Parser_AST.Attributes ts -> (concat_map ()) lidents_of_term ts + | FStarC_Parser_AST.Antiquote t1 -> lidents_of_term t1 + | FStarC_Parser_AST.Quote (t1, uu___) -> lidents_of_term t1 + | FStarC_Parser_AST.VQuote t1 -> lidents_of_term t1 + | FStarC_Parser_AST.CalcProof (t1, t2, ts) -> + let uu___ = lidents_of_term t1 in + let uu___1 = + let uu___2 = lidents_of_term t2 in + let uu___3 = (concat_map ()) lidents_of_calc_step ts in + FStarC_Compiler_List.op_At uu___2 uu___3 in + FStarC_Compiler_List.op_At uu___ uu___1 + | FStarC_Parser_AST.IntroForall (bs, t1, t2) -> + let uu___ = lidents_of_term t1 in + let uu___1 = lidents_of_term t2 in + FStarC_Compiler_List.op_At uu___ uu___1 + | FStarC_Parser_AST.IntroExists (bs, t1, ts, t2) -> + let uu___ = lidents_of_term t1 in + let uu___1 = + let uu___2 = (concat_map ()) lidents_of_term ts in + let uu___3 = lidents_of_term t2 in + FStarC_Compiler_List.op_At uu___2 uu___3 in + FStarC_Compiler_List.op_At uu___ uu___1 + | FStarC_Parser_AST.IntroImplies (t1, t2, b, t3) -> + let uu___ = lidents_of_term t1 in + let uu___1 = + let uu___2 = lidents_of_term t2 in + let uu___3 = lidents_of_term t3 in + FStarC_Compiler_List.op_At uu___2 uu___3 in + FStarC_Compiler_List.op_At uu___ uu___1 + | FStarC_Parser_AST.IntroOr (b, t1, t2, t3) -> + let uu___ = lidents_of_term t1 in + let uu___1 = + let uu___2 = lidents_of_term t2 in + let uu___3 = lidents_of_term t3 in + FStarC_Compiler_List.op_At uu___2 uu___3 in + FStarC_Compiler_List.op_At uu___ uu___1 + | FStarC_Parser_AST.IntroAnd (t1, t2, t3, t4) -> + let uu___ = lidents_of_term t1 in + let uu___1 = + let uu___2 = lidents_of_term t2 in + let uu___3 = + let uu___4 = lidents_of_term t3 in + let uu___5 = lidents_of_term t4 in + FStarC_Compiler_List.op_At uu___4 uu___5 in + FStarC_Compiler_List.op_At uu___2 uu___3 in + FStarC_Compiler_List.op_At uu___ uu___1 + | FStarC_Parser_AST.ElimForall (bs, t1, ts) -> + let uu___ = (concat_map ()) lidents_of_binder bs in + let uu___1 = + let uu___2 = lidents_of_term t1 in + let uu___3 = (concat_map ()) lidents_of_term ts in + FStarC_Compiler_List.op_At uu___2 uu___3 in + FStarC_Compiler_List.op_At uu___ uu___1 + | FStarC_Parser_AST.ElimExists (bs, t1, t2, b, t3) -> + let uu___ = (concat_map ()) lidents_of_binder bs in + let uu___1 = + let uu___2 = lidents_of_term t1 in + let uu___3 = + let uu___4 = lidents_of_term t2 in + let uu___5 = lidents_of_term t3 in + FStarC_Compiler_List.op_At uu___4 uu___5 in + FStarC_Compiler_List.op_At uu___2 uu___3 in + FStarC_Compiler_List.op_At uu___ uu___1 + | FStarC_Parser_AST.ElimImplies (t1, t2, t3) -> + let uu___ = lidents_of_term t1 in + let uu___1 = + let uu___2 = lidents_of_term t2 in + let uu___3 = lidents_of_term t3 in + FStarC_Compiler_List.op_At uu___2 uu___3 in + FStarC_Compiler_List.op_At uu___ uu___1 + | FStarC_Parser_AST.ElimOr (t1, t2, t3, b1, t4, b2, t5) -> + let uu___ = lidents_of_term t1 in + let uu___1 = + let uu___2 = lidents_of_term t2 in + let uu___3 = + let uu___4 = lidents_of_term t3 in + let uu___5 = + let uu___6 = lidents_of_term t4 in + let uu___7 = lidents_of_term t5 in + FStarC_Compiler_List.op_At uu___6 uu___7 in + FStarC_Compiler_List.op_At uu___4 uu___5 in + FStarC_Compiler_List.op_At uu___2 uu___3 in + FStarC_Compiler_List.op_At uu___ uu___1 + | FStarC_Parser_AST.ElimAnd (t1, t2, t3, b1, b2, t4) -> + let uu___ = lidents_of_term t1 in + let uu___1 = + let uu___2 = lidents_of_term t2 in + let uu___3 = + let uu___4 = lidents_of_term t3 in + let uu___5 = lidents_of_term t4 in + FStarC_Compiler_List.op_At uu___4 uu___5 in + FStarC_Compiler_List.op_At uu___2 uu___3 in + FStarC_Compiler_List.op_At uu___ uu___1 + | FStarC_Parser_AST.ListLiteral ts -> (concat_map ()) lidents_of_term ts + | FStarC_Parser_AST.SeqLiteral ts -> (concat_map ()) lidents_of_term ts +and (lidents_of_branch : + (FStarC_Parser_AST.pattern * FStarC_Parser_AST.term + FStar_Pervasives_Native.option * FStarC_Parser_AST.term) -> + FStarC_Ident.lident Prims.list) + = + fun uu___ -> + match uu___ with + | (p, uu___1, t) -> + let uu___2 = lidents_of_pattern p in + let uu___3 = lidents_of_term t in + FStarC_Compiler_List.op_At uu___2 uu___3 +and (lidents_of_calc_step : + FStarC_Parser_AST.calc_step -> FStarC_Ident.lident Prims.list) = + fun uu___ -> + match uu___ with + | FStarC_Parser_AST.CalcStep (t1, t2, t3) -> + let uu___1 = lidents_of_term t1 in + let uu___2 = + let uu___3 = lidents_of_term t2 in + let uu___4 = lidents_of_term t3 in + FStarC_Compiler_List.op_At uu___3 uu___4 in + FStarC_Compiler_List.op_At uu___1 uu___2 +and (lidents_of_pattern : + FStarC_Parser_AST.pattern -> FStarC_Ident.lident Prims.list) = + fun p -> + match p.FStarC_Parser_AST.pat with + | FStarC_Parser_AST.PatWild uu___ -> [] + | FStarC_Parser_AST.PatConst uu___ -> [] + | FStarC_Parser_AST.PatApp (p1, ps) -> + let uu___ = lidents_of_pattern p1 in + let uu___1 = (concat_map ()) lidents_of_pattern ps in + FStarC_Compiler_List.op_At uu___ uu___1 + | FStarC_Parser_AST.PatVar (i, uu___, uu___1) -> + let uu___2 = FStarC_Ident.lid_of_ids [i] in [uu___2] + | FStarC_Parser_AST.PatName lid -> [lid] + | FStarC_Parser_AST.PatTvar (i, uu___, uu___1) -> [] + | FStarC_Parser_AST.PatList ps -> (concat_map ()) lidents_of_pattern ps + | FStarC_Parser_AST.PatTuple (ps, uu___) -> + (concat_map ()) lidents_of_pattern ps + | FStarC_Parser_AST.PatRecord ps -> + (concat_map ()) + (fun uu___ -> + match uu___ with | (uu___1, p1) -> lidents_of_pattern p1) ps + | FStarC_Parser_AST.PatAscribed (p1, (t1, t2)) -> + let uu___ = lidents_of_pattern p1 in + let uu___1 = + let uu___2 = lidents_of_term t1 in + let uu___3 = opt_map lidents_of_term t2 in + FStarC_Compiler_List.op_At uu___2 uu___3 in + FStarC_Compiler_List.op_At uu___ uu___1 + | FStarC_Parser_AST.PatOr ps -> (concat_map ()) lidents_of_pattern ps + | FStarC_Parser_AST.PatOp uu___ -> [] + | FStarC_Parser_AST.PatVQuote t -> lidents_of_term t +and (lidents_of_binder : + FStarC_Parser_AST.binder -> FStarC_Ident.lident Prims.list) = + fun b -> + match b.FStarC_Parser_AST.b with + | FStarC_Parser_AST.Annotated (uu___, t) -> lidents_of_term t + | FStarC_Parser_AST.TAnnotated (uu___, t) -> lidents_of_term t + | FStarC_Parser_AST.NoName t -> lidents_of_term t + | uu___ -> [] +let lidents_of_tycon_record : + 'uuuuu 'uuuuu1 'uuuuu2 . + ('uuuuu * 'uuuuu1 * 'uuuuu2 * FStarC_Parser_AST.term) -> + FStarC_Ident.lident Prims.list + = + fun uu___ -> + match uu___ with | (uu___1, uu___2, uu___3, t) -> lidents_of_term t +let (lidents_of_constructor_payload : + FStarC_Parser_AST.constructor_payload -> FStarC_Ident.lident Prims.list) = + fun t -> + match t with + | FStarC_Parser_AST.VpOfNotation t1 -> lidents_of_term t1 + | FStarC_Parser_AST.VpArbitrary t1 -> lidents_of_term t1 + | FStarC_Parser_AST.VpRecord (tc, FStar_Pervasives_Native.None) -> + (concat_map ()) lidents_of_tycon_record tc + | FStarC_Parser_AST.VpRecord (tc, FStar_Pervasives_Native.Some t1) -> + let uu___ = (concat_map ()) lidents_of_tycon_record tc in + let uu___1 = lidents_of_term t1 in + FStarC_Compiler_List.op_At uu___ uu___1 +let (lidents_of_tycon_variant : + (FStarC_Ident.ident * FStarC_Parser_AST.constructor_payload + FStar_Pervasives_Native.option * FStarC_Parser_AST.attributes_) -> + FStarC_Ident.lident Prims.list) + = + fun tc -> + match tc with + | (uu___, FStar_Pervasives_Native.None, uu___1) -> [] + | (uu___, FStar_Pervasives_Native.Some t, uu___1) -> + lidents_of_constructor_payload t +let (lidents_of_tycon : + FStarC_Parser_AST.tycon -> FStarC_Ident.lident Prims.list) = + fun tc -> + match tc with + | FStarC_Parser_AST.TyconAbstract (uu___, bs, k) -> + let uu___1 = (concat_map ()) lidents_of_binder bs in + let uu___2 = opt_map lidents_of_term k in + FStarC_Compiler_List.op_At uu___1 uu___2 + | FStarC_Parser_AST.TyconAbbrev (uu___, bs, k, t) -> + let uu___1 = (concat_map ()) lidents_of_binder bs in + let uu___2 = + let uu___3 = opt_map lidents_of_term k in + let uu___4 = lidents_of_term t in + FStarC_Compiler_List.op_At uu___3 uu___4 in + FStarC_Compiler_List.op_At uu___1 uu___2 + | FStarC_Parser_AST.TyconRecord (uu___, bs, k, uu___1, tcs) -> + let uu___2 = (concat_map ()) lidents_of_binder bs in + let uu___3 = + let uu___4 = opt_map lidents_of_term k in + let uu___5 = (concat_map ()) lidents_of_tycon_record tcs in + FStarC_Compiler_List.op_At uu___4 uu___5 in + FStarC_Compiler_List.op_At uu___2 uu___3 + | FStarC_Parser_AST.TyconVariant (uu___, bs, k, tcs) -> + let uu___1 = (concat_map ()) lidents_of_binder bs in + let uu___2 = + let uu___3 = opt_map lidents_of_term k in + let uu___4 = (concat_map ()) lidents_of_tycon_variant tcs in + FStarC_Compiler_List.op_At uu___3 uu___4 in + FStarC_Compiler_List.op_At uu___1 uu___2 +let (lidents_of_lift : + FStarC_Parser_AST.lift -> FStarC_Ident.lident Prims.list) = + fun l -> + let uu___ = + match l.FStarC_Parser_AST.lift_op with + | FStarC_Parser_AST.NonReifiableLift t -> lidents_of_term t + | FStarC_Parser_AST.ReifiableLift (t1, t2) -> + let uu___1 = lidents_of_term t1 in + let uu___2 = lidents_of_term t2 in + FStarC_Compiler_List.op_At uu___1 uu___2 + | FStarC_Parser_AST.LiftForFree t -> lidents_of_term t in + FStarC_Compiler_List.op_At + [l.FStarC_Parser_AST.msource; l.FStarC_Parser_AST.mdest] uu___ +let rec (lidents_of_decl : + FStarC_Parser_AST.decl -> FStarC_Ident.lident Prims.list) = + fun d -> + match d.FStarC_Parser_AST.d with + | FStarC_Parser_AST.TopLevelModule uu___ -> [] + | FStarC_Parser_AST.Open (l, uu___) -> [l] + | FStarC_Parser_AST.Friend l -> [l] + | FStarC_Parser_AST.Include (l, uu___) -> [l] + | FStarC_Parser_AST.ModuleAbbrev (uu___, l) -> [l] + | FStarC_Parser_AST.TopLevelLet (_q, lbs) -> + (concat_map ()) + (fun uu___ -> + match uu___ with + | (p, t) -> + let uu___1 = lidents_of_pattern p in + let uu___2 = lidents_of_term t in + FStarC_Compiler_List.op_At uu___1 uu___2) lbs + | FStarC_Parser_AST.Tycon (uu___, uu___1, tcs) -> + (concat_map ()) lidents_of_tycon tcs + | FStarC_Parser_AST.Val (uu___, t) -> lidents_of_term t + | FStarC_Parser_AST.Exception (uu___, FStar_Pervasives_Native.None) -> [] + | FStarC_Parser_AST.Exception (uu___, FStar_Pervasives_Native.Some t) -> + lidents_of_term t + | FStarC_Parser_AST.NewEffect ed -> lidents_of_effect_decl ed + | FStarC_Parser_AST.LayeredEffect ed -> lidents_of_effect_decl ed + | FStarC_Parser_AST.SubEffect lift -> lidents_of_lift lift + | FStarC_Parser_AST.Polymonadic_bind (l0, l1, l2, t) -> + let uu___ = + let uu___1 = let uu___2 = lidents_of_term t in l2 :: uu___2 in l1 + :: uu___1 in + l0 :: uu___ + | FStarC_Parser_AST.Polymonadic_subcomp (l0, l1, t) -> + let uu___ = let uu___1 = lidents_of_term t in l1 :: uu___1 in l0 :: + uu___ + | FStarC_Parser_AST.Pragma uu___ -> [] + | FStarC_Parser_AST.Assume (uu___, t) -> lidents_of_term t + | FStarC_Parser_AST.Splice (uu___, uu___1, t) -> lidents_of_term t + | FStarC_Parser_AST.DeclSyntaxExtension uu___ -> [] + | FStarC_Parser_AST.DeclToBeDesugared uu___ -> [] +and (lidents_of_effect_decl : + FStarC_Parser_AST.effect_decl -> FStarC_Ident.lident Prims.list) = + fun ed -> + match ed with + | FStarC_Parser_AST.DefineEffect (uu___, bs, t, ds) -> + let uu___1 = (concat_map ()) lidents_of_binder bs in + let uu___2 = + let uu___3 = lidents_of_term t in + let uu___4 = (concat_map ()) lidents_of_decl ds in + FStarC_Compiler_List.op_At uu___3 uu___4 in + FStarC_Compiler_List.op_At uu___1 uu___2 + | FStarC_Parser_AST.RedefineEffect (uu___, bs, t) -> + let uu___1 = (concat_map ()) lidents_of_binder bs in + let uu___2 = lidents_of_term t in + FStarC_Compiler_List.op_At uu___1 uu___2 +type open_namespaces_and_abbreviations = + { + open_namespaces: FStarC_Ident.lident Prims.list ; + module_abbreviations: (FStarC_Ident.ident * FStarC_Ident.lident) Prims.list } +let (__proj__Mkopen_namespaces_and_abbreviations__item__open_namespaces : + open_namespaces_and_abbreviations -> FStarC_Ident.lident Prims.list) = + fun projectee -> + match projectee with + | { open_namespaces; module_abbreviations;_} -> open_namespaces +let (__proj__Mkopen_namespaces_and_abbreviations__item__module_abbreviations + : + open_namespaces_and_abbreviations -> + (FStarC_Ident.ident * FStarC_Ident.lident) Prims.list) + = + fun projectee -> + match projectee with + | { open_namespaces; module_abbreviations;_} -> module_abbreviations +type error_message = + { + message: Prims.string ; + range: FStarC_Compiler_Range_Type.range } +let (__proj__Mkerror_message__item__message : error_message -> Prims.string) + = fun projectee -> match projectee with | { message; range;_} -> message +let (__proj__Mkerror_message__item__range : + error_message -> FStarC_Compiler_Range_Type.range) = + fun projectee -> match projectee with | { message; range;_} -> range +type extension_parser = + { + parse_decl_name: + Prims.string -> + FStarC_Compiler_Range_Type.range -> + (error_message, FStarC_Ident.ident) FStar_Pervasives.either + ; + parse_decl: + open_namespaces_and_abbreviations -> + Prims.string -> + FStarC_Compiler_Range_Type.range -> + (error_message, FStarC_Parser_AST.decl) FStar_Pervasives.either + } +let (__proj__Mkextension_parser__item__parse_decl_name : + extension_parser -> + Prims.string -> + FStarC_Compiler_Range_Type.range -> + (error_message, FStarC_Ident.ident) FStar_Pervasives.either) + = + fun projectee -> + match projectee with + | { parse_decl_name; parse_decl;_} -> parse_decl_name +let (__proj__Mkextension_parser__item__parse_decl : + extension_parser -> + open_namespaces_and_abbreviations -> + Prims.string -> + FStarC_Compiler_Range_Type.range -> + (error_message, FStarC_Parser_AST.decl) FStar_Pervasives.either) + = + fun projectee -> + match projectee with | { parse_decl_name; parse_decl;_} -> parse_decl +let (extension_parser_table : extension_parser FStarC_Compiler_Util.smap) = + FStarC_Compiler_Util.smap_create (Prims.of_int (20)) +let (register_extension_parser : Prims.string -> extension_parser -> unit) = + fun ext -> + fun parser -> + FStarC_Compiler_Util.smap_add extension_parser_table ext parser +let (lookup_extension_parser : + Prims.string -> extension_parser FStar_Pervasives_Native.option) = + fun ext -> + let do1 uu___ = + FStarC_Compiler_Util.smap_try_find extension_parser_table ext in + let uu___ = do1 () in + match uu___ with + | FStar_Pervasives_Native.None -> + let uu___1 = FStarC_Compiler_Plugins.autoload_plugin ext in + if uu___1 then do1 () else FStar_Pervasives_Native.None + | r -> r +type extension_lang_parser = + { + parse_decls: + Prims.string -> + FStarC_Compiler_Range_Type.range -> + (error_message, FStarC_Parser_AST.decl Prims.list) + FStar_Pervasives.either + } +let (__proj__Mkextension_lang_parser__item__parse_decls : + extension_lang_parser -> + Prims.string -> + FStarC_Compiler_Range_Type.range -> + (error_message, FStarC_Parser_AST.decl Prims.list) + FStar_Pervasives.either) + = fun projectee -> match projectee with | { parse_decls;_} -> parse_decls +let (as_open_namespaces_and_abbrevs : + FStarC_Parser_AST.decl Prims.list -> open_namespaces_and_abbreviations) = + fun ls -> + FStarC_Compiler_List.fold_right + (fun d -> + fun out -> + match d.FStarC_Parser_AST.d with + | FStarC_Parser_AST.Open (lid, uu___) -> + { + open_namespaces = (lid :: (out.open_namespaces)); + module_abbreviations = (out.module_abbreviations) + } + | FStarC_Parser_AST.ModuleAbbrev (i, lid) -> + { + open_namespaces = (out.open_namespaces); + module_abbreviations = ((i, lid) :: + (out.module_abbreviations)) + } + | uu___ -> out) ls + { open_namespaces = []; module_abbreviations = [] } +let (extension_lang_parser_table : + extension_lang_parser FStarC_Compiler_Util.smap) = + FStarC_Compiler_Util.smap_create (Prims.of_int (20)) +let (register_extension_lang_parser : + Prims.string -> extension_lang_parser -> unit) = + fun ext -> + fun parser -> + FStarC_Compiler_Util.smap_add extension_lang_parser_table ext parser +let (lookup_extension_lang_parser : + Prims.string -> extension_lang_parser FStar_Pervasives_Native.option) = + fun ext -> + let r = + FStarC_Compiler_Util.smap_try_find extension_lang_parser_table ext in + match r with + | FStar_Pervasives_Native.None -> + let uu___ = FStarC_Compiler_Plugins.autoload_plugin ext in + if uu___ + then + FStarC_Compiler_Util.smap_try_find extension_lang_parser_table ext + else FStar_Pervasives_Native.None + | uu___ -> r +let (parse_extension_lang : + Prims.string -> + Prims.string -> + FStarC_Compiler_Range_Type.range -> FStarC_Parser_AST.decl Prims.list) + = + fun lang_name -> + fun raw_text -> + fun raw_text_pos -> + let extension_parser1 = lookup_extension_lang_parser lang_name in + match extension_parser1 with + | FStar_Pervasives_Native.None -> + let uu___ = + FStarC_Compiler_Util.format1 "Unknown language extension %s" + lang_name in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range + raw_text_pos FStarC_Errors_Codes.Fatal_SyntaxError () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___) + | FStar_Pervasives_Native.Some parser -> + let uu___ = parser.parse_decls raw_text raw_text_pos in + (match uu___ with + | FStar_Pervasives.Inl error -> + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range error.range + FStarC_Errors_Codes.Fatal_SyntaxError () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic error.message) + | FStar_Pervasives.Inr ds -> ds) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Parser_Const.ml b/ocaml/fstar-lib/generated/FStarC_Parser_Const.ml new file mode 100644 index 00000000000..fccd08dcf26 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Parser_Const.ml @@ -0,0 +1,681 @@ +open Prims +let (p2l : FStarC_Ident.path -> FStarC_Ident.lident) = + fun l -> FStarC_Ident.lid_of_path l FStarC_Compiler_Range_Type.dummyRange +let (pconst : Prims.string -> FStarC_Ident.lident) = + fun s -> p2l ["Prims"; s] +let (psconst : Prims.string -> FStarC_Ident.lident) = + fun s -> p2l ["FStar"; "Pervasives"; s] +let (psnconst : Prims.string -> FStarC_Ident.lident) = + fun s -> p2l ["FStar"; "Pervasives"; "Native"; s] +let (prims_lid : FStarC_Ident.lident) = p2l ["Prims"] +let (pervasives_native_lid : FStarC_Ident.lident) = + p2l ["FStar"; "Pervasives"; "Native"] +let (pervasives_lid : FStarC_Ident.lident) = p2l ["FStar"; "Pervasives"] +let (fstar_ns_lid : FStarC_Ident.lident) = p2l ["FStar"] +let (bool_lid : FStarC_Ident.lident) = pconst "bool" +let (unit_lid : FStarC_Ident.lident) = pconst "unit" +let (squash_lid : FStarC_Ident.lident) = pconst "squash" +let (auto_squash_lid : FStarC_Ident.lident) = pconst "auto_squash" +let (string_lid : FStarC_Ident.lident) = pconst "string" +let (bytes_lid : FStarC_Ident.lident) = pconst "bytes" +let (int_lid : FStarC_Ident.lident) = pconst "int" +let (exn_lid : FStarC_Ident.lident) = pconst "exn" +let (list_lid : FStarC_Ident.lident) = pconst "list" +let (immutable_array_t_lid : FStarC_Ident.lident) = + p2l ["FStar"; "ImmutableArray"; "Base"; "t"] +let (immutable_array_of_list_lid : FStarC_Ident.lident) = + p2l ["FStar"; "ImmutableArray"; "Base"; "of_list"] +let (immutable_array_length_lid : FStarC_Ident.lident) = + p2l ["FStar"; "ImmutableArray"; "Base"; "length"] +let (immutable_array_index_lid : FStarC_Ident.lident) = + p2l ["FStar"; "ImmutableArray"; "Base"; "index"] +let (eqtype_lid : FStarC_Ident.lident) = pconst "eqtype" +let (option_lid : FStarC_Ident.lident) = psnconst "option" +let (either_lid : FStarC_Ident.lident) = psconst "either" +let (pattern_lid : FStarC_Ident.lident) = psconst "pattern" +let (lex_t_lid : FStarC_Ident.lident) = pconst "lex_t" +let (precedes_lid : FStarC_Ident.lident) = pconst "precedes" +let (smtpat_lid : FStarC_Ident.lident) = psconst "smt_pat" +let (smtpatOr_lid : FStarC_Ident.lident) = psconst "smt_pat_or" +let (monadic_lid : FStarC_Ident.lident) = pconst "M" +let (spinoff_lid : FStarC_Ident.lident) = psconst "spinoff" +let (inl_lid : FStarC_Ident.lident) = psconst "Inl" +let (inr_lid : FStarC_Ident.lident) = psconst "Inr" +let (int8_lid : FStarC_Ident.lident) = p2l ["FStar"; "Int8"; "t"] +let (uint8_lid : FStarC_Ident.lident) = p2l ["FStar"; "UInt8"; "t"] +let (int16_lid : FStarC_Ident.lident) = p2l ["FStar"; "Int16"; "t"] +let (uint16_lid : FStarC_Ident.lident) = p2l ["FStar"; "UInt16"; "t"] +let (int32_lid : FStarC_Ident.lident) = p2l ["FStar"; "Int32"; "t"] +let (uint32_lid : FStarC_Ident.lident) = p2l ["FStar"; "UInt32"; "t"] +let (int64_lid : FStarC_Ident.lident) = p2l ["FStar"; "Int64"; "t"] +let (uint64_lid : FStarC_Ident.lident) = p2l ["FStar"; "UInt64"; "t"] +let (sizet_lid : FStarC_Ident.lident) = p2l ["FStar"; "SizeT"; "t"] +let (salloc_lid : FStarC_Ident.lident) = p2l ["FStar"; "ST"; "salloc"] +let (swrite_lid : FStarC_Ident.lident) = + p2l ["FStar"; "ST"; "op_Colon_Equals"] +let (sread_lid : FStarC_Ident.lident) = p2l ["FStar"; "ST"; "op_Bang"] +let (max_lid : FStarC_Ident.lident) = p2l ["max"] +let (real_lid : FStarC_Ident.lident) = p2l ["FStar"; "Real"; "real"] +let (float_lid : FStarC_Ident.lident) = p2l ["FStar"; "Float"; "float"] +let (char_lid : FStarC_Ident.lident) = p2l ["FStar"; "Char"; "char"] +let (heap_lid : FStarC_Ident.lident) = p2l ["FStar"; "Heap"; "heap"] +let (logical_lid : FStarC_Ident.lident) = pconst "logical" +let (prop_lid : FStarC_Ident.lident) = pconst "prop" +let (smt_theory_symbol_attr_lid : FStarC_Ident.lident) = + pconst "smt_theory_symbol" +let (true_lid : FStarC_Ident.lident) = pconst "l_True" +let (false_lid : FStarC_Ident.lident) = pconst "l_False" +let (and_lid : FStarC_Ident.lident) = pconst "l_and" +let (or_lid : FStarC_Ident.lident) = pconst "l_or" +let (not_lid : FStarC_Ident.lident) = pconst "l_not" +let (imp_lid : FStarC_Ident.lident) = pconst "l_imp" +let (iff_lid : FStarC_Ident.lident) = pconst "l_iff" +let (ite_lid : FStarC_Ident.lident) = pconst "l_ITE" +let (exists_lid : FStarC_Ident.lident) = pconst "l_Exists" +let (forall_lid : FStarC_Ident.lident) = pconst "l_Forall" +let (haseq_lid : FStarC_Ident.lident) = pconst "hasEq" +let (b2t_lid : FStarC_Ident.lident) = pconst "b2t" +let (admit_lid : FStarC_Ident.lident) = pconst "admit" +let (magic_lid : FStarC_Ident.lident) = pconst "magic" +let (has_type_lid : FStarC_Ident.lident) = pconst "has_type" +let (c_true_lid : FStarC_Ident.lident) = pconst "trivial" +let (empty_type_lid : FStarC_Ident.lident) = pconst "empty" +let (c_and_lid : FStarC_Ident.lident) = pconst "pair" +let (c_or_lid : FStarC_Ident.lident) = pconst "sum" +let (dtuple2_lid : FStarC_Ident.lident) = pconst "dtuple2" +let (eq2_lid : FStarC_Ident.lident) = pconst "eq2" +let (eq3_lid : FStarC_Ident.lident) = pconst "op_Equals_Equals_Equals" +let (c_eq2_lid : FStarC_Ident.lident) = pconst "equals" +let (cons_lid : FStarC_Ident.lident) = pconst "Cons" +let (nil_lid : FStarC_Ident.lident) = pconst "Nil" +let (some_lid : FStarC_Ident.lident) = psnconst "Some" +let (none_lid : FStarC_Ident.lident) = psnconst "None" +let (assume_lid : FStarC_Ident.lident) = pconst "_assume" +let (assert_lid : FStarC_Ident.lident) = pconst "_assert" +let (pure_wp_lid : FStarC_Ident.lident) = pconst "pure_wp" +let (pure_wp_monotonic_lid : FStarC_Ident.lident) = + pconst "pure_wp_monotonic" +let (pure_wp_monotonic0_lid : FStarC_Ident.lident) = + pconst "pure_wp_monotonic0" +let (trivial_pure_post_lid : FStarC_Ident.lident) = + psconst "trivial_pure_post" +let (pure_assert_wp_lid : FStarC_Ident.lident) = pconst "pure_assert_wp0" +let (pure_assume_wp_lid : FStarC_Ident.lident) = pconst "pure_assume_wp0" +let (assert_norm_lid : FStarC_Ident.lident) = + p2l ["FStar"; "Pervasives"; "assert_norm"] +let (list_append_lid : FStarC_Ident.lident) = p2l ["FStar"; "List"; "append"] +let (list_tot_append_lid : FStarC_Ident.lident) = + p2l ["FStar"; "List"; "Tot"; "Base"; "append"] +let (id_lid : FStarC_Ident.lident) = psconst "id" +let (seq_cons_lid : FStarC_Ident.lident) = + p2l ["FStar"; "Seq"; "Base"; "cons"] +let (seq_empty_lid : FStarC_Ident.lident) = + p2l ["FStar"; "Seq"; "Base"; "empty"] +let (c2l : Prims.string -> FStarC_Ident.lident) = + fun s -> p2l ["FStar"; "Char"; s] +let (char_u32_of_char : FStarC_Ident.lident) = c2l "u32_of_char" +let (s2l : Prims.string -> FStarC_Ident.lident) = + fun n -> p2l ["FStar"; "String"; n] +let (string_list_of_string_lid : FStarC_Ident.lident) = s2l "list_of_string" +let (string_string_of_list_lid : FStarC_Ident.lident) = s2l "string_of_list" +let (string_make_lid : FStarC_Ident.lident) = s2l "make" +let (string_split_lid : FStarC_Ident.lident) = s2l "split" +let (string_concat_lid : FStarC_Ident.lident) = s2l "concat" +let (string_compare_lid : FStarC_Ident.lident) = s2l "compare" +let (string_lowercase_lid : FStarC_Ident.lident) = s2l "lowercase" +let (string_uppercase_lid : FStarC_Ident.lident) = s2l "uppercase" +let (string_index_lid : FStarC_Ident.lident) = s2l "index" +let (string_index_of_lid : FStarC_Ident.lident) = s2l "index_of" +let (string_sub_lid : FStarC_Ident.lident) = s2l "sub" +let (prims_strcat_lid : FStarC_Ident.lident) = pconst "strcat" +let (prims_op_Hat_lid : FStarC_Ident.lident) = pconst "op_Hat" +let (let_in_typ : FStarC_Ident.lident) = p2l ["Prims"; "Let"] +let (string_of_int_lid : FStarC_Ident.lident) = + p2l ["Prims"; "string_of_int"] +let (string_of_bool_lid : FStarC_Ident.lident) = + p2l ["Prims"; "string_of_bool"] +let (int_of_string_lid : FStarC_Ident.lident) = + p2l ["FStar"; "Parse"; "int_of_string"] +let (bool_of_string_lid : FStarC_Ident.lident) = + p2l ["FStar"; "Parse"; "bool_of_string"] +let (string_compare : FStarC_Ident.lident) = + p2l ["FStar"; "String"; "compare"] +let (order_lid : FStarC_Ident.lident) = p2l ["FStar"; "Order"; "order"] +let (vconfig_lid : FStarC_Ident.lident) = + p2l ["FStar"; "Stubs"; "VConfig"; "vconfig"] +let (mkvconfig_lid : FStarC_Ident.lident) = + p2l ["FStar"; "Stubs"; "VConfig"; "Mkvconfig"] +let (op_Eq : FStarC_Ident.lident) = pconst "op_Equality" +let (op_notEq : FStarC_Ident.lident) = pconst "op_disEquality" +let (op_LT : FStarC_Ident.lident) = pconst "op_LessThan" +let (op_LTE : FStarC_Ident.lident) = pconst "op_LessThanOrEqual" +let (op_GT : FStarC_Ident.lident) = pconst "op_GreaterThan" +let (op_GTE : FStarC_Ident.lident) = pconst "op_GreaterThanOrEqual" +let (op_Subtraction : FStarC_Ident.lident) = pconst "op_Subtraction" +let (op_Minus : FStarC_Ident.lident) = pconst "op_Minus" +let (op_Addition : FStarC_Ident.lident) = pconst "op_Addition" +let (op_Multiply : FStarC_Ident.lident) = pconst "op_Multiply" +let (op_Division : FStarC_Ident.lident) = pconst "op_Division" +let (op_Modulus : FStarC_Ident.lident) = pconst "op_Modulus" +let (op_And : FStarC_Ident.lident) = pconst "op_AmpAmp" +let (op_Or : FStarC_Ident.lident) = pconst "op_BarBar" +let (op_Negation : FStarC_Ident.lident) = pconst "op_Negation" +let (subtype_of_lid : FStarC_Ident.lident) = pconst "subtype_of" +let (real_const : Prims.string -> FStarC_Ident.lident) = + fun s -> p2l ["FStar"; "Real"; s] +let (real_op_LT : FStarC_Ident.lident) = real_const "op_Less_Dot" +let (real_op_LTE : FStarC_Ident.lident) = real_const "op_Less_Equals_Dot" +let (real_op_GT : FStarC_Ident.lident) = real_const "op_Greater_Dot" +let (real_op_GTE : FStarC_Ident.lident) = real_const "op_Greater_Equals_Dot" +let (real_op_Subtraction : FStarC_Ident.lident) = + real_const "op_Subtraction_Dot" +let (real_op_Addition : FStarC_Ident.lident) = real_const "op_Plus_Dot" +let (real_op_Multiply : FStarC_Ident.lident) = real_const "op_Star_Dot" +let (real_op_Division : FStarC_Ident.lident) = real_const "op_Slash_Dot" +let (real_of_int : FStarC_Ident.lident) = real_const "of_int" +let (bvconst : Prims.string -> FStarC_Ident.lident) = + fun s -> p2l ["FStar"; "BV"; s] +let (bv_t_lid : FStarC_Ident.lident) = bvconst "bv_t" +let (nat_to_bv_lid : FStarC_Ident.lident) = bvconst "int2bv" +let (bv_to_nat_lid : FStarC_Ident.lident) = bvconst "bv2int" +let (bv_and_lid : FStarC_Ident.lident) = bvconst "bvand" +let (bv_xor_lid : FStarC_Ident.lident) = bvconst "bvxor" +let (bv_or_lid : FStarC_Ident.lident) = bvconst "bvor" +let (bv_add_lid : FStarC_Ident.lident) = bvconst "bvadd" +let (bv_sub_lid : FStarC_Ident.lident) = bvconst "bvsub" +let (bv_shift_left_lid : FStarC_Ident.lident) = bvconst "bvshl" +let (bv_shift_right_lid : FStarC_Ident.lident) = bvconst "bvshr" +let (bv_udiv_lid : FStarC_Ident.lident) = bvconst "bvdiv" +let (bv_mod_lid : FStarC_Ident.lident) = bvconst "bvmod" +let (bv_mul_lid : FStarC_Ident.lident) = bvconst "bvmul" +let (bv_shift_left'_lid : FStarC_Ident.lident) = bvconst "bvshl'" +let (bv_shift_right'_lid : FStarC_Ident.lident) = bvconst "bvshr'" +let (bv_udiv_unsafe_lid : FStarC_Ident.lident) = bvconst "bvdiv_unsafe" +let (bv_mod_unsafe_lid : FStarC_Ident.lident) = bvconst "bvmod_unsafe" +let (bv_mul'_lid : FStarC_Ident.lident) = bvconst "bvmul'" +let (bv_ult_lid : FStarC_Ident.lident) = bvconst "bvult" +let (bv_uext_lid : FStarC_Ident.lident) = bvconst "bv_uext" +let (array_lid : FStarC_Ident.lident) = p2l ["FStar"; "Array"; "array"] +let (array_of_list_lid : FStarC_Ident.lident) = + p2l ["FStar"; "Array"; "of_list"] +let (st_lid : FStarC_Ident.lident) = p2l ["FStar"; "ST"] +let (write_lid : FStarC_Ident.lident) = p2l ["FStar"; "ST"; "write"] +let (read_lid : FStarC_Ident.lident) = p2l ["FStar"; "ST"; "read"] +let (alloc_lid : FStarC_Ident.lident) = p2l ["FStar"; "ST"; "alloc"] +let (op_ColonEq : FStarC_Ident.lident) = + p2l ["FStar"; "ST"; "op_Colon_Equals"] +let (ref_lid : FStarC_Ident.lident) = p2l ["FStar"; "Heap"; "ref"] +let (heap_addr_of_lid : FStarC_Ident.lident) = + p2l ["FStar"; "Heap"; "addr_of"] +let (set_empty : FStarC_Ident.lident) = p2l ["FStar"; "Set"; "empty"] +let (set_singleton : FStarC_Ident.lident) = p2l ["FStar"; "Set"; "singleton"] +let (set_union : FStarC_Ident.lident) = p2l ["FStar"; "Set"; "union"] +let (fstar_hyperheap_lid : FStarC_Ident.lident) = p2l ["FStar"; "HyperHeap"] +let (rref_lid : FStarC_Ident.lident) = p2l ["FStar"; "HyperHeap"; "rref"] +let (erased_lid : FStarC_Ident.lident) = p2l ["FStar"; "Ghost"; "erased"] +let (effect_PURE_lid : FStarC_Ident.lident) = pconst "PURE" +let (effect_Pure_lid : FStarC_Ident.lident) = pconst "Pure" +let (effect_Tot_lid : FStarC_Ident.lident) = pconst "Tot" +let (effect_Lemma_lid : FStarC_Ident.lident) = psconst "Lemma" +let (effect_GTot_lid : FStarC_Ident.lident) = pconst "GTot" +let (effect_GHOST_lid : FStarC_Ident.lident) = pconst "GHOST" +let (effect_Ghost_lid : FStarC_Ident.lident) = pconst "Ghost" +let (effect_DIV_lid : FStarC_Ident.lident) = psconst "DIV" +let (effect_Div_lid : FStarC_Ident.lident) = psconst "Div" +let (effect_Dv_lid : FStarC_Ident.lident) = psconst "Dv" +let (ef_base : unit -> Prims.string Prims.list) = + fun uu___ -> + let uu___1 = FStarC_Options.ml_ish () in + if uu___1 + then + let uu___2 = FStarC_Options.ml_ish_effect () in + FStar_String.split [46] uu___2 + else ["FStar"; "All"] +let (effect_ALL_lid : unit -> FStarC_Ident.lident) = + fun uu___ -> + let uu___1 = + let uu___2 = ef_base () in FStarC_Compiler_List.op_At uu___2 ["ALL"] in + p2l uu___1 +let (effect_ML_lid : unit -> FStarC_Ident.lident) = + fun uu___ -> + let uu___1 = + let uu___2 = ef_base () in FStarC_Compiler_List.op_At uu___2 ["ML"] in + p2l uu___1 +let (failwith_lid : unit -> FStarC_Ident.lident) = + fun uu___ -> + let uu___1 = + let uu___2 = ef_base () in + FStarC_Compiler_List.op_At uu___2 ["failwith"] in + p2l uu___1 +let (try_with_lid : unit -> FStarC_Ident.lident) = + fun uu___ -> + let uu___1 = + let uu___2 = ef_base () in + FStarC_Compiler_List.op_At uu___2 ["try_with"] in + p2l uu___1 +let (as_requires : FStarC_Ident.lident) = pconst "as_requires" +let (as_ensures : FStarC_Ident.lident) = pconst "as_ensures" +let (decreases_lid : FStarC_Ident.lident) = pconst "decreases" +let (reveal : FStarC_Ident.lident) = p2l ["FStar"; "Ghost"; "reveal"] +let (hide : FStarC_Ident.lident) = p2l ["FStar"; "Ghost"; "hide"] +let (labeled_lid : FStarC_Ident.lident) = p2l ["FStar"; "Range"; "labeled"] +let (__range_lid : FStarC_Ident.lident) = p2l ["FStar"; "Range"; "__range"] +let (range_lid : FStarC_Ident.lident) = p2l ["FStar"; "Range"; "range"] +let (range_0 : FStarC_Ident.lident) = p2l ["FStar"; "Range"; "range_0"] +let (mk_range_lid : FStarC_Ident.lident) = p2l ["FStar"; "Range"; "mk_range"] +let (__mk_range_lid : FStarC_Ident.lident) = + p2l ["FStar"; "Range"; "__mk_range"] +let (__explode_range_lid : FStarC_Ident.lident) = + p2l ["FStar"; "Range"; "explode"] +let (join_range_lid : FStarC_Ident.lident) = + p2l ["FStar"; "Range"; "join_range"] +let (guard_free : FStarC_Ident.lident) = pconst "guard_free" +let (inversion_lid : FStarC_Ident.lident) = + p2l ["FStar"; "Pervasives"; "inversion"] +let (normalize : FStarC_Ident.lident) = psconst "normalize" +let (normalize_term : FStarC_Ident.lident) = psconst "normalize_term" +let (norm : FStarC_Ident.lident) = psconst "norm" +let (steps_simpl : FStarC_Ident.lident) = psconst "simplify" +let (steps_weak : FStarC_Ident.lident) = psconst "weak" +let (steps_hnf : FStarC_Ident.lident) = psconst "hnf" +let (steps_primops : FStarC_Ident.lident) = psconst "primops" +let (steps_zeta : FStarC_Ident.lident) = psconst "zeta" +let (steps_zeta_full : FStarC_Ident.lident) = psconst "zeta_full" +let (steps_iota : FStarC_Ident.lident) = psconst "iota" +let (steps_delta : FStarC_Ident.lident) = psconst "delta" +let (steps_reify : FStarC_Ident.lident) = psconst "reify_" +let (steps_norm_debug : FStarC_Ident.lident) = psconst "norm_debug" +let (steps_unfoldonly : FStarC_Ident.lident) = psconst "delta_only" +let (steps_unfoldfully : FStarC_Ident.lident) = psconst "delta_fully" +let (steps_unfoldattr : FStarC_Ident.lident) = psconst "delta_attr" +let (steps_unfoldqual : FStarC_Ident.lident) = psconst "delta_qualifier" +let (steps_unfoldnamespace : FStarC_Ident.lident) = psconst "delta_namespace" +let (steps_unascribe : FStarC_Ident.lident) = psconst "unascribe" +let (steps_nbe : FStarC_Ident.lident) = psconst "nbe" +let (steps_unmeta : FStarC_Ident.lident) = psconst "unmeta" +let (deprecated_attr : FStarC_Ident.lident) = pconst "deprecated" +let (warn_on_use_attr : FStarC_Ident.lident) = pconst "warn_on_use" +let (inline_let_attr : FStarC_Ident.lident) = + p2l ["FStar"; "Pervasives"; "inline_let"] +let (rename_let_attr : FStarC_Ident.lident) = + p2l ["FStar"; "Pervasives"; "rename_let"] +let (plugin_attr : FStarC_Ident.lident) = + p2l ["FStar"; "Pervasives"; "plugin"] +let (tcnorm_attr : FStarC_Ident.lident) = + p2l ["FStar"; "Pervasives"; "tcnorm"] +let (dm4f_bind_range_attr : FStarC_Ident.lident) = + p2l ["FStar"; "Pervasives"; "dm4f_bind_range"] +let (must_erase_for_extraction_attr : FStarC_Ident.lident) = + psconst "must_erase_for_extraction" +let (strict_on_arguments_attr : FStarC_Ident.lident) = + p2l ["FStar"; "Pervasives"; "strict_on_arguments"] +let (resolve_implicits_attr_string : Prims.string) = + "FStar.Pervasives.resolve_implicits" +let (unification_tag_lid : FStarC_Ident.lident) = psconst "defer_to" +let (override_resolve_implicits_handler_lid : FStarC_Ident.lident) = + p2l ["FStar"; "Pervasives"; "override_resolve_implicits_handler"] +let (handle_smt_goals_attr : FStarC_Ident.lident) = + psconst "handle_smt_goals" +let (handle_smt_goals_attr_string : Prims.string) = + "FStar.Pervasives.handle_smt_goals" +let (erasable_attr : FStarC_Ident.lident) = + p2l ["FStar"; "Pervasives"; "erasable"] +let (comment_attr : FStarC_Ident.lident) = + p2l ["FStar"; "Pervasives"; "Comment"] +let (c_inline_attr : FStarC_Ident.lident) = + p2l ["FStar"; "Pervasives"; "CInline"] +let (fail_attr : FStarC_Ident.lident) = psconst "expect_failure" +let (fail_lax_attr : FStarC_Ident.lident) = psconst "expect_lax_failure" +let (tcdecltime_attr : FStarC_Ident.lident) = psconst "tcdecltime" +let (noextract_to_attr : FStarC_Ident.lident) = psconst "noextract_to" +let (unifier_hint_injective_lid : FStarC_Ident.lident) = + psconst "unifier_hint_injective" +let (normalize_for_extraction_lid : FStarC_Ident.lident) = + psconst "normalize_for_extraction" +let (commute_nested_matches_lid : FStarC_Ident.lident) = + psconst "commute_nested_matches" +let (remove_unused_type_parameters_lid : FStarC_Ident.lident) = + psconst "remove_unused_type_parameters" +let (ite_soundness_by_attr : FStarC_Ident.lident) = + psconst "ite_soundness_by" +let (default_effect_attr : FStarC_Ident.lident) = psconst "default_effect" +let (top_level_effect_attr : FStarC_Ident.lident) = + psconst "top_level_effect" +let (effect_parameter_attr : FStarC_Ident.lident) = psconst "effect_param" +let (bind_has_range_args_attr : FStarC_Ident.lident) = + psconst "bind_has_range_args" +let (primitive_extraction_attr : FStarC_Ident.lident) = + psconst "primitive_extraction" +let (binder_strictly_positive_attr : FStarC_Ident.lident) = + psconst "strictly_positive" +let (binder_unused_attr : FStarC_Ident.lident) = psconst "unused" +let (no_auto_projectors_decls_attr : FStarC_Ident.lident) = + psconst "no_auto_projectors_decls" +let (no_auto_projectors_attr : FStarC_Ident.lident) = + psconst "no_auto_projectors" +let (no_subtping_attr_lid : FStarC_Ident.lident) = psconst "no_subtyping" +let (admit_termination_lid : FStarC_Ident.lident) = + psconst "admit_termination" +let (unrefine_binder_attr : FStarC_Ident.lident) = pconst "unrefine" +let (do_not_unrefine_attr : FStarC_Ident.lident) = pconst "do_not_unrefine" +let (attr_substitute_lid : FStarC_Ident.lident) = + p2l ["FStar"; "Pervasives"; "Substitute"] +let (desugar_of_variant_record_lid : FStarC_Ident.lident) = + psconst "desugar_of_variant_record" +let (well_founded_relation_lid : FStarC_Ident.lident) = + p2l ["FStar"; "WellFounded"; "well_founded_relation"] +let (gen_reset : ((unit -> Prims.int) * (unit -> unit))) = + let x = FStarC_Compiler_Util.mk_ref Prims.int_zero in + let gen uu___ = FStarC_Compiler_Util.incr x; FStarC_Compiler_Util.read x in + let reset uu___ = FStarC_Compiler_Util.write x Prims.int_zero in + (gen, reset) +let (next_id : unit -> Prims.int) = FStar_Pervasives_Native.fst gen_reset +let (sli : FStarC_Ident.lident -> Prims.string) = + fun l -> + let uu___ = FStarC_Options.print_real_names () in + if uu___ + then FStarC_Ident.string_of_lid l + else + (let uu___2 = FStarC_Ident.ident_of_lid l in + FStarC_Ident.string_of_id uu___2) +let (const_to_string : FStarC_Const.sconst -> Prims.string) = + fun x -> + match x with + | FStarC_Const.Const_effect -> "Effect" + | FStarC_Const.Const_unit -> "()" + | FStarC_Const.Const_bool b -> if b then "true" else "false" + | FStarC_Const.Const_real r -> Prims.strcat r "R" + | FStarC_Const.Const_string (s, uu___) -> + FStarC_Compiler_Util.format1 "\"%s\"" s + | FStarC_Const.Const_int (x1, uu___) -> x1 + | FStarC_Const.Const_char c -> + Prims.strcat "'" + (Prims.strcat (FStarC_Compiler_Util.string_of_char c) "'") + | FStarC_Const.Const_range r -> + FStarC_Compiler_Range_Ops.string_of_range r + | FStarC_Const.Const_range_of -> "range_of" + | FStarC_Const.Const_set_range_of -> "set_range_of" + | FStarC_Const.Const_reify lopt -> + let uu___ = + match lopt with + | FStar_Pervasives_Native.None -> "" + | FStar_Pervasives_Native.Some l -> + let uu___1 = FStarC_Ident.string_of_lid l in + FStarC_Compiler_Util.format1 "<%s>" uu___1 in + FStarC_Compiler_Util.format1 "reify%s" uu___ + | FStarC_Const.Const_reflect l -> + let uu___ = sli l in + FStarC_Compiler_Util.format1 "[[%s.reflect]]" uu___ +let (mk_tuple_lid : + Prims.int -> FStarC_Compiler_Range_Type.range -> FStarC_Ident.lident) = + fun n -> + fun r -> + let t = + let uu___ = FStarC_Compiler_Util.string_of_int n in + FStarC_Compiler_Util.format1 "tuple%s" uu___ in + let uu___ = psnconst t in FStarC_Ident.set_lid_range uu___ r +let (lid_tuple2 : FStarC_Ident.lident) = + mk_tuple_lid (Prims.of_int (2)) FStarC_Compiler_Range_Type.dummyRange +let (lid_tuple3 : FStarC_Ident.lident) = + mk_tuple_lid (Prims.of_int (3)) FStarC_Compiler_Range_Type.dummyRange +let (lid_tuple4 : FStarC_Ident.lident) = + mk_tuple_lid (Prims.of_int (4)) FStarC_Compiler_Range_Type.dummyRange +let (lid_tuple5 : FStarC_Ident.lident) = + mk_tuple_lid (Prims.of_int (5)) FStarC_Compiler_Range_Type.dummyRange +let (is_tuple_constructor_string : Prims.string -> Prims.bool) = + fun s -> FStarC_Compiler_Util.starts_with s "FStar.Pervasives.Native.tuple" +let (is_tuple_constructor_id : FStarC_Ident.ident -> Prims.bool) = + fun id -> + let uu___ = FStarC_Ident.string_of_id id in + is_tuple_constructor_string uu___ +let (is_tuple_constructor_lid : FStarC_Ident.lident -> Prims.bool) = + fun lid -> + let uu___ = FStarC_Ident.string_of_lid lid in + is_tuple_constructor_string uu___ +let (mk_tuple_data_lid : + Prims.int -> FStarC_Compiler_Range_Type.range -> FStarC_Ident.lident) = + fun n -> + fun r -> + let t = + let uu___ = FStarC_Compiler_Util.string_of_int n in + FStarC_Compiler_Util.format1 "Mktuple%s" uu___ in + let uu___ = psnconst t in FStarC_Ident.set_lid_range uu___ r +let (lid_Mktuple2 : FStarC_Ident.lident) = + mk_tuple_data_lid (Prims.of_int (2)) FStarC_Compiler_Range_Type.dummyRange +let (lid_Mktuple3 : FStarC_Ident.lident) = + mk_tuple_data_lid (Prims.of_int (3)) FStarC_Compiler_Range_Type.dummyRange +let (lid_Mktuple4 : FStarC_Ident.lident) = + mk_tuple_data_lid (Prims.of_int (4)) FStarC_Compiler_Range_Type.dummyRange +let (lid_Mktuple5 : FStarC_Ident.lident) = + mk_tuple_data_lid (Prims.of_int (5)) FStarC_Compiler_Range_Type.dummyRange +let (is_tuple_datacon_string : Prims.string -> Prims.bool) = + fun s -> + FStarC_Compiler_Util.starts_with s "FStar.Pervasives.Native.Mktuple" +let (is_tuple_datacon_id : FStarC_Ident.ident -> Prims.bool) = + fun id -> + let uu___ = FStarC_Ident.string_of_id id in is_tuple_datacon_string uu___ +let (is_tuple_datacon_lid : FStarC_Ident.lident -> Prims.bool) = + fun lid -> + let uu___ = FStarC_Ident.string_of_lid lid in + is_tuple_datacon_string uu___ +let (is_tuple_data_lid : FStarC_Ident.lident -> Prims.int -> Prims.bool) = + fun f -> + fun n -> + let uu___ = mk_tuple_data_lid n FStarC_Compiler_Range_Type.dummyRange in + FStarC_Ident.lid_equals f uu___ +let (is_tuple_data_lid' : FStarC_Ident.lident -> Prims.bool) = + fun f -> + let uu___ = FStarC_Ident.string_of_lid f in is_tuple_datacon_string uu___ +let (mod_prefix_dtuple : Prims.int -> Prims.string -> FStarC_Ident.lident) = + fun n -> if n = (Prims.of_int (2)) then pconst else psconst +let (mk_dtuple_lid : + Prims.int -> FStarC_Compiler_Range_Type.range -> FStarC_Ident.lident) = + fun n -> + fun r -> + let t = + let uu___ = FStarC_Compiler_Util.string_of_int n in + FStarC_Compiler_Util.format1 "dtuple%s" uu___ in + let uu___ = let uu___1 = mod_prefix_dtuple n in uu___1 t in + FStarC_Ident.set_lid_range uu___ r +let (is_dtuple_constructor_string : Prims.string -> Prims.bool) = + fun s -> + (s = "Prims.dtuple2") || + (FStarC_Compiler_Util.starts_with s "FStar.Pervasives.dtuple") +let (is_dtuple_constructor_lid : FStarC_Ident.lident -> Prims.bool) = + fun lid -> + let uu___ = FStarC_Ident.string_of_lid lid in + is_dtuple_constructor_string uu___ +let (mk_dtuple_data_lid : + Prims.int -> FStarC_Compiler_Range_Type.range -> FStarC_Ident.lident) = + fun n -> + fun r -> + let t = + let uu___ = FStarC_Compiler_Util.string_of_int n in + FStarC_Compiler_Util.format1 "Mkdtuple%s" uu___ in + let uu___ = let uu___1 = mod_prefix_dtuple n in uu___1 t in + FStarC_Ident.set_lid_range uu___ r +let (is_dtuple_datacon_string : Prims.string -> Prims.bool) = + fun s -> + (s = "Prims.Mkdtuple2") || + (FStarC_Compiler_Util.starts_with s "FStar.Pervasives.Mkdtuple") +let (is_dtuple_data_lid : FStarC_Ident.lident -> Prims.int -> Prims.bool) = + fun f -> + fun n -> + let uu___ = mk_dtuple_data_lid n FStarC_Compiler_Range_Type.dummyRange in + FStarC_Ident.lid_equals f uu___ +let (is_dtuple_data_lid' : FStarC_Ident.lident -> Prims.bool) = + fun f -> + let uu___ = FStarC_Ident.string_of_lid f in + is_dtuple_datacon_string uu___ +let (is_name : FStarC_Ident.lident -> Prims.bool) = + fun lid -> + let c = + let uu___ = + let uu___1 = FStarC_Ident.ident_of_lid lid in + FStarC_Ident.string_of_id uu___1 in + FStarC_Compiler_Util.char_at uu___ Prims.int_zero in + FStarC_Compiler_Util.is_upper c +let (term_view_lid : FStarC_Ident.lident) = + p2l ["FStar"; "Reflection"; "V1"; "Data"; "term_view"] +let (fstar_tactics_lid' : Prims.string Prims.list -> FStarC_Ident.lid) = + fun s -> + FStarC_Ident.lid_of_path + (FStarC_Compiler_List.op_At ["FStar"; "Tactics"] s) + FStarC_Compiler_Range_Type.dummyRange +let (fstar_stubs_tactics_lid' : Prims.string Prims.list -> FStarC_Ident.lid) + = + fun s -> + FStarC_Ident.lid_of_path + (FStarC_Compiler_List.op_At ["FStar"; "Stubs"; "Tactics"] s) + FStarC_Compiler_Range_Type.dummyRange +let (fstar_tactics_lid : Prims.string -> FStarC_Ident.lid) = + fun s -> fstar_tactics_lid' [s] +let (tac_lid : FStarC_Ident.lid) = fstar_tactics_lid' ["Effect"; "tac"] +let (tactic_lid : FStarC_Ident.lid) = fstar_tactics_lid' ["Effect"; "tactic"] +let (tac_opaque_attr : FStarC_Ident.lident) = pconst "tac_opaque" +let (meta_projectors_attr : FStarC_Ident.lid) = + fstar_tactics_lid' ["MkProjectors"; "meta_projectors"] +let (mk_projs_lid : FStarC_Ident.lid) = + fstar_tactics_lid' ["MkProjectors"; "mk_projs"] +let (mk_class_lid : FStarC_Ident.lid) = + fstar_tactics_lid' ["Typeclasses"; "mk_class"] +let (tcresolve_lid : FStarC_Ident.lid) = + fstar_tactics_lid' ["Typeclasses"; "tcresolve"] +let (tcclass_lid : FStarC_Ident.lid) = + fstar_tactics_lid' ["Typeclasses"; "tcclass"] +let (tcinstance_lid : FStarC_Ident.lid) = + fstar_tactics_lid' ["Typeclasses"; "tcinstance"] +let (no_method_lid : FStarC_Ident.lid) = + fstar_tactics_lid' ["Typeclasses"; "no_method"] +let (effect_TAC_lid : FStarC_Ident.lid) = + fstar_tactics_lid' ["Effect"; "TAC"] +let (effect_Tac_lid : FStarC_Ident.lid) = + fstar_tactics_lid' ["Effect"; "Tac"] +let (by_tactic_lid : FStarC_Ident.lid) = + fstar_tactics_lid' ["Effect"; "with_tactic"] +let (rewrite_by_tactic_lid : FStarC_Ident.lid) = + fstar_tactics_lid' ["Effect"; "rewrite_with_tactic"] +let (synth_lid : FStarC_Ident.lid) = + fstar_tactics_lid' ["Effect"; "synth_by_tactic"] +let (assert_by_tactic_lid : FStarC_Ident.lid) = + fstar_tactics_lid' ["Effect"; "assert_by_tactic"] +let (fstar_syntax_syntax_term : FStarC_Ident.lident) = + FStarC_Ident.lid_of_str "FStarC.Syntax.Syntax.term" +let (binder_lid : FStarC_Ident.lident) = + FStarC_Ident.lid_of_path + ["FStar"; "Stubs"; "Reflection"; "Types"; "binder"] + FStarC_Compiler_Range_Type.dummyRange +let (binders_lid : FStarC_Ident.lident) = + FStarC_Ident.lid_of_path + ["FStar"; "Stubs"; "Reflection"; "Types"; "binders"] + FStarC_Compiler_Range_Type.dummyRange +let (bv_lid : FStarC_Ident.lident) = + FStarC_Ident.lid_of_path ["FStar"; "Stubs"; "Reflection"; "Types"; "bv"] + FStarC_Compiler_Range_Type.dummyRange +let (fv_lid : FStarC_Ident.lident) = + FStarC_Ident.lid_of_path ["FStar"; "Stubs"; "Reflection"; "Types"; "fv"] + FStarC_Compiler_Range_Type.dummyRange +let (norm_step_lid : FStarC_Ident.lident) = psconst "norm_step" +let (postprocess_with : FStarC_Ident.lident) = + p2l ["FStar"; "Tactics"; "Effect"; "postprocess_with"] +let (preprocess_with : FStarC_Ident.lident) = + p2l ["FStar"; "Tactics"; "Effect"; "preprocess_with"] +let (postprocess_extr_with : FStarC_Ident.lident) = + p2l ["FStar"; "Tactics"; "Effect"; "postprocess_for_extraction_with"] +let (term_lid : FStarC_Ident.lident) = + p2l ["FStar"; "Stubs"; "Reflection"; "Types"; "term"] +let (ctx_uvar_and_subst_lid : FStarC_Ident.lident) = + p2l ["FStar"; "Stubs"; "Reflection"; "Types"; "ctx_uvar_and_subst"] +let (universe_uvar_lid : FStarC_Ident.lident) = + p2l ["FStar"; "Stubs"; "Reflection"; "Types"; "universe_uvar"] +let (check_with_lid : FStarC_Ident.lident) = + FStarC_Ident.lid_of_path ["FStar"; "Stubs"; "VConfig"; "check_with"] + FStarC_Compiler_Range_Type.dummyRange +let (decls_lid : FStarC_Ident.lident) = + p2l ["FStar"; "Stubs"; "Reflection"; "Types"; "decls"] +let (dsl_typing_builtin : Prims.string -> FStarC_Ident.lident) = + fun s -> + FStarC_Ident.lid_of_path + (FStarC_Compiler_List.op_At + ["FStar"; "Reflection"; "Typing"; "Builtins"] [s]) + FStarC_Compiler_Range_Type.dummyRange +let (dsl_tac_typ_lid : FStarC_Ident.lident) = + FStarC_Ident.lid_of_path ["FStar"; "Reflection"; "Typing"; "dsl_tac_t"] + FStarC_Compiler_Range_Type.dummyRange +let (calc_lid : Prims.string -> FStarC_Ident.lid) = + fun i -> + FStarC_Ident.lid_of_path ["FStar"; "Calc"; i] + FStarC_Compiler_Range_Type.dummyRange +let (calc_init_lid : FStarC_Ident.lid) = calc_lid "calc_init" +let (calc_step_lid : FStarC_Ident.lid) = calc_lid "calc_step" +let (calc_finish_lid : FStarC_Ident.lid) = calc_lid "calc_finish" +let (calc_push_impl_lid : FStarC_Ident.lid) = calc_lid "calc_push_impl" +let (classical_sugar_lid : Prims.string -> FStarC_Ident.lid) = + fun i -> + FStarC_Ident.lid_of_path ["FStar"; "Classical"; "Sugar"; i] + FStarC_Compiler_Range_Type.dummyRange +let (forall_intro_lid : FStarC_Ident.lid) = + classical_sugar_lid "forall_intro" +let (exists_intro_lid : FStarC_Ident.lid) = + classical_sugar_lid "exists_intro" +let (implies_intro_lid : FStarC_Ident.lid) = + classical_sugar_lid "implies_intro" +let (or_intro_left_lid : FStarC_Ident.lid) = + classical_sugar_lid "or_intro_left" +let (or_intro_right_lid : FStarC_Ident.lid) = + classical_sugar_lid "or_intro_right" +let (and_intro_lid : FStarC_Ident.lid) = classical_sugar_lid "and_intro" +let (forall_elim_lid : FStarC_Ident.lid) = classical_sugar_lid "forall_elim" +let (exists_elim_lid : FStarC_Ident.lid) = classical_sugar_lid "exists_elim" +let (implies_elim_lid : FStarC_Ident.lid) = + classical_sugar_lid "implies_elim" +let (or_elim_lid : FStarC_Ident.lid) = classical_sugar_lid "or_elim" +let (and_elim_lid : FStarC_Ident.lid) = classical_sugar_lid "and_elim" +let (match_returns_def_name : Prims.string) = + Prims.strcat FStarC_Ident.reserved_prefix "_ret_" +let (steel_memory_inv_lid : FStarC_Ident.lident) = + FStarC_Ident.lid_of_path ["Steel"; "Memory"; "inv"] + FStarC_Compiler_Range_Type.dummyRange +let (steel_new_invariant_lid : FStarC_Ident.lident) = + FStarC_Ident.lid_of_path ["Steel"; "Effect"; "Atomic"; "new_invariant"] + FStarC_Compiler_Range_Type.dummyRange +let (steel_st_new_invariant_lid : FStarC_Ident.lident) = + FStarC_Ident.lid_of_path ["Steel"; "ST"; "Util"; "new_invariant"] + FStarC_Compiler_Range_Type.dummyRange +let (steel_with_invariant_g_lid : FStarC_Ident.lident) = + FStarC_Ident.lid_of_path ["Steel"; "Effect"; "Atomic"; "with_invariant_g"] + FStarC_Compiler_Range_Type.dummyRange +let (steel_st_with_invariant_g_lid : FStarC_Ident.lident) = + FStarC_Ident.lid_of_path ["Steel"; "ST"; "Util"; "with_invariant_g"] + FStarC_Compiler_Range_Type.dummyRange +let (steel_with_invariant_lid : FStarC_Ident.lident) = + FStarC_Ident.lid_of_path ["Steel"; "Effect"; "Atomic"; "with_invariant"] + FStarC_Compiler_Range_Type.dummyRange +let (steel_st_with_invariant_lid : FStarC_Ident.lident) = + FStarC_Ident.lid_of_path ["Steel"; "ST"; "Util"; "with_invariant"] + FStarC_Compiler_Range_Type.dummyRange +let (fext_lid : Prims.string -> FStarC_Ident.lident) = + fun s -> + FStarC_Ident.lid_of_path ["FStar"; "FunctionalExtensionality"; s] + FStarC_Compiler_Range_Type.dummyRange +let (fext_on_domain_lid : FStarC_Ident.lident) = fext_lid "on_domain" +let (fext_on_dom_lid : FStarC_Ident.lident) = fext_lid "on_dom" +let (fext_on_domain_g_lid : FStarC_Ident.lident) = fext_lid "on_domain_g" +let (fext_on_dom_g_lid : FStarC_Ident.lident) = fext_lid "on_dom_g" +let (sealed_lid : FStarC_Ident.lident) = p2l ["FStar"; "Sealed"; "sealed"] +let (seal_lid : FStarC_Ident.lident) = p2l ["FStar"; "Sealed"; "seal"] +let (unseal_lid : FStarC_Ident.lident) = + p2l ["FStar"; "Tactics"; "Unseal"; "unseal"] +let (map_seal_lid : FStarC_Ident.lident) = + p2l ["FStar"; "Sealed"; "map_seal"] +let (bind_seal_lid : FStarC_Ident.lident) = + p2l ["FStar"; "Sealed"; "bind_seal"] +let (tref_lid : FStarC_Ident.lident) = + p2l ["FStar"; "Stubs"; "Tactics"; "Types"; "tref"] +let (document_lid : FStarC_Ident.lident) = + p2l ["FStar"; "Stubs"; "Pprint"; "document"] +let (issue_lid : FStarC_Ident.lident) = p2l ["FStar"; "Issue"; "issue"] +let (extract_as_lid : FStarC_Ident.lident) = + p2l ["FStar"; "ExtractAs"; "extract_as"] +let (extract_as_impure_effect_lid : FStarC_Ident.lident) = + p2l ["FStar"; "Pervasives"; "extract_as_impure_effect"] \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Parser_Dep.ml b/ocaml/fstar-lib/generated/FStarC_Parser_Dep.ml new file mode 100644 index 00000000000..972cd7ef6eb --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Parser_Dep.ml @@ -0,0 +1,3004 @@ +open Prims +type open_kind = + | Open_module + | Open_namespace +let (uu___is_Open_module : open_kind -> Prims.bool) = + fun projectee -> + match projectee with | Open_module -> true | uu___ -> false +let (uu___is_Open_namespace : open_kind -> Prims.bool) = + fun projectee -> + match projectee with | Open_namespace -> true | uu___ -> false +type module_name = Prims.string +let (dbg : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Dep" +let (dbg_CheckedFiles : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "CheckedFiles" +let profile : 'uuuuu . (unit -> 'uuuuu) -> Prims.string -> 'uuuuu = + fun f -> fun c -> FStarC_Profiling.profile f FStar_Pervasives_Native.None c +let with_file_outchannel : + 'a . Prims.string -> (FStarC_Compiler_Util.out_channel -> 'a) -> 'a = + fun fn -> + fun k -> + let outc = FStarC_Compiler_Util.open_file_for_writing fn in + let r = + try (fun uu___ -> match () with | () -> k outc) () + with + | uu___ -> + (FStarC_Compiler_Util.close_out_channel outc; + FStarC_Compiler_Util.delete_file fn; + FStarC_Compiler_Effect.raise uu___) in + FStarC_Compiler_Util.close_out_channel outc; r +type verify_mode = + | VerifyAll + | VerifyUserList + | VerifyFigureItOut +let (uu___is_VerifyAll : verify_mode -> Prims.bool) = + fun projectee -> match projectee with | VerifyAll -> true | uu___ -> false +let (uu___is_VerifyUserList : verify_mode -> Prims.bool) = + fun projectee -> + match projectee with | VerifyUserList -> true | uu___ -> false +let (uu___is_VerifyFigureItOut : verify_mode -> Prims.bool) = + fun projectee -> + match projectee with | VerifyFigureItOut -> true | uu___ -> false +type intf_and_impl = + (Prims.string FStar_Pervasives_Native.option * Prims.string + FStar_Pervasives_Native.option) +type files_for_module_name = intf_and_impl FStarC_Compiler_Util.smap +let (intf_and_impl_to_string : + (Prims.string FStar_Pervasives_Native.option * Prims.string + FStar_Pervasives_Native.option) -> Prims.string) + = + fun ii -> + match ii with + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> + ", " + | (FStar_Pervasives_Native.Some intf, FStar_Pervasives_Native.None) -> + intf + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.Some impl) -> + impl + | (FStar_Pervasives_Native.Some intf, FStar_Pervasives_Native.Some impl) + -> Prims.strcat intf (Prims.strcat ", " impl) +let (files_for_module_name_to_string : files_for_module_name -> unit) = + fun m -> + FStarC_Compiler_Util.print_string "Printing the file system map {\n"; + (let str_opt_to_string sopt = + match sopt with + | FStar_Pervasives_Native.None -> "" + | FStar_Pervasives_Native.Some s -> s in + FStarC_Compiler_Util.smap_iter m + (fun k -> + fun v -> + FStarC_Compiler_Util.print2 "%s:%s\n" k + (intf_and_impl_to_string v)); + FStarC_Compiler_Util.print_string "}\n") +type color = + | White + | Gray + | Black +let (uu___is_White : color -> Prims.bool) = + fun projectee -> match projectee with | White -> true | uu___ -> false +let (uu___is_Gray : color -> Prims.bool) = + fun projectee -> match projectee with | Gray -> true | uu___ -> false +let (uu___is_Black : color -> Prims.bool) = + fun projectee -> match projectee with | Black -> true | uu___ -> false +let (check_and_strip_suffix : + Prims.string -> Prims.string FStar_Pervasives_Native.option) = + fun f -> + let suffixes = [".fsti"; ".fst"; ".fsi"; ".fs"] in + let matches = + FStarC_Compiler_List.map + (fun ext -> + let lext = FStarC_Compiler_String.length ext in + let l = FStarC_Compiler_String.length f in + let uu___ = + (l > lext) && + (let uu___1 = + FStarC_Compiler_String.substring f (l - lext) lext in + uu___1 = ext) in + if uu___ + then + let uu___1 = + FStarC_Compiler_String.substring f Prims.int_zero (l - lext) in + FStar_Pervasives_Native.Some uu___1 + else FStar_Pervasives_Native.None) suffixes in + let uu___ = + FStarC_Compiler_List.filter FStarC_Compiler_Util.is_some matches in + match uu___ with + | (FStar_Pervasives_Native.Some m)::uu___1 -> + FStar_Pervasives_Native.Some m + | uu___1 -> FStar_Pervasives_Native.None +let (is_interface : Prims.string -> Prims.bool) = + fun f -> + let uu___ = + FStarC_Compiler_String.get f + ((FStarC_Compiler_String.length f) - Prims.int_one) in + uu___ = 105 +let (is_implementation : Prims.string -> Prims.bool) = + fun f -> let uu___ = is_interface f in Prims.op_Negation uu___ +let list_of_option : + 'uuuuu . 'uuuuu FStar_Pervasives_Native.option -> 'uuuuu Prims.list = + fun uu___ -> + match uu___ with + | FStar_Pervasives_Native.Some x -> [x] + | FStar_Pervasives_Native.None -> [] +let list_of_pair : + 'uuuuu . + ('uuuuu FStar_Pervasives_Native.option * 'uuuuu + FStar_Pervasives_Native.option) -> 'uuuuu Prims.list + = + fun uu___ -> + match uu___ with + | (intf, impl) -> + FStarC_Compiler_List.op_At (list_of_option intf) + (list_of_option impl) +let (maybe_module_name_of_file : + Prims.string -> Prims.string FStar_Pervasives_Native.option) = + fun f -> + let uu___ = FStarC_Compiler_Util.basename f in + check_and_strip_suffix uu___ +let (module_name_of_file : Prims.string -> Prims.string) = + fun f -> + let uu___ = maybe_module_name_of_file f in + match uu___ with + | FStar_Pervasives_Native.Some longname -> longname + | FStar_Pervasives_Native.None -> + let uu___1 = + FStarC_Compiler_Util.format1 "Not a valid FStar file: '%s'" f in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_NotValidFStarFile () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) +let (lowercase_module_name : Prims.string -> Prims.string) = + fun f -> + let uu___ = module_name_of_file f in + FStarC_Compiler_String.lowercase uu___ +let (namespace_of_module : + Prims.string -> FStarC_Ident.lident FStar_Pervasives_Native.option) = + fun f -> + let lid = + let uu___ = FStarC_Ident.path_of_text f in + FStarC_Ident.lid_of_path uu___ FStarC_Compiler_Range_Type.dummyRange in + let uu___ = FStarC_Ident.ns_of_lid lid in + match uu___ with + | [] -> FStar_Pervasives_Native.None + | ns -> + let uu___1 = FStarC_Ident.lid_of_ids ns in + FStar_Pervasives_Native.Some uu___1 +type file_name = Prims.string +type dependence = + | UseInterface of module_name + | PreferInterface of module_name + | UseImplementation of module_name + | FriendImplementation of module_name +let (uu___is_UseInterface : dependence -> Prims.bool) = + fun projectee -> + match projectee with | UseInterface _0 -> true | uu___ -> false +let (__proj__UseInterface__item___0 : dependence -> module_name) = + fun projectee -> match projectee with | UseInterface _0 -> _0 +let (uu___is_PreferInterface : dependence -> Prims.bool) = + fun projectee -> + match projectee with | PreferInterface _0 -> true | uu___ -> false +let (__proj__PreferInterface__item___0 : dependence -> module_name) = + fun projectee -> match projectee with | PreferInterface _0 -> _0 +let (uu___is_UseImplementation : dependence -> Prims.bool) = + fun projectee -> + match projectee with | UseImplementation _0 -> true | uu___ -> false +let (__proj__UseImplementation__item___0 : dependence -> module_name) = + fun projectee -> match projectee with | UseImplementation _0 -> _0 +let (uu___is_FriendImplementation : dependence -> Prims.bool) = + fun projectee -> + match projectee with | FriendImplementation _0 -> true | uu___ -> false +let (__proj__FriendImplementation__item___0 : dependence -> module_name) = + fun projectee -> match projectee with | FriendImplementation _0 -> _0 +let (dep_to_string : dependence -> Prims.string) = + fun uu___ -> + match uu___ with + | UseInterface f -> Prims.strcat "UseInterface " f + | PreferInterface f -> Prims.strcat "PreferInterface " f + | UseImplementation f -> Prims.strcat "UseImplementation " f + | FriendImplementation f -> Prims.strcat "FriendImplementation " f +let (showable_dependence : dependence FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = dep_to_string } +type dependences = dependence Prims.list +let empty_dependences : 'uuuuu . unit -> 'uuuuu Prims.list = fun uu___ -> [] +type dep_node = { + edges: dependences ; + color: color } +let (__proj__Mkdep_node__item__edges : dep_node -> dependences) = + fun projectee -> match projectee with | { edges; color = color1;_} -> edges +let (__proj__Mkdep_node__item__color : dep_node -> color) = + fun projectee -> + match projectee with | { edges; color = color1;_} -> color1 +type dependence_graph = + | Deps of dep_node FStarC_Compiler_Util.smap +let (uu___is_Deps : dependence_graph -> Prims.bool) = fun projectee -> true +let (__proj__Deps__item___0 : + dependence_graph -> dep_node FStarC_Compiler_Util.smap) = + fun projectee -> match projectee with | Deps _0 -> _0 +type parsing_data_elt = + | P_begin_module of FStarC_Ident.lident + | P_open of (Prims.bool * FStarC_Ident.lident) + | P_implicit_open_module_or_namespace of (open_kind * FStarC_Ident.lid) + | P_dep of (Prims.bool * FStarC_Ident.lident) + | P_alias of (FStarC_Ident.ident * FStarC_Ident.lident) + | P_lid of FStarC_Ident.lident + | P_inline_for_extraction +let (uu___is_P_begin_module : parsing_data_elt -> Prims.bool) = + fun projectee -> + match projectee with | P_begin_module _0 -> true | uu___ -> false +let (__proj__P_begin_module__item___0 : + parsing_data_elt -> FStarC_Ident.lident) = + fun projectee -> match projectee with | P_begin_module _0 -> _0 +let (uu___is_P_open : parsing_data_elt -> Prims.bool) = + fun projectee -> match projectee with | P_open _0 -> true | uu___ -> false +let (__proj__P_open__item___0 : + parsing_data_elt -> (Prims.bool * FStarC_Ident.lident)) = + fun projectee -> match projectee with | P_open _0 -> _0 +let (uu___is_P_implicit_open_module_or_namespace : + parsing_data_elt -> Prims.bool) = + fun projectee -> + match projectee with + | P_implicit_open_module_or_namespace _0 -> true + | uu___ -> false +let (__proj__P_implicit_open_module_or_namespace__item___0 : + parsing_data_elt -> (open_kind * FStarC_Ident.lid)) = + fun projectee -> + match projectee with | P_implicit_open_module_or_namespace _0 -> _0 +let (uu___is_P_dep : parsing_data_elt -> Prims.bool) = + fun projectee -> match projectee with | P_dep _0 -> true | uu___ -> false +let (__proj__P_dep__item___0 : + parsing_data_elt -> (Prims.bool * FStarC_Ident.lident)) = + fun projectee -> match projectee with | P_dep _0 -> _0 +let (uu___is_P_alias : parsing_data_elt -> Prims.bool) = + fun projectee -> match projectee with | P_alias _0 -> true | uu___ -> false +let (__proj__P_alias__item___0 : + parsing_data_elt -> (FStarC_Ident.ident * FStarC_Ident.lident)) = + fun projectee -> match projectee with | P_alias _0 -> _0 +let (uu___is_P_lid : parsing_data_elt -> Prims.bool) = + fun projectee -> match projectee with | P_lid _0 -> true | uu___ -> false +let (__proj__P_lid__item___0 : parsing_data_elt -> FStarC_Ident.lident) = + fun projectee -> match projectee with | P_lid _0 -> _0 +let (uu___is_P_inline_for_extraction : parsing_data_elt -> Prims.bool) = + fun projectee -> + match projectee with | P_inline_for_extraction -> true | uu___ -> false +type parsing_data = + | Mk_pd of parsing_data_elt Prims.list +let (uu___is_Mk_pd : parsing_data -> Prims.bool) = fun projectee -> true +let (__proj__Mk_pd__item___0 : parsing_data -> parsing_data_elt Prims.list) = + fun projectee -> match projectee with | Mk_pd _0 -> _0 +let (str_of_parsing_data_elt : parsing_data_elt -> Prims.string) = + fun elt -> + let str_of_open_kind uu___ = + match uu___ with + | Open_module -> "P_open_module" + | Open_namespace -> "P_open_namespace" in + match elt with + | P_begin_module lid -> + let uu___ = + let uu___1 = FStarC_Ident.string_of_lid lid in + Prims.strcat uu___1 ")" in + Prims.strcat "P_begin_module (" uu___ + | P_open (b, lid) -> + let uu___ = + let uu___1 = FStarC_Compiler_Util.string_of_bool b in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Ident.string_of_lid lid in + Prims.strcat uu___4 ")" in + Prims.strcat ", " uu___3 in + Prims.strcat uu___1 uu___2 in + Prims.strcat "P_open (" uu___ + | P_implicit_open_module_or_namespace (k, lid) -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Ident.string_of_lid lid in + Prims.strcat uu___3 ")" in + Prims.strcat ", " uu___2 in + Prims.strcat (str_of_open_kind k) uu___1 in + Prims.strcat "P_implicit_open_module_or_namespace (" uu___ + | P_dep (b, lid) -> + let uu___ = + let uu___1 = FStarC_Ident.string_of_lid lid in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Compiler_Util.string_of_bool b in + Prims.strcat uu___4 ")" in + Prims.strcat ", " uu___3 in + Prims.strcat uu___1 uu___2 in + Prims.strcat "P_dep (" uu___ + | P_alias (id, lid) -> + let uu___ = + let uu___1 = FStarC_Ident.string_of_id id in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Ident.string_of_lid lid in + Prims.strcat uu___4 ")" in + Prims.strcat ", " uu___3 in + Prims.strcat uu___1 uu___2 in + Prims.strcat "P_alias (" uu___ + | P_lid lid -> + let uu___ = + let uu___1 = FStarC_Ident.string_of_lid lid in + Prims.strcat uu___1 ")" in + Prims.strcat "P_lid (" uu___ + | P_inline_for_extraction -> "P_inline_for_extraction" +let (str_of_parsing_data : parsing_data -> Prims.string) = + fun uu___ -> + match uu___ with + | Mk_pd l -> + FStarC_Compiler_List.fold_left + (fun s -> + fun elt -> + let uu___1 = + let uu___2 = str_of_parsing_data_elt elt in + Prims.strcat "; " uu___2 in + Prims.strcat s uu___1) "" l +let (friends : parsing_data -> FStarC_Ident.lident Prims.list) = + fun p -> + let uu___ = p in + match uu___ with + | Mk_pd p1 -> + FStarC_Compiler_List.collect + (fun uu___1 -> + match uu___1 with | P_dep (true, l) -> [l] | uu___2 -> []) p1 +let (parsing_data_elt_eq : + parsing_data_elt -> parsing_data_elt -> Prims.bool) = + fun e1 -> + fun e2 -> + match (e1, e2) with + | (P_begin_module l1, P_begin_module l2) -> + FStarC_Ident.lid_equals l1 l2 + | (P_open (b1, l1), P_open (b2, l2)) -> + (b1 = b2) && (FStarC_Ident.lid_equals l1 l2) + | (P_implicit_open_module_or_namespace (k1, l1), + P_implicit_open_module_or_namespace (k2, l2)) -> + (k1 = k2) && (FStarC_Ident.lid_equals l1 l2) + | (P_dep (b1, l1), P_dep (b2, l2)) -> + (b1 = b2) && (FStarC_Ident.lid_equals l1 l2) + | (P_alias (i1, l1), P_alias (i2, l2)) -> + (let uu___ = FStarC_Ident.string_of_id i1 in + let uu___1 = FStarC_Ident.string_of_id i2 in uu___ = uu___1) && + (FStarC_Ident.lid_equals l1 l2) + | (P_lid l1, P_lid l2) -> FStarC_Ident.lid_equals l1 l2 + | (P_inline_for_extraction, P_inline_for_extraction) -> true + | (uu___, uu___1) -> false +let (empty_parsing_data : parsing_data) = Mk_pd [] +type deps = + { + dep_graph: dependence_graph ; + file_system_map: files_for_module_name ; + cmd_line_files: file_name Prims.list ; + all_files: file_name Prims.list ; + interfaces_with_inlining: module_name Prims.list ; + parse_results: parsing_data FStarC_Compiler_Util.smap } +let (__proj__Mkdeps__item__dep_graph : deps -> dependence_graph) = + fun projectee -> + match projectee with + | { dep_graph; file_system_map; cmd_line_files; all_files; + interfaces_with_inlining; parse_results;_} -> dep_graph +let (__proj__Mkdeps__item__file_system_map : deps -> files_for_module_name) = + fun projectee -> + match projectee with + | { dep_graph; file_system_map; cmd_line_files; all_files; + interfaces_with_inlining; parse_results;_} -> file_system_map +let (__proj__Mkdeps__item__cmd_line_files : deps -> file_name Prims.list) = + fun projectee -> + match projectee with + | { dep_graph; file_system_map; cmd_line_files; all_files; + interfaces_with_inlining; parse_results;_} -> cmd_line_files +let (__proj__Mkdeps__item__all_files : deps -> file_name Prims.list) = + fun projectee -> + match projectee with + | { dep_graph; file_system_map; cmd_line_files; all_files; + interfaces_with_inlining; parse_results;_} -> all_files +let (__proj__Mkdeps__item__interfaces_with_inlining : + deps -> module_name Prims.list) = + fun projectee -> + match projectee with + | { dep_graph; file_system_map; cmd_line_files; all_files; + interfaces_with_inlining; parse_results;_} -> + interfaces_with_inlining +let (__proj__Mkdeps__item__parse_results : + deps -> parsing_data FStarC_Compiler_Util.smap) = + fun projectee -> + match projectee with + | { dep_graph; file_system_map; cmd_line_files; all_files; + interfaces_with_inlining; parse_results;_} -> parse_results +let (deps_try_find : + dependence_graph -> Prims.string -> dep_node FStar_Pervasives_Native.option) + = + fun uu___ -> + fun k -> + match uu___ with | Deps m -> FStarC_Compiler_Util.smap_try_find m k +let (deps_add_dep : dependence_graph -> Prims.string -> dep_node -> unit) = + fun uu___ -> + fun k -> + fun v -> + match uu___ with | Deps m -> FStarC_Compiler_Util.smap_add m k v +let (deps_keys : dependence_graph -> Prims.string Prims.list) = + fun uu___ -> match uu___ with | Deps m -> FStarC_Compiler_Util.smap_keys m +let (deps_empty : unit -> dependence_graph) = + fun uu___ -> + let uu___1 = FStarC_Compiler_Util.smap_create (Prims.of_int (41)) in + Deps uu___1 +let (mk_deps : + dependence_graph -> + files_for_module_name -> + file_name Prims.list -> + file_name Prims.list -> + module_name Prims.list -> + parsing_data FStarC_Compiler_Util.smap -> deps) + = + fun dg -> + fun fs -> + fun c -> + fun a -> + fun i -> + fun pr -> + { + dep_graph = dg; + file_system_map = fs; + cmd_line_files = c; + all_files = a; + interfaces_with_inlining = i; + parse_results = pr + } +let (empty_deps : deps) = + let uu___ = deps_empty () in + let uu___1 = FStarC_Compiler_Util.smap_create Prims.int_zero in + let uu___2 = FStarC_Compiler_Util.smap_create Prims.int_zero in + mk_deps uu___ uu___1 [] [] [] uu___2 +let (module_name_of_dep : dependence -> module_name) = + fun uu___ -> + match uu___ with + | UseInterface m -> m + | PreferInterface m -> m + | UseImplementation m -> m + | FriendImplementation m -> m +let (resolve_module_name : + files_for_module_name -> + module_name -> module_name FStar_Pervasives_Native.option) + = + fun file_system_map -> + fun key -> + let uu___ = FStarC_Compiler_Util.smap_try_find file_system_map key in + match uu___ with + | FStar_Pervasives_Native.Some + (FStar_Pervasives_Native.Some fn, uu___1) -> + let uu___2 = lowercase_module_name fn in + FStar_Pervasives_Native.Some uu___2 + | FStar_Pervasives_Native.Some + (uu___1, FStar_Pervasives_Native.Some fn) -> + let uu___2 = lowercase_module_name fn in + FStar_Pervasives_Native.Some uu___2 + | uu___1 -> FStar_Pervasives_Native.None +let (interface_of_internal : + files_for_module_name -> + module_name -> file_name FStar_Pervasives_Native.option) + = + fun file_system_map -> + fun key -> + let uu___ = FStarC_Compiler_Util.smap_try_find file_system_map key in + match uu___ with + | FStar_Pervasives_Native.Some + (FStar_Pervasives_Native.Some iface, uu___1) -> + FStar_Pervasives_Native.Some iface + | uu___1 -> FStar_Pervasives_Native.None +let (implementation_of_internal : + files_for_module_name -> + module_name -> file_name FStar_Pervasives_Native.option) + = + fun file_system_map -> + fun key -> + let uu___ = FStarC_Compiler_Util.smap_try_find file_system_map key in + match uu___ with + | FStar_Pervasives_Native.Some + (uu___1, FStar_Pervasives_Native.Some impl) -> + FStar_Pervasives_Native.Some impl + | uu___1 -> FStar_Pervasives_Native.None +let (interface_of : + deps -> Prims.string -> Prims.string FStar_Pervasives_Native.option) = + fun deps1 -> fun key -> interface_of_internal deps1.file_system_map key +let (implementation_of : + deps -> Prims.string -> Prims.string FStar_Pervasives_Native.option) = + fun deps1 -> + fun key -> implementation_of_internal deps1.file_system_map key +let (has_interface : files_for_module_name -> module_name -> Prims.bool) = + fun file_system_map -> + fun key -> + let uu___ = interface_of_internal file_system_map key in + FStarC_Compiler_Option.isSome uu___ +let (has_implementation : files_for_module_name -> module_name -> Prims.bool) + = + fun file_system_map -> + fun key -> + let uu___ = implementation_of_internal file_system_map key in + FStarC_Compiler_Option.isSome uu___ +let (cache_file_name : Prims.string -> Prims.string) = + let checked_file_and_exists_flag fn = + let cache_fn = + let lax = FStarC_Options.lax () in + if lax + then Prims.strcat fn ".checked.lax" + else Prims.strcat fn ".checked" in + let mname = module_name_of_file fn in + let uu___ = + let uu___1 = FStarC_Compiler_Util.basename cache_fn in + FStarC_Find.find_file uu___1 in + match uu___ with + | FStar_Pervasives_Native.Some path -> + let expected_cache_file = FStarC_Options.prepend_cache_dir cache_fn in + ((let uu___2 = + ((let uu___3 = FStarC_Options.dep () in + FStarC_Compiler_Option.isSome uu___3) && + (let uu___3 = FStarC_Options.should_be_already_cached mname in + Prims.op_Negation uu___3)) + && + ((Prims.op_Negation + (FStarC_Compiler_Util.file_exists expected_cache_file)) + || + (let uu___3 = + FStarC_Compiler_Util.paths_to_same_file path + expected_cache_file in + Prims.op_Negation uu___3)) in + if uu___2 + then + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Errors_Msg.text "Did not expect module" in + let uu___6 = + let uu___7 = FStarC_Pprint.doc_of_string mname in + let uu___8 = + FStarC_Errors_Msg.text "to be already checked." in + FStarC_Pprint.op_Hat_Slash_Hat uu___7 uu___8 in + FStarC_Pprint.op_Hat_Slash_Hat uu___5 uu___6 in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Errors_Msg.text + "Found it in an unexpected location:" in + let uu___9 = FStarC_Pprint.doc_of_string path in + FStarC_Pprint.prefix (Prims.of_int (2)) Prims.int_one + uu___8 uu___9 in + let uu___8 = + let uu___9 = FStarC_Errors_Msg.text "instead of" in + let uu___10 = + FStarC_Pprint.doc_of_string expected_cache_file in + FStarC_Pprint.prefix (Prims.of_int (2)) Prims.int_one + uu___9 uu___10 in + FStarC_Pprint.op_Hat_Slash_Hat uu___7 uu___8 in + [uu___6] in + uu___4 :: uu___5 in + FStarC_Errors.log_issue0 + FStarC_Errors_Codes.Warning_UnexpectedCheckedFile () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___3) + else ()); + (let uu___2 = + (FStarC_Compiler_Util.file_exists expected_cache_file) && + (FStarC_Compiler_Util.paths_to_same_file path + expected_cache_file) in + if uu___2 then expected_cache_file else path)) + | FStar_Pervasives_Native.None -> + ((let uu___2 = FStarC_Compiler_Effect.op_Bang dbg_CheckedFiles in + if uu___2 + then + let uu___3 = FStarC_Compiler_Util.basename cache_fn in + FStarC_Compiler_Util.print1 "find_file(%s) returned None\n" + uu___3 + else ()); + (let uu___3 = FStarC_Options.should_be_already_cached mname in + if uu___3 + then + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Compiler_Util.format1 + "Expected %s to be already checked but could not find it." + mname in + FStarC_Errors_Msg.text uu___6 in + [uu___5] in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Error_AlreadyCachedAssertionFailure () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___4) + else ()); + FStarC_Options.prepend_cache_dir cache_fn) in + let memo = FStarC_Compiler_Util.smap_create (Prims.of_int (100)) in + let memo1 f x = + let uu___ = FStarC_Compiler_Util.smap_try_find memo x in + match uu___ with + | FStar_Pervasives_Native.Some res -> res + | FStar_Pervasives_Native.None -> + let res = f x in (FStarC_Compiler_Util.smap_add memo x res; res) in + memo1 checked_file_and_exists_flag +let (parsing_data_of : deps -> Prims.string -> parsing_data) = + fun deps1 -> + fun fn -> + let uu___ = FStarC_Compiler_Util.smap_try_find deps1.parse_results fn in + FStarC_Compiler_Util.must uu___ +let (file_of_dep_aux : + Prims.bool -> + files_for_module_name -> file_name Prims.list -> dependence -> file_name) + = + fun use_checked_file -> + fun file_system_map -> + fun all_cmd_line_files -> + fun d -> + let cmd_line_has_impl key = + FStarC_Compiler_Util.for_some + (fun fn -> + (is_implementation fn) && + (let uu___ = lowercase_module_name fn in key = uu___)) + all_cmd_line_files in + let maybe_use_cache_of f = + if use_checked_file then cache_file_name f else f in + match d with + | UseInterface key -> + let uu___ = interface_of_internal file_system_map key in + (match uu___ with + | FStar_Pervasives_Native.None -> + let uu___1 = + FStarC_Compiler_Util.format1 + "Expected an interface for module %s, but couldn't find one" + key in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_MissingInterface () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) + | FStar_Pervasives_Native.Some f -> f) + | PreferInterface key when has_interface file_system_map key -> + let uu___ = + (cmd_line_has_impl key) && + (let uu___1 = FStarC_Options.dep () in + FStarC_Compiler_Option.isNone uu___1) in + if uu___ + then + let uu___1 = FStarC_Options.expose_interfaces () in + (if uu___1 + then + let uu___2 = + let uu___3 = + implementation_of_internal file_system_map key in + FStarC_Compiler_Option.get uu___3 in + maybe_use_cache_of uu___2 + else + (let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + implementation_of_internal file_system_map key in + FStarC_Compiler_Option.get uu___7 in + let uu___7 = + let uu___8 = + interface_of_internal file_system_map key in + FStarC_Compiler_Option.get uu___8 in + FStarC_Compiler_Util.format3 + "You may have a cyclic dependence on module %s: use --dep full to confirm. Alternatively, invoking fstar with %s on the command line breaks the abstraction imposed by its interface %s." + key uu___6 uu___7 in + FStarC_Errors_Msg.text uu___5 in + let uu___5 = + let uu___6 = + FStarC_Errors_Msg.text + "If you really want this behavior add the option '--expose_interfaces'." in + [uu___6] in + uu___4 :: uu___5 in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_MissingExposeInterfacesOption + () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___3))) + else + (let uu___2 = + let uu___3 = interface_of_internal file_system_map key in + FStarC_Compiler_Option.get uu___3 in + maybe_use_cache_of uu___2) + | PreferInterface key -> + let uu___ = implementation_of_internal file_system_map key in + (match uu___ with + | FStar_Pervasives_Native.None -> + let uu___1 = + FStarC_Compiler_Util.format1 + "Expected an implementation of module %s, but couldn't find one" + key in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_MissingImplementation () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) + | FStar_Pervasives_Native.Some f -> maybe_use_cache_of f) + | UseImplementation key -> + let uu___ = implementation_of_internal file_system_map key in + (match uu___ with + | FStar_Pervasives_Native.None -> + let uu___1 = + FStarC_Compiler_Util.format1 + "Expected an implementation of module %s, but couldn't find one" + key in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_MissingImplementation () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) + | FStar_Pervasives_Native.Some f -> maybe_use_cache_of f) + | FriendImplementation key -> + let uu___ = implementation_of_internal file_system_map key in + (match uu___ with + | FStar_Pervasives_Native.None -> + let uu___1 = + FStarC_Compiler_Util.format1 + "Expected an implementation of module %s, but couldn't find one" + key in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_MissingImplementation () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) + | FStar_Pervasives_Native.Some f -> maybe_use_cache_of f) +let (file_of_dep : + files_for_module_name -> file_name Prims.list -> dependence -> file_name) = + file_of_dep_aux false +let (dependences_of : + files_for_module_name -> + dependence_graph -> + file_name Prims.list -> file_name -> file_name Prims.list) + = + fun file_system_map -> + fun deps1 -> + fun all_cmd_line_files -> + fun fn -> + let uu___ = deps_try_find deps1 fn in + match uu___ with + | FStar_Pervasives_Native.None -> empty_dependences () + | FStar_Pervasives_Native.Some { edges = deps2; color = uu___1;_} + -> + let uu___2 = + FStarC_Compiler_List.map + (file_of_dep file_system_map all_cmd_line_files) deps2 in + FStarC_Compiler_List.filter (fun k -> k <> fn) uu___2 +let (print_graph : + FStarC_Compiler_Util.out_channel -> + Prims.string -> dependence_graph -> unit) + = + fun outc -> + fun fn -> + fun graph -> + (let uu___1 = + let uu___2 = FStarC_Options.silent () in Prims.op_Negation uu___2 in + if uu___1 + then + (FStarC_Compiler_Util.print1 + "A DOT-format graph has been dumped in the current directory as `%s`\n" + fn; + FStarC_Compiler_Util.print1 + "With GraphViz installed, try: fdp -Tpng -odep.png %s\n" fn; + FStarC_Compiler_Util.print1 + "Hint: cat %s | grep -v _ | grep -v prims\n" fn) + else ()); + (let s = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = deps_keys graph in + FStarC_Compiler_List.unique uu___5 in + FStarC_Compiler_List.collect + (fun k -> + let deps1 = + let uu___5 = + let uu___6 = deps_try_find graph k in + FStarC_Compiler_Util.must uu___6 in + uu___5.edges in + let r s1 = FStarC_Compiler_Util.replace_char s1 46 95 in + let print dep = + let uu___5 = + let uu___6 = lowercase_module_name k in r uu___6 in + FStarC_Compiler_Util.format2 " \"%s\" -> \"%s\"" + uu___5 (r (module_name_of_dep dep)) in + FStarC_Compiler_List.map print deps1) uu___4 in + FStarC_Compiler_String.concat "\n" uu___3 in + Prims.strcat uu___2 "\n}\n" in + Prims.strcat "digraph {\n" uu___1 in + FStarC_Compiler_Util.fprint outc "%s" [s]) +let (safe_readdir_for_include : Prims.string -> Prims.string Prims.list) = + fun d -> + try + (fun uu___ -> match () with | () -> FStarC_Compiler_Util.readdir d) () + with | uu___ -> [] +let (build_inclusion_candidates_list : + unit -> (Prims.string * Prims.string) Prims.list) = + fun uu___ -> + let include_directories = FStarC_Options.include_path () in + let include_directories1 = + FStarC_Compiler_List.map FStarC_Compiler_Util.normalize_file_path + include_directories in + let include_directories2 = + FStarC_Compiler_List.unique include_directories1 in + let cwd = + let uu___1 = FStarC_Compiler_Util.getcwd () in + FStarC_Compiler_Util.normalize_file_path uu___1 in + FStarC_Compiler_List.concatMap + (fun d -> + let files = safe_readdir_for_include d in + FStarC_Compiler_List.filter_map + (fun f -> + let f1 = FStarC_Compiler_Util.basename f in + let uu___1 = check_and_strip_suffix f1 in + FStarC_Compiler_Util.map_option + (fun longname -> + let full_path = + if d = cwd + then f1 + else FStarC_Compiler_Util.join_paths d f1 in + (longname, full_path)) uu___1) files) include_directories2 +let (build_map : Prims.string Prims.list -> files_for_module_name) = + fun filenames -> + let map = FStarC_Compiler_Util.smap_create (Prims.of_int (41)) in + let add_entry key full_path = + let uu___ = FStarC_Compiler_Util.smap_try_find map key in + match uu___ with + | FStar_Pervasives_Native.Some (intf, impl) -> + let uu___1 = is_interface full_path in + if uu___1 + then + FStarC_Compiler_Util.smap_add map key + ((FStar_Pervasives_Native.Some full_path), impl) + else + FStarC_Compiler_Util.smap_add map key + (intf, (FStar_Pervasives_Native.Some full_path)) + | FStar_Pervasives_Native.None -> + let uu___1 = is_interface full_path in + if uu___1 + then + FStarC_Compiler_Util.smap_add map key + ((FStar_Pervasives_Native.Some full_path), + FStar_Pervasives_Native.None) + else + FStarC_Compiler_Util.smap_add map key + (FStar_Pervasives_Native.None, + (FStar_Pervasives_Native.Some full_path)) in + (let uu___1 = build_inclusion_candidates_list () in + FStarC_Compiler_List.iter + (fun uu___2 -> + match uu___2 with + | (longname, full_path) -> + add_entry (FStarC_Compiler_String.lowercase longname) full_path) + uu___1); + FStarC_Compiler_List.iter + (fun f -> let uu___2 = lowercase_module_name f in add_entry uu___2 f) + filenames; + map +let (string_of_lid : FStarC_Ident.lident -> Prims.bool -> Prims.string) = + fun l -> + fun last -> + let suffix = + if last + then + let uu___ = + let uu___1 = FStarC_Ident.ident_of_lid l in + FStarC_Ident.string_of_id uu___1 in + [uu___] + else [] in + let names = + let uu___ = + let uu___1 = FStarC_Ident.ns_of_lid l in + FStarC_Compiler_List.map (fun x -> FStarC_Ident.string_of_id x) + uu___1 in + FStarC_Compiler_List.op_At uu___ suffix in + FStarC_Compiler_String.concat "." names +let (lowercase_join_longident : + FStarC_Ident.lident -> Prims.bool -> Prims.string) = + fun l -> + fun last -> + let uu___ = string_of_lid l last in + FStarC_Compiler_String.lowercase uu___ +let (namespace_of_lid : FStarC_Ident.lident -> Prims.string) = + fun l -> + let uu___ = + let uu___1 = FStarC_Ident.ns_of_lid l in + FStarC_Compiler_List.map FStarC_Ident.string_of_id uu___1 in + FStarC_Compiler_String.concat "_" uu___ +let (check_module_declaration_against_filename : + FStarC_Ident.lident -> Prims.string -> unit) = + fun lid -> + fun filename -> + let k' = string_of_lid lid true in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Compiler_Util.basename filename in + check_and_strip_suffix uu___3 in + FStarC_Compiler_Util.must uu___2 in + uu___1 <> k' in + if uu___ + then + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = string_of_lid lid true in + FStarC_Compiler_Util.format2 + "The module declaration \"module %s\" found in file %s does not match its filename." + uu___4 filename in + FStarC_Errors_Msg.text uu___3 in + let uu___3 = + let uu___4 = + FStarC_Errors_Msg.text + "Dependencies will be incorrect and the module will not be verified." in + [uu___4] in + uu___2 :: uu___3 in + FStarC_Errors.log_issue FStarC_Ident.hasrange_lident lid + FStarC_Errors_Codes.Error_ModuleFileNameMismatch () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___1) + else () +exception Exit +let (uu___is_Exit : Prims.exn -> Prims.bool) = + fun projectee -> match projectee with | Exit -> true | uu___ -> false +let (core_modules : unit -> Prims.string Prims.list) = + fun uu___ -> + let uu___1 = + let uu___2 = FStarC_Basefiles.prims_basename () in + let uu___3 = + let uu___4 = FStarC_Basefiles.pervasives_basename () in + let uu___5 = + let uu___6 = FStarC_Basefiles.pervasives_native_basename () in + [uu___6] in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + FStarC_Compiler_List.map module_name_of_file uu___1 +let (implicit_ns_deps : FStarC_Ident.lident Prims.list) = + [FStarC_Parser_Const.fstar_ns_lid] +let (implicit_module_deps : FStarC_Ident.lident Prims.list) = + [FStarC_Parser_Const.prims_lid; FStarC_Parser_Const.pervasives_lid] +let (hard_coded_dependencies : + Prims.string -> (FStarC_Ident.lident * open_kind) Prims.list) = + fun full_filename -> + let filename = FStarC_Compiler_Util.basename full_filename in + let implicit_module_deps1 = + FStarC_Compiler_List.map (fun l -> (l, Open_module)) + implicit_module_deps in + let implicit_ns_deps1 = + FStarC_Compiler_List.map (fun l -> (l, Open_namespace)) + implicit_ns_deps in + let uu___ = + let uu___1 = module_name_of_file filename in + let uu___2 = core_modules () in FStarC_Compiler_List.mem uu___1 uu___2 in + if uu___ + then [] + else + (let uu___2 = + let uu___3 = module_name_of_file full_filename in + namespace_of_module uu___3 in + match uu___2 with + | FStar_Pervasives_Native.None -> + FStarC_Compiler_List.op_At implicit_ns_deps1 implicit_module_deps1 + | FStar_Pervasives_Native.Some ns -> + FStarC_Compiler_List.op_At implicit_ns_deps1 + (FStarC_Compiler_List.op_At implicit_module_deps1 + [(ns, Open_namespace)])) +let (dep_subsumed_by : dependence -> dependence -> Prims.bool) = + fun d -> + fun d' -> + match (d, d') with + | (PreferInterface l', FriendImplementation l) -> l = l' + | uu___ -> d = d' +let (enter_namespace : + files_for_module_name -> + files_for_module_name -> Prims.string -> Prims.bool -> Prims.bool) + = + fun original_map -> + fun working_map -> + fun sprefix -> + fun implicit_open -> + let found = FStarC_Compiler_Util.mk_ref false in + let sprefix1 = Prims.strcat sprefix "." in + let suffix_exists mopt = + match mopt with + | FStar_Pervasives_Native.None -> false + | FStar_Pervasives_Native.Some (intf, impl) -> + (FStarC_Compiler_Util.is_some intf) || + (FStarC_Compiler_Util.is_some impl) in + FStarC_Compiler_Util.smap_iter original_map + (fun k -> + fun uu___1 -> + if FStarC_Compiler_Util.starts_with k sprefix1 + then + let suffix = + FStarC_Compiler_String.substring k + (FStarC_Compiler_String.length sprefix1) + ((FStarC_Compiler_String.length k) - + (FStarC_Compiler_String.length sprefix1)) in + ((let suffix_filename = + FStarC_Compiler_Util.smap_try_find original_map suffix in + if implicit_open && (suffix_exists suffix_filename) + then + let str = + let uu___3 = + FStarC_Compiler_Util.must suffix_filename in + intf_and_impl_to_string uu___3 in + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Pprint.break_ Prims.int_one in + let uu___6 = + let uu___7 = + FStarC_Errors_Msg.text + "Implicitly opening namespace" in + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Pprint.doc_of_string sprefix1 in + FStarC_Pprint.squotes uu___10 in + let uu___10 = + let uu___11 = + FStarC_Errors_Msg.text "shadows module" in + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_Pprint.doc_of_string suffix in + FStarC_Pprint.squotes uu___14 in + let uu___14 = + let uu___15 = + FStarC_Errors_Msg.text "in file" in + let uu___16 = + let uu___17 = + let uu___18 = + let uu___19 = + FStarC_Pprint.doc_of_string str in + FStarC_Pprint.dquotes uu___19 in + FStarC_Pprint.op_Hat_Hat uu___18 + FStarC_Pprint.dot in + [uu___17] in + uu___15 :: uu___16 in + uu___13 :: uu___14 in + uu___11 :: uu___12 in + uu___9 :: uu___10 in + uu___7 :: uu___8 in + FStarC_Pprint.flow uu___5 uu___6 in + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Errors_Msg.text "Rename" in + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Pprint.doc_of_string str in + FStarC_Pprint.dquotes uu___10 in + let uu___10 = + FStarC_Errors_Msg.text "to avoid conflicts." in + FStarC_Pprint.op_Hat_Slash_Hat uu___9 uu___10 in + FStarC_Pprint.op_Hat_Slash_Hat uu___7 uu___8 in + [uu___6] in + uu___4 :: uu___5 in + FStarC_Errors.log_issue0 + FStarC_Errors_Codes.Warning_UnexpectedFile () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___3) + else ()); + (let filename = + let uu___3 = + FStarC_Compiler_Util.smap_try_find original_map k in + FStarC_Compiler_Util.must uu___3 in + FStarC_Compiler_Util.smap_add working_map suffix + filename; + FStarC_Compiler_Effect.op_Colon_Equals found true)) + else ()); + FStarC_Compiler_Effect.op_Bang found +let (collect_one : + files_for_module_name -> + Prims.string -> + (Prims.string -> parsing_data FStar_Pervasives_Native.option) -> + (parsing_data * dependence Prims.list * Prims.bool * dependence + Prims.list)) + = + fun original_map -> + fun filename -> + fun get_parsing_data_from_cache -> + let from_parsing_data pd original_map1 filename1 = + let deps1 = FStarC_Compiler_Util.mk_ref [] in + let has_inline_for_extraction = FStarC_Compiler_Util.mk_ref false in + let mo_roots = + let mname = lowercase_module_name filename1 in + let uu___ = + (is_interface filename1) && + (has_implementation original_map1 mname) in + if uu___ then [UseImplementation mname] else [] in + let auto_open = + let uu___ = hard_coded_dependencies filename1 in + FStarC_Compiler_List.map + (fun uu___1 -> + match uu___1 with + | (lid, k) -> P_implicit_open_module_or_namespace (k, lid)) + uu___ in + let working_map = FStarC_Compiler_Util.smap_copy original_map1 in + let set_interface_inlining uu___ = + let uu___1 = is_interface filename1 in + if uu___1 + then + FStarC_Compiler_Effect.op_Colon_Equals + has_inline_for_extraction true + else () in + let add_dep deps2 d = + let uu___ = + let uu___1 = + let uu___2 = FStarC_Compiler_Effect.op_Bang deps2 in + FStarC_Compiler_List.existsML (dep_subsumed_by d) uu___2 in + Prims.op_Negation uu___1 in + if uu___ + then + let uu___1 = + let uu___2 = FStarC_Compiler_Effect.op_Bang deps2 in d :: + uu___2 in + FStarC_Compiler_Effect.op_Colon_Equals deps2 uu___1 + else () in + let dep_edge module_name1 is_friend = + if is_friend + then FriendImplementation module_name1 + else PreferInterface module_name1 in + let add_dependence_edge original_or_working_map lid is_friend = + let key = lowercase_join_longident lid true in + let uu___ = resolve_module_name original_or_working_map key in + match uu___ with + | FStar_Pervasives_Native.Some module_name1 -> + (add_dep deps1 (dep_edge module_name1 is_friend); true) + | uu___1 -> false in + let record_open_module let_open lid = + let uu___ = + (let_open && (add_dependence_edge working_map lid false)) || + ((Prims.op_Negation let_open) && + (add_dependence_edge original_map1 lid false)) in + if uu___ + then true + else + (if let_open + then + (let uu___3 = + let uu___4 = string_of_lid lid true in + FStarC_Compiler_Util.format1 "Module not found: %s" + uu___4 in + FStarC_Errors.log_issue FStarC_Ident.hasrange_lident lid + FStarC_Errors_Codes.Warning_ModuleOrFileNotFoundWarning + () (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___3)) + else (); + false) in + let record_open_namespace lid implicit_open = + let key = lowercase_join_longident lid true in + let r = + enter_namespace original_map1 working_map key implicit_open in + if (Prims.op_Negation r) && (Prims.op_Negation implicit_open) + then + let uu___ = + let uu___1 = string_of_lid lid true in + FStarC_Compiler_Util.format1 + "No modules in namespace %s and no file with that name either" + uu___1 in + FStarC_Errors.log_issue FStarC_Ident.hasrange_lident lid + FStarC_Errors_Codes.Warning_ModuleOrFileNotFoundWarning () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___) + else () in + let record_open let_open lid = + let uu___ = record_open_module let_open lid in + if uu___ + then () + else + if Prims.op_Negation let_open + then record_open_namespace lid false + else () in + let record_implicit_open_module_or_namespace uu___ = + match uu___ with + | (lid, kind) -> + (match kind with + | Open_namespace -> record_open_namespace lid true + | Open_module -> + let uu___1 = record_open_module false lid in ()) in + let record_module_alias ident lid = + let key = + let uu___ = FStarC_Ident.string_of_id ident in + FStarC_Compiler_String.lowercase uu___ in + let alias = lowercase_join_longident lid true in + let uu___ = + FStarC_Compiler_Util.smap_try_find original_map1 alias in + match uu___ with + | FStar_Pervasives_Native.Some deps_of_aliased_module -> + (FStarC_Compiler_Util.smap_add working_map key + deps_of_aliased_module; + (let uu___3 = + let uu___4 = lowercase_join_longident lid true in + dep_edge uu___4 false in + add_dep deps1 uu___3); + true) + | FStar_Pervasives_Native.None -> + ((let uu___2 = + FStarC_Compiler_Util.format1 + "module not found in search path: %s" alias in + FStarC_Errors.log_issue FStarC_Ident.hasrange_lident lid + FStarC_Errors_Codes.Warning_ModuleOrFileNotFoundWarning + () (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + false) in + let add_dep_on_module module_name1 is_friend = + let uu___ = + add_dependence_edge working_map module_name1 is_friend in + if uu___ + then () + else + (let uu___2 = FStarC_Compiler_Effect.op_Bang dbg in + if uu___2 + then + let uu___3 = + let uu___4 = + FStarC_Class_Show.show FStarC_Ident.showable_lident + module_name1 in + FStarC_Compiler_Util.format1 "Unbound module reference %s" + uu___4 in + FStarC_Errors.log_issue FStarC_Ident.hasrange_lident + module_name1 + FStarC_Errors_Codes.Warning_UnboundModuleReference () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___3) + else ()) in + let record_lid lid = + let uu___ = FStarC_Ident.ns_of_lid lid in + match uu___ with + | [] -> () + | ns -> + let module_name1 = FStarC_Ident.lid_of_ids ns in + add_dep_on_module module_name1 false in + let begin_module lid = + let uu___ = + let uu___1 = + let uu___2 = FStarC_Ident.ns_of_lid lid in + FStarC_Compiler_List.length uu___2 in + uu___1 > Prims.int_zero in + if uu___ + then + let uu___1 = + let uu___2 = namespace_of_lid lid in + enter_namespace original_map1 working_map uu___2 in + () + else () in + (match pd with + | Mk_pd l -> + FStarC_Compiler_List.iter + (fun elt -> + match elt with + | P_begin_module lid -> begin_module lid + | P_open (b, lid) -> record_open b lid + | P_implicit_open_module_or_namespace (k, lid) -> + record_implicit_open_module_or_namespace (lid, k) + | P_dep (b, lid) -> add_dep_on_module lid b + | P_alias (id, lid) -> + let uu___1 = record_module_alias id lid in () + | P_lid lid -> record_lid lid + | P_inline_for_extraction -> set_interface_inlining ()) + (FStarC_Compiler_List.op_At auto_open l)); + (let uu___1 = FStarC_Compiler_Effect.op_Bang deps1 in + let uu___2 = + FStarC_Compiler_Effect.op_Bang has_inline_for_extraction in + (uu___1, uu___2, mo_roots)) in + let data_from_cache = get_parsing_data_from_cache filename in + if FStarC_Compiler_Util.is_some data_from_cache + then + let uu___ = + let uu___1 = FStarC_Compiler_Util.must data_from_cache in + from_parsing_data uu___1 original_map filename in + match uu___ with + | (deps1, has_inline_for_extraction, mo_roots) -> + ((let uu___2 = FStarC_Compiler_Effect.op_Bang dbg in + if uu___2 + then + let uu___3 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list showable_dependence) deps1 in + FStarC_Compiler_Util.print2 + "Reading the parsing data for %s from its checked file .. found [%s]\n" + filename uu___3 + else ()); + (let uu___2 = FStarC_Compiler_Util.must data_from_cache in + (uu___2, deps1, has_inline_for_extraction, mo_roots))) + else + (let num_of_toplevelmods = + FStarC_Compiler_Util.mk_ref Prims.int_zero in + let pd = FStarC_Compiler_Util.mk_ref [] in + let add_to_parsing_data elt = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Compiler_Effect.op_Bang pd in + FStarC_Compiler_List.existsML + (fun e -> parsing_data_elt_eq e elt) uu___3 in + Prims.op_Negation uu___2 in + if uu___1 + then + let uu___2 = + let uu___3 = FStarC_Compiler_Effect.op_Bang pd in elt :: + uu___3 in + FStarC_Compiler_Effect.op_Colon_Equals pd uu___2 + else () in + let rec collect_module uu___1 = + match uu___1 with + | FStarC_Parser_AST.Module (lid, decls) -> + (check_module_declaration_against_filename lid filename; + add_to_parsing_data (P_begin_module lid); + collect_decls decls) + | FStarC_Parser_AST.Interface (lid, decls, uu___2) -> + (check_module_declaration_against_filename lid filename; + add_to_parsing_data (P_begin_module lid); + collect_decls decls) + and collect_decls decls = + FStarC_Compiler_List.iter + (fun x -> + collect_decl x.FStarC_Parser_AST.d; + FStarC_Compiler_List.iter collect_term + x.FStarC_Parser_AST.attrs; + if + FStarC_Compiler_List.contains + FStarC_Parser_AST.Inline_for_extraction + x.FStarC_Parser_AST.quals + then add_to_parsing_data P_inline_for_extraction + else ()) decls + and collect_decl d = + match d with + | FStarC_Parser_AST.Include (lid, uu___1) -> + add_to_parsing_data (P_open (false, lid)) + | FStarC_Parser_AST.Open (lid, uu___1) -> + add_to_parsing_data (P_open (false, lid)) + | FStarC_Parser_AST.Friend lid -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = lowercase_join_longident lid true in + FStarC_Ident.lid_of_str uu___4 in + (true, uu___3) in + P_dep uu___2 in + add_to_parsing_data uu___1 + | FStarC_Parser_AST.ModuleAbbrev (ident, lid) -> + add_to_parsing_data (P_alias (ident, lid)) + | FStarC_Parser_AST.TopLevelLet (uu___1, patterms) -> + FStarC_Compiler_List.iter + (fun uu___2 -> + match uu___2 with + | (pat, t) -> (collect_pattern pat; collect_term t)) + patterms + | FStarC_Parser_AST.Splice (uu___1, uu___2, t) -> collect_term t + | FStarC_Parser_AST.Assume (uu___1, t) -> collect_term t + | FStarC_Parser_AST.SubEffect + { FStarC_Parser_AST.msource = uu___1; + FStarC_Parser_AST.mdest = uu___2; + FStarC_Parser_AST.lift_op = + FStarC_Parser_AST.NonReifiableLift t; + FStarC_Parser_AST.braced = uu___3;_} + -> collect_term t + | FStarC_Parser_AST.SubEffect + { FStarC_Parser_AST.msource = uu___1; + FStarC_Parser_AST.mdest = uu___2; + FStarC_Parser_AST.lift_op = FStarC_Parser_AST.LiftForFree + t; + FStarC_Parser_AST.braced = uu___3;_} + -> collect_term t + | FStarC_Parser_AST.Val (uu___1, t) -> collect_term t + | FStarC_Parser_AST.SubEffect + { FStarC_Parser_AST.msource = uu___1; + FStarC_Parser_AST.mdest = uu___2; + FStarC_Parser_AST.lift_op = + FStarC_Parser_AST.ReifiableLift (t0, t1); + FStarC_Parser_AST.braced = uu___3;_} + -> (collect_term t0; collect_term t1) + | FStarC_Parser_AST.Tycon (uu___1, tc, ts) -> + (if tc + then + add_to_parsing_data + (P_lid FStarC_Parser_Const.tcclass_lid) + else (); + FStarC_Compiler_List.iter collect_tycon ts) + | FStarC_Parser_AST.Exception (uu___1, t) -> + FStarC_Compiler_Util.iter_opt t collect_term + | FStarC_Parser_AST.NewEffect ed -> collect_effect_decl ed + | FStarC_Parser_AST.LayeredEffect ed -> collect_effect_decl ed + | FStarC_Parser_AST.Polymonadic_bind (uu___1, uu___2, uu___3, t) + -> collect_term t + | FStarC_Parser_AST.Polymonadic_subcomp (uu___1, uu___2, t) -> + collect_term t + | FStarC_Parser_AST.DeclToBeDesugared tbs -> + tbs.FStarC_Parser_AST.dep_scan + { + FStarC_Parser_AST.scan_term = collect_term; + FStarC_Parser_AST.scan_binder = collect_binder; + FStarC_Parser_AST.scan_pattern = collect_pattern; + FStarC_Parser_AST.add_lident = + (fun lid -> add_to_parsing_data (P_lid lid)); + FStarC_Parser_AST.add_open = + (fun lid -> add_to_parsing_data (P_open (true, lid))) + } tbs.FStarC_Parser_AST.blob + | FStarC_Parser_AST.UseLangDecls uu___1 -> () + | FStarC_Parser_AST.Pragma uu___1 -> () + | FStarC_Parser_AST.DeclSyntaxExtension uu___1 -> () + | FStarC_Parser_AST.Unparseable -> () + | FStarC_Parser_AST.TopLevelModule lid -> + (FStarC_Compiler_Util.incr num_of_toplevelmods; + (let uu___2 = + let uu___3 = + FStarC_Compiler_Effect.op_Bang num_of_toplevelmods in + uu___3 > Prims.int_one in + if uu___2 + then + let uu___3 = + let uu___4 = string_of_lid lid true in + FStarC_Compiler_Util.format1 + "Automatic dependency analysis demands one module per file (module %s not supported)" + uu___4 in + FStarC_Errors.raise_error FStarC_Ident.hasrange_lident + lid FStarC_Errors_Codes.Fatal_OneModulePerFile () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___3) + else ())) + and collect_tycon uu___1 = + match uu___1 with + | FStarC_Parser_AST.TyconAbstract (uu___2, binders, k) -> + (collect_binders binders; + FStarC_Compiler_Util.iter_opt k collect_term) + | FStarC_Parser_AST.TyconAbbrev (uu___2, binders, k, t) -> + (collect_binders binders; + FStarC_Compiler_Util.iter_opt k collect_term; + collect_term t) + | FStarC_Parser_AST.TyconRecord + (uu___2, binders, k, uu___3, identterms) -> + (collect_binders binders; + FStarC_Compiler_Util.iter_opt k collect_term; + collect_tycon_record identterms) + | FStarC_Parser_AST.TyconVariant + (uu___2, binders, k, identterms) -> + (collect_binders binders; + FStarC_Compiler_Util.iter_opt k collect_term; + (let uu___5 = + FStarC_Compiler_List.filter_map + FStar_Pervasives_Native.__proj__Mktuple3__item___2 + identterms in + FStarC_Compiler_List.iter + (fun uu___6 -> + match uu___6 with + | FStarC_Parser_AST.VpOfNotation t -> collect_term t + | FStarC_Parser_AST.VpArbitrary t -> collect_term t + | FStarC_Parser_AST.VpRecord (record, t) -> + (collect_tycon_record record; + FStarC_Compiler_Util.iter_opt t collect_term)) + uu___5)) + and collect_tycon_record r = + FStarC_Compiler_List.iter + (fun uu___1 -> + match uu___1 with + | (uu___2, aq, attrs, t) -> + (collect_aqual aq; + FStarC_Compiler_List.iter collect_term attrs; + collect_term t)) r + and collect_effect_decl uu___1 = + match uu___1 with + | FStarC_Parser_AST.DefineEffect (uu___2, binders, t, decls) -> + (collect_binders binders; + collect_term t; + collect_decls decls) + | FStarC_Parser_AST.RedefineEffect (uu___2, binders, t) -> + (collect_binders binders; collect_term t) + and collect_binders binders = + FStarC_Compiler_List.iter collect_binder binders + and collect_binder b = + collect_aqual b.FStarC_Parser_AST.aqual; + FStarC_Compiler_List.iter collect_term + b.FStarC_Parser_AST.battributes; + (match b with + | { + FStarC_Parser_AST.b = FStarC_Parser_AST.Annotated + (uu___3, t); + FStarC_Parser_AST.brange = uu___4; + FStarC_Parser_AST.blevel = uu___5; + FStarC_Parser_AST.aqual = uu___6; + FStarC_Parser_AST.battributes = uu___7;_} -> collect_term t + | { + FStarC_Parser_AST.b = FStarC_Parser_AST.TAnnotated + (uu___3, t); + FStarC_Parser_AST.brange = uu___4; + FStarC_Parser_AST.blevel = uu___5; + FStarC_Parser_AST.aqual = uu___6; + FStarC_Parser_AST.battributes = uu___7;_} -> collect_term t + | { FStarC_Parser_AST.b = FStarC_Parser_AST.NoName t; + FStarC_Parser_AST.brange = uu___3; + FStarC_Parser_AST.blevel = uu___4; + FStarC_Parser_AST.aqual = uu___5; + FStarC_Parser_AST.battributes = uu___6;_} -> collect_term t + | uu___3 -> ()) + and collect_aqual uu___1 = + match uu___1 with + | FStar_Pervasives_Native.Some (FStarC_Parser_AST.Meta t) -> + collect_term t + | FStar_Pervasives_Native.Some (FStarC_Parser_AST.TypeClassArg) + -> + add_to_parsing_data + (P_lid FStarC_Parser_Const.tcresolve_lid) + | uu___2 -> () + and collect_term t = collect_term' t.FStarC_Parser_AST.tm + and collect_constant uu___1 = + match uu___1 with + | FStarC_Const.Const_int + (uu___2, FStar_Pervasives_Native.Some + (FStarC_Const.Unsigned, FStarC_Const.Sizet)) + -> + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Ident.lid_of_str "fstar.sizeT" in + (false, uu___5) in + P_dep uu___4 in + add_to_parsing_data uu___3 + | FStarC_Const.Const_int + (uu___2, FStar_Pervasives_Native.Some (signedness, width)) + -> + let u = + match signedness with + | FStarC_Const.Unsigned -> "u" + | FStarC_Const.Signed -> "" in + let w = + match width with + | FStarC_Const.Int8 -> "8" + | FStarC_Const.Int16 -> "16" + | FStarC_Const.Int32 -> "32" + | FStarC_Const.Int64 -> "64" in + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Compiler_Util.format2 "fstar.%sint%s" u w in + FStarC_Ident.lid_of_str uu___6 in + (false, uu___5) in + P_dep uu___4 in + add_to_parsing_data uu___3 + | FStarC_Const.Const_char uu___2 -> + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Ident.lid_of_str "fstar.char" in + (false, uu___5) in + P_dep uu___4 in + add_to_parsing_data uu___3 + | FStarC_Const.Const_range_of -> + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Ident.lid_of_str "fstar.range" in + (false, uu___4) in + P_dep uu___3 in + add_to_parsing_data uu___2 + | FStarC_Const.Const_set_range_of -> + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Ident.lid_of_str "fstar.range" in + (false, uu___4) in + P_dep uu___3 in + add_to_parsing_data uu___2 + | FStarC_Const.Const_real uu___2 -> + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Ident.lid_of_str "fstar.real" in + (false, uu___5) in + P_dep uu___4 in + add_to_parsing_data uu___3 + | uu___2 -> () + and collect_term' uu___1 = + match uu___1 with + | FStarC_Parser_AST.Wild -> () + | FStarC_Parser_AST.Const c -> collect_constant c + | FStarC_Parser_AST.Op (uu___2, ts) -> + FStarC_Compiler_List.iter collect_term ts + | FStarC_Parser_AST.Tvar uu___2 -> () + | FStarC_Parser_AST.Uvar uu___2 -> () + | FStarC_Parser_AST.Var lid -> add_to_parsing_data (P_lid lid) + | FStarC_Parser_AST.Projector (lid, uu___2) -> + add_to_parsing_data (P_lid lid) + | FStarC_Parser_AST.Discrim lid -> + add_to_parsing_data (P_lid lid) + | FStarC_Parser_AST.Name lid -> add_to_parsing_data (P_lid lid) + | FStarC_Parser_AST.Construct (lid, termimps) -> + (add_to_parsing_data (P_lid lid); + FStarC_Compiler_List.iter + (fun uu___3 -> + match uu___3 with | (t, uu___4) -> collect_term t) + termimps) + | FStarC_Parser_AST.Function (branches, uu___2) -> + collect_branches branches + | FStarC_Parser_AST.Abs (pats, t) -> + (collect_patterns pats; collect_term t) + | FStarC_Parser_AST.App (t1, t2, uu___2) -> + (collect_term t1; collect_term t2) + | FStarC_Parser_AST.Let (uu___2, patterms, t) -> + (FStarC_Compiler_List.iter + (fun uu___4 -> + match uu___4 with + | (attrs_opt, (pat, t1)) -> + ((let uu___6 = + FStarC_Compiler_Util.map_opt attrs_opt + (FStarC_Compiler_List.iter collect_term) in + ()); + collect_pattern pat; + collect_term t1)) patterms; + collect_term t) + | FStarC_Parser_AST.LetOperator (lets, body) -> + (FStarC_Compiler_List.iter + (fun uu___3 -> + match uu___3 with + | (ident, pat, def) -> + (collect_pattern pat; collect_term def)) lets; + collect_term body) + | FStarC_Parser_AST.LetOpen (lid, t) -> + (add_to_parsing_data (P_open (true, lid)); collect_term t) + | FStarC_Parser_AST.LetOpenRecord (r, rty, e) -> + (collect_term r; collect_term rty; collect_term e) + | FStarC_Parser_AST.Bind (uu___2, t1, t2) -> + (collect_term t1; collect_term t2) + | FStarC_Parser_AST.Seq (t1, t2) -> + (collect_term t1; collect_term t2) + | FStarC_Parser_AST.If (t1, uu___2, ret_opt, t2, t3) -> + (collect_term t1; + (match ret_opt with + | FStar_Pervasives_Native.None -> () + | FStar_Pervasives_Native.Some (uu___5, ret, uu___6) -> + collect_term ret); + collect_term t2; + collect_term t3) + | FStarC_Parser_AST.Match (t, uu___2, ret_opt, bs) -> + (collect_term t; + (match ret_opt with + | FStar_Pervasives_Native.None -> () + | FStar_Pervasives_Native.Some (uu___5, ret, uu___6) -> + collect_term ret); + collect_branches bs) + | FStarC_Parser_AST.TryWith (t, bs) -> + (collect_term t; collect_branches bs) + | FStarC_Parser_AST.Ascribed + (t1, t2, FStar_Pervasives_Native.None, uu___2) -> + (collect_term t1; collect_term t2) + | FStarC_Parser_AST.Ascribed + (t1, t2, FStar_Pervasives_Native.Some tac, uu___2) -> + (collect_term t1; collect_term t2; collect_term tac) + | FStarC_Parser_AST.Record (t, idterms) -> + (FStarC_Compiler_Util.iter_opt t collect_term; + FStarC_Compiler_List.iter + (fun uu___3 -> + match uu___3 with + | (fn, t1) -> (collect_fieldname fn; collect_term t1)) + idterms) + | FStarC_Parser_AST.Project (t, f) -> + (collect_term t; collect_fieldname f) + | FStarC_Parser_AST.Product (binders, t) -> + (collect_binders binders; collect_term t) + | FStarC_Parser_AST.Sum (binders, t) -> + (FStarC_Compiler_List.iter + (fun uu___3 -> + match uu___3 with + | FStar_Pervasives.Inl b -> collect_binder b + | FStar_Pervasives.Inr t1 -> collect_term t1) binders; + collect_term t) + | FStarC_Parser_AST.QForall (binders, (uu___2, ts), t) -> + (collect_binders binders; + FStarC_Compiler_List.iter + (FStarC_Compiler_List.iter collect_term) ts; + collect_term t) + | FStarC_Parser_AST.QExists (binders, (uu___2, ts), t) -> + (collect_binders binders; + FStarC_Compiler_List.iter + (FStarC_Compiler_List.iter collect_term) ts; + collect_term t) + | FStarC_Parser_AST.QuantOp (uu___2, binders, (uu___3, ts), t) + -> + (collect_binders binders; + FStarC_Compiler_List.iter + (FStarC_Compiler_List.iter collect_term) ts; + collect_term t) + | FStarC_Parser_AST.Refine (binder, t) -> + (collect_binder binder; collect_term t) + | FStarC_Parser_AST.NamedTyp (uu___2, t) -> collect_term t + | FStarC_Parser_AST.Paren t -> collect_term t + | FStarC_Parser_AST.Requires (t, uu___2) -> collect_term t + | FStarC_Parser_AST.Ensures (t, uu___2) -> collect_term t + | FStarC_Parser_AST.Labeled (t, uu___2, uu___3) -> + collect_term t + | FStarC_Parser_AST.LexList l -> + FStarC_Compiler_List.iter collect_term l + | FStarC_Parser_AST.WFOrder (t1, t2) -> + ((let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Ident.lid_of_str "FStar.WellFounded" in + (false, uu___5) in + P_dep uu___4 in + add_to_parsing_data uu___3); + collect_term t1; + collect_term t2) + | FStarC_Parser_AST.Decreases (t, uu___2) -> collect_term t + | FStarC_Parser_AST.Quote (t, uu___2) -> collect_term t + | FStarC_Parser_AST.Antiquote t -> collect_term t + | FStarC_Parser_AST.VQuote t -> collect_term t + | FStarC_Parser_AST.Attributes cattributes -> + FStarC_Compiler_List.iter collect_term cattributes + | FStarC_Parser_AST.CalcProof (rel, init, steps) -> + ((let uu___3 = + let uu___4 = + let uu___5 = FStarC_Ident.lid_of_str "FStar.Calc" in + (false, uu___5) in + P_dep uu___4 in + add_to_parsing_data uu___3); + collect_term rel; + collect_term init; + FStarC_Compiler_List.iter + (fun uu___5 -> + match uu___5 with + | FStarC_Parser_AST.CalcStep (rel1, just, next) -> + (collect_term rel1; + collect_term just; + collect_term next)) steps) + | FStarC_Parser_AST.IntroForall (bs, p, e) -> + ((let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Ident.lid_of_str "FStar.Classical.Sugar" in + (false, uu___5) in + P_dep uu___4 in + add_to_parsing_data uu___3); + collect_binders bs; + collect_term p; + collect_term e) + | FStarC_Parser_AST.IntroExists (bs, t, vs, e) -> + ((let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Ident.lid_of_str "FStar.Classical.Sugar" in + (false, uu___5) in + P_dep uu___4 in + add_to_parsing_data uu___3); + collect_binders bs; + collect_term t; + FStarC_Compiler_List.iter collect_term vs; + collect_term e) + | FStarC_Parser_AST.IntroImplies (p, q, x, e) -> + ((let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Ident.lid_of_str "FStar.Classical.Sugar" in + (false, uu___5) in + P_dep uu___4 in + add_to_parsing_data uu___3); + collect_term p; + collect_term q; + collect_binder x; + collect_term e) + | FStarC_Parser_AST.IntroOr (b, p, q, r) -> + ((let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Ident.lid_of_str "FStar.Classical.Sugar" in + (false, uu___5) in + P_dep uu___4 in + add_to_parsing_data uu___3); + collect_term p; + collect_term q; + collect_term r) + | FStarC_Parser_AST.IntroAnd (p, q, r, e) -> + ((let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Ident.lid_of_str "FStar.Classical.Sugar" in + (false, uu___5) in + P_dep uu___4 in + add_to_parsing_data uu___3); + collect_term p; + collect_term q; + collect_term r; + collect_term e) + | FStarC_Parser_AST.ElimForall (bs, p, vs) -> + ((let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Ident.lid_of_str "FStar.Classical.Sugar" in + (false, uu___5) in + P_dep uu___4 in + add_to_parsing_data uu___3); + collect_binders bs; + collect_term p; + FStarC_Compiler_List.iter collect_term vs) + | FStarC_Parser_AST.ElimExists (bs, p, q, b, e) -> + ((let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Ident.lid_of_str "FStar.Classical.Sugar" in + (false, uu___5) in + P_dep uu___4 in + add_to_parsing_data uu___3); + collect_binders bs; + collect_term p; + collect_term q; + collect_binder b; + collect_term e) + | FStarC_Parser_AST.ElimImplies (p, q, e) -> + ((let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Ident.lid_of_str "FStar.Classical.Sugar" in + (false, uu___5) in + P_dep uu___4 in + add_to_parsing_data uu___3); + collect_term p; + collect_term q; + collect_term e) + | FStarC_Parser_AST.ElimAnd (p, q, r, x, y, e) -> + ((let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Ident.lid_of_str "FStar.Classical.Sugar" in + (false, uu___5) in + P_dep uu___4 in + add_to_parsing_data uu___3); + collect_term p; + collect_term q; + collect_term r; + collect_binder x; + collect_binder y; + collect_term e) + | FStarC_Parser_AST.ElimOr (p, q, r, x, e, y, e') -> + ((let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Ident.lid_of_str "FStar.Classical.Sugar" in + (false, uu___5) in + P_dep uu___4 in + add_to_parsing_data uu___3); + collect_term p; + collect_term q; + collect_term r; + collect_binder x; + collect_binder y; + collect_term e; + collect_term e') + | FStarC_Parser_AST.ListLiteral ts -> + FStarC_Compiler_List.iter collect_term ts + | FStarC_Parser_AST.SeqLiteral ts -> + ((let uu___3 = + let uu___4 = + let uu___5 = FStarC_Ident.lid_of_str "FStar.Seq.Base" in + (false, uu___5) in + P_dep uu___4 in + add_to_parsing_data uu___3); + FStarC_Compiler_List.iter collect_term ts) + and collect_patterns ps = + FStarC_Compiler_List.iter collect_pattern ps + and collect_pattern p = collect_pattern' p.FStarC_Parser_AST.pat + and collect_pattern' uu___1 = + match uu___1 with + | FStarC_Parser_AST.PatVar (uu___2, aqual, attrs) -> + (collect_aqual aqual; + FStarC_Compiler_List.iter collect_term attrs) + | FStarC_Parser_AST.PatTvar (uu___2, aqual, attrs) -> + (collect_aqual aqual; + FStarC_Compiler_List.iter collect_term attrs) + | FStarC_Parser_AST.PatWild (aqual, attrs) -> + (collect_aqual aqual; + FStarC_Compiler_List.iter collect_term attrs) + | FStarC_Parser_AST.PatOp uu___2 -> () + | FStarC_Parser_AST.PatConst uu___2 -> () + | FStarC_Parser_AST.PatVQuote t -> collect_term t + | FStarC_Parser_AST.PatApp (p, ps) -> + (collect_pattern p; collect_patterns ps) + | FStarC_Parser_AST.PatName uu___2 -> () + | FStarC_Parser_AST.PatList ps -> collect_patterns ps + | FStarC_Parser_AST.PatOr ps -> collect_patterns ps + | FStarC_Parser_AST.PatTuple (ps, uu___2) -> collect_patterns ps + | FStarC_Parser_AST.PatRecord lidpats -> + FStarC_Compiler_List.iter + (fun uu___2 -> + match uu___2 with | (uu___3, p) -> collect_pattern p) + lidpats + | FStarC_Parser_AST.PatAscribed + (p, (t, FStar_Pervasives_Native.None)) -> + (collect_pattern p; collect_term t) + | FStarC_Parser_AST.PatAscribed + (p, (t, FStar_Pervasives_Native.Some tac)) -> + (collect_pattern p; collect_term t; collect_term tac) + and collect_branches bs = + FStarC_Compiler_List.iter collect_branch bs + and collect_branch uu___1 = + match uu___1 with + | (pat, t1, t2) -> + (collect_pattern pat; + FStarC_Compiler_Util.iter_opt t1 collect_term; + collect_term t2) + and collect_fieldname fn = + let uu___1 = let uu___2 = FStarC_Ident.nsstr fn in uu___2 <> "" in + if uu___1 + then + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Ident.ns_of_lid fn in + FStarC_Ident.lid_of_ids uu___5 in + (false, uu___4) in + P_dep uu___3 in + add_to_parsing_data uu___2 + else () in + let uu___1 = FStarC_Parser_Driver.parse_file filename in + match uu___1 with + | (ast, uu___2) -> + (collect_module ast; + (let pd1 = + let uu___4 = + let uu___5 = FStarC_Compiler_Effect.op_Bang pd in + FStarC_Compiler_List.rev uu___5 in + Mk_pd uu___4 in + let uu___4 = from_parsing_data pd1 original_map filename in + match uu___4 with + | (deps1, has_inline_for_extraction, mo_roots) -> + (pd1, deps1, has_inline_for_extraction, mo_roots)))) +let (collect_one_cache : + (dependence Prims.list * dependence Prims.list * Prims.bool) + FStarC_Compiler_Util.smap FStarC_Compiler_Effect.ref) + = + let uu___ = FStarC_Compiler_Util.smap_create Prims.int_zero in + FStarC_Compiler_Util.mk_ref uu___ +let (set_collect_one_cache : + (dependence Prims.list * dependence Prims.list * Prims.bool) + FStarC_Compiler_Util.smap -> unit) + = + fun cache -> FStarC_Compiler_Effect.op_Colon_Equals collect_one_cache cache +let (dep_graph_copy : dependence_graph -> dependence_graph) = + fun dep_graph -> + let uu___ = dep_graph in + match uu___ with + | Deps g -> let uu___1 = FStarC_Compiler_Util.smap_copy g in Deps uu___1 +let (widen_deps : + module_name Prims.list -> + dependence_graph -> + files_for_module_name -> Prims.bool -> (Prims.bool * dependence_graph)) + = + fun friends1 -> + fun dep_graph -> + fun file_system_map -> + fun widened -> + let widened1 = FStarC_Compiler_Util.mk_ref widened in + let uu___ = dep_graph in + match uu___ with + | Deps dg -> + let uu___1 = deps_empty () in + (match uu___1 with + | Deps dg' -> + let widen_one deps1 = + FStarC_Compiler_List.map + (fun d -> + match d with + | PreferInterface m when + (FStarC_Compiler_List.contains m friends1) && + (has_implementation file_system_map m) + -> + (FStarC_Compiler_Effect.op_Colon_Equals + widened1 true; + FriendImplementation m) + | uu___2 -> d) deps1 in + (FStarC_Compiler_Util.smap_fold dg + (fun filename -> + fun dep_node1 -> + fun uu___3 -> + let uu___4 = + let uu___5 = widen_one dep_node1.edges in + { edges = uu___5; color = White } in + FStarC_Compiler_Util.smap_add dg' filename + uu___4) (); + (let uu___3 = FStarC_Compiler_Effect.op_Bang widened1 in + (uu___3, (Deps dg'))))) +let (topological_dependences_of' : + files_for_module_name -> + dependence_graph -> + Prims.string Prims.list -> + file_name Prims.list -> + Prims.bool -> (file_name Prims.list * Prims.bool)) + = + fun file_system_map -> + fun dep_graph -> + fun interfaces_needing_inlining -> + fun root_files -> + fun widened -> + let rec all_friend_deps_1 dep_graph1 cycle uu___ filename = + match uu___ with + | (all_friends, all_files) -> + let dep_node1 = + let uu___1 = deps_try_find dep_graph1 filename in + FStarC_Compiler_Util.must uu___1 in + (match dep_node1.color with + | Gray -> + failwith + "Impossible: cycle detected after cycle detection has passed" + | Black -> (all_friends, all_files) + | White -> + ((let uu___2 = FStarC_Compiler_Effect.op_Bang dbg in + if uu___2 + then + let uu___3 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + showable_dependence) dep_node1.edges in + FStarC_Compiler_Util.print2 + "Visiting %s: direct deps are %s\n" filename + uu___3 + else ()); + deps_add_dep dep_graph1 filename + { edges = (dep_node1.edges); color = Gray }; + (let uu___3 = + let uu___4 = + dependences_of file_system_map dep_graph1 + root_files filename in + all_friend_deps dep_graph1 cycle + (all_friends, all_files) uu___4 in + match uu___3 with + | (all_friends1, all_files1) -> + (deps_add_dep dep_graph1 filename + { edges = (dep_node1.edges); color = Black }; + (let uu___6 = + FStarC_Compiler_Effect.op_Bang dbg in + if uu___6 + then + FStarC_Compiler_Util.print1 "Adding %s\n" + filename + else ()); + (let uu___6 = + let uu___7 = + FStarC_Compiler_List.collect + (fun uu___8 -> + match uu___8 with + | FriendImplementation m -> [m] + | d -> []) dep_node1.edges in + FStarC_Compiler_List.op_At uu___7 + all_friends1 in + (uu___6, (filename :: all_files1))))))) + and all_friend_deps dep_graph1 cycle all_friends filenames = + FStarC_Compiler_List.fold_left + (fun all_friends1 -> + fun k -> + all_friend_deps_1 dep_graph1 (k :: cycle) all_friends1 k) + all_friends filenames in + let uu___ = all_friend_deps dep_graph [] ([], []) root_files in + match uu___ with + | (friends1, all_files_0) -> + ((let uu___2 = FStarC_Compiler_Effect.op_Bang dbg in + if uu___2 + then + let uu___3 = + let uu___4 = + FStarC_Compiler_Util.remove_dups + (fun x -> fun y -> x = y) friends1 in + FStarC_Compiler_String.concat ", " uu___4 in + FStarC_Compiler_Util.print3 + "Phase1 complete:\n\tall_files = %s\n\tall_friends=%s\n\tinterfaces_with_inlining=%s\n" + (FStarC_Compiler_String.concat ", " all_files_0) uu___3 + (FStarC_Compiler_String.concat ", " + interfaces_needing_inlining) + else ()); + (let uu___2 = + widen_deps friends1 dep_graph file_system_map widened in + match uu___2 with + | (widened1, dep_graph1) -> + let uu___3 = + (let uu___5 = FStarC_Compiler_Effect.op_Bang dbg in + if uu___5 + then + FStarC_Compiler_Util.print_string + "==============Phase2==================\n" + else ()); + all_friend_deps dep_graph1 [] ([], []) root_files in + (match uu___3 with + | (uu___4, all_files) -> + ((let uu___6 = FStarC_Compiler_Effect.op_Bang dbg in + if uu___6 + then + FStarC_Compiler_Util.print1 + "Phase2 complete: all_files = %s\n" + (FStarC_Compiler_String.concat ", " + all_files) + else ()); + (all_files, widened1))))) +let (phase1 : + files_for_module_name -> + dependence_graph -> + module_name Prims.list -> Prims.bool -> (Prims.bool * dependence_graph)) + = + fun file_system_map -> + fun dep_graph -> + fun interfaces_needing_inlining -> + fun for_extraction -> + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg in + if uu___1 + then + FStarC_Compiler_Util.print_string + "==============Phase1==================\n" + else ()); + (let widened = false in + let uu___1 = (FStarC_Options.cmi ()) && for_extraction in + if uu___1 + then + widen_deps interfaces_needing_inlining dep_graph file_system_map + widened + else (widened, dep_graph)) +let (topological_dependences_of : + files_for_module_name -> + dependence_graph -> + Prims.string Prims.list -> + file_name Prims.list -> + Prims.bool -> (file_name Prims.list * Prims.bool)) + = + fun file_system_map -> + fun dep_graph -> + fun interfaces_needing_inlining -> + fun root_files -> + fun for_extraction -> + let uu___ = + phase1 file_system_map dep_graph interfaces_needing_inlining + for_extraction in + match uu___ with + | (widened, dep_graph1) -> + topological_dependences_of' file_system_map dep_graph1 + interfaces_needing_inlining root_files widened +let (all_files_in_include_paths : unit -> Prims.string Prims.list) = + fun uu___ -> + let paths = FStarC_Options.include_path () in + FStarC_Compiler_List.collect + (fun path -> + let files = safe_readdir_for_include path in + let files1 = + FStarC_Compiler_List.filter + (fun f -> + (FStarC_Compiler_Util.ends_with f ".fst") || + (FStarC_Compiler_Util.ends_with f ".fsti")) files in + FStarC_Compiler_List.map + (fun file -> FStarC_Compiler_Util.join_paths path file) files1) + paths +let (collect : + Prims.string Prims.list -> + (Prims.string -> parsing_data FStar_Pervasives_Native.option) -> + (Prims.string Prims.list * deps)) + = + fun all_cmd_line_files -> + fun get_parsing_data_from_cache -> + let all_cmd_line_files1 = + match all_cmd_line_files with + | [] -> all_files_in_include_paths () + | uu___ -> all_cmd_line_files in + let all_cmd_line_files2 = + FStarC_Compiler_List.map + (fun fn -> + let uu___ = FStarC_Find.find_file fn in + match uu___ with + | FStar_Pervasives_Native.None -> + let uu___1 = + FStarC_Compiler_Util.format1 "File %s could not be found" + fn in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_ModuleOrFileNotFound () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) + | FStar_Pervasives_Native.Some fn1 -> fn1) all_cmd_line_files1 in + let dep_graph = deps_empty () in + let file_system_map = build_map all_cmd_line_files2 in + let interfaces_needing_inlining = FStarC_Compiler_Util.mk_ref [] in + let add_interface_for_inlining l = + let l1 = lowercase_module_name l in + let uu___ = + let uu___1 = + FStarC_Compiler_Effect.op_Bang interfaces_needing_inlining in + l1 :: uu___1 in + FStarC_Compiler_Effect.op_Colon_Equals interfaces_needing_inlining + uu___ in + let parse_results = + FStarC_Compiler_Util.smap_create (Prims.of_int (40)) in + let rec discover_one file_name1 = + let uu___ = + let uu___1 = deps_try_find dep_graph file_name1 in + uu___1 = FStar_Pervasives_Native.None in + if uu___ + then + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Compiler_Effect.op_Bang collect_one_cache in + FStarC_Compiler_Util.smap_try_find uu___3 file_name1 in + match uu___2 with + | FStar_Pervasives_Native.Some cached -> ((Mk_pd []), cached) + | FStar_Pervasives_Native.None -> + let uu___3 = + collect_one file_system_map file_name1 + get_parsing_data_from_cache in + (match uu___3 with + | (parsing_data1, deps1, needs_interface_inlining, + additional_roots) -> + (parsing_data1, + (deps1, additional_roots, needs_interface_inlining))) in + match uu___1 with + | (parsing_data1, (deps1, mo_roots, needs_interface_inlining)) -> + (if needs_interface_inlining + then add_interface_for_inlining file_name1 + else (); + FStarC_Compiler_Util.smap_add parse_results file_name1 + parsing_data1; + (let deps2 = + let module_name1 = lowercase_module_name file_name1 in + let uu___4 = + (is_implementation file_name1) && + (has_interface file_system_map module_name1) in + if uu___4 + then + FStarC_Compiler_List.op_At deps1 + [UseInterface module_name1] + else deps1 in + let dep_node1 = + let uu___4 = FStarC_Compiler_List.unique deps2 in + { edges = uu___4; color = White } in + deps_add_dep dep_graph file_name1 dep_node1; + (let uu___5 = + FStarC_Compiler_List.map + (file_of_dep file_system_map all_cmd_line_files2) + (FStarC_Compiler_List.op_At deps2 mo_roots) in + FStarC_Compiler_List.iter discover_one uu___5))) + else () in + profile + (fun uu___1 -> + FStarC_Compiler_List.iter discover_one all_cmd_line_files2) + "FStarC.Parser.Dep.discover"; + (let cycle_detected dep_graph1 cycle filename = + FStarC_Compiler_Util.print1 + "The cycle contains a subset of the modules in:\n%s \n" + (FStarC_Compiler_String.concat "\n`used by` " cycle); + (let fn = "dep.graph" in + with_file_outchannel fn + (fun outc -> print_graph outc fn dep_graph1); + FStarC_Compiler_Util.print_string "\n"; + (let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Compiler_Util.format1 + "Recursive dependency on module %s." filename in + FStarC_Errors_Msg.text uu___6 in + let uu___6 = + let uu___7 = + FStarC_Errors_Msg.text + "A full dependency graph was written to dep.graph." in + [uu___7] in + uu___5 :: uu___6 in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_CyclicDependence () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___4))) in + let full_cycle_detection all_command_line_files file_system_map1 = + let dep_graph1 = dep_graph_copy dep_graph in + let mo_files = FStarC_Compiler_Util.mk_ref [] in + let rec aux cycle filename = + let node = + let uu___1 = deps_try_find dep_graph1 filename in + match uu___1 with + | FStar_Pervasives_Native.Some node1 -> node1 + | FStar_Pervasives_Native.None -> + let uu___2 = + FStarC_Compiler_Util.format1 + "Impossible: Failed to find dependencies of %s" filename in + failwith uu___2 in + let direct_deps = + FStarC_Compiler_List.collect + (fun x -> + match x with + | UseInterface f -> + let uu___1 = + implementation_of_internal file_system_map1 f in + (match uu___1 with + | FStar_Pervasives_Native.None -> [x] + | FStar_Pervasives_Native.Some fn when fn = filename + -> [x] + | uu___2 -> [x; UseImplementation f]) + | PreferInterface f -> + let uu___1 = + implementation_of_internal file_system_map1 f in + (match uu___1 with + | FStar_Pervasives_Native.None -> [x] + | FStar_Pervasives_Native.Some fn when fn = filename + -> [x] + | uu___2 -> [x; UseImplementation f]) + | uu___1 -> [x]) node.edges in + match node.color with + | Gray -> cycle_detected dep_graph1 cycle filename + | Black -> () + | White -> + (deps_add_dep dep_graph1 filename + { edges = direct_deps; color = Gray }; + (let uu___3 = + dependences_of file_system_map1 dep_graph1 + all_command_line_files filename in + FStarC_Compiler_List.iter (fun k -> aux (k :: cycle) k) + uu___3); + deps_add_dep dep_graph1 filename + { edges = direct_deps; color = Black }; + (let uu___4 = is_interface filename in + if uu___4 + then + let uu___5 = + let uu___6 = lowercase_module_name filename in + implementation_of_internal file_system_map1 uu___6 in + FStarC_Compiler_Util.iter_opt uu___5 + (fun impl -> + if + Prims.op_Negation + (FStarC_Compiler_List.contains impl + all_command_line_files) + then + let uu___6 = + let uu___7 = + FStarC_Compiler_Effect.op_Bang mo_files in + impl :: uu___7 in + FStarC_Compiler_Effect.op_Colon_Equals mo_files + uu___6 + else ()) + else ())) in + FStarC_Compiler_List.iter (aux []) all_command_line_files; + (let uu___2 = FStarC_Compiler_Effect.op_Bang mo_files in + FStarC_Compiler_List.iter (aux []) uu___2) in + full_cycle_detection all_cmd_line_files2 file_system_map; + FStarC_Compiler_List.iter + (fun f -> + let m = lowercase_module_name f in + FStarC_Options.add_verify_module m) all_cmd_line_files2; + (let inlining_ifaces = + FStarC_Compiler_Effect.op_Bang interfaces_needing_inlining in + let uu___3 = + profile + (fun uu___4 -> + let uu___5 = + let uu___6 = FStarC_Options.codegen () in + uu___6 <> FStar_Pervasives_Native.None in + topological_dependences_of file_system_map dep_graph + inlining_ifaces all_cmd_line_files2 uu___5) + "FStarC.Parser.Dep.topological_dependences_of" in + match uu___3 with + | (all_files, uu___4) -> + ((let uu___6 = FStarC_Compiler_Effect.op_Bang dbg in + if uu___6 + then + FStarC_Compiler_Util.print1 + "Interfaces needing inlining: %s\n" + (FStarC_Compiler_String.concat ", " inlining_ifaces) + else ()); + (all_files, + (mk_deps dep_graph file_system_map all_cmd_line_files2 + all_files inlining_ifaces parse_results))))) +let (deps_of : deps -> Prims.string -> Prims.string Prims.list) = + fun deps1 -> + fun f -> + dependences_of deps1.file_system_map deps1.dep_graph + deps1.cmd_line_files f +let (deps_of_modul : deps -> module_name -> module_name Prims.list) = + fun deps1 -> + fun m -> + let aux fopt = + let uu___ = + FStarC_Compiler_Util.map_option + (fun f -> + let uu___1 = deps_of deps1 f in + FStarC_Compiler_List.map module_name_of_file uu___1) fopt in + FStarC_Compiler_Util.dflt [] uu___ in + let uu___ = + let uu___1 = + FStarC_Compiler_Util.smap_try_find deps1.file_system_map + (FStarC_Compiler_String.lowercase m) in + FStarC_Compiler_Util.map_option + (fun uu___2 -> + match uu___2 with + | (intf_opt, impl_opt) -> + let uu___3 = + let uu___4 = aux intf_opt in + let uu___5 = aux impl_opt in + FStarC_Compiler_List.op_At uu___4 uu___5 in + FStarC_Compiler_Util.remove_dups (fun x -> fun y -> x = y) + uu___3) uu___1 in + FStarC_Compiler_Util.dflt [] uu___ +let (print_digest : (Prims.string * Prims.string) Prims.list -> Prims.string) + = + fun dig -> + let uu___ = + FStarC_Compiler_List.map + (fun uu___1 -> + match uu___1 with + | (m, d) -> + let uu___2 = FStarC_Compiler_Util.base64_encode d in + FStarC_Compiler_Util.format2 "%s:%s" m uu___2) dig in + FStarC_Compiler_String.concat "\n" uu___ +let (print_make : FStarC_Compiler_Util.out_channel -> deps -> unit) = + fun outc -> + fun deps1 -> + let file_system_map = deps1.file_system_map in + let all_cmd_line_files = deps1.cmd_line_files in + let deps2 = deps1.dep_graph in + let keys = deps_keys deps2 in + FStarC_Compiler_List.iter + (fun f -> + let dep_node1 = + let uu___ = deps_try_find deps2 f in + FStarC_Compiler_Option.get uu___ in + let files = + FStarC_Compiler_List.map + (file_of_dep file_system_map all_cmd_line_files) + dep_node1.edges in + let files1 = + FStarC_Compiler_List.map + (fun s -> FStarC_Compiler_Util.replace_chars s 32 "\\ ") files in + FStarC_Compiler_Util.print2 "%s: %s\n\n" f + (FStarC_Compiler_String.concat " " files1)) keys +let (print_raw : FStarC_Compiler_Util.out_channel -> deps -> unit) = + fun outc -> + fun deps1 -> + let uu___ = deps1.dep_graph in + match uu___ with + | Deps deps2 -> + let uu___1 = + let uu___2 = + FStarC_Compiler_Util.smap_fold deps2 + (fun k -> + fun dep_node1 -> + fun out -> + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Compiler_List.map dep_to_string + dep_node1.edges in + FStarC_Compiler_String.concat ";\n\t" uu___5 in + FStarC_Compiler_Util.format2 "%s -> [\n\t%s\n] " k + uu___4 in + uu___3 :: out) [] in + FStarC_Compiler_String.concat ";;\n" uu___2 in + FStarC_Compiler_Util.fprint outc "%s\n" [uu___1] +let (print_full : FStarC_Compiler_Util.out_channel -> deps -> unit) = + fun outc -> + fun deps1 -> + let pre_tag = FStarC_Options_Ext.get "dep_pretag" in + let sort_output_files orig_output_file_map = + let order = FStarC_Compiler_Util.mk_ref [] in + let remaining_output_files = + FStarC_Compiler_Util.smap_copy orig_output_file_map in + let visited_other_modules = + FStarC_Compiler_Util.smap_create (Prims.of_int (41)) in + let should_visit lc_module_name = + (let uu___ = + FStarC_Compiler_Util.smap_try_find remaining_output_files + lc_module_name in + FStarC_Compiler_Option.isSome uu___) || + (let uu___ = + FStarC_Compiler_Util.smap_try_find visited_other_modules + lc_module_name in + FStarC_Compiler_Option.isNone uu___) in + let mark_visiting lc_module_name = + let ml_file_opt = + FStarC_Compiler_Util.smap_try_find remaining_output_files + lc_module_name in + FStarC_Compiler_Util.smap_remove remaining_output_files + lc_module_name; + FStarC_Compiler_Util.smap_add visited_other_modules lc_module_name + true; + ml_file_opt in + let emit_output_file_opt ml_file_opt = + match ml_file_opt with + | FStar_Pervasives_Native.None -> () + | FStar_Pervasives_Native.Some ml_file -> + let uu___ = + let uu___1 = FStarC_Compiler_Effect.op_Bang order in ml_file + :: uu___1 in + FStarC_Compiler_Effect.op_Colon_Equals order uu___ in + let rec aux uu___ = + match uu___ with + | [] -> () + | lc_module_name::modules_to_extract -> + let visit_file file_opt = + match file_opt with + | FStar_Pervasives_Native.None -> () + | FStar_Pervasives_Native.Some file_name1 -> + let uu___1 = deps_try_find deps1.dep_graph file_name1 in + (match uu___1 with + | FStar_Pervasives_Native.None -> + let uu___2 = + FStarC_Compiler_Util.format2 + "Impossible: module %s: %s not found" + lc_module_name file_name1 in + failwith uu___2 + | FStar_Pervasives_Native.Some + { edges = immediate_deps; color = uu___2;_} -> + let immediate_deps1 = + FStarC_Compiler_List.map + (fun x -> + FStarC_Compiler_String.lowercase + (module_name_of_dep x)) immediate_deps in + aux immediate_deps1) in + ((let uu___2 = should_visit lc_module_name in + if uu___2 + then + let ml_file_opt = mark_visiting lc_module_name in + ((let uu___4 = implementation_of deps1 lc_module_name in + visit_file uu___4); + (let uu___5 = interface_of deps1 lc_module_name in + visit_file uu___5); + emit_output_file_opt ml_file_opt) + else ()); + aux modules_to_extract) in + let all_extracted_modules = + FStarC_Compiler_Util.smap_keys orig_output_file_map in + aux all_extracted_modules; + (let uu___1 = FStarC_Compiler_Effect.op_Bang order in + FStarC_Compiler_List.rev uu___1) in + let sb = + let uu___ = FStarC_BigInt.of_int_fs (Prims.of_int (10000)) in + FStarC_StringBuffer.create uu___ in + let pr str = let uu___ = FStarC_StringBuffer.add str sb in () in + let print_entry target first_dep all_deps = + pr target; pr ": "; pr first_dep; pr "\\\n\t"; pr all_deps; pr "\n\n" in + let keys = deps_keys deps1.dep_graph in + let no_fstar_stubs_file s = + let s1 = "FStar.Stubs." in + let s2 = "FStar." in + let l1 = FStarC_Compiler_String.length s1 in + let uu___ = + ((FStarC_Compiler_String.length s) >= l1) && + (let uu___1 = + FStarC_Compiler_String.substring s Prims.int_zero l1 in + uu___1 = s1) in + if uu___ + then + let uu___1 = + FStarC_Compiler_String.substring s l1 + ((FStarC_Compiler_String.length s) - l1) in + Prims.strcat s2 uu___1 + else s in + let output_file ext fst_file = + let basename = + let uu___ = + let uu___1 = FStarC_Compiler_Util.basename fst_file in + check_and_strip_suffix uu___1 in + FStarC_Compiler_Option.get uu___ in + let basename1 = no_fstar_stubs_file basename in + let ml_base_name = + FStarC_Compiler_Util.replace_chars basename1 46 "_" in + FStarC_Options.prepend_output_dir (Prims.strcat ml_base_name ext) in + let norm_path s = + FStarC_Compiler_Util.replace_chars + (FStarC_Compiler_Util.replace_chars s 92 "/") 32 "\\ " in + let output_fs_file f = + let uu___ = output_file ".fs" f in norm_path uu___ in + let output_ml_file f = + let uu___ = output_file ".ml" f in norm_path uu___ in + let output_krml_file f = + let uu___ = output_file ".krml" f in norm_path uu___ in + let output_cmx_file f = + let uu___ = output_file ".cmx" f in norm_path uu___ in + let cache_file f = let uu___ = cache_file_name f in norm_path uu___ in + let uu___ = + phase1 deps1.file_system_map deps1.dep_graph + deps1.interfaces_with_inlining true in + match uu___ with + | (widened, dep_graph) -> + let all_checked_files = + FStarC_Compiler_List.fold_left + (fun all_checked_files1 -> + fun file_name1 -> + let process_one_key uu___1 = + let dep_node1 = + let uu___2 = deps_try_find deps1.dep_graph file_name1 in + FStarC_Compiler_Option.get uu___2 in + let uu___2 = + let uu___3 = is_interface file_name1 in + if uu___3 + then + (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None) + else + (let uu___5 = + let uu___6 = lowercase_module_name file_name1 in + interface_of deps1 uu___6 in + match uu___5 with + | FStar_Pervasives_Native.None -> + (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None) + | FStar_Pervasives_Native.Some iface -> + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + deps_try_find deps1.dep_graph iface in + FStarC_Compiler_Option.get uu___9 in + uu___8.edges in + FStar_Pervasives_Native.Some uu___7 in + ((FStar_Pervasives_Native.Some iface), uu___6)) in + match uu___2 with + | (iface_fn, iface_deps) -> + let iface_deps1 = + FStarC_Compiler_Util.map_opt iface_deps + (FStarC_Compiler_List.filter + (fun iface_dep -> + let uu___3 = + FStarC_Compiler_Util.for_some + (dep_subsumed_by iface_dep) + dep_node1.edges in + Prims.op_Negation uu___3)) in + let norm_f = norm_path file_name1 in + let files = + FStarC_Compiler_List.map + (file_of_dep_aux true deps1.file_system_map + deps1.cmd_line_files) dep_node1.edges in + let files1 = + match iface_deps1 with + | FStar_Pervasives_Native.None -> files + | FStar_Pervasives_Native.Some iface_deps2 -> + let iface_files = + FStarC_Compiler_List.map + (file_of_dep_aux true + deps1.file_system_map + deps1.cmd_line_files) iface_deps2 in + FStarC_Compiler_Util.remove_dups + (fun x -> fun y -> x = y) + (FStarC_Compiler_List.op_At files + iface_files) in + let files2 = + if FStarC_Compiler_Util.is_some iface_fn + then + let iface_fn1 = + FStarC_Compiler_Util.must iface_fn in + let uu___3 = + FStarC_Compiler_List.filter + (fun f -> f <> iface_fn1) files1 in + let uu___4 = cache_file_name iface_fn1 in uu___4 + :: uu___3 + else files1 in + let files3 = + FStarC_Compiler_List.map norm_path files2 in + let files4 = + FStarC_Compiler_String.concat "\\\n\t" files3 in + let cache_file_name1 = cache_file file_name1 in + let all_checked_files2 = + let uu___3 = + let uu___4 = + let uu___5 = module_name_of_file file_name1 in + FStarC_Options.should_be_already_cached uu___5 in + Prims.op_Negation uu___4 in + if uu___3 + then + (print_entry cache_file_name1 norm_f files4; + cache_file_name1 + :: + all_checked_files1) + else all_checked_files1 in + let uu___3 = + let uu___4 = FStarC_Options.cmi () in + if uu___4 + then + profile + (fun uu___5 -> + let uu___6 = dep_graph_copy dep_graph in + topological_dependences_of' + deps1.file_system_map uu___6 + deps1.interfaces_with_inlining + [file_name1] widened) + "FStarC.Parser.Dep.topological_dependences_of_2" + else + (let maybe_widen_deps f_deps = + FStarC_Compiler_List.map + (fun dep -> + file_of_dep_aux false + deps1.file_system_map + deps1.cmd_line_files dep) f_deps in + let fst_files = + maybe_widen_deps dep_node1.edges in + let fst_files_from_iface = + match iface_deps1 with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some iface_deps2 -> + maybe_widen_deps iface_deps2 in + let uu___6 = + FStarC_Compiler_Util.remove_dups + (fun x -> fun y -> x = y) + (FStarC_Compiler_List.op_At fst_files + fst_files_from_iface) in + (uu___6, false)) in + (match uu___3 with + | (all_fst_files_dep, widened1) -> + let all_checked_fst_dep_files = + FStarC_Compiler_List.map cache_file + all_fst_files_dep in + let all_checked_fst_dep_files_string = + FStarC_Compiler_String.concat " \\\n\t" + all_checked_fst_dep_files in + ((let uu___5 = is_implementation file_name1 in + if uu___5 + then + ((let uu___7 = + (FStarC_Options.cmi ()) && widened1 in + if uu___7 + then + let mname = + lowercase_module_name file_name1 in + ((let uu___9 = + output_ml_file file_name1 in + print_entry uu___9 cache_file_name1 + all_checked_fst_dep_files_string); + (let uu___10 = + FStarC_Options.should_extract mname + FStarC_Options.FSharp in + if uu___10 + then + let uu___11 = + output_fs_file file_name1 in + print_entry uu___11 + cache_file_name1 + all_checked_fst_dep_files_string + else ()); + (let uu___10 = + output_krml_file file_name1 in + print_entry uu___10 cache_file_name1 + all_checked_fst_dep_files_string)) + else + (let mname = + lowercase_module_name file_name1 in + (let uu___10 = + output_ml_file file_name1 in + print_entry uu___10 cache_file_name1 + ""); + (let uu___11 = + FStarC_Options.should_extract mname + FStarC_Options.FSharp in + if uu___11 + then + let uu___12 = + output_fs_file file_name1 in + print_entry uu___12 + cache_file_name1 "" + else ()); + (let uu___11 = + output_krml_file file_name1 in + print_entry uu___11 cache_file_name1 + ""))); + (let cmx_files = + let extracted_fst_files = + FStarC_Compiler_List.filter + (fun df -> + (let uu___7 = + lowercase_module_name df in + let uu___8 = + lowercase_module_name + file_name1 in + uu___7 <> uu___8) && + (let uu___7 = + lowercase_module_name df in + FStarC_Options.should_extract + uu___7 FStarC_Options.OCaml)) + all_fst_files_dep in + FStarC_Compiler_List.map + output_cmx_file extracted_fst_files in + let uu___7 = + let uu___8 = + lowercase_module_name file_name1 in + FStarC_Options.should_extract uu___8 + FStarC_Options.OCaml in + if uu___7 + then + let cmx_files1 = + FStarC_Compiler_String.concat + "\\\n\t" cmx_files in + let uu___8 = output_cmx_file file_name1 in + let uu___9 = output_ml_file file_name1 in + print_entry uu___8 uu___9 cmx_files1 + else ())) + else + (let uu___7 = + (let uu___8 = + let uu___9 = + lowercase_module_name file_name1 in + has_implementation + deps1.file_system_map uu___9 in + Prims.op_Negation uu___8) && + (is_interface file_name1) in + if uu___7 + then + let uu___8 = + (FStarC_Options.cmi ()) && + (widened1 || true) in + (if uu___8 + then + let uu___9 = + output_krml_file file_name1 in + print_entry uu___9 cache_file_name1 + all_checked_fst_dep_files_string + else + (let uu___10 = + output_krml_file file_name1 in + print_entry uu___10 cache_file_name1 + "")) + else ())); + all_checked_files2)) in + profile process_one_key + "FStarC.Parser.Dep.process_one_key") [] keys in + let all_fst_files = + let uu___1 = FStarC_Compiler_List.filter is_implementation keys in + FStarC_Compiler_Util.sort_with FStarC_Compiler_String.compare + uu___1 in + let all_fsti_files = + let uu___1 = FStarC_Compiler_List.filter is_interface keys in + FStarC_Compiler_Util.sort_with FStarC_Compiler_String.compare + uu___1 in + let all_ml_files = + let ml_file_map = + FStarC_Compiler_Util.smap_create (Prims.of_int (41)) in + FStarC_Compiler_List.iter + (fun fst_file -> + let mname = lowercase_module_name fst_file in + let uu___2 = + FStarC_Options.should_extract mname FStarC_Options.OCaml in + if uu___2 + then + let uu___3 = output_ml_file fst_file in + FStarC_Compiler_Util.smap_add ml_file_map mname uu___3 + else ()) all_fst_files; + sort_output_files ml_file_map in + let all_fs_files = + let fs_file_map = + FStarC_Compiler_Util.smap_create (Prims.of_int (41)) in + FStarC_Compiler_List.iter + (fun fst_file -> + let mname = lowercase_module_name fst_file in + let uu___2 = + FStarC_Options.should_extract mname FStarC_Options.FSharp in + if uu___2 + then + let uu___3 = output_fs_file fst_file in + FStarC_Compiler_Util.smap_add fs_file_map mname uu___3 + else ()) all_fst_files; + sort_output_files fs_file_map in + let all_krml_files = + let krml_file_map = + FStarC_Compiler_Util.smap_create (Prims.of_int (41)) in + FStarC_Compiler_List.iter + (fun fst_file -> + let mname = lowercase_module_name fst_file in + let uu___2 = + FStarC_Options.should_extract mname FStarC_Options.Krml in + if uu___2 + then + let uu___3 = output_krml_file fst_file in + FStarC_Compiler_Util.smap_add krml_file_map mname uu___3 + else ()) keys; + sort_output_files krml_file_map in + let print_all tag files = + pr (Prims.strcat pre_tag tag); + pr "=\\\n\t"; + FStarC_Compiler_List.iter + (fun f -> pr (norm_path f); pr " \\\n\t") files; + pr "\n" in + (FStarC_Compiler_List.iter + (fun fsti -> + let mn = lowercase_module_name fsti in + let range_of_file fsti1 = + let r = + FStarC_Compiler_Range_Ops.set_file_of_range + FStarC_Compiler_Range_Type.dummyRange fsti1 in + let uu___2 = FStarC_Compiler_Range_Type.def_range r in + FStarC_Compiler_Range_Type.set_use_range r uu___2 in + let uu___2 = + let uu___3 = has_implementation deps1.file_system_map mn in + Prims.op_Negation uu___3 in + if uu___2 + then + let uu___3 = range_of_file fsti in + let uu___4 = + let uu___5 = module_name_of_file fsti in + FStarC_Compiler_Util.format1 + "Interface %s is admitted without an implementation" + uu___5 in + FStarC_Errors.log_issue + FStarC_Class_HasRange.hasRange_range uu___3 + FStarC_Errors_Codes.Warning_WarnOnUse () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4) + else ()) all_fsti_files; + print_all "ALL_FST_FILES" all_fst_files; + print_all "ALL_FSTI_FILES" all_fsti_files; + print_all "ALL_CHECKED_FILES" all_checked_files; + print_all "ALL_FS_FILES" all_fs_files; + print_all "ALL_ML_FILES" all_ml_files; + print_all "ALL_KRML_FILES" all_krml_files; + FStarC_StringBuffer.output_channel outc sb) +let (do_print : + FStarC_Compiler_Util.out_channel -> Prims.string -> deps -> unit) = + fun outc -> + fun fn -> + fun deps1 -> + let pref uu___ = + (let uu___2 = + let uu___3 = + FStarC_Compiler_Effect.op_Bang FStarC_Options._version in + [uu___3] in + FStarC_Compiler_Util.fprint outc + "# This .depend was generated by F* %s\n" uu___2); + (let uu___3 = + let uu___4 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_string) + FStarC_Compiler_Util.exec_name in + [uu___4] in + FStarC_Compiler_Util.fprint outc "# Executable: %s\n" uu___3); + (let uu___4 = + let uu___5 = + FStarC_Compiler_Effect.op_Bang FStarC_Options._commit in + [uu___5] in + FStarC_Compiler_Util.fprint outc "# Hash: %s\n" uu___4); + (let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Compiler_Util.getcwd () in + FStarC_Compiler_Util.normalize_file_path uu___8 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_string) uu___7 in + [uu___6] in + FStarC_Compiler_Util.fprint outc "# Running in directory %s\n" + uu___5); + (let uu___6 = + let uu___7 = + let uu___8 = FStarC_Compiler_Util.get_cmd_args () in + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_string)) uu___8 in + [uu___7] in + FStarC_Compiler_Util.fprint outc + "# Command line arguments: \"%s\"\n" uu___6); + FStarC_Compiler_Util.fprint outc "\n" [] in + let uu___ = FStarC_Options.dep () in + match uu___ with + | FStar_Pervasives_Native.Some "make" -> + (pref (); print_make outc deps1) + | FStar_Pervasives_Native.Some "full" -> + (pref (); + profile (fun uu___2 -> print_full outc deps1) + "FStarC.Parser.Deps.print_full_deps") + | FStar_Pervasives_Native.Some "graph" -> + print_graph outc fn deps1.dep_graph + | FStar_Pervasives_Native.Some "raw" -> print_raw outc deps1 + | FStar_Pervasives_Native.Some uu___1 -> + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_UnknownToolForDep () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "unknown tool for --dep\n") + | FStar_Pervasives_Native.None -> () +let (do_print_stdout : deps -> unit) = + fun deps1 -> do_print FStarC_Compiler_Util.stdout "" deps1 +let (do_print_file : deps -> Prims.string -> unit) = + fun deps1 -> + fun fn -> with_file_outchannel fn (fun outc -> do_print outc fn deps1) +let (print : deps -> unit) = + fun deps1 -> + let uu___ = FStarC_Options.output_deps_to () in + match uu___ with + | FStar_Pervasives_Native.Some s -> do_print_file deps1 s + | FStar_Pervasives_Native.None when + let uu___1 = FStarC_Options.dep () in + uu___1 = (FStar_Pervasives_Native.Some "graph") -> + do_print_file deps1 "dep.graph" + | FStar_Pervasives_Native.None -> do_print_stdout deps1 +let (module_has_interface : deps -> FStarC_Ident.lident -> Prims.bool) = + fun deps1 -> + fun module_name1 -> + let uu___ = + let uu___1 = FStarC_Ident.string_of_lid module_name1 in + FStarC_Compiler_String.lowercase uu___1 in + has_interface deps1.file_system_map uu___ +let (deps_has_implementation : deps -> FStarC_Ident.lident -> Prims.bool) = + fun deps1 -> + fun module_name1 -> + let m = + let uu___ = FStarC_Ident.string_of_lid module_name1 in + FStarC_Compiler_String.lowercase uu___ in + FStarC_Compiler_Util.for_some + (fun f -> + (is_implementation f) && + (let uu___ = + let uu___1 = module_name_of_file f in + FStarC_Compiler_String.lowercase uu___1 in + uu___ = m)) deps1.all_files \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Parser_Driver.ml b/ocaml/fstar-lib/generated/FStarC_Parser_Driver.ml new file mode 100644 index 00000000000..9a9f5e39a21 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Parser_Driver.ml @@ -0,0 +1,111 @@ +open Prims +let (is_cache_file : Prims.string -> Prims.bool) = + fun fn -> + let uu___ = FStarC_Compiler_Util.get_file_extension fn in + uu___ = ".cache" +type fragment = + | Empty + | Modul of FStarC_Parser_AST.modul + | Decls of FStarC_Parser_AST.decl Prims.list + | DeclsWithContent of (FStarC_Parser_AST.decl * + FStarC_Parser_ParseIt.code_fragment) Prims.list +let (uu___is_Empty : fragment -> Prims.bool) = + fun projectee -> match projectee with | Empty -> true | uu___ -> false +let (uu___is_Modul : fragment -> Prims.bool) = + fun projectee -> match projectee with | Modul _0 -> true | uu___ -> false +let (__proj__Modul__item___0 : fragment -> FStarC_Parser_AST.modul) = + fun projectee -> match projectee with | Modul _0 -> _0 +let (uu___is_Decls : fragment -> Prims.bool) = + fun projectee -> match projectee with | Decls _0 -> true | uu___ -> false +let (__proj__Decls__item___0 : fragment -> FStarC_Parser_AST.decl Prims.list) + = fun projectee -> match projectee with | Decls _0 -> _0 +let (uu___is_DeclsWithContent : fragment -> Prims.bool) = + fun projectee -> + match projectee with | DeclsWithContent _0 -> true | uu___ -> false +let (__proj__DeclsWithContent__item___0 : + fragment -> + (FStarC_Parser_AST.decl * FStarC_Parser_ParseIt.code_fragment) Prims.list) + = fun projectee -> match projectee with | DeclsWithContent _0 -> _0 +let (parse_fragment : + FStarC_Parser_ParseIt.lang_opts -> + FStarC_Parser_ParseIt.input_frag -> fragment) + = + fun lang_opt -> + fun frag -> + let uu___ = + FStarC_Parser_ParseIt.parse lang_opt + (FStarC_Parser_ParseIt.Toplevel frag) in + match uu___ with + | FStarC_Parser_ParseIt.ASTFragment + (FStar_Pervasives.Inl modul, uu___1) -> Modul modul + | FStarC_Parser_ParseIt.ASTFragment (FStar_Pervasives.Inr [], uu___1) + -> Empty + | FStarC_Parser_ParseIt.ASTFragment + (FStar_Pervasives.Inr decls, uu___1) -> Decls decls + | FStarC_Parser_ParseIt.IncrementalFragment (decls, uu___1, uu___2) -> + DeclsWithContent decls + | FStarC_Parser_ParseIt.ParseError (e, msg, r) -> + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range r e + () (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic msg) + | FStarC_Parser_ParseIt.Term uu___1 -> + failwith + "Impossible: parsing a Toplevel always results in an ASTFragment" +let (maybe_dump_module : FStarC_Parser_AST.modul -> unit) = + fun m -> + match m with + | FStarC_Parser_AST.Module (l, ds) -> + let uu___ = + let uu___1 = FStarC_Ident.string_of_lid l in + FStarC_Options.dump_module uu___1 in + if uu___ + then + let uu___1 = FStarC_Ident.string_of_lid l in + let uu___2 = + let uu___3 = + FStarC_Compiler_List.map + (FStarC_Class_Show.show FStarC_Parser_AST.showable_decl) ds in + FStarC_Compiler_String.concat "\n" uu___3 in + FStarC_Compiler_Util.print2 "Parsed module %s\n%s\n" uu___1 uu___2 + else () + | FStarC_Parser_AST.Interface (l, ds, uu___) -> + let uu___1 = + let uu___2 = FStarC_Ident.string_of_lid l in + FStarC_Options.dump_module uu___2 in + if uu___1 + then + let uu___2 = FStarC_Ident.string_of_lid l in + let uu___3 = + let uu___4 = + FStarC_Compiler_List.map + (FStarC_Class_Show.show FStarC_Parser_AST.showable_decl) ds in + FStarC_Compiler_String.concat "\n" uu___4 in + FStarC_Compiler_Util.print2 "Parsed module %s\n%s\n" uu___2 uu___3 + else () +let (parse_file : + Prims.string -> + (FStarC_Parser_AST.file * (Prims.string * + FStarC_Compiler_Range_Type.range) Prims.list)) + = + fun fn -> + let uu___ = + FStarC_Parser_ParseIt.parse FStar_Pervasives_Native.None + (FStarC_Parser_ParseIt.Filename fn) in + match uu___ with + | FStarC_Parser_ParseIt.ASTFragment (FStar_Pervasives.Inl ast, comments) + -> (ast, comments) + | FStarC_Parser_ParseIt.ASTFragment (FStar_Pervasives.Inr uu___1, uu___2) + -> + let msg = FStarC_Compiler_Util.format1 "%s: expected a module\n" fn in + let r = FStarC_Compiler_Range_Type.dummyRange in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_ModuleExpected () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic msg) + | FStarC_Parser_ParseIt.ParseError (e, msg, r) -> + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range r e () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic msg) + | FStarC_Parser_ParseIt.Term uu___1 -> + failwith + "Impossible: parsing a Filename always results in an ASTFragment" \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Parser_ToDocument.ml b/ocaml/fstar-lib/generated/FStarC_Parser_ToDocument.ml new file mode 100644 index 00000000000..be026a52a78 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Parser_ToDocument.ml @@ -0,0 +1,5144 @@ +open Prims +let (maybe_unthunk : FStarC_Parser_AST.term -> FStarC_Parser_AST.term) = + fun t -> + match t.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Abs (uu___::[], body) -> body + | uu___ -> t +let (min : Prims.int -> Prims.int -> Prims.int) = + fun x -> fun y -> if x > y then y else x +let (max : Prims.int -> Prims.int -> Prims.int) = + fun x -> fun y -> if x > y then x else y +let map_rev : 'a 'b . ('a -> 'b) -> 'a Prims.list -> 'b Prims.list = + fun f -> + fun l -> + let rec aux l1 acc = + match l1 with + | [] -> acc + | x::xs -> + let uu___ = let uu___1 = f x in uu___1 :: acc in aux xs uu___ in + aux l [] +let map_if_all : + 'a 'b . + ('a -> 'b FStar_Pervasives_Native.option) -> + 'a Prims.list -> 'b Prims.list FStar_Pervasives_Native.option + = + fun f -> + fun l -> + let rec aux l1 acc = + match l1 with + | [] -> acc + | x::xs -> + let uu___ = f x in + (match uu___ with + | FStar_Pervasives_Native.Some r -> aux xs (r :: acc) + | FStar_Pervasives_Native.None -> []) in + let r = aux l [] in + if (FStarC_Compiler_List.length l) = (FStarC_Compiler_List.length r) + then FStar_Pervasives_Native.Some r + else FStar_Pervasives_Native.None +let rec all : 'a . ('a -> Prims.bool) -> 'a Prims.list -> Prims.bool = + fun f -> + fun l -> + match l with + | [] -> true + | x::xs -> let uu___ = f x in if uu___ then all f xs else false +let (all1_explicit : + (FStarC_Parser_AST.term * FStarC_Parser_AST.imp) Prims.list -> Prims.bool) + = + fun args -> + (Prims.op_Negation (FStarC_Compiler_List.isEmpty args)) && + (FStarC_Compiler_Util.for_all + (fun uu___ -> + match uu___ with + | (uu___1, FStarC_Parser_AST.Nothing) -> true + | uu___1 -> false) args) +let (str : Prims.string -> FStarC_Pprint.document) = + fun s -> FStarC_Pprint.doc_of_string s +let default_or_map : + 'uuuuu 'uuuuu1 . + 'uuuuu -> + ('uuuuu1 -> 'uuuuu) -> 'uuuuu1 FStar_Pervasives_Native.option -> 'uuuuu + = + fun n -> + fun f -> + fun x -> + match x with + | FStar_Pervasives_Native.None -> n + | FStar_Pervasives_Native.Some x' -> f x' +let (prefix2 : + FStarC_Pprint.document -> FStarC_Pprint.document -> FStarC_Pprint.document) + = + fun prefix_ -> + fun body -> + FStarC_Pprint.prefix (Prims.of_int (2)) Prims.int_one prefix_ body +let (prefix2_nonempty : + FStarC_Pprint.document -> FStarC_Pprint.document -> FStarC_Pprint.document) + = + fun prefix_ -> + fun body -> + if body = FStarC_Pprint.empty then prefix_ else prefix2 prefix_ body +let (op_Hat_Slash_Plus_Hat : + FStarC_Pprint.document -> FStarC_Pprint.document -> FStarC_Pprint.document) + = fun prefix_ -> fun body -> prefix2 prefix_ body +let (jump2 : FStarC_Pprint.document -> FStarC_Pprint.document) = + fun body -> FStarC_Pprint.jump (Prims.of_int (2)) Prims.int_one body +let (infix2 : + FStarC_Pprint.document -> + FStarC_Pprint.document -> + FStarC_Pprint.document -> FStarC_Pprint.document) + = FStarC_Pprint.infix (Prims.of_int (2)) Prims.int_one +let (infix0 : + FStarC_Pprint.document -> + FStarC_Pprint.document -> + FStarC_Pprint.document -> FStarC_Pprint.document) + = FStarC_Pprint.infix Prims.int_zero Prims.int_one +let (break1 : FStarC_Pprint.document) = FStarC_Pprint.break_ Prims.int_one +let separate_break_map : + 'uuuuu . + FStarC_Pprint.document -> + ('uuuuu -> FStarC_Pprint.document) -> + 'uuuuu Prims.list -> FStarC_Pprint.document + = + fun sep -> + fun f -> + fun l -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Pprint.op_Hat_Hat sep break1 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___2 in + FStarC_Pprint.separate_map uu___1 f l in + FStarC_Pprint.group uu___ +let precede_break_separate_map : + 'uuuuu . + FStarC_Pprint.document -> + FStarC_Pprint.document -> + ('uuuuu -> FStarC_Pprint.document) -> + 'uuuuu Prims.list -> FStarC_Pprint.document + = + fun prec -> + fun sep -> + fun f -> + fun l -> + let uu___ = + let uu___1 = FStarC_Pprint.op_Hat_Hat prec FStarC_Pprint.space in + let uu___2 = let uu___3 = FStarC_Compiler_List.hd l in f uu___3 in + FStarC_Pprint.precede uu___1 uu___2 in + let uu___1 = + let uu___2 = FStarC_Compiler_List.tl l in + FStarC_Pprint.concat_map + (fun x -> + let uu___3 = + let uu___4 = + let uu___5 = f x in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___5 in + FStarC_Pprint.op_Hat_Hat sep uu___4 in + FStarC_Pprint.op_Hat_Hat break1 uu___3) uu___2 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 +let concat_break_map : + 'uuuuu . + ('uuuuu -> FStarC_Pprint.document) -> + 'uuuuu Prims.list -> FStarC_Pprint.document + = + fun f -> + fun l -> + let uu___ = + FStarC_Pprint.concat_map + (fun x -> + let uu___1 = f x in FStarC_Pprint.op_Hat_Hat uu___1 break1) l in + FStarC_Pprint.group uu___ +let (parens_with_nesting : FStarC_Pprint.document -> FStarC_Pprint.document) + = + fun contents -> + FStarC_Pprint.surround (Prims.of_int (2)) Prims.int_zero + FStarC_Pprint.lparen contents FStarC_Pprint.rparen +let (soft_parens_with_nesting : + FStarC_Pprint.document -> FStarC_Pprint.document) = + fun contents -> + FStarC_Pprint.soft_surround (Prims.of_int (2)) Prims.int_zero + FStarC_Pprint.lparen contents FStarC_Pprint.rparen +let (braces_with_nesting : FStarC_Pprint.document -> FStarC_Pprint.document) + = + fun contents -> + FStarC_Pprint.surround (Prims.of_int (2)) Prims.int_one + FStarC_Pprint.lbrace contents FStarC_Pprint.rbrace +let (soft_braces_with_nesting : + FStarC_Pprint.document -> FStarC_Pprint.document) = + fun contents -> + FStarC_Pprint.soft_surround (Prims.of_int (2)) Prims.int_one + FStarC_Pprint.lbrace contents FStarC_Pprint.rbrace +let (soft_braces_with_nesting_tight : + FStarC_Pprint.document -> FStarC_Pprint.document) = + fun contents -> + FStarC_Pprint.soft_surround (Prims.of_int (2)) Prims.int_zero + FStarC_Pprint.lbrace contents FStarC_Pprint.rbrace +let (brackets_with_nesting : + FStarC_Pprint.document -> FStarC_Pprint.document) = + fun contents -> + FStarC_Pprint.surround (Prims.of_int (2)) Prims.int_one + FStarC_Pprint.lbracket contents FStarC_Pprint.rbracket +let (soft_brackets_with_nesting : + FStarC_Pprint.document -> FStarC_Pprint.document) = + fun contents -> + FStarC_Pprint.soft_surround (Prims.of_int (2)) Prims.int_one + FStarC_Pprint.lbracket contents FStarC_Pprint.rbracket +let (soft_lens_access_with_nesting : + FStarC_Pprint.document -> FStarC_Pprint.document) = + fun contents -> + let uu___ = str "(|" in + let uu___1 = str "|)" in + FStarC_Pprint.soft_surround (Prims.of_int (2)) Prims.int_one uu___ + contents uu___1 +let (soft_brackets_lens_access_with_nesting : + FStarC_Pprint.document -> FStarC_Pprint.document) = + fun contents -> + let uu___ = str "[|" in + let uu___1 = str "|]" in + FStarC_Pprint.soft_surround (Prims.of_int (2)) Prims.int_one uu___ + contents uu___1 +let (soft_begin_end_with_nesting : + FStarC_Pprint.document -> FStarC_Pprint.document) = + fun contents -> + let uu___ = str "begin" in + let uu___1 = str "end" in + FStarC_Pprint.soft_surround (Prims.of_int (2)) Prims.int_one uu___ + contents uu___1 +let (tc_arg : FStarC_Pprint.document -> FStarC_Pprint.document) = + fun contents -> + let uu___ = str "{|" in + let uu___1 = str "|}" in + FStarC_Pprint.soft_surround (Prims.of_int (2)) Prims.int_one uu___ + contents uu___1 +let (is_tc_binder : FStarC_Parser_AST.binder -> Prims.bool) = + fun b -> + match b.FStarC_Parser_AST.aqual with + | FStar_Pervasives_Native.Some (FStarC_Parser_AST.TypeClassArg) -> true + | uu___ -> false +let (is_meta_qualifier : + FStarC_Parser_AST.arg_qualifier FStar_Pervasives_Native.option -> + Prims.bool) + = + fun aq -> + match aq with + | FStar_Pervasives_Native.Some (FStarC_Parser_AST.Meta uu___) -> true + | uu___ -> false +let (is_joinable_binder : FStarC_Parser_AST.binder -> Prims.bool) = + fun b -> + (let uu___ = is_tc_binder b in Prims.op_Negation uu___) && + (Prims.op_Negation (is_meta_qualifier b.FStarC_Parser_AST.aqual)) +let separate_map_last : + 'uuuuu . + FStarC_Pprint.document -> + (Prims.bool -> 'uuuuu -> FStarC_Pprint.document) -> + 'uuuuu Prims.list -> FStarC_Pprint.document + = + fun sep -> + fun f -> + fun es -> + let l = FStarC_Compiler_List.length es in + let es1 = + FStarC_Compiler_List.mapi + (fun i -> fun e -> f (i <> (l - Prims.int_one)) e) es in + FStarC_Pprint.separate sep es1 +let separate_break_map_last : + 'uuuuu . + FStarC_Pprint.document -> + (Prims.bool -> 'uuuuu -> FStarC_Pprint.document) -> + 'uuuuu Prims.list -> FStarC_Pprint.document + = + fun sep -> + fun f -> + fun l -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Pprint.op_Hat_Hat sep break1 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___2 in + separate_map_last uu___1 f l in + FStarC_Pprint.group uu___ +let separate_map_or_flow : + 'uuuuu . + FStarC_Pprint.document -> + ('uuuuu -> FStarC_Pprint.document) -> + 'uuuuu Prims.list -> FStarC_Pprint.document + = + fun sep -> + fun f -> + fun l -> + if (FStarC_Compiler_List.length l) < (Prims.of_int (10)) + then FStarC_Pprint.separate_map sep f l + else FStarC_Pprint.flow_map sep f l +let flow_map_last : + 'uuuuu . + FStarC_Pprint.document -> + (Prims.bool -> 'uuuuu -> FStarC_Pprint.document) -> + 'uuuuu Prims.list -> FStarC_Pprint.document + = + fun sep -> + fun f -> + fun es -> + let l = FStarC_Compiler_List.length es in + let es1 = + FStarC_Compiler_List.mapi + (fun i -> fun e -> f (i <> (l - Prims.int_one)) e) es in + FStarC_Pprint.flow sep es1 +let separate_map_or_flow_last : + 'uuuuu . + FStarC_Pprint.document -> + (Prims.bool -> 'uuuuu -> FStarC_Pprint.document) -> + 'uuuuu Prims.list -> FStarC_Pprint.document + = + fun sep -> + fun f -> + fun l -> + if (FStarC_Compiler_List.length l) < (Prims.of_int (10)) + then separate_map_last sep f l + else flow_map_last sep f l +let (separate_or_flow : + FStarC_Pprint.document -> + FStarC_Pprint.document Prims.list -> FStarC_Pprint.document) + = fun sep -> fun l -> separate_map_or_flow sep (fun x -> x) l +let (surround_maybe_empty : + Prims.int -> + Prims.int -> + FStarC_Pprint.document -> + FStarC_Pprint.document -> + FStarC_Pprint.document -> FStarC_Pprint.document) + = + fun n -> + fun b -> + fun doc1 -> + fun doc2 -> + fun doc3 -> + if doc2 = FStarC_Pprint.empty + then + let uu___ = FStarC_Pprint.op_Hat_Slash_Hat doc1 doc3 in + FStarC_Pprint.group uu___ + else FStarC_Pprint.surround n b doc1 doc2 doc3 +let soft_surround_separate_map : + 'uuuuu . + Prims.int -> + Prims.int -> + FStarC_Pprint.document -> + FStarC_Pprint.document -> + FStarC_Pprint.document -> + FStarC_Pprint.document -> + ('uuuuu -> FStarC_Pprint.document) -> + 'uuuuu Prims.list -> FStarC_Pprint.document + = + fun n -> + fun b -> + fun void_ -> + fun opening -> + fun sep -> + fun closing -> + fun f -> + fun xs -> + if xs = [] + then void_ + else + (let uu___1 = FStarC_Pprint.separate_map sep f xs in + FStarC_Pprint.soft_surround n b opening uu___1 closing) +let soft_surround_map_or_flow : + 'uuuuu . + Prims.int -> + Prims.int -> + FStarC_Pprint.document -> + FStarC_Pprint.document -> + FStarC_Pprint.document -> + FStarC_Pprint.document -> + ('uuuuu -> FStarC_Pprint.document) -> + 'uuuuu Prims.list -> FStarC_Pprint.document + = + fun n -> + fun b -> + fun void_ -> + fun opening -> + fun sep -> + fun closing -> + fun f -> + fun xs -> + if xs = [] + then void_ + else + (let uu___1 = separate_map_or_flow sep f xs in + FStarC_Pprint.soft_surround n b opening uu___1 closing) +let (is_unit : FStarC_Parser_AST.term -> Prims.bool) = + fun e -> + match e.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Const (FStarC_Const.Const_unit) -> true + | uu___ -> false +let (matches_var : + FStarC_Parser_AST.term -> FStarC_Ident.ident -> Prims.bool) = + fun t -> + fun x -> + match t.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Var y -> + let uu___ = FStarC_Ident.string_of_id x in + let uu___1 = FStarC_Ident.string_of_lid y in uu___ = uu___1 + | uu___ -> false +let (is_tuple_constructor : FStarC_Ident.lident -> Prims.bool) = + FStarC_Parser_Const.is_tuple_data_lid' +let (is_dtuple_constructor : FStarC_Ident.lident -> Prims.bool) = + FStarC_Parser_Const.is_dtuple_data_lid' +let (is_array : FStarC_Parser_AST.term -> Prims.bool) = + fun e -> + match e.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.App + ({ FStarC_Parser_AST.tm = FStarC_Parser_AST.Var lid; + FStarC_Parser_AST.range = uu___; + FStarC_Parser_AST.level = uu___1;_}, + l, FStarC_Parser_AST.Nothing) + -> + (FStarC_Ident.lid_equals lid FStarC_Parser_Const.array_of_list_lid) + && (FStarC_Parser_AST.uu___is_ListLiteral l.FStarC_Parser_AST.tm) + | uu___ -> false +let rec (is_ref_set : FStarC_Parser_AST.term -> Prims.bool) = + fun e -> + match e.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Var maybe_empty_lid -> + FStarC_Ident.lid_equals maybe_empty_lid FStarC_Parser_Const.set_empty + | FStarC_Parser_AST.App + ({ FStarC_Parser_AST.tm = FStarC_Parser_AST.Var maybe_singleton_lid; + FStarC_Parser_AST.range = uu___; + FStarC_Parser_AST.level = uu___1;_}, + { + FStarC_Parser_AST.tm = FStarC_Parser_AST.App + ({ + FStarC_Parser_AST.tm = FStarC_Parser_AST.Var + maybe_addr_of_lid; + FStarC_Parser_AST.range = uu___2; + FStarC_Parser_AST.level = uu___3;_}, + e1, FStarC_Parser_AST.Nothing); + FStarC_Parser_AST.range = uu___4; + FStarC_Parser_AST.level = uu___5;_}, + FStarC_Parser_AST.Nothing) + -> + (FStarC_Ident.lid_equals maybe_singleton_lid + FStarC_Parser_Const.set_singleton) + && + (FStarC_Ident.lid_equals maybe_addr_of_lid + FStarC_Parser_Const.heap_addr_of_lid) + | FStarC_Parser_AST.App + ({ + FStarC_Parser_AST.tm = FStarC_Parser_AST.App + ({ FStarC_Parser_AST.tm = FStarC_Parser_AST.Var maybe_union_lid; + FStarC_Parser_AST.range = uu___; + FStarC_Parser_AST.level = uu___1;_}, + e1, FStarC_Parser_AST.Nothing); + FStarC_Parser_AST.range = uu___2; + FStarC_Parser_AST.level = uu___3;_}, + e2, FStarC_Parser_AST.Nothing) + -> + ((FStarC_Ident.lid_equals maybe_union_lid + FStarC_Parser_Const.set_union) + && (is_ref_set e1)) + && (is_ref_set e2) + | uu___ -> false +let rec (extract_from_ref_set : + FStarC_Parser_AST.term -> FStarC_Parser_AST.term Prims.list) = + fun e -> + match e.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Var uu___ -> [] + | FStarC_Parser_AST.App + ({ FStarC_Parser_AST.tm = FStarC_Parser_AST.Var uu___; + FStarC_Parser_AST.range = uu___1; + FStarC_Parser_AST.level = uu___2;_}, + { + FStarC_Parser_AST.tm = FStarC_Parser_AST.App + ({ FStarC_Parser_AST.tm = FStarC_Parser_AST.Var uu___3; + FStarC_Parser_AST.range = uu___4; + FStarC_Parser_AST.level = uu___5;_}, + e1, FStarC_Parser_AST.Nothing); + FStarC_Parser_AST.range = uu___6; + FStarC_Parser_AST.level = uu___7;_}, + FStarC_Parser_AST.Nothing) + -> [e1] + | FStarC_Parser_AST.App + ({ + FStarC_Parser_AST.tm = FStarC_Parser_AST.App + ({ FStarC_Parser_AST.tm = FStarC_Parser_AST.Var uu___; + FStarC_Parser_AST.range = uu___1; + FStarC_Parser_AST.level = uu___2;_}, + e1, FStarC_Parser_AST.Nothing); + FStarC_Parser_AST.range = uu___3; + FStarC_Parser_AST.level = uu___4;_}, + e2, FStarC_Parser_AST.Nothing) + -> + let uu___5 = extract_from_ref_set e1 in + let uu___6 = extract_from_ref_set e2 in + FStarC_Compiler_List.op_At uu___5 uu___6 + | uu___ -> + let uu___1 = + let uu___2 = FStarC_Parser_AST.term_to_string e in + FStarC_Compiler_Util.format1 "Not a ref set %s" uu___2 in + failwith uu___1 +let (is_general_application : FStarC_Parser_AST.term -> Prims.bool) = + fun e -> + let uu___ = (is_array e) || (is_ref_set e) in Prims.op_Negation uu___ +let (is_general_construction : FStarC_Parser_AST.term -> Prims.bool) = + fun e -> + Prims.op_Negation + (FStarC_Parser_AST.uu___is_ListLiteral e.FStarC_Parser_AST.tm) +let (is_general_prefix_op : FStarC_Ident.ident -> Prims.bool) = + fun op -> + let op_starting_char = + let uu___ = FStarC_Ident.string_of_id op in + FStarC_Compiler_Util.char_at uu___ Prims.int_zero in + ((op_starting_char = 33) || (op_starting_char = 63)) || + ((op_starting_char = 126) && + (let uu___ = FStarC_Ident.string_of_id op in uu___ <> "~")) +let (head_and_args : + FStarC_Parser_AST.term -> + (FStarC_Parser_AST.term * (FStarC_Parser_AST.term * + FStarC_Parser_AST.imp) Prims.list)) + = + fun e -> + let rec aux e1 acc = + match e1.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.App (head, arg, imp) -> + aux head ((arg, imp) :: acc) + | uu___ -> (e1, acc) in + aux e [] +type associativity = + | Left + | Right + | NonAssoc +let (uu___is_Left : associativity -> Prims.bool) = + fun projectee -> match projectee with | Left -> true | uu___ -> false +let (uu___is_Right : associativity -> Prims.bool) = + fun projectee -> match projectee with | Right -> true | uu___ -> false +let (uu___is_NonAssoc : associativity -> Prims.bool) = + fun projectee -> match projectee with | NonAssoc -> true | uu___ -> false +type token = + | StartsWith of FStar_Char.char + | Exact of Prims.string + | UnicodeOperator +let (uu___is_StartsWith : token -> Prims.bool) = + fun projectee -> + match projectee with | StartsWith _0 -> true | uu___ -> false +let (__proj__StartsWith__item___0 : token -> FStar_Char.char) = + fun projectee -> match projectee with | StartsWith _0 -> _0 +let (uu___is_Exact : token -> Prims.bool) = + fun projectee -> match projectee with | Exact _0 -> true | uu___ -> false +let (__proj__Exact__item___0 : token -> Prims.string) = + fun projectee -> match projectee with | Exact _0 -> _0 +let (uu___is_UnicodeOperator : token -> Prims.bool) = + fun projectee -> + match projectee with | UnicodeOperator -> true | uu___ -> false +type associativity_level = (associativity * token Prims.list) +let (token_to_string : token -> Prims.string) = + fun uu___ -> + match uu___ with + | StartsWith c -> + Prims.strcat (FStarC_Compiler_Util.string_of_char c) ".*" + | Exact s -> s + | UnicodeOperator -> "" +let (is_non_latin_char : FStar_Char.char -> Prims.bool) = + fun s -> (FStarC_Compiler_Util.int_of_char s) > (Prims.of_int (0x024f)) +let (matches_token : Prims.string -> token -> Prims.bool) = + fun s -> + fun uu___ -> + match uu___ with + | StartsWith c -> + let uu___1 = FStarC_Compiler_String.get s Prims.int_zero in + uu___1 = c + | Exact s' -> s = s' + | UnicodeOperator -> + let uu___1 = FStarC_Compiler_String.get s Prims.int_zero in + is_non_latin_char uu___1 +let matches_level : + 'uuuuu . Prims.string -> ('uuuuu * token Prims.list) -> Prims.bool = + fun s -> + fun uu___ -> + match uu___ with + | (assoc_levels, tokens) -> + let uu___1 = FStarC_Compiler_List.tryFind (matches_token s) tokens in + uu___1 <> FStar_Pervasives_Native.None +let (opinfix4 : associativity_level) = (Right, [Exact "**"; UnicodeOperator]) +let (opinfix3 : associativity_level) = + (Left, [StartsWith 42; StartsWith 47; StartsWith 37]) +let (opinfix2 : associativity_level) = (Left, [StartsWith 43; StartsWith 45]) +let (minus_lvl : associativity_level) = (Left, [Exact "-"]) +let (opinfix1 : associativity_level) = + (Right, [StartsWith 64; StartsWith 94]) +let (pipe_right : associativity_level) = (Left, [Exact "|>"]) +let (opinfix0d : associativity_level) = (Left, [StartsWith 36]) +let (opinfix0c : associativity_level) = + (Left, [StartsWith 61; StartsWith 60; StartsWith 62]) +let (equal : associativity_level) = (Left, [Exact "="]) +let (opinfix0b : associativity_level) = (Left, [StartsWith 38]) +let (opinfix0a : associativity_level) = (Left, [StartsWith 124]) +let (colon_equals : associativity_level) = (NonAssoc, [Exact ":="]) +let (amp : associativity_level) = (Right, [Exact "&"]) +let (colon_colon : associativity_level) = (Right, [Exact "::"]) +let (level_associativity_spec : associativity_level Prims.list) = + [opinfix4; + opinfix3; + opinfix2; + opinfix1; + pipe_right; + opinfix0d; + opinfix0c; + opinfix0b; + opinfix0a; + colon_equals; + amp; + colon_colon] +let (level_table : + ((Prims.int * Prims.int * Prims.int) * token Prims.list) Prims.list) = + let levels_from_associativity l uu___ = + match uu___ with + | Left -> (l, l, (l - Prims.int_one)) + | Right -> ((l - Prims.int_one), l, l) + | NonAssoc -> ((l - Prims.int_one), l, (l - Prims.int_one)) in + FStarC_Compiler_List.mapi + (fun i -> + fun uu___ -> + match uu___ with + | (assoc, tokens) -> ((levels_from_associativity i assoc), tokens)) + level_associativity_spec +let (assign_levels : + associativity_level Prims.list -> + Prims.string -> (Prims.int * Prims.int * Prims.int)) + = + fun token_associativity_spec -> + fun s -> + let uu___ = FStarC_Compiler_List.tryFind (matches_level s) level_table in + match uu___ with + | FStar_Pervasives_Native.Some (assoc_levels, uu___1) -> assoc_levels + | uu___1 -> failwith (Prims.strcat "Unrecognized operator " s) +let max_level : 'uuuuu . ('uuuuu * token Prims.list) Prims.list -> Prims.int + = + fun l -> + let find_level_and_max n level = + let uu___ = + FStarC_Compiler_List.tryFind + (fun uu___1 -> + match uu___1 with + | (uu___2, tokens) -> + tokens = (FStar_Pervasives_Native.snd level)) level_table in + match uu___ with + | FStar_Pervasives_Native.Some ((uu___1, l1, uu___2), uu___3) -> + max n l1 + | FStar_Pervasives_Native.None -> + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Compiler_List.map token_to_string + (FStar_Pervasives_Native.snd level) in + FStarC_Compiler_String.concat "," uu___3 in + FStarC_Compiler_Util.format1 "Undefined associativity level %s" + uu___2 in + failwith uu___1 in + FStarC_Compiler_List.fold_left find_level_and_max Prims.int_zero l +let (levels : Prims.string -> (Prims.int * Prims.int * Prims.int)) = + fun op -> + let uu___ = assign_levels level_associativity_spec op in + match uu___ with + | (left, mine, right) -> + if op = "&" + then ((left - Prims.int_one), mine, right) + else (left, mine, right) +let (operatorInfix0ad12 : associativity_level Prims.list) = + [opinfix0a; opinfix0b; opinfix0c; opinfix0d; opinfix1; opinfix2] +let (is_operatorInfix0ad12 : FStarC_Ident.ident -> Prims.bool) = + fun op -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Ident.string_of_id op in matches_level uu___2 in + FStarC_Compiler_List.tryFind uu___1 operatorInfix0ad12 in + uu___ <> FStar_Pervasives_Native.None +let (is_operatorInfix34 : FStarC_Ident.ident -> Prims.bool) = + let opinfix34 = [opinfix3; opinfix4] in + fun op -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Ident.string_of_id op in matches_level uu___2 in + FStarC_Compiler_List.tryFind uu___1 opinfix34 in + uu___ <> FStar_Pervasives_Native.None +let (handleable_args_length : FStarC_Ident.ident -> Prims.int) = + fun op -> + let op_s = FStarC_Ident.string_of_id op in + let uu___ = + (is_general_prefix_op op) || (FStarC_Compiler_List.mem op_s ["-"; "~"]) in + if uu___ + then Prims.int_one + else + (let uu___2 = + ((is_operatorInfix0ad12 op) || (is_operatorInfix34 op)) || + (FStarC_Compiler_List.mem op_s + ["<==>"; + "==>"; + "\\/"; + "/\\"; + "="; + "|>"; + ":="; + ".()"; + ".[]"; + ".(||)"; + ".[||]"]) in + if uu___2 + then (Prims.of_int (2)) + else + if + FStarC_Compiler_List.mem op_s + [".()<-"; ".[]<-"; ".(||)<-"; ".[||]<-"] + then (Prims.of_int (3)) + else Prims.int_zero) +let handleable_op : + 'uuuuu . FStarC_Ident.ident -> 'uuuuu Prims.list -> Prims.bool = + fun op -> + fun args -> + match FStarC_Compiler_List.length args with + | uu___ when uu___ = Prims.int_zero -> true + | uu___ when uu___ = Prims.int_one -> + (is_general_prefix_op op) || + (let uu___1 = FStarC_Ident.string_of_id op in + FStarC_Compiler_List.mem uu___1 ["-"; "~"]) + | uu___ when uu___ = (Prims.of_int (2)) -> + ((is_operatorInfix0ad12 op) || (is_operatorInfix34 op)) || + (let uu___1 = FStarC_Ident.string_of_id op in + FStarC_Compiler_List.mem uu___1 + ["<==>"; + "==>"; + "\\/"; + "/\\"; + "="; + "|>"; + ":="; + ".()"; + ".[]"; + ".(||)"; + ".[||]"]) + | uu___ when uu___ = (Prims.of_int (3)) -> + let uu___1 = FStarC_Ident.string_of_id op in + FStarC_Compiler_List.mem uu___1 + [".()<-"; ".[]<-"; ".(||)<-"; ".[||]<-"] + | uu___ -> false +type annotation_style = + | Binders of (Prims.int * Prims.int * Prims.bool) + | Arrows of (Prims.int * Prims.int) +let (uu___is_Binders : annotation_style -> Prims.bool) = + fun projectee -> match projectee with | Binders _0 -> true | uu___ -> false +let (__proj__Binders__item___0 : + annotation_style -> (Prims.int * Prims.int * Prims.bool)) = + fun projectee -> match projectee with | Binders _0 -> _0 +let (uu___is_Arrows : annotation_style -> Prims.bool) = + fun projectee -> match projectee with | Arrows _0 -> true | uu___ -> false +let (__proj__Arrows__item___0 : annotation_style -> (Prims.int * Prims.int)) + = fun projectee -> match projectee with | Arrows _0 -> _0 +let (all_binders_annot : FStarC_Parser_AST.term -> Prims.bool) = + fun e -> + let is_binder_annot b = + match b.FStarC_Parser_AST.b with + | FStarC_Parser_AST.Annotated uu___ -> true + | uu___ -> false in + let rec all_binders e1 l = + match e1.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Product (bs, tgt) -> + let uu___ = FStarC_Compiler_List.for_all is_binder_annot bs in + if uu___ + then all_binders tgt (l + (FStarC_Compiler_List.length bs)) + else (false, Prims.int_zero) + | uu___ -> (true, (l + Prims.int_one)) in + let uu___ = all_binders e Prims.int_zero in + match uu___ with + | (b, l) -> if b && (l > Prims.int_one) then true else false +type catf = + FStarC_Pprint.document -> FStarC_Pprint.document -> FStarC_Pprint.document +let (cat_with_colon : + FStarC_Pprint.document -> FStarC_Pprint.document -> FStarC_Pprint.document) + = + fun x -> + fun y -> + let uu___ = FStarC_Pprint.op_Hat_Slash_Hat FStarC_Pprint.colon y in + FStarC_Pprint.op_Hat_Hat x uu___ +let (comment_stack : + (Prims.string * FStarC_Compiler_Range_Type.range) Prims.list + FStarC_Compiler_Effect.ref) + = FStarC_Compiler_Util.mk_ref [] +type decl_meta = + { + r: FStarC_Compiler_Range_Type.range ; + has_qs: Prims.bool ; + has_attrs: Prims.bool } +let (__proj__Mkdecl_meta__item__r : + decl_meta -> FStarC_Compiler_Range_Type.range) = + fun projectee -> match projectee with | { r; has_qs; has_attrs;_} -> r +let (__proj__Mkdecl_meta__item__has_qs : decl_meta -> Prims.bool) = + fun projectee -> match projectee with | { r; has_qs; has_attrs;_} -> has_qs +let (__proj__Mkdecl_meta__item__has_attrs : decl_meta -> Prims.bool) = + fun projectee -> + match projectee with | { r; has_qs; has_attrs;_} -> has_attrs +let (dummy_meta : decl_meta) = + { + r = FStarC_Compiler_Range_Type.dummyRange; + has_qs = false; + has_attrs = false + } +let with_comment : + 'uuuuu . + ('uuuuu -> FStarC_Pprint.document) -> + 'uuuuu -> FStarC_Compiler_Range_Type.range -> FStarC_Pprint.document + = + fun printer -> + fun tm -> + fun tmrange -> + let rec comments_before_pos acc print_pos lookahead_pos = + let uu___ = FStarC_Compiler_Effect.op_Bang comment_stack in + match uu___ with + | [] -> (acc, false) + | (c, crange)::cs -> + let comment = + let uu___1 = str c in + FStarC_Pprint.op_Hat_Hat uu___1 FStarC_Pprint.hardline in + let uu___1 = + FStarC_Compiler_Range_Ops.range_before_pos crange print_pos in + if uu___1 + then + (FStarC_Compiler_Effect.op_Colon_Equals comment_stack cs; + (let uu___3 = FStarC_Pprint.op_Hat_Hat acc comment in + comments_before_pos uu___3 print_pos lookahead_pos)) + else + (let uu___3 = + FStarC_Compiler_Range_Ops.range_before_pos crange + lookahead_pos in + (acc, uu___3)) in + let uu___ = + let uu___1 = + let uu___2 = FStarC_Compiler_Range_Ops.start_of_range tmrange in + FStarC_Compiler_Range_Ops.end_of_line uu___2 in + let uu___2 = FStarC_Compiler_Range_Ops.end_of_range tmrange in + comments_before_pos FStarC_Pprint.empty uu___1 uu___2 in + match uu___ with + | (comments, has_lookahead) -> + let printed_e = printer tm in + let comments1 = + if has_lookahead + then + let pos = FStarC_Compiler_Range_Ops.end_of_range tmrange in + let uu___1 = comments_before_pos comments pos pos in + FStar_Pervasives_Native.fst uu___1 + else comments in + if comments1 = FStarC_Pprint.empty + then printed_e + else + (let uu___2 = FStarC_Pprint.op_Hat_Hat comments1 printed_e in + FStarC_Pprint.group uu___2) +let with_comment_sep : + 'uuuuu 'uuuuu1 . + ('uuuuu -> 'uuuuu1) -> + 'uuuuu -> + FStarC_Compiler_Range_Type.range -> + (FStarC_Pprint.document * 'uuuuu1) + = + fun printer -> + fun tm -> + fun tmrange -> + let rec comments_before_pos acc print_pos lookahead_pos = + let uu___ = FStarC_Compiler_Effect.op_Bang comment_stack in + match uu___ with + | [] -> (acc, false) + | (c, crange)::cs -> + let comment = str c in + let uu___1 = + FStarC_Compiler_Range_Ops.range_before_pos crange print_pos in + if uu___1 + then + (FStarC_Compiler_Effect.op_Colon_Equals comment_stack cs; + (let uu___3 = + if acc = FStarC_Pprint.empty + then comment + else + (let uu___5 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline + comment in + FStarC_Pprint.op_Hat_Hat acc uu___5) in + comments_before_pos uu___3 print_pos lookahead_pos)) + else + (let uu___3 = + FStarC_Compiler_Range_Ops.range_before_pos crange + lookahead_pos in + (acc, uu___3)) in + let uu___ = + let uu___1 = + let uu___2 = FStarC_Compiler_Range_Ops.start_of_range tmrange in + FStarC_Compiler_Range_Ops.end_of_line uu___2 in + let uu___2 = FStarC_Compiler_Range_Ops.end_of_range tmrange in + comments_before_pos FStarC_Pprint.empty uu___1 uu___2 in + match uu___ with + | (comments, has_lookahead) -> + let printed_e = printer tm in + let comments1 = + if has_lookahead + then + let pos = FStarC_Compiler_Range_Ops.end_of_range tmrange in + let uu___1 = comments_before_pos comments pos pos in + FStar_Pervasives_Native.fst uu___1 + else comments in + (comments1, printed_e) +let rec (place_comments_until_pos : + Prims.int -> + Prims.int -> + FStarC_Compiler_Range_Type.pos -> + decl_meta -> + FStarC_Pprint.document -> + Prims.bool -> Prims.bool -> FStarC_Pprint.document) + = + fun k -> + fun lbegin -> + fun pos -> + fun meta_decl -> + fun doc -> + fun r -> + fun init -> + let uu___ = FStarC_Compiler_Effect.op_Bang comment_stack in + match uu___ with + | (comment, crange)::cs when + FStarC_Compiler_Range_Ops.range_before_pos crange pos -> + (FStarC_Compiler_Effect.op_Colon_Equals comment_stack cs; + (let lnum = + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Compiler_Range_Ops.start_of_range crange in + FStarC_Compiler_Range_Ops.line_of_pos uu___4 in + uu___3 - lbegin in + max k uu___2 in + let lnum1 = min (Prims.of_int (2)) lnum in + let doc1 = + let uu___2 = + let uu___3 = + FStarC_Pprint.repeat lnum1 FStarC_Pprint.hardline in + let uu___4 = str comment in + FStarC_Pprint.op_Hat_Hat uu___3 uu___4 in + FStarC_Pprint.op_Hat_Hat doc uu___2 in + let uu___2 = + let uu___3 = + FStarC_Compiler_Range_Ops.end_of_range crange in + FStarC_Compiler_Range_Ops.line_of_pos uu___3 in + place_comments_until_pos Prims.int_one uu___2 pos + meta_decl doc1 true init)) + | uu___1 -> + if doc = FStarC_Pprint.empty + then FStarC_Pprint.empty + else + (let lnum = + let uu___3 = + FStarC_Compiler_Range_Ops.line_of_pos pos in + uu___3 - lbegin in + let lnum1 = min (Prims.of_int (3)) lnum in + let lnum2 = + if meta_decl.has_qs || meta_decl.has_attrs + then lnum1 - Prims.int_one + else lnum1 in + let lnum3 = max k lnum2 in + let lnum4 = + if meta_decl.has_qs && meta_decl.has_attrs + then (Prims.of_int (2)) + else lnum3 in + let lnum5 = if init then (Prims.of_int (2)) else lnum4 in + let uu___3 = + FStarC_Pprint.repeat lnum5 FStarC_Pprint.hardline in + FStarC_Pprint.op_Hat_Hat doc uu___3) +let separate_map_with_comments : + 'uuuuu . + FStarC_Pprint.document -> + FStarC_Pprint.document -> + ('uuuuu -> FStarC_Pprint.document) -> + 'uuuuu Prims.list -> + ('uuuuu -> decl_meta) -> FStarC_Pprint.document + = + fun prefix -> + fun sep -> + fun f -> + fun xs -> + fun extract_meta -> + let fold_fun uu___ x = + match uu___ with + | (last_line, doc) -> + let meta_decl = extract_meta x in + let r = meta_decl.r in + let doc1 = + let uu___1 = FStarC_Compiler_Range_Ops.start_of_range r in + place_comments_until_pos Prims.int_one last_line uu___1 + meta_decl doc false false in + let uu___1 = + let uu___2 = FStarC_Compiler_Range_Ops.end_of_range r in + FStarC_Compiler_Range_Ops.line_of_pos uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = f x in FStarC_Pprint.op_Hat_Hat sep uu___4 in + FStarC_Pprint.op_Hat_Hat doc1 uu___3 in + (uu___1, uu___2) in + let uu___ = + let uu___1 = FStarC_Compiler_List.hd xs in + let uu___2 = FStarC_Compiler_List.tl xs in (uu___1, uu___2) in + match uu___ with + | (x, xs1) -> + let init = + let meta_decl = extract_meta x in + let uu___1 = + let uu___2 = + FStarC_Compiler_Range_Ops.end_of_range meta_decl.r in + FStarC_Compiler_Range_Ops.line_of_pos uu___2 in + let uu___2 = + let uu___3 = f x in + FStarC_Pprint.op_Hat_Hat prefix uu___3 in + (uu___1, uu___2) in + let uu___1 = FStarC_Compiler_List.fold_left fold_fun init xs1 in + FStar_Pervasives_Native.snd uu___1 +let separate_map_with_comments_kw : + 'uuuuu 'uuuuu1 . + 'uuuuu -> + 'uuuuu -> + ('uuuuu -> 'uuuuu1 -> FStarC_Pprint.document) -> + 'uuuuu1 Prims.list -> + ('uuuuu1 -> decl_meta) -> FStarC_Pprint.document + = + fun prefix -> + fun sep -> + fun f -> + fun xs -> + fun extract_meta -> + let fold_fun uu___ x = + match uu___ with + | (last_line, doc) -> + let meta_decl = extract_meta x in + let r = meta_decl.r in + let doc1 = + let uu___1 = FStarC_Compiler_Range_Ops.start_of_range r in + place_comments_until_pos Prims.int_one last_line uu___1 + meta_decl doc false false in + let uu___1 = + let uu___2 = FStarC_Compiler_Range_Ops.end_of_range r in + FStarC_Compiler_Range_Ops.line_of_pos uu___2 in + let uu___2 = + let uu___3 = f sep x in + FStarC_Pprint.op_Hat_Hat doc1 uu___3 in + (uu___1, uu___2) in + let uu___ = + let uu___1 = FStarC_Compiler_List.hd xs in + let uu___2 = FStarC_Compiler_List.tl xs in (uu___1, uu___2) in + match uu___ with + | (x, xs1) -> + let init = + let meta_decl = extract_meta x in + let uu___1 = + let uu___2 = + FStarC_Compiler_Range_Ops.end_of_range meta_decl.r in + FStarC_Compiler_Range_Ops.line_of_pos uu___2 in + let uu___2 = f prefix x in (uu___1, uu___2) in + let uu___1 = FStarC_Compiler_List.fold_left fold_fun init xs1 in + FStar_Pervasives_Native.snd uu___1 +let p_lidentOrOperator' : + 'uuuuu . + 'uuuuu -> + ('uuuuu -> Prims.string) -> + ('uuuuu -> FStarC_Pprint.document) -> FStarC_Pprint.document + = + fun l -> + fun s_l -> + fun p_l -> + let lstr = s_l l in + if FStarC_Compiler_Util.starts_with lstr "op_" + then + let uu___ = FStarC_Parser_AST.string_to_op lstr in + match uu___ with + | FStar_Pervasives_Native.None -> + let uu___1 = str "( " in + let uu___2 = + let uu___3 = p_l l in + let uu___4 = str " )" in + FStarC_Pprint.op_Hat_Hat uu___3 uu___4 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 + | FStar_Pervasives_Native.Some (s, uu___1) -> + let uu___2 = str "( " in + let uu___3 = + let uu___4 = str s in + let uu___5 = str " )" in + FStarC_Pprint.op_Hat_Hat uu___4 uu___5 in + FStarC_Pprint.op_Hat_Hat uu___2 uu___3 + else p_l l +let (string_of_id_or_underscore : + FStarC_Ident.ident -> FStarC_Pprint.document) = + fun lid -> + let uu___ = + (let uu___1 = FStarC_Ident.string_of_id lid in + FStarC_Compiler_Util.starts_with uu___1 FStarC_Ident.reserved_prefix) + && + (let uu___1 = FStarC_Options.print_real_names () in + Prims.op_Negation uu___1) in + if uu___ + then FStarC_Pprint.underscore + else (let uu___2 = FStarC_Ident.string_of_id lid in str uu___2) +let (text_of_lid_or_underscore : + FStarC_Ident.lident -> FStarC_Pprint.document) = + fun lid -> + let uu___ = + (let uu___1 = + let uu___2 = FStarC_Ident.ident_of_lid lid in + FStarC_Ident.string_of_id uu___2 in + FStarC_Compiler_Util.starts_with uu___1 FStarC_Ident.reserved_prefix) + && + (let uu___1 = FStarC_Options.print_real_names () in + Prims.op_Negation uu___1) in + if uu___ + then FStarC_Pprint.underscore + else (let uu___2 = FStarC_Ident.string_of_lid lid in str uu___2) +let (p_qlident : FStarC_Ident.lident -> FStarC_Pprint.document) = + fun lid -> text_of_lid_or_underscore lid +let (p_quident : FStarC_Ident.lident -> FStarC_Pprint.document) = + fun lid -> text_of_lid_or_underscore lid +let (p_ident : FStarC_Ident.ident -> FStarC_Pprint.document) = + fun lid -> string_of_id_or_underscore lid +let (p_lident : FStarC_Ident.ident -> FStarC_Pprint.document) = + fun lid -> string_of_id_or_underscore lid +let (p_uident : FStarC_Ident.ident -> FStarC_Pprint.document) = + fun lid -> string_of_id_or_underscore lid +let (p_tvar : FStarC_Ident.ident -> FStarC_Pprint.document) = + fun lid -> string_of_id_or_underscore lid +let (p_qlidentOrOperator : FStarC_Ident.lident -> FStarC_Pprint.document) = + fun lid -> p_lidentOrOperator' lid FStarC_Ident.string_of_lid p_qlident +let (p_lidentOrOperator : FStarC_Ident.ident -> FStarC_Pprint.document) = + fun lid -> p_lidentOrOperator' lid FStarC_Ident.string_of_id p_lident +let rec (p_decl : FStarC_Parser_AST.decl -> FStarC_Pprint.document) = + fun d -> + let qualifiers = + match ((d.FStarC_Parser_AST.quals), (d.FStarC_Parser_AST.d)) with + | ((FStarC_Parser_AST.Assumption)::[], FStarC_Parser_AST.Assume + (id, uu___)) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Ident.string_of_id id in + FStarC_Compiler_Util.char_at uu___3 Prims.int_zero in + FStarC_Compiler_Util.is_upper uu___2 in + if uu___1 + then + let uu___2 = p_qualifier FStarC_Parser_AST.Assumption in + FStarC_Pprint.op_Hat_Hat uu___2 FStarC_Pprint.space + else p_qualifiers d.FStarC_Parser_AST.quals + | uu___ -> p_qualifiers d.FStarC_Parser_AST.quals in + let uu___ = p_attributes true d.FStarC_Parser_AST.attrs in + let uu___1 = + let uu___2 = p_rawDecl d in FStarC_Pprint.op_Hat_Hat qualifiers uu___2 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 +and (p_attributes : + Prims.bool -> FStarC_Parser_AST.attributes_ -> FStarC_Pprint.document) = + fun isTopLevel -> + fun attrs -> + match attrs with + | [] -> FStarC_Pprint.empty + | uu___ -> + let uu___1 = + let uu___2 = str (if isTopLevel then "@@ " else "@@@ ") in + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = str "; " in + let uu___8 = + FStarC_Compiler_List.map + (p_noSeqTermAndComment false false) attrs in + FStarC_Pprint.flow uu___7 uu___8 in + FStarC_Pprint.op_Hat_Hat uu___6 FStarC_Pprint.rbracket in + FStarC_Pprint.align uu___5 in + FStarC_Pprint.op_Hat_Hat uu___4 + (if isTopLevel + then FStarC_Pprint.hardline + else FStarC_Pprint.empty) in + FStarC_Pprint.op_Hat_Hat uu___2 uu___3 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.lbracket uu___1 +and (p_justSig : FStarC_Parser_AST.decl -> FStarC_Pprint.document) = + fun d -> + match d.FStarC_Parser_AST.d with + | FStarC_Parser_AST.Val (lid, t) -> + let uu___ = + let uu___1 = str "val" in + let uu___2 = + let uu___3 = + let uu___4 = p_lidentOrOperator lid in + let uu___5 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space + FStarC_Pprint.colon in + FStarC_Pprint.op_Hat_Hat uu___4 uu___5 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___3 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + let uu___1 = p_typ false false t in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 + | FStarC_Parser_AST.TopLevelLet (uu___, lbs) -> + FStarC_Pprint.separate_map FStarC_Pprint.hardline + (fun lb -> + let uu___1 = let uu___2 = str "let" in p_letlhs uu___2 lb false in + FStarC_Pprint.group uu___1) lbs + | uu___ -> FStarC_Pprint.empty +and p_list : + 't . + ('t -> FStarC_Pprint.document) -> + FStarC_Pprint.document -> 't Prims.list -> FStarC_Pprint.document + = + fun f -> + fun sep -> + fun l -> + let rec p_list' uu___ = + match uu___ with + | [] -> FStarC_Pprint.empty + | x::[] -> f x + | x::xs -> + let uu___1 = f x in + let uu___2 = + let uu___3 = p_list' xs in + FStarC_Pprint.op_Hat_Hat sep uu___3 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + let uu___ = str "[" in + let uu___1 = + let uu___2 = p_list' l in + let uu___3 = str "]" in FStarC_Pprint.op_Hat_Hat uu___2 uu___3 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 +and (p_restriction : + FStarC_Syntax_Syntax.restriction -> FStarC_Pprint.document) = + fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.Unrestricted -> FStarC_Pprint.empty + | FStarC_Syntax_Syntax.AllowList ids -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = str ", " in + p_list + (fun uu___5 -> + match uu___5 with + | (id, renamed) -> + let uu___6 = p_ident id in + let uu___7 = FStarC_Pprint.optional p_ident renamed in + FStarC_Pprint.op_Hat_Slash_Hat uu___6 uu___7) uu___4 + ids in + FStarC_Pprint.op_Hat_Hat uu___3 FStarC_Pprint.rbrace in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.lbrace uu___2 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___1 +and (p_rawDecl : FStarC_Parser_AST.decl -> FStarC_Pprint.document) = + fun d -> + match d.FStarC_Parser_AST.d with + | FStarC_Parser_AST.Open (uid, r) -> + let uu___ = + let uu___1 = str "open" in + let uu___2 = + let uu___3 = p_quident uid in + let uu___4 = p_restriction r in + FStarC_Pprint.op_Hat_Slash_Hat uu___3 uu___4 in + FStarC_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | FStarC_Parser_AST.Include (uid, r) -> + let uu___ = + let uu___1 = str "include" in + let uu___2 = + let uu___3 = p_quident uid in + let uu___4 = p_restriction r in + FStarC_Pprint.op_Hat_Slash_Hat uu___3 uu___4 in + FStarC_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | FStarC_Parser_AST.Friend uid -> + let uu___ = + let uu___1 = str "friend" in + let uu___2 = p_quident uid in + FStarC_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | FStarC_Parser_AST.ModuleAbbrev (uid1, uid2) -> + let uu___ = + let uu___1 = str "module" in + let uu___2 = + let uu___3 = + let uu___4 = p_uident uid1 in + let uu___5 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space + FStarC_Pprint.equals in + FStarC_Pprint.op_Hat_Hat uu___4 uu___5 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___3 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + let uu___1 = p_quident uid2 in op_Hat_Slash_Plus_Hat uu___ uu___1 + | FStarC_Parser_AST.TopLevelModule uid -> + let uu___ = + let uu___1 = str "module" in + let uu___2 = + let uu___3 = p_quident uid in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___3 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | FStarC_Parser_AST.Tycon + (true, uu___, (FStarC_Parser_AST.TyconAbbrev + (uid, tpars, FStar_Pervasives_Native.None, t))::[]) + -> + let effect_prefix_doc = + let uu___1 = str "effect" in + let uu___2 = + let uu___3 = p_uident uid in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___3 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + let uu___1 = + let uu___2 = p_typars tpars in + FStarC_Pprint.surround (Prims.of_int (2)) Prims.int_one + effect_prefix_doc uu___2 FStarC_Pprint.equals in + let uu___2 = p_typ false false t in + op_Hat_Slash_Plus_Hat uu___1 uu___2 + | FStarC_Parser_AST.Tycon (false, tc, tcdefs) -> + let s = if tc then str "class" else str "type" in + let uu___ = + let uu___1 = FStarC_Compiler_List.hd tcdefs in + p_typeDeclWithKw s uu___1 in + let uu___1 = + let uu___2 = FStarC_Compiler_List.tl tcdefs in + FStarC_Pprint.concat_map + (fun x -> + let uu___3 = + let uu___4 = str "and" in p_typeDeclWithKw uu___4 x in + FStarC_Pprint.op_Hat_Hat break1 uu___3) uu___2 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 + | FStarC_Parser_AST.TopLevelLet (q, lbs) -> + let let_doc = + let uu___ = str "let" in + let uu___1 = p_letqualifier q in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 in + let uu___ = str "and" in + separate_map_with_comments_kw let_doc uu___ p_letbinding lbs + (fun uu___1 -> + match uu___1 with + | (p, t) -> + let uu___2 = + FStarC_Compiler_Range_Ops.union_ranges + p.FStarC_Parser_AST.prange t.FStarC_Parser_AST.range in + { r = uu___2; has_qs = false; has_attrs = false }) + | FStarC_Parser_AST.Val (lid, t) -> + let uu___ = + let uu___1 = str "val" in + let uu___2 = + let uu___3 = + let uu___4 = p_lidentOrOperator lid in + let uu___5 = sig_as_binders_if_possible t false in + FStarC_Pprint.op_Hat_Hat uu___4 uu___5 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___3 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | FStarC_Parser_AST.Assume (id, t) -> + let decl_keyword = + let uu___ = + let uu___1 = + let uu___2 = FStarC_Ident.string_of_id id in + FStarC_Compiler_Util.char_at uu___2 Prims.int_zero in + FStarC_Compiler_Util.is_upper uu___1 in + if uu___ + then FStarC_Pprint.empty + else + (let uu___2 = str "val" in + FStarC_Pprint.op_Hat_Hat uu___2 FStarC_Pprint.space) in + let uu___ = + let uu___1 = p_ident id in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = p_typ false false t in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___5 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.colon uu___4 in + FStarC_Pprint.group uu___3 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + FStarC_Pprint.op_Hat_Hat decl_keyword uu___ + | FStarC_Parser_AST.Exception (uid, t_opt) -> + let uu___ = str "exception" in + let uu___1 = + let uu___2 = + let uu___3 = p_uident uid in + let uu___4 = + FStarC_Pprint.optional + (fun t -> + let uu___5 = + let uu___6 = str "of" in + let uu___7 = p_typ false false t in + op_Hat_Slash_Plus_Hat uu___6 uu___7 in + FStarC_Pprint.op_Hat_Hat break1 uu___5) t_opt in + FStarC_Pprint.op_Hat_Hat uu___3 uu___4 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___2 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 + | FStarC_Parser_AST.NewEffect ne -> + let uu___ = str "new_effect" in + let uu___1 = + let uu___2 = p_newEffect ne in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___2 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 + | FStarC_Parser_AST.SubEffect se -> + let uu___ = str "sub_effect" in + let uu___1 = + let uu___2 = p_subEffect se in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___2 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 + | FStarC_Parser_AST.LayeredEffect ne -> + let uu___ = str "layered_effect" in + let uu___1 = + let uu___2 = p_newEffect ne in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___2 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 + | FStarC_Parser_AST.Polymonadic_bind (l1, l2, l3, t) -> + let uu___ = str "polymonadic_bind" in + let uu___1 = + let uu___2 = + let uu___3 = p_quident l1 in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = p_quident l2 in + let uu___8 = + let uu___9 = + let uu___10 = str "|>" in + let uu___11 = + let uu___12 = p_quident l3 in + let uu___13 = + let uu___14 = p_simpleTerm false false t in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.equals + uu___14 in + FStarC_Pprint.op_Hat_Hat uu___12 uu___13 in + FStarC_Pprint.op_Hat_Hat uu___10 uu___11 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.rparen uu___9 in + FStarC_Pprint.op_Hat_Hat uu___7 uu___8 in + FStarC_Pprint.op_Hat_Hat break1 uu___6 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.comma uu___5 in + FStarC_Pprint.op_Hat_Hat uu___3 uu___4 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.lparen uu___2 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 + | FStarC_Parser_AST.Pragma p -> p_pragma p + | FStarC_Parser_AST.Tycon (true, uu___, uu___1) -> + failwith + "Effect abbreviation is expected to be defined by an abbreviation" + | FStarC_Parser_AST.Splice (is_typed, ids, t) -> + let uu___ = str "%splice" in + let uu___1 = + let uu___2 = if is_typed then str "_t" else FStarC_Pprint.empty in + let uu___3 = + let uu___4 = let uu___5 = str ";" in p_list p_uident uu___5 ids in + let uu___5 = + let uu___6 = p_term false false t in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___6 in + FStarC_Pprint.op_Hat_Hat uu___4 uu___5 in + FStarC_Pprint.op_Hat_Hat uu___2 uu___3 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 + | FStarC_Parser_AST.DeclSyntaxExtension (tag, blob, blob_rng, start_rng) + -> + let uu___ = FStarC_Pprint.doc_of_string (Prims.strcat "```" tag) in + let uu___1 = + let uu___2 = FStarC_Pprint.arbitrary_string blob in + let uu___3 = FStarC_Pprint.doc_of_string "```" in + FStarC_Pprint.op_Hat_Hat uu___2 uu___3 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 + | FStarC_Parser_AST.DeclToBeDesugared tbs -> + let uu___ = + tbs.FStarC_Parser_AST.to_string tbs.FStarC_Parser_AST.blob in + FStarC_Pprint.arbitrary_string uu___ +and (p_pragma : FStarC_Parser_AST.pragma -> FStarC_Pprint.document) = + fun uu___ -> + match uu___ with + | FStarC_Parser_AST.ShowOptions -> str "#show-options" + | FStarC_Parser_AST.SetOptions s -> + let uu___1 = str "#set-options" in + let uu___2 = + let uu___3 = let uu___4 = str s in FStarC_Pprint.dquotes uu___4 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___3 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 + | FStarC_Parser_AST.ResetOptions s_opt -> + let uu___1 = str "#reset-options" in + let uu___2 = + FStarC_Pprint.optional + (fun s -> + let uu___3 = + let uu___4 = str s in FStarC_Pprint.dquotes uu___4 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___3) s_opt in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 + | FStarC_Parser_AST.PushOptions s_opt -> + let uu___1 = str "#push-options" in + let uu___2 = + FStarC_Pprint.optional + (fun s -> + let uu___3 = + let uu___4 = str s in FStarC_Pprint.dquotes uu___4 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___3) s_opt in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 + | FStarC_Parser_AST.PopOptions -> str "#pop-options" + | FStarC_Parser_AST.RestartSolver -> str "#restart-solver" + | FStarC_Parser_AST.PrintEffectsGraph -> str "#print-effects-graph" +and (p_typars : + FStarC_Parser_AST.binder Prims.list -> FStarC_Pprint.document) = + fun bs -> p_binders true bs +and (p_typeDeclWithKw : + FStarC_Pprint.document -> FStarC_Parser_AST.tycon -> FStarC_Pprint.document) + = + fun kw -> + fun typedecl -> + let uu___ = p_typeDecl kw typedecl in + match uu___ with + | (comm, decl, body, pre) -> + if comm = FStarC_Pprint.empty + then let uu___1 = pre body in FStarC_Pprint.op_Hat_Hat decl uu___1 + else + (let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = pre body in + FStarC_Pprint.op_Hat_Slash_Hat uu___5 comm in + FStarC_Pprint.op_Hat_Hat decl uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline body in + FStarC_Pprint.op_Hat_Hat comm uu___8 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline uu___7 in + FStarC_Pprint.nest (Prims.of_int (2)) uu___6 in + FStarC_Pprint.op_Hat_Hat decl uu___5 in + FStarC_Pprint.ifflat uu___3 uu___4 in + FStarC_Pprint.group uu___2) +and (p_typeDecl : + FStarC_Pprint.document -> + FStarC_Parser_AST.tycon -> + (FStarC_Pprint.document * FStarC_Pprint.document * + FStarC_Pprint.document * + (FStarC_Pprint.document -> FStarC_Pprint.document))) + = + fun pre -> + fun uu___ -> + match uu___ with + | FStarC_Parser_AST.TyconAbstract (lid, bs, typ_opt) -> + let uu___1 = p_typeDeclPrefix pre false lid bs typ_opt in + (FStarC_Pprint.empty, uu___1, FStarC_Pprint.empty, ((fun x -> x))) + | FStarC_Parser_AST.TyconAbbrev (lid, bs, typ_opt, t) -> + let uu___1 = p_typ_sep false false t in + (match uu___1 with + | (comm, doc) -> + let uu___2 = p_typeDeclPrefix pre true lid bs typ_opt in + (comm, uu___2, doc, jump2)) + | FStarC_Parser_AST.TyconRecord + (lid, bs, typ_opt, attrs, record_field_decls) -> + let uu___1 = p_typeDeclPrefix pre true lid bs typ_opt in + let uu___2 = + let uu___3 = p_attributes false attrs in + let uu___4 = p_typeDeclRecord record_field_decls in + FStarC_Pprint.op_Hat_Hat uu___3 uu___4 in + (FStarC_Pprint.empty, uu___1, uu___2, + ((fun d -> FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space d))) + | FStarC_Parser_AST.TyconVariant (lid, bs, typ_opt, ct_decls) -> + let p_constructorBranchAndComments uu___1 = + match uu___1 with + | (uid, payload, attrs) -> + let range = + let uu___2 = + let uu___3 = FStarC_Ident.range_of_id uid in + let uu___4 = + FStarC_Compiler_Util.bind_opt payload + (fun uu___5 -> + match uu___5 with + | FStarC_Parser_AST.VpOfNotation t -> + FStar_Pervasives_Native.Some + (t.FStarC_Parser_AST.range) + | FStarC_Parser_AST.VpArbitrary t -> + FStar_Pervasives_Native.Some + (t.FStarC_Parser_AST.range) + | FStarC_Parser_AST.VpRecord (record, uu___6) -> + FStar_Pervasives_Native.None) in + FStarC_Compiler_Util.dflt uu___3 uu___4 in + FStarC_Compiler_Range_Ops.extend_to_end_of_line uu___2 in + let uu___2 = + with_comment_sep p_constructorBranch (uid, payload, attrs) + range in + (match uu___2 with + | (comm, ctor) -> + inline_comment_or_above comm ctor FStarC_Pprint.empty) in + let datacon_doc = + FStarC_Pprint.separate_map FStarC_Pprint.hardline + p_constructorBranchAndComments ct_decls in + let uu___1 = p_typeDeclPrefix pre true lid bs typ_opt in + (FStarC_Pprint.empty, uu___1, datacon_doc, jump2) +and (p_typeDeclRecord : + FStarC_Parser_AST.tycon_record -> FStarC_Pprint.document) = + fun fields -> + let p_recordField ps uu___ = + match uu___ with + | (lid, aq, attrs, t) -> + let uu___1 = + let uu___2 = + FStarC_Compiler_Range_Ops.extend_to_end_of_line + t.FStarC_Parser_AST.range in + with_comment_sep (p_recordFieldDecl ps) (lid, aq, attrs, t) + uu___2 in + (match uu___1 with + | (comm, field) -> + let sep = + if ps then FStarC_Pprint.semi else FStarC_Pprint.empty in + inline_comment_or_above comm field sep) in + let uu___ = separate_map_last FStarC_Pprint.hardline p_recordField fields in + braces_with_nesting uu___ +and (p_typeDeclPrefix : + FStarC_Pprint.document -> + Prims.bool -> + FStarC_Ident.ident -> + FStarC_Parser_AST.binder Prims.list -> + FStarC_Parser_AST.knd FStar_Pervasives_Native.option -> + FStarC_Pprint.document) + = + fun kw -> + fun eq -> + fun lid -> + fun bs -> + fun typ_opt -> + let with_kw cont = + let lid_doc = p_ident lid in + let kw_lid = + let uu___ = FStarC_Pprint.op_Hat_Slash_Hat kw lid_doc in + FStarC_Pprint.group uu___ in + cont kw_lid in + let typ = + let maybe_eq = + if eq then FStarC_Pprint.equals else FStarC_Pprint.empty in + match typ_opt with + | FStar_Pervasives_Native.None -> maybe_eq + | FStar_Pervasives_Native.Some t -> + let uu___ = + let uu___1 = + let uu___2 = p_typ false false t in + FStarC_Pprint.op_Hat_Slash_Hat uu___2 maybe_eq in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___1 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.colon uu___ in + if bs = [] + then with_kw (fun n -> prefix2 n typ) + else + (let binders = p_binders_list true bs in + with_kw + (fun n -> + let uu___1 = + let uu___2 = FStarC_Pprint.flow break1 binders in + prefix2 n uu___2 in + prefix2 uu___1 typ)) +and (p_recordFieldDecl : + Prims.bool -> + (FStarC_Ident.ident * FStarC_Parser_AST.aqual * + FStarC_Parser_AST.attributes_ * FStarC_Parser_AST.term) -> + FStarC_Pprint.document) + = + fun ps -> + fun uu___ -> + match uu___ with + | (lid, aq, attrs, t) -> + let uu___1 = + let uu___2 = FStarC_Pprint.optional p_aqual aq in + let uu___3 = + let uu___4 = p_attributes false attrs in + let uu___5 = + let uu___6 = p_lidentOrOperator lid in + let uu___7 = + let uu___8 = p_typ ps false t in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.colon uu___8 in + FStarC_Pprint.op_Hat_Hat uu___6 uu___7 in + FStarC_Pprint.op_Hat_Hat uu___4 uu___5 in + FStarC_Pprint.op_Hat_Hat uu___2 uu___3 in + FStarC_Pprint.group uu___1 +and (p_constructorBranch : + (FStarC_Ident.ident * FStarC_Parser_AST.constructor_payload + FStar_Pervasives_Native.option * FStarC_Parser_AST.attributes_) -> + FStarC_Pprint.document) + = + fun uu___ -> + match uu___ with + | (uid, variant, attrs) -> + let h isOf t = + let uu___1 = if isOf then str "of" else FStarC_Pprint.colon in + let uu___2 = + let uu___3 = p_typ false false t in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___3 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = p_attributes false attrs in + let uu___6 = p_uident uid in + FStarC_Pprint.op_Hat_Hat uu___5 uu___6 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___4 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.bar uu___3 in + FStarC_Pprint.group uu___2 in + let uu___2 = + default_or_map FStarC_Pprint.empty + (fun payload -> + let uu___3 = + let uu___4 = + match payload with + | FStarC_Parser_AST.VpOfNotation t -> h true t + | FStarC_Parser_AST.VpArbitrary t -> h false t + | FStarC_Parser_AST.VpRecord (r, t) -> + let uu___5 = p_typeDeclRecord r in + let uu___6 = + default_or_map FStarC_Pprint.empty (h false) t in + FStarC_Pprint.op_Hat_Hat uu___5 uu___6 in + FStarC_Pprint.group uu___4 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___3) variant in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 +and (p_letlhs : + FStarC_Pprint.document -> + (FStarC_Parser_AST.pattern * FStarC_Parser_AST.term) -> + Prims.bool -> FStarC_Pprint.document) + = + fun kw -> + fun uu___ -> + fun inner_let -> + match uu___ with + | (pat, uu___1) -> + let uu___2 = + match pat.FStarC_Parser_AST.pat with + | FStarC_Parser_AST.PatAscribed + (pat1, (t, FStar_Pervasives_Native.None)) -> + (pat1, + (FStar_Pervasives_Native.Some (t, FStarC_Pprint.empty))) + | FStarC_Parser_AST.PatAscribed + (pat1, (t, FStar_Pervasives_Native.Some tac)) -> + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = str "by" in + let uu___9 = + let uu___10 = p_atomicTerm (maybe_unthunk tac) in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space + uu___10 in + FStarC_Pprint.op_Hat_Hat uu___8 uu___9 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___7 in + FStarC_Pprint.group uu___6 in + (t, uu___5) in + FStar_Pervasives_Native.Some uu___4 in + (pat1, uu___3) + | uu___3 -> (pat, FStar_Pervasives_Native.None) in + (match uu___2 with + | (pat1, ascr) -> + (match pat1.FStarC_Parser_AST.pat with + | FStarC_Parser_AST.PatApp + ({ + FStarC_Parser_AST.pat = FStarC_Parser_AST.PatVar + (lid, uu___3, uu___4); + FStarC_Parser_AST.prange = uu___5;_}, + pats) + -> + let ascr_doc = + match ascr with + | FStar_Pervasives_Native.Some (t, tac) -> + let uu___6 = sig_as_binders_if_possible t true in + FStarC_Pprint.op_Hat_Hat uu___6 tac + | FStar_Pervasives_Native.None -> FStarC_Pprint.empty in + let uu___6 = + if inner_let + then + let uu___7 = pats_as_binders_if_possible pats in + match uu___7 with | (bs, style) -> (bs, style) + else + (let uu___8 = pats_as_binders_if_possible pats in + match uu___8 with | (bs, style) -> (bs, style)) in + (match uu___6 with + | (terms, style) -> + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = p_lidentOrOperator lid in + let uu___11 = + format_sig style terms ascr_doc true true in + FStarC_Pprint.op_Hat_Hat uu___10 uu___11 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space + uu___9 in + FStarC_Pprint.op_Hat_Hat kw uu___8 in + FStarC_Pprint.group uu___7) + | uu___3 -> + let ascr_doc = + match ascr with + | FStar_Pervasives_Native.Some (t, tac) -> + let uu___4 = + let uu___5 = + let uu___6 = + p_typ_top + (Arrows + ((Prims.of_int (2)), + (Prims.of_int (2)))) false false t in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.colon + uu___6 in + FStarC_Pprint.group uu___5 in + FStarC_Pprint.op_Hat_Hat uu___4 tac + | FStar_Pervasives_Native.None -> FStarC_Pprint.empty in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = p_tuplePattern pat1 in + FStarC_Pprint.op_Hat_Slash_Hat kw uu___7 in + FStarC_Pprint.group uu___6 in + FStarC_Pprint.op_Hat_Hat uu___5 ascr_doc in + FStarC_Pprint.group uu___4)) +and (p_letbinding : + FStarC_Pprint.document -> + (FStarC_Parser_AST.pattern * FStarC_Parser_AST.term) -> + FStarC_Pprint.document) + = + fun kw -> + fun uu___ -> + match uu___ with + | (pat, e) -> + let doc_pat = p_letlhs kw (pat, e) false in + let uu___1 = p_term_sep false false e in + (match uu___1 with + | (comm, doc_expr) -> + let doc_expr1 = + inline_comment_or_above comm doc_expr FStarC_Pprint.empty in + let uu___2 = + let uu___3 = + FStarC_Pprint.op_Hat_Slash_Hat FStarC_Pprint.equals + doc_expr1 in + FStarC_Pprint.op_Hat_Slash_Hat doc_pat uu___3 in + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = jump2 doc_expr1 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.equals uu___7 in + FStarC_Pprint.group uu___6 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___5 in + FStarC_Pprint.op_Hat_Hat doc_pat uu___4 in + FStarC_Pprint.ifflat uu___2 uu___3) +and (p_term_list : + Prims.bool -> + Prims.bool -> FStarC_Parser_AST.term Prims.list -> FStarC_Pprint.document) + = + fun ps -> + fun pb -> + fun l -> + let rec aux uu___ = + match uu___ with + | [] -> FStarC_Pprint.empty + | x::[] -> p_term ps pb x + | x::xs -> + let uu___1 = p_term ps pb x in + let uu___2 = + let uu___3 = str ";" in + let uu___4 = aux xs in FStarC_Pprint.op_Hat_Hat uu___3 uu___4 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + let uu___ = str "[" in + let uu___1 = + let uu___2 = aux l in + let uu___3 = str "]" in FStarC_Pprint.op_Hat_Hat uu___2 uu___3 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 +and (p_newEffect : FStarC_Parser_AST.effect_decl -> FStarC_Pprint.document) = + fun uu___ -> + match uu___ with + | FStarC_Parser_AST.RedefineEffect (lid, bs, t) -> + p_effectRedefinition lid bs t + | FStarC_Parser_AST.DefineEffect (lid, bs, t, eff_decls) -> + p_effectDefinition lid bs t eff_decls +and (p_effectRedefinition : + FStarC_Ident.ident -> + FStarC_Parser_AST.binder Prims.list -> + FStarC_Parser_AST.term -> FStarC_Pprint.document) + = + fun uid -> + fun bs -> + fun t -> + let uu___ = p_uident uid in + let uu___1 = p_binders true bs in + let uu___2 = + let uu___3 = p_simpleTerm false false t in + prefix2 FStarC_Pprint.equals uu___3 in + surround_maybe_empty (Prims.of_int (2)) Prims.int_one uu___ uu___1 + uu___2 +and (p_effectDefinition : + FStarC_Ident.ident -> + FStarC_Parser_AST.binder Prims.list -> + FStarC_Parser_AST.term -> + FStarC_Parser_AST.decl Prims.list -> FStarC_Pprint.document) + = + fun uid -> + fun bs -> + fun t -> + fun eff_decls -> + let binders = p_binders true bs in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = p_uident uid in + let uu___4 = p_binders true bs in + let uu___5 = + let uu___6 = p_typ false false t in + prefix2 FStarC_Pprint.colon uu___6 in + surround_maybe_empty (Prims.of_int (2)) Prims.int_one uu___3 + uu___4 uu___5 in + FStarC_Pprint.group uu___2 in + let uu___2 = + let uu___3 = str "with" in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.semi + FStarC_Pprint.space in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline + uu___9 in + separate_map_last uu___8 p_effectDecl eff_decls in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___7 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___6 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline uu___5 in + FStarC_Pprint.op_Hat_Hat uu___3 uu___4 in + FStarC_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in + braces_with_nesting uu___ +and (p_effectDecl : + Prims.bool -> FStarC_Parser_AST.decl -> FStarC_Pprint.document) = + fun ps -> + fun d -> + match d.FStarC_Parser_AST.d with + | FStarC_Parser_AST.Tycon + (false, uu___, (FStarC_Parser_AST.TyconAbbrev + (lid, [], FStar_Pervasives_Native.None, e))::[]) + -> + let uu___1 = + let uu___2 = p_lident lid in + let uu___3 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space + FStarC_Pprint.equals in + FStarC_Pprint.op_Hat_Hat uu___2 uu___3 in + let uu___2 = p_simpleTerm ps false e in prefix2 uu___1 uu___2 + | uu___ -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Parser_AST.showable_decl d in + FStarC_Compiler_Util.format1 + "Not a declaration of an effect member... or at least I hope so : %s" + uu___2 in + failwith uu___1 +and (p_subEffect : FStarC_Parser_AST.lift -> FStarC_Pprint.document) = + fun lift -> + let lift_op_doc = + let lifts = + match lift.FStarC_Parser_AST.lift_op with + | FStarC_Parser_AST.NonReifiableLift t -> [("lift_wp", t)] + | FStarC_Parser_AST.ReifiableLift (t1, t2) -> + [("lift_wp", t1); ("lift", t2)] + | FStarC_Parser_AST.LiftForFree t -> [("lift", t)] in + let p_lift ps uu___ = + match uu___ with + | (kwd, t) -> + let uu___1 = + let uu___2 = str kwd in + let uu___3 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space + FStarC_Pprint.equals in + FStarC_Pprint.op_Hat_Hat uu___2 uu___3 in + let uu___2 = p_simpleTerm ps false t in prefix2 uu___1 uu___2 in + separate_break_map_last FStarC_Pprint.semi p_lift lifts in + let uu___ = + let uu___1 = + let uu___2 = p_quident lift.FStarC_Parser_AST.msource in + let uu___3 = + let uu___4 = str "~>" in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___4 in + FStarC_Pprint.op_Hat_Hat uu___2 uu___3 in + let uu___2 = p_quident lift.FStarC_Parser_AST.mdest in + prefix2 uu___1 uu___2 in + let uu___1 = + let uu___2 = braces_with_nesting lift_op_doc in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___2 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 +and (p_qualifier : FStarC_Parser_AST.qualifier -> FStarC_Pprint.document) = + fun uu___ -> + match uu___ with + | FStarC_Parser_AST.Private -> str "private" + | FStarC_Parser_AST.Noeq -> str "noeq" + | FStarC_Parser_AST.Unopteq -> str "unopteq" + | FStarC_Parser_AST.Assumption -> str "assume" + | FStarC_Parser_AST.DefaultEffect -> str "default" + | FStarC_Parser_AST.TotalEffect -> str "total" + | FStarC_Parser_AST.Effect_qual -> FStarC_Pprint.empty + | FStarC_Parser_AST.New -> str "new" + | FStarC_Parser_AST.Inline -> str "inline" + | FStarC_Parser_AST.Visible -> FStarC_Pprint.empty + | FStarC_Parser_AST.Unfold_for_unification_and_vcgen -> str "unfold" + | FStarC_Parser_AST.Inline_for_extraction -> str "inline_for_extraction" + | FStarC_Parser_AST.Irreducible -> str "irreducible" + | FStarC_Parser_AST.NoExtract -> str "noextract" + | FStarC_Parser_AST.Reifiable -> str "reifiable" + | FStarC_Parser_AST.Reflectable -> str "reflectable" + | FStarC_Parser_AST.Opaque -> str "opaque" + | FStarC_Parser_AST.Logic -> str "logic" +and (p_qualifiers : FStarC_Parser_AST.qualifiers -> FStarC_Pprint.document) = + fun qs -> + match qs with + | [] -> FStarC_Pprint.empty + | q::[] -> + let uu___ = p_qualifier q in + FStarC_Pprint.op_Hat_Hat uu___ FStarC_Pprint.hardline + | uu___ -> + let uu___1 = + let uu___2 = FStarC_Compiler_List.map p_qualifier qs in + FStarC_Pprint.flow break1 uu___2 in + FStarC_Pprint.op_Hat_Hat uu___1 FStarC_Pprint.hardline +and (p_letqualifier : + FStarC_Parser_AST.let_qualifier -> FStarC_Pprint.document) = + fun uu___ -> + match uu___ with + | FStarC_Parser_AST.Rec -> + let uu___1 = str "rec" in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___1 + | FStarC_Parser_AST.NoLetQualifier -> FStarC_Pprint.empty +and (p_aqual : FStarC_Parser_AST.arg_qualifier -> FStarC_Pprint.document) = + fun uu___ -> + match uu___ with + | FStarC_Parser_AST.Implicit -> str "#" + | FStarC_Parser_AST.Equality -> str "$" + | FStarC_Parser_AST.Meta t -> + let t1 = + match t.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Abs (uu___1, e) -> e + | uu___1 -> + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Parser_AST.unit_const t.FStarC_Parser_AST.range in + (t, uu___4, FStarC_Parser_AST.Nothing) in + FStarC_Parser_AST.App uu___3 in + FStarC_Parser_AST.mk_term uu___2 t.FStarC_Parser_AST.range + FStarC_Parser_AST.Expr in + let uu___1 = str "#[" in + let uu___2 = + let uu___3 = p_term false false t1 in + let uu___4 = + let uu___5 = str "]" in FStarC_Pprint.op_Hat_Hat uu___5 break1 in + FStarC_Pprint.op_Hat_Hat uu___3 uu___4 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 + | FStarC_Parser_AST.TypeClassArg -> FStarC_Pprint.empty +and (p_disjunctivePattern : + FStarC_Parser_AST.pattern -> FStarC_Pprint.document) = + fun p -> + match p.FStarC_Parser_AST.pat with + | FStarC_Parser_AST.PatOr pats -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.bar FStarC_Pprint.space in + FStarC_Pprint.op_Hat_Hat break1 uu___2 in + FStarC_Pprint.separate_map uu___1 p_tuplePattern pats in + FStarC_Pprint.group uu___ + | uu___ -> p_tuplePattern p +and (p_tuplePattern : FStarC_Parser_AST.pattern -> FStarC_Pprint.document) = + fun p -> + match p.FStarC_Parser_AST.pat with + | FStarC_Parser_AST.PatTuple (pats, false) -> + let uu___ = + let uu___1 = FStarC_Pprint.op_Hat_Hat FStarC_Pprint.comma break1 in + FStarC_Pprint.separate_map uu___1 p_constructorPattern pats in + FStarC_Pprint.group uu___ + | uu___ -> p_constructorPattern p +and (p_constructorPattern : + FStarC_Parser_AST.pattern -> FStarC_Pprint.document) = + fun p -> + match p.FStarC_Parser_AST.pat with + | FStarC_Parser_AST.PatApp + ({ FStarC_Parser_AST.pat = FStarC_Parser_AST.PatName maybe_cons_lid; + FStarC_Parser_AST.prange = uu___;_}, + hd::tl::[]) + when + FStarC_Ident.lid_equals maybe_cons_lid FStarC_Parser_Const.cons_lid + -> + let uu___1 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.colon FStarC_Pprint.colon in + let uu___2 = p_constructorPattern hd in + let uu___3 = p_constructorPattern tl in infix0 uu___1 uu___2 uu___3 + | FStarC_Parser_AST.PatApp + ({ FStarC_Parser_AST.pat = FStarC_Parser_AST.PatName uid; + FStarC_Parser_AST.prange = uu___;_}, + pats) + -> + let uu___1 = p_quident uid in + let uu___2 = FStarC_Pprint.separate_map break1 p_atomicPattern pats in + prefix2 uu___1 uu___2 + | uu___ -> p_atomicPattern p +and (p_atomicPattern : FStarC_Parser_AST.pattern -> FStarC_Pprint.document) = + fun p -> + match p.FStarC_Parser_AST.pat with + | FStarC_Parser_AST.PatAscribed (pat, (t, FStar_Pervasives_Native.None)) + -> + (match ((pat.FStarC_Parser_AST.pat), (t.FStarC_Parser_AST.tm)) with + | (FStarC_Parser_AST.PatVar (lid, aqual, attrs), + FStarC_Parser_AST.Refine + ({ FStarC_Parser_AST.b = FStarC_Parser_AST.Annotated (lid', t1); + FStarC_Parser_AST.brange = uu___; + FStarC_Parser_AST.blevel = uu___1; + FStarC_Parser_AST.aqual = uu___2; + FStarC_Parser_AST.battributes = uu___3;_}, + phi)) when + let uu___4 = FStarC_Ident.string_of_id lid in + let uu___5 = FStarC_Ident.string_of_id lid' in uu___4 = uu___5 + -> + let uu___4 = + let uu___5 = p_ident lid in + p_refinement aqual attrs uu___5 t1 phi in + soft_parens_with_nesting uu___4 + | (FStarC_Parser_AST.PatWild (aqual, attrs), + FStarC_Parser_AST.Refine + ({ FStarC_Parser_AST.b = FStarC_Parser_AST.NoName t1; + FStarC_Parser_AST.brange = uu___; + FStarC_Parser_AST.blevel = uu___1; + FStarC_Parser_AST.aqual = uu___2; + FStarC_Parser_AST.battributes = uu___3;_}, + phi)) -> + let uu___4 = + p_refinement aqual attrs FStarC_Pprint.underscore t1 phi in + soft_parens_with_nesting uu___4 + | (FStarC_Parser_AST.PatVar (uu___, aqual, uu___1), uu___2) -> + let wrap = + if + aqual = + (FStar_Pervasives_Native.Some + FStarC_Parser_AST.TypeClassArg) + then tc_arg + else soft_parens_with_nesting in + let uu___3 = + let uu___4 = p_tuplePattern pat in + let uu___5 = + let uu___6 = p_tmEqNoRefinement t in + FStarC_Pprint.op_Hat_Slash_Hat FStarC_Pprint.colon uu___6 in + FStarC_Pprint.op_Hat_Hat uu___4 uu___5 in + wrap uu___3 + | (FStarC_Parser_AST.PatWild (aqual, uu___), uu___1) -> + let wrap = + if + aqual = + (FStar_Pervasives_Native.Some + FStarC_Parser_AST.TypeClassArg) + then tc_arg + else soft_parens_with_nesting in + let uu___2 = + let uu___3 = p_tuplePattern pat in + let uu___4 = + let uu___5 = p_tmEqNoRefinement t in + FStarC_Pprint.op_Hat_Slash_Hat FStarC_Pprint.colon uu___5 in + FStarC_Pprint.op_Hat_Hat uu___3 uu___4 in + wrap uu___2 + | uu___ -> + let uu___1 = + let uu___2 = p_tuplePattern pat in + let uu___3 = + let uu___4 = p_tmEqNoRefinement t in + FStarC_Pprint.op_Hat_Slash_Hat FStarC_Pprint.colon uu___4 in + FStarC_Pprint.op_Hat_Hat uu___2 uu___3 in + soft_parens_with_nesting uu___1) + | FStarC_Parser_AST.PatList pats -> + let uu___ = separate_break_map FStarC_Pprint.semi p_tuplePattern pats in + FStarC_Pprint.surround (Prims.of_int (2)) Prims.int_zero + FStarC_Pprint.lbracket uu___ FStarC_Pprint.rbracket + | FStarC_Parser_AST.PatRecord pats -> + let p_recordFieldPat uu___ = + match uu___ with + | (lid, pat) -> + let uu___1 = p_qlident lid in + let uu___2 = p_tuplePattern pat in + infix2 FStarC_Pprint.equals uu___1 uu___2 in + let uu___ = + separate_break_map FStarC_Pprint.semi p_recordFieldPat pats in + soft_braces_with_nesting uu___ + | FStarC_Parser_AST.PatTuple (pats, true) -> + let uu___ = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.lparen FStarC_Pprint.bar in + let uu___1 = + separate_break_map FStarC_Pprint.comma p_constructorPattern pats in + let uu___2 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.bar FStarC_Pprint.rparen in + FStarC_Pprint.surround (Prims.of_int (2)) Prims.int_one uu___ uu___1 + uu___2 + | FStarC_Parser_AST.PatTvar (tv, arg_qualifier_opt, attrs) -> p_tvar tv + | FStarC_Parser_AST.PatOp op -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Ident.string_of_id op in str uu___3 in + let uu___3 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space + FStarC_Pprint.rparen in + FStarC_Pprint.op_Hat_Hat uu___2 uu___3 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___1 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.lparen uu___ + | FStarC_Parser_AST.PatWild (aqual, attrs) -> + let uu___ = FStarC_Pprint.optional p_aqual aqual in + let uu___1 = + let uu___2 = p_attributes false attrs in + FStarC_Pprint.op_Hat_Hat uu___2 FStarC_Pprint.underscore in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 + | FStarC_Parser_AST.PatConst c -> p_constant c + | FStarC_Parser_AST.PatVQuote e -> + let uu___ = + let uu___1 = str "`%" in + let uu___2 = p_noSeqTermAndComment false false e in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | FStarC_Parser_AST.PatVar (lid, aqual, attrs) -> + let uu___ = FStarC_Pprint.optional p_aqual aqual in + let uu___1 = + let uu___2 = p_attributes false attrs in + let uu___3 = p_lident lid in FStarC_Pprint.op_Hat_Hat uu___2 uu___3 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 + | FStarC_Parser_AST.PatName uid -> p_quident uid + | FStarC_Parser_AST.PatOr uu___ -> failwith "Inner or pattern !" + | FStarC_Parser_AST.PatApp + ({ FStarC_Parser_AST.pat = FStarC_Parser_AST.PatName uu___; + FStarC_Parser_AST.prange = uu___1;_}, + uu___2) + -> let uu___3 = p_tuplePattern p in soft_parens_with_nesting uu___3 + | FStarC_Parser_AST.PatTuple (uu___, false) -> + let uu___1 = p_tuplePattern p in soft_parens_with_nesting uu___1 + | uu___ -> + let uu___1 = + let uu___2 = FStarC_Parser_AST.pat_to_string p in + FStarC_Compiler_Util.format1 "Invalid pattern %s" uu___2 in + failwith uu___1 +and (is_typ_tuple : FStarC_Parser_AST.term -> Prims.bool) = + fun e -> + match e.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Op (id, uu___) when + let uu___1 = FStarC_Ident.string_of_id id in uu___1 = "*" -> true + | uu___ -> false +and (p_binder : + Prims.bool -> FStarC_Parser_AST.binder -> FStarC_Pprint.document) = + fun is_atomic -> + fun b -> + let is_tc = is_tc_binder b in + let uu___ = p_binder' false (is_atomic && (Prims.op_Negation is_tc)) b in + match uu___ with + | (b', t') -> + let d = + match t' with + | FStar_Pervasives_Native.Some (typ, catf1) -> catf1 b' typ + | FStar_Pervasives_Native.None -> b' in + if is_tc then tc_arg d else d +and (p_binder' : + Prims.bool -> + Prims.bool -> + FStarC_Parser_AST.binder -> + (FStarC_Pprint.document * (FStarC_Pprint.document * catf) + FStar_Pervasives_Native.option)) + = + fun no_pars -> + fun is_atomic -> + fun b -> + match b.FStarC_Parser_AST.b with + | FStarC_Parser_AST.Variable lid -> + let uu___ = + let uu___1 = + FStarC_Pprint.optional p_aqual b.FStarC_Parser_AST.aqual in + let uu___2 = + let uu___3 = + p_attributes false b.FStarC_Parser_AST.battributes in + let uu___4 = p_lident lid in + FStarC_Pprint.op_Hat_Hat uu___3 uu___4 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + (uu___, FStar_Pervasives_Native.None) + | FStarC_Parser_AST.TVariable lid -> + let uu___ = + let uu___1 = p_attributes false b.FStarC_Parser_AST.battributes in + let uu___2 = p_lident lid in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + (uu___, FStar_Pervasives_Native.None) + | FStarC_Parser_AST.Annotated (lid, t) -> + let uu___ = + match t.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Refine + ({ + FStarC_Parser_AST.b = FStarC_Parser_AST.Annotated + (lid', t1); + FStarC_Parser_AST.brange = uu___1; + FStarC_Parser_AST.blevel = uu___2; + FStarC_Parser_AST.aqual = uu___3; + FStarC_Parser_AST.battributes = uu___4;_}, + phi) + when + let uu___5 = FStarC_Ident.string_of_id lid in + let uu___6 = FStarC_Ident.string_of_id lid' in + uu___5 = uu___6 -> + let uu___5 = p_lident lid in + p_refinement' b.FStarC_Parser_AST.aqual + b.FStarC_Parser_AST.battributes uu___5 t1 phi + | uu___1 -> + let t' = + let uu___2 = is_typ_tuple t in + if uu___2 + then + let uu___3 = p_tmFormula t in + soft_parens_with_nesting uu___3 + else p_tmFormula t in + let uu___2 = + let uu___3 = + FStarC_Pprint.optional p_aqual + b.FStarC_Parser_AST.aqual in + let uu___4 = + let uu___5 = + p_attributes false b.FStarC_Parser_AST.battributes in + let uu___6 = p_lident lid in + FStarC_Pprint.op_Hat_Hat uu___5 uu___6 in + FStarC_Pprint.op_Hat_Hat uu___3 uu___4 in + (uu___2, t') in + (match uu___ with + | (b', t') -> + let catf1 = + if + is_atomic || + ((is_meta_qualifier b.FStarC_Parser_AST.aqual) && + (Prims.op_Negation no_pars)) + then + fun x -> + fun y -> + let uu___1 = + let uu___2 = + let uu___3 = cat_with_colon x y in + FStarC_Pprint.op_Hat_Hat uu___3 + FStarC_Pprint.rparen in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.lparen + uu___2 in + FStarC_Pprint.group uu___1 + else + (fun x -> + fun y -> + let uu___2 = cat_with_colon x y in + FStarC_Pprint.group uu___2) in + (b', (FStar_Pervasives_Native.Some (t', catf1)))) + | FStarC_Parser_AST.TAnnotated uu___ -> + failwith "Is this still used ?" + | FStarC_Parser_AST.NoName t -> + (match t.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Refine + ({ FStarC_Parser_AST.b = FStarC_Parser_AST.NoName t1; + FStarC_Parser_AST.brange = uu___; + FStarC_Parser_AST.blevel = uu___1; + FStarC_Parser_AST.aqual = uu___2; + FStarC_Parser_AST.battributes = uu___3;_}, + phi) + -> + let uu___4 = + p_refinement' b.FStarC_Parser_AST.aqual + b.FStarC_Parser_AST.battributes FStarC_Pprint.underscore + t1 phi in + (match uu___4 with + | (b', t') -> + (b', + (FStar_Pervasives_Native.Some (t', cat_with_colon)))) + | uu___ -> + let pref = + let uu___1 = + FStarC_Pprint.optional p_aqual b.FStarC_Parser_AST.aqual in + let uu___2 = + p_attributes false b.FStarC_Parser_AST.battributes in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + let p_Tm = if is_atomic then p_atomicTerm else p_appTerm in + let uu___1 = + let uu___2 = p_Tm t in + FStarC_Pprint.op_Hat_Hat pref uu___2 in + (uu___1, FStar_Pervasives_Native.None)) +and (p_refinement : + FStarC_Parser_AST.arg_qualifier FStar_Pervasives_Native.option -> + FStarC_Parser_AST.term Prims.list -> + FStarC_Pprint.document -> + FStarC_Parser_AST.term -> + FStarC_Parser_AST.term -> FStarC_Pprint.document) + = + fun aqual_opt -> + fun attrs -> + fun binder -> + fun t -> + fun phi -> + let uu___ = p_refinement' aqual_opt attrs binder t phi in + match uu___ with | (b, typ) -> cat_with_colon b typ +and (p_refinement' : + FStarC_Parser_AST.arg_qualifier FStar_Pervasives_Native.option -> + FStarC_Parser_AST.term Prims.list -> + FStarC_Pprint.document -> + FStarC_Parser_AST.term -> + FStarC_Parser_AST.term -> + (FStarC_Pprint.document * FStarC_Pprint.document)) + = + fun aqual_opt -> + fun attrs -> + fun binder -> + fun t -> + fun phi -> + let is_t_atomic = + match t.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Construct uu___ -> false + | FStarC_Parser_AST.App uu___ -> false + | FStarC_Parser_AST.Op uu___ -> false + | uu___ -> true in + let uu___ = p_noSeqTerm false false phi in + match uu___ with + | (comm, phi1) -> + let phi2 = + if comm = FStarC_Pprint.empty + then phi1 + else + (let uu___2 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline phi1 in + FStarC_Pprint.op_Hat_Hat comm uu___2) in + let jump_break = + if is_t_atomic then Prims.int_zero else Prims.int_one in + let uu___1 = + let uu___2 = FStarC_Pprint.optional p_aqual aqual_opt in + let uu___3 = + let uu___4 = p_attributes false attrs in + FStarC_Pprint.op_Hat_Hat uu___4 binder in + FStarC_Pprint.op_Hat_Hat uu___2 uu___3 in + let uu___2 = + let uu___3 = p_appTerm t in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = soft_braces_with_nesting_tight phi2 in + let uu___8 = soft_braces_with_nesting phi2 in + FStarC_Pprint.ifflat uu___7 uu___8 in + FStarC_Pprint.group uu___6 in + FStarC_Pprint.jump (Prims.of_int (2)) jump_break uu___5 in + FStarC_Pprint.op_Hat_Hat uu___3 uu___4 in + (uu___1, uu___2) +and (p_binders_list : + Prims.bool -> + FStarC_Parser_AST.binder Prims.list -> FStarC_Pprint.document Prims.list) + = + fun is_atomic -> fun bs -> FStarC_Compiler_List.map (p_binder is_atomic) bs +and (p_binders : + Prims.bool -> FStarC_Parser_AST.binder Prims.list -> FStarC_Pprint.document) + = + fun is_atomic -> + fun bs -> + let uu___ = p_binders_list is_atomic bs in + separate_or_flow break1 uu___ +and (p_binders_sep : + FStarC_Parser_AST.binder Prims.list -> FStarC_Pprint.document) = + fun bs -> + let uu___ = p_binders_list true bs in + FStarC_Pprint.separate_map FStarC_Pprint.space (fun x -> x) uu___ +and (paren_if : + Prims.bool -> FStarC_Pprint.document -> FStarC_Pprint.document) = + fun b -> if b then soft_parens_with_nesting else (fun x -> x) +and (inline_comment_or_above : + FStarC_Pprint.document -> + FStarC_Pprint.document -> + FStarC_Pprint.document -> FStarC_Pprint.document) + = + fun comm -> + fun doc -> + fun sep -> + if comm = FStarC_Pprint.empty + then + let uu___ = FStarC_Pprint.op_Hat_Hat doc sep in + FStarC_Pprint.group uu___ + else + (let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Pprint.op_Hat_Hat break1 comm in + FStarC_Pprint.op_Hat_Hat sep uu___5 in + FStarC_Pprint.op_Hat_Hat doc uu___4 in + FStarC_Pprint.group uu___3 in + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Pprint.op_Hat_Hat doc sep in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline uu___5 in + FStarC_Pprint.op_Hat_Hat comm uu___4 in + FStarC_Pprint.ifflat uu___2 uu___3 in + FStarC_Pprint.group uu___1) +and (p_term : + Prims.bool -> + Prims.bool -> FStarC_Parser_AST.term -> FStarC_Pprint.document) + = + fun ps -> + fun pb -> + fun e -> + match e.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Seq (e1, e2) -> + let uu___ = p_noSeqTerm true false e1 in + (match uu___ with + | (comm, t1) -> + let uu___1 = + inline_comment_or_above comm t1 FStarC_Pprint.semi in + let uu___2 = + let uu___3 = p_term ps pb e2 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline uu___3 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2) + | FStarC_Parser_AST.Bind (x, e1, e2) -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = p_lident x in + let uu___4 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space + FStarC_Pprint.long_left_arrow in + FStarC_Pprint.op_Hat_Hat uu___3 uu___4 in + let uu___3 = + let uu___4 = p_noSeqTermAndComment true false e1 in + let uu___5 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space + FStarC_Pprint.semi in + FStarC_Pprint.op_Hat_Hat uu___4 uu___5 in + op_Hat_Slash_Plus_Hat uu___2 uu___3 in + FStarC_Pprint.group uu___1 in + let uu___1 = p_term ps pb e2 in + FStarC_Pprint.op_Hat_Slash_Hat uu___ uu___1 + | uu___ -> + let uu___1 = p_noSeqTermAndComment ps pb e in + FStarC_Pprint.group uu___1 +and (p_term_sep : + Prims.bool -> + Prims.bool -> + FStarC_Parser_AST.term -> + (FStarC_Pprint.document * FStarC_Pprint.document)) + = + fun ps -> + fun pb -> + fun e -> + match e.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Seq (e1, e2) -> + let uu___ = p_noSeqTerm true false e1 in + (match uu___ with + | (comm, t1) -> + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Pprint.op_Hat_Hat t1 FStarC_Pprint.semi in + FStarC_Pprint.group uu___3 in + let uu___3 = + let uu___4 = p_term ps pb e2 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline uu___4 in + FStarC_Pprint.op_Hat_Hat uu___2 uu___3 in + (comm, uu___1)) + | FStarC_Parser_AST.Bind (x, e1, e2) -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = p_lident x in + let uu___5 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space + FStarC_Pprint.long_left_arrow in + FStarC_Pprint.op_Hat_Hat uu___4 uu___5 in + let uu___4 = + let uu___5 = p_noSeqTermAndComment true false e1 in + let uu___6 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space + FStarC_Pprint.semi in + FStarC_Pprint.op_Hat_Hat uu___5 uu___6 in + op_Hat_Slash_Plus_Hat uu___3 uu___4 in + FStarC_Pprint.group uu___2 in + let uu___2 = p_term ps pb e2 in + FStarC_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in + (FStarC_Pprint.empty, uu___) + | uu___ -> p_noSeqTerm ps pb e +and (p_noSeqTerm : + Prims.bool -> + Prims.bool -> + FStarC_Parser_AST.term -> + (FStarC_Pprint.document * FStarC_Pprint.document)) + = + fun ps -> + fun pb -> + fun e -> + with_comment_sep (p_noSeqTerm' ps pb) e e.FStarC_Parser_AST.range +and (p_noSeqTermAndComment : + Prims.bool -> + Prims.bool -> FStarC_Parser_AST.term -> FStarC_Pprint.document) + = + fun ps -> + fun pb -> + fun e -> with_comment (p_noSeqTerm' ps pb) e e.FStarC_Parser_AST.range +and (p_noSeqTerm' : + Prims.bool -> + Prims.bool -> FStarC_Parser_AST.term -> FStarC_Pprint.document) + = + fun ps -> + fun pb -> + fun e -> + match e.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Ascribed + (e1, t, FStar_Pervasives_Native.None, use_eq) -> + let uu___ = + let uu___1 = p_tmIff e1 in + let uu___2 = + let uu___3 = + let uu___4 = p_typ ps pb t in + FStarC_Pprint.op_Hat_Slash_Hat FStarC_Pprint.colon uu___4 in + FStarC_Pprint.op_Hat_Hat + (if use_eq + then FStarC_Pprint.dollar + else FStarC_Pprint.langle) uu___3 in + FStarC_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | FStarC_Parser_AST.Ascribed + (e1, t, FStar_Pervasives_Native.Some tac, use_eq) -> + let uu___ = + let uu___1 = p_tmIff e1 in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = p_typ false false t in + let uu___6 = + let uu___7 = str "by" in + let uu___8 = p_typ ps pb (maybe_unthunk tac) in + FStarC_Pprint.op_Hat_Slash_Hat uu___7 uu___8 in + FStarC_Pprint.op_Hat_Slash_Hat uu___5 uu___6 in + FStarC_Pprint.op_Hat_Slash_Hat FStarC_Pprint.colon uu___4 in + FStarC_Pprint.op_Hat_Hat + (if use_eq + then FStarC_Pprint.dollar + else FStarC_Pprint.langle) uu___3 in + FStarC_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | FStarC_Parser_AST.Op (id, e1::e2::e3::[]) when + let uu___ = FStarC_Ident.string_of_id id in uu___ = ".()<-" -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = p_atomicTermNotQUident e1 in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = p_term false false e2 in + soft_parens_with_nesting uu___7 in + let uu___7 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space + FStarC_Pprint.larrow in + FStarC_Pprint.op_Hat_Hat uu___6 uu___7 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.dot uu___5 in + FStarC_Pprint.op_Hat_Hat uu___3 uu___4 in + FStarC_Pprint.group uu___2 in + let uu___2 = + let uu___3 = p_noSeqTermAndComment ps pb e3 in jump2 uu___3 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | FStarC_Parser_AST.Op (id, e1::e2::e3::[]) when + let uu___ = FStarC_Ident.string_of_id id in uu___ = ".[]<-" -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = p_atomicTermNotQUident e1 in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = p_term false false e2 in + soft_brackets_with_nesting uu___7 in + let uu___7 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space + FStarC_Pprint.larrow in + FStarC_Pprint.op_Hat_Hat uu___6 uu___7 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.dot uu___5 in + FStarC_Pprint.op_Hat_Hat uu___3 uu___4 in + FStarC_Pprint.group uu___2 in + let uu___2 = + let uu___3 = p_noSeqTermAndComment ps pb e3 in jump2 uu___3 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | FStarC_Parser_AST.Op (id, e1::e2::e3::[]) when + let uu___ = FStarC_Ident.string_of_id id in uu___ = ".(||)<-" -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = p_atomicTermNotQUident e1 in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = p_term false false e2 in + soft_lens_access_with_nesting uu___7 in + let uu___7 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space + FStarC_Pprint.larrow in + FStarC_Pprint.op_Hat_Hat uu___6 uu___7 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.dot uu___5 in + FStarC_Pprint.op_Hat_Hat uu___3 uu___4 in + FStarC_Pprint.group uu___2 in + let uu___2 = + let uu___3 = p_noSeqTermAndComment ps pb e3 in jump2 uu___3 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | FStarC_Parser_AST.Op (id, e1::e2::e3::[]) when + let uu___ = FStarC_Ident.string_of_id id in uu___ = ".[||]<-" -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = p_atomicTermNotQUident e1 in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = p_term false false e2 in + soft_brackets_lens_access_with_nesting uu___7 in + let uu___7 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space + FStarC_Pprint.larrow in + FStarC_Pprint.op_Hat_Hat uu___6 uu___7 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.dot uu___5 in + FStarC_Pprint.op_Hat_Hat uu___3 uu___4 in + FStarC_Pprint.group uu___2 in + let uu___2 = + let uu___3 = p_noSeqTermAndComment ps pb e3 in jump2 uu___3 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | FStarC_Parser_AST.Requires (e1, wtf) -> + let uu___ = + let uu___1 = str "requires" in + let uu___2 = p_typ ps pb e1 in + FStarC_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | FStarC_Parser_AST.Ensures (e1, wtf) -> + let uu___ = + let uu___1 = str "ensures" in + let uu___2 = p_typ ps pb e1 in + FStarC_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | FStarC_Parser_AST.WFOrder (rel, e1) -> p_dec_wf ps pb rel e1 + | FStarC_Parser_AST.LexList l -> + let uu___ = + let uu___1 = str "%" in + let uu___2 = p_term_list ps pb l in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | FStarC_Parser_AST.Decreases (e1, wtf) -> + let uu___ = + let uu___1 = str "decreases" in + let uu___2 = p_typ ps pb e1 in + FStarC_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | FStarC_Parser_AST.Attributes es -> + let uu___ = + let uu___1 = str "attributes" in + let uu___2 = FStarC_Pprint.separate_map break1 p_atomicTerm es in + FStarC_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | FStarC_Parser_AST.If (e1, op_opt, ret_opt, e2, e3) -> + if is_unit e3 + then + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Compiler_Util.map_opt op_opt + FStarC_Ident.string_of_id in + FStarC_Compiler_Util.bind_opt uu___6 + (FStarC_Parser_AST.strip_prefix "let") in + FStarC_Compiler_Util.dflt "" uu___5 in + Prims.strcat "if" uu___4 in + str uu___3 in + let uu___3 = p_noSeqTermAndComment false false e1 in + op_Hat_Slash_Plus_Hat uu___2 uu___3 in + let uu___2 = + let uu___3 = str "then" in + let uu___4 = p_noSeqTermAndComment ps pb e2 in + op_Hat_Slash_Plus_Hat uu___3 uu___4 in + FStarC_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + else + (let e2_doc = + match e2.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.If (uu___1, uu___2, uu___3, uu___4, e31) + when is_unit e31 -> + let uu___5 = p_noSeqTermAndComment false false e2 in + soft_parens_with_nesting uu___5 + | uu___1 -> p_noSeqTermAndComment false false e2 in + match ret_opt with + | FStar_Pervasives_Native.None -> + let uu___1 = + let uu___2 = + let uu___3 = str "if" in + let uu___4 = p_noSeqTermAndComment false false e1 in + op_Hat_Slash_Plus_Hat uu___3 uu___4 in + let uu___3 = + let uu___4 = + let uu___5 = str "then" in + op_Hat_Slash_Plus_Hat uu___5 e2_doc in + let uu___5 = + let uu___6 = str "else" in + let uu___7 = p_noSeqTermAndComment ps pb e3 in + op_Hat_Slash_Plus_Hat uu___6 uu___7 in + FStarC_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in + FStarC_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in + FStarC_Pprint.group uu___1 + | FStar_Pervasives_Native.Some (as_opt, ret, use_eq) -> + let uu___1 = + let uu___2 = + let uu___3 = str "if" in + let uu___4 = p_noSeqTermAndComment false false e1 in + op_Hat_Slash_Plus_Hat uu___3 uu___4 in + let uu___3 = + let uu___4 = + let uu___5 = + match as_opt with + | FStar_Pervasives_Native.None -> + FStarC_Pprint.empty + | FStar_Pervasives_Native.Some as_ident -> + let uu___6 = str "as" in + let uu___7 = p_ident as_ident in + FStarC_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in + let uu___6 = + let uu___7 = + str (if use_eq then "returns$" else "returns") in + let uu___8 = p_tmIff ret in + op_Hat_Slash_Plus_Hat uu___7 uu___8 in + FStarC_Pprint.op_Hat_Slash_Hat uu___5 uu___6 in + let uu___5 = + let uu___6 = + let uu___7 = str "then" in + op_Hat_Slash_Plus_Hat uu___7 e2_doc in + let uu___7 = + let uu___8 = str "else" in + let uu___9 = p_noSeqTermAndComment ps pb e3 in + op_Hat_Slash_Plus_Hat uu___8 uu___9 in + FStarC_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in + FStarC_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in + FStarC_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in + FStarC_Pprint.group uu___1) + | FStarC_Parser_AST.TryWith (e1, branches) -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = str "try" in + let uu___4 = p_noSeqTermAndComment false false e1 in + prefix2 uu___3 uu___4 in + let uu___3 = + let uu___4 = str "with" in + let uu___5 = + separate_map_last FStarC_Pprint.hardline p_patternBranch + branches in + FStarC_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in + FStarC_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in + FStarC_Pprint.group uu___1 in + let uu___1 = paren_if (ps || pb) in uu___1 uu___ + | FStarC_Parser_AST.Match (e1, op_opt, ret_opt, branches) -> + let match_doc = + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Compiler_Util.map_opt op_opt + FStarC_Ident.string_of_id in + FStarC_Compiler_Util.bind_opt uu___3 + (FStarC_Parser_AST.strip_prefix "let") in + FStarC_Compiler_Util.dflt "" uu___2 in + Prims.strcat "match" uu___1 in + str uu___ in + let uu___ = + let uu___1 = + match ret_opt with + | FStar_Pervasives_Native.None -> + let uu___2 = + let uu___3 = p_noSeqTermAndComment false false e1 in + let uu___4 = str "with" in + FStarC_Pprint.surround (Prims.of_int (2)) Prims.int_one + match_doc uu___3 uu___4 in + FStarC_Pprint.group uu___2 + | FStar_Pervasives_Native.Some (as_opt, ret, use_eq) -> + let uu___2 = + let uu___3 = + let uu___4 = p_noSeqTermAndComment false false e1 in + let uu___5 = + let uu___6 = + match as_opt with + | FStar_Pervasives_Native.None -> + FStarC_Pprint.empty + | FStar_Pervasives_Native.Some as_ident -> + let uu___7 = str "as" in + let uu___8 = p_ident as_ident in + op_Hat_Slash_Plus_Hat uu___7 uu___8 in + let uu___7 = + let uu___8 = + str (if use_eq then "returns$" else "returns") in + let uu___9 = p_tmIff ret in + op_Hat_Slash_Plus_Hat uu___8 uu___9 in + op_Hat_Slash_Plus_Hat uu___6 uu___7 in + op_Hat_Slash_Plus_Hat uu___4 uu___5 in + let uu___4 = str "with" in + FStarC_Pprint.surround (Prims.of_int (2)) Prims.int_one + match_doc uu___3 uu___4 in + FStarC_Pprint.group uu___2 in + let uu___2 = + separate_map_last FStarC_Pprint.hardline p_patternBranch + branches in + FStarC_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in + let uu___1 = paren_if (ps || pb) in uu___1 uu___ + | FStarC_Parser_AST.LetOpen (uid, e1) -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = str "let open" in + let uu___4 = p_quident uid in + let uu___5 = str "in" in + FStarC_Pprint.surround (Prims.of_int (2)) Prims.int_one + uu___3 uu___4 uu___5 in + let uu___3 = p_term false pb e1 in + FStarC_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in + FStarC_Pprint.group uu___1 in + let uu___1 = paren_if ps in uu___1 uu___ + | FStarC_Parser_AST.LetOpenRecord (r, rty, e1) -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = str "let open" in + let uu___4 = p_term false pb r in + let uu___5 = str "as" in + FStarC_Pprint.surround (Prims.of_int (2)) Prims.int_one + uu___3 uu___4 uu___5 in + let uu___3 = + let uu___4 = p_term false pb rty in + let uu___5 = + let uu___6 = str "in" in + let uu___7 = p_term false pb e1 in + FStarC_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in + FStarC_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in + FStarC_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in + FStarC_Pprint.group uu___1 in + let uu___1 = paren_if ps in uu___1 uu___ + | FStarC_Parser_AST.LetOperator (lets, body) -> + let p_let uu___ is_last = + match uu___ with + | (id, pat, e1) -> + let doc_let_or_and = + let uu___1 = FStarC_Ident.string_of_id id in str uu___1 in + let doc_pat = p_letlhs doc_let_or_and (pat, e1) true in + (match ((pat.FStarC_Parser_AST.pat), + (e1.FStarC_Parser_AST.tm)) + with + | (FStarC_Parser_AST.PatVar (pid, uu___1, uu___2), + FStarC_Parser_AST.Name tid) when + let uu___3 = FStarC_Ident.string_of_id pid in + let uu___4 = + let uu___5 = FStarC_Ident.path_of_lid tid in + FStarC_Compiler_List.last uu___5 in + uu___3 = uu___4 -> + let uu___3 = + if is_last then str "in" else FStarC_Pprint.empty in + FStarC_Pprint.op_Hat_Slash_Hat doc_pat uu___3 + | (FStarC_Parser_AST.PatVar (pid, uu___1, uu___2), + FStarC_Parser_AST.Var tid) when + let uu___3 = FStarC_Ident.string_of_id pid in + let uu___4 = + let uu___5 = FStarC_Ident.path_of_lid tid in + FStarC_Compiler_List.last uu___5 in + uu___3 = uu___4 -> + let uu___3 = + if is_last then str "in" else FStarC_Pprint.empty in + FStarC_Pprint.op_Hat_Slash_Hat doc_pat uu___3 + | uu___1 -> + let uu___2 = p_term_sep false false e1 in + (match uu___2 with + | (comm, doc_expr) -> + let doc_expr1 = + inline_comment_or_above comm doc_expr + FStarC_Pprint.empty in + if is_last + then + let uu___3 = + FStarC_Pprint.flow break1 + [doc_pat; FStarC_Pprint.equals] in + let uu___4 = str "in" in + FStarC_Pprint.surround (Prims.of_int (2)) + Prims.int_one uu___3 doc_expr1 uu___4 + else + (let uu___4 = + FStarC_Pprint.flow break1 + [doc_pat; FStarC_Pprint.equals; doc_expr1] in + FStarC_Pprint.hang (Prims.of_int (2)) uu___4))) in + let l = FStarC_Compiler_List.length lets in + let lets_docs = + FStarC_Compiler_List.mapi + (fun i -> + fun lb -> + let uu___ = p_let lb (i = (l - Prims.int_one)) in + FStarC_Pprint.group uu___) lets in + let lets_doc = + let uu___ = FStarC_Pprint.separate break1 lets_docs in + FStarC_Pprint.group uu___ in + let r = + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = p_term false pb body in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline uu___3 in + FStarC_Pprint.op_Hat_Hat lets_doc uu___2 in + FStarC_Pprint.group uu___1 in + let uu___1 = paren_if ps in uu___1 uu___ in + r + | FStarC_Parser_AST.Let (q, lbs, e1) -> + let p_lb q1 uu___ is_last = + match uu___ with + | (a, (pat, e2)) -> + let attrs = p_attrs_opt true a in + let doc_let_or_and = + match q1 with + | FStar_Pervasives_Native.Some (FStarC_Parser_AST.Rec) -> + let uu___1 = + let uu___2 = str "let" in + let uu___3 = str "rec" in + FStarC_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in + FStarC_Pprint.group uu___1 + | FStar_Pervasives_Native.Some + (FStarC_Parser_AST.NoLetQualifier) -> str "let" + | uu___1 -> str "and" in + let doc_pat = p_letlhs doc_let_or_and (pat, e2) true in + let uu___1 = p_term_sep false false e2 in + (match uu___1 with + | (comm, doc_expr) -> + let doc_expr1 = + inline_comment_or_above comm doc_expr + FStarC_Pprint.empty in + let uu___2 = + if is_last + then + let uu___3 = + FStarC_Pprint.flow break1 + [doc_pat; FStarC_Pprint.equals] in + let uu___4 = str "in" in + FStarC_Pprint.surround (Prims.of_int (2)) + Prims.int_one uu___3 doc_expr1 uu___4 + else + (let uu___4 = + FStarC_Pprint.flow break1 + [doc_pat; FStarC_Pprint.equals; doc_expr1] in + FStarC_Pprint.hang (Prims.of_int (2)) uu___4) in + FStarC_Pprint.op_Hat_Hat attrs uu___2) in + let l = FStarC_Compiler_List.length lbs in + let lbs_docs = + FStarC_Compiler_List.mapi + (fun i -> + fun lb -> + if i = Prims.int_zero + then + let uu___ = + p_lb (FStar_Pervasives_Native.Some q) lb + (i = (l - Prims.int_one)) in + FStarC_Pprint.group uu___ + else + (let uu___1 = + p_lb FStar_Pervasives_Native.None lb + (i = (l - Prims.int_one)) in + FStarC_Pprint.group uu___1)) lbs in + let lbs_doc = + let uu___ = FStarC_Pprint.separate break1 lbs_docs in + FStarC_Pprint.group uu___ in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = p_term false pb e1 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline uu___3 in + FStarC_Pprint.op_Hat_Hat lbs_doc uu___2 in + FStarC_Pprint.group uu___1 in + let uu___1 = paren_if ps in uu___1 uu___ + | FStarC_Parser_AST.Quote (e1, FStarC_Parser_AST.Dynamic) -> + let uu___ = + let uu___1 = str "quote" in + let uu___2 = p_noSeqTermAndComment ps pb e1 in + FStarC_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | FStarC_Parser_AST.Quote (e1, FStarC_Parser_AST.Static) -> + let uu___ = + let uu___1 = str "`" in + let uu___2 = p_noSeqTermAndComment ps pb e1 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | FStarC_Parser_AST.VQuote e1 -> + let uu___ = + let uu___1 = str "`%" in + let uu___2 = p_noSeqTermAndComment ps pb e1 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | FStarC_Parser_AST.Antiquote + { + FStarC_Parser_AST.tm = FStarC_Parser_AST.Quote + (e1, FStarC_Parser_AST.Dynamic); + FStarC_Parser_AST.range = uu___; + FStarC_Parser_AST.level = uu___1;_} + -> + let uu___2 = + let uu___3 = str "`@" in + let uu___4 = p_noSeqTermAndComment ps pb e1 in + FStarC_Pprint.op_Hat_Hat uu___3 uu___4 in + FStarC_Pprint.group uu___2 + | FStarC_Parser_AST.Antiquote e1 -> + let uu___ = + let uu___1 = str "`#" in + let uu___2 = p_noSeqTermAndComment ps pb e1 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | FStarC_Parser_AST.CalcProof (rel, init, steps) -> + let head = + let uu___ = str "calc" in + let uu___1 = + let uu___2 = + let uu___3 = p_noSeqTermAndComment false false rel in + let uu___4 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space + FStarC_Pprint.lbrace in + FStarC_Pprint.op_Hat_Hat uu___3 uu___4 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___2 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 in + let bot = FStarC_Pprint.rbrace in + let uu___ = FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline bot in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = p_noSeqTermAndComment false false init in + let uu___5 = + let uu___6 = str ";" in + let uu___7 = + let uu___8 = + separate_map_last FStarC_Pprint.hardline p_calcStep + steps in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline uu___8 in + FStarC_Pprint.op_Hat_Hat uu___6 uu___7 in + FStarC_Pprint.op_Hat_Hat uu___4 uu___5 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline uu___3 in + FStarC_Pprint.nest (Prims.of_int (2)) uu___2 in + FStarC_Pprint.enclose head uu___ uu___1 + | FStarC_Parser_AST.IntroForall (xs, p, e1) -> + let p1 = p_noSeqTermAndComment false false p in + let e2 = p_noSeqTermAndComment false false e1 in + let xs1 = p_binders_sep xs in + let uu___ = str "introduce forall" in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = str "." in + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = str "with" in + let uu___11 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space e2 in + FStarC_Pprint.op_Hat_Hat uu___10 uu___11 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline + uu___9 in + FStarC_Pprint.op_Hat_Hat p1 uu___8 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___7 in + FStarC_Pprint.op_Hat_Hat uu___5 uu___6 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___4 in + FStarC_Pprint.op_Hat_Hat xs1 uu___3 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___2 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 + | FStarC_Parser_AST.IntroExists (xs, p, vs, e1) -> + let p1 = p_noSeqTermAndComment false false p in + let e2 = p_noSeqTermAndComment false false e1 in + let xs1 = p_binders_sep xs in + let uu___ = str "introduce" in + let uu___1 = + let uu___2 = + let uu___3 = str "exists" in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = str "." in + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = str "with" in + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_Pprint.separate_map + FStarC_Pprint.space p_atomicTerm vs in + let uu___15 = + let uu___16 = + let uu___17 = str "and" in + let uu___18 = + FStarC_Pprint.op_Hat_Hat + FStarC_Pprint.space e2 in + FStarC_Pprint.op_Hat_Hat uu___17 uu___18 in + FStarC_Pprint.op_Hat_Hat + FStarC_Pprint.hardline uu___16 in + FStarC_Pprint.op_Hat_Hat uu___14 uu___15 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space + uu___13 in + FStarC_Pprint.op_Hat_Hat uu___11 uu___12 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline + uu___10 in + FStarC_Pprint.op_Hat_Hat p1 uu___9 in + FStarC_Pprint.op_Hat_Hat uu___7 uu___8 in + FStarC_Pprint.op_Hat_Hat xs1 uu___6 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___5 in + FStarC_Pprint.op_Hat_Hat uu___3 uu___4 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___2 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 + | FStarC_Parser_AST.IntroImplies (p, q, x, e1) -> + let p1 = p_tmFormula p in + let q1 = p_tmFormula q in + let e2 = p_noSeqTermAndComment false false e1 in + let x1 = p_binders_sep [x] in + let uu___ = str "introduce" in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = str "==>" in + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = str "with" in + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = str "." in + let uu___15 = + FStarC_Pprint.op_Hat_Hat + FStarC_Pprint.space e2 in + FStarC_Pprint.op_Hat_Hat uu___14 uu___15 in + FStarC_Pprint.op_Hat_Hat x1 uu___13 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space + uu___12 in + FStarC_Pprint.op_Hat_Hat uu___10 uu___11 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline + uu___9 in + FStarC_Pprint.op_Hat_Hat q1 uu___8 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___7 in + FStarC_Pprint.op_Hat_Hat uu___5 uu___6 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___4 in + FStarC_Pprint.op_Hat_Hat p1 uu___3 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___2 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 + | FStarC_Parser_AST.IntroOr (b, p, q, e1) -> + let p1 = p_tmFormula p in + let q1 = p_tmFormula q in + let e2 = p_noSeqTermAndComment false false e1 in + let uu___ = str "introduce" in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = str "\\/" in + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = str "with" in + let uu___11 = + let uu___12 = + let uu___13 = + if b then str "Left" else str "Right" in + let uu___14 = + FStarC_Pprint.op_Hat_Hat + FStarC_Pprint.space e2 in + FStarC_Pprint.op_Hat_Hat uu___13 uu___14 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space + uu___12 in + FStarC_Pprint.op_Hat_Hat uu___10 uu___11 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline + uu___9 in + FStarC_Pprint.op_Hat_Hat q1 uu___8 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___7 in + FStarC_Pprint.op_Hat_Hat uu___5 uu___6 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___4 in + FStarC_Pprint.op_Hat_Hat p1 uu___3 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___2 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 + | FStarC_Parser_AST.IntroAnd (p, q, e1, e2) -> + let p1 = p_tmFormula p in + let q1 = p_tmTuple q in + let e11 = p_noSeqTermAndComment false false e1 in + let e21 = p_noSeqTermAndComment false false e2 in + let uu___ = str "introduce" in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = str "/\\" in + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = str "with" in + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = str "and" in + let uu___16 = + FStarC_Pprint.op_Hat_Hat + FStarC_Pprint.space e21 in + FStarC_Pprint.op_Hat_Hat uu___15 uu___16 in + FStarC_Pprint.op_Hat_Hat + FStarC_Pprint.hardline uu___14 in + FStarC_Pprint.op_Hat_Hat e11 uu___13 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space + uu___12 in + FStarC_Pprint.op_Hat_Hat uu___10 uu___11 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline + uu___9 in + FStarC_Pprint.op_Hat_Hat q1 uu___8 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___7 in + FStarC_Pprint.op_Hat_Hat uu___5 uu___6 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___4 in + FStarC_Pprint.op_Hat_Hat p1 uu___3 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___2 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 + | FStarC_Parser_AST.ElimForall (xs, p, vs) -> + let xs1 = p_binders_sep xs in + let p1 = p_noSeqTermAndComment false false p in + let vs1 = + FStarC_Pprint.separate_map FStarC_Pprint.space p_atomicTerm vs in + let uu___ = str "eliminate" in + let uu___1 = + let uu___2 = + let uu___3 = str "forall" in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = str "." in + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = str "with" in + let uu___13 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space + vs1 in + FStarC_Pprint.op_Hat_Hat uu___12 uu___13 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline + uu___11 in + FStarC_Pprint.op_Hat_Hat p1 uu___10 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___9 in + FStarC_Pprint.op_Hat_Hat uu___7 uu___8 in + FStarC_Pprint.op_Hat_Hat xs1 uu___6 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___5 in + FStarC_Pprint.op_Hat_Hat uu___3 uu___4 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___2 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 + | FStarC_Parser_AST.ElimExists (bs, p, q, b, e1) -> + let head = + let uu___ = str "eliminate exists" in + let uu___1 = + let uu___2 = + let uu___3 = p_binders_sep bs in + let uu___4 = str "." in + FStarC_Pprint.op_Hat_Hat uu___3 uu___4 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___2 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 in + let p1 = p_noSeqTermAndComment false false p in + let q1 = p_noSeqTermAndComment false false q in + let e2 = p_noSeqTermAndComment false false e1 in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = str "returns" in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = str "with" in + let uu___10 = + let uu___11 = + let uu___12 = p_binders_sep [b] in + let uu___13 = + let uu___14 = str "." in + let uu___15 = + FStarC_Pprint.op_Hat_Hat + FStarC_Pprint.hardline e2 in + FStarC_Pprint.op_Hat_Hat uu___14 uu___15 in + FStarC_Pprint.op_Hat_Hat uu___12 uu___13 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space + uu___11 in + FStarC_Pprint.op_Hat_Hat uu___9 uu___10 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline + uu___8 in + FStarC_Pprint.op_Hat_Hat q1 uu___7 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___6 in + FStarC_Pprint.op_Hat_Hat uu___4 uu___5 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline uu___3 in + FStarC_Pprint.op_Hat_Hat p1 uu___2 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline uu___1 in + FStarC_Pprint.op_Hat_Hat head uu___ + | FStarC_Parser_AST.ElimImplies (p, q, e1) -> + let p1 = p_tmFormula p in + let q1 = p_tmFormula q in + let e2 = p_noSeqTermAndComment false false e1 in + let uu___ = str "eliminate" in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = str "==>" in + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = str "with" in + let uu___11 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space e2 in + FStarC_Pprint.op_Hat_Hat uu___10 uu___11 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline + uu___9 in + FStarC_Pprint.op_Hat_Hat q1 uu___8 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___7 in + FStarC_Pprint.op_Hat_Hat uu___5 uu___6 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___4 in + FStarC_Pprint.op_Hat_Hat p1 uu___3 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___2 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 + | FStarC_Parser_AST.ElimOr (p, q, r, x, e1, y, e2) -> + let p1 = p_tmFormula p in + let q1 = p_tmFormula q in + let r1 = p_noSeqTermAndComment false false r in + let x1 = p_binders_sep [x] in + let e11 = p_noSeqTermAndComment false false e1 in + let y1 = p_binders_sep [y] in + let e21 = p_noSeqTermAndComment false false e2 in + let uu___ = str "eliminate" in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = str "\\/" in + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = str "returns" in + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = str "with" in + let uu___16 = + let uu___17 = + let uu___18 = + let uu___19 = + let uu___20 = str "." in + let uu___21 = + let uu___22 = + let uu___23 = + let uu___24 = + let uu___25 = str "and" in + let uu___26 = + let uu___27 = + let uu___28 = + let uu___29 = + let uu___30 = + str "." in + let uu___31 = + FStarC_Pprint.op_Hat_Hat + FStarC_Pprint.space + e21 in + FStarC_Pprint.op_Hat_Hat + uu___30 uu___31 in + FStarC_Pprint.op_Hat_Hat + FStarC_Pprint.space + uu___29 in + FStarC_Pprint.op_Hat_Hat + y1 uu___28 in + FStarC_Pprint.op_Hat_Hat + FStarC_Pprint.space + uu___27 in + FStarC_Pprint.op_Hat_Hat + uu___25 uu___26 in + FStarC_Pprint.op_Hat_Hat + FStarC_Pprint.hardline + uu___24 in + FStarC_Pprint.op_Hat_Hat e11 + uu___23 in + FStarC_Pprint.op_Hat_Hat + FStarC_Pprint.space uu___22 in + FStarC_Pprint.op_Hat_Hat uu___20 + uu___21 in + FStarC_Pprint.op_Hat_Hat + FStarC_Pprint.space uu___19 in + FStarC_Pprint.op_Hat_Hat x1 uu___18 in + FStarC_Pprint.op_Hat_Hat + FStarC_Pprint.space uu___17 in + FStarC_Pprint.op_Hat_Hat uu___15 uu___16 in + FStarC_Pprint.op_Hat_Hat + FStarC_Pprint.hardline uu___14 in + FStarC_Pprint.op_Hat_Hat r1 uu___13 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space + uu___12 in + FStarC_Pprint.op_Hat_Hat uu___10 uu___11 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline + uu___9 in + FStarC_Pprint.op_Hat_Hat q1 uu___8 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___7 in + FStarC_Pprint.op_Hat_Hat uu___5 uu___6 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___4 in + FStarC_Pprint.op_Hat_Hat p1 uu___3 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___2 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 + | FStarC_Parser_AST.ElimAnd (p, q, r, x, y, e1) -> + let p1 = p_tmFormula p in + let q1 = p_tmTuple q in + let r1 = p_noSeqTermAndComment false false r in + let xy = p_binders_sep [x; y] in + let e2 = p_noSeqTermAndComment false false e1 in + let uu___ = str "eliminate" in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = str "/\\" in + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = str "returns" in + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = str "with" in + let uu___16 = + let uu___17 = + let uu___18 = + let uu___19 = + let uu___20 = str "." in + let uu___21 = + FStarC_Pprint.op_Hat_Hat + FStarC_Pprint.space e2 in + FStarC_Pprint.op_Hat_Hat uu___20 + uu___21 in + FStarC_Pprint.op_Hat_Hat + FStarC_Pprint.space uu___19 in + FStarC_Pprint.op_Hat_Hat xy uu___18 in + FStarC_Pprint.op_Hat_Hat + FStarC_Pprint.space uu___17 in + FStarC_Pprint.op_Hat_Hat uu___15 uu___16 in + FStarC_Pprint.op_Hat_Hat + FStarC_Pprint.hardline uu___14 in + FStarC_Pprint.op_Hat_Hat r1 uu___13 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space + uu___12 in + FStarC_Pprint.op_Hat_Hat uu___10 uu___11 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline + uu___9 in + FStarC_Pprint.op_Hat_Hat q1 uu___8 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___7 in + FStarC_Pprint.op_Hat_Hat uu___5 uu___6 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___4 in + FStarC_Pprint.op_Hat_Hat p1 uu___3 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___2 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 + | uu___ -> p_typ ps pb e +and (p_dec_wf : + Prims.bool -> + Prims.bool -> + FStarC_Parser_AST.term -> + FStarC_Parser_AST.term -> FStarC_Pprint.document) + = + fun ps -> + fun pb -> + fun rel -> + fun e -> + let uu___ = + let uu___1 = str "{:well-founded " in + let uu___2 = + let uu___3 = p_typ ps pb rel in + let uu___4 = + let uu___5 = p_typ ps pb e in + let uu___6 = str " }" in + FStarC_Pprint.op_Hat_Hat uu___5 uu___6 in + FStarC_Pprint.op_Hat_Slash_Hat uu___3 uu___4 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ +and (p_calcStep : + Prims.bool -> FStarC_Parser_AST.calc_step -> FStarC_Pprint.document) = + fun uu___ -> + fun uu___1 -> + match uu___1 with + | FStarC_Parser_AST.CalcStep (rel, just, next) -> + let uu___2 = + let uu___3 = p_noSeqTermAndComment false false rel in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = p_noSeqTermAndComment false false just in + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + p_noSeqTermAndComment false false next in + let uu___14 = str ";" in + FStarC_Pprint.op_Hat_Hat uu___13 uu___14 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline + uu___12 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.rbrace uu___11 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___10 in + FStarC_Pprint.op_Hat_Hat uu___8 uu___9 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___7 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.lbrace uu___6 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___5 in + FStarC_Pprint.op_Hat_Hat uu___3 uu___4 in + FStarC_Pprint.group uu___2 +and (p_attrs_opt : + Prims.bool -> + FStarC_Parser_AST.term Prims.list FStar_Pervasives_Native.option -> + FStarC_Pprint.document) + = + fun isTopLevel -> + fun uu___ -> + match uu___ with + | FStar_Pervasives_Native.None -> FStarC_Pprint.empty + | FStar_Pervasives_Native.Some terms -> + let uu___1 = + let uu___2 = str (if isTopLevel then "[@@" else "[@@@") in + let uu___3 = + let uu___4 = + let uu___5 = str "; " in + FStarC_Pprint.separate_map uu___5 + (p_noSeqTermAndComment false false) terms in + let uu___5 = str "]" in + FStarC_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in + FStarC_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in + FStarC_Pprint.group uu___1 +and (p_typ : + Prims.bool -> + Prims.bool -> FStarC_Parser_AST.term -> FStarC_Pprint.document) + = + fun ps -> + fun pb -> + fun e -> with_comment (p_typ' ps pb) e e.FStarC_Parser_AST.range +and (p_typ_sep : + Prims.bool -> + Prims.bool -> + FStarC_Parser_AST.term -> + (FStarC_Pprint.document * FStarC_Pprint.document)) + = + fun ps -> + fun pb -> + fun e -> with_comment_sep (p_typ' ps pb) e e.FStarC_Parser_AST.range +and (p_typ' : + Prims.bool -> + Prims.bool -> FStarC_Parser_AST.term -> FStarC_Pprint.document) + = + fun ps -> + fun pb -> + fun e -> + match e.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.QForall (bs, (uu___, trigger), e1) -> + let binders_doc = p_binders true bs in + let term_doc = p_noSeqTermAndComment ps pb e1 in + (match trigger with + | [] -> + let uu___1 = + let uu___2 = + let uu___3 = p_quantifier e in + FStarC_Pprint.op_Hat_Hat uu___3 FStarC_Pprint.space in + FStarC_Pprint.soft_surround (Prims.of_int (2)) + Prims.int_zero uu___2 binders_doc FStarC_Pprint.dot in + prefix2 uu___1 term_doc + | pats -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = p_quantifier e in + FStarC_Pprint.op_Hat_Hat uu___5 FStarC_Pprint.space in + FStarC_Pprint.soft_surround (Prims.of_int (2)) + Prims.int_zero uu___4 binders_doc FStarC_Pprint.dot in + let uu___4 = p_trigger trigger in prefix2 uu___3 uu___4 in + FStarC_Pprint.group uu___2 in + prefix2 uu___1 term_doc) + | FStarC_Parser_AST.QExists (bs, (uu___, trigger), e1) -> + let binders_doc = p_binders true bs in + let term_doc = p_noSeqTermAndComment ps pb e1 in + (match trigger with + | [] -> + let uu___1 = + let uu___2 = + let uu___3 = p_quantifier e in + FStarC_Pprint.op_Hat_Hat uu___3 FStarC_Pprint.space in + FStarC_Pprint.soft_surround (Prims.of_int (2)) + Prims.int_zero uu___2 binders_doc FStarC_Pprint.dot in + prefix2 uu___1 term_doc + | pats -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = p_quantifier e in + FStarC_Pprint.op_Hat_Hat uu___5 FStarC_Pprint.space in + FStarC_Pprint.soft_surround (Prims.of_int (2)) + Prims.int_zero uu___4 binders_doc FStarC_Pprint.dot in + let uu___4 = p_trigger trigger in prefix2 uu___3 uu___4 in + FStarC_Pprint.group uu___2 in + prefix2 uu___1 term_doc) + | FStarC_Parser_AST.QuantOp (uu___, bs, (uu___1, trigger), e1) -> + let binders_doc = p_binders true bs in + let term_doc = p_noSeqTermAndComment ps pb e1 in + (match trigger with + | [] -> + let uu___2 = + let uu___3 = + let uu___4 = p_quantifier e in + FStarC_Pprint.op_Hat_Hat uu___4 FStarC_Pprint.space in + FStarC_Pprint.soft_surround (Prims.of_int (2)) + Prims.int_zero uu___3 binders_doc FStarC_Pprint.dot in + prefix2 uu___2 term_doc + | pats -> + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = p_quantifier e in + FStarC_Pprint.op_Hat_Hat uu___6 FStarC_Pprint.space in + FStarC_Pprint.soft_surround (Prims.of_int (2)) + Prims.int_zero uu___5 binders_doc FStarC_Pprint.dot in + let uu___5 = p_trigger trigger in prefix2 uu___4 uu___5 in + FStarC_Pprint.group uu___3 in + prefix2 uu___2 term_doc) + | uu___ -> p_simpleTerm ps pb e +and (p_typ_top : + annotation_style -> + Prims.bool -> + Prims.bool -> FStarC_Parser_AST.term -> FStarC_Pprint.document) + = + fun style -> + fun ps -> + fun pb -> + fun e -> + with_comment (p_typ_top' style ps pb) e e.FStarC_Parser_AST.range +and (p_typ_top' : + annotation_style -> + Prims.bool -> + Prims.bool -> FStarC_Parser_AST.term -> FStarC_Pprint.document) + = + fun style -> + fun ps -> fun pb -> fun e -> p_tmArrow style true p_tmFormula e +and (sig_as_binders_if_possible : + FStarC_Parser_AST.term -> Prims.bool -> FStarC_Pprint.document) = + fun t -> + fun extra_space -> + let s = + if extra_space then FStarC_Pprint.space else FStarC_Pprint.empty in + let uu___ = all_binders_annot t in + if uu___ + then + let uu___1 = + p_typ_top (Binders ((Prims.of_int (4)), Prims.int_zero, true)) + false false t in + FStarC_Pprint.op_Hat_Hat s uu___1 + else + (let uu___2 = + let uu___3 = + let uu___4 = + p_typ_top (Arrows ((Prims.of_int (2)), (Prims.of_int (2)))) + false false t in + FStarC_Pprint.op_Hat_Hat s uu___4 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.colon uu___3 in + FStarC_Pprint.group uu___2) +and (collapse_pats : + (FStarC_Pprint.document * FStarC_Pprint.document * Prims.bool * Prims.bool) + Prims.list -> FStarC_Pprint.document Prims.list) + = + fun pats -> + let fold_fun bs x = + let uu___ = x in + match uu___ with + | (b1, t1, tc1, j1) -> + (match bs with + | [] -> [([b1], t1, tc1, j1)] + | hd::tl -> + let uu___1 = hd in + (match uu___1 with + | (b2s, t2, tc2, j2) -> + if ((t1 = t2) && j1) && j2 + then + ((FStarC_Compiler_List.op_At b2s [b1]), t1, false, + true) + :: tl + else ([b1], t1, tc1, j1) :: hd :: tl)) in + let p_collapsed_binder cb = + let uu___ = cb in + match uu___ with + | (bs, typ, istcarg, uu___1) -> + let body = + match bs with + | [] -> failwith "Impossible" + | hd::tl -> + let uu___2 = + FStarC_Compiler_List.fold_left + (fun x -> + fun y -> + let uu___3 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space y in + FStarC_Pprint.op_Hat_Hat x uu___3) hd tl in + cat_with_colon uu___2 typ in + if istcarg then tc_arg body else soft_parens_with_nesting body in + let binders = + FStarC_Compiler_List.fold_left fold_fun [] + (FStarC_Compiler_List.rev pats) in + map_rev p_collapsed_binder binders +and (pats_as_binders_if_possible : + FStarC_Parser_AST.pattern Prims.list -> + (FStarC_Pprint.document Prims.list * annotation_style)) + = + fun pats -> + let all_binders p = + match p.FStarC_Parser_AST.pat with + | FStarC_Parser_AST.PatAscribed + (pat, (t, FStar_Pervasives_Native.None)) -> + (match ((pat.FStarC_Parser_AST.pat), (t.FStarC_Parser_AST.tm)) with + | (FStarC_Parser_AST.PatVar (lid, aqual, attrs), + FStarC_Parser_AST.Refine + ({ + FStarC_Parser_AST.b = FStarC_Parser_AST.Annotated (lid', t1); + FStarC_Parser_AST.brange = uu___; + FStarC_Parser_AST.blevel = uu___1; + FStarC_Parser_AST.aqual = uu___2; + FStarC_Parser_AST.battributes = uu___3;_}, + phi)) when + let uu___4 = FStarC_Ident.string_of_id lid in + let uu___5 = FStarC_Ident.string_of_id lid' in uu___4 = uu___5 + -> + let uu___4 = + let uu___5 = p_ident lid in + p_refinement' aqual attrs uu___5 t1 phi in + (match uu___4 with + | (x, y) -> FStar_Pervasives_Native.Some (x, y, false, false)) + | (FStarC_Parser_AST.PatVar (lid, aqual, attrs), uu___) -> + let is_tc = + aqual = + (FStar_Pervasives_Native.Some + FStarC_Parser_AST.TypeClassArg) in + let is_meta = + match aqual with + | FStar_Pervasives_Native.Some (FStarC_Parser_AST.Meta + uu___1) -> true + | uu___1 -> false in + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Pprint.optional p_aqual aqual in + let uu___4 = + let uu___5 = p_attributes false attrs in + let uu___6 = p_ident lid in + FStarC_Pprint.op_Hat_Hat uu___5 uu___6 in + FStarC_Pprint.op_Hat_Hat uu___3 uu___4 in + let uu___3 = p_tmEqNoRefinement t in + (uu___2, uu___3, is_tc, + ((Prims.op_Negation is_tc) && (Prims.op_Negation is_meta))) in + FStar_Pervasives_Native.Some uu___1 + | uu___ -> FStar_Pervasives_Native.None) + | uu___ -> FStar_Pervasives_Native.None in + let uu___ = map_if_all all_binders pats in + match uu___ with + | FStar_Pervasives_Native.Some bs -> + let uu___1 = collapse_pats bs in + (uu___1, (Binders ((Prims.of_int (4)), Prims.int_zero, true))) + | FStar_Pervasives_Native.None -> + let uu___1 = FStarC_Compiler_List.map p_atomicPattern pats in + (uu___1, (Binders ((Prims.of_int (4)), Prims.int_zero, false))) +and (p_quantifier : FStarC_Parser_AST.term -> FStarC_Pprint.document) = + fun e -> + match e.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.QForall uu___ -> str "forall" + | FStarC_Parser_AST.QExists uu___ -> str "exists" + | FStarC_Parser_AST.QuantOp (i, uu___, uu___1, uu___2) -> p_ident i + | uu___ -> + failwith "Imposible : p_quantifier called on a non-quantifier term" +and (p_trigger : + FStarC_Parser_AST.term Prims.list Prims.list -> FStarC_Pprint.document) = + fun uu___ -> + match uu___ with + | [] -> FStarC_Pprint.empty + | pats -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = str "pattern" in + let uu___5 = + let uu___6 = + let uu___7 = p_disjunctivePats pats in + FStarC_Pprint.jump (Prims.of_int (2)) Prims.int_zero uu___7 in + FStarC_Pprint.op_Hat_Hat uu___6 FStarC_Pprint.rbrace in + FStarC_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.colon uu___3 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.lbrace uu___2 in + FStarC_Pprint.group uu___1 +and (p_disjunctivePats : + FStarC_Parser_AST.term Prims.list Prims.list -> FStarC_Pprint.document) = + fun pats -> + let uu___ = str "\\/" in + FStarC_Pprint.separate_map uu___ p_conjunctivePats pats +and (p_conjunctivePats : + FStarC_Parser_AST.term Prims.list -> FStarC_Pprint.document) = + fun pats -> + let uu___ = + let uu___1 = FStarC_Pprint.op_Hat_Hat FStarC_Pprint.semi break1 in + FStarC_Pprint.separate_map uu___1 p_appTerm pats in + FStarC_Pprint.group uu___ +and (p_simpleTerm : + Prims.bool -> + Prims.bool -> FStarC_Parser_AST.term -> FStarC_Pprint.document) + = + fun ps -> + fun pb -> + fun e -> + match e.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Function (branches, uu___) -> + let uu___1 = + let uu___2 = + let uu___3 = str "function" in + let uu___4 = + separate_map_last FStarC_Pprint.hardline p_patternBranch + branches in + FStarC_Pprint.op_Hat_Slash_Hat uu___3 uu___4 in + FStarC_Pprint.group uu___2 in + let uu___2 = paren_if (ps || pb) in uu___2 uu___1 + | FStarC_Parser_AST.Abs (pats, e1) -> + let uu___ = p_term_sep false pb e1 in + (match uu___ with + | (comm, doc) -> + let prefix = + let uu___1 = str "fun" in + let uu___2 = + let uu___3 = + FStarC_Pprint.separate_map break1 p_atomicPattern pats in + FStarC_Pprint.op_Hat_Slash_Hat uu___3 + FStarC_Pprint.rarrow in + op_Hat_Slash_Plus_Hat uu___1 uu___2 in + let uu___1 = + if comm <> FStarC_Pprint.empty + then + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline + doc in + FStarC_Pprint.op_Hat_Hat comm uu___4 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline uu___3 in + FStarC_Pprint.op_Hat_Hat prefix uu___2 + else + (let uu___3 = op_Hat_Slash_Plus_Hat prefix doc in + FStarC_Pprint.group uu___3) in + let uu___2 = paren_if ps in uu___2 uu___1) + | uu___ -> p_tmIff e +and (p_maybeFocusArrow : Prims.bool -> FStarC_Pprint.document) = + fun b -> if b then str "~>" else FStarC_Pprint.rarrow +and (p_patternBranch : + Prims.bool -> + (FStarC_Parser_AST.pattern * FStarC_Parser_AST.term + FStar_Pervasives_Native.option * FStarC_Parser_AST.term) -> + FStarC_Pprint.document) + = + fun pb -> + fun uu___ -> + match uu___ with + | (pat, when_opt, e) -> + let one_pattern_branch p = + let branch = + match when_opt with + | FStar_Pervasives_Native.None -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = p_tuplePattern p in + let uu___5 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space + FStarC_Pprint.rarrow in + FStarC_Pprint.op_Hat_Hat uu___4 uu___5 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___3 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.bar uu___2 in + FStarC_Pprint.group uu___1 + | FStar_Pervasives_Native.Some f -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = p_tuplePattern p in + let uu___7 = str "when" in + FStarC_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in + FStarC_Pprint.group uu___5 in + let uu___5 = + let uu___6 = + let uu___7 = p_tmFormula f in + [uu___7; FStarC_Pprint.rarrow] in + FStarC_Pprint.flow break1 uu___6 in + FStarC_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___3 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.bar uu___2 in + FStarC_Pprint.hang (Prims.of_int (2)) uu___1 in + let uu___1 = p_term_sep false pb e in + match uu___1 with + | (comm, doc) -> + if pb + then + (if comm = FStarC_Pprint.empty + then + let uu___2 = op_Hat_Slash_Plus_Hat branch doc in + FStarC_Pprint.group uu___2 + else + (let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Pprint.op_Hat_Hat break1 comm in + FStarC_Pprint.op_Hat_Hat doc uu___7 in + op_Hat_Slash_Plus_Hat branch uu___6 in + FStarC_Pprint.group uu___5 in + let uu___5 = + let uu___6 = + let uu___7 = + inline_comment_or_above comm doc + FStarC_Pprint.empty in + jump2 uu___7 in + FStarC_Pprint.op_Hat_Hat branch uu___6 in + FStarC_Pprint.ifflat uu___4 uu___5 in + FStarC_Pprint.group uu___3)) + else + if comm <> FStarC_Pprint.empty + then + (let uu___3 = + let uu___4 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline doc in + FStarC_Pprint.op_Hat_Hat comm uu___4 in + op_Hat_Slash_Plus_Hat branch uu___3) + else op_Hat_Slash_Plus_Hat branch doc in + (match pat.FStarC_Parser_AST.pat with + | FStarC_Parser_AST.PatOr pats -> + (match FStarC_Compiler_List.rev pats with + | hd::tl -> + let last_pat_branch = one_pattern_branch hd in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.bar + FStarC_Pprint.space in + FStarC_Pprint.op_Hat_Hat break1 uu___6 in + FStarC_Pprint.separate_map uu___5 p_tuplePattern + (FStarC_Compiler_List.rev tl) in + FStarC_Pprint.op_Hat_Slash_Hat uu___4 + last_pat_branch in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___3 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.bar uu___2 in + FStarC_Pprint.group uu___1 + | [] -> + failwith "Impossible: disjunctive pattern can't be empty") + | uu___1 -> one_pattern_branch pat) +and (p_tmIff : FStarC_Parser_AST.term -> FStarC_Pprint.document) = + fun e -> + match e.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Op (id, e1::e2::[]) when + let uu___ = FStarC_Ident.string_of_id id in uu___ = "<==>" -> + let uu___ = str "<==>" in + let uu___1 = p_tmImplies e1 in + let uu___2 = p_tmIff e2 in infix0 uu___ uu___1 uu___2 + | uu___ -> p_tmImplies e +and (p_tmImplies : FStarC_Parser_AST.term -> FStarC_Pprint.document) = + fun e -> + match e.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Op (id, e1::e2::[]) when + let uu___ = FStarC_Ident.string_of_id id in uu___ = "==>" -> + let uu___ = str "==>" in + let uu___1 = + p_tmArrow (Arrows ((Prims.of_int (2)), (Prims.of_int (2)))) false + p_tmFormula e1 in + let uu___2 = p_tmImplies e2 in infix0 uu___ uu___1 uu___2 + | uu___ -> + p_tmArrow (Arrows ((Prims.of_int (2)), (Prims.of_int (2)))) false + p_tmFormula e +and (format_sig : + annotation_style -> + FStarC_Pprint.document Prims.list -> + FStarC_Pprint.document -> + Prims.bool -> Prims.bool -> FStarC_Pprint.document) + = + fun style -> + fun terms -> + fun ret_d -> + fun no_last_op -> + fun flat_space -> + let uu___ = + match style with + | Arrows (n, ln) -> + let uu___1 = + let uu___2 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.rarrow break1 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___2 in + let uu___2 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.rarrow + FStarC_Pprint.space in + (n, ln, uu___1, uu___2) + | Binders (n, ln, parens) -> + let uu___1 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.colon + FStarC_Pprint.space in + (n, ln, break1, uu___1) in + match uu___ with + | (n, last_n, sep, last_op) -> + let last_op1 = + if + ((FStarC_Compiler_List.length terms) > Prims.int_zero) && + (Prims.op_Negation no_last_op) + then last_op + else FStarC_Pprint.empty in + let one_line_space = + if + (Prims.op_Negation (ret_d = FStarC_Pprint.empty)) || + (Prims.op_Negation no_last_op) + then FStarC_Pprint.space + else FStarC_Pprint.empty in + let single_line_arg_indent = + FStarC_Pprint.repeat n FStarC_Pprint.space in + let fs = + if flat_space + then FStarC_Pprint.space + else FStarC_Pprint.empty in + (match FStarC_Compiler_List.length terms with + | uu___1 when uu___1 = Prims.int_zero -> ret_d + | uu___1 -> + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Pprint.separate sep terms in + let uu___6 = + let uu___7 = + FStarC_Pprint.op_Hat_Hat last_op1 ret_d in + FStarC_Pprint.op_Hat_Hat one_line_space uu___7 in + FStarC_Pprint.op_Hat_Hat uu___5 uu___6 in + FStarC_Pprint.op_Hat_Hat fs uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Pprint.separate sep terms in + FStarC_Pprint.op_Hat_Hat fs uu___8 in + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Pprint.op_Hat_Hat sep + single_line_arg_indent in + let uu___12 = + FStarC_Compiler_List.map + (fun x -> + let uu___13 = + FStarC_Pprint.hang + (Prims.of_int (2)) x in + FStarC_Pprint.align uu___13) terms in + FStarC_Pprint.separate uu___11 uu___12 in + FStarC_Pprint.op_Hat_Hat + single_line_arg_indent uu___10 in + jump2 uu___9 in + FStarC_Pprint.ifflat uu___7 uu___8 in + FStarC_Pprint.group uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Pprint.op_Hat_Hat last_op1 ret_d in + FStarC_Pprint.hang last_n uu___8 in + FStarC_Pprint.align uu___7 in + FStarC_Pprint.prefix n Prims.int_one uu___5 uu___6 in + FStarC_Pprint.ifflat uu___3 uu___4 in + FStarC_Pprint.group uu___2) +and (p_tmArrow : + annotation_style -> + Prims.bool -> + (FStarC_Parser_AST.term -> FStarC_Pprint.document) -> + FStarC_Parser_AST.term -> FStarC_Pprint.document) + = + fun style -> + fun flat_space -> + fun p_Tm -> + fun e -> + let uu___ = + match style with + | Arrows uu___1 -> p_tmArrow' p_Tm e + | Binders uu___1 -> collapse_binders style p_Tm e in + match uu___ with + | (terms, ret_d) -> format_sig style terms ret_d false flat_space +and (p_tmArrow' : + (FStarC_Parser_AST.term -> FStarC_Pprint.document) -> + FStarC_Parser_AST.term -> + (FStarC_Pprint.document Prims.list * FStarC_Pprint.document)) + = + fun p_Tm -> + fun e -> + match e.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Product (bs, tgt) -> + let bs_ds = FStarC_Compiler_List.map (fun b -> p_binder false b) bs in + let uu___ = p_tmArrow' p_Tm tgt in + (match uu___ with + | (bs_ds', ret) -> + ((FStarC_Compiler_List.op_At bs_ds bs_ds'), ret)) + | uu___ -> let uu___1 = p_Tm e in ([], uu___1) +and (collapse_binders : + annotation_style -> + (FStarC_Parser_AST.term -> FStarC_Pprint.document) -> + FStarC_Parser_AST.term -> + (FStarC_Pprint.document Prims.list * FStarC_Pprint.document)) + = + fun style -> + fun p_Tm -> + fun e -> + let atomize = + match style with | Binders (uu___, uu___1, a) -> a | uu___ -> false in + let wrap is_tc doc = + if is_tc + then tc_arg doc + else if atomize then soft_parens_with_nesting doc else doc in + let rec accumulate_binders p_Tm1 e1 = + match e1.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Product (bs, tgt) -> + let bs_ds = + FStarC_Compiler_List.map + (fun b -> + let uu___ = p_binder' true false b in + let uu___1 = is_tc_binder b in + let uu___2 = is_joinable_binder b in + (uu___, uu___1, uu___2)) bs in + let uu___ = accumulate_binders p_Tm1 tgt in + (match uu___ with + | (bs_ds', ret) -> + ((FStarC_Compiler_List.op_At bs_ds bs_ds'), ret)) + | uu___ -> let uu___1 = p_Tm1 e1 in ([], uu___1) in + let fold_fun bs x = + let uu___ = x in + match uu___ with + | ((b1, t1), tc1, j1) -> + (match bs with + | [] -> [([b1], t1, tc1, j1)] + | hd::tl -> + let uu___1 = hd in + (match uu___1 with + | (b2s, t2, tc2, j2) -> + (match (t1, t2) with + | (FStar_Pervasives_Native.Some (typ1, catf1), + FStar_Pervasives_Native.Some (typ2, uu___2)) when + ((typ1 = typ2) && j1) && j2 -> + ((FStarC_Compiler_List.op_At b2s [b1]), t1, + false, true) + :: tl + | uu___2 -> ([b1], t1, tc1, j1) :: bs))) in + let p_collapsed_binder cb = + let uu___ = cb in + match uu___ with + | (bs, t, is_tc, uu___1) -> + (match t with + | FStar_Pervasives_Native.None -> + (match bs with + | b::[] -> wrap is_tc b + | uu___2 -> failwith "Impossible") + | FStar_Pervasives_Native.Some (typ, f) -> + (match bs with + | [] -> failwith "Impossible" + | hd::tl -> + let uu___2 = + let uu___3 = + FStarC_Compiler_List.fold_left + (fun x -> + fun y -> + let uu___4 = + FStarC_Pprint.op_Hat_Hat + FStarC_Pprint.space y in + FStarC_Pprint.op_Hat_Hat x uu___4) hd tl in + f uu___3 typ in + wrap is_tc uu___2)) in + let uu___ = accumulate_binders p_Tm e in + match uu___ with + | (bs_ds, ret_d) -> + let binders = FStarC_Compiler_List.fold_left fold_fun [] bs_ds in + let uu___1 = map_rev p_collapsed_binder binders in + (uu___1, ret_d) +and (p_tmFormula : FStarC_Parser_AST.term -> FStarC_Pprint.document) = + fun e -> + let conj = + let uu___ = + let uu___1 = str "/\\" in FStarC_Pprint.op_Hat_Hat uu___1 break1 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___ in + let disj = + let uu___ = + let uu___1 = str "\\/" in FStarC_Pprint.op_Hat_Hat uu___1 break1 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___ in + let formula = p_tmDisjunction e in + FStarC_Pprint.flow_map disj + (fun d -> + FStarC_Pprint.flow_map conj (fun x -> FStarC_Pprint.group x) d) + formula +and (p_tmDisjunction : + FStarC_Parser_AST.term -> FStarC_Pprint.document Prims.list Prims.list) = + fun e -> + match e.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Op (id, e1::e2::[]) when + let uu___ = FStarC_Ident.string_of_id id in uu___ = "\\/" -> + let uu___ = p_tmDisjunction e1 in + let uu___1 = let uu___2 = p_tmConjunction e2 in [uu___2] in + FStarC_Compiler_List.op_At uu___ uu___1 + | uu___ -> let uu___1 = p_tmConjunction e in [uu___1] +and (p_tmConjunction : + FStarC_Parser_AST.term -> FStarC_Pprint.document Prims.list) = + fun e -> + match e.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Op (id, e1::e2::[]) when + let uu___ = FStarC_Ident.string_of_id id in uu___ = "/\\" -> + let uu___ = p_tmConjunction e1 in + let uu___1 = let uu___2 = p_tmTuple e2 in [uu___2] in + FStarC_Compiler_List.op_At uu___ uu___1 + | uu___ -> let uu___1 = p_tmTuple e in [uu___1] +and (p_tmTuple : FStarC_Parser_AST.term -> FStarC_Pprint.document) = + fun e -> with_comment p_tmTuple' e e.FStarC_Parser_AST.range +and (p_tmTuple' : FStarC_Parser_AST.term -> FStarC_Pprint.document) = + fun e -> + match e.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Construct (lid, args) when + (is_tuple_constructor lid) && (all1_explicit args) -> + let uu___ = FStarC_Pprint.op_Hat_Hat FStarC_Pprint.comma break1 in + FStarC_Pprint.separate_map uu___ + (fun uu___1 -> match uu___1 with | (e1, uu___2) -> p_tmEq e1) args + | uu___ -> p_tmEq e +and (paren_if_gt : + Prims.int -> Prims.int -> FStarC_Pprint.document -> FStarC_Pprint.document) + = + fun curr -> + fun mine -> + fun doc -> + if mine > curr + then + let uu___ = + let uu___1 = FStarC_Pprint.op_Hat_Hat doc FStarC_Pprint.rparen in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.lparen uu___1 in + FStarC_Pprint.group uu___ + else doc +and (p_tmEqWith : + (FStarC_Parser_AST.term -> FStarC_Pprint.document) -> + FStarC_Parser_AST.term -> FStarC_Pprint.document) + = + fun p_X -> + fun e -> + let n = + max_level + (FStarC_Compiler_List.op_At [colon_equals; pipe_right] + operatorInfix0ad12) in + p_tmEqWith' p_X n e +and (p_tmEqWith' : + (FStarC_Parser_AST.term -> FStarC_Pprint.document) -> + Prims.int -> FStarC_Parser_AST.term -> FStarC_Pprint.document) + = + fun p_X -> + fun curr -> + fun e -> + match e.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Op (op, e1::e2::[]) when + (let uu___ = + (let uu___1 = FStarC_Ident.string_of_id op in uu___1 = "==>") + || + (let uu___1 = FStarC_Ident.string_of_id op in + uu___1 = "<==>") in + Prims.op_Negation uu___) && + (((is_operatorInfix0ad12 op) || + (let uu___ = FStarC_Ident.string_of_id op in uu___ = "=")) + || + (let uu___ = FStarC_Ident.string_of_id op in uu___ = "|>")) + -> + let op1 = FStarC_Ident.string_of_id op in + let uu___ = levels op1 in + (match uu___ with + | (left, mine, right) -> + let uu___1 = + let uu___2 = str op1 in + let uu___3 = p_tmEqWith' p_X left e1 in + let uu___4 = p_tmEqWith' p_X right e2 in + infix0 uu___2 uu___3 uu___4 in + paren_if_gt curr mine uu___1) + | FStarC_Parser_AST.Op (id, e1::e2::[]) when + let uu___ = FStarC_Ident.string_of_id id in uu___ = ":=" -> + let uu___ = + let uu___1 = p_tmEqWith p_X e1 in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = p_tmEqWith p_X e2 in + op_Hat_Slash_Plus_Hat FStarC_Pprint.equals uu___5 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.colon uu___4 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___3 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | FStarC_Parser_AST.Op (id, e1::[]) when + let uu___ = FStarC_Ident.string_of_id id in uu___ = "-" -> + let uu___ = levels "-" in + (match uu___ with + | (left, mine, right) -> + let uu___1 = p_tmEqWith' p_X mine e1 in + FStarC_Pprint.op_Hat_Slash_Hat FStarC_Pprint.minus uu___1) + | uu___ -> p_tmNoEqWith p_X e +and (p_tmNoEqWith : + (FStarC_Parser_AST.term -> FStarC_Pprint.document) -> + FStarC_Parser_AST.term -> FStarC_Pprint.document) + = + fun p_X -> + fun e -> + let n = max_level [colon_colon; amp; opinfix3; opinfix4] in + p_tmNoEqWith' false p_X n e +and (p_tmNoEqWith' : + Prims.bool -> + (FStarC_Parser_AST.term -> FStarC_Pprint.document) -> + Prims.int -> FStarC_Parser_AST.term -> FStarC_Pprint.document) + = + fun inside_tuple -> + fun p_X -> + fun curr -> + fun e -> + match e.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Construct (lid, (e1, uu___)::(e2, uu___1)::[]) + when FStarC_Ident.lid_equals lid FStarC_Parser_Const.cons_lid + -> + let op = "::" in + let uu___2 = levels op in + (match uu___2 with + | (left, mine, right) -> + let uu___3 = + let uu___4 = str op in + let uu___5 = p_tmNoEqWith' false p_X left e1 in + let uu___6 = p_tmNoEqWith' false p_X right e2 in + infix0 uu___4 uu___5 uu___6 in + paren_if_gt curr mine uu___3) + | FStarC_Parser_AST.Sum (binders, res) -> + let op = "&" in + let uu___ = levels op in + (match uu___ with + | (left, mine, right) -> + let p_dsumfst bt = + match bt with + | FStar_Pervasives.Inl b -> + let uu___1 = p_binder false b in + let uu___2 = + let uu___3 = + let uu___4 = str op in + FStarC_Pprint.op_Hat_Hat uu___4 break1 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space + uu___3 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 + | FStar_Pervasives.Inr t -> + let uu___1 = p_tmNoEqWith' false p_X left t in + let uu___2 = + let uu___3 = + let uu___4 = str op in + FStarC_Pprint.op_Hat_Hat uu___4 break1 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space + uu___3 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + let uu___1 = + let uu___2 = FStarC_Pprint.concat_map p_dsumfst binders in + let uu___3 = p_tmNoEqWith' false p_X right res in + FStarC_Pprint.op_Hat_Hat uu___2 uu___3 in + paren_if_gt curr mine uu___1) + | FStarC_Parser_AST.Op (op, e1::e2::[]) when is_operatorInfix34 op + -> + let op1 = FStarC_Ident.string_of_id op in + let uu___ = levels op1 in + (match uu___ with + | (left, mine, right) -> + let uu___1 = + let uu___2 = str op1 in + let uu___3 = p_tmNoEqWith' false p_X left e1 in + let uu___4 = p_tmNoEqWith' false p_X right e2 in + infix0 uu___2 uu___3 uu___4 in + paren_if_gt curr mine uu___1) + | FStarC_Parser_AST.Record (with_opt, record_fields) -> + let uu___ = + let uu___1 = + default_or_map FStarC_Pprint.empty p_with_clause with_opt in + let uu___2 = + let uu___3 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.semi break1 in + separate_map_last uu___3 p_simpleDef record_fields in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + braces_with_nesting uu___ + | FStarC_Parser_AST.Op (id, e1::[]) when + let uu___ = FStarC_Ident.string_of_id id in uu___ = "~" -> + let uu___ = + let uu___1 = str "~" in + let uu___2 = p_atomicTerm e1 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | FStarC_Parser_AST.Paren p when inside_tuple -> + (match p.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Op (id, e1::e2::[]) when + let uu___ = FStarC_Ident.string_of_id id in uu___ = "*" -> + let op = "*" in + let uu___ = levels op in + (match uu___ with + | (left, mine, right) -> + let uu___1 = + let uu___2 = str op in + let uu___3 = p_tmNoEqWith' true p_X left e1 in + let uu___4 = p_tmNoEqWith' true p_X right e2 in + infix0 uu___2 uu___3 uu___4 in + paren_if_gt curr mine uu___1) + | uu___ -> p_X e) + | uu___ -> p_X e +and (p_tmEqNoRefinement : FStarC_Parser_AST.term -> FStarC_Pprint.document) = + fun e -> p_tmEqWith p_appTerm e +and (p_tmEq : FStarC_Parser_AST.term -> FStarC_Pprint.document) = + fun e -> p_tmEqWith p_tmRefinement e +and (p_tmNoEq : FStarC_Parser_AST.term -> FStarC_Pprint.document) = + fun e -> p_tmNoEqWith p_tmRefinement e +and (p_tmRefinement : FStarC_Parser_AST.term -> FStarC_Pprint.document) = + fun e -> + match e.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.NamedTyp (lid, e1) -> + let uu___ = + let uu___1 = p_lident lid in + let uu___2 = + let uu___3 = p_appTerm e1 in + FStarC_Pprint.op_Hat_Slash_Hat FStarC_Pprint.colon uu___3 in + FStarC_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | FStarC_Parser_AST.Refine (b, phi) -> p_refinedBinder b phi + | uu___ -> p_appTerm e +and (p_with_clause : FStarC_Parser_AST.term -> FStarC_Pprint.document) = + fun e -> + let uu___ = p_appTerm e in + let uu___1 = + let uu___2 = + let uu___3 = str "with" in FStarC_Pprint.op_Hat_Hat uu___3 break1 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___2 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 +and (p_refinedBinder : + FStarC_Parser_AST.binder -> + FStarC_Parser_AST.term -> FStarC_Pprint.document) + = + fun b -> + fun phi -> + match b.FStarC_Parser_AST.b with + | FStarC_Parser_AST.Annotated (lid, t) -> + let uu___ = p_lident lid in + p_refinement b.FStarC_Parser_AST.aqual + b.FStarC_Parser_AST.battributes uu___ t phi + | FStarC_Parser_AST.Variable lid -> + let uu___ = p_lident lid in + let uu___1 = + let uu___2 = FStarC_Ident.range_of_id lid in + FStarC_Parser_AST.mk_term FStarC_Parser_AST.Wild uu___2 + FStarC_Parser_AST.Type_level in + p_refinement b.FStarC_Parser_AST.aqual + b.FStarC_Parser_AST.battributes uu___ uu___1 phi + | FStarC_Parser_AST.TAnnotated uu___ -> failwith "Is this still used ?" + | FStarC_Parser_AST.TVariable uu___ -> + let uu___1 = + let uu___2 = FStarC_Parser_AST.binder_to_string b in + FStarC_Compiler_Util.format1 + "Impossible: a refined binder ought to be annotated (%s)" + uu___2 in + failwith uu___1 + | FStarC_Parser_AST.NoName uu___ -> + let uu___1 = + let uu___2 = FStarC_Parser_AST.binder_to_string b in + FStarC_Compiler_Util.format1 + "Impossible: a refined binder ought to be annotated (%s)" + uu___2 in + failwith uu___1 +and (p_simpleDef : + Prims.bool -> + (FStarC_Ident.lid * FStarC_Parser_AST.term) -> FStarC_Pprint.document) + = + fun ps -> + fun uu___ -> + match uu___ with + | (lid, e) -> + let uu___1 = + let uu___2 = p_qlidentOrOperator lid in + let uu___3 = + let uu___4 = p_noSeqTermAndComment ps false e in + FStarC_Pprint.op_Hat_Slash_Hat FStarC_Pprint.equals uu___4 in + FStarC_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in + FStarC_Pprint.group uu___1 +and (p_appTerm : FStarC_Parser_AST.term -> FStarC_Pprint.document) = + fun e -> + match e.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.App uu___ when is_general_application e -> + let uu___1 = head_and_args e in + (match uu___1 with + | (head, args) -> + (match args with + | e1::e2::[] when + (FStar_Pervasives_Native.snd e1) = FStarC_Parser_AST.Infix + -> + let uu___2 = p_argTerm e1 in + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = str "`" in + let uu___7 = + let uu___8 = p_indexingTerm head in + let uu___9 = str "`" in + FStarC_Pprint.op_Hat_Hat uu___8 uu___9 in + FStarC_Pprint.op_Hat_Hat uu___6 uu___7 in + FStarC_Pprint.group uu___5 in + let uu___5 = p_argTerm e2 in + FStarC_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in + FStarC_Pprint.op_Hat_Slash_Hat uu___2 uu___3 + | uu___2 -> + let uu___3 = + let uu___4 = p_indexingTerm head in (uu___4, args) in + (match uu___3 with + | (head_doc, args1) -> + let uu___4 = + let uu___5 = + FStarC_Pprint.op_Hat_Hat head_doc + FStarC_Pprint.space in + soft_surround_map_or_flow (Prims.of_int (2)) + Prims.int_zero head_doc uu___5 break1 + FStarC_Pprint.empty p_argTerm args1 in + FStarC_Pprint.group uu___4))) + | FStarC_Parser_AST.Construct (lid, args) when + ((is_general_construction e) && + (let uu___ = (is_dtuple_constructor lid) && (all1_explicit args) in + Prims.op_Negation uu___)) + && + (let uu___ = (is_tuple_constructor lid) && (all1_explicit args) in + Prims.op_Negation uu___) + -> + (match args with + | [] -> p_quident lid + | arg::[] -> + let uu___ = + let uu___1 = p_quident lid in + let uu___2 = p_argTerm arg in + FStarC_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | hd::tl -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = p_quident lid in + let uu___4 = p_argTerm hd in prefix2 uu___3 uu___4 in + FStarC_Pprint.group uu___2 in + let uu___2 = + let uu___3 = FStarC_Pprint.separate_map break1 p_argTerm tl in + jump2 uu___3 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___) + | uu___ -> p_indexingTerm e +and (p_argTerm : + (FStarC_Parser_AST.term * FStarC_Parser_AST.imp) -> FStarC_Pprint.document) + = + fun arg_imp -> + match arg_imp with + | (u, FStarC_Parser_AST.UnivApp) -> p_universe u + | (e, FStarC_Parser_AST.FsTypApp) -> + (FStarC_Errors.log_issue FStarC_Parser_AST.hasRange_term e + FStarC_Errors_Codes.Warning_UnexpectedFsTypApp () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Unexpected FsTypApp, output might not be formatted correctly."); + (let uu___1 = p_indexingTerm e in + FStarC_Pprint.surround (Prims.of_int (2)) Prims.int_one + FStarC_Pprint.langle uu___1 FStarC_Pprint.rangle)) + | (e, FStarC_Parser_AST.Hash) -> + let uu___ = str "#" in + let uu___1 = p_indexingTerm e in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 + | (e, FStarC_Parser_AST.HashBrace t) -> + let uu___ = str "#[" in + let uu___1 = + let uu___2 = p_indexingTerm t in + let uu___3 = + let uu___4 = str "]" in + let uu___5 = p_indexingTerm e in + FStarC_Pprint.op_Hat_Hat uu___4 uu___5 in + FStarC_Pprint.op_Hat_Hat uu___2 uu___3 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 + | (e, FStarC_Parser_AST.Infix) -> p_indexingTerm e + | (e, FStarC_Parser_AST.Nothing) -> p_indexingTerm e +and (p_indexingTerm_aux : + (FStarC_Parser_AST.term -> FStarC_Pprint.document) -> + FStarC_Parser_AST.term -> FStarC_Pprint.document) + = + fun exit -> + fun e -> + match e.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Op (id, e1::e2::[]) when + let uu___ = FStarC_Ident.string_of_id id in uu___ = ".()" -> + let uu___ = + let uu___1 = p_indexingTerm_aux p_atomicTermNotQUident e1 in + let uu___2 = + let uu___3 = + let uu___4 = p_term false false e2 in + soft_parens_with_nesting uu___4 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.dot uu___3 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | FStarC_Parser_AST.Op (id, e1::e2::[]) when + let uu___ = FStarC_Ident.string_of_id id in uu___ = ".[]" -> + let uu___ = + let uu___1 = p_indexingTerm_aux p_atomicTermNotQUident e1 in + let uu___2 = + let uu___3 = + let uu___4 = p_term false false e2 in + soft_brackets_with_nesting uu___4 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.dot uu___3 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | FStarC_Parser_AST.Op (id, e1::e2::[]) when + let uu___ = FStarC_Ident.string_of_id id in uu___ = ".(||)" -> + let uu___ = + let uu___1 = p_indexingTerm_aux p_atomicTermNotQUident e1 in + let uu___2 = + let uu___3 = + let uu___4 = p_term false false e2 in + soft_lens_access_with_nesting uu___4 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.dot uu___3 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | FStarC_Parser_AST.Op (id, e1::e2::[]) when + let uu___ = FStarC_Ident.string_of_id id in uu___ = ".[||]" -> + let uu___ = + let uu___1 = p_indexingTerm_aux p_atomicTermNotQUident e1 in + let uu___2 = + let uu___3 = + let uu___4 = p_term false false e2 in + soft_brackets_lens_access_with_nesting uu___4 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.dot uu___3 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | uu___ -> exit e +and (p_indexingTerm : FStarC_Parser_AST.term -> FStarC_Pprint.document) = + fun e -> p_indexingTerm_aux p_atomicTerm e +and (p_atomicTerm : FStarC_Parser_AST.term -> FStarC_Pprint.document) = + fun e -> + match e.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.LetOpen (lid, e1) -> + let uu___ = p_quident lid in + let uu___1 = + let uu___2 = + let uu___3 = p_term false false e1 in + soft_parens_with_nesting uu___3 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.dot uu___2 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 + | FStarC_Parser_AST.Name lid -> p_quident lid + | FStarC_Parser_AST.Construct (lid, []) when is_general_construction e -> + p_quident lid + | FStarC_Parser_AST.Op (op, e1::[]) when is_general_prefix_op op -> + let uu___ = let uu___1 = FStarC_Ident.string_of_id op in str uu___1 in + let uu___1 = p_atomicTerm e1 in FStarC_Pprint.op_Hat_Hat uu___ uu___1 + | FStarC_Parser_AST.ListLiteral ts -> + let uu___ = + let uu___1 = FStarC_Pprint.op_Hat_Hat FStarC_Pprint.semi break1 in + separate_map_or_flow_last uu___1 + (fun ps -> p_noSeqTermAndComment ps false) ts in + FStarC_Pprint.surround (Prims.of_int (2)) Prims.int_zero + FStarC_Pprint.lbracket uu___ FStarC_Pprint.rbracket + | FStarC_Parser_AST.SeqLiteral ts -> + let uu___ = + let uu___1 = FStarC_Pprint.doc_of_string "seq!" in + FStarC_Pprint.op_Hat_Hat uu___1 FStarC_Pprint.lbracket in + let uu___1 = + let uu___2 = FStarC_Pprint.op_Hat_Hat FStarC_Pprint.semi break1 in + separate_map_or_flow_last uu___2 + (fun ps -> p_noSeqTermAndComment ps false) ts in + FStarC_Pprint.surround (Prims.of_int (2)) Prims.int_zero uu___ uu___1 + FStarC_Pprint.rbracket + | uu___ -> p_atomicTermNotQUident e +and (p_atomicTermNotQUident : + FStarC_Parser_AST.term -> FStarC_Pprint.document) = + fun e -> + match e.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Wild -> FStarC_Pprint.underscore + | FStarC_Parser_AST.Var lid when + FStarC_Ident.lid_equals lid FStarC_Parser_Const.assert_lid -> + str "assert" + | FStarC_Parser_AST.Var lid when + FStarC_Ident.lid_equals lid FStarC_Parser_Const.assume_lid -> + str "assume" + | FStarC_Parser_AST.Tvar tv -> p_tvar tv + | FStarC_Parser_AST.Const c -> + (match c with + | FStarC_Const.Const_char x when x = 10 -> str "0x0Az" + | uu___ -> p_constant c) + | FStarC_Parser_AST.Name lid when + FStarC_Ident.lid_equals lid FStarC_Parser_Const.true_lid -> + str "True" + | FStarC_Parser_AST.Name lid when + FStarC_Ident.lid_equals lid FStarC_Parser_Const.false_lid -> + str "False" + | FStarC_Parser_AST.Op (op, e1::[]) when is_general_prefix_op op -> + let uu___ = let uu___1 = FStarC_Ident.string_of_id op in str uu___1 in + let uu___1 = p_atomicTermNotQUident e1 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 + | FStarC_Parser_AST.Op (op, []) -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Ident.string_of_id op in str uu___3 in + let uu___3 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space + FStarC_Pprint.rparen in + FStarC_Pprint.op_Hat_Hat uu___2 uu___3 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.space uu___1 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.lparen uu___ + | FStarC_Parser_AST.Construct (lid, args) when + (is_dtuple_constructor lid) && (all1_explicit args) -> + let uu___ = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.lparen FStarC_Pprint.bar in + let uu___1 = + let uu___2 = FStarC_Pprint.op_Hat_Hat FStarC_Pprint.comma break1 in + FStarC_Pprint.separate_map uu___2 + (fun uu___3 -> match uu___3 with | (e1, uu___4) -> p_tmEq e1) + args in + let uu___2 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.bar FStarC_Pprint.rparen in + FStarC_Pprint.surround (Prims.of_int (2)) Prims.int_one uu___ uu___1 + uu___2 + | FStarC_Parser_AST.Construct (lid, args) when + (is_tuple_constructor lid) && (all1_explicit args) -> + let uu___ = p_tmTuple e in FStarC_Pprint.parens uu___ + | FStarC_Parser_AST.Project (e1, lid) -> + let uu___ = + let uu___1 = p_atomicTermNotQUident e1 in + let uu___2 = + let uu___3 = p_qlident lid in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.dot uu___3 in + FStarC_Pprint.prefix (Prims.of_int (2)) Prims.int_zero uu___1 + uu___2 in + FStarC_Pprint.group uu___ + | uu___ -> p_projectionLHS e +and (p_projectionLHS : FStarC_Parser_AST.term -> FStarC_Pprint.document) = + fun e -> + match e.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Var lid -> p_qlident lid + | FStarC_Parser_AST.Projector (constr_lid, field_lid) -> + let uu___ = p_quident constr_lid in + let uu___1 = + let uu___2 = + let uu___3 = p_lident field_lid in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.dot uu___3 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.qmark uu___2 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 + | FStarC_Parser_AST.Discrim constr_lid -> + let uu___ = p_quident constr_lid in + FStarC_Pprint.op_Hat_Hat uu___ FStarC_Pprint.qmark + | FStarC_Parser_AST.Paren e1 -> + let uu___ = p_term_sep false false e1 in + (match uu___ with + | (comm, t) -> + let doc = soft_parens_with_nesting t in + if comm = FStarC_Pprint.empty + then doc + else + (let uu___2 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline doc in + FStarC_Pprint.op_Hat_Hat comm uu___2)) + | uu___ when is_ref_set e -> + let es = extract_from_ref_set e in + let uu___1 = + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.bang FStarC_Pprint.lbrace in + let uu___2 = + let uu___3 = FStarC_Pprint.op_Hat_Hat FStarC_Pprint.comma break1 in + separate_map_or_flow uu___3 p_appTerm es in + FStarC_Pprint.surround (Prims.of_int (2)) Prims.int_zero uu___1 + uu___2 FStarC_Pprint.rbrace + | FStarC_Parser_AST.Labeled (e1, s, b) -> + let uu___ = str (Prims.strcat "(*" (Prims.strcat s "*)")) in + let uu___1 = p_term false false e1 in + FStarC_Pprint.op_Hat_Slash_Hat uu___ uu___1 + | FStarC_Parser_AST.Op (op, args) when + let uu___ = handleable_op op args in Prims.op_Negation uu___ -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Ident.string_of_id op in + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length args) in + Prims.strcat uu___5 + " arguments couldn't be handled by the pretty printer" in + Prims.strcat " with " uu___4 in + Prims.strcat uu___2 uu___3 in + Prims.strcat "Operation " uu___1 in + failwith uu___ + | FStarC_Parser_AST.Uvar id -> + failwith "Unexpected universe variable out of universe context" + | FStarC_Parser_AST.Wild -> + let uu___ = p_term false false e in soft_parens_with_nesting uu___ + | FStarC_Parser_AST.Const uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.Op uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.Tvar uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.Var uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.Name uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.Construct uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.Abs uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.App uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.Let uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.LetOperator uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.LetOpen uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.LetOpenRecord uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.Seq uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.Bind uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.If uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.Match uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.TryWith uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.Ascribed uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.Record uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.Project uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.Product uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.Sum uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.QForall uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.QExists uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.QuantOp uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.Refine uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.NamedTyp uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.Requires uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.Ensures uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.Decreases uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.Attributes uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.Quote uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.VQuote uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.Antiquote uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.CalcProof uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.ListLiteral uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.SeqLiteral uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.ElimExists uu___ -> + let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.LexList l -> + let uu___ = + let uu___1 = str "%" in + let uu___2 = p_term_list false false l in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | FStarC_Parser_AST.WFOrder (rel, e1) -> p_dec_wf false false rel e1 +and (p_constant : FStarC_Const.sconst -> FStarC_Pprint.document) = + fun uu___ -> + match uu___ with + | FStarC_Const.Const_effect -> str "Effect" + | FStarC_Const.Const_unit -> str "()" + | FStarC_Const.Const_bool b -> FStarC_Pprint.doc_of_bool b + | FStarC_Const.Const_real r -> str (Prims.strcat r "R") + | FStarC_Const.Const_char x -> FStarC_Pprint.doc_of_char x + | FStarC_Const.Const_string (s, uu___1) -> + let uu___2 = str (FStarC_Compiler_String.escaped s) in + FStarC_Pprint.dquotes uu___2 + | FStarC_Const.Const_int (repr, sign_width_opt) -> + let signedness uu___1 = + match uu___1 with + | FStarC_Const.Unsigned -> str "u" + | FStarC_Const.Signed -> FStarC_Pprint.empty in + let width uu___1 = + match uu___1 with + | FStarC_Const.Int8 -> str "y" + | FStarC_Const.Int16 -> str "s" + | FStarC_Const.Int32 -> str "l" + | FStarC_Const.Int64 -> str "L" in + let suffix uu___1 = + match uu___1 with + | (s, w) -> + (match (s, w) with + | (uu___2, FStarC_Const.Sizet) -> str "sz" + | uu___2 -> + let uu___3 = signedness s in + let uu___4 = width w in + FStarC_Pprint.op_Hat_Hat uu___3 uu___4) in + let ending = default_or_map FStarC_Pprint.empty suffix sign_width_opt in + let uu___1 = str repr in FStarC_Pprint.op_Hat_Hat uu___1 ending + | FStarC_Const.Const_range_of -> str "range_of" + | FStarC_Const.Const_set_range_of -> str "set_range_of" + | FStarC_Const.Const_range r -> + let uu___1 = FStarC_Compiler_Range_Ops.string_of_range r in + str uu___1 + | FStarC_Const.Const_reify uu___1 -> str "reify" + | FStarC_Const.Const_reflect lid -> + let uu___1 = p_quident lid in + let uu___2 = + let uu___3 = + let uu___4 = str "reflect" in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.dot uu___4 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.qmark uu___3 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 +and (p_universe : FStarC_Parser_AST.term -> FStarC_Pprint.document) = + fun u -> + let uu___ = str "u#" in + let uu___1 = p_atomicUniverse u in FStarC_Pprint.op_Hat_Hat uu___ uu___1 +and (p_universeFrom : FStarC_Parser_AST.term -> FStarC_Pprint.document) = + fun u -> + match u.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Op (id, u1::u2::[]) when + let uu___ = FStarC_Ident.string_of_id id in uu___ = "+" -> + let uu___ = + let uu___1 = p_universeFrom u1 in + let uu___2 = + let uu___3 = p_universeFrom u2 in + FStarC_Pprint.op_Hat_Slash_Hat FStarC_Pprint.plus uu___3 in + FStarC_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in + FStarC_Pprint.group uu___ + | FStarC_Parser_AST.App uu___ -> + let uu___1 = head_and_args u in + (match uu___1 with + | (head, args) -> + (match head.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Var maybe_max_lid when + FStarC_Ident.lid_equals maybe_max_lid + FStarC_Parser_Const.max_lid + -> + let uu___2 = + let uu___3 = p_qlident FStarC_Parser_Const.max_lid in + let uu___4 = + FStarC_Pprint.separate_map FStarC_Pprint.space + (fun uu___5 -> + match uu___5 with + | (u1, uu___6) -> p_atomicUniverse u1) args in + op_Hat_Slash_Plus_Hat uu___3 uu___4 in + FStarC_Pprint.group uu___2 + | uu___2 -> + let uu___3 = + let uu___4 = FStarC_Parser_AST.term_to_string u in + FStarC_Compiler_Util.format1 + "Invalid term in universe context %s" uu___4 in + failwith uu___3)) + | uu___ -> p_atomicUniverse u +and (p_atomicUniverse : FStarC_Parser_AST.term -> FStarC_Pprint.document) = + fun u -> + match u.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Wild -> FStarC_Pprint.underscore + | FStarC_Parser_AST.Const (FStarC_Const.Const_int (r, sw)) -> + p_constant (FStarC_Const.Const_int (r, sw)) + | FStarC_Parser_AST.Uvar id -> + let uu___ = FStarC_Ident.string_of_id id in str uu___ + | FStarC_Parser_AST.Paren u1 -> + let uu___ = p_universeFrom u1 in soft_parens_with_nesting uu___ + | FStarC_Parser_AST.App uu___ -> + let uu___1 = p_universeFrom u in soft_parens_with_nesting uu___1 + | FStarC_Parser_AST.Op (id, uu___::uu___1::[]) when + let uu___2 = FStarC_Ident.string_of_id id in uu___2 = "+" -> + let uu___2 = p_universeFrom u in soft_parens_with_nesting uu___2 + | uu___ -> + let uu___1 = + let uu___2 = FStarC_Parser_AST.term_to_string u in + FStarC_Compiler_Util.format1 "Invalid term in universe context %s" + uu___2 in + failwith uu___1 +let (term_to_document : FStarC_Parser_AST.term -> FStarC_Pprint.document) = + fun e -> p_term false false e +let (signature_to_document : + FStarC_Parser_AST.decl -> FStarC_Pprint.document) = fun e -> p_justSig e +let (decl_to_document : FStarC_Parser_AST.decl -> FStarC_Pprint.document) = + fun e -> p_decl e +let (pat_to_document : FStarC_Parser_AST.pattern -> FStarC_Pprint.document) = + fun p -> p_disjunctivePattern p +let (binder_to_document : FStarC_Parser_AST.binder -> FStarC_Pprint.document) + = fun b -> p_binder true b +let (modul_to_document : FStarC_Parser_AST.modul -> FStarC_Pprint.document) = + fun m -> + match m with + | FStarC_Parser_AST.Module (uu___, decls) -> + let uu___1 = FStarC_Compiler_List.map decl_to_document decls in + FStarC_Pprint.separate FStarC_Pprint.hardline uu___1 + | FStarC_Parser_AST.Interface (uu___, decls, uu___1) -> + let uu___2 = FStarC_Compiler_List.map decl_to_document decls in + FStarC_Pprint.separate FStarC_Pprint.hardline uu___2 +let (comments_to_document : + (Prims.string * FStarC_Compiler_Range_Type.range) Prims.list -> + FStarC_Pprint.document) + = + fun comments -> + FStarC_Pprint.separate_map FStarC_Pprint.hardline + (fun uu___ -> match uu___ with | (comment, range) -> str comment) + comments +let (extract_decl_range : FStarC_Parser_AST.decl -> decl_meta) = + fun d -> + let has_qs = + match ((d.FStarC_Parser_AST.quals), (d.FStarC_Parser_AST.d)) with + | ((FStarC_Parser_AST.Assumption)::[], FStarC_Parser_AST.Assume + (id, uu___)) -> false + | ([], uu___) -> false + | uu___ -> true in + { + r = (d.FStarC_Parser_AST.drange); + has_qs; + has_attrs = + (Prims.op_Negation + (FStarC_Compiler_List.isEmpty d.FStarC_Parser_AST.attrs)) + } +let (decls_with_comments_to_document : + FStarC_Parser_AST.decl Prims.list -> + (Prims.string * FStarC_Compiler_Range_Type.range) Prims.list -> + (FStarC_Pprint.document * (Prims.string * + FStarC_Compiler_Range_Type.range) Prims.list)) + = + fun decls -> + fun comments -> + match decls with + | [] -> (FStarC_Pprint.empty, comments) + | d::ds -> + let uu___ = ((d :: ds), (d.FStarC_Parser_AST.drange)) in + (match uu___ with + | (decls1, first_range) -> + (FStarC_Compiler_Effect.op_Colon_Equals comment_stack comments; + (let initial_comment = + let uu___2 = + FStarC_Compiler_Range_Ops.start_of_range first_range in + place_comments_until_pos Prims.int_zero Prims.int_one + uu___2 dummy_meta FStarC_Pprint.empty false true in + let doc = + separate_map_with_comments FStarC_Pprint.empty + FStarC_Pprint.empty p_decl decls1 extract_decl_range in + let comments1 = FStarC_Compiler_Effect.op_Bang comment_stack in + FStarC_Compiler_Effect.op_Colon_Equals comment_stack []; + (let uu___3 = FStarC_Pprint.op_Hat_Hat initial_comment doc in + (uu___3, comments1))))) +let (modul_with_comments_to_document : + FStarC_Parser_AST.modul -> + (Prims.string * FStarC_Compiler_Range_Type.range) Prims.list -> + (FStarC_Pprint.document * (Prims.string * + FStarC_Compiler_Range_Type.range) Prims.list)) + = + fun m -> + fun comments -> + let decls = + match m with + | FStarC_Parser_AST.Module (uu___, decls1) -> decls1 + | FStarC_Parser_AST.Interface (uu___, decls1, uu___1) -> decls1 in + decls_with_comments_to_document decls comments +let (decl_with_comments_to_document : + FStarC_Parser_AST.decl -> + (Prims.string * FStarC_Compiler_Range_Type.range) Prims.list -> + (FStarC_Pprint.document * (Prims.string * + FStarC_Compiler_Range_Type.range) Prims.list)) + = fun d -> fun comments -> decls_with_comments_to_document [d] comments \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Prettyprint.ml b/ocaml/fstar-lib/generated/FStarC_Prettyprint.ml new file mode 100644 index 00000000000..149c1a9b16d --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Prettyprint.ml @@ -0,0 +1,89 @@ +open Prims +type printing_mode = + | ToTempFile + | FromTempToStdout + | FromTempToFile +let (uu___is_ToTempFile : printing_mode -> Prims.bool) = + fun projectee -> match projectee with | ToTempFile -> true | uu___ -> false +let (uu___is_FromTempToStdout : printing_mode -> Prims.bool) = + fun projectee -> + match projectee with | FromTempToStdout -> true | uu___ -> false +let (uu___is_FromTempToFile : printing_mode -> Prims.bool) = + fun projectee -> + match projectee with | FromTempToFile -> true | uu___ -> false +let (temp_file_name : Prims.string -> Prims.string) = + fun f -> FStarC_Compiler_Util.format1 "%s.print_.fst" f +let (generate : printing_mode -> Prims.string Prims.list -> unit) = + fun m -> + fun filenames -> + let parse_and_prettyprint m1 filename = + let uu___ = FStarC_Parser_Driver.parse_file filename in + match uu___ with + | (modul, comments) -> + let outf = + match m1 with + | FromTempToStdout -> FStar_Pervasives_Native.None + | FromTempToFile -> + let outf1 = + FStarC_Compiler_Util.open_file_for_writing filename in + FStar_Pervasives_Native.Some outf1 + | ToTempFile -> + let outf1 = + let uu___1 = temp_file_name filename in + FStarC_Compiler_Util.open_file_for_writing uu___1 in + FStar_Pervasives_Native.Some outf1 in + let leftover_comments = + let comments1 = FStarC_Compiler_List.rev comments in + let uu___1 = + FStarC_Parser_ToDocument.modul_with_comments_to_document + modul comments1 in + match uu___1 with + | (doc, comments2) -> + ((match outf with + | FStar_Pervasives_Native.Some f -> + let uu___3 = + FStarC_Pprint.pretty_string + (FStarC_Compiler_Util.float_of_string "1.0") + (Prims.of_int (100)) doc in + FStarC_Compiler_Util.append_to_file f uu___3 + | FStar_Pervasives_Native.None -> + FStarC_Pprint.pretty_out_channel + (FStarC_Compiler_Util.float_of_string "1.0") + (Prims.of_int (100)) doc + FStarC_Compiler_Util.stdout); + comments2) in + let left_over_doc = + if + Prims.op_Negation + (FStarC_Compiler_List.isEmpty leftover_comments) + then + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Parser_ToDocument.comments_to_document + leftover_comments in + [uu___4] in + FStarC_Pprint.hardline :: uu___3 in + FStarC_Pprint.hardline :: uu___2 in + FStarC_Pprint.concat uu___1 + else + if m1 = FromTempToStdout + then + FStarC_Pprint.concat + [FStarC_Pprint.hardline; FStarC_Pprint.hardline] + else FStarC_Pprint.empty in + (match outf with + | FStar_Pervasives_Native.None -> + FStarC_Pprint.pretty_out_channel + (FStarC_Compiler_Util.float_of_string "1.0") + (Prims.of_int (100)) left_over_doc + FStarC_Compiler_Util.stdout + | FStar_Pervasives_Native.Some outf1 -> + ((let uu___2 = + FStarC_Pprint.pretty_string + (FStarC_Compiler_Util.float_of_string "1.0") + (Prims.of_int (100)) left_over_doc in + FStarC_Compiler_Util.append_to_file outf1 uu___2); + FStarC_Compiler_Util.close_out_channel outf1)) in + FStarC_Compiler_List.iter (parse_and_prettyprint m) filenames \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Profiling.ml b/ocaml/fstar-lib/generated/FStarC_Profiling.ml new file mode 100644 index 00000000000..c176a6e0187 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Profiling.ml @@ -0,0 +1,155 @@ +open Prims +type counter = + { + cid: Prims.string ; + total_time: Prims.int FStarC_Compiler_Effect.ref ; + running: Prims.bool FStarC_Compiler_Effect.ref ; + undercount: Prims.bool FStarC_Compiler_Effect.ref } +let (__proj__Mkcounter__item__cid : counter -> Prims.string) = + fun projectee -> + match projectee with | { cid; total_time; running; undercount;_} -> cid +let (__proj__Mkcounter__item__total_time : + counter -> Prims.int FStarC_Compiler_Effect.ref) = + fun projectee -> + match projectee with + | { cid; total_time; running; undercount;_} -> total_time +let (__proj__Mkcounter__item__running : + counter -> Prims.bool FStarC_Compiler_Effect.ref) = + fun projectee -> + match projectee with + | { cid; total_time; running; undercount;_} -> running +let (__proj__Mkcounter__item__undercount : + counter -> Prims.bool FStarC_Compiler_Effect.ref) = + fun projectee -> + match projectee with + | { cid; total_time; running; undercount;_} -> undercount +let (json_of_counter : counter -> FStarC_Json.json) = + fun c -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Compiler_Effect.op_Bang c.total_time in + FStarC_Json.JsonInt uu___4 in + ("total_time", uu___3) in + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Compiler_Effect.op_Bang c.running in + FStarC_Json.JsonBool uu___6 in + ("running", uu___5) in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Compiler_Effect.op_Bang c.undercount in + FStarC_Json.JsonBool uu___8 in + ("undercount", uu___7) in + [uu___6] in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + ("id", (FStarC_Json.JsonStr (c.cid))) :: uu___1 in + FStarC_Json.JsonAssoc uu___ +let (new_counter : Prims.string -> counter) = + fun cid -> + let uu___ = FStarC_Compiler_Util.mk_ref Prims.int_zero in + let uu___1 = FStarC_Compiler_Util.mk_ref false in + let uu___2 = FStarC_Compiler_Util.mk_ref false in + { cid; total_time = uu___; running = uu___1; undercount = uu___2 } +let (all_counters : counter FStarC_Compiler_Util.smap) = + FStarC_Compiler_Util.smap_create (Prims.of_int (20)) +let (create_or_lookup_counter : Prims.string -> counter) = + fun cid -> + let uu___ = FStarC_Compiler_Util.smap_try_find all_counters cid in + match uu___ with + | FStar_Pervasives_Native.Some c -> c + | FStar_Pervasives_Native.None -> + let c = new_counter cid in + (FStarC_Compiler_Util.smap_add all_counters cid c; c) +let profile : + 'a . + (unit -> 'a) -> + Prims.string FStar_Pervasives_Native.option -> Prims.string -> 'a + = + fun f -> + fun module_name -> + fun cid -> + let uu___ = FStarC_Options.profile_enabled module_name cid in + if uu___ + then + let c = create_or_lookup_counter cid in + let uu___1 = FStarC_Compiler_Effect.op_Bang c.running in + (if uu___1 + then f () + else + (try + (fun uu___3 -> + match () with + | () -> + (FStarC_Compiler_Effect.op_Colon_Equals c.running true; + (let uu___5 = FStarC_Compiler_Util.record_time f in + match uu___5 with + | (res, elapsed) -> + ((let uu___7 = + let uu___8 = + FStarC_Compiler_Effect.op_Bang + c.total_time in + uu___8 + elapsed in + FStarC_Compiler_Effect.op_Colon_Equals + c.total_time uu___7); + FStarC_Compiler_Effect.op_Colon_Equals + c.running false; + res)))) () + with + | uu___3 -> + (FStarC_Compiler_Effect.op_Colon_Equals c.running false; + FStarC_Compiler_Effect.op_Colon_Equals c.undercount true; + FStarC_Compiler_Effect.raise uu___3))) + else f () +let (report_json : Prims.string -> counter -> unit) = + fun tag -> + fun c -> + let counter1 = json_of_counter c in + let uu___ = + FStarC_Json.string_of_json + (FStarC_Json.JsonAssoc + [("tag", (FStarC_Json.JsonStr tag)); ("counter", counter1)]) in + FStarC_Compiler_Util.print1_error "%s\n" uu___ +let (report_human : Prims.string -> counter -> unit) = + fun tag -> + fun c -> + let warn = + let uu___ = FStarC_Compiler_Effect.op_Bang c.running in + if uu___ + then " (Warning, this counter is still running)" + else + (let uu___2 = FStarC_Compiler_Effect.op_Bang c.undercount in + if uu___2 + then + " (Warning, some operations raised exceptions and we not accounted for)" + else "") in + let uu___ = + let uu___1 = FStarC_Compiler_Effect.op_Bang c.total_time in + FStarC_Compiler_Util.string_of_int uu___1 in + FStarC_Compiler_Util.print4 "%s, profiled %s:\t %s ms%s\n" tag + c.cid uu___ warn +let (report : Prims.string -> counter -> unit) = + fun tag -> + fun c -> + let uu___ = FStarC_Options.message_format () in + match uu___ with + | FStarC_Options.Human -> report_human tag c + | FStarC_Options.Json -> report_json tag c +let (report_and_clear : Prims.string -> unit) = + fun tag -> + let ctrs = + FStarC_Compiler_Util.smap_fold all_counters + (fun uu___ -> fun v -> fun l -> v :: l) [] in + FStarC_Compiler_Util.smap_clear all_counters; + (let ctrs1 = + FStarC_Compiler_Util.sort_with + (fun c1 -> + fun c2 -> + let uu___1 = FStarC_Compiler_Effect.op_Bang c2.total_time in + let uu___2 = FStarC_Compiler_Effect.op_Bang c1.total_time in + uu___1 - uu___2) ctrs in + FStarC_Compiler_List.iter (report tag) ctrs1) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Reflection_V1_Builtins.ml b/ocaml/fstar-lib/generated/FStarC_Reflection_V1_Builtins.ml new file mode 100644 index 00000000000..34b99258b53 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Reflection_V1_Builtins.ml @@ -0,0 +1,1550 @@ +open Prims +let (get_env : unit -> FStarC_TypeChecker_Env.env) = + fun uu___ -> + let uu___1 = + FStarC_Compiler_Effect.op_Bang + FStarC_TypeChecker_Normalize.reflection_env_hook in + match uu___1 with + | FStar_Pervasives_Native.None -> + failwith "impossible: env_hook unset in reflection" + | FStar_Pervasives_Native.Some e -> e +let (inspect_bqual : + FStarC_Syntax_Syntax.bqual -> FStarC_Reflection_V1_Data.aqualv) = + fun bq -> + match bq with + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Implicit uu___) -> + FStarC_Reflection_V1_Data.Q_Implicit + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Meta t) -> + FStarC_Reflection_V1_Data.Q_Meta t + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Equality) -> + FStarC_Reflection_V1_Data.Q_Explicit + | FStar_Pervasives_Native.None -> FStarC_Reflection_V1_Data.Q_Explicit +let (inspect_aqual : + FStarC_Syntax_Syntax.aqual -> FStarC_Reflection_V1_Data.aqualv) = + fun aq -> + match aq with + | FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = uu___;_} + -> FStarC_Reflection_V1_Data.Q_Implicit + | uu___ -> FStarC_Reflection_V1_Data.Q_Explicit +let (pack_bqual : + FStarC_Reflection_V1_Data.aqualv -> FStarC_Syntax_Syntax.bqual) = + fun aqv -> + match aqv with + | FStarC_Reflection_V1_Data.Q_Explicit -> FStar_Pervasives_Native.None + | FStarC_Reflection_V1_Data.Q_Implicit -> + FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Implicit false) + | FStarC_Reflection_V1_Data.Q_Meta t -> + FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Meta t) +let (pack_aqual : + FStarC_Reflection_V1_Data.aqualv -> FStarC_Syntax_Syntax.aqual) = + fun aqv -> + match aqv with + | FStarC_Reflection_V1_Data.Q_Implicit -> + FStarC_Syntax_Syntax.as_aqual_implicit true + | uu___ -> FStar_Pervasives_Native.None +let (inspect_fv : FStarC_Syntax_Syntax.fv -> Prims.string Prims.list) = + fun fv -> + let uu___ = FStarC_Syntax_Syntax.lid_of_fv fv in + FStarC_Ident.path_of_lid uu___ +let (pack_fv : Prims.string Prims.list -> FStarC_Syntax_Syntax.fv) = + fun ns -> + let lid = FStarC_Parser_Const.p2l ns in + let fallback uu___ = + let quals = + let uu___1 = FStarC_Ident.lid_equals lid FStarC_Parser_Const.cons_lid in + if uu___1 + then FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.Data_ctor + else + (let uu___3 = + FStarC_Ident.lid_equals lid FStarC_Parser_Const.nil_lid in + if uu___3 + then FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.Data_ctor + else + (let uu___5 = + FStarC_Ident.lid_equals lid FStarC_Parser_Const.some_lid in + if uu___5 + then + FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.Data_ctor + else + (let uu___7 = + FStarC_Ident.lid_equals lid FStarC_Parser_Const.none_lid in + if uu___7 + then + FStar_Pervasives_Native.Some + FStarC_Syntax_Syntax.Data_ctor + else FStar_Pervasives_Native.None))) in + let uu___1 = FStarC_Parser_Const.p2l ns in + FStarC_Syntax_Syntax.lid_as_fv uu___1 quals in + let uu___ = + FStarC_Compiler_Effect.op_Bang + FStarC_TypeChecker_Normalize.reflection_env_hook in + match uu___ with + | FStar_Pervasives_Native.None -> fallback () + | FStar_Pervasives_Native.Some env -> + let qninfo = FStarC_TypeChecker_Env.lookup_qname env lid in + (match qninfo with + | FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr (se, _us), _rng) -> + let quals = FStarC_Syntax_DsEnv.fv_qual_of_se se in + let uu___1 = FStarC_Parser_Const.p2l ns in + FStarC_Syntax_Syntax.lid_as_fv uu___1 quals + | uu___1 -> fallback ()) +let rec last : 'a . 'a Prims.list -> 'a = + fun l -> + match l with + | [] -> failwith "last: empty list" + | x::[] -> x + | uu___::xs -> last xs +let rec init : 'a . 'a Prims.list -> 'a Prims.list = + fun l -> + match l with + | [] -> failwith "init: empty list" + | x::[] -> [] + | x::xs -> let uu___ = init xs in x :: uu___ +let (inspect_const : + FStarC_Syntax_Syntax.sconst -> FStarC_Reflection_V1_Data.vconst) = + fun c -> + match c with + | FStarC_Const.Const_unit -> FStarC_Reflection_V1_Data.C_Unit + | FStarC_Const.Const_int (s, uu___) -> + let uu___1 = FStarC_BigInt.big_int_of_string s in + FStarC_Reflection_V1_Data.C_Int uu___1 + | FStarC_Const.Const_bool (true) -> FStarC_Reflection_V1_Data.C_True + | FStarC_Const.Const_bool (false) -> FStarC_Reflection_V1_Data.C_False + | FStarC_Const.Const_string (s, uu___) -> + FStarC_Reflection_V1_Data.C_String s + | FStarC_Const.Const_range r -> FStarC_Reflection_V1_Data.C_Range r + | FStarC_Const.Const_reify uu___ -> FStarC_Reflection_V1_Data.C_Reify + | FStarC_Const.Const_reflect l -> + let uu___ = FStarC_Ident.path_of_lid l in + FStarC_Reflection_V1_Data.C_Reflect uu___ + | uu___ -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_const c in + FStarC_Compiler_Util.format1 "unknown constant: %s" uu___2 in + failwith uu___1 +let (inspect_universe : + FStarC_Syntax_Syntax.universe -> FStarC_Reflection_V1_Data.universe_view) = + fun u -> + match u with + | FStarC_Syntax_Syntax.U_zero -> FStarC_Reflection_V1_Data.Uv_Zero + | FStarC_Syntax_Syntax.U_succ u1 -> FStarC_Reflection_V1_Data.Uv_Succ u1 + | FStarC_Syntax_Syntax.U_max us -> FStarC_Reflection_V1_Data.Uv_Max us + | FStarC_Syntax_Syntax.U_bvar n -> + let uu___ = FStarC_BigInt.of_int_fs n in + FStarC_Reflection_V1_Data.Uv_BVar uu___ + | FStarC_Syntax_Syntax.U_name i -> + let uu___ = + let uu___1 = FStarC_Ident.string_of_id i in + let uu___2 = FStarC_Ident.range_of_id i in (uu___1, uu___2) in + FStarC_Reflection_V1_Data.Uv_Name uu___ + | FStarC_Syntax_Syntax.U_unif u1 -> FStarC_Reflection_V1_Data.Uv_Unif u1 + | FStarC_Syntax_Syntax.U_unknown -> FStarC_Reflection_V1_Data.Uv_Unk +let (pack_universe : + FStarC_Reflection_V1_Data.universe_view -> FStarC_Syntax_Syntax.universe) = + fun uv -> + match uv with + | FStarC_Reflection_V1_Data.Uv_Zero -> FStarC_Syntax_Syntax.U_zero + | FStarC_Reflection_V1_Data.Uv_Succ u -> FStarC_Syntax_Syntax.U_succ u + | FStarC_Reflection_V1_Data.Uv_Max us -> FStarC_Syntax_Syntax.U_max us + | FStarC_Reflection_V1_Data.Uv_BVar n -> + let uu___ = FStarC_BigInt.to_int_fs n in + FStarC_Syntax_Syntax.U_bvar uu___ + | FStarC_Reflection_V1_Data.Uv_Name i -> + let uu___ = FStarC_Ident.mk_ident i in + FStarC_Syntax_Syntax.U_name uu___ + | FStarC_Reflection_V1_Data.Uv_Unif u -> FStarC_Syntax_Syntax.U_unif u + | FStarC_Reflection_V1_Data.Uv_Unk -> FStarC_Syntax_Syntax.U_unknown +let rec (inspect_ln : + FStarC_Syntax_Syntax.term -> FStarC_Reflection_V1_Data.term_view) = + fun t -> + let t1 = FStarC_Syntax_Subst.compress_subst t in + match t1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t2; FStarC_Syntax_Syntax.meta = uu___;_} + -> inspect_ln t2 + | FStarC_Syntax_Syntax.Tm_name bv -> FStarC_Reflection_V1_Data.Tv_Var bv + | FStarC_Syntax_Syntax.Tm_bvar bv -> FStarC_Reflection_V1_Data.Tv_BVar bv + | FStarC_Syntax_Syntax.Tm_fvar fv -> FStarC_Reflection_V1_Data.Tv_FVar fv + | FStarC_Syntax_Syntax.Tm_uinst (t2, us) -> + (match t2.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + FStarC_Reflection_V1_Data.Tv_UInst (fv, us) + | uu___ -> + failwith "Reflection::inspect_ln: uinst for a non-fvar node") + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t2; + FStarC_Syntax_Syntax.asc = (FStar_Pervasives.Inl ty, tacopt, eq); + FStarC_Syntax_Syntax.eff_opt = uu___;_} + -> FStarC_Reflection_V1_Data.Tv_AscribedT (t2, ty, tacopt, eq) + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t2; + FStarC_Syntax_Syntax.asc = (FStar_Pervasives.Inr cty, tacopt, eq); + FStarC_Syntax_Syntax.eff_opt = uu___;_} + -> FStarC_Reflection_V1_Data.Tv_AscribedC (t2, cty, tacopt, eq) + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = uu___; FStarC_Syntax_Syntax.args = [];_} + -> failwith "inspect_ln: empty arguments on Tm_app" + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = hd; FStarC_Syntax_Syntax.args = args;_} + -> + let uu___ = last args in + (match uu___ with + | (a, q) -> + let q' = inspect_aqual q in + let uu___1 = + let uu___2 = + let uu___3 = init args in + FStarC_Syntax_Util.mk_app hd uu___3 in + (uu___2, (a, q')) in + FStarC_Reflection_V1_Data.Tv_App uu___1) + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = []; FStarC_Syntax_Syntax.body = uu___; + FStarC_Syntax_Syntax.rc_opt = uu___1;_} + -> failwith "inspect_ln: empty arguments on Tm_abs" + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = b::bs; FStarC_Syntax_Syntax.body = t2; + FStarC_Syntax_Syntax.rc_opt = k;_} + -> + let body = + match bs with + | [] -> t2 + | bs1 -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs = bs1; + FStarC_Syntax_Syntax.body = t2; + FStarC_Syntax_Syntax.rc_opt = k + }) t2.FStarC_Syntax_Syntax.pos in + FStarC_Reflection_V1_Data.Tv_Abs (b, body) + | FStarC_Syntax_Syntax.Tm_type u -> FStarC_Reflection_V1_Data.Tv_Type u + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = []; FStarC_Syntax_Syntax.comp = uu___;_} + -> failwith "inspect_ln: empty binders on arrow" + | FStarC_Syntax_Syntax.Tm_arrow uu___ -> + let uu___1 = FStarC_Syntax_Util.arrow_one_ln t1 in + (match uu___1 with + | FStar_Pervasives_Native.Some (b, c) -> + FStarC_Reflection_V1_Data.Tv_Arrow (b, c) + | FStar_Pervasives_Native.None -> failwith "impossible") + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = bv; FStarC_Syntax_Syntax.phi = t2;_} -> + FStarC_Reflection_V1_Data.Tv_Refine + (bv, (bv.FStarC_Syntax_Syntax.sort), t2) + | FStarC_Syntax_Syntax.Tm_constant c -> + let uu___ = inspect_const c in + FStarC_Reflection_V1_Data.Tv_Const uu___ + | FStarC_Syntax_Syntax.Tm_uvar (ctx_u, s) -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Syntax_Unionfind.uvar_unique_id + ctx_u.FStarC_Syntax_Syntax.ctx_uvar_head in + FStarC_BigInt.of_int_fs uu___2 in + (uu___1, (ctx_u, s)) in + FStarC_Reflection_V1_Data.Tv_Uvar uu___ + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (false, lb::[]); + FStarC_Syntax_Syntax.body1 = t2;_} + -> + if lb.FStarC_Syntax_Syntax.lbunivs <> [] + then FStarC_Reflection_V1_Data.Tv_Unsupp + else + (match lb.FStarC_Syntax_Syntax.lbname with + | FStar_Pervasives.Inr uu___1 -> + FStarC_Reflection_V1_Data.Tv_Unsupp + | FStar_Pervasives.Inl bv -> + FStarC_Reflection_V1_Data.Tv_Let + (false, (lb.FStarC_Syntax_Syntax.lbattrs), bv, + (bv.FStarC_Syntax_Syntax.sort), + (lb.FStarC_Syntax_Syntax.lbdef), t2)) + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (true, lb::[]); + FStarC_Syntax_Syntax.body1 = t2;_} + -> + if lb.FStarC_Syntax_Syntax.lbunivs <> [] + then FStarC_Reflection_V1_Data.Tv_Unsupp + else + (match lb.FStarC_Syntax_Syntax.lbname with + | FStar_Pervasives.Inr uu___1 -> + FStarC_Reflection_V1_Data.Tv_Unsupp + | FStar_Pervasives.Inl bv -> + FStarC_Reflection_V1_Data.Tv_Let + (true, (lb.FStarC_Syntax_Syntax.lbattrs), bv, + (bv.FStarC_Syntax_Syntax.sort), + (lb.FStarC_Syntax_Syntax.lbdef), t2)) + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = t2; + FStarC_Syntax_Syntax.ret_opt = ret_opt; + FStarC_Syntax_Syntax.brs = brs; + FStarC_Syntax_Syntax.rc_opt1 = uu___;_} + -> + let rec inspect_pat p = + match p.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_constant c -> + let uu___1 = inspect_const c in + FStarC_Reflection_V1_Data.Pat_Constant uu___1 + | FStarC_Syntax_Syntax.Pat_cons (fv, us_opt, ps) -> + let uu___1 = + let uu___2 = + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with + | (p1, b) -> + let uu___4 = inspect_pat p1 in (uu___4, b)) ps in + (fv, us_opt, uu___2) in + FStarC_Reflection_V1_Data.Pat_Cons uu___1 + | FStarC_Syntax_Syntax.Pat_var bv -> + FStarC_Reflection_V1_Data.Pat_Var + (bv, + (FStarC_Compiler_Sealed.seal bv.FStarC_Syntax_Syntax.sort)) + | FStarC_Syntax_Syntax.Pat_dot_term eopt -> + FStarC_Reflection_V1_Data.Pat_Dot_Term eopt in + let brs1 = + FStarC_Compiler_List.map + (fun uu___1 -> + match uu___1 with + | (pat, uu___2, t3) -> + let uu___3 = inspect_pat pat in (uu___3, t3)) brs in + FStarC_Reflection_V1_Data.Tv_Match (t2, ret_opt, brs1) + | FStarC_Syntax_Syntax.Tm_unknown -> FStarC_Reflection_V1_Data.Tv_Unknown + | FStarC_Syntax_Syntax.Tm_lazy i -> + let uu___ = FStarC_Syntax_Util.unfold_lazy i in inspect_ln uu___ + | uu___ -> + ((let uu___2 = + let uu___3 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t1 in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.format2 + "inspect_ln: outside of expected syntax (%s, %s)" uu___3 uu___4 in + FStarC_Errors.log_issue (FStarC_Syntax_Syntax.has_range_syntax ()) + t1 FStarC_Errors_Codes.Warning_CantInspect () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStarC_Reflection_V1_Data.Tv_Unsupp) +let (inspect_comp : + FStarC_Syntax_Syntax.comp -> FStarC_Reflection_V1_Data.comp_view) = + fun c -> + let get_dec flags = + let uu___ = + FStarC_Compiler_List.tryFind + (fun uu___1 -> + match uu___1 with + | FStarC_Syntax_Syntax.DECREASES uu___2 -> true + | uu___2 -> false) flags in + match uu___ with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.DECREASES + (FStarC_Syntax_Syntax.Decreases_lex ts)) -> ts + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.DECREASES + (FStarC_Syntax_Syntax.Decreases_wf uu___1)) -> + ((let uu___3 = + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_comp c in + FStarC_Compiler_Util.format1 + "inspect_comp: inspecting comp with wf decreases clause is not yet supported: %s skipping the decreases clause" + uu___4 in + FStarC_Errors.log_issue + (FStarC_Syntax_Syntax.has_range_syntax ()) c + FStarC_Errors_Codes.Warning_CantInspect () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___3)); + []) + | uu___1 -> failwith "Impossible!" in + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total t -> FStarC_Reflection_V1_Data.C_Total t + | FStarC_Syntax_Syntax.GTotal t -> FStarC_Reflection_V1_Data.C_GTotal t + | FStarC_Syntax_Syntax.Comp ct -> + let uopt = + if + (FStarC_Compiler_List.length ct.FStarC_Syntax_Syntax.comp_univs) + = Prims.int_zero + then FStarC_Syntax_Syntax.U_unknown + else FStarC_Compiler_List.hd ct.FStarC_Syntax_Syntax.comp_univs in + let uu___ = + FStarC_Ident.lid_equals ct.FStarC_Syntax_Syntax.effect_name + FStarC_Parser_Const.effect_Lemma_lid in + if uu___ + then + (match ct.FStarC_Syntax_Syntax.effect_args with + | (pre, uu___1)::(post, uu___2)::(pats, uu___3)::uu___4 -> + FStarC_Reflection_V1_Data.C_Lemma (pre, post, pats) + | uu___1 -> + failwith "inspect_comp: Lemma does not have enough arguments?") + else + (let inspect_arg uu___2 = + match uu___2 with + | (a, q) -> let uu___3 = inspect_aqual q in (a, uu___3) in + let uu___2 = + let uu___3 = + FStarC_Ident.path_of_lid ct.FStarC_Syntax_Syntax.effect_name in + let uu___4 = + FStarC_Compiler_List.map inspect_arg + ct.FStarC_Syntax_Syntax.effect_args in + let uu___5 = get_dec ct.FStarC_Syntax_Syntax.flags in + ((ct.FStarC_Syntax_Syntax.comp_univs), uu___3, + (ct.FStarC_Syntax_Syntax.result_typ), uu___4, uu___5) in + FStarC_Reflection_V1_Data.C_Eff uu___2) +let (pack_comp : + FStarC_Reflection_V1_Data.comp_view -> FStarC_Syntax_Syntax.comp) = + fun cv -> + let urefl_to_univs u = + if u = FStarC_Syntax_Syntax.U_unknown then [] else [u] in + let urefl_to_univ_opt u = + if u = FStarC_Syntax_Syntax.U_unknown + then FStar_Pervasives_Native.None + else FStar_Pervasives_Native.Some u in + match cv with + | FStarC_Reflection_V1_Data.C_Total t -> FStarC_Syntax_Syntax.mk_Total t + | FStarC_Reflection_V1_Data.C_GTotal t -> + FStarC_Syntax_Syntax.mk_GTotal t + | FStarC_Reflection_V1_Data.C_Lemma (pre, post, pats) -> + let ct = + let uu___ = + let uu___1 = FStarC_Syntax_Syntax.as_arg pre in + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.as_arg post in + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.as_arg pats in [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + { + FStarC_Syntax_Syntax.comp_univs = []; + FStarC_Syntax_Syntax.effect_name = + FStarC_Parser_Const.effect_Lemma_lid; + FStarC_Syntax_Syntax.result_typ = FStarC_Syntax_Syntax.t_unit; + FStarC_Syntax_Syntax.effect_args = uu___; + FStarC_Syntax_Syntax.flags = [] + } in + FStarC_Syntax_Syntax.mk_Comp ct + | FStarC_Reflection_V1_Data.C_Eff (us, ef, res, args, decrs) -> + let pack_arg uu___ = + match uu___ with + | (a, q) -> let uu___1 = pack_aqual q in (a, uu___1) in + let flags = + if (FStarC_Compiler_List.length decrs) = Prims.int_zero + then [] + else + [FStarC_Syntax_Syntax.DECREASES + (FStarC_Syntax_Syntax.Decreases_lex decrs)] in + let ct = + let uu___ = + FStarC_Ident.lid_of_path ef FStarC_Compiler_Range_Type.dummyRange in + let uu___1 = FStarC_Compiler_List.map pack_arg args in + { + FStarC_Syntax_Syntax.comp_univs = us; + FStarC_Syntax_Syntax.effect_name = uu___; + FStarC_Syntax_Syntax.result_typ = res; + FStarC_Syntax_Syntax.effect_args = uu___1; + FStarC_Syntax_Syntax.flags = flags + } in + FStarC_Syntax_Syntax.mk_Comp ct +let (pack_const : + FStarC_Reflection_V1_Data.vconst -> FStarC_Syntax_Syntax.sconst) = + fun c -> + match c with + | FStarC_Reflection_V1_Data.C_Unit -> FStarC_Const.Const_unit + | FStarC_Reflection_V1_Data.C_Int i -> + let uu___ = + let uu___1 = FStarC_BigInt.string_of_big_int i in + (uu___1, FStar_Pervasives_Native.None) in + FStarC_Const.Const_int uu___ + | FStarC_Reflection_V1_Data.C_True -> FStarC_Const.Const_bool true + | FStarC_Reflection_V1_Data.C_False -> FStarC_Const.Const_bool false + | FStarC_Reflection_V1_Data.C_String s -> + FStarC_Const.Const_string (s, FStarC_Compiler_Range_Type.dummyRange) + | FStarC_Reflection_V1_Data.C_Range r -> FStarC_Const.Const_range r + | FStarC_Reflection_V1_Data.C_Reify -> + FStarC_Const.Const_reify FStar_Pervasives_Native.None + | FStarC_Reflection_V1_Data.C_Reflect ns -> + let uu___ = + FStarC_Ident.lid_of_path ns FStarC_Compiler_Range_Type.dummyRange in + FStarC_Const.Const_reflect uu___ +let (pack_ln : + FStarC_Reflection_V1_Data.term_view -> FStarC_Syntax_Syntax.term) = + fun tv -> + match tv with + | FStarC_Reflection_V1_Data.Tv_Var bv -> + FStarC_Syntax_Syntax.bv_to_name bv + | FStarC_Reflection_V1_Data.Tv_BVar bv -> + FStarC_Syntax_Syntax.bv_to_tm bv + | FStarC_Reflection_V1_Data.Tv_FVar fv -> + FStarC_Syntax_Syntax.fv_to_tm fv + | FStarC_Reflection_V1_Data.Tv_UInst (fv, us) -> + let uu___ = FStarC_Syntax_Syntax.fv_to_tm fv in + FStarC_Syntax_Syntax.mk_Tm_uinst uu___ us + | FStarC_Reflection_V1_Data.Tv_App (l, (r, q)) -> + let q' = pack_aqual q in FStarC_Syntax_Util.mk_app l [(r, q')] + | FStarC_Reflection_V1_Data.Tv_Abs (b, t) -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs = [b]; + FStarC_Syntax_Syntax.body = t; + FStarC_Syntax_Syntax.rc_opt = FStar_Pervasives_Native.None + }) t.FStarC_Syntax_Syntax.pos + | FStarC_Reflection_V1_Data.Tv_Arrow (b, c) -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = [b]; FStarC_Syntax_Syntax.comp = c + }) c.FStarC_Syntax_Syntax.pos + | FStarC_Reflection_V1_Data.Tv_Type u -> + FStarC_Syntax_Syntax.mk (FStarC_Syntax_Syntax.Tm_type u) + FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V1_Data.Tv_Refine (bv, sort, t) -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_refine + { + FStarC_Syntax_Syntax.b = + { + FStarC_Syntax_Syntax.ppname = + (bv.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (bv.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = sort + }; + FStarC_Syntax_Syntax.phi = t + }) t.FStarC_Syntax_Syntax.pos + | FStarC_Reflection_V1_Data.Tv_Const c -> + let uu___ = + let uu___1 = pack_const c in + FStarC_Syntax_Syntax.Tm_constant uu___1 in + FStarC_Syntax_Syntax.mk uu___ FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V1_Data.Tv_Uvar (u, ctx_u_s) -> + FStarC_Syntax_Syntax.mk (FStarC_Syntax_Syntax.Tm_uvar ctx_u_s) + FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V1_Data.Tv_Let (false, attrs, bv, ty, t1, t2) -> + let bv1 = + { + FStarC_Syntax_Syntax.ppname = (bv.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = (bv.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = ty + } in + let lb = + FStarC_Syntax_Util.mk_letbinding (FStar_Pervasives.Inl bv1) [] + bv1.FStarC_Syntax_Syntax.sort FStarC_Parser_Const.effect_Tot_lid + t1 attrs FStarC_Compiler_Range_Type.dummyRange in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = (false, [lb]); + FStarC_Syntax_Syntax.body1 = t2 + }) FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V1_Data.Tv_Let (true, attrs, bv, ty, t1, t2) -> + let bv1 = + { + FStarC_Syntax_Syntax.ppname = (bv.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = (bv.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = ty + } in + let lb = + FStarC_Syntax_Util.mk_letbinding (FStar_Pervasives.Inl bv1) [] + bv1.FStarC_Syntax_Syntax.sort FStarC_Parser_Const.effect_Tot_lid + t1 attrs FStarC_Compiler_Range_Type.dummyRange in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = (true, [lb]); + FStarC_Syntax_Syntax.body1 = t2 + }) FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V1_Data.Tv_Match (t, ret_opt, brs) -> + let wrap v = + { + FStarC_Syntax_Syntax.v = v; + FStarC_Syntax_Syntax.p = FStarC_Compiler_Range_Type.dummyRange + } in + let rec pack_pat p = + match p with + | FStarC_Reflection_V1_Data.Pat_Constant c -> + let uu___ = + let uu___1 = pack_const c in + FStarC_Syntax_Syntax.Pat_constant uu___1 in + wrap uu___ + | FStarC_Reflection_V1_Data.Pat_Cons (fv, us_opt, ps) -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with + | (p1, b) -> let uu___4 = pack_pat p1 in (uu___4, b)) + ps in + (fv, us_opt, uu___2) in + FStarC_Syntax_Syntax.Pat_cons uu___1 in + wrap uu___ + | FStarC_Reflection_V1_Data.Pat_Var (bv, _sort) -> + wrap (FStarC_Syntax_Syntax.Pat_var bv) + | FStarC_Reflection_V1_Data.Pat_Dot_Term eopt -> + wrap (FStarC_Syntax_Syntax.Pat_dot_term eopt) in + let brs1 = + FStarC_Compiler_List.map + (fun uu___ -> + match uu___ with + | (pat, t1) -> + let uu___1 = pack_pat pat in + (uu___1, FStar_Pervasives_Native.None, t1)) brs in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_match + { + FStarC_Syntax_Syntax.scrutinee = t; + FStarC_Syntax_Syntax.ret_opt = ret_opt; + FStarC_Syntax_Syntax.brs = brs1; + FStarC_Syntax_Syntax.rc_opt1 = FStar_Pervasives_Native.None + }) FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V1_Data.Tv_AscribedT (e, t, tacopt, use_eq) -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_ascribed + { + FStarC_Syntax_Syntax.tm = e; + FStarC_Syntax_Syntax.asc = + ((FStar_Pervasives.Inl t), tacopt, use_eq); + FStarC_Syntax_Syntax.eff_opt = FStar_Pervasives_Native.None + }) FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V1_Data.Tv_AscribedC (e, c, tacopt, use_eq) -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_ascribed + { + FStarC_Syntax_Syntax.tm = e; + FStarC_Syntax_Syntax.asc = + ((FStar_Pervasives.Inr c), tacopt, use_eq); + FStarC_Syntax_Syntax.eff_opt = FStar_Pervasives_Native.None + }) FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V1_Data.Tv_Unknown -> + FStarC_Syntax_Syntax.mk FStarC_Syntax_Syntax.Tm_unknown + FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V1_Data.Tv_Unsupp -> + (FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_CantInspect () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "packing a Tv_Unsupp into Tm_unknown"); + FStarC_Syntax_Syntax.mk FStarC_Syntax_Syntax.Tm_unknown + FStarC_Compiler_Range_Type.dummyRange) +let (compare_bv : + FStarC_Syntax_Syntax.bv -> FStarC_Syntax_Syntax.bv -> FStar_Order.order) = + fun x -> + fun y -> + let n = FStarC_Syntax_Syntax.order_bv x y in + if n < Prims.int_zero + then FStar_Order.Lt + else if n = Prims.int_zero then FStar_Order.Eq else FStar_Order.Gt +let (lookup_attr : + FStarC_Syntax_Syntax.term -> + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.fv Prims.list) + = + fun attr -> + fun env -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress_subst attr in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let ses = + let uu___1 = + let uu___2 = FStarC_Syntax_Syntax.lid_of_fv fv in + FStarC_Ident.string_of_lid uu___2 in + FStarC_TypeChecker_Env.lookup_attr env uu___1 in + FStarC_Compiler_List.concatMap + (fun se -> + let uu___1 = FStarC_Syntax_Util.lid_of_sigelt se in + match uu___1 with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some l -> + let uu___2 = + FStarC_Syntax_Syntax.lid_as_fv l + FStar_Pervasives_Native.None in + [uu___2]) ses + | uu___1 -> [] +let (all_defs_in_env : + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.fv Prims.list) = + fun env -> + let uu___ = FStarC_TypeChecker_Env.lidents env in + FStarC_Compiler_List.map + (fun l -> FStarC_Syntax_Syntax.lid_as_fv l FStar_Pervasives_Native.None) + uu___ +let (defs_in_module : + FStarC_TypeChecker_Env.env -> + FStarC_Reflection_V1_Data.name -> FStarC_Syntax_Syntax.fv Prims.list) + = + fun env -> + fun modul -> + let uu___ = FStarC_TypeChecker_Env.lidents env in + FStarC_Compiler_List.concatMap + (fun l -> + let ns = + let uu___1 = + let uu___2 = FStarC_Ident.ids_of_lid l in init uu___2 in + FStarC_Compiler_List.map FStarC_Ident.string_of_id uu___1 in + if ns = modul + then + let uu___1 = + FStarC_Syntax_Syntax.lid_as_fv l FStar_Pervasives_Native.None in + [uu___1] + else []) uu___ +let (lookup_typ : + FStarC_TypeChecker_Env.env -> + Prims.string Prims.list -> + FStarC_Syntax_Syntax.sigelt FStar_Pervasives_Native.option) + = + fun env -> + fun ns -> + let lid = FStarC_Parser_Const.p2l ns in + FStarC_TypeChecker_Env.lookup_sigelt env lid +let (sigelt_attrs : + FStarC_Syntax_Syntax.sigelt -> FStarC_Syntax_Syntax.attribute Prims.list) = + fun se -> se.FStarC_Syntax_Syntax.sigattrs +let (set_sigelt_attrs : + FStarC_Syntax_Syntax.attribute Prims.list -> + FStarC_Syntax_Syntax.sigelt -> FStarC_Syntax_Syntax.sigelt) + = + fun attrs -> + fun se -> + { + FStarC_Syntax_Syntax.sigel = (se.FStarC_Syntax_Syntax.sigel); + FStarC_Syntax_Syntax.sigrng = (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = (se.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = attrs; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = (se.FStarC_Syntax_Syntax.sigopts) + } +let (inspect_ident : FStarC_Ident.ident -> FStarC_Reflection_V1_Data.ident) = + fun i -> FStarC_Reflection_V2_Builtins.inspect_ident i +let (pack_ident : FStarC_Reflection_V1_Data.ident -> FStarC_Ident.ident) = + fun i -> FStarC_Reflection_V2_Builtins.pack_ident i +let (rd_to_syntax_qual : + FStarC_Reflection_V1_Data.qualifier -> FStarC_Syntax_Syntax.qualifier) = + fun uu___ -> + match uu___ with + | FStarC_Reflection_V1_Data.Assumption -> FStarC_Syntax_Syntax.Assumption + | FStarC_Reflection_V1_Data.New -> FStarC_Syntax_Syntax.New + | FStarC_Reflection_V1_Data.Private -> FStarC_Syntax_Syntax.Private + | FStarC_Reflection_V1_Data.Unfold_for_unification_and_vcgen -> + FStarC_Syntax_Syntax.Unfold_for_unification_and_vcgen + | FStarC_Reflection_V1_Data.Visible_default -> + FStarC_Syntax_Syntax.Visible_default + | FStarC_Reflection_V1_Data.Irreducible -> + FStarC_Syntax_Syntax.Irreducible + | FStarC_Reflection_V1_Data.Inline_for_extraction -> + FStarC_Syntax_Syntax.Inline_for_extraction + | FStarC_Reflection_V1_Data.NoExtract -> FStarC_Syntax_Syntax.NoExtract + | FStarC_Reflection_V1_Data.Noeq -> FStarC_Syntax_Syntax.Noeq + | FStarC_Reflection_V1_Data.Unopteq -> FStarC_Syntax_Syntax.Unopteq + | FStarC_Reflection_V1_Data.TotalEffect -> + FStarC_Syntax_Syntax.TotalEffect + | FStarC_Reflection_V1_Data.Logic -> FStarC_Syntax_Syntax.Logic + | FStarC_Reflection_V1_Data.Reifiable -> FStarC_Syntax_Syntax.Reifiable + | FStarC_Reflection_V1_Data.Reflectable l -> + let uu___1 = + FStarC_Ident.lid_of_path l FStarC_Compiler_Range_Type.dummyRange in + FStarC_Syntax_Syntax.Reflectable uu___1 + | FStarC_Reflection_V1_Data.Discriminator l -> + let uu___1 = + FStarC_Ident.lid_of_path l FStarC_Compiler_Range_Type.dummyRange in + FStarC_Syntax_Syntax.Discriminator uu___1 + | FStarC_Reflection_V1_Data.Projector (l, i) -> + let uu___1 = + let uu___2 = + FStarC_Ident.lid_of_path l FStarC_Compiler_Range_Type.dummyRange in + let uu___3 = pack_ident i in (uu___2, uu___3) in + FStarC_Syntax_Syntax.Projector uu___1 + | FStarC_Reflection_V1_Data.RecordType (l1, l2) -> + let uu___1 = + let uu___2 = FStarC_Compiler_List.map pack_ident l1 in + let uu___3 = FStarC_Compiler_List.map pack_ident l2 in + (uu___2, uu___3) in + FStarC_Syntax_Syntax.RecordType uu___1 + | FStarC_Reflection_V1_Data.RecordConstructor (l1, l2) -> + let uu___1 = + let uu___2 = FStarC_Compiler_List.map pack_ident l1 in + let uu___3 = FStarC_Compiler_List.map pack_ident l2 in + (uu___2, uu___3) in + FStarC_Syntax_Syntax.RecordConstructor uu___1 + | FStarC_Reflection_V1_Data.Action l -> + let uu___1 = + FStarC_Ident.lid_of_path l FStarC_Compiler_Range_Type.dummyRange in + FStarC_Syntax_Syntax.Action uu___1 + | FStarC_Reflection_V1_Data.ExceptionConstructor -> + FStarC_Syntax_Syntax.ExceptionConstructor + | FStarC_Reflection_V1_Data.HasMaskedEffect -> + FStarC_Syntax_Syntax.HasMaskedEffect + | FStarC_Reflection_V1_Data.Effect -> FStarC_Syntax_Syntax.Effect + | FStarC_Reflection_V1_Data.OnlyName -> FStarC_Syntax_Syntax.OnlyName +let (syntax_to_rd_qual : + FStarC_Syntax_Syntax.qualifier -> FStarC_Reflection_V1_Data.qualifier) = + fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.Assumption -> FStarC_Reflection_V1_Data.Assumption + | FStarC_Syntax_Syntax.New -> FStarC_Reflection_V1_Data.New + | FStarC_Syntax_Syntax.Private -> FStarC_Reflection_V1_Data.Private + | FStarC_Syntax_Syntax.Unfold_for_unification_and_vcgen -> + FStarC_Reflection_V1_Data.Unfold_for_unification_and_vcgen + | FStarC_Syntax_Syntax.Visible_default -> + FStarC_Reflection_V1_Data.Visible_default + | FStarC_Syntax_Syntax.Irreducible -> + FStarC_Reflection_V1_Data.Irreducible + | FStarC_Syntax_Syntax.Inline_for_extraction -> + FStarC_Reflection_V1_Data.Inline_for_extraction + | FStarC_Syntax_Syntax.NoExtract -> FStarC_Reflection_V1_Data.NoExtract + | FStarC_Syntax_Syntax.Noeq -> FStarC_Reflection_V1_Data.Noeq + | FStarC_Syntax_Syntax.Unopteq -> FStarC_Reflection_V1_Data.Unopteq + | FStarC_Syntax_Syntax.TotalEffect -> + FStarC_Reflection_V1_Data.TotalEffect + | FStarC_Syntax_Syntax.Logic -> FStarC_Reflection_V1_Data.Logic + | FStarC_Syntax_Syntax.Reifiable -> FStarC_Reflection_V1_Data.Reifiable + | FStarC_Syntax_Syntax.Reflectable l -> + let uu___1 = FStarC_Ident.path_of_lid l in + FStarC_Reflection_V1_Data.Reflectable uu___1 + | FStarC_Syntax_Syntax.Discriminator l -> + let uu___1 = FStarC_Ident.path_of_lid l in + FStarC_Reflection_V1_Data.Discriminator uu___1 + | FStarC_Syntax_Syntax.Projector (l, i) -> + let uu___1 = + let uu___2 = FStarC_Ident.path_of_lid l in + let uu___3 = inspect_ident i in (uu___2, uu___3) in + FStarC_Reflection_V1_Data.Projector uu___1 + | FStarC_Syntax_Syntax.RecordType (l1, l2) -> + let uu___1 = + let uu___2 = FStarC_Compiler_List.map inspect_ident l1 in + let uu___3 = FStarC_Compiler_List.map inspect_ident l2 in + (uu___2, uu___3) in + FStarC_Reflection_V1_Data.RecordType uu___1 + | FStarC_Syntax_Syntax.RecordConstructor (l1, l2) -> + let uu___1 = + let uu___2 = FStarC_Compiler_List.map inspect_ident l1 in + let uu___3 = FStarC_Compiler_List.map inspect_ident l2 in + (uu___2, uu___3) in + FStarC_Reflection_V1_Data.RecordConstructor uu___1 + | FStarC_Syntax_Syntax.Action l -> + let uu___1 = FStarC_Ident.path_of_lid l in + FStarC_Reflection_V1_Data.Action uu___1 + | FStarC_Syntax_Syntax.ExceptionConstructor -> + FStarC_Reflection_V1_Data.ExceptionConstructor + | FStarC_Syntax_Syntax.HasMaskedEffect -> + FStarC_Reflection_V1_Data.HasMaskedEffect + | FStarC_Syntax_Syntax.Effect -> FStarC_Reflection_V1_Data.Effect + | FStarC_Syntax_Syntax.OnlyName -> FStarC_Reflection_V1_Data.OnlyName +let (sigelt_quals : + FStarC_Syntax_Syntax.sigelt -> + FStarC_Reflection_V1_Data.qualifier Prims.list) + = + fun se -> + FStarC_Compiler_List.map syntax_to_rd_qual + se.FStarC_Syntax_Syntax.sigquals +let (set_sigelt_quals : + FStarC_Reflection_V1_Data.qualifier Prims.list -> + FStarC_Syntax_Syntax.sigelt -> FStarC_Syntax_Syntax.sigelt) + = + fun quals -> + fun se -> + let uu___ = FStarC_Compiler_List.map rd_to_syntax_qual quals in + { + FStarC_Syntax_Syntax.sigel = (se.FStarC_Syntax_Syntax.sigel); + FStarC_Syntax_Syntax.sigrng = (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = uu___; + FStarC_Syntax_Syntax.sigmeta = (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = (se.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = (se.FStarC_Syntax_Syntax.sigopts) + } +let (sigelt_opts : + FStarC_Syntax_Syntax.sigelt -> + FStarC_VConfig.vconfig FStar_Pervasives_Native.option) + = fun se -> se.FStarC_Syntax_Syntax.sigopts +let (embed_vconfig : FStarC_VConfig.vconfig -> FStarC_Syntax_Syntax.term) = + fun vcfg -> + let uu___ = + FStarC_Syntax_Embeddings_Base.embed FStarC_Syntax_Embeddings.e_vconfig + vcfg in + uu___ FStarC_Compiler_Range_Type.dummyRange FStar_Pervasives_Native.None + FStarC_Syntax_Embeddings_Base.id_norm_cb +let (inspect_sigelt : + FStarC_Syntax_Syntax.sigelt -> FStarC_Reflection_V1_Data.sigelt_view) = + fun se -> + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (r, lbs); + FStarC_Syntax_Syntax.lids1 = uu___;_} + -> + let inspect_letbinding lb = + let uu___1 = lb in + match uu___1 with + | { FStarC_Syntax_Syntax.lbname = nm; + FStarC_Syntax_Syntax.lbunivs = us; + FStarC_Syntax_Syntax.lbtyp = typ; + FStarC_Syntax_Syntax.lbeff = eff; + FStarC_Syntax_Syntax.lbdef = def; + FStarC_Syntax_Syntax.lbattrs = attrs; + FStarC_Syntax_Syntax.lbpos = pos;_} -> + let uu___2 = FStarC_Syntax_Subst.univ_var_opening us in + (match uu___2 with + | (s, us1) -> + let typ1 = FStarC_Syntax_Subst.subst s typ in + let def1 = FStarC_Syntax_Subst.subst s def in + FStarC_Syntax_Util.mk_letbinding nm us1 typ1 eff def1 + attrs pos) in + let uu___1 = + let uu___2 = FStarC_Compiler_List.map inspect_letbinding lbs in + (r, uu___2) in + FStarC_Reflection_V1_Data.Sg_Let uu___1 + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = lid; FStarC_Syntax_Syntax.us = us; + FStarC_Syntax_Syntax.params = param_bs; + FStarC_Syntax_Syntax.num_uniform_params = uu___; + FStarC_Syntax_Syntax.t = ty; FStarC_Syntax_Syntax.mutuals = uu___1; + FStarC_Syntax_Syntax.ds = c_lids; + FStarC_Syntax_Syntax.injective_type_params = uu___2;_} + -> + let nm = FStarC_Ident.path_of_lid lid in + let uu___3 = FStarC_Syntax_Subst.univ_var_opening us in + (match uu___3 with + | (s, us1) -> + let param_bs1 = FStarC_Syntax_Subst.subst_binders s param_bs in + let ty1 = FStarC_Syntax_Subst.subst s ty in + let uu___4 = FStarC_Syntax_Subst.open_term param_bs1 ty1 in + (match uu___4 with + | (param_bs2, ty2) -> + let inspect_ctor c_lid = + let uu___5 = + let uu___6 = get_env () in + FStarC_TypeChecker_Env.lookup_sigelt uu___6 c_lid in + match uu___5 with + | FStar_Pervasives_Native.Some + { + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = lid1; + FStarC_Syntax_Syntax.us1 = us2; + FStarC_Syntax_Syntax.t1 = cty; + FStarC_Syntax_Syntax.ty_lid = uu___6; + FStarC_Syntax_Syntax.num_ty_params = nparam; + FStarC_Syntax_Syntax.mutuals1 = uu___7; + FStarC_Syntax_Syntax.injective_type_params1 = + uu___8;_}; + FStarC_Syntax_Syntax.sigrng = uu___9; + FStarC_Syntax_Syntax.sigquals = uu___10; + FStarC_Syntax_Syntax.sigmeta = uu___11; + FStarC_Syntax_Syntax.sigattrs = uu___12; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___13; + FStarC_Syntax_Syntax.sigopts = uu___14;_} + -> + let cty1 = FStarC_Syntax_Subst.subst s cty in + let uu___15 = + let uu___16 = get_env () in + FStarC_TypeChecker_Normalize.get_n_binders uu___16 + nparam cty1 in + (match uu___15 with + | (param_ctor_bs, c) -> + (if + (FStarC_Compiler_List.length param_ctor_bs) + <> nparam + then + failwith + "impossible: inspect_sigelt: could not obtain sufficient ctor param binders" + else (); + (let uu___18 = + let uu___19 = + FStarC_Syntax_Util.is_total_comp c in + Prims.op_Negation uu___19 in + if uu___18 + then + failwith + "impossible: inspect_sigelt: removed parameters and got an effectful comp" + else ()); + (let cty2 = FStarC_Syntax_Util.comp_result c in + let s' = + FStarC_Compiler_List.map2 + (fun b1 -> + fun b2 -> + let uu___18 = + let uu___19 = + FStarC_Syntax_Syntax.bv_to_name + b2.FStarC_Syntax_Syntax.binder_bv in + ((b1.FStarC_Syntax_Syntax.binder_bv), + uu___19) in + FStarC_Syntax_Syntax.NT uu___18) + param_ctor_bs param_bs2 in + let cty3 = FStarC_Syntax_Subst.subst s' cty2 in + let cty4 = + FStarC_Syntax_Util.remove_inacc cty3 in + let uu___18 = FStarC_Ident.path_of_lid lid1 in + (uu___18, cty4)))) + | uu___6 -> + failwith + "impossible: inspect_sigelt: did not find ctor" in + let uu___5 = + let uu___6 = FStarC_Compiler_List.map inspect_ident us1 in + let uu___7 = FStarC_Compiler_List.map inspect_ctor c_lids in + (nm, uu___6, param_bs2, ty2, uu___7) in + FStarC_Reflection_V1_Data.Sg_Inductive uu___5)) + | FStarC_Syntax_Syntax.Sig_declare_typ + { FStarC_Syntax_Syntax.lid2 = lid; FStarC_Syntax_Syntax.us2 = us; + FStarC_Syntax_Syntax.t2 = ty;_} + -> + let nm = FStarC_Ident.path_of_lid lid in + let uu___ = FStarC_Syntax_Subst.open_univ_vars us ty in + (match uu___ with + | (us1, ty1) -> + let uu___1 = + let uu___2 = FStarC_Compiler_List.map inspect_ident us1 in + (nm, uu___2, ty1) in + FStarC_Reflection_V1_Data.Sg_Val uu___1) + | uu___ -> FStarC_Reflection_V1_Data.Unk +let (pack_sigelt : + FStarC_Reflection_V1_Data.sigelt_view -> FStarC_Syntax_Syntax.sigelt) = + fun sv -> + let check_lid lid = + let uu___ = + let uu___1 = + let uu___2 = FStarC_Ident.path_of_lid lid in + FStarC_Compiler_List.length uu___2 in + uu___1 <= Prims.int_one in + if uu___ + then + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Ident.string_of_lid lid in + Prims.strcat uu___3 "\" (did you forget a module path?)" in + Prims.strcat "pack_sigelt: invalid long identifier \"" uu___2 in + failwith uu___1 + else () in + match sv with + | FStarC_Reflection_V1_Data.Sg_Let (r, lbs) -> + let pack_letbinding lb = + let uu___ = lb in + match uu___ with + | { FStarC_Syntax_Syntax.lbname = nm; + FStarC_Syntax_Syntax.lbunivs = us; + FStarC_Syntax_Syntax.lbtyp = typ; + FStarC_Syntax_Syntax.lbeff = eff; + FStarC_Syntax_Syntax.lbdef = def; + FStarC_Syntax_Syntax.lbattrs = attrs; + FStarC_Syntax_Syntax.lbpos = pos;_} -> + let lid = + match nm with + | FStar_Pervasives.Inr fv -> + FStarC_Syntax_Syntax.lid_of_fv fv + | uu___1 -> + failwith + "impossible: pack_sigelt: bv in toplevel let binding" in + (check_lid lid; + (let s = FStarC_Syntax_Subst.univ_var_closing us in + let typ1 = FStarC_Syntax_Subst.subst s typ in + let def1 = FStarC_Syntax_Subst.subst s def in + let lb1 = + FStarC_Syntax_Util.mk_letbinding nm us typ1 eff def1 attrs + pos in + (lid, lb1))) in + let packed = FStarC_Compiler_List.map pack_letbinding lbs in + let lbs1 = + FStarC_Compiler_List.map FStar_Pervasives_Native.snd packed in + let lids = + FStarC_Compiler_List.map FStar_Pervasives_Native.fst packed in + FStarC_Syntax_Syntax.mk_sigelt + (FStarC_Syntax_Syntax.Sig_let + { + FStarC_Syntax_Syntax.lbs1 = (r, lbs1); + FStarC_Syntax_Syntax.lids1 = lids + }) + | FStarC_Reflection_V1_Data.Sg_Inductive + (nm, us_names, param_bs, ty, ctors) -> + let us_names1 = FStarC_Compiler_List.map pack_ident us_names in + let ind_lid = + FStarC_Ident.lid_of_path nm FStarC_Compiler_Range_Type.dummyRange in + (check_lid ind_lid; + (let s = FStarC_Syntax_Subst.univ_var_closing us_names1 in + let nparam = FStarC_Compiler_List.length param_bs in + let injective_type_params = false in + let pack_ctor c = + let uu___1 = c in + match uu___1 with + | (nm1, ty1) -> + let lid = + FStarC_Ident.lid_of_path nm1 + FStarC_Compiler_Range_Type.dummyRange in + let ty2 = + let uu___2 = FStarC_Syntax_Syntax.mk_Total ty1 in + FStarC_Syntax_Util.arrow param_bs uu___2 in + let ty3 = FStarC_Syntax_Subst.subst s ty2 in + FStarC_Syntax_Syntax.mk_sigelt + (FStarC_Syntax_Syntax.Sig_datacon + { + FStarC_Syntax_Syntax.lid1 = lid; + FStarC_Syntax_Syntax.us1 = us_names1; + FStarC_Syntax_Syntax.t1 = ty3; + FStarC_Syntax_Syntax.ty_lid = ind_lid; + FStarC_Syntax_Syntax.num_ty_params = nparam; + FStarC_Syntax_Syntax.mutuals1 = []; + FStarC_Syntax_Syntax.injective_type_params1 = + injective_type_params + }) in + let ctor_ses = FStarC_Compiler_List.map pack_ctor ctors in + let c_lids = + FStarC_Compiler_List.map + (fun se -> + let uu___1 = FStarC_Syntax_Util.lid_of_sigelt se in + FStarC_Compiler_Util.must uu___1) ctor_ses in + let ind_se = + let param_bs1 = FStarC_Syntax_Subst.close_binders param_bs in + let ty1 = FStarC_Syntax_Subst.close param_bs1 ty in + let param_bs2 = FStarC_Syntax_Subst.subst_binders s param_bs1 in + let ty2 = FStarC_Syntax_Subst.subst s ty1 in + FStarC_Syntax_Syntax.mk_sigelt + (FStarC_Syntax_Syntax.Sig_inductive_typ + { + FStarC_Syntax_Syntax.lid = ind_lid; + FStarC_Syntax_Syntax.us = us_names1; + FStarC_Syntax_Syntax.params = param_bs2; + FStarC_Syntax_Syntax.num_uniform_params = + FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.t = ty2; + FStarC_Syntax_Syntax.mutuals = []; + FStarC_Syntax_Syntax.ds = c_lids; + FStarC_Syntax_Syntax.injective_type_params = + injective_type_params + }) in + let se = + FStarC_Syntax_Syntax.mk_sigelt + (FStarC_Syntax_Syntax.Sig_bundle + { + FStarC_Syntax_Syntax.ses = (ind_se :: ctor_ses); + FStarC_Syntax_Syntax.lids = (ind_lid :: c_lids) + }) in + { + FStarC_Syntax_Syntax.sigel = (se.FStarC_Syntax_Syntax.sigel); + FStarC_Syntax_Syntax.sigrng = (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = (FStarC_Syntax_Syntax.Noeq :: + (se.FStarC_Syntax_Syntax.sigquals)); + FStarC_Syntax_Syntax.sigmeta = (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = (se.FStarC_Syntax_Syntax.sigopts) + })) + | FStarC_Reflection_V1_Data.Sg_Val (nm, us_names, ty) -> + let us_names1 = FStarC_Compiler_List.map pack_ident us_names in + let val_lid = + FStarC_Ident.lid_of_path nm FStarC_Compiler_Range_Type.dummyRange in + (check_lid val_lid; + (let typ = FStarC_Syntax_Subst.close_univ_vars us_names1 ty in + FStarC_Syntax_Syntax.mk_sigelt + (FStarC_Syntax_Syntax.Sig_declare_typ + { + FStarC_Syntax_Syntax.lid2 = val_lid; + FStarC_Syntax_Syntax.us2 = us_names1; + FStarC_Syntax_Syntax.t2 = typ + }))) + | FStarC_Reflection_V1_Data.Unk -> failwith "packing Unk, sorry" +let (inspect_lb : + FStarC_Syntax_Syntax.letbinding -> FStarC_Reflection_V1_Data.lb_view) = + fun lb -> + let uu___ = lb in + match uu___ with + | { FStarC_Syntax_Syntax.lbname = nm; FStarC_Syntax_Syntax.lbunivs = us; + FStarC_Syntax_Syntax.lbtyp = typ; FStarC_Syntax_Syntax.lbeff = eff; + FStarC_Syntax_Syntax.lbdef = def; + FStarC_Syntax_Syntax.lbattrs = attrs; + FStarC_Syntax_Syntax.lbpos = pos;_} -> + let uu___1 = FStarC_Syntax_Subst.univ_var_opening us in + (match uu___1 with + | (s, us1) -> + let typ1 = FStarC_Syntax_Subst.subst s typ in + let def1 = FStarC_Syntax_Subst.subst s def in + let us2 = FStarC_Compiler_List.map inspect_ident us1 in + (match nm with + | FStar_Pervasives.Inr fv -> + { + FStarC_Reflection_V1_Data.lb_fv = fv; + FStarC_Reflection_V1_Data.lb_us = us2; + FStarC_Reflection_V1_Data.lb_typ = typ1; + FStarC_Reflection_V1_Data.lb_def = def1 + } + | uu___2 -> failwith "Impossible: bv in top-level let binding")) +let (pack_lb : + FStarC_Reflection_V1_Data.lb_view -> FStarC_Syntax_Syntax.letbinding) = + fun lbv -> + let uu___ = lbv in + match uu___ with + | { FStarC_Reflection_V1_Data.lb_fv = fv; + FStarC_Reflection_V1_Data.lb_us = us; + FStarC_Reflection_V1_Data.lb_typ = typ; + FStarC_Reflection_V1_Data.lb_def = def;_} -> + let us1 = FStarC_Compiler_List.map pack_ident us in + let s = FStarC_Syntax_Subst.univ_var_closing us1 in + let typ1 = FStarC_Syntax_Subst.subst s typ in + let def1 = FStarC_Syntax_Subst.subst s def in + FStarC_Syntax_Util.mk_letbinding (FStar_Pervasives.Inr fv) us1 typ1 + FStarC_Parser_Const.effect_Tot_lid def1 [] + FStarC_Compiler_Range_Type.dummyRange +let (inspect_bv : + FStarC_Syntax_Syntax.bv -> FStarC_Reflection_V1_Data.bv_view) = + fun bv -> + if bv.FStarC_Syntax_Syntax.index < Prims.int_zero + then + (let uu___1 = + let uu___2 = + FStarC_Ident.string_of_id bv.FStarC_Syntax_Syntax.ppname in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + bv.FStarC_Syntax_Syntax.sort in + let uu___4 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + bv.FStarC_Syntax_Syntax.index in + FStarC_Compiler_Util.format3 + "inspect_bv: index is negative (%s : %s), index = %s" uu___2 + uu___3 uu___4 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_CantInspect () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1)) + else (); + (let uu___1 = + let uu___2 = FStarC_Ident.string_of_id bv.FStarC_Syntax_Syntax.ppname in + FStarC_Compiler_Sealed.seal uu___2 in + let uu___2 = FStarC_BigInt.of_int_fs bv.FStarC_Syntax_Syntax.index in + { + FStarC_Reflection_V1_Data.bv_ppname = uu___1; + FStarC_Reflection_V1_Data.bv_index = uu___2 + }) +let (pack_bv : FStarC_Reflection_V1_Data.bv_view -> FStarC_Syntax_Syntax.bv) + = + fun bvv -> + (let uu___1 = + let uu___2 = + FStarC_BigInt.to_int_fs bvv.FStarC_Reflection_V1_Data.bv_index in + uu___2 < Prims.int_zero in + if uu___1 + then + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_BigInt.to_int_fs bvv.FStarC_Reflection_V1_Data.bv_index in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) uu___4 in + FStarC_Compiler_Util.format2 + "pack_bv: index is negative (%s), index = %s" + (FStarC_Compiler_Sealed.unseal + bvv.FStarC_Reflection_V1_Data.bv_ppname) uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_CantInspect () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2) + else ()); + (let uu___1 = + FStarC_Ident.mk_ident + ((FStarC_Compiler_Sealed.unseal + bvv.FStarC_Reflection_V1_Data.bv_ppname), + FStarC_Compiler_Range_Type.dummyRange) in + let uu___2 = + FStarC_BigInt.to_int_fs bvv.FStarC_Reflection_V1_Data.bv_index in + { + FStarC_Syntax_Syntax.ppname = uu___1; + FStarC_Syntax_Syntax.index = uu___2; + FStarC_Syntax_Syntax.sort = FStarC_Syntax_Syntax.tun + }) +let (inspect_binder : + FStarC_Syntax_Syntax.binder -> FStarC_Reflection_V1_Data.binder_view) = + fun b -> + let attrs = + FStarC_Syntax_Util.encode_positivity_attributes + b.FStarC_Syntax_Syntax.binder_positivity + b.FStarC_Syntax_Syntax.binder_attrs in + let uu___ = inspect_bqual b.FStarC_Syntax_Syntax.binder_qual in + { + FStarC_Reflection_V1_Data.binder_bv = + (b.FStarC_Syntax_Syntax.binder_bv); + FStarC_Reflection_V1_Data.binder_qual = uu___; + FStarC_Reflection_V1_Data.binder_attrs = attrs; + FStarC_Reflection_V1_Data.binder_sort = + ((b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort) + } +let (pack_binder : + FStarC_Reflection_V1_Data.binder_view -> FStarC_Syntax_Syntax.binder) = + fun bview -> + let uu___ = + FStarC_Syntax_Util.parse_positivity_attributes + bview.FStarC_Reflection_V1_Data.binder_attrs in + match uu___ with + | (pqual, attrs) -> + let uu___1 = pack_bqual bview.FStarC_Reflection_V1_Data.binder_qual in + { + FStarC_Syntax_Syntax.binder_bv = + (let uu___2 = bview.FStarC_Reflection_V1_Data.binder_bv in + { + FStarC_Syntax_Syntax.ppname = + (uu___2.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (uu___2.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = + (bview.FStarC_Reflection_V1_Data.binder_sort) + }); + FStarC_Syntax_Syntax.binder_qual = uu___1; + FStarC_Syntax_Syntax.binder_positivity = pqual; + FStarC_Syntax_Syntax.binder_attrs = attrs + } +let (moduleof : FStarC_TypeChecker_Env.env -> Prims.string Prims.list) = + fun e -> FStarC_Ident.path_of_lid e.FStarC_TypeChecker_Env.curmodule +let (env_open_modules : + FStarC_TypeChecker_Env.env -> FStarC_Reflection_V1_Data.name Prims.list) = + fun e -> + let uu___ = + FStarC_Syntax_DsEnv.open_modules e.FStarC_TypeChecker_Env.dsenv in + FStarC_Compiler_List.map + (fun uu___1 -> + match uu___1 with + | (l, m) -> + let uu___2 = FStarC_Ident.ids_of_lid l in + FStarC_Compiler_List.map FStarC_Ident.string_of_id uu___2) uu___ +let (binders_of_env : + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.binders) = + fun e -> FStarC_TypeChecker_Env.all_binders e +let eqopt : + 'uuuuu . + unit -> + ('uuuuu -> 'uuuuu -> Prims.bool) -> + 'uuuuu FStar_Pervasives_Native.option -> + 'uuuuu FStar_Pervasives_Native.option -> Prims.bool + = fun uu___ -> FStarC_Syntax_Util.eqopt +let eqlist : + 'uuuuu . + unit -> + ('uuuuu -> 'uuuuu -> Prims.bool) -> + 'uuuuu Prims.list -> 'uuuuu Prims.list -> Prims.bool + = fun uu___ -> FStarC_Syntax_Util.eqlist +let eqprod : + 'uuuuu 'uuuuu1 . + unit -> + ('uuuuu -> 'uuuuu -> Prims.bool) -> + ('uuuuu1 -> 'uuuuu1 -> Prims.bool) -> + ('uuuuu * 'uuuuu1) -> ('uuuuu * 'uuuuu1) -> Prims.bool + = fun uu___ -> FStarC_Syntax_Util.eqprod +let rec (term_eq : + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t1 -> + fun t2 -> + let uu___ = + let uu___1 = inspect_ln t1 in + let uu___2 = inspect_ln t2 in (uu___1, uu___2) in + match uu___ with + | (FStarC_Reflection_V1_Data.Tv_Var bv1, + FStarC_Reflection_V1_Data.Tv_Var bv2) -> bv_eq bv1 bv2 + | (FStarC_Reflection_V1_Data.Tv_BVar bv1, + FStarC_Reflection_V1_Data.Tv_BVar bv2) -> bv_eq bv1 bv2 + | (FStarC_Reflection_V1_Data.Tv_FVar fv1, + FStarC_Reflection_V1_Data.Tv_FVar fv2) -> + FStarC_Syntax_Syntax.fv_eq fv1 fv2 + | (FStarC_Reflection_V1_Data.Tv_UInst (fv1, us1), + FStarC_Reflection_V1_Data.Tv_UInst (fv2, us2)) -> + (FStarC_Syntax_Syntax.fv_eq fv1 fv2) && (univs_eq us1 us2) + | (FStarC_Reflection_V1_Data.Tv_App (h1, arg1), + FStarC_Reflection_V1_Data.Tv_App (h2, arg2)) -> + (term_eq h1 h2) && (arg_eq arg1 arg2) + | (FStarC_Reflection_V1_Data.Tv_Abs (b1, t11), + FStarC_Reflection_V1_Data.Tv_Abs (b2, t21)) -> + (binder_eq b1 b2) && (term_eq t11 t21) + | (FStarC_Reflection_V1_Data.Tv_Arrow (b1, c1), + FStarC_Reflection_V1_Data.Tv_Arrow (b2, c2)) -> + (binder_eq b1 b2) && (comp_eq c1 c2) + | (FStarC_Reflection_V1_Data.Tv_Type u1, + FStarC_Reflection_V1_Data.Tv_Type u2) -> univ_eq u1 u2 + | (FStarC_Reflection_V1_Data.Tv_Refine (b1, sort1, t11), + FStarC_Reflection_V1_Data.Tv_Refine (b2, sort2, t21)) -> + (term_eq sort1 sort2) && (term_eq t11 t21) + | (FStarC_Reflection_V1_Data.Tv_Const c1, + FStarC_Reflection_V1_Data.Tv_Const c2) -> const_eq c1 c2 + | (FStarC_Reflection_V1_Data.Tv_Uvar (n1, uv1), + FStarC_Reflection_V1_Data.Tv_Uvar (n2, uv2)) -> n1 = n2 + | (FStarC_Reflection_V1_Data.Tv_Let (r1, ats1, bv1, ty1, m1, n1), + FStarC_Reflection_V1_Data.Tv_Let (r2, ats2, bv2, ty2, m2, n2)) -> + ((((r1 = r2) && ((eqlist ()) term_eq ats1 ats2)) && + (term_eq ty1 ty2)) + && (term_eq m1 m2)) + && (term_eq n1 n2) + | (FStarC_Reflection_V1_Data.Tv_Match (h1, an1, brs1), + FStarC_Reflection_V1_Data.Tv_Match (h2, an2, brs2)) -> + ((term_eq h1 h2) && ((eqopt ()) match_ret_asc_eq an1 an2)) && + ((eqlist ()) branch_eq brs1 brs2) + | (FStarC_Reflection_V1_Data.Tv_AscribedT (e1, t11, topt1, eq1), + FStarC_Reflection_V1_Data.Tv_AscribedT (e2, t21, topt2, eq2)) -> + (((term_eq e1 e2) && (term_eq t11 t21)) && + ((eqopt ()) term_eq topt1 topt2)) + && (eq1 = eq2) + | (FStarC_Reflection_V1_Data.Tv_AscribedC (e1, c1, topt1, eq1), + FStarC_Reflection_V1_Data.Tv_AscribedC (e2, c2, topt2, eq2)) -> + (((term_eq e1 e2) && (comp_eq c1 c2)) && + ((eqopt ()) term_eq topt1 topt2)) + && (eq1 = eq2) + | (FStarC_Reflection_V1_Data.Tv_Unknown, + FStarC_Reflection_V1_Data.Tv_Unknown) -> true + | uu___1 -> false +and (arg_eq : + FStarC_Reflection_V1_Data.argv -> + FStarC_Reflection_V1_Data.argv -> Prims.bool) + = + fun arg1 -> + fun arg2 -> + let uu___ = arg1 in + match uu___ with + | (a1, aq1) -> + let uu___1 = arg2 in + (match uu___1 with + | (a2, aq2) -> (term_eq a1 a2) && (aqual_eq aq1 aq2)) +and (aqual_eq : + FStarC_Reflection_V1_Data.aqualv -> + FStarC_Reflection_V1_Data.aqualv -> Prims.bool) + = + fun aq1 -> + fun aq2 -> + match (aq1, aq2) with + | (FStarC_Reflection_V1_Data.Q_Implicit, + FStarC_Reflection_V1_Data.Q_Implicit) -> true + | (FStarC_Reflection_V1_Data.Q_Explicit, + FStarC_Reflection_V1_Data.Q_Explicit) -> true + | (FStarC_Reflection_V1_Data.Q_Meta t1, + FStarC_Reflection_V1_Data.Q_Meta t2) -> term_eq t1 t2 + | uu___ -> false +and (binder_eq : + FStarC_Syntax_Syntax.binder -> FStarC_Syntax_Syntax.binder -> Prims.bool) = + fun b1 -> + fun b2 -> + let bview1 = inspect_binder b1 in + let bview2 = inspect_binder b2 in + ((binding_bv_eq bview1.FStarC_Reflection_V1_Data.binder_bv + bview2.FStarC_Reflection_V1_Data.binder_bv) + && + (aqual_eq bview1.FStarC_Reflection_V1_Data.binder_qual + bview2.FStarC_Reflection_V1_Data.binder_qual)) + && + ((eqlist ()) term_eq bview1.FStarC_Reflection_V1_Data.binder_attrs + bview2.FStarC_Reflection_V1_Data.binder_attrs) +and (binding_bv_eq : + FStarC_Syntax_Syntax.bv -> FStarC_Syntax_Syntax.bv -> Prims.bool) = + fun bv1 -> + fun bv2 -> + term_eq bv1.FStarC_Syntax_Syntax.sort bv2.FStarC_Syntax_Syntax.sort +and (bv_eq : + FStarC_Syntax_Syntax.bv -> FStarC_Syntax_Syntax.bv -> Prims.bool) = + fun bv1 -> + fun bv2 -> + bv1.FStarC_Syntax_Syntax.index = bv2.FStarC_Syntax_Syntax.index +and (comp_eq : + FStarC_Syntax_Syntax.comp -> FStarC_Syntax_Syntax.comp -> Prims.bool) = + fun c1 -> + fun c2 -> + let uu___ = + let uu___1 = inspect_comp c1 in + let uu___2 = inspect_comp c2 in (uu___1, uu___2) in + match uu___ with + | (FStarC_Reflection_V1_Data.C_Total t1, + FStarC_Reflection_V1_Data.C_Total t2) -> term_eq t1 t2 + | (FStarC_Reflection_V1_Data.C_GTotal t1, + FStarC_Reflection_V1_Data.C_GTotal t2) -> term_eq t1 t2 + | (FStarC_Reflection_V1_Data.C_Lemma (pre1, post1, pats1), + FStarC_Reflection_V1_Data.C_Lemma (pre2, post2, pats2)) -> + ((term_eq pre1 pre2) && (term_eq post1 post2)) && + (term_eq pats1 pats2) + | (FStarC_Reflection_V1_Data.C_Eff (us1, name1, t1, args1, decrs1), + FStarC_Reflection_V1_Data.C_Eff (us2, name2, t2, args2, decrs2)) -> + ((((univs_eq us1 us2) && (name1 = name2)) && (term_eq t1 t2)) && + ((eqlist ()) arg_eq args1 args2)) + && ((eqlist ()) term_eq decrs1 decrs2) + | uu___1 -> false +and (match_ret_asc_eq : + FStarC_Syntax_Syntax.match_returns_ascription -> + FStarC_Syntax_Syntax.match_returns_ascription -> Prims.bool) + = fun a1 -> fun a2 -> (eqprod ()) binder_eq ascription_eq a1 a2 +and (ascription_eq : + FStarC_Syntax_Syntax.ascription -> + FStarC_Syntax_Syntax.ascription -> Prims.bool) + = + fun asc1 -> + fun asc2 -> + let uu___ = asc1 in + match uu___ with + | (a1, topt1, eq1) -> + let uu___1 = asc2 in + (match uu___1 with + | (a2, topt2, eq2) -> + ((match (a1, a2) with + | (FStar_Pervasives.Inl t1, FStar_Pervasives.Inl t2) -> + term_eq t1 t2 + | (FStar_Pervasives.Inr c1, FStar_Pervasives.Inr c2) -> + comp_eq c1 c2) + && ((eqopt ()) term_eq topt1 topt2)) + && (eq1 = eq2)) +and (branch_eq : + FStarC_Reflection_V1_Data.branch -> + FStarC_Reflection_V1_Data.branch -> Prims.bool) + = fun c1 -> fun c2 -> (eqprod ()) pattern_eq term_eq c1 c2 +and (pattern_eq : + FStarC_Reflection_V1_Data.pattern -> + FStarC_Reflection_V1_Data.pattern -> Prims.bool) + = + fun p1 -> + fun p2 -> + match (p1, p2) with + | (FStarC_Reflection_V1_Data.Pat_Constant c1, + FStarC_Reflection_V1_Data.Pat_Constant c2) -> const_eq c1 c2 + | (FStarC_Reflection_V1_Data.Pat_Cons (fv1, us1, subpats1), + FStarC_Reflection_V1_Data.Pat_Cons (fv2, us2, subpats2)) -> + ((FStarC_Syntax_Syntax.fv_eq fv1 fv2) && + ((eqopt ()) ((eqlist ()) univ_eq) us1 us2)) + && + ((eqlist ()) + ((eqprod ()) pattern_eq (fun b1 -> fun b2 -> b1 = b2)) + subpats1 subpats2) + | (FStarC_Reflection_V1_Data.Pat_Var (bv1, uu___), + FStarC_Reflection_V1_Data.Pat_Var (bv2, uu___1)) -> + binding_bv_eq bv1 bv2 + | (FStarC_Reflection_V1_Data.Pat_Dot_Term topt1, + FStarC_Reflection_V1_Data.Pat_Dot_Term topt2) -> + (eqopt ()) term_eq topt1 topt2 + | uu___ -> false +and (const_eq : + FStarC_Reflection_V1_Data.vconst -> + FStarC_Reflection_V1_Data.vconst -> Prims.bool) + = fun c1 -> fun c2 -> c1 = c2 +and (univ_eq : + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.universe -> Prims.bool) + = fun u1 -> fun u2 -> FStarC_Syntax_Util.eq_univs u1 u2 +and (univs_eq : + FStarC_Syntax_Syntax.universe Prims.list -> + FStarC_Syntax_Syntax.universe Prims.list -> Prims.bool) + = fun us1 -> fun us2 -> (eqlist ()) univ_eq us1 us2 +let (implode_qn : Prims.string Prims.list -> Prims.string) = + fun ns -> FStarC_Compiler_String.concat "." ns +let (explode_qn : Prims.string -> Prims.string Prims.list) = + fun s -> FStarC_Compiler_String.split [46] s +let (compare_string : Prims.string -> Prims.string -> FStarC_BigInt.t) = + fun s1 -> + fun s2 -> FStarC_BigInt.of_int_fs (FStarC_Compiler_String.compare s1 s2) +let (push_binder : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.binder -> FStarC_TypeChecker_Env.env) + = fun e -> fun b -> FStarC_TypeChecker_Env.push_binders e [b] +let (subst : + FStarC_Syntax_Syntax.bv -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun x -> + fun n -> + fun m -> FStarC_Syntax_Subst.subst [FStarC_Syntax_Syntax.NT (x, n)] m +let (close_term : + FStarC_Syntax_Syntax.binder -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = fun b -> fun t -> FStarC_Syntax_Subst.close [b] t +let (range_of_term : + FStarC_Syntax_Syntax.term -> FStarC_Compiler_Range_Type.range) = + fun t -> t.FStarC_Syntax_Syntax.pos +let (range_of_sigelt : + FStarC_Syntax_Syntax.sigelt -> FStarC_Compiler_Range_Type.range) = + fun s -> s.FStarC_Syntax_Syntax.sigrng \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Reflection_V1_Constants.ml b/ocaml/fstar-lib/generated/FStarC_Reflection_V1_Constants.ml new file mode 100644 index 00000000000..572c68fd2dc --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Reflection_V1_Constants.ml @@ -0,0 +1,392 @@ +open Prims +type refl_constant = + { + lid: FStarC_Ident.lid ; + fv: FStarC_Syntax_Syntax.fv ; + t: FStarC_Syntax_Syntax.term } +let (__proj__Mkrefl_constant__item__lid : refl_constant -> FStarC_Ident.lid) + = fun projectee -> match projectee with | { lid; fv; t;_} -> lid +let (__proj__Mkrefl_constant__item__fv : + refl_constant -> FStarC_Syntax_Syntax.fv) = + fun projectee -> match projectee with | { lid; fv; t;_} -> fv +let (__proj__Mkrefl_constant__item__t : + refl_constant -> FStarC_Syntax_Syntax.term) = + fun projectee -> match projectee with | { lid; fv; t;_} -> t +let (refl_constant_lid : refl_constant -> FStarC_Ident.lid) = + fun rc -> rc.lid +let (refl_constant_term : refl_constant -> FStarC_Syntax_Syntax.term) = + fun rc -> rc.t +let (fstar_refl_lid : Prims.string Prims.list -> FStarC_Ident.lident) = + fun s -> + FStarC_Ident.lid_of_path + (FStarC_Compiler_List.op_At ["FStar"; "Stubs"; "Reflection"] s) + FStarC_Compiler_Range_Type.dummyRange +let (fstar_refl_types_lid : Prims.string -> FStarC_Ident.lident) = + fun s -> fstar_refl_lid ["Types"; s] +let (fstar_refl_builtins_lid : Prims.string -> FStarC_Ident.lident) = + fun s -> fstar_refl_lid ["V1"; "Builtins"; s] +let (fstar_refl_data_lid : Prims.string -> FStarC_Ident.lident) = + fun s -> fstar_refl_lid ["V1"; "Data"; s] +let (fstar_refl_data_const : Prims.string -> refl_constant) = + fun s -> + let lid = fstar_refl_data_lid s in + let uu___ = + FStarC_Syntax_Syntax.lid_as_fv lid + (FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.Data_ctor) in + let uu___1 = FStarC_Syntax_Syntax.tdataconstr lid in + { lid; fv = uu___; t = uu___1 } +let (mk_refl_types_lid_as_term : Prims.string -> FStarC_Syntax_Syntax.term) = + fun s -> + let uu___ = fstar_refl_types_lid s in FStarC_Syntax_Syntax.tconst uu___ +let (mk_refl_types_lid_as_fv : Prims.string -> FStarC_Syntax_Syntax.fv) = + fun s -> + let uu___ = fstar_refl_types_lid s in FStarC_Syntax_Syntax.fvconst uu___ +let (mk_refl_data_lid_as_term : Prims.string -> FStarC_Syntax_Syntax.term) = + fun s -> + let uu___ = fstar_refl_data_lid s in FStarC_Syntax_Syntax.tconst uu___ +let (mk_refl_data_lid_as_fv : Prims.string -> FStarC_Syntax_Syntax.fv) = + fun s -> + let uu___ = fstar_refl_data_lid s in FStarC_Syntax_Syntax.fvconst uu___ +let (mk_inspect_pack_pair : Prims.string -> (refl_constant * refl_constant)) + = + fun s -> + let inspect_lid = fstar_refl_builtins_lid (Prims.strcat "inspect" s) in + let pack_lid = fstar_refl_builtins_lid (Prims.strcat "pack" s) in + let inspect_fv = + FStarC_Syntax_Syntax.lid_as_fv inspect_lid FStar_Pervasives_Native.None in + let pack_fv = + FStarC_Syntax_Syntax.lid_as_fv pack_lid FStar_Pervasives_Native.None in + let inspect = + let uu___ = FStarC_Syntax_Syntax.fv_to_tm inspect_fv in + { lid = inspect_lid; fv = inspect_fv; t = uu___ } in + let pack = + let uu___ = FStarC_Syntax_Syntax.fv_to_tm pack_fv in + { lid = pack_lid; fv = pack_fv; t = uu___ } in + (inspect, pack) +let (uu___0 : (refl_constant * refl_constant)) = mk_inspect_pack_pair "_ln" +let (fstar_refl_inspect_ln : refl_constant) = + match uu___0 with + | (fstar_refl_inspect_ln1, fstar_refl_pack_ln) -> fstar_refl_inspect_ln1 +let (fstar_refl_pack_ln : refl_constant) = + match uu___0 with + | (fstar_refl_inspect_ln1, fstar_refl_pack_ln1) -> fstar_refl_pack_ln1 +let (uu___1 : (refl_constant * refl_constant)) = mk_inspect_pack_pair "_fv" +let (fstar_refl_inspect_fv : refl_constant) = + match uu___1 with + | (fstar_refl_inspect_fv1, fstar_refl_pack_fv) -> fstar_refl_inspect_fv1 +let (fstar_refl_pack_fv : refl_constant) = + match uu___1 with + | (fstar_refl_inspect_fv1, fstar_refl_pack_fv1) -> fstar_refl_pack_fv1 +let (uu___2 : (refl_constant * refl_constant)) = mk_inspect_pack_pair "_bv" +let (fstar_refl_inspect_bv : refl_constant) = + match uu___2 with + | (fstar_refl_inspect_bv1, fstar_refl_pack_bv) -> fstar_refl_inspect_bv1 +let (fstar_refl_pack_bv : refl_constant) = + match uu___2 with + | (fstar_refl_inspect_bv1, fstar_refl_pack_bv1) -> fstar_refl_pack_bv1 +let (uu___3 : (refl_constant * refl_constant)) = + mk_inspect_pack_pair "_binder" +let (fstar_refl_inspect_binder : refl_constant) = + match uu___3 with + | (fstar_refl_inspect_binder1, fstar_refl_pack_binder) -> + fstar_refl_inspect_binder1 +let (fstar_refl_pack_binder : refl_constant) = + match uu___3 with + | (fstar_refl_inspect_binder1, fstar_refl_pack_binder1) -> + fstar_refl_pack_binder1 +let (uu___4 : (refl_constant * refl_constant)) = mk_inspect_pack_pair "_comp" +let (fstar_refl_inspect_comp : refl_constant) = + match uu___4 with + | (fstar_refl_inspect_comp1, fstar_refl_pack_comp) -> + fstar_refl_inspect_comp1 +let (fstar_refl_pack_comp : refl_constant) = + match uu___4 with + | (fstar_refl_inspect_comp1, fstar_refl_pack_comp1) -> + fstar_refl_pack_comp1 +let (uu___5 : (refl_constant * refl_constant)) = + mk_inspect_pack_pair "_sigelt" +let (fstar_refl_inspect_sigelt : refl_constant) = + match uu___5 with + | (fstar_refl_inspect_sigelt1, fstar_refl_pack_sigelt) -> + fstar_refl_inspect_sigelt1 +let (fstar_refl_pack_sigelt : refl_constant) = + match uu___5 with + | (fstar_refl_inspect_sigelt1, fstar_refl_pack_sigelt1) -> + fstar_refl_pack_sigelt1 +let (uu___6 : (refl_constant * refl_constant)) = mk_inspect_pack_pair "_lb" +let (fstar_refl_inspect_lb : refl_constant) = + match uu___6 with + | (fstar_refl_inspect_lb1, fstar_refl_pack_lb) -> fstar_refl_inspect_lb1 +let (fstar_refl_pack_lb : refl_constant) = + match uu___6 with + | (fstar_refl_inspect_lb1, fstar_refl_pack_lb1) -> fstar_refl_pack_lb1 +let (uu___7 : (refl_constant * refl_constant)) = + mk_inspect_pack_pair "_universe" +let (fstar_refl_inspect_universe : refl_constant) = + match uu___7 with + | (fstar_refl_inspect_universe1, fstar_refl_pack_universe) -> + fstar_refl_inspect_universe1 +let (fstar_refl_pack_universe : refl_constant) = + match uu___7 with + | (fstar_refl_inspect_universe1, fstar_refl_pack_universe1) -> + fstar_refl_pack_universe1 +let (fstar_refl_env : FStarC_Syntax_Syntax.term) = + mk_refl_types_lid_as_term "env" +let (fstar_refl_env_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_types_lid_as_fv "env" +let (fstar_refl_bv : FStarC_Syntax_Syntax.term) = + mk_refl_types_lid_as_term "bv" +let (fstar_refl_bv_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_types_lid_as_fv "bv" +let (fstar_refl_fv : FStarC_Syntax_Syntax.term) = + mk_refl_types_lid_as_term "fv" +let (fstar_refl_fv_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_types_lid_as_fv "fv" +let (fstar_refl_comp : FStarC_Syntax_Syntax.term) = + mk_refl_types_lid_as_term "comp" +let (fstar_refl_comp_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_types_lid_as_fv "comp" +let (fstar_refl_binder : FStarC_Syntax_Syntax.term) = + mk_refl_types_lid_as_term "binder" +let (fstar_refl_binder_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_types_lid_as_fv "binder" +let (fstar_refl_sigelt : FStarC_Syntax_Syntax.term) = + mk_refl_types_lid_as_term "sigelt" +let (fstar_refl_sigelt_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_types_lid_as_fv "sigelt" +let (fstar_refl_term : FStarC_Syntax_Syntax.term) = + mk_refl_types_lid_as_term "term" +let (fstar_refl_term_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_types_lid_as_fv "term" +let (fstar_refl_letbinding : FStarC_Syntax_Syntax.term) = + mk_refl_types_lid_as_term "letbinding" +let (fstar_refl_letbinding_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_types_lid_as_fv "letbinding" +let (fstar_refl_ident : FStarC_Syntax_Syntax.term) = + mk_refl_types_lid_as_term "ident" +let (fstar_refl_ident_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_types_lid_as_fv "ident" +let (fstar_refl_univ_name : FStarC_Syntax_Syntax.term) = + mk_refl_types_lid_as_term "univ_name" +let (fstar_refl_univ_name_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_types_lid_as_fv "univ_name" +let (fstar_refl_optionstate : FStarC_Syntax_Syntax.term) = + mk_refl_types_lid_as_term "optionstate" +let (fstar_refl_optionstate_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_types_lid_as_fv "optionstate" +let (fstar_refl_universe : FStarC_Syntax_Syntax.term) = + mk_refl_types_lid_as_term "universe" +let (fstar_refl_universe_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_types_lid_as_fv "universe" +let (fstar_refl_aqualv : FStarC_Syntax_Syntax.term) = + mk_refl_data_lid_as_term "aqualv" +let (fstar_refl_aqualv_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_data_lid_as_fv "aqualv" +let (fstar_refl_comp_view : FStarC_Syntax_Syntax.term) = + mk_refl_data_lid_as_term "comp_view" +let (fstar_refl_comp_view_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_data_lid_as_fv "comp_view" +let (fstar_refl_term_view : FStarC_Syntax_Syntax.term) = + mk_refl_data_lid_as_term "term_view" +let (fstar_refl_term_view_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_data_lid_as_fv "term_view" +let (fstar_refl_pattern : FStarC_Syntax_Syntax.term) = + mk_refl_data_lid_as_term "pattern" +let (fstar_refl_pattern_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_data_lid_as_fv "pattern" +let (fstar_refl_branch : FStarC_Syntax_Syntax.term) = + mk_refl_data_lid_as_term "branch" +let (fstar_refl_branch_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_data_lid_as_fv "branch" +let (fstar_refl_bv_view : FStarC_Syntax_Syntax.term) = + mk_refl_data_lid_as_term "bv_view" +let (fstar_refl_bv_view_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_data_lid_as_fv "bv_view" +let (fstar_refl_binder_view : FStarC_Syntax_Syntax.term) = + mk_refl_data_lid_as_term "binder_view" +let (fstar_refl_binder_view_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_data_lid_as_fv "binder_view" +let (fstar_refl_vconst : FStarC_Syntax_Syntax.term) = + mk_refl_data_lid_as_term "vconst" +let (fstar_refl_vconst_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_data_lid_as_fv "vconst" +let (fstar_refl_lb_view : FStarC_Syntax_Syntax.term) = + mk_refl_data_lid_as_term "lb_view" +let (fstar_refl_lb_view_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_data_lid_as_fv "lb_view" +let (fstar_refl_sigelt_view : FStarC_Syntax_Syntax.term) = + mk_refl_data_lid_as_term "sigelt_view" +let (fstar_refl_sigelt_view_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_data_lid_as_fv "sigelt_view" +let (fstar_refl_qualifier : FStarC_Syntax_Syntax.term) = + mk_refl_data_lid_as_term "qualifier" +let (fstar_refl_qualifier_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_data_lid_as_fv "qualifier" +let (fstar_refl_universe_view : FStarC_Syntax_Syntax.term) = + mk_refl_data_lid_as_term "universe_view" +let (fstar_refl_universe_view_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_data_lid_as_fv "universe_view" +let (ref_Mk_bv : refl_constant) = + let lid = fstar_refl_data_lid "Mkbv_view" in + let attr = + let uu___ = + let uu___8 = fstar_refl_data_lid "bv_view" in + let uu___9 = + let uu___10 = + FStarC_Ident.mk_ident + ("bv_ppname", FStarC_Compiler_Range_Type.dummyRange) in + let uu___11 = + let uu___12 = + FStarC_Ident.mk_ident + ("bv_index", FStarC_Compiler_Range_Type.dummyRange) in + [uu___12] in + uu___10 :: uu___11 in + (uu___8, uu___9) in + FStarC_Syntax_Syntax.Record_ctor uu___ in + let fv = + FStarC_Syntax_Syntax.lid_as_fv lid (FStar_Pervasives_Native.Some attr) in + let uu___ = FStarC_Syntax_Syntax.fv_to_tm fv in { lid; fv; t = uu___ } +let (ref_Mk_binder : refl_constant) = + let lid = fstar_refl_data_lid "Mkbinder_view" in + let attr = + let uu___ = + let uu___8 = fstar_refl_data_lid "binder_view" in + let uu___9 = + let uu___10 = + FStarC_Ident.mk_ident + ("binder_bv", FStarC_Compiler_Range_Type.dummyRange) in + let uu___11 = + let uu___12 = + FStarC_Ident.mk_ident + ("binder_qual", FStarC_Compiler_Range_Type.dummyRange) in + let uu___13 = + let uu___14 = + FStarC_Ident.mk_ident + ("binder_attrs", FStarC_Compiler_Range_Type.dummyRange) in + let uu___15 = + let uu___16 = + FStarC_Ident.mk_ident + ("binder_sort", FStarC_Compiler_Range_Type.dummyRange) in + [uu___16] in + uu___14 :: uu___15 in + uu___12 :: uu___13 in + uu___10 :: uu___11 in + (uu___8, uu___9) in + FStarC_Syntax_Syntax.Record_ctor uu___ in + let fv = + FStarC_Syntax_Syntax.lid_as_fv lid (FStar_Pervasives_Native.Some attr) in + let uu___ = FStarC_Syntax_Syntax.fv_to_tm fv in { lid; fv; t = uu___ } +let (ref_Mk_lb : refl_constant) = + let lid = fstar_refl_data_lid "Mklb_view" in + let attr = + let uu___ = + let uu___8 = fstar_refl_data_lid "lb_view" in + let uu___9 = + let uu___10 = + FStarC_Ident.mk_ident + ("lb_fv", FStarC_Compiler_Range_Type.dummyRange) in + let uu___11 = + let uu___12 = + FStarC_Ident.mk_ident + ("lb_us", FStarC_Compiler_Range_Type.dummyRange) in + let uu___13 = + let uu___14 = + FStarC_Ident.mk_ident + ("lb_typ", FStarC_Compiler_Range_Type.dummyRange) in + let uu___15 = + let uu___16 = + FStarC_Ident.mk_ident + ("lb_def", FStarC_Compiler_Range_Type.dummyRange) in + [uu___16] in + uu___14 :: uu___15 in + uu___12 :: uu___13 in + uu___10 :: uu___11 in + (uu___8, uu___9) in + FStarC_Syntax_Syntax.Record_ctor uu___ in + let fv = + FStarC_Syntax_Syntax.lid_as_fv lid (FStar_Pervasives_Native.Some attr) in + let uu___ = FStarC_Syntax_Syntax.fv_to_tm fv in { lid; fv; t = uu___ } +let (ref_Q_Explicit : refl_constant) = fstar_refl_data_const "Q_Explicit" +let (ref_Q_Implicit : refl_constant) = fstar_refl_data_const "Q_Implicit" +let (ref_Q_Meta : refl_constant) = fstar_refl_data_const "Q_Meta" +let (ref_C_Unit : refl_constant) = fstar_refl_data_const "C_Unit" +let (ref_C_True : refl_constant) = fstar_refl_data_const "C_True" +let (ref_C_False : refl_constant) = fstar_refl_data_const "C_False" +let (ref_C_Int : refl_constant) = fstar_refl_data_const "C_Int" +let (ref_C_String : refl_constant) = fstar_refl_data_const "C_String" +let (ref_C_Range : refl_constant) = fstar_refl_data_const "C_Range" +let (ref_C_Reify : refl_constant) = fstar_refl_data_const "C_Reify" +let (ref_C_Reflect : refl_constant) = fstar_refl_data_const "C_Reflect" +let (ref_Pat_Constant : refl_constant) = fstar_refl_data_const "Pat_Constant" +let (ref_Pat_Cons : refl_constant) = fstar_refl_data_const "Pat_Cons" +let (ref_Pat_Var : refl_constant) = fstar_refl_data_const "Pat_Var" +let (ref_Pat_Dot_Term : refl_constant) = fstar_refl_data_const "Pat_Dot_Term" +let (ref_Uv_Zero : refl_constant) = fstar_refl_data_const "Uv_Zero" +let (ref_Uv_Succ : refl_constant) = fstar_refl_data_const "Uv_Succ" +let (ref_Uv_Max : refl_constant) = fstar_refl_data_const "Uv_Max" +let (ref_Uv_BVar : refl_constant) = fstar_refl_data_const "Uv_BVar" +let (ref_Uv_Name : refl_constant) = fstar_refl_data_const "Uv_Name" +let (ref_Uv_Unif : refl_constant) = fstar_refl_data_const "Uv_Unif" +let (ref_Uv_Unk : refl_constant) = fstar_refl_data_const "Uv_Unk" +let (ref_Tv_Var : refl_constant) = fstar_refl_data_const "Tv_Var" +let (ref_Tv_BVar : refl_constant) = fstar_refl_data_const "Tv_BVar" +let (ref_Tv_FVar : refl_constant) = fstar_refl_data_const "Tv_FVar" +let (ref_Tv_UInst : refl_constant) = fstar_refl_data_const "Tv_UInst" +let (ref_Tv_App : refl_constant) = fstar_refl_data_const "Tv_App" +let (ref_Tv_Abs : refl_constant) = fstar_refl_data_const "Tv_Abs" +let (ref_Tv_Arrow : refl_constant) = fstar_refl_data_const "Tv_Arrow" +let (ref_Tv_Type : refl_constant) = fstar_refl_data_const "Tv_Type" +let (ref_Tv_Refine : refl_constant) = fstar_refl_data_const "Tv_Refine" +let (ref_Tv_Const : refl_constant) = fstar_refl_data_const "Tv_Const" +let (ref_Tv_Uvar : refl_constant) = fstar_refl_data_const "Tv_Uvar" +let (ref_Tv_Let : refl_constant) = fstar_refl_data_const "Tv_Let" +let (ref_Tv_Match : refl_constant) = fstar_refl_data_const "Tv_Match" +let (ref_Tv_AscT : refl_constant) = fstar_refl_data_const "Tv_AscribedT" +let (ref_Tv_AscC : refl_constant) = fstar_refl_data_const "Tv_AscribedC" +let (ref_Tv_Unknown : refl_constant) = fstar_refl_data_const "Tv_Unknown" +let (ref_Tv_Unsupp : refl_constant) = fstar_refl_data_const "Tv_Unsupp" +let (ref_C_Total : refl_constant) = fstar_refl_data_const "C_Total" +let (ref_C_GTotal : refl_constant) = fstar_refl_data_const "C_GTotal" +let (ref_C_Lemma : refl_constant) = fstar_refl_data_const "C_Lemma" +let (ref_C_Eff : refl_constant) = fstar_refl_data_const "C_Eff" +let (ref_Sg_Let : refl_constant) = fstar_refl_data_const "Sg_Let" +let (ref_Sg_Inductive : refl_constant) = fstar_refl_data_const "Sg_Inductive" +let (ref_Sg_Val : refl_constant) = fstar_refl_data_const "Sg_Val" +let (ref_Unk : refl_constant) = fstar_refl_data_const "Unk" +let (ref_qual_Assumption : refl_constant) = + fstar_refl_data_const "Assumption" +let (ref_qual_InternalAssumption : refl_constant) = + fstar_refl_data_const "InternalAssumption" +let (ref_qual_New : refl_constant) = fstar_refl_data_const "New" +let (ref_qual_Private : refl_constant) = fstar_refl_data_const "Private" +let (ref_qual_Unfold_for_unification_and_vcgen : refl_constant) = + fstar_refl_data_const "Unfold_for_unification_and_vcgen" +let (ref_qual_Visible_default : refl_constant) = + fstar_refl_data_const "Visible_default" +let (ref_qual_Irreducible : refl_constant) = + fstar_refl_data_const "Irreducible" +let (ref_qual_Inline_for_extraction : refl_constant) = + fstar_refl_data_const "Inline_for_extraction" +let (ref_qual_NoExtract : refl_constant) = fstar_refl_data_const "NoExtract" +let (ref_qual_Noeq : refl_constant) = fstar_refl_data_const "Noeq" +let (ref_qual_Unopteq : refl_constant) = fstar_refl_data_const "Unopteq" +let (ref_qual_TotalEffect : refl_constant) = + fstar_refl_data_const "TotalEffect" +let (ref_qual_Logic : refl_constant) = fstar_refl_data_const "Logic" +let (ref_qual_Reifiable : refl_constant) = fstar_refl_data_const "Reifiable" +let (ref_qual_Reflectable : refl_constant) = + fstar_refl_data_const "Reflectable" +let (ref_qual_Discriminator : refl_constant) = + fstar_refl_data_const "Discriminator" +let (ref_qual_Projector : refl_constant) = fstar_refl_data_const "Projector" +let (ref_qual_RecordType : refl_constant) = + fstar_refl_data_const "RecordType" +let (ref_qual_RecordConstructor : refl_constant) = + fstar_refl_data_const "RecordConstructor" +let (ref_qual_Action : refl_constant) = fstar_refl_data_const "Action" +let (ref_qual_ExceptionConstructor : refl_constant) = + fstar_refl_data_const "ExceptionConstructor" +let (ref_qual_HasMaskedEffect : refl_constant) = + fstar_refl_data_const "HasMaskedEffect" +let (ref_qual_Effect : refl_constant) = fstar_refl_data_const "Effect" +let (ref_qual_OnlyName : refl_constant) = fstar_refl_data_const "OnlyName" \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Reflection_V1_Data.ml b/ocaml/fstar-lib/generated/FStarC_Reflection_V1_Data.ml new file mode 100644 index 00000000000..14c35308b76 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Reflection_V1_Data.ml @@ -0,0 +1,474 @@ +open Prims +type name = Prims.string Prims.list +type typ = FStarC_Syntax_Syntax.term +type binders = FStarC_Syntax_Syntax.binder Prims.list +type ident = (Prims.string * FStarC_Compiler_Range_Type.range) +type univ_name = ident +type vconst = + | C_Unit + | C_Int of FStarC_BigInt.t + | C_True + | C_False + | C_String of Prims.string + | C_Range of FStarC_Compiler_Range_Type.range + | C_Reify + | C_Reflect of name +let (uu___is_C_Unit : vconst -> Prims.bool) = + fun projectee -> match projectee with | C_Unit -> true | uu___ -> false +let (uu___is_C_Int : vconst -> Prims.bool) = + fun projectee -> match projectee with | C_Int _0 -> true | uu___ -> false +let (__proj__C_Int__item___0 : vconst -> FStarC_BigInt.t) = + fun projectee -> match projectee with | C_Int _0 -> _0 +let (uu___is_C_True : vconst -> Prims.bool) = + fun projectee -> match projectee with | C_True -> true | uu___ -> false +let (uu___is_C_False : vconst -> Prims.bool) = + fun projectee -> match projectee with | C_False -> true | uu___ -> false +let (uu___is_C_String : vconst -> Prims.bool) = + fun projectee -> + match projectee with | C_String _0 -> true | uu___ -> false +let (__proj__C_String__item___0 : vconst -> Prims.string) = + fun projectee -> match projectee with | C_String _0 -> _0 +let (uu___is_C_Range : vconst -> Prims.bool) = + fun projectee -> match projectee with | C_Range _0 -> true | uu___ -> false +let (__proj__C_Range__item___0 : vconst -> FStarC_Compiler_Range_Type.range) + = fun projectee -> match projectee with | C_Range _0 -> _0 +let (uu___is_C_Reify : vconst -> Prims.bool) = + fun projectee -> match projectee with | C_Reify -> true | uu___ -> false +let (uu___is_C_Reflect : vconst -> Prims.bool) = + fun projectee -> + match projectee with | C_Reflect _0 -> true | uu___ -> false +let (__proj__C_Reflect__item___0 : vconst -> name) = + fun projectee -> match projectee with | C_Reflect _0 -> _0 +type universes = FStarC_Syntax_Syntax.universe Prims.list +type pattern = + | Pat_Constant of vconst + | Pat_Cons of (FStarC_Syntax_Syntax.fv * FStarC_Syntax_Syntax.universe + Prims.list FStar_Pervasives_Native.option * (pattern * Prims.bool) + Prims.list) + | Pat_Var of (FStarC_Syntax_Syntax.bv * typ FStarC_Compiler_Sealed.sealed) + + | Pat_Dot_Term of FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option +let (uu___is_Pat_Constant : pattern -> Prims.bool) = + fun projectee -> + match projectee with | Pat_Constant _0 -> true | uu___ -> false +let (__proj__Pat_Constant__item___0 : pattern -> vconst) = + fun projectee -> match projectee with | Pat_Constant _0 -> _0 +let (uu___is_Pat_Cons : pattern -> Prims.bool) = + fun projectee -> + match projectee with | Pat_Cons _0 -> true | uu___ -> false +let (__proj__Pat_Cons__item___0 : + pattern -> + (FStarC_Syntax_Syntax.fv * FStarC_Syntax_Syntax.universe Prims.list + FStar_Pervasives_Native.option * (pattern * Prims.bool) Prims.list)) + = fun projectee -> match projectee with | Pat_Cons _0 -> _0 +let (uu___is_Pat_Var : pattern -> Prims.bool) = + fun projectee -> match projectee with | Pat_Var _0 -> true | uu___ -> false +let (__proj__Pat_Var__item___0 : + pattern -> (FStarC_Syntax_Syntax.bv * typ FStarC_Compiler_Sealed.sealed)) = + fun projectee -> match projectee with | Pat_Var _0 -> _0 +let (uu___is_Pat_Dot_Term : pattern -> Prims.bool) = + fun projectee -> + match projectee with | Pat_Dot_Term _0 -> true | uu___ -> false +let (__proj__Pat_Dot_Term__item___0 : + pattern -> FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) = + fun projectee -> match projectee with | Pat_Dot_Term _0 -> _0 +type branch = (pattern * FStarC_Syntax_Syntax.term) +type aqualv = + | Q_Implicit + | Q_Explicit + | Q_Meta of FStarC_Syntax_Syntax.term +let (uu___is_Q_Implicit : aqualv -> Prims.bool) = + fun projectee -> match projectee with | Q_Implicit -> true | uu___ -> false +let (uu___is_Q_Explicit : aqualv -> Prims.bool) = + fun projectee -> match projectee with | Q_Explicit -> true | uu___ -> false +let (uu___is_Q_Meta : aqualv -> Prims.bool) = + fun projectee -> match projectee with | Q_Meta _0 -> true | uu___ -> false +let (__proj__Q_Meta__item___0 : aqualv -> FStarC_Syntax_Syntax.term) = + fun projectee -> match projectee with | Q_Meta _0 -> _0 +type argv = (FStarC_Syntax_Syntax.term * aqualv) +type ppname_t = Prims.string FStarC_Compiler_Sealed.sealed +let (as_ppname : Prims.string -> ppname_t) = + fun x -> FStarC_Compiler_Sealed.seal x +type bv_view = { + bv_ppname: ppname_t ; + bv_index: FStarC_BigInt.t } +let (__proj__Mkbv_view__item__bv_ppname : bv_view -> ppname_t) = + fun projectee -> + match projectee with | { bv_ppname; bv_index;_} -> bv_ppname +let (__proj__Mkbv_view__item__bv_index : bv_view -> FStarC_BigInt.t) = + fun projectee -> + match projectee with | { bv_ppname; bv_index;_} -> bv_index +type binder_view = + { + binder_bv: FStarC_Syntax_Syntax.bv ; + binder_qual: aqualv ; + binder_attrs: FStarC_Syntax_Syntax.term Prims.list ; + binder_sort: typ } +let (__proj__Mkbinder_view__item__binder_bv : + binder_view -> FStarC_Syntax_Syntax.bv) = + fun projectee -> + match projectee with + | { binder_bv; binder_qual; binder_attrs; binder_sort;_} -> binder_bv +let (__proj__Mkbinder_view__item__binder_qual : binder_view -> aqualv) = + fun projectee -> + match projectee with + | { binder_bv; binder_qual; binder_attrs; binder_sort;_} -> binder_qual +let (__proj__Mkbinder_view__item__binder_attrs : + binder_view -> FStarC_Syntax_Syntax.term Prims.list) = + fun projectee -> + match projectee with + | { binder_bv; binder_qual; binder_attrs; binder_sort;_} -> binder_attrs +let (__proj__Mkbinder_view__item__binder_sort : binder_view -> typ) = + fun projectee -> + match projectee with + | { binder_bv; binder_qual; binder_attrs; binder_sort;_} -> binder_sort +type universe_view = + | Uv_Zero + | Uv_Succ of FStarC_Syntax_Syntax.universe + | Uv_Max of universes + | Uv_BVar of FStarC_BigInt.t + | Uv_Name of (Prims.string * FStarC_Compiler_Range_Type.range) + | Uv_Unif of FStarC_Syntax_Syntax.universe_uvar + | Uv_Unk +let (uu___is_Uv_Zero : universe_view -> Prims.bool) = + fun projectee -> match projectee with | Uv_Zero -> true | uu___ -> false +let (uu___is_Uv_Succ : universe_view -> Prims.bool) = + fun projectee -> match projectee with | Uv_Succ _0 -> true | uu___ -> false +let (__proj__Uv_Succ__item___0 : + universe_view -> FStarC_Syntax_Syntax.universe) = + fun projectee -> match projectee with | Uv_Succ _0 -> _0 +let (uu___is_Uv_Max : universe_view -> Prims.bool) = + fun projectee -> match projectee with | Uv_Max _0 -> true | uu___ -> false +let (__proj__Uv_Max__item___0 : universe_view -> universes) = + fun projectee -> match projectee with | Uv_Max _0 -> _0 +let (uu___is_Uv_BVar : universe_view -> Prims.bool) = + fun projectee -> match projectee with | Uv_BVar _0 -> true | uu___ -> false +let (__proj__Uv_BVar__item___0 : universe_view -> FStarC_BigInt.t) = + fun projectee -> match projectee with | Uv_BVar _0 -> _0 +let (uu___is_Uv_Name : universe_view -> Prims.bool) = + fun projectee -> match projectee with | Uv_Name _0 -> true | uu___ -> false +let (__proj__Uv_Name__item___0 : + universe_view -> (Prims.string * FStarC_Compiler_Range_Type.range)) = + fun projectee -> match projectee with | Uv_Name _0 -> _0 +let (uu___is_Uv_Unif : universe_view -> Prims.bool) = + fun projectee -> match projectee with | Uv_Unif _0 -> true | uu___ -> false +let (__proj__Uv_Unif__item___0 : + universe_view -> FStarC_Syntax_Syntax.universe_uvar) = + fun projectee -> match projectee with | Uv_Unif _0 -> _0 +let (uu___is_Uv_Unk : universe_view -> Prims.bool) = + fun projectee -> match projectee with | Uv_Unk -> true | uu___ -> false +type term_view = + | Tv_Var of FStarC_Syntax_Syntax.bv + | Tv_BVar of FStarC_Syntax_Syntax.bv + | Tv_FVar of FStarC_Syntax_Syntax.fv + | Tv_UInst of (FStarC_Syntax_Syntax.fv * universes) + | Tv_App of (FStarC_Syntax_Syntax.term * argv) + | Tv_Abs of (FStarC_Syntax_Syntax.binder * FStarC_Syntax_Syntax.term) + | Tv_Arrow of (FStarC_Syntax_Syntax.binder * FStarC_Syntax_Syntax.comp) + | Tv_Type of FStarC_Syntax_Syntax.universe + | Tv_Refine of (FStarC_Syntax_Syntax.bv * typ * FStarC_Syntax_Syntax.term) + + | Tv_Const of vconst + | Tv_Uvar of (FStarC_BigInt.t * FStarC_Syntax_Syntax.ctx_uvar_and_subst) + | Tv_Let of (Prims.bool * FStarC_Syntax_Syntax.term Prims.list * + FStarC_Syntax_Syntax.bv * typ * FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.term) + | Tv_Match of (FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.match_returns_ascription + FStar_Pervasives_Native.option * branch Prims.list) + | Tv_AscribedT of (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option * Prims.bool) + | Tv_AscribedC of (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.comp * + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option * Prims.bool) + | Tv_Unknown + | Tv_Unsupp +let (uu___is_Tv_Var : term_view -> Prims.bool) = + fun projectee -> match projectee with | Tv_Var _0 -> true | uu___ -> false +let (__proj__Tv_Var__item___0 : term_view -> FStarC_Syntax_Syntax.bv) = + fun projectee -> match projectee with | Tv_Var _0 -> _0 +let (uu___is_Tv_BVar : term_view -> Prims.bool) = + fun projectee -> match projectee with | Tv_BVar _0 -> true | uu___ -> false +let (__proj__Tv_BVar__item___0 : term_view -> FStarC_Syntax_Syntax.bv) = + fun projectee -> match projectee with | Tv_BVar _0 -> _0 +let (uu___is_Tv_FVar : term_view -> Prims.bool) = + fun projectee -> match projectee with | Tv_FVar _0 -> true | uu___ -> false +let (__proj__Tv_FVar__item___0 : term_view -> FStarC_Syntax_Syntax.fv) = + fun projectee -> match projectee with | Tv_FVar _0 -> _0 +let (uu___is_Tv_UInst : term_view -> Prims.bool) = + fun projectee -> + match projectee with | Tv_UInst _0 -> true | uu___ -> false +let (__proj__Tv_UInst__item___0 : + term_view -> (FStarC_Syntax_Syntax.fv * universes)) = + fun projectee -> match projectee with | Tv_UInst _0 -> _0 +let (uu___is_Tv_App : term_view -> Prims.bool) = + fun projectee -> match projectee with | Tv_App _0 -> true | uu___ -> false +let (__proj__Tv_App__item___0 : + term_view -> (FStarC_Syntax_Syntax.term * argv)) = + fun projectee -> match projectee with | Tv_App _0 -> _0 +let (uu___is_Tv_Abs : term_view -> Prims.bool) = + fun projectee -> match projectee with | Tv_Abs _0 -> true | uu___ -> false +let (__proj__Tv_Abs__item___0 : + term_view -> (FStarC_Syntax_Syntax.binder * FStarC_Syntax_Syntax.term)) = + fun projectee -> match projectee with | Tv_Abs _0 -> _0 +let (uu___is_Tv_Arrow : term_view -> Prims.bool) = + fun projectee -> + match projectee with | Tv_Arrow _0 -> true | uu___ -> false +let (__proj__Tv_Arrow__item___0 : + term_view -> (FStarC_Syntax_Syntax.binder * FStarC_Syntax_Syntax.comp)) = + fun projectee -> match projectee with | Tv_Arrow _0 -> _0 +let (uu___is_Tv_Type : term_view -> Prims.bool) = + fun projectee -> match projectee with | Tv_Type _0 -> true | uu___ -> false +let (__proj__Tv_Type__item___0 : term_view -> FStarC_Syntax_Syntax.universe) + = fun projectee -> match projectee with | Tv_Type _0 -> _0 +let (uu___is_Tv_Refine : term_view -> Prims.bool) = + fun projectee -> + match projectee with | Tv_Refine _0 -> true | uu___ -> false +let (__proj__Tv_Refine__item___0 : + term_view -> (FStarC_Syntax_Syntax.bv * typ * FStarC_Syntax_Syntax.term)) = + fun projectee -> match projectee with | Tv_Refine _0 -> _0 +let (uu___is_Tv_Const : term_view -> Prims.bool) = + fun projectee -> + match projectee with | Tv_Const _0 -> true | uu___ -> false +let (__proj__Tv_Const__item___0 : term_view -> vconst) = + fun projectee -> match projectee with | Tv_Const _0 -> _0 +let (uu___is_Tv_Uvar : term_view -> Prims.bool) = + fun projectee -> match projectee with | Tv_Uvar _0 -> true | uu___ -> false +let (__proj__Tv_Uvar__item___0 : + term_view -> (FStarC_BigInt.t * FStarC_Syntax_Syntax.ctx_uvar_and_subst)) = + fun projectee -> match projectee with | Tv_Uvar _0 -> _0 +let (uu___is_Tv_Let : term_view -> Prims.bool) = + fun projectee -> match projectee with | Tv_Let _0 -> true | uu___ -> false +let (__proj__Tv_Let__item___0 : + term_view -> + (Prims.bool * FStarC_Syntax_Syntax.term Prims.list * + FStarC_Syntax_Syntax.bv * typ * FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.term)) + = fun projectee -> match projectee with | Tv_Let _0 -> _0 +let (uu___is_Tv_Match : term_view -> Prims.bool) = + fun projectee -> + match projectee with | Tv_Match _0 -> true | uu___ -> false +let (__proj__Tv_Match__item___0 : + term_view -> + (FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.match_returns_ascription + FStar_Pervasives_Native.option * branch Prims.list)) + = fun projectee -> match projectee with | Tv_Match _0 -> _0 +let (uu___is_Tv_AscribedT : term_view -> Prims.bool) = + fun projectee -> + match projectee with | Tv_AscribedT _0 -> true | uu___ -> false +let (__proj__Tv_AscribedT__item___0 : + term_view -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option * Prims.bool)) + = fun projectee -> match projectee with | Tv_AscribedT _0 -> _0 +let (uu___is_Tv_AscribedC : term_view -> Prims.bool) = + fun projectee -> + match projectee with | Tv_AscribedC _0 -> true | uu___ -> false +let (__proj__Tv_AscribedC__item___0 : + term_view -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.comp * + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option * Prims.bool)) + = fun projectee -> match projectee with | Tv_AscribedC _0 -> _0 +let (uu___is_Tv_Unknown : term_view -> Prims.bool) = + fun projectee -> match projectee with | Tv_Unknown -> true | uu___ -> false +let (uu___is_Tv_Unsupp : term_view -> Prims.bool) = + fun projectee -> match projectee with | Tv_Unsupp -> true | uu___ -> false +let (notAscription : term_view -> Prims.bool) = + fun tv -> + (Prims.op_Negation (uu___is_Tv_AscribedT tv)) && + (Prims.op_Negation (uu___is_Tv_AscribedC tv)) +type comp_view = + | C_Total of typ + | C_GTotal of typ + | C_Lemma of (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.term) + | C_Eff of (universes * name * FStarC_Syntax_Syntax.term * argv Prims.list + * FStarC_Syntax_Syntax.term Prims.list) +let (uu___is_C_Total : comp_view -> Prims.bool) = + fun projectee -> match projectee with | C_Total _0 -> true | uu___ -> false +let (__proj__C_Total__item___0 : comp_view -> typ) = + fun projectee -> match projectee with | C_Total _0 -> _0 +let (uu___is_C_GTotal : comp_view -> Prims.bool) = + fun projectee -> + match projectee with | C_GTotal _0 -> true | uu___ -> false +let (__proj__C_GTotal__item___0 : comp_view -> typ) = + fun projectee -> match projectee with | C_GTotal _0 -> _0 +let (uu___is_C_Lemma : comp_view -> Prims.bool) = + fun projectee -> match projectee with | C_Lemma _0 -> true | uu___ -> false +let (__proj__C_Lemma__item___0 : + comp_view -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.term)) + = fun projectee -> match projectee with | C_Lemma _0 -> _0 +let (uu___is_C_Eff : comp_view -> Prims.bool) = + fun projectee -> match projectee with | C_Eff _0 -> true | uu___ -> false +let (__proj__C_Eff__item___0 : + comp_view -> + (universes * name * FStarC_Syntax_Syntax.term * argv Prims.list * + FStarC_Syntax_Syntax.term Prims.list)) + = fun projectee -> match projectee with | C_Eff _0 -> _0 +type ctor = (name * typ) +type lb_view = + { + lb_fv: FStarC_Syntax_Syntax.fv ; + lb_us: univ_name Prims.list ; + lb_typ: typ ; + lb_def: FStarC_Syntax_Syntax.term } +let (__proj__Mklb_view__item__lb_fv : lb_view -> FStarC_Syntax_Syntax.fv) = + fun projectee -> + match projectee with | { lb_fv; lb_us; lb_typ; lb_def;_} -> lb_fv +let (__proj__Mklb_view__item__lb_us : lb_view -> univ_name Prims.list) = + fun projectee -> + match projectee with | { lb_fv; lb_us; lb_typ; lb_def;_} -> lb_us +let (__proj__Mklb_view__item__lb_typ : lb_view -> typ) = + fun projectee -> + match projectee with | { lb_fv; lb_us; lb_typ; lb_def;_} -> lb_typ +let (__proj__Mklb_view__item__lb_def : lb_view -> FStarC_Syntax_Syntax.term) + = + fun projectee -> + match projectee with | { lb_fv; lb_us; lb_typ; lb_def;_} -> lb_def +type sigelt_view = + | Sg_Let of (Prims.bool * FStarC_Syntax_Syntax.letbinding Prims.list) + | Sg_Inductive of (name * univ_name Prims.list * + FStarC_Syntax_Syntax.binder Prims.list * typ * ctor Prims.list) + | Sg_Val of (name * univ_name Prims.list * typ) + | Unk +let (uu___is_Sg_Let : sigelt_view -> Prims.bool) = + fun projectee -> match projectee with | Sg_Let _0 -> true | uu___ -> false +let (__proj__Sg_Let__item___0 : + sigelt_view -> (Prims.bool * FStarC_Syntax_Syntax.letbinding Prims.list)) = + fun projectee -> match projectee with | Sg_Let _0 -> _0 +let (uu___is_Sg_Inductive : sigelt_view -> Prims.bool) = + fun projectee -> + match projectee with | Sg_Inductive _0 -> true | uu___ -> false +let (__proj__Sg_Inductive__item___0 : + sigelt_view -> + (name * univ_name Prims.list * FStarC_Syntax_Syntax.binder Prims.list * + typ * ctor Prims.list)) + = fun projectee -> match projectee with | Sg_Inductive _0 -> _0 +let (uu___is_Sg_Val : sigelt_view -> Prims.bool) = + fun projectee -> match projectee with | Sg_Val _0 -> true | uu___ -> false +let (__proj__Sg_Val__item___0 : + sigelt_view -> (name * univ_name Prims.list * typ)) = + fun projectee -> match projectee with | Sg_Val _0 -> _0 +let (uu___is_Unk : sigelt_view -> Prims.bool) = + fun projectee -> match projectee with | Unk -> true | uu___ -> false +type qualifier = + | Assumption + | InternalAssumption + | New + | Private + | Unfold_for_unification_and_vcgen + | Visible_default + | Irreducible + | Inline_for_extraction + | NoExtract + | Noeq + | Unopteq + | TotalEffect + | Logic + | Reifiable + | Reflectable of name + | Discriminator of name + | Projector of (name * ident) + | RecordType of (ident Prims.list * ident Prims.list) + | RecordConstructor of (ident Prims.list * ident Prims.list) + | Action of name + | ExceptionConstructor + | HasMaskedEffect + | Effect + | OnlyName +let (uu___is_Assumption : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Assumption -> true | uu___ -> false +let (uu___is_InternalAssumption : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | InternalAssumption -> true | uu___ -> false +let (uu___is_New : qualifier -> Prims.bool) = + fun projectee -> match projectee with | New -> true | uu___ -> false +let (uu___is_Private : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Private -> true | uu___ -> false +let (uu___is_Unfold_for_unification_and_vcgen : qualifier -> Prims.bool) = + fun projectee -> + match projectee with + | Unfold_for_unification_and_vcgen -> true + | uu___ -> false +let (uu___is_Visible_default : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | Visible_default -> true | uu___ -> false +let (uu___is_Irreducible : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | Irreducible -> true | uu___ -> false +let (uu___is_Inline_for_extraction : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | Inline_for_extraction -> true | uu___ -> false +let (uu___is_NoExtract : qualifier -> Prims.bool) = + fun projectee -> match projectee with | NoExtract -> true | uu___ -> false +let (uu___is_Noeq : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Noeq -> true | uu___ -> false +let (uu___is_Unopteq : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Unopteq -> true | uu___ -> false +let (uu___is_TotalEffect : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | TotalEffect -> true | uu___ -> false +let (uu___is_Logic : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Logic -> true | uu___ -> false +let (uu___is_Reifiable : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Reifiable -> true | uu___ -> false +let (uu___is_Reflectable : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | Reflectable _0 -> true | uu___ -> false +let (__proj__Reflectable__item___0 : qualifier -> name) = + fun projectee -> match projectee with | Reflectable _0 -> _0 +let (uu___is_Discriminator : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | Discriminator _0 -> true | uu___ -> false +let (__proj__Discriminator__item___0 : qualifier -> name) = + fun projectee -> match projectee with | Discriminator _0 -> _0 +let (uu___is_Projector : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | Projector _0 -> true | uu___ -> false +let (__proj__Projector__item___0 : qualifier -> (name * ident)) = + fun projectee -> match projectee with | Projector _0 -> _0 +let (uu___is_RecordType : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | RecordType _0 -> true | uu___ -> false +let (__proj__RecordType__item___0 : + qualifier -> (ident Prims.list * ident Prims.list)) = + fun projectee -> match projectee with | RecordType _0 -> _0 +let (uu___is_RecordConstructor : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | RecordConstructor _0 -> true | uu___ -> false +let (__proj__RecordConstructor__item___0 : + qualifier -> (ident Prims.list * ident Prims.list)) = + fun projectee -> match projectee with | RecordConstructor _0 -> _0 +let (uu___is_Action : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Action _0 -> true | uu___ -> false +let (__proj__Action__item___0 : qualifier -> name) = + fun projectee -> match projectee with | Action _0 -> _0 +let (uu___is_ExceptionConstructor : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | ExceptionConstructor -> true | uu___ -> false +let (uu___is_HasMaskedEffect : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | HasMaskedEffect -> true | uu___ -> false +let (uu___is_Effect : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Effect -> true | uu___ -> false +let (uu___is_OnlyName : qualifier -> Prims.bool) = + fun projectee -> match projectee with | OnlyName -> true | uu___ -> false +type qualifiers = qualifier Prims.list +type var = FStarC_BigInt.t +type exp = + | Unit + | Var of var + | Mult of (exp * exp) +let (uu___is_Unit : exp -> Prims.bool) = + fun projectee -> match projectee with | Unit -> true | uu___ -> false +let (uu___is_Var : exp -> Prims.bool) = + fun projectee -> match projectee with | Var _0 -> true | uu___ -> false +let (__proj__Var__item___0 : exp -> var) = + fun projectee -> match projectee with | Var _0 -> _0 +let (uu___is_Mult : exp -> Prims.bool) = + fun projectee -> match projectee with | Mult _0 -> true | uu___ -> false +let (__proj__Mult__item___0 : exp -> (exp * exp)) = + fun projectee -> match projectee with | Mult _0 -> _0 +type decls = FStarC_Syntax_Syntax.sigelt Prims.list \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Reflection_V1_Embeddings.ml b/ocaml/fstar-lib/generated/FStarC_Reflection_V1_Embeddings.ml new file mode 100644 index 00000000000..cb8f5cb85d5 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Reflection_V1_Embeddings.ml @@ -0,0 +1,2177 @@ +open Prims +let (noaqs : FStarC_Syntax_Syntax.antiquotations) = (Prims.int_zero, []) +let mk_emb : + 'uuuuu . + (FStarC_Compiler_Range_Type.range -> 'uuuuu -> FStarC_Syntax_Syntax.term) + -> + (FStarC_Syntax_Syntax.term -> 'uuuuu FStar_Pervasives_Native.option) -> + FStarC_Syntax_Syntax.term -> + 'uuuuu FStarC_Syntax_Embeddings_Base.embedding + = + fun f -> + fun g -> + fun t -> + let uu___ = FStarC_Syntax_Embeddings_Base.term_as_fv t in + FStarC_Syntax_Embeddings_Base.mk_emb + (fun x -> fun r -> fun _topt -> fun _norm -> f r x) + (fun x -> fun _norm -> g x) uu___ +let embed : + 'a . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_Compiler_Range_Type.range -> 'a -> FStarC_Syntax_Syntax.term + = + fun uu___ -> + fun r -> + fun x -> + let uu___1 = FStarC_Syntax_Embeddings_Base.embed uu___ x in + uu___1 r FStar_Pervasives_Native.None + FStarC_Syntax_Embeddings_Base.id_norm_cb +let unembed : + 'a . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_Syntax_Syntax.term -> 'a FStar_Pervasives_Native.option + = + fun uu___ -> + fun x -> + FStarC_Syntax_Embeddings_Base.try_unembed uu___ x + FStarC_Syntax_Embeddings_Base.id_norm_cb +let (e_bv : FStarC_Syntax_Syntax.bv FStarC_Syntax_Embeddings_Base.embedding) + = FStarC_Reflection_V2_Embeddings.e_bv +let (e_binder : + FStarC_Syntax_Syntax.binder FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Reflection_V2_Embeddings.e_binder +let (e_term_aq : + FStarC_Syntax_Syntax.antiquotations -> + FStarC_Syntax_Syntax.term FStarC_Syntax_Embeddings_Base.embedding) + = FStarC_Reflection_V2_Embeddings.e_term_aq +let (e_term : + FStarC_Syntax_Syntax.term FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Reflection_V2_Embeddings.e_term +let (e_binders : + FStarC_Syntax_Syntax.binders FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Reflection_V2_Embeddings.e_binders +let (e_fv : FStarC_Syntax_Syntax.fv FStarC_Syntax_Embeddings_Base.embedding) + = FStarC_Reflection_V2_Embeddings.e_fv +let (e_comp : + FStarC_Syntax_Syntax.comp FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Reflection_V2_Embeddings.e_comp +let (e_universe : + FStarC_Syntax_Syntax.universe FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Reflection_V2_Embeddings.e_universe +let (e_aqualv : + FStarC_Reflection_V1_Data.aqualv FStarC_Syntax_Embeddings_Base.embedding) = + let embed_aqualv rng q = + let r = + match q with + | FStarC_Reflection_V1_Data.Q_Explicit -> + FStarC_Reflection_V1_Constants.ref_Q_Explicit.FStarC_Reflection_V1_Constants.t + | FStarC_Reflection_V1_Data.Q_Implicit -> + FStarC_Reflection_V1_Constants.ref_Q_Implicit.FStarC_Reflection_V1_Constants.t + | FStarC_Reflection_V1_Data.Q_Meta t -> + let uu___ = + let uu___1 = + let uu___2 = embed e_term rng t in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_Q_Meta.FStarC_Reflection_V1_Constants.t + uu___ FStarC_Compiler_Range_Type.dummyRange in + { + FStarC_Syntax_Syntax.n = (r.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = rng; + FStarC_Syntax_Syntax.vars = (r.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = (r.FStarC_Syntax_Syntax.hash_code) + } in + let unembed_aqualv t = + let t1 = FStarC_Syntax_Util.unascribe t in + let uu___ = FStarC_Syntax_Util.head_and_args t1 in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst hd in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Q_Explicit.FStarC_Reflection_V1_Constants.lid + -> + FStar_Pervasives_Native.Some + FStarC_Reflection_V1_Data.Q_Explicit + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Q_Implicit.FStarC_Reflection_V1_Constants.lid + -> + FStar_Pervasives_Native.Some + FStarC_Reflection_V1_Data.Q_Implicit + | (FStarC_Syntax_Syntax.Tm_fvar fv, (t2, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Q_Meta.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = unembed e_term t2 in + FStarC_Compiler_Util.bind_opt uu___3 + (fun t3 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Q_Meta t3)) + | uu___2 -> FStar_Pervasives_Native.None) in + mk_emb embed_aqualv unembed_aqualv + FStarC_Reflection_V1_Constants.fstar_refl_aqualv +let (e_ident : + FStarC_Reflection_V1_Data.ident FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Syntax_Embeddings.e_tuple2 FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_range +let (e_universe_view : + FStarC_Reflection_V1_Data.universe_view + FStarC_Syntax_Embeddings_Base.embedding) + = + let embed_universe_view rng uv = + match uv with + | FStarC_Reflection_V1_Data.Uv_Zero -> + FStarC_Reflection_V1_Constants.ref_Uv_Zero.FStarC_Reflection_V1_Constants.t + | FStarC_Reflection_V1_Data.Uv_Succ u -> + let uu___ = + let uu___1 = + let uu___2 = + embed FStarC_Reflection_V2_Embeddings.e_universe rng u in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_Uv_Succ.FStarC_Reflection_V1_Constants.t + uu___ rng + | FStarC_Reflection_V1_Data.Uv_Max us -> + let uu___ = + let uu___1 = + let uu___2 = + embed + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_universe) rng us in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_Uv_Max.FStarC_Reflection_V1_Constants.t + uu___ rng + | FStarC_Reflection_V1_Data.Uv_BVar n -> + let uu___ = + let uu___1 = + let uu___2 = embed FStarC_Syntax_Embeddings.e_int rng n in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_Uv_BVar.FStarC_Reflection_V1_Constants.t + uu___ rng + | FStarC_Reflection_V1_Data.Uv_Name i -> + let uu___ = + let uu___1 = + let uu___2 = embed e_ident rng i in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_Uv_Name.FStarC_Reflection_V1_Constants.t + uu___ rng + | FStarC_Reflection_V1_Data.Uv_Unif u -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Syntax_Util.mk_lazy u FStarC_Syntax_Util.t_universe_uvar + FStarC_Syntax_Syntax.Lazy_universe_uvar + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_Uv_Unif.FStarC_Reflection_V1_Constants.t + uu___ rng + | FStarC_Reflection_V1_Data.Uv_Unk -> + FStarC_Reflection_V1_Constants.ref_Uv_Unk.FStarC_Reflection_V1_Constants.t in + let unembed_universe_view t = + let t1 = FStarC_Syntax_Util.unascribe t in + let uu___ = FStarC_Syntax_Util.head_and_args t1 in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst hd in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Uv_Zero.FStarC_Reflection_V1_Constants.lid + -> + FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.Uv_Zero + | (FStarC_Syntax_Syntax.Tm_fvar fv, (u, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Uv_Succ.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = + unembed FStarC_Reflection_V2_Embeddings.e_universe u in + FStarC_Compiler_Util.bind_opt uu___3 + (fun u1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Uv_Succ u1)) + | (FStarC_Syntax_Syntax.Tm_fvar fv, (us, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Uv_Max.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = + unembed + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_universe) us in + FStarC_Compiler_Util.bind_opt uu___3 + (fun us1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Uv_Max us1)) + | (FStarC_Syntax_Syntax.Tm_fvar fv, (n, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Uv_BVar.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = unembed FStarC_Syntax_Embeddings.e_int n in + FStarC_Compiler_Util.bind_opt uu___3 + (fun n1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Uv_BVar n1)) + | (FStarC_Syntax_Syntax.Tm_fvar fv, (i, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Uv_Name.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = unembed e_ident i in + FStarC_Compiler_Util.bind_opt uu___3 + (fun i1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Uv_Name i1)) + | (FStarC_Syntax_Syntax.Tm_fvar fv, (u, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Uv_Unif.FStarC_Reflection_V1_Constants.lid + -> + let u1 = + FStarC_Syntax_Util.unlazy_as_t + FStarC_Syntax_Syntax.Lazy_universe_uvar u in + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Uv_Unif u1) + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Uv_Unk.FStarC_Reflection_V1_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.Uv_Unk + | uu___2 -> FStar_Pervasives_Native.None) in + mk_emb embed_universe_view unembed_universe_view + FStarC_Reflection_V1_Constants.fstar_refl_universe_view +let (e_env : + FStarC_TypeChecker_Env.env FStarC_Syntax_Embeddings_Base.embedding) = + let embed_env rng e = + FStarC_Syntax_Util.mk_lazy e + FStarC_Reflection_V1_Constants.fstar_refl_env + FStarC_Syntax_Syntax.Lazy_env (FStar_Pervasives_Native.Some rng) in + let unembed_env t = + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_lazy + { FStarC_Syntax_Syntax.blob = b; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_env; + FStarC_Syntax_Syntax.ltyp = uu___1; + FStarC_Syntax_Syntax.rng = uu___2;_} + -> + let uu___3 = FStarC_Dyn.undyn b in + FStar_Pervasives_Native.Some uu___3 + | uu___1 -> FStar_Pervasives_Native.None in + mk_emb embed_env unembed_env FStarC_Reflection_V1_Constants.fstar_refl_env +let (e_const : + FStarC_Reflection_V1_Data.vconst FStarC_Syntax_Embeddings_Base.embedding) = + let embed_const rng c = + let r = + match c with + | FStarC_Reflection_V1_Data.C_Unit -> + FStarC_Reflection_V1_Constants.ref_C_Unit.FStarC_Reflection_V1_Constants.t + | FStarC_Reflection_V1_Data.C_True -> + FStarC_Reflection_V1_Constants.ref_C_True.FStarC_Reflection_V1_Constants.t + | FStarC_Reflection_V1_Data.C_False -> + FStarC_Reflection_V1_Constants.ref_C_False.FStarC_Reflection_V1_Constants.t + | FStarC_Reflection_V1_Data.C_Int i -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_BigInt.string_of_big_int i in + FStarC_Syntax_Util.exp_int uu___3 in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_C_Int.FStarC_Reflection_V1_Constants.t + uu___ FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V1_Data.C_String s -> + let uu___ = + let uu___1 = + let uu___2 = embed FStarC_Syntax_Embeddings.e_string rng s in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_C_String.FStarC_Reflection_V1_Constants.t + uu___ FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V1_Data.C_Range r1 -> + let uu___ = + let uu___1 = + let uu___2 = embed FStarC_Syntax_Embeddings.e_range rng r1 in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_C_Range.FStarC_Reflection_V1_Constants.t + uu___ FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V1_Data.C_Reify -> + FStarC_Reflection_V1_Constants.ref_C_Reify.FStarC_Reflection_V1_Constants.t + | FStarC_Reflection_V1_Data.C_Reflect ns -> + let uu___ = + let uu___1 = + let uu___2 = + embed FStarC_Syntax_Embeddings.e_string_list rng ns in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_C_Reflect.FStarC_Reflection_V1_Constants.t + uu___ FStarC_Compiler_Range_Type.dummyRange in + { + FStarC_Syntax_Syntax.n = (r.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = rng; + FStarC_Syntax_Syntax.vars = (r.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = (r.FStarC_Syntax_Syntax.hash_code) + } in + let unembed_const t = + let t1 = FStarC_Syntax_Util.unascribe t in + let uu___ = FStarC_Syntax_Util.head_and_args t1 in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst hd in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_C_Unit.FStarC_Reflection_V1_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.C_Unit + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_C_True.FStarC_Reflection_V1_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.C_True + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_C_False.FStarC_Reflection_V1_Constants.lid + -> + FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.C_False + | (FStarC_Syntax_Syntax.Tm_fvar fv, (i, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_C_Int.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = unembed FStarC_Syntax_Embeddings.e_int i in + FStarC_Compiler_Util.bind_opt uu___3 + (fun i1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.C_Int i1)) + | (FStarC_Syntax_Syntax.Tm_fvar fv, (s, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_C_String.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = unembed FStarC_Syntax_Embeddings.e_string s in + FStarC_Compiler_Util.bind_opt uu___3 + (fun s1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.C_String s1)) + | (FStarC_Syntax_Syntax.Tm_fvar fv, (r, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_C_Range.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = unembed FStarC_Syntax_Embeddings.e_range r in + FStarC_Compiler_Util.bind_opt uu___3 + (fun r1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.C_Range r1)) + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_C_Reify.FStarC_Reflection_V1_Constants.lid + -> + FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.C_Reify + | (FStarC_Syntax_Syntax.Tm_fvar fv, (ns, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_C_Reflect.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = unembed FStarC_Syntax_Embeddings.e_string_list ns in + FStarC_Compiler_Util.bind_opt uu___3 + (fun ns1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.C_Reflect ns1)) + | uu___2 -> FStar_Pervasives_Native.None) in + mk_emb embed_const unembed_const + FStarC_Reflection_V1_Constants.fstar_refl_vconst +let rec e_pattern_aq : + 'uuuuu . + 'uuuuu -> + FStarC_Reflection_V1_Data.pattern + FStarC_Syntax_Embeddings_Base.embedding + = + fun aq -> + let rec embed_pattern rng p = + match p with + | FStarC_Reflection_V1_Data.Pat_Constant c -> + let uu___ = + let uu___1 = + let uu___2 = embed e_const rng c in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_Pat_Constant.FStarC_Reflection_V1_Constants.t + uu___ rng + | FStarC_Reflection_V1_Data.Pat_Cons (fv, us_opt, ps) -> + let uu___ = + let uu___1 = + let uu___2 = embed FStarC_Reflection_V2_Embeddings.e_fv rng fv in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + embed + (FStarC_Syntax_Embeddings.e_option + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_universe)) rng + us_opt in + FStarC_Syntax_Syntax.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = e_pattern_aq aq in + FStarC_Syntax_Embeddings.e_tuple2 uu___9 + FStarC_Syntax_Embeddings.e_bool in + FStarC_Syntax_Embeddings.e_list uu___8 in + embed uu___7 rng ps in + FStarC_Syntax_Syntax.as_arg uu___6 in + [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_Pat_Cons.FStarC_Reflection_V1_Constants.t + uu___ rng + | FStarC_Reflection_V1_Data.Pat_Var (bv, sort) -> + let uu___ = + let uu___1 = + let uu___2 = embed e_bv rng bv in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + embed (FStarC_Syntax_Embeddings.e_sealed e_term) rng sort in + FStarC_Syntax_Syntax.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_Pat_Var.FStarC_Reflection_V1_Constants.t + uu___ rng + | FStarC_Reflection_V1_Data.Pat_Dot_Term eopt -> + let uu___ = + let uu___1 = + let uu___2 = + embed (FStarC_Syntax_Embeddings.e_option e_term) rng eopt in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_Pat_Dot_Term.FStarC_Reflection_V1_Constants.t + uu___ rng in + let rec unembed_pattern t = + let t1 = FStarC_Syntax_Util.unascribe t in + let uu___ = FStarC_Syntax_Util.head_and_args t1 in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst hd in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, (c, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Pat_Constant.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = unembed e_const c in + FStarC_Compiler_Util.bind_opt uu___3 + (fun c1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Pat_Constant c1)) + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (f, uu___2)::(us_opt, uu___3)::(ps, uu___4)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Pat_Cons.FStarC_Reflection_V1_Constants.lid + -> + let uu___5 = unembed FStarC_Reflection_V2_Embeddings.e_fv f in + FStarC_Compiler_Util.bind_opt uu___5 + (fun f1 -> + let uu___6 = + unembed + (FStarC_Syntax_Embeddings.e_option + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_universe)) + us_opt in + FStarC_Compiler_Util.bind_opt uu___6 + (fun us_opt1 -> + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = e_pattern_aq aq in + FStarC_Syntax_Embeddings.e_tuple2 uu___10 + FStarC_Syntax_Embeddings.e_bool in + FStarC_Syntax_Embeddings.e_list uu___9 in + unembed uu___8 ps in + FStarC_Compiler_Util.bind_opt uu___7 + (fun ps1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Pat_Cons + (f1, us_opt1, ps1))))) + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (bv, uu___2)::(sort, uu___3)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Pat_Var.FStarC_Reflection_V1_Constants.lid + -> + let uu___4 = unembed e_bv bv in + FStarC_Compiler_Util.bind_opt uu___4 + (fun bv1 -> + let uu___5 = + unembed (FStarC_Syntax_Embeddings.e_sealed e_term) sort in + FStarC_Compiler_Util.bind_opt uu___5 + (fun sort1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Pat_Var (bv1, sort1)))) + | (FStarC_Syntax_Syntax.Tm_fvar fv, (eopt, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Pat_Dot_Term.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = + unembed (FStarC_Syntax_Embeddings.e_option e_term) eopt in + FStarC_Compiler_Util.bind_opt uu___3 + (fun eopt1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Pat_Dot_Term eopt1)) + | uu___2 -> FStar_Pervasives_Native.None) in + mk_emb embed_pattern unembed_pattern + FStarC_Reflection_V1_Constants.fstar_refl_pattern +let (e_pattern : + FStarC_Reflection_V1_Data.pattern FStarC_Syntax_Embeddings_Base.embedding) + = e_pattern_aq noaqs +let (e_branch : + FStarC_Reflection_V1_Data.branch FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Syntax_Embeddings.e_tuple2 e_pattern e_term +let (e_argv : + FStarC_Reflection_V1_Data.argv FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Syntax_Embeddings.e_tuple2 e_term e_aqualv +let (e_args : + FStarC_Reflection_V1_Data.argv Prims.list + FStarC_Syntax_Embeddings_Base.embedding) + = FStarC_Syntax_Embeddings.e_list e_argv +let (e_branch_aq : + FStarC_Syntax_Syntax.antiquotations -> + (FStarC_Reflection_V1_Data.pattern * FStarC_Syntax_Syntax.term) + FStarC_Syntax_Embeddings_Base.embedding) + = + fun aq -> + let uu___ = e_pattern_aq aq in + let uu___1 = e_term_aq aq in + FStarC_Syntax_Embeddings.e_tuple2 uu___ uu___1 +let (e_argv_aq : + FStarC_Syntax_Syntax.antiquotations -> + (FStarC_Syntax_Syntax.term * FStarC_Reflection_V1_Data.aqualv) + FStarC_Syntax_Embeddings_Base.embedding) + = + fun aq -> + let uu___ = e_term_aq aq in + FStarC_Syntax_Embeddings.e_tuple2 uu___ e_aqualv +let (e_match_returns_annotation : + (FStarC_Syntax_Syntax.binder * ((FStarC_Syntax_Syntax.term, + FStarC_Syntax_Syntax.comp) FStar_Pervasives.either * + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option * Prims.bool)) + FStar_Pervasives_Native.option FStarC_Syntax_Embeddings_Base.embedding) + = + FStarC_Syntax_Embeddings.e_option + (FStarC_Syntax_Embeddings.e_tuple2 e_binder + (FStarC_Syntax_Embeddings.e_tuple3 + (FStarC_Syntax_Embeddings.e_either e_term e_comp) + (FStarC_Syntax_Embeddings.e_option e_term) + FStarC_Syntax_Embeddings.e_bool)) +let (e_term_view_aq : + FStarC_Syntax_Syntax.antiquotations -> + FStarC_Reflection_V1_Data.term_view + FStarC_Syntax_Embeddings_Base.embedding) + = + fun aq -> + let push uu___ = + match uu___ with | (s, aq1) -> ((s + Prims.int_one), aq1) in + let embed_term_view rng t = + match t with + | FStarC_Reflection_V1_Data.Tv_FVar fv -> + let uu___ = + let uu___1 = + let uu___2 = embed FStarC_Reflection_V2_Embeddings.e_fv rng fv in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_Tv_FVar.FStarC_Reflection_V1_Constants.t + uu___ rng + | FStarC_Reflection_V1_Data.Tv_BVar fv -> + let uu___ = + let uu___1 = + let uu___2 = embed e_bv rng fv in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_Tv_BVar.FStarC_Reflection_V1_Constants.t + uu___ rng + | FStarC_Reflection_V1_Data.Tv_Var bv -> + let uu___ = + let uu___1 = + let uu___2 = embed e_bv rng bv in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_Tv_Var.FStarC_Reflection_V1_Constants.t + uu___ rng + | FStarC_Reflection_V1_Data.Tv_UInst (fv, us) -> + let uu___ = + let uu___1 = + let uu___2 = embed FStarC_Reflection_V2_Embeddings.e_fv rng fv in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + embed + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_universe) rng us in + FStarC_Syntax_Syntax.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_Tv_UInst.FStarC_Reflection_V1_Constants.t + uu___ rng + | FStarC_Reflection_V1_Data.Tv_App (hd, a) -> + let uu___ = + let uu___1 = + let uu___2 = let uu___3 = e_term_aq aq in embed uu___3 rng hd in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = let uu___5 = e_argv_aq aq in embed uu___5 rng a in + FStarC_Syntax_Syntax.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_Tv_App.FStarC_Reflection_V1_Constants.t + uu___ rng + | FStarC_Reflection_V1_Data.Tv_Abs (b, t1) -> + let uu___ = + let uu___1 = + let uu___2 = + embed FStarC_Reflection_V2_Embeddings.e_binder rng b in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = e_term_aq (push aq) in embed uu___5 rng t1 in + FStarC_Syntax_Syntax.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_Tv_Abs.FStarC_Reflection_V1_Constants.t + uu___ rng + | FStarC_Reflection_V1_Data.Tv_Arrow (b, c) -> + let uu___ = + let uu___1 = + let uu___2 = + embed FStarC_Reflection_V2_Embeddings.e_binder rng b in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + embed FStarC_Reflection_V2_Embeddings.e_comp rng c in + FStarC_Syntax_Syntax.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_Tv_Arrow.FStarC_Reflection_V1_Constants.t + uu___ rng + | FStarC_Reflection_V1_Data.Tv_Type u -> + let uu___ = + let uu___1 = + let uu___2 = + embed FStarC_Reflection_V2_Embeddings.e_universe rng u in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_Tv_Type.FStarC_Reflection_V1_Constants.t + uu___ rng + | FStarC_Reflection_V1_Data.Tv_Refine (bv, s, t1) -> + let uu___ = + let uu___1 = + let uu___2 = embed e_bv rng bv in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = let uu___5 = e_term_aq aq in embed uu___5 rng s in + FStarC_Syntax_Syntax.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = e_term_aq (push aq) in embed uu___7 rng t1 in + FStarC_Syntax_Syntax.as_arg uu___6 in + [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_Tv_Refine.FStarC_Reflection_V1_Constants.t + uu___ rng + | FStarC_Reflection_V1_Data.Tv_Const c -> + let uu___ = + let uu___1 = + let uu___2 = embed e_const rng c in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_Tv_Const.FStarC_Reflection_V1_Constants.t + uu___ rng + | FStarC_Reflection_V1_Data.Tv_Uvar (u, d) -> + let uu___ = + let uu___1 = + let uu___2 = embed FStarC_Syntax_Embeddings.e_int rng u in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Syntax_Util.mk_lazy (u, d) + FStarC_Syntax_Util.t_ctx_uvar_and_sust + FStarC_Syntax_Syntax.Lazy_uvar + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_Tv_Uvar.FStarC_Reflection_V1_Constants.t + uu___ rng + | FStarC_Reflection_V1_Data.Tv_Let (r, attrs, b, ty, t1, t2) -> + let uu___ = + let uu___1 = + let uu___2 = embed FStarC_Syntax_Embeddings.e_bool rng r in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + embed (FStarC_Syntax_Embeddings.e_list e_term) rng attrs in + FStarC_Syntax_Syntax.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = embed e_bv rng b in + FStarC_Syntax_Syntax.as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = e_term_aq aq in embed uu___9 rng ty in + FStarC_Syntax_Syntax.as_arg uu___8 in + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = e_term_aq aq in embed uu___11 rng t1 in + FStarC_Syntax_Syntax.as_arg uu___10 in + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = e_term_aq (push aq) in + embed uu___13 rng t2 in + FStarC_Syntax_Syntax.as_arg uu___12 in + [uu___11] in + uu___9 :: uu___10 in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_Tv_Let.FStarC_Reflection_V1_Constants.t + uu___ rng + | FStarC_Reflection_V1_Data.Tv_Match (t1, ret_opt, brs) -> + let uu___ = + let uu___1 = + let uu___2 = let uu___3 = e_term_aq aq in embed uu___3 rng t1 in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = embed e_match_returns_annotation rng ret_opt in + FStarC_Syntax_Syntax.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = e_branch_aq aq in + FStarC_Syntax_Embeddings.e_list uu___8 in + embed uu___7 rng brs in + FStarC_Syntax_Syntax.as_arg uu___6 in + [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_Tv_Match.FStarC_Reflection_V1_Constants.t + uu___ rng + | FStarC_Reflection_V1_Data.Tv_AscribedT (e, t1, tacopt, use_eq) -> + let uu___ = + let uu___1 = + let uu___2 = let uu___3 = e_term_aq aq in embed uu___3 rng e in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = let uu___5 = e_term_aq aq in embed uu___5 rng t1 in + FStarC_Syntax_Syntax.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = e_term_aq aq in + FStarC_Syntax_Embeddings.e_option uu___8 in + embed uu___7 rng tacopt in + FStarC_Syntax_Syntax.as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + embed FStarC_Syntax_Embeddings.e_bool rng use_eq in + FStarC_Syntax_Syntax.as_arg uu___8 in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_Tv_AscT.FStarC_Reflection_V1_Constants.t + uu___ rng + | FStarC_Reflection_V1_Data.Tv_AscribedC (e, c, tacopt, use_eq) -> + let uu___ = + let uu___1 = + let uu___2 = let uu___3 = e_term_aq aq in embed uu___3 rng e in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + embed FStarC_Reflection_V2_Embeddings.e_comp rng c in + FStarC_Syntax_Syntax.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = e_term_aq aq in + FStarC_Syntax_Embeddings.e_option uu___8 in + embed uu___7 rng tacopt in + FStarC_Syntax_Syntax.as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + embed FStarC_Syntax_Embeddings.e_bool rng use_eq in + FStarC_Syntax_Syntax.as_arg uu___8 in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_Tv_AscC.FStarC_Reflection_V1_Constants.t + uu___ rng + | FStarC_Reflection_V1_Data.Tv_Unknown -> + let uu___ = + FStarC_Reflection_V1_Constants.ref_Tv_Unknown.FStarC_Reflection_V1_Constants.t in + { + FStarC_Syntax_Syntax.n = (uu___.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = rng; + FStarC_Syntax_Syntax.vars = (uu___.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (uu___.FStarC_Syntax_Syntax.hash_code) + } + | FStarC_Reflection_V1_Data.Tv_Unsupp -> + let uu___ = + FStarC_Reflection_V1_Constants.ref_Tv_Unsupp.FStarC_Reflection_V1_Constants.t in + { + FStarC_Syntax_Syntax.n = (uu___.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = rng; + FStarC_Syntax_Syntax.vars = (uu___.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (uu___.FStarC_Syntax_Syntax.hash_code) + } in + let unembed_term_view t = + let uu___ = FStarC_Syntax_Util.head_and_args t in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst hd in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, (b, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_Var.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = unembed e_bv b in + FStarC_Compiler_Util.bind_opt uu___3 + (fun b1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Tv_Var b1)) + | (FStarC_Syntax_Syntax.Tm_fvar fv, (b, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_BVar.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = unembed e_bv b in + FStarC_Compiler_Util.bind_opt uu___3 + (fun b1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Tv_BVar b1)) + | (FStarC_Syntax_Syntax.Tm_fvar fv, (f, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_FVar.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = unembed FStarC_Reflection_V2_Embeddings.e_fv f in + FStarC_Compiler_Util.bind_opt uu___3 + (fun f1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Tv_FVar f1)) + | (FStarC_Syntax_Syntax.Tm_fvar fv, (f, uu___2)::(us, uu___3)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_UInst.FStarC_Reflection_V1_Constants.lid + -> + let uu___4 = unembed FStarC_Reflection_V2_Embeddings.e_fv f in + FStarC_Compiler_Util.bind_opt uu___4 + (fun f1 -> + let uu___5 = + unembed + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_universe) us in + FStarC_Compiler_Util.bind_opt uu___5 + (fun us1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Tv_UInst (f1, us1)))) + | (FStarC_Syntax_Syntax.Tm_fvar fv, (l, uu___2)::(r, uu___3)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_App.FStarC_Reflection_V1_Constants.lid + -> + let uu___4 = unembed e_term l in + FStarC_Compiler_Util.bind_opt uu___4 + (fun l1 -> + let uu___5 = unembed e_argv r in + FStarC_Compiler_Util.bind_opt uu___5 + (fun r1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Tv_App (l1, r1)))) + | (FStarC_Syntax_Syntax.Tm_fvar fv, (b, uu___2)::(t1, uu___3)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_Abs.FStarC_Reflection_V1_Constants.lid + -> + let uu___4 = + unembed FStarC_Reflection_V2_Embeddings.e_binder b in + FStarC_Compiler_Util.bind_opt uu___4 + (fun b1 -> + let uu___5 = unembed e_term t1 in + FStarC_Compiler_Util.bind_opt uu___5 + (fun t2 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Tv_Abs (b1, t2)))) + | (FStarC_Syntax_Syntax.Tm_fvar fv, (b, uu___2)::(t1, uu___3)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_Arrow.FStarC_Reflection_V1_Constants.lid + -> + let uu___4 = + unembed FStarC_Reflection_V2_Embeddings.e_binder b in + FStarC_Compiler_Util.bind_opt uu___4 + (fun b1 -> + let uu___5 = + unembed FStarC_Reflection_V2_Embeddings.e_comp t1 in + FStarC_Compiler_Util.bind_opt uu___5 + (fun c -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Tv_Arrow (b1, c)))) + | (FStarC_Syntax_Syntax.Tm_fvar fv, (u, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_Type.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = + unembed FStarC_Reflection_V2_Embeddings.e_universe u in + FStarC_Compiler_Util.bind_opt uu___3 + (fun u1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Tv_Type u1)) + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (b, uu___2)::(sort, uu___3)::(t1, uu___4)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_Refine.FStarC_Reflection_V1_Constants.lid + -> + let uu___5 = unembed e_bv b in + FStarC_Compiler_Util.bind_opt uu___5 + (fun b1 -> + let uu___6 = unembed e_term sort in + FStarC_Compiler_Util.bind_opt uu___6 + (fun sort1 -> + let uu___7 = unembed e_term t1 in + FStarC_Compiler_Util.bind_opt uu___7 + (fun t2 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Tv_Refine + (b1, sort1, t2))))) + | (FStarC_Syntax_Syntax.Tm_fvar fv, (c, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_Const.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = unembed e_const c in + FStarC_Compiler_Util.bind_opt uu___3 + (fun c1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Tv_Const c1)) + | (FStarC_Syntax_Syntax.Tm_fvar fv, (u, uu___2)::(l, uu___3)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_Uvar.FStarC_Reflection_V1_Constants.lid + -> + let uu___4 = unembed FStarC_Syntax_Embeddings.e_int u in + FStarC_Compiler_Util.bind_opt uu___4 + (fun u1 -> + let ctx_u_s = + FStarC_Syntax_Util.unlazy_as_t + FStarC_Syntax_Syntax.Lazy_uvar l in + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Tv_Uvar (u1, ctx_u_s))) + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (r, uu___2)::(attrs, uu___3)::(b, uu___4)::(ty, uu___5):: + (t1, uu___6)::(t2, uu___7)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_Let.FStarC_Reflection_V1_Constants.lid + -> + let uu___8 = unembed FStarC_Syntax_Embeddings.e_bool r in + FStarC_Compiler_Util.bind_opt uu___8 + (fun r1 -> + let uu___9 = + unembed (FStarC_Syntax_Embeddings.e_list e_term) attrs in + FStarC_Compiler_Util.bind_opt uu___9 + (fun attrs1 -> + let uu___10 = unembed e_bv b in + FStarC_Compiler_Util.bind_opt uu___10 + (fun b1 -> + let uu___11 = unembed e_term ty in + FStarC_Compiler_Util.bind_opt uu___11 + (fun ty1 -> + let uu___12 = unembed e_term t1 in + FStarC_Compiler_Util.bind_opt uu___12 + (fun t11 -> + let uu___13 = unembed e_term t2 in + FStarC_Compiler_Util.bind_opt uu___13 + (fun t21 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Tv_Let + (r1, attrs1, b1, ty1, t11, + t21)))))))) + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (t1, uu___2)::(ret_opt, uu___3)::(brs, uu___4)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_Match.FStarC_Reflection_V1_Constants.lid + -> + let uu___5 = unembed e_term t1 in + FStarC_Compiler_Util.bind_opt uu___5 + (fun t2 -> + let uu___6 = unembed e_match_returns_annotation ret_opt in + FStarC_Compiler_Util.bind_opt uu___6 + (fun ret_opt1 -> + let uu___7 = + unembed (FStarC_Syntax_Embeddings.e_list e_branch) + brs in + FStarC_Compiler_Util.bind_opt uu___7 + (fun brs1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Tv_Match + (t2, ret_opt1, brs1))))) + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (e, uu___2)::(t1, uu___3)::(tacopt, uu___4)::(use_eq, uu___5)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_AscT.FStarC_Reflection_V1_Constants.lid + -> + let uu___6 = unembed e_term e in + FStarC_Compiler_Util.bind_opt uu___6 + (fun e1 -> + let uu___7 = unembed e_term t1 in + FStarC_Compiler_Util.bind_opt uu___7 + (fun t2 -> + let uu___8 = + unembed (FStarC_Syntax_Embeddings.e_option e_term) + tacopt in + FStarC_Compiler_Util.bind_opt uu___8 + (fun tacopt1 -> + let uu___9 = + unembed FStarC_Syntax_Embeddings.e_bool + use_eq in + FStarC_Compiler_Util.bind_opt uu___9 + (fun use_eq1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Tv_AscribedT + (e1, t2, tacopt1, use_eq1)))))) + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (e, uu___2)::(c, uu___3)::(tacopt, uu___4)::(use_eq, uu___5)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_AscC.FStarC_Reflection_V1_Constants.lid + -> + let uu___6 = unembed e_term e in + FStarC_Compiler_Util.bind_opt uu___6 + (fun e1 -> + let uu___7 = unembed e_comp c in + FStarC_Compiler_Util.bind_opt uu___7 + (fun c1 -> + let uu___8 = + unembed (FStarC_Syntax_Embeddings.e_option e_term) + tacopt in + FStarC_Compiler_Util.bind_opt uu___8 + (fun tacopt1 -> + let uu___9 = + unembed FStarC_Syntax_Embeddings.e_bool + use_eq in + FStarC_Compiler_Util.bind_opt uu___9 + (fun use_eq1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Tv_AscribedC + (e1, c1, tacopt1, use_eq1)))))) + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_Unknown.FStarC_Reflection_V1_Constants.lid + -> + FStar_Pervasives_Native.Some + FStarC_Reflection_V1_Data.Tv_Unknown + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_Unsupp.FStarC_Reflection_V1_Constants.lid + -> + FStar_Pervasives_Native.Some + FStarC_Reflection_V1_Data.Tv_Unsupp + | uu___2 -> FStar_Pervasives_Native.None) in + mk_emb embed_term_view unembed_term_view + FStarC_Reflection_V1_Constants.fstar_refl_term_view +let (e_term_view : + FStarC_Reflection_V1_Data.term_view FStarC_Syntax_Embeddings_Base.embedding) + = e_term_view_aq noaqs +let (e_name : + Prims.string Prims.list FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Syntax_Embeddings.e_list FStarC_Syntax_Embeddings.e_string +let (e_bv_view : + FStarC_Reflection_V1_Data.bv_view FStarC_Syntax_Embeddings_Base.embedding) + = + let embed_bv_view rng bvv = + let uu___ = + let uu___1 = + let uu___2 = + embed + (FStarC_Syntax_Embeddings.e_sealed + FStarC_Syntax_Embeddings.e_string) rng + bvv.FStarC_Reflection_V1_Data.bv_ppname in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + embed FStarC_Syntax_Embeddings.e_int rng + bvv.FStarC_Reflection_V1_Data.bv_index in + FStarC_Syntax_Syntax.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_Mk_bv.FStarC_Reflection_V1_Constants.t + uu___ rng in + let unembed_bv_view t = + let t1 = FStarC_Syntax_Util.unascribe t in + let uu___ = FStarC_Syntax_Util.head_and_args t1 in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst hd in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, (nm, uu___2)::(idx, uu___3)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Mk_bv.FStarC_Reflection_V1_Constants.lid + -> + let uu___4 = + unembed + (FStarC_Syntax_Embeddings.e_sealed + FStarC_Syntax_Embeddings.e_string) nm in + FStarC_Compiler_Util.bind_opt uu___4 + (fun nm1 -> + let uu___5 = unembed FStarC_Syntax_Embeddings.e_int idx in + FStarC_Compiler_Util.bind_opt uu___5 + (fun idx1 -> + FStar_Pervasives_Native.Some + { + FStarC_Reflection_V1_Data.bv_ppname = nm1; + FStarC_Reflection_V1_Data.bv_index = idx1 + })) + | uu___2 -> FStar_Pervasives_Native.None) in + mk_emb embed_bv_view unembed_bv_view + FStarC_Reflection_V1_Constants.fstar_refl_bv_view +let (e_attribute : + FStarC_Syntax_Syntax.attribute FStarC_Syntax_Embeddings_Base.embedding) = + e_term +let (e_attributes : + FStarC_Syntax_Syntax.attribute Prims.list + FStarC_Syntax_Embeddings_Base.embedding) + = FStarC_Syntax_Embeddings.e_list e_attribute +let (e_binder_view : + FStarC_Reflection_V1_Data.binder_view + FStarC_Syntax_Embeddings_Base.embedding) + = + let embed_binder_view rng bview = + let uu___ = + let uu___1 = + let uu___2 = embed e_bv rng bview.FStarC_Reflection_V1_Data.binder_bv in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + embed e_aqualv rng bview.FStarC_Reflection_V1_Data.binder_qual in + FStarC_Syntax_Syntax.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + embed e_attributes rng + bview.FStarC_Reflection_V1_Data.binder_attrs in + FStarC_Syntax_Syntax.as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + embed e_term rng bview.FStarC_Reflection_V1_Data.binder_sort in + FStarC_Syntax_Syntax.as_arg uu___8 in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_Mk_binder.FStarC_Reflection_V1_Constants.t + uu___ rng in + let unembed_binder_view t = + let t1 = FStarC_Syntax_Util.unascribe t in + let uu___ = FStarC_Syntax_Util.head_and_args t1 in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst hd in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (bv, uu___2)::(q, uu___3)::(attrs, uu___4)::(sort, uu___5)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Mk_binder.FStarC_Reflection_V1_Constants.lid + -> + let uu___6 = unembed e_bv bv in + FStarC_Compiler_Util.bind_opt uu___6 + (fun bv1 -> + let uu___7 = unembed e_aqualv q in + FStarC_Compiler_Util.bind_opt uu___7 + (fun q1 -> + let uu___8 = unembed e_attributes attrs in + FStarC_Compiler_Util.bind_opt uu___8 + (fun attrs1 -> + let uu___9 = unembed e_term sort in + FStarC_Compiler_Util.bind_opt uu___9 + (fun sort1 -> + FStar_Pervasives_Native.Some + { + FStarC_Reflection_V1_Data.binder_bv = + bv1; + FStarC_Reflection_V1_Data.binder_qual = + q1; + FStarC_Reflection_V1_Data.binder_attrs = + attrs1; + FStarC_Reflection_V1_Data.binder_sort = + sort1 + })))) + | uu___2 -> FStar_Pervasives_Native.None) in + mk_emb embed_binder_view unembed_binder_view + FStarC_Reflection_V1_Constants.fstar_refl_binder_view +let (e_comp_view : + FStarC_Reflection_V1_Data.comp_view FStarC_Syntax_Embeddings_Base.embedding) + = + let embed_comp_view rng cv = + match cv with + | FStarC_Reflection_V1_Data.C_Total t -> + let uu___ = + let uu___1 = + let uu___2 = embed e_term rng t in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_C_Total.FStarC_Reflection_V1_Constants.t + uu___ rng + | FStarC_Reflection_V1_Data.C_GTotal t -> + let uu___ = + let uu___1 = + let uu___2 = embed e_term rng t in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_C_GTotal.FStarC_Reflection_V1_Constants.t + uu___ rng + | FStarC_Reflection_V1_Data.C_Lemma (pre, post, pats) -> + let uu___ = + let uu___1 = + let uu___2 = embed e_term rng pre in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = embed e_term rng post in + FStarC_Syntax_Syntax.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = embed e_term rng pats in + FStarC_Syntax_Syntax.as_arg uu___6 in + [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_C_Lemma.FStarC_Reflection_V1_Constants.t + uu___ rng + | FStarC_Reflection_V1_Data.C_Eff (us, eff, res, args, decrs) -> + let uu___ = + let uu___1 = + let uu___2 = + embed + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_universe) rng us in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + embed FStarC_Syntax_Embeddings.e_string_list rng eff in + FStarC_Syntax_Syntax.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = embed e_term rng res in + FStarC_Syntax_Syntax.as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + embed (FStarC_Syntax_Embeddings.e_list e_argv) rng args in + FStarC_Syntax_Syntax.as_arg uu___8 in + let uu___8 = + let uu___9 = + let uu___10 = + embed (FStarC_Syntax_Embeddings.e_list e_term) rng + decrs in + FStarC_Syntax_Syntax.as_arg uu___10 in + [uu___9] in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_C_Eff.FStarC_Reflection_V1_Constants.t + uu___ rng in + let unembed_comp_view t = + let t1 = FStarC_Syntax_Util.unascribe t in + let uu___ = FStarC_Syntax_Util.head_and_args t1 in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst hd in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, (t2, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_C_Total.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = unembed e_term t2 in + FStarC_Compiler_Util.bind_opt uu___3 + (fun t3 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.C_Total t3)) + | (FStarC_Syntax_Syntax.Tm_fvar fv, (t2, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_C_GTotal.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = unembed e_term t2 in + FStarC_Compiler_Util.bind_opt uu___3 + (fun t3 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.C_GTotal t3)) + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (pre, uu___2)::(post, uu___3)::(pats, uu___4)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_C_Lemma.FStarC_Reflection_V1_Constants.lid + -> + let uu___5 = unembed e_term pre in + FStarC_Compiler_Util.bind_opt uu___5 + (fun pre1 -> + let uu___6 = unembed e_term post in + FStarC_Compiler_Util.bind_opt uu___6 + (fun post1 -> + let uu___7 = unembed e_term pats in + FStarC_Compiler_Util.bind_opt uu___7 + (fun pats1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.C_Lemma + (pre1, post1, pats1))))) + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (us, uu___2)::(eff, uu___3)::(res, uu___4)::(args1, uu___5):: + (decrs, uu___6)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_C_Eff.FStarC_Reflection_V1_Constants.lid + -> + let uu___7 = + unembed + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_universe) us in + FStarC_Compiler_Util.bind_opt uu___7 + (fun us1 -> + let uu___8 = + unembed FStarC_Syntax_Embeddings.e_string_list eff in + FStarC_Compiler_Util.bind_opt uu___8 + (fun eff1 -> + let uu___9 = unembed e_term res in + FStarC_Compiler_Util.bind_opt uu___9 + (fun res1 -> + let uu___10 = + unembed + (FStarC_Syntax_Embeddings.e_list e_argv) + args1 in + FStarC_Compiler_Util.bind_opt uu___10 + (fun args2 -> + let uu___11 = + unembed + (FStarC_Syntax_Embeddings.e_list e_term) + decrs in + FStarC_Compiler_Util.bind_opt uu___11 + (fun decrs1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.C_Eff + (us1, eff1, res1, args2, decrs1))))))) + | uu___2 -> FStar_Pervasives_Native.None) in + mk_emb embed_comp_view unembed_comp_view + FStarC_Reflection_V1_Constants.fstar_refl_comp_view +let (e_sigelt : + FStarC_Syntax_Syntax.sigelt FStarC_Syntax_Embeddings_Base.embedding) = + let embed_sigelt rng se = + FStarC_Syntax_Util.mk_lazy se + FStarC_Reflection_V1_Constants.fstar_refl_sigelt + FStarC_Syntax_Syntax.Lazy_sigelt (FStar_Pervasives_Native.Some rng) in + let unembed_sigelt t = + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_lazy + { FStarC_Syntax_Syntax.blob = b; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_sigelt; + FStarC_Syntax_Syntax.ltyp = uu___1; + FStarC_Syntax_Syntax.rng = uu___2;_} + -> + let uu___3 = FStarC_Dyn.undyn b in + FStar_Pervasives_Native.Some uu___3 + | uu___1 -> FStar_Pervasives_Native.None in + mk_emb embed_sigelt unembed_sigelt + FStarC_Reflection_V1_Constants.fstar_refl_sigelt +let (e_univ_name : + FStarC_Reflection_V1_Data.univ_name FStarC_Syntax_Embeddings_Base.embedding) + = + FStarC_Syntax_Embeddings_Base.set_type + FStarC_Reflection_V1_Constants.fstar_refl_univ_name e_ident +let (e_lb_view : + FStarC_Reflection_V1_Data.lb_view FStarC_Syntax_Embeddings_Base.embedding) + = + let embed_lb_view rng lbv = + let uu___ = + let uu___1 = + let uu___2 = + embed FStarC_Reflection_V2_Embeddings.e_fv rng + lbv.FStarC_Reflection_V1_Data.lb_fv in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + embed (FStarC_Syntax_Embeddings.e_list e_ident) rng + lbv.FStarC_Reflection_V1_Data.lb_us in + FStarC_Syntax_Syntax.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + embed e_term rng lbv.FStarC_Reflection_V1_Data.lb_typ in + FStarC_Syntax_Syntax.as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + embed e_term rng lbv.FStarC_Reflection_V1_Data.lb_def in + FStarC_Syntax_Syntax.as_arg uu___8 in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_Mk_lb.FStarC_Reflection_V1_Constants.t + uu___ rng in + let unembed_lb_view t = + let t1 = FStarC_Syntax_Util.unascribe t in + let uu___ = FStarC_Syntax_Util.head_and_args t1 in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst hd in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (fv', uu___2)::(us, uu___3)::(typ, uu___4)::(def, uu___5)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Mk_lb.FStarC_Reflection_V1_Constants.lid + -> + let uu___6 = unembed FStarC_Reflection_V2_Embeddings.e_fv fv' in + FStarC_Compiler_Util.bind_opt uu___6 + (fun fv'1 -> + let uu___7 = + unembed (FStarC_Syntax_Embeddings.e_list e_ident) us in + FStarC_Compiler_Util.bind_opt uu___7 + (fun us1 -> + let uu___8 = unembed e_term typ in + FStarC_Compiler_Util.bind_opt uu___8 + (fun typ1 -> + let uu___9 = unembed e_term def in + FStarC_Compiler_Util.bind_opt uu___9 + (fun def1 -> + FStar_Pervasives_Native.Some + { + FStarC_Reflection_V1_Data.lb_fv = fv'1; + FStarC_Reflection_V1_Data.lb_us = us1; + FStarC_Reflection_V1_Data.lb_typ = typ1; + FStarC_Reflection_V1_Data.lb_def = def1 + })))) + | uu___2 -> FStar_Pervasives_Native.None) in + mk_emb embed_lb_view unembed_lb_view + FStarC_Reflection_V1_Constants.fstar_refl_lb_view +let (e_letbinding : + FStarC_Syntax_Syntax.letbinding FStarC_Syntax_Embeddings_Base.embedding) = + let embed_letbinding rng lb = + FStarC_Syntax_Util.mk_lazy lb + FStarC_Reflection_V1_Constants.fstar_refl_letbinding + FStarC_Syntax_Syntax.Lazy_letbinding (FStar_Pervasives_Native.Some rng) in + let unembed_letbinding t = + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_lazy + { FStarC_Syntax_Syntax.blob = lb; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_letbinding; + FStarC_Syntax_Syntax.ltyp = uu___1; + FStarC_Syntax_Syntax.rng = uu___2;_} + -> + let uu___3 = FStarC_Dyn.undyn lb in + FStar_Pervasives_Native.Some uu___3 + | uu___1 -> FStar_Pervasives_Native.None in + mk_emb embed_letbinding unembed_letbinding + FStarC_Reflection_V1_Constants.fstar_refl_letbinding +let (e_ctor : + FStarC_Reflection_V1_Data.ctor FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_list FStarC_Syntax_Embeddings.e_string) + e_term +let (e_sigelt_view : + FStarC_Reflection_V1_Data.sigelt_view + FStarC_Syntax_Embeddings_Base.embedding) + = + let embed_sigelt_view rng sev = + match sev with + | FStarC_Reflection_V1_Data.Sg_Let (r, lbs) -> + let uu___ = + let uu___1 = + let uu___2 = embed FStarC_Syntax_Embeddings.e_bool rng r in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + embed + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_letbinding) rng lbs in + FStarC_Syntax_Syntax.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_Sg_Let.FStarC_Reflection_V1_Constants.t + uu___ rng + | FStarC_Reflection_V1_Data.Sg_Inductive (nm, univs, bs, t, dcs) -> + let uu___ = + let uu___1 = + let uu___2 = embed FStarC_Syntax_Embeddings.e_string_list rng nm in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + embed (FStarC_Syntax_Embeddings.e_list e_ident) rng univs in + FStarC_Syntax_Syntax.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + embed FStarC_Reflection_V2_Embeddings.e_binders rng bs in + FStarC_Syntax_Syntax.as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = embed e_term rng t in + FStarC_Syntax_Syntax.as_arg uu___8 in + let uu___8 = + let uu___9 = + let uu___10 = + embed (FStarC_Syntax_Embeddings.e_list e_ctor) rng dcs in + FStarC_Syntax_Syntax.as_arg uu___10 in + [uu___9] in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_Sg_Inductive.FStarC_Reflection_V1_Constants.t + uu___ rng + | FStarC_Reflection_V1_Data.Sg_Val (nm, univs, t) -> + let uu___ = + let uu___1 = + let uu___2 = embed FStarC_Syntax_Embeddings.e_string_list rng nm in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + embed (FStarC_Syntax_Embeddings.e_list e_ident) rng univs in + FStarC_Syntax_Syntax.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = embed e_term rng t in + FStarC_Syntax_Syntax.as_arg uu___6 in + [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_Sg_Val.FStarC_Reflection_V1_Constants.t + uu___ rng + | FStarC_Reflection_V1_Data.Unk -> + let uu___ = + FStarC_Reflection_V1_Constants.ref_Unk.FStarC_Reflection_V1_Constants.t in + { + FStarC_Syntax_Syntax.n = (uu___.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = rng; + FStarC_Syntax_Syntax.vars = (uu___.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (uu___.FStarC_Syntax_Syntax.hash_code) + } in + let unembed_sigelt_view t = + let t1 = FStarC_Syntax_Util.unascribe t in + let uu___ = FStarC_Syntax_Util.head_and_args t1 in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst hd in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (nm, uu___2)::(us, uu___3)::(bs, uu___4)::(t2, uu___5)::(dcs, + uu___6)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Sg_Inductive.FStarC_Reflection_V1_Constants.lid + -> + let uu___7 = unembed FStarC_Syntax_Embeddings.e_string_list nm in + FStarC_Compiler_Util.bind_opt uu___7 + (fun nm1 -> + let uu___8 = + unembed (FStarC_Syntax_Embeddings.e_list e_ident) us in + FStarC_Compiler_Util.bind_opt uu___8 + (fun us1 -> + let uu___9 = + unembed FStarC_Reflection_V2_Embeddings.e_binders bs in + FStarC_Compiler_Util.bind_opt uu___9 + (fun bs1 -> + let uu___10 = unembed e_term t2 in + FStarC_Compiler_Util.bind_opt uu___10 + (fun t3 -> + let uu___11 = + unembed + (FStarC_Syntax_Embeddings.e_list e_ctor) + dcs in + FStarC_Compiler_Util.bind_opt uu___11 + (fun dcs1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Sg_Inductive + (nm1, us1, bs1, t3, dcs1))))))) + | (FStarC_Syntax_Syntax.Tm_fvar fv, (r, uu___2)::(lbs, uu___3)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Sg_Let.FStarC_Reflection_V1_Constants.lid + -> + let uu___4 = unembed FStarC_Syntax_Embeddings.e_bool r in + FStarC_Compiler_Util.bind_opt uu___4 + (fun r1 -> + let uu___5 = + unembed + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_letbinding) lbs in + FStarC_Compiler_Util.bind_opt uu___5 + (fun lbs1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Sg_Let (r1, lbs1)))) + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (nm, uu___2)::(us, uu___3)::(t2, uu___4)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Sg_Val.FStarC_Reflection_V1_Constants.lid + -> + let uu___5 = unembed FStarC_Syntax_Embeddings.e_string_list nm in + FStarC_Compiler_Util.bind_opt uu___5 + (fun nm1 -> + let uu___6 = + unembed (FStarC_Syntax_Embeddings.e_list e_ident) us in + FStarC_Compiler_Util.bind_opt uu___6 + (fun us1 -> + let uu___7 = unembed e_term t2 in + FStarC_Compiler_Util.bind_opt uu___7 + (fun t3 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Sg_Val + (nm1, us1, t3))))) + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Unk.FStarC_Reflection_V1_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.Unk + | uu___2 -> FStar_Pervasives_Native.None) in + mk_emb embed_sigelt_view unembed_sigelt_view + FStarC_Reflection_V1_Constants.fstar_refl_sigelt_view +let (e_qualifier : + FStarC_Reflection_V1_Data.qualifier FStarC_Syntax_Embeddings_Base.embedding) + = + let embed1 rng q = + let r = + match q with + | FStarC_Reflection_V1_Data.Assumption -> + FStarC_Reflection_V1_Constants.ref_qual_Assumption.FStarC_Reflection_V1_Constants.t + | FStarC_Reflection_V1_Data.InternalAssumption -> + FStarC_Reflection_V1_Constants.ref_qual_InternalAssumption.FStarC_Reflection_V1_Constants.t + | FStarC_Reflection_V1_Data.New -> + FStarC_Reflection_V1_Constants.ref_qual_New.FStarC_Reflection_V1_Constants.t + | FStarC_Reflection_V1_Data.Private -> + FStarC_Reflection_V1_Constants.ref_qual_Private.FStarC_Reflection_V1_Constants.t + | FStarC_Reflection_V1_Data.Unfold_for_unification_and_vcgen -> + FStarC_Reflection_V1_Constants.ref_qual_Unfold_for_unification_and_vcgen.FStarC_Reflection_V1_Constants.t + | FStarC_Reflection_V1_Data.Visible_default -> + FStarC_Reflection_V1_Constants.ref_qual_Visible_default.FStarC_Reflection_V1_Constants.t + | FStarC_Reflection_V1_Data.Irreducible -> + FStarC_Reflection_V1_Constants.ref_qual_Irreducible.FStarC_Reflection_V1_Constants.t + | FStarC_Reflection_V1_Data.Inline_for_extraction -> + FStarC_Reflection_V1_Constants.ref_qual_Inline_for_extraction.FStarC_Reflection_V1_Constants.t + | FStarC_Reflection_V1_Data.NoExtract -> + FStarC_Reflection_V1_Constants.ref_qual_NoExtract.FStarC_Reflection_V1_Constants.t + | FStarC_Reflection_V1_Data.Noeq -> + FStarC_Reflection_V1_Constants.ref_qual_Noeq.FStarC_Reflection_V1_Constants.t + | FStarC_Reflection_V1_Data.Unopteq -> + FStarC_Reflection_V1_Constants.ref_qual_Unopteq.FStarC_Reflection_V1_Constants.t + | FStarC_Reflection_V1_Data.TotalEffect -> + FStarC_Reflection_V1_Constants.ref_qual_TotalEffect.FStarC_Reflection_V1_Constants.t + | FStarC_Reflection_V1_Data.Logic -> + FStarC_Reflection_V1_Constants.ref_qual_Logic.FStarC_Reflection_V1_Constants.t + | FStarC_Reflection_V1_Data.Reifiable -> + FStarC_Reflection_V1_Constants.ref_qual_Reifiable.FStarC_Reflection_V1_Constants.t + | FStarC_Reflection_V1_Data.ExceptionConstructor -> + FStarC_Reflection_V1_Constants.ref_qual_ExceptionConstructor.FStarC_Reflection_V1_Constants.t + | FStarC_Reflection_V1_Data.HasMaskedEffect -> + FStarC_Reflection_V1_Constants.ref_qual_HasMaskedEffect.FStarC_Reflection_V1_Constants.t + | FStarC_Reflection_V1_Data.Effect -> + FStarC_Reflection_V1_Constants.ref_qual_Effect.FStarC_Reflection_V1_Constants.t + | FStarC_Reflection_V1_Data.OnlyName -> + FStarC_Reflection_V1_Constants.ref_qual_OnlyName.FStarC_Reflection_V1_Constants.t + | FStarC_Reflection_V1_Data.Reflectable l -> + let uu___ = + let uu___1 = + let uu___2 = embed FStarC_Syntax_Embeddings.e_string_list rng l in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_qual_Reflectable.FStarC_Reflection_V1_Constants.t + uu___ FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V1_Data.Discriminator l -> + let uu___ = + let uu___1 = + let uu___2 = embed FStarC_Syntax_Embeddings.e_string_list rng l in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_qual_Discriminator.FStarC_Reflection_V1_Constants.t + uu___ FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V1_Data.Action l -> + let uu___ = + let uu___1 = + let uu___2 = embed FStarC_Syntax_Embeddings.e_string_list rng l in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_qual_Action.FStarC_Reflection_V1_Constants.t + uu___ FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V1_Data.Projector (l, i) -> + let uu___ = + let uu___1 = + let uu___2 = + embed + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Syntax_Embeddings.e_string_list e_ident) rng + (l, i) in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_qual_Projector.FStarC_Reflection_V1_Constants.t + uu___ FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V1_Data.RecordType (ids1, ids2) -> + let uu___ = + let uu___1 = + let uu___2 = + embed + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_list e_ident) + (FStarC_Syntax_Embeddings.e_list e_ident)) rng + (ids1, ids2) in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_qual_RecordType.FStarC_Reflection_V1_Constants.t + uu___ FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V1_Data.RecordConstructor (ids1, ids2) -> + let uu___ = + let uu___1 = + let uu___2 = + embed + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_list e_ident) + (FStarC_Syntax_Embeddings.e_list e_ident)) rng + (ids1, ids2) in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.ref_qual_RecordConstructor.FStarC_Reflection_V1_Constants.t + uu___ FStarC_Compiler_Range_Type.dummyRange in + { + FStarC_Syntax_Syntax.n = (r.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = rng; + FStarC_Syntax_Syntax.vars = (r.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = (r.FStarC_Syntax_Syntax.hash_code) + } in + let unembed1 t = + let t1 = FStarC_Syntax_Util.unascribe t in + let uu___ = FStarC_Syntax_Util.head_and_args t1 in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst hd in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_Assumption.FStarC_Reflection_V1_Constants.lid + -> + FStar_Pervasives_Native.Some + FStarC_Reflection_V1_Data.Assumption + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_InternalAssumption.FStarC_Reflection_V1_Constants.lid + -> + FStar_Pervasives_Native.Some + FStarC_Reflection_V1_Data.InternalAssumption + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_New.FStarC_Reflection_V1_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.New + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_Private.FStarC_Reflection_V1_Constants.lid + -> + FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.Private + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_Unfold_for_unification_and_vcgen.FStarC_Reflection_V1_Constants.lid + -> + FStar_Pervasives_Native.Some + FStarC_Reflection_V1_Data.Unfold_for_unification_and_vcgen + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_Visible_default.FStarC_Reflection_V1_Constants.lid + -> + FStar_Pervasives_Native.Some + FStarC_Reflection_V1_Data.Visible_default + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_Irreducible.FStarC_Reflection_V1_Constants.lid + -> + FStar_Pervasives_Native.Some + FStarC_Reflection_V1_Data.Irreducible + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_Inline_for_extraction.FStarC_Reflection_V1_Constants.lid + -> + FStar_Pervasives_Native.Some + FStarC_Reflection_V1_Data.Inline_for_extraction + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_NoExtract.FStarC_Reflection_V1_Constants.lid + -> + FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.NoExtract + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_Noeq.FStarC_Reflection_V1_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.Noeq + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_Unopteq.FStarC_Reflection_V1_Constants.lid + -> + FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.Unopteq + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_TotalEffect.FStarC_Reflection_V1_Constants.lid + -> + FStar_Pervasives_Native.Some + FStarC_Reflection_V1_Data.TotalEffect + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_Logic.FStarC_Reflection_V1_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.Logic + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_Reifiable.FStarC_Reflection_V1_Constants.lid + -> + FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.Reifiable + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_ExceptionConstructor.FStarC_Reflection_V1_Constants.lid + -> + FStar_Pervasives_Native.Some + FStarC_Reflection_V1_Data.ExceptionConstructor + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_HasMaskedEffect.FStarC_Reflection_V1_Constants.lid + -> + FStar_Pervasives_Native.Some + FStarC_Reflection_V1_Data.HasMaskedEffect + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_Effect.FStarC_Reflection_V1_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.Effect + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_OnlyName.FStarC_Reflection_V1_Constants.lid + -> + FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.OnlyName + | (FStarC_Syntax_Syntax.Tm_fvar fv, (l, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_Reflectable.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = unembed FStarC_Syntax_Embeddings.e_string_list l in + FStarC_Compiler_Util.bind_opt uu___3 + (fun l1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Reflectable l1)) + | (FStarC_Syntax_Syntax.Tm_fvar fv, (l, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_Discriminator.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = unembed FStarC_Syntax_Embeddings.e_string_list l in + FStarC_Compiler_Util.bind_opt uu___3 + (fun l1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Discriminator l1)) + | (FStarC_Syntax_Syntax.Tm_fvar fv, (l, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_Action.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = unembed FStarC_Syntax_Embeddings.e_string_list l in + FStarC_Compiler_Util.bind_opt uu___3 + (fun l1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Action l1)) + | (FStarC_Syntax_Syntax.Tm_fvar fv, (payload, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_Projector.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = + unembed + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Syntax_Embeddings.e_string_list e_ident) payload in + FStarC_Compiler_Util.bind_opt uu___3 + (fun uu___4 -> + match uu___4 with + | (l, i) -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Projector (l, i))) + | (FStarC_Syntax_Syntax.Tm_fvar fv, (payload, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_RecordType.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = + unembed + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_list e_ident) + (FStarC_Syntax_Embeddings.e_list e_ident)) payload in + FStarC_Compiler_Util.bind_opt uu___3 + (fun uu___4 -> + match uu___4 with + | (ids1, ids2) -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.RecordType (ids1, ids2))) + | (FStarC_Syntax_Syntax.Tm_fvar fv, (payload, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_RecordConstructor.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = + unembed + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_list e_ident) + (FStarC_Syntax_Embeddings.e_list e_ident)) payload in + FStarC_Compiler_Util.bind_opt uu___3 + (fun uu___4 -> + match uu___4 with + | (ids1, ids2) -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.RecordConstructor + (ids1, ids2))) + | uu___2 -> FStar_Pervasives_Native.None) in + mk_emb embed1 unembed1 FStarC_Reflection_V1_Constants.fstar_refl_qualifier +let (e_qualifiers : + FStarC_Reflection_V1_Data.qualifier Prims.list + FStarC_Syntax_Embeddings_Base.embedding) + = FStarC_Syntax_Embeddings.e_list e_qualifier +let (unfold_lazy_bv : + FStarC_Syntax_Syntax.lazyinfo -> FStarC_Syntax_Syntax.term) = + fun i -> + let bv = FStarC_Dyn.undyn i.FStarC_Syntax_Syntax.blob in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Reflection_V1_Builtins.inspect_bv bv in + embed e_bv_view i.FStarC_Syntax_Syntax.rng uu___3 in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.fstar_refl_pack_bv.FStarC_Reflection_V1_Constants.t + uu___ i.FStarC_Syntax_Syntax.rng +let (unfold_lazy_binder : + FStarC_Syntax_Syntax.lazyinfo -> FStarC_Syntax_Syntax.term) = + fun i -> + let binder = FStarC_Dyn.undyn i.FStarC_Syntax_Syntax.blob in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Reflection_V1_Builtins.inspect_binder binder in + embed e_binder_view i.FStarC_Syntax_Syntax.rng uu___3 in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.fstar_refl_pack_binder.FStarC_Reflection_V1_Constants.t + uu___ i.FStarC_Syntax_Syntax.rng +let (unfold_lazy_letbinding : + FStarC_Syntax_Syntax.lazyinfo -> FStarC_Syntax_Syntax.term) = + fun i -> + let lb = FStarC_Dyn.undyn i.FStarC_Syntax_Syntax.blob in + let lbv = FStarC_Reflection_V1_Builtins.inspect_lb lb in + let uu___ = + let uu___1 = + let uu___2 = + embed FStarC_Reflection_V2_Embeddings.e_fv + i.FStarC_Syntax_Syntax.rng lbv.FStarC_Reflection_V1_Data.lb_fv in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + embed (FStarC_Syntax_Embeddings.e_list e_ident) + i.FStarC_Syntax_Syntax.rng lbv.FStarC_Reflection_V1_Data.lb_us in + FStarC_Syntax_Syntax.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + embed e_term i.FStarC_Syntax_Syntax.rng + lbv.FStarC_Reflection_V1_Data.lb_typ in + FStarC_Syntax_Syntax.as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + embed e_term i.FStarC_Syntax_Syntax.rng + lbv.FStarC_Reflection_V1_Data.lb_def in + FStarC_Syntax_Syntax.as_arg uu___8 in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.fstar_refl_pack_lb.FStarC_Reflection_V1_Constants.t + uu___ i.FStarC_Syntax_Syntax.rng +let (unfold_lazy_fvar : + FStarC_Syntax_Syntax.lazyinfo -> FStarC_Syntax_Syntax.term) = + fun i -> + let fv = FStarC_Dyn.undyn i.FStarC_Syntax_Syntax.blob in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Reflection_V1_Builtins.inspect_fv fv in + embed FStarC_Syntax_Embeddings.e_string_list + i.FStarC_Syntax_Syntax.rng uu___3 in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.fstar_refl_pack_fv.FStarC_Reflection_V1_Constants.t + uu___ i.FStarC_Syntax_Syntax.rng +let (unfold_lazy_comp : + FStarC_Syntax_Syntax.lazyinfo -> FStarC_Syntax_Syntax.term) = + fun i -> + let comp = FStarC_Dyn.undyn i.FStarC_Syntax_Syntax.blob in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Reflection_V1_Builtins.inspect_comp comp in + embed e_comp_view i.FStarC_Syntax_Syntax.rng uu___3 in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.fstar_refl_pack_comp.FStarC_Reflection_V1_Constants.t + uu___ i.FStarC_Syntax_Syntax.rng +let (unfold_lazy_env : + FStarC_Syntax_Syntax.lazyinfo -> FStarC_Syntax_Syntax.term) = + fun i -> FStarC_Syntax_Util.exp_unit +let (unfold_lazy_optionstate : + FStarC_Syntax_Syntax.lazyinfo -> FStarC_Syntax_Syntax.term) = + fun i -> FStarC_Syntax_Util.exp_unit +let (unfold_lazy_sigelt : + FStarC_Syntax_Syntax.lazyinfo -> FStarC_Syntax_Syntax.term) = + fun i -> + let sigelt = FStarC_Dyn.undyn i.FStarC_Syntax_Syntax.blob in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Reflection_V1_Builtins.inspect_sigelt sigelt in + embed e_sigelt_view i.FStarC_Syntax_Syntax.rng uu___3 in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.fstar_refl_pack_sigelt.FStarC_Reflection_V1_Constants.t + uu___ i.FStarC_Syntax_Syntax.rng +let (unfold_lazy_universe : + FStarC_Syntax_Syntax.lazyinfo -> FStarC_Syntax_Syntax.term) = + fun i -> + let u = FStarC_Dyn.undyn i.FStarC_Syntax_Syntax.blob in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Reflection_V1_Builtins.inspect_universe u in + embed e_universe_view i.FStarC_Syntax_Syntax.rng uu___3 in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V1_Constants.fstar_refl_pack_universe.FStarC_Reflection_V1_Constants.t + uu___ i.FStarC_Syntax_Syntax.rng \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Reflection_V1_Interpreter.ml b/ocaml/fstar-lib/generated/FStarC_Reflection_V1_Interpreter.ml new file mode 100644 index 00000000000..8b2db5db7c5 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Reflection_V1_Interpreter.ml @@ -0,0 +1,562 @@ +open Prims +let mk1 : + 'res 't1 . + Prims.string -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 'res FStarC_Syntax_Embeddings_Base.embedding -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 'res FStarC_TypeChecker_NBETerm.embedding -> + ('t1 -> 'res) -> FStarC_TypeChecker_Primops_Base.primitive_step + = + fun nm -> + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun f -> + let lid = + FStarC_Reflection_V1_Constants.fstar_refl_builtins_lid nm in + FStarC_TypeChecker_Primops_Base.mk1' Prims.int_zero lid uu___ + uu___2 uu___1 uu___3 + (fun x -> + let uu___4 = f x in FStar_Pervasives_Native.Some uu___4) + (fun x -> + let uu___4 = f x in FStar_Pervasives_Native.Some uu___4) +let mk2 : + 'res 't1 't2 . + Prims.string -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 'res FStarC_Syntax_Embeddings_Base.embedding -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 'res FStarC_TypeChecker_NBETerm.embedding -> + ('t1 -> 't2 -> 'res) -> + FStarC_TypeChecker_Primops_Base.primitive_step + = + fun nm -> + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun uu___4 -> + fun uu___5 -> + fun f -> + let lid = + FStarC_Reflection_V1_Constants.fstar_refl_builtins_lid nm in + FStarC_TypeChecker_Primops_Base.mk2' Prims.int_zero lid + uu___ uu___3 uu___1 uu___4 uu___2 uu___5 + (fun x -> + fun y -> + let uu___6 = f x y in + FStar_Pervasives_Native.Some uu___6) + (fun x -> + fun y -> + let uu___6 = f x y in + FStar_Pervasives_Native.Some uu___6) +let mk3 : + 'res 't1 't2 't3 . + Prims.string -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 'res FStarC_Syntax_Embeddings_Base.embedding -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 'res FStarC_TypeChecker_NBETerm.embedding -> + ('t1 -> 't2 -> 't3 -> 'res) -> + FStarC_TypeChecker_Primops_Base.primitive_step + = + fun nm -> + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun uu___4 -> + fun uu___5 -> + fun uu___6 -> + fun uu___7 -> + fun f -> + let lid = + FStarC_Reflection_V1_Constants.fstar_refl_builtins_lid + nm in + FStarC_TypeChecker_Primops_Base.mk3' Prims.int_zero lid + uu___ uu___4 uu___1 uu___5 uu___2 uu___6 uu___3 + uu___7 + (fun x -> + fun y -> + fun z -> + let uu___8 = f x y z in + FStar_Pervasives_Native.Some uu___8) + (fun x -> + fun y -> + fun z -> + let uu___8 = f x y z in + FStar_Pervasives_Native.Some uu___8) +let (uu___0 : + FStarC_Syntax_Syntax.term FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Reflection_V1_Embeddings.e_term +let (uu___1 : + FStarC_Reflection_V1_Data.term_view FStarC_Syntax_Embeddings_Base.embedding) + = FStarC_Reflection_V1_Embeddings.e_term_view +let (uu___2 : + FStarC_Syntax_Syntax.fv FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Reflection_V1_Embeddings.e_fv +let (uu___3 : + FStarC_Syntax_Syntax.bv FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Reflection_V1_Embeddings.e_bv +let (uu___4 : + FStarC_Reflection_V1_Data.bv_view FStarC_Syntax_Embeddings_Base.embedding) + = FStarC_Reflection_V1_Embeddings.e_bv_view +let (uu___5 : + FStarC_Syntax_Syntax.comp FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Reflection_V1_Embeddings.e_comp +let (uu___6 : + FStarC_Reflection_V1_Data.comp_view FStarC_Syntax_Embeddings_Base.embedding) + = FStarC_Reflection_V1_Embeddings.e_comp_view +let (uu___7 : + FStarC_Syntax_Syntax.universe FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Reflection_V1_Embeddings.e_universe +let (uu___8 : + FStarC_Reflection_V1_Data.universe_view + FStarC_Syntax_Embeddings_Base.embedding) + = FStarC_Reflection_V1_Embeddings.e_universe_view +let (uu___9 : + FStarC_Syntax_Syntax.sigelt FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Reflection_V1_Embeddings.e_sigelt +let (uu___10 : + FStarC_Reflection_V1_Data.sigelt_view + FStarC_Syntax_Embeddings_Base.embedding) + = FStarC_Reflection_V1_Embeddings.e_sigelt_view +let (uu___11 : + FStarC_Syntax_Syntax.binder FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Reflection_V1_Embeddings.e_binder +let (uu___12 : + FStarC_Reflection_V1_Data.binder_view + FStarC_Syntax_Embeddings_Base.embedding) + = FStarC_Reflection_V1_Embeddings.e_binder_view +let (uu___13 : + FStarC_Reflection_V1_Data.binders FStarC_Syntax_Embeddings_Base.embedding) + = FStarC_Reflection_V1_Embeddings.e_binders +let (uu___14 : + FStarC_Syntax_Syntax.letbinding FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Reflection_V1_Embeddings.e_letbinding +let (uu___15 : + FStarC_Reflection_V1_Data.lb_view FStarC_Syntax_Embeddings_Base.embedding) + = FStarC_Reflection_V1_Embeddings.e_lb_view +let (uu___16 : + FStarC_TypeChecker_Env.env FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Reflection_V1_Embeddings.e_env +let (uu___17 : + FStarC_Reflection_V1_Data.aqualv FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Reflection_V1_Embeddings.e_aqualv +let (uu___18 : + FStarC_Syntax_Syntax.attribute Prims.list + FStarC_Syntax_Embeddings_Base.embedding) + = FStarC_Reflection_V1_Embeddings.e_attributes +let (uu___19 : + FStarC_Reflection_V1_Data.qualifier Prims.list + FStarC_Syntax_Embeddings_Base.embedding) + = FStarC_Reflection_V1_Embeddings.e_qualifiers +let (uu___20 : + FStarC_Syntax_Syntax.term FStarC_TypeChecker_NBETerm.embedding) = + FStarC_Reflection_V1_NBEEmbeddings.e_term +let (uu___21 : + FStarC_Reflection_V1_Data.term_view FStarC_TypeChecker_NBETerm.embedding) = + FStarC_Reflection_V1_NBEEmbeddings.e_term_view +let (uu___22 : FStarC_Syntax_Syntax.fv FStarC_TypeChecker_NBETerm.embedding) + = FStarC_Reflection_V1_NBEEmbeddings.e_fv +let (uu___23 : FStarC_Syntax_Syntax.bv FStarC_TypeChecker_NBETerm.embedding) + = FStarC_Reflection_V1_NBEEmbeddings.e_bv +let (uu___24 : + FStarC_Reflection_V1_Data.bv_view FStarC_TypeChecker_NBETerm.embedding) = + FStarC_Reflection_V1_NBEEmbeddings.e_bv_view +let (uu___25 : + FStarC_Syntax_Syntax.comp FStarC_TypeChecker_NBETerm.embedding) = + FStarC_Reflection_V1_NBEEmbeddings.e_comp +let (uu___26 : + FStarC_Reflection_V1_Data.comp_view FStarC_TypeChecker_NBETerm.embedding) = + FStarC_Reflection_V1_NBEEmbeddings.e_comp_view +let (uu___27 : + FStarC_Syntax_Syntax.universe FStarC_TypeChecker_NBETerm.embedding) = + FStarC_Reflection_V1_NBEEmbeddings.e_universe +let (uu___28 : + FStarC_Reflection_V1_Data.universe_view + FStarC_TypeChecker_NBETerm.embedding) + = FStarC_Reflection_V1_NBEEmbeddings.e_universe_view +let (uu___29 : + FStarC_Syntax_Syntax.sigelt FStarC_TypeChecker_NBETerm.embedding) = + FStarC_Reflection_V1_NBEEmbeddings.e_sigelt +let (uu___30 : + FStarC_Reflection_V1_Data.sigelt_view FStarC_TypeChecker_NBETerm.embedding) + = FStarC_Reflection_V1_NBEEmbeddings.e_sigelt_view +let (uu___31 : + FStarC_Syntax_Syntax.binder FStarC_TypeChecker_NBETerm.embedding) = + FStarC_Reflection_V1_NBEEmbeddings.e_binder +let (uu___32 : + FStarC_Reflection_V1_Data.binder_view FStarC_TypeChecker_NBETerm.embedding) + = FStarC_Reflection_V1_NBEEmbeddings.e_binder_view +let (uu___33 : + FStarC_Reflection_V1_Data.binders FStarC_TypeChecker_NBETerm.embedding) = + FStarC_Reflection_V1_NBEEmbeddings.e_binders +let (uu___34 : + FStarC_Syntax_Syntax.letbinding FStarC_TypeChecker_NBETerm.embedding) = + FStarC_Reflection_V1_NBEEmbeddings.e_letbinding +let (uu___35 : + FStarC_Reflection_V1_Data.lb_view FStarC_TypeChecker_NBETerm.embedding) = + FStarC_Reflection_V1_NBEEmbeddings.e_lb_view +let (uu___36 : + FStarC_TypeChecker_Env.env FStarC_TypeChecker_NBETerm.embedding) = + FStarC_Reflection_V1_NBEEmbeddings.e_env +let (uu___37 : + FStarC_Reflection_V1_Data.aqualv FStarC_TypeChecker_NBETerm.embedding) = + FStarC_Reflection_V1_NBEEmbeddings.e_aqualv +let (uu___38 : + FStarC_Syntax_Syntax.attribute Prims.list + FStarC_TypeChecker_NBETerm.embedding) + = FStarC_Reflection_V1_NBEEmbeddings.e_attributes +let (uu___39 : + FStarC_Reflection_V1_Data.qualifier Prims.list + FStarC_TypeChecker_NBETerm.embedding) + = FStarC_Reflection_V1_NBEEmbeddings.e_qualifiers +let (reflection_primops : + FStarC_TypeChecker_Primops_Base.primitive_step Prims.list) = + let uu___ = + mk1 "inspect_ln" uu___0 uu___1 uu___20 uu___21 + FStarC_Reflection_V1_Builtins.inspect_ln in + let uu___40 = + let uu___41 = + mk1 "pack_ln" uu___1 uu___0 uu___21 uu___20 + FStarC_Reflection_V1_Builtins.pack_ln in + let uu___42 = + let uu___43 = + mk1 "inspect_fv" uu___2 FStarC_Syntax_Embeddings.e_string_list + uu___22 FStarC_TypeChecker_NBETerm.e_string_list + FStarC_Reflection_V1_Builtins.inspect_fv in + let uu___44 = + let uu___45 = + mk1 "pack_fv" FStarC_Syntax_Embeddings.e_string_list uu___2 + FStarC_TypeChecker_NBETerm.e_string_list uu___22 + FStarC_Reflection_V1_Builtins.pack_fv in + let uu___46 = + let uu___47 = + mk1 "inspect_comp" uu___5 uu___6 uu___25 uu___26 + FStarC_Reflection_V1_Builtins.inspect_comp in + let uu___48 = + let uu___49 = + mk1 "pack_comp" uu___6 uu___5 uu___26 uu___25 + FStarC_Reflection_V1_Builtins.pack_comp in + let uu___50 = + let uu___51 = + mk1 "inspect_universe" uu___7 uu___8 uu___27 uu___28 + FStarC_Reflection_V1_Builtins.inspect_universe in + let uu___52 = + let uu___53 = + mk1 "pack_universe" uu___8 uu___7 uu___28 uu___27 + FStarC_Reflection_V1_Builtins.pack_universe in + let uu___54 = + let uu___55 = + mk1 "inspect_sigelt" uu___9 uu___10 uu___29 uu___30 + FStarC_Reflection_V1_Builtins.inspect_sigelt in + let uu___56 = + let uu___57 = + mk1 "pack_sigelt" uu___10 uu___9 uu___30 uu___29 + FStarC_Reflection_V1_Builtins.pack_sigelt in + let uu___58 = + let uu___59 = + mk1 "inspect_lb" uu___14 uu___15 uu___34 uu___35 + FStarC_Reflection_V1_Builtins.inspect_lb in + let uu___60 = + let uu___61 = + mk1 "pack_lb" uu___15 uu___14 uu___35 uu___34 + FStarC_Reflection_V1_Builtins.pack_lb in + let uu___62 = + let uu___63 = + mk1 "inspect_bv" uu___3 uu___4 uu___23 uu___24 + FStarC_Reflection_V1_Builtins.inspect_bv in + let uu___64 = + let uu___65 = + mk1 "pack_bv" uu___4 uu___3 uu___24 uu___23 + FStarC_Reflection_V1_Builtins.pack_bv in + let uu___66 = + let uu___67 = + mk1 "inspect_binder" uu___11 uu___12 uu___31 + uu___32 + FStarC_Reflection_V1_Builtins.inspect_binder in + let uu___68 = + let uu___69 = + mk1 "pack_binder" uu___12 uu___11 uu___32 + uu___31 + FStarC_Reflection_V1_Builtins.pack_binder in + let uu___70 = + let uu___71 = + mk1 "sigelt_opts" uu___9 + (FStarC_Syntax_Embeddings.e_option + FStarC_Syntax_Embeddings.e_vconfig) + uu___29 + (FStarC_TypeChecker_NBETerm.e_option + FStarC_TypeChecker_NBETerm.e_vconfig) + FStarC_Reflection_V1_Builtins.sigelt_opts in + let uu___72 = + let uu___73 = + mk1 "embed_vconfig" + FStarC_Syntax_Embeddings.e_vconfig + uu___0 + FStarC_TypeChecker_NBETerm.e_vconfig + uu___20 + FStarC_Reflection_V1_Builtins.embed_vconfig in + let uu___74 = + let uu___75 = + mk1 "sigelt_attrs" uu___9 uu___18 + uu___29 uu___38 + FStarC_Reflection_V1_Builtins.sigelt_attrs in + let uu___76 = + let uu___77 = + mk2 "set_sigelt_attrs" uu___18 + uu___9 uu___9 uu___38 uu___29 + uu___29 + FStarC_Reflection_V1_Builtins.set_sigelt_attrs in + let uu___78 = + let uu___79 = + mk1 "sigelt_quals" uu___9 uu___19 + uu___29 uu___39 + FStarC_Reflection_V1_Builtins.sigelt_quals in + let uu___80 = + let uu___81 = + mk2 "set_sigelt_quals" uu___19 + uu___9 uu___9 uu___39 uu___29 + uu___29 + FStarC_Reflection_V1_Builtins.set_sigelt_quals in + let uu___82 = + let uu___83 = + mk3 "subst" uu___3 uu___0 + uu___0 uu___0 uu___23 + uu___20 uu___20 uu___20 + FStarC_Reflection_V1_Builtins.subst in + let uu___84 = + let uu___85 = + mk2 "close_term" uu___11 + uu___0 uu___0 uu___31 + uu___20 uu___20 + FStarC_Reflection_V1_Builtins.close_term in + let uu___86 = + let uu___87 = + mk2 "compare_bv" uu___3 + uu___3 + FStarC_Syntax_Embeddings.e_order + uu___23 uu___23 + FStarC_TypeChecker_NBETerm.e_order + FStarC_Reflection_V1_Builtins.compare_bv in + let uu___88 = + let uu___89 = + mk2 "lookup_attr" + uu___0 uu___16 + (FStarC_Syntax_Embeddings.e_list + uu___2) uu___20 + uu___36 + (FStarC_TypeChecker_NBETerm.e_list + uu___22) + FStarC_Reflection_V1_Builtins.lookup_attr in + let uu___90 = + let uu___91 = + mk1 "all_defs_in_env" + uu___16 + (FStarC_Syntax_Embeddings.e_list + uu___2) uu___36 + (FStarC_TypeChecker_NBETerm.e_list + uu___22) + FStarC_Reflection_V1_Builtins.all_defs_in_env in + let uu___92 = + let uu___93 = + mk2 + "defs_in_module" + uu___16 + FStarC_Syntax_Embeddings.e_string_list + (FStarC_Syntax_Embeddings.e_list + uu___2) + uu___36 + FStarC_TypeChecker_NBETerm.e_string_list + (FStarC_TypeChecker_NBETerm.e_list + uu___22) + FStarC_Reflection_V1_Builtins.defs_in_module in + let uu___94 = + let uu___95 = + mk2 "term_eq" + uu___0 uu___0 + FStarC_Syntax_Embeddings.e_bool + uu___20 uu___20 + FStarC_TypeChecker_NBETerm.e_bool + FStarC_Reflection_V1_Builtins.term_eq in + let uu___96 = + let uu___97 = + mk1 "moduleof" + uu___16 + FStarC_Syntax_Embeddings.e_string_list + uu___36 + FStarC_TypeChecker_NBETerm.e_string_list + FStarC_Reflection_V1_Builtins.moduleof in + let uu___98 = + let uu___99 = + mk1 + "binders_of_env" + uu___16 + uu___13 + uu___36 + uu___33 + FStarC_Reflection_V1_Builtins.binders_of_env in + let uu___100 = + let uu___101 + = + mk2 + "lookup_typ" + uu___16 + FStarC_Syntax_Embeddings.e_string_list + ( + FStarC_Syntax_Embeddings.e_option + uu___9) + uu___36 + FStarC_TypeChecker_NBETerm.e_string_list + ( + FStarC_TypeChecker_NBETerm.e_option + uu___29) + FStarC_Reflection_V1_Builtins.lookup_typ in + let uu___102 + = + let uu___103 + = + mk1 + "env_open_modules" + uu___16 + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_string_list) + uu___36 + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_string_list) + FStarC_Reflection_V1_Builtins.env_open_modules in + let uu___104 + = + let uu___105 + = + mk1 + "implode_qn" + FStarC_Syntax_Embeddings.e_string_list + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string_list + FStarC_TypeChecker_NBETerm.e_string + FStarC_Reflection_V1_Builtins.implode_qn in + let uu___106 + = + let uu___107 + = + mk1 + "explode_qn" + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_string_list + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_string_list + FStarC_Reflection_V1_Builtins.explode_qn in + let uu___108 + = + let uu___109 + = + mk2 + "compare_string" + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_int + FStarC_Reflection_V1_Builtins.compare_string in + let uu___110 + = + let uu___111 + = + mk2 + "push_binder" + uu___16 + uu___11 + uu___16 + uu___36 + uu___31 + uu___36 + FStarC_Reflection_V1_Builtins.push_binder in + let uu___112 + = + let uu___113 + = + mk1 + "range_of_term" + uu___0 + FStarC_Syntax_Embeddings.e_range + uu___20 + FStarC_TypeChecker_NBETerm.e_range + FStarC_Reflection_V1_Builtins.range_of_term in + let uu___114 + = + let uu___115 + = + mk1 + "range_of_sigelt" + uu___9 + FStarC_Syntax_Embeddings.e_range + uu___29 + FStarC_TypeChecker_NBETerm.e_range + FStarC_Reflection_V1_Builtins.range_of_sigelt in + [uu___115] in + uu___113 + :: + uu___114 in + uu___111 + :: + uu___112 in + uu___109 + :: + uu___110 in + uu___107 + :: + uu___108 in + uu___105 + :: + uu___106 in + uu___103 :: + uu___104 in + uu___101 :: + uu___102 in + uu___99 :: + uu___100 in + uu___97 :: + uu___98 in + uu___95 :: uu___96 in + uu___93 :: uu___94 in + uu___91 :: uu___92 in + uu___89 :: uu___90 in + uu___87 :: uu___88 in + uu___85 :: uu___86 in + uu___83 :: uu___84 in + uu___81 :: uu___82 in + uu___79 :: uu___80 in + uu___77 :: uu___78 in + uu___75 :: uu___76 in + uu___73 :: uu___74 in + uu___71 :: uu___72 in + uu___69 :: uu___70 in + uu___67 :: uu___68 in + uu___65 :: uu___66 in + uu___63 :: uu___64 in + uu___61 :: uu___62 in + uu___59 :: uu___60 in + uu___57 :: uu___58 in + uu___55 :: uu___56 in + uu___53 :: uu___54 in + uu___51 :: uu___52 in + uu___49 :: uu___50 in + uu___47 :: uu___48 in + uu___45 :: uu___46 in + uu___43 :: uu___44 in + uu___41 :: uu___42 in + uu___ :: uu___40 +let (uu___40 : unit) = + FStarC_Compiler_List.iter FStarC_TypeChecker_Cfg.register_extra_step + reflection_primops \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Reflection_V1_NBEEmbeddings.ml b/ocaml/fstar-lib/generated/FStarC_Reflection_V1_NBEEmbeddings.ml new file mode 100644 index 00000000000..6dd3c51c3f8 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Reflection_V1_NBEEmbeddings.ml @@ -0,0 +1,2359 @@ +open Prims +let (noaqs : FStarC_Syntax_Syntax.antiquotations) = (Prims.int_zero, []) +let (mkFV : + FStarC_Syntax_Syntax.fv -> + FStarC_Syntax_Syntax.universe Prims.list -> + (FStarC_TypeChecker_NBETerm.t * FStarC_Syntax_Syntax.aqual) Prims.list + -> FStarC_TypeChecker_NBETerm.t) + = + fun fv -> + fun us -> + fun ts -> + FStarC_TypeChecker_NBETerm.mkFV fv (FStarC_Compiler_List.rev us) + (FStarC_Compiler_List.rev ts) +let (mkConstruct : + FStarC_Syntax_Syntax.fv -> + FStarC_Syntax_Syntax.universe Prims.list -> + (FStarC_TypeChecker_NBETerm.t * FStarC_Syntax_Syntax.aqual) Prims.list + -> FStarC_TypeChecker_NBETerm.t) + = + fun fv -> + fun us -> + fun ts -> + FStarC_TypeChecker_NBETerm.mkConstruct fv + (FStarC_Compiler_List.rev us) (FStarC_Compiler_List.rev ts) +let (fv_as_emb_typ : FStarC_Syntax_Syntax.fv -> FStarC_Syntax_Syntax.emb_typ) + = + fun fv -> + let uu___ = + let uu___1 = + FStarC_Ident.string_of_lid + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + (uu___1, []) in + FStarC_Syntax_Syntax.ET_app uu___ +let mk_emb' : + 'uuuuu . + (FStarC_TypeChecker_NBETerm.nbe_cbs -> + 'uuuuu -> FStarC_TypeChecker_NBETerm.t) + -> + (FStarC_TypeChecker_NBETerm.nbe_cbs -> + FStarC_TypeChecker_NBETerm.t -> + 'uuuuu FStar_Pervasives_Native.option) + -> + FStarC_Syntax_Syntax.fv -> + 'uuuuu FStarC_TypeChecker_NBETerm.embedding + = + fun x -> + fun y -> + fun fv -> + FStarC_TypeChecker_NBETerm.mk_emb x y (fun uu___ -> mkFV fv [] []) + (fun uu___ -> fv_as_emb_typ fv) +let mk_lazy : + 'uuuuu . + FStarC_TypeChecker_NBETerm.nbe_cbs -> + 'uuuuu -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.lazy_kind -> FStarC_TypeChecker_NBETerm.t + = + fun cb -> + fun obj -> + fun ty -> + fun kind -> + let li = + let uu___ = FStarC_Dyn.mkdyn obj in + { + FStarC_Syntax_Syntax.blob = uu___; + FStarC_Syntax_Syntax.lkind = kind; + FStarC_Syntax_Syntax.ltyp = ty; + FStarC_Syntax_Syntax.rng = + FStarC_Compiler_Range_Type.dummyRange + } in + let thunk = + FStarC_Thunk.mk + (fun uu___ -> + let uu___1 = FStarC_Syntax_Util.unfold_lazy li in + FStarC_TypeChecker_NBETerm.translate_cb cb uu___1) in + FStarC_TypeChecker_NBETerm.mk_t + (FStarC_TypeChecker_NBETerm.Lazy + ((FStar_Pervasives.Inl li), thunk)) +let (e_bv : FStarC_Syntax_Syntax.bv FStarC_TypeChecker_NBETerm.embedding) = + let embed_bv cb bv = + mk_lazy cb bv FStarC_Reflection_V1_Constants.fstar_refl_bv + FStarC_Syntax_Syntax.Lazy_bv in + let unembed_bv cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Lazy + (FStar_Pervasives.Inl + { FStarC_Syntax_Syntax.blob = b; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_bv; + FStarC_Syntax_Syntax.ltyp = uu___; + FStarC_Syntax_Syntax.rng = uu___1;_}, + uu___2) + -> + let uu___3 = FStarC_Dyn.undyn b in + FStar_Pervasives_Native.Some uu___3 + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded bv: %s" uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_bv unembed_bv FStarC_Reflection_V1_Constants.fstar_refl_bv_fv +let (e_binder : + FStarC_Syntax_Syntax.binder FStarC_TypeChecker_NBETerm.embedding) = + let embed_binder cb b = + mk_lazy cb b FStarC_Reflection_V1_Constants.fstar_refl_binder + FStarC_Syntax_Syntax.Lazy_binder in + let unembed_binder cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Lazy + (FStar_Pervasives.Inl + { FStarC_Syntax_Syntax.blob = b; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_binder; + FStarC_Syntax_Syntax.ltyp = uu___; + FStarC_Syntax_Syntax.rng = uu___1;_}, + uu___2) + -> + let uu___3 = FStarC_Dyn.undyn b in + FStar_Pervasives_Native.Some uu___3 + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded binder: %s" uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_binder unembed_binder + FStarC_Reflection_V1_Constants.fstar_refl_binder_fv +let rec mapM_opt : + 'a 'b . + ('a -> 'b FStar_Pervasives_Native.option) -> + 'a Prims.list -> 'b Prims.list FStar_Pervasives_Native.option + = + fun f -> + fun l -> + match l with + | [] -> FStar_Pervasives_Native.Some [] + | x::xs -> + let uu___ = f x in + FStarC_Compiler_Util.bind_opt uu___ + (fun x1 -> + let uu___1 = mapM_opt f xs in + FStarC_Compiler_Util.bind_opt uu___1 + (fun xs1 -> FStar_Pervasives_Native.Some (x1 :: xs1))) +let (e_term_aq : + (Prims.int * FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax + Prims.list) -> + FStarC_Syntax_Syntax.term FStarC_TypeChecker_NBETerm.embedding) + = + fun aq -> + let embed_term cb t = + let qi = + { + FStarC_Syntax_Syntax.qkind = FStarC_Syntax_Syntax.Quote_static; + FStarC_Syntax_Syntax.antiquotations = aq + } in + FStarC_TypeChecker_NBETerm.mk_t + (FStarC_TypeChecker_NBETerm.Quote (t, qi)) in + let unembed_term cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Quote (tm, qi) -> + let uu___ = + FStarC_Reflection_V1_Embeddings.e_term_aq (Prims.int_zero, []) in + let uu___1 = + FStarC_Syntax_Syntax.mk (FStarC_Syntax_Syntax.Tm_quoted (tm, qi)) + FStarC_Compiler_Range_Type.dummyRange in + FStarC_Syntax_Embeddings_Base.unembed uu___ uu___1 + FStarC_Syntax_Embeddings_Base.id_norm_cb + | uu___ -> FStar_Pervasives_Native.None in + { + FStarC_TypeChecker_NBETerm.em = embed_term; + FStarC_TypeChecker_NBETerm.un = unembed_term; + FStarC_TypeChecker_NBETerm.typ = + (fun uu___ -> + mkFV FStarC_Reflection_V1_Constants.fstar_refl_term_fv [] []); + FStarC_TypeChecker_NBETerm.e_typ = + (fun uu___ -> + fv_as_emb_typ FStarC_Reflection_V1_Constants.fstar_refl_term_fv) + } +let (e_term : FStarC_Syntax_Syntax.term FStarC_TypeChecker_NBETerm.embedding) + = e_term_aq (Prims.int_zero, []) +let (e_sort : + FStarC_Syntax_Syntax.term FStarC_Compiler_Sealed.sealed + FStarC_TypeChecker_NBETerm.embedding) + = FStarC_TypeChecker_NBETerm.e_sealed e_term +let (e_ppname : + Prims.string FStarC_Compiler_Sealed.sealed + FStarC_TypeChecker_NBETerm.embedding) + = FStarC_TypeChecker_NBETerm.e_sealed FStarC_TypeChecker_NBETerm.e_string +let (e_aqualv : + FStarC_Reflection_V1_Data.aqualv FStarC_TypeChecker_NBETerm.embedding) = + let embed_aqualv cb q = + match q with + | FStarC_Reflection_V1_Data.Q_Explicit -> + mkConstruct + FStarC_Reflection_V1_Constants.ref_Q_Explicit.FStarC_Reflection_V1_Constants.fv + [] [] + | FStarC_Reflection_V1_Data.Q_Implicit -> + mkConstruct + FStarC_Reflection_V1_Constants.ref_Q_Implicit.FStarC_Reflection_V1_Constants.fv + [] [] + | FStarC_Reflection_V1_Data.Q_Meta t -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_term cb t in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V1_Constants.ref_Q_Meta.FStarC_Reflection_V1_Constants.fv + [] uu___ in + let unembed_aqualv cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Q_Explicit.FStarC_Reflection_V1_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.Q_Explicit + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Q_Implicit.FStarC_Reflection_V1_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.Q_Implicit + | FStarC_TypeChecker_NBETerm.Construct (fv, [], (t1, uu___)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Q_Meta.FStarC_Reflection_V1_Constants.lid + -> + let uu___1 = FStarC_TypeChecker_NBETerm.unembed e_term cb t1 in + FStarC_Compiler_Util.bind_opt uu___1 + (fun t2 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Q_Meta t2)) + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded aqualv: %s" uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + FStarC_TypeChecker_NBETerm.mk_emb embed_aqualv unembed_aqualv + (fun uu___ -> + mkConstruct FStarC_Reflection_V1_Constants.fstar_refl_aqualv_fv [] []) + (fun uu___ -> + fv_as_emb_typ FStarC_Reflection_V1_Constants.fstar_refl_aqualv_fv) +let (e_binders : + FStarC_Syntax_Syntax.binders FStarC_TypeChecker_NBETerm.embedding) = + FStarC_TypeChecker_NBETerm.e_list e_binder +let (e_fv : FStarC_Syntax_Syntax.fv FStarC_TypeChecker_NBETerm.embedding) = + let embed_fv cb fv = + mk_lazy cb fv FStarC_Reflection_V1_Constants.fstar_refl_fv + FStarC_Syntax_Syntax.Lazy_fvar in + let unembed_fv cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Lazy + (FStar_Pervasives.Inl + { FStarC_Syntax_Syntax.blob = b; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_fvar; + FStarC_Syntax_Syntax.ltyp = uu___; + FStarC_Syntax_Syntax.rng = uu___1;_}, + uu___2) + -> + let uu___3 = FStarC_Dyn.undyn b in + FStar_Pervasives_Native.Some uu___3 + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded fvar: %s" uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_fv unembed_fv FStarC_Reflection_V1_Constants.fstar_refl_fv_fv +let (e_comp : FStarC_Syntax_Syntax.comp FStarC_TypeChecker_NBETerm.embedding) + = + let embed_comp cb c = + mk_lazy cb c FStarC_Reflection_V1_Constants.fstar_refl_comp + FStarC_Syntax_Syntax.Lazy_comp in + let unembed_comp cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Lazy + (FStar_Pervasives.Inl + { FStarC_Syntax_Syntax.blob = b; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_comp; + FStarC_Syntax_Syntax.ltyp = uu___; + FStarC_Syntax_Syntax.rng = uu___1;_}, + uu___2) + -> + let uu___3 = FStarC_Dyn.undyn b in + FStar_Pervasives_Native.Some uu___3 + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded comp: %s" uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_comp unembed_comp + FStarC_Reflection_V1_Constants.fstar_refl_comp_fv +let (e_env : FStarC_TypeChecker_Env.env FStarC_TypeChecker_NBETerm.embedding) + = + let embed_env cb e = + mk_lazy cb e FStarC_Reflection_V1_Constants.fstar_refl_env + FStarC_Syntax_Syntax.Lazy_env in + let unembed_env cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Lazy + (FStar_Pervasives.Inl + { FStarC_Syntax_Syntax.blob = b; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_env; + FStarC_Syntax_Syntax.ltyp = uu___; + FStarC_Syntax_Syntax.rng = uu___1;_}, + uu___2) + -> + let uu___3 = FStarC_Dyn.undyn b in + FStar_Pervasives_Native.Some uu___3 + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded env: %s" uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_env unembed_env + FStarC_Reflection_V1_Constants.fstar_refl_env_fv +let (e_const : + FStarC_Reflection_V1_Data.vconst FStarC_TypeChecker_NBETerm.embedding) = + let embed_const cb c = + match c with + | FStarC_Reflection_V1_Data.C_Unit -> + mkConstruct + FStarC_Reflection_V1_Constants.ref_C_Unit.FStarC_Reflection_V1_Constants.fv + [] [] + | FStarC_Reflection_V1_Data.C_True -> + mkConstruct + FStarC_Reflection_V1_Constants.ref_C_True.FStarC_Reflection_V1_Constants.fv + [] [] + | FStarC_Reflection_V1_Data.C_False -> + mkConstruct + FStarC_Reflection_V1_Constants.ref_C_False.FStarC_Reflection_V1_Constants.fv + [] [] + | FStarC_Reflection_V1_Data.C_Int i -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.mk_t + (FStarC_TypeChecker_NBETerm.Constant + (FStarC_TypeChecker_NBETerm.Int i)) in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V1_Constants.ref_C_Int.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.C_String s -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed + FStarC_TypeChecker_NBETerm.e_string cb s in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V1_Constants.ref_C_String.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.C_Range r -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed + FStarC_TypeChecker_NBETerm.e_range cb r in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V1_Constants.ref_C_Range.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.C_Reify -> + mkConstruct + FStarC_Reflection_V1_Constants.ref_C_Reify.FStarC_Reflection_V1_Constants.fv + [] [] + | FStarC_Reflection_V1_Data.C_Reflect ns -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed + FStarC_TypeChecker_NBETerm.e_string_list cb ns in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V1_Constants.ref_C_Reflect.FStarC_Reflection_V1_Constants.fv + [] uu___ in + let unembed_const cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_C_Unit.FStarC_Reflection_V1_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.C_Unit + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_C_True.FStarC_Reflection_V1_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.C_True + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_C_False.FStarC_Reflection_V1_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.C_False + | FStarC_TypeChecker_NBETerm.Construct (fv, [], (i, uu___)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_C_Int.FStarC_Reflection_V1_Constants.lid + -> + let uu___1 = + FStarC_TypeChecker_NBETerm.unembed FStarC_TypeChecker_NBETerm.e_int + cb i in + FStarC_Compiler_Util.bind_opt uu___1 + (fun i1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.C_Int i1)) + | FStarC_TypeChecker_NBETerm.Construct (fv, [], (s, uu___)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_C_String.FStarC_Reflection_V1_Constants.lid + -> + let uu___1 = + FStarC_TypeChecker_NBETerm.unembed + FStarC_TypeChecker_NBETerm.e_string cb s in + FStarC_Compiler_Util.bind_opt uu___1 + (fun s1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.C_String s1)) + | FStarC_TypeChecker_NBETerm.Construct (fv, [], (r, uu___)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_C_Range.FStarC_Reflection_V1_Constants.lid + -> + let uu___1 = + FStarC_TypeChecker_NBETerm.unembed + FStarC_TypeChecker_NBETerm.e_range cb r in + FStarC_Compiler_Util.bind_opt uu___1 + (fun r1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.C_Range r1)) + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_C_Reify.FStarC_Reflection_V1_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.C_Reify + | FStarC_TypeChecker_NBETerm.Construct (fv, [], (ns, uu___)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_C_Reflect.FStarC_Reflection_V1_Constants.lid + -> + let uu___1 = + FStarC_TypeChecker_NBETerm.unembed + FStarC_TypeChecker_NBETerm.e_string_list cb ns in + FStarC_Compiler_Util.bind_opt uu___1 + (fun ns1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.C_Reflect ns1)) + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded vconst: %s" uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_const unembed_const + FStarC_Reflection_V1_Constants.fstar_refl_vconst_fv +let (e_universe : + FStarC_Syntax_Syntax.universe FStarC_TypeChecker_NBETerm.embedding) = + let embed_universe cb u = + mk_lazy cb u FStarC_Reflection_V1_Constants.fstar_refl_universe + FStarC_Syntax_Syntax.Lazy_universe in + let unembed_universe cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Lazy + (FStar_Pervasives.Inl + { FStarC_Syntax_Syntax.blob = b; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_universe; + FStarC_Syntax_Syntax.ltyp = uu___; + FStarC_Syntax_Syntax.rng = uu___1;_}, + uu___2) + -> + let uu___3 = FStarC_Dyn.undyn b in + FStar_Pervasives_Native.Some uu___3 + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded universe: %s" + uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_universe unembed_universe + FStarC_Reflection_V1_Constants.fstar_refl_universe_fv +let rec e_pattern_aq : + 'uuuuu . + 'uuuuu -> + FStarC_Reflection_V1_Data.pattern FStarC_TypeChecker_NBETerm.embedding + = + fun aq -> + let embed_pattern cb p = + match p with + | FStarC_Reflection_V1_Data.Pat_Constant c -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_const cb c in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V1_Constants.ref_Pat_Constant.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.Pat_Cons (fv, us_opt, ps) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_fv cb fv in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_option + (FStarC_TypeChecker_NBETerm.e_list e_universe)) cb + us_opt in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = e_pattern_aq aq in + FStarC_TypeChecker_NBETerm.e_tuple2 uu___9 + FStarC_TypeChecker_NBETerm.e_bool in + FStarC_TypeChecker_NBETerm.e_list uu___8 in + FStarC_TypeChecker_NBETerm.embed uu___7 cb ps in + FStarC_TypeChecker_NBETerm.as_arg uu___6 in + [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V1_Constants.ref_Pat_Cons.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.Pat_Var (bv, sort) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_bv cb bv in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_TypeChecker_NBETerm.embed e_sort cb sort in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V1_Constants.ref_Pat_Var.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.Pat_Dot_Term eopt -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_option e_term) cb eopt in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V1_Constants.ref_Pat_Dot_Term.FStarC_Reflection_V1_Constants.fv + [] uu___ in + let unembed_pattern cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Construct (fv, [], (c, uu___)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Pat_Constant.FStarC_Reflection_V1_Constants.lid + -> + let uu___1 = FStarC_TypeChecker_NBETerm.unembed e_const cb c in + FStarC_Compiler_Util.bind_opt uu___1 + (fun c1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Pat_Constant c1)) + | FStarC_TypeChecker_NBETerm.Construct + (fv, [], (ps, uu___)::(us_opt, uu___1)::(f, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Pat_Cons.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = FStarC_TypeChecker_NBETerm.unembed e_fv cb f in + FStarC_Compiler_Util.bind_opt uu___3 + (fun f1 -> + let uu___4 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_option + (FStarC_TypeChecker_NBETerm.e_list e_universe)) cb + us_opt in + FStarC_Compiler_Util.bind_opt uu___4 + (fun us -> + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = e_pattern_aq aq in + FStarC_TypeChecker_NBETerm.e_tuple2 uu___8 + FStarC_TypeChecker_NBETerm.e_bool in + FStarC_TypeChecker_NBETerm.e_list uu___7 in + FStarC_TypeChecker_NBETerm.unembed uu___6 cb ps in + FStarC_Compiler_Util.bind_opt uu___5 + (fun ps1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Pat_Cons (f1, us, ps1))))) + | FStarC_TypeChecker_NBETerm.Construct + (fv, [], (sort, uu___)::(bv, uu___1)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Pat_Var.FStarC_Reflection_V1_Constants.lid + -> + let uu___2 = FStarC_TypeChecker_NBETerm.unembed e_bv cb bv in + FStarC_Compiler_Util.bind_opt uu___2 + (fun bv1 -> + let uu___3 = FStarC_TypeChecker_NBETerm.unembed e_sort cb sort in + FStarC_Compiler_Util.bind_opt uu___3 + (fun sort1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Pat_Var (bv1, sort1)))) + | FStarC_TypeChecker_NBETerm.Construct (fv, [], (eopt, uu___)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Pat_Dot_Term.FStarC_Reflection_V1_Constants.lid + -> + let uu___1 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_option e_term) cb eopt in + FStarC_Compiler_Util.bind_opt uu___1 + (fun eopt1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Pat_Dot_Term eopt1)) + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded pattern: %s" + uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded + () (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_pattern unembed_pattern + FStarC_Reflection_V1_Constants.fstar_refl_pattern_fv +let (e_pattern : + FStarC_Reflection_V1_Data.pattern FStarC_TypeChecker_NBETerm.embedding) = + e_pattern_aq noaqs +let (e_branch : + FStarC_Reflection_V1_Data.branch FStarC_TypeChecker_NBETerm.embedding) = + FStarC_TypeChecker_NBETerm.e_tuple2 e_pattern e_term +let (e_argv : + FStarC_Reflection_V1_Data.argv FStarC_TypeChecker_NBETerm.embedding) = + FStarC_TypeChecker_NBETerm.e_tuple2 e_term e_aqualv +let (e_branch_aq : + (Prims.int * FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax + Prims.list) -> + (FStarC_Reflection_V1_Data.pattern * FStarC_Syntax_Syntax.term) + FStarC_TypeChecker_NBETerm.embedding) + = + fun aq -> + let uu___ = e_pattern_aq aq in + FStarC_TypeChecker_NBETerm.e_tuple2 uu___ (e_term_aq aq) +let (e_argv_aq : + (Prims.int * FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax + Prims.list) -> + (FStarC_Syntax_Syntax.term * FStarC_Reflection_V1_Data.aqualv) + FStarC_TypeChecker_NBETerm.embedding) + = fun aq -> FStarC_TypeChecker_NBETerm.e_tuple2 (e_term_aq aq) e_aqualv +let (e_match_returns_annotation : + (FStarC_Syntax_Syntax.binder * ((FStarC_Syntax_Syntax.term, + FStarC_Syntax_Syntax.comp) FStar_Pervasives.either * + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option * Prims.bool)) + FStar_Pervasives_Native.option FStarC_TypeChecker_NBETerm.embedding) + = + FStarC_TypeChecker_NBETerm.e_option + (FStarC_TypeChecker_NBETerm.e_tuple2 e_binder + (FStarC_TypeChecker_NBETerm.e_tuple3 + (FStarC_TypeChecker_NBETerm.e_either e_term e_comp) + (FStarC_TypeChecker_NBETerm.e_option e_term) + FStarC_TypeChecker_NBETerm.e_bool)) +let unlazy_as_t : + 'uuuuu . + FStarC_Syntax_Syntax.lazy_kind -> FStarC_TypeChecker_NBETerm.t -> 'uuuuu + = + fun k -> + fun t -> + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Lazy + (FStar_Pervasives.Inl + { FStarC_Syntax_Syntax.blob = v; FStarC_Syntax_Syntax.lkind = k'; + FStarC_Syntax_Syntax.ltyp = uu___; + FStarC_Syntax_Syntax.rng = uu___1;_}, + uu___2) + when + FStarC_Class_Deq.op_Equals_Question + FStarC_Syntax_Syntax.deq_lazy_kind k k' + -> FStarC_Dyn.undyn v + | uu___ -> failwith "Not a Lazy of the expected kind (NBE)" +let (e_ident : + FStarC_Reflection_V1_Data.ident FStarC_TypeChecker_NBETerm.embedding) = + FStarC_TypeChecker_NBETerm.e_tuple2 FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_range +let (e_universe_view : + FStarC_Reflection_V1_Data.universe_view + FStarC_TypeChecker_NBETerm.embedding) + = + let embed_universe_view cb uv = + match uv with + | FStarC_Reflection_V1_Data.Uv_Zero -> + mkConstruct + FStarC_Reflection_V1_Constants.ref_Uv_Zero.FStarC_Reflection_V1_Constants.fv + [] [] + | FStarC_Reflection_V1_Data.Uv_Succ u -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_universe cb u in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V1_Constants.ref_Uv_Succ.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.Uv_Max us -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_list e_universe) cb us in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V1_Constants.ref_Uv_Max.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.Uv_BVar n -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed + FStarC_TypeChecker_NBETerm.e_int cb n in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V1_Constants.ref_Uv_BVar.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.Uv_Name i -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_tuple2 + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_range) cb i in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V1_Constants.ref_Uv_Name.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.Uv_Unif u -> + let uu___ = + let uu___1 = + let uu___2 = + mk_lazy cb u FStarC_Syntax_Util.t_universe_uvar + FStarC_Syntax_Syntax.Lazy_universe_uvar in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V1_Constants.ref_Uv_Unif.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.Uv_Unk -> + mkConstruct + FStarC_Reflection_V1_Constants.ref_Uv_Unk.FStarC_Reflection_V1_Constants.fv + [] [] in + let unembed_universe_view cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Uv_Zero.FStarC_Reflection_V1_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.Uv_Zero + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, (u, uu___1)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Uv_Succ.FStarC_Reflection_V1_Constants.lid + -> + let uu___2 = FStarC_TypeChecker_NBETerm.unembed e_universe cb u in + FStarC_Compiler_Util.bind_opt uu___2 + (fun u1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Uv_Succ u1)) + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, (us, uu___1)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Uv_Max.FStarC_Reflection_V1_Constants.lid + -> + let uu___2 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_list e_universe) cb us in + FStarC_Compiler_Util.bind_opt uu___2 + (fun us1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Uv_Max us1)) + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, (n, uu___1)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Uv_BVar.FStarC_Reflection_V1_Constants.lid + -> + let uu___2 = + FStarC_TypeChecker_NBETerm.unembed FStarC_TypeChecker_NBETerm.e_int + cb n in + FStarC_Compiler_Util.bind_opt uu___2 + (fun n1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Uv_BVar n1)) + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, (i, uu___1)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Uv_Name.FStarC_Reflection_V1_Constants.lid + -> + let uu___2 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_tuple2 + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_range) cb i in + FStarC_Compiler_Util.bind_opt uu___2 + (fun i1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Uv_Name i1)) + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, (u, uu___1)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Uv_Unif.FStarC_Reflection_V1_Constants.lid + -> + let u1 = unlazy_as_t FStarC_Syntax_Syntax.Lazy_universe_uvar u in + FStar_Pervasives_Native.Some (FStarC_Reflection_V1_Data.Uv_Unif u1) + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Uv_Unk.FStarC_Reflection_V1_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.Uv_Unk + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded universe view: %s" + uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_universe_view unembed_universe_view + FStarC_Reflection_V1_Constants.fstar_refl_universe_view_fv +let (e_term_view_aq : + (Prims.int * FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax + Prims.list) -> + FStarC_Reflection_V1_Data.term_view FStarC_TypeChecker_NBETerm.embedding) + = + fun aq -> + let shift uu___ = + match uu___ with | (s, aqs) -> ((s + Prims.int_one), aqs) in + let embed_term_view cb tv = + match tv with + | FStarC_Reflection_V1_Data.Tv_FVar fv -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_fv cb fv in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V1_Constants.ref_Tv_FVar.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.Tv_BVar bv -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_bv cb bv in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V1_Constants.ref_Tv_BVar.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.Tv_Var bv -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_bv cb bv in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V1_Constants.ref_Tv_Var.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.Tv_UInst (fv, us) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_fv cb fv in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_list e_universe) cb us in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V1_Constants.ref_Tv_UInst.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.Tv_App (hd, a) -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed (e_term_aq aq) cb hd in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed (e_argv_aq aq) cb a in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V1_Constants.ref_Tv_App.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.Tv_Abs (b, t) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_binder cb b in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed (e_term_aq (shift aq)) cb + t in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V1_Constants.ref_Tv_Abs.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.Tv_Arrow (b, c) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_binder cb b in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_TypeChecker_NBETerm.embed e_comp cb c in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V1_Constants.ref_Tv_Arrow.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.Tv_Type u -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_universe cb u in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V1_Constants.ref_Tv_Type.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.Tv_Refine (bv, sort, t) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_bv cb bv in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed (e_term_aq aq) cb sort in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_TypeChecker_NBETerm.embed (e_term_aq (shift aq)) + cb t in + FStarC_TypeChecker_NBETerm.as_arg uu___6 in + [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V1_Constants.ref_Tv_Refine.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.Tv_Const c -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_const cb c in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V1_Constants.ref_Tv_Const.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.Tv_Uvar (u, d) -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed + FStarC_TypeChecker_NBETerm.e_int cb u in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + mk_lazy cb (u, d) FStarC_Syntax_Util.t_ctx_uvar_and_sust + FStarC_Syntax_Syntax.Lazy_uvar in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V1_Constants.ref_Tv_Uvar.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.Tv_Let (r, attrs, b, ty, t1, t2) -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed + FStarC_TypeChecker_NBETerm.e_bool cb r in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_list e_term) cb attrs in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = FStarC_TypeChecker_NBETerm.embed e_bv cb b in + FStarC_TypeChecker_NBETerm.as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_TypeChecker_NBETerm.embed (e_term_aq aq) cb ty in + FStarC_TypeChecker_NBETerm.as_arg uu___8 in + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_TypeChecker_NBETerm.embed (e_term_aq aq) cb t1 in + FStarC_TypeChecker_NBETerm.as_arg uu___10 in + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_TypeChecker_NBETerm.embed + (e_term_aq (shift aq)) cb t2 in + FStarC_TypeChecker_NBETerm.as_arg uu___12 in + [uu___11] in + uu___9 :: uu___10 in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V1_Constants.ref_Tv_Let.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.Tv_Match (t, ret_opt, brs) -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed (e_term_aq aq) cb t in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed e_match_returns_annotation + cb ret_opt in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = e_branch_aq aq in + FStarC_TypeChecker_NBETerm.e_list uu___8 in + FStarC_TypeChecker_NBETerm.embed uu___7 cb brs in + FStarC_TypeChecker_NBETerm.as_arg uu___6 in + [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V1_Constants.ref_Tv_Match.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.Tv_AscribedT (e, t, tacopt, use_eq) -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed (e_term_aq aq) cb e in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed (e_term_aq aq) cb t in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_option (e_term_aq aq)) cb + tacopt in + FStarC_TypeChecker_NBETerm.as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_TypeChecker_NBETerm.embed + FStarC_TypeChecker_NBETerm.e_bool cb use_eq in + FStarC_TypeChecker_NBETerm.as_arg uu___8 in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V1_Constants.ref_Tv_AscT.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.Tv_AscribedC (e, c, tacopt, use_eq) -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed (e_term_aq aq) cb e in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_TypeChecker_NBETerm.embed e_comp cb c in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_option (e_term_aq aq)) cb + tacopt in + FStarC_TypeChecker_NBETerm.as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_TypeChecker_NBETerm.embed + FStarC_TypeChecker_NBETerm.e_bool cb use_eq in + FStarC_TypeChecker_NBETerm.as_arg uu___8 in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V1_Constants.ref_Tv_AscT.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.Tv_Unknown -> + mkConstruct + FStarC_Reflection_V1_Constants.ref_Tv_Unknown.FStarC_Reflection_V1_Constants.fv + [] [] + | FStarC_Reflection_V1_Data.Tv_Unsupp -> + mkConstruct + FStarC_Reflection_V1_Constants.ref_Tv_Unsupp.FStarC_Reflection_V1_Constants.fv + [] [] in + let unembed_term_view cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, (b, uu___1)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_Var.FStarC_Reflection_V1_Constants.lid + -> + let uu___2 = FStarC_TypeChecker_NBETerm.unembed e_bv cb b in + FStarC_Compiler_Util.bind_opt uu___2 + (fun b1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Tv_Var b1)) + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, (b, uu___1)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_BVar.FStarC_Reflection_V1_Constants.lid + -> + let uu___2 = FStarC_TypeChecker_NBETerm.unembed e_bv cb b in + FStarC_Compiler_Util.bind_opt uu___2 + (fun b1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Tv_BVar b1)) + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, (f, uu___1)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_FVar.FStarC_Reflection_V1_Constants.lid + -> + let uu___2 = FStarC_TypeChecker_NBETerm.unembed e_fv cb f in + FStarC_Compiler_Util.bind_opt uu___2 + (fun f1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Tv_FVar f1)) + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, (f, uu___1)::(us, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_UInst.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = FStarC_TypeChecker_NBETerm.unembed e_fv cb f in + FStarC_Compiler_Util.bind_opt uu___3 + (fun f1 -> + let uu___4 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_list e_universe) cb us in + FStarC_Compiler_Util.bind_opt uu___4 + (fun us1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Tv_UInst (f1, us1)))) + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, (r, uu___1)::(l, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_App.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = FStarC_TypeChecker_NBETerm.unembed e_term cb l in + FStarC_Compiler_Util.bind_opt uu___3 + (fun l1 -> + let uu___4 = FStarC_TypeChecker_NBETerm.unembed e_argv cb r in + FStarC_Compiler_Util.bind_opt uu___4 + (fun r1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Tv_App (l1, r1)))) + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, (t1, uu___1)::(b, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_Abs.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = FStarC_TypeChecker_NBETerm.unembed e_binder cb b in + FStarC_Compiler_Util.bind_opt uu___3 + (fun b1 -> + let uu___4 = FStarC_TypeChecker_NBETerm.unembed e_term cb t1 in + FStarC_Compiler_Util.bind_opt uu___4 + (fun t2 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Tv_Abs (b1, t2)))) + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, (t1, uu___1)::(b, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_Arrow.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = FStarC_TypeChecker_NBETerm.unembed e_binder cb b in + FStarC_Compiler_Util.bind_opt uu___3 + (fun b1 -> + let uu___4 = FStarC_TypeChecker_NBETerm.unembed e_comp cb t1 in + FStarC_Compiler_Util.bind_opt uu___4 + (fun c -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Tv_Arrow (b1, c)))) + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, (u, uu___1)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_Type.FStarC_Reflection_V1_Constants.lid + -> + let uu___2 = FStarC_TypeChecker_NBETerm.unembed e_universe cb u in + FStarC_Compiler_Util.bind_opt uu___2 + (fun u1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Tv_Type u1)) + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, (t1, uu___1)::(sort, uu___2)::(b, uu___3)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_Refine.FStarC_Reflection_V1_Constants.lid + -> + let uu___4 = FStarC_TypeChecker_NBETerm.unembed e_bv cb b in + FStarC_Compiler_Util.bind_opt uu___4 + (fun b1 -> + let uu___5 = FStarC_TypeChecker_NBETerm.unembed e_term cb sort in + FStarC_Compiler_Util.bind_opt uu___5 + (fun sort1 -> + let uu___6 = + FStarC_TypeChecker_NBETerm.unembed e_term cb t1 in + FStarC_Compiler_Util.bind_opt uu___6 + (fun t2 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Tv_Refine + (b1, sort1, t2))))) + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, (c, uu___1)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_Const.FStarC_Reflection_V1_Constants.lid + -> + let uu___2 = FStarC_TypeChecker_NBETerm.unembed e_const cb c in + FStarC_Compiler_Util.bind_opt uu___2 + (fun c1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Tv_Const c1)) + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, (l, uu___1)::(u, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_Uvar.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = + FStarC_TypeChecker_NBETerm.unembed + FStarC_TypeChecker_NBETerm.e_int cb u in + FStarC_Compiler_Util.bind_opt uu___3 + (fun u1 -> + let ctx_u_s = unlazy_as_t FStarC_Syntax_Syntax.Lazy_uvar l in + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Tv_Uvar (u1, ctx_u_s))) + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, + (t2, uu___1)::(t1, uu___2)::(ty, uu___3)::(b, uu___4)::(attrs, + uu___5):: + (r, uu___6)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_Let.FStarC_Reflection_V1_Constants.lid + -> + let uu___7 = + FStarC_TypeChecker_NBETerm.unembed + FStarC_TypeChecker_NBETerm.e_bool cb r in + FStarC_Compiler_Util.bind_opt uu___7 + (fun r1 -> + let uu___8 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_list e_term) cb attrs in + FStarC_Compiler_Util.bind_opt uu___8 + (fun attrs1 -> + let uu___9 = FStarC_TypeChecker_NBETerm.unembed e_bv cb b in + FStarC_Compiler_Util.bind_opt uu___9 + (fun b1 -> + let uu___10 = + FStarC_TypeChecker_NBETerm.unembed e_term cb ty in + FStarC_Compiler_Util.bind_opt uu___10 + (fun ty1 -> + let uu___11 = + FStarC_TypeChecker_NBETerm.unembed e_term cb + t1 in + FStarC_Compiler_Util.bind_opt uu___11 + (fun t11 -> + let uu___12 = + FStarC_TypeChecker_NBETerm.unembed + e_term cb t2 in + FStarC_Compiler_Util.bind_opt uu___12 + (fun t21 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Tv_Let + (r1, attrs1, b1, ty1, t11, t21)))))))) + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, (brs, uu___1)::(ret_opt, uu___2)::(t1, uu___3)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_Match.FStarC_Reflection_V1_Constants.lid + -> + let uu___4 = FStarC_TypeChecker_NBETerm.unembed e_term cb t1 in + FStarC_Compiler_Util.bind_opt uu___4 + (fun t2 -> + let uu___5 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_list e_branch) cb brs in + FStarC_Compiler_Util.bind_opt uu___5 + (fun brs1 -> + let uu___6 = + FStarC_TypeChecker_NBETerm.unembed + e_match_returns_annotation cb ret_opt in + FStarC_Compiler_Util.bind_opt uu___6 + (fun ret_opt1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Tv_Match + (t2, ret_opt1, brs1))))) + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, + (tacopt, uu___1)::(t1, uu___2)::(e, uu___3)::(use_eq, uu___4)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_AscT.FStarC_Reflection_V1_Constants.lid + -> + let uu___5 = FStarC_TypeChecker_NBETerm.unembed e_term cb e in + FStarC_Compiler_Util.bind_opt uu___5 + (fun e1 -> + let uu___6 = FStarC_TypeChecker_NBETerm.unembed e_term cb t1 in + FStarC_Compiler_Util.bind_opt uu___6 + (fun t2 -> + let uu___7 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_option e_term) cb + tacopt in + FStarC_Compiler_Util.bind_opt uu___7 + (fun tacopt1 -> + let uu___8 = + FStarC_TypeChecker_NBETerm.unembed + FStarC_TypeChecker_NBETerm.e_bool cb use_eq in + FStarC_Compiler_Util.bind_opt uu___8 + (fun use_eq1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Tv_AscribedT + (e1, t2, tacopt1, use_eq1)))))) + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, + (tacopt, uu___1)::(c, uu___2)::(e, uu___3)::(use_eq, uu___4)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_AscC.FStarC_Reflection_V1_Constants.lid + -> + let uu___5 = FStarC_TypeChecker_NBETerm.unembed e_term cb e in + FStarC_Compiler_Util.bind_opt uu___5 + (fun e1 -> + let uu___6 = FStarC_TypeChecker_NBETerm.unembed e_comp cb c in + FStarC_Compiler_Util.bind_opt uu___6 + (fun c1 -> + let uu___7 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_option e_term) cb + tacopt in + FStarC_Compiler_Util.bind_opt uu___7 + (fun tacopt1 -> + let uu___8 = + FStarC_TypeChecker_NBETerm.unembed + FStarC_TypeChecker_NBETerm.e_bool cb use_eq in + FStarC_Compiler_Util.bind_opt uu___8 + (fun use_eq1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Tv_AscribedC + (e1, c1, tacopt1, use_eq1)))))) + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_Unknown.FStarC_Reflection_V1_Constants.lid + -> + FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.Tv_Unknown + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Tv_Unsupp.FStarC_Reflection_V1_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.Tv_Unsupp + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded term_view: %s" + uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded + () (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_term_view unembed_term_view + FStarC_Reflection_V1_Constants.fstar_refl_term_view_fv +let (e_term_view : + FStarC_Reflection_V1_Data.term_view FStarC_TypeChecker_NBETerm.embedding) = + e_term_view_aq (Prims.int_zero, []) +let (e_bv_view : + FStarC_Reflection_V1_Data.bv_view FStarC_TypeChecker_NBETerm.embedding) = + let embed_bv_view cb bvv = + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_sealed + FStarC_TypeChecker_NBETerm.e_string) cb + bvv.FStarC_Reflection_V1_Data.bv_ppname in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed FStarC_TypeChecker_NBETerm.e_int + cb bvv.FStarC_Reflection_V1_Data.bv_index in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V1_Constants.ref_Mk_bv.FStarC_Reflection_V1_Constants.fv + [] uu___ in + let unembed_bv_view cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, (idx, uu___1)::(nm, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Mk_bv.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_sealed + FStarC_TypeChecker_NBETerm.e_string) cb nm in + FStarC_Compiler_Util.bind_opt uu___3 + (fun nm1 -> + let uu___4 = + FStarC_TypeChecker_NBETerm.unembed + FStarC_TypeChecker_NBETerm.e_int cb idx in + FStarC_Compiler_Util.bind_opt uu___4 + (fun idx1 -> + FStar_Pervasives_Native.Some + { + FStarC_Reflection_V1_Data.bv_ppname = nm1; + FStarC_Reflection_V1_Data.bv_index = idx1 + })) + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded bv_view: %s" uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_bv_view unembed_bv_view + FStarC_Reflection_V1_Constants.fstar_refl_bv_view_fv +let (e_attribute : + FStarC_Syntax_Syntax.attribute FStarC_TypeChecker_NBETerm.embedding) = + e_term +let (e_attributes : + FStarC_Syntax_Syntax.attribute Prims.list + FStarC_TypeChecker_NBETerm.embedding) + = FStarC_TypeChecker_NBETerm.e_list e_attribute +let (e_binder_view : + FStarC_Reflection_V1_Data.binder_view FStarC_TypeChecker_NBETerm.embedding) + = + let embed_binder_view cb bview = + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed e_bv cb + bview.FStarC_Reflection_V1_Data.binder_bv in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed e_aqualv cb + bview.FStarC_Reflection_V1_Data.binder_qual in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_TypeChecker_NBETerm.embed e_attributes cb + bview.FStarC_Reflection_V1_Data.binder_attrs in + FStarC_TypeChecker_NBETerm.as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_TypeChecker_NBETerm.embed e_term cb + bview.FStarC_Reflection_V1_Data.binder_sort in + FStarC_TypeChecker_NBETerm.as_arg uu___8 in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V1_Constants.ref_Mk_binder.FStarC_Reflection_V1_Constants.fv + [] uu___ in + let unembed_binder_view cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, + (sort, uu___1)::(attrs, uu___2)::(q, uu___3)::(bv, uu___4)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Mk_binder.FStarC_Reflection_V1_Constants.lid + -> + let uu___5 = FStarC_TypeChecker_NBETerm.unembed e_bv cb bv in + FStarC_Compiler_Util.bind_opt uu___5 + (fun bv1 -> + let uu___6 = FStarC_TypeChecker_NBETerm.unembed e_aqualv cb q in + FStarC_Compiler_Util.bind_opt uu___6 + (fun q1 -> + let uu___7 = + FStarC_TypeChecker_NBETerm.unembed e_attributes cb attrs in + FStarC_Compiler_Util.bind_opt uu___7 + (fun attrs1 -> + let uu___8 = + FStarC_TypeChecker_NBETerm.unembed e_term cb sort in + FStarC_Compiler_Util.bind_opt uu___8 + (fun sort1 -> + FStar_Pervasives_Native.Some + { + FStarC_Reflection_V1_Data.binder_bv = bv1; + FStarC_Reflection_V1_Data.binder_qual = q1; + FStarC_Reflection_V1_Data.binder_attrs = + attrs1; + FStarC_Reflection_V1_Data.binder_sort = sort1 + })))) + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded binder_view: %s" + uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_binder_view unembed_binder_view + FStarC_Reflection_V1_Constants.fstar_refl_binder_view_fv +let (e_comp_view : + FStarC_Reflection_V1_Data.comp_view FStarC_TypeChecker_NBETerm.embedding) = + let embed_comp_view cb cv = + match cv with + | FStarC_Reflection_V1_Data.C_Total t -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_term cb t in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V1_Constants.ref_C_Total.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.C_GTotal t -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_term cb t in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V1_Constants.ref_C_GTotal.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.C_Lemma (pre, post, pats) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_term cb pre in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_TypeChecker_NBETerm.embed e_term cb post in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = FStarC_TypeChecker_NBETerm.embed e_term cb pats in + FStarC_TypeChecker_NBETerm.as_arg uu___6 in + [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V1_Constants.ref_C_Lemma.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.C_Eff (us, eff, res, args, decrs) -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_list e_universe) cb us in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed + FStarC_TypeChecker_NBETerm.e_string_list cb eff in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = FStarC_TypeChecker_NBETerm.embed e_term cb res in + FStarC_TypeChecker_NBETerm.as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_list e_argv) cb args in + FStarC_TypeChecker_NBETerm.as_arg uu___8 in + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_list e_term) cb decrs in + FStarC_TypeChecker_NBETerm.as_arg uu___10 in + [uu___9] in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V1_Constants.ref_C_Eff.FStarC_Reflection_V1_Constants.fv + [] uu___ in + let unembed_comp_view cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, (t1, uu___1)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_C_Total.FStarC_Reflection_V1_Constants.lid + -> + let uu___2 = FStarC_TypeChecker_NBETerm.unembed e_term cb t1 in + FStarC_Compiler_Util.bind_opt uu___2 + (fun t2 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.C_Total t2)) + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, (t1, uu___1)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_C_GTotal.FStarC_Reflection_V1_Constants.lid + -> + let uu___2 = FStarC_TypeChecker_NBETerm.unembed e_term cb t1 in + FStarC_Compiler_Util.bind_opt uu___2 + (fun t2 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.C_GTotal t2)) + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, (post, uu___1)::(pre, uu___2)::(pats, uu___3)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_C_Lemma.FStarC_Reflection_V1_Constants.lid + -> + let uu___4 = FStarC_TypeChecker_NBETerm.unembed e_term cb pre in + FStarC_Compiler_Util.bind_opt uu___4 + (fun pre1 -> + let uu___5 = FStarC_TypeChecker_NBETerm.unembed e_term cb post in + FStarC_Compiler_Util.bind_opt uu___5 + (fun post1 -> + let uu___6 = + FStarC_TypeChecker_NBETerm.unembed e_term cb pats in + FStarC_Compiler_Util.bind_opt uu___6 + (fun pats1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.C_Lemma + (pre1, post1, pats1))))) + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, + (decrs, uu___1)::(args, uu___2)::(res, uu___3)::(eff, uu___4):: + (us, uu___5)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_C_Eff.FStarC_Reflection_V1_Constants.lid + -> + let uu___6 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_list e_universe) cb us in + FStarC_Compiler_Util.bind_opt uu___6 + (fun us1 -> + let uu___7 = + FStarC_TypeChecker_NBETerm.unembed + FStarC_TypeChecker_NBETerm.e_string_list cb eff in + FStarC_Compiler_Util.bind_opt uu___7 + (fun eff1 -> + let uu___8 = + FStarC_TypeChecker_NBETerm.unembed e_term cb res in + FStarC_Compiler_Util.bind_opt uu___8 + (fun res1 -> + let uu___9 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_list e_argv) cb args in + FStarC_Compiler_Util.bind_opt uu___9 + (fun args1 -> + let uu___10 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_list e_term) cb + decrs in + FStarC_Compiler_Util.bind_opt uu___10 + (fun decrs1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.C_Eff + (us1, eff1, res1, args1, decrs1))))))) + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded comp_view: %s" + uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_comp_view unembed_comp_view + FStarC_Reflection_V1_Constants.fstar_refl_comp_view_fv +let (e_sigelt : + FStarC_Syntax_Syntax.sigelt FStarC_TypeChecker_NBETerm.embedding) = + let embed_sigelt cb se = + mk_lazy cb se FStarC_Reflection_V1_Constants.fstar_refl_sigelt + FStarC_Syntax_Syntax.Lazy_sigelt in + let unembed_sigelt cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Lazy + (FStar_Pervasives.Inl + { FStarC_Syntax_Syntax.blob = b; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_sigelt; + FStarC_Syntax_Syntax.ltyp = uu___; + FStarC_Syntax_Syntax.rng = uu___1;_}, + uu___2) + -> + let uu___3 = FStarC_Dyn.undyn b in + FStar_Pervasives_Native.Some uu___3 + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded sigelt: %s" uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_sigelt unembed_sigelt + FStarC_Reflection_V1_Constants.fstar_refl_sigelt_fv +let (e_univ_name : + FStarC_Reflection_V1_Data.univ_name FStarC_TypeChecker_NBETerm.embedding) = + e_ident +let (e_univ_names : + FStarC_Reflection_V1_Data.univ_name Prims.list + FStarC_TypeChecker_NBETerm.embedding) + = FStarC_TypeChecker_NBETerm.e_list e_univ_name +let (e_string_list : + Prims.string Prims.list FStarC_TypeChecker_NBETerm.embedding) = + FStarC_TypeChecker_NBETerm.e_list FStarC_TypeChecker_NBETerm.e_string +let (e_ctor : + (Prims.string Prims.list * FStarC_Syntax_Syntax.term) + FStarC_TypeChecker_NBETerm.embedding) + = FStarC_TypeChecker_NBETerm.e_tuple2 e_string_list e_term +let (e_lb_view : + FStarC_Reflection_V1_Data.lb_view FStarC_TypeChecker_NBETerm.embedding) = + let embed_lb_view cb lbv = + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed e_fv cb + lbv.FStarC_Reflection_V1_Data.lb_fv in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed e_univ_names cb + lbv.FStarC_Reflection_V1_Data.lb_us in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_TypeChecker_NBETerm.embed e_term cb + lbv.FStarC_Reflection_V1_Data.lb_typ in + FStarC_TypeChecker_NBETerm.as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_TypeChecker_NBETerm.embed e_term cb + lbv.FStarC_Reflection_V1_Data.lb_def in + FStarC_TypeChecker_NBETerm.as_arg uu___8 in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V1_Constants.ref_Mk_lb.FStarC_Reflection_V1_Constants.fv + [] uu___ in + let unembed_lb_view cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, + (fv', uu___1)::(us, uu___2)::(typ, uu___3)::(def, uu___4)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Mk_lb.FStarC_Reflection_V1_Constants.lid + -> + let uu___5 = FStarC_TypeChecker_NBETerm.unembed e_fv cb fv' in + FStarC_Compiler_Util.bind_opt uu___5 + (fun fv'1 -> + let uu___6 = + FStarC_TypeChecker_NBETerm.unembed e_univ_names cb us in + FStarC_Compiler_Util.bind_opt uu___6 + (fun us1 -> + let uu___7 = + FStarC_TypeChecker_NBETerm.unembed e_term cb typ in + FStarC_Compiler_Util.bind_opt uu___7 + (fun typ1 -> + let uu___8 = + FStarC_TypeChecker_NBETerm.unembed e_term cb def in + FStarC_Compiler_Util.bind_opt uu___8 + (fun def1 -> + FStar_Pervasives_Native.Some + { + FStarC_Reflection_V1_Data.lb_fv = fv'1; + FStarC_Reflection_V1_Data.lb_us = us1; + FStarC_Reflection_V1_Data.lb_typ = typ1; + FStarC_Reflection_V1_Data.lb_def = def1 + })))) + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded lb_view: %s" uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_lb_view unembed_lb_view + FStarC_Reflection_V1_Constants.fstar_refl_lb_view_fv +let (e_lid : FStarC_Ident.lid FStarC_TypeChecker_NBETerm.embedding) = + let embed rng lid = + let uu___ = FStarC_Ident.path_of_lid lid in + FStarC_TypeChecker_NBETerm.embed e_string_list rng uu___ in + let unembed cb t = + let uu___ = FStarC_TypeChecker_NBETerm.unembed e_string_list cb t in + FStarC_Compiler_Util.map_opt uu___ + (fun p -> + FStarC_Ident.lid_of_path p FStarC_Compiler_Range_Type.dummyRange) in + FStarC_TypeChecker_NBETerm.mk_emb embed unembed + (fun uu___ -> + mkConstruct FStarC_Reflection_V1_Constants.fstar_refl_aqualv_fv [] []) + (fun uu___ -> + fv_as_emb_typ FStarC_Reflection_V1_Constants.fstar_refl_aqualv_fv) +let (e_letbinding : + FStarC_Syntax_Syntax.letbinding FStarC_TypeChecker_NBETerm.embedding) = + let embed_letbinding cb lb = + mk_lazy cb lb FStarC_Reflection_V1_Constants.fstar_refl_letbinding + FStarC_Syntax_Syntax.Lazy_letbinding in + let unembed_letbinding cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Lazy + (FStar_Pervasives.Inl + { FStarC_Syntax_Syntax.blob = lb; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_letbinding; + FStarC_Syntax_Syntax.ltyp = uu___; + FStarC_Syntax_Syntax.rng = uu___1;_}, + uu___2) + -> + let uu___3 = FStarC_Dyn.undyn lb in + FStar_Pervasives_Native.Some uu___3 + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded letbinding: %s" + uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_letbinding unembed_letbinding + FStarC_Reflection_V1_Constants.fstar_refl_letbinding_fv +let (e_sigelt_view : + FStarC_Reflection_V1_Data.sigelt_view FStarC_TypeChecker_NBETerm.embedding) + = + let embed_sigelt_view cb sev = + match sev with + | FStarC_Reflection_V1_Data.Sg_Let (r, lbs) -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed + FStarC_TypeChecker_NBETerm.e_bool cb r in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_list e_letbinding) cb lbs in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V1_Constants.ref_Sg_Let.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.Sg_Inductive (nm, univs, bs, t, dcs) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_string_list cb nm in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed e_univ_names cb univs in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = FStarC_TypeChecker_NBETerm.embed e_binders cb bs in + FStarC_TypeChecker_NBETerm.as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = FStarC_TypeChecker_NBETerm.embed e_term cb t in + FStarC_TypeChecker_NBETerm.as_arg uu___8 in + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_list e_ctor) cb dcs in + FStarC_TypeChecker_NBETerm.as_arg uu___10 in + [uu___9] in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V1_Constants.ref_Sg_Inductive.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.Sg_Val (nm, univs, t) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_string_list cb nm in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed e_univ_names cb univs in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = FStarC_TypeChecker_NBETerm.embed e_term cb t in + FStarC_TypeChecker_NBETerm.as_arg uu___6 in + [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V1_Constants.ref_Sg_Val.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.Unk -> + mkConstruct + FStarC_Reflection_V1_Constants.ref_Unk.FStarC_Reflection_V1_Constants.fv + [] [] in + let unembed_sigelt_view cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, + (dcs, uu___1)::(t1, uu___2)::(bs, uu___3)::(us, uu___4)::(nm, + uu___5)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Sg_Inductive.FStarC_Reflection_V1_Constants.lid + -> + let uu___6 = FStarC_TypeChecker_NBETerm.unembed e_string_list cb nm in + FStarC_Compiler_Util.bind_opt uu___6 + (fun nm1 -> + let uu___7 = + FStarC_TypeChecker_NBETerm.unembed e_univ_names cb us in + FStarC_Compiler_Util.bind_opt uu___7 + (fun us1 -> + let uu___8 = + FStarC_TypeChecker_NBETerm.unembed e_binders cb bs in + FStarC_Compiler_Util.bind_opt uu___8 + (fun bs1 -> + let uu___9 = + FStarC_TypeChecker_NBETerm.unembed e_term cb t1 in + FStarC_Compiler_Util.bind_opt uu___9 + (fun t2 -> + let uu___10 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_list e_ctor) cb + dcs in + FStarC_Compiler_Util.bind_opt uu___10 + (fun dcs1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Sg_Inductive + (nm1, us1, bs1, t2, dcs1))))))) + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, (lbs, uu___1)::(r, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Sg_Let.FStarC_Reflection_V1_Constants.lid + -> + let uu___3 = + FStarC_TypeChecker_NBETerm.unembed + FStarC_TypeChecker_NBETerm.e_bool cb r in + FStarC_Compiler_Util.bind_opt uu___3 + (fun r1 -> + let uu___4 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_list e_letbinding) cb lbs in + FStarC_Compiler_Util.bind_opt uu___4 + (fun lbs1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Sg_Let (r1, lbs1)))) + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, (t1, uu___1)::(us, uu___2)::(nm, uu___3)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Sg_Val.FStarC_Reflection_V1_Constants.lid + -> + let uu___4 = FStarC_TypeChecker_NBETerm.unembed e_string_list cb nm in + FStarC_Compiler_Util.bind_opt uu___4 + (fun nm1 -> + let uu___5 = + FStarC_TypeChecker_NBETerm.unembed e_univ_names cb us in + FStarC_Compiler_Util.bind_opt uu___5 + (fun us1 -> + let uu___6 = + FStarC_TypeChecker_NBETerm.unembed e_term cb t1 in + FStarC_Compiler_Util.bind_opt uu___6 + (fun t2 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Sg_Val (nm1, us1, t2))))) + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_Unk.FStarC_Reflection_V1_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.Unk + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded sigelt_view: %s" + uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_sigelt_view unembed_sigelt_view + FStarC_Reflection_V1_Constants.fstar_refl_sigelt_view_fv +let (e_name : Prims.string Prims.list FStarC_TypeChecker_NBETerm.embedding) = + FStarC_TypeChecker_NBETerm.e_list FStarC_TypeChecker_NBETerm.e_string +let (e_qualifier : + FStarC_Reflection_V1_Data.qualifier FStarC_TypeChecker_NBETerm.embedding) = + let embed cb q = + match q with + | FStarC_Reflection_V1_Data.Assumption -> + mkConstruct + FStarC_Reflection_V1_Constants.ref_qual_Assumption.FStarC_Reflection_V1_Constants.fv + [] [] + | FStarC_Reflection_V1_Data.New -> + mkConstruct + FStarC_Reflection_V1_Constants.ref_qual_New.FStarC_Reflection_V1_Constants.fv + [] [] + | FStarC_Reflection_V1_Data.Private -> + mkConstruct + FStarC_Reflection_V1_Constants.ref_qual_Private.FStarC_Reflection_V1_Constants.fv + [] [] + | FStarC_Reflection_V1_Data.Unfold_for_unification_and_vcgen -> + mkConstruct + FStarC_Reflection_V1_Constants.ref_qual_Unfold_for_unification_and_vcgen.FStarC_Reflection_V1_Constants.fv + [] [] + | FStarC_Reflection_V1_Data.Visible_default -> + mkConstruct + FStarC_Reflection_V1_Constants.ref_qual_Visible_default.FStarC_Reflection_V1_Constants.fv + [] [] + | FStarC_Reflection_V1_Data.Irreducible -> + mkConstruct + FStarC_Reflection_V1_Constants.ref_qual_Irreducible.FStarC_Reflection_V1_Constants.fv + [] [] + | FStarC_Reflection_V1_Data.Inline_for_extraction -> + mkConstruct + FStarC_Reflection_V1_Constants.ref_qual_Inline_for_extraction.FStarC_Reflection_V1_Constants.fv + [] [] + | FStarC_Reflection_V1_Data.NoExtract -> + mkConstruct + FStarC_Reflection_V1_Constants.ref_qual_NoExtract.FStarC_Reflection_V1_Constants.fv + [] [] + | FStarC_Reflection_V1_Data.Noeq -> + mkConstruct + FStarC_Reflection_V1_Constants.ref_qual_Noeq.FStarC_Reflection_V1_Constants.fv + [] [] + | FStarC_Reflection_V1_Data.Unopteq -> + mkConstruct + FStarC_Reflection_V1_Constants.ref_qual_Unopteq.FStarC_Reflection_V1_Constants.fv + [] [] + | FStarC_Reflection_V1_Data.TotalEffect -> + mkConstruct + FStarC_Reflection_V1_Constants.ref_qual_TotalEffect.FStarC_Reflection_V1_Constants.fv + [] [] + | FStarC_Reflection_V1_Data.Logic -> + mkConstruct + FStarC_Reflection_V1_Constants.ref_qual_Logic.FStarC_Reflection_V1_Constants.fv + [] [] + | FStarC_Reflection_V1_Data.Reifiable -> + mkConstruct + FStarC_Reflection_V1_Constants.ref_qual_Reifiable.FStarC_Reflection_V1_Constants.fv + [] [] + | FStarC_Reflection_V1_Data.ExceptionConstructor -> + mkConstruct + FStarC_Reflection_V1_Constants.ref_qual_ExceptionConstructor.FStarC_Reflection_V1_Constants.fv + [] [] + | FStarC_Reflection_V1_Data.HasMaskedEffect -> + mkConstruct + FStarC_Reflection_V1_Constants.ref_qual_HasMaskedEffect.FStarC_Reflection_V1_Constants.fv + [] [] + | FStarC_Reflection_V1_Data.Effect -> + mkConstruct + FStarC_Reflection_V1_Constants.ref_qual_Effect.FStarC_Reflection_V1_Constants.fv + [] [] + | FStarC_Reflection_V1_Data.OnlyName -> + mkConstruct + FStarC_Reflection_V1_Constants.ref_qual_OnlyName.FStarC_Reflection_V1_Constants.fv + [] [] + | FStarC_Reflection_V1_Data.Reflectable l -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_name cb l in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V1_Constants.ref_qual_Reflectable.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.Discriminator l -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_name cb l in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V1_Constants.ref_qual_Discriminator.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.Action l -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_name cb l in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V1_Constants.ref_qual_Action.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.Projector (l, i) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_name cb l in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_TypeChecker_NBETerm.embed e_ident cb i in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V1_Constants.ref_qual_Projector.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.RecordType (ids1, ids2) -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_list e_ident) cb ids1 in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_list e_ident) cb ids2 in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V1_Constants.ref_qual_RecordType.FStarC_Reflection_V1_Constants.fv + [] uu___ + | FStarC_Reflection_V1_Data.RecordConstructor (ids1, ids2) -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_list e_ident) cb ids1 in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_list e_ident) cb ids2 in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V1_Constants.ref_qual_RecordConstructor.FStarC_Reflection_V1_Constants.fv + [] uu___ in + let unembed cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_Assumption.FStarC_Reflection_V1_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.Assumption + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_New.FStarC_Reflection_V1_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.New + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_Private.FStarC_Reflection_V1_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.Private + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_Unfold_for_unification_and_vcgen.FStarC_Reflection_V1_Constants.lid + -> + FStar_Pervasives_Native.Some + FStarC_Reflection_V1_Data.Unfold_for_unification_and_vcgen + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_Visible_default.FStarC_Reflection_V1_Constants.lid + -> + FStar_Pervasives_Native.Some + FStarC_Reflection_V1_Data.Visible_default + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_Irreducible.FStarC_Reflection_V1_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.Irreducible + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_Inline_for_extraction.FStarC_Reflection_V1_Constants.lid + -> + FStar_Pervasives_Native.Some + FStarC_Reflection_V1_Data.Inline_for_extraction + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_NoExtract.FStarC_Reflection_V1_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.NoExtract + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_Noeq.FStarC_Reflection_V1_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.Noeq + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_Unopteq.FStarC_Reflection_V1_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.Unopteq + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_TotalEffect.FStarC_Reflection_V1_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.TotalEffect + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_Logic.FStarC_Reflection_V1_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.Logic + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_Reifiable.FStarC_Reflection_V1_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.Reifiable + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_ExceptionConstructor.FStarC_Reflection_V1_Constants.lid + -> + FStar_Pervasives_Native.Some + FStarC_Reflection_V1_Data.ExceptionConstructor + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_HasMaskedEffect.FStarC_Reflection_V1_Constants.lid + -> + FStar_Pervasives_Native.Some + FStarC_Reflection_V1_Data.HasMaskedEffect + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_Effect.FStarC_Reflection_V1_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.Effect + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_OnlyName.FStarC_Reflection_V1_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V1_Data.OnlyName + | FStarC_TypeChecker_NBETerm.Construct (fv, [], (l, uu___)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_Reflectable.FStarC_Reflection_V1_Constants.lid + -> + let uu___1 = FStarC_TypeChecker_NBETerm.unembed e_name cb l in + FStarC_Compiler_Util.bind_opt uu___1 + (fun l1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Reflectable l1)) + | FStarC_TypeChecker_NBETerm.Construct (fv, [], (l, uu___)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_Discriminator.FStarC_Reflection_V1_Constants.lid + -> + let uu___1 = FStarC_TypeChecker_NBETerm.unembed e_name cb l in + FStarC_Compiler_Util.bind_opt uu___1 + (fun l1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Discriminator l1)) + | FStarC_TypeChecker_NBETerm.Construct (fv, [], (l, uu___)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_Action.FStarC_Reflection_V1_Constants.lid + -> + let uu___1 = FStarC_TypeChecker_NBETerm.unembed e_name cb l in + FStarC_Compiler_Util.bind_opt uu___1 + (fun l1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Action l1)) + | FStarC_TypeChecker_NBETerm.Construct + (fv, [], (i, uu___)::(l, uu___1)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_Projector.FStarC_Reflection_V1_Constants.lid + -> + let uu___2 = FStarC_TypeChecker_NBETerm.unembed e_ident cb i in + FStarC_Compiler_Util.bind_opt uu___2 + (fun i1 -> + let uu___3 = FStarC_TypeChecker_NBETerm.unembed e_name cb l in + FStarC_Compiler_Util.bind_opt uu___3 + (fun l1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.Projector (l1, i1)))) + | FStarC_TypeChecker_NBETerm.Construct + (fv, [], (ids2, uu___)::(ids1, uu___1)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_RecordType.FStarC_Reflection_V1_Constants.lid + -> + let uu___2 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_list e_ident) cb ids1 in + FStarC_Compiler_Util.bind_opt uu___2 + (fun ids11 -> + let uu___3 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_list e_ident) cb ids2 in + FStarC_Compiler_Util.bind_opt uu___3 + (fun ids21 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.RecordType (ids11, ids21)))) + | FStarC_TypeChecker_NBETerm.Construct + (fv, [], (ids2, uu___)::(ids1, uu___1)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V1_Constants.ref_qual_RecordConstructor.FStarC_Reflection_V1_Constants.lid + -> + let uu___2 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_list e_ident) cb ids1 in + FStarC_Compiler_Util.bind_opt uu___2 + (fun ids11 -> + let uu___3 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_list e_ident) cb ids2 in + FStarC_Compiler_Util.bind_opt uu___3 + (fun ids21 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V1_Data.RecordConstructor + (ids11, ids21)))) + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded qualifier: %s" + uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + FStarC_TypeChecker_NBETerm.mk_emb embed unembed + (fun uu___ -> + mkConstruct FStarC_Reflection_V1_Constants.fstar_refl_qualifier_fv [] + []) + (fun uu___ -> + fv_as_emb_typ FStarC_Reflection_V1_Constants.fstar_refl_qualifier_fv) +let (e_qualifiers : + FStarC_Reflection_V1_Data.qualifier Prims.list + FStarC_TypeChecker_NBETerm.embedding) + = FStarC_TypeChecker_NBETerm.e_list e_qualifier +let (e_vconfig : + FStarC_Compiler_Order.order FStarC_TypeChecker_NBETerm.embedding) = + let emb cb o = failwith "emb vconfig NBE" in + let unemb cb t = failwith "unemb vconfig NBE" in + let uu___ = + FStarC_Syntax_Syntax.lid_as_fv FStarC_Parser_Const.vconfig_lid + FStar_Pervasives_Native.None in + mk_emb' emb unemb uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Reflection_V2_Builtins.ml b/ocaml/fstar-lib/generated/FStarC_Reflection_V2_Builtins.ml new file mode 100644 index 00000000000..8b319c89e2b --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Reflection_V2_Builtins.ml @@ -0,0 +1,1502 @@ +open Prims +let (get_env : unit -> FStarC_TypeChecker_Env.env) = + fun uu___ -> + let uu___1 = + FStarC_Compiler_Effect.op_Bang + FStarC_TypeChecker_Normalize.reflection_env_hook in + match uu___1 with + | FStar_Pervasives_Native.None -> + failwith "impossible: env_hook unset in reflection" + | FStar_Pervasives_Native.Some e -> e +let (inspect_bqual : + FStarC_Syntax_Syntax.bqual -> FStarC_Reflection_V2_Data.aqualv) = + fun bq -> + match bq with + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Implicit uu___) -> + FStarC_Reflection_V2_Data.Q_Implicit + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Meta t) -> + FStarC_Reflection_V2_Data.Q_Meta t + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Equality) -> + FStarC_Reflection_V2_Data.Q_Equality + | FStar_Pervasives_Native.None -> FStarC_Reflection_V2_Data.Q_Explicit +let (inspect_aqual : + FStarC_Syntax_Syntax.aqual -> FStarC_Reflection_V2_Data.aqualv) = + fun aq -> + match aq with + | FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = uu___;_} + -> FStarC_Reflection_V2_Data.Q_Implicit + | uu___ -> FStarC_Reflection_V2_Data.Q_Explicit +let (pack_bqual : + FStarC_Reflection_V2_Data.aqualv -> FStarC_Syntax_Syntax.bqual) = + fun aqv -> + match aqv with + | FStarC_Reflection_V2_Data.Q_Implicit -> + FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Implicit false) + | FStarC_Reflection_V2_Data.Q_Meta t -> + FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Meta t) + | FStarC_Reflection_V2_Data.Q_Equality -> + FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.Equality + | FStarC_Reflection_V2_Data.Q_Explicit -> FStar_Pervasives_Native.None +let (pack_aqual : + FStarC_Reflection_V2_Data.aqualv -> FStarC_Syntax_Syntax.aqual) = + fun aqv -> + match aqv with + | FStarC_Reflection_V2_Data.Q_Implicit -> + FStarC_Syntax_Syntax.as_aqual_implicit true + | uu___ -> FStar_Pervasives_Native.None +let (inspect_fv : FStarC_Syntax_Syntax.fv -> Prims.string Prims.list) = + fun fv -> + let uu___ = FStarC_Syntax_Syntax.lid_of_fv fv in + FStarC_Ident.path_of_lid uu___ +let (pack_fv : Prims.string Prims.list -> FStarC_Syntax_Syntax.fv) = + fun ns -> + let lid = FStarC_Parser_Const.p2l ns in + let fallback uu___ = + let quals = + let uu___1 = FStarC_Ident.lid_equals lid FStarC_Parser_Const.cons_lid in + if uu___1 + then FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.Data_ctor + else + (let uu___3 = + FStarC_Ident.lid_equals lid FStarC_Parser_Const.nil_lid in + if uu___3 + then FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.Data_ctor + else + (let uu___5 = + FStarC_Ident.lid_equals lid FStarC_Parser_Const.some_lid in + if uu___5 + then + FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.Data_ctor + else + (let uu___7 = + FStarC_Ident.lid_equals lid FStarC_Parser_Const.none_lid in + if uu___7 + then + FStar_Pervasives_Native.Some + FStarC_Syntax_Syntax.Data_ctor + else FStar_Pervasives_Native.None))) in + let uu___1 = FStarC_Parser_Const.p2l ns in + FStarC_Syntax_Syntax.lid_as_fv uu___1 quals in + let uu___ = + FStarC_Compiler_Effect.op_Bang + FStarC_TypeChecker_Normalize.reflection_env_hook in + match uu___ with + | FStar_Pervasives_Native.None -> fallback () + | FStar_Pervasives_Native.Some env -> + let qninfo = FStarC_TypeChecker_Env.lookup_qname env lid in + (match qninfo with + | FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr (se, _us), _rng) -> + let quals = FStarC_Syntax_DsEnv.fv_qual_of_se se in + let uu___1 = FStarC_Parser_Const.p2l ns in + FStarC_Syntax_Syntax.lid_as_fv uu___1 quals + | uu___1 -> fallback ()) +let rec last : 'a . 'a Prims.list -> 'a = + fun l -> + match l with + | [] -> failwith "last: empty list" + | x::[] -> x + | uu___::xs -> last xs +let rec init : 'a . 'a Prims.list -> 'a Prims.list = + fun l -> + match l with + | [] -> failwith "init: empty list" + | x::[] -> [] + | x::xs -> let uu___ = init xs in x :: uu___ +let (inspect_const : + FStarC_Syntax_Syntax.sconst -> FStarC_Reflection_V2_Data.vconst) = + fun c -> + match c with + | FStarC_Const.Const_unit -> FStarC_Reflection_V2_Data.C_Unit + | FStarC_Const.Const_int (s, uu___) -> + let uu___1 = FStarC_BigInt.big_int_of_string s in + FStarC_Reflection_V2_Data.C_Int uu___1 + | FStarC_Const.Const_bool (true) -> FStarC_Reflection_V2_Data.C_True + | FStarC_Const.Const_bool (false) -> FStarC_Reflection_V2_Data.C_False + | FStarC_Const.Const_string (s, uu___) -> + FStarC_Reflection_V2_Data.C_String s + | FStarC_Const.Const_range r -> FStarC_Reflection_V2_Data.C_Range r + | FStarC_Const.Const_reify uu___ -> FStarC_Reflection_V2_Data.C_Reify + | FStarC_Const.Const_reflect l -> + let uu___ = FStarC_Ident.path_of_lid l in + FStarC_Reflection_V2_Data.C_Reflect uu___ + | FStarC_Const.Const_real s -> FStarC_Reflection_V2_Data.C_Real s + | uu___ -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_const c in + FStarC_Compiler_Util.format1 "unknown constant: %s" uu___2 in + failwith uu___1 +let (inspect_universe : + FStarC_Syntax_Syntax.universe -> FStarC_Reflection_V2_Data.universe_view) = + fun u -> + match u with + | FStarC_Syntax_Syntax.U_zero -> FStarC_Reflection_V2_Data.Uv_Zero + | FStarC_Syntax_Syntax.U_succ u1 -> FStarC_Reflection_V2_Data.Uv_Succ u1 + | FStarC_Syntax_Syntax.U_max us -> FStarC_Reflection_V2_Data.Uv_Max us + | FStarC_Syntax_Syntax.U_bvar n -> + let uu___ = FStarC_BigInt.of_int_fs n in + FStarC_Reflection_V2_Data.Uv_BVar uu___ + | FStarC_Syntax_Syntax.U_name i -> FStarC_Reflection_V2_Data.Uv_Name i + | FStarC_Syntax_Syntax.U_unif u1 -> FStarC_Reflection_V2_Data.Uv_Unif u1 + | FStarC_Syntax_Syntax.U_unknown -> FStarC_Reflection_V2_Data.Uv_Unk +let (pack_universe : + FStarC_Reflection_V2_Data.universe_view -> FStarC_Syntax_Syntax.universe) = + fun uv -> + match uv with + | FStarC_Reflection_V2_Data.Uv_Zero -> FStarC_Syntax_Syntax.U_zero + | FStarC_Reflection_V2_Data.Uv_Succ u -> FStarC_Syntax_Syntax.U_succ u + | FStarC_Reflection_V2_Data.Uv_Max us -> FStarC_Syntax_Syntax.U_max us + | FStarC_Reflection_V2_Data.Uv_BVar n -> + let uu___ = FStarC_BigInt.to_int_fs n in + FStarC_Syntax_Syntax.U_bvar uu___ + | FStarC_Reflection_V2_Data.Uv_Name i -> FStarC_Syntax_Syntax.U_name i + | FStarC_Reflection_V2_Data.Uv_Unif u -> FStarC_Syntax_Syntax.U_unif u + | FStarC_Reflection_V2_Data.Uv_Unk -> FStarC_Syntax_Syntax.U_unknown +let rec (inspect_pat : + FStarC_Syntax_Syntax.pat -> FStarC_Reflection_V2_Data.pattern) = + fun p -> + match p.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_constant c -> + let uu___ = inspect_const c in + FStarC_Reflection_V2_Data.Pat_Constant uu___ + | FStarC_Syntax_Syntax.Pat_cons (fv, us_opt, ps) -> + let uu___ = + FStarC_Compiler_List.map + (fun uu___1 -> + match uu___1 with + | (p1, b) -> let uu___2 = inspect_pat p1 in (uu___2, b)) ps in + FStarC_Reflection_V2_Data.Pat_Cons (fv, us_opt, uu___) + | FStarC_Syntax_Syntax.Pat_var bv -> + let uu___ = + let uu___1 = + FStarC_Ident.string_of_id bv.FStarC_Syntax_Syntax.ppname in + FStarC_Compiler_Sealed.seal uu___1 in + FStarC_Reflection_V2_Data.Pat_Var + ((FStarC_Compiler_Sealed.seal bv.FStarC_Syntax_Syntax.sort), uu___) + | FStarC_Syntax_Syntax.Pat_dot_term eopt -> + FStarC_Reflection_V2_Data.Pat_Dot_Term eopt +let rec (inspect_ln : + FStarC_Syntax_Syntax.term -> FStarC_Reflection_V2_Data.term_view) = + fun t -> + let t1 = FStarC_Syntax_Subst.compress_subst t in + match t1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t2; FStarC_Syntax_Syntax.meta = uu___;_} + -> inspect_ln t2 + | FStarC_Syntax_Syntax.Tm_name bv -> FStarC_Reflection_V2_Data.Tv_Var bv + | FStarC_Syntax_Syntax.Tm_bvar bv -> FStarC_Reflection_V2_Data.Tv_BVar bv + | FStarC_Syntax_Syntax.Tm_fvar fv -> FStarC_Reflection_V2_Data.Tv_FVar fv + | FStarC_Syntax_Syntax.Tm_uinst (t2, us) -> + (match t2.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + FStarC_Reflection_V2_Data.Tv_UInst (fv, us) + | uu___ -> + failwith "Reflection::inspect_ln: uinst for a non-fvar node") + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t2; + FStarC_Syntax_Syntax.asc = (FStar_Pervasives.Inl ty, tacopt, eq); + FStarC_Syntax_Syntax.eff_opt = uu___;_} + -> FStarC_Reflection_V2_Data.Tv_AscribedT (t2, ty, tacopt, eq) + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t2; + FStarC_Syntax_Syntax.asc = (FStar_Pervasives.Inr cty, tacopt, eq); + FStarC_Syntax_Syntax.eff_opt = uu___;_} + -> FStarC_Reflection_V2_Data.Tv_AscribedC (t2, cty, tacopt, eq) + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = uu___; FStarC_Syntax_Syntax.args = [];_} + -> failwith "inspect_ln: empty arguments on Tm_app" + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = hd; FStarC_Syntax_Syntax.args = args;_} + -> + let uu___ = last args in + (match uu___ with + | (a, q) -> + let q' = inspect_aqual q in + let uu___1 = + let uu___2 = + let uu___3 = init args in + FStarC_Syntax_Util.mk_app hd uu___3 in + (uu___2, (a, q')) in + FStarC_Reflection_V2_Data.Tv_App uu___1) + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = []; FStarC_Syntax_Syntax.body = uu___; + FStarC_Syntax_Syntax.rc_opt = uu___1;_} + -> failwith "inspect_ln: empty arguments on Tm_abs" + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = b::bs; FStarC_Syntax_Syntax.body = t2; + FStarC_Syntax_Syntax.rc_opt = k;_} + -> + let body = + match bs with + | [] -> t2 + | bs1 -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs = bs1; + FStarC_Syntax_Syntax.body = t2; + FStarC_Syntax_Syntax.rc_opt = k + }) t2.FStarC_Syntax_Syntax.pos in + FStarC_Reflection_V2_Data.Tv_Abs (b, body) + | FStarC_Syntax_Syntax.Tm_type u -> FStarC_Reflection_V2_Data.Tv_Type u + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = []; FStarC_Syntax_Syntax.comp = uu___;_} + -> failwith "inspect_ln: empty binders on arrow" + | FStarC_Syntax_Syntax.Tm_arrow uu___ -> + let uu___1 = FStarC_Syntax_Util.arrow_one_ln t1 in + (match uu___1 with + | FStar_Pervasives_Native.Some (b, c) -> + FStarC_Reflection_V2_Data.Tv_Arrow (b, c) + | FStar_Pervasives_Native.None -> failwith "impossible") + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = bv; FStarC_Syntax_Syntax.phi = t2;_} -> + let uu___ = + let uu___1 = FStarC_Syntax_Syntax.mk_binder bv in (uu___1, t2) in + FStarC_Reflection_V2_Data.Tv_Refine uu___ + | FStarC_Syntax_Syntax.Tm_constant c -> + let uu___ = inspect_const c in + FStarC_Reflection_V2_Data.Tv_Const uu___ + | FStarC_Syntax_Syntax.Tm_uvar (ctx_u, s) -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Syntax_Unionfind.uvar_unique_id + ctx_u.FStarC_Syntax_Syntax.ctx_uvar_head in + FStarC_BigInt.of_int_fs uu___2 in + (uu___1, (ctx_u, s)) in + FStarC_Reflection_V2_Data.Tv_Uvar uu___ + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (isrec, lb::[]); + FStarC_Syntax_Syntax.body1 = t2;_} + -> + if lb.FStarC_Syntax_Syntax.lbunivs <> [] + then FStarC_Reflection_V2_Data.Tv_Unsupp + else + (match lb.FStarC_Syntax_Syntax.lbname with + | FStar_Pervasives.Inr uu___1 -> + FStarC_Reflection_V2_Data.Tv_Unsupp + | FStar_Pervasives.Inl bv -> + let uu___1 = + let uu___2 = FStarC_Syntax_Syntax.mk_binder bv in + (isrec, (lb.FStarC_Syntax_Syntax.lbattrs), uu___2, + (lb.FStarC_Syntax_Syntax.lbdef), t2) in + FStarC_Reflection_V2_Data.Tv_Let uu___1) + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = t2; + FStarC_Syntax_Syntax.ret_opt = ret_opt; + FStarC_Syntax_Syntax.brs = brs; + FStarC_Syntax_Syntax.rc_opt1 = uu___;_} + -> + let brs1 = + FStarC_Compiler_List.map + (fun uu___1 -> + match uu___1 with + | (pat, uu___2, t3) -> + let uu___3 = inspect_pat pat in (uu___3, t3)) brs in + FStarC_Reflection_V2_Data.Tv_Match (t2, ret_opt, brs1) + | FStarC_Syntax_Syntax.Tm_unknown -> FStarC_Reflection_V2_Data.Tv_Unknown + | FStarC_Syntax_Syntax.Tm_lazy i -> + let uu___ = FStarC_Syntax_Util.unfold_lazy i in inspect_ln uu___ + | uu___ -> + ((let uu___2 = + let uu___3 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t1 in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.format2 + "inspect_ln: outside of expected syntax (%s, %s)" uu___3 uu___4 in + FStarC_Errors.log_issue (FStarC_Syntax_Syntax.has_range_syntax ()) + t1 FStarC_Errors_Codes.Warning_CantInspect () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStarC_Reflection_V2_Data.Tv_Unsupp) +let (inspect_comp : + FStarC_Syntax_Syntax.comp -> FStarC_Reflection_V2_Data.comp_view) = + fun c -> + let get_dec flags = + let uu___ = + FStarC_Compiler_List.tryFind + (fun uu___1 -> + match uu___1 with + | FStarC_Syntax_Syntax.DECREASES uu___2 -> true + | uu___2 -> false) flags in + match uu___ with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.DECREASES + (FStarC_Syntax_Syntax.Decreases_lex ts)) -> ts + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.DECREASES + (FStarC_Syntax_Syntax.Decreases_wf uu___1)) -> + ((let uu___3 = + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_comp c in + FStarC_Compiler_Util.format1 + "inspect_comp: inspecting comp with wf decreases clause is not yet supported: %s skipping the decreases clause" + uu___4 in + FStarC_Errors.log_issue + (FStarC_Syntax_Syntax.has_range_syntax ()) c + FStarC_Errors_Codes.Warning_CantInspect () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___3)); + []) + | uu___1 -> failwith "Impossible!" in + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total t -> FStarC_Reflection_V2_Data.C_Total t + | FStarC_Syntax_Syntax.GTotal t -> FStarC_Reflection_V2_Data.C_GTotal t + | FStarC_Syntax_Syntax.Comp ct -> + let uopt = + if + (FStarC_Compiler_List.length ct.FStarC_Syntax_Syntax.comp_univs) + = Prims.int_zero + then FStarC_Syntax_Syntax.U_unknown + else FStarC_Compiler_List.hd ct.FStarC_Syntax_Syntax.comp_univs in + let uu___ = + FStarC_Ident.lid_equals ct.FStarC_Syntax_Syntax.effect_name + FStarC_Parser_Const.effect_Lemma_lid in + if uu___ + then + (match ct.FStarC_Syntax_Syntax.effect_args with + | (pre, uu___1)::(post, uu___2)::(pats, uu___3)::uu___4 -> + FStarC_Reflection_V2_Data.C_Lemma (pre, post, pats) + | uu___1 -> + failwith "inspect_comp: Lemma does not have enough arguments?") + else + (let inspect_arg uu___2 = + match uu___2 with + | (a, q) -> let uu___3 = inspect_aqual q in (a, uu___3) in + let uu___2 = + let uu___3 = + FStarC_Ident.path_of_lid ct.FStarC_Syntax_Syntax.effect_name in + let uu___4 = + FStarC_Compiler_List.map inspect_arg + ct.FStarC_Syntax_Syntax.effect_args in + let uu___5 = get_dec ct.FStarC_Syntax_Syntax.flags in + ((ct.FStarC_Syntax_Syntax.comp_univs), uu___3, + (ct.FStarC_Syntax_Syntax.result_typ), uu___4, uu___5) in + FStarC_Reflection_V2_Data.C_Eff uu___2) +let (pack_comp : + FStarC_Reflection_V2_Data.comp_view -> FStarC_Syntax_Syntax.comp) = + fun cv -> + let urefl_to_univs u = + if u = FStarC_Syntax_Syntax.U_unknown then [] else [u] in + let urefl_to_univ_opt u = + if u = FStarC_Syntax_Syntax.U_unknown + then FStar_Pervasives_Native.None + else FStar_Pervasives_Native.Some u in + match cv with + | FStarC_Reflection_V2_Data.C_Total t -> FStarC_Syntax_Syntax.mk_Total t + | FStarC_Reflection_V2_Data.C_GTotal t -> + FStarC_Syntax_Syntax.mk_GTotal t + | FStarC_Reflection_V2_Data.C_Lemma (pre, post, pats) -> + let ct = + let uu___ = + let uu___1 = FStarC_Syntax_Syntax.as_arg pre in + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.as_arg post in + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.as_arg pats in [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + { + FStarC_Syntax_Syntax.comp_univs = []; + FStarC_Syntax_Syntax.effect_name = + FStarC_Parser_Const.effect_Lemma_lid; + FStarC_Syntax_Syntax.result_typ = FStarC_Syntax_Syntax.t_unit; + FStarC_Syntax_Syntax.effect_args = uu___; + FStarC_Syntax_Syntax.flags = [] + } in + FStarC_Syntax_Syntax.mk_Comp ct + | FStarC_Reflection_V2_Data.C_Eff (us, ef, res, args, decrs) -> + let pack_arg uu___ = + match uu___ with + | (a, q) -> let uu___1 = pack_aqual q in (a, uu___1) in + let flags = + if (FStarC_Compiler_List.length decrs) = Prims.int_zero + then [] + else + [FStarC_Syntax_Syntax.DECREASES + (FStarC_Syntax_Syntax.Decreases_lex decrs)] in + let ct = + let uu___ = + FStarC_Ident.lid_of_path ef FStarC_Compiler_Range_Type.dummyRange in + let uu___1 = FStarC_Compiler_List.map pack_arg args in + { + FStarC_Syntax_Syntax.comp_univs = us; + FStarC_Syntax_Syntax.effect_name = uu___; + FStarC_Syntax_Syntax.result_typ = res; + FStarC_Syntax_Syntax.effect_args = uu___1; + FStarC_Syntax_Syntax.flags = flags + } in + FStarC_Syntax_Syntax.mk_Comp ct +let (pack_const : + FStarC_Reflection_V2_Data.vconst -> FStarC_Syntax_Syntax.sconst) = + fun c -> + match c with + | FStarC_Reflection_V2_Data.C_Unit -> FStarC_Const.Const_unit + | FStarC_Reflection_V2_Data.C_Int i -> + let uu___ = + let uu___1 = FStarC_BigInt.string_of_big_int i in + (uu___1, FStar_Pervasives_Native.None) in + FStarC_Const.Const_int uu___ + | FStarC_Reflection_V2_Data.C_True -> FStarC_Const.Const_bool true + | FStarC_Reflection_V2_Data.C_False -> FStarC_Const.Const_bool false + | FStarC_Reflection_V2_Data.C_String s -> + FStarC_Const.Const_string (s, FStarC_Compiler_Range_Type.dummyRange) + | FStarC_Reflection_V2_Data.C_Range r -> FStarC_Const.Const_range r + | FStarC_Reflection_V2_Data.C_Reify -> + FStarC_Const.Const_reify FStar_Pervasives_Native.None + | FStarC_Reflection_V2_Data.C_Reflect ns -> + let uu___ = + FStarC_Ident.lid_of_path ns FStarC_Compiler_Range_Type.dummyRange in + FStarC_Const.Const_reflect uu___ + | FStarC_Reflection_V2_Data.C_Real r -> FStarC_Const.Const_real r +let rec (pack_pat : + FStarC_Reflection_V2_Data.pattern -> FStarC_Syntax_Syntax.pat) = + fun p -> + let wrap v = + { + FStarC_Syntax_Syntax.v = v; + FStarC_Syntax_Syntax.p = FStarC_Compiler_Range_Type.dummyRange + } in + match p with + | FStarC_Reflection_V2_Data.Pat_Constant c -> + let uu___ = + let uu___1 = pack_const c in + FStarC_Syntax_Syntax.Pat_constant uu___1 in + wrap uu___ + | FStarC_Reflection_V2_Data.Pat_Cons (head, univs, subpats) -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with + | (p1, b) -> let uu___4 = pack_pat p1 in (uu___4, b)) + subpats in + (head, univs, uu___2) in + FStarC_Syntax_Syntax.Pat_cons uu___1 in + wrap uu___ + | FStarC_Reflection_V2_Data.Pat_Var (sort, ppname) -> + let bv = + FStarC_Syntax_Syntax.gen_bv (FStarC_Compiler_Sealed.unseal ppname) + FStar_Pervasives_Native.None (FStarC_Compiler_Sealed.unseal sort) in + wrap (FStarC_Syntax_Syntax.Pat_var bv) + | FStarC_Reflection_V2_Data.Pat_Dot_Term eopt -> + wrap (FStarC_Syntax_Syntax.Pat_dot_term eopt) +let (pack_ln : + FStarC_Reflection_V2_Data.term_view -> FStarC_Syntax_Syntax.term) = + fun tv -> + match tv with + | FStarC_Reflection_V2_Data.Tv_Var bv -> + FStarC_Syntax_Syntax.bv_to_name + { + FStarC_Syntax_Syntax.ppname = (bv.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = (bv.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = FStarC_Syntax_Syntax.tun + } + | FStarC_Reflection_V2_Data.Tv_BVar bv -> + FStarC_Syntax_Syntax.bv_to_tm + { + FStarC_Syntax_Syntax.ppname = (bv.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = (bv.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = FStarC_Syntax_Syntax.tun + } + | FStarC_Reflection_V2_Data.Tv_FVar fv -> + FStarC_Syntax_Syntax.fv_to_tm fv + | FStarC_Reflection_V2_Data.Tv_UInst (fv, us) -> + let uu___ = FStarC_Syntax_Syntax.fv_to_tm fv in + FStarC_Syntax_Syntax.mk_Tm_uinst uu___ us + | FStarC_Reflection_V2_Data.Tv_App (l, (r, q)) -> + let q' = pack_aqual q in FStarC_Syntax_Util.mk_app l [(r, q')] + | FStarC_Reflection_V2_Data.Tv_Abs (b, t) -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs = [b]; + FStarC_Syntax_Syntax.body = t; + FStarC_Syntax_Syntax.rc_opt = FStar_Pervasives_Native.None + }) t.FStarC_Syntax_Syntax.pos + | FStarC_Reflection_V2_Data.Tv_Arrow (b, c) -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = [b]; FStarC_Syntax_Syntax.comp = c + }) c.FStarC_Syntax_Syntax.pos + | FStarC_Reflection_V2_Data.Tv_Type u -> + FStarC_Syntax_Syntax.mk (FStarC_Syntax_Syntax.Tm_type u) + FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V2_Data.Tv_Refine (b, t) -> + let bv = b.FStarC_Syntax_Syntax.binder_bv in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = bv; FStarC_Syntax_Syntax.phi = t }) + t.FStarC_Syntax_Syntax.pos + | FStarC_Reflection_V2_Data.Tv_Const c -> + let uu___ = + let uu___1 = pack_const c in + FStarC_Syntax_Syntax.Tm_constant uu___1 in + FStarC_Syntax_Syntax.mk uu___ FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V2_Data.Tv_Uvar (u, ctx_u_s) -> + FStarC_Syntax_Syntax.mk (FStarC_Syntax_Syntax.Tm_uvar ctx_u_s) + FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V2_Data.Tv_Let (isrec, attrs, b, t1, t2) -> + let bv = b.FStarC_Syntax_Syntax.binder_bv in + let lb = + FStarC_Syntax_Util.mk_letbinding (FStar_Pervasives.Inl bv) [] + bv.FStarC_Syntax_Syntax.sort FStarC_Parser_Const.effect_Tot_lid + t1 attrs FStarC_Compiler_Range_Type.dummyRange in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = (isrec, [lb]); + FStarC_Syntax_Syntax.body1 = t2 + }) FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V2_Data.Tv_Match (t, ret_opt, brs) -> + let brs1 = + FStarC_Compiler_List.map + (fun uu___ -> + match uu___ with + | (pat, t1) -> + let uu___1 = pack_pat pat in + (uu___1, FStar_Pervasives_Native.None, t1)) brs in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_match + { + FStarC_Syntax_Syntax.scrutinee = t; + FStarC_Syntax_Syntax.ret_opt = ret_opt; + FStarC_Syntax_Syntax.brs = brs1; + FStarC_Syntax_Syntax.rc_opt1 = FStar_Pervasives_Native.None + }) FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V2_Data.Tv_AscribedT (e, t, tacopt, use_eq) -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_ascribed + { + FStarC_Syntax_Syntax.tm = e; + FStarC_Syntax_Syntax.asc = + ((FStar_Pervasives.Inl t), tacopt, use_eq); + FStarC_Syntax_Syntax.eff_opt = FStar_Pervasives_Native.None + }) FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V2_Data.Tv_AscribedC (e, c, tacopt, use_eq) -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_ascribed + { + FStarC_Syntax_Syntax.tm = e; + FStarC_Syntax_Syntax.asc = + ((FStar_Pervasives.Inr c), tacopt, use_eq); + FStarC_Syntax_Syntax.eff_opt = FStar_Pervasives_Native.None + }) FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V2_Data.Tv_Unknown -> + FStarC_Syntax_Syntax.mk FStarC_Syntax_Syntax.Tm_unknown + FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V2_Data.Tv_Unsupp -> + (FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_CantInspect () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "packing a Tv_Unsupp into Tm_unknown"); + FStarC_Syntax_Syntax.mk FStarC_Syntax_Syntax.Tm_unknown + FStarC_Compiler_Range_Type.dummyRange) +let (compare_bv : + FStarC_Syntax_Syntax.bv -> FStarC_Syntax_Syntax.bv -> FStar_Order.order) = + fun x -> + fun y -> + let n = FStarC_Syntax_Syntax.order_bv x y in + if n < Prims.int_zero + then FStar_Order.Lt + else if n = Prims.int_zero then FStar_Order.Eq else FStar_Order.Gt +let (compare_namedv : + FStarC_Reflection_V2_Data.namedv -> + FStarC_Reflection_V2_Data.namedv -> FStar_Order.order) + = + fun x -> + fun y -> + let n = FStarC_Syntax_Syntax.order_bv x y in + if n < Prims.int_zero + then FStar_Order.Lt + else if n = Prims.int_zero then FStar_Order.Eq else FStar_Order.Gt +let (lookup_attr_ses : + FStarC_Syntax_Syntax.term -> + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.sigelt Prims.list) + = + fun attr -> + fun env -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress_subst attr in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let uu___1 = + let uu___2 = FStarC_Syntax_Syntax.lid_of_fv fv in + FStarC_Ident.string_of_lid uu___2 in + FStarC_TypeChecker_Env.lookup_attr env uu___1 + | uu___1 -> [] +let (lookup_attr : + FStarC_Syntax_Syntax.term -> + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.fv Prims.list) + = + fun attr -> + fun env -> + let ses = lookup_attr_ses attr env in + FStarC_Compiler_List.concatMap + (fun se -> + let uu___ = FStarC_Syntax_Util.lid_of_sigelt se in + match uu___ with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some l -> + let uu___1 = + FStarC_Syntax_Syntax.lid_as_fv l + FStar_Pervasives_Native.None in + [uu___1]) ses +let (all_defs_in_env : + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.fv Prims.list) = + fun env -> + let uu___ = FStarC_TypeChecker_Env.lidents env in + FStarC_Compiler_List.map + (fun l -> FStarC_Syntax_Syntax.lid_as_fv l FStar_Pervasives_Native.None) + uu___ +let (defs_in_module : + FStarC_TypeChecker_Env.env -> + FStarC_Reflection_V2_Data.name -> FStarC_Syntax_Syntax.fv Prims.list) + = + fun env -> + fun modul -> + let uu___ = FStarC_TypeChecker_Env.lidents env in + FStarC_Compiler_List.concatMap + (fun l -> + let ns = + let uu___1 = + let uu___2 = FStarC_Ident.ids_of_lid l in init uu___2 in + FStarC_Compiler_List.map FStarC_Ident.string_of_id uu___1 in + if ns = modul + then + let uu___1 = + FStarC_Syntax_Syntax.lid_as_fv l FStar_Pervasives_Native.None in + [uu___1] + else []) uu___ +let (lookup_typ : + FStarC_TypeChecker_Env.env -> + Prims.string Prims.list -> + FStarC_Syntax_Syntax.sigelt FStar_Pervasives_Native.option) + = + fun env -> + fun ns -> + let lid = FStarC_Parser_Const.p2l ns in + FStarC_TypeChecker_Env.lookup_sigelt env lid +let (sigelt_attrs : + FStarC_Syntax_Syntax.sigelt -> FStarC_Syntax_Syntax.attribute Prims.list) = + fun se -> se.FStarC_Syntax_Syntax.sigattrs +let (set_sigelt_attrs : + FStarC_Syntax_Syntax.attribute Prims.list -> + FStarC_Syntax_Syntax.sigelt -> FStarC_Syntax_Syntax.sigelt) + = + fun attrs -> + fun se -> + { + FStarC_Syntax_Syntax.sigel = (se.FStarC_Syntax_Syntax.sigel); + FStarC_Syntax_Syntax.sigrng = (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = (se.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = attrs; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = (se.FStarC_Syntax_Syntax.sigopts) + } +let (rd_to_syntax_qual : + FStarC_Reflection_V2_Data.qualifier -> FStarC_Syntax_Syntax.qualifier) = + fun uu___ -> + match uu___ with + | FStarC_Reflection_V2_Data.Assumption -> FStarC_Syntax_Syntax.Assumption + | FStarC_Reflection_V2_Data.New -> FStarC_Syntax_Syntax.New + | FStarC_Reflection_V2_Data.Private -> FStarC_Syntax_Syntax.Private + | FStarC_Reflection_V2_Data.Unfold_for_unification_and_vcgen -> + FStarC_Syntax_Syntax.Unfold_for_unification_and_vcgen + | FStarC_Reflection_V2_Data.Visible_default -> + FStarC_Syntax_Syntax.Visible_default + | FStarC_Reflection_V2_Data.Irreducible -> + FStarC_Syntax_Syntax.Irreducible + | FStarC_Reflection_V2_Data.Inline_for_extraction -> + FStarC_Syntax_Syntax.Inline_for_extraction + | FStarC_Reflection_V2_Data.NoExtract -> FStarC_Syntax_Syntax.NoExtract + | FStarC_Reflection_V2_Data.Noeq -> FStarC_Syntax_Syntax.Noeq + | FStarC_Reflection_V2_Data.Unopteq -> FStarC_Syntax_Syntax.Unopteq + | FStarC_Reflection_V2_Data.TotalEffect -> + FStarC_Syntax_Syntax.TotalEffect + | FStarC_Reflection_V2_Data.Logic -> FStarC_Syntax_Syntax.Logic + | FStarC_Reflection_V2_Data.Reifiable -> FStarC_Syntax_Syntax.Reifiable + | FStarC_Reflection_V2_Data.Reflectable l -> + let uu___1 = + FStarC_Ident.lid_of_path l FStarC_Compiler_Range_Type.dummyRange in + FStarC_Syntax_Syntax.Reflectable uu___1 + | FStarC_Reflection_V2_Data.Discriminator l -> + let uu___1 = + FStarC_Ident.lid_of_path l FStarC_Compiler_Range_Type.dummyRange in + FStarC_Syntax_Syntax.Discriminator uu___1 + | FStarC_Reflection_V2_Data.Projector (l, i) -> + let uu___1 = + let uu___2 = + FStarC_Ident.lid_of_path l FStarC_Compiler_Range_Type.dummyRange in + (uu___2, i) in + FStarC_Syntax_Syntax.Projector uu___1 + | FStarC_Reflection_V2_Data.RecordType (l1, l2) -> + FStarC_Syntax_Syntax.RecordType (l1, l2) + | FStarC_Reflection_V2_Data.RecordConstructor (l1, l2) -> + FStarC_Syntax_Syntax.RecordConstructor (l1, l2) + | FStarC_Reflection_V2_Data.Action l -> + let uu___1 = + FStarC_Ident.lid_of_path l FStarC_Compiler_Range_Type.dummyRange in + FStarC_Syntax_Syntax.Action uu___1 + | FStarC_Reflection_V2_Data.ExceptionConstructor -> + FStarC_Syntax_Syntax.ExceptionConstructor + | FStarC_Reflection_V2_Data.HasMaskedEffect -> + FStarC_Syntax_Syntax.HasMaskedEffect + | FStarC_Reflection_V2_Data.Effect -> FStarC_Syntax_Syntax.Effect + | FStarC_Reflection_V2_Data.OnlyName -> FStarC_Syntax_Syntax.OnlyName +let (syntax_to_rd_qual : + FStarC_Syntax_Syntax.qualifier -> FStarC_Reflection_V2_Data.qualifier) = + fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.Assumption -> FStarC_Reflection_V2_Data.Assumption + | FStarC_Syntax_Syntax.New -> FStarC_Reflection_V2_Data.New + | FStarC_Syntax_Syntax.Private -> FStarC_Reflection_V2_Data.Private + | FStarC_Syntax_Syntax.Unfold_for_unification_and_vcgen -> + FStarC_Reflection_V2_Data.Unfold_for_unification_and_vcgen + | FStarC_Syntax_Syntax.Visible_default -> + FStarC_Reflection_V2_Data.Visible_default + | FStarC_Syntax_Syntax.Irreducible -> + FStarC_Reflection_V2_Data.Irreducible + | FStarC_Syntax_Syntax.Inline_for_extraction -> + FStarC_Reflection_V2_Data.Inline_for_extraction + | FStarC_Syntax_Syntax.NoExtract -> FStarC_Reflection_V2_Data.NoExtract + | FStarC_Syntax_Syntax.Noeq -> FStarC_Reflection_V2_Data.Noeq + | FStarC_Syntax_Syntax.Unopteq -> FStarC_Reflection_V2_Data.Unopteq + | FStarC_Syntax_Syntax.TotalEffect -> + FStarC_Reflection_V2_Data.TotalEffect + | FStarC_Syntax_Syntax.Logic -> FStarC_Reflection_V2_Data.Logic + | FStarC_Syntax_Syntax.Reifiable -> FStarC_Reflection_V2_Data.Reifiable + | FStarC_Syntax_Syntax.Reflectable l -> + let uu___1 = FStarC_Ident.path_of_lid l in + FStarC_Reflection_V2_Data.Reflectable uu___1 + | FStarC_Syntax_Syntax.Discriminator l -> + let uu___1 = FStarC_Ident.path_of_lid l in + FStarC_Reflection_V2_Data.Discriminator uu___1 + | FStarC_Syntax_Syntax.Projector (l, i) -> + let uu___1 = let uu___2 = FStarC_Ident.path_of_lid l in (uu___2, i) in + FStarC_Reflection_V2_Data.Projector uu___1 + | FStarC_Syntax_Syntax.RecordType (l1, l2) -> + FStarC_Reflection_V2_Data.RecordType (l1, l2) + | FStarC_Syntax_Syntax.RecordConstructor (l1, l2) -> + FStarC_Reflection_V2_Data.RecordConstructor (l1, l2) + | FStarC_Syntax_Syntax.Action l -> + let uu___1 = FStarC_Ident.path_of_lid l in + FStarC_Reflection_V2_Data.Action uu___1 + | FStarC_Syntax_Syntax.ExceptionConstructor -> + FStarC_Reflection_V2_Data.ExceptionConstructor + | FStarC_Syntax_Syntax.HasMaskedEffect -> + FStarC_Reflection_V2_Data.HasMaskedEffect + | FStarC_Syntax_Syntax.Effect -> FStarC_Reflection_V2_Data.Effect + | FStarC_Syntax_Syntax.OnlyName -> FStarC_Reflection_V2_Data.OnlyName +let (inspect_ident : + FStarC_Ident.ident -> (Prims.string * FStarC_Compiler_Range_Type.range)) = + fun i -> + let uu___ = FStarC_Ident.string_of_id i in + let uu___1 = FStarC_Ident.range_of_id i in (uu___, uu___1) +let (pack_ident : + (Prims.string * FStarC_Compiler_Range_Type.range) -> FStarC_Ident.ident) = + fun i -> FStarC_Ident.mk_ident i +let (sigelt_quals : + FStarC_Syntax_Syntax.sigelt -> + FStarC_Reflection_V2_Data.qualifier Prims.list) + = + fun se -> + FStarC_Compiler_List.map syntax_to_rd_qual + se.FStarC_Syntax_Syntax.sigquals +let (set_sigelt_quals : + FStarC_Reflection_V2_Data.qualifier Prims.list -> + FStarC_Syntax_Syntax.sigelt -> FStarC_Syntax_Syntax.sigelt) + = + fun quals -> + fun se -> + let uu___ = FStarC_Compiler_List.map rd_to_syntax_qual quals in + { + FStarC_Syntax_Syntax.sigel = (se.FStarC_Syntax_Syntax.sigel); + FStarC_Syntax_Syntax.sigrng = (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = uu___; + FStarC_Syntax_Syntax.sigmeta = (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = (se.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = (se.FStarC_Syntax_Syntax.sigopts) + } +let (sigelt_opts : + FStarC_Syntax_Syntax.sigelt -> + FStarC_VConfig.vconfig FStar_Pervasives_Native.option) + = fun se -> se.FStarC_Syntax_Syntax.sigopts +let (embed_vconfig : FStarC_VConfig.vconfig -> FStarC_Syntax_Syntax.term) = + fun vcfg -> + let uu___ = + FStarC_Syntax_Embeddings_Base.embed FStarC_Syntax_Embeddings.e_vconfig + vcfg in + uu___ FStarC_Compiler_Range_Type.dummyRange FStar_Pervasives_Native.None + FStarC_Syntax_Embeddings_Base.id_norm_cb +let (inspect_sigelt : + FStarC_Syntax_Syntax.sigelt -> FStarC_Reflection_V2_Data.sigelt_view) = + fun se -> + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (r, lbs); + FStarC_Syntax_Syntax.lids1 = uu___;_} + -> FStarC_Reflection_V2_Data.Sg_Let (r, lbs) + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = lid; FStarC_Syntax_Syntax.us = us; + FStarC_Syntax_Syntax.params = param_bs; + FStarC_Syntax_Syntax.num_uniform_params = uu___; + FStarC_Syntax_Syntax.t = ty; FStarC_Syntax_Syntax.mutuals = uu___1; + FStarC_Syntax_Syntax.ds = c_lids; + FStarC_Syntax_Syntax.injective_type_params = uu___2;_} + -> + let nm = FStarC_Ident.path_of_lid lid in + let inspect_ctor c_lid = + let uu___3 = + let uu___4 = get_env () in + FStarC_TypeChecker_Env.lookup_sigelt uu___4 c_lid in + match uu___3 with + | FStar_Pervasives_Native.Some + { + FStarC_Syntax_Syntax.sigel = FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = lid1; + FStarC_Syntax_Syntax.us1 = us1; + FStarC_Syntax_Syntax.t1 = cty; + FStarC_Syntax_Syntax.ty_lid = uu___4; + FStarC_Syntax_Syntax.num_ty_params = nparam; + FStarC_Syntax_Syntax.mutuals1 = uu___5; + FStarC_Syntax_Syntax.injective_type_params1 = uu___6;_}; + FStarC_Syntax_Syntax.sigrng = uu___7; + FStarC_Syntax_Syntax.sigquals = uu___8; + FStarC_Syntax_Syntax.sigmeta = uu___9; + FStarC_Syntax_Syntax.sigattrs = uu___10; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___11; + FStarC_Syntax_Syntax.sigopts = uu___12;_} + -> + let uu___13 = FStarC_Ident.path_of_lid lid1 in (uu___13, cty) + | uu___4 -> + failwith "impossible: inspect_sigelt: did not find ctor" in + let uu___3 = + let uu___4 = FStarC_Compiler_List.map inspect_ctor c_lids in + (nm, us, param_bs, ty, uu___4) in + FStarC_Reflection_V2_Data.Sg_Inductive uu___3 + | FStarC_Syntax_Syntax.Sig_declare_typ + { FStarC_Syntax_Syntax.lid2 = lid; FStarC_Syntax_Syntax.us2 = us; + FStarC_Syntax_Syntax.t2 = ty;_} + -> + let nm = FStarC_Ident.path_of_lid lid in + FStarC_Reflection_V2_Data.Sg_Val (nm, us, ty) + | uu___ -> FStarC_Reflection_V2_Data.Unk +let (pack_sigelt : + FStarC_Reflection_V2_Data.sigelt_view -> FStarC_Syntax_Syntax.sigelt) = + fun sv -> + let check_lid lid = + let uu___ = + let uu___1 = + let uu___2 = FStarC_Ident.path_of_lid lid in + FStarC_Compiler_List.length uu___2 in + uu___1 <= Prims.int_one in + if uu___ + then + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Ident.string_of_lid lid in + Prims.strcat uu___3 "\" (did you forget a module path?)" in + Prims.strcat "pack_sigelt: invalid long identifier \"" uu___2 in + failwith uu___1 + else () in + match sv with + | FStarC_Reflection_V2_Data.Sg_Let (r, lbs) -> + let pack_letbinding lb = + let uu___ = lb in + match uu___ with + | { FStarC_Syntax_Syntax.lbname = nm; + FStarC_Syntax_Syntax.lbunivs = uu___1; + FStarC_Syntax_Syntax.lbtyp = uu___2; + FStarC_Syntax_Syntax.lbeff = uu___3; + FStarC_Syntax_Syntax.lbdef = uu___4; + FStarC_Syntax_Syntax.lbattrs = uu___5; + FStarC_Syntax_Syntax.lbpos = uu___6;_} -> + let lid = + match nm with + | FStar_Pervasives.Inr fv -> + FStarC_Syntax_Syntax.lid_of_fv fv + | uu___7 -> + failwith + "impossible: pack_sigelt: bv in toplevel let binding" in + (check_lid lid; (lid, lb)) in + let packed = FStarC_Compiler_List.map pack_letbinding lbs in + let lbs1 = + FStarC_Compiler_List.map FStar_Pervasives_Native.snd packed in + let lids = + FStarC_Compiler_List.map FStar_Pervasives_Native.fst packed in + FStarC_Syntax_Syntax.mk_sigelt + (FStarC_Syntax_Syntax.Sig_let + { + FStarC_Syntax_Syntax.lbs1 = (r, lbs1); + FStarC_Syntax_Syntax.lids1 = lids + }) + | FStarC_Reflection_V2_Data.Sg_Inductive + (nm, us_names, param_bs, ty, ctors) -> + let ind_lid = + FStarC_Ident.lid_of_path nm FStarC_Compiler_Range_Type.dummyRange in + (check_lid ind_lid; + (let nparam = FStarC_Compiler_List.length param_bs in + let injective_type_params = false in + let pack_ctor c = + let uu___1 = c in + match uu___1 with + | (nm1, ty1) -> + let lid = + FStarC_Ident.lid_of_path nm1 + FStarC_Compiler_Range_Type.dummyRange in + FStarC_Syntax_Syntax.mk_sigelt + (FStarC_Syntax_Syntax.Sig_datacon + { + FStarC_Syntax_Syntax.lid1 = lid; + FStarC_Syntax_Syntax.us1 = us_names; + FStarC_Syntax_Syntax.t1 = ty1; + FStarC_Syntax_Syntax.ty_lid = ind_lid; + FStarC_Syntax_Syntax.num_ty_params = nparam; + FStarC_Syntax_Syntax.mutuals1 = []; + FStarC_Syntax_Syntax.injective_type_params1 = + injective_type_params + }) in + let ctor_ses = FStarC_Compiler_List.map pack_ctor ctors in + let c_lids = + FStarC_Compiler_List.map + (fun se -> + let uu___1 = FStarC_Syntax_Util.lid_of_sigelt se in + FStarC_Compiler_Util.must uu___1) ctor_ses in + let ind_se = + FStarC_Syntax_Syntax.mk_sigelt + (FStarC_Syntax_Syntax.Sig_inductive_typ + { + FStarC_Syntax_Syntax.lid = ind_lid; + FStarC_Syntax_Syntax.us = us_names; + FStarC_Syntax_Syntax.params = param_bs; + FStarC_Syntax_Syntax.num_uniform_params = + FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.t = ty; + FStarC_Syntax_Syntax.mutuals = []; + FStarC_Syntax_Syntax.ds = c_lids; + FStarC_Syntax_Syntax.injective_type_params = + injective_type_params + }) in + let se = + FStarC_Syntax_Syntax.mk_sigelt + (FStarC_Syntax_Syntax.Sig_bundle + { + FStarC_Syntax_Syntax.ses = (ind_se :: ctor_ses); + FStarC_Syntax_Syntax.lids = (ind_lid :: c_lids) + }) in + { + FStarC_Syntax_Syntax.sigel = (se.FStarC_Syntax_Syntax.sigel); + FStarC_Syntax_Syntax.sigrng = (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = (FStarC_Syntax_Syntax.Noeq :: + (se.FStarC_Syntax_Syntax.sigquals)); + FStarC_Syntax_Syntax.sigmeta = (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = (se.FStarC_Syntax_Syntax.sigopts) + })) + | FStarC_Reflection_V2_Data.Sg_Val (nm, us_names, ty) -> + let val_lid = + FStarC_Ident.lid_of_path nm FStarC_Compiler_Range_Type.dummyRange in + (check_lid val_lid; + FStarC_Syntax_Syntax.mk_sigelt + (FStarC_Syntax_Syntax.Sig_declare_typ + { + FStarC_Syntax_Syntax.lid2 = val_lid; + FStarC_Syntax_Syntax.us2 = us_names; + FStarC_Syntax_Syntax.t2 = ty + })) + | FStarC_Reflection_V2_Data.Unk -> + failwith "packing Unk, this should never happen" +let (inspect_lb : + FStarC_Syntax_Syntax.letbinding -> FStarC_Reflection_V2_Data.lb_view) = + fun lb -> + let uu___ = lb in + match uu___ with + | { FStarC_Syntax_Syntax.lbname = nm; FStarC_Syntax_Syntax.lbunivs = us; + FStarC_Syntax_Syntax.lbtyp = typ; + FStarC_Syntax_Syntax.lbeff = uu___1; + FStarC_Syntax_Syntax.lbdef = def; + FStarC_Syntax_Syntax.lbattrs = uu___2; + FStarC_Syntax_Syntax.lbpos = uu___3;_} -> + (match nm with + | FStar_Pervasives.Inr fv -> + { + FStarC_Reflection_V2_Data.lb_fv = fv; + FStarC_Reflection_V2_Data.lb_us = us; + FStarC_Reflection_V2_Data.lb_typ = typ; + FStarC_Reflection_V2_Data.lb_def = def + } + | uu___4 -> failwith "Impossible: bv in top-level let binding") +let (pack_lb : + FStarC_Reflection_V2_Data.lb_view -> FStarC_Syntax_Syntax.letbinding) = + fun lbv -> + let uu___ = lbv in + match uu___ with + | { FStarC_Reflection_V2_Data.lb_fv = fv; + FStarC_Reflection_V2_Data.lb_us = us; + FStarC_Reflection_V2_Data.lb_typ = typ; + FStarC_Reflection_V2_Data.lb_def = def;_} -> + FStarC_Syntax_Util.mk_letbinding (FStar_Pervasives.Inr fv) us typ + FStarC_Parser_Const.effect_Tot_lid def [] + FStarC_Compiler_Range_Type.dummyRange +let (inspect_namedv : + FStarC_Reflection_V2_Data.namedv -> FStarC_Reflection_V2_Data.namedv_view) + = + fun v -> + if v.FStarC_Syntax_Syntax.index < Prims.int_zero + then + (let uu___1 = + let uu___2 = FStarC_Ident.string_of_id v.FStarC_Syntax_Syntax.ppname in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + v.FStarC_Syntax_Syntax.sort in + FStarC_Compiler_Util.format3 + "inspect_namedv: uniq is negative (%s : %s), uniq = %s" uu___2 + uu___3 (Prims.string_of_int v.FStarC_Syntax_Syntax.index) in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_CantInspect () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1)) + else (); + (let uu___1 = FStarC_BigInt.of_int_fs v.FStarC_Syntax_Syntax.index in + let uu___2 = + let uu___3 = FStarC_Ident.string_of_id v.FStarC_Syntax_Syntax.ppname in + FStarC_Compiler_Sealed.seal uu___3 in + { + FStarC_Reflection_V2_Data.uniq = uu___1; + FStarC_Reflection_V2_Data.sort = + (FStarC_Compiler_Sealed.seal v.FStarC_Syntax_Syntax.sort); + FStarC_Reflection_V2_Data.ppname = uu___2 + }) +let (pack_namedv : + FStarC_Reflection_V2_Data.namedv_view -> FStarC_Reflection_V2_Data.namedv) + = + fun vv -> + (let uu___1 = + let uu___2 = FStarC_BigInt.to_int_fs vv.FStarC_Reflection_V2_Data.uniq in + uu___2 < Prims.int_zero in + if uu___1 + then + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_BigInt.to_int_fs vv.FStarC_Reflection_V2_Data.uniq in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) uu___4 in + FStarC_Compiler_Util.format2 + "pack_namedv: uniq is negative (%s), uniq = %s" + (FStarC_Compiler_Sealed.unseal vv.FStarC_Reflection_V2_Data.ppname) + uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_CantInspect () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2) + else ()); + (let uu___1 = + FStarC_Ident.mk_ident + ((FStarC_Compiler_Sealed.unseal vv.FStarC_Reflection_V2_Data.ppname), + FStarC_Compiler_Range_Type.dummyRange) in + let uu___2 = FStarC_BigInt.to_int_fs vv.FStarC_Reflection_V2_Data.uniq in + { + FStarC_Syntax_Syntax.ppname = uu___1; + FStarC_Syntax_Syntax.index = uu___2; + FStarC_Syntax_Syntax.sort = + (FStarC_Compiler_Sealed.unseal vv.FStarC_Reflection_V2_Data.sort) + }) +let (inspect_bv : + FStarC_Syntax_Syntax.bv -> FStarC_Reflection_V2_Data.bv_view) = + fun bv -> + if bv.FStarC_Syntax_Syntax.index < Prims.int_zero + then + (let uu___1 = + let uu___2 = + FStarC_Ident.string_of_id bv.FStarC_Syntax_Syntax.ppname in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + bv.FStarC_Syntax_Syntax.sort in + FStarC_Compiler_Util.format3 + "inspect_bv: index is negative (%s : %s), index = %s" uu___2 + uu___3 (Prims.string_of_int bv.FStarC_Syntax_Syntax.index) in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_CantInspect () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1)) + else (); + (let uu___1 = FStarC_BigInt.of_int_fs bv.FStarC_Syntax_Syntax.index in + let uu___2 = + let uu___3 = FStarC_Ident.string_of_id bv.FStarC_Syntax_Syntax.ppname in + FStarC_Compiler_Sealed.seal uu___3 in + { + FStarC_Reflection_V2_Data.index = uu___1; + FStarC_Reflection_V2_Data.sort1 = + (FStarC_Compiler_Sealed.seal bv.FStarC_Syntax_Syntax.sort); + FStarC_Reflection_V2_Data.ppname1 = uu___2 + }) +let (pack_bv : FStarC_Reflection_V2_Data.bv_view -> FStarC_Syntax_Syntax.bv) + = + fun bvv -> + (let uu___1 = + let uu___2 = + FStarC_BigInt.to_int_fs bvv.FStarC_Reflection_V2_Data.index in + uu___2 < Prims.int_zero in + if uu___1 + then + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_BigInt.to_int_fs bvv.FStarC_Reflection_V2_Data.index in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) uu___4 in + FStarC_Compiler_Util.format2 + "pack_bv: index is negative (%s), index = %s" + (FStarC_Compiler_Sealed.unseal + bvv.FStarC_Reflection_V2_Data.ppname1) uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_CantInspect () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2) + else ()); + (let uu___1 = + FStarC_Ident.mk_ident + ((FStarC_Compiler_Sealed.unseal + bvv.FStarC_Reflection_V2_Data.ppname1), + FStarC_Compiler_Range_Type.dummyRange) in + let uu___2 = FStarC_BigInt.to_int_fs bvv.FStarC_Reflection_V2_Data.index in + { + FStarC_Syntax_Syntax.ppname = uu___1; + FStarC_Syntax_Syntax.index = uu___2; + FStarC_Syntax_Syntax.sort = + (FStarC_Compiler_Sealed.unseal bvv.FStarC_Reflection_V2_Data.sort1) + }) +let (inspect_binder : + FStarC_Syntax_Syntax.binder -> FStarC_Reflection_V2_Data.binder_view) = + fun b -> + let attrs = + FStarC_Syntax_Util.encode_positivity_attributes + b.FStarC_Syntax_Syntax.binder_positivity + b.FStarC_Syntax_Syntax.binder_attrs in + let uu___ = inspect_bqual b.FStarC_Syntax_Syntax.binder_qual in + let uu___1 = + let uu___2 = + FStarC_Ident.string_of_id + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.ppname in + FStarC_Compiler_Sealed.seal uu___2 in + { + FStarC_Reflection_V2_Data.sort2 = + ((b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort); + FStarC_Reflection_V2_Data.qual = uu___; + FStarC_Reflection_V2_Data.attrs = attrs; + FStarC_Reflection_V2_Data.ppname2 = uu___1 + } +let (pack_binder : + FStarC_Reflection_V2_Data.binder_view -> FStarC_Syntax_Syntax.binder) = + fun bview -> + let uu___ = + FStarC_Syntax_Util.parse_positivity_attributes + bview.FStarC_Reflection_V2_Data.attrs in + match uu___ with + | (pqual, attrs) -> + let uu___1 = + let uu___2 = + FStarC_Ident.mk_ident + ((FStarC_Compiler_Sealed.unseal + bview.FStarC_Reflection_V2_Data.ppname2), + FStarC_Compiler_Range_Type.dummyRange) in + { + FStarC_Syntax_Syntax.ppname = uu___2; + FStarC_Syntax_Syntax.index = Prims.int_zero; + FStarC_Syntax_Syntax.sort = + (bview.FStarC_Reflection_V2_Data.sort2) + } in + let uu___2 = pack_bqual bview.FStarC_Reflection_V2_Data.qual in + { + FStarC_Syntax_Syntax.binder_bv = uu___1; + FStarC_Syntax_Syntax.binder_qual = uu___2; + FStarC_Syntax_Syntax.binder_positivity = pqual; + FStarC_Syntax_Syntax.binder_attrs = attrs + } +let (moduleof : FStarC_TypeChecker_Env.env -> Prims.string Prims.list) = + fun e -> FStarC_Ident.path_of_lid e.FStarC_TypeChecker_Env.curmodule +let (env_open_modules : + FStarC_TypeChecker_Env.env -> FStarC_Reflection_V2_Data.name Prims.list) = + fun e -> + let uu___ = + FStarC_Syntax_DsEnv.open_modules e.FStarC_TypeChecker_Env.dsenv in + FStarC_Compiler_List.map + (fun uu___1 -> + match uu___1 with + | (l, m) -> + let uu___2 = FStarC_Ident.ids_of_lid l in + FStarC_Compiler_List.map FStarC_Ident.string_of_id uu___2) uu___ +let (bv_to_binding : + FStarC_Syntax_Syntax.bv -> FStarC_Reflection_V2_Data.binding) = + fun bv -> + let uu___ = FStarC_BigInt.of_int_fs bv.FStarC_Syntax_Syntax.index in + let uu___1 = + let uu___2 = FStarC_Ident.string_of_id bv.FStarC_Syntax_Syntax.ppname in + FStarC_Compiler_Sealed.seal uu___2 in + { + FStarC_Reflection_V2_Data.uniq1 = uu___; + FStarC_Reflection_V2_Data.sort3 = (bv.FStarC_Syntax_Syntax.sort); + FStarC_Reflection_V2_Data.ppname3 = uu___1 + } +let (vars_of_env : + FStarC_TypeChecker_Env.env -> FStarC_Reflection_V2_Data.binding Prims.list) + = + fun e -> + let uu___ = FStarC_TypeChecker_Env.all_binders e in + FStarC_Compiler_List.map + (fun b -> bv_to_binding b.FStarC_Syntax_Syntax.binder_bv) uu___ +let eqopt : + 'uuuuu . + unit -> + ('uuuuu -> 'uuuuu -> Prims.bool) -> + 'uuuuu FStar_Pervasives_Native.option -> + 'uuuuu FStar_Pervasives_Native.option -> Prims.bool + = fun uu___ -> FStarC_Syntax_Util.eqopt +let eqlist : + 'uuuuu . + unit -> + ('uuuuu -> 'uuuuu -> Prims.bool) -> + 'uuuuu Prims.list -> 'uuuuu Prims.list -> Prims.bool + = fun uu___ -> FStarC_Syntax_Util.eqlist +let eqprod : + 'uuuuu 'uuuuu1 . + unit -> + ('uuuuu -> 'uuuuu -> Prims.bool) -> + ('uuuuu1 -> 'uuuuu1 -> Prims.bool) -> + ('uuuuu * 'uuuuu1) -> ('uuuuu * 'uuuuu1) -> Prims.bool + = fun uu___ -> FStarC_Syntax_Util.eqprod +let rec (term_eq : + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t1 -> + fun t2 -> + let uu___ = + let uu___1 = inspect_ln t1 in + let uu___2 = inspect_ln t2 in (uu___1, uu___2) in + match uu___ with + | (FStarC_Reflection_V2_Data.Tv_Var bv1, + FStarC_Reflection_V2_Data.Tv_Var bv2) -> bv_eq bv1 bv2 + | (FStarC_Reflection_V2_Data.Tv_BVar bv1, + FStarC_Reflection_V2_Data.Tv_BVar bv2) -> bv_eq bv1 bv2 + | (FStarC_Reflection_V2_Data.Tv_FVar fv1, + FStarC_Reflection_V2_Data.Tv_FVar fv2) -> + FStarC_Syntax_Syntax.fv_eq fv1 fv2 + | (FStarC_Reflection_V2_Data.Tv_UInst (fv1, us1), + FStarC_Reflection_V2_Data.Tv_UInst (fv2, us2)) -> + (FStarC_Syntax_Syntax.fv_eq fv1 fv2) && (univs_eq us1 us2) + | (FStarC_Reflection_V2_Data.Tv_App (h1, arg1), + FStarC_Reflection_V2_Data.Tv_App (h2, arg2)) -> + (term_eq h1 h2) && (arg_eq arg1 arg2) + | (FStarC_Reflection_V2_Data.Tv_Abs (b1, t11), + FStarC_Reflection_V2_Data.Tv_Abs (b2, t21)) -> + (binder_eq b1 b2) && (term_eq t11 t21) + | (FStarC_Reflection_V2_Data.Tv_Arrow (b1, c1), + FStarC_Reflection_V2_Data.Tv_Arrow (b2, c2)) -> + (binder_eq b1 b2) && (comp_eq c1 c2) + | (FStarC_Reflection_V2_Data.Tv_Type u1, + FStarC_Reflection_V2_Data.Tv_Type u2) -> univ_eq u1 u2 + | (FStarC_Reflection_V2_Data.Tv_Refine (b1, t11), + FStarC_Reflection_V2_Data.Tv_Refine (b2, t21)) -> + (term_eq + (b1.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort + (b2.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort) + && (term_eq t11 t21) + | (FStarC_Reflection_V2_Data.Tv_Const c1, + FStarC_Reflection_V2_Data.Tv_Const c2) -> const_eq c1 c2 + | (FStarC_Reflection_V2_Data.Tv_Uvar (n1, uv1), + FStarC_Reflection_V2_Data.Tv_Uvar (n2, uv2)) -> n1 = n2 + | (FStarC_Reflection_V2_Data.Tv_Let (r1, ats1, b1, m1, n1), + FStarC_Reflection_V2_Data.Tv_Let (r2, ats2, b2, m2, n2)) -> + ((((r1 = r2) && ((eqlist ()) term_eq ats1 ats2)) && + (binder_eq b1 b2)) + && (term_eq m1 m2)) + && (term_eq n1 n2) + | (FStarC_Reflection_V2_Data.Tv_Match (h1, an1, brs1), + FStarC_Reflection_V2_Data.Tv_Match (h2, an2, brs2)) -> + ((term_eq h1 h2) && ((eqopt ()) match_ret_asc_eq an1 an2)) && + ((eqlist ()) branch_eq brs1 brs2) + | (FStarC_Reflection_V2_Data.Tv_AscribedT (e1, t11, topt1, eq1), + FStarC_Reflection_V2_Data.Tv_AscribedT (e2, t21, topt2, eq2)) -> + (((term_eq e1 e2) && (term_eq t11 t21)) && + ((eqopt ()) term_eq topt1 topt2)) + && (eq1 = eq2) + | (FStarC_Reflection_V2_Data.Tv_AscribedC (e1, c1, topt1, eq1), + FStarC_Reflection_V2_Data.Tv_AscribedC (e2, c2, topt2, eq2)) -> + (((term_eq e1 e2) && (comp_eq c1 c2)) && + ((eqopt ()) term_eq topt1 topt2)) + && (eq1 = eq2) + | (FStarC_Reflection_V2_Data.Tv_Unknown, + FStarC_Reflection_V2_Data.Tv_Unknown) -> true + | uu___1 -> false +and (arg_eq : + FStarC_Reflection_V2_Data.argv -> + FStarC_Reflection_V2_Data.argv -> Prims.bool) + = + fun arg1 -> + fun arg2 -> + let uu___ = arg1 in + match uu___ with + | (a1, aq1) -> + let uu___1 = arg2 in + (match uu___1 with + | (a2, aq2) -> (term_eq a1 a2) && (aqual_eq aq1 aq2)) +and (aqual_eq : + FStarC_Reflection_V2_Data.aqualv -> + FStarC_Reflection_V2_Data.aqualv -> Prims.bool) + = + fun aq1 -> + fun aq2 -> + match (aq1, aq2) with + | (FStarC_Reflection_V2_Data.Q_Implicit, + FStarC_Reflection_V2_Data.Q_Implicit) -> true + | (FStarC_Reflection_V2_Data.Q_Explicit, + FStarC_Reflection_V2_Data.Q_Explicit) -> true + | (FStarC_Reflection_V2_Data.Q_Meta t1, + FStarC_Reflection_V2_Data.Q_Meta t2) -> term_eq t1 t2 + | uu___ -> false +and (binder_eq : + FStarC_Syntax_Syntax.binder -> FStarC_Syntax_Syntax.binder -> Prims.bool) = + fun b1 -> + fun b2 -> + let bview1 = inspect_binder b1 in + let bview2 = inspect_binder b2 in + ((term_eq bview1.FStarC_Reflection_V2_Data.sort2 + bview2.FStarC_Reflection_V2_Data.sort2) + && + (aqual_eq bview1.FStarC_Reflection_V2_Data.qual + bview2.FStarC_Reflection_V2_Data.qual)) + && + ((eqlist ()) term_eq bview1.FStarC_Reflection_V2_Data.attrs + bview2.FStarC_Reflection_V2_Data.attrs) +and (bv_eq : + FStarC_Syntax_Syntax.bv -> FStarC_Syntax_Syntax.bv -> Prims.bool) = + fun bv1 -> + fun bv2 -> + bv1.FStarC_Syntax_Syntax.index = bv2.FStarC_Syntax_Syntax.index +and (comp_eq : + FStarC_Syntax_Syntax.comp -> FStarC_Syntax_Syntax.comp -> Prims.bool) = + fun c1 -> + fun c2 -> + let uu___ = + let uu___1 = inspect_comp c1 in + let uu___2 = inspect_comp c2 in (uu___1, uu___2) in + match uu___ with + | (FStarC_Reflection_V2_Data.C_Total t1, + FStarC_Reflection_V2_Data.C_Total t2) -> term_eq t1 t2 + | (FStarC_Reflection_V2_Data.C_GTotal t1, + FStarC_Reflection_V2_Data.C_GTotal t2) -> term_eq t1 t2 + | (FStarC_Reflection_V2_Data.C_Lemma (pre1, post1, pats1), + FStarC_Reflection_V2_Data.C_Lemma (pre2, post2, pats2)) -> + ((term_eq pre1 pre2) && (term_eq post1 post2)) && + (term_eq pats1 pats2) + | (FStarC_Reflection_V2_Data.C_Eff (us1, name1, t1, args1, decrs1), + FStarC_Reflection_V2_Data.C_Eff (us2, name2, t2, args2, decrs2)) -> + ((((univs_eq us1 us2) && (name1 = name2)) && (term_eq t1 t2)) && + ((eqlist ()) arg_eq args1 args2)) + && ((eqlist ()) term_eq decrs1 decrs2) + | uu___1 -> false +and (match_ret_asc_eq : + FStarC_Syntax_Syntax.match_returns_ascription -> + FStarC_Syntax_Syntax.match_returns_ascription -> Prims.bool) + = fun a1 -> fun a2 -> (eqprod ()) binder_eq ascription_eq a1 a2 +and (ascription_eq : + FStarC_Syntax_Syntax.ascription -> + FStarC_Syntax_Syntax.ascription -> Prims.bool) + = + fun asc1 -> + fun asc2 -> + let uu___ = asc1 in + match uu___ with + | (a1, topt1, eq1) -> + let uu___1 = asc2 in + (match uu___1 with + | (a2, topt2, eq2) -> + ((match (a1, a2) with + | (FStar_Pervasives.Inl t1, FStar_Pervasives.Inl t2) -> + term_eq t1 t2 + | (FStar_Pervasives.Inr c1, FStar_Pervasives.Inr c2) -> + comp_eq c1 c2) + && ((eqopt ()) term_eq topt1 topt2)) + && (eq1 = eq2)) +and (branch_eq : + FStarC_Reflection_V2_Data.branch -> + FStarC_Reflection_V2_Data.branch -> Prims.bool) + = fun c1 -> fun c2 -> (eqprod ()) pattern_eq term_eq c1 c2 +and (pattern_eq : + FStarC_Reflection_V2_Data.pattern -> + FStarC_Reflection_V2_Data.pattern -> Prims.bool) + = + fun p1 -> + fun p2 -> + match (p1, p2) with + | (FStarC_Reflection_V2_Data.Pat_Constant c1, + FStarC_Reflection_V2_Data.Pat_Constant c2) -> const_eq c1 c2 + | (FStarC_Reflection_V2_Data.Pat_Cons (fv1, us1, subpats1), + FStarC_Reflection_V2_Data.Pat_Cons (fv2, us2, subpats2)) -> + ((FStarC_Syntax_Syntax.fv_eq fv1 fv2) && + ((eqopt ()) ((eqlist ()) univ_eq) us1 us2)) + && + ((eqlist ()) + ((eqprod ()) pattern_eq (fun b1 -> fun b2 -> b1 = b2)) + subpats1 subpats2) + | (FStarC_Reflection_V2_Data.Pat_Var (uu___, uu___1), + FStarC_Reflection_V2_Data.Pat_Var (uu___2, uu___3)) -> true + | (FStarC_Reflection_V2_Data.Pat_Dot_Term topt1, + FStarC_Reflection_V2_Data.Pat_Dot_Term topt2) -> + (eqopt ()) term_eq topt1 topt2 + | uu___ -> false +and (const_eq : + FStarC_Reflection_V2_Data.vconst -> + FStarC_Reflection_V2_Data.vconst -> Prims.bool) + = fun c1 -> fun c2 -> c1 = c2 +and (univ_eq : + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.universe -> Prims.bool) + = fun u1 -> fun u2 -> FStarC_Syntax_Util.eq_univs u1 u2 +and (univs_eq : + FStarC_Syntax_Syntax.universe Prims.list -> + FStarC_Syntax_Syntax.universe Prims.list -> Prims.bool) + = fun us1 -> fun us2 -> (eqlist ()) univ_eq us1 us2 +let (implode_qn : Prims.string Prims.list -> Prims.string) = + fun ns -> FStarC_Compiler_String.concat "." ns +let (explode_qn : Prims.string -> Prims.string Prims.list) = + fun s -> FStarC_Compiler_String.split [46] s +let (compare_string : Prims.string -> Prims.string -> FStarC_BigInt.t) = + fun s1 -> + fun s2 -> FStarC_BigInt.of_int_fs (FStarC_Compiler_String.compare s1 s2) +let (push_binder : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.binder -> FStarC_TypeChecker_Env.env) + = fun e -> fun b -> FStarC_TypeChecker_Env.push_binders e [b] +let (push_namedv : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.bv -> FStarC_TypeChecker_Env.env) + = + fun e -> + fun b -> + let uu___ = let uu___1 = FStarC_Syntax_Syntax.mk_binder b in [uu___1] in + FStarC_TypeChecker_Env.push_binders e uu___ +let (subst_term : + FStarC_Syntax_Syntax.subst_elt Prims.list -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = fun s -> fun t -> FStarC_Syntax_Subst.subst s t +let (subst_comp : + FStarC_Syntax_Syntax.subst_elt Prims.list -> + FStarC_Syntax_Syntax.comp -> FStarC_Syntax_Syntax.comp) + = fun s -> fun c -> FStarC_Syntax_Subst.subst_comp s c +let (range_of_term : + FStarC_Syntax_Syntax.term -> FStarC_Compiler_Range_Type.range) = + fun t -> t.FStarC_Syntax_Syntax.pos +let (range_of_sigelt : + FStarC_Syntax_Syntax.sigelt -> FStarC_Compiler_Range_Type.range) = + fun s -> s.FStarC_Syntax_Syntax.sigrng \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Reflection_V2_Constants.ml b/ocaml/fstar-lib/generated/FStarC_Reflection_V2_Constants.ml new file mode 100644 index 00000000000..dd1d3d50405 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Reflection_V2_Constants.ml @@ -0,0 +1,514 @@ +open Prims +type refl_constant = + { + lid: FStarC_Ident.lid ; + fv: FStarC_Syntax_Syntax.fv ; + t: FStarC_Syntax_Syntax.term } +let (__proj__Mkrefl_constant__item__lid : refl_constant -> FStarC_Ident.lid) + = fun projectee -> match projectee with | { lid; fv; t;_} -> lid +let (__proj__Mkrefl_constant__item__fv : + refl_constant -> FStarC_Syntax_Syntax.fv) = + fun projectee -> match projectee with | { lid; fv; t;_} -> fv +let (__proj__Mkrefl_constant__item__t : + refl_constant -> FStarC_Syntax_Syntax.term) = + fun projectee -> match projectee with | { lid; fv; t;_} -> t +let (refl_constant_lid : refl_constant -> FStarC_Ident.lid) = + fun rc -> rc.lid +let (refl_constant_term : refl_constant -> FStarC_Syntax_Syntax.term) = + fun rc -> rc.t +let (fstar_syntax_syntax_lid : + Prims.string Prims.list -> FStarC_Ident.lident) = + fun s -> + FStarC_Ident.lid_of_path + (FStarC_Compiler_List.op_At ["FStar"; "Stubs"; "Syntax"; "Syntax"] s) + FStarC_Compiler_Range_Type.dummyRange +let (fstar_refl_lid : Prims.string Prims.list -> FStarC_Ident.lident) = + fun s -> + FStarC_Ident.lid_of_path + (FStarC_Compiler_List.op_At ["FStar"; "Stubs"; "Reflection"] s) + FStarC_Compiler_Range_Type.dummyRange +let (fstar_refl_types_lid : Prims.string -> FStarC_Ident.lident) = + fun s -> fstar_refl_lid ["Types"; s] +let (fstar_refl_builtins_lid : Prims.string -> FStarC_Ident.lident) = + fun s -> fstar_refl_lid ["V2"; "Builtins"; s] +let (fstar_refl_data_lid : Prims.string -> FStarC_Ident.lident) = + fun s -> fstar_refl_lid ["V2"; "Data"; s] +let (fstar_syntax_syntax_const : Prims.string Prims.list -> refl_constant) = + fun s -> + let lid = fstar_syntax_syntax_lid s in + let uu___ = + FStarC_Syntax_Syntax.lid_as_fv lid + (FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.Data_ctor) in + let uu___1 = FStarC_Syntax_Syntax.tdataconstr lid in + { lid; fv = uu___; t = uu___1 } +let (fstar_refl_data_const : Prims.string -> refl_constant) = + fun s -> + let lid = fstar_refl_data_lid s in + let uu___ = + FStarC_Syntax_Syntax.lid_as_fv lid + (FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.Data_ctor) in + let uu___1 = FStarC_Syntax_Syntax.tdataconstr lid in + { lid; fv = uu___; t = uu___1 } +let (mk_refl_types_lid_as_term : Prims.string -> FStarC_Syntax_Syntax.term) = + fun s -> + let uu___ = fstar_refl_types_lid s in FStarC_Syntax_Syntax.tconst uu___ +let (mk_refl_types_lid_as_fv : Prims.string -> FStarC_Syntax_Syntax.fv) = + fun s -> + let uu___ = fstar_refl_types_lid s in FStarC_Syntax_Syntax.fvconst uu___ +let (mk_refl_data_lid_as_term : Prims.string -> FStarC_Syntax_Syntax.term) = + fun s -> + let uu___ = fstar_refl_data_lid s in FStarC_Syntax_Syntax.tconst uu___ +let (mk_refl_data_lid_as_fv : Prims.string -> FStarC_Syntax_Syntax.fv) = + fun s -> + let uu___ = fstar_refl_data_lid s in FStarC_Syntax_Syntax.fvconst uu___ +let (mk_ss_lid_as_fv : Prims.string -> FStarC_Syntax_Syntax.fv) = + fun s -> + let uu___ = fstar_syntax_syntax_lid [s] in + FStarC_Syntax_Syntax.fvconst uu___ +let (mk_ss_lid_as_term : Prims.string -> FStarC_Syntax_Syntax.term) = + fun s -> + let uu___ = fstar_syntax_syntax_lid [s] in + FStarC_Syntax_Syntax.tconst uu___ +let (mk_inspect_pack_pair : Prims.string -> (refl_constant * refl_constant)) + = + fun s -> + let inspect_lid = fstar_refl_builtins_lid (Prims.strcat "inspect" s) in + let pack_lid = fstar_refl_builtins_lid (Prims.strcat "pack" s) in + let inspect_fv = + FStarC_Syntax_Syntax.lid_as_fv inspect_lid FStar_Pervasives_Native.None in + let pack_fv = + FStarC_Syntax_Syntax.lid_as_fv pack_lid FStar_Pervasives_Native.None in + let inspect = + let uu___ = FStarC_Syntax_Syntax.fv_to_tm inspect_fv in + { lid = inspect_lid; fv = inspect_fv; t = uu___ } in + let pack = + let uu___ = FStarC_Syntax_Syntax.fv_to_tm pack_fv in + { lid = pack_lid; fv = pack_fv; t = uu___ } in + (inspect, pack) +let (uu___0 : (refl_constant * refl_constant)) = mk_inspect_pack_pair "_ln" +let (fstar_refl_inspect_ln : refl_constant) = + match uu___0 with + | (fstar_refl_inspect_ln1, fstar_refl_pack_ln) -> fstar_refl_inspect_ln1 +let (fstar_refl_pack_ln : refl_constant) = + match uu___0 with + | (fstar_refl_inspect_ln1, fstar_refl_pack_ln1) -> fstar_refl_pack_ln1 +let (uu___1 : (refl_constant * refl_constant)) = mk_inspect_pack_pair "_fv" +let (fstar_refl_inspect_fv : refl_constant) = + match uu___1 with + | (fstar_refl_inspect_fv1, fstar_refl_pack_fv) -> fstar_refl_inspect_fv1 +let (fstar_refl_pack_fv : refl_constant) = + match uu___1 with + | (fstar_refl_inspect_fv1, fstar_refl_pack_fv1) -> fstar_refl_pack_fv1 +let (uu___2 : (refl_constant * refl_constant)) = mk_inspect_pack_pair "_bv" +let (fstar_refl_inspect_bv : refl_constant) = + match uu___2 with + | (fstar_refl_inspect_bv1, fstar_refl_pack_bv) -> fstar_refl_inspect_bv1 +let (fstar_refl_pack_bv : refl_constant) = + match uu___2 with + | (fstar_refl_inspect_bv1, fstar_refl_pack_bv1) -> fstar_refl_pack_bv1 +let (uu___3 : (refl_constant * refl_constant)) = + mk_inspect_pack_pair "_namedv" +let (fstar_refl_inspect_namedv : refl_constant) = + match uu___3 with + | (fstar_refl_inspect_namedv1, fstar_refl_pack_namedv) -> + fstar_refl_inspect_namedv1 +let (fstar_refl_pack_namedv : refl_constant) = + match uu___3 with + | (fstar_refl_inspect_namedv1, fstar_refl_pack_namedv1) -> + fstar_refl_pack_namedv1 +let (uu___4 : (refl_constant * refl_constant)) = + mk_inspect_pack_pair "_binder" +let (fstar_refl_inspect_binder : refl_constant) = + match uu___4 with + | (fstar_refl_inspect_binder1, fstar_refl_pack_binder) -> + fstar_refl_inspect_binder1 +let (fstar_refl_pack_binder : refl_constant) = + match uu___4 with + | (fstar_refl_inspect_binder1, fstar_refl_pack_binder1) -> + fstar_refl_pack_binder1 +let (uu___5 : (refl_constant * refl_constant)) = mk_inspect_pack_pair "_comp" +let (fstar_refl_inspect_comp : refl_constant) = + match uu___5 with + | (fstar_refl_inspect_comp1, fstar_refl_pack_comp) -> + fstar_refl_inspect_comp1 +let (fstar_refl_pack_comp : refl_constant) = + match uu___5 with + | (fstar_refl_inspect_comp1, fstar_refl_pack_comp1) -> + fstar_refl_pack_comp1 +let (uu___6 : (refl_constant * refl_constant)) = + mk_inspect_pack_pair "_sigelt" +let (fstar_refl_inspect_sigelt : refl_constant) = + match uu___6 with + | (fstar_refl_inspect_sigelt1, fstar_refl_pack_sigelt) -> + fstar_refl_inspect_sigelt1 +let (fstar_refl_pack_sigelt : refl_constant) = + match uu___6 with + | (fstar_refl_inspect_sigelt1, fstar_refl_pack_sigelt1) -> + fstar_refl_pack_sigelt1 +let (uu___7 : (refl_constant * refl_constant)) = mk_inspect_pack_pair "_lb" +let (fstar_refl_inspect_lb : refl_constant) = + match uu___7 with + | (fstar_refl_inspect_lb1, fstar_refl_pack_lb) -> fstar_refl_inspect_lb1 +let (fstar_refl_pack_lb : refl_constant) = + match uu___7 with + | (fstar_refl_inspect_lb1, fstar_refl_pack_lb1) -> fstar_refl_pack_lb1 +let (uu___8 : (refl_constant * refl_constant)) = + mk_inspect_pack_pair "_universe" +let (fstar_refl_inspect_universe : refl_constant) = + match uu___8 with + | (fstar_refl_inspect_universe1, fstar_refl_pack_universe) -> + fstar_refl_inspect_universe1 +let (fstar_refl_pack_universe : refl_constant) = + match uu___8 with + | (fstar_refl_inspect_universe1, fstar_refl_pack_universe1) -> + fstar_refl_pack_universe1 +let (fstar_refl_env : FStarC_Syntax_Syntax.term) = + mk_refl_types_lid_as_term "env" +let (fstar_refl_env_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_types_lid_as_fv "env" +let (fstar_refl_namedv : FStarC_Syntax_Syntax.term) = + mk_refl_types_lid_as_term "namedv" +let (fstar_refl_namedv_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_types_lid_as_fv "namedv" +let (fstar_refl_bv : FStarC_Syntax_Syntax.term) = + mk_refl_types_lid_as_term "bv" +let (fstar_refl_bv_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_types_lid_as_fv "bv" +let (fstar_refl_fv : FStarC_Syntax_Syntax.term) = + mk_refl_types_lid_as_term "fv" +let (fstar_refl_fv_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_types_lid_as_fv "fv" +let (fstar_refl_comp : FStarC_Syntax_Syntax.term) = + mk_refl_types_lid_as_term "comp" +let (fstar_refl_comp_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_types_lid_as_fv "comp" +let (fstar_refl_binding : FStarC_Syntax_Syntax.term) = + mk_refl_types_lid_as_term "binding" +let (fstar_refl_binding_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_types_lid_as_fv "binding" +let (fstar_refl_binder : FStarC_Syntax_Syntax.term) = + mk_refl_types_lid_as_term "binder" +let (fstar_refl_binder_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_types_lid_as_fv "binder" +let (fstar_refl_sigelt : FStarC_Syntax_Syntax.term) = + mk_refl_types_lid_as_term "sigelt" +let (fstar_refl_sigelt_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_types_lid_as_fv "sigelt" +let (fstar_refl_term : FStarC_Syntax_Syntax.term) = + mk_refl_types_lid_as_term "term" +let (fstar_refl_term_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_types_lid_as_fv "term" +let (fstar_refl_letbinding : FStarC_Syntax_Syntax.term) = + mk_refl_types_lid_as_term "letbinding" +let (fstar_refl_letbinding_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_types_lid_as_fv "letbinding" +let (fstar_refl_ident : FStarC_Syntax_Syntax.term) = + mk_refl_types_lid_as_term "ident" +let (fstar_refl_ident_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_types_lid_as_fv "ident" +let (fstar_refl_univ_name : FStarC_Syntax_Syntax.term) = + mk_refl_types_lid_as_term "univ_name" +let (fstar_refl_univ_name_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_types_lid_as_fv "univ_name" +let (fstar_refl_optionstate : FStarC_Syntax_Syntax.term) = + mk_refl_types_lid_as_term "optionstate" +let (fstar_refl_optionstate_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_types_lid_as_fv "optionstate" +let (fstar_refl_universe : FStarC_Syntax_Syntax.term) = + mk_refl_types_lid_as_term "universe" +let (fstar_refl_universe_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_types_lid_as_fv "universe" +let (fstar_refl_universe_uvar : FStarC_Syntax_Syntax.term) = + mk_refl_types_lid_as_term "universe_uvar" +let (fstar_refl_universe_uvar_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_types_lid_as_fv "universe_uvar" +let (fstar_refl_ctx_uvar_and_subst : FStarC_Syntax_Syntax.term) = + mk_refl_types_lid_as_term "ctx_uvar_and_subst" +let (fstar_refl_ctx_uvar_and_subst_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_types_lid_as_fv "ctx_uvar_and_subst" +let (fstar_refl_aqualv : FStarC_Syntax_Syntax.term) = + mk_refl_data_lid_as_term "aqualv" +let (fstar_refl_aqualv_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_data_lid_as_fv "aqualv" +let (fstar_refl_comp_view : FStarC_Syntax_Syntax.term) = + mk_refl_data_lid_as_term "comp_view" +let (fstar_refl_comp_view_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_data_lid_as_fv "comp_view" +let (fstar_refl_term_view : FStarC_Syntax_Syntax.term) = + mk_refl_data_lid_as_term "term_view" +let (fstar_refl_term_view_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_data_lid_as_fv "term_view" +let (fstar_refl_pattern : FStarC_Syntax_Syntax.term) = + mk_refl_data_lid_as_term "pattern" +let (fstar_refl_pattern_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_data_lid_as_fv "pattern" +let (fstar_refl_branch : FStarC_Syntax_Syntax.term) = + mk_refl_data_lid_as_term "branch" +let (fstar_refl_branch_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_data_lid_as_fv "branch" +let (fstar_refl_namedv_view : FStarC_Syntax_Syntax.term) = + mk_refl_data_lid_as_term "namedv_view" +let (fstar_refl_namedv_view_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_data_lid_as_fv "namedv_view" +let (fstar_refl_bv_view : FStarC_Syntax_Syntax.term) = + mk_refl_data_lid_as_term "bv_view" +let (fstar_refl_bv_view_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_data_lid_as_fv "bv_view" +let (fstar_refl_binder_view : FStarC_Syntax_Syntax.term) = + mk_refl_data_lid_as_term "binder_view" +let (fstar_refl_binder_view_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_data_lid_as_fv "binder_view" +let (fstar_refl_vconst : FStarC_Syntax_Syntax.term) = + mk_refl_data_lid_as_term "vconst" +let (fstar_refl_vconst_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_data_lid_as_fv "vconst" +let (fstar_refl_lb_view : FStarC_Syntax_Syntax.term) = + mk_refl_data_lid_as_term "lb_view" +let (fstar_refl_lb_view_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_data_lid_as_fv "lb_view" +let (fstar_refl_sigelt_view : FStarC_Syntax_Syntax.term) = + mk_refl_data_lid_as_term "sigelt_view" +let (fstar_refl_sigelt_view_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_data_lid_as_fv "sigelt_view" +let (fstar_refl_qualifier : FStarC_Syntax_Syntax.term) = + mk_refl_data_lid_as_term "qualifier" +let (fstar_refl_qualifier_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_data_lid_as_fv "qualifier" +let (fstar_refl_universe_view : FStarC_Syntax_Syntax.term) = + mk_refl_data_lid_as_term "universe_view" +let (fstar_refl_universe_view_fv : FStarC_Syntax_Syntax.fv) = + mk_refl_data_lid_as_fv "universe_view" +let (fstar_refl_subst_elt : FStarC_Syntax_Syntax.term) = + mk_ss_lid_as_term "subst_elt" +let (fstar_refl_subst_elt_fv : FStarC_Syntax_Syntax.fv) = + mk_ss_lid_as_fv "subst_elt" +let (fstar_refl_subst : FStarC_Syntax_Syntax.term) = + mk_ss_lid_as_term "subst" +let (fstar_refl_subst_fv : FStarC_Syntax_Syntax.fv) = mk_ss_lid_as_fv "subst" +let (ref_Mk_namedv_view : refl_constant) = + let lid = fstar_refl_data_lid "Mknamedv_view" in + let attr = + let uu___ = + let uu___9 = fstar_refl_data_lid "namedv_view" in + let uu___10 = + let uu___11 = + FStarC_Ident.mk_ident + ("uniq", FStarC_Compiler_Range_Type.dummyRange) in + let uu___12 = + let uu___13 = + FStarC_Ident.mk_ident + ("sort", FStarC_Compiler_Range_Type.dummyRange) in + let uu___14 = + let uu___15 = + FStarC_Ident.mk_ident + ("ppname", FStarC_Compiler_Range_Type.dummyRange) in + [uu___15] in + uu___13 :: uu___14 in + uu___11 :: uu___12 in + (uu___9, uu___10) in + FStarC_Syntax_Syntax.Record_ctor uu___ in + let fv = + FStarC_Syntax_Syntax.lid_as_fv lid (FStar_Pervasives_Native.Some attr) in + let uu___ = FStarC_Syntax_Syntax.fv_to_tm fv in { lid; fv; t = uu___ } +let (ref_Mk_bv_view : refl_constant) = + let lid = fstar_refl_data_lid "Mkbv_view" in + let attr = + let uu___ = + let uu___9 = fstar_refl_data_lid "bv_view" in + let uu___10 = + let uu___11 = + FStarC_Ident.mk_ident + ("index", FStarC_Compiler_Range_Type.dummyRange) in + let uu___12 = + let uu___13 = + FStarC_Ident.mk_ident + ("sort", FStarC_Compiler_Range_Type.dummyRange) in + let uu___14 = + let uu___15 = + FStarC_Ident.mk_ident + ("ppname", FStarC_Compiler_Range_Type.dummyRange) in + [uu___15] in + uu___13 :: uu___14 in + uu___11 :: uu___12 in + (uu___9, uu___10) in + FStarC_Syntax_Syntax.Record_ctor uu___ in + let fv = + FStarC_Syntax_Syntax.lid_as_fv lid (FStar_Pervasives_Native.Some attr) in + let uu___ = FStarC_Syntax_Syntax.fv_to_tm fv in { lid; fv; t = uu___ } +let (ref_Mk_binding : refl_constant) = + let lid = fstar_refl_data_lid "Mkbinding" in + let attr = + let uu___ = + let uu___9 = fstar_refl_data_lid "binding" in + let uu___10 = + let uu___11 = + FStarC_Ident.mk_ident + ("uniq", FStarC_Compiler_Range_Type.dummyRange) in + let uu___12 = + let uu___13 = + FStarC_Ident.mk_ident + ("sort", FStarC_Compiler_Range_Type.dummyRange) in + let uu___14 = + let uu___15 = + FStarC_Ident.mk_ident + ("ppname", FStarC_Compiler_Range_Type.dummyRange) in + [uu___15] in + uu___13 :: uu___14 in + uu___11 :: uu___12 in + (uu___9, uu___10) in + FStarC_Syntax_Syntax.Record_ctor uu___ in + let fv = + FStarC_Syntax_Syntax.lid_as_fv lid (FStar_Pervasives_Native.Some attr) in + let uu___ = FStarC_Syntax_Syntax.fv_to_tm fv in { lid; fv; t = uu___ } +let (ref_Mk_binder_view : refl_constant) = + let lid = fstar_refl_data_lid "Mkbinder_view" in + let attr = + let uu___ = + let uu___9 = fstar_refl_data_lid "binder_view" in + let uu___10 = + let uu___11 = + FStarC_Ident.mk_ident + ("sort", FStarC_Compiler_Range_Type.dummyRange) in + let uu___12 = + let uu___13 = + FStarC_Ident.mk_ident + ("qual", FStarC_Compiler_Range_Type.dummyRange) in + let uu___14 = + let uu___15 = + FStarC_Ident.mk_ident + ("attrs", FStarC_Compiler_Range_Type.dummyRange) in + let uu___16 = + let uu___17 = + FStarC_Ident.mk_ident + ("ppname", FStarC_Compiler_Range_Type.dummyRange) in + [uu___17] in + uu___15 :: uu___16 in + uu___13 :: uu___14 in + uu___11 :: uu___12 in + (uu___9, uu___10) in + FStarC_Syntax_Syntax.Record_ctor uu___ in + let fv = + FStarC_Syntax_Syntax.lid_as_fv lid (FStar_Pervasives_Native.Some attr) in + let uu___ = FStarC_Syntax_Syntax.fv_to_tm fv in { lid; fv; t = uu___ } +let (ref_Mk_lb : refl_constant) = + let lid = fstar_refl_data_lid "Mklb_view" in + let attr = + let uu___ = + let uu___9 = fstar_refl_data_lid "lb_view" in + let uu___10 = + let uu___11 = + FStarC_Ident.mk_ident + ("lb_fv", FStarC_Compiler_Range_Type.dummyRange) in + let uu___12 = + let uu___13 = + FStarC_Ident.mk_ident + ("lb_us", FStarC_Compiler_Range_Type.dummyRange) in + let uu___14 = + let uu___15 = + FStarC_Ident.mk_ident + ("lb_typ", FStarC_Compiler_Range_Type.dummyRange) in + let uu___16 = + let uu___17 = + FStarC_Ident.mk_ident + ("lb_def", FStarC_Compiler_Range_Type.dummyRange) in + [uu___17] in + uu___15 :: uu___16 in + uu___13 :: uu___14 in + uu___11 :: uu___12 in + (uu___9, uu___10) in + FStarC_Syntax_Syntax.Record_ctor uu___ in + let fv = + FStarC_Syntax_Syntax.lid_as_fv lid (FStar_Pervasives_Native.Some attr) in + let uu___ = FStarC_Syntax_Syntax.fv_to_tm fv in { lid; fv; t = uu___ } +let (ref_Q_Explicit : refl_constant) = fstar_refl_data_const "Q_Explicit" +let (ref_Q_Implicit : refl_constant) = fstar_refl_data_const "Q_Implicit" +let (ref_Q_Equality : refl_constant) = fstar_refl_data_const "Q_Equality" +let (ref_Q_Meta : refl_constant) = fstar_refl_data_const "Q_Meta" +let (ref_DB : refl_constant) = fstar_syntax_syntax_const ["DB"] +let (ref_DT : refl_constant) = fstar_syntax_syntax_const ["DT"] +let (ref_NM : refl_constant) = fstar_syntax_syntax_const ["NM"] +let (ref_NT : refl_constant) = fstar_syntax_syntax_const ["NT"] +let (ref_UN : refl_constant) = fstar_syntax_syntax_const ["UN"] +let (ref_UD : refl_constant) = fstar_syntax_syntax_const ["UD"] +let (ref_C_Unit : refl_constant) = fstar_refl_data_const "C_Unit" +let (ref_C_True : refl_constant) = fstar_refl_data_const "C_True" +let (ref_C_False : refl_constant) = fstar_refl_data_const "C_False" +let (ref_C_Int : refl_constant) = fstar_refl_data_const "C_Int" +let (ref_C_String : refl_constant) = fstar_refl_data_const "C_String" +let (ref_C_Range : refl_constant) = fstar_refl_data_const "C_Range" +let (ref_C_Reify : refl_constant) = fstar_refl_data_const "C_Reify" +let (ref_C_Reflect : refl_constant) = fstar_refl_data_const "C_Reflect" +let (ref_C_Real : refl_constant) = fstar_refl_data_const "C_Real" +let (ref_Pat_Constant : refl_constant) = fstar_refl_data_const "Pat_Constant" +let (ref_Pat_Cons : refl_constant) = fstar_refl_data_const "Pat_Cons" +let (ref_Pat_Var : refl_constant) = fstar_refl_data_const "Pat_Var" +let (ref_Pat_Dot_Term : refl_constant) = fstar_refl_data_const "Pat_Dot_Term" +let (ref_Uv_Zero : refl_constant) = fstar_refl_data_const "Uv_Zero" +let (ref_Uv_Succ : refl_constant) = fstar_refl_data_const "Uv_Succ" +let (ref_Uv_Max : refl_constant) = fstar_refl_data_const "Uv_Max" +let (ref_Uv_BVar : refl_constant) = fstar_refl_data_const "Uv_BVar" +let (ref_Uv_Name : refl_constant) = fstar_refl_data_const "Uv_Name" +let (ref_Uv_Unif : refl_constant) = fstar_refl_data_const "Uv_Unif" +let (ref_Uv_Unk : refl_constant) = fstar_refl_data_const "Uv_Unk" +let (ref_Tv_Var : refl_constant) = fstar_refl_data_const "Tv_Var" +let (ref_Tv_BVar : refl_constant) = fstar_refl_data_const "Tv_BVar" +let (ref_Tv_FVar : refl_constant) = fstar_refl_data_const "Tv_FVar" +let (ref_Tv_UInst : refl_constant) = fstar_refl_data_const "Tv_UInst" +let (ref_Tv_App : refl_constant) = fstar_refl_data_const "Tv_App" +let (ref_Tv_Abs : refl_constant) = fstar_refl_data_const "Tv_Abs" +let (ref_Tv_Arrow : refl_constant) = fstar_refl_data_const "Tv_Arrow" +let (ref_Tv_Type : refl_constant) = fstar_refl_data_const "Tv_Type" +let (ref_Tv_Refine : refl_constant) = fstar_refl_data_const "Tv_Refine" +let (ref_Tv_Const : refl_constant) = fstar_refl_data_const "Tv_Const" +let (ref_Tv_Uvar : refl_constant) = fstar_refl_data_const "Tv_Uvar" +let (ref_Tv_Let : refl_constant) = fstar_refl_data_const "Tv_Let" +let (ref_Tv_Match : refl_constant) = fstar_refl_data_const "Tv_Match" +let (ref_Tv_AscT : refl_constant) = fstar_refl_data_const "Tv_AscribedT" +let (ref_Tv_AscC : refl_constant) = fstar_refl_data_const "Tv_AscribedC" +let (ref_Tv_Unknown : refl_constant) = fstar_refl_data_const "Tv_Unknown" +let (ref_Tv_Unsupp : refl_constant) = fstar_refl_data_const "Tv_Unsupp" +let (ref_C_Total : refl_constant) = fstar_refl_data_const "C_Total" +let (ref_C_GTotal : refl_constant) = fstar_refl_data_const "C_GTotal" +let (ref_C_Lemma : refl_constant) = fstar_refl_data_const "C_Lemma" +let (ref_C_Eff : refl_constant) = fstar_refl_data_const "C_Eff" +let (ref_Sg_Let : refl_constant) = fstar_refl_data_const "Sg_Let" +let (ref_Sg_Inductive : refl_constant) = fstar_refl_data_const "Sg_Inductive" +let (ref_Sg_Val : refl_constant) = fstar_refl_data_const "Sg_Val" +let (ref_Unk : refl_constant) = fstar_refl_data_const "Unk" +let (ref_qual_Assumption : refl_constant) = + fstar_refl_data_const "Assumption" +let (ref_qual_InternalAssumption : refl_constant) = + fstar_refl_data_const "InternalAssumption" +let (ref_qual_New : refl_constant) = fstar_refl_data_const "New" +let (ref_qual_Private : refl_constant) = fstar_refl_data_const "Private" +let (ref_qual_Unfold_for_unification_and_vcgen : refl_constant) = + fstar_refl_data_const "Unfold_for_unification_and_vcgen" +let (ref_qual_Visible_default : refl_constant) = + fstar_refl_data_const "Visible_default" +let (ref_qual_Irreducible : refl_constant) = + fstar_refl_data_const "Irreducible" +let (ref_qual_Inline_for_extraction : refl_constant) = + fstar_refl_data_const "Inline_for_extraction" +let (ref_qual_NoExtract : refl_constant) = fstar_refl_data_const "NoExtract" +let (ref_qual_Noeq : refl_constant) = fstar_refl_data_const "Noeq" +let (ref_qual_Unopteq : refl_constant) = fstar_refl_data_const "Unopteq" +let (ref_qual_TotalEffect : refl_constant) = + fstar_refl_data_const "TotalEffect" +let (ref_qual_Logic : refl_constant) = fstar_refl_data_const "Logic" +let (ref_qual_Reifiable : refl_constant) = fstar_refl_data_const "Reifiable" +let (ref_qual_Reflectable : refl_constant) = + fstar_refl_data_const "Reflectable" +let (ref_qual_Discriminator : refl_constant) = + fstar_refl_data_const "Discriminator" +let (ref_qual_Projector : refl_constant) = fstar_refl_data_const "Projector" +let (ref_qual_RecordType : refl_constant) = + fstar_refl_data_const "RecordType" +let (ref_qual_RecordConstructor : refl_constant) = + fstar_refl_data_const "RecordConstructor" +let (ref_qual_Action : refl_constant) = fstar_refl_data_const "Action" +let (ref_qual_ExceptionConstructor : refl_constant) = + fstar_refl_data_const "ExceptionConstructor" +let (ref_qual_HasMaskedEffect : refl_constant) = + fstar_refl_data_const "HasMaskedEffect" +let (ref_qual_Effect : refl_constant) = fstar_refl_data_const "Effect" +let (ref_qual_OnlyName : refl_constant) = fstar_refl_data_const "OnlyName" \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Reflection_V2_Data.ml b/ocaml/fstar-lib/generated/FStarC_Reflection_V2_Data.ml new file mode 100644 index 00000000000..2c7f1951df8 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Reflection_V2_Data.ml @@ -0,0 +1,533 @@ +open Prims +type name = Prims.string Prims.list +type typ = FStarC_Syntax_Syntax.term +type binders = FStarC_Syntax_Syntax.binder Prims.list +type ppname_t = Prims.string FStarC_Compiler_Sealed.sealed +let (as_ppname : Prims.string -> ppname_t) = + fun x -> FStarC_Compiler_Sealed.seal x +type simple_binder = FStarC_Syntax_Syntax.binder +type ident_view = (Prims.string * FStarC_Compiler_Range_Type.range) +type namedv = FStarC_Syntax_Syntax.bv +type vconst = + | C_Unit + | C_Int of FStarC_BigInt.t + | C_True + | C_False + | C_String of Prims.string + | C_Range of FStarC_Compiler_Range_Type.range + | C_Reify + | C_Reflect of name + | C_Real of Prims.string +let (uu___is_C_Unit : vconst -> Prims.bool) = + fun projectee -> match projectee with | C_Unit -> true | uu___ -> false +let (uu___is_C_Int : vconst -> Prims.bool) = + fun projectee -> match projectee with | C_Int _0 -> true | uu___ -> false +let (__proj__C_Int__item___0 : vconst -> FStarC_BigInt.t) = + fun projectee -> match projectee with | C_Int _0 -> _0 +let (uu___is_C_True : vconst -> Prims.bool) = + fun projectee -> match projectee with | C_True -> true | uu___ -> false +let (uu___is_C_False : vconst -> Prims.bool) = + fun projectee -> match projectee with | C_False -> true | uu___ -> false +let (uu___is_C_String : vconst -> Prims.bool) = + fun projectee -> + match projectee with | C_String _0 -> true | uu___ -> false +let (__proj__C_String__item___0 : vconst -> Prims.string) = + fun projectee -> match projectee with | C_String _0 -> _0 +let (uu___is_C_Range : vconst -> Prims.bool) = + fun projectee -> match projectee with | C_Range _0 -> true | uu___ -> false +let (__proj__C_Range__item___0 : vconst -> FStarC_Compiler_Range_Type.range) + = fun projectee -> match projectee with | C_Range _0 -> _0 +let (uu___is_C_Reify : vconst -> Prims.bool) = + fun projectee -> match projectee with | C_Reify -> true | uu___ -> false +let (uu___is_C_Reflect : vconst -> Prims.bool) = + fun projectee -> + match projectee with | C_Reflect _0 -> true | uu___ -> false +let (__proj__C_Reflect__item___0 : vconst -> name) = + fun projectee -> match projectee with | C_Reflect _0 -> _0 +let (uu___is_C_Real : vconst -> Prims.bool) = + fun projectee -> match projectee with | C_Real _0 -> true | uu___ -> false +let (__proj__C_Real__item___0 : vconst -> Prims.string) = + fun projectee -> match projectee with | C_Real _0 -> _0 +type universes = FStarC_Syntax_Syntax.universe Prims.list +type pattern = + | Pat_Constant of vconst + | Pat_Cons of FStarC_Syntax_Syntax.fv * universes + FStar_Pervasives_Native.option * (pattern * Prims.bool) Prims.list + | Pat_Var of FStarC_Syntax_Syntax.term FStarC_Compiler_Sealed.sealed * + ppname_t + | Pat_Dot_Term of FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option +let (uu___is_Pat_Constant : pattern -> Prims.bool) = + fun projectee -> + match projectee with | Pat_Constant c -> true | uu___ -> false +let (__proj__Pat_Constant__item__c : pattern -> vconst) = + fun projectee -> match projectee with | Pat_Constant c -> c +let (uu___is_Pat_Cons : pattern -> Prims.bool) = + fun projectee -> + match projectee with + | Pat_Cons (head, univs, subpats) -> true + | uu___ -> false +let (__proj__Pat_Cons__item__head : pattern -> FStarC_Syntax_Syntax.fv) = + fun projectee -> + match projectee with | Pat_Cons (head, univs, subpats) -> head +let (__proj__Pat_Cons__item__univs : + pattern -> universes FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with | Pat_Cons (head, univs, subpats) -> univs +let (__proj__Pat_Cons__item__subpats : + pattern -> (pattern * Prims.bool) Prims.list) = + fun projectee -> + match projectee with | Pat_Cons (head, univs, subpats) -> subpats +let (uu___is_Pat_Var : pattern -> Prims.bool) = + fun projectee -> + match projectee with | Pat_Var (sort, ppname) -> true | uu___ -> false +let (__proj__Pat_Var__item__sort : + pattern -> FStarC_Syntax_Syntax.term FStarC_Compiler_Sealed.sealed) = + fun projectee -> match projectee with | Pat_Var (sort, ppname) -> sort +let (__proj__Pat_Var__item__ppname : pattern -> ppname_t) = + fun projectee -> match projectee with | Pat_Var (sort, ppname) -> ppname +let (uu___is_Pat_Dot_Term : pattern -> Prims.bool) = + fun projectee -> + match projectee with | Pat_Dot_Term t -> true | uu___ -> false +let (__proj__Pat_Dot_Term__item__t : + pattern -> FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) = + fun projectee -> match projectee with | Pat_Dot_Term t -> t +type branch = (pattern * FStarC_Syntax_Syntax.term) +type aqualv = + | Q_Implicit + | Q_Explicit + | Q_Equality + | Q_Meta of FStarC_Syntax_Syntax.term +let (uu___is_Q_Implicit : aqualv -> Prims.bool) = + fun projectee -> match projectee with | Q_Implicit -> true | uu___ -> false +let (uu___is_Q_Explicit : aqualv -> Prims.bool) = + fun projectee -> match projectee with | Q_Explicit -> true | uu___ -> false +let (uu___is_Q_Equality : aqualv -> Prims.bool) = + fun projectee -> match projectee with | Q_Equality -> true | uu___ -> false +let (uu___is_Q_Meta : aqualv -> Prims.bool) = + fun projectee -> match projectee with | Q_Meta _0 -> true | uu___ -> false +let (__proj__Q_Meta__item___0 : aqualv -> FStarC_Syntax_Syntax.term) = + fun projectee -> match projectee with | Q_Meta _0 -> _0 +type argv = (FStarC_Syntax_Syntax.term * aqualv) +type namedv_view = + { + uniq: FStarC_BigInt.t ; + sort: typ FStarC_Compiler_Sealed.sealed ; + ppname: ppname_t } +let (__proj__Mknamedv_view__item__uniq : namedv_view -> FStarC_BigInt.t) = + fun projectee -> match projectee with | { uniq; sort; ppname;_} -> uniq +let (__proj__Mknamedv_view__item__sort : + namedv_view -> typ FStarC_Compiler_Sealed.sealed) = + fun projectee -> match projectee with | { uniq; sort; ppname;_} -> sort +let (__proj__Mknamedv_view__item__ppname : namedv_view -> ppname_t) = + fun projectee -> match projectee with | { uniq; sort; ppname;_} -> ppname +type bv_view = + { + index: FStarC_BigInt.t ; + sort1: typ FStarC_Compiler_Sealed.sealed ; + ppname1: ppname_t } +let (__proj__Mkbv_view__item__index : bv_view -> FStarC_BigInt.t) = + fun projectee -> + match projectee with + | { index; sort1 = sort; ppname1 = ppname;_} -> index +let (__proj__Mkbv_view__item__sort : + bv_view -> typ FStarC_Compiler_Sealed.sealed) = + fun projectee -> + match projectee with | { index; sort1 = sort; ppname1 = ppname;_} -> sort +let (__proj__Mkbv_view__item__ppname : bv_view -> ppname_t) = + fun projectee -> + match projectee with + | { index; sort1 = sort; ppname1 = ppname;_} -> ppname +type binder_view = + { + sort2: typ ; + qual: aqualv ; + attrs: FStarC_Syntax_Syntax.term Prims.list ; + ppname2: ppname_t } +let (__proj__Mkbinder_view__item__sort : binder_view -> typ) = + fun projectee -> + match projectee with + | { sort2 = sort; qual; attrs; ppname2 = ppname;_} -> sort +let (__proj__Mkbinder_view__item__qual : binder_view -> aqualv) = + fun projectee -> + match projectee with + | { sort2 = sort; qual; attrs; ppname2 = ppname;_} -> qual +let (__proj__Mkbinder_view__item__attrs : + binder_view -> FStarC_Syntax_Syntax.term Prims.list) = + fun projectee -> + match projectee with + | { sort2 = sort; qual; attrs; ppname2 = ppname;_} -> attrs +let (__proj__Mkbinder_view__item__ppname : binder_view -> ppname_t) = + fun projectee -> + match projectee with + | { sort2 = sort; qual; attrs; ppname2 = ppname;_} -> ppname +type binding = { + uniq1: FStarC_BigInt.t ; + sort3: typ ; + ppname3: ppname_t } +let (__proj__Mkbinding__item__uniq : binding -> FStarC_BigInt.t) = + fun projectee -> + match projectee with + | { uniq1 = uniq; sort3 = sort; ppname3 = ppname;_} -> uniq +let (__proj__Mkbinding__item__sort : binding -> typ) = + fun projectee -> + match projectee with + | { uniq1 = uniq; sort3 = sort; ppname3 = ppname;_} -> sort +let (__proj__Mkbinding__item__ppname : binding -> ppname_t) = + fun projectee -> + match projectee with + | { uniq1 = uniq; sort3 = sort; ppname3 = ppname;_} -> ppname +type bindings = binding Prims.list +type universe_view = + | Uv_Zero + | Uv_Succ of FStarC_Syntax_Syntax.universe + | Uv_Max of universes + | Uv_BVar of FStarC_BigInt.t + | Uv_Name of FStarC_Syntax_Syntax.univ_name + | Uv_Unif of FStarC_Syntax_Syntax.universe_uvar + | Uv_Unk +let (uu___is_Uv_Zero : universe_view -> Prims.bool) = + fun projectee -> match projectee with | Uv_Zero -> true | uu___ -> false +let (uu___is_Uv_Succ : universe_view -> Prims.bool) = + fun projectee -> match projectee with | Uv_Succ _0 -> true | uu___ -> false +let (__proj__Uv_Succ__item___0 : + universe_view -> FStarC_Syntax_Syntax.universe) = + fun projectee -> match projectee with | Uv_Succ _0 -> _0 +let (uu___is_Uv_Max : universe_view -> Prims.bool) = + fun projectee -> match projectee with | Uv_Max _0 -> true | uu___ -> false +let (__proj__Uv_Max__item___0 : universe_view -> universes) = + fun projectee -> match projectee with | Uv_Max _0 -> _0 +let (uu___is_Uv_BVar : universe_view -> Prims.bool) = + fun projectee -> match projectee with | Uv_BVar _0 -> true | uu___ -> false +let (__proj__Uv_BVar__item___0 : universe_view -> FStarC_BigInt.t) = + fun projectee -> match projectee with | Uv_BVar _0 -> _0 +let (uu___is_Uv_Name : universe_view -> Prims.bool) = + fun projectee -> match projectee with | Uv_Name _0 -> true | uu___ -> false +let (__proj__Uv_Name__item___0 : + universe_view -> FStarC_Syntax_Syntax.univ_name) = + fun projectee -> match projectee with | Uv_Name _0 -> _0 +let (uu___is_Uv_Unif : universe_view -> Prims.bool) = + fun projectee -> match projectee with | Uv_Unif _0 -> true | uu___ -> false +let (__proj__Uv_Unif__item___0 : + universe_view -> FStarC_Syntax_Syntax.universe_uvar) = + fun projectee -> match projectee with | Uv_Unif _0 -> _0 +let (uu___is_Uv_Unk : universe_view -> Prims.bool) = + fun projectee -> match projectee with | Uv_Unk -> true | uu___ -> false +type term_view = + | Tv_Var of namedv + | Tv_BVar of FStarC_Syntax_Syntax.bv + | Tv_FVar of FStarC_Syntax_Syntax.fv + | Tv_UInst of (FStarC_Syntax_Syntax.fv * universes) + | Tv_App of (FStarC_Syntax_Syntax.term * argv) + | Tv_Abs of (FStarC_Syntax_Syntax.binder * FStarC_Syntax_Syntax.term) + | Tv_Arrow of (FStarC_Syntax_Syntax.binder * FStarC_Syntax_Syntax.comp) + | Tv_Type of FStarC_Syntax_Syntax.universe + | Tv_Refine of (FStarC_Syntax_Syntax.binder * FStarC_Syntax_Syntax.term) + | Tv_Const of vconst + | Tv_Uvar of (FStarC_BigInt.t * FStarC_Syntax_Syntax.ctx_uvar_and_subst) + | Tv_Let of (Prims.bool * FStarC_Syntax_Syntax.term Prims.list * + FStarC_Syntax_Syntax.binder * FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.term) + | Tv_Match of (FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.match_returns_ascription + FStar_Pervasives_Native.option * branch Prims.list) + | Tv_AscribedT of (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option * Prims.bool) + | Tv_AscribedC of (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.comp * + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option * Prims.bool) + | Tv_Unknown + | Tv_Unsupp +let (uu___is_Tv_Var : term_view -> Prims.bool) = + fun projectee -> match projectee with | Tv_Var _0 -> true | uu___ -> false +let (__proj__Tv_Var__item___0 : term_view -> namedv) = + fun projectee -> match projectee with | Tv_Var _0 -> _0 +let (uu___is_Tv_BVar : term_view -> Prims.bool) = + fun projectee -> match projectee with | Tv_BVar _0 -> true | uu___ -> false +let (__proj__Tv_BVar__item___0 : term_view -> FStarC_Syntax_Syntax.bv) = + fun projectee -> match projectee with | Tv_BVar _0 -> _0 +let (uu___is_Tv_FVar : term_view -> Prims.bool) = + fun projectee -> match projectee with | Tv_FVar _0 -> true | uu___ -> false +let (__proj__Tv_FVar__item___0 : term_view -> FStarC_Syntax_Syntax.fv) = + fun projectee -> match projectee with | Tv_FVar _0 -> _0 +let (uu___is_Tv_UInst : term_view -> Prims.bool) = + fun projectee -> + match projectee with | Tv_UInst _0 -> true | uu___ -> false +let (__proj__Tv_UInst__item___0 : + term_view -> (FStarC_Syntax_Syntax.fv * universes)) = + fun projectee -> match projectee with | Tv_UInst _0 -> _0 +let (uu___is_Tv_App : term_view -> Prims.bool) = + fun projectee -> match projectee with | Tv_App _0 -> true | uu___ -> false +let (__proj__Tv_App__item___0 : + term_view -> (FStarC_Syntax_Syntax.term * argv)) = + fun projectee -> match projectee with | Tv_App _0 -> _0 +let (uu___is_Tv_Abs : term_view -> Prims.bool) = + fun projectee -> match projectee with | Tv_Abs _0 -> true | uu___ -> false +let (__proj__Tv_Abs__item___0 : + term_view -> (FStarC_Syntax_Syntax.binder * FStarC_Syntax_Syntax.term)) = + fun projectee -> match projectee with | Tv_Abs _0 -> _0 +let (uu___is_Tv_Arrow : term_view -> Prims.bool) = + fun projectee -> + match projectee with | Tv_Arrow _0 -> true | uu___ -> false +let (__proj__Tv_Arrow__item___0 : + term_view -> (FStarC_Syntax_Syntax.binder * FStarC_Syntax_Syntax.comp)) = + fun projectee -> match projectee with | Tv_Arrow _0 -> _0 +let (uu___is_Tv_Type : term_view -> Prims.bool) = + fun projectee -> match projectee with | Tv_Type _0 -> true | uu___ -> false +let (__proj__Tv_Type__item___0 : term_view -> FStarC_Syntax_Syntax.universe) + = fun projectee -> match projectee with | Tv_Type _0 -> _0 +let (uu___is_Tv_Refine : term_view -> Prims.bool) = + fun projectee -> + match projectee with | Tv_Refine _0 -> true | uu___ -> false +let (__proj__Tv_Refine__item___0 : + term_view -> (FStarC_Syntax_Syntax.binder * FStarC_Syntax_Syntax.term)) = + fun projectee -> match projectee with | Tv_Refine _0 -> _0 +let (uu___is_Tv_Const : term_view -> Prims.bool) = + fun projectee -> + match projectee with | Tv_Const _0 -> true | uu___ -> false +let (__proj__Tv_Const__item___0 : term_view -> vconst) = + fun projectee -> match projectee with | Tv_Const _0 -> _0 +let (uu___is_Tv_Uvar : term_view -> Prims.bool) = + fun projectee -> match projectee with | Tv_Uvar _0 -> true | uu___ -> false +let (__proj__Tv_Uvar__item___0 : + term_view -> (FStarC_BigInt.t * FStarC_Syntax_Syntax.ctx_uvar_and_subst)) = + fun projectee -> match projectee with | Tv_Uvar _0 -> _0 +let (uu___is_Tv_Let : term_view -> Prims.bool) = + fun projectee -> match projectee with | Tv_Let _0 -> true | uu___ -> false +let (__proj__Tv_Let__item___0 : + term_view -> + (Prims.bool * FStarC_Syntax_Syntax.term Prims.list * + FStarC_Syntax_Syntax.binder * FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.term)) + = fun projectee -> match projectee with | Tv_Let _0 -> _0 +let (uu___is_Tv_Match : term_view -> Prims.bool) = + fun projectee -> + match projectee with | Tv_Match _0 -> true | uu___ -> false +let (__proj__Tv_Match__item___0 : + term_view -> + (FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.match_returns_ascription + FStar_Pervasives_Native.option * branch Prims.list)) + = fun projectee -> match projectee with | Tv_Match _0 -> _0 +let (uu___is_Tv_AscribedT : term_view -> Prims.bool) = + fun projectee -> + match projectee with | Tv_AscribedT _0 -> true | uu___ -> false +let (__proj__Tv_AscribedT__item___0 : + term_view -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option * Prims.bool)) + = fun projectee -> match projectee with | Tv_AscribedT _0 -> _0 +let (uu___is_Tv_AscribedC : term_view -> Prims.bool) = + fun projectee -> + match projectee with | Tv_AscribedC _0 -> true | uu___ -> false +let (__proj__Tv_AscribedC__item___0 : + term_view -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.comp * + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option * Prims.bool)) + = fun projectee -> match projectee with | Tv_AscribedC _0 -> _0 +let (uu___is_Tv_Unknown : term_view -> Prims.bool) = + fun projectee -> match projectee with | Tv_Unknown -> true | uu___ -> false +let (uu___is_Tv_Unsupp : term_view -> Prims.bool) = + fun projectee -> match projectee with | Tv_Unsupp -> true | uu___ -> false +let (notAscription : term_view -> Prims.bool) = + fun tv -> + (Prims.op_Negation (uu___is_Tv_AscribedT tv)) && + (Prims.op_Negation (uu___is_Tv_AscribedC tv)) +type comp_view = + | C_Total of typ + | C_GTotal of typ + | C_Lemma of (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.term) + | C_Eff of (universes * name * FStarC_Syntax_Syntax.term * argv Prims.list + * FStarC_Syntax_Syntax.term Prims.list) +let (uu___is_C_Total : comp_view -> Prims.bool) = + fun projectee -> match projectee with | C_Total _0 -> true | uu___ -> false +let (__proj__C_Total__item___0 : comp_view -> typ) = + fun projectee -> match projectee with | C_Total _0 -> _0 +let (uu___is_C_GTotal : comp_view -> Prims.bool) = + fun projectee -> + match projectee with | C_GTotal _0 -> true | uu___ -> false +let (__proj__C_GTotal__item___0 : comp_view -> typ) = + fun projectee -> match projectee with | C_GTotal _0 -> _0 +let (uu___is_C_Lemma : comp_view -> Prims.bool) = + fun projectee -> match projectee with | C_Lemma _0 -> true | uu___ -> false +let (__proj__C_Lemma__item___0 : + comp_view -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.term)) + = fun projectee -> match projectee with | C_Lemma _0 -> _0 +let (uu___is_C_Eff : comp_view -> Prims.bool) = + fun projectee -> match projectee with | C_Eff _0 -> true | uu___ -> false +let (__proj__C_Eff__item___0 : + comp_view -> + (universes * name * FStarC_Syntax_Syntax.term * argv Prims.list * + FStarC_Syntax_Syntax.term Prims.list)) + = fun projectee -> match projectee with | C_Eff _0 -> _0 +type ctor = (name * typ) +type lb_view = + { + lb_fv: FStarC_Syntax_Syntax.fv ; + lb_us: FStarC_Syntax_Syntax.univ_name Prims.list ; + lb_typ: typ ; + lb_def: FStarC_Syntax_Syntax.term } +let (__proj__Mklb_view__item__lb_fv : lb_view -> FStarC_Syntax_Syntax.fv) = + fun projectee -> + match projectee with | { lb_fv; lb_us; lb_typ; lb_def;_} -> lb_fv +let (__proj__Mklb_view__item__lb_us : + lb_view -> FStarC_Syntax_Syntax.univ_name Prims.list) = + fun projectee -> + match projectee with | { lb_fv; lb_us; lb_typ; lb_def;_} -> lb_us +let (__proj__Mklb_view__item__lb_typ : lb_view -> typ) = + fun projectee -> + match projectee with | { lb_fv; lb_us; lb_typ; lb_def;_} -> lb_typ +let (__proj__Mklb_view__item__lb_def : lb_view -> FStarC_Syntax_Syntax.term) + = + fun projectee -> + match projectee with | { lb_fv; lb_us; lb_typ; lb_def;_} -> lb_def +type sigelt_view = + | Sg_Let of (Prims.bool * FStarC_Syntax_Syntax.letbinding Prims.list) + | Sg_Inductive of (name * FStarC_Syntax_Syntax.univ_name Prims.list * + FStarC_Syntax_Syntax.binder Prims.list * typ * ctor Prims.list) + | Sg_Val of (name * FStarC_Syntax_Syntax.univ_name Prims.list * typ) + | Unk +let (uu___is_Sg_Let : sigelt_view -> Prims.bool) = + fun projectee -> match projectee with | Sg_Let _0 -> true | uu___ -> false +let (__proj__Sg_Let__item___0 : + sigelt_view -> (Prims.bool * FStarC_Syntax_Syntax.letbinding Prims.list)) = + fun projectee -> match projectee with | Sg_Let _0 -> _0 +let (uu___is_Sg_Inductive : sigelt_view -> Prims.bool) = + fun projectee -> + match projectee with | Sg_Inductive _0 -> true | uu___ -> false +let (__proj__Sg_Inductive__item___0 : + sigelt_view -> + (name * FStarC_Syntax_Syntax.univ_name Prims.list * + FStarC_Syntax_Syntax.binder Prims.list * typ * ctor Prims.list)) + = fun projectee -> match projectee with | Sg_Inductive _0 -> _0 +let (uu___is_Sg_Val : sigelt_view -> Prims.bool) = + fun projectee -> match projectee with | Sg_Val _0 -> true | uu___ -> false +let (__proj__Sg_Val__item___0 : + sigelt_view -> (name * FStarC_Syntax_Syntax.univ_name Prims.list * typ)) = + fun projectee -> match projectee with | Sg_Val _0 -> _0 +let (uu___is_Unk : sigelt_view -> Prims.bool) = + fun projectee -> match projectee with | Unk -> true | uu___ -> false +type qualifier = + | Assumption + | InternalAssumption + | New + | Private + | Unfold_for_unification_and_vcgen + | Visible_default + | Irreducible + | Inline_for_extraction + | NoExtract + | Noeq + | Unopteq + | TotalEffect + | Logic + | Reifiable + | Reflectable of name + | Discriminator of name + | Projector of (name * FStarC_Ident.ident) + | RecordType of (FStarC_Ident.ident Prims.list * FStarC_Ident.ident + Prims.list) + | RecordConstructor of (FStarC_Ident.ident Prims.list * FStarC_Ident.ident + Prims.list) + | Action of name + | ExceptionConstructor + | HasMaskedEffect + | Effect + | OnlyName +let (uu___is_Assumption : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Assumption -> true | uu___ -> false +let (uu___is_InternalAssumption : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | InternalAssumption -> true | uu___ -> false +let (uu___is_New : qualifier -> Prims.bool) = + fun projectee -> match projectee with | New -> true | uu___ -> false +let (uu___is_Private : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Private -> true | uu___ -> false +let (uu___is_Unfold_for_unification_and_vcgen : qualifier -> Prims.bool) = + fun projectee -> + match projectee with + | Unfold_for_unification_and_vcgen -> true + | uu___ -> false +let (uu___is_Visible_default : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | Visible_default -> true | uu___ -> false +let (uu___is_Irreducible : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | Irreducible -> true | uu___ -> false +let (uu___is_Inline_for_extraction : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | Inline_for_extraction -> true | uu___ -> false +let (uu___is_NoExtract : qualifier -> Prims.bool) = + fun projectee -> match projectee with | NoExtract -> true | uu___ -> false +let (uu___is_Noeq : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Noeq -> true | uu___ -> false +let (uu___is_Unopteq : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Unopteq -> true | uu___ -> false +let (uu___is_TotalEffect : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | TotalEffect -> true | uu___ -> false +let (uu___is_Logic : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Logic -> true | uu___ -> false +let (uu___is_Reifiable : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Reifiable -> true | uu___ -> false +let (uu___is_Reflectable : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | Reflectable _0 -> true | uu___ -> false +let (__proj__Reflectable__item___0 : qualifier -> name) = + fun projectee -> match projectee with | Reflectable _0 -> _0 +let (uu___is_Discriminator : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | Discriminator _0 -> true | uu___ -> false +let (__proj__Discriminator__item___0 : qualifier -> name) = + fun projectee -> match projectee with | Discriminator _0 -> _0 +let (uu___is_Projector : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | Projector _0 -> true | uu___ -> false +let (__proj__Projector__item___0 : qualifier -> (name * FStarC_Ident.ident)) + = fun projectee -> match projectee with | Projector _0 -> _0 +let (uu___is_RecordType : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | RecordType _0 -> true | uu___ -> false +let (__proj__RecordType__item___0 : + qualifier -> + (FStarC_Ident.ident Prims.list * FStarC_Ident.ident Prims.list)) + = fun projectee -> match projectee with | RecordType _0 -> _0 +let (uu___is_RecordConstructor : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | RecordConstructor _0 -> true | uu___ -> false +let (__proj__RecordConstructor__item___0 : + qualifier -> + (FStarC_Ident.ident Prims.list * FStarC_Ident.ident Prims.list)) + = fun projectee -> match projectee with | RecordConstructor _0 -> _0 +let (uu___is_Action : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Action _0 -> true | uu___ -> false +let (__proj__Action__item___0 : qualifier -> name) = + fun projectee -> match projectee with | Action _0 -> _0 +let (uu___is_ExceptionConstructor : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | ExceptionConstructor -> true | uu___ -> false +let (uu___is_HasMaskedEffect : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | HasMaskedEffect -> true | uu___ -> false +let (uu___is_Effect : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Effect -> true | uu___ -> false +let (uu___is_OnlyName : qualifier -> Prims.bool) = + fun projectee -> match projectee with | OnlyName -> true | uu___ -> false +type qualifiers = qualifier Prims.list +type var = FStarC_BigInt.t +type exp = + | Unit + | Var of var + | Mult of (exp * exp) +let (uu___is_Unit : exp -> Prims.bool) = + fun projectee -> match projectee with | Unit -> true | uu___ -> false +let (uu___is_Var : exp -> Prims.bool) = + fun projectee -> match projectee with | Var _0 -> true | uu___ -> false +let (__proj__Var__item___0 : exp -> var) = + fun projectee -> match projectee with | Var _0 -> _0 +let (uu___is_Mult : exp -> Prims.bool) = + fun projectee -> match projectee with | Mult _0 -> true | uu___ -> false +let (__proj__Mult__item___0 : exp -> (exp * exp)) = + fun projectee -> match projectee with | Mult _0 -> _0 +type decls = FStarC_Syntax_Syntax.sigelt Prims.list \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Reflection_V2_Embeddings.ml b/ocaml/fstar-lib/generated/FStarC_Reflection_V2_Embeddings.ml new file mode 100644 index 00000000000..ee9801634ed --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Reflection_V2_Embeddings.ml @@ -0,0 +1,2718 @@ +open Prims +type namedv = FStarC_Syntax_Syntax.bv +let mk_emb : + 'uuuuu . + (FStarC_Compiler_Range_Type.range -> 'uuuuu -> FStarC_Syntax_Syntax.term) + -> + (FStarC_Syntax_Syntax.term -> 'uuuuu FStar_Pervasives_Native.option) -> + FStarC_Syntax_Syntax.term -> + 'uuuuu FStarC_Syntax_Embeddings_Base.embedding + = + fun f -> + fun g -> + fun t -> + let uu___ = FStarC_Syntax_Embeddings_Base.term_as_fv t in + FStarC_Syntax_Embeddings_Base.mk_emb + (fun x -> fun r -> fun _topt -> fun _norm -> f r x) + (fun x -> fun _norm -> g x) uu___ +let embed : + 'a . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_Compiler_Range_Type.range -> 'a -> FStarC_Syntax_Syntax.term + = + fun uu___ -> + fun r -> + fun x -> + let uu___1 = FStarC_Syntax_Embeddings_Base.embed uu___ x in + uu___1 r FStar_Pervasives_Native.None + FStarC_Syntax_Embeddings_Base.id_norm_cb +let try_unembed : + 'a . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_Syntax_Syntax.term -> 'a FStar_Pervasives_Native.option + = + fun uu___ -> + fun x -> + FStarC_Syntax_Embeddings_Base.try_unembed uu___ x + FStarC_Syntax_Embeddings_Base.id_norm_cb +let curry : + 'uuuuu 'uuuuu1 'uuuuu2 . + (('uuuuu * 'uuuuu1) -> 'uuuuu2) -> 'uuuuu -> 'uuuuu1 -> 'uuuuu2 + = fun f -> fun x -> fun y -> f (x, y) +let curry3 : + 'uuuuu 'uuuuu1 'uuuuu2 'uuuuu3 . + (('uuuuu * 'uuuuu1 * 'uuuuu2) -> 'uuuuu3) -> + 'uuuuu -> 'uuuuu1 -> 'uuuuu2 -> 'uuuuu3 + = fun f -> fun x -> fun y -> fun z -> f (x, y, z) +let curry4 : + 'uuuuu 'uuuuu1 'uuuuu2 'uuuuu3 'uuuuu4 . + (('uuuuu * 'uuuuu1 * 'uuuuu2 * 'uuuuu3) -> 'uuuuu4) -> + 'uuuuu -> 'uuuuu1 -> 'uuuuu2 -> 'uuuuu3 -> 'uuuuu4 + = fun f -> fun x -> fun y -> fun z -> fun w -> f (x, y, z, w) +let curry5 : + 'uuuuu 'uuuuu1 'uuuuu2 'uuuuu3 'uuuuu4 'uuuuu5 . + (('uuuuu * 'uuuuu1 * 'uuuuu2 * 'uuuuu3 * 'uuuuu4) -> 'uuuuu5) -> + 'uuuuu -> 'uuuuu1 -> 'uuuuu2 -> 'uuuuu3 -> 'uuuuu4 -> 'uuuuu5 + = fun f -> fun x -> fun y -> fun z -> fun w -> fun v -> f (x, y, z, w, v) +let (head_fv_and_args : + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.fv * FStarC_Syntax_Syntax.args) + FStar_Pervasives_Native.option) + = + fun t -> + let t1 = FStarC_Syntax_Util.unascribe t in + let uu___ = FStarC_Syntax_Util.head_and_args t1 in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = FStarC_Syntax_Util.un_uinst hd in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + FStar_Pervasives_Native.Some (fv, args) + | uu___2 -> FStar_Pervasives_Native.None) +let (noaqs : FStarC_Syntax_Syntax.antiquotations) = (Prims.int_zero, []) +let (e_bv : FStarC_Syntax_Syntax.bv FStarC_Syntax_Embeddings_Base.embedding) + = + FStarC_Syntax_Embeddings_Base.e_lazy FStarC_Syntax_Syntax.Lazy_bv + FStarC_Reflection_V2_Constants.fstar_refl_bv +let (e_namedv : namedv FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Syntax_Embeddings_Base.e_lazy FStarC_Syntax_Syntax.Lazy_namedv + FStarC_Reflection_V2_Constants.fstar_refl_namedv +let (e_binder : + FStarC_Syntax_Syntax.binder FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Syntax_Embeddings_Base.e_lazy FStarC_Syntax_Syntax.Lazy_binder + FStarC_Reflection_V2_Constants.fstar_refl_binder +let (e_fv : FStarC_Syntax_Syntax.fv FStarC_Syntax_Embeddings_Base.embedding) + = + FStarC_Syntax_Embeddings_Base.e_lazy FStarC_Syntax_Syntax.Lazy_fvar + FStarC_Reflection_V2_Constants.fstar_refl_fv +let (e_comp : + FStarC_Syntax_Syntax.comp FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Syntax_Embeddings_Base.e_lazy FStarC_Syntax_Syntax.Lazy_comp + FStarC_Reflection_V2_Constants.fstar_refl_comp +let (e_universe : + FStarC_Syntax_Syntax.universe FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Syntax_Embeddings_Base.e_lazy FStarC_Syntax_Syntax.Lazy_universe + FStarC_Reflection_V2_Constants.fstar_refl_universe +let (e_ident : FStarC_Ident.ident FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Syntax_Embeddings_Base.e_lazy FStarC_Syntax_Syntax.Lazy_ident + FStarC_Reflection_V2_Constants.fstar_refl_ident +let (e_env : + FStarC_TypeChecker_Env.env FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Syntax_Embeddings_Base.e_lazy FStarC_Syntax_Syntax.Lazy_env + FStarC_Reflection_V2_Constants.fstar_refl_env +let (e_sigelt : + FStarC_Syntax_Syntax.sigelt FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Syntax_Embeddings_Base.e_lazy FStarC_Syntax_Syntax.Lazy_sigelt + FStarC_Reflection_V2_Constants.fstar_refl_sigelt +let (e_letbinding : + FStarC_Syntax_Syntax.letbinding FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Syntax_Embeddings_Base.e_lazy FStarC_Syntax_Syntax.Lazy_letbinding + FStarC_Reflection_V2_Constants.fstar_refl_letbinding +let (e_ctx_uvar_and_subst : + FStarC_Syntax_Syntax.ctx_uvar_and_subst + FStarC_Syntax_Embeddings_Base.embedding) + = + FStarC_Syntax_Embeddings_Base.e_lazy FStarC_Syntax_Syntax.Lazy_uvar + FStarC_Reflection_V2_Constants.fstar_refl_ctx_uvar_and_subst +let (e_universe_uvar : + FStarC_Syntax_Syntax.universe_uvar FStarC_Syntax_Embeddings_Base.embedding) + = + FStarC_Syntax_Embeddings_Base.e_lazy + FStarC_Syntax_Syntax.Lazy_universe_uvar + FStarC_Reflection_V2_Constants.fstar_refl_universe_uvar +let rec mapM_opt : + 'a 'b . + ('a -> 'b FStar_Pervasives_Native.option) -> + 'a Prims.list -> 'b Prims.list FStar_Pervasives_Native.option + = + fun f -> + fun l -> + match l with + | [] -> FStar_Pervasives_Native.Some [] + | x::xs -> + let uu___ = f x in + FStarC_Compiler_Util.bind_opt uu___ + (fun x1 -> + let uu___1 = mapM_opt f xs in + FStarC_Compiler_Util.bind_opt uu___1 + (fun xs1 -> FStar_Pervasives_Native.Some (x1 :: xs1))) +let (e_term_aq : + FStarC_Syntax_Syntax.antiquotations -> + FStarC_Syntax_Syntax.term FStarC_Syntax_Embeddings_Base.embedding) + = + fun aq -> + let embed_term rng t = + let qi = + { + FStarC_Syntax_Syntax.qkind = FStarC_Syntax_Syntax.Quote_static; + FStarC_Syntax_Syntax.antiquotations = aq + } in + FStarC_Syntax_Syntax.mk (FStarC_Syntax_Syntax.Tm_quoted (t, qi)) rng in + let rec unembed_term t = + let apply_antiquotations t1 aq1 = + let uu___ = aq1 in + match uu___ with + | (shift, aqs) -> + let aqs1 = FStarC_Compiler_List.rev aqs in + let uu___1 = mapM_opt unembed_term aqs1 in + FStarC_Compiler_Util.bind_opt uu___1 + (fun aq_ts -> + let uu___2 = + let uu___3 = + FStarC_Compiler_List.mapi + (fun i -> + fun at -> + let x = + FStarC_Syntax_Syntax.new_bv + FStar_Pervasives_Native.None + FStarC_Syntax_Syntax.t_term in + ((FStarC_Syntax_Syntax.DB ((shift + i), x)), + (FStarC_Syntax_Syntax.NT (x, at)))) aq_ts in + FStarC_Compiler_List.unzip uu___3 in + match uu___2 with + | (subst_open, subst) -> + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.subst subst_open t1 in + FStarC_Syntax_Subst.subst subst uu___4 in + FStar_Pervasives_Native.Some uu___3) in + let t1 = FStarC_Syntax_Util.unmeta t in + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t1 in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_quoted (tm, qi) -> + apply_antiquotations tm qi.FStarC_Syntax_Syntax.antiquotations + | uu___1 -> FStar_Pervasives_Native.None in + mk_emb embed_term unembed_term FStarC_Syntax_Syntax.t_term +let (e_term : + FStarC_Syntax_Syntax.term FStarC_Syntax_Embeddings_Base.embedding) = + e_term_aq noaqs +let (e_sort : + FStarC_Syntax_Syntax.term FStarC_Compiler_Sealed.sealed + FStarC_Syntax_Embeddings_Base.embedding) + = FStarC_Syntax_Embeddings.e_sealed e_term +let (e_ppname : + FStarC_Reflection_V2_Data.ppname_t FStarC_Syntax_Embeddings_Base.embedding) + = FStarC_Syntax_Embeddings.e_sealed FStarC_Syntax_Embeddings.e_string +let (e_aqualv : + FStarC_Reflection_V2_Data.aqualv FStarC_Syntax_Embeddings_Base.embedding) = + let embed_aqualv rng q = + let r = + match q with + | FStarC_Reflection_V2_Data.Q_Explicit -> + FStarC_Reflection_V2_Constants.ref_Q_Explicit.FStarC_Reflection_V2_Constants.t + | FStarC_Reflection_V2_Data.Q_Implicit -> + FStarC_Reflection_V2_Constants.ref_Q_Implicit.FStarC_Reflection_V2_Constants.t + | FStarC_Reflection_V2_Data.Q_Equality -> + FStarC_Reflection_V2_Constants.ref_Q_Equality.FStarC_Reflection_V2_Constants.t + | FStarC_Reflection_V2_Data.Q_Meta t -> + let uu___ = + let uu___1 = + let uu___2 = embed e_term rng t in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Q_Meta.FStarC_Reflection_V2_Constants.t + uu___ FStarC_Compiler_Range_Type.dummyRange in + { + FStarC_Syntax_Syntax.n = (r.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = rng; + FStarC_Syntax_Syntax.vars = (r.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = (r.FStarC_Syntax_Syntax.hash_code) + } in + let unembed_aqualv t = + let uu___ = head_fv_and_args t in + FStarC_Syntax_Embeddings_AppEmb.op_let_Question uu___ + (fun uu___1 -> + match uu___1 with + | (fv, args) -> + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Q_Explicit.FStarC_Reflection_V2_Constants.lid + then + let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.pure + FStarC_Reflection_V2_Data.Q_Explicit in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2 + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Q_Implicit.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.pure + FStarC_Reflection_V2_Data.Q_Implicit in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Q_Equality.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.pure + FStarC_Reflection_V2_Data.Q_Equality in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Q_Meta.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___3 -> + FStarC_Reflection_V2_Data.Q_Meta uu___3) e_term in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else FStar_Pervasives_Native.None) in + mk_emb embed_aqualv unembed_aqualv + FStarC_Reflection_V2_Constants.fstar_refl_aqualv +let (e_binders : + FStarC_Syntax_Syntax.binders FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Syntax_Embeddings.e_list e_binder +let (e_universe_view : + FStarC_Reflection_V2_Data.universe_view + FStarC_Syntax_Embeddings_Base.embedding) + = + let embed_universe_view rng uv = + match uv with + | FStarC_Reflection_V2_Data.Uv_Zero -> + FStarC_Reflection_V2_Constants.ref_Uv_Zero.FStarC_Reflection_V2_Constants.t + | FStarC_Reflection_V2_Data.Uv_Succ u -> + let uu___ = + let uu___1 = + let uu___2 = embed e_universe rng u in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Uv_Succ.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Reflection_V2_Data.Uv_Max us -> + let uu___ = + let uu___1 = + let uu___2 = + embed (FStarC_Syntax_Embeddings.e_list e_universe) rng us in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Uv_Max.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Reflection_V2_Data.Uv_BVar n -> + let uu___ = + let uu___1 = + let uu___2 = embed FStarC_Syntax_Embeddings.e_int rng n in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Uv_BVar.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Reflection_V2_Data.Uv_Name i -> + let uu___ = + let uu___1 = + let uu___2 = embed e_ident rng i in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Uv_Name.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Reflection_V2_Data.Uv_Unif u -> + let uu___ = + let uu___1 = + let uu___2 = embed e_universe_uvar rng u in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Uv_Unif.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Reflection_V2_Data.Uv_Unk -> + FStarC_Reflection_V2_Constants.ref_Uv_Unk.FStarC_Reflection_V2_Constants.t in + let unembed_universe_view t = + let uu___ = head_fv_and_args t in + FStarC_Syntax_Embeddings_AppEmb.op_let_Question uu___ + (fun uu___1 -> + match uu___1 with + | (fv, args) -> + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Uv_Zero.FStarC_Reflection_V2_Constants.lid + then + let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.pure + FStarC_Reflection_V2_Data.Uv_Zero in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2 + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Uv_Succ.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___3 -> FStarC_Reflection_V2_Data.Uv_Succ uu___3) + e_universe in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Uv_Max.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___3 -> + FStarC_Reflection_V2_Data.Uv_Max uu___3) + (FStarC_Syntax_Embeddings.e_list e_universe) in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Uv_BVar.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___3 -> + FStarC_Reflection_V2_Data.Uv_BVar uu___3) + FStarC_Syntax_Embeddings.e_int in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Uv_Name.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___3 -> + FStarC_Reflection_V2_Data.Uv_Name uu___3) + e_ident in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Uv_Unif.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___3 -> + FStarC_Reflection_V2_Data.Uv_Unif uu___3) + e_universe_uvar in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Uv_Unk.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.pure + FStarC_Reflection_V2_Data.Uv_Unk in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else FStar_Pervasives_Native.None) in + mk_emb embed_universe_view unembed_universe_view + FStarC_Reflection_V2_Constants.fstar_refl_universe_view +let (e_vconst : + FStarC_Reflection_V2_Data.vconst FStarC_Syntax_Embeddings_Base.embedding) = + let embed_const rng c = + let r = + match c with + | FStarC_Reflection_V2_Data.C_Unit -> + FStarC_Reflection_V2_Constants.ref_C_Unit.FStarC_Reflection_V2_Constants.t + | FStarC_Reflection_V2_Data.C_True -> + FStarC_Reflection_V2_Constants.ref_C_True.FStarC_Reflection_V2_Constants.t + | FStarC_Reflection_V2_Data.C_False -> + FStarC_Reflection_V2_Constants.ref_C_False.FStarC_Reflection_V2_Constants.t + | FStarC_Reflection_V2_Data.C_Int i -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_BigInt.string_of_big_int i in + FStarC_Syntax_Util.exp_int uu___3 in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_C_Int.FStarC_Reflection_V2_Constants.t + uu___ FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V2_Data.C_String s -> + let uu___ = + let uu___1 = + let uu___2 = embed FStarC_Syntax_Embeddings.e_string rng s in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_C_String.FStarC_Reflection_V2_Constants.t + uu___ FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V2_Data.C_Range r1 -> + let uu___ = + let uu___1 = + let uu___2 = embed FStarC_Syntax_Embeddings.e_range rng r1 in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_C_Range.FStarC_Reflection_V2_Constants.t + uu___ FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V2_Data.C_Reify -> + FStarC_Reflection_V2_Constants.ref_C_Reify.FStarC_Reflection_V2_Constants.t + | FStarC_Reflection_V2_Data.C_Reflect ns -> + let uu___ = + let uu___1 = + let uu___2 = + embed FStarC_Syntax_Embeddings.e_string_list rng ns in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_C_Reflect.FStarC_Reflection_V2_Constants.t + uu___ FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V2_Data.C_Real s -> + let uu___ = + let uu___1 = + let uu___2 = embed FStarC_Syntax_Embeddings.e_string rng s in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_C_Real.FStarC_Reflection_V2_Constants.t + uu___ FStarC_Compiler_Range_Type.dummyRange in + { + FStarC_Syntax_Syntax.n = (r.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = rng; + FStarC_Syntax_Syntax.vars = (r.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = (r.FStarC_Syntax_Syntax.hash_code) + } in + let unembed_const t = + let uu___ = head_fv_and_args t in + FStarC_Syntax_Embeddings_AppEmb.op_let_Question uu___ + (fun uu___1 -> + match uu___1 with + | (fv, args) -> + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_C_Unit.FStarC_Reflection_V2_Constants.lid + then + let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.pure + FStarC_Reflection_V2_Data.C_Unit in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2 + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_C_True.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.pure + FStarC_Reflection_V2_Data.C_True in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_C_False.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.pure + FStarC_Reflection_V2_Data.C_False in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_C_Int.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___3 -> + FStarC_Reflection_V2_Data.C_Int uu___3) + FStarC_Syntax_Embeddings.e_int in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_C_String.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___3 -> + FStarC_Reflection_V2_Data.C_String uu___3) + FStarC_Syntax_Embeddings.e_string in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_C_Range.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___3 -> + FStarC_Reflection_V2_Data.C_Range uu___3) + FStarC_Syntax_Embeddings.e_range in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_C_Reify.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.pure + FStarC_Reflection_V2_Data.C_Reify in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_C_Reflect.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___3 -> + FStarC_Reflection_V2_Data.C_Reflect + uu___3) + FStarC_Syntax_Embeddings.e_string_list in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_C_Real.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___3 -> + FStarC_Reflection_V2_Data.C_Real + uu___3) + FStarC_Syntax_Embeddings.e_string in + FStarC_Syntax_Embeddings_AppEmb.run args + uu___2) + else FStar_Pervasives_Native.None) in + mk_emb embed_const unembed_const + FStarC_Reflection_V2_Constants.fstar_refl_vconst +let rec e_pattern_aq : + 'uuuuu . + 'uuuuu -> + FStarC_Reflection_V2_Data.pattern + FStarC_Syntax_Embeddings_Base.embedding + = + fun aq -> + let rec embed_pattern rng p = + match p with + | FStarC_Reflection_V2_Data.Pat_Constant c -> + let uu___ = + let uu___1 = + let uu___2 = embed e_vconst rng c in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Pat_Constant.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Reflection_V2_Data.Pat_Cons (head, univs, subpats) -> + let uu___ = + let uu___1 = + let uu___2 = embed e_fv rng head in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + embed + (FStarC_Syntax_Embeddings.e_option + (FStarC_Syntax_Embeddings.e_list e_universe)) rng + univs in + FStarC_Syntax_Syntax.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = e_pattern_aq aq in + FStarC_Syntax_Embeddings.e_tuple2 uu___9 + FStarC_Syntax_Embeddings.e_bool in + FStarC_Syntax_Embeddings.e_list uu___8 in + embed uu___7 rng subpats in + FStarC_Syntax_Syntax.as_arg uu___6 in + [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Pat_Cons.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Reflection_V2_Data.Pat_Var (sort, ppname) -> + let uu___ = + let uu___1 = + let uu___2 = embed e_sort rng sort in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + embed + (FStarC_Syntax_Embeddings.e_sealed + FStarC_Syntax_Embeddings.e_string) rng ppname in + FStarC_Syntax_Syntax.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Pat_Var.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Reflection_V2_Data.Pat_Dot_Term eopt -> + let uu___ = + let uu___1 = + let uu___2 = + embed (FStarC_Syntax_Embeddings.e_option e_term) rng eopt in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Pat_Dot_Term.FStarC_Reflection_V2_Constants.t + uu___ rng in + let rec unembed_pattern t = + let uu___ = head_fv_and_args t in + FStarC_Syntax_Embeddings_AppEmb.op_let_Question uu___ + (fun uu___1 -> + match uu___1 with + | (fv, args) -> + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Pat_Constant.FStarC_Reflection_V2_Constants.lid + then + let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___3 -> + FStarC_Reflection_V2_Data.Pat_Constant uu___3) + e_vconst in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2 + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Pat_Cons.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___5 -> + fun uu___6 -> + fun uu___7 -> + FStarC_Reflection_V2_Data.Pat_Cons + (uu___5, uu___6, uu___7)) e_fv in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___4 + (FStarC_Syntax_Embeddings.e_option + (FStarC_Syntax_Embeddings.e_list e_universe)) in + let uu___4 = + let uu___5 = + let uu___6 = e_pattern_aq aq in + FStarC_Syntax_Embeddings.e_tuple2 uu___6 + FStarC_Syntax_Embeddings.e_bool in + FStarC_Syntax_Embeddings.e_list uu___5 in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___3 uu___4 in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Pat_Var.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + let uu___3 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___4 -> + fun uu___5 -> + FStarC_Reflection_V2_Data.Pat_Var + (uu___4, uu___5)) e_sort in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___3 e_ppname in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Pat_Dot_Term.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___3 -> + FStarC_Reflection_V2_Data.Pat_Dot_Term uu___3) + (FStarC_Syntax_Embeddings.e_option e_term) in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else FStar_Pervasives_Native.None) in + mk_emb embed_pattern unembed_pattern + FStarC_Reflection_V2_Constants.fstar_refl_pattern +let (e_pattern : + FStarC_Reflection_V2_Data.pattern FStarC_Syntax_Embeddings_Base.embedding) + = e_pattern_aq noaqs +let (e_branch : + FStarC_Reflection_V2_Data.branch FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Syntax_Embeddings.e_tuple2 e_pattern e_term +let (e_argv : + FStarC_Reflection_V2_Data.argv FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Syntax_Embeddings.e_tuple2 e_term e_aqualv +let (e_args : + FStarC_Reflection_V2_Data.argv Prims.list + FStarC_Syntax_Embeddings_Base.embedding) + = FStarC_Syntax_Embeddings.e_list e_argv +let (e_branch_aq : + FStarC_Syntax_Syntax.antiquotations -> + (FStarC_Reflection_V2_Data.pattern * FStarC_Syntax_Syntax.term) + FStarC_Syntax_Embeddings_Base.embedding) + = + fun aq -> + let uu___ = e_pattern_aq aq in + let uu___1 = e_term_aq aq in + FStarC_Syntax_Embeddings.e_tuple2 uu___ uu___1 +let (e_argv_aq : + FStarC_Syntax_Syntax.antiquotations -> + (FStarC_Syntax_Syntax.term * FStarC_Reflection_V2_Data.aqualv) + FStarC_Syntax_Embeddings_Base.embedding) + = + fun aq -> + let uu___ = e_term_aq aq in + FStarC_Syntax_Embeddings.e_tuple2 uu___ e_aqualv +let (e_match_returns_annotation : + (FStarC_Syntax_Syntax.binder * ((FStarC_Syntax_Syntax.term, + FStarC_Syntax_Syntax.comp) FStar_Pervasives.either * + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option * Prims.bool)) + FStar_Pervasives_Native.option FStarC_Syntax_Embeddings_Base.embedding) + = + FStarC_Syntax_Embeddings.e_option + (FStarC_Syntax_Embeddings.e_tuple2 e_binder + (FStarC_Syntax_Embeddings.e_tuple3 + (FStarC_Syntax_Embeddings.e_either e_term e_comp) + (FStarC_Syntax_Embeddings.e_option e_term) + FStarC_Syntax_Embeddings.e_bool)) +let (e_term_view_aq : + FStarC_Syntax_Syntax.antiquotations -> + FStarC_Reflection_V2_Data.term_view + FStarC_Syntax_Embeddings_Base.embedding) + = + fun aq -> + let push uu___ = + match uu___ with | (s, aq1) -> ((s + Prims.int_one), aq1) in + let embed_term_view rng t = + match t with + | FStarC_Reflection_V2_Data.Tv_FVar fv -> + let uu___ = + let uu___1 = + let uu___2 = embed e_fv rng fv in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Tv_FVar.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Reflection_V2_Data.Tv_BVar fv -> + let uu___ = + let uu___1 = + let uu___2 = embed e_bv rng fv in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Tv_BVar.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Reflection_V2_Data.Tv_Var bv -> + let uu___ = + let uu___1 = + let uu___2 = embed e_namedv rng bv in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Tv_Var.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Reflection_V2_Data.Tv_UInst (fv, us) -> + let uu___ = + let uu___1 = + let uu___2 = embed e_fv rng fv in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + embed (FStarC_Syntax_Embeddings.e_list e_universe) rng us in + FStarC_Syntax_Syntax.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Tv_UInst.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Reflection_V2_Data.Tv_App (hd, a) -> + let uu___ = + let uu___1 = + let uu___2 = let uu___3 = e_term_aq aq in embed uu___3 rng hd in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = let uu___5 = e_argv_aq aq in embed uu___5 rng a in + FStarC_Syntax_Syntax.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Tv_App.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Reflection_V2_Data.Tv_Abs (b, t1) -> + let uu___ = + let uu___1 = + let uu___2 = embed e_binder rng b in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = e_term_aq (push aq) in embed uu___5 rng t1 in + FStarC_Syntax_Syntax.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Tv_Abs.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Reflection_V2_Data.Tv_Arrow (b, c) -> + let uu___ = + let uu___1 = + let uu___2 = embed e_binder rng b in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = embed e_comp rng c in + FStarC_Syntax_Syntax.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Tv_Arrow.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Reflection_V2_Data.Tv_Type u -> + let uu___ = + let uu___1 = + let uu___2 = embed e_universe rng u in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Tv_Type.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Reflection_V2_Data.Tv_Refine (b, t1) -> + let uu___ = + let uu___1 = + let uu___2 = embed e_binder rng b in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = e_term_aq (push aq) in embed uu___5 rng t1 in + FStarC_Syntax_Syntax.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Tv_Refine.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Reflection_V2_Data.Tv_Const c -> + let uu___ = + let uu___1 = + let uu___2 = embed e_vconst rng c in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Tv_Const.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Reflection_V2_Data.Tv_Uvar (u, ctx_u) -> + let uu___ = + let uu___1 = + let uu___2 = embed FStarC_Syntax_Embeddings.e_int rng u in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = embed e_ctx_uvar_and_subst rng ctx_u in + FStarC_Syntax_Syntax.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Tv_Uvar.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Reflection_V2_Data.Tv_Let (r, attrs, b, t1, t2) -> + let uu___ = + let uu___1 = + let uu___2 = embed FStarC_Syntax_Embeddings.e_bool rng r in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + embed (FStarC_Syntax_Embeddings.e_list e_term) rng attrs in + FStarC_Syntax_Syntax.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = embed e_binder rng b in + FStarC_Syntax_Syntax.as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = e_term_aq aq in embed uu___9 rng t1 in + FStarC_Syntax_Syntax.as_arg uu___8 in + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = e_term_aq (push aq) in + embed uu___11 rng t2 in + FStarC_Syntax_Syntax.as_arg uu___10 in + [uu___9] in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Tv_Let.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Reflection_V2_Data.Tv_Match (t1, ret_opt, brs) -> + let uu___ = + let uu___1 = + let uu___2 = let uu___3 = e_term_aq aq in embed uu___3 rng t1 in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = embed e_match_returns_annotation rng ret_opt in + FStarC_Syntax_Syntax.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = e_branch_aq aq in + FStarC_Syntax_Embeddings.e_list uu___8 in + embed uu___7 rng brs in + FStarC_Syntax_Syntax.as_arg uu___6 in + [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Tv_Match.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Reflection_V2_Data.Tv_AscribedT (e, t1, tacopt, use_eq) -> + let uu___ = + let uu___1 = + let uu___2 = let uu___3 = e_term_aq aq in embed uu___3 rng e in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = let uu___5 = e_term_aq aq in embed uu___5 rng t1 in + FStarC_Syntax_Syntax.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = e_term_aq aq in + FStarC_Syntax_Embeddings.e_option uu___8 in + embed uu___7 rng tacopt in + FStarC_Syntax_Syntax.as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + embed FStarC_Syntax_Embeddings.e_bool rng use_eq in + FStarC_Syntax_Syntax.as_arg uu___8 in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Tv_AscT.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Reflection_V2_Data.Tv_AscribedC (e, c, tacopt, use_eq) -> + let uu___ = + let uu___1 = + let uu___2 = let uu___3 = e_term_aq aq in embed uu___3 rng e in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = embed e_comp rng c in + FStarC_Syntax_Syntax.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = e_term_aq aq in + FStarC_Syntax_Embeddings.e_option uu___8 in + embed uu___7 rng tacopt in + FStarC_Syntax_Syntax.as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + embed FStarC_Syntax_Embeddings.e_bool rng use_eq in + FStarC_Syntax_Syntax.as_arg uu___8 in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Tv_AscC.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Reflection_V2_Data.Tv_Unknown -> + let uu___ = + FStarC_Reflection_V2_Constants.ref_Tv_Unknown.FStarC_Reflection_V2_Constants.t in + { + FStarC_Syntax_Syntax.n = (uu___.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = rng; + FStarC_Syntax_Syntax.vars = (uu___.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (uu___.FStarC_Syntax_Syntax.hash_code) + } + | FStarC_Reflection_V2_Data.Tv_Unsupp -> + let uu___ = + FStarC_Reflection_V2_Constants.ref_Tv_Unsupp.FStarC_Reflection_V2_Constants.t in + { + FStarC_Syntax_Syntax.n = (uu___.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = rng; + FStarC_Syntax_Syntax.vars = (uu___.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (uu___.FStarC_Syntax_Syntax.hash_code) + } in + let unembed_term_view t = + let uu___ = head_fv_and_args t in + FStarC_Syntax_Embeddings_AppEmb.op_let_Question uu___ + (fun uu___1 -> + match uu___1 with + | (fv, args) -> + let xTv_Let a b c d e = + FStarC_Reflection_V2_Data.Tv_Let (a, b, c, d, e) in + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Tv_FVar.FStarC_Reflection_V2_Constants.lid + then + let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___3 -> FStarC_Reflection_V2_Data.Tv_FVar uu___3) + e_fv in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2 + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Tv_BVar.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___3 -> + FStarC_Reflection_V2_Data.Tv_BVar uu___3) e_bv in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Tv_Var.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___3 -> + FStarC_Reflection_V2_Data.Tv_Var uu___3) + e_namedv in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Tv_UInst.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + let uu___3 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (curry + (fun uu___4 -> + FStarC_Reflection_V2_Data.Tv_UInst uu___4)) + e_fv in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___3 + (FStarC_Syntax_Embeddings.e_list e_universe) in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Tv_App.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + let uu___3 = + let uu___4 = e_term_aq aq in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (curry + (fun uu___5 -> + FStarC_Reflection_V2_Data.Tv_App uu___5)) + uu___4 in + let uu___4 = e_argv_aq aq in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___3 uu___4 in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Tv_Abs.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + let uu___3 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (curry + (fun uu___4 -> + FStarC_Reflection_V2_Data.Tv_Abs + uu___4)) e_binder in + let uu___4 = e_term_aq (push aq) in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___3 uu___4 in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Tv_Arrow.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + let uu___3 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (curry + (fun uu___4 -> + FStarC_Reflection_V2_Data.Tv_Arrow + uu___4)) e_binder in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___3 e_comp in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Tv_Type.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___3 -> + FStarC_Reflection_V2_Data.Tv_Type + uu___3) e_universe in + FStarC_Syntax_Embeddings_AppEmb.run args + uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Tv_Refine.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + let uu___3 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (curry + (fun uu___4 -> + FStarC_Reflection_V2_Data.Tv_Refine + uu___4)) e_binder in + let uu___4 = e_term_aq (push aq) in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___3 uu___4 in + FStarC_Syntax_Embeddings_AppEmb.run args + uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Tv_Const.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___3 -> + FStarC_Reflection_V2_Data.Tv_Const + uu___3) e_vconst in + FStarC_Syntax_Embeddings_AppEmb.run args + uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Tv_Uvar.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + let uu___3 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (curry + (fun uu___4 -> + FStarC_Reflection_V2_Data.Tv_Uvar + uu___4)) + FStarC_Syntax_Embeddings.e_int in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___3 e_ctx_uvar_and_subst in + FStarC_Syntax_Embeddings_AppEmb.run + args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Tv_Let.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + xTv_Let + FStarC_Syntax_Embeddings.e_bool in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___6 + (FStarC_Syntax_Embeddings.e_list + e_term) in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___5 e_binder in + let uu___5 = e_term_aq aq in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___4 uu___5 in + let uu___4 = e_term_aq (push aq) in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___3 uu___4 in + FStarC_Syntax_Embeddings_AppEmb.run + args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Tv_Match.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = e_term_aq aq in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (curry3 + (fun uu___6 -> + FStarC_Reflection_V2_Data.Tv_Match + uu___6)) uu___5 in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___4 + e_match_returns_annotation in + let uu___4 = + let uu___5 = e_branch_aq aq in + FStarC_Syntax_Embeddings.e_list + uu___5 in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___3 uu___4 in + FStarC_Syntax_Embeddings_AppEmb.run + args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Tv_AscT.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = e_term_aq aq in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (curry4 + (fun uu___7 -> + FStarC_Reflection_V2_Data.Tv_AscribedT + uu___7)) uu___6 in + let uu___6 = e_term_aq aq in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___5 uu___6 in + let uu___5 = + let uu___6 = e_term_aq aq in + FStarC_Syntax_Embeddings.e_option + uu___6 in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___4 uu___5 in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___3 + FStarC_Syntax_Embeddings.e_bool in + FStarC_Syntax_Embeddings_AppEmb.run + args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid + fv + FStarC_Reflection_V2_Constants.ref_Tv_AscC.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + e_term_aq aq in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (curry4 + (fun uu___7 -> + FStarC_Reflection_V2_Data.Tv_AscribedC + uu___7)) + uu___6 in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___5 e_comp in + let uu___5 = + let uu___6 = e_term_aq aq in + FStarC_Syntax_Embeddings.e_option + uu___6 in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___4 uu___5 in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___3 + FStarC_Syntax_Embeddings.e_bool in + FStarC_Syntax_Embeddings_AppEmb.run + args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid + fv + FStarC_Reflection_V2_Constants.ref_Tv_Unknown.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.pure + FStarC_Reflection_V2_Data.Tv_Unknown in + FStarC_Syntax_Embeddings_AppEmb.run + args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid + fv + FStarC_Reflection_V2_Constants.ref_Tv_Unsupp.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.pure + FStarC_Reflection_V2_Data.Tv_Unsupp in + FStarC_Syntax_Embeddings_AppEmb.run + args uu___2) + else + FStar_Pervasives_Native.None) in + mk_emb embed_term_view unembed_term_view + FStarC_Reflection_V2_Constants.fstar_refl_term_view +let (e_term_view : + FStarC_Reflection_V2_Data.term_view FStarC_Syntax_Embeddings_Base.embedding) + = e_term_view_aq noaqs +let (e_name : + Prims.string Prims.list FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Syntax_Embeddings.e_list FStarC_Syntax_Embeddings.e_string +let (e_namedv_view : + FStarC_Reflection_V2_Data.namedv_view + FStarC_Syntax_Embeddings_Base.embedding) + = + let embed_namedv_view rng namedvv = + let uu___ = + let uu___1 = + let uu___2 = + embed FStarC_Syntax_Embeddings.e_int rng + namedvv.FStarC_Reflection_V2_Data.uniq in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + embed e_sort rng namedvv.FStarC_Reflection_V2_Data.sort in + FStarC_Syntax_Syntax.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + embed + (FStarC_Syntax_Embeddings.e_sealed + FStarC_Syntax_Embeddings.e_string) rng + namedvv.FStarC_Reflection_V2_Data.ppname in + FStarC_Syntax_Syntax.as_arg uu___6 in + [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Mk_namedv_view.FStarC_Reflection_V2_Constants.t + uu___ rng in + let unembed_namedv_view t = + let uu___ = head_fv_and_args t in + FStarC_Syntax_Embeddings_AppEmb.op_let_Question uu___ + (fun uu___1 -> + match uu___1 with + | (fv, args) -> + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Mk_namedv_view.FStarC_Reflection_V2_Constants.lid + then + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___5 -> + fun uu___6 -> + fun uu___7 -> + { + FStarC_Reflection_V2_Data.uniq = uu___5; + FStarC_Reflection_V2_Data.sort = uu___6; + FStarC_Reflection_V2_Data.ppname = uu___7 + }) FStarC_Syntax_Embeddings.e_int in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___4 e_sort in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___3 e_ppname in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2 + else FStar_Pervasives_Native.None) in + mk_emb embed_namedv_view unembed_namedv_view + FStarC_Reflection_V2_Constants.fstar_refl_namedv_view +let (e_bv_view : + FStarC_Reflection_V2_Data.bv_view FStarC_Syntax_Embeddings_Base.embedding) + = + let embed_bv_view rng bvv = + let uu___ = + let uu___1 = + let uu___2 = + embed FStarC_Syntax_Embeddings.e_int rng + bvv.FStarC_Reflection_V2_Data.index in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = embed e_sort rng bvv.FStarC_Reflection_V2_Data.sort1 in + FStarC_Syntax_Syntax.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + embed + (FStarC_Syntax_Embeddings.e_sealed + FStarC_Syntax_Embeddings.e_string) rng + bvv.FStarC_Reflection_V2_Data.ppname1 in + FStarC_Syntax_Syntax.as_arg uu___6 in + [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Mk_bv_view.FStarC_Reflection_V2_Constants.t + uu___ rng in + let unembed_bv_view t = + let uu___ = head_fv_and_args t in + FStarC_Syntax_Embeddings_AppEmb.op_let_Question uu___ + (fun uu___1 -> + match uu___1 with + | (fv, args) -> + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Mk_bv_view.FStarC_Reflection_V2_Constants.lid + then + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___5 -> + fun uu___6 -> + fun uu___7 -> + { + FStarC_Reflection_V2_Data.index = uu___5; + FStarC_Reflection_V2_Data.sort1 = uu___6; + FStarC_Reflection_V2_Data.ppname1 = uu___7 + }) FStarC_Syntax_Embeddings.e_int in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___4 e_sort in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___3 e_ppname in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2 + else FStar_Pervasives_Native.None) in + mk_emb embed_bv_view unembed_bv_view + FStarC_Reflection_V2_Constants.fstar_refl_bv_view +let (e_binding : + FStarC_Reflection_V2_Data.binding FStarC_Syntax_Embeddings_Base.embedding) + = + let embed1 rng bindingv = + let uu___ = + let uu___1 = + let uu___2 = + embed FStarC_Syntax_Embeddings.e_int rng + bindingv.FStarC_Reflection_V2_Data.uniq1 in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + embed e_term rng bindingv.FStarC_Reflection_V2_Data.sort3 in + FStarC_Syntax_Syntax.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + embed + (FStarC_Syntax_Embeddings.e_sealed + FStarC_Syntax_Embeddings.e_string) rng + bindingv.FStarC_Reflection_V2_Data.ppname3 in + FStarC_Syntax_Syntax.as_arg uu___6 in + [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Mk_binding.FStarC_Reflection_V2_Constants.t + uu___ rng in + let unembed t = + let uu___ = head_fv_and_args t in + FStarC_Syntax_Embeddings_AppEmb.op_let_Question uu___ + (fun uu___1 -> + match uu___1 with + | (fv, args) -> + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Mk_binding.FStarC_Reflection_V2_Constants.lid + then + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___5 -> + fun uu___6 -> + fun uu___7 -> + { + FStarC_Reflection_V2_Data.uniq1 = uu___5; + FStarC_Reflection_V2_Data.sort3 = uu___6; + FStarC_Reflection_V2_Data.ppname3 = uu___7 + }) FStarC_Syntax_Embeddings.e_int in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___4 e_term in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___3 e_ppname in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2 + else FStar_Pervasives_Native.None) in + mk_emb embed1 unembed FStarC_Reflection_V2_Constants.fstar_refl_binding +let (e_attribute : + FStarC_Syntax_Syntax.attribute FStarC_Syntax_Embeddings_Base.embedding) = + e_term +let (e_attributes : + FStarC_Syntax_Syntax.attribute Prims.list + FStarC_Syntax_Embeddings_Base.embedding) + = FStarC_Syntax_Embeddings.e_list e_attribute +let (e_binder_view : + FStarC_Reflection_V2_Data.binder_view + FStarC_Syntax_Embeddings_Base.embedding) + = + let embed_binder_view rng bview = + let uu___ = + let uu___1 = + let uu___2 = embed e_term rng bview.FStarC_Reflection_V2_Data.sort2 in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + embed e_aqualv rng bview.FStarC_Reflection_V2_Data.qual in + FStarC_Syntax_Syntax.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + embed e_attributes rng bview.FStarC_Reflection_V2_Data.attrs in + FStarC_Syntax_Syntax.as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + embed + (FStarC_Syntax_Embeddings.e_sealed + FStarC_Syntax_Embeddings.e_string) rng + bview.FStarC_Reflection_V2_Data.ppname2 in + FStarC_Syntax_Syntax.as_arg uu___8 in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Mk_binder_view.FStarC_Reflection_V2_Constants.t + uu___ rng in + let unembed_binder_view t = + let uu___ = head_fv_and_args t in + FStarC_Syntax_Embeddings_AppEmb.op_let_Question uu___ + (fun uu___1 -> + match uu___1 with + | (fv, args) -> + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Mk_binder_view.FStarC_Reflection_V2_Constants.lid + then + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___6 -> + fun uu___7 -> + fun uu___8 -> + fun uu___9 -> + { + FStarC_Reflection_V2_Data.sort2 = uu___6; + FStarC_Reflection_V2_Data.qual = uu___7; + FStarC_Reflection_V2_Data.attrs = uu___8; + FStarC_Reflection_V2_Data.ppname2 = + uu___9 + }) e_term in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___5 e_aqualv in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___4 (FStarC_Syntax_Embeddings.e_list e_term) in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___3 e_ppname in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2 + else FStar_Pervasives_Native.None) in + mk_emb embed_binder_view unembed_binder_view + FStarC_Reflection_V2_Constants.fstar_refl_binder_view +let (e_comp_view : + FStarC_Reflection_V2_Data.comp_view FStarC_Syntax_Embeddings_Base.embedding) + = + let embed_comp_view rng cv = + match cv with + | FStarC_Reflection_V2_Data.C_Total t -> + let uu___ = + let uu___1 = + let uu___2 = embed e_term rng t in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_C_Total.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Reflection_V2_Data.C_GTotal t -> + let uu___ = + let uu___1 = + let uu___2 = embed e_term rng t in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_C_GTotal.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Reflection_V2_Data.C_Lemma (pre, post, pats) -> + let uu___ = + let uu___1 = + let uu___2 = embed e_term rng pre in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = embed e_term rng post in + FStarC_Syntax_Syntax.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = embed e_term rng pats in + FStarC_Syntax_Syntax.as_arg uu___6 in + [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_C_Lemma.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Reflection_V2_Data.C_Eff (us, eff, res, args, decrs) -> + let uu___ = + let uu___1 = + let uu___2 = + embed (FStarC_Syntax_Embeddings.e_list e_universe) rng us in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + embed FStarC_Syntax_Embeddings.e_string_list rng eff in + FStarC_Syntax_Syntax.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = embed e_term rng res in + FStarC_Syntax_Syntax.as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + embed (FStarC_Syntax_Embeddings.e_list e_argv) rng args in + FStarC_Syntax_Syntax.as_arg uu___8 in + let uu___8 = + let uu___9 = + let uu___10 = + embed (FStarC_Syntax_Embeddings.e_list e_term) rng + decrs in + FStarC_Syntax_Syntax.as_arg uu___10 in + [uu___9] in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_C_Eff.FStarC_Reflection_V2_Constants.t + uu___ rng in + let unembed_comp_view t = + let uu___ = head_fv_and_args t in + FStarC_Syntax_Embeddings_AppEmb.op_let_Question uu___ + (fun uu___1 -> + match uu___1 with + | (fv, args) -> + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_C_Total.FStarC_Reflection_V2_Constants.lid + then + let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___3 -> FStarC_Reflection_V2_Data.C_Total uu___3) + e_term in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2 + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_C_GTotal.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___3 -> + FStarC_Reflection_V2_Data.C_GTotal uu___3) e_term in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_C_Lemma.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (curry3 + (fun uu___5 -> + FStarC_Reflection_V2_Data.C_Lemma uu___5)) + e_term in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___4 e_term in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___3 e_term in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_C_Eff.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (curry5 + (fun uu___7 -> + FStarC_Reflection_V2_Data.C_Eff + uu___7)) + (FStarC_Syntax_Embeddings.e_list e_universe) in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___6 FStarC_Syntax_Embeddings.e_string_list in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___5 e_term in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___4 (FStarC_Syntax_Embeddings.e_list e_argv) in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___3 (FStarC_Syntax_Embeddings.e_list e_term) in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else FStar_Pervasives_Native.None) in + mk_emb embed_comp_view unembed_comp_view + FStarC_Reflection_V2_Constants.fstar_refl_comp_view +let (e_univ_name : + FStarC_Syntax_Syntax.univ_name FStarC_Syntax_Embeddings_Base.embedding) = + e_ident +let (e_univ_names : + FStarC_Syntax_Syntax.univ_name Prims.list + FStarC_Syntax_Embeddings_Base.embedding) + = FStarC_Syntax_Embeddings.e_list e_univ_name +let (e_subst_elt : + FStarC_Syntax_Syntax.subst_elt FStarC_Syntax_Embeddings_Base.embedding) = + let ee rng e = + match e with + | FStarC_Syntax_Syntax.DB (i, x) -> + let uu___ = + let uu___1 = + let uu___2 = embed FStarC_Syntax_Embeddings.e_fsint rng i in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = embed e_namedv rng x in + FStarC_Syntax_Syntax.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_DB.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Syntax_Syntax.DT (i, t) -> + let uu___ = + let uu___1 = + let uu___2 = embed FStarC_Syntax_Embeddings.e_fsint rng i in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = embed e_term rng t in + FStarC_Syntax_Syntax.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_DT.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Syntax_Syntax.NM (x, i) -> + let uu___ = + let uu___1 = + let uu___2 = embed e_namedv rng x in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = embed FStarC_Syntax_Embeddings.e_fsint rng i in + FStarC_Syntax_Syntax.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_NM.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Syntax_Syntax.NT (x, t) -> + let uu___ = + let uu___1 = + let uu___2 = embed e_namedv rng x in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = embed e_term rng t in + FStarC_Syntax_Syntax.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_NT.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Syntax_Syntax.UN (i, u) -> + let uu___ = + let uu___1 = + let uu___2 = embed FStarC_Syntax_Embeddings.e_fsint rng i in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = embed e_universe rng u in + FStarC_Syntax_Syntax.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_UN.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Syntax_Syntax.UD (u, i) -> + let uu___ = + let uu___1 = + let uu___2 = embed e_univ_name rng u in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = embed FStarC_Syntax_Embeddings.e_fsint rng i in + FStarC_Syntax_Syntax.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_UD.FStarC_Reflection_V2_Constants.t + uu___ rng in + let uu t = + let uu___ = head_fv_and_args t in + FStarC_Syntax_Embeddings_AppEmb.op_let_Question uu___ + (fun uu___1 -> + match uu___1 with + | (fv, args) -> + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_DB.FStarC_Reflection_V2_Constants.lid + then + let uu___2 = + let uu___3 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (curry (fun uu___4 -> FStarC_Syntax_Syntax.DB uu___4)) + FStarC_Syntax_Embeddings.e_fsint in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___3 e_namedv in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2 + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_DT.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + let uu___3 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (curry (fun uu___4 -> FStarC_Syntax_Syntax.DT uu___4)) + FStarC_Syntax_Embeddings.e_fsint in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___3 e_term in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_NM.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + let uu___3 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (curry + (fun uu___4 -> FStarC_Syntax_Syntax.NM uu___4)) + e_namedv in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___3 FStarC_Syntax_Embeddings.e_fsint in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_NT.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + let uu___3 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (curry + (fun uu___4 -> FStarC_Syntax_Syntax.NT uu___4)) + e_namedv in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___3 e_term in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_UN.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + let uu___3 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (curry + (fun uu___4 -> + FStarC_Syntax_Syntax.UN uu___4)) + FStarC_Syntax_Embeddings.e_fsint in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___3 e_universe in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_UD.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + let uu___3 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (curry + (fun uu___4 -> + FStarC_Syntax_Syntax.UD uu___4)) + e_ident in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___3 FStarC_Syntax_Embeddings.e_fsint in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else FStar_Pervasives_Native.None) in + mk_emb ee uu FStarC_Reflection_V2_Constants.fstar_refl_subst_elt +let (e_subst : + FStarC_Syntax_Syntax.subst_elt Prims.list + FStarC_Syntax_Embeddings_Base.embedding) + = FStarC_Syntax_Embeddings.e_list e_subst_elt +let (e_ctor : + (Prims.string Prims.list * FStarC_Syntax_Syntax.term) + FStarC_Syntax_Embeddings_Base.embedding) + = + FStarC_Syntax_Embeddings.e_tuple2 FStarC_Syntax_Embeddings.e_string_list + e_term +let (e_lb_view : + FStarC_Reflection_V2_Data.lb_view FStarC_Syntax_Embeddings_Base.embedding) + = + let embed_lb_view rng lbv = + let uu___ = + let uu___1 = + let uu___2 = embed e_fv rng lbv.FStarC_Reflection_V2_Data.lb_fv in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + embed (FStarC_Syntax_Embeddings.e_list e_univ_name) rng + lbv.FStarC_Reflection_V2_Data.lb_us in + FStarC_Syntax_Syntax.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + embed e_term rng lbv.FStarC_Reflection_V2_Data.lb_typ in + FStarC_Syntax_Syntax.as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + embed e_term rng lbv.FStarC_Reflection_V2_Data.lb_def in + FStarC_Syntax_Syntax.as_arg uu___8 in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Mk_lb.FStarC_Reflection_V2_Constants.t + uu___ rng in + let unembed_lb_view t = + let uu___ = head_fv_and_args t in + FStarC_Syntax_Embeddings_AppEmb.op_let_Question uu___ + (fun uu___1 -> + match uu___1 with + | (fv, args) -> + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Mk_lb.FStarC_Reflection_V2_Constants.lid + then + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___6 -> + fun uu___7 -> + fun uu___8 -> + fun uu___9 -> + { + FStarC_Reflection_V2_Data.lb_fv = uu___6; + FStarC_Reflection_V2_Data.lb_us = uu___7; + FStarC_Reflection_V2_Data.lb_typ = uu___8; + FStarC_Reflection_V2_Data.lb_def = uu___9 + }) e_fv in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___5 e_univ_names in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___4 e_term in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___3 e_term in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2 + else FStar_Pervasives_Native.None) in + mk_emb embed_lb_view unembed_lb_view + FStarC_Reflection_V2_Constants.fstar_refl_lb_view +let (e_sigelt_view : + FStarC_Reflection_V2_Data.sigelt_view + FStarC_Syntax_Embeddings_Base.embedding) + = + let embed_sigelt_view rng sev = + match sev with + | FStarC_Reflection_V2_Data.Sg_Let (r, lbs) -> + let uu___ = + let uu___1 = + let uu___2 = embed FStarC_Syntax_Embeddings.e_bool rng r in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + embed (FStarC_Syntax_Embeddings.e_list e_letbinding) rng lbs in + FStarC_Syntax_Syntax.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Sg_Let.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Reflection_V2_Data.Sg_Inductive (nm, univs, bs, t, dcs) -> + let uu___ = + let uu___1 = + let uu___2 = embed FStarC_Syntax_Embeddings.e_string_list rng nm in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + embed (FStarC_Syntax_Embeddings.e_list e_univ_name) rng univs in + FStarC_Syntax_Syntax.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = embed e_binders rng bs in + FStarC_Syntax_Syntax.as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = embed e_term rng t in + FStarC_Syntax_Syntax.as_arg uu___8 in + let uu___8 = + let uu___9 = + let uu___10 = + embed (FStarC_Syntax_Embeddings.e_list e_ctor) rng dcs in + FStarC_Syntax_Syntax.as_arg uu___10 in + [uu___9] in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Sg_Inductive.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Reflection_V2_Data.Sg_Val (nm, univs, t) -> + let uu___ = + let uu___1 = + let uu___2 = embed FStarC_Syntax_Embeddings.e_string_list rng nm in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + embed (FStarC_Syntax_Embeddings.e_list e_univ_name) rng univs in + FStarC_Syntax_Syntax.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = embed e_term rng t in + FStarC_Syntax_Syntax.as_arg uu___6 in + [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_Sg_Val.FStarC_Reflection_V2_Constants.t + uu___ rng + | FStarC_Reflection_V2_Data.Unk -> + let uu___ = + FStarC_Reflection_V2_Constants.ref_Unk.FStarC_Reflection_V2_Constants.t in + { + FStarC_Syntax_Syntax.n = (uu___.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = rng; + FStarC_Syntax_Syntax.vars = (uu___.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (uu___.FStarC_Syntax_Syntax.hash_code) + } in + let unembed_sigelt_view t = + let uu___ = head_fv_and_args t in + FStarC_Syntax_Embeddings_AppEmb.op_let_Question uu___ + (fun uu___1 -> + match uu___1 with + | (fv, args) -> + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Sg_Inductive.FStarC_Reflection_V2_Constants.lid + then + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (curry5 + (fun uu___7 -> + FStarC_Reflection_V2_Data.Sg_Inductive + uu___7)) + FStarC_Syntax_Embeddings.e_string_list in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___6 e_univ_names in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___5 e_binders in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___4 e_term in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___3 (FStarC_Syntax_Embeddings.e_list e_ctor) in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2 + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Sg_Let.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + let uu___3 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (curry + (fun uu___4 -> + FStarC_Reflection_V2_Data.Sg_Let uu___4)) + FStarC_Syntax_Embeddings.e_bool in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___3 (FStarC_Syntax_Embeddings.e_list e_letbinding) in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Sg_Val.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (curry3 + (fun uu___5 -> + FStarC_Reflection_V2_Data.Sg_Val uu___5)) + FStarC_Syntax_Embeddings.e_string_list in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___4 e_univ_names in + FStarC_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater + uu___3 e_term in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Unk.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.pure + FStarC_Reflection_V2_Data.Unk in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else FStar_Pervasives_Native.None) in + mk_emb embed_sigelt_view unembed_sigelt_view + FStarC_Reflection_V2_Constants.fstar_refl_sigelt_view +let (e_qualifier : + FStarC_Reflection_V2_Data.qualifier FStarC_Syntax_Embeddings_Base.embedding) + = + let embed1 rng q = + let r = + match q with + | FStarC_Reflection_V2_Data.Assumption -> + FStarC_Reflection_V2_Constants.ref_qual_Assumption.FStarC_Reflection_V2_Constants.t + | FStarC_Reflection_V2_Data.InternalAssumption -> + FStarC_Reflection_V2_Constants.ref_qual_InternalAssumption.FStarC_Reflection_V2_Constants.t + | FStarC_Reflection_V2_Data.New -> + FStarC_Reflection_V2_Constants.ref_qual_New.FStarC_Reflection_V2_Constants.t + | FStarC_Reflection_V2_Data.Private -> + FStarC_Reflection_V2_Constants.ref_qual_Private.FStarC_Reflection_V2_Constants.t + | FStarC_Reflection_V2_Data.Unfold_for_unification_and_vcgen -> + FStarC_Reflection_V2_Constants.ref_qual_Unfold_for_unification_and_vcgen.FStarC_Reflection_V2_Constants.t + | FStarC_Reflection_V2_Data.Visible_default -> + FStarC_Reflection_V2_Constants.ref_qual_Visible_default.FStarC_Reflection_V2_Constants.t + | FStarC_Reflection_V2_Data.Irreducible -> + FStarC_Reflection_V2_Constants.ref_qual_Irreducible.FStarC_Reflection_V2_Constants.t + | FStarC_Reflection_V2_Data.Inline_for_extraction -> + FStarC_Reflection_V2_Constants.ref_qual_Inline_for_extraction.FStarC_Reflection_V2_Constants.t + | FStarC_Reflection_V2_Data.NoExtract -> + FStarC_Reflection_V2_Constants.ref_qual_NoExtract.FStarC_Reflection_V2_Constants.t + | FStarC_Reflection_V2_Data.Noeq -> + FStarC_Reflection_V2_Constants.ref_qual_Noeq.FStarC_Reflection_V2_Constants.t + | FStarC_Reflection_V2_Data.Unopteq -> + FStarC_Reflection_V2_Constants.ref_qual_Unopteq.FStarC_Reflection_V2_Constants.t + | FStarC_Reflection_V2_Data.TotalEffect -> + FStarC_Reflection_V2_Constants.ref_qual_TotalEffect.FStarC_Reflection_V2_Constants.t + | FStarC_Reflection_V2_Data.Logic -> + FStarC_Reflection_V2_Constants.ref_qual_Logic.FStarC_Reflection_V2_Constants.t + | FStarC_Reflection_V2_Data.Reifiable -> + FStarC_Reflection_V2_Constants.ref_qual_Reifiable.FStarC_Reflection_V2_Constants.t + | FStarC_Reflection_V2_Data.ExceptionConstructor -> + FStarC_Reflection_V2_Constants.ref_qual_ExceptionConstructor.FStarC_Reflection_V2_Constants.t + | FStarC_Reflection_V2_Data.HasMaskedEffect -> + FStarC_Reflection_V2_Constants.ref_qual_HasMaskedEffect.FStarC_Reflection_V2_Constants.t + | FStarC_Reflection_V2_Data.Effect -> + FStarC_Reflection_V2_Constants.ref_qual_Effect.FStarC_Reflection_V2_Constants.t + | FStarC_Reflection_V2_Data.OnlyName -> + FStarC_Reflection_V2_Constants.ref_qual_OnlyName.FStarC_Reflection_V2_Constants.t + | FStarC_Reflection_V2_Data.Reflectable l -> + let uu___ = + let uu___1 = + let uu___2 = embed FStarC_Syntax_Embeddings.e_string_list rng l in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_qual_Reflectable.FStarC_Reflection_V2_Constants.t + uu___ FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V2_Data.Discriminator l -> + let uu___ = + let uu___1 = + let uu___2 = embed FStarC_Syntax_Embeddings.e_string_list rng l in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_qual_Discriminator.FStarC_Reflection_V2_Constants.t + uu___ FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V2_Data.Action l -> + let uu___ = + let uu___1 = + let uu___2 = embed FStarC_Syntax_Embeddings.e_string_list rng l in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_qual_Action.FStarC_Reflection_V2_Constants.t + uu___ FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V2_Data.Projector (l, i) -> + let uu___ = + let uu___1 = + let uu___2 = + embed + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Syntax_Embeddings.e_string_list e_univ_name) rng + (l, i) in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_qual_Projector.FStarC_Reflection_V2_Constants.t + uu___ FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V2_Data.RecordType (ids1, ids2) -> + let uu___ = + let uu___1 = + let uu___2 = + embed + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_list e_univ_name) + (FStarC_Syntax_Embeddings.e_list e_univ_name)) rng + (ids1, ids2) in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_qual_RecordType.FStarC_Reflection_V2_Constants.t + uu___ FStarC_Compiler_Range_Type.dummyRange + | FStarC_Reflection_V2_Data.RecordConstructor (ids1, ids2) -> + let uu___ = + let uu___1 = + let uu___2 = + embed + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_list e_univ_name) + (FStarC_Syntax_Embeddings.e_list e_univ_name)) rng + (ids1, ids2) in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.ref_qual_RecordConstructor.FStarC_Reflection_V2_Constants.t + uu___ FStarC_Compiler_Range_Type.dummyRange in + { + FStarC_Syntax_Syntax.n = (r.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = rng; + FStarC_Syntax_Syntax.vars = (r.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = (r.FStarC_Syntax_Syntax.hash_code) + } in + let unembed t = + let uu___ = head_fv_and_args t in + FStarC_Syntax_Embeddings_AppEmb.op_let_Question uu___ + (fun uu___1 -> + match uu___1 with + | (fv, args) -> + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_Assumption.FStarC_Reflection_V2_Constants.lid + then + let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.pure + FStarC_Reflection_V2_Data.Assumption in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2 + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_InternalAssumption.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.pure + FStarC_Reflection_V2_Data.InternalAssumption in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_New.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.pure + FStarC_Reflection_V2_Data.New in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_Private.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.pure + FStarC_Reflection_V2_Data.Private in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_Unfold_for_unification_and_vcgen.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.pure + FStarC_Reflection_V2_Data.Unfold_for_unification_and_vcgen in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_Visible_default.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.pure + FStarC_Reflection_V2_Data.Visible_default in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_Irreducible.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.pure + FStarC_Reflection_V2_Data.Irreducible in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_Inline_for_extraction.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.pure + FStarC_Reflection_V2_Data.Inline_for_extraction in + FStarC_Syntax_Embeddings_AppEmb.run args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_NoExtract.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.pure + FStarC_Reflection_V2_Data.NoExtract in + FStarC_Syntax_Embeddings_AppEmb.run args + uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_Noeq.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.pure + FStarC_Reflection_V2_Data.Noeq in + FStarC_Syntax_Embeddings_AppEmb.run args + uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_Unopteq.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.pure + FStarC_Reflection_V2_Data.Unopteq in + FStarC_Syntax_Embeddings_AppEmb.run args + uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_TotalEffect.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.pure + FStarC_Reflection_V2_Data.TotalEffect in + FStarC_Syntax_Embeddings_AppEmb.run + args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_Logic.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.pure + FStarC_Reflection_V2_Data.Logic in + FStarC_Syntax_Embeddings_AppEmb.run + args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_Reifiable.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.pure + FStarC_Reflection_V2_Data.Reifiable in + FStarC_Syntax_Embeddings_AppEmb.run + args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_ExceptionConstructor.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.pure + FStarC_Reflection_V2_Data.ExceptionConstructor in + FStarC_Syntax_Embeddings_AppEmb.run + args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid + fv + FStarC_Reflection_V2_Constants.ref_qual_HasMaskedEffect.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.pure + FStarC_Reflection_V2_Data.HasMaskedEffect in + FStarC_Syntax_Embeddings_AppEmb.run + args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid + fv + FStarC_Reflection_V2_Constants.ref_qual_Effect.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.pure + FStarC_Reflection_V2_Data.Effect in + FStarC_Syntax_Embeddings_AppEmb.run + args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid + fv + FStarC_Reflection_V2_Constants.ref_qual_OnlyName.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.pure + FStarC_Reflection_V2_Data.OnlyName in + FStarC_Syntax_Embeddings_AppEmb.run + args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid + fv + FStarC_Reflection_V2_Constants.ref_qual_Reflectable.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___3 -> + FStarC_Reflection_V2_Data.Reflectable + uu___3) e_name in + FStarC_Syntax_Embeddings_AppEmb.run + args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid + fv + FStarC_Reflection_V2_Constants.ref_qual_Discriminator.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___3 -> + FStarC_Reflection_V2_Data.Discriminator + uu___3) e_name in + FStarC_Syntax_Embeddings_AppEmb.run + args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid + fv + FStarC_Reflection_V2_Constants.ref_qual_Action.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___3 -> + FStarC_Reflection_V2_Data.Action + uu___3) + e_name in + FStarC_Syntax_Embeddings_AppEmb.run + args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid + fv + FStarC_Reflection_V2_Constants.ref_qual_Projector.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___3 -> + FStarC_Reflection_V2_Data.Projector + uu___3) + (FStarC_Syntax_Embeddings.e_tuple2 + e_name + e_ident) in + FStarC_Syntax_Embeddings_AppEmb.run + args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid + fv + FStarC_Reflection_V2_Constants.ref_qual_RecordType.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___3 + -> + FStarC_Reflection_V2_Data.RecordType + uu___3) + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_list + e_ident) + (FStarC_Syntax_Embeddings.e_list + e_ident)) in + FStarC_Syntax_Embeddings_AppEmb.run + args uu___2) + else + if + FStarC_Syntax_Syntax.fv_eq_lid + fv + FStarC_Reflection_V2_Constants.ref_qual_RecordConstructor.FStarC_Reflection_V2_Constants.lid + then + (let uu___2 = + FStarC_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater + (fun uu___3 + -> + FStarC_Reflection_V2_Data.RecordConstructor + uu___3) + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_list + e_ident) + (FStarC_Syntax_Embeddings.e_list + e_ident)) in + FStarC_Syntax_Embeddings_AppEmb.run + args uu___2) + else + FStar_Pervasives_Native.None) in + mk_emb embed1 unembed FStarC_Reflection_V2_Constants.fstar_refl_qualifier +let (e_qualifiers : + FStarC_Reflection_V2_Data.qualifier Prims.list + FStarC_Syntax_Embeddings_Base.embedding) + = FStarC_Syntax_Embeddings.e_list e_qualifier +let (unfold_lazy_bv : + FStarC_Syntax_Syntax.lazyinfo -> FStarC_Syntax_Syntax.term) = + fun i -> + let bv = FStarC_Dyn.undyn i.FStarC_Syntax_Syntax.blob in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Reflection_V2_Builtins.inspect_bv bv in + embed e_bv_view i.FStarC_Syntax_Syntax.rng uu___3 in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.fstar_refl_pack_bv.FStarC_Reflection_V2_Constants.t + uu___ i.FStarC_Syntax_Syntax.rng +let (unfold_lazy_namedv : + FStarC_Syntax_Syntax.lazyinfo -> FStarC_Syntax_Syntax.term) = + fun i -> + let namedv1 = FStarC_Dyn.undyn i.FStarC_Syntax_Syntax.blob in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Reflection_V2_Builtins.inspect_namedv namedv1 in + embed e_namedv_view i.FStarC_Syntax_Syntax.rng uu___3 in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.fstar_refl_pack_namedv.FStarC_Reflection_V2_Constants.t + uu___ i.FStarC_Syntax_Syntax.rng +let (unfold_lazy_binder : + FStarC_Syntax_Syntax.lazyinfo -> FStarC_Syntax_Syntax.term) = + fun i -> + let binder = FStarC_Dyn.undyn i.FStarC_Syntax_Syntax.blob in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Reflection_V2_Builtins.inspect_binder binder in + embed e_binder_view i.FStarC_Syntax_Syntax.rng uu___3 in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.fstar_refl_pack_binder.FStarC_Reflection_V2_Constants.t + uu___ i.FStarC_Syntax_Syntax.rng +let (unfold_lazy_letbinding : + FStarC_Syntax_Syntax.lazyinfo -> FStarC_Syntax_Syntax.term) = + fun i -> + let lb = FStarC_Dyn.undyn i.FStarC_Syntax_Syntax.blob in + let lbv = FStarC_Reflection_V2_Builtins.inspect_lb lb in + let uu___ = + let uu___1 = + let uu___2 = + embed e_fv i.FStarC_Syntax_Syntax.rng + lbv.FStarC_Reflection_V2_Data.lb_fv in + FStarC_Syntax_Syntax.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + embed (FStarC_Syntax_Embeddings.e_list e_univ_name) + i.FStarC_Syntax_Syntax.rng lbv.FStarC_Reflection_V2_Data.lb_us in + FStarC_Syntax_Syntax.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + embed e_term i.FStarC_Syntax_Syntax.rng + lbv.FStarC_Reflection_V2_Data.lb_typ in + FStarC_Syntax_Syntax.as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + embed e_term i.FStarC_Syntax_Syntax.rng + lbv.FStarC_Reflection_V2_Data.lb_def in + FStarC_Syntax_Syntax.as_arg uu___8 in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.fstar_refl_pack_lb.FStarC_Reflection_V2_Constants.t + uu___ i.FStarC_Syntax_Syntax.rng +let (unfold_lazy_fvar : + FStarC_Syntax_Syntax.lazyinfo -> FStarC_Syntax_Syntax.term) = + fun i -> + let fv = FStarC_Dyn.undyn i.FStarC_Syntax_Syntax.blob in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Reflection_V2_Builtins.inspect_fv fv in + embed FStarC_Syntax_Embeddings.e_string_list + i.FStarC_Syntax_Syntax.rng uu___3 in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.fstar_refl_pack_fv.FStarC_Reflection_V2_Constants.t + uu___ i.FStarC_Syntax_Syntax.rng +let (unfold_lazy_comp : + FStarC_Syntax_Syntax.lazyinfo -> FStarC_Syntax_Syntax.term) = + fun i -> + let comp = FStarC_Dyn.undyn i.FStarC_Syntax_Syntax.blob in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Reflection_V2_Builtins.inspect_comp comp in + embed e_comp_view i.FStarC_Syntax_Syntax.rng uu___3 in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.fstar_refl_pack_comp.FStarC_Reflection_V2_Constants.t + uu___ i.FStarC_Syntax_Syntax.rng +let (unfold_lazy_env : + FStarC_Syntax_Syntax.lazyinfo -> FStarC_Syntax_Syntax.term) = + fun i -> FStarC_Syntax_Util.exp_unit +let (unfold_lazy_optionstate : + FStarC_Syntax_Syntax.lazyinfo -> FStarC_Syntax_Syntax.term) = + fun i -> FStarC_Syntax_Util.exp_unit +let (unfold_lazy_sigelt : + FStarC_Syntax_Syntax.lazyinfo -> FStarC_Syntax_Syntax.term) = + fun i -> + let sigelt = FStarC_Dyn.undyn i.FStarC_Syntax_Syntax.blob in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Reflection_V2_Builtins.inspect_sigelt sigelt in + embed e_sigelt_view i.FStarC_Syntax_Syntax.rng uu___3 in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.fstar_refl_pack_sigelt.FStarC_Reflection_V2_Constants.t + uu___ i.FStarC_Syntax_Syntax.rng +let (unfold_lazy_universe : + FStarC_Syntax_Syntax.lazyinfo -> FStarC_Syntax_Syntax.term) = + fun i -> + let u = FStarC_Dyn.undyn i.FStarC_Syntax_Syntax.blob in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Reflection_V2_Builtins.inspect_universe u in + embed e_universe_view i.FStarC_Syntax_Syntax.rng uu___3 in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Reflection_V2_Constants.fstar_refl_pack_universe.FStarC_Reflection_V2_Constants.t + uu___ i.FStarC_Syntax_Syntax.rng +let (unfold_lazy_doc : + FStarC_Syntax_Syntax.lazyinfo -> FStarC_Syntax_Syntax.term) = + fun i -> + let d = FStarC_Dyn.undyn i.FStarC_Syntax_Syntax.blob in + let lid = FStarC_Ident.lid_of_str "FStar.Stubs.Pprint.arbitrary_string" in + let s = FStarC_Pprint.render d in + let uu___ = FStarC_Syntax_Syntax.fvar lid FStar_Pervasives_Native.None in + let uu___1 = + let uu___2 = + let uu___3 = + embed FStarC_Syntax_Embeddings.e_string i.FStarC_Syntax_Syntax.rng + s in + FStarC_Syntax_Syntax.as_arg uu___3 in + [uu___2] in + FStarC_Syntax_Syntax.mk_Tm_app uu___ uu___1 i.FStarC_Syntax_Syntax.rng \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Reflection_V2_Interpreter.ml b/ocaml/fstar-lib/generated/FStarC_Reflection_V2_Interpreter.ml new file mode 100644 index 00000000000..d1e958d967a --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Reflection_V2_Interpreter.ml @@ -0,0 +1,627 @@ +open Prims +let solve : 'a . 'a -> 'a = fun ev -> ev +let mk1 : + 'res 't1 . + Prims.string -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 'res FStarC_Syntax_Embeddings_Base.embedding -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 'res FStarC_TypeChecker_NBETerm.embedding -> + ('t1 -> 'res) -> FStarC_TypeChecker_Primops_Base.primitive_step + = + fun nm -> + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun f -> + let lid = + FStarC_Reflection_V2_Constants.fstar_refl_builtins_lid nm in + FStarC_TypeChecker_Primops_Base.mk1' Prims.int_zero lid uu___ + uu___2 uu___1 uu___3 + (fun x -> + let uu___4 = f x in FStar_Pervasives_Native.Some uu___4) + (fun x -> + let uu___4 = f x in FStar_Pervasives_Native.Some uu___4) +let mk2 : + 'res 't1 't2 . + Prims.string -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 'res FStarC_Syntax_Embeddings_Base.embedding -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 'res FStarC_TypeChecker_NBETerm.embedding -> + ('t1 -> 't2 -> 'res) -> + FStarC_TypeChecker_Primops_Base.primitive_step + = + fun nm -> + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun uu___4 -> + fun uu___5 -> + fun f -> + let lid = + FStarC_Reflection_V2_Constants.fstar_refl_builtins_lid nm in + FStarC_TypeChecker_Primops_Base.mk2' Prims.int_zero lid + uu___ uu___3 uu___1 uu___4 uu___2 uu___5 + (fun x -> + fun y -> + let uu___6 = f x y in + FStar_Pervasives_Native.Some uu___6) + (fun x -> + fun y -> + let uu___6 = f x y in + FStar_Pervasives_Native.Some uu___6) +let mk3 : + 'res 't1 't2 't3 . + Prims.string -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 'res FStarC_Syntax_Embeddings_Base.embedding -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 'res FStarC_TypeChecker_NBETerm.embedding -> + ('t1 -> 't2 -> 't3 -> 'res) -> + FStarC_TypeChecker_Primops_Base.primitive_step + = + fun nm -> + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun uu___4 -> + fun uu___5 -> + fun uu___6 -> + fun uu___7 -> + fun f -> + let lid = + FStarC_Reflection_V2_Constants.fstar_refl_builtins_lid + nm in + FStarC_TypeChecker_Primops_Base.mk3' Prims.int_zero lid + uu___ uu___4 uu___1 uu___5 uu___2 uu___6 uu___3 + uu___7 + (fun x -> + fun y -> + fun z -> + let uu___8 = f x y z in + FStar_Pervasives_Native.Some uu___8) + (fun x -> + fun y -> + fun z -> + let uu___8 = f x y z in + FStar_Pervasives_Native.Some uu___8) +let (reflection_primops : + FStarC_TypeChecker_Primops_Base.primitive_step Prims.list) = + let uu___ = + mk1 "inspect_ln" FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_term_view + FStarC_Reflection_V2_NBEEmbeddings.e_term + FStarC_Reflection_V2_NBEEmbeddings.e_term_view + FStarC_Reflection_V2_Builtins.inspect_ln in + let uu___1 = + let uu___2 = + mk1 "pack_ln" FStarC_Reflection_V2_Embeddings.e_term_view + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_NBEEmbeddings.e_term_view + FStarC_Reflection_V2_NBEEmbeddings.e_term + FStarC_Reflection_V2_Builtins.pack_ln in + let uu___3 = + let uu___4 = + mk1 "inspect_fv" FStarC_Reflection_V2_Embeddings.e_fv + FStarC_Syntax_Embeddings.e_string_list + FStarC_Reflection_V2_NBEEmbeddings.e_fv + FStarC_TypeChecker_NBETerm.e_string_list + FStarC_Reflection_V2_Builtins.inspect_fv in + let uu___5 = + let uu___6 = + mk1 "pack_fv" FStarC_Syntax_Embeddings.e_string_list + FStarC_Reflection_V2_Embeddings.e_fv + FStarC_TypeChecker_NBETerm.e_string_list + FStarC_Reflection_V2_NBEEmbeddings.e_fv + FStarC_Reflection_V2_Builtins.pack_fv in + let uu___7 = + let uu___8 = + mk1 "inspect_comp" FStarC_Reflection_V2_Embeddings.e_comp + FStarC_Reflection_V2_Embeddings.e_comp_view + FStarC_Reflection_V2_NBEEmbeddings.e_comp + FStarC_Reflection_V2_NBEEmbeddings.e_comp_view + FStarC_Reflection_V2_Builtins.inspect_comp in + let uu___9 = + let uu___10 = + mk1 "pack_comp" FStarC_Reflection_V2_Embeddings.e_comp_view + FStarC_Reflection_V2_Embeddings.e_comp + FStarC_Reflection_V2_NBEEmbeddings.e_comp_view + FStarC_Reflection_V2_NBEEmbeddings.e_comp + FStarC_Reflection_V2_Builtins.pack_comp in + let uu___11 = + let uu___12 = + mk1 "inspect_universe" + FStarC_Reflection_V2_Embeddings.e_universe + FStarC_Reflection_V2_Embeddings.e_universe_view + FStarC_Reflection_V2_NBEEmbeddings.e_universe + FStarC_Reflection_V2_NBEEmbeddings.e_universe_view + FStarC_Reflection_V2_Builtins.inspect_universe in + let uu___13 = + let uu___14 = + mk1 "pack_universe" + FStarC_Reflection_V2_Embeddings.e_universe_view + FStarC_Reflection_V2_Embeddings.e_universe + FStarC_Reflection_V2_NBEEmbeddings.e_universe_view + FStarC_Reflection_V2_NBEEmbeddings.e_universe + FStarC_Reflection_V2_Builtins.pack_universe in + let uu___15 = + let uu___16 = + mk1 "inspect_sigelt" + FStarC_Reflection_V2_Embeddings.e_sigelt + FStarC_Reflection_V2_Embeddings.e_sigelt_view + FStarC_Reflection_V2_NBEEmbeddings.e_sigelt + FStarC_Reflection_V2_NBEEmbeddings.e_sigelt_view + FStarC_Reflection_V2_Builtins.inspect_sigelt in + let uu___17 = + let uu___18 = + mk1 "pack_sigelt" + FStarC_Reflection_V2_Embeddings.e_sigelt_view + FStarC_Reflection_V2_Embeddings.e_sigelt + FStarC_Reflection_V2_NBEEmbeddings.e_sigelt_view + FStarC_Reflection_V2_NBEEmbeddings.e_sigelt + FStarC_Reflection_V2_Builtins.pack_sigelt in + let uu___19 = + let uu___20 = + mk1 "inspect_lb" + FStarC_Reflection_V2_Embeddings.e_letbinding + FStarC_Reflection_V2_Embeddings.e_lb_view + FStarC_Reflection_V2_NBEEmbeddings.e_letbinding + FStarC_Reflection_V2_NBEEmbeddings.e_lb_view + FStarC_Reflection_V2_Builtins.inspect_lb in + let uu___21 = + let uu___22 = + mk1 "pack_lb" + FStarC_Reflection_V2_Embeddings.e_lb_view + FStarC_Reflection_V2_Embeddings.e_letbinding + FStarC_Reflection_V2_NBEEmbeddings.e_lb_view + FStarC_Reflection_V2_NBEEmbeddings.e_letbinding + FStarC_Reflection_V2_Builtins.pack_lb in + let uu___23 = + let uu___24 = + mk1 "inspect_namedv" + FStarC_Reflection_V2_Embeddings.e_namedv + FStarC_Reflection_V2_Embeddings.e_namedv_view + FStarC_Reflection_V2_NBEEmbeddings.e_namedv + FStarC_Reflection_V2_NBEEmbeddings.e_namedv_view + FStarC_Reflection_V2_Builtins.inspect_namedv in + let uu___25 = + let uu___26 = + mk1 "pack_namedv" + FStarC_Reflection_V2_Embeddings.e_namedv_view + FStarC_Reflection_V2_Embeddings.e_namedv + FStarC_Reflection_V2_NBEEmbeddings.e_namedv_view + FStarC_Reflection_V2_NBEEmbeddings.e_namedv + FStarC_Reflection_V2_Builtins.pack_namedv in + let uu___27 = + let uu___28 = + mk1 "inspect_bv" + FStarC_Reflection_V2_Embeddings.e_bv + FStarC_Reflection_V2_Embeddings.e_bv_view + FStarC_Reflection_V2_NBEEmbeddings.e_bv + FStarC_Reflection_V2_NBEEmbeddings.e_bv_view + FStarC_Reflection_V2_Builtins.inspect_bv in + let uu___29 = + let uu___30 = + mk1 "pack_bv" + FStarC_Reflection_V2_Embeddings.e_bv_view + FStarC_Reflection_V2_Embeddings.e_bv + FStarC_Reflection_V2_NBEEmbeddings.e_bv_view + FStarC_Reflection_V2_NBEEmbeddings.e_bv + FStarC_Reflection_V2_Builtins.pack_bv in + let uu___31 = + let uu___32 = + mk1 "inspect_binder" + FStarC_Reflection_V2_Embeddings.e_binder + FStarC_Reflection_V2_Embeddings.e_binder_view + FStarC_Reflection_V2_NBEEmbeddings.e_binder + FStarC_Reflection_V2_NBEEmbeddings.e_binder_view + FStarC_Reflection_V2_Builtins.inspect_binder in + let uu___33 = + let uu___34 = + mk1 "pack_binder" + FStarC_Reflection_V2_Embeddings.e_binder_view + FStarC_Reflection_V2_Embeddings.e_binder + FStarC_Reflection_V2_NBEEmbeddings.e_binder_view + FStarC_Reflection_V2_NBEEmbeddings.e_binder + FStarC_Reflection_V2_Builtins.pack_binder in + let uu___35 = + let uu___36 = + mk1 "sigelt_opts" + FStarC_Reflection_V2_Embeddings.e_sigelt + (FStarC_Syntax_Embeddings.e_option + FStarC_Syntax_Embeddings.e_vconfig) + FStarC_Reflection_V2_NBEEmbeddings.e_sigelt + (FStarC_TypeChecker_NBETerm.e_option + FStarC_TypeChecker_NBETerm.e_vconfig) + FStarC_Reflection_V2_Builtins.sigelt_opts in + let uu___37 = + let uu___38 = + mk1 "embed_vconfig" + FStarC_Syntax_Embeddings.e_vconfig + FStarC_Reflection_V2_Embeddings.e_term + FStarC_TypeChecker_NBETerm.e_vconfig + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Reflection_V2_Builtins.embed_vconfig in + let uu___39 = + let uu___40 = + mk1 "sigelt_attrs" + FStarC_Reflection_V2_Embeddings.e_sigelt + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_term) + FStarC_Reflection_V2_NBEEmbeddings.e_sigelt + FStarC_Reflection_V2_NBEEmbeddings.e_attributes + FStarC_Reflection_V2_Builtins.sigelt_attrs in + let uu___41 = + let uu___42 = + mk2 "set_sigelt_attrs" + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_term) + FStarC_Reflection_V2_Embeddings.e_sigelt + FStarC_Reflection_V2_Embeddings.e_sigelt + FStarC_Reflection_V2_NBEEmbeddings.e_attributes + FStarC_Reflection_V2_NBEEmbeddings.e_sigelt + FStarC_Reflection_V2_NBEEmbeddings.e_sigelt + FStarC_Reflection_V2_Builtins.set_sigelt_attrs in + let uu___43 = + let uu___44 = + mk1 "sigelt_quals" + FStarC_Reflection_V2_Embeddings.e_sigelt + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_qualifier) + FStarC_Reflection_V2_NBEEmbeddings.e_sigelt + FStarC_Reflection_V2_NBEEmbeddings.e_qualifiers + FStarC_Reflection_V2_Builtins.sigelt_quals in + let uu___45 = + let uu___46 = + mk2 "set_sigelt_quals" + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_qualifier) + FStarC_Reflection_V2_Embeddings.e_sigelt + FStarC_Reflection_V2_Embeddings.e_sigelt + FStarC_Reflection_V2_NBEEmbeddings.e_qualifiers + FStarC_Reflection_V2_NBEEmbeddings.e_sigelt + FStarC_Reflection_V2_NBEEmbeddings.e_sigelt + FStarC_Reflection_V2_Builtins.set_sigelt_quals in + let uu___47 = + let uu___48 = + mk2 "subst_term" + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_subst_elt) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_NBEEmbeddings.e_subst + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Reflection_V2_Builtins.subst_term in + let uu___49 = + let uu___50 = + mk2 "subst_comp" + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_subst_elt) + FStarC_Reflection_V2_Embeddings.e_comp + FStarC_Reflection_V2_Embeddings.e_comp + FStarC_Reflection_V2_NBEEmbeddings.e_subst + FStarC_Reflection_V2_NBEEmbeddings.e_comp + FStarC_Reflection_V2_NBEEmbeddings.e_comp + FStarC_Reflection_V2_Builtins.subst_comp in + let uu___51 = + let uu___52 = + mk2 "compare_bv" + FStarC_Reflection_V2_Embeddings.e_bv + FStarC_Reflection_V2_Embeddings.e_bv + FStarC_Syntax_Embeddings.e_order + FStarC_Reflection_V2_NBEEmbeddings.e_bv + FStarC_Reflection_V2_NBEEmbeddings.e_bv + FStarC_TypeChecker_NBETerm.e_order + FStarC_Reflection_V2_Builtins.compare_bv in + let uu___53 = + let uu___54 = + mk2 + "compare_namedv" + FStarC_Reflection_V2_Embeddings.e_namedv + FStarC_Reflection_V2_Embeddings.e_namedv + FStarC_Syntax_Embeddings.e_order + FStarC_Reflection_V2_NBEEmbeddings.e_namedv + FStarC_Reflection_V2_NBEEmbeddings.e_namedv + FStarC_TypeChecker_NBETerm.e_order + FStarC_Reflection_V2_Builtins.compare_namedv in + let uu___55 = + let uu___56 = + mk2 + "lookup_attr_ses" + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_env + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_sigelt) + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Reflection_V2_NBEEmbeddings.e_env + (FStarC_TypeChecker_NBETerm.e_list + FStarC_Reflection_V2_NBEEmbeddings.e_sigelt) + FStarC_Reflection_V2_Builtins.lookup_attr_ses in + let uu___57 = + let uu___58 = + mk2 + "lookup_attr" + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_env + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_fv) + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Reflection_V2_NBEEmbeddings.e_env + (FStarC_TypeChecker_NBETerm.e_list + FStarC_Reflection_V2_NBEEmbeddings.e_fv) + FStarC_Reflection_V2_Builtins.lookup_attr in + let uu___59 = + let uu___60 = + mk1 + "all_defs_in_env" + FStarC_Reflection_V2_Embeddings.e_env + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_fv) + FStarC_Reflection_V2_NBEEmbeddings.e_env + (FStarC_TypeChecker_NBETerm.e_list + FStarC_Reflection_V2_NBEEmbeddings.e_fv) + FStarC_Reflection_V2_Builtins.all_defs_in_env in + let uu___61 = + let uu___62 = + mk2 + "defs_in_module" + FStarC_Reflection_V2_Embeddings.e_env + FStarC_Syntax_Embeddings.e_string_list + ( + FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_fv) + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_TypeChecker_NBETerm.e_string_list + ( + FStarC_TypeChecker_NBETerm.e_list + FStarC_Reflection_V2_NBEEmbeddings.e_fv) + FStarC_Reflection_V2_Builtins.defs_in_module in + let uu___63 = + let uu___64 + = + mk2 + "term_eq" + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Syntax_Embeddings.e_bool + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_TypeChecker_NBETerm.e_bool + FStarC_Reflection_V2_Builtins.term_eq in + let uu___65 + = + let uu___66 + = + mk1 + "moduleof" + FStarC_Reflection_V2_Embeddings.e_env + FStarC_Syntax_Embeddings.e_string_list + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_TypeChecker_NBETerm.e_string_list + FStarC_Reflection_V2_Builtins.moduleof in + let uu___67 + = + let uu___68 + = + mk1 + "vars_of_env" + FStarC_Reflection_V2_Embeddings.e_env + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_binding) + FStarC_Reflection_V2_NBEEmbeddings.e_env + (FStarC_TypeChecker_NBETerm.e_list + FStarC_Reflection_V2_NBEEmbeddings.e_binding) + FStarC_Reflection_V2_Builtins.vars_of_env in + let uu___69 + = + let uu___70 + = + mk2 + "lookup_typ" + FStarC_Reflection_V2_Embeddings.e_env + FStarC_Syntax_Embeddings.e_string_list + (FStarC_Syntax_Embeddings.e_option + FStarC_Reflection_V2_Embeddings.e_sigelt) + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_TypeChecker_NBETerm.e_string_list + (FStarC_TypeChecker_NBETerm.e_option + FStarC_Reflection_V2_NBEEmbeddings.e_sigelt) + FStarC_Reflection_V2_Builtins.lookup_typ in + let uu___71 + = + let uu___72 + = + mk1 + "env_open_modules" + FStarC_Reflection_V2_Embeddings.e_env + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_string_list) + FStarC_Reflection_V2_NBEEmbeddings.e_env + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_string_list) + FStarC_Reflection_V2_Builtins.env_open_modules in + let uu___73 + = + let uu___74 + = + mk1 + "implode_qn" + FStarC_Syntax_Embeddings.e_string_list + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string_list + FStarC_TypeChecker_NBETerm.e_string + FStarC_Reflection_V2_Builtins.implode_qn in + let uu___75 + = + let uu___76 + = + mk1 + "explode_qn" + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_string_list + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_string_list + FStarC_Reflection_V2_Builtins.explode_qn in + let uu___77 + = + let uu___78 + = + mk2 + "compare_string" + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_int + FStarC_Reflection_V2_Builtins.compare_string in + let uu___79 + = + let uu___80 + = + mk2 + "push_namedv" + FStarC_Reflection_V2_Embeddings.e_env + FStarC_Reflection_V2_Embeddings.e_namedv + FStarC_Reflection_V2_Embeddings.e_env + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_Reflection_V2_NBEEmbeddings.e_namedv + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_Reflection_V2_Builtins.push_namedv in + let uu___81 + = + let uu___82 + = + mk1 + "range_of_term" + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Syntax_Embeddings.e_range + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_TypeChecker_NBETerm.e_range + FStarC_Reflection_V2_Builtins.range_of_term in + let uu___83 + = + let uu___84 + = + mk1 + "range_of_sigelt" + FStarC_Reflection_V2_Embeddings.e_sigelt + FStarC_Syntax_Embeddings.e_range + FStarC_Reflection_V2_NBEEmbeddings.e_sigelt + FStarC_TypeChecker_NBETerm.e_range + FStarC_Reflection_V2_Builtins.range_of_sigelt in + let uu___85 + = + let uu___86 + = + mk1 + "inspect_ident" + FStarC_Reflection_V2_Embeddings.e_univ_name + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_range) + FStarC_Reflection_V2_NBEEmbeddings.e_univ_name + (FStarC_TypeChecker_NBETerm.e_tuple2 + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_range) + FStarC_Reflection_V2_Builtins.inspect_ident in + let uu___87 + = + let uu___88 + = + mk1 + "pack_ident" + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_range) + FStarC_Reflection_V2_Embeddings.e_univ_name + (FStarC_TypeChecker_NBETerm.e_tuple2 + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_range) + FStarC_Reflection_V2_NBEEmbeddings.e_univ_name + FStarC_Reflection_V2_Builtins.pack_ident in + [uu___88] in + uu___86 + :: + uu___87 in + uu___84 + :: + uu___85 in + uu___82 + :: + uu___83 in + uu___80 + :: + uu___81 in + uu___78 + :: + uu___79 in + uu___76 + :: + uu___77 in + uu___74 + :: + uu___75 in + uu___72 + :: + uu___73 in + uu___70 + :: + uu___71 in + uu___68 + :: + uu___69 in + uu___66 + :: + uu___67 in + uu___64 :: + uu___65 in + uu___62 :: + uu___63 in + uu___60 :: + uu___61 in + uu___58 :: + uu___59 in + uu___56 :: uu___57 in + uu___54 :: uu___55 in + uu___52 :: uu___53 in + uu___50 :: uu___51 in + uu___48 :: uu___49 in + uu___46 :: uu___47 in + uu___44 :: uu___45 in + uu___42 :: uu___43 in + uu___40 :: uu___41 in + uu___38 :: uu___39 in + uu___36 :: uu___37 in + uu___34 :: uu___35 in + uu___32 :: uu___33 in + uu___30 :: uu___31 in + uu___28 :: uu___29 in + uu___26 :: uu___27 in + uu___24 :: uu___25 in + uu___22 :: uu___23 in + uu___20 :: uu___21 in + uu___18 :: uu___19 in + uu___16 :: uu___17 in + uu___14 :: uu___15 in + uu___12 :: uu___13 in + uu___10 :: uu___11 in + uu___8 :: uu___9 in + uu___6 :: uu___7 in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + uu___ :: uu___1 +let (uu___0 : unit) = + FStar_List.iter FStarC_TypeChecker_Cfg.register_extra_step + reflection_primops \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Reflection_V2_NBEEmbeddings.ml b/ocaml/fstar-lib/generated/FStarC_Reflection_V2_NBEEmbeddings.ml new file mode 100644 index 00000000000..124043e7c4c --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Reflection_V2_NBEEmbeddings.ml @@ -0,0 +1,2676 @@ +open Prims +let (noaqs : FStarC_Syntax_Syntax.antiquotations) = (Prims.int_zero, []) +let (mkFV : + FStarC_Syntax_Syntax.fv -> + FStarC_Syntax_Syntax.universe Prims.list -> + (FStarC_TypeChecker_NBETerm.t * FStarC_Syntax_Syntax.aqual) Prims.list + -> FStarC_TypeChecker_NBETerm.t) + = + fun fv -> + fun us -> + fun ts -> + FStarC_TypeChecker_NBETerm.mkFV fv (FStarC_Compiler_List.rev us) + (FStarC_Compiler_List.rev ts) +let (mkConstruct : + FStarC_Syntax_Syntax.fv -> + FStarC_Syntax_Syntax.universe Prims.list -> + (FStarC_TypeChecker_NBETerm.t * FStarC_Syntax_Syntax.aqual) Prims.list + -> FStarC_TypeChecker_NBETerm.t) + = + fun fv -> + fun us -> + fun ts -> + FStarC_TypeChecker_NBETerm.mkConstruct fv + (FStarC_Compiler_List.rev us) (FStarC_Compiler_List.rev ts) +let (fv_as_emb_typ : FStarC_Syntax_Syntax.fv -> FStarC_Syntax_Syntax.emb_typ) + = + fun fv -> + let uu___ = + let uu___1 = + FStarC_Ident.string_of_lid + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + (uu___1, []) in + FStarC_Syntax_Syntax.ET_app uu___ +let mk_emb' : + 'uuuuu . + (FStarC_TypeChecker_NBETerm.nbe_cbs -> + 'uuuuu -> FStarC_TypeChecker_NBETerm.t) + -> + (FStarC_TypeChecker_NBETerm.nbe_cbs -> + FStarC_TypeChecker_NBETerm.t -> + 'uuuuu FStar_Pervasives_Native.option) + -> + FStarC_Syntax_Syntax.fv -> + 'uuuuu FStarC_TypeChecker_NBETerm.embedding + = + fun x -> + fun y -> + fun fv -> + FStarC_TypeChecker_NBETerm.mk_emb x y (fun uu___ -> mkFV fv [] []) + (fun uu___ -> fv_as_emb_typ fv) +let mk_lazy : + 'uuuuu . + FStarC_TypeChecker_NBETerm.nbe_cbs -> + 'uuuuu -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.lazy_kind -> FStarC_TypeChecker_NBETerm.t + = + fun cb -> + fun obj -> + fun ty -> + fun kind -> + let li = + let uu___ = FStarC_Dyn.mkdyn obj in + { + FStarC_Syntax_Syntax.blob = uu___; + FStarC_Syntax_Syntax.lkind = kind; + FStarC_Syntax_Syntax.ltyp = ty; + FStarC_Syntax_Syntax.rng = + FStarC_Compiler_Range_Type.dummyRange + } in + let thunk = + FStarC_Thunk.mk + (fun uu___ -> + let uu___1 = FStarC_Syntax_Util.unfold_lazy li in + FStarC_TypeChecker_NBETerm.translate_cb cb uu___1) in + FStarC_TypeChecker_NBETerm.mk_t + (FStarC_TypeChecker_NBETerm.Lazy + ((FStar_Pervasives.Inl li), thunk)) +let (e_bv : FStarC_Syntax_Syntax.bv FStarC_TypeChecker_NBETerm.embedding) = + let embed_bv cb bv = + mk_lazy cb bv FStarC_Reflection_V2_Constants.fstar_refl_bv + FStarC_Syntax_Syntax.Lazy_bv in + let unembed_bv cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Lazy + (FStar_Pervasives.Inl + { FStarC_Syntax_Syntax.blob = b; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_bv; + FStarC_Syntax_Syntax.ltyp = uu___; + FStarC_Syntax_Syntax.rng = uu___1;_}, + uu___2) + -> + let uu___3 = FStarC_Dyn.undyn b in + FStar_Pervasives_Native.Some uu___3 + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded bv: %s" uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_bv unembed_bv FStarC_Reflection_V2_Constants.fstar_refl_bv_fv +let (e_namedv : + FStarC_Reflection_V2_Data.namedv FStarC_TypeChecker_NBETerm.embedding) = + let embed_namedv cb namedv = + mk_lazy cb namedv FStarC_Reflection_V2_Constants.fstar_refl_namedv + FStarC_Syntax_Syntax.Lazy_namedv in + let unembed_namedv cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Lazy + (FStar_Pervasives.Inl + { FStarC_Syntax_Syntax.blob = b; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_namedv; + FStarC_Syntax_Syntax.ltyp = uu___; + FStarC_Syntax_Syntax.rng = uu___1;_}, + uu___2) + -> + let uu___3 = FStarC_Dyn.undyn b in + FStar_Pervasives_Native.Some uu___3 + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded namedv: %s" uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_namedv unembed_namedv + FStarC_Reflection_V2_Constants.fstar_refl_namedv_fv +let (e_binder : + FStarC_Syntax_Syntax.binder FStarC_TypeChecker_NBETerm.embedding) = + let embed_binder cb b = + mk_lazy cb b FStarC_Reflection_V2_Constants.fstar_refl_binder + FStarC_Syntax_Syntax.Lazy_binder in + let unembed_binder cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Lazy + (FStar_Pervasives.Inl + { FStarC_Syntax_Syntax.blob = b; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_binder; + FStarC_Syntax_Syntax.ltyp = uu___; + FStarC_Syntax_Syntax.rng = uu___1;_}, + uu___2) + -> + let uu___3 = FStarC_Dyn.undyn b in + FStar_Pervasives_Native.Some uu___3 + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded binder: %s" uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_binder unembed_binder + FStarC_Reflection_V2_Constants.fstar_refl_binder_fv +let rec mapM_opt : + 'a 'b . + ('a -> 'b FStar_Pervasives_Native.option) -> + 'a Prims.list -> 'b Prims.list FStar_Pervasives_Native.option + = + fun f -> + fun l -> + match l with + | [] -> FStar_Pervasives_Native.Some [] + | x::xs -> + let uu___ = f x in + FStarC_Compiler_Util.bind_opt uu___ + (fun x1 -> + let uu___1 = mapM_opt f xs in + FStarC_Compiler_Util.bind_opt uu___1 + (fun xs1 -> FStar_Pervasives_Native.Some (x1 :: xs1))) +let (e_term_aq : + (Prims.int * FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax + Prims.list) -> + FStarC_Syntax_Syntax.term FStarC_TypeChecker_NBETerm.embedding) + = + fun aq -> + let embed_term cb t = + let qi = + { + FStarC_Syntax_Syntax.qkind = FStarC_Syntax_Syntax.Quote_static; + FStarC_Syntax_Syntax.antiquotations = aq + } in + FStarC_TypeChecker_NBETerm.mk_t + (FStarC_TypeChecker_NBETerm.Quote (t, qi)) in + let unembed_term cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Quote (tm, qi) -> + let uu___ = + FStarC_Reflection_V2_Embeddings.e_term_aq (Prims.int_zero, []) in + let uu___1 = + FStarC_Syntax_Syntax.mk (FStarC_Syntax_Syntax.Tm_quoted (tm, qi)) + FStarC_Compiler_Range_Type.dummyRange in + FStarC_Syntax_Embeddings_Base.unembed uu___ uu___1 + FStarC_Syntax_Embeddings_Base.id_norm_cb + | uu___ -> FStar_Pervasives_Native.None in + { + FStarC_TypeChecker_NBETerm.em = embed_term; + FStarC_TypeChecker_NBETerm.un = unembed_term; + FStarC_TypeChecker_NBETerm.typ = + (fun uu___ -> + mkFV FStarC_Reflection_V2_Constants.fstar_refl_term_fv [] []); + FStarC_TypeChecker_NBETerm.e_typ = + (fun uu___ -> + fv_as_emb_typ FStarC_Reflection_V2_Constants.fstar_refl_term_fv) + } +let (e_term : FStarC_Syntax_Syntax.term FStarC_TypeChecker_NBETerm.embedding) + = e_term_aq (Prims.int_zero, []) +let (e_sort : + FStarC_Syntax_Syntax.term FStarC_Compiler_Sealed.sealed + FStarC_TypeChecker_NBETerm.embedding) + = FStarC_TypeChecker_NBETerm.e_sealed e_term +let (e_ppname : + Prims.string FStarC_Compiler_Sealed.sealed + FStarC_TypeChecker_NBETerm.embedding) + = FStarC_TypeChecker_NBETerm.e_sealed FStarC_TypeChecker_NBETerm.e_string +let (e_aqualv : + FStarC_Reflection_V2_Data.aqualv FStarC_TypeChecker_NBETerm.embedding) = + let embed_aqualv cb q = + match q with + | FStarC_Reflection_V2_Data.Q_Explicit -> + mkConstruct + FStarC_Reflection_V2_Constants.ref_Q_Explicit.FStarC_Reflection_V2_Constants.fv + [] [] + | FStarC_Reflection_V2_Data.Q_Implicit -> + mkConstruct + FStarC_Reflection_V2_Constants.ref_Q_Implicit.FStarC_Reflection_V2_Constants.fv + [] [] + | FStarC_Reflection_V2_Data.Q_Meta t -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_term cb t in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Q_Meta.FStarC_Reflection_V2_Constants.fv + [] uu___ in + let unembed_aqualv cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Q_Explicit.FStarC_Reflection_V2_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V2_Data.Q_Explicit + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Q_Implicit.FStarC_Reflection_V2_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V2_Data.Q_Implicit + | FStarC_TypeChecker_NBETerm.Construct (fv, [], (t1, uu___)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Q_Meta.FStarC_Reflection_V2_Constants.lid + -> + let uu___1 = FStarC_TypeChecker_NBETerm.unembed e_term cb t1 in + FStarC_Compiler_Util.bind_opt uu___1 + (fun t2 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.Q_Meta t2)) + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded aqualv: %s" uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + FStarC_TypeChecker_NBETerm.mk_emb embed_aqualv unembed_aqualv + (fun uu___ -> + mkConstruct FStarC_Reflection_V2_Constants.fstar_refl_aqualv_fv [] []) + (fun uu___ -> + fv_as_emb_typ FStarC_Reflection_V2_Constants.fstar_refl_aqualv_fv) +let (e_binders : + FStarC_Syntax_Syntax.binders FStarC_TypeChecker_NBETerm.embedding) = + FStarC_TypeChecker_NBETerm.e_list e_binder +let (e_fv : FStarC_Syntax_Syntax.fv FStarC_TypeChecker_NBETerm.embedding) = + let embed_fv cb fv = + mk_lazy cb fv FStarC_Reflection_V2_Constants.fstar_refl_fv + FStarC_Syntax_Syntax.Lazy_fvar in + let unembed_fv cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Lazy + (FStar_Pervasives.Inl + { FStarC_Syntax_Syntax.blob = b; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_fvar; + FStarC_Syntax_Syntax.ltyp = uu___; + FStarC_Syntax_Syntax.rng = uu___1;_}, + uu___2) + -> + let uu___3 = FStarC_Dyn.undyn b in + FStar_Pervasives_Native.Some uu___3 + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded fvar: %s" uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_fv unembed_fv FStarC_Reflection_V2_Constants.fstar_refl_fv_fv +let (e_comp : FStarC_Syntax_Syntax.comp FStarC_TypeChecker_NBETerm.embedding) + = + let embed_comp cb c = + mk_lazy cb c FStarC_Reflection_V2_Constants.fstar_refl_comp + FStarC_Syntax_Syntax.Lazy_comp in + let unembed_comp cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Lazy + (FStar_Pervasives.Inl + { FStarC_Syntax_Syntax.blob = b; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_comp; + FStarC_Syntax_Syntax.ltyp = uu___; + FStarC_Syntax_Syntax.rng = uu___1;_}, + uu___2) + -> + let uu___3 = FStarC_Dyn.undyn b in + FStar_Pervasives_Native.Some uu___3 + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded comp: %s" uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_comp unembed_comp + FStarC_Reflection_V2_Constants.fstar_refl_comp_fv +let (e_env : FStarC_TypeChecker_Env.env FStarC_TypeChecker_NBETerm.embedding) + = + let embed_env cb e = + mk_lazy cb e FStarC_Reflection_V2_Constants.fstar_refl_env + FStarC_Syntax_Syntax.Lazy_env in + let unembed_env cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Lazy + (FStar_Pervasives.Inl + { FStarC_Syntax_Syntax.blob = b; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_env; + FStarC_Syntax_Syntax.ltyp = uu___; + FStarC_Syntax_Syntax.rng = uu___1;_}, + uu___2) + -> + let uu___3 = FStarC_Dyn.undyn b in + FStar_Pervasives_Native.Some uu___3 + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded env: %s" uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_env unembed_env + FStarC_Reflection_V2_Constants.fstar_refl_env_fv +let (e_vconst : + FStarC_Reflection_V2_Data.vconst FStarC_TypeChecker_NBETerm.embedding) = + let embed_const cb c = + match c with + | FStarC_Reflection_V2_Data.C_Unit -> + mkConstruct + FStarC_Reflection_V2_Constants.ref_C_Unit.FStarC_Reflection_V2_Constants.fv + [] [] + | FStarC_Reflection_V2_Data.C_True -> + mkConstruct + FStarC_Reflection_V2_Constants.ref_C_True.FStarC_Reflection_V2_Constants.fv + [] [] + | FStarC_Reflection_V2_Data.C_False -> + mkConstruct + FStarC_Reflection_V2_Constants.ref_C_False.FStarC_Reflection_V2_Constants.fv + [] [] + | FStarC_Reflection_V2_Data.C_Int i -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.mk_t + (FStarC_TypeChecker_NBETerm.Constant + (FStarC_TypeChecker_NBETerm.Int i)) in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V2_Constants.ref_C_Int.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.C_String s -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed + FStarC_TypeChecker_NBETerm.e_string cb s in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V2_Constants.ref_C_String.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.C_Range r -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed + FStarC_TypeChecker_NBETerm.e_range cb r in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V2_Constants.ref_C_Range.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.C_Reify -> + mkConstruct + FStarC_Reflection_V2_Constants.ref_C_Reify.FStarC_Reflection_V2_Constants.fv + [] [] + | FStarC_Reflection_V2_Data.C_Reflect ns -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed + FStarC_TypeChecker_NBETerm.e_string_list cb ns in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V2_Constants.ref_C_Reflect.FStarC_Reflection_V2_Constants.fv + [] uu___ in + let unembed_const cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_C_Unit.FStarC_Reflection_V2_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V2_Data.C_Unit + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_C_True.FStarC_Reflection_V2_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V2_Data.C_True + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_C_False.FStarC_Reflection_V2_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V2_Data.C_False + | FStarC_TypeChecker_NBETerm.Construct (fv, [], (i, uu___)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_C_Int.FStarC_Reflection_V2_Constants.lid + -> + let uu___1 = + FStarC_TypeChecker_NBETerm.unembed FStarC_TypeChecker_NBETerm.e_int + cb i in + FStarC_Compiler_Util.bind_opt uu___1 + (fun i1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.C_Int i1)) + | FStarC_TypeChecker_NBETerm.Construct (fv, [], (s, uu___)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_C_String.FStarC_Reflection_V2_Constants.lid + -> + let uu___1 = + FStarC_TypeChecker_NBETerm.unembed + FStarC_TypeChecker_NBETerm.e_string cb s in + FStarC_Compiler_Util.bind_opt uu___1 + (fun s1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.C_String s1)) + | FStarC_TypeChecker_NBETerm.Construct (fv, [], (r, uu___)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_C_Range.FStarC_Reflection_V2_Constants.lid + -> + let uu___1 = + FStarC_TypeChecker_NBETerm.unembed + FStarC_TypeChecker_NBETerm.e_range cb r in + FStarC_Compiler_Util.bind_opt uu___1 + (fun r1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.C_Range r1)) + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_C_Reify.FStarC_Reflection_V2_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V2_Data.C_Reify + | FStarC_TypeChecker_NBETerm.Construct (fv, [], (ns, uu___)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_C_Reflect.FStarC_Reflection_V2_Constants.lid + -> + let uu___1 = + FStarC_TypeChecker_NBETerm.unembed + FStarC_TypeChecker_NBETerm.e_string_list cb ns in + FStarC_Compiler_Util.bind_opt uu___1 + (fun ns1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.C_Reflect ns1)) + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded vconst: %s" uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_const unembed_const + FStarC_Reflection_V2_Constants.fstar_refl_vconst_fv +let (e_universe : + FStarC_Syntax_Syntax.universe FStarC_TypeChecker_NBETerm.embedding) = + let embed_universe cb u = + mk_lazy cb u FStarC_Reflection_V2_Constants.fstar_refl_universe + FStarC_Syntax_Syntax.Lazy_universe in + let unembed_universe cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Lazy + (FStar_Pervasives.Inl + { FStarC_Syntax_Syntax.blob = b; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_universe; + FStarC_Syntax_Syntax.ltyp = uu___; + FStarC_Syntax_Syntax.rng = uu___1;_}, + uu___2) + -> + let uu___3 = FStarC_Dyn.undyn b in + FStar_Pervasives_Native.Some uu___3 + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded universe: %s" + uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_universe unembed_universe + FStarC_Reflection_V2_Constants.fstar_refl_universe_fv +let rec e_pattern_aq : + 'uuuuu . + 'uuuuu -> + FStarC_Reflection_V2_Data.pattern FStarC_TypeChecker_NBETerm.embedding + = + fun aq -> + let embed_pattern cb p = + match p with + | FStarC_Reflection_V2_Data.Pat_Constant c -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_vconst cb c in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Pat_Constant.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.Pat_Cons (fv, us_opt, ps) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_fv cb fv in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_option + (FStarC_TypeChecker_NBETerm.e_list e_universe)) cb + us_opt in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = e_pattern_aq aq in + FStarC_TypeChecker_NBETerm.e_tuple2 uu___9 + FStarC_TypeChecker_NBETerm.e_bool in + FStarC_TypeChecker_NBETerm.e_list uu___8 in + FStarC_TypeChecker_NBETerm.embed uu___7 cb ps in + FStarC_TypeChecker_NBETerm.as_arg uu___6 in + [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Pat_Cons.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.Pat_Var (sort, ppname) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_sort cb sort in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed e_ppname cb ppname in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Pat_Var.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.Pat_Dot_Term eopt -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_option e_term) cb eopt in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Pat_Dot_Term.FStarC_Reflection_V2_Constants.fv + [] uu___ in + let unembed_pattern cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Construct (fv, [], (c, uu___)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Pat_Constant.FStarC_Reflection_V2_Constants.lid + -> + let uu___1 = FStarC_TypeChecker_NBETerm.unembed e_vconst cb c in + FStarC_Compiler_Util.bind_opt uu___1 + (fun c1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.Pat_Constant c1)) + | FStarC_TypeChecker_NBETerm.Construct + (fv, [], (ps, uu___)::(us_opt, uu___1)::(f, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Pat_Cons.FStarC_Reflection_V2_Constants.lid + -> + let uu___3 = FStarC_TypeChecker_NBETerm.unembed e_fv cb f in + FStarC_Compiler_Util.bind_opt uu___3 + (fun f1 -> + let uu___4 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_option + (FStarC_TypeChecker_NBETerm.e_list e_universe)) cb + us_opt in + FStarC_Compiler_Util.bind_opt uu___4 + (fun us -> + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = e_pattern_aq aq in + FStarC_TypeChecker_NBETerm.e_tuple2 uu___8 + FStarC_TypeChecker_NBETerm.e_bool in + FStarC_TypeChecker_NBETerm.e_list uu___7 in + FStarC_TypeChecker_NBETerm.unembed uu___6 cb ps in + FStarC_Compiler_Util.bind_opt uu___5 + (fun ps1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.Pat_Cons (f1, us, ps1))))) + | FStarC_TypeChecker_NBETerm.Construct + (fv, [], (ppname, uu___)::(sort, uu___1)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Pat_Var.FStarC_Reflection_V2_Constants.lid + -> + let uu___2 = FStarC_TypeChecker_NBETerm.unembed e_sort cb sort in + FStarC_Compiler_Util.bind_opt uu___2 + (fun sort1 -> + let uu___3 = + FStarC_TypeChecker_NBETerm.unembed e_ppname cb ppname in + FStarC_Compiler_Util.bind_opt uu___3 + (fun ppname1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.Pat_Var (sort1, ppname1)))) + | FStarC_TypeChecker_NBETerm.Construct (fv, [], (eopt, uu___)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Pat_Dot_Term.FStarC_Reflection_V2_Constants.lid + -> + let uu___1 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_option e_term) cb eopt in + FStarC_Compiler_Util.bind_opt uu___1 + (fun eopt1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.Pat_Dot_Term eopt1)) + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded pattern: %s" + uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded + () (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_pattern unembed_pattern + FStarC_Reflection_V2_Constants.fstar_refl_pattern_fv +let (e_pattern : + FStarC_Reflection_V2_Data.pattern FStarC_TypeChecker_NBETerm.embedding) = + e_pattern_aq noaqs +let (e_branch : + FStarC_Reflection_V2_Data.branch FStarC_TypeChecker_NBETerm.embedding) = + FStarC_TypeChecker_NBETerm.e_tuple2 e_pattern e_term +let (e_argv : + FStarC_Reflection_V2_Data.argv FStarC_TypeChecker_NBETerm.embedding) = + FStarC_TypeChecker_NBETerm.e_tuple2 e_term e_aqualv +let (e_branch_aq : + (Prims.int * FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax + Prims.list) -> + (FStarC_Reflection_V2_Data.pattern * FStarC_Syntax_Syntax.term) + FStarC_TypeChecker_NBETerm.embedding) + = + fun aq -> + let uu___ = e_pattern_aq aq in + FStarC_TypeChecker_NBETerm.e_tuple2 uu___ (e_term_aq aq) +let (e_argv_aq : + (Prims.int * FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax + Prims.list) -> + (FStarC_Syntax_Syntax.term * FStarC_Reflection_V2_Data.aqualv) + FStarC_TypeChecker_NBETerm.embedding) + = fun aq -> FStarC_TypeChecker_NBETerm.e_tuple2 (e_term_aq aq) e_aqualv +let (e_match_returns_annotation : + (FStarC_Syntax_Syntax.binder * ((FStarC_Syntax_Syntax.term, + FStarC_Syntax_Syntax.comp) FStar_Pervasives.either * + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option * Prims.bool)) + FStar_Pervasives_Native.option FStarC_TypeChecker_NBETerm.embedding) + = + FStarC_TypeChecker_NBETerm.e_option + (FStarC_TypeChecker_NBETerm.e_tuple2 e_binder + (FStarC_TypeChecker_NBETerm.e_tuple3 + (FStarC_TypeChecker_NBETerm.e_either e_term e_comp) + (FStarC_TypeChecker_NBETerm.e_option e_term) + FStarC_TypeChecker_NBETerm.e_bool)) +let unlazy_as_t : + 'uuuuu . + FStarC_Syntax_Syntax.lazy_kind -> FStarC_TypeChecker_NBETerm.t -> 'uuuuu + = + fun k -> + fun t -> + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Lazy + (FStar_Pervasives.Inl + { FStarC_Syntax_Syntax.blob = v; FStarC_Syntax_Syntax.lkind = k'; + FStarC_Syntax_Syntax.ltyp = uu___; + FStarC_Syntax_Syntax.rng = uu___1;_}, + uu___2) + when + FStarC_Class_Deq.op_Equals_Question + FStarC_Syntax_Syntax.deq_lazy_kind k k' + -> FStarC_Dyn.undyn v + | uu___ -> failwith "Not a Lazy of the expected kind (NBE)" +let (e_ident : FStarC_Ident.ident FStarC_TypeChecker_NBETerm.embedding) = + let embed_ident cb se = + mk_lazy cb se FStarC_Reflection_V2_Constants.fstar_refl_ident + FStarC_Syntax_Syntax.Lazy_ident in + let unembed_ident cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Lazy + (FStar_Pervasives.Inl + { FStarC_Syntax_Syntax.blob = b; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_ident; + FStarC_Syntax_Syntax.ltyp = uu___; + FStarC_Syntax_Syntax.rng = uu___1;_}, + uu___2) + -> + let uu___3 = FStarC_Dyn.undyn b in + FStar_Pervasives_Native.Some uu___3 + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded ident: %s" uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_ident unembed_ident + FStarC_Reflection_V2_Constants.fstar_refl_ident_fv +let (e_univ_name : + FStarC_Syntax_Syntax.univ_name FStarC_TypeChecker_NBETerm.embedding) = + e_ident +let (e_univ_names : + FStarC_Syntax_Syntax.univ_name Prims.list + FStarC_TypeChecker_NBETerm.embedding) + = FStarC_TypeChecker_NBETerm.e_list e_univ_name +let (e_universe_view : + FStarC_Reflection_V2_Data.universe_view + FStarC_TypeChecker_NBETerm.embedding) + = + let embed_universe_view cb uv = + match uv with + | FStarC_Reflection_V2_Data.Uv_Zero -> + mkConstruct + FStarC_Reflection_V2_Constants.ref_Uv_Zero.FStarC_Reflection_V2_Constants.fv + [] [] + | FStarC_Reflection_V2_Data.Uv_Succ u -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_universe cb u in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Uv_Succ.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.Uv_Max us -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_list e_universe) cb us in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Uv_Max.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.Uv_BVar n -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed + FStarC_TypeChecker_NBETerm.e_int cb n in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Uv_BVar.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.Uv_Name i -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_ident cb i in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Uv_Name.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.Uv_Unif u -> + let uu___ = + let uu___1 = + let uu___2 = + mk_lazy cb u FStarC_Syntax_Util.t_universe_uvar + FStarC_Syntax_Syntax.Lazy_universe_uvar in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Uv_Unif.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.Uv_Unk -> + mkConstruct + FStarC_Reflection_V2_Constants.ref_Uv_Unk.FStarC_Reflection_V2_Constants.fv + [] [] in + let unembed_universe_view cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Uv_Zero.FStarC_Reflection_V2_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V2_Data.Uv_Zero + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, (u, uu___1)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Uv_Succ.FStarC_Reflection_V2_Constants.lid + -> + let uu___2 = FStarC_TypeChecker_NBETerm.unembed e_universe cb u in + FStarC_Compiler_Util.bind_opt uu___2 + (fun u1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.Uv_Succ u1)) + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, (us, uu___1)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Uv_Max.FStarC_Reflection_V2_Constants.lid + -> + let uu___2 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_list e_universe) cb us in + FStarC_Compiler_Util.bind_opt uu___2 + (fun us1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.Uv_Max us1)) + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, (n, uu___1)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Uv_BVar.FStarC_Reflection_V2_Constants.lid + -> + let uu___2 = + FStarC_TypeChecker_NBETerm.unembed FStarC_TypeChecker_NBETerm.e_int + cb n in + FStarC_Compiler_Util.bind_opt uu___2 + (fun n1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.Uv_BVar n1)) + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, (i, uu___1)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Uv_Name.FStarC_Reflection_V2_Constants.lid + -> + let uu___2 = FStarC_TypeChecker_NBETerm.unembed e_ident cb i in + FStarC_Compiler_Util.bind_opt uu___2 + (fun i1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.Uv_Name i1)) + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, (u, uu___1)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Uv_Unif.FStarC_Reflection_V2_Constants.lid + -> + let u1 = unlazy_as_t FStarC_Syntax_Syntax.Lazy_universe_uvar u in + FStar_Pervasives_Native.Some (FStarC_Reflection_V2_Data.Uv_Unif u1) + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Uv_Unk.FStarC_Reflection_V2_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V2_Data.Uv_Unk + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded universe view: %s" + uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_universe_view unembed_universe_view + FStarC_Reflection_V2_Constants.fstar_refl_universe_view_fv +let (e_subst_elt : + FStarC_Syntax_Syntax.subst_elt FStarC_TypeChecker_NBETerm.embedding) = + let embed_const cb e = + match e with + | FStarC_Syntax_Syntax.DB (i, x) -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_BigInt.of_int_fs i in + FStarC_TypeChecker_NBETerm.embed + FStarC_TypeChecker_NBETerm.e_int cb uu___3 in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_TypeChecker_NBETerm.embed e_namedv cb x in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V2_Constants.ref_DB.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Syntax_Syntax.NM (x, i) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_namedv cb x in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_BigInt.of_int_fs i in + FStarC_TypeChecker_NBETerm.embed + FStarC_TypeChecker_NBETerm.e_int cb uu___5 in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V2_Constants.ref_NM.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Syntax_Syntax.NT (x, t) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_namedv cb x in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_TypeChecker_NBETerm.embed e_term cb t in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V2_Constants.ref_NT.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Syntax_Syntax.UN (i, u) -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_BigInt.of_int_fs i in + FStarC_TypeChecker_NBETerm.embed + FStarC_TypeChecker_NBETerm.e_int cb uu___3 in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_TypeChecker_NBETerm.embed e_universe cb u in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V2_Constants.ref_UN.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Syntax_Syntax.UD (n, i) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_univ_name cb n in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_BigInt.of_int_fs i in + FStarC_TypeChecker_NBETerm.embed + FStarC_TypeChecker_NBETerm.e_int cb uu___5 in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V2_Constants.ref_UD.FStarC_Reflection_V2_Constants.fv + [] uu___ in + let unembed_const cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Construct + (fv, [], (x, uu___)::(i, uu___1)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_DB.FStarC_Reflection_V2_Constants.lid + -> + let uu___2 = + FStarC_TypeChecker_NBETerm.unembed FStarC_TypeChecker_NBETerm.e_int + cb i in + FStarC_Compiler_Util.bind_opt uu___2 + (fun i1 -> + let uu___3 = FStarC_TypeChecker_NBETerm.unembed e_namedv cb x in + FStarC_Compiler_Util.bind_opt uu___3 + (fun x1 -> + let uu___4 = + let uu___5 = + let uu___6 = FStarC_BigInt.to_int_fs i1 in (uu___6, x1) in + FStarC_Syntax_Syntax.DB uu___5 in + FStar_Pervasives_Native.Some uu___4)) + | FStarC_TypeChecker_NBETerm.Construct + (fv, [], (i, uu___)::(x, uu___1)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_NM.FStarC_Reflection_V2_Constants.lid + -> + let uu___2 = FStarC_TypeChecker_NBETerm.unembed e_namedv cb x in + FStarC_Compiler_Util.bind_opt uu___2 + (fun x1 -> + let uu___3 = + FStarC_TypeChecker_NBETerm.unembed + FStarC_TypeChecker_NBETerm.e_int cb i in + FStarC_Compiler_Util.bind_opt uu___3 + (fun i1 -> + let uu___4 = + let uu___5 = + let uu___6 = FStarC_BigInt.to_int_fs i1 in (x1, uu___6) in + FStarC_Syntax_Syntax.NM uu___5 in + FStar_Pervasives_Native.Some uu___4)) + | FStarC_TypeChecker_NBETerm.Construct + (fv, [], (t1, uu___)::(x, uu___1)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_NT.FStarC_Reflection_V2_Constants.lid + -> + let uu___2 = FStarC_TypeChecker_NBETerm.unembed e_namedv cb x in + FStarC_Compiler_Util.bind_opt uu___2 + (fun x1 -> + let uu___3 = FStarC_TypeChecker_NBETerm.unembed e_term cb t1 in + FStarC_Compiler_Util.bind_opt uu___3 + (fun t2 -> + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.NT (x1, t2)))) + | FStarC_TypeChecker_NBETerm.Construct + (fv, [], (u, uu___)::(i, uu___1)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_UN.FStarC_Reflection_V2_Constants.lid + -> + let uu___2 = + FStarC_TypeChecker_NBETerm.unembed FStarC_TypeChecker_NBETerm.e_int + cb i in + FStarC_Compiler_Util.bind_opt uu___2 + (fun i1 -> + let uu___3 = FStarC_TypeChecker_NBETerm.unembed e_universe cb u in + FStarC_Compiler_Util.bind_opt uu___3 + (fun u1 -> + let uu___4 = + let uu___5 = + let uu___6 = FStarC_BigInt.to_int_fs i1 in (uu___6, u1) in + FStarC_Syntax_Syntax.UN uu___5 in + FStar_Pervasives_Native.Some uu___4)) + | FStarC_TypeChecker_NBETerm.Construct + (fv, [], (i, uu___)::(n, uu___1)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_UD.FStarC_Reflection_V2_Constants.lid + -> + let uu___2 = FStarC_TypeChecker_NBETerm.unembed e_univ_name cb n in + FStarC_Compiler_Util.bind_opt uu___2 + (fun n1 -> + let uu___3 = + FStarC_TypeChecker_NBETerm.unembed + FStarC_TypeChecker_NBETerm.e_int cb i in + FStarC_Compiler_Util.bind_opt uu___3 + (fun i1 -> + let uu___4 = + let uu___5 = + let uu___6 = FStarC_BigInt.to_int_fs i1 in (n1, uu___6) in + FStarC_Syntax_Syntax.UD uu___5 in + FStar_Pervasives_Native.Some uu___4)) + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded vconst: %s" uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_const unembed_const + FStarC_Reflection_V2_Constants.fstar_refl_subst_elt_fv +let (e_subst : + FStarC_Syntax_Syntax.subst_elt Prims.list + FStarC_TypeChecker_NBETerm.embedding) + = FStarC_TypeChecker_NBETerm.e_list e_subst_elt +let (e_term_view_aq : + (Prims.int * FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax + Prims.list) -> + FStarC_Reflection_V2_Data.term_view FStarC_TypeChecker_NBETerm.embedding) + = + fun aq -> + let shift uu___ = + match uu___ with | (s, aqs) -> ((s + Prims.int_one), aqs) in + let embed_term_view cb tv = + match tv with + | FStarC_Reflection_V2_Data.Tv_FVar fv -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_fv cb fv in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Tv_FVar.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.Tv_BVar bv -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_bv cb bv in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Tv_BVar.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.Tv_Var bv -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_bv cb bv in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Tv_Var.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.Tv_UInst (fv, us) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_fv cb fv in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_list e_universe) cb us in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Tv_UInst.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.Tv_App (hd, a) -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed (e_term_aq aq) cb hd in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed (e_argv_aq aq) cb a in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Tv_App.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.Tv_Abs (b, t) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_binder cb b in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed (e_term_aq (shift aq)) cb + t in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Tv_Abs.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.Tv_Arrow (b, c) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_binder cb b in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_TypeChecker_NBETerm.embed e_comp cb c in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Tv_Arrow.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.Tv_Type u -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_universe cb u in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Tv_Type.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.Tv_Refine (b, t) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_binder cb b in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed (e_term_aq (shift aq)) cb + t in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Tv_Refine.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.Tv_Const c -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_vconst cb c in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Tv_Const.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.Tv_Uvar (u, d) -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed + FStarC_TypeChecker_NBETerm.e_int cb u in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + mk_lazy cb (u, d) FStarC_Syntax_Util.t_ctx_uvar_and_sust + FStarC_Syntax_Syntax.Lazy_uvar in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Tv_Uvar.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.Tv_Let (r, attrs, b, t1, t2) -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed + FStarC_TypeChecker_NBETerm.e_bool cb r in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_list e_term) cb attrs in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = FStarC_TypeChecker_NBETerm.embed e_binder cb b in + FStarC_TypeChecker_NBETerm.as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_TypeChecker_NBETerm.embed (e_term_aq aq) cb t1 in + FStarC_TypeChecker_NBETerm.as_arg uu___8 in + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_TypeChecker_NBETerm.embed + (e_term_aq (shift aq)) cb t2 in + FStarC_TypeChecker_NBETerm.as_arg uu___10 in + [uu___9] in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Tv_Let.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.Tv_Match (t, ret_opt, brs) -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed (e_term_aq aq) cb t in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed e_match_returns_annotation + cb ret_opt in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = e_branch_aq aq in + FStarC_TypeChecker_NBETerm.e_list uu___8 in + FStarC_TypeChecker_NBETerm.embed uu___7 cb brs in + FStarC_TypeChecker_NBETerm.as_arg uu___6 in + [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Tv_Match.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.Tv_AscribedT (e, t, tacopt, use_eq) -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed (e_term_aq aq) cb e in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed (e_term_aq aq) cb t in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_option (e_term_aq aq)) cb + tacopt in + FStarC_TypeChecker_NBETerm.as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_TypeChecker_NBETerm.embed + FStarC_TypeChecker_NBETerm.e_bool cb use_eq in + FStarC_TypeChecker_NBETerm.as_arg uu___8 in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Tv_AscT.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.Tv_AscribedC (e, c, tacopt, use_eq) -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed (e_term_aq aq) cb e in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_TypeChecker_NBETerm.embed e_comp cb c in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_option (e_term_aq aq)) cb + tacopt in + FStarC_TypeChecker_NBETerm.as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_TypeChecker_NBETerm.embed + FStarC_TypeChecker_NBETerm.e_bool cb use_eq in + FStarC_TypeChecker_NBETerm.as_arg uu___8 in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Tv_AscT.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.Tv_Unknown -> + mkConstruct + FStarC_Reflection_V2_Constants.ref_Tv_Unknown.FStarC_Reflection_V2_Constants.fv + [] [] + | FStarC_Reflection_V2_Data.Tv_Unsupp -> + mkConstruct + FStarC_Reflection_V2_Constants.ref_Tv_Unsupp.FStarC_Reflection_V2_Constants.fv + [] [] in + let unembed_term_view cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, (b, uu___1)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Tv_Var.FStarC_Reflection_V2_Constants.lid + -> + let uu___2 = FStarC_TypeChecker_NBETerm.unembed e_bv cb b in + FStarC_Compiler_Util.bind_opt uu___2 + (fun b1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.Tv_Var b1)) + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, (b, uu___1)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Tv_BVar.FStarC_Reflection_V2_Constants.lid + -> + let uu___2 = FStarC_TypeChecker_NBETerm.unembed e_bv cb b in + FStarC_Compiler_Util.bind_opt uu___2 + (fun b1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.Tv_BVar b1)) + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, (f, uu___1)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Tv_FVar.FStarC_Reflection_V2_Constants.lid + -> + let uu___2 = FStarC_TypeChecker_NBETerm.unembed e_fv cb f in + FStarC_Compiler_Util.bind_opt uu___2 + (fun f1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.Tv_FVar f1)) + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, (f, uu___1)::(us, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Tv_UInst.FStarC_Reflection_V2_Constants.lid + -> + let uu___3 = FStarC_TypeChecker_NBETerm.unembed e_fv cb f in + FStarC_Compiler_Util.bind_opt uu___3 + (fun f1 -> + let uu___4 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_list e_universe) cb us in + FStarC_Compiler_Util.bind_opt uu___4 + (fun us1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.Tv_UInst (f1, us1)))) + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, (r, uu___1)::(l, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Tv_App.FStarC_Reflection_V2_Constants.lid + -> + let uu___3 = FStarC_TypeChecker_NBETerm.unembed e_term cb l in + FStarC_Compiler_Util.bind_opt uu___3 + (fun l1 -> + let uu___4 = FStarC_TypeChecker_NBETerm.unembed e_argv cb r in + FStarC_Compiler_Util.bind_opt uu___4 + (fun r1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.Tv_App (l1, r1)))) + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, (t1, uu___1)::(b, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Tv_Abs.FStarC_Reflection_V2_Constants.lid + -> + let uu___3 = FStarC_TypeChecker_NBETerm.unembed e_binder cb b in + FStarC_Compiler_Util.bind_opt uu___3 + (fun b1 -> + let uu___4 = FStarC_TypeChecker_NBETerm.unembed e_term cb t1 in + FStarC_Compiler_Util.bind_opt uu___4 + (fun t2 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.Tv_Abs (b1, t2)))) + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, (t1, uu___1)::(b, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Tv_Arrow.FStarC_Reflection_V2_Constants.lid + -> + let uu___3 = FStarC_TypeChecker_NBETerm.unembed e_binder cb b in + FStarC_Compiler_Util.bind_opt uu___3 + (fun b1 -> + let uu___4 = FStarC_TypeChecker_NBETerm.unembed e_comp cb t1 in + FStarC_Compiler_Util.bind_opt uu___4 + (fun c -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.Tv_Arrow (b1, c)))) + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, (u, uu___1)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Tv_Type.FStarC_Reflection_V2_Constants.lid + -> + let uu___2 = FStarC_TypeChecker_NBETerm.unembed e_universe cb u in + FStarC_Compiler_Util.bind_opt uu___2 + (fun u1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.Tv_Type u1)) + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, (t1, uu___1)::(b, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Tv_Refine.FStarC_Reflection_V2_Constants.lid + -> + let uu___3 = FStarC_TypeChecker_NBETerm.unembed e_binder cb b in + FStarC_Compiler_Util.bind_opt uu___3 + (fun b1 -> + let uu___4 = FStarC_TypeChecker_NBETerm.unembed e_term cb t1 in + FStarC_Compiler_Util.bind_opt uu___4 + (fun t2 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.Tv_Refine (b1, t2)))) + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, (c, uu___1)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Tv_Const.FStarC_Reflection_V2_Constants.lid + -> + let uu___2 = FStarC_TypeChecker_NBETerm.unembed e_vconst cb c in + FStarC_Compiler_Util.bind_opt uu___2 + (fun c1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.Tv_Const c1)) + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, (l, uu___1)::(u, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Tv_Uvar.FStarC_Reflection_V2_Constants.lid + -> + let uu___3 = + FStarC_TypeChecker_NBETerm.unembed + FStarC_TypeChecker_NBETerm.e_int cb u in + FStarC_Compiler_Util.bind_opt uu___3 + (fun u1 -> + let ctx_u_s = unlazy_as_t FStarC_Syntax_Syntax.Lazy_uvar l in + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.Tv_Uvar (u1, ctx_u_s))) + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, + (t2, uu___1)::(t1, uu___2)::(b, uu___3)::(attrs, uu___4):: + (r, uu___5)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Tv_Let.FStarC_Reflection_V2_Constants.lid + -> + let uu___6 = + FStarC_TypeChecker_NBETerm.unembed + FStarC_TypeChecker_NBETerm.e_bool cb r in + FStarC_Compiler_Util.bind_opt uu___6 + (fun r1 -> + let uu___7 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_list e_term) cb attrs in + FStarC_Compiler_Util.bind_opt uu___7 + (fun attrs1 -> + let uu___8 = + FStarC_TypeChecker_NBETerm.unembed e_binder cb b in + FStarC_Compiler_Util.bind_opt uu___8 + (fun b1 -> + let uu___9 = + FStarC_TypeChecker_NBETerm.unembed e_term cb t1 in + FStarC_Compiler_Util.bind_opt uu___9 + (fun t11 -> + let uu___10 = + FStarC_TypeChecker_NBETerm.unembed e_term cb + t2 in + FStarC_Compiler_Util.bind_opt uu___10 + (fun t21 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.Tv_Let + (r1, attrs1, b1, t11, t21))))))) + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, (brs, uu___1)::(ret_opt, uu___2)::(t1, uu___3)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Tv_Match.FStarC_Reflection_V2_Constants.lid + -> + let uu___4 = FStarC_TypeChecker_NBETerm.unembed e_term cb t1 in + FStarC_Compiler_Util.bind_opt uu___4 + (fun t2 -> + let uu___5 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_list e_branch) cb brs in + FStarC_Compiler_Util.bind_opt uu___5 + (fun brs1 -> + let uu___6 = + FStarC_TypeChecker_NBETerm.unembed + e_match_returns_annotation cb ret_opt in + FStarC_Compiler_Util.bind_opt uu___6 + (fun ret_opt1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.Tv_Match + (t2, ret_opt1, brs1))))) + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, + (tacopt, uu___1)::(t1, uu___2)::(e, uu___3)::(use_eq, uu___4)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Tv_AscT.FStarC_Reflection_V2_Constants.lid + -> + let uu___5 = FStarC_TypeChecker_NBETerm.unembed e_term cb e in + FStarC_Compiler_Util.bind_opt uu___5 + (fun e1 -> + let uu___6 = FStarC_TypeChecker_NBETerm.unembed e_term cb t1 in + FStarC_Compiler_Util.bind_opt uu___6 + (fun t2 -> + let uu___7 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_option e_term) cb + tacopt in + FStarC_Compiler_Util.bind_opt uu___7 + (fun tacopt1 -> + let uu___8 = + FStarC_TypeChecker_NBETerm.unembed + FStarC_TypeChecker_NBETerm.e_bool cb use_eq in + FStarC_Compiler_Util.bind_opt uu___8 + (fun use_eq1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.Tv_AscribedT + (e1, t2, tacopt1, use_eq1)))))) + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, + (tacopt, uu___1)::(c, uu___2)::(e, uu___3)::(use_eq, uu___4)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Tv_AscC.FStarC_Reflection_V2_Constants.lid + -> + let uu___5 = FStarC_TypeChecker_NBETerm.unembed e_term cb e in + FStarC_Compiler_Util.bind_opt uu___5 + (fun e1 -> + let uu___6 = FStarC_TypeChecker_NBETerm.unembed e_comp cb c in + FStarC_Compiler_Util.bind_opt uu___6 + (fun c1 -> + let uu___7 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_option e_term) cb + tacopt in + FStarC_Compiler_Util.bind_opt uu___7 + (fun tacopt1 -> + let uu___8 = + FStarC_TypeChecker_NBETerm.unembed + FStarC_TypeChecker_NBETerm.e_bool cb use_eq in + FStarC_Compiler_Util.bind_opt uu___8 + (fun use_eq1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.Tv_AscribedC + (e1, c1, tacopt1, use_eq1)))))) + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Tv_Unknown.FStarC_Reflection_V2_Constants.lid + -> + FStar_Pervasives_Native.Some FStarC_Reflection_V2_Data.Tv_Unknown + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Tv_Unsupp.FStarC_Reflection_V2_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V2_Data.Tv_Unsupp + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded term_view: %s" + uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded + () (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_term_view unembed_term_view + FStarC_Reflection_V2_Constants.fstar_refl_term_view_fv +let (e_term_view : + FStarC_Reflection_V2_Data.term_view FStarC_TypeChecker_NBETerm.embedding) = + e_term_view_aq (Prims.int_zero, []) +let (e_namedv_view : + FStarC_Reflection_V2_Data.namedv_view FStarC_TypeChecker_NBETerm.embedding) + = + let embed_namedv_view cb namedvv = + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed FStarC_TypeChecker_NBETerm.e_int + cb namedvv.FStarC_Reflection_V2_Data.uniq in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed e_ppname cb + namedvv.FStarC_Reflection_V2_Data.ppname in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_TypeChecker_NBETerm.embed e_sort cb + namedvv.FStarC_Reflection_V2_Data.sort in + FStarC_TypeChecker_NBETerm.as_arg uu___6 in + [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Mk_namedv_view.FStarC_Reflection_V2_Constants.fv + [] uu___ in + let unembed_namedv_view cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, (sort, uu___1)::(ppname, uu___2)::(uniq, uu___3)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Mk_namedv_view.FStarC_Reflection_V2_Constants.lid + -> + let uu___4 = + FStarC_TypeChecker_NBETerm.unembed FStarC_TypeChecker_NBETerm.e_int + cb uniq in + FStarC_Compiler_Util.bind_opt uu___4 + (fun uniq1 -> + let uu___5 = + FStarC_TypeChecker_NBETerm.unembed e_ppname cb ppname in + FStarC_Compiler_Util.bind_opt uu___5 + (fun ppname1 -> + let uu___6 = + FStarC_TypeChecker_NBETerm.unembed e_sort cb sort in + FStarC_Compiler_Util.bind_opt uu___6 + (fun sort1 -> + let r = + { + FStarC_Reflection_V2_Data.uniq = uniq1; + FStarC_Reflection_V2_Data.sort = sort1; + FStarC_Reflection_V2_Data.ppname = ppname1 + } in + FStar_Pervasives_Native.Some r))) + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded namedv_view: %s" + uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_namedv_view unembed_namedv_view + FStarC_Reflection_V2_Constants.fstar_refl_namedv_view_fv +let (e_bv_view : + FStarC_Reflection_V2_Data.bv_view FStarC_TypeChecker_NBETerm.embedding) = + let embed_bv_view cb bvv = + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed FStarC_TypeChecker_NBETerm.e_int + cb bvv.FStarC_Reflection_V2_Data.index in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed e_ppname cb + bvv.FStarC_Reflection_V2_Data.ppname1 in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_TypeChecker_NBETerm.embed e_sort cb + bvv.FStarC_Reflection_V2_Data.sort1 in + FStarC_TypeChecker_NBETerm.as_arg uu___6 in + [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Mk_bv_view.FStarC_Reflection_V2_Constants.fv + [] uu___ in + let unembed_bv_view cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, (sort, uu___1)::(ppname, uu___2)::(idx, uu___3)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Mk_bv_view.FStarC_Reflection_V2_Constants.lid + -> + let uu___4 = + FStarC_TypeChecker_NBETerm.unembed FStarC_TypeChecker_NBETerm.e_int + cb idx in + FStarC_Compiler_Util.bind_opt uu___4 + (fun idx1 -> + let uu___5 = + FStarC_TypeChecker_NBETerm.unembed e_ppname cb ppname in + FStarC_Compiler_Util.bind_opt uu___5 + (fun ppname1 -> + let uu___6 = + FStarC_TypeChecker_NBETerm.unembed e_sort cb sort in + FStarC_Compiler_Util.bind_opt uu___6 + (fun sort1 -> + let r = + { + FStarC_Reflection_V2_Data.index = idx1; + FStarC_Reflection_V2_Data.sort1 = sort1; + FStarC_Reflection_V2_Data.ppname1 = ppname1 + } in + FStar_Pervasives_Native.Some r))) + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded bv_view: %s" uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_bv_view unembed_bv_view + FStarC_Reflection_V2_Constants.fstar_refl_bv_view_fv +let (e_attribute : + FStarC_Syntax_Syntax.attribute FStarC_TypeChecker_NBETerm.embedding) = + e_term +let (e_attributes : + FStarC_Syntax_Syntax.attribute Prims.list + FStarC_TypeChecker_NBETerm.embedding) + = FStarC_TypeChecker_NBETerm.e_list e_attribute +let (e_binding : + FStarC_Reflection_V2_Data.binding FStarC_TypeChecker_NBETerm.embedding) = + let embed cb b = + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed FStarC_TypeChecker_NBETerm.e_int + cb b.FStarC_Reflection_V2_Data.uniq1 in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed e_term cb + b.FStarC_Reflection_V2_Data.sort3 in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_TypeChecker_NBETerm.embed e_ppname cb + b.FStarC_Reflection_V2_Data.ppname3 in + FStarC_TypeChecker_NBETerm.as_arg uu___6 in + [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Mk_binding.FStarC_Reflection_V2_Constants.fv + [] uu___ in + let unembed cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, (ppname, uu___1)::(sort, uu___2)::(uniq, uu___3)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Mk_binding.FStarC_Reflection_V2_Constants.lid + -> + let uu___4 = + FStarC_TypeChecker_NBETerm.unembed FStarC_TypeChecker_NBETerm.e_int + cb uniq in + FStarC_Compiler_Util.bind_opt uu___4 + (fun uniq1 -> + let uu___5 = FStarC_TypeChecker_NBETerm.unembed e_term cb sort in + FStarC_Compiler_Util.bind_opt uu___5 + (fun sort1 -> + let uu___6 = + FStarC_TypeChecker_NBETerm.unembed e_ppname cb ppname in + FStarC_Compiler_Util.bind_opt uu___6 + (fun ppname1 -> + let r = + { + FStarC_Reflection_V2_Data.uniq1 = uniq1; + FStarC_Reflection_V2_Data.sort3 = sort1; + FStarC_Reflection_V2_Data.ppname3 = ppname1 + } in + FStar_Pervasives_Native.Some r))) in + mk_emb' embed unembed FStarC_Reflection_V2_Constants.fstar_refl_binding_fv +let (e_binder_view : + FStarC_Reflection_V2_Data.binder_view FStarC_TypeChecker_NBETerm.embedding) + = + let embed_binder_view cb bview = + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed e_term cb + bview.FStarC_Reflection_V2_Data.sort2 in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed e_aqualv cb + bview.FStarC_Reflection_V2_Data.qual in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_TypeChecker_NBETerm.embed e_attributes cb + bview.FStarC_Reflection_V2_Data.attrs in + FStarC_TypeChecker_NBETerm.as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_TypeChecker_NBETerm.embed e_ppname cb + bview.FStarC_Reflection_V2_Data.ppname2 in + FStarC_TypeChecker_NBETerm.as_arg uu___8 in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Mk_binder_view.FStarC_Reflection_V2_Constants.fv + [] uu___ in + let unembed_binder_view cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, + (ppname, uu___1)::(attrs, uu___2)::(q, uu___3)::(sort, uu___4)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Mk_binder_view.FStarC_Reflection_V2_Constants.lid + -> + let uu___5 = FStarC_TypeChecker_NBETerm.unembed e_term cb sort in + FStarC_Compiler_Util.bind_opt uu___5 + (fun sort1 -> + let uu___6 = FStarC_TypeChecker_NBETerm.unembed e_aqualv cb q in + FStarC_Compiler_Util.bind_opt uu___6 + (fun q1 -> + let uu___7 = + FStarC_TypeChecker_NBETerm.unembed e_attributes cb attrs in + FStarC_Compiler_Util.bind_opt uu___7 + (fun attrs1 -> + let uu___8 = + FStarC_TypeChecker_NBETerm.unembed e_ppname cb + ppname in + FStarC_Compiler_Util.bind_opt uu___8 + (fun ppname1 -> + let r = + { + FStarC_Reflection_V2_Data.sort2 = sort1; + FStarC_Reflection_V2_Data.qual = q1; + FStarC_Reflection_V2_Data.attrs = attrs1; + FStarC_Reflection_V2_Data.ppname2 = ppname1 + } in + FStar_Pervasives_Native.Some r)))) + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded binder_view: %s" + uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_binder_view unembed_binder_view + FStarC_Reflection_V2_Constants.fstar_refl_binder_view_fv +let (e_comp_view : + FStarC_Reflection_V2_Data.comp_view FStarC_TypeChecker_NBETerm.embedding) = + let embed_comp_view cb cv = + match cv with + | FStarC_Reflection_V2_Data.C_Total t -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_term cb t in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V2_Constants.ref_C_Total.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.C_GTotal t -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_term cb t in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V2_Constants.ref_C_GTotal.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.C_Lemma (pre, post, pats) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_term cb pre in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_TypeChecker_NBETerm.embed e_term cb post in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = FStarC_TypeChecker_NBETerm.embed e_term cb pats in + FStarC_TypeChecker_NBETerm.as_arg uu___6 in + [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V2_Constants.ref_C_Lemma.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.C_Eff (us, eff, res, args, decrs) -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_list e_universe) cb us in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed + FStarC_TypeChecker_NBETerm.e_string_list cb eff in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = FStarC_TypeChecker_NBETerm.embed e_term cb res in + FStarC_TypeChecker_NBETerm.as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_list e_argv) cb args in + FStarC_TypeChecker_NBETerm.as_arg uu___8 in + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_list e_term) cb decrs in + FStarC_TypeChecker_NBETerm.as_arg uu___10 in + [uu___9] in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V2_Constants.ref_C_Eff.FStarC_Reflection_V2_Constants.fv + [] uu___ in + let unembed_comp_view cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, (t1, uu___1)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_C_Total.FStarC_Reflection_V2_Constants.lid + -> + let uu___2 = FStarC_TypeChecker_NBETerm.unembed e_term cb t1 in + FStarC_Compiler_Util.bind_opt uu___2 + (fun t2 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.C_Total t2)) + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, (t1, uu___1)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_C_GTotal.FStarC_Reflection_V2_Constants.lid + -> + let uu___2 = FStarC_TypeChecker_NBETerm.unembed e_term cb t1 in + FStarC_Compiler_Util.bind_opt uu___2 + (fun t2 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.C_GTotal t2)) + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, (post, uu___1)::(pre, uu___2)::(pats, uu___3)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_C_Lemma.FStarC_Reflection_V2_Constants.lid + -> + let uu___4 = FStarC_TypeChecker_NBETerm.unembed e_term cb pre in + FStarC_Compiler_Util.bind_opt uu___4 + (fun pre1 -> + let uu___5 = FStarC_TypeChecker_NBETerm.unembed e_term cb post in + FStarC_Compiler_Util.bind_opt uu___5 + (fun post1 -> + let uu___6 = + FStarC_TypeChecker_NBETerm.unembed e_term cb pats in + FStarC_Compiler_Util.bind_opt uu___6 + (fun pats1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.C_Lemma + (pre1, post1, pats1))))) + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, + (decrs, uu___1)::(args, uu___2)::(res, uu___3)::(eff, uu___4):: + (us, uu___5)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_C_Eff.FStarC_Reflection_V2_Constants.lid + -> + let uu___6 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_list e_universe) cb us in + FStarC_Compiler_Util.bind_opt uu___6 + (fun us1 -> + let uu___7 = + FStarC_TypeChecker_NBETerm.unembed + FStarC_TypeChecker_NBETerm.e_string_list cb eff in + FStarC_Compiler_Util.bind_opt uu___7 + (fun eff1 -> + let uu___8 = + FStarC_TypeChecker_NBETerm.unembed e_term cb res in + FStarC_Compiler_Util.bind_opt uu___8 + (fun res1 -> + let uu___9 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_list e_argv) cb args in + FStarC_Compiler_Util.bind_opt uu___9 + (fun args1 -> + let uu___10 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_list e_term) cb + decrs in + FStarC_Compiler_Util.bind_opt uu___10 + (fun decrs1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.C_Eff + (us1, eff1, res1, args1, decrs1))))))) + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded comp_view: %s" + uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_comp_view unembed_comp_view + FStarC_Reflection_V2_Constants.fstar_refl_comp_view_fv +let (e_sigelt : + FStarC_Syntax_Syntax.sigelt FStarC_TypeChecker_NBETerm.embedding) = + let embed_sigelt cb se = + mk_lazy cb se FStarC_Reflection_V2_Constants.fstar_refl_sigelt + FStarC_Syntax_Syntax.Lazy_sigelt in + let unembed_sigelt cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Lazy + (FStar_Pervasives.Inl + { FStarC_Syntax_Syntax.blob = b; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_sigelt; + FStarC_Syntax_Syntax.ltyp = uu___; + FStarC_Syntax_Syntax.rng = uu___1;_}, + uu___2) + -> + let uu___3 = FStarC_Dyn.undyn b in + FStar_Pervasives_Native.Some uu___3 + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded sigelt: %s" uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_sigelt unembed_sigelt + FStarC_Reflection_V2_Constants.fstar_refl_sigelt_fv +let (e_string_list : + Prims.string Prims.list FStarC_TypeChecker_NBETerm.embedding) = + FStarC_TypeChecker_NBETerm.e_list FStarC_TypeChecker_NBETerm.e_string +let (e_ctor : + (Prims.string Prims.list * FStarC_Syntax_Syntax.term) + FStarC_TypeChecker_NBETerm.embedding) + = FStarC_TypeChecker_NBETerm.e_tuple2 e_string_list e_term +let (e_lb_view : + FStarC_Reflection_V2_Data.lb_view FStarC_TypeChecker_NBETerm.embedding) = + let embed_lb_view cb lbv = + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed e_fv cb + lbv.FStarC_Reflection_V2_Data.lb_fv in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed e_univ_names cb + lbv.FStarC_Reflection_V2_Data.lb_us in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_TypeChecker_NBETerm.embed e_term cb + lbv.FStarC_Reflection_V2_Data.lb_typ in + FStarC_TypeChecker_NBETerm.as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_TypeChecker_NBETerm.embed e_term cb + lbv.FStarC_Reflection_V2_Data.lb_def in + FStarC_TypeChecker_NBETerm.as_arg uu___8 in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Mk_lb.FStarC_Reflection_V2_Constants.fv + [] uu___ in + let unembed_lb_view cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, + (fv', uu___1)::(us, uu___2)::(typ, uu___3)::(def, uu___4)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Mk_lb.FStarC_Reflection_V2_Constants.lid + -> + let uu___5 = FStarC_TypeChecker_NBETerm.unembed e_fv cb fv' in + FStarC_Compiler_Util.bind_opt uu___5 + (fun fv'1 -> + let uu___6 = + FStarC_TypeChecker_NBETerm.unembed e_univ_names cb us in + FStarC_Compiler_Util.bind_opt uu___6 + (fun us1 -> + let uu___7 = + FStarC_TypeChecker_NBETerm.unembed e_term cb typ in + FStarC_Compiler_Util.bind_opt uu___7 + (fun typ1 -> + let uu___8 = + FStarC_TypeChecker_NBETerm.unembed e_term cb def in + FStarC_Compiler_Util.bind_opt uu___8 + (fun def1 -> + FStar_Pervasives_Native.Some + { + FStarC_Reflection_V2_Data.lb_fv = fv'1; + FStarC_Reflection_V2_Data.lb_us = us1; + FStarC_Reflection_V2_Data.lb_typ = typ1; + FStarC_Reflection_V2_Data.lb_def = def1 + })))) + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded lb_view: %s" uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_lb_view unembed_lb_view + FStarC_Reflection_V2_Constants.fstar_refl_lb_view_fv +let (e_lid : FStarC_Ident.lid FStarC_TypeChecker_NBETerm.embedding) = + let embed rng lid = + let uu___ = FStarC_Ident.path_of_lid lid in + FStarC_TypeChecker_NBETerm.embed e_string_list rng uu___ in + let unembed cb t = + let uu___ = FStarC_TypeChecker_NBETerm.unembed e_string_list cb t in + FStarC_Compiler_Util.map_opt uu___ + (fun p -> + FStarC_Ident.lid_of_path p FStarC_Compiler_Range_Type.dummyRange) in + FStarC_TypeChecker_NBETerm.mk_emb embed unembed + (fun uu___ -> + mkConstruct FStarC_Reflection_V2_Constants.fstar_refl_aqualv_fv [] []) + (fun uu___ -> + fv_as_emb_typ FStarC_Reflection_V2_Constants.fstar_refl_aqualv_fv) +let (e_letbinding : + FStarC_Syntax_Syntax.letbinding FStarC_TypeChecker_NBETerm.embedding) = + let embed_letbinding cb lb = + mk_lazy cb lb FStarC_Reflection_V2_Constants.fstar_refl_letbinding + FStarC_Syntax_Syntax.Lazy_letbinding in + let unembed_letbinding cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Lazy + (FStar_Pervasives.Inl + { FStarC_Syntax_Syntax.blob = lb; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_letbinding; + FStarC_Syntax_Syntax.ltyp = uu___; + FStarC_Syntax_Syntax.rng = uu___1;_}, + uu___2) + -> + let uu___3 = FStarC_Dyn.undyn lb in + FStar_Pervasives_Native.Some uu___3 + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded letbinding: %s" + uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_letbinding unembed_letbinding + FStarC_Reflection_V2_Constants.fstar_refl_letbinding_fv +let (e_sigelt_view : + FStarC_Reflection_V2_Data.sigelt_view FStarC_TypeChecker_NBETerm.embedding) + = + let embed_sigelt_view cb sev = + match sev with + | FStarC_Reflection_V2_Data.Sg_Let (r, lbs) -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed + FStarC_TypeChecker_NBETerm.e_bool cb r in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_list e_letbinding) cb lbs in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + [uu___3] in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Sg_Let.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.Sg_Inductive (nm, univs, bs, t, dcs) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_string_list cb nm in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed e_univ_names cb univs in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = FStarC_TypeChecker_NBETerm.embed e_binders cb bs in + FStarC_TypeChecker_NBETerm.as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = FStarC_TypeChecker_NBETerm.embed e_term cb t in + FStarC_TypeChecker_NBETerm.as_arg uu___8 in + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_list e_ctor) cb dcs in + FStarC_TypeChecker_NBETerm.as_arg uu___10 in + [uu___9] in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Sg_Inductive.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.Sg_Val (nm, univs, t) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_string_list cb nm in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.embed e_univ_names cb univs in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = FStarC_TypeChecker_NBETerm.embed e_term cb t in + FStarC_TypeChecker_NBETerm.as_arg uu___6 in + [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mkConstruct + FStarC_Reflection_V2_Constants.ref_Sg_Val.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.Unk -> + mkConstruct + FStarC_Reflection_V2_Constants.ref_Unk.FStarC_Reflection_V2_Constants.fv + [] [] in + let unembed_sigelt_view cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, + (dcs, uu___1)::(t1, uu___2)::(bs, uu___3)::(us, uu___4)::(nm, + uu___5)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Sg_Inductive.FStarC_Reflection_V2_Constants.lid + -> + let uu___6 = FStarC_TypeChecker_NBETerm.unembed e_string_list cb nm in + FStarC_Compiler_Util.bind_opt uu___6 + (fun nm1 -> + let uu___7 = + FStarC_TypeChecker_NBETerm.unembed e_univ_names cb us in + FStarC_Compiler_Util.bind_opt uu___7 + (fun us1 -> + let uu___8 = + FStarC_TypeChecker_NBETerm.unembed e_binders cb bs in + FStarC_Compiler_Util.bind_opt uu___8 + (fun bs1 -> + let uu___9 = + FStarC_TypeChecker_NBETerm.unembed e_term cb t1 in + FStarC_Compiler_Util.bind_opt uu___9 + (fun t2 -> + let uu___10 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_list e_ctor) cb + dcs in + FStarC_Compiler_Util.bind_opt uu___10 + (fun dcs1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.Sg_Inductive + (nm1, us1, bs1, t2, dcs1))))))) + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, (lbs, uu___1)::(r, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Sg_Let.FStarC_Reflection_V2_Constants.lid + -> + let uu___3 = + FStarC_TypeChecker_NBETerm.unembed + FStarC_TypeChecker_NBETerm.e_bool cb r in + FStarC_Compiler_Util.bind_opt uu___3 + (fun r1 -> + let uu___4 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_list e_letbinding) cb lbs in + FStarC_Compiler_Util.bind_opt uu___4 + (fun lbs1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.Sg_Let (r1, lbs1)))) + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___, (t1, uu___1)::(us, uu___2)::(nm, uu___3)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Sg_Val.FStarC_Reflection_V2_Constants.lid + -> + let uu___4 = FStarC_TypeChecker_NBETerm.unembed e_string_list cb nm in + FStarC_Compiler_Util.bind_opt uu___4 + (fun nm1 -> + let uu___5 = + FStarC_TypeChecker_NBETerm.unembed e_univ_names cb us in + FStarC_Compiler_Util.bind_opt uu___5 + (fun us1 -> + let uu___6 = + FStarC_TypeChecker_NBETerm.unembed e_term cb t1 in + FStarC_Compiler_Util.bind_opt uu___6 + (fun t2 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.Sg_Val (nm1, us1, t2))))) + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_Unk.FStarC_Reflection_V2_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V2_Data.Unk + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded sigelt_view: %s" + uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb' embed_sigelt_view unembed_sigelt_view + FStarC_Reflection_V2_Constants.fstar_refl_sigelt_view_fv +let (e_name : + FStarC_Reflection_V2_Data.name FStarC_TypeChecker_NBETerm.embedding) = + FStarC_TypeChecker_NBETerm.e_list FStarC_TypeChecker_NBETerm.e_string +let (e_qualifier : + FStarC_Reflection_V2_Data.qualifier FStarC_TypeChecker_NBETerm.embedding) = + let embed cb q = + match q with + | FStarC_Reflection_V2_Data.Assumption -> + mkConstruct + FStarC_Reflection_V2_Constants.ref_qual_Assumption.FStarC_Reflection_V2_Constants.fv + [] [] + | FStarC_Reflection_V2_Data.New -> + mkConstruct + FStarC_Reflection_V2_Constants.ref_qual_New.FStarC_Reflection_V2_Constants.fv + [] [] + | FStarC_Reflection_V2_Data.Private -> + mkConstruct + FStarC_Reflection_V2_Constants.ref_qual_Private.FStarC_Reflection_V2_Constants.fv + [] [] + | FStarC_Reflection_V2_Data.Unfold_for_unification_and_vcgen -> + mkConstruct + FStarC_Reflection_V2_Constants.ref_qual_Unfold_for_unification_and_vcgen.FStarC_Reflection_V2_Constants.fv + [] [] + | FStarC_Reflection_V2_Data.Visible_default -> + mkConstruct + FStarC_Reflection_V2_Constants.ref_qual_Visible_default.FStarC_Reflection_V2_Constants.fv + [] [] + | FStarC_Reflection_V2_Data.Irreducible -> + mkConstruct + FStarC_Reflection_V2_Constants.ref_qual_Irreducible.FStarC_Reflection_V2_Constants.fv + [] [] + | FStarC_Reflection_V2_Data.Inline_for_extraction -> + mkConstruct + FStarC_Reflection_V2_Constants.ref_qual_Inline_for_extraction.FStarC_Reflection_V2_Constants.fv + [] [] + | FStarC_Reflection_V2_Data.NoExtract -> + mkConstruct + FStarC_Reflection_V2_Constants.ref_qual_NoExtract.FStarC_Reflection_V2_Constants.fv + [] [] + | FStarC_Reflection_V2_Data.Noeq -> + mkConstruct + FStarC_Reflection_V2_Constants.ref_qual_Noeq.FStarC_Reflection_V2_Constants.fv + [] [] + | FStarC_Reflection_V2_Data.Unopteq -> + mkConstruct + FStarC_Reflection_V2_Constants.ref_qual_Unopteq.FStarC_Reflection_V2_Constants.fv + [] [] + | FStarC_Reflection_V2_Data.TotalEffect -> + mkConstruct + FStarC_Reflection_V2_Constants.ref_qual_TotalEffect.FStarC_Reflection_V2_Constants.fv + [] [] + | FStarC_Reflection_V2_Data.Logic -> + mkConstruct + FStarC_Reflection_V2_Constants.ref_qual_Logic.FStarC_Reflection_V2_Constants.fv + [] [] + | FStarC_Reflection_V2_Data.Reifiable -> + mkConstruct + FStarC_Reflection_V2_Constants.ref_qual_Reifiable.FStarC_Reflection_V2_Constants.fv + [] [] + | FStarC_Reflection_V2_Data.ExceptionConstructor -> + mkConstruct + FStarC_Reflection_V2_Constants.ref_qual_ExceptionConstructor.FStarC_Reflection_V2_Constants.fv + [] [] + | FStarC_Reflection_V2_Data.HasMaskedEffect -> + mkConstruct + FStarC_Reflection_V2_Constants.ref_qual_HasMaskedEffect.FStarC_Reflection_V2_Constants.fv + [] [] + | FStarC_Reflection_V2_Data.Effect -> + mkConstruct + FStarC_Reflection_V2_Constants.ref_qual_Effect.FStarC_Reflection_V2_Constants.fv + [] [] + | FStarC_Reflection_V2_Data.OnlyName -> + mkConstruct + FStarC_Reflection_V2_Constants.ref_qual_OnlyName.FStarC_Reflection_V2_Constants.fv + [] [] + | FStarC_Reflection_V2_Data.Reflectable l -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_name cb l in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V2_Constants.ref_qual_Reflectable.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.Discriminator l -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_name cb l in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V2_Constants.ref_qual_Discriminator.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.Action l -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.embed e_name cb l in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V2_Constants.ref_qual_Action.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.Projector li -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_tuple2 e_name e_ident) cb li in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V2_Constants.ref_qual_Projector.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.RecordType ids12 -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_tuple2 + (FStarC_TypeChecker_NBETerm.e_list e_ident) + (FStarC_TypeChecker_NBETerm.e_list e_ident)) cb ids12 in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V2_Constants.ref_qual_RecordType.FStarC_Reflection_V2_Constants.fv + [] uu___ + | FStarC_Reflection_V2_Data.RecordConstructor ids12 -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_tuple2 + (FStarC_TypeChecker_NBETerm.e_list e_ident) + (FStarC_TypeChecker_NBETerm.e_list e_ident)) cb ids12 in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct + FStarC_Reflection_V2_Constants.ref_qual_RecordConstructor.FStarC_Reflection_V2_Constants.fv + [] uu___ in + let unembed cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_Assumption.FStarC_Reflection_V2_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V2_Data.Assumption + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_New.FStarC_Reflection_V2_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V2_Data.New + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_Private.FStarC_Reflection_V2_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V2_Data.Private + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_Unfold_for_unification_and_vcgen.FStarC_Reflection_V2_Constants.lid + -> + FStar_Pervasives_Native.Some + FStarC_Reflection_V2_Data.Unfold_for_unification_and_vcgen + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_Visible_default.FStarC_Reflection_V2_Constants.lid + -> + FStar_Pervasives_Native.Some + FStarC_Reflection_V2_Data.Visible_default + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_Irreducible.FStarC_Reflection_V2_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V2_Data.Irreducible + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_Inline_for_extraction.FStarC_Reflection_V2_Constants.lid + -> + FStar_Pervasives_Native.Some + FStarC_Reflection_V2_Data.Inline_for_extraction + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_NoExtract.FStarC_Reflection_V2_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V2_Data.NoExtract + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_Noeq.FStarC_Reflection_V2_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V2_Data.Noeq + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_Unopteq.FStarC_Reflection_V2_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V2_Data.Unopteq + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_TotalEffect.FStarC_Reflection_V2_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V2_Data.TotalEffect + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_Logic.FStarC_Reflection_V2_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V2_Data.Logic + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_Reifiable.FStarC_Reflection_V2_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V2_Data.Reifiable + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_ExceptionConstructor.FStarC_Reflection_V2_Constants.lid + -> + FStar_Pervasives_Native.Some + FStarC_Reflection_V2_Data.ExceptionConstructor + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_HasMaskedEffect.FStarC_Reflection_V2_Constants.lid + -> + FStar_Pervasives_Native.Some + FStarC_Reflection_V2_Data.HasMaskedEffect + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_Effect.FStarC_Reflection_V2_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V2_Data.Effect + | FStarC_TypeChecker_NBETerm.Construct (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_OnlyName.FStarC_Reflection_V2_Constants.lid + -> FStar_Pervasives_Native.Some FStarC_Reflection_V2_Data.OnlyName + | FStarC_TypeChecker_NBETerm.Construct (fv, [], (l, uu___)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_Reflectable.FStarC_Reflection_V2_Constants.lid + -> + let uu___1 = FStarC_TypeChecker_NBETerm.unembed e_name cb l in + FStarC_Compiler_Util.bind_opt uu___1 + (fun l1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.Reflectable l1)) + | FStarC_TypeChecker_NBETerm.Construct (fv, [], (l, uu___)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_Discriminator.FStarC_Reflection_V2_Constants.lid + -> + let uu___1 = FStarC_TypeChecker_NBETerm.unembed e_name cb l in + FStarC_Compiler_Util.bind_opt uu___1 + (fun l1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.Discriminator l1)) + | FStarC_TypeChecker_NBETerm.Construct (fv, [], (l, uu___)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_Action.FStarC_Reflection_V2_Constants.lid + -> + let uu___1 = FStarC_TypeChecker_NBETerm.unembed e_name cb l in + FStarC_Compiler_Util.bind_opt uu___1 + (fun l1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.Action l1)) + | FStarC_TypeChecker_NBETerm.Construct (fv, [], (li, uu___)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_Projector.FStarC_Reflection_V2_Constants.lid + -> + let uu___1 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_tuple2 e_name e_ident) cb li in + FStarC_Compiler_Util.bind_opt uu___1 + (fun li1 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.Projector li1)) + | FStarC_TypeChecker_NBETerm.Construct (fv, [], (ids12, uu___)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_RecordType.FStarC_Reflection_V2_Constants.lid + -> + let uu___1 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_tuple2 + (FStarC_TypeChecker_NBETerm.e_list e_ident) + (FStarC_TypeChecker_NBETerm.e_list e_ident)) cb ids12 in + FStarC_Compiler_Util.bind_opt uu___1 + (fun ids121 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.RecordType ids121)) + | FStarC_TypeChecker_NBETerm.Construct (fv, [], (ids12, uu___)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Reflection_V2_Constants.ref_qual_RecordConstructor.FStarC_Reflection_V2_Constants.lid + -> + let uu___1 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_tuple2 + (FStarC_TypeChecker_NBETerm.e_list e_ident) + (FStarC_TypeChecker_NBETerm.e_list e_ident)) cb ids12 in + FStarC_Compiler_Util.bind_opt uu___1 + (fun ids121 -> + FStar_Pervasives_Native.Some + (FStarC_Reflection_V2_Data.RecordConstructor ids121)) + | uu___ -> + ((let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded qualifier: %s" + uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + FStarC_TypeChecker_NBETerm.mk_emb embed unembed + (fun uu___ -> + mkConstruct FStarC_Reflection_V2_Constants.fstar_refl_qualifier_fv [] + []) + (fun uu___ -> + fv_as_emb_typ FStarC_Reflection_V2_Constants.fstar_refl_qualifier_fv) +let (e_qualifiers : + FStarC_Reflection_V2_Data.qualifier Prims.list + FStarC_TypeChecker_NBETerm.embedding) + = FStarC_TypeChecker_NBETerm.e_list e_qualifier +let (e_vconfig : + FStarC_Compiler_Order.order FStarC_TypeChecker_NBETerm.embedding) = + let emb cb o = failwith "emb vconfig NBE" in + let unemb cb t = failwith "unemb vconfig NBE" in + let uu___ = + FStarC_Syntax_Syntax.lid_as_fv FStarC_Parser_Const.vconfig_lid + FStar_Pervasives_Native.None in + mk_emb' emb unemb uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_SMTEncoding_Encode.ml b/ocaml/fstar-lib/generated/FStarC_SMTEncoding_Encode.ml new file mode 100644 index 00000000000..92a739589bc --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_SMTEncoding_Encode.ml @@ -0,0 +1,7982 @@ +open Prims +type encoding_depth = (Prims.int * Prims.int) +let (dbg_SMTEncoding : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "SMTEncoding" +let (dbg_SMTQuery : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "SMTQuery" +let (dbg_Time : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Time" +let (norm_before_encoding : + FStarC_SMTEncoding_Env.env_t -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun env -> + fun t -> + let steps = + [FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.Simplify; + FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.AllowUnboundUniverses; + FStarC_TypeChecker_Env.EraseUniverses; + FStarC_TypeChecker_Env.Exclude FStarC_TypeChecker_Env.Zeta] in + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_Env.current_module + env.FStarC_SMTEncoding_Env.tcenv in + FStarC_Ident.string_of_lid uu___2 in + FStar_Pervasives_Native.Some uu___1 in + FStarC_Profiling.profile + (fun uu___1 -> + FStarC_TypeChecker_Normalize.normalize steps + env.FStarC_SMTEncoding_Env.tcenv t) uu___ + "FStarC.SMTEncoding.Encode.norm_before_encoding" +let (norm_before_encoding_us : + FStarC_SMTEncoding_Env.env_t -> + FStarC_Syntax_Syntax.univ_names -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun env -> + fun us -> + fun t -> + let env_u = + let uu___ = + FStarC_TypeChecker_Env.push_univ_vars + env.FStarC_SMTEncoding_Env.tcenv us in + { + FStarC_SMTEncoding_Env.bvar_bindings = + (env.FStarC_SMTEncoding_Env.bvar_bindings); + FStarC_SMTEncoding_Env.fvar_bindings = + (env.FStarC_SMTEncoding_Env.fvar_bindings); + FStarC_SMTEncoding_Env.depth = (env.FStarC_SMTEncoding_Env.depth); + FStarC_SMTEncoding_Env.tcenv = uu___; + FStarC_SMTEncoding_Env.warn = (env.FStarC_SMTEncoding_Env.warn); + FStarC_SMTEncoding_Env.nolabels = + (env.FStarC_SMTEncoding_Env.nolabels); + FStarC_SMTEncoding_Env.use_zfuel_name = + (env.FStarC_SMTEncoding_Env.use_zfuel_name); + FStarC_SMTEncoding_Env.encode_non_total_function_typ = + (env.FStarC_SMTEncoding_Env.encode_non_total_function_typ); + FStarC_SMTEncoding_Env.current_module_name = + (env.FStarC_SMTEncoding_Env.current_module_name); + FStarC_SMTEncoding_Env.encoding_quantifier = + (env.FStarC_SMTEncoding_Env.encoding_quantifier); + FStarC_SMTEncoding_Env.global_cache = + (env.FStarC_SMTEncoding_Env.global_cache) + } in + let uu___ = FStarC_Syntax_Subst.open_univ_vars us t in + match uu___ with + | (us1, t1) -> + let t2 = norm_before_encoding env_u t1 in + FStarC_Syntax_Subst.close_univ_vars us1 t2 +let (norm_with_steps : + FStarC_TypeChecker_Env.steps -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun steps -> + fun env -> + fun t -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_Env.current_module env in + FStarC_Ident.string_of_lid uu___2 in + FStar_Pervasives_Native.Some uu___1 in + FStarC_Profiling.profile + (fun uu___1 -> FStarC_TypeChecker_Normalize.normalize steps env t) + uu___ "FStarC.SMTEncoding.Encode.norm" +type prims_t = + { + mk: + FStarC_Ident.lident -> + Prims.string -> + (FStarC_SMTEncoding_Term.term * Prims.int * + FStarC_SMTEncoding_Term.decl Prims.list) + ; + is: FStarC_Ident.lident -> Prims.bool } +let (__proj__Mkprims_t__item__mk : + prims_t -> + FStarC_Ident.lident -> + Prims.string -> + (FStarC_SMTEncoding_Term.term * Prims.int * + FStarC_SMTEncoding_Term.decl Prims.list)) + = fun projectee -> match projectee with | { mk; is;_} -> mk +let (__proj__Mkprims_t__item__is : + prims_t -> FStarC_Ident.lident -> Prims.bool) = + fun projectee -> match projectee with | { mk; is;_} -> is +type defn_rel_type = + | Eq + | ValidIff +let (uu___is_Eq : defn_rel_type -> Prims.bool) = + fun projectee -> match projectee with | Eq -> true | uu___ -> false +let (uu___is_ValidIff : defn_rel_type -> Prims.bool) = + fun projectee -> match projectee with | ValidIff -> true | uu___ -> false +let (rel_type_f : + defn_rel_type -> + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = + fun uu___ -> + match uu___ with + | Eq -> FStarC_SMTEncoding_Util.mkEq + | ValidIff -> + (fun uu___1 -> + match uu___1 with + | (x, y) -> + let uu___2 = + let uu___3 = FStarC_SMTEncoding_Term.mk_Valid x in + (uu___3, y) in + FStarC_SMTEncoding_Util.mkEq uu___2) +let (prims : prims_t) = + let module_name = "Prims" in + let uu___ = + FStarC_SMTEncoding_Env.fresh_fvar module_name "a" + FStarC_SMTEncoding_Term.Term_sort in + match uu___ with + | (asym, a) -> + let uu___1 = + FStarC_SMTEncoding_Env.fresh_fvar module_name "x" + FStarC_SMTEncoding_Term.Term_sort in + (match uu___1 with + | (xsym, x) -> + let uu___2 = + FStarC_SMTEncoding_Env.fresh_fvar module_name "y" + FStarC_SMTEncoding_Term.Term_sort in + (match uu___2 with + | (ysym, y) -> + let quant_with_pre rel vars precondition body rng x1 = + let xname_decl = + let uu___3 = + let uu___4 = + FStarC_Compiler_List.map + FStarC_SMTEncoding_Term.fv_sort vars in + (x1, uu___4, FStarC_SMTEncoding_Term.Term_sort, + FStar_Pervasives_Native.None) in + FStarC_SMTEncoding_Term.DeclFun uu___3 in + let xtok = Prims.strcat x1 "@tok" in + let xtok_decl = + FStarC_SMTEncoding_Term.DeclFun + (xtok, [], FStarC_SMTEncoding_Term.Term_sort, + FStar_Pervasives_Native.None) in + let xapp = + let uu___3 = + let uu___4 = + FStarC_Compiler_List.map + FStarC_SMTEncoding_Util.mkFreeV vars in + (x1, uu___4) in + FStarC_SMTEncoding_Util.mkApp uu___3 in + let xtok1 = FStarC_SMTEncoding_Util.mkApp (xtok, []) in + let xtok_app = + FStarC_SMTEncoding_EncodeTerm.mk_Apply xtok1 vars in + let tot_fun_axioms = + let all_vars_but_one = + FStar_Pervasives_Native.fst + (FStarC_Compiler_Util.prefix vars) in + let axiom_name = Prims.strcat "primitive_tot_fun_" x1 in + let tot_fun_axiom_for_x = + let uu___3 = + let uu___4 = + FStarC_SMTEncoding_Term.mk_IsTotFun xtok1 in + (uu___4, FStar_Pervasives_Native.None, axiom_name) in + FStarC_SMTEncoding_Util.mkAssume uu___3 in + let uu___3 = + FStarC_Compiler_List.fold_left + (fun uu___4 -> + fun var -> + match uu___4 with + | (axioms, app, vars1) -> + let app1 = + FStarC_SMTEncoding_EncodeTerm.mk_Apply app + [var] in + let vars2 = + FStarC_Compiler_List.op_At vars1 [var] in + let axiom_name1 = + Prims.strcat axiom_name + (Prims.strcat "." + (Prims.string_of_int + (FStarC_Compiler_List.length vars2))) in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_SMTEncoding_Term.mk_IsTotFun + app1 in + ([[app1]], vars2, uu___11) in + FStarC_SMTEncoding_Term.mkForall + rng uu___10 in + (uu___9, + FStar_Pervasives_Native.None, + axiom_name1) in + FStarC_SMTEncoding_Util.mkAssume + uu___8 in + [uu___7] in + FStarC_Compiler_List.op_At axioms uu___6 in + (uu___5, app1, vars2)) + ([tot_fun_axiom_for_x], xtok1, []) all_vars_but_one in + match uu___3 with | (axioms, uu___4, uu___5) -> axioms in + let rel_body = + let rel_body1 = rel_type_f rel (xapp, body) in + match precondition with + | FStar_Pervasives_Native.None -> rel_body1 + | FStar_Pervasives_Native.Some pre -> + FStarC_SMTEncoding_Util.mkImp (pre, rel_body1) in + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_SMTEncoding_Term.mkForall rng + ([[xapp]], vars, rel_body) in + (uu___9, FStar_Pervasives_Native.None, + (Prims.strcat "primitive_" x1)) in + FStarC_SMTEncoding_Util.mkAssume uu___8 in + [uu___7] in + xtok_decl :: uu___6 in + xname_decl :: uu___5 in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_SMTEncoding_Util.mkEq + (xtok_app, xapp) in + ([[xtok_app]], vars, uu___11) in + FStarC_SMTEncoding_Term.mkForall rng uu___10 in + (uu___9, + (FStar_Pervasives_Native.Some + "Name-token correspondence"), + (Prims.strcat "token_correspondence_" x1)) in + FStarC_SMTEncoding_Util.mkAssume uu___8 in + [uu___7] in + FStarC_Compiler_List.op_At tot_fun_axioms uu___6 in + FStarC_Compiler_List.op_At uu___4 uu___5 in + (xtok1, (FStarC_Compiler_List.length vars), uu___3) in + let quant rel vars body = + quant_with_pre rel vars FStar_Pervasives_Native.None body in + let axy = + FStarC_Compiler_List.map FStarC_SMTEncoding_Term.mk_fv + [(asym, FStarC_SMTEncoding_Term.Term_sort); + (xsym, FStarC_SMTEncoding_Term.Term_sort); + (ysym, FStarC_SMTEncoding_Term.Term_sort)] in + let xy = + FStarC_Compiler_List.map FStarC_SMTEncoding_Term.mk_fv + [(xsym, FStarC_SMTEncoding_Term.Term_sort); + (ysym, FStarC_SMTEncoding_Term.Term_sort)] in + let qx = + FStarC_Compiler_List.map FStarC_SMTEncoding_Term.mk_fv + [(xsym, FStarC_SMTEncoding_Term.Term_sort)] in + let prims1 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = FStarC_SMTEncoding_Util.mkEq (x, y) in + FStarC_SMTEncoding_Term.boxBool uu___6 in + quant Eq axy uu___5 in + (FStarC_Parser_Const.op_Eq, uu___4) in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = FStarC_SMTEncoding_Util.mkEq (x, y) in + FStarC_SMTEncoding_Util.mkNot uu___9 in + FStarC_SMTEncoding_Term.boxBool uu___8 in + quant Eq axy uu___7 in + (FStarC_Parser_Const.op_notEq, uu___6) in + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_SMTEncoding_Term.unboxBool x in + let uu___13 = + FStarC_SMTEncoding_Term.unboxBool y in + (uu___12, uu___13) in + FStarC_SMTEncoding_Util.mkAnd uu___11 in + FStarC_SMTEncoding_Term.boxBool uu___10 in + quant Eq xy uu___9 in + (FStarC_Parser_Const.op_And, uu___8) in + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_SMTEncoding_Term.unboxBool x in + let uu___15 = + FStarC_SMTEncoding_Term.unboxBool y in + (uu___14, uu___15) in + FStarC_SMTEncoding_Util.mkOr uu___13 in + FStarC_SMTEncoding_Term.boxBool uu___12 in + quant Eq xy uu___11 in + (FStarC_Parser_Const.op_Or, uu___10) in + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + FStarC_SMTEncoding_Term.unboxBool x in + FStarC_SMTEncoding_Util.mkNot uu___15 in + FStarC_SMTEncoding_Term.boxBool uu___14 in + quant Eq qx uu___13 in + (FStarC_Parser_Const.op_Negation, uu___12) in + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = + let uu___17 = + let uu___18 = + FStarC_SMTEncoding_Term.unboxInt x in + let uu___19 = + FStarC_SMTEncoding_Term.unboxInt y in + (uu___18, uu___19) in + FStarC_SMTEncoding_Util.mkLT uu___17 in + FStarC_SMTEncoding_Term.boxBool uu___16 in + quant Eq xy uu___15 in + (FStarC_Parser_Const.op_LT, uu___14) in + let uu___14 = + let uu___15 = + let uu___16 = + let uu___17 = + let uu___18 = + let uu___19 = + let uu___20 = + FStarC_SMTEncoding_Term.unboxInt x in + let uu___21 = + FStarC_SMTEncoding_Term.unboxInt y in + (uu___20, uu___21) in + FStarC_SMTEncoding_Util.mkLTE uu___19 in + FStarC_SMTEncoding_Term.boxBool uu___18 in + quant Eq xy uu___17 in + (FStarC_Parser_Const.op_LTE, uu___16) in + let uu___16 = + let uu___17 = + let uu___18 = + let uu___19 = + let uu___20 = + let uu___21 = + let uu___22 = + FStarC_SMTEncoding_Term.unboxInt + x in + let uu___23 = + FStarC_SMTEncoding_Term.unboxInt + y in + (uu___22, uu___23) in + FStarC_SMTEncoding_Util.mkGT uu___21 in + FStarC_SMTEncoding_Term.boxBool uu___20 in + quant Eq xy uu___19 in + (FStarC_Parser_Const.op_GT, uu___18) in + let uu___18 = + let uu___19 = + let uu___20 = + let uu___21 = + let uu___22 = + let uu___23 = + let uu___24 = + FStarC_SMTEncoding_Term.unboxInt + x in + let uu___25 = + FStarC_SMTEncoding_Term.unboxInt + y in + (uu___24, uu___25) in + FStarC_SMTEncoding_Util.mkGTE + uu___23 in + FStarC_SMTEncoding_Term.boxBool + uu___22 in + quant Eq xy uu___21 in + (FStarC_Parser_Const.op_GTE, uu___20) in + let uu___20 = + let uu___21 = + let uu___22 = + let uu___23 = + let uu___24 = + let uu___25 = + let uu___26 = + FStarC_SMTEncoding_Term.unboxInt + x in + let uu___27 = + FStarC_SMTEncoding_Term.unboxInt + y in + (uu___26, uu___27) in + FStarC_SMTEncoding_Util.mkSub + uu___25 in + FStarC_SMTEncoding_Term.boxInt + uu___24 in + quant Eq xy uu___23 in + (FStarC_Parser_Const.op_Subtraction, + uu___22) in + let uu___22 = + let uu___23 = + let uu___24 = + let uu___25 = + let uu___26 = + let uu___27 = + FStarC_SMTEncoding_Term.unboxInt + x in + FStarC_SMTEncoding_Util.mkMinus + uu___27 in + FStarC_SMTEncoding_Term.boxInt + uu___26 in + quant Eq qx uu___25 in + (FStarC_Parser_Const.op_Minus, + uu___24) in + let uu___24 = + let uu___25 = + let uu___26 = + let uu___27 = + let uu___28 = + let uu___29 = + let uu___30 = + FStarC_SMTEncoding_Term.unboxInt + x in + let uu___31 = + FStarC_SMTEncoding_Term.unboxInt + y in + (uu___30, uu___31) in + FStarC_SMTEncoding_Util.mkAdd + uu___29 in + FStarC_SMTEncoding_Term.boxInt + uu___28 in + quant Eq xy uu___27 in + (FStarC_Parser_Const.op_Addition, + uu___26) in + let uu___26 = + let uu___27 = + let uu___28 = + let uu___29 = + let uu___30 = + let uu___31 = + let uu___32 = + FStarC_SMTEncoding_Term.unboxInt + x in + let uu___33 = + FStarC_SMTEncoding_Term.unboxInt + y in + (uu___32, uu___33) in + FStarC_SMTEncoding_Util.mkMul + uu___31 in + FStarC_SMTEncoding_Term.boxInt + uu___30 in + quant Eq xy uu___29 in + (FStarC_Parser_Const.op_Multiply, + uu___28) in + let uu___28 = + let uu___29 = + let uu___30 = + let uu___31 = + let uu___32 = + let uu___33 = + let uu___34 = + let uu___35 = + FStarC_SMTEncoding_Term.unboxInt + y in + let uu___36 = + FStarC_SMTEncoding_Util.mkInteger + "0" in + (uu___35, uu___36) in + FStarC_SMTEncoding_Util.mkEq + uu___34 in + FStarC_SMTEncoding_Util.mkNot + uu___33 in + FStar_Pervasives_Native.Some + uu___32 in + let uu___32 = + let uu___33 = + let uu___34 = + let uu___35 = + FStarC_SMTEncoding_Term.unboxInt + x in + let uu___36 = + FStarC_SMTEncoding_Term.unboxInt + y in + (uu___35, uu___36) in + FStarC_SMTEncoding_Util.mkDiv + uu___34 in + FStarC_SMTEncoding_Term.boxInt + uu___33 in + quant_with_pre Eq xy uu___31 + uu___32 in + (FStarC_Parser_Const.op_Division, + uu___30) in + let uu___30 = + let uu___31 = + let uu___32 = + let uu___33 = + let uu___34 = + let uu___35 = + let uu___36 = + let uu___37 = + FStarC_SMTEncoding_Term.unboxInt + y in + let uu___38 = + FStarC_SMTEncoding_Util.mkInteger + "0" in + (uu___37, uu___38) in + FStarC_SMTEncoding_Util.mkEq + uu___36 in + FStarC_SMTEncoding_Util.mkNot + uu___35 in + FStar_Pervasives_Native.Some + uu___34 in + let uu___34 = + let uu___35 = + let uu___36 = + let uu___37 = + FStarC_SMTEncoding_Term.unboxInt + x in + let uu___38 = + FStarC_SMTEncoding_Term.unboxInt + y in + (uu___37, uu___38) in + FStarC_SMTEncoding_Util.mkMod + uu___36 in + FStarC_SMTEncoding_Term.boxInt + uu___35 in + quant_with_pre Eq xy + uu___33 uu___34 in + (FStarC_Parser_Const.op_Modulus, + uu___32) in + let uu___32 = + let uu___33 = + let uu___34 = + let uu___35 = + let uu___36 = + let uu___37 = + FStarC_SMTEncoding_Term.unboxReal + x in + let uu___38 = + FStarC_SMTEncoding_Term.unboxReal + y in + (uu___37, uu___38) in + FStarC_SMTEncoding_Util.mkLT + uu___36 in + quant ValidIff xy uu___35 in + (FStarC_Parser_Const.real_op_LT, + uu___34) in + let uu___34 = + let uu___35 = + let uu___36 = + let uu___37 = + let uu___38 = + let uu___39 = + FStarC_SMTEncoding_Term.unboxReal + x in + let uu___40 = + FStarC_SMTEncoding_Term.unboxReal + y in + (uu___39, uu___40) in + FStarC_SMTEncoding_Util.mkLTE + uu___38 in + quant ValidIff xy + uu___37 in + (FStarC_Parser_Const.real_op_LTE, + uu___36) in + let uu___36 = + let uu___37 = + let uu___38 = + let uu___39 = + let uu___40 = + let uu___41 = + FStarC_SMTEncoding_Term.unboxReal + x in + let uu___42 = + FStarC_SMTEncoding_Term.unboxReal + y in + (uu___41, + uu___42) in + FStarC_SMTEncoding_Util.mkGT + uu___40 in + quant ValidIff xy + uu___39 in + (FStarC_Parser_Const.real_op_GT, + uu___38) in + let uu___38 = + let uu___39 = + let uu___40 = + let uu___41 = + let uu___42 = + let uu___43 = + FStarC_SMTEncoding_Term.unboxReal + x in + let uu___44 = + FStarC_SMTEncoding_Term.unboxReal + y in + (uu___43, + uu___44) in + FStarC_SMTEncoding_Util.mkGTE + uu___42 in + quant ValidIff xy + uu___41 in + (FStarC_Parser_Const.real_op_GTE, + uu___40) in + let uu___40 = + let uu___41 = + let uu___42 = + let uu___43 = + let uu___44 = + let uu___45 = + let uu___46 + = + FStarC_SMTEncoding_Term.unboxReal + x in + let uu___47 + = + FStarC_SMTEncoding_Term.unboxReal + y in + (uu___46, + uu___47) in + FStarC_SMTEncoding_Util.mkSub + uu___45 in + FStarC_SMTEncoding_Term.boxReal + uu___44 in + quant Eq xy + uu___43 in + (FStarC_Parser_Const.real_op_Subtraction, + uu___42) in + let uu___42 = + let uu___43 = + let uu___44 = + let uu___45 = + let uu___46 = + let uu___47 + = + let uu___48 + = + FStarC_SMTEncoding_Term.unboxReal + x in + let uu___49 + = + FStarC_SMTEncoding_Term.unboxReal + y in + (uu___48, + uu___49) in + FStarC_SMTEncoding_Util.mkAdd + uu___47 in + FStarC_SMTEncoding_Term.boxReal + uu___46 in + quant Eq xy + uu___45 in + (FStarC_Parser_Const.real_op_Addition, + uu___44) in + let uu___44 = + let uu___45 = + let uu___46 = + let uu___47 = + let uu___48 + = + let uu___49 + = + let uu___50 + = + FStarC_SMTEncoding_Term.unboxReal + x in + let uu___51 + = + FStarC_SMTEncoding_Term.unboxReal + y in + (uu___50, + uu___51) in + FStarC_SMTEncoding_Util.mkMul + uu___49 in + FStarC_SMTEncoding_Term.boxReal + uu___48 in + quant Eq xy + uu___47 in + (FStarC_Parser_Const.real_op_Multiply, + uu___46) in + let uu___46 = + let uu___47 = + let uu___48 = + let uu___49 + = + let uu___50 + = + let uu___51 + = + let uu___52 + = + let uu___53 + = + FStarC_SMTEncoding_Term.unboxReal + y in + let uu___54 + = + FStarC_SMTEncoding_Util.mkReal + "0" in + (uu___53, + uu___54) in + FStarC_SMTEncoding_Util.mkEq + uu___52 in + FStarC_SMTEncoding_Util.mkNot + uu___51 in + FStar_Pervasives_Native.Some + uu___50 in + let uu___50 + = + let uu___51 + = + let uu___52 + = + let uu___53 + = + FStarC_SMTEncoding_Term.unboxReal + x in + let uu___54 + = + FStarC_SMTEncoding_Term.unboxReal + y in + (uu___53, + uu___54) in + FStarC_SMTEncoding_Util.mkRealDiv + uu___52 in + FStarC_SMTEncoding_Term.boxReal + uu___51 in + quant_with_pre + Eq xy + uu___49 + uu___50 in + (FStarC_Parser_Const.real_op_Division, + uu___48) in + let uu___48 = + let uu___49 = + let uu___50 + = + let uu___51 + = + let uu___52 + = + let uu___53 + = + FStarC_SMTEncoding_Term.unboxInt + x in + FStarC_SMTEncoding_Term.mkRealOfInt + uu___53 + FStarC_Compiler_Range_Type.dummyRange in + FStarC_SMTEncoding_Term.boxReal + uu___52 in + quant Eq + qx + uu___51 in + (FStarC_Parser_Const.real_of_int, + uu___50) in + [uu___49] in + uu___47 :: + uu___48 in + uu___45 :: + uu___46 in + uu___43 :: uu___44 in + uu___41 :: uu___42 in + uu___39 :: uu___40 in + uu___37 :: uu___38 in + uu___35 :: uu___36 in + uu___33 :: uu___34 in + uu___31 :: uu___32 in + uu___29 :: uu___30 in + uu___27 :: uu___28 in + uu___25 :: uu___26 in + uu___23 :: uu___24 in + uu___21 :: uu___22 in + uu___19 :: uu___20 in + uu___17 :: uu___18 in + uu___15 :: uu___16 in + uu___13 :: uu___14 in + uu___11 :: uu___12 in + uu___9 :: uu___10 in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + let mk l v = + let uu___3 = + let uu___4 = + FStarC_Compiler_List.find + (fun uu___5 -> + match uu___5 with + | (l', uu___6) -> FStarC_Ident.lid_equals l l') + prims1 in + FStarC_Compiler_Option.map + (fun uu___5 -> + match uu___5 with + | (uu___6, b) -> + let uu___7 = FStarC_Ident.range_of_lid l in + b uu___7 v) uu___4 in + FStarC_Compiler_Option.get uu___3 in + let is l = + FStarC_Compiler_Util.for_some + (fun uu___3 -> + match uu___3 with + | (l', uu___4) -> FStarC_Ident.lid_equals l l') prims1 in + { mk; is })) +let (pretype_axiom : + Prims.bool -> + FStarC_Compiler_Range_Type.range -> + FStarC_SMTEncoding_Env.env_t -> + FStarC_SMTEncoding_Term.term -> + FStarC_SMTEncoding_Term.fv Prims.list -> + FStarC_SMTEncoding_Term.decl) + = + fun term_constr_eq -> + fun rng -> + fun env -> + fun tapp -> + fun vars -> + let uu___ = + FStarC_SMTEncoding_Env.fresh_fvar + env.FStarC_SMTEncoding_Env.current_module_name "x" + FStarC_SMTEncoding_Term.Term_sort in + match uu___ with + | (xxsym, xx) -> + let uu___1 = + FStarC_SMTEncoding_Env.fresh_fvar + env.FStarC_SMTEncoding_Env.current_module_name "f" + FStarC_SMTEncoding_Term.Fuel_sort in + (match uu___1 with + | (ffsym, ff) -> + let xx_has_type = + FStarC_SMTEncoding_Term.mk_HasTypeFuel ff xx tapp in + let tapp_hash = + FStarC_SMTEncoding_Term.hash_of_term tapp in + let module_name = + env.FStarC_SMTEncoding_Env.current_module_name in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_SMTEncoding_Term.mk_fv + (xxsym, FStarC_SMTEncoding_Term.Term_sort) in + let uu___7 = + let uu___8 = + FStarC_SMTEncoding_Term.mk_fv + (ffsym, FStarC_SMTEncoding_Term.Fuel_sort) in + uu___8 :: vars in + uu___6 :: uu___7 in + let uu___6 = + let uu___7 = + let uu___8 = + if term_constr_eq + then + let uu___9 = + let uu___10 = + FStarC_SMTEncoding_Util.mkApp + ("Term_constr_id", [tapp]) in + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_SMTEncoding_Util.mkApp + ("PreType", [xx]) in + [uu___14] in + ("Term_constr_id", uu___13) in + FStarC_SMTEncoding_Util.mkApp uu___12 in + (uu___10, uu___11) in + FStarC_SMTEncoding_Util.mkEq uu___9 + else + (let uu___10 = + let uu___11 = + FStarC_SMTEncoding_Util.mkApp + ("PreType", [xx]) in + (tapp, uu___11) in + FStarC_SMTEncoding_Util.mkEq uu___10) in + (xx_has_type, uu___8) in + FStarC_SMTEncoding_Util.mkImp uu___7 in + ([[xx_has_type]], uu___5, uu___6) in + FStarC_SMTEncoding_Term.mkForall rng uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Compiler_Util.digest_of_string + tapp_hash in + Prims.strcat "_pretyping_" uu___7 in + Prims.strcat module_name uu___6 in + FStarC_SMTEncoding_Env.varops.FStarC_SMTEncoding_Env.mk_unique + uu___5 in + (uu___3, (FStar_Pervasives_Native.Some "pretyping"), + uu___4) in + FStarC_SMTEncoding_Util.mkAssume uu___2) +let (primitive_type_axioms : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident -> + Prims.string -> + FStarC_SMTEncoding_Term.term -> + FStarC_SMTEncoding_Term.decl Prims.list) + = + let xx = + FStarC_SMTEncoding_Term.mk_fv ("x", FStarC_SMTEncoding_Term.Term_sort) in + let x = FStarC_SMTEncoding_Util.mkFreeV xx in + let yy = + FStarC_SMTEncoding_Term.mk_fv ("y", FStarC_SMTEncoding_Term.Term_sort) in + let y = FStarC_SMTEncoding_Util.mkFreeV yy in + let mkForall_fuel env = + let uu___ = + let uu___1 = FStarC_TypeChecker_Env.current_module env in + FStarC_Ident.string_of_lid uu___1 in + FStarC_SMTEncoding_EncodeTerm.mkForall_fuel uu___ in + let mk_unit env nm tt = + let typing_pred = FStarC_SMTEncoding_Term.mk_HasType x tt in + let uu___ = + let uu___1 = + let uu___2 = + FStarC_SMTEncoding_Term.mk_HasType + FStarC_SMTEncoding_Term.mk_Term_unit tt in + (uu___2, (FStar_Pervasives_Native.Some "unit typing"), "unit_typing") in + FStarC_SMTEncoding_Util.mkAssume uu___1 in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_SMTEncoding_Util.mkEq + (x, FStarC_SMTEncoding_Term.mk_Term_unit) in + (typing_pred, uu___8) in + FStarC_SMTEncoding_Util.mkImp uu___7 in + ([[typing_pred]], [xx], uu___6) in + let uu___6 = + let uu___7 = FStarC_TypeChecker_Env.get_range env in + let uu___8 = mkForall_fuel env in uu___8 uu___7 in + uu___6 uu___5 in + (uu___4, (FStar_Pervasives_Native.Some "unit inversion"), + "unit_inversion") in + FStarC_SMTEncoding_Util.mkAssume uu___3 in + [uu___2] in + uu___ :: uu___1 in + let mk_bool env nm tt = + let typing_pred = FStarC_SMTEncoding_Term.mk_HasType x tt in + let bb = + FStarC_SMTEncoding_Term.mk_fv ("b", FStarC_SMTEncoding_Term.Bool_sort) in + let b = FStarC_SMTEncoding_Util.mkFreeV bb in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_TypeChecker_Env.get_range env in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = FStarC_SMTEncoding_Term.boxBool b in [uu___7] in + [uu___6] in + let uu___6 = + let uu___7 = FStarC_SMTEncoding_Term.boxBool b in + FStarC_SMTEncoding_Term.mk_HasType uu___7 tt in + (uu___5, [bb], uu___6) in + FStarC_SMTEncoding_Term.mkForall uu___3 uu___4 in + (uu___2, (FStar_Pervasives_Native.Some "bool typing"), "bool_typing") in + FStarC_SMTEncoding_Util.mkAssume uu___1 in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_SMTEncoding_Term.mk_tester + (FStar_Pervasives_Native.fst + FStarC_SMTEncoding_Term.boxBoolFun) x in + (typing_pred, uu___8) in + FStarC_SMTEncoding_Util.mkImp uu___7 in + ([[typing_pred]], [xx], uu___6) in + let uu___6 = + let uu___7 = FStarC_TypeChecker_Env.get_range env in + let uu___8 = mkForall_fuel env in uu___8 uu___7 in + uu___6 uu___5 in + (uu___4, (FStar_Pervasives_Native.Some "bool inversion"), + "bool_inversion") in + FStarC_SMTEncoding_Util.mkAssume uu___3 in + [uu___2] in + uu___ :: uu___1 in + let mk_int env nm tt = + let lex_t = + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Ident.string_of_lid FStarC_Parser_Const.lex_t_lid in + (uu___2, FStarC_SMTEncoding_Term.Term_sort) in + FStarC_SMTEncoding_Term.mk_fv uu___1 in + FStarC_SMTEncoding_Util.mkFreeV uu___ in + let typing_pred = FStarC_SMTEncoding_Term.mk_HasType x tt in + let typing_pred_y = FStarC_SMTEncoding_Term.mk_HasType y tt in + let aa = + FStarC_SMTEncoding_Term.mk_fv ("a", FStarC_SMTEncoding_Term.Int_sort) in + let a = FStarC_SMTEncoding_Util.mkFreeV aa in + let bb = + FStarC_SMTEncoding_Term.mk_fv ("b", FStarC_SMTEncoding_Term.Int_sort) in + let b = FStarC_SMTEncoding_Util.mkFreeV bb in + let precedes_y_x = + let uu___ = + FStarC_SMTEncoding_Util.mkApp + ("Prims.precedes", [lex_t; lex_t; y; x]) in + FStarC_SMTEncoding_Term.mk_Valid uu___ in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_TypeChecker_Env.get_range env in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = FStarC_SMTEncoding_Term.boxInt b in [uu___7] in + [uu___6] in + let uu___6 = + let uu___7 = FStarC_SMTEncoding_Term.boxInt b in + FStarC_SMTEncoding_Term.mk_HasType uu___7 tt in + (uu___5, [bb], uu___6) in + FStarC_SMTEncoding_Term.mkForall uu___3 uu___4 in + (uu___2, (FStar_Pervasives_Native.Some "int typing"), "int_typing") in + FStarC_SMTEncoding_Util.mkAssume uu___1 in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_SMTEncoding_Term.mk_tester + (FStar_Pervasives_Native.fst + FStarC_SMTEncoding_Term.boxIntFun) x in + (typing_pred, uu___8) in + FStarC_SMTEncoding_Util.mkImp uu___7 in + ([[typing_pred]], [xx], uu___6) in + let uu___6 = + let uu___7 = FStarC_TypeChecker_Env.get_range env in + let uu___8 = mkForall_fuel env in uu___8 uu___7 in + uu___6 uu___5 in + (uu___4, (FStar_Pervasives_Native.Some "int inversion"), + "int_inversion") in + FStarC_SMTEncoding_Util.mkAssume uu___3 in + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = + FStarC_SMTEncoding_Term.unboxInt x in + let uu___17 = + FStarC_SMTEncoding_Util.mkInteger' + Prims.int_zero in + (uu___16, uu___17) in + FStarC_SMTEncoding_Util.mkGT uu___15 in + let uu___15 = + let uu___16 = + let uu___17 = + let uu___18 = + FStarC_SMTEncoding_Term.unboxInt y in + let uu___19 = + FStarC_SMTEncoding_Util.mkInteger' + Prims.int_zero in + (uu___18, uu___19) in + FStarC_SMTEncoding_Util.mkGTE uu___17 in + let uu___17 = + let uu___18 = + let uu___19 = + let uu___20 = + FStarC_SMTEncoding_Term.unboxInt y in + let uu___21 = + FStarC_SMTEncoding_Term.unboxInt x in + (uu___20, uu___21) in + FStarC_SMTEncoding_Util.mkLT uu___19 in + [uu___18] in + uu___16 :: uu___17 in + uu___14 :: uu___15 in + typing_pred_y :: uu___13 in + typing_pred :: uu___12 in + FStarC_SMTEncoding_Util.mk_and_l uu___11 in + (uu___10, precedes_y_x) in + FStarC_SMTEncoding_Util.mkImp uu___9 in + ([[typing_pred; typing_pred_y; precedes_y_x]], [xx; yy], + uu___8) in + let uu___8 = + let uu___9 = FStarC_TypeChecker_Env.get_range env in + let uu___10 = mkForall_fuel env in uu___10 uu___9 in + uu___8 uu___7 in + (uu___6, + (FStar_Pervasives_Native.Some + "well-founded ordering on nat (alt)"), + "well-founded-ordering-on-nat") in + FStarC_SMTEncoding_Util.mkAssume uu___5 in + [uu___4] in + uu___2 :: uu___3 in + uu___ :: uu___1 in + let mk_real env nm tt = + let typing_pred = FStarC_SMTEncoding_Term.mk_HasType x tt in + let aa = + FStarC_SMTEncoding_Term.mk_fv + ("a", (FStarC_SMTEncoding_Term.Sort "Real")) in + let a = FStarC_SMTEncoding_Util.mkFreeV aa in + let bb = + FStarC_SMTEncoding_Term.mk_fv + ("b", (FStarC_SMTEncoding_Term.Sort "Real")) in + let b = FStarC_SMTEncoding_Util.mkFreeV bb in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_TypeChecker_Env.get_range env in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = FStarC_SMTEncoding_Term.boxReal b in [uu___7] in + [uu___6] in + let uu___6 = + let uu___7 = FStarC_SMTEncoding_Term.boxReal b in + FStarC_SMTEncoding_Term.mk_HasType uu___7 tt in + (uu___5, [bb], uu___6) in + FStarC_SMTEncoding_Term.mkForall uu___3 uu___4 in + (uu___2, (FStar_Pervasives_Native.Some "real typing"), "real_typing") in + FStarC_SMTEncoding_Util.mkAssume uu___1 in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_SMTEncoding_Term.mk_tester + (FStar_Pervasives_Native.fst + FStarC_SMTEncoding_Term.boxRealFun) x in + (typing_pred, uu___8) in + FStarC_SMTEncoding_Util.mkImp uu___7 in + ([[typing_pred]], [xx], uu___6) in + let uu___6 = + let uu___7 = FStarC_TypeChecker_Env.get_range env in + let uu___8 = mkForall_fuel env in uu___8 uu___7 in + uu___6 uu___5 in + (uu___4, (FStar_Pervasives_Native.Some "real inversion"), + "real_inversion") in + FStarC_SMTEncoding_Util.mkAssume uu___3 in + [uu___2] in + uu___ :: uu___1 in + let mk_str env nm tt = + let typing_pred = FStarC_SMTEncoding_Term.mk_HasType x tt in + let bb = + FStarC_SMTEncoding_Term.mk_fv + ("b", FStarC_SMTEncoding_Term.String_sort) in + let b = FStarC_SMTEncoding_Util.mkFreeV bb in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_TypeChecker_Env.get_range env in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = FStarC_SMTEncoding_Term.boxString b in [uu___7] in + [uu___6] in + let uu___6 = + let uu___7 = FStarC_SMTEncoding_Term.boxString b in + FStarC_SMTEncoding_Term.mk_HasType uu___7 tt in + (uu___5, [bb], uu___6) in + FStarC_SMTEncoding_Term.mkForall uu___3 uu___4 in + (uu___2, (FStar_Pervasives_Native.Some "string typing"), + "string_typing") in + FStarC_SMTEncoding_Util.mkAssume uu___1 in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_SMTEncoding_Term.mk_tester + (FStar_Pervasives_Native.fst + FStarC_SMTEncoding_Term.boxStringFun) x in + (typing_pred, uu___8) in + FStarC_SMTEncoding_Util.mkImp uu___7 in + ([[typing_pred]], [xx], uu___6) in + let uu___6 = + let uu___7 = FStarC_TypeChecker_Env.get_range env in + let uu___8 = mkForall_fuel env in uu___8 uu___7 in + uu___6 uu___5 in + (uu___4, (FStar_Pervasives_Native.Some "string inversion"), + "string_inversion") in + FStarC_SMTEncoding_Util.mkAssume uu___3 in + [uu___2] in + uu___ :: uu___1 in + let mk_true_interp env nm true_tm = + let valid = FStarC_SMTEncoding_Util.mkApp ("Valid", [true_tm]) in + let uu___ = + FStarC_SMTEncoding_Util.mkAssume + (valid, (FStar_Pervasives_Native.Some "True interpretation"), + "true_interp") in + [uu___] in + let mk_false_interp env nm false_tm = + let valid = FStarC_SMTEncoding_Util.mkApp ("Valid", [false_tm]) in + let uu___ = + let uu___1 = + let uu___2 = + FStarC_SMTEncoding_Util.mkIff + (FStarC_SMTEncoding_Util.mkFalse, valid) in + (uu___2, (FStar_Pervasives_Native.Some "False interpretation"), + "false_interp") in + FStarC_SMTEncoding_Util.mkAssume uu___1 in + [uu___] in + let mk_and_interp env conj uu___ = + let aa = + FStarC_SMTEncoding_Term.mk_fv ("a", FStarC_SMTEncoding_Term.Term_sort) in + let bb = + FStarC_SMTEncoding_Term.mk_fv ("b", FStarC_SMTEncoding_Term.Term_sort) in + let a = FStarC_SMTEncoding_Util.mkFreeV aa in + let b = FStarC_SMTEncoding_Util.mkFreeV bb in + let l_and_a_b = FStarC_SMTEncoding_Util.mkApp (conj, [a; b]) in + let valid = FStarC_SMTEncoding_Util.mkApp ("Valid", [l_and_a_b]) in + let valid_a = FStarC_SMTEncoding_Util.mkApp ("Valid", [a]) in + let valid_b = FStarC_SMTEncoding_Util.mkApp ("Valid", [b]) in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_TypeChecker_Env.get_range env in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = FStarC_SMTEncoding_Util.mkAnd (valid_a, valid_b) in + (uu___8, valid) in + FStarC_SMTEncoding_Util.mkIff uu___7 in + ([[l_and_a_b]], [aa; bb], uu___6) in + FStarC_SMTEncoding_Term.mkForall uu___4 uu___5 in + (uu___3, (FStar_Pervasives_Native.Some "/\\ interpretation"), + "l_and-interp") in + FStarC_SMTEncoding_Util.mkAssume uu___2 in + [uu___1] in + let mk_or_interp env disj uu___ = + let aa = + FStarC_SMTEncoding_Term.mk_fv ("a", FStarC_SMTEncoding_Term.Term_sort) in + let bb = + FStarC_SMTEncoding_Term.mk_fv ("b", FStarC_SMTEncoding_Term.Term_sort) in + let a = FStarC_SMTEncoding_Util.mkFreeV aa in + let b = FStarC_SMTEncoding_Util.mkFreeV bb in + let l_or_a_b = FStarC_SMTEncoding_Util.mkApp (disj, [a; b]) in + let valid = FStarC_SMTEncoding_Util.mkApp ("Valid", [l_or_a_b]) in + let valid_a = FStarC_SMTEncoding_Util.mkApp ("Valid", [a]) in + let valid_b = FStarC_SMTEncoding_Util.mkApp ("Valid", [b]) in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_TypeChecker_Env.get_range env in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = FStarC_SMTEncoding_Util.mkOr (valid_a, valid_b) in + (uu___8, valid) in + FStarC_SMTEncoding_Util.mkIff uu___7 in + ([[l_or_a_b]], [aa; bb], uu___6) in + FStarC_SMTEncoding_Term.mkForall uu___4 uu___5 in + (uu___3, (FStar_Pervasives_Native.Some "\\/ interpretation"), + "l_or-interp") in + FStarC_SMTEncoding_Util.mkAssume uu___2 in + [uu___1] in + let mk_eq2_interp env eq2 tt = + let aa = + FStarC_SMTEncoding_Term.mk_fv ("a", FStarC_SMTEncoding_Term.Term_sort) in + let xx1 = + FStarC_SMTEncoding_Term.mk_fv ("x", FStarC_SMTEncoding_Term.Term_sort) in + let yy1 = + FStarC_SMTEncoding_Term.mk_fv ("y", FStarC_SMTEncoding_Term.Term_sort) in + let a = FStarC_SMTEncoding_Util.mkFreeV aa in + let x1 = FStarC_SMTEncoding_Util.mkFreeV xx1 in + let y1 = FStarC_SMTEncoding_Util.mkFreeV yy1 in + let eq2_x_y = FStarC_SMTEncoding_Util.mkApp (eq2, [a; x1; y1]) in + let valid = FStarC_SMTEncoding_Util.mkApp ("Valid", [eq2_x_y]) in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_TypeChecker_Env.get_range env in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = FStarC_SMTEncoding_Util.mkEq (x1, y1) in + (uu___7, valid) in + FStarC_SMTEncoding_Util.mkIff uu___6 in + ([[eq2_x_y]], [aa; xx1; yy1], uu___5) in + FStarC_SMTEncoding_Term.mkForall uu___3 uu___4 in + (uu___2, (FStar_Pervasives_Native.Some "Eq2 interpretation"), + "eq2-interp") in + FStarC_SMTEncoding_Util.mkAssume uu___1 in + [uu___] in + let mk_imp_interp env imp tt = + let aa = + FStarC_SMTEncoding_Term.mk_fv ("a", FStarC_SMTEncoding_Term.Term_sort) in + let bb = + FStarC_SMTEncoding_Term.mk_fv ("b", FStarC_SMTEncoding_Term.Term_sort) in + let a = FStarC_SMTEncoding_Util.mkFreeV aa in + let b = FStarC_SMTEncoding_Util.mkFreeV bb in + let l_imp_a_b = FStarC_SMTEncoding_Util.mkApp (imp, [a; b]) in + let valid = FStarC_SMTEncoding_Util.mkApp ("Valid", [l_imp_a_b]) in + let valid_a = FStarC_SMTEncoding_Util.mkApp ("Valid", [a]) in + let valid_b = FStarC_SMTEncoding_Util.mkApp ("Valid", [b]) in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_TypeChecker_Env.get_range env in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = FStarC_SMTEncoding_Util.mkImp (valid_a, valid_b) in + (uu___7, valid) in + FStarC_SMTEncoding_Util.mkIff uu___6 in + ([[l_imp_a_b]], [aa; bb], uu___5) in + FStarC_SMTEncoding_Term.mkForall uu___3 uu___4 in + (uu___2, (FStar_Pervasives_Native.Some "==> interpretation"), + "l_imp-interp") in + FStarC_SMTEncoding_Util.mkAssume uu___1 in + [uu___] in + let mk_iff_interp env iff tt = + let aa = + FStarC_SMTEncoding_Term.mk_fv ("a", FStarC_SMTEncoding_Term.Term_sort) in + let bb = + FStarC_SMTEncoding_Term.mk_fv ("b", FStarC_SMTEncoding_Term.Term_sort) in + let a = FStarC_SMTEncoding_Util.mkFreeV aa in + let b = FStarC_SMTEncoding_Util.mkFreeV bb in + let l_iff_a_b = FStarC_SMTEncoding_Util.mkApp (iff, [a; b]) in + let valid = FStarC_SMTEncoding_Util.mkApp ("Valid", [l_iff_a_b]) in + let valid_a = FStarC_SMTEncoding_Util.mkApp ("Valid", [a]) in + let valid_b = FStarC_SMTEncoding_Util.mkApp ("Valid", [b]) in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_TypeChecker_Env.get_range env in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = FStarC_SMTEncoding_Util.mkIff (valid_a, valid_b) in + (uu___7, valid) in + FStarC_SMTEncoding_Util.mkIff uu___6 in + ([[l_iff_a_b]], [aa; bb], uu___5) in + FStarC_SMTEncoding_Term.mkForall uu___3 uu___4 in + (uu___2, (FStar_Pervasives_Native.Some "<==> interpretation"), + "l_iff-interp") in + FStarC_SMTEncoding_Util.mkAssume uu___1 in + [uu___] in + let mk_not_interp env l_not tt = + let aa = + FStarC_SMTEncoding_Term.mk_fv ("a", FStarC_SMTEncoding_Term.Term_sort) in + let a = FStarC_SMTEncoding_Util.mkFreeV aa in + let l_not_a = FStarC_SMTEncoding_Util.mkApp (l_not, [a]) in + let valid = FStarC_SMTEncoding_Util.mkApp ("Valid", [l_not_a]) in + let not_valid_a = + let uu___ = FStarC_SMTEncoding_Util.mkApp ("Valid", [a]) in + FStarC_SMTEncoding_Util.mkNot uu___ in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_TypeChecker_Env.get_range env in + let uu___4 = + let uu___5 = FStarC_SMTEncoding_Util.mkIff (not_valid_a, valid) in + ([[l_not_a]], [aa], uu___5) in + FStarC_SMTEncoding_Term.mkForall uu___3 uu___4 in + (uu___2, (FStar_Pervasives_Native.Some "not interpretation"), + "l_not-interp") in + FStarC_SMTEncoding_Util.mkAssume uu___1 in + [uu___] in + let mk_range_interp env range tt = + let range_ty = FStarC_SMTEncoding_Util.mkApp (range, []) in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_SMTEncoding_Term.mk_Range_const () in + FStarC_SMTEncoding_Term.mk_HasTypeZ uu___3 range_ty in + let uu___3 = + FStarC_SMTEncoding_Env.varops.FStarC_SMTEncoding_Env.mk_unique + "typing_range_const" in + (uu___2, (FStar_Pervasives_Native.Some "Range_const typing"), uu___3) in + FStarC_SMTEncoding_Util.mkAssume uu___1 in + [uu___] in + let mk_inversion_axiom env inversion tt = + let tt1 = + FStarC_SMTEncoding_Term.mk_fv ("t", FStarC_SMTEncoding_Term.Term_sort) in + let t = FStarC_SMTEncoding_Util.mkFreeV tt1 in + let xx1 = + FStarC_SMTEncoding_Term.mk_fv ("x", FStarC_SMTEncoding_Term.Term_sort) in + let x1 = FStarC_SMTEncoding_Util.mkFreeV xx1 in + let inversion_t = FStarC_SMTEncoding_Util.mkApp (inversion, [t]) in + let valid = FStarC_SMTEncoding_Util.mkApp ("Valid", [inversion_t]) in + let body = + let hastypeZ = FStarC_SMTEncoding_Term.mk_HasTypeZ x1 t in + let hastypeS = + let uu___ = FStarC_SMTEncoding_Term.n_fuel Prims.int_one in + FStarC_SMTEncoding_Term.mk_HasTypeFuel uu___ x1 t in + let uu___ = FStarC_TypeChecker_Env.get_range env in + let uu___1 = + let uu___2 = FStarC_SMTEncoding_Util.mkImp (hastypeZ, hastypeS) in + ([[hastypeZ]], [xx1], uu___2) in + FStarC_SMTEncoding_Term.mkForall uu___ uu___1 in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_TypeChecker_Env.get_range env in + let uu___4 = + let uu___5 = FStarC_SMTEncoding_Util.mkImp (valid, body) in + ([[inversion_t]], [tt1], uu___5) in + FStarC_SMTEncoding_Term.mkForall uu___3 uu___4 in + (uu___2, (FStar_Pervasives_Native.Some "inversion interpretation"), + "inversion-interp") in + FStarC_SMTEncoding_Util.mkAssume uu___1 in + [uu___] in + let prims1 = + [(FStarC_Parser_Const.unit_lid, mk_unit); + (FStarC_Parser_Const.bool_lid, mk_bool); + (FStarC_Parser_Const.int_lid, mk_int); + (FStarC_Parser_Const.real_lid, mk_real); + (FStarC_Parser_Const.string_lid, mk_str); + (FStarC_Parser_Const.true_lid, mk_true_interp); + (FStarC_Parser_Const.false_lid, mk_false_interp); + (FStarC_Parser_Const.and_lid, mk_and_interp); + (FStarC_Parser_Const.or_lid, mk_or_interp); + (FStarC_Parser_Const.eq2_lid, mk_eq2_interp); + (FStarC_Parser_Const.imp_lid, mk_imp_interp); + (FStarC_Parser_Const.iff_lid, mk_iff_interp); + (FStarC_Parser_Const.not_lid, mk_not_interp); + (FStarC_Parser_Const.range_lid, mk_range_interp); + (FStarC_Parser_Const.inversion_lid, mk_inversion_axiom)] in + fun env -> + fun t -> + fun s -> + fun tt -> + let uu___ = + FStarC_Compiler_Util.find_opt + (fun uu___1 -> + match uu___1 with + | (l, uu___2) -> FStarC_Ident.lid_equals l t) prims1 in + match uu___ with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some (uu___1, f) -> f env s tt +let (encode_smt_lemma : + FStarC_SMTEncoding_Env.env_t -> + FStarC_Syntax_Syntax.fv -> + FStarC_Syntax_Syntax.typ -> + FStarC_SMTEncoding_Term.decls_elt Prims.list) + = + fun env -> + fun fv -> + fun t -> + let lid = (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + let uu___ = + FStarC_SMTEncoding_EncodeTerm.encode_function_type_as_formula t env in + match uu___ with + | (form, decls) -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Ident.string_of_lid lid in + Prims.strcat "Lemma: " uu___7 in + FStar_Pervasives_Native.Some uu___6 in + let uu___6 = + let uu___7 = FStarC_Ident.string_of_lid lid in + Prims.strcat "lemma_" uu___7 in + (form, uu___5, uu___6) in + FStarC_SMTEncoding_Util.mkAssume uu___4 in + [uu___3] in + FStarC_SMTEncoding_Term.mk_decls_trivial uu___2 in + FStarC_Compiler_List.op_At decls uu___1 +let (encode_free_var : + Prims.bool -> + FStarC_SMTEncoding_Env.env_t -> + FStarC_Syntax_Syntax.fv -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.qualifier Prims.list -> + (FStarC_SMTEncoding_Term.decls_t * + FStarC_SMTEncoding_Env.env_t)) + = + fun uninterpreted -> + fun env -> + fun fv -> + fun tt -> + fun t_norm -> + fun quals -> + let lid = + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + let uu___ = + ((let uu___1 = + (FStarC_Syntax_Util.is_pure_or_ghost_function t_norm) || + (FStarC_SMTEncoding_Util.is_smt_reifiable_function + env.FStarC_SMTEncoding_Env.tcenv t_norm) in + Prims.op_Negation uu___1) || + (FStarC_Syntax_Util.is_lemma t_norm)) + || uninterpreted in + if uu___ + then + let arg_sorts = + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress t_norm in + uu___2.FStarC_Syntax_Syntax.n in + match uu___1 with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = binders; + FStarC_Syntax_Syntax.comp = uu___2;_} + -> + FStarC_Compiler_List.map + (fun uu___3 -> FStarC_SMTEncoding_Term.Term_sort) + binders + | uu___2 -> [] in + let arity = FStarC_Compiler_List.length arg_sorts in + let uu___1 = + FStarC_SMTEncoding_Env.new_term_constant_and_tok_from_lid + env lid arity in + match uu___1 with + | (vname, vtok, env1) -> + let d = + FStarC_SMTEncoding_Term.DeclFun + (vname, arg_sorts, FStarC_SMTEncoding_Term.Term_sort, + (FStar_Pervasives_Native.Some + "Uninterpreted function symbol for impure function")) in + let dd = + FStarC_SMTEncoding_Term.DeclFun + (vtok, [], FStarC_SMTEncoding_Term.Term_sort, + (FStar_Pervasives_Native.Some + "Uninterpreted name for impure function")) in + let uu___2 = + FStarC_SMTEncoding_Term.mk_decls_trivial [d; dd] in + (uu___2, env1) + else + (let uu___2 = prims.is lid in + if uu___2 + then + let vname = + FStarC_SMTEncoding_Env.varops.FStarC_SMTEncoding_Env.new_fvar + lid in + let uu___3 = prims.mk lid vname in + match uu___3 with + | (tok, arity, definition) -> + let env1 = + FStarC_SMTEncoding_Env.push_free_var env lid arity + vname (FStar_Pervasives_Native.Some tok) in + let uu___4 = + FStarC_SMTEncoding_Term.mk_decls_trivial definition in + (uu___4, env1) + else + (let encode_non_total_function_typ = + let uu___4 = FStarC_Ident.nsstr lid in + uu___4 <> "Prims" in + let uu___4 = + let uu___5 = + FStarC_SMTEncoding_EncodeTerm.curried_arrow_formals_comp + t_norm in + match uu___5 with + | (args, comp) -> + let tcenv_comp = + FStarC_TypeChecker_Env.push_binders + env.FStarC_SMTEncoding_Env.tcenv args in + let comp1 = + let uu___6 = + FStarC_SMTEncoding_Util.is_smt_reifiable_comp + env.FStarC_SMTEncoding_Env.tcenv comp in + if uu___6 + then + let uu___7 = + FStarC_TypeChecker_Env.reify_comp + { + FStarC_TypeChecker_Env.solver = + (tcenv_comp.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (tcenv_comp.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (tcenv_comp.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (tcenv_comp.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (tcenv_comp.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (tcenv_comp.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (tcenv_comp.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (tcenv_comp.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (tcenv_comp.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (tcenv_comp.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (tcenv_comp.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (tcenv_comp.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (tcenv_comp.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (tcenv_comp.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (tcenv_comp.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (tcenv_comp.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (tcenv_comp.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (tcenv_comp.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = true; + FStarC_TypeChecker_Env.lax_universes = + (tcenv_comp.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (tcenv_comp.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (tcenv_comp.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (tcenv_comp.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (tcenv_comp.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (tcenv_comp.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (tcenv_comp.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (tcenv_comp.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (tcenv_comp.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (tcenv_comp.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (tcenv_comp.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (tcenv_comp.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (tcenv_comp.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (tcenv_comp.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (tcenv_comp.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (tcenv_comp.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (tcenv_comp.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (tcenv_comp.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (tcenv_comp.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (tcenv_comp.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (tcenv_comp.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (tcenv_comp.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (tcenv_comp.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (tcenv_comp.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (tcenv_comp.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (tcenv_comp.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (tcenv_comp.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (tcenv_comp.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (tcenv_comp.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (tcenv_comp.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (tcenv_comp.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (tcenv_comp.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (tcenv_comp.FStarC_TypeChecker_Env.missing_decl) + } comp FStarC_Syntax_Syntax.U_unknown in + FStarC_Syntax_Syntax.mk_Total uu___7 + else comp in + if encode_non_total_function_typ + then + let uu___6 = + FStarC_TypeChecker_Util.pure_or_ghost_pre_and_post + tcenv_comp comp1 in + (args, uu___6) + else + (args, + (FStar_Pervasives_Native.None, + (FStarC_Syntax_Util.comp_result comp1))) in + match uu___4 with + | (formals, (pre_opt, res_t)) -> + let mk_disc_proj_axioms guard encoded_res_t vapp vars + = + FStarC_Compiler_List.collect + (fun uu___5 -> + match uu___5 with + | FStarC_Syntax_Syntax.Discriminator d -> + let uu___6 = + FStarC_Compiler_Util.prefix vars in + (match uu___6 with + | (uu___7, xxv) -> + let xx = + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_SMTEncoding_Term.fv_name + xxv in + (uu___10, + FStarC_SMTEncoding_Term.Term_sort) in + FStarC_SMTEncoding_Term.mk_fv + uu___9 in + FStarC_SMTEncoding_Util.mkFreeV + uu___8 in + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Syntax_Syntax.range_of_fv + fv in + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = + let uu___17 = + let uu___18 = + FStarC_Ident.string_of_lid + d in + FStarC_SMTEncoding_Env.escape + uu___18 in + FStarC_SMTEncoding_Term.mk_tester + uu___17 xx in + FStarC_SMTEncoding_Term.boxBool + uu___16 in + (vapp, uu___15) in + FStarC_SMTEncoding_Util.mkEq + uu___14 in + ([[vapp]], vars, uu___13) in + FStarC_SMTEncoding_Term.mkForall + uu___11 uu___12 in + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Ident.string_of_lid + d in + FStarC_SMTEncoding_Env.escape + uu___13 in + Prims.strcat "disc_equation_" + uu___12 in + (uu___10, + (FStar_Pervasives_Native.Some + "Discriminator equation"), + uu___11) in + FStarC_SMTEncoding_Util.mkAssume + uu___9 in + [uu___8]) + | FStarC_Syntax_Syntax.Projector (d, f) -> + let uu___6 = + FStarC_Compiler_Util.prefix vars in + (match uu___6 with + | (uu___7, xxv) -> + let xx = + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_SMTEncoding_Term.fv_name + xxv in + (uu___10, + FStarC_SMTEncoding_Term.Term_sort) in + FStarC_SMTEncoding_Term.mk_fv + uu___9 in + FStarC_SMTEncoding_Util.mkFreeV + uu___8 in + let f1 = + { + FStarC_Syntax_Syntax.ppname = f; + FStarC_Syntax_Syntax.index = + Prims.int_zero; + FStarC_Syntax_Syntax.sort = + FStarC_Syntax_Syntax.tun + } in + let tp_name = + FStarC_SMTEncoding_Env.mk_term_projector_name + d f1 in + let prim_app = + FStarC_SMTEncoding_Util.mkApp + (tp_name, [xx]) in + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Syntax_Syntax.range_of_fv + fv in + let uu___12 = + let uu___13 = + FStarC_SMTEncoding_Util.mkEq + (vapp, prim_app) in + ([[vapp]], vars, uu___13) in + FStarC_SMTEncoding_Term.mkForall + uu___11 uu___12 in + (uu___10, + (FStar_Pervasives_Native.Some + "Projector equation"), + (Prims.strcat "proj_equation_" + tp_name)) in + FStarC_SMTEncoding_Util.mkAssume + uu___9 in + [uu___8]) + | uu___6 -> []) quals in + let uu___5 = + FStarC_SMTEncoding_EncodeTerm.encode_binders + FStar_Pervasives_Native.None formals env in + (match uu___5 with + | (vars, guards, env', decls1, uu___6) -> + let uu___7 = + match pre_opt with + | FStar_Pervasives_Native.None -> + let uu___8 = + FStarC_SMTEncoding_Util.mk_and_l guards in + (uu___8, decls1) + | FStar_Pervasives_Native.Some p -> + let uu___8 = + FStarC_SMTEncoding_EncodeTerm.encode_formula + p env' in + (match uu___8 with + | (g, ds) -> + let uu___9 = + FStarC_SMTEncoding_Util.mk_and_l (g + :: guards) in + (uu___9, + (FStarC_Compiler_List.op_At decls1 + ds))) in + (match uu___7 with + | (guard, decls11) -> + let dummy_var = + FStarC_SMTEncoding_Term.mk_fv + ("@dummy", + FStarC_SMTEncoding_Term.dummy_sort) in + let dummy_tm = + FStarC_SMTEncoding_Term.mkFreeV dummy_var + FStarC_Compiler_Range_Type.dummyRange in + let should_thunk uu___8 = + let is_type t = + let uu___9 = + let uu___10 = + FStarC_Syntax_Subst.compress t in + uu___10.FStarC_Syntax_Syntax.n in + match uu___9 with + | FStarC_Syntax_Syntax.Tm_type uu___10 + -> true + | uu___10 -> false in + let is_squash t = + let uu___9 = + FStarC_Syntax_Util.head_and_args t in + match uu___9 with + | (head, uu___10) -> + let uu___11 = + let uu___12 = + FStarC_Syntax_Util.un_uinst + head in + uu___12.FStarC_Syntax_Syntax.n in + (match uu___11 with + | FStarC_Syntax_Syntax.Tm_fvar fv1 + -> + FStarC_Syntax_Syntax.fv_eq_lid + fv1 + FStarC_Parser_Const.squash_lid + | FStarC_Syntax_Syntax.Tm_refine + { + FStarC_Syntax_Syntax.b = + { + FStarC_Syntax_Syntax.ppname + = uu___12; + FStarC_Syntax_Syntax.index + = uu___13; + FStarC_Syntax_Syntax.sort + = + { + FStarC_Syntax_Syntax.n + = + FStarC_Syntax_Syntax.Tm_fvar + fv1; + FStarC_Syntax_Syntax.pos + = uu___14; + FStarC_Syntax_Syntax.vars + = uu___15; + FStarC_Syntax_Syntax.hash_code + = uu___16;_};_}; + FStarC_Syntax_Syntax.phi = + uu___17;_} + -> + FStarC_Syntax_Syntax.fv_eq_lid + fv1 + FStarC_Parser_Const.unit_lid + | uu___12 -> false) in + (((let uu___9 = FStarC_Ident.nsstr lid in + uu___9 <> "Prims") && + (Prims.op_Negation + (FStarC_Compiler_List.contains + FStarC_Syntax_Syntax.Logic + quals))) + && + (let uu___9 = is_squash t_norm in + Prims.op_Negation uu___9)) + && + (let uu___9 = is_type t_norm in + Prims.op_Negation uu___9) in + let uu___8 = + match vars with + | [] when should_thunk () -> + (true, [dummy_var]) + | uu___9 -> (false, vars) in + (match uu___8 with + | (thunked, vars1) -> + let arity = + FStarC_Compiler_List.length formals in + let uu___9 = + FStarC_SMTEncoding_Env.new_term_constant_and_tok_from_lid_maybe_thunked + env lid arity thunked in + (match uu___9 with + | (vname, vtok_opt, env1) -> + let get_vtok uu___10 = + FStarC_Compiler_Option.get + vtok_opt in + let vtok_tm = + match formals with + | [] when + Prims.op_Negation thunked + -> + FStarC_SMTEncoding_Util.mkApp + (vname, []) + | [] when thunked -> + FStarC_SMTEncoding_Util.mkApp + (vname, [dummy_tm]) + | uu___10 -> + let uu___11 = + let uu___12 = get_vtok () in + (uu___12, []) in + FStarC_SMTEncoding_Util.mkApp + uu___11 in + let vtok_app = + FStarC_SMTEncoding_EncodeTerm.mk_Apply + vtok_tm vars1 in + let vapp = + let uu___10 = + let uu___11 = + FStarC_Compiler_List.map + FStarC_SMTEncoding_Util.mkFreeV + vars1 in + (vname, uu___11) in + FStarC_SMTEncoding_Util.mkApp + uu___10 in + let uu___10 = + let vname_decl = + let uu___11 = + let uu___12 = + FStarC_Compiler_List.map + FStarC_SMTEncoding_Term.fv_sort + vars1 in + (vname, uu___12, + FStarC_SMTEncoding_Term.Term_sort, + FStar_Pervasives_Native.None) in + FStarC_SMTEncoding_Term.DeclFun + uu___11 in + let uu___11 = + let env2 = + { + FStarC_SMTEncoding_Env.bvar_bindings + = + (env1.FStarC_SMTEncoding_Env.bvar_bindings); + FStarC_SMTEncoding_Env.fvar_bindings + = + (env1.FStarC_SMTEncoding_Env.fvar_bindings); + FStarC_SMTEncoding_Env.depth + = + (env1.FStarC_SMTEncoding_Env.depth); + FStarC_SMTEncoding_Env.tcenv + = + (env1.FStarC_SMTEncoding_Env.tcenv); + FStarC_SMTEncoding_Env.warn + = + (env1.FStarC_SMTEncoding_Env.warn); + FStarC_SMTEncoding_Env.nolabels + = + (env1.FStarC_SMTEncoding_Env.nolabels); + FStarC_SMTEncoding_Env.use_zfuel_name + = + (env1.FStarC_SMTEncoding_Env.use_zfuel_name); + FStarC_SMTEncoding_Env.encode_non_total_function_typ + = + encode_non_total_function_typ; + FStarC_SMTEncoding_Env.current_module_name + = + (env1.FStarC_SMTEncoding_Env.current_module_name); + FStarC_SMTEncoding_Env.encoding_quantifier + = + (env1.FStarC_SMTEncoding_Env.encoding_quantifier); + FStarC_SMTEncoding_Env.global_cache + = + (env1.FStarC_SMTEncoding_Env.global_cache) + } in + let uu___12 = + let uu___13 = + FStarC_SMTEncoding_EncodeTerm.head_normal + env2 tt in + Prims.op_Negation uu___13 in + if uu___12 + then + FStarC_SMTEncoding_EncodeTerm.encode_term_pred + FStar_Pervasives_Native.None + tt env2 vtok_tm + else + FStarC_SMTEncoding_EncodeTerm.encode_term_pred + FStar_Pervasives_Native.None + t_norm env2 vtok_tm in + match uu___11 with + | (tok_typing, decls2) -> + let uu___12 = + match vars1 with + | [] -> + let tok_typing1 = + FStarC_SMTEncoding_Util.mkAssume + (tok_typing, + (FStar_Pervasives_Native.Some + "function token typing"), + (Prims.strcat + "function_token_typing_" + vname)) in + let uu___13 = + let uu___14 = + FStarC_SMTEncoding_Term.mk_decls_trivial + [tok_typing1] in + FStarC_Compiler_List.op_At + decls2 uu___14 in + let uu___14 = + let uu___15 = + let uu___16 = + FStarC_SMTEncoding_Util.mkApp + (vname, []) in + FStar_Pervasives_Native.Some + uu___16 in + FStarC_SMTEncoding_Env.push_free_var + env1 lid arity + vname uu___15 in + (uu___13, uu___14) + | uu___13 when thunked -> + (decls2, env1) + | uu___13 -> + let vtok = + get_vtok () in + let vtok_decl = + FStarC_SMTEncoding_Term.DeclFun + (vtok, [], + FStarC_SMTEncoding_Term.Term_sort, + FStar_Pervasives_Native.None) in + let name_tok_corr_formula + pat = + let uu___14 = + FStarC_Syntax_Syntax.range_of_fv + fv in + let uu___15 = + let uu___16 = + FStarC_SMTEncoding_Util.mkEq + (vtok_app, + vapp) in + ([[pat]], vars1, + uu___16) in + FStarC_SMTEncoding_Term.mkForall + uu___14 uu___15 in + let name_tok_corr = + let uu___14 = + let uu___15 = + name_tok_corr_formula + vtok_app in + (uu___15, + (FStar_Pervasives_Native.Some + "Name-token correspondence"), + (Prims.strcat + "token_correspondence_" + vname)) in + FStarC_SMTEncoding_Util.mkAssume + uu___14 in + let tok_typing1 = + let ff = + FStarC_SMTEncoding_Term.mk_fv + ("ty", + FStarC_SMTEncoding_Term.Term_sort) in + let f = + FStarC_SMTEncoding_Util.mkFreeV + ff in + let vtok_app_r = + let uu___14 = + let uu___15 = + FStarC_SMTEncoding_Term.mk_fv + (vtok, + FStarC_SMTEncoding_Term.Term_sort) in + [uu___15] in + FStarC_SMTEncoding_EncodeTerm.mk_Apply + f uu___14 in + let guarded_tok_typing + = + let uu___14 = + FStarC_Syntax_Syntax.range_of_fv + fv in + let uu___15 = + let uu___16 = + let uu___17 = + let uu___18 + = + FStarC_SMTEncoding_Term.mk_NoHoist + f + tok_typing in + let uu___19 + = + name_tok_corr_formula + vapp in + (uu___18, + uu___19) in + FStarC_SMTEncoding_Util.mkAnd + uu___17 in + ([[vtok_app_r]], + [ff], + uu___16) in + FStarC_SMTEncoding_Term.mkForall + uu___14 uu___15 in + FStarC_SMTEncoding_Util.mkAssume + (guarded_tok_typing, + (FStar_Pervasives_Native.Some + "function token typing"), + (Prims.strcat + "function_token_typing_" + vname)) in + let uu___14 = + let uu___15 = + FStarC_SMTEncoding_Term.mk_decls_trivial + [vtok_decl; + name_tok_corr; + tok_typing1] in + FStarC_Compiler_List.op_At + decls2 uu___15 in + (uu___14, env1) in + (match uu___12 with + | (tok_decl, env2) -> + let uu___13 = + let uu___14 = + FStarC_SMTEncoding_Term.mk_decls_trivial + [vname_decl] in + FStarC_Compiler_List.op_At + uu___14 tok_decl in + (uu___13, env2)) in + (match uu___10 with + | (decls2, env2) -> + let uu___11 = + let res_t1 = + FStarC_Syntax_Subst.compress + res_t in + let uu___12 = + FStarC_SMTEncoding_EncodeTerm.encode_term + res_t1 env' in + match uu___12 with + | (encoded_res_t, decls) + -> + let uu___13 = + FStarC_SMTEncoding_Term.mk_HasType + vapp encoded_res_t in + (encoded_res_t, + uu___13, decls) in + (match uu___11 with + | (encoded_res_t, ty_pred, + decls3) -> + let typingAx = + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_Syntax_Syntax.range_of_fv + fv in + let uu___15 = + let uu___16 = + FStarC_SMTEncoding_Util.mkImp + (guard, + ty_pred) in + ([[vapp]], + vars1, + uu___16) in + FStarC_SMTEncoding_Term.mkForall + uu___14 uu___15 in + (uu___13, + (FStar_Pervasives_Native.Some + "free var typing"), + (Prims.strcat + "typing_" + vname)) in + FStarC_SMTEncoding_Util.mkAssume + uu___12 in + let freshness = + if + FStarC_Compiler_List.contains + FStarC_Syntax_Syntax.New + quals + then + let uu___12 = + let uu___13 = + FStarC_Syntax_Syntax.range_of_fv + fv in + let uu___14 = + let uu___15 = + FStarC_Compiler_List.map + FStarC_SMTEncoding_Term.fv_sort + vars1 in + let uu___16 = + FStarC_SMTEncoding_Env.varops.FStarC_SMTEncoding_Env.next_id + () in + (vname, + uu___15, + FStarC_SMTEncoding_Term.Term_sort, + uu___16) in + FStarC_SMTEncoding_Term.fresh_constructor + uu___13 uu___14 in + let uu___13 = + let uu___14 = + let uu___15 = + FStarC_Syntax_Syntax.range_of_fv + fv in + pretype_axiom + false uu___15 + env2 vapp + vars1 in + [uu___14] in + uu___12 :: uu___13 + else [] in + let g = + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = + let uu___17 + = + mk_disc_proj_axioms + guard + encoded_res_t + vapp + vars1 in + typingAx :: + uu___17 in + FStarC_Compiler_List.op_At + freshness + uu___16 in + FStarC_SMTEncoding_Term.mk_decls_trivial + uu___15 in + FStarC_Compiler_List.op_At + decls3 uu___14 in + FStarC_Compiler_List.op_At + decls2 uu___13 in + FStarC_Compiler_List.op_At + decls11 uu___12 in + (g, env2))))))))) +let (declare_top_level_let : + FStarC_SMTEncoding_Env.env_t -> + FStarC_Syntax_Syntax.fv -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term -> + (FStarC_SMTEncoding_Env.fvar_binding * + FStarC_SMTEncoding_Term.decls_t * FStarC_SMTEncoding_Env.env_t)) + = + fun env -> + fun x -> + fun t -> + fun t_norm -> + let uu___ = + FStarC_SMTEncoding_Env.lookup_fvar_binding env + (x.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + match uu___ with + | FStar_Pervasives_Native.None -> + let uu___1 = encode_free_var false env x t t_norm [] in + (match uu___1 with + | (decls, env1) -> + let fvb = + FStarC_SMTEncoding_Env.lookup_lid env1 + (x.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + (fvb, decls, env1)) + | FStar_Pervasives_Native.Some fvb -> (fvb, [], env) +let (encode_top_level_val : + Prims.bool -> + FStarC_SMTEncoding_Env.env_t -> + FStarC_Syntax_Syntax.univ_names -> + FStarC_Syntax_Syntax.fv -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.qualifier Prims.list -> + (FStarC_SMTEncoding_Term.decls_elt Prims.list * + FStarC_SMTEncoding_Env.env_t)) + = + fun uninterpreted -> + fun env -> + fun us -> + fun fv -> + fun t -> + fun quals -> + let tt = + let uu___ = + let uu___1 = + let uu___2 = FStarC_Syntax_Syntax.lid_of_fv fv in + FStarC_Ident.nsstr uu___2 in + uu___1 = "FStar.Ghost" in + if uu___ + then + norm_with_steps + [FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.Simplify; + FStarC_TypeChecker_Env.AllowUnboundUniverses; + FStarC_TypeChecker_Env.EraseUniverses; + FStarC_TypeChecker_Env.Exclude + FStarC_TypeChecker_Env.Zeta] + env.FStarC_SMTEncoding_Env.tcenv t + else norm_before_encoding_us env us t in + let uu___ = encode_free_var uninterpreted env fv t tt quals in + match uu___ with + | (decls, env1) -> + let uu___1 = FStarC_Syntax_Util.is_smt_lemma t in + if uu___1 + then + let uu___2 = + let uu___3 = encode_smt_lemma env1 fv tt in + FStarC_Compiler_List.op_At decls uu___3 in + (uu___2, env1) + else (decls, env1) +let (encode_top_level_vals : + FStarC_SMTEncoding_Env.env_t -> + FStarC_Syntax_Syntax.letbinding Prims.list -> + FStarC_Syntax_Syntax.qualifier Prims.list -> + (FStarC_SMTEncoding_Term.decls_elt Prims.list * + FStarC_SMTEncoding_Env.env_t)) + = + fun env -> + fun bindings -> + fun quals -> + FStarC_Compiler_List.fold_left + (fun uu___ -> + fun lb -> + match uu___ with + | (decls, env1) -> + let uu___1 = + let uu___2 = + FStarC_Compiler_Util.right + lb.FStarC_Syntax_Syntax.lbname in + encode_top_level_val false env1 + lb.FStarC_Syntax_Syntax.lbunivs uu___2 + lb.FStarC_Syntax_Syntax.lbtyp quals in + (match uu___1 with + | (decls', env2) -> + ((FStarC_Compiler_List.op_At decls decls'), env2))) + ([], env) bindings +exception Let_rec_unencodeable +let (uu___is_Let_rec_unencodeable : Prims.exn -> Prims.bool) = + fun projectee -> + match projectee with | Let_rec_unencodeable -> true | uu___ -> false +let (copy_env : FStarC_SMTEncoding_Env.env_t -> FStarC_SMTEncoding_Env.env_t) + = + fun en -> + let uu___ = + FStarC_Compiler_Util.smap_copy en.FStarC_SMTEncoding_Env.global_cache in + { + FStarC_SMTEncoding_Env.bvar_bindings = + (en.FStarC_SMTEncoding_Env.bvar_bindings); + FStarC_SMTEncoding_Env.fvar_bindings = + (en.FStarC_SMTEncoding_Env.fvar_bindings); + FStarC_SMTEncoding_Env.depth = (en.FStarC_SMTEncoding_Env.depth); + FStarC_SMTEncoding_Env.tcenv = (en.FStarC_SMTEncoding_Env.tcenv); + FStarC_SMTEncoding_Env.warn = (en.FStarC_SMTEncoding_Env.warn); + FStarC_SMTEncoding_Env.nolabels = (en.FStarC_SMTEncoding_Env.nolabels); + FStarC_SMTEncoding_Env.use_zfuel_name = + (en.FStarC_SMTEncoding_Env.use_zfuel_name); + FStarC_SMTEncoding_Env.encode_non_total_function_typ = + (en.FStarC_SMTEncoding_Env.encode_non_total_function_typ); + FStarC_SMTEncoding_Env.current_module_name = + (en.FStarC_SMTEncoding_Env.current_module_name); + FStarC_SMTEncoding_Env.encoding_quantifier = + (en.FStarC_SMTEncoding_Env.encoding_quantifier); + FStarC_SMTEncoding_Env.global_cache = uu___ + } +let (encode_top_level_let : + FStarC_SMTEncoding_Env.env_t -> + (Prims.bool * FStarC_Syntax_Syntax.letbinding Prims.list) -> + FStarC_Syntax_Syntax.qualifier Prims.list -> + (FStarC_SMTEncoding_Term.decls_t * FStarC_SMTEncoding_Env.env_t)) + = + fun env -> + fun uu___ -> + fun quals -> + match uu___ with + | (is_rec, bindings) -> + let eta_expand binders formals body t = + let nbinders = FStarC_Compiler_List.length binders in + let uu___1 = FStarC_Compiler_Util.first_N nbinders formals in + match uu___1 with + | (formals1, extra_formals) -> + let subst = + FStarC_Compiler_List.map2 + (fun uu___2 -> + fun uu___3 -> + match (uu___2, uu___3) with + | ({ FStarC_Syntax_Syntax.binder_bv = formal; + FStarC_Syntax_Syntax.binder_qual = uu___4; + FStarC_Syntax_Syntax.binder_positivity = + uu___5; + FStarC_Syntax_Syntax.binder_attrs = uu___6;_}, + { FStarC_Syntax_Syntax.binder_bv = binder; + FStarC_Syntax_Syntax.binder_qual = uu___7; + FStarC_Syntax_Syntax.binder_positivity = + uu___8; + FStarC_Syntax_Syntax.binder_attrs = uu___9;_}) + -> + let uu___10 = + let uu___11 = + FStarC_Syntax_Syntax.bv_to_name binder in + (formal, uu___11) in + FStarC_Syntax_Syntax.NT uu___10) formals1 + binders in + let extra_formals1 = + let uu___2 = + FStarC_Compiler_List.map + (fun b -> + let uu___3 = + let uu___4 = b.FStarC_Syntax_Syntax.binder_bv in + let uu___5 = + FStarC_Syntax_Subst.subst subst + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + { + FStarC_Syntax_Syntax.ppname = + (uu___4.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (uu___4.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = uu___5 + } in + { + FStarC_Syntax_Syntax.binder_bv = uu___3; + FStarC_Syntax_Syntax.binder_qual = + (b.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity = + (b.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs = + (b.FStarC_Syntax_Syntax.binder_attrs) + }) extra_formals in + FStarC_Syntax_Util.name_binders uu___2 in + let body1 = + let uu___2 = FStarC_Syntax_Subst.compress body in + let uu___3 = + let uu___4 = + FStarC_Syntax_Util.args_of_binders extra_formals1 in + FStar_Pervasives_Native.snd uu___4 in + FStarC_Syntax_Syntax.extend_app_n uu___2 uu___3 + body.FStarC_Syntax_Syntax.pos in + ((FStarC_Compiler_List.op_At binders extra_formals1), + body1) in + let destruct_bound_function t e = + let tcenv = + let uu___1 = env.FStarC_SMTEncoding_Env.tcenv in + { + FStarC_TypeChecker_Env.solver = + (uu___1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (uu___1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (uu___1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (uu___1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (uu___1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (uu___1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (uu___1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (uu___1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (uu___1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (uu___1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (uu___1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (uu___1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (uu___1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (uu___1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (uu___1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (uu___1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (uu___1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (uu___1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = true; + FStarC_TypeChecker_Env.lax_universes = + (uu___1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (uu___1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (uu___1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (uu___1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (uu___1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (uu___1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (uu___1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (uu___1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (uu___1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (uu___1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (uu___1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (uu___1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (uu___1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (uu___1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (uu___1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (uu___1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (uu___1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (uu___1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (uu___1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (uu___1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (uu___1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (uu___1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (uu___1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (uu___1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (uu___1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (uu___1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (uu___1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (uu___1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (uu___1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (uu___1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (uu___1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (uu___1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (uu___1.FStarC_TypeChecker_Env.missing_decl) + } in + let subst_comp formals actuals comp = + let subst = + FStarC_Compiler_List.map2 + (fun uu___1 -> + fun uu___2 -> + match (uu___1, uu___2) with + | ({ FStarC_Syntax_Syntax.binder_bv = x; + FStarC_Syntax_Syntax.binder_qual = uu___3; + FStarC_Syntax_Syntax.binder_positivity = uu___4; + FStarC_Syntax_Syntax.binder_attrs = uu___5;_}, + { FStarC_Syntax_Syntax.binder_bv = b; + FStarC_Syntax_Syntax.binder_qual = uu___6; + FStarC_Syntax_Syntax.binder_positivity = uu___7; + FStarC_Syntax_Syntax.binder_attrs = uu___8;_}) + -> + let uu___9 = + let uu___10 = + FStarC_Syntax_Syntax.bv_to_name b in + (x, uu___10) in + FStarC_Syntax_Syntax.NT uu___9) formals actuals in + FStarC_Syntax_Subst.subst_comp subst comp in + let rec arrow_formals_comp_norm norm t1 = + let t2 = + let uu___1 = FStarC_Syntax_Subst.compress t1 in + FStarC_Syntax_Util.unascribe uu___1 in + match t2.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = formals; + FStarC_Syntax_Syntax.comp = comp;_} + -> FStarC_Syntax_Subst.open_comp formals comp + | FStarC_Syntax_Syntax.Tm_refine uu___1 -> + let uu___2 = FStarC_Syntax_Util.unrefine t2 in + arrow_formals_comp_norm norm uu___2 + | uu___1 when Prims.op_Negation norm -> + let t_norm = + norm_with_steps + [FStarC_TypeChecker_Env.AllowUnboundUniverses; + FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Weak; + FStarC_TypeChecker_Env.HNF; + FStarC_TypeChecker_Env.Exclude + FStarC_TypeChecker_Env.Zeta; + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.EraseUniverses] tcenv t2 in + arrow_formals_comp_norm true t_norm + | uu___1 -> + let uu___2 = FStarC_Syntax_Syntax.mk_Total t2 in + ([], uu___2) in + let aux t1 e1 = + let uu___1 = FStarC_Syntax_Util.abs_formals e1 in + match uu___1 with + | (binders, body, lopt) -> + let uu___2 = + match binders with + | [] -> arrow_formals_comp_norm true t1 + | uu___3 -> arrow_formals_comp_norm false t1 in + (match uu___2 with + | (formals, comp) -> + let nformals = FStarC_Compiler_List.length formals in + let nbinders = FStarC_Compiler_List.length binders in + let uu___3 = + if nformals < nbinders + then + let uu___4 = + FStarC_Compiler_Util.first_N nformals binders in + match uu___4 with + | (bs0, rest) -> + let body1 = + FStarC_Syntax_Util.abs rest body lopt in + let uu___5 = subst_comp formals bs0 comp in + (bs0, body1, uu___5) + else + if nformals > nbinders + then + (let uu___5 = + eta_expand binders formals body + (FStarC_Syntax_Util.comp_result comp) in + match uu___5 with + | (binders1, body1) -> + let uu___6 = + subst_comp formals binders1 comp in + (binders1, body1, uu___6)) + else + (let uu___6 = subst_comp formals binders comp in + (binders, body, uu___6)) in + (match uu___3 with + | (binders1, body1, comp1) -> + (binders1, body1, comp1))) in + let uu___1 = aux t e in + match uu___1 with + | (binders, body, comp) -> + let uu___2 = + let tcenv1 = + FStarC_TypeChecker_Env.push_binders tcenv binders in + let uu___3 = + FStarC_SMTEncoding_Util.is_smt_reifiable_comp tcenv1 + comp in + if uu___3 + then + let eff_name = FStarC_Syntax_Util.comp_effect_name comp in + let comp1 = + FStarC_TypeChecker_Env.reify_comp tcenv1 comp + FStarC_Syntax_Syntax.U_unknown in + let body1 = + let uu___4 = + FStarC_Syntax_Util.mk_reify body + (FStar_Pervasives_Native.Some eff_name) in + FStarC_TypeChecker_Util.norm_reify tcenv1 [] uu___4 in + let uu___4 = aux comp1 body1 in + match uu___4 with + | (more_binders, body2, comp2) -> + ((FStarC_Compiler_List.op_At binders more_binders), + body2, comp2) + else (binders, body, comp) in + (match uu___2 with + | (binders1, body1, comp1) -> + let uu___3 = + FStarC_Syntax_Util.ascribe body1 + ((FStar_Pervasives.Inl + (FStarC_Syntax_Util.comp_result comp1)), + FStar_Pervasives_Native.None, false) in + (binders1, uu___3, comp1)) in + (try + (fun uu___1 -> + match () with + | () -> + let uu___2 = + FStarC_Compiler_Util.for_all + (fun lb -> + FStarC_Syntax_Util.is_lemma + lb.FStarC_Syntax_Syntax.lbtyp) bindings in + if uu___2 + then encode_top_level_vals env bindings quals + else + (let uu___4 = + FStarC_Compiler_List.fold_left + (fun uu___5 -> + fun lb -> + match uu___5 with + | (toks, typs, decls, env1) -> + ((let uu___7 = + FStarC_Syntax_Util.is_lemma + lb.FStarC_Syntax_Syntax.lbtyp in + if uu___7 + then + FStarC_Compiler_Effect.raise + Let_rec_unencodeable + else ()); + (let t_norm = + if is_rec + then + FStarC_TypeChecker_Normalize.unfold_whnf' + [FStarC_TypeChecker_Env.AllowUnboundUniverses] + env1.FStarC_SMTEncoding_Env.tcenv + lb.FStarC_Syntax_Syntax.lbtyp + else + norm_before_encoding env1 + lb.FStarC_Syntax_Syntax.lbtyp in + let uu___7 = + let uu___8 = + FStarC_Compiler_Util.right + lb.FStarC_Syntax_Syntax.lbname in + declare_top_level_let env1 uu___8 + lb.FStarC_Syntax_Syntax.lbtyp + t_norm in + match uu___7 with + | (tok, decl, env2) -> + ((tok :: toks), (t_norm :: typs), + (decl :: decls), env2)))) + ([], [], [], env) bindings in + match uu___4 with + | (toks, typs, decls, env1) -> + let toks_fvbs = FStarC_Compiler_List.rev toks in + let decls1 = + FStarC_Compiler_List.flatten + (FStarC_Compiler_List.rev decls) in + let env_decls = copy_env env1 in + let typs1 = FStarC_Compiler_List.rev typs in + let encode_non_rec_lbdef bindings1 typs2 toks1 + env2 = + match (bindings1, typs2, toks1) with + | ({ FStarC_Syntax_Syntax.lbname = lbn; + FStarC_Syntax_Syntax.lbunivs = uvs; + FStarC_Syntax_Syntax.lbtyp = uu___5; + FStarC_Syntax_Syntax.lbeff = uu___6; + FStarC_Syntax_Syntax.lbdef = e; + FStarC_Syntax_Syntax.lbattrs = uu___7; + FStarC_Syntax_Syntax.lbpos = uu___8;_}::[], + t_norm::[], fvb::[]) -> + let flid = + fvb.FStarC_SMTEncoding_Env.fvar_lid in + let uu___9 = + let uu___10 = + FStarC_TypeChecker_Env.open_universes_in + env2.FStarC_SMTEncoding_Env.tcenv + uvs [e; t_norm] in + match uu___10 with + | (tcenv', uu___11, e_t) -> + let uu___12 = + match e_t with + | e1::t_norm1::[] -> (e1, t_norm1) + | uu___13 -> failwith "Impossible" in + (match uu___12 with + | (e1, t_norm1) -> + ({ + FStarC_SMTEncoding_Env.bvar_bindings + = + (env2.FStarC_SMTEncoding_Env.bvar_bindings); + FStarC_SMTEncoding_Env.fvar_bindings + = + (env2.FStarC_SMTEncoding_Env.fvar_bindings); + FStarC_SMTEncoding_Env.depth + = + (env2.FStarC_SMTEncoding_Env.depth); + FStarC_SMTEncoding_Env.tcenv + = tcenv'; + FStarC_SMTEncoding_Env.warn + = + (env2.FStarC_SMTEncoding_Env.warn); + FStarC_SMTEncoding_Env.nolabels + = + (env2.FStarC_SMTEncoding_Env.nolabels); + FStarC_SMTEncoding_Env.use_zfuel_name + = + (env2.FStarC_SMTEncoding_Env.use_zfuel_name); + FStarC_SMTEncoding_Env.encode_non_total_function_typ + = + (env2.FStarC_SMTEncoding_Env.encode_non_total_function_typ); + FStarC_SMTEncoding_Env.current_module_name + = + (env2.FStarC_SMTEncoding_Env.current_module_name); + FStarC_SMTEncoding_Env.encoding_quantifier + = + (env2.FStarC_SMTEncoding_Env.encoding_quantifier); + FStarC_SMTEncoding_Env.global_cache + = + (env2.FStarC_SMTEncoding_Env.global_cache) + }, e1, t_norm1)) in + (match uu___9 with + | (env', e1, t_norm1) -> + let uu___10 = + destruct_bound_function t_norm1 e1 in + (match uu___10 with + | (binders, body, t_body_comp) -> + let t_body = + FStarC_Syntax_Util.comp_result + t_body_comp in + ((let uu___12 = + FStarC_Compiler_Effect.op_Bang + dbg_SMTEncoding in + if uu___12 + then + let uu___13 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binder) + binders in + let uu___14 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + body in + FStarC_Compiler_Util.print2 + "Encoding let : binders=[%s], body=%s\n" + uu___13 uu___14 + else ()); + (let uu___12 = + FStarC_SMTEncoding_EncodeTerm.encode_binders + FStar_Pervasives_Native.None + binders env' in + match uu___12 with + | (vars, binder_guards, env'1, + binder_decls, uu___13) -> + let uu___14 = + if + fvb.FStarC_SMTEncoding_Env.fvb_thunked + && (vars = []) + then + let dummy_var = + FStarC_SMTEncoding_Term.mk_fv + ("@dummy", + FStarC_SMTEncoding_Term.dummy_sort) in + let dummy_tm = + FStarC_SMTEncoding_Term.mkFreeV + dummy_var + FStarC_Compiler_Range_Type.dummyRange in + let app = + let uu___15 = + FStarC_Syntax_Syntax.range_of_lbname + lbn in + FStarC_SMTEncoding_Term.mkApp + ((fvb.FStarC_SMTEncoding_Env.smt_id), + [dummy_tm]) + uu___15 in + ([dummy_var], app) + else + (let uu___16 = + let uu___17 = + FStarC_Syntax_Syntax.range_of_lbname + lbn in + let uu___18 = + FStarC_Compiler_List.map + FStarC_SMTEncoding_Util.mkFreeV + vars in + FStarC_SMTEncoding_EncodeTerm.maybe_curry_fvb + uu___17 fvb + uu___18 in + (vars, uu___16)) in + (match uu___14 with + | (vars1, app) -> + let is_logical = + let uu___15 = + let uu___16 = + FStarC_Syntax_Subst.compress + t_body in + uu___16.FStarC_Syntax_Syntax.n in + match uu___15 with + | FStarC_Syntax_Syntax.Tm_fvar + fv when + FStarC_Syntax_Syntax.fv_eq_lid + fv + FStarC_Parser_Const.logical_lid + -> true + | uu___16 -> false in + let is_smt_theory_symbol + = + let fv = + FStarC_Compiler_Util.right + lbn in + FStarC_TypeChecker_Env.fv_has_attr + env2.FStarC_SMTEncoding_Env.tcenv + fv + FStarC_Parser_Const.smt_theory_symbol_attr_lid in + let is_sub_singleton + = + FStarC_Syntax_Util.is_sub_singleton + body in + let should_encode_logical + = + (Prims.op_Negation + is_smt_theory_symbol) + && + ((FStarC_Compiler_List.contains + FStarC_Syntax_Syntax.Logic + quals) + || is_logical) in + let make_eqn name pat + app1 body1 = + let uu___15 = + let uu___16 = + let uu___17 = + FStarC_Syntax_Syntax.range_of_lbname + lbn in + let uu___18 = + let uu___19 = + FStarC_SMTEncoding_Util.mkEq + (app1, + body1) in + ([[pat]], + vars1, + uu___19) in + FStarC_SMTEncoding_Term.mkForall + uu___17 + uu___18 in + let uu___17 = + let uu___18 = + let uu___19 = + FStarC_Ident.string_of_lid + flid in + FStarC_Compiler_Util.format1 + "Equation for %s" + uu___19 in + FStar_Pervasives_Native.Some + uu___18 in + (uu___16, + uu___17, + (Prims.strcat + name + (Prims.strcat + "_" + fvb.FStarC_SMTEncoding_Env.smt_id))) in + FStarC_SMTEncoding_Util.mkAssume + uu___15 in + let uu___15 = + let basic_eqn_name + = + if + should_encode_logical + then + "defn_equation" + else "equation" in + let uu___16 = + let app_is_prop = + FStarC_SMTEncoding_Term.mk_subtype_of_unit + app in + if + should_encode_logical + then + let uu___17 = + is_sub_singleton + && + (let uu___18 + = + FStarC_Options_Ext.get + "retain_old_prop_typing" in + uu___18 = + "") in + (if uu___17 + then + let uu___18 + = + let uu___19 + = + let uu___20 + = + let uu___21 + = + FStarC_Syntax_Syntax.range_of_lbname + lbn in + let uu___22 + = + let uu___23 + = + let uu___24 + = + let uu___25 + = + FStarC_SMTEncoding_Util.mk_and_l + binder_guards in + let uu___26 + = + FStarC_SMTEncoding_Term.mk_Valid + app_is_prop in + (uu___25, + uu___26) in + FStarC_SMTEncoding_Util.mkImp + uu___24 in + ([ + [app_is_prop]], + vars1, + uu___23) in + FStarC_SMTEncoding_Term.mkForall + uu___21 + uu___22 in + let uu___21 + = + let uu___22 + = + let uu___23 + = + FStarC_Ident.string_of_lid + flid in + FStarC_Compiler_Util.format1 + "Prop-typing for %s" + uu___23 in + FStar_Pervasives_Native.Some + uu___22 in + (uu___20, + uu___21, + (Prims.strcat + basic_eqn_name + (Prims.strcat + "_" + fvb.FStarC_SMTEncoding_Env.smt_id))) in + FStarC_SMTEncoding_Util.mkAssume + uu___19 in + (uu___18, + []) + else + (let uu___19 + = + FStarC_SMTEncoding_EncodeTerm.encode_term + body + env'1 in + match uu___19 + with + | (body1, + decls2) + -> + let uu___20 + = + make_eqn + basic_eqn_name + app_is_prop + app body1 in + (uu___20, + decls2))) + else + (let uu___18 = + FStarC_SMTEncoding_EncodeTerm.encode_term + body env'1 in + match uu___18 + with + | (body1, + decls2) -> + let uu___19 + = + make_eqn + basic_eqn_name + app app + body1 in + (uu___19, + decls2)) in + match uu___16 with + | (basic_eqn, + decls2) -> + if + should_encode_logical + then + let uu___17 = + let uu___18 + = + FStarC_SMTEncoding_Term.mk_Valid + app in + let uu___19 + = + FStarC_SMTEncoding_EncodeTerm.encode_formula + body + env'1 in + (app, + uu___18, + uu___19) in + (match uu___17 + with + | (pat, + app1, + (body1, + decls21)) + -> + let logical_eqn + = + make_eqn + "equation" + pat app1 + body1 in + ([logical_eqn; + basic_eqn], + (FStarC_Compiler_List.op_At + decls2 + decls21))) + else + ([basic_eqn], + decls2) in + (match uu___15 with + | (eqns, decls2) -> + let uu___16 = + let uu___17 = + let uu___18 + = + let uu___19 + = + let uu___20 + = + let uu___21 + = + primitive_type_axioms + env2.FStarC_SMTEncoding_Env.tcenv + flid + fvb.FStarC_SMTEncoding_Env.smt_id + app in + FStarC_Compiler_List.op_At + eqns + uu___21 in + FStarC_SMTEncoding_Term.mk_decls_trivial + uu___20 in + FStarC_Compiler_List.op_At + decls2 + uu___19 in + FStarC_Compiler_List.op_At + binder_decls + uu___18 in + FStarC_Compiler_List.op_At + decls1 + uu___17 in + (uu___16, env2))))))) + | uu___5 -> failwith "Impossible" in + let encode_rec_lbdefs bindings1 typs2 toks1 env2 + = + let fuel = + let uu___5 = + let uu___6 = + FStarC_SMTEncoding_Env.varops.FStarC_SMTEncoding_Env.fresh + env2.FStarC_SMTEncoding_Env.current_module_name + "fuel" in + (uu___6, + FStarC_SMTEncoding_Term.Fuel_sort) in + FStarC_SMTEncoding_Term.mk_fv uu___5 in + let fuel_tm = + FStarC_SMTEncoding_Util.mkFreeV fuel in + let env0 = env2 in + let uu___5 = + FStarC_Compiler_List.fold_left + (fun uu___6 -> + fun fvb -> + match uu___6 with + | (gtoks, env3) -> + let flid = + fvb.FStarC_SMTEncoding_Env.fvar_lid in + let g = + let uu___7 = + FStarC_Ident.lid_add_suffix + flid "fuel_instrumented" in + FStarC_SMTEncoding_Env.varops.FStarC_SMTEncoding_Env.new_fvar + uu___7 in + let gtok = + let uu___7 = + FStarC_Ident.lid_add_suffix + flid + "fuel_instrumented_token" in + FStarC_SMTEncoding_Env.varops.FStarC_SMTEncoding_Env.new_fvar + uu___7 in + let env4 = + let uu___7 = + let uu___8 = + FStarC_SMTEncoding_Util.mkApp + (g, [fuel_tm]) in + FStar_Pervasives_Native.Some + uu___8 in + FStarC_SMTEncoding_Env.push_free_var + env3 flid + fvb.FStarC_SMTEncoding_Env.smt_arity + gtok uu___7 in + (((fvb, g, gtok) :: gtoks), env4)) + ([], env2) toks1 in + match uu___5 with + | (gtoks, env3) -> + let gtoks1 = + FStarC_Compiler_List.rev gtoks in + let encode_one_binding env01 uu___6 t_norm + uu___7 = + match (uu___6, uu___7) with + | ((fvb, g, gtok), + { FStarC_Syntax_Syntax.lbname = lbn; + FStarC_Syntax_Syntax.lbunivs = uvs; + FStarC_Syntax_Syntax.lbtyp = uu___8; + FStarC_Syntax_Syntax.lbeff = uu___9; + FStarC_Syntax_Syntax.lbdef = e; + FStarC_Syntax_Syntax.lbattrs = + uu___10; + FStarC_Syntax_Syntax.lbpos = + uu___11;_}) + -> + let uu___12 = + let uu___13 = + FStarC_TypeChecker_Env.open_universes_in + env3.FStarC_SMTEncoding_Env.tcenv + uvs [e; t_norm] in + match uu___13 with + | (tcenv', uu___14, e_t) -> + let uu___15 = + match e_t with + | e1::t_norm1::[] -> + (e1, t_norm1) + | uu___16 -> + failwith "Impossible" in + (match uu___15 with + | (e1, t_norm1) -> + ({ + FStarC_SMTEncoding_Env.bvar_bindings + = + (env3.FStarC_SMTEncoding_Env.bvar_bindings); + FStarC_SMTEncoding_Env.fvar_bindings + = + (env3.FStarC_SMTEncoding_Env.fvar_bindings); + FStarC_SMTEncoding_Env.depth + = + (env3.FStarC_SMTEncoding_Env.depth); + FStarC_SMTEncoding_Env.tcenv + = tcenv'; + FStarC_SMTEncoding_Env.warn + = + (env3.FStarC_SMTEncoding_Env.warn); + FStarC_SMTEncoding_Env.nolabels + = + (env3.FStarC_SMTEncoding_Env.nolabels); + FStarC_SMTEncoding_Env.use_zfuel_name + = + (env3.FStarC_SMTEncoding_Env.use_zfuel_name); + FStarC_SMTEncoding_Env.encode_non_total_function_typ + = + (env3.FStarC_SMTEncoding_Env.encode_non_total_function_typ); + FStarC_SMTEncoding_Env.current_module_name + = + (env3.FStarC_SMTEncoding_Env.current_module_name); + FStarC_SMTEncoding_Env.encoding_quantifier + = + (env3.FStarC_SMTEncoding_Env.encoding_quantifier); + FStarC_SMTEncoding_Env.global_cache + = + (env3.FStarC_SMTEncoding_Env.global_cache) + }, e1, t_norm1)) in + (match uu___12 with + | (env', e1, t_norm1) -> + ((let uu___14 = + FStarC_Compiler_Effect.op_Bang + dbg_SMTEncoding in + if uu___14 + then + let uu___15 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_either + FStarC_Syntax_Print.showable_bv + FStarC_Syntax_Print.showable_fv) + lbn in + let uu___16 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t_norm1 in + let uu___17 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + e1 in + FStarC_Compiler_Util.print3 + "Encoding let rec %s : %s = %s\n" + uu___15 uu___16 uu___17 + else ()); + (let uu___14 = + destruct_bound_function + t_norm1 e1 in + match uu___14 with + | (binders, body, tres_comp) + -> + let curry = + fvb.FStarC_SMTEncoding_Env.smt_arity + <> + (FStarC_Compiler_List.length + binders) in + let uu___15 = + FStarC_TypeChecker_Util.pure_or_ghost_pre_and_post + env3.FStarC_SMTEncoding_Env.tcenv + tres_comp in + (match uu___15 with + | (pre_opt, tres) -> + ((let uu___17 = + FStarC_Compiler_Effect.op_Bang + dbg_SMTEncoding in + if uu___17 + then + let uu___18 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_either + FStarC_Syntax_Print.showable_bv + FStarC_Syntax_Print.showable_fv) + lbn in + let uu___19 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binder) + binders in + let uu___20 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + body in + let uu___21 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_comp + tres_comp in + FStarC_Compiler_Util.print4 + "Encoding let rec %s: \n\tbinders=[%s], \n\tbody=%s, \n\ttres=%s\n" + uu___18 + uu___19 + uu___20 + uu___21 + else ()); + (let uu___17 = + FStarC_SMTEncoding_EncodeTerm.encode_binders + FStar_Pervasives_Native.None + binders env' in + match uu___17 with + | (vars, guards, + env'1, + binder_decls, + uu___18) -> + let uu___19 = + match pre_opt + with + | FStar_Pervasives_Native.None + -> + let uu___20 + = + FStarC_SMTEncoding_Util.mk_and_l + guards in + (uu___20, + []) + | FStar_Pervasives_Native.Some + pre -> + let uu___20 + = + FStarC_SMTEncoding_EncodeTerm.encode_formula + pre env'1 in + (match uu___20 + with + | + (guard, + decls0) + -> + let uu___21 + = + FStarC_SMTEncoding_Util.mk_and_l + (FStarC_Compiler_List.op_At + guards + [guard]) in + (uu___21, + decls0)) in + (match uu___19 + with + | (guard, + guard_decls) + -> + let binder_decls1 + = + FStarC_Compiler_List.op_At + binder_decls + guard_decls in + let decl_g + = + let uu___20 + = + let uu___21 + = + let uu___22 + = + let uu___23 + = + let uu___24 + = + FStarC_Compiler_Util.first_N + fvb.FStarC_SMTEncoding_Env.smt_arity + vars in + FStar_Pervasives_Native.fst + uu___24 in + FStarC_Compiler_List.map + FStarC_SMTEncoding_Term.fv_sort + uu___23 in + FStarC_SMTEncoding_Term.Fuel_sort + :: + uu___22 in + (g, + uu___21, + FStarC_SMTEncoding_Term.Term_sort, + (FStar_Pervasives_Native.Some + "Fuel-instrumented function name")) in + FStarC_SMTEncoding_Term.DeclFun + uu___20 in + let decl_g_tok + = + FStarC_SMTEncoding_Term.DeclFun + (gtok, + [], + FStarC_SMTEncoding_Term.Term_sort, + (FStar_Pervasives_Native.Some + "Token for fuel-instrumented partial applications")) in + let env02 + = + FStarC_SMTEncoding_Env.push_zfuel_name + env01 + fvb.FStarC_SMTEncoding_Env.fvar_lid + g gtok in + let vars_tm + = + FStarC_Compiler_List.map + FStarC_SMTEncoding_Util.mkFreeV + vars in + let rng = + FStarC_Syntax_Syntax.range_of_lbname + lbn in + let app = + let uu___20 + = + FStarC_Compiler_List.map + FStarC_SMTEncoding_Util.mkFreeV + vars in + FStarC_SMTEncoding_EncodeTerm.maybe_curry_fvb + rng fvb + uu___20 in + let mk_g_app + args = + FStarC_SMTEncoding_EncodeTerm.maybe_curry_app + rng + (FStar_Pervasives.Inl + (FStarC_SMTEncoding_Term.Var + g)) + (fvb.FStarC_SMTEncoding_Env.smt_arity + + + Prims.int_one) + args in + let gsapp + = + let uu___20 + = + let uu___21 + = + FStarC_SMTEncoding_Util.mkApp + ("SFuel", + [fuel_tm]) in + uu___21 + :: + vars_tm in + mk_g_app + uu___20 in + let gmax + = + let uu___20 + = + let uu___21 + = + FStarC_SMTEncoding_Util.mkApp + ("MaxFuel", + []) in + uu___21 + :: + vars_tm in + mk_g_app + uu___20 in + let uu___20 + = + FStarC_SMTEncoding_EncodeTerm.encode_term + body + env'1 in + (match uu___20 + with + | + (body_tm, + decls2) + -> + let eqn_g + = + let uu___21 + = + let uu___22 + = + let uu___23 + = + FStarC_Syntax_Syntax.range_of_lbname + lbn in + let uu___24 + = + let uu___25 + = + let uu___26 + = + let uu___27 + = + FStarC_SMTEncoding_Util.mkEq + (gsapp, + body_tm) in + (guard, + uu___27) in + FStarC_SMTEncoding_Util.mkImp + uu___26 in + ([ + [gsapp]], + (FStar_Pervasives_Native.Some + Prims.int_zero), + (fuel :: + vars), + uu___25) in + FStarC_SMTEncoding_Term.mkForall' + uu___23 + uu___24 in + let uu___23 + = + let uu___24 + = + let uu___25 + = + FStarC_Ident.string_of_lid + fvb.FStarC_SMTEncoding_Env.fvar_lid in + FStarC_Compiler_Util.format1 + "Equation for fuel-instrumented recursive function: %s" + uu___25 in + FStar_Pervasives_Native.Some + uu___24 in + (uu___22, + uu___23, + (Prims.strcat + "equation_with_fuel_" + g)) in + FStarC_SMTEncoding_Util.mkAssume + uu___21 in + let eqn_f + = + let uu___21 + = + let uu___22 + = + let uu___23 + = + FStarC_Syntax_Syntax.range_of_lbname + lbn in + let uu___24 + = + let uu___25 + = + FStarC_SMTEncoding_Util.mkEq + (app, + gmax) in + ([[app]], + vars, + uu___25) in + FStarC_SMTEncoding_Term.mkForall + uu___23 + uu___24 in + (uu___22, + (FStar_Pervasives_Native.Some + "Correspondence of recursive function to instrumented version"), + (Prims.strcat + "@fuel_correspondence_" + g)) in + FStarC_SMTEncoding_Util.mkAssume + uu___21 in + let eqn_g' + = + let uu___21 + = + let uu___22 + = + let uu___23 + = + FStarC_Syntax_Syntax.range_of_lbname + lbn in + let uu___24 + = + let uu___25 + = + let uu___26 + = + let uu___27 + = + let uu___28 + = + let uu___29 + = + FStarC_SMTEncoding_Term.n_fuel + Prims.int_zero in + uu___29 + :: + vars_tm in + mk_g_app + uu___28 in + (gsapp, + uu___27) in + FStarC_SMTEncoding_Util.mkEq + uu___26 in + ([ + [gsapp]], + (fuel :: + vars), + uu___25) in + FStarC_SMTEncoding_Term.mkForall + uu___23 + uu___24 in + (uu___22, + (FStar_Pervasives_Native.Some + "Fuel irrelevance"), + (Prims.strcat + "@fuel_irrelevance_" + g)) in + FStarC_SMTEncoding_Util.mkAssume + uu___21 in + let uu___21 + = + let gapp + = + mk_g_app + (fuel_tm + :: + vars_tm) in + let tok_corr + = + let tok_app + = + let uu___22 + = + let uu___23 + = + FStarC_SMTEncoding_Term.mk_fv + (gtok, + FStarC_SMTEncoding_Term.Term_sort) in + FStarC_SMTEncoding_Util.mkFreeV + uu___23 in + FStarC_SMTEncoding_EncodeTerm.mk_Apply + uu___22 + (fuel :: + vars) in + let tot_fun_axioms + = + let head + = + let uu___22 + = + FStarC_SMTEncoding_Term.mk_fv + (gtok, + FStarC_SMTEncoding_Term.Term_sort) in + FStarC_SMTEncoding_Util.mkFreeV + uu___22 in + let vars1 + = fuel :: + vars in + let guards1 + = + FStarC_Compiler_List.map + (fun + uu___22 + -> + FStarC_SMTEncoding_Util.mkTrue) + vars1 in + let uu___22 + = + FStarC_Syntax_Util.is_pure_comp + tres_comp in + FStarC_SMTEncoding_EncodeTerm.isTotFun_axioms + rng head + vars1 + guards1 + uu___22 in + let uu___22 + = + let uu___23 + = + let uu___24 + = + let uu___25 + = + let uu___26 + = + FStarC_Syntax_Syntax.range_of_lbname + lbn in + let uu___27 + = + let uu___28 + = + FStarC_SMTEncoding_Util.mkEq + (tok_app, + gapp) in + ([ + [tok_app]], + (fuel :: + vars), + uu___28) in + FStarC_SMTEncoding_Term.mkForall + uu___26 + uu___27 in + (uu___25, + tot_fun_axioms) in + FStarC_SMTEncoding_Util.mkAnd + uu___24 in + (uu___23, + (FStar_Pervasives_Native.Some + "Fuel token correspondence"), + (Prims.strcat + "fuel_token_correspondence_" + gtok)) in + FStarC_SMTEncoding_Util.mkAssume + uu___22 in + let uu___22 + = + let uu___23 + = + FStarC_SMTEncoding_EncodeTerm.encode_term_pred + FStar_Pervasives_Native.None + tres + env'1 + gapp in + match uu___23 + with + | + (g_typing, + d3) -> + let uu___24 + = + let uu___25 + = + let uu___26 + = + let uu___27 + = + let uu___28 + = + FStarC_Syntax_Syntax.range_of_lbname + lbn in + let uu___29 + = + let uu___30 + = + FStarC_SMTEncoding_Util.mkImp + (guard, + g_typing) in + ([[gapp]], + (fuel :: + vars), + uu___30) in + FStarC_SMTEncoding_Term.mkForall + uu___28 + uu___29 in + (uu___27, + (FStar_Pervasives_Native.Some + "Typing correspondence of token to term"), + (Prims.strcat + "token_correspondence_" + g)) in + FStarC_SMTEncoding_Util.mkAssume + uu___26 in + [uu___25] in + (d3, + uu___24) in + match uu___22 + with + | + (aux_decls, + typing_corr) + -> + (aux_decls, + (FStarC_Compiler_List.op_At + typing_corr + [tok_corr])) in + (match uu___21 + with + | + (aux_decls, + g_typing) + -> + let uu___22 + = + let uu___23 + = + let uu___24 + = + let uu___25 + = + FStarC_SMTEncoding_Term.mk_decls_trivial + [decl_g; + decl_g_tok] in + FStarC_Compiler_List.op_At + aux_decls + uu___25 in + FStarC_Compiler_List.op_At + decls2 + uu___24 in + FStarC_Compiler_List.op_At + binder_decls1 + uu___23 in + let uu___23 + = + FStarC_SMTEncoding_Term.mk_decls_trivial + (FStarC_Compiler_List.op_At + [eqn_g; + eqn_g'; + eqn_f] + g_typing) in + (uu___22, + uu___23, + env02)))))))))) in + let uu___6 = + let uu___7 = + FStarC_Compiler_List.zip3 gtoks1 typs2 + bindings1 in + FStarC_Compiler_List.fold_left + (fun uu___8 -> + fun uu___9 -> + match (uu___8, uu___9) with + | ((decls2, eqns, env01), + (gtok, ty, lb)) -> + let uu___10 = + encode_one_binding env01 + gtok ty lb in + (match uu___10 with + | (decls', eqns', env02) -> + ((decls' :: decls2), + (FStarC_Compiler_List.op_At + eqns' eqns), env02))) + ([decls1], [], env0) uu___7 in + (match uu___6 with + | (decls2, eqns, env01) -> + let uu___7 = + let isDeclFun uu___8 = + match uu___8 with + | FStarC_SMTEncoding_Term.DeclFun + uu___9 -> true + | uu___9 -> false in + let uu___8 = + FStarC_Compiler_List.fold_left + (fun uu___9 -> + fun elt -> + match uu___9 with + | (prefix_decls, elts, + rest) -> + let uu___10 = + (FStarC_Compiler_Util.is_some + elt.FStarC_SMTEncoding_Term.key) + && + (FStarC_Compiler_List.existsb + isDeclFun + elt.FStarC_SMTEncoding_Term.decls) in + if uu___10 + then + (prefix_decls, + (FStarC_Compiler_List.op_At + elts [elt]), + rest) + else + (let uu___12 = + FStarC_Compiler_List.partition + isDeclFun + elt.FStarC_SMTEncoding_Term.decls in + match uu___12 with + | (elt_decl_funs, + elt_rest) -> + ((FStarC_Compiler_List.op_At + prefix_decls + elt_decl_funs), + elts, + (FStarC_Compiler_List.op_At + rest + [{ + FStarC_SMTEncoding_Term.sym_name + = + (elt.FStarC_SMTEncoding_Term.sym_name); + FStarC_SMTEncoding_Term.key + = + (elt.FStarC_SMTEncoding_Term.key); + FStarC_SMTEncoding_Term.decls + = + elt_rest; + FStarC_SMTEncoding_Term.a_names + = + (elt.FStarC_SMTEncoding_Term.a_names) + }])))) + ([], [], []) + (FStarC_Compiler_List.flatten + decls2) in + match uu___8 with + | (prefix_decls, elts, rest) -> + let uu___9 = + FStarC_SMTEncoding_Term.mk_decls_trivial + prefix_decls in + (uu___9, elts, rest) in + (match uu___7 with + | (prefix_decls, elts, rest) -> + let eqns1 = + FStarC_Compiler_List.rev eqns in + ((FStarC_Compiler_List.op_At + prefix_decls + (FStarC_Compiler_List.op_At + elts + (FStarC_Compiler_List.op_At + rest eqns1))), env01))) in + let uu___5 = + (FStarC_Compiler_Util.for_some + (fun uu___6 -> + match uu___6 with + | FStarC_Syntax_Syntax.HasMaskedEffect + -> true + | uu___7 -> false) quals) + || + (FStarC_Compiler_Util.for_some + (fun t -> + let uu___6 = + (FStarC_Syntax_Util.is_pure_or_ghost_function + t) + || + (FStarC_SMTEncoding_Util.is_smt_reifiable_function + env1.FStarC_SMTEncoding_Env.tcenv + t) in + Prims.op_Negation uu___6) typs1) in + if uu___5 + then (decls1, env_decls) + else + (try + (fun uu___7 -> + match () with + | () -> + if Prims.op_Negation is_rec + then + encode_non_rec_lbdef bindings + typs1 toks_fvbs env1 + else + encode_rec_lbdefs bindings typs1 + toks_fvbs env1) () + with + | FStarC_SMTEncoding_Env.Inner_let_rec names + -> + let plural = + (FStarC_Compiler_List.length names) > + Prims.int_one in + let r = + let uu___8 = + FStarC_Compiler_List.hd names in + FStar_Pervasives_Native.snd uu___8 in + ((let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + FStarC_Compiler_List.map + FStar_Pervasives_Native.fst + names in + FStarC_Compiler_String.concat + "," uu___15 in + FStarC_Compiler_Util.format3 + "Definitions of inner let-rec%s %s and %s enclosing top-level letbinding are not encoded to the solver, you will only be able to reason with their types" + (if plural then "s" else "") + uu___14 + (if plural + then "their" + else "its") in + FStarC_Errors_Msg.text uu___13 in + [uu___12] in + let uu___12 = + FStarC_Errors.get_ctx () in + (FStarC_Errors_Codes.Warning_DefinitionNotTranslated, + uu___11, r, uu___12) in + [uu___10] in + FStarC_TypeChecker_Err.add_errors + env1.FStarC_SMTEncoding_Env.tcenv + uu___9); + (decls1, env_decls))))) () + with + | Let_rec_unencodeable -> + let msg = + let uu___2 = + FStarC_Compiler_List.map + (fun lb -> + FStarC_Class_Show.show + (FStarC_Class_Show.show_either + FStarC_Syntax_Print.showable_bv + FStarC_Syntax_Print.showable_fv) + lb.FStarC_Syntax_Syntax.lbname) bindings in + FStarC_Compiler_String.concat " and " uu___2 in + let decl = + FStarC_SMTEncoding_Term.Caption + (Prims.strcat "let rec unencodeable: Skipping: " msg) in + let uu___2 = FStarC_SMTEncoding_Term.mk_decls_trivial [decl] in + (uu___2, env)) +let (encode_sig_inductive : + FStarC_SMTEncoding_Env.env_t -> + FStarC_Syntax_Syntax.sigelt -> + (FStarC_SMTEncoding_Term.decls_t * FStarC_SMTEncoding_Env.env_t)) + = + fun env -> + fun se -> + let uu___ = se.FStarC_Syntax_Syntax.sigel in + match uu___ with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = t; + FStarC_Syntax_Syntax.us = universe_names; + FStarC_Syntax_Syntax.params = tps; + FStarC_Syntax_Syntax.num_uniform_params = uu___1; + FStarC_Syntax_Syntax.t = k; + FStarC_Syntax_Syntax.mutuals = uu___2; + FStarC_Syntax_Syntax.ds = datas; + FStarC_Syntax_Syntax.injective_type_params = + injective_type_params;_} + -> + let t_lid = t in + let tcenv = env.FStarC_SMTEncoding_Env.tcenv in + let quals = se.FStarC_Syntax_Syntax.sigquals in + let is_logical = + FStarC_Compiler_Util.for_some + (fun uu___3 -> + match uu___3 with + | FStarC_Syntax_Syntax.Logic -> true + | FStarC_Syntax_Syntax.Assumption -> true + | uu___4 -> false) quals in + let constructor_or_logic_type_decl c = + if is_logical + then + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Compiler_List.map + (fun f -> f.FStarC_SMTEncoding_Term.field_sort) + c.FStarC_SMTEncoding_Term.constr_fields in + ((c.FStarC_SMTEncoding_Term.constr_name), uu___5, + FStarC_SMTEncoding_Term.Term_sort, + FStar_Pervasives_Native.None) in + FStarC_SMTEncoding_Term.DeclFun uu___4 in + [uu___3] + else + (let uu___4 = FStarC_Ident.range_of_lid t in + FStarC_SMTEncoding_Term.constructor_to_decl uu___4 c) in + let inversion_axioms env1 tapp vars = + let uu___3 = + FStarC_Compiler_Util.for_some + (fun l -> + let uu___4 = + FStarC_TypeChecker_Env.try_lookup_lid + env1.FStarC_SMTEncoding_Env.tcenv l in + FStarC_Compiler_Option.isNone uu___4) datas in + if uu___3 + then [] + else + (let uu___5 = + FStarC_SMTEncoding_Env.fresh_fvar + env1.FStarC_SMTEncoding_Env.current_module_name "x" + FStarC_SMTEncoding_Term.Term_sort in + match uu___5 with + | (xxsym, xx) -> + let uu___6 = + FStarC_Compiler_List.fold_left + (fun uu___7 -> + fun l -> + match uu___7 with + | (out, decls) -> + let is_l = + FStarC_SMTEncoding_Env.mk_data_tester env1 + l xx in + let uu___8 = + let uu___9 = + injective_type_params || + (let uu___10 = + FStarC_Options_Ext.get + "compat:injectivity" in + uu___10 <> "") in + if uu___9 + then + let uu___10 = + FStarC_TypeChecker_Env.lookup_datacon + env1.FStarC_SMTEncoding_Env.tcenv l in + match uu___10 with + | (uu___11, data_t) -> + let uu___12 = + FStarC_Syntax_Util.arrow_formals + data_t in + (match uu___12 with + | (args, res) -> + let indices = + let uu___13 = + FStarC_Syntax_Util.head_and_args_full + res in + FStar_Pervasives_Native.snd + uu___13 in + let env2 = + FStarC_Compiler_List.fold_left + (fun env3 -> + fun uu___13 -> + match uu___13 with + | { + FStarC_Syntax_Syntax.binder_bv + = x; + FStarC_Syntax_Syntax.binder_qual + = uu___14; + FStarC_Syntax_Syntax.binder_positivity + = uu___15; + FStarC_Syntax_Syntax.binder_attrs + = uu___16;_} + -> + let uu___17 = + let uu___18 = + let uu___19 = + FStarC_SMTEncoding_Env.mk_term_projector_name + l x in + (uu___19, [xx]) in + FStarC_SMTEncoding_Util.mkApp + uu___18 in + FStarC_SMTEncoding_Env.push_term_var + env3 x uu___17) + env1 args in + let uu___13 = + FStarC_SMTEncoding_EncodeTerm.encode_args + indices env2 in + (match uu___13 with + | (indices1, decls') -> + (if + (FStarC_Compiler_List.length + indices1) + <> + (FStarC_Compiler_List.length + vars) + then failwith "Impossible" + else (); + (let eqs = + FStarC_Compiler_List.map2 + (fun v -> + fun a -> + let uu___15 = + let uu___16 = + FStarC_SMTEncoding_Util.mkFreeV + v in + (uu___16, a) in + FStarC_SMTEncoding_Util.mkEq + uu___15) vars + indices1 in + let uu___15 = + let uu___16 = + let uu___17 = + FStarC_SMTEncoding_Util.mk_and_l + eqs in + (is_l, uu___17) in + FStarC_SMTEncoding_Util.mkAnd + uu___16 in + (uu___15, decls'))))) + else (is_l, []) in + (match uu___8 with + | (inversion_case, decls') -> + let uu___9 = + FStarC_SMTEncoding_Util.mkOr + (out, inversion_case) in + (uu___9, + (FStarC_Compiler_List.op_At decls + decls')))) + (FStarC_SMTEncoding_Util.mkFalse, []) datas in + (match uu___6 with + | (data_ax, decls) -> + let uu___7 = + FStarC_SMTEncoding_Env.fresh_fvar + env1.FStarC_SMTEncoding_Env.current_module_name + "f" FStarC_SMTEncoding_Term.Fuel_sort in + (match uu___7 with + | (ffsym, ff) -> + let fuel_guarded_inversion = + let xx_has_type_sfuel = + if + (FStarC_Compiler_List.length datas) > + Prims.int_one + then + let uu___8 = + FStarC_SMTEncoding_Util.mkApp + ("SFuel", [ff]) in + FStarC_SMTEncoding_Term.mk_HasTypeFuel + uu___8 xx tapp + else + FStarC_SMTEncoding_Term.mk_HasTypeFuel ff + xx tapp in + let uu___8 = + let uu___9 = + let uu___10 = FStarC_Ident.range_of_lid t in + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_SMTEncoding_Term.mk_fv + (ffsym, + FStarC_SMTEncoding_Term.Fuel_sort) in + let uu___14 = + let uu___15 = + FStarC_SMTEncoding_Term.mk_fv + (xxsym, + FStarC_SMTEncoding_Term.Term_sort) in + uu___15 :: vars in + FStarC_SMTEncoding_Env.add_fuel + uu___13 uu___14 in + let uu___13 = + FStarC_SMTEncoding_Util.mkImp + (xx_has_type_sfuel, data_ax) in + ([[xx_has_type_sfuel]], uu___12, + uu___13) in + FStarC_SMTEncoding_Term.mkForall uu___10 + uu___11 in + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Ident.string_of_lid t in + Prims.strcat "fuel_guarded_inversion_" + uu___12 in + FStarC_SMTEncoding_Env.varops.FStarC_SMTEncoding_Env.mk_unique + uu___11 in + (uu___9, + (FStar_Pervasives_Native.Some + "inversion axiom"), uu___10) in + FStarC_SMTEncoding_Util.mkAssume uu___8 in + let uu___8 = + FStarC_SMTEncoding_Term.mk_decls_trivial + [fuel_guarded_inversion] in + FStarC_Compiler_List.op_At decls uu___8))) in + let uu___3 = + let k1 = + match tps with + | [] -> k + | uu___4 -> + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Syntax_Syntax.mk_Total k in + { + FStarC_Syntax_Syntax.bs1 = tps; + FStarC_Syntax_Syntax.comp = uu___7 + } in + FStarC_Syntax_Syntax.Tm_arrow uu___6 in + FStarC_Syntax_Syntax.mk uu___5 k.FStarC_Syntax_Syntax.pos in + let k2 = norm_before_encoding env k1 in + FStarC_Syntax_Util.arrow_formals k2 in + (match uu___3 with + | (formals, res) -> + let uu___4 = + FStarC_SMTEncoding_EncodeTerm.encode_binders + FStar_Pervasives_Native.None formals env in + (match uu___4 with + | (vars, guards, env', binder_decls, uu___5) -> + let arity = FStarC_Compiler_List.length vars in + let uu___6 = + FStarC_SMTEncoding_Env.new_term_constant_and_tok_from_lid + env t arity in + (match uu___6 with + | (tname, ttok, env1) -> + let ttok_tm = + FStarC_SMTEncoding_Util.mkApp (ttok, []) in + let guard = FStarC_SMTEncoding_Util.mk_and_l guards in + let tapp = + let uu___7 = + let uu___8 = + FStarC_Compiler_List.map + FStarC_SMTEncoding_Util.mkFreeV vars in + (tname, uu___8) in + FStarC_SMTEncoding_Util.mkApp uu___7 in + let uu___7 = + let tname_decl = + let uu___8 = + let uu___9 = + FStarC_Compiler_List.map + (fun fv -> + let uu___10 = + let uu___11 = + FStarC_SMTEncoding_Term.fv_name fv in + Prims.strcat tname uu___11 in + let uu___11 = + FStarC_SMTEncoding_Term.fv_sort fv in + { + FStarC_SMTEncoding_Term.field_name = + uu___10; + FStarC_SMTEncoding_Term.field_sort = + uu___11; + FStarC_SMTEncoding_Term.field_projectible + = false + }) vars in + let uu___10 = + let uu___11 = + FStarC_SMTEncoding_Env.varops.FStarC_SMTEncoding_Env.next_id + () in + FStar_Pervasives_Native.Some uu___11 in + { + FStarC_SMTEncoding_Term.constr_name = tname; + FStarC_SMTEncoding_Term.constr_fields = + uu___9; + FStarC_SMTEncoding_Term.constr_sort = + FStarC_SMTEncoding_Term.Term_sort; + FStarC_SMTEncoding_Term.constr_id = uu___10; + FStarC_SMTEncoding_Term.constr_base = false + } in + constructor_or_logic_type_decl uu___8 in + let uu___8 = + match vars with + | [] -> + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_SMTEncoding_Util.mkApp + (tname, []) in + FStar_Pervasives_Native.Some uu___11 in + FStarC_SMTEncoding_Env.push_free_var env1 + t arity tname uu___10 in + ([], uu___9) + | uu___9 -> + let ttok_decl = + FStarC_SMTEncoding_Term.DeclFun + (ttok, [], + FStarC_SMTEncoding_Term.Term_sort, + (FStar_Pervasives_Native.Some "token")) in + let ttok_fresh = + let uu___10 = + FStarC_SMTEncoding_Env.varops.FStarC_SMTEncoding_Env.next_id + () in + FStarC_SMTEncoding_Term.fresh_token + (ttok, + FStarC_SMTEncoding_Term.Term_sort) + uu___10 in + let ttok_app = + FStarC_SMTEncoding_EncodeTerm.mk_Apply + ttok_tm vars in + let pats = [[ttok_app]; [tapp]] in + let name_tok_corr = + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Ident.range_of_lid t in + let uu___13 = + let uu___14 = + FStarC_SMTEncoding_Util.mkEq + (ttok_app, tapp) in + (pats, FStar_Pervasives_Native.None, + vars, uu___14) in + FStarC_SMTEncoding_Term.mkForall' + uu___12 uu___13 in + (uu___11, + (FStar_Pervasives_Native.Some + "name-token correspondence"), + (Prims.strcat "token_correspondence_" + ttok)) in + FStarC_SMTEncoding_Util.mkAssume uu___10 in + ([ttok_decl; ttok_fresh; name_tok_corr], + env1) in + match uu___8 with + | (tok_decls, env2) -> + ((FStarC_Compiler_List.op_At tname_decl + tok_decls), env2) in + (match uu___7 with + | (decls, env2) -> + let kindingAx = + let uu___8 = + FStarC_SMTEncoding_EncodeTerm.encode_term_pred + FStar_Pervasives_Native.None res env' + tapp in + match uu___8 with + | (k1, decls1) -> + let karr = + if + (FStarC_Compiler_List.length formals) + > Prims.int_zero + then + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_SMTEncoding_Term.mk_PreType + ttok_tm in + FStarC_SMTEncoding_Term.mk_tester + "Tm_arrow" uu___12 in + (uu___11, + (FStar_Pervasives_Native.Some + "kinding"), + (Prims.strcat "pre_kinding_" + ttok)) in + FStarC_SMTEncoding_Util.mkAssume + uu___10 in + [uu___9] + else [] in + let rng = FStarC_Ident.range_of_lid t in + let tot_fun_axioms = + let uu___9 = + FStarC_Compiler_List.map + (fun uu___10 -> + FStarC_SMTEncoding_Util.mkTrue) + vars in + FStarC_SMTEncoding_EncodeTerm.isTotFun_axioms + rng ttok_tm vars uu___9 true in + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = + let uu___17 = + let uu___18 = + FStarC_SMTEncoding_Util.mkImp + (guard, k1) in + ([[tapp]], vars, + uu___18) in + FStarC_SMTEncoding_Term.mkForall + rng uu___17 in + (tot_fun_axioms, uu___16) in + FStarC_SMTEncoding_Util.mkAnd + uu___15 in + (uu___14, + FStar_Pervasives_Native.None, + (Prims.strcat "kinding_" ttok)) in + FStarC_SMTEncoding_Util.mkAssume + uu___13 in + [uu___12] in + FStarC_Compiler_List.op_At karr + uu___11 in + FStarC_SMTEncoding_Term.mk_decls_trivial + uu___10 in + FStarC_Compiler_List.op_At decls1 uu___9 in + let aux = + let uu___8 = + let uu___9 = + inversion_axioms env2 tapp vars in + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Ident.range_of_lid t in + pretype_axiom + (Prims.op_Negation + injective_type_params) uu___13 + env2 tapp vars in + [uu___12] in + FStarC_SMTEncoding_Term.mk_decls_trivial + uu___11 in + FStarC_Compiler_List.op_At uu___9 uu___10 in + FStarC_Compiler_List.op_At kindingAx uu___8 in + let uu___8 = + let uu___9 = + FStarC_SMTEncoding_Term.mk_decls_trivial + decls in + FStarC_Compiler_List.op_At uu___9 + (FStarC_Compiler_List.op_At binder_decls + aux) in + (uu___8, env2))))) +let (encode_datacon : + FStarC_SMTEncoding_Env.env_t -> + FStarC_Syntax_Syntax.sigelt -> + (FStarC_SMTEncoding_Term.decls_t * FStarC_SMTEncoding_Env.env_t)) + = + fun env -> + fun se -> + let uu___ = se.FStarC_Syntax_Syntax.sigel in + match uu___ with + | FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = d; FStarC_Syntax_Syntax.us1 = us; + FStarC_Syntax_Syntax.t1 = t; + FStarC_Syntax_Syntax.ty_lid = uu___1; + FStarC_Syntax_Syntax.num_ty_params = n_tps; + FStarC_Syntax_Syntax.mutuals1 = mutuals; + FStarC_Syntax_Syntax.injective_type_params1 = + injective_type_params;_} + -> + let quals = se.FStarC_Syntax_Syntax.sigquals in + let t1 = norm_before_encoding_us env us t in + let uu___2 = FStarC_Syntax_Util.arrow_formals t1 in + (match uu___2 with + | (formals, t_res) -> + let arity = FStarC_Compiler_List.length formals in + let uu___3 = + FStarC_SMTEncoding_Env.new_term_constant_and_tok_from_lid + env d arity in + (match uu___3 with + | (ddconstrsym, ddtok, env1) -> + let ddtok_tm = FStarC_SMTEncoding_Util.mkApp (ddtok, []) in + let uu___4 = + FStarC_SMTEncoding_Env.fresh_fvar + env1.FStarC_SMTEncoding_Env.current_module_name "f" + FStarC_SMTEncoding_Term.Fuel_sort in + (match uu___4 with + | (fuel_var, fuel_tm) -> + let s_fuel_tm = + FStarC_SMTEncoding_Util.mkApp ("SFuel", [fuel_tm]) in + let uu___5 = + FStarC_SMTEncoding_EncodeTerm.encode_binders + (FStar_Pervasives_Native.Some fuel_tm) formals + env1 in + (match uu___5 with + | (vars, guards, env', binder_decls, names) -> + let injective_type_params1 = + injective_type_params || + (let uu___6 = + FStarC_Options_Ext.get + "compat:injectivity" in + uu___6 <> "") in + let fields = + FStarC_Compiler_List.mapi + (fun n -> + fun x -> + let field_projectible = + (n >= n_tps) || + injective_type_params1 in + let uu___6 = + FStarC_SMTEncoding_Env.mk_term_projector_name + d x in + { + FStarC_SMTEncoding_Term.field_name = + uu___6; + FStarC_SMTEncoding_Term.field_sort = + FStarC_SMTEncoding_Term.Term_sort; + FStarC_SMTEncoding_Term.field_projectible + = field_projectible + }) names in + let datacons = + let uu___6 = FStarC_Ident.range_of_lid d in + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_SMTEncoding_Env.varops.FStarC_SMTEncoding_Env.next_id + () in + FStar_Pervasives_Native.Some uu___9 in + { + FStarC_SMTEncoding_Term.constr_name = + ddconstrsym; + FStarC_SMTEncoding_Term.constr_fields = + fields; + FStarC_SMTEncoding_Term.constr_sort = + FStarC_SMTEncoding_Term.Term_sort; + FStarC_SMTEncoding_Term.constr_id = + uu___8; + FStarC_SMTEncoding_Term.constr_base = + (Prims.op_Negation + injective_type_params1) + } in + FStarC_SMTEncoding_Term.constructor_to_decl + uu___6 uu___7 in + let app = + FStarC_SMTEncoding_EncodeTerm.mk_Apply + ddtok_tm vars in + let guard = + FStarC_SMTEncoding_Util.mk_and_l guards in + let xvars = + FStarC_Compiler_List.map + FStarC_SMTEncoding_Util.mkFreeV vars in + let dapp = + FStarC_SMTEncoding_Util.mkApp + (ddconstrsym, xvars) in + let uu___6 = + FStarC_SMTEncoding_EncodeTerm.encode_term_pred + FStar_Pervasives_Native.None t1 env1 + ddtok_tm in + (match uu___6 with + | (tok_typing, decls3) -> + let tok_typing1 = + match fields with + | uu___7::uu___8 -> + let ff = + FStarC_SMTEncoding_Term.mk_fv + ("ty", + FStarC_SMTEncoding_Term.Term_sort) in + let f = + FStarC_SMTEncoding_Util.mkFreeV ff in + let vtok_app_l = + FStarC_SMTEncoding_EncodeTerm.mk_Apply + ddtok_tm [ff] in + let vtok_app_r = + let uu___9 = + let uu___10 = + FStarC_SMTEncoding_Term.mk_fv + (ddtok, + FStarC_SMTEncoding_Term.Term_sort) in + [uu___10] in + FStarC_SMTEncoding_EncodeTerm.mk_Apply + f uu___9 in + let uu___9 = + FStarC_Ident.range_of_lid d in + let uu___10 = + let uu___11 = + FStarC_SMTEncoding_Term.mk_NoHoist + f tok_typing in + ([[vtok_app_l]; [vtok_app_r]], + [ff], uu___11) in + FStarC_SMTEncoding_Term.mkForall + uu___9 uu___10 + | uu___7 -> tok_typing in + let uu___7 = + let uu___8 = + FStarC_SMTEncoding_EncodeTerm.encode_term + t_res env' in + match uu___8 with + | (t_res_tm, t_res_decls) -> + let uu___9 = + FStarC_SMTEncoding_Term.mk_HasTypeWithFuel + (FStar_Pervasives_Native.Some + fuel_tm) dapp t_res_tm in + (uu___9, t_res_tm, t_res_decls) in + (match uu___7 with + | (ty_pred', t_res_tm, decls_pred) -> + let proxy_fresh = + match formals with + | [] -> [] + | uu___8 -> + let uu___9 = + let uu___10 = + FStarC_SMTEncoding_Env.varops.FStarC_SMTEncoding_Env.next_id + () in + FStarC_SMTEncoding_Term.fresh_token + (ddtok, + FStarC_SMTEncoding_Term.Term_sort) + uu___10 in + [uu___9] in + let encode_elim uu___8 = + let uu___9 = + FStarC_Syntax_Util.head_and_args + t_res in + match uu___9 with + | (head, args) -> + let uu___10 = + let uu___11 = + FStarC_Syntax_Subst.compress + head in + uu___11.FStarC_Syntax_Syntax.n in + (match uu___10 with + | FStarC_Syntax_Syntax.Tm_uinst + ({ + FStarC_Syntax_Syntax.n + = + FStarC_Syntax_Syntax.Tm_fvar + fv; + FStarC_Syntax_Syntax.pos + = uu___11; + FStarC_Syntax_Syntax.vars + = uu___12; + FStarC_Syntax_Syntax.hash_code + = uu___13;_}, + uu___14) + -> + let encoded_head_fvb = + FStarC_SMTEncoding_Env.lookup_free_var_name + env' + fv.FStarC_Syntax_Syntax.fv_name in + let uu___15 = + FStarC_SMTEncoding_EncodeTerm.encode_args + args env' in + (match uu___15 with + | (encoded_args, + arg_decls) -> + let uu___16 = + let uu___17 = + FStarC_Compiler_List.zip + args + encoded_args in + FStarC_Compiler_List.fold_left + (fun uu___18 -> + fun uu___19 -> + match + (uu___18, + uu___19) + with + | ((env2, + arg_vars, + eqns_or_guards, + i), + (orig_arg, + arg)) -> + let uu___20 + = + let uu___21 + = + FStarC_Syntax_Syntax.new_bv + FStar_Pervasives_Native.None + FStarC_Syntax_Syntax.tun in + FStarC_SMTEncoding_Env.gen_term_var + env2 + uu___21 in + (match uu___20 + with + | + (uu___21, + xv, env3) + -> + let eqns + = + if + i < n_tps + then + eqns_or_guards + else + (let uu___23 + = + FStarC_SMTEncoding_Util.mkEq + (arg, xv) in + uu___23 + :: + eqns_or_guards) in + (env3, + (xv :: + arg_vars), + eqns, + (i + + Prims.int_one)))) + (env', [], [], + Prims.int_zero) + uu___17 in + (match uu___16 with + | (uu___17, + arg_vars, + elim_eqns_or_guards, + uu___18) -> + let arg_vars1 = + FStarC_Compiler_List.rev + arg_vars in + let uu___19 = + FStarC_Compiler_List.splitAt + n_tps + arg_vars1 in + (match uu___19 + with + | (arg_params, + uu___20) -> + let uu___21 + = + FStarC_Compiler_List.splitAt + n_tps + vars in + (match uu___21 + with + | + (data_arg_params, + uu___22) + -> + let elim_eqns_and_guards + = + let uu___23 + = + FStarC_SMTEncoding_Util.mk_and_l + (FStarC_Compiler_List.op_At + elim_eqns_or_guards + guards) in + FStarC_Compiler_List.fold_left2 + (fun + elim_eqns_and_guards1 + -> + fun + data_arg_param + -> + fun + arg_param + -> + FStarC_SMTEncoding_Term.subst + elim_eqns_and_guards1 + data_arg_param + arg_param) + uu___23 + data_arg_params + arg_params in + let ty = + FStarC_SMTEncoding_EncodeTerm.maybe_curry_fvb + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.p + encoded_head_fvb + arg_vars1 in + let xvars1 + = + FStarC_Compiler_List.map + FStarC_SMTEncoding_Util.mkFreeV + vars in + let dapp1 + = + FStarC_SMTEncoding_Util.mkApp + (ddconstrsym, + xvars1) in + let ty_pred + = + FStarC_SMTEncoding_Term.mk_HasTypeWithFuel + (FStar_Pervasives_Native.Some + s_fuel_tm) + dapp1 ty in + let arg_binders + = + FStarC_Compiler_List.map + FStarC_SMTEncoding_Term.fv_of_term + arg_vars1 in + let typing_inversion + = + let uu___23 + = + let uu___24 + = + let uu___25 + = + FStarC_Ident.range_of_lid + d in + let uu___26 + = + let uu___27 + = + let uu___28 + = + FStarC_SMTEncoding_Term.mk_fv + (fuel_var, + FStarC_SMTEncoding_Term.Fuel_sort) in + FStarC_SMTEncoding_Env.add_fuel + uu___28 + (FStarC_Compiler_List.op_At + vars + arg_binders) in + let uu___28 + = + FStarC_SMTEncoding_Util.mkImp + (ty_pred, + elim_eqns_and_guards) in + ([ + [ty_pred]], + uu___27, + uu___28) in + FStarC_SMTEncoding_Term.mkForall + uu___25 + uu___26 in + (uu___24, + (FStar_Pervasives_Native.Some + "data constructor typing elim"), + (Prims.strcat + "data_elim_" + ddconstrsym)) in + FStarC_SMTEncoding_Util.mkAssume + uu___23 in + let lex_t + = + let uu___23 + = + let uu___24 + = + let uu___25 + = + FStarC_Ident.string_of_lid + FStarC_Parser_Const.lex_t_lid in + (uu___25, + FStarC_SMTEncoding_Term.Term_sort) in + FStarC_SMTEncoding_Term.mk_fv + uu___24 in + FStarC_SMTEncoding_Util.mkFreeV + uu___23 in + let subterm_ordering + = + let prec + = + let uu___23 + = + FStarC_Compiler_List.mapi + (fun i -> + fun v -> + if + i < n_tps + then [] + else + (let uu___25 + = + let uu___26 + = + FStarC_SMTEncoding_Util.mkFreeV + v in + FStarC_SMTEncoding_Util.mk_Precedes + lex_t + lex_t + uu___26 + dapp1 in + [uu___25])) + vars in + FStarC_Compiler_List.flatten + uu___23 in + let uu___23 + = + let uu___24 + = + let uu___25 + = + FStarC_Ident.range_of_lid + d in + let uu___26 + = + let uu___27 + = + let uu___28 + = + FStarC_SMTEncoding_Term.mk_fv + (fuel_var, + FStarC_SMTEncoding_Term.Fuel_sort) in + FStarC_SMTEncoding_Env.add_fuel + uu___28 + (FStarC_Compiler_List.op_At + vars + arg_binders) in + let uu___28 + = + let uu___29 + = + let uu___30 + = + FStarC_SMTEncoding_Util.mk_and_l + prec in + (ty_pred, + uu___30) in + FStarC_SMTEncoding_Util.mkImp + uu___29 in + ([ + [ty_pred]], + uu___27, + uu___28) in + FStarC_SMTEncoding_Term.mkForall + uu___25 + uu___26 in + (uu___24, + (FStar_Pervasives_Native.Some + "subterm ordering"), + (Prims.strcat + "subterm_ordering_" + ddconstrsym)) in + FStarC_SMTEncoding_Util.mkAssume + uu___23 in + let uu___23 + = + let uu___24 + = + FStarC_Compiler_Util.first_N + n_tps + formals in + match uu___24 + with + | + (uu___25, + formals') + -> + let uu___26 + = + FStarC_Compiler_Util.first_N + n_tps + vars in + (match uu___26 + with + | + (uu___27, + vars') -> + let norm + t2 = + FStarC_TypeChecker_Normalize.unfold_whnf' + [FStarC_TypeChecker_Env.AllowUnboundUniverses; + FStarC_TypeChecker_Env.EraseUniverses; + FStarC_TypeChecker_Env.Unascribe; + FStarC_TypeChecker_Env.Exclude + FStarC_TypeChecker_Env.Zeta] + env'.FStarC_SMTEncoding_Env.tcenv + t2 in + let warn_compat + uu___28 = + let uu___29 + = + let uu___30 + = + FStarC_Errors_Msg.text + "Using 'compat:2954' to use a permissive encoding of the subterm ordering on the codomain of a constructor." in + let uu___31 + = + let uu___32 + = + FStarC_Errors_Msg.text + "This is deprecated and will be removed in a future version of F*." in + [uu___32] in + uu___30 + :: + uu___31 in + FStarC_Errors.log_issue + FStarC_Syntax_Syntax.hasRange_fv + fv + FStarC_Errors_Codes.Warning_DeprecatedGeneric + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic + uu___29) in + let uu___28 + = + FStarC_Compiler_List.fold_left2 + (fun + uu___29 + -> + fun + formal -> + fun var + -> + match uu___29 + with + | + (codomain_prec_l, + cod_decls) + -> + let rec binder_and_codomain_type + t2 = + let t3 = + FStarC_Syntax_Util.unrefine + t2 in + let uu___30 + = + let uu___31 + = + FStarC_Syntax_Subst.compress + t3 in + uu___31.FStarC_Syntax_Syntax.n in + match uu___30 + with + | + FStarC_Syntax_Syntax.Tm_arrow + uu___31 + -> + let uu___32 + = + let uu___33 + = + FStarC_Syntax_Util.unrefine + t3 in + FStarC_Syntax_Util.arrow_formals_comp + uu___33 in + (match uu___32 + with + | + (bs, c) + -> + (match bs + with + | + [] -> + FStar_Pervasives_Native.None + | + uu___33 + when + let uu___34 + = + FStarC_Syntax_Util.is_tot_or_gtot_comp + c in + Prims.op_Negation + uu___34 + -> + FStar_Pervasives_Native.None + | + uu___33 + -> + let uu___34 + = + FStarC_Syntax_Util.is_lemma_comp + c in + if + uu___34 + then + FStar_Pervasives_Native.None + else + (let t4 = + FStarC_Syntax_Util.unrefine + (FStarC_Syntax_Util.comp_result + c) in + let t5 = + norm t4 in + let uu___36 + = + (FStarC_Syntax_Syntax.is_type + t5) || + (FStarC_Syntax_Util.is_sub_singleton + t5) in + if + uu___36 + then + FStar_Pervasives_Native.None + else + (let uu___38 + = + FStarC_Syntax_Util.head_and_args_full + t5 in + match uu___38 + with + | + (head1, + uu___39) + -> + let uu___40 + = + let uu___41 + = + FStarC_Syntax_Util.un_uinst + head1 in + uu___41.FStarC_Syntax_Syntax.n in + (match uu___40 + with + | + FStarC_Syntax_Syntax.Tm_fvar + fv1 -> + let uu___41 + = + FStarC_Compiler_Util.for_some + (FStarC_Syntax_Syntax.fv_eq_lid + fv1) + mutuals in + if + uu___41 + then + FStar_Pervasives_Native.Some + (bs, c) + else + (let uu___43 + = + let uu___44 + = + FStarC_Options_Ext.get + "compat:2954" in + uu___44 + <> "" in + if + uu___43 + then + (warn_compat + (); + FStar_Pervasives_Native.Some + (bs, c)) + else + FStar_Pervasives_Native.None) + | + uu___41 + -> + let uu___42 + = + let uu___43 + = + FStarC_Options_Ext.get + "compat:2954" in + uu___43 + <> "" in + if + uu___42 + then + (warn_compat + (); + FStar_Pervasives_Native.Some + (bs, c)) + else + FStar_Pervasives_Native.None))))) + | + uu___31 + -> + let uu___32 + = + FStarC_Syntax_Util.head_and_args + t3 in + (match uu___32 + with + | + (head1, + uu___33) + -> + let t' = + norm t3 in + let uu___34 + = + FStarC_Syntax_Util.head_and_args + t' in + (match uu___34 + with + | + (head', + uu___35) + -> + let uu___36 + = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm + env1.FStarC_SMTEncoding_Env.tcenv + head1 + head' in + (match uu___36 + with + | + FStarC_TypeChecker_TermEqAndSimplify.Equal + -> + FStar_Pervasives_Native.None + | + FStarC_TypeChecker_TermEqAndSimplify.NotEqual + -> + binder_and_codomain_type + t' + | + uu___37 + -> + let uu___38 + = + let uu___39 + = + FStarC_Syntax_Subst.compress + head1 in + uu___39.FStarC_Syntax_Syntax.n in + (match uu___38 + with + | + FStarC_Syntax_Syntax.Tm_fvar + uu___39 + -> + binder_and_codomain_type + t' + | + FStarC_Syntax_Syntax.Tm_name + uu___39 + -> + binder_and_codomain_type + t' + | + FStarC_Syntax_Syntax.Tm_uinst + uu___39 + -> + binder_and_codomain_type + t' + | + uu___39 + -> + FStar_Pervasives_Native.None)))) in + let uu___30 + = + binder_and_codomain_type + (formal.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + (match uu___30 + with + | + FStar_Pervasives_Native.None + -> + (codomain_prec_l, + cod_decls) + | + FStar_Pervasives_Native.Some + (bs, c) + -> + let uu___31 + = + FStarC_SMTEncoding_EncodeTerm.encode_binders + FStar_Pervasives_Native.None + bs env' in + (match uu___31 + with + | + (bs', + guards', + _env', + bs_decls, + uu___32) + -> + let fun_app + = + let uu___33 + = + FStarC_SMTEncoding_Util.mkFreeV + var in + FStarC_SMTEncoding_EncodeTerm.mk_Apply + uu___33 + bs' in + let uu___33 + = + let uu___34 + = + let uu___35 + = + FStarC_Ident.range_of_lid + d in + let uu___36 + = + let uu___37 + = + let uu___38 + = + let uu___39 + = + FStarC_SMTEncoding_Util.mk_Precedes + lex_t + lex_t + fun_app + dapp1 in + [uu___39] in + [uu___38] in + let uu___38 + = + let uu___39 + = + let uu___40 + = + FStarC_SMTEncoding_Util.mk_and_l + (ty_pred' + :: + guards') in + let uu___41 + = + FStarC_SMTEncoding_Util.mk_Precedes + lex_t + lex_t + fun_app + dapp1 in + (uu___40, + uu___41) in + FStarC_SMTEncoding_Util.mkImp + uu___39 in + (uu___37, + bs', + uu___38) in + FStarC_SMTEncoding_Term.mkForall + uu___35 + uu___36 in + uu___34 + :: + codomain_prec_l in + (uu___33, + (FStarC_Compiler_List.op_At + bs_decls + cod_decls))))) + ([], []) + formals' + vars' in + (match uu___28 + with + | + (codomain_prec_l, + cod_decls) + -> + (match codomain_prec_l + with + | + [] -> + ([], + cod_decls) + | + uu___29 + -> + let uu___30 + = + let uu___31 + = + let uu___32 + = + let uu___33 + = + let uu___34 + = + FStarC_Ident.range_of_lid + d in + let uu___35 + = + let uu___36 + = + let uu___37 + = + FStarC_SMTEncoding_Term.mk_fv + (fuel_var, + FStarC_SMTEncoding_Term.Fuel_sort) in + FStarC_SMTEncoding_Env.add_fuel + uu___37 + (FStarC_Compiler_List.op_At + vars + arg_binders) in + let uu___37 + = + FStarC_SMTEncoding_Util.mk_and_l + codomain_prec_l in + ([ + [ty_pred]], + uu___36, + uu___37) in + FStarC_SMTEncoding_Term.mkForall + uu___34 + uu___35 in + (uu___33, + (FStar_Pervasives_Native.Some + "well-founded ordering on codomain"), + (Prims.strcat + "well_founded_ordering_on_codomain_" + ddconstrsym)) in + FStarC_SMTEncoding_Util.mkAssume + uu___32 in + [uu___31] in + (uu___30, + cod_decls)))) in + (match uu___23 + with + | + (codomain_ordering, + codomain_decls) + -> + ((FStarC_Compiler_List.op_At + arg_decls + codomain_decls), + (FStarC_Compiler_List.op_At + [typing_inversion; + subterm_ordering] + codomain_ordering))))))) + | FStarC_Syntax_Syntax.Tm_fvar + fv -> + let encoded_head_fvb = + FStarC_SMTEncoding_Env.lookup_free_var_name + env' + fv.FStarC_Syntax_Syntax.fv_name in + let uu___11 = + FStarC_SMTEncoding_EncodeTerm.encode_args + args env' in + (match uu___11 with + | (encoded_args, + arg_decls) -> + let uu___12 = + let uu___13 = + FStarC_Compiler_List.zip + args + encoded_args in + FStarC_Compiler_List.fold_left + (fun uu___14 -> + fun uu___15 -> + match + (uu___14, + uu___15) + with + | ((env2, + arg_vars, + eqns_or_guards, + i), + (orig_arg, + arg)) -> + let uu___16 + = + let uu___17 + = + FStarC_Syntax_Syntax.new_bv + FStar_Pervasives_Native.None + FStarC_Syntax_Syntax.tun in + FStarC_SMTEncoding_Env.gen_term_var + env2 + uu___17 in + (match uu___16 + with + | + (uu___17, + xv, env3) + -> + let eqns + = + if + i < n_tps + then + eqns_or_guards + else + (let uu___19 + = + FStarC_SMTEncoding_Util.mkEq + (arg, xv) in + uu___19 + :: + eqns_or_guards) in + (env3, + (xv :: + arg_vars), + eqns, + (i + + Prims.int_one)))) + (env', [], [], + Prims.int_zero) + uu___13 in + (match uu___12 with + | (uu___13, + arg_vars, + elim_eqns_or_guards, + uu___14) -> + let arg_vars1 = + FStarC_Compiler_List.rev + arg_vars in + let uu___15 = + FStarC_Compiler_List.splitAt + n_tps + arg_vars1 in + (match uu___15 + with + | (arg_params, + uu___16) -> + let uu___17 + = + FStarC_Compiler_List.splitAt + n_tps + vars in + (match uu___17 + with + | + (data_arg_params, + uu___18) + -> + let elim_eqns_and_guards + = + let uu___19 + = + FStarC_SMTEncoding_Util.mk_and_l + (FStarC_Compiler_List.op_At + elim_eqns_or_guards + guards) in + FStarC_Compiler_List.fold_left2 + (fun + elim_eqns_and_guards1 + -> + fun + data_arg_param + -> + fun + arg_param + -> + FStarC_SMTEncoding_Term.subst + elim_eqns_and_guards1 + data_arg_param + arg_param) + uu___19 + data_arg_params + arg_params in + let ty = + FStarC_SMTEncoding_EncodeTerm.maybe_curry_fvb + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.p + encoded_head_fvb + arg_vars1 in + let xvars1 + = + FStarC_Compiler_List.map + FStarC_SMTEncoding_Util.mkFreeV + vars in + let dapp1 + = + FStarC_SMTEncoding_Util.mkApp + (ddconstrsym, + xvars1) in + let ty_pred + = + FStarC_SMTEncoding_Term.mk_HasTypeWithFuel + (FStar_Pervasives_Native.Some + s_fuel_tm) + dapp1 ty in + let arg_binders + = + FStarC_Compiler_List.map + FStarC_SMTEncoding_Term.fv_of_term + arg_vars1 in + let typing_inversion + = + let uu___19 + = + let uu___20 + = + let uu___21 + = + FStarC_Ident.range_of_lid + d in + let uu___22 + = + let uu___23 + = + let uu___24 + = + FStarC_SMTEncoding_Term.mk_fv + (fuel_var, + FStarC_SMTEncoding_Term.Fuel_sort) in + FStarC_SMTEncoding_Env.add_fuel + uu___24 + (FStarC_Compiler_List.op_At + vars + arg_binders) in + let uu___24 + = + FStarC_SMTEncoding_Util.mkImp + (ty_pred, + elim_eqns_and_guards) in + ([ + [ty_pred]], + uu___23, + uu___24) in + FStarC_SMTEncoding_Term.mkForall + uu___21 + uu___22 in + (uu___20, + (FStar_Pervasives_Native.Some + "data constructor typing elim"), + (Prims.strcat + "data_elim_" + ddconstrsym)) in + FStarC_SMTEncoding_Util.mkAssume + uu___19 in + let lex_t + = + let uu___19 + = + let uu___20 + = + let uu___21 + = + FStarC_Ident.string_of_lid + FStarC_Parser_Const.lex_t_lid in + (uu___21, + FStarC_SMTEncoding_Term.Term_sort) in + FStarC_SMTEncoding_Term.mk_fv + uu___20 in + FStarC_SMTEncoding_Util.mkFreeV + uu___19 in + let subterm_ordering + = + let prec + = + let uu___19 + = + FStarC_Compiler_List.mapi + (fun i -> + fun v -> + if + i < n_tps + then [] + else + (let uu___21 + = + let uu___22 + = + FStarC_SMTEncoding_Util.mkFreeV + v in + FStarC_SMTEncoding_Util.mk_Precedes + lex_t + lex_t + uu___22 + dapp1 in + [uu___21])) + vars in + FStarC_Compiler_List.flatten + uu___19 in + let uu___19 + = + let uu___20 + = + let uu___21 + = + FStarC_Ident.range_of_lid + d in + let uu___22 + = + let uu___23 + = + let uu___24 + = + FStarC_SMTEncoding_Term.mk_fv + (fuel_var, + FStarC_SMTEncoding_Term.Fuel_sort) in + FStarC_SMTEncoding_Env.add_fuel + uu___24 + (FStarC_Compiler_List.op_At + vars + arg_binders) in + let uu___24 + = + let uu___25 + = + let uu___26 + = + FStarC_SMTEncoding_Util.mk_and_l + prec in + (ty_pred, + uu___26) in + FStarC_SMTEncoding_Util.mkImp + uu___25 in + ([ + [ty_pred]], + uu___23, + uu___24) in + FStarC_SMTEncoding_Term.mkForall + uu___21 + uu___22 in + (uu___20, + (FStar_Pervasives_Native.Some + "subterm ordering"), + (Prims.strcat + "subterm_ordering_" + ddconstrsym)) in + FStarC_SMTEncoding_Util.mkAssume + uu___19 in + let uu___19 + = + let uu___20 + = + FStarC_Compiler_Util.first_N + n_tps + formals in + match uu___20 + with + | + (uu___21, + formals') + -> + let uu___22 + = + FStarC_Compiler_Util.first_N + n_tps + vars in + (match uu___22 + with + | + (uu___23, + vars') -> + let norm + t2 = + FStarC_TypeChecker_Normalize.unfold_whnf' + [FStarC_TypeChecker_Env.AllowUnboundUniverses; + FStarC_TypeChecker_Env.EraseUniverses; + FStarC_TypeChecker_Env.Unascribe; + FStarC_TypeChecker_Env.Exclude + FStarC_TypeChecker_Env.Zeta] + env'.FStarC_SMTEncoding_Env.tcenv + t2 in + let warn_compat + uu___24 = + let uu___25 + = + let uu___26 + = + FStarC_Errors_Msg.text + "Using 'compat:2954' to use a permissive encoding of the subterm ordering on the codomain of a constructor." in + let uu___27 + = + let uu___28 + = + FStarC_Errors_Msg.text + "This is deprecated and will be removed in a future version of F*." in + [uu___28] in + uu___26 + :: + uu___27 in + FStarC_Errors.log_issue + FStarC_Syntax_Syntax.hasRange_fv + fv + FStarC_Errors_Codes.Warning_DeprecatedGeneric + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic + uu___25) in + let uu___24 + = + FStarC_Compiler_List.fold_left2 + (fun + uu___25 + -> + fun + formal -> + fun var + -> + match uu___25 + with + | + (codomain_prec_l, + cod_decls) + -> + let rec binder_and_codomain_type + t2 = + let t3 = + FStarC_Syntax_Util.unrefine + t2 in + let uu___26 + = + let uu___27 + = + FStarC_Syntax_Subst.compress + t3 in + uu___27.FStarC_Syntax_Syntax.n in + match uu___26 + with + | + FStarC_Syntax_Syntax.Tm_arrow + uu___27 + -> + let uu___28 + = + let uu___29 + = + FStarC_Syntax_Util.unrefine + t3 in + FStarC_Syntax_Util.arrow_formals_comp + uu___29 in + (match uu___28 + with + | + (bs, c) + -> + (match bs + with + | + [] -> + FStar_Pervasives_Native.None + | + uu___29 + when + let uu___30 + = + FStarC_Syntax_Util.is_tot_or_gtot_comp + c in + Prims.op_Negation + uu___30 + -> + FStar_Pervasives_Native.None + | + uu___29 + -> + let uu___30 + = + FStarC_Syntax_Util.is_lemma_comp + c in + if + uu___30 + then + FStar_Pervasives_Native.None + else + (let t4 = + FStarC_Syntax_Util.unrefine + (FStarC_Syntax_Util.comp_result + c) in + let t5 = + norm t4 in + let uu___32 + = + (FStarC_Syntax_Syntax.is_type + t5) || + (FStarC_Syntax_Util.is_sub_singleton + t5) in + if + uu___32 + then + FStar_Pervasives_Native.None + else + (let uu___34 + = + FStarC_Syntax_Util.head_and_args_full + t5 in + match uu___34 + with + | + (head1, + uu___35) + -> + let uu___36 + = + let uu___37 + = + FStarC_Syntax_Util.un_uinst + head1 in + uu___37.FStarC_Syntax_Syntax.n in + (match uu___36 + with + | + FStarC_Syntax_Syntax.Tm_fvar + fv1 -> + let uu___37 + = + FStarC_Compiler_Util.for_some + (FStarC_Syntax_Syntax.fv_eq_lid + fv1) + mutuals in + if + uu___37 + then + FStar_Pervasives_Native.Some + (bs, c) + else + (let uu___39 + = + let uu___40 + = + FStarC_Options_Ext.get + "compat:2954" in + uu___40 + <> "" in + if + uu___39 + then + (warn_compat + (); + FStar_Pervasives_Native.Some + (bs, c)) + else + FStar_Pervasives_Native.None) + | + uu___37 + -> + let uu___38 + = + let uu___39 + = + FStarC_Options_Ext.get + "compat:2954" in + uu___39 + <> "" in + if + uu___38 + then + (warn_compat + (); + FStar_Pervasives_Native.Some + (bs, c)) + else + FStar_Pervasives_Native.None))))) + | + uu___27 + -> + let uu___28 + = + FStarC_Syntax_Util.head_and_args + t3 in + (match uu___28 + with + | + (head1, + uu___29) + -> + let t' = + norm t3 in + let uu___30 + = + FStarC_Syntax_Util.head_and_args + t' in + (match uu___30 + with + | + (head', + uu___31) + -> + let uu___32 + = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm + env1.FStarC_SMTEncoding_Env.tcenv + head1 + head' in + (match uu___32 + with + | + FStarC_TypeChecker_TermEqAndSimplify.Equal + -> + FStar_Pervasives_Native.None + | + FStarC_TypeChecker_TermEqAndSimplify.NotEqual + -> + binder_and_codomain_type + t' + | + uu___33 + -> + let uu___34 + = + let uu___35 + = + FStarC_Syntax_Subst.compress + head1 in + uu___35.FStarC_Syntax_Syntax.n in + (match uu___34 + with + | + FStarC_Syntax_Syntax.Tm_fvar + uu___35 + -> + binder_and_codomain_type + t' + | + FStarC_Syntax_Syntax.Tm_name + uu___35 + -> + binder_and_codomain_type + t' + | + FStarC_Syntax_Syntax.Tm_uinst + uu___35 + -> + binder_and_codomain_type + t' + | + uu___35 + -> + FStar_Pervasives_Native.None)))) in + let uu___26 + = + binder_and_codomain_type + (formal.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + (match uu___26 + with + | + FStar_Pervasives_Native.None + -> + (codomain_prec_l, + cod_decls) + | + FStar_Pervasives_Native.Some + (bs, c) + -> + let uu___27 + = + FStarC_SMTEncoding_EncodeTerm.encode_binders + FStar_Pervasives_Native.None + bs env' in + (match uu___27 + with + | + (bs', + guards', + _env', + bs_decls, + uu___28) + -> + let fun_app + = + let uu___29 + = + FStarC_SMTEncoding_Util.mkFreeV + var in + FStarC_SMTEncoding_EncodeTerm.mk_Apply + uu___29 + bs' in + let uu___29 + = + let uu___30 + = + let uu___31 + = + FStarC_Ident.range_of_lid + d in + let uu___32 + = + let uu___33 + = + let uu___34 + = + let uu___35 + = + FStarC_SMTEncoding_Util.mk_Precedes + lex_t + lex_t + fun_app + dapp1 in + [uu___35] in + [uu___34] in + let uu___34 + = + let uu___35 + = + let uu___36 + = + FStarC_SMTEncoding_Util.mk_and_l + (ty_pred' + :: + guards') in + let uu___37 + = + FStarC_SMTEncoding_Util.mk_Precedes + lex_t + lex_t + fun_app + dapp1 in + (uu___36, + uu___37) in + FStarC_SMTEncoding_Util.mkImp + uu___35 in + (uu___33, + bs', + uu___34) in + FStarC_SMTEncoding_Term.mkForall + uu___31 + uu___32 in + uu___30 + :: + codomain_prec_l in + (uu___29, + (FStarC_Compiler_List.op_At + bs_decls + cod_decls))))) + ([], []) + formals' + vars' in + (match uu___24 + with + | + (codomain_prec_l, + cod_decls) + -> + (match codomain_prec_l + with + | + [] -> + ([], + cod_decls) + | + uu___25 + -> + let uu___26 + = + let uu___27 + = + let uu___28 + = + let uu___29 + = + let uu___30 + = + FStarC_Ident.range_of_lid + d in + let uu___31 + = + let uu___32 + = + let uu___33 + = + FStarC_SMTEncoding_Term.mk_fv + (fuel_var, + FStarC_SMTEncoding_Term.Fuel_sort) in + FStarC_SMTEncoding_Env.add_fuel + uu___33 + (FStarC_Compiler_List.op_At + vars + arg_binders) in + let uu___33 + = + FStarC_SMTEncoding_Util.mk_and_l + codomain_prec_l in + ([ + [ty_pred]], + uu___32, + uu___33) in + FStarC_SMTEncoding_Term.mkForall + uu___30 + uu___31 in + (uu___29, + (FStar_Pervasives_Native.Some + "well-founded ordering on codomain"), + (Prims.strcat + "well_founded_ordering_on_codomain_" + ddconstrsym)) in + FStarC_SMTEncoding_Util.mkAssume + uu___28 in + [uu___27] in + (uu___26, + cod_decls)))) in + (match uu___19 + with + | + (codomain_ordering, + codomain_decls) + -> + ((FStarC_Compiler_List.op_At + arg_decls + codomain_decls), + (FStarC_Compiler_List.op_At + [typing_inversion; + subterm_ordering] + codomain_ordering))))))) + | uu___11 -> + ((let uu___13 = + let uu___14 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + d in + let uu___15 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + head in + FStarC_Compiler_Util.format2 + "Constructor %s builds an unexpected type %s" + uu___14 uu___15 in + FStarC_Errors.log_issue + FStarC_Syntax_Syntax.has_range_sigelt + se + FStarC_Errors_Codes.Warning_ConstructorBuildsUnexpectedType + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___13)); + ([], []))) in + let uu___8 = encode_elim () in + (match uu___8 with + | (decls2, elim) -> + let data_cons_typing_intro_decl + = + let uu___9 = + match t_res_tm.FStarC_SMTEncoding_Term.tm + with + | FStarC_SMTEncoding_Term.App + (op, args) -> + let uu___10 = + FStarC_Compiler_List.splitAt + n_tps args in + (match uu___10 with + | (targs, iargs) -> + let uu___11 = + let uu___12 = + FStarC_Compiler_List.map + (fun uu___13 + -> + FStarC_SMTEncoding_Env.fresh_fvar + env1.FStarC_SMTEncoding_Env.current_module_name + "i" + FStarC_SMTEncoding_Term.Term_sort) + iargs in + FStarC_Compiler_List.split + uu___12 in + (match uu___11 with + | (fresh_ivars, + fresh_iargs) -> + let additional_guards + = + let uu___12 + = + FStarC_Compiler_List.map2 + (fun a -> + fun + fresh_a + -> + FStarC_SMTEncoding_Util.mkEq + (a, + fresh_a)) + iargs + fresh_iargs in + FStarC_SMTEncoding_Util.mk_and_l + uu___12 in + let uu___12 = + FStarC_SMTEncoding_Term.mk_HasTypeWithFuel + (FStar_Pervasives_Native.Some + fuel_tm) + dapp + { + FStarC_SMTEncoding_Term.tm + = + (FStarC_SMTEncoding_Term.App + (op, + (FStarC_Compiler_List.op_At + targs + fresh_iargs))); + FStarC_SMTEncoding_Term.freevars + = + (t_res_tm.FStarC_SMTEncoding_Term.freevars); + FStarC_SMTEncoding_Term.rng + = + (t_res_tm.FStarC_SMTEncoding_Term.rng) + } in + let uu___13 = + let uu___14 + = + FStarC_Compiler_List.map + (fun s -> + FStarC_SMTEncoding_Term.mk_fv + (s, + FStarC_SMTEncoding_Term.Term_sort)) + fresh_ivars in + FStarC_Compiler_List.op_At + vars + uu___14 in + let uu___14 = + FStarC_SMTEncoding_Util.mkAnd + (guard, + additional_guards) in + (uu___12, + uu___13, + uu___14))) + | uu___10 -> + (ty_pred', vars, guard) in + match uu___9 with + | (ty_pred'1, vars1, guard1) + -> + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Ident.range_of_lid + d in + let uu___13 = + let uu___14 = + let uu___15 = + FStarC_SMTEncoding_Term.mk_fv + (fuel_var, + FStarC_SMTEncoding_Term.Fuel_sort) in + FStarC_SMTEncoding_Env.add_fuel + uu___15 vars1 in + let uu___15 = + FStarC_SMTEncoding_Util.mkImp + (guard1, + ty_pred'1) in + ([[ty_pred'1]], + uu___14, uu___15) in + FStarC_SMTEncoding_Term.mkForall + uu___12 uu___13 in + (uu___11, + (FStar_Pervasives_Native.Some + "data constructor typing intro"), + (Prims.strcat + "data_typing_intro_" + ddtok)) in + FStarC_SMTEncoding_Util.mkAssume + uu___10 in + let g = + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = + let uu___17 = + let uu___18 + = + let uu___19 + = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + d in + FStarC_Compiler_Util.format1 + "data constructor proxy: %s" + uu___19 in + FStar_Pervasives_Native.Some + uu___18 in + (ddtok, [], + FStarC_SMTEncoding_Term.Term_sort, + uu___17) in + FStarC_SMTEncoding_Term.DeclFun + uu___16 in + [uu___15] in + FStarC_Compiler_List.op_At + uu___14 + proxy_fresh in + FStarC_SMTEncoding_Term.mk_decls_trivial + uu___13 in + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = + let uu___17 = + FStarC_SMTEncoding_Util.mkAssume + (tok_typing1, + (FStar_Pervasives_Native.Some + "typing for data constructor proxy"), + (Prims.strcat + "typing_tok_" + ddtok)) in + let uu___18 = + let uu___19 = + let uu___20 + = + let uu___21 + = + let uu___22 + = + FStarC_Ident.range_of_lid + d in + let uu___23 + = + let uu___24 + = + FStarC_SMTEncoding_Util.mkEq + (app, + dapp) in + ([[app]], + vars, + uu___24) in + FStarC_SMTEncoding_Term.mkForall + uu___22 + uu___23 in + (uu___21, + (FStar_Pervasives_Native.Some + "equality for proxy"), + (Prims.strcat + "equality_tok_" + ddtok)) in + FStarC_SMTEncoding_Util.mkAssume + uu___20 in + [uu___19; + data_cons_typing_intro_decl] in + uu___17 :: + uu___18 in + FStarC_Compiler_List.op_At + uu___16 elim in + FStarC_SMTEncoding_Term.mk_decls_trivial + uu___15 in + FStarC_Compiler_List.op_At + decls_pred uu___14 in + FStarC_Compiler_List.op_At + uu___12 uu___13 in + FStarC_Compiler_List.op_At + decls3 uu___11 in + FStarC_Compiler_List.op_At + decls2 uu___10 in + FStarC_Compiler_List.op_At + binder_decls uu___9 in + let uu___9 = + let uu___10 = + FStarC_SMTEncoding_Term.mk_decls_trivial + datacons in + FStarC_Compiler_List.op_At + uu___10 g in + (uu___9, env1)))))))) +let rec (encode_sigelt : + FStarC_SMTEncoding_Env.env_t -> + FStarC_Syntax_Syntax.sigelt -> + (FStarC_SMTEncoding_Term.decls_t * FStarC_SMTEncoding_Env.env_t)) + = + fun env -> + fun se -> + let nm = FStarC_Syntax_Print.sigelt_to_string_short se in + let uu___ = + let uu___1 = + let uu___2 = FStarC_Syntax_Print.sigelt_to_string_short se in + FStarC_Compiler_Util.format1 + "While encoding top-level declaration `%s`" uu___2 in + FStarC_Errors.with_ctx uu___1 (fun uu___2 -> encode_sigelt' env se) in + match uu___ with + | (g, env1) -> + let g1 = + match g with + | [] -> + ((let uu___2 = FStarC_Compiler_Effect.op_Bang dbg_SMTEncoding in + if uu___2 + then + FStarC_Compiler_Util.print1 "Skipped encoding of %s\n" nm + else ()); + (let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Compiler_Util.format1 "" nm in + FStarC_SMTEncoding_Term.Caption uu___4 in + [uu___3] in + FStarC_SMTEncoding_Term.mk_decls_trivial uu___2)) + | uu___1 -> + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Compiler_Util.format1 "" nm in + FStarC_SMTEncoding_Term.Caption uu___5 in + [uu___4] in + FStarC_SMTEncoding_Term.mk_decls_trivial uu___3 in + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Compiler_Util.format1 "" + nm in + FStarC_SMTEncoding_Term.Caption uu___7 in + [uu___6] in + FStarC_SMTEncoding_Term.mk_decls_trivial uu___5 in + FStarC_Compiler_List.op_At g uu___4 in + FStarC_Compiler_List.op_At uu___2 uu___3 in + (g1, env1) +and (encode_sigelt' : + FStarC_SMTEncoding_Env.env_t -> + FStarC_Syntax_Syntax.sigelt -> + (FStarC_SMTEncoding_Term.decls_t * FStarC_SMTEncoding_Env.env_t)) + = + fun env -> + fun se -> + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_SMTEncoding in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_sigelt se in + FStarC_Compiler_Util.print1 "@@@Encoding sigelt %s\n" uu___2 + else ()); + (let is_opaque_to_smt t = + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress t in + uu___2.FStarC_Syntax_Syntax.n in + match uu___1 with + | FStarC_Syntax_Syntax.Tm_constant (FStarC_Const.Const_string + (s, uu___2)) -> s = "opaque_to_smt" + | uu___2 -> false in + let is_uninterpreted_by_smt t = + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress t in + uu___2.FStarC_Syntax_Syntax.n in + match uu___1 with + | FStarC_Syntax_Syntax.Tm_constant (FStarC_Const.Const_string + (s, uu___2)) -> s = "uninterpreted_by_smt" + | uu___2 -> false in + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_splice uu___1 -> + failwith "impossible -- splice should have been removed by Tc.fs" + | FStarC_Syntax_Syntax.Sig_fail uu___1 -> + failwith + "impossible -- Sig_fail should have been removed by Tc.fs" + | FStarC_Syntax_Syntax.Sig_pragma uu___1 -> ([], env) + | FStarC_Syntax_Syntax.Sig_effect_abbrev uu___1 -> ([], env) + | FStarC_Syntax_Syntax.Sig_sub_effect uu___1 -> ([], env) + | FStarC_Syntax_Syntax.Sig_polymonadic_bind uu___1 -> ([], env) + | FStarC_Syntax_Syntax.Sig_polymonadic_subcomp uu___1 -> ([], env) + | FStarC_Syntax_Syntax.Sig_new_effect ed -> + let uu___1 = + let uu___2 = + FStarC_SMTEncoding_Util.is_smt_reifiable_effect + env.FStarC_SMTEncoding_Env.tcenv + ed.FStarC_Syntax_Syntax.mname in + Prims.op_Negation uu___2 in + if uu___1 + then ([], env) + else + (let close_effect_params tm = + match ed.FStarC_Syntax_Syntax.binders with + | [] -> tm + | uu___3 -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs = + (ed.FStarC_Syntax_Syntax.binders); + FStarC_Syntax_Syntax.body = tm; + FStarC_Syntax_Syntax.rc_opt = + (FStar_Pervasives_Native.Some + (FStarC_Syntax_Util.mk_residual_comp + FStarC_Parser_Const.effect_Tot_lid + FStar_Pervasives_Native.None + [FStarC_Syntax_Syntax.TOTAL])) + }) tm.FStarC_Syntax_Syntax.pos in + let encode_action env1 a = + let action_defn = + let uu___3 = + close_effect_params a.FStarC_Syntax_Syntax.action_defn in + norm_before_encoding env1 uu___3 in + let uu___3 = + FStarC_Syntax_Util.arrow_formals_comp + a.FStarC_Syntax_Syntax.action_typ in + match uu___3 with + | (formals, uu___4) -> + let arity = FStarC_Compiler_List.length formals in + let uu___5 = + FStarC_SMTEncoding_Env.new_term_constant_and_tok_from_lid + env1 a.FStarC_Syntax_Syntax.action_name arity in + (match uu___5 with + | (aname, atok, env2) -> + let uu___6 = + FStarC_SMTEncoding_EncodeTerm.encode_term + action_defn env2 in + (match uu___6 with + | (tm, decls) -> + let a_decls = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Compiler_List.map + (fun uu___10 -> + FStarC_SMTEncoding_Term.Term_sort) + formals in + (aname, uu___9, + FStarC_SMTEncoding_Term.Term_sort, + (FStar_Pervasives_Native.Some "Action")) in + FStarC_SMTEncoding_Term.DeclFun uu___8 in + [uu___7; + FStarC_SMTEncoding_Term.DeclFun + (atok, [], + FStarC_SMTEncoding_Term.Term_sort, + (FStar_Pervasives_Native.Some + "Action token"))] in + let uu___7 = + let aux uu___8 uu___9 = + match (uu___8, uu___9) with + | ({ FStarC_Syntax_Syntax.binder_bv = bv; + FStarC_Syntax_Syntax.binder_qual = + uu___10; + FStarC_Syntax_Syntax.binder_positivity + = uu___11; + FStarC_Syntax_Syntax.binder_attrs = + uu___12;_}, + (env3, acc_sorts, acc)) -> + let uu___13 = + FStarC_SMTEncoding_Env.gen_term_var + env3 bv in + (match uu___13 with + | (xxsym, xx, env4) -> + let uu___14 = + let uu___15 = + FStarC_SMTEncoding_Term.mk_fv + (xxsym, + FStarC_SMTEncoding_Term.Term_sort) in + uu___15 :: acc_sorts in + (env4, uu___14, (xx :: acc))) in + FStarC_Compiler_List.fold_right aux formals + (env2, [], []) in + (match uu___7 with + | (uu___8, xs_sorts, xs) -> + let app = + FStarC_SMTEncoding_Util.mkApp + (aname, xs) in + let a_eq = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Ident.range_of_lid + a.FStarC_Syntax_Syntax.action_name in + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + FStarC_SMTEncoding_EncodeTerm.mk_Apply + tm xs_sorts in + (app, uu___15) in + FStarC_SMTEncoding_Util.mkEq + uu___14 in + ([[app]], xs_sorts, uu___13) in + FStarC_SMTEncoding_Term.mkForall + uu___11 uu___12 in + (uu___10, + (FStar_Pervasives_Native.Some + "Action equality"), + (Prims.strcat aname "_equality")) in + FStarC_SMTEncoding_Util.mkAssume uu___9 in + let tok_correspondence = + let tok_term = + let uu___9 = + FStarC_SMTEncoding_Term.mk_fv + (atok, + FStarC_SMTEncoding_Term.Term_sort) in + FStarC_SMTEncoding_Util.mkFreeV uu___9 in + let tok_app = + FStarC_SMTEncoding_EncodeTerm.mk_Apply + tok_term xs_sorts in + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Ident.range_of_lid + a.FStarC_Syntax_Syntax.action_name in + let uu___12 = + let uu___13 = + FStarC_SMTEncoding_Util.mkEq + (tok_app, app) in + ([[tok_app]], xs_sorts, uu___13) in + FStarC_SMTEncoding_Term.mkForall + uu___11 uu___12 in + (uu___10, + (FStar_Pervasives_Native.Some + "Action token correspondence"), + (Prims.strcat aname + "_token_correspondence")) in + FStarC_SMTEncoding_Util.mkAssume uu___9 in + let uu___9 = + let uu___10 = + FStarC_SMTEncoding_Term.mk_decls_trivial + (FStarC_Compiler_List.op_At a_decls + [a_eq; tok_correspondence]) in + FStarC_Compiler_List.op_At decls uu___10 in + (env2, uu___9)))) in + let uu___3 = + FStarC_Compiler_Util.fold_map encode_action env + ed.FStarC_Syntax_Syntax.actions in + match uu___3 with + | (env1, decls2) -> + ((FStarC_Compiler_List.flatten decls2), env1)) + | FStarC_Syntax_Syntax.Sig_declare_typ + { FStarC_Syntax_Syntax.lid2 = lid; + FStarC_Syntax_Syntax.us2 = uu___1; + FStarC_Syntax_Syntax.t2 = uu___2;_} + when FStarC_Ident.lid_equals lid FStarC_Parser_Const.precedes_lid + -> + let uu___3 = + FStarC_SMTEncoding_Env.new_term_constant_and_tok_from_lid env + lid (Prims.of_int (4)) in + (match uu___3 with | (tname, ttok, env1) -> ([], env1)) + | FStarC_Syntax_Syntax.Sig_declare_typ + { FStarC_Syntax_Syntax.lid2 = lid; FStarC_Syntax_Syntax.us2 = us; + FStarC_Syntax_Syntax.t2 = t;_} + -> + let quals = se.FStarC_Syntax_Syntax.sigquals in + let will_encode_definition = + let uu___1 = + FStarC_Compiler_Util.for_some + (fun uu___2 -> + match uu___2 with + | FStarC_Syntax_Syntax.Assumption -> true + | FStarC_Syntax_Syntax.Projector uu___3 -> true + | FStarC_Syntax_Syntax.Discriminator uu___3 -> true + | FStarC_Syntax_Syntax.Irreducible -> true + | uu___3 -> false) quals in + Prims.op_Negation uu___1 in + if will_encode_definition + then ([], env) + else + (let fv = + FStarC_Syntax_Syntax.lid_as_fv lid + FStar_Pervasives_Native.None in + let uu___2 = + let uu___3 = + FStarC_Compiler_Util.for_some is_uninterpreted_by_smt + se.FStarC_Syntax_Syntax.sigattrs in + encode_top_level_val uu___3 env us fv t quals in + match uu___2 with + | (decls, env1) -> + let tname = FStarC_Ident.string_of_lid lid in + let tsym = + let uu___3 = + FStarC_SMTEncoding_Env.try_lookup_free_var env1 lid in + FStarC_Compiler_Option.get uu___3 in + let uu___3 = + let uu___4 = + let uu___5 = + primitive_type_axioms + env1.FStarC_SMTEncoding_Env.tcenv lid tname tsym in + FStarC_SMTEncoding_Term.mk_decls_trivial uu___5 in + FStarC_Compiler_List.op_At decls uu___4 in + (uu___3, env1)) + | FStarC_Syntax_Syntax.Sig_assume + { FStarC_Syntax_Syntax.lid3 = l; FStarC_Syntax_Syntax.us3 = us; + FStarC_Syntax_Syntax.phi1 = f;_} + -> + let uu___1 = FStarC_Syntax_Subst.open_univ_vars us f in + (match uu___1 with + | (uvs, f1) -> + let env1 = + let uu___2 = + FStarC_TypeChecker_Env.push_univ_vars + env.FStarC_SMTEncoding_Env.tcenv uvs in + { + FStarC_SMTEncoding_Env.bvar_bindings = + (env.FStarC_SMTEncoding_Env.bvar_bindings); + FStarC_SMTEncoding_Env.fvar_bindings = + (env.FStarC_SMTEncoding_Env.fvar_bindings); + FStarC_SMTEncoding_Env.depth = + (env.FStarC_SMTEncoding_Env.depth); + FStarC_SMTEncoding_Env.tcenv = uu___2; + FStarC_SMTEncoding_Env.warn = + (env.FStarC_SMTEncoding_Env.warn); + FStarC_SMTEncoding_Env.nolabels = + (env.FStarC_SMTEncoding_Env.nolabels); + FStarC_SMTEncoding_Env.use_zfuel_name = + (env.FStarC_SMTEncoding_Env.use_zfuel_name); + FStarC_SMTEncoding_Env.encode_non_total_function_typ = + (env.FStarC_SMTEncoding_Env.encode_non_total_function_typ); + FStarC_SMTEncoding_Env.current_module_name = + (env.FStarC_SMTEncoding_Env.current_module_name); + FStarC_SMTEncoding_Env.encoding_quantifier = + (env.FStarC_SMTEncoding_Env.encoding_quantifier); + FStarC_SMTEncoding_Env.global_cache = + (env.FStarC_SMTEncoding_Env.global_cache) + } in + let f2 = norm_before_encoding env1 f1 in + let uu___2 = + FStarC_SMTEncoding_EncodeTerm.encode_formula f2 env1 in + (match uu___2 with + | (f3, decls) -> + let g = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident l in + FStarC_Compiler_Util.format1 + "Assumption: %s" uu___8 in + FStar_Pervasives_Native.Some uu___7 in + let uu___7 = + let uu___8 = + let uu___9 = FStarC_Ident.string_of_lid l in + Prims.strcat "assumption_" uu___9 in + FStarC_SMTEncoding_Env.varops.FStarC_SMTEncoding_Env.mk_unique + uu___8 in + (f3, uu___6, uu___7) in + FStarC_SMTEncoding_Util.mkAssume uu___5 in + [uu___4] in + FStarC_SMTEncoding_Term.mk_decls_trivial uu___3 in + ((FStarC_Compiler_List.op_At decls g), env1))) + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = lbs; + FStarC_Syntax_Syntax.lids1 = uu___1;_} + when + (FStarC_Compiler_List.contains FStarC_Syntax_Syntax.Irreducible + se.FStarC_Syntax_Syntax.sigquals) + || + (FStarC_Compiler_Util.for_some is_opaque_to_smt + se.FStarC_Syntax_Syntax.sigattrs) + -> + let attrs = se.FStarC_Syntax_Syntax.sigattrs in + let uu___2 = + FStarC_Compiler_Util.fold_map + (fun env1 -> + fun lb -> + let lid = + let uu___3 = + let uu___4 = + FStarC_Compiler_Util.right + lb.FStarC_Syntax_Syntax.lbname in + uu___4.FStarC_Syntax_Syntax.fv_name in + uu___3.FStarC_Syntax_Syntax.v in + let uu___3 = + let uu___4 = + FStarC_TypeChecker_Env.try_lookup_val_decl + env1.FStarC_SMTEncoding_Env.tcenv lid in + FStarC_Compiler_Option.isNone uu___4 in + if uu___3 + then + let val_decl = + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_declare_typ + { + FStarC_Syntax_Syntax.lid2 = lid; + FStarC_Syntax_Syntax.us2 = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.t2 = + (lb.FStarC_Syntax_Syntax.lbtyp) + }); + FStarC_Syntax_Syntax.sigrng = + (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (FStarC_Syntax_Syntax.Irreducible :: + (se.FStarC_Syntax_Syntax.sigquals)); + FStarC_Syntax_Syntax.sigmeta = + (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se.FStarC_Syntax_Syntax.sigopts) + } in + let uu___4 = encode_sigelt' env1 val_decl in + match uu___4 with | (decls, env2) -> (env2, decls) + else (env1, [])) env (FStar_Pervasives_Native.snd lbs) in + (match uu___2 with + | (env1, decls) -> ((FStarC_Compiler_List.flatten decls), env1)) + | FStarC_Syntax_Syntax.Sig_let + { + FStarC_Syntax_Syntax.lbs1 = + (uu___1, + { FStarC_Syntax_Syntax.lbname = FStar_Pervasives.Inr b2t; + FStarC_Syntax_Syntax.lbunivs = uu___2; + FStarC_Syntax_Syntax.lbtyp = uu___3; + FStarC_Syntax_Syntax.lbeff = uu___4; + FStarC_Syntax_Syntax.lbdef = uu___5; + FStarC_Syntax_Syntax.lbattrs = uu___6; + FStarC_Syntax_Syntax.lbpos = uu___7;_}::[]); + FStarC_Syntax_Syntax.lids1 = uu___8;_} + when + FStarC_Syntax_Syntax.fv_eq_lid b2t FStarC_Parser_Const.b2t_lid -> + let uu___9 = + FStarC_SMTEncoding_Env.new_term_constant_and_tok_from_lid env + (b2t.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + Prims.int_one in + (match uu___9 with + | (tname, ttok, env1) -> + let xx = + FStarC_SMTEncoding_Term.mk_fv + ("x", FStarC_SMTEncoding_Term.Term_sort) in + let x = FStarC_SMTEncoding_Util.mkFreeV xx in + let b2t_x = FStarC_SMTEncoding_Util.mkApp ("Prims.b2t", [x]) in + let valid_b2t_x = + FStarC_SMTEncoding_Util.mkApp ("Valid", [b2t_x]) in + let bool_ty = + let uu___10 = + FStarC_Syntax_Syntax.withsort + FStarC_Parser_Const.bool_lid in + FStarC_SMTEncoding_Env.lookup_free_var env1 uu___10 in + let decls = + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = FStarC_Syntax_Syntax.range_of_fv b2t in + let uu___15 = + let uu___16 = + let uu___17 = + let uu___18 = + FStarC_SMTEncoding_Util.mkApp + ((FStar_Pervasives_Native.snd + FStarC_SMTEncoding_Term.boxBoolFun), + [x]) in + (valid_b2t_x, uu___18) in + FStarC_SMTEncoding_Util.mkEq uu___17 in + ([[b2t_x]], [xx], uu___16) in + FStarC_SMTEncoding_Term.mkForall uu___14 uu___15 in + (uu___13, (FStar_Pervasives_Native.Some "b2t def"), + "b2t_def") in + FStarC_SMTEncoding_Util.mkAssume uu___12 in + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = + FStarC_Syntax_Syntax.range_of_fv b2t in + let uu___17 = + let uu___18 = + let uu___19 = + let uu___20 = + FStarC_SMTEncoding_Term.mk_HasType x + bool_ty in + let uu___21 = + FStarC_SMTEncoding_Term.mk_HasType b2t_x + FStarC_SMTEncoding_Term.mk_Term_type in + (uu___20, uu___21) in + FStarC_SMTEncoding_Util.mkImp uu___19 in + ([[b2t_x]], [xx], uu___18) in + FStarC_SMTEncoding_Term.mkForall uu___16 uu___17 in + (uu___15, + (FStar_Pervasives_Native.Some "b2t typing"), + "b2t_typing") in + FStarC_SMTEncoding_Util.mkAssume uu___14 in + [uu___13] in + uu___11 :: uu___12 in + (FStarC_SMTEncoding_Term.DeclFun + (tname, [FStarC_SMTEncoding_Term.Term_sort], + FStarC_SMTEncoding_Term.Term_sort, + FStar_Pervasives_Native.None)) + :: uu___10 in + let uu___10 = FStarC_SMTEncoding_Term.mk_decls_trivial decls in + (uu___10, env1)) + | FStarC_Syntax_Syntax.Sig_let uu___1 when + FStarC_Compiler_Util.for_some + (fun uu___2 -> + match uu___2 with + | FStarC_Syntax_Syntax.Discriminator uu___3 -> true + | uu___3 -> false) se.FStarC_Syntax_Syntax.sigquals + -> + ((let uu___3 = FStarC_Compiler_Effect.op_Bang dbg_SMTEncoding in + if uu___3 + then + let uu___4 = FStarC_Syntax_Print.sigelt_to_string_short se in + FStarC_Compiler_Util.print1 + "Not encoding discriminator '%s'\n" uu___4 + else ()); + ([], env)) + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = uu___1; + FStarC_Syntax_Syntax.lids1 = lids;_} + when + (FStarC_Compiler_Util.for_some + (fun l -> + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Ident.ns_of_lid l in + FStarC_Compiler_List.hd uu___4 in + FStarC_Ident.string_of_id uu___3 in + uu___2 = "Prims") lids) + && + (FStarC_Compiler_Util.for_some + (fun uu___2 -> + match uu___2 with + | FStarC_Syntax_Syntax.Unfold_for_unification_and_vcgen -> + true + | uu___3 -> false) se.FStarC_Syntax_Syntax.sigquals) + -> + ((let uu___3 = FStarC_Compiler_Effect.op_Bang dbg_SMTEncoding in + if uu___3 + then + let uu___4 = FStarC_Syntax_Print.sigelt_to_string_short se in + FStarC_Compiler_Util.print1 + "Not encoding unfold let from Prims '%s'\n" uu___4 + else ()); + ([], env)) + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (false, lb::[]); + FStarC_Syntax_Syntax.lids1 = uu___1;_} + when + FStarC_Compiler_Util.for_some + (fun uu___2 -> + match uu___2 with + | FStarC_Syntax_Syntax.Projector uu___3 -> true + | uu___3 -> false) se.FStarC_Syntax_Syntax.sigquals + -> + let fv = FStarC_Compiler_Util.right lb.FStarC_Syntax_Syntax.lbname in + let l = (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + let uu___2 = FStarC_SMTEncoding_Env.try_lookup_free_var env l in + (match uu___2 with + | FStar_Pervasives_Native.Some uu___3 -> ([], env) + | FStar_Pervasives_Native.None -> + let se1 = + let uu___3 = FStarC_Ident.range_of_lid l in + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_declare_typ + { + FStarC_Syntax_Syntax.lid2 = l; + FStarC_Syntax_Syntax.us2 = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.t2 = + (lb.FStarC_Syntax_Syntax.lbtyp) + }); + FStarC_Syntax_Syntax.sigrng = uu___3; + FStarC_Syntax_Syntax.sigquals = + (se.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se.FStarC_Syntax_Syntax.sigopts) + } in + encode_sigelt env se1) + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (is_rec, bindings); + FStarC_Syntax_Syntax.lids1 = uu___1;_} + -> + let bindings1 = + FStarC_Compiler_List.map + (fun lb -> + let def = + norm_before_encoding_us env + lb.FStarC_Syntax_Syntax.lbunivs + lb.FStarC_Syntax_Syntax.lbdef in + let typ = + norm_before_encoding_us env + lb.FStarC_Syntax_Syntax.lbunivs + lb.FStarC_Syntax_Syntax.lbtyp in + { + FStarC_Syntax_Syntax.lbname = + (lb.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = typ; + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = def; + FStarC_Syntax_Syntax.lbattrs = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + }) bindings in + encode_top_level_let env (is_rec, bindings1) + se.FStarC_Syntax_Syntax.sigquals + | FStarC_Syntax_Syntax.Sig_bundle + { FStarC_Syntax_Syntax.ses = ses; + FStarC_Syntax_Syntax.lids = uu___1;_} + -> + let uu___2 = + FStarC_Compiler_List.fold_left + (fun uu___3 -> + fun se1 -> + match uu___3 with + | (g, env1) -> + let uu___4 = + match se1.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_inductive_typ uu___5 -> + encode_sig_inductive env1 se1 + | FStarC_Syntax_Syntax.Sig_datacon uu___5 -> + encode_datacon env1 se1 + | uu___5 -> encode_sigelt env1 se1 in + (match uu___4 with + | (g', env2) -> + ((FStarC_Compiler_List.op_At g g'), env2))) + ([], env) ses in + (match uu___2 with + | (g, env1) -> + let uu___3 = + FStarC_Compiler_List.fold_left + (fun uu___4 -> + fun elt -> + match uu___4 with + | (g', inversions) -> + let uu___5 = + FStarC_Compiler_List.partition + (fun uu___6 -> + match uu___6 with + | FStarC_SMTEncoding_Term.Assume + { + FStarC_SMTEncoding_Term.assumption_term + = uu___7; + FStarC_SMTEncoding_Term.assumption_caption + = FStar_Pervasives_Native.Some + "inversion axiom"; + FStarC_SMTEncoding_Term.assumption_name + = uu___8; + FStarC_SMTEncoding_Term.assumption_fact_ids + = uu___9; + FStarC_SMTEncoding_Term.assumption_free_names + = uu___10;_} + -> false + | uu___7 -> true) + elt.FStarC_SMTEncoding_Term.decls in + (match uu___5 with + | (elt_g', elt_inversions) -> + ((FStarC_Compiler_List.op_At g' + [{ + FStarC_SMTEncoding_Term.sym_name = + (elt.FStarC_SMTEncoding_Term.sym_name); + FStarC_SMTEncoding_Term.key = + (elt.FStarC_SMTEncoding_Term.key); + FStarC_SMTEncoding_Term.decls = + elt_g'; + FStarC_SMTEncoding_Term.a_names = + (elt.FStarC_SMTEncoding_Term.a_names) + }]), + (FStarC_Compiler_List.op_At inversions + elt_inversions)))) ([], []) g in + (match uu___3 with + | (g', inversions) -> + let uu___4 = + FStarC_Compiler_List.fold_left + (fun uu___5 -> + fun elt -> + match uu___5 with + | (decls, elts, rest) -> + let uu___6 = + (FStarC_Compiler_Util.is_some + elt.FStarC_SMTEncoding_Term.key) + && + (FStarC_Compiler_List.existsb + (fun uu___7 -> + match uu___7 with + | FStarC_SMTEncoding_Term.DeclFun + uu___8 -> true + | uu___8 -> false) + elt.FStarC_SMTEncoding_Term.decls) in + if uu___6 + then + (decls, + (FStarC_Compiler_List.op_At elts [elt]), + rest) + else + (let uu___8 = + FStarC_Compiler_List.partition + (fun uu___9 -> + match uu___9 with + | FStarC_SMTEncoding_Term.DeclFun + uu___10 -> true + | uu___10 -> false) + elt.FStarC_SMTEncoding_Term.decls in + match uu___8 with + | (elt_decls, elt_rest) -> + ((FStarC_Compiler_List.op_At decls + elt_decls), elts, + (FStarC_Compiler_List.op_At rest + [{ + FStarC_SMTEncoding_Term.sym_name + = + (elt.FStarC_SMTEncoding_Term.sym_name); + FStarC_SMTEncoding_Term.key + = + (elt.FStarC_SMTEncoding_Term.key); + FStarC_SMTEncoding_Term.decls + = elt_rest; + FStarC_SMTEncoding_Term.a_names + = + (elt.FStarC_SMTEncoding_Term.a_names) + }])))) ([], [], []) g' in + (match uu___4 with + | (decls, elts, rest) -> + let uu___5 = + let uu___6 = + FStarC_SMTEncoding_Term.mk_decls_trivial decls in + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_SMTEncoding_Term.mk_decls_trivial + inversions in + FStarC_Compiler_List.op_At rest uu___9 in + FStarC_Compiler_List.op_At elts uu___8 in + FStarC_Compiler_List.op_At uu___6 uu___7 in + (uu___5, env1))))) +let (encode_env_bindings : + FStarC_SMTEncoding_Env.env_t -> + FStarC_Syntax_Syntax.binding Prims.list -> + (FStarC_SMTEncoding_Term.decls_t * FStarC_SMTEncoding_Env.env_t)) + = + fun env -> + fun bindings -> + let encode_binding b uu___ = + match uu___ with + | (i, decls, env1) -> + (match b with + | FStarC_Syntax_Syntax.Binding_univ uu___1 -> + ((i + Prims.int_one), decls, env1) + | FStarC_Syntax_Syntax.Binding_var x -> + let t1 = + norm_before_encoding env1 x.FStarC_Syntax_Syntax.sort in + ((let uu___2 = + FStarC_Compiler_Effect.op_Bang dbg_SMTEncoding in + if uu___2 + then + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_bv + x in + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + x.FStarC_Syntax_Syntax.sort in + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.print3 "Normalized %s : %s to %s\n" + uu___3 uu___4 uu___5 + else ()); + (let uu___2 = + FStarC_SMTEncoding_EncodeTerm.encode_term t1 env1 in + match uu___2 with + | (t, decls') -> + let t_hash = FStarC_SMTEncoding_Term.hash_of_term t in + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Compiler_Util.digest_of_string t_hash in + Prims.strcat uu___6 + (Prims.strcat "_" (Prims.string_of_int i)) in + Prims.strcat "x_" uu___5 in + FStarC_SMTEncoding_Env.new_term_constant_from_string + env1 x uu___4 in + (match uu___3 with + | (xxsym, xx, env') -> + let t2 = + FStarC_SMTEncoding_Term.mk_HasTypeWithFuel + FStar_Pervasives_Native.None xx t in + let caption = + let uu___4 = FStarC_Options.log_queries () in + if uu___4 + then + let uu___5 = + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_bv x in + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + x.FStarC_Syntax_Syntax.sort in + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.format3 "%s : %s (%s)" + uu___6 uu___7 uu___8 in + FStar_Pervasives_Native.Some uu___5 + else FStar_Pervasives_Native.None in + let ax = + let a_name = Prims.strcat "binder_" xxsym in + FStarC_SMTEncoding_Util.mkAssume + (t2, (FStar_Pervasives_Native.Some a_name), + a_name) in + let g = + let uu___4 = + FStarC_SMTEncoding_Term.mk_decls_trivial + [FStarC_SMTEncoding_Term.DeclFun + (xxsym, [], + FStarC_SMTEncoding_Term.Term_sort, + caption)] in + let uu___5 = + let uu___6 = + FStarC_SMTEncoding_Term.mk_decls_trivial + [ax] in + FStarC_Compiler_List.op_At decls' uu___6 in + FStarC_Compiler_List.op_At uu___4 uu___5 in + ((i + Prims.int_one), + (FStarC_Compiler_List.op_At decls g), env')))) + | FStarC_Syntax_Syntax.Binding_lid (x, (uu___1, t)) -> + let t_norm = norm_before_encoding env1 t in + let fv = + FStarC_Syntax_Syntax.lid_as_fv x + FStar_Pervasives_Native.None in + let uu___2 = encode_free_var false env1 fv t t_norm [] in + (match uu___2 with + | (g, env') -> + ((i + Prims.int_one), + (FStarC_Compiler_List.op_At decls g), env'))) in + let uu___ = + FStarC_Compiler_List.fold_right encode_binding bindings + (Prims.int_zero, [], env) in + match uu___ with | (uu___1, decls, env1) -> (decls, env1) +let (encode_labels : + FStarC_SMTEncoding_Term.error_label Prims.list -> + (FStarC_SMTEncoding_Term.decl Prims.list * FStarC_SMTEncoding_Term.decl + Prims.list)) + = + fun labs -> + let prefix = + FStarC_Compiler_List.map + (fun uu___ -> + match uu___ with + | (l, uu___1, uu___2) -> + let uu___3 = + let uu___4 = FStarC_SMTEncoding_Term.fv_name l in + (uu___4, [], FStarC_SMTEncoding_Term.Bool_sort, + FStar_Pervasives_Native.None) in + FStarC_SMTEncoding_Term.DeclFun uu___3) labs in + let suffix = + FStarC_Compiler_List.collect + (fun uu___ -> + match uu___ with + | (l, uu___1, uu___2) -> + let uu___3 = + let uu___4 = FStarC_SMTEncoding_Term.fv_name l in + FStarC_SMTEncoding_Term.Echo uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = FStarC_SMTEncoding_Util.mkFreeV l in + FStarC_SMTEncoding_Term.Eval uu___6 in + [uu___5] in + uu___3 :: uu___4) labs in + (prefix, suffix) +let (last_env : + FStarC_SMTEncoding_Env.env_t Prims.list FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref [] +let (init_env : FStarC_TypeChecker_Env.env -> unit) = + fun tcenv -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Compiler_Util.psmap_empty () in + let uu___3 = + let uu___4 = FStarC_Compiler_Util.psmap_empty () in (uu___4, []) in + let uu___4 = + let uu___5 = FStarC_TypeChecker_Env.current_module tcenv in + FStarC_Ident.string_of_lid uu___5 in + let uu___5 = FStarC_Compiler_Util.smap_create (Prims.of_int (100)) in + { + FStarC_SMTEncoding_Env.bvar_bindings = uu___2; + FStarC_SMTEncoding_Env.fvar_bindings = uu___3; + FStarC_SMTEncoding_Env.depth = Prims.int_zero; + FStarC_SMTEncoding_Env.tcenv = tcenv; + FStarC_SMTEncoding_Env.warn = true; + FStarC_SMTEncoding_Env.nolabels = false; + FStarC_SMTEncoding_Env.use_zfuel_name = false; + FStarC_SMTEncoding_Env.encode_non_total_function_typ = true; + FStarC_SMTEncoding_Env.current_module_name = uu___4; + FStarC_SMTEncoding_Env.encoding_quantifier = false; + FStarC_SMTEncoding_Env.global_cache = uu___5 + } in + [uu___1] in + FStarC_Compiler_Effect.op_Colon_Equals last_env uu___ +let (get_env : + FStarC_Ident.lident -> + FStarC_TypeChecker_Env.env -> FStarC_SMTEncoding_Env.env_t) + = + fun cmn -> + fun tcenv -> + let uu___ = FStarC_Compiler_Effect.op_Bang last_env in + match uu___ with + | [] -> failwith "No env; call init first!" + | e::uu___1 -> + let uu___2 = FStarC_Ident.string_of_lid cmn in + { + FStarC_SMTEncoding_Env.bvar_bindings = + (e.FStarC_SMTEncoding_Env.bvar_bindings); + FStarC_SMTEncoding_Env.fvar_bindings = + (e.FStarC_SMTEncoding_Env.fvar_bindings); + FStarC_SMTEncoding_Env.depth = (e.FStarC_SMTEncoding_Env.depth); + FStarC_SMTEncoding_Env.tcenv = tcenv; + FStarC_SMTEncoding_Env.warn = (e.FStarC_SMTEncoding_Env.warn); + FStarC_SMTEncoding_Env.nolabels = + (e.FStarC_SMTEncoding_Env.nolabels); + FStarC_SMTEncoding_Env.use_zfuel_name = + (e.FStarC_SMTEncoding_Env.use_zfuel_name); + FStarC_SMTEncoding_Env.encode_non_total_function_typ = + (e.FStarC_SMTEncoding_Env.encode_non_total_function_typ); + FStarC_SMTEncoding_Env.current_module_name = uu___2; + FStarC_SMTEncoding_Env.encoding_quantifier = + (e.FStarC_SMTEncoding_Env.encoding_quantifier); + FStarC_SMTEncoding_Env.global_cache = + (e.FStarC_SMTEncoding_Env.global_cache) + } +let (set_env : FStarC_SMTEncoding_Env.env_t -> unit) = + fun env -> + let uu___ = FStarC_Compiler_Effect.op_Bang last_env in + match uu___ with + | [] -> failwith "Empty env stack" + | uu___1::tl -> + FStarC_Compiler_Effect.op_Colon_Equals last_env (env :: tl) +let (get_current_env : + FStarC_TypeChecker_Env.env -> FStarC_SMTEncoding_Env.env_t) = + fun tcenv -> + let uu___ = FStarC_TypeChecker_Env.current_module tcenv in + get_env uu___ tcenv +let (push_env : unit -> unit) = + fun uu___ -> + let uu___1 = FStarC_Compiler_Effect.op_Bang last_env in + match uu___1 with + | [] -> failwith "Empty env stack" + | hd::tl -> + let top = copy_env hd in + FStarC_Compiler_Effect.op_Colon_Equals last_env (top :: hd :: tl) +let (pop_env : unit -> unit) = + fun uu___ -> + let uu___1 = FStarC_Compiler_Effect.op_Bang last_env in + match uu___1 with + | [] -> failwith "Popping an empty stack" + | uu___2::tl -> FStarC_Compiler_Effect.op_Colon_Equals last_env tl +let (snapshot_env : unit -> (Prims.int * unit)) = + fun uu___ -> FStarC_Common.snapshot push_env last_env () +let (rollback_env : Prims.int FStar_Pervasives_Native.option -> unit) = + fun depth -> FStarC_Common.rollback pop_env last_env depth +let (init : FStarC_TypeChecker_Env.env -> unit) = + fun tcenv -> + init_env tcenv; + FStarC_SMTEncoding_Z3.giveZ3 [FStarC_SMTEncoding_Term.DefPrelude] +let (snapshot_encoding : Prims.string -> encoding_depth) = + fun msg -> + FStarC_Compiler_Util.atomically + (fun uu___ -> + let uu___1 = snapshot_env () in + match uu___1 with + | (env_depth, ()) -> + let uu___2 = + FStarC_SMTEncoding_Env.varops.FStarC_SMTEncoding_Env.snapshot + () in + (match uu___2 with + | (varops_depth, ()) -> (env_depth, varops_depth))) +let (rollback_encoding : + Prims.string -> encoding_depth FStar_Pervasives_Native.option -> unit) = + fun msg -> + fun depth -> + FStarC_Compiler_Util.atomically + (fun uu___ -> + let uu___1 = + match depth with + | FStar_Pervasives_Native.Some (s1, s2) -> + ((FStar_Pervasives_Native.Some s1), + (FStar_Pervasives_Native.Some s2)) + | FStar_Pervasives_Native.None -> + (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) in + match uu___1 with + | (env_depth, varops_depth) -> + (rollback_env env_depth; + FStarC_SMTEncoding_Env.varops.FStarC_SMTEncoding_Env.rollback + varops_depth)) +let (push_encoding_state : Prims.string -> unit) = + fun msg -> let uu___ = snapshot_encoding msg in () +let (pop_encoding_state : Prims.string -> unit) = + fun msg -> rollback_encoding msg FStar_Pervasives_Native.None +let (open_fact_db_tags : + FStarC_SMTEncoding_Env.env_t -> + FStarC_SMTEncoding_Term.fact_db_id Prims.list) + = fun env -> [] +let (place_decl_in_fact_dbs : + FStarC_SMTEncoding_Env.env_t -> + FStarC_SMTEncoding_Term.fact_db_id Prims.list -> + FStarC_SMTEncoding_Term.decl -> FStarC_SMTEncoding_Term.decl) + = + fun env -> + fun fact_db_ids -> + fun d -> + match (fact_db_ids, d) with + | (uu___::uu___1, FStarC_SMTEncoding_Term.Assume a) -> + FStarC_SMTEncoding_Term.Assume + { + FStarC_SMTEncoding_Term.assumption_term = + (a.FStarC_SMTEncoding_Term.assumption_term); + FStarC_SMTEncoding_Term.assumption_caption = + (a.FStarC_SMTEncoding_Term.assumption_caption); + FStarC_SMTEncoding_Term.assumption_name = + (a.FStarC_SMTEncoding_Term.assumption_name); + FStarC_SMTEncoding_Term.assumption_fact_ids = fact_db_ids; + FStarC_SMTEncoding_Term.assumption_free_names = + (a.FStarC_SMTEncoding_Term.assumption_free_names) + } + | uu___ -> d +let (place_decl_elt_in_fact_dbs : + FStarC_SMTEncoding_Env.env_t -> + FStarC_SMTEncoding_Term.fact_db_id Prims.list -> + FStarC_SMTEncoding_Term.decls_elt -> FStarC_SMTEncoding_Term.decls_elt) + = + fun env -> + fun fact_db_ids -> + fun elt -> + let uu___ = + FStarC_Compiler_List.map (place_decl_in_fact_dbs env fact_db_ids) + elt.FStarC_SMTEncoding_Term.decls in + { + FStarC_SMTEncoding_Term.sym_name = + (elt.FStarC_SMTEncoding_Term.sym_name); + FStarC_SMTEncoding_Term.key = (elt.FStarC_SMTEncoding_Term.key); + FStarC_SMTEncoding_Term.decls = uu___; + FStarC_SMTEncoding_Term.a_names = + (elt.FStarC_SMTEncoding_Term.a_names) + } +let (fact_dbs_for_lid : + FStarC_SMTEncoding_Env.env_t -> + FStarC_Ident.lid -> FStarC_SMTEncoding_Term.fact_db_id Prims.list) + = + fun env -> + fun lid -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Ident.ns_of_lid lid in + FStarC_Ident.lid_of_ids uu___3 in + FStarC_SMTEncoding_Term.Namespace uu___2 in + let uu___2 = open_fact_db_tags env in uu___1 :: uu___2 in + (FStarC_SMTEncoding_Term.Name lid) :: uu___ +let (encode_top_level_facts : + FStarC_SMTEncoding_Env.env_t -> + FStarC_Syntax_Syntax.sigelt -> + (FStarC_SMTEncoding_Term.decls_elt Prims.list * + FStarC_SMTEncoding_Env.env_t)) + = + fun env -> + fun se -> + let fact_db_ids = + FStarC_Compiler_List.collect (fact_dbs_for_lid env) + (FStarC_Syntax_Util.lids_of_sigelt se) in + let uu___ = encode_sigelt env se in + match uu___ with + | (g, env1) -> + let g1 = + FStarC_Compiler_List.map + (place_decl_elt_in_fact_dbs env1 fact_db_ids) g in + (g1, env1) +let (recover_caching_and_update_env : + FStarC_SMTEncoding_Env.env_t -> + FStarC_SMTEncoding_Term.decls_t -> FStarC_SMTEncoding_Term.decls_t) + = + fun env -> + fun decls -> + FStarC_Compiler_List.collect + (fun elt -> + if elt.FStarC_SMTEncoding_Term.key = FStar_Pervasives_Native.None + then [elt] + else + (let uu___1 = + let uu___2 = + FStarC_Compiler_Util.must elt.FStarC_SMTEncoding_Term.key in + FStarC_Compiler_Util.smap_try_find + env.FStarC_SMTEncoding_Env.global_cache uu___2 in + match uu___1 with + | FStar_Pervasives_Native.Some cache_elt -> + FStarC_SMTEncoding_Term.mk_decls_trivial + [FStarC_SMTEncoding_Term.RetainAssumptions + (cache_elt.FStarC_SMTEncoding_Term.a_names)] + | FStar_Pervasives_Native.None -> + ((let uu___3 = + FStarC_Compiler_Util.must + elt.FStarC_SMTEncoding_Term.key in + FStarC_Compiler_Util.smap_add + env.FStarC_SMTEncoding_Env.global_cache uu___3 elt); + [elt]))) decls +let (encode_sig : + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.sigelt -> unit) = + fun tcenv -> + fun se -> + let caption decls = + let uu___ = FStarC_Options.log_queries () in + if uu___ + then + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Print.sigelt_to_string_short se in + Prims.strcat "encoding sigelt " uu___3 in + FStarC_SMTEncoding_Term.Caption uu___2 in + uu___1 :: decls + else decls in + (let uu___1 = FStarC_Compiler_Debug.medium () in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_sigelt se in + FStarC_Compiler_Util.print1 "+++++++++++Encoding sigelt %s\n" uu___2 + else ()); + (let env = + let uu___1 = FStarC_TypeChecker_Env.current_module tcenv in + get_env uu___1 tcenv in + let uu___1 = encode_top_level_facts env se in + match uu___1 with + | (decls, env1) -> + (set_env env1; + (let uu___3 = + let uu___4 = + let uu___5 = recover_caching_and_update_env env1 decls in + FStarC_SMTEncoding_Term.decls_list_of uu___5 in + caption uu___4 in + FStarC_SMTEncoding_Z3.giveZ3 uu___3))) +let (give_decls_to_z3_and_set_env : + FStarC_SMTEncoding_Env.env_t -> + Prims.string -> FStarC_SMTEncoding_Term.decls_t -> unit) + = + fun env -> + fun name -> + fun decls -> + let caption decls1 = + let uu___ = FStarC_Options.log_queries () in + if uu___ + then + let msg = Prims.strcat "Externals for " name in + [FStarC_SMTEncoding_Term.Module + (name, + (FStarC_Compiler_List.op_At + ((FStarC_SMTEncoding_Term.Caption msg) :: decls1) + [FStarC_SMTEncoding_Term.Caption + (Prims.strcat "End " msg)]))] + else [FStarC_SMTEncoding_Term.Module (name, decls1)] in + set_env + { + FStarC_SMTEncoding_Env.bvar_bindings = + (env.FStarC_SMTEncoding_Env.bvar_bindings); + FStarC_SMTEncoding_Env.fvar_bindings = + (env.FStarC_SMTEncoding_Env.fvar_bindings); + FStarC_SMTEncoding_Env.depth = (env.FStarC_SMTEncoding_Env.depth); + FStarC_SMTEncoding_Env.tcenv = (env.FStarC_SMTEncoding_Env.tcenv); + FStarC_SMTEncoding_Env.warn = true; + FStarC_SMTEncoding_Env.nolabels = + (env.FStarC_SMTEncoding_Env.nolabels); + FStarC_SMTEncoding_Env.use_zfuel_name = + (env.FStarC_SMTEncoding_Env.use_zfuel_name); + FStarC_SMTEncoding_Env.encode_non_total_function_typ = + (env.FStarC_SMTEncoding_Env.encode_non_total_function_typ); + FStarC_SMTEncoding_Env.current_module_name = + (env.FStarC_SMTEncoding_Env.current_module_name); + FStarC_SMTEncoding_Env.encoding_quantifier = + (env.FStarC_SMTEncoding_Env.encoding_quantifier); + FStarC_SMTEncoding_Env.global_cache = + (env.FStarC_SMTEncoding_Env.global_cache) + }; + (let z3_decls = + let uu___1 = + let uu___2 = recover_caching_and_update_env env decls in + FStarC_SMTEncoding_Term.decls_list_of uu___2 in + caption uu___1 in + FStarC_SMTEncoding_Z3.giveZ3 z3_decls) +let (encode_modul : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.modul -> + (FStarC_SMTEncoding_Term.decls_t * FStarC_SMTEncoding_Env.fvar_binding + Prims.list)) + = + fun tcenv -> + fun modul -> + let uu___ = (FStarC_Options.lax ()) && (FStarC_Options.ml_ish ()) in + if uu___ + then ([], []) + else + (let tcenv1 = + FStarC_TypeChecker_Env.set_current_module tcenv + modul.FStarC_Syntax_Syntax.name in + FStarC_Syntax_Unionfind.with_uf_enabled + (fun uu___2 -> + FStarC_SMTEncoding_Env.varops.FStarC_SMTEncoding_Env.reset_fresh + (); + (let name = + let uu___4 = + FStarC_Ident.string_of_lid modul.FStarC_Syntax_Syntax.name in + FStarC_Compiler_Util.format2 "%s %s" + (if modul.FStarC_Syntax_Syntax.is_interface + then "interface" + else "module") uu___4 in + (let uu___5 = FStarC_Compiler_Debug.medium () in + if uu___5 + then + FStarC_Compiler_Util.print2 + "+++++++++++Encoding externals for %s ... %s declarations\n" + name + (Prims.string_of_int + (FStarC_Compiler_List.length + modul.FStarC_Syntax_Syntax.declarations)) + else ()); + (let env = + let uu___5 = get_env modul.FStarC_Syntax_Syntax.name tcenv1 in + FStarC_SMTEncoding_Env.reset_current_module_fvbs uu___5 in + let encode_signature env1 ses = + FStarC_Compiler_List.fold_left + (fun uu___5 -> + fun se -> + match uu___5 with + | (g, env2) -> + let uu___6 = encode_top_level_facts env2 se in + (match uu___6 with + | (g', env3) -> + ((FStarC_Compiler_List.op_At g g'), env3))) + ([], env1) ses in + let uu___5 = + encode_signature + { + FStarC_SMTEncoding_Env.bvar_bindings = + (env.FStarC_SMTEncoding_Env.bvar_bindings); + FStarC_SMTEncoding_Env.fvar_bindings = + (env.FStarC_SMTEncoding_Env.fvar_bindings); + FStarC_SMTEncoding_Env.depth = + (env.FStarC_SMTEncoding_Env.depth); + FStarC_SMTEncoding_Env.tcenv = + (env.FStarC_SMTEncoding_Env.tcenv); + FStarC_SMTEncoding_Env.warn = false; + FStarC_SMTEncoding_Env.nolabels = + (env.FStarC_SMTEncoding_Env.nolabels); + FStarC_SMTEncoding_Env.use_zfuel_name = + (env.FStarC_SMTEncoding_Env.use_zfuel_name); + FStarC_SMTEncoding_Env.encode_non_total_function_typ = + (env.FStarC_SMTEncoding_Env.encode_non_total_function_typ); + FStarC_SMTEncoding_Env.current_module_name = + (env.FStarC_SMTEncoding_Env.current_module_name); + FStarC_SMTEncoding_Env.encoding_quantifier = + (env.FStarC_SMTEncoding_Env.encoding_quantifier); + FStarC_SMTEncoding_Env.global_cache = + (env.FStarC_SMTEncoding_Env.global_cache) + } modul.FStarC_Syntax_Syntax.declarations in + match uu___5 with + | (decls, env1) -> + (give_decls_to_z3_and_set_env env1 name decls; + (let uu___8 = FStarC_Compiler_Debug.medium () in + if uu___8 + then + FStarC_Compiler_Util.print1 + "Done encoding externals for %s\n" name + else ()); + (decls, + (FStarC_SMTEncoding_Env.get_current_module_fvbs env1))))))) +let (encode_modul_from_cache : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.modul -> + (FStarC_SMTEncoding_Term.decls_t * FStarC_SMTEncoding_Env.fvar_binding + Prims.list) -> unit) + = + fun tcenv -> + fun tcmod -> + fun uu___ -> + match uu___ with + | (decls, fvbs) -> + let uu___1 = + (FStarC_Options.lax ()) && (FStarC_Options.ml_ish ()) in + if uu___1 + then () + else + (let tcenv1 = + FStarC_TypeChecker_Env.set_current_module tcenv + tcmod.FStarC_Syntax_Syntax.name in + let name = + let uu___3 = + FStarC_Ident.string_of_lid tcmod.FStarC_Syntax_Syntax.name in + FStarC_Compiler_Util.format2 "%s %s" + (if tcmod.FStarC_Syntax_Syntax.is_interface + then "interface" + else "module") uu___3 in + (let uu___4 = FStarC_Compiler_Debug.medium () in + if uu___4 + then + FStarC_Compiler_Util.print2 + "+++++++++++Encoding externals from cache for %s ... %s decls\n" + name + (Prims.string_of_int (FStarC_Compiler_List.length decls)) + else ()); + (let env = + let uu___4 = get_env tcmod.FStarC_Syntax_Syntax.name tcenv1 in + FStarC_SMTEncoding_Env.reset_current_module_fvbs uu___4 in + let env1 = + FStarC_Compiler_List.fold_left + (fun env2 -> + fun fvb -> + FStarC_SMTEncoding_Env.add_fvar_binding_to_env fvb + env2) env (FStarC_Compiler_List.rev fvbs) in + give_decls_to_z3_and_set_env env1 name decls; + (let uu___5 = FStarC_Compiler_Debug.medium () in + if uu___5 + then + FStarC_Compiler_Util.print1 + "Done encoding externals from cache for %s\n" name + else ()))) +let (encode_query : + (unit -> Prims.string) FStar_Pervasives_Native.option -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + (FStarC_SMTEncoding_Term.decl Prims.list * + FStarC_SMTEncoding_ErrorReporting.label Prims.list * + FStarC_SMTEncoding_Term.decl * FStarC_SMTEncoding_Term.decl + Prims.list)) + = + fun use_env_msg -> + fun tcenv -> + fun q -> + FStarC_Errors.with_ctx "While encoding a query" + (fun uu___ -> + (let uu___2 = + let uu___3 = FStarC_TypeChecker_Env.current_module tcenv in + FStarC_Ident.string_of_lid uu___3 in + FStarC_SMTEncoding_Z3.query_logging.FStarC_SMTEncoding_Z3.set_module_name + uu___2); + (let env = + let uu___2 = FStarC_TypeChecker_Env.current_module tcenv in + get_env uu___2 tcenv in + let uu___2 = + let rec aux bindings = + match bindings with + | (FStarC_Syntax_Syntax.Binding_var x)::rest -> + let uu___3 = aux rest in + (match uu___3 with + | (out, rest1) -> + let t = + let uu___4 = + FStarC_Syntax_Formula.destruct_typ_as_formula + x.FStarC_Syntax_Syntax.sort in + match uu___4 with + | FStar_Pervasives_Native.Some uu___5 -> + let uu___6 = + FStarC_Syntax_Syntax.new_bv + FStar_Pervasives_Native.None + FStarC_Syntax_Syntax.t_unit in + FStarC_Syntax_Util.refine uu___6 + x.FStarC_Syntax_Syntax.sort + | uu___5 -> x.FStarC_Syntax_Syntax.sort in + let t1 = + norm_with_steps + [FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Simplify; + FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.EraseUniverses] + env.FStarC_SMTEncoding_Env.tcenv t in + let uu___4 = + let uu___5 = + FStarC_Syntax_Syntax.mk_binder + { + FStarC_Syntax_Syntax.ppname = + (x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (x.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = t1 + } in + uu___5 :: out in + (uu___4, rest1)) + | uu___3 -> ([], bindings) in + let uu___3 = aux tcenv.FStarC_TypeChecker_Env.gamma in + match uu___3 with + | (closing, bindings) -> + let uu___4 = + FStarC_Syntax_Util.close_forall_no_univs + (FStarC_Compiler_List.rev closing) q in + (uu___4, bindings) in + match uu___2 with + | (q1, bindings) -> + let uu___3 = encode_env_bindings env bindings in + (match uu___3 with + | (env_decls, env1) -> + ((let uu___5 = + ((FStarC_Compiler_Debug.medium ()) || + (FStarC_Compiler_Effect.op_Bang dbg_SMTEncoding)) + || (FStarC_Compiler_Effect.op_Bang dbg_SMTQuery) in + if uu___5 + then + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term q1 in + FStarC_Compiler_Util.print1 + "Encoding query formula {: %s\n" uu___6 + else ()); + (let uu___5 = + FStarC_Compiler_Util.record_time + (fun uu___6 -> + FStarC_SMTEncoding_EncodeTerm.encode_formula + q1 env1) in + match uu___5 with + | ((phi, qdecls), ms) -> + let uu___6 = + let uu___7 = + FStarC_TypeChecker_Env.get_range tcenv in + FStarC_SMTEncoding_ErrorReporting.label_goals + use_env_msg uu___7 phi in + (match uu___6 with + | (labels, phi1) -> + let uu___7 = encode_labels labels in + (match uu___7 with + | (label_prefix, label_suffix) -> + let caption = + let uu___8 = + (FStarC_Options.log_queries ()) || + (FStarC_Options.log_failing_queries + ()) in + if uu___8 + then + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + q1 in + Prims.strcat + "Encoding query formula : " + uu___11 in + FStarC_SMTEncoding_Term.Caption + uu___10 in + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_Errors.get_ctx () in + FStarC_Compiler_String.concat + "\n" uu___14 in + Prims.strcat "Context: " + uu___13 in + FStarC_SMTEncoding_Term.Caption + uu___12 in + [uu___11] in + uu___9 :: uu___10 + else [] in + let query_prelude = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_SMTEncoding_Term.mk_decls_trivial + label_prefix in + let uu___12 = + let uu___13 = + FStarC_SMTEncoding_Term.mk_decls_trivial + caption in + FStarC_Compiler_List.op_At + qdecls uu___13 in + FStarC_Compiler_List.op_At + uu___11 uu___12 in + FStarC_Compiler_List.op_At + env_decls uu___10 in + recover_caching_and_update_env + env1 uu___9 in + FStarC_SMTEncoding_Term.decls_list_of + uu___8 in + let qry = + let uu___8 = + let uu___9 = + FStarC_SMTEncoding_Util.mkNot + phi1 in + let uu___10 = + FStarC_SMTEncoding_Env.varops.FStarC_SMTEncoding_Env.mk_unique + "@query" in + (uu___9, + (FStar_Pervasives_Native.Some + "query"), uu___10) in + FStarC_SMTEncoding_Util.mkAssume + uu___8 in + let suffix = + FStarC_Compiler_List.op_At + [FStarC_SMTEncoding_Term.Echo + ""] + (FStarC_Compiler_List.op_At + label_suffix + [FStarC_SMTEncoding_Term.Echo + ""; + FStarC_SMTEncoding_Term.Echo + "Done!"]) in + ((let uu___9 = + ((FStarC_Compiler_Debug.medium ()) + || + (FStarC_Compiler_Effect.op_Bang + dbg_SMTEncoding)) + || + (FStarC_Compiler_Effect.op_Bang + dbg_SMTQuery) in + if uu___9 + then + FStarC_Compiler_Util.print_string + "} Done encoding\n" + else ()); + (let uu___10 = + ((FStarC_Compiler_Debug.medium ()) + || + (FStarC_Compiler_Effect.op_Bang + dbg_SMTEncoding)) + || + (FStarC_Compiler_Effect.op_Bang + dbg_Time) in + if uu___10 + then + FStarC_Compiler_Util.print1 + "Encoding took %sms\n" + (Prims.string_of_int ms) + else ()); + (query_prelude, labels, qry, suffix))))))))) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_SMTEncoding_EncodeTerm.ml b/ocaml/fstar-lib/generated/FStarC_SMTEncoding_EncodeTerm.ml new file mode 100644 index 00000000000..3a344effbc2 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_SMTEncoding_EncodeTerm.ml @@ -0,0 +1,3987 @@ +open Prims +let (dbg_PartialApp : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "PartialApp" +let (dbg_SMTEncoding : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "SMTEncoding" +let (dbg_SMTEncodingReify : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "SMTEncodingReify" +let mkForall_fuel' : + 'uuuuu . + Prims.string -> + FStarC_Compiler_Range_Type.range -> + 'uuuuu -> + (FStarC_SMTEncoding_Term.pat Prims.list Prims.list * + FStarC_SMTEncoding_Term.fvs * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term + = + fun mname -> + fun r -> + fun n -> + fun uu___ -> + match uu___ with + | (pats, vars, body) -> + let fallback uu___1 = + FStarC_SMTEncoding_Term.mkForall r (pats, vars, body) in + let uu___1 = FStarC_Options.unthrottle_inductives () in + if uu___1 + then fallback () + else + (let uu___3 = + FStarC_SMTEncoding_Env.fresh_fvar mname "f" + FStarC_SMTEncoding_Term.Fuel_sort in + match uu___3 with + | (fsym, fterm) -> + let add_fuel tms = + FStarC_Compiler_List.map + (fun p -> + match p.FStarC_SMTEncoding_Term.tm with + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Var "HasType", args) + -> + FStarC_SMTEncoding_Util.mkApp + ("HasTypeFuel", (fterm :: args)) + | uu___4 -> p) tms in + let pats1 = FStarC_Compiler_List.map add_fuel pats in + let body1 = + match body.FStarC_SMTEncoding_Term.tm with + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Imp, guard::body'::[]) -> + let guard1 = + match guard.FStarC_SMTEncoding_Term.tm with + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.And, guards) -> + let uu___4 = add_fuel guards in + FStarC_SMTEncoding_Util.mk_and_l uu___4 + | uu___4 -> + let uu___5 = add_fuel [guard] in + FStarC_Compiler_List.hd uu___5 in + FStarC_SMTEncoding_Util.mkImp (guard1, body') + | uu___4 -> body in + let vars1 = + let uu___4 = + FStarC_SMTEncoding_Term.mk_fv + (fsym, FStarC_SMTEncoding_Term.Fuel_sort) in + uu___4 :: vars in + FStarC_SMTEncoding_Term.mkForall r (pats1, vars1, body1)) +let (mkForall_fuel : + Prims.string -> + FStarC_Compiler_Range_Type.range -> + (FStarC_SMTEncoding_Term.pat Prims.list Prims.list * + FStarC_SMTEncoding_Term.fvs * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = fun mname -> fun r -> mkForall_fuel' mname r Prims.int_one +let (head_normal : + FStarC_SMTEncoding_Env.env_t -> FStarC_Syntax_Syntax.term -> Prims.bool) = + fun env -> + fun t -> + let t1 = FStarC_Syntax_Util.unmeta t in + match t1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_arrow uu___ -> true + | FStarC_Syntax_Syntax.Tm_refine uu___ -> true + | FStarC_Syntax_Syntax.Tm_bvar uu___ -> true + | FStarC_Syntax_Syntax.Tm_uvar uu___ -> true + | FStarC_Syntax_Syntax.Tm_abs uu___ -> true + | FStarC_Syntax_Syntax.Tm_constant uu___ -> true + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let uu___ = + FStarC_TypeChecker_Env.lookup_definition + [FStarC_TypeChecker_Env.Eager_unfolding_only] + env.FStarC_SMTEncoding_Env.tcenv + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + FStarC_Compiler_Option.isNone uu___ + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar fv; + FStarC_Syntax_Syntax.pos = uu___; + FStarC_Syntax_Syntax.vars = uu___1; + FStarC_Syntax_Syntax.hash_code = uu___2;_}; + FStarC_Syntax_Syntax.args = uu___3;_} + -> + let uu___4 = + FStarC_TypeChecker_Env.lookup_definition + [FStarC_TypeChecker_Env.Eager_unfolding_only] + env.FStarC_SMTEncoding_Env.tcenv + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + FStarC_Compiler_Option.isNone uu___4 + | uu___ -> false +let (head_redex : + FStarC_SMTEncoding_Env.env_t -> FStarC_Syntax_Syntax.term -> Prims.bool) = + fun env -> + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Util.un_uinst t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = uu___1; + FStarC_Syntax_Syntax.body = uu___2; + FStarC_Syntax_Syntax.rc_opt = FStar_Pervasives_Native.Some rc;_} + -> + ((FStarC_Ident.lid_equals rc.FStarC_Syntax_Syntax.residual_effect + FStarC_Parser_Const.effect_Tot_lid) + || + (FStarC_Ident.lid_equals rc.FStarC_Syntax_Syntax.residual_effect + FStarC_Parser_Const.effect_GTot_lid)) + || + (FStarC_Compiler_List.existsb + (fun uu___3 -> + match uu___3 with + | FStarC_Syntax_Syntax.TOTAL -> true + | uu___4 -> false) rc.FStarC_Syntax_Syntax.residual_flags) + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let uu___1 = + FStarC_TypeChecker_Env.lookup_definition + [FStarC_TypeChecker_Env.Eager_unfolding_only] + env.FStarC_SMTEncoding_Env.tcenv + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + FStarC_Compiler_Option.isSome uu___1 + | uu___1 -> false +let (norm_with_steps : + FStarC_TypeChecker_Env.steps -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun steps -> + fun env -> + fun t -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_Env.current_module env in + FStarC_Ident.string_of_lid uu___2 in + FStar_Pervasives_Native.Some uu___1 in + FStarC_Profiling.profile + (fun uu___1 -> FStarC_TypeChecker_Normalize.normalize steps env t) + uu___ "FStarC.SMTEncoding.EncodeTerm.norm_with_steps" +let (normalize_refinement : + FStarC_TypeChecker_Env.steps -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.typ) + = + fun steps -> + fun env -> + fun t -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_Env.current_module env in + FStarC_Ident.string_of_lid uu___2 in + FStar_Pervasives_Native.Some uu___1 in + FStarC_Profiling.profile + (fun uu___1 -> + FStarC_TypeChecker_Normalize.normalize_refinement steps env t) + uu___ "FStarC.SMTEncoding.EncodeTerm.normalize_refinement" +let (whnf : + FStarC_SMTEncoding_Env.env_t -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun env -> + fun t -> + let uu___ = head_normal env t in + if uu___ + then t + else + norm_with_steps + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Weak; + FStarC_TypeChecker_Env.HNF; + FStarC_TypeChecker_Env.Exclude FStarC_TypeChecker_Env.Zeta; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.EraseUniverses] + env.FStarC_SMTEncoding_Env.tcenv t +let (norm : + FStarC_SMTEncoding_Env.env_t -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun env -> + fun t -> + norm_with_steps + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Exclude FStarC_TypeChecker_Env.Zeta; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.EraseUniverses] + env.FStarC_SMTEncoding_Env.tcenv t +let (maybe_whnf : + FStarC_SMTEncoding_Env.env_t -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = + fun env -> + fun t -> + let t' = whnf env t in + let uu___ = FStarC_Syntax_Util.head_and_args t' in + match uu___ with + | (head', uu___1) -> + let uu___2 = head_redex env head' in + if uu___2 + then FStar_Pervasives_Native.None + else FStar_Pervasives_Native.Some t' +let (trivial_post : FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) = + fun t -> + let uu___ = let uu___1 = FStarC_Syntax_Syntax.null_binder t in [uu___1] in + let uu___1 = + FStarC_Syntax_Syntax.fvar FStarC_Parser_Const.true_lid + FStar_Pervasives_Native.None in + FStarC_Syntax_Util.abs uu___ uu___1 FStar_Pervasives_Native.None +let (mk_Apply : + FStarC_SMTEncoding_Term.term -> + FStarC_SMTEncoding_Term.fvs -> FStarC_SMTEncoding_Term.term) + = + fun e -> + fun vars -> + FStarC_Compiler_List.fold_left + (fun out -> + fun var -> + let uu___ = FStarC_SMTEncoding_Term.fv_sort var in + match uu___ with + | FStarC_SMTEncoding_Term.Fuel_sort -> + let uu___1 = FStarC_SMTEncoding_Util.mkFreeV var in + FStarC_SMTEncoding_Term.mk_ApplyTF out uu___1 + | s -> + let uu___1 = FStarC_SMTEncoding_Util.mkFreeV var in + FStarC_SMTEncoding_Util.mk_ApplyTT out uu___1) e vars +let (mk_Apply_args : + FStarC_SMTEncoding_Term.term -> + FStarC_SMTEncoding_Term.term Prims.list -> FStarC_SMTEncoding_Term.term) + = + fun e -> + fun args -> + FStarC_Compiler_List.fold_left FStarC_SMTEncoding_Util.mk_ApplyTT e + args +let raise_arity_mismatch : + 'a . + Prims.string -> + Prims.int -> Prims.int -> FStarC_Compiler_Range_Type.range -> 'a + = + fun head -> + fun arity -> + fun n_args -> + fun rng -> + let uu___ = + let uu___1 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) arity in + let uu___2 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) n_args in + FStarC_Compiler_Util.format3 + "Head symbol %s expects at least %s arguments; got only %s" + head uu___1 uu___2 in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range rng + FStarC_Errors_Codes.Fatal_SMTEncodingArityMismatch () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___) +let (isTotFun_axioms : + FStarC_Compiler_Range_Type.range -> + FStarC_SMTEncoding_Term.term -> + FStarC_SMTEncoding_Term.fvs -> + FStarC_SMTEncoding_Term.term Prims.list -> + Prims.bool -> FStarC_SMTEncoding_Term.term) + = + fun pos -> + fun head -> + fun vars -> + fun guards -> + fun is_pure -> + let maybe_mkForall pat vars1 body = + match vars1 with + | [] -> body + | uu___ -> + FStarC_SMTEncoding_Term.mkForall pos (pat, vars1, body) in + let rec is_tot_fun_axioms ctx ctx_guard head1 vars1 guards1 = + match (vars1, guards1) with + | ([], []) -> FStarC_SMTEncoding_Util.mkTrue + | (uu___::[], uu___1) -> + if is_pure + then + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_SMTEncoding_Term.mk_IsTotFun head1 in + (ctx_guard, uu___4) in + FStarC_SMTEncoding_Util.mkImp uu___3 in + maybe_mkForall [[head1]] ctx uu___2 + else FStarC_SMTEncoding_Util.mkTrue + | (x::vars2, g_x::guards2) -> + let is_tot_fun_head = + let uu___ = + let uu___1 = + let uu___2 = + FStarC_SMTEncoding_Term.mk_IsTotFun head1 in + (ctx_guard, uu___2) in + FStarC_SMTEncoding_Util.mkImp uu___1 in + maybe_mkForall [[head1]] ctx uu___ in + let app = mk_Apply head1 [x] in + let ctx1 = FStarC_Compiler_List.op_At ctx [x] in + let ctx_guard1 = + FStarC_SMTEncoding_Util.mkAnd (ctx_guard, g_x) in + let rest = + is_tot_fun_axioms ctx1 ctx_guard1 app vars2 guards2 in + FStarC_SMTEncoding_Util.mkAnd (is_tot_fun_head, rest) + | uu___ -> failwith "impossible: isTotFun_axioms" in + is_tot_fun_axioms [] FStarC_SMTEncoding_Util.mkTrue head vars + guards +let (maybe_curry_app : + FStarC_Compiler_Range_Type.range -> + (FStarC_SMTEncoding_Term.op, FStarC_SMTEncoding_Term.term) + FStar_Pervasives.either -> + Prims.int -> + FStarC_SMTEncoding_Term.term Prims.list -> + FStarC_SMTEncoding_Term.term) + = + fun rng -> + fun head -> + fun arity -> + fun args -> + let n_args = FStarC_Compiler_List.length args in + match head with + | FStar_Pervasives.Inr head1 -> mk_Apply_args head1 args + | FStar_Pervasives.Inl head1 -> + if n_args = arity + then FStarC_SMTEncoding_Util.mkApp' (head1, args) + else + if n_args > arity + then + (let uu___1 = FStarC_Compiler_Util.first_N arity args in + match uu___1 with + | (args1, rest) -> + let head2 = + FStarC_SMTEncoding_Util.mkApp' (head1, args1) in + mk_Apply_args head2 rest) + else + (let uu___2 = FStarC_SMTEncoding_Term.op_to_string head1 in + raise_arity_mismatch uu___2 arity n_args rng) +let (maybe_curry_fvb : + FStarC_Compiler_Range_Type.range -> + FStarC_SMTEncoding_Env.fvar_binding -> + FStarC_SMTEncoding_Term.term Prims.list -> FStarC_SMTEncoding_Term.term) + = + fun rng -> + fun fvb -> + fun args -> + if fvb.FStarC_SMTEncoding_Env.fvb_thunked + then + let uu___ = FStarC_SMTEncoding_Env.force_thunk fvb in + mk_Apply_args uu___ args + else + maybe_curry_app rng + (FStar_Pervasives.Inl + (FStarC_SMTEncoding_Term.Var + (fvb.FStarC_SMTEncoding_Env.smt_id))) + fvb.FStarC_SMTEncoding_Env.smt_arity args +let (is_app : FStarC_SMTEncoding_Term.op -> Prims.bool) = + fun uu___ -> + match uu___ with + | FStarC_SMTEncoding_Term.Var "ApplyTT" -> true + | FStarC_SMTEncoding_Term.Var "ApplyTF" -> true + | uu___1 -> false +let check_pattern_vars : + 'uuuuu . + FStarC_SMTEncoding_Env.env_t -> + FStarC_Syntax_Syntax.binder Prims.list -> + (FStarC_Syntax_Syntax.term * 'uuuuu) Prims.list -> unit + = + fun env -> + fun vars -> + fun pats -> + let pats1 = + FStarC_Compiler_List.map + (fun uu___ -> + match uu___ with + | (x, uu___1) -> + norm_with_steps + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.AllowUnboundUniverses; + FStarC_TypeChecker_Env.EraseUniverses] + env.FStarC_SMTEncoding_Env.tcenv x) pats in + match pats1 with + | [] -> () + | hd::tl -> + let pat_vars = + let uu___ = FStarC_Syntax_Free.names hd in + FStarC_Compiler_List.fold_left + (fun uu___2 -> + fun uu___1 -> + (fun out -> + fun x -> + let uu___1 = FStarC_Syntax_Free.names x in + Obj.magic + (FStarC_Class_Setlike.union () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) + (Obj.magic out) (Obj.magic uu___1))) uu___2 + uu___1) uu___ tl in + let uu___ = + FStarC_Compiler_Util.find_opt + (fun uu___1 -> + match uu___1 with + | { FStarC_Syntax_Syntax.binder_bv = b; + FStarC_Syntax_Syntax.binder_qual = uu___2; + FStarC_Syntax_Syntax.binder_positivity = uu___3; + FStarC_Syntax_Syntax.binder_attrs = uu___4;_} -> + let uu___5 = + FStarC_Class_Setlike.mem () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) b + (Obj.magic pat_vars) in + Prims.op_Negation uu___5) vars in + (match uu___ with + | FStar_Pervasives_Native.None -> () + | FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.binder_bv = x; + FStarC_Syntax_Syntax.binder_qual = uu___1; + FStarC_Syntax_Syntax.binder_positivity = uu___2; + FStarC_Syntax_Syntax.binder_attrs = uu___3;_} + -> + let pos = + FStarC_Compiler_List.fold_left + (fun out -> + fun t -> + FStarC_Compiler_Range_Ops.union_ranges out + t.FStarC_Syntax_Syntax.pos) + hd.FStarC_Syntax_Syntax.pos tl in + let uu___4 = + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_bv x in + FStarC_Compiler_Util.format1 + "SMT pattern misses at least one bound variable: %s" + uu___5 in + FStarC_Errors.log_issue FStarC_Class_HasRange.hasRange_range + pos FStarC_Errors_Codes.Warning_SMTPatternIllFormed () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4)) +type label = + (FStarC_SMTEncoding_Term.fv * Prims.string * + FStarC_Compiler_Range_Type.range) +type labels = label Prims.list +type pattern = + { + pat_vars: (FStarC_Syntax_Syntax.bv * FStarC_SMTEncoding_Term.fv) Prims.list ; + pat_term: + unit -> (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.decls_t) ; + guard: FStarC_SMTEncoding_Term.term -> FStarC_SMTEncoding_Term.term ; + projections: + FStarC_SMTEncoding_Term.term -> + (FStarC_Syntax_Syntax.bv * FStarC_SMTEncoding_Term.term) Prims.list + } +let (__proj__Mkpattern__item__pat_vars : + pattern -> + (FStarC_Syntax_Syntax.bv * FStarC_SMTEncoding_Term.fv) Prims.list) + = + fun projectee -> + match projectee with + | { pat_vars; pat_term; guard; projections;_} -> pat_vars +let (__proj__Mkpattern__item__pat_term : + pattern -> + unit -> (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.decls_t)) + = + fun projectee -> + match projectee with + | { pat_vars; pat_term; guard; projections;_} -> pat_term +let (__proj__Mkpattern__item__guard : + pattern -> FStarC_SMTEncoding_Term.term -> FStarC_SMTEncoding_Term.term) = + fun projectee -> + match projectee with + | { pat_vars; pat_term; guard; projections;_} -> guard +let (__proj__Mkpattern__item__projections : + pattern -> + FStarC_SMTEncoding_Term.term -> + (FStarC_Syntax_Syntax.bv * FStarC_SMTEncoding_Term.term) Prims.list) + = + fun projectee -> + match projectee with + | { pat_vars; pat_term; guard; projections;_} -> projections +let (as_function_typ : + FStarC_SMTEncoding_Env.env_t -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term) + = + fun env -> + fun t0 -> + let rec aux norm1 t = + let t1 = FStarC_Syntax_Subst.compress t in + match t1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_arrow uu___ -> t1 + | FStarC_Syntax_Syntax.Tm_refine uu___ -> + let uu___1 = FStarC_Syntax_Util.unrefine t1 in aux true uu___1 + | uu___ -> + if norm1 + then let uu___1 = whnf env t1 in aux false uu___1 + else + (let uu___2 = + let uu___3 = + FStarC_Compiler_Range_Ops.string_of_range + t0.FStarC_Syntax_Syntax.pos in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + t0 in + FStarC_Compiler_Util.format2 + "(%s) Expected a function typ; got %s" uu___3 uu___4 in + failwith uu___2) in + aux true t0 +let rec (curried_arrow_formals_comp : + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.binders * FStarC_Syntax_Syntax.comp)) + = + fun k -> + let k1 = FStarC_Syntax_Subst.compress k in + match k1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; FStarC_Syntax_Syntax.comp = c;_} -> + FStarC_Syntax_Subst.open_comp bs c + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = bv; FStarC_Syntax_Syntax.phi = uu___;_} -> + let uu___1 = curried_arrow_formals_comp bv.FStarC_Syntax_Syntax.sort in + (match uu___1 with + | (args, res) -> + (match args with + | [] -> + let uu___2 = FStarC_Syntax_Syntax.mk_Total k1 in + ([], uu___2) + | uu___2 -> (args, res))) + | uu___ -> let uu___1 = FStarC_Syntax_Syntax.mk_Total k1 in ([], uu___1) +let is_arithmetic_primitive : + 'uuuuu . + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + 'uuuuu Prims.list -> Prims.bool + = + fun head -> + fun args -> + match ((head.FStarC_Syntax_Syntax.n), args) with + | (FStarC_Syntax_Syntax.Tm_fvar fv, uu___::uu___1::[]) -> + ((((((((((((FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.op_Addition) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.op_Subtraction)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.op_Multiply)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.op_Division)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.op_Modulus)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.real_op_LT)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.real_op_LTE)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.real_op_GT)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.real_op_GTE)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.real_op_Addition)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.real_op_Subtraction)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.real_op_Multiply)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.real_op_Division) + | (FStarC_Syntax_Syntax.Tm_fvar fv, uu___::[]) -> + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.op_Minus + | uu___ -> false +let (isInteger : FStarC_Syntax_Syntax.term' -> Prims.bool) = + fun tm -> + match tm with + | FStarC_Syntax_Syntax.Tm_constant (FStarC_Const.Const_int + (n, FStar_Pervasives_Native.None)) -> true + | uu___ -> false +let (getInteger : FStarC_Syntax_Syntax.term' -> Prims.int) = + fun tm -> + match tm with + | FStarC_Syntax_Syntax.Tm_constant (FStarC_Const.Const_int + (n, FStar_Pervasives_Native.None)) -> + FStarC_Compiler_Util.int_of_string n + | uu___ -> failwith "Expected an Integer term" +let is_BitVector_primitive : + 'uuuuu . + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + (FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax * 'uuuuu) + Prims.list -> Prims.bool + = + fun head -> + fun args -> + match ((head.FStarC_Syntax_Syntax.n), args) with + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (sz_arg, uu___)::uu___1::uu___2::[]) -> + (((((((((((((((((FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.bv_and_lid) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.bv_xor_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.bv_or_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.bv_add_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.bv_sub_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.bv_shift_left_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.bv_shift_right_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.bv_udiv_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.bv_mod_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.bv_mul_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.bv_shift_left'_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.bv_shift_right'_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.bv_udiv_unsafe_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.bv_mod_unsafe_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.bv_mul'_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.bv_ult_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.bv_uext_lid)) + && (isInteger sz_arg.FStarC_Syntax_Syntax.n) + | (FStarC_Syntax_Syntax.Tm_fvar fv, (sz_arg, uu___)::uu___1::[]) -> + ((FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.nat_to_bv_lid) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.bv_to_nat_lid)) + && (isInteger sz_arg.FStarC_Syntax_Syntax.n) + | uu___ -> false +let rec (encode_const : + FStarC_Const.sconst -> + FStarC_SMTEncoding_Env.env_t -> + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.decls_elt + Prims.list)) + = + fun c -> + fun env -> + FStarC_Errors.with_ctx "While encoding a constant to SMT" + (fun uu___ -> + match c with + | FStarC_Const.Const_unit -> + (FStarC_SMTEncoding_Term.mk_Term_unit, []) + | FStarC_Const.Const_bool (true) -> + let uu___1 = + FStarC_SMTEncoding_Term.boxBool + FStarC_SMTEncoding_Util.mkTrue in + (uu___1, []) + | FStarC_Const.Const_bool (false) -> + let uu___1 = + FStarC_SMTEncoding_Term.boxBool + FStarC_SMTEncoding_Util.mkFalse in + (uu___1, []) + | FStarC_Const.Const_char c1 -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_SMTEncoding_Util.mkInteger' + (FStarC_Compiler_Util.int_of_char c1) in + FStarC_SMTEncoding_Term.boxInt uu___5 in + [uu___4] in + ("FStar.Char.__char_of_int", uu___3) in + FStarC_SMTEncoding_Util.mkApp uu___2 in + (uu___1, []) + | FStarC_Const.Const_int (i, FStar_Pervasives_Native.None) -> + let uu___1 = + let uu___2 = FStarC_SMTEncoding_Util.mkInteger i in + FStarC_SMTEncoding_Term.boxInt uu___2 in + (uu___1, []) + | FStarC_Const.Const_int (repr, FStar_Pervasives_Native.Some sw) + -> + let syntax_term = + FStarC_ToSyntax_ToSyntax.desugar_machine_integer + (env.FStarC_SMTEncoding_Env.tcenv).FStarC_TypeChecker_Env.dsenv + repr sw FStarC_Compiler_Range_Type.dummyRange in + encode_term syntax_term env + | FStarC_Const.Const_string (s, uu___1) -> + let uu___2 = + let uu___3 = FStarC_SMTEncoding_Util.mk_String_const s in + FStarC_SMTEncoding_Term.boxString uu___3 in + (uu___2, []) + | FStarC_Const.Const_range uu___1 -> + let uu___2 = FStarC_SMTEncoding_Term.mk_Range_const () in + (uu___2, []) + | FStarC_Const.Const_effect -> + (FStarC_SMTEncoding_Term.mk_Term_type, []) + | FStarC_Const.Const_real r -> + let uu___1 = + let uu___2 = FStarC_SMTEncoding_Util.mkReal r in + FStarC_SMTEncoding_Term.boxReal uu___2 in + (uu___1, []) + | c1 -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_const + c1 in + FStarC_Compiler_Util.format1 "Unhandled constant: %s" uu___2 in + failwith uu___1) +and (encode_binders : + FStarC_SMTEncoding_Term.term FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.binders -> + FStarC_SMTEncoding_Env.env_t -> + (FStarC_SMTEncoding_Term.fv Prims.list * FStarC_SMTEncoding_Term.term + Prims.list * FStarC_SMTEncoding_Env.env_t * + FStarC_SMTEncoding_Term.decls_t * FStarC_Syntax_Syntax.bv + Prims.list)) + = + fun fuel_opt -> + fun bs -> + fun env -> + (let uu___1 = FStarC_Compiler_Debug.medium () in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binder) bs in + FStarC_Compiler_Util.print1 "Encoding binders %s\n" uu___2 + else ()); + (let uu___1 = + FStarC_Compiler_List.fold_left + (fun uu___2 -> + fun b -> + match uu___2 with + | (vars, guards, env1, decls, names) -> + let uu___3 = + let x = b.FStarC_Syntax_Syntax.binder_bv in + let uu___4 = + FStarC_SMTEncoding_Env.gen_term_var env1 x in + match uu___4 with + | (xxsym, xx, env') -> + let uu___5 = + let uu___6 = + norm env1 x.FStarC_Syntax_Syntax.sort in + encode_term_pred fuel_opt uu___6 env1 xx in + (match uu___5 with + | (guard_x_t, decls') -> + let uu___6 = + FStarC_SMTEncoding_Term.mk_fv + (xxsym, + FStarC_SMTEncoding_Term.Term_sort) in + (uu___6, guard_x_t, env', decls', x)) in + (match uu___3 with + | (v, g, env2, decls', n) -> + ((v :: vars), (g :: guards), env2, + (FStarC_Compiler_List.op_At decls decls'), (n :: + names)))) ([], [], env, [], []) bs in + match uu___1 with + | (vars, guards, env1, decls, names) -> + ((FStarC_Compiler_List.rev vars), + (FStarC_Compiler_List.rev guards), env1, decls, + (FStarC_Compiler_List.rev names))) +and (encode_term_pred : + FStarC_SMTEncoding_Term.term FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.typ -> + FStarC_SMTEncoding_Env.env_t -> + FStarC_SMTEncoding_Term.term -> + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.decls_t)) + = + fun fuel_opt -> + fun t -> + fun env -> + fun e -> + let uu___ = encode_term t env in + match uu___ with + | (t1, decls) -> + let uu___1 = + FStarC_SMTEncoding_Term.mk_HasTypeWithFuel fuel_opt e t1 in + (uu___1, decls) +and (encode_arith_term : + FStarC_SMTEncoding_Env.env_t -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.args -> + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.decls_t)) + = + fun env -> + fun head -> + fun args_e -> + let uu___ = encode_args args_e env in + match uu___ with + | (arg_tms, decls) -> + let head_fv = + match head.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_fvar fv -> fv + | uu___1 -> failwith "Impossible" in + let unary unbox arg_tms1 = + let uu___1 = FStarC_Compiler_List.hd arg_tms1 in unbox uu___1 in + let binary unbox arg_tms1 = + let uu___1 = + let uu___2 = FStarC_Compiler_List.hd arg_tms1 in unbox uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Compiler_List.tl arg_tms1 in + FStarC_Compiler_List.hd uu___4 in + unbox uu___3 in + (uu___1, uu___2) in + let mk_default uu___1 = + let uu___2 = + FStarC_SMTEncoding_Env.lookup_free_var_sym env + head_fv.FStarC_Syntax_Syntax.fv_name in + match uu___2 with + | (fname, fuel_args, arity) -> + let args = FStarC_Compiler_List.op_At fuel_args arg_tms in + maybe_curry_app head.FStarC_Syntax_Syntax.pos fname arity + args in + let mk_l box op mk_args ts = + let uu___1 = FStarC_Options.smtencoding_l_arith_native () in + if uu___1 + then + let uu___2 = let uu___3 = mk_args ts in op uu___3 in + box uu___2 + else mk_default () in + let mk_nl box unbox nm op ts = + let uu___1 = FStarC_Options.smtencoding_nl_arith_wrapped () in + if uu___1 + then + let uu___2 = binary unbox ts in + match uu___2 with + | (t1, t2) -> + let uu___3 = FStarC_SMTEncoding_Util.mkApp (nm, [t1; t2]) in + box uu___3 + else + (let uu___3 = FStarC_Options.smtencoding_nl_arith_native () in + if uu___3 + then + let uu___4 = let uu___5 = binary unbox ts in op uu___5 in + box uu___4 + else mk_default ()) in + let add box unbox = + mk_l box FStarC_SMTEncoding_Util.mkAdd (binary unbox) in + let sub box unbox = + mk_l box FStarC_SMTEncoding_Util.mkSub (binary unbox) in + let minus box unbox = + mk_l box FStarC_SMTEncoding_Util.mkMinus (unary unbox) in + let mul box unbox nm = + mk_nl box unbox nm FStarC_SMTEncoding_Util.mkMul in + let div box unbox nm = + mk_nl box unbox nm FStarC_SMTEncoding_Util.mkDiv in + let modulus box unbox = + mk_nl box unbox "_mod" FStarC_SMTEncoding_Util.mkMod in + let ops = + [(FStarC_Parser_Const.op_Addition, + (add FStarC_SMTEncoding_Term.boxInt + FStarC_SMTEncoding_Term.unboxInt)); + (FStarC_Parser_Const.op_Subtraction, + (sub FStarC_SMTEncoding_Term.boxInt + FStarC_SMTEncoding_Term.unboxInt)); + (FStarC_Parser_Const.op_Multiply, + (mul FStarC_SMTEncoding_Term.boxInt + FStarC_SMTEncoding_Term.unboxInt "_mul")); + (FStarC_Parser_Const.op_Division, + (div FStarC_SMTEncoding_Term.boxInt + FStarC_SMTEncoding_Term.unboxInt "_div")); + (FStarC_Parser_Const.op_Modulus, + (modulus FStarC_SMTEncoding_Term.boxInt + FStarC_SMTEncoding_Term.unboxInt)); + (FStarC_Parser_Const.op_Minus, + (minus FStarC_SMTEncoding_Term.boxInt + FStarC_SMTEncoding_Term.unboxInt)); + (FStarC_Parser_Const.real_op_Addition, + (add FStarC_SMTEncoding_Term.boxReal + FStarC_SMTEncoding_Term.unboxReal)); + (FStarC_Parser_Const.real_op_Subtraction, + (sub FStarC_SMTEncoding_Term.boxReal + FStarC_SMTEncoding_Term.unboxReal)); + (FStarC_Parser_Const.real_op_Multiply, + (mul FStarC_SMTEncoding_Term.boxReal + FStarC_SMTEncoding_Term.unboxReal "_rmul")); + (FStarC_Parser_Const.real_op_Division, + (mk_nl FStarC_SMTEncoding_Term.boxReal + FStarC_SMTEncoding_Term.unboxReal "_rdiv" + FStarC_SMTEncoding_Util.mkRealDiv)); + (FStarC_Parser_Const.real_op_LT, + (mk_l FStarC_SMTEncoding_Term.boxBool + FStarC_SMTEncoding_Util.mkLT + (binary FStarC_SMTEncoding_Term.unboxReal))); + (FStarC_Parser_Const.real_op_LTE, + (mk_l FStarC_SMTEncoding_Term.boxBool + FStarC_SMTEncoding_Util.mkLTE + (binary FStarC_SMTEncoding_Term.unboxReal))); + (FStarC_Parser_Const.real_op_GT, + (mk_l FStarC_SMTEncoding_Term.boxBool + FStarC_SMTEncoding_Util.mkGT + (binary FStarC_SMTEncoding_Term.unboxReal))); + (FStarC_Parser_Const.real_op_GTE, + (mk_l FStarC_SMTEncoding_Term.boxBool + FStarC_SMTEncoding_Util.mkGTE + (binary FStarC_SMTEncoding_Term.unboxReal)))] in + let uu___1 = + let uu___2 = + FStarC_Compiler_List.tryFind + (fun uu___3 -> + match uu___3 with + | (l, uu___4) -> + FStarC_Syntax_Syntax.fv_eq_lid head_fv l) ops in + FStarC_Compiler_Util.must uu___2 in + (match uu___1 with + | (uu___2, op) -> let uu___3 = op arg_tms in (uu___3, decls)) +and (encode_BitVector_term : + FStarC_SMTEncoding_Env.env_t -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + (FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax * + FStarC_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) + Prims.list -> + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.decls_elt + Prims.list)) + = + fun env -> + fun head -> + fun args_e -> + let uu___ = FStarC_Compiler_List.hd args_e in + match uu___ with + | (tm_sz, uu___1) -> + let uu___2 = uu___ in + let sz = getInteger tm_sz.FStarC_Syntax_Syntax.n in + let sz_key = + FStarC_Compiler_Util.format1 "BitVector_%s" + (Prims.string_of_int sz) in + let sz_decls = + let uu___3 = FStarC_SMTEncoding_Term.mkBvConstructor sz in + match uu___3 with + | (t_decls, constr_name, discriminator_name) -> + let uu___4 = + let uu___5 = + let head1 = + FStarC_Syntax_Syntax.lid_as_fv + FStarC_Parser_Const.bv_t_lid + FStar_Pervasives_Native.None in + let t = + let uu___6 = FStarC_Syntax_Syntax.fv_to_tm head1 in + FStarC_Syntax_Util.mk_app uu___6 + [(tm_sz, FStar_Pervasives_Native.None)] in + encode_term t env in + match uu___5 with + | (bv_t_n, decls) -> + let xsym = + let uu___6 = + let uu___7 = + FStarC_SMTEncoding_Env.varops.FStarC_SMTEncoding_Env.fresh + env.FStarC_SMTEncoding_Env.current_module_name + "x" in + (uu___7, FStarC_SMTEncoding_Term.Term_sort) in + FStarC_SMTEncoding_Term.mk_fv uu___6 in + let x = FStarC_SMTEncoding_Util.mkFreeV xsym in + let x_has_type_bv_t_n = + FStarC_SMTEncoding_Term.mk_HasType x bv_t_n in + let ax = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_SMTEncoding_Util.mkApp + (discriminator_name, [x]) in + (x_has_type_bv_t_n, uu___9) in + FStarC_SMTEncoding_Util.mkImp uu___8 in + ([[x_has_type_bv_t_n]], [xsym], uu___7) in + FStarC_SMTEncoding_Term.mkForall + head.FStarC_Syntax_Syntax.pos uu___6 in + let name = + Prims.strcat "typing_inversion_for_" constr_name in + let uu___6 = + FStarC_SMTEncoding_Util.mkAssume + (ax, (FStar_Pervasives_Native.Some name), name) in + (decls, uu___6) in + (match uu___4 with + | (decls, typing_inversion) -> + let uu___5 = + FStarC_SMTEncoding_Term.mk_decls "" sz_key + (FStarC_Compiler_List.op_At t_decls + [typing_inversion]) [] in + FStarC_Compiler_List.op_At decls uu___5) in + let uu___3 = + match ((head.FStarC_Syntax_Syntax.n), args_e) with + | (FStarC_Syntax_Syntax.Tm_fvar fv, + uu___4::(sz_arg, uu___5)::uu___6::[]) when + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.bv_uext_lid) + && (isInteger sz_arg.FStarC_Syntax_Syntax.n) + -> + let uu___7 = + let uu___8 = FStarC_Compiler_List.tail args_e in + FStarC_Compiler_List.tail uu___8 in + let uu___8 = + let uu___9 = getInteger sz_arg.FStarC_Syntax_Syntax.n in + FStar_Pervasives_Native.Some uu___9 in + (uu___7, uu___8) + | (FStarC_Syntax_Syntax.Tm_fvar fv, + uu___4::(sz_arg, uu___5)::uu___6::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.bv_uext_lid + -> + let uu___7 = + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term sz_arg in + FStarC_Compiler_Util.format1 + "Not a constant bitvector extend size: %s" uu___8 in + failwith uu___7 + | uu___4 -> + let uu___5 = FStarC_Compiler_List.tail args_e in + (uu___5, FStar_Pervasives_Native.None) in + (match uu___3 with + | (arg_tms, ext_sz) -> + let uu___4 = encode_args arg_tms env in + (match uu___4 with + | (arg_tms1, decls) -> + let head_fv = + match head.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_fvar fv -> fv + | uu___5 -> failwith "Impossible" in + let unary arg_tms2 = + let uu___5 = FStarC_Compiler_List.hd arg_tms2 in + FStarC_SMTEncoding_Term.unboxBitVec sz uu___5 in + let unary_arith arg_tms2 = + let uu___5 = FStarC_Compiler_List.hd arg_tms2 in + FStarC_SMTEncoding_Term.unboxInt uu___5 in + let binary arg_tms2 = + let uu___5 = + let uu___6 = FStarC_Compiler_List.hd arg_tms2 in + FStarC_SMTEncoding_Term.unboxBitVec sz uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Compiler_List.tl arg_tms2 in + FStarC_Compiler_List.hd uu___8 in + FStarC_SMTEncoding_Term.unboxBitVec sz uu___7 in + (uu___5, uu___6) in + let binary_arith arg_tms2 = + let uu___5 = + let uu___6 = FStarC_Compiler_List.hd arg_tms2 in + FStarC_SMTEncoding_Term.unboxBitVec sz uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Compiler_List.tl arg_tms2 in + FStarC_Compiler_List.hd uu___8 in + FStarC_SMTEncoding_Term.unboxInt uu___7 in + (uu___5, uu___6) in + let mk_bv op mk_args resBox ts = + let uu___5 = let uu___6 = mk_args ts in op uu___6 in + resBox uu___5 in + let bv_and = + mk_bv FStarC_SMTEncoding_Util.mkBvAnd binary + (FStarC_SMTEncoding_Term.boxBitVec sz) in + let bv_xor = + mk_bv FStarC_SMTEncoding_Util.mkBvXor binary + (FStarC_SMTEncoding_Term.boxBitVec sz) in + let bv_or = + mk_bv FStarC_SMTEncoding_Util.mkBvOr binary + (FStarC_SMTEncoding_Term.boxBitVec sz) in + let bv_add = + mk_bv FStarC_SMTEncoding_Util.mkBvAdd binary + (FStarC_SMTEncoding_Term.boxBitVec sz) in + let bv_sub = + mk_bv FStarC_SMTEncoding_Util.mkBvSub binary + (FStarC_SMTEncoding_Term.boxBitVec sz) in + let bv_shl = + mk_bv (FStarC_SMTEncoding_Util.mkBvShl sz) + binary_arith (FStarC_SMTEncoding_Term.boxBitVec sz) in + let bv_shr = + mk_bv (FStarC_SMTEncoding_Util.mkBvShr sz) + binary_arith (FStarC_SMTEncoding_Term.boxBitVec sz) in + let bv_udiv = + mk_bv (FStarC_SMTEncoding_Util.mkBvUdiv sz) + binary_arith (FStarC_SMTEncoding_Term.boxBitVec sz) in + let bv_mod = + mk_bv (FStarC_SMTEncoding_Util.mkBvMod sz) + binary_arith (FStarC_SMTEncoding_Term.boxBitVec sz) in + let bv_mul = + mk_bv (FStarC_SMTEncoding_Util.mkBvMul sz) + binary_arith (FStarC_SMTEncoding_Term.boxBitVec sz) in + let bv_shl' = + mk_bv (FStarC_SMTEncoding_Util.mkBvShl' sz) binary + (FStarC_SMTEncoding_Term.boxBitVec sz) in + let bv_shr' = + mk_bv (FStarC_SMTEncoding_Util.mkBvShr' sz) binary + (FStarC_SMTEncoding_Term.boxBitVec sz) in + let bv_udiv_unsafe = + mk_bv (FStarC_SMTEncoding_Util.mkBvUdivUnsafe sz) + binary (FStarC_SMTEncoding_Term.boxBitVec sz) in + let bv_mod_unsafe = + mk_bv (FStarC_SMTEncoding_Util.mkBvModUnsafe sz) + binary (FStarC_SMTEncoding_Term.boxBitVec sz) in + let bv_mul' = + mk_bv (FStarC_SMTEncoding_Util.mkBvMul' sz) binary + (FStarC_SMTEncoding_Term.boxBitVec sz) in + let bv_ult = + mk_bv FStarC_SMTEncoding_Util.mkBvUlt binary + FStarC_SMTEncoding_Term.boxBool in + let bv_uext arg_tms2 = + let uu___5 = + let uu___6 = + match ext_sz with + | FStar_Pervasives_Native.Some x -> x + | FStar_Pervasives_Native.None -> + failwith "impossible" in + FStarC_SMTEncoding_Util.mkBvUext uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + match ext_sz with + | FStar_Pervasives_Native.Some x -> x + | FStar_Pervasives_Native.None -> + failwith "impossible" in + sz + uu___8 in + FStarC_SMTEncoding_Term.boxBitVec uu___7 in + mk_bv uu___5 unary uu___6 arg_tms2 in + let to_int = + mk_bv FStarC_SMTEncoding_Util.mkBvToNat unary + FStarC_SMTEncoding_Term.boxInt in + let bv_to = + mk_bv (FStarC_SMTEncoding_Util.mkNatToBv sz) + unary_arith (FStarC_SMTEncoding_Term.boxBitVec sz) in + let ops = + [(FStarC_Parser_Const.bv_and_lid, bv_and); + (FStarC_Parser_Const.bv_xor_lid, bv_xor); + (FStarC_Parser_Const.bv_or_lid, bv_or); + (FStarC_Parser_Const.bv_add_lid, bv_add); + (FStarC_Parser_Const.bv_sub_lid, bv_sub); + (FStarC_Parser_Const.bv_shift_left_lid, bv_shl); + (FStarC_Parser_Const.bv_shift_right_lid, bv_shr); + (FStarC_Parser_Const.bv_udiv_lid, bv_udiv); + (FStarC_Parser_Const.bv_mod_lid, bv_mod); + (FStarC_Parser_Const.bv_mul_lid, bv_mul); + (FStarC_Parser_Const.bv_shift_left'_lid, bv_shl'); + (FStarC_Parser_Const.bv_shift_right'_lid, bv_shr'); + (FStarC_Parser_Const.bv_udiv_unsafe_lid, + bv_udiv_unsafe); + (FStarC_Parser_Const.bv_mod_unsafe_lid, + bv_mod_unsafe); + (FStarC_Parser_Const.bv_mul'_lid, bv_mul'); + (FStarC_Parser_Const.bv_ult_lid, bv_ult); + (FStarC_Parser_Const.bv_uext_lid, bv_uext); + (FStarC_Parser_Const.bv_to_nat_lid, to_int); + (FStarC_Parser_Const.nat_to_bv_lid, bv_to)] in + let uu___5 = + let uu___6 = + FStarC_Compiler_List.tryFind + (fun uu___7 -> + match uu___7 with + | (l, uu___8) -> + FStarC_Syntax_Syntax.fv_eq_lid head_fv l) + ops in + FStarC_Compiler_Util.must uu___6 in + (match uu___5 with + | (uu___6, op) -> + let uu___7 = op arg_tms1 in + (uu___7, + (FStarC_Compiler_List.op_At sz_decls decls))))) +and (encode_deeply_embedded_quantifier : + FStarC_Syntax_Syntax.term -> + FStarC_SMTEncoding_Env.env_t -> + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.decls_t)) + = + fun t -> + fun env -> + let env1 = + { + FStarC_SMTEncoding_Env.bvar_bindings = + (env.FStarC_SMTEncoding_Env.bvar_bindings); + FStarC_SMTEncoding_Env.fvar_bindings = + (env.FStarC_SMTEncoding_Env.fvar_bindings); + FStarC_SMTEncoding_Env.depth = (env.FStarC_SMTEncoding_Env.depth); + FStarC_SMTEncoding_Env.tcenv = (env.FStarC_SMTEncoding_Env.tcenv); + FStarC_SMTEncoding_Env.warn = (env.FStarC_SMTEncoding_Env.warn); + FStarC_SMTEncoding_Env.nolabels = + (env.FStarC_SMTEncoding_Env.nolabels); + FStarC_SMTEncoding_Env.use_zfuel_name = + (env.FStarC_SMTEncoding_Env.use_zfuel_name); + FStarC_SMTEncoding_Env.encode_non_total_function_typ = + (env.FStarC_SMTEncoding_Env.encode_non_total_function_typ); + FStarC_SMTEncoding_Env.current_module_name = + (env.FStarC_SMTEncoding_Env.current_module_name); + FStarC_SMTEncoding_Env.encoding_quantifier = true; + FStarC_SMTEncoding_Env.global_cache = + (env.FStarC_SMTEncoding_Env.global_cache) + } in + let uu___ = encode_term t env1 in + match uu___ with + | (tm, decls) -> + let vars = FStarC_SMTEncoding_Term.free_variables tm in + let valid_tm = FStarC_SMTEncoding_Term.mk_Valid tm in + let key = + FStarC_SMTEncoding_Term.mkForall t.FStarC_Syntax_Syntax.pos + ([], vars, valid_tm) in + let tkey_hash = FStarC_SMTEncoding_Term.hash_of_term key in + (match tm.FStarC_SMTEncoding_Term.tm with + | FStarC_SMTEncoding_Term.App + (uu___1, + { + FStarC_SMTEncoding_Term.tm = FStarC_SMTEncoding_Term.FreeV + uu___2; + FStarC_SMTEncoding_Term.freevars = uu___3; + FStarC_SMTEncoding_Term.rng = uu___4;_}::{ + FStarC_SMTEncoding_Term.tm + = + FStarC_SMTEncoding_Term.FreeV + uu___5; + FStarC_SMTEncoding_Term.freevars + = uu___6; + FStarC_SMTEncoding_Term.rng + = uu___7;_}::[]) + -> + (FStarC_Errors.log_issue + (FStarC_Syntax_Syntax.has_range_syntax ()) t + FStarC_Errors_Codes.Warning_QuantifierWithoutPattern () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Not encoding deeply embedded, unguarded quantifier to SMT"); + (tm, decls)) + | uu___1 -> + let uu___2 = encode_formula t env1 in + (match uu___2 with + | (phi, decls') -> + let interp = + match vars with + | [] -> + let uu___3 = + let uu___4 = FStarC_SMTEncoding_Term.mk_Valid tm in + (uu___4, phi) in + FStarC_SMTEncoding_Util.mkIff uu___3 + | uu___3 -> + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_SMTEncoding_Term.mk_Valid tm in + (uu___7, phi) in + FStarC_SMTEncoding_Util.mkIff uu___6 in + ([[valid_tm]], vars, uu___5) in + FStarC_SMTEncoding_Term.mkForall + t.FStarC_Syntax_Syntax.pos uu___4 in + let ax = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Compiler_Util.digest_of_string tkey_hash in + Prims.strcat "l_quant_interp_" uu___5 in + (interp, + (FStar_Pervasives_Native.Some + "Interpretation of deeply embedded quantifier"), + uu___4) in + FStarC_SMTEncoding_Util.mkAssume uu___3 in + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_SMTEncoding_Term.mk_decls "" tkey_hash + [ax] (FStarC_Compiler_List.op_At decls decls') in + FStarC_Compiler_List.op_At decls' uu___5 in + FStarC_Compiler_List.op_At decls uu___4 in + (tm, uu___3))) +and (encode_term : + FStarC_Syntax_Syntax.typ -> + FStarC_SMTEncoding_Env.env_t -> + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.decls_t)) + = + fun t -> + fun env -> + FStarC_Defensive.def_check_scoped FStarC_TypeChecker_Env.hasBinders_env + FStarC_Class_Binders.hasNames_term FStarC_Syntax_Print.pretty_term + t.FStarC_Syntax_Syntax.pos "encode_term" + env.FStarC_SMTEncoding_Env.tcenv t; + (let t1 = FStarC_Syntax_Subst.compress t in + let t0 = t1 in + (let uu___2 = FStarC_Compiler_Effect.op_Bang dbg_SMTEncoding in + if uu___2 + then + let uu___3 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t1 in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.print2 "(%s) %s\n" uu___3 uu___4 + else ()); + (match t1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_delayed uu___2 -> + let uu___3 = + let uu___4 = + FStarC_Compiler_Range_Ops.string_of_range + t1.FStarC_Syntax_Syntax.pos in + let uu___5 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term + t1 in + let uu___6 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.format3 "(%s) Impossible: %s\n%s\n" uu___4 + uu___5 uu___6 in + failwith uu___3 + | FStarC_Syntax_Syntax.Tm_unknown -> + let uu___2 = + let uu___3 = + FStarC_Compiler_Range_Ops.string_of_range + t1.FStarC_Syntax_Syntax.pos in + let uu___4 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term + t1 in + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.format3 "(%s) Impossible: %s\n%s\n" uu___3 + uu___4 uu___5 in + failwith uu___2 + | FStarC_Syntax_Syntax.Tm_lazy i -> + let e = FStarC_Syntax_Util.unfold_lazy i in + ((let uu___3 = FStarC_Compiler_Effect.op_Bang dbg_SMTEncoding in + if uu___3 + then + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + FStarC_Compiler_Util.print2 ">> Unfolded (%s) ~> (%s)\n" + uu___4 uu___5 + else ()); + encode_term e env) + | FStarC_Syntax_Syntax.Tm_bvar x -> + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_bv x in + FStarC_Compiler_Util.format1 + "Impossible: locally nameless; got %s" uu___3 in + failwith uu___2 + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t2; + FStarC_Syntax_Syntax.asc = (k, uu___2, uu___3); + FStarC_Syntax_Syntax.eff_opt = uu___4;_} + -> + let uu___5 = + match k with + | FStar_Pervasives.Inl t3 -> FStarC_Syntax_Util.is_unit t3 + | uu___6 -> false in + if uu___5 + then (FStarC_SMTEncoding_Term.mk_Term_unit, []) + else encode_term t2 env + | FStarC_Syntax_Syntax.Tm_quoted (qt, uu___2) -> + let tv = + let uu___3 = + let uu___4 = FStarC_Reflection_V2_Builtins.inspect_ln qt in + FStarC_Syntax_Embeddings_Base.embed + FStarC_Reflection_V2_Embeddings.e_term_view uu___4 in + uu___3 t1.FStarC_Syntax_Syntax.pos FStar_Pervasives_Native.None + FStarC_Syntax_Embeddings_Base.id_norm_cb in + ((let uu___4 = FStarC_Compiler_Effect.op_Bang dbg_SMTEncoding in + if uu___4 + then + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t0 in + let uu___6 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term tv in + FStarC_Compiler_Util.print2 ">> Inspected (%s) ~> (%s)\n" + uu___5 uu___6 + else ()); + (let t2 = + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.as_arg tv in [uu___5] in + FStarC_Syntax_Util.mk_app + (FStarC_Reflection_V2_Constants.refl_constant_term + FStarC_Reflection_V2_Constants.fstar_refl_pack_ln) + uu___4 in + encode_term t2 env)) + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t2; + FStarC_Syntax_Syntax.meta = FStarC_Syntax_Syntax.Meta_pattern + uu___2;_} + -> + encode_term t2 + { + FStarC_SMTEncoding_Env.bvar_bindings = + (env.FStarC_SMTEncoding_Env.bvar_bindings); + FStarC_SMTEncoding_Env.fvar_bindings = + (env.FStarC_SMTEncoding_Env.fvar_bindings); + FStarC_SMTEncoding_Env.depth = + (env.FStarC_SMTEncoding_Env.depth); + FStarC_SMTEncoding_Env.tcenv = + (env.FStarC_SMTEncoding_Env.tcenv); + FStarC_SMTEncoding_Env.warn = + (env.FStarC_SMTEncoding_Env.warn); + FStarC_SMTEncoding_Env.nolabels = + (env.FStarC_SMTEncoding_Env.nolabels); + FStarC_SMTEncoding_Env.use_zfuel_name = + (env.FStarC_SMTEncoding_Env.use_zfuel_name); + FStarC_SMTEncoding_Env.encode_non_total_function_typ = + (env.FStarC_SMTEncoding_Env.encode_non_total_function_typ); + FStarC_SMTEncoding_Env.current_module_name = + (env.FStarC_SMTEncoding_Env.current_module_name); + FStarC_SMTEncoding_Env.encoding_quantifier = false; + FStarC_SMTEncoding_Env.global_cache = + (env.FStarC_SMTEncoding_Env.global_cache) + } + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t2; + FStarC_Syntax_Syntax.meta = uu___2;_} + -> encode_term t2 env + | FStarC_Syntax_Syntax.Tm_name x -> + let t2 = FStarC_SMTEncoding_Env.lookup_term_var env x in (t2, []) + | FStarC_Syntax_Syntax.Tm_fvar v -> + let encode_freev uu___2 = + let fvb = + FStarC_SMTEncoding_Env.lookup_free_var_name env + v.FStarC_Syntax_Syntax.fv_name in + let tok = + FStarC_SMTEncoding_Env.lookup_free_var env + v.FStarC_Syntax_Syntax.fv_name in + let tkey_hash = FStarC_SMTEncoding_Term.hash_of_term tok in + let uu___3 = + if fvb.FStarC_SMTEncoding_Env.smt_arity > Prims.int_zero + then + match tok.FStarC_SMTEncoding_Term.tm with + | FStarC_SMTEncoding_Term.FreeV uu___4 -> + let sym_name = + let uu___5 = + FStarC_Compiler_Util.digest_of_string tkey_hash in + Prims.strcat "@kick_partial_app_" uu___5 in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_SMTEncoding_Term.kick_partial_app tok in + (uu___8, + (FStar_Pervasives_Native.Some + "kick_partial_app"), sym_name) in + FStarC_SMTEncoding_Util.mkAssume uu___7 in + [uu___6] in + (uu___5, sym_name) + | FStarC_SMTEncoding_Term.App (uu___4, []) -> + let sym_name = + let uu___5 = + FStarC_Compiler_Util.digest_of_string tkey_hash in + Prims.strcat "@kick_partial_app_" uu___5 in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_SMTEncoding_Term.kick_partial_app tok in + (uu___8, + (FStar_Pervasives_Native.Some + "kick_partial_app"), sym_name) in + FStarC_SMTEncoding_Util.mkAssume uu___7 in + [uu___6] in + (uu___5, sym_name) + | uu___4 -> ([], "") + else ([], "") in + match uu___3 with + | (aux_decls, sym_name) -> + let uu___4 = + if aux_decls = [] + then FStarC_SMTEncoding_Term.mk_decls_trivial [] + else + FStarC_SMTEncoding_Term.mk_decls sym_name tkey_hash + aux_decls [] in + (tok, uu___4) in + let uu___2 = head_redex env t1 in + if uu___2 + then + let uu___3 = maybe_whnf env t1 in + (match uu___3 with + | FStar_Pervasives_Native.None -> encode_freev () + | FStar_Pervasives_Native.Some t2 -> encode_term t2 env) + else encode_freev () + | FStarC_Syntax_Syntax.Tm_type uu___2 -> + (FStarC_SMTEncoding_Term.mk_Term_type, []) + | FStarC_Syntax_Syntax.Tm_uinst (t2, uu___2) -> encode_term t2 env + | FStarC_Syntax_Syntax.Tm_constant c -> encode_const c env + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = binders; + FStarC_Syntax_Syntax.comp = c;_} + -> + let module_name = env.FStarC_SMTEncoding_Env.current_module_name in + let uu___2 = FStarC_Syntax_Subst.open_comp binders c in + (match uu___2 with + | (binders1, res) -> + let uu___3 = + (env.FStarC_SMTEncoding_Env.encode_non_total_function_typ + && (FStarC_Syntax_Util.is_pure_or_ghost_comp res)) + || (FStarC_Syntax_Util.is_tot_or_gtot_comp res) in + if uu___3 + then + let uu___4 = + encode_binders FStar_Pervasives_Native.None binders1 env in + (match uu___4 with + | (vars, guards_l, env', decls, uu___5) -> + let fsym = + let uu___6 = + let uu___7 = + FStarC_SMTEncoding_Env.varops.FStarC_SMTEncoding_Env.fresh + module_name "f" in + (uu___7, FStarC_SMTEncoding_Term.Term_sort) in + FStarC_SMTEncoding_Term.mk_fv uu___6 in + let f = FStarC_SMTEncoding_Util.mkFreeV fsym in + let app = mk_Apply f vars in + let tcenv_bs = + let uu___6 = env'.FStarC_SMTEncoding_Env.tcenv in + { + FStarC_TypeChecker_Env.solver = + (uu___6.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (uu___6.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (uu___6.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (uu___6.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (uu___6.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (uu___6.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (uu___6.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (uu___6.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (uu___6.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (uu___6.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (uu___6.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (uu___6.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (uu___6.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (uu___6.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (uu___6.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (uu___6.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (uu___6.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (uu___6.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = true; + FStarC_TypeChecker_Env.lax_universes = + (uu___6.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (uu___6.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (uu___6.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (uu___6.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (uu___6.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (uu___6.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (uu___6.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (uu___6.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (uu___6.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (uu___6.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (uu___6.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (uu___6.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (uu___6.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (uu___6.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (uu___6.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (uu___6.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (uu___6.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (uu___6.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (uu___6.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (uu___6.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (uu___6.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (uu___6.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (uu___6.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (uu___6.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (uu___6.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (uu___6.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (uu___6.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (uu___6.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (uu___6.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (uu___6.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (uu___6.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (uu___6.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (uu___6.FStarC_TypeChecker_Env.missing_decl) + } in + let uu___6 = + FStarC_TypeChecker_Util.pure_or_ghost_pre_and_post + tcenv_bs res in + (match uu___6 with + | (pre_opt, res_t) -> + let uu___7 = + encode_term_pred FStar_Pervasives_Native.None + res_t env' app in + (match uu___7 with + | (res_pred, decls') -> + let uu___8 = + match pre_opt with + | FStar_Pervasives_Native.None -> + let uu___9 = + FStarC_SMTEncoding_Util.mk_and_l + guards_l in + (uu___9, []) + | FStar_Pervasives_Native.Some pre -> + let uu___9 = encode_formula pre env' in + (match uu___9 with + | (guard, decls0) -> + let uu___10 = + FStarC_SMTEncoding_Util.mk_and_l + (guard :: guards_l) in + (uu___10, decls0)) in + (match uu___8 with + | (guards, guard_decls) -> + let is_pure = + let uu___9 = + FStarC_TypeChecker_Normalize.maybe_ghost_to_pure + env.FStarC_SMTEncoding_Env.tcenv + res in + FStarC_Syntax_Util.is_pure_comp + uu___9 in + let t_interp = + let uu___9 = + let uu___10 = + FStarC_SMTEncoding_Util.mkImp + (guards, res_pred) in + ([[app]], vars, uu___10) in + FStarC_SMTEncoding_Term.mkForall + t1.FStarC_Syntax_Syntax.pos uu___9 in + let t_interp1 = + let tot_fun_axioms = + isTotFun_axioms + t1.FStarC_Syntax_Syntax.pos f + vars guards_l is_pure in + FStarC_SMTEncoding_Util.mkAnd + (t_interp, tot_fun_axioms) in + let cvars = + let uu___9 = + FStarC_SMTEncoding_Term.free_variables + t_interp1 in + FStarC_Compiler_List.filter + (fun x -> + let uu___10 = + FStarC_SMTEncoding_Term.fv_name + x in + let uu___11 = + FStarC_SMTEncoding_Term.fv_name + fsym in + uu___10 <> uu___11) uu___9 in + let tkey = + FStarC_SMTEncoding_Term.mkForall + t1.FStarC_Syntax_Syntax.pos + ([], (fsym :: cvars), t_interp1) in + let prefix = + if is_pure + then "Tm_arrow_" + else "Tm_ghost_arrow_" in + let tkey_hash = + let uu___9 = + FStarC_SMTEncoding_Term.hash_of_term + tkey in + Prims.strcat prefix uu___9 in + let tsym = + let uu___9 = + FStarC_Compiler_Util.digest_of_string + tkey_hash in + Prims.strcat prefix uu___9 in + let cvar_sorts = + FStarC_Compiler_List.map + FStarC_SMTEncoding_Term.fv_sort + cvars in + let caption = + let uu___9 = + FStarC_Options.log_queries () in + if uu___9 + then + let uu___10 = + let uu___11 = + FStarC_TypeChecker_Normalize.term_to_string + env.FStarC_SMTEncoding_Env.tcenv + t0 in + FStarC_Compiler_Util.replace_char + uu___11 10 32 in + FStar_Pervasives_Native.Some + uu___10 + else FStar_Pervasives_Native.None in + let tdecl = + FStarC_SMTEncoding_Term.DeclFun + (tsym, cvar_sorts, + FStarC_SMTEncoding_Term.Term_sort, + caption) in + let t2 = + let uu___9 = + let uu___10 = + FStarC_Compiler_List.map + FStarC_SMTEncoding_Util.mkFreeV + cvars in + (tsym, uu___10) in + FStarC_SMTEncoding_Util.mkApp uu___9 in + let t_has_kind = + FStarC_SMTEncoding_Term.mk_HasType + t2 + FStarC_SMTEncoding_Term.mk_Term_type in + let k_assumption = + let a_name = + Prims.strcat "kinding_" tsym in + let uu___9 = + let uu___10 = + FStarC_SMTEncoding_Term.mkForall + t0.FStarC_Syntax_Syntax.pos + ([[t_has_kind]], cvars, + t_has_kind) in + (uu___10, + (FStar_Pervasives_Native.Some + a_name), a_name) in + FStarC_SMTEncoding_Util.mkAssume + uu___9 in + let f_has_t = + FStarC_SMTEncoding_Term.mk_HasType f + t2 in + let f_has_t_z = + FStarC_SMTEncoding_Term.mk_HasTypeZ + f t2 in + let pre_typing = + let a_name = + Prims.strcat "pre_typing_" tsym in + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + FStarC_SMTEncoding_Term.mk_PreType + f in + FStarC_SMTEncoding_Term.mk_tester + "Tm_arrow" uu___15 in + (f_has_t, uu___14) in + FStarC_SMTEncoding_Util.mkImp + uu___13 in + ([[f_has_t]], (fsym :: cvars), + uu___12) in + let uu___12 = + mkForall_fuel module_name + t0.FStarC_Syntax_Syntax.pos in + uu___12 uu___11 in + (uu___10, + (FStar_Pervasives_Native.Some + "pre-typing for functions"), + (Prims.strcat module_name + (Prims.strcat "_" a_name))) in + FStarC_SMTEncoding_Util.mkAssume + uu___9 in + let t_interp2 = + let a_name = + Prims.strcat "interpretation_" + tsym in + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_SMTEncoding_Util.mkIff + (f_has_t_z, t_interp1) in + ([[f_has_t_z]], (fsym :: + cvars), uu___12) in + FStarC_SMTEncoding_Term.mkForall + t0.FStarC_Syntax_Syntax.pos + uu___11 in + (uu___10, + (FStar_Pervasives_Native.Some + a_name), + (Prims.strcat module_name + (Prims.strcat "_" a_name))) in + FStarC_SMTEncoding_Util.mkAssume + uu___9 in + let t_decls = + [tdecl; + k_assumption; + pre_typing; + t_interp2] in + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_SMTEncoding_Term.mk_decls + tsym tkey_hash t_decls + (FStarC_Compiler_List.op_At + decls + (FStarC_Compiler_List.op_At + decls' guard_decls)) in + FStarC_Compiler_List.op_At + guard_decls uu___12 in + FStarC_Compiler_List.op_At decls' + uu___11 in + FStarC_Compiler_List.op_At decls + uu___10 in + (t2, uu___9))))) + else + (let tkey_hash = + let uu___5 = + encode_binders FStar_Pervasives_Native.None binders1 + env in + match uu___5 with + | (vars, guards_l, env_bs, uu___6, uu___7) -> + let c1 = + let uu___8 = + let uu___9 = + FStarC_TypeChecker_Env.push_binders + env.FStarC_SMTEncoding_Env.tcenv binders1 in + FStarC_TypeChecker_Env.unfold_effect_abbrev + uu___9 res in + FStarC_Syntax_Syntax.mk_Comp uu___8 in + let uu___8 = + encode_term (FStarC_Syntax_Util.comp_result c1) + env_bs in + (match uu___8 with + | (ct, uu___9) -> + let uu___10 = + let uu___11 = + FStarC_Syntax_Util.comp_effect_args c1 in + encode_args uu___11 env_bs in + (match uu___10 with + | (effect_args, uu___11) -> + let tkey = + let uu___12 = + let uu___13 = + FStarC_SMTEncoding_Util.mk_and_l + (FStarC_Compiler_List.op_At + guards_l + (FStarC_Compiler_List.op_At + [ct] effect_args)) in + ([], vars, uu___13) in + FStarC_SMTEncoding_Term.mkForall + t1.FStarC_Syntax_Syntax.pos uu___12 in + let tkey_hash1 = + let uu___12 = + let uu___13 = + FStarC_SMTEncoding_Term.hash_of_term + tkey in + let uu___14 = + let uu___15 = + FStarC_Ident.string_of_lid + (FStarC_Syntax_Util.comp_effect_name + c1) in + Prims.strcat "@Effect=" uu___15 in + Prims.strcat uu___13 uu___14 in + Prims.strcat "Non_total_Tm_arrow" + uu___12 in + FStarC_Compiler_Util.digest_of_string + tkey_hash1)) in + let tsym = Prims.strcat "Non_total_Tm_arrow_" tkey_hash in + let env0 = env in + let uu___5 = + let fvs = + let uu___6 = FStarC_Syntax_Free.names t0 in + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) + (Obj.magic uu___6) in + let getfreeV t2 = + match t2.FStarC_SMTEncoding_Term.tm with + | FStarC_SMTEncoding_Term.FreeV fv -> fv + | uu___6 -> + failwith + "Impossible: getfreeV: gen_term_var should always returns a FreeV" in + let uu___6 = + FStarC_Compiler_List.fold_left + (fun uu___7 -> + fun bv -> + match uu___7 with + | (env1, decls, vars, tms, guards) -> + let uu___8 = + FStarC_TypeChecker_Env.lookup_bv + env1.FStarC_SMTEncoding_Env.tcenv bv in + (match uu___8 with + | (sort, uu___9) -> + let uu___10 = + FStarC_SMTEncoding_Env.gen_term_var + env1 bv in + (match uu___10 with + | (sym, smt_tm, env2) -> + let fv = getfreeV smt_tm in + let uu___11 = + let uu___12 = norm env2 sort in + encode_term_pred + FStar_Pervasives_Native.None + uu___12 env2 smt_tm in + (match uu___11 with + | (guard, decls') -> + (env2, + (FStarC_Compiler_List.op_At + decls' decls), (fv :: + vars), (smt_tm :: tms), + (guard :: guards)))))) + (env, [], [], [], []) fvs in + (fvs, uu___6) in + match uu___5 with + | (fstar_fvs, + (env1, fv_decls, fv_vars, fv_tms, fv_guards)) -> + let fv_decls1 = FStarC_Compiler_List.rev fv_decls in + let fv_vars1 = FStarC_Compiler_List.rev fv_vars in + let fv_tms1 = FStarC_Compiler_List.rev fv_tms in + let fv_guards1 = FStarC_Compiler_List.rev fv_guards in + let arg_sorts = + FStarC_Compiler_List.map + (fun uu___6 -> FStarC_SMTEncoding_Term.Term_sort) + fv_tms1 in + let tdecl = + FStarC_SMTEncoding_Term.DeclFun + (tsym, arg_sorts, + FStarC_SMTEncoding_Term.Term_sort, + FStar_Pervasives_Native.None) in + let tapp = + FStarC_SMTEncoding_Util.mkApp (tsym, fv_tms1) in + let t_kinding = + let a_name = + Prims.strcat "non_total_function_typing_" tsym in + let axiom = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_SMTEncoding_Term.mk_HasType tapp + FStarC_SMTEncoding_Term.mk_Term_type in + [uu___9] in + [uu___8] in + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_SMTEncoding_Util.mk_and_l + fv_guards1 in + let uu___11 = + FStarC_SMTEncoding_Term.mk_HasType tapp + FStarC_SMTEncoding_Term.mk_Term_type in + (uu___10, uu___11) in + FStarC_SMTEncoding_Util.mkImp uu___9 in + (uu___7, fv_vars1, uu___8) in + FStarC_SMTEncoding_Term.mkForall + t0.FStarC_Syntax_Syntax.pos uu___6 in + let svars = + FStarC_SMTEncoding_Term.free_variables axiom in + let axiom1 = + FStarC_SMTEncoding_Term.mkForall + t0.FStarC_Syntax_Syntax.pos ([], svars, axiom) in + FStarC_SMTEncoding_Util.mkAssume + (axiom1, + (FStar_Pervasives_Native.Some + "Typing for non-total arrows"), a_name) in + let tapp_concrete = + let uu___6 = + let uu___7 = + FStarC_Compiler_List.map + (FStarC_SMTEncoding_Env.lookup_term_var env0) + fstar_fvs in + (tsym, uu___7) in + FStarC_SMTEncoding_Util.mkApp uu___6 in + let uu___6 = + let uu___7 = + FStarC_SMTEncoding_Term.mk_decls tsym tkey_hash + [tdecl; t_kinding] [] in + FStarC_Compiler_List.op_At fv_decls1 uu___7 in + (tapp_concrete, uu___6))) + | FStarC_Syntax_Syntax.Tm_refine uu___2 -> + let uu___3 = + let steps = + [FStarC_TypeChecker_Env.Weak; + FStarC_TypeChecker_Env.HNF; + FStarC_TypeChecker_Env.EraseUniverses] in + let uu___4 = + normalize_refinement steps env.FStarC_SMTEncoding_Env.tcenv + t0 in + match uu___4 with + | { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x; + FStarC_Syntax_Syntax.phi = f;_}; + FStarC_Syntax_Syntax.pos = uu___5; + FStarC_Syntax_Syntax.vars = uu___6; + FStarC_Syntax_Syntax.hash_code = uu___7;_} -> + let uu___8 = + let uu___9 = + let uu___10 = FStarC_Syntax_Syntax.mk_binder x in + [uu___10] in + FStarC_Syntax_Subst.open_term uu___9 f in + (match uu___8 with + | (b, f1) -> + let uu___9 = + let uu___10 = FStarC_Compiler_List.hd b in + uu___10.FStarC_Syntax_Syntax.binder_bv in + (uu___9, f1)) + | uu___5 -> failwith "impossible" in + (match uu___3 with + | (x, f) -> + let uu___4 = encode_term x.FStarC_Syntax_Syntax.sort env in + (match uu___4 with + | (base_t, decls) -> + let uu___5 = FStarC_SMTEncoding_Env.gen_term_var env x in + (match uu___5 with + | (x1, xtm, env') -> + let uu___6 = encode_formula f env' in + (match uu___6 with + | (refinement, decls') -> + let uu___7 = + FStarC_SMTEncoding_Env.fresh_fvar + env.FStarC_SMTEncoding_Env.current_module_name + "f" FStarC_SMTEncoding_Term.Fuel_sort in + (match uu___7 with + | (fsym, fterm) -> + let tm_has_type_with_fuel = + FStarC_SMTEncoding_Term.mk_HasTypeWithFuel + (FStar_Pervasives_Native.Some fterm) + xtm base_t in + let encoding = + FStarC_SMTEncoding_Util.mkAnd + (tm_has_type_with_fuel, refinement) in + let cvars = + let uu___8 = + let uu___9 = + FStarC_SMTEncoding_Term.free_variables + refinement in + let uu___10 = + FStarC_SMTEncoding_Term.free_variables + tm_has_type_with_fuel in + FStarC_Compiler_List.op_At uu___9 + uu___10 in + FStarC_Compiler_Util.remove_dups + FStarC_SMTEncoding_Term.fv_eq uu___8 in + let cvars1 = + FStarC_Compiler_List.filter + (fun y -> + (let uu___8 = + FStarC_SMTEncoding_Term.fv_name + y in + uu___8 <> x1) && + (let uu___8 = + FStarC_SMTEncoding_Term.fv_name + y in + uu___8 <> fsym)) cvars in + let xfv = + FStarC_SMTEncoding_Term.mk_fv + (x1, + FStarC_SMTEncoding_Term.Term_sort) in + let ffv = + FStarC_SMTEncoding_Term.mk_fv + (fsym, + FStarC_SMTEncoding_Term.Fuel_sort) in + let tkey = + FStarC_SMTEncoding_Term.mkForall + t0.FStarC_Syntax_Syntax.pos + ([], (ffv :: xfv :: cvars1), + encoding) in + let tkey_hash = + FStarC_SMTEncoding_Term.hash_of_term + tkey in + ((let uu___9 = + FStarC_Compiler_Effect.op_Bang + dbg_SMTEncoding in + if uu___9 + then + let uu___10 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + f in + let uu___11 = + FStarC_Compiler_Util.digest_of_string + tkey_hash in + FStarC_Compiler_Util.print3 + "Encoding Tm_refine %s with tkey_hash %s and digest %s\n" + uu___10 tkey_hash uu___11 + else ()); + (let tsym = + let uu___9 = + FStarC_Compiler_Util.digest_of_string + tkey_hash in + Prims.strcat "Tm_refine_" uu___9 in + let cvar_sorts = + FStarC_Compiler_List.map + FStarC_SMTEncoding_Term.fv_sort + cvars1 in + let tdecl = + FStarC_SMTEncoding_Term.DeclFun + (tsym, cvar_sorts, + FStarC_SMTEncoding_Term.Term_sort, + FStar_Pervasives_Native.None) in + let t2 = + let uu___9 = + let uu___10 = + FStarC_Compiler_List.map + FStarC_SMTEncoding_Util.mkFreeV + cvars1 in + (tsym, uu___10) in + FStarC_SMTEncoding_Util.mkApp uu___9 in + let x_has_base_t = + FStarC_SMTEncoding_Term.mk_HasType + xtm base_t in + let x_has_t = + FStarC_SMTEncoding_Term.mk_HasTypeWithFuel + (FStar_Pervasives_Native.Some + fterm) xtm t2 in + let t_has_kind = + FStarC_SMTEncoding_Term.mk_HasType + t2 + FStarC_SMTEncoding_Term.mk_Term_type in + let t_haseq_base = + FStarC_SMTEncoding_Term.mk_haseq + base_t in + let t_haseq_ref = + FStarC_SMTEncoding_Term.mk_haseq t2 in + let t_haseq = + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_SMTEncoding_Util.mkIff + (t_haseq_ref, + t_haseq_base) in + ([[t_haseq_ref]], cvars1, + uu___12) in + FStarC_SMTEncoding_Term.mkForall + t0.FStarC_Syntax_Syntax.pos + uu___11 in + (uu___10, + (FStar_Pervasives_Native.Some + (Prims.strcat "haseq for " + tsym)), + (Prims.strcat "haseq" tsym)) in + FStarC_SMTEncoding_Util.mkAssume + uu___9 in + let t_kinding = + let uu___9 = + let uu___10 = + FStarC_SMTEncoding_Term.mkForall + t0.FStarC_Syntax_Syntax.pos + ([[t_has_kind]], cvars1, + t_has_kind) in + (uu___10, + (FStar_Pervasives_Native.Some + "refinement kinding"), + (Prims.strcat + "refinement_kinding_" tsym)) in + FStarC_SMTEncoding_Util.mkAssume + uu___9 in + let t_interp = + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_SMTEncoding_Util.mkIff + (x_has_t, encoding) in + ([[x_has_t]], (ffv :: xfv :: + cvars1), uu___12) in + FStarC_SMTEncoding_Term.mkForall + t0.FStarC_Syntax_Syntax.pos + uu___11 in + (uu___10, + (FStar_Pervasives_Native.Some + "refinement_interpretation"), + (Prims.strcat + "refinement_interpretation_" + tsym)) in + FStarC_SMTEncoding_Util.mkAssume + uu___9 in + let t_decls = + [tdecl; + t_kinding; + t_interp; + t_haseq] in + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_SMTEncoding_Term.mk_decls + tsym tkey_hash t_decls + (FStarC_Compiler_List.op_At + decls decls') in + FStarC_Compiler_List.op_At decls' + uu___11 in + FStarC_Compiler_List.op_At decls + uu___10 in + (t2, uu___9)))))))) + | FStarC_Syntax_Syntax.Tm_uvar (uv, uu___2) -> + let ttm = + let uu___3 = + FStarC_Syntax_Unionfind.uvar_id + uv.FStarC_Syntax_Syntax.ctx_uvar_head in + FStarC_SMTEncoding_Util.mk_Term_uvar uu___3 in + let uu___3 = + let uu___4 = FStarC_Syntax_Util.ctx_uvar_typ uv in + encode_term_pred FStar_Pervasives_Native.None uu___4 env ttm in + (match uu___3 with + | (t_has_k, decls) -> + let d = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Unionfind.uvar_id + uv.FStarC_Syntax_Syntax.ctx_uvar_head in + FStarC_Compiler_Util.string_of_int uu___8 in + FStarC_Compiler_Util.format1 "uvar_typing_%s" uu___7 in + FStarC_SMTEncoding_Env.varops.FStarC_SMTEncoding_Env.mk_unique + uu___6 in + (t_has_k, (FStar_Pervasives_Native.Some "Uvar typing"), + uu___5) in + FStarC_SMTEncoding_Util.mkAssume uu___4 in + let uu___4 = + let uu___5 = FStarC_SMTEncoding_Term.mk_decls_trivial [d] in + FStarC_Compiler_List.op_At decls uu___5 in + (ttm, uu___4)) + | FStarC_Syntax_Syntax.Tm_app uu___2 -> + let uu___3 = FStarC_Syntax_Util.head_and_args t0 in + (match uu___3 with + | (head, args_e) -> + let uu___4 = + let uu___5 = head_redex env head in + if uu___5 + then + let uu___6 = maybe_whnf env t0 in + match uu___6 with + | FStar_Pervasives_Native.None -> (head, args_e) + | FStar_Pervasives_Native.Some t2 -> + FStarC_Syntax_Util.head_and_args t2 + else (head, args_e) in + (match uu___4 with + | (head1, args_e1) -> + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Syntax_Subst.compress head1 in + uu___7.FStarC_Syntax_Syntax.n in + (uu___6, args_e1) in + if is_arithmetic_primitive head1 args_e1 + then encode_arith_term env head1 args_e1 + else + if is_BitVector_primitive head1 args_e1 + then encode_BitVector_term env head1 args_e1 + else + (match uu___5 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (arg, uu___6)::[]) when + ((FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.squash_lid) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.auto_squash_lid)) + && + (let uu___7 = + FStarC_Syntax_Formula.destruct_typ_as_formula + arg in + FStarC_Compiler_Option.isSome uu___7) + -> + let dummy = + FStarC_Syntax_Syntax.new_bv + FStar_Pervasives_Native.None + FStarC_Syntax_Syntax.t_unit in + let t2 = FStarC_Syntax_Util.refine dummy arg in + encode_term t2 env + | (FStarC_Syntax_Syntax.Tm_uinst + ({ + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Tm_fvar fv; + FStarC_Syntax_Syntax.pos = uu___6; + FStarC_Syntax_Syntax.vars = uu___7; + FStarC_Syntax_Syntax.hash_code = uu___8;_}, + uu___9), + (arg, uu___10)::[]) when + ((FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.squash_lid) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.auto_squash_lid)) + && + (let uu___11 = + FStarC_Syntax_Formula.destruct_typ_as_formula + arg in + FStarC_Compiler_Option.isSome uu___11) + -> + let dummy = + FStarC_Syntax_Syntax.new_bv + FStar_Pervasives_Native.None + FStarC_Syntax_Syntax.t_unit in + let t2 = FStarC_Syntax_Util.refine dummy arg in + encode_term t2 env + | (FStarC_Syntax_Syntax.Tm_fvar fv, uu___6) when + (Prims.op_Negation + env.FStarC_SMTEncoding_Env.encoding_quantifier) + && + ((FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.forall_lid) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.exists_lid)) + -> encode_deeply_embedded_quantifier t0 env + | (FStarC_Syntax_Syntax.Tm_uinst + ({ + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Tm_fvar fv; + FStarC_Syntax_Syntax.pos = uu___6; + FStarC_Syntax_Syntax.vars = uu___7; + FStarC_Syntax_Syntax.hash_code = uu___8;_}, + uu___9), + uu___10) when + (Prims.op_Negation + env.FStarC_SMTEncoding_Env.encoding_quantifier) + && + ((FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.forall_lid) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.exists_lid)) + -> encode_deeply_embedded_quantifier t0 env + | (FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_range_of), + (arg, uu___6)::[]) -> + encode_const + (FStarC_Const.Const_range + (arg.FStarC_Syntax_Syntax.pos)) env + | (FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_set_range_of), + (arg, uu___6)::(rng, uu___7)::[]) -> + encode_term arg env + | (FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_reify lopt), uu___6) -> + let fallback uu___7 = + let f = + FStarC_SMTEncoding_Env.varops.FStarC_SMTEncoding_Env.fresh + env.FStarC_SMTEncoding_Env.current_module_name + "Tm_reify" in + let decl = + FStarC_SMTEncoding_Term.DeclFun + (f, [], + FStarC_SMTEncoding_Term.Term_sort, + (FStar_Pervasives_Native.Some + "Imprecise reify")) in + let uu___8 = + let uu___9 = + FStarC_SMTEncoding_Term.mk_fv + (f, FStarC_SMTEncoding_Term.Term_sort) in + FStarC_SMTEncoding_Util.mkFreeV uu___9 in + let uu___9 = + FStarC_SMTEncoding_Term.mk_decls_trivial + [decl] in + (uu___8, uu___9) in + (match lopt with + | FStar_Pervasives_Native.None -> fallback () + | FStar_Pervasives_Native.Some l when + let uu___7 = + FStarC_TypeChecker_Env.norm_eff_name + env.FStarC_SMTEncoding_Env.tcenv l in + FStarC_TypeChecker_Env.is_layered_effect + env.FStarC_SMTEncoding_Env.tcenv uu___7 + -> fallback () + | uu___7 -> + let e0 = + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Compiler_List.hd args_e1 in + FStar_Pervasives_Native.fst uu___10 in + FStarC_Syntax_Util.mk_reify uu___9 + lopt in + FStarC_TypeChecker_Util.norm_reify + env.FStarC_SMTEncoding_Env.tcenv [] + uu___8 in + ((let uu___9 = + FStarC_Compiler_Effect.op_Bang + dbg_SMTEncodingReify in + if uu___9 + then + let uu___10 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + e0 in + FStarC_Compiler_Util.print1 + "Result of normalization %s\n" + uu___10 + else ()); + (let e = + let uu___9 = + FStarC_TypeChecker_Util.remove_reify + e0 in + let uu___10 = + FStarC_Compiler_List.tl args_e1 in + FStarC_Syntax_Syntax.mk_Tm_app uu___9 + uu___10 t0.FStarC_Syntax_Syntax.pos in + encode_term e env))) + | (FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_reflect uu___6), + (arg, uu___7)::[]) -> encode_term arg env + | (FStarC_Syntax_Syntax.Tm_fvar fv, + uu___6::(phi, uu___7)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.by_tactic_lid + -> encode_term phi env + | (FStarC_Syntax_Syntax.Tm_uinst + ({ + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Tm_fvar fv; + FStarC_Syntax_Syntax.pos = uu___6; + FStarC_Syntax_Syntax.vars = uu___7; + FStarC_Syntax_Syntax.hash_code = uu___8;_}, + uu___9), + uu___10::(phi, uu___11)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.by_tactic_lid + -> encode_term phi env + | (FStarC_Syntax_Syntax.Tm_fvar fv, + uu___6::uu___7::(phi, uu___8)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.rewrite_by_tactic_lid + -> encode_term phi env + | (FStarC_Syntax_Syntax.Tm_uinst + ({ + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Tm_fvar fv; + FStarC_Syntax_Syntax.pos = uu___6; + FStarC_Syntax_Syntax.vars = uu___7; + FStarC_Syntax_Syntax.hash_code = uu___8;_}, + uu___9), + uu___10::uu___11::(phi, uu___12)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.rewrite_by_tactic_lid + -> encode_term phi env + | uu___6 -> + let uu___7 = encode_args args_e1 env in + (match uu___7 with + | (args, decls) -> + let encode_partial_app ht_opt = + let uu___8 = encode_term head1 env in + match uu___8 with + | (smt_head, decls') -> + let app_tm = + mk_Apply_args smt_head args in + (app_tm, + (FStarC_Compiler_List.op_At decls + decls')) in + let encode_full_app fv = + let uu___8 = + FStarC_SMTEncoding_Env.lookup_free_var_sym + env fv in + match uu___8 with + | (fname, fuel_args, arity) -> + let tm = + maybe_curry_app + t0.FStarC_Syntax_Syntax.pos + fname arity + (FStarC_Compiler_List.op_At + fuel_args args) in + (tm, decls) in + let head2 = + FStarC_Syntax_Subst.compress head1 in + let head_type = + match head2.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_uinst + ({ + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Tm_name x; + FStarC_Syntax_Syntax.pos = + uu___8; + FStarC_Syntax_Syntax.vars = + uu___9; + FStarC_Syntax_Syntax.hash_code = + uu___10;_}, + uu___11) + -> + FStar_Pervasives_Native.Some + (x.FStarC_Syntax_Syntax.sort) + | FStarC_Syntax_Syntax.Tm_name x -> + FStar_Pervasives_Native.Some + (x.FStarC_Syntax_Syntax.sort) + | FStarC_Syntax_Syntax.Tm_uinst + ({ + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Tm_fvar + fv; + FStarC_Syntax_Syntax.pos = + uu___8; + FStarC_Syntax_Syntax.vars = + uu___9; + FStarC_Syntax_Syntax.hash_code = + uu___10;_}, + uu___11) + -> + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_TypeChecker_Env.lookup_lid + env.FStarC_SMTEncoding_Env.tcenv + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + FStar_Pervasives_Native.fst + uu___14 in + FStar_Pervasives_Native.snd + uu___13 in + FStar_Pervasives_Native.Some + uu___12 + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_TypeChecker_Env.lookup_lid + env.FStarC_SMTEncoding_Env.tcenv + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + FStar_Pervasives_Native.fst + uu___10 in + FStar_Pervasives_Native.snd + uu___9 in + FStar_Pervasives_Native.Some uu___8 + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = uu___8; + FStarC_Syntax_Syntax.asc = + (FStar_Pervasives.Inl t2, + uu___9, uu___10); + FStarC_Syntax_Syntax.eff_opt = + uu___11;_} + -> FStar_Pervasives_Native.Some t2 + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = uu___8; + FStarC_Syntax_Syntax.asc = + (FStar_Pervasives.Inr c, + uu___9, uu___10); + FStarC_Syntax_Syntax.eff_opt = + uu___11;_} + -> + FStar_Pervasives_Native.Some + (FStarC_Syntax_Util.comp_result c) + | uu___8 -> + FStar_Pervasives_Native.None in + (match head_type with + | FStar_Pervasives_Native.None -> + encode_partial_app + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some + head_type1 -> + let uu___8 = + let head_type2 = + let uu___9 = + normalize_refinement + [FStarC_TypeChecker_Env.Weak; + FStarC_TypeChecker_Env.HNF; + FStarC_TypeChecker_Env.EraseUniverses] + env.FStarC_SMTEncoding_Env.tcenv + head_type1 in + FStarC_Syntax_Util.unrefine + uu___9 in + let uu___9 = + curried_arrow_formals_comp + head_type2 in + match uu___9 with + | (formals, c) -> + if + (FStarC_Compiler_List.length + formals) + < + (FStarC_Compiler_List.length + args) + then + let head_type3 = + let uu___10 = + normalize_refinement + [FStarC_TypeChecker_Env.Weak; + FStarC_TypeChecker_Env.HNF; + FStarC_TypeChecker_Env.EraseUniverses; + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant] + env.FStarC_SMTEncoding_Env.tcenv + head_type2 in + FStarC_Syntax_Util.unrefine + uu___10 in + let uu___10 = + curried_arrow_formals_comp + head_type3 in + (match uu___10 with + | (formals1, c1) -> + (head_type3, formals1, + c1)) + else (head_type2, formals, c) in + (match uu___8 with + | (head_type2, formals, c) -> + ((let uu___10 = + FStarC_Compiler_Effect.op_Bang + dbg_PartialApp in + if uu___10 + then + let uu___11 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + head_type2 in + let uu___12 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binder) + formals in + let uu___13 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + (FStarC_Class_Show.show_tuple2 + FStarC_Syntax_Print.showable_term + FStarC_Syntax_Print.showable_aqual)) + args_e1 in + FStarC_Compiler_Util.print3 + "Encoding partial application, head_type = %s, formals = %s, args = %s\n" + uu___11 uu___12 uu___13 + else ()); + (match head2.FStarC_Syntax_Syntax.n + with + | FStarC_Syntax_Syntax.Tm_uinst + ({ + FStarC_Syntax_Syntax.n + = + FStarC_Syntax_Syntax.Tm_fvar + fv; + FStarC_Syntax_Syntax.pos + = uu___10; + FStarC_Syntax_Syntax.vars + = uu___11; + FStarC_Syntax_Syntax.hash_code + = uu___12;_}, + uu___13) + when + (FStarC_Compiler_List.length + formals) + = + (FStarC_Compiler_List.length + args) + -> + encode_full_app + fv.FStarC_Syntax_Syntax.fv_name + | FStarC_Syntax_Syntax.Tm_fvar + fv when + (FStarC_Compiler_List.length + formals) + = + (FStarC_Compiler_List.length + args) + -> + encode_full_app + fv.FStarC_Syntax_Syntax.fv_name + | uu___10 -> + if + (FStarC_Compiler_List.length + formals) + > + (FStarC_Compiler_List.length + args) + then + encode_partial_app + (FStar_Pervasives_Native.Some + (head_type2, + formals, c)) + else + encode_partial_app + FStar_Pervasives_Native.None)))))))) + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs; FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = lopt;_} + -> + let uu___2 = FStarC_Syntax_Subst.open_term' bs body in + (match uu___2 with + | (bs1, body1, opening) -> + let fallback uu___3 = + let uu___4 = + let fvs = + let uu___5 = FStarC_Syntax_Free.names t0 in + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) + (Obj.magic uu___5) in + let tms = + FStarC_Compiler_List.map + (FStarC_SMTEncoding_Env.lookup_term_var env) fvs in + let uu___5 = + FStarC_Compiler_List.map + (fun uu___6 -> FStarC_SMTEncoding_Term.Term_sort) + fvs in + (uu___5, tms) in + match uu___4 with + | (arg_sorts, arg_terms) -> + let f = + FStarC_SMTEncoding_Env.varops.FStarC_SMTEncoding_Env.fresh + env.FStarC_SMTEncoding_Env.current_module_name + "Tm_abs" in + let decl = + FStarC_SMTEncoding_Term.DeclFun + (f, arg_sorts, FStarC_SMTEncoding_Term.Term_sort, + (FStar_Pervasives_Native.Some + "Imprecise function encoding")) in + let fv = + let uu___5 = + FStarC_SMTEncoding_Term.mk_fv + (f, FStarC_SMTEncoding_Term.Term_sort) in + FStarC_SMTEncoding_Util.mkFreeV uu___5 in + let fapp = + FStarC_SMTEncoding_Util.mkApp (f, arg_terms) in + let uu___5 = + FStarC_SMTEncoding_Term.mk_decls_trivial [decl] in + (fapp, uu___5) in + let is_impure rc = + let uu___3 = + FStarC_TypeChecker_Util.is_pure_or_ghost_effect + env.FStarC_SMTEncoding_Env.tcenv + rc.FStarC_Syntax_Syntax.residual_effect in + Prims.op_Negation uu___3 in + let codomain_eff rc = + let res_typ = + match rc.FStarC_Syntax_Syntax.residual_typ with + | FStar_Pervasives_Native.None -> + let uu___3 = + let uu___4 = + FStarC_TypeChecker_Env.get_range + env.FStarC_SMTEncoding_Env.tcenv in + FStarC_TypeChecker_Util.new_implicit_var + "SMTEncoding codomain" uu___4 + env.FStarC_SMTEncoding_Env.tcenv + FStarC_Syntax_Util.ktype0 false in + (match uu___3 with | (t2, uu___4, uu___5) -> t2) + | FStar_Pervasives_Native.Some t2 -> t2 in + let uu___3 = + FStarC_Ident.lid_equals + rc.FStarC_Syntax_Syntax.residual_effect + FStarC_Parser_Const.effect_Tot_lid in + if uu___3 + then + let uu___4 = FStarC_Syntax_Syntax.mk_Total res_typ in + FStar_Pervasives_Native.Some uu___4 + else + (let uu___5 = + FStarC_Ident.lid_equals + rc.FStarC_Syntax_Syntax.residual_effect + FStarC_Parser_Const.effect_GTot_lid in + if uu___5 + then + let uu___6 = FStarC_Syntax_Syntax.mk_GTotal res_typ in + FStar_Pervasives_Native.Some uu___6 + else FStar_Pervasives_Native.None) in + (match lopt with + | FStar_Pervasives_Native.None -> + ((let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Errors_Msg.text + "Losing precision when encoding a function literal:" in + let uu___7 = + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_term t0 in + FStarC_Pprint.prefix (Prims.of_int (2)) + Prims.int_one uu___6 uu___7 in + let uu___6 = + let uu___7 = + FStarC_Errors_Msg.text + "Unannotated abstraction in the compiler?" in + [uu___7] in + uu___5 :: uu___6 in + FStarC_Errors.log_issue + (FStarC_Syntax_Syntax.has_range_syntax ()) t0 + FStarC_Errors_Codes.Warning_FunctionLiteralPrecisionLoss + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___4)); + fallback ()) + | FStar_Pervasives_Native.Some rc -> + let uu___3 = + (is_impure rc) && + (let uu___4 = + FStarC_SMTEncoding_Util.is_smt_reifiable_rc + env.FStarC_SMTEncoding_Env.tcenv rc in + Prims.op_Negation uu___4) in + if uu___3 + then fallback () + else + (let uu___5 = + encode_binders FStar_Pervasives_Native.None bs1 + env in + match uu___5 with + | (vars, guards, envbody, decls, uu___6) -> + let body2 = + let uu___7 = + FStarC_SMTEncoding_Util.is_smt_reifiable_rc + env.FStarC_SMTEncoding_Env.tcenv rc in + if uu___7 + then + let uu___8 = + FStarC_Syntax_Util.mk_reify body1 + (FStar_Pervasives_Native.Some + (rc.FStarC_Syntax_Syntax.residual_effect)) in + FStarC_TypeChecker_Util.norm_reify + env.FStarC_SMTEncoding_Env.tcenv [] uu___8 + else body1 in + let uu___7 = encode_term body2 envbody in + (match uu___7 with + | (body3, decls') -> + let is_pure = + FStarC_Syntax_Util.is_pure_effect + rc.FStarC_Syntax_Syntax.residual_effect in + let uu___8 = + let uu___9 = codomain_eff rc in + match uu___9 with + | FStar_Pervasives_Native.None -> + (FStar_Pervasives_Native.None, []) + | FStar_Pervasives_Native.Some c -> + let tfun = + FStarC_Syntax_Util.arrow bs1 c in + let uu___10 = encode_term tfun env in + (match uu___10 with + | (t2, decls1) -> + ((FStar_Pervasives_Native.Some + t2), decls1)) in + (match uu___8 with + | (arrow_t_opt, decls'') -> + let key_body = + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_SMTEncoding_Util.mk_and_l + guards in + (uu___12, body3) in + FStarC_SMTEncoding_Util.mkImp + uu___11 in + ([], vars, uu___10) in + FStarC_SMTEncoding_Term.mkForall + t0.FStarC_Syntax_Syntax.pos uu___9 in + let cvars = + FStarC_SMTEncoding_Term.free_variables + key_body in + let uu___9 = + match arrow_t_opt with + | FStar_Pervasives_Native.None -> + (cvars, key_body) + | FStar_Pervasives_Native.Some t2 -> + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_SMTEncoding_Term.free_variables + t2 in + FStarC_Compiler_List.op_At + uu___12 cvars in + FStarC_Compiler_Util.remove_dups + FStarC_SMTEncoding_Term.fv_eq + uu___11 in + let uu___11 = + FStarC_SMTEncoding_Util.mkAnd + (key_body, t2) in + (uu___10, uu___11) in + (match uu___9 with + | (cvars1, key_body1) -> + let tkey = + FStarC_SMTEncoding_Term.mkForall + t0.FStarC_Syntax_Syntax.pos + ([], cvars1, key_body1) in + let tkey_hash = + FStarC_SMTEncoding_Term.hash_of_term + tkey in + ((let uu___11 = + FStarC_Compiler_Effect.op_Bang + dbg_PartialApp in + if uu___11 + then + let uu___12 = + let uu___13 = + FStarC_Compiler_List.map + FStarC_SMTEncoding_Term.fv_name + vars in + FStarC_Compiler_String.concat + ", " uu___13 in + let uu___13 = + FStarC_SMTEncoding_Term.print_smt_term + body3 in + FStarC_Compiler_Util.print2 + "Checking eta expansion of\n\tvars={%s}\n\tbody=%s\n" + uu___12 uu___13 + else ()); + (let cvar_sorts = + FStarC_Compiler_List.map + FStarC_SMTEncoding_Term.fv_sort + cvars1 in + let fsym = + let uu___11 = + FStarC_Compiler_Util.digest_of_string + tkey_hash in + Prims.strcat "Tm_abs_" + uu___11 in + let fdecl = + FStarC_SMTEncoding_Term.DeclFun + (fsym, cvar_sorts, + FStarC_SMTEncoding_Term.Term_sort, + FStar_Pervasives_Native.None) in + let f = + let uu___11 = + let uu___12 = + FStarC_Compiler_List.map + FStarC_SMTEncoding_Util.mkFreeV + cvars1 in + (fsym, uu___12) in + FStarC_SMTEncoding_Util.mkApp + uu___11 in + let app = mk_Apply f vars in + let typing_f = + match arrow_t_opt with + | FStar_Pervasives_Native.None + -> + let tot_fun_ax = + let ax = + let uu___11 = + FStarC_Compiler_List.map + (fun uu___12 -> + FStarC_SMTEncoding_Util.mkTrue) + vars in + isTotFun_axioms + t0.FStarC_Syntax_Syntax.pos + f vars uu___11 + is_pure in + match cvars1 with + | [] -> ax + | uu___11 -> + FStarC_SMTEncoding_Term.mkForall + t0.FStarC_Syntax_Syntax.pos + ([[f]], cvars1, + ax) in + let a_name = + Prims.strcat "tot_fun_" + fsym in + let uu___11 = + FStarC_SMTEncoding_Util.mkAssume + (tot_fun_ax, + (FStar_Pervasives_Native.Some + a_name), a_name) in + [uu___11] + | FStar_Pervasives_Native.Some + t2 -> + let f_has_t = + FStarC_SMTEncoding_Term.mk_HasTypeWithFuel + FStar_Pervasives_Native.None + f t2 in + let a_name = + Prims.strcat "typing_" + fsym in + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_SMTEncoding_Term.mkForall + t0.FStarC_Syntax_Syntax.pos + ([[f]], cvars1, + f_has_t) in + (uu___13, + (FStar_Pervasives_Native.Some + a_name), a_name) in + FStarC_SMTEncoding_Util.mkAssume + uu___12 in + [uu___11] in + let interp_f = + let a_name = + Prims.strcat + "interpretation_" fsym in + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_SMTEncoding_Util.mkEq + (app, body3) in + ([[app]], + (FStarC_Compiler_List.op_At + vars cvars1), + uu___14) in + FStarC_SMTEncoding_Term.mkForall + t0.FStarC_Syntax_Syntax.pos + uu___13 in + (uu___12, + (FStar_Pervasives_Native.Some + a_name), a_name) in + FStarC_SMTEncoding_Util.mkAssume + uu___11 in + let f_decls = + FStarC_Compiler_List.op_At + (fdecl :: typing_f) + [interp_f] in + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_SMTEncoding_Term.mk_decls + fsym tkey_hash + f_decls + (FStarC_Compiler_List.op_At + decls + (FStarC_Compiler_List.op_At + decls' decls'')) in + FStarC_Compiler_List.op_At + decls'' uu___14 in + FStarC_Compiler_List.op_At + decls' uu___13 in + FStarC_Compiler_List.op_At + decls uu___12 in + (f, uu___11))))))))) + | FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = + (uu___2, + { FStarC_Syntax_Syntax.lbname = FStar_Pervasives.Inr uu___3; + FStarC_Syntax_Syntax.lbunivs = uu___4; + FStarC_Syntax_Syntax.lbtyp = uu___5; + FStarC_Syntax_Syntax.lbeff = uu___6; + FStarC_Syntax_Syntax.lbdef = uu___7; + FStarC_Syntax_Syntax.lbattrs = uu___8; + FStarC_Syntax_Syntax.lbpos = uu___9;_}::uu___10); + FStarC_Syntax_Syntax.body1 = uu___11;_} + -> failwith "Impossible: already handled by encoding of Sig_let" + | FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = + (false, + { FStarC_Syntax_Syntax.lbname = FStar_Pervasives.Inl x; + FStarC_Syntax_Syntax.lbunivs = uu___2; + FStarC_Syntax_Syntax.lbtyp = t11; + FStarC_Syntax_Syntax.lbeff = uu___3; + FStarC_Syntax_Syntax.lbdef = e1; + FStarC_Syntax_Syntax.lbattrs = uu___4; + FStarC_Syntax_Syntax.lbpos = uu___5;_}::[]); + FStarC_Syntax_Syntax.body1 = e2;_} + -> encode_let x t11 e1 e2 env encode_term + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (false, uu___2::uu___3); + FStarC_Syntax_Syntax.body1 = uu___4;_} + -> + failwith "Impossible: non-recursive let with multiple bindings" + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (uu___2, lbs); + FStarC_Syntax_Syntax.body1 = uu___3;_} + -> + let names = + FStarC_Compiler_List.map + (fun lb -> + let uu___4 = lb in + match uu___4 with + | { FStarC_Syntax_Syntax.lbname = lbname; + FStarC_Syntax_Syntax.lbunivs = uu___5; + FStarC_Syntax_Syntax.lbtyp = uu___6; + FStarC_Syntax_Syntax.lbeff = uu___7; + FStarC_Syntax_Syntax.lbdef = uu___8; + FStarC_Syntax_Syntax.lbattrs = uu___9; + FStarC_Syntax_Syntax.lbpos = uu___10;_} -> + let x = FStarC_Compiler_Util.left lbname in + let uu___11 = + FStarC_Ident.string_of_id + x.FStarC_Syntax_Syntax.ppname in + let uu___12 = FStarC_Syntax_Syntax.range_of_bv x in + (uu___11, uu___12)) lbs in + FStarC_Compiler_Effect.raise + (FStarC_SMTEncoding_Env.Inner_let_rec names) + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = e; + FStarC_Syntax_Syntax.ret_opt = uu___2; + FStarC_Syntax_Syntax.brs = pats; + FStarC_Syntax_Syntax.rc_opt1 = uu___3;_} + -> + encode_match e pats FStarC_SMTEncoding_Term.mk_Term_unit env + encode_term)) +and (encode_let : + FStarC_Syntax_Syntax.bv -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> + FStarC_SMTEncoding_Env.env_t -> + (FStarC_Syntax_Syntax.term -> + FStarC_SMTEncoding_Env.env_t -> + (FStarC_SMTEncoding_Term.term * + FStarC_SMTEncoding_Term.decls_t)) + -> + (FStarC_SMTEncoding_Term.term * + FStarC_SMTEncoding_Term.decls_t)) + = + fun x -> + fun t1 -> + fun e1 -> + fun e2 -> + fun env -> + fun encode_body -> + let uu___ = + let uu___1 = + FStarC_Syntax_Util.ascribe e1 + ((FStar_Pervasives.Inl t1), FStar_Pervasives_Native.None, + false) in + encode_term uu___1 env in + match uu___ with + | (ee1, decls1) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.mk_binder x in + [uu___3] in + FStarC_Syntax_Subst.open_term uu___2 e2 in + (match uu___1 with + | (xs, e21) -> + let x1 = + let uu___2 = FStarC_Compiler_List.hd xs in + uu___2.FStarC_Syntax_Syntax.binder_bv in + let env' = + FStarC_SMTEncoding_Env.push_term_var env x1 ee1 in + let uu___2 = encode_body e21 env' in + (match uu___2 with + | (ee2, decls2) -> + (ee2, (FStarC_Compiler_List.op_At decls1 decls2)))) +and (encode_match : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.branch Prims.list -> + FStarC_SMTEncoding_Term.term -> + FStarC_SMTEncoding_Env.env_t -> + (FStarC_Syntax_Syntax.term -> + FStarC_SMTEncoding_Env.env_t -> + (FStarC_SMTEncoding_Term.term * + FStarC_SMTEncoding_Term.decls_t)) + -> + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.decls_t)) + = + fun e -> + fun pats -> + fun default_case -> + fun env -> + fun encode_br -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Syntax_Syntax.mk FStarC_Syntax_Syntax.Tm_unknown + FStarC_Compiler_Range_Type.dummyRange in + FStarC_Syntax_Syntax.null_bv uu___2 in + FStarC_SMTEncoding_Env.gen_term_var env uu___1 in + match uu___ with + | (scrsym, scr', env1) -> + let uu___1 = encode_term e env1 in + (match uu___1 with + | (scr, decls) -> + let uu___2 = + let encode_branch b uu___3 = + match uu___3 with + | (else_case, decls1) -> + let uu___4 = FStarC_Syntax_Subst.open_branch b in + (match uu___4 with + | (p, w, br) -> + let uu___5 = encode_pat env1 p in + (match uu___5 with + | (env0, pattern1) -> + let guard = pattern1.guard scr' in + let projections = + pattern1.projections scr' in + let env2 = + FStarC_Compiler_List.fold_left + (fun env3 -> + fun uu___6 -> + match uu___6 with + | (x, t) -> + FStarC_SMTEncoding_Env.push_term_var + env3 x t) env1 + projections in + let uu___6 = + match w with + | FStar_Pervasives_Native.None -> + (guard, []) + | FStar_Pervasives_Native.Some w1 -> + let uu___7 = encode_term w1 env2 in + (match uu___7 with + | (w2, decls2) -> + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_SMTEncoding_Term.boxBool + FStarC_SMTEncoding_Util.mkTrue in + (w2, uu___12) in + FStarC_SMTEncoding_Util.mkEq + uu___11 in + (guard, uu___10) in + FStarC_SMTEncoding_Util.mkAnd + uu___9 in + (uu___8, decls2)) in + (match uu___6 with + | (guard1, decls2) -> + let uu___7 = encode_br br env2 in + (match uu___7 with + | (br1, decls3) -> + let uu___8 = + FStarC_SMTEncoding_Util.mkITE + (guard1, br1, else_case) in + (uu___8, + (FStarC_Compiler_List.op_At + decls1 + (FStarC_Compiler_List.op_At + decls2 decls3))))))) in + FStarC_Compiler_List.fold_right encode_branch pats + (default_case, decls) in + (match uu___2 with + | (match_tm, decls1) -> + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_SMTEncoding_Term.mk_fv + (scrsym, + FStarC_SMTEncoding_Term.Term_sort) in + (uu___7, scr) in + [uu___6] in + (uu___5, match_tm) in + FStarC_SMTEncoding_Term.mkLet' uu___4 + FStarC_Compiler_Range_Type.dummyRange in + (uu___3, decls1))) +and (encode_pat : + FStarC_SMTEncoding_Env.env_t -> + FStarC_Syntax_Syntax.pat -> (FStarC_SMTEncoding_Env.env_t * pattern)) + = + fun env -> + fun pat -> + (let uu___1 = FStarC_Compiler_Debug.medium () in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_pat pat in + FStarC_Compiler_Util.print1 "Encoding pattern %s\n" uu___2 + else ()); + (let uu___1 = FStarC_TypeChecker_Util.decorated_pattern_as_term pat in + match uu___1 with + | (vars, pat_term) -> + let uu___2 = + FStarC_Compiler_List.fold_left + (fun uu___3 -> + fun v -> + match uu___3 with + | (env1, vars1) -> + let uu___4 = + FStarC_SMTEncoding_Env.gen_term_var env1 v in + (match uu___4 with + | (xx, uu___5, env2) -> + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_SMTEncoding_Term.mk_fv + (xx, FStarC_SMTEncoding_Term.Term_sort) in + (v, uu___8) in + uu___7 :: vars1 in + (env2, uu___6))) (env, []) vars in + (match uu___2 with + | (env1, vars1) -> + let rec mk_guard pat1 scrutinee = + match pat1.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_var uu___3 -> + FStarC_SMTEncoding_Util.mkTrue + | FStarC_Syntax_Syntax.Pat_dot_term uu___3 -> + FStarC_SMTEncoding_Util.mkTrue + | FStarC_Syntax_Syntax.Pat_constant c -> + let uu___3 = encode_const c env1 in + (match uu___3 with + | (tm, decls) -> + ((match decls with + | uu___5::uu___6 -> + failwith + "Unexpected encoding of constant pattern" + | uu___5 -> ()); + FStarC_SMTEncoding_Util.mkEq (scrutinee, tm))) + | FStarC_Syntax_Syntax.Pat_cons (f, uu___3, args) -> + let is_f = + let tc_name = + FStarC_TypeChecker_Env.typ_of_datacon + env1.FStarC_SMTEncoding_Env.tcenv + (f.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + let uu___4 = + FStarC_TypeChecker_Env.datacons_of_typ + env1.FStarC_SMTEncoding_Env.tcenv tc_name in + match uu___4 with + | (uu___5, uu___6::[]) -> + FStarC_SMTEncoding_Util.mkTrue + | uu___5 -> + FStarC_SMTEncoding_Env.mk_data_tester env1 + (f.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + scrutinee in + let sub_term_guards = + FStarC_Compiler_List.mapi + (fun i -> + fun uu___4 -> + match uu___4 with + | (arg, uu___5) -> + let proj = + FStarC_SMTEncoding_Env.primitive_projector_by_pos + env1.FStarC_SMTEncoding_Env.tcenv + (f.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + i in + let uu___6 = + FStarC_SMTEncoding_Util.mkApp + (proj, [scrutinee]) in + mk_guard arg uu___6) args in + FStarC_SMTEncoding_Util.mk_and_l (is_f :: + sub_term_guards) in + let rec mk_projections pat1 scrutinee = + match pat1.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_dot_term uu___3 -> [] + | FStarC_Syntax_Syntax.Pat_var x -> [(x, scrutinee)] + | FStarC_Syntax_Syntax.Pat_constant uu___3 -> [] + | FStarC_Syntax_Syntax.Pat_cons (f, uu___3, args) -> + let uu___4 = + FStarC_Compiler_List.mapi + (fun i -> + fun uu___5 -> + match uu___5 with + | (arg, uu___6) -> + let proj = + FStarC_SMTEncoding_Env.primitive_projector_by_pos + env1.FStarC_SMTEncoding_Env.tcenv + (f.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + i in + let uu___7 = + FStarC_SMTEncoding_Util.mkApp + (proj, [scrutinee]) in + mk_projections arg uu___7) args in + FStarC_Compiler_List.flatten uu___4 in + let pat_term1 uu___3 = encode_term pat_term env1 in + let pattern1 = + { + pat_vars = vars1; + pat_term = pat_term1; + guard = (mk_guard pat); + projections = (mk_projections pat) + } in + (env1, pattern1))) +and (encode_args : + FStarC_Syntax_Syntax.args -> + FStarC_SMTEncoding_Env.env_t -> + (FStarC_SMTEncoding_Term.term Prims.list * + FStarC_SMTEncoding_Term.decls_t)) + = + fun l -> + fun env -> + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun uu___2 -> + match (uu___1, uu___2) with + | ((tms, decls), (t, uu___3)) -> + let uu___4 = encode_term t env in + (match uu___4 with + | (t1, decls') -> + ((t1 :: tms), + (FStarC_Compiler_List.op_At decls decls')))) + ([], []) l in + match uu___ with + | (l1, decls) -> ((FStarC_Compiler_List.rev l1), decls) +and (encode_smt_patterns : + FStarC_Syntax_Syntax.arg Prims.list Prims.list -> + FStarC_SMTEncoding_Env.env_t -> + (FStarC_SMTEncoding_Term.term Prims.list Prims.list * + FStarC_SMTEncoding_Term.decls_t)) + = + fun pats_l -> + fun env -> + let env1 = + { + FStarC_SMTEncoding_Env.bvar_bindings = + (env.FStarC_SMTEncoding_Env.bvar_bindings); + FStarC_SMTEncoding_Env.fvar_bindings = + (env.FStarC_SMTEncoding_Env.fvar_bindings); + FStarC_SMTEncoding_Env.depth = (env.FStarC_SMTEncoding_Env.depth); + FStarC_SMTEncoding_Env.tcenv = (env.FStarC_SMTEncoding_Env.tcenv); + FStarC_SMTEncoding_Env.warn = (env.FStarC_SMTEncoding_Env.warn); + FStarC_SMTEncoding_Env.nolabels = + (env.FStarC_SMTEncoding_Env.nolabels); + FStarC_SMTEncoding_Env.use_zfuel_name = true; + FStarC_SMTEncoding_Env.encode_non_total_function_typ = + (env.FStarC_SMTEncoding_Env.encode_non_total_function_typ); + FStarC_SMTEncoding_Env.current_module_name = + (env.FStarC_SMTEncoding_Env.current_module_name); + FStarC_SMTEncoding_Env.encoding_quantifier = + (env.FStarC_SMTEncoding_Env.encoding_quantifier); + FStarC_SMTEncoding_Env.global_cache = + (env.FStarC_SMTEncoding_Env.global_cache) + } in + let encode_smt_pattern t = + let uu___ = FStarC_Syntax_Util.head_and_args t in + match uu___ with + | (head, args) -> + let head1 = FStarC_Syntax_Util.un_uinst head in + (match ((head1.FStarC_Syntax_Syntax.n), args) with + | (FStarC_Syntax_Syntax.Tm_fvar fv, + uu___1::(x, uu___2)::(t1, uu___3)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.has_type_lid + -> + let uu___4 = encode_term x env1 in + (match uu___4 with + | (x1, decls) -> + let uu___5 = encode_term t1 env1 in + (match uu___5 with + | (t2, decls') -> + let uu___6 = + FStarC_SMTEncoding_Term.mk_HasType x1 t2 in + (uu___6, + (FStarC_Compiler_List.op_At decls decls')))) + | uu___1 -> encode_term t env1) in + FStarC_Compiler_List.fold_right + (fun pats -> + fun uu___ -> + match uu___ with + | (pats_l1, decls) -> + let uu___1 = + FStarC_Compiler_List.fold_right + (fun uu___2 -> + fun uu___3 -> + match (uu___2, uu___3) with + | ((p, uu___4), (pats1, decls1)) -> + let uu___5 = encode_smt_pattern p in + (match uu___5 with + | (t, d) -> + let uu___6 = + FStarC_SMTEncoding_Term.check_pattern_ok + t in + (match uu___6 with + | FStar_Pervasives_Native.None -> + ((t :: pats1), + (FStarC_Compiler_List.op_At d + decls1)) + | FStar_Pervasives_Native.Some + illegal_subterm -> + ((let uu___8 = + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + p in + let uu___10 = + FStarC_Class_Show.show + FStarC_SMTEncoding_Term.showable_smt_term + illegal_subterm in + FStarC_Compiler_Util.format2 + "Pattern %s contains illegal sub-term (%s); dropping it" + uu___9 uu___10 in + FStarC_Errors.log_issue + (FStarC_Syntax_Syntax.has_range_syntax + ()) p + FStarC_Errors_Codes.Warning_SMTPatternIllFormed + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___8)); + (pats1, + (FStarC_Compiler_List.op_At d + decls1)))))) pats ([], decls) in + (match uu___1 with + | (pats1, decls1) -> ((pats1 :: pats_l1), decls1))) pats_l + ([], []) +and (encode_formula : + FStarC_Syntax_Syntax.typ -> + FStarC_SMTEncoding_Env.env_t -> + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.decls_t)) + = + fun phi -> + fun env -> + let debug phi1 = + let uu___ = FStarC_Compiler_Effect.op_Bang dbg_SMTEncoding in + if uu___ + then + let uu___1 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term phi1 in + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term phi1 in + FStarC_Compiler_Util.print2 "Formula (%s) %s\n" uu___1 uu___2 + else () in + let enc f r l = + let uu___ = + FStarC_Compiler_Util.fold_map + (fun decls -> + fun x -> + let uu___1 = encode_term (FStar_Pervasives_Native.fst x) env in + match uu___1 with + | (t, decls') -> + ((FStarC_Compiler_List.op_At decls decls'), t)) [] l in + match uu___ with + | (decls, args) -> + let uu___1 = + let uu___2 = f args in + { + FStarC_SMTEncoding_Term.tm = + (uu___2.FStarC_SMTEncoding_Term.tm); + FStarC_SMTEncoding_Term.freevars = + (uu___2.FStarC_SMTEncoding_Term.freevars); + FStarC_SMTEncoding_Term.rng = r + } in + (uu___1, decls) in + let const_op f r uu___ = let uu___1 = f r in (uu___1, []) in + let un_op f l = let uu___ = FStarC_Compiler_List.hd l in f uu___ in + let bin_op f uu___ = + match uu___ with + | t1::t2::[] -> f (t1, t2) + | uu___1 -> failwith "Impossible" in + let enc_prop_c f r l = + let uu___ = + FStarC_Compiler_Util.fold_map + (fun decls -> + fun uu___1 -> + match uu___1 with + | (t, uu___2) -> + let uu___3 = encode_formula t env in + (match uu___3 with + | (phi1, decls') -> + ((FStarC_Compiler_List.op_At decls decls'), phi1))) + [] l in + match uu___ with + | (decls, phis) -> + let uu___1 = + let uu___2 = f phis in + { + FStarC_SMTEncoding_Term.tm = + (uu___2.FStarC_SMTEncoding_Term.tm); + FStarC_SMTEncoding_Term.freevars = + (uu___2.FStarC_SMTEncoding_Term.freevars); + FStarC_SMTEncoding_Term.rng = r + } in + (uu___1, decls) in + let eq_op r args = + let rf = + FStarC_Compiler_List.filter + (fun uu___ -> + match uu___ with + | (a, q) -> + (match q with + | FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = uu___1;_} + -> false + | uu___1 -> true)) args in + if (FStarC_Compiler_List.length rf) <> (Prims.of_int (2)) + then + let uu___ = + FStarC_Compiler_Util.format1 + "eq_op: got %s non-implicit arguments instead of 2?" + (Prims.string_of_int (FStarC_Compiler_List.length rf)) in + failwith uu___ + else + (let uu___1 = enc (bin_op FStarC_SMTEncoding_Util.mkEq) in + uu___1 r rf) in + let mk_imp r uu___ = + match uu___ with + | (lhs, uu___1)::(rhs, uu___2)::[] -> + let uu___3 = encode_formula rhs env in + (match uu___3 with + | (l1, decls1) -> + (match l1.FStarC_SMTEncoding_Term.tm with + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.TrueOp, uu___4) -> + (l1, decls1) + | uu___4 -> + let uu___5 = encode_formula lhs env in + (match uu___5 with + | (l2, decls2) -> + let uu___6 = + FStarC_SMTEncoding_Term.mkImp (l2, l1) r in + (uu___6, + (FStarC_Compiler_List.op_At decls1 decls2))))) + | uu___1 -> failwith "impossible" in + let mk_ite r uu___ = + match uu___ with + | (guard, uu___1)::(_then, uu___2)::(_else, uu___3)::[] -> + let uu___4 = encode_formula guard env in + (match uu___4 with + | (g, decls1) -> + let uu___5 = encode_formula _then env in + (match uu___5 with + | (t, decls2) -> + let uu___6 = encode_formula _else env in + (match uu___6 with + | (e, decls3) -> + let res = + FStarC_SMTEncoding_Term.mkITE (g, t, e) r in + (res, + (FStarC_Compiler_List.op_At decls1 + (FStarC_Compiler_List.op_At decls2 decls3)))))) + | uu___1 -> failwith "impossible" in + let unboxInt_l f l = + let uu___ = + FStarC_Compiler_List.map FStarC_SMTEncoding_Term.unboxInt l in + f uu___ in + let connectives = + let uu___ = + let uu___1 = enc_prop_c (bin_op FStarC_SMTEncoding_Util.mkAnd) in + (FStarC_Parser_Const.and_lid, uu___1) in + let uu___1 = + let uu___2 = + let uu___3 = enc_prop_c (bin_op FStarC_SMTEncoding_Util.mkOr) in + (FStarC_Parser_Const.or_lid, uu___3) in + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + enc_prop_c (bin_op FStarC_SMTEncoding_Util.mkIff) in + (FStarC_Parser_Const.iff_lid, uu___6) in + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + enc_prop_c (un_op FStarC_SMTEncoding_Util.mkNot) in + (FStarC_Parser_Const.not_lid, uu___9) in + [uu___8; + (FStarC_Parser_Const.eq2_lid, eq_op); + (FStarC_Parser_Const.c_eq2_lid, eq_op); + (FStarC_Parser_Const.true_lid, + (const_op FStarC_SMTEncoding_Term.mkTrue)); + (FStarC_Parser_Const.false_lid, + (const_op FStarC_SMTEncoding_Term.mkFalse))] in + (FStarC_Parser_Const.ite_lid, mk_ite) :: uu___7 in + uu___5 :: uu___6 in + (FStarC_Parser_Const.imp_lid, mk_imp) :: uu___4 in + uu___2 :: uu___3 in + uu___ :: uu___1 in + let rec fallback phi1 = + match phi1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = phi'; + FStarC_Syntax_Syntax.meta = FStarC_Syntax_Syntax.Meta_labeled + (msg, r, b);_} + -> + let uu___ = encode_formula phi' env in + (match uu___ with + | (phi2, decls) -> + let uu___1 = + FStarC_SMTEncoding_Term.mk + (FStarC_SMTEncoding_Term.Labeled (phi2, msg, r)) r in + (uu___1, decls)) + | FStarC_Syntax_Syntax.Tm_meta uu___ -> + let uu___1 = FStarC_Syntax_Util.unmeta phi1 in + encode_formula uu___1 env + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = e; + FStarC_Syntax_Syntax.ret_opt = uu___; + FStarC_Syntax_Syntax.brs = pats; + FStarC_Syntax_Syntax.rc_opt1 = uu___1;_} + -> + let uu___2 = + encode_match e pats FStarC_SMTEncoding_Term.mkUnreachable env + encode_formula in + (match uu___2 with | (t, decls) -> (t, decls)) + | FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = + (false, + { FStarC_Syntax_Syntax.lbname = FStar_Pervasives.Inl x; + FStarC_Syntax_Syntax.lbunivs = uu___; + FStarC_Syntax_Syntax.lbtyp = t1; + FStarC_Syntax_Syntax.lbeff = uu___1; + FStarC_Syntax_Syntax.lbdef = e1; + FStarC_Syntax_Syntax.lbattrs = uu___2; + FStarC_Syntax_Syntax.lbpos = uu___3;_}::[]); + FStarC_Syntax_Syntax.body1 = e2;_} + -> + let uu___4 = encode_let x t1 e1 e2 env encode_formula in + (match uu___4 with | (t, decls) -> (t, decls)) + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = args;_} + -> + let head1 = FStarC_Syntax_Util.un_uinst head in + (match ((head1.FStarC_Syntax_Syntax.n), args) with + | (FStarC_Syntax_Syntax.Tm_fvar fv, + uu___::(x, uu___1)::(t, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.has_type_lid + -> + let uu___3 = encode_term x env in + (match uu___3 with + | (x1, decls) -> + let uu___4 = encode_term t env in + (match uu___4 with + | (t1, decls') -> + let uu___5 = + FStarC_SMTEncoding_Term.mk_HasType x1 t1 in + (uu___5, + (FStarC_Compiler_List.op_At decls decls')))) + | (FStarC_Syntax_Syntax.Tm_fvar fv, uu___::(phi2, uu___1)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.by_tactic_lid + -> encode_formula phi2 env + | (FStarC_Syntax_Syntax.Tm_uinst + ({ FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar fv; + FStarC_Syntax_Syntax.pos = uu___; + FStarC_Syntax_Syntax.vars = uu___1; + FStarC_Syntax_Syntax.hash_code = uu___2;_}, + uu___3), + uu___4::(phi2, uu___5)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.by_tactic_lid + -> encode_formula phi2 env + | (FStarC_Syntax_Syntax.Tm_fvar fv, + uu___::uu___1::(phi2, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.rewrite_by_tactic_lid + -> encode_formula phi2 env + | (FStarC_Syntax_Syntax.Tm_uinst + ({ FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar fv; + FStarC_Syntax_Syntax.pos = uu___; + FStarC_Syntax_Syntax.vars = uu___1; + FStarC_Syntax_Syntax.hash_code = uu___2;_}, + uu___3), + uu___4::uu___5::(phi2, uu___6)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.rewrite_by_tactic_lid + -> encode_formula phi2 env + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (r, uu___)::(msg, uu___1)::(phi2, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.labeled_lid + -> + let uu___3 = + let uu___4 = + FStarC_Syntax_Embeddings_Base.try_unembed + FStarC_Syntax_Embeddings.e_range r + FStarC_Syntax_Embeddings_Base.id_norm_cb in + let uu___5 = + FStarC_Syntax_Embeddings_Base.try_unembed + FStarC_Syntax_Embeddings.e_string msg + FStarC_Syntax_Embeddings_Base.id_norm_cb in + (uu___4, uu___5) in + (match uu___3 with + | (FStar_Pervasives_Native.Some r1, + FStar_Pervasives_Native.Some s) -> + let phi3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Errors_Msg.mkmsg s in + (uu___8, r1, false) in + FStarC_Syntax_Syntax.Meta_labeled uu___7 in + { + FStarC_Syntax_Syntax.tm2 = phi2; + FStarC_Syntax_Syntax.meta = uu___6 + } in + FStarC_Syntax_Syntax.Tm_meta uu___5 in + FStarC_Syntax_Syntax.mk uu___4 r1 in + fallback phi3 + | (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.Some s) -> + let phi3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Errors_Msg.mkmsg s in + (uu___8, (phi2.FStarC_Syntax_Syntax.pos), + false) in + FStarC_Syntax_Syntax.Meta_labeled uu___7 in + { + FStarC_Syntax_Syntax.tm2 = phi2; + FStarC_Syntax_Syntax.meta = uu___6 + } in + FStarC_Syntax_Syntax.Tm_meta uu___5 in + FStarC_Syntax_Syntax.mk uu___4 + phi2.FStarC_Syntax_Syntax.pos in + fallback phi3 + | uu___4 -> fallback phi2) + | (FStarC_Syntax_Syntax.Tm_fvar fv, (t, uu___)::[]) when + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.squash_lid) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.auto_squash_lid) + -> encode_formula t env + | uu___ -> + let encode_valid uu___1 = + let uu___2 = encode_term phi1 env in + match uu___2 with + | (tt, decls) -> + let tt1 = + let uu___3 = + let uu___4 = + FStarC_Compiler_Range_Type.use_range + tt.FStarC_SMTEncoding_Term.rng in + let uu___5 = + FStarC_Compiler_Range_Type.use_range + phi1.FStarC_Syntax_Syntax.pos in + FStarC_Compiler_Range_Ops.rng_included uu___4 + uu___5 in + if uu___3 + then tt + else + { + FStarC_SMTEncoding_Term.tm = + (tt.FStarC_SMTEncoding_Term.tm); + FStarC_SMTEncoding_Term.freevars = + (tt.FStarC_SMTEncoding_Term.freevars); + FStarC_SMTEncoding_Term.rng = + (phi1.FStarC_Syntax_Syntax.pos) + } in + let uu___3 = FStarC_SMTEncoding_Term.mk_Valid tt1 in + (uu___3, decls) in + let uu___1 = head_redex env head1 in + if uu___1 + then + let uu___2 = maybe_whnf env head1 in + (match uu___2 with + | FStar_Pervasives_Native.None -> encode_valid () + | FStar_Pervasives_Native.Some phi2 -> + encode_formula phi2 env) + else encode_valid ()) + | uu___ -> + let uu___1 = encode_term phi1 env in + (match uu___1 with + | (tt, decls) -> + let tt1 = + let uu___2 = + let uu___3 = + FStarC_Compiler_Range_Type.use_range + tt.FStarC_SMTEncoding_Term.rng in + let uu___4 = + FStarC_Compiler_Range_Type.use_range + phi1.FStarC_Syntax_Syntax.pos in + FStarC_Compiler_Range_Ops.rng_included uu___3 uu___4 in + if uu___2 + then tt + else + { + FStarC_SMTEncoding_Term.tm = + (tt.FStarC_SMTEncoding_Term.tm); + FStarC_SMTEncoding_Term.freevars = + (tt.FStarC_SMTEncoding_Term.freevars); + FStarC_SMTEncoding_Term.rng = + (phi1.FStarC_Syntax_Syntax.pos) + } in + let uu___2 = FStarC_SMTEncoding_Term.mk_Valid tt1 in + (uu___2, decls)) in + let encode_q_body env1 bs ps body = + let uu___ = encode_binders FStar_Pervasives_Native.None bs env1 in + match uu___ with + | (vars, guards, env2, decls, uu___1) -> + let uu___2 = encode_smt_patterns ps env2 in + (match uu___2 with + | (pats, decls') -> + let uu___3 = encode_formula body env2 in + (match uu___3 with + | (body1, decls'') -> + let guards1 = + match pats with + | ({ + FStarC_SMTEncoding_Term.tm = + FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Var gf, p::[]); + FStarC_SMTEncoding_Term.freevars = uu___4; + FStarC_SMTEncoding_Term.rng = uu___5;_}::[])::[] + when + let uu___6 = + FStarC_Ident.string_of_lid + FStarC_Parser_Const.guard_free in + uu___6 = gf -> [] + | uu___4 -> guards in + let uu___4 = FStarC_SMTEncoding_Util.mk_and_l guards1 in + (vars, pats, uu___4, body1, + (FStarC_Compiler_List.op_At decls + (FStarC_Compiler_List.op_At decls' decls''))))) in + debug phi; + (let phi1 = FStarC_Syntax_Util.unascribe phi in + let uu___1 = FStarC_Syntax_Formula.destruct_typ_as_formula phi1 in + match uu___1 with + | FStar_Pervasives_Native.None -> fallback phi1 + | FStar_Pervasives_Native.Some (FStarC_Syntax_Formula.BaseConn + (op, arms)) -> + let uu___2 = + FStarC_Compiler_List.tryFind + (fun uu___3 -> + match uu___3 with + | (l, uu___4) -> FStarC_Ident.lid_equals op l) connectives in + (match uu___2 with + | FStar_Pervasives_Native.None -> fallback phi1 + | FStar_Pervasives_Native.Some (uu___3, f) -> + f phi1.FStarC_Syntax_Syntax.pos arms) + | FStar_Pervasives_Native.Some (FStarC_Syntax_Formula.QAll + (vars, pats, body)) -> + (FStarC_Compiler_List.iter (check_pattern_vars env vars) pats; + (let uu___3 = encode_q_body env vars pats body in + match uu___3 with + | (vars1, pats1, guard, body1, decls) -> + let tm = + let uu___4 = + let uu___5 = + FStarC_SMTEncoding_Util.mkImp (guard, body1) in + (pats1, vars1, uu___5) in + FStarC_SMTEncoding_Term.mkForall + phi1.FStarC_Syntax_Syntax.pos uu___4 in + (tm, decls))) + | FStar_Pervasives_Native.Some (FStarC_Syntax_Formula.QEx + (vars, pats, body)) -> + (FStarC_Compiler_List.iter (check_pattern_vars env vars) pats; + (let uu___3 = encode_q_body env vars pats body in + match uu___3 with + | (vars1, pats1, guard, body1, decls) -> + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_SMTEncoding_Util.mkAnd (guard, body1) in + (pats1, vars1, uu___6) in + FStarC_SMTEncoding_Term.mkExists + phi1.FStarC_Syntax_Syntax.pos uu___5 in + (uu___4, decls)))) +let (encode_function_type_as_formula : + FStarC_Syntax_Syntax.typ -> + FStarC_SMTEncoding_Env.env_t -> + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.decls_t)) + = + fun t -> + fun env -> + let universe_of_binders binders = + FStarC_Compiler_List.map (fun uu___ -> FStarC_Syntax_Syntax.U_zero) + binders in + let quant = + FStarC_Syntax_Util.smt_lemma_as_forall t universe_of_binders in + let env1 = + { + FStarC_SMTEncoding_Env.bvar_bindings = + (env.FStarC_SMTEncoding_Env.bvar_bindings); + FStarC_SMTEncoding_Env.fvar_bindings = + (env.FStarC_SMTEncoding_Env.fvar_bindings); + FStarC_SMTEncoding_Env.depth = (env.FStarC_SMTEncoding_Env.depth); + FStarC_SMTEncoding_Env.tcenv = (env.FStarC_SMTEncoding_Env.tcenv); + FStarC_SMTEncoding_Env.warn = (env.FStarC_SMTEncoding_Env.warn); + FStarC_SMTEncoding_Env.nolabels = + (env.FStarC_SMTEncoding_Env.nolabels); + FStarC_SMTEncoding_Env.use_zfuel_name = true; + FStarC_SMTEncoding_Env.encode_non_total_function_typ = + (env.FStarC_SMTEncoding_Env.encode_non_total_function_typ); + FStarC_SMTEncoding_Env.current_module_name = + (env.FStarC_SMTEncoding_Env.current_module_name); + FStarC_SMTEncoding_Env.encoding_quantifier = + (env.FStarC_SMTEncoding_Env.encoding_quantifier); + FStarC_SMTEncoding_Env.global_cache = + (env.FStarC_SMTEncoding_Env.global_cache) + } in + encode_formula quant env1 \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_SMTEncoding_Env.ml b/ocaml/fstar-lib/generated/FStarC_SMTEncoding_Env.ml new file mode 100644 index 00000000000..bb2fa21a1c8 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_SMTEncoding_Env.ml @@ -0,0 +1,1109 @@ +open Prims +let (dbg_PartialApp : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "PartialApp" +exception Inner_let_rec of (Prims.string * FStarC_Compiler_Range_Type.range) + Prims.list +let (uu___is_Inner_let_rec : Prims.exn -> Prims.bool) = + fun projectee -> + match projectee with | Inner_let_rec uu___ -> true | uu___ -> false +let (__proj__Inner_let_rec__item__uu___ : + Prims.exn -> (Prims.string * FStarC_Compiler_Range_Type.range) Prims.list) + = fun projectee -> match projectee with | Inner_let_rec uu___ -> uu___ +let add_fuel : 'uuuuu . 'uuuuu -> 'uuuuu Prims.list -> 'uuuuu Prims.list = + fun x -> + fun tl -> + let uu___ = FStarC_Options.unthrottle_inductives () in + if uu___ then tl else x :: tl +let withenv : + 'uuuuu 'uuuuu1 'uuuuu2 . + 'uuuuu -> ('uuuuu1 * 'uuuuu2) -> ('uuuuu1 * 'uuuuu2 * 'uuuuu) + = fun c -> fun uu___ -> match uu___ with | (a, b) -> (a, b, c) +let vargs : + 'uuuuu 'uuuuu1 'uuuuu2 . + (('uuuuu, 'uuuuu1) FStar_Pervasives.either * 'uuuuu2) Prims.list -> + (('uuuuu, 'uuuuu1) FStar_Pervasives.either * 'uuuuu2) Prims.list + = + fun args -> + FStarC_Compiler_List.filter + (fun uu___ -> + match uu___ with + | (FStar_Pervasives.Inl uu___1, uu___2) -> false + | uu___1 -> true) args +let (escape : Prims.string -> Prims.string) = + fun s -> FStarC_Compiler_Util.replace_char s 39 95 +let (mk_term_projector_name : + FStarC_Ident.lident -> FStarC_Syntax_Syntax.bv -> Prims.string) = + fun lid -> + fun a -> + let uu___ = + let uu___1 = FStarC_Ident.string_of_lid lid in + let uu___2 = FStarC_Ident.string_of_id a.FStarC_Syntax_Syntax.ppname in + FStarC_Compiler_Util.format2 "%s_%s" uu___1 uu___2 in + escape uu___ +let (primitive_projector_by_pos : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident -> Prims.int -> Prims.string) + = + fun env -> + fun lid -> + fun i -> + let fail uu___ = + let uu___1 = + let uu___2 = FStarC_Ident.string_of_lid lid in + FStarC_Compiler_Util.format2 + "Projector %s on data constructor %s not found" + (Prims.string_of_int i) uu___2 in + failwith uu___1 in + let uu___ = FStarC_TypeChecker_Env.lookup_datacon env lid in + match uu___ with + | (uu___1, t) -> + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress t in + uu___3.FStarC_Syntax_Syntax.n in + (match uu___2 with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = c;_} + -> + let uu___3 = FStarC_Syntax_Subst.open_comp bs c in + (match uu___3 with + | (binders, uu___4) -> + if + (i < Prims.int_zero) || + (i >= (FStarC_Compiler_List.length binders)) + then fail () + else + (let b = FStarC_Compiler_List.nth binders i in + mk_term_projector_name lid + b.FStarC_Syntax_Syntax.binder_bv)) + | uu___3 -> fail ()) +let (mk_term_projector_name_by_pos : + FStarC_Ident.lident -> Prims.int -> Prims.string) = + fun lid -> + fun i -> + let uu___ = + let uu___1 = FStarC_Ident.string_of_lid lid in + FStarC_Compiler_Util.format2 "%s_%s" uu___1 (Prims.string_of_int i) in + escape uu___ +let (mk_term_projector : + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.bv -> FStarC_SMTEncoding_Term.term) + = + fun lid -> + fun a -> + let uu___ = + let uu___1 = + let uu___2 = mk_term_projector_name lid a in + (uu___2, + (FStarC_SMTEncoding_Term.Arrow + (FStarC_SMTEncoding_Term.Term_sort, + FStarC_SMTEncoding_Term.Term_sort))) in + FStarC_SMTEncoding_Term.mk_fv uu___1 in + FStarC_SMTEncoding_Util.mkFreeV uu___ +let (mk_term_projector_by_pos : + FStarC_Ident.lident -> Prims.int -> FStarC_SMTEncoding_Term.term) = + fun lid -> + fun i -> + let uu___ = + let uu___1 = + let uu___2 = mk_term_projector_name_by_pos lid i in + (uu___2, + (FStarC_SMTEncoding_Term.Arrow + (FStarC_SMTEncoding_Term.Term_sort, + FStarC_SMTEncoding_Term.Term_sort))) in + FStarC_SMTEncoding_Term.mk_fv uu___1 in + FStarC_SMTEncoding_Util.mkFreeV uu___ +let mk_data_tester : + 'uuuuu . + 'uuuuu -> + FStarC_Ident.lident -> + FStarC_SMTEncoding_Term.term -> FStarC_SMTEncoding_Term.term + = + fun env -> + fun l -> + fun x -> + let uu___ = + let uu___1 = FStarC_Ident.string_of_lid l in escape uu___1 in + FStarC_SMTEncoding_Term.mk_tester uu___ x +type varops_t = + { + push: unit -> unit ; + pop: unit -> unit ; + snapshot: unit -> (Prims.int * unit) ; + rollback: Prims.int FStar_Pervasives_Native.option -> unit ; + new_var: FStarC_Ident.ident -> Prims.int -> Prims.string ; + new_fvar: FStarC_Ident.lident -> Prims.string ; + fresh: Prims.string -> Prims.string -> Prims.string ; + reset_fresh: unit -> unit ; + next_id: unit -> Prims.int ; + mk_unique: Prims.string -> Prims.string } +let (__proj__Mkvarops_t__item__push : varops_t -> unit -> unit) = + fun projectee -> + match projectee with + | { push; pop; snapshot; rollback; new_var; new_fvar; fresh; reset_fresh; + next_id; mk_unique;_} -> push +let (__proj__Mkvarops_t__item__pop : varops_t -> unit -> unit) = + fun projectee -> + match projectee with + | { push; pop; snapshot; rollback; new_var; new_fvar; fresh; reset_fresh; + next_id; mk_unique;_} -> pop +let (__proj__Mkvarops_t__item__snapshot : + varops_t -> unit -> (Prims.int * unit)) = + fun projectee -> + match projectee with + | { push; pop; snapshot; rollback; new_var; new_fvar; fresh; reset_fresh; + next_id; mk_unique;_} -> snapshot +let (__proj__Mkvarops_t__item__rollback : + varops_t -> Prims.int FStar_Pervasives_Native.option -> unit) = + fun projectee -> + match projectee with + | { push; pop; snapshot; rollback; new_var; new_fvar; fresh; reset_fresh; + next_id; mk_unique;_} -> rollback +let (__proj__Mkvarops_t__item__new_var : + varops_t -> FStarC_Ident.ident -> Prims.int -> Prims.string) = + fun projectee -> + match projectee with + | { push; pop; snapshot; rollback; new_var; new_fvar; fresh; reset_fresh; + next_id; mk_unique;_} -> new_var +let (__proj__Mkvarops_t__item__new_fvar : + varops_t -> FStarC_Ident.lident -> Prims.string) = + fun projectee -> + match projectee with + | { push; pop; snapshot; rollback; new_var; new_fvar; fresh; reset_fresh; + next_id; mk_unique;_} -> new_fvar +let (__proj__Mkvarops_t__item__fresh : + varops_t -> Prims.string -> Prims.string -> Prims.string) = + fun projectee -> + match projectee with + | { push; pop; snapshot; rollback; new_var; new_fvar; fresh; reset_fresh; + next_id; mk_unique;_} -> fresh +let (__proj__Mkvarops_t__item__reset_fresh : varops_t -> unit -> unit) = + fun projectee -> + match projectee with + | { push; pop; snapshot; rollback; new_var; new_fvar; fresh; reset_fresh; + next_id; mk_unique;_} -> reset_fresh +let (__proj__Mkvarops_t__item__next_id : varops_t -> unit -> Prims.int) = + fun projectee -> + match projectee with + | { push; pop; snapshot; rollback; new_var; new_fvar; fresh; reset_fresh; + next_id; mk_unique;_} -> next_id +let (__proj__Mkvarops_t__item__mk_unique : + varops_t -> Prims.string -> Prims.string) = + fun projectee -> + match projectee with + | { push; pop; snapshot; rollback; new_var; new_fvar; fresh; reset_fresh; + next_id; mk_unique;_} -> mk_unique +let (varops : varops_t) = + let initial_ctr = (Prims.of_int (100)) in + let ctr = FStarC_Compiler_Util.mk_ref initial_ctr in + let new_scope uu___ = FStarC_Compiler_Util.smap_create (Prims.of_int (100)) in + let scopes = + let uu___ = let uu___1 = new_scope () in [uu___1] in + FStarC_Compiler_Util.mk_ref uu___ in + let mk_unique y = + let y1 = escape y in + let y2 = + let uu___ = + let uu___1 = FStarC_Compiler_Effect.op_Bang scopes in + FStarC_Compiler_Util.find_map uu___1 + (fun names -> FStarC_Compiler_Util.smap_try_find names y1) in + match uu___ with + | FStar_Pervasives_Native.None -> y1 + | FStar_Pervasives_Native.Some uu___1 -> + (FStarC_Compiler_Util.incr ctr; + (let uu___3 = + let uu___4 = + let uu___5 = FStarC_Compiler_Effect.op_Bang ctr in + Prims.string_of_int uu___5 in + Prims.strcat "__" uu___4 in + Prims.strcat y1 uu___3)) in + let top_scope = + let uu___ = FStarC_Compiler_Effect.op_Bang scopes in + FStarC_Compiler_List.hd uu___ in + FStarC_Compiler_Util.smap_add top_scope y2 true; y2 in + let new_var pp rn = + let uu___ = + let uu___1 = FStarC_Ident.string_of_id pp in + Prims.strcat uu___1 (Prims.strcat "__" (Prims.string_of_int rn)) in + mk_unique uu___ in + let new_fvar lid = + let uu___ = FStarC_Ident.string_of_lid lid in mk_unique uu___ in + let next_id uu___ = + FStarC_Compiler_Util.incr ctr; FStarC_Compiler_Effect.op_Bang ctr in + let fresh mname pfx = + let uu___ = let uu___1 = next_id () in Prims.string_of_int uu___1 in + FStarC_Compiler_Util.format3 "%s_%s_%s" pfx mname uu___ in + let reset_fresh uu___ = + FStarC_Compiler_Effect.op_Colon_Equals ctr initial_ctr in + let push uu___ = + let uu___1 = + let uu___2 = new_scope () in + let uu___3 = FStarC_Compiler_Effect.op_Bang scopes in uu___2 :: uu___3 in + FStarC_Compiler_Effect.op_Colon_Equals scopes uu___1 in + let pop uu___ = + let uu___1 = + let uu___2 = FStarC_Compiler_Effect.op_Bang scopes in + FStarC_Compiler_List.tl uu___2 in + FStarC_Compiler_Effect.op_Colon_Equals scopes uu___1 in + let snapshot uu___ = FStarC_Common.snapshot push scopes () in + let rollback depth = FStarC_Common.rollback pop scopes depth in + { + push; + pop; + snapshot; + rollback; + new_var; + new_fvar; + fresh; + reset_fresh; + next_id; + mk_unique + } +type fvar_binding = + { + fvar_lid: FStarC_Ident.lident ; + smt_arity: Prims.int ; + smt_id: Prims.string ; + smt_token: FStarC_SMTEncoding_Term.term FStar_Pervasives_Native.option ; + smt_fuel_partial_app: + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) + FStar_Pervasives_Native.option + ; + fvb_thunked: Prims.bool } +let (__proj__Mkfvar_binding__item__fvar_lid : + fvar_binding -> FStarC_Ident.lident) = + fun projectee -> + match projectee with + | { fvar_lid; smt_arity; smt_id; smt_token; smt_fuel_partial_app; + fvb_thunked;_} -> fvar_lid +let (__proj__Mkfvar_binding__item__smt_arity : fvar_binding -> Prims.int) = + fun projectee -> + match projectee with + | { fvar_lid; smt_arity; smt_id; smt_token; smt_fuel_partial_app; + fvb_thunked;_} -> smt_arity +let (__proj__Mkfvar_binding__item__smt_id : fvar_binding -> Prims.string) = + fun projectee -> + match projectee with + | { fvar_lid; smt_arity; smt_id; smt_token; smt_fuel_partial_app; + fvb_thunked;_} -> smt_id +let (__proj__Mkfvar_binding__item__smt_token : + fvar_binding -> FStarC_SMTEncoding_Term.term FStar_Pervasives_Native.option) + = + fun projectee -> + match projectee with + | { fvar_lid; smt_arity; smt_id; smt_token; smt_fuel_partial_app; + fvb_thunked;_} -> smt_token +let (__proj__Mkfvar_binding__item__smt_fuel_partial_app : + fvar_binding -> + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) + FStar_Pervasives_Native.option) + = + fun projectee -> + match projectee with + | { fvar_lid; smt_arity; smt_id; smt_token; smt_fuel_partial_app; + fvb_thunked;_} -> smt_fuel_partial_app +let (__proj__Mkfvar_binding__item__fvb_thunked : fvar_binding -> Prims.bool) + = + fun projectee -> + match projectee with + | { fvar_lid; smt_arity; smt_id; smt_token; smt_fuel_partial_app; + fvb_thunked;_} -> fvb_thunked +let (fvb_to_string : fvar_binding -> Prims.string) = + fun fvb -> + let term_opt_to_string uu___ = + match uu___ with + | FStar_Pervasives_Native.None -> "None" + | FStar_Pervasives_Native.Some s -> + FStarC_SMTEncoding_Term.print_smt_term s in + let term_pair_opt_to_string uu___ = + match uu___ with + | FStar_Pervasives_Native.None -> "None" + | FStar_Pervasives_Native.Some (s0, s1) -> + let uu___1 = FStarC_SMTEncoding_Term.print_smt_term s0 in + let uu___2 = FStarC_SMTEncoding_Term.print_smt_term s1 in + FStarC_Compiler_Util.format2 "(%s, %s)" uu___1 uu___2 in + let uu___ = FStarC_Ident.string_of_lid fvb.fvar_lid in + let uu___1 = term_opt_to_string fvb.smt_token in + let uu___2 = term_pair_opt_to_string fvb.smt_fuel_partial_app in + let uu___3 = FStarC_Compiler_Util.string_of_bool fvb.fvb_thunked in + FStarC_Compiler_Util.format6 + "{ lid = %s;\n smt_arity = %s;\n smt_id = %s;\n smt_token = %s;\n smt_fuel_partial_app = %s;\n fvb_thunked = %s }" + uu___ (Prims.string_of_int fvb.smt_arity) fvb.smt_id uu___1 uu___2 + uu___3 +let (check_valid_fvb : fvar_binding -> unit) = + fun fvb -> + if + ((FStarC_Compiler_Option.isSome fvb.smt_token) || + (FStarC_Compiler_Option.isSome fvb.smt_fuel_partial_app)) + && fvb.fvb_thunked + then + (let uu___1 = + let uu___2 = FStarC_Ident.string_of_lid fvb.fvar_lid in + FStarC_Compiler_Util.format1 "Unexpected thunked SMT symbol: %s" + uu___2 in + failwith uu___1) + else + if fvb.fvb_thunked && (fvb.smt_arity <> Prims.int_zero) + then + (let uu___2 = + let uu___3 = FStarC_Ident.string_of_lid fvb.fvar_lid in + FStarC_Compiler_Util.format1 + "Unexpected arity of thunked SMT symbol: %s" uu___3 in + failwith uu___2) + else (); + (match fvb.smt_token with + | FStar_Pervasives_Native.Some + { FStarC_SMTEncoding_Term.tm = FStarC_SMTEncoding_Term.FreeV uu___1; + FStarC_SMTEncoding_Term.freevars = uu___2; + FStarC_SMTEncoding_Term.rng = uu___3;_} + -> + let uu___4 = + let uu___5 = fvb_to_string fvb in + FStarC_Compiler_Util.format1 "bad fvb\n%s" uu___5 in + failwith uu___4 + | uu___1 -> ()) +let binder_of_eithervar : + 'uuuuu 'uuuuu1 . + 'uuuuu -> ('uuuuu * 'uuuuu1 FStar_Pervasives_Native.option) + = fun v -> (v, FStar_Pervasives_Native.None) +type env_t = + { + bvar_bindings: + (FStarC_Syntax_Syntax.bv * FStarC_SMTEncoding_Term.term) + FStarC_Compiler_Util.pimap FStarC_Compiler_Util.psmap + ; + fvar_bindings: + (fvar_binding FStarC_Compiler_Util.psmap * fvar_binding Prims.list) ; + depth: Prims.int ; + tcenv: FStarC_TypeChecker_Env.env ; + warn: Prims.bool ; + nolabels: Prims.bool ; + use_zfuel_name: Prims.bool ; + encode_non_total_function_typ: Prims.bool ; + current_module_name: Prims.string ; + encoding_quantifier: Prims.bool ; + global_cache: FStarC_SMTEncoding_Term.decls_elt FStarC_Compiler_Util.smap } +let (__proj__Mkenv_t__item__bvar_bindings : + env_t -> + (FStarC_Syntax_Syntax.bv * FStarC_SMTEncoding_Term.term) + FStarC_Compiler_Util.pimap FStarC_Compiler_Util.psmap) + = + fun projectee -> + match projectee with + | { bvar_bindings; fvar_bindings; depth; tcenv; warn; nolabels; + use_zfuel_name; encode_non_total_function_typ; current_module_name; + encoding_quantifier; global_cache;_} -> bvar_bindings +let (__proj__Mkenv_t__item__fvar_bindings : + env_t -> + (fvar_binding FStarC_Compiler_Util.psmap * fvar_binding Prims.list)) + = + fun projectee -> + match projectee with + | { bvar_bindings; fvar_bindings; depth; tcenv; warn; nolabels; + use_zfuel_name; encode_non_total_function_typ; current_module_name; + encoding_quantifier; global_cache;_} -> fvar_bindings +let (__proj__Mkenv_t__item__depth : env_t -> Prims.int) = + fun projectee -> + match projectee with + | { bvar_bindings; fvar_bindings; depth; tcenv; warn; nolabels; + use_zfuel_name; encode_non_total_function_typ; current_module_name; + encoding_quantifier; global_cache;_} -> depth +let (__proj__Mkenv_t__item__tcenv : env_t -> FStarC_TypeChecker_Env.env) = + fun projectee -> + match projectee with + | { bvar_bindings; fvar_bindings; depth; tcenv; warn; nolabels; + use_zfuel_name; encode_non_total_function_typ; current_module_name; + encoding_quantifier; global_cache;_} -> tcenv +let (__proj__Mkenv_t__item__warn : env_t -> Prims.bool) = + fun projectee -> + match projectee with + | { bvar_bindings; fvar_bindings; depth; tcenv; warn; nolabels; + use_zfuel_name; encode_non_total_function_typ; current_module_name; + encoding_quantifier; global_cache;_} -> warn +let (__proj__Mkenv_t__item__nolabels : env_t -> Prims.bool) = + fun projectee -> + match projectee with + | { bvar_bindings; fvar_bindings; depth; tcenv; warn; nolabels; + use_zfuel_name; encode_non_total_function_typ; current_module_name; + encoding_quantifier; global_cache;_} -> nolabels +let (__proj__Mkenv_t__item__use_zfuel_name : env_t -> Prims.bool) = + fun projectee -> + match projectee with + | { bvar_bindings; fvar_bindings; depth; tcenv; warn; nolabels; + use_zfuel_name; encode_non_total_function_typ; current_module_name; + encoding_quantifier; global_cache;_} -> use_zfuel_name +let (__proj__Mkenv_t__item__encode_non_total_function_typ : + env_t -> Prims.bool) = + fun projectee -> + match projectee with + | { bvar_bindings; fvar_bindings; depth; tcenv; warn; nolabels; + use_zfuel_name; encode_non_total_function_typ; current_module_name; + encoding_quantifier; global_cache;_} -> encode_non_total_function_typ +let (__proj__Mkenv_t__item__current_module_name : env_t -> Prims.string) = + fun projectee -> + match projectee with + | { bvar_bindings; fvar_bindings; depth; tcenv; warn; nolabels; + use_zfuel_name; encode_non_total_function_typ; current_module_name; + encoding_quantifier; global_cache;_} -> current_module_name +let (__proj__Mkenv_t__item__encoding_quantifier : env_t -> Prims.bool) = + fun projectee -> + match projectee with + | { bvar_bindings; fvar_bindings; depth; tcenv; warn; nolabels; + use_zfuel_name; encode_non_total_function_typ; current_module_name; + encoding_quantifier; global_cache;_} -> encoding_quantifier +let (__proj__Mkenv_t__item__global_cache : + env_t -> FStarC_SMTEncoding_Term.decls_elt FStarC_Compiler_Util.smap) = + fun projectee -> + match projectee with + | { bvar_bindings; fvar_bindings; depth; tcenv; warn; nolabels; + use_zfuel_name; encode_non_total_function_typ; current_module_name; + encoding_quantifier; global_cache;_} -> global_cache +let (print_env : env_t -> Prims.string) = + fun e -> + let bvars = + FStarC_Compiler_Util.psmap_fold e.bvar_bindings + (fun _k -> + fun pi -> + fun acc -> + FStarC_Compiler_Util.pimap_fold pi + (fun _i -> + fun uu___ -> + fun acc1 -> + match uu___ with + | (x, _term) -> + let uu___1 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_bv x in + uu___1 :: acc1) acc) [] in + let allvars = + FStarC_Compiler_Util.psmap_fold + (FStar_Pervasives_Native.fst e.fvar_bindings) + (fun _k -> fun fvb -> fun acc -> (fvb.fvar_lid) :: acc) [] in + let last_fvar = + match FStarC_Compiler_List.rev allvars with + | [] -> "" + | l::uu___ -> + let uu___1 = FStarC_Class_Show.show FStarC_Ident.showable_lident l in + Prims.strcat "...," uu___1 in + FStarC_Compiler_String.concat ", " (last_fvar :: bvars) +let (lookup_bvar_binding : + env_t -> + FStarC_Syntax_Syntax.bv -> + (FStarC_Syntax_Syntax.bv * FStarC_SMTEncoding_Term.term) + FStar_Pervasives_Native.option) + = + fun env -> + fun bv -> + let uu___ = + let uu___1 = FStarC_Ident.string_of_id bv.FStarC_Syntax_Syntax.ppname in + FStarC_Compiler_Util.psmap_try_find env.bvar_bindings uu___1 in + match uu___ with + | FStar_Pervasives_Native.Some bvs -> + FStarC_Compiler_Util.pimap_try_find bvs + bv.FStarC_Syntax_Syntax.index + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None +let (lookup_fvar_binding : + env_t -> FStarC_Ident.lident -> fvar_binding FStar_Pervasives_Native.option) + = + fun env -> + fun lid -> + let uu___ = FStarC_Ident.string_of_lid lid in + FStarC_Compiler_Util.psmap_try_find + (FStar_Pervasives_Native.fst env.fvar_bindings) uu___ +let add_bvar_binding : + 'uuuuu . + (FStarC_Syntax_Syntax.bv * 'uuuuu) -> + (FStarC_Syntax_Syntax.bv * 'uuuuu) FStarC_Compiler_Util.pimap + FStarC_Compiler_Util.psmap -> + (FStarC_Syntax_Syntax.bv * 'uuuuu) FStarC_Compiler_Util.pimap + FStarC_Compiler_Util.psmap + = + fun bvb -> + fun bvbs -> + let uu___ = + FStarC_Ident.string_of_id + (FStar_Pervasives_Native.fst bvb).FStarC_Syntax_Syntax.ppname in + FStarC_Compiler_Util.psmap_modify bvbs uu___ + (fun pimap_opt -> + let uu___1 = + let uu___2 = FStarC_Compiler_Util.pimap_empty () in + FStarC_Compiler_Util.dflt uu___2 pimap_opt in + FStarC_Compiler_Util.pimap_add uu___1 + (FStar_Pervasives_Native.fst bvb).FStarC_Syntax_Syntax.index bvb) +let (add_fvar_binding : + fvar_binding -> + (fvar_binding FStarC_Compiler_Util.psmap * fvar_binding Prims.list) -> + (fvar_binding FStarC_Compiler_Util.psmap * fvar_binding Prims.list)) + = + fun fvb -> + fun uu___ -> + match uu___ with + | (fvb_map, fvb_list) -> + let uu___1 = + let uu___2 = FStarC_Ident.string_of_lid fvb.fvar_lid in + FStarC_Compiler_Util.psmap_add fvb_map uu___2 fvb in + (uu___1, (fvb :: fvb_list)) +let (fresh_fvar : + Prims.string -> + Prims.string -> + FStarC_SMTEncoding_Term.sort -> + (Prims.string * FStarC_SMTEncoding_Term.term)) + = + fun mname -> + fun x -> + fun s -> + let xsym = varops.fresh mname x in + let uu___ = + let uu___1 = FStarC_SMTEncoding_Term.mk_fv (xsym, s) in + FStarC_SMTEncoding_Util.mkFreeV uu___1 in + (xsym, uu___) +let (gen_term_var : + env_t -> + FStarC_Syntax_Syntax.bv -> + (Prims.string * FStarC_SMTEncoding_Term.term * env_t)) + = + fun env -> + fun x -> + let ysym = Prims.strcat "@x" (Prims.string_of_int env.depth) in + let y = + let uu___ = + FStarC_SMTEncoding_Term.mk_fv + (ysym, FStarC_SMTEncoding_Term.Term_sort) in + FStarC_SMTEncoding_Util.mkFreeV uu___ in + let uu___ = + let uu___1 = add_bvar_binding (x, y) env.bvar_bindings in + let uu___2 = FStarC_TypeChecker_Env.push_bv env.tcenv x in + { + bvar_bindings = uu___1; + fvar_bindings = (env.fvar_bindings); + depth = (env.depth + Prims.int_one); + tcenv = uu___2; + warn = (env.warn); + nolabels = (env.nolabels); + use_zfuel_name = (env.use_zfuel_name); + encode_non_total_function_typ = (env.encode_non_total_function_typ); + current_module_name = (env.current_module_name); + encoding_quantifier = (env.encoding_quantifier); + global_cache = (env.global_cache) + } in + (ysym, y, uu___) +let (new_term_constant : + env_t -> + FStarC_Syntax_Syntax.bv -> + (Prims.string * FStarC_SMTEncoding_Term.term * env_t)) + = + fun env -> + fun x -> + let ysym = + varops.new_var x.FStarC_Syntax_Syntax.ppname + x.FStarC_Syntax_Syntax.index in + let y = FStarC_SMTEncoding_Util.mkApp (ysym, []) in + let uu___ = + let uu___1 = add_bvar_binding (x, y) env.bvar_bindings in + let uu___2 = FStarC_TypeChecker_Env.push_bv env.tcenv x in + { + bvar_bindings = uu___1; + fvar_bindings = (env.fvar_bindings); + depth = (env.depth); + tcenv = uu___2; + warn = (env.warn); + nolabels = (env.nolabels); + use_zfuel_name = (env.use_zfuel_name); + encode_non_total_function_typ = (env.encode_non_total_function_typ); + current_module_name = (env.current_module_name); + encoding_quantifier = (env.encoding_quantifier); + global_cache = (env.global_cache) + } in + (ysym, y, uu___) +let (new_term_constant_from_string : + env_t -> + FStarC_Syntax_Syntax.bv -> + Prims.string -> (Prims.string * FStarC_SMTEncoding_Term.term * env_t)) + = + fun env -> + fun x -> + fun str -> + let ysym = varops.mk_unique str in + let y = FStarC_SMTEncoding_Util.mkApp (ysym, []) in + let uu___ = + let uu___1 = add_bvar_binding (x, y) env.bvar_bindings in + let uu___2 = FStarC_TypeChecker_Env.push_bv env.tcenv x in + { + bvar_bindings = uu___1; + fvar_bindings = (env.fvar_bindings); + depth = (env.depth); + tcenv = uu___2; + warn = (env.warn); + nolabels = (env.nolabels); + use_zfuel_name = (env.use_zfuel_name); + encode_non_total_function_typ = + (env.encode_non_total_function_typ); + current_module_name = (env.current_module_name); + encoding_quantifier = (env.encoding_quantifier); + global_cache = (env.global_cache) + } in + (ysym, y, uu___) +let (push_term_var : + env_t -> FStarC_Syntax_Syntax.bv -> FStarC_SMTEncoding_Term.term -> env_t) + = + fun env -> + fun x -> + fun t -> + let uu___ = add_bvar_binding (x, t) env.bvar_bindings in + let uu___1 = FStarC_TypeChecker_Env.push_bv env.tcenv x in + { + bvar_bindings = uu___; + fvar_bindings = (env.fvar_bindings); + depth = (env.depth); + tcenv = uu___1; + warn = (env.warn); + nolabels = (env.nolabels); + use_zfuel_name = (env.use_zfuel_name); + encode_non_total_function_typ = (env.encode_non_total_function_typ); + current_module_name = (env.current_module_name); + encoding_quantifier = (env.encoding_quantifier); + global_cache = (env.global_cache) + } +let (lookup_term_var : + env_t -> FStarC_Syntax_Syntax.bv -> FStarC_SMTEncoding_Term.term) = + fun env -> + fun a -> + let uu___ = lookup_bvar_binding env a in + match uu___ with + | FStar_Pervasives_Native.Some (b, t) -> t + | FStar_Pervasives_Native.None -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_bv a in + let uu___3 = print_env env in + FStarC_Compiler_Util.format2 + "Bound term variable not found %s in environment: %s" uu___2 + uu___3 in + failwith uu___1 +let (mk_fvb : + FStarC_Ident.lident -> + Prims.string -> + Prims.int -> + FStarC_SMTEncoding_Term.term FStar_Pervasives_Native.option -> + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) + FStar_Pervasives_Native.option -> Prims.bool -> fvar_binding) + = + fun lid -> + fun fname -> + fun arity -> + fun ftok -> + fun fuel_partial_app -> + fun thunked -> + let fvb = + { + fvar_lid = lid; + smt_arity = arity; + smt_id = fname; + smt_token = ftok; + smt_fuel_partial_app = fuel_partial_app; + fvb_thunked = thunked + } in + check_valid_fvb fvb; fvb +let (new_term_constant_and_tok_from_lid_aux : + env_t -> + FStarC_Ident.lident -> + Prims.int -> + Prims.bool -> + (Prims.string * Prims.string FStar_Pervasives_Native.option * + env_t)) + = + fun env -> + fun x -> + fun arity -> + fun thunked -> + let fname = varops.new_fvar x in + let uu___ = + if thunked + then (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) + else + (let ftok_name = Prims.strcat fname "@tok" in + let ftok = FStarC_SMTEncoding_Util.mkApp (ftok_name, []) in + ((FStar_Pervasives_Native.Some ftok_name), + (FStar_Pervasives_Native.Some ftok))) in + match uu___ with + | (ftok_name, ftok) -> + let fvb = + mk_fvb x fname arity ftok FStar_Pervasives_Native.None + thunked in + let uu___1 = + let uu___2 = add_fvar_binding fvb env.fvar_bindings in + { + bvar_bindings = (env.bvar_bindings); + fvar_bindings = uu___2; + depth = (env.depth); + tcenv = (env.tcenv); + warn = (env.warn); + nolabels = (env.nolabels); + use_zfuel_name = (env.use_zfuel_name); + encode_non_total_function_typ = + (env.encode_non_total_function_typ); + current_module_name = (env.current_module_name); + encoding_quantifier = (env.encoding_quantifier); + global_cache = (env.global_cache) + } in + (fname, ftok_name, uu___1) +let (new_term_constant_and_tok_from_lid : + env_t -> + FStarC_Ident.lident -> Prims.int -> (Prims.string * Prims.string * env_t)) + = + fun env -> + fun x -> + fun arity -> + let uu___ = new_term_constant_and_tok_from_lid_aux env x arity false in + match uu___ with + | (fname, ftok_name_opt, env1) -> + let uu___1 = FStarC_Compiler_Option.get ftok_name_opt in + (fname, uu___1, env1) +let (new_term_constant_and_tok_from_lid_maybe_thunked : + env_t -> + FStarC_Ident.lident -> + Prims.int -> + Prims.bool -> + (Prims.string * Prims.string FStar_Pervasives_Native.option * + env_t)) + = + fun env -> + fun x -> + fun arity -> + fun th -> new_term_constant_and_tok_from_lid_aux env x arity th +let fail_fvar_lookup : 'uuuuu . env_t -> FStarC_Ident.lident -> 'uuuuu = + fun env -> + fun a -> + let q = FStarC_TypeChecker_Env.lookup_qname env.tcenv a in + match q with + | FStar_Pervasives_Native.None -> + let uu___ = + let uu___1 = + FStarC_Class_Show.show FStarC_Ident.showable_lident a in + FStarC_Compiler_Util.format1 + "Name %s not found in the smtencoding and typechecker env" + uu___1 in + failwith uu___ + | uu___ -> + let quals = FStarC_TypeChecker_Env.quals_of_qninfo q in + let uu___1 = + (FStarC_Compiler_Util.is_some quals) && + (let uu___2 = FStarC_Compiler_Util.must quals in + FStarC_Compiler_List.contains + FStarC_Syntax_Syntax.Unfold_for_unification_and_vcgen uu___2) in + if uu___1 + then + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Ident.showable_lident a in + FStarC_Compiler_Util.format1 + "Name %s not found in the smtencoding env (the symbol is marked unfold, expected it to reduce)" + uu___3 in + FStarC_Errors.raise_error FStarC_Ident.hasrange_lident a + FStarC_Errors_Codes.Fatal_IdentifierNotFound () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2) + else + (let uu___3 = + let uu___4 = + FStarC_Class_Show.show FStarC_Ident.showable_lident a in + FStarC_Compiler_Util.format1 + "Name %s not found in the smtencoding env" uu___4 in + failwith uu___3) +let (lookup_lid : env_t -> FStarC_Ident.lident -> fvar_binding) = + fun env -> + fun a -> + let uu___ = lookup_fvar_binding env a in + match uu___ with + | FStar_Pervasives_Native.None -> fail_fvar_lookup env a + | FStar_Pervasives_Native.Some s -> (check_valid_fvb s; s) +let (push_free_var_maybe_thunked : + env_t -> + FStarC_Ident.lident -> + Prims.int -> + Prims.string -> + FStarC_SMTEncoding_Term.term FStar_Pervasives_Native.option -> + Prims.bool -> env_t) + = + fun env -> + fun x -> + fun arity -> + fun fname -> + fun ftok -> + fun thunked -> + let fvb = + mk_fvb x fname arity ftok FStar_Pervasives_Native.None + thunked in + let uu___ = add_fvar_binding fvb env.fvar_bindings in + { + bvar_bindings = (env.bvar_bindings); + fvar_bindings = uu___; + depth = (env.depth); + tcenv = (env.tcenv); + warn = (env.warn); + nolabels = (env.nolabels); + use_zfuel_name = (env.use_zfuel_name); + encode_non_total_function_typ = + (env.encode_non_total_function_typ); + current_module_name = (env.current_module_name); + encoding_quantifier = (env.encoding_quantifier); + global_cache = (env.global_cache) + } +let (push_free_var : + env_t -> + FStarC_Ident.lident -> + Prims.int -> + Prims.string -> + FStarC_SMTEncoding_Term.term FStar_Pervasives_Native.option -> + env_t) + = + fun env -> + fun x -> + fun arity -> + fun fname -> + fun ftok -> + push_free_var_maybe_thunked env x arity fname ftok false +let (push_free_var_thunk : + env_t -> + FStarC_Ident.lident -> + Prims.int -> + Prims.string -> + FStarC_SMTEncoding_Term.term FStar_Pervasives_Native.option -> + env_t) + = + fun env -> + fun x -> + fun arity -> + fun fname -> + fun ftok -> + push_free_var_maybe_thunked env x arity fname ftok + (arity = Prims.int_zero) +let (push_zfuel_name : + env_t -> FStarC_Ident.lident -> Prims.string -> Prims.string -> env_t) = + fun env -> + fun x -> + fun f -> + fun ftok -> + let fvb = lookup_lid env x in + let t3 = + let uu___ = + let uu___1 = + let uu___2 = FStarC_SMTEncoding_Util.mkApp ("ZFuel", []) in + [uu___2] in + (f, uu___1) in + FStarC_SMTEncoding_Util.mkApp uu___ in + let t3' = + let uu___ = FStarC_SMTEncoding_Util.mkApp (ftok, []) in + let uu___1 = FStarC_SMTEncoding_Util.mkApp ("ZFuel", []) in + FStarC_SMTEncoding_Term.mk_ApplyTF uu___ uu___1 in + let fvb1 = + mk_fvb x fvb.smt_id fvb.smt_arity fvb.smt_token + (FStar_Pervasives_Native.Some (t3, t3')) false in + let uu___ = add_fvar_binding fvb1 env.fvar_bindings in + { + bvar_bindings = (env.bvar_bindings); + fvar_bindings = uu___; + depth = (env.depth); + tcenv = (env.tcenv); + warn = (env.warn); + nolabels = (env.nolabels); + use_zfuel_name = (env.use_zfuel_name); + encode_non_total_function_typ = + (env.encode_non_total_function_typ); + current_module_name = (env.current_module_name); + encoding_quantifier = (env.encoding_quantifier); + global_cache = (env.global_cache) + } +let (force_thunk : fvar_binding -> FStarC_SMTEncoding_Term.term) = + fun fvb -> + if + (Prims.op_Negation fvb.fvb_thunked) || + (fvb.smt_arity <> Prims.int_zero) + then failwith "Forcing a non-thunk in the SMT encoding" + else (); + FStarC_SMTEncoding_Util.mkFreeV + (FStarC_SMTEncoding_Term.FV + ((fvb.smt_id), FStarC_SMTEncoding_Term.Term_sort, true)) +let (try_lookup_free_var : + env_t -> + FStarC_Ident.lident -> + FStarC_SMTEncoding_Term.term FStar_Pervasives_Native.option) + = + fun env -> + fun l -> + let uu___ = lookup_fvar_binding env l in + match uu___ with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some fvb -> + ((let uu___2 = FStarC_Compiler_Effect.op_Bang dbg_PartialApp in + if uu___2 + then + let uu___3 = FStarC_Ident.string_of_lid l in + let uu___4 = fvb_to_string fvb in + FStarC_Compiler_Util.print2 "Looked up %s found\n%s\n" uu___3 + uu___4 + else ()); + if fvb.fvb_thunked + then + (let uu___2 = force_thunk fvb in + FStar_Pervasives_Native.Some uu___2) + else + (match fvb.smt_fuel_partial_app with + | FStar_Pervasives_Native.Some (uu___3, f) when + env.use_zfuel_name -> FStar_Pervasives_Native.Some f + | uu___3 -> + (match fvb.smt_token with + | FStar_Pervasives_Native.Some t -> + (match t.FStarC_SMTEncoding_Term.tm with + | FStarC_SMTEncoding_Term.App (uu___4, fuel::[]) -> + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_SMTEncoding_Term.fv_of_term fuel in + FStarC_SMTEncoding_Term.fv_name uu___7 in + FStarC_Compiler_Util.starts_with uu___6 "fuel" in + if uu___5 + then + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_SMTEncoding_Term.mk_fv + ((fvb.smt_id), + FStarC_SMTEncoding_Term.Term_sort) in + FStarC_SMTEncoding_Util.mkFreeV uu___8 in + FStarC_SMTEncoding_Term.mk_ApplyTF uu___7 + fuel in + FStar_Pervasives_Native.Some uu___6 + else FStar_Pervasives_Native.Some t + | uu___4 -> FStar_Pervasives_Native.Some t) + | uu___4 -> FStar_Pervasives_Native.None))) +let (lookup_free_var : + env_t -> + FStarC_Ident.lident FStarC_Syntax_Syntax.withinfo_t -> + FStarC_SMTEncoding_Term.term) + = + fun env -> + fun a -> + let uu___ = try_lookup_free_var env a.FStarC_Syntax_Syntax.v in + match uu___ with + | FStar_Pervasives_Native.Some t -> t + | FStar_Pervasives_Native.None -> + fail_fvar_lookup env a.FStarC_Syntax_Syntax.v +let (lookup_free_var_name : + env_t -> + FStarC_Ident.lident FStarC_Syntax_Syntax.withinfo_t -> fvar_binding) + = fun env -> fun a -> lookup_lid env a.FStarC_Syntax_Syntax.v +let (lookup_free_var_sym : + env_t -> + FStarC_Ident.lident FStarC_Syntax_Syntax.withinfo_t -> + ((FStarC_SMTEncoding_Term.op, FStarC_SMTEncoding_Term.term) + FStar_Pervasives.either * FStarC_SMTEncoding_Term.term Prims.list * + Prims.int)) + = + fun env -> + fun a -> + let fvb = lookup_lid env a.FStarC_Syntax_Syntax.v in + match fvb.smt_fuel_partial_app with + | FStar_Pervasives_Native.Some + ({ + FStarC_SMTEncoding_Term.tm = FStarC_SMTEncoding_Term.App (g, zf); + FStarC_SMTEncoding_Term.freevars = uu___; + FStarC_SMTEncoding_Term.rng = uu___1;_}, + uu___2) + when env.use_zfuel_name -> + ((FStar_Pervasives.Inl g), zf, (fvb.smt_arity + Prims.int_one)) + | uu___ -> + (match fvb.smt_token with + | FStar_Pervasives_Native.None when fvb.fvb_thunked -> + let uu___1 = + let uu___2 = force_thunk fvb in FStar_Pervasives.Inr uu___2 in + (uu___1, [], (fvb.smt_arity)) + | FStar_Pervasives_Native.None -> + ((FStar_Pervasives.Inl + (FStarC_SMTEncoding_Term.Var (fvb.smt_id))), [], + (fvb.smt_arity)) + | FStar_Pervasives_Native.Some sym -> + (match sym.FStarC_SMTEncoding_Term.tm with + | FStarC_SMTEncoding_Term.App (g, fuel::[]) -> + ((FStar_Pervasives.Inl g), [fuel], + (fvb.smt_arity + Prims.int_one)) + | uu___1 -> + ((FStar_Pervasives.Inl + (FStarC_SMTEncoding_Term.Var (fvb.smt_id))), [], + (fvb.smt_arity)))) +let (tok_of_name : + env_t -> + Prims.string -> + FStarC_SMTEncoding_Term.term FStar_Pervasives_Native.option) + = + fun env -> + fun nm -> + let uu___ = + FStarC_Compiler_Util.psmap_find_map + (FStar_Pervasives_Native.fst env.fvar_bindings) + (fun uu___1 -> + fun fvb -> + check_valid_fvb fvb; + if fvb.smt_id = nm + then fvb.smt_token + else FStar_Pervasives_Native.None) in + match uu___ with + | FStar_Pervasives_Native.Some b -> FStar_Pervasives_Native.Some b + | FStar_Pervasives_Native.None -> + FStarC_Compiler_Util.psmap_find_map env.bvar_bindings + (fun uu___1 -> + fun pi -> + FStarC_Compiler_Util.pimap_fold pi + (fun uu___2 -> + fun y -> + fun res -> + match (res, y) with + | (FStar_Pervasives_Native.Some uu___3, uu___4) -> + res + | (FStar_Pervasives_Native.None, + (uu___3, + { + FStarC_SMTEncoding_Term.tm = + FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Var sym, []); + FStarC_SMTEncoding_Term.freevars = uu___4; + FStarC_SMTEncoding_Term.rng = uu___5;_})) + when sym = nm -> + FStar_Pervasives_Native.Some + (FStar_Pervasives_Native.snd y) + | uu___3 -> FStar_Pervasives_Native.None) + FStar_Pervasives_Native.None) +let (reset_current_module_fvbs : env_t -> env_t) = + fun env -> + { + bvar_bindings = (env.bvar_bindings); + fvar_bindings = ((FStar_Pervasives_Native.fst env.fvar_bindings), []); + depth = (env.depth); + tcenv = (env.tcenv); + warn = (env.warn); + nolabels = (env.nolabels); + use_zfuel_name = (env.use_zfuel_name); + encode_non_total_function_typ = (env.encode_non_total_function_typ); + current_module_name = (env.current_module_name); + encoding_quantifier = (env.encoding_quantifier); + global_cache = (env.global_cache) + } +let (get_current_module_fvbs : env_t -> fvar_binding Prims.list) = + fun env -> FStar_Pervasives_Native.snd env.fvar_bindings +let (add_fvar_binding_to_env : fvar_binding -> env_t -> env_t) = + fun fvb -> + fun env -> + let uu___ = add_fvar_binding fvb env.fvar_bindings in + { + bvar_bindings = (env.bvar_bindings); + fvar_bindings = uu___; + depth = (env.depth); + tcenv = (env.tcenv); + warn = (env.warn); + nolabels = (env.nolabels); + use_zfuel_name = (env.use_zfuel_name); + encode_non_total_function_typ = (env.encode_non_total_function_typ); + current_module_name = (env.current_module_name); + encoding_quantifier = (env.encoding_quantifier); + global_cache = (env.global_cache) + } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_SMTEncoding_ErrorReporting.ml b/ocaml/fstar-lib/generated/FStarC_SMTEncoding_ErrorReporting.ml new file mode 100644 index 00000000000..b858a5bbe14 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_SMTEncoding_ErrorReporting.ml @@ -0,0 +1,882 @@ +open Prims +type label = FStarC_SMTEncoding_Term.error_label +type labels = label Prims.list +exception Not_a_wp_implication of Prims.string +let (uu___is_Not_a_wp_implication : Prims.exn -> Prims.bool) = + fun projectee -> + match projectee with + | Not_a_wp_implication uu___ -> true + | uu___ -> false +let (__proj__Not_a_wp_implication__item__uu___ : Prims.exn -> Prims.string) = + fun projectee -> match projectee with | Not_a_wp_implication uu___ -> uu___ +let (sort_labels : + (FStarC_SMTEncoding_Term.error_label * Prims.bool) Prims.list -> + ((FStarC_SMTEncoding_Term.fv * FStarC_Errors_Msg.error_message * + FStarC_Compiler_Range_Type.range) * Prims.bool) Prims.list) + = + fun l -> + FStarC_Compiler_List.sortWith + (fun uu___ -> + fun uu___1 -> + match (uu___, uu___1) with + | (((uu___2, uu___3, r1), uu___4), ((uu___5, uu___6, r2), uu___7)) + -> FStarC_Compiler_Range_Ops.compare r1 r2) l +let (remove_dups : + labels -> + (FStarC_SMTEncoding_Term.fv * FStarC_Errors_Msg.error_message * + FStarC_Compiler_Range_Type.range) Prims.list) + = + fun l -> + FStarC_Compiler_Util.remove_dups + (fun uu___ -> + fun uu___1 -> + match (uu___, uu___1) with + | ((uu___2, m1, r1), (uu___3, m2, r2)) -> (r1 = r2) && (m1 = m2)) + l +type msg = (Prims.string * FStarC_Compiler_Range_Type.range) +type ranges = + (Prims.string FStar_Pervasives_Native.option * + FStarC_Compiler_Range_Type.range) Prims.list +let (__ctr : Prims.int FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref Prims.int_zero +let (fresh_label : + FStarC_Errors_Msg.error_message -> + FStarC_Compiler_Range_Type.range -> + FStarC_SMTEncoding_Term.term -> (label * FStarC_SMTEncoding_Term.term)) + = + fun message -> + fun range -> + fun t -> + let l = + FStarC_Compiler_Util.incr __ctr; + (let uu___1 = + let uu___2 = FStarC_Compiler_Effect.op_Bang __ctr in + FStarC_Compiler_Util.string_of_int uu___2 in + FStarC_Compiler_Util.format1 "label_%s" uu___1) in + let lvar = + FStarC_SMTEncoding_Term.mk_fv + (l, FStarC_SMTEncoding_Term.Bool_sort) in + let label1 = (lvar, message, range) in + let lterm = FStarC_SMTEncoding_Util.mkFreeV lvar in + let lt = FStarC_SMTEncoding_Term.mkOr (lterm, t) range in + (label1, lt) +let (label_goals : + (unit -> Prims.string) FStar_Pervasives_Native.option -> + FStarC_Compiler_Range_Type.range -> + FStarC_SMTEncoding_Term.term -> (labels * FStarC_SMTEncoding_Term.term)) + = + fun use_env_msg -> + fun r -> + fun q -> + let rec is_a_post_condition post_name_opt tm = + match (post_name_opt, (tm.FStarC_SMTEncoding_Term.tm)) with + | (FStar_Pervasives_Native.None, uu___) -> false + | (FStar_Pervasives_Native.Some nm, FStarC_SMTEncoding_Term.FreeV + fv) -> + let uu___ = FStarC_SMTEncoding_Term.fv_name fv in nm = uu___ + | (uu___, FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Var "Valid", tm1::[])) -> + is_a_post_condition post_name_opt tm1 + | (uu___, FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Var "ApplyTT", tm1::uu___1)) -> + is_a_post_condition post_name_opt tm1 + | uu___ -> false in + let conjuncts t = + match t.FStarC_SMTEncoding_Term.tm with + | FStarC_SMTEncoding_Term.App (FStarC_SMTEncoding_Term.And, cs) -> + cs + | uu___ -> [t] in + let is_guard_free tm = + match tm.FStarC_SMTEncoding_Term.tm with + | FStarC_SMTEncoding_Term.Quant + (FStarC_SMTEncoding_Term.Forall, + ({ + FStarC_SMTEncoding_Term.tm = FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Var "Prims.guard_free", p::[]); + FStarC_SMTEncoding_Term.freevars = uu___; + FStarC_SMTEncoding_Term.rng = uu___1;_}::[])::[], + iopt, uu___2, + { + FStarC_SMTEncoding_Term.tm = FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Imp, l::r1::[]); + FStarC_SMTEncoding_Term.freevars = uu___3; + FStarC_SMTEncoding_Term.rng = uu___4;_}) + -> true + | uu___ -> false in + let is_a_named_continuation lhs = + FStarC_Compiler_Util.for_some is_guard_free (conjuncts lhs) in + let uu___ = + match use_env_msg with + | FStar_Pervasives_Native.None -> (false, FStarC_Pprint.empty) + | FStar_Pervasives_Native.Some f -> + let uu___1 = + let uu___2 = f () in FStarC_Pprint.doc_of_string uu___2 in + (true, uu___1) in + match uu___ with + | (flag, msg_prefix) -> + let fresh_label1 msg1 ropt rng t = + let msg2 = + if flag + then + let uu___1 = + let uu___2 = + FStarC_Errors_Msg.text + "Failed to verify implicit argument: " in + FStarC_Pprint.op_Hat_Hat uu___2 msg_prefix in + uu___1 :: msg1 + else msg1 in + let rng1 = + match ropt with + | FStar_Pervasives_Native.None -> rng + | FStar_Pervasives_Native.Some r1 -> + let uu___1 = + let uu___2 = FStarC_Compiler_Range_Type.use_range rng in + let uu___3 = FStarC_Compiler_Range_Type.use_range r1 in + FStarC_Compiler_Range_Ops.rng_included uu___2 uu___3 in + if uu___1 + then rng + else + (let uu___3 = FStarC_Compiler_Range_Type.def_range rng in + FStarC_Compiler_Range_Type.set_def_range r1 uu___3) in + fresh_label msg2 rng1 t in + let rec aux default_msg ropt post_name_opt labels1 q1 = + match q1.FStarC_SMTEncoding_Term.tm with + | FStarC_SMTEncoding_Term.BoundV uu___1 -> (labels1, q1) + | FStarC_SMTEncoding_Term.Integer uu___1 -> (labels1, q1) + | FStarC_SMTEncoding_Term.String uu___1 -> (labels1, q1) + | FStarC_SMTEncoding_Term.Real uu___1 -> (labels1, q1) + | FStarC_SMTEncoding_Term.LblPos uu___1 -> + failwith "Impossible" + | FStarC_SMTEncoding_Term.Labeled (arg, d::[], label_range) + when + let uu___1 = FStarC_Errors_Msg.renderdoc d in + uu___1 = "Could not prove post-condition" -> + let fallback debug_msg = + aux default_msg + (FStar_Pervasives_Native.Some label_range) + post_name_opt labels1 arg in + (try + (fun uu___1 -> + match () with + | () -> + (match arg.FStarC_SMTEncoding_Term.tm with + | FStarC_SMTEncoding_Term.Quant + (FStarC_SMTEncoding_Term.Forall, pats, iopt, + post::sorts, + { + FStarC_SMTEncoding_Term.tm = + FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Imp, + lhs::rhs::[]); + FStarC_SMTEncoding_Term.freevars = uu___2; + FStarC_SMTEncoding_Term.rng = rng;_}) + -> + let post_name = + let uu___3 = + let uu___4 = FStarC_GenSym.next_id () in + FStarC_Compiler_Util.string_of_int + uu___4 in + Prims.strcat "^^post_condition_" uu___3 in + let names = + let uu___3 = + FStarC_SMTEncoding_Term.mk_fv + (post_name, post) in + let uu___4 = + FStarC_Compiler_List.map + (fun s -> + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_GenSym.next_id () in + FStarC_Compiler_Util.string_of_int + uu___8 in + Prims.strcat "^^" uu___7 in + (uu___6, s) in + FStarC_SMTEncoding_Term.mk_fv + uu___5) sorts in + uu___3 :: uu___4 in + let instantiation = + FStarC_Compiler_List.map + FStarC_SMTEncoding_Util.mkFreeV names in + let uu___3 = + let uu___4 = + FStarC_SMTEncoding_Term.inst + instantiation lhs in + let uu___5 = + FStarC_SMTEncoding_Term.inst + instantiation rhs in + (uu___4, uu___5) in + (match uu___3 with + | (lhs1, rhs1) -> + let uu___4 = + match lhs1.FStarC_SMTEncoding_Term.tm + with + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.And, + clauses_lhs) + -> + let uu___5 = + FStarC_Compiler_Util.prefix + clauses_lhs in + (match uu___5 with + | (req, ens) -> + (match ens.FStarC_SMTEncoding_Term.tm + with + | FStarC_SMTEncoding_Term.Quant + (FStarC_SMTEncoding_Term.Forall, + pats_ens, iopt_ens, + sorts_ens, + { + FStarC_SMTEncoding_Term.tm + = + FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Imp, + ensures_conjuncts::post1::[]); + FStarC_SMTEncoding_Term.freevars + = uu___6; + FStarC_SMTEncoding_Term.rng + = rng_ens;_}) + -> + let uu___7 = + is_a_post_condition + (FStar_Pervasives_Native.Some + post_name) post1 in + if uu___7 + then + let uu___8 = + let uu___9 = + FStarC_Errors_Msg.mkmsg + "Could not prove post-condition" in + aux uu___9 + FStar_Pervasives_Native.None + (FStar_Pervasives_Native.Some + post_name) + labels1 + ensures_conjuncts in + (match uu___8 with + | (labels2, + ensures_conjuncts1) + -> + let pats_ens1 = + match pats_ens + with + | [] -> + [[post1]] + | []::[] -> + [[post1]] + | uu___9 -> + pats_ens in + let ens1 = + let uu___9 = + let uu___10 + = + let uu___11 + = + FStarC_SMTEncoding_Term.mk + (FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Imp, + [ensures_conjuncts1; + post1])) + rng_ens in + (FStarC_SMTEncoding_Term.Forall, + pats_ens1, + iopt_ens, + sorts_ens, + uu___11) in + FStarC_SMTEncoding_Term.Quant + uu___10 in + FStarC_SMTEncoding_Term.mk + uu___9 + ens.FStarC_SMTEncoding_Term.rng in + let lhs2 = + FStarC_SMTEncoding_Term.mk + (FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.And, + (FStarC_Compiler_List.op_At + req + [ens1]))) + lhs1.FStarC_SMTEncoding_Term.rng in + let uu___9 = + FStarC_SMTEncoding_Term.abstr + names lhs2 in + (labels2, + uu___9)) + else + (let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 + = + FStarC_SMTEncoding_Term.print_smt_term + post1 in + Prims.strcat + " ... " + uu___13 in + Prims.strcat + post_name + uu___12 in + Prims.strcat + "Ensures clause doesn't match post name: " + uu___11 in + Not_a_wp_implication + uu___10 in + FStarC_Compiler_Effect.raise + uu___9) + | uu___6 -> + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_SMTEncoding_Term.print_smt_term + ens in + Prims.strcat + " ... " + uu___11 in + Prims.strcat + post_name + uu___10 in + Prims.strcat + "Ensures clause doesn't have the expected shape for post-condition " + uu___9 in + Not_a_wp_implication + uu___8 in + FStarC_Compiler_Effect.raise + uu___7)) + | uu___5 -> + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_SMTEncoding_Term.print_smt_term + lhs1 in + Prims.strcat + "LHS not a conjunct: " + uu___8 in + Not_a_wp_implication uu___7 in + FStarC_Compiler_Effect.raise + uu___6 in + (match uu___4 with + | (labels2, lhs2) -> + let uu___5 = + let uu___6 = + aux default_msg + FStar_Pervasives_Native.None + (FStar_Pervasives_Native.Some + post_name) labels2 rhs1 in + match uu___6 with + | (labels3, rhs2) -> + let uu___7 = + FStarC_SMTEncoding_Term.abstr + names rhs2 in + (labels3, uu___7) in + (match uu___5 with + | (labels3, rhs2) -> + let body = + FStarC_SMTEncoding_Term.mkImp + (lhs2, rhs2) rng in + let uu___6 = + FStarC_SMTEncoding_Term.mk + (FStarC_SMTEncoding_Term.Quant + (FStarC_SMTEncoding_Term.Forall, + pats, iopt, (post :: + sorts), body)) + q1.FStarC_SMTEncoding_Term.rng in + (labels3, uu___6)))) + | uu___2 -> fallback "arg not a quant: ")) () + with | Not_a_wp_implication msg1 -> fallback msg1) + | FStarC_SMTEncoding_Term.Labeled (arg, reason, r1) -> + aux reason (FStar_Pervasives_Native.Some r1) post_name_opt + labels1 arg + | FStarC_SMTEncoding_Term.Quant + (FStarC_SMTEncoding_Term.Forall, [], + FStar_Pervasives_Native.None, sorts, + { + FStarC_SMTEncoding_Term.tm = FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Imp, lhs::rhs::[]); + FStarC_SMTEncoding_Term.freevars = uu___1; + FStarC_SMTEncoding_Term.rng = rng;_}) + when is_a_named_continuation lhs -> + let uu___2 = FStarC_Compiler_Util.prefix sorts in + (match uu___2 with + | (sorts', post) -> + let new_post_name = + let uu___3 = + let uu___4 = FStarC_GenSym.next_id () in + FStarC_Compiler_Util.string_of_int uu___4 in + Prims.strcat "^^post_condition_" uu___3 in + let names = + let uu___3 = + FStarC_Compiler_List.map + (fun s -> + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = FStarC_GenSym.next_id () in + FStarC_Compiler_Util.string_of_int + uu___7 in + Prims.strcat "^^" uu___6 in + (uu___5, s) in + FStarC_SMTEncoding_Term.mk_fv uu___4) sorts' in + let uu___4 = + let uu___5 = + FStarC_SMTEncoding_Term.mk_fv + (new_post_name, post) in + [uu___5] in + FStarC_Compiler_List.op_At uu___3 uu___4 in + let instantiation = + FStarC_Compiler_List.map + FStarC_SMTEncoding_Util.mkFreeV names in + let uu___3 = + let uu___4 = + FStarC_SMTEncoding_Term.inst instantiation lhs in + let uu___5 = + FStarC_SMTEncoding_Term.inst instantiation rhs in + (uu___4, uu___5) in + (match uu___3 with + | (lhs1, rhs1) -> + let uu___4 = + FStarC_Compiler_Util.fold_map + (fun labels2 -> + fun tm -> + match tm.FStarC_SMTEncoding_Term.tm with + | FStarC_SMTEncoding_Term.Quant + (FStarC_SMTEncoding_Term.Forall, + ({ + FStarC_SMTEncoding_Term.tm = + FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Var + "Prims.guard_free", p::[]); + FStarC_SMTEncoding_Term.freevars + = uu___5; + FStarC_SMTEncoding_Term.rng = + uu___6;_}::[])::[], + iopt, sorts1, + { + FStarC_SMTEncoding_Term.tm = + FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Imp, + l0::r1::[]); + FStarC_SMTEncoding_Term.freevars + = uu___7; + FStarC_SMTEncoding_Term.rng = + uu___8;_}) + -> + let uu___9 = + is_a_post_condition + (FStar_Pervasives_Native.Some + new_post_name) r1 in + if uu___9 + then + let uu___10 = + aux default_msg + FStar_Pervasives_Native.None + post_name_opt labels2 l0 in + (match uu___10 with + | (labels3, l) -> + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_SMTEncoding_Util.norng + FStarC_SMTEncoding_Term.mk + (FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Imp, + [l; r1])) in + (FStarC_SMTEncoding_Term.Forall, + [[p]], + (FStar_Pervasives_Native.Some + Prims.int_zero), + sorts1, uu___14) in + FStarC_SMTEncoding_Term.Quant + uu___13 in + FStarC_SMTEncoding_Term.mk + uu___12 + q1.FStarC_SMTEncoding_Term.rng in + (labels3, uu___11)) + else (labels2, tm) + | uu___5 -> (labels2, tm)) labels1 + (conjuncts lhs1) in + (match uu___4 with + | (labels2, lhs_conjs) -> + let uu___5 = + aux default_msg + FStar_Pervasives_Native.None + (FStar_Pervasives_Native.Some + new_post_name) labels2 rhs1 in + (match uu___5 with + | (labels3, rhs2) -> + let body = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_SMTEncoding_Term.mk_and_l + lhs_conjs + lhs1.FStarC_SMTEncoding_Term.rng in + (uu___8, rhs2) in + FStarC_SMTEncoding_Term.mkImp + uu___7 rng in + FStarC_SMTEncoding_Term.abstr names + uu___6 in + let q2 = + FStarC_SMTEncoding_Term.mk + (FStarC_SMTEncoding_Term.Quant + (FStarC_SMTEncoding_Term.Forall, + [], + FStar_Pervasives_Native.None, + sorts, body)) + q1.FStarC_SMTEncoding_Term.rng in + (labels3, q2))))) + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Imp, lhs::rhs::[]) -> + let uu___1 = aux default_msg ropt post_name_opt labels1 rhs in + (match uu___1 with + | (labels2, rhs1) -> + let uu___2 = FStarC_SMTEncoding_Util.mkImp (lhs, rhs1) in + (labels2, uu___2)) + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.And, conjuncts1) -> + let uu___1 = + FStarC_Compiler_Util.fold_map + (aux default_msg ropt post_name_opt) labels1 conjuncts1 in + (match uu___1 with + | (labels2, conjuncts2) -> + let uu___2 = + FStarC_SMTEncoding_Term.mk_and_l conjuncts2 + q1.FStarC_SMTEncoding_Term.rng in + (labels2, uu___2)) + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.ITE, hd::q11::q2::[]) -> + let uu___1 = aux default_msg ropt post_name_opt labels1 q11 in + (match uu___1 with + | (labels2, q12) -> + let uu___2 = + aux default_msg ropt post_name_opt labels2 q2 in + (match uu___2 with + | (labels3, q21) -> + let uu___3 = + FStarC_SMTEncoding_Term.mkITE (hd, q12, q21) + q1.FStarC_SMTEncoding_Term.rng in + (labels3, uu___3))) + | FStarC_SMTEncoding_Term.Quant + (FStarC_SMTEncoding_Term.Exists, uu___1, uu___2, uu___3, + uu___4) + -> + let uu___5 = + fresh_label1 default_msg ropt + q1.FStarC_SMTEncoding_Term.rng q1 in + (match uu___5 with | (lab, q2) -> ((lab :: labels1), q2)) + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Iff, uu___1) -> + let uu___2 = + fresh_label1 default_msg ropt + q1.FStarC_SMTEncoding_Term.rng q1 in + (match uu___2 with | (lab, q2) -> ((lab :: labels1), q2)) + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Or, uu___1) -> + let uu___2 = + fresh_label1 default_msg ropt + q1.FStarC_SMTEncoding_Term.rng q1 in + (match uu___2 with | (lab, q2) -> ((lab :: labels1), q2)) + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Var "Unreachable", uu___1) -> + (labels1, q1) + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Var uu___1, uu___2) when + is_a_post_condition post_name_opt q1 -> (labels1, q1) + | FStarC_SMTEncoding_Term.FreeV uu___1 -> + let uu___2 = + fresh_label1 default_msg ropt + q1.FStarC_SMTEncoding_Term.rng q1 in + (match uu___2 with | (lab, q2) -> ((lab :: labels1), q2)) + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.TrueOp, uu___1) -> + let uu___2 = + fresh_label1 default_msg ropt + q1.FStarC_SMTEncoding_Term.rng q1 in + (match uu___2 with | (lab, q2) -> ((lab :: labels1), q2)) + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.FalseOp, uu___1) -> + let uu___2 = + fresh_label1 default_msg ropt + q1.FStarC_SMTEncoding_Term.rng q1 in + (match uu___2 with | (lab, q2) -> ((lab :: labels1), q2)) + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Not, uu___1) -> + let uu___2 = + fresh_label1 default_msg ropt + q1.FStarC_SMTEncoding_Term.rng q1 in + (match uu___2 with | (lab, q2) -> ((lab :: labels1), q2)) + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Eq, uu___1) -> + let uu___2 = + fresh_label1 default_msg ropt + q1.FStarC_SMTEncoding_Term.rng q1 in + (match uu___2 with | (lab, q2) -> ((lab :: labels1), q2)) + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.LT, uu___1) -> + let uu___2 = + fresh_label1 default_msg ropt + q1.FStarC_SMTEncoding_Term.rng q1 in + (match uu___2 with | (lab, q2) -> ((lab :: labels1), q2)) + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.LTE, uu___1) -> + let uu___2 = + fresh_label1 default_msg ropt + q1.FStarC_SMTEncoding_Term.rng q1 in + (match uu___2 with | (lab, q2) -> ((lab :: labels1), q2)) + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.GT, uu___1) -> + let uu___2 = + fresh_label1 default_msg ropt + q1.FStarC_SMTEncoding_Term.rng q1 in + (match uu___2 with | (lab, q2) -> ((lab :: labels1), q2)) + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.GTE, uu___1) -> + let uu___2 = + fresh_label1 default_msg ropt + q1.FStarC_SMTEncoding_Term.rng q1 in + (match uu___2 with | (lab, q2) -> ((lab :: labels1), q2)) + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.BvUlt, uu___1) -> + let uu___2 = + fresh_label1 default_msg ropt + q1.FStarC_SMTEncoding_Term.rng q1 in + (match uu___2 with | (lab, q2) -> ((lab :: labels1), q2)) + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Var uu___1, uu___2) -> + let uu___3 = + fresh_label1 default_msg ropt + q1.FStarC_SMTEncoding_Term.rng q1 in + (match uu___3 with | (lab, q2) -> ((lab :: labels1), q2)) + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.RealDiv, uu___1) -> + failwith "Impossible: non-propositional term" + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Add, uu___1) -> + failwith "Impossible: non-propositional term" + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Sub, uu___1) -> + failwith "Impossible: non-propositional term" + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Div, uu___1) -> + failwith "Impossible: non-propositional term" + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Mul, uu___1) -> + failwith "Impossible: non-propositional term" + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Minus, uu___1) -> + failwith "Impossible: non-propositional term" + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Mod, uu___1) -> + failwith "Impossible: non-propositional term" + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.BvAnd, uu___1) -> + failwith "Impossible: non-propositional term" + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.BvXor, uu___1) -> + failwith "Impossible: non-propositional term" + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.BvOr, uu___1) -> + failwith "Impossible: non-propositional term" + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.BvAdd, uu___1) -> + failwith "Impossible: non-propositional term" + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.BvSub, uu___1) -> + failwith "Impossible: non-propositional term" + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.BvShl, uu___1) -> + failwith "Impossible: non-propositional term" + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.BvShr, uu___1) -> + failwith "Impossible: non-propositional term" + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.BvUdiv, uu___1) -> + failwith "Impossible: non-propositional term" + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.BvMod, uu___1) -> + failwith "Impossible: non-propositional term" + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.BvMul, uu___1) -> + failwith "Impossible: non-propositional term" + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.BvUext uu___1, uu___2) -> + failwith "Impossible: non-propositional term" + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.BvToNat, uu___1) -> + failwith "Impossible: non-propositional term" + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.NatToBv uu___1, uu___2) -> + failwith "Impossible: non-propositional term" + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.ITE, uu___1) -> + failwith "Impossible: arity mismatch" + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Imp, uu___1) -> + failwith "Impossible: arity mismatch" + | FStarC_SMTEncoding_Term.Quant + (FStarC_SMTEncoding_Term.Forall, pats, iopt, sorts, body) + -> + let uu___1 = + aux default_msg ropt post_name_opt labels1 body in + (match uu___1 with + | (labels2, body1) -> + let uu___2 = + FStarC_SMTEncoding_Term.mk + (FStarC_SMTEncoding_Term.Quant + (FStarC_SMTEncoding_Term.Forall, pats, iopt, + sorts, body1)) q1.FStarC_SMTEncoding_Term.rng in + (labels2, uu___2)) + | FStarC_SMTEncoding_Term.Let (es, body) -> + let uu___1 = + aux default_msg ropt post_name_opt labels1 body in + (match uu___1 with + | (labels2, body1) -> + let uu___2 = + FStarC_SMTEncoding_Term.mkLet (es, body1) + q1.FStarC_SMTEncoding_Term.rng in + (labels2, uu___2)) in + (FStarC_Compiler_Effect.op_Colon_Equals __ctr Prims.int_zero; + (let uu___2 = FStarC_Errors_Msg.mkmsg "Assertion failed" in + aux uu___2 FStar_Pervasives_Native.None + FStar_Pervasives_Native.None [] q)) +let (detail_errors : + Prims.bool -> + FStarC_TypeChecker_Env.env -> + labels -> + (FStarC_SMTEncoding_Term.decl Prims.list -> + FStarC_SMTEncoding_Z3.z3result) + -> unit) + = + fun hint_replay -> + fun env -> + fun all_labels -> + fun askZ3 -> + let print_banner uu___ = + let msg1 = + let uu___1 = + let uu___2 = FStarC_TypeChecker_Env.get_range env in + FStarC_Compiler_Range_Ops.string_of_range uu___2 in + let uu___2 = + FStarC_Compiler_Util.string_of_int (Prims.of_int (5)) in + let uu___3 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length all_labels) in + FStarC_Compiler_Util.format4 + "Detailed %s report follows for %s\nTaking %s seconds per proof obligation (%s proofs in total)\n" + (if hint_replay then "hint replay" else "error") uu___1 + uu___2 uu___3 in + FStarC_Compiler_Util.print_error msg1 in + let print_result uu___ = + match uu___ with + | ((uu___1, msg1, r), success) -> + if success + then + let uu___2 = FStarC_Compiler_Range_Ops.string_of_range r in + FStarC_Compiler_Util.print1 + "OK: proof obligation at %s was proven in isolation\n" + uu___2 + else + if hint_replay + then + (let uu___3 = + let uu___4 = + FStarC_Errors_Msg.text + "Hint failed to replay this sub-proof" in + uu___4 :: msg1 in + FStarC_Errors.log_issue + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Warning_HintFailedToReplayProof () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___3)) + else + (let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Class_Show.show + FStarC_Compiler_Range_Ops.showable_range r in + FStarC_Compiler_Util.format1 + "XX: proof obligation at %s failed." uu___8 in + FStarC_Errors_Msg.text uu___7 in + [uu___6] in + FStarC_Compiler_List.op_At uu___5 msg1 in + FStarC_Errors.log_issue + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Error_ProofObligationFailed () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___4)) in + let elim labs = + FStarC_Compiler_List.map + (fun uu___ -> + match uu___ with + | (l, uu___1, uu___2) -> + let tm = + let uu___3 = + let uu___4 = FStarC_SMTEncoding_Util.mkFreeV l in + (uu___4, FStarC_SMTEncoding_Util.mkTrue) in + FStarC_SMTEncoding_Util.mkEq uu___3 in + let a = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_SMTEncoding_Util.mkFreeV l in + (uu___5, FStarC_SMTEncoding_Util.mkTrue) in + FStarC_SMTEncoding_Util.mkEq uu___4 in + let uu___4 = + let uu___5 = FStarC_SMTEncoding_Term.fv_name l in + Prims.strcat "@disable_label_" uu___5 in + let uu___5 = + FStarC_SMTEncoding_Term.free_top_level_names tm in + { + FStarC_SMTEncoding_Term.assumption_term = uu___3; + FStarC_SMTEncoding_Term.assumption_caption = + (FStar_Pervasives_Native.Some "Disabling label"); + FStarC_SMTEncoding_Term.assumption_name = uu___4; + FStarC_SMTEncoding_Term.assumption_fact_ids = []; + FStarC_SMTEncoding_Term.assumption_free_names = + uu___5 + } in + FStarC_SMTEncoding_Term.Assume a) labs in + let rec linear_check eliminated errors active = + FStarC_SMTEncoding_Z3.refresh + (FStar_Pervasives_Native.Some + (env.FStarC_TypeChecker_Env.proof_ns)); + (match active with + | [] -> + let results = + let uu___1 = + FStarC_Compiler_List.map (fun x -> (x, true)) eliminated in + let uu___2 = + FStarC_Compiler_List.map (fun x -> (x, false)) errors in + FStarC_Compiler_List.op_At uu___1 uu___2 in + sort_labels results + | hd::tl -> + ((let uu___2 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length active) in + FStarC_Compiler_Util.print1 "%s, " uu___2); + (let decls = + elim + (FStarC_Compiler_List.op_At eliminated + (FStarC_Compiler_List.op_At errors tl)) in + let result = askZ3 decls in + match result.FStarC_SMTEncoding_Z3.z3result_status with + | FStarC_SMTEncoding_Z3.UNSAT uu___2 -> + linear_check (hd :: eliminated) errors tl + | uu___2 -> linear_check eliminated (hd :: errors) tl))) in + print_banner (); + FStarC_Options.set_option "z3rlimit" + (FStarC_Options.Int (Prims.of_int (5))); + (let res = linear_check [] [] all_labels in + FStarC_Compiler_Util.print_string "\n"; + FStarC_Compiler_List.iter print_result res; + (let uu___4 = + FStarC_Compiler_Util.for_all FStar_Pervasives_Native.snd res in + if uu___4 + then + FStarC_Compiler_Util.print_string + "Failed: the heuristic of trying each proof in isolation failed to identify a precise error\n" + else ())) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_SMTEncoding_Pruning.ml b/ocaml/fstar-lib/generated/FStarC_SMTEncoding_Pruning.ml new file mode 100644 index 00000000000..0d03d2ef94b --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_SMTEncoding_Pruning.ml @@ -0,0 +1,1087 @@ +open Prims +type triggers = Prims.string Prims.list Prims.list +type triggers_set = Prims.string FStarC_Compiler_RBSet.t Prims.list +let (triggers_as_triggers_set : triggers -> triggers_set) = + fun ts -> + FStarC_Compiler_List.map + (fun uu___ -> + (Obj.magic + (FStarC_Class_Setlike.from_list () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)))) uu___) ts +type pruning_state = + { + macro_freenames: Prims.string Prims.list FStarC_Compiler_Util.psmap ; + trigger_to_assumption: + FStarC_SMTEncoding_Term.assumption Prims.list FStarC_Compiler_Util.psmap ; + assumption_to_triggers: triggers_set FStarC_Compiler_Util.psmap ; + assumption_name_map: + FStarC_SMTEncoding_Term.decl FStarC_Compiler_Util.psmap ; + ambients: Prims.string Prims.list ; + extra_roots: FStarC_SMTEncoding_Term.assumption Prims.list } +let (__proj__Mkpruning_state__item__macro_freenames : + pruning_state -> Prims.string Prims.list FStarC_Compiler_Util.psmap) = + fun projectee -> + match projectee with + | { macro_freenames; trigger_to_assumption; assumption_to_triggers; + assumption_name_map; ambients; extra_roots;_} -> macro_freenames +let (__proj__Mkpruning_state__item__trigger_to_assumption : + pruning_state -> + FStarC_SMTEncoding_Term.assumption Prims.list FStarC_Compiler_Util.psmap) + = + fun projectee -> + match projectee with + | { macro_freenames; trigger_to_assumption; assumption_to_triggers; + assumption_name_map; ambients; extra_roots;_} -> + trigger_to_assumption +let (__proj__Mkpruning_state__item__assumption_to_triggers : + pruning_state -> triggers_set FStarC_Compiler_Util.psmap) = + fun projectee -> + match projectee with + | { macro_freenames; trigger_to_assumption; assumption_to_triggers; + assumption_name_map; ambients; extra_roots;_} -> + assumption_to_triggers +let (__proj__Mkpruning_state__item__assumption_name_map : + pruning_state -> FStarC_SMTEncoding_Term.decl FStarC_Compiler_Util.psmap) = + fun projectee -> + match projectee with + | { macro_freenames; trigger_to_assumption; assumption_to_triggers; + assumption_name_map; ambients; extra_roots;_} -> assumption_name_map +let (__proj__Mkpruning_state__item__ambients : + pruning_state -> Prims.string Prims.list) = + fun projectee -> + match projectee with + | { macro_freenames; trigger_to_assumption; assumption_to_triggers; + assumption_name_map; ambients; extra_roots;_} -> ambients +let (__proj__Mkpruning_state__item__extra_roots : + pruning_state -> FStarC_SMTEncoding_Term.assumption Prims.list) = + fun projectee -> + match projectee with + | { macro_freenames; trigger_to_assumption; assumption_to_triggers; + assumption_name_map; ambients; extra_roots;_} -> extra_roots +let (debug : (unit -> unit) -> unit) = + fun f -> + let uu___ = + let uu___1 = FStarC_Options_Ext.get "debug_context_pruning" in + uu___1 <> "" in + if uu___ then f () else () +let (print_pruning_state : pruning_state -> Prims.string) = + fun p -> + let t_to_a = + FStarC_Compiler_Util.psmap_fold p.trigger_to_assumption + (fun k -> + fun v -> fun acc -> (k, (FStarC_Compiler_List.length v)) :: acc) + [] in + let t_to_a1 = + FStarC_Compiler_Util.sort_with + (fun x -> + fun y -> + (FStar_Pervasives_Native.snd x) - + (FStar_Pervasives_Native.snd y)) t_to_a in + let a_to_t = + FStarC_Compiler_Util.psmap_fold p.assumption_to_triggers + (fun k -> + fun v -> + fun acc -> + let uu___ = + let uu___1 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + (FStarC_Compiler_RBSet.showable_rbset + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_string))) v in + FStarC_Compiler_Util.format2 "[%s -> %s]" k uu___1 in + uu___ :: acc) [] in + let macros = + FStarC_Compiler_Util.psmap_fold p.macro_freenames + (fun k -> + fun v -> + fun acc -> + let uu___ = + let uu___1 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_string)) v in + FStarC_Compiler_Util.format2 "[%s -> %s]" k uu___1 in + uu___ :: acc) [] in + let uu___ = + let uu___1 = + FStarC_Compiler_List.map + (FStarC_Class_Show.show + (FStarC_Class_Show.show_tuple2 + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_string) + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int))) t_to_a1 in + FStarC_Compiler_String.concat "\n\t" uu___1 in + FStarC_Compiler_Util.format3 + "Pruning state:\n\tTriggers to assumptions:\n\t%s\nAssumptions to triggers:\n\t%s\nMacros:\n\t%s\n" + uu___ (FStarC_Compiler_String.concat "\n\t" a_to_t) + (FStarC_Compiler_String.concat "\n\t" macros) +let (show_pruning_state : pruning_state FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = print_pruning_state } +let (init : pruning_state) = + let uu___ = FStarC_Compiler_Util.psmap_empty () in + let uu___1 = FStarC_Compiler_Util.psmap_empty () in + let uu___2 = FStarC_Compiler_Util.psmap_empty () in + let uu___3 = FStarC_Compiler_Util.psmap_empty () in + { + macro_freenames = uu___; + trigger_to_assumption = uu___1; + assumption_to_triggers = uu___2; + assumption_name_map = uu___3; + ambients = []; + extra_roots = [] + } +let (add_trigger_to_assumption : + FStarC_SMTEncoding_Term.assumption -> + pruning_state -> Prims.string -> pruning_state) + = + fun a -> + fun p -> + fun trig -> + let uu___ = + FStarC_Compiler_Util.psmap_try_find p.trigger_to_assumption trig in + match uu___ with + | FStar_Pervasives_Native.None -> + let uu___1 = + FStarC_Compiler_Util.psmap_add p.trigger_to_assumption trig [a] in + { + macro_freenames = (p.macro_freenames); + trigger_to_assumption = uu___1; + assumption_to_triggers = (p.assumption_to_triggers); + assumption_name_map = (p.assumption_name_map); + ambients = (p.ambients); + extra_roots = (p.extra_roots) + } + | FStar_Pervasives_Native.Some l -> + let uu___1 = + FStarC_Compiler_Util.psmap_add p.trigger_to_assumption trig (a + :: l) in + { + macro_freenames = (p.macro_freenames); + trigger_to_assumption = uu___1; + assumption_to_triggers = (p.assumption_to_triggers); + assumption_name_map = (p.assumption_name_map); + ambients = (p.ambients); + extra_roots = (p.extra_roots) + } +let (exclude_names : Prims.string FStarC_Compiler_RBSet.t) = + Obj.magic + (FStarC_Class_Setlike.from_list () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset FStarC_Class_Ord.ord_string)) + ["SFuel"; + "ZFuel"; + "HasType"; + "HasTypeZ"; + "HasTypeFuel"; + "Valid"; + "ApplyTT"; + "ApplyTF"; + "Prims.lex_t"]) +let (free_top_level_names : + FStarC_SMTEncoding_Term.term -> Prims.string FStarC_Compiler_RBSet.t) = + fun uu___ -> + (fun t -> + let uu___ = FStarC_SMTEncoding_Term.free_top_level_names t in + Obj.magic + (FStarC_Class_Setlike.diff () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) (Obj.magic uu___) + (Obj.magic exclude_names))) uu___ +let (assumption_free_names : + FStarC_SMTEncoding_Term.assumption -> Prims.string FStarC_Compiler_RBSet.t) + = + fun uu___ -> + (fun a -> + Obj.magic + (FStarC_Class_Setlike.diff () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) + (Obj.magic a.FStarC_SMTEncoding_Term.assumption_free_names) + (Obj.magic exclude_names))) uu___ +let (triggers_of_term : FStarC_SMTEncoding_Term.term -> triggers_set) = + fun t -> + let rec aux t1 = + match t1.FStarC_SMTEncoding_Term.tm with + | FStarC_SMTEncoding_Term.Quant + (FStarC_SMTEncoding_Term.Forall, triggers1, uu___, uu___1, uu___2) + -> + FStarC_Compiler_List.map + (fun disjunct -> + let uu___3 = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) ()) in + FStarC_Compiler_List.fold_left + (fun uu___5 -> + fun uu___4 -> + (fun out -> + fun t2 -> + let uu___4 = free_top_level_names t2 in + Obj.magic + (FStarC_Class_Setlike.union () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) + (Obj.magic out) (Obj.magic uu___4))) uu___5 + uu___4) uu___3 disjunct) triggers1 + | FStarC_SMTEncoding_Term.Labeled (t2, uu___, uu___1) -> aux t2 + | FStarC_SMTEncoding_Term.LblPos (t2, uu___) -> aux t2 + | uu___ -> [] in + aux t +let (maybe_add_ambient : + FStarC_SMTEncoding_Term.assumption -> pruning_state -> pruning_state) = + fun a -> + fun p -> + let add_assumption_with_triggers triggers1 = + let p1 = + let uu___ = + FStarC_Compiler_Util.psmap_add p.assumption_to_triggers + a.FStarC_SMTEncoding_Term.assumption_name triggers1 in + { + macro_freenames = (p.macro_freenames); + trigger_to_assumption = (p.trigger_to_assumption); + assumption_to_triggers = uu___; + assumption_name_map = (p.assumption_name_map); + ambients = (p.ambients); + extra_roots = (p.extra_roots) + } in + let uu___ = + FStarC_Compiler_List.map + (fun uu___1 -> + (Obj.magic + (FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)))) uu___1) triggers1 in + FStarC_Compiler_List.fold_left + (FStarC_Compiler_List.fold_left (add_trigger_to_assumption a)) p1 + uu___ in + let is_empty triggers1 = + match triggers1 with + | [] -> true + | t::[] -> + FStarC_Class_Setlike.is_empty () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) (Obj.magic t) + | uu___ -> false in + let is_ambient_refinement ty = + match ty.FStarC_SMTEncoding_Term.tm with + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Var "Prims.squash", uu___) -> true + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Var name, uu___) -> + FStarC_Compiler_Util.starts_with name "Tm_refine_" + | FStarC_SMTEncoding_Term.FreeV (FStarC_SMTEncoding_Term.FV + (name, uu___, uu___1)) -> + FStarC_Compiler_Util.starts_with name "Tm_refine_" + | uu___ -> false in + let ambient_refinement_payload ty = + match ty.FStarC_SMTEncoding_Term.tm with + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Var "Prims.squash", t::[]) -> t + | uu___ -> ty in + if + a.FStarC_SMTEncoding_Term.assumption_name = + "function_token_typing_Prims.__cache_version_number__" + then + { + macro_freenames = (p.macro_freenames); + trigger_to_assumption = (p.trigger_to_assumption); + assumption_to_triggers = (p.assumption_to_triggers); + assumption_name_map = (p.assumption_name_map); + ambients = ((a.FStarC_SMTEncoding_Term.assumption_name) :: + (p.ambients)); + extra_roots = (p.extra_roots) + } + else + (match (a.FStarC_SMTEncoding_Term.assumption_term).FStarC_SMTEncoding_Term.tm + with + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Iff, t0::t1::[]) when + FStarC_Compiler_Util.starts_with + a.FStarC_SMTEncoding_Term.assumption_name "l_quant_interp" + -> + let triggers_lhs = free_top_level_names t0 in + add_assumption_with_triggers [triggers_lhs] + | uu___ when + FStarC_Compiler_Util.starts_with + a.FStarC_SMTEncoding_Term.assumption_name "assumption_" + -> + let triggers1 = + triggers_of_term a.FStarC_SMTEncoding_Term.assumption_term in + let uu___1 = is_empty triggers1 in + if uu___1 + then + let triggers2 = + let uu___2 = + free_top_level_names + a.FStarC_SMTEncoding_Term.assumption_term in + [uu___2] in + add_assumption_with_triggers triggers2 + else add_assumption_with_triggers triggers1 + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Var "HasType", term::ty::[]) when + is_ambient_refinement ty -> + let triggers1 = triggers_of_term (ambient_refinement_payload ty) in + let uu___ = is_empty triggers1 in + if uu___ + then + { + macro_freenames = (p.macro_freenames); + trigger_to_assumption = (p.trigger_to_assumption); + assumption_to_triggers = (p.assumption_to_triggers); + assumption_name_map = (p.assumption_name_map); + ambients = ((a.FStarC_SMTEncoding_Term.assumption_name) :: + (p.ambients)); + extra_roots = (a :: (p.extra_roots)) + } + else add_assumption_with_triggers triggers1 + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Var "Valid", + { + FStarC_SMTEncoding_Term.tm = FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Var "ApplyTT", + { + FStarC_SMTEncoding_Term.tm = + FStarC_SMTEncoding_Term.FreeV + (FStarC_SMTEncoding_Term.FV + ("__uu__PartialApp", uu___, uu___1)); + FStarC_SMTEncoding_Term.freevars = uu___2; + FStarC_SMTEncoding_Term.rng = uu___3;_}::term::[]); + FStarC_SMTEncoding_Term.freevars = uu___4; + FStarC_SMTEncoding_Term.rng = uu___5;_}::[]) + -> + let triggers1 = + match term.FStarC_SMTEncoding_Term.tm with + | FStarC_SMTEncoding_Term.FreeV (FStarC_SMTEncoding_Term.FV + (token, uu___6, uu___7)) -> + if FStarC_Compiler_Util.ends_with token "@tok" + then + let uu___8 = + Obj.magic + (FStarC_Class_Setlike.singleton () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) token) in + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Compiler_Util.substring token + Prims.int_zero + ((FStarC_Compiler_String.length token) - + (Prims.of_int (4))) in + Obj.magic + (FStarC_Class_Setlike.singleton () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) uu___11) in + [uu___10] in + uu___8 :: uu___9 + else + (let uu___9 = + Obj.magic + (FStarC_Class_Setlike.singleton () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) token) in + [uu___9]) + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Var token, []) -> + if FStarC_Compiler_Util.ends_with token "@tok" + then + let uu___6 = + Obj.magic + (FStarC_Class_Setlike.singleton () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) token) in + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Compiler_Util.substring token + Prims.int_zero + ((FStarC_Compiler_String.length token) - + (Prims.of_int (4))) in + Obj.magic + (FStarC_Class_Setlike.singleton () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) uu___9) in + [uu___8] in + uu___6 :: uu___7 + else + (let uu___7 = + Obj.magic + (FStarC_Class_Setlike.singleton () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) token) in + [uu___7]) + | uu___6 -> [] in + add_assumption_with_triggers triggers1 + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Var "Valid", + { + FStarC_SMTEncoding_Term.tm = FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Var "ApplyTT", + { + FStarC_SMTEncoding_Term.tm = FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Var "__uu__PartialApp", + uu___); + FStarC_SMTEncoding_Term.freevars = uu___1; + FStarC_SMTEncoding_Term.rng = uu___2;_}::term::[]); + FStarC_SMTEncoding_Term.freevars = uu___3; + FStarC_SMTEncoding_Term.rng = uu___4;_}::[]) + -> + let triggers1 = + match term.FStarC_SMTEncoding_Term.tm with + | FStarC_SMTEncoding_Term.FreeV (FStarC_SMTEncoding_Term.FV + (token, uu___5, uu___6)) -> + if FStarC_Compiler_Util.ends_with token "@tok" + then + let uu___7 = + Obj.magic + (FStarC_Class_Setlike.singleton () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) token) in + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Compiler_Util.substring token + Prims.int_zero + ((FStarC_Compiler_String.length token) - + (Prims.of_int (4))) in + Obj.magic + (FStarC_Class_Setlike.singleton () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) uu___10) in + [uu___9] in + uu___7 :: uu___8 + else + (let uu___8 = + Obj.magic + (FStarC_Class_Setlike.singleton () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) token) in + [uu___8]) + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Var token, []) -> + if FStarC_Compiler_Util.ends_with token "@tok" + then + let uu___5 = + Obj.magic + (FStarC_Class_Setlike.singleton () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) token) in + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Compiler_Util.substring token + Prims.int_zero + ((FStarC_Compiler_String.length token) - + (Prims.of_int (4))) in + Obj.magic + (FStarC_Class_Setlike.singleton () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) uu___8) in + [uu___7] in + uu___5 :: uu___6 + else + (let uu___6 = + Obj.magic + (FStarC_Class_Setlike.singleton () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) token) in + [uu___6]) + | uu___5 -> [] in + add_assumption_with_triggers triggers1 + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Var "Valid", term::[]) -> + let uu___ = let uu___1 = free_top_level_names term in [uu___1] in + add_assumption_with_triggers uu___ + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Var "HasType", term::uu___::[]) -> + let uu___1 = let uu___2 = free_top_level_names term in [uu___2] in + add_assumption_with_triggers uu___1 + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Var "IsTotFun", term::[]) -> + let uu___ = let uu___1 = free_top_level_names term in [uu___1] in + add_assumption_with_triggers uu___ + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Var "is-Tm_arrow", term::[]) -> + let uu___ = let uu___1 = free_top_level_names term in [uu___1] in + add_assumption_with_triggers uu___ + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Eq, + uu___::{ + FStarC_SMTEncoding_Term.tm = + FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Var "Term_constr_id", + term::[]); + FStarC_SMTEncoding_Term.freevars = uu___1; + FStarC_SMTEncoding_Term.rng = uu___2;_}::[]) + -> + let uu___3 = let uu___4 = free_top_level_names term in [uu___4] in + add_assumption_with_triggers uu___3 + | FStarC_SMTEncoding_Term.App (FStarC_SMTEncoding_Term.And, tms) -> + let t1 = FStarC_Compiler_List.collect triggers_of_term tms in + add_assumption_with_triggers t1 + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Eq, t0::t1::[]) when + FStarC_Compiler_Util.starts_with + a.FStarC_SMTEncoding_Term.assumption_name "equation_" + -> + let t01 = free_top_level_names t0 in + add_assumption_with_triggers [t01] + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Iff, t0::t1::[]) -> + let t01 = free_top_level_names t0 in + let t11 = free_top_level_names t1 in + add_assumption_with_triggers [t01; t11] + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.Eq, t0::t1::[]) -> + let t01 = free_top_level_names t0 in + let t11 = free_top_level_names t1 in + add_assumption_with_triggers [t01; t11] + | FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.TrueOp, uu___) -> p + | uu___ -> + { + macro_freenames = (p.macro_freenames); + trigger_to_assumption = (p.trigger_to_assumption); + assumption_to_triggers = (p.assumption_to_triggers); + assumption_name_map = (p.assumption_name_map); + ambients = ((a.FStarC_SMTEncoding_Term.assumption_name) :: + (p.ambients)); + extra_roots = (p.extra_roots) + }) +let (add_assumption_to_triggers : + FStarC_SMTEncoding_Term.assumption -> + pruning_state -> triggers_set -> pruning_state) + = + fun a -> + fun p -> + fun trigs -> + let p1 = + let uu___ = + FStarC_Compiler_Util.psmap_add p.assumption_name_map + a.FStarC_SMTEncoding_Term.assumption_name + (FStarC_SMTEncoding_Term.Assume a) in + { + macro_freenames = (p.macro_freenames); + trigger_to_assumption = (p.trigger_to_assumption); + assumption_to_triggers = (p.assumption_to_triggers); + assumption_name_map = uu___; + ambients = (p.ambients); + extra_roots = (p.extra_roots) + } in + match trigs with + | [] -> maybe_add_ambient a p1 + | uu___ -> + let uu___1 = + FStarC_Compiler_Util.psmap_add p1.assumption_to_triggers + a.FStarC_SMTEncoding_Term.assumption_name trigs in + { + macro_freenames = (p1.macro_freenames); + trigger_to_assumption = (p1.trigger_to_assumption); + assumption_to_triggers = uu___1; + assumption_name_map = (p1.assumption_name_map); + ambients = (p1.ambients); + extra_roots = (p1.extra_roots) + } +let (trigger_reached : pruning_state -> Prims.string -> pruning_state) = + fun p -> + fun trig -> + let uu___ = + FStarC_Compiler_Util.psmap_remove p.trigger_to_assumption trig in + { + macro_freenames = (p.macro_freenames); + trigger_to_assumption = uu___; + assumption_to_triggers = (p.assumption_to_triggers); + assumption_name_map = (p.assumption_name_map); + ambients = (p.ambients); + extra_roots = (p.extra_roots) + } +let (remove_trigger_for_assumption : + pruning_state -> + Prims.string -> Prims.string -> (pruning_state * Prims.bool)) + = + fun p -> + fun trig -> + fun aname -> + let uu___ = + FStarC_Compiler_Util.psmap_try_find p.assumption_to_triggers aname in + match uu___ with + | FStar_Pervasives_Native.None -> (p, false) + | FStar_Pervasives_Native.Some l -> + let remaining_triggers = + FStarC_Compiler_List.map + (fun uu___1 -> + (fun ts -> + Obj.magic + (FStarC_Class_Setlike.remove () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) trig + (Obj.magic ts))) uu___1) l in + let eligible = + FStarC_Compiler_Util.for_some + (fun uu___1 -> + (Obj.magic + (FStarC_Class_Setlike.is_empty () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)))) uu___1) + remaining_triggers in + let uu___1 = + let uu___2 = + FStarC_Compiler_Util.psmap_add p.assumption_to_triggers aname + remaining_triggers in + { + macro_freenames = (p.macro_freenames); + trigger_to_assumption = (p.trigger_to_assumption); + assumption_to_triggers = uu___2; + assumption_name_map = (p.assumption_name_map); + ambients = (p.ambients); + extra_roots = (p.extra_roots) + } in + (uu___1, eligible) +let rec (assumptions_of_decl : + FStarC_SMTEncoding_Term.decl -> + FStarC_SMTEncoding_Term.assumption Prims.list) + = + fun d -> + match d with + | FStarC_SMTEncoding_Term.Assume a -> [a] + | FStarC_SMTEncoding_Term.Module (uu___, ds) -> + FStarC_Compiler_List.collect assumptions_of_decl ds + | d1 -> [] +let rec (add_decl : + FStarC_SMTEncoding_Term.decl -> pruning_state -> pruning_state) = + fun d -> + fun p -> + match d with + | FStarC_SMTEncoding_Term.Assume a -> + let triggers1 = + triggers_of_term a.FStarC_SMTEncoding_Term.assumption_term in + let p1 = + let uu___ = + FStarC_Compiler_List.map + (fun uu___1 -> + (Obj.magic + (FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)))) uu___1) + triggers1 in + FStarC_Compiler_List.fold_left + (FStarC_Compiler_List.fold_left (add_trigger_to_assumption a)) + p uu___ in + add_assumption_to_triggers a p1 triggers1 + | FStarC_SMTEncoding_Term.Module (uu___, ds) -> + FStarC_Compiler_List.fold_left (fun p1 -> fun d1 -> add_decl d1 p1) + p ds + | FStarC_SMTEncoding_Term.DefineFun + (macro, uu___, uu___1, body, uu___2) -> + let free_names = + let uu___3 = free_top_level_names body in + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) (Obj.magic uu___3) in + let p1 = + let uu___3 = + FStarC_Compiler_Util.psmap_add p.macro_freenames macro + free_names in + { + macro_freenames = uu___3; + trigger_to_assumption = (p.trigger_to_assumption); + assumption_to_triggers = (p.assumption_to_triggers); + assumption_name_map = (p.assumption_name_map); + ambients = (p.ambients); + extra_roots = (p.extra_roots) + } in + p1 + | uu___ -> p +let (add_decls : + FStarC_SMTEncoding_Term.decl Prims.list -> pruning_state -> pruning_state) + = + fun ds -> + fun p -> + FStarC_Compiler_List.fold_left (fun p1 -> fun d -> add_decl d p1) p ds +type sym = Prims.string +type reached_assumption_names = Prims.string FStarC_Compiler_RBSet.rbset +type ctxt = { + p: pruning_state ; + reached: reached_assumption_names } +let (__proj__Mkctxt__item__p : ctxt -> pruning_state) = + fun projectee -> match projectee with | { p; reached;_} -> p +let (__proj__Mkctxt__item__reached : ctxt -> reached_assumption_names) = + fun projectee -> match projectee with | { p; reached;_} -> reached +type 'a st = ctxt -> ('a * ctxt) +let (get : ctxt st) = fun s -> (s, s) +let (put : ctxt -> unit st) = fun c -> fun uu___ -> ((), c) +let (st_monad : unit st FStarC_Class_Monad.monad) = + { + FStarC_Class_Monad.return = + (fun uu___1 -> + fun uu___ -> + (fun a -> fun x -> fun s -> Obj.magic (x, s)) uu___1 uu___); + FStarC_Class_Monad.op_let_Bang = + (fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun a -> + fun b -> + fun m -> + let m = Obj.magic m in + fun f -> + let f = Obj.magic f in + fun s -> + let uu___ = m s in + match uu___ with + | (x, s1) -> + let uu___1 = f x in Obj.magic (uu___1 s1)) + uu___3 uu___2 uu___1 uu___) + } +let (mark_trigger_reached : sym -> unit st) = + fun x -> + FStarC_Class_Monad.op_let_Bang st_monad () () (Obj.magic get) + (fun uu___ -> + (fun ctxt1 -> + let ctxt1 = Obj.magic ctxt1 in + let uu___ = + let uu___1 = trigger_reached ctxt1.p x in + { p = uu___1; reached = (ctxt1.reached) } in + Obj.magic (put uu___)) uu___) +let (find_assumptions_waiting_on_trigger : + sym -> FStarC_SMTEncoding_Term.assumption Prims.list st) = + fun uu___ -> + (fun x -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang st_monad () () (Obj.magic get) + (fun uu___ -> + (fun ctxt1 -> + let ctxt1 = Obj.magic ctxt1 in + let uu___ = + FStarC_Compiler_Util.psmap_try_find + (ctxt1.p).trigger_to_assumption x in + match uu___ with + | FStar_Pervasives_Native.None -> + Obj.magic + (FStarC_Class_Monad.return st_monad () (Obj.magic [])) + | FStar_Pervasives_Native.Some l -> + Obj.magic + (FStarC_Class_Monad.return st_monad () (Obj.magic l))) + uu___))) uu___ +let (reached_assumption : Prims.string -> unit st) = + fun aname -> + FStarC_Class_Monad.op_let_Bang st_monad () () (Obj.magic get) + (fun uu___ -> + (fun ctxt1 -> + let ctxt1 = Obj.magic ctxt1 in + let p = + let uu___ = ctxt1.p in + let uu___1 = + FStarC_Compiler_Util.psmap_remove + (ctxt1.p).assumption_to_triggers aname in + { + macro_freenames = (uu___.macro_freenames); + trigger_to_assumption = (uu___.trigger_to_assumption); + assumption_to_triggers = uu___1; + assumption_name_map = (uu___.assumption_name_map); + ambients = (uu___.ambients); + extra_roots = (uu___.extra_roots) + } in + let uu___ = + let uu___1 = + Obj.magic + (FStarC_Class_Setlike.add () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) aname + (Obj.magic ctxt1.reached)) in + { p = (ctxt1.p); reached = uu___1 } in + Obj.magic (put uu___)) uu___) +let (remove_trigger_for : + sym -> FStarC_SMTEncoding_Term.assumption -> Prims.bool st) = + fun uu___1 -> + fun uu___ -> + (fun trig -> + fun a -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang st_monad () () (Obj.magic get) + (fun uu___ -> + (fun ctxt1 -> + let ctxt1 = Obj.magic ctxt1 in + let uu___ = + remove_trigger_for_assumption ctxt1.p trig + a.FStarC_SMTEncoding_Term.assumption_name in + match uu___ with + | (p, eligible) -> + let uu___1 = put { p; reached = (ctxt1.reached) } in + Obj.magic + (FStarC_Class_Monad.op_let_Bang st_monad () () + uu___1 + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + Obj.magic + (FStarC_Class_Monad.return st_monad () + (Obj.magic eligible))) uu___2))) + uu___))) uu___1 uu___ +let (already_reached : Prims.string -> Prims.bool st) = + fun uu___ -> + (fun aname -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang st_monad () () (Obj.magic get) + (fun uu___ -> + (fun ctxt1 -> + let ctxt1 = Obj.magic ctxt1 in + let uu___ = + FStarC_Class_Setlike.mem () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) aname + (Obj.magic ctxt1.reached) in + Obj.magic + (FStarC_Class_Monad.return st_monad () (Obj.magic uu___))) + uu___))) uu___ +let (trigger_pending_assumptions : + sym Prims.list -> FStarC_SMTEncoding_Term.assumption Prims.list st) = + fun uu___ -> + (fun lids -> + Obj.magic + (FStarC_Class_Monad.foldM_left st_monad () () + (fun uu___1 -> + fun uu___ -> + (fun acc -> + let acc = Obj.magic acc in + fun lid -> + let lid = Obj.magic lid in + let uu___ = find_assumptions_waiting_on_trigger lid in + Obj.magic + (FStarC_Class_Monad.op_let_Bang st_monad () () + (Obj.magic uu___) + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + match uu___1 with + | [] -> + Obj.magic + (FStarC_Class_Monad.return st_monad () + (Obj.magic acc)) + | assumptions -> + let uu___2 = mark_trigger_reached lid in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + st_monad () () uu___2 + (fun uu___3 -> + (fun uu___3 -> + let uu___3 = Obj.magic uu___3 in + Obj.magic + (FStarC_Class_Monad.foldM_left + st_monad () () + (fun uu___5 -> + fun uu___4 -> + (fun acc1 -> + let acc1 = + Obj.magic acc1 in + fun assumption + -> + let assumption + = + Obj.magic + assumption in + let uu___4 = + remove_trigger_for + lid + assumption in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + st_monad + () () + ( + Obj.magic + uu___4) + ( + fun + uu___5 -> + (fun + uu___5 -> + let uu___5 + = + Obj.magic + uu___5 in + if uu___5 + then + Obj.magic + (FStarC_Class_Monad.return + st_monad + () + (Obj.magic + (assumption + :: acc1))) + else + Obj.magic + (FStarC_Class_Monad.return + st_monad + () + (Obj.magic + acc1))) + uu___5))) + uu___5 uu___4) + (Obj.magic acc) + (Obj.magic assumptions))) + uu___3))) uu___1))) uu___1 + uu___) (Obj.magic []) (Obj.magic lids))) uu___ +let rec (scan : FStarC_SMTEncoding_Term.assumption Prims.list -> unit st) = + fun ds -> + FStarC_Class_Monad.op_let_Bang st_monad () () (Obj.magic get) + (fun uu___ -> + (fun ctxt1 -> + let ctxt1 = Obj.magic ctxt1 in + let macro_expand s = + let uu___ = + FStarC_Compiler_Util.psmap_try_find (ctxt1.p).macro_freenames + s in + match uu___ with + | FStar_Pervasives_Native.None -> [s] + | FStar_Pervasives_Native.Some l -> s :: l in + let new_syms = + FStarC_Compiler_List.collect + (fun a -> + let uu___ = + let uu___1 = assumption_free_names a in + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) (Obj.magic uu___1) in + FStarC_Compiler_List.collect macro_expand uu___) ds in + let uu___ = trigger_pending_assumptions new_syms in + Obj.magic + (FStarC_Class_Monad.op_let_Bang st_monad () () + (Obj.magic uu___) + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + match uu___1 with + | [] -> + Obj.magic + (FStarC_Class_Monad.return st_monad () + (Obj.repr ())) + | triggered -> + let uu___2 = + Obj.magic + (FStarC_Class_Monad.foldM_left st_monad () () + (fun uu___4 -> + fun uu___3 -> + (fun acc -> + let acc = Obj.magic acc in + fun assumption -> + let assumption = + Obj.magic assumption in + let uu___3 = + already_reached + assumption.FStarC_SMTEncoding_Term.assumption_name in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + st_monad () () + (Obj.magic uu___3) + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = + Obj.magic uu___4 in + if uu___4 + then + Obj.magic + (FStarC_Class_Monad.return + st_monad () + (Obj.magic acc)) + else + (let uu___6 = + reached_assumption + assumption.FStarC_SMTEncoding_Term.assumption_name in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + st_monad () () + uu___6 + (fun uu___7 -> + (fun uu___7 + -> + let uu___7 + = + Obj.magic + uu___7 in + Obj.magic + (FStarC_Class_Monad.return + st_monad + () + (Obj.magic + (assumption + :: acc)))) + uu___7)))) + uu___4))) uu___4 uu___3) + (Obj.magic []) (Obj.magic triggered)) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang st_monad () () + (Obj.magic uu___2) + (fun uu___3 -> + (fun to_scan -> + let to_scan = Obj.magic to_scan in + Obj.magic (scan to_scan)) uu___3))) + uu___1))) uu___) +let (prune : + pruning_state -> + FStarC_SMTEncoding_Term.decl Prims.list -> + FStarC_SMTEncoding_Term.decl Prims.list) + = + fun p -> + fun roots -> + let roots1 = FStarC_Compiler_List.collect assumptions_of_decl roots in + let init1 = + let uu___ = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) ()) in + { p; reached = uu___ } in + let uu___ = + let uu___1 = scan (FStar_List_Tot_Base.op_At roots1 p.extra_roots) in + uu___1 init1 in + match uu___ with + | (uu___1, ctxt1) -> + let reached_names = + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) (Obj.magic ctxt1.reached) in + let reached_assumptions = + FStarC_Compiler_List.collect + (fun name -> + let uu___2 = + FStarC_Compiler_Util.psmap_try_find + (ctxt1.p).assumption_name_map name in + match uu___2 with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some a -> [a]) + (FStar_List_Tot_Base.op_At reached_names p.ambients) in + reached_assumptions \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_SMTEncoding_Solver.ml b/ocaml/fstar-lib/generated/FStarC_SMTEncoding_Solver.ml new file mode 100644 index 00000000000..2349abf0042 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_SMTEncoding_Solver.ml @@ -0,0 +1,2523 @@ +open Prims +exception SplitQueryAndRetry +let (uu___is_SplitQueryAndRetry : Prims.exn -> Prims.bool) = + fun projectee -> + match projectee with | SplitQueryAndRetry -> true | uu___ -> false +let (dbg_SMTQuery : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "SMTQuery" +let (dbg_SMTFail : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "SMTFail" +let (z3_replay_result : (unit * unit)) = ((), ()) +let z3_result_as_replay_result : + 'uuuuu 'uuuuu1 'uuuuu2 . + ('uuuuu, ('uuuuu1 * 'uuuuu2)) FStar_Pervasives.either -> + ('uuuuu, 'uuuuu1) FStar_Pervasives.either + = + fun uu___ -> + match uu___ with + | FStar_Pervasives.Inl l -> FStar_Pervasives.Inl l + | FStar_Pervasives.Inr (r, uu___1) -> FStar_Pervasives.Inr r +let (recorded_hints : + FStarC_Compiler_Hints.hints FStar_Pervasives_Native.option + FStarC_Compiler_Effect.ref) + = FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None +let (replaying_hints : + FStarC_Compiler_Hints.hints FStar_Pervasives_Native.option + FStarC_Compiler_Effect.ref) + = FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None +let (use_hints : unit -> Prims.bool) = + fun uu___ -> + (FStarC_Options.use_hints ()) && + (let uu___1 = FStarC_Options_Ext.get "context_pruning" in uu___1 = "") +let initialize_hints_db : 'uuuuu . Prims.string -> 'uuuuu -> unit = + fun src_filename -> + fun format_filename -> + (let uu___1 = FStarC_Options.record_hints () in + if uu___1 + then + FStarC_Compiler_Effect.op_Colon_Equals recorded_hints + (FStar_Pervasives_Native.Some []) + else ()); + (let norm_src_filename = + FStarC_Compiler_Util.normalize_file_path src_filename in + let val_filename = FStarC_Options.hint_file_for_src norm_src_filename in + let uu___1 = FStarC_Compiler_Hints.read_hints val_filename in + match uu___1 with + | FStarC_Compiler_Hints.HintsOK hints -> + let expected_digest = + FStarC_Compiler_Util.digest_of_file norm_src_filename in + ((let uu___3 = FStarC_Options.hint_info () in + if uu___3 + then + FStarC_Compiler_Util.print3 "(%s) digest is %s from %s.\n" + norm_src_filename + (if + hints.FStarC_Compiler_Hints.module_digest = + expected_digest + then "valid; using hints" + else "invalid; using potentially stale hints") val_filename + else ()); + FStarC_Compiler_Effect.op_Colon_Equals replaying_hints + (FStar_Pervasives_Native.Some + (hints.FStarC_Compiler_Hints.hints))) + | FStarC_Compiler_Hints.MalformedJson -> + let uu___3 = use_hints () in + if uu___3 + then + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Compiler_Util.format1 + "Malformed JSON hints file: %s; ran without hints" + val_filename in + FStarC_Errors_Msg.text uu___6 in + [uu___5] in + FStarC_Errors.log_issue0 + FStarC_Errors_Codes.Warning_CouldNotReadHints () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___4) + else () + | FStarC_Compiler_Hints.UnableToOpen -> + let uu___3 = use_hints () in + if uu___3 + then + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Compiler_Util.format1 + "Unable to open hints file: %s; ran without hints" + val_filename in + FStarC_Errors_Msg.text uu___6 in + [uu___5] in + FStarC_Errors.log_issue0 + FStarC_Errors_Codes.Warning_CouldNotReadHints () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___4) + else ()) +let (finalize_hints_db : Prims.string -> unit) = + fun src_filename -> + (let uu___1 = FStarC_Options.record_hints () in + if uu___1 + then + let hints = + let uu___2 = FStarC_Compiler_Effect.op_Bang recorded_hints in + FStarC_Compiler_Option.get uu___2 in + let hints_db = + let uu___2 = FStarC_Compiler_Util.digest_of_file src_filename in + { + FStarC_Compiler_Hints.module_digest = uu___2; + FStarC_Compiler_Hints.hints = hints + } in + let norm_src_filename = + FStarC_Compiler_Util.normalize_file_path src_filename in + let val_filename = FStarC_Options.hint_file_for_src norm_src_filename in + FStarC_Compiler_Hints.write_hints val_filename hints_db + else ()); + FStarC_Compiler_Effect.op_Colon_Equals recorded_hints + FStar_Pervasives_Native.None; + FStarC_Compiler_Effect.op_Colon_Equals replaying_hints + FStar_Pervasives_Native.None +let with_hints_db : 'a . Prims.string -> (unit -> 'a) -> 'a = + fun fname -> + fun f -> + initialize_hints_db fname false; + (let result = f () in finalize_hints_db fname; result) +type errors = + { + error_reason: Prims.string ; + error_rlimit: Prims.int ; + error_fuel: Prims.int ; + error_ifuel: Prims.int ; + error_hint: Prims.string Prims.list FStar_Pervasives_Native.option ; + error_messages: FStarC_Errors.error Prims.list } +let (__proj__Mkerrors__item__error_reason : errors -> Prims.string) = + fun projectee -> + match projectee with + | { error_reason; error_rlimit; error_fuel; error_ifuel; error_hint; + error_messages;_} -> error_reason +let (__proj__Mkerrors__item__error_rlimit : errors -> Prims.int) = + fun projectee -> + match projectee with + | { error_reason; error_rlimit; error_fuel; error_ifuel; error_hint; + error_messages;_} -> error_rlimit +let (__proj__Mkerrors__item__error_fuel : errors -> Prims.int) = + fun projectee -> + match projectee with + | { error_reason; error_rlimit; error_fuel; error_ifuel; error_hint; + error_messages;_} -> error_fuel +let (__proj__Mkerrors__item__error_ifuel : errors -> Prims.int) = + fun projectee -> + match projectee with + | { error_reason; error_rlimit; error_fuel; error_ifuel; error_hint; + error_messages;_} -> error_ifuel +let (__proj__Mkerrors__item__error_hint : + errors -> Prims.string Prims.list FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { error_reason; error_rlimit; error_fuel; error_ifuel; error_hint; + error_messages;_} -> error_hint +let (__proj__Mkerrors__item__error_messages : + errors -> FStarC_Errors.error Prims.list) = + fun projectee -> + match projectee with + | { error_reason; error_rlimit; error_fuel; error_ifuel; error_hint; + error_messages;_} -> error_messages +let (error_to_short_string : errors -> Prims.string) = + fun err -> + let uu___ = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow FStar_Class_Printable.printable_int) + err.error_rlimit in + let uu___1 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow FStar_Class_Printable.printable_int) + err.error_fuel in + let uu___2 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow FStar_Class_Printable.printable_int) + err.error_ifuel in + FStarC_Compiler_Util.format5 "%s (rlimit=%s; fuel=%s; ifuel=%s%s)" + err.error_reason uu___ uu___1 uu___2 + (if FStarC_Compiler_Option.isSome err.error_hint + then "; with hint" + else "") +let (error_to_is_timeout : errors -> Prims.string Prims.list) = + fun err -> + if FStarC_Compiler_Util.ends_with err.error_reason "canceled" + then + let uu___ = + let uu___1 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) err.error_rlimit in + let uu___2 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) err.error_fuel in + let uu___3 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) err.error_ifuel in + FStarC_Compiler_Util.format5 + "timeout (rlimit=%s; fuel=%s; ifuel=%s; %s)" err.error_reason + uu___1 uu___2 uu___3 + (if FStarC_Compiler_Option.isSome err.error_hint + then "with hint" + else "") in + [uu___] + else [] +type query_settings = + { + query_env: FStarC_SMTEncoding_Env.env_t ; + query_decl: FStarC_SMTEncoding_Term.decl ; + query_name: Prims.string ; + query_index: Prims.int ; + query_range: FStarC_Compiler_Range_Type.range ; + query_fuel: Prims.int ; + query_ifuel: Prims.int ; + query_rlimit: Prims.int ; + query_hint: + FStarC_SMTEncoding_UnsatCore.unsat_core FStar_Pervasives_Native.option ; + query_errors: errors Prims.list ; + query_all_labels: FStarC_SMTEncoding_Term.error_labels ; + query_suffix: FStarC_SMTEncoding_Term.decl Prims.list ; + query_hash: Prims.string FStar_Pervasives_Native.option ; + query_can_be_split_and_retried: Prims.bool ; + query_term: FStarC_Syntax_Syntax.term } +let (__proj__Mkquery_settings__item__query_env : + query_settings -> FStarC_SMTEncoding_Env.env_t) = + fun projectee -> + match projectee with + | { query_env; query_decl; query_name; query_index; query_range; + query_fuel; query_ifuel; query_rlimit; query_hint; query_errors; + query_all_labels; query_suffix; query_hash; + query_can_be_split_and_retried; query_term;_} -> query_env +let (__proj__Mkquery_settings__item__query_decl : + query_settings -> FStarC_SMTEncoding_Term.decl) = + fun projectee -> + match projectee with + | { query_env; query_decl; query_name; query_index; query_range; + query_fuel; query_ifuel; query_rlimit; query_hint; query_errors; + query_all_labels; query_suffix; query_hash; + query_can_be_split_and_retried; query_term;_} -> query_decl +let (__proj__Mkquery_settings__item__query_name : + query_settings -> Prims.string) = + fun projectee -> + match projectee with + | { query_env; query_decl; query_name; query_index; query_range; + query_fuel; query_ifuel; query_rlimit; query_hint; query_errors; + query_all_labels; query_suffix; query_hash; + query_can_be_split_and_retried; query_term;_} -> query_name +let (__proj__Mkquery_settings__item__query_index : + query_settings -> Prims.int) = + fun projectee -> + match projectee with + | { query_env; query_decl; query_name; query_index; query_range; + query_fuel; query_ifuel; query_rlimit; query_hint; query_errors; + query_all_labels; query_suffix; query_hash; + query_can_be_split_and_retried; query_term;_} -> query_index +let (__proj__Mkquery_settings__item__query_range : + query_settings -> FStarC_Compiler_Range_Type.range) = + fun projectee -> + match projectee with + | { query_env; query_decl; query_name; query_index; query_range; + query_fuel; query_ifuel; query_rlimit; query_hint; query_errors; + query_all_labels; query_suffix; query_hash; + query_can_be_split_and_retried; query_term;_} -> query_range +let (__proj__Mkquery_settings__item__query_fuel : + query_settings -> Prims.int) = + fun projectee -> + match projectee with + | { query_env; query_decl; query_name; query_index; query_range; + query_fuel; query_ifuel; query_rlimit; query_hint; query_errors; + query_all_labels; query_suffix; query_hash; + query_can_be_split_and_retried; query_term;_} -> query_fuel +let (__proj__Mkquery_settings__item__query_ifuel : + query_settings -> Prims.int) = + fun projectee -> + match projectee with + | { query_env; query_decl; query_name; query_index; query_range; + query_fuel; query_ifuel; query_rlimit; query_hint; query_errors; + query_all_labels; query_suffix; query_hash; + query_can_be_split_and_retried; query_term;_} -> query_ifuel +let (__proj__Mkquery_settings__item__query_rlimit : + query_settings -> Prims.int) = + fun projectee -> + match projectee with + | { query_env; query_decl; query_name; query_index; query_range; + query_fuel; query_ifuel; query_rlimit; query_hint; query_errors; + query_all_labels; query_suffix; query_hash; + query_can_be_split_and_retried; query_term;_} -> query_rlimit +let (__proj__Mkquery_settings__item__query_hint : + query_settings -> + FStarC_SMTEncoding_UnsatCore.unsat_core FStar_Pervasives_Native.option) + = + fun projectee -> + match projectee with + | { query_env; query_decl; query_name; query_index; query_range; + query_fuel; query_ifuel; query_rlimit; query_hint; query_errors; + query_all_labels; query_suffix; query_hash; + query_can_be_split_and_retried; query_term;_} -> query_hint +let (__proj__Mkquery_settings__item__query_errors : + query_settings -> errors Prims.list) = + fun projectee -> + match projectee with + | { query_env; query_decl; query_name; query_index; query_range; + query_fuel; query_ifuel; query_rlimit; query_hint; query_errors; + query_all_labels; query_suffix; query_hash; + query_can_be_split_and_retried; query_term;_} -> query_errors +let (__proj__Mkquery_settings__item__query_all_labels : + query_settings -> FStarC_SMTEncoding_Term.error_labels) = + fun projectee -> + match projectee with + | { query_env; query_decl; query_name; query_index; query_range; + query_fuel; query_ifuel; query_rlimit; query_hint; query_errors; + query_all_labels; query_suffix; query_hash; + query_can_be_split_and_retried; query_term;_} -> query_all_labels +let (__proj__Mkquery_settings__item__query_suffix : + query_settings -> FStarC_SMTEncoding_Term.decl Prims.list) = + fun projectee -> + match projectee with + | { query_env; query_decl; query_name; query_index; query_range; + query_fuel; query_ifuel; query_rlimit; query_hint; query_errors; + query_all_labels; query_suffix; query_hash; + query_can_be_split_and_retried; query_term;_} -> query_suffix +let (__proj__Mkquery_settings__item__query_hash : + query_settings -> Prims.string FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { query_env; query_decl; query_name; query_index; query_range; + query_fuel; query_ifuel; query_rlimit; query_hint; query_errors; + query_all_labels; query_suffix; query_hash; + query_can_be_split_and_retried; query_term;_} -> query_hash +let (__proj__Mkquery_settings__item__query_can_be_split_and_retried : + query_settings -> Prims.bool) = + fun projectee -> + match projectee with + | { query_env; query_decl; query_name; query_index; query_range; + query_fuel; query_ifuel; query_rlimit; query_hint; query_errors; + query_all_labels; query_suffix; query_hash; + query_can_be_split_and_retried; query_term;_} -> + query_can_be_split_and_retried +let (__proj__Mkquery_settings__item__query_term : + query_settings -> FStarC_Syntax_Syntax.term) = + fun projectee -> + match projectee with + | { query_env; query_decl; query_name; query_index; query_range; + query_fuel; query_ifuel; query_rlimit; query_hint; query_errors; + query_all_labels; query_suffix; query_hash; + query_can_be_split_and_retried; query_term;_} -> query_term +let (convert_rlimit : Prims.int -> Prims.int) = + fun r -> + let uu___ = + let uu___1 = FStarC_Options.z3_version () in + FStarC_Compiler_Misc.version_ge uu___1 "4.12.3" in + if uu___ + then (Prims.parse_int "500000") * r + else (Prims.parse_int "544656") * r +let (with_fuel_and_diagnostics : + query_settings -> + FStarC_SMTEncoding_Term.decl Prims.list -> + FStarC_SMTEncoding_Term.decl Prims.list) + = + fun settings -> + fun label_assumptions -> + let n = settings.query_fuel in + let i = settings.query_ifuel in + let rlimit = convert_rlimit settings.query_rlimit in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Compiler_Util.string_of_int n in + let uu___4 = FStarC_Compiler_Util.string_of_int i in + FStarC_Compiler_Util.format2 "" uu___3 + uu___4 in + FStarC_SMTEncoding_Term.Caption uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = FStarC_SMTEncoding_Util.mkApp ("MaxFuel", []) in + let uu___8 = FStarC_SMTEncoding_Term.n_fuel n in + (uu___7, uu___8) in + FStarC_SMTEncoding_Util.mkEq uu___6 in + (uu___5, FStar_Pervasives_Native.None, "@MaxFuel_assumption") in + FStarC_SMTEncoding_Util.mkAssume uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_SMTEncoding_Util.mkApp ("MaxIFuel", []) in + let uu___10 = FStarC_SMTEncoding_Term.n_fuel i in + (uu___9, uu___10) in + FStarC_SMTEncoding_Util.mkEq uu___8 in + (uu___7, FStar_Pervasives_Native.None, + "@MaxIFuel_assumption") in + FStarC_SMTEncoding_Util.mkAssume uu___6 in + [uu___5; settings.query_decl] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Compiler_Util.string_of_int rlimit in + ("rlimit", uu___6) in + FStarC_SMTEncoding_Term.SetOption uu___5 in + [uu___4; + FStarC_SMTEncoding_Term.CheckSat; + FStarC_SMTEncoding_Term.SetOption ("rlimit", "0"); + FStarC_SMTEncoding_Term.GetReasonUnknown; + FStarC_SMTEncoding_Term.GetUnsatCore] in + let uu___4 = + let uu___5 = + let uu___6 = + (FStarC_Options.print_z3_statistics ()) || + (FStarC_Options.query_stats ()) in + if uu___6 then [FStarC_SMTEncoding_Term.GetStatistics] else [] in + FStarC_Compiler_List.op_At uu___5 settings.query_suffix in + FStarC_Compiler_List.op_At uu___3 uu___4 in + FStarC_Compiler_List.op_At label_assumptions uu___2 in + FStarC_Compiler_List.op_At uu___ uu___1 +let (used_hint : query_settings -> Prims.bool) = + fun s -> FStarC_Compiler_Option.isSome s.query_hint +let (get_hint_for : + Prims.string -> + Prims.int -> FStarC_Compiler_Hints.hint FStar_Pervasives_Native.option) + = + fun qname -> + fun qindex -> + let uu___ = FStarC_Compiler_Effect.op_Bang replaying_hints in + match uu___ with + | FStar_Pervasives_Native.Some hints -> + FStarC_Compiler_Util.find_map hints + (fun uu___1 -> + match uu___1 with + | FStar_Pervasives_Native.Some hint when + (hint.FStarC_Compiler_Hints.hint_name = qname) && + (hint.FStarC_Compiler_Hints.hint_index = qindex) + -> FStar_Pervasives_Native.Some hint + | uu___2 -> FStar_Pervasives_Native.None) + | uu___1 -> FStar_Pervasives_Native.None +let (query_errors : + query_settings -> + FStarC_SMTEncoding_Z3.z3result -> errors FStar_Pervasives_Native.option) + = + fun settings -> + fun z3result -> + match z3result.FStarC_SMTEncoding_Z3.z3result_status with + | FStarC_SMTEncoding_Z3.UNSAT uu___ -> FStar_Pervasives_Native.None + | uu___ -> + let uu___1 = + FStarC_SMTEncoding_Z3.status_string_and_errors + z3result.FStarC_SMTEncoding_Z3.z3result_status in + (match uu___1 with + | (msg, error_labels) -> + let err = + let uu___2 = + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with + | (uu___4, x, y) -> + let uu___5 = FStarC_Errors.get_ctx () in + (FStarC_Errors_Codes.Error_Z3SolverError, x, y, + uu___5)) error_labels in + { + error_reason = msg; + error_rlimit = (settings.query_rlimit); + error_fuel = (settings.query_fuel); + error_ifuel = (settings.query_ifuel); + error_hint = (settings.query_hint); + error_messages = uu___2 + } in + FStar_Pervasives_Native.Some err) +let (detail_hint_replay : + query_settings -> FStarC_SMTEncoding_Z3.z3result -> unit) = + fun settings -> + fun z3result -> + let uu___ = + (used_hint settings) && (FStarC_Options.detail_hint_replay ()) in + if uu___ + then + match z3result.FStarC_SMTEncoding_Z3.z3result_status with + | FStarC_SMTEncoding_Z3.UNSAT uu___1 -> () + | _failed -> + let ask_z3 label_assumptions = + let uu___1 = + with_fuel_and_diagnostics settings label_assumptions in + let uu___2 = + let uu___3 = + FStarC_Compiler_Util.string_of_int settings.query_index in + FStarC_Compiler_Util.format2 "(%s, %s)" settings.query_name + uu___3 in + FStarC_SMTEncoding_Z3.ask settings.query_range + settings.query_hash settings.query_all_labels uu___1 uu___2 + false FStar_Pervasives_Native.None in + FStarC_SMTEncoding_ErrorReporting.detail_errors true + (settings.query_env).FStarC_SMTEncoding_Env.tcenv + settings.query_all_labels ask_z3 + else () +let (find_localized_errors : + errors Prims.list -> errors FStar_Pervasives_Native.option) = + fun errs -> + FStarC_Compiler_List.tryFind + (fun err -> match err.error_messages with | [] -> false | uu___ -> true) + errs +let (errors_to_report : + Prims.bool -> query_settings -> FStarC_Errors.error Prims.list) = + fun tried_recovery -> + fun settings -> + let format_smt_error msg = + let d = + let uu___ = FStarC_Pprint.doc_of_string "SMT solver says:" in + let uu___1 = + let uu___2 = FStarC_Errors_Msg.sublist FStarC_Pprint.empty msg in + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Pprint.doc_of_string "Note:" in + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Errors_Msg.text + "'canceled' or 'resource limits reached' means the SMT query timed out, so you might want to increase the rlimit" in + let uu___9 = + let uu___10 = + FStarC_Errors_Msg.text + "'incomplete quantifiers' means Z3 could not prove the query, so try to spell out your proof out in greater detail, increase fuel or ifuel" in + let uu___11 = + let uu___12 = + FStarC_Errors_Msg.text + "'unknown' means Z3 provided no further reason for the proof failing" in + [uu___12] in + uu___10 :: uu___11 in + uu___8 :: uu___9 in + FStarC_Errors_Msg.bulleted uu___7 in + FStarC_Pprint.op_Hat_Hat uu___5 uu___6 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline uu___4 in + FStarC_Pprint.op_Hat_Hat uu___2 uu___3 in + FStarC_Pprint.op_Hat_Hat uu___ uu___1 in + [d] in + let recovery_failed_msg = + if tried_recovery + then + let uu___ = + FStarC_Errors_Msg.text + "This query was retried due to the --proof_recovery option, yet it\n still failed on all attempts." in + [uu___] + else [] in + let basic_errors = + let smt_error = + let uu___ = FStarC_Options.query_stats () in + if uu___ + then + let uu___1 = + let uu___2 = + FStarC_Compiler_List.map error_to_short_string + settings.query_errors in + FStarC_Compiler_List.map FStarC_Pprint.doc_of_string uu___2 in + format_smt_error uu___1 + else + (let uu___2 = + FStarC_Compiler_List.fold_left + (fun uu___3 -> + fun err -> + match uu___3 with + | (ic, cc, uc, bc) -> + let err1 = + FStarC_Compiler_Util.substring_from + err.error_reason + (FStarC_Compiler_String.length + "unknown because ") in + if + FStarC_Compiler_Util.starts_with err1 + "(incomplete" + then ((ic + Prims.int_one), cc, uc, bc) + else + if + ((FStarC_Compiler_Util.starts_with err1 + "canceled") + || + (FStarC_Compiler_Util.starts_with err1 + "(resource")) + || + (FStarC_Compiler_Util.starts_with err1 + "timeout") + then (ic, (cc + Prims.int_one), uc, bc) + else + if + FStarC_Compiler_Util.starts_with err1 + "Overflow encountered when expanding old_vector" + then (ic, cc, uc, (bc + Prims.int_one)) + else (ic, cc, (uc + Prims.int_one), bc)) + (Prims.int_zero, Prims.int_zero, Prims.int_zero, + Prims.int_zero) settings.query_errors in + match uu___2 with + | (incomplete_count, canceled_count, unknown_count, + z3_overflow_bug_count) -> + (if z3_overflow_bug_count > Prims.int_zero + then + (let uu___4 = + let uu___5 = + FStarC_Errors_Msg.text + "Z3 ran into an internal overflow while trying to prove this query." in + let uu___6 = + let uu___7 = + FStarC_Errors_Msg.text + "Try breaking it down, or using --split_queries." in + [uu___7] in + uu___5 :: uu___6 in + FStarC_Errors.log_issue + FStarC_Class_HasRange.hasRange_range + settings.query_range + FStarC_Errors_Codes.Warning_UnexpectedZ3Stderr () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___4)) + else (); + (let base = + match (incomplete_count, canceled_count, unknown_count) + with + | (uu___4, uu___5, uu___6) when + ((uu___5 = Prims.int_zero) && + (uu___6 = Prims.int_zero)) + && (incomplete_count > Prims.int_zero) + -> + let uu___7 = + FStarC_Errors_Msg.text + "The SMT solver could not prove the query. Use --query_stats for more details." in + [uu___7] + | (uu___4, uu___5, uu___6) when + ((uu___4 = Prims.int_zero) && + (uu___6 = Prims.int_zero)) + && (canceled_count > Prims.int_zero) + -> + let uu___7 = + FStarC_Errors_Msg.text + "The SMT query timed out, you might want to increase the rlimit" in + [uu___7] + | (uu___4, uu___5, uu___6) -> + let uu___7 = + FStarC_Errors_Msg.text + "Try with --query_stats to get more details" in + [uu___7] in + FStarC_Compiler_List.op_At base recovery_failed_msg))) in + let uu___ = + let uu___1 = find_localized_errors settings.query_errors in + (uu___1, (settings.query_all_labels)) in + match uu___ with + | (FStar_Pervasives_Native.Some err, uu___1) -> + FStarC_TypeChecker_Err.errors_smt_detail + (settings.query_env).FStarC_SMTEncoding_Env.tcenv + err.error_messages smt_error + | (FStar_Pervasives_Native.None, (uu___1, msg, rng)::[]) -> + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Errors.get_ctx () in + (FStarC_Errors_Codes.Error_Z3SolverError, msg, rng, uu___4) in + [uu___3] in + FStarC_TypeChecker_Err.errors_smt_detail + (settings.query_env).FStarC_SMTEncoding_Env.tcenv uu___2 + recovery_failed_msg + | (FStar_Pervasives_Native.None, uu___1) -> + if settings.query_can_be_split_and_retried + then FStarC_Compiler_Effect.raise SplitQueryAndRetry + else + (let l = FStarC_Compiler_List.length settings.query_all_labels in + let labels = + if l = Prims.int_zero + then + let dummy_fv = + FStarC_SMTEncoding_Term.mk_fv + ("", FStarC_SMTEncoding_Term.dummy_sort) in + let msg = + let uu___3 = + let uu___4 = + FStarC_Errors_Msg.text + "Failed to prove the following goal, although it appears to be trivial:" in + let uu___5 = + FStarC_Class_PP.pp FStarC_Syntax_Print.pretty_term + settings.query_term in + FStarC_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in + [uu___3] in + let range = + FStarC_TypeChecker_Env.get_range + (settings.query_env).FStarC_SMTEncoding_Env.tcenv in + [(dummy_fv, msg, range)] + else + if l > Prims.int_one + then + ((let uu___5 = + let uu___6 = FStarC_Options.split_queries () in + uu___6 <> FStarC_Options.No in + if uu___5 + then + let uu___6 = + FStarC_TypeChecker_Env.get_range + (settings.query_env).FStarC_SMTEncoding_Env.tcenv in + FStarC_TypeChecker_Err.log_issue_text + (settings.query_env).FStarC_SMTEncoding_Env.tcenv + uu___6 + (FStarC_Errors_Codes.Warning_SplitAndRetryQueries, + "The verification condition was to be split into several atomic sub-goals, but this query has multiple sub-goals---the error report may be inaccurate") + else ()); + settings.query_all_labels) + else settings.query_all_labels in + FStarC_Compiler_List.collect + (fun uu___3 -> + match uu___3 with + | (uu___4, msg, rng) -> + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Errors.get_ctx () in + (FStarC_Errors_Codes.Error_Z3SolverError, msg, + rng, uu___7) in + [uu___6] in + FStarC_TypeChecker_Err.errors_smt_detail + (settings.query_env).FStarC_SMTEncoding_Env.tcenv + uu___5 recovery_failed_msg) labels) in + (let uu___ = FStarC_Options.detail_errors () in + if uu___ + then + let initial_fuel = + let uu___1 = FStarC_Options.initial_fuel () in + let uu___2 = FStarC_Options.initial_ifuel () in + { + query_env = (settings.query_env); + query_decl = (settings.query_decl); + query_name = (settings.query_name); + query_index = (settings.query_index); + query_range = (settings.query_range); + query_fuel = uu___1; + query_ifuel = uu___2; + query_rlimit = (settings.query_rlimit); + query_hint = FStar_Pervasives_Native.None; + query_errors = (settings.query_errors); + query_all_labels = (settings.query_all_labels); + query_suffix = (settings.query_suffix); + query_hash = (settings.query_hash); + query_can_be_split_and_retried = + (settings.query_can_be_split_and_retried); + query_term = (settings.query_term) + } in + let ask_z3 label_assumptions = + let uu___1 = + with_fuel_and_diagnostics initial_fuel label_assumptions in + let uu___2 = + let uu___3 = + FStarC_Compiler_Util.string_of_int settings.query_index in + FStarC_Compiler_Util.format2 "(%s, %s)" settings.query_name + uu___3 in + FStarC_SMTEncoding_Z3.ask settings.query_range settings.query_hash + settings.query_all_labels uu___1 uu___2 false + FStar_Pervasives_Native.None in + FStarC_SMTEncoding_ErrorReporting.detail_errors false + (settings.query_env).FStarC_SMTEncoding_Env.tcenv + settings.query_all_labels ask_z3 + else ()); + basic_errors +let (report_errors : Prims.bool -> query_settings -> unit) = + fun tried_recovery -> + fun qry_settings -> + let uu___ = errors_to_report tried_recovery qry_settings in + FStarC_Errors.add_errors uu___ +type unique_string_accumulator = + { + add: Prims.string -> unit ; + get: unit -> Prims.string Prims.list ; + clear: unit -> unit } +let (__proj__Mkunique_string_accumulator__item__add : + unique_string_accumulator -> Prims.string -> unit) = + fun projectee -> match projectee with | { add; get; clear;_} -> add +let (__proj__Mkunique_string_accumulator__item__get : + unique_string_accumulator -> unit -> Prims.string Prims.list) = + fun projectee -> match projectee with | { add; get; clear;_} -> get +let (__proj__Mkunique_string_accumulator__item__clear : + unique_string_accumulator -> unit -> unit) = + fun projectee -> match projectee with | { add; get; clear;_} -> clear +let (mk_unique_string_accumulator : unit -> unique_string_accumulator) = + fun uu___ -> + let strings = FStarC_Compiler_Util.mk_ref [] in + let add m = + let ms = FStarC_Compiler_Effect.op_Bang strings in + if FStarC_Compiler_List.contains m ms + then () + else FStarC_Compiler_Effect.op_Colon_Equals strings (m :: ms) in + let get uu___1 = + let uu___2 = FStarC_Compiler_Effect.op_Bang strings in + FStarC_Compiler_Util.sort_with FStarC_Compiler_String.compare uu___2 in + let clear uu___1 = FStarC_Compiler_Effect.op_Colon_Equals strings [] in + { add; get; clear } +let (query_info : query_settings -> FStarC_SMTEncoding_Z3.z3result -> unit) = + fun settings -> + fun z3result -> + let process_unsat_core core = + let uu___ = mk_unique_string_accumulator () in + match uu___ with + | { add = add_module_name; get = get_module_names; clear = uu___1;_} + -> + let add_module_name1 s = add_module_name s in + let uu___2 = mk_unique_string_accumulator () in + (match uu___2 with + | { add = add_discarded_name; get = get_discarded_names; + clear = uu___3;_} -> + let parse_axiom_name s = + let chars = FStarC_Compiler_String.list_of_string s in + let first_upper_index = + FStarC_Compiler_Util.try_find_index + FStarC_Compiler_Util.is_upper chars in + match first_upper_index with + | FStar_Pervasives_Native.None -> + (add_discarded_name s; []) + | FStar_Pervasives_Native.Some first_upper_index1 -> + let name_and_suffix = + FStarC_Compiler_Util.substring_from s + first_upper_index1 in + let components = + FStarC_Compiler_String.split [46] name_and_suffix in + let excluded_suffixes = + ["fuel_instrumented"; + "_pretyping"; + "_Tm_refine"; + "_Tm_abs"; + "@"; + "_interpretation_Tm_arrow"; + "MaxFuel_assumption"; + "MaxIFuel_assumption"] in + let exclude_suffix s1 = + let s2 = FStarC_Compiler_Util.trim_string s1 in + let sopt = + FStarC_Compiler_Util.find_map excluded_suffixes + (fun sfx -> + if FStarC_Compiler_Util.contains s2 sfx + then + let uu___4 = + FStarC_Compiler_List.hd + (FStarC_Compiler_Util.split s2 sfx) in + FStar_Pervasives_Native.Some uu___4 + else FStar_Pervasives_Native.None) in + match sopt with + | FStar_Pervasives_Native.None -> + if s2 = "" then [] else [s2] + | FStar_Pervasives_Native.Some s3 -> + if s3 = "" then [] else [s3] in + let components1 = + match components with + | [] -> [] + | uu___4 -> + let uu___5 = + FStarC_Compiler_Util.prefix components in + (match uu___5 with + | (lident, last) -> + let components2 = + let uu___6 = exclude_suffix last in + FStarC_Compiler_List.op_At lident uu___6 in + let module_name = + FStarC_Compiler_Util.prefix_until + (fun s1 -> + let uu___6 = + let uu___7 = + FStarC_Compiler_Util.char_at s1 + Prims.int_zero in + FStarC_Compiler_Util.is_upper + uu___7 in + Prims.op_Negation uu___6) + components2 in + ((match module_name with + | FStar_Pervasives_Native.None -> () + | FStar_Pervasives_Native.Some + (m, uu___7, uu___8) -> + add_module_name1 + (FStarC_Compiler_String.concat "." + m)); + components2)) in + if components1 = [] + then (add_discarded_name s; []) + else [FStarC_Compiler_String.concat "." components1] in + let should_log = + (FStarC_Options.hint_info ()) || + (FStarC_Options.query_stats ()) in + let maybe_log f = if should_log then f () else () in + (match core with + | FStar_Pervasives_Native.None -> + maybe_log + (fun uu___4 -> + FStarC_Compiler_Util.print_string + "no unsat core\n") + | FStar_Pervasives_Native.Some core1 -> + let core2 = + FStarC_Compiler_List.collect parse_axiom_name core1 in + maybe_log + (fun uu___4 -> + (let uu___6 = + let uu___7 = get_module_names () in + FStarC_Compiler_String.concat + "\nZ3 Proof Stats:\t" uu___7 in + FStarC_Compiler_Util.print1 + "Z3 Proof Stats: Modules relevant to this proof:\nZ3 Proof Stats:\t%s\n" + uu___6); + FStarC_Compiler_Util.print1 + "Z3 Proof Stats (Detail 1): Specifically:\nZ3 Proof Stats (Detail 1):\t%s\n" + (FStarC_Compiler_String.concat + "\nZ3 Proof Stats (Detail 1):\t" core2); + (let uu___7 = + let uu___8 = get_discarded_names () in + FStarC_Compiler_String.concat ", " uu___8 in + FStarC_Compiler_Util.print1 + "Z3 Proof Stats (Detail 2): Note, this report ignored the following names in the context: %s\n" + uu___7)))) in + let uu___ = + (FStarC_Options.hint_info ()) || (FStarC_Options.query_stats ()) in + if uu___ + then + let uu___1 = + FStarC_SMTEncoding_Z3.status_string_and_errors + z3result.FStarC_SMTEncoding_Z3.z3result_status in + match uu___1 with + | (status_string, errs) -> + let at_log_file = + match z3result.FStarC_SMTEncoding_Z3.z3result_log_file with + | FStar_Pervasives_Native.None -> "" + | FStar_Pervasives_Native.Some s -> Prims.strcat "@" s in + let uu___2 = + match z3result.FStarC_SMTEncoding_Z3.z3result_status with + | FStarC_SMTEncoding_Z3.UNSAT core -> + let uu___3 = + FStarC_Compiler_Util.colorize_green "succeeded" in + (uu___3, core) + | uu___3 -> + let uu___4 = + FStarC_Compiler_Util.colorize_red + (Prims.strcat "failed {reason-unknown=" + (Prims.strcat status_string "}")) in + (uu___4, FStar_Pervasives_Native.None) in + (match uu___2 with + | (tag, core) -> + let range = + let uu___3 = + let uu___4 = + FStarC_Class_Show.show + FStarC_Compiler_Range_Ops.showable_range + settings.query_range in + Prims.strcat uu___4 (Prims.strcat at_log_file ")") in + Prims.strcat "(" uu___3 in + let used_hint_tag = + if used_hint settings then " (with hint)" else "" in + let stats = + let uu___3 = FStarC_Options.query_stats () in + if uu___3 + then + let f k v a = + Prims.strcat a + (Prims.strcat k + (Prims.strcat "=" (Prims.strcat v " "))) in + let str = + FStarC_Compiler_Util.smap_fold + z3result.FStarC_SMTEncoding_Z3.z3result_statistics f + "statistics={" in + let uu___4 = + FStarC_Compiler_Util.substring str Prims.int_zero + ((FStarC_Compiler_String.length str) - Prims.int_one) in + Prims.strcat uu___4 "}" + else "" in + ((let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + settings.query_index in + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + z3result.FStarC_SMTEncoding_Z3.z3result_time in + let uu___12 = + let uu___13 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + settings.query_fuel in + let uu___14 = + let uu___15 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + settings.query_ifuel in + let uu___16 = + let uu___17 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + settings.query_rlimit in + [uu___17] in + uu___15 :: uu___16 in + uu___13 :: uu___14 in + uu___11 :: uu___12 in + used_hint_tag :: uu___10 in + tag :: uu___9 in + uu___7 :: uu___8 in + (settings.query_name) :: uu___6 in + range :: uu___5 in + FStarC_Compiler_Util.print + "%s\tQuery-stats (%s, %s)\t%s%s in %s milliseconds with fuel %s and ifuel %s and rlimit %s\n" + uu___4); + (let uu___5 = FStarC_Options.print_z3_statistics () in + if uu___5 then process_unsat_core core else ()); + FStarC_Compiler_List.iter + (fun uu___5 -> + match uu___5 with + | (uu___6, msg, range1) -> + let msg1 = + if used_hint settings + then + let uu___7 = + FStarC_Pprint.doc_of_string + "Hint-replay failed" in + uu___7 :: msg + else msg in + FStarC_Errors.log_issue + FStarC_Class_HasRange.hasRange_range range1 + FStarC_Errors_Codes.Warning_HitReplayFailed () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic msg1)) errs)) + else + (let uu___2 = + let uu___3 = FStarC_Options_Ext.get "profile_context" in + uu___3 <> "" in + if uu___2 + then + match z3result.FStarC_SMTEncoding_Z3.z3result_status with + | FStarC_SMTEncoding_Z3.UNSAT core -> process_unsat_core core + | uu___3 -> () + else ()) +let (store_hint : FStarC_Compiler_Hints.hint -> unit) = + fun hint -> + let uu___ = FStarC_Compiler_Effect.op_Bang recorded_hints in + match uu___ with + | FStar_Pervasives_Native.Some l -> + FStarC_Compiler_Effect.op_Colon_Equals recorded_hints + (FStar_Pervasives_Native.Some + (FStarC_Compiler_List.op_At l + [FStar_Pervasives_Native.Some hint])) + | uu___1 -> () +let (record_hint : query_settings -> FStarC_SMTEncoding_Z3.z3result -> unit) + = + fun settings -> + fun z3result -> + let uu___ = + let uu___1 = FStarC_Options.record_hints () in + Prims.op_Negation uu___1 in + if uu___ + then () + else + (let mk_hint core = + { + FStarC_Compiler_Hints.hint_name = (settings.query_name); + FStarC_Compiler_Hints.hint_index = (settings.query_index); + FStarC_Compiler_Hints.fuel = (settings.query_fuel); + FStarC_Compiler_Hints.ifuel = (settings.query_ifuel); + FStarC_Compiler_Hints.unsat_core = core; + FStarC_Compiler_Hints.query_elapsed_time = Prims.int_zero; + FStarC_Compiler_Hints.hash = + (match z3result.FStarC_SMTEncoding_Z3.z3result_status with + | FStarC_SMTEncoding_Z3.UNSAT core1 -> + z3result.FStarC_SMTEncoding_Z3.z3result_query_hash + | uu___2 -> FStar_Pervasives_Native.None) + } in + match z3result.FStarC_SMTEncoding_Z3.z3result_status with + | FStarC_SMTEncoding_Z3.UNSAT (FStar_Pervasives_Native.None) -> + let uu___2 = + let uu___3 = + get_hint_for settings.query_name settings.query_index in + FStarC_Compiler_Option.get uu___3 in + store_hint uu___2 + | FStarC_SMTEncoding_Z3.UNSAT unsat_core -> + if used_hint settings + then store_hint (mk_hint settings.query_hint) + else store_hint (mk_hint unsat_core) + | uu___2 -> ()) +let (process_result : + query_settings -> + FStarC_SMTEncoding_Z3.z3result -> errors FStar_Pervasives_Native.option) + = + fun settings -> + fun result -> + let errs = query_errors settings result in + query_info settings result; + record_hint settings result; + detail_hint_replay settings result; + errs +let (fold_queries : + query_settings Prims.list -> + (query_settings -> FStarC_SMTEncoding_Z3.z3result) -> + (query_settings -> + FStarC_SMTEncoding_Z3.z3result -> + errors FStar_Pervasives_Native.option) + -> (errors Prims.list, query_settings) FStar_Pervasives.either) + = + fun qs -> + fun ask -> + fun f -> + let rec aux acc qs1 = + match qs1 with + | [] -> FStar_Pervasives.Inl acc + | q::qs2 -> + let res = ask q in + let uu___ = f q res in + (match uu___ with + | FStar_Pervasives_Native.None -> FStar_Pervasives.Inr q + | FStar_Pervasives_Native.Some errs -> aux (errs :: acc) qs2) in + aux [] qs +let (full_query_id : query_settings -> Prims.string) = + fun settings -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Compiler_Util.string_of_int settings.query_index in + Prims.strcat uu___3 ")" in + Prims.strcat ", " uu___2 in + Prims.strcat settings.query_name uu___1 in + Prims.strcat "(" uu___ +let collect_dups : 'a . 'a Prims.list -> ('a * Prims.int) Prims.list = + fun l -> + let acc = [] in + let rec add_one acc1 x = + match acc1 with + | [] -> [(x, Prims.int_one)] + | (h, n)::t -> + if h = x + then (h, (n + Prims.int_one)) :: t + else (let uu___1 = add_one t x in (h, n) :: uu___1) in + FStarC_Compiler_List.fold_left add_one acc l +type answer = + { + ok: Prims.bool ; + cache_hit: Prims.bool ; + quaking: Prims.bool ; + quaking_or_retrying: Prims.bool ; + lo: Prims.int ; + hi: Prims.int ; + nsuccess: Prims.int ; + total_ran: Prims.int ; + tried_recovery: Prims.bool ; + errs: errors Prims.list Prims.list } +let (__proj__Mkanswer__item__ok : answer -> Prims.bool) = + fun projectee -> + match projectee with + | { ok; cache_hit; quaking; quaking_or_retrying; lo; hi; nsuccess; + total_ran; tried_recovery; errs;_} -> ok +let (__proj__Mkanswer__item__cache_hit : answer -> Prims.bool) = + fun projectee -> + match projectee with + | { ok; cache_hit; quaking; quaking_or_retrying; lo; hi; nsuccess; + total_ran; tried_recovery; errs;_} -> cache_hit +let (__proj__Mkanswer__item__quaking : answer -> Prims.bool) = + fun projectee -> + match projectee with + | { ok; cache_hit; quaking; quaking_or_retrying; lo; hi; nsuccess; + total_ran; tried_recovery; errs;_} -> quaking +let (__proj__Mkanswer__item__quaking_or_retrying : answer -> Prims.bool) = + fun projectee -> + match projectee with + | { ok; cache_hit; quaking; quaking_or_retrying; lo; hi; nsuccess; + total_ran; tried_recovery; errs;_} -> quaking_or_retrying +let (__proj__Mkanswer__item__lo : answer -> Prims.int) = + fun projectee -> + match projectee with + | { ok; cache_hit; quaking; quaking_or_retrying; lo; hi; nsuccess; + total_ran; tried_recovery; errs;_} -> lo +let (__proj__Mkanswer__item__hi : answer -> Prims.int) = + fun projectee -> + match projectee with + | { ok; cache_hit; quaking; quaking_or_retrying; lo; hi; nsuccess; + total_ran; tried_recovery; errs;_} -> hi +let (__proj__Mkanswer__item__nsuccess : answer -> Prims.int) = + fun projectee -> + match projectee with + | { ok; cache_hit; quaking; quaking_or_retrying; lo; hi; nsuccess; + total_ran; tried_recovery; errs;_} -> nsuccess +let (__proj__Mkanswer__item__total_ran : answer -> Prims.int) = + fun projectee -> + match projectee with + | { ok; cache_hit; quaking; quaking_or_retrying; lo; hi; nsuccess; + total_ran; tried_recovery; errs;_} -> total_ran +let (__proj__Mkanswer__item__tried_recovery : answer -> Prims.bool) = + fun projectee -> + match projectee with + | { ok; cache_hit; quaking; quaking_or_retrying; lo; hi; nsuccess; + total_ran; tried_recovery; errs;_} -> tried_recovery +let (__proj__Mkanswer__item__errs : answer -> errors Prims.list Prims.list) = + fun projectee -> + match projectee with + | { ok; cache_hit; quaking; quaking_or_retrying; lo; hi; nsuccess; + total_ran; tried_recovery; errs;_} -> errs +let (ans_ok : answer) = + { + ok = true; + cache_hit = false; + quaking = false; + quaking_or_retrying = false; + lo = Prims.int_one; + hi = Prims.int_one; + nsuccess = Prims.int_one; + total_ran = Prims.int_one; + tried_recovery = false; + errs = [] + } +let (ans_fail : answer) = + { + ok = false; + cache_hit = (ans_ok.cache_hit); + quaking = (ans_ok.quaking); + quaking_or_retrying = (ans_ok.quaking_or_retrying); + lo = (ans_ok.lo); + hi = (ans_ok.hi); + nsuccess = Prims.int_zero; + total_ran = (ans_ok.total_ran); + tried_recovery = (ans_ok.tried_recovery); + errs = (ans_ok.errs) + } +let (uu___0 : answer FStarC_Class_Show.showable) = + { + FStarC_Class_Show.show = + (fun ans -> + let uu___ = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) ans.ok in + let uu___1 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) ans.nsuccess in + let uu___2 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) ans.lo in + let uu___3 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) ans.hi in + let uu___4 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) ans.tried_recovery in + FStarC_Compiler_Util.format5 + "ok=%s nsuccess=%s lo=%s hi=%s tried_recovery=%s" uu___ uu___1 + uu___2 uu___3 uu___4) + } +let (make_solver_configs : + Prims.bool -> + Prims.bool -> + FStarC_SMTEncoding_Env.env_t -> + FStarC_SMTEncoding_Term.error_labels -> + FStarC_SMTEncoding_Term.decl -> + FStarC_Syntax_Syntax.term -> + FStarC_SMTEncoding_Term.decl Prims.list -> + (query_settings Prims.list * FStarC_Compiler_Hints.hint + FStar_Pervasives_Native.option)) + = + fun can_split -> + fun is_retry -> + fun env -> + fun all_labels -> + fun query -> + fun query_term -> + fun suffix -> + let uu___ = + let uu___1 = + match (env.FStarC_SMTEncoding_Env.tcenv).FStarC_TypeChecker_Env.qtbl_name_and_index + with + | (FStar_Pervasives_Native.None, uu___2) -> + failwith "No query name set!" + | (FStar_Pervasives_Native.Some (q, _typ, n), uu___2) -> + let uu___3 = FStarC_Ident.string_of_lid q in + (uu___3, n) in + match uu___1 with + | (qname, index) -> + let rlimit = + let uu___2 = FStarC_Options.z3_rlimit_factor () in + let uu___3 = FStarC_Options.z3_rlimit () in + uu___2 * uu___3 in + let next_hint = get_hint_for qname index in + let default_settings = + let uu___2 = + FStarC_TypeChecker_Env.get_range + env.FStarC_SMTEncoding_Env.tcenv in + let uu___3 = FStarC_Options.initial_fuel () in + let uu___4 = FStarC_Options.initial_ifuel () in + { + query_env = env; + query_decl = query; + query_name = qname; + query_index = index; + query_range = uu___2; + query_fuel = uu___3; + query_ifuel = uu___4; + query_rlimit = rlimit; + query_hint = FStar_Pervasives_Native.None; + query_errors = []; + query_all_labels = all_labels; + query_suffix = suffix; + query_hash = + (match next_hint with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some + { FStarC_Compiler_Hints.hint_name = uu___5; + FStarC_Compiler_Hints.hint_index = uu___6; + FStarC_Compiler_Hints.fuel = uu___7; + FStarC_Compiler_Hints.ifuel = uu___8; + FStarC_Compiler_Hints.unsat_core = uu___9; + FStarC_Compiler_Hints.query_elapsed_time = + uu___10; + FStarC_Compiler_Hints.hash = h;_} + -> h); + query_can_be_split_and_retried = can_split; + query_term + } in + (default_settings, next_hint) in + match uu___ with + | (default_settings, next_hint) -> + let use_hints_setting = + let uu___1 = + (use_hints ()) && + (FStarC_Compiler_Util.is_some next_hint) in + if uu___1 + then + let uu___2 = FStarC_Compiler_Util.must next_hint in + match uu___2 with + | { FStarC_Compiler_Hints.hint_name = uu___3; + FStarC_Compiler_Hints.hint_index = uu___4; + FStarC_Compiler_Hints.fuel = i; + FStarC_Compiler_Hints.ifuel = j; + FStarC_Compiler_Hints.unsat_core = + FStar_Pervasives_Native.Some core; + FStarC_Compiler_Hints.query_elapsed_time = uu___5; + FStarC_Compiler_Hints.hash = h;_} -> + [{ + query_env = (default_settings.query_env); + query_decl = (default_settings.query_decl); + query_name = (default_settings.query_name); + query_index = (default_settings.query_index); + query_range = (default_settings.query_range); + query_fuel = i; + query_ifuel = j; + query_rlimit = (default_settings.query_rlimit); + query_hint = + (FStar_Pervasives_Native.Some core); + query_errors = (default_settings.query_errors); + query_all_labels = + (default_settings.query_all_labels); + query_suffix = (default_settings.query_suffix); + query_hash = (default_settings.query_hash); + query_can_be_split_and_retried = + (default_settings.query_can_be_split_and_retried); + query_term = (default_settings.query_term) + }] + else [] in + let initial_fuel_max_ifuel = + let uu___1 = + let uu___2 = FStarC_Options.max_ifuel () in + let uu___3 = FStarC_Options.initial_ifuel () in + uu___2 > uu___3 in + if uu___1 + then + let uu___2 = + let uu___3 = FStarC_Options.max_ifuel () in + { + query_env = (default_settings.query_env); + query_decl = (default_settings.query_decl); + query_name = (default_settings.query_name); + query_index = (default_settings.query_index); + query_range = (default_settings.query_range); + query_fuel = (default_settings.query_fuel); + query_ifuel = uu___3; + query_rlimit = (default_settings.query_rlimit); + query_hint = (default_settings.query_hint); + query_errors = (default_settings.query_errors); + query_all_labels = + (default_settings.query_all_labels); + query_suffix = (default_settings.query_suffix); + query_hash = (default_settings.query_hash); + query_can_be_split_and_retried = + (default_settings.query_can_be_split_and_retried); + query_term = (default_settings.query_term) + } in + [uu___2] + else [] in + let half_max_fuel_max_ifuel = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Options.max_fuel () in + uu___3 / (Prims.of_int (2)) in + let uu___3 = FStarC_Options.initial_fuel () in + uu___2 > uu___3 in + if uu___1 + then + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Options.max_fuel () in + uu___4 / (Prims.of_int (2)) in + let uu___4 = FStarC_Options.max_ifuel () in + { + query_env = (default_settings.query_env); + query_decl = (default_settings.query_decl); + query_name = (default_settings.query_name); + query_index = (default_settings.query_index); + query_range = (default_settings.query_range); + query_fuel = uu___3; + query_ifuel = uu___4; + query_rlimit = (default_settings.query_rlimit); + query_hint = (default_settings.query_hint); + query_errors = (default_settings.query_errors); + query_all_labels = + (default_settings.query_all_labels); + query_suffix = (default_settings.query_suffix); + query_hash = (default_settings.query_hash); + query_can_be_split_and_retried = + (default_settings.query_can_be_split_and_retried); + query_term = (default_settings.query_term) + } in + [uu___2] + else [] in + let max_fuel_max_ifuel = + let uu___1 = + (let uu___2 = FStarC_Options.max_fuel () in + let uu___3 = FStarC_Options.initial_fuel () in + uu___2 > uu___3) && + (let uu___2 = FStarC_Options.max_ifuel () in + let uu___3 = FStarC_Options.initial_ifuel () in + uu___2 >= uu___3) in + if uu___1 + then + let uu___2 = + let uu___3 = FStarC_Options.max_fuel () in + let uu___4 = FStarC_Options.max_ifuel () in + { + query_env = (default_settings.query_env); + query_decl = (default_settings.query_decl); + query_name = (default_settings.query_name); + query_index = (default_settings.query_index); + query_range = (default_settings.query_range); + query_fuel = uu___3; + query_ifuel = uu___4; + query_rlimit = (default_settings.query_rlimit); + query_hint = (default_settings.query_hint); + query_errors = (default_settings.query_errors); + query_all_labels = + (default_settings.query_all_labels); + query_suffix = (default_settings.query_suffix); + query_hash = (default_settings.query_hash); + query_can_be_split_and_retried = + (default_settings.query_can_be_split_and_retried); + query_term = (default_settings.query_term) + } in + [uu___2] + else [] in + let cfgs = + if is_retry + then [default_settings] + else + FStarC_Compiler_List.op_At use_hints_setting + (FStarC_Compiler_List.op_At [default_settings] + (FStarC_Compiler_List.op_At + initial_fuel_max_ifuel + (FStarC_Compiler_List.op_At + half_max_fuel_max_ifuel max_fuel_max_ifuel))) in + (cfgs, next_hint) +let (__ask_solver : + query_settings Prims.list -> + (errors Prims.list, query_settings) FStar_Pervasives.either) + = + fun configs -> + let check_one_config config = + (let uu___1 = FStarC_Options.z3_refresh () in + if uu___1 + then + FStarC_SMTEncoding_Z3.refresh + (FStar_Pervasives_Native.Some + (((config.query_env).FStarC_SMTEncoding_Env.tcenv).FStarC_TypeChecker_Env.proof_ns)) + else ()); + (let uu___1 = with_fuel_and_diagnostics config [] in + let uu___2 = + let uu___3 = FStarC_Compiler_Util.string_of_int config.query_index in + FStarC_Compiler_Util.format2 "(%s, %s)" config.query_name uu___3 in + FStarC_SMTEncoding_Z3.ask config.query_range config.query_hash + config.query_all_labels uu___1 uu___2 (used_hint config) + config.query_hint) in + fold_queries configs check_one_config process_result +let (ask_solver_quake : query_settings Prims.list -> answer) = + fun configs -> + let lo = FStarC_Options.quake_lo () in + let hi = FStarC_Options.quake_hi () in + let seed = FStarC_Options.z3_seed () in + let default_settings = FStarC_Compiler_List.hd configs in + let name = full_query_id default_settings in + let quaking = + (hi > Prims.int_one) && + (let uu___ = FStarC_Options.retry () in Prims.op_Negation uu___) in + let quaking_or_retrying = hi > Prims.int_one in + let hi1 = if hi < Prims.int_one then Prims.int_one else hi in + let lo1 = + if lo < Prims.int_one + then Prims.int_one + else if lo > hi1 then hi1 else lo in + let run_one seed1 = + let uu___ = FStarC_Options.z3_refresh () in + if uu___ + then + FStarC_Options.with_saved_options + (fun uu___1 -> + FStarC_Options.set_option "z3seed" (FStarC_Options.Int seed1); + __ask_solver configs) + else __ask_solver configs in + let rec fold_nat' f acc lo2 hi2 = + if lo2 > hi2 + then acc + else + (let uu___1 = f acc lo2 in + fold_nat' f uu___1 (lo2 + Prims.int_one) hi2) in + let best_fuel = FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None in + let best_ifuel = FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None in + let maybe_improve r n = + let uu___ = FStarC_Compiler_Effect.op_Bang r in + match uu___ with + | FStar_Pervasives_Native.None -> + FStarC_Compiler_Effect.op_Colon_Equals r + (FStar_Pervasives_Native.Some n) + | FStar_Pervasives_Native.Some m -> + if n < m + then + FStarC_Compiler_Effect.op_Colon_Equals r + (FStar_Pervasives_Native.Some n) + else () in + let uu___ = + fold_nat' + (fun uu___1 -> + fun n -> + match uu___1 with + | (nsucc, nfail, rs) -> + let uu___2 = + (let uu___3 = FStarC_Options.quake_keep () in + Prims.op_Negation uu___3) && + ((nsucc >= lo1) || (nfail > (hi1 - lo1))) in + if uu___2 + then (nsucc, nfail, rs) + else + ((let uu___5 = + (quaking_or_retrying && + ((FStarC_Options.interactive ()) || + (FStarC_Compiler_Debug.any ()))) + && (n > Prims.int_zero) in + if uu___5 + then + let uu___6 = + if quaking + then + let uu___7 = + FStarC_Compiler_Util.string_of_int nsucc in + FStarC_Compiler_Util.format1 + "succeeded %s times and " uu___7 + else "" in + let uu___7 = + if quaking + then FStarC_Compiler_Util.string_of_int nfail + else + (let uu___9 = + FStarC_Compiler_Util.string_of_int nfail in + Prims.strcat uu___9 " times") in + let uu___8 = + FStarC_Compiler_Util.string_of_int (hi1 - n) in + FStarC_Compiler_Util.print5 + "%s: so far query %s %sfailed %s (%s runs remain)\n" + (if quaking then "Quake" else "Retry") name uu___6 + uu___7 uu___8 + else ()); + (let r = run_one (seed + n) in + let uu___5 = + match r with + | FStar_Pervasives.Inr cfg -> + (maybe_improve best_fuel cfg.query_fuel; + maybe_improve best_ifuel cfg.query_ifuel; + ((nsucc + Prims.int_one), nfail)) + | uu___6 -> (nsucc, (nfail + Prims.int_one)) in + match uu___5 with + | (nsucc1, nfail1) -> (nsucc1, nfail1, (r :: rs))))) + (Prims.int_zero, Prims.int_zero, []) Prims.int_zero + (hi1 - Prims.int_one) in + match uu___ with + | (nsuccess, nfailures, rs) -> + let total_ran = nsuccess + nfailures in + (if quaking + then + (let fuel_msg = + let uu___2 = + let uu___3 = FStarC_Compiler_Effect.op_Bang best_fuel in + let uu___4 = FStarC_Compiler_Effect.op_Bang best_ifuel in + (uu___3, uu___4) in + match uu___2 with + | (FStar_Pervasives_Native.Some f, FStar_Pervasives_Native.Some + i) -> + let uu___3 = FStarC_Compiler_Util.string_of_int f in + let uu___4 = FStarC_Compiler_Util.string_of_int i in + FStarC_Compiler_Util.format2 + " (best fuel=%s, best ifuel=%s)" uu___3 uu___4 + | (uu___3, uu___4) -> "" in + let uu___2 = FStarC_Compiler_Util.string_of_int nsuccess in + let uu___3 = FStarC_Compiler_Util.string_of_int total_ran in + FStarC_Compiler_Util.print5 + "Quake: query %s succeeded %s/%s times%s%s\n" name uu___2 + uu___3 (if total_ran < hi1 then " (early finish)" else "") + fuel_msg) + else (); + (let all_errs = + FStarC_Compiler_List.concatMap + (fun uu___2 -> + match uu___2 with + | FStar_Pervasives.Inr uu___3 -> [] + | FStar_Pervasives.Inl es -> [es]) rs in + { + ok = (nsuccess >= lo1); + cache_hit = false; + quaking; + quaking_or_retrying; + lo = lo1; + hi = hi1; + nsuccess; + total_ran; + tried_recovery = false; + errs = all_errs + })) +type recovery_hammer = + | IncreaseRLimit of Prims.int + | RestartAnd of recovery_hammer +let (uu___is_IncreaseRLimit : recovery_hammer -> Prims.bool) = + fun projectee -> + match projectee with | IncreaseRLimit _0 -> true | uu___ -> false +let (__proj__IncreaseRLimit__item___0 : recovery_hammer -> Prims.int) = + fun projectee -> match projectee with | IncreaseRLimit _0 -> _0 +let (uu___is_RestartAnd : recovery_hammer -> Prims.bool) = + fun projectee -> + match projectee with | RestartAnd _0 -> true | uu___ -> false +let (__proj__RestartAnd__item___0 : recovery_hammer -> recovery_hammer) = + fun projectee -> match projectee with | RestartAnd _0 -> _0 +let rec (pp_hammer : recovery_hammer -> FStarC_Pprint.document) = + fun h -> + match h with + | IncreaseRLimit factor -> + let uu___ = FStarC_Errors_Msg.text "increasing its rlimit by" in + let uu___1 = + let uu___2 = FStarC_Class_PP.pp FStarC_Class_PP.pp_int factor in + let uu___3 = FStarC_Pprint.doc_of_string "x" in + FStarC_Pprint.op_Hat_Hat uu___2 uu___3 in + FStarC_Pprint.op_Hat_Slash_Hat uu___ uu___1 + | RestartAnd h1 -> + let uu___ = FStarC_Errors_Msg.text "restarting the solver and" in + let uu___1 = pp_hammer h1 in + FStarC_Pprint.op_Hat_Slash_Hat uu___ uu___1 +let (ask_solver_recover : query_settings Prims.list -> answer) = + fun configs -> + let uu___ = FStarC_Options.proof_recovery () in + if uu___ + then + let r = ask_solver_quake configs in + (if r.ok + then r + else + (let restarted = FStarC_Compiler_Util.mk_ref false in + let cfg = FStarC_Compiler_List.last configs in + (let uu___3 = + let uu___4 = + FStarC_Errors_Msg.text + "This query failed to be solved. Will now retry with higher rlimits due to --proof_recovery." in + [uu___4] in + FStarC_Errors.diag FStarC_Class_HasRange.hasRange_range + cfg.query_range () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___3)); + (let try_factor n = + (let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Errors_Msg.text + "Retrying query with rlimit factor" in + let uu___7 = FStarC_Class_PP.pp FStarC_Class_PP.pp_int n in + FStarC_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in + [uu___5] in + FStarC_Errors.diag FStarC_Class_HasRange.hasRange_range + cfg.query_range () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___4)); + (let cfg1 = + { + query_env = (cfg.query_env); + query_decl = (cfg.query_decl); + query_name = (cfg.query_name); + query_index = (cfg.query_index); + query_range = (cfg.query_range); + query_fuel = (cfg.query_fuel); + query_ifuel = (cfg.query_ifuel); + query_rlimit = (n * cfg.query_rlimit); + query_hint = (cfg.query_hint); + query_errors = (cfg.query_errors); + query_all_labels = (cfg.query_all_labels); + query_suffix = (cfg.query_suffix); + query_hash = (cfg.query_hash); + query_can_be_split_and_retried = + (cfg.query_can_be_split_and_retried); + query_term = (cfg.query_term) + } in + ask_solver_quake [cfg1]) in + let rec try_hammer h = + match h with + | IncreaseRLimit factor -> try_factor factor + | RestartAnd h1 -> + ((let uu___4 = + let uu___5 = + FStarC_Errors_Msg.text "Trying a solver restart" in + [uu___5] in + FStarC_Errors.diag FStarC_Class_HasRange.hasRange_range + cfg.query_range () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___4)); + (((cfg.query_env).FStarC_SMTEncoding_Env.tcenv).FStarC_TypeChecker_Env.solver).FStarC_TypeChecker_Env.refresh + (FStar_Pervasives_Native.Some + (((cfg.query_env).FStarC_SMTEncoding_Env.tcenv).FStarC_TypeChecker_Env.proof_ns)); + try_hammer h1) in + let rec aux hammers = + match hammers with + | [] -> + { + ok = (r.ok); + cache_hit = (r.cache_hit); + quaking = (r.quaking); + quaking_or_retrying = (r.quaking_or_retrying); + lo = (r.lo); + hi = (r.hi); + nsuccess = (r.nsuccess); + total_ran = (r.total_ran); + tried_recovery = true; + errs = (r.errs) + } + | h::hs -> + let r1 = try_hammer h in + if r1.ok + then + ((let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Errors_Msg.text + "This query succeeded after " in + let uu___7 = pp_hammer h in + FStarC_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in + let uu___6 = + let uu___7 = + FStarC_Errors_Msg.text + "Increase the rlimit in the file or simplify the proof. This is only succeeding due to --proof_recovery being given." in + [uu___7] in + uu___5 :: uu___6 in + FStarC_Errors.log_issue + FStarC_Class_HasRange.hasRange_range cfg.query_range + FStarC_Errors_Codes.Warning_ProofRecovery () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___4)); + r1) + else aux hs in + aux + [IncreaseRLimit (Prims.of_int (2)); + IncreaseRLimit (Prims.of_int (4)); + IncreaseRLimit (Prims.of_int (8)); + RestartAnd (IncreaseRLimit (Prims.of_int (8)))]))) + else ask_solver_quake configs +let (failing_query_ctr : Prims.int FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref Prims.int_zero +let (maybe_save_failing_query : + FStarC_SMTEncoding_Env.env_t -> query_settings -> unit) = + fun env -> + fun qs -> + (let uu___1 = FStarC_Options.log_failing_queries () in + if uu___1 + then + let mod1 = + let uu___2 = + FStarC_TypeChecker_Env.current_module + env.FStarC_SMTEncoding_Env.tcenv in + FStarC_Class_Show.show FStarC_Ident.showable_lident uu___2 in + let n = + (let uu___3 = + let uu___4 = FStarC_Compiler_Effect.op_Bang failing_query_ctr in + uu___4 + Prims.int_one in + FStarC_Compiler_Effect.op_Colon_Equals failing_query_ctr uu___3); + FStarC_Compiler_Effect.op_Bang failing_query_ctr in + let file_name = + let uu___2 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) n in + FStarC_Compiler_Util.format2 "failedQueries-%s-%s.smt2" mod1 + uu___2 in + let query_str = + let uu___2 = with_fuel_and_diagnostics qs [] in + let uu___3 = + let uu___4 = FStarC_Compiler_Util.string_of_int qs.query_index in + FStarC_Compiler_Util.format2 "(%s, %s)" qs.query_name uu___4 in + FStarC_SMTEncoding_Z3.ask_text qs.query_range qs.query_hash + qs.query_all_labels uu___2 uu___3 qs.query_hint in + FStarC_Compiler_Util.write_file file_name query_str + else ()); + (let uu___2 = FStarC_Compiler_Effect.op_Bang dbg_SMTFail in + if uu___2 + then + let uu___3 = + let uu___4 = FStarC_Errors_Msg.text "This query failed:" in + let uu___5 = + let uu___6 = + FStarC_Class_PP.pp FStarC_Syntax_Print.pretty_term + qs.query_term in + [uu___6] in + uu___4 :: uu___5 in + FStarC_Errors.diag FStarC_Class_HasRange.hasRange_range + qs.query_range () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___3) + else ()) +let (ask_solver : + FStarC_SMTEncoding_Env.env_t -> + query_settings Prims.list -> + FStarC_Compiler_Hints.hint FStar_Pervasives_Native.option -> + (query_settings Prims.list * answer)) + = + fun env -> + fun configs -> + fun next_hint -> + let default_settings = FStarC_Compiler_List.hd configs in + let skip = + ((env.FStarC_SMTEncoding_Env.tcenv).FStarC_TypeChecker_Env.admit || + (FStarC_TypeChecker_Env.too_early_in_prims + env.FStarC_SMTEncoding_Env.tcenv)) + || + (let uu___ = FStarC_Options.admit_except () in + match uu___ with + | FStar_Pervasives_Native.Some id -> + if FStarC_Compiler_Util.starts_with id "(" + then + let uu___1 = full_query_id default_settings in + uu___1 <> id + else default_settings.query_name <> id + | FStar_Pervasives_Native.None -> false) in + let ans = + if skip + then + ((let uu___1 = + (FStarC_Options.record_hints ()) && + (FStarC_Compiler_Util.is_some next_hint) in + if uu___1 + then + let uu___2 = FStarC_Compiler_Util.must next_hint in + store_hint uu___2 + else ()); + ans_ok) + else + (let ans1 = ask_solver_recover configs in + let cfg = FStarC_Compiler_List.last configs in + if Prims.op_Negation ans1.ok + then maybe_save_failing_query env cfg + else (); + ans1) in + (configs, ans) +let (report : FStarC_TypeChecker_Env.env -> query_settings -> answer -> unit) + = + fun env -> + fun default_settings -> + fun a -> + let nsuccess = a.nsuccess in + let name = full_query_id default_settings in + let lo = a.lo in + let hi = a.hi in + let total_ran = a.total_ran in + let all_errs = a.errs in + let quaking_or_retrying = a.quaking_or_retrying in + let quaking = a.quaking in + if nsuccess < lo + then + let uu___ = + quaking_or_retrying && + (let uu___1 = FStarC_Options.query_stats () in + Prims.op_Negation uu___1) in + (if uu___ + then + let errors_to_report1 errs = + errors_to_report a.tried_recovery + { + query_env = (default_settings.query_env); + query_decl = (default_settings.query_decl); + query_name = (default_settings.query_name); + query_index = (default_settings.query_index); + query_range = (default_settings.query_range); + query_fuel = (default_settings.query_fuel); + query_ifuel = (default_settings.query_ifuel); + query_rlimit = (default_settings.query_rlimit); + query_hint = (default_settings.query_hint); + query_errors = errs; + query_all_labels = (default_settings.query_all_labels); + query_suffix = (default_settings.query_suffix); + query_hash = (default_settings.query_hash); + query_can_be_split_and_retried = + (default_settings.query_can_be_split_and_retried); + query_term = (default_settings.query_term) + } in + let errs = FStarC_Compiler_List.map errors_to_report1 all_errs in + let errs1 = collect_dups (FStarC_Compiler_List.flatten errs) in + let errs2 = + FStarC_Compiler_List.map + (fun uu___1 -> + match uu___1 with + | ((e, m, r, ctx), n) -> + let m1 = + if n > Prims.int_one + then + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Compiler_Util.string_of_int n in + FStarC_Compiler_Util.format1 + "Repeated %s times" uu___5 in + FStarC_Pprint.doc_of_string uu___4 in + [uu___3] in + FStarC_Compiler_List.op_At m uu___2 + else m in + (e, m1, r, ctx)) errs1 in + (FStarC_Errors.add_errors errs2; + if quaking + then + (let rng = + match FStar_Pervasives_Native.fst + env.FStarC_TypeChecker_Env.qtbl_name_and_index + with + | FStar_Pervasives_Native.Some (l, uu___2, uu___3) -> + FStarC_Ident.range_of_lid l + | uu___2 -> FStarC_Compiler_Range_Type.dummyRange in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Compiler_Util.string_of_int nsuccess in + let uu___7 = + FStarC_Compiler_Util.string_of_int total_ran in + let uu___8 = FStarC_Compiler_Util.string_of_int lo in + let uu___9 = FStarC_Compiler_Util.string_of_int hi in + FStarC_Compiler_Util.format6 + "Query %s failed the quake test, %s out of %s attempts succeded, but the threshold was %s out of %s%s" + name uu___6 uu___7 uu___8 uu___9 + (if total_ran < hi then " (early abort)" else "") in + FStarC_Errors_Msg.text uu___5 in + [uu___4] in + (FStarC_Errors_Codes.Error_QuakeFailed, uu___3) in + FStarC_TypeChecker_Err.log_issue env rng uu___2) + else ()) + else + (let report1 errs = + report_errors a.tried_recovery + { + query_env = (default_settings.query_env); + query_decl = (default_settings.query_decl); + query_name = (default_settings.query_name); + query_index = (default_settings.query_index); + query_range = (default_settings.query_range); + query_fuel = (default_settings.query_fuel); + query_ifuel = (default_settings.query_ifuel); + query_rlimit = (default_settings.query_rlimit); + query_hint = (default_settings.query_hint); + query_errors = errs; + query_all_labels = (default_settings.query_all_labels); + query_suffix = (default_settings.query_suffix); + query_hash = (default_settings.query_hash); + query_can_be_split_and_retried = + (default_settings.query_can_be_split_and_retried); + query_term = (default_settings.query_term) + } in + FStarC_Compiler_List.iter report1 all_errs)) + else () +type solver_cfg = + { + seed: Prims.int ; + cliopt: Prims.string Prims.list ; + smtopt: Prims.string Prims.list ; + facts: (Prims.string Prims.list * Prims.bool) Prims.list ; + valid_intro: Prims.bool ; + valid_elim: Prims.bool ; + z3version: Prims.string ; + context_pruning: Prims.bool } +let (__proj__Mksolver_cfg__item__seed : solver_cfg -> Prims.int) = + fun projectee -> + match projectee with + | { seed; cliopt; smtopt; facts; valid_intro; valid_elim; z3version; + context_pruning;_} -> seed +let (__proj__Mksolver_cfg__item__cliopt : + solver_cfg -> Prims.string Prims.list) = + fun projectee -> + match projectee with + | { seed; cliopt; smtopt; facts; valid_intro; valid_elim; z3version; + context_pruning;_} -> cliopt +let (__proj__Mksolver_cfg__item__smtopt : + solver_cfg -> Prims.string Prims.list) = + fun projectee -> + match projectee with + | { seed; cliopt; smtopt; facts; valid_intro; valid_elim; z3version; + context_pruning;_} -> smtopt +let (__proj__Mksolver_cfg__item__facts : + solver_cfg -> (Prims.string Prims.list * Prims.bool) Prims.list) = + fun projectee -> + match projectee with + | { seed; cliopt; smtopt; facts; valid_intro; valid_elim; z3version; + context_pruning;_} -> facts +let (__proj__Mksolver_cfg__item__valid_intro : solver_cfg -> Prims.bool) = + fun projectee -> + match projectee with + | { seed; cliopt; smtopt; facts; valid_intro; valid_elim; z3version; + context_pruning;_} -> valid_intro +let (__proj__Mksolver_cfg__item__valid_elim : solver_cfg -> Prims.bool) = + fun projectee -> + match projectee with + | { seed; cliopt; smtopt; facts; valid_intro; valid_elim; z3version; + context_pruning;_} -> valid_elim +let (__proj__Mksolver_cfg__item__z3version : solver_cfg -> Prims.string) = + fun projectee -> + match projectee with + | { seed; cliopt; smtopt; facts; valid_intro; valid_elim; z3version; + context_pruning;_} -> z3version +let (__proj__Mksolver_cfg__item__context_pruning : solver_cfg -> Prims.bool) + = + fun projectee -> + match projectee with + | { seed; cliopt; smtopt; facts; valid_intro; valid_elim; z3version; + context_pruning;_} -> context_pruning +let (_last_cfg : + solver_cfg FStar_Pervasives_Native.option FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None +let (get_cfg : FStarC_TypeChecker_Env.env -> solver_cfg) = + fun env -> + let uu___ = FStarC_Options.z3_seed () in + let uu___1 = FStarC_Options.z3_cliopt () in + let uu___2 = FStarC_Options.z3_smtopt () in + let uu___3 = FStarC_Options.smtencoding_valid_intro () in + let uu___4 = FStarC_Options.smtencoding_valid_elim () in + let uu___5 = FStarC_Options.z3_version () in + let uu___6 = + let uu___7 = FStarC_Options_Ext.get "context_pruning" in uu___7 <> "" in + { + seed = uu___; + cliopt = uu___1; + smtopt = uu___2; + facts = (env.FStarC_TypeChecker_Env.proof_ns); + valid_intro = uu___3; + valid_elim = uu___4; + z3version = uu___5; + context_pruning = uu___6 + } +let (save_cfg : FStarC_TypeChecker_Env.env -> unit) = + fun env -> + let uu___ = + let uu___1 = get_cfg env in FStar_Pervasives_Native.Some uu___1 in + FStarC_Compiler_Effect.op_Colon_Equals _last_cfg uu___ +let (maybe_refresh_solver : FStarC_TypeChecker_Env.env -> unit) = + fun env -> + let uu___ = FStarC_Compiler_Effect.op_Bang _last_cfg in + match uu___ with + | FStar_Pervasives_Native.None -> save_cfg env + | FStar_Pervasives_Native.Some cfg -> + let uu___1 = let uu___2 = get_cfg env in cfg <> uu___2 in + if uu___1 + then + (save_cfg env; + FStarC_SMTEncoding_Z3.refresh + (FStar_Pervasives_Native.Some + (env.FStarC_TypeChecker_Env.proof_ns))) + else () +let finally : 'a . (unit -> unit) -> (unit -> 'a) -> 'a = + fun h -> + fun f -> + let r = + try (fun uu___ -> match () with | () -> f ()) () + with | uu___ -> (h (); FStarC_Compiler_Effect.raise uu___) in + h (); r +let (encode_and_ask : + Prims.bool -> + Prims.bool -> + (unit -> Prims.string) FStar_Pervasives_Native.option -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> (query_settings Prims.list * answer)) + = + fun can_split -> + fun is_retry -> + fun use_env_msg -> + fun tcenv -> + fun q -> + let do1 uu___ = + maybe_refresh_solver tcenv; + (let msg = + let uu___2 = + let uu___3 = FStarC_TypeChecker_Env.get_range tcenv in + FStarC_Compiler_Range_Ops.string_of_range uu___3 in + FStarC_Compiler_Util.format1 "Starting query at %s" uu___2 in + FStarC_SMTEncoding_Encode.push_encoding_state msg; + (let uu___3 = + FStarC_SMTEncoding_Encode.encode_query use_env_msg tcenv q in + match uu___3 with + | (prefix, labels, qry, suffix) -> + (FStarC_SMTEncoding_Z3.start_query msg prefix qry; + (let finish_query uu___5 = + let msg1 = + let uu___6 = + let uu___7 = + FStarC_TypeChecker_Env.get_range tcenv in + FStarC_Compiler_Range_Ops.string_of_range uu___7 in + FStarC_Compiler_Util.format1 "Ending query at %s" + uu___6 in + FStarC_SMTEncoding_Encode.pop_encoding_state msg1; + FStarC_SMTEncoding_Z3.finish_query msg1 in + finally finish_query + (fun uu___5 -> + let tcenv1 = + FStarC_TypeChecker_Env.incr_query_index tcenv in + match qry with + | FStarC_SMTEncoding_Term.Assume + { + FStarC_SMTEncoding_Term.assumption_term = + { + FStarC_SMTEncoding_Term.tm = + FStarC_SMTEncoding_Term.App + (FStarC_SMTEncoding_Term.FalseOp, + uu___6); + FStarC_SMTEncoding_Term.freevars = + uu___7; + FStarC_SMTEncoding_Term.rng = uu___8;_}; + FStarC_SMTEncoding_Term.assumption_caption = + uu___9; + FStarC_SMTEncoding_Term.assumption_name = + uu___10; + FStarC_SMTEncoding_Term.assumption_fact_ids + = uu___11; + FStarC_SMTEncoding_Term.assumption_free_names + = uu___12;_} + -> ([], ans_ok) + | uu___6 when tcenv1.FStarC_TypeChecker_Env.admit + -> ([], ans_ok) + | FStarC_SMTEncoding_Term.Assume uu___6 -> + ((let uu___8 = + (is_retry || + (let uu___9 = + FStarC_Options.split_queries () in + uu___9 = FStarC_Options.Always)) + && (FStarC_Compiler_Debug.any ()) in + if uu___8 + then + let n = FStarC_Compiler_List.length labels in + (if n <> Prims.int_one + then + let uu___9 = + FStarC_TypeChecker_Env.get_range + tcenv1 in + let uu___10 = + let uu___11 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + q in + let uu___12 = + FStarC_SMTEncoding_Term.declToSmt + "" qry in + let uu___13 = + FStarC_Compiler_Util.string_of_int + n in + FStarC_Compiler_Util.format3 + "Encoded split query %s\nto %s\nwith %s labels" + uu___11 uu___12 uu___13 in + FStarC_Errors.diag + FStarC_Class_HasRange.hasRange_range + uu___9 () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___10) + else ()) + else ()); + (let env = + FStarC_SMTEncoding_Encode.get_current_env + tcenv1 in + let uu___8 = + make_solver_configs can_split is_retry env + labels qry q suffix in + match uu___8 with + | (configs, next_hint) -> + ask_solver env configs next_hint)) + | uu___6 -> failwith "Impossible"))))) in + let uu___ = + FStarC_SMTEncoding_Solver_Cache.try_find_query_cache tcenv q in + if uu___ + then + ([], + { + ok = (ans_ok.ok); + cache_hit = true; + quaking = (ans_ok.quaking); + quaking_or_retrying = (ans_ok.quaking_or_retrying); + lo = (ans_ok.lo); + hi = (ans_ok.hi); + nsuccess = (ans_ok.nsuccess); + total_ran = (ans_ok.total_ran); + tried_recovery = (ans_ok.tried_recovery); + errs = (ans_ok.errs) + }) + else + (let uu___2 = do1 () in + match uu___2 with + | (cfgs, ans) -> + (if ans.ok + then + FStarC_SMTEncoding_Solver_Cache.query_cache_add tcenv q + else (); + (cfgs, ans))) +let (do_solve : + Prims.bool -> + Prims.bool -> + (unit -> Prims.string) FStar_Pervasives_Native.option -> + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.term -> unit) + = + fun can_split -> + fun is_retry -> + fun use_env_msg -> + fun tcenv -> + fun q -> + let ans_opt = + try + (fun uu___ -> + match () with + | () -> + let uu___1 = + encode_and_ask can_split is_retry use_env_msg tcenv + q in + FStar_Pervasives_Native.Some uu___1) () + with + | FStarC_SMTEncoding_Env.Inner_let_rec names -> + ((let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Compiler_List.map + FStar_Pervasives_Native.fst names in + FStarC_Compiler_String.concat "," uu___7 in + FStarC_Compiler_Util.format1 + "Could not encode the query since F* does not support precise smtencoding of inner let-recs yet (in this case %s)" + uu___6 in + FStarC_Errors_Msg.text uu___5 in + [uu___4] in + (FStarC_Errors_Codes.Error_NonTopRecFunctionNotFullyEncoded, + uu___3) in + FStarC_TypeChecker_Err.log_issue tcenv + tcenv.FStarC_TypeChecker_Env.range uu___2); + FStar_Pervasives_Native.None) in + match ans_opt with + | FStar_Pervasives_Native.Some (default_settings::uu___, ans) + when Prims.op_Negation ans.ok -> + report tcenv default_settings ans + | FStar_Pervasives_Native.Some (uu___, ans) when ans.ok -> () + | FStar_Pervasives_Native.Some ([], ans) when + Prims.op_Negation ans.ok -> + failwith "impossible: bad answer from encode_and_ask" + | FStar_Pervasives_Native.None -> () +let (split_and_solve : + Prims.bool -> + (unit -> Prims.string) FStar_Pervasives_Native.option -> + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.term -> unit) + = + fun retrying -> + fun use_env_msg -> + fun tcenv -> + fun q -> + (let uu___1 = + (FStarC_Compiler_Debug.any ()) || + (FStarC_Options.query_stats ()) in + if uu___1 + then + let range = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_TypeChecker_Env.get_range tcenv in + FStarC_Compiler_Range_Ops.string_of_range uu___4 in + Prims.strcat uu___3 ")" in + Prims.strcat "(" uu___2 in + FStarC_Compiler_Util.print2 + "%s\tQuery-stats splitting query because %s\n" range + (if retrying + then "retrying failed query" + else "--split_queries is always") + else ()); + (let goals = + let uu___1 = FStarC_TypeChecker_Env.split_smt_query tcenv q in + match uu___1 with + | FStar_Pervasives_Native.None -> + failwith "Impossible: split_query callback is not set" + | FStar_Pervasives_Native.Some goals1 -> goals1 in + FStarC_Compiler_List.iter + (fun uu___2 -> + match uu___2 with + | (env, goal) -> do_solve false retrying use_env_msg env goal) + goals; + (let uu___2 = + (let uu___3 = FStarC_Errors.get_err_count () in + uu___3 = Prims.int_zero) && retrying in + if uu___2 + then + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Errors_Msg.text + "The verification condition succeeded after splitting it to localize potential errors, although the original non-split verification condition failed. If you want to rely on splitting queries for verifying your program please use the '--split_queries always' option rather than relying on it implicitly." in + [uu___5] in + (FStarC_Errors_Codes.Warning_SplitAndRetryQueries, uu___4) in + FStarC_TypeChecker_Err.log_issue tcenv + tcenv.FStarC_TypeChecker_Env.range uu___3 + else ())) +let disable_quake_for : 'a . (unit -> 'a) -> 'a = + fun f -> + FStarC_Options.with_saved_options + (fun uu___ -> + FStarC_Options.set_option "quake_hi" + (FStarC_Options.Int Prims.int_one); + f ()) +let (do_solve_maybe_split : + (unit -> Prims.string) FStar_Pervasives_Native.option -> + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.term -> unit) + = + fun use_env_msg -> + fun tcenv -> + fun q -> + if tcenv.FStarC_TypeChecker_Env.admit + then () + else + (let uu___1 = FStarC_Options.split_queries () in + match uu___1 with + | FStarC_Options.No -> do_solve false false use_env_msg tcenv q + | FStarC_Options.OnFailure -> + let can_split = + let uu___2 = + let uu___3 = FStarC_Options.quake_hi () in + uu___3 > Prims.int_one in + Prims.op_Negation uu___2 in + (try + (fun uu___2 -> + match () with + | () -> do_solve can_split false use_env_msg tcenv q) () + with + | SplitQueryAndRetry -> + split_and_solve true use_env_msg tcenv q) + | FStarC_Options.Always -> + split_and_solve false use_env_msg tcenv q) +let (solve : + (unit -> Prims.string) FStar_Pervasives_Native.option -> + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.term -> unit) + = + fun use_env_msg -> + fun tcenv -> + fun q -> + let uu___ = FStarC_Options.no_smt () in + if uu___ + then + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Errors_Msg.text + "A query could not be solved internally, and --no_smt was given." in + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Errors_Msg.text "Query = " in + let uu___7 = + FStarC_Class_PP.pp FStarC_Syntax_Print.pretty_term q in + FStarC_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in + [uu___5] in + uu___3 :: uu___4 in + (FStarC_Errors_Codes.Error_NoSMTButNeeded, uu___2) in + FStarC_TypeChecker_Err.log_issue tcenv + tcenv.FStarC_TypeChecker_Env.range uu___1 + else + (let uu___2 = + let uu___3 = + let uu___4 = FStarC_TypeChecker_Env.current_module tcenv in + FStarC_Ident.string_of_lid uu___4 in + FStar_Pervasives_Native.Some uu___3 in + FStarC_Profiling.profile + (fun uu___3 -> do_solve_maybe_split use_env_msg tcenv q) uu___2 + "FStarC.SMTEncoding.solve_top_level") +let (solve_sync : + (unit -> Prims.string) FStar_Pervasives_Native.option -> + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.term -> answer) + = + fun use_env_msg -> + fun tcenv -> + fun q -> + let uu___ = FStarC_Options.no_smt () in + if uu___ + then ans_fail + else + (let go uu___2 = + (let uu___4 = FStarC_Compiler_Effect.op_Bang dbg_SMTQuery in + if uu___4 + then + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Errors_Msg.text + "Running synchronous SMT query. Q =" in + let uu___8 = + FStarC_Class_PP.pp FStarC_Syntax_Print.pretty_term q in + FStarC_Pprint.prefix (Prims.of_int (2)) Prims.int_one + uu___7 uu___8 in + [uu___6] in + FStarC_Errors.diag FStarC_Class_HasRange.hasRange_range + q.FStarC_Syntax_Syntax.pos () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___5) + else ()); + (let uu___4 = + disable_quake_for + (fun uu___5 -> + encode_and_ask false false use_env_msg tcenv q) in + match uu___4 with | (_cfgs, ans) -> ans) in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_TypeChecker_Env.current_module tcenv in + FStarC_Ident.string_of_lid uu___4 in + FStar_Pervasives_Native.Some uu___3 in + FStarC_Profiling.profile go uu___2 + "FStarC.SMTEncoding.solve_sync_top_level") +let (solve_sync_bool : + (unit -> Prims.string) FStar_Pervasives_Native.option -> + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.term -> Prims.bool) + = + fun use_env_msg -> + fun tcenv -> fun q -> let ans = solve_sync use_env_msg tcenv q in ans.ok +let (snapshot : Prims.string -> ((Prims.int * Prims.int * Prims.int) * unit)) + = + fun msg -> + let uu___ = FStarC_SMTEncoding_Encode.snapshot_encoding msg in + match uu___ with + | (v0, v1) -> + let v2 = FStarC_SMTEncoding_Z3.snapshot msg in ((v0, v1, v2), ()) +let (rollback : + Prims.string -> + (Prims.int * Prims.int * Prims.int) FStar_Pervasives_Native.option -> + unit) + = + fun msg -> + fun tok -> + let uu___ = + match tok with + | FStar_Pervasives_Native.None -> + (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) + | FStar_Pervasives_Native.Some (v0, v1, v2) -> + ((FStar_Pervasives_Native.Some (v0, v1)), + (FStar_Pervasives_Native.Some v2)) in + match uu___ with + | (tok01, tok2) -> + (FStarC_SMTEncoding_Encode.rollback_encoding msg tok01; + FStarC_SMTEncoding_Z3.rollback msg tok2) +let (solver : FStarC_TypeChecker_Env.solver_t) = + { + FStarC_TypeChecker_Env.init = + (fun e -> save_cfg e; FStarC_SMTEncoding_Encode.init e); + FStarC_TypeChecker_Env.snapshot = snapshot; + FStarC_TypeChecker_Env.rollback = rollback; + FStarC_TypeChecker_Env.encode_sig = FStarC_SMTEncoding_Encode.encode_sig; + FStarC_TypeChecker_Env.preprocess = + (fun e -> + fun g -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Options.peek () in (e, g, uu___2) in + [uu___1] in + (false, uu___)); + FStarC_TypeChecker_Env.spinoff_strictly_positive_goals = + FStar_Pervasives_Native.None; + FStarC_TypeChecker_Env.handle_smt_goal = (fun e -> fun g -> [(e, g)]); + FStarC_TypeChecker_Env.solve = solve; + FStarC_TypeChecker_Env.solve_sync = solve_sync_bool; + FStarC_TypeChecker_Env.finish = (fun uu___ -> ()); + FStarC_TypeChecker_Env.refresh = FStarC_SMTEncoding_Z3.refresh + } +let (dummy : FStarC_TypeChecker_Env.solver_t) = + { + FStarC_TypeChecker_Env.init = (fun uu___ -> ()); + FStarC_TypeChecker_Env.snapshot = + (fun uu___ -> ((Prims.int_zero, Prims.int_zero, Prims.int_zero), ())); + FStarC_TypeChecker_Env.rollback = (fun uu___ -> fun uu___1 -> ()); + FStarC_TypeChecker_Env.encode_sig = (fun uu___ -> fun uu___1 -> ()); + FStarC_TypeChecker_Env.preprocess = + (fun e -> + fun g -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Options.peek () in (e, g, uu___2) in + [uu___1] in + (false, uu___)); + FStarC_TypeChecker_Env.spinoff_strictly_positive_goals = + FStar_Pervasives_Native.None; + FStarC_TypeChecker_Env.handle_smt_goal = (fun e -> fun g -> [(e, g)]); + FStarC_TypeChecker_Env.solve = + (fun uu___ -> fun uu___1 -> fun uu___2 -> ()); + FStarC_TypeChecker_Env.solve_sync = + (fun uu___ -> fun uu___1 -> fun uu___2 -> false); + FStarC_TypeChecker_Env.finish = (fun uu___ -> ()); + FStarC_TypeChecker_Env.refresh = (fun uu___ -> ()) + } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_SMTEncoding_SolverState.ml b/ocaml/fstar-lib/generated/FStarC_SMTEncoding_SolverState.ml new file mode 100644 index 00000000000..94f51c44fee --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_SMTEncoding_SolverState.ml @@ -0,0 +1,810 @@ +open Prims +type using_facts_from_setting = + (Prims.string Prims.list * Prims.bool) Prims.list +type decl_name_set = Prims.bool FStarC_Compiler_Util.psmap +let (empty_decl_names : Prims.bool FStarC_Compiler_Util.psmap) = + FStarC_Compiler_Util.psmap_empty () +let (decl_names_contains : Prims.string -> decl_name_set -> Prims.bool) = + fun x -> + fun s -> + let uu___ = FStarC_Compiler_Util.psmap_try_find s x in + FStar_Pervasives_Native.uu___is_Some uu___ +let (add_name : + Prims.string -> decl_name_set -> Prims.bool FStarC_Compiler_Util.psmap) = + fun x -> fun s -> FStarC_Compiler_Util.psmap_add s x true +type decls_at_level = + { + pruning_state: FStarC_SMTEncoding_Pruning.pruning_state ; + given_decl_names: decl_name_set ; + all_decls_at_level_rev: FStarC_SMTEncoding_Term.decl Prims.list Prims.list ; + given_some_decls: Prims.bool ; + to_flush_rev: FStarC_SMTEncoding_Term.decl Prims.list Prims.list ; + named_assumptions: + FStarC_SMTEncoding_Term.assumption FStarC_Compiler_Util.psmap ; + pruning_roots: + FStarC_SMTEncoding_Term.decl Prims.list FStar_Pervasives_Native.option } +let (__proj__Mkdecls_at_level__item__pruning_state : + decls_at_level -> FStarC_SMTEncoding_Pruning.pruning_state) = + fun projectee -> + match projectee with + | { pruning_state; given_decl_names; all_decls_at_level_rev; + given_some_decls; to_flush_rev; named_assumptions; pruning_roots;_} + -> pruning_state +let (__proj__Mkdecls_at_level__item__given_decl_names : + decls_at_level -> decl_name_set) = + fun projectee -> + match projectee with + | { pruning_state; given_decl_names; all_decls_at_level_rev; + given_some_decls; to_flush_rev; named_assumptions; pruning_roots;_} + -> given_decl_names +let (__proj__Mkdecls_at_level__item__all_decls_at_level_rev : + decls_at_level -> FStarC_SMTEncoding_Term.decl Prims.list Prims.list) = + fun projectee -> + match projectee with + | { pruning_state; given_decl_names; all_decls_at_level_rev; + given_some_decls; to_flush_rev; named_assumptions; pruning_roots;_} + -> all_decls_at_level_rev +let (__proj__Mkdecls_at_level__item__given_some_decls : + decls_at_level -> Prims.bool) = + fun projectee -> + match projectee with + | { pruning_state; given_decl_names; all_decls_at_level_rev; + given_some_decls; to_flush_rev; named_assumptions; pruning_roots;_} + -> given_some_decls +let (__proj__Mkdecls_at_level__item__to_flush_rev : + decls_at_level -> FStarC_SMTEncoding_Term.decl Prims.list Prims.list) = + fun projectee -> + match projectee with + | { pruning_state; given_decl_names; all_decls_at_level_rev; + given_some_decls; to_flush_rev; named_assumptions; pruning_roots;_} + -> to_flush_rev +let (__proj__Mkdecls_at_level__item__named_assumptions : + decls_at_level -> + FStarC_SMTEncoding_Term.assumption FStarC_Compiler_Util.psmap) + = + fun projectee -> + match projectee with + | { pruning_state; given_decl_names; all_decls_at_level_rev; + given_some_decls; to_flush_rev; named_assumptions; pruning_roots;_} + -> named_assumptions +let (__proj__Mkdecls_at_level__item__pruning_roots : + decls_at_level -> + FStarC_SMTEncoding_Term.decl Prims.list FStar_Pervasives_Native.option) + = + fun projectee -> + match projectee with + | { pruning_state; given_decl_names; all_decls_at_level_rev; + given_some_decls; to_flush_rev; named_assumptions; pruning_roots;_} + -> pruning_roots +let (init_given_decls_at_level : decls_at_level) = + let uu___ = FStarC_Compiler_Util.psmap_empty () in + { + pruning_state = FStarC_SMTEncoding_Pruning.init; + given_decl_names = empty_decl_names; + all_decls_at_level_rev = []; + given_some_decls = false; + to_flush_rev = []; + named_assumptions = uu___; + pruning_roots = FStar_Pervasives_Native.None + } +type solver_state = + { + levels: decls_at_level Prims.list ; + pending_flushes_rev: FStarC_SMTEncoding_Term.decl Prims.list ; + using_facts_from: using_facts_from_setting FStar_Pervasives_Native.option ; + retain_assumptions: decl_name_set } +let (__proj__Mksolver_state__item__levels : + solver_state -> decls_at_level Prims.list) = + fun projectee -> + match projectee with + | { levels; pending_flushes_rev; using_facts_from; retain_assumptions;_} + -> levels +let (__proj__Mksolver_state__item__pending_flushes_rev : + solver_state -> FStarC_SMTEncoding_Term.decl Prims.list) = + fun projectee -> + match projectee with + | { levels; pending_flushes_rev; using_facts_from; retain_assumptions;_} + -> pending_flushes_rev +let (__proj__Mksolver_state__item__using_facts_from : + solver_state -> using_facts_from_setting FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { levels; pending_flushes_rev; using_facts_from; retain_assumptions;_} + -> using_facts_from +let (__proj__Mksolver_state__item__retain_assumptions : + solver_state -> decl_name_set) = + fun projectee -> + match projectee with + | { levels; pending_flushes_rev; using_facts_from; retain_assumptions;_} + -> retain_assumptions +let (depth : solver_state -> Prims.int) = + fun s -> FStarC_Compiler_List.length s.levels +let (solver_state_to_string : solver_state -> Prims.string) = + fun s -> + let levels = + FStarC_Compiler_List.map + (fun level -> + let uu___ = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_nat) + (FStarC_Compiler_List.length level.all_decls_at_level_rev) in + let uu___1 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + level.given_some_decls in + let uu___2 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_nat) + (FStarC_Compiler_List.length level.to_flush_rev) in + FStarC_Compiler_Util.format3 + "Level { all_decls=%s; given_decls=%s; to_flush=%s }" uu___ + uu___1 uu___2) s.levels in + let uu___ = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_string)) levels in + let uu___1 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow FStar_Class_Printable.printable_nat) + (FStarC_Compiler_List.length s.pending_flushes_rev) in + FStarC_Compiler_Util.format2 + "Solver state { levels=%s; pending_flushes=%s }" uu___ uu___1 +let (showable_solver_state : solver_state FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = solver_state_to_string } +let (debug : Prims.string -> solver_state -> solver_state -> unit) = + fun msg -> + fun s0 -> + fun s1 -> + let uu___ = + let uu___1 = FStarC_Options_Ext.get "debug_solver_state" in + uu___1 <> "" in + if uu___ + then + let uu___1 = solver_state_to_string s0 in + let uu___2 = solver_state_to_string s1 in + FStarC_Compiler_Util.print3 + "Debug (%s):{\n\t before=%s\n\t after=%s\n}" msg uu___1 uu___2 + else () +let (peek : solver_state -> (decls_at_level * decls_at_level Prims.list)) = + fun s -> + match s.levels with + | [] -> failwith "Solver state cannot have an empty stack" + | hd::tl -> (hd, tl) +let (replace_head : decls_at_level -> solver_state -> solver_state) = + fun hd -> + fun s -> + let uu___ = + let uu___1 = FStarC_Compiler_List.tl s.levels in hd :: uu___1 in + { + levels = uu___; + pending_flushes_rev = (s.pending_flushes_rev); + using_facts_from = (s.using_facts_from); + retain_assumptions = (s.retain_assumptions) + } +let (init : unit -> solver_state) = + fun uu___ -> + let uu___1 = + let uu___2 = FStarC_Options.using_facts_from () in + FStar_Pervasives_Native.Some uu___2 in + { + levels = [init_given_decls_at_level]; + pending_flushes_rev = []; + using_facts_from = uu___1; + retain_assumptions = empty_decl_names + } +let (push : solver_state -> solver_state) = + fun s -> + let uu___ = peek s in + match uu___ with + | (hd, uu___1) -> + let push1 = + FStarC_SMTEncoding_Term.Push (FStarC_Compiler_List.length s.levels) in + let next = + { + pruning_state = (hd.pruning_state); + given_decl_names = (hd.given_decl_names); + all_decls_at_level_rev = []; + given_some_decls = false; + to_flush_rev = [[push1]]; + named_assumptions = (hd.named_assumptions); + pruning_roots = FStar_Pervasives_Native.None + } in + { + levels = (next :: (s.levels)); + pending_flushes_rev = (s.pending_flushes_rev); + using_facts_from = (s.using_facts_from); + retain_assumptions = (s.retain_assumptions) + } +let (pop : solver_state -> solver_state) = + fun s -> + let uu___ = peek s in + match uu___ with + | (hd, tl) -> + (if Prims.uu___is_Nil tl + then failwith "Solver state cannot have an empty stack" + else (); + (let s1 = + if Prims.op_Negation hd.given_some_decls + then + { + levels = tl; + pending_flushes_rev = (s.pending_flushes_rev); + using_facts_from = (s.using_facts_from); + retain_assumptions = (s.retain_assumptions) + } + else + { + levels = tl; + pending_flushes_rev = + ((FStarC_SMTEncoding_Term.Pop + (FStarC_Compiler_List.length tl)) :: + (s.pending_flushes_rev)); + using_facts_from = (s.using_facts_from); + retain_assumptions = (s.retain_assumptions) + } in + s1)) +let (filter_using_facts_from : + using_facts_from_setting FStar_Pervasives_Native.option -> + FStarC_SMTEncoding_Term.assumption FStarC_Compiler_Util.psmap -> + decl_name_set -> + (Prims.string -> Prims.bool) -> + FStarC_SMTEncoding_Term.decl Prims.list -> + FStarC_SMTEncoding_Term.decl Prims.list) + = + fun using_facts_from -> + fun named_assumptions -> + fun retain_assumptions -> + fun already_given_decl -> + fun ds -> + match using_facts_from with + | FStar_Pervasives_Native.None -> ds + | FStar_Pervasives_Native.Some (([], true)::[]) -> ds + | FStar_Pervasives_Native.Some using_facts_from1 -> + let keep_assumption a = + match a.FStarC_SMTEncoding_Term.assumption_fact_ids with + | [] -> true + | uu___ -> + (decl_names_contains + a.FStarC_SMTEncoding_Term.assumption_name + retain_assumptions) + || + (FStarC_Compiler_Util.for_some + (fun uu___1 -> + match uu___1 with + | FStarC_SMTEncoding_Term.Name lid -> + FStarC_TypeChecker_Env.should_enc_lid + using_facts_from1 lid + | uu___2 -> false) + a.FStarC_SMTEncoding_Term.assumption_fact_ids) in + let already_given_map = + FStarC_Compiler_Util.smap_create (Prims.of_int (1000)) in + let add_assumption a = + FStarC_Compiler_Util.smap_add already_given_map + a.FStarC_SMTEncoding_Term.assumption_name true in + let already_given a = + (let uu___ = + FStarC_Compiler_Util.smap_try_find already_given_map + a.FStarC_SMTEncoding_Term.assumption_name in + FStar_Pervasives_Native.uu___is_Some uu___) || + (already_given_decl + a.FStarC_SMTEncoding_Term.assumption_name) in + let map_decl d = + match d with + | FStarC_SMTEncoding_Term.Assume a -> + let uu___ = + (keep_assumption a) && + (let uu___1 = already_given a in + Prims.op_Negation uu___1) in + if uu___ then (add_assumption a; [d]) else [] + | FStarC_SMTEncoding_Term.RetainAssumptions names -> + let assumptions = + FStarC_Compiler_List.collect + (fun name -> + let uu___ = + FStarC_Compiler_Util.psmap_try_find + named_assumptions name in + match uu___ with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some a -> + let uu___1 = already_given a in + if uu___1 + then [] + else + (add_assumption a; + [FStarC_SMTEncoding_Term.Assume a])) + names in + assumptions + | uu___ -> [d] in + let ds1 = FStarC_Compiler_List.collect map_decl ds in ds1 +let (already_given_decl : solver_state -> Prims.string -> Prims.bool) = + fun s -> + fun aname -> + FStarC_Compiler_Util.for_some + (fun level -> decl_names_contains aname level.given_decl_names) + s.levels +let rec (flatten : + FStarC_SMTEncoding_Term.decl -> FStarC_SMTEncoding_Term.decl Prims.list) = + fun d -> + match d with + | FStarC_SMTEncoding_Term.Module (uu___, ds) -> + FStarC_Compiler_List.collect flatten ds + | uu___ -> [d] +let (add_named_assumptions : + FStarC_SMTEncoding_Term.assumption FStarC_Compiler_Util.psmap -> + FStarC_SMTEncoding_Term.decl Prims.list -> + FStarC_SMTEncoding_Term.assumption FStarC_Compiler_Util.psmap) + = + fun named_assumptions -> + fun ds -> + FStarC_Compiler_List.fold_left + (fun named_assumptions1 -> + fun d -> + match d with + | FStarC_SMTEncoding_Term.Assume a -> + FStarC_Compiler_Util.psmap_add named_assumptions1 + a.FStarC_SMTEncoding_Term.assumption_name a + | uu___ -> named_assumptions1) named_assumptions ds +let (add_retain_assumptions : + FStarC_SMTEncoding_Term.decl Prims.list -> solver_state -> solver_state) = + fun ds -> + fun s -> + let ra = + FStarC_Compiler_List.fold_left + (fun ra1 -> + fun d -> + match d with + | FStarC_SMTEncoding_Term.RetainAssumptions names -> + FStarC_Compiler_List.fold_left + (fun ra2 -> fun name -> add_name name ra2) ra1 names + | uu___ -> ra1) s.retain_assumptions ds in + { + levels = (s.levels); + pending_flushes_rev = (s.pending_flushes_rev); + using_facts_from = (s.using_facts_from); + retain_assumptions = ra + } +let (give_delay_assumptions : + Prims.bool -> + FStarC_SMTEncoding_Term.decl Prims.list -> solver_state -> solver_state) + = + fun resetting -> + fun ds -> + fun s -> + let decls = FStarC_Compiler_List.collect flatten ds in + let uu___ = + FStarC_Compiler_List.partition + FStarC_SMTEncoding_Term.uu___is_Assume decls in + match uu___ with + | (assumptions, rest) -> + let uu___1 = peek s in + (match uu___1 with + | (hd, tl) -> + let hd1 = + { + pruning_state = (hd.pruning_state); + given_decl_names = (hd.given_decl_names); + all_decls_at_level_rev = (ds :: + (hd.all_decls_at_level_rev)); + given_some_decls = (hd.given_some_decls); + to_flush_rev = (rest :: (hd.to_flush_rev)); + named_assumptions = (hd.named_assumptions); + pruning_roots = (hd.pruning_roots) + } in + if resetting + then + { + levels = (hd1 :: tl); + pending_flushes_rev = (s.pending_flushes_rev); + using_facts_from = (s.using_facts_from); + retain_assumptions = (s.retain_assumptions) + } + else + (let hd2 = + let uu___3 = + FStarC_SMTEncoding_Pruning.add_decls decls + hd1.pruning_state in + let uu___4 = + add_named_assumptions hd1.named_assumptions + assumptions in + { + pruning_state = uu___3; + given_decl_names = (hd1.given_decl_names); + all_decls_at_level_rev = (hd1.all_decls_at_level_rev); + given_some_decls = (hd1.given_some_decls); + to_flush_rev = (hd1.to_flush_rev); + named_assumptions = uu___4; + pruning_roots = (hd1.pruning_roots) + } in + add_retain_assumptions decls + { + levels = (hd2 :: tl); + pending_flushes_rev = (s.pending_flushes_rev); + using_facts_from = (s.using_facts_from); + retain_assumptions = (s.retain_assumptions) + })) +let (give_now : + Prims.bool -> + FStarC_SMTEncoding_Term.decl Prims.list -> solver_state -> solver_state) + = + fun resetting -> + fun ds -> + fun s -> + let decls = FStarC_Compiler_List.collect flatten ds in + let uu___ = + FStarC_Compiler_List.partition + FStarC_SMTEncoding_Term.uu___is_Assume decls in + match uu___ with + | (assumptions, uu___1) -> + let uu___2 = peek s in + (match uu___2 with + | (hd, tl) -> + let named_assumptions = + if resetting + then hd.named_assumptions + else + add_named_assumptions hd.named_assumptions assumptions in + let ds_to_flush = + filter_using_facts_from s.using_facts_from + named_assumptions s.retain_assumptions + (already_given_decl s) decls in + let given = + FStarC_Compiler_List.fold_left + (fun given1 -> + fun d -> + match d with + | FStarC_SMTEncoding_Term.Assume a -> + add_name + a.FStarC_SMTEncoding_Term.assumption_name + given1 + | uu___3 -> given1) hd.given_decl_names ds_to_flush in + let hd1 = + { + pruning_state = (hd.pruning_state); + given_decl_names = given; + all_decls_at_level_rev = (ds :: + (hd.all_decls_at_level_rev)); + given_some_decls = (hd.given_some_decls); + to_flush_rev = (ds_to_flush :: (hd.to_flush_rev)); + named_assumptions = (hd.named_assumptions); + pruning_roots = (hd.pruning_roots) + } in + if resetting + then + { + levels = (hd1 :: tl); + pending_flushes_rev = (s.pending_flushes_rev); + using_facts_from = (s.using_facts_from); + retain_assumptions = (s.retain_assumptions) + } + else + (let hd2 = + let uu___4 = + FStarC_SMTEncoding_Pruning.add_decls decls + hd1.pruning_state in + { + pruning_state = uu___4; + given_decl_names = (hd1.given_decl_names); + all_decls_at_level_rev = (hd1.all_decls_at_level_rev); + given_some_decls = (hd1.given_some_decls); + to_flush_rev = (hd1.to_flush_rev); + named_assumptions; + pruning_roots = (hd1.pruning_roots) + } in + add_retain_assumptions decls + { + levels = (hd2 :: tl); + pending_flushes_rev = (s.pending_flushes_rev); + using_facts_from = (s.using_facts_from); + retain_assumptions = (s.retain_assumptions) + })) +let (give_aux : + Prims.bool -> + FStarC_SMTEncoding_Term.decl Prims.list -> solver_state -> solver_state) + = + fun resetting -> + fun ds -> + fun s -> + let uu___ = + let uu___1 = FStarC_Options_Ext.get "context_pruning" in + uu___1 <> "" in + if uu___ + then give_delay_assumptions resetting ds s + else give_now resetting ds s +let (give : + FStarC_SMTEncoding_Term.decl Prims.list -> solver_state -> solver_state) = + give_aux false +let (reset : + using_facts_from_setting FStar_Pervasives_Native.option -> + solver_state -> solver_state) + = + fun using_facts_from -> + fun s -> + let s_new = init () in + let s_new1 = + { + levels = (s_new.levels); + pending_flushes_rev = (s_new.pending_flushes_rev); + using_facts_from; + retain_assumptions = (s.retain_assumptions) + } in + let set_pruning_roots level s1 = + let uu___ = peek s1 in + match uu___ with + | (hd, tl) -> + let hd1 = + { + pruning_state = (hd.pruning_state); + given_decl_names = (hd.given_decl_names); + all_decls_at_level_rev = (hd.all_decls_at_level_rev); + given_some_decls = (hd.given_some_decls); + to_flush_rev = (hd.to_flush_rev); + named_assumptions = (hd.named_assumptions); + pruning_roots = (level.pruning_roots) + } in + { + levels = (hd1 :: tl); + pending_flushes_rev = (s1.pending_flushes_rev); + using_facts_from = (s1.using_facts_from); + retain_assumptions = (s1.retain_assumptions) + } in + let rebuild_level now level s_new2 = + let uu___ = peek s_new2 in + match uu___ with + | (hd, tl) -> + let hd1 = + { + pruning_state = (level.pruning_state); + given_decl_names = (hd.given_decl_names); + all_decls_at_level_rev = (hd.all_decls_at_level_rev); + given_some_decls = (hd.given_some_decls); + to_flush_rev = (hd.to_flush_rev); + named_assumptions = (level.named_assumptions); + pruning_roots = (hd.pruning_roots) + } in + let s_new3 = + { + levels = (hd1 :: tl); + pending_flushes_rev = (s_new2.pending_flushes_rev); + using_facts_from = (s_new2.using_facts_from); + retain_assumptions = (s_new2.retain_assumptions) + } in + let s1 = + FStarC_Compiler_List.fold_right + (if now then give_now true else give_aux true) + level.all_decls_at_level_rev s_new3 in + let uu___1 = set_pruning_roots level s1 in + (uu___1, + (FStar_Pervasives_Native.uu___is_Some level.pruning_roots)) in + let rec rebuild levels s_new2 = + match levels with + | last::[] -> rebuild_level false last s_new2 + | level::levels1 -> + let uu___ = rebuild levels1 s_new2 in + (match uu___ with + | (s_new3, now) -> + let s_new4 = push s_new3 in rebuild_level now level s_new4) in + let uu___ = rebuild s.levels s_new1 in + FStar_Pervasives_Native.fst uu___ +let (name_of_assumption : FStarC_SMTEncoding_Term.decl -> Prims.string) = + fun d -> + match d with + | FStarC_SMTEncoding_Term.Assume a -> + a.FStarC_SMTEncoding_Term.assumption_name + | uu___ -> failwith "Expected an assumption" +let (prune_level : + FStarC_SMTEncoding_Term.decl Prims.list -> + decls_at_level -> solver_state -> decls_at_level) + = + fun roots -> + fun hd -> + fun s -> + let to_give = FStarC_SMTEncoding_Pruning.prune hd.pruning_state roots in + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun to_give1 -> + match uu___1 with + | (decl_name_set1, can_give) -> + let name = name_of_assumption to_give1 in + let uu___2 = + let uu___3 = decl_names_contains name decl_name_set1 in + Prims.op_Negation uu___3 in + if uu___2 + then + let uu___3 = add_name name decl_name_set1 in + (uu___3, (to_give1 :: can_give)) + else (decl_name_set1, can_give)) + ((hd.given_decl_names), []) to_give in + match uu___ with + | (given_decl_names, can_give) -> + let can_give1 = + filter_using_facts_from s.using_facts_from hd.named_assumptions + s.retain_assumptions (already_given_decl s) can_give in + let hd1 = + { + pruning_state = (hd.pruning_state); + given_decl_names; + all_decls_at_level_rev = (hd.all_decls_at_level_rev); + given_some_decls = (hd.given_some_decls); + to_flush_rev = (can_give1 :: (hd.to_flush_rev)); + named_assumptions = (hd.named_assumptions); + pruning_roots = (hd.pruning_roots) + } in + hd1 +let (prune_sim : + FStarC_SMTEncoding_Term.decl Prims.list -> + solver_state -> Prims.string Prims.list) + = + fun roots -> + fun s -> + let uu___ = peek s in + match uu___ with + | (hd, tl) -> + let to_give = + FStarC_SMTEncoding_Pruning.prune hd.pruning_state roots in + let can_give = + filter_using_facts_from s.using_facts_from hd.named_assumptions + s.retain_assumptions (already_given_decl s) to_give in + let uu___1 = + let uu___2 = + FStarC_Compiler_List.filter + FStarC_SMTEncoding_Term.uu___is_Assume roots in + FStar_List_Tot_Base.op_At uu___2 can_give in + FStarC_Compiler_List.map name_of_assumption uu___1 +let (start_query : + Prims.string -> + FStarC_SMTEncoding_Term.decl Prims.list -> + FStarC_SMTEncoding_Term.decl -> solver_state -> solver_state) + = + fun msg -> + fun roots_to_push -> + fun qry -> + fun s -> + let uu___ = peek s in + match uu___ with + | (hd, tl) -> + let s1 = + { + levels = + ({ + pruning_state = (hd.pruning_state); + given_decl_names = (hd.given_decl_names); + all_decls_at_level_rev = (hd.all_decls_at_level_rev); + given_some_decls = (hd.given_some_decls); + to_flush_rev = (hd.to_flush_rev); + named_assumptions = (hd.named_assumptions); + pruning_roots = + (FStar_Pervasives_Native.Some (qry :: roots_to_push)) + } :: tl); + pending_flushes_rev = (s.pending_flushes_rev); + using_facts_from = (s.using_facts_from); + retain_assumptions = (s.retain_assumptions) + } in + let s2 = push s1 in + let s3 = give [FStarC_SMTEncoding_Term.Caption msg] s2 in + give_now false roots_to_push s3 +let (finish_query : Prims.string -> solver_state -> solver_state) = + fun msg -> + fun s -> + let s1 = give [FStarC_SMTEncoding_Term.Caption msg] s in + let s2 = pop s1 in + let uu___ = peek s2 in + match uu___ with + | (hd, tl) -> + { + levels = + ({ + pruning_state = (hd.pruning_state); + given_decl_names = (hd.given_decl_names); + all_decls_at_level_rev = (hd.all_decls_at_level_rev); + given_some_decls = (hd.given_some_decls); + to_flush_rev = (hd.to_flush_rev); + named_assumptions = (hd.named_assumptions); + pruning_roots = FStar_Pervasives_Native.None + } :: tl); + pending_flushes_rev = (s2.pending_flushes_rev); + using_facts_from = (s2.using_facts_from); + retain_assumptions = (s2.retain_assumptions) + } +let (filter_with_unsat_core : + Prims.string -> + FStarC_SMTEncoding_UnsatCore.unsat_core -> + solver_state -> FStarC_SMTEncoding_Term.decl Prims.list) + = + fun queryid -> + fun core -> + fun s -> + let rec all_decls levels = + match levels with + | last::[] -> last.all_decls_at_level_rev + | level::levels1 -> + let uu___ = + let uu___1 = all_decls levels1 in + [FStarC_SMTEncoding_Term.Push + (FStarC_Compiler_List.length levels1)] + :: uu___1 in + FStar_List_Tot_Base.op_At level.all_decls_at_level_rev uu___ in + let all_decls1 = all_decls s.levels in + let all_decls2 = + FStarC_Compiler_List.flatten (FStarC_Compiler_List.rev all_decls1) in + FStarC_SMTEncoding_UnsatCore.filter core all_decls2 +let (would_have_pruned : + solver_state -> Prims.string Prims.list FStar_Pervasives_Native.option) = + fun s -> + let uu___ = + let uu___1 = FStarC_Options_Ext.get "context_pruning_sim" in + uu___1 = "" in + if uu___ + then FStar_Pervasives_Native.None + else + (let rec aux levels = + match levels with + | [] -> FStar_Pervasives_Native.None + | level::levels1 -> + (match level.pruning_roots with + | FStar_Pervasives_Native.Some roots -> + let uu___2 = prune_sim roots s in + FStar_Pervasives_Native.Some uu___2 + | FStar_Pervasives_Native.None -> aux levels1) in + aux s.levels) +let (flush : + solver_state -> (FStarC_SMTEncoding_Term.decl Prims.list * solver_state)) = + fun s -> + let s1 = + let uu___ = + let uu___1 = FStarC_Options_Ext.get "context_pruning" in uu___1 <> "" in + if uu___ + then + let rec aux levels = + match levels with + | [] -> [] + | level::levels1 -> + (match level.pruning_roots with + | FStar_Pervasives_Native.Some roots -> + let hd = prune_level roots level s in hd :: levels1 + | FStar_Pervasives_Native.None -> + let uu___1 = aux levels1 in level :: uu___1) in + let uu___1 = aux s.levels in + { + levels = uu___1; + pending_flushes_rev = (s.pending_flushes_rev); + using_facts_from = (s.using_facts_from); + retain_assumptions = (s.retain_assumptions) + } + else s in + let to_flush = + let uu___ = + let uu___1 = + FStarC_Compiler_List.collect (fun level -> level.to_flush_rev) + s1.levels in + FStarC_Compiler_List.rev uu___1 in + FStarC_Compiler_List.flatten uu___ in + let levels = + FStarC_Compiler_List.map + (fun level -> + { + pruning_state = (level.pruning_state); + given_decl_names = (level.given_decl_names); + all_decls_at_level_rev = (level.all_decls_at_level_rev); + given_some_decls = + (level.given_some_decls || + (Prims.uu___is_Cons level.to_flush_rev)); + to_flush_rev = []; + named_assumptions = (level.named_assumptions); + pruning_roots = (level.pruning_roots) + }) s1.levels in + let s11 = + { + levels; + pending_flushes_rev = []; + using_facts_from = (s1.using_facts_from); + retain_assumptions = (s1.retain_assumptions) + } in + let flushed = + FStar_List_Tot_Base.op_At + (FStarC_Compiler_List.rev s1.pending_flushes_rev) to_flush in + (flushed, s11) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_SMTEncoding_Solver_Cache.ml b/ocaml/fstar-lib/generated/FStarC_SMTEncoding_Solver_Cache.ml new file mode 100644 index 00000000000..89241361214 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_SMTEncoding_Solver_Cache.ml @@ -0,0 +1,385 @@ +open Prims +let (hashable_lident : FStarC_Ident.lident FStarC_Class_Hashable.hashable) = + { + FStarC_Class_Hashable.hash = + (fun l -> + let uu___ = FStarC_Class_Show.show FStarC_Ident.showable_lident l in + FStarC_Class_Hashable.hash FStarC_Class_Hashable.hashable_string + uu___) + } +let (hashable_ident : FStarC_Ident.ident FStarC_Class_Hashable.hashable) = + { + FStarC_Class_Hashable.hash = + (fun i -> + let uu___ = FStarC_Class_Show.show FStarC_Ident.showable_ident i in + FStarC_Class_Hashable.hash FStarC_Class_Hashable.hashable_string + uu___) + } +let (hashable_binding : + FStarC_Syntax_Syntax.binding FStarC_Class_Hashable.hashable) = + { + FStarC_Class_Hashable.hash = + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.Binding_var bv -> + FStarC_Class_Hashable.hash FStarC_Syntax_Hash.hashable_term + bv.FStarC_Syntax_Syntax.sort + | FStarC_Syntax_Syntax.Binding_lid (l, (us, t)) -> + let uu___1 = + let uu___2 = FStarC_Class_Hashable.hash hashable_lident l in + let uu___3 = + FStarC_Class_Hashable.hash + (FStarC_Class_Hashable.hashable_list hashable_ident) us in + FStarC_Hash.mix uu___2 uu___3 in + let uu___2 = + FStarC_Class_Hashable.hash FStarC_Syntax_Hash.hashable_term t in + FStarC_Hash.mix uu___1 uu___2 + | FStarC_Syntax_Syntax.Binding_univ u -> + FStarC_Class_Hashable.hash hashable_ident u) + } +let (hashable_bv : FStarC_Syntax_Syntax.bv FStarC_Class_Hashable.hashable) = + { + FStarC_Class_Hashable.hash = + (fun b -> + FStarC_Class_Hashable.hash FStarC_Syntax_Hash.hashable_term + b.FStarC_Syntax_Syntax.sort) + } +let (hashable_fv : FStarC_Syntax_Syntax.fv FStarC_Class_Hashable.hashable) = + { + FStarC_Class_Hashable.hash = + (fun f -> + FStarC_Class_Hashable.hash hashable_lident + (f.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v) + } +let (hashable_binder : + FStarC_Syntax_Syntax.binder FStarC_Class_Hashable.hashable) = + { + FStarC_Class_Hashable.hash = + (fun b -> + FStarC_Class_Hashable.hash hashable_bv + b.FStarC_Syntax_Syntax.binder_bv) + } +let (hashable_letbinding : + FStarC_Syntax_Syntax.letbinding FStarC_Class_Hashable.hashable) = + { + FStarC_Class_Hashable.hash = + (fun lb -> + let uu___ = + let uu___1 = + FStarC_Class_Hashable.hash + (FStarC_Class_Hashable.hashable_either hashable_bv hashable_fv) + lb.FStarC_Syntax_Syntax.lbname in + let uu___2 = + FStarC_Class_Hashable.hash FStarC_Syntax_Hash.hashable_term + lb.FStarC_Syntax_Syntax.lbtyp in + FStarC_Hash.mix uu___1 uu___2 in + let uu___1 = + FStarC_Class_Hashable.hash FStarC_Syntax_Hash.hashable_term + lb.FStarC_Syntax_Syntax.lbdef in + FStarC_Hash.mix uu___ uu___1) + } +let (hashable_pragma : + FStarC_Syntax_Syntax.pragma FStarC_Class_Hashable.hashable) = + { + FStarC_Class_Hashable.hash = + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.SetOptions s -> + let uu___1 = + FStarC_Class_Hashable.hash FStarC_Class_Hashable.hashable_int + Prims.int_one in + let uu___2 = + FStarC_Class_Hashable.hash + FStarC_Class_Hashable.hashable_string s in + FStarC_Hash.mix uu___1 uu___2 + | FStarC_Syntax_Syntax.ResetOptions s -> + let uu___1 = + FStarC_Class_Hashable.hash FStarC_Class_Hashable.hashable_int + (Prims.of_int (2)) in + let uu___2 = + FStarC_Class_Hashable.hash + (FStarC_Class_Hashable.hashable_option + FStarC_Class_Hashable.hashable_string) s in + FStarC_Hash.mix uu___1 uu___2 + | FStarC_Syntax_Syntax.PushOptions s -> + let uu___1 = + FStarC_Class_Hashable.hash FStarC_Class_Hashable.hashable_int + (Prims.of_int (3)) in + let uu___2 = + FStarC_Class_Hashable.hash + (FStarC_Class_Hashable.hashable_option + FStarC_Class_Hashable.hashable_string) s in + FStarC_Hash.mix uu___1 uu___2 + | FStarC_Syntax_Syntax.PopOptions -> + FStarC_Class_Hashable.hash FStarC_Class_Hashable.hashable_int + (Prims.of_int (4)) + | FStarC_Syntax_Syntax.RestartSolver -> + FStarC_Class_Hashable.hash FStarC_Class_Hashable.hashable_int + (Prims.of_int (5)) + | FStarC_Syntax_Syntax.PrintEffectsGraph -> + FStarC_Class_Hashable.hash FStarC_Class_Hashable.hashable_int + (Prims.of_int (6))) + } +let rec (hash_sigelt : FStarC_Syntax_Syntax.sigelt -> FStarC_Hash.hash_code) + = fun se -> hash_sigelt' se.FStarC_Syntax_Syntax.sigel +and (hash_sigelt' : FStarC_Syntax_Syntax.sigelt' -> FStarC_Hash.hash_code) = + fun se -> + match se with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = lid; FStarC_Syntax_Syntax.us = us; + FStarC_Syntax_Syntax.params = params; + FStarC_Syntax_Syntax.num_uniform_params = num_uniform_params; + FStarC_Syntax_Syntax.t = t; FStarC_Syntax_Syntax.mutuals = mutuals; + FStarC_Syntax_Syntax.ds = ds; + FStarC_Syntax_Syntax.injective_type_params = injective_type_params;_} + -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Class_Hashable.hash + FStarC_Class_Hashable.hashable_int Prims.int_zero in + let uu___8 = + FStarC_Class_Hashable.hash hashable_lident lid in + FStarC_Hash.mix uu___7 uu___8 in + let uu___7 = + FStarC_Class_Hashable.hash + (FStarC_Class_Hashable.hashable_list hashable_ident) + us in + FStarC_Hash.mix uu___6 uu___7 in + let uu___6 = + FStarC_Class_Hashable.hash + (FStarC_Class_Hashable.hashable_list hashable_binder) + params in + FStarC_Hash.mix uu___5 uu___6 in + let uu___5 = + FStarC_Class_Hashable.hash + (FStarC_Class_Hashable.hashable_option + FStarC_Class_Hashable.hashable_int) num_uniform_params in + FStarC_Hash.mix uu___4 uu___5 in + let uu___4 = + FStarC_Class_Hashable.hash FStarC_Syntax_Hash.hashable_term t in + FStarC_Hash.mix uu___3 uu___4 in + let uu___3 = + FStarC_Class_Hashable.hash + (FStarC_Class_Hashable.hashable_list hashable_lident) mutuals in + FStarC_Hash.mix uu___2 uu___3 in + let uu___2 = + FStarC_Class_Hashable.hash + (FStarC_Class_Hashable.hashable_list hashable_lident) ds in + FStarC_Hash.mix uu___1 uu___2 in + let uu___1 = + FStarC_Class_Hashable.hash FStarC_Class_Hashable.hashable_bool + injective_type_params in + FStarC_Hash.mix uu___ uu___1 + | FStarC_Syntax_Syntax.Sig_bundle + { FStarC_Syntax_Syntax.ses = ses; FStarC_Syntax_Syntax.lids = lids;_} + -> + let uu___ = + let uu___1 = + FStarC_Class_Hashable.hash FStarC_Class_Hashable.hashable_int + Prims.int_one in + let uu___2 = + (FStarC_Class_Hashable.hashable_list + { FStarC_Class_Hashable.hash = hash_sigelt }).FStarC_Class_Hashable.hash + ses in + FStarC_Hash.mix uu___1 uu___2 in + let uu___1 = + FStarC_Class_Hashable.hash + (FStarC_Class_Hashable.hashable_list hashable_lident) lids in + FStarC_Hash.mix uu___ uu___1 + | FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = lid; FStarC_Syntax_Syntax.us1 = us; + FStarC_Syntax_Syntax.t1 = t; FStarC_Syntax_Syntax.ty_lid = ty_lid; + FStarC_Syntax_Syntax.num_ty_params = num_ty_params; + FStarC_Syntax_Syntax.mutuals1 = mutuals; + FStarC_Syntax_Syntax.injective_type_params1 = injective_type_params;_} + -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Class_Hashable.hash + FStarC_Class_Hashable.hashable_int (Prims.of_int (2)) in + let uu___7 = + FStarC_Class_Hashable.hash hashable_lident lid in + FStarC_Hash.mix uu___6 uu___7 in + let uu___6 = + FStarC_Class_Hashable.hash + (FStarC_Class_Hashable.hashable_list hashable_ident) us in + FStarC_Hash.mix uu___5 uu___6 in + let uu___5 = + FStarC_Class_Hashable.hash FStarC_Syntax_Hash.hashable_term + t in + FStarC_Hash.mix uu___4 uu___5 in + let uu___4 = FStarC_Class_Hashable.hash hashable_lident ty_lid in + FStarC_Hash.mix uu___3 uu___4 in + let uu___3 = + FStarC_Class_Hashable.hash FStarC_Class_Hashable.hashable_int + num_ty_params in + FStarC_Hash.mix uu___2 uu___3 in + let uu___2 = + FStarC_Class_Hashable.hash + (FStarC_Class_Hashable.hashable_list hashable_lident) mutuals in + FStarC_Hash.mix uu___1 uu___2 in + let uu___1 = + FStarC_Class_Hashable.hash FStarC_Class_Hashable.hashable_bool + injective_type_params in + FStarC_Hash.mix uu___ uu___1 + | FStarC_Syntax_Syntax.Sig_declare_typ + { FStarC_Syntax_Syntax.lid2 = lid; FStarC_Syntax_Syntax.us2 = us; + FStarC_Syntax_Syntax.t2 = t;_} + -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Class_Hashable.hash FStarC_Class_Hashable.hashable_int + (Prims.of_int (3)) in + let uu___3 = FStarC_Class_Hashable.hash hashable_lident lid in + FStarC_Hash.mix uu___2 uu___3 in + let uu___2 = + FStarC_Class_Hashable.hash + (FStarC_Class_Hashable.hashable_list hashable_ident) us in + FStarC_Hash.mix uu___1 uu___2 in + let uu___1 = + FStarC_Class_Hashable.hash FStarC_Syntax_Hash.hashable_term t in + FStarC_Hash.mix uu___ uu___1 + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = lbs; + FStarC_Syntax_Syntax.lids1 = lids;_} + -> + let uu___ = + let uu___1 = + FStarC_Class_Hashable.hash FStarC_Class_Hashable.hashable_int + (Prims.of_int (4)) in + let uu___2 = + FStarC_Class_Hashable.hash + (FStarC_Class_Hashable.hashable_tuple2 + FStarC_Class_Hashable.hashable_bool + (FStarC_Class_Hashable.hashable_list hashable_letbinding)) + lbs in + FStarC_Hash.mix uu___1 uu___2 in + let uu___1 = + FStarC_Class_Hashable.hash + (FStarC_Class_Hashable.hashable_list hashable_lident) lids in + FStarC_Hash.mix uu___ uu___1 + | FStarC_Syntax_Syntax.Sig_assume + { FStarC_Syntax_Syntax.lid3 = lid; FStarC_Syntax_Syntax.us3 = us; + FStarC_Syntax_Syntax.phi1 = phi;_} + -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Class_Hashable.hash FStarC_Class_Hashable.hashable_int + (Prims.of_int (5)) in + let uu___3 = FStarC_Class_Hashable.hash hashable_lident lid in + FStarC_Hash.mix uu___2 uu___3 in + let uu___2 = + FStarC_Class_Hashable.hash + (FStarC_Class_Hashable.hashable_list hashable_ident) us in + FStarC_Hash.mix uu___1 uu___2 in + let uu___1 = + FStarC_Class_Hashable.hash FStarC_Syntax_Hash.hashable_term phi in + FStarC_Hash.mix uu___ uu___1 + | FStarC_Syntax_Syntax.Sig_pragma p -> + let uu___ = + FStarC_Class_Hashable.hash FStarC_Class_Hashable.hashable_int + (Prims.of_int (6)) in + let uu___1 = FStarC_Class_Hashable.hash hashable_pragma p in + FStarC_Hash.mix uu___ uu___1 + | uu___ -> + FStarC_Class_Hashable.hash FStarC_Class_Hashable.hashable_int + Prims.int_zero +let (hashable_sigelt : + FStarC_Syntax_Syntax.sigelt FStarC_Class_Hashable.hashable) = + { FStarC_Class_Hashable.hash = hash_sigelt } +let (hashable_env : + FStarC_TypeChecker_Env.env FStarC_Class_Hashable.hashable) = + { + FStarC_Class_Hashable.hash = + (fun e -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Class_Hashable.hash + (FStarC_Class_Hashable.hashable_list hashable_binding) + e.FStarC_TypeChecker_Env.gamma in + let uu___3 = + FStarC_Class_Hashable.hash + (FStarC_Class_Hashable.hashable_list + (FStarC_Class_Hashable.hashable_tuple2 + (FStarC_Class_Hashable.hashable_list hashable_lident) + hashable_sigelt)) e.FStarC_TypeChecker_Env.gamma_sig in + FStarC_Hash.mix uu___2 uu___3 in + let uu___2 = + FStarC_Class_Hashable.hash + (FStarC_Class_Hashable.hashable_list + (FStarC_Class_Hashable.hashable_tuple2 + (FStarC_Class_Hashable.hashable_list + FStarC_Class_Hashable.hashable_string) + FStarC_Class_Hashable.hashable_bool)) + e.FStarC_TypeChecker_Env.proof_ns in + FStarC_Hash.mix uu___1 uu___2 in + let uu___1 = + FStarC_Class_Hashable.hash FStarC_Class_Hashable.hashable_bool + e.FStarC_TypeChecker_Env.admit in + FStarC_Hash.mix uu___ uu___1) + } +let (query_cache_ref : + FStarC_Hash.hash_code FStarC_Compiler_RBSet.t FStarC_Compiler_Effect.ref) = + let uu___ = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Hashable.ord_hash_code)) ()) in + FStarC_Compiler_Util.mk_ref uu___ +let (on : unit -> Prims.bool) = + fun uu___ -> (FStarC_Options.query_cache ()) && (FStarC_Options.ide ()) +let (query_cache_add : + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.term -> unit) = + fun g -> + fun q -> + let uu___ = on () in + if uu___ + then + let h = + FStarC_Class_Hashable.hash + (FStarC_Class_Hashable.hashable_tuple2 hashable_env + FStarC_Syntax_Hash.hashable_term) (g, q) in + let uu___1 = + let uu___2 = FStarC_Compiler_Effect.op_Bang query_cache_ref in + Obj.magic + (FStarC_Class_Setlike.add () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Hashable.ord_hash_code)) h + (Obj.magic uu___2)) in + FStarC_Compiler_Effect.op_Colon_Equals query_cache_ref uu___1 + else () +let (try_find_query_cache : + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.term -> Prims.bool) = + fun g -> + fun q -> + let uu___ = on () in + if uu___ + then + let h = + FStarC_Class_Hashable.hash + (FStarC_Class_Hashable.hashable_tuple2 hashable_env + FStarC_Syntax_Hash.hashable_term) (g, q) in + let r = + let uu___1 = FStarC_Compiler_Effect.op_Bang query_cache_ref in + FStarC_Class_Setlike.mem () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Hashable.ord_hash_code)) h (Obj.magic uu___1) in + r + else false \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_SMTEncoding_Term.ml b/ocaml/fstar-lib/generated/FStarC_SMTEncoding_Term.ml new file mode 100644 index 00000000000..1e87378220b --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_SMTEncoding_Term.ml @@ -0,0 +1,2551 @@ +open Prims +type sort = + | Bool_sort + | Int_sort + | String_sort + | Term_sort + | Fuel_sort + | BitVec_sort of Prims.int + | Array of (sort * sort) + | Arrow of (sort * sort) + | Sort of Prims.string +let (uu___is_Bool_sort : sort -> Prims.bool) = + fun projectee -> match projectee with | Bool_sort -> true | uu___ -> false +let (uu___is_Int_sort : sort -> Prims.bool) = + fun projectee -> match projectee with | Int_sort -> true | uu___ -> false +let (uu___is_String_sort : sort -> Prims.bool) = + fun projectee -> + match projectee with | String_sort -> true | uu___ -> false +let (uu___is_Term_sort : sort -> Prims.bool) = + fun projectee -> match projectee with | Term_sort -> true | uu___ -> false +let (uu___is_Fuel_sort : sort -> Prims.bool) = + fun projectee -> match projectee with | Fuel_sort -> true | uu___ -> false +let (uu___is_BitVec_sort : sort -> Prims.bool) = + fun projectee -> + match projectee with | BitVec_sort _0 -> true | uu___ -> false +let (__proj__BitVec_sort__item___0 : sort -> Prims.int) = + fun projectee -> match projectee with | BitVec_sort _0 -> _0 +let (uu___is_Array : sort -> Prims.bool) = + fun projectee -> match projectee with | Array _0 -> true | uu___ -> false +let (__proj__Array__item___0 : sort -> (sort * sort)) = + fun projectee -> match projectee with | Array _0 -> _0 +let (uu___is_Arrow : sort -> Prims.bool) = + fun projectee -> match projectee with | Arrow _0 -> true | uu___ -> false +let (__proj__Arrow__item___0 : sort -> (sort * sort)) = + fun projectee -> match projectee with | Arrow _0 -> _0 +let (uu___is_Sort : sort -> Prims.bool) = + fun projectee -> match projectee with | Sort _0 -> true | uu___ -> false +let (__proj__Sort__item___0 : sort -> Prims.string) = + fun projectee -> match projectee with | Sort _0 -> _0 +type op = + | TrueOp + | FalseOp + | Not + | And + | Or + | Imp + | Iff + | Eq + | LT + | LTE + | GT + | GTE + | Add + | Sub + | Div + | RealDiv + | Mul + | Minus + | Mod + | BvAnd + | BvXor + | BvOr + | BvAdd + | BvSub + | BvShl + | BvShr + | BvUdiv + | BvMod + | BvMul + | BvUlt + | BvUext of Prims.int + | NatToBv of Prims.int + | BvToNat + | ITE + | Var of Prims.string +let (uu___is_TrueOp : op -> Prims.bool) = + fun projectee -> match projectee with | TrueOp -> true | uu___ -> false +let (uu___is_FalseOp : op -> Prims.bool) = + fun projectee -> match projectee with | FalseOp -> true | uu___ -> false +let (uu___is_Not : op -> Prims.bool) = + fun projectee -> match projectee with | Not -> true | uu___ -> false +let (uu___is_And : op -> Prims.bool) = + fun projectee -> match projectee with | And -> true | uu___ -> false +let (uu___is_Or : op -> Prims.bool) = + fun projectee -> match projectee with | Or -> true | uu___ -> false +let (uu___is_Imp : op -> Prims.bool) = + fun projectee -> match projectee with | Imp -> true | uu___ -> false +let (uu___is_Iff : op -> Prims.bool) = + fun projectee -> match projectee with | Iff -> true | uu___ -> false +let (uu___is_Eq : op -> Prims.bool) = + fun projectee -> match projectee with | Eq -> true | uu___ -> false +let (uu___is_LT : op -> Prims.bool) = + fun projectee -> match projectee with | LT -> true | uu___ -> false +let (uu___is_LTE : op -> Prims.bool) = + fun projectee -> match projectee with | LTE -> true | uu___ -> false +let (uu___is_GT : op -> Prims.bool) = + fun projectee -> match projectee with | GT -> true | uu___ -> false +let (uu___is_GTE : op -> Prims.bool) = + fun projectee -> match projectee with | GTE -> true | uu___ -> false +let (uu___is_Add : op -> Prims.bool) = + fun projectee -> match projectee with | Add -> true | uu___ -> false +let (uu___is_Sub : op -> Prims.bool) = + fun projectee -> match projectee with | Sub -> true | uu___ -> false +let (uu___is_Div : op -> Prims.bool) = + fun projectee -> match projectee with | Div -> true | uu___ -> false +let (uu___is_RealDiv : op -> Prims.bool) = + fun projectee -> match projectee with | RealDiv -> true | uu___ -> false +let (uu___is_Mul : op -> Prims.bool) = + fun projectee -> match projectee with | Mul -> true | uu___ -> false +let (uu___is_Minus : op -> Prims.bool) = + fun projectee -> match projectee with | Minus -> true | uu___ -> false +let (uu___is_Mod : op -> Prims.bool) = + fun projectee -> match projectee with | Mod -> true | uu___ -> false +let (uu___is_BvAnd : op -> Prims.bool) = + fun projectee -> match projectee with | BvAnd -> true | uu___ -> false +let (uu___is_BvXor : op -> Prims.bool) = + fun projectee -> match projectee with | BvXor -> true | uu___ -> false +let (uu___is_BvOr : op -> Prims.bool) = + fun projectee -> match projectee with | BvOr -> true | uu___ -> false +let (uu___is_BvAdd : op -> Prims.bool) = + fun projectee -> match projectee with | BvAdd -> true | uu___ -> false +let (uu___is_BvSub : op -> Prims.bool) = + fun projectee -> match projectee with | BvSub -> true | uu___ -> false +let (uu___is_BvShl : op -> Prims.bool) = + fun projectee -> match projectee with | BvShl -> true | uu___ -> false +let (uu___is_BvShr : op -> Prims.bool) = + fun projectee -> match projectee with | BvShr -> true | uu___ -> false +let (uu___is_BvUdiv : op -> Prims.bool) = + fun projectee -> match projectee with | BvUdiv -> true | uu___ -> false +let (uu___is_BvMod : op -> Prims.bool) = + fun projectee -> match projectee with | BvMod -> true | uu___ -> false +let (uu___is_BvMul : op -> Prims.bool) = + fun projectee -> match projectee with | BvMul -> true | uu___ -> false +let (uu___is_BvUlt : op -> Prims.bool) = + fun projectee -> match projectee with | BvUlt -> true | uu___ -> false +let (uu___is_BvUext : op -> Prims.bool) = + fun projectee -> match projectee with | BvUext _0 -> true | uu___ -> false +let (__proj__BvUext__item___0 : op -> Prims.int) = + fun projectee -> match projectee with | BvUext _0 -> _0 +let (uu___is_NatToBv : op -> Prims.bool) = + fun projectee -> match projectee with | NatToBv _0 -> true | uu___ -> false +let (__proj__NatToBv__item___0 : op -> Prims.int) = + fun projectee -> match projectee with | NatToBv _0 -> _0 +let (uu___is_BvToNat : op -> Prims.bool) = + fun projectee -> match projectee with | BvToNat -> true | uu___ -> false +let (uu___is_ITE : op -> Prims.bool) = + fun projectee -> match projectee with | ITE -> true | uu___ -> false +let (uu___is_Var : op -> Prims.bool) = + fun projectee -> match projectee with | Var _0 -> true | uu___ -> false +let (__proj__Var__item___0 : op -> Prims.string) = + fun projectee -> match projectee with | Var _0 -> _0 +type qop = + | Forall + | Exists +let (uu___is_Forall : qop -> Prims.bool) = + fun projectee -> match projectee with | Forall -> true | uu___ -> false +let (uu___is_Exists : qop -> Prims.bool) = + fun projectee -> match projectee with | Exists -> true | uu___ -> false +type term' = + | Integer of Prims.string + | String of Prims.string + | Real of Prims.string + | BoundV of Prims.int + | FreeV of fv + | App of (op * term Prims.list) + | Quant of (qop * term Prims.list Prims.list * Prims.int + FStar_Pervasives_Native.option * sort Prims.list * term) + | Let of (term Prims.list * term) + | Labeled of (term * FStarC_Errors_Msg.error_message * + FStarC_Compiler_Range_Type.range) + | LblPos of (term * Prims.string) +and term = + { + tm: term' ; + freevars: fv Prims.list FStarC_Syntax_Syntax.memo ; + rng: FStarC_Compiler_Range_Type.range } +and fv = + | FV of (Prims.string * sort * Prims.bool) +let (uu___is_Integer : term' -> Prims.bool) = + fun projectee -> match projectee with | Integer _0 -> true | uu___ -> false +let (__proj__Integer__item___0 : term' -> Prims.string) = + fun projectee -> match projectee with | Integer _0 -> _0 +let (uu___is_String : term' -> Prims.bool) = + fun projectee -> match projectee with | String _0 -> true | uu___ -> false +let (__proj__String__item___0 : term' -> Prims.string) = + fun projectee -> match projectee with | String _0 -> _0 +let (uu___is_Real : term' -> Prims.bool) = + fun projectee -> match projectee with | Real _0 -> true | uu___ -> false +let (__proj__Real__item___0 : term' -> Prims.string) = + fun projectee -> match projectee with | Real _0 -> _0 +let (uu___is_BoundV : term' -> Prims.bool) = + fun projectee -> match projectee with | BoundV _0 -> true | uu___ -> false +let (__proj__BoundV__item___0 : term' -> Prims.int) = + fun projectee -> match projectee with | BoundV _0 -> _0 +let (uu___is_FreeV : term' -> Prims.bool) = + fun projectee -> match projectee with | FreeV _0 -> true | uu___ -> false +let (__proj__FreeV__item___0 : term' -> fv) = + fun projectee -> match projectee with | FreeV _0 -> _0 +let (uu___is_App : term' -> Prims.bool) = + fun projectee -> match projectee with | App _0 -> true | uu___ -> false +let (__proj__App__item___0 : term' -> (op * term Prims.list)) = + fun projectee -> match projectee with | App _0 -> _0 +let (uu___is_Quant : term' -> Prims.bool) = + fun projectee -> match projectee with | Quant _0 -> true | uu___ -> false +let (__proj__Quant__item___0 : + term' -> + (qop * term Prims.list Prims.list * Prims.int + FStar_Pervasives_Native.option * sort Prims.list * term)) + = fun projectee -> match projectee with | Quant _0 -> _0 +let (uu___is_Let : term' -> Prims.bool) = + fun projectee -> match projectee with | Let _0 -> true | uu___ -> false +let (__proj__Let__item___0 : term' -> (term Prims.list * term)) = + fun projectee -> match projectee with | Let _0 -> _0 +let (uu___is_Labeled : term' -> Prims.bool) = + fun projectee -> match projectee with | Labeled _0 -> true | uu___ -> false +let (__proj__Labeled__item___0 : + term' -> + (term * FStarC_Errors_Msg.error_message * + FStarC_Compiler_Range_Type.range)) + = fun projectee -> match projectee with | Labeled _0 -> _0 +let (uu___is_LblPos : term' -> Prims.bool) = + fun projectee -> match projectee with | LblPos _0 -> true | uu___ -> false +let (__proj__LblPos__item___0 : term' -> (term * Prims.string)) = + fun projectee -> match projectee with | LblPos _0 -> _0 +let (__proj__Mkterm__item__tm : term -> term') = + fun projectee -> match projectee with | { tm; freevars; rng;_} -> tm +let (__proj__Mkterm__item__freevars : + term -> fv Prims.list FStarC_Syntax_Syntax.memo) = + fun projectee -> match projectee with | { tm; freevars; rng;_} -> freevars +let (__proj__Mkterm__item__rng : term -> FStarC_Compiler_Range_Type.range) = + fun projectee -> match projectee with | { tm; freevars; rng;_} -> rng +let (uu___is_FV : fv -> Prims.bool) = fun projectee -> true +let (__proj__FV__item___0 : fv -> (Prims.string * sort * Prims.bool)) = + fun projectee -> match projectee with | FV _0 -> _0 +type pat = term +type fvs = fv Prims.list +type caption = Prims.string FStar_Pervasives_Native.option +type binders = (Prims.string * sort) Prims.list +type constructor_field = + { + field_name: Prims.string ; + field_sort: sort ; + field_projectible: Prims.bool } +let (__proj__Mkconstructor_field__item__field_name : + constructor_field -> Prims.string) = + fun projectee -> + match projectee with + | { field_name; field_sort; field_projectible;_} -> field_name +let (__proj__Mkconstructor_field__item__field_sort : + constructor_field -> sort) = + fun projectee -> + match projectee with + | { field_name; field_sort; field_projectible;_} -> field_sort +let (__proj__Mkconstructor_field__item__field_projectible : + constructor_field -> Prims.bool) = + fun projectee -> + match projectee with + | { field_name; field_sort; field_projectible;_} -> field_projectible +type constructor_t = + { + constr_name: Prims.string ; + constr_fields: constructor_field Prims.list ; + constr_sort: sort ; + constr_id: Prims.int FStar_Pervasives_Native.option ; + constr_base: Prims.bool } +let (__proj__Mkconstructor_t__item__constr_name : + constructor_t -> Prims.string) = + fun projectee -> + match projectee with + | { constr_name; constr_fields; constr_sort; constr_id; constr_base;_} -> + constr_name +let (__proj__Mkconstructor_t__item__constr_fields : + constructor_t -> constructor_field Prims.list) = + fun projectee -> + match projectee with + | { constr_name; constr_fields; constr_sort; constr_id; constr_base;_} -> + constr_fields +let (__proj__Mkconstructor_t__item__constr_sort : constructor_t -> sort) = + fun projectee -> + match projectee with + | { constr_name; constr_fields; constr_sort; constr_id; constr_base;_} -> + constr_sort +let (__proj__Mkconstructor_t__item__constr_id : + constructor_t -> Prims.int FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { constr_name; constr_fields; constr_sort; constr_id; constr_base;_} -> + constr_id +let (__proj__Mkconstructor_t__item__constr_base : + constructor_t -> Prims.bool) = + fun projectee -> + match projectee with + | { constr_name; constr_fields; constr_sort; constr_id; constr_base;_} -> + constr_base +type constructors = constructor_t Prims.list +type fact_db_id = + | Name of FStarC_Ident.lid + | Namespace of FStarC_Ident.lid + | Tag of Prims.string +let (uu___is_Name : fact_db_id -> Prims.bool) = + fun projectee -> match projectee with | Name _0 -> true | uu___ -> false +let (__proj__Name__item___0 : fact_db_id -> FStarC_Ident.lid) = + fun projectee -> match projectee with | Name _0 -> _0 +let (uu___is_Namespace : fact_db_id -> Prims.bool) = + fun projectee -> + match projectee with | Namespace _0 -> true | uu___ -> false +let (__proj__Namespace__item___0 : fact_db_id -> FStarC_Ident.lid) = + fun projectee -> match projectee with | Namespace _0 -> _0 +let (uu___is_Tag : fact_db_id -> Prims.bool) = + fun projectee -> match projectee with | Tag _0 -> true | uu___ -> false +let (__proj__Tag__item___0 : fact_db_id -> Prims.string) = + fun projectee -> match projectee with | Tag _0 -> _0 +type assumption = + { + assumption_term: term ; + assumption_caption: caption ; + assumption_name: Prims.string ; + assumption_fact_ids: fact_db_id Prims.list ; + assumption_free_names: Prims.string FStarC_Compiler_RBSet.t } +let (__proj__Mkassumption__item__assumption_term : assumption -> term) = + fun projectee -> + match projectee with + | { assumption_term; assumption_caption; assumption_name; + assumption_fact_ids; assumption_free_names;_} -> assumption_term +let (__proj__Mkassumption__item__assumption_caption : assumption -> caption) + = + fun projectee -> + match projectee with + | { assumption_term; assumption_caption; assumption_name; + assumption_fact_ids; assumption_free_names;_} -> assumption_caption +let (__proj__Mkassumption__item__assumption_name : + assumption -> Prims.string) = + fun projectee -> + match projectee with + | { assumption_term; assumption_caption; assumption_name; + assumption_fact_ids; assumption_free_names;_} -> assumption_name +let (__proj__Mkassumption__item__assumption_fact_ids : + assumption -> fact_db_id Prims.list) = + fun projectee -> + match projectee with + | { assumption_term; assumption_caption; assumption_name; + assumption_fact_ids; assumption_free_names;_} -> assumption_fact_ids +let (__proj__Mkassumption__item__assumption_free_names : + assumption -> Prims.string FStarC_Compiler_RBSet.t) = + fun projectee -> + match projectee with + | { assumption_term; assumption_caption; assumption_name; + assumption_fact_ids; assumption_free_names;_} -> + assumption_free_names +type decl = + | DefPrelude + | DeclFun of (Prims.string * sort Prims.list * sort * caption) + | DefineFun of (Prims.string * sort Prims.list * sort * term * caption) + | Assume of assumption + | Caption of Prims.string + | Module of (Prims.string * decl Prims.list) + | Eval of term + | Echo of Prims.string + | RetainAssumptions of Prims.string Prims.list + | Push of Prims.int + | Pop of Prims.int + | CheckSat + | GetUnsatCore + | SetOption of (Prims.string * Prims.string) + | GetStatistics + | GetReasonUnknown +let (uu___is_DefPrelude : decl -> Prims.bool) = + fun projectee -> match projectee with | DefPrelude -> true | uu___ -> false +let (uu___is_DeclFun : decl -> Prims.bool) = + fun projectee -> match projectee with | DeclFun _0 -> true | uu___ -> false +let (__proj__DeclFun__item___0 : + decl -> (Prims.string * sort Prims.list * sort * caption)) = + fun projectee -> match projectee with | DeclFun _0 -> _0 +let (uu___is_DefineFun : decl -> Prims.bool) = + fun projectee -> + match projectee with | DefineFun _0 -> true | uu___ -> false +let (__proj__DefineFun__item___0 : + decl -> (Prims.string * sort Prims.list * sort * term * caption)) = + fun projectee -> match projectee with | DefineFun _0 -> _0 +let (uu___is_Assume : decl -> Prims.bool) = + fun projectee -> match projectee with | Assume _0 -> true | uu___ -> false +let (__proj__Assume__item___0 : decl -> assumption) = + fun projectee -> match projectee with | Assume _0 -> _0 +let (uu___is_Caption : decl -> Prims.bool) = + fun projectee -> match projectee with | Caption _0 -> true | uu___ -> false +let (__proj__Caption__item___0 : decl -> Prims.string) = + fun projectee -> match projectee with | Caption _0 -> _0 +let (uu___is_Module : decl -> Prims.bool) = + fun projectee -> match projectee with | Module _0 -> true | uu___ -> false +let (__proj__Module__item___0 : decl -> (Prims.string * decl Prims.list)) = + fun projectee -> match projectee with | Module _0 -> _0 +let (uu___is_Eval : decl -> Prims.bool) = + fun projectee -> match projectee with | Eval _0 -> true | uu___ -> false +let (__proj__Eval__item___0 : decl -> term) = + fun projectee -> match projectee with | Eval _0 -> _0 +let (uu___is_Echo : decl -> Prims.bool) = + fun projectee -> match projectee with | Echo _0 -> true | uu___ -> false +let (__proj__Echo__item___0 : decl -> Prims.string) = + fun projectee -> match projectee with | Echo _0 -> _0 +let (uu___is_RetainAssumptions : decl -> Prims.bool) = + fun projectee -> + match projectee with | RetainAssumptions _0 -> true | uu___ -> false +let (__proj__RetainAssumptions__item___0 : decl -> Prims.string Prims.list) = + fun projectee -> match projectee with | RetainAssumptions _0 -> _0 +let (uu___is_Push : decl -> Prims.bool) = + fun projectee -> match projectee with | Push _0 -> true | uu___ -> false +let (__proj__Push__item___0 : decl -> Prims.int) = + fun projectee -> match projectee with | Push _0 -> _0 +let (uu___is_Pop : decl -> Prims.bool) = + fun projectee -> match projectee with | Pop _0 -> true | uu___ -> false +let (__proj__Pop__item___0 : decl -> Prims.int) = + fun projectee -> match projectee with | Pop _0 -> _0 +let (uu___is_CheckSat : decl -> Prims.bool) = + fun projectee -> match projectee with | CheckSat -> true | uu___ -> false +let (uu___is_GetUnsatCore : decl -> Prims.bool) = + fun projectee -> + match projectee with | GetUnsatCore -> true | uu___ -> false +let (uu___is_SetOption : decl -> Prims.bool) = + fun projectee -> + match projectee with | SetOption _0 -> true | uu___ -> false +let (__proj__SetOption__item___0 : decl -> (Prims.string * Prims.string)) = + fun projectee -> match projectee with | SetOption _0 -> _0 +let (uu___is_GetStatistics : decl -> Prims.bool) = + fun projectee -> + match projectee with | GetStatistics -> true | uu___ -> false +let (uu___is_GetReasonUnknown : decl -> Prims.bool) = + fun projectee -> + match projectee with | GetReasonUnknown -> true | uu___ -> false +type decls_elt = + { + sym_name: Prims.string FStar_Pervasives_Native.option ; + key: Prims.string FStar_Pervasives_Native.option ; + decls: decl Prims.list ; + a_names: Prims.string Prims.list } +let (__proj__Mkdecls_elt__item__sym_name : + decls_elt -> Prims.string FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with | { sym_name; key; decls; a_names;_} -> sym_name +let (__proj__Mkdecls_elt__item__key : + decls_elt -> Prims.string FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with | { sym_name; key; decls; a_names;_} -> key +let (__proj__Mkdecls_elt__item__decls : decls_elt -> decl Prims.list) = + fun projectee -> + match projectee with | { sym_name; key; decls; a_names;_} -> decls +let (__proj__Mkdecls_elt__item__a_names : + decls_elt -> Prims.string Prims.list) = + fun projectee -> + match projectee with | { sym_name; key; decls; a_names;_} -> a_names +type decls_t = decls_elt Prims.list +let (escape : Prims.string -> Prims.string) = + fun s -> FStarC_Compiler_Util.replace_char s 39 95 +let rec (strSort : sort -> Prims.string) = + fun x -> + match x with + | Bool_sort -> "Bool" + | Int_sort -> "Int" + | Term_sort -> "Term" + | String_sort -> "FString" + | Fuel_sort -> "Fuel" + | BitVec_sort n -> + let uu___ = FStarC_Compiler_Util.string_of_int n in + FStarC_Compiler_Util.format1 "(_ BitVec %s)" uu___ + | Array (s1, s2) -> + let uu___ = strSort s1 in + let uu___1 = strSort s2 in + FStarC_Compiler_Util.format2 "(Array %s %s)" uu___ uu___1 + | Arrow (s1, s2) -> + let uu___ = strSort s1 in + let uu___1 = strSort s2 in + FStarC_Compiler_Util.format2 "(%s -> %s)" uu___ uu___1 + | Sort s -> s +let (mk_decls : + Prims.string -> + Prims.string -> decl Prims.list -> decls_elt Prims.list -> decls_t) + = + fun name -> + fun key -> + fun decls -> + fun aux_decls -> + let uu___ = + let uu___1 = + let sm = FStarC_Compiler_Util.smap_create (Prims.of_int (20)) in + FStarC_Compiler_List.iter + (fun elt -> + FStarC_Compiler_List.iter + (fun s -> FStarC_Compiler_Util.smap_add sm s "0") + elt.a_names) aux_decls; + FStarC_Compiler_List.iter + (fun d -> + match d with + | Assume a -> + FStarC_Compiler_Util.smap_add sm a.assumption_name "0" + | uu___4 -> ()) decls; + FStarC_Compiler_Util.smap_keys sm in + { + sym_name = (FStar_Pervasives_Native.Some name); + key = (FStar_Pervasives_Native.Some key); + decls; + a_names = uu___1 + } in + [uu___] +let (mk_decls_trivial : decl Prims.list -> decls_t) = + fun decls -> + let uu___ = + let uu___1 = + FStarC_Compiler_List.collect + (fun uu___2 -> + match uu___2 with + | Assume a -> [a.assumption_name] + | uu___3 -> []) decls in + { + sym_name = FStar_Pervasives_Native.None; + key = FStar_Pervasives_Native.None; + decls; + a_names = uu___1 + } in + [uu___] +let (decls_list_of : decls_t -> decl Prims.list) = + fun l -> FStarC_Compiler_List.collect (fun elt -> elt.decls) l +let (mk_fv : (Prims.string * sort) -> fv) = + fun uu___ -> match uu___ with | (x, y) -> FV (x, y, false) +let (fv_name : fv -> Prims.string) = + fun x -> let uu___ = x in match uu___ with | FV (nm, uu___1, uu___2) -> nm +let (deq_fv : fv FStarC_Class_Deq.deq) = + { + FStarC_Class_Deq.op_Equals_Question = + (fun fv1 -> + fun fv2 -> + let uu___ = fv_name fv1 in + let uu___1 = fv_name fv2 in uu___ = uu___1) + } +let (ord_fv : fv FStarC_Class_Ord.ord) = + { + FStarC_Class_Ord.super = deq_fv; + FStarC_Class_Ord.cmp = + (fun fv1 -> + fun fv2 -> + let uu___ = + let uu___1 = fv_name fv1 in + let uu___2 = fv_name fv2 in + FStarC_Compiler_Util.compare uu___1 uu___2 in + FStarC_Compiler_Order.order_from_int uu___) + } +let (fv_sort : fv -> sort) = + fun x -> + let uu___ = x in match uu___ with | FV (uu___1, sort1, uu___2) -> sort1 +let (fv_force : fv -> Prims.bool) = + fun x -> + let uu___ = x in match uu___ with | FV (uu___1, uu___2, force) -> force +type error_label = + (fv * FStarC_Errors_Msg.error_message * FStarC_Compiler_Range_Type.range) +type error_labels = error_label Prims.list +let (fv_eq : fv -> fv -> Prims.bool) = + fun x -> + fun y -> + let uu___ = fv_name x in let uu___1 = fv_name y in uu___ = uu___1 +let (fvs_subset_of : fvs -> fvs -> Prims.bool) = + fun x -> + fun y -> + let uu___ = + Obj.magic + (FStarC_Class_Setlike.from_list () + (Obj.magic (FStarC_Compiler_RBSet.setlike_rbset ord_fv)) x) in + let uu___1 = + Obj.magic + (FStarC_Class_Setlike.from_list () + (Obj.magic (FStarC_Compiler_RBSet.setlike_rbset ord_fv)) y) in + FStarC_Class_Setlike.subset () + (Obj.magic (FStarC_Compiler_RBSet.setlike_rbset ord_fv)) + (Obj.magic uu___) (Obj.magic uu___1) +let (freevar_eq : term -> term -> Prims.bool) = + fun x -> + fun y -> + match ((x.tm), (y.tm)) with + | (FreeV x1, FreeV y1) -> fv_eq x1 y1 + | uu___ -> false +let (freevar_sort : term -> sort) = + fun uu___ -> + match uu___ with + | { tm = FreeV x; freevars = uu___1; rng = uu___2;_} -> fv_sort x + | uu___1 -> failwith "impossible" +let (fv_of_term : term -> fv) = + fun uu___ -> + match uu___ with + | { tm = FreeV fv1; freevars = uu___1; rng = uu___2;_} -> fv1 + | uu___1 -> failwith "impossible" +let rec (freevars : term -> fv Prims.list) = + fun t -> + match t.tm with + | Integer uu___ -> [] + | String uu___ -> [] + | Real uu___ -> [] + | BoundV uu___ -> [] + | FreeV fv1 when fv_force fv1 -> [] + | FreeV fv1 -> [fv1] + | App (uu___, tms) -> FStarC_Compiler_List.collect freevars tms + | Quant (uu___, uu___1, uu___2, uu___3, t1) -> freevars t1 + | Labeled (t1, uu___, uu___1) -> freevars t1 + | LblPos (t1, uu___) -> freevars t1 + | Let (es, body) -> FStarC_Compiler_List.collect freevars (body :: es) +let (free_variables : term -> fvs) = + fun t -> + let uu___ = FStarC_Compiler_Effect.op_Bang t.freevars in + match uu___ with + | FStar_Pervasives_Native.Some b -> b + | FStar_Pervasives_Native.None -> + let fvs1 = + let uu___1 = freevars t in + FStarC_Compiler_Util.remove_dups fv_eq uu___1 in + (FStarC_Compiler_Effect.op_Colon_Equals t.freevars + (FStar_Pervasives_Native.Some fvs1); + fvs1) +let (free_top_level_names : term -> Prims.string FStarC_Compiler_RBSet.t) = + fun t -> + let rec free_top_level_names1 uu___1 uu___ = + (fun acc -> + fun t1 -> + match t1.tm with + | FreeV (FV (nm, uu___, uu___1)) -> + Obj.magic + (Obj.repr + (FStarC_Class_Setlike.add () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) nm (Obj.magic acc))) + | App (Var s, args) -> + Obj.magic + (Obj.repr + (let acc1 = + Obj.magic + (FStarC_Class_Setlike.add () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) s + (Obj.magic acc)) in + FStarC_Compiler_List.fold_left free_top_level_names1 + acc1 args)) + | App (uu___, args) -> + Obj.magic + (Obj.repr + (FStarC_Compiler_List.fold_left free_top_level_names1 acc + args)) + | Quant (uu___, pats, uu___1, uu___2, body) -> + Obj.magic + (Obj.repr + (let acc1 = + FStarC_Compiler_List.fold_left + (fun acc2 -> + fun pats1 -> + FStarC_Compiler_List.fold_left + free_top_level_names1 acc2 pats1) acc pats in + free_top_level_names1 acc1 body)) + | Let (tms, t2) -> + Obj.magic + (Obj.repr + (let acc1 = + FStarC_Compiler_List.fold_left free_top_level_names1 + acc tms in + free_top_level_names1 acc1 t2)) + | Labeled (t2, uu___, uu___1) -> + Obj.magic (Obj.repr (free_top_level_names1 acc t2)) + | LblPos (t2, uu___) -> + Obj.magic (Obj.repr (free_top_level_names1 acc t2)) + | uu___ -> Obj.magic (Obj.repr acc)) uu___1 uu___ in + let uu___ = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) ()) in + free_top_level_names1 uu___ t +let (qop_to_string : qop -> Prims.string) = + fun uu___ -> match uu___ with | Forall -> "forall" | Exists -> "exists" +let (op_to_string : op -> Prims.string) = + fun uu___ -> + match uu___ with + | TrueOp -> "true" + | FalseOp -> "false" + | Not -> "not" + | And -> "and" + | Or -> "or" + | Imp -> "implies" + | Iff -> "iff" + | Eq -> "=" + | LT -> "<" + | LTE -> "<=" + | GT -> ">" + | GTE -> ">=" + | Add -> "+" + | Sub -> "-" + | Div -> "div" + | RealDiv -> "/" + | Mul -> "*" + | Minus -> "-" + | Mod -> "mod" + | ITE -> "ite" + | BvAnd -> "bvand" + | BvXor -> "bvxor" + | BvOr -> "bvor" + | BvAdd -> "bvadd" + | BvSub -> "bvsub" + | BvShl -> "bvshl" + | BvShr -> "bvlshr" + | BvUdiv -> "bvudiv" + | BvMod -> "bvurem" + | BvMul -> "bvmul" + | BvUlt -> "bvult" + | BvToNat -> "bv2int" + | BvUext n -> + let uu___1 = FStarC_Compiler_Util.string_of_int n in + FStarC_Compiler_Util.format1 "(_ zero_extend %s)" uu___1 + | NatToBv n -> + let uu___1 = FStarC_Compiler_Util.string_of_int n in + FStarC_Compiler_Util.format1 "(_ int2bv %s)" uu___1 + | Var s -> s +let (weightToSmt : Prims.int FStar_Pervasives_Native.option -> Prims.string) + = + fun uu___ -> + match uu___ with + | FStar_Pervasives_Native.None -> "" + | FStar_Pervasives_Native.Some i -> + let uu___1 = FStarC_Compiler_Util.string_of_int i in + FStarC_Compiler_Util.format1 ":weight %s\n" uu___1 +let rec (hash_of_term' : term' -> Prims.string) = + fun t -> + match t with + | Integer i -> i + | String s -> s + | Real r -> r + | BoundV i -> + let uu___ = FStarC_Compiler_Util.string_of_int i in + Prims.strcat "@" uu___ + | FreeV x -> + let uu___ = fv_name x in + let uu___1 = + let uu___2 = let uu___3 = fv_sort x in strSort uu___3 in + Prims.strcat ":" uu___2 in + Prims.strcat uu___ uu___1 + | App (op1, tms) -> + let uu___ = + let uu___1 = op_to_string op1 in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Compiler_List.map hash_of_term tms in + FStarC_Compiler_String.concat " " uu___4 in + Prims.strcat uu___3 ")" in + Prims.strcat uu___1 uu___2 in + Prims.strcat "(" uu___ + | Labeled (t1, r1, r2) -> + let uu___ = hash_of_term t1 in + let uu___1 = + let uu___2 = FStarC_Errors_Msg.rendermsg r1 in + let uu___3 = FStarC_Compiler_Range_Ops.string_of_range r2 in + Prims.strcat uu___2 uu___3 in + Prims.strcat uu___ uu___1 + | LblPos (t1, r) -> + let uu___ = + let uu___1 = hash_of_term t1 in + Prims.strcat uu___1 (Prims.strcat " :lblpos " (Prims.strcat r ")")) in + Prims.strcat "(! " uu___ + | Quant (qop1, pats, wopt, sorts, body) -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Compiler_List.map strSort sorts in + FStarC_Compiler_String.concat " " uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = hash_of_term body in + let uu___7 = + let uu___8 = + let uu___9 = weightToSmt wopt in + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Compiler_List.map + (fun pats1 -> + let uu___14 = + FStarC_Compiler_List.map hash_of_term + pats1 in + FStarC_Compiler_String.concat " " uu___14) + pats in + FStarC_Compiler_String.concat "; " uu___13 in + Prims.strcat uu___12 "))" in + Prims.strcat " " uu___11 in + Prims.strcat uu___9 uu___10 in + Prims.strcat " " uu___8 in + Prims.strcat uu___6 uu___7 in + Prims.strcat ")(! " uu___5 in + Prims.strcat uu___3 uu___4 in + Prims.strcat " (" uu___2 in + Prims.strcat (qop_to_string qop1) uu___1 in + Prims.strcat "(" uu___ + | Let (es, body) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Compiler_List.map hash_of_term es in + FStarC_Compiler_String.concat " " uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = hash_of_term body in Prims.strcat uu___4 ")" in + Prims.strcat ") " uu___3 in + Prims.strcat uu___1 uu___2 in + Prims.strcat "(let (" uu___ +and (hash_of_term : term -> Prims.string) = fun tm -> hash_of_term' tm.tm +let (mkBoxFunctions : Prims.string -> (Prims.string * Prims.string)) = + fun s -> (s, (Prims.strcat s "_proj_0")) +let (boxIntFun : (Prims.string * Prims.string)) = mkBoxFunctions "BoxInt" +let (boxBoolFun : (Prims.string * Prims.string)) = mkBoxFunctions "BoxBool" +let (boxStringFun : (Prims.string * Prims.string)) = + mkBoxFunctions "BoxString" +let (boxBitVecFun : Prims.int -> (Prims.string * Prims.string)) = + fun sz -> + let uu___ = + let uu___1 = FStarC_Compiler_Util.string_of_int sz in + Prims.strcat "BoxBitVec" uu___1 in + mkBoxFunctions uu___ +let (boxRealFun : (Prims.string * Prims.string)) = mkBoxFunctions "BoxReal" +let (isInjective : Prims.string -> Prims.bool) = + fun s -> + if (FStar_String.strlen s) >= (Prims.of_int (3)) + then + (let uu___ = + FStarC_Compiler_String.substring s Prims.int_zero (Prims.of_int (3)) in + uu___ = "Box") && + (let uu___ = + FStarC_Compiler_List.existsML (fun c -> c = 46) + (FStar_String.list_of_string s) in + Prims.op_Negation uu___) + else false +let (mk : term' -> FStarC_Compiler_Range_Type.range -> term) = + fun t -> + fun r -> + let uu___ = FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None in + { tm = t; freevars = uu___; rng = r } +let (mkTrue : FStarC_Compiler_Range_Type.range -> term) = + fun r -> mk (App (TrueOp, [])) r +let (mkFalse : FStarC_Compiler_Range_Type.range -> term) = + fun r -> mk (App (FalseOp, [])) r +let (mkUnreachable : term) = + mk (App ((Var "Unreachable"), [])) FStarC_Compiler_Range_Type.dummyRange +let (mkInteger : Prims.string -> FStarC_Compiler_Range_Type.range -> term) = + fun i -> + fun r -> + let uu___ = + let uu___1 = FStarC_Compiler_Util.ensure_decimal i in Integer uu___1 in + mk uu___ r +let (mkInteger' : Prims.int -> FStarC_Compiler_Range_Type.range -> term) = + fun i -> + fun r -> + let uu___ = FStarC_Compiler_Util.string_of_int i in mkInteger uu___ r +let (mkReal : Prims.string -> FStarC_Compiler_Range_Type.range -> term) = + fun i -> fun r -> mk (Real i) r +let (mkBoundV : Prims.int -> FStarC_Compiler_Range_Type.range -> term) = + fun i -> fun r -> mk (BoundV i) r +let (mkFreeV : fv -> FStarC_Compiler_Range_Type.range -> term) = + fun x -> fun r -> mk (FreeV x) r +let (mkApp' : + (op * term Prims.list) -> FStarC_Compiler_Range_Type.range -> term) = + fun f -> fun r -> mk (App f) r +let (mkApp : + (Prims.string * term Prims.list) -> + FStarC_Compiler_Range_Type.range -> term) + = + fun uu___ -> + fun r -> match uu___ with | (s, args) -> mk (App ((Var s), args)) r +let (mkNot : term -> FStarC_Compiler_Range_Type.range -> term) = + fun t -> + fun r -> + match t.tm with + | App (TrueOp, uu___) -> mkFalse r + | App (FalseOp, uu___) -> mkTrue r + | uu___ -> mkApp' (Not, [t]) r +let (mkAnd : (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + fun uu___ -> + fun r -> + match uu___ with + | (t1, t2) -> + (match ((t1.tm), (t2.tm)) with + | (App (TrueOp, uu___1), uu___2) -> t2 + | (uu___1, App (TrueOp, uu___2)) -> t1 + | (App (FalseOp, uu___1), uu___2) -> mkFalse r + | (uu___1, App (FalseOp, uu___2)) -> mkFalse r + | (App (And, ts1), App (And, ts2)) -> + mkApp' (And, (FStarC_Compiler_List.op_At ts1 ts2)) r + | (uu___1, App (And, ts2)) -> mkApp' (And, (t1 :: ts2)) r + | (App (And, ts1), uu___1) -> + mkApp' (And, (FStarC_Compiler_List.op_At ts1 [t2])) r + | uu___1 -> mkApp' (And, [t1; t2]) r) +let (mkOr : (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + fun uu___ -> + fun r -> + match uu___ with + | (t1, t2) -> + (match ((t1.tm), (t2.tm)) with + | (App (TrueOp, uu___1), uu___2) -> mkTrue r + | (uu___1, App (TrueOp, uu___2)) -> mkTrue r + | (App (FalseOp, uu___1), uu___2) -> t2 + | (uu___1, App (FalseOp, uu___2)) -> t1 + | (App (Or, ts1), App (Or, ts2)) -> + mkApp' (Or, (FStarC_Compiler_List.op_At ts1 ts2)) r + | (uu___1, App (Or, ts2)) -> mkApp' (Or, (t1 :: ts2)) r + | (App (Or, ts1), uu___1) -> + mkApp' (Or, (FStarC_Compiler_List.op_At ts1 [t2])) r + | uu___1 -> mkApp' (Or, [t1; t2]) r) +let (mkImp : (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + fun uu___ -> + fun r -> + match uu___ with + | (t1, t2) -> + (match ((t1.tm), (t2.tm)) with + | (uu___1, App (TrueOp, uu___2)) -> mkTrue r + | (App (FalseOp, uu___1), uu___2) -> mkTrue r + | (App (TrueOp, uu___1), uu___2) -> t2 + | (uu___1, App (Imp, t1'::t2'::[])) -> + let uu___2 = + let uu___3 = let uu___4 = mkAnd (t1, t1') r in [uu___4; t2'] in + (Imp, uu___3) in + mkApp' uu___2 r + | uu___1 -> mkApp' (Imp, [t1; t2]) r) +let (mk_bin_op : + op -> (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + fun op1 -> + fun uu___ -> + fun r -> match uu___ with | (t1, t2) -> mkApp' (op1, [t1; t2]) r +let (mkMinus : term -> FStarC_Compiler_Range_Type.range -> term) = + fun t -> fun r -> mkApp' (Minus, [t]) r +let (mkNatToBv : + Prims.int -> term -> FStarC_Compiler_Range_Type.range -> term) = + fun sz -> fun t -> fun r -> mkApp' ((NatToBv sz), [t]) r +let (mkBvUext : + Prims.int -> term -> FStarC_Compiler_Range_Type.range -> term) = + fun sz -> fun t -> fun r -> mkApp' ((BvUext sz), [t]) r +let (mkBvToNat : term -> FStarC_Compiler_Range_Type.range -> term) = + fun t -> fun r -> mkApp' (BvToNat, [t]) r +let (mkBvAnd : (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + mk_bin_op BvAnd +let (mkBvXor : (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + mk_bin_op BvXor +let (mkBvOr : (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + mk_bin_op BvOr +let (mkBvAdd : (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + mk_bin_op BvAdd +let (mkBvSub : (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + mk_bin_op BvSub +let (mkBvShl : + Prims.int -> (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + fun sz -> + fun uu___ -> + fun r -> + match uu___ with + | (t1, t2) -> + let uu___1 = + let uu___2 = + let uu___3 = let uu___4 = mkNatToBv sz t2 r in [uu___4] in t1 + :: uu___3 in + (BvShl, uu___2) in + mkApp' uu___1 r +let (mkBvShr : + Prims.int -> (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + fun sz -> + fun uu___ -> + fun r -> + match uu___ with + | (t1, t2) -> + let uu___1 = + let uu___2 = + let uu___3 = let uu___4 = mkNatToBv sz t2 r in [uu___4] in t1 + :: uu___3 in + (BvShr, uu___2) in + mkApp' uu___1 r +let (mkBvUdiv : + Prims.int -> (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + fun sz -> + fun uu___ -> + fun r -> + match uu___ with + | (t1, t2) -> + let uu___1 = + let uu___2 = + let uu___3 = let uu___4 = mkNatToBv sz t2 r in [uu___4] in t1 + :: uu___3 in + (BvUdiv, uu___2) in + mkApp' uu___1 r +let (mkBvMod : + Prims.int -> (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + fun sz -> + fun uu___ -> + fun r -> + match uu___ with + | (t1, t2) -> + let uu___1 = + let uu___2 = + let uu___3 = let uu___4 = mkNatToBv sz t2 r in [uu___4] in t1 + :: uu___3 in + (BvMod, uu___2) in + mkApp' uu___1 r +let (mkBvMul : + Prims.int -> (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + fun sz -> + fun uu___ -> + fun r -> + match uu___ with + | (t1, t2) -> + let uu___1 = + let uu___2 = + let uu___3 = let uu___4 = mkNatToBv sz t2 r in [uu___4] in t1 + :: uu___3 in + (BvMul, uu___2) in + mkApp' uu___1 r +let (mkBvShl' : + Prims.int -> (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + fun sz -> + fun uu___ -> + fun r -> match uu___ with | (t1, t2) -> mkApp' (BvShl, [t1; t2]) r +let (mkBvShr' : + Prims.int -> (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + fun sz -> + fun uu___ -> + fun r -> match uu___ with | (t1, t2) -> mkApp' (BvShr, [t1; t2]) r +let (mkBvMul' : + Prims.int -> (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + fun sz -> + fun uu___ -> + fun r -> match uu___ with | (t1, t2) -> mkApp' (BvMul, [t1; t2]) r +let (mkBvUdivUnsafe : + Prims.int -> (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + fun sz -> + fun uu___ -> + fun r -> match uu___ with | (t1, t2) -> mkApp' (BvUdiv, [t1; t2]) r +let (mkBvModUnsafe : + Prims.int -> (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + fun sz -> + fun uu___ -> + fun r -> match uu___ with | (t1, t2) -> mkApp' (BvMod, [t1; t2]) r +let (mkBvUlt : (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + mk_bin_op BvUlt +let (mkIff : (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + mk_bin_op Iff +let (mkEq : (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + fun uu___ -> + fun r -> + match uu___ with + | (t1, t2) -> + (match ((t1.tm), (t2.tm)) with + | (App (Var f1, s1::[]), App (Var f2, s2::[])) when + (f1 = f2) && (isInjective f1) -> mk_bin_op Eq (s1, s2) r + | uu___1 -> mk_bin_op Eq (t1, t2) r) +let (mkLT : (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + mk_bin_op LT +let (mkLTE : (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + mk_bin_op LTE +let (mkGT : (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + mk_bin_op GT +let (mkGTE : (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + mk_bin_op GTE +let (mkAdd : (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + mk_bin_op Add +let (mkSub : (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + mk_bin_op Sub +let (mkDiv : (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + mk_bin_op Div +let (mkRealDiv : (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + mk_bin_op RealDiv +let (mkMul : (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + mk_bin_op Mul +let (mkMod : (term * term) -> FStarC_Compiler_Range_Type.range -> term) = + mk_bin_op Mod +let (mkRealOfInt : term -> FStarC_Compiler_Range_Type.range -> term) = + fun t -> fun r -> mkApp ("to_real", [t]) r +let (mkITE : + (term * term * term) -> FStarC_Compiler_Range_Type.range -> term) = + fun uu___ -> + fun r -> + match uu___ with + | (t1, t2, t3) -> + (match t1.tm with + | App (TrueOp, uu___1) -> t2 + | App (FalseOp, uu___1) -> t3 + | uu___1 -> + (match ((t2.tm), (t3.tm)) with + | (App (TrueOp, uu___2), App (TrueOp, uu___3)) -> mkTrue r + | (App (TrueOp, uu___2), uu___3) -> + let uu___4 = let uu___5 = mkNot t1 t1.rng in (uu___5, t3) in + mkImp uu___4 r + | (uu___2, App (TrueOp, uu___3)) -> mkImp (t1, t2) r + | (uu___2, uu___3) -> mkApp' (ITE, [t1; t2; t3]) r)) +let (mkCases : term Prims.list -> FStarC_Compiler_Range_Type.range -> term) = + fun t -> + fun r -> + match t with + | [] -> failwith "Impos" + | hd::tl -> + FStarC_Compiler_List.fold_left + (fun out -> fun t1 -> mkAnd (out, t1) r) hd tl +let (check_pattern_ok : term -> term FStar_Pervasives_Native.option) = + fun t -> + let rec aux t1 = + match t1.tm with + | Integer uu___ -> FStar_Pervasives_Native.None + | String uu___ -> FStar_Pervasives_Native.None + | Real uu___ -> FStar_Pervasives_Native.None + | BoundV uu___ -> FStar_Pervasives_Native.None + | FreeV uu___ -> FStar_Pervasives_Native.None + | Let (tms, tm) -> aux_l (tm :: tms) + | App (head, terms) -> + let head_ok = + match head with + | Var uu___ -> true + | TrueOp -> true + | FalseOp -> true + | Not -> false + | And -> false + | Or -> false + | Imp -> false + | Iff -> false + | Eq -> false + | LT -> true + | LTE -> true + | GT -> true + | GTE -> true + | Add -> true + | Sub -> true + | Div -> true + | RealDiv -> true + | Mul -> true + | Minus -> true + | Mod -> true + | BvAnd -> false + | BvXor -> false + | BvOr -> false + | BvAdd -> false + | BvSub -> false + | BvShl -> false + | BvShr -> false + | BvUdiv -> false + | BvMod -> false + | BvMul -> false + | BvUlt -> false + | BvUext uu___ -> false + | NatToBv uu___ -> false + | BvToNat -> false + | ITE -> false in + if Prims.op_Negation head_ok + then FStar_Pervasives_Native.Some t1 + else aux_l terms + | Labeled (t2, uu___, uu___1) -> aux t2 + | Quant uu___ -> FStar_Pervasives_Native.Some t1 + | LblPos uu___ -> FStar_Pervasives_Native.Some t1 + and aux_l ts = + match ts with + | [] -> FStar_Pervasives_Native.None + | t1::ts1 -> + let uu___ = aux t1 in + (match uu___ with + | FStar_Pervasives_Native.Some t2 -> + FStar_Pervasives_Native.Some t2 + | FStar_Pervasives_Native.None -> aux_l ts1) in + aux t +let rec (print_smt_term : term -> Prims.string) = + fun t -> + match t.tm with + | Integer n -> FStarC_Compiler_Util.format1 "(Integer %s)" n + | String s -> FStarC_Compiler_Util.format1 "(String %s)" s + | Real r -> FStarC_Compiler_Util.format1 "(Real %s)" r + | BoundV n -> + let uu___ = FStarC_Compiler_Util.string_of_int n in + FStarC_Compiler_Util.format1 "(BoundV %s)" uu___ + | FreeV fv1 -> + let uu___ = fv_name fv1 in + FStarC_Compiler_Util.format1 "(FreeV %s)" uu___ + | App (op1, l) -> + let uu___ = op_to_string op1 in + let uu___1 = print_smt_term_list l in + FStarC_Compiler_Util.format2 "(%s %s)" uu___ uu___1 + | Labeled (t1, r1, r2) -> + let uu___ = FStarC_Errors_Msg.rendermsg r1 in + let uu___1 = print_smt_term t1 in + FStarC_Compiler_Util.format2 "(Labeled '%s' %s)" uu___ uu___1 + | LblPos (t1, s) -> + let uu___ = print_smt_term t1 in + FStarC_Compiler_Util.format2 "(LblPos %s %s)" s uu___ + | Quant (qop1, l, uu___, uu___1, t1) -> + let uu___2 = print_smt_term_list_list l in + let uu___3 = print_smt_term t1 in + FStarC_Compiler_Util.format3 "(%s %s %s)" (qop_to_string qop1) uu___2 + uu___3 + | Let (es, body) -> + let uu___ = print_smt_term_list es in + let uu___1 = print_smt_term body in + FStarC_Compiler_Util.format2 "(let %s %s)" uu___ uu___1 +and (print_smt_term_list : term Prims.list -> Prims.string) = + fun l -> + let uu___ = FStarC_Compiler_List.map print_smt_term l in + FStarC_Compiler_String.concat " " uu___ +and (print_smt_term_list_list : term Prims.list Prims.list -> Prims.string) = + fun l -> + FStarC_Compiler_List.fold_left + (fun s -> + fun l1 -> + let uu___ = + let uu___1 = + let uu___2 = print_smt_term_list l1 in + Prims.strcat uu___2 " ] " in + Prims.strcat "; [ " uu___1 in + Prims.strcat s uu___) "" l +let (mkQuant : + FStarC_Compiler_Range_Type.range -> + Prims.bool -> + (qop * term Prims.list Prims.list * Prims.int + FStar_Pervasives_Native.option * sort Prims.list * term) -> term) + = + fun r -> + fun check_pats -> + fun uu___ -> + match uu___ with + | (qop1, pats, wopt, vars, body) -> + let all_pats_ok pats1 = + if Prims.op_Negation check_pats + then pats1 + else + (let uu___2 = + FStarC_Compiler_Util.find_map pats1 + (fun x -> + FStarC_Compiler_Util.find_map x check_pattern_ok) in + match uu___2 with + | FStar_Pervasives_Native.None -> pats1 + | FStar_Pervasives_Native.Some p -> + ((let uu___4 = + let uu___5 = print_smt_term p in + FStarC_Compiler_Util.format1 + "Pattern (%s) contains illegal symbols; dropping it" + uu___5 in + FStarC_Errors.log_issue + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Warning_SMTPatternIllFormed () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4)); + [])) in + if (FStarC_Compiler_List.length vars) = Prims.int_zero + then body + else + (match body.tm with + | App (TrueOp, uu___2) -> body + | uu___2 -> + let uu___3 = + let uu___4 = + let uu___5 = all_pats_ok pats in + (qop1, uu___5, wopt, vars, body) in + Quant uu___4 in + mk uu___3 r) +let (mkLet : + (term Prims.list * term) -> FStarC_Compiler_Range_Type.range -> term) = + fun uu___ -> + fun r -> + match uu___ with + | (es, body) -> + if (FStarC_Compiler_List.length es) = Prims.int_zero + then body + else mk (Let (es, body)) r +let (abstr : fv Prims.list -> term -> term) = + fun fvs1 -> + fun t -> + let nvars = FStarC_Compiler_List.length fvs1 in + let index_of fv1 = + let uu___ = FStarC_Compiler_Util.try_find_index (fv_eq fv1) fvs1 in + match uu___ with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some i -> + FStar_Pervasives_Native.Some (nvars - (i + Prims.int_one)) in + let rec aux ix t1 = + let uu___ = FStarC_Compiler_Effect.op_Bang t1.freevars in + match uu___ with + | FStar_Pervasives_Native.Some [] -> t1 + | uu___1 -> + (match t1.tm with + | Integer uu___2 -> t1 + | String uu___2 -> t1 + | Real uu___2 -> t1 + | BoundV uu___2 -> t1 + | FreeV x -> + let uu___2 = index_of x in + (match uu___2 with + | FStar_Pervasives_Native.None -> t1 + | FStar_Pervasives_Native.Some i -> + mkBoundV (i + ix) t1.rng) + | App (op1, tms) -> + let uu___2 = + let uu___3 = FStarC_Compiler_List.map (aux ix) tms in + (op1, uu___3) in + mkApp' uu___2 t1.rng + | Labeled (t2, r1, r2) -> + let uu___2 = + let uu___3 = let uu___4 = aux ix t2 in (uu___4, r1, r2) in + Labeled uu___3 in + mk uu___2 t2.rng + | LblPos (t2, r) -> + let uu___2 = + let uu___3 = let uu___4 = aux ix t2 in (uu___4, r) in + LblPos uu___3 in + mk uu___2 t2.rng + | Quant (qop1, pats, wopt, vars, body) -> + let n = FStarC_Compiler_List.length vars in + let uu___2 = + let uu___3 = + FStarC_Compiler_List.map + (FStarC_Compiler_List.map (aux (ix + n))) pats in + let uu___4 = aux (ix + n) body in + (qop1, uu___3, wopt, vars, uu___4) in + mkQuant t1.rng false uu___2 + | Let (es, body) -> + let uu___2 = + FStarC_Compiler_List.fold_left + (fun uu___3 -> + fun e -> + match uu___3 with + | (ix1, l) -> + let uu___4 = + let uu___5 = aux ix1 e in uu___5 :: l in + ((ix1 + Prims.int_one), uu___4)) (ix, []) es in + (match uu___2 with + | (ix1, es_rev) -> + let uu___3 = + let uu___4 = aux ix1 body in + ((FStarC_Compiler_List.rev es_rev), uu___4) in + mkLet uu___3 t1.rng)) in + aux Prims.int_zero t +let (inst : term Prims.list -> term -> term) = + fun tms -> + fun t -> + let tms1 = FStarC_Compiler_List.rev tms in + let n = FStarC_Compiler_List.length tms1 in + let rec aux shift t1 = + match t1.tm with + | Integer uu___ -> t1 + | String uu___ -> t1 + | Real uu___ -> t1 + | FreeV uu___ -> t1 + | BoundV i -> + if (Prims.int_zero <= (i - shift)) && ((i - shift) < n) + then FStarC_Compiler_List.nth tms1 (i - shift) + else t1 + | App (op1, tms2) -> + let uu___ = + let uu___1 = FStarC_Compiler_List.map (aux shift) tms2 in + (op1, uu___1) in + mkApp' uu___ t1.rng + | Labeled (t2, r1, r2) -> + let uu___ = + let uu___1 = let uu___2 = aux shift t2 in (uu___2, r1, r2) in + Labeled uu___1 in + mk uu___ t2.rng + | LblPos (t2, r) -> + let uu___ = + let uu___1 = let uu___2 = aux shift t2 in (uu___2, r) in + LblPos uu___1 in + mk uu___ t2.rng + | Quant (qop1, pats, wopt, vars, body) -> + let m = FStarC_Compiler_List.length vars in + let shift1 = shift + m in + let uu___ = + let uu___1 = + FStarC_Compiler_List.map + (FStarC_Compiler_List.map (aux shift1)) pats in + let uu___2 = aux shift1 body in + (qop1, uu___1, wopt, vars, uu___2) in + mkQuant t1.rng false uu___ + | Let (es, body) -> + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun e -> + match uu___1 with + | (ix, es1) -> + let uu___2 = + let uu___3 = aux shift e in uu___3 :: es1 in + ((shift + Prims.int_one), uu___2)) (shift, []) es in + (match uu___ with + | (shift1, es_rev) -> + let uu___1 = + let uu___2 = aux shift1 body in + ((FStarC_Compiler_List.rev es_rev), uu___2) in + mkLet uu___1 t1.rng) in + aux Prims.int_zero t +let (subst : term -> fv -> term -> term) = + fun t -> fun fv1 -> fun s -> let uu___ = abstr [fv1] t in inst [s] uu___ +let (mkQuant' : + FStarC_Compiler_Range_Type.range -> + (qop * term Prims.list Prims.list * Prims.int + FStar_Pervasives_Native.option * fv Prims.list * term) -> term) + = + fun r -> + fun uu___ -> + match uu___ with + | (qop1, pats, wopt, vars, body) -> + let uu___1 = + let uu___2 = + FStarC_Compiler_List.map + (FStarC_Compiler_List.map (abstr vars)) pats in + let uu___3 = FStarC_Compiler_List.map fv_sort vars in + let uu___4 = abstr vars body in + (qop1, uu___2, wopt, uu___3, uu___4) in + mkQuant r true uu___1 +let (mkForall : + FStarC_Compiler_Range_Type.range -> + (pat Prims.list Prims.list * fvs * term) -> term) + = + fun r -> + fun uu___ -> + match uu___ with + | (pats, vars, body) -> + mkQuant' r (Forall, pats, FStar_Pervasives_Native.None, vars, body) +let (mkForall'' : + FStarC_Compiler_Range_Type.range -> + (pat Prims.list Prims.list * Prims.int FStar_Pervasives_Native.option * + sort Prims.list * term) -> term) + = + fun r -> + fun uu___ -> + match uu___ with + | (pats, wopt, sorts, body) -> + mkQuant r true (Forall, pats, wopt, sorts, body) +let (mkForall' : + FStarC_Compiler_Range_Type.range -> + (pat Prims.list Prims.list * Prims.int FStar_Pervasives_Native.option * + fvs * term) -> term) + = + fun r -> + fun uu___ -> + match uu___ with + | (pats, wopt, vars, body) -> + mkQuant' r (Forall, pats, wopt, vars, body) +let (mkExists : + FStarC_Compiler_Range_Type.range -> + (pat Prims.list Prims.list * fvs * term) -> term) + = + fun r -> + fun uu___ -> + match uu___ with + | (pats, vars, body) -> + mkQuant' r (Exists, pats, FStar_Pervasives_Native.None, vars, body) +let (mkLet' : + ((fv * term) Prims.list * term) -> FStarC_Compiler_Range_Type.range -> term) + = + fun uu___ -> + fun r -> + match uu___ with + | (bindings, body) -> + let uu___1 = FStarC_Compiler_List.split bindings in + (match uu___1 with + | (vars, es) -> + let uu___2 = let uu___3 = abstr vars body in (es, uu___3) in + mkLet uu___2 r) +let (norng : FStarC_Compiler_Range_Type.range) = + FStarC_Compiler_Range_Type.dummyRange +let (mkDefineFun : + (Prims.string * fv Prims.list * sort * term * caption) -> decl) = + fun uu___ -> + match uu___ with + | (nm, vars, s, tm, c) -> + let uu___1 = + let uu___2 = FStarC_Compiler_List.map fv_sort vars in + let uu___3 = abstr vars tm in (nm, uu___2, s, uu___3, c) in + DefineFun uu___1 +let (constr_id_of_sort : sort -> Prims.string) = + fun sort1 -> + let uu___ = strSort sort1 in + FStarC_Compiler_Util.format1 "%s_constr_id" uu___ +let (fresh_token : (Prims.string * sort) -> Prims.int -> decl) = + fun uu___ -> + fun id -> + match uu___ with + | (tok_name, sort1) -> + let a_name = Prims.strcat "fresh_token_" tok_name in + let tm = + let uu___1 = + let uu___2 = mkInteger' id norng in + let uu___3 = + let uu___4 = + let uu___5 = constr_id_of_sort sort1 in + let uu___6 = + let uu___7 = mkApp (tok_name, []) norng in [uu___7] in + (uu___5, uu___6) in + mkApp uu___4 norng in + (uu___2, uu___3) in + mkEq uu___1 norng in + let a = + let uu___1 = escape a_name in + let uu___2 = free_top_level_names tm in + { + assumption_term = tm; + assumption_caption = + (FStar_Pervasives_Native.Some "fresh token"); + assumption_name = uu___1; + assumption_fact_ids = []; + assumption_free_names = uu___2 + } in + Assume a +let (fresh_constructor : + FStarC_Compiler_Range_Type.range -> + (Prims.string * sort Prims.list * sort * Prims.int) -> decl) + = + fun rng -> + fun uu___ -> + match uu___ with + | (name, arg_sorts, sort1, id) -> + let id1 = FStarC_Compiler_Util.string_of_int id in + let bvars = + FStarC_Compiler_List.mapi + (fun i -> + fun s -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Compiler_Util.string_of_int i in + Prims.strcat "x_" uu___4 in + (uu___3, s) in + mk_fv uu___2 in + mkFreeV uu___1 norng) arg_sorts in + let bvar_names = FStarC_Compiler_List.map fv_of_term bvars in + let capp = mkApp (name, bvars) norng in + let cid_app = + let uu___1 = + let uu___2 = constr_id_of_sort sort1 in (uu___2, [capp]) in + mkApp uu___1 norng in + let a_name = Prims.strcat "constructor_distinct_" name in + let tm = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = mkInteger id1 norng in (uu___4, cid_app) in + mkEq uu___3 norng in + ([[capp]], bvar_names, uu___2) in + mkForall rng uu___1 in + let a = + let uu___1 = escape a_name in + let uu___2 = free_top_level_names tm in + { + assumption_term = tm; + assumption_caption = + (FStar_Pervasives_Native.Some "Constructor distinct"); + assumption_name = uu___1; + assumption_fact_ids = []; + assumption_free_names = uu___2 + } in + Assume a +let (injective_constructor : + FStarC_Compiler_Range_Type.range -> + (Prims.string * constructor_field Prims.list * sort) -> decl Prims.list) + = + fun rng -> + fun uu___ -> + match uu___ with + | (name, fields, sort1) -> + let n_bvars = FStarC_Compiler_List.length fields in + let bvar_name i = + let uu___1 = FStarC_Compiler_Util.string_of_int i in + Prims.strcat "x_" uu___1 in + let bvar_index i = n_bvars - (i + Prims.int_one) in + let bvar i s = + let uu___1 = + let uu___2 = let uu___3 = bvar_name i in (uu___3, s) in + mk_fv uu___2 in + mkFreeV uu___1 in + let bvars = + FStarC_Compiler_List.mapi + (fun i -> + fun f -> let uu___1 = bvar i f.field_sort in uu___1 norng) + fields in + let bvar_names = FStarC_Compiler_List.map fv_of_term bvars in + let capp = mkApp (name, bvars) norng in + let uu___1 = + FStarC_Compiler_List.mapi + (fun i -> + fun uu___2 -> + match uu___2 with + | { field_name = name1; field_sort = s; + field_projectible = projectible;_} -> + if projectible + then + let cproj_app = mkApp (name1, [capp]) norng in + let proj_name = + DeclFun + (name1, [sort1], s, + (FStar_Pervasives_Native.Some "Projector")) in + let tm = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = bvar i s in uu___7 norng in + (cproj_app, uu___6) in + mkEq uu___5 norng in + ([[capp]], bvar_names, uu___4) in + mkForall rng uu___3 in + let a = + let uu___3 = + escape + (Prims.strcat "projection_inverse_" name1) in + let uu___4 = free_top_level_names tm in + { + assumption_term = tm; + assumption_caption = + (FStar_Pervasives_Native.Some + "Projection inverse"); + assumption_name = uu___3; + assumption_fact_ids = []; + assumption_free_names = uu___4 + } in + [proj_name; Assume a] + else []) fields in + FStarC_Compiler_List.flatten uu___1 +let (discriminator_name : constructor_t -> Prims.string) = + fun constr -> Prims.strcat "is-" constr.constr_name +let (constructor_to_decl : + FStarC_Compiler_Range_Type.range -> constructor_t -> decl Prims.list) = + fun rng -> + fun constr -> + let sort1 = constr.constr_sort in + let field_sorts = + FStarC_Compiler_List.map (fun f -> f.field_sort) constr.constr_fields in + let cdecl = + DeclFun + ((constr.constr_name), field_sorts, (constr.constr_sort), + (FStar_Pervasives_Native.Some "Constructor")) in + let cid = + match constr.constr_id with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some id -> + let uu___ = + fresh_constructor rng + ((constr.constr_name), field_sorts, sort1, id) in + [uu___] in + let disc = + let disc_name = discriminator_name constr in + let xfv = mk_fv ("x", sort1) in + let xx = mkFreeV xfv norng in + let uu___ = + let uu___1 = + FStarC_Compiler_List.mapi + (fun i -> + fun uu___2 -> + match uu___2 with + | { field_name = proj; field_sort = s; + field_projectible = projectible;_} -> + if projectible + then + let uu___3 = mkApp (proj, [xx]) norng in + (uu___3, []) + else + (let fi = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Compiler_Util.string_of_int i in + Prims.strcat "f_" uu___6 in + (uu___5, s) in + mk_fv uu___4 in + let uu___4 = mkFreeV fi norng in (uu___4, [fi]))) + constr.constr_fields in + FStarC_Compiler_List.split uu___1 in + match uu___ with + | (proj_terms, ex_vars) -> + let ex_vars1 = FStarC_Compiler_List.flatten ex_vars in + let disc_inv_body = + let uu___1 = + let uu___2 = mkApp ((constr.constr_name), proj_terms) norng in + (xx, uu___2) in + mkEq uu___1 norng in + let disc_inv_body1 = + match ex_vars1 with + | [] -> disc_inv_body + | uu___1 -> mkExists norng ([], ex_vars1, disc_inv_body) in + let disc_ax = + match constr.constr_id with + | FStar_Pervasives_Native.None -> disc_inv_body1 + | FStar_Pervasives_Native.Some id -> + let disc_eq = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = constr_id_of_sort constr.constr_sort in + (uu___4, [xx]) in + mkApp uu___3 norng in + let uu___3 = + let uu___4 = FStarC_Compiler_Util.string_of_int id in + mkInteger uu___4 norng in + (uu___2, uu___3) in + mkEq uu___1 norng in + mkAnd (disc_eq, disc_inv_body1) norng in + let def = + mkDefineFun + (disc_name, [xfv], Bool_sort, disc_ax, + (FStar_Pervasives_Native.Some "Discriminator definition")) in + def in + let projs = + injective_constructor rng + ((constr.constr_name), (constr.constr_fields), sort1) in + let base = + if Prims.op_Negation constr.constr_base + then [] + else + (let arg_sorts = + let uu___1 = + FStarC_Compiler_List.filter (fun f -> f.field_projectible) + constr.constr_fields in + FStarC_Compiler_List.map (fun uu___2 -> Term_sort) uu___1 in + let base_name = Prims.strcat constr.constr_name "@base" in + let decl1 = + DeclFun + (base_name, arg_sorts, Term_sort, + (FStar_Pervasives_Native.Some "Constructor base")) in + let formals = + FStarC_Compiler_List.mapi + (fun i -> + fun uu___1 -> + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Compiler_Util.string_of_int i in + Prims.strcat "x" uu___4 in + (uu___3, Term_sort) in + mk_fv uu___2) constr.constr_fields in + let constructed_term = + let uu___1 = + let uu___2 = + FStarC_Compiler_List.map (fun fv1 -> mkFreeV fv1 norng) + formals in + ((constr.constr_name), uu___2) in + mkApp uu___1 norng in + let inj_formals = + let uu___1 = + FStarC_Compiler_List.map2 + (fun f -> + fun fld -> if fld.field_projectible then [f] else []) + formals constr.constr_fields in + FStarC_Compiler_List.flatten uu___1 in + let base_term = + let uu___1 = + let uu___2 = + FStarC_Compiler_List.map (fun fv1 -> mkFreeV fv1 norng) + inj_formals in + (base_name, uu___2) in + mkApp uu___1 norng in + let eq = mkEq (constructed_term, base_term) norng in + let guard = + mkApp ((discriminator_name constr), [constructed_term]) norng in + let q = + let uu___1 = + let uu___2 = mkImp (guard, eq) norng in + ([[constructed_term]], formals, uu___2) in + mkForall rng uu___1 in + let a = + let uu___1 = + escape (Prims.strcat "constructor_base_" constr.constr_name) in + let uu___2 = free_top_level_names q in + { + assumption_term = q; + assumption_caption = + (FStar_Pervasives_Native.Some "Constructor base"); + assumption_name = uu___1; + assumption_fact_ids = []; + assumption_free_names = uu___2 + } in + [decl1; Assume a]) in + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Compiler_Util.format1 "" + constr.constr_name in + Caption uu___2 in + [uu___1; cdecl] in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Compiler_Util.format1 "" + constr.constr_name in + Caption uu___7 in + [uu___6] in + FStarC_Compiler_List.op_At base uu___5 in + FStarC_Compiler_List.op_At [disc] uu___4 in + FStarC_Compiler_List.op_At projs uu___3 in + FStarC_Compiler_List.op_At cid uu___2 in + FStarC_Compiler_List.op_At uu___ uu___1 +let (name_binders_inner : + Prims.string FStar_Pervasives_Native.option -> + fv Prims.list -> + Prims.int -> + sort Prims.list -> + (fv Prims.list * Prims.string Prims.list * Prims.int)) + = + fun prefix_opt -> + fun outer_names -> + fun start -> + fun sorts -> + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun s -> + match uu___1 with + | (names, binders1, n) -> + let prefix = + match s with | Term_sort -> "@x" | uu___2 -> "@u" in + let prefix1 = + match prefix_opt with + | FStar_Pervasives_Native.None -> prefix + | FStar_Pervasives_Native.Some p -> + Prims.strcat p prefix in + let nm = + let uu___2 = FStarC_Compiler_Util.string_of_int n in + Prims.strcat prefix1 uu___2 in + let names1 = + let uu___2 = mk_fv (nm, s) in uu___2 :: names in + let b = + let uu___2 = strSort s in + FStarC_Compiler_Util.format2 "(%s %s)" nm uu___2 in + (names1, (b :: binders1), (n + Prims.int_one))) + (outer_names, [], start) sorts in + match uu___ with + | (names, binders1, n) -> + (names, (FStarC_Compiler_List.rev binders1), n) +let (name_macro_binders : + sort Prims.list -> (fv Prims.list * Prims.string Prims.list)) = + fun sorts -> + let uu___ = + name_binders_inner (FStar_Pervasives_Native.Some "__") [] + Prims.int_zero sorts in + match uu___ with + | (names, binders1, n) -> ((FStarC_Compiler_List.rev names), binders1) +let (termToSmt : Prims.bool -> Prims.string -> term -> Prims.string) = + let string_id_counter = FStarC_Compiler_Util.mk_ref Prims.int_zero in + let string_cache = FStarC_Compiler_Util.smap_create (Prims.of_int (20)) in + fun print_ranges -> + fun enclosing_name -> + fun t -> + let next_qid = + let ctr = FStarC_Compiler_Util.mk_ref Prims.int_zero in + fun depth -> + let n = FStarC_Compiler_Effect.op_Bang ctr in + FStarC_Compiler_Util.incr ctr; + if n = Prims.int_zero + then enclosing_name + else + (let uu___2 = FStarC_Compiler_Util.string_of_int n in + FStarC_Compiler_Util.format2 "%s.%s" enclosing_name uu___2) in + let remove_guard_free pats = + FStarC_Compiler_List.map + (fun ps -> + FStarC_Compiler_List.map + (fun tm -> + match tm.tm with + | App + (Var "Prims.guard_free", + { tm = BoundV uu___; freevars = uu___1; + rng = uu___2;_}::[]) + -> tm + | App (Var "Prims.guard_free", p::[]) -> p + | uu___ -> tm) ps) pats in + let rec aux' depth n names t1 = + let aux1 = aux (depth + Prims.int_one) in + match t1.tm with + | Integer i -> i + | Real r -> r + | String s -> + let id_opt = FStarC_Compiler_Util.smap_try_find string_cache s in + (match id_opt with + | FStar_Pervasives_Native.Some id -> id + | FStar_Pervasives_Native.None -> + let id = + let uu___ = + FStarC_Compiler_Effect.op_Bang string_id_counter in + FStarC_Compiler_Util.string_of_int uu___ in + (FStarC_Compiler_Util.incr string_id_counter; + FStarC_Compiler_Util.smap_add string_cache s id; + id)) + | BoundV i -> + let uu___ = FStarC_Compiler_List.nth names i in fv_name uu___ + | FreeV x when fv_force x -> + let uu___ = + let uu___1 = fv_name x in Prims.strcat uu___1 " Dummy_value)" in + Prims.strcat "(" uu___ + | FreeV x -> fv_name x + | App (op1, []) -> op_to_string op1 + | App (op1, tms) -> + let uu___ = op_to_string op1 in + let uu___1 = + let uu___2 = FStarC_Compiler_List.map (aux1 n names) tms in + FStarC_Compiler_String.concat "\n" uu___2 in + FStarC_Compiler_Util.format2 "(%s %s)" uu___ uu___1 + | Labeled (t2, uu___, uu___1) -> aux1 n names t2 + | LblPos (t2, s) -> + let uu___ = aux1 n names t2 in + FStarC_Compiler_Util.format2 "(! %s :lblpos %s)" uu___ s + | Quant (qop1, pats, wopt, sorts, body) -> + let qid = next_qid () in + let uu___ = + name_binders_inner FStar_Pervasives_Native.None names n sorts in + (match uu___ with + | (names1, binders1, n1) -> + let binders2 = FStarC_Compiler_String.concat " " binders1 in + let pats1 = remove_guard_free pats in + let pats_str = + match pats1 with + | []::[] -> if print_ranges then ";;no pats" else "" + | [] -> if print_ranges then ";;no pats" else "" + | uu___1 -> + let uu___2 = + FStarC_Compiler_List.map + (fun pats2 -> + let uu___3 = + let uu___4 = + FStarC_Compiler_List.map + (fun p -> + let uu___5 = aux1 n1 names1 p in + FStarC_Compiler_Util.format1 "%s" + uu___5) pats2 in + FStarC_Compiler_String.concat " " uu___4 in + FStarC_Compiler_Util.format1 + "\n:pattern (%s)" uu___3) pats1 in + FStarC_Compiler_String.concat "\n" uu___2 in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = aux1 n1 names1 body in + let uu___5 = + let uu___6 = weightToSmt wopt in + [uu___6; pats_str; qid] in + uu___4 :: uu___5 in + binders2 :: uu___3 in + (qop_to_string qop1) :: uu___2 in + FStarC_Compiler_Util.format + "(%s (%s)\n (! %s\n %s\n%s\n:qid %s))" uu___1) + | Let (es, body) -> + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun e -> + match uu___1 with + | (names0, binders1, n0) -> + let nm = + let uu___2 = + FStarC_Compiler_Util.string_of_int n0 in + Prims.strcat "@lb" uu___2 in + let names01 = + let uu___2 = mk_fv (nm, Term_sort) in uu___2 :: + names0 in + let b = + let uu___2 = aux1 n names e in + FStarC_Compiler_Util.format2 "(%s %s)" nm uu___2 in + (names01, (b :: binders1), (n0 + Prims.int_one))) + (names, [], n) es in + (match uu___ with + | (names1, binders1, n1) -> + let uu___1 = aux1 n1 names1 body in + FStarC_Compiler_Util.format2 "(let (%s)\n%s)" + (FStarC_Compiler_String.concat " " binders1) uu___1) + and aux depth n names t1 = + let s = aux' depth n names t1 in + if print_ranges && (t1.rng <> norng) + then + let uu___ = FStarC_Compiler_Range_Ops.string_of_range t1.rng in + let uu___1 = FStarC_Compiler_Range_Ops.string_of_use_range t1.rng in + FStarC_Compiler_Util.format3 "\n;; def=%s; use=%s\n%s\n" uu___ + uu___1 s + else s in + aux Prims.int_zero Prims.int_zero [] t +let (caption_to_string : + Prims.bool -> Prims.string FStar_Pervasives_Native.option -> Prims.string) + = + fun print_captions -> + fun uu___ -> + match uu___ with + | FStar_Pervasives_Native.Some c when print_captions -> + let c1 = + let uu___1 = + FStarC_Compiler_List.map FStarC_Compiler_Util.trim_string + (FStarC_Compiler_String.split [10] c) in + FStarC_Compiler_String.concat " " uu___1 in + Prims.strcat ";;;;;;;;;;;;;;;;" (Prims.strcat c1 "\n") + | uu___1 -> "" +let rec (declToSmt' : Prims.bool -> Prims.string -> decl -> Prims.string) = + fun print_captions -> + fun z3options -> + fun decl1 -> + match decl1 with + | DefPrelude -> mkPrelude z3options + | Module (s, decls) -> + let res = + let uu___ = + FStarC_Compiler_List.map + (declToSmt' print_captions z3options) decls in + FStarC_Compiler_String.concat "\n" uu___ in + let uu___ = FStarC_Options.keep_query_captions () in + if uu___ + then + let uu___1 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length decls) in + let uu___2 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_String.length res) in + FStarC_Compiler_Util.format5 + "\n;;; Start %s\n%s\n;;; End %s (%s decls; total size %s)" s + res s uu___1 uu___2 + else res + | Caption c -> + if print_captions + then + let uu___ = + let uu___1 = + FStarC_Compiler_List.map + (fun s -> Prims.strcat "; " (Prims.strcat s "\n")) + (FStarC_Compiler_Util.splitlines c) in + FStarC_Compiler_String.concat "" uu___1 in + Prims.strcat "\n" uu___ + else "" + | DeclFun (f, argsorts, retsort, c) -> + let l = FStarC_Compiler_List.map strSort argsorts in + let uu___ = caption_to_string print_captions c in + let uu___1 = strSort retsort in + FStarC_Compiler_Util.format4 "%s(declare-fun %s (%s) %s)" uu___ f + (FStarC_Compiler_String.concat " " l) uu___1 + | DefineFun (f, arg_sorts, retsort, body, c) -> + let uu___ = name_macro_binders arg_sorts in + (match uu___ with + | (names, binders1) -> + let body1 = + let uu___1 = + FStarC_Compiler_List.map (fun x -> mkFreeV x norng) + names in + inst uu___1 body in + let uu___1 = caption_to_string print_captions c in + let uu___2 = strSort retsort in + let uu___3 = + let uu___4 = escape f in + termToSmt print_captions uu___4 body1 in + FStarC_Compiler_Util.format5 + "%s(define-fun %s (%s) %s\n %s)" uu___1 f + (FStarC_Compiler_String.concat " " binders1) uu___2 uu___3) + | Assume a -> + let fact_ids_to_string ids = + FStarC_Compiler_List.map + (fun uu___ -> + match uu___ with + | Name n -> + let uu___1 = FStarC_Ident.string_of_lid n in + Prims.strcat "Name " uu___1 + | Namespace ns -> + let uu___1 = FStarC_Ident.string_of_lid ns in + Prims.strcat "Namespace " uu___1 + | Tag t -> Prims.strcat "Tag " t) ids in + let fids = + if print_captions + then + let uu___ = + let uu___1 = fact_ids_to_string a.assumption_fact_ids in + FStarC_Compiler_String.concat "; " uu___1 in + FStarC_Compiler_Util.format1 ";;; Fact-ids: %s\n" uu___ + else "" in + let n = a.assumption_name in + let uu___ = caption_to_string print_captions a.assumption_caption in + let uu___1 = termToSmt print_captions n a.assumption_term in + FStarC_Compiler_Util.format4 "%s%s(assert (! %s\n:named %s))" + uu___ fids uu___1 n + | Eval t -> + let uu___ = termToSmt print_captions "eval" t in + FStarC_Compiler_Util.format1 "(eval %s)" uu___ + | Echo s -> FStarC_Compiler_Util.format1 "(echo \"%s\")" s + | RetainAssumptions uu___ -> "" + | CheckSat -> + "(echo \"\")\n(check-sat)\n(echo \"\")" + | GetUnsatCore -> + "(echo \"\")\n(get-unsat-core)\n(echo \"\")" + | Push n -> + let uu___ = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) n in + FStarC_Compiler_Util.format1 "(push) ;; push{%s" uu___ + | Pop n -> + let uu___ = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) n in + FStarC_Compiler_Util.format1 "(pop) ;; %s}pop" uu___ + | SetOption (s, v) -> + FStarC_Compiler_Util.format2 "(set-option :%s %s)" s v + | GetStatistics -> + "(echo \"\")\n(get-info :all-statistics)\n(echo \"\")" + | GetReasonUnknown -> + "(echo \"\")\n(get-info :reason-unknown)\n(echo \"\")" +and (declToSmt : Prims.string -> decl -> Prims.string) = + fun z3options -> + fun decl1 -> + let uu___ = FStarC_Options.keep_query_captions () in + declToSmt' uu___ z3options decl1 +and (mkPrelude : Prims.string -> Prims.string) = + fun z3options -> + let basic = + Prims.strcat z3options + "(declare-sort FString)\n(declare-fun FString_constr_id (FString) Int)\n\n(declare-sort Term)\n(declare-fun Term_constr_id (Term) Int)\n(declare-sort Dummy_sort)\n(declare-fun Dummy_value () Dummy_sort)\n(declare-datatypes () ((Fuel \n(ZFuel) \n(SFuel (prec Fuel)))))\n(declare-fun MaxIFuel () Fuel)\n(declare-fun MaxFuel () Fuel)\n(declare-fun PreType (Term) Term)\n(declare-fun Valid (Term) Bool)\n(declare-fun HasTypeFuel (Fuel Term Term) Bool)\n(define-fun HasTypeZ ((x Term) (t Term)) Bool\n(HasTypeFuel ZFuel x t))\n(define-fun HasType ((x Term) (t Term)) Bool\n(HasTypeFuel MaxIFuel x t))\n(declare-fun IsTotFun (Term) Bool)\n\n ;;fuel irrelevance\n(assert (forall ((f Fuel) (x Term) (t Term))\n(! (= (HasTypeFuel (SFuel f) x t)\n(HasTypeZ x t))\n:pattern ((HasTypeFuel (SFuel f) x t)))))\n(declare-fun NoHoist (Term Bool) Bool)\n;;no-hoist\n(assert (forall ((dummy Term) (b Bool))\n(! (= (NoHoist dummy b)\nb)\n:pattern ((NoHoist dummy b)))))\n(define-fun IsTyped ((x Term)) Bool\n(exists ((t Term)) (HasTypeZ x t)))\n(declare-fun ApplyTF (Term Fuel) Term)\n(declare-fun ApplyTT (Term Term) Term)\n(declare-fun Prec (Term Term) Bool)\n(assert (forall ((x Term) (y Term) (z Term))\n(! (implies (and (Prec x y) (Prec y z))\n(Prec x z))\n :pattern ((Prec x z) (Prec x y)))))\n(assert (forall ((x Term) (y Term))\n(implies (Prec x y)\n(not (Prec y x)))))\n(declare-fun Closure (Term) Term)\n(declare-fun ConsTerm (Term Term) Term)\n(declare-fun ConsFuel (Fuel Term) Term)\n(declare-fun Tm_uvar (Int) Term)\n(define-fun Reify ((x Term)) Term x)\n(declare-fun Prims.precedes (Term Term Term Term) Term)\n(declare-fun Range_const (Int) Term)\n(declare-fun _mul (Int Int) Int)\n(declare-fun _div (Int Int) Int)\n(declare-fun _mod (Int Int) Int)\n(declare-fun __uu__PartialApp () Term)\n(assert (forall ((x Int) (y Int)) (! (= (_mul x y) (* x y)) :pattern ((_mul x y)))))\n(assert (forall ((x Int) (y Int)) (! (= (_div x y) (div x y)) :pattern ((_div x y)))))\n(assert (forall ((x Int) (y Int)) (! (= (_mod x y) (mod x y)) :pattern ((_mod x y)))))\n(declare-fun _rmul (Real Real) Real)\n(declare-fun _rdiv (Real Real) Real)\n(assert (forall ((x Real) (y Real)) (! (= (_rmul x y) (* x y)) :pattern ((_rmul x y)))))\n(assert (forall ((x Real) (y Real)) (! (= (_rdiv x y) (/ x y)) :pattern ((_rdiv x y)))))\n(define-fun Unreachable () Bool false)" in + let as_constr uu___ = + match uu___ with + | (name, fields, sort1, id, _injective) -> + let uu___1 = + FStarC_Compiler_List.map + (fun uu___2 -> + match uu___2 with + | (field_name, field_sort, field_projectible) -> + { field_name; field_sort; field_projectible }) fields in + { + constr_name = name; + constr_fields = uu___1; + constr_sort = sort1; + constr_id = (FStar_Pervasives_Native.Some id); + constr_base = false + } in + let constrs = + FStarC_Compiler_List.map as_constr + [("FString_const", [("FString_const_proj_0", Int_sort, true)], + String_sort, Prims.int_zero, true); + ("Tm_type", [], Term_sort, (Prims.of_int (2)), true); + ("Tm_arrow", [("Tm_arrow_id", Int_sort, true)], Term_sort, + (Prims.of_int (3)), false); + ("Tm_unit", [], Term_sort, (Prims.of_int (6)), true); + ((FStar_Pervasives_Native.fst boxIntFun), + [((FStar_Pervasives_Native.snd boxIntFun), Int_sort, true)], + Term_sort, (Prims.of_int (7)), true); + ((FStar_Pervasives_Native.fst boxBoolFun), + [((FStar_Pervasives_Native.snd boxBoolFun), Bool_sort, true)], + Term_sort, (Prims.of_int (8)), true); + ((FStar_Pervasives_Native.fst boxStringFun), + [((FStar_Pervasives_Native.snd boxStringFun), String_sort, true)], + Term_sort, (Prims.of_int (9)), true); + ((FStar_Pervasives_Native.fst boxRealFun), + [((FStar_Pervasives_Native.snd boxRealFun), (Sort "Real"), true)], + Term_sort, (Prims.of_int (10)), true)] in + let bcons = + let uu___ = + let uu___1 = + FStarC_Compiler_List.collect (constructor_to_decl norng) constrs in + FStarC_Compiler_List.map (declToSmt z3options) uu___1 in + FStarC_Compiler_String.concat "\n" uu___ in + let precedes_partial_app = + "\n(declare-fun Prims.precedes@tok () Term)\n(assert\n(forall ((@x0 Term) (@x1 Term) (@x2 Term) (@x3 Term))\n(! (= (ApplyTT (ApplyTT (ApplyTT (ApplyTT Prims.precedes@tok\n@x0)\n@x1)\n@x2)\n@x3)\n(Prims.precedes @x0 @x1 @x2 @x3))\n\n:pattern ((ApplyTT (ApplyTT (ApplyTT (ApplyTT Prims.precedes@tok\n@x0)\n@x1)\n@x2)\n@x3)))))\n" in + let lex_ordering = + "\n(declare-fun Prims.lex_t () Term)\n(assert (forall ((t1 Term) (t2 Term) (e1 Term) (e2 Term))\n(! (iff (Valid (Prims.precedes t1 t2 e1 e2))\n(Valid (Prims.precedes Prims.lex_t Prims.lex_t e1 e2)))\n:pattern (Prims.precedes t1 t2 e1 e2))))\n(assert (forall ((t1 Term) (t2 Term))\n(! (iff (Valid (Prims.precedes Prims.lex_t Prims.lex_t t1 t2)) \n(Prec t1 t2))\n:pattern ((Prims.precedes Prims.lex_t Prims.lex_t t1 t2)))))\n" in + let valid_intro = + "(assert (forall ((e Term) (t Term))\n(! (implies (HasType e t)\n(Valid t))\n:pattern ((HasType e t)\n(Valid t))\n:qid __prelude_valid_intro)))\n" in + let valid_elim = + "(assert (forall ((t Term))\n(! (implies (Valid t)\n(exists ((e Term)) (HasType e t)))\n:pattern ((Valid t))\n:qid __prelude_valid_elim)))\n" in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Options.smtencoding_valid_intro () in + if uu___5 then valid_intro else "" in + let uu___5 = + let uu___6 = FStarC_Options.smtencoding_valid_elim () in + if uu___6 then valid_elim else "" in + Prims.strcat uu___4 uu___5 in + Prims.strcat lex_ordering uu___3 in + Prims.strcat precedes_partial_app uu___2 in + Prims.strcat bcons uu___1 in + Prims.strcat basic uu___ +let (declsToSmt : Prims.string -> decl Prims.list -> Prims.string) = + fun z3options -> + fun decls -> + let uu___ = FStarC_Compiler_List.map (declToSmt z3options) decls in + FStarC_Compiler_String.concat "\n" uu___ +let (declToSmt_no_caps : Prims.string -> decl -> Prims.string) = + fun z3options -> fun decl1 -> declToSmt' false z3options decl1 +let (mkBvConstructor : + Prims.int -> (decl Prims.list * Prims.string * Prims.string)) = + fun sz -> + let constr = + let uu___ = + let uu___1 = boxBitVecFun sz in FStar_Pervasives_Native.fst uu___1 in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = boxBitVecFun sz in + FStar_Pervasives_Native.snd uu___4 in + { + field_name = uu___3; + field_sort = (BitVec_sort sz); + field_projectible = true + } in + [uu___2] in + { + constr_name = uu___; + constr_fields = uu___1; + constr_sort = Term_sort; + constr_id = FStar_Pervasives_Native.None; + constr_base = false + } in + let uu___ = constructor_to_decl norng constr in + (uu___, (constr.constr_name), (discriminator_name constr)) +let (__range_c : Prims.int FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref Prims.int_zero +let (mk_Range_const : unit -> term) = + fun uu___ -> + let i = FStarC_Compiler_Effect.op_Bang __range_c in + (let uu___2 = + let uu___3 = FStarC_Compiler_Effect.op_Bang __range_c in + uu___3 + Prims.int_one in + FStarC_Compiler_Effect.op_Colon_Equals __range_c uu___2); + (let uu___2 = + let uu___3 = let uu___4 = mkInteger' i norng in [uu___4] in + ("Range_const", uu___3) in + mkApp uu___2 norng) +let (mk_Term_type : term) = mkApp ("Tm_type", []) norng +let (mk_Term_app : term -> term -> FStarC_Compiler_Range_Type.range -> term) + = fun t1 -> fun t2 -> fun r -> mkApp ("Tm_app", [t1; t2]) r +let (mk_Term_uvar : Prims.int -> FStarC_Compiler_Range_Type.range -> term) = + fun i -> + fun r -> + let uu___ = + let uu___1 = let uu___2 = mkInteger' i norng in [uu___2] in + ("Tm_uvar", uu___1) in + mkApp uu___ r +let (mk_Term_unit : term) = mkApp ("Tm_unit", []) norng +let (elim_box : Prims.bool -> Prims.string -> Prims.string -> term -> term) = + fun cond -> + fun u -> + fun v -> + fun t -> + match t.tm with + | App (Var v', t1::[]) when (v = v') && cond -> t1 + | uu___ -> mkApp (u, [t]) t.rng +let (maybe_elim_box : Prims.string -> Prims.string -> term -> term) = + fun u -> + fun v -> + fun t -> + let uu___ = FStarC_Options.smtencoding_elim_box () in + elim_box uu___ u v t +let (boxInt : term -> term) = + fun t -> + maybe_elim_box (FStar_Pervasives_Native.fst boxIntFun) + (FStar_Pervasives_Native.snd boxIntFun) t +let (unboxInt : term -> term) = + fun t -> + maybe_elim_box (FStar_Pervasives_Native.snd boxIntFun) + (FStar_Pervasives_Native.fst boxIntFun) t +let (boxBool : term -> term) = + fun t -> + maybe_elim_box (FStar_Pervasives_Native.fst boxBoolFun) + (FStar_Pervasives_Native.snd boxBoolFun) t +let (unboxBool : term -> term) = + fun t -> + maybe_elim_box (FStar_Pervasives_Native.snd boxBoolFun) + (FStar_Pervasives_Native.fst boxBoolFun) t +let (boxString : term -> term) = + fun t -> + maybe_elim_box (FStar_Pervasives_Native.fst boxStringFun) + (FStar_Pervasives_Native.snd boxStringFun) t +let (unboxString : term -> term) = + fun t -> + maybe_elim_box (FStar_Pervasives_Native.snd boxStringFun) + (FStar_Pervasives_Native.fst boxStringFun) t +let (boxReal : term -> term) = + fun t -> + maybe_elim_box (FStar_Pervasives_Native.fst boxRealFun) + (FStar_Pervasives_Native.snd boxRealFun) t +let (unboxReal : term -> term) = + fun t -> + maybe_elim_box (FStar_Pervasives_Native.snd boxRealFun) + (FStar_Pervasives_Native.fst boxRealFun) t +let (boxBitVec : Prims.int -> term -> term) = + fun sz -> + fun t -> + let uu___ = + let uu___1 = boxBitVecFun sz in FStar_Pervasives_Native.fst uu___1 in + let uu___1 = + let uu___2 = boxBitVecFun sz in FStar_Pervasives_Native.snd uu___2 in + elim_box true uu___ uu___1 t +let (unboxBitVec : Prims.int -> term -> term) = + fun sz -> + fun t -> + let uu___ = + let uu___1 = boxBitVecFun sz in FStar_Pervasives_Native.snd uu___1 in + let uu___1 = + let uu___2 = boxBitVecFun sz in FStar_Pervasives_Native.fst uu___2 in + elim_box true uu___ uu___1 t +let (boxTerm : sort -> term -> term) = + fun sort1 -> + fun t -> + match sort1 with + | Int_sort -> boxInt t + | Bool_sort -> boxBool t + | String_sort -> boxString t + | BitVec_sort sz -> boxBitVec sz t + | Sort "Real" -> boxReal t + | uu___ -> FStarC_Compiler_Effect.raise FStarC_Compiler_Util.Impos +let (unboxTerm : sort -> term -> term) = + fun sort1 -> + fun t -> + match sort1 with + | Int_sort -> unboxInt t + | Bool_sort -> unboxBool t + | String_sort -> unboxString t + | BitVec_sort sz -> unboxBitVec sz t + | Sort "Real" -> unboxReal t + | uu___ -> FStarC_Compiler_Effect.raise FStarC_Compiler_Util.Impos +let (getBoxedInteger : term -> Prims.int FStar_Pervasives_Native.option) = + fun t -> + match t.tm with + | App (Var s, t2::[]) when s = (FStar_Pervasives_Native.fst boxIntFun) -> + (match t2.tm with + | Integer n -> + let uu___ = FStarC_Compiler_Util.int_of_string n in + FStar_Pervasives_Native.Some uu___ + | uu___ -> FStar_Pervasives_Native.None) + | uu___ -> FStar_Pervasives_Native.None +let (mk_PreType : term -> term) = fun t -> mkApp ("PreType", [t]) t.rng +let (mk_Valid : term -> term) = + fun t -> + match t.tm with + | App + (Var "Prims.b2t", + { tm = App (Var "Prims.op_Equality", uu___::t1::t2::[]); + freevars = uu___1; rng = uu___2;_}::[]) + -> mkEq (t1, t2) t.rng + | App + (Var "Prims.b2t", + { tm = App (Var "Prims.op_disEquality", uu___::t1::t2::[]); + freevars = uu___1; rng = uu___2;_}::[]) + -> let uu___3 = mkEq (t1, t2) norng in mkNot uu___3 t.rng + | App + (Var "Prims.b2t", + { tm = App (Var "Prims.op_LessThanOrEqual", t1::t2::[]); + freevars = uu___; rng = uu___1;_}::[]) + -> + let uu___2 = + let uu___3 = unboxInt t1 in + let uu___4 = unboxInt t2 in (uu___3, uu___4) in + mkLTE uu___2 t.rng + | App + (Var "Prims.b2t", + { tm = App (Var "Prims.op_LessThan", t1::t2::[]); freevars = uu___; + rng = uu___1;_}::[]) + -> + let uu___2 = + let uu___3 = unboxInt t1 in + let uu___4 = unboxInt t2 in (uu___3, uu___4) in + mkLT uu___2 t.rng + | App + (Var "Prims.b2t", + { tm = App (Var "Prims.op_GreaterThanOrEqual", t1::t2::[]); + freevars = uu___; rng = uu___1;_}::[]) + -> + let uu___2 = + let uu___3 = unboxInt t1 in + let uu___4 = unboxInt t2 in (uu___3, uu___4) in + mkGTE uu___2 t.rng + | App + (Var "Prims.b2t", + { tm = App (Var "Prims.op_GreaterThan", t1::t2::[]); + freevars = uu___; rng = uu___1;_}::[]) + -> + let uu___2 = + let uu___3 = unboxInt t1 in + let uu___4 = unboxInt t2 in (uu___3, uu___4) in + mkGT uu___2 t.rng + | App + (Var "Prims.b2t", + { tm = App (Var "Prims.op_AmpAmp", t1::t2::[]); freevars = uu___; + rng = uu___1;_}::[]) + -> + let uu___2 = + let uu___3 = unboxBool t1 in + let uu___4 = unboxBool t2 in (uu___3, uu___4) in + mkAnd uu___2 t.rng + | App + (Var "Prims.b2t", + { tm = App (Var "Prims.op_BarBar", t1::t2::[]); freevars = uu___; + rng = uu___1;_}::[]) + -> + let uu___2 = + let uu___3 = unboxBool t1 in + let uu___4 = unboxBool t2 in (uu___3, uu___4) in + mkOr uu___2 t.rng + | App + (Var "Prims.b2t", + { tm = App (Var "Prims.op_Negation", t1::[]); freevars = uu___; + rng = uu___1;_}::[]) + -> let uu___2 = unboxBool t1 in mkNot uu___2 t1.rng + | App + (Var "Prims.b2t", + { tm = App (Var "FStar.BV.bvult", t0::t1::t2::[]); freevars = uu___; + rng = uu___1;_}::[]) + when + let uu___2 = getBoxedInteger t0 in + FStarC_Compiler_Util.is_some uu___2 -> + let sz = + let uu___2 = getBoxedInteger t0 in + match uu___2 with + | FStar_Pervasives_Native.Some sz1 -> sz1 + | uu___3 -> failwith "impossible" in + let uu___2 = + let uu___3 = unboxBitVec sz t1 in + let uu___4 = unboxBitVec sz t2 in (uu___3, uu___4) in + mkBvUlt uu___2 t.rng + | App + (Var "Prims.equals", + uu___::{ tm = App (Var "FStar.BV.bvult", t0::t1::t2::[]); + freevars = uu___1; rng = uu___2;_}::uu___3::[]) + when + let uu___4 = getBoxedInteger t0 in + FStarC_Compiler_Util.is_some uu___4 -> + let sz = + let uu___4 = getBoxedInteger t0 in + match uu___4 with + | FStar_Pervasives_Native.Some sz1 -> sz1 + | uu___5 -> failwith "impossible" in + let uu___4 = + let uu___5 = unboxBitVec sz t1 in + let uu___6 = unboxBitVec sz t2 in (uu___5, uu___6) in + mkBvUlt uu___4 t.rng + | App (Var "Prims.b2t", t1::[]) -> + let uu___ = unboxBool t1 in + { tm = (uu___.tm); freevars = (uu___.freevars); rng = (t.rng) } + | uu___ -> mkApp ("Valid", [t]) t.rng +let (mk_unit_type : term) = mkApp ("Prims.unit", []) norng +let (mk_subtype_of_unit : term -> term) = + fun v -> mkApp ("Prims.subtype_of", [v; mk_unit_type]) v.rng +let (mk_HasType : term -> term -> term) = + fun v -> fun t -> mkApp ("HasType", [v; t]) t.rng +let (mk_HasTypeZ : term -> term -> term) = + fun v -> fun t -> mkApp ("HasTypeZ", [v; t]) t.rng +let (mk_IsTotFun : term -> term) = fun t -> mkApp ("IsTotFun", [t]) t.rng +let (mk_HasTypeFuel : term -> term -> term -> term) = + fun f -> + fun v -> + fun t -> + let uu___ = FStarC_Options.unthrottle_inductives () in + if uu___ + then mk_HasType v t + else mkApp ("HasTypeFuel", [f; v; t]) t.rng +let (mk_HasTypeWithFuel : + term FStar_Pervasives_Native.option -> term -> term -> term) = + fun f -> + fun v -> + fun t -> + match f with + | FStar_Pervasives_Native.None -> mk_HasType v t + | FStar_Pervasives_Native.Some f1 -> mk_HasTypeFuel f1 v t +let (mk_NoHoist : term -> term -> term) = + fun dummy -> fun b -> mkApp ("NoHoist", [dummy; b]) b.rng +let (mk_tester : Prims.string -> term -> term) = + fun n -> fun t -> mkApp ((Prims.strcat "is-" n), [t]) t.rng +let (mk_ApplyTF : term -> term -> term) = + fun t -> fun t' -> mkApp ("ApplyTF", [t; t']) t.rng +let (mk_ApplyTT : term -> term -> FStarC_Compiler_Range_Type.range -> term) = + fun t -> fun t' -> fun r -> mkApp ("ApplyTT", [t; t']) r +let (kick_partial_app : term -> term) = + fun t -> + let uu___ = + let uu___1 = mkApp ("__uu__PartialApp", []) t.rng in + mk_ApplyTT uu___1 t t.rng in + mk_Valid uu___ +let (mk_String_const : + Prims.string -> FStarC_Compiler_Range_Type.range -> term) = + fun s -> + fun r -> + let uu___ = + let uu___1 = let uu___2 = mk (String s) r in [uu___2] in + ("FString_const", uu___1) in + mkApp uu___ r +let (mk_Precedes : + term -> term -> term -> term -> FStarC_Compiler_Range_Type.range -> term) = + fun x1 -> + fun x2 -> + fun x3 -> + fun x4 -> + fun r -> + let uu___ = mkApp ("Prims.precedes", [x1; x2; x3; x4]) r in + mk_Valid uu___ +let rec (n_fuel : Prims.int -> term) = + fun n -> + if n = Prims.int_zero + then mkApp ("ZFuel", []) norng + else + (let uu___1 = + let uu___2 = let uu___3 = n_fuel (n - Prims.int_one) in [uu___3] in + ("SFuel", uu___2) in + mkApp uu___1 norng) +let (mk_and_l : term Prims.list -> FStarC_Compiler_Range_Type.range -> term) + = + fun l -> + fun r -> + let uu___ = mkTrue r in + FStarC_Compiler_List.fold_right (fun p1 -> fun p2 -> mkAnd (p1, p2) r) + l uu___ +let (mk_or_l : term Prims.list -> FStarC_Compiler_Range_Type.range -> term) = + fun l -> + fun r -> + let uu___ = mkFalse r in + FStarC_Compiler_List.fold_right (fun p1 -> fun p2 -> mkOr (p1, p2) r) l + uu___ +let (mk_haseq : term -> term) = + fun t -> let uu___ = mkApp ("Prims.hasEq", [t]) t.rng in mk_Valid uu___ +let (dummy_sort : sort) = Sort "Dummy_sort" +let (showable_smt_term : term FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = print_smt_term } +let (showable_decl : decl FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = (declToSmt_no_caps "") } +let rec (names_of_decl : decl -> Prims.string Prims.list) = + fun d -> + match d with + | Assume a -> [a.assumption_name] + | Module (uu___, ds) -> FStarC_Compiler_List.collect names_of_decl ds + | uu___ -> [] +let (decl_to_string_short : decl -> Prims.string) = + fun d -> + match d with + | DefPrelude -> "prelude" + | DeclFun (s, uu___, uu___1, uu___2) -> Prims.strcat "DeclFun " s + | DefineFun (s, uu___, uu___1, uu___2, uu___3) -> + Prims.strcat "DefineFun " s + | Assume a -> Prims.strcat "Assumption " a.assumption_name + | Caption s -> Prims.strcat "Caption " s + | Module (s, uu___) -> Prims.strcat "Module " s + | Eval uu___ -> "Eval" + | Echo s -> Prims.strcat "Echo " s + | RetainAssumptions uu___ -> "RetainAssumptions" + | Push n -> + let uu___ = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) n in + FStarC_Compiler_Util.format1 "push %s" uu___ + | Pop n -> + let uu___ = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) n in + FStarC_Compiler_Util.format1 "pop %s" uu___ + | CheckSat -> "check-sat" + | GetUnsatCore -> "get-unsat-core" + | SetOption (s, v) -> + Prims.strcat "SetOption " (Prims.strcat s (Prims.strcat " " v)) + | GetStatistics -> "get-statistics" + | GetReasonUnknown -> "get-reason-unknown" \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_SMTEncoding_UnsatCore.ml b/ocaml/fstar-lib/generated/FStarC_SMTEncoding_UnsatCore.ml new file mode 100644 index 00000000000..63eab14503b --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_SMTEncoding_UnsatCore.ml @@ -0,0 +1,48 @@ +open Prims +type unsat_core = Prims.string Prims.list +let (filter : + unsat_core -> + FStarC_SMTEncoding_Term.decl Prims.list -> + FStarC_SMTEncoding_Term.decl Prims.list) + = + fun core -> + fun decls -> + let rec aux theory = + let theory_rev = FStarC_Compiler_List.rev theory in + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun d -> + match uu___1 with + | (keep, n_retained, n_pruned) -> + (match d with + | FStarC_SMTEncoding_Term.Assume a -> + if + FStarC_Compiler_List.contains + a.FStarC_SMTEncoding_Term.assumption_name core + then + ((d :: keep), (n_retained + Prims.int_one), + n_pruned) + else + if + FStarC_Compiler_Util.starts_with + a.FStarC_SMTEncoding_Term.assumption_name "@" + then ((d :: keep), n_retained, n_pruned) + else + (keep, n_retained, (n_pruned + Prims.int_one)) + | FStarC_SMTEncoding_Term.Module (name, decls1) -> + let uu___2 = aux decls1 in + (match uu___2 with + | (keep', n, m) -> + (((FStarC_SMTEncoding_Term.Module + (name, keep')) :: keep), + (n_retained + n), (n_pruned + m))) + | uu___2 -> ((d :: keep), n_retained, n_pruned))) + ([FStarC_SMTEncoding_Term.Caption + (Prims.strcat "UNSAT CORE USED: " + (FStarC_Compiler_String.concat ", " core))], + Prims.int_zero, Prims.int_zero) theory_rev in + match uu___ with + | (keep, n_retained, n_pruned) -> (keep, n_retained, n_pruned) in + let uu___ = aux decls in + match uu___ with | (keep, uu___1, uu___2) -> keep \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_SMTEncoding_Util.ml b/ocaml/fstar-lib/generated/FStarC_SMTEncoding_Util.ml new file mode 100644 index 00000000000..76be85ef0dd --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_SMTEncoding_Util.ml @@ -0,0 +1,287 @@ +open Prims +let (mkAssume : + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.caption * + Prims.string) -> FStarC_SMTEncoding_Term.decl) + = + fun uu___ -> + match uu___ with + | (tm, cap, nm) -> + let uu___1 = + let uu___2 = FStarC_SMTEncoding_Term.escape nm in + let uu___3 = FStarC_SMTEncoding_Term.free_top_level_names tm in + { + FStarC_SMTEncoding_Term.assumption_term = tm; + FStarC_SMTEncoding_Term.assumption_caption = cap; + FStarC_SMTEncoding_Term.assumption_name = uu___2; + FStarC_SMTEncoding_Term.assumption_fact_ids = []; + FStarC_SMTEncoding_Term.assumption_free_names = uu___3 + } in + FStarC_SMTEncoding_Term.Assume uu___1 +let norng : + 'uuuuu 'uuuuu1 . + ('uuuuu -> FStarC_Compiler_Range_Type.range -> 'uuuuu1) -> + 'uuuuu -> 'uuuuu1 + = fun f -> fun x -> f x FStarC_Compiler_Range_Type.dummyRange +let (mkTrue : FStarC_SMTEncoding_Term.term) = + FStarC_SMTEncoding_Term.mkTrue FStarC_Compiler_Range_Type.dummyRange +let (mkFalse : FStarC_SMTEncoding_Term.term) = + FStarC_SMTEncoding_Term.mkFalse FStarC_Compiler_Range_Type.dummyRange +let (mkInteger : Prims.string -> FStarC_SMTEncoding_Term.term) = + norng FStarC_SMTEncoding_Term.mkInteger +let (mkInteger' : Prims.int -> FStarC_SMTEncoding_Term.term) = + norng FStarC_SMTEncoding_Term.mkInteger' +let (mkReal : Prims.string -> FStarC_SMTEncoding_Term.term) = + norng FStarC_SMTEncoding_Term.mkReal +let (mkBoundV : Prims.int -> FStarC_SMTEncoding_Term.term) = + norng FStarC_SMTEncoding_Term.mkBoundV +let (mkFreeV : FStarC_SMTEncoding_Term.fv -> FStarC_SMTEncoding_Term.term) = + norng FStarC_SMTEncoding_Term.mkFreeV +let (mkApp' : + (FStarC_SMTEncoding_Term.op * FStarC_SMTEncoding_Term.term Prims.list) -> + FStarC_SMTEncoding_Term.term) + = norng FStarC_SMTEncoding_Term.mkApp' +let (mkApp : + (Prims.string * FStarC_SMTEncoding_Term.term Prims.list) -> + FStarC_SMTEncoding_Term.term) + = norng FStarC_SMTEncoding_Term.mkApp +let (mkNot : FStarC_SMTEncoding_Term.term -> FStarC_SMTEncoding_Term.term) = + norng FStarC_SMTEncoding_Term.mkNot +let (mkMinus : FStarC_SMTEncoding_Term.term -> FStarC_SMTEncoding_Term.term) + = norng FStarC_SMTEncoding_Term.mkMinus +let (mkAnd : + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = norng FStarC_SMTEncoding_Term.mkAnd +let (mkOr : + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = norng FStarC_SMTEncoding_Term.mkOr +let (mkImp : + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = norng FStarC_SMTEncoding_Term.mkImp +let (mkIff : + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = norng FStarC_SMTEncoding_Term.mkIff +let (mkEq : + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = norng FStarC_SMTEncoding_Term.mkEq +let (mkLT : + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = norng FStarC_SMTEncoding_Term.mkLT +let (mkLTE : + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = norng FStarC_SMTEncoding_Term.mkLTE +let (mkGT : + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = norng FStarC_SMTEncoding_Term.mkGT +let (mkGTE : + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = norng FStarC_SMTEncoding_Term.mkGTE +let (mkAdd : + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = norng FStarC_SMTEncoding_Term.mkAdd +let (mkSub : + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = norng FStarC_SMTEncoding_Term.mkSub +let (mkDiv : + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = norng FStarC_SMTEncoding_Term.mkDiv +let (mkRealDiv : + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = norng FStarC_SMTEncoding_Term.mkRealDiv +let (mkMul : + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = norng FStarC_SMTEncoding_Term.mkMul +let (mkMod : + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = norng FStarC_SMTEncoding_Term.mkMod +let (mkNatToBv : + Prims.int -> FStarC_SMTEncoding_Term.term -> FStarC_SMTEncoding_Term.term) + = fun sz -> norng (FStarC_SMTEncoding_Term.mkNatToBv sz) +let (mkBvAnd : + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = norng FStarC_SMTEncoding_Term.mkBvAnd +let (mkBvXor : + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = norng FStarC_SMTEncoding_Term.mkBvXor +let (mkBvOr : + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = norng FStarC_SMTEncoding_Term.mkBvOr +let (mkBvAdd : + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = norng FStarC_SMTEncoding_Term.mkBvAdd +let (mkBvSub : + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = norng FStarC_SMTEncoding_Term.mkBvSub +let (mkBvShl : + Prims.int -> + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = fun sz -> norng (FStarC_SMTEncoding_Term.mkBvShl sz) +let (mkBvShr : + Prims.int -> + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = fun sz -> norng (FStarC_SMTEncoding_Term.mkBvShr sz) +let (mkBvUdiv : + Prims.int -> + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = fun sz -> norng (FStarC_SMTEncoding_Term.mkBvUdiv sz) +let (mkBvMod : + Prims.int -> + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = fun sz -> norng (FStarC_SMTEncoding_Term.mkBvMod sz) +let (mkBvMul : + Prims.int -> + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = fun sz -> norng (FStarC_SMTEncoding_Term.mkBvMul sz) +let (mkBvShl' : + Prims.int -> + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = fun sz -> norng (FStarC_SMTEncoding_Term.mkBvShl' sz) +let (mkBvShr' : + Prims.int -> + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = fun sz -> norng (FStarC_SMTEncoding_Term.mkBvShr' sz) +let (mkBvUdivUnsafe : + Prims.int -> + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = fun sz -> norng (FStarC_SMTEncoding_Term.mkBvUdivUnsafe sz) +let (mkBvModUnsafe : + Prims.int -> + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = fun sz -> norng (FStarC_SMTEncoding_Term.mkBvModUnsafe sz) +let (mkBvMul' : + Prims.int -> + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = fun sz -> norng (FStarC_SMTEncoding_Term.mkBvMul' sz) +let (mkBvUlt : + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term) -> + FStarC_SMTEncoding_Term.term) + = norng FStarC_SMTEncoding_Term.mkBvUlt +let (mkBvUext : + Prims.int -> FStarC_SMTEncoding_Term.term -> FStarC_SMTEncoding_Term.term) + = fun sz -> norng (FStarC_SMTEncoding_Term.mkBvUext sz) +let (mkBvToNat : + FStarC_SMTEncoding_Term.term -> FStarC_SMTEncoding_Term.term) = + norng FStarC_SMTEncoding_Term.mkBvToNat +let (mkITE : + (FStarC_SMTEncoding_Term.term * FStarC_SMTEncoding_Term.term * + FStarC_SMTEncoding_Term.term) -> FStarC_SMTEncoding_Term.term) + = norng FStarC_SMTEncoding_Term.mkITE +let (mkCases : + FStarC_SMTEncoding_Term.term Prims.list -> FStarC_SMTEncoding_Term.term) = + norng FStarC_SMTEncoding_Term.mkCases +let norng2 : + 'uuuuu 'uuuuu1 'uuuuu2 . + ('uuuuu -> 'uuuuu1 -> FStarC_Compiler_Range_Type.range -> 'uuuuu2) -> + 'uuuuu -> 'uuuuu1 -> 'uuuuu2 + = fun f -> fun x -> fun y -> f x y FStarC_Compiler_Range_Type.dummyRange +let norng3 : + 'uuuuu 'uuuuu1 'uuuuu2 'uuuuu3 . + ('uuuuu -> + 'uuuuu1 -> 'uuuuu2 -> FStarC_Compiler_Range_Type.range -> 'uuuuu3) + -> 'uuuuu -> 'uuuuu1 -> 'uuuuu2 -> 'uuuuu3 + = + fun f -> + fun x -> fun y -> fun z -> f x y z FStarC_Compiler_Range_Type.dummyRange +let norng4 : + 'uuuuu 'uuuuu1 'uuuuu2 'uuuuu3 'uuuuu4 . + ('uuuuu -> + 'uuuuu1 -> + 'uuuuu2 -> 'uuuuu3 -> FStarC_Compiler_Range_Type.range -> 'uuuuu4) + -> 'uuuuu -> 'uuuuu1 -> 'uuuuu2 -> 'uuuuu3 -> 'uuuuu4 + = + fun f -> + fun x -> + fun y -> + fun z -> fun w -> f x y z w FStarC_Compiler_Range_Type.dummyRange +let (mk_Term_app : + FStarC_SMTEncoding_Term.term -> + FStarC_SMTEncoding_Term.term -> FStarC_SMTEncoding_Term.term) + = norng2 FStarC_SMTEncoding_Term.mk_Term_app +let (mk_Term_uvar : Prims.int -> FStarC_SMTEncoding_Term.term) = + norng FStarC_SMTEncoding_Term.mk_Term_uvar +let (mk_and_l : + FStarC_SMTEncoding_Term.term Prims.list -> FStarC_SMTEncoding_Term.term) = + norng FStarC_SMTEncoding_Term.mk_and_l +let (mk_or_l : + FStarC_SMTEncoding_Term.term Prims.list -> FStarC_SMTEncoding_Term.term) = + norng FStarC_SMTEncoding_Term.mk_or_l +let (mk_ApplyTT : + FStarC_SMTEncoding_Term.term -> + FStarC_SMTEncoding_Term.term -> FStarC_SMTEncoding_Term.term) + = norng2 FStarC_SMTEncoding_Term.mk_ApplyTT +let (mk_String_const : Prims.string -> FStarC_SMTEncoding_Term.term) = + norng FStarC_SMTEncoding_Term.mk_String_const +let (mk_Precedes : + FStarC_SMTEncoding_Term.term -> + FStarC_SMTEncoding_Term.term -> + FStarC_SMTEncoding_Term.term -> + FStarC_SMTEncoding_Term.term -> FStarC_SMTEncoding_Term.term) + = norng4 FStarC_SMTEncoding_Term.mk_Precedes +let (is_smt_reifiable_effect : + FStarC_TypeChecker_Env.env -> FStarC_Ident.lident -> Prims.bool) = + fun en -> + fun l -> + let l1 = FStarC_TypeChecker_Env.norm_eff_name en l in + (FStarC_TypeChecker_Env.is_reifiable_effect en l1) && + (let uu___ = + let uu___1 = FStarC_TypeChecker_Env.get_effect_decl en l1 in + FStarC_Syntax_Util.is_layered uu___1 in + Prims.op_Negation uu___) +let (is_smt_reifiable_comp : + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.comp -> Prims.bool) = + fun en -> + fun c -> + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Comp ct -> + is_smt_reifiable_effect en ct.FStarC_Syntax_Syntax.effect_name + | uu___ -> false +let (is_smt_reifiable_rc : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.residual_comp -> Prims.bool) + = + fun en -> + fun rc -> + is_smt_reifiable_effect en rc.FStarC_Syntax_Syntax.residual_effect +let (is_smt_reifiable_function : + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.term -> Prims.bool) = + fun en -> + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = uu___1; + FStarC_Syntax_Syntax.comp = c;_} + -> + is_smt_reifiable_effect en (FStarC_Syntax_Util.comp_effect_name c) + | uu___1 -> false \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_SMTEncoding_Z3.ml b/ocaml/fstar-lib/generated/FStarC_SMTEncoding_Z3.ml new file mode 100644 index 00000000000..97dae3f0503 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_SMTEncoding_Z3.ml @@ -0,0 +1,1392 @@ +open Prims +type z3status = + | UNSAT of FStarC_SMTEncoding_UnsatCore.unsat_core + FStar_Pervasives_Native.option + | SAT of (FStarC_SMTEncoding_Term.error_labels * Prims.string + FStar_Pervasives_Native.option) + | UNKNOWN of (FStarC_SMTEncoding_Term.error_labels * Prims.string + FStar_Pervasives_Native.option) + | TIMEOUT of (FStarC_SMTEncoding_Term.error_labels * Prims.string + FStar_Pervasives_Native.option) + | KILLED +let (uu___is_UNSAT : z3status -> Prims.bool) = + fun projectee -> match projectee with | UNSAT _0 -> true | uu___ -> false +let (__proj__UNSAT__item___0 : + z3status -> + FStarC_SMTEncoding_UnsatCore.unsat_core FStar_Pervasives_Native.option) + = fun projectee -> match projectee with | UNSAT _0 -> _0 +let (uu___is_SAT : z3status -> Prims.bool) = + fun projectee -> match projectee with | SAT _0 -> true | uu___ -> false +let (__proj__SAT__item___0 : + z3status -> + (FStarC_SMTEncoding_Term.error_labels * Prims.string + FStar_Pervasives_Native.option)) + = fun projectee -> match projectee with | SAT _0 -> _0 +let (uu___is_UNKNOWN : z3status -> Prims.bool) = + fun projectee -> match projectee with | UNKNOWN _0 -> true | uu___ -> false +let (__proj__UNKNOWN__item___0 : + z3status -> + (FStarC_SMTEncoding_Term.error_labels * Prims.string + FStar_Pervasives_Native.option)) + = fun projectee -> match projectee with | UNKNOWN _0 -> _0 +let (uu___is_TIMEOUT : z3status -> Prims.bool) = + fun projectee -> match projectee with | TIMEOUT _0 -> true | uu___ -> false +let (__proj__TIMEOUT__item___0 : + z3status -> + (FStarC_SMTEncoding_Term.error_labels * Prims.string + FStar_Pervasives_Native.option)) + = fun projectee -> match projectee with | TIMEOUT _0 -> _0 +let (uu___is_KILLED : z3status -> Prims.bool) = + fun projectee -> match projectee with | KILLED -> true | uu___ -> false +type z3statistics = Prims.string FStarC_Compiler_Util.smap +type z3result = + { + z3result_status: z3status ; + z3result_time: Prims.int ; + z3result_statistics: z3statistics ; + z3result_query_hash: Prims.string FStar_Pervasives_Native.option ; + z3result_log_file: Prims.string FStar_Pervasives_Native.option } +let (__proj__Mkz3result__item__z3result_status : z3result -> z3status) = + fun projectee -> + match projectee with + | { z3result_status; z3result_time; z3result_statistics; + z3result_query_hash; z3result_log_file;_} -> z3result_status +let (__proj__Mkz3result__item__z3result_time : z3result -> Prims.int) = + fun projectee -> + match projectee with + | { z3result_status; z3result_time; z3result_statistics; + z3result_query_hash; z3result_log_file;_} -> z3result_time +let (__proj__Mkz3result__item__z3result_statistics : + z3result -> z3statistics) = + fun projectee -> + match projectee with + | { z3result_status; z3result_time; z3result_statistics; + z3result_query_hash; z3result_log_file;_} -> z3result_statistics +let (__proj__Mkz3result__item__z3result_query_hash : + z3result -> Prims.string FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { z3result_status; z3result_time; z3result_statistics; + z3result_query_hash; z3result_log_file;_} -> z3result_query_hash +let (__proj__Mkz3result__item__z3result_log_file : + z3result -> Prims.string FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { z3result_status; z3result_time; z3result_statistics; + z3result_query_hash; z3result_log_file;_} -> z3result_log_file +type query_log = + { + get_module_name: unit -> Prims.string ; + set_module_name: Prims.string -> unit ; + write_to_log: Prims.bool -> Prims.string -> Prims.string ; + append_to_log: Prims.string -> Prims.string ; + close_log: unit -> unit } +let (__proj__Mkquery_log__item__get_module_name : + query_log -> unit -> Prims.string) = + fun projectee -> + match projectee with + | { get_module_name; set_module_name; write_to_log; append_to_log; + close_log;_} -> get_module_name +let (__proj__Mkquery_log__item__set_module_name : + query_log -> Prims.string -> unit) = + fun projectee -> + match projectee with + | { get_module_name; set_module_name; write_to_log; append_to_log; + close_log;_} -> set_module_name +let (__proj__Mkquery_log__item__write_to_log : + query_log -> Prims.bool -> Prims.string -> Prims.string) = + fun projectee -> + match projectee with + | { get_module_name; set_module_name; write_to_log; append_to_log; + close_log;_} -> write_to_log +let (__proj__Mkquery_log__item__append_to_log : + query_log -> Prims.string -> Prims.string) = + fun projectee -> + match projectee with + | { get_module_name; set_module_name; write_to_log; append_to_log; + close_log;_} -> append_to_log +let (__proj__Mkquery_log__item__close_log : query_log -> unit -> unit) = + fun projectee -> + match projectee with + | { get_module_name; set_module_name; write_to_log; append_to_log; + close_log;_} -> close_log +let (_already_warned_solver_mismatch : Prims.bool FStarC_Compiler_Effect.ref) + = FStarC_Compiler_Util.mk_ref false +let (_already_warned_version_mismatch : + Prims.bool FStarC_Compiler_Effect.ref) = FStarC_Compiler_Util.mk_ref false +let (z3url : Prims.string) = "https://github.com/Z3Prover/z3/releases" +let (inpath : Prims.string -> Prims.bool) = + fun path -> + try + (fun uu___ -> + match () with + | () -> + let s = + FStarC_Compiler_Util.run_process "z3_pathtest" path + ["-version"] FStar_Pervasives_Native.None in + s <> "") () + with | uu___ -> false +let (z3_exe : unit -> Prims.string) = + let cache = FStarC_Compiler_Util.smap_create (Prims.of_int (5)) in + let find_or k f = + let uu___ = FStarC_Compiler_Util.smap_try_find cache k in + match uu___ with + | FStar_Pervasives_Native.Some v -> v + | FStar_Pervasives_Native.None -> + let v = f k in (FStarC_Compiler_Util.smap_add cache k v; v) in + fun uu___ -> + let uu___1 = FStarC_Options.z3_version () in + find_or uu___1 + (fun version -> + let path = + let z3_v = FStarC_Platform.exe (Prims.strcat "z3-" version) in + let smto = FStarC_Options.smt () in + if FStar_Pervasives_Native.uu___is_Some smto + then FStar_Pervasives_Native.__proj__Some__item__v smto + else + (let uu___3 = inpath z3_v in + if uu___3 then z3_v else FStarC_Platform.exe "z3") in + (let uu___3 = FStarC_Compiler_Debug.any () in + if uu___3 + then FStarC_Compiler_Util.print1 "Chosen Z3 executable: %s\n" path + else ()); + path) +type label = Prims.string +let (status_tag : z3status -> Prims.string) = + fun uu___ -> + match uu___ with + | SAT uu___1 -> "sat" + | UNSAT uu___1 -> "unsat" + | UNKNOWN uu___1 -> "unknown" + | TIMEOUT uu___1 -> "timeout" + | KILLED -> "killed" +let (status_string_and_errors : + z3status -> (Prims.string * FStarC_SMTEncoding_Term.error_labels)) = + fun s -> + match s with + | KILLED -> ((status_tag s), []) + | UNSAT uu___ -> ((status_tag s), []) + | SAT (errs, msg) -> + let uu___ = + FStarC_Compiler_Util.format2 "%s%s" (status_tag s) + (match msg with + | FStar_Pervasives_Native.None -> "" + | FStar_Pervasives_Native.Some msg1 -> + Prims.strcat " because " msg1) in + (uu___, errs) + | UNKNOWN (errs, msg) -> + let uu___ = + FStarC_Compiler_Util.format2 "%s%s" (status_tag s) + (match msg with + | FStar_Pervasives_Native.None -> "" + | FStar_Pervasives_Native.Some msg1 -> + Prims.strcat " because " msg1) in + (uu___, errs) + | TIMEOUT (errs, msg) -> + let uu___ = + FStarC_Compiler_Util.format2 "%s%s" (status_tag s) + (match msg with + | FStar_Pervasives_Native.None -> "" + | FStar_Pervasives_Native.Some msg1 -> + Prims.strcat " because " msg1) in + (uu___, errs) +let (query_logging : query_log) = + let query_number = FStarC_Compiler_Util.mk_ref Prims.int_zero in + let log_file_opt = FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None in + let used_file_names = FStarC_Compiler_Util.mk_ref [] in + let current_module_name = + FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None in + let current_file_name = + FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None in + let set_module_name n = + FStarC_Compiler_Effect.op_Colon_Equals current_module_name + (FStar_Pervasives_Native.Some n) in + let get_module_name uu___ = + let uu___1 = FStarC_Compiler_Effect.op_Bang current_module_name in + match uu___1 with + | FStar_Pervasives_Native.None -> failwith "Module name not set" + | FStar_Pervasives_Native.Some n -> n in + let next_file_name uu___ = + let n = get_module_name () in + let file_name = + let uu___1 = + let uu___2 = FStarC_Compiler_Effect.op_Bang used_file_names in + FStarC_Compiler_List.tryFind + (fun uu___3 -> match uu___3 with | (m, uu___4) -> n = m) uu___2 in + match uu___1 with + | FStar_Pervasives_Native.None -> + ((let uu___3 = + let uu___4 = FStarC_Compiler_Effect.op_Bang used_file_names in + (n, Prims.int_zero) :: uu___4 in + FStarC_Compiler_Effect.op_Colon_Equals used_file_names uu___3); + n) + | FStar_Pervasives_Native.Some (uu___2, k) -> + ((let uu___4 = + let uu___5 = FStarC_Compiler_Effect.op_Bang used_file_names in + (n, (k + Prims.int_one)) :: uu___5 in + FStarC_Compiler_Effect.op_Colon_Equals used_file_names uu___4); + (let uu___4 = + FStarC_Compiler_Util.string_of_int (k + Prims.int_one) in + FStarC_Compiler_Util.format2 "%s-%s" n uu___4)) in + FStarC_Compiler_Util.format1 "queries-%s.smt2" file_name in + let new_log_file uu___ = + let file_name = next_file_name () in + FStarC_Compiler_Effect.op_Colon_Equals current_file_name + (FStar_Pervasives_Native.Some file_name); + (let c = FStarC_Compiler_Util.open_file_for_writing file_name in + FStarC_Compiler_Effect.op_Colon_Equals log_file_opt + (FStar_Pervasives_Native.Some (c, file_name)); + (c, file_name)) in + let get_log_file uu___ = + let uu___1 = FStarC_Compiler_Effect.op_Bang log_file_opt in + match uu___1 with + | FStar_Pervasives_Native.None -> new_log_file () + | FStar_Pervasives_Native.Some c -> c in + let append_to_log str = + let uu___ = get_log_file () in + match uu___ with + | (f, nm) -> (FStarC_Compiler_Util.append_to_file f str; nm) in + let write_to_new_log str = + let file_name = next_file_name () in + FStarC_Compiler_Util.write_file file_name str; file_name in + let write_to_log fresh str = + if fresh then write_to_new_log str else append_to_log str in + let close_log uu___ = + let uu___1 = FStarC_Compiler_Effect.op_Bang log_file_opt in + match uu___1 with + | FStar_Pervasives_Native.None -> () + | FStar_Pervasives_Native.Some (c, uu___2) -> + (FStarC_Compiler_Util.close_out_channel c; + FStarC_Compiler_Effect.op_Colon_Equals log_file_opt + FStar_Pervasives_Native.None) in + let log_file_name uu___ = + let uu___1 = FStarC_Compiler_Effect.op_Bang current_file_name in + match uu___1 with + | FStar_Pervasives_Native.None -> failwith "no log file" + | FStar_Pervasives_Native.Some n -> n in + { get_module_name; set_module_name; write_to_log; append_to_log; close_log + } +let (z3_cmd_and_args : unit -> (Prims.string * Prims.string Prims.list)) = + fun uu___ -> + let cmd = z3_exe () in + let cmd_args = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Options.z3_seed () in + FStarC_Compiler_Util.string_of_int uu___6 in + FStarC_Compiler_Util.format1 "smt.random_seed=%s" uu___5 in + [uu___4] in + "-in" :: uu___3 in + "-smt2" :: uu___2 in + let uu___2 = FStarC_Options.z3_cliopt () in + FStarC_Compiler_List.append uu___1 uu___2 in + (cmd, cmd_args) +let (warn_handler : FStarC_Errors_Msg.error_message -> Prims.string -> unit) + = + fun suf -> + fun s -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Errors_Msg.text "Unexpected output from Z3:" in + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Pprint.blank (Prims.of_int (2)) in + let uu___7 = + let uu___8 = + let uu___9 = FStarC_Pprint.arbitrary_string s in + FStarC_Pprint.dquotes uu___9 in + FStarC_Pprint.align uu___8 in + FStarC_Pprint.op_Hat_Hat uu___6 uu___7 in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline uu___5 in + FStarC_Pprint.op_Hat_Hat uu___3 uu___4 in + [uu___2] in + FStarC_Compiler_List.op_At uu___1 suf in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_UnexpectedZ3Output + () (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___) +let (check_z3version : FStarC_Compiler_Util.proc -> unit) = + fun p -> + let getinfo arg = + let s = + let uu___ = + FStarC_Compiler_Util.format1 "(get-info :%s)\n(echo \"Done!\")\n" + arg in + FStarC_Compiler_Util.ask_process p uu___ (fun uu___1 -> "Killed") + (warn_handler []) in + if FStarC_Compiler_Util.starts_with s (Prims.strcat "(:" arg) + then + let ss = FStarC_Compiler_String.split [34] s in + FStarC_Compiler_List.nth ss Prims.int_one + else + (warn_handler [] s; + (let uu___2 = + let uu___3 = FStarC_Compiler_Util.proc_prog p in + FStarC_Compiler_Util.format1 "Could not run Z3 from `%s'" uu___3 in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Error_Z3InvocationError () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2))) in + let name = getinfo "name" in + (let uu___1 = + (name <> "Z3") && + (let uu___2 = + FStarC_Compiler_Effect.op_Bang _already_warned_solver_mismatch in + Prims.op_Negation uu___2) in + if uu___1 + then + ((let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Options.z3_version () in + Prims.strcat "z3-" uu___6 in + FStarC_Platform.exe uu___5 in + FStarC_Compiler_Util.format3 + "Unexpected SMT solver: expected to be talking to Z3, got %s.\nPlease download the correct version of Z3 from %s\nand install it into your $PATH as `%s'." + name z3url uu___4 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_SolverMismatch + () (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___3)); + FStarC_Compiler_Effect.op_Colon_Equals + _already_warned_solver_mismatch true) + else ()); + (let ver_found = + let uu___1 = + let uu___2 = + let uu___3 = getinfo "version" in + FStarC_Compiler_Util.split uu___3 "-" in + FStarC_Compiler_List.hd uu___2 in + FStarC_Compiler_Util.trim_string uu___1 in + let ver_conf = + let uu___1 = FStarC_Options.z3_version () in + FStarC_Compiler_Util.trim_string uu___1 in + let uu___2 = + (ver_conf <> ver_found) && + (let uu___3 = + FStarC_Compiler_Effect.op_Bang _already_warned_version_mismatch in + Prims.op_Negation uu___3) in + if uu___2 + then + ((let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Compiler_Util.proc_prog p in + FStarC_Compiler_Util.format3 + "Unexpected Z3 version for '%s': expected '%s', got '%s'." + uu___7 ver_conf ver_found in + FStarC_Errors_Msg.text uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Errors_Msg.text + "Please download the correct version of Z3 from" in + let uu___10 = FStarC_Pprint.url z3url in + FStarC_Pprint.prefix (Prims.of_int (4)) Prims.int_one uu___9 + uu___10 in + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Errors_Msg.text + "and install it into your $PATH as" in + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = + let uu___17 = FStarC_Options.z3_version () in + Prims.strcat "z3-" uu___17 in + FStarC_Platform.exe uu___16 in + FStarC_Pprint.doc_of_string uu___15 in + FStarC_Pprint.squotes uu___14 in + FStarC_Pprint.op_Hat_Hat uu___13 FStarC_Pprint.dot in + FStarC_Pprint.op_Hat_Slash_Hat uu___11 uu___12 in + FStarC_Pprint.group uu___10 in + FStarC_Pprint.op_Hat_Slash_Hat uu___8 uu___9 in + [uu___7] in + uu___5 :: uu___6 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_SolverMismatch + () (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___4)); + FStarC_Errors.stop_if_err (); + FStarC_Compiler_Effect.op_Colon_Equals + _already_warned_version_mismatch true) + else ()) +let (new_z3proc : + Prims.string -> + (Prims.string * Prims.string Prims.list) -> FStarC_Compiler_Util.proc) + = + fun id -> + fun cmd_and_args -> + let proc = + try + (fun uu___ -> + match () with + | () -> + FStarC_Compiler_Util.start_process id + (FStar_Pervasives_Native.fst cmd_and_args) + (FStar_Pervasives_Native.snd cmd_and_args) + (fun s -> s = "Done!")) () + with + | uu___ -> + let uu___1 = + let uu___2 = + FStarC_Errors_Msg.text "Could not start SMT solver process." in + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Errors_Msg.text "Command:" in + let uu___6 = + let uu___7 = + FStarC_Pprint.arbitrary_string + (FStar_Pervasives_Native.fst cmd_and_args) in + FStarC_Pprint.squotes uu___7 in + FStarC_Pprint.prefix (Prims.of_int (2)) Prims.int_one + uu___5 uu___6 in + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Errors_Msg.text "Exception:" in + let uu___8 = + let uu___9 = FStarC_Compiler_Util.print_exn uu___ in + FStarC_Pprint.arbitrary_string uu___9 in + FStarC_Pprint.prefix (Prims.of_int (2)) Prims.int_one + uu___7 uu___8 in + [uu___6] in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Error_Z3InvocationError () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___1) in + check_z3version proc; proc +let (new_z3proc_with_id : + (Prims.string * Prims.string Prims.list) -> FStarC_Compiler_Util.proc) = + let ctr = FStarC_Compiler_Util.mk_ref (Prims.of_int (-1)) in + fun cmd_and_args -> + let p = + let uu___ = + let uu___1 = + FStarC_Compiler_Util.incr ctr; + (let uu___3 = FStarC_Compiler_Effect.op_Bang ctr in + FStarC_Compiler_Util.string_of_int uu___3) in + FStarC_Compiler_Util.format1 "z3-bg-%s" uu___1 in + new_z3proc uu___ cmd_and_args in + p +type bgproc = + { + ask: Prims.string -> Prims.string ; + refresh: unit -> unit ; + restart: unit -> unit ; + version: unit -> Prims.string ; + ctxt: FStarC_SMTEncoding_SolverState.solver_state } +let (__proj__Mkbgproc__item__ask : bgproc -> Prims.string -> Prims.string) = + fun projectee -> + match projectee with | { ask; refresh; restart; version; ctxt;_} -> ask +let (__proj__Mkbgproc__item__refresh : bgproc -> unit -> unit) = + fun projectee -> + match projectee with + | { ask; refresh; restart; version; ctxt;_} -> refresh +let (__proj__Mkbgproc__item__restart : bgproc -> unit -> unit) = + fun projectee -> + match projectee with + | { ask; refresh; restart; version; ctxt;_} -> restart +let (__proj__Mkbgproc__item__version : bgproc -> unit -> Prims.string) = + fun projectee -> + match projectee with + | { ask; refresh; restart; version; ctxt;_} -> version +let (__proj__Mkbgproc__item__ctxt : + bgproc -> FStarC_SMTEncoding_SolverState.solver_state) = + fun projectee -> + match projectee with | { ask; refresh; restart; version; ctxt;_} -> ctxt +let (cmd_and_args_to_string : + (Prims.string * Prims.string Prims.list) -> Prims.string) = + fun cmd_and_args -> + FStarC_Compiler_String.concat "" + ["cmd="; + FStar_Pervasives_Native.fst cmd_and_args; + " args=["; + FStarC_Compiler_String.concat ", " + (FStar_Pervasives_Native.snd cmd_and_args); + "]"] +let (bg_z3_proc : bgproc FStarC_Compiler_Effect.ref) = + let the_z3proc = FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None in + let the_z3proc_params = + FStarC_Compiler_Util.mk_ref (FStar_Pervasives_Native.Some ("", [""])) in + let the_z3proc_ask_count = FStarC_Compiler_Util.mk_ref Prims.int_zero in + let the_z3proc_version = FStarC_Compiler_Util.mk_ref "" in + let make_new_z3_proc cmd_and_args = + (let uu___1 = + let uu___2 = new_z3proc_with_id cmd_and_args in + FStar_Pervasives_Native.Some uu___2 in + FStarC_Compiler_Effect.op_Colon_Equals the_z3proc uu___1); + FStarC_Compiler_Effect.op_Colon_Equals the_z3proc_params + (FStar_Pervasives_Native.Some cmd_and_args); + FStarC_Compiler_Effect.op_Colon_Equals the_z3proc_ask_count + Prims.int_zero in + (let uu___1 = FStarC_Options.z3_version () in + FStarC_Compiler_Effect.op_Colon_Equals the_z3proc_version uu___1); + (let z3proc uu___1 = + (let uu___3 = + let uu___4 = FStarC_Compiler_Effect.op_Bang the_z3proc in + uu___4 = FStar_Pervasives_Native.None in + if uu___3 + then let uu___4 = z3_cmd_and_args () in make_new_z3_proc uu___4 + else ()); + (let uu___3 = FStarC_Compiler_Effect.op_Bang the_z3proc in + FStarC_Compiler_Util.must uu___3) in + let ask input = + FStarC_Compiler_Util.incr the_z3proc_ask_count; + (let kill_handler uu___2 = "\nkilled\n" in + let uu___2 = z3proc () in + FStarC_Compiler_Util.ask_process uu___2 input kill_handler + (warn_handler [])) in + let maybe_kill_z3proc uu___1 = + let uu___2 = + let uu___3 = FStarC_Compiler_Effect.op_Bang the_z3proc in + uu___3 <> FStar_Pervasives_Native.None in + if uu___2 + then + ((let uu___4 = + let uu___5 = FStarC_Compiler_Effect.op_Bang the_z3proc in + FStarC_Compiler_Util.must uu___5 in + FStarC_Compiler_Util.kill_process uu___4); + FStarC_Compiler_Effect.op_Colon_Equals the_z3proc + FStar_Pervasives_Native.None) + else () in + let refresh uu___1 = + let next_params = z3_cmd_and_args () in + let old_params = + let uu___2 = FStarC_Compiler_Effect.op_Bang the_z3proc_params in + FStarC_Compiler_Util.must uu___2 in + let old_version = FStarC_Compiler_Effect.op_Bang the_z3proc_version in + let next_version = FStarC_Options.z3_version () in + (let uu___3 = + (((FStarC_Options.log_queries ()) || + (let uu___4 = FStarC_Compiler_Effect.op_Bang the_z3proc_ask_count in + uu___4 > Prims.int_zero)) + || (old_params <> next_params)) + || (old_version <> next_version) in + if uu___3 + then + (maybe_kill_z3proc (); + (let uu___6 = FStarC_Options.query_stats () in + if uu___6 + then + let uu___7 = + let uu___8 = + FStarC_Compiler_Effect.op_Bang the_z3proc_ask_count in + FStarC_Compiler_Util.string_of_int uu___8 in + FStarC_Compiler_Util.print3 + "Refreshing the z3proc (ask_count=%s old=[%s] new=[%s])\n" + uu___7 (cmd_and_args_to_string old_params) + (cmd_and_args_to_string next_params) + else ()); + make_new_z3_proc next_params) + else ()); + query_logging.close_log () in + let restart uu___1 = + maybe_kill_z3proc (); + query_logging.close_log (); + (let next_params = z3_cmd_and_args () in make_new_z3_proc next_params) in + let x = [] in + let uu___1 = + let uu___2 = FStarC_SMTEncoding_SolverState.init () in + { + ask = (FStarC_Compiler_Util.with_monitor x ask); + refresh = (FStarC_Compiler_Util.with_monitor x refresh); + restart = (FStarC_Compiler_Util.with_monitor x restart); + version = + (fun uu___3 -> FStarC_Compiler_Effect.op_Bang the_z3proc_version); + ctxt = uu___2 + } in + FStarC_Compiler_Util.mk_ref uu___1) +type smt_output_section = Prims.string Prims.list +type smt_output = + { + smt_result: smt_output_section ; + smt_reason_unknown: smt_output_section FStar_Pervasives_Native.option ; + smt_unsat_core: smt_output_section FStar_Pervasives_Native.option ; + smt_statistics: smt_output_section FStar_Pervasives_Native.option ; + smt_labels: smt_output_section FStar_Pervasives_Native.option } +let (__proj__Mksmt_output__item__smt_result : + smt_output -> smt_output_section) = + fun projectee -> + match projectee with + | { smt_result; smt_reason_unknown; smt_unsat_core; smt_statistics; + smt_labels;_} -> smt_result +let (__proj__Mksmt_output__item__smt_reason_unknown : + smt_output -> smt_output_section FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { smt_result; smt_reason_unknown; smt_unsat_core; smt_statistics; + smt_labels;_} -> smt_reason_unknown +let (__proj__Mksmt_output__item__smt_unsat_core : + smt_output -> smt_output_section FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { smt_result; smt_reason_unknown; smt_unsat_core; smt_statistics; + smt_labels;_} -> smt_unsat_core +let (__proj__Mksmt_output__item__smt_statistics : + smt_output -> smt_output_section FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { smt_result; smt_reason_unknown; smt_unsat_core; smt_statistics; + smt_labels;_} -> smt_statistics +let (__proj__Mksmt_output__item__smt_labels : + smt_output -> smt_output_section FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { smt_result; smt_reason_unknown; smt_unsat_core; smt_statistics; + smt_labels;_} -> smt_labels +let (smt_output_sections : + Prims.string FStar_Pervasives_Native.option -> + FStarC_Compiler_Range_Type.range -> Prims.string Prims.list -> smt_output) + = + fun log_file -> + fun r -> + fun lines -> + let rec until tag lines1 = + match lines1 with + | [] -> FStar_Pervasives_Native.None + | l::lines2 -> + if tag = l + then FStar_Pervasives_Native.Some ([], lines2) + else + (let uu___1 = until tag lines2 in + FStarC_Compiler_Util.map_opt uu___1 + (fun uu___2 -> + match uu___2 with + | (until_tag, rest) -> ((l :: until_tag), rest))) in + let start_tag tag = Prims.strcat "<" (Prims.strcat tag ">") in + let end_tag tag = Prims.strcat "") in + let find_section tag lines1 = + let uu___ = until (start_tag tag) lines1 in + match uu___ with + | FStar_Pervasives_Native.None -> + (FStar_Pervasives_Native.None, lines1) + | FStar_Pervasives_Native.Some (prefix, suffix) -> + let uu___1 = until (end_tag tag) suffix in + (match uu___1 with + | FStar_Pervasives_Native.None -> + failwith + (Prims.strcat "Parse error: " + (Prims.strcat (end_tag tag) " not found")) + | FStar_Pervasives_Native.Some (section, suffix1) -> + ((FStar_Pervasives_Native.Some section), + (FStarC_Compiler_List.op_At prefix suffix1))) in + let uu___ = find_section "result" lines in + match uu___ with + | (result_opt, lines1) -> + let result = + match result_opt with + | FStar_Pervasives_Native.None -> + let uu___1 = + FStarC_Compiler_Util.format1 + "Unexpexted output from Z3: no result section found:\n%s" + (FStarC_Compiler_String.concat "\n" lines1) in + failwith uu___1 + | FStar_Pervasives_Native.Some result1 -> result1 in + let uu___1 = find_section "reason-unknown" lines1 in + (match uu___1 with + | (reason_unknown, lines2) -> + let uu___2 = find_section "unsat-core" lines2 in + (match uu___2 with + | (unsat_core, lines3) -> + let uu___3 = find_section "statistics" lines3 in + (match uu___3 with + | (statistics, lines4) -> + let uu___4 = find_section "labels" lines4 in + (match uu___4 with + | (labels, lines5) -> + let remaining = + let uu___5 = until "Done!" lines5 in + match uu___5 with + | FStar_Pervasives_Native.None -> lines5 + | FStar_Pervasives_Native.Some + (prefix, suffix) -> + FStarC_Compiler_List.op_At prefix + suffix in + ((match remaining with + | [] -> () + | uu___6 -> + let msg = + FStarC_Compiler_String.concat "\n" + remaining in + let suf = + match log_file with + | FStar_Pervasives_Native.Some + log_file1 -> + let uu___7 = + let uu___8 = + FStarC_Errors_Msg.text + "Log file:" in + let uu___9 = + FStarC_Pprint.doc_of_string + log_file1 in + FStarC_Pprint.op_Hat_Slash_Hat + uu___8 uu___9 in + [uu___7] + | FStar_Pervasives_Native.None -> [] in + warn_handler suf msg); + (let uu___6 = + FStarC_Compiler_Util.must result_opt in + { + smt_result = uu___6; + smt_reason_unknown = reason_unknown; + smt_unsat_core = unsat_core; + smt_statistics = statistics; + smt_labels = labels + })))))) +let with_solver_state : + 'a . + (FStarC_SMTEncoding_SolverState.solver_state -> + ('a * FStarC_SMTEncoding_SolverState.solver_state)) + -> 'a + = + fun f -> + let ss = FStarC_Compiler_Effect.op_Bang bg_z3_proc in + let uu___ = f ss.ctxt in + match uu___ with + | (res, ctxt) -> + (FStarC_Compiler_Effect.op_Colon_Equals bg_z3_proc + { + ask = (ss.ask); + refresh = (ss.refresh); + restart = (ss.restart); + version = (ss.version); + ctxt + }; + res) +let (with_solver_state_unit : + (FStarC_SMTEncoding_SolverState.solver_state -> + FStarC_SMTEncoding_SolverState.solver_state) + -> unit) + = fun f -> with_solver_state (fun x -> let uu___ = f x in ((), uu___)) +let reading_solver_state : + 'a . (FStarC_SMTEncoding_SolverState.solver_state -> 'a) -> 'a = + fun f -> let ss = FStarC_Compiler_Effect.op_Bang bg_z3_proc in f ss.ctxt +let (push : Prims.string -> unit) = + fun msg -> + with_solver_state_unit FStarC_SMTEncoding_SolverState.push; + with_solver_state_unit + (FStarC_SMTEncoding_SolverState.give + [FStarC_SMTEncoding_Term.Caption msg]) +let (pop : Prims.string -> unit) = + fun msg -> + with_solver_state_unit + (FStarC_SMTEncoding_SolverState.give + [FStarC_SMTEncoding_Term.Caption msg]); + with_solver_state_unit FStarC_SMTEncoding_SolverState.pop +let (snapshot : Prims.string -> Prims.int) = + fun msg -> + let d = reading_solver_state FStarC_SMTEncoding_SolverState.depth in + push msg; d +let (rollback : + Prims.string -> Prims.int FStar_Pervasives_Native.option -> unit) = + fun msg -> + fun depth -> + let rec rollback_aux msg1 depth1 = + let d = reading_solver_state FStarC_SMTEncoding_SolverState.depth in + match depth1 with + | FStar_Pervasives_Native.None -> pop msg1 + | FStar_Pervasives_Native.Some n -> + if d = n then () else (pop msg1; rollback_aux msg1 depth1) in + rollback_aux msg depth +let (start_query : + Prims.string -> + FStarC_SMTEncoding_Term.decl Prims.list -> + FStarC_SMTEncoding_Term.decl -> unit) + = + fun msg -> + fun roots_to_push -> + fun qry -> + with_solver_state_unit + (FStarC_SMTEncoding_SolverState.start_query msg roots_to_push qry) +let (finish_query : Prims.string -> unit) = + fun msg -> + with_solver_state_unit (FStarC_SMTEncoding_SolverState.finish_query msg) +let (giveZ3 : FStarC_SMTEncoding_Term.decl Prims.list -> unit) = + fun decls -> + with_solver_state_unit (FStarC_SMTEncoding_SolverState.give decls) +let (refresh : + FStarC_SMTEncoding_SolverState.using_facts_from_setting + FStar_Pervasives_Native.option -> unit) + = + fun using_facts_from -> + (let uu___1 = FStarC_Compiler_Effect.op_Bang bg_z3_proc in + uu___1.refresh ()); + with_solver_state_unit + (FStarC_SMTEncoding_SolverState.reset using_facts_from) +let (doZ3Exe : + Prims.string FStar_Pervasives_Native.option -> + FStarC_Compiler_Range_Type.range -> + Prims.bool -> + Prims.string -> + FStarC_SMTEncoding_Term.error_labels -> + Prims.string -> (z3status * z3statistics)) + = + fun log_file -> + fun r -> + fun fresh -> + fun input -> + fun label_messages -> + fun queryid -> + let parse z3out = + let lines = + FStarC_Compiler_List.map FStarC_Compiler_Util.trim_string + (FStarC_Compiler_String.split [10] z3out) in + let smt_output1 = smt_output_sections log_file r lines in + let unsat_core = + match smt_output1.smt_unsat_core with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some s -> + let s1 = + FStarC_Compiler_Util.trim_string + (FStarC_Compiler_String.concat " " s) in + let s2 = + FStarC_Compiler_Util.substring s1 Prims.int_one + ((FStarC_Compiler_String.length s1) - + (Prims.of_int (2))) in + if FStarC_Compiler_Util.starts_with s2 "error" + then FStar_Pervasives_Native.None + else + (let uu___1 = + FStarC_Compiler_Util.sort_with + FStarC_Compiler_String.compare + (FStarC_Compiler_Util.split s2 " ") in + FStar_Pervasives_Native.Some uu___1) in + let labels = + match smt_output1.smt_labels with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some lines1 -> + let rec lblnegs lines2 = + match lines2 with + | lname::"false"::rest when + FStarC_Compiler_Util.starts_with lname "label_" + -> let uu___ = lblnegs rest in lname :: uu___ + | lname::uu___::rest when + FStarC_Compiler_Util.starts_with lname "label_" + -> lblnegs rest + | uu___ -> [] in + let lblnegs1 = lblnegs lines1 in + FStarC_Compiler_List.collect + (fun l -> + let uu___ = + FStarC_Compiler_List.tryFind + (fun uu___1 -> + match uu___1 with + | (m, uu___2, uu___3) -> + let uu___4 = + FStarC_SMTEncoding_Term.fv_name m in + uu___4 = l) label_messages in + match uu___ with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some (lbl, msg, r1) -> + [(lbl, msg, r1)]) lblnegs1 in + let statistics = + let statistics1 = + FStarC_Compiler_Util.smap_create Prims.int_zero in + match smt_output1.smt_statistics with + | FStar_Pervasives_Native.None -> statistics1 + | FStar_Pervasives_Native.Some lines1 -> + let parse_line line = + let pline = + FStarC_Compiler_Util.split + (FStarC_Compiler_Util.trim_string line) ":" in + match pline with + | "("::entry::[] -> + let tokens = FStarC_Compiler_Util.split entry " " in + let key = FStarC_Compiler_List.hd tokens in + let ltok = + FStarC_Compiler_List.nth tokens + ((FStarC_Compiler_List.length tokens) - + Prims.int_one) in + let value = + if FStarC_Compiler_Util.ends_with ltok ")" + then + FStarC_Compiler_Util.substring ltok + Prims.int_zero + ((FStarC_Compiler_String.length ltok) - + Prims.int_one) + else ltok in + FStarC_Compiler_Util.smap_add statistics1 key + value + | ""::entry::[] -> + let tokens = FStarC_Compiler_Util.split entry " " in + let key = FStarC_Compiler_List.hd tokens in + let ltok = + FStarC_Compiler_List.nth tokens + ((FStarC_Compiler_List.length tokens) - + Prims.int_one) in + let value = + if FStarC_Compiler_Util.ends_with ltok ")" + then + FStarC_Compiler_Util.substring ltok + Prims.int_zero + ((FStarC_Compiler_String.length ltok) - + Prims.int_one) + else ltok in + FStarC_Compiler_Util.smap_add statistics1 key + value + | uu___ -> () in + (FStarC_Compiler_List.iter parse_line lines1; + statistics1) in + let reason_unknown = + FStarC_Compiler_Util.map_opt smt_output1.smt_reason_unknown + (fun x -> + let ru = FStarC_Compiler_String.concat " " x in + if + FStarC_Compiler_Util.starts_with ru + "(:reason-unknown \"" + then + let reason = + FStarC_Compiler_Util.substring_from ru + (FStarC_Compiler_String.length + "(:reason-unknown \"") in + let res = + FStarC_Compiler_String.substring reason + Prims.int_zero + ((FStarC_Compiler_String.length reason) - + (Prims.of_int (2))) in + res + else ru) in + let status = + (let uu___1 = FStarC_Compiler_Debug.any () in + if uu___1 + then + let uu___2 = + FStarC_Compiler_Util.format1 "Z3 says: %s\n" + (FStarC_Compiler_String.concat "\n" + smt_output1.smt_result) in + FStarC_Compiler_Util.print_string uu___2 + else ()); + (match smt_output1.smt_result with + | "unsat"::[] -> UNSAT unsat_core + | "sat"::[] -> SAT (labels, reason_unknown) + | "unknown"::[] -> UNKNOWN (labels, reason_unknown) + | "timeout"::[] -> TIMEOUT (labels, reason_unknown) + | "killed"::[] -> + ((let uu___2 = + FStarC_Compiler_Effect.op_Bang bg_z3_proc in + uu___2.restart ()); + KILLED) + | uu___1 -> + let uu___2 = + FStarC_Compiler_Util.format1 + "Unexpected output from Z3: got output result: %s\n" + (FStarC_Compiler_String.concat "\n" + smt_output1.smt_result) in + failwith uu___2) in + (status, statistics) in + let log_result fwrite uu___ = + match uu___ with + | (res, _stats) -> + ((match log_file with + | FStar_Pervasives_Native.Some fname -> + (fwrite fname (Prims.strcat "; QUERY ID: " queryid); + (let uu___4 = + let uu___5 = + let uu___6 = status_string_and_errors res in + FStar_Pervasives_Native.fst uu___6 in + Prims.strcat "; STATUS: " uu___5 in + fwrite fname uu___4); + (match res with + | UNSAT (FStar_Pervasives_Native.Some core) -> + fwrite fname + (Prims.strcat "; UNSAT CORE GENERATED: " + (FStarC_Compiler_String.concat ", " core)) + | uu___4 -> ())) + | FStar_Pervasives_Native.None -> ()); + (let log_file_name = + match log_file with + | FStar_Pervasives_Native.Some fname -> fname + | uu___2 -> "" in + let uu___3 = + let uu___4 = + reading_solver_state + FStarC_SMTEncoding_SolverState.would_have_pruned in + (uu___4, res) in + match uu___3 with + | (FStar_Pervasives_Native.Some names, UNSAT + (FStar_Pervasives_Native.Some core)) -> + let whitelist = + ["BoxInt"; + "BoxBool"; + "BoxString"; + "BoxReal"; + "Tm_unit"; + "FString_const"] in + let missing = + FStarC_Compiler_List.filter + (fun name -> + (((((let uu___4 = + FStarC_Compiler_Util.for_some + (fun wl -> + FStarC_Compiler_Util.contains + name wl) whitelist in + Prims.op_Negation uu___4) && + (Prims.op_Negation + (FStarC_Compiler_Util.starts_with + name "binder_"))) + && + (Prims.op_Negation + (FStarC_Compiler_Util.starts_with + name "@query"))) + && + (Prims.op_Negation + (FStarC_Compiler_Util.starts_with + name "@MaxFuel"))) + && + (Prims.op_Negation + (FStarC_Compiler_Util.starts_with name + "@MaxIFuel"))) + && + (let uu___4 = + FStarC_Compiler_Util.for_some + (fun name' -> name = name') names in + Prims.op_Negation uu___4)) core in + (match missing with + | [] -> () + | uu___4 -> + FStarC_Compiler_Util.print3 + "Query %s (%s): Pruned theory would miss %s\n" + queryid log_file_name + (FStarC_Compiler_String.concat ", " missing)) + | uu___4 -> ())) in + if fresh + then + let proc = + let uu___ = z3_cmd_and_args () in new_z3proc_with_id uu___ in + let kill_handler uu___ = "\nkilled\n" in + let out = + FStarC_Compiler_Util.ask_process proc input kill_handler + (warn_handler []) in + let r1 = parse (FStarC_Compiler_Util.trim_string out) in + (log_result + (fun fname -> + fun s -> + let h = + FStarC_Compiler_Util.open_file_for_appending fname in + FStarC_Compiler_Util.append_to_file h s; + FStarC_Compiler_Util.close_out_channel h) r1; + FStarC_Compiler_Util.kill_process proc; + r1) + else + (let out = + let uu___1 = FStarC_Compiler_Effect.op_Bang bg_z3_proc in + uu___1.ask input in + let r1 = parse (FStarC_Compiler_Util.trim_string out) in + log_result + (fun _fname -> + fun s -> + let uu___2 = query_logging.append_to_log s in ()) r1; + r1) +let (z3_options : Prims.string -> Prims.string) = + fun ver -> + let opts = + ["(set-option :global-decls false)"; + "(set-option :smt.mbqi false)"; + "(set-option :auto_config false)"; + "(set-option :produce-unsat-cores true)"; + "(set-option :model true)"; + "(set-option :smt.case_split 3)"; + "(set-option :smt.relevancy 2)"] in + let opts1 = + let uu___ = + let uu___1 = FStarC_Compiler_Misc.version_ge ver "4.12.3" in + if uu___1 + then + ["(set-option :rewriter.enable_der false)"; + "(set-option :rewriter.sort_disjunctions false)"; + "(set-option :pi.decompose_patterns false)"; + "(set-option :smt.arith.solver 6)"] + else ["(set-option :smt.arith.solver 2)"] in + FStarC_Compiler_List.op_At opts uu___ in + Prims.strcat (FStarC_Compiler_String.concat "\n" opts1) "\n" +let (context_profile : FStarC_SMTEncoding_Term.decl Prims.list -> unit) = + fun theory -> + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun d -> + match uu___1 with + | (out, _total) -> + (match d with + | FStarC_SMTEncoding_Term.Module (name, decls) -> + let decls1 = + FStarC_Compiler_List.filter + (fun uu___2 -> + match uu___2 with + | FStarC_SMTEncoding_Term.Assume uu___3 -> true + | uu___3 -> false) decls in + let n = FStarC_Compiler_List.length decls1 in + (((name, n) :: out), (n + _total)) + | uu___2 -> (out, _total))) ([], Prims.int_zero) theory in + match uu___ with + | (modules, total_decls) -> + let modules1 = + FStarC_Compiler_List.sortWith + (fun uu___1 -> + fun uu___2 -> + match (uu___1, uu___2) with + | ((uu___3, n), (uu___4, m)) -> m - n) modules in + (if modules1 <> [] + then + (let uu___2 = FStarC_Compiler_Util.string_of_int total_decls in + FStarC_Compiler_Util.print1 + "Z3 Proof Stats: context_profile with %s assertions\n" uu___2) + else (); + FStarC_Compiler_List.iter + (fun uu___2 -> + match uu___2 with + | (m, n) -> + if n <> Prims.int_zero + then + let uu___3 = FStarC_Compiler_Util.string_of_int n in + FStarC_Compiler_Util.print2 + "Z3 Proof Stats: %s produced %s SMT decls\n" m uu___3 + else ()) modules1) +let (mk_input : + Prims.bool -> + FStarC_SMTEncoding_Term.decl Prims.list -> + (Prims.string * Prims.string FStar_Pervasives_Native.option * + Prims.string FStar_Pervasives_Native.option)) + = + fun fresh -> + fun theory -> + let ver = FStarC_Options.z3_version () in + let theory1 = + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Compiler_Effect.op_Bang FStarC_Options._version in + let uu___3 = + FStarC_Compiler_Effect.op_Bang FStarC_Options._commit in + FStarC_Compiler_Util.format3 + "Z3 invocation started by F*\nF* version: %s -- commit hash: %s\nZ3 version (according to F*): %s" + uu___2 uu___3 ver in + FStarC_SMTEncoding_Term.Caption uu___1 in + uu___ :: theory in + let options = z3_options ver in + let options1 = + let uu___ = + let uu___1 = + let uu___2 = FStarC_Options.z3_smtopt () in + FStarC_Compiler_String.concat "\n" uu___2 in + Prims.strcat uu___1 "\n\n" in + Prims.strcat options uu___ in + (let uu___1 = FStarC_Options.print_z3_statistics () in + if uu___1 then context_profile theory1 else ()); + (let uu___1 = + let uu___2 = + (FStarC_Options.record_hints ()) || + ((FStarC_Options.use_hints ()) && + (FStarC_Options.use_hint_hashes ())) in + if uu___2 + then + let uu___3 = + let uu___4 = + FStarC_Compiler_Util.prefix_until + (fun uu___5 -> + match uu___5 with + | FStarC_SMTEncoding_Term.CheckSat -> true + | uu___6 -> false) theory1 in + FStarC_Compiler_Option.get uu___4 in + match uu___3 with + | (prefix, check_sat, suffix) -> + let pp = + FStarC_Compiler_List.map + (FStarC_SMTEncoding_Term.declToSmt options1) in + let suffix1 = check_sat :: suffix in + let ps_lines = pp prefix in + let ss_lines = pp suffix1 in + let ps = FStarC_Compiler_String.concat "\n" ps_lines in + let ss = FStarC_Compiler_String.concat "\n" ss_lines in + let hs = + let uu___4 = FStarC_Options.keep_query_captions () in + if uu___4 + then + let uu___5 = + FStarC_Compiler_List.map + (FStarC_SMTEncoding_Term.declToSmt_no_caps options1) + prefix in + FStarC_Compiler_String.concat "\n" uu___5 + else ps in + let hs1 = Prims.strcat hs (Prims.strcat "Z3 version: " ver) in + let uu___4 = + let uu___5 = FStarC_Compiler_Util.digest_of_string hs1 in + FStar_Pervasives_Native.Some uu___5 in + ((Prims.strcat ps (Prims.strcat "\n" ss)), uu___4) + else + (let uu___4 = + let uu___5 = + FStarC_Compiler_List.map + (FStarC_SMTEncoding_Term.declToSmt options1) theory1 in + FStarC_Compiler_String.concat "\n" uu___5 in + (uu___4, FStar_Pervasives_Native.None)) in + match uu___1 with + | (r, hash) -> + let log_file_name = + let uu___2 = FStarC_Options.log_queries () in + if uu___2 + then + let uu___3 = query_logging.write_to_log fresh r in + FStar_Pervasives_Native.Some uu___3 + else FStar_Pervasives_Native.None in + (r, hash, log_file_name)) +let (cache_hit : + Prims.string FStar_Pervasives_Native.option -> + Prims.string FStar_Pervasives_Native.option -> + Prims.string FStar_Pervasives_Native.option -> + z3result FStar_Pervasives_Native.option) + = + fun log_file -> + fun cache -> + fun qhash -> + let uu___ = + (FStarC_Options.use_hints ()) && + (FStarC_Options.use_hint_hashes ()) in + if uu___ + then + match qhash with + | FStar_Pervasives_Native.Some x when qhash = cache -> + let stats = FStarC_Compiler_Util.smap_create Prims.int_zero in + (FStarC_Compiler_Util.smap_add stats "fstar_cache_hit" "1"; + (let result = + { + z3result_status = (UNSAT FStar_Pervasives_Native.None); + z3result_time = Prims.int_zero; + z3result_statistics = stats; + z3result_query_hash = qhash; + z3result_log_file = log_file + } in + FStar_Pervasives_Native.Some result)) + | uu___1 -> FStar_Pervasives_Native.None + else FStar_Pervasives_Native.None +let (z3_job : + Prims.string FStar_Pervasives_Native.option -> + FStarC_Compiler_Range_Type.range -> + Prims.bool -> + FStarC_SMTEncoding_Term.error_labels -> + Prims.string -> + Prims.string FStar_Pervasives_Native.option -> + Prims.string -> z3result) + = + fun log_file -> + fun r -> + fun fresh -> + fun label_messages -> + fun input -> + fun qhash -> + fun queryid -> + let uu___ = + let uu___1 = + let uu___2 = query_logging.get_module_name () in + FStar_Pervasives_Native.Some uu___2 in + FStarC_Profiling.profile + (fun uu___2 -> + try + (fun uu___3 -> + match () with + | () -> + FStarC_Compiler_Util.record_time + (fun uu___4 -> + doZ3Exe log_file r fresh input + label_messages queryid)) () + with + | uu___3 -> + (refresh FStar_Pervasives_Native.None; + FStarC_Compiler_Effect.raise uu___3)) uu___1 + "FStarC.SMTEncoding.Z3 (aggregate query time)" in + match uu___ with + | ((status, statistics), elapsed_time) -> + { + z3result_status = status; + z3result_time = elapsed_time; + z3result_statistics = statistics; + z3result_query_hash = qhash; + z3result_log_file = log_file + } +let (ask_text : + FStarC_Compiler_Range_Type.range -> + Prims.string FStar_Pervasives_Native.option -> + FStarC_SMTEncoding_Term.error_labels -> + FStarC_SMTEncoding_Term.decl Prims.list -> + Prims.string -> + FStarC_SMTEncoding_UnsatCore.unsat_core + FStar_Pervasives_Native.option -> Prims.string) + = + fun r -> + fun cache -> + fun label_messages -> + fun qry -> + fun queryid -> + fun core -> + let theory = + match core with + | FStar_Pervasives_Native.None -> + with_solver_state FStarC_SMTEncoding_SolverState.flush + | FStar_Pervasives_Native.Some core1 -> + reading_solver_state + (FStarC_SMTEncoding_SolverState.filter_with_unsat_core + queryid core1) in + let query_tail = + FStarC_Compiler_List.op_At + ((FStarC_SMTEncoding_Term.Push Prims.int_zero) :: qry) + [FStarC_SMTEncoding_Term.Pop Prims.int_zero] in + let theory1 = FStarC_Compiler_List.op_At theory query_tail in + let uu___ = mk_input true theory1 in + match uu___ with | (input, qhash, log_file_name) -> input +let (ask : + FStarC_Compiler_Range_Type.range -> + Prims.string FStar_Pervasives_Native.option -> + FStarC_SMTEncoding_Term.error_labels -> + FStarC_SMTEncoding_Term.decl Prims.list -> + Prims.string -> + Prims.bool -> + FStarC_SMTEncoding_UnsatCore.unsat_core + FStar_Pervasives_Native.option -> z3result) + = + fun r -> + fun cache -> + fun label_messages -> + fun qry -> + fun queryid -> + fun fresh -> + fun core -> + let theory = + match core with + | FStar_Pervasives_Native.None -> + with_solver_state FStarC_SMTEncoding_SolverState.flush + | FStar_Pervasives_Native.Some core1 -> + (if Prims.op_Negation fresh + then + failwith + "Unexpected: unsat core must only be used with fresh solvers" + else (); + reading_solver_state + (FStarC_SMTEncoding_SolverState.filter_with_unsat_core + queryid core1)) in + let theory1 = + FStarC_Compiler_List.op_At theory + (FStarC_Compiler_List.op_At + ((FStarC_SMTEncoding_Term.Push Prims.int_zero) :: qry) + [FStarC_SMTEncoding_Term.Pop Prims.int_zero]) in + let uu___ = mk_input fresh theory1 in + match uu___ with + | (input, qhash, log_file_name) -> + let just_ask uu___1 = + z3_job log_file_name r fresh label_messages input qhash + queryid in + let result = + if fresh + then + let uu___1 = cache_hit log_file_name cache qhash in + match uu___1 with + | FStar_Pervasives_Native.Some z3r -> z3r + | FStar_Pervasives_Native.None -> just_ask () + else just_ask () in + result \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Syntax_Compress.ml b/ocaml/fstar-lib/generated/FStarC_Syntax_Compress.ml new file mode 100644 index 00000000000..9decadf3e94 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Syntax_Compress.ml @@ -0,0 +1,170 @@ +open Prims +let (compress1_t : + Prims.bool -> + Prims.bool -> FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun allow_uvars -> + fun allow_names -> + fun t -> + let mk x = FStarC_Syntax_Syntax.mk x t.FStarC_Syntax_Syntax.pos in + match t.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_uvar (uv, s) when + Prims.op_Negation allow_uvars -> + let uu___ = + let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_ctxu uv in + FStarC_Compiler_Util.format1 + "Internal error: unexpected unresolved uvar in deep_compress: %s" + uu___1 in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Error_UnexpectedUnresolvedUvar () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___) + | FStarC_Syntax_Syntax.Tm_name bv when Prims.op_Negation allow_names + -> + ((let uu___1 = FStarC_Compiler_Debug.any () in + if uu___1 + then + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_bv bv in + FStarC_Compiler_Util.format1 "Tm_name %s in deep compress" + uu___3 in + FStarC_Errors.log_issue + (FStarC_Syntax_Syntax.has_range_syntax ()) t + FStarC_Errors_Codes.Warning_NameEscape () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2) + else ()); + (let uu___1 = + let uu___2 = + let uu___3 = mk FStarC_Syntax_Syntax.Tm_unknown in + { + FStarC_Syntax_Syntax.ppname = + (bv.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (bv.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = uu___3 + } in + FStarC_Syntax_Syntax.Tm_name uu___2 in + mk uu___1)) + | FStarC_Syntax_Syntax.Tm_bvar bv -> + let uu___ = + let uu___1 = + let uu___2 = mk FStarC_Syntax_Syntax.Tm_unknown in + { + FStarC_Syntax_Syntax.ppname = + (bv.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (bv.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = uu___2 + } in + FStarC_Syntax_Syntax.Tm_bvar uu___1 in + mk uu___ + | FStarC_Syntax_Syntax.Tm_name bv -> + let uu___ = + let uu___1 = + let uu___2 = mk FStarC_Syntax_Syntax.Tm_unknown in + { + FStarC_Syntax_Syntax.ppname = + (bv.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (bv.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = uu___2 + } in + FStarC_Syntax_Syntax.Tm_name uu___1 in + mk uu___ + | uu___ -> t +let (compress1_u : + Prims.bool -> + Prims.bool -> + FStarC_Syntax_Syntax.universe -> FStarC_Syntax_Syntax.universe) + = + fun allow_uvars -> + fun allow_names -> + fun u -> + match u with + | FStarC_Syntax_Syntax.U_name bv when Prims.op_Negation allow_names + -> + ((let uu___1 = FStarC_Compiler_Debug.any () in + if uu___1 + then + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Ident.showable_ident bv in + FStarC_Compiler_Util.format1 "U_name %s in deep compress" + uu___3 in + FStarC_Errors.log_issue0 + FStarC_Errors_Codes.Warning_NameEscape () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2) + else ()); + u) + | FStarC_Syntax_Syntax.U_unif uv when Prims.op_Negation allow_uvars + -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Syntax_Unionfind.univ_uvar_id uv in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) uu___2 in + FStarC_Compiler_Util.format1 + "Internal error: unexpected unresolved (universe) uvar in deep_compress: %s" + uu___1 in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Error_UnexpectedUnresolvedUvar () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___) + | uu___ -> u +let (deep_compress : + Prims.bool -> + Prims.bool -> FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun allow_uvars -> + fun allow_names -> + fun tm -> + FStarC_Errors.with_ctx "While deep-compressing a term" + (fun uu___ -> + let uu___1 = compress1_t allow_uvars allow_names in + let uu___2 = compress1_u allow_uvars allow_names in + FStarC_Syntax_Visit.visit_term_univs true uu___1 uu___2 tm) +let (deep_compress_uvars : + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) = + deep_compress false true +let (deep_compress_if_no_uvars : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = + fun tm -> + FStarC_Errors.with_ctx "While deep-compressing a term" + (fun uu___ -> + try + (fun uu___1 -> + match () with + | () -> + let uu___2 = + let uu___3 = compress1_t false true in + let uu___4 = compress1_u false true in + FStarC_Syntax_Visit.visit_term_univs true uu___3 uu___4 + tm in + FStar_Pervasives_Native.Some uu___2) () + with + | FStarC_Errors.Error + (FStarC_Errors_Codes.Error_UnexpectedUnresolvedUvar, uu___2, + uu___3, uu___4) + -> FStar_Pervasives_Native.None) +let (deep_compress_se : + Prims.bool -> + Prims.bool -> FStarC_Syntax_Syntax.sigelt -> FStarC_Syntax_Syntax.sigelt) + = + fun allow_uvars -> + fun allow_names -> + fun se -> + let uu___ = + let uu___1 = FStarC_Syntax_Print.sigelt_to_string_short se in + FStarC_Compiler_Util.format1 "While deep-compressing %s" uu___1 in + FStarC_Errors.with_ctx uu___ + (fun uu___1 -> + let uu___2 = compress1_t allow_uvars allow_names in + let uu___3 = compress1_u allow_uvars allow_names in + FStarC_Syntax_Visit.visit_sigelt true uu___2 uu___3 se) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Syntax_DsEnv.ml b/ocaml/fstar-lib/generated/FStarC_Syntax_DsEnv.ml new file mode 100644 index 00000000000..d8057311592 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Syntax_DsEnv.ml @@ -0,0 +1,4136 @@ +open Prims +let (ugly_sigelt_to_string_hook : + (FStarC_Syntax_Syntax.sigelt -> Prims.string) FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref (fun uu___ -> "") +type used_marker = Prims.bool FStarC_Compiler_Effect.ref +type record_or_dc = + { + typename: FStarC_Ident.lident ; + constrname: FStarC_Ident.ident ; + parms: FStarC_Syntax_Syntax.binders ; + fields: (FStarC_Ident.ident * FStarC_Syntax_Syntax.typ) Prims.list ; + is_private: Prims.bool ; + is_record: Prims.bool } +let (__proj__Mkrecord_or_dc__item__typename : + record_or_dc -> FStarC_Ident.lident) = + fun projectee -> + match projectee with + | { typename; constrname; parms; fields; is_private; is_record;_} -> + typename +let (__proj__Mkrecord_or_dc__item__constrname : + record_or_dc -> FStarC_Ident.ident) = + fun projectee -> + match projectee with + | { typename; constrname; parms; fields; is_private; is_record;_} -> + constrname +let (__proj__Mkrecord_or_dc__item__parms : + record_or_dc -> FStarC_Syntax_Syntax.binders) = + fun projectee -> + match projectee with + | { typename; constrname; parms; fields; is_private; is_record;_} -> + parms +let (__proj__Mkrecord_or_dc__item__fields : + record_or_dc -> (FStarC_Ident.ident * FStarC_Syntax_Syntax.typ) Prims.list) + = + fun projectee -> + match projectee with + | { typename; constrname; parms; fields; is_private; is_record;_} -> + fields +let (__proj__Mkrecord_or_dc__item__is_private : record_or_dc -> Prims.bool) = + fun projectee -> + match projectee with + | { typename; constrname; parms; fields; is_private; is_record;_} -> + is_private +let (__proj__Mkrecord_or_dc__item__is_record : record_or_dc -> Prims.bool) = + fun projectee -> + match projectee with + | { typename; constrname; parms; fields; is_private; is_record;_} -> + is_record +let (ugly_sigelt_to_string : FStarC_Syntax_Syntax.sigelt -> Prims.string) = + fun se -> + let uu___ = FStarC_Compiler_Effect.op_Bang ugly_sigelt_to_string_hook in + uu___ se +type local_binding = + (FStarC_Ident.ident * FStarC_Syntax_Syntax.bv * used_marker) +type rec_binding = (FStarC_Ident.ident * FStarC_Ident.lid * used_marker) +type scope_mod = + | Local_binding of local_binding + | Rec_binding of rec_binding + | Module_abbrev of FStarC_Syntax_Syntax.module_abbrev + | Open_module_or_namespace of FStarC_Syntax_Syntax.open_module_or_namespace + + | Top_level_def of FStarC_Ident.ident + | Record_or_dc of record_or_dc +let (uu___is_Local_binding : scope_mod -> Prims.bool) = + fun projectee -> + match projectee with | Local_binding _0 -> true | uu___ -> false +let (__proj__Local_binding__item___0 : scope_mod -> local_binding) = + fun projectee -> match projectee with | Local_binding _0 -> _0 +let (uu___is_Rec_binding : scope_mod -> Prims.bool) = + fun projectee -> + match projectee with | Rec_binding _0 -> true | uu___ -> false +let (__proj__Rec_binding__item___0 : scope_mod -> rec_binding) = + fun projectee -> match projectee with | Rec_binding _0 -> _0 +let (uu___is_Module_abbrev : scope_mod -> Prims.bool) = + fun projectee -> + match projectee with | Module_abbrev _0 -> true | uu___ -> false +let (__proj__Module_abbrev__item___0 : + scope_mod -> FStarC_Syntax_Syntax.module_abbrev) = + fun projectee -> match projectee with | Module_abbrev _0 -> _0 +let (uu___is_Open_module_or_namespace : scope_mod -> Prims.bool) = + fun projectee -> + match projectee with + | Open_module_or_namespace _0 -> true + | uu___ -> false +let (__proj__Open_module_or_namespace__item___0 : + scope_mod -> FStarC_Syntax_Syntax.open_module_or_namespace) = + fun projectee -> match projectee with | Open_module_or_namespace _0 -> _0 +let (uu___is_Top_level_def : scope_mod -> Prims.bool) = + fun projectee -> + match projectee with | Top_level_def _0 -> true | uu___ -> false +let (__proj__Top_level_def__item___0 : scope_mod -> FStarC_Ident.ident) = + fun projectee -> match projectee with | Top_level_def _0 -> _0 +let (uu___is_Record_or_dc : scope_mod -> Prims.bool) = + fun projectee -> + match projectee with | Record_or_dc _0 -> true | uu___ -> false +let (__proj__Record_or_dc__item___0 : scope_mod -> record_or_dc) = + fun projectee -> match projectee with | Record_or_dc _0 -> _0 +type string_set = Prims.string FStarC_Compiler_RBSet.t +type exported_id_kind = + | Exported_id_term_type + | Exported_id_field +let (uu___is_Exported_id_term_type : exported_id_kind -> Prims.bool) = + fun projectee -> + match projectee with | Exported_id_term_type -> true | uu___ -> false +let (uu___is_Exported_id_field : exported_id_kind -> Prims.bool) = + fun projectee -> + match projectee with | Exported_id_field -> true | uu___ -> false +type exported_id_set = + exported_id_kind -> string_set FStarC_Compiler_Effect.ref +type env = + { + curmodule: FStarC_Ident.lident FStar_Pervasives_Native.option ; + curmonad: FStarC_Ident.ident FStar_Pervasives_Native.option ; + modules: (FStarC_Ident.lident * FStarC_Syntax_Syntax.modul) Prims.list ; + scope_mods: scope_mod Prims.list ; + exported_ids: exported_id_set FStarC_Compiler_Util.smap ; + trans_exported_ids: exported_id_set FStarC_Compiler_Util.smap ; + includes: + (FStarC_Ident.lident * FStarC_Syntax_Syntax.restriction) Prims.list + FStarC_Compiler_Effect.ref FStarC_Compiler_Util.smap + ; + sigaccum: FStarC_Syntax_Syntax.sigelts ; + sigmap: + (FStarC_Syntax_Syntax.sigelt * Prims.bool) FStarC_Compiler_Util.smap ; + iface: Prims.bool ; + admitted_iface: Prims.bool ; + expect_typ: Prims.bool ; + remaining_iface_decls: + (FStarC_Ident.lident * FStarC_Parser_AST.decl Prims.list) Prims.list ; + syntax_only: Prims.bool ; + ds_hooks: dsenv_hooks ; + dep_graph: FStarC_Parser_Dep.deps } +and dsenv_hooks = + { + ds_push_open_hook: + env -> FStarC_Syntax_Syntax.open_module_or_namespace -> unit ; + ds_push_include_hook: env -> FStarC_Ident.lident -> unit ; + ds_push_module_abbrev_hook: + env -> FStarC_Ident.ident -> FStarC_Ident.lident -> unit } +let (__proj__Mkenv__item__curmodule : + env -> FStarC_Ident.lident FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { curmodule; curmonad; modules; scope_mods; exported_ids; + trans_exported_ids; includes; sigaccum; sigmap; iface; + admitted_iface; expect_typ; remaining_iface_decls; syntax_only; + ds_hooks; dep_graph;_} -> curmodule +let (__proj__Mkenv__item__curmonad : + env -> FStarC_Ident.ident FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { curmodule; curmonad; modules; scope_mods; exported_ids; + trans_exported_ids; includes; sigaccum; sigmap; iface; + admitted_iface; expect_typ; remaining_iface_decls; syntax_only; + ds_hooks; dep_graph;_} -> curmonad +let (__proj__Mkenv__item__modules : + env -> (FStarC_Ident.lident * FStarC_Syntax_Syntax.modul) Prims.list) = + fun projectee -> + match projectee with + | { curmodule; curmonad; modules; scope_mods; exported_ids; + trans_exported_ids; includes; sigaccum; sigmap; iface; + admitted_iface; expect_typ; remaining_iface_decls; syntax_only; + ds_hooks; dep_graph;_} -> modules +let (__proj__Mkenv__item__scope_mods : env -> scope_mod Prims.list) = + fun projectee -> + match projectee with + | { curmodule; curmonad; modules; scope_mods; exported_ids; + trans_exported_ids; includes; sigaccum; sigmap; iface; + admitted_iface; expect_typ; remaining_iface_decls; syntax_only; + ds_hooks; dep_graph;_} -> scope_mods +let (__proj__Mkenv__item__exported_ids : + env -> exported_id_set FStarC_Compiler_Util.smap) = + fun projectee -> + match projectee with + | { curmodule; curmonad; modules; scope_mods; exported_ids; + trans_exported_ids; includes; sigaccum; sigmap; iface; + admitted_iface; expect_typ; remaining_iface_decls; syntax_only; + ds_hooks; dep_graph;_} -> exported_ids +let (__proj__Mkenv__item__trans_exported_ids : + env -> exported_id_set FStarC_Compiler_Util.smap) = + fun projectee -> + match projectee with + | { curmodule; curmonad; modules; scope_mods; exported_ids; + trans_exported_ids; includes; sigaccum; sigmap; iface; + admitted_iface; expect_typ; remaining_iface_decls; syntax_only; + ds_hooks; dep_graph;_} -> trans_exported_ids +let (__proj__Mkenv__item__includes : + env -> + (FStarC_Ident.lident * FStarC_Syntax_Syntax.restriction) Prims.list + FStarC_Compiler_Effect.ref FStarC_Compiler_Util.smap) + = + fun projectee -> + match projectee with + | { curmodule; curmonad; modules; scope_mods; exported_ids; + trans_exported_ids; includes; sigaccum; sigmap; iface; + admitted_iface; expect_typ; remaining_iface_decls; syntax_only; + ds_hooks; dep_graph;_} -> includes +let (__proj__Mkenv__item__sigaccum : env -> FStarC_Syntax_Syntax.sigelts) = + fun projectee -> + match projectee with + | { curmodule; curmonad; modules; scope_mods; exported_ids; + trans_exported_ids; includes; sigaccum; sigmap; iface; + admitted_iface; expect_typ; remaining_iface_decls; syntax_only; + ds_hooks; dep_graph;_} -> sigaccum +let (__proj__Mkenv__item__sigmap : + env -> (FStarC_Syntax_Syntax.sigelt * Prims.bool) FStarC_Compiler_Util.smap) + = + fun projectee -> + match projectee with + | { curmodule; curmonad; modules; scope_mods; exported_ids; + trans_exported_ids; includes; sigaccum; sigmap; iface; + admitted_iface; expect_typ; remaining_iface_decls; syntax_only; + ds_hooks; dep_graph;_} -> sigmap +let (__proj__Mkenv__item__iface : env -> Prims.bool) = + fun projectee -> + match projectee with + | { curmodule; curmonad; modules; scope_mods; exported_ids; + trans_exported_ids; includes; sigaccum; sigmap; iface; + admitted_iface; expect_typ; remaining_iface_decls; syntax_only; + ds_hooks; dep_graph;_} -> iface +let (__proj__Mkenv__item__admitted_iface : env -> Prims.bool) = + fun projectee -> + match projectee with + | { curmodule; curmonad; modules; scope_mods; exported_ids; + trans_exported_ids; includes; sigaccum; sigmap; iface; + admitted_iface; expect_typ; remaining_iface_decls; syntax_only; + ds_hooks; dep_graph;_} -> admitted_iface +let (__proj__Mkenv__item__expect_typ : env -> Prims.bool) = + fun projectee -> + match projectee with + | { curmodule; curmonad; modules; scope_mods; exported_ids; + trans_exported_ids; includes; sigaccum; sigmap; iface; + admitted_iface; expect_typ; remaining_iface_decls; syntax_only; + ds_hooks; dep_graph;_} -> expect_typ +let (__proj__Mkenv__item__remaining_iface_decls : + env -> (FStarC_Ident.lident * FStarC_Parser_AST.decl Prims.list) Prims.list) + = + fun projectee -> + match projectee with + | { curmodule; curmonad; modules; scope_mods; exported_ids; + trans_exported_ids; includes; sigaccum; sigmap; iface; + admitted_iface; expect_typ; remaining_iface_decls; syntax_only; + ds_hooks; dep_graph;_} -> remaining_iface_decls +let (__proj__Mkenv__item__syntax_only : env -> Prims.bool) = + fun projectee -> + match projectee with + | { curmodule; curmonad; modules; scope_mods; exported_ids; + trans_exported_ids; includes; sigaccum; sigmap; iface; + admitted_iface; expect_typ; remaining_iface_decls; syntax_only; + ds_hooks; dep_graph;_} -> syntax_only +let (__proj__Mkenv__item__ds_hooks : env -> dsenv_hooks) = + fun projectee -> + match projectee with + | { curmodule; curmonad; modules; scope_mods; exported_ids; + trans_exported_ids; includes; sigaccum; sigmap; iface; + admitted_iface; expect_typ; remaining_iface_decls; syntax_only; + ds_hooks; dep_graph;_} -> ds_hooks +let (__proj__Mkenv__item__dep_graph : env -> FStarC_Parser_Dep.deps) = + fun projectee -> + match projectee with + | { curmodule; curmonad; modules; scope_mods; exported_ids; + trans_exported_ids; includes; sigaccum; sigmap; iface; + admitted_iface; expect_typ; remaining_iface_decls; syntax_only; + ds_hooks; dep_graph;_} -> dep_graph +let (__proj__Mkdsenv_hooks__item__ds_push_open_hook : + dsenv_hooks -> env -> FStarC_Syntax_Syntax.open_module_or_namespace -> unit) + = + fun projectee -> + match projectee with + | { ds_push_open_hook; ds_push_include_hook; + ds_push_module_abbrev_hook;_} -> ds_push_open_hook +let (__proj__Mkdsenv_hooks__item__ds_push_include_hook : + dsenv_hooks -> env -> FStarC_Ident.lident -> unit) = + fun projectee -> + match projectee with + | { ds_push_open_hook; ds_push_include_hook; + ds_push_module_abbrev_hook;_} -> ds_push_include_hook +let (__proj__Mkdsenv_hooks__item__ds_push_module_abbrev_hook : + dsenv_hooks -> env -> FStarC_Ident.ident -> FStarC_Ident.lident -> unit) = + fun projectee -> + match projectee with + | { ds_push_open_hook; ds_push_include_hook; + ds_push_module_abbrev_hook;_} -> ds_push_module_abbrev_hook +let (mk_dsenv_hooks : + (env -> FStarC_Syntax_Syntax.open_module_or_namespace -> unit) -> + (env -> FStarC_Ident.lident -> unit) -> + (env -> FStarC_Ident.ident -> FStarC_Ident.lident -> unit) -> + dsenv_hooks) + = + fun open_hook -> + fun include_hook -> + fun module_abbrev_hook -> + { + ds_push_open_hook = open_hook; + ds_push_include_hook = include_hook; + ds_push_module_abbrev_hook = module_abbrev_hook + } +type 'a withenv = env -> ('a * env) +type foundname = + | Term_name of (FStarC_Syntax_Syntax.typ * FStarC_Syntax_Syntax.attribute + Prims.list) + | Eff_name of (FStarC_Syntax_Syntax.sigelt * FStarC_Ident.lident) +let (uu___is_Term_name : foundname -> Prims.bool) = + fun projectee -> + match projectee with | Term_name _0 -> true | uu___ -> false +let (__proj__Term_name__item___0 : + foundname -> + (FStarC_Syntax_Syntax.typ * FStarC_Syntax_Syntax.attribute Prims.list)) + = fun projectee -> match projectee with | Term_name _0 -> _0 +let (uu___is_Eff_name : foundname -> Prims.bool) = + fun projectee -> + match projectee with | Eff_name _0 -> true | uu___ -> false +let (__proj__Eff_name__item___0 : + foundname -> (FStarC_Syntax_Syntax.sigelt * FStarC_Ident.lident)) = + fun projectee -> match projectee with | Eff_name _0 -> _0 +let (default_ds_hooks : dsenv_hooks) = + { + ds_push_open_hook = (fun uu___ -> fun uu___1 -> ()); + ds_push_include_hook = (fun uu___ -> fun uu___1 -> ()); + ds_push_module_abbrev_hook = + (fun uu___ -> fun uu___1 -> fun uu___2 -> ()) + } +let (set_iface : env -> Prims.bool -> env) = + fun env1 -> + fun b -> + { + curmodule = (env1.curmodule); + curmonad = (env1.curmonad); + modules = (env1.modules); + scope_mods = (env1.scope_mods); + exported_ids = (env1.exported_ids); + trans_exported_ids = (env1.trans_exported_ids); + includes = (env1.includes); + sigaccum = (env1.sigaccum); + sigmap = (env1.sigmap); + iface = b; + admitted_iface = (env1.admitted_iface); + expect_typ = (env1.expect_typ); + remaining_iface_decls = (env1.remaining_iface_decls); + syntax_only = (env1.syntax_only); + ds_hooks = (env1.ds_hooks); + dep_graph = (env1.dep_graph) + } +let (iface : env -> Prims.bool) = fun e -> e.iface +let (set_admitted_iface : env -> Prims.bool -> env) = + fun e -> + fun b -> + { + curmodule = (e.curmodule); + curmonad = (e.curmonad); + modules = (e.modules); + scope_mods = (e.scope_mods); + exported_ids = (e.exported_ids); + trans_exported_ids = (e.trans_exported_ids); + includes = (e.includes); + sigaccum = (e.sigaccum); + sigmap = (e.sigmap); + iface = (e.iface); + admitted_iface = b; + expect_typ = (e.expect_typ); + remaining_iface_decls = (e.remaining_iface_decls); + syntax_only = (e.syntax_only); + ds_hooks = (e.ds_hooks); + dep_graph = (e.dep_graph) + } +let (admitted_iface : env -> Prims.bool) = fun e -> e.admitted_iface +let (set_expect_typ : env -> Prims.bool -> env) = + fun e -> + fun b -> + { + curmodule = (e.curmodule); + curmonad = (e.curmonad); + modules = (e.modules); + scope_mods = (e.scope_mods); + exported_ids = (e.exported_ids); + trans_exported_ids = (e.trans_exported_ids); + includes = (e.includes); + sigaccum = (e.sigaccum); + sigmap = (e.sigmap); + iface = (e.iface); + admitted_iface = (e.admitted_iface); + expect_typ = b; + remaining_iface_decls = (e.remaining_iface_decls); + syntax_only = (e.syntax_only); + ds_hooks = (e.ds_hooks); + dep_graph = (e.dep_graph) + } +let (expect_typ : env -> Prims.bool) = fun e -> e.expect_typ +let (all_exported_id_kinds : exported_id_kind Prims.list) = + [Exported_id_field; Exported_id_term_type] +let (transitive_exported_ids : + env -> FStarC_Ident.lident -> Prims.string Prims.list) = + fun env1 -> + fun lid -> + let module_name = FStarC_Ident.string_of_lid lid in + let uu___ = + FStarC_Compiler_Util.smap_try_find env1.trans_exported_ids + module_name in + match uu___ with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some exported_id_set1 -> + let uu___1 = + let uu___2 = exported_id_set1 Exported_id_term_type in + FStarC_Compiler_Effect.op_Bang uu___2 in + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) (Obj.magic uu___1) +let (opens_and_abbrevs : + env -> + (FStarC_Syntax_Syntax.open_module_or_namespace, + FStarC_Syntax_Syntax.module_abbrev) FStar_Pervasives.either Prims.list) + = + fun env1 -> + FStarC_Compiler_List.collect + (fun uu___ -> + match uu___ with + | Open_module_or_namespace payload -> [FStar_Pervasives.Inl payload] + | Module_abbrev (id, lid) -> [FStar_Pervasives.Inr (id, lid)] + | uu___1 -> []) env1.scope_mods +let (open_modules : + env -> (FStarC_Ident.lident * FStarC_Syntax_Syntax.modul) Prims.list) = + fun e -> e.modules +let (open_modules_and_namespaces : env -> FStarC_Ident.lident Prims.list) = + fun env1 -> + FStarC_Compiler_List.filter_map + (fun uu___ -> + match uu___ with + | Open_module_or_namespace (lid, _info, _restriction) -> + FStar_Pervasives_Native.Some lid + | uu___1 -> FStar_Pervasives_Native.None) env1.scope_mods +let (module_abbrevs : + env -> (FStarC_Ident.ident * FStarC_Ident.lident) Prims.list) = + fun env1 -> + FStarC_Compiler_List.filter_map + (fun uu___ -> + match uu___ with + | Module_abbrev (l, m) -> FStar_Pervasives_Native.Some (l, m) + | uu___1 -> FStar_Pervasives_Native.None) env1.scope_mods +let (set_current_module : env -> FStarC_Ident.lident -> env) = + fun e -> + fun l -> + { + curmodule = (FStar_Pervasives_Native.Some l); + curmonad = (e.curmonad); + modules = (e.modules); + scope_mods = (e.scope_mods); + exported_ids = (e.exported_ids); + trans_exported_ids = (e.trans_exported_ids); + includes = (e.includes); + sigaccum = (e.sigaccum); + sigmap = (e.sigmap); + iface = (e.iface); + admitted_iface = (e.admitted_iface); + expect_typ = (e.expect_typ); + remaining_iface_decls = (e.remaining_iface_decls); + syntax_only = (e.syntax_only); + ds_hooks = (e.ds_hooks); + dep_graph = (e.dep_graph) + } +let (current_module : env -> FStarC_Ident.lident) = + fun env1 -> + match env1.curmodule with + | FStar_Pervasives_Native.None -> failwith "Unset current module" + | FStar_Pervasives_Native.Some m -> m +let (iface_decls : + env -> + FStarC_Ident.lident -> + FStarC_Parser_AST.decl Prims.list FStar_Pervasives_Native.option) + = + fun env1 -> + fun l -> + let uu___ = + FStarC_Compiler_List.tryFind + (fun uu___1 -> + match uu___1 with | (m, uu___2) -> FStarC_Ident.lid_equals l m) + env1.remaining_iface_decls in + match uu___ with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (uu___1, decls) -> + FStar_Pervasives_Native.Some decls +let (set_iface_decls : + env -> FStarC_Ident.lident -> FStarC_Parser_AST.decl Prims.list -> env) = + fun env1 -> + fun l -> + fun ds -> + let uu___ = + FStarC_Compiler_List.partition + (fun uu___1 -> + match uu___1 with | (m, uu___2) -> FStarC_Ident.lid_equals l m) + env1.remaining_iface_decls in + match uu___ with + | (uu___1, rest) -> + { + curmodule = (env1.curmodule); + curmonad = (env1.curmonad); + modules = (env1.modules); + scope_mods = (env1.scope_mods); + exported_ids = (env1.exported_ids); + trans_exported_ids = (env1.trans_exported_ids); + includes = (env1.includes); + sigaccum = (env1.sigaccum); + sigmap = (env1.sigmap); + iface = (env1.iface); + admitted_iface = (env1.admitted_iface); + expect_typ = (env1.expect_typ); + remaining_iface_decls = ((l, ds) :: rest); + syntax_only = (env1.syntax_only); + ds_hooks = (env1.ds_hooks); + dep_graph = (env1.dep_graph) + } +let (qual : FStarC_Ident.lident -> FStarC_Ident.ident -> FStarC_Ident.lident) + = FStarC_Ident.qual_id +let (qualify : env -> FStarC_Ident.ident -> FStarC_Ident.lident) = + fun env1 -> + fun id -> + match env1.curmonad with + | FStar_Pervasives_Native.None -> + let uu___ = current_module env1 in qual uu___ id + | FStar_Pervasives_Native.Some monad -> + let uu___ = let uu___1 = current_module env1 in qual uu___1 monad in + FStarC_Syntax_Util.mk_field_projector_name_from_ident uu___ id +let (syntax_only : env -> Prims.bool) = fun env1 -> env1.syntax_only +let (set_syntax_only : env -> Prims.bool -> env) = + fun env1 -> + fun b -> + { + curmodule = (env1.curmodule); + curmonad = (env1.curmonad); + modules = (env1.modules); + scope_mods = (env1.scope_mods); + exported_ids = (env1.exported_ids); + trans_exported_ids = (env1.trans_exported_ids); + includes = (env1.includes); + sigaccum = (env1.sigaccum); + sigmap = (env1.sigmap); + iface = (env1.iface); + admitted_iface = (env1.admitted_iface); + expect_typ = (env1.expect_typ); + remaining_iface_decls = (env1.remaining_iface_decls); + syntax_only = b; + ds_hooks = (env1.ds_hooks); + dep_graph = (env1.dep_graph) + } +let (ds_hooks : env -> dsenv_hooks) = fun env1 -> env1.ds_hooks +let (set_ds_hooks : env -> dsenv_hooks -> env) = + fun env1 -> + fun hooks -> + { + curmodule = (env1.curmodule); + curmonad = (env1.curmonad); + modules = (env1.modules); + scope_mods = (env1.scope_mods); + exported_ids = (env1.exported_ids); + trans_exported_ids = (env1.trans_exported_ids); + includes = (env1.includes); + sigaccum = (env1.sigaccum); + sigmap = (env1.sigmap); + iface = (env1.iface); + admitted_iface = (env1.admitted_iface); + expect_typ = (env1.expect_typ); + remaining_iface_decls = (env1.remaining_iface_decls); + syntax_only = (env1.syntax_only); + ds_hooks = hooks; + dep_graph = (env1.dep_graph) + } +let new_sigmap : 'uuuuu . unit -> 'uuuuu FStarC_Compiler_Util.smap = + fun uu___ -> FStarC_Compiler_Util.smap_create (Prims.of_int (100)) +let (empty_env : FStarC_Parser_Dep.deps -> env) = + fun deps -> + let uu___ = new_sigmap () in + let uu___1 = new_sigmap () in + let uu___2 = new_sigmap () in + let uu___3 = new_sigmap () in + { + curmodule = FStar_Pervasives_Native.None; + curmonad = FStar_Pervasives_Native.None; + modules = []; + scope_mods = []; + exported_ids = uu___; + trans_exported_ids = uu___1; + includes = uu___2; + sigaccum = []; + sigmap = uu___3; + iface = false; + admitted_iface = false; + expect_typ = false; + remaining_iface_decls = []; + syntax_only = false; + ds_hooks = default_ds_hooks; + dep_graph = deps + } +let (dep_graph : env -> FStarC_Parser_Dep.deps) = fun env1 -> env1.dep_graph +let (set_dep_graph : env -> FStarC_Parser_Dep.deps -> env) = + fun env1 -> + fun ds -> + { + curmodule = (env1.curmodule); + curmonad = (env1.curmonad); + modules = (env1.modules); + scope_mods = (env1.scope_mods); + exported_ids = (env1.exported_ids); + trans_exported_ids = (env1.trans_exported_ids); + includes = (env1.includes); + sigaccum = (env1.sigaccum); + sigmap = (env1.sigmap); + iface = (env1.iface); + admitted_iface = (env1.admitted_iface); + expect_typ = (env1.expect_typ); + remaining_iface_decls = (env1.remaining_iface_decls); + syntax_only = (env1.syntax_only); + ds_hooks = (env1.ds_hooks); + dep_graph = ds + } +let (sigmap : + env -> (FStarC_Syntax_Syntax.sigelt * Prims.bool) FStarC_Compiler_Util.smap) + = fun env1 -> env1.sigmap +let (set_bv_range : + FStarC_Syntax_Syntax.bv -> + FStarC_Compiler_Range_Type.range -> FStarC_Syntax_Syntax.bv) + = + fun bv -> + fun r -> + let id = FStarC_Ident.set_id_range r bv.FStarC_Syntax_Syntax.ppname in + { + FStarC_Syntax_Syntax.ppname = id; + FStarC_Syntax_Syntax.index = (bv.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = (bv.FStarC_Syntax_Syntax.sort) + } +let (bv_to_name : + FStarC_Syntax_Syntax.bv -> + FStarC_Compiler_Range_Type.range -> FStarC_Syntax_Syntax.term) + = + fun bv -> + fun r -> + let uu___ = set_bv_range bv r in FStarC_Syntax_Syntax.bv_to_name uu___ +let (unmangleMap : + (Prims.string * Prims.string * FStarC_Syntax_Syntax.fv_qual + FStar_Pervasives_Native.option) Prims.list) + = + [("op_ColonColon", "Cons", + (FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.Data_ctor)); + ("not", "op_Negation", FStar_Pervasives_Native.None)] +let (unmangleOpName : + FStarC_Ident.ident -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = + fun id -> + FStarC_Compiler_Util.find_map unmangleMap + (fun uu___ -> + match uu___ with + | (x, y, dq) -> + let uu___1 = + let uu___2 = FStarC_Ident.string_of_id id in uu___2 = x in + if uu___1 + then + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Ident.range_of_id id in + FStarC_Ident.lid_of_path ["Prims"; y] uu___4 in + FStarC_Syntax_Syntax.fvar_with_dd uu___3 dq in + FStar_Pervasives_Native.Some uu___2 + else FStar_Pervasives_Native.None) +type 'a cont_t = + | Cont_ok of 'a + | Cont_fail + | Cont_ignore +let uu___is_Cont_ok : 'a . 'a cont_t -> Prims.bool = + fun projectee -> match projectee with | Cont_ok _0 -> true | uu___ -> false +let __proj__Cont_ok__item___0 : 'a . 'a cont_t -> 'a = + fun projectee -> match projectee with | Cont_ok _0 -> _0 +let uu___is_Cont_fail : 'a . 'a cont_t -> Prims.bool = + fun projectee -> match projectee with | Cont_fail -> true | uu___ -> false +let uu___is_Cont_ignore : 'a . 'a cont_t -> Prims.bool = + fun projectee -> + match projectee with | Cont_ignore -> true | uu___ -> false +let option_of_cont : + 'a . + (unit -> 'a FStar_Pervasives_Native.option) -> + 'a cont_t -> 'a FStar_Pervasives_Native.option + = + fun k_ignore -> + fun uu___ -> + match uu___ with + | Cont_ok a1 -> FStar_Pervasives_Native.Some a1 + | Cont_fail -> FStar_Pervasives_Native.None + | Cont_ignore -> k_ignore () +let find_in_record : + 'uuuuu . + FStarC_Ident.ident Prims.list -> + FStarC_Ident.ident -> + record_or_dc -> (record_or_dc -> 'uuuuu cont_t) -> 'uuuuu cont_t + = + fun ns -> + fun id -> + fun record -> + fun cont -> + let typename' = + let uu___ = + let uu___1 = + let uu___2 = FStarC_Ident.ident_of_lid record.typename in + [uu___2] in + FStarC_Compiler_List.op_At ns uu___1 in + FStarC_Ident.lid_of_ids uu___ in + let uu___ = FStarC_Ident.lid_equals typename' record.typename in + if uu___ + then + let fname = + let uu___1 = + let uu___2 = FStarC_Ident.ns_of_lid record.typename in + FStarC_Compiler_List.op_At uu___2 [id] in + FStarC_Ident.lid_of_ids uu___1 in + let find = + FStarC_Compiler_Util.find_map record.fields + (fun uu___1 -> + match uu___1 with + | (f, uu___2) -> + let uu___3 = + let uu___4 = FStarC_Ident.string_of_id id in + let uu___5 = FStarC_Ident.string_of_id f in + uu___4 = uu___5 in + if uu___3 + then FStar_Pervasives_Native.Some record + else FStar_Pervasives_Native.None) in + match find with + | FStar_Pervasives_Native.Some r -> cont r + | FStar_Pervasives_Native.None -> Cont_ignore + else Cont_ignore +let (get_exported_id_set : + env -> + Prims.string -> + (exported_id_kind -> string_set FStarC_Compiler_Effect.ref) + FStar_Pervasives_Native.option) + = + fun e -> + fun mname -> FStarC_Compiler_Util.smap_try_find e.exported_ids mname +let (get_trans_exported_id_set : + env -> + Prims.string -> + (exported_id_kind -> string_set FStarC_Compiler_Effect.ref) + FStar_Pervasives_Native.option) + = + fun e -> + fun mname -> + FStarC_Compiler_Util.smap_try_find e.trans_exported_ids mname +let (string_of_exported_id_kind : exported_id_kind -> Prims.string) = + fun uu___ -> + match uu___ with + | Exported_id_field -> "field" + | Exported_id_term_type -> "term/type" +let (is_exported_id_termtype : exported_id_kind -> Prims.bool) = + fun uu___ -> + match uu___ with | Exported_id_term_type -> true | uu___1 -> false +let (is_exported_id_field : exported_id_kind -> Prims.bool) = + fun uu___ -> match uu___ with | Exported_id_field -> true | uu___1 -> false +let find_in_module_with_includes : + 'a . + exported_id_kind -> + (FStarC_Ident.lident -> 'a cont_t) -> + 'a cont_t -> + env -> FStarC_Ident.lident -> FStarC_Ident.ident -> 'a cont_t + = + fun eikind -> + fun find_in_module -> + fun find_in_module_default -> + fun env1 -> + fun ns -> + fun id -> + let rec aux uu___ = + match uu___ with + | [] -> find_in_module_default + | (modul, id1)::q -> + let mname = FStarC_Ident.string_of_lid modul in + let not_shadowed = + let uu___1 = get_exported_id_set env1 mname in + match uu___1 with + | FStar_Pervasives_Native.None -> true + | FStar_Pervasives_Native.Some mex -> + let mexports = + let uu___2 = mex eikind in + FStarC_Compiler_Effect.op_Bang uu___2 in + let uu___2 = FStarC_Ident.string_of_id id1 in + FStarC_Class_Setlike.mem () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) uu___2 + (Obj.magic mexports) in + let mincludes = + let uu___1 = + FStarC_Compiler_Util.smap_try_find env1.includes + mname in + match uu___1 with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some minc -> + let uu___2 = FStarC_Compiler_Effect.op_Bang minc in + FStarC_Compiler_List.filter_map + (fun uu___3 -> + match uu___3 with + | (ns1, restriction) -> + let opt = + FStarC_Syntax_Syntax.is_ident_allowed_by_restriction + id1 restriction in + FStarC_Compiler_Util.map_opt opt + (fun id2 -> (ns1, id2))) uu___2 in + let look_into = + if not_shadowed + then + let uu___1 = qual modul id1 in find_in_module uu___1 + else Cont_ignore in + (match look_into with + | Cont_ignore -> + aux (FStarC_Compiler_List.op_At mincludes q) + | uu___1 -> look_into) in + aux [(ns, id)] +let try_lookup_id'' : + 'a . + env -> + FStarC_Ident.ident -> + exported_id_kind -> + (local_binding -> 'a cont_t) -> + (rec_binding -> 'a cont_t) -> + (record_or_dc -> 'a cont_t) -> + (FStarC_Ident.lident -> 'a cont_t) -> + ('a cont_t -> FStarC_Ident.ident -> 'a cont_t) -> + 'a FStar_Pervasives_Native.option + = + fun env1 -> + fun id -> + fun eikind -> + fun k_local_binding -> + fun k_rec_binding -> + fun k_record -> + fun find_in_module -> + fun lookup_default_id -> + let check_local_binding_id uu___ = + match uu___ with + | (id', uu___1, uu___2) -> + let uu___3 = FStarC_Ident.string_of_id id' in + let uu___4 = FStarC_Ident.string_of_id id in + uu___3 = uu___4 in + let check_rec_binding_id uu___ = + match uu___ with + | (id', uu___1, uu___2) -> + let uu___3 = FStarC_Ident.string_of_id id' in + let uu___4 = FStarC_Ident.string_of_id id in + uu___3 = uu___4 in + let curmod_ns = + let uu___ = current_module env1 in + FStarC_Ident.ids_of_lid uu___ in + let proc uu___ = + match uu___ with + | Local_binding l when check_local_binding_id l -> + let uu___1 = l in + (match uu___1 with + | (uu___2, uu___3, used_marker1) -> + (FStarC_Compiler_Effect.op_Colon_Equals + used_marker1 true; + k_local_binding l)) + | Rec_binding r when check_rec_binding_id r -> + let uu___1 = r in + (match uu___1 with + | (uu___2, uu___3, used_marker1) -> + (FStarC_Compiler_Effect.op_Colon_Equals + used_marker1 true; + k_rec_binding r)) + | Open_module_or_namespace + (ns, FStarC_Syntax_Syntax.Open_module, restriction) + -> + let uu___1 = + FStarC_Syntax_Syntax.is_ident_allowed_by_restriction + id restriction in + (match uu___1 with + | FStar_Pervasives_Native.None -> Cont_ignore + | FStar_Pervasives_Native.Some id1 -> + find_in_module_with_includes eikind + find_in_module Cont_ignore env1 ns id1) + | Top_level_def id' when + let uu___1 = FStarC_Ident.string_of_id id' in + let uu___2 = FStarC_Ident.string_of_id id in + uu___1 = uu___2 -> lookup_default_id Cont_ignore id + | Record_or_dc r when is_exported_id_field eikind -> + let uu___1 = FStarC_Ident.lid_of_ids curmod_ns in + find_in_module_with_includes Exported_id_field + (fun lid -> + let id1 = FStarC_Ident.ident_of_lid lid in + let uu___2 = FStarC_Ident.ns_of_lid lid in + find_in_record uu___2 id1 r k_record) + Cont_ignore env1 uu___1 id + | Record_or_dc r when is_exported_id_termtype eikind -> + let uu___1 = + let uu___2 = FStarC_Ident.ident_of_lid r.typename in + FStarC_Ident.ident_equals uu___2 id in + if uu___1 then k_record r else Cont_ignore + | uu___1 -> Cont_ignore in + let rec aux uu___ = + match uu___ with + | a1::q -> + let uu___1 = proc a1 in + option_of_cont (fun uu___2 -> aux q) uu___1 + | [] -> + let uu___1 = lookup_default_id Cont_fail id in + option_of_cont + (fun uu___2 -> FStar_Pervasives_Native.None) uu___1 in + aux env1.scope_mods +let found_local_binding : + 'uuuuu 'uuuuu1 . + FStarC_Compiler_Range_Type.range -> + ('uuuuu * FStarC_Syntax_Syntax.bv * 'uuuuu1) -> + FStarC_Syntax_Syntax.term + = + fun r -> fun uu___ -> match uu___ with | (id', x, uu___1) -> bv_to_name x r +let find_in_module : + 'uuuuu . + env -> + FStarC_Ident.lident -> + (FStarC_Ident.lident -> + (FStarC_Syntax_Syntax.sigelt * Prims.bool) -> 'uuuuu) + -> 'uuuuu -> 'uuuuu + = + fun env1 -> + fun lid -> + fun k_global_def -> + fun k_not_found -> + let uu___ = + let uu___1 = FStarC_Ident.string_of_lid lid in + FStarC_Compiler_Util.smap_try_find (sigmap env1) uu___1 in + match uu___ with + | FStar_Pervasives_Native.Some sb -> k_global_def lid sb + | FStar_Pervasives_Native.None -> k_not_found +let (try_lookup_id : + env -> + FStarC_Ident.ident -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = + fun env1 -> + fun id -> + let uu___ = unmangleOpName id in + match uu___ with + | FStar_Pervasives_Native.Some f -> FStar_Pervasives_Native.Some f + | uu___1 -> + try_lookup_id'' env1 id Exported_id_term_type + (fun r -> + let uu___2 = + let uu___3 = FStarC_Ident.range_of_id id in + found_local_binding uu___3 r in + Cont_ok uu___2) (fun uu___2 -> Cont_fail) + (fun uu___2 -> Cont_ignore) + (fun i -> + find_in_module env1 i (fun uu___2 -> fun uu___3 -> Cont_fail) + Cont_ignore) (fun uu___2 -> fun uu___3 -> Cont_fail) +let lookup_default_id : + 'a . + env -> + FStarC_Ident.ident -> + (FStarC_Ident.lident -> + (FStarC_Syntax_Syntax.sigelt * Prims.bool) -> 'a cont_t) + -> 'a cont_t -> 'a cont_t + = + fun env1 -> + fun id -> + fun k_global_def -> + fun k_not_found -> + let find_in_monad = + match env1.curmonad with + | FStar_Pervasives_Native.Some uu___ -> + let lid = qualify env1 id in + let uu___1 = + let uu___2 = FStarC_Ident.string_of_lid lid in + FStarC_Compiler_Util.smap_try_find (sigmap env1) uu___2 in + (match uu___1 with + | FStar_Pervasives_Native.Some r -> + let uu___2 = k_global_def lid r in + FStar_Pervasives_Native.Some uu___2 + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None) + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None in + match find_in_monad with + | FStar_Pervasives_Native.Some v -> v + | FStar_Pervasives_Native.None -> + let lid = let uu___ = current_module env1 in qual uu___ id in + find_in_module env1 lid k_global_def k_not_found +let (lid_is_curmod : env -> FStarC_Ident.lident -> Prims.bool) = + fun env1 -> + fun lid -> + match env1.curmodule with + | FStar_Pervasives_Native.None -> false + | FStar_Pervasives_Native.Some m -> FStarC_Ident.lid_equals lid m +let (module_is_defined : env -> FStarC_Ident.lident -> Prims.bool) = + fun env1 -> + fun lid -> + (lid_is_curmod env1 lid) || + (FStarC_Compiler_List.existsb + (fun x -> + FStarC_Ident.lid_equals lid (FStar_Pervasives_Native.fst x)) + env1.modules) +let (resolve_module_name : + env -> + FStarC_Ident.lident -> + Prims.bool -> FStarC_Ident.lident FStar_Pervasives_Native.option) + = + fun env1 -> + fun lid -> + fun honor_ns -> + let nslen = + let uu___ = FStarC_Ident.ns_of_lid lid in + FStarC_Compiler_List.length uu___ in + let rec aux uu___ = + match uu___ with + | [] -> + let uu___1 = module_is_defined env1 lid in + if uu___1 + then FStar_Pervasives_Native.Some lid + else FStar_Pervasives_Native.None + | (Open_module_or_namespace + (ns, FStarC_Syntax_Syntax.Open_namespace, restriction))::q when + honor_ns -> + let new_lid = + let uu___1 = + let uu___2 = FStarC_Ident.path_of_lid ns in + let uu___3 = FStarC_Ident.path_of_lid lid in + FStarC_Compiler_List.op_At uu___2 uu___3 in + let uu___2 = FStarC_Ident.range_of_lid lid in + FStarC_Ident.lid_of_path uu___1 uu___2 in + let uu___1 = module_is_defined env1 new_lid in + if uu___1 then FStar_Pervasives_Native.Some new_lid else aux q + | (Module_abbrev (name, modul))::uu___1 when + (nslen = Prims.int_zero) && + (let uu___2 = FStarC_Ident.string_of_id name in + let uu___3 = + let uu___4 = FStarC_Ident.ident_of_lid lid in + FStarC_Ident.string_of_id uu___4 in + uu___2 = uu___3) + -> FStar_Pervasives_Native.Some modul + | uu___1::q -> aux q in + aux env1.scope_mods +let (is_open : + env -> FStarC_Ident.lident -> FStarC_Syntax_Syntax.open_kind -> Prims.bool) + = + fun env1 -> + fun lid -> + fun open_kind -> + FStarC_Compiler_List.existsb + (fun uu___ -> + match uu___ with + | Open_module_or_namespace + (ns, k, FStarC_Syntax_Syntax.Unrestricted) -> + (k = open_kind) && (FStarC_Ident.lid_equals lid ns) + | uu___1 -> false) env1.scope_mods +let (namespace_is_open : env -> FStarC_Ident.lident -> Prims.bool) = + fun env1 -> fun lid -> is_open env1 lid FStarC_Syntax_Syntax.Open_namespace +let (module_is_open : env -> FStarC_Ident.lident -> Prims.bool) = + fun env1 -> + fun lid -> + (lid_is_curmod env1 lid) || + (is_open env1 lid FStarC_Syntax_Syntax.Open_module) +let (shorten_module_path : + env -> + FStarC_Ident.ident Prims.list -> + Prims.bool -> + (FStarC_Ident.ident Prims.list * FStarC_Ident.ident Prims.list)) + = + fun env1 -> + fun ids -> + fun is_full_path -> + let rec aux revns id = + let lid = + FStarC_Ident.lid_of_ns_and_id (FStarC_Compiler_List.rev revns) id in + let uu___ = namespace_is_open env1 lid in + if uu___ + then + FStar_Pervasives_Native.Some + ((FStarC_Compiler_List.rev (id :: revns)), []) + else + (match revns with + | [] -> FStar_Pervasives_Native.None + | ns_last_id::rev_ns_prefix -> + let uu___2 = aux rev_ns_prefix ns_last_id in + FStarC_Compiler_Util.map_option + (fun uu___3 -> + match uu___3 with + | (stripped_ids, rev_kept_ids) -> + (stripped_ids, (id :: rev_kept_ids))) uu___2) in + let do_shorten env2 ids1 = + match FStarC_Compiler_List.rev ids1 with + | [] -> ([], []) + | ns_last_id::ns_rev_prefix -> + let uu___ = aux ns_rev_prefix ns_last_id in + (match uu___ with + | FStar_Pervasives_Native.None -> ([], ids1) + | FStar_Pervasives_Native.Some (stripped_ids, rev_kept_ids) -> + (stripped_ids, (FStarC_Compiler_List.rev rev_kept_ids))) in + if + is_full_path && + ((FStarC_Compiler_List.length ids) > Prims.int_zero) + then + let uu___ = + let uu___1 = FStarC_Ident.lid_of_ids ids in + resolve_module_name env1 uu___1 true in + match uu___ with + | FStar_Pervasives_Native.Some m when module_is_open env1 m -> + (ids, []) + | uu___1 -> do_shorten env1 ids + else do_shorten env1 ids +let resolve_in_open_namespaces'' : + 'a . + env -> + FStarC_Ident.lident -> + exported_id_kind -> + (local_binding -> 'a cont_t) -> + (rec_binding -> 'a cont_t) -> + (record_or_dc -> 'a cont_t) -> + (FStarC_Ident.lident -> 'a cont_t) -> + ('a cont_t -> FStarC_Ident.ident -> 'a cont_t) -> + 'a FStar_Pervasives_Native.option + = + fun env1 -> + fun lid -> + fun eikind -> + fun k_local_binding -> + fun k_rec_binding -> + fun k_record -> + fun f_module -> + fun l_default -> + let uu___ = FStarC_Ident.ns_of_lid lid in + match uu___ with + | uu___1::uu___2 -> + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Ident.ns_of_lid lid in + FStarC_Ident.lid_of_ids uu___6 in + let uu___6 = FStarC_Ident.range_of_lid lid in + FStarC_Ident.set_lid_range uu___5 uu___6 in + resolve_module_name env1 uu___4 true in + (match uu___3 with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some modul -> + let uu___4 = + let uu___5 = FStarC_Ident.ident_of_lid lid in + find_in_module_with_includes eikind f_module + Cont_fail env1 modul uu___5 in + option_of_cont + (fun uu___5 -> FStar_Pervasives_Native.None) + uu___4) + | [] -> + let uu___1 = FStarC_Ident.ident_of_lid lid in + try_lookup_id'' env1 uu___1 eikind k_local_binding + k_rec_binding k_record f_module l_default +let cont_of_option : + 'a . 'a cont_t -> 'a FStar_Pervasives_Native.option -> 'a cont_t = + fun k_none -> + fun uu___ -> + match uu___ with + | FStar_Pervasives_Native.Some v -> Cont_ok v + | FStar_Pervasives_Native.None -> k_none +let resolve_in_open_namespaces' : + 'a . + env -> + FStarC_Ident.lident -> + (local_binding -> 'a FStar_Pervasives_Native.option) -> + (rec_binding -> 'a FStar_Pervasives_Native.option) -> + (FStarC_Ident.lident -> + (FStarC_Syntax_Syntax.sigelt * Prims.bool) -> + 'a FStar_Pervasives_Native.option) + -> 'a FStar_Pervasives_Native.option + = + fun env1 -> + fun lid -> + fun k_local_binding -> + fun k_rec_binding -> + fun k_global_def -> + let k_global_def' k lid1 def = + let uu___ = k_global_def lid1 def in cont_of_option k uu___ in + let f_module lid' = + let k = Cont_ignore in + find_in_module env1 lid' (k_global_def' k) k in + let l_default k i = lookup_default_id env1 i (k_global_def' k) k in + resolve_in_open_namespaces'' env1 lid Exported_id_term_type + (fun l -> + let uu___ = k_local_binding l in + cont_of_option Cont_fail uu___) + (fun r -> + let uu___ = k_rec_binding r in + cont_of_option Cont_fail uu___) (fun uu___ -> Cont_ignore) + f_module l_default +let (fv_qual_of_se : + FStarC_Syntax_Syntax.sigelt -> + FStarC_Syntax_Syntax.fv_qual FStar_Pervasives_Native.option) + = + fun se -> + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = uu___; + FStarC_Syntax_Syntax.us1 = uu___1; + FStarC_Syntax_Syntax.t1 = uu___2; FStarC_Syntax_Syntax.ty_lid = l; + FStarC_Syntax_Syntax.num_ty_params = uu___3; + FStarC_Syntax_Syntax.mutuals1 = uu___4; + FStarC_Syntax_Syntax.injective_type_params1 = uu___5;_} + -> + let qopt = + FStarC_Compiler_Util.find_map se.FStarC_Syntax_Syntax.sigquals + (fun uu___6 -> + match uu___6 with + | FStarC_Syntax_Syntax.RecordConstructor (uu___7, fs) -> + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Record_ctor (l, fs)) + | uu___7 -> FStar_Pervasives_Native.None) in + (match qopt with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.Data_ctor + | x -> x) + | FStarC_Syntax_Syntax.Sig_declare_typ uu___ -> + FStar_Pervasives_Native.None + | uu___ -> FStar_Pervasives_Native.None +let (lb_fv : + FStarC_Syntax_Syntax.letbinding Prims.list -> + FStarC_Ident.lident -> FStarC_Syntax_Syntax.fv) + = + fun lbs -> + fun lid -> + let uu___ = + FStarC_Compiler_Util.find_map lbs + (fun lb -> + let fv = + FStarC_Compiler_Util.right lb.FStarC_Syntax_Syntax.lbname in + let uu___1 = FStarC_Syntax_Syntax.fv_eq_lid fv lid in + if uu___1 + then FStar_Pervasives_Native.Some fv + else FStar_Pervasives_Native.None) in + FStarC_Compiler_Util.must uu___ +let (ns_of_lid_equals : + FStarC_Ident.lident -> FStarC_Ident.lident -> Prims.bool) = + fun lid -> + fun ns -> + (let uu___ = + let uu___1 = FStarC_Ident.ns_of_lid lid in + FStarC_Compiler_List.length uu___1 in + let uu___1 = + let uu___2 = FStarC_Ident.ids_of_lid ns in + FStarC_Compiler_List.length uu___2 in + uu___ = uu___1) && + (let uu___ = + let uu___1 = FStarC_Ident.ns_of_lid lid in + FStarC_Ident.lid_of_ids uu___1 in + FStarC_Ident.lid_equals uu___ ns) +let (try_lookup_name : + Prims.bool -> + Prims.bool -> + env -> FStarC_Ident.lident -> foundname FStar_Pervasives_Native.option) + = + fun any_val -> + fun exclude_interf -> + fun env1 -> + fun lid -> + let occurrence_range = FStarC_Ident.range_of_lid lid in + let k_global_def source_lid uu___ = + match uu___ with + | (uu___1, true) when exclude_interf -> + FStar_Pervasives_Native.None + | (se, uu___1) -> + (match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_inductive_typ uu___2 -> + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Syntax_Syntax.fvar_with_dd source_lid + FStar_Pervasives_Native.None in + (uu___5, (se.FStarC_Syntax_Syntax.sigattrs)) in + Term_name uu___4 in + FStar_Pervasives_Native.Some uu___3 + | FStarC_Syntax_Syntax.Sig_datacon uu___2 -> + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = fv_qual_of_se se in + FStarC_Syntax_Syntax.fvar_with_dd source_lid + uu___6 in + (uu___5, (se.FStarC_Syntax_Syntax.sigattrs)) in + Term_name uu___4 in + FStar_Pervasives_Native.Some uu___3 + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (uu___2, lbs); + FStarC_Syntax_Syntax.lids1 = uu___3;_} + -> + let fv = lb_fv lbs source_lid in + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.fvar_with_dd source_lid + fv.FStarC_Syntax_Syntax.fv_qual in + (uu___6, (se.FStarC_Syntax_Syntax.sigattrs)) in + Term_name uu___5 in + FStar_Pervasives_Native.Some uu___4 + | FStarC_Syntax_Syntax.Sig_declare_typ + { FStarC_Syntax_Syntax.lid2 = lid1; + FStarC_Syntax_Syntax.us2 = uu___2; + FStarC_Syntax_Syntax.t2 = uu___3;_} + -> + let quals = se.FStarC_Syntax_Syntax.sigquals in + let uu___4 = + any_val || + (FStarC_Compiler_Util.for_some + (fun uu___5 -> + match uu___5 with + | FStarC_Syntax_Syntax.Assumption -> true + | uu___6 -> false) quals) in + if uu___4 + then + let lid2 = + let uu___5 = FStarC_Ident.range_of_lid source_lid in + FStarC_Ident.set_lid_range lid1 uu___5 in + let uu___5 = + FStarC_Compiler_Util.find_map quals + (fun uu___6 -> + match uu___6 with + | FStarC_Syntax_Syntax.Reflectable refl_monad + -> FStar_Pervasives_Native.Some refl_monad + | uu___7 -> FStar_Pervasives_Native.None) in + (match uu___5 with + | FStar_Pervasives_Native.Some refl_monad -> + let refl_const = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_reflect refl_monad)) + occurrence_range in + FStar_Pervasives_Native.Some + (Term_name + (refl_const, + (se.FStarC_Syntax_Syntax.sigattrs))) + | uu___6 -> + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = fv_qual_of_se se in + FStarC_Syntax_Syntax.fvar_with_dd lid2 + uu___10 in + (uu___9, (se.FStarC_Syntax_Syntax.sigattrs)) in + Term_name uu___8 in + FStar_Pervasives_Native.Some uu___7) + else FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Sig_new_effect ne -> + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Ident.range_of_lid source_lid in + FStarC_Ident.set_lid_range + ne.FStarC_Syntax_Syntax.mname uu___5 in + (se, uu___4) in + Eff_name uu___3 in + FStar_Pervasives_Native.Some uu___2 + | FStarC_Syntax_Syntax.Sig_effect_abbrev uu___2 -> + FStar_Pervasives_Native.Some (Eff_name (se, source_lid)) + | FStarC_Syntax_Syntax.Sig_splice + { FStarC_Syntax_Syntax.is_typed = uu___2; + FStarC_Syntax_Syntax.lids2 = lids; + FStarC_Syntax_Syntax.tac = t;_} + -> + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Syntax_Syntax.fvar_with_dd source_lid + FStar_Pervasives_Native.None in + (uu___5, []) in + Term_name uu___4 in + FStar_Pervasives_Native.Some uu___3 + | uu___2 -> FStar_Pervasives_Native.None) in + let k_local_binding r = + let t = + let uu___ = FStarC_Ident.range_of_lid lid in + found_local_binding uu___ r in + FStar_Pervasives_Native.Some (Term_name (t, [])) in + let k_rec_binding uu___ = + match uu___ with + | (id, l, used_marker1) -> + (FStarC_Compiler_Effect.op_Colon_Equals used_marker1 true; + (let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Ident.range_of_lid lid in + FStarC_Ident.set_lid_range l uu___6 in + FStarC_Syntax_Syntax.fvar_with_dd uu___5 + FStar_Pervasives_Native.None in + (uu___4, []) in + Term_name uu___3 in + FStar_Pervasives_Native.Some uu___2)) in + let found_unmangled = + let uu___ = FStarC_Ident.ns_of_lid lid in + match uu___ with + | [] -> + let uu___1 = + let uu___2 = FStarC_Ident.ident_of_lid lid in + unmangleOpName uu___2 in + (match uu___1 with + | FStar_Pervasives_Native.Some t -> + FStar_Pervasives_Native.Some (Term_name (t, [])) + | uu___2 -> FStar_Pervasives_Native.None) + | uu___1 -> FStar_Pervasives_Native.None in + match found_unmangled with + | FStar_Pervasives_Native.None -> + resolve_in_open_namespaces' env1 lid k_local_binding + k_rec_binding k_global_def + | x -> x +let (try_lookup_effect_name' : + Prims.bool -> + env -> + FStarC_Ident.lident -> + (FStarC_Syntax_Syntax.sigelt * FStarC_Ident.lident) + FStar_Pervasives_Native.option) + = + fun exclude_interf -> + fun env1 -> + fun lid -> + let uu___ = try_lookup_name true exclude_interf env1 lid in + match uu___ with + | FStar_Pervasives_Native.Some (Eff_name (o, l)) -> + FStar_Pervasives_Native.Some (o, l) + | uu___1 -> FStar_Pervasives_Native.None +let (try_lookup_effect_name : + env -> + FStarC_Ident.lident -> FStarC_Ident.lident FStar_Pervasives_Native.option) + = + fun env1 -> + fun l -> + let uu___ = + try_lookup_effect_name' (Prims.op_Negation env1.iface) env1 l in + match uu___ with + | FStar_Pervasives_Native.Some (o, l1) -> + FStar_Pervasives_Native.Some l1 + | uu___1 -> FStar_Pervasives_Native.None +let (try_lookup_effect_name_and_attributes : + env -> + FStarC_Ident.lident -> + (FStarC_Ident.lident * FStarC_Syntax_Syntax.cflag Prims.list) + FStar_Pervasives_Native.option) + = + fun env1 -> + fun l -> + let uu___ = + try_lookup_effect_name' (Prims.op_Negation env1.iface) env1 l in + match uu___ with + | FStar_Pervasives_Native.Some + ({ + FStarC_Syntax_Syntax.sigel = FStarC_Syntax_Syntax.Sig_new_effect + ne; + FStarC_Syntax_Syntax.sigrng = uu___1; + FStarC_Syntax_Syntax.sigquals = uu___2; + FStarC_Syntax_Syntax.sigmeta = uu___3; + FStarC_Syntax_Syntax.sigattrs = uu___4; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___5; + FStarC_Syntax_Syntax.sigopts = uu___6;_}, + l1) + -> + FStar_Pervasives_Native.Some + (l1, (ne.FStarC_Syntax_Syntax.cattributes)) + | FStar_Pervasives_Native.Some + ({ + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_effect_abbrev + { FStarC_Syntax_Syntax.lid4 = uu___1; + FStarC_Syntax_Syntax.us4 = uu___2; + FStarC_Syntax_Syntax.bs2 = uu___3; + FStarC_Syntax_Syntax.comp1 = uu___4; + FStarC_Syntax_Syntax.cflags = cattributes;_}; + FStarC_Syntax_Syntax.sigrng = uu___5; + FStarC_Syntax_Syntax.sigquals = uu___6; + FStarC_Syntax_Syntax.sigmeta = uu___7; + FStarC_Syntax_Syntax.sigattrs = uu___8; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___9; + FStarC_Syntax_Syntax.sigopts = uu___10;_}, + l1) + -> FStar_Pervasives_Native.Some (l1, cattributes) + | uu___1 -> FStar_Pervasives_Native.None +let (try_lookup_effect_defn : + env -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.eff_decl FStar_Pervasives_Native.option) + = + fun env1 -> + fun l -> + let uu___ = + try_lookup_effect_name' (Prims.op_Negation env1.iface) env1 l in + match uu___ with + | FStar_Pervasives_Native.Some + ({ + FStarC_Syntax_Syntax.sigel = FStarC_Syntax_Syntax.Sig_new_effect + ne; + FStarC_Syntax_Syntax.sigrng = uu___1; + FStarC_Syntax_Syntax.sigquals = uu___2; + FStarC_Syntax_Syntax.sigmeta = uu___3; + FStarC_Syntax_Syntax.sigattrs = uu___4; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___5; + FStarC_Syntax_Syntax.sigopts = uu___6;_}, + uu___7) + -> FStar_Pervasives_Native.Some ne + | uu___1 -> FStar_Pervasives_Native.None +let (is_effect_name : env -> FStarC_Ident.lident -> Prims.bool) = + fun env1 -> + fun lid -> + let uu___ = try_lookup_effect_name env1 lid in + match uu___ with + | FStar_Pervasives_Native.None -> false + | FStar_Pervasives_Native.Some uu___1 -> true +let (try_lookup_root_effect_name : + env -> + FStarC_Ident.lident -> FStarC_Ident.lident FStar_Pervasives_Native.option) + = + fun env1 -> + fun l -> + let uu___ = + try_lookup_effect_name' (Prims.op_Negation env1.iface) env1 l in + match uu___ with + | FStar_Pervasives_Native.Some + ({ + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_effect_abbrev + { FStarC_Syntax_Syntax.lid4 = l'; + FStarC_Syntax_Syntax.us4 = uu___1; + FStarC_Syntax_Syntax.bs2 = uu___2; + FStarC_Syntax_Syntax.comp1 = uu___3; + FStarC_Syntax_Syntax.cflags = uu___4;_}; + FStarC_Syntax_Syntax.sigrng = uu___5; + FStarC_Syntax_Syntax.sigquals = uu___6; + FStarC_Syntax_Syntax.sigmeta = uu___7; + FStarC_Syntax_Syntax.sigattrs = uu___8; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___9; + FStarC_Syntax_Syntax.sigopts = uu___10;_}, + uu___11) + -> + let rec aux new_name = + let uu___12 = + let uu___13 = FStarC_Ident.string_of_lid new_name in + FStarC_Compiler_Util.smap_try_find (sigmap env1) uu___13 in + match uu___12 with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (s, uu___13) -> + (match s.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_new_effect ne -> + let uu___14 = + let uu___15 = FStarC_Ident.range_of_lid l in + FStarC_Ident.set_lid_range + ne.FStarC_Syntax_Syntax.mname uu___15 in + FStar_Pervasives_Native.Some uu___14 + | FStarC_Syntax_Syntax.Sig_effect_abbrev + { FStarC_Syntax_Syntax.lid4 = uu___14; + FStarC_Syntax_Syntax.us4 = uu___15; + FStarC_Syntax_Syntax.bs2 = uu___16; + FStarC_Syntax_Syntax.comp1 = cmp; + FStarC_Syntax_Syntax.cflags = uu___17;_} + -> + let l'' = FStarC_Syntax_Util.comp_effect_name cmp in + aux l'' + | uu___14 -> FStar_Pervasives_Native.None) in + aux l' + | FStar_Pervasives_Native.Some (uu___1, l') -> + FStar_Pervasives_Native.Some l' + | uu___1 -> FStar_Pervasives_Native.None +let (lookup_letbinding_quals_and_attrs : + env -> + FStarC_Ident.lident -> + (FStarC_Syntax_Syntax.qualifier Prims.list * + FStarC_Syntax_Syntax.attribute Prims.list)) + = + fun env1 -> + fun lid -> + let k_global_def lid1 uu___ = + match uu___ with + | ({ + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_declare_typ uu___1; + FStarC_Syntax_Syntax.sigrng = uu___2; + FStarC_Syntax_Syntax.sigquals = quals; + FStarC_Syntax_Syntax.sigmeta = uu___3; + FStarC_Syntax_Syntax.sigattrs = attrs; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___4; + FStarC_Syntax_Syntax.sigopts = uu___5;_}, + uu___6) -> FStar_Pervasives_Native.Some (quals, attrs) + | uu___1 -> FStar_Pervasives_Native.None in + let uu___ = + resolve_in_open_namespaces' env1 lid + (fun uu___1 -> FStar_Pervasives_Native.None) + (fun uu___1 -> FStar_Pervasives_Native.None) k_global_def in + match uu___ with + | FStar_Pervasives_Native.Some qa -> qa + | uu___1 -> ([], []) +let (try_lookup_module : + env -> + FStarC_Ident.path -> + FStarC_Syntax_Syntax.modul FStar_Pervasives_Native.option) + = + fun env1 -> + fun path -> + let uu___ = + FStarC_Compiler_List.tryFind + (fun uu___1 -> + match uu___1 with + | (mlid, modul) -> + let uu___2 = FStarC_Ident.path_of_lid mlid in uu___2 = path) + env1.modules in + match uu___ with + | FStar_Pervasives_Native.Some (uu___1, modul) -> + FStar_Pervasives_Native.Some modul + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None +let (try_lookup_let : + env -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = + fun env1 -> + fun lid -> + let k_global_def lid1 uu___ = + match uu___ with + | ({ + FStarC_Syntax_Syntax.sigel = FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (uu___1, lbs); + FStarC_Syntax_Syntax.lids1 = uu___2;_}; + FStarC_Syntax_Syntax.sigrng = uu___3; + FStarC_Syntax_Syntax.sigquals = uu___4; + FStarC_Syntax_Syntax.sigmeta = uu___5; + FStarC_Syntax_Syntax.sigattrs = uu___6; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___7; + FStarC_Syntax_Syntax.sigopts = uu___8;_}, + uu___9) -> + let fv = lb_fv lbs lid1 in + let uu___10 = + FStarC_Syntax_Syntax.fvar_with_dd lid1 + fv.FStarC_Syntax_Syntax.fv_qual in + FStar_Pervasives_Native.Some uu___10 + | uu___1 -> FStar_Pervasives_Native.None in + resolve_in_open_namespaces' env1 lid + (fun uu___ -> FStar_Pervasives_Native.None) + (fun uu___ -> FStar_Pervasives_Native.None) k_global_def +let (try_lookup_definition : + env -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = + fun env1 -> + fun lid -> + let k_global_def lid1 uu___ = + match uu___ with + | ({ + FStarC_Syntax_Syntax.sigel = FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = lbs; + FStarC_Syntax_Syntax.lids1 = uu___1;_}; + FStarC_Syntax_Syntax.sigrng = uu___2; + FStarC_Syntax_Syntax.sigquals = uu___3; + FStarC_Syntax_Syntax.sigmeta = uu___4; + FStarC_Syntax_Syntax.sigattrs = uu___5; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___6; + FStarC_Syntax_Syntax.sigopts = uu___7;_}, + uu___8) -> + FStarC_Compiler_Util.find_map (FStar_Pervasives_Native.snd lbs) + (fun lb -> + match lb.FStarC_Syntax_Syntax.lbname with + | FStar_Pervasives.Inr fv when + FStarC_Syntax_Syntax.fv_eq_lid fv lid1 -> + FStar_Pervasives_Native.Some + (lb.FStarC_Syntax_Syntax.lbdef) + | uu___9 -> FStar_Pervasives_Native.None) + | uu___1 -> FStar_Pervasives_Native.None in + resolve_in_open_namespaces' env1 lid + (fun uu___ -> FStar_Pervasives_Native.None) + (fun uu___ -> FStar_Pervasives_Native.None) k_global_def +let (empty_include_smap : + (FStarC_Ident.lident * FStarC_Syntax_Syntax.restriction) Prims.list + FStarC_Compiler_Effect.ref FStarC_Compiler_Util.smap) + = new_sigmap () +let (empty_exported_id_smap : exported_id_set FStarC_Compiler_Util.smap) = + new_sigmap () +let (try_lookup_lid' : + Prims.bool -> + Prims.bool -> + env -> + FStarC_Ident.lident -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.attribute + Prims.list) FStar_Pervasives_Native.option) + = + fun any_val -> + fun exclude_interface -> + fun env1 -> + fun lid -> + let uu___ = try_lookup_name any_val exclude_interface env1 lid in + match uu___ with + | FStar_Pervasives_Native.Some (Term_name (e, attrs)) -> + FStar_Pervasives_Native.Some (e, attrs) + | uu___1 -> FStar_Pervasives_Native.None +let (drop_attributes : + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.attribute Prims.list) + FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = + fun x -> + match x with + | FStar_Pervasives_Native.Some (t, uu___) -> + FStar_Pervasives_Native.Some t + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None +let (try_lookup_lid_with_attributes : + env -> + FStarC_Ident.lident -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.attribute Prims.list) + FStar_Pervasives_Native.option) + = fun env1 -> fun l -> try_lookup_lid' env1.iface false env1 l +let (try_lookup_lid : + env -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = + fun env1 -> + fun l -> + let uu___ = try_lookup_lid_with_attributes env1 l in + drop_attributes uu___ +let (resolve_to_fully_qualified_name : + env -> + FStarC_Ident.lident -> FStarC_Ident.lident FStar_Pervasives_Native.option) + = + fun env1 -> + fun l -> + let r = + let uu___ = try_lookup_name true false env1 l in + match uu___ with + | FStar_Pervasives_Native.Some (Term_name (e, attrs)) -> + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress e in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + FStar_Pervasives_Native.Some + ((fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v) + | uu___2 -> FStar_Pervasives_Native.None) + | FStar_Pervasives_Native.Some (Eff_name (o, l1)) -> + FStar_Pervasives_Native.Some l1 + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None in + r +let (is_abbrev : + env -> + FStarC_Ident.lident -> FStarC_Ident.ipath FStar_Pervasives_Native.option) + = + fun env1 -> + fun lid -> + FStarC_Compiler_List.tryPick + (fun uu___ -> + match uu___ with + | Module_abbrev (id, ns) when FStarC_Ident.lid_equals lid ns -> + FStar_Pervasives_Native.Some [id] + | uu___1 -> FStar_Pervasives_Native.None) env1.scope_mods +let (try_shorten_abbrev : + env -> + FStarC_Ident.ipath -> + (FStarC_Ident.ipath * FStarC_Ident.ident Prims.list) + FStar_Pervasives_Native.option) + = + fun env1 -> + fun ns -> + let rec aux ns1 rest = + match ns1 with + | [] -> FStar_Pervasives_Native.None + | hd::tl -> + let uu___ = + let uu___1 = + FStarC_Ident.lid_of_ids (FStarC_Compiler_List.rev ns1) in + is_abbrev env1 uu___1 in + (match uu___ with + | FStar_Pervasives_Native.Some short -> + FStar_Pervasives_Native.Some (short, rest) + | uu___1 -> aux tl (hd :: rest)) in + aux (FStarC_Compiler_List.rev ns) [] +let (shorten_lid' : env -> FStarC_Ident.lident -> FStarC_Ident.lident) = + fun env1 -> + fun lid0 -> + let id0 = FStarC_Ident.ident_of_lid lid0 in + let ns0 = FStarC_Ident.ns_of_lid lid0 in + let uu___ = + let uu___1 = try_shorten_abbrev env1 ns0 in + match uu___1 with + | FStar_Pervasives_Native.None -> ([], ns0) + | FStar_Pervasives_Native.Some (ns, rest) -> (ns, rest) in + match uu___ with + | (pref, ns) -> + let rec tails l = + match l with + | [] -> [[]] + | uu___1::tl -> let uu___2 = tails tl in l :: uu___2 in + let suffs = + let uu___1 = tails ns in FStarC_Compiler_List.rev uu___1 in + let try1 lid' = + let uu___1 = resolve_to_fully_qualified_name env1 lid' in + match uu___1 with + | FStar_Pervasives_Native.Some lid2 when + FStarC_Ident.lid_equals lid2 lid0 -> true + | uu___2 -> false in + let rec go nss = + match nss with + | ns1::rest -> + let lid' = + FStarC_Ident.lid_of_ns_and_id + (FStarC_Compiler_List.op_At pref ns1) id0 in + let uu___1 = try1 lid' in if uu___1 then lid' else go rest + | [] -> lid0 in + let r = go suffs in r +let (shorten_lid : env -> FStarC_Ident.lid -> FStarC_Ident.lid) = + fun env1 -> + fun lid0 -> + match env1.curmodule with + | FStar_Pervasives_Native.None -> lid0 + | uu___ -> shorten_lid' env1 lid0 +let (try_lookup_lid_with_attributes_no_resolve : + env -> + FStarC_Ident.lident -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.attribute Prims.list) + FStar_Pervasives_Native.option) + = + fun env1 -> + fun l -> + let env' = + { + curmodule = (env1.curmodule); + curmonad = (env1.curmonad); + modules = (env1.modules); + scope_mods = []; + exported_ids = empty_exported_id_smap; + trans_exported_ids = (env1.trans_exported_ids); + includes = empty_include_smap; + sigaccum = (env1.sigaccum); + sigmap = (env1.sigmap); + iface = (env1.iface); + admitted_iface = (env1.admitted_iface); + expect_typ = (env1.expect_typ); + remaining_iface_decls = (env1.remaining_iface_decls); + syntax_only = (env1.syntax_only); + ds_hooks = (env1.ds_hooks); + dep_graph = (env1.dep_graph) + } in + try_lookup_lid_with_attributes env' l +let (try_lookup_lid_no_resolve : + env -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = + fun env1 -> + fun l -> + let uu___ = try_lookup_lid_with_attributes_no_resolve env1 l in + drop_attributes uu___ +let (try_lookup_datacon : + env -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.fv FStar_Pervasives_Native.option) + = + fun env1 -> + fun lid -> + let k_global_def lid1 se = + match se with + | ({ + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_declare_typ uu___; + FStarC_Syntax_Syntax.sigrng = uu___1; + FStarC_Syntax_Syntax.sigquals = quals; + FStarC_Syntax_Syntax.sigmeta = uu___2; + FStarC_Syntax_Syntax.sigattrs = uu___3; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___4; + FStarC_Syntax_Syntax.sigopts = uu___5;_}, + uu___6) -> + let uu___7 = + FStarC_Compiler_Util.for_some + (fun uu___8 -> + match uu___8 with + | FStarC_Syntax_Syntax.Assumption -> true + | uu___9 -> false) quals in + if uu___7 + then + let uu___8 = + FStarC_Syntax_Syntax.lid_and_dd_as_fv lid1 + FStar_Pervasives_Native.None in + FStar_Pervasives_Native.Some uu___8 + else FStar_Pervasives_Native.None + | ({ + FStarC_Syntax_Syntax.sigel = FStarC_Syntax_Syntax.Sig_splice + uu___; + FStarC_Syntax_Syntax.sigrng = uu___1; + FStarC_Syntax_Syntax.sigquals = uu___2; + FStarC_Syntax_Syntax.sigmeta = uu___3; + FStarC_Syntax_Syntax.sigattrs = uu___4; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___5; + FStarC_Syntax_Syntax.sigopts = uu___6;_}, + uu___7) -> + let qual1 = fv_qual_of_se (FStar_Pervasives_Native.fst se) in + let uu___8 = FStarC_Syntax_Syntax.lid_and_dd_as_fv lid1 qual1 in + FStar_Pervasives_Native.Some uu___8 + | ({ + FStarC_Syntax_Syntax.sigel = FStarC_Syntax_Syntax.Sig_datacon + uu___; + FStarC_Syntax_Syntax.sigrng = uu___1; + FStarC_Syntax_Syntax.sigquals = uu___2; + FStarC_Syntax_Syntax.sigmeta = uu___3; + FStarC_Syntax_Syntax.sigattrs = uu___4; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___5; + FStarC_Syntax_Syntax.sigopts = uu___6;_}, + uu___7) -> + let qual1 = fv_qual_of_se (FStar_Pervasives_Native.fst se) in + let uu___8 = FStarC_Syntax_Syntax.lid_and_dd_as_fv lid1 qual1 in + FStar_Pervasives_Native.Some uu___8 + | uu___ -> FStar_Pervasives_Native.None in + resolve_in_open_namespaces' env1 lid + (fun uu___ -> FStar_Pervasives_Native.None) + (fun uu___ -> FStar_Pervasives_Native.None) k_global_def +let (find_all_datacons : + env -> + FStarC_Ident.lident -> + FStarC_Ident.lident Prims.list FStar_Pervasives_Native.option) + = + fun env1 -> + fun lid -> + let k_global_def lid1 uu___ = + match uu___ with + | ({ + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = uu___1; + FStarC_Syntax_Syntax.us = uu___2; + FStarC_Syntax_Syntax.params = uu___3; + FStarC_Syntax_Syntax.num_uniform_params = uu___4; + FStarC_Syntax_Syntax.t = uu___5; + FStarC_Syntax_Syntax.mutuals = datas; + FStarC_Syntax_Syntax.ds = uu___6; + FStarC_Syntax_Syntax.injective_type_params = uu___7;_}; + FStarC_Syntax_Syntax.sigrng = uu___8; + FStarC_Syntax_Syntax.sigquals = uu___9; + FStarC_Syntax_Syntax.sigmeta = uu___10; + FStarC_Syntax_Syntax.sigattrs = uu___11; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___12; + FStarC_Syntax_Syntax.sigopts = uu___13;_}, + uu___14) -> FStar_Pervasives_Native.Some datas + | uu___1 -> FStar_Pervasives_Native.None in + resolve_in_open_namespaces' env1 lid + (fun uu___ -> FStar_Pervasives_Native.None) + (fun uu___ -> FStar_Pervasives_Native.None) k_global_def +let (record_cache_aux_with_filter : + ((((unit -> unit) * (unit -> unit)) * (((unit -> (Prims.int * unit)) * + (Prims.int FStar_Pervasives_Native.option -> unit)) * + ((unit -> record_or_dc Prims.list) * (record_or_dc -> unit)))) * + (unit -> unit))) + = + let record_cache = FStarC_Compiler_Util.mk_ref [[]] in + let push uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Compiler_Effect.op_Bang record_cache in + FStarC_Compiler_List.hd uu___3 in + let uu___3 = FStarC_Compiler_Effect.op_Bang record_cache in uu___2 :: + uu___3 in + FStarC_Compiler_Effect.op_Colon_Equals record_cache uu___1 in + let pop uu___ = + let uu___1 = + let uu___2 = FStarC_Compiler_Effect.op_Bang record_cache in + FStarC_Compiler_List.tl uu___2 in + FStarC_Compiler_Effect.op_Colon_Equals record_cache uu___1 in + let snapshot uu___ = FStarC_Common.snapshot push record_cache () in + let rollback depth = FStarC_Common.rollback pop record_cache depth in + let peek uu___ = + let uu___1 = FStarC_Compiler_Effect.op_Bang record_cache in + FStarC_Compiler_List.hd uu___1 in + let insert r = + let uu___ = + let uu___1 = let uu___2 = peek () in r :: uu___2 in + let uu___2 = + let uu___3 = FStarC_Compiler_Effect.op_Bang record_cache in + FStarC_Compiler_List.tl uu___3 in + uu___1 :: uu___2 in + FStarC_Compiler_Effect.op_Colon_Equals record_cache uu___ in + let filter uu___ = + let rc = peek () in + let filtered = + FStarC_Compiler_List.filter (fun r -> Prims.op_Negation r.is_private) + rc in + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Compiler_Effect.op_Bang record_cache in + FStarC_Compiler_List.tl uu___3 in + filtered :: uu___2 in + FStarC_Compiler_Effect.op_Colon_Equals record_cache uu___1 in + let aux = ((push, pop), ((snapshot, rollback), (peek, insert))) in + (aux, filter) +let (record_cache_aux : + (((unit -> unit) * (unit -> unit)) * (((unit -> (Prims.int * unit)) * + (Prims.int FStar_Pervasives_Native.option -> unit)) * + ((unit -> record_or_dc Prims.list) * (record_or_dc -> unit))))) + = FStar_Pervasives_Native.fst record_cache_aux_with_filter +let (filter_record_cache : unit -> unit) = + FStar_Pervasives_Native.snd record_cache_aux_with_filter +let (push_record_cache : unit -> unit) = + FStar_Pervasives_Native.fst (FStar_Pervasives_Native.fst record_cache_aux) +let (pop_record_cache : unit -> unit) = + FStar_Pervasives_Native.snd (FStar_Pervasives_Native.fst record_cache_aux) +let (snapshot_record_cache : unit -> (Prims.int * unit)) = + FStar_Pervasives_Native.fst + (FStar_Pervasives_Native.fst + (FStar_Pervasives_Native.snd record_cache_aux)) +let (rollback_record_cache : + Prims.int FStar_Pervasives_Native.option -> unit) = + FStar_Pervasives_Native.snd + (FStar_Pervasives_Native.fst + (FStar_Pervasives_Native.snd record_cache_aux)) +let (peek_record_cache : unit -> record_or_dc Prims.list) = + FStar_Pervasives_Native.fst + (FStar_Pervasives_Native.snd + (FStar_Pervasives_Native.snd record_cache_aux)) +let (insert_record_cache : record_or_dc -> unit) = + FStar_Pervasives_Native.snd + (FStar_Pervasives_Native.snd + (FStar_Pervasives_Native.snd record_cache_aux)) +let (extract_record : + env -> + scope_mod Prims.list FStarC_Compiler_Effect.ref -> + FStarC_Syntax_Syntax.sigelt -> unit) + = + fun e -> + fun new_globs -> + fun se -> + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_bundle + { FStarC_Syntax_Syntax.ses = sigs; + FStarC_Syntax_Syntax.lids = uu___;_} + -> + let is_record = + FStarC_Compiler_Util.for_some + (fun uu___1 -> + match uu___1 with + | FStarC_Syntax_Syntax.RecordType uu___2 -> true + | FStarC_Syntax_Syntax.RecordConstructor uu___2 -> true + | uu___2 -> false) in + let find_dc dc = + FStarC_Compiler_Util.find_opt + (fun uu___1 -> + match uu___1 with + | { + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = lid; + FStarC_Syntax_Syntax.us1 = uu___2; + FStarC_Syntax_Syntax.t1 = uu___3; + FStarC_Syntax_Syntax.ty_lid = uu___4; + FStarC_Syntax_Syntax.num_ty_params = uu___5; + FStarC_Syntax_Syntax.mutuals1 = uu___6; + FStarC_Syntax_Syntax.injective_type_params1 = + uu___7;_}; + FStarC_Syntax_Syntax.sigrng = uu___8; + FStarC_Syntax_Syntax.sigquals = uu___9; + FStarC_Syntax_Syntax.sigmeta = uu___10; + FStarC_Syntax_Syntax.sigattrs = uu___11; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___12; + FStarC_Syntax_Syntax.sigopts = uu___13;_} -> + FStarC_Ident.lid_equals dc lid + | uu___2 -> false) sigs in + FStarC_Compiler_List.iter + (fun uu___1 -> + match uu___1 with + | { + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = typename; + FStarC_Syntax_Syntax.us = univs; + FStarC_Syntax_Syntax.params = parms; + FStarC_Syntax_Syntax.num_uniform_params = uu___2; + FStarC_Syntax_Syntax.t = uu___3; + FStarC_Syntax_Syntax.mutuals = uu___4; + FStarC_Syntax_Syntax.ds = dc::[]; + FStarC_Syntax_Syntax.injective_type_params = uu___5;_}; + FStarC_Syntax_Syntax.sigrng = uu___6; + FStarC_Syntax_Syntax.sigquals = typename_quals; + FStarC_Syntax_Syntax.sigmeta = uu___7; + FStarC_Syntax_Syntax.sigattrs = uu___8; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___9; + FStarC_Syntax_Syntax.sigopts = uu___10;_} -> + let uu___11 = + let uu___12 = find_dc dc in + FStarC_Compiler_Util.must uu___12 in + (match uu___11 with + | { + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = constrname; + FStarC_Syntax_Syntax.us1 = uu___12; + FStarC_Syntax_Syntax.t1 = t; + FStarC_Syntax_Syntax.ty_lid = uu___13; + FStarC_Syntax_Syntax.num_ty_params = n; + FStarC_Syntax_Syntax.mutuals1 = uu___14; + FStarC_Syntax_Syntax.injective_type_params1 = + uu___15;_}; + FStarC_Syntax_Syntax.sigrng = uu___16; + FStarC_Syntax_Syntax.sigquals = uu___17; + FStarC_Syntax_Syntax.sigmeta = uu___18; + FStarC_Syntax_Syntax.sigattrs = uu___19; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___20; + FStarC_Syntax_Syntax.sigopts = uu___21;_} -> + let uu___22 = FStarC_Syntax_Util.arrow_formals t in + (match uu___22 with + | (all_formals, uu___23) -> + let uu___24 = + FStarC_Compiler_Util.first_N n all_formals in + (match uu___24 with + | (_params, formals) -> + let is_rec = is_record typename_quals in + let formals' = + FStarC_Compiler_List.collect + (fun f -> + let uu___25 = + (FStarC_Syntax_Syntax.is_null_bv + f.FStarC_Syntax_Syntax.binder_bv) + || + (is_rec && + (FStarC_Syntax_Syntax.is_bqual_implicit + f.FStarC_Syntax_Syntax.binder_qual)) in + if uu___25 then [] else [f]) + formals in + let fields' = + FStarC_Compiler_List.map + (fun f -> + (((f.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.ppname), + ((f.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort))) + formals' in + let fields = fields' in + let record = + let uu___25 = + FStarC_Ident.ident_of_lid constrname in + { + typename; + constrname = uu___25; + parms; + fields; + is_private = + (FStarC_Compiler_List.contains + FStarC_Syntax_Syntax.Private + typename_quals); + is_record = is_rec + } in + ((let uu___26 = + let uu___27 = + FStarC_Compiler_Effect.op_Bang + new_globs in + (Record_or_dc record) :: uu___27 in + FStarC_Compiler_Effect.op_Colon_Equals + new_globs uu___26); + (match () with + | () -> + ((let add_field uu___27 = + match uu___27 with + | (id, uu___28) -> + let modul = + let uu___29 = + let uu___30 = + FStarC_Ident.ns_of_lid + constrname in + FStarC_Ident.lid_of_ids + uu___30 in + FStarC_Ident.string_of_lid + uu___29 in + let uu___29 = + get_exported_id_set e + modul in + (match uu___29 with + | FStar_Pervasives_Native.Some + my_ex -> + let my_exported_ids = + my_ex + Exported_id_field in + ((let uu___31 = + let uu___32 = + FStarC_Ident.string_of_id + id in + let uu___33 = + FStarC_Compiler_Effect.op_Bang + my_exported_ids in + Obj.magic + (FStarC_Class_Setlike.add + () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) + uu___32 + (Obj.magic + uu___33)) in + FStarC_Compiler_Effect.op_Colon_Equals + my_exported_ids + uu___31); + (match () with + | () -> + let projname = + let uu___31 = + let uu___32 + = + FStarC_Syntax_Util.mk_field_projector_name_from_ident + constrname + id in + FStarC_Ident.ident_of_lid + uu___32 in + FStarC_Ident.string_of_id + uu___31 in + let uu___32 = + let uu___33 = + FStarC_Compiler_Effect.op_Bang + my_exported_ids in + Obj.magic + (FStarC_Class_Setlike.add + () + ( + Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) + projname + ( + Obj.magic + uu___33)) in + FStarC_Compiler_Effect.op_Colon_Equals + my_exported_ids + uu___32)) + | FStar_Pervasives_Native.None + -> ()) in + FStarC_Compiler_List.iter + add_field fields'); + (match () with + | () -> + insert_record_cache record)))))) + | uu___12 -> ()) + | uu___2 -> ()) sigs + | uu___ -> () +let (try_lookup_record_or_dc_by_field_name : + env -> FStarC_Ident.lident -> record_or_dc FStar_Pervasives_Native.option) + = + fun env1 -> + fun fieldname -> + let find_in_cache fieldname1 = + let uu___ = + let uu___1 = FStarC_Ident.ns_of_lid fieldname1 in + let uu___2 = FStarC_Ident.ident_of_lid fieldname1 in + (uu___1, uu___2) in + match uu___ with + | (ns, id) -> + let uu___1 = peek_record_cache () in + FStarC_Compiler_Util.find_map uu___1 + (fun record -> + let uu___2 = + find_in_record ns id record (fun r -> Cont_ok r) in + option_of_cont (fun uu___3 -> FStar_Pervasives_Native.None) + uu___2) in + resolve_in_open_namespaces'' env1 fieldname Exported_id_field + (fun uu___ -> Cont_ignore) (fun uu___ -> Cont_ignore) + (fun r -> Cont_ok r) + (fun fn -> + let uu___ = find_in_cache fn in cont_of_option Cont_ignore uu___) + (fun k -> fun uu___ -> k) +let (try_lookup_record_by_field_name : + env -> FStarC_Ident.lident -> record_or_dc FStar_Pervasives_Native.option) + = + fun env1 -> + fun fieldname -> + let uu___ = try_lookup_record_or_dc_by_field_name env1 fieldname in + match uu___ with + | FStar_Pervasives_Native.Some r when r.is_record -> + FStar_Pervasives_Native.Some r + | uu___1 -> FStar_Pervasives_Native.None +let (try_lookup_record_type : + env -> FStarC_Ident.lident -> record_or_dc FStar_Pervasives_Native.option) + = + fun env1 -> + fun typename -> + let find_in_cache name = + let uu___ = + let uu___1 = FStarC_Ident.ns_of_lid name in + let uu___2 = FStarC_Ident.ident_of_lid name in (uu___1, uu___2) in + match uu___ with + | (ns, id) -> + let uu___1 = peek_record_cache () in + FStarC_Compiler_Util.find_map uu___1 + (fun record -> + let uu___2 = + let uu___3 = FStarC_Ident.ident_of_lid record.typename in + FStarC_Ident.ident_equals uu___3 id in + if uu___2 + then FStar_Pervasives_Native.Some record + else FStar_Pervasives_Native.None) in + resolve_in_open_namespaces'' env1 typename Exported_id_term_type + (fun uu___ -> Cont_ignore) (fun uu___ -> Cont_ignore) + (fun r -> Cont_ok r) + (fun l -> + let uu___ = find_in_cache l in cont_of_option Cont_ignore uu___) + (fun k -> fun uu___ -> k) +let (belongs_to_record : + env -> FStarC_Ident.lident -> record_or_dc -> Prims.bool) = + fun env1 -> + fun lid -> + fun record -> + let uu___ = try_lookup_record_by_field_name env1 lid in + match uu___ with + | FStar_Pervasives_Native.Some record' when + let uu___1 = FStarC_Ident.nsstr record.typename in + let uu___2 = FStarC_Ident.nsstr record'.typename in + uu___1 = uu___2 -> + let uu___1 = + let uu___2 = FStarC_Ident.ns_of_lid record.typename in + let uu___3 = FStarC_Ident.ident_of_lid lid in + find_in_record uu___2 uu___3 record (fun uu___4 -> Cont_ok ()) in + (match uu___1 with | Cont_ok uu___2 -> true | uu___2 -> false) + | uu___1 -> false +let (try_lookup_dc_by_field_name : + env -> + FStarC_Ident.lident -> + (FStarC_Ident.lident * Prims.bool) FStar_Pervasives_Native.option) + = + fun env1 -> + fun fieldname -> + let uu___ = try_lookup_record_or_dc_by_field_name env1 fieldname in + match uu___ with + | FStar_Pervasives_Native.Some r -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Ident.ns_of_lid r.typename in + FStarC_Compiler_List.op_At uu___5 [r.constrname] in + FStarC_Ident.lid_of_ids uu___4 in + let uu___4 = FStarC_Ident.range_of_lid fieldname in + FStarC_Ident.set_lid_range uu___3 uu___4 in + (uu___2, (r.is_record)) in + FStar_Pervasives_Native.Some uu___1 + | uu___1 -> FStar_Pervasives_Native.None +let (string_set_ref_new : unit -> string_set FStarC_Compiler_Effect.ref) = + fun uu___ -> + let uu___1 = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) ()) in + FStarC_Compiler_Util.mk_ref uu___1 +let (exported_id_set_new : + unit -> exported_id_kind -> string_set FStarC_Compiler_Effect.ref) = + fun uu___ -> + let term_type_set = string_set_ref_new () in + let field_set = string_set_ref_new () in + fun uu___1 -> + match uu___1 with + | Exported_id_term_type -> term_type_set + | Exported_id_field -> field_set +let (unique : + Prims.bool -> Prims.bool -> env -> FStarC_Ident.lident -> Prims.bool) = + fun any_val -> + fun exclude_interface -> + fun env1 -> + fun lid -> + let filter_scope_mods uu___ = + match uu___ with | Rec_binding uu___1 -> true | uu___1 -> false in + let this_env = + let uu___ = + FStarC_Compiler_List.filter filter_scope_mods env1.scope_mods in + { + curmodule = (env1.curmodule); + curmonad = (env1.curmonad); + modules = (env1.modules); + scope_mods = uu___; + exported_ids = empty_exported_id_smap; + trans_exported_ids = (env1.trans_exported_ids); + includes = empty_include_smap; + sigaccum = (env1.sigaccum); + sigmap = (env1.sigmap); + iface = (env1.iface); + admitted_iface = (env1.admitted_iface); + expect_typ = (env1.expect_typ); + remaining_iface_decls = (env1.remaining_iface_decls); + syntax_only = (env1.syntax_only); + ds_hooks = (env1.ds_hooks); + dep_graph = (env1.dep_graph) + } in + let uu___ = try_lookup_lid' any_val exclude_interface this_env lid in + match uu___ with + | FStar_Pervasives_Native.None -> true + | FStar_Pervasives_Native.Some uu___1 -> false +let (push_scope_mod : env -> scope_mod -> env) = + fun env1 -> + fun scope_mod1 -> + { + curmodule = (env1.curmodule); + curmonad = (env1.curmonad); + modules = (env1.modules); + scope_mods = (scope_mod1 :: (env1.scope_mods)); + exported_ids = (env1.exported_ids); + trans_exported_ids = (env1.trans_exported_ids); + includes = (env1.includes); + sigaccum = (env1.sigaccum); + sigmap = (env1.sigmap); + iface = (env1.iface); + admitted_iface = (env1.admitted_iface); + expect_typ = (env1.expect_typ); + remaining_iface_decls = (env1.remaining_iface_decls); + syntax_only = (env1.syntax_only); + ds_hooks = (env1.ds_hooks); + dep_graph = (env1.dep_graph) + } +let (push_bv' : + env -> FStarC_Ident.ident -> (env * FStarC_Syntax_Syntax.bv * used_marker)) + = + fun env1 -> + fun x -> + let r = FStarC_Ident.range_of_id x in + let bv = + let uu___ = FStarC_Ident.string_of_id x in + FStarC_Syntax_Syntax.gen_bv uu___ (FStar_Pervasives_Native.Some r) + { + FStarC_Syntax_Syntax.n = + (FStarC_Syntax_Syntax.tun.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = r; + FStarC_Syntax_Syntax.vars = + (FStarC_Syntax_Syntax.tun.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (FStarC_Syntax_Syntax.tun.FStarC_Syntax_Syntax.hash_code) + } in + let used_marker1 = FStarC_Compiler_Util.mk_ref false in + ((push_scope_mod env1 (Local_binding (x, bv, used_marker1))), bv, + used_marker1) +let (push_bv : env -> FStarC_Ident.ident -> (env * FStarC_Syntax_Syntax.bv)) + = + fun env1 -> + fun x -> + let uu___ = push_bv' env1 x in + match uu___ with | (env2, bv, uu___1) -> (env2, bv) +let (push_top_level_rec_binding : + env -> FStarC_Ident.ident -> (env * Prims.bool FStarC_Compiler_Effect.ref)) + = + fun env0 -> + fun x -> + let l = qualify env0 x in + let uu___ = + (unique false true env0 l) || (FStarC_Options.interactive ()) in + if uu___ + then + let used_marker1 = FStarC_Compiler_Util.mk_ref false in + ((push_scope_mod env0 (Rec_binding (x, l, used_marker1))), + used_marker1) + else + (let uu___2 = + let uu___3 = FStarC_Ident.string_of_lid l in + Prims.strcat "Duplicate top-level names " uu___3 in + FStarC_Errors.raise_error FStarC_Ident.hasrange_lident l + FStarC_Errors_Codes.Fatal_DuplicateTopLevelNames () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)) +let (push_sigelt' : Prims.bool -> env -> FStarC_Syntax_Syntax.sigelt -> env) + = + fun fail_on_dup -> + fun env1 -> + fun s -> + let err l = + let sopt = + let uu___ = FStarC_Ident.string_of_lid l in + FStarC_Compiler_Util.smap_try_find (sigmap env1) uu___ in + let r = + match sopt with + | FStar_Pervasives_Native.Some (se, uu___) -> + let uu___1 = + FStarC_Compiler_Util.find_opt (FStarC_Ident.lid_equals l) + (FStarC_Syntax_Util.lids_of_sigelt se) in + (match uu___1 with + | FStar_Pervasives_Native.Some l1 -> + let uu___2 = FStarC_Ident.range_of_lid l1 in + FStarC_Compiler_Range_Ops.string_of_range uu___2 + | FStar_Pervasives_Native.None -> "") + | FStar_Pervasives_Native.None -> "" in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Ident.string_of_lid l in + FStarC_Compiler_Util.format1 "Duplicate top-level names [%s]" + uu___3 in + FStarC_Errors_Msg.text uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Compiler_Util.format1 "Previously declared at %s" r in + FStarC_Errors_Msg.text uu___4 in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Errors.raise_error FStarC_Ident.hasrange_lident l + FStarC_Errors_Codes.Fatal_DuplicateTopLevelNames () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___) in + let globals = FStarC_Compiler_Util.mk_ref env1.scope_mods in + let env2 = + let uu___ = + match s.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_let uu___1 -> (false, true) + | FStarC_Syntax_Syntax.Sig_bundle uu___1 -> (false, true) + | uu___1 -> (false, false) in + match uu___ with + | (any_val, exclude_interface) -> + let lids = FStarC_Syntax_Util.lids_of_sigelt s in + let uu___1 = + FStarC_Compiler_Util.find_map lids + (fun l -> + let uu___2 = + let uu___3 = unique any_val exclude_interface env1 l in + Prims.op_Negation uu___3 in + if uu___2 + then FStar_Pervasives_Native.Some l + else FStar_Pervasives_Native.None) in + (match uu___1 with + | FStar_Pervasives_Native.Some l when fail_on_dup -> err l + | uu___2 -> + (extract_record env1 globals s; + { + curmodule = (env1.curmodule); + curmonad = (env1.curmonad); + modules = (env1.modules); + scope_mods = (env1.scope_mods); + exported_ids = (env1.exported_ids); + trans_exported_ids = (env1.trans_exported_ids); + includes = (env1.includes); + sigaccum = (s :: (env1.sigaccum)); + sigmap = (env1.sigmap); + iface = (env1.iface); + admitted_iface = (env1.admitted_iface); + expect_typ = (env1.expect_typ); + remaining_iface_decls = (env1.remaining_iface_decls); + syntax_only = (env1.syntax_only); + ds_hooks = (env1.ds_hooks); + dep_graph = (env1.dep_graph) + })) in + let env3 = + let uu___ = FStarC_Compiler_Effect.op_Bang globals in + { + curmodule = (env2.curmodule); + curmonad = (env2.curmonad); + modules = (env2.modules); + scope_mods = uu___; + exported_ids = (env2.exported_ids); + trans_exported_ids = (env2.trans_exported_ids); + includes = (env2.includes); + sigaccum = (env2.sigaccum); + sigmap = (env2.sigmap); + iface = (env2.iface); + admitted_iface = (env2.admitted_iface); + expect_typ = (env2.expect_typ); + remaining_iface_decls = (env2.remaining_iface_decls); + syntax_only = (env2.syntax_only); + ds_hooks = (env2.ds_hooks); + dep_graph = (env2.dep_graph) + } in + let uu___ = + match s.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_bundle + { FStarC_Syntax_Syntax.ses = ses; + FStarC_Syntax_Syntax.lids = uu___1;_} + -> + let uu___2 = + FStarC_Compiler_List.map + (fun se -> ((FStarC_Syntax_Util.lids_of_sigelt se), se)) + ses in + (env3, uu___2) + | uu___1 -> (env3, [((FStarC_Syntax_Util.lids_of_sigelt s), s)]) in + match uu___ with + | (env4, lss) -> + (FStarC_Compiler_List.iter + (fun uu___2 -> + match uu___2 with + | (lids, se) -> + FStarC_Compiler_List.iter + (fun lid -> + (let uu___4 = + let uu___5 = + let uu___6 = FStarC_Ident.ident_of_lid lid in + Top_level_def uu___6 in + let uu___6 = + FStarC_Compiler_Effect.op_Bang globals in + uu___5 :: uu___6 in + FStarC_Compiler_Effect.op_Colon_Equals globals + uu___4); + (match () with + | () -> + let modul = + let uu___4 = + let uu___5 = FStarC_Ident.ns_of_lid lid in + FStarC_Ident.lid_of_ids uu___5 in + FStarC_Ident.string_of_lid uu___4 in + ((let uu___5 = get_exported_id_set env4 modul in + match uu___5 with + | FStar_Pervasives_Native.Some f -> + let my_exported_ids = + f Exported_id_term_type in + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Ident.ident_of_lid lid in + FStarC_Ident.string_of_id uu___8 in + let uu___8 = + FStarC_Compiler_Effect.op_Bang + my_exported_ids in + Obj.magic + (FStarC_Class_Setlike.add () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) + uu___7 (Obj.magic uu___8)) in + FStarC_Compiler_Effect.op_Colon_Equals + my_exported_ids uu___6 + | FStar_Pervasives_Native.None -> ()); + (match () with + | () -> + let is_iface = + env4.iface && + (Prims.op_Negation + env4.admitted_iface) in + let uu___5 = + FStarC_Ident.string_of_lid lid in + FStarC_Compiler_Util.smap_add + (sigmap env4) uu___5 + (se, + (env4.iface && + (Prims.op_Negation + env4.admitted_iface))))))) + lids) lss; + (let env5 = + let uu___2 = FStarC_Compiler_Effect.op_Bang globals in + { + curmodule = (env4.curmodule); + curmonad = (env4.curmonad); + modules = (env4.modules); + scope_mods = uu___2; + exported_ids = (env4.exported_ids); + trans_exported_ids = (env4.trans_exported_ids); + includes = (env4.includes); + sigaccum = (env4.sigaccum); + sigmap = (env4.sigmap); + iface = (env4.iface); + admitted_iface = (env4.admitted_iface); + expect_typ = (env4.expect_typ); + remaining_iface_decls = (env4.remaining_iface_decls); + syntax_only = (env4.syntax_only); + ds_hooks = (env4.ds_hooks); + dep_graph = (env4.dep_graph) + } in + env5)) +let (push_sigelt : env -> FStarC_Syntax_Syntax.sigelt -> env) = + fun env1 -> fun se -> push_sigelt' true env1 se +let (push_sigelt_force : env -> FStarC_Syntax_Syntax.sigelt -> env) = + fun env1 -> fun se -> push_sigelt' false env1 se +let (find_data_constructors_for_typ : + env -> + FStarC_Ident.lident -> + FStarC_Ident.lident Prims.list FStar_Pervasives_Native.option) + = + fun env1 -> + fun lid -> + let k_global_def lid1 uu___ = + match uu___ with + | ({ + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = uu___1; + FStarC_Syntax_Syntax.us = uu___2; + FStarC_Syntax_Syntax.params = uu___3; + FStarC_Syntax_Syntax.num_uniform_params = uu___4; + FStarC_Syntax_Syntax.t = uu___5; + FStarC_Syntax_Syntax.mutuals = uu___6; + FStarC_Syntax_Syntax.ds = ds; + FStarC_Syntax_Syntax.injective_type_params = uu___7;_}; + FStarC_Syntax_Syntax.sigrng = uu___8; + FStarC_Syntax_Syntax.sigquals = uu___9; + FStarC_Syntax_Syntax.sigmeta = uu___10; + FStarC_Syntax_Syntax.sigattrs = uu___11; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___12; + FStarC_Syntax_Syntax.sigopts = uu___13;_}, + uu___14) -> FStar_Pervasives_Native.Some ds + | uu___1 -> FStar_Pervasives_Native.None in + resolve_in_open_namespaces' env1 lid + (fun uu___ -> FStar_Pervasives_Native.None) + (fun uu___ -> FStar_Pervasives_Native.None) k_global_def +let (find_binders_for_datacons : + env -> + FStarC_Ident.lident -> + FStarC_Ident.ident Prims.list FStar_Pervasives_Native.option) + = + fun env1 -> + fun lid -> + let k_global_def lid1 uu___ = + match uu___ with + | ({ + FStarC_Syntax_Syntax.sigel = FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = uu___1; + FStarC_Syntax_Syntax.us1 = uu___2; + FStarC_Syntax_Syntax.t1 = t; + FStarC_Syntax_Syntax.ty_lid = uu___3; + FStarC_Syntax_Syntax.num_ty_params = uu___4; + FStarC_Syntax_Syntax.mutuals1 = uu___5; + FStarC_Syntax_Syntax.injective_type_params1 = uu___6;_}; + FStarC_Syntax_Syntax.sigrng = uu___7; + FStarC_Syntax_Syntax.sigquals = uu___8; + FStarC_Syntax_Syntax.sigmeta = uu___9; + FStarC_Syntax_Syntax.sigattrs = uu___10; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___11; + FStarC_Syntax_Syntax.sigopts = uu___12;_}, + uu___13) -> + let uu___14 = + let uu___15 = + let uu___16 = FStarC_Syntax_Util.arrow_formals_comp_ln t in + FStar_Pervasives_Native.fst uu___16 in + FStarC_Compiler_List.map + (fun x -> + (x.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.ppname) + uu___15 in + FStar_Pervasives_Native.Some uu___14 + | uu___1 -> FStar_Pervasives_Native.None in + resolve_in_open_namespaces' env1 lid + (fun uu___ -> FStar_Pervasives_Native.None) + (fun uu___ -> FStar_Pervasives_Native.None) k_global_def +let elab_restriction : + 'uuuuu . + (env -> FStarC_Ident.lident -> FStarC_Syntax_Syntax.restriction -> 'uuuuu) + -> + env -> + FStarC_Ident.lident -> FStarC_Syntax_Syntax.restriction -> 'uuuuu + = + fun f -> + fun env1 -> + fun ns -> + fun restriction -> + match restriction with + | FStarC_Syntax_Syntax.Unrestricted -> f env1 ns restriction + | FStarC_Syntax_Syntax.AllowList l -> + let mk_lid id = + let uu___ = + let uu___1 = + let uu___2 = FStarC_Ident.qual_id ns id in + FStarC_Ident.ids_of_lid uu___2 in + FStarC_Ident.lid_of_ids uu___1 in + let uu___1 = FStarC_Ident.range_of_id id in + FStarC_Ident.set_lid_range uu___ uu___1 in + let name_exists id = + let lid = mk_lid id in + let uu___ = try_lookup_lid env1 lid in + match uu___ with + | FStar_Pervasives_Native.Some uu___1 -> true + | FStar_Pervasives_Native.None -> + let uu___1 = + try_lookup_record_or_dc_by_field_name env1 lid in + FStarC_Compiler_Util.is_some uu___1 in + let l1 = + let uu___ = + let uu___1 = + FStarC_Compiler_List.map + (fun uu___2 -> + match uu___2 with + | (id, renamed) -> + let with_id_range = + let uu___3 = + FStarC_Ident.range_of_id + (FStarC_Compiler_Util.dflt id renamed) in + FStarC_Ident.set_id_range uu___3 in + let uu___3 = + let uu___4 = mk_lid id in + find_data_constructors_for_typ env1 uu___4 in + (match uu___3 with + | FStar_Pervasives_Native.Some idents -> + FStarC_Compiler_List.map + (fun id1 -> + let uu___4 = + let uu___5 = + FStarC_Ident.ident_of_lid id1 in + with_id_range uu___5 in + (uu___4, FStar_Pervasives_Native.None)) + idents + | FStar_Pervasives_Native.None -> [])) l in + FStarC_Compiler_List.flatten uu___1 in + FStarC_Compiler_List.append l uu___ in + let l2 = + let constructor_lid_to_desugared_record_lids = + let uu___ = + let uu___1 = + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_list () () + (Obj.magic env1.modules) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + match uu___2 with + | (uu___3, + { FStarC_Syntax_Syntax.name = uu___4; + FStarC_Syntax_Syntax.declarations = + declarations; + FStarC_Syntax_Syntax.is_interface = + uu___5;_}) + -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_list () () + (Obj.magic declarations) + (fun uu___6 -> + (fun sigelt -> + let sigelt = Obj.magic sigelt in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_list + () () + (match sigelt.FStarC_Syntax_Syntax.sigel + with + | FStarC_Syntax_Syntax.Sig_bundle + { + FStarC_Syntax_Syntax.ses + = ses; + FStarC_Syntax_Syntax.lids + = uu___6;_} + -> Obj.magic ses + | uu___6 -> + Obj.magic []) + (fun uu___6 -> + (fun sigelt1 -> + let sigelt1 = + Obj.magic + sigelt1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_list + () () + (Obj.magic + (FStarC_Syntax_Util.lids_of_sigelt + sigelt1)) + (fun uu___6 + -> + (fun lid + -> + let lid = + Obj.magic + lid in + let uu___6 + = + FStarC_Syntax_Util.get_attribute + FStarC_Parser_Const.desugar_of_variant_record_lid + sigelt1.FStarC_Syntax_Syntax.sigattrs in + match uu___6 + with + | + FStar_Pervasives_Native.Some + (({ + FStarC_Syntax_Syntax.n + = + FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_string + (s, + uu___7)); + FStarC_Syntax_Syntax.pos + = uu___8; + FStarC_Syntax_Syntax.vars + = uu___9; + FStarC_Syntax_Syntax.hash_code + = uu___10;_}, + FStar_Pervasives_Native.None)::[]) + -> + let uu___11 + = + let uu___12 + = + FStarC_Ident.lid_of_str + s in + (uu___12, + lid) in + Obj.magic + [uu___11] + | + uu___7 -> + Obj.magic + []) + uu___6))) + uu___6))) uu___6))) + uu___2)) in + FStarC_Compiler_List.filter + (fun uu___2 -> + match uu___2 with + | (cons, lid) -> + (let uu___3 = FStarC_Ident.ns_of_lid cons in + let uu___4 = FStarC_Ident.ns_of_lid lid in + FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq + (FStarC_Class_Ord.ord_list + FStarC_Syntax_Syntax.ord_ident)) uu___3 + uu___4) + && + (let uu___3 = FStarC_Ident.ns_of_lid lid in + let uu___4 = FStarC_Ident.ids_of_lid ns in + FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq + (FStarC_Class_Ord.ord_list + FStarC_Syntax_Syntax.ord_ident)) + uu___3 uu___4)) uu___1 in + FStarC_Compiler_List.map + (fun uu___1 -> + match uu___1 with + | (cons, lid) -> + let uu___2 = FStarC_Ident.ident_of_lid cons in + let uu___3 = FStarC_Ident.ident_of_lid lid in + (uu___2, uu___3)) uu___ in + let uu___ = + let uu___1 = + FStarC_Compiler_List.filter + (fun uu___2 -> + match uu___2 with + | (cons, uu___3) -> + let uu___4 = + FStarC_Compiler_List.find + (fun uu___5 -> + match uu___5 with + | (lid, uu___6) -> + FStarC_Class_Deq.op_Equals_Question + FStarC_Syntax_Syntax.deq_univ_name + lid cons) l1 in + FStar_Pervasives_Native.uu___is_Some uu___4) + constructor_lid_to_desugared_record_lids in + FStarC_Compiler_List.map + (fun uu___2 -> + match uu___2 with + | (uu___3, lid) -> (lid, FStar_Pervasives_Native.None)) + uu___1 in + FStarC_Compiler_List.append l1 uu___ in + let l3 = + let uu___ = + let uu___1 = + FStarC_Compiler_List.map + (fun uu___2 -> + match uu___2 with + | (id, renamed) -> + let with_renamed_range = + let uu___3 = + FStarC_Ident.range_of_id + (FStarC_Compiler_Util.dflt id renamed) in + FStarC_Ident.set_id_range uu___3 in + let with_id_range = + let uu___3 = + FStarC_Ident.range_of_id + (FStarC_Compiler_Util.dflt id renamed) in + FStarC_Ident.set_id_range uu___3 in + let lid = mk_lid id in + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + find_binders_for_datacons env1 lid in + match uu___6 with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some l4 -> l4 in + FStarC_Compiler_List.map + (fun binder -> + let uu___6 = + let uu___7 = + FStarC_Syntax_Util.mk_field_projector_name_from_ident + lid binder in + FStarC_Ident.ident_of_lid uu___7 in + let uu___7 = + FStarC_Compiler_Util.map_opt renamed + (fun renamed1 -> + let uu___8 = + let uu___9 = + FStarC_Ident.lid_of_ids + [renamed1] in + FStarC_Syntax_Util.mk_field_projector_name_from_ident + uu___9 binder in + FStarC_Ident.ident_of_lid uu___8) in + (uu___6, uu___7)) uu___5 in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Ident.lid_of_ids [id] in + FStarC_Syntax_Util.mk_discriminator + uu___11 in + let uu___11 = + FStarC_Compiler_Util.map_opt + renamed + (fun renamed1 -> + let uu___12 = + FStarC_Ident.lid_of_ids + [renamed1] in + FStarC_Syntax_Util.mk_discriminator + uu___12) in + (uu___10, uu___11) in + [uu___9] in + FStarC_Compiler_List.map + (fun uu___9 -> + match uu___9 with + | (x, y) -> + let uu___10 = + FStarC_Ident.ident_of_lid x in + let uu___11 = + FStarC_Compiler_Util.map_opt + y FStarC_Ident.ident_of_lid in + (uu___10, uu___11)) uu___8 in + FStarC_Compiler_List.filter + (fun uu___8 -> + match uu___8 with + | (x, uu___9) -> name_exists x) + uu___7 in + let uu___7 = + let uu___8 = + try_lookup_record_type env1 lid in + match uu___8 with + | FStar_Pervasives_Native.Some + { typename = uu___9; constrname; + parms = uu___10; fields; + is_private = uu___11; + is_record = uu___12;_} + -> + FStarC_Compiler_List.map + (fun uu___13 -> + match uu___13 with + | (id1, uu___14) -> + (id1, + FStar_Pervasives_Native.None)) + fields + | FStar_Pervasives_Native.None -> [] in + FStarC_Compiler_List.op_At uu___6 uu___7 in + FStarC_Compiler_List.op_At uu___4 uu___5 in + FStarC_Compiler_List.map + (fun uu___4 -> + match uu___4 with + | (id1, renamed1) -> + let uu___5 = with_id_range id1 in + let uu___6 = + FStarC_Compiler_Util.map_opt renamed1 + with_renamed_range in + (uu___5, uu___6)) uu___3) l2 in + FStarC_Compiler_List.flatten uu___1 in + FStarC_Compiler_List.append l2 uu___ in + ((let final_idents = + FStarC_Compiler_List.mapi + (fun i -> + fun uu___ -> + match uu___ with + | (id, renamed) -> + ((FStarC_Compiler_Util.dflt id renamed), i)) l3 in + let uu___ = + FStarC_Compiler_Util.find_dup + (fun uu___1 -> + fun uu___2 -> + match (uu___1, uu___2) with + | ((x, uu___3), (y, uu___4)) -> + FStarC_Class_Deq.op_Equals_Question + FStarC_Syntax_Syntax.deq_univ_name x y) + final_idents in + match uu___ with + | FStar_Pervasives_Native.Some (id, i) -> + let others = + FStarC_Compiler_List.filter + (fun uu___1 -> + match uu___1 with + | (id', i') -> + (FStarC_Class_Deq.op_Equals_Question + FStarC_Syntax_Syntax.deq_univ_name id id') + && + (let uu___2 = + FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq + FStarC_Class_Ord.ord_int) i i' in + Prims.op_Negation uu___2)) final_idents in + ((let uu___2 = + FStarC_Compiler_List.mapi + (fun nth -> + fun uu___3 -> + match uu___3 with + | (other, uu___4) -> + let nth1 = + match nth with + | uu___5 when uu___5 = Prims.int_zero -> + "first" + | uu___5 when uu___5 = Prims.int_one -> + "second" + | uu___5 when + uu___5 = (Prims.of_int (2)) -> + "third" + | nth2 -> + let uu___5 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + (nth2 + Prims.int_one) in + Prims.strcat uu___5 "th" in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Class_Show.show + FStarC_Ident.showable_ident + other in + Prims.strcat uu___8 + (Prims.strcat " " + (Prims.strcat nth1 + " occurence comes from this declaration")) in + FStarC_Errors_Msg.text uu___7 in + [uu___6] in + let uu___6 = + let uu___7 = + FStarC_Ident.range_of_id other in + FStar_Pervasives_Native.Some uu___7 in + { + FStarC_Errors.issue_msg = uu___5; + FStarC_Errors.issue_level = + FStarC_Errors.EError; + FStarC_Errors.issue_range = uu___6; + FStarC_Errors.issue_number = + FStar_Pervasives_Native.None; + FStarC_Errors.issue_ctx = [] + }) others in + FStarC_Errors.add_issues uu___2); + (let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + ((FStarC_Compiler_List.length others) + + Prims.int_one) in + Prims.strcat uu___5 " times" in + Prims.strcat "The name %s was imported " uu___4 in + let uu___4 = FStarC_Ident.string_of_id id in + FStarC_Compiler_Util.format1 uu___3 uu___4 in + FStarC_Errors.raise_error FStarC_Ident.hasrange_ident + id FStarC_Errors_Codes.Fatal_DuplicateTopLevelNames + () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2))) + | FStar_Pervasives_Native.None -> ()); + FStarC_Compiler_List.iter + (fun uu___1 -> + match uu___1 with + | (id, _renamed) -> + let uu___2 = + let uu___3 = name_exists id in + Prims.op_Negation uu___3 in + if uu___2 + then + let uu___3 = + let uu___4 = + let uu___5 = mk_lid id in + FStarC_Ident.string_of_lid uu___5 in + FStarC_Compiler_Util.format1 + "Definition %s cannot be found" uu___4 in + FStarC_Errors.raise_error + FStarC_Ident.hasrange_ident id + FStarC_Errors_Codes.Fatal_NameNotFound () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___3) + else ()) l3; + f env1 ns (FStarC_Syntax_Syntax.AllowList l3)) +let (push_namespace' : + env -> FStarC_Ident.lident -> FStarC_Syntax_Syntax.restriction -> env) = + fun env1 -> + fun ns -> + fun restriction -> + let uu___ = + let uu___1 = resolve_module_name env1 ns false in + match uu___1 with + | FStar_Pervasives_Native.None -> + let module_names = + FStarC_Compiler_List.map FStar_Pervasives_Native.fst + env1.modules in + let module_names1 = + match env1.curmodule with + | FStar_Pervasives_Native.None -> module_names + | FStar_Pervasives_Native.Some l -> l :: module_names in + let uu___2 = + FStarC_Compiler_Util.for_some + (fun m -> + let uu___3 = + let uu___4 = FStarC_Ident.string_of_lid m in + Prims.strcat uu___4 "." in + let uu___4 = + let uu___5 = FStarC_Ident.string_of_lid ns in + Prims.strcat uu___5 "." in + FStarC_Compiler_Util.starts_with uu___3 uu___4) + module_names1 in + if uu___2 + then (ns, FStarC_Syntax_Syntax.Open_namespace) + else + (let uu___4 = + let uu___5 = FStarC_Ident.string_of_lid ns in + FStarC_Compiler_Util.format1 + "Namespace %s cannot be found" uu___5 in + FStarC_Errors.raise_error FStarC_Ident.hasrange_lident ns + FStarC_Errors_Codes.Fatal_NameSpaceNotFound () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4)) + | FStar_Pervasives_Native.Some ns' -> + (ns', FStarC_Syntax_Syntax.Open_module) in + match uu___ with + | (ns', kd) -> + ((env1.ds_hooks).ds_push_open_hook env1 (ns', kd, restriction); + push_scope_mod env1 + (Open_module_or_namespace (ns', kd, restriction))) +let (push_include' : + env -> FStarC_Ident.lident -> FStarC_Syntax_Syntax.restriction -> env) = + fun env1 -> + fun ns -> + fun restriction -> + let ns0 = ns in + let uu___ = resolve_module_name env1 ns false in + match uu___ with + | FStar_Pervasives_Native.Some ns1 -> + ((env1.ds_hooks).ds_push_include_hook env1 ns1; + (let env2 = + push_scope_mod env1 + (Open_module_or_namespace + (ns1, FStarC_Syntax_Syntax.Open_module, restriction)) in + let curmod = + let uu___2 = current_module env2 in + FStarC_Ident.string_of_lid uu___2 in + (let uu___3 = + FStarC_Compiler_Util.smap_try_find env2.includes curmod in + match uu___3 with + | FStar_Pervasives_Native.None -> () + | FStar_Pervasives_Native.Some incl -> + let uu___4 = + let uu___5 = FStarC_Compiler_Effect.op_Bang incl in + (ns1, restriction) :: uu___5 in + FStarC_Compiler_Effect.op_Colon_Equals incl uu___4); + (match () with + | () -> + let uu___3 = + let uu___4 = FStarC_Ident.string_of_lid ns1 in + get_trans_exported_id_set env2 uu___4 in + (match uu___3 with + | FStar_Pervasives_Native.Some ns_trans_exports -> + ((let uu___5 = + let uu___6 = get_exported_id_set env2 curmod in + let uu___7 = + get_trans_exported_id_set env2 curmod in + (uu___6, uu___7) in + match uu___5 with + | (FStar_Pervasives_Native.Some cur_exports, + FStar_Pervasives_Native.Some cur_trans_exports) + -> + let update_exports k = + let ns_ex = + let uu___6 = ns_trans_exports k in + FStarC_Compiler_Effect.op_Bang uu___6 in + let ex = cur_exports k in + (let uu___7 = + let uu___8 = + FStarC_Compiler_Effect.op_Bang ex in + Obj.magic + (FStarC_Class_Setlike.diff () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) + (Obj.magic uu___8) (Obj.magic ns_ex)) in + FStarC_Compiler_Effect.op_Colon_Equals ex + uu___7); + (match () with + | () -> + let trans_ex = cur_trans_exports k in + let uu___8 = + let uu___9 = + FStarC_Compiler_Effect.op_Bang + trans_ex in + Obj.magic + (FStarC_Class_Setlike.union () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) + (Obj.magic uu___9) + (Obj.magic ns_ex)) in + FStarC_Compiler_Effect.op_Colon_Equals + trans_ex uu___8) in + FStarC_Compiler_List.iter update_exports + all_exported_id_kinds + | uu___6 -> ()); + (match () with | () -> env2)) + | FStar_Pervasives_Native.None -> + let uu___4 = + let uu___5 = FStarC_Ident.string_of_lid ns1 in + FStarC_Compiler_Util.format1 + "include: Module %s was not prepared" uu___5 in + FStarC_Errors.raise_error + FStarC_Ident.hasrange_lident ns1 + FStarC_Errors_Codes.Fatal_IncludeModuleNotPrepared + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4))))) + | uu___1 -> + let uu___2 = + let uu___3 = FStarC_Ident.string_of_lid ns in + FStarC_Compiler_Util.format1 + "include: Module %s cannot be found" uu___3 in + FStarC_Errors.raise_error FStarC_Ident.hasrange_lident ns + FStarC_Errors_Codes.Fatal_ModuleNotFound () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2) +let (push_namespace : + env -> FStarC_Ident.lident -> FStarC_Syntax_Syntax.restriction -> env) = + elab_restriction push_namespace' +let (push_include : + env -> FStarC_Ident.lident -> FStarC_Syntax_Syntax.restriction -> env) = + elab_restriction push_include' +let (push_module_abbrev : + env -> FStarC_Ident.ident -> FStarC_Ident.lident -> env) = + fun env1 -> + fun x -> + fun l -> + let uu___ = module_is_defined env1 l in + if uu___ + then + ((env1.ds_hooks).ds_push_module_abbrev_hook env1 x l; + push_scope_mod env1 (Module_abbrev (x, l))) + else + (let uu___2 = + let uu___3 = FStarC_Ident.string_of_lid l in + FStarC_Compiler_Util.format1 "Module %s cannot be found" uu___3 in + FStarC_Errors.raise_error FStarC_Ident.hasrange_lident l + FStarC_Errors_Codes.Fatal_ModuleNotFound () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)) +let (check_admits : + env -> FStarC_Syntax_Syntax.modul -> FStarC_Syntax_Syntax.modul) = + fun env1 -> + fun m -> + let admitted_sig_lids = + FStarC_Compiler_List.fold_left + (fun lids -> + fun se -> + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_declare_typ + { FStarC_Syntax_Syntax.lid2 = l; + FStarC_Syntax_Syntax.us2 = u; + FStarC_Syntax_Syntax.t2 = t;_} + when + Prims.op_Negation + (FStarC_Compiler_List.contains + FStarC_Syntax_Syntax.Assumption + se.FStarC_Syntax_Syntax.sigquals) + -> + let uu___ = + let uu___1 = FStarC_Ident.string_of_lid l in + FStarC_Compiler_Util.smap_try_find (sigmap env1) uu___1 in + (match uu___ with + | FStar_Pervasives_Native.Some + ({ + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_let uu___1; + FStarC_Syntax_Syntax.sigrng = uu___2; + FStarC_Syntax_Syntax.sigquals = uu___3; + FStarC_Syntax_Syntax.sigmeta = uu___4; + FStarC_Syntax_Syntax.sigattrs = uu___5; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___6; + FStarC_Syntax_Syntax.sigopts = uu___7;_}, + uu___8) + -> lids + | FStar_Pervasives_Native.Some + ({ + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_inductive_typ uu___1; + FStarC_Syntax_Syntax.sigrng = uu___2; + FStarC_Syntax_Syntax.sigquals = uu___3; + FStarC_Syntax_Syntax.sigmeta = uu___4; + FStarC_Syntax_Syntax.sigattrs = uu___5; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___6; + FStarC_Syntax_Syntax.sigopts = uu___7;_}, + uu___8) + -> lids + | FStar_Pervasives_Native.Some + ({ + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_splice uu___1; + FStarC_Syntax_Syntax.sigrng = uu___2; + FStarC_Syntax_Syntax.sigquals = uu___3; + FStarC_Syntax_Syntax.sigmeta = uu___4; + FStarC_Syntax_Syntax.sigattrs = uu___5; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___6; + FStarC_Syntax_Syntax.sigopts = uu___7;_}, + uu___8) + -> lids + | uu___1 -> + ((let uu___3 = + let uu___4 = FStarC_Options.interactive () in + Prims.op_Negation uu___4 in + if uu___3 + then + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident l in + FStarC_Pprint.doc_of_string uu___7 in + let uu___7 = + FStarC_Errors_Msg.text + "is declared but no definition was found" in + FStarC_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in + let uu___6 = + let uu___7 = + FStarC_Errors_Msg.text + "Add an 'assume' if this is intentional" in + [uu___7] in + uu___5 :: uu___6 in + FStarC_Errors.log_issue + FStarC_Ident.hasrange_lident l + FStarC_Errors_Codes.Error_AdmitWithoutDefinition + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___4) + else ()); + (let quals = FStarC_Syntax_Syntax.Assumption :: + (se.FStarC_Syntax_Syntax.sigquals) in + (let uu___4 = FStarC_Ident.string_of_lid l in + FStarC_Compiler_Util.smap_add (sigmap env1) uu___4 + ({ + FStarC_Syntax_Syntax.sigel = + (se.FStarC_Syntax_Syntax.sigel); + FStarC_Syntax_Syntax.sigrng = + (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = quals; + FStarC_Syntax_Syntax.sigmeta = + (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se.FStarC_Syntax_Syntax.sigopts) + }, false)); + l + :: + lids))) + | uu___ -> lids) [] env1.sigaccum in + m +let (finish : env -> FStarC_Syntax_Syntax.modul -> env) = + fun env1 -> + fun modul -> + FStarC_Compiler_List.iter + (fun se -> + let quals = se.FStarC_Syntax_Syntax.sigquals in + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_bundle + { FStarC_Syntax_Syntax.ses = ses; + FStarC_Syntax_Syntax.lids = uu___1;_} + -> + if + FStarC_Compiler_List.contains FStarC_Syntax_Syntax.Private + quals + then + FStarC_Compiler_List.iter + (fun se1 -> + match se1.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = lid; + FStarC_Syntax_Syntax.us1 = uu___2; + FStarC_Syntax_Syntax.t1 = uu___3; + FStarC_Syntax_Syntax.ty_lid = uu___4; + FStarC_Syntax_Syntax.num_ty_params = uu___5; + FStarC_Syntax_Syntax.mutuals1 = uu___6; + FStarC_Syntax_Syntax.injective_type_params1 = + uu___7;_} + -> + let uu___8 = FStarC_Ident.string_of_lid lid in + FStarC_Compiler_Util.smap_remove (sigmap env1) + uu___8 + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = lid; + FStarC_Syntax_Syntax.us = univ_names; + FStarC_Syntax_Syntax.params = binders; + FStarC_Syntax_Syntax.num_uniform_params = uu___2; + FStarC_Syntax_Syntax.t = typ; + FStarC_Syntax_Syntax.mutuals = uu___3; + FStarC_Syntax_Syntax.ds = uu___4; + FStarC_Syntax_Syntax.injective_type_params = + uu___5;_} + -> + ((let uu___7 = FStarC_Ident.string_of_lid lid in + FStarC_Compiler_Util.smap_remove (sigmap env1) + uu___7); + if + Prims.op_Negation + (FStarC_Compiler_List.contains + FStarC_Syntax_Syntax.Private quals) + then + (let sigel = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Syntax_Syntax.mk_Total typ in + { + FStarC_Syntax_Syntax.bs1 = binders; + FStarC_Syntax_Syntax.comp = uu___11 + } in + FStarC_Syntax_Syntax.Tm_arrow uu___10 in + let uu___10 = + FStarC_Ident.range_of_lid lid in + FStarC_Syntax_Syntax.mk uu___9 uu___10 in + { + FStarC_Syntax_Syntax.lid2 = lid; + FStarC_Syntax_Syntax.us2 = univ_names; + FStarC_Syntax_Syntax.t2 = uu___8 + } in + FStarC_Syntax_Syntax.Sig_declare_typ uu___7 in + let se2 = + { + FStarC_Syntax_Syntax.sigel = sigel; + FStarC_Syntax_Syntax.sigrng = + (se1.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (FStarC_Syntax_Syntax.Assumption :: + quals); + FStarC_Syntax_Syntax.sigmeta = + (se1.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se1.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se1.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se1.FStarC_Syntax_Syntax.sigopts) + } in + let uu___7 = FStarC_Ident.string_of_lid lid in + FStarC_Compiler_Util.smap_add (sigmap env1) + uu___7 (se2, false)) + else ()) + | uu___2 -> ()) ses + else () + | FStarC_Syntax_Syntax.Sig_declare_typ + { FStarC_Syntax_Syntax.lid2 = lid; + FStarC_Syntax_Syntax.us2 = uu___1; + FStarC_Syntax_Syntax.t2 = uu___2;_} + -> + if + FStarC_Compiler_List.contains FStarC_Syntax_Syntax.Private + quals + then + let uu___3 = FStarC_Ident.string_of_lid lid in + FStarC_Compiler_Util.smap_remove (sigmap env1) uu___3 + else () + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (uu___1, lbs); + FStarC_Syntax_Syntax.lids1 = uu___2;_} + -> + if + FStarC_Compiler_List.contains FStarC_Syntax_Syntax.Private + quals + then + FStarC_Compiler_List.iter + (fun lb -> + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Compiler_Util.right + lb.FStarC_Syntax_Syntax.lbname in + uu___6.FStarC_Syntax_Syntax.fv_name in + uu___5.FStarC_Syntax_Syntax.v in + FStarC_Ident.string_of_lid uu___4 in + FStarC_Compiler_Util.smap_remove (sigmap env1) uu___3) + lbs + else () + | uu___1 -> ()) modul.FStarC_Syntax_Syntax.declarations; + (let curmod = + let uu___1 = current_module env1 in + FStarC_Ident.string_of_lid uu___1 in + (let uu___2 = + let uu___3 = get_exported_id_set env1 curmod in + let uu___4 = get_trans_exported_id_set env1 curmod in + (uu___3, uu___4) in + match uu___2 with + | (FStar_Pervasives_Native.Some cur_ex, FStar_Pervasives_Native.Some + cur_trans_ex) -> + let update_exports eikind = + let cur_ex_set = + let uu___3 = cur_ex eikind in + FStarC_Compiler_Effect.op_Bang uu___3 in + let cur_trans_ex_set_ref = cur_trans_ex eikind in + let uu___3 = + let uu___4 = + FStarC_Compiler_Effect.op_Bang cur_trans_ex_set_ref in + Obj.magic + (FStarC_Class_Setlike.union () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_string)) + (Obj.magic cur_ex_set) (Obj.magic uu___4)) in + FStarC_Compiler_Effect.op_Colon_Equals cur_trans_ex_set_ref + uu___3 in + FStarC_Compiler_List.iter update_exports all_exported_id_kinds + | uu___3 -> ()); + (match () with + | () -> + (filter_record_cache (); + (match () with + | () -> + { + curmodule = FStar_Pervasives_Native.None; + curmonad = (env1.curmonad); + modules = (((modul.FStarC_Syntax_Syntax.name), modul) :: + (env1.modules)); + scope_mods = []; + exported_ids = (env1.exported_ids); + trans_exported_ids = (env1.trans_exported_ids); + includes = (env1.includes); + sigaccum = []; + sigmap = (env1.sigmap); + iface = (env1.iface); + admitted_iface = (env1.admitted_iface); + expect_typ = (env1.expect_typ); + remaining_iface_decls = (env1.remaining_iface_decls); + syntax_only = (env1.syntax_only); + ds_hooks = (env1.ds_hooks); + dep_graph = (env1.dep_graph) + })))) +let (stack : env Prims.list FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref [] +let (push : env -> env) = + fun env1 -> + FStarC_Compiler_Util.atomically + (fun uu___ -> + push_record_cache (); + (let uu___3 = + let uu___4 = FStarC_Compiler_Effect.op_Bang stack in env1 :: + uu___4 in + FStarC_Compiler_Effect.op_Colon_Equals stack uu___3); + (let uu___3 = FStarC_Compiler_Util.smap_copy env1.exported_ids in + let uu___4 = FStarC_Compiler_Util.smap_copy env1.trans_exported_ids in + let uu___5 = FStarC_Compiler_Util.smap_copy env1.includes in + let uu___6 = FStarC_Compiler_Util.smap_copy env1.sigmap in + { + curmodule = (env1.curmodule); + curmonad = (env1.curmonad); + modules = (env1.modules); + scope_mods = (env1.scope_mods); + exported_ids = uu___3; + trans_exported_ids = uu___4; + includes = uu___5; + sigaccum = (env1.sigaccum); + sigmap = uu___6; + iface = (env1.iface); + admitted_iface = (env1.admitted_iface); + expect_typ = (env1.expect_typ); + remaining_iface_decls = (env1.remaining_iface_decls); + syntax_only = (env1.syntax_only); + ds_hooks = (env1.ds_hooks); + dep_graph = (env1.dep_graph) + })) +let (pop : unit -> env) = + fun uu___ -> + FStarC_Compiler_Util.atomically + (fun uu___1 -> + let uu___2 = FStarC_Compiler_Effect.op_Bang stack in + match uu___2 with + | env1::tl -> + (pop_record_cache (); + FStarC_Compiler_Effect.op_Colon_Equals stack tl; + env1) + | uu___3 -> failwith "Impossible: Too many pops") +let (snapshot : env -> (Prims.int * env)) = + fun env1 -> FStarC_Common.snapshot push stack env1 +let (rollback : Prims.int FStar_Pervasives_Native.option -> env) = + fun depth -> FStarC_Common.rollback pop stack depth +let (export_interface : FStarC_Ident.lident -> env -> env) = + fun m -> + fun env1 -> + let sigelt_in_m se = + match FStarC_Syntax_Util.lids_of_sigelt se with + | l::uu___ -> + let uu___1 = FStarC_Ident.nsstr l in + let uu___2 = FStarC_Ident.string_of_lid m in uu___1 = uu___2 + | uu___ -> false in + let sm = sigmap env1 in + let env2 = pop () in + let keys = FStarC_Compiler_Util.smap_keys sm in + let sm' = sigmap env2 in + FStarC_Compiler_List.iter + (fun k -> + let uu___1 = FStarC_Compiler_Util.smap_try_find sm' k in + match uu___1 with + | FStar_Pervasives_Native.Some (se, true) when sigelt_in_m se -> + (FStarC_Compiler_Util.smap_remove sm' k; + (let se1 = + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_declare_typ + { FStarC_Syntax_Syntax.lid2 = l; + FStarC_Syntax_Syntax.us2 = u; + FStarC_Syntax_Syntax.t2 = t;_} + -> + { + FStarC_Syntax_Syntax.sigel = + (se.FStarC_Syntax_Syntax.sigel); + FStarC_Syntax_Syntax.sigrng = + (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (FStarC_Syntax_Syntax.Assumption :: + (se.FStarC_Syntax_Syntax.sigquals)); + FStarC_Syntax_Syntax.sigmeta = + (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se.FStarC_Syntax_Syntax.sigopts) + } + | uu___3 -> se in + FStarC_Compiler_Util.smap_add sm' k (se1, false))) + | uu___2 -> ()) keys; + env2 +let (finish_module_or_interface : + env -> FStarC_Syntax_Syntax.modul -> (env * FStarC_Syntax_Syntax.modul)) = + fun env1 -> + fun modul -> + let modul1 = + if Prims.op_Negation modul.FStarC_Syntax_Syntax.is_interface + then check_admits env1 modul + else modul in + let uu___ = finish env1 modul1 in (uu___, modul1) +type exported_ids = + { + exported_id_terms: string_set ; + exported_id_fields: string_set } +let (__proj__Mkexported_ids__item__exported_id_terms : + exported_ids -> string_set) = + fun projectee -> + match projectee with + | { exported_id_terms; exported_id_fields;_} -> exported_id_terms +let (__proj__Mkexported_ids__item__exported_id_fields : + exported_ids -> string_set) = + fun projectee -> + match projectee with + | { exported_id_terms; exported_id_fields;_} -> exported_id_fields +let (as_exported_ids : exported_id_set -> exported_ids) = + fun e -> + let terms = + let uu___ = e Exported_id_term_type in + FStarC_Compiler_Effect.op_Bang uu___ in + let fields = + let uu___ = e Exported_id_field in FStarC_Compiler_Effect.op_Bang uu___ in + { exported_id_terms = terms; exported_id_fields = fields } +let (as_exported_id_set : + exported_ids FStar_Pervasives_Native.option -> + exported_id_kind -> string_set FStarC_Compiler_Effect.ref) + = + fun e -> + match e with + | FStar_Pervasives_Native.None -> exported_id_set_new () + | FStar_Pervasives_Native.Some e1 -> + let terms = FStarC_Compiler_Util.mk_ref e1.exported_id_terms in + let fields = FStarC_Compiler_Util.mk_ref e1.exported_id_fields in + (fun uu___ -> + match uu___ with + | Exported_id_term_type -> terms + | Exported_id_field -> fields) +type module_inclusion_info = + { + mii_exported_ids: exported_ids FStar_Pervasives_Native.option ; + mii_trans_exported_ids: exported_ids FStar_Pervasives_Native.option ; + mii_includes: + (FStarC_Ident.lident * FStarC_Syntax_Syntax.restriction) Prims.list + FStar_Pervasives_Native.option + } +let (__proj__Mkmodule_inclusion_info__item__mii_exported_ids : + module_inclusion_info -> exported_ids FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { mii_exported_ids; mii_trans_exported_ids; mii_includes;_} -> + mii_exported_ids +let (__proj__Mkmodule_inclusion_info__item__mii_trans_exported_ids : + module_inclusion_info -> exported_ids FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { mii_exported_ids; mii_trans_exported_ids; mii_includes;_} -> + mii_trans_exported_ids +let (__proj__Mkmodule_inclusion_info__item__mii_includes : + module_inclusion_info -> + (FStarC_Ident.lident * FStarC_Syntax_Syntax.restriction) Prims.list + FStar_Pervasives_Native.option) + = + fun projectee -> + match projectee with + | { mii_exported_ids; mii_trans_exported_ids; mii_includes;_} -> + mii_includes +let (default_mii : module_inclusion_info) = + { + mii_exported_ids = FStar_Pervasives_Native.None; + mii_trans_exported_ids = FStar_Pervasives_Native.None; + mii_includes = FStar_Pervasives_Native.None + } +let as_includes : + 'uuuuu . + 'uuuuu Prims.list FStar_Pervasives_Native.option -> + 'uuuuu Prims.list FStarC_Compiler_Effect.ref + = + fun uu___ -> + match uu___ with + | FStar_Pervasives_Native.None -> FStarC_Compiler_Util.mk_ref [] + | FStar_Pervasives_Native.Some l -> FStarC_Compiler_Util.mk_ref l +let (inclusion_info : env -> FStarC_Ident.lident -> module_inclusion_info) = + fun env1 -> + fun l -> + let mname = FStarC_Ident.string_of_lid l in + let as_ids_opt m = + let uu___ = FStarC_Compiler_Util.smap_try_find m mname in + FStarC_Compiler_Util.map_opt uu___ as_exported_ids in + let uu___ = as_ids_opt env1.exported_ids in + let uu___1 = as_ids_opt env1.trans_exported_ids in + let uu___2 = + let uu___3 = FStarC_Compiler_Util.smap_try_find env1.includes mname in + FStarC_Compiler_Util.map_opt uu___3 + (fun r -> FStarC_Compiler_Effect.op_Bang r) in + { + mii_exported_ids = uu___; + mii_trans_exported_ids = uu___1; + mii_includes = uu___2 + } +let (prepare_module_or_interface : + Prims.bool -> + Prims.bool -> + env -> + FStarC_Ident.lident -> module_inclusion_info -> (env * Prims.bool)) + = + fun intf -> + fun admitted -> + fun env1 -> + fun mname -> + fun mii -> + let prep env2 = + let filename = + let uu___ = FStarC_Ident.string_of_lid mname in + FStarC_Compiler_Util.strcat uu___ ".fst" in + let auto_open = + FStarC_Parser_Dep.hard_coded_dependencies filename in + let auto_open1 = + let convert_kind uu___ = + match uu___ with + | FStarC_Parser_Dep.Open_namespace -> + FStarC_Syntax_Syntax.Open_namespace + | FStarC_Parser_Dep.Open_module -> + FStarC_Syntax_Syntax.Open_module in + FStarC_Compiler_List.map + (fun uu___ -> + match uu___ with + | (lid, kind) -> + (lid, (convert_kind kind), + FStarC_Syntax_Syntax.Unrestricted)) auto_open in + let namespace_of_module = + let uu___ = + let uu___1 = + let uu___2 = FStarC_Ident.ns_of_lid mname in + FStarC_Compiler_List.length uu___2 in + uu___1 > Prims.int_zero in + if uu___ + then + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Ident.ns_of_lid mname in + FStarC_Ident.lid_of_ids uu___3 in + (uu___2, FStarC_Syntax_Syntax.Open_namespace, + FStarC_Syntax_Syntax.Unrestricted) in + [uu___1] + else [] in + let auto_open2 = + FStarC_Compiler_List.op_At namespace_of_module + (FStarC_Compiler_List.rev auto_open1) in + (let uu___1 = FStarC_Ident.string_of_lid mname in + let uu___2 = as_exported_id_set mii.mii_exported_ids in + FStarC_Compiler_Util.smap_add env2.exported_ids uu___1 uu___2); + (match () with + | () -> + ((let uu___2 = FStarC_Ident.string_of_lid mname in + let uu___3 = + as_exported_id_set mii.mii_trans_exported_ids in + FStarC_Compiler_Util.smap_add env2.trans_exported_ids + uu___2 uu___3); + (match () with + | () -> + ((let uu___3 = FStarC_Ident.string_of_lid mname in + let uu___4 = as_includes mii.mii_includes in + FStarC_Compiler_Util.smap_add env2.includes uu___3 + uu___4); + (match () with + | () -> + let env' = + let uu___3 = + FStarC_Compiler_List.map + (fun x -> Open_module_or_namespace x) + auto_open2 in + { + curmodule = + (FStar_Pervasives_Native.Some mname); + curmonad = (env2.curmonad); + modules = (env2.modules); + scope_mods = uu___3; + exported_ids = (env2.exported_ids); + trans_exported_ids = + (env2.trans_exported_ids); + includes = (env2.includes); + sigaccum = (env2.sigaccum); + sigmap = (env2.sigmap); + iface = intf; + admitted_iface = admitted; + expect_typ = (env2.expect_typ); + remaining_iface_decls = + (env2.remaining_iface_decls); + syntax_only = (env2.syntax_only); + ds_hooks = (env2.ds_hooks); + dep_graph = (env2.dep_graph) + } in + (FStarC_Compiler_List.iter + (fun op -> + (env2.ds_hooks).ds_push_open_hook env' + op) + (FStarC_Compiler_List.rev auto_open2); + env')))))) in + let uu___ = + FStarC_Compiler_Util.find_opt + (fun uu___1 -> + match uu___1 with + | (l, uu___2) -> FStarC_Ident.lid_equals l mname) + env1.modules in + match uu___ with + | FStar_Pervasives_Native.None -> + let uu___1 = prep env1 in (uu___1, false) + | FStar_Pervasives_Native.Some (uu___1, m) -> + ((let uu___3 = + (let uu___4 = FStarC_Options.interactive () in + Prims.op_Negation uu___4) && + ((Prims.op_Negation m.FStarC_Syntax_Syntax.is_interface) + || intf) in + if uu___3 + then + let uu___4 = + let uu___5 = FStarC_Ident.string_of_lid mname in + FStarC_Compiler_Util.format1 + "Duplicate module or interface name: %s" uu___5 in + FStarC_Errors.raise_error FStarC_Ident.hasrange_lident + mname + FStarC_Errors_Codes.Fatal_DuplicateModuleOrInterface () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4) + else ()); + (let uu___3 = let uu___4 = push env1 in prep uu___4 in + (uu___3, true))) +let (enter_monad_scope : env -> FStarC_Ident.ident -> env) = + fun env1 -> + fun mname -> + match env1.curmonad with + | FStar_Pervasives_Native.Some mname' -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Ident.showable_ident mname in + let uu___3 = + let uu___4 = + FStarC_Class_Show.show FStarC_Ident.showable_ident mname' in + Prims.strcat ", but already in monad scope " uu___4 in + Prims.strcat uu___2 uu___3 in + Prims.strcat "Trying to define monad " uu___1 in + FStarC_Errors.raise_error FStarC_Ident.hasrange_ident mname + FStarC_Errors_Codes.Fatal_MonadAlreadyDefined () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___) + | FStar_Pervasives_Native.None -> + { + curmodule = (env1.curmodule); + curmonad = (FStar_Pervasives_Native.Some mname); + modules = (env1.modules); + scope_mods = (env1.scope_mods); + exported_ids = (env1.exported_ids); + trans_exported_ids = (env1.trans_exported_ids); + includes = (env1.includes); + sigaccum = (env1.sigaccum); + sigmap = (env1.sigmap); + iface = (env1.iface); + admitted_iface = (env1.admitted_iface); + expect_typ = (env1.expect_typ); + remaining_iface_decls = (env1.remaining_iface_decls); + syntax_only = (env1.syntax_only); + ds_hooks = (env1.ds_hooks); + dep_graph = (env1.dep_graph) + } +let fail_or : + 'a . + env -> + (FStarC_Ident.lident -> 'a FStar_Pervasives_Native.option) -> + FStarC_Ident.lident -> 'a + = + fun env1 -> + fun lookup -> + fun lid -> + let uu___ = lookup lid in + match uu___ with + | FStar_Pervasives_Native.Some r -> r + | FStar_Pervasives_Native.None -> + let opened_modules = + FStarC_Compiler_List.map + (fun uu___1 -> + match uu___1 with + | (lid1, uu___2) -> FStarC_Ident.string_of_lid lid1) + env1.modules in + let msg = + let uu___1 = + let uu___2 = FStarC_Ident.string_of_lid lid in + FStarC_Compiler_Util.format1 "Identifier not found: [%s]" + uu___2 in + FStarC_Errors_Msg.mkmsg uu___1 in + let msg1 = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Ident.ns_of_lid lid in + FStarC_Compiler_List.length uu___3 in + uu___2 = Prims.int_zero in + if uu___1 + then msg + else + (let modul = + let uu___3 = + let uu___4 = FStarC_Ident.ns_of_lid lid in + FStarC_Ident.lid_of_ids uu___4 in + let uu___4 = FStarC_Ident.range_of_lid lid in + FStarC_Ident.set_lid_range uu___3 uu___4 in + let subdoc d = + let uu___3 = + let uu___4 = FStarC_Pprint.align d in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.hardline uu___4 in + FStarC_Pprint.nest (Prims.of_int (2)) uu___3 in + let uu___3 = resolve_module_name env1 modul true in + match uu___3 with + | FStar_Pervasives_Native.None -> + let opened_modules1 = + FStarC_Errors_Msg.text + (FStarC_Compiler_String.concat ", " opened_modules) in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Ident.string_of_lid modul in + FStarC_Compiler_Util.format1 + "Could not resolve module name %s" uu___7 in + FStarC_Errors_Msg.text uu___6 in + [uu___5] in + FStarC_Compiler_List.op_At msg uu___4 + | FStar_Pervasives_Native.Some modul' when + let uu___4 = + FStarC_Compiler_List.existsb + (fun m -> + let uu___5 = FStarC_Ident.string_of_lid modul' in + m = uu___5) opened_modules in + Prims.op_Negation uu___4 -> + let opened_modules1 = + FStarC_Errors_Msg.text + (FStarC_Compiler_String.concat ", " opened_modules) in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Ident.string_of_lid modul in + let uu___9 = FStarC_Ident.string_of_lid modul' in + FStarC_Compiler_Util.format2 + "Module %s resolved into %s, which does not belong to the list of modules in scope, namely:" + uu___8 uu___9 in + FStarC_Errors_Msg.text uu___7 in + let uu___7 = subdoc opened_modules1 in + FStarC_Pprint.op_Hat_Hat uu___6 uu___7 in + [uu___5] in + FStarC_Compiler_List.op_At msg uu___4 + | FStar_Pervasives_Native.Some modul' -> + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Ident.string_of_lid modul in + let uu___8 = FStarC_Ident.string_of_lid modul' in + let uu___9 = + let uu___10 = FStarC_Ident.ident_of_lid lid in + FStarC_Ident.string_of_id uu___10 in + FStarC_Compiler_Util.format3 + "Module %s resolved into %s, definition %s not found" + uu___7 uu___8 uu___9 in + FStarC_Errors_Msg.text uu___6 in + [uu___5] in + FStarC_Compiler_List.op_At msg uu___4) in + FStarC_Errors.raise_error FStarC_Ident.hasrange_lident lid + FStarC_Errors_Codes.Fatal_IdentifierNotFound () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic msg1) +let fail_or2 : + 'a . + (FStarC_Ident.ident -> 'a FStar_Pervasives_Native.option) -> + FStarC_Ident.ident -> 'a + = + fun lookup -> + fun id -> + let uu___ = lookup id in + match uu___ with + | FStar_Pervasives_Native.None -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Ident.string_of_id id in + Prims.strcat uu___3 "]" in + Prims.strcat "Identifier not found [" uu___2 in + FStarC_Errors.raise_error FStarC_Ident.hasrange_ident id + FStarC_Errors_Codes.Fatal_IdentifierNotFound () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) + | FStar_Pervasives_Native.Some r -> r +let (resolve_name : + env -> + FStarC_Ident.lident -> + (FStarC_Syntax_Syntax.bv, FStarC_Syntax_Syntax.fv) + FStar_Pervasives.either FStar_Pervasives_Native.option) + = + fun e -> + fun name -> + let uu___ = try_lookup_name false false e name in + match uu___ with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (Term_name (e1, attrs)) -> + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress e1 in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_name n -> + FStar_Pervasives_Native.Some (FStar_Pervasives.Inl n) + | FStarC_Syntax_Syntax.Tm_fvar fv -> + FStar_Pervasives_Native.Some (FStar_Pervasives.Inr fv) + | uu___2 -> FStar_Pervasives_Native.None) + | FStar_Pervasives_Native.Some (Eff_name (se, l)) -> + let uu___1 = + let uu___2 = + FStarC_Syntax_Syntax.lid_and_dd_as_fv l + FStar_Pervasives_Native.None in + FStar_Pervasives.Inr uu___2 in + FStar_Pervasives_Native.Some uu___1 \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Syntax_Embeddings.ml b/ocaml/fstar-lib/generated/FStarC_Syntax_Embeddings.ml new file mode 100644 index 00000000000..07f279cd99a --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Syntax_Embeddings.ml @@ -0,0 +1,3207 @@ +open Prims +let (id_norm_cb : FStarC_Syntax_Embeddings_Base.norm_cb) = + fun uu___ -> + match uu___ with + | FStar_Pervasives.Inr x -> x + | FStar_Pervasives.Inl l -> + let uu___1 = + FStarC_Syntax_Syntax.lid_as_fv l FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___1 +exception Embedding_failure +let (uu___is_Embedding_failure : Prims.exn -> Prims.bool) = + fun projectee -> + match projectee with | Embedding_failure -> true | uu___ -> false +exception Unembedding_failure +let (uu___is_Unembedding_failure : Prims.exn -> Prims.bool) = + fun projectee -> + match projectee with | Unembedding_failure -> true | uu___ -> false +let (map_shadow : + FStarC_Syntax_Embeddings_Base.shadow_term -> + (FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) -> + FStarC_Syntax_Embeddings_Base.shadow_term) + = fun s -> fun f -> FStarC_Compiler_Util.map_opt s (FStarC_Thunk.map f) +let (force_shadow : + FStarC_Syntax_Embeddings_Base.shadow_term -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = fun s -> FStarC_Compiler_Util.map_opt s FStarC_Thunk.force +type 'a printer = 'a -> Prims.string +let unknown_printer : + 'uuuuu . FStarC_Syntax_Syntax.typ -> 'uuuuu -> Prims.string = + fun typ -> + fun uu___ -> + let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term typ in + FStarC_Compiler_Util.format1 "unknown %s" uu___1 +let (term_as_fv : FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.fv) = + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_fvar fv -> fv + | uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.format1 "Embeddings not defined for type %s" + uu___3 in + failwith uu___2 +let lazy_embed : + 'a . + 'a printer -> + (unit -> FStarC_Syntax_Syntax.emb_typ) -> + FStarC_Compiler_Range_Type.range -> + (unit -> FStarC_Syntax_Syntax.term) -> + 'a -> + (unit -> FStarC_Syntax_Syntax.term) -> + FStarC_Syntax_Syntax.term + = + fun pa -> + fun et -> + fun rng -> + fun ta -> + fun x -> + fun f -> + (let uu___1 = + FStarC_Compiler_Effect.op_Bang + FStarC_Options.debug_embedding in + if uu___1 + then + let uu___2 = + let uu___3 = ta () in + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + uu___3 in + let uu___3 = + let uu___4 = et () in + FStarC_Class_Show.show + FStarC_Syntax_Syntax.showable_emb_typ uu___4 in + let uu___4 = pa x in + FStarC_Compiler_Util.print3 + "Embedding a %s\n\temb_typ=%s\n\tvalue is %s\n" uu___2 + uu___3 uu___4 + else ()); + (let uu___1 = + FStarC_Compiler_Effect.op_Bang + FStarC_Options.eager_embedding in + if uu___1 + then f () + else + (let thunk = FStarC_Thunk.mk f in + let uu___3 = + let uu___4 = let uu___5 = et () in (uu___5, thunk) in + FStarC_Syntax_Syntax.Lazy_embedding uu___4 in + FStarC_Syntax_Util.mk_lazy x FStarC_Syntax_Syntax.tun + uu___3 (FStar_Pervasives_Native.Some rng))) +let lazy_unembed : + 'a . + 'a printer -> + (unit -> FStarC_Syntax_Syntax.emb_typ) -> + FStarC_Syntax_Syntax.term -> + (unit -> FStarC_Syntax_Syntax.term) -> + (FStarC_Syntax_Syntax.term -> 'a FStar_Pervasives_Native.option) + -> 'a FStar_Pervasives_Native.option + = + fun pa -> + fun et -> + fun x -> + fun ta -> + fun f -> + let et1 = et () in + let x1 = FStarC_Syntax_Embeddings_Base.unmeta_div_results x in + match x1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_lazy + { FStarC_Syntax_Syntax.blob = b; + FStarC_Syntax_Syntax.lkind = + FStarC_Syntax_Syntax.Lazy_embedding (et', t); + FStarC_Syntax_Syntax.ltyp = uu___; + FStarC_Syntax_Syntax.rng = uu___1;_} + -> + let uu___2 = + (et1 <> et') || + (FStarC_Compiler_Effect.op_Bang + FStarC_Options.eager_embedding) in + if uu___2 + then + let res = let uu___3 = FStarC_Thunk.force t in f uu___3 in + ((let uu___4 = + FStarC_Compiler_Effect.op_Bang + FStarC_Options.debug_embedding in + if uu___4 + then + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Syntax.showable_emb_typ et1 in + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Syntax.showable_emb_typ et' in + let uu___7 = + match res with + | FStar_Pervasives_Native.None -> "None" + | FStar_Pervasives_Native.Some x2 -> + let uu___8 = pa x2 in Prims.strcat "Some " uu___8 in + FStarC_Compiler_Util.print3 + "Unembed cancellation failed\n\t%s <> %s\nvalue is %s\n" + uu___5 uu___6 uu___7 + else ()); + res) + else + (let a1 = FStarC_Dyn.undyn b in + (let uu___5 = + FStarC_Compiler_Effect.op_Bang + FStarC_Options.debug_embedding in + if uu___5 + then + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Syntax.showable_emb_typ et1 in + let uu___7 = pa a1 in + FStarC_Compiler_Util.print2 + "Unembed cancelled for %s\n\tvalue is %s\n" uu___6 + uu___7 + else ()); + FStar_Pervasives_Native.Some a1) + | uu___ -> + let aopt = f x1 in + ((let uu___2 = + FStarC_Compiler_Effect.op_Bang + FStarC_Options.debug_embedding in + if uu___2 + then + let uu___3 = + FStarC_Class_Show.show + FStarC_Syntax_Syntax.showable_emb_typ et1 in + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term x1 in + let uu___5 = + match aopt with + | FStar_Pervasives_Native.None -> "None" + | FStar_Pervasives_Native.Some a1 -> + let uu___6 = pa a1 in Prims.strcat "Some " uu___6 in + FStarC_Compiler_Util.print3 + "Unembedding:\n\temb_typ=%s\n\tterm is %s\n\tvalue is %s\n" + uu___3 uu___4 uu___5 + else ()); + aopt) +let (mk_any_emb : + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.term FStarC_Syntax_Embeddings_Base.embedding) + = + fun typ -> + let em t _r _shadow _norm = + (let uu___1 = + FStarC_Compiler_Effect.op_Bang FStarC_Options.debug_embedding in + if uu___1 + then + let uu___2 = unknown_printer typ t in + FStarC_Compiler_Util.print1 "Embedding abstract: %s\n" uu___2 + else ()); + t in + let un t _n = + (let uu___1 = + FStarC_Compiler_Effect.op_Bang FStarC_Options.debug_embedding in + if uu___1 + then + let uu___2 = unknown_printer typ t in + FStarC_Compiler_Util.print1 "Unembedding abstract: %s\n" uu___2 + else ()); + FStar_Pervasives_Native.Some t in + FStarC_Syntax_Embeddings_Base.mk_emb_full em un (fun uu___ -> typ) + (unknown_printer typ) (fun uu___ -> FStarC_Syntax_Syntax.ET_abstract) +let (e_any : + FStarC_Syntax_Syntax.term FStarC_Syntax_Embeddings_Base.embedding) = + let em t r _shadow _norm = + { + FStarC_Syntax_Syntax.n = (t.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = r; + FStarC_Syntax_Syntax.vars = (t.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = (t.FStarC_Syntax_Syntax.hash_code) + } in + let un t _n = FStar_Pervasives_Native.Some t in + FStarC_Syntax_Embeddings_Base.mk_emb_full em un + (fun uu___ -> FStarC_Syntax_Syntax.t_term) + (FStarC_Class_Show.show FStarC_Syntax_Print.showable_term) + (fun uu___ -> + let uu___1 = + let uu___2 = FStarC_Ident.string_of_lid FStarC_Parser_Const.term_lid in + (uu___2, []) in + FStarC_Syntax_Syntax.ET_app uu___1) +let (e_unit : unit FStarC_Syntax_Embeddings_Base.embedding) = + let em u rng _shadow _norm = + { + FStarC_Syntax_Syntax.n = + (FStarC_Syntax_Util.exp_unit.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = rng; + FStarC_Syntax_Syntax.vars = + (FStarC_Syntax_Util.exp_unit.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (FStarC_Syntax_Util.exp_unit.FStarC_Syntax_Syntax.hash_code) + } in + let un t0 _norm = + let t = FStarC_Syntax_Util.unascribe t0 in + match t.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_constant (FStarC_Const.Const_unit) -> + FStar_Pervasives_Native.Some () + | uu___ -> FStar_Pervasives_Native.None in + FStarC_Syntax_Embeddings_Base.mk_emb_full em un + (fun uu___ -> FStarC_Syntax_Syntax.t_unit) (fun uu___ -> "()") + (fun uu___ -> + let uu___1 = + let uu___2 = FStarC_Ident.string_of_lid FStarC_Parser_Const.unit_lid in + (uu___2, []) in + FStarC_Syntax_Syntax.ET_app uu___1) +let (e_bool : Prims.bool FStarC_Syntax_Embeddings_Base.embedding) = + let em b rng _shadow _norm = + let t = + if b + then FStarC_Syntax_Util.exp_true_bool + else FStarC_Syntax_Util.exp_false_bool in + { + FStarC_Syntax_Syntax.n = (t.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = rng; + FStarC_Syntax_Syntax.vars = (t.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = (t.FStarC_Syntax_Syntax.hash_code) + } in + let un t _norm = + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_constant (FStarC_Const.Const_bool b) -> + FStar_Pervasives_Native.Some b + | uu___1 -> FStar_Pervasives_Native.None in + FStarC_Syntax_Embeddings_Base.mk_emb_full em un + (fun uu___ -> FStarC_Syntax_Syntax.t_bool) + FStarC_Compiler_Util.string_of_bool + (fun uu___ -> + let uu___1 = + let uu___2 = FStarC_Ident.string_of_lid FStarC_Parser_Const.bool_lid in + (uu___2, []) in + FStarC_Syntax_Syntax.ET_app uu___1) +let (e_char : FStar_Char.char FStarC_Syntax_Embeddings_Base.embedding) = + let em c rng _shadow _norm = + let t = FStarC_Syntax_Util.exp_char c in + { + FStarC_Syntax_Syntax.n = (t.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = rng; + FStarC_Syntax_Syntax.vars = (t.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = (t.FStarC_Syntax_Syntax.hash_code) + } in + let un t _norm = + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_constant (FStarC_Const.Const_char c) -> + FStar_Pervasives_Native.Some c + | uu___1 -> FStar_Pervasives_Native.None in + FStarC_Syntax_Embeddings_Base.mk_emb_full em un + (fun uu___ -> FStarC_Syntax_Syntax.t_char) + FStarC_Compiler_Util.string_of_char + (fun uu___ -> + let uu___1 = + let uu___2 = FStarC_Ident.string_of_lid FStarC_Parser_Const.char_lid in + (uu___2, []) in + FStarC_Syntax_Syntax.ET_app uu___1) +let (e_int : FStarC_BigInt.t FStarC_Syntax_Embeddings_Base.embedding) = + let ty = FStarC_Syntax_Syntax.t_int in + let emb_t_int = + let uu___ = + let uu___1 = FStarC_Ident.string_of_lid FStarC_Parser_Const.int_lid in + (uu___1, []) in + FStarC_Syntax_Syntax.ET_app uu___ in + let em i rng _shadow _norm = + lazy_embed FStarC_BigInt.string_of_big_int (fun uu___ -> emb_t_int) rng + (fun uu___ -> ty) i + (fun uu___ -> + let uu___1 = FStarC_BigInt.string_of_big_int i in + FStarC_Syntax_Util.exp_int uu___1) in + let un t _norm = + lazy_unembed FStarC_BigInt.string_of_big_int (fun uu___ -> emb_t_int) t + (fun uu___ -> ty) + (fun t1 -> + match t1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_constant (FStarC_Const.Const_int + (s, uu___)) -> + let uu___1 = FStarC_BigInt.big_int_of_string s in + FStar_Pervasives_Native.Some uu___1 + | uu___ -> FStar_Pervasives_Native.None) in + FStarC_Syntax_Embeddings_Base.mk_emb_full em un (fun uu___ -> ty) + FStarC_BigInt.string_of_big_int (fun uu___ -> emb_t_int) +let (e_fsint : Prims.int FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Syntax_Embeddings_Base.embed_as e_int FStarC_BigInt.to_int_fs + FStarC_BigInt.of_int_fs FStar_Pervasives_Native.None +let (e_string : Prims.string FStarC_Syntax_Embeddings_Base.embedding) = + let emb_t_string = + let uu___ = + let uu___1 = FStarC_Ident.string_of_lid FStarC_Parser_Const.string_lid in + (uu___1, []) in + FStarC_Syntax_Syntax.ET_app uu___ in + let em s rng _shadow _norm = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_constant (FStarC_Const.Const_string (s, rng))) + rng in + let un t _norm = + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_constant (FStarC_Const.Const_string + (s, uu___1)) -> FStar_Pervasives_Native.Some s + | uu___1 -> FStar_Pervasives_Native.None in + FStarC_Syntax_Embeddings_Base.mk_emb_full em un + (fun uu___ -> FStarC_Syntax_Syntax.t_string) + (fun x -> Prims.strcat "\"" (Prims.strcat x "\"")) + (fun uu___ -> emb_t_string) +let (e_real : + FStarC_Compiler_Real.real FStarC_Syntax_Embeddings_Base.embedding) = + let ty = FStarC_Syntax_Syntax.t_real in + let emb_t_real = + let uu___ = + let uu___1 = FStarC_Ident.string_of_lid FStarC_Parser_Const.real_lid in + (uu___1, []) in + FStarC_Syntax_Syntax.ET_app uu___ in + let em r rng _shadow _norm = + let uu___ = r in + match uu___ with + | FStarC_Compiler_Real.Real s -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_constant (FStarC_Const.Const_real s)) rng in + let un t _norm = + let uu___ = + let uu___1 = FStarC_Syntax_Embeddings_Base.unmeta_div_results t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_constant (FStarC_Const.Const_real s) -> + FStar_Pervasives_Native.Some (FStarC_Compiler_Real.Real s) + | uu___1 -> FStar_Pervasives_Native.None in + FStarC_Syntax_Embeddings_Base.mk_emb_full em un (fun uu___ -> ty) + (fun uu___ -> "") (fun uu___ -> emb_t_real) +let e_option : + 'a . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'a FStar_Pervasives_Native.option + FStarC_Syntax_Embeddings_Base.embedding + = + fun ea -> + let typ uu___ = + let uu___1 = FStarC_Syntax_Embeddings_Base.type_of ea in + FStarC_Syntax_Syntax.t_option_of uu___1 in + let emb_t_option_a uu___ = + let uu___1 = + let uu___2 = + FStarC_Ident.string_of_lid FStarC_Parser_Const.option_lid in + let uu___3 = + let uu___4 = FStarC_Syntax_Embeddings_Base.emb_typ_of ea () in + [uu___4] in + (uu___2, uu___3) in + FStarC_Syntax_Syntax.ET_app uu___1 in + let printer1 x = + let uu___ = FStarC_Syntax_Embeddings_Base.printer_of ea in + FStarC_Common.string_of_option uu___ x in + let em o rng shadow norm = + lazy_embed printer1 emb_t_option_a rng + (fun uu___ -> + let uu___1 = FStarC_Syntax_Embeddings_Base.type_of ea in + FStarC_Syntax_Syntax.t_option_of uu___1) o + (fun uu___ -> + match o with + | FStar_Pervasives_Native.None -> + let uu___1 = + let uu___2 = + FStarC_Syntax_Syntax.tdataconstr + FStarC_Parser_Const.none_lid in + FStarC_Syntax_Syntax.mk_Tm_uinst uu___2 + [FStarC_Syntax_Syntax.U_zero] in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Embeddings_Base.type_of ea in + FStarC_Syntax_Syntax.iarg uu___4 in + [uu___3] in + FStarC_Syntax_Syntax.mk_Tm_app uu___1 uu___2 rng + | FStar_Pervasives_Native.Some a1 -> + let shadow_a = + map_shadow shadow + (fun t -> + let v = FStarC_Ident.mk_ident ("v", rng) in + let some_v = + FStarC_Syntax_Util.mk_field_projector_name_from_ident + FStarC_Parser_Const.some_lid v in + let some_v_tm = + let uu___1 = + FStarC_Syntax_Syntax.lid_as_fv some_v + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___1 in + let uu___1 = + FStarC_Syntax_Syntax.mk_Tm_uinst some_v_tm + [FStarC_Syntax_Syntax.U_zero] in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Syntax_Embeddings_Base.type_of ea in + FStarC_Syntax_Syntax.iarg uu___4 in + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.as_arg t in + [uu___5] in + uu___3 :: uu___4 in + FStarC_Syntax_Syntax.mk_Tm_app uu___1 uu___2 rng) in + let uu___1 = + let uu___2 = + FStarC_Syntax_Syntax.tdataconstr + FStarC_Parser_Const.some_lid in + FStarC_Syntax_Syntax.mk_Tm_uinst uu___2 + [FStarC_Syntax_Syntax.U_zero] in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Embeddings_Base.type_of ea in + FStarC_Syntax_Syntax.iarg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Syntax_Embeddings_Base.embed ea a1 in + uu___7 rng shadow_a norm in + FStarC_Syntax_Syntax.as_arg uu___6 in + [uu___5] in + uu___3 :: uu___4 in + FStarC_Syntax_Syntax.mk_Tm_app uu___1 uu___2 rng) in + let un t norm = + lazy_unembed printer1 emb_t_option_a t + (fun uu___ -> + let uu___1 = FStarC_Syntax_Embeddings_Base.type_of ea in + FStarC_Syntax_Syntax.t_option_of uu___1) + (fun t1 -> + let uu___ = FStarC_Syntax_Util.head_and_args_full t1 in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst hd in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, uu___2) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.none_lid + -> + FStar_Pervasives_Native.Some FStar_Pervasives_Native.None + | (FStarC_Syntax_Syntax.Tm_fvar fv, uu___2::(a1, uu___3)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.some_lid + -> + let uu___4 = + FStarC_Syntax_Embeddings_Base.try_unembed ea a1 norm in + FStarC_Compiler_Util.bind_opt uu___4 + (fun a2 -> + FStar_Pervasives_Native.Some + (FStar_Pervasives_Native.Some a2)) + | uu___2 -> FStar_Pervasives_Native.None)) in + FStarC_Syntax_Embeddings_Base.mk_emb_full em un typ printer1 + emb_t_option_a +let e_tuple2 : + 'a 'b . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'b FStarC_Syntax_Embeddings_Base.embedding -> + ('a * 'b) FStarC_Syntax_Embeddings_Base.embedding + = + fun ea -> + fun eb -> + let typ uu___ = + let uu___1 = FStarC_Syntax_Embeddings_Base.type_of ea in + let uu___2 = FStarC_Syntax_Embeddings_Base.type_of eb in + FStarC_Syntax_Syntax.t_tuple2_of uu___1 uu___2 in + let emb_t_pair uu___ = + let uu___1 = + let uu___2 = + FStarC_Ident.string_of_lid FStarC_Parser_Const.lid_tuple2 in + let uu___3 = + let uu___4 = FStarC_Syntax_Embeddings_Base.emb_typ_of ea () in + let uu___5 = + let uu___6 = FStarC_Syntax_Embeddings_Base.emb_typ_of eb () in + [uu___6] in + uu___4 :: uu___5 in + (uu___2, uu___3) in + FStarC_Syntax_Syntax.ET_app uu___1 in + let printer1 uu___ = + match uu___ with + | (x, y) -> + let uu___1 = + let uu___2 = FStarC_Syntax_Embeddings_Base.printer_of ea in + uu___2 x in + let uu___2 = + let uu___3 = FStarC_Syntax_Embeddings_Base.printer_of eb in + uu___3 y in + FStarC_Compiler_Util.format2 "(%s, %s)" uu___1 uu___2 in + let em x rng shadow norm = + lazy_embed printer1 emb_t_pair rng typ x + (fun uu___ -> + let proj i ab = + let proj_1 = + let uu___1 = + FStarC_Parser_Const.mk_tuple_data_lid (Prims.of_int (2)) + rng in + let uu___2 = + FStarC_Syntax_Syntax.null_bv FStarC_Syntax_Syntax.tun in + FStarC_Syntax_Util.mk_field_projector_name uu___1 uu___2 i in + let proj_1_tm = + let uu___1 = + FStarC_Syntax_Syntax.lid_as_fv proj_1 + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___1 in + let uu___1 = + FStarC_Syntax_Syntax.mk_Tm_uinst proj_1_tm + [FStarC_Syntax_Syntax.U_zero] in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Embeddings_Base.type_of ea in + FStarC_Syntax_Syntax.iarg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Syntax_Embeddings_Base.type_of eb in + FStarC_Syntax_Syntax.iarg uu___6 in + let uu___6 = + let uu___7 = FStarC_Syntax_Syntax.as_arg ab in [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + FStarC_Syntax_Syntax.mk_Tm_app uu___1 uu___2 rng in + let shadow_a = map_shadow shadow (proj Prims.int_one) in + let shadow_b = map_shadow shadow (proj (Prims.of_int (2))) in + let uu___1 = + let uu___2 = + FStarC_Syntax_Syntax.tdataconstr + FStarC_Parser_Const.lid_Mktuple2 in + FStarC_Syntax_Syntax.mk_Tm_uinst uu___2 + [FStarC_Syntax_Syntax.U_zero; FStarC_Syntax_Syntax.U_zero] in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Embeddings_Base.type_of ea in + FStarC_Syntax_Syntax.iarg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Syntax_Embeddings_Base.type_of eb in + FStarC_Syntax_Syntax.iarg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Syntax_Embeddings_Base.embed ea + (FStar_Pervasives_Native.fst x) in + uu___9 rng shadow_a norm in + FStarC_Syntax_Syntax.as_arg uu___8 in + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Syntax_Embeddings_Base.embed eb + (FStar_Pervasives_Native.snd x) in + uu___11 rng shadow_b norm in + FStarC_Syntax_Syntax.as_arg uu___10 in + [uu___9] in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + FStarC_Syntax_Syntax.mk_Tm_app uu___1 uu___2 rng) in + let un t norm = + lazy_unembed printer1 emb_t_pair t typ + (fun uu___ -> + (fun t1 -> + let uu___ = FStarC_Syntax_Util.head_and_args_full t1 in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst hd in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, + uu___2::uu___3::(a1, uu___4)::(b1, uu___5)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.lid_Mktuple2 + -> + Obj.magic + (Obj.repr + (let uu___6 = + FStarC_Syntax_Embeddings_Base.try_unembed ea + a1 norm in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () + (Obj.magic uu___6) + (fun uu___7 -> + (fun a2 -> + let a2 = Obj.magic a2 in + let uu___7 = + FStarC_Syntax_Embeddings_Base.try_unembed + eb b1 norm in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___7) + (fun uu___8 -> + (fun b2 -> + let b2 = Obj.magic b2 in + Obj.magic + (FStar_Pervasives_Native.Some + (a2, b2))) uu___8))) + uu___7))) + | uu___2 -> + Obj.magic (Obj.repr FStar_Pervasives_Native.None))) + uu___) in + FStarC_Syntax_Embeddings_Base.mk_emb_full em un typ printer1 emb_t_pair +let e_tuple3 : + 'a 'b 'c . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'b FStarC_Syntax_Embeddings_Base.embedding -> + 'c FStarC_Syntax_Embeddings_Base.embedding -> + ('a * 'b * 'c) FStarC_Syntax_Embeddings_Base.embedding + = + fun ea -> + fun eb -> + fun ec -> + let typ uu___ = + let uu___1 = FStarC_Syntax_Embeddings_Base.type_of ea in + let uu___2 = FStarC_Syntax_Embeddings_Base.type_of eb in + let uu___3 = FStarC_Syntax_Embeddings_Base.type_of ec in + FStarC_Syntax_Syntax.t_tuple3_of uu___1 uu___2 uu___3 in + let emb_t_pair uu___ = + let uu___1 = + let uu___2 = + FStarC_Ident.string_of_lid FStarC_Parser_Const.lid_tuple3 in + let uu___3 = + let uu___4 = FStarC_Syntax_Embeddings_Base.emb_typ_of ea () in + let uu___5 = + let uu___6 = FStarC_Syntax_Embeddings_Base.emb_typ_of eb () in + let uu___7 = + let uu___8 = FStarC_Syntax_Embeddings_Base.emb_typ_of ec () in + [uu___8] in + uu___6 :: uu___7 in + uu___4 :: uu___5 in + (uu___2, uu___3) in + FStarC_Syntax_Syntax.ET_app uu___1 in + let printer1 uu___ = + match uu___ with + | (x, y, z) -> + let uu___1 = + let uu___2 = FStarC_Syntax_Embeddings_Base.printer_of ea in + uu___2 x in + let uu___2 = + let uu___3 = FStarC_Syntax_Embeddings_Base.printer_of eb in + uu___3 y in + let uu___3 = + let uu___4 = FStarC_Syntax_Embeddings_Base.printer_of ec in + uu___4 z in + FStarC_Compiler_Util.format3 "(%s, %s, %s)" uu___1 uu___2 + uu___3 in + let em uu___ rng shadow norm = + match uu___ with + | (x1, x2, x3) -> + lazy_embed printer1 emb_t_pair rng typ (x1, x2, x3) + (fun uu___1 -> + let proj i abc = + let proj_i = + let uu___2 = + FStarC_Parser_Const.mk_tuple_data_lid + (Prims.of_int (3)) rng in + let uu___3 = + FStarC_Syntax_Syntax.null_bv + FStarC_Syntax_Syntax.tun in + FStarC_Syntax_Util.mk_field_projector_name uu___2 + uu___3 i in + let proj_i_tm = + let uu___2 = + FStarC_Syntax_Syntax.lid_as_fv proj_i + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___2 in + let uu___2 = + FStarC_Syntax_Syntax.mk_Tm_uinst proj_i_tm + [FStarC_Syntax_Syntax.U_zero] in + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Syntax_Embeddings_Base.type_of ea in + FStarC_Syntax_Syntax.iarg uu___5 in + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Syntax_Embeddings_Base.type_of eb in + FStarC_Syntax_Syntax.iarg uu___7 in + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Syntax_Embeddings_Base.type_of ec in + FStarC_Syntax_Syntax.iarg uu___9 in + let uu___9 = + let uu___10 = FStarC_Syntax_Syntax.as_arg abc in + [uu___10] in + uu___8 :: uu___9 in + uu___6 :: uu___7 in + uu___4 :: uu___5 in + FStarC_Syntax_Syntax.mk_Tm_app uu___2 uu___3 rng in + let shadow_a = map_shadow shadow (proj Prims.int_one) in + let shadow_b = map_shadow shadow (proj (Prims.of_int (2))) in + let shadow_c = map_shadow shadow (proj (Prims.of_int (3))) in + let uu___2 = + let uu___3 = + FStarC_Syntax_Syntax.tdataconstr + FStarC_Parser_Const.lid_Mktuple3 in + FStarC_Syntax_Syntax.mk_Tm_uinst uu___3 + [FStarC_Syntax_Syntax.U_zero; + FStarC_Syntax_Syntax.U_zero; + FStarC_Syntax_Syntax.U_zero] in + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Embeddings_Base.type_of ea in + FStarC_Syntax_Syntax.iarg uu___5 in + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Syntax_Embeddings_Base.type_of eb in + FStarC_Syntax_Syntax.iarg uu___7 in + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Syntax_Embeddings_Base.type_of ec in + FStarC_Syntax_Syntax.iarg uu___9 in + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Syntax_Embeddings_Base.embed ea x1 in + uu___12 rng shadow_a norm in + FStarC_Syntax_Syntax.as_arg uu___11 in + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_Syntax_Embeddings_Base.embed eb x2 in + uu___14 rng shadow_b norm in + FStarC_Syntax_Syntax.as_arg uu___13 in + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = + FStarC_Syntax_Embeddings_Base.embed ec + x3 in + uu___16 rng shadow_c norm in + FStarC_Syntax_Syntax.as_arg uu___15 in + [uu___14] in + uu___12 :: uu___13 in + uu___10 :: uu___11 in + uu___8 :: uu___9 in + uu___6 :: uu___7 in + uu___4 :: uu___5 in + FStarC_Syntax_Syntax.mk_Tm_app uu___2 uu___3 rng) in + let un t norm = + lazy_unembed printer1 emb_t_pair t typ + (fun uu___ -> + (fun t1 -> + let uu___ = FStarC_Syntax_Util.head_and_args_full t1 in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst hd in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, + uu___2::uu___3::uu___4::(a1, uu___5)::(b1, uu___6):: + (c1, uu___7)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.lid_Mktuple3 + -> + Obj.magic + (Obj.repr + (let uu___8 = + FStarC_Syntax_Embeddings_Base.try_unembed + ea a1 norm in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () + (Obj.magic uu___8) + (fun uu___9 -> + (fun a2 -> + let a2 = Obj.magic a2 in + let uu___9 = + FStarC_Syntax_Embeddings_Base.try_unembed + eb b1 norm in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___9) + (fun uu___10 -> + (fun b2 -> + let b2 = Obj.magic b2 in + let uu___10 = + FStarC_Syntax_Embeddings_Base.try_unembed + ec c1 norm in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () + (Obj.magic uu___10) + (fun uu___11 -> + (fun c2 -> + let c2 = + Obj.magic c2 in + Obj.magic + (FStar_Pervasives_Native.Some + (a2, b2, + c2))) + uu___11))) + uu___10))) uu___9))) + | uu___2 -> + Obj.magic (Obj.repr FStar_Pervasives_Native.None))) + uu___) in + FStarC_Syntax_Embeddings_Base.mk_emb_full em un typ printer1 + emb_t_pair +let e_tuple4 : + 'a 'b 'c 'd . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'b FStarC_Syntax_Embeddings_Base.embedding -> + 'c FStarC_Syntax_Embeddings_Base.embedding -> + 'd FStarC_Syntax_Embeddings_Base.embedding -> + ('a * 'b * 'c * 'd) FStarC_Syntax_Embeddings_Base.embedding + = + fun ea -> + fun eb -> + fun ec -> + fun ed -> + let typ uu___ = + let uu___1 = FStarC_Syntax_Embeddings_Base.type_of ea in + let uu___2 = FStarC_Syntax_Embeddings_Base.type_of eb in + let uu___3 = FStarC_Syntax_Embeddings_Base.type_of ec in + let uu___4 = FStarC_Syntax_Embeddings_Base.type_of ed in + FStarC_Syntax_Syntax.t_tuple4_of uu___1 uu___2 uu___3 uu___4 in + let emb_t_pair uu___ = + let uu___1 = + let uu___2 = + FStarC_Ident.string_of_lid FStarC_Parser_Const.lid_tuple4 in + let uu___3 = + let uu___4 = FStarC_Syntax_Embeddings_Base.emb_typ_of ea () in + let uu___5 = + let uu___6 = FStarC_Syntax_Embeddings_Base.emb_typ_of eb () in + let uu___7 = + let uu___8 = + FStarC_Syntax_Embeddings_Base.emb_typ_of ec () in + let uu___9 = + let uu___10 = + FStarC_Syntax_Embeddings_Base.emb_typ_of ed () in + [uu___10] in + uu___8 :: uu___9 in + uu___6 :: uu___7 in + uu___4 :: uu___5 in + (uu___2, uu___3) in + FStarC_Syntax_Syntax.ET_app uu___1 in + let printer1 uu___ = + match uu___ with + | (x, y, z, w) -> + let uu___1 = + let uu___2 = FStarC_Syntax_Embeddings_Base.printer_of ea in + uu___2 x in + let uu___2 = + let uu___3 = FStarC_Syntax_Embeddings_Base.printer_of eb in + uu___3 y in + let uu___3 = + let uu___4 = FStarC_Syntax_Embeddings_Base.printer_of ec in + uu___4 z in + let uu___4 = + let uu___5 = FStarC_Syntax_Embeddings_Base.printer_of ed in + uu___5 w in + FStarC_Compiler_Util.format4 "(%s, %s, %s, %s)" uu___1 uu___2 + uu___3 uu___4 in + let em uu___ rng shadow norm = + match uu___ with + | (x1, x2, x3, x4) -> + lazy_embed printer1 emb_t_pair rng typ (x1, x2, x3, x4) + (fun uu___1 -> + let proj i abcd = + let proj_i = + let uu___2 = + FStarC_Parser_Const.mk_tuple_data_lid + (Prims.of_int (4)) rng in + let uu___3 = + FStarC_Syntax_Syntax.null_bv + FStarC_Syntax_Syntax.tun in + FStarC_Syntax_Util.mk_field_projector_name uu___2 + uu___3 i in + let proj_i_tm = + let uu___2 = + FStarC_Syntax_Syntax.lid_as_fv proj_i + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___2 in + let uu___2 = + FStarC_Syntax_Syntax.mk_Tm_uinst proj_i_tm + [FStarC_Syntax_Syntax.U_zero] in + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Syntax_Embeddings_Base.type_of ea in + FStarC_Syntax_Syntax.iarg uu___5 in + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Syntax_Embeddings_Base.type_of eb in + FStarC_Syntax_Syntax.iarg uu___7 in + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Syntax_Embeddings_Base.type_of ec in + FStarC_Syntax_Syntax.iarg uu___9 in + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Syntax_Embeddings_Base.type_of ed in + FStarC_Syntax_Syntax.iarg uu___11 in + let uu___11 = + let uu___12 = + FStarC_Syntax_Syntax.as_arg abcd in + [uu___12] in + uu___10 :: uu___11 in + uu___8 :: uu___9 in + uu___6 :: uu___7 in + uu___4 :: uu___5 in + FStarC_Syntax_Syntax.mk_Tm_app uu___2 uu___3 rng in + let shadow_a = map_shadow shadow (proj Prims.int_one) in + let shadow_b = + map_shadow shadow (proj (Prims.of_int (2))) in + let shadow_c = + map_shadow shadow (proj (Prims.of_int (3))) in + let shadow_d = + map_shadow shadow (proj (Prims.of_int (4))) in + let uu___2 = + let uu___3 = + FStarC_Syntax_Syntax.tdataconstr + FStarC_Parser_Const.lid_Mktuple4 in + FStarC_Syntax_Syntax.mk_Tm_uinst uu___3 + [FStarC_Syntax_Syntax.U_zero; + FStarC_Syntax_Syntax.U_zero; + FStarC_Syntax_Syntax.U_zero; + FStarC_Syntax_Syntax.U_zero] in + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Syntax_Embeddings_Base.type_of ea in + FStarC_Syntax_Syntax.iarg uu___5 in + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Syntax_Embeddings_Base.type_of eb in + FStarC_Syntax_Syntax.iarg uu___7 in + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Syntax_Embeddings_Base.type_of ec in + FStarC_Syntax_Syntax.iarg uu___9 in + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Syntax_Embeddings_Base.type_of ed in + FStarC_Syntax_Syntax.iarg uu___11 in + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_Syntax_Embeddings_Base.embed ea + x1 in + uu___14 rng shadow_a norm in + FStarC_Syntax_Syntax.as_arg uu___13 in + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = + FStarC_Syntax_Embeddings_Base.embed eb + x2 in + uu___16 rng shadow_b norm in + FStarC_Syntax_Syntax.as_arg uu___15 in + let uu___15 = + let uu___16 = + let uu___17 = + let uu___18 = + FStarC_Syntax_Embeddings_Base.embed + ec x3 in + uu___18 rng shadow_c norm in + FStarC_Syntax_Syntax.as_arg uu___17 in + let uu___17 = + let uu___18 = + let uu___19 = + let uu___20 = + FStarC_Syntax_Embeddings_Base.embed + ed x4 in + uu___20 rng shadow_d norm in + FStarC_Syntax_Syntax.as_arg uu___19 in + [uu___18] in + uu___16 :: uu___17 in + uu___14 :: uu___15 in + uu___12 :: uu___13 in + uu___10 :: uu___11 in + uu___8 :: uu___9 in + uu___6 :: uu___7 in + uu___4 :: uu___5 in + FStarC_Syntax_Syntax.mk_Tm_app uu___2 uu___3 rng) in + let un t norm = + lazy_unembed printer1 emb_t_pair t typ + (fun uu___ -> + (fun t1 -> + let uu___ = FStarC_Syntax_Util.head_and_args_full t1 in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst hd in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, + uu___2::uu___3::uu___4::uu___5::(a1, uu___6):: + (b1, uu___7)::(c1, uu___8)::(d1, uu___9)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.lid_Mktuple4 + -> + Obj.magic + (Obj.repr + (let uu___10 = + FStarC_Syntax_Embeddings_Base.try_unembed + ea a1 norm in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () + (Obj.magic uu___10) + (fun uu___11 -> + (fun a2 -> + let a2 = Obj.magic a2 in + let uu___11 = + FStarC_Syntax_Embeddings_Base.try_unembed + eb b1 norm in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___11) + (fun uu___12 -> + (fun b2 -> + let b2 = Obj.magic b2 in + let uu___12 = + FStarC_Syntax_Embeddings_Base.try_unembed + ec c1 norm in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () + (Obj.magic uu___12) + (fun uu___13 -> + (fun c2 -> + let c2 = + Obj.magic + c2 in + let uu___13 + = + FStarC_Syntax_Embeddings_Base.try_unembed + ed d1 + norm in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () + (Obj.magic + uu___13) + (fun + uu___14 + -> + (fun d2 + -> + let d2 = + Obj.magic + d2 in + Obj.magic + (FStar_Pervasives_Native.Some + (a2, b2, + c2, d2))) + uu___14))) + uu___13))) + uu___12))) uu___11))) + | uu___2 -> + Obj.magic + (Obj.repr FStar_Pervasives_Native.None))) + uu___) in + FStarC_Syntax_Embeddings_Base.mk_emb_full em un typ printer1 + emb_t_pair +let e_tuple5 : + 'a 'b 'c 'd 'e . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'b FStarC_Syntax_Embeddings_Base.embedding -> + 'c FStarC_Syntax_Embeddings_Base.embedding -> + 'd FStarC_Syntax_Embeddings_Base.embedding -> + 'e FStarC_Syntax_Embeddings_Base.embedding -> + ('a * 'b * 'c * 'd * 'e) + FStarC_Syntax_Embeddings_Base.embedding + = + fun ea -> + fun eb -> + fun ec -> + fun ed -> + fun ee -> + let typ uu___ = + let uu___1 = FStarC_Syntax_Embeddings_Base.type_of ea in + let uu___2 = FStarC_Syntax_Embeddings_Base.type_of eb in + let uu___3 = FStarC_Syntax_Embeddings_Base.type_of ec in + let uu___4 = FStarC_Syntax_Embeddings_Base.type_of ed in + let uu___5 = FStarC_Syntax_Embeddings_Base.type_of ee in + FStarC_Syntax_Syntax.t_tuple5_of uu___1 uu___2 uu___3 uu___4 + uu___5 in + let emb_t_pair uu___ = + let uu___1 = + let uu___2 = + FStarC_Ident.string_of_lid FStarC_Parser_Const.lid_tuple5 in + let uu___3 = + let uu___4 = FStarC_Syntax_Embeddings_Base.emb_typ_of ea () in + let uu___5 = + let uu___6 = + FStarC_Syntax_Embeddings_Base.emb_typ_of eb () in + let uu___7 = + let uu___8 = + FStarC_Syntax_Embeddings_Base.emb_typ_of ec () in + let uu___9 = + let uu___10 = + FStarC_Syntax_Embeddings_Base.emb_typ_of ed () in + let uu___11 = + let uu___12 = + FStarC_Syntax_Embeddings_Base.emb_typ_of ee () in + [uu___12] in + uu___10 :: uu___11 in + uu___8 :: uu___9 in + uu___6 :: uu___7 in + uu___4 :: uu___5 in + (uu___2, uu___3) in + FStarC_Syntax_Syntax.ET_app uu___1 in + let printer1 uu___ = + match uu___ with + | (x, y, z, w, v) -> + let uu___1 = + let uu___2 = FStarC_Syntax_Embeddings_Base.printer_of ea in + uu___2 x in + let uu___2 = + let uu___3 = FStarC_Syntax_Embeddings_Base.printer_of eb in + uu___3 y in + let uu___3 = + let uu___4 = FStarC_Syntax_Embeddings_Base.printer_of ec in + uu___4 z in + let uu___4 = + let uu___5 = FStarC_Syntax_Embeddings_Base.printer_of ed in + uu___5 w in + let uu___5 = + let uu___6 = FStarC_Syntax_Embeddings_Base.printer_of ee in + uu___6 v in + FStarC_Compiler_Util.format5 "(%s, %s, %s, %s, %s)" uu___1 + uu___2 uu___3 uu___4 uu___5 in + let em uu___ rng shadow norm = + match uu___ with + | (x1, x2, x3, x4, x5) -> + lazy_embed printer1 emb_t_pair rng typ (x1, x2, x3, x4, x5) + (fun uu___1 -> + let proj i abcde = + let proj_i = + let uu___2 = + FStarC_Parser_Const.mk_tuple_data_lid + (Prims.of_int (5)) rng in + let uu___3 = + FStarC_Syntax_Syntax.null_bv + FStarC_Syntax_Syntax.tun in + FStarC_Syntax_Util.mk_field_projector_name uu___2 + uu___3 i in + let proj_i_tm = + let uu___2 = + FStarC_Syntax_Syntax.lid_as_fv proj_i + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___2 in + let uu___2 = + FStarC_Syntax_Syntax.mk_Tm_uinst proj_i_tm + [FStarC_Syntax_Syntax.U_zero] in + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Syntax_Embeddings_Base.type_of ea in + FStarC_Syntax_Syntax.iarg uu___5 in + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Syntax_Embeddings_Base.type_of eb in + FStarC_Syntax_Syntax.iarg uu___7 in + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Syntax_Embeddings_Base.type_of ec in + FStarC_Syntax_Syntax.iarg uu___9 in + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Syntax_Embeddings_Base.type_of ed in + FStarC_Syntax_Syntax.iarg uu___11 in + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Syntax_Embeddings_Base.type_of + ee in + FStarC_Syntax_Syntax.iarg uu___13 in + let uu___13 = + let uu___14 = + FStarC_Syntax_Syntax.as_arg abcde in + [uu___14] in + uu___12 :: uu___13 in + uu___10 :: uu___11 in + uu___8 :: uu___9 in + uu___6 :: uu___7 in + uu___4 :: uu___5 in + FStarC_Syntax_Syntax.mk_Tm_app uu___2 uu___3 rng in + let shadow_a = map_shadow shadow (proj Prims.int_one) in + let shadow_b = + map_shadow shadow (proj (Prims.of_int (2))) in + let shadow_c = + map_shadow shadow (proj (Prims.of_int (3))) in + let shadow_d = + map_shadow shadow (proj (Prims.of_int (4))) in + let shadow_e = + map_shadow shadow (proj (Prims.of_int (5))) in + let uu___2 = + let uu___3 = + FStarC_Syntax_Syntax.tdataconstr + FStarC_Parser_Const.lid_Mktuple5 in + FStarC_Syntax_Syntax.mk_Tm_uinst uu___3 + [FStarC_Syntax_Syntax.U_zero; + FStarC_Syntax_Syntax.U_zero; + FStarC_Syntax_Syntax.U_zero; + FStarC_Syntax_Syntax.U_zero; + FStarC_Syntax_Syntax.U_zero] in + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Syntax_Embeddings_Base.type_of ea in + FStarC_Syntax_Syntax.iarg uu___5 in + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Syntax_Embeddings_Base.type_of eb in + FStarC_Syntax_Syntax.iarg uu___7 in + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Syntax_Embeddings_Base.type_of ec in + FStarC_Syntax_Syntax.iarg uu___9 in + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Syntax_Embeddings_Base.type_of ed in + FStarC_Syntax_Syntax.iarg uu___11 in + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Syntax_Embeddings_Base.type_of ee in + FStarC_Syntax_Syntax.iarg uu___13 in + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = + FStarC_Syntax_Embeddings_Base.embed + ea x1 in + uu___16 rng shadow_a norm in + FStarC_Syntax_Syntax.as_arg uu___15 in + let uu___15 = + let uu___16 = + let uu___17 = + let uu___18 = + FStarC_Syntax_Embeddings_Base.embed + eb x2 in + uu___18 rng shadow_b norm in + FStarC_Syntax_Syntax.as_arg uu___17 in + let uu___17 = + let uu___18 = + let uu___19 = + let uu___20 = + FStarC_Syntax_Embeddings_Base.embed + ec x3 in + uu___20 rng shadow_c norm in + FStarC_Syntax_Syntax.as_arg uu___19 in + let uu___19 = + let uu___20 = + let uu___21 = + let uu___22 = + FStarC_Syntax_Embeddings_Base.embed + ed x4 in + uu___22 rng shadow_d norm in + FStarC_Syntax_Syntax.as_arg + uu___21 in + let uu___21 = + let uu___22 = + let uu___23 = + let uu___24 = + FStarC_Syntax_Embeddings_Base.embed + ee x5 in + uu___24 rng shadow_e norm in + FStarC_Syntax_Syntax.as_arg + uu___23 in + [uu___22] in + uu___20 :: uu___21 in + uu___18 :: uu___19 in + uu___16 :: uu___17 in + uu___14 :: uu___15 in + uu___12 :: uu___13 in + uu___10 :: uu___11 in + uu___8 :: uu___9 in + uu___6 :: uu___7 in + uu___4 :: uu___5 in + FStarC_Syntax_Syntax.mk_Tm_app uu___2 uu___3 rng) in + let un t norm = + lazy_unembed printer1 emb_t_pair t typ + (fun uu___ -> + (fun t1 -> + let uu___ = FStarC_Syntax_Util.head_and_args_full t1 in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst hd in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, + uu___2::uu___3::uu___4::uu___5::uu___6:: + (a1, uu___7)::(b1, uu___8)::(c1, uu___9):: + (d1, uu___10)::(e1, uu___11)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.lid_Mktuple5 + -> + Obj.magic + (Obj.repr + (let uu___12 = + FStarC_Syntax_Embeddings_Base.try_unembed + ea a1 norm in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () + (Obj.magic uu___12) + (fun uu___13 -> + (fun a2 -> + let a2 = Obj.magic a2 in + let uu___13 = + FStarC_Syntax_Embeddings_Base.try_unembed + eb b1 norm in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___13) + (fun uu___14 -> + (fun b2 -> + let b2 = Obj.magic b2 in + let uu___14 = + FStarC_Syntax_Embeddings_Base.try_unembed + ec c1 norm in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () + (Obj.magic + uu___14) + (fun uu___15 -> + (fun c2 -> + let c2 = + Obj.magic + c2 in + let uu___15 + = + FStarC_Syntax_Embeddings_Base.try_unembed + ed d1 + norm in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () + (Obj.magic + uu___15) + (fun + uu___16 + -> + (fun d2 + -> + let d2 = + Obj.magic + d2 in + let uu___16 + = + FStarC_Syntax_Embeddings_Base.try_unembed + ee e1 + norm in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () + (Obj.magic + uu___16) + (fun + uu___17 + -> + (fun e2 + -> + let e2 = + Obj.magic + e2 in + Obj.magic + (FStar_Pervasives_Native.Some + (a2, b2, + c2, d2, + e2))) + uu___17))) + uu___16))) + uu___15))) + uu___14))) uu___13))) + | uu___2 -> + Obj.magic + (Obj.repr FStar_Pervasives_Native.None))) + uu___) in + FStarC_Syntax_Embeddings_Base.mk_emb_full em un typ printer1 + emb_t_pair +let e_either : + 'a 'b . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'b FStarC_Syntax_Embeddings_Base.embedding -> + ('a, 'b) FStar_Pervasives.either + FStarC_Syntax_Embeddings_Base.embedding + = + fun ea -> + fun eb -> + let typ uu___ = + let uu___1 = FStarC_Syntax_Embeddings_Base.type_of ea in + let uu___2 = FStarC_Syntax_Embeddings_Base.type_of eb in + FStarC_Syntax_Syntax.t_either_of uu___1 uu___2 in + let emb_t_sum_a_b uu___ = + let uu___1 = + let uu___2 = + FStarC_Ident.string_of_lid FStarC_Parser_Const.either_lid in + let uu___3 = + let uu___4 = FStarC_Syntax_Embeddings_Base.emb_typ_of ea () in + let uu___5 = + let uu___6 = FStarC_Syntax_Embeddings_Base.emb_typ_of eb () in + [uu___6] in + uu___4 :: uu___5 in + (uu___2, uu___3) in + FStarC_Syntax_Syntax.ET_app uu___1 in + let printer1 s = + match s with + | FStar_Pervasives.Inl a1 -> + let uu___ = + let uu___1 = FStarC_Syntax_Embeddings_Base.printer_of ea in + uu___1 a1 in + FStarC_Compiler_Util.format1 "Inl %s" uu___ + | FStar_Pervasives.Inr b1 -> + let uu___ = + let uu___1 = FStarC_Syntax_Embeddings_Base.printer_of eb in + uu___1 b1 in + FStarC_Compiler_Util.format1 "Inr %s" uu___ in + let em s rng shadow norm = + lazy_embed printer1 emb_t_sum_a_b rng typ s + (match s with + | FStar_Pervasives.Inl a1 -> + (fun uu___ -> + let shadow_a = + map_shadow shadow + (fun t -> + let v = FStarC_Ident.mk_ident ("v", rng) in + let some_v = + FStarC_Syntax_Util.mk_field_projector_name_from_ident + FStarC_Parser_Const.inl_lid v in + let some_v_tm = + let uu___1 = + FStarC_Syntax_Syntax.lid_as_fv some_v + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___1 in + let uu___1 = + FStarC_Syntax_Syntax.mk_Tm_uinst some_v_tm + [FStarC_Syntax_Syntax.U_zero] in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Syntax_Embeddings_Base.type_of ea in + FStarC_Syntax_Syntax.iarg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Embeddings_Base.type_of eb in + FStarC_Syntax_Syntax.iarg uu___6 in + let uu___6 = + let uu___7 = FStarC_Syntax_Syntax.as_arg t in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + FStarC_Syntax_Syntax.mk_Tm_app uu___1 uu___2 rng) in + let uu___1 = + let uu___2 = + FStarC_Syntax_Syntax.tdataconstr + FStarC_Parser_Const.inl_lid in + FStarC_Syntax_Syntax.mk_Tm_uinst uu___2 + [FStarC_Syntax_Syntax.U_zero; + FStarC_Syntax_Syntax.U_zero] in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Embeddings_Base.type_of ea in + FStarC_Syntax_Syntax.iarg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Syntax_Embeddings_Base.type_of eb in + FStarC_Syntax_Syntax.iarg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Syntax_Embeddings_Base.embed ea a1 in + uu___9 rng shadow_a norm in + FStarC_Syntax_Syntax.as_arg uu___8 in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + FStarC_Syntax_Syntax.mk_Tm_app uu___1 uu___2 rng) + | FStar_Pervasives.Inr b1 -> + (fun uu___ -> + let shadow_b = + map_shadow shadow + (fun t -> + let v = FStarC_Ident.mk_ident ("v", rng) in + let some_v = + FStarC_Syntax_Util.mk_field_projector_name_from_ident + FStarC_Parser_Const.inr_lid v in + let some_v_tm = + let uu___1 = + FStarC_Syntax_Syntax.lid_as_fv some_v + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___1 in + let uu___1 = + FStarC_Syntax_Syntax.mk_Tm_uinst some_v_tm + [FStarC_Syntax_Syntax.U_zero] in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Syntax_Embeddings_Base.type_of ea in + FStarC_Syntax_Syntax.iarg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Embeddings_Base.type_of eb in + FStarC_Syntax_Syntax.iarg uu___6 in + let uu___6 = + let uu___7 = FStarC_Syntax_Syntax.as_arg t in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + FStarC_Syntax_Syntax.mk_Tm_app uu___1 uu___2 rng) in + let uu___1 = + let uu___2 = + FStarC_Syntax_Syntax.tdataconstr + FStarC_Parser_Const.inr_lid in + FStarC_Syntax_Syntax.mk_Tm_uinst uu___2 + [FStarC_Syntax_Syntax.U_zero; + FStarC_Syntax_Syntax.U_zero] in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Embeddings_Base.type_of ea in + FStarC_Syntax_Syntax.iarg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Syntax_Embeddings_Base.type_of eb in + FStarC_Syntax_Syntax.iarg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Syntax_Embeddings_Base.embed eb b1 in + uu___9 rng shadow_b norm in + FStarC_Syntax_Syntax.as_arg uu___8 in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + FStarC_Syntax_Syntax.mk_Tm_app uu___1 uu___2 rng)) in + let un t norm = + lazy_unembed printer1 emb_t_sum_a_b t typ + (fun t1 -> + let uu___ = FStarC_Syntax_Util.head_and_args_full t1 in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst hd in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, + uu___2::uu___3::(a1, uu___4)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.inl_lid + -> + let uu___5 = + FStarC_Syntax_Embeddings_Base.try_unembed ea a1 norm in + FStarC_Compiler_Util.bind_opt uu___5 + (fun a2 -> + FStar_Pervasives_Native.Some + (FStar_Pervasives.Inl a2)) + | (FStarC_Syntax_Syntax.Tm_fvar fv, + uu___2::uu___3::(b1, uu___4)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.inr_lid + -> + let uu___5 = + FStarC_Syntax_Embeddings_Base.try_unembed eb b1 norm in + FStarC_Compiler_Util.bind_opt uu___5 + (fun b2 -> + FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr b2)) + | uu___2 -> FStar_Pervasives_Native.None)) in + FStarC_Syntax_Embeddings_Base.mk_emb_full em un typ printer1 + emb_t_sum_a_b +let e_list : + 'a . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'a Prims.list FStarC_Syntax_Embeddings_Base.embedding + = + fun ea -> + let typ uu___ = + let uu___1 = FStarC_Syntax_Embeddings_Base.type_of ea in + FStarC_Syntax_Syntax.t_list_of uu___1 in + let emb_t_list_a uu___ = + let uu___1 = + let uu___2 = FStarC_Ident.string_of_lid FStarC_Parser_Const.list_lid in + let uu___3 = + let uu___4 = FStarC_Syntax_Embeddings_Base.emb_typ_of ea () in + [uu___4] in + (uu___2, uu___3) in + FStarC_Syntax_Syntax.ET_app uu___1 in + let printer1 l = + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Embeddings_Base.printer_of ea in + FStarC_Compiler_List.map uu___3 l in + FStarC_Compiler_String.concat "; " uu___2 in + Prims.strcat uu___1 "]" in + Prims.strcat "[" uu___ in + let rec em l rng shadow_l norm = + lazy_embed printer1 emb_t_list_a rng typ l + (fun uu___ -> + let t = + let uu___1 = FStarC_Syntax_Embeddings_Base.type_of ea in + FStarC_Syntax_Syntax.iarg uu___1 in + match l with + | [] -> + let uu___1 = + let uu___2 = + FStarC_Syntax_Syntax.tdataconstr + FStarC_Parser_Const.nil_lid in + FStarC_Syntax_Syntax.mk_Tm_uinst uu___2 + [FStarC_Syntax_Syntax.U_zero] in + FStarC_Syntax_Syntax.mk_Tm_app uu___1 [t] rng + | hd::tl -> + let cons = + let uu___1 = + FStarC_Syntax_Syntax.tdataconstr + FStarC_Parser_Const.cons_lid in + FStarC_Syntax_Syntax.mk_Tm_uinst uu___1 + [FStarC_Syntax_Syntax.U_zero] in + let proj f cons_tm = + let fid = FStarC_Ident.mk_ident (f, rng) in + let proj1 = + FStarC_Syntax_Util.mk_field_projector_name_from_ident + FStarC_Parser_Const.cons_lid fid in + let proj_tm = + let uu___1 = + FStarC_Syntax_Syntax.lid_as_fv proj1 + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___1 in + let uu___1 = + FStarC_Syntax_Syntax.mk_Tm_uinst proj_tm + [FStarC_Syntax_Syntax.U_zero] in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Embeddings_Base.type_of ea in + FStarC_Syntax_Syntax.iarg uu___4 in + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.as_arg cons_tm in + [uu___5] in + uu___3 :: uu___4 in + FStarC_Syntax_Syntax.mk_Tm_app uu___1 uu___2 rng in + let shadow_hd = map_shadow shadow_l (proj "hd") in + let shadow_tl = map_shadow shadow_l (proj "tl") in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Embeddings_Base.embed ea hd in + uu___5 rng shadow_hd norm in + FStarC_Syntax_Syntax.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = em tl rng shadow_tl norm in + FStarC_Syntax_Syntax.as_arg uu___6 in + [uu___5] in + uu___3 :: uu___4 in + t :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app cons uu___1 rng) in + let rec un t norm = + lazy_unembed printer1 emb_t_list_a t typ + (fun t1 -> + let uu___ = FStarC_Syntax_Util.head_and_args_full t1 in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst hd in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, uu___2) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.nil_lid + -> FStar_Pervasives_Native.Some [] + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (uu___2, FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = uu___3;_}):: + (hd1, FStar_Pervasives_Native.None)::(tl, + FStar_Pervasives_Native.None)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.cons_lid + -> + let uu___4 = + FStarC_Syntax_Embeddings_Base.try_unembed ea hd1 norm in + FStarC_Compiler_Util.bind_opt uu___4 + (fun hd2 -> + let uu___5 = un tl norm in + FStarC_Compiler_Util.bind_opt uu___5 + (fun tl1 -> + FStar_Pervasives_Native.Some (hd2 :: tl1))) + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (hd1, FStar_Pervasives_Native.None)::(tl, + FStar_Pervasives_Native.None)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.cons_lid + -> + let uu___2 = + FStarC_Syntax_Embeddings_Base.try_unembed ea hd1 norm in + FStarC_Compiler_Util.bind_opt uu___2 + (fun hd2 -> + let uu___3 = un tl norm in + FStarC_Compiler_Util.bind_opt uu___3 + (fun tl1 -> + FStar_Pervasives_Native.Some (hd2 :: tl1))) + | uu___2 -> FStar_Pervasives_Native.None)) in + FStarC_Syntax_Embeddings_Base.mk_emb_full em un typ printer1 emb_t_list_a +let (e_string_list : + Prims.string Prims.list FStarC_Syntax_Embeddings_Base.embedding) = + e_list e_string +let (steps_Simpl : FStarC_Syntax_Syntax.term) = + FStarC_Syntax_Syntax.tconst FStarC_Parser_Const.steps_simpl +let (steps_Weak : FStarC_Syntax_Syntax.term) = + FStarC_Syntax_Syntax.tconst FStarC_Parser_Const.steps_weak +let (steps_HNF : FStarC_Syntax_Syntax.term) = + FStarC_Syntax_Syntax.tconst FStarC_Parser_Const.steps_hnf +let (steps_Primops : FStarC_Syntax_Syntax.term) = + FStarC_Syntax_Syntax.tconst FStarC_Parser_Const.steps_primops +let (steps_Delta : FStarC_Syntax_Syntax.term) = + FStarC_Syntax_Syntax.tconst FStarC_Parser_Const.steps_delta +let (steps_Zeta : FStarC_Syntax_Syntax.term) = + FStarC_Syntax_Syntax.tconst FStarC_Parser_Const.steps_zeta +let (steps_ZetaFull : FStarC_Syntax_Syntax.term) = + FStarC_Syntax_Syntax.tconst FStarC_Parser_Const.steps_zeta_full +let (steps_Iota : FStarC_Syntax_Syntax.term) = + FStarC_Syntax_Syntax.tconst FStarC_Parser_Const.steps_iota +let (steps_Reify : FStarC_Syntax_Syntax.term) = + FStarC_Syntax_Syntax.tconst FStarC_Parser_Const.steps_reify +let (steps_NormDebug : FStarC_Syntax_Syntax.term) = + FStarC_Syntax_Syntax.tconst FStarC_Parser_Const.steps_norm_debug +let (steps_UnfoldOnly : FStarC_Syntax_Syntax.term) = + FStarC_Syntax_Syntax.tconst FStarC_Parser_Const.steps_unfoldonly +let (steps_UnfoldFully : FStarC_Syntax_Syntax.term) = + FStarC_Syntax_Syntax.tconst FStarC_Parser_Const.steps_unfoldonly +let (steps_UnfoldAttr : FStarC_Syntax_Syntax.term) = + FStarC_Syntax_Syntax.tconst FStarC_Parser_Const.steps_unfoldattr +let (steps_UnfoldQual : FStarC_Syntax_Syntax.term) = + FStarC_Syntax_Syntax.tconst FStarC_Parser_Const.steps_unfoldqual +let (steps_UnfoldNamespace : FStarC_Syntax_Syntax.term) = + FStarC_Syntax_Syntax.tconst FStarC_Parser_Const.steps_unfoldnamespace +let (steps_Unascribe : FStarC_Syntax_Syntax.term) = + FStarC_Syntax_Syntax.tconst FStarC_Parser_Const.steps_unascribe +let (steps_NBE : FStarC_Syntax_Syntax.term) = + FStarC_Syntax_Syntax.tconst FStarC_Parser_Const.steps_nbe +let (steps_Unmeta : FStarC_Syntax_Syntax.term) = + FStarC_Syntax_Syntax.tconst FStarC_Parser_Const.steps_unmeta +let (e_norm_step : + FStar_Pervasives.norm_step FStarC_Syntax_Embeddings_Base.embedding) = + let typ uu___ = FStarC_Syntax_Syntax.t_norm_step in + let emb_t_norm_step uu___ = + let uu___1 = + let uu___2 = + FStarC_Ident.string_of_lid FStarC_Parser_Const.norm_step_lid in + (uu___2, []) in + FStarC_Syntax_Syntax.ET_app uu___1 in + let printer1 uu___ = "norm_step" in + let em n rng _shadow norm = + lazy_embed printer1 emb_t_norm_step rng typ n + (fun uu___ -> + match n with + | FStar_Pervasives.Simpl -> steps_Simpl + | FStar_Pervasives.Weak -> steps_Weak + | FStar_Pervasives.HNF -> steps_HNF + | FStar_Pervasives.Primops -> steps_Primops + | FStar_Pervasives.Delta -> steps_Delta + | FStar_Pervasives.Zeta -> steps_Zeta + | FStar_Pervasives.ZetaFull -> steps_ZetaFull + | FStar_Pervasives.Iota -> steps_Iota + | FStar_Pervasives.Unascribe -> steps_Unascribe + | FStar_Pervasives.NBE -> steps_NBE + | FStar_Pervasives.Unmeta -> steps_Unmeta + | FStar_Pervasives.Reify -> steps_Reify + | FStar_Pervasives.NormDebug -> steps_NormDebug + | FStar_Pervasives.UnfoldOnly l -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Syntax_Embeddings_Base.embed e_string_list l in + uu___4 rng FStar_Pervasives_Native.None norm in + FStarC_Syntax_Syntax.as_arg uu___3 in + [uu___2] in + FStarC_Syntax_Syntax.mk_Tm_app steps_UnfoldOnly uu___1 rng + | FStar_Pervasives.UnfoldFully l -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Syntax_Embeddings_Base.embed e_string_list l in + uu___4 rng FStar_Pervasives_Native.None norm in + FStarC_Syntax_Syntax.as_arg uu___3 in + [uu___2] in + FStarC_Syntax_Syntax.mk_Tm_app steps_UnfoldFully uu___1 rng + | FStar_Pervasives.UnfoldAttr l -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Syntax_Embeddings_Base.embed e_string_list l in + uu___4 rng FStar_Pervasives_Native.None norm in + FStarC_Syntax_Syntax.as_arg uu___3 in + [uu___2] in + FStarC_Syntax_Syntax.mk_Tm_app steps_UnfoldAttr uu___1 rng + | FStar_Pervasives.UnfoldQual l -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Syntax_Embeddings_Base.embed e_string_list l in + uu___4 rng FStar_Pervasives_Native.None norm in + FStarC_Syntax_Syntax.as_arg uu___3 in + [uu___2] in + FStarC_Syntax_Syntax.mk_Tm_app steps_UnfoldQual uu___1 rng + | FStar_Pervasives.UnfoldNamespace l -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Syntax_Embeddings_Base.embed e_string_list l in + uu___4 rng FStar_Pervasives_Native.None norm in + FStarC_Syntax_Syntax.as_arg uu___3 in + [uu___2] in + FStarC_Syntax_Syntax.mk_Tm_app steps_UnfoldNamespace uu___1 rng) in + let un t norm = + lazy_unembed printer1 emb_t_norm_step t typ + (fun t1 -> + let uu___ = FStarC_Syntax_Util.head_and_args t1 in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst hd in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.steps_simpl + -> FStar_Pervasives_Native.Some FStar_Pervasives.Simpl + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.steps_weak + -> FStar_Pervasives_Native.Some FStar_Pervasives.Weak + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.steps_hnf + -> FStar_Pervasives_Native.Some FStar_Pervasives.HNF + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.steps_primops + -> FStar_Pervasives_Native.Some FStar_Pervasives.Primops + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.steps_delta + -> FStar_Pervasives_Native.Some FStar_Pervasives.Delta + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.steps_zeta + -> FStar_Pervasives_Native.Some FStar_Pervasives.Zeta + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.steps_zeta_full + -> FStar_Pervasives_Native.Some FStar_Pervasives.ZetaFull + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.steps_iota + -> FStar_Pervasives_Native.Some FStar_Pervasives.Iota + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.steps_unascribe + -> FStar_Pervasives_Native.Some FStar_Pervasives.Unascribe + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.steps_nbe + -> FStar_Pervasives_Native.Some FStar_Pervasives.NBE + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.steps_unmeta + -> FStar_Pervasives_Native.Some FStar_Pervasives.Unmeta + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.steps_reify + -> FStar_Pervasives_Native.Some FStar_Pervasives.Reify + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.steps_norm_debug + -> FStar_Pervasives_Native.Some FStar_Pervasives.NormDebug + | (FStarC_Syntax_Syntax.Tm_fvar fv, (l, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.steps_unfoldonly + -> + let uu___3 = + FStarC_Syntax_Embeddings_Base.try_unembed e_string_list l + norm in + FStarC_Compiler_Util.bind_opt uu___3 + (fun ss -> + FStar_Pervasives_Native.Some + (FStar_Pervasives.UnfoldOnly ss)) + | (FStarC_Syntax_Syntax.Tm_fvar fv, (l, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.steps_unfoldfully + -> + let uu___3 = + FStarC_Syntax_Embeddings_Base.try_unembed e_string_list l + norm in + FStarC_Compiler_Util.bind_opt uu___3 + (fun ss -> + FStar_Pervasives_Native.Some + (FStar_Pervasives.UnfoldFully ss)) + | (FStarC_Syntax_Syntax.Tm_fvar fv, (l, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.steps_unfoldattr + -> + let uu___3 = + FStarC_Syntax_Embeddings_Base.try_unembed e_string_list l + norm in + FStarC_Compiler_Util.bind_opt uu___3 + (fun ss -> + FStar_Pervasives_Native.Some + (FStar_Pervasives.UnfoldAttr ss)) + | (FStarC_Syntax_Syntax.Tm_fvar fv, (l, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.steps_unfoldqual + -> + let uu___3 = + FStarC_Syntax_Embeddings_Base.try_unembed e_string_list l + norm in + FStarC_Compiler_Util.bind_opt uu___3 + (fun ss -> + FStar_Pervasives_Native.Some + (FStar_Pervasives.UnfoldQual ss)) + | (FStarC_Syntax_Syntax.Tm_fvar fv, (l, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.steps_unfoldnamespace + -> + let uu___3 = + FStarC_Syntax_Embeddings_Base.try_unembed e_string_list l + norm in + FStarC_Compiler_Util.bind_opt uu___3 + (fun ss -> + FStar_Pervasives_Native.Some + (FStar_Pervasives.UnfoldNamespace ss)) + | uu___2 -> FStar_Pervasives_Native.None)) in + FStarC_Syntax_Embeddings_Base.mk_emb_full em un typ printer1 + emb_t_norm_step +let (e_vconfig : + FStarC_VConfig.vconfig FStarC_Syntax_Embeddings_Base.embedding) = + let em vcfg rng _shadow norm = + let uu___ = + FStarC_Syntax_Syntax.tdataconstr FStarC_Parser_Const.mkvconfig_lid in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Syntax_Embeddings_Base.embed e_fsint + vcfg.FStarC_VConfig.initial_fuel in + uu___4 rng FStar_Pervasives_Native.None norm in + FStarC_Syntax_Syntax.as_arg uu___3 in + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Embeddings_Base.embed e_fsint + vcfg.FStarC_VConfig.max_fuel in + uu___6 rng FStar_Pervasives_Native.None norm in + FStarC_Syntax_Syntax.as_arg uu___5 in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Embeddings_Base.embed e_fsint + vcfg.FStarC_VConfig.initial_ifuel in + uu___8 rng FStar_Pervasives_Native.None norm in + FStarC_Syntax_Syntax.as_arg uu___7 in + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Syntax_Embeddings_Base.embed e_fsint + vcfg.FStarC_VConfig.max_ifuel in + uu___10 rng FStar_Pervasives_Native.None norm in + FStarC_Syntax_Syntax.as_arg uu___9 in + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Syntax_Embeddings_Base.embed e_bool + vcfg.FStarC_VConfig.detail_errors in + uu___12 rng FStar_Pervasives_Native.None norm in + FStarC_Syntax_Syntax.as_arg uu___11 in + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_Syntax_Embeddings_Base.embed e_bool + vcfg.FStarC_VConfig.detail_hint_replay in + uu___14 rng FStar_Pervasives_Native.None norm in + FStarC_Syntax_Syntax.as_arg uu___13 in + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = + FStarC_Syntax_Embeddings_Base.embed e_bool + vcfg.FStarC_VConfig.no_smt in + uu___16 rng FStar_Pervasives_Native.None norm in + FStarC_Syntax_Syntax.as_arg uu___15 in + let uu___15 = + let uu___16 = + let uu___17 = + let uu___18 = + FStarC_Syntax_Embeddings_Base.embed e_fsint + vcfg.FStarC_VConfig.quake_lo in + uu___18 rng FStar_Pervasives_Native.None norm in + FStarC_Syntax_Syntax.as_arg uu___17 in + let uu___17 = + let uu___18 = + let uu___19 = + let uu___20 = + FStarC_Syntax_Embeddings_Base.embed e_fsint + vcfg.FStarC_VConfig.quake_hi in + uu___20 rng FStar_Pervasives_Native.None norm in + FStarC_Syntax_Syntax.as_arg uu___19 in + let uu___19 = + let uu___20 = + let uu___21 = + let uu___22 = + FStarC_Syntax_Embeddings_Base.embed e_bool + vcfg.FStarC_VConfig.quake_keep in + uu___22 rng FStar_Pervasives_Native.None norm in + FStarC_Syntax_Syntax.as_arg uu___21 in + let uu___21 = + let uu___22 = + let uu___23 = + let uu___24 = + FStarC_Syntax_Embeddings_Base.embed e_bool + vcfg.FStarC_VConfig.retry in + uu___24 rng FStar_Pervasives_Native.None norm in + FStarC_Syntax_Syntax.as_arg uu___23 in + let uu___23 = + let uu___24 = + let uu___25 = + let uu___26 = + FStarC_Syntax_Embeddings_Base.embed e_bool + vcfg.FStarC_VConfig.smtencoding_elim_box in + uu___26 rng FStar_Pervasives_Native.None norm in + FStarC_Syntax_Syntax.as_arg uu___25 in + let uu___25 = + let uu___26 = + let uu___27 = + let uu___28 = + FStarC_Syntax_Embeddings_Base.embed + e_string + vcfg.FStarC_VConfig.smtencoding_nl_arith_repr in + uu___28 rng FStar_Pervasives_Native.None + norm in + FStarC_Syntax_Syntax.as_arg uu___27 in + let uu___27 = + let uu___28 = + let uu___29 = + let uu___30 = + FStarC_Syntax_Embeddings_Base.embed + e_string + vcfg.FStarC_VConfig.smtencoding_l_arith_repr in + uu___30 rng FStar_Pervasives_Native.None + norm in + FStarC_Syntax_Syntax.as_arg uu___29 in + let uu___29 = + let uu___30 = + let uu___31 = + let uu___32 = + FStarC_Syntax_Embeddings_Base.embed + e_bool + vcfg.FStarC_VConfig.smtencoding_valid_intro in + uu___32 rng + FStar_Pervasives_Native.None norm in + FStarC_Syntax_Syntax.as_arg uu___31 in + let uu___31 = + let uu___32 = + let uu___33 = + let uu___34 = + FStarC_Syntax_Embeddings_Base.embed + e_bool + vcfg.FStarC_VConfig.smtencoding_valid_elim in + uu___34 rng + FStar_Pervasives_Native.None norm in + FStarC_Syntax_Syntax.as_arg uu___33 in + let uu___33 = + let uu___34 = + let uu___35 = + let uu___36 = + FStarC_Syntax_Embeddings_Base.embed + e_bool + vcfg.FStarC_VConfig.tcnorm in + uu___36 rng + FStar_Pervasives_Native.None norm in + FStarC_Syntax_Syntax.as_arg uu___35 in + let uu___35 = + let uu___36 = + let uu___37 = + let uu___38 = + FStarC_Syntax_Embeddings_Base.embed + e_bool + vcfg.FStarC_VConfig.no_plugins in + uu___38 rng + FStar_Pervasives_Native.None + norm in + FStarC_Syntax_Syntax.as_arg uu___37 in + let uu___37 = + let uu___38 = + let uu___39 = + let uu___40 = + FStarC_Syntax_Embeddings_Base.embed + e_bool + vcfg.FStarC_VConfig.no_tactics in + uu___40 rng + FStar_Pervasives_Native.None + norm in + FStarC_Syntax_Syntax.as_arg + uu___39 in + let uu___39 = + let uu___40 = + let uu___41 = + let uu___42 = + FStarC_Syntax_Embeddings_Base.embed + e_string_list + vcfg.FStarC_VConfig.z3cliopt in + uu___42 rng + FStar_Pervasives_Native.None + norm in + FStarC_Syntax_Syntax.as_arg + uu___41 in + let uu___41 = + let uu___42 = + let uu___43 = + let uu___44 = + FStarC_Syntax_Embeddings_Base.embed + e_string_list + vcfg.FStarC_VConfig.z3smtopt in + uu___44 rng + FStar_Pervasives_Native.None + norm in + FStarC_Syntax_Syntax.as_arg + uu___43 in + let uu___43 = + let uu___44 = + let uu___45 = + let uu___46 = + FStarC_Syntax_Embeddings_Base.embed + e_bool + vcfg.FStarC_VConfig.z3refresh in + uu___46 rng + FStar_Pervasives_Native.None + norm in + FStarC_Syntax_Syntax.as_arg + uu___45 in + let uu___45 = + let uu___46 = + let uu___47 = + let uu___48 = + FStarC_Syntax_Embeddings_Base.embed + e_fsint + vcfg.FStarC_VConfig.z3rlimit in + uu___48 rng + FStar_Pervasives_Native.None + norm in + FStarC_Syntax_Syntax.as_arg + uu___47 in + let uu___47 = + let uu___48 = + let uu___49 = + let uu___50 = + FStarC_Syntax_Embeddings_Base.embed + e_fsint + vcfg.FStarC_VConfig.z3rlimit_factor in + uu___50 rng + FStar_Pervasives_Native.None + norm in + FStarC_Syntax_Syntax.as_arg + uu___49 in + let uu___49 = + let uu___50 = + let uu___51 = + let uu___52 = + FStarC_Syntax_Embeddings_Base.embed + e_fsint + vcfg.FStarC_VConfig.z3seed in + uu___52 rng + FStar_Pervasives_Native.None + norm in + FStarC_Syntax_Syntax.as_arg + uu___51 in + let uu___51 = + let uu___52 = + let uu___53 = + let uu___54 = + FStarC_Syntax_Embeddings_Base.embed + e_string + vcfg.FStarC_VConfig.z3version in + uu___54 rng + FStar_Pervasives_Native.None + norm in + FStarC_Syntax_Syntax.as_arg + uu___53 in + let uu___53 = + let uu___54 = + let uu___55 = + let uu___56 = + FStarC_Syntax_Embeddings_Base.embed + e_bool + vcfg.FStarC_VConfig.trivial_pre_for_unannotated_effectful_fns in + uu___56 rng + FStar_Pervasives_Native.None + norm in + FStarC_Syntax_Syntax.as_arg + uu___55 in + let uu___55 = + let uu___56 = + let uu___57 = + let uu___58 = + FStarC_Syntax_Embeddings_Base.embed + ( + e_option + e_string) + vcfg.FStarC_VConfig.reuse_hint_for in + uu___58 rng + FStar_Pervasives_Native.None + norm in + FStarC_Syntax_Syntax.as_arg + uu___57 in + [uu___56] in + uu___54 :: uu___55 in + uu___52 :: uu___53 in + uu___50 :: uu___51 in + uu___48 :: uu___49 in + uu___46 :: uu___47 in + uu___44 :: uu___45 in + uu___42 :: uu___43 in + uu___40 :: uu___41 in + uu___38 :: uu___39 in + uu___36 :: uu___37 in + uu___34 :: uu___35 in + uu___32 :: uu___33 in + uu___30 :: uu___31 in + uu___28 :: uu___29 in + uu___26 :: uu___27 in + uu___24 :: uu___25 in + uu___22 :: uu___23 in + uu___20 :: uu___21 in + uu___18 :: uu___19 in + uu___16 :: uu___17 in + uu___14 :: uu___15 in + uu___12 :: uu___13 in + uu___10 :: uu___11 in + uu___8 :: uu___9 in + uu___6 :: uu___7 in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + FStarC_Syntax_Syntax.mk_Tm_app uu___ uu___1 rng in + let un t norm = + let uu___ = FStarC_Syntax_Util.head_and_args t in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst hd in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (initial_fuel, uu___2)::(max_fuel, uu___3)::(initial_ifuel, + uu___4)::(max_ifuel, + uu___5):: + (detail_errors, uu___6)::(detail_hint_replay, uu___7)::(no_smt, + uu___8):: + (quake_lo, uu___9)::(quake_hi, uu___10)::(quake_keep, uu___11):: + (retry, uu___12)::(smtencoding_elim_box, uu___13)::(smtencoding_nl_arith_repr, + uu___14):: + (smtencoding_l_arith_repr, uu___15)::(smtencoding_valid_intro, + uu___16)::(smtencoding_valid_elim, + uu___17):: + (tcnorm, uu___18)::(no_plugins, uu___19)::(no_tactics, uu___20):: + (z3cliopt, uu___21)::(z3smtopt, uu___22)::(z3refresh, uu___23):: + (z3rlimit, uu___24)::(z3rlimit_factor, uu___25)::(z3seed, + uu___26):: + (z3version, uu___27)::(trivial_pre_for_unannotated_effectful_fns, + uu___28)::(reuse_hint_for, uu___29)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.mkvconfig_lid + -> + let uu___30 = + FStarC_Syntax_Embeddings_Base.try_unembed e_fsint initial_fuel + norm in + FStarC_Compiler_Util.bind_opt uu___30 + (fun initial_fuel1 -> + let uu___31 = + FStarC_Syntax_Embeddings_Base.try_unembed e_fsint + max_fuel norm in + FStarC_Compiler_Util.bind_opt uu___31 + (fun max_fuel1 -> + let uu___32 = + FStarC_Syntax_Embeddings_Base.try_unembed e_fsint + initial_ifuel norm in + FStarC_Compiler_Util.bind_opt uu___32 + (fun initial_ifuel1 -> + let uu___33 = + FStarC_Syntax_Embeddings_Base.try_unembed + e_fsint max_ifuel norm in + FStarC_Compiler_Util.bind_opt uu___33 + (fun max_ifuel1 -> + let uu___34 = + FStarC_Syntax_Embeddings_Base.try_unembed + e_bool detail_errors norm in + FStarC_Compiler_Util.bind_opt uu___34 + (fun detail_errors1 -> + let uu___35 = + FStarC_Syntax_Embeddings_Base.try_unembed + e_bool detail_hint_replay norm in + FStarC_Compiler_Util.bind_opt uu___35 + (fun detail_hint_replay1 -> + let uu___36 = + FStarC_Syntax_Embeddings_Base.try_unembed + e_bool no_smt norm in + FStarC_Compiler_Util.bind_opt + uu___36 + (fun no_smt1 -> + let uu___37 = + FStarC_Syntax_Embeddings_Base.try_unembed + e_fsint quake_lo norm in + FStarC_Compiler_Util.bind_opt + uu___37 + (fun quake_lo1 -> + let uu___38 = + FStarC_Syntax_Embeddings_Base.try_unembed + e_fsint quake_hi + norm in + FStarC_Compiler_Util.bind_opt + uu___38 + (fun quake_hi1 -> + let uu___39 = + FStarC_Syntax_Embeddings_Base.try_unembed + e_bool + quake_keep norm in + FStarC_Compiler_Util.bind_opt + uu___39 + (fun quake_keep1 + -> + let uu___40 = + FStarC_Syntax_Embeddings_Base.try_unembed + e_bool + retry norm in + FStarC_Compiler_Util.bind_opt + uu___40 + (fun retry1 + -> + let uu___41 + = + FStarC_Syntax_Embeddings_Base.try_unembed + e_bool + smtencoding_elim_box + norm in + FStarC_Compiler_Util.bind_opt + uu___41 + (fun + smtencoding_elim_box1 + -> + let uu___42 + = + FStarC_Syntax_Embeddings_Base.try_unembed + e_string + smtencoding_nl_arith_repr + norm in + FStarC_Compiler_Util.bind_opt + uu___42 + (fun + smtencoding_nl_arith_repr1 + -> + let uu___43 + = + FStarC_Syntax_Embeddings_Base.try_unembed + e_string + smtencoding_l_arith_repr + norm in + FStarC_Compiler_Util.bind_opt + uu___43 + (fun + smtencoding_l_arith_repr1 + -> + let uu___44 + = + FStarC_Syntax_Embeddings_Base.try_unembed + e_bool + smtencoding_valid_intro + norm in + FStarC_Compiler_Util.bind_opt + uu___44 + (fun + smtencoding_valid_intro1 + -> + let uu___45 + = + FStarC_Syntax_Embeddings_Base.try_unembed + e_bool + smtencoding_valid_elim + norm in + FStarC_Compiler_Util.bind_opt + uu___45 + (fun + smtencoding_valid_elim1 + -> + let uu___46 + = + FStarC_Syntax_Embeddings_Base.try_unembed + e_bool + tcnorm + norm in + FStarC_Compiler_Util.bind_opt + uu___46 + (fun + tcnorm1 + -> + let uu___47 + = + FStarC_Syntax_Embeddings_Base.try_unembed + e_bool + no_plugins + norm in + FStarC_Compiler_Util.bind_opt + uu___47 + (fun + no_plugins1 + -> + let uu___48 + = + FStarC_Syntax_Embeddings_Base.try_unembed + e_bool + no_tactics + norm in + FStarC_Compiler_Util.bind_opt + uu___48 + (fun + no_tactics1 + -> + let uu___49 + = + FStarC_Syntax_Embeddings_Base.try_unembed + e_string_list + z3cliopt + norm in + FStarC_Compiler_Util.bind_opt + uu___49 + (fun + z3cliopt1 + -> + let uu___50 + = + FStarC_Syntax_Embeddings_Base.try_unembed + e_string_list + z3smtopt + norm in + FStarC_Compiler_Util.bind_opt + uu___50 + (fun + z3smtopt1 + -> + let uu___51 + = + FStarC_Syntax_Embeddings_Base.try_unembed + e_bool + z3refresh + norm in + FStarC_Compiler_Util.bind_opt + uu___51 + (fun + z3refresh1 + -> + let uu___52 + = + FStarC_Syntax_Embeddings_Base.try_unembed + e_fsint + z3rlimit + norm in + FStarC_Compiler_Util.bind_opt + uu___52 + (fun + z3rlimit1 + -> + let uu___53 + = + FStarC_Syntax_Embeddings_Base.try_unembed + e_fsint + z3rlimit_factor + norm in + FStarC_Compiler_Util.bind_opt + uu___53 + (fun + z3rlimit_factor1 + -> + let uu___54 + = + FStarC_Syntax_Embeddings_Base.try_unembed + e_fsint + z3seed + norm in + FStarC_Compiler_Util.bind_opt + uu___54 + (fun + z3seed1 + -> + let uu___55 + = + FStarC_Syntax_Embeddings_Base.try_unembed + e_string + z3version + norm in + FStarC_Compiler_Util.bind_opt + uu___55 + (fun + z3version1 + -> + let uu___56 + = + FStarC_Syntax_Embeddings_Base.try_unembed + e_bool + trivial_pre_for_unannotated_effectful_fns + norm in + FStarC_Compiler_Util.bind_opt + uu___56 + (fun + trivial_pre_for_unannotated_effectful_fns1 + -> + let uu___57 + = + FStarC_Syntax_Embeddings_Base.try_unembed + (e_option + e_string) + reuse_hint_for + norm in + FStarC_Compiler_Util.bind_opt + uu___57 + (fun + reuse_hint_for1 + -> + FStar_Pervasives_Native.Some + { + FStarC_VConfig.initial_fuel + = + initial_fuel1; + FStarC_VConfig.max_fuel + = + max_fuel1; + FStarC_VConfig.initial_ifuel + = + initial_ifuel1; + FStarC_VConfig.max_ifuel + = + max_ifuel1; + FStarC_VConfig.detail_errors + = + detail_errors1; + FStarC_VConfig.detail_hint_replay + = + detail_hint_replay1; + FStarC_VConfig.no_smt + = no_smt1; + FStarC_VConfig.quake_lo + = + quake_lo1; + FStarC_VConfig.quake_hi + = + quake_hi1; + FStarC_VConfig.quake_keep + = + quake_keep1; + FStarC_VConfig.retry + = retry1; + FStarC_VConfig.smtencoding_elim_box + = + smtencoding_elim_box1; + FStarC_VConfig.smtencoding_nl_arith_repr + = + smtencoding_nl_arith_repr1; + FStarC_VConfig.smtencoding_l_arith_repr + = + smtencoding_l_arith_repr1; + FStarC_VConfig.smtencoding_valid_intro + = + smtencoding_valid_intro1; + FStarC_VConfig.smtencoding_valid_elim + = + smtencoding_valid_elim1; + FStarC_VConfig.tcnorm + = tcnorm1; + FStarC_VConfig.no_plugins + = + no_plugins1; + FStarC_VConfig.no_tactics + = + no_tactics1; + FStarC_VConfig.z3cliopt + = + z3cliopt1; + FStarC_VConfig.z3smtopt + = + z3smtopt1; + FStarC_VConfig.z3refresh + = + z3refresh1; + FStarC_VConfig.z3rlimit + = + z3rlimit1; + FStarC_VConfig.z3rlimit_factor + = + z3rlimit_factor1; + FStarC_VConfig.z3seed + = z3seed1; + FStarC_VConfig.z3version + = + z3version1; + FStarC_VConfig.trivial_pre_for_unannotated_effectful_fns + = + trivial_pre_for_unannotated_effectful_fns1; + FStarC_VConfig.reuse_hint_for + = + reuse_hint_for1 + })))))))))))))))))))))))))))) + | uu___2 -> FStar_Pervasives_Native.None) in + FStarC_Syntax_Embeddings_Base.mk_emb_full em un + (fun uu___ -> FStarC_Syntax_Syntax.t_vconfig) (fun uu___ -> "vconfig") + (fun uu___ -> + let uu___1 = + let uu___2 = + FStarC_Ident.string_of_lid FStarC_Parser_Const.vconfig_lid in + (uu___2, []) in + FStarC_Syntax_Syntax.ET_app uu___1) +let (e_order : FStar_Order.order FStarC_Syntax_Embeddings_Base.embedding) = + let ord_Lt_lid = + FStarC_Ident.lid_of_path ["FStar"; "Order"; "Lt"] + FStarC_Compiler_Range_Type.dummyRange in + let ord_Eq_lid = + FStarC_Ident.lid_of_path ["FStar"; "Order"; "Eq"] + FStarC_Compiler_Range_Type.dummyRange in + let ord_Gt_lid = + FStarC_Ident.lid_of_path ["FStar"; "Order"; "Gt"] + FStarC_Compiler_Range_Type.dummyRange in + let ord_Lt = FStarC_Syntax_Syntax.tdataconstr ord_Lt_lid in + let ord_Eq = FStarC_Syntax_Syntax.tdataconstr ord_Eq_lid in + let ord_Gt = FStarC_Syntax_Syntax.tdataconstr ord_Gt_lid in + let ord_Lt_fv = + FStarC_Syntax_Syntax.lid_as_fv ord_Lt_lid + (FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.Data_ctor) in + let ord_Eq_fv = + FStarC_Syntax_Syntax.lid_as_fv ord_Eq_lid + (FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.Data_ctor) in + let ord_Gt_fv = + FStarC_Syntax_Syntax.lid_as_fv ord_Gt_lid + (FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.Data_ctor) in + let embed_order o rng shadow cb = + let r = + match o with + | FStar_Order.Lt -> ord_Lt + | FStar_Order.Eq -> ord_Eq + | FStar_Order.Gt -> ord_Gt in + { + FStarC_Syntax_Syntax.n = (r.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = rng; + FStarC_Syntax_Syntax.vars = (r.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = (r.FStarC_Syntax_Syntax.hash_code) + } in + let unembed_order t cb = + let t1 = FStarC_Syntax_Util.unascribe t in + let uu___ = FStarC_Syntax_Util.head_and_args t1 in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst hd in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv ord_Lt_lid -> + FStar_Pervasives_Native.Some FStar_Order.Lt + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv ord_Eq_lid -> + FStar_Pervasives_Native.Some FStar_Order.Eq + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv ord_Gt_lid -> + FStar_Pervasives_Native.Some FStar_Order.Gt + | uu___2 -> FStar_Pervasives_Native.None) in + let uu___ = + FStarC_Syntax_Syntax.lid_as_fv FStarC_Parser_Const.order_lid + FStar_Pervasives_Native.None in + FStarC_Syntax_Embeddings_Base.mk_emb embed_order unembed_order uu___ +let or_else : 'a . 'a FStar_Pervasives_Native.option -> (unit -> 'a) -> 'a = + fun f -> + fun g -> + match f with + | FStar_Pervasives_Native.Some x -> x + | FStar_Pervasives_Native.None -> g () +let e_arrow : + 'a 'b . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'b FStarC_Syntax_Embeddings_Base.embedding -> + ('a -> 'b) FStarC_Syntax_Embeddings_Base.embedding + = + fun ea -> + fun eb -> + let typ uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Syntax_Embeddings_Base.type_of ea in + FStarC_Syntax_Syntax.null_bv uu___6 in + FStarC_Syntax_Syntax.mk_binder uu___5 in + [uu___4] in + let uu___4 = + let uu___5 = FStarC_Syntax_Embeddings_Base.type_of eb in + FStarC_Syntax_Syntax.mk_Total uu___5 in + { + FStarC_Syntax_Syntax.bs1 = uu___3; + FStarC_Syntax_Syntax.comp = uu___4 + } in + FStarC_Syntax_Syntax.Tm_arrow uu___2 in + FStarC_Syntax_Syntax.mk uu___1 FStarC_Compiler_Range_Type.dummyRange in + let emb_t_arr_a_b uu___ = + let uu___1 = + let uu___2 = FStarC_Syntax_Embeddings_Base.emb_typ_of ea () in + let uu___3 = FStarC_Syntax_Embeddings_Base.emb_typ_of eb () in + (uu___2, uu___3) in + FStarC_Syntax_Syntax.ET_fun uu___1 in + let printer1 f = "" in + let em f rng shadow_f norm = + lazy_embed printer1 emb_t_arr_a_b rng typ f + (fun uu___ -> + let uu___1 = force_shadow shadow_f in + match uu___1 with + | FStar_Pervasives_Native.None -> + FStarC_Compiler_Effect.raise Embedding_failure + | FStar_Pervasives_Native.Some repr_f -> + ((let uu___3 = + FStarC_Compiler_Effect.op_Bang + FStarC_Options.debug_embedding in + if uu___3 + then + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term repr_f in + let uu___5 = FStarC_Compiler_Util.stack_dump () in + FStarC_Compiler_Util.print2 + "e_arrow forced back to term using shadow %s; repr=%s\n" + uu___4 uu___5 + else ()); + (let res = norm (FStar_Pervasives.Inr repr_f) in + (let uu___4 = + FStarC_Compiler_Effect.op_Bang + FStarC_Options.debug_embedding in + if uu___4 + then + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term repr_f in + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term res in + let uu___7 = FStarC_Compiler_Util.stack_dump () in + FStarC_Compiler_Util.print3 + "e_arrow forced back to term using shadow %s; repr=%s\n\t%s\n" + uu___5 uu___6 uu___7 + else ()); + res))) in + let un f norm = + lazy_unembed printer1 emb_t_arr_a_b f typ + (fun f1 -> + let f_wrapped a1 = + (let uu___1 = + FStarC_Compiler_Effect.op_Bang + FStarC_Options.debug_embedding in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + f1 in + let uu___3 = FStarC_Compiler_Util.stack_dump () in + FStarC_Compiler_Util.print2 + "Calling back into normalizer for %s\n%s\n" uu___2 uu___3 + else ()); + (let a_tm = + let uu___1 = FStarC_Syntax_Embeddings_Base.embed ea a1 in + uu___1 f1.FStarC_Syntax_Syntax.pos + FStar_Pervasives_Native.None norm in + let b_tm = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Syntax.as_arg a_tm in + [uu___4] in + FStarC_Syntax_Syntax.mk_Tm_app f1 uu___3 + f1.FStarC_Syntax_Syntax.pos in + FStar_Pervasives.Inr uu___2 in + norm uu___1 in + let uu___1 = + FStarC_Syntax_Embeddings_Base.unembed eb b_tm norm in + match uu___1 with + | FStar_Pervasives_Native.None -> + FStarC_Compiler_Effect.raise Unembedding_failure + | FStar_Pervasives_Native.Some b1 -> b1) in + FStar_Pervasives_Native.Some f_wrapped) in + FStarC_Syntax_Embeddings_Base.mk_emb_full em un typ printer1 + emb_t_arr_a_b +let e_sealed : + 'a . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'a FStarC_Compiler_Sealed.sealed + FStarC_Syntax_Embeddings_Base.embedding + = + fun ea -> + let typ uu___ = + let uu___1 = FStarC_Syntax_Embeddings_Base.type_of ea in + FStarC_Syntax_Syntax.t_sealed_of uu___1 in + let emb_ty_a uu___ = + let uu___1 = + let uu___2 = + FStarC_Ident.string_of_lid FStarC_Parser_Const.sealed_lid in + let uu___3 = + let uu___4 = FStarC_Syntax_Embeddings_Base.emb_typ_of ea () in + [uu___4] in + (uu___2, uu___3) in + FStarC_Syntax_Syntax.ET_app uu___1 in + let printer1 x = + let uu___ = + let uu___1 = + let uu___2 = FStarC_Syntax_Embeddings_Base.printer_of ea in + uu___2 (FStarC_Compiler_Sealed.unseal x) in + Prims.strcat uu___1 ")" in + Prims.strcat "(seal " uu___ in + let em a1 rng shadow norm = + let shadow_a = + map_shadow shadow + (fun t -> + let unseal = + FStarC_Syntax_Util.fvar_const FStarC_Parser_Const.unseal_lid in + let uu___ = + FStarC_Syntax_Syntax.mk_Tm_uinst unseal + [FStarC_Syntax_Syntax.U_zero] in + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Embeddings_Base.type_of ea in + FStarC_Syntax_Syntax.iarg uu___3 in + let uu___3 = + let uu___4 = FStarC_Syntax_Syntax.as_arg t in [uu___4] in + uu___2 :: uu___3 in + FStarC_Syntax_Syntax.mk_Tm_app uu___ uu___1 rng) in + let uu___ = + let uu___1 = + FStarC_Syntax_Util.fvar_const FStarC_Parser_Const.seal_lid in + FStarC_Syntax_Syntax.mk_Tm_uinst uu___1 [FStarC_Syntax_Syntax.U_zero] in + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Embeddings_Base.type_of ea in + FStarC_Syntax_Syntax.iarg uu___3 in + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Embeddings_Base.embed ea + (FStarC_Compiler_Sealed.unseal a1) in + uu___6 rng shadow_a norm in + FStarC_Syntax_Syntax.as_arg uu___5 in + [uu___4] in + uu___2 :: uu___3 in + FStarC_Syntax_Syntax.mk_Tm_app uu___ uu___1 rng in + let un uu___1 uu___ = + (fun t -> + fun norm -> + let uu___ = FStarC_Syntax_Util.head_and_args_full t in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst hd in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, uu___2::(a1, uu___3)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.seal_lid + -> + Obj.magic + (Obj.repr + (let uu___4 = + FStarC_Syntax_Embeddings_Base.try_unembed ea a1 + norm in + FStarC_Class_Monad.fmap + FStarC_Class_Monad.monad_option () () + (fun uu___5 -> + (Obj.magic FStarC_Compiler_Sealed.seal) uu___5) + (Obj.magic uu___4))) + | uu___2 -> Obj.magic (Obj.repr FStar_Pervasives_Native.None))) + uu___1 uu___ in + FStarC_Syntax_Embeddings_Base.mk_emb_full em un typ printer1 emb_ty_a +let (e___range : + FStarC_Compiler_Range_Type.range FStarC_Syntax_Embeddings_Base.embedding) = + let em r rng _shadow _norm = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_constant (FStarC_Const.Const_range r)) rng in + let un t _norm = + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_constant (FStarC_Const.Const_range r) -> + FStar_Pervasives_Native.Some r + | uu___1 -> FStar_Pervasives_Native.None in + FStarC_Syntax_Embeddings_Base.mk_emb_full em un + (fun uu___ -> FStarC_Syntax_Syntax.t___range) + FStarC_Compiler_Range_Ops.string_of_range + (fun uu___ -> + let uu___1 = + let uu___2 = + FStarC_Ident.string_of_lid FStarC_Parser_Const.range_lid in + (uu___2, []) in + FStarC_Syntax_Syntax.ET_app uu___1) +let (e_range : + FStarC_Compiler_Range_Type.range FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Syntax_Embeddings_Base.embed_as (e_sealed e___range) + FStarC_Compiler_Sealed.unseal FStarC_Compiler_Sealed.seal + FStar_Pervasives_Native.None +let (e_issue : FStarC_Errors.issue FStarC_Syntax_Embeddings_Base.embedding) = + let uu___ = + FStarC_Syntax_Syntax.fvar FStarC_Parser_Const.issue_lid + FStar_Pervasives_Native.None in + FStarC_Syntax_Embeddings_Base.e_lazy FStarC_Syntax_Syntax.Lazy_issue uu___ +let (e_document : + FStarC_Pprint.document FStarC_Syntax_Embeddings_Base.embedding) = + let uu___ = + FStarC_Syntax_Syntax.fvar FStarC_Parser_Const.document_lid + FStar_Pervasives_Native.None in + FStarC_Syntax_Embeddings_Base.e_lazy FStarC_Syntax_Syntax.Lazy_doc uu___ +type abstract_term = + | Abstract of FStarC_Syntax_Syntax.term +let (uu___is_Abstract : abstract_term -> Prims.bool) = fun projectee -> true +let (__proj__Abstract__item__t : abstract_term -> FStarC_Syntax_Syntax.term) + = fun projectee -> match projectee with | Abstract t -> t +let arrow_as_prim_step_1 : + 'a 'b . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'b FStarC_Syntax_Embeddings_Base.embedding -> + ('a -> 'b) -> + FStarC_Ident.lid -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option + = + fun ea -> + fun eb -> + fun f -> + fun fv_lid -> + fun norm -> + let rng = FStarC_Ident.range_of_lid fv_lid in + let f_wrapped _us args = + let uu___ = args in + match uu___ with + | (x, uu___1)::[] -> + let shadow_app = + let uu___2 = + FStarC_Thunk.mk + (fun uu___3 -> + let uu___4 = norm (FStar_Pervasives.Inl fv_lid) in + FStarC_Syntax_Syntax.mk_Tm_app uu___4 args rng) in + FStar_Pervasives_Native.Some uu___2 in + let uu___2 = + let uu___3 = + FStarC_Syntax_Embeddings_Base.try_unembed ea x norm in + FStarC_Compiler_Util.map_opt uu___3 + (fun x1 -> + let uu___4 = + let uu___5 = f x1 in + FStarC_Syntax_Embeddings_Base.embed eb uu___5 in + uu___4 rng shadow_app norm) in + (match uu___2 with + | FStar_Pervasives_Native.Some x1 -> + FStar_Pervasives_Native.Some x1 + | FStar_Pervasives_Native.None -> force_shadow shadow_app) in + f_wrapped +let arrow_as_prim_step_2 : + 'a 'b 'c . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'b FStarC_Syntax_Embeddings_Base.embedding -> + 'c FStarC_Syntax_Embeddings_Base.embedding -> + ('a -> 'b -> 'c) -> + FStarC_Ident.lid -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option + = + fun ea -> + fun eb -> + fun ec -> + fun f -> + fun fv_lid -> + fun norm -> + let rng = FStarC_Ident.range_of_lid fv_lid in + let f_wrapped _us args = + let uu___ = args in + match uu___ with + | (x, uu___1)::(y, uu___2)::[] -> + let shadow_app = + let uu___3 = + FStarC_Thunk.mk + (fun uu___4 -> + let uu___5 = norm (FStar_Pervasives.Inl fv_lid) in + FStarC_Syntax_Syntax.mk_Tm_app uu___5 args rng) in + FStar_Pervasives_Native.Some uu___3 in + let uu___3 = + let uu___4 = + FStarC_Syntax_Embeddings_Base.try_unembed ea x norm in + FStarC_Compiler_Util.bind_opt uu___4 + (fun x1 -> + let uu___5 = + FStarC_Syntax_Embeddings_Base.try_unembed eb y + norm in + FStarC_Compiler_Util.bind_opt uu___5 + (fun y1 -> + let uu___6 = + let uu___7 = + let uu___8 = f x1 y1 in + FStarC_Syntax_Embeddings_Base.embed ec + uu___8 in + uu___7 rng shadow_app norm in + FStar_Pervasives_Native.Some uu___6)) in + (match uu___3 with + | FStar_Pervasives_Native.Some x1 -> + FStar_Pervasives_Native.Some x1 + | FStar_Pervasives_Native.None -> + force_shadow shadow_app) in + f_wrapped +let arrow_as_prim_step_3 : + 'a 'b 'c 'd . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'b FStarC_Syntax_Embeddings_Base.embedding -> + 'c FStarC_Syntax_Embeddings_Base.embedding -> + 'd FStarC_Syntax_Embeddings_Base.embedding -> + ('a -> 'b -> 'c -> 'd) -> + FStarC_Ident.lid -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun ea -> + fun eb -> + fun ec -> + fun ed -> + fun f -> + fun fv_lid -> + fun norm -> + let rng = FStarC_Ident.range_of_lid fv_lid in + let f_wrapped _us args = + let uu___ = args in + match uu___ with + | (x, uu___1)::(y, uu___2)::(z, uu___3)::[] -> + let shadow_app = + let uu___4 = + FStarC_Thunk.mk + (fun uu___5 -> + let uu___6 = + norm (FStar_Pervasives.Inl fv_lid) in + FStarC_Syntax_Syntax.mk_Tm_app uu___6 args rng) in + FStar_Pervasives_Native.Some uu___4 in + let uu___4 = + let uu___5 = + FStarC_Syntax_Embeddings_Base.try_unembed ea x norm in + FStarC_Compiler_Util.bind_opt uu___5 + (fun x1 -> + let uu___6 = + FStarC_Syntax_Embeddings_Base.try_unembed eb y + norm in + FStarC_Compiler_Util.bind_opt uu___6 + (fun y1 -> + let uu___7 = + FStarC_Syntax_Embeddings_Base.try_unembed + ec z norm in + FStarC_Compiler_Util.bind_opt uu___7 + (fun z1 -> + let uu___8 = + let uu___9 = + let uu___10 = f x1 y1 z1 in + FStarC_Syntax_Embeddings_Base.embed + ed uu___10 in + uu___9 rng shadow_app norm in + FStar_Pervasives_Native.Some uu___8))) in + (match uu___4 with + | FStar_Pervasives_Native.Some x1 -> + FStar_Pervasives_Native.Some x1 + | FStar_Pervasives_Native.None -> + force_shadow shadow_app) in + f_wrapped +let debug_wrap : 'a . Prims.string -> (unit -> 'a) -> 'a = + fun s -> + fun f -> + (let uu___1 = + FStarC_Compiler_Effect.op_Bang FStarC_Options.debug_embedding in + if uu___1 + then FStarC_Compiler_Util.print1 "++++starting %s\n" s + else ()); + (let res = f () in + (let uu___2 = + FStarC_Compiler_Effect.op_Bang FStarC_Options.debug_embedding in + if uu___2 + then FStarC_Compiler_Util.print1 "------ending %s\n" s + else ()); + res) +let (e_abstract_term : abstract_term FStarC_Syntax_Embeddings_Base.embedding) + = + FStarC_Syntax_Embeddings_Base.embed_as e_any (fun x -> Abstract x) + (fun x -> match x with | Abstract x1 -> x1) FStar_Pervasives_Native.None \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Syntax_Embeddings_AppEmb.ml b/ocaml/fstar-lib/generated/FStarC_Syntax_Embeddings_AppEmb.ml new file mode 100644 index 00000000000..17e3bc6fd1d --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Syntax_Embeddings_AppEmb.ml @@ -0,0 +1,87 @@ +open Prims +type 'a appemb = + FStarC_Syntax_Syntax.args -> + ('a * FStarC_Syntax_Syntax.args) FStar_Pervasives_Native.option +let one : 'a . 'a FStarC_Syntax_Embeddings_Base.embedding -> 'a appemb = + fun e -> + fun args -> + match args with + | (t, uu___)::xs -> + let uu___1 = + FStarC_Syntax_Embeddings_Base.try_unembed e t + FStarC_Syntax_Embeddings_Base.id_norm_cb in + (match uu___1 with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some v -> + FStar_Pervasives_Native.Some (v, xs)) +let op_let_Question : + 'uuuuu 'uuuuu1 . + 'uuuuu FStar_Pervasives_Native.option -> + ('uuuuu -> 'uuuuu1 FStar_Pervasives_Native.option) -> + 'uuuuu1 FStar_Pervasives_Native.option + = + fun o -> + fun f -> + match o with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some v -> f v +let op_Less_Star_Greater : + 'a 'b . ('a -> 'b) appemb -> 'a appemb -> 'b appemb = + fun u1 -> + fun u2 -> + fun args -> + let uu___ = u1 args in + op_let_Question uu___ + (fun uu___1 -> + match uu___1 with + | (f, args') -> + let uu___2 = u2 args' in + op_let_Question uu___2 + (fun uu___3 -> + match uu___3 with + | (v, args'') -> + let uu___4 = let uu___5 = f v in (uu___5, args'') in + FStar_Pervasives_Native.Some uu___4)) +let op_Less_Star_Star_Greater : + 'a 'b . + ('a -> 'b) appemb -> + 'a FStarC_Syntax_Embeddings_Base.embedding -> 'b appemb + = fun u1 -> fun u2 -> let uu___ = one u2 in op_Less_Star_Greater u1 uu___ +let pure : 'a . 'a -> 'a appemb = + fun x -> fun args -> FStar_Pervasives_Native.Some (x, args) +let op_Less_Dollar_Greater : 'a 'b . ('a -> 'b) -> 'a appemb -> 'b appemb = + fun u1 -> fun u2 -> let uu___ = pure u1 in op_Less_Star_Greater uu___ u2 +let op_Less_Dollar_Dollar_Greater : + 'a 'b . + ('a -> 'b) -> 'a FStarC_Syntax_Embeddings_Base.embedding -> 'b appemb + = + fun u1 -> + fun u2 -> + let uu___ = pure u1 in + let uu___1 = one u2 in op_Less_Star_Greater uu___ uu___1 +let run : + 'a . + FStarC_Syntax_Syntax.args -> + 'a appemb -> 'a FStar_Pervasives_Native.option + = + fun args -> + fun u -> + let uu___ = u args in + match uu___ with + | FStar_Pervasives_Native.Some (r, []) -> + FStar_Pervasives_Native.Some r + | uu___1 -> FStar_Pervasives_Native.None +let wrap : + 'a . + (FStarC_Syntax_Syntax.term -> 'a FStar_Pervasives_Native.option) -> + 'a appemb + = + fun f -> + fun args -> + match args with + | (t, uu___)::xs -> + let uu___1 = f t in + (match uu___1 with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some v -> + FStar_Pervasives_Native.Some (v, xs)) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Syntax_Embeddings_Base.ml b/ocaml/fstar-lib/generated/FStarC_Syntax_Embeddings_Base.ml new file mode 100644 index 00000000000..3bb4ec8cd30 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Syntax_Embeddings_Base.ml @@ -0,0 +1,514 @@ +open Prims +type norm_cb = + (FStarC_Ident.lident, FStarC_Syntax_Syntax.term) FStar_Pervasives.either -> + FStarC_Syntax_Syntax.term +type shadow_term = + FStarC_Syntax_Syntax.term FStarC_Thunk.t FStar_Pervasives_Native.option +type embed_t = + FStarC_Compiler_Range_Type.range -> + shadow_term -> norm_cb -> FStarC_Syntax_Syntax.term +type 'a unembed_t = norm_cb -> 'a FStar_Pervasives_Native.option +type 'a raw_embedder = 'a -> embed_t +type 'a raw_unembedder = FStarC_Syntax_Syntax.term -> 'a unembed_t +type 'a printer = 'a -> Prims.string +let (id_norm_cb : norm_cb) = + fun uu___ -> + match uu___ with + | FStar_Pervasives.Inr x -> x + | FStar_Pervasives.Inl l -> + let uu___1 = + FStarC_Syntax_Syntax.lid_as_fv l FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___1 +exception Embedding_failure +let (uu___is_Embedding_failure : Prims.exn -> Prims.bool) = + fun projectee -> + match projectee with | Embedding_failure -> true | uu___ -> false +exception Unembedding_failure +let (uu___is_Unembedding_failure : Prims.exn -> Prims.bool) = + fun projectee -> + match projectee with | Unembedding_failure -> true | uu___ -> false +let (map_shadow : + shadow_term -> + (FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) -> shadow_term) + = fun s -> fun f -> FStarC_Compiler_Util.map_opt s (FStarC_Thunk.map f) +let (force_shadow : + shadow_term -> FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) = + fun s -> FStarC_Compiler_Util.map_opt s FStarC_Thunk.force +type 'a embedding = + { + em: 'a -> embed_t ; + un: FStarC_Syntax_Syntax.term -> 'a unembed_t ; + print: 'a printer ; + typ: unit -> FStarC_Syntax_Syntax.typ ; + e_typ: unit -> FStarC_Syntax_Syntax.emb_typ } +let __proj__Mkembedding__item__em : 'a . 'a embedding -> 'a -> embed_t = + fun projectee -> + match projectee with | { em; un; print; typ; e_typ;_} -> em +let __proj__Mkembedding__item__un : + 'a . 'a embedding -> FStarC_Syntax_Syntax.term -> 'a unembed_t = + fun projectee -> + match projectee with | { em; un; print; typ; e_typ;_} -> un +let __proj__Mkembedding__item__print : 'a . 'a embedding -> 'a printer = + fun projectee -> + match projectee with | { em; un; print; typ; e_typ;_} -> print +let __proj__Mkembedding__item__typ : + 'a . 'a embedding -> unit -> FStarC_Syntax_Syntax.typ = + fun projectee -> + match projectee with | { em; un; print; typ; e_typ;_} -> typ +let __proj__Mkembedding__item__e_typ : + 'a . 'a embedding -> unit -> FStarC_Syntax_Syntax.emb_typ = + fun projectee -> + match projectee with | { em; un; print; typ; e_typ;_} -> e_typ +let em : 'a . 'a embedding -> 'a -> embed_t = + fun projectee -> + match projectee with | { em = em1; un; print; typ; e_typ;_} -> em1 +let un : 'a . 'a embedding -> FStarC_Syntax_Syntax.term -> 'a unembed_t = + fun projectee -> + match projectee with | { em = em1; un = un1; print; typ; e_typ;_} -> un1 +let print : 'a . 'a embedding -> 'a printer = + fun projectee -> + match projectee with + | { em = em1; un = un1; print = print1; typ; e_typ;_} -> print1 +let typ : 'a . 'a embedding -> unit -> FStarC_Syntax_Syntax.typ = + fun projectee -> + match projectee with + | { em = em1; un = un1; print = print1; typ = typ1; e_typ;_} -> typ1 +let e_typ : 'a . 'a embedding -> unit -> FStarC_Syntax_Syntax.emb_typ = + fun projectee -> + match projectee with + | { em = em1; un = un1; print = print1; typ = typ1; e_typ = e_typ1;_} -> + e_typ1 +let emb_typ_of : 'a . 'a embedding -> unit -> FStarC_Syntax_Syntax.emb_typ = + fun e -> fun uu___ -> e.e_typ () +let unknown_printer : 'a . FStarC_Syntax_Syntax.term -> 'a -> Prims.string = + fun typ1 -> + fun uu___ -> + let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term typ1 in + FStarC_Compiler_Util.format1 "unknown %s" uu___1 +let (term_as_fv : FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.fv) = + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_fvar fv -> fv + | uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.format1 "Embeddings not defined for type %s" + uu___3 in + failwith uu___2 +let mk_emb : + 'a . + 'a raw_embedder -> + 'a raw_unembedder -> FStarC_Syntax_Syntax.fv -> 'a embedding + = + fun em1 -> + fun un1 -> + fun fv -> + { + em = em1; + un = un1; + print = + (fun x -> + let typ1 = FStarC_Syntax_Syntax.fv_to_tm fv in + unknown_printer typ1 x); + typ = (fun uu___ -> FStarC_Syntax_Syntax.fv_to_tm fv); + e_typ = + (fun uu___ -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.lid_of_fv fv in + FStarC_Ident.string_of_lid uu___3 in + (uu___2, []) in + FStarC_Syntax_Syntax.ET_app uu___1) + } +let mk_emb_full : + 'a . + 'a raw_embedder -> + 'a raw_unembedder -> + (unit -> FStarC_Syntax_Syntax.typ) -> + ('a -> Prims.string) -> + (unit -> FStarC_Syntax_Syntax.emb_typ) -> 'a embedding + = + fun em1 -> + fun un1 -> + fun typ1 -> + fun printe -> + fun emb_typ -> + { em = em1; un = un1; print = printe; typ = typ1; e_typ = emb_typ + } +let rec (unmeta_div_results : + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) = + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t'; + FStarC_Syntax_Syntax.meta = FStarC_Syntax_Syntax.Meta_monadic_lift + (src, dst, uu___1);_} + -> + let uu___2 = + (FStarC_Ident.lid_equals src FStarC_Parser_Const.effect_PURE_lid) + && + (FStarC_Ident.lid_equals dst FStarC_Parser_Const.effect_DIV_lid) in + if uu___2 then unmeta_div_results t' else t + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t'; + FStarC_Syntax_Syntax.meta = FStarC_Syntax_Syntax.Meta_monadic + (m, uu___1);_} + -> + let uu___2 = + FStarC_Ident.lid_equals m FStarC_Parser_Const.effect_DIV_lid in + if uu___2 then unmeta_div_results t' else t + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t'; + FStarC_Syntax_Syntax.meta = uu___1;_} + -> unmeta_div_results t' + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t'; FStarC_Syntax_Syntax.asc = uu___1; + FStarC_Syntax_Syntax.eff_opt = uu___2;_} + -> unmeta_div_results t' + | uu___1 -> t +let type_of : 'a . 'a embedding -> FStarC_Syntax_Syntax.typ = + fun e -> e.typ () +let printer_of : 'a . 'a embedding -> 'a printer = fun e -> e.print +let set_type : 'a . FStarC_Syntax_Syntax.typ -> 'a embedding -> 'a embedding + = + fun ty -> + fun e -> + { + em = (e.em); + un = (e.un); + print = (e.print); + typ = (fun uu___ -> ty); + e_typ = (e.e_typ) + } +let embed : 'a . 'a embedding -> 'a -> embed_t = fun e -> e.em +let try_unembed : + 'a . + 'a embedding -> + FStarC_Syntax_Syntax.term -> + norm_cb -> 'a FStar_Pervasives_Native.option + = + fun e -> + fun t -> + fun n -> + let t1 = unmeta_div_results t in + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t1 in e.un uu___1 in + uu___ n +let unembed : + 'a . + 'a embedding -> + FStarC_Syntax_Syntax.term -> + norm_cb -> 'a FStar_Pervasives_Native.option + = + fun e -> + fun t -> + fun n -> + let r = try_unembed e t n in + if FStar_Pervasives_Native.uu___is_None r + then + (let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Errors_Msg.text "Unembedding failed for type" in + let uu___4 = + let uu___5 = type_of e in + FStarC_Class_PP.pp FStarC_Syntax_Print.pretty_term uu___5 in + FStarC_Pprint.op_Hat_Slash_Hat uu___3 uu___4 in + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Errors_Msg.text "emb_typ = " in + let uu___6 = + let uu___7 = + let uu___8 = emb_typ_of e () in + FStarC_Class_Show.show + FStarC_Syntax_Syntax.showable_emb_typ uu___8 in + FStarC_Pprint.doc_of_string uu___7 in + FStarC_Pprint.op_Hat_Slash_Hat uu___5 uu___6 in + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Errors_Msg.text "Term =" in + let uu___8 = + FStarC_Class_PP.pp FStarC_Syntax_Print.pretty_term t in + FStarC_Pprint.op_Hat_Slash_Hat uu___7 uu___8 in + [uu___6] in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + FStarC_Errors.log_issue (FStarC_Syntax_Syntax.has_range_syntax ()) + t FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___1)) + else (); + r +let embed_as : + 'a 'b . + 'a embedding -> + ('a -> 'b) -> + ('b -> 'a) -> + FStarC_Syntax_Syntax.typ FStar_Pervasives_Native.option -> + 'b embedding + = + fun ea -> + fun ab -> + fun ba -> + fun o -> + mk_emb_full (fun x -> let uu___ = ba x in embed ea uu___) + (fun t -> + fun cb -> + let uu___ = try_unembed ea t cb in + FStarC_Compiler_Util.map_opt uu___ ab) + (fun uu___ -> + match o with + | FStar_Pervasives_Native.Some t -> t + | uu___1 -> type_of ea) + (fun x -> + let uu___ = let uu___1 = ba x in ea.print uu___1 in + FStarC_Compiler_Util.format1 "(embed_as>> %s)\n" uu___) + ea.e_typ +let e_lazy : + 'a . + FStarC_Syntax_Syntax.lazy_kind -> + FStarC_Syntax_Syntax.term -> 'a embedding + = + fun k -> + fun ty -> + let ee x rng _topt _norm = + FStarC_Syntax_Util.mk_lazy x ty k (FStar_Pervasives_Native.Some rng) in + let uu t _norm = + let t0 = t in + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_lazy + { FStarC_Syntax_Syntax.blob = b; + FStarC_Syntax_Syntax.lkind = lkind; + FStarC_Syntax_Syntax.ltyp = uu___1; + FStarC_Syntax_Syntax.rng = uu___2;_} + when + FStarC_Class_Deq.op_Equals_Question + FStarC_Syntax_Syntax.deq_lazy_kind lkind k + -> + let uu___3 = FStarC_Dyn.undyn b in + FStar_Pervasives_Native.Some uu___3 + | FStarC_Syntax_Syntax.Tm_lazy + { FStarC_Syntax_Syntax.blob = b; + FStarC_Syntax_Syntax.lkind = lkind; + FStarC_Syntax_Syntax.ltyp = uu___1; + FStarC_Syntax_Syntax.rng = uu___2;_} + -> + ((let uu___4 = + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Syntax.showable_lazy_kind k in + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Syntax.showable_lazy_kind lkind in + let uu___7 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t0 in + FStarC_Compiler_Util.format3 + "Warning, lazy unembedding failed, tag mismatch.\n\tExpected %s, got %s\n\tt = %s." + uu___5 uu___6 uu___7 in + FStarC_Errors.log_issue + (FStarC_Syntax_Syntax.has_range_syntax ()) t0 + FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4)); + FStar_Pervasives_Native.None) + | uu___1 -> FStar_Pervasives_Native.None in + let uu___ = term_as_fv ty in mk_emb ee uu uu___ +let lazy_embed : + 'a . + 'a printer -> + FStarC_Syntax_Syntax.emb_typ -> + FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.term -> + 'a -> + (unit -> FStarC_Syntax_Syntax.term) -> + FStarC_Syntax_Syntax.term + = + fun pa -> + fun et -> + fun rng -> + fun ta -> + fun x -> + fun f -> + (let uu___1 = + FStarC_Compiler_Effect.op_Bang + FStarC_Options.debug_embedding in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + ta in + let uu___3 = + FStarC_Class_Show.show + FStarC_Syntax_Syntax.showable_emb_typ et in + let uu___4 = pa x in + FStarC_Compiler_Util.print3 + "Embedding a %s\n\temb_typ=%s\n\tvalue is %s\n" uu___2 + uu___3 uu___4 + else ()); + (let uu___1 = + FStarC_Compiler_Effect.op_Bang + FStarC_Options.eager_embedding in + if uu___1 + then f () + else + (let thunk = FStarC_Thunk.mk f in + FStarC_Syntax_Util.mk_lazy x FStarC_Syntax_Syntax.tun + (FStarC_Syntax_Syntax.Lazy_embedding (et, thunk)) + (FStar_Pervasives_Native.Some rng))) +let lazy_unembed : + 'a . + 'a printer -> + FStarC_Syntax_Syntax.emb_typ -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term -> 'a FStar_Pervasives_Native.option) + -> 'a FStar_Pervasives_Native.option + = + fun pa -> + fun et -> + fun x -> + fun ta -> + fun f -> + let x1 = FStarC_Syntax_Subst.compress x in + match x1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_lazy + { FStarC_Syntax_Syntax.blob = b; + FStarC_Syntax_Syntax.lkind = + FStarC_Syntax_Syntax.Lazy_embedding (et', t); + FStarC_Syntax_Syntax.ltyp = uu___; + FStarC_Syntax_Syntax.rng = uu___1;_} + -> + let uu___2 = + (et <> et') || + (FStarC_Compiler_Effect.op_Bang + FStarC_Options.eager_embedding) in + if uu___2 + then + let res = let uu___3 = FStarC_Thunk.force t in f uu___3 in + ((let uu___4 = + FStarC_Compiler_Effect.op_Bang + FStarC_Options.debug_embedding in + if uu___4 + then + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Syntax.showable_emb_typ et in + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Syntax.showable_emb_typ et' in + let uu___7 = + match res with + | FStar_Pervasives_Native.None -> "None" + | FStar_Pervasives_Native.Some x2 -> + let uu___8 = pa x2 in Prims.strcat "Some " uu___8 in + FStarC_Compiler_Util.print3 + "Unembed cancellation failed\n\t%s <> %s\nvalue is %s\n" + uu___5 uu___6 uu___7 + else ()); + res) + else + (let a1 = FStarC_Dyn.undyn b in + (let uu___5 = + FStarC_Compiler_Effect.op_Bang + FStarC_Options.debug_embedding in + if uu___5 + then + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Syntax.showable_emb_typ et in + let uu___7 = pa a1 in + FStarC_Compiler_Util.print2 + "Unembed cancelled for %s\n\tvalue is %s\n" uu___6 + uu___7 + else ()); + FStar_Pervasives_Native.Some a1) + | uu___ -> + let aopt = f x1 in + ((let uu___2 = + FStarC_Compiler_Effect.op_Bang + FStarC_Options.debug_embedding in + if uu___2 + then + let uu___3 = + FStarC_Class_Show.show + FStarC_Syntax_Syntax.showable_emb_typ et in + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term x1 in + let uu___5 = + match aopt with + | FStar_Pervasives_Native.None -> "None" + | FStar_Pervasives_Native.Some a1 -> + let uu___6 = pa a1 in Prims.strcat "Some " uu___6 in + FStarC_Compiler_Util.print3 + "Unembedding:\n\temb_typ=%s\n\tterm is %s\n\tvalue is %s\n" + uu___3 uu___4 uu___5 + else ()); + aopt) +let op_let_Question : + 'uuuuu 'uuuuu1 . + 'uuuuu FStar_Pervasives_Native.option -> + ('uuuuu -> 'uuuuu1 FStar_Pervasives_Native.option) -> + 'uuuuu1 FStar_Pervasives_Native.option + = fun o -> fun f -> FStarC_Compiler_Util.bind_opt o f +let mk_extracted_embedding : + 'a . + Prims.string -> + ((Prims.string * FStarC_Syntax_Syntax.term Prims.list) -> + 'a FStar_Pervasives_Native.option) + -> ('a -> FStarC_Syntax_Syntax.term) -> 'a embedding + = + fun name -> + fun u -> + fun e -> + let uu t _norm = + let uu___ = FStarC_Syntax_Util.head_and_args t in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Util.un_uinst hd in + FStarC_Syntax_Subst.compress uu___4 in + uu___3.FStarC_Syntax_Syntax.n in + match uu___2 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + FStar_Pervasives_Native.Some + ((fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v) + | uu___3 -> FStar_Pervasives_Native.None in + op_let_Question uu___1 + (fun hd_lid -> + let uu___2 = + let uu___3 = FStarC_Ident.string_of_lid hd_lid in + let uu___4 = + FStarC_Compiler_List.map FStar_Pervasives_Native.fst + args in + (uu___3, uu___4) in + u uu___2) in + let ee x rng _topt _norm = e x in + let uu___ = + let uu___1 = FStarC_Ident.lid_of_str name in + FStarC_Syntax_Syntax.lid_as_fv uu___1 FStar_Pervasives_Native.None in + mk_emb ee uu uu___ +let extracted_embed : 'a . 'a embedding -> 'a -> FStarC_Syntax_Syntax.term = + fun e -> + fun x -> + let uu___ = embed e x in + uu___ FStarC_Compiler_Range_Type.dummyRange + FStar_Pervasives_Native.None id_norm_cb +let extracted_unembed : + 'a . + 'a embedding -> + FStarC_Syntax_Syntax.term -> 'a FStar_Pervasives_Native.option + = fun e -> fun t -> try_unembed e t id_norm_cb \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Syntax_Formula.ml b/ocaml/fstar-lib/generated/FStarC_Syntax_Formula.ml new file mode 100644 index 00000000000..0e4e6a4fc9e --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Syntax_Formula.ml @@ -0,0 +1,462 @@ +open Prims +type qpats = FStarC_Syntax_Syntax.args Prims.list +type connective = + | QAll of (FStarC_Syntax_Syntax.binders * qpats * FStarC_Syntax_Syntax.typ) + + | QEx of (FStarC_Syntax_Syntax.binders * qpats * FStarC_Syntax_Syntax.typ) + + | BaseConn of (FStarC_Ident.lident * FStarC_Syntax_Syntax.args) +let (uu___is_QAll : connective -> Prims.bool) = + fun projectee -> match projectee with | QAll _0 -> true | uu___ -> false +let (__proj__QAll__item___0 : + connective -> + (FStarC_Syntax_Syntax.binders * qpats * FStarC_Syntax_Syntax.typ)) + = fun projectee -> match projectee with | QAll _0 -> _0 +let (uu___is_QEx : connective -> Prims.bool) = + fun projectee -> match projectee with | QEx _0 -> true | uu___ -> false +let (__proj__QEx__item___0 : + connective -> + (FStarC_Syntax_Syntax.binders * qpats * FStarC_Syntax_Syntax.typ)) + = fun projectee -> match projectee with | QEx _0 -> _0 +let (uu___is_BaseConn : connective -> Prims.bool) = + fun projectee -> + match projectee with | BaseConn _0 -> true | uu___ -> false +let (__proj__BaseConn__item___0 : + connective -> (FStarC_Ident.lident * FStarC_Syntax_Syntax.args)) = + fun projectee -> match projectee with | BaseConn _0 -> _0 +let (connective_to_string : connective -> Prims.string) = + fun c -> + match c with + | QAll p -> + let uu___ = + FStarC_Class_Show.show + (FStarC_Class_Show.show_tuple3 + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binder) + (FStarC_Class_Show.show_list + (FStarC_Class_Show.show_list + (FStarC_Class_Show.show_tuple2 + FStarC_Syntax_Print.showable_term + FStarC_Syntax_Print.showable_aqual))) + FStarC_Syntax_Print.showable_term) p in + Prims.strcat "QAll " uu___ + | QEx p -> + let uu___ = + FStarC_Class_Show.show + (FStarC_Class_Show.show_tuple3 + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binder) + (FStarC_Class_Show.show_list + (FStarC_Class_Show.show_list + (FStarC_Class_Show.show_tuple2 + FStarC_Syntax_Print.showable_term + FStarC_Syntax_Print.showable_aqual))) + FStarC_Syntax_Print.showable_term) p in + Prims.strcat "QEx " uu___ + | BaseConn p -> + let uu___ = + FStarC_Class_Show.show + (FStarC_Class_Show.show_tuple2 FStarC_Ident.showable_lident + (FStarC_Class_Show.show_list + (FStarC_Class_Show.show_tuple2 + FStarC_Syntax_Print.showable_term + FStarC_Syntax_Print.showable_aqual))) p in + Prims.strcat "BaseConn" uu___ +let (showable_connective : connective FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = connective_to_string } +let (destruct_base_table : + (Prims.int * (FStarC_Ident.lident * FStarC_Ident.lident) Prims.list) + Prims.list) + = + let f x = (x, x) in + [(Prims.int_zero, + [f FStarC_Parser_Const.true_lid; f FStarC_Parser_Const.false_lid]); + (Prims.int_one, [f FStarC_Parser_Const.not_lid]); + ((Prims.of_int (2)), + [f FStarC_Parser_Const.and_lid; + f FStarC_Parser_Const.or_lid; + f FStarC_Parser_Const.imp_lid; + f FStarC_Parser_Const.iff_lid; + f FStarC_Parser_Const.eq2_lid]); + ((Prims.of_int (3)), + [f FStarC_Parser_Const.ite_lid; f FStarC_Parser_Const.eq2_lid])] +let (destruct_sq_base_table : + (Prims.int * (FStarC_Ident.lident * FStarC_Ident.lident) Prims.list) + Prims.list) + = + [(Prims.int_zero, + [(FStarC_Parser_Const.c_true_lid, FStarC_Parser_Const.true_lid); + (FStarC_Parser_Const.empty_type_lid, FStarC_Parser_Const.false_lid)]); + ((Prims.of_int (2)), + [(FStarC_Parser_Const.c_and_lid, FStarC_Parser_Const.and_lid); + (FStarC_Parser_Const.c_or_lid, FStarC_Parser_Const.or_lid); + (FStarC_Parser_Const.c_eq2_lid, FStarC_Parser_Const.eq2_lid)]); + ((Prims.of_int (3)), + [(FStarC_Parser_Const.c_eq2_lid, FStarC_Parser_Const.eq2_lid)])] +let rec (unmeta_monadic : + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) = + fun f -> + let f1 = FStarC_Syntax_Subst.compress f in + match f1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t; + FStarC_Syntax_Syntax.meta = FStarC_Syntax_Syntax.Meta_monadic uu___;_} + -> unmeta_monadic t + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t; + FStarC_Syntax_Syntax.meta = FStarC_Syntax_Syntax.Meta_monadic_lift + uu___;_} + -> unmeta_monadic t + | uu___ -> f1 +let (lookup_arity_lid : + (Prims.int * (FStarC_Ident.lident * FStarC_Ident.lident) Prims.list) + Prims.list -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.args -> connective FStar_Pervasives_Native.option) + = + fun table -> + fun target_lid -> + fun args -> + let arg_len = FStarC_Compiler_List.length args in + let aux uu___ = + match uu___ with + | (arity, lids) -> + if arg_len = arity + then + FStarC_Compiler_Util.find_map lids + (fun uu___1 -> + match uu___1 with + | (lid, out_lid) -> + let uu___2 = FStarC_Ident.lid_equals target_lid lid in + if uu___2 + then + FStar_Pervasives_Native.Some + (BaseConn (out_lid, args)) + else FStar_Pervasives_Native.None) + else FStar_Pervasives_Native.None in + FStarC_Compiler_Util.find_map table aux +let (destruct_base_conn : + FStarC_Syntax_Syntax.term -> connective FStar_Pervasives_Native.option) = + fun t -> + let uu___ = FStarC_Syntax_Util.head_and_args t in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = FStarC_Syntax_Util.un_uinst hd in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + lookup_arity_lid destruct_base_table + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v args + | uu___2 -> FStar_Pervasives_Native.None) +let (destruct_sq_base_conn : + FStarC_Syntax_Syntax.term -> connective FStar_Pervasives_Native.option) = + fun uu___ -> + (fun t -> + let uu___ = FStarC_Syntax_Util.un_squash t in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Class_Monad.monad_option () + () (Obj.magic uu___) + (fun uu___1 -> + (fun t1 -> + let t1 = Obj.magic t1 in + let t2 = FStarC_Syntax_Util.unmeta t1 in + let uu___1 = FStarC_Syntax_Util.head_and_args_full t2 in + match uu___1 with + | (hd, args) -> + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst hd in + uu___3.FStarC_Syntax_Syntax.n in + (match uu___2 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + Obj.magic + (lookup_arity_lid destruct_sq_base_table + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + args) + | uu___3 -> Obj.magic FStar_Pervasives_Native.None)) + uu___1))) uu___ +let (patterns : + FStarC_Syntax_Syntax.term -> + ((FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax * + FStarC_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) + Prims.list Prims.list * FStarC_Syntax_Syntax.term)) + = + fun t -> + let t1 = FStarC_Syntax_Subst.compress t in + match t1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t2; + FStarC_Syntax_Syntax.meta = FStarC_Syntax_Syntax.Meta_pattern + (uu___, pats);_} + -> let uu___1 = FStarC_Syntax_Subst.compress t2 in (pats, uu___1) + | uu___ -> ([], t1) +let (destruct_q_conn : + FStarC_Syntax_Syntax.term -> connective FStar_Pervasives_Native.option) = + fun t -> + let is_q fa fv = + if fa + then + FStarC_Syntax_Util.is_forall + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + else + FStarC_Syntax_Util.is_exists + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + let flat t1 = + let uu___ = FStarC_Syntax_Util.head_and_args t1 in + match uu___ with + | (t2, args) -> + let uu___1 = FStarC_Syntax_Util.un_uinst t2 in + let uu___2 = + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with + | (t3, imp) -> + let uu___4 = FStarC_Syntax_Util.unascribe t3 in + (uu___4, imp)) args in + (uu___1, uu___2) in + let rec aux qopt out t1 = + let uu___ = let uu___1 = flat t1 in (qopt, uu___1) in + match uu___ with + | (FStar_Pervasives_Native.Some fa, + ({ FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar tc; + FStarC_Syntax_Syntax.pos = uu___1; + FStarC_Syntax_Syntax.vars = uu___2; + FStarC_Syntax_Syntax.hash_code = uu___3;_}, + ({ + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = b::[]; + FStarC_Syntax_Syntax.body = t2; + FStarC_Syntax_Syntax.rc_opt = uu___4;_}; + FStarC_Syntax_Syntax.pos = uu___5; + FStarC_Syntax_Syntax.vars = uu___6; + FStarC_Syntax_Syntax.hash_code = uu___7;_}, + uu___8)::[])) + when is_q fa tc -> aux qopt (b :: out) t2 + | (FStar_Pervasives_Native.Some fa, + ({ FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar tc; + FStarC_Syntax_Syntax.pos = uu___1; + FStarC_Syntax_Syntax.vars = uu___2; + FStarC_Syntax_Syntax.hash_code = uu___3;_}, + uu___4::({ + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = b::[]; + FStarC_Syntax_Syntax.body = t2; + FStarC_Syntax_Syntax.rc_opt = uu___5;_}; + FStarC_Syntax_Syntax.pos = uu___6; + FStarC_Syntax_Syntax.vars = uu___7; + FStarC_Syntax_Syntax.hash_code = uu___8;_}, + uu___9)::[])) + when is_q fa tc -> aux qopt (b :: out) t2 + | (FStar_Pervasives_Native.None, + ({ FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar tc; + FStarC_Syntax_Syntax.pos = uu___1; + FStarC_Syntax_Syntax.vars = uu___2; + FStarC_Syntax_Syntax.hash_code = uu___3;_}, + ({ + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = b::[]; + FStarC_Syntax_Syntax.body = t2; + FStarC_Syntax_Syntax.rc_opt = uu___4;_}; + FStarC_Syntax_Syntax.pos = uu___5; + FStarC_Syntax_Syntax.vars = uu___6; + FStarC_Syntax_Syntax.hash_code = uu___7;_}, + uu___8)::[])) + when + FStarC_Syntax_Util.is_qlid + (tc.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + -> + let uu___9 = + let uu___10 = + FStarC_Syntax_Util.is_forall + (tc.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + FStar_Pervasives_Native.Some uu___10 in + aux uu___9 (b :: out) t2 + | (FStar_Pervasives_Native.None, + ({ FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar tc; + FStarC_Syntax_Syntax.pos = uu___1; + FStarC_Syntax_Syntax.vars = uu___2; + FStarC_Syntax_Syntax.hash_code = uu___3;_}, + uu___4::({ + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = b::[]; + FStarC_Syntax_Syntax.body = t2; + FStarC_Syntax_Syntax.rc_opt = uu___5;_}; + FStarC_Syntax_Syntax.pos = uu___6; + FStarC_Syntax_Syntax.vars = uu___7; + FStarC_Syntax_Syntax.hash_code = uu___8;_}, + uu___9)::[])) + when + FStarC_Syntax_Util.is_qlid + (tc.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + -> + let uu___10 = + let uu___11 = + FStarC_Syntax_Util.is_forall + (tc.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + FStar_Pervasives_Native.Some uu___11 in + aux uu___10 (b :: out) t2 + | (FStar_Pervasives_Native.Some b, uu___1) -> + let bs = FStarC_Compiler_List.rev out in + let uu___2 = FStarC_Syntax_Subst.open_term bs t1 in + (match uu___2 with + | (bs1, t2) -> + let uu___3 = patterns t2 in + (match uu___3 with + | (pats, body) -> + if b + then + FStar_Pervasives_Native.Some (QAll (bs1, pats, body)) + else FStar_Pervasives_Native.Some (QEx (bs1, pats, body)))) + | uu___1 -> FStar_Pervasives_Native.None in + aux FStar_Pervasives_Native.None [] t +let rec (destruct_sq_forall : + FStarC_Syntax_Syntax.term -> connective FStar_Pervasives_Native.option) = + fun uu___ -> + (fun t -> + let uu___ = FStarC_Syntax_Util.un_squash t in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Class_Monad.monad_option () + () (Obj.magic uu___) + (fun uu___1 -> + (fun t1 -> + let t1 = Obj.magic t1 in + let t2 = FStarC_Syntax_Util.unmeta t1 in + let uu___1 = FStarC_Syntax_Util.arrow_one t2 in + match uu___1 with + | FStar_Pervasives_Native.Some (b, c) -> + let uu___2 = + let uu___3 = FStarC_Syntax_Util.is_tot_or_gtot_comp c in + Prims.op_Negation uu___3 in + if uu___2 + then Obj.magic FStar_Pervasives_Native.None + else + (let q = FStarC_Syntax_Util.comp_result c in + let uu___4 = + FStarC_Syntax_Util.is_free_in + b.FStarC_Syntax_Syntax.binder_bv q in + if uu___4 + then + let uu___5 = patterns q in + match uu___5 with + | (pats, q1) -> + Obj.magic + (maybe_collect + (FStar_Pervasives_Native.Some + (QAll ([b], pats, q1)))) + else + (let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Syntax_Syntax.as_arg + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + let uu___10 = + let uu___11 = + FStarC_Syntax_Syntax.as_arg q in + [uu___11] in + uu___9 :: uu___10 in + (FStarC_Parser_Const.imp_lid, uu___8) in + BaseConn uu___7 in + Obj.magic (FStar_Pervasives_Native.Some uu___6))) + | uu___2 -> Obj.magic FStar_Pervasives_Native.None) uu___1))) + uu___ +and (destruct_sq_exists : + FStarC_Syntax_Syntax.term -> connective FStar_Pervasives_Native.option) = + fun uu___ -> + (fun t -> + let uu___ = FStarC_Syntax_Util.un_squash t in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Class_Monad.monad_option () + () (Obj.magic uu___) + (fun uu___1 -> + (fun t1 -> + let t1 = Obj.magic t1 in + let t2 = FStarC_Syntax_Util.unmeta t1 in + let uu___1 = FStarC_Syntax_Util.head_and_args_full t2 in + match uu___1 with + | (hd, args) -> + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Util.un_uinst hd in + uu___4.FStarC_Syntax_Syntax.n in + (uu___3, args) in + (match uu___2 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (a1, uu___3)::(a2, uu___4)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.dtuple2_lid + -> + let uu___5 = + let uu___6 = FStarC_Syntax_Subst.compress a2 in + uu___6.FStarC_Syntax_Syntax.n in + (match uu___5 with + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = b::[]; + FStarC_Syntax_Syntax.body = q; + FStarC_Syntax_Syntax.rc_opt = uu___6;_} + -> + let uu___7 = + FStarC_Syntax_Subst.open_term [b] q in + (match uu___7 with + | (bs, q1) -> + let b1 = + match bs with + | b2::[] -> b2 + | uu___8 -> failwith "impossible" in + let uu___8 = patterns q1 in + (match uu___8 with + | (pats, q2) -> + Obj.magic + (maybe_collect + (FStar_Pervasives_Native.Some + (QEx ([b1], pats, q2)))))) + | uu___6 -> + Obj.magic FStar_Pervasives_Native.None) + | uu___3 -> Obj.magic FStar_Pervasives_Native.None)) + uu___1))) uu___ +and (maybe_collect : + connective FStar_Pervasives_Native.option -> + connective FStar_Pervasives_Native.option) + = + fun f -> + match f with + | FStar_Pervasives_Native.Some (QAll (bs, pats, phi)) -> + let uu___ = destruct_sq_forall phi in + (match uu___ with + | FStar_Pervasives_Native.Some (QAll (bs', pats', psi)) -> + FStar_Pervasives_Native.Some + (QAll + ((FStarC_Compiler_List.op_At bs bs'), + (FStarC_Compiler_List.op_At pats pats'), psi)) + | uu___1 -> f) + | FStar_Pervasives_Native.Some (QEx (bs, pats, phi)) -> + let uu___ = destruct_sq_exists phi in + (match uu___ with + | FStar_Pervasives_Native.Some (QEx (bs', pats', psi)) -> + FStar_Pervasives_Native.Some + (QEx + ((FStarC_Compiler_List.op_At bs bs'), + (FStarC_Compiler_List.op_At pats pats'), psi)) + | uu___1 -> f) + | uu___ -> f +let (destruct_typ_as_formula : + FStarC_Syntax_Syntax.term -> connective FStar_Pervasives_Native.option) = + fun f -> + let phi = unmeta_monadic f in + let r = + let uu___ = destruct_base_conn phi in + FStarC_Compiler_Util.catch_opt uu___ + (fun uu___1 -> + let uu___2 = destruct_q_conn phi in + FStarC_Compiler_Util.catch_opt uu___2 + (fun uu___3 -> + let uu___4 = destruct_sq_base_conn phi in + FStarC_Compiler_Util.catch_opt uu___4 + (fun uu___5 -> + let uu___6 = destruct_sq_forall phi in + FStarC_Compiler_Util.catch_opt uu___6 + (fun uu___7 -> + let uu___8 = destruct_sq_exists phi in + FStarC_Compiler_Util.catch_opt uu___8 + (fun uu___9 -> FStar_Pervasives_Native.None))))) in + r \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Syntax_Free.ml b/ocaml/fstar-lib/generated/FStarC_Syntax_Free.ml new file mode 100644 index 00000000000..8ca857b0c0e --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Syntax_Free.ml @@ -0,0 +1,768 @@ +open Prims +let (compare_uv : + FStarC_Syntax_Syntax.ctx_uvar -> FStarC_Syntax_Syntax.ctx_uvar -> Prims.int) + = + fun uv1 -> + fun uv2 -> + let uu___ = + FStarC_Syntax_Unionfind.uvar_id + uv1.FStarC_Syntax_Syntax.ctx_uvar_head in + let uu___1 = + FStarC_Syntax_Unionfind.uvar_id + uv2.FStarC_Syntax_Syntax.ctx_uvar_head in + uu___ - uu___1 +let (compare_universe_uvar : + FStarC_Syntax_Syntax.universe_uvar -> + FStarC_Syntax_Syntax.universe_uvar -> Prims.int) + = + fun x -> + fun y -> + let uu___ = FStarC_Syntax_Unionfind.univ_uvar_id x in + let uu___1 = FStarC_Syntax_Unionfind.univ_uvar_id y in uu___ - uu___1 +let (deq_ctx_uvar : FStarC_Syntax_Syntax.ctx_uvar FStarC_Class_Deq.deq) = + { + FStarC_Class_Deq.op_Equals_Question = + (fun u -> + fun v -> + let uu___ = + FStarC_Syntax_Unionfind.uvar_id + u.FStarC_Syntax_Syntax.ctx_uvar_head in + let uu___1 = + FStarC_Syntax_Unionfind.uvar_id + v.FStarC_Syntax_Syntax.ctx_uvar_head in + FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq FStarC_Class_Ord.ord_int) uu___ uu___1) + } +let (ord_ctx_uvar : FStarC_Syntax_Syntax.ctx_uvar FStarC_Class_Ord.ord) = + { + FStarC_Class_Ord.super = deq_ctx_uvar; + FStarC_Class_Ord.cmp = + (fun u -> + fun v -> + let uu___ = + FStarC_Syntax_Unionfind.uvar_id + u.FStarC_Syntax_Syntax.ctx_uvar_head in + let uu___1 = + FStarC_Syntax_Unionfind.uvar_id + v.FStarC_Syntax_Syntax.ctx_uvar_head in + FStarC_Class_Ord.cmp FStarC_Class_Ord.ord_int uu___ uu___1) + } +let (deq_univ_uvar : FStarC_Syntax_Syntax.universe_uvar FStarC_Class_Deq.deq) + = + { + FStarC_Class_Deq.op_Equals_Question = + (fun u -> + fun v -> + let uu___ = FStarC_Syntax_Unionfind.univ_uvar_id u in + let uu___1 = FStarC_Syntax_Unionfind.univ_uvar_id v in + FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq FStarC_Class_Ord.ord_int) uu___ uu___1) + } +let (ord_univ_uvar : FStarC_Syntax_Syntax.universe_uvar FStarC_Class_Ord.ord) + = + { + FStarC_Class_Ord.super = deq_univ_uvar; + FStarC_Class_Ord.cmp = + (fun u -> + fun v -> + let uu___ = FStarC_Syntax_Unionfind.univ_uvar_id u in + let uu___1 = FStarC_Syntax_Unionfind.univ_uvar_id v in + FStarC_Class_Ord.cmp FStarC_Class_Ord.ord_int uu___ uu___1) + } +let (ctx_uvar_typ : + FStarC_Syntax_Syntax.ctx_uvar -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun u -> + let uu___ = + FStarC_Syntax_Unionfind.find_decoration + u.FStarC_Syntax_Syntax.ctx_uvar_head in + uu___.FStarC_Syntax_Syntax.uvar_decoration_typ +type use_cache_t = + | Def + | NoCache + | Full +let (uu___is_Def : use_cache_t -> Prims.bool) = + fun projectee -> match projectee with | Def -> true | uu___ -> false +let (uu___is_NoCache : use_cache_t -> Prims.bool) = + fun projectee -> match projectee with | NoCache -> true | uu___ -> false +let (uu___is_Full : use_cache_t -> Prims.bool) = + fun projectee -> match projectee with | Full -> true | uu___ -> false +type free_vars_and_fvars = + (FStarC_Syntax_Syntax.free_vars * FStarC_Ident.lident + FStarC_Compiler_RBSet.t) +let rec snoc : + 'a . 'a FStarC_Class_Deq.deq -> 'a Prims.list -> 'a -> 'a Prims.list = + fun uu___ -> + fun xx -> + fun y -> + match xx with + | [] -> [y] + | x::xx' -> + let uu___1 = FStarC_Class_Deq.op_Equals_Question uu___ x y in + if uu___1 + then xx + else (let uu___3 = snoc uu___ xx' y in x :: uu___3) +let op_At_At : + 'a . + 'a FStarC_Class_Deq.deq -> + 'a Prims.list -> 'a Prims.list -> 'a Prims.list + = + fun uu___ -> + fun xs -> + fun ys -> + FStarC_Compiler_List.fold_left (fun xs1 -> fun y -> snoc uu___ xs1 y) + xs ys +let (no_free_vars : free_vars_and_fvars) = + let uu___ = + let uu___1 = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) ()) in + let uu___2 = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic (FStarC_Compiler_FlatSet.setlike_flat_set ord_ctx_uvar)) + ()) in + let uu___3 = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set ord_univ_uvar)) ()) in + let uu___4 = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_ident)) ()) in + { + FStarC_Syntax_Syntax.free_names = uu___1; + FStarC_Syntax_Syntax.free_uvars = uu___2; + FStarC_Syntax_Syntax.free_univs = uu___3; + FStarC_Syntax_Syntax.free_univ_names = uu___4 + } in + let uu___1 = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset FStarC_Syntax_Syntax.ord_fv)) + ()) in + (uu___, uu___1) +let (singleton_fvar : FStarC_Syntax_Syntax.fv -> free_vars_and_fvars) = + fun fv -> + let uu___ = + let uu___1 = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Syntax.ord_fv)) ()) in + Obj.magic + (FStarC_Class_Setlike.add () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Syntax.ord_fv)) + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + (Obj.magic uu___1)) in + ((FStar_Pervasives_Native.fst no_free_vars), uu___) +let (singleton_bv : + FStarC_Syntax_Syntax.bv -> + (FStarC_Syntax_Syntax.free_vars * FStarC_Ident.lident + FStarC_Compiler_RBSet.t)) + = + fun x -> + let uu___ = + let uu___1 = FStar_Pervasives_Native.fst no_free_vars in + let uu___2 = + Obj.magic + (FStarC_Class_Setlike.singleton () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) x) in + { + FStarC_Syntax_Syntax.free_names = uu___2; + FStarC_Syntax_Syntax.free_uvars = + (uu___1.FStarC_Syntax_Syntax.free_uvars); + FStarC_Syntax_Syntax.free_univs = + (uu___1.FStarC_Syntax_Syntax.free_univs); + FStarC_Syntax_Syntax.free_univ_names = + (uu___1.FStarC_Syntax_Syntax.free_univ_names) + } in + (uu___, (FStar_Pervasives_Native.snd no_free_vars)) +let (singleton_uv : + FStarC_Syntax_Syntax.ctx_uvar -> + (FStarC_Syntax_Syntax.free_vars * FStarC_Ident.lident + FStarC_Compiler_RBSet.t)) + = + fun x -> + let uu___ = + let uu___1 = FStar_Pervasives_Native.fst no_free_vars in + let uu___2 = + Obj.magic + (FStarC_Class_Setlike.singleton () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set ord_ctx_uvar)) x) in + { + FStarC_Syntax_Syntax.free_names = + (uu___1.FStarC_Syntax_Syntax.free_names); + FStarC_Syntax_Syntax.free_uvars = uu___2; + FStarC_Syntax_Syntax.free_univs = + (uu___1.FStarC_Syntax_Syntax.free_univs); + FStarC_Syntax_Syntax.free_univ_names = + (uu___1.FStarC_Syntax_Syntax.free_univ_names) + } in + (uu___, (FStar_Pervasives_Native.snd no_free_vars)) +let (singleton_univ : + FStarC_Syntax_Syntax.universe_uvar -> + (FStarC_Syntax_Syntax.free_vars * FStarC_Ident.lident + FStarC_Compiler_RBSet.t)) + = + fun x -> + let uu___ = + let uu___1 = FStar_Pervasives_Native.fst no_free_vars in + let uu___2 = + Obj.magic + (FStarC_Class_Setlike.singleton () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set ord_univ_uvar)) x) in + { + FStarC_Syntax_Syntax.free_names = + (uu___1.FStarC_Syntax_Syntax.free_names); + FStarC_Syntax_Syntax.free_uvars = + (uu___1.FStarC_Syntax_Syntax.free_uvars); + FStarC_Syntax_Syntax.free_univs = uu___2; + FStarC_Syntax_Syntax.free_univ_names = + (uu___1.FStarC_Syntax_Syntax.free_univ_names) + } in + (uu___, (FStar_Pervasives_Native.snd no_free_vars)) +let (singleton_univ_name : + FStarC_Syntax_Syntax.univ_name -> + (FStarC_Syntax_Syntax.free_vars * FStarC_Ident.lident + FStarC_Compiler_RBSet.t)) + = + fun x -> + let uu___ = + let uu___1 = FStar_Pervasives_Native.fst no_free_vars in + let uu___2 = + Obj.magic + (FStarC_Class_Setlike.singleton () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_ident)) x) in + { + FStarC_Syntax_Syntax.free_names = + (uu___1.FStarC_Syntax_Syntax.free_names); + FStarC_Syntax_Syntax.free_uvars = + (uu___1.FStarC_Syntax_Syntax.free_uvars); + FStarC_Syntax_Syntax.free_univs = + (uu___1.FStarC_Syntax_Syntax.free_univs); + FStarC_Syntax_Syntax.free_univ_names = uu___2 + } in + (uu___, (FStar_Pervasives_Native.snd no_free_vars)) +let (op_Plus_Plus : + free_vars_and_fvars -> + free_vars_and_fvars -> + (FStarC_Syntax_Syntax.free_vars * FStarC_Ident.lident + FStarC_Compiler_RBSet.t)) + = + fun f1 -> + fun f2 -> + let uu___ = + let uu___1 = + Obj.magic + (FStarC_Class_Setlike.union () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) + (Obj.magic + (FStar_Pervasives_Native.fst f1).FStarC_Syntax_Syntax.free_names) + (Obj.magic + (FStar_Pervasives_Native.fst f2).FStarC_Syntax_Syntax.free_names)) in + let uu___2 = + Obj.magic + (FStarC_Class_Setlike.union () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set ord_ctx_uvar)) + (Obj.magic + (FStar_Pervasives_Native.fst f1).FStarC_Syntax_Syntax.free_uvars) + (Obj.magic + (FStar_Pervasives_Native.fst f2).FStarC_Syntax_Syntax.free_uvars)) in + let uu___3 = + Obj.magic + (FStarC_Class_Setlike.union () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set ord_univ_uvar)) + (Obj.magic + (FStar_Pervasives_Native.fst f1).FStarC_Syntax_Syntax.free_univs) + (Obj.magic + (FStar_Pervasives_Native.fst f2).FStarC_Syntax_Syntax.free_univs)) in + let uu___4 = + Obj.magic + (FStarC_Class_Setlike.union () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_ident)) + (Obj.magic + (FStar_Pervasives_Native.fst f1).FStarC_Syntax_Syntax.free_univ_names) + (Obj.magic + (FStar_Pervasives_Native.fst f2).FStarC_Syntax_Syntax.free_univ_names)) in + { + FStarC_Syntax_Syntax.free_names = uu___1; + FStarC_Syntax_Syntax.free_uvars = uu___2; + FStarC_Syntax_Syntax.free_univs = uu___3; + FStarC_Syntax_Syntax.free_univ_names = uu___4 + } in + let uu___1 = + Obj.magic + (FStarC_Class_Setlike.union () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Syntax.ord_fv)) + (Obj.magic (FStar_Pervasives_Native.snd f1)) + (Obj.magic (FStar_Pervasives_Native.snd f2))) in + (uu___, uu___1) +let rec (free_univs : FStarC_Syntax_Syntax.universe -> free_vars_and_fvars) = + fun u -> + let uu___ = FStarC_Syntax_Subst.compress_univ u in + match uu___ with + | FStarC_Syntax_Syntax.U_zero -> no_free_vars + | FStarC_Syntax_Syntax.U_bvar uu___1 -> no_free_vars + | FStarC_Syntax_Syntax.U_unknown -> no_free_vars + | FStarC_Syntax_Syntax.U_name uname -> singleton_univ_name uname + | FStarC_Syntax_Syntax.U_succ u1 -> free_univs u1 + | FStarC_Syntax_Syntax.U_max us -> + FStarC_Compiler_List.fold_left + (fun out -> + fun x -> let uu___1 = free_univs x in op_Plus_Plus out uu___1) + no_free_vars us + | FStarC_Syntax_Syntax.U_unif u1 -> singleton_univ u1 +let rec (free_names_and_uvs' : + FStarC_Syntax_Syntax.term -> use_cache_t -> free_vars_and_fvars) = + fun tm -> + fun use_cache -> + let aux_binders bs from_body = + let from_binders = free_names_and_uvars_binders bs use_cache in + op_Plus_Plus from_binders from_body in + let t = FStarC_Syntax_Subst.compress tm in + match t.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_delayed uu___ -> failwith "Impossible" + | FStarC_Syntax_Syntax.Tm_name x -> singleton_bv x + | FStarC_Syntax_Syntax.Tm_uvar (uv, (s, uu___)) -> + let uu___1 = singleton_uv uv in + let uu___2 = + if use_cache = Full + then + let uu___3 = ctx_uvar_typ uv in + free_names_and_uvars uu___3 use_cache + else no_free_vars in + op_Plus_Plus uu___1 uu___2 + | FStarC_Syntax_Syntax.Tm_type u -> free_univs u + | FStarC_Syntax_Syntax.Tm_bvar uu___ -> no_free_vars + | FStarC_Syntax_Syntax.Tm_fvar fv -> singleton_fvar fv + | FStarC_Syntax_Syntax.Tm_constant uu___ -> no_free_vars + | FStarC_Syntax_Syntax.Tm_lazy uu___ -> no_free_vars + | FStarC_Syntax_Syntax.Tm_unknown -> no_free_vars + | FStarC_Syntax_Syntax.Tm_uinst (t1, us) -> + let f = free_names_and_uvars t1 use_cache in + FStarC_Compiler_List.fold_left + (fun out -> + fun u -> let uu___ = free_univs u in op_Plus_Plus out uu___) f + us + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs; FStarC_Syntax_Syntax.body = t1; + FStarC_Syntax_Syntax.rc_opt = ropt;_} + -> + let uu___ = + let uu___1 = free_names_and_uvars t1 use_cache in + aux_binders bs uu___1 in + let uu___1 = + match ropt with + | FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.residual_effect = uu___2; + FStarC_Syntax_Syntax.residual_typ = + FStar_Pervasives_Native.Some t2; + FStarC_Syntax_Syntax.residual_flags = uu___3;_} + -> free_names_and_uvars t2 use_cache + | uu___2 -> no_free_vars in + op_Plus_Plus uu___ uu___1 + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; FStarC_Syntax_Syntax.comp = c;_} + -> + let uu___ = free_names_and_uvars_comp c use_cache in + aux_binders bs uu___ + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = bv; FStarC_Syntax_Syntax.phi = t1;_} -> + let uu___ = + let uu___1 = FStarC_Syntax_Syntax.mk_binder bv in [uu___1] in + let uu___1 = free_names_and_uvars t1 use_cache in + aux_binders uu___ uu___1 + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = t1; FStarC_Syntax_Syntax.args = args;_} + -> + let uu___ = free_names_and_uvars t1 use_cache in + free_names_and_uvars_args args uu___ use_cache + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = t1; + FStarC_Syntax_Syntax.ret_opt = asc_opt; + FStarC_Syntax_Syntax.brs = pats; + FStarC_Syntax_Syntax.rc_opt1 = rc_opt;_} + -> + let uu___ = + match rc_opt with + | FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.residual_effect = uu___1; + FStarC_Syntax_Syntax.residual_typ = + FStar_Pervasives_Native.Some t2; + FStarC_Syntax_Syntax.residual_flags = uu___2;_} + -> free_names_and_uvars t2 use_cache + | uu___1 -> no_free_vars in + let uu___1 = + let uu___2 = + let uu___3 = free_names_and_uvars t1 use_cache in + let uu___4 = + match asc_opt with + | FStar_Pervasives_Native.None -> no_free_vars + | FStar_Pervasives_Native.Some (b, asc) -> + let uu___5 = free_names_and_uvars_binders [b] use_cache in + let uu___6 = + free_names_and_uvars_ascription asc use_cache in + op_Plus_Plus uu___5 uu___6 in + op_Plus_Plus uu___3 uu___4 in + FStarC_Compiler_List.fold_left + (fun n -> + fun uu___3 -> + match uu___3 with + | (p, wopt, t2) -> + let n1 = + match wopt with + | FStar_Pervasives_Native.None -> no_free_vars + | FStar_Pervasives_Native.Some w -> + free_names_and_uvars w use_cache in + let n2 = free_names_and_uvars t2 use_cache in + let n3 = + let uu___4 = FStarC_Syntax_Syntax.pat_bvs p in + FStarC_Compiler_List.fold_left + (fun n4 -> + fun x -> + let uu___5 = + free_names_and_uvars + x.FStarC_Syntax_Syntax.sort use_cache in + op_Plus_Plus n4 uu___5) n uu___4 in + let uu___4 = op_Plus_Plus n3 n1 in + op_Plus_Plus uu___4 n2) uu___2 pats in + op_Plus_Plus uu___ uu___1 + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t1; FStarC_Syntax_Syntax.asc = asc; + FStarC_Syntax_Syntax.eff_opt = uu___;_} + -> + let uu___1 = free_names_and_uvars t1 use_cache in + let uu___2 = free_names_and_uvars_ascription asc use_cache in + op_Plus_Plus uu___1 uu___2 + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = lbs; + FStarC_Syntax_Syntax.body1 = t1;_} + -> + let uu___ = free_names_and_uvars t1 use_cache in + FStarC_Compiler_List.fold_left + (fun n -> + fun lb -> + let uu___1 = + let uu___2 = + free_names_and_uvars lb.FStarC_Syntax_Syntax.lbtyp + use_cache in + op_Plus_Plus n uu___2 in + let uu___2 = + free_names_and_uvars lb.FStarC_Syntax_Syntax.lbdef + use_cache in + op_Plus_Plus uu___1 uu___2) uu___ + (FStar_Pervasives_Native.snd lbs) + | FStarC_Syntax_Syntax.Tm_quoted (tm1, qi) -> + (match qi.FStarC_Syntax_Syntax.qkind with + | FStarC_Syntax_Syntax.Quote_static -> + FStarC_Compiler_List.fold_left + (fun n -> + fun t1 -> + let uu___ = free_names_and_uvars t1 use_cache in + op_Plus_Plus n uu___) no_free_vars + (FStar_Pervasives_Native.snd + qi.FStarC_Syntax_Syntax.antiquotations) + | FStarC_Syntax_Syntax.Quote_dynamic -> + free_names_and_uvars tm1 use_cache) + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t1; FStarC_Syntax_Syntax.meta = m;_} + -> + let u1 = free_names_and_uvars t1 use_cache in + (match m with + | FStarC_Syntax_Syntax.Meta_pattern (uu___, args) -> + FStarC_Compiler_List.fold_right + (fun a -> + fun acc -> free_names_and_uvars_args a acc use_cache) + args u1 + | FStarC_Syntax_Syntax.Meta_monadic (uu___, t') -> + let uu___1 = free_names_and_uvars t' use_cache in + op_Plus_Plus u1 uu___1 + | FStarC_Syntax_Syntax.Meta_monadic_lift (uu___, uu___1, t') -> + let uu___2 = free_names_and_uvars t' use_cache in + op_Plus_Plus u1 uu___2 + | FStarC_Syntax_Syntax.Meta_labeled uu___ -> u1 + | FStarC_Syntax_Syntax.Meta_desugared uu___ -> u1 + | FStarC_Syntax_Syntax.Meta_named uu___ -> u1) +and (free_names_and_uvars_binders : + FStarC_Syntax_Syntax.binders -> use_cache_t -> free_vars_and_fvars) = + fun bs -> + fun use_cache -> + FStarC_Compiler_List.fold_left + (fun n -> + fun b -> + let uu___ = + free_names_and_uvars + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort + use_cache in + op_Plus_Plus n uu___) no_free_vars bs +and (free_names_and_uvars_ascription : + ((FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax, + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax) + FStar_Pervasives.either * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax FStar_Pervasives_Native.option * Prims.bool) + -> use_cache_t -> free_vars_and_fvars) + = + fun asc -> + fun use_cache -> + let uu___ = asc in + match uu___ with + | (asc1, tacopt, uu___1) -> + let uu___2 = + match asc1 with + | FStar_Pervasives.Inl t -> free_names_and_uvars t use_cache + | FStar_Pervasives.Inr c -> free_names_and_uvars_comp c use_cache in + let uu___3 = + match tacopt with + | FStar_Pervasives_Native.None -> no_free_vars + | FStar_Pervasives_Native.Some tac -> + free_names_and_uvars tac use_cache in + op_Plus_Plus uu___2 uu___3 +and (free_names_and_uvars : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + use_cache_t -> free_vars_and_fvars) + = + fun t -> + fun use_cache -> + let t1 = FStarC_Syntax_Subst.compress t in + let uu___ = FStarC_Compiler_Effect.op_Bang t1.FStarC_Syntax_Syntax.vars in + match uu___ with + | FStar_Pervasives_Native.Some n when + let uu___1 = should_invalidate_cache n use_cache in + Prims.op_Negation uu___1 -> + let uu___1 = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Syntax.ord_fv)) ()) in + (n, uu___1) + | uu___1 -> + (FStarC_Compiler_Effect.op_Colon_Equals + t1.FStarC_Syntax_Syntax.vars FStar_Pervasives_Native.None; + (let n = free_names_and_uvs' t1 use_cache in + if use_cache <> Full + then + FStarC_Compiler_Effect.op_Colon_Equals + t1.FStarC_Syntax_Syntax.vars + (FStar_Pervasives_Native.Some (FStar_Pervasives_Native.fst n)) + else (); + n)) +and (free_names_and_uvars_args : + (FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax * + FStarC_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) + Prims.list -> free_vars_and_fvars -> use_cache_t -> free_vars_and_fvars) + = + fun args -> + fun acc -> + fun use_cache -> + FStarC_Compiler_List.fold_left + (fun n -> + fun uu___ -> + match uu___ with + | (x, uu___1) -> + let uu___2 = free_names_and_uvars x use_cache in + op_Plus_Plus n uu___2) acc args +and (free_names_and_uvars_comp : + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> + use_cache_t -> free_vars_and_fvars) + = + fun c -> + fun use_cache -> + let uu___ = FStarC_Compiler_Effect.op_Bang c.FStarC_Syntax_Syntax.vars in + match uu___ with + | FStar_Pervasives_Native.Some n -> + let uu___1 = should_invalidate_cache n use_cache in + if uu___1 + then + (FStarC_Compiler_Effect.op_Colon_Equals + c.FStarC_Syntax_Syntax.vars FStar_Pervasives_Native.None; + free_names_and_uvars_comp c use_cache) + else + (let uu___3 = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Syntax.ord_fv)) ()) in + (n, uu___3)) + | uu___1 -> + let n = + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.GTotal t -> + free_names_and_uvars t use_cache + | FStarC_Syntax_Syntax.Total t -> + free_names_and_uvars t use_cache + | FStarC_Syntax_Syntax.Comp ct -> + let decreases_vars = + let uu___2 = + FStarC_Compiler_List.tryFind + (fun uu___3 -> + match uu___3 with + | FStarC_Syntax_Syntax.DECREASES uu___4 -> true + | uu___4 -> false) ct.FStarC_Syntax_Syntax.flags in + match uu___2 with + | FStar_Pervasives_Native.None -> no_free_vars + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.DECREASES dec_order) -> + free_names_and_uvars_dec_order dec_order use_cache in + let us = + let uu___2 = + free_names_and_uvars ct.FStarC_Syntax_Syntax.result_typ + use_cache in + op_Plus_Plus uu___2 decreases_vars in + let us1 = + free_names_and_uvars_args + ct.FStarC_Syntax_Syntax.effect_args us use_cache in + FStarC_Compiler_List.fold_left + (fun us2 -> + fun u -> + let uu___2 = free_univs u in op_Plus_Plus us2 uu___2) + us1 ct.FStarC_Syntax_Syntax.comp_univs in + (FStarC_Compiler_Effect.op_Colon_Equals c.FStarC_Syntax_Syntax.vars + (FStar_Pervasives_Native.Some (FStar_Pervasives_Native.fst n)); + n) +and (free_names_and_uvars_dec_order : + FStarC_Syntax_Syntax.decreases_order -> use_cache_t -> free_vars_and_fvars) + = + fun dec_order -> + fun use_cache -> + match dec_order with + | FStarC_Syntax_Syntax.Decreases_lex l -> + FStarC_Compiler_List.fold_left + (fun acc -> + fun t -> + let uu___ = free_names_and_uvars t use_cache in + op_Plus_Plus acc uu___) no_free_vars l + | FStarC_Syntax_Syntax.Decreases_wf (rel, e) -> + let uu___ = free_names_and_uvars rel use_cache in + let uu___1 = free_names_and_uvars e use_cache in + op_Plus_Plus uu___ uu___1 +and (should_invalidate_cache : + FStarC_Syntax_Syntax.free_vars -> use_cache_t -> Prims.bool) = + fun n -> + fun use_cache -> + ((use_cache <> Def) || + (FStarC_Class_Setlike.for_any () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set ord_ctx_uvar)) + (fun u -> + let uu___ = + FStarC_Syntax_Unionfind.find + u.FStarC_Syntax_Syntax.ctx_uvar_head in + match uu___ with + | FStar_Pervasives_Native.Some uu___1 -> true + | uu___1 -> false) + (Obj.magic n.FStarC_Syntax_Syntax.free_uvars))) + || + (FStarC_Class_Setlike.for_any () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set ord_univ_uvar)) + (fun u -> + let uu___ = FStarC_Syntax_Unionfind.univ_find u in + match uu___ with + | FStar_Pervasives_Native.Some uu___1 -> true + | FStar_Pervasives_Native.None -> false) + (Obj.magic n.FStarC_Syntax_Syntax.free_univs)) +let (names : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.bv FStarC_Compiler_FlatSet.t) + = + fun t -> + let uu___ = + let uu___1 = free_names_and_uvars t Def in + FStar_Pervasives_Native.fst uu___1 in + uu___.FStarC_Syntax_Syntax.free_names +let (uvars : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.ctx_uvar FStarC_Compiler_FlatSet.t) + = + fun t -> + let uu___ = + let uu___1 = free_names_and_uvars t Def in + FStar_Pervasives_Native.fst uu___1 in + uu___.FStarC_Syntax_Syntax.free_uvars +let (univs : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.universe_uvar FStarC_Compiler_FlatSet.t) + = + fun t -> + let uu___ = + let uu___1 = free_names_and_uvars t Def in + FStar_Pervasives_Native.fst uu___1 in + uu___.FStarC_Syntax_Syntax.free_univs +let (univnames : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.univ_name FStarC_Compiler_FlatSet.t) + = + fun t -> + let uu___ = + let uu___1 = free_names_and_uvars t Def in + FStar_Pervasives_Native.fst uu___1 in + uu___.FStarC_Syntax_Syntax.free_univ_names +let (univnames_comp : + FStarC_Syntax_Syntax.comp -> + FStarC_Syntax_Syntax.univ_name FStarC_Compiler_FlatSet.t) + = + fun c -> + let uu___ = + let uu___1 = free_names_and_uvars_comp c Def in + FStar_Pervasives_Native.fst uu___1 in + uu___.FStarC_Syntax_Syntax.free_univ_names +let (fvars : + FStarC_Syntax_Syntax.term -> FStarC_Ident.lident FStarC_Compiler_RBSet.t) = + fun t -> + let uu___ = free_names_and_uvars t NoCache in + FStar_Pervasives_Native.snd uu___ +let (names_of_binders : + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.bv FStarC_Compiler_FlatSet.t) + = + fun bs -> + let uu___ = + let uu___1 = free_names_and_uvars_binders bs Def in + FStar_Pervasives_Native.fst uu___1 in + uu___.FStarC_Syntax_Syntax.free_names +let (uvars_uncached : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.ctx_uvar FStarC_Compiler_FlatSet.t) + = + fun t -> + let uu___ = + let uu___1 = free_names_and_uvars t NoCache in + FStar_Pervasives_Native.fst uu___1 in + uu___.FStarC_Syntax_Syntax.free_uvars +let (uvars_full : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.ctx_uvar FStarC_Compiler_FlatSet.t) + = + fun t -> + let uu___ = + let uu___1 = free_names_and_uvars t Full in + FStar_Pervasives_Native.fst uu___1 in + uu___.FStarC_Syntax_Syntax.free_uvars \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Syntax_Hash.ml b/ocaml/fstar-lib/generated/FStarC_Syntax_Hash.ml new file mode 100644 index 00000000000..b8ec74e32bb --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Syntax_Hash.ml @@ -0,0 +1,1281 @@ +open Prims +type 't mm = Prims.bool -> ('t * Prims.bool) +let op_let_Question : 's 't . 't mm -> ('t -> 's mm) -> 's mm = + fun f -> + fun g -> + fun b -> + let uu___ = f b in + match uu___ with | (t1, b1) -> let uu___1 = g t1 in uu___1 b1 +let ret : 't . 't -> 't mm = fun x -> fun b -> (x, b) +let (should_memo : Prims.bool mm) = fun b -> (b, b) +let (no_memo : unit mm) = fun uu___ -> ((), false) +let maybe_memoize : + 'a . + 'a FStarC_Syntax_Syntax.syntax -> + ('a FStarC_Syntax_Syntax.syntax -> FStarC_Hash.hash_code mm) -> + FStarC_Hash.hash_code mm + = + fun h -> + fun f -> + fun should_memo1 -> + if should_memo1 + then + let uu___ = + FStarC_Compiler_Effect.op_Bang h.FStarC_Syntax_Syntax.hash_code in + match uu___ with + | FStar_Pervasives_Native.Some c -> (c, should_memo1) + | FStar_Pervasives_Native.None -> + let uu___1 = let uu___2 = f h in uu___2 should_memo1 in + (match uu___1 with + | (c, should_memo2) -> + (if should_memo2 + then + FStarC_Compiler_Effect.op_Colon_Equals + h.FStarC_Syntax_Syntax.hash_code + (FStar_Pervasives_Native.Some c) + else (); + (c, should_memo2))) + else (let uu___1 = f h in uu___1 should_memo1) +let (of_int : Prims.int -> FStarC_Hash.hash_code mm) = + fun i -> let uu___ = FStarC_Hash.of_int i in ret uu___ +let (of_string : Prims.string -> FStarC_Hash.hash_code mm) = + fun s -> let uu___ = FStarC_Hash.of_string s in ret uu___ +let (mix : + FStarC_Hash.hash_code mm -> + FStarC_Hash.hash_code mm -> FStarC_Hash.hash_code mm) + = + fun f -> + fun g -> + fun b -> + let uu___ = f b in + match uu___ with + | (x, b0) -> + let uu___1 = g b in + (match uu___1 with + | (y, b1) -> + let uu___2 = FStarC_Hash.mix x y in (uu___2, (b0 && b1))) +let (nil_hc : FStarC_Hash.hash_code mm) = of_int (Prims.of_int (1229)) +let (cons_hc : FStarC_Hash.hash_code mm) = of_int (Prims.of_int (1231)) +let (mix_list : + FStarC_Hash.hash_code mm Prims.list -> FStarC_Hash.hash_code mm) = + fun l -> FStarC_Compiler_List.fold_right mix l nil_hc +let (mix_list_lit : + FStarC_Hash.hash_code mm Prims.list -> FStarC_Hash.hash_code mm) = mix_list +let hash_list : + 'a . + ('a -> FStarC_Hash.hash_code mm) -> + 'a Prims.list -> FStarC_Hash.hash_code mm + = + fun h -> + fun ts -> let uu___ = FStarC_Compiler_List.map h ts in mix_list uu___ +let hash_option : + 'a . + ('a -> FStarC_Hash.hash_code mm) -> + 'a FStar_Pervasives_Native.option -> FStarC_Hash.hash_code mm + = + fun h -> + fun o -> + match o with + | FStar_Pervasives_Native.None -> + let uu___ = FStarC_Hash.of_int (Prims.of_int (1237)) in ret uu___ + | FStar_Pervasives_Native.Some o1 -> + let uu___ = + let uu___1 = FStarC_Hash.of_int (Prims.of_int (1249)) in + ret uu___1 in + let uu___1 = h o1 in mix uu___ uu___1 +let (hash_doc : FStarC_Pprint.document -> FStarC_Hash.hash_code mm) = + fun d -> + let uu___ = + FStarC_Pprint.pretty_string + (FStarC_Compiler_Util.float_of_string "1.0") (Prims.of_int (80)) d in + of_string uu___ +let (hash_doc_list : + FStarC_Pprint.document Prims.list -> FStarC_Hash.hash_code mm) = + fun ds -> hash_list hash_doc ds +let hash_pair : + 'a 'b . + ('a -> FStarC_Hash.hash_code mm) -> + ('b -> FStarC_Hash.hash_code mm) -> + ('a * 'b) -> FStarC_Hash.hash_code mm + = + fun h -> + fun i -> + fun x -> + let uu___ = h (FStar_Pervasives_Native.fst x) in + let uu___1 = i (FStar_Pervasives_Native.snd x) in mix uu___ uu___1 +let rec (hash_term : FStarC_Syntax_Syntax.term -> FStarC_Hash.hash_code mm) = + fun t -> maybe_memoize t hash_term' +and (hash_comp : + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> + FStarC_Hash.hash_code mm) + = fun c -> maybe_memoize c hash_comp' +and (hash_term' : FStarC_Syntax_Syntax.term -> FStarC_Hash.hash_code mm) = + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_bvar bv -> + let uu___1 = of_int (Prims.of_int (3)) in + let uu___2 = of_int bv.FStarC_Syntax_Syntax.index in + mix uu___1 uu___2 + | FStarC_Syntax_Syntax.Tm_name bv -> + let uu___1 = of_int (Prims.of_int (5)) in + let uu___2 = of_int bv.FStarC_Syntax_Syntax.index in + mix uu___1 uu___2 + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let uu___1 = of_int (Prims.of_int (7)) in + let uu___2 = hash_fv fv in mix uu___1 uu___2 + | FStarC_Syntax_Syntax.Tm_uinst (t1, us) -> + let uu___1 = of_int (Prims.of_int (11)) in + let uu___2 = + let uu___3 = hash_term t1 in + let uu___4 = hash_list hash_universe us in mix uu___3 uu___4 in + mix uu___1 uu___2 + | FStarC_Syntax_Syntax.Tm_constant sc -> + let uu___1 = of_int (Prims.of_int (13)) in + let uu___2 = hash_constant sc in mix uu___1 uu___2 + | FStarC_Syntax_Syntax.Tm_type u -> + let uu___1 = of_int (Prims.of_int (17)) in + let uu___2 = hash_universe u in mix uu___1 uu___2 + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs; FStarC_Syntax_Syntax.body = t1; + FStarC_Syntax_Syntax.rc_opt = rcopt;_} + -> + let uu___1 = of_int (Prims.of_int (19)) in + let uu___2 = + let uu___3 = hash_list hash_binder bs in + let uu___4 = + let uu___5 = hash_term t1 in + let uu___6 = hash_option hash_rc rcopt in mix uu___5 uu___6 in + mix uu___3 uu___4 in + mix uu___1 uu___2 + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; FStarC_Syntax_Syntax.comp = c;_} -> + let uu___1 = of_int (Prims.of_int (23)) in + let uu___2 = + let uu___3 = hash_list hash_binder bs in + let uu___4 = hash_comp c in mix uu___3 uu___4 in + mix uu___1 uu___2 + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = b; FStarC_Syntax_Syntax.phi = t1;_} -> + let uu___1 = of_int (Prims.of_int (29)) in + let uu___2 = + let uu___3 = hash_bv b in + let uu___4 = hash_term t1 in mix uu___3 uu___4 in + mix uu___1 uu___2 + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = t1; FStarC_Syntax_Syntax.args = args;_} + -> + let uu___1 = of_int (Prims.of_int (31)) in + let uu___2 = + let uu___3 = hash_term t1 in + let uu___4 = hash_list hash_arg args in mix uu___3 uu___4 in + mix uu___1 uu___2 + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = t1; + FStarC_Syntax_Syntax.ret_opt = asc_opt; + FStarC_Syntax_Syntax.brs = branches; + FStarC_Syntax_Syntax.rc_opt1 = rcopt;_} + -> + let uu___1 = of_int (Prims.of_int (37)) in + let uu___2 = + let uu___3 = hash_option hash_match_returns asc_opt in + let uu___4 = + let uu___5 = + let uu___6 = hash_term t1 in + let uu___7 = hash_list hash_branch branches in + mix uu___6 uu___7 in + let uu___6 = hash_option hash_rc rcopt in mix uu___5 uu___6 in + mix uu___3 uu___4 in + mix uu___1 uu___2 + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t1; FStarC_Syntax_Syntax.asc = a; + FStarC_Syntax_Syntax.eff_opt = lopt;_} + -> + let uu___1 = of_int (Prims.of_int (43)) in + let uu___2 = + let uu___3 = hash_term t1 in + let uu___4 = + let uu___5 = hash_ascription a in + let uu___6 = hash_option hash_lid lopt in mix uu___5 uu___6 in + mix uu___3 uu___4 in + mix uu___1 uu___2 + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (false, lb::[]); + FStarC_Syntax_Syntax.body1 = t1;_} + -> + let uu___1 = of_int (Prims.of_int (47)) in + let uu___2 = + let uu___3 = hash_lb lb in + let uu___4 = hash_term t1 in mix uu___3 uu___4 in + mix uu___1 uu___2 + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (uu___1, lbs); + FStarC_Syntax_Syntax.body1 = t1;_} + -> + let uu___2 = of_int (Prims.of_int (51)) in + let uu___3 = + let uu___4 = hash_list hash_lb lbs in + let uu___5 = hash_term t1 in mix uu___4 uu___5 in + mix uu___2 uu___3 + | FStarC_Syntax_Syntax.Tm_uvar uv -> + let uu___1 = of_int (Prims.of_int (53)) in + let uu___2 = hash_uvar uv in mix uu___1 uu___2 + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t1; FStarC_Syntax_Syntax.meta = m;_} -> + let uu___1 = of_int (Prims.of_int (61)) in + let uu___2 = + let uu___3 = hash_term t1 in + let uu___4 = hash_meta m in mix uu___3 uu___4 in + mix uu___1 uu___2 + | FStarC_Syntax_Syntax.Tm_lazy li -> + let uu___1 = of_int (Prims.of_int (67)) in + let uu___2 = hash_lazyinfo li in mix uu___1 uu___2 + | FStarC_Syntax_Syntax.Tm_quoted (t1, qi) -> + let uu___1 = of_int (Prims.of_int (71)) in + let uu___2 = + let uu___3 = hash_term t1 in + let uu___4 = hash_quoteinfo qi in mix uu___3 uu___4 in + mix uu___1 uu___2 + | FStarC_Syntax_Syntax.Tm_unknown -> of_int (Prims.of_int (73)) + | FStarC_Syntax_Syntax.Tm_delayed uu___1 -> failwith "Impossible" +and (hash_comp' : FStarC_Syntax_Syntax.comp -> FStarC_Hash.hash_code mm) = + fun c -> + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total t -> + let uu___ = + let uu___1 = of_int (Prims.of_int (811)) in + let uu___2 = let uu___3 = hash_term t in [uu___3] in uu___1 :: + uu___2 in + mix_list_lit uu___ + | FStarC_Syntax_Syntax.GTotal t -> + let uu___ = + let uu___1 = of_int (Prims.of_int (821)) in + let uu___2 = let uu___3 = hash_term t in [uu___3] in uu___1 :: + uu___2 in + mix_list_lit uu___ + | FStarC_Syntax_Syntax.Comp ct -> + let uu___ = + let uu___1 = of_int (Prims.of_int (823)) in + let uu___2 = + let uu___3 = + hash_list hash_universe ct.FStarC_Syntax_Syntax.comp_univs in + let uu___4 = + let uu___5 = hash_lid ct.FStarC_Syntax_Syntax.effect_name in + let uu___6 = + let uu___7 = hash_term ct.FStarC_Syntax_Syntax.result_typ in + let uu___8 = + let uu___9 = + hash_list hash_arg ct.FStarC_Syntax_Syntax.effect_args in + let uu___10 = + let uu___11 = + hash_list hash_flag ct.FStarC_Syntax_Syntax.flags in + [uu___11] in + uu___9 :: uu___10 in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mix_list_lit uu___ +and (hash_lb : FStarC_Syntax_Syntax.letbinding -> FStarC_Hash.hash_code mm) = + fun lb -> + let uu___ = + let uu___1 = of_int (Prims.of_int (79)) in + let uu___2 = + let uu___3 = hash_lbname lb.FStarC_Syntax_Syntax.lbname in + let uu___4 = + let uu___5 = hash_list hash_ident lb.FStarC_Syntax_Syntax.lbunivs in + let uu___6 = + let uu___7 = hash_term lb.FStarC_Syntax_Syntax.lbtyp in + let uu___8 = + let uu___9 = hash_lid lb.FStarC_Syntax_Syntax.lbeff in + let uu___10 = + let uu___11 = hash_term lb.FStarC_Syntax_Syntax.lbdef in + let uu___12 = + let uu___13 = + hash_list hash_term lb.FStarC_Syntax_Syntax.lbattrs in + [uu___13] in + uu___11 :: uu___12 in + uu___9 :: uu___10 in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mix_list_lit uu___ +and (hash_match_returns : + (FStarC_Syntax_Syntax.binder * + ((FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax, + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax) + FStar_Pervasives.either * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax FStar_Pervasives_Native.option * Prims.bool)) + -> FStarC_Hash.hash_code mm) + = + fun uu___ -> + match uu___ with + | (b, asc) -> + let uu___1 = hash_binder b in + let uu___2 = hash_ascription asc in mix uu___1 uu___2 +and (hash_branch : + (FStarC_Syntax_Syntax.pat' FStarC_Syntax_Syntax.withinfo_t * + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax + FStar_Pervasives_Native.option * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax) -> FStarC_Hash.hash_code mm) + = + fun b -> + let uu___ = b in + match uu___ with + | (p, topt, t) -> + let uu___1 = + let uu___2 = of_int (Prims.of_int (83)) in + let uu___3 = + let uu___4 = hash_pat p in + let uu___5 = + let uu___6 = hash_option hash_term topt in + let uu___7 = let uu___8 = hash_term t in [uu___8] in uu___6 :: + uu___7 in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + mix_list_lit uu___1 +and (hash_pat : + FStarC_Syntax_Syntax.pat' FStarC_Syntax_Syntax.withinfo_t -> + FStarC_Hash.hash_code mm) + = + fun p -> + match p.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_constant c -> + let uu___ = of_int (Prims.of_int (89)) in + let uu___1 = hash_constant c in mix uu___ uu___1 + | FStarC_Syntax_Syntax.Pat_cons (fv, us, args) -> + let uu___ = + let uu___1 = of_int (Prims.of_int (97)) in + let uu___2 = + let uu___3 = hash_fv fv in + let uu___4 = + let uu___5 = hash_option (hash_list hash_universe) us in + let uu___6 = + let uu___7 = hash_list (hash_pair hash_pat hash_bool) args in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mix_list_lit uu___ + | FStarC_Syntax_Syntax.Pat_var bv -> + let uu___ = of_int (Prims.of_int (101)) in + let uu___1 = hash_bv bv in mix uu___ uu___1 + | FStarC_Syntax_Syntax.Pat_dot_term t -> + let uu___ = + let uu___1 = of_int (Prims.of_int (107)) in + let uu___2 = let uu___3 = hash_option hash_term t in [uu___3] in + uu___1 :: uu___2 in + mix_list_lit uu___ +and (hash_bv : FStarC_Syntax_Syntax.bv -> FStarC_Hash.hash_code mm) = + fun b -> hash_term b.FStarC_Syntax_Syntax.sort +and (hash_fv : FStarC_Syntax_Syntax.fv -> FStarC_Hash.hash_code mm) = + fun fv -> + let uu___ = + FStarC_Ident.string_of_lid + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + of_string uu___ +and (hash_binder : FStarC_Syntax_Syntax.binder -> FStarC_Hash.hash_code mm) = + fun b -> + let uu___ = + let uu___1 = hash_bv b.FStarC_Syntax_Syntax.binder_bv in + let uu___2 = + let uu___3 = + hash_option hash_bqual b.FStarC_Syntax_Syntax.binder_qual in + let uu___4 = + let uu___5 = + hash_list hash_term b.FStarC_Syntax_Syntax.binder_attrs in + [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mix_list_lit uu___ +and (hash_universe : + FStarC_Syntax_Syntax.universe -> FStarC_Hash.hash_code mm) = + fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.U_zero -> of_int (Prims.of_int (179)) + | FStarC_Syntax_Syntax.U_succ u -> + let uu___1 = of_int (Prims.of_int (181)) in + let uu___2 = hash_universe u in mix uu___1 uu___2 + | FStarC_Syntax_Syntax.U_max us -> + let uu___1 = of_int (Prims.of_int (191)) in + let uu___2 = hash_list hash_universe us in mix uu___1 uu___2 + | FStarC_Syntax_Syntax.U_bvar i -> + let uu___1 = of_int (Prims.of_int (193)) in + let uu___2 = of_int i in mix uu___1 uu___2 + | FStarC_Syntax_Syntax.U_name i -> + let uu___1 = of_int (Prims.of_int (197)) in + let uu___2 = hash_ident i in mix uu___1 uu___2 + | FStarC_Syntax_Syntax.U_unif uv -> + let uu___1 = of_int (Prims.of_int (199)) in + let uu___2 = hash_universe_uvar uv in mix uu___1 uu___2 + | FStarC_Syntax_Syntax.U_unknown -> of_int (Prims.of_int (211)) +and (hash_arg : + (FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax * + FStarC_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) -> + FStarC_Hash.hash_code mm) + = + fun uu___ -> + match uu___ with + | (t, aq) -> + let uu___1 = hash_term t in + let uu___2 = hash_option hash_arg_qualifier aq in mix uu___1 uu___2 +and (hash_arg_qualifier : + FStarC_Syntax_Syntax.arg_qualifier -> FStarC_Hash.hash_code mm) = + fun aq -> + let uu___ = hash_bool aq.FStarC_Syntax_Syntax.aqual_implicit in + let uu___1 = hash_list hash_term aq.FStarC_Syntax_Syntax.aqual_attributes in + mix uu___ uu___1 +and (hash_bqual : + FStarC_Syntax_Syntax.binder_qualifier -> FStarC_Hash.hash_code mm) = + fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.Implicit (true) -> of_int (Prims.of_int (419)) + | FStarC_Syntax_Syntax.Implicit (false) -> of_int (Prims.of_int (421)) + | FStarC_Syntax_Syntax.Meta t -> + let uu___1 = of_int (Prims.of_int (431)) in + let uu___2 = hash_term t in mix uu___1 uu___2 + | FStarC_Syntax_Syntax.Equality -> of_int (Prims.of_int (433)) +and (hash_uvar : + (FStarC_Syntax_Syntax.ctx_uvar * (FStarC_Syntax_Syntax.subst_elt Prims.list + Prims.list * FStarC_Syntax_Syntax.maybe_set_use_range)) -> + FStarC_Hash.hash_code mm) + = + fun uu___ -> + match uu___ with + | (u, uu___1) -> + let uu___2 = + FStarC_Syntax_Unionfind.uvar_id + u.FStarC_Syntax_Syntax.ctx_uvar_head in + of_int uu___2 +and (hash_universe_uvar : + (FStarC_Syntax_Syntax.universe FStar_Pervasives_Native.option + FStarC_Unionfind.p_uvar * FStarC_Syntax_Syntax.version * + FStarC_Compiler_Range_Type.range) -> FStarC_Hash.hash_code mm) + = + fun u -> let uu___ = FStarC_Syntax_Unionfind.univ_uvar_id u in of_int uu___ +and (hash_ascription : + ((FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax, + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax) + FStar_Pervasives.either * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax FStar_Pervasives_Native.option * Prims.bool) + -> FStarC_Hash.hash_code mm) + = + fun uu___ -> + match uu___ with + | (a, to1, b) -> + let uu___1 = + match a with + | FStar_Pervasives.Inl t -> hash_term t + | FStar_Pervasives.Inr c -> hash_comp c in + let uu___2 = hash_option hash_term to1 in mix uu___1 uu___2 +and (hash_bool : Prims.bool -> FStarC_Hash.hash_code mm) = + fun b -> + if b then of_int (Prims.of_int (307)) else of_int (Prims.of_int (311)) +and (hash_constant : FStarC_Syntax_Syntax.sconst -> FStarC_Hash.hash_code mm) + = + fun uu___ -> + match uu___ with + | FStarC_Const.Const_effect -> of_int (Prims.of_int (283)) + | FStarC_Const.Const_unit -> of_int (Prims.of_int (293)) + | FStarC_Const.Const_bool b -> hash_bool b + | FStarC_Const.Const_int (s, o) -> + let uu___1 = of_int (Prims.of_int (313)) in + let uu___2 = + let uu___3 = of_string s in + let uu___4 = hash_option hash_sw o in mix uu___3 uu___4 in + mix uu___1 uu___2 + | FStarC_Const.Const_char c -> + let uu___1 = of_int (Prims.of_int (317)) in + let uu___2 = of_int (FStar_Char.int_of_char c) in mix uu___1 uu___2 + | FStarC_Const.Const_real s -> + let uu___1 = of_int (Prims.of_int (337)) in + let uu___2 = of_string s in mix uu___1 uu___2 + | FStarC_Const.Const_string (s, uu___1) -> + let uu___2 = of_int (Prims.of_int (349)) in + let uu___3 = of_string s in mix uu___2 uu___3 + | FStarC_Const.Const_range_of -> of_int (Prims.of_int (353)) + | FStarC_Const.Const_set_range_of -> of_int (Prims.of_int (359)) + | FStarC_Const.Const_range r -> + let uu___1 = of_int (Prims.of_int (367)) in + let uu___2 = + let uu___3 = FStarC_Compiler_Range_Ops.string_of_range r in + of_string uu___3 in + mix uu___1 uu___2 + | FStarC_Const.Const_reify uu___1 -> of_int (Prims.of_int (367)) + | FStarC_Const.Const_reflect l -> + let uu___1 = of_int (Prims.of_int (373)) in + let uu___2 = hash_lid l in mix uu___1 uu___2 +and (hash_sw : + (FStarC_Const.signedness * FStarC_Const.width) -> FStarC_Hash.hash_code mm) + = + fun uu___ -> + match uu___ with + | (s, w) -> + let uu___1 = + match s with + | FStarC_Const.Unsigned -> of_int (Prims.of_int (547)) + | FStarC_Const.Signed -> of_int (Prims.of_int (557)) in + let uu___2 = + match w with + | FStarC_Const.Int8 -> of_int (Prims.of_int (563)) + | FStarC_Const.Int16 -> of_int (Prims.of_int (569)) + | FStarC_Const.Int32 -> of_int (Prims.of_int (571)) + | FStarC_Const.Int64 -> of_int (Prims.of_int (577)) + | FStarC_Const.Sizet -> of_int (Prims.of_int (583)) in + mix uu___1 uu___2 +and (hash_ident : FStarC_Syntax_Syntax.univ_name -> FStarC_Hash.hash_code mm) + = fun i -> let uu___ = FStarC_Ident.string_of_id i in of_string uu___ +and (hash_lid : FStarC_Ident.lident -> FStarC_Hash.hash_code mm) = + fun l -> let uu___ = FStarC_Ident.string_of_lid l in of_string uu___ +and (hash_lbname : + (FStarC_Syntax_Syntax.bv, FStarC_Syntax_Syntax.fv) FStar_Pervasives.either + -> FStarC_Hash.hash_code mm) + = + fun l -> + match l with + | FStar_Pervasives.Inl bv -> hash_bv bv + | FStar_Pervasives.Inr fv -> hash_fv fv +and (hash_rc : + FStarC_Syntax_Syntax.residual_comp -> FStarC_Hash.hash_code mm) = + fun rc -> + let uu___ = + let uu___1 = hash_lid rc.FStarC_Syntax_Syntax.residual_effect in + let uu___2 = + let uu___3 = + hash_option hash_term rc.FStarC_Syntax_Syntax.residual_typ in + let uu___4 = + let uu___5 = + hash_list hash_flag rc.FStarC_Syntax_Syntax.residual_flags in + [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mix_list_lit uu___ +and (hash_flag : FStarC_Syntax_Syntax.cflag -> FStarC_Hash.hash_code mm) = + fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.TOTAL -> of_int (Prims.of_int (947)) + | FStarC_Syntax_Syntax.MLEFFECT -> of_int (Prims.of_int (953)) + | FStarC_Syntax_Syntax.LEMMA -> of_int (Prims.of_int (967)) + | FStarC_Syntax_Syntax.RETURN -> of_int (Prims.of_int (971)) + | FStarC_Syntax_Syntax.PARTIAL_RETURN -> of_int (Prims.of_int (977)) + | FStarC_Syntax_Syntax.SOMETRIVIAL -> of_int (Prims.of_int (983)) + | FStarC_Syntax_Syntax.TRIVIAL_POSTCONDITION -> + of_int (Prims.of_int (991)) + | FStarC_Syntax_Syntax.SHOULD_NOT_INLINE -> of_int (Prims.of_int (997)) + | FStarC_Syntax_Syntax.CPS -> of_int (Prims.of_int (1009)) + | FStarC_Syntax_Syntax.DECREASES (FStarC_Syntax_Syntax.Decreases_lex ts) + -> + let uu___1 = of_int (Prims.of_int (1013)) in + let uu___2 = hash_list hash_term ts in mix uu___1 uu___2 + | FStarC_Syntax_Syntax.DECREASES (FStarC_Syntax_Syntax.Decreases_wf + (t0, t1)) -> + let uu___1 = of_int (Prims.of_int (2341)) in + let uu___2 = hash_list hash_term [t0; t1] in mix uu___1 uu___2 +and (hash_meta : FStarC_Syntax_Syntax.metadata -> FStarC_Hash.hash_code mm) = + fun m -> + match m with + | FStarC_Syntax_Syntax.Meta_pattern (ts, args) -> + let uu___ = + let uu___1 = of_int (Prims.of_int (1019)) in + let uu___2 = + let uu___3 = hash_list hash_term ts in + let uu___4 = + let uu___5 = hash_list (hash_list hash_arg) args in [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mix_list_lit uu___ + | FStarC_Syntax_Syntax.Meta_named l -> + let uu___ = + let uu___1 = of_int (Prims.of_int (1021)) in + let uu___2 = let uu___3 = hash_lid l in [uu___3] in uu___1 :: + uu___2 in + mix_list_lit uu___ + | FStarC_Syntax_Syntax.Meta_labeled (s, r, uu___) -> + let uu___1 = + let uu___2 = of_int (Prims.of_int (1031)) in + let uu___3 = + let uu___4 = hash_doc_list s in + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Compiler_Range_Ops.string_of_range r in + of_string uu___7 in + [uu___6] in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + mix_list_lit uu___1 + | FStarC_Syntax_Syntax.Meta_desugared msi -> + let uu___ = + let uu___1 = of_int (Prims.of_int (1033)) in + let uu___2 = let uu___3 = hash_meta_source_info msi in [uu___3] in + uu___1 :: uu___2 in + mix_list_lit uu___ + | FStarC_Syntax_Syntax.Meta_monadic (m1, t) -> + let uu___ = + let uu___1 = of_int (Prims.of_int (1039)) in + let uu___2 = + let uu___3 = hash_lid m1 in + let uu___4 = let uu___5 = hash_term t in [uu___5] in uu___3 :: + uu___4 in + uu___1 :: uu___2 in + mix_list_lit uu___ + | FStarC_Syntax_Syntax.Meta_monadic_lift (m0, m1, t) -> + let uu___ = + let uu___1 = of_int (Prims.of_int (1069)) in + let uu___2 = + let uu___3 = hash_lid m0 in + let uu___4 = + let uu___5 = hash_lid m1 in + let uu___6 = let uu___7 = hash_term t in [uu___7] in uu___5 :: + uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mix_list_lit uu___ +and (hash_meta_source_info : + FStarC_Syntax_Syntax.meta_source_info -> FStarC_Hash.hash_code mm) = + fun m -> + match m with + | FStarC_Syntax_Syntax.Sequence -> of_int (Prims.of_int (1049)) + | FStarC_Syntax_Syntax.Primop -> of_int (Prims.of_int (1051)) + | FStarC_Syntax_Syntax.Masked_effect -> of_int (Prims.of_int (1061)) + | FStarC_Syntax_Syntax.Meta_smt_pat -> of_int (Prims.of_int (1063)) + | FStarC_Syntax_Syntax.Machine_integer sw -> + let uu___ = of_int (Prims.of_int (1069)) in + let uu___1 = hash_sw sw in mix uu___ uu___1 +and (hash_lazyinfo : + FStarC_Syntax_Syntax.lazyinfo -> FStarC_Hash.hash_code mm) = + fun li -> of_int Prims.int_zero +and (hash_quoteinfo : + FStarC_Syntax_Syntax.quoteinfo -> FStarC_Hash.hash_code mm) = + fun qi -> + let uu___ = + hash_bool + (qi.FStarC_Syntax_Syntax.qkind = FStarC_Syntax_Syntax.Quote_static) in + let uu___1 = + hash_list hash_term + (FStar_Pervasives_Native.snd qi.FStarC_Syntax_Syntax.antiquotations) in + mix uu___ uu___1 +let rec equal_list : + 'uuuuu 'uuuuu1 . + ('uuuuu -> 'uuuuu1 -> Prims.bool) -> + 'uuuuu Prims.list -> 'uuuuu1 Prims.list -> Prims.bool + = + fun f -> + fun l1 -> + fun l2 -> + match (l1, l2) with + | ([], []) -> true + | (h1::t1, h2::t2) -> (f h1 h2) && (equal_list f t1 t2) + | uu___ -> false +let equal_opt : + 'uuuuu 'uuuuu1 . + ('uuuuu -> 'uuuuu1 -> Prims.bool) -> + 'uuuuu FStar_Pervasives_Native.option -> + 'uuuuu1 FStar_Pervasives_Native.option -> Prims.bool + = + fun f -> + fun o1 -> + fun o2 -> + match (o1, o2) with + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> + true + | (FStar_Pervasives_Native.Some a, FStar_Pervasives_Native.Some b) -> + f a b + | uu___ -> false +let equal_pair : + 'uuuuu 'uuuuu1 'uuuuu2 'uuuuu3 . + ('uuuuu -> 'uuuuu1 -> Prims.bool) -> + ('uuuuu2 -> 'uuuuu3 -> Prims.bool) -> + ('uuuuu * 'uuuuu2) -> ('uuuuu1 * 'uuuuu3) -> Prims.bool + = + fun f -> + fun g -> + fun uu___ -> + fun uu___1 -> + match (uu___, uu___1) with + | ((x1, y1), (x2, y2)) -> (f x1 x2) && (g y1 y2) +let equal_poly : 'uuuuu . 'uuuuu -> 'uuuuu -> Prims.bool = + fun x -> fun y -> x = y +let (ext_hash_term : FStarC_Syntax_Syntax.term -> FStarC_Hash.hash_code) = + fun t -> + let uu___ = let uu___1 = hash_term t in uu___1 true in + FStar_Pervasives_Native.fst uu___ +let (ext_hash_term_no_memo : + FStarC_Syntax_Syntax.term -> FStarC_Hash.hash_code) = + fun t -> + let uu___ = let uu___1 = hash_term t in uu___1 false in + FStar_Pervasives_Native.fst uu___ +let rec (equal_term : + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t1 -> + fun t2 -> + let uu___ = FStarC_Compiler_Util.physical_equality t1 t2 in + if uu___ + then true + else + (let uu___2 = + FStarC_Compiler_Util.physical_equality t1.FStarC_Syntax_Syntax.n + t2.FStarC_Syntax_Syntax.n in + if uu___2 + then true + else + (let uu___4 = + let uu___5 = ext_hash_term t1 in + let uu___6 = ext_hash_term t2 in uu___5 <> uu___6 in + if uu___4 + then false + else + (let uu___6 = + let uu___7 = + let uu___8 = FStarC_Syntax_Subst.compress t1 in + uu___8.FStarC_Syntax_Syntax.n in + let uu___8 = + let uu___9 = FStarC_Syntax_Subst.compress t2 in + uu___9.FStarC_Syntax_Syntax.n in + (uu___7, uu___8) in + match uu___6 with + | (FStarC_Syntax_Syntax.Tm_bvar x, + FStarC_Syntax_Syntax.Tm_bvar y) -> + x.FStarC_Syntax_Syntax.index = + y.FStarC_Syntax_Syntax.index + | (FStarC_Syntax_Syntax.Tm_name x, + FStarC_Syntax_Syntax.Tm_name y) -> + x.FStarC_Syntax_Syntax.index = + y.FStarC_Syntax_Syntax.index + | (FStarC_Syntax_Syntax.Tm_fvar f, + FStarC_Syntax_Syntax.Tm_fvar g) -> equal_fv f g + | (FStarC_Syntax_Syntax.Tm_uinst (t11, u1), + FStarC_Syntax_Syntax.Tm_uinst (t21, u2)) -> + (equal_term t11 t21) && (equal_list equal_universe u1 u2) + | (FStarC_Syntax_Syntax.Tm_constant c1, + FStarC_Syntax_Syntax.Tm_constant c2) -> + equal_constant c1 c2 + | (FStarC_Syntax_Syntax.Tm_type u1, + FStarC_Syntax_Syntax.Tm_type u2) -> equal_universe u1 u2 + | (FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs1; + FStarC_Syntax_Syntax.body = t11; + FStarC_Syntax_Syntax.rc_opt = rc1;_}, + FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs2; + FStarC_Syntax_Syntax.body = t21; + FStarC_Syntax_Syntax.rc_opt = rc2;_}) + -> + ((equal_list equal_binder bs1 bs2) && (equal_term t11 t21)) + && (equal_opt equal_rc rc1 rc2) + | (FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs1; + FStarC_Syntax_Syntax.comp = c1;_}, + FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs2; + FStarC_Syntax_Syntax.comp = c2;_}) + -> (equal_list equal_binder bs1 bs2) && (equal_comp c1 c2) + | (FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = b1; + FStarC_Syntax_Syntax.phi = t11;_}, + FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = b2; + FStarC_Syntax_Syntax.phi = t21;_}) + -> (equal_bv b1 b2) && (equal_term t11 t21) + | (FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = t11; + FStarC_Syntax_Syntax.args = as1;_}, + FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = t21; + FStarC_Syntax_Syntax.args = as2;_}) + -> (equal_term t11 t21) && (equal_list equal_arg as1 as2) + | (FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = t11; + FStarC_Syntax_Syntax.ret_opt = asc_opt1; + FStarC_Syntax_Syntax.brs = bs1; + FStarC_Syntax_Syntax.rc_opt1 = ropt1;_}, + FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = t21; + FStarC_Syntax_Syntax.ret_opt = asc_opt2; + FStarC_Syntax_Syntax.brs = bs2; + FStarC_Syntax_Syntax.rc_opt1 = ropt2;_}) + -> + (((equal_term t11 t21) && + (equal_opt equal_match_returns asc_opt1 asc_opt2)) + && (equal_list equal_branch bs1 bs2)) + && (equal_opt equal_rc ropt1 ropt2) + | (FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t11; + FStarC_Syntax_Syntax.asc = a1; + FStarC_Syntax_Syntax.eff_opt = l1;_}, + FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t21; + FStarC_Syntax_Syntax.asc = a2; + FStarC_Syntax_Syntax.eff_opt = l2;_}) + -> + ((equal_term t11 t21) && (equal_ascription a1 a2)) && + (equal_opt FStarC_Ident.lid_equals l1 l2) + | (FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (r1, lbs1); + FStarC_Syntax_Syntax.body1 = t11;_}, + FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (r2, lbs2); + FStarC_Syntax_Syntax.body1 = t21;_}) + -> + ((r1 = r2) && (equal_list equal_letbinding lbs1 lbs2)) && + (equal_term t11 t21) + | (FStarC_Syntax_Syntax.Tm_uvar u1, + FStarC_Syntax_Syntax.Tm_uvar u2) -> equal_uvar u1 u2 + | (FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t11; + FStarC_Syntax_Syntax.meta = m1;_}, + FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t21; + FStarC_Syntax_Syntax.meta = m2;_}) + -> (equal_term t11 t21) && (equal_meta m1 m2) + | (FStarC_Syntax_Syntax.Tm_lazy l1, + FStarC_Syntax_Syntax.Tm_lazy l2) -> equal_lazyinfo l1 l2 + | (FStarC_Syntax_Syntax.Tm_quoted (t11, q1), + FStarC_Syntax_Syntax.Tm_quoted (t21, q2)) -> + (equal_term t11 t21) && (equal_quoteinfo q1 q2) + | (FStarC_Syntax_Syntax.Tm_unknown, + FStarC_Syntax_Syntax.Tm_unknown) -> true + | uu___7 -> false))) +and (equal_comp : + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> Prims.bool) + = + fun c1 -> + fun c2 -> + let uu___ = FStarC_Compiler_Util.physical_equality c1 c2 in + if uu___ + then true + else + (match ((c1.FStarC_Syntax_Syntax.n), (c2.FStarC_Syntax_Syntax.n)) + with + | (FStarC_Syntax_Syntax.Total t1, FStarC_Syntax_Syntax.Total t2) -> + equal_term t1 t2 + | (FStarC_Syntax_Syntax.GTotal t1, FStarC_Syntax_Syntax.GTotal t2) + -> equal_term t1 t2 + | (FStarC_Syntax_Syntax.Comp ct1, FStarC_Syntax_Syntax.Comp ct2) -> + ((((FStarC_Ident.lid_equals ct1.FStarC_Syntax_Syntax.effect_name + ct2.FStarC_Syntax_Syntax.effect_name) + && + (equal_list equal_universe + ct1.FStarC_Syntax_Syntax.comp_univs + ct2.FStarC_Syntax_Syntax.comp_univs)) + && + (equal_term ct1.FStarC_Syntax_Syntax.result_typ + ct2.FStarC_Syntax_Syntax.result_typ)) + && + (equal_list equal_arg ct1.FStarC_Syntax_Syntax.effect_args + ct2.FStarC_Syntax_Syntax.effect_args)) + && + (equal_list equal_flag ct1.FStarC_Syntax_Syntax.flags + ct2.FStarC_Syntax_Syntax.flags)) +and (equal_binder : + FStarC_Syntax_Syntax.binder -> FStarC_Syntax_Syntax.binder -> Prims.bool) = + fun b1 -> + fun b2 -> + let uu___ = FStarC_Compiler_Util.physical_equality b1 b2 in + if uu___ + then true + else + ((equal_bv b1.FStarC_Syntax_Syntax.binder_bv + b2.FStarC_Syntax_Syntax.binder_bv) + && + (equal_bqual b1.FStarC_Syntax_Syntax.binder_qual + b2.FStarC_Syntax_Syntax.binder_qual)) + && + (equal_list equal_term b1.FStarC_Syntax_Syntax.binder_attrs + b2.FStarC_Syntax_Syntax.binder_attrs) +and (equal_match_returns : + (FStarC_Syntax_Syntax.binder * + ((FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax, + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax) + FStar_Pervasives.either * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax FStar_Pervasives_Native.option * Prims.bool)) + -> + (FStarC_Syntax_Syntax.binder * + ((FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax, + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax) + FStar_Pervasives.either * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax FStar_Pervasives_Native.option * + Prims.bool)) -> Prims.bool) + = + fun uu___ -> + fun uu___1 -> + match (uu___, uu___1) with + | ((b1, asc1), (b2, asc2)) -> + (equal_binder b1 b2) && (equal_ascription asc1 asc2) +and (equal_ascription : + ((FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax, + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax) + FStar_Pervasives.either * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax FStar_Pervasives_Native.option * Prims.bool) + -> + ((FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax, + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax) + FStar_Pervasives.either * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax FStar_Pervasives_Native.option * + Prims.bool) -> Prims.bool) + = + fun x1 -> + fun x2 -> + let uu___ = FStarC_Compiler_Util.physical_equality x1 x2 in + if uu___ + then true + else + (let uu___2 = x1 in + match uu___2 with + | (a1, t1, b1) -> + let uu___3 = x2 in + (match uu___3 with + | (a2, t2, b2) -> + ((match (a1, a2) with + | (FStar_Pervasives.Inl t11, FStar_Pervasives.Inl t21) -> + equal_term t11 t21 + | (FStar_Pervasives.Inr c1, FStar_Pervasives.Inr c2) -> + equal_comp c1 c2 + | uu___4 -> false) && (equal_opt equal_term t1 t2)) && + (b1 = b2))) +and (equal_letbinding : + FStarC_Syntax_Syntax.letbinding -> + FStarC_Syntax_Syntax.letbinding -> Prims.bool) + = + fun l1 -> + fun l2 -> + let uu___ = FStarC_Compiler_Util.physical_equality l1 l2 in + if uu___ + then true + else + (((((equal_lbname l1.FStarC_Syntax_Syntax.lbname + l2.FStarC_Syntax_Syntax.lbname) + && + (equal_list FStarC_Ident.ident_equals + l1.FStarC_Syntax_Syntax.lbunivs + l2.FStarC_Syntax_Syntax.lbunivs)) + && + (equal_term l1.FStarC_Syntax_Syntax.lbtyp + l2.FStarC_Syntax_Syntax.lbtyp)) + && + (FStarC_Ident.lid_equals l1.FStarC_Syntax_Syntax.lbeff + l2.FStarC_Syntax_Syntax.lbeff)) + && + (equal_term l1.FStarC_Syntax_Syntax.lbdef + l2.FStarC_Syntax_Syntax.lbdef)) + && + (equal_list equal_term l1.FStarC_Syntax_Syntax.lbattrs + l2.FStarC_Syntax_Syntax.lbattrs) +and (equal_uvar : + (FStarC_Syntax_Syntax.ctx_uvar * (FStarC_Syntax_Syntax.subst_elt Prims.list + Prims.list * FStarC_Syntax_Syntax.maybe_set_use_range)) -> + (FStarC_Syntax_Syntax.ctx_uvar * (FStarC_Syntax_Syntax.subst_elt + Prims.list Prims.list * FStarC_Syntax_Syntax.maybe_set_use_range)) -> + Prims.bool) + = + fun uu___ -> + fun uu___1 -> + match (uu___, uu___1) with + | ((u1, (s1, uu___2)), (u2, (s2, uu___3))) -> + (FStarC_Syntax_Unionfind.equiv + u1.FStarC_Syntax_Syntax.ctx_uvar_head + u2.FStarC_Syntax_Syntax.ctx_uvar_head) + && (equal_list (equal_list equal_subst_elt) s1 s2) +and (equal_bv : + FStarC_Syntax_Syntax.bv -> FStarC_Syntax_Syntax.bv -> Prims.bool) = + fun b1 -> + fun b2 -> + let uu___ = FStarC_Compiler_Util.physical_equality b1 b2 in + if uu___ + then true + else + (FStarC_Ident.ident_equals b1.FStarC_Syntax_Syntax.ppname + b2.FStarC_Syntax_Syntax.ppname) + && + (equal_term b1.FStarC_Syntax_Syntax.sort + b2.FStarC_Syntax_Syntax.sort) +and (equal_fv : + FStarC_Syntax_Syntax.fv -> FStarC_Syntax_Syntax.fv -> Prims.bool) = + fun f1 -> + fun f2 -> + let uu___ = FStarC_Compiler_Util.physical_equality f1 f2 in + if uu___ + then true + else + FStarC_Ident.lid_equals + (f1.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + (f2.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v +and (equal_universe : + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.universe -> Prims.bool) + = + fun u1 -> + fun u2 -> + let uu___ = FStarC_Compiler_Util.physical_equality u1 u2 in + if uu___ + then true + else + (let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress_univ u1 in + let uu___4 = FStarC_Syntax_Subst.compress_univ u2 in + (uu___3, uu___4) in + match uu___2 with + | (FStarC_Syntax_Syntax.U_zero, FStarC_Syntax_Syntax.U_zero) -> true + | (FStarC_Syntax_Syntax.U_succ u11, FStarC_Syntax_Syntax.U_succ u21) + -> equal_universe u11 u21 + | (FStarC_Syntax_Syntax.U_max us1, FStarC_Syntax_Syntax.U_max us2) + -> equal_list equal_universe us1 us2 + | (FStarC_Syntax_Syntax.U_bvar i1, FStarC_Syntax_Syntax.U_bvar i2) + -> i1 = i2 + | (FStarC_Syntax_Syntax.U_name x1, FStarC_Syntax_Syntax.U_name x2) + -> FStarC_Ident.ident_equals x1 x2 + | (FStarC_Syntax_Syntax.U_unif u11, FStarC_Syntax_Syntax.U_unif u21) + -> FStarC_Syntax_Unionfind.univ_equiv u11 u21 + | (FStarC_Syntax_Syntax.U_unknown, FStarC_Syntax_Syntax.U_unknown) + -> true + | uu___3 -> false) +and (equal_constant : + FStarC_Syntax_Syntax.sconst -> FStarC_Syntax_Syntax.sconst -> Prims.bool) = + fun c1 -> + fun c2 -> + let uu___ = FStarC_Compiler_Util.physical_equality c1 c2 in + if uu___ + then true + else + (match (c1, c2) with + | (FStarC_Const.Const_effect, FStarC_Const.Const_effect) -> true + | (FStarC_Const.Const_unit, FStarC_Const.Const_unit) -> true + | (FStarC_Const.Const_bool b1, FStarC_Const.Const_bool b2) -> + b1 = b2 + | (FStarC_Const.Const_int (s1, o1), FStarC_Const.Const_int (s2, o2)) + -> (s1 = s2) && (o1 = o2) + | (FStarC_Const.Const_char c11, FStarC_Const.Const_char c21) -> + c11 = c21 + | (FStarC_Const.Const_real s1, FStarC_Const.Const_real s2) -> + s1 = s2 + | (FStarC_Const.Const_string (s1, uu___2), FStarC_Const.Const_string + (s2, uu___3)) -> s1 = s2 + | (FStarC_Const.Const_range_of, FStarC_Const.Const_range_of) -> true + | (FStarC_Const.Const_set_range_of, FStarC_Const.Const_set_range_of) + -> true + | (FStarC_Const.Const_range r1, FStarC_Const.Const_range r2) -> + let uu___2 = FStarC_Compiler_Range_Ops.compare r1 r2 in + uu___2 = Prims.int_zero + | (FStarC_Const.Const_reify uu___2, FStarC_Const.Const_reify uu___3) + -> true + | (FStarC_Const.Const_reflect l1, FStarC_Const.Const_reflect l2) -> + FStarC_Ident.lid_equals l1 l2 + | uu___2 -> false) +and (equal_arg : + (FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax * + FStarC_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) -> + (FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax * + FStarC_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) -> + Prims.bool) + = + fun arg1 -> + fun arg2 -> + let uu___ = FStarC_Compiler_Util.physical_equality arg1 arg2 in + if uu___ + then true + else + (let uu___2 = arg1 in + match uu___2 with + | (t1, a1) -> + let uu___3 = arg2 in + (match uu___3 with + | (t2, a2) -> + (equal_term t1 t2) && (equal_opt equal_arg_qualifier a1 a2))) +and (equal_bqual : + FStarC_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> + Prims.bool) + = fun b1 -> fun b2 -> equal_opt equal_binder_qualifier b1 b2 +and (equal_binder_qualifier : + FStarC_Syntax_Syntax.binder_qualifier -> + FStarC_Syntax_Syntax.binder_qualifier -> Prims.bool) + = + fun b1 -> + fun b2 -> + match (b1, b2) with + | (FStarC_Syntax_Syntax.Implicit b11, FStarC_Syntax_Syntax.Implicit + b21) -> b11 = b21 + | (FStarC_Syntax_Syntax.Equality, FStarC_Syntax_Syntax.Equality) -> + true + | (FStarC_Syntax_Syntax.Meta t1, FStarC_Syntax_Syntax.Meta t2) -> + equal_term t1 t2 + | uu___ -> false +and (equal_branch : + (FStarC_Syntax_Syntax.pat' FStarC_Syntax_Syntax.withinfo_t * + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax + FStar_Pervasives_Native.option * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax) -> + (FStarC_Syntax_Syntax.pat' FStarC_Syntax_Syntax.withinfo_t * + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax + FStar_Pervasives_Native.option * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax) -> Prims.bool) + = + fun uu___ -> + fun uu___1 -> + match (uu___, uu___1) with + | ((p1, w1, t1), (p2, w2, t2)) -> + ((equal_pat p1 p2) && (equal_opt equal_term w1 w2)) && + (equal_term t1 t2) +and (equal_pat : + FStarC_Syntax_Syntax.pat' FStarC_Syntax_Syntax.withinfo_t -> + FStarC_Syntax_Syntax.pat' FStarC_Syntax_Syntax.withinfo_t -> Prims.bool) + = + fun p1 -> + fun p2 -> + let uu___ = FStarC_Compiler_Util.physical_equality p1 p2 in + if uu___ + then true + else + (match ((p1.FStarC_Syntax_Syntax.v), (p2.FStarC_Syntax_Syntax.v)) + with + | (FStarC_Syntax_Syntax.Pat_constant c1, + FStarC_Syntax_Syntax.Pat_constant c2) -> equal_constant c1 c2 + | (FStarC_Syntax_Syntax.Pat_cons (fv1, us1, args1), + FStarC_Syntax_Syntax.Pat_cons (fv2, us2, args2)) -> + ((equal_fv fv1 fv2) && + (equal_opt (equal_list equal_universe) us1 us2)) + && (equal_list (equal_pair equal_pat equal_poly) args1 args2) + | (FStarC_Syntax_Syntax.Pat_var bv1, FStarC_Syntax_Syntax.Pat_var + bv2) -> equal_bv bv1 bv2 + | (FStarC_Syntax_Syntax.Pat_dot_term t1, + FStarC_Syntax_Syntax.Pat_dot_term t2) -> + equal_opt equal_term t1 t2 + | uu___2 -> false) +and (equal_meta : + FStarC_Syntax_Syntax.metadata -> + FStarC_Syntax_Syntax.metadata -> Prims.bool) + = + fun m1 -> + fun m2 -> + match (m1, m2) with + | (FStarC_Syntax_Syntax.Meta_pattern (ts1, args1), + FStarC_Syntax_Syntax.Meta_pattern (ts2, args2)) -> + (equal_list equal_term ts1 ts2) && + (equal_list (equal_list equal_arg) args1 args2) + | (FStarC_Syntax_Syntax.Meta_named l1, FStarC_Syntax_Syntax.Meta_named + l2) -> FStarC_Ident.lid_equals l1 l2 + | (FStarC_Syntax_Syntax.Meta_labeled (s1, r1, uu___), + FStarC_Syntax_Syntax.Meta_labeled (s2, r2, uu___1)) -> + (s1 = s2) && + (let uu___2 = FStarC_Compiler_Range_Ops.compare r1 r2 in + uu___2 = Prims.int_zero) + | (FStarC_Syntax_Syntax.Meta_desugared msi1, + FStarC_Syntax_Syntax.Meta_desugared msi2) -> msi1 = msi2 + | (FStarC_Syntax_Syntax.Meta_monadic (m11, t1), + FStarC_Syntax_Syntax.Meta_monadic (m21, t2)) -> + (FStarC_Ident.lid_equals m11 m21) && (equal_term t1 t2) + | (FStarC_Syntax_Syntax.Meta_monadic_lift (m11, n1, t1), + FStarC_Syntax_Syntax.Meta_monadic_lift (m21, n2, t2)) -> + ((FStarC_Ident.lid_equals m11 m21) && + (FStarC_Ident.lid_equals n1 n2)) + && (equal_term t1 t2) +and (equal_lazyinfo : + FStarC_Syntax_Syntax.lazyinfo -> + FStarC_Syntax_Syntax.lazyinfo -> Prims.bool) + = + fun l1 -> + fun l2 -> + FStarC_Compiler_Util.physical_equality l1.FStarC_Syntax_Syntax.blob + l2.FStarC_Syntax_Syntax.blob +and (equal_quoteinfo : + FStarC_Syntax_Syntax.quoteinfo -> + FStarC_Syntax_Syntax.quoteinfo -> Prims.bool) + = + fun q1 -> + fun q2 -> + ((q1.FStarC_Syntax_Syntax.qkind = q2.FStarC_Syntax_Syntax.qkind) && + ((FStar_Pervasives_Native.fst q1.FStarC_Syntax_Syntax.antiquotations) + = + (FStar_Pervasives_Native.fst + q2.FStarC_Syntax_Syntax.antiquotations))) + && + (equal_list equal_term + (FStar_Pervasives_Native.snd + q1.FStarC_Syntax_Syntax.antiquotations) + (FStar_Pervasives_Native.snd + q2.FStarC_Syntax_Syntax.antiquotations)) +and (equal_rc : + FStarC_Syntax_Syntax.residual_comp -> + FStarC_Syntax_Syntax.residual_comp -> Prims.bool) + = + fun r1 -> + fun r2 -> + ((FStarC_Ident.lid_equals r1.FStarC_Syntax_Syntax.residual_effect + r2.FStarC_Syntax_Syntax.residual_effect) + && + (equal_opt equal_term r1.FStarC_Syntax_Syntax.residual_typ + r2.FStarC_Syntax_Syntax.residual_typ)) + && + (equal_list equal_flag r1.FStarC_Syntax_Syntax.residual_flags + r2.FStarC_Syntax_Syntax.residual_flags) +and (equal_flag : + FStarC_Syntax_Syntax.cflag -> FStarC_Syntax_Syntax.cflag -> Prims.bool) = + fun f1 -> + fun f2 -> + match (f1, f2) with + | (FStarC_Syntax_Syntax.DECREASES t1, FStarC_Syntax_Syntax.DECREASES + t2) -> equal_decreases_order t1 t2 + | uu___ -> f1 = f2 +and (equal_decreases_order : + FStarC_Syntax_Syntax.decreases_order -> + FStarC_Syntax_Syntax.decreases_order -> Prims.bool) + = + fun d1 -> + fun d2 -> + match (d1, d2) with + | (FStarC_Syntax_Syntax.Decreases_lex ts1, + FStarC_Syntax_Syntax.Decreases_lex ts2) -> + equal_list equal_term ts1 ts2 + | (FStarC_Syntax_Syntax.Decreases_wf (t1, t1'), + FStarC_Syntax_Syntax.Decreases_wf (t2, t2')) -> + (equal_term t1 t2) && (equal_term t1' t2') +and (equal_arg_qualifier : + FStarC_Syntax_Syntax.arg_qualifier -> + FStarC_Syntax_Syntax.arg_qualifier -> Prims.bool) + = + fun a1 -> + fun a2 -> + (a1.FStarC_Syntax_Syntax.aqual_implicit = + a2.FStarC_Syntax_Syntax.aqual_implicit) + && + (equal_list equal_term a1.FStarC_Syntax_Syntax.aqual_attributes + a2.FStarC_Syntax_Syntax.aqual_attributes) +and (equal_lbname : + (FStarC_Syntax_Syntax.bv, FStarC_Syntax_Syntax.fv) FStar_Pervasives.either + -> + (FStarC_Syntax_Syntax.bv, FStarC_Syntax_Syntax.fv) + FStar_Pervasives.either -> Prims.bool) + = + fun l1 -> + fun l2 -> + match (l1, l2) with + | (FStar_Pervasives.Inl b1, FStar_Pervasives.Inl b2) -> + FStarC_Ident.ident_equals b1.FStarC_Syntax_Syntax.ppname + b2.FStarC_Syntax_Syntax.ppname + | (FStar_Pervasives.Inr f1, FStar_Pervasives.Inr f2) -> + FStarC_Ident.lid_equals + (f1.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + (f2.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v +and (equal_subst_elt : + FStarC_Syntax_Syntax.subst_elt -> + FStarC_Syntax_Syntax.subst_elt -> Prims.bool) + = + fun s1 -> + fun s2 -> + match (s1, s2) with + | (FStarC_Syntax_Syntax.DB (i1, bv1), FStarC_Syntax_Syntax.DB + (i2, bv2)) -> (i1 = i2) && (equal_bv bv1 bv2) + | (FStarC_Syntax_Syntax.NM (bv1, i1), FStarC_Syntax_Syntax.NM + (bv2, i2)) -> (i1 = i2) && (equal_bv bv1 bv2) + | (FStarC_Syntax_Syntax.NT (bv1, t1), FStarC_Syntax_Syntax.NT + (bv2, t2)) -> (equal_bv bv1 bv2) && (equal_term t1 t2) + | (FStarC_Syntax_Syntax.UN (i1, u1), FStarC_Syntax_Syntax.UN (i2, u2)) + -> (i1 = i2) && (equal_universe u1 u2) + | (FStarC_Syntax_Syntax.UD (un1, i1), FStarC_Syntax_Syntax.UD + (un2, i2)) -> (i1 = i2) && (FStarC_Ident.ident_equals un1 un2) +let (hashable_term : + FStarC_Syntax_Syntax.term FStarC_Class_Hashable.hashable) = + { FStarC_Class_Hashable.hash = ext_hash_term } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Syntax_InstFV.ml b/ocaml/fstar-lib/generated/FStarC_Syntax_InstFV.ml new file mode 100644 index 00000000000..e72c4fdc410 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Syntax_InstFV.ml @@ -0,0 +1,391 @@ +open Prims +type inst_t = + (FStarC_Ident.lident * FStarC_Syntax_Syntax.universes) Prims.list +let mk : + 'uuuuu 'uuuuu1 . + 'uuuuu FStarC_Syntax_Syntax.syntax -> + 'uuuuu1 -> 'uuuuu1 FStarC_Syntax_Syntax.syntax + = fun t -> fun s -> FStarC_Syntax_Syntax.mk s t.FStarC_Syntax_Syntax.pos +let rec (inst : + (FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.fv -> FStarC_Syntax_Syntax.term) + -> FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun s -> + fun t -> + let t1 = FStarC_Syntax_Subst.compress t in + let mk1 = mk t1 in + match t1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_delayed uu___ -> failwith "Impossible" + | FStarC_Syntax_Syntax.Tm_name uu___ -> t1 + | FStarC_Syntax_Syntax.Tm_uvar uu___ -> t1 + | FStarC_Syntax_Syntax.Tm_uvar uu___ -> t1 + | FStarC_Syntax_Syntax.Tm_type uu___ -> t1 + | FStarC_Syntax_Syntax.Tm_bvar uu___ -> t1 + | FStarC_Syntax_Syntax.Tm_constant uu___ -> t1 + | FStarC_Syntax_Syntax.Tm_quoted uu___ -> t1 + | FStarC_Syntax_Syntax.Tm_unknown -> t1 + | FStarC_Syntax_Syntax.Tm_uinst uu___ -> t1 + | FStarC_Syntax_Syntax.Tm_lazy uu___ -> t1 + | FStarC_Syntax_Syntax.Tm_fvar fv -> s t1 fv + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs; FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = lopt;_} + -> + let bs1 = inst_binders s bs in + let body1 = inst s body in + let uu___ = + let uu___1 = + let uu___2 = inst_lcomp_opt s lopt in + { + FStarC_Syntax_Syntax.bs = bs1; + FStarC_Syntax_Syntax.body = body1; + FStarC_Syntax_Syntax.rc_opt = uu___2 + } in + FStarC_Syntax_Syntax.Tm_abs uu___1 in + mk1 uu___ + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; FStarC_Syntax_Syntax.comp = c;_} + -> + let bs1 = inst_binders s bs in + let c1 = inst_comp s c in + mk1 + (FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 = bs1; + FStarC_Syntax_Syntax.comp = c1 + }) + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = bv; FStarC_Syntax_Syntax.phi = t2;_} -> + let bv1 = + let uu___ = inst s bv.FStarC_Syntax_Syntax.sort in + { + FStarC_Syntax_Syntax.ppname = (bv.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = (bv.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = uu___ + } in + let t3 = inst s t2 in + mk1 + (FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = bv1; FStarC_Syntax_Syntax.phi = t3 + }) + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = t2; FStarC_Syntax_Syntax.args = args;_} + -> + let uu___ = + let uu___1 = + let uu___2 = inst s t2 in + let uu___3 = inst_args s args in + { + FStarC_Syntax_Syntax.hd = uu___2; + FStarC_Syntax_Syntax.args = uu___3 + } in + FStarC_Syntax_Syntax.Tm_app uu___1 in + mk1 uu___ + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = t2; + FStarC_Syntax_Syntax.ret_opt = asc_opt; + FStarC_Syntax_Syntax.brs = pats; + FStarC_Syntax_Syntax.rc_opt1 = lopt;_} + -> + let pats1 = + FStarC_Compiler_List.map + (fun uu___ -> + match uu___ with + | (p, wopt, t3) -> + let wopt1 = + match wopt with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some w -> + let uu___1 = inst s w in + FStar_Pervasives_Native.Some uu___1 in + let t4 = inst s t3 in (p, wopt1, t4)) pats in + let asc_opt1 = + match asc_opt with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (b, asc) -> + let uu___ = + let uu___1 = inst_binder s b in + let uu___2 = inst_ascription s asc in (uu___1, uu___2) in + FStar_Pervasives_Native.Some uu___ in + let uu___ = + let uu___1 = + let uu___2 = inst s t2 in + let uu___3 = inst_lcomp_opt s lopt in + { + FStarC_Syntax_Syntax.scrutinee = uu___2; + FStarC_Syntax_Syntax.ret_opt = asc_opt1; + FStarC_Syntax_Syntax.brs = pats1; + FStarC_Syntax_Syntax.rc_opt1 = uu___3 + } in + FStarC_Syntax_Syntax.Tm_match uu___1 in + mk1 uu___ + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t11; FStarC_Syntax_Syntax.asc = asc; + FStarC_Syntax_Syntax.eff_opt = f;_} + -> + let uu___ = + let uu___1 = + let uu___2 = inst s t11 in + let uu___3 = inst_ascription s asc in + { + FStarC_Syntax_Syntax.tm = uu___2; + FStarC_Syntax_Syntax.asc = uu___3; + FStarC_Syntax_Syntax.eff_opt = f + } in + FStarC_Syntax_Syntax.Tm_ascribed uu___1 in + mk1 uu___ + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = lbs; + FStarC_Syntax_Syntax.body1 = t2;_} + -> + let lbs1 = + let uu___ = + FStarC_Compiler_List.map + (fun lb -> + let uu___1 = inst s lb.FStarC_Syntax_Syntax.lbtyp in + let uu___2 = inst s lb.FStarC_Syntax_Syntax.lbdef in + { + FStarC_Syntax_Syntax.lbname = + (lb.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = uu___1; + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = uu___2; + FStarC_Syntax_Syntax.lbattrs = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + }) (FStar_Pervasives_Native.snd lbs) in + ((FStar_Pervasives_Native.fst lbs), uu___) in + let uu___ = + let uu___1 = + let uu___2 = inst s t2 in + { + FStarC_Syntax_Syntax.lbs = lbs1; + FStarC_Syntax_Syntax.body1 = uu___2 + } in + FStarC_Syntax_Syntax.Tm_let uu___1 in + mk1 uu___ + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t2; + FStarC_Syntax_Syntax.meta = FStarC_Syntax_Syntax.Meta_pattern + (bvs, args);_} + -> + let uu___ = + let uu___1 = + let uu___2 = inst s t2 in + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Compiler_List.map (inst_args s) args in + (bvs, uu___5) in + FStarC_Syntax_Syntax.Meta_pattern uu___4 in + { + FStarC_Syntax_Syntax.tm2 = uu___2; + FStarC_Syntax_Syntax.meta = uu___3 + } in + FStarC_Syntax_Syntax.Tm_meta uu___1 in + mk1 uu___ + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t2; + FStarC_Syntax_Syntax.meta = FStarC_Syntax_Syntax.Meta_monadic + (m, t');_} + -> + let uu___ = + let uu___1 = + let uu___2 = inst s t2 in + let uu___3 = + let uu___4 = let uu___5 = inst s t' in (m, uu___5) in + FStarC_Syntax_Syntax.Meta_monadic uu___4 in + { + FStarC_Syntax_Syntax.tm2 = uu___2; + FStarC_Syntax_Syntax.meta = uu___3 + } in + FStarC_Syntax_Syntax.Tm_meta uu___1 in + mk1 uu___ + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t2; FStarC_Syntax_Syntax.meta = tag;_} + -> + let uu___ = + let uu___1 = + let uu___2 = inst s t2 in + { + FStarC_Syntax_Syntax.tm2 = uu___2; + FStarC_Syntax_Syntax.meta = tag + } in + FStarC_Syntax_Syntax.Tm_meta uu___1 in + mk1 uu___ +and (inst_binder : + (FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.fv -> FStarC_Syntax_Syntax.term) + -> FStarC_Syntax_Syntax.binder -> FStarC_Syntax_Syntax.binder) + = + fun s -> + fun b -> + let uu___ = + let uu___1 = b.FStarC_Syntax_Syntax.binder_bv in + let uu___2 = + inst s (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + { + FStarC_Syntax_Syntax.ppname = (uu___1.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = (uu___1.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = uu___2 + } in + let uu___1 = + FStarC_Compiler_List.map (inst s) b.FStarC_Syntax_Syntax.binder_attrs in + { + FStarC_Syntax_Syntax.binder_bv = uu___; + FStarC_Syntax_Syntax.binder_qual = + (b.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity = + (b.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs = uu___1 + } +and (inst_binders : + (FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.fv -> FStarC_Syntax_Syntax.term) + -> FStarC_Syntax_Syntax.binders -> FStarC_Syntax_Syntax.binders) + = fun s -> fun bs -> FStarC_Compiler_List.map (inst_binder s) bs +and (inst_args : + (FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.fv -> FStarC_Syntax_Syntax.term) + -> + (FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax * + FStarC_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) + Prims.list -> + (FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax * + FStarC_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) + Prims.list) + = + fun s -> + fun args -> + FStarC_Compiler_List.map + (fun uu___ -> + match uu___ with + | (a, imp) -> let uu___1 = inst s a in (uu___1, imp)) args +and (inst_comp : + (FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.fv -> FStarC_Syntax_Syntax.term) + -> + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax) + = + fun s -> + fun c -> + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total t -> + let uu___ = inst s t in FStarC_Syntax_Syntax.mk_Total uu___ + | FStarC_Syntax_Syntax.GTotal t -> + let uu___ = inst s t in FStarC_Syntax_Syntax.mk_GTotal uu___ + | FStarC_Syntax_Syntax.Comp ct -> + let ct1 = + let uu___ = inst s ct.FStarC_Syntax_Syntax.result_typ in + let uu___1 = inst_args s ct.FStarC_Syntax_Syntax.effect_args in + let uu___2 = + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with + | FStarC_Syntax_Syntax.DECREASES dec_order -> + let uu___4 = inst_decreases_order s dec_order in + FStarC_Syntax_Syntax.DECREASES uu___4 + | f -> f) ct.FStarC_Syntax_Syntax.flags in + { + FStarC_Syntax_Syntax.comp_univs = + (ct.FStarC_Syntax_Syntax.comp_univs); + FStarC_Syntax_Syntax.effect_name = + (ct.FStarC_Syntax_Syntax.effect_name); + FStarC_Syntax_Syntax.result_typ = uu___; + FStarC_Syntax_Syntax.effect_args = uu___1; + FStarC_Syntax_Syntax.flags = uu___2 + } in + FStarC_Syntax_Syntax.mk_Comp ct1 +and (inst_decreases_order : + (FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.fv -> FStarC_Syntax_Syntax.term) + -> + FStarC_Syntax_Syntax.decreases_order -> + FStarC_Syntax_Syntax.decreases_order) + = + fun s -> + fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.Decreases_lex l -> + let uu___1 = FStarC_Compiler_List.map (inst s) l in + FStarC_Syntax_Syntax.Decreases_lex uu___1 + | FStarC_Syntax_Syntax.Decreases_wf (rel, e) -> + let uu___1 = + let uu___2 = inst s rel in + let uu___3 = inst s e in (uu___2, uu___3) in + FStarC_Syntax_Syntax.Decreases_wf uu___1 +and (inst_lcomp_opt : + (FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.fv -> FStarC_Syntax_Syntax.term) + -> + FStarC_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option) + = + fun s -> + fun l -> + match l with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some rc -> + let uu___ = + let uu___1 = + FStarC_Compiler_Util.map_opt + rc.FStarC_Syntax_Syntax.residual_typ (inst s) in + { + FStarC_Syntax_Syntax.residual_effect = + (rc.FStarC_Syntax_Syntax.residual_effect); + FStarC_Syntax_Syntax.residual_typ = uu___1; + FStarC_Syntax_Syntax.residual_flags = + (rc.FStarC_Syntax_Syntax.residual_flags) + } in + FStar_Pervasives_Native.Some uu___ +and (inst_ascription : + (FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.fv -> FStarC_Syntax_Syntax.term) + -> + FStarC_Syntax_Syntax.ascription -> + ((FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax, + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax) + FStar_Pervasives.either * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax FStar_Pervasives_Native.option * + Prims.bool)) + = + fun s -> + fun asc -> + let uu___ = asc in + match uu___ with + | (annot, topt, use_eq) -> + let annot1 = + match annot with + | FStar_Pervasives.Inl t -> + let uu___1 = inst s t in FStar_Pervasives.Inl uu___1 + | FStar_Pervasives.Inr c -> + let uu___1 = inst_comp s c in FStar_Pervasives.Inr uu___1 in + let topt1 = FStarC_Compiler_Util.map_opt topt (inst s) in + (annot1, topt1, use_eq) +let (instantiate : + inst_t -> FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) = + fun i -> + fun t -> + match i with + | [] -> t + | uu___ -> + let inst_fv t1 fv = + let uu___1 = + FStarC_Compiler_Util.find_opt + (fun uu___2 -> + match uu___2 with + | (x, uu___3) -> + FStarC_Ident.lid_equals x + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v) + i in + match uu___1 with + | FStar_Pervasives_Native.None -> t1 + | FStar_Pervasives_Native.Some (uu___2, us) -> + mk t1 (FStarC_Syntax_Syntax.Tm_uinst (t1, us)) in + inst inst_fv t \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Syntax_MutRecTy.ml b/ocaml/fstar-lib/generated/FStarC_Syntax_MutRecTy.ml new file mode 100644 index 00000000000..84ab48511b8 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Syntax_MutRecTy.ml @@ -0,0 +1,462 @@ +open Prims +let (disentangle_abbrevs_from_bundle : + FStarC_Syntax_Syntax.sigelt Prims.list -> + FStarC_Syntax_Syntax.qualifier Prims.list -> + FStarC_Ident.lident Prims.list -> + FStarC_Compiler_Range_Type.range -> + (FStarC_Syntax_Syntax.sigelt * FStarC_Syntax_Syntax.sigelt + Prims.list)) + = + fun sigelts -> + fun quals -> + fun members -> + fun rng -> + let sigattrs = + FStarC_Compiler_List.collect + (fun s -> + match s.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_inductive_typ uu___ -> + s.FStarC_Syntax_Syntax.sigattrs + | FStarC_Syntax_Syntax.Sig_let uu___ -> + s.FStarC_Syntax_Syntax.sigattrs + | uu___ -> []) sigelts in + let sigattrs1 = FStarC_Syntax_Util.deduplicate_terms sigattrs in + let type_abbrev_sigelts = + FStarC_Compiler_List.collect + (fun x -> + match x.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_let + { + FStarC_Syntax_Syntax.lbs1 = + (false, + { + FStarC_Syntax_Syntax.lbname = + FStar_Pervasives.Inr uu___; + FStarC_Syntax_Syntax.lbunivs = uu___1; + FStarC_Syntax_Syntax.lbtyp = uu___2; + FStarC_Syntax_Syntax.lbeff = uu___3; + FStarC_Syntax_Syntax.lbdef = uu___4; + FStarC_Syntax_Syntax.lbattrs = uu___5; + FStarC_Syntax_Syntax.lbpos = uu___6;_}::[]); + FStarC_Syntax_Syntax.lids1 = uu___7;_} + -> [x] + | FStarC_Syntax_Syntax.Sig_let uu___ -> + failwith + "mutrecty: disentangle_abbrevs_from_bundle: type_abbrev_sigelts: impossible" + | uu___ -> []) sigelts in + match type_abbrev_sigelts with + | [] -> + ({ + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_bundle + { + FStarC_Syntax_Syntax.ses = sigelts; + FStarC_Syntax_Syntax.lids = members + }); + FStarC_Syntax_Syntax.sigrng = rng; + FStarC_Syntax_Syntax.sigquals = quals; + FStarC_Syntax_Syntax.sigmeta = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs = sigattrs1; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = []; + FStarC_Syntax_Syntax.sigopts = FStar_Pervasives_Native.None + }, []) + | uu___ -> + let type_abbrevs = + FStarC_Compiler_List.map + (fun x -> + match x.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_let + { + FStarC_Syntax_Syntax.lbs1 = + (uu___1, + { + FStarC_Syntax_Syntax.lbname = + FStar_Pervasives.Inr fv; + FStarC_Syntax_Syntax.lbunivs = uu___2; + FStarC_Syntax_Syntax.lbtyp = uu___3; + FStarC_Syntax_Syntax.lbeff = uu___4; + FStarC_Syntax_Syntax.lbdef = uu___5; + FStarC_Syntax_Syntax.lbattrs = uu___6; + FStarC_Syntax_Syntax.lbpos = uu___7;_}::[]); + FStarC_Syntax_Syntax.lids1 = uu___8;_} + -> + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + | uu___1 -> + failwith + "mutrecty: disentangle_abbrevs_from_bundle: type_abbrevs: impossible") + type_abbrev_sigelts in + let unfolded_type_abbrevs = + let rev_unfolded_type_abbrevs = + FStarC_Compiler_Util.mk_ref [] in + let in_progress = FStarC_Compiler_Util.mk_ref [] in + let not_unfolded_yet = + FStarC_Compiler_Util.mk_ref type_abbrev_sigelts in + let remove_not_unfolded lid = + let uu___1 = + let uu___2 = + FStarC_Compiler_Effect.op_Bang not_unfolded_yet in + FStarC_Compiler_List.filter + (fun x -> + match x.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_let + { + FStarC_Syntax_Syntax.lbs1 = + (uu___3, + { + FStarC_Syntax_Syntax.lbname = + FStar_Pervasives.Inr fv; + FStarC_Syntax_Syntax.lbunivs = uu___4; + FStarC_Syntax_Syntax.lbtyp = uu___5; + FStarC_Syntax_Syntax.lbeff = uu___6; + FStarC_Syntax_Syntax.lbdef = uu___7; + FStarC_Syntax_Syntax.lbattrs = uu___8; + FStarC_Syntax_Syntax.lbpos = uu___9;_}::[]); + FStarC_Syntax_Syntax.lids1 = uu___10;_} + -> + let uu___11 = + FStarC_Ident.lid_equals lid + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + Prims.op_Negation uu___11 + | uu___3 -> true) uu___2 in + FStarC_Compiler_Effect.op_Colon_Equals not_unfolded_yet + uu___1 in + let rec unfold_abbrev_fv t fv = + let replacee x = + match x.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_let + { + FStarC_Syntax_Syntax.lbs1 = + (uu___1, + { + FStarC_Syntax_Syntax.lbname = + FStar_Pervasives.Inr fv'; + FStarC_Syntax_Syntax.lbunivs = uu___2; + FStarC_Syntax_Syntax.lbtyp = uu___3; + FStarC_Syntax_Syntax.lbeff = uu___4; + FStarC_Syntax_Syntax.lbdef = uu___5; + FStarC_Syntax_Syntax.lbattrs = uu___6; + FStarC_Syntax_Syntax.lbpos = uu___7;_}::[]); + FStarC_Syntax_Syntax.lids1 = uu___8;_} + when + FStarC_Ident.lid_equals + (fv'.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + -> FStar_Pervasives_Native.Some x + | uu___1 -> FStar_Pervasives_Native.None in + let replacee_term x = + match replacee x with + | FStar_Pervasives_Native.Some + { + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_let + { + FStarC_Syntax_Syntax.lbs1 = + (uu___1, + { FStarC_Syntax_Syntax.lbname = uu___2; + FStarC_Syntax_Syntax.lbunivs = uu___3; + FStarC_Syntax_Syntax.lbtyp = uu___4; + FStarC_Syntax_Syntax.lbeff = uu___5; + FStarC_Syntax_Syntax.lbdef = tm; + FStarC_Syntax_Syntax.lbattrs = uu___6; + FStarC_Syntax_Syntax.lbpos = uu___7;_}::[]); + FStarC_Syntax_Syntax.lids1 = uu___8;_}; + FStarC_Syntax_Syntax.sigrng = uu___9; + FStarC_Syntax_Syntax.sigquals = uu___10; + FStarC_Syntax_Syntax.sigmeta = uu___11; + FStarC_Syntax_Syntax.sigattrs = uu___12; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___13; + FStarC_Syntax_Syntax.sigopts = uu___14;_} + -> FStar_Pervasives_Native.Some tm + | uu___1 -> FStar_Pervasives_Native.None in + let uu___1 = + let uu___2 = + FStarC_Compiler_Effect.op_Bang + rev_unfolded_type_abbrevs in + FStarC_Compiler_Util.find_map uu___2 replacee_term in + match uu___1 with + | FStar_Pervasives_Native.Some x -> x + | FStar_Pervasives_Native.None -> + let uu___2 = + FStarC_Compiler_Util.find_map type_abbrev_sigelts + replacee in + (match uu___2 with + | FStar_Pervasives_Native.Some se -> + let uu___3 = + let uu___4 = + FStarC_Compiler_Effect.op_Bang in_progress in + FStarC_Compiler_List.existsb + (fun x -> + FStarC_Ident.lid_equals x + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v) + uu___4 in + if uu___3 + then + let msg = + let uu___4 = + FStarC_Ident.string_of_lid + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + FStarC_Compiler_Util.format1 + "Cycle on %s in mutually recursive type abbreviations" + uu___4 in + FStarC_Errors.raise_error + FStarC_Ident.hasrange_lident + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + FStarC_Errors_Codes.Fatal_CycleInRecTypeAbbreviation + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic msg) + else unfold_abbrev se + | uu___3 -> t) + and unfold_abbrev x = + match x.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (false, lb::[]); + FStarC_Syntax_Syntax.lids1 = uu___1;_} + -> + let quals1 = + FStarC_Compiler_List.filter + (fun uu___2 -> + match uu___2 with + | FStarC_Syntax_Syntax.Noeq -> false + | uu___3 -> true) + x.FStarC_Syntax_Syntax.sigquals in + let lid = + match lb.FStarC_Syntax_Syntax.lbname with + | FStar_Pervasives.Inr fv -> + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + | uu___2 -> + failwith + "mutrecty: disentangle_abbrevs_from_bundle: rename_abbrev: lid: impossible" in + ((let uu___3 = + let uu___4 = + FStarC_Compiler_Effect.op_Bang in_progress in + lid :: uu___4 in + FStarC_Compiler_Effect.op_Colon_Equals in_progress + uu___3); + (match () with + | () -> + (remove_not_unfolded lid; + (match () with + | () -> + let ty' = + FStarC_Syntax_InstFV.inst + unfold_abbrev_fv + lb.FStarC_Syntax_Syntax.lbtyp in + let tm' = + FStarC_Syntax_InstFV.inst + unfold_abbrev_fv + lb.FStarC_Syntax_Syntax.lbdef in + let lb' = + { + FStarC_Syntax_Syntax.lbname = + (lb.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = ty'; + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = tm'; + FStarC_Syntax_Syntax.lbattrs = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + } in + let sigelt' = + FStarC_Syntax_Syntax.Sig_let + { + FStarC_Syntax_Syntax.lbs1 = + (false, [lb']); + FStarC_Syntax_Syntax.lids1 = [lid] + } in + ((let uu___5 = + let uu___6 = + FStarC_Compiler_Effect.op_Bang + rev_unfolded_type_abbrevs in + { + FStarC_Syntax_Syntax.sigel = sigelt'; + FStarC_Syntax_Syntax.sigrng = + (x.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + quals1; + FStarC_Syntax_Syntax.sigmeta = + (x.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (x.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = + (x.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (x.FStarC_Syntax_Syntax.sigopts) + } :: uu___6 in + FStarC_Compiler_Effect.op_Colon_Equals + rev_unfolded_type_abbrevs uu___5); + (match () with + | () -> + ((let uu___6 = + let uu___7 = + FStarC_Compiler_Effect.op_Bang + in_progress in + FStarC_Compiler_List.tl uu___7 in + FStarC_Compiler_Effect.op_Colon_Equals + in_progress uu___6); + (match () with | () -> tm')))))))) + | uu___1 -> + failwith + "mutrecty: disentangle_abbrevs_from_bundle: rename_abbrev: impossible" in + let rec aux uu___1 = + let uu___2 = + FStarC_Compiler_Effect.op_Bang not_unfolded_yet in + match uu___2 with + | x::uu___3 -> let _unused = unfold_abbrev x in aux () + | uu___3 -> + let uu___4 = + FStarC_Compiler_Effect.op_Bang + rev_unfolded_type_abbrevs in + FStarC_Compiler_List.rev uu___4 in + aux () in + let filter_out_type_abbrevs l = + FStarC_Compiler_List.filter + (fun lid -> + FStarC_Compiler_List.for_all + (fun lid' -> + let uu___1 = FStarC_Ident.lid_equals lid lid' in + Prims.op_Negation uu___1) type_abbrevs) l in + let inductives_with_abbrevs_unfolded = + let find_in_unfolded fv = + FStarC_Compiler_Util.find_map unfolded_type_abbrevs + (fun x -> + match x.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_let + { + FStarC_Syntax_Syntax.lbs1 = + (uu___1, + { + FStarC_Syntax_Syntax.lbname = + FStar_Pervasives.Inr fv'; + FStarC_Syntax_Syntax.lbunivs = uu___2; + FStarC_Syntax_Syntax.lbtyp = uu___3; + FStarC_Syntax_Syntax.lbeff = uu___4; + FStarC_Syntax_Syntax.lbdef = tm; + FStarC_Syntax_Syntax.lbattrs = uu___5; + FStarC_Syntax_Syntax.lbpos = uu___6;_}::[]); + FStarC_Syntax_Syntax.lids1 = uu___7;_} + when + FStarC_Ident.lid_equals + (fv'.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + -> FStar_Pervasives_Native.Some tm + | uu___1 -> FStar_Pervasives_Native.None) in + let unfold_fv t fv = + let uu___1 = find_in_unfolded fv in + match uu___1 with + | FStar_Pervasives_Native.Some t' -> t' + | uu___2 -> t in + let unfold_in_sig x = + match x.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = lid; + FStarC_Syntax_Syntax.us = univs; + FStarC_Syntax_Syntax.params = bnd; + FStarC_Syntax_Syntax.num_uniform_params = num_uniform; + FStarC_Syntax_Syntax.t = ty; + FStarC_Syntax_Syntax.mutuals = mut; + FStarC_Syntax_Syntax.ds = dc; + FStarC_Syntax_Syntax.injective_type_params = + injective_type_params;_} + -> + let bnd' = + FStarC_Syntax_InstFV.inst_binders unfold_fv bnd in + let ty' = FStarC_Syntax_InstFV.inst unfold_fv ty in + let mut' = filter_out_type_abbrevs mut in + [{ + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_inductive_typ + { + FStarC_Syntax_Syntax.lid = lid; + FStarC_Syntax_Syntax.us = univs; + FStarC_Syntax_Syntax.params = bnd'; + FStarC_Syntax_Syntax.num_uniform_params = + num_uniform; + FStarC_Syntax_Syntax.t = ty'; + FStarC_Syntax_Syntax.mutuals = mut'; + FStarC_Syntax_Syntax.ds = dc; + FStarC_Syntax_Syntax.injective_type_params = + injective_type_params + }); + FStarC_Syntax_Syntax.sigrng = + (x.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (x.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (x.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (x.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (x.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (x.FStarC_Syntax_Syntax.sigopts) + }] + | FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = lid; + FStarC_Syntax_Syntax.us1 = univs; + FStarC_Syntax_Syntax.t1 = ty; + FStarC_Syntax_Syntax.ty_lid = res; + FStarC_Syntax_Syntax.num_ty_params = npars; + FStarC_Syntax_Syntax.mutuals1 = mut; + FStarC_Syntax_Syntax.injective_type_params1 = + injective_type_params;_} + -> + let ty' = FStarC_Syntax_InstFV.inst unfold_fv ty in + let mut' = filter_out_type_abbrevs mut in + [{ + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_datacon + { + FStarC_Syntax_Syntax.lid1 = lid; + FStarC_Syntax_Syntax.us1 = univs; + FStarC_Syntax_Syntax.t1 = ty'; + FStarC_Syntax_Syntax.ty_lid = res; + FStarC_Syntax_Syntax.num_ty_params = npars; + FStarC_Syntax_Syntax.mutuals1 = mut'; + FStarC_Syntax_Syntax.injective_type_params1 = + injective_type_params + }); + FStarC_Syntax_Syntax.sigrng = + (x.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (x.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (x.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (x.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (x.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (x.FStarC_Syntax_Syntax.sigopts) + }] + | FStarC_Syntax_Syntax.Sig_let uu___1 -> [] + | uu___1 -> + failwith + "mutrecty: inductives_with_abbrevs_unfolded: unfold_in_sig: impossible" in + FStarC_Compiler_List.collect unfold_in_sig sigelts in + let new_members = filter_out_type_abbrevs members in + let new_bundle = + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_bundle + { + FStarC_Syntax_Syntax.ses = + inductives_with_abbrevs_unfolded; + FStarC_Syntax_Syntax.lids = new_members + }); + FStarC_Syntax_Syntax.sigrng = rng; + FStarC_Syntax_Syntax.sigquals = quals; + FStarC_Syntax_Syntax.sigmeta = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs = sigattrs1; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = []; + FStarC_Syntax_Syntax.sigopts = FStar_Pervasives_Native.None + } in + (new_bundle, unfolded_type_abbrevs) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Syntax_Print.ml b/ocaml/fstar-lib/generated/FStarC_Syntax_Print.ml new file mode 100644 index 00000000000..98e9df4edab --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Syntax_Print.ml @@ -0,0 +1,966 @@ +open Prims +let (sli : FStarC_Ident.lident -> Prims.string) = + fun l -> + let uu___ = FStarC_Options.print_real_names () in + if uu___ + then FStarC_Ident.string_of_lid l + else + (let uu___2 = FStarC_Ident.ident_of_lid l in + FStarC_Ident.string_of_id uu___2) +let (lid_to_string : FStarC_Ident.lid -> Prims.string) = fun l -> sli l +let (fv_to_string : FStarC_Syntax_Syntax.fv -> Prims.string) = + fun fv -> + lid_to_string (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v +let (bv_to_string : FStarC_Syntax_Syntax.bv -> Prims.string) = + fun bv -> + let uu___ = FStarC_Options.print_real_names () in + if uu___ + then + let uu___1 = + FStarC_Class_Show.show FStarC_Ident.showable_ident + bv.FStarC_Syntax_Syntax.ppname in + let uu___2 = + let uu___3 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + bv.FStarC_Syntax_Syntax.index in + Prims.strcat "#" uu___3 in + Prims.strcat uu___1 uu___2 + else + FStarC_Class_Show.show FStarC_Ident.showable_ident + bv.FStarC_Syntax_Syntax.ppname +let (nm_to_string : FStarC_Syntax_Syntax.bv -> Prims.string) = + fun bv -> + let uu___ = FStarC_Options.print_real_names () in + if uu___ + then bv_to_string bv + else FStarC_Ident.string_of_id bv.FStarC_Syntax_Syntax.ppname +let (db_to_string : FStarC_Syntax_Syntax.bv -> Prims.string) = + fun bv -> + let uu___ = FStarC_Ident.string_of_id bv.FStarC_Syntax_Syntax.ppname in + let uu___1 = + let uu___2 = + FStarC_Compiler_Util.string_of_int bv.FStarC_Syntax_Syntax.index in + Prims.strcat "@" uu___2 in + Prims.strcat uu___ uu___1 +let (filter_imp : + FStarC_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> + Prims.bool) + = + fun aq -> + match aq with + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Meta t) when + FStarC_Syntax_Util.is_fvar FStarC_Parser_Const.tcresolve_lid t -> + true + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Implicit uu___) -> + false + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Meta uu___) -> false + | uu___ -> true +let filter_imp_args : + 'uuuuu . + ('uuuuu * FStarC_Syntax_Syntax.arg_qualifier + FStar_Pervasives_Native.option) Prims.list -> + ('uuuuu * FStarC_Syntax_Syntax.arg_qualifier + FStar_Pervasives_Native.option) Prims.list + = + fun args -> + FStarC_Compiler_List.filter + (fun uu___ -> + match uu___ with + | (uu___1, FStar_Pervasives_Native.None) -> true + | (uu___1, FStar_Pervasives_Native.Some a) -> + Prims.op_Negation a.FStarC_Syntax_Syntax.aqual_implicit) args +let (filter_imp_binders : + FStarC_Syntax_Syntax.binder Prims.list -> + FStarC_Syntax_Syntax.binder Prims.list) + = + fun bs -> + FStarC_Compiler_List.filter + (fun b -> filter_imp b.FStarC_Syntax_Syntax.binder_qual) bs +let (const_to_string : FStarC_Const.sconst -> Prims.string) = + FStarC_Parser_Const.const_to_string +let (lbname_to_string : + (FStarC_Syntax_Syntax.bv, FStarC_Syntax_Syntax.fv) FStar_Pervasives.either + -> Prims.string) + = + fun uu___ -> + match uu___ with + | FStar_Pervasives.Inl l -> bv_to_string l + | FStar_Pervasives.Inr l -> + lid_to_string (l.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v +let (uvar_to_string : FStarC_Syntax_Syntax.uvar -> Prims.string) = + fun u -> + let uu___ = FStarC_Options.hide_uvar_nums () in + if uu___ + then "?" + else + (let uu___2 = + let uu___3 = FStarC_Syntax_Unionfind.uvar_id u in + FStarC_Compiler_Util.string_of_int uu___3 in + Prims.strcat "?" uu___2) +let (version_to_string : FStarC_Syntax_Syntax.version -> Prims.string) = + fun v -> + let uu___ = + FStarC_Compiler_Util.string_of_int v.FStarC_Syntax_Syntax.major in + let uu___1 = + FStarC_Compiler_Util.string_of_int v.FStarC_Syntax_Syntax.minor in + FStarC_Compiler_Util.format2 "%s.%s" uu___ uu___1 +let (univ_uvar_to_string : + (FStarC_Syntax_Syntax.universe FStar_Pervasives_Native.option + FStarC_Unionfind.p_uvar * FStarC_Syntax_Syntax.version * + FStarC_Compiler_Range_Type.range) -> Prims.string) + = + fun u -> + let uu___ = FStarC_Options.hide_uvar_nums () in + if uu___ + then "?" + else + (let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Unionfind.univ_uvar_id u in + FStarC_Compiler_Util.string_of_int uu___4 in + let uu___4 = + let uu___5 = + match u with | (uu___6, u1, uu___7) -> version_to_string u1 in + Prims.strcat ":" uu___5 in + Prims.strcat uu___3 uu___4 in + Prims.strcat "?" uu___2) +let rec (int_of_univ : + Prims.int -> + FStarC_Syntax_Syntax.universe -> + (Prims.int * FStarC_Syntax_Syntax.universe + FStar_Pervasives_Native.option)) + = + fun n -> + fun u -> + let uu___ = FStarC_Syntax_Subst.compress_univ u in + match uu___ with + | FStarC_Syntax_Syntax.U_zero -> (n, FStar_Pervasives_Native.None) + | FStarC_Syntax_Syntax.U_succ u1 -> int_of_univ (n + Prims.int_one) u1 + | uu___1 -> (n, (FStar_Pervasives_Native.Some u)) +let rec (univ_to_string : FStarC_Syntax_Syntax.universe -> Prims.string) = + fun u -> + FStarC_Errors.with_ctx "While printing universe" + (fun uu___ -> + let uu___1 = FStarC_Syntax_Subst.compress_univ u in + match uu___1 with + | FStarC_Syntax_Syntax.U_unif u1 -> + let uu___2 = univ_uvar_to_string u1 in + Prims.strcat "U_unif " uu___2 + | FStarC_Syntax_Syntax.U_name x -> + let uu___2 = FStarC_Ident.string_of_id x in + Prims.strcat "U_name " uu___2 + | FStarC_Syntax_Syntax.U_bvar x -> + let uu___2 = FStarC_Compiler_Util.string_of_int x in + Prims.strcat "@" uu___2 + | FStarC_Syntax_Syntax.U_zero -> "0" + | FStarC_Syntax_Syntax.U_succ u1 -> + let uu___2 = int_of_univ Prims.int_one u1 in + (match uu___2 with + | (n, FStar_Pervasives_Native.None) -> + FStarC_Compiler_Util.string_of_int n + | (n, FStar_Pervasives_Native.Some u2) -> + let uu___3 = univ_to_string u2 in + let uu___4 = FStarC_Compiler_Util.string_of_int n in + FStarC_Compiler_Util.format2 "(%s + %s)" uu___3 uu___4) + | FStarC_Syntax_Syntax.U_max us -> + let uu___2 = + let uu___3 = FStarC_Compiler_List.map univ_to_string us in + FStarC_Compiler_String.concat ", " uu___3 in + FStarC_Compiler_Util.format1 "(max %s)" uu___2 + | FStarC_Syntax_Syntax.U_unknown -> "unknown") +let (univs_to_string : + FStarC_Syntax_Syntax.universe Prims.list -> Prims.string) = + fun us -> + let uu___ = FStarC_Compiler_List.map univ_to_string us in + FStarC_Compiler_String.concat ", " uu___ +let (qual_to_string : FStarC_Syntax_Syntax.qualifier -> Prims.string) = + fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.Assumption -> "assume" + | FStarC_Syntax_Syntax.InternalAssumption -> "internal_assume" + | FStarC_Syntax_Syntax.New -> "new" + | FStarC_Syntax_Syntax.Private -> "private" + | FStarC_Syntax_Syntax.Unfold_for_unification_and_vcgen -> "unfold" + | FStarC_Syntax_Syntax.Inline_for_extraction -> "inline_for_extraction" + | FStarC_Syntax_Syntax.NoExtract -> "noextract" + | FStarC_Syntax_Syntax.Visible_default -> "visible" + | FStarC_Syntax_Syntax.Irreducible -> "irreducible" + | FStarC_Syntax_Syntax.Noeq -> "noeq" + | FStarC_Syntax_Syntax.Unopteq -> "unopteq" + | FStarC_Syntax_Syntax.Logic -> "logic" + | FStarC_Syntax_Syntax.TotalEffect -> "total" + | FStarC_Syntax_Syntax.Discriminator l -> + let uu___1 = lid_to_string l in + FStarC_Compiler_Util.format1 "(Discriminator %s)" uu___1 + | FStarC_Syntax_Syntax.Projector (l, x) -> + let uu___1 = lid_to_string l in + let uu___2 = FStarC_Ident.string_of_id x in + FStarC_Compiler_Util.format2 "(Projector %s %s)" uu___1 uu___2 + | FStarC_Syntax_Syntax.RecordType (ns, fns) -> + let uu___1 = + let uu___2 = FStarC_Ident.path_of_ns ns in + FStarC_Ident.text_of_path uu___2 in + let uu___2 = + let uu___3 = FStarC_Compiler_List.map FStarC_Ident.string_of_id fns in + FStarC_Compiler_String.concat ", " uu___3 in + FStarC_Compiler_Util.format2 "(RecordType %s %s)" uu___1 uu___2 + | FStarC_Syntax_Syntax.RecordConstructor (ns, fns) -> + let uu___1 = + let uu___2 = FStarC_Ident.path_of_ns ns in + FStarC_Ident.text_of_path uu___2 in + let uu___2 = + let uu___3 = FStarC_Compiler_List.map FStarC_Ident.string_of_id fns in + FStarC_Compiler_String.concat ", " uu___3 in + FStarC_Compiler_Util.format2 "(RecordConstructor %s %s)" uu___1 + uu___2 + | FStarC_Syntax_Syntax.Action eff_lid -> + let uu___1 = lid_to_string eff_lid in + FStarC_Compiler_Util.format1 "(Action %s)" uu___1 + | FStarC_Syntax_Syntax.ExceptionConstructor -> "ExceptionConstructor" + | FStarC_Syntax_Syntax.HasMaskedEffect -> "HasMaskedEffect" + | FStarC_Syntax_Syntax.Effect -> "Effect" + | FStarC_Syntax_Syntax.Reifiable -> "reify" + | FStarC_Syntax_Syntax.Reflectable l -> + let uu___1 = FStarC_Ident.string_of_lid l in + FStarC_Compiler_Util.format1 "(reflect %s)" uu___1 + | FStarC_Syntax_Syntax.OnlyName -> "OnlyName" +let (quals_to_string : + FStarC_Syntax_Syntax.qualifier Prims.list -> Prims.string) = + fun quals -> + match quals with + | [] -> "" + | uu___ -> + let uu___1 = FStarC_Compiler_List.map qual_to_string quals in + FStarC_Compiler_String.concat " " uu___1 +let (quals_to_string' : + FStarC_Syntax_Syntax.qualifier Prims.list -> Prims.string) = + fun quals -> + match quals with + | [] -> "" + | uu___ -> let uu___1 = quals_to_string quals in Prims.strcat uu___1 " " +let (paren : Prims.string -> Prims.string) = + fun s -> Prims.strcat "(" (Prims.strcat s ")") +let (lkind_to_string : FStarC_Syntax_Syntax.lazy_kind -> Prims.string) = + fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.BadLazy -> "BadLazy" + | FStarC_Syntax_Syntax.Lazy_bv -> "Lazy_bv" + | FStarC_Syntax_Syntax.Lazy_namedv -> "Lazy_namedv" + | FStarC_Syntax_Syntax.Lazy_binder -> "Lazy_binder" + | FStarC_Syntax_Syntax.Lazy_optionstate -> "Lazy_optionstate" + | FStarC_Syntax_Syntax.Lazy_fvar -> "Lazy_fvar" + | FStarC_Syntax_Syntax.Lazy_comp -> "Lazy_comp" + | FStarC_Syntax_Syntax.Lazy_env -> "Lazy_env" + | FStarC_Syntax_Syntax.Lazy_proofstate -> "Lazy_proofstate" + | FStarC_Syntax_Syntax.Lazy_goal -> "Lazy_goal" + | FStarC_Syntax_Syntax.Lazy_sigelt -> "Lazy_sigelt" + | FStarC_Syntax_Syntax.Lazy_uvar -> "Lazy_uvar" + | FStarC_Syntax_Syntax.Lazy_letbinding -> "Lazy_letbinding" + | FStarC_Syntax_Syntax.Lazy_embedding (e, uu___1) -> + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Syntax.showable_emb_typ e in + Prims.strcat uu___3 ")" in + Prims.strcat "Lazy_embedding(" uu___2 + | FStarC_Syntax_Syntax.Lazy_universe -> "Lazy_universe" + | FStarC_Syntax_Syntax.Lazy_universe_uvar -> "Lazy_universe_uvar" + | FStarC_Syntax_Syntax.Lazy_issue -> "Lazy_issue" + | FStarC_Syntax_Syntax.Lazy_ident -> "Lazy_ident" + | FStarC_Syntax_Syntax.Lazy_doc -> "Lazy_doc" + | FStarC_Syntax_Syntax.Lazy_extension s -> + Prims.strcat "Lazy_extension:" s +let (term_to_string : FStarC_Syntax_Syntax.term -> Prims.string) = + fun x -> + let uu___ = FStarC_Options.ugly () in + if uu___ + then FStarC_Syntax_Print_Ugly.term_to_string x + else FStarC_Syntax_Print_Pretty.term_to_string x +let (term_to_string' : + FStarC_Syntax_DsEnv.env -> FStarC_Syntax_Syntax.term -> Prims.string) = + fun env -> + fun x -> + let uu___ = FStarC_Options.ugly () in + if uu___ + then FStarC_Syntax_Print_Ugly.term_to_string x + else FStarC_Syntax_Print_Pretty.term_to_string' env x +let (comp_to_string : FStarC_Syntax_Syntax.comp -> Prims.string) = + fun c -> + let uu___ = FStarC_Options.ugly () in + if uu___ + then FStarC_Syntax_Print_Ugly.comp_to_string c + else FStarC_Syntax_Print_Pretty.comp_to_string c +let (comp_to_string' : + FStarC_Syntax_DsEnv.env -> FStarC_Syntax_Syntax.comp -> Prims.string) = + fun env -> + fun c -> + let uu___ = FStarC_Options.ugly () in + if uu___ + then FStarC_Syntax_Print_Ugly.comp_to_string c + else FStarC_Syntax_Print_Pretty.comp_to_string' env c +let (sigelt_to_string : FStarC_Syntax_Syntax.sigelt -> Prims.string) = + fun x -> + let uu___ = FStarC_Options.ugly () in + if uu___ + then FStarC_Syntax_Print_Ugly.sigelt_to_string x + else FStarC_Syntax_Print_Pretty.sigelt_to_string x +let (sigelt_to_string' : + FStarC_Syntax_DsEnv.env -> FStarC_Syntax_Syntax.sigelt -> Prims.string) = + fun env -> + fun x -> + let uu___ = FStarC_Options.ugly () in + if uu___ + then FStarC_Syntax_Print_Ugly.sigelt_to_string x + else FStarC_Syntax_Print_Pretty.sigelt_to_string' env x +let (pat_to_string : FStarC_Syntax_Syntax.pat -> Prims.string) = + fun x -> + let uu___ = FStarC_Options.ugly () in + if uu___ + then FStarC_Syntax_Print_Ugly.pat_to_string x + else FStarC_Syntax_Print_Pretty.pat_to_string x +let (term_to_doc' : + FStarC_Syntax_DsEnv.env -> + FStarC_Syntax_Syntax.term -> FStarC_Pprint.document) + = + fun dsenv -> + fun t -> + let uu___ = FStarC_Options.ugly () in + if uu___ + then + let uu___1 = FStarC_Syntax_Print_Ugly.term_to_string t in + FStarC_Pprint.arbitrary_string uu___1 + else FStarC_Syntax_Print_Pretty.term_to_doc' dsenv t +let (univ_to_doc' : + FStarC_Syntax_DsEnv.env -> + FStarC_Syntax_Syntax.universe -> FStarC_Pprint.document) + = + fun dsenv -> + fun t -> + let uu___ = FStarC_Options.ugly () in + if uu___ + then + let uu___1 = FStarC_Syntax_Print_Ugly.univ_to_string t in + FStarC_Pprint.arbitrary_string uu___1 + else FStarC_Syntax_Print_Pretty.univ_to_doc' dsenv t +let (comp_to_doc' : + FStarC_Syntax_DsEnv.env -> + FStarC_Syntax_Syntax.comp -> FStarC_Pprint.document) + = + fun dsenv -> + fun t -> + let uu___ = FStarC_Options.ugly () in + if uu___ + then + let uu___1 = FStarC_Syntax_Print_Ugly.comp_to_string t in + FStarC_Pprint.arbitrary_string uu___1 + else FStarC_Syntax_Print_Pretty.comp_to_doc' dsenv t +let (sigelt_to_doc' : + FStarC_Syntax_DsEnv.env -> + FStarC_Syntax_Syntax.sigelt -> FStarC_Pprint.document) + = + fun dsenv -> + fun t -> + let uu___ = FStarC_Options.ugly () in + if uu___ + then + let uu___1 = FStarC_Syntax_Print_Ugly.sigelt_to_string t in + FStarC_Pprint.arbitrary_string uu___1 + else FStarC_Syntax_Print_Pretty.sigelt_to_doc' dsenv t +let (term_to_doc : FStarC_Syntax_Syntax.term -> FStarC_Pprint.document) = + fun t -> + let uu___ = FStarC_Options.ugly () in + if uu___ + then + let uu___1 = FStarC_Syntax_Print_Ugly.term_to_string t in + FStarC_Pprint.arbitrary_string uu___1 + else FStarC_Syntax_Print_Pretty.term_to_doc t +let (univ_to_doc : FStarC_Syntax_Syntax.universe -> FStarC_Pprint.document) = + fun t -> + let uu___ = FStarC_Options.ugly () in + if uu___ + then + let uu___1 = FStarC_Syntax_Print_Ugly.univ_to_string t in + FStarC_Pprint.arbitrary_string uu___1 + else FStarC_Syntax_Print_Pretty.univ_to_doc t +let (comp_to_doc : FStarC_Syntax_Syntax.comp -> FStarC_Pprint.document) = + fun t -> + let uu___ = FStarC_Options.ugly () in + if uu___ + then + let uu___1 = FStarC_Syntax_Print_Ugly.comp_to_string t in + FStarC_Pprint.arbitrary_string uu___1 + else FStarC_Syntax_Print_Pretty.comp_to_doc t +let (sigelt_to_doc : FStarC_Syntax_Syntax.sigelt -> FStarC_Pprint.document) = + fun t -> + let uu___ = FStarC_Options.ugly () in + if uu___ + then + let uu___1 = FStarC_Syntax_Print_Ugly.sigelt_to_string t in + FStarC_Pprint.arbitrary_string uu___1 + else FStarC_Syntax_Print_Pretty.sigelt_to_doc t +let (binder_to_string : FStarC_Syntax_Syntax.binder -> Prims.string) = + fun b -> + let uu___ = FStarC_Options.ugly () in + if uu___ + then FStarC_Syntax_Print_Pretty.binder_to_string' false b + else FStarC_Syntax_Print_Ugly.binder_to_string b +let (aqual_to_string : FStarC_Syntax_Syntax.aqual -> Prims.string) = + fun q -> + match q with + | FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = uu___;_} + -> "#" + | uu___ -> "" +let (bqual_to_string' : + Prims.string -> FStarC_Syntax_Syntax.bqual -> Prims.string) = + fun s -> + fun b -> + match b with + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Implicit (false)) + -> Prims.strcat "#" s + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Implicit (true)) + -> Prims.strcat "#." s + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Equality) -> + Prims.strcat "$" s + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Meta t) when + FStarC_Syntax_Util.is_fvar FStarC_Parser_Const.tcresolve_lid t -> + Prims.strcat "{|" (Prims.strcat s "|}") + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Meta t) -> + let uu___ = + let uu___1 = term_to_string t in + Prims.strcat uu___1 (Prims.strcat "]" s) in + Prims.strcat "#[" uu___ + | FStar_Pervasives_Native.None -> s +let (bqual_to_string : FStarC_Syntax_Syntax.bqual -> Prims.string) = + fun q -> bqual_to_string' "" q +let (subst_elt_to_string : FStarC_Syntax_Syntax.subst_elt -> Prims.string) = + fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.DB (i, x) -> + let uu___1 = FStarC_Compiler_Util.string_of_int i in + let uu___2 = bv_to_string x in + FStarC_Compiler_Util.format2 "DB (%s, %s)" uu___1 uu___2 + | FStarC_Syntax_Syntax.DT (i, t) -> + let uu___1 = FStarC_Compiler_Util.string_of_int i in + let uu___2 = term_to_string t in + FStarC_Compiler_Util.format2 "DT (%s, %s)" uu___1 uu___2 + | FStarC_Syntax_Syntax.NM (x, i) -> + let uu___1 = bv_to_string x in + let uu___2 = FStarC_Compiler_Util.string_of_int i in + FStarC_Compiler_Util.format2 "NM (%s, %s)" uu___1 uu___2 + | FStarC_Syntax_Syntax.NT (x, t) -> + let uu___1 = bv_to_string x in + let uu___2 = term_to_string t in + FStarC_Compiler_Util.format2 "NT (%s, %s)" uu___1 uu___2 + | FStarC_Syntax_Syntax.UN (i, u) -> + let uu___1 = FStarC_Compiler_Util.string_of_int i in + let uu___2 = univ_to_string u in + FStarC_Compiler_Util.format2 "UN (%s, %s)" uu___1 uu___2 + | FStarC_Syntax_Syntax.UD (u, i) -> + let uu___1 = FStarC_Ident.string_of_id u in + let uu___2 = FStarC_Compiler_Util.string_of_int i in + FStarC_Compiler_Util.format2 "UD (%s, %s)" uu___1 uu___2 +let (modul_to_string : FStarC_Syntax_Syntax.modul -> Prims.string) = + fun m -> + let uu___ = + FStarC_Class_Show.show FStarC_Ident.showable_lident + m.FStarC_Syntax_Syntax.name in + let uu___1 = + let uu___2 = + FStarC_Compiler_List.map sigelt_to_string + m.FStarC_Syntax_Syntax.declarations in + FStarC_Compiler_String.concat "\n" uu___2 in + FStarC_Compiler_Util.format2 "module %s\nDeclarations: [\n%s\n]\n" uu___ + uu___1 +let (metadata_to_string : FStarC_Syntax_Syntax.metadata -> Prims.string) = + fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.Meta_pattern (uu___1, ps) -> + let pats = + let uu___2 = + FStarC_Compiler_List.map + (fun args -> + let uu___3 = + FStarC_Compiler_List.map + (fun uu___4 -> + match uu___4 with | (t, uu___5) -> term_to_string t) + args in + FStarC_Compiler_String.concat "; " uu___3) ps in + FStarC_Compiler_String.concat "\\/" uu___2 in + FStarC_Compiler_Util.format1 "{Meta_pattern %s}" pats + | FStarC_Syntax_Syntax.Meta_named lid -> + let uu___1 = sli lid in + FStarC_Compiler_Util.format1 "{Meta_named %s}" uu___1 + | FStarC_Syntax_Syntax.Meta_labeled (l, r, uu___1) -> + let uu___2 = FStarC_Errors_Msg.rendermsg l in + let uu___3 = FStarC_Compiler_Range_Ops.string_of_range r in + FStarC_Compiler_Util.format2 "{Meta_labeled (%s, %s)}" uu___2 uu___3 + | FStarC_Syntax_Syntax.Meta_desugared msi -> "{Meta_desugared}" + | FStarC_Syntax_Syntax.Meta_monadic (m, t) -> + let uu___1 = sli m in + let uu___2 = term_to_string t in + FStarC_Compiler_Util.format2 "{Meta_monadic(%s @ %s)}" uu___1 uu___2 + | FStarC_Syntax_Syntax.Meta_monadic_lift (m, m', t) -> + let uu___1 = sli m in + let uu___2 = sli m' in + let uu___3 = term_to_string t in + FStarC_Compiler_Util.format3 "{Meta_monadic_lift(%s -> %s @ %s)}" + uu___1 uu___2 uu___3 +let (showable_term : FStarC_Syntax_Syntax.term FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = term_to_string } +let (showable_univ : + FStarC_Syntax_Syntax.universe FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = univ_to_string } +let (showable_comp : FStarC_Syntax_Syntax.comp FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = comp_to_string } +let (showable_sigelt : + FStarC_Syntax_Syntax.sigelt FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = sigelt_to_string } +let (showable_bv : FStarC_Syntax_Syntax.bv FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = bv_to_string } +let (showable_fv : FStarC_Syntax_Syntax.fv FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = fv_to_string } +let (showable_binder : + FStarC_Syntax_Syntax.binder FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = binder_to_string } +let (showable_uvar : FStarC_Syntax_Syntax.uvar FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = uvar_to_string } +let (ctx_uvar_to_string : FStarC_Syntax_Syntax.ctx_uvar -> Prims.string) = + fun ctx_uvar -> + let reason_string = + FStarC_Compiler_Util.format1 "(* %s *)\n" + ctx_uvar.FStarC_Syntax_Syntax.ctx_uvar_reason in + let uu___ = + let uu___1 = + FStarC_Compiler_List.map (FStarC_Class_Show.show showable_binder) + ctx_uvar.FStarC_Syntax_Syntax.ctx_uvar_binders in + FStarC_Compiler_String.concat ", " uu___1 in + let uu___1 = uvar_to_string ctx_uvar.FStarC_Syntax_Syntax.ctx_uvar_head in + let uu___2 = + let uu___3 = FStarC_Syntax_Util.ctx_uvar_typ ctx_uvar in + term_to_string uu___3 in + let uu___3 = + let uu___4 = FStarC_Syntax_Util.ctx_uvar_should_check ctx_uvar in + match uu___4 with + | FStarC_Syntax_Syntax.Allow_unresolved s -> + Prims.strcat "Allow_unresolved " s + | FStarC_Syntax_Syntax.Allow_untyped s -> + Prims.strcat "Allow_untyped " s + | FStarC_Syntax_Syntax.Allow_ghost s -> Prims.strcat "Allow_ghost " s + | FStarC_Syntax_Syntax.Strict -> "Strict" + | FStarC_Syntax_Syntax.Already_checked -> "Already_checked" in + FStarC_Compiler_Util.format5 "%s(%s |- %s : %s) %s" reason_string uu___ + uu___1 uu___2 uu___3 +let (showable_ctxu : + FStarC_Syntax_Syntax.ctx_uvar FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = ctx_uvar_to_string } +let (showable_binding : + FStarC_Syntax_Syntax.binding FStarC_Class_Show.showable) = + { + FStarC_Class_Show.show = + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.Binding_var x -> + let uu___1 = FStarC_Class_Show.show showable_bv x in + Prims.strcat "Binding_var " uu___1 + | FStarC_Syntax_Syntax.Binding_lid x -> + let uu___1 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_tuple2 FStarC_Ident.showable_lident + (FStarC_Class_Show.show_tuple2 + (FStarC_Class_Show.show_list + FStarC_Ident.showable_ident) showable_term)) x in + Prims.strcat "Binding_lid " uu___1 + | FStarC_Syntax_Syntax.Binding_univ x -> + let uu___1 = + FStarC_Class_Show.show FStarC_Ident.showable_ident x in + Prims.strcat "Binding_univ " uu___1) + } +let (showable_subst_elt : + FStarC_Syntax_Syntax.subst_elt FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = subst_elt_to_string } +let (showable_branch : + FStarC_Syntax_Syntax.branch FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = FStarC_Syntax_Print_Ugly.branch_to_string } +let (showable_qualifier : + FStarC_Syntax_Syntax.qualifier FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = qual_to_string } +let (showable_pat : FStarC_Syntax_Syntax.pat FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = pat_to_string } +let (showable_const : FStarC_Const.sconst FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = const_to_string } +let (showable_letbinding : + FStarC_Syntax_Syntax.letbinding FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = FStarC_Syntax_Print_Ugly.lb_to_string } +let (showable_modul : FStarC_Syntax_Syntax.modul FStarC_Class_Show.showable) + = { FStarC_Class_Show.show = modul_to_string } +let (showable_metadata : + FStarC_Syntax_Syntax.metadata FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = metadata_to_string } +let (showable_ctx_uvar_meta : + FStarC_Syntax_Syntax.ctx_uvar_meta_t FStarC_Class_Show.showable) = + { + FStarC_Class_Show.show = + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.Ctx_uvar_meta_attr attr -> + let uu___1 = FStarC_Class_Show.show showable_term attr in + Prims.strcat "Ctx_uvar_meta_attr " uu___1 + | FStarC_Syntax_Syntax.Ctx_uvar_meta_tac r -> + let uu___1 = FStarC_Class_Show.show showable_term r in + Prims.strcat "Ctx_uvar_meta_tac " uu___1) + } +let (showable_aqual : FStarC_Syntax_Syntax.aqual FStarC_Class_Show.showable) + = { FStarC_Class_Show.show = aqual_to_string } +let (tscheme_to_string : FStarC_Syntax_Syntax.tscheme -> Prims.string) = + fun ts -> + let uu___ = FStarC_Options.ugly () in + if uu___ + then FStarC_Syntax_Print_Ugly.tscheme_to_string ts + else FStarC_Syntax_Print_Pretty.tscheme_to_string ts +let (sub_eff_to_string : FStarC_Syntax_Syntax.sub_eff -> Prims.string) = + fun se -> + let tsopt_to_string ts_opt = + if FStarC_Compiler_Util.is_some ts_opt + then + let uu___ = FStarC_Compiler_Util.must ts_opt in + tscheme_to_string uu___ + else "" in + let uu___ = lid_to_string se.FStarC_Syntax_Syntax.source in + let uu___1 = lid_to_string se.FStarC_Syntax_Syntax.target in + let uu___2 = tsopt_to_string se.FStarC_Syntax_Syntax.lift in + let uu___3 = tsopt_to_string se.FStarC_Syntax_Syntax.lift_wp in + FStarC_Compiler_Util.format4 + "sub_effect %s ~> %s : lift = %s ;; lift_wp = %s" uu___ uu___1 uu___2 + uu___3 +let (showable_sub_eff : + FStarC_Syntax_Syntax.sub_eff FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = sub_eff_to_string } +let (pretty_term : FStarC_Syntax_Syntax.term FStarC_Class_PP.pretty) = + { FStarC_Class_PP.pp = term_to_doc } +let (pretty_univ : FStarC_Syntax_Syntax.universe FStarC_Class_PP.pretty) = + { FStarC_Class_PP.pp = univ_to_doc } +let (pretty_sigelt : FStarC_Syntax_Syntax.sigelt FStarC_Class_PP.pretty) = + { FStarC_Class_PP.pp = sigelt_to_doc } +let (pretty_comp : FStarC_Syntax_Syntax.comp FStarC_Class_PP.pretty) = + { FStarC_Class_PP.pp = comp_to_doc } +let (pretty_ctxu : FStarC_Syntax_Syntax.ctx_uvar FStarC_Class_PP.pretty) = + { + FStarC_Class_PP.pp = + (fun x -> + let uu___ = FStarC_Class_Show.show showable_ctxu x in + FStarC_Pprint.doc_of_string uu___) + } +let (pretty_uvar : FStarC_Syntax_Syntax.uvar FStarC_Class_PP.pretty) = + { + FStarC_Class_PP.pp = + (fun x -> + let uu___ = FStarC_Class_Show.show showable_uvar x in + FStarC_Pprint.doc_of_string uu___) + } +let (pretty_binder : FStarC_Syntax_Syntax.binder FStarC_Class_PP.pretty) = + { + FStarC_Class_PP.pp = + (fun x -> + let uu___ = FStarC_Class_Show.show showable_binder x in + FStarC_Pprint.doc_of_string uu___) + } +let (pretty_bv : FStarC_Syntax_Syntax.bv FStarC_Class_PP.pretty) = + { + FStarC_Class_PP.pp = + (fun x -> + let uu___ = FStarC_Class_Show.show showable_bv x in + FStarC_Pprint.doc_of_string uu___) + } +let (pretty_binding : FStarC_Syntax_Syntax.binding FStarC_Class_PP.pretty) = + { + FStarC_Class_PP.pp = + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.Binding_var bv -> + FStarC_Class_PP.pp pretty_bv bv + | FStarC_Syntax_Syntax.Binding_lid (l, (us, t)) -> + let uu___1 = FStarC_Class_PP.pp FStarC_Ident.pretty_lident l in + let uu___2 = + let uu___3 = FStarC_Class_PP.pp pretty_term t in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.colon uu___3 in + FStarC_Pprint.op_Hat_Hat uu___1 uu___2 + | FStarC_Syntax_Syntax.Binding_univ u -> + FStarC_Class_PP.pp FStarC_Ident.pretty_ident u) + } +let rec (sigelt_to_string_short : + FStarC_Syntax_Syntax.sigelt -> Prims.string) = + fun x -> + match x.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_pragma p -> + FStarC_Class_Show.show FStarC_Syntax_Syntax.showable_pragma p + | FStarC_Syntax_Syntax.Sig_let + { + FStarC_Syntax_Syntax.lbs1 = + (false, + { FStarC_Syntax_Syntax.lbname = lb; + FStarC_Syntax_Syntax.lbunivs = uu___; + FStarC_Syntax_Syntax.lbtyp = uu___1; + FStarC_Syntax_Syntax.lbeff = uu___2; + FStarC_Syntax_Syntax.lbdef = uu___3; + FStarC_Syntax_Syntax.lbattrs = uu___4; + FStarC_Syntax_Syntax.lbpos = uu___5;_}::[]); + FStarC_Syntax_Syntax.lids1 = uu___6;_} + -> + let uu___7 = lbname_to_string lb in + FStarC_Compiler_Util.format1 "let %s" uu___7 + | FStarC_Syntax_Syntax.Sig_let + { + FStarC_Syntax_Syntax.lbs1 = + (true, + { FStarC_Syntax_Syntax.lbname = lb; + FStarC_Syntax_Syntax.lbunivs = uu___; + FStarC_Syntax_Syntax.lbtyp = uu___1; + FStarC_Syntax_Syntax.lbeff = uu___2; + FStarC_Syntax_Syntax.lbdef = uu___3; + FStarC_Syntax_Syntax.lbattrs = uu___4; + FStarC_Syntax_Syntax.lbpos = uu___5;_}::[]); + FStarC_Syntax_Syntax.lids1 = uu___6;_} + -> + let uu___7 = lbname_to_string lb in + FStarC_Compiler_Util.format1 "let rec %s" uu___7 + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (true, lbs); + FStarC_Syntax_Syntax.lids1 = uu___;_} + -> + let uu___1 = + let uu___2 = + FStarC_Compiler_List.map + (fun lb -> lbname_to_string lb.FStarC_Syntax_Syntax.lbname) lbs in + FStarC_Compiler_String.concat " and " uu___2 in + FStarC_Compiler_Util.format1 "let rec %s" uu___1 + | FStarC_Syntax_Syntax.Sig_let uu___ -> + failwith "Impossible: sigelt_to_string_short, ill-formed let" + | FStarC_Syntax_Syntax.Sig_declare_typ + { FStarC_Syntax_Syntax.lid2 = lid; FStarC_Syntax_Syntax.us2 = uu___; + FStarC_Syntax_Syntax.t2 = uu___1;_} + -> + let uu___2 = FStarC_Ident.string_of_lid lid in + FStarC_Compiler_Util.format1 "val %s" uu___2 + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = lid; FStarC_Syntax_Syntax.us = uu___; + FStarC_Syntax_Syntax.params = uu___1; + FStarC_Syntax_Syntax.num_uniform_params = uu___2; + FStarC_Syntax_Syntax.t = uu___3; + FStarC_Syntax_Syntax.mutuals = uu___4; + FStarC_Syntax_Syntax.ds = uu___5; + FStarC_Syntax_Syntax.injective_type_params = uu___6;_} + -> + let uu___7 = FStarC_Ident.string_of_lid lid in + FStarC_Compiler_Util.format1 "type %s" uu___7 + | FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = lid; FStarC_Syntax_Syntax.us1 = uu___; + FStarC_Syntax_Syntax.t1 = uu___1; + FStarC_Syntax_Syntax.ty_lid = t_lid; + FStarC_Syntax_Syntax.num_ty_params = uu___2; + FStarC_Syntax_Syntax.mutuals1 = uu___3; + FStarC_Syntax_Syntax.injective_type_params1 = uu___4;_} + -> + let uu___5 = FStarC_Ident.string_of_lid lid in + let uu___6 = FStarC_Ident.string_of_lid t_lid in + FStarC_Compiler_Util.format2 "datacon %s for type %s" uu___5 uu___6 + | FStarC_Syntax_Syntax.Sig_assume + { FStarC_Syntax_Syntax.lid3 = lid; FStarC_Syntax_Syntax.us3 = uu___; + FStarC_Syntax_Syntax.phi1 = uu___1;_} + -> + let uu___2 = FStarC_Ident.string_of_lid lid in + FStarC_Compiler_Util.format1 "assume %s" uu___2 + | FStarC_Syntax_Syntax.Sig_bundle + { FStarC_Syntax_Syntax.ses = ses; + FStarC_Syntax_Syntax.lids = uu___;_} + -> + let uu___1 = FStarC_Compiler_List.hd ses in + sigelt_to_string_short uu___1 + | FStarC_Syntax_Syntax.Sig_fail + { FStarC_Syntax_Syntax.errs = uu___; + FStarC_Syntax_Syntax.fail_in_lax = uu___1; + FStarC_Syntax_Syntax.ses1 = ses;_} + -> + let uu___2 = + let uu___3 = FStarC_Compiler_List.hd ses in + sigelt_to_string_short uu___3 in + FStarC_Compiler_Util.format1 "[@@expect_failure] %s" uu___2 + | FStarC_Syntax_Syntax.Sig_new_effect ed -> + let kw = + let uu___ = FStarC_Syntax_Util.is_layered ed in + if uu___ + then "layered_effect" + else + (let uu___2 = FStarC_Syntax_Util.is_dm4f ed in + if uu___2 then "new_effect_for_free" else "new_effect") in + let uu___ = lid_to_string ed.FStarC_Syntax_Syntax.mname in + FStarC_Compiler_Util.format2 "%s { %s ... }" kw uu___ + | FStarC_Syntax_Syntax.Sig_sub_effect se -> + let uu___ = lid_to_string se.FStarC_Syntax_Syntax.source in + let uu___1 = lid_to_string se.FStarC_Syntax_Syntax.target in + FStarC_Compiler_Util.format2 "sub_effect %s ~> %s" uu___ uu___1 + | FStarC_Syntax_Syntax.Sig_effect_abbrev + { FStarC_Syntax_Syntax.lid4 = l; FStarC_Syntax_Syntax.us4 = uu___; + FStarC_Syntax_Syntax.bs2 = tps; FStarC_Syntax_Syntax.comp1 = c; + FStarC_Syntax_Syntax.cflags = uu___1;_} + -> + let uu___2 = sli l in + let uu___3 = + let uu___4 = + FStarC_Compiler_List.map (FStarC_Class_Show.show showable_binder) + tps in + FStarC_Compiler_String.concat " " uu___4 in + let uu___4 = FStarC_Class_Show.show showable_comp c in + FStarC_Compiler_Util.format3 "effect %s %s = %s" uu___2 uu___3 uu___4 + | FStarC_Syntax_Syntax.Sig_splice + { FStarC_Syntax_Syntax.is_typed = is_typed; + FStarC_Syntax_Syntax.lids2 = lids; + FStarC_Syntax_Syntax.tac = uu___;_} + -> + let uu___1 = + let uu___2 = + FStarC_Compiler_List.map FStarC_Ident.string_of_lid lids in + FStarC_Compiler_String.concat "; " uu___2 in + FStarC_Compiler_Util.format3 "%splice%s[%s] (...)" "%s" + (if is_typed then "_t" else "") uu___1 + | FStarC_Syntax_Syntax.Sig_polymonadic_bind + { FStarC_Syntax_Syntax.m_lid = m; FStarC_Syntax_Syntax.n_lid = n; + FStarC_Syntax_Syntax.p_lid = p; FStarC_Syntax_Syntax.tm3 = uu___; + FStarC_Syntax_Syntax.typ = uu___1; + FStarC_Syntax_Syntax.kind1 = uu___2;_} + -> + let uu___3 = FStarC_Ident.string_of_lid m in + let uu___4 = FStarC_Ident.string_of_lid n in + let uu___5 = FStarC_Ident.string_of_lid p in + FStarC_Compiler_Util.format3 "polymonadic_bind (%s, %s) |> %s" uu___3 + uu___4 uu___5 + | FStarC_Syntax_Syntax.Sig_polymonadic_subcomp + { FStarC_Syntax_Syntax.m_lid1 = m; FStarC_Syntax_Syntax.n_lid1 = n; + FStarC_Syntax_Syntax.tm4 = uu___; + FStarC_Syntax_Syntax.typ1 = uu___1; + FStarC_Syntax_Syntax.kind2 = uu___2;_} + -> + let uu___3 = FStarC_Ident.string_of_lid m in + let uu___4 = FStarC_Ident.string_of_lid n in + FStarC_Compiler_Util.format2 "polymonadic_subcomp %s <: %s" uu___3 + uu___4 +let (binder_to_json : + FStarC_Syntax_DsEnv.env -> FStarC_Syntax_Syntax.binder -> FStarC_Json.json) + = + fun env -> + fun b -> + let n = + let uu___ = + let uu___1 = nm_to_string b.FStarC_Syntax_Syntax.binder_bv in + bqual_to_string' uu___1 b.FStarC_Syntax_Syntax.binder_qual in + FStarC_Json.JsonStr uu___ in + let t = + let uu___ = + term_to_string' env + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + FStarC_Json.JsonStr uu___ in + FStarC_Json.JsonAssoc [("name", n); ("type", t)] +let (binders_to_json : + FStarC_Syntax_DsEnv.env -> FStarC_Syntax_Syntax.binders -> FStarC_Json.json) + = + fun env -> + fun bs -> + let uu___ = FStarC_Compiler_List.map (binder_to_json env) bs in + FStarC_Json.JsonList uu___ +let (eff_decl_to_string : FStarC_Syntax_Syntax.eff_decl -> Prims.string) = + fun ed -> + let uu___ = FStarC_Options.ugly () in + if uu___ + then FStarC_Syntax_Print_Ugly.eff_decl_to_string ed + else FStarC_Syntax_Print_Pretty.eff_decl_to_string ed +let (showable_eff_decl : + FStarC_Syntax_Syntax.eff_decl FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = eff_decl_to_string } +let (args_to_string : FStarC_Syntax_Syntax.args -> Prims.string) = + fun args -> + let uu___ = + FStarC_Compiler_List.map + (fun uu___1 -> + match uu___1 with + | (a, q) -> + let uu___2 = aqual_to_string q in + let uu___3 = term_to_string a in Prims.strcat uu___2 uu___3) + args in + FStarC_Compiler_String.concat " " uu___ +let (showable_decreases_order : + FStarC_Syntax_Syntax.decreases_order FStarC_Class_Show.showable) = + { + FStarC_Class_Show.show = + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.Decreases_lex l -> + let uu___1 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list showable_term) l in + Prims.strcat "Decreases_lex " uu___1 + | FStarC_Syntax_Syntax.Decreases_wf l -> + let uu___1 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_tuple2 showable_term showable_term) + l in + Prims.strcat "Decreases_wf " uu___1) + } +let (cflag_to_string : FStarC_Syntax_Syntax.cflag -> Prims.string) = + fun c -> + match c with + | FStarC_Syntax_Syntax.TOTAL -> "total" + | FStarC_Syntax_Syntax.MLEFFECT -> "ml" + | FStarC_Syntax_Syntax.RETURN -> "return" + | FStarC_Syntax_Syntax.PARTIAL_RETURN -> "partial_return" + | FStarC_Syntax_Syntax.SOMETRIVIAL -> "sometrivial" + | FStarC_Syntax_Syntax.TRIVIAL_POSTCONDITION -> "trivial_postcondition" + | FStarC_Syntax_Syntax.SHOULD_NOT_INLINE -> "should_not_inline" + | FStarC_Syntax_Syntax.LEMMA -> "lemma" + | FStarC_Syntax_Syntax.CPS -> "cps" + | FStarC_Syntax_Syntax.DECREASES do1 -> + let uu___ = FStarC_Class_Show.show showable_decreases_order do1 in + Prims.strcat "decreases " uu___ +let (showable_cflag : FStarC_Syntax_Syntax.cflag FStarC_Class_Show.showable) + = { FStarC_Class_Show.show = cflag_to_string } +let (binder_to_string_with_type : + FStarC_Syntax_Syntax.binder -> Prims.string) = + fun b -> + let uu___ = FStarC_Options.ugly () in + if uu___ + then + let attrs = + match b.FStarC_Syntax_Syntax.binder_attrs with + | [] -> "" + | ts -> + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Compiler_List.map + (FStarC_Class_Show.show showable_term) ts in + FStarC_Compiler_String.concat ", " uu___3 in + Prims.strcat uu___2 "] " in + Prims.strcat "[@@@" uu___1 in + let uu___1 = FStarC_Syntax_Syntax.is_null_binder b in + (if uu___1 + then + let uu___2 = + let uu___3 = + term_to_string + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + Prims.strcat "_:" uu___3 in + Prims.strcat attrs uu___2 + else + (let uu___3 = + let uu___4 = + let uu___5 = nm_to_string b.FStarC_Syntax_Syntax.binder_bv in + let uu___6 = + let uu___7 = + term_to_string + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + Prims.strcat ": " uu___7 in + Prims.strcat uu___5 uu___6 in + Prims.strcat attrs uu___4 in + bqual_to_string' uu___3 b.FStarC_Syntax_Syntax.binder_qual)) + else FStarC_Syntax_Print_Pretty.binder_to_string' false b \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Syntax_Print_Pretty.ml b/ocaml/fstar-lib/generated/FStarC_Syntax_Print_Pretty.ml new file mode 100644 index 00000000000..37e4a742359 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Syntax_Print_Pretty.ml @@ -0,0 +1,166 @@ +open Prims +let (rfrac : FStarC_BaseTypes.float) = + FStarC_Compiler_Util.float_of_string "1.0" +let (width : Prims.int) = (Prims.of_int (100)) +let (pp : FStarC_Pprint.document -> Prims.string) = + fun d -> FStarC_Pprint.pretty_string rfrac width d +let (term_to_doc' : + FStarC_Syntax_DsEnv.env -> + FStarC_Syntax_Syntax.term -> FStarC_Pprint.document) + = + fun env -> + fun tm -> + FStarC_GenSym.with_frozen_gensym + (fun uu___ -> + let e = FStarC_Syntax_Resugar.resugar_term' env tm in + FStarC_Parser_ToDocument.term_to_document e) +let (univ_to_doc' : + FStarC_Syntax_DsEnv.env -> + FStarC_Syntax_Syntax.universe -> FStarC_Pprint.document) + = + fun env -> + fun u -> + FStarC_GenSym.with_frozen_gensym + (fun uu___ -> + let e = + FStarC_Syntax_Resugar.resugar_universe' env u + FStarC_Compiler_Range_Type.dummyRange in + FStarC_Parser_ToDocument.term_to_document e) +let (term_to_string' : + FStarC_Syntax_DsEnv.env -> FStarC_Syntax_Syntax.term -> Prims.string) = + fun env -> + fun tm -> + FStarC_GenSym.with_frozen_gensym + (fun uu___ -> let d = term_to_doc' env tm in pp d) +let (univ_to_string' : + FStarC_Syntax_DsEnv.env -> FStarC_Syntax_Syntax.universe -> Prims.string) = + fun env -> + fun u -> + FStarC_GenSym.with_frozen_gensym + (fun uu___ -> let d = univ_to_doc' env u in pp d) +let (comp_to_doc' : + FStarC_Syntax_DsEnv.env -> + FStarC_Syntax_Syntax.comp -> FStarC_Pprint.document) + = + fun env -> + fun c -> + FStarC_GenSym.with_frozen_gensym + (fun uu___ -> + let e = FStarC_Syntax_Resugar.resugar_comp' env c in + FStarC_Parser_ToDocument.term_to_document e) +let (comp_to_string' : + FStarC_Syntax_DsEnv.env -> FStarC_Syntax_Syntax.comp -> Prims.string) = + fun env -> + fun c -> + FStarC_GenSym.with_frozen_gensym + (fun uu___ -> let d = comp_to_doc' env c in pp d) +let (sigelt_to_doc' : + FStarC_Syntax_DsEnv.env -> + FStarC_Syntax_Syntax.sigelt -> FStarC_Pprint.document) + = + fun env -> + fun se -> + FStarC_GenSym.with_frozen_gensym + (fun uu___ -> + let uu___1 = FStarC_Syntax_Resugar.resugar_sigelt' env se in + match uu___1 with + | FStar_Pervasives_Native.None -> FStarC_Pprint.empty + | FStar_Pervasives_Native.Some d -> + FStarC_Parser_ToDocument.decl_to_document d) +let (sigelt_to_string' : + FStarC_Syntax_DsEnv.env -> FStarC_Syntax_Syntax.sigelt -> Prims.string) = + fun env -> + fun se -> + FStarC_GenSym.with_frozen_gensym + (fun uu___ -> let d = sigelt_to_doc' env se in pp d) +let (term_to_doc : FStarC_Syntax_Syntax.term -> FStarC_Pprint.document) = + fun tm -> + FStarC_GenSym.with_frozen_gensym + (fun uu___ -> + let e = FStarC_Syntax_Resugar.resugar_term tm in + FStarC_Parser_ToDocument.term_to_document e) +let (univ_to_doc : FStarC_Syntax_Syntax.universe -> FStarC_Pprint.document) = + fun u -> + FStarC_GenSym.with_frozen_gensym + (fun uu___ -> + let e = + FStarC_Syntax_Resugar.resugar_universe u + FStarC_Compiler_Range_Type.dummyRange in + FStarC_Parser_ToDocument.term_to_document e) +let (comp_to_doc : FStarC_Syntax_Syntax.comp -> FStarC_Pprint.document) = + fun c -> + FStarC_GenSym.with_frozen_gensym + (fun uu___ -> + let e = FStarC_Syntax_Resugar.resugar_comp c in + FStarC_Parser_ToDocument.term_to_document e) +let (sigelt_to_doc : FStarC_Syntax_Syntax.sigelt -> FStarC_Pprint.document) = + fun se -> + FStarC_GenSym.with_frozen_gensym + (fun uu___ -> + let uu___1 = FStarC_Syntax_Resugar.resugar_sigelt se in + match uu___1 with + | FStar_Pervasives_Native.None -> FStarC_Pprint.empty + | FStar_Pervasives_Native.Some d -> + FStarC_Parser_ToDocument.decl_to_document d) +let (term_to_string : FStarC_Syntax_Syntax.term -> Prims.string) = + fun tm -> + FStarC_GenSym.with_frozen_gensym + (fun uu___ -> let d = term_to_doc tm in pp d) +let (comp_to_string : FStarC_Syntax_Syntax.comp -> Prims.string) = + fun c -> + FStarC_GenSym.with_frozen_gensym + (fun uu___ -> + let e = FStarC_Syntax_Resugar.resugar_comp c in + let d = FStarC_Parser_ToDocument.term_to_document e in pp d) +let (sigelt_to_string : FStarC_Syntax_Syntax.sigelt -> Prims.string) = + fun se -> + FStarC_GenSym.with_frozen_gensym + (fun uu___ -> + let uu___1 = FStarC_Syntax_Resugar.resugar_sigelt se in + match uu___1 with + | FStar_Pervasives_Native.None -> "" + | FStar_Pervasives_Native.Some d -> + let d1 = FStarC_Parser_ToDocument.decl_to_document d in pp d1) +let (univ_to_string : FStarC_Syntax_Syntax.universe -> Prims.string) = + fun u -> + FStarC_GenSym.with_frozen_gensym + (fun uu___ -> + let e = + FStarC_Syntax_Resugar.resugar_universe u + FStarC_Compiler_Range_Type.dummyRange in + let d = FStarC_Parser_ToDocument.term_to_document e in pp d) +let (tscheme_to_string : FStarC_Syntax_Syntax.tscheme -> Prims.string) = + fun ts -> + FStarC_GenSym.with_frozen_gensym + (fun uu___ -> + let d = FStarC_Syntax_Resugar.resugar_tscheme ts in + let d1 = FStarC_Parser_ToDocument.decl_to_document d in pp d1) +let (pat_to_string : FStarC_Syntax_Syntax.pat -> Prims.string) = + fun p -> + FStarC_GenSym.with_frozen_gensym + (fun uu___ -> + let e = + let uu___1 = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) ()) in + FStarC_Syntax_Resugar.resugar_pat p uu___1 in + let d = FStarC_Parser_ToDocument.pat_to_document e in pp d) +let (binder_to_string' : + Prims.bool -> FStarC_Syntax_Syntax.binder -> Prims.string) = + fun is_arrow -> + fun b -> + FStarC_GenSym.with_frozen_gensym + (fun uu___ -> + let e = + FStarC_Syntax_Resugar.resugar_binder b + FStarC_Compiler_Range_Type.dummyRange in + let d = FStarC_Parser_ToDocument.binder_to_document e in pp d) +let (eff_decl_to_string : FStarC_Syntax_Syntax.eff_decl -> Prims.string) = + fun ed -> + FStarC_GenSym.with_frozen_gensym + (fun uu___ -> + let d = FStarC_Syntax_Resugar.resugar_eff_decl ed in + let d1 = FStarC_Parser_ToDocument.decl_to_document d in pp d1) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Syntax_Print_Ugly.ml b/ocaml/fstar-lib/generated/FStarC_Syntax_Print_Ugly.ml new file mode 100644 index 00000000000..749e227a807 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Syntax_Print_Ugly.ml @@ -0,0 +1,1473 @@ +open Prims +let (sli : FStarC_Ident.lident -> Prims.string) = + fun l -> + let uu___ = FStarC_Options.print_real_names () in + if uu___ + then FStarC_Ident.string_of_lid l + else + (let uu___2 = FStarC_Ident.ident_of_lid l in + FStarC_Ident.string_of_id uu___2) +let (lid_to_string : FStarC_Ident.lid -> Prims.string) = fun l -> sli l +let (fv_to_string : FStarC_Syntax_Syntax.fv -> Prims.string) = + fun fv -> + lid_to_string (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v +let (bv_to_string : FStarC_Syntax_Syntax.bv -> Prims.string) = + fun bv -> + let uu___ = FStarC_Ident.string_of_id bv.FStarC_Syntax_Syntax.ppname in + let uu___1 = + let uu___2 = + FStarC_Compiler_Util.string_of_int bv.FStarC_Syntax_Syntax.index in + Prims.strcat "#" uu___2 in + Prims.strcat uu___ uu___1 +let (nm_to_string : FStarC_Syntax_Syntax.bv -> Prims.string) = + fun bv -> + let uu___ = FStarC_Options.print_real_names () in + if uu___ + then bv_to_string bv + else FStarC_Ident.string_of_id bv.FStarC_Syntax_Syntax.ppname +let (db_to_string : FStarC_Syntax_Syntax.bv -> Prims.string) = + fun bv -> + let uu___ = FStarC_Ident.string_of_id bv.FStarC_Syntax_Syntax.ppname in + let uu___1 = + let uu___2 = + FStarC_Compiler_Util.string_of_int bv.FStarC_Syntax_Syntax.index in + Prims.strcat "@" uu___2 in + Prims.strcat uu___ uu___1 +let (filter_imp : + FStarC_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> + Prims.bool) + = + fun aq -> + match aq with + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Meta t) when + FStarC_Syntax_Util.is_fvar FStarC_Parser_Const.tcresolve_lid t -> + true + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Implicit uu___) -> + false + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Meta uu___) -> false + | uu___ -> true +let filter_imp_args : + 'uuuuu . + ('uuuuu * FStarC_Syntax_Syntax.arg_qualifier + FStar_Pervasives_Native.option) Prims.list -> + ('uuuuu * FStarC_Syntax_Syntax.arg_qualifier + FStar_Pervasives_Native.option) Prims.list + = + fun args -> + FStarC_Compiler_List.filter + (fun uu___ -> + match uu___ with + | (uu___1, FStar_Pervasives_Native.None) -> true + | (uu___1, FStar_Pervasives_Native.Some a) -> + Prims.op_Negation a.FStarC_Syntax_Syntax.aqual_implicit) args +let (filter_imp_binders : + FStarC_Syntax_Syntax.binder Prims.list -> + FStarC_Syntax_Syntax.binder Prims.list) + = + fun bs -> + FStarC_Compiler_List.filter + (fun b -> filter_imp b.FStarC_Syntax_Syntax.binder_qual) bs +let (const_to_string : FStarC_Const.sconst -> Prims.string) = + FStarC_Parser_Const.const_to_string +let (lbname_to_string : + (FStarC_Syntax_Syntax.bv, FStarC_Syntax_Syntax.fv) FStar_Pervasives.either + -> Prims.string) + = + fun uu___ -> + match uu___ with + | FStar_Pervasives.Inl l -> bv_to_string l + | FStar_Pervasives.Inr l -> + lid_to_string (l.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v +let (uvar_to_string : FStarC_Syntax_Syntax.uvar -> Prims.string) = + fun u -> + let uu___ = FStarC_Options.hide_uvar_nums () in + if uu___ + then "?" + else + (let uu___2 = + let uu___3 = FStarC_Syntax_Unionfind.uvar_id u in + FStarC_Compiler_Util.string_of_int uu___3 in + Prims.strcat "?" uu___2) +let (version_to_string : FStarC_Syntax_Syntax.version -> Prims.string) = + fun v -> + let uu___ = + FStarC_Compiler_Util.string_of_int v.FStarC_Syntax_Syntax.major in + let uu___1 = + FStarC_Compiler_Util.string_of_int v.FStarC_Syntax_Syntax.minor in + FStarC_Compiler_Util.format2 "%s.%s" uu___ uu___1 +let (univ_uvar_to_string : + (FStarC_Syntax_Syntax.universe FStar_Pervasives_Native.option + FStarC_Unionfind.p_uvar * FStarC_Syntax_Syntax.version * + FStarC_Compiler_Range_Type.range) -> Prims.string) + = + fun u -> + let uu___ = FStarC_Options.hide_uvar_nums () in + if uu___ + then "?" + else + (let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Unionfind.univ_uvar_id u in + FStarC_Compiler_Util.string_of_int uu___4 in + let uu___4 = + let uu___5 = + match u with | (uu___6, u1, uu___7) -> version_to_string u1 in + Prims.strcat ":" uu___5 in + Prims.strcat uu___3 uu___4 in + Prims.strcat "?" uu___2) +let rec (int_of_univ : + Prims.int -> + FStarC_Syntax_Syntax.universe -> + (Prims.int * FStarC_Syntax_Syntax.universe + FStar_Pervasives_Native.option)) + = + fun n -> + fun u -> + let uu___ = FStarC_Syntax_Subst.compress_univ u in + match uu___ with + | FStarC_Syntax_Syntax.U_zero -> (n, FStar_Pervasives_Native.None) + | FStarC_Syntax_Syntax.U_succ u1 -> int_of_univ (n + Prims.int_one) u1 + | uu___1 -> (n, (FStar_Pervasives_Native.Some u)) +let rec (univ_to_string : FStarC_Syntax_Syntax.universe -> Prims.string) = + fun u -> + FStarC_Errors.with_ctx "While printing universe" + (fun uu___ -> + let uu___1 = FStarC_Syntax_Subst.compress_univ u in + match uu___1 with + | FStarC_Syntax_Syntax.U_unif u1 -> + let uu___2 = univ_uvar_to_string u1 in + Prims.strcat "U_unif " uu___2 + | FStarC_Syntax_Syntax.U_name x -> + let uu___2 = FStarC_Ident.string_of_id x in + Prims.strcat "U_name " uu___2 + | FStarC_Syntax_Syntax.U_bvar x -> + let uu___2 = FStarC_Compiler_Util.string_of_int x in + Prims.strcat "@" uu___2 + | FStarC_Syntax_Syntax.U_zero -> "0" + | FStarC_Syntax_Syntax.U_succ u1 -> + let uu___2 = int_of_univ Prims.int_one u1 in + (match uu___2 with + | (n, FStar_Pervasives_Native.None) -> + FStarC_Compiler_Util.string_of_int n + | (n, FStar_Pervasives_Native.Some u2) -> + let uu___3 = univ_to_string u2 in + let uu___4 = FStarC_Compiler_Util.string_of_int n in + FStarC_Compiler_Util.format2 "(%s + %s)" uu___3 uu___4) + | FStarC_Syntax_Syntax.U_max us -> + let uu___2 = + let uu___3 = FStarC_Compiler_List.map univ_to_string us in + FStarC_Compiler_String.concat ", " uu___3 in + FStarC_Compiler_Util.format1 "(max %s)" uu___2 + | FStarC_Syntax_Syntax.U_unknown -> "unknown") +let (univs_to_string : + FStarC_Syntax_Syntax.universe Prims.list -> Prims.string) = + fun us -> + let uu___ = FStarC_Compiler_List.map univ_to_string us in + FStarC_Compiler_String.concat ", " uu___ +let (univ_names_to_string : FStarC_Ident.ident Prims.list -> Prims.string) = + fun us -> + let uu___ = + FStarC_Compiler_List.map (fun x -> FStarC_Ident.string_of_id x) us in + FStarC_Compiler_String.concat ", " uu___ +let (qual_to_string : FStarC_Syntax_Syntax.qualifier -> Prims.string) = + fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.Assumption -> "assume" + | FStarC_Syntax_Syntax.InternalAssumption -> "internal_assume" + | FStarC_Syntax_Syntax.New -> "new" + | FStarC_Syntax_Syntax.Private -> "private" + | FStarC_Syntax_Syntax.Unfold_for_unification_and_vcgen -> "unfold" + | FStarC_Syntax_Syntax.Inline_for_extraction -> "inline_for_extraction" + | FStarC_Syntax_Syntax.NoExtract -> "noextract" + | FStarC_Syntax_Syntax.Visible_default -> "visible" + | FStarC_Syntax_Syntax.Irreducible -> "irreducible" + | FStarC_Syntax_Syntax.Noeq -> "noeq" + | FStarC_Syntax_Syntax.Unopteq -> "unopteq" + | FStarC_Syntax_Syntax.Logic -> "logic" + | FStarC_Syntax_Syntax.TotalEffect -> "total" + | FStarC_Syntax_Syntax.Discriminator l -> + let uu___1 = lid_to_string l in + FStarC_Compiler_Util.format1 "(Discriminator %s)" uu___1 + | FStarC_Syntax_Syntax.Projector (l, x) -> + let uu___1 = lid_to_string l in + let uu___2 = FStarC_Ident.string_of_id x in + FStarC_Compiler_Util.format2 "(Projector %s %s)" uu___1 uu___2 + | FStarC_Syntax_Syntax.RecordType (ns, fns) -> + let uu___1 = + let uu___2 = FStarC_Ident.path_of_ns ns in + FStarC_Ident.text_of_path uu___2 in + let uu___2 = + let uu___3 = FStarC_Compiler_List.map FStarC_Ident.string_of_id fns in + FStarC_Compiler_String.concat ", " uu___3 in + FStarC_Compiler_Util.format2 "(RecordType %s %s)" uu___1 uu___2 + | FStarC_Syntax_Syntax.RecordConstructor (ns, fns) -> + let uu___1 = + let uu___2 = FStarC_Ident.path_of_ns ns in + FStarC_Ident.text_of_path uu___2 in + let uu___2 = + let uu___3 = FStarC_Compiler_List.map FStarC_Ident.string_of_id fns in + FStarC_Compiler_String.concat ", " uu___3 in + FStarC_Compiler_Util.format2 "(RecordConstructor %s %s)" uu___1 + uu___2 + | FStarC_Syntax_Syntax.Action eff_lid -> + let uu___1 = lid_to_string eff_lid in + FStarC_Compiler_Util.format1 "(Action %s)" uu___1 + | FStarC_Syntax_Syntax.ExceptionConstructor -> "ExceptionConstructor" + | FStarC_Syntax_Syntax.HasMaskedEffect -> "HasMaskedEffect" + | FStarC_Syntax_Syntax.Effect -> "Effect" + | FStarC_Syntax_Syntax.Reifiable -> "reify" + | FStarC_Syntax_Syntax.Reflectable l -> + let uu___1 = FStarC_Ident.string_of_lid l in + FStarC_Compiler_Util.format1 "(reflect %s)" uu___1 + | FStarC_Syntax_Syntax.OnlyName -> "OnlyName" +let (quals_to_string : + FStarC_Syntax_Syntax.qualifier Prims.list -> Prims.string) = + fun quals -> + match quals with + | [] -> "" + | uu___ -> + let uu___1 = FStarC_Compiler_List.map qual_to_string quals in + FStarC_Compiler_String.concat " " uu___1 +let (quals_to_string' : + FStarC_Syntax_Syntax.qualifier Prims.list -> Prims.string) = + fun quals -> + match quals with + | [] -> "" + | uu___ -> let uu___1 = quals_to_string quals in Prims.strcat uu___1 " " +let (paren : Prims.string -> Prims.string) = + fun s -> Prims.strcat "(" (Prims.strcat s ")") +let rec (term_to_string : FStarC_Syntax_Syntax.term -> Prims.string) = + fun x -> + FStarC_Errors.with_ctx "While ugly-printing a term" + (fun uu___ -> + let x1 = FStarC_Syntax_Subst.compress x in + let x2 = + let uu___1 = FStarC_Options.print_implicits () in + if uu___1 then x1 else FStarC_Syntax_Util.unmeta x1 in + match x2.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_delayed uu___1 -> failwith "impossible" + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = uu___1; + FStarC_Syntax_Syntax.args = [];_} + -> failwith "Empty args!" + | FStarC_Syntax_Syntax.Tm_lazy + { FStarC_Syntax_Syntax.blob = b; + FStarC_Syntax_Syntax.lkind = + FStarC_Syntax_Syntax.Lazy_embedding (uu___1, thunk); + FStarC_Syntax_Syntax.ltyp = uu___2; + FStarC_Syntax_Syntax.rng = uu___3;_} + -> + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Thunk.force thunk in + term_to_string uu___6 in + Prims.strcat uu___5 "]" in + Prims.strcat "[LAZYEMB:" uu___4 + | FStarC_Syntax_Syntax.Tm_lazy i -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Compiler_Effect.op_Bang + FStarC_Syntax_Syntax.lazy_chooser in + FStarC_Compiler_Util.must uu___5 in + uu___4 i.FStarC_Syntax_Syntax.lkind i in + term_to_string uu___3 in + Prims.strcat uu___2 "]" in + Prims.strcat "[lazy:" uu___1 + | FStarC_Syntax_Syntax.Tm_quoted (tm, qi) -> + (match qi.FStarC_Syntax_Syntax.qkind with + | FStarC_Syntax_Syntax.Quote_static -> + let uu___1 = term_to_string tm in + let uu___2 = + (FStarC_Common.string_of_list ()) term_to_string + (FStar_Pervasives_Native.snd + qi.FStarC_Syntax_Syntax.antiquotations) in + FStarC_Compiler_Util.format2 "`(%s)%s" uu___1 uu___2 + | FStarC_Syntax_Syntax.Quote_dynamic -> + let uu___1 = term_to_string tm in + FStarC_Compiler_Util.format1 "quote (%s)" uu___1) + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t; + FStarC_Syntax_Syntax.meta = FStarC_Syntax_Syntax.Meta_pattern + (uu___1, ps);_} + -> + let pats = + let uu___2 = + FStarC_Compiler_List.map + (fun args -> + let uu___3 = + FStarC_Compiler_List.map + (fun uu___4 -> + match uu___4 with + | (t1, uu___5) -> term_to_string t1) args in + FStarC_Compiler_String.concat "; " uu___3) ps in + FStarC_Compiler_String.concat "\\/" uu___2 in + let uu___2 = term_to_string t in + FStarC_Compiler_Util.format2 "{:pattern %s} %s" pats uu___2 + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t; + FStarC_Syntax_Syntax.meta = FStarC_Syntax_Syntax.Meta_monadic + (m, t');_} + -> + let uu___1 = sli m in + let uu___2 = term_to_string t' in + let uu___3 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t in + let uu___4 = term_to_string t in + FStarC_Compiler_Util.format4 "(MetaMonadic-{%s %s} (%s) %s)" + uu___1 uu___2 uu___3 uu___4 + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_monadic_lift (m0, m1, t');_} + -> + let uu___1 = term_to_string t' in + let uu___2 = sli m0 in + let uu___3 = sli m1 in + let uu___4 = term_to_string t in + FStarC_Compiler_Util.format4 + "(MetaMonadicLift-{%s : %s -> %s} %s)" uu___1 uu___2 uu___3 + uu___4 + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t; + FStarC_Syntax_Syntax.meta = FStarC_Syntax_Syntax.Meta_labeled + (l, r, b);_} + -> + let uu___1 = FStarC_Errors_Msg.rendermsg l in + let uu___2 = FStarC_Compiler_Range_Ops.string_of_range r in + let uu___3 = term_to_string t in + FStarC_Compiler_Util.format3 "Meta_labeled(%s, %s){%s}" uu___1 + uu___2 uu___3 + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t; + FStarC_Syntax_Syntax.meta = FStarC_Syntax_Syntax.Meta_named l;_} + -> + let uu___1 = lid_to_string l in + let uu___2 = + FStarC_Compiler_Range_Ops.string_of_range + t.FStarC_Syntax_Syntax.pos in + let uu___3 = term_to_string t in + FStarC_Compiler_Util.format3 "Meta_named(%s, %s){%s}" uu___1 + uu___2 uu___3 + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_desugared uu___1;_} + -> + let uu___2 = term_to_string t in + FStarC_Compiler_Util.format1 "Meta_desugared{%s}" uu___2 + | FStarC_Syntax_Syntax.Tm_bvar x3 -> + let uu___1 = db_to_string x3 in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Class_Tagged.tag_of + FStarC_Syntax_Syntax.tagged_term + x3.FStarC_Syntax_Syntax.sort in + Prims.strcat uu___4 ")" in + Prims.strcat ":(" uu___3 in + Prims.strcat uu___1 uu___2 + | FStarC_Syntax_Syntax.Tm_name x3 -> nm_to_string x3 + | FStarC_Syntax_Syntax.Tm_fvar f -> + let pref = + match f.FStarC_Syntax_Syntax.fv_qual with + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Unresolved_projector uu___1) -> + "(Unresolved_projector)" + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Unresolved_constructor uu___1) -> + "(Unresolved_constructor)" + | uu___1 -> "" in + let uu___1 = fv_to_string f in Prims.strcat pref uu___1 + | FStarC_Syntax_Syntax.Tm_uvar (u, ([], uu___1)) -> + let uu___2 = + (FStarC_Options.print_bound_var_types ()) && + (FStarC_Options.print_effect_args ()) in + if uu___2 + then ctx_uvar_to_string_aux true u + else + (let uu___4 = + let uu___5 = + FStarC_Syntax_Unionfind.uvar_id + u.FStarC_Syntax_Syntax.ctx_uvar_head in + FStarC_Compiler_Util.string_of_int uu___5 in + Prims.strcat "?" uu___4) + | FStarC_Syntax_Syntax.Tm_uvar (u, s) -> + let uu___1 = + (FStarC_Options.print_bound_var_types ()) && + (FStarC_Options.print_effect_args ()) in + if uu___1 + then + let uu___2 = ctx_uvar_to_string_aux true u in + let uu___3 = + let uu___4 = + FStarC_Compiler_List.map subst_to_string + (FStar_Pervasives_Native.fst s) in + FStarC_Compiler_String.concat "; " uu___4 in + FStarC_Compiler_Util.format2 "(%s @ %s)" uu___2 uu___3 + else + (let uu___3 = + let uu___4 = + FStarC_Syntax_Unionfind.uvar_id + u.FStarC_Syntax_Syntax.ctx_uvar_head in + FStarC_Compiler_Util.string_of_int uu___4 in + Prims.strcat "?" uu___3) + | FStarC_Syntax_Syntax.Tm_constant c -> const_to_string c + | FStarC_Syntax_Syntax.Tm_type u -> + let uu___1 = FStarC_Options.print_universes () in + if uu___1 + then + let uu___2 = univ_to_string u in + FStarC_Compiler_Util.format1 "Type u#(%s)" uu___2 + else "Type" + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = c;_} + -> + let uu___1 = binders_to_string " -> " bs in + let uu___2 = comp_to_string c in + FStarC_Compiler_Util.format2 "(%s -> %s)" uu___1 uu___2 + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs; FStarC_Syntax_Syntax.body = t2; + FStarC_Syntax_Syntax.rc_opt = lc;_} + -> + (match lc with + | FStar_Pervasives_Native.Some rc when + FStarC_Options.print_implicits () -> + let uu___1 = binders_to_string " " bs in + let uu___2 = term_to_string t2 in + let uu___3 = + FStarC_Ident.string_of_lid + rc.FStarC_Syntax_Syntax.residual_effect in + let uu___4 = + if + FStarC_Compiler_Option.isNone + rc.FStarC_Syntax_Syntax.residual_typ + then "None" + else + (let uu___6 = + FStarC_Compiler_Option.get + rc.FStarC_Syntax_Syntax.residual_typ in + term_to_string uu___6) in + FStarC_Compiler_Util.format4 + "(fun %s -> (%s $$ (residual) %s %s))" uu___1 uu___2 + uu___3 uu___4 + | uu___1 -> + let uu___2 = binders_to_string " " bs in + let uu___3 = term_to_string t2 in + FStarC_Compiler_Util.format2 "(fun %s -> %s)" uu___2 uu___3) + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = xt; FStarC_Syntax_Syntax.phi = f;_} + -> + let uu___1 = bv_to_string xt in + let uu___2 = term_to_string xt.FStarC_Syntax_Syntax.sort in + let uu___3 = formula_to_string f in + FStarC_Compiler_Util.format3 "(%s:%s{%s})" uu___1 uu___2 uu___3 + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = t; + FStarC_Syntax_Syntax.args = args;_} + -> + let uu___1 = term_to_string t in + let uu___2 = args_to_string args in + FStarC_Compiler_Util.format2 "(%s %s)" uu___1 uu___2 + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = lbs; + FStarC_Syntax_Syntax.body1 = e;_} + -> + let uu___1 = lbs_to_string [] lbs in + let uu___2 = term_to_string e in + FStarC_Compiler_Util.format2 "%s\nin\n%s" uu___1 uu___2 + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = e; + FStarC_Syntax_Syntax.asc = (annot, topt, b); + FStarC_Syntax_Syntax.eff_opt = eff_name;_} + -> + let annot1 = + match annot with + | FStar_Pervasives.Inl t -> + let uu___1 = + let uu___2 = + FStarC_Compiler_Util.map_opt eff_name + FStarC_Ident.string_of_lid in + FStarC_Compiler_Util.dflt "default" uu___2 in + let uu___2 = term_to_string t in + FStarC_Compiler_Util.format2 "[%s] %s" uu___1 uu___2 + | FStar_Pervasives.Inr c -> comp_to_string c in + let topt1 = + match topt with + | FStar_Pervasives_Native.None -> "" + | FStar_Pervasives_Native.Some t -> + let uu___1 = term_to_string t in + FStarC_Compiler_Util.format1 "by %s" uu___1 in + let s = if b then "ascribed_eq" else "ascribed" in + let uu___1 = term_to_string e in + FStarC_Compiler_Util.format4 "(%s <%s: %s %s)" uu___1 s annot1 + topt1 + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = head; + FStarC_Syntax_Syntax.ret_opt = asc_opt; + FStarC_Syntax_Syntax.brs = branches; + FStarC_Syntax_Syntax.rc_opt1 = lc;_} + -> + let lc_str = + match lc with + | FStar_Pervasives_Native.Some lc1 when + FStarC_Options.print_implicits () -> + let uu___1 = + if + FStarC_Compiler_Option.isNone + lc1.FStarC_Syntax_Syntax.residual_typ + then "None" + else + (let uu___3 = + FStarC_Compiler_Option.get + lc1.FStarC_Syntax_Syntax.residual_typ in + term_to_string uu___3) in + FStarC_Compiler_Util.format1 " (residual_comp:%s)" uu___1 + | uu___1 -> "" in + let uu___1 = term_to_string head in + let uu___2 = + match asc_opt with + | FStar_Pervasives_Native.None -> "" + | FStar_Pervasives_Native.Some (b, (asc, tacopt, use_eq)) -> + let s = if use_eq then "returns$" else "returns" in + let uu___3 = binder_to_string b in + let uu___4 = + match asc with + | FStar_Pervasives.Inl t -> term_to_string t + | FStar_Pervasives.Inr c -> comp_to_string c in + let uu___5 = + match tacopt with + | FStar_Pervasives_Native.None -> "" + | FStar_Pervasives_Native.Some tac -> + let uu___6 = term_to_string tac in + FStarC_Compiler_Util.format1 " by %s" uu___6 in + FStarC_Compiler_Util.format4 "as %s %s %s%s " uu___3 s + uu___4 uu___5 in + let uu___3 = + let uu___4 = + FStarC_Compiler_List.map branch_to_string branches in + FStarC_Compiler_Util.concat_l "\n\t|" uu___4 in + FStarC_Compiler_Util.format4 "(match %s %swith\n\t| %s%s)" + uu___1 uu___2 uu___3 lc_str + | FStarC_Syntax_Syntax.Tm_uinst (t, us) -> + let uu___1 = FStarC_Options.print_universes () in + if uu___1 + then + let uu___2 = term_to_string t in + let uu___3 = univs_to_string us in + FStarC_Compiler_Util.format2 "%s<%s>" uu___2 uu___3 + else term_to_string t + | FStarC_Syntax_Syntax.Tm_unknown -> "_") +and (branch_to_string : FStarC_Syntax_Syntax.branch -> Prims.string) = + fun uu___ -> + match uu___ with + | (p, wopt, e) -> + let uu___1 = pat_to_string p in + let uu___2 = + match wopt with + | FStar_Pervasives_Native.None -> "" + | FStar_Pervasives_Native.Some w -> + let uu___3 = term_to_string w in + FStarC_Compiler_Util.format1 "when %s" uu___3 in + let uu___3 = term_to_string e in + FStarC_Compiler_Util.format3 "%s %s -> %s" uu___1 uu___2 uu___3 +and (ctx_uvar_to_string_aux : + Prims.bool -> FStarC_Syntax_Syntax.ctx_uvar -> Prims.string) = + fun print_reason -> + fun ctx_uvar -> + let reason_string = + if print_reason + then + FStarC_Compiler_Util.format1 "(* %s *)\n" + ctx_uvar.FStarC_Syntax_Syntax.ctx_uvar_reason + else + (let uu___1 = + let uu___2 = + FStarC_Compiler_Range_Ops.start_of_range + ctx_uvar.FStarC_Syntax_Syntax.ctx_uvar_range in + FStarC_Compiler_Range_Ops.string_of_pos uu___2 in + let uu___2 = + let uu___3 = + FStarC_Compiler_Range_Ops.end_of_range + ctx_uvar.FStarC_Syntax_Syntax.ctx_uvar_range in + FStarC_Compiler_Range_Ops.string_of_pos uu___3 in + FStarC_Compiler_Util.format2 "(%s-%s) " uu___1 uu___2) in + let uu___ = + binders_to_string ", " ctx_uvar.FStarC_Syntax_Syntax.ctx_uvar_binders in + let uu___1 = uvar_to_string ctx_uvar.FStarC_Syntax_Syntax.ctx_uvar_head in + let uu___2 = + let uu___3 = FStarC_Syntax_Util.ctx_uvar_typ ctx_uvar in + term_to_string uu___3 in + let uu___3 = + let uu___4 = FStarC_Syntax_Util.ctx_uvar_should_check ctx_uvar in + match uu___4 with + | FStarC_Syntax_Syntax.Allow_unresolved s -> + Prims.strcat "Allow_unresolved " s + | FStarC_Syntax_Syntax.Allow_untyped s -> + Prims.strcat "Allow_untyped " s + | FStarC_Syntax_Syntax.Allow_ghost s -> Prims.strcat "Allow_ghost " s + | FStarC_Syntax_Syntax.Strict -> "Strict" + | FStarC_Syntax_Syntax.Already_checked -> "Already_checked" in + FStarC_Compiler_Util.format5 "%s(%s |- %s : %s) %s" reason_string uu___ + uu___1 uu___2 uu___3 +and (subst_elt_to_string : FStarC_Syntax_Syntax.subst_elt -> Prims.string) = + fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.DB (i, x) -> + let uu___1 = FStarC_Compiler_Util.string_of_int i in + let uu___2 = bv_to_string x in + FStarC_Compiler_Util.format2 "DB (%s, %s)" uu___1 uu___2 + | FStarC_Syntax_Syntax.DT (i, t) -> + let uu___1 = FStarC_Compiler_Util.string_of_int i in + let uu___2 = term_to_string t in + FStarC_Compiler_Util.format2 "DT (%s, %s)" uu___1 uu___2 + | FStarC_Syntax_Syntax.NM (x, i) -> + let uu___1 = bv_to_string x in + let uu___2 = FStarC_Compiler_Util.string_of_int i in + FStarC_Compiler_Util.format2 "NM (%s, %s)" uu___1 uu___2 + | FStarC_Syntax_Syntax.NT (x, t) -> + let uu___1 = bv_to_string x in + let uu___2 = term_to_string t in + FStarC_Compiler_Util.format2 "NT (%s, %s)" uu___1 uu___2 + | FStarC_Syntax_Syntax.UN (i, u) -> + let uu___1 = FStarC_Compiler_Util.string_of_int i in + let uu___2 = univ_to_string u in + FStarC_Compiler_Util.format2 "UN (%s, %s)" uu___1 uu___2 + | FStarC_Syntax_Syntax.UD (u, i) -> + let uu___1 = FStarC_Ident.string_of_id u in + let uu___2 = FStarC_Compiler_Util.string_of_int i in + FStarC_Compiler_Util.format2 "UD (%s, %s)" uu___1 uu___2 +and (subst_to_string : + FStarC_Syntax_Syntax.subst_elt Prims.list -> Prims.string) = + fun s -> + let uu___ = FStarC_Compiler_List.map subst_elt_to_string s in + FStarC_Compiler_String.concat "; " uu___ +and (pat_to_string : FStarC_Syntax_Syntax.pat -> Prims.string) = + fun x -> + match x.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_cons (l, us_opt, pats) -> + let uu___ = fv_to_string l in + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Options.print_universes () in + Prims.op_Negation uu___3 in + if uu___2 + then " " + else + (match us_opt with + | FStar_Pervasives_Native.None -> " " + | FStar_Pervasives_Native.Some us -> + let uu___4 = + let uu___5 = FStarC_Compiler_List.map univ_to_string us in + FStarC_Compiler_String.concat " " uu___5 in + FStarC_Compiler_Util.format1 " %s " uu___4) in + let uu___2 = + let uu___3 = + FStarC_Compiler_List.map + (fun uu___4 -> + match uu___4 with + | (x1, b) -> + let p = pat_to_string x1 in + if b then Prims.strcat "#" p else p) pats in + FStarC_Compiler_String.concat " " uu___3 in + FStarC_Compiler_Util.format3 "(%s%s%s)" uu___ uu___1 uu___2 + | FStarC_Syntax_Syntax.Pat_dot_term topt -> + let uu___ = FStarC_Options.print_bound_var_types () in + if uu___ + then + let uu___1 = + if topt = FStar_Pervasives_Native.None + then "_" + else + (let uu___3 = FStarC_Compiler_Util.must topt in + term_to_string uu___3) in + FStarC_Compiler_Util.format1 ".%s" uu___1 + else "._" + | FStarC_Syntax_Syntax.Pat_var x1 -> + let uu___ = FStarC_Options.print_bound_var_types () in + if uu___ + then + let uu___1 = bv_to_string x1 in + let uu___2 = term_to_string x1.FStarC_Syntax_Syntax.sort in + FStarC_Compiler_Util.format2 "%s:%s" uu___1 uu___2 + else bv_to_string x1 + | FStarC_Syntax_Syntax.Pat_constant c -> const_to_string c +and (lbs_to_string : + FStarC_Syntax_Syntax.qualifier Prims.list -> + (Prims.bool * FStarC_Syntax_Syntax.letbinding Prims.list) -> Prims.string) + = + fun quals -> + fun lbs -> + let uu___ = quals_to_string' quals in + let uu___1 = + let uu___2 = + FStarC_Compiler_List.map + (fun lb -> + let uu___3 = attrs_to_string lb.FStarC_Syntax_Syntax.lbattrs in + let uu___4 = lbname_to_string lb.FStarC_Syntax_Syntax.lbname in + let uu___5 = + let uu___6 = FStarC_Options.print_universes () in + if uu___6 + then + let uu___7 = + let uu___8 = + univ_names_to_string lb.FStarC_Syntax_Syntax.lbunivs in + Prims.strcat uu___8 ">" in + Prims.strcat "<" uu___7 + else "" in + let uu___6 = term_to_string lb.FStarC_Syntax_Syntax.lbtyp in + let uu___7 = term_to_string lb.FStarC_Syntax_Syntax.lbdef in + FStarC_Compiler_Util.format5 "%s%s %s : %s = %s" uu___3 uu___4 + uu___5 uu___6 uu___7) (FStar_Pervasives_Native.snd lbs) in + FStarC_Compiler_Util.concat_l "\n and " uu___2 in + FStarC_Compiler_Util.format3 "%slet %s %s" uu___ + (if FStar_Pervasives_Native.fst lbs then "rec" else "") uu___1 +and (attrs_to_string : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax Prims.list -> + Prims.string) + = + fun uu___ -> + match uu___ with + | [] -> "" + | tms -> + let uu___1 = + let uu___2 = + FStarC_Compiler_List.map + (fun t -> let uu___3 = term_to_string t in paren uu___3) tms in + FStarC_Compiler_String.concat "; " uu___2 in + FStarC_Compiler_Util.format1 "[@ %s]" uu___1 +and (binder_attrs_to_string : + FStarC_Syntax_Syntax.term Prims.list -> Prims.string) = + fun uu___ -> + if FStarC_Options.any_dump_module () + then "" + else + (match uu___ with + | [] -> "" + | tms -> + let uu___1 = + let uu___2 = + FStarC_Compiler_List.map + (fun t -> let uu___3 = term_to_string t in paren uu___3) tms in + FStarC_Compiler_String.concat "; " uu___2 in + FStarC_Compiler_Util.format1 "[@@@ %s]" uu___1) +and (bqual_to_string' : + Prims.string -> + FStarC_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> + Prims.string) + = + fun s -> + fun uu___ -> + match uu___ with + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Implicit (false)) + -> Prims.strcat "#" s + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Implicit (true)) + -> Prims.strcat "#." s + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Equality) -> + Prims.strcat "$" s + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Meta t) when + FStarC_Syntax_Util.is_fvar FStarC_Parser_Const.tcresolve_lid t -> + Prims.strcat "{|" (Prims.strcat s "|}") + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Meta t) -> + let uu___1 = + let uu___2 = term_to_string t in + Prims.strcat uu___2 (Prims.strcat "]" s) in + Prims.strcat "#[" uu___1 + | FStar_Pervasives_Native.None -> s +and (aqual_to_string' : + Prims.string -> + FStarC_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option -> + Prims.string) + = + fun s -> + fun uu___ -> + match uu___ with + | FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = uu___1;_} + -> Prims.strcat "#" s + | uu___1 -> s +and (binder_to_string' : + Prims.bool -> FStarC_Syntax_Syntax.binder -> Prims.string) = + fun is_arrow -> + fun b -> + let attrs = binder_attrs_to_string b.FStarC_Syntax_Syntax.binder_attrs in + let uu___ = FStarC_Syntax_Syntax.is_null_binder b in + if uu___ + then + let uu___1 = + let uu___2 = + term_to_string + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + Prims.strcat "_:" uu___2 in + Prims.strcat attrs uu___1 + else + (let uu___2 = + (Prims.op_Negation is_arrow) && + (let uu___3 = FStarC_Options.print_bound_var_types () in + Prims.op_Negation uu___3) in + if uu___2 + then + let uu___3 = + let uu___4 = nm_to_string b.FStarC_Syntax_Syntax.binder_bv in + Prims.strcat attrs uu___4 in + bqual_to_string' uu___3 b.FStarC_Syntax_Syntax.binder_qual + else + (let uu___4 = + let uu___5 = + let uu___6 = nm_to_string b.FStarC_Syntax_Syntax.binder_bv in + let uu___7 = + let uu___8 = + term_to_string + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + Prims.strcat ":" uu___8 in + Prims.strcat uu___6 uu___7 in + Prims.strcat attrs uu___5 in + bqual_to_string' uu___4 b.FStarC_Syntax_Syntax.binder_qual)) +and (binder_to_string : FStarC_Syntax_Syntax.binder -> Prims.string) = + fun b -> binder_to_string' false b +and (arrow_binder_to_string : FStarC_Syntax_Syntax.binder -> Prims.string) = + fun b -> binder_to_string' true b +and (binders_to_string : + Prims.string -> FStarC_Syntax_Syntax.binder Prims.list -> Prims.string) = + fun sep -> + fun bs -> + let bs1 = + let uu___ = FStarC_Options.print_implicits () in + if uu___ then bs else filter_imp_binders bs in + if sep = " -> " + then + let uu___ = FStarC_Compiler_List.map arrow_binder_to_string bs1 in + FStarC_Compiler_String.concat sep uu___ + else + (let uu___1 = FStarC_Compiler_List.map binder_to_string bs1 in + FStarC_Compiler_String.concat sep uu___1) +and (arg_to_string : + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.arg_qualifier + FStar_Pervasives_Native.option) -> Prims.string) + = + fun uu___ -> + match uu___ with + | (a, imp) -> + let uu___1 = term_to_string a in aqual_to_string' uu___1 imp +and (args_to_string : + (FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax * + FStarC_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) + Prims.list -> Prims.string) + = + fun args -> + let args1 = + let uu___ = FStarC_Options.print_implicits () in + if uu___ then args else filter_imp_args args in + let uu___ = FStarC_Compiler_List.map arg_to_string args1 in + FStarC_Compiler_String.concat " " uu___ +and (comp_to_string : FStarC_Syntax_Syntax.comp -> Prims.string) = + fun c -> + FStarC_Errors.with_ctx "While ugly-printing a computation" + (fun uu___ -> + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total t -> + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress t in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_type uu___2 when + let uu___3 = + (FStarC_Options.print_implicits ()) || + (FStarC_Options.print_universes ()) in + Prims.op_Negation uu___3 -> term_to_string t + | uu___2 -> + let uu___3 = term_to_string t in + FStarC_Compiler_Util.format1 "Tot %s" uu___3) + | FStarC_Syntax_Syntax.GTotal t -> + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress t in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_type uu___2 when + let uu___3 = + (FStarC_Options.print_implicits ()) || + (FStarC_Options.print_universes ()) in + Prims.op_Negation uu___3 -> term_to_string t + | uu___2 -> + let uu___3 = term_to_string t in + FStarC_Compiler_Util.format1 "GTot %s" uu___3) + | FStarC_Syntax_Syntax.Comp c1 -> + let basic = + let uu___1 = FStarC_Options.print_effect_args () in + if uu___1 + then + let uu___2 = sli c1.FStarC_Syntax_Syntax.effect_name in + let uu___3 = + let uu___4 = + FStarC_Compiler_List.map univ_to_string + c1.FStarC_Syntax_Syntax.comp_univs in + FStarC_Compiler_String.concat ", " uu___4 in + let uu___4 = + term_to_string c1.FStarC_Syntax_Syntax.result_typ in + let uu___5 = + let uu___6 = + FStarC_Compiler_List.map arg_to_string + c1.FStarC_Syntax_Syntax.effect_args in + FStarC_Compiler_String.concat ", " uu___6 in + let uu___6 = cflags_to_string c1.FStarC_Syntax_Syntax.flags in + FStarC_Compiler_Util.format5 + "%s<%s> (%s) %s (attributes %s)" uu___2 uu___3 uu___4 + uu___5 uu___6 + else + (let uu___3 = + (FStarC_Compiler_Util.for_some + (fun uu___4 -> + match uu___4 with + | FStarC_Syntax_Syntax.TOTAL -> true + | uu___5 -> false) c1.FStarC_Syntax_Syntax.flags) + && + (let uu___4 = FStarC_Options.print_effect_args () in + Prims.op_Negation uu___4) in + if uu___3 + then + let uu___4 = + term_to_string c1.FStarC_Syntax_Syntax.result_typ in + FStarC_Compiler_Util.format1 "Tot %s" uu___4 + else + (let uu___5 = + ((let uu___6 = FStarC_Options.print_effect_args () in + Prims.op_Negation uu___6) && + (let uu___6 = FStarC_Options.print_implicits () in + Prims.op_Negation uu___6)) + && + (let uu___6 = FStarC_Parser_Const.effect_ML_lid () in + FStarC_Ident.lid_equals + c1.FStarC_Syntax_Syntax.effect_name uu___6) in + if uu___5 + then term_to_string c1.FStarC_Syntax_Syntax.result_typ + else + (let uu___7 = + (let uu___8 = FStarC_Options.print_effect_args () in + Prims.op_Negation uu___8) && + (FStarC_Compiler_Util.for_some + (fun uu___8 -> + match uu___8 with + | FStarC_Syntax_Syntax.MLEFFECT -> true + | uu___9 -> false) + c1.FStarC_Syntax_Syntax.flags) in + if uu___7 + then + let uu___8 = + term_to_string c1.FStarC_Syntax_Syntax.result_typ in + FStarC_Compiler_Util.format1 "ALL %s" uu___8 + else + (let uu___9 = + sli c1.FStarC_Syntax_Syntax.effect_name in + let uu___10 = + term_to_string + c1.FStarC_Syntax_Syntax.result_typ in + FStarC_Compiler_Util.format2 "%s (%s)" uu___9 + uu___10)))) in + let dec = + let uu___1 = + FStarC_Compiler_List.collect + (fun uu___2 -> + match uu___2 with + | FStarC_Syntax_Syntax.DECREASES dec_order -> + (match dec_order with + | FStarC_Syntax_Syntax.Decreases_lex l -> + let uu___3 = + let uu___4 = + match l with + | [] -> "" + | hd::tl -> + let uu___5 = term_to_string hd in + FStarC_Compiler_List.fold_left + (fun s -> + fun t -> + let uu___6 = + let uu___7 = term_to_string t in + Prims.strcat ";" uu___7 in + Prims.strcat s uu___6) uu___5 + tl in + FStarC_Compiler_Util.format1 + " (decreases [%s])" uu___4 in + [uu___3] + | FStarC_Syntax_Syntax.Decreases_wf (rel, e) -> + let uu___3 = + let uu___4 = term_to_string rel in + let uu___5 = term_to_string e in + FStarC_Compiler_Util.format2 + "(decreases {:well-founded %s %s})" uu___4 + uu___5 in + [uu___3]) + | uu___3 -> []) c1.FStarC_Syntax_Syntax.flags in + FStarC_Compiler_String.concat " " uu___1 in + FStarC_Compiler_Util.format2 "%s%s" basic dec) +and (cflag_to_string : FStarC_Syntax_Syntax.cflag -> Prims.string) = + fun c -> + match c with + | FStarC_Syntax_Syntax.TOTAL -> "total" + | FStarC_Syntax_Syntax.MLEFFECT -> "ml" + | FStarC_Syntax_Syntax.RETURN -> "return" + | FStarC_Syntax_Syntax.PARTIAL_RETURN -> "partial_return" + | FStarC_Syntax_Syntax.SOMETRIVIAL -> "sometrivial" + | FStarC_Syntax_Syntax.TRIVIAL_POSTCONDITION -> "trivial_postcondition" + | FStarC_Syntax_Syntax.SHOULD_NOT_INLINE -> "should_not_inline" + | FStarC_Syntax_Syntax.LEMMA -> "lemma" + | FStarC_Syntax_Syntax.CPS -> "cps" + | FStarC_Syntax_Syntax.DECREASES uu___ -> "" +and (cflags_to_string : + FStarC_Syntax_Syntax.cflag Prims.list -> Prims.string) = + fun fs -> (FStarC_Common.string_of_list ()) cflag_to_string fs +and (formula_to_string : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> Prims.string) = + fun phi -> term_to_string phi +let (aqual_to_string : + FStarC_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option -> + Prims.string) + = fun aq -> aqual_to_string' "" aq +let (bqual_to_string : + FStarC_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> + Prims.string) + = fun bq -> bqual_to_string' "" bq +let (lb_to_string : FStarC_Syntax_Syntax.letbinding -> Prims.string) = + fun lb -> lbs_to_string [] (false, [lb]) +let comp_to_string' : + 'uuuuu . 'uuuuu -> FStarC_Syntax_Syntax.comp -> Prims.string = + fun env -> fun c -> comp_to_string c +let term_to_string' : + 'uuuuu . 'uuuuu -> FStarC_Syntax_Syntax.term -> Prims.string = + fun env -> fun x -> term_to_string x +let (enclose_universes : Prims.string -> Prims.string) = + fun s -> + let uu___ = FStarC_Options.print_universes () in + if uu___ then Prims.strcat "<" (Prims.strcat s ">") else "" +let (tscheme_to_string : FStarC_Syntax_Syntax.tscheme -> Prims.string) = + fun s -> + let uu___ = s in + match uu___ with + | (us, t) -> + let uu___1 = + let uu___2 = univ_names_to_string us in enclose_universes uu___2 in + let uu___2 = term_to_string t in + FStarC_Compiler_Util.format2 "%s%s" uu___1 uu___2 +let (action_to_string : FStarC_Syntax_Syntax.action -> Prims.string) = + fun a -> + let uu___ = sli a.FStarC_Syntax_Syntax.action_name in + let uu___1 = binders_to_string " " a.FStarC_Syntax_Syntax.action_params in + let uu___2 = + let uu___3 = univ_names_to_string a.FStarC_Syntax_Syntax.action_univs in + enclose_universes uu___3 in + let uu___3 = term_to_string a.FStarC_Syntax_Syntax.action_typ in + let uu___4 = term_to_string a.FStarC_Syntax_Syntax.action_defn in + FStarC_Compiler_Util.format5 "%s%s %s : %s = %s" uu___ uu___1 uu___2 + uu___3 uu___4 +let (wp_eff_combinators_to_string : + FStarC_Syntax_Syntax.wp_eff_combinators -> Prims.string) = + fun combs -> + let tscheme_opt_to_string uu___ = + match uu___ with + | FStar_Pervasives_Native.Some ts -> tscheme_to_string ts + | FStar_Pervasives_Native.None -> "None" in + let uu___ = + let uu___1 = tscheme_to_string combs.FStarC_Syntax_Syntax.ret_wp in + let uu___2 = + let uu___3 = tscheme_to_string combs.FStarC_Syntax_Syntax.bind_wp in + let uu___4 = + let uu___5 = tscheme_to_string combs.FStarC_Syntax_Syntax.stronger in + let uu___6 = + let uu___7 = + tscheme_to_string combs.FStarC_Syntax_Syntax.if_then_else in + let uu___8 = + let uu___9 = + tscheme_to_string combs.FStarC_Syntax_Syntax.ite_wp in + let uu___10 = + let uu___11 = + tscheme_to_string combs.FStarC_Syntax_Syntax.close_wp in + let uu___12 = + let uu___13 = + tscheme_to_string combs.FStarC_Syntax_Syntax.trivial in + let uu___14 = + let uu___15 = + tscheme_opt_to_string combs.FStarC_Syntax_Syntax.repr in + let uu___16 = + let uu___17 = + tscheme_opt_to_string + combs.FStarC_Syntax_Syntax.return_repr in + let uu___18 = + let uu___19 = + tscheme_opt_to_string + combs.FStarC_Syntax_Syntax.bind_repr in + [uu___19] in + uu___17 :: uu___18 in + uu___15 :: uu___16 in + uu___13 :: uu___14 in + uu___11 :: uu___12 in + uu___9 :: uu___10 in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Compiler_Util.format + "{\nret_wp = %s\n; bind_wp = %s\n; stronger = %s\n; if_then_else = %s\n; ite_wp = %s\n; close_wp = %s\n; trivial = %s\n; repr = %s\n; return_repr = %s\n; bind_repr = %s\n}\n" + uu___ +let (sub_eff_to_string : FStarC_Syntax_Syntax.sub_eff -> Prims.string) = + fun se -> + let tsopt_to_string ts_opt = + if FStarC_Compiler_Util.is_some ts_opt + then + let uu___ = FStarC_Compiler_Util.must ts_opt in + tscheme_to_string uu___ + else "" in + let uu___ = lid_to_string se.FStarC_Syntax_Syntax.source in + let uu___1 = lid_to_string se.FStarC_Syntax_Syntax.target in + let uu___2 = tsopt_to_string se.FStarC_Syntax_Syntax.lift in + let uu___3 = tsopt_to_string se.FStarC_Syntax_Syntax.lift_wp in + FStarC_Compiler_Util.format4 + "sub_effect %s ~> %s : lift = %s ;; lift_wp = %s" uu___ uu___1 uu___2 + uu___3 +let (layered_eff_combinators_to_string : + FStarC_Syntax_Syntax.layered_eff_combinators -> Prims.string) = + fun combs -> + let to_str uu___ = + match uu___ with + | (ts_t, ts_ty, kopt) -> + let uu___1 = tscheme_to_string ts_t in + let uu___2 = tscheme_to_string ts_ty in + let uu___3 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_option + FStarC_Syntax_Syntax.showable_indexed_effect_combinator_kind) + kopt in + FStarC_Compiler_Util.format3 "(%s) : (%s)<%s>" uu___1 uu___2 uu___3 in + let to_str2 uu___ = + match uu___ with + | (ts_t, ts_ty) -> + let uu___1 = tscheme_to_string ts_t in + let uu___2 = tscheme_to_string ts_ty in + FStarC_Compiler_Util.format2 "(%s) : (%s)" uu___1 uu___2 in + let uu___ = + let uu___1 = to_str2 combs.FStarC_Syntax_Syntax.l_repr in + let uu___2 = + let uu___3 = to_str2 combs.FStarC_Syntax_Syntax.l_return in + let uu___4 = + let uu___5 = to_str combs.FStarC_Syntax_Syntax.l_bind in + let uu___6 = + let uu___7 = to_str combs.FStarC_Syntax_Syntax.l_subcomp in + let uu___8 = + let uu___9 = to_str combs.FStarC_Syntax_Syntax.l_if_then_else in + let uu___10 = + let uu___11 = + if + FStar_Pervasives_Native.uu___is_None + combs.FStarC_Syntax_Syntax.l_close + then "" + else + (let uu___13 = + let uu___14 = + FStarC_Compiler_Util.must + combs.FStarC_Syntax_Syntax.l_close in + to_str2 uu___14 in + FStarC_Compiler_Util.format1 "; l_close = %s\n" uu___13) in + [uu___11] in + uu___9 :: uu___10 in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Compiler_Util.format + "{\n; l_repr = %s\n; l_return = %s\n; l_bind = %s\n; l_subcomp = %s\n; l_if_then_else = %s\n\n %s\n }\n" + uu___ +let (eff_combinators_to_string : + FStarC_Syntax_Syntax.eff_combinators -> Prims.string) = + fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.Primitive_eff combs -> + wp_eff_combinators_to_string combs + | FStarC_Syntax_Syntax.DM4F_eff combs -> + wp_eff_combinators_to_string combs + | FStarC_Syntax_Syntax.Layered_eff combs -> + layered_eff_combinators_to_string combs +let (eff_extraction_mode_to_string : + FStarC_Syntax_Syntax.eff_extraction_mode -> Prims.string) = + fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.Extract_none s -> + FStarC_Compiler_Util.format1 "none (%s)" s + | FStarC_Syntax_Syntax.Extract_reify -> "reify" + | FStarC_Syntax_Syntax.Extract_primitive -> "primitive" +let (eff_decl_to_string : FStarC_Syntax_Syntax.eff_decl -> Prims.string) = + fun ed -> + let actions_to_string actions = + let uu___ = FStarC_Compiler_List.map action_to_string actions in + FStarC_Compiler_String.concat ",\n\t" uu___ in + let eff_name = + let uu___ = FStarC_Syntax_Util.is_layered ed in + if uu___ then "layered_effect" else "new_effect" in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = lid_to_string ed.FStarC_Syntax_Syntax.mname in + let uu___4 = + let uu___5 = + let uu___6 = univ_names_to_string ed.FStarC_Syntax_Syntax.univs in + enclose_universes uu___6 in + let uu___6 = + let uu___7 = + binders_to_string " " ed.FStarC_Syntax_Syntax.binders in + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Syntax_Util.effect_sig_ts + ed.FStarC_Syntax_Syntax.signature in + tscheme_to_string uu___10 in + let uu___10 = + let uu___11 = + eff_combinators_to_string + ed.FStarC_Syntax_Syntax.combinators in + let uu___12 = + let uu___13 = + actions_to_string ed.FStarC_Syntax_Syntax.actions in + [uu___13] in + uu___11 :: uu___12 in + uu___9 :: uu___10 in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + "" :: uu___2 in + eff_name :: uu___1 in + FStarC_Compiler_Util.format + "%s%s { %s%s %s : %s \n %s\nand effect_actions\n\t%s\n}\n" uu___ +let rec (sigelt_to_string : FStarC_Syntax_Syntax.sigelt -> Prims.string) = + fun x -> + let basic = + match x.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_pragma p -> + FStarC_Class_Show.show FStarC_Syntax_Syntax.showable_pragma p + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = lid; FStarC_Syntax_Syntax.us = univs; + FStarC_Syntax_Syntax.params = tps; + FStarC_Syntax_Syntax.num_uniform_params = uu___; + FStarC_Syntax_Syntax.t = k; + FStarC_Syntax_Syntax.mutuals = uu___1; + FStarC_Syntax_Syntax.ds = uu___2; + FStarC_Syntax_Syntax.injective_type_params = uu___3;_} + -> + let quals_str = quals_to_string' x.FStarC_Syntax_Syntax.sigquals in + let binders_str = binders_to_string " " tps in + let term_str = term_to_string k in + let uu___4 = FStarC_Options.print_universes () in + if uu___4 + then + let uu___5 = FStarC_Ident.string_of_lid lid in + let uu___6 = univ_names_to_string univs in + FStarC_Compiler_Util.format5 "%stype %s<%s> %s : %s" quals_str + uu___5 uu___6 binders_str term_str + else + (let uu___6 = FStarC_Ident.string_of_lid lid in + FStarC_Compiler_Util.format4 "%stype %s %s : %s" quals_str + uu___6 binders_str term_str) + | FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = lid; + FStarC_Syntax_Syntax.us1 = univs; FStarC_Syntax_Syntax.t1 = t; + FStarC_Syntax_Syntax.ty_lid = uu___; + FStarC_Syntax_Syntax.num_ty_params = uu___1; + FStarC_Syntax_Syntax.mutuals1 = uu___2; + FStarC_Syntax_Syntax.injective_type_params1 = uu___3;_} + -> + let uu___4 = FStarC_Options.print_universes () in + if uu___4 + then + let uu___5 = univ_names_to_string univs in + let uu___6 = FStarC_Ident.string_of_lid lid in + let uu___7 = term_to_string t in + FStarC_Compiler_Util.format3 "datacon<%s> %s : %s" uu___5 uu___6 + uu___7 + else + (let uu___6 = FStarC_Ident.string_of_lid lid in + let uu___7 = term_to_string t in + FStarC_Compiler_Util.format2 "datacon %s : %s" uu___6 uu___7) + | FStarC_Syntax_Syntax.Sig_declare_typ + { FStarC_Syntax_Syntax.lid2 = lid; + FStarC_Syntax_Syntax.us2 = univs; FStarC_Syntax_Syntax.t2 = t;_} + -> + let uu___ = quals_to_string' x.FStarC_Syntax_Syntax.sigquals in + let uu___1 = FStarC_Ident.string_of_lid lid in + let uu___2 = + let uu___3 = FStarC_Options.print_universes () in + if uu___3 + then + let uu___4 = univ_names_to_string univs in + FStarC_Compiler_Util.format1 "<%s>" uu___4 + else "" in + let uu___3 = term_to_string t in + FStarC_Compiler_Util.format4 "%sval %s %s : %s" uu___ uu___1 uu___2 + uu___3 + | FStarC_Syntax_Syntax.Sig_assume + { FStarC_Syntax_Syntax.lid3 = lid; FStarC_Syntax_Syntax.us3 = us; + FStarC_Syntax_Syntax.phi1 = f;_} + -> + let uu___ = FStarC_Options.print_universes () in + if uu___ + then + let uu___1 = FStarC_Ident.string_of_lid lid in + let uu___2 = univ_names_to_string us in + let uu___3 = term_to_string f in + FStarC_Compiler_Util.format3 "assume %s<%s> : %s" uu___1 uu___2 + uu___3 + else + (let uu___2 = FStarC_Ident.string_of_lid lid in + let uu___3 = term_to_string f in + FStarC_Compiler_Util.format2 "assume %s : %s" uu___2 uu___3) + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = lbs; + FStarC_Syntax_Syntax.lids1 = uu___;_} + -> + let lbs1 = + let uu___1 = + FStarC_Compiler_List.map + (fun lb -> + { + FStarC_Syntax_Syntax.lbname = + (lb.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = + (lb.FStarC_Syntax_Syntax.lbtyp); + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = + (lb.FStarC_Syntax_Syntax.lbdef); + FStarC_Syntax_Syntax.lbattrs = []; + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + }) (FStar_Pervasives_Native.snd lbs) in + ((FStar_Pervasives_Native.fst lbs), uu___1) in + lbs_to_string x.FStarC_Syntax_Syntax.sigquals lbs1 + | FStarC_Syntax_Syntax.Sig_bundle + { FStarC_Syntax_Syntax.ses = ses; + FStarC_Syntax_Syntax.lids = uu___;_} + -> + let uu___1 = + let uu___2 = FStarC_Compiler_List.map sigelt_to_string ses in + FStarC_Compiler_String.concat "\n" uu___2 in + Prims.strcat "(* Sig_bundle *)" uu___1 + | FStarC_Syntax_Syntax.Sig_fail + { FStarC_Syntax_Syntax.errs = errs; + FStarC_Syntax_Syntax.fail_in_lax = lax; + FStarC_Syntax_Syntax.ses1 = ses;_} + -> + let uu___ = FStarC_Compiler_Util.string_of_bool lax in + let uu___1 = + (FStarC_Common.string_of_list ()) + FStarC_Compiler_Util.string_of_int errs in + let uu___2 = + let uu___3 = FStarC_Compiler_List.map sigelt_to_string ses in + FStarC_Compiler_String.concat "\n" uu___3 in + FStarC_Compiler_Util.format3 + "(* Sig_fail %s %s *)\n%s\n(* / Sig_fail*)\n" uu___ uu___1 uu___2 + | FStarC_Syntax_Syntax.Sig_new_effect ed -> + let uu___ = + let uu___1 = FStarC_Syntax_Util.is_dm4f ed in + if uu___1 then "(* DM4F *)" else "" in + let uu___1 = + let uu___2 = quals_to_string' x.FStarC_Syntax_Syntax.sigquals in + let uu___3 = eff_decl_to_string ed in Prims.strcat uu___2 uu___3 in + Prims.strcat uu___ uu___1 + | FStarC_Syntax_Syntax.Sig_sub_effect se -> sub_eff_to_string se + | FStarC_Syntax_Syntax.Sig_effect_abbrev + { FStarC_Syntax_Syntax.lid4 = l; FStarC_Syntax_Syntax.us4 = univs; + FStarC_Syntax_Syntax.bs2 = tps; FStarC_Syntax_Syntax.comp1 = c; + FStarC_Syntax_Syntax.cflags = flags;_} + -> + let uu___ = FStarC_Options.print_universes () in + if uu___ + then + let uu___1 = + let uu___2 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 = tps; + FStarC_Syntax_Syntax.comp = c + }) FStarC_Compiler_Range_Type.dummyRange in + FStarC_Syntax_Subst.open_univ_vars univs uu___2 in + (match uu___1 with + | (univs1, t) -> + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.compress t in + uu___4.FStarC_Syntax_Syntax.n in + match uu___3 with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = c1;_} + -> (bs, c1) + | uu___4 -> failwith "impossible" in + (match uu___2 with + | (tps1, c1) -> + let uu___3 = sli l in + let uu___4 = univ_names_to_string univs1 in + let uu___5 = binders_to_string " " tps1 in + let uu___6 = comp_to_string c1 in + FStarC_Compiler_Util.format4 "effect %s<%s> %s = %s" + uu___3 uu___4 uu___5 uu___6)) + else + (let uu___2 = sli l in + let uu___3 = binders_to_string " " tps in + let uu___4 = comp_to_string c in + FStarC_Compiler_Util.format3 "effect %s %s = %s" uu___2 uu___3 + uu___4) + | FStarC_Syntax_Syntax.Sig_splice + { FStarC_Syntax_Syntax.is_typed = is_typed; + FStarC_Syntax_Syntax.lids2 = lids; + FStarC_Syntax_Syntax.tac = t;_} + -> + let uu___ = + let uu___1 = + FStarC_Compiler_List.map + (FStarC_Class_Show.show FStarC_Ident.showable_lident) lids in + FStarC_Compiler_String.concat "; " uu___1 in + let uu___1 = term_to_string t in + FStarC_Compiler_Util.format3 "splice%s[%s] (%s)" + (if is_typed then "_t" else "") uu___ uu___1 + | FStarC_Syntax_Syntax.Sig_polymonadic_bind + { FStarC_Syntax_Syntax.m_lid = m; FStarC_Syntax_Syntax.n_lid = n; + FStarC_Syntax_Syntax.p_lid = p; FStarC_Syntax_Syntax.tm3 = t; + FStarC_Syntax_Syntax.typ = ty; FStarC_Syntax_Syntax.kind1 = k;_} + -> + let uu___ = FStarC_Class_Show.show FStarC_Ident.showable_lident m in + let uu___1 = FStarC_Class_Show.show FStarC_Ident.showable_lident n in + let uu___2 = FStarC_Class_Show.show FStarC_Ident.showable_lident p in + let uu___3 = tscheme_to_string t in + let uu___4 = tscheme_to_string ty in + let uu___5 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_option + FStarC_Syntax_Syntax.showable_indexed_effect_combinator_kind) + k in + FStarC_Compiler_Util.format6 + "polymonadic_bind (%s, %s) |> %s = (%s, %s)<%s>" uu___ uu___1 + uu___2 uu___3 uu___4 uu___5 + | FStarC_Syntax_Syntax.Sig_polymonadic_subcomp + { FStarC_Syntax_Syntax.m_lid1 = m; FStarC_Syntax_Syntax.n_lid1 = n; + FStarC_Syntax_Syntax.tm4 = t; FStarC_Syntax_Syntax.typ1 = ty; + FStarC_Syntax_Syntax.kind2 = k;_} + -> + let uu___ = FStarC_Class_Show.show FStarC_Ident.showable_lident m in + let uu___1 = FStarC_Class_Show.show FStarC_Ident.showable_lident n in + let uu___2 = tscheme_to_string t in + let uu___3 = tscheme_to_string ty in + let uu___4 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_option + FStarC_Syntax_Syntax.showable_indexed_effect_combinator_kind) + k in + FStarC_Compiler_Util.format5 + "polymonadic_subcomp %s <: %s = (%s, %s)<%s>" uu___ uu___1 uu___2 + uu___3 uu___4 in + match x.FStarC_Syntax_Syntax.sigattrs with + | [] -> Prims.strcat "[@ ]" (Prims.strcat "\n" basic) + | uu___ -> + let uu___1 = attrs_to_string x.FStarC_Syntax_Syntax.sigattrs in + Prims.strcat uu___1 (Prims.strcat "\n" basic) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Syntax_Resugar.ml b/ocaml/fstar-lib/generated/FStarC_Syntax_Resugar.ml new file mode 100644 index 00000000000..9836a4bd039 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Syntax_Resugar.ml @@ -0,0 +1,3658 @@ +open Prims +let (doc_to_string : FStarC_Pprint.document -> Prims.string) = + fun doc -> + FStarC_Pprint.pretty_string (FStarC_Compiler_Util.float_of_string "1.0") + (Prims.of_int (100)) doc +let (parser_term_to_string : FStarC_Parser_AST.term -> Prims.string) = + fun t -> + let uu___ = FStarC_Parser_ToDocument.term_to_document t in + doc_to_string uu___ +let (parser_pat_to_string : FStarC_Parser_AST.pattern -> Prims.string) = + fun t -> + let uu___ = FStarC_Parser_ToDocument.pat_to_document t in + doc_to_string uu___ +let (tts : FStarC_Syntax_Syntax.term -> Prims.string) = + fun t -> FStarC_Syntax_Util.tts t +let map_opt : + 'uuuuu 'uuuuu1 . + unit -> + ('uuuuu -> 'uuuuu1 FStar_Pervasives_Native.option) -> + 'uuuuu Prims.list -> 'uuuuu1 Prims.list + = fun uu___ -> FStarC_Compiler_List.filter_map +let (bv_as_unique_ident : FStarC_Syntax_Syntax.bv -> FStarC_Ident.ident) = + fun x -> + let unique_name = + let uu___ = + (let uu___1 = FStarC_Ident.string_of_id x.FStarC_Syntax_Syntax.ppname in + FStarC_Compiler_Util.starts_with FStarC_Ident.reserved_prefix uu___1) + || (FStarC_Options.print_real_names ()) in + if uu___ + then + let uu___1 = FStarC_Ident.string_of_id x.FStarC_Syntax_Syntax.ppname in + let uu___2 = + FStarC_Compiler_Util.string_of_int x.FStarC_Syntax_Syntax.index in + Prims.strcat uu___1 uu___2 + else FStarC_Ident.string_of_id x.FStarC_Syntax_Syntax.ppname in + let uu___ = + let uu___1 = FStarC_Ident.range_of_id x.FStarC_Syntax_Syntax.ppname in + (unique_name, uu___1) in + FStarC_Ident.mk_ident uu___ +let (is_imp_bqual : + FStarC_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> + Prims.bool) + = + fun a -> + match a with + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Meta t) when + FStarC_Syntax_Util.is_fvar FStarC_Parser_Const.tcresolve_lid t -> + false + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Implicit uu___) -> + true + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Meta uu___) -> true + | uu___ -> false +let (no_imp_args : FStarC_Syntax_Syntax.args -> FStarC_Syntax_Syntax.args) = + fun args -> + FStarC_Compiler_List.filter + (fun uu___ -> + match uu___ with + | (uu___1, FStar_Pervasives_Native.None) -> true + | (uu___1, FStar_Pervasives_Native.Some arg) -> + Prims.op_Negation arg.FStarC_Syntax_Syntax.aqual_implicit) args +let (no_imp_bs : + FStarC_Syntax_Syntax.binder Prims.list -> + FStarC_Syntax_Syntax.binder Prims.list) + = + fun bs -> + FStarC_Compiler_List.filter + (fun b -> + Prims.op_Negation (is_imp_bqual b.FStarC_Syntax_Syntax.binder_qual)) + bs +let (filter_imp_args : + FStarC_Syntax_Syntax.args -> FStarC_Syntax_Syntax.args) = + fun args -> + let uu___ = FStarC_Options.print_implicits () in + if uu___ then args else no_imp_args args +let (filter_imp_bs : + FStarC_Syntax_Syntax.binder Prims.list -> + FStarC_Syntax_Syntax.binder Prims.list) + = + fun bs -> + let uu___ = FStarC_Options.print_implicits () in + if uu___ then bs else no_imp_bs bs +let filter_pattern_imp : + 'uuuuu . + ('uuuuu * Prims.bool) Prims.list -> ('uuuuu * Prims.bool) Prims.list + = + fun xs -> + let uu___ = FStarC_Options.print_implicits () in + if uu___ + then xs + else + FStarC_Compiler_List.filter + (fun uu___2 -> + match uu___2 with + | (uu___3, is_implicit) -> Prims.op_Negation is_implicit) xs +let (label : + Prims.string -> FStarC_Parser_AST.term -> FStarC_Parser_AST.term) = + fun s -> + fun t -> + if s = "" + then t + else + FStarC_Parser_AST.mk_term (FStarC_Parser_AST.Labeled (t, s, true)) + t.FStarC_Parser_AST.range FStarC_Parser_AST.Un +let rec (universe_to_int : + Prims.int -> + FStarC_Syntax_Syntax.universe -> + (Prims.int * FStarC_Syntax_Syntax.universe)) + = + fun n -> + fun u -> + let uu___ = FStarC_Syntax_Subst.compress_univ u in + match uu___ with + | FStarC_Syntax_Syntax.U_succ u1 -> + universe_to_int (n + Prims.int_one) u1 + | uu___1 -> (n, u) +let (universe_to_string : FStarC_Ident.ident Prims.list -> Prims.string) = + fun univs -> + let uu___ = FStarC_Options.print_universes () in + if uu___ + then + let uu___1 = + FStarC_Compiler_List.map (fun x -> FStarC_Ident.string_of_id x) univs in + FStarC_Compiler_String.concat ", " uu___1 + else "" +let rec (resugar_universe : + FStarC_Syntax_Syntax.universe -> + FStarC_Compiler_Range_Type.range -> FStarC_Parser_AST.term) + = + fun u -> + fun r -> + let mk a r1 = FStarC_Parser_AST.mk_term a r1 FStarC_Parser_AST.Un in + let u1 = FStarC_Syntax_Subst.compress_univ u in + match u1 with + | FStarC_Syntax_Syntax.U_zero -> + mk + (FStarC_Parser_AST.Const + (FStarC_Const.Const_int ("0", FStar_Pervasives_Native.None))) + r + | FStarC_Syntax_Syntax.U_succ uu___ -> + let uu___1 = universe_to_int Prims.int_zero u1 in + (match uu___1 with + | (n, u2) -> + (match u2 with + | FStarC_Syntax_Syntax.U_zero -> + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Compiler_Util.string_of_int n in + (uu___5, FStar_Pervasives_Native.None) in + FStarC_Const.Const_int uu___4 in + FStarC_Parser_AST.Const uu___3 in + mk uu___2 r + | uu___2 -> + let e1 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Compiler_Util.string_of_int n in + (uu___6, FStar_Pervasives_Native.None) in + FStarC_Const.Const_int uu___5 in + FStarC_Parser_AST.Const uu___4 in + mk uu___3 r in + let e2 = resugar_universe u2 r in + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Ident.id_of_text "+" in + (uu___5, [e1; e2]) in + FStarC_Parser_AST.Op uu___4 in + mk uu___3 r)) + | FStarC_Syntax_Syntax.U_max l -> + (match l with + | [] -> failwith "Impossible: U_max without arguments" + | uu___ -> + let t = + let uu___1 = + let uu___2 = FStarC_Ident.lid_of_path ["max"] r in + FStarC_Parser_AST.Var uu___2 in + mk uu___1 r in + FStarC_Compiler_List.fold_left + (fun acc -> + fun x -> + let uu___1 = + let uu___2 = + let uu___3 = resugar_universe x r in + (acc, uu___3, FStarC_Parser_AST.Nothing) in + FStarC_Parser_AST.App uu___2 in + mk uu___1 r) t l) + | FStarC_Syntax_Syntax.U_name u2 -> mk (FStarC_Parser_AST.Uvar u2) r + | FStarC_Syntax_Syntax.U_unif uu___ -> mk FStarC_Parser_AST.Wild r + | FStarC_Syntax_Syntax.U_bvar x -> + let id = + let uu___ = + let uu___1 = + let uu___2 = FStarC_Compiler_Util.string_of_int x in + FStarC_Compiler_Util.strcat "uu__univ_bvar_" uu___2 in + (uu___1, r) in + FStarC_Ident.mk_ident uu___ in + mk (FStarC_Parser_AST.Uvar id) r + | FStarC_Syntax_Syntax.U_unknown -> mk FStarC_Parser_AST.Wild r +let (resugar_universe' : + FStarC_Syntax_DsEnv.env -> + FStarC_Syntax_Syntax.universe -> + FStarC_Compiler_Range_Type.range -> FStarC_Parser_AST.term) + = fun env -> fun u -> fun r -> resugar_universe u r +type expected_arity = Prims.int FStar_Pervasives_Native.option +let rec (resugar_term_as_op : + FStarC_Syntax_Syntax.term -> + (Prims.string * expected_arity) FStar_Pervasives_Native.option) + = + fun t -> + let infix_prim_ops = + [(FStarC_Parser_Const.op_Addition, "+"); + (FStarC_Parser_Const.op_Subtraction, "-"); + (FStarC_Parser_Const.op_Minus, "-"); + (FStarC_Parser_Const.op_Multiply, "*"); + (FStarC_Parser_Const.op_Division, "/"); + (FStarC_Parser_Const.op_Modulus, "%"); + (FStarC_Parser_Const.read_lid, "!"); + (FStarC_Parser_Const.list_append_lid, "@"); + (FStarC_Parser_Const.list_tot_append_lid, "@"); + (FStarC_Parser_Const.op_Eq, "="); + (FStarC_Parser_Const.op_ColonEq, ":="); + (FStarC_Parser_Const.op_notEq, "<>"); + (FStarC_Parser_Const.not_lid, "~"); + (FStarC_Parser_Const.op_And, "&&"); + (FStarC_Parser_Const.op_Or, "||"); + (FStarC_Parser_Const.op_LTE, "<="); + (FStarC_Parser_Const.op_GTE, ">="); + (FStarC_Parser_Const.op_LT, "<"); + (FStarC_Parser_Const.op_GT, ">"); + (FStarC_Parser_Const.op_Modulus, "mod"); + (FStarC_Parser_Const.and_lid, "/\\"); + (FStarC_Parser_Const.or_lid, "\\/"); + (FStarC_Parser_Const.imp_lid, "==>"); + (FStarC_Parser_Const.iff_lid, "<==>"); + (FStarC_Parser_Const.precedes_lid, "<<"); + (FStarC_Parser_Const.eq2_lid, "=="); + (FStarC_Parser_Const.forall_lid, "forall"); + (FStarC_Parser_Const.exists_lid, "exists"); + (FStarC_Parser_Const.salloc_lid, "alloc"); + (FStarC_Parser_Const.calc_finish_lid, "calc_finish")] in + let fallback fv = + let uu___ = + FStarC_Compiler_Util.find_opt + (fun d -> + FStarC_Syntax_Syntax.fv_eq_lid fv + (FStar_Pervasives_Native.fst d)) infix_prim_ops in + match uu___ with + | FStar_Pervasives_Native.Some op -> + FStar_Pervasives_Native.Some + ((FStar_Pervasives_Native.snd op), FStar_Pervasives_Native.None) + | uu___1 -> + let length = + let uu___2 = + FStarC_Ident.nsstr + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + FStarC_Compiler_String.length uu___2 in + let str = + if length = Prims.int_zero + then + FStarC_Ident.string_of_lid + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + else + (let uu___3 = + FStarC_Ident.string_of_lid + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + FStarC_Compiler_Util.substring_from uu___3 + (length + Prims.int_one)) in + let uu___2 = + (FStarC_Compiler_Util.starts_with str "dtuple") && + (let uu___3 = + let uu___4 = + FStarC_Compiler_Util.substring_from str (Prims.of_int (6)) in + FStarC_Compiler_Util.safe_int_of_string uu___4 in + FStarC_Compiler_Option.isSome uu___3) in + if uu___2 + then + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Compiler_Util.substring_from str (Prims.of_int (6)) in + FStarC_Compiler_Util.safe_int_of_string uu___5 in + ("dtuple", uu___4) in + FStar_Pervasives_Native.Some uu___3 + else + (let uu___4 = + (FStarC_Compiler_Util.starts_with str "tuple") && + (let uu___5 = + let uu___6 = + FStarC_Compiler_Util.substring_from str + (Prims.of_int (5)) in + FStarC_Compiler_Util.safe_int_of_string uu___6 in + FStarC_Compiler_Option.isSome uu___5) in + if uu___4 + then + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Compiler_Util.substring_from str + (Prims.of_int (5)) in + FStarC_Compiler_Util.safe_int_of_string uu___7 in + ("tuple", uu___6) in + FStar_Pervasives_Native.Some uu___5 + else + if FStarC_Compiler_Util.starts_with str "try_with" + then + FStar_Pervasives_Native.Some + ("try_with", FStar_Pervasives_Native.None) + else + (let uu___7 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.sread_lid in + if uu___7 + then + let uu___8 = + let uu___9 = + FStarC_Ident.string_of_lid + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + (uu___9, FStar_Pervasives_Native.None) in + FStar_Pervasives_Native.Some uu___8 + else FStar_Pervasives_Native.None)) in + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let length = + let uu___1 = + FStarC_Ident.nsstr + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + FStarC_Compiler_String.length uu___1 in + let s = + if length = Prims.int_zero + then + FStarC_Ident.string_of_lid + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + else + (let uu___2 = + FStarC_Ident.string_of_lid + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + FStarC_Compiler_Util.substring_from uu___2 + (length + Prims.int_one)) in + let uu___1 = FStarC_Parser_AST.string_to_op s in + (match uu___1 with + | FStar_Pervasives_Native.Some t1 -> FStar_Pervasives_Native.Some t1 + | uu___2 -> fallback fv) + | FStarC_Syntax_Syntax.Tm_uinst (e, us) -> resugar_term_as_op e + | uu___1 -> FStar_Pervasives_Native.None +let (is_true_pat : FStarC_Syntax_Syntax.pat -> Prims.bool) = + fun p -> + match p.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_constant (FStarC_Const.Const_bool (true)) -> + true + | uu___ -> false +let (is_tuple_constructor_lid : FStarC_Ident.lident -> Prims.bool) = + fun lid -> + (FStarC_Parser_Const.is_tuple_data_lid' lid) || + (FStarC_Parser_Const.is_dtuple_data_lid' lid) +let (may_shorten : FStarC_Ident.lident -> Prims.bool) = + fun lid -> + let uu___ = FStarC_Options.print_real_names () in + if uu___ + then false + else + (let uu___2 = FStarC_Ident.string_of_lid lid in + match uu___2 with + | "Prims.Nil" -> false + | "Prims.Cons" -> false + | uu___3 -> + let uu___4 = is_tuple_constructor_lid lid in + Prims.op_Negation uu___4) +let (maybe_shorten_lid : + FStarC_Syntax_DsEnv.env -> FStarC_Ident.lident -> FStarC_Ident.lident) = + fun env -> + fun lid -> + let uu___ = may_shorten lid in + if uu___ then FStarC_Syntax_DsEnv.shorten_lid env lid else lid +let (maybe_shorten_fv : + FStarC_Syntax_DsEnv.env -> FStarC_Syntax_Syntax.fv -> FStarC_Ident.lident) + = + fun env -> + fun fv -> + let lid = (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + maybe_shorten_lid env lid +let (serialize_machine_integer_desc : + (FStarC_Const.signedness * FStarC_Const.width) -> Prims.string Prims.list) + = + fun uu___ -> + match uu___ with + | (s, w) -> + let sU = + match s with + | FStarC_Const.Unsigned -> "U" + | FStarC_Const.Signed -> "" in + let sW = + match w with + | FStarC_Const.Int8 -> "8" + | FStarC_Const.Int16 -> "16" + | FStarC_Const.Int32 -> "32" + | FStarC_Const.Int64 -> "64" in + let su = + match s with + | FStarC_Const.Unsigned -> "u" + | FStarC_Const.Signed -> "" in + let uu___1 = + FStarC_Compiler_Util.format3 "FStar.%sInt%s.__%sint_to_t" sU sW su in + let uu___2 = + let uu___3 = + FStarC_Compiler_Util.format3 "FStar.%sInt%s.%sint_to_t" sU sW su in + [uu___3] in + uu___1 :: uu___2 +let (parse_machine_integer_desc : + FStarC_Syntax_Syntax.fv -> + ((FStarC_Const.signedness * FStarC_Const.width) * Prims.string) + FStar_Pervasives_Native.option) + = + let signs = [FStarC_Const.Unsigned; FStarC_Const.Signed] in + let widths = + [FStarC_Const.Int8; + FStarC_Const.Int16; + FStarC_Const.Int32; + FStarC_Const.Int64] in + let descs = + let uu___ = + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Class_Monad.monad_list () () + (Obj.magic signs) + (fun uu___1 -> + (fun s -> + let s = Obj.magic s in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_list () () (Obj.magic widths) + (fun uu___1 -> + (fun w -> + let w = Obj.magic w in + let uu___1 = + serialize_machine_integer_desc (s, w) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_list () () + (Obj.magic uu___1) + (fun uu___2 -> + (fun desc -> + let desc = Obj.magic desc in + Obj.magic [((s, w), desc)]) uu___2))) + uu___1))) uu___1)) in + ((FStarC_Const.Unsigned, FStarC_Const.Sizet), "FStar.SizeT.__uint_to_t") + :: uu___ in + fun fv -> + FStarC_Compiler_List.tryFind + (fun uu___ -> + match uu___ with + | (uu___1, d) -> + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.lid_of_fv fv in + FStarC_Ident.string_of_lid uu___3 in + d = uu___2) descs +let (can_resugar_machine_integer_fv : FStarC_Syntax_Syntax.fv -> Prims.bool) + = + fun fv -> + let uu___ = parse_machine_integer_desc fv in + FStarC_Compiler_Option.isSome uu___ +let (resugar_machine_integer : + FStarC_Syntax_Syntax.fv -> + Prims.string -> + FStarC_Compiler_Range_Type.range -> FStarC_Parser_AST.term) + = + fun fv -> + fun i -> + fun pos -> + let uu___ = parse_machine_integer_desc fv in + match uu___ with + | FStar_Pervasives_Native.None -> + failwith + "Impossible: should be guarded by can_resugar_machine_integer" + | FStar_Pervasives_Native.Some (sw, uu___1) -> + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.Const + (FStarC_Const.Const_int + (i, (FStar_Pervasives_Native.Some sw)))) pos + FStarC_Parser_AST.Un +let rec (__is_list_literal : + FStarC_Ident.lident -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term Prims.list FStar_Pervasives_Native.option) + = + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun cons_lid -> + fun nil_lid -> + fun t -> + let uu___ = FStarC_Syntax_Util.head_and_args_full t in + match uu___ with + | (hd, args) -> + let hd1 = + let uu___1 = FStarC_Syntax_Util.un_uinst hd in + FStarC_Syntax_Subst.compress uu___1 in + let args1 = filter_imp_args args in + (match ((hd1.FStarC_Syntax_Syntax.n), args1) with + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (hd2, FStar_Pervasives_Native.None)::(tl, + FStar_Pervasives_Native.None)::[]) + when FStarC_Syntax_Syntax.fv_eq_lid fv cons_lid -> + Obj.magic + (Obj.repr + (let uu___1 = + __is_list_literal cons_lid nil_lid tl in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () + (Obj.magic uu___1) + (fun uu___2 -> + (fun tl1 -> + let tl1 = Obj.magic tl1 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Class_Monad.monad_option () + (Obj.magic (hd2 :: tl1)))) uu___2))) + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv nil_lid -> + Obj.magic + (Obj.repr + (FStarC_Class_Monad.return + FStarC_Class_Monad.monad_option () + (Obj.magic []))) + | (uu___1, uu___2) -> + Obj.magic (Obj.repr FStar_Pervasives_Native.None))) + uu___2 uu___1 uu___ +let (is_list_literal : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term Prims.list FStar_Pervasives_Native.option) + = + __is_list_literal FStarC_Parser_Const.cons_lid FStarC_Parser_Const.nil_lid +let (is_seq_literal : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term Prims.list FStar_Pervasives_Native.option) + = + __is_list_literal FStarC_Parser_Const.seq_cons_lid + FStarC_Parser_Const.seq_empty_lid +let (can_resugar_machine_integer : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.args -> + (FStarC_Syntax_Syntax.fv * Prims.string) FStar_Pervasives_Native.option) + = + fun hd -> + fun args -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress hd in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_fvar fv when + can_resugar_machine_integer_fv fv -> + (match args with + | (a, FStar_Pervasives_Native.None)::[] -> + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress a in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_constant (FStarC_Const.Const_int + (i, FStar_Pervasives_Native.None)) -> + FStar_Pervasives_Native.Some (fv, i) + | uu___2 -> FStar_Pervasives_Native.None) + | uu___1 -> FStar_Pervasives_Native.None) + | uu___1 -> FStar_Pervasives_Native.None +let rec (resugar_term' : + FStarC_Syntax_DsEnv.env -> + FStarC_Syntax_Syntax.term -> FStarC_Parser_AST.term) + = + fun env -> + fun t -> + let mk a = + FStarC_Parser_AST.mk_term a t.FStarC_Syntax_Syntax.pos + FStarC_Parser_AST.Un in + let name a r = + let uu___ = FStarC_Ident.lid_of_path [a] r in + FStarC_Parser_AST.Name uu___ in + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_delayed uu___1 -> + failwith "Tm_delayed is impossible after compress" + | FStarC_Syntax_Syntax.Tm_lazy i -> + let uu___1 = FStarC_Syntax_Util.unfold_lazy i in + resugar_term' env uu___1 + | FStarC_Syntax_Syntax.Tm_bvar x -> + let l = + let uu___1 = let uu___2 = bv_as_unique_ident x in [uu___2] in + FStarC_Ident.lid_of_ids uu___1 in + mk (FStarC_Parser_AST.Var l) + | FStarC_Syntax_Syntax.Tm_name x -> + let l = + let uu___1 = let uu___2 = bv_as_unique_ident x in [uu___2] in + FStarC_Ident.lid_of_ids uu___1 in + mk (FStarC_Parser_AST.Var l) + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let a = (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + let length = + let uu___1 = + FStarC_Ident.nsstr + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + FStarC_Compiler_String.length uu___1 in + let s = + if length = Prims.int_zero + then FStarC_Ident.string_of_lid a + else + (let uu___2 = FStarC_Ident.string_of_lid a in + FStarC_Compiler_Util.substring_from uu___2 + (length + Prims.int_one)) in + let is_prefix = Prims.strcat FStarC_Ident.reserved_prefix "is_" in + if FStarC_Compiler_Util.starts_with s is_prefix + then + let rest = + FStarC_Compiler_Util.substring_from s + (FStarC_Compiler_String.length is_prefix) in + let uu___1 = + let uu___2 = + FStarC_Ident.lid_of_path [rest] t.FStarC_Syntax_Syntax.pos in + FStarC_Parser_AST.Discrim uu___2 in + mk uu___1 + else + if + FStarC_Compiler_Util.starts_with s + FStarC_Syntax_Util.field_projector_prefix + then + (let rest = + FStarC_Compiler_Util.substring_from s + (FStarC_Compiler_String.length + FStarC_Syntax_Util.field_projector_prefix) in + let r = + FStarC_Compiler_Util.split rest + FStarC_Syntax_Util.field_projector_sep in + match r with + | fst::snd::[] -> + let l = + FStarC_Ident.lid_of_path [fst] + t.FStarC_Syntax_Syntax.pos in + let r1 = + FStarC_Ident.mk_ident + (snd, (t.FStarC_Syntax_Syntax.pos)) in + mk (FStarC_Parser_AST.Projector (l, r1)) + | uu___2 -> failwith "wrong projector format") + else + (let uu___3 = + FStarC_Ident.lid_equals a FStarC_Parser_Const.smtpat_lid in + if uu___3 + then + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Ident.range_of_lid a in + ("SMTPat", uu___7) in + FStarC_Ident.mk_ident uu___6 in + FStarC_Parser_AST.Tvar uu___5 in + mk uu___4 + else + (let uu___5 = + FStarC_Ident.lid_equals a + FStarC_Parser_Const.smtpatOr_lid in + if uu___5 + then + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = FStarC_Ident.range_of_lid a in + ("SMTPatOr", uu___9) in + FStarC_Ident.mk_ident uu___8 in + FStarC_Parser_AST.Tvar uu___7 in + mk uu___6 + else + (let uu___7 = + ((FStarC_Ident.lid_equals a + FStarC_Parser_Const.assert_lid) + || + (FStarC_Ident.lid_equals a + FStarC_Parser_Const.assume_lid)) + || + (let uu___8 = + let uu___9 = + FStarC_Compiler_String.get s Prims.int_zero in + FStar_Char.uppercase uu___9 in + let uu___9 = + FStarC_Compiler_String.get s Prims.int_zero in + uu___8 <> uu___9) in + if uu___7 + then + let uu___8 = + let uu___9 = maybe_shorten_fv env fv in + FStarC_Parser_AST.Var uu___9 in + mk uu___8 + else + (let uu___9 = + let uu___10 = + let uu___11 = maybe_shorten_fv env fv in + (uu___11, []) in + FStarC_Parser_AST.Construct uu___10 in + mk uu___9)))) + | FStarC_Syntax_Syntax.Tm_uinst (e, universes) -> + let e1 = resugar_term' env e in + let uu___1 = FStarC_Options.print_universes () in + if uu___1 + then + let univs = + FStarC_Compiler_List.map + (fun x -> resugar_universe x t.FStarC_Syntax_Syntax.pos) + universes in + (match e1 with + | { + FStarC_Parser_AST.tm = FStarC_Parser_AST.Construct + (hd, args); + FStarC_Parser_AST.range = r; FStarC_Parser_AST.level = l;_} + -> + let args1 = + let uu___2 = + FStarC_Compiler_List.map + (fun u -> (u, FStarC_Parser_AST.UnivApp)) univs in + FStarC_Compiler_List.op_At args uu___2 in + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.Construct (hd, args1)) r l + | uu___2 -> + FStarC_Compiler_List.fold_left + (fun acc -> + fun u -> + mk + (FStarC_Parser_AST.App + (acc, u, FStarC_Parser_AST.UnivApp))) e1 univs) + else e1 + | FStarC_Syntax_Syntax.Tm_constant c -> + let uu___1 = FStarC_Syntax_Syntax.is_teff t in + if uu___1 + then + let uu___2 = name "Effect" t.FStarC_Syntax_Syntax.pos in + mk uu___2 + else mk (FStarC_Parser_AST.Const c) + | FStarC_Syntax_Syntax.Tm_type u -> + let uu___1 = + match u with + | FStarC_Syntax_Syntax.U_zero -> ("Type0", false) + | FStarC_Syntax_Syntax.U_unknown -> ("Type", false) + | uu___2 -> ("Type", true) in + (match uu___1 with + | (nm, needs_app) -> + let typ = + let uu___2 = name nm t.FStarC_Syntax_Syntax.pos in mk uu___2 in + let uu___2 = needs_app && (FStarC_Options.print_universes ()) in + if uu___2 + then + let uu___3 = + let uu___4 = + let uu___5 = + resugar_universe u t.FStarC_Syntax_Syntax.pos in + (typ, uu___5, FStarC_Parser_AST.UnivApp) in + FStarC_Parser_AST.App uu___4 in + mk uu___3 + else typ) + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = xs; FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = uu___1;_} + -> + let uu___2 = FStarC_Syntax_Subst.open_term xs body in + (match uu___2 with + | (xs1, body1) -> + let xs2 = filter_imp_bs xs1 in + let body_bv = FStarC_Syntax_Free.names body1 in + let patterns = + FStarC_Compiler_List.map + (fun x -> + resugar_bv_as_pat env x.FStarC_Syntax_Syntax.binder_bv + x.FStarC_Syntax_Syntax.binder_qual body_bv) xs2 in + let body2 = resugar_term' env body1 in + if FStarC_Compiler_List.isEmpty patterns + then body2 + else mk (FStarC_Parser_AST.Abs (patterns, body2))) + | FStarC_Syntax_Syntax.Tm_arrow uu___1 -> + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Util.canon_arrow t in + FStarC_Syntax_Subst.compress uu___5 in + uu___4.FStarC_Syntax_Syntax.n in + match uu___3 with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = xs; + FStarC_Syntax_Syntax.comp = body;_} + -> (xs, body) + | uu___4 -> failwith "impossible: Tm_arrow in resugar_term" in + (match uu___2 with + | (xs, body) -> + let uu___3 = FStarC_Syntax_Subst.open_comp xs body in + (match uu___3 with + | (xs1, body1) -> + let xs2 = filter_imp_bs xs1 in + let body2 = resugar_comp' env body1 in + let xs3 = + let uu___4 = + FStarC_Compiler_List.map + (fun b -> + resugar_binder' env b t.FStarC_Syntax_Syntax.pos) + xs2 in + FStarC_Compiler_List.rev uu___4 in + let rec aux body3 uu___4 = + match uu___4 with + | [] -> body3 + | hd::tl -> + let body4 = + mk (FStarC_Parser_AST.Product ([hd], body3)) in + aux body4 tl in + aux body2 xs3)) + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x; FStarC_Syntax_Syntax.phi = phi;_} -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.mk_binder x in [uu___3] in + FStarC_Syntax_Subst.open_term uu___2 phi in + (match uu___1 with + | (x1, phi1) -> + let b = + let uu___2 = FStarC_Compiler_List.hd x1 in + resugar_binder' env uu___2 t.FStarC_Syntax_Syntax.pos in + let uu___2 = + let uu___3 = + let uu___4 = resugar_term' env phi1 in (b, uu___4) in + FStarC_Parser_AST.Refine uu___3 in + mk uu___2) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar fv; + FStarC_Syntax_Syntax.pos = uu___1; + FStarC_Syntax_Syntax.vars = uu___2; + FStarC_Syntax_Syntax.hash_code = uu___3;_}; + FStarC_Syntax_Syntax.args = (e, uu___4)::[];_} + when + (let uu___5 = FStarC_Options.print_implicits () in + Prims.op_Negation uu___5) && + (FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.b2t_lid) + -> resugar_term' env e + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = hd; FStarC_Syntax_Syntax.args = args;_} + when + let uu___1 = can_resugar_machine_integer hd args in + FStar_Pervasives_Native.uu___is_Some uu___1 -> + let uu___1 = can_resugar_machine_integer hd args in + (match uu___1 with + | FStar_Pervasives_Native.Some (fv, i) -> + resugar_machine_integer fv i t.FStarC_Syntax_Syntax.pos) + | FStarC_Syntax_Syntax.Tm_app uu___1 -> + let t1 = FStarC_Syntax_Util.canon_app t in + let uu___2 = t1.FStarC_Syntax_Syntax.n in + (match uu___2 with + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = e; + FStarC_Syntax_Syntax.args = args;_} + -> + let is_hide_or_reveal e1 = + let uu___3 = FStarC_Syntax_Util.un_uinst e1 in + match uu___3 with + | { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar fv; + FStarC_Syntax_Syntax.pos = uu___4; + FStarC_Syntax_Syntax.vars = uu___5; + FStarC_Syntax_Syntax.hash_code = uu___6;_} -> + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.hide) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.reveal) + | uu___4 -> false in + let rec last uu___3 = + match uu___3 with + | hd::[] -> [hd] + | hd::tl -> last tl + | uu___4 -> failwith "last of an empty list" in + let first_two_explicit args1 = + let rec drop_implicits args2 = + match args2 with + | (uu___3, FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = uu___4;_})::tl + -> drop_implicits tl + | uu___3 -> args2 in + let uu___3 = drop_implicits args1 in + match uu___3 with + | [] -> failwith "not_enough explicit_arguments" + | uu___4::[] -> failwith "not_enough explicit_arguments" + | a1::a2::uu___4 -> [a1; a2] in + let resugar_as_app e1 args1 = + let args2 = + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with + | (e2, qual) -> + let uu___4 = resugar_term' env e2 in + let uu___5 = resugar_aqual env qual in + (uu___4, uu___5)) args1 in + let uu___3 = resugar_term' env e1 in + match uu___3 with + | { + FStarC_Parser_AST.tm = FStarC_Parser_AST.Construct + (hd, previous_args); + FStarC_Parser_AST.range = r; + FStarC_Parser_AST.level = l;_} -> + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.Construct + (hd, + (FStarC_Compiler_List.op_At previous_args args2))) + r l + | e2 -> + FStarC_Compiler_List.fold_left + (fun acc -> + fun uu___4 -> + match uu___4 with + | (x, qual) -> + mk (FStarC_Parser_AST.App (acc, x, qual))) e2 + args2 in + let args1 = filter_imp_args args in + let is_projector t2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Subst.compress t2 in + FStarC_Syntax_Util.un_uinst uu___5 in + uu___4.FStarC_Syntax_Syntax.n in + match uu___3 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let a = + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + let length = + let uu___4 = + FStarC_Ident.nsstr + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + FStarC_Compiler_String.length uu___4 in + let s = + if length = Prims.int_zero + then FStarC_Ident.string_of_lid a + else + (let uu___5 = FStarC_Ident.string_of_lid a in + FStarC_Compiler_Util.substring_from uu___5 + (length + Prims.int_one)) in + if + FStarC_Compiler_Util.starts_with s + FStarC_Syntax_Util.field_projector_prefix + then + let rest = + FStarC_Compiler_Util.substring_from s + (FStarC_Compiler_String.length + FStarC_Syntax_Util.field_projector_prefix) in + let r = + FStarC_Compiler_Util.split rest + FStarC_Syntax_Util.field_projector_sep in + (match r with + | fst::snd::[] -> + let l = + FStarC_Ident.lid_of_path [fst] + t2.FStarC_Syntax_Syntax.pos in + let r1 = + FStarC_Ident.mk_ident + (snd, (t2.FStarC_Syntax_Syntax.pos)) in + FStar_Pervasives_Native.Some (l, r1) + | uu___4 -> failwith "wrong projector format") + else FStar_Pervasives_Native.None + | uu___4 -> FStar_Pervasives_Native.None in + let uu___3 = + ((let uu___4 = is_projector e in + FStar_Pervasives_Native.uu___is_Some uu___4) && + ((FStarC_Compiler_List.length args1) >= Prims.int_one)) + && + (let uu___4 = + let uu___5 = FStarC_Compiler_List.hd args1 in + FStar_Pervasives_Native.snd uu___5 in + FStar_Pervasives_Native.uu___is_None uu___4) in + if uu___3 + then + let uu___4 = args1 in + (match uu___4 with + | arg1::rest_args -> + let uu___5 = + let uu___6 = is_projector e in + FStar_Pervasives_Native.__proj__Some__item__v uu___6 in + (match uu___5 with + | (uu___6, fi) -> + let arg = + resugar_term' env + (FStar_Pervasives_Native.fst arg1) in + let h = + let uu___7 = + let uu___8 = + let uu___9 = FStarC_Ident.lid_of_ids [fi] in + (arg, uu___9) in + FStarC_Parser_AST.Project uu___8 in + mk uu___7 in + FStarC_Compiler_List.fold_left + (fun acc -> + fun uu___7 -> + match uu___7 with + | (a, q) -> + let aa = resugar_term' env a in + let qq = resugar_aqual env q in + mk + (FStarC_Parser_AST.App (acc, aa, qq))) + h rest_args)) + else + (let uu___5 = + (((let uu___6 = FStarC_Options.print_implicits () in + Prims.op_Negation uu___6) && + (let uu___6 = + FStarC_Options_Ext.get "show_hide_reveal" in + uu___6 = "")) + && (is_hide_or_reveal e)) + && + ((FStarC_Compiler_List.length args1) = Prims.int_one) in + if uu___5 + then + let uu___6 = args1 in + match uu___6 with + | (e1, uu___7)::[] -> resugar_term' env e1 + else + (let unsnoc l = + let rec unsnoc' acc uu___7 = + match uu___7 with + | [] -> failwith "unsnoc: empty list" + | x::[] -> ((FStarC_Compiler_List.rev acc), x) + | x::xs -> unsnoc' (x :: acc) xs in + unsnoc' [] l in + let resugar_tuple_type env1 args2 = + let typs = + FStarC_Compiler_List.map + (fun uu___7 -> + match uu___7 with + | (x, uu___8) -> resugar_term' env1 x) args2 in + let uu___7 = unsnoc typs in + match uu___7 with + | (pre, last1) -> + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Compiler_List.map + (fun uu___11 -> + FStar_Pervasives.Inr uu___11) pre in + (uu___10, last1) in + FStarC_Parser_AST.Sum uu___9 in + mk uu___8 in + let resugar_dtuple_type env1 hd args2 = + let fancy_resugar uu___7 = + (fun uu___7 -> + let n = FStarC_Compiler_List.length args2 in + let take n1 l = + let uu___8 = FStarC_Compiler_List.splitAt n1 l in + FStar_Pervasives_Native.fst uu___8 in + let uu___8 = + let uu___9 = + let uu___10 = FStarC_Compiler_List.last args2 in + FStar_Pervasives_Native.fst uu___10 in + FStarC_Syntax_Util.abs_formals uu___9 in + match uu___8 with + | (bs, uu___9, uu___10) -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () + (if + (FStarC_Compiler_List.length bs) < + (n - Prims.int_one) + then FStar_Pervasives_Native.None + else FStar_Pervasives_Native.Some ()) + (fun uu___11 -> + (fun uu___11 -> + let uu___11 = Obj.magic uu___11 in + let bs1 = + take (n - Prims.int_one) bs in + let concatM uu___12 l = + FStarC_Class_Monad.mapM uu___12 + () () + (fun uu___13 -> + (fun x -> + let x = Obj.magic x in + Obj.magic x) uu___13) + (Obj.magic l) in + let rec open_lambda_binders + uu___13 uu___12 = + (fun t2 -> + fun bs2 -> + match bs2 with + | [] -> + Obj.magic + (Obj.repr + (FStar_Pervasives_Native.Some + t2)) + | b::bs3 -> + Obj.magic + (Obj.repr + (let uu___12 = + FStarC_Syntax_Util.abs_one_ln + t2 in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () + (Obj.magic + uu___12) + (fun uu___13 -> + (fun uu___13 + -> + let uu___13 + = + Obj.magic + uu___13 in + match uu___13 + with + | + (uu___14, + body) -> + let uu___15 + = + FStarC_Syntax_Subst.open_term + [b] body in + (match uu___15 + with + | + (uu___16, + body1) -> + Obj.magic + (open_lambda_binders + body1 bs3))) + uu___13)))) + uu___13 uu___12 in + let uu___12 = + Obj.magic + (FStarC_Class_Monad.mapMi + FStarC_Class_Monad.monad_option + () () + (fun uu___14 -> + fun uu___13 -> + (fun i -> + fun uu___13 -> + let uu___13 = + Obj.magic + uu___13 in + match uu___13 + with + | (t2, uu___14) + -> + let uu___15 = + take i bs1 in + Obj.magic + (open_lambda_binders + t2 + uu___15)) + uu___14 uu___13) + (Obj.magic args2)) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___12) + (fun uu___13 -> + (fun opened_bs_types -> + let opened_bs_types = + Obj.magic + opened_bs_types in + let set_binder_sort t2 + b = + { + FStarC_Syntax_Syntax.binder_bv + = + (let uu___13 = + b.FStarC_Syntax_Syntax.binder_bv in + { + FStarC_Syntax_Syntax.ppname + = + (uu___13.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index + = + (uu___13.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort + = t2 + }); + FStarC_Syntax_Syntax.binder_qual + = + (b.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity + = + (b.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs + = + (b.FStarC_Syntax_Syntax.binder_attrs) + } in + let uu___13 = + unsnoc + opened_bs_types in + match uu___13 with + | (pre_bs_types, + last_type) -> + let bs2 = + FStarC_Compiler_List.map2 + (fun b -> + fun t2 -> + let b1 = + set_binder_sort + t2 b in + resugar_binder' + env1 b1 + t2.FStarC_Syntax_Syntax.pos) + bs1 + pre_bs_types in + let uu___14 = + let uu___15 = + let uu___16 = + let uu___17 = + FStarC_Compiler_List.map + ( + fun + uu___18 + -> + FStar_Pervasives.Inl + uu___18) + bs2 in + let uu___18 = + resugar_term' + env1 + last_type in + (uu___17, + uu___18) in + FStarC_Parser_AST.Sum + uu___16 in + mk uu___15 in + Obj.magic + (FStar_Pervasives_Native.Some + uu___14)) + uu___13))) uu___11))) + uu___7 in + let uu___7 = fancy_resugar () in + match uu___7 with + | FStar_Pervasives_Native.Some r -> r + | FStar_Pervasives_Native.None -> + resugar_as_app hd args2 in + let uu___7 = is_list_literal t1 in + match uu___7 with + | FStar_Pervasives_Native.Some ts -> + let uu___8 = + let uu___9 = + FStarC_Compiler_List.map (resugar_term' env) ts in + FStarC_Parser_AST.ListLiteral uu___9 in + mk uu___8 + | FStar_Pervasives_Native.None -> + let uu___8 = is_seq_literal t1 in + (match uu___8 with + | FStar_Pervasives_Native.Some ts -> + let uu___9 = + let uu___10 = + FStarC_Compiler_List.map + (resugar_term' env) ts in + FStarC_Parser_AST.SeqLiteral uu___10 in + mk uu___9 + | FStar_Pervasives_Native.None -> + let uu___9 = resugar_term_as_op e in + (match uu___9 with + | FStar_Pervasives_Native.None -> + resugar_as_app e args1 + | FStar_Pervasives_Native.Some + ("calc_finish", uu___10) -> + let uu___11 = resugar_calc env t1 in + (match uu___11 with + | FStar_Pervasives_Native.Some r -> r + | uu___12 -> resugar_as_app e args1) + | FStar_Pervasives_Native.Some ("tuple", n) + when + (FStar_Pervasives_Native.Some + (FStarC_Compiler_List.length args1)) + = n + -> resugar_tuple_type env args1 + | FStar_Pervasives_Native.Some ("dtuple", n) + when + (FStar_Pervasives_Native.Some + (FStarC_Compiler_List.length args1)) + = n + -> resugar_dtuple_type env e args1 + | FStar_Pervasives_Native.Some + (ref_read, uu___10) when + let uu___11 = + FStarC_Ident.string_of_lid + FStarC_Parser_Const.sread_lid in + ref_read = uu___11 -> + let uu___11 = + FStarC_Compiler_List.hd args1 in + (match uu___11 with + | (t2, uu___12) -> + let uu___13 = + let uu___14 = + FStarC_Syntax_Subst.compress t2 in + uu___14.FStarC_Syntax_Syntax.n in + (match uu___13 with + | FStarC_Syntax_Syntax.Tm_fvar fv + when + let uu___14 = + FStarC_Ident.string_of_lid + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + FStarC_Syntax_Util.field_projector_contains_constructor + uu___14 + -> + let f = + let uu___14 = + let uu___15 = + FStarC_Ident.string_of_lid + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + [uu___15] in + FStarC_Ident.lid_of_path + uu___14 + t2.FStarC_Syntax_Syntax.pos in + let uu___14 = + let uu___15 = + let uu___16 = + resugar_term' env t2 in + (uu___16, f) in + FStarC_Parser_AST.Project + uu___15 in + mk uu___14 + | uu___14 -> resugar_term' env t2)) + | FStar_Pervasives_Native.Some + ("try_with", uu___10) when + (FStarC_Compiler_List.length args1) > + Prims.int_one + -> + (try + (fun uu___11 -> + match () with + | () -> + let new_args = + first_two_explicit args1 in + let uu___12 = + match new_args with + | (a1, uu___13)::(a2, uu___14)::[] + -> (a1, a2) + | uu___13 -> + failwith + "wrong arguments to try_with" in + (match uu___12 with + | (body, handler) -> + let decomp term = + let uu___13 = + let uu___14 = + FStarC_Syntax_Subst.compress + term in + uu___14.FStarC_Syntax_Syntax.n in + match uu___13 with + | FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs + = x; + FStarC_Syntax_Syntax.body + = e1; + FStarC_Syntax_Syntax.rc_opt + = uu___14;_} + -> + let uu___15 = + FStarC_Syntax_Subst.open_term + x e1 in + (match uu___15 with + | (x1, e2) -> e2) + | uu___14 -> + let uu___15 = + let uu___16 = + let uu___17 = + resugar_term' + env term in + FStarC_Parser_AST.term_to_string + uu___17 in + Prims.strcat + "wrong argument format to try_with: " + uu___16 in + failwith uu___15 in + let body1 = + let uu___13 = decomp body in + resugar_term' env uu___13 in + let handler1 = + let uu___13 = + decomp handler in + resugar_term' env uu___13 in + let rec resugar_body t2 = + match t2.FStarC_Parser_AST.tm + with + | FStarC_Parser_AST.Match + (e1, + FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None, + (uu___13, uu___14, + b)::[]) + -> b + | FStarC_Parser_AST.Let + (uu___13, uu___14, b) + -> b + | FStarC_Parser_AST.Ascribed + (t11, t21, t3, + use_eq) + -> + let uu___13 = + let uu___14 = + let uu___15 = + resugar_body + t11 in + (uu___15, t21, + t3, use_eq) in + FStarC_Parser_AST.Ascribed + uu___14 in + mk uu___13 + | uu___13 -> + failwith + "unexpected body format to try_with" in + let e1 = resugar_body body1 in + let rec resugar_branches t2 + = + match t2.FStarC_Parser_AST.tm + with + | FStarC_Parser_AST.Match + (e2, + FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None, + branches) + -> branches + | FStarC_Parser_AST.Ascribed + (t11, t21, t3, + uu___13) + -> + resugar_branches t11 + | uu___13 -> [] in + let branches = + resugar_branches handler1 in + mk + (FStarC_Parser_AST.TryWith + (e1, branches)))) () + with | uu___11 -> resugar_as_app e args1) + | FStar_Pervasives_Native.Some + ("try_with", uu___10) -> + resugar_as_app e args1 + | FStar_Pervasives_Native.Some (op, uu___10) + when + (((((((op = "=") || (op = "==")) || + (op = "===")) + || (op = "@")) + || (op = ":=")) + || (op = "|>")) + || (op = "<<")) + && (FStarC_Options.print_implicits ()) + -> resugar_as_app e args1 + | FStar_Pervasives_Native.Some (op, uu___10) + when + (FStarC_Compiler_Util.starts_with op + "forall") + || + (FStarC_Compiler_Util.starts_with op + "exists") + -> + let rec uncurry xs pats t2 flavor_matches + = + match t2.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.QExists + (xs', (uu___11, pats'), body) when + flavor_matches t2 -> + uncurry + (FStarC_Compiler_List.op_At xs xs') + (FStarC_Compiler_List.op_At pats + pats') body flavor_matches + | FStarC_Parser_AST.QForall + (xs', (uu___11, pats'), body) when + flavor_matches t2 -> + uncurry + (FStarC_Compiler_List.op_At xs xs') + (FStarC_Compiler_List.op_At pats + pats') body flavor_matches + | FStarC_Parser_AST.QuantOp + (uu___11, xs', (uu___12, pats'), + body) + when flavor_matches t2 -> + uncurry + (FStarC_Compiler_List.op_At xs xs') + (FStarC_Compiler_List.op_At pats + pats') body flavor_matches + | uu___11 -> (xs, pats, t2) in + let resugar_forall_body body = + let uu___11 = + let uu___12 = + FStarC_Syntax_Subst.compress body in + uu___12.FStarC_Syntax_Syntax.n in + match uu___11 with + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = xs; + FStarC_Syntax_Syntax.body = body1; + FStarC_Syntax_Syntax.rc_opt = + uu___12;_} + -> + let uu___13 = + FStarC_Syntax_Subst.open_term xs + body1 in + (match uu___13 with + | (xs1, body2) -> + let xs2 = filter_imp_bs xs1 in + let xs3 = + FStarC_Compiler_List.map + (fun b -> + resugar_binder' env b + t1.FStarC_Syntax_Syntax.pos) + xs2 in + let uu___14 = + let uu___15 = + let uu___16 = + FStarC_Syntax_Subst.compress + body2 in + uu___16.FStarC_Syntax_Syntax.n in + match uu___15 with + | FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 + = e1; + FStarC_Syntax_Syntax.meta + = m;_} + -> + let body3 = + resugar_term' env e1 in + let uu___16 = + match m with + | FStarC_Syntax_Syntax.Meta_pattern + (uu___17, pats) -> + let uu___18 = + FStarC_Compiler_List.map + (fun es -> + FStarC_Compiler_List.map + (fun + uu___19 + -> + match uu___19 + with + | + (e2, + uu___20) + -> + resugar_term' + env e2) + es) pats in + (uu___18, body3) + | FStarC_Syntax_Syntax.Meta_labeled + (s, r, p) -> + let uu___17 = + let uu___18 = + let uu___19 = + let uu___20 = + FStarC_Errors_Msg.rendermsg + s in + (body3, + uu___20, p) in + FStarC_Parser_AST.Labeled + uu___19 in + mk uu___18 in + ([], uu___17) + | uu___17 -> + failwith + "wrong pattern format for QForall/QExists" in + (match uu___16 with + | (pats, body4) -> + (pats, body4)) + | uu___16 -> + let uu___17 = + resugar_term' env body2 in + ([], uu___17) in + (match uu___14 with + | (pats, body3) -> + let decompile_op op1 = + let uu___15 = + FStarC_Parser_AST.string_to_op + op1 in + match uu___15 with + | FStar_Pervasives_Native.None + -> op1 + | FStar_Pervasives_Native.Some + (op2, uu___16) -> + op2 in + let flavor_matches t2 = + match ((t2.FStarC_Parser_AST.tm), + op) + with + | (FStarC_Parser_AST.QExists + uu___15, "exists") -> + true + | (FStarC_Parser_AST.QForall + uu___15, "forall") -> + true + | (FStarC_Parser_AST.QuantOp + (id, uu___15, + uu___16, uu___17), + uu___18) -> + let uu___19 = + FStarC_Ident.string_of_id + id in + uu___19 = op + | uu___15 -> false in + let uu___15 = + uncurry xs3 pats body3 + flavor_matches in + (match uu___15 with + | (xs4, pats1, body4) -> + let binders = + FStarC_Parser_AST.idents_of_binders + xs4 + t1.FStarC_Syntax_Syntax.pos in + if op = "forall" + then + mk + (FStarC_Parser_AST.QForall + (xs4, + (binders, + pats1), + body4)) + else + if op = "exists" + then + mk + (FStarC_Parser_AST.QExists + (xs4, + (binders, + pats1), + body4)) + else + (let uu___18 = + let uu___19 = + let uu___20 + = + FStarC_Ident.id_of_text + op in + (uu___20, + xs4, + (binders, + pats1), + body4) in + FStarC_Parser_AST.QuantOp + uu___19 in + mk uu___18)))) + | uu___12 -> + if op = "forall" + then + let uu___13 = + let uu___14 = + let uu___15 = + resugar_term' env body in + ([], ([], []), uu___15) in + FStarC_Parser_AST.QForall + uu___14 in + mk uu___13 + else + (let uu___14 = + let uu___15 = + let uu___16 = + resugar_term' env body in + ([], ([], []), uu___16) in + FStarC_Parser_AST.QExists + uu___15 in + mk uu___14) in + if + (FStarC_Compiler_List.length args1) > + Prims.int_zero + then + let args2 = last args1 in + (match args2 with + | (b, uu___11)::[] -> + resugar_forall_body b + | uu___11 -> + failwith + "wrong args format to QForall") + else resugar_as_app e args1 + | FStar_Pervasives_Native.Some + ("alloc", uu___10) -> + let uu___11 = + FStarC_Compiler_List.hd args1 in + (match uu___11 with + | (e1, uu___12) -> resugar_term' env e1) + | FStar_Pervasives_Native.Some + (op, expected_arity1) -> + let op1 = FStarC_Ident.id_of_text op in + let resugar args2 = + FStarC_Compiler_List.map + (fun uu___10 -> + match uu___10 with + | (e1, qual) -> + let uu___11 = + resugar_term' env e1 in + let uu___12 = + resugar_aqual env qual in + (uu___11, uu___12)) args2 in + (match expected_arity1 with + | FStar_Pervasives_Native.None -> + let resugared_args = resugar args1 in + let expect_n = + FStarC_Parser_ToDocument.handleable_args_length + op1 in + if + (FStarC_Compiler_List.length + resugared_args) + >= expect_n + then + let uu___10 = + FStarC_Compiler_Util.first_N + expect_n resugared_args in + (match uu___10 with + | (op_args, rest) -> + let head = + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Compiler_List.map + FStar_Pervasives_Native.fst + op_args in + (op1, uu___13) in + FStarC_Parser_AST.Op + uu___12 in + mk uu___11 in + FStarC_Compiler_List.fold_left + (fun head1 -> + fun uu___11 -> + match uu___11 with + | (arg, qual) -> + mk + (FStarC_Parser_AST.App + (head1, arg, + qual))) head + rest) + else resugar_as_app e args1 + | FStar_Pervasives_Native.Some n when + (FStarC_Compiler_List.length args1) = + n + -> + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = resugar args1 in + FStarC_Compiler_List.map + FStar_Pervasives_Native.fst + uu___13 in + (op1, uu___12) in + FStarC_Parser_AST.Op uu___11 in + mk uu___10 + | uu___10 -> resugar_as_app e args1)))))) + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = e; + FStarC_Syntax_Syntax.ret_opt = FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.brs = (pat, wopt, t1)::[]; + FStarC_Syntax_Syntax.rc_opt1 = uu___1;_} + -> + let uu___2 = FStarC_Syntax_Subst.open_branch (pat, wopt, t1) in + (match uu___2 with + | (pat1, wopt1, t2) -> + let branch_bv = FStarC_Syntax_Free.names t2 in + let bnds = + let uu___3 = + let uu___4 = + let uu___5 = resugar_pat' env pat1 branch_bv in + let uu___6 = resugar_term' env e in (uu___5, uu___6) in + (FStar_Pervasives_Native.None, uu___4) in + [uu___3] in + let body = resugar_term' env t2 in + mk + (FStarC_Parser_AST.Let + (FStarC_Parser_AST.NoLetQualifier, bnds, body))) + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = e; + FStarC_Syntax_Syntax.ret_opt = asc_opt; + FStarC_Syntax_Syntax.brs = branches; + FStarC_Syntax_Syntax.rc_opt1 = uu___1;_} + -> + let resugar_branch uu___2 = + match uu___2 with + | (pat, wopt, b) -> + let uu___3 = FStarC_Syntax_Subst.open_branch (pat, wopt, b) in + (match uu___3 with + | (pat1, wopt1, b1) -> + let branch_bv = FStarC_Syntax_Free.names b1 in + let pat2 = resugar_pat' env pat1 branch_bv in + let wopt2 = + match wopt1 with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some e1 -> + let uu___4 = resugar_term' env e1 in + FStar_Pervasives_Native.Some uu___4 in + let b2 = resugar_term' env b1 in (pat2, wopt2, b2)) in + let asc_opt1 = + resugar_match_returns env e t.FStarC_Syntax_Syntax.pos asc_opt in + let uu___2 = + let uu___3 = + let uu___4 = resugar_term' env e in + let uu___5 = FStarC_Compiler_List.map resugar_branch branches in + (uu___4, FStar_Pervasives_Native.None, asc_opt1, uu___5) in + FStarC_Parser_AST.Match uu___3 in + mk uu___2 + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = e; FStarC_Syntax_Syntax.asc = asc; + FStarC_Syntax_Syntax.eff_opt = uu___1;_} + -> + let uu___2 = resugar_ascription env asc in + (match uu___2 with + | (asc1, tac_opt, b) -> + let uu___3 = + let uu___4 = + let uu___5 = resugar_term' env e in + (uu___5, asc1, tac_opt, b) in + FStarC_Parser_AST.Ascribed uu___4 in + mk uu___3) + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (is_rec, source_lbs); + FStarC_Syntax_Syntax.body1 = body;_} + -> + let mk_pat a = + FStarC_Parser_AST.mk_pattern a t.FStarC_Syntax_Syntax.pos in + let uu___1 = FStarC_Syntax_Subst.open_let_rec source_lbs body in + (match uu___1 with + | (source_lbs1, body1) -> + let resugar_one_binding bnd = + let attrs_opt = + match bnd.FStarC_Syntax_Syntax.lbattrs with + | [] -> FStar_Pervasives_Native.None + | tms -> + let uu___2 = + FStarC_Compiler_List.map (resugar_term' env) tms in + FStar_Pervasives_Native.Some uu___2 in + let uu___2 = + let uu___3 = + FStarC_Syntax_Util.mk_conj + bnd.FStarC_Syntax_Syntax.lbtyp + bnd.FStarC_Syntax_Syntax.lbdef in + FStarC_Syntax_Subst.open_univ_vars + bnd.FStarC_Syntax_Syntax.lbunivs uu___3 in + match uu___2 with + | (univs, td) -> + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Subst.compress td in + uu___5.FStarC_Syntax_Syntax.n in + match uu___4 with + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = uu___5; + FStarC_Syntax_Syntax.args = + (t1, uu___6)::(d, uu___7)::[];_} + -> (t1, d) + | uu___5 -> failwith "wrong let binding format" in + (match uu___3 with + | (typ, def) -> + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Syntax_Subst.compress def in + uu___6.FStarC_Syntax_Syntax.n in + match uu___5 with + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = b; + FStarC_Syntax_Syntax.body = t1; + FStarC_Syntax_Syntax.rc_opt = uu___6;_} + -> + let uu___7 = + FStarC_Syntax_Subst.open_term b t1 in + (match uu___7 with + | (b1, t2) -> + let b2 = filter_imp_bs b1 in + (b2, t2, true)) + | uu___6 -> ([], def, false) in + (match uu___4 with + | (binders, term, is_pat_app) -> + let uu___5 = + match bnd.FStarC_Syntax_Syntax.lbname with + | FStar_Pervasives.Inr fv -> + let uu___6 = + mk_pat + (FStarC_Parser_AST.PatName + ((fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v)) in + (uu___6, term) + | FStar_Pervasives.Inl bv -> + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = bv_as_unique_ident bv in + (uu___9, + FStar_Pervasives_Native.None, + []) in + FStarC_Parser_AST.PatVar uu___8 in + mk_pat uu___7 in + (uu___6, term) in + (match uu___5 with + | (pat, term1) -> + let uu___6 = + if is_pat_app + then + let args = + FStarC_Compiler_List.map + (fun b -> + let q = + resugar_bqual env + b.FStarC_Syntax_Syntax.binder_qual in + let uu___7 = + let uu___8 = + let uu___9 = + bv_as_unique_ident + b.FStarC_Syntax_Syntax.binder_bv in + let uu___10 = + FStarC_Compiler_List.map + (resugar_term' env) + b.FStarC_Syntax_Syntax.binder_attrs in + (uu___9, q, uu___10) in + FStarC_Parser_AST.PatVar + uu___8 in + mk_pat uu___7) binders in + let uu___7 = + let uu___8 = + mk_pat + (FStarC_Parser_AST.PatApp + (pat, args)) in + let uu___9 = + resugar_term' env term1 in + (uu___8, uu___9) in + let uu___8 = universe_to_string univs in + (uu___7, uu___8) + else + (let uu___8 = + let uu___9 = + resugar_term' env term1 in + (pat, uu___9) in + let uu___9 = + universe_to_string univs in + (uu___8, uu___9)) in + (attrs_opt, uu___6)))) in + let r = + FStarC_Compiler_List.map resugar_one_binding source_lbs1 in + let bnds = + let f uu___2 = + match uu___2 with + | (attrs, (pb, univs)) -> + let uu___3 = + let uu___4 = FStarC_Options.print_universes () in + Prims.op_Negation uu___4 in + if uu___3 + then (attrs, pb) + else + (let uu___5 = + let uu___6 = + label univs (FStar_Pervasives_Native.snd pb) in + ((FStar_Pervasives_Native.fst pb), uu___6) in + (attrs, uu___5)) in + FStarC_Compiler_List.map f r in + let body2 = resugar_term' env body1 in + mk + (FStarC_Parser_AST.Let + ((if is_rec + then FStarC_Parser_AST.Rec + else FStarC_Parser_AST.NoLetQualifier), bnds, body2))) + | FStarC_Syntax_Syntax.Tm_uvar (u, uu___1) -> + let s = + let uu___2 = + let uu___3 = + FStarC_Syntax_Unionfind.uvar_id + u.FStarC_Syntax_Syntax.ctx_uvar_head in + FStarC_Compiler_Util.string_of_int uu___3 in + Prims.strcat "?u" uu___2 in + let uu___2 = mk FStarC_Parser_AST.Wild in label s uu___2 + | FStarC_Syntax_Syntax.Tm_quoted (tm, qi) -> + let qi1 = + match qi.FStarC_Syntax_Syntax.qkind with + | FStarC_Syntax_Syntax.Quote_static -> FStarC_Parser_AST.Static + | FStarC_Syntax_Syntax.Quote_dynamic -> FStarC_Parser_AST.Dynamic in + let uu___1 = + let uu___2 = let uu___3 = resugar_term' env tm in (uu___3, qi1) in + FStarC_Parser_AST.Quote uu___2 in + mk uu___1 + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = e; FStarC_Syntax_Syntax.meta = m;_} -> + let resugar_meta_desugared uu___1 = + match uu___1 with + | FStarC_Syntax_Syntax.Sequence -> + let term = resugar_term' env e in + let rec resugar_seq t1 = + match t1.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Let + (uu___2, (uu___3, (p, t11))::[], t2) -> + mk (FStarC_Parser_AST.Seq (t11, t2)) + | FStarC_Parser_AST.Ascribed (t11, t2, t3, use_eq) -> + let uu___2 = + let uu___3 = + let uu___4 = resugar_seq t11 in + (uu___4, t2, t3, use_eq) in + FStarC_Parser_AST.Ascribed uu___3 in + mk uu___2 + | uu___2 -> t1 in + resugar_seq term + | FStarC_Syntax_Syntax.Machine_integer (uu___2, uu___3) -> + resugar_term' env e + | FStarC_Syntax_Syntax.Primop -> resugar_term' env e + | FStarC_Syntax_Syntax.Masked_effect -> resugar_term' env e + | FStarC_Syntax_Syntax.Meta_smt_pat -> resugar_term' env e in + (match m with + | FStarC_Syntax_Syntax.Meta_labeled uu___1 -> resugar_term' env e + | FStarC_Syntax_Syntax.Meta_desugared i -> + resugar_meta_desugared i + | FStarC_Syntax_Syntax.Meta_named t1 -> + mk (FStarC_Parser_AST.Name t1) + | FStarC_Syntax_Syntax.Meta_pattern uu___1 -> resugar_term' env e + | FStarC_Syntax_Syntax.Meta_monadic uu___1 -> resugar_term' env e + | FStarC_Syntax_Syntax.Meta_monadic_lift uu___1 -> + resugar_term' env e) + | FStarC_Syntax_Syntax.Tm_unknown -> mk FStarC_Parser_AST.Wild +and (resugar_ascription : + FStarC_Syntax_DsEnv.env -> + ((FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax, + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax) + FStar_Pervasives.either * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax FStar_Pervasives_Native.option * + Prims.bool) -> + (FStarC_Parser_AST.term * FStarC_Parser_AST.term + FStar_Pervasives_Native.option * Prims.bool)) + = + fun env -> + fun uu___ -> + match uu___ with + | (asc, tac_opt, b) -> + let uu___1 = + match asc with + | FStar_Pervasives.Inl n -> resugar_term' env n + | FStar_Pervasives.Inr n -> resugar_comp' env n in + let uu___2 = + FStarC_Compiler_Util.map_opt tac_opt (resugar_term' env) in + (uu___1, uu___2, b) +and (resugar_calc : + FStarC_Syntax_DsEnv.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Parser_AST.term FStar_Pervasives_Native.option) + = + fun uu___1 -> + fun uu___ -> + (fun env -> + fun t0 -> + let mk a = + FStarC_Parser_AST.mk_term a t0.FStarC_Syntax_Syntax.pos + FStarC_Parser_AST.Un in + let resugar_calc_finish t = + let uu___ = FStarC_Syntax_Util.head_and_args t in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Util.un_uinst hd in + FStarC_Syntax_Subst.compress uu___4 in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (uu___2, FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = uu___3;_}):: + (rel, FStar_Pervasives_Native.None)::(uu___4, + FStar_Pervasives_Native.Some + { + FStarC_Syntax_Syntax.aqual_implicit + = true; + FStarC_Syntax_Syntax.aqual_attributes + = uu___5;_}):: + (uu___6, FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = uu___7;_}):: + (uu___8, FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = uu___9;_}):: + (pf, FStar_Pervasives_Native.None)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.calc_finish_lid + -> + let pf1 = FStarC_Syntax_Util.unthunk pf in + FStar_Pervasives_Native.Some (rel, pf1) + | uu___2 -> FStar_Pervasives_Native.None) in + let un_eta_rel rel = + let bv_eq_tm b t = + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_name b' when + FStarC_Syntax_Syntax.bv_eq b b' -> true + | uu___1 -> false in + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress rel in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = b1::b2::[]; + FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = uu___1;_} + -> + let uu___2 = FStarC_Syntax_Subst.open_term [b1; b2] body in + (match uu___2 with + | (b11::b21::[], body1) -> + let body2 = FStarC_Syntax_Util.unascribe body1 in + let body3 = + let uu___3 = FStarC_Syntax_Util.unb2t body2 in + match uu___3 with + | FStar_Pervasives_Native.Some body4 -> body4 + | FStar_Pervasives_Native.None -> body2 in + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.compress body3 in + uu___4.FStarC_Syntax_Syntax.n in + (match uu___3 with + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = e; + FStarC_Syntax_Syntax.args = args;_} + when + (FStarC_Compiler_List.length args) >= + (Prims.of_int (2)) + -> + (match FStarC_Compiler_List.rev args with + | (a1, FStar_Pervasives_Native.None)::(a2, + FStar_Pervasives_Native.None)::rest + -> + let uu___4 = + (bv_eq_tm + b11.FStarC_Syntax_Syntax.binder_bv a2) + && + (bv_eq_tm + b21.FStarC_Syntax_Syntax.binder_bv a1) in + if uu___4 + then + let uu___5 = + FStarC_Syntax_Util.mk_app e + (FStarC_Compiler_List.rev rest) in + FStar_Pervasives_Native.Some uu___5 + else FStar_Pervasives_Native.Some rel + | uu___4 -> FStar_Pervasives_Native.Some rel) + | uu___4 -> FStar_Pervasives_Native.Some rel)) + | uu___1 -> FStar_Pervasives_Native.Some rel in + let resugar_step pack = + let uu___ = FStarC_Syntax_Util.head_and_args pack in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Util.un_uinst hd in + FStarC_Syntax_Subst.compress uu___4 in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (uu___2, FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = uu___3;_}):: + (uu___4, FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = uu___5;_}):: + (uu___6, FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = uu___7;_}):: + (rel, FStar_Pervasives_Native.None)::(z, + FStar_Pervasives_Native.None):: + (uu___8, FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = uu___9;_}):: + (pf, FStar_Pervasives_Native.None)::(j, + FStar_Pervasives_Native.None)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.calc_step_lid + -> + let pf1 = FStarC_Syntax_Util.unthunk pf in + let j1 = FStarC_Syntax_Util.unthunk j in + FStar_Pervasives_Native.Some (z, rel, j1, pf1) + | uu___2 -> FStar_Pervasives_Native.None) in + let resugar_init pack = + let uu___ = FStarC_Syntax_Util.head_and_args pack in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Util.un_uinst hd in + FStarC_Syntax_Subst.compress uu___4 in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (uu___2, FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = uu___3;_}):: + (x, FStar_Pervasives_Native.None)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.calc_init_lid + -> FStar_Pervasives_Native.Some x + | uu___2 -> FStar_Pervasives_Native.None) in + let rec resugar_all_steps pack = + let uu___ = resugar_step pack in + match uu___ with + | FStar_Pervasives_Native.Some (t, r, j, k) -> + let uu___1 = resugar_all_steps k in + FStarC_Compiler_Util.bind_opt uu___1 + (fun uu___2 -> + match uu___2 with + | (steps, k1) -> + FStar_Pervasives_Native.Some + (((t, r, j) :: steps), k1)) + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.Some ([], pack) in + let resugar_rel rel = + let rel1 = + let uu___ = un_eta_rel rel in + match uu___ with + | FStar_Pervasives_Native.Some rel2 -> rel2 + | FStar_Pervasives_Native.None -> rel in + let fallback uu___ = + let uu___1 = + let uu___2 = resugar_term' env rel1 in + FStarC_Parser_AST.Paren uu___2 in + mk uu___1 in + let uu___ = resugar_term_as_op rel1 in + match uu___ with + | FStar_Pervasives_Native.Some (s, FStar_Pervasives_Native.None) + -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Ident.id_of_text s in (uu___3, []) in + FStarC_Parser_AST.Op uu___2 in + mk uu___1 + | FStar_Pervasives_Native.Some + (s, FStar_Pervasives_Native.Some uu___1) when + uu___1 = (Prims.of_int (2)) -> + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Ident.id_of_text s in (uu___4, []) in + FStarC_Parser_AST.Op uu___3 in + mk uu___2 + | uu___1 -> fallback () in + let build_calc rel x0 steps = + let r = resugar_term' env in + let uu___ = + let uu___1 = + let uu___2 = resugar_rel rel in + let uu___3 = r x0 in + let uu___4 = + FStarC_Compiler_List.map + (fun uu___5 -> + match uu___5 with + | (z, rel1, j) -> + let uu___6 = + let uu___7 = resugar_rel rel1 in + let uu___8 = r j in + let uu___9 = r z in (uu___7, uu___8, uu___9) in + FStarC_Parser_AST.CalcStep uu___6) steps in + (uu___2, uu___3, uu___4) in + FStarC_Parser_AST.CalcProof uu___1 in + mk uu___ in + let uu___ = resugar_calc_finish t0 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Class_Monad.monad_option + () () (Obj.magic uu___) + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + match uu___1 with + | (rel, pack) -> + let uu___2 = resugar_all_steps pack in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () + (Obj.magic uu___2) + (fun uu___3 -> + (fun uu___3 -> + let uu___3 = Obj.magic uu___3 in + match uu___3 with + | (steps, k) -> + let uu___4 = resugar_init k in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___4) + (fun uu___5 -> + (fun x0 -> + let x0 = Obj.magic x0 in + let uu___5 = + build_calc rel x0 + (FStarC_Compiler_List.rev + steps) in + Obj.magic + (FStar_Pervasives_Native.Some + uu___5)) uu___5))) + uu___3))) uu___1))) uu___1 uu___ +and (resugar_match_returns : + FStarC_Syntax_DsEnv.env -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Compiler_Range_Type.range -> + (FStarC_Syntax_Syntax.binder * + ((FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax, + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax) + FStar_Pervasives.either * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax FStar_Pervasives_Native.option * + Prims.bool)) FStar_Pervasives_Native.option -> + (FStarC_Ident.ident FStar_Pervasives_Native.option * + FStarC_Parser_AST.term * Prims.bool) + FStar_Pervasives_Native.option) + = + fun env -> + fun scrutinee -> + fun r -> + fun asc_opt -> + match asc_opt with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (b, asc) -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.open_ascription [b] asc in + match uu___1 with + | (bs, asc1) -> + let b1 = FStarC_Compiler_List.hd bs in + let uu___2 = + let uu___3 = + FStarC_Ident.string_of_id + (b1.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.ppname in + uu___3 = FStarC_Parser_Const.match_returns_def_name in + if uu___2 + then + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Subst.compress scrutinee in + FStarC_Syntax_Util.unascribe uu___5 in + uu___4.FStarC_Syntax_Syntax.n in + (match uu___3 with + | FStarC_Syntax_Syntax.Tm_name sbv -> + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Syntax.bv_to_name sbv in + ((b1.FStarC_Syntax_Syntax.binder_bv), + uu___8) in + FStarC_Syntax_Syntax.NT uu___7 in + [uu___6] in + FStarC_Syntax_Subst.subst_ascription uu___5 asc1 in + (FStar_Pervasives_Native.None, uu___4) + | uu___4 -> (FStar_Pervasives_Native.None, asc1)) + else ((FStar_Pervasives_Native.Some b1), asc1) in + (match uu___ with + | (bopt, asc1) -> + let bopt1 = + FStarC_Compiler_Util.map_option + (fun b1 -> + let uu___1 = resugar_binder' env b1 r in + FStarC_Parser_AST.ident_of_binder r uu___1) bopt in + let uu___1 = + let uu___2 = resugar_ascription env asc1 in + match uu___2 with + | (asc2, FStar_Pervasives_Native.None, use_eq) -> + (asc2, use_eq) + | uu___3 -> + failwith + "resugaring does not support match return annotation with a tactic" in + (match uu___1 with + | (asc2, use_eq) -> + FStar_Pervasives_Native.Some (bopt1, asc2, use_eq))) +and (resugar_comp' : + FStarC_Syntax_DsEnv.env -> + FStarC_Syntax_Syntax.comp -> FStarC_Parser_AST.term) + = + fun env -> + fun c -> + let mk a = + FStarC_Parser_AST.mk_term a c.FStarC_Syntax_Syntax.pos + FStarC_Parser_AST.Un in + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total typ -> + let t = resugar_term' env typ in + let uu___ = FStarC_Options.print_implicits () in + if uu___ + then + mk + (FStarC_Parser_AST.Construct + (FStarC_Parser_Const.effect_Tot_lid, + [(t, FStarC_Parser_AST.Nothing)])) + else t + | FStarC_Syntax_Syntax.GTotal typ -> + let t = resugar_term' env typ in + mk + (FStarC_Parser_AST.Construct + (FStarC_Parser_Const.effect_GTot_lid, + [(t, FStarC_Parser_AST.Nothing)])) + | FStarC_Syntax_Syntax.Comp c1 -> + let result = + let uu___ = resugar_term' env c1.FStarC_Syntax_Syntax.result_typ in + (uu___, FStarC_Parser_AST.Nothing) in + let mk_decreases fl = + let rec aux l uu___ = + match uu___ with + | [] -> l + | hd::tl -> + (match hd with + | FStarC_Syntax_Syntax.DECREASES dec_order -> + let d = + match dec_order with + | FStarC_Syntax_Syntax.Decreases_lex (t::[]) -> + resugar_term' env t + | FStarC_Syntax_Syntax.Decreases_lex ts -> + let uu___1 = + let uu___2 = + FStarC_Compiler_List.map (resugar_term' env) + ts in + FStarC_Parser_AST.LexList uu___2 in + mk uu___1 + | FStarC_Syntax_Syntax.Decreases_wf (rel, e) -> + let uu___1 = + let uu___2 = + let uu___3 = resugar_term' env rel in + let uu___4 = resugar_term' env e in + (uu___3, uu___4) in + FStarC_Parser_AST.WFOrder uu___2 in + mk uu___1 in + let e = + mk + (FStarC_Parser_AST.Decreases + (d, FStar_Pervasives_Native.None)) in + aux (e :: l) tl + | uu___1 -> aux l tl) in + aux [] fl in + let uu___ = + (FStarC_Ident.lid_equals c1.FStarC_Syntax_Syntax.effect_name + FStarC_Parser_Const.effect_Lemma_lid) + && + ((FStarC_Compiler_List.length + c1.FStarC_Syntax_Syntax.effect_args) + = (Prims.of_int (3))) in + if uu___ + then + let args = + FStarC_Compiler_List.map + (fun uu___1 -> + match uu___1 with + | (e, uu___2) -> + let uu___3 = resugar_term' env e in + (uu___3, FStarC_Parser_AST.Nothing)) + c1.FStarC_Syntax_Syntax.effect_args in + let uu___1 = + match c1.FStarC_Syntax_Syntax.effect_args with + | (pre, uu___2)::(post, uu___3)::(pats, uu___4)::[] -> + (pre, post, pats) + | uu___2 -> failwith "impossible" in + (match uu___1 with + | (pre, post, pats) -> + let pre1 = + let uu___2 = + FStarC_Syntax_Util.is_fvar FStarC_Parser_Const.true_lid + pre in + if uu___2 then [] else [pre] in + let post1 = FStarC_Syntax_Util.unthunk_lemma_post post in + let pats1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.head_of pats in + FStarC_Syntax_Util.is_fvar FStarC_Parser_Const.nil_lid + uu___3 in + if uu___2 then [] else [pats] in + let pre2 = + FStarC_Compiler_List.map + (fun t -> + let uu___2 = + let uu___3 = + let uu___4 = resugar_term' env t in + (uu___4, FStar_Pervasives_Native.None) in + FStarC_Parser_AST.Requires uu___3 in + mk uu___2) pre1 in + let post2 = + let uu___2 = + let uu___3 = + let uu___4 = resugar_term' env post1 in + (uu___4, FStar_Pervasives_Native.None) in + FStarC_Parser_AST.Ensures uu___3 in + mk uu___2 in + let pats2 = + FStarC_Compiler_List.map (resugar_term' env) pats1 in + let decrease = mk_decreases c1.FStarC_Syntax_Syntax.flags in + let uu___2 = + let uu___3 = + let uu___4 = + maybe_shorten_lid env + c1.FStarC_Syntax_Syntax.effect_name in + let uu___5 = + FStarC_Compiler_List.map + (fun t -> (t, FStarC_Parser_AST.Nothing)) + (FStarC_Compiler_List.op_At pre2 + (FStarC_Compiler_List.op_At (post2 :: decrease) + pats2)) in + (uu___4, uu___5) in + FStarC_Parser_AST.Construct uu___3 in + mk uu___2) + else + (let uu___2 = FStarC_Options.print_effect_args () in + if uu___2 + then + let args = + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with + | (e, uu___4) -> + let uu___5 = resugar_term' env e in + (uu___5, FStarC_Parser_AST.Nothing)) + c1.FStarC_Syntax_Syntax.effect_args in + let decrease = + let uu___3 = mk_decreases c1.FStarC_Syntax_Syntax.flags in + FStarC_Compiler_List.map + (fun t -> (t, FStarC_Parser_AST.Nothing)) uu___3 in + let uu___3 = + let uu___4 = + let uu___5 = + maybe_shorten_lid env + c1.FStarC_Syntax_Syntax.effect_name in + (uu___5, + (FStarC_Compiler_List.op_At (result :: decrease) args)) in + FStarC_Parser_AST.Construct uu___4 in + mk uu___3 + else + (let uu___4 = + let uu___5 = + let uu___6 = + maybe_shorten_lid env + c1.FStarC_Syntax_Syntax.effect_name in + (uu___6, [result]) in + FStarC_Parser_AST.Construct uu___5 in + mk uu___4)) +and (resugar_binder' : + FStarC_Syntax_DsEnv.env -> + FStarC_Syntax_Syntax.binder -> + FStarC_Compiler_Range_Type.range -> FStarC_Parser_AST.binder) + = + fun env -> + fun b -> + fun r -> + let imp = resugar_bqual env b.FStarC_Syntax_Syntax.binder_qual in + let e = + resugar_term' env + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + let attrs = + FStarC_Compiler_List.map (resugar_term' env) + b.FStarC_Syntax_Syntax.binder_attrs in + let b' = + match e.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Wild -> + let uu___ = bv_as_unique_ident b.FStarC_Syntax_Syntax.binder_bv in + FStarC_Parser_AST.Variable uu___ + | uu___ -> + let uu___1 = + FStarC_Syntax_Syntax.is_null_bv + b.FStarC_Syntax_Syntax.binder_bv in + if uu___1 + then FStarC_Parser_AST.NoName e + else + (let uu___3 = + let uu___4 = + bv_as_unique_ident b.FStarC_Syntax_Syntax.binder_bv in + (uu___4, e) in + FStarC_Parser_AST.Annotated uu___3) in + FStarC_Parser_AST.mk_binder_with_attrs b' r + FStarC_Parser_AST.Type_level imp attrs +and (resugar_bv_as_pat' : + FStarC_Syntax_DsEnv.env -> + FStarC_Syntax_Syntax.bv -> + FStarC_Parser_AST.arg_qualifier FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.bv FStarC_Compiler_FlatSet.t -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax + FStar_Pervasives_Native.option -> FStarC_Parser_AST.pattern) + = + fun env -> + fun v -> + fun aqual -> + fun body_bv -> + fun typ_opt -> + let mk a = + let uu___ = FStarC_Syntax_Syntax.range_of_bv v in + FStarC_Parser_AST.mk_pattern a uu___ in + let used = + FStarC_Class_Setlike.mem () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) v (Obj.magic body_bv) in + let pat = + let uu___ = + if used + then + let uu___1 = + let uu___2 = bv_as_unique_ident v in (uu___2, aqual, []) in + FStarC_Parser_AST.PatVar uu___1 + else FStarC_Parser_AST.PatWild (aqual, []) in + mk uu___ in + match typ_opt with + | FStar_Pervasives_Native.None -> pat + | FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_unknown; + FStarC_Syntax_Syntax.pos = uu___; + FStarC_Syntax_Syntax.vars = uu___1; + FStarC_Syntax_Syntax.hash_code = uu___2;_} + -> pat + | FStar_Pervasives_Native.Some typ -> + let uu___ = FStarC_Options.print_bound_var_types () in + if uu___ + then + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = resugar_term' env typ in + (uu___4, FStar_Pervasives_Native.None) in + (pat, uu___3) in + FStarC_Parser_AST.PatAscribed uu___2 in + mk uu___1 + else pat +and (resugar_bv_as_pat : + FStarC_Syntax_DsEnv.env -> + FStarC_Syntax_Syntax.bv -> + FStarC_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.bv FStarC_Compiler_FlatSet.t -> + FStarC_Parser_AST.pattern) + = + fun env -> + fun x -> + fun qual -> + fun body_bv -> + let bq = resugar_bqual env qual in + let uu___ = + let uu___1 = + FStarC_Syntax_Subst.compress x.FStarC_Syntax_Syntax.sort in + FStar_Pervasives_Native.Some uu___1 in + resugar_bv_as_pat' env x bq body_bv uu___ +and (resugar_pat' : + FStarC_Syntax_DsEnv.env -> + FStarC_Syntax_Syntax.pat -> + FStarC_Syntax_Syntax.bv FStarC_Compiler_FlatSet.t -> + FStarC_Parser_AST.pattern) + = + fun env -> + fun p -> + fun branch_bv -> + let mk a = FStarC_Parser_AST.mk_pattern a p.FStarC_Syntax_Syntax.p in + let to_arg_qual bopt = + FStarC_Compiler_Util.bind_opt bopt + (fun b -> + if b + then FStar_Pervasives_Native.Some FStarC_Parser_AST.Implicit + else FStar_Pervasives_Native.None) in + let must_print args = + FStarC_Compiler_List.existsML + (fun uu___ -> + match uu___ with + | (pattern, is_implicit) -> + (match pattern.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_var bv -> + is_implicit && + (FStarC_Class_Setlike.mem () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) bv + (Obj.magic branch_bv)) + | uu___1 -> false)) args in + let resugar_plain_pat_cons' fv args = + let uu___ = + let uu___1 = + let uu___2 = + mk + (FStarC_Parser_AST.PatName + ((fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v)) in + (uu___2, args) in + FStarC_Parser_AST.PatApp uu___1 in + mk uu___ in + let rec resugar_plain_pat_cons fv args = + let args1 = + let uu___ = + let uu___1 = must_print args in Prims.op_Negation uu___1 in + if uu___ then filter_pattern_imp args else args in + let args2 = + FStarC_Compiler_List.map + (fun uu___ -> + match uu___ with + | (p1, b) -> aux p1 (FStar_Pervasives_Native.Some b)) args1 in + resugar_plain_pat_cons' fv args2 + and aux p1 imp_opt = + match p1.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_constant c -> + mk (FStarC_Parser_AST.PatConst c) + | FStarC_Syntax_Syntax.Pat_cons (fv, uu___, args) when + FStarC_Ident.lid_equals + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + FStarC_Parser_Const.nil_lid + -> + let uu___1 = filter_pattern_imp args in + (match uu___1 with + | [] -> mk (FStarC_Parser_AST.PatList []) + | uu___2 -> resugar_plain_pat_cons fv args) + | FStarC_Syntax_Syntax.Pat_cons (fv, uu___, args) when + FStarC_Ident.lid_equals + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + FStarC_Parser_Const.cons_lid + -> + let uu___1 = filter_pattern_imp args in + (match uu___1 with + | (hd, false)::(tl, false)::[] -> + let hd' = aux hd (FStar_Pervasives_Native.Some false) in + let uu___2 = aux tl (FStar_Pervasives_Native.Some false) in + (match uu___2 with + | { + FStarC_Parser_AST.pat = FStarC_Parser_AST.PatList tl'; + FStarC_Parser_AST.prange = p2;_} -> + FStarC_Parser_AST.mk_pattern + (FStarC_Parser_AST.PatList (hd' :: tl')) p2 + | tl' -> resugar_plain_pat_cons' fv [hd'; tl']) + | uu___2 -> resugar_plain_pat_cons fv args) + | FStarC_Syntax_Syntax.Pat_cons (fv, uu___, []) -> + mk + (FStarC_Parser_AST.PatName + ((fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v)) + | FStarC_Syntax_Syntax.Pat_cons (fv, uu___, args) when + (is_tuple_constructor_lid + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v) + && (let uu___1 = must_print args in Prims.op_Negation uu___1) + -> + let args1 = + FStarC_Compiler_List.filter_map + (fun uu___1 -> + match uu___1 with + | (p2, is_implicit) -> + if is_implicit + then FStar_Pervasives_Native.None + else + (let uu___3 = + aux p2 (FStar_Pervasives_Native.Some false) in + FStar_Pervasives_Native.Some uu___3)) args in + let is_dependent_tuple = + FStarC_Parser_Const.is_dtuple_data_lid' + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + mk (FStarC_Parser_AST.PatTuple (args1, is_dependent_tuple)) + | FStarC_Syntax_Syntax.Pat_cons + ({ FStarC_Syntax_Syntax.fv_name = uu___; + FStarC_Syntax_Syntax.fv_qual = FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Record_ctor (name, fields));_}, + uu___1, args) + -> + let fields1 = + let uu___2 = + FStarC_Compiler_List.map + (fun f -> FStarC_Ident.lid_of_ids [f]) fields in + FStarC_Compiler_List.rev uu___2 in + let args1 = + let uu___2 = + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with + | (p2, b) -> aux p2 (FStar_Pervasives_Native.Some b)) + args in + FStarC_Compiler_List.rev uu___2 in + let rec map2 l1 l2 = + match (l1, l2) with + | ([], []) -> [] + | ([], hd::tl) -> [] + | (hd::tl, []) -> + let uu___2 = + let uu___3 = + mk + (FStarC_Parser_AST.PatWild + (FStar_Pervasives_Native.None, [])) in + (hd, uu___3) in + let uu___3 = map2 tl [] in uu___2 :: uu___3 + | (hd1::tl1, hd2::tl2) -> + let uu___2 = map2 tl1 tl2 in (hd1, hd2) :: uu___2 in + let args2 = + let uu___2 = map2 fields1 args1 in + FStarC_Compiler_List.rev uu___2 in + mk (FStarC_Parser_AST.PatRecord args2) + | FStarC_Syntax_Syntax.Pat_cons (fv, uu___, args) -> + resugar_plain_pat_cons fv args + | FStarC_Syntax_Syntax.Pat_var v -> + let uu___ = + let uu___1 = + FStarC_Ident.string_of_id v.FStarC_Syntax_Syntax.ppname in + FStarC_Parser_AST.string_to_op uu___1 in + (match uu___ with + | FStar_Pervasives_Native.Some (op, uu___1) -> + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Ident.range_of_id + v.FStarC_Syntax_Syntax.ppname in + (op, uu___5) in + FStarC_Ident.mk_ident uu___4 in + FStarC_Parser_AST.PatOp uu___3 in + mk uu___2 + | FStar_Pervasives_Native.None -> + let uu___1 = to_arg_qual imp_opt in + resugar_bv_as_pat' env v uu___1 branch_bv + FStar_Pervasives_Native.None) + | FStarC_Syntax_Syntax.Pat_dot_term uu___ -> + mk + (FStarC_Parser_AST.PatWild + ((FStar_Pervasives_Native.Some FStarC_Parser_AST.Implicit), + [])) in + aux p FStar_Pervasives_Native.None +and (resugar_bqual : + FStarC_Syntax_DsEnv.env -> + FStarC_Syntax_Syntax.bqual -> + FStarC_Parser_AST.arg_qualifier FStar_Pervasives_Native.option) + = + fun env -> + fun q -> + match q with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Implicit b) -> + FStar_Pervasives_Native.Some FStarC_Parser_AST.Implicit + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Equality) -> + FStar_Pervasives_Native.Some FStarC_Parser_AST.Equality + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Meta t) when + FStarC_Syntax_Util.is_fvar FStarC_Parser_Const.tcresolve_lid t -> + FStar_Pervasives_Native.Some FStarC_Parser_AST.TypeClassArg + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Meta t) -> + let uu___ = + let uu___1 = resugar_term' env t in FStarC_Parser_AST.Meta uu___1 in + FStar_Pervasives_Native.Some uu___ +and (resugar_aqual : + FStarC_Syntax_DsEnv.env -> + FStarC_Syntax_Syntax.aqual -> FStarC_Parser_AST.imp) + = + fun env -> + fun q -> + match q with + | FStar_Pervasives_Native.None -> FStarC_Parser_AST.Nothing + | FStar_Pervasives_Native.Some a -> + if a.FStarC_Syntax_Syntax.aqual_implicit + then FStarC_Parser_AST.Hash + else FStarC_Parser_AST.Nothing +let (resugar_qualifier : + FStarC_Syntax_Syntax.qualifier -> + FStarC_Parser_AST.qualifier FStar_Pervasives_Native.option) + = + fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.Assumption -> + FStar_Pervasives_Native.Some FStarC_Parser_AST.Assumption + | FStarC_Syntax_Syntax.InternalAssumption -> FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.New -> + FStar_Pervasives_Native.Some FStarC_Parser_AST.New + | FStarC_Syntax_Syntax.Private -> + FStar_Pervasives_Native.Some FStarC_Parser_AST.Private + | FStarC_Syntax_Syntax.Unfold_for_unification_and_vcgen -> + FStar_Pervasives_Native.Some + FStarC_Parser_AST.Unfold_for_unification_and_vcgen + | FStarC_Syntax_Syntax.Visible_default -> FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Irreducible -> + FStar_Pervasives_Native.Some FStarC_Parser_AST.Irreducible + | FStarC_Syntax_Syntax.Inline_for_extraction -> + FStar_Pervasives_Native.Some FStarC_Parser_AST.Inline_for_extraction + | FStarC_Syntax_Syntax.NoExtract -> + FStar_Pervasives_Native.Some FStarC_Parser_AST.NoExtract + | FStarC_Syntax_Syntax.Noeq -> + FStar_Pervasives_Native.Some FStarC_Parser_AST.Noeq + | FStarC_Syntax_Syntax.Unopteq -> + FStar_Pervasives_Native.Some FStarC_Parser_AST.Unopteq + | FStarC_Syntax_Syntax.TotalEffect -> + FStar_Pervasives_Native.Some FStarC_Parser_AST.TotalEffect + | FStarC_Syntax_Syntax.Logic -> FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Reifiable -> + FStar_Pervasives_Native.Some FStarC_Parser_AST.Reifiable + | FStarC_Syntax_Syntax.Reflectable uu___1 -> + FStar_Pervasives_Native.Some FStarC_Parser_AST.Reflectable + | FStarC_Syntax_Syntax.Discriminator uu___1 -> + FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Projector uu___1 -> FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.RecordType uu___1 -> FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.RecordConstructor uu___1 -> + FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Action uu___1 -> FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.ExceptionConstructor -> + FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.HasMaskedEffect -> FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Effect -> + FStar_Pervasives_Native.Some FStarC_Parser_AST.Effect_qual + | FStarC_Syntax_Syntax.OnlyName -> FStar_Pervasives_Native.None +let (resugar_pragma : + FStarC_Syntax_Syntax.pragma -> FStarC_Parser_AST.pragma) = + fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.ShowOptions -> FStarC_Parser_AST.ShowOptions + | FStarC_Syntax_Syntax.SetOptions s -> FStarC_Parser_AST.SetOptions s + | FStarC_Syntax_Syntax.ResetOptions s -> FStarC_Parser_AST.ResetOptions s + | FStarC_Syntax_Syntax.PushOptions s -> FStarC_Parser_AST.PushOptions s + | FStarC_Syntax_Syntax.PopOptions -> FStarC_Parser_AST.PopOptions + | FStarC_Syntax_Syntax.RestartSolver -> FStarC_Parser_AST.RestartSolver + | FStarC_Syntax_Syntax.PrintEffectsGraph -> + FStarC_Parser_AST.PrintEffectsGraph +let (drop_n_bs : + Prims.int -> FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) = + fun n -> + fun t -> + let uu___ = FStarC_Syntax_Util.arrow_formals_comp_ln t in + match uu___ with + | (bs, c) -> + let bs1 = + let uu___1 = FStarC_Compiler_List.splitAt n bs in + FStar_Pervasives_Native.snd uu___1 in + FStarC_Syntax_Util.arrow bs1 c +let (resugar_typ : + FStarC_Syntax_DsEnv.env -> + FStarC_Syntax_Syntax.sigelt Prims.list -> + FStarC_Syntax_Syntax.sigelt -> + (FStarC_Syntax_Syntax.sigelts * FStarC_Parser_AST.tycon)) + = + fun env -> + fun datacon_ses -> + fun se -> + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = tylid; + FStarC_Syntax_Syntax.us = uvs; + FStarC_Syntax_Syntax.params = bs; + FStarC_Syntax_Syntax.num_uniform_params = uu___; + FStarC_Syntax_Syntax.t = t; + FStarC_Syntax_Syntax.mutuals = uu___1; + FStarC_Syntax_Syntax.ds = datacons; + FStarC_Syntax_Syntax.injective_type_params = uu___2;_} + -> + let uu___3 = + FStarC_Compiler_List.partition + (fun se1 -> + match se1.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = uu___4; + FStarC_Syntax_Syntax.us1 = uu___5; + FStarC_Syntax_Syntax.t1 = uu___6; + FStarC_Syntax_Syntax.ty_lid = inductive_lid; + FStarC_Syntax_Syntax.num_ty_params = uu___7; + FStarC_Syntax_Syntax.mutuals1 = uu___8; + FStarC_Syntax_Syntax.injective_type_params1 = uu___9;_} + -> FStarC_Ident.lid_equals inductive_lid tylid + | uu___4 -> failwith "unexpected") datacon_ses in + (match uu___3 with + | (current_datacons, other_datacons) -> + let bs1 = filter_imp_bs bs in + let bs2 = + FStarC_Compiler_List.map + (fun b -> + resugar_binder' env b t.FStarC_Syntax_Syntax.pos) bs1 in + let tyc = + let uu___4 = + (FStarC_Compiler_Util.for_some + FStarC_Syntax_Syntax.uu___is_RecordType + se.FStarC_Syntax_Syntax.sigquals) + && + ((FStarC_Compiler_List.length current_datacons) = + Prims.int_one) in + if uu___4 + then + let uu___5 = current_datacons in + match uu___5 with + | dc::[] -> + (match dc.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = l; + FStarC_Syntax_Syntax.us1 = univs; + FStarC_Syntax_Syntax.t1 = typ; + FStarC_Syntax_Syntax.ty_lid = uu___6; + FStarC_Syntax_Syntax.num_ty_params = num; + FStarC_Syntax_Syntax.mutuals1 = uu___7; + FStarC_Syntax_Syntax.injective_type_params1 = + uu___8;_} + -> + let typ1 = drop_n_bs num typ in + let fields = + let uu___9 = + FStarC_Syntax_Util.arrow_formals_comp_ln + typ1 in + match uu___9 with + | (bs3, uu___10) -> + let bs4 = filter_imp_bs bs3 in + FStarC_Compiler_List.map + (fun b -> + let q = + resugar_bqual env + b.FStarC_Syntax_Syntax.binder_qual in + let uu___11 = + bv_as_unique_ident + b.FStarC_Syntax_Syntax.binder_bv in + let uu___12 = + FStarC_Compiler_List.map + (resugar_term' env) + b.FStarC_Syntax_Syntax.binder_attrs in + let uu___13 = + resugar_term' env + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + (uu___11, q, uu___12, uu___13)) bs4 in + let uu___9 = + let uu___10 = FStarC_Ident.ident_of_lid tylid in + let uu___11 = + FStarC_Compiler_List.map + (resugar_term' env) + se.FStarC_Syntax_Syntax.sigattrs in + (uu___10, bs2, FStar_Pervasives_Native.None, + uu___11, fields) in + FStarC_Parser_AST.TyconRecord uu___9 + | uu___6 -> failwith "ggg1") + else + (let resugar_datacon constructors se1 = + match se1.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = l; + FStarC_Syntax_Syntax.us1 = univs; + FStarC_Syntax_Syntax.t1 = typ; + FStarC_Syntax_Syntax.ty_lid = uu___6; + FStarC_Syntax_Syntax.num_ty_params = num; + FStarC_Syntax_Syntax.mutuals1 = uu___7; + FStarC_Syntax_Syntax.injective_type_params1 = + uu___8;_} + -> + let typ1 = drop_n_bs num typ in + let c = + let uu___9 = FStarC_Ident.ident_of_lid l in + let uu___10 = + let uu___11 = + let uu___12 = resugar_term' env typ1 in + FStarC_Parser_AST.VpArbitrary uu___12 in + FStar_Pervasives_Native.Some uu___11 in + let uu___11 = + FStarC_Compiler_List.map (resugar_term' env) + se1.FStarC_Syntax_Syntax.sigattrs in + (uu___9, uu___10, uu___11) in + c :: constructors + | uu___6 -> failwith "unexpected" in + let constructors = + FStarC_Compiler_List.fold_left resugar_datacon [] + current_datacons in + let uu___6 = + let uu___7 = FStarC_Ident.ident_of_lid tylid in + (uu___7, bs2, FStar_Pervasives_Native.None, + constructors) in + FStarC_Parser_AST.TyconVariant uu___6) in + (other_datacons, tyc)) + | uu___ -> + failwith + "Impossible : only Sig_inductive_typ can be resugared as types" +let (mk_decl : + FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.qualifier Prims.list -> + FStarC_Parser_AST.decl' -> FStarC_Parser_AST.decl) + = + fun r -> + fun q -> + fun d' -> + let uu___ = FStarC_Compiler_List.choose resugar_qualifier q in + { + FStarC_Parser_AST.d = d'; + FStarC_Parser_AST.drange = r; + FStarC_Parser_AST.quals = uu___; + FStarC_Parser_AST.attrs = []; + FStarC_Parser_AST.interleaved = false + } +let (decl'_to_decl : + FStarC_Syntax_Syntax.sigelt -> + FStarC_Parser_AST.decl' -> FStarC_Parser_AST.decl) + = + fun se -> + fun d' -> + mk_decl se.FStarC_Syntax_Syntax.sigrng se.FStarC_Syntax_Syntax.sigquals + d' +let (resugar_tscheme'' : + FStarC_Syntax_DsEnv.env -> + Prims.string -> FStarC_Syntax_Syntax.tscheme -> FStarC_Parser_AST.decl) + = + fun env -> + fun name -> + fun ts -> + let uu___ = ts in + match uu___ with + | (univs, typ) -> + let name1 = + FStarC_Ident.mk_ident (name, (typ.FStarC_Syntax_Syntax.pos)) in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = resugar_term' env typ in + (name1, [], FStar_Pervasives_Native.None, uu___6) in + FStarC_Parser_AST.TyconAbbrev uu___5 in + [uu___4] in + (false, false, uu___3) in + FStarC_Parser_AST.Tycon uu___2 in + mk_decl typ.FStarC_Syntax_Syntax.pos [] uu___1 +let (resugar_tscheme' : + FStarC_Syntax_DsEnv.env -> + FStarC_Syntax_Syntax.tscheme -> FStarC_Parser_AST.decl) + = fun env -> fun ts -> resugar_tscheme'' env "tscheme" ts +let (resugar_wp_eff_combinators : + FStarC_Syntax_DsEnv.env -> + Prims.bool -> + FStarC_Syntax_Syntax.wp_eff_combinators -> + FStarC_Parser_AST.decl Prims.list) + = + fun env -> + fun for_free -> + fun combs -> + let resugar_opt name tsopt = + match tsopt with + | FStar_Pervasives_Native.Some ts -> + let uu___ = resugar_tscheme'' env name ts in [uu___] + | FStar_Pervasives_Native.None -> [] in + let repr = resugar_opt "repr" combs.FStarC_Syntax_Syntax.repr in + let return_repr = + resugar_opt "return_repr" combs.FStarC_Syntax_Syntax.return_repr in + let bind_repr = + resugar_opt "bind_repr" combs.FStarC_Syntax_Syntax.bind_repr in + if for_free + then + FStarC_Compiler_List.op_At repr + (FStarC_Compiler_List.op_At return_repr bind_repr) + else + (let uu___1 = + resugar_tscheme'' env "ret_wp" combs.FStarC_Syntax_Syntax.ret_wp in + let uu___2 = + let uu___3 = + resugar_tscheme'' env "bind_wp" + combs.FStarC_Syntax_Syntax.bind_wp in + let uu___4 = + let uu___5 = + resugar_tscheme'' env "stronger" + combs.FStarC_Syntax_Syntax.stronger in + let uu___6 = + let uu___7 = + resugar_tscheme'' env "if_then_else" + combs.FStarC_Syntax_Syntax.if_then_else in + let uu___8 = + let uu___9 = + resugar_tscheme'' env "ite_wp" + combs.FStarC_Syntax_Syntax.ite_wp in + let uu___10 = + let uu___11 = + resugar_tscheme'' env "close_wp" + combs.FStarC_Syntax_Syntax.close_wp in + let uu___12 = + let uu___13 = + resugar_tscheme'' env "trivial" + combs.FStarC_Syntax_Syntax.trivial in + uu___13 :: + (FStarC_Compiler_List.op_At repr + (FStarC_Compiler_List.op_At return_repr bind_repr)) in + uu___11 :: uu___12 in + uu___9 :: uu___10 in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2) +let (resugar_layered_eff_combinators : + FStarC_Syntax_DsEnv.env -> + FStarC_Syntax_Syntax.layered_eff_combinators -> + FStarC_Parser_AST.decl Prims.list) + = + fun env -> + fun combs -> + let resugar name uu___ = + match uu___ with + | (ts, uu___1, uu___2) -> resugar_tscheme'' env name ts in + let resugar2 name uu___ = + match uu___ with | (ts, uu___1) -> resugar_tscheme'' env name ts in + let uu___ = resugar2 "repr" combs.FStarC_Syntax_Syntax.l_repr in + let uu___1 = + let uu___2 = resugar2 "return" combs.FStarC_Syntax_Syntax.l_return in + let uu___3 = + let uu___4 = resugar "bind" combs.FStarC_Syntax_Syntax.l_bind in + let uu___5 = + let uu___6 = + resugar "subcomp" combs.FStarC_Syntax_Syntax.l_subcomp in + let uu___7 = + let uu___8 = + resugar "if_then_else" + combs.FStarC_Syntax_Syntax.l_if_then_else in + [uu___8] in + uu___6 :: uu___7 in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + uu___ :: uu___1 +let (resugar_combinators : + FStarC_Syntax_DsEnv.env -> + FStarC_Syntax_Syntax.eff_combinators -> FStarC_Parser_AST.decl Prims.list) + = + fun env -> + fun combs -> + match combs with + | FStarC_Syntax_Syntax.Primitive_eff combs1 -> + resugar_wp_eff_combinators env false combs1 + | FStarC_Syntax_Syntax.DM4F_eff combs1 -> + resugar_wp_eff_combinators env true combs1 + | FStarC_Syntax_Syntax.Layered_eff combs1 -> + resugar_layered_eff_combinators env combs1 +let (resugar_eff_decl' : + FStarC_Syntax_DsEnv.env -> + FStarC_Syntax_Syntax.eff_decl -> FStarC_Parser_AST.decl) + = + fun env -> + fun ed -> + let r = FStarC_Compiler_Range_Type.dummyRange in + let q = [] in + let resugar_action d for_free = + let action_params = + FStarC_Syntax_Subst.open_binders + d.FStarC_Syntax_Syntax.action_params in + let uu___ = + FStarC_Syntax_Subst.open_term action_params + d.FStarC_Syntax_Syntax.action_defn in + match uu___ with + | (bs, action_defn) -> + let uu___1 = + FStarC_Syntax_Subst.open_term action_params + d.FStarC_Syntax_Syntax.action_typ in + (match uu___1 with + | (bs1, action_typ) -> + let action_params1 = filter_imp_bs action_params in + let action_params2 = + let uu___2 = + FStarC_Compiler_List.map + (fun b -> resugar_binder' env b r) action_params1 in + FStarC_Compiler_List.rev uu___2 in + let action_defn1 = resugar_term' env action_defn in + let action_typ1 = resugar_term' env action_typ in + if for_free + then + let a = + let uu___2 = + let uu___3 = FStarC_Ident.lid_of_str "construct" in + (uu___3, + [(action_defn1, FStarC_Parser_AST.Nothing); + (action_typ1, FStarC_Parser_AST.Nothing)]) in + FStarC_Parser_AST.Construct uu___2 in + let t = FStarC_Parser_AST.mk_term a r FStarC_Parser_AST.Un in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Ident.ident_of_lid + d.FStarC_Syntax_Syntax.action_name in + (uu___7, action_params2, + FStar_Pervasives_Native.None, t) in + FStarC_Parser_AST.TyconAbbrev uu___6 in + [uu___5] in + (false, false, uu___4) in + FStarC_Parser_AST.Tycon uu___3 in + mk_decl r q uu___2 + else + (let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Ident.ident_of_lid + d.FStarC_Syntax_Syntax.action_name in + (uu___8, action_params2, + FStar_Pervasives_Native.None, action_defn1) in + FStarC_Parser_AST.TyconAbbrev uu___7 in + [uu___6] in + (false, false, uu___5) in + FStarC_Parser_AST.Tycon uu___4 in + mk_decl r q uu___3)) in + let eff_name = FStarC_Ident.ident_of_lid ed.FStarC_Syntax_Syntax.mname in + let uu___ = + let sig_ts = + FStarC_Syntax_Util.effect_sig_ts ed.FStarC_Syntax_Syntax.signature in + FStarC_Syntax_Subst.open_term ed.FStarC_Syntax_Syntax.binders + (FStar_Pervasives_Native.snd sig_ts) in + match uu___ with + | (eff_binders, eff_typ) -> + let eff_binders1 = filter_imp_bs eff_binders in + let eff_binders2 = + let uu___1 = + FStarC_Compiler_List.map (fun b -> resugar_binder' env b r) + eff_binders1 in + FStarC_Compiler_List.rev uu___1 in + let eff_typ1 = resugar_term' env eff_typ in + let mandatory_members_decls = + resugar_combinators env ed.FStarC_Syntax_Syntax.combinators in + let actions = + FStarC_Compiler_List.map (fun a -> resugar_action a false) + ed.FStarC_Syntax_Syntax.actions in + let decls = + FStarC_Compiler_List.op_At mandatory_members_decls actions in + mk_decl r q + (FStarC_Parser_AST.NewEffect + (FStarC_Parser_AST.DefineEffect + (eff_name, eff_binders2, eff_typ1, decls))) +let (resugar_sigelt' : + FStarC_Syntax_DsEnv.env -> + FStarC_Syntax_Syntax.sigelt -> + FStarC_Parser_AST.decl FStar_Pervasives_Native.option) + = + fun env -> + fun se -> + let d = + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_bundle + { FStarC_Syntax_Syntax.ses = ses; + FStarC_Syntax_Syntax.lids = uu___;_} + -> + let uu___1 = + FStarC_Compiler_List.partition + (fun se1 -> + match se1.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_inductive_typ uu___2 -> true + | FStarC_Syntax_Syntax.Sig_declare_typ uu___2 -> true + | FStarC_Syntax_Syntax.Sig_datacon uu___2 -> false + | uu___2 -> + failwith + "Found a sigelt which is neither a type declaration or a data constructor in a sigelt") + ses in + (match uu___1 with + | (decl_typ_ses, datacon_ses) -> + let retrieve_datacons_and_resugar uu___2 se1 = + match uu___2 with + | (datacon_ses1, tycons) -> + let uu___3 = resugar_typ env datacon_ses1 se1 in + (match uu___3 with + | (datacon_ses2, tyc) -> + (datacon_ses2, (tyc :: tycons))) in + let uu___2 = + FStarC_Compiler_List.fold_left + retrieve_datacons_and_resugar (datacon_ses, []) + decl_typ_ses in + (match uu___2 with + | (leftover_datacons, tycons) -> + (match leftover_datacons with + | [] -> + let uu___3 = + decl'_to_decl se + (FStarC_Parser_AST.Tycon + (false, false, tycons)) in + FStar_Pervasives_Native.Some uu___3 + | se1::[] -> + (match se1.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = l; + FStarC_Syntax_Syntax.us1 = uu___3; + FStarC_Syntax_Syntax.t1 = uu___4; + FStarC_Syntax_Syntax.ty_lid = uu___5; + FStarC_Syntax_Syntax.num_ty_params = uu___6; + FStarC_Syntax_Syntax.mutuals1 = uu___7; + FStarC_Syntax_Syntax.injective_type_params1 + = uu___8;_} + -> + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Ident.ident_of_lid l in + (uu___12, FStar_Pervasives_Native.None) in + FStarC_Parser_AST.Exception uu___11 in + decl'_to_decl se1 uu___10 in + FStar_Pervasives_Native.Some uu___9 + | uu___3 -> + failwith + "wrong format for resguar to Exception") + | uu___3 -> failwith "Should not happen hopefully"))) + | FStarC_Syntax_Syntax.Sig_fail uu___ -> FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = lbs; + FStarC_Syntax_Syntax.lids1 = uu___;_} + -> + let uu___1 = + FStarC_Compiler_Util.for_some + (fun uu___2 -> + match uu___2 with + | FStarC_Syntax_Syntax.Projector (uu___3, uu___4) -> true + | FStarC_Syntax_Syntax.Discriminator uu___3 -> true + | uu___3 -> false) se.FStarC_Syntax_Syntax.sigquals in + if uu___1 + then FStar_Pervasives_Native.None + else + (let mk e = + FStarC_Syntax_Syntax.mk e se.FStarC_Syntax_Syntax.sigrng in + let dummy = mk FStarC_Syntax_Syntax.Tm_unknown in + let nopath_lbs uu___3 = + match uu___3 with + | (is_rec, lbs1) -> + let nopath fv = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Syntax_Syntax.lid_of_fv fv in + FStarC_Ident.ident_of_lid uu___7 in + [uu___6] in + FStarC_Ident.lid_of_ids uu___5 in + FStarC_Syntax_Syntax.lid_as_fv uu___4 + FStar_Pervasives_Native.None in + let lbs2 = + FStarC_Compiler_List.map + (fun lb -> + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Compiler_Util.right + lb.FStarC_Syntax_Syntax.lbname in + nopath uu___6 in + FStar_Pervasives.Inr uu___5 in + { + FStarC_Syntax_Syntax.lbname = uu___4; + FStarC_Syntax_Syntax.lbunivs = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = + (lb.FStarC_Syntax_Syntax.lbtyp); + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = + (lb.FStarC_Syntax_Syntax.lbdef); + FStarC_Syntax_Syntax.lbattrs = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + }) lbs1 in + (is_rec, lbs2) in + let lbs1 = nopath_lbs lbs in + let desugared_let = + mk + (FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = lbs1; + FStarC_Syntax_Syntax.body1 = dummy + }) in + let t = resugar_term' env desugared_let in + match t.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Let (isrec, lets, uu___3) -> + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Compiler_List.map + FStar_Pervasives_Native.snd lets in + (isrec, uu___7) in + FStarC_Parser_AST.TopLevelLet uu___6 in + decl'_to_decl se uu___5 in + FStar_Pervasives_Native.Some uu___4 + | uu___3 -> failwith "Should not happen hopefully") + | FStarC_Syntax_Syntax.Sig_assume + { FStarC_Syntax_Syntax.lid3 = lid; + FStarC_Syntax_Syntax.us3 = uu___; + FStarC_Syntax_Syntax.phi1 = fml;_} + -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Ident.ident_of_lid lid in + let uu___5 = resugar_term' env fml in (uu___4, uu___5) in + FStarC_Parser_AST.Assume uu___3 in + decl'_to_decl se uu___2 in + FStar_Pervasives_Native.Some uu___1 + | FStarC_Syntax_Syntax.Sig_new_effect ed -> + let a_decl = resugar_eff_decl' env ed in + let q = + FStarC_Compiler_List.choose resugar_qualifier + se.FStarC_Syntax_Syntax.sigquals in + FStar_Pervasives_Native.Some + { + FStarC_Parser_AST.d = (a_decl.FStarC_Parser_AST.d); + FStarC_Parser_AST.drange = (a_decl.FStarC_Parser_AST.drange); + FStarC_Parser_AST.quals = q; + FStarC_Parser_AST.attrs = (a_decl.FStarC_Parser_AST.attrs); + FStarC_Parser_AST.interleaved = + (a_decl.FStarC_Parser_AST.interleaved) + } + | FStarC_Syntax_Syntax.Sig_sub_effect e -> + let src = e.FStarC_Syntax_Syntax.source in + let dst = e.FStarC_Syntax_Syntax.target in + let lift_wp = + match e.FStarC_Syntax_Syntax.lift_wp with + | FStar_Pervasives_Native.Some (uu___, t) -> + let uu___1 = resugar_term' env t in + FStar_Pervasives_Native.Some uu___1 + | uu___ -> FStar_Pervasives_Native.None in + let lift = + match e.FStarC_Syntax_Syntax.lift with + | FStar_Pervasives_Native.Some (uu___, t) -> + let uu___1 = resugar_term' env t in + FStar_Pervasives_Native.Some uu___1 + | uu___ -> FStar_Pervasives_Native.None in + let op = + match (lift_wp, lift) with + | (FStar_Pervasives_Native.Some t, + FStar_Pervasives_Native.None) -> + FStarC_Parser_AST.NonReifiableLift t + | (FStar_Pervasives_Native.Some wp, + FStar_Pervasives_Native.Some t) -> + FStarC_Parser_AST.ReifiableLift (wp, t) + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.Some + t) -> FStarC_Parser_AST.LiftForFree t + | uu___ -> failwith "Should not happen hopefully" in + let uu___ = + decl'_to_decl se + (FStarC_Parser_AST.SubEffect + { + FStarC_Parser_AST.msource = src; + FStarC_Parser_AST.mdest = dst; + FStarC_Parser_AST.lift_op = op; + FStarC_Parser_AST.braced = false + }) in + FStar_Pervasives_Native.Some uu___ + | FStarC_Syntax_Syntax.Sig_effect_abbrev + { FStarC_Syntax_Syntax.lid4 = lid; FStarC_Syntax_Syntax.us4 = vs; + FStarC_Syntax_Syntax.bs2 = bs; FStarC_Syntax_Syntax.comp1 = c; + FStarC_Syntax_Syntax.cflags = flags;_} + -> + let uu___ = FStarC_Syntax_Subst.open_comp bs c in + (match uu___ with + | (bs1, c1) -> + let bs2 = filter_imp_bs bs1 in + let bs3 = + FStarC_Compiler_List.map + (fun b -> + resugar_binder' env b se.FStarC_Syntax_Syntax.sigrng) + bs2 in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Ident.ident_of_lid lid in + let uu___8 = resugar_comp' env c1 in + (uu___7, bs3, FStar_Pervasives_Native.None, + uu___8) in + FStarC_Parser_AST.TyconAbbrev uu___6 in + [uu___5] in + (false, false, uu___4) in + FStarC_Parser_AST.Tycon uu___3 in + decl'_to_decl se uu___2 in + FStar_Pervasives_Native.Some uu___1) + | FStarC_Syntax_Syntax.Sig_pragma p -> + let uu___ = + decl'_to_decl se (FStarC_Parser_AST.Pragma (resugar_pragma p)) in + FStar_Pervasives_Native.Some uu___ + | FStarC_Syntax_Syntax.Sig_declare_typ + { FStarC_Syntax_Syntax.lid2 = lid; + FStarC_Syntax_Syntax.us2 = uvs; FStarC_Syntax_Syntax.t2 = t;_} + -> + let uu___ = + FStarC_Compiler_Util.for_some + (fun uu___1 -> + match uu___1 with + | FStarC_Syntax_Syntax.Projector (uu___2, uu___3) -> true + | FStarC_Syntax_Syntax.Discriminator uu___2 -> true + | uu___2 -> false) se.FStarC_Syntax_Syntax.sigquals in + if uu___ + then FStar_Pervasives_Native.None + else + (let t' = + let uu___2 = + (let uu___3 = FStarC_Options.print_universes () in + Prims.op_Negation uu___3) || + (FStarC_Compiler_List.isEmpty uvs) in + if uu___2 + then resugar_term' env t + else + (let uu___4 = FStarC_Syntax_Subst.open_univ_vars uvs t in + match uu___4 with + | (uvs1, t1) -> + let universes = universe_to_string uvs1 in + let uu___5 = resugar_term' env t1 in + label universes uu___5) in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Ident.ident_of_lid lid in + (uu___5, t') in + FStarC_Parser_AST.Val uu___4 in + decl'_to_decl se uu___3 in + FStar_Pervasives_Native.Some uu___2) + | FStarC_Syntax_Syntax.Sig_splice + { FStarC_Syntax_Syntax.is_typed = is_typed; + FStarC_Syntax_Syntax.lids2 = ids; + FStarC_Syntax_Syntax.tac = t;_} + -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Compiler_List.map + (fun l -> FStarC_Ident.ident_of_lid l) ids in + let uu___4 = resugar_term' env t in + (is_typed, uu___3, uu___4) in + FStarC_Parser_AST.Splice uu___2 in + decl'_to_decl se uu___1 in + FStar_Pervasives_Native.Some uu___ + | FStarC_Syntax_Syntax.Sig_inductive_typ uu___ -> + FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Sig_datacon uu___ -> + FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Sig_polymonadic_bind + { FStarC_Syntax_Syntax.m_lid = m; FStarC_Syntax_Syntax.n_lid = n; + FStarC_Syntax_Syntax.p_lid = p; + FStarC_Syntax_Syntax.tm3 = (uu___, t); + FStarC_Syntax_Syntax.typ = uu___1; + FStarC_Syntax_Syntax.kind1 = uu___2;_} + -> + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = resugar_term' env t in (m, n, p, uu___6) in + FStarC_Parser_AST.Polymonadic_bind uu___5 in + decl'_to_decl se uu___4 in + FStar_Pervasives_Native.Some uu___3 + | FStarC_Syntax_Syntax.Sig_polymonadic_subcomp + { FStarC_Syntax_Syntax.m_lid1 = m; + FStarC_Syntax_Syntax.n_lid1 = n; + FStarC_Syntax_Syntax.tm4 = (uu___, t); + FStarC_Syntax_Syntax.typ1 = uu___1; + FStarC_Syntax_Syntax.kind2 = uu___2;_} + -> + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = resugar_term' env t in (m, n, uu___6) in + FStarC_Parser_AST.Polymonadic_subcomp uu___5 in + decl'_to_decl se uu___4 in + FStar_Pervasives_Native.Some uu___3 in + match d with + | FStar_Pervasives_Native.Some d1 -> + let uu___ = + let uu___1 = + FStarC_Compiler_List.map (resugar_term' env) + se.FStarC_Syntax_Syntax.sigattrs in + { + FStarC_Parser_AST.d = (d1.FStarC_Parser_AST.d); + FStarC_Parser_AST.drange = (d1.FStarC_Parser_AST.drange); + FStarC_Parser_AST.quals = (d1.FStarC_Parser_AST.quals); + FStarC_Parser_AST.attrs = uu___1; + FStarC_Parser_AST.interleaved = + (d1.FStarC_Parser_AST.interleaved) + } in + FStar_Pervasives_Native.Some uu___ + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None +let (empty_env : FStarC_Syntax_DsEnv.env) = + FStarC_Syntax_DsEnv.empty_env FStarC_Parser_Dep.empty_deps +let noenv : 'a . (FStarC_Syntax_DsEnv.env -> 'a) -> 'a = fun f -> f empty_env +let (resugar_term : FStarC_Syntax_Syntax.term -> FStarC_Parser_AST.term) = + fun t -> let uu___ = noenv resugar_term' in uu___ t +let (resugar_sigelt : + FStarC_Syntax_Syntax.sigelt -> + FStarC_Parser_AST.decl FStar_Pervasives_Native.option) + = fun se -> let uu___ = noenv resugar_sigelt' in uu___ se +let (resugar_comp : FStarC_Syntax_Syntax.comp -> FStarC_Parser_AST.term) = + fun c -> let uu___ = noenv resugar_comp' in uu___ c +let (resugar_pat : + FStarC_Syntax_Syntax.pat -> + FStarC_Syntax_Syntax.bv FStarC_Compiler_FlatSet.t -> + FStarC_Parser_AST.pattern) + = + fun p -> + fun branch_bv -> let uu___ = noenv resugar_pat' in uu___ p branch_bv +let (resugar_binder : + FStarC_Syntax_Syntax.binder -> + FStarC_Compiler_Range_Type.range -> FStarC_Parser_AST.binder) + = fun b -> fun r -> let uu___ = noenv resugar_binder' in uu___ b r +let (resugar_tscheme : + FStarC_Syntax_Syntax.tscheme -> FStarC_Parser_AST.decl) = + fun ts -> let uu___ = noenv resugar_tscheme' in uu___ ts +let (resugar_eff_decl : + FStarC_Syntax_Syntax.eff_decl -> FStarC_Parser_AST.decl) = + fun ed -> let uu___ = noenv resugar_eff_decl' in uu___ ed \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Syntax_Subst.ml b/ocaml/fstar-lib/generated/FStarC_Syntax_Subst.ml new file mode 100644 index 00000000000..5ad3c9f4010 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Syntax_Subst.ml @@ -0,0 +1,1745 @@ +open Prims +let subst_to_string : + 'uuuuu . (FStarC_Syntax_Syntax.bv * 'uuuuu) Prims.list -> Prims.string = + fun s -> + let uu___ = + FStarC_Compiler_List.map + (fun uu___1 -> + match uu___1 with + | (b, uu___2) -> + FStarC_Ident.string_of_id b.FStarC_Syntax_Syntax.ppname) s in + FStarC_Compiler_String.concat ", " uu___ +let rec apply_until_some : + 'uuuuu 'uuuuu1 . + ('uuuuu -> 'uuuuu1 FStar_Pervasives_Native.option) -> + 'uuuuu Prims.list -> + ('uuuuu Prims.list * 'uuuuu1) FStar_Pervasives_Native.option + = + fun f -> + fun s -> + match s with + | [] -> FStar_Pervasives_Native.None + | s0::rest -> + let uu___ = f s0 in + (match uu___ with + | FStar_Pervasives_Native.None -> apply_until_some f rest + | FStar_Pervasives_Native.Some st -> + FStar_Pervasives_Native.Some (rest, st)) +let map_some_curry : + 'uuuuu 'uuuuu1 'uuuuu2 . + ('uuuuu -> 'uuuuu1 -> 'uuuuu2) -> + 'uuuuu2 -> ('uuuuu * 'uuuuu1) FStar_Pervasives_Native.option -> 'uuuuu2 + = + fun f -> + fun x -> + fun uu___ -> + match uu___ with + | FStar_Pervasives_Native.None -> x + | FStar_Pervasives_Native.Some (a, b) -> f a b +let apply_until_some_then_map : + 'uuuuu 'uuuuu1 'uuuuu2 . + ('uuuuu -> 'uuuuu1 FStar_Pervasives_Native.option) -> + 'uuuuu Prims.list -> + ('uuuuu Prims.list -> 'uuuuu1 -> 'uuuuu2) -> 'uuuuu2 -> 'uuuuu2 + = + fun f -> + fun s -> + fun g -> + fun t -> let uu___ = apply_until_some f s in map_some_curry g t uu___ +let compose_subst : + 'uuuuu . + ('uuuuu Prims.list * FStarC_Syntax_Syntax.maybe_set_use_range) -> + ('uuuuu Prims.list * FStarC_Syntax_Syntax.maybe_set_use_range) -> + ('uuuuu Prims.list * FStarC_Syntax_Syntax.maybe_set_use_range) + = + fun s1 -> + fun s2 -> + let s = + FStarC_Compiler_List.op_At (FStar_Pervasives_Native.fst s1) + (FStar_Pervasives_Native.fst s2) in + let ropt = + match FStar_Pervasives_Native.snd s2 with + | FStarC_Syntax_Syntax.SomeUseRange uu___ -> + FStar_Pervasives_Native.snd s2 + | uu___ -> FStar_Pervasives_Native.snd s1 in + (s, ropt) +let (delay : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + (FStarC_Syntax_Syntax.subst_elt Prims.list Prims.list * + FStarC_Syntax_Syntax.maybe_set_use_range) -> FStarC_Syntax_Syntax.term) + = + fun t -> + fun s -> + match t.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_delayed + { FStarC_Syntax_Syntax.tm1 = t'; + FStarC_Syntax_Syntax.substs = s';_} + -> + FStarC_Syntax_Syntax.mk_Tm_delayed (t', (compose_subst s' s)) + t.FStarC_Syntax_Syntax.pos + | uu___ -> + FStarC_Syntax_Syntax.mk_Tm_delayed (t, s) + t.FStarC_Syntax_Syntax.pos +let rec (force_uvar' : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + (FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax * Prims.bool)) + = + fun t -> + match t.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_uvar + ({ FStarC_Syntax_Syntax.ctx_uvar_head = uv; + FStarC_Syntax_Syntax.ctx_uvar_gamma = uu___; + FStarC_Syntax_Syntax.ctx_uvar_binders = uu___1; + FStarC_Syntax_Syntax.ctx_uvar_reason = uu___2; + FStarC_Syntax_Syntax.ctx_uvar_range = uu___3; + FStarC_Syntax_Syntax.ctx_uvar_meta = uu___4;_}, + s) + -> + let uu___5 = FStarC_Syntax_Unionfind.find uv in + (match uu___5 with + | FStar_Pervasives_Native.Some t' -> + let uu___6 = + let uu___7 = let uu___8 = delay t' s in force_uvar' uu___8 in + FStar_Pervasives_Native.fst uu___7 in + (uu___6, true) + | uu___6 -> (t, false)) + | uu___ -> (t, false) +let (force_uvar : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun t -> + let uu___ = force_uvar' t in + match uu___ with + | (t', forced) -> + if forced + then + delay t' + ([], + (FStarC_Syntax_Syntax.SomeUseRange (t.FStarC_Syntax_Syntax.pos))) + else t +let rec (compress_univ : + FStarC_Syntax_Syntax.universe -> FStarC_Syntax_Syntax.universe) = + fun u -> + match u with + | FStarC_Syntax_Syntax.U_unif u' -> + let uu___ = FStarC_Syntax_Unionfind.univ_find u' in + (match uu___ with + | FStar_Pervasives_Native.Some u1 -> compress_univ u1 + | uu___1 -> u) + | uu___ -> u +let (subst_bv : + FStarC_Syntax_Syntax.bv -> + FStarC_Syntax_Syntax.subst_elt Prims.list -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax + FStar_Pervasives_Native.option) + = + fun a -> + fun s -> + FStarC_Compiler_Util.find_map s + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.DB (i, x) when + i = a.FStarC_Syntax_Syntax.index -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.range_of_bv a in + FStarC_Syntax_Syntax.set_range_of_bv x uu___3 in + FStarC_Syntax_Syntax.bv_to_name uu___2 in + FStar_Pervasives_Native.Some uu___1 + | FStarC_Syntax_Syntax.DT (i, t) when + i = a.FStarC_Syntax_Syntax.index -> + FStar_Pervasives_Native.Some t + | uu___1 -> FStar_Pervasives_Native.None) +let (subst_nm : + FStarC_Syntax_Syntax.bv -> + FStarC_Syntax_Syntax.subst_elt Prims.list -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax + FStar_Pervasives_Native.option) + = + fun a -> + fun s -> + FStarC_Compiler_Util.find_map s + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.NM (x, i) when + FStarC_Syntax_Syntax.bv_eq a x -> + let uu___1 = + FStarC_Syntax_Syntax.bv_to_tm + { + FStarC_Syntax_Syntax.ppname = + (a.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = i; + FStarC_Syntax_Syntax.sort = + (a.FStarC_Syntax_Syntax.sort) + } in + FStar_Pervasives_Native.Some uu___1 + | FStarC_Syntax_Syntax.NT (x, t) when + FStarC_Syntax_Syntax.bv_eq a x -> + FStar_Pervasives_Native.Some t + | uu___1 -> FStar_Pervasives_Native.None) +let (subst_univ_bv : + Prims.int -> + FStarC_Syntax_Syntax.subst_elt Prims.list -> + FStarC_Syntax_Syntax.universe FStar_Pervasives_Native.option) + = + fun x -> + fun s -> + FStarC_Compiler_Util.find_map s + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.UN (y, t) when x = y -> + FStar_Pervasives_Native.Some t + | uu___1 -> FStar_Pervasives_Native.None) +let (subst_univ_nm : + FStarC_Syntax_Syntax.univ_name -> + FStarC_Syntax_Syntax.subst_elt Prims.list -> + FStarC_Syntax_Syntax.universe FStar_Pervasives_Native.option) + = + fun x -> + fun s -> + FStarC_Compiler_Util.find_map s + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.UD (y, i) when + FStarC_Ident.ident_equals x y -> + FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.U_bvar i) + | uu___1 -> FStar_Pervasives_Native.None) +let rec (subst_univ : + FStarC_Syntax_Syntax.subst_elt Prims.list Prims.list -> + FStarC_Syntax_Syntax.universe -> FStarC_Syntax_Syntax.universe) + = + fun s -> + fun u -> + let u1 = compress_univ u in + match u1 with + | FStarC_Syntax_Syntax.U_bvar x -> + apply_until_some_then_map (subst_univ_bv x) s subst_univ u1 + | FStarC_Syntax_Syntax.U_name x -> + apply_until_some_then_map (subst_univ_nm x) s subst_univ u1 + | FStarC_Syntax_Syntax.U_zero -> u1 + | FStarC_Syntax_Syntax.U_unknown -> u1 + | FStarC_Syntax_Syntax.U_unif uu___ -> u1 + | FStarC_Syntax_Syntax.U_succ u2 -> + let uu___ = subst_univ s u2 in FStarC_Syntax_Syntax.U_succ uu___ + | FStarC_Syntax_Syntax.U_max us -> + let uu___ = FStarC_Compiler_List.map (subst_univ s) us in + FStarC_Syntax_Syntax.U_max uu___ +let tag_with_range : + 'uuuuu . + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + ('uuuuu * FStarC_Syntax_Syntax.maybe_set_use_range) -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax + = + fun t -> + fun s -> + match FStar_Pervasives_Native.snd s with + | FStarC_Syntax_Syntax.NoUseRange -> t + | FStarC_Syntax_Syntax.SomeUseRange r -> + let uu___ = + let uu___1 = + FStarC_Compiler_Range_Type.use_range t.FStarC_Syntax_Syntax.pos in + let uu___2 = FStarC_Compiler_Range_Type.use_range r in + FStarC_Compiler_Range_Ops.rng_included uu___1 uu___2 in + if uu___ + then t + else + (let r1 = + let uu___2 = FStarC_Compiler_Range_Type.use_range r in + FStarC_Compiler_Range_Type.set_use_range + t.FStarC_Syntax_Syntax.pos uu___2 in + let t' = + match t.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_bvar bv -> + let uu___2 = FStarC_Syntax_Syntax.set_range_of_bv bv r1 in + FStarC_Syntax_Syntax.Tm_bvar uu___2 + | FStarC_Syntax_Syntax.Tm_name bv -> + let uu___2 = FStarC_Syntax_Syntax.set_range_of_bv bv r1 in + FStarC_Syntax_Syntax.Tm_name uu___2 + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let l = FStarC_Syntax_Syntax.lid_of_fv fv in + let v = + let uu___2 = fv.FStarC_Syntax_Syntax.fv_name in + let uu___3 = FStarC_Ident.set_lid_range l r1 in + { + FStarC_Syntax_Syntax.v = uu___3; + FStarC_Syntax_Syntax.p = + (uu___2.FStarC_Syntax_Syntax.p) + } in + let fv1 = + { + FStarC_Syntax_Syntax.fv_name = v; + FStarC_Syntax_Syntax.fv_qual = + (fv.FStarC_Syntax_Syntax.fv_qual) + } in + FStarC_Syntax_Syntax.Tm_fvar fv1 + | t'1 -> t'1 in + { + FStarC_Syntax_Syntax.n = t'; + FStarC_Syntax_Syntax.pos = r1; + FStarC_Syntax_Syntax.vars = (t.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (t.FStarC_Syntax_Syntax.hash_code) + }) +let tag_lid_with_range : + 'uuuuu . + FStarC_Ident.lident -> + ('uuuuu * FStarC_Syntax_Syntax.maybe_set_use_range) -> + FStarC_Ident.lident + = + fun l -> + fun s -> + match FStar_Pervasives_Native.snd s with + | FStarC_Syntax_Syntax.NoUseRange -> l + | FStarC_Syntax_Syntax.SomeUseRange r -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Ident.range_of_lid l in + FStarC_Compiler_Range_Type.use_range uu___2 in + let uu___2 = FStarC_Compiler_Range_Type.use_range r in + FStarC_Compiler_Range_Ops.rng_included uu___1 uu___2 in + if uu___ + then l + else + (let uu___2 = + let uu___3 = FStarC_Ident.range_of_lid l in + let uu___4 = FStarC_Compiler_Range_Type.use_range r in + FStarC_Compiler_Range_Type.set_use_range uu___3 uu___4 in + FStarC_Ident.set_lid_range l uu___2) +let (mk_range : + FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.subst_ts -> FStarC_Compiler_Range_Type.range) + = + fun r -> + fun s -> + match FStar_Pervasives_Native.snd s with + | FStarC_Syntax_Syntax.NoUseRange -> r + | FStarC_Syntax_Syntax.SomeUseRange r' -> + let uu___ = + let uu___1 = FStarC_Compiler_Range_Type.use_range r in + let uu___2 = FStarC_Compiler_Range_Type.use_range r' in + FStarC_Compiler_Range_Ops.rng_included uu___1 uu___2 in + if uu___ + then r + else + (let uu___2 = FStarC_Compiler_Range_Type.use_range r' in + FStarC_Compiler_Range_Type.set_use_range r uu___2) +let rec (subst' : + FStarC_Syntax_Syntax.subst_ts -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun s -> + fun t -> + let subst_tail tl = subst' (tl, (FStar_Pervasives_Native.snd s)) in + match s with + | ([], FStarC_Syntax_Syntax.NoUseRange) -> t + | ([]::[], FStarC_Syntax_Syntax.NoUseRange) -> t + | uu___ -> + let t0 = t in + (match t0.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_unknown -> tag_with_range t0 s + | FStarC_Syntax_Syntax.Tm_constant uu___1 -> tag_with_range t0 s + | FStarC_Syntax_Syntax.Tm_fvar uu___1 -> tag_with_range t0 s + | FStarC_Syntax_Syntax.Tm_delayed + { FStarC_Syntax_Syntax.tm1 = t'; + FStarC_Syntax_Syntax.substs = s';_} + -> + FStarC_Syntax_Syntax.mk_Tm_delayed (t', (compose_subst s' s)) + t.FStarC_Syntax_Syntax.pos + | FStarC_Syntax_Syntax.Tm_bvar a -> + apply_until_some_then_map (subst_bv a) + (FStar_Pervasives_Native.fst s) subst_tail t0 + | FStarC_Syntax_Syntax.Tm_name a -> + apply_until_some_then_map (subst_nm a) + (FStar_Pervasives_Native.fst s) subst_tail t0 + | FStarC_Syntax_Syntax.Tm_type u -> + let uu___1 = + let uu___2 = subst_univ (FStar_Pervasives_Native.fst s) u in + FStarC_Syntax_Syntax.Tm_type uu___2 in + let uu___2 = mk_range t0.FStarC_Syntax_Syntax.pos s in + FStarC_Syntax_Syntax.mk uu___1 uu___2 + | uu___1 -> + let uu___2 = mk_range t.FStarC_Syntax_Syntax.pos s in + FStarC_Syntax_Syntax.mk_Tm_delayed (t0, s) uu___2) +let (subst_dec_order' : + FStarC_Syntax_Syntax.subst_ts -> + FStarC_Syntax_Syntax.decreases_order -> + FStarC_Syntax_Syntax.decreases_order) + = + fun s -> + fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.Decreases_lex l -> + let uu___1 = FStarC_Compiler_List.map (subst' s) l in + FStarC_Syntax_Syntax.Decreases_lex uu___1 + | FStarC_Syntax_Syntax.Decreases_wf (rel, e) -> + let uu___1 = + let uu___2 = subst' s rel in + let uu___3 = subst' s e in (uu___2, uu___3) in + FStarC_Syntax_Syntax.Decreases_wf uu___1 +let (subst_flags' : + FStarC_Syntax_Syntax.subst_ts -> + FStarC_Syntax_Syntax.cflag Prims.list -> + FStarC_Syntax_Syntax.cflag Prims.list) + = + fun s -> + fun flags -> + FStarC_Compiler_List.map + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.DECREASES dec_order -> + let uu___1 = subst_dec_order' s dec_order in + FStarC_Syntax_Syntax.DECREASES uu___1 + | f -> f) flags +let (subst_bqual' : + FStarC_Syntax_Syntax.subst_ts -> + FStarC_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option) + = + fun s -> + fun i -> + match i with + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Meta t) -> + let uu___ = + let uu___1 = subst' s t in FStarC_Syntax_Syntax.Meta uu___1 in + FStar_Pervasives_Native.Some uu___ + | uu___ -> i +let (subst_aqual' : + FStarC_Syntax_Syntax.subst_ts -> + FStarC_Syntax_Syntax.aqual -> FStarC_Syntax_Syntax.aqual) + = + fun s -> + fun i -> + match i with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some a -> + let uu___ = + let uu___1 = + FStarC_Compiler_List.map (subst' s) + a.FStarC_Syntax_Syntax.aqual_attributes in + { + FStarC_Syntax_Syntax.aqual_implicit = + (a.FStarC_Syntax_Syntax.aqual_implicit); + FStarC_Syntax_Syntax.aqual_attributes = uu___1 + } in + FStar_Pervasives_Native.Some uu___ +let (subst_comp_typ' : + (FStarC_Syntax_Syntax.subst_elt Prims.list Prims.list * + FStarC_Syntax_Syntax.maybe_set_use_range) -> + FStarC_Syntax_Syntax.comp_typ -> FStarC_Syntax_Syntax.comp_typ) + = + fun s -> + fun t -> + match s with + | ([], FStarC_Syntax_Syntax.NoUseRange) -> t + | ([]::[], FStarC_Syntax_Syntax.NoUseRange) -> t + | uu___ -> + let uu___1 = + FStarC_Compiler_List.map + (subst_univ (FStar_Pervasives_Native.fst s)) + t.FStarC_Syntax_Syntax.comp_univs in + let uu___2 = + tag_lid_with_range t.FStarC_Syntax_Syntax.effect_name s in + let uu___3 = subst' s t.FStarC_Syntax_Syntax.result_typ in + let uu___4 = + FStarC_Compiler_List.map + (fun uu___5 -> + match uu___5 with + | (t1, imp) -> + let uu___6 = subst' s t1 in + let uu___7 = subst_aqual' s imp in (uu___6, uu___7)) + t.FStarC_Syntax_Syntax.effect_args in + let uu___5 = subst_flags' s t.FStarC_Syntax_Syntax.flags in + { + FStarC_Syntax_Syntax.comp_univs = uu___1; + FStarC_Syntax_Syntax.effect_name = uu___2; + FStarC_Syntax_Syntax.result_typ = uu___3; + FStarC_Syntax_Syntax.effect_args = uu___4; + FStarC_Syntax_Syntax.flags = uu___5 + } +let (subst_comp' : + (FStarC_Syntax_Syntax.subst_elt Prims.list Prims.list * + FStarC_Syntax_Syntax.maybe_set_use_range) -> + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax) + = + fun s -> + fun t -> + match s with + | ([], FStarC_Syntax_Syntax.NoUseRange) -> t + | ([]::[], FStarC_Syntax_Syntax.NoUseRange) -> t + | uu___ -> + (match t.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total t1 -> + let uu___1 = subst' s t1 in + FStarC_Syntax_Syntax.mk_Total uu___1 + | FStarC_Syntax_Syntax.GTotal t1 -> + let uu___1 = subst' s t1 in + FStarC_Syntax_Syntax.mk_GTotal uu___1 + | FStarC_Syntax_Syntax.Comp ct -> + let uu___1 = subst_comp_typ' s ct in + FStarC_Syntax_Syntax.mk_Comp uu___1) +let (subst_ascription' : + FStarC_Syntax_Syntax.subst_ts -> + FStarC_Syntax_Syntax.ascription -> + ((FStarC_Syntax_Syntax.term, + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax) + FStar_Pervasives.either * FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option * Prims.bool)) + = + fun s -> + fun asc -> + let uu___ = asc in + match uu___ with + | (annot, topt, use_eq) -> + let annot1 = + match annot with + | FStar_Pervasives.Inl t -> + let uu___1 = subst' s t in FStar_Pervasives.Inl uu___1 + | FStar_Pervasives.Inr c -> + let uu___1 = subst_comp' s c in FStar_Pervasives.Inr uu___1 in + let uu___1 = FStarC_Compiler_Util.map_opt topt (subst' s) in + (annot1, uu___1, use_eq) +let (shift : + Prims.int -> + FStarC_Syntax_Syntax.subst_elt -> FStarC_Syntax_Syntax.subst_elt) + = + fun n -> + fun s -> + match s with + | FStarC_Syntax_Syntax.DB (i, t) -> + FStarC_Syntax_Syntax.DB ((i + n), t) + | FStarC_Syntax_Syntax.DT (i, t) -> + FStarC_Syntax_Syntax.DT ((i + n), t) + | FStarC_Syntax_Syntax.UN (i, t) -> + FStarC_Syntax_Syntax.UN ((i + n), t) + | FStarC_Syntax_Syntax.NM (x, i) -> + FStarC_Syntax_Syntax.NM (x, (i + n)) + | FStarC_Syntax_Syntax.UD (x, i) -> + FStarC_Syntax_Syntax.UD (x, (i + n)) + | FStarC_Syntax_Syntax.NT uu___ -> s +let (shift_subst : + Prims.int -> FStarC_Syntax_Syntax.subst_t -> FStarC_Syntax_Syntax.subst_t) + = fun n -> fun s -> FStarC_Compiler_List.map (shift n) s +let shift_subst' : + 'uuuuu . + Prims.int -> + (FStarC_Syntax_Syntax.subst_t Prims.list * 'uuuuu) -> + (FStarC_Syntax_Syntax.subst_t Prims.list * 'uuuuu) + = + fun n -> + fun s -> + let uu___ = + FStarC_Compiler_List.map (shift_subst n) + (FStar_Pervasives_Native.fst s) in + (uu___, (FStar_Pervasives_Native.snd s)) +let (subst_binder' : + FStarC_Syntax_Syntax.subst_ts -> + FStarC_Syntax_Syntax.binder -> FStarC_Syntax_Syntax.binder) + = + fun s -> + fun b -> + let uu___ = + let uu___1 = b.FStarC_Syntax_Syntax.binder_bv in + let uu___2 = + subst' s + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + { + FStarC_Syntax_Syntax.ppname = (uu___1.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = (uu___1.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = uu___2 + } in + let uu___1 = subst_bqual' s b.FStarC_Syntax_Syntax.binder_qual in + let uu___2 = + FStarC_Compiler_List.map (subst' s) + b.FStarC_Syntax_Syntax.binder_attrs in + FStarC_Syntax_Syntax.mk_binder_with_attrs uu___ uu___1 + b.FStarC_Syntax_Syntax.binder_positivity uu___2 +let (subst_binder : + FStarC_Syntax_Syntax.subst_elt Prims.list -> + FStarC_Syntax_Syntax.binder -> FStarC_Syntax_Syntax.binder) + = fun s -> fun b -> subst_binder' ([s], FStarC_Syntax_Syntax.NoUseRange) b +let (subst_binders' : + (FStarC_Syntax_Syntax.subst_elt Prims.list Prims.list * + FStarC_Syntax_Syntax.maybe_set_use_range) -> + FStarC_Syntax_Syntax.binder Prims.list -> + FStarC_Syntax_Syntax.binder Prims.list) + = + fun s -> + fun bs -> + FStarC_Compiler_List.mapi + (fun i -> + fun b -> + if i = Prims.int_zero + then subst_binder' s b + else (let uu___1 = shift_subst' i s in subst_binder' uu___1 b)) + bs +let (subst_binders : + FStarC_Syntax_Syntax.subst_elt Prims.list -> + FStarC_Syntax_Syntax.binders -> FStarC_Syntax_Syntax.binders) + = + fun s -> fun bs -> subst_binders' ([s], FStarC_Syntax_Syntax.NoUseRange) bs +let subst_arg' : + 'uuuuu . + FStarC_Syntax_Syntax.subst_ts -> + (FStarC_Syntax_Syntax.term * 'uuuuu) -> + (FStarC_Syntax_Syntax.term * 'uuuuu) + = + fun s -> + fun uu___ -> + match uu___ with | (t, imp) -> let uu___1 = subst' s t in (uu___1, imp) +let subst_args' : + 'uuuuu . + FStarC_Syntax_Syntax.subst_ts -> + (FStarC_Syntax_Syntax.term * 'uuuuu) Prims.list -> + (FStarC_Syntax_Syntax.term * 'uuuuu) Prims.list + = fun s -> FStarC_Compiler_List.map (subst_arg' s) +let (subst_univs_opt : + FStarC_Syntax_Syntax.subst_elt Prims.list Prims.list -> + FStarC_Syntax_Syntax.universe Prims.list FStar_Pervasives_Native.option + -> + FStarC_Syntax_Syntax.universe Prims.list FStar_Pervasives_Native.option) + = + fun sub -> + fun us_opt -> + match us_opt with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some us -> + let uu___ = FStarC_Compiler_List.map (subst_univ sub) us in + FStar_Pervasives_Native.Some uu___ +let (subst_pat' : + (FStarC_Syntax_Syntax.subst_t Prims.list * + FStarC_Syntax_Syntax.maybe_set_use_range) -> + FStarC_Syntax_Syntax.pat' FStarC_Syntax_Syntax.withinfo_t -> + (FStarC_Syntax_Syntax.pat * Prims.int)) + = + fun s -> + fun p -> + let rec aux n p1 = + match p1.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_constant uu___ -> (p1, n) + | FStarC_Syntax_Syntax.Pat_cons (fv, us_opt, pats) -> + let us_opt1 = + let uu___ = + let uu___1 = shift_subst' n s in + FStar_Pervasives_Native.fst uu___1 in + subst_univs_opt uu___ us_opt in + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun uu___2 -> + match (uu___1, uu___2) with + | ((pats1, n1), (p2, imp)) -> + let uu___3 = aux n1 p2 in + (match uu___3 with + | (p3, m) -> (((p3, imp) :: pats1), m))) ([], n) + pats in + (match uu___ with + | (pats1, n1) -> + ({ + FStarC_Syntax_Syntax.v = + (FStarC_Syntax_Syntax.Pat_cons + (fv, us_opt1, (FStarC_Compiler_List.rev pats1))); + FStarC_Syntax_Syntax.p = (p1.FStarC_Syntax_Syntax.p) + }, n1)) + | FStarC_Syntax_Syntax.Pat_var x -> + let s1 = shift_subst' n s in + let x1 = + let uu___ = subst' s1 x.FStarC_Syntax_Syntax.sort in + { + FStarC_Syntax_Syntax.ppname = (x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = (x.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = uu___ + } in + ({ + FStarC_Syntax_Syntax.v = (FStarC_Syntax_Syntax.Pat_var x1); + FStarC_Syntax_Syntax.p = (p1.FStarC_Syntax_Syntax.p) + }, (n + Prims.int_one)) + | FStarC_Syntax_Syntax.Pat_dot_term eopt -> + let s1 = shift_subst' n s in + let eopt1 = FStarC_Compiler_Util.map_option (subst' s1) eopt in + ({ + FStarC_Syntax_Syntax.v = + (FStarC_Syntax_Syntax.Pat_dot_term eopt1); + FStarC_Syntax_Syntax.p = (p1.FStarC_Syntax_Syntax.p) + }, n) in + aux Prims.int_zero p +let (push_subst_lcomp : + FStarC_Syntax_Syntax.subst_ts -> + FStarC_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option) + = + fun s -> + fun lopt -> + match lopt with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some rc -> + let residual_typ = + FStarC_Compiler_Util.map_opt rc.FStarC_Syntax_Syntax.residual_typ + (subst' s) in + let rc1 = + { + FStarC_Syntax_Syntax.residual_effect = + (rc.FStarC_Syntax_Syntax.residual_effect); + FStarC_Syntax_Syntax.residual_typ = residual_typ; + FStarC_Syntax_Syntax.residual_flags = + (rc.FStarC_Syntax_Syntax.residual_flags) + } in + FStar_Pervasives_Native.Some rc1 +let (compose_uvar_subst : + FStarC_Syntax_Syntax.ctx_uvar -> + FStarC_Syntax_Syntax.subst_ts -> + FStarC_Syntax_Syntax.subst_ts -> FStarC_Syntax_Syntax.subst_ts) + = + fun u -> + fun s0 -> + fun s -> + let should_retain x = + FStarC_Compiler_Util.for_some + (fun b -> + FStarC_Syntax_Syntax.bv_eq x b.FStarC_Syntax_Syntax.binder_bv) + u.FStarC_Syntax_Syntax.ctx_uvar_binders in + let rec aux uu___ = + match uu___ with + | [] -> [] + | hd_subst::rest -> + let hd = + FStarC_Compiler_List.collect + (fun uu___1 -> + match uu___1 with + | FStarC_Syntax_Syntax.NT (x, t) -> + let uu___2 = should_retain x in + if uu___2 + then + let uu___3 = + let uu___4 = + let uu___5 = + delay t + (rest, FStarC_Syntax_Syntax.NoUseRange) in + (x, uu___5) in + FStarC_Syntax_Syntax.NT uu___4 in + [uu___3] + else [] + | FStarC_Syntax_Syntax.NM (x, i) -> + let uu___2 = should_retain x in + if uu___2 + then + let x_i = + FStarC_Syntax_Syntax.bv_to_tm + { + FStarC_Syntax_Syntax.ppname = + (x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = i; + FStarC_Syntax_Syntax.sort = + (x.FStarC_Syntax_Syntax.sort) + } in + let t = + subst' (rest, FStarC_Syntax_Syntax.NoUseRange) + x_i in + (match t.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_bvar x_j -> + [FStarC_Syntax_Syntax.NM + (x, (x_j.FStarC_Syntax_Syntax.index))] + | uu___3 -> [FStarC_Syntax_Syntax.NT (x, t)]) + else [] + | uu___2 -> []) hd_subst in + let uu___1 = aux rest in FStarC_Compiler_List.op_At hd uu___1 in + let uu___ = + aux + (FStarC_Compiler_List.op_At (FStar_Pervasives_Native.fst s0) + (FStar_Pervasives_Native.fst s)) in + match uu___ with + | [] -> ([], (FStar_Pervasives_Native.snd s)) + | s' -> ([s'], (FStar_Pervasives_Native.snd s)) +let rec (push_subst_aux : + Prims.bool -> + FStarC_Syntax_Syntax.subst_ts -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun resolve_uvars -> + fun s -> + fun t -> + let mk t' = + let uu___ = mk_range t.FStarC_Syntax_Syntax.pos s in + FStarC_Syntax_Syntax.mk t' uu___ in + match t.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_delayed uu___ -> + failwith "Impossible (delayed node in push_subst)" + | FStarC_Syntax_Syntax.Tm_lazy i -> + (match i.FStarC_Syntax_Syntax.lkind with + | FStarC_Syntax_Syntax.Lazy_embedding uu___ -> + let t1 = + let uu___1 = + let uu___2 = + FStarC_Compiler_Effect.op_Bang + FStarC_Syntax_Syntax.lazy_chooser in + FStarC_Compiler_Util.must uu___2 in + uu___1 i.FStarC_Syntax_Syntax.lkind i in + push_subst_aux resolve_uvars s t1 + | uu___ -> tag_with_range t s) + | FStarC_Syntax_Syntax.Tm_constant uu___ -> tag_with_range t s + | FStarC_Syntax_Syntax.Tm_fvar uu___ -> tag_with_range t s + | FStarC_Syntax_Syntax.Tm_unknown -> tag_with_range t s + | FStarC_Syntax_Syntax.Tm_uvar (uv, s0) -> + let fallback uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = compose_uvar_subst uv s0 s in (uv, uu___4) in + FStarC_Syntax_Syntax.Tm_uvar uu___3 in + { + FStarC_Syntax_Syntax.n = uu___2; + FStarC_Syntax_Syntax.pos = (t.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = (t.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (t.FStarC_Syntax_Syntax.hash_code) + } in + tag_with_range uu___1 s in + if Prims.op_Negation resolve_uvars + then fallback () + else + (let uu___1 = + FStarC_Syntax_Unionfind.find + uv.FStarC_Syntax_Syntax.ctx_uvar_head in + match uu___1 with + | FStar_Pervasives_Native.None -> fallback () + | FStar_Pervasives_Native.Some t1 -> + push_subst_aux resolve_uvars (compose_subst s0 s) t1) + | FStarC_Syntax_Syntax.Tm_type uu___ -> subst' s t + | FStarC_Syntax_Syntax.Tm_bvar uu___ -> subst' s t + | FStarC_Syntax_Syntax.Tm_name uu___ -> subst' s t + | FStarC_Syntax_Syntax.Tm_uinst (t', us) -> + let us1 = + FStarC_Compiler_List.map + (subst_univ (FStar_Pervasives_Native.fst s)) us in + let uu___ = mk (FStarC_Syntax_Syntax.Tm_uinst (t', us1)) in + tag_with_range uu___ s + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = t0; + FStarC_Syntax_Syntax.args = args;_} + -> + let uu___ = + let uu___1 = + let uu___2 = subst' s t0 in + let uu___3 = subst_args' s args in + { + FStarC_Syntax_Syntax.hd = uu___2; + FStarC_Syntax_Syntax.args = uu___3 + } in + FStarC_Syntax_Syntax.Tm_app uu___1 in + mk uu___ + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t0; FStarC_Syntax_Syntax.asc = asc; + FStarC_Syntax_Syntax.eff_opt = lopt;_} + -> + let uu___ = + let uu___1 = + let uu___2 = subst' s t0 in + let uu___3 = subst_ascription' s asc in + { + FStarC_Syntax_Syntax.tm = uu___2; + FStarC_Syntax_Syntax.asc = uu___3; + FStarC_Syntax_Syntax.eff_opt = lopt + } in + FStarC_Syntax_Syntax.Tm_ascribed uu___1 in + mk uu___ + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs; FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = lopt;_} + -> + let n = FStarC_Compiler_List.length bs in + let s' = shift_subst' n s in + let uu___ = + let uu___1 = + let uu___2 = subst_binders' s bs in + let uu___3 = subst' s' body in + let uu___4 = push_subst_lcomp s' lopt in + { + FStarC_Syntax_Syntax.bs = uu___2; + FStarC_Syntax_Syntax.body = uu___3; + FStarC_Syntax_Syntax.rc_opt = uu___4 + } in + FStarC_Syntax_Syntax.Tm_abs uu___1 in + mk uu___ + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = comp;_} + -> + let n = FStarC_Compiler_List.length bs in + let uu___ = + let uu___1 = + let uu___2 = subst_binders' s bs in + let uu___3 = + let uu___4 = shift_subst' n s in subst_comp' uu___4 comp in + { + FStarC_Syntax_Syntax.bs1 = uu___2; + FStarC_Syntax_Syntax.comp = uu___3 + } in + FStarC_Syntax_Syntax.Tm_arrow uu___1 in + mk uu___ + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x; FStarC_Syntax_Syntax.phi = phi;_} + -> + let x1 = + let uu___ = subst' s x.FStarC_Syntax_Syntax.sort in + { + FStarC_Syntax_Syntax.ppname = (x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = (x.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = uu___ + } in + let phi1 = + let uu___ = shift_subst' Prims.int_one s in subst' uu___ phi in + mk + (FStarC_Syntax_Syntax.Tm_refine + { + FStarC_Syntax_Syntax.b = x1; + FStarC_Syntax_Syntax.phi = phi1 + }) + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = t0; + FStarC_Syntax_Syntax.ret_opt = asc_opt; + FStarC_Syntax_Syntax.brs = pats; + FStarC_Syntax_Syntax.rc_opt1 = lopt;_} + -> + let t01 = subst' s t0 in + let pats1 = + FStarC_Compiler_List.map + (fun uu___ -> + match uu___ with + | (pat, wopt, branch) -> + let uu___1 = subst_pat' s pat in + (match uu___1 with + | (pat1, n) -> + let s1 = shift_subst' n s in + let wopt1 = + match wopt with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some w -> + let uu___2 = subst' s1 w in + FStar_Pervasives_Native.Some uu___2 in + let branch1 = subst' s1 branch in + (pat1, wopt1, branch1))) pats in + let asc_opt1 = + match asc_opt with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (b, asc) -> + let b1 = subst_binder' s b in + let asc1 = + let uu___ = shift_subst' Prims.int_one s in + subst_ascription' uu___ asc in + FStar_Pervasives_Native.Some (b1, asc1) in + let uu___ = + let uu___1 = + let uu___2 = push_subst_lcomp s lopt in + { + FStarC_Syntax_Syntax.scrutinee = t01; + FStarC_Syntax_Syntax.ret_opt = asc_opt1; + FStarC_Syntax_Syntax.brs = pats1; + FStarC_Syntax_Syntax.rc_opt1 = uu___2 + } in + FStarC_Syntax_Syntax.Tm_match uu___1 in + mk uu___ + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (is_rec, lbs); + FStarC_Syntax_Syntax.body1 = body;_} + -> + let n = FStarC_Compiler_List.length lbs in + let sn = shift_subst' n s in + let body1 = subst' sn body in + let lbs1 = + FStarC_Compiler_List.map + (fun lb -> + let lbt = subst' s lb.FStarC_Syntax_Syntax.lbtyp in + let lbd = + let uu___ = + is_rec && + (FStarC_Compiler_Util.is_left + lb.FStarC_Syntax_Syntax.lbname) in + if uu___ + then subst' sn lb.FStarC_Syntax_Syntax.lbdef + else subst' s lb.FStarC_Syntax_Syntax.lbdef in + let lbname = + match lb.FStarC_Syntax_Syntax.lbname with + | FStar_Pervasives.Inl x -> + FStar_Pervasives.Inl + { + FStarC_Syntax_Syntax.ppname = + (x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (x.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = lbt + } + | FStar_Pervasives.Inr fv -> FStar_Pervasives.Inr fv in + let lbattrs = + FStarC_Compiler_List.map (subst' s) + lb.FStarC_Syntax_Syntax.lbattrs in + { + FStarC_Syntax_Syntax.lbname = lbname; + FStarC_Syntax_Syntax.lbunivs = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = lbt; + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = lbd; + FStarC_Syntax_Syntax.lbattrs = lbattrs; + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + }) lbs in + mk + (FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = (is_rec, lbs1); + FStarC_Syntax_Syntax.body1 = body1 + }) + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t0; + FStarC_Syntax_Syntax.meta = FStarC_Syntax_Syntax.Meta_pattern + (bs, ps);_} + -> + let uu___ = + let uu___1 = + let uu___2 = subst' s t0 in + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Compiler_List.map (subst' s) bs in + let uu___6 = FStarC_Compiler_List.map (subst_args' s) ps in + (uu___5, uu___6) in + FStarC_Syntax_Syntax.Meta_pattern uu___4 in + { + FStarC_Syntax_Syntax.tm2 = uu___2; + FStarC_Syntax_Syntax.meta = uu___3 + } in + FStarC_Syntax_Syntax.Tm_meta uu___1 in + mk uu___ + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t0; + FStarC_Syntax_Syntax.meta = FStarC_Syntax_Syntax.Meta_monadic + (m, t1);_} + -> + let uu___ = + let uu___1 = + let uu___2 = subst' s t0 in + let uu___3 = + let uu___4 = let uu___5 = subst' s t1 in (m, uu___5) in + FStarC_Syntax_Syntax.Meta_monadic uu___4 in + { + FStarC_Syntax_Syntax.tm2 = uu___2; + FStarC_Syntax_Syntax.meta = uu___3 + } in + FStarC_Syntax_Syntax.Tm_meta uu___1 in + mk uu___ + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t0; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_monadic_lift (m1, m2, t1);_} + -> + let uu___ = + let uu___1 = + let uu___2 = subst' s t0 in + let uu___3 = + let uu___4 = let uu___5 = subst' s t1 in (m1, m2, uu___5) in + FStarC_Syntax_Syntax.Meta_monadic_lift uu___4 in + { + FStarC_Syntax_Syntax.tm2 = uu___2; + FStarC_Syntax_Syntax.meta = uu___3 + } in + FStarC_Syntax_Syntax.Tm_meta uu___1 in + mk uu___ + | FStarC_Syntax_Syntax.Tm_quoted (tm, qi) -> + (match qi.FStarC_Syntax_Syntax.qkind with + | FStarC_Syntax_Syntax.Quote_dynamic -> + let uu___ = + let uu___1 = let uu___2 = subst' s tm in (uu___2, qi) in + FStarC_Syntax_Syntax.Tm_quoted uu___1 in + mk uu___ + | FStarC_Syntax_Syntax.Quote_static -> + let qi1 = FStarC_Syntax_Syntax.on_antiquoted (subst' s) qi in + mk (FStarC_Syntax_Syntax.Tm_quoted (tm, qi1))) + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t1; FStarC_Syntax_Syntax.meta = m;_} + -> + let uu___ = + let uu___1 = + let uu___2 = subst' s t1 in + { + FStarC_Syntax_Syntax.tm2 = uu___2; + FStarC_Syntax_Syntax.meta = m + } in + FStarC_Syntax_Syntax.Tm_meta uu___1 in + mk uu___ +let (push_subst : + FStarC_Syntax_Syntax.subst_ts -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = fun s -> fun t -> push_subst_aux true s t +let (compress_subst : FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun t -> + match t.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_delayed + { FStarC_Syntax_Syntax.tm1 = t1; FStarC_Syntax_Syntax.substs = s;_} + -> let resolve_uvars = false in push_subst_aux resolve_uvars s t1 + | uu___ -> t +let rec (compress_slow : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun t -> + let t1 = force_uvar t in + match t1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_delayed + { FStarC_Syntax_Syntax.tm1 = t'; FStarC_Syntax_Syntax.substs = s;_} + -> let uu___ = push_subst s t' in compress uu___ + | uu___ -> t1 +and (compress : FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) = + fun t -> + match t.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_delayed uu___ -> let r = compress_slow t in r + | FStarC_Syntax_Syntax.Tm_uvar uu___ -> let r = compress_slow t in r + | uu___ -> t +let (subst : + FStarC_Syntax_Syntax.subst_elt Prims.list -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = fun s -> fun t -> subst' ([s], FStarC_Syntax_Syntax.NoUseRange) t +let (set_use_range : + FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun r -> + fun t -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Compiler_Range_Type.use_range r in + FStarC_Compiler_Range_Type.set_def_range r uu___3 in + FStarC_Syntax_Syntax.SomeUseRange uu___2 in + ([], uu___1) in + subst' uu___ t +let (subst_comp : + FStarC_Syntax_Syntax.subst_elt Prims.list -> + FStarC_Syntax_Syntax.comp -> FStarC_Syntax_Syntax.comp) + = fun s -> fun t -> subst_comp' ([s], FStarC_Syntax_Syntax.NoUseRange) t +let (subst_bqual : + FStarC_Syntax_Syntax.subst_elt Prims.list -> + FStarC_Syntax_Syntax.bqual -> FStarC_Syntax_Syntax.bqual) + = + fun s -> fun imp -> subst_bqual' ([s], FStarC_Syntax_Syntax.NoUseRange) imp +let (subst_aqual : + FStarC_Syntax_Syntax.subst_elt Prims.list -> + FStarC_Syntax_Syntax.aqual -> FStarC_Syntax_Syntax.aqual) + = + fun s -> fun imp -> subst_aqual' ([s], FStarC_Syntax_Syntax.NoUseRange) imp +let (subst_ascription : + FStarC_Syntax_Syntax.subst_elt Prims.list -> + FStarC_Syntax_Syntax.ascription -> FStarC_Syntax_Syntax.ascription) + = + fun s -> + fun asc -> subst_ascription' ([s], FStarC_Syntax_Syntax.NoUseRange) asc +let (subst_decreasing_order : + FStarC_Syntax_Syntax.subst_elt Prims.list -> + FStarC_Syntax_Syntax.decreases_order -> + FStarC_Syntax_Syntax.decreases_order) + = + fun s -> + fun dec -> subst_dec_order' ([s], FStarC_Syntax_Syntax.NoUseRange) dec +let (subst_residual_comp : + FStarC_Syntax_Syntax.subst_elt Prims.list -> + FStarC_Syntax_Syntax.residual_comp -> FStarC_Syntax_Syntax.residual_comp) + = + fun s -> + fun rc -> + match rc.FStarC_Syntax_Syntax.residual_typ with + | FStar_Pervasives_Native.None -> rc + | FStar_Pervasives_Native.Some t -> + let uu___ = + let uu___1 = subst s t in FStar_Pervasives_Native.Some uu___1 in + { + FStarC_Syntax_Syntax.residual_effect = + (rc.FStarC_Syntax_Syntax.residual_effect); + FStarC_Syntax_Syntax.residual_typ = uu___; + FStarC_Syntax_Syntax.residual_flags = + (rc.FStarC_Syntax_Syntax.residual_flags) + } +let (closing_subst : + FStarC_Syntax_Syntax.binders -> FStarC_Syntax_Syntax.subst_elt Prims.list) + = + fun bs -> + let uu___ = + FStarC_Compiler_List.fold_right + (fun b -> + fun uu___1 -> + match uu___1 with + | (subst1, n) -> + (((FStarC_Syntax_Syntax.NM + ((b.FStarC_Syntax_Syntax.binder_bv), n)) :: subst1), + (n + Prims.int_one))) bs ([], Prims.int_zero) in + FStar_Pervasives_Native.fst uu___ +let (open_binders' : + FStarC_Syntax_Syntax.binders -> + (FStarC_Syntax_Syntax.binders * FStarC_Syntax_Syntax.subst_t)) + = + fun bs -> + let rec aux bs1 o = + match bs1 with + | [] -> ([], o) + | b::bs' -> + let x' = + let uu___ = + FStarC_Syntax_Syntax.freshen_bv + b.FStarC_Syntax_Syntax.binder_bv in + let uu___1 = + subst o + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + { + FStarC_Syntax_Syntax.ppname = + (uu___.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = (uu___.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = uu___1 + } in + let imp = subst_bqual o b.FStarC_Syntax_Syntax.binder_qual in + let attrs = + FStarC_Compiler_List.map (subst o) + b.FStarC_Syntax_Syntax.binder_attrs in + let o1 = + let uu___ = shift_subst Prims.int_one o in + (FStarC_Syntax_Syntax.DB (Prims.int_zero, x')) :: uu___ in + let uu___ = aux bs' o1 in + (match uu___ with + | (bs'1, o2) -> + let uu___1 = + let uu___2 = + FStarC_Syntax_Syntax.mk_binder_with_attrs x' imp + b.FStarC_Syntax_Syntax.binder_positivity attrs in + uu___2 :: bs'1 in + (uu___1, o2)) in + aux bs [] +let (open_binders : + FStarC_Syntax_Syntax.binders -> FStarC_Syntax_Syntax.binders) = + fun bs -> let uu___ = open_binders' bs in FStar_Pervasives_Native.fst uu___ +let (open_term' : + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.binders * FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.subst_t)) + = + fun bs -> + fun t -> + let uu___ = open_binders' bs in + match uu___ with + | (bs', opening) -> + let uu___1 = subst opening t in (bs', uu___1, opening) +let (open_term : + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.binders * FStarC_Syntax_Syntax.term)) + = + fun bs -> + fun t -> + let uu___ = open_term' bs t in + match uu___ with | (b, t1, uu___1) -> (b, t1) +let (open_comp : + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.comp -> + (FStarC_Syntax_Syntax.binders * FStarC_Syntax_Syntax.comp)) + = + fun bs -> + fun t -> + let uu___ = open_binders' bs in + match uu___ with + | (bs', opening) -> let uu___1 = subst_comp opening t in (bs', uu___1) +let (open_ascription : + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.ascription -> + (FStarC_Syntax_Syntax.binders * FStarC_Syntax_Syntax.ascription)) + = + fun bs -> + fun asc -> + let uu___ = open_binders' bs in + match uu___ with + | (bs', opening) -> + let uu___1 = subst_ascription opening asc in (bs', uu___1) +let (open_pat : + FStarC_Syntax_Syntax.pat -> + (FStarC_Syntax_Syntax.pat * FStarC_Syntax_Syntax.subst_t)) + = + fun p -> + let rec open_pat_aux sub p1 = + match p1.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_constant uu___ -> (p1, sub) + | FStarC_Syntax_Syntax.Pat_cons (fv, us_opt, pats) -> + let us_opt1 = subst_univs_opt [sub] us_opt in + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun uu___2 -> + match (uu___1, uu___2) with + | ((pats1, sub1), (p2, imp)) -> + let uu___3 = open_pat_aux sub1 p2 in + (match uu___3 with + | (p3, sub2) -> (((p3, imp) :: pats1), sub2))) + ([], sub) pats in + (match uu___ with + | (pats1, sub1) -> + ({ + FStarC_Syntax_Syntax.v = + (FStarC_Syntax_Syntax.Pat_cons + (fv, us_opt1, (FStarC_Compiler_List.rev pats1))); + FStarC_Syntax_Syntax.p = (p1.FStarC_Syntax_Syntax.p) + }, sub1)) + | FStarC_Syntax_Syntax.Pat_var x -> + let x' = + let uu___ = FStarC_Syntax_Syntax.freshen_bv x in + let uu___1 = subst sub x.FStarC_Syntax_Syntax.sort in + { + FStarC_Syntax_Syntax.ppname = + (uu___.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = (uu___.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = uu___1 + } in + let sub1 = + let uu___ = shift_subst Prims.int_one sub in + (FStarC_Syntax_Syntax.DB (Prims.int_zero, x')) :: uu___ in + ({ + FStarC_Syntax_Syntax.v = (FStarC_Syntax_Syntax.Pat_var x'); + FStarC_Syntax_Syntax.p = (p1.FStarC_Syntax_Syntax.p) + }, sub1) + | FStarC_Syntax_Syntax.Pat_dot_term eopt -> + let eopt1 = FStarC_Compiler_Util.map_option (subst sub) eopt in + ({ + FStarC_Syntax_Syntax.v = + (FStarC_Syntax_Syntax.Pat_dot_term eopt1); + FStarC_Syntax_Syntax.p = (p1.FStarC_Syntax_Syntax.p) + }, sub) in + open_pat_aux [] p +let (open_branch' : + FStarC_Syntax_Syntax.branch -> + (FStarC_Syntax_Syntax.branch * FStarC_Syntax_Syntax.subst_t)) + = + fun uu___ -> + match uu___ with + | (p, wopt, e) -> + let uu___1 = open_pat p in + (match uu___1 with + | (p1, opening) -> + let wopt1 = + match wopt with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some w -> + let uu___2 = subst opening w in + FStar_Pervasives_Native.Some uu___2 in + let e1 = subst opening e in ((p1, wopt1, e1), opening)) +let (open_branch : + FStarC_Syntax_Syntax.branch -> FStarC_Syntax_Syntax.branch) = + fun br -> + let uu___ = open_branch' br in match uu___ with | (br1, uu___1) -> br1 +let (close : + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = fun bs -> fun t -> let uu___ = closing_subst bs in subst uu___ t +let (close_comp : + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.comp -> FStarC_Syntax_Syntax.comp) + = fun bs -> fun c -> let uu___ = closing_subst bs in subst_comp uu___ c +let (close_binders : + FStarC_Syntax_Syntax.binders -> FStarC_Syntax_Syntax.binders) = + fun bs -> + let rec aux s bs1 = + match bs1 with + | [] -> [] + | b::tl -> + let x = + let uu___ = b.FStarC_Syntax_Syntax.binder_bv in + let uu___1 = + subst s + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + { + FStarC_Syntax_Syntax.ppname = + (uu___.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = (uu___.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = uu___1 + } in + let imp = subst_bqual s b.FStarC_Syntax_Syntax.binder_qual in + let attrs = + FStarC_Compiler_List.map (subst s) + b.FStarC_Syntax_Syntax.binder_attrs in + let s' = + let uu___ = shift_subst Prims.int_one s in + (FStarC_Syntax_Syntax.NM (x, Prims.int_zero)) :: uu___ in + let uu___ = + FStarC_Syntax_Syntax.mk_binder_with_attrs x imp + b.FStarC_Syntax_Syntax.binder_positivity attrs in + let uu___1 = aux s' tl in uu___ :: uu___1 in + aux [] bs +let (close_ascription : + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.ascription -> FStarC_Syntax_Syntax.ascription) + = + fun bs -> + fun asc -> let uu___ = closing_subst bs in subst_ascription uu___ asc +let (close_pat : + FStarC_Syntax_Syntax.pat' FStarC_Syntax_Syntax.withinfo_t -> + (FStarC_Syntax_Syntax.pat' FStarC_Syntax_Syntax.withinfo_t * + FStarC_Syntax_Syntax.subst_elt Prims.list)) + = + fun p -> + let rec aux sub p1 = + match p1.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_constant uu___ -> (p1, sub) + | FStarC_Syntax_Syntax.Pat_cons (fv, us_opt, pats) -> + let us_opt1 = subst_univs_opt [sub] us_opt in + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun uu___2 -> + match (uu___1, uu___2) with + | ((pats1, sub1), (p2, imp)) -> + let uu___3 = aux sub1 p2 in + (match uu___3 with + | (p3, sub2) -> (((p3, imp) :: pats1), sub2))) + ([], sub) pats in + (match uu___ with + | (pats1, sub1) -> + ({ + FStarC_Syntax_Syntax.v = + (FStarC_Syntax_Syntax.Pat_cons + (fv, us_opt1, (FStarC_Compiler_List.rev pats1))); + FStarC_Syntax_Syntax.p = (p1.FStarC_Syntax_Syntax.p) + }, sub1)) + | FStarC_Syntax_Syntax.Pat_var x -> + let x1 = + let uu___ = subst sub x.FStarC_Syntax_Syntax.sort in + { + FStarC_Syntax_Syntax.ppname = (x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = (x.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = uu___ + } in + let sub1 = + let uu___ = shift_subst Prims.int_one sub in + (FStarC_Syntax_Syntax.NM (x1, Prims.int_zero)) :: uu___ in + ({ + FStarC_Syntax_Syntax.v = (FStarC_Syntax_Syntax.Pat_var x1); + FStarC_Syntax_Syntax.p = (p1.FStarC_Syntax_Syntax.p) + }, sub1) + | FStarC_Syntax_Syntax.Pat_dot_term eopt -> + let eopt1 = FStarC_Compiler_Util.map_option (subst sub) eopt in + ({ + FStarC_Syntax_Syntax.v = + (FStarC_Syntax_Syntax.Pat_dot_term eopt1); + FStarC_Syntax_Syntax.p = (p1.FStarC_Syntax_Syntax.p) + }, sub) in + aux [] p +let (close_branch : + FStarC_Syntax_Syntax.branch -> FStarC_Syntax_Syntax.branch) = + fun uu___ -> + match uu___ with + | (p, wopt, e) -> + let uu___1 = close_pat p in + (match uu___1 with + | (p1, closing) -> + let wopt1 = + match wopt with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some w -> + let uu___2 = subst closing w in + FStar_Pervasives_Native.Some uu___2 in + let e1 = subst closing e in (p1, wopt1, e1)) +let (univ_var_opening : + FStarC_Syntax_Syntax.univ_names -> + (FStarC_Syntax_Syntax.subst_elt Prims.list * + FStarC_Syntax_Syntax.univ_name Prims.list)) + = + fun us -> + let n = (FStarC_Compiler_List.length us) - Prims.int_one in + let s = + FStarC_Compiler_List.mapi + (fun i -> + fun u -> + FStarC_Syntax_Syntax.UN + ((n - i), (FStarC_Syntax_Syntax.U_name u))) us in + (s, us) +let (univ_var_closing : + FStarC_Syntax_Syntax.univ_names -> + FStarC_Syntax_Syntax.subst_elt Prims.list) + = + fun us -> + let n = (FStarC_Compiler_List.length us) - Prims.int_one in + FStarC_Compiler_List.mapi + (fun i -> fun u -> FStarC_Syntax_Syntax.UD (u, (n - i))) us +let (open_univ_vars : + FStarC_Syntax_Syntax.univ_names -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.univ_names * FStarC_Syntax_Syntax.term)) + = + fun us -> + fun t -> + let uu___ = univ_var_opening us in + match uu___ with | (s, us') -> let t1 = subst s t in (us', t1) +let (open_univ_vars_comp : + FStarC_Syntax_Syntax.univ_names -> + FStarC_Syntax_Syntax.comp -> + (FStarC_Syntax_Syntax.univ_names * FStarC_Syntax_Syntax.comp)) + = + fun us -> + fun c -> + let uu___ = univ_var_opening us in + match uu___ with + | (s, us') -> let uu___1 = subst_comp s c in (us', uu___1) +let (close_univ_vars : + FStarC_Syntax_Syntax.univ_names -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = fun us -> fun t -> let s = univ_var_closing us in subst s t +let (close_univ_vars_comp : + FStarC_Syntax_Syntax.univ_names -> + FStarC_Syntax_Syntax.comp -> FStarC_Syntax_Syntax.comp) + = + fun us -> + fun c -> + let n = (FStarC_Compiler_List.length us) - Prims.int_one in + let s = + FStarC_Compiler_List.mapi + (fun i -> fun u -> FStarC_Syntax_Syntax.UD (u, (n - i))) us in + subst_comp s c +let (open_let_rec : + FStarC_Syntax_Syntax.letbinding Prims.list -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.letbinding Prims.list * + FStarC_Syntax_Syntax.term)) + = + fun lbs -> + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Syntax.is_top_level lbs in + if uu___1 + then (Prims.int_zero, lbs, []) + else + FStarC_Compiler_List.fold_right + (fun lb -> + fun uu___3 -> + match uu___3 with + | (i, lbs1, out) -> + let x = + let uu___4 = + FStarC_Compiler_Util.left + lb.FStarC_Syntax_Syntax.lbname in + FStarC_Syntax_Syntax.freshen_bv uu___4 in + ((i + Prims.int_one), + ({ + FStarC_Syntax_Syntax.lbname = + (FStar_Pervasives.Inl x); + FStarC_Syntax_Syntax.lbunivs = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = + (lb.FStarC_Syntax_Syntax.lbtyp); + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = + (lb.FStarC_Syntax_Syntax.lbdef); + FStarC_Syntax_Syntax.lbattrs = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + } :: lbs1), ((FStarC_Syntax_Syntax.DB (i, x)) :: + out))) lbs (Prims.int_zero, [], []) in + match uu___ with + | (n_let_recs, lbs1, let_rec_opening) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Compiler_List.hd lbs1 in + uu___3.FStarC_Syntax_Syntax.lbunivs in + FStarC_Compiler_List.fold_right + (fun u -> + fun uu___3 -> + match uu___3 with + | (i, us, out) -> + let u1 = + FStarC_Syntax_Syntax.new_univ_name + FStar_Pervasives_Native.None in + ((i + Prims.int_one), (u1 :: us), + ((FStarC_Syntax_Syntax.UN + (i, (FStarC_Syntax_Syntax.U_name u1))) :: out))) + uu___2 (n_let_recs, [], let_rec_opening) in + (match uu___1 with + | (uu___2, us, u_let_rec_opening) -> + let lbs2 = + FStarC_Compiler_List.map + (fun lb -> + let uu___3 = + subst u_let_rec_opening lb.FStarC_Syntax_Syntax.lbtyp in + let uu___4 = + subst u_let_rec_opening lb.FStarC_Syntax_Syntax.lbdef in + { + FStarC_Syntax_Syntax.lbname = + (lb.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs = us; + FStarC_Syntax_Syntax.lbtyp = uu___3; + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = uu___4; + FStarC_Syntax_Syntax.lbattrs = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + }) lbs1 in + let t1 = subst let_rec_opening t in (lbs2, t1)) +let (close_let_rec : + FStarC_Syntax_Syntax.letbinding Prims.list -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.letbinding Prims.list * + FStarC_Syntax_Syntax.term)) + = + fun lbs -> + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Syntax.is_top_level lbs in + if uu___1 + then (Prims.int_zero, []) + else + FStarC_Compiler_List.fold_right + (fun lb -> + fun uu___3 -> + match uu___3 with + | (i, out) -> + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Compiler_Util.left + lb.FStarC_Syntax_Syntax.lbname in + (uu___7, i) in + FStarC_Syntax_Syntax.NM uu___6 in + uu___5 :: out in + ((i + Prims.int_one), uu___4)) lbs (Prims.int_zero, []) in + match uu___ with + | (n_let_recs, let_rec_closing) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Compiler_List.hd lbs in + uu___3.FStarC_Syntax_Syntax.lbunivs in + FStarC_Compiler_List.fold_right + (fun u -> + fun uu___3 -> + match uu___3 with + | (i, out) -> + ((i + Prims.int_one), + ((FStarC_Syntax_Syntax.UD (u, i)) :: out))) uu___2 + (n_let_recs, let_rec_closing) in + (match uu___1 with + | (uu___2, u_let_rec_closing) -> + let lbs1 = + FStarC_Compiler_List.map + (fun lb -> + let uu___3 = + subst u_let_rec_closing lb.FStarC_Syntax_Syntax.lbtyp in + let uu___4 = + subst u_let_rec_closing lb.FStarC_Syntax_Syntax.lbdef in + { + FStarC_Syntax_Syntax.lbname = + (lb.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = uu___3; + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = uu___4; + FStarC_Syntax_Syntax.lbattrs = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + }) lbs in + let t1 = subst let_rec_closing t in (lbs1, t1)) +let (close_tscheme : + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.tscheme -> FStarC_Syntax_Syntax.tscheme) + = + fun binders -> + fun uu___ -> + match uu___ with + | (us, t) -> + let n = (FStarC_Compiler_List.length binders) - Prims.int_one in + let k = FStarC_Compiler_List.length us in + let s = + FStarC_Compiler_List.mapi + (fun i -> + fun b -> + FStarC_Syntax_Syntax.NM + ((b.FStarC_Syntax_Syntax.binder_bv), (k + (n - i)))) + binders in + let t1 = subst s t in (us, t1) +let (close_univ_vars_tscheme : + FStarC_Syntax_Syntax.univ_names -> + FStarC_Syntax_Syntax.tscheme -> FStarC_Syntax_Syntax.tscheme) + = + fun us -> + fun uu___ -> + match uu___ with + | (us', t) -> + let n = (FStarC_Compiler_List.length us) - Prims.int_one in + let k = FStarC_Compiler_List.length us' in + let s = + FStarC_Compiler_List.mapi + (fun i -> fun x -> FStarC_Syntax_Syntax.UD (x, (k + (n - i)))) + us in + let uu___1 = subst s t in (us', uu___1) +let (subst_tscheme : + FStarC_Syntax_Syntax.subst_elt Prims.list -> + FStarC_Syntax_Syntax.tscheme -> FStarC_Syntax_Syntax.tscheme) + = + fun s -> + fun uu___ -> + match uu___ with + | (us, t) -> + let s1 = shift_subst (FStarC_Compiler_List.length us) s in + let uu___1 = subst s1 t in (us, uu___1) +let (opening_of_binders : + FStarC_Syntax_Syntax.binders -> FStarC_Syntax_Syntax.subst_t) = + fun bs -> + let n = (FStarC_Compiler_List.length bs) - Prims.int_one in + FStarC_Compiler_List.mapi + (fun i -> + fun b -> + FStarC_Syntax_Syntax.DB + ((n - i), (b.FStarC_Syntax_Syntax.binder_bv))) bs +let (closing_of_binders : + FStarC_Syntax_Syntax.binders -> FStarC_Syntax_Syntax.subst_t) = + fun bs -> closing_subst bs +let (open_term_1 : + FStarC_Syntax_Syntax.binder -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.binder * FStarC_Syntax_Syntax.term)) + = + fun b -> + fun t -> + let uu___ = open_term [b] t in + match uu___ with + | (b1::[], t1) -> (b1, t1) + | uu___1 -> failwith "impossible: open_term_1" +let (open_term_bvs : + FStarC_Syntax_Syntax.bv Prims.list -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.bv Prims.list * FStarC_Syntax_Syntax.term)) + = + fun bvs -> + fun t -> + let uu___ = + let uu___1 = + FStarC_Compiler_List.map FStarC_Syntax_Syntax.mk_binder bvs in + open_term uu___1 t in + match uu___ with + | (bs, t1) -> + let uu___1 = + FStarC_Compiler_List.map + (fun b -> b.FStarC_Syntax_Syntax.binder_bv) bs in + (uu___1, t1) +let (open_term_bv : + FStarC_Syntax_Syntax.bv -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.bv * FStarC_Syntax_Syntax.term)) + = + fun bv -> + fun t -> + let uu___ = open_term_bvs [bv] t in + match uu___ with + | (bv1::[], t1) -> (bv1, t1) + | uu___1 -> failwith "impossible: open_term_bv" \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Syntax_Syntax.ml b/ocaml/fstar-lib/generated/FStarC_Syntax_Syntax.ml new file mode 100644 index 00000000000..c7b933e21ec --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Syntax_Syntax.ml @@ -0,0 +1,3336 @@ +open Prims +type 'a withinfo_t = { + v: 'a ; + p: FStarC_Compiler_Range_Type.range }[@@deriving yojson,show] +let __proj__Mkwithinfo_t__item__v : 'a . 'a withinfo_t -> 'a = + fun projectee -> match projectee with | { v; p;_} -> v +let __proj__Mkwithinfo_t__item__p : + 'a . 'a withinfo_t -> FStarC_Compiler_Range_Type.range = + fun projectee -> match projectee with | { v; p;_} -> p +type var = FStarC_Ident.lident withinfo_t[@@deriving yojson,show] +type sconst = FStarC_Const.sconst[@@deriving yojson,show] +type pragma = + | ShowOptions + | SetOptions of Prims.string + | ResetOptions of Prims.string FStar_Pervasives_Native.option + | PushOptions of Prims.string FStar_Pervasives_Native.option + | PopOptions + | RestartSolver + | PrintEffectsGraph [@@deriving yojson,show] +let (uu___is_ShowOptions : pragma -> Prims.bool) = + fun projectee -> + match projectee with | ShowOptions -> true | uu___ -> false +let (uu___is_SetOptions : pragma -> Prims.bool) = + fun projectee -> + match projectee with | SetOptions _0 -> true | uu___ -> false +let (__proj__SetOptions__item___0 : pragma -> Prims.string) = + fun projectee -> match projectee with | SetOptions _0 -> _0 +let (uu___is_ResetOptions : pragma -> Prims.bool) = + fun projectee -> + match projectee with | ResetOptions _0 -> true | uu___ -> false +let (__proj__ResetOptions__item___0 : + pragma -> Prims.string FStar_Pervasives_Native.option) = + fun projectee -> match projectee with | ResetOptions _0 -> _0 +let (uu___is_PushOptions : pragma -> Prims.bool) = + fun projectee -> + match projectee with | PushOptions _0 -> true | uu___ -> false +let (__proj__PushOptions__item___0 : + pragma -> Prims.string FStar_Pervasives_Native.option) = + fun projectee -> match projectee with | PushOptions _0 -> _0 +let (uu___is_PopOptions : pragma -> Prims.bool) = + fun projectee -> match projectee with | PopOptions -> true | uu___ -> false +let (uu___is_RestartSolver : pragma -> Prims.bool) = + fun projectee -> + match projectee with | RestartSolver -> true | uu___ -> false +let (uu___is_PrintEffectsGraph : pragma -> Prims.bool) = + fun projectee -> + match projectee with | PrintEffectsGraph -> true | uu___ -> false +let (pragma_to_string : pragma -> Prims.string) = + fun p -> + match p with + | ShowOptions -> "#show-options" + | ResetOptions (FStar_Pervasives_Native.None) -> "#reset-options" + | ResetOptions (FStar_Pervasives_Native.Some s) -> + FStarC_Compiler_Util.format1 "#reset-options \"%s\"" s + | SetOptions s -> FStarC_Compiler_Util.format1 "#set-options \"%s\"" s + | PushOptions (FStar_Pervasives_Native.None) -> "#push-options" + | PushOptions (FStar_Pervasives_Native.Some s) -> + FStarC_Compiler_Util.format1 "#push-options \"%s\"" s + | RestartSolver -> "#restart-solver" + | PrintEffectsGraph -> "#print-effects-graph" + | PopOptions -> "#pop-options" +let (showable_pragma : pragma FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = pragma_to_string } +type 'a memo = + (('a FStar_Pervasives_Native.option FStarC_Compiler_Effect.ref)[@printer + fun fmt -> + fun _ -> + Format.pp_print_string + fmt + "None"]) +[@@deriving yojson,show] +type emb_typ = + | ET_abstract + | ET_fun of (emb_typ * emb_typ) + | ET_app of (Prims.string * emb_typ Prims.list) +let (uu___is_ET_abstract : emb_typ -> Prims.bool) = + fun projectee -> + match projectee with | ET_abstract -> true | uu___ -> false +let (uu___is_ET_fun : emb_typ -> Prims.bool) = + fun projectee -> match projectee with | ET_fun _0 -> true | uu___ -> false +let (__proj__ET_fun__item___0 : emb_typ -> (emb_typ * emb_typ)) = + fun projectee -> match projectee with | ET_fun _0 -> _0 +let (uu___is_ET_app : emb_typ -> Prims.bool) = + fun projectee -> match projectee with | ET_app _0 -> true | uu___ -> false +let (__proj__ET_app__item___0 : + emb_typ -> (Prims.string * emb_typ Prims.list)) = + fun projectee -> match projectee with | ET_app _0 -> _0 +type version = { + major: Prims.int ; + minor: Prims.int }[@@deriving yojson,show] +let (__proj__Mkversion__item__major : version -> Prims.int) = + fun projectee -> match projectee with | { major; minor;_} -> major +let (__proj__Mkversion__item__minor : version -> Prims.int) = + fun projectee -> match projectee with | { major; minor;_} -> minor +type universe = + | U_zero + | U_succ of universe + | U_max of universe Prims.list + | U_bvar of Prims.int + | U_name of FStarC_Ident.ident + | U_unif of (universe FStar_Pervasives_Native.option + FStarC_Unionfind.p_uvar * version * FStarC_Compiler_Range_Type.range) + | U_unknown [@@deriving yojson,show] +let (uu___is_U_zero : universe -> Prims.bool) = + fun projectee -> match projectee with | U_zero -> true | uu___ -> false +let (uu___is_U_succ : universe -> Prims.bool) = + fun projectee -> match projectee with | U_succ _0 -> true | uu___ -> false +let (__proj__U_succ__item___0 : universe -> universe) = + fun projectee -> match projectee with | U_succ _0 -> _0 +let (uu___is_U_max : universe -> Prims.bool) = + fun projectee -> match projectee with | U_max _0 -> true | uu___ -> false +let (__proj__U_max__item___0 : universe -> universe Prims.list) = + fun projectee -> match projectee with | U_max _0 -> _0 +let (uu___is_U_bvar : universe -> Prims.bool) = + fun projectee -> match projectee with | U_bvar _0 -> true | uu___ -> false +let (__proj__U_bvar__item___0 : universe -> Prims.int) = + fun projectee -> match projectee with | U_bvar _0 -> _0 +let (uu___is_U_name : universe -> Prims.bool) = + fun projectee -> match projectee with | U_name _0 -> true | uu___ -> false +let (__proj__U_name__item___0 : universe -> FStarC_Ident.ident) = + fun projectee -> match projectee with | U_name _0 -> _0 +let (uu___is_U_unif : universe -> Prims.bool) = + fun projectee -> match projectee with | U_unif _0 -> true | uu___ -> false +let (__proj__U_unif__item___0 : + universe -> + (universe FStar_Pervasives_Native.option FStarC_Unionfind.p_uvar * + version * FStarC_Compiler_Range_Type.range)) + = fun projectee -> match projectee with | U_unif _0 -> _0 +let (uu___is_U_unknown : universe -> Prims.bool) = + fun projectee -> match projectee with | U_unknown -> true | uu___ -> false +type univ_name = FStarC_Ident.ident[@@deriving yojson,show] +type universe_uvar = + (universe FStar_Pervasives_Native.option FStarC_Unionfind.p_uvar * version + * FStarC_Compiler_Range_Type.range)[@@deriving yojson,show] +type univ_names = univ_name Prims.list[@@deriving yojson,show] +type universes = universe Prims.list[@@deriving yojson,show] +type monad_name = FStarC_Ident.lident[@@deriving yojson,show] +type quote_kind = + | Quote_static + | Quote_dynamic [@@deriving yojson,show] +let (uu___is_Quote_static : quote_kind -> Prims.bool) = + fun projectee -> + match projectee with | Quote_static -> true | uu___ -> false +let (uu___is_Quote_dynamic : quote_kind -> Prims.bool) = + fun projectee -> + match projectee with | Quote_dynamic -> true | uu___ -> false +type maybe_set_use_range = + | NoUseRange + | SomeUseRange of FStarC_Compiler_Range_Type.range [@@deriving yojson,show] +let (uu___is_NoUseRange : maybe_set_use_range -> Prims.bool) = + fun projectee -> match projectee with | NoUseRange -> true | uu___ -> false +let (uu___is_SomeUseRange : maybe_set_use_range -> Prims.bool) = + fun projectee -> + match projectee with | SomeUseRange _0 -> true | uu___ -> false +let (__proj__SomeUseRange__item___0 : + maybe_set_use_range -> FStarC_Compiler_Range_Type.range) = + fun projectee -> match projectee with | SomeUseRange _0 -> _0 +type delta_depth = + | Delta_constant_at_level of Prims.int + | Delta_equational_at_level of Prims.int + | Delta_abstract of delta_depth [@@deriving yojson,show] +let (uu___is_Delta_constant_at_level : delta_depth -> Prims.bool) = + fun projectee -> + match projectee with + | Delta_constant_at_level _0 -> true + | uu___ -> false +let (__proj__Delta_constant_at_level__item___0 : delta_depth -> Prims.int) = + fun projectee -> match projectee with | Delta_constant_at_level _0 -> _0 +let (uu___is_Delta_equational_at_level : delta_depth -> Prims.bool) = + fun projectee -> + match projectee with + | Delta_equational_at_level _0 -> true + | uu___ -> false +let (__proj__Delta_equational_at_level__item___0 : delta_depth -> Prims.int) + = + fun projectee -> match projectee with | Delta_equational_at_level _0 -> _0 +let (uu___is_Delta_abstract : delta_depth -> Prims.bool) = + fun projectee -> + match projectee with | Delta_abstract _0 -> true | uu___ -> false +let (__proj__Delta_abstract__item___0 : delta_depth -> delta_depth) = + fun projectee -> match projectee with | Delta_abstract _0 -> _0 +type should_check_uvar = + | Allow_unresolved of Prims.string + | Allow_untyped of Prims.string + | Allow_ghost of Prims.string + | Strict + | Already_checked [@@deriving yojson,show] +let (uu___is_Allow_unresolved : should_check_uvar -> Prims.bool) = + fun projectee -> + match projectee with | Allow_unresolved _0 -> true | uu___ -> false +let (__proj__Allow_unresolved__item___0 : should_check_uvar -> Prims.string) + = fun projectee -> match projectee with | Allow_unresolved _0 -> _0 +let (uu___is_Allow_untyped : should_check_uvar -> Prims.bool) = + fun projectee -> + match projectee with | Allow_untyped _0 -> true | uu___ -> false +let (__proj__Allow_untyped__item___0 : should_check_uvar -> Prims.string) = + fun projectee -> match projectee with | Allow_untyped _0 -> _0 +let (uu___is_Allow_ghost : should_check_uvar -> Prims.bool) = + fun projectee -> + match projectee with | Allow_ghost _0 -> true | uu___ -> false +let (__proj__Allow_ghost__item___0 : should_check_uvar -> Prims.string) = + fun projectee -> match projectee with | Allow_ghost _0 -> _0 +let (uu___is_Strict : should_check_uvar -> Prims.bool) = + fun projectee -> match projectee with | Strict -> true | uu___ -> false +let (uu___is_Already_checked : should_check_uvar -> Prims.bool) = + fun projectee -> + match projectee with | Already_checked -> true | uu___ -> false +type positivity_qualifier = + | BinderStrictlyPositive + | BinderUnused +let (uu___is_BinderStrictlyPositive : positivity_qualifier -> Prims.bool) = + fun projectee -> + match projectee with | BinderStrictlyPositive -> true | uu___ -> false +let (uu___is_BinderUnused : positivity_qualifier -> Prims.bool) = + fun projectee -> + match projectee with | BinderUnused -> true | uu___ -> false +type term'__Tm_abs__payload = + { + bs: binder Prims.list ; + body: term' syntax ; + rc_opt: residual_comp FStar_Pervasives_Native.option } +and term'__Tm_arrow__payload = { + bs1: binder Prims.list ; + comp: comp' syntax } +and term'__Tm_refine__payload = { + b: bv ; + phi: term' syntax } +and term'__Tm_app__payload = + { + hd: term' syntax ; + args: + (term' syntax * arg_qualifier FStar_Pervasives_Native.option) Prims.list } +and term'__Tm_match__payload = + { + scrutinee: term' syntax ; + ret_opt: + (binder * ((term' syntax, comp' syntax) FStar_Pervasives.either * term' + syntax FStar_Pervasives_Native.option * Prims.bool)) + FStar_Pervasives_Native.option + ; + brs: + (pat' withinfo_t * term' syntax FStar_Pervasives_Native.option * term' + syntax) Prims.list + ; + rc_opt1: residual_comp FStar_Pervasives_Native.option } +and term'__Tm_ascribed__payload = + { + tm: term' syntax ; + asc: + ((term' syntax, comp' syntax) FStar_Pervasives.either * term' syntax + FStar_Pervasives_Native.option * Prims.bool) + ; + eff_opt: FStarC_Ident.lident FStar_Pervasives_Native.option } +and term'__Tm_let__payload = + { + lbs: (Prims.bool * letbinding Prims.list) ; + body1: term' syntax } +and term'__Tm_delayed__payload = + { + tm1: term' syntax ; + substs: (subst_elt Prims.list Prims.list * maybe_set_use_range) } +and term'__Tm_meta__payload = { + tm2: term' syntax ; + meta: metadata } +and term' = + | Tm_bvar of bv + | Tm_name of bv + | Tm_fvar of fv + | Tm_uinst of (term' syntax * universes) + | Tm_constant of sconst + | Tm_type of universe + | Tm_abs of term'__Tm_abs__payload + | Tm_arrow of term'__Tm_arrow__payload + | Tm_refine of term'__Tm_refine__payload + | Tm_app of term'__Tm_app__payload + | Tm_match of term'__Tm_match__payload + | Tm_ascribed of term'__Tm_ascribed__payload + | Tm_let of term'__Tm_let__payload + | Tm_uvar of (ctx_uvar * (subst_elt Prims.list Prims.list * + maybe_set_use_range)) + | Tm_delayed of term'__Tm_delayed__payload + | Tm_meta of term'__Tm_meta__payload + | Tm_lazy of lazyinfo + | Tm_quoted of (term' syntax * quoteinfo) + | Tm_unknown +and ctx_uvar = + { + ctx_uvar_head: + ((term' syntax FStar_Pervasives_Native.option * uvar_decoration) + FStarC_Unionfind.p_uvar * version * FStarC_Compiler_Range_Type.range) + ; + ctx_uvar_gamma: binding Prims.list ; + ctx_uvar_binders: binder Prims.list ; + ctx_uvar_reason: Prims.string ; + ctx_uvar_range: FStarC_Compiler_Range_Type.range ; + ctx_uvar_meta: ctx_uvar_meta_t FStar_Pervasives_Native.option } +and ctx_uvar_meta_t = + | Ctx_uvar_meta_tac of term' syntax + | Ctx_uvar_meta_attr of term' syntax +and uvar_decoration = + { + uvar_decoration_typ: term' syntax ; + uvar_decoration_typedness_depends_on: ctx_uvar Prims.list ; + uvar_decoration_should_check: should_check_uvar ; + uvar_decoration_should_unrefine: Prims.bool } +and pat' = + | Pat_constant of sconst + | Pat_cons of (fv * universes FStar_Pervasives_Native.option * (pat' + withinfo_t * Prims.bool) Prims.list) + | Pat_var of bv + | Pat_dot_term of term' syntax FStar_Pervasives_Native.option +and letbinding = + { + lbname: (bv, fv) FStar_Pervasives.either ; + lbunivs: univ_name Prims.list ; + lbtyp: term' syntax ; + lbeff: FStarC_Ident.lident ; + lbdef: term' syntax ; + lbattrs: term' syntax Prims.list ; + lbpos: FStarC_Compiler_Range_Type.range } +and quoteinfo = + { + qkind: quote_kind ; + antiquotations: (Prims.int * term' syntax Prims.list) } +and comp_typ = + { + comp_univs: universes ; + effect_name: FStarC_Ident.lident ; + result_typ: term' syntax ; + effect_args: + (term' syntax * arg_qualifier FStar_Pervasives_Native.option) Prims.list ; + flags: cflag Prims.list } +and comp' = + | Total of term' syntax + | GTotal of term' syntax + | Comp of comp_typ +and binder = + { + binder_bv: bv ; + binder_qual: binder_qualifier FStar_Pervasives_Native.option ; + binder_positivity: positivity_qualifier FStar_Pervasives_Native.option ; + binder_attrs: term' syntax Prims.list } +and decreases_order = + | Decreases_lex of term' syntax Prims.list + | Decreases_wf of (term' syntax * term' syntax) +and cflag = + | TOTAL + | MLEFFECT + | LEMMA + | RETURN + | PARTIAL_RETURN + | SOMETRIVIAL + | TRIVIAL_POSTCONDITION + | SHOULD_NOT_INLINE + | CPS + | DECREASES of decreases_order +and metadata = + | Meta_pattern of (term' syntax Prims.list * (term' syntax * arg_qualifier + FStar_Pervasives_Native.option) Prims.list Prims.list) + | Meta_named of FStarC_Ident.lident + | Meta_labeled of (FStarC_Pprint.document Prims.list * + FStarC_Compiler_Range_Type.range * Prims.bool) + | Meta_desugared of meta_source_info + | Meta_monadic of (monad_name * term' syntax) + | Meta_monadic_lift of (monad_name * monad_name * term' syntax) +and meta_source_info = + | Sequence + | Primop + | Masked_effect + | Meta_smt_pat + | Machine_integer of (FStarC_Const.signedness * FStarC_Const.width) +and fv_qual = + | Data_ctor + | Record_projector of (FStarC_Ident.lident * FStarC_Ident.ident) + | Record_ctor of (FStarC_Ident.lident * FStarC_Ident.ident Prims.list) + | Unresolved_projector of fv FStar_Pervasives_Native.option + | Unresolved_constructor of unresolved_constructor +and unresolved_constructor = + { + uc_base_term: Prims.bool ; + uc_typename: FStarC_Ident.lident FStar_Pervasives_Native.option ; + uc_fields: FStarC_Ident.lident Prims.list } +and subst_elt = + | DB of (Prims.int * bv) + | DT of (Prims.int * term' syntax) + | NM of (bv * Prims.int) + | NT of (bv * term' syntax) + | UN of (Prims.int * universe) + | UD of (univ_name * Prims.int) +and 'a syntax = + { + n: 'a ; + pos: FStarC_Compiler_Range_Type.range ; + vars: free_vars memo ; + hash_code: FStarC_Hash.hash_code memo } +and bv = { + ppname: FStarC_Ident.ident ; + index: Prims.int ; + sort: term' syntax } +and fv = { + fv_name: var ; + fv_qual: fv_qual FStar_Pervasives_Native.option } +and free_vars = + { + free_names: bv FStarC_Compiler_FlatSet.t ; + free_uvars: ctx_uvar FStarC_Compiler_FlatSet.t ; + free_univs: universe_uvar FStarC_Compiler_FlatSet.t ; + free_univ_names: univ_name FStarC_Compiler_FlatSet.t } +and residual_comp = + { + residual_effect: FStarC_Ident.lident ; + residual_typ: term' syntax FStar_Pervasives_Native.option ; + residual_flags: cflag Prims.list } +and lazyinfo = + { + blob: FStarC_Dyn.dyn ; + lkind: lazy_kind ; + ltyp: term' syntax ; + rng: FStarC_Compiler_Range_Type.range } +and lazy_kind = + | BadLazy + | Lazy_bv + | Lazy_namedv + | Lazy_binder + | Lazy_optionstate + | Lazy_fvar + | Lazy_comp + | Lazy_env + | Lazy_proofstate + | Lazy_goal + | Lazy_sigelt + | Lazy_uvar + | Lazy_letbinding + | Lazy_embedding of (emb_typ * term' syntax FStarC_Thunk.t) + | Lazy_universe + | Lazy_universe_uvar + | Lazy_issue + | Lazy_ident + | Lazy_doc + | Lazy_extension of Prims.string + | Lazy_tref +and binding = + | Binding_var of bv + | Binding_lid of (FStarC_Ident.lident * (univ_names * term' syntax)) + | Binding_univ of univ_name +and binder_qualifier = + | Implicit of Prims.bool + | Meta of term' syntax + | Equality +and arg_qualifier = + { + aqual_implicit: Prims.bool ; + aqual_attributes: term' syntax Prims.list } +let (__proj__Mkterm'__Tm_abs__payload__item__bs : + term'__Tm_abs__payload -> binder Prims.list) = + fun projectee -> match projectee with | { bs; body; rc_opt;_} -> bs +let (__proj__Mkterm'__Tm_abs__payload__item__body : + term'__Tm_abs__payload -> term' syntax) = + fun projectee -> match projectee with | { bs; body; rc_opt;_} -> body +let (__proj__Mkterm'__Tm_abs__payload__item__rc_opt : + term'__Tm_abs__payload -> residual_comp FStar_Pervasives_Native.option) = + fun projectee -> match projectee with | { bs; body; rc_opt;_} -> rc_opt +let (__proj__Mkterm'__Tm_arrow__payload__item__bs : + term'__Tm_arrow__payload -> binder Prims.list) = + fun projectee -> match projectee with | { bs1 = bs; comp;_} -> bs +let (__proj__Mkterm'__Tm_arrow__payload__item__comp : + term'__Tm_arrow__payload -> comp' syntax) = + fun projectee -> match projectee with | { bs1 = bs; comp;_} -> comp +let (__proj__Mkterm'__Tm_refine__payload__item__b : + term'__Tm_refine__payload -> bv) = + fun projectee -> match projectee with | { b; phi;_} -> b +let (__proj__Mkterm'__Tm_refine__payload__item__phi : + term'__Tm_refine__payload -> term' syntax) = + fun projectee -> match projectee with | { b; phi;_} -> phi +let (__proj__Mkterm'__Tm_app__payload__item__hd : + term'__Tm_app__payload -> term' syntax) = + fun projectee -> match projectee with | { hd; args;_} -> hd +let (__proj__Mkterm'__Tm_app__payload__item__args : + term'__Tm_app__payload -> + (term' syntax * arg_qualifier FStar_Pervasives_Native.option) Prims.list) + = fun projectee -> match projectee with | { hd; args;_} -> args +let (__proj__Mkterm'__Tm_match__payload__item__scrutinee : + term'__Tm_match__payload -> term' syntax) = + fun projectee -> + match projectee with + | { scrutinee; ret_opt; brs; rc_opt1 = rc_opt;_} -> scrutinee +let (__proj__Mkterm'__Tm_match__payload__item__ret_opt : + term'__Tm_match__payload -> + (binder * ((term' syntax, comp' syntax) FStar_Pervasives.either * term' + syntax FStar_Pervasives_Native.option * Prims.bool)) + FStar_Pervasives_Native.option) + = + fun projectee -> + match projectee with + | { scrutinee; ret_opt; brs; rc_opt1 = rc_opt;_} -> ret_opt +let (__proj__Mkterm'__Tm_match__payload__item__brs : + term'__Tm_match__payload -> + (pat' withinfo_t * term' syntax FStar_Pervasives_Native.option * term' + syntax) Prims.list) + = + fun projectee -> + match projectee with + | { scrutinee; ret_opt; brs; rc_opt1 = rc_opt;_} -> brs +let (__proj__Mkterm'__Tm_match__payload__item__rc_opt : + term'__Tm_match__payload -> residual_comp FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { scrutinee; ret_opt; brs; rc_opt1 = rc_opt;_} -> rc_opt +let (__proj__Mkterm'__Tm_ascribed__payload__item__tm : + term'__Tm_ascribed__payload -> term' syntax) = + fun projectee -> match projectee with | { tm; asc; eff_opt;_} -> tm +let (__proj__Mkterm'__Tm_ascribed__payload__item__asc : + term'__Tm_ascribed__payload -> + ((term' syntax, comp' syntax) FStar_Pervasives.either * term' syntax + FStar_Pervasives_Native.option * Prims.bool)) + = fun projectee -> match projectee with | { tm; asc; eff_opt;_} -> asc +let (__proj__Mkterm'__Tm_ascribed__payload__item__eff_opt : + term'__Tm_ascribed__payload -> + FStarC_Ident.lident FStar_Pervasives_Native.option) + = fun projectee -> match projectee with | { tm; asc; eff_opt;_} -> eff_opt +let (__proj__Mkterm'__Tm_let__payload__item__lbs : + term'__Tm_let__payload -> (Prims.bool * letbinding Prims.list)) = + fun projectee -> match projectee with | { lbs; body1 = body;_} -> lbs +let (__proj__Mkterm'__Tm_let__payload__item__body : + term'__Tm_let__payload -> term' syntax) = + fun projectee -> match projectee with | { lbs; body1 = body;_} -> body +let (__proj__Mkterm'__Tm_delayed__payload__item__tm : + term'__Tm_delayed__payload -> term' syntax) = + fun projectee -> match projectee with | { tm1 = tm; substs;_} -> tm +let (__proj__Mkterm'__Tm_delayed__payload__item__substs : + term'__Tm_delayed__payload -> + (subst_elt Prims.list Prims.list * maybe_set_use_range)) + = fun projectee -> match projectee with | { tm1 = tm; substs;_} -> substs +let (__proj__Mkterm'__Tm_meta__payload__item__tm : + term'__Tm_meta__payload -> term' syntax) = + fun projectee -> match projectee with | { tm2 = tm; meta;_} -> tm +let (__proj__Mkterm'__Tm_meta__payload__item__meta : + term'__Tm_meta__payload -> metadata) = + fun projectee -> match projectee with | { tm2 = tm; meta;_} -> meta +let (uu___is_Tm_bvar : term' -> Prims.bool) = + fun projectee -> match projectee with | Tm_bvar _0 -> true | uu___ -> false +let (__proj__Tm_bvar__item___0 : term' -> bv) = + fun projectee -> match projectee with | Tm_bvar _0 -> _0 +let (uu___is_Tm_name : term' -> Prims.bool) = + fun projectee -> match projectee with | Tm_name _0 -> true | uu___ -> false +let (__proj__Tm_name__item___0 : term' -> bv) = + fun projectee -> match projectee with | Tm_name _0 -> _0 +let (uu___is_Tm_fvar : term' -> Prims.bool) = + fun projectee -> match projectee with | Tm_fvar _0 -> true | uu___ -> false +let (__proj__Tm_fvar__item___0 : term' -> fv) = + fun projectee -> match projectee with | Tm_fvar _0 -> _0 +let (uu___is_Tm_uinst : term' -> Prims.bool) = + fun projectee -> + match projectee with | Tm_uinst _0 -> true | uu___ -> false +let (__proj__Tm_uinst__item___0 : term' -> (term' syntax * universes)) = + fun projectee -> match projectee with | Tm_uinst _0 -> _0 +let (uu___is_Tm_constant : term' -> Prims.bool) = + fun projectee -> + match projectee with | Tm_constant _0 -> true | uu___ -> false +let (__proj__Tm_constant__item___0 : term' -> sconst) = + fun projectee -> match projectee with | Tm_constant _0 -> _0 +let (uu___is_Tm_type : term' -> Prims.bool) = + fun projectee -> match projectee with | Tm_type _0 -> true | uu___ -> false +let (__proj__Tm_type__item___0 : term' -> universe) = + fun projectee -> match projectee with | Tm_type _0 -> _0 +let (uu___is_Tm_abs : term' -> Prims.bool) = + fun projectee -> match projectee with | Tm_abs _0 -> true | uu___ -> false +let (__proj__Tm_abs__item___0 : term' -> term'__Tm_abs__payload) = + fun projectee -> match projectee with | Tm_abs _0 -> _0 +let (uu___is_Tm_arrow : term' -> Prims.bool) = + fun projectee -> + match projectee with | Tm_arrow _0 -> true | uu___ -> false +let (__proj__Tm_arrow__item___0 : term' -> term'__Tm_arrow__payload) = + fun projectee -> match projectee with | Tm_arrow _0 -> _0 +let (uu___is_Tm_refine : term' -> Prims.bool) = + fun projectee -> + match projectee with | Tm_refine _0 -> true | uu___ -> false +let (__proj__Tm_refine__item___0 : term' -> term'__Tm_refine__payload) = + fun projectee -> match projectee with | Tm_refine _0 -> _0 +let (uu___is_Tm_app : term' -> Prims.bool) = + fun projectee -> match projectee with | Tm_app _0 -> true | uu___ -> false +let (__proj__Tm_app__item___0 : term' -> term'__Tm_app__payload) = + fun projectee -> match projectee with | Tm_app _0 -> _0 +let (uu___is_Tm_match : term' -> Prims.bool) = + fun projectee -> + match projectee with | Tm_match _0 -> true | uu___ -> false +let (__proj__Tm_match__item___0 : term' -> term'__Tm_match__payload) = + fun projectee -> match projectee with | Tm_match _0 -> _0 +let (uu___is_Tm_ascribed : term' -> Prims.bool) = + fun projectee -> + match projectee with | Tm_ascribed _0 -> true | uu___ -> false +let (__proj__Tm_ascribed__item___0 : term' -> term'__Tm_ascribed__payload) = + fun projectee -> match projectee with | Tm_ascribed _0 -> _0 +let (uu___is_Tm_let : term' -> Prims.bool) = + fun projectee -> match projectee with | Tm_let _0 -> true | uu___ -> false +let (__proj__Tm_let__item___0 : term' -> term'__Tm_let__payload) = + fun projectee -> match projectee with | Tm_let _0 -> _0 +let (uu___is_Tm_uvar : term' -> Prims.bool) = + fun projectee -> match projectee with | Tm_uvar _0 -> true | uu___ -> false +let (__proj__Tm_uvar__item___0 : + term' -> + (ctx_uvar * (subst_elt Prims.list Prims.list * maybe_set_use_range))) + = fun projectee -> match projectee with | Tm_uvar _0 -> _0 +let (uu___is_Tm_delayed : term' -> Prims.bool) = + fun projectee -> + match projectee with | Tm_delayed _0 -> true | uu___ -> false +let (__proj__Tm_delayed__item___0 : term' -> term'__Tm_delayed__payload) = + fun projectee -> match projectee with | Tm_delayed _0 -> _0 +let (uu___is_Tm_meta : term' -> Prims.bool) = + fun projectee -> match projectee with | Tm_meta _0 -> true | uu___ -> false +let (__proj__Tm_meta__item___0 : term' -> term'__Tm_meta__payload) = + fun projectee -> match projectee with | Tm_meta _0 -> _0 +let (uu___is_Tm_lazy : term' -> Prims.bool) = + fun projectee -> match projectee with | Tm_lazy _0 -> true | uu___ -> false +let (__proj__Tm_lazy__item___0 : term' -> lazyinfo) = + fun projectee -> match projectee with | Tm_lazy _0 -> _0 +let (uu___is_Tm_quoted : term' -> Prims.bool) = + fun projectee -> + match projectee with | Tm_quoted _0 -> true | uu___ -> false +let (__proj__Tm_quoted__item___0 : term' -> (term' syntax * quoteinfo)) = + fun projectee -> match projectee with | Tm_quoted _0 -> _0 +let (uu___is_Tm_unknown : term' -> Prims.bool) = + fun projectee -> match projectee with | Tm_unknown -> true | uu___ -> false +let (__proj__Mkctx_uvar__item__ctx_uvar_head : + ctx_uvar -> + ((term' syntax FStar_Pervasives_Native.option * uvar_decoration) + FStarC_Unionfind.p_uvar * version * FStarC_Compiler_Range_Type.range)) + = + fun projectee -> + match projectee with + | { ctx_uvar_head; ctx_uvar_gamma; ctx_uvar_binders; ctx_uvar_reason; + ctx_uvar_range; ctx_uvar_meta;_} -> ctx_uvar_head +let (__proj__Mkctx_uvar__item__ctx_uvar_gamma : + ctx_uvar -> binding Prims.list) = + fun projectee -> + match projectee with + | { ctx_uvar_head; ctx_uvar_gamma; ctx_uvar_binders; ctx_uvar_reason; + ctx_uvar_range; ctx_uvar_meta;_} -> ctx_uvar_gamma +let (__proj__Mkctx_uvar__item__ctx_uvar_binders : + ctx_uvar -> binder Prims.list) = + fun projectee -> + match projectee with + | { ctx_uvar_head; ctx_uvar_gamma; ctx_uvar_binders; ctx_uvar_reason; + ctx_uvar_range; ctx_uvar_meta;_} -> ctx_uvar_binders +let (__proj__Mkctx_uvar__item__ctx_uvar_reason : ctx_uvar -> Prims.string) = + fun projectee -> + match projectee with + | { ctx_uvar_head; ctx_uvar_gamma; ctx_uvar_binders; ctx_uvar_reason; + ctx_uvar_range; ctx_uvar_meta;_} -> ctx_uvar_reason +let (__proj__Mkctx_uvar__item__ctx_uvar_range : + ctx_uvar -> FStarC_Compiler_Range_Type.range) = + fun projectee -> + match projectee with + | { ctx_uvar_head; ctx_uvar_gamma; ctx_uvar_binders; ctx_uvar_reason; + ctx_uvar_range; ctx_uvar_meta;_} -> ctx_uvar_range +let (__proj__Mkctx_uvar__item__ctx_uvar_meta : + ctx_uvar -> ctx_uvar_meta_t FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { ctx_uvar_head; ctx_uvar_gamma; ctx_uvar_binders; ctx_uvar_reason; + ctx_uvar_range; ctx_uvar_meta;_} -> ctx_uvar_meta +let (uu___is_Ctx_uvar_meta_tac : ctx_uvar_meta_t -> Prims.bool) = + fun projectee -> + match projectee with | Ctx_uvar_meta_tac _0 -> true | uu___ -> false +let (__proj__Ctx_uvar_meta_tac__item___0 : ctx_uvar_meta_t -> term' syntax) = + fun projectee -> match projectee with | Ctx_uvar_meta_tac _0 -> _0 +let (uu___is_Ctx_uvar_meta_attr : ctx_uvar_meta_t -> Prims.bool) = + fun projectee -> + match projectee with | Ctx_uvar_meta_attr _0 -> true | uu___ -> false +let (__proj__Ctx_uvar_meta_attr__item___0 : ctx_uvar_meta_t -> term' syntax) + = fun projectee -> match projectee with | Ctx_uvar_meta_attr _0 -> _0 +let (__proj__Mkuvar_decoration__item__uvar_decoration_typ : + uvar_decoration -> term' syntax) = + fun projectee -> + match projectee with + | { uvar_decoration_typ; uvar_decoration_typedness_depends_on; + uvar_decoration_should_check; uvar_decoration_should_unrefine;_} -> + uvar_decoration_typ +let (__proj__Mkuvar_decoration__item__uvar_decoration_typedness_depends_on : + uvar_decoration -> ctx_uvar Prims.list) = + fun projectee -> + match projectee with + | { uvar_decoration_typ; uvar_decoration_typedness_depends_on; + uvar_decoration_should_check; uvar_decoration_should_unrefine;_} -> + uvar_decoration_typedness_depends_on +let (__proj__Mkuvar_decoration__item__uvar_decoration_should_check : + uvar_decoration -> should_check_uvar) = + fun projectee -> + match projectee with + | { uvar_decoration_typ; uvar_decoration_typedness_depends_on; + uvar_decoration_should_check; uvar_decoration_should_unrefine;_} -> + uvar_decoration_should_check +let (__proj__Mkuvar_decoration__item__uvar_decoration_should_unrefine : + uvar_decoration -> Prims.bool) = + fun projectee -> + match projectee with + | { uvar_decoration_typ; uvar_decoration_typedness_depends_on; + uvar_decoration_should_check; uvar_decoration_should_unrefine;_} -> + uvar_decoration_should_unrefine +let (uu___is_Pat_constant : pat' -> Prims.bool) = + fun projectee -> + match projectee with | Pat_constant _0 -> true | uu___ -> false +let (__proj__Pat_constant__item___0 : pat' -> sconst) = + fun projectee -> match projectee with | Pat_constant _0 -> _0 +let (uu___is_Pat_cons : pat' -> Prims.bool) = + fun projectee -> + match projectee with | Pat_cons _0 -> true | uu___ -> false +let (__proj__Pat_cons__item___0 : + pat' -> + (fv * universes FStar_Pervasives_Native.option * (pat' withinfo_t * + Prims.bool) Prims.list)) + = fun projectee -> match projectee with | Pat_cons _0 -> _0 +let (uu___is_Pat_var : pat' -> Prims.bool) = + fun projectee -> match projectee with | Pat_var _0 -> true | uu___ -> false +let (__proj__Pat_var__item___0 : pat' -> bv) = + fun projectee -> match projectee with | Pat_var _0 -> _0 +let (uu___is_Pat_dot_term : pat' -> Prims.bool) = + fun projectee -> + match projectee with | Pat_dot_term _0 -> true | uu___ -> false +let (__proj__Pat_dot_term__item___0 : + pat' -> term' syntax FStar_Pervasives_Native.option) = + fun projectee -> match projectee with | Pat_dot_term _0 -> _0 +let (__proj__Mkletbinding__item__lbname : + letbinding -> (bv, fv) FStar_Pervasives.either) = + fun projectee -> + match projectee with + | { lbname; lbunivs; lbtyp; lbeff; lbdef; lbattrs; lbpos;_} -> lbname +let (__proj__Mkletbinding__item__lbunivs : + letbinding -> univ_name Prims.list) = + fun projectee -> + match projectee with + | { lbname; lbunivs; lbtyp; lbeff; lbdef; lbattrs; lbpos;_} -> lbunivs +let (__proj__Mkletbinding__item__lbtyp : letbinding -> term' syntax) = + fun projectee -> + match projectee with + | { lbname; lbunivs; lbtyp; lbeff; lbdef; lbattrs; lbpos;_} -> lbtyp +let (__proj__Mkletbinding__item__lbeff : letbinding -> FStarC_Ident.lident) = + fun projectee -> + match projectee with + | { lbname; lbunivs; lbtyp; lbeff; lbdef; lbattrs; lbpos;_} -> lbeff +let (__proj__Mkletbinding__item__lbdef : letbinding -> term' syntax) = + fun projectee -> + match projectee with + | { lbname; lbunivs; lbtyp; lbeff; lbdef; lbattrs; lbpos;_} -> lbdef +let (__proj__Mkletbinding__item__lbattrs : + letbinding -> term' syntax Prims.list) = + fun projectee -> + match projectee with + | { lbname; lbunivs; lbtyp; lbeff; lbdef; lbattrs; lbpos;_} -> lbattrs +let (__proj__Mkletbinding__item__lbpos : + letbinding -> FStarC_Compiler_Range_Type.range) = + fun projectee -> + match projectee with + | { lbname; lbunivs; lbtyp; lbeff; lbdef; lbattrs; lbpos;_} -> lbpos +let (__proj__Mkquoteinfo__item__qkind : quoteinfo -> quote_kind) = + fun projectee -> match projectee with | { qkind; antiquotations;_} -> qkind +let (__proj__Mkquoteinfo__item__antiquotations : + quoteinfo -> (Prims.int * term' syntax Prims.list)) = + fun projectee -> + match projectee with | { qkind; antiquotations;_} -> antiquotations +let (__proj__Mkcomp_typ__item__comp_univs : comp_typ -> universes) = + fun projectee -> + match projectee with + | { comp_univs; effect_name; result_typ; effect_args; flags;_} -> + comp_univs +let (__proj__Mkcomp_typ__item__effect_name : comp_typ -> FStarC_Ident.lident) + = + fun projectee -> + match projectee with + | { comp_univs; effect_name; result_typ; effect_args; flags;_} -> + effect_name +let (__proj__Mkcomp_typ__item__result_typ : comp_typ -> term' syntax) = + fun projectee -> + match projectee with + | { comp_univs; effect_name; result_typ; effect_args; flags;_} -> + result_typ +let (__proj__Mkcomp_typ__item__effect_args : + comp_typ -> + (term' syntax * arg_qualifier FStar_Pervasives_Native.option) Prims.list) + = + fun projectee -> + match projectee with + | { comp_univs; effect_name; result_typ; effect_args; flags;_} -> + effect_args +let (__proj__Mkcomp_typ__item__flags : comp_typ -> cflag Prims.list) = + fun projectee -> + match projectee with + | { comp_univs; effect_name; result_typ; effect_args; flags;_} -> flags +let (uu___is_Total : comp' -> Prims.bool) = + fun projectee -> match projectee with | Total _0 -> true | uu___ -> false +let (__proj__Total__item___0 : comp' -> term' syntax) = + fun projectee -> match projectee with | Total _0 -> _0 +let (uu___is_GTotal : comp' -> Prims.bool) = + fun projectee -> match projectee with | GTotal _0 -> true | uu___ -> false +let (__proj__GTotal__item___0 : comp' -> term' syntax) = + fun projectee -> match projectee with | GTotal _0 -> _0 +let (uu___is_Comp : comp' -> Prims.bool) = + fun projectee -> match projectee with | Comp _0 -> true | uu___ -> false +let (__proj__Comp__item___0 : comp' -> comp_typ) = + fun projectee -> match projectee with | Comp _0 -> _0 +let (__proj__Mkbinder__item__binder_bv : binder -> bv) = + fun projectee -> + match projectee with + | { binder_bv; binder_qual; binder_positivity; binder_attrs;_} -> + binder_bv +let (__proj__Mkbinder__item__binder_qual : + binder -> binder_qualifier FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { binder_bv; binder_qual; binder_positivity; binder_attrs;_} -> + binder_qual +let (__proj__Mkbinder__item__binder_positivity : + binder -> positivity_qualifier FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { binder_bv; binder_qual; binder_positivity; binder_attrs;_} -> + binder_positivity +let (__proj__Mkbinder__item__binder_attrs : + binder -> term' syntax Prims.list) = + fun projectee -> + match projectee with + | { binder_bv; binder_qual; binder_positivity; binder_attrs;_} -> + binder_attrs +let (uu___is_Decreases_lex : decreases_order -> Prims.bool) = + fun projectee -> + match projectee with | Decreases_lex _0 -> true | uu___ -> false +let (__proj__Decreases_lex__item___0 : + decreases_order -> term' syntax Prims.list) = + fun projectee -> match projectee with | Decreases_lex _0 -> _0 +let (uu___is_Decreases_wf : decreases_order -> Prims.bool) = + fun projectee -> + match projectee with | Decreases_wf _0 -> true | uu___ -> false +let (__proj__Decreases_wf__item___0 : + decreases_order -> (term' syntax * term' syntax)) = + fun projectee -> match projectee with | Decreases_wf _0 -> _0 +let (uu___is_TOTAL : cflag -> Prims.bool) = + fun projectee -> match projectee with | TOTAL -> true | uu___ -> false +let (uu___is_MLEFFECT : cflag -> Prims.bool) = + fun projectee -> match projectee with | MLEFFECT -> true | uu___ -> false +let (uu___is_LEMMA : cflag -> Prims.bool) = + fun projectee -> match projectee with | LEMMA -> true | uu___ -> false +let (uu___is_RETURN : cflag -> Prims.bool) = + fun projectee -> match projectee with | RETURN -> true | uu___ -> false +let (uu___is_PARTIAL_RETURN : cflag -> Prims.bool) = + fun projectee -> + match projectee with | PARTIAL_RETURN -> true | uu___ -> false +let (uu___is_SOMETRIVIAL : cflag -> Prims.bool) = + fun projectee -> + match projectee with | SOMETRIVIAL -> true | uu___ -> false +let (uu___is_TRIVIAL_POSTCONDITION : cflag -> Prims.bool) = + fun projectee -> + match projectee with | TRIVIAL_POSTCONDITION -> true | uu___ -> false +let (uu___is_SHOULD_NOT_INLINE : cflag -> Prims.bool) = + fun projectee -> + match projectee with | SHOULD_NOT_INLINE -> true | uu___ -> false +let (uu___is_CPS : cflag -> Prims.bool) = + fun projectee -> match projectee with | CPS -> true | uu___ -> false +let (uu___is_DECREASES : cflag -> Prims.bool) = + fun projectee -> + match projectee with | DECREASES _0 -> true | uu___ -> false +let (__proj__DECREASES__item___0 : cflag -> decreases_order) = + fun projectee -> match projectee with | DECREASES _0 -> _0 +let (uu___is_Meta_pattern : metadata -> Prims.bool) = + fun projectee -> + match projectee with | Meta_pattern _0 -> true | uu___ -> false +let (__proj__Meta_pattern__item___0 : + metadata -> + (term' syntax Prims.list * (term' syntax * arg_qualifier + FStar_Pervasives_Native.option) Prims.list Prims.list)) + = fun projectee -> match projectee with | Meta_pattern _0 -> _0 +let (uu___is_Meta_named : metadata -> Prims.bool) = + fun projectee -> + match projectee with | Meta_named _0 -> true | uu___ -> false +let (__proj__Meta_named__item___0 : metadata -> FStarC_Ident.lident) = + fun projectee -> match projectee with | Meta_named _0 -> _0 +let (uu___is_Meta_labeled : metadata -> Prims.bool) = + fun projectee -> + match projectee with | Meta_labeled _0 -> true | uu___ -> false +let (__proj__Meta_labeled__item___0 : + metadata -> + (FStarC_Pprint.document Prims.list * FStarC_Compiler_Range_Type.range * + Prims.bool)) + = fun projectee -> match projectee with | Meta_labeled _0 -> _0 +let (uu___is_Meta_desugared : metadata -> Prims.bool) = + fun projectee -> + match projectee with | Meta_desugared _0 -> true | uu___ -> false +let (__proj__Meta_desugared__item___0 : metadata -> meta_source_info) = + fun projectee -> match projectee with | Meta_desugared _0 -> _0 +let (uu___is_Meta_monadic : metadata -> Prims.bool) = + fun projectee -> + match projectee with | Meta_monadic _0 -> true | uu___ -> false +let (__proj__Meta_monadic__item___0 : + metadata -> (monad_name * term' syntax)) = + fun projectee -> match projectee with | Meta_monadic _0 -> _0 +let (uu___is_Meta_monadic_lift : metadata -> Prims.bool) = + fun projectee -> + match projectee with | Meta_monadic_lift _0 -> true | uu___ -> false +let (__proj__Meta_monadic_lift__item___0 : + metadata -> (monad_name * monad_name * term' syntax)) = + fun projectee -> match projectee with | Meta_monadic_lift _0 -> _0 +let (uu___is_Sequence : meta_source_info -> Prims.bool) = + fun projectee -> match projectee with | Sequence -> true | uu___ -> false +let (uu___is_Primop : meta_source_info -> Prims.bool) = + fun projectee -> match projectee with | Primop -> true | uu___ -> false +let (uu___is_Masked_effect : meta_source_info -> Prims.bool) = + fun projectee -> + match projectee with | Masked_effect -> true | uu___ -> false +let (uu___is_Meta_smt_pat : meta_source_info -> Prims.bool) = + fun projectee -> + match projectee with | Meta_smt_pat -> true | uu___ -> false +let (uu___is_Machine_integer : meta_source_info -> Prims.bool) = + fun projectee -> + match projectee with | Machine_integer _0 -> true | uu___ -> false +let (__proj__Machine_integer__item___0 : + meta_source_info -> (FStarC_Const.signedness * FStarC_Const.width)) = + fun projectee -> match projectee with | Machine_integer _0 -> _0 +let (uu___is_Data_ctor : fv_qual -> Prims.bool) = + fun projectee -> match projectee with | Data_ctor -> true | uu___ -> false +let (uu___is_Record_projector : fv_qual -> Prims.bool) = + fun projectee -> + match projectee with | Record_projector _0 -> true | uu___ -> false +let (__proj__Record_projector__item___0 : + fv_qual -> (FStarC_Ident.lident * FStarC_Ident.ident)) = + fun projectee -> match projectee with | Record_projector _0 -> _0 +let (uu___is_Record_ctor : fv_qual -> Prims.bool) = + fun projectee -> + match projectee with | Record_ctor _0 -> true | uu___ -> false +let (__proj__Record_ctor__item___0 : + fv_qual -> (FStarC_Ident.lident * FStarC_Ident.ident Prims.list)) = + fun projectee -> match projectee with | Record_ctor _0 -> _0 +let (uu___is_Unresolved_projector : fv_qual -> Prims.bool) = + fun projectee -> + match projectee with | Unresolved_projector _0 -> true | uu___ -> false +let (__proj__Unresolved_projector__item___0 : + fv_qual -> fv FStar_Pervasives_Native.option) = + fun projectee -> match projectee with | Unresolved_projector _0 -> _0 +let (uu___is_Unresolved_constructor : fv_qual -> Prims.bool) = + fun projectee -> + match projectee with | Unresolved_constructor _0 -> true | uu___ -> false +let (__proj__Unresolved_constructor__item___0 : + fv_qual -> unresolved_constructor) = + fun projectee -> match projectee with | Unresolved_constructor _0 -> _0 +let (__proj__Mkunresolved_constructor__item__uc_base_term : + unresolved_constructor -> Prims.bool) = + fun projectee -> + match projectee with + | { uc_base_term; uc_typename; uc_fields;_} -> uc_base_term +let (__proj__Mkunresolved_constructor__item__uc_typename : + unresolved_constructor -> + FStarC_Ident.lident FStar_Pervasives_Native.option) + = + fun projectee -> + match projectee with + | { uc_base_term; uc_typename; uc_fields;_} -> uc_typename +let (__proj__Mkunresolved_constructor__item__uc_fields : + unresolved_constructor -> FStarC_Ident.lident Prims.list) = + fun projectee -> + match projectee with + | { uc_base_term; uc_typename; uc_fields;_} -> uc_fields +let (uu___is_DB : subst_elt -> Prims.bool) = + fun projectee -> match projectee with | DB _0 -> true | uu___ -> false +let (__proj__DB__item___0 : subst_elt -> (Prims.int * bv)) = + fun projectee -> match projectee with | DB _0 -> _0 +let (uu___is_DT : subst_elt -> Prims.bool) = + fun projectee -> match projectee with | DT _0 -> true | uu___ -> false +let (__proj__DT__item___0 : subst_elt -> (Prims.int * term' syntax)) = + fun projectee -> match projectee with | DT _0 -> _0 +let (uu___is_NM : subst_elt -> Prims.bool) = + fun projectee -> match projectee with | NM _0 -> true | uu___ -> false +let (__proj__NM__item___0 : subst_elt -> (bv * Prims.int)) = + fun projectee -> match projectee with | NM _0 -> _0 +let (uu___is_NT : subst_elt -> Prims.bool) = + fun projectee -> match projectee with | NT _0 -> true | uu___ -> false +let (__proj__NT__item___0 : subst_elt -> (bv * term' syntax)) = + fun projectee -> match projectee with | NT _0 -> _0 +let (uu___is_UN : subst_elt -> Prims.bool) = + fun projectee -> match projectee with | UN _0 -> true | uu___ -> false +let (__proj__UN__item___0 : subst_elt -> (Prims.int * universe)) = + fun projectee -> match projectee with | UN _0 -> _0 +let (uu___is_UD : subst_elt -> Prims.bool) = + fun projectee -> match projectee with | UD _0 -> true | uu___ -> false +let (__proj__UD__item___0 : subst_elt -> (univ_name * Prims.int)) = + fun projectee -> match projectee with | UD _0 -> _0 +let __proj__Mksyntax__item__n : 'a . 'a syntax -> 'a = + fun projectee -> match projectee with | { n; pos; vars; hash_code;_} -> n +let __proj__Mksyntax__item__pos : + 'a . 'a syntax -> FStarC_Compiler_Range_Type.range = + fun projectee -> match projectee with | { n; pos; vars; hash_code;_} -> pos +let __proj__Mksyntax__item__vars : 'a . 'a syntax -> free_vars memo = + fun projectee -> + match projectee with | { n; pos; vars; hash_code;_} -> vars +let __proj__Mksyntax__item__hash_code : + 'a . 'a syntax -> FStarC_Hash.hash_code memo = + fun projectee -> + match projectee with | { n; pos; vars; hash_code;_} -> hash_code +let (__proj__Mkbv__item__ppname : bv -> FStarC_Ident.ident) = + fun projectee -> match projectee with | { ppname; index; sort;_} -> ppname +let (__proj__Mkbv__item__index : bv -> Prims.int) = + fun projectee -> match projectee with | { ppname; index; sort;_} -> index +let (__proj__Mkbv__item__sort : bv -> term' syntax) = + fun projectee -> match projectee with | { ppname; index; sort;_} -> sort +let (__proj__Mkfv__item__fv_name : fv -> var) = + fun projectee -> + match projectee with | { fv_name; fv_qual = fv_qual1;_} -> fv_name +let (__proj__Mkfv__item__fv_qual : + fv -> fv_qual FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with | { fv_name; fv_qual = fv_qual1;_} -> fv_qual1 +let (__proj__Mkfree_vars__item__free_names : + free_vars -> bv FStarC_Compiler_FlatSet.t) = + fun projectee -> + match projectee with + | { free_names; free_uvars; free_univs; free_univ_names;_} -> free_names +let (__proj__Mkfree_vars__item__free_uvars : + free_vars -> ctx_uvar FStarC_Compiler_FlatSet.t) = + fun projectee -> + match projectee with + | { free_names; free_uvars; free_univs; free_univ_names;_} -> free_uvars +let (__proj__Mkfree_vars__item__free_univs : + free_vars -> universe_uvar FStarC_Compiler_FlatSet.t) = + fun projectee -> + match projectee with + | { free_names; free_uvars; free_univs; free_univ_names;_} -> free_univs +let (__proj__Mkfree_vars__item__free_univ_names : + free_vars -> univ_name FStarC_Compiler_FlatSet.t) = + fun projectee -> + match projectee with + | { free_names; free_uvars; free_univs; free_univ_names;_} -> + free_univ_names +let (__proj__Mkresidual_comp__item__residual_effect : + residual_comp -> FStarC_Ident.lident) = + fun projectee -> + match projectee with + | { residual_effect; residual_typ; residual_flags;_} -> residual_effect +let (__proj__Mkresidual_comp__item__residual_typ : + residual_comp -> term' syntax FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { residual_effect; residual_typ; residual_flags;_} -> residual_typ +let (__proj__Mkresidual_comp__item__residual_flags : + residual_comp -> cflag Prims.list) = + fun projectee -> + match projectee with + | { residual_effect; residual_typ; residual_flags;_} -> residual_flags +let (__proj__Mklazyinfo__item__blob : lazyinfo -> FStarC_Dyn.dyn) = + fun projectee -> match projectee with | { blob; lkind; ltyp; rng;_} -> blob +let (__proj__Mklazyinfo__item__lkind : lazyinfo -> lazy_kind) = + fun projectee -> + match projectee with | { blob; lkind; ltyp; rng;_} -> lkind +let (__proj__Mklazyinfo__item__ltyp : lazyinfo -> term' syntax) = + fun projectee -> match projectee with | { blob; lkind; ltyp; rng;_} -> ltyp +let (__proj__Mklazyinfo__item__rng : + lazyinfo -> FStarC_Compiler_Range_Type.range) = + fun projectee -> match projectee with | { blob; lkind; ltyp; rng;_} -> rng +let (uu___is_BadLazy : lazy_kind -> Prims.bool) = + fun projectee -> match projectee with | BadLazy -> true | uu___ -> false +let (uu___is_Lazy_bv : lazy_kind -> Prims.bool) = + fun projectee -> match projectee with | Lazy_bv -> true | uu___ -> false +let (uu___is_Lazy_namedv : lazy_kind -> Prims.bool) = + fun projectee -> + match projectee with | Lazy_namedv -> true | uu___ -> false +let (uu___is_Lazy_binder : lazy_kind -> Prims.bool) = + fun projectee -> + match projectee with | Lazy_binder -> true | uu___ -> false +let (uu___is_Lazy_optionstate : lazy_kind -> Prims.bool) = + fun projectee -> + match projectee with | Lazy_optionstate -> true | uu___ -> false +let (uu___is_Lazy_fvar : lazy_kind -> Prims.bool) = + fun projectee -> match projectee with | Lazy_fvar -> true | uu___ -> false +let (uu___is_Lazy_comp : lazy_kind -> Prims.bool) = + fun projectee -> match projectee with | Lazy_comp -> true | uu___ -> false +let (uu___is_Lazy_env : lazy_kind -> Prims.bool) = + fun projectee -> match projectee with | Lazy_env -> true | uu___ -> false +let (uu___is_Lazy_proofstate : lazy_kind -> Prims.bool) = + fun projectee -> + match projectee with | Lazy_proofstate -> true | uu___ -> false +let (uu___is_Lazy_goal : lazy_kind -> Prims.bool) = + fun projectee -> match projectee with | Lazy_goal -> true | uu___ -> false +let (uu___is_Lazy_sigelt : lazy_kind -> Prims.bool) = + fun projectee -> + match projectee with | Lazy_sigelt -> true | uu___ -> false +let (uu___is_Lazy_uvar : lazy_kind -> Prims.bool) = + fun projectee -> match projectee with | Lazy_uvar -> true | uu___ -> false +let (uu___is_Lazy_letbinding : lazy_kind -> Prims.bool) = + fun projectee -> + match projectee with | Lazy_letbinding -> true | uu___ -> false +let (uu___is_Lazy_embedding : lazy_kind -> Prims.bool) = + fun projectee -> + match projectee with | Lazy_embedding _0 -> true | uu___ -> false +let (__proj__Lazy_embedding__item___0 : + lazy_kind -> (emb_typ * term' syntax FStarC_Thunk.t)) = + fun projectee -> match projectee with | Lazy_embedding _0 -> _0 +let (uu___is_Lazy_universe : lazy_kind -> Prims.bool) = + fun projectee -> + match projectee with | Lazy_universe -> true | uu___ -> false +let (uu___is_Lazy_universe_uvar : lazy_kind -> Prims.bool) = + fun projectee -> + match projectee with | Lazy_universe_uvar -> true | uu___ -> false +let (uu___is_Lazy_issue : lazy_kind -> Prims.bool) = + fun projectee -> match projectee with | Lazy_issue -> true | uu___ -> false +let (uu___is_Lazy_ident : lazy_kind -> Prims.bool) = + fun projectee -> match projectee with | Lazy_ident -> true | uu___ -> false +let (uu___is_Lazy_doc : lazy_kind -> Prims.bool) = + fun projectee -> match projectee with | Lazy_doc -> true | uu___ -> false +let (uu___is_Lazy_extension : lazy_kind -> Prims.bool) = + fun projectee -> + match projectee with | Lazy_extension _0 -> true | uu___ -> false +let (__proj__Lazy_extension__item___0 : lazy_kind -> Prims.string) = + fun projectee -> match projectee with | Lazy_extension _0 -> _0 +let (uu___is_Lazy_tref : lazy_kind -> Prims.bool) = + fun projectee -> match projectee with | Lazy_tref -> true | uu___ -> false +let (uu___is_Binding_var : binding -> Prims.bool) = + fun projectee -> + match projectee with | Binding_var _0 -> true | uu___ -> false +let (__proj__Binding_var__item___0 : binding -> bv) = + fun projectee -> match projectee with | Binding_var _0 -> _0 +let (uu___is_Binding_lid : binding -> Prims.bool) = + fun projectee -> + match projectee with | Binding_lid _0 -> true | uu___ -> false +let (__proj__Binding_lid__item___0 : + binding -> (FStarC_Ident.lident * (univ_names * term' syntax))) = + fun projectee -> match projectee with | Binding_lid _0 -> _0 +let (uu___is_Binding_univ : binding -> Prims.bool) = + fun projectee -> + match projectee with | Binding_univ _0 -> true | uu___ -> false +let (__proj__Binding_univ__item___0 : binding -> univ_name) = + fun projectee -> match projectee with | Binding_univ _0 -> _0 +let (uu___is_Implicit : binder_qualifier -> Prims.bool) = + fun projectee -> + match projectee with | Implicit _0 -> true | uu___ -> false +let (__proj__Implicit__item___0 : binder_qualifier -> Prims.bool) = + fun projectee -> match projectee with | Implicit _0 -> _0 +let (uu___is_Meta : binder_qualifier -> Prims.bool) = + fun projectee -> match projectee with | Meta _0 -> true | uu___ -> false +let (__proj__Meta__item___0 : binder_qualifier -> term' syntax) = + fun projectee -> match projectee with | Meta _0 -> _0 +let (uu___is_Equality : binder_qualifier -> Prims.bool) = + fun projectee -> match projectee with | Equality -> true | uu___ -> false +let (__proj__Mkarg_qualifier__item__aqual_implicit : + arg_qualifier -> Prims.bool) = + fun projectee -> + match projectee with + | { aqual_implicit; aqual_attributes;_} -> aqual_implicit +let (__proj__Mkarg_qualifier__item__aqual_attributes : + arg_qualifier -> term' syntax Prims.list) = + fun projectee -> + match projectee with + | { aqual_implicit; aqual_attributes;_} -> aqual_attributes +type subst_ts = (subst_elt Prims.list Prims.list * maybe_set_use_range) +type ctx_uvar_and_subst = + (ctx_uvar * (subst_elt Prims.list Prims.list * maybe_set_use_range)) +type term = term' syntax +type uvar = + ((term' syntax FStar_Pervasives_Native.option * uvar_decoration) + FStarC_Unionfind.p_uvar * version * FStarC_Compiler_Range_Type.range) +type uvars = ctx_uvar FStarC_Compiler_FlatSet.t +type comp = comp' syntax +type ascription = + ((term' syntax, comp' syntax) FStar_Pervasives.either * term' syntax + FStar_Pervasives_Native.option * Prims.bool) +type match_returns_ascription = + (binder * ((term' syntax, comp' syntax) FStar_Pervasives.either * term' + syntax FStar_Pervasives_Native.option * Prims.bool)) +type pat = pat' withinfo_t +type branch = + (pat' withinfo_t * term' syntax FStar_Pervasives_Native.option * term' + syntax) +type antiquotations = (Prims.int * term' syntax Prims.list) +type typ = term' syntax +type aqual = arg_qualifier FStar_Pervasives_Native.option +type arg = (term' syntax * arg_qualifier FStar_Pervasives_Native.option) +type args = + (term' syntax * arg_qualifier FStar_Pervasives_Native.option) Prims.list +type binders = binder Prims.list +type lbname = (bv, fv) FStar_Pervasives.either +type letbindings = (Prims.bool * letbinding Prims.list) +type freenames = bv FStarC_Compiler_FlatSet.t +type attribute = term' syntax +type tscheme = (univ_name Prims.list * term' syntax) +type gamma = binding Prims.list +type bqual = binder_qualifier FStar_Pervasives_Native.option +type freenames_l = bv Prims.list +type formula = typ +type formulae = typ Prims.list +type qualifier = + | Assumption + | New + | Private + | Unfold_for_unification_and_vcgen + | Irreducible + | Inline_for_extraction + | NoExtract + | Noeq + | Unopteq + | TotalEffect + | Logic + | Reifiable + | Reflectable of FStarC_Ident.lident + | Visible_default + | Discriminator of FStarC_Ident.lident + | Projector of (FStarC_Ident.lident * FStarC_Ident.ident) + | RecordType of (FStarC_Ident.ident Prims.list * FStarC_Ident.ident + Prims.list) + | RecordConstructor of (FStarC_Ident.ident Prims.list * FStarC_Ident.ident + Prims.list) + | Action of FStarC_Ident.lident + | ExceptionConstructor + | HasMaskedEffect + | Effect + | OnlyName + | InternalAssumption +let (uu___is_Assumption : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Assumption -> true | uu___ -> false +let (uu___is_New : qualifier -> Prims.bool) = + fun projectee -> match projectee with | New -> true | uu___ -> false +let (uu___is_Private : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Private -> true | uu___ -> false +let (uu___is_Unfold_for_unification_and_vcgen : qualifier -> Prims.bool) = + fun projectee -> + match projectee with + | Unfold_for_unification_and_vcgen -> true + | uu___ -> false +let (uu___is_Irreducible : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | Irreducible -> true | uu___ -> false +let (uu___is_Inline_for_extraction : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | Inline_for_extraction -> true | uu___ -> false +let (uu___is_NoExtract : qualifier -> Prims.bool) = + fun projectee -> match projectee with | NoExtract -> true | uu___ -> false +let (uu___is_Noeq : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Noeq -> true | uu___ -> false +let (uu___is_Unopteq : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Unopteq -> true | uu___ -> false +let (uu___is_TotalEffect : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | TotalEffect -> true | uu___ -> false +let (uu___is_Logic : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Logic -> true | uu___ -> false +let (uu___is_Reifiable : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Reifiable -> true | uu___ -> false +let (uu___is_Reflectable : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | Reflectable _0 -> true | uu___ -> false +let (__proj__Reflectable__item___0 : qualifier -> FStarC_Ident.lident) = + fun projectee -> match projectee with | Reflectable _0 -> _0 +let (uu___is_Visible_default : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | Visible_default -> true | uu___ -> false +let (uu___is_Discriminator : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | Discriminator _0 -> true | uu___ -> false +let (__proj__Discriminator__item___0 : qualifier -> FStarC_Ident.lident) = + fun projectee -> match projectee with | Discriminator _0 -> _0 +let (uu___is_Projector : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | Projector _0 -> true | uu___ -> false +let (__proj__Projector__item___0 : + qualifier -> (FStarC_Ident.lident * FStarC_Ident.ident)) = + fun projectee -> match projectee with | Projector _0 -> _0 +let (uu___is_RecordType : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | RecordType _0 -> true | uu___ -> false +let (__proj__RecordType__item___0 : + qualifier -> + (FStarC_Ident.ident Prims.list * FStarC_Ident.ident Prims.list)) + = fun projectee -> match projectee with | RecordType _0 -> _0 +let (uu___is_RecordConstructor : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | RecordConstructor _0 -> true | uu___ -> false +let (__proj__RecordConstructor__item___0 : + qualifier -> + (FStarC_Ident.ident Prims.list * FStarC_Ident.ident Prims.list)) + = fun projectee -> match projectee with | RecordConstructor _0 -> _0 +let (uu___is_Action : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Action _0 -> true | uu___ -> false +let (__proj__Action__item___0 : qualifier -> FStarC_Ident.lident) = + fun projectee -> match projectee with | Action _0 -> _0 +let (uu___is_ExceptionConstructor : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | ExceptionConstructor -> true | uu___ -> false +let (uu___is_HasMaskedEffect : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | HasMaskedEffect -> true | uu___ -> false +let (uu___is_Effect : qualifier -> Prims.bool) = + fun projectee -> match projectee with | Effect -> true | uu___ -> false +let (uu___is_OnlyName : qualifier -> Prims.bool) = + fun projectee -> match projectee with | OnlyName -> true | uu___ -> false +let (uu___is_InternalAssumption : qualifier -> Prims.bool) = + fun projectee -> + match projectee with | InternalAssumption -> true | uu___ -> false +let rec (emb_typ_to_string : emb_typ -> Prims.string) = + fun uu___ -> + match uu___ with + | ET_abstract -> "abstract" + | ET_app (h, []) -> h + | ET_app (h, args1) -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Compiler_List.map emb_typ_to_string args1 in + FStarC_Compiler_String.concat " " uu___5 in + Prims.strcat uu___4 ")" in + Prims.strcat " " uu___3 in + Prims.strcat h uu___2 in + Prims.strcat "(" uu___1 + | ET_fun (a, b) -> + let uu___1 = + let uu___2 = emb_typ_to_string a in + let uu___3 = + let uu___4 = emb_typ_to_string b in Prims.strcat ") -> " uu___4 in + Prims.strcat uu___2 uu___3 in + Prims.strcat "(" uu___1 +let (showable_emb_typ : emb_typ FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = emb_typ_to_string } +let rec (delta_depth_to_string : delta_depth -> Prims.string) = + fun uu___ -> + match uu___ with + | Delta_constant_at_level i -> + let uu___1 = FStarC_Compiler_Util.string_of_int i in + Prims.strcat "Delta_constant_at_level " uu___1 + | Delta_equational_at_level i -> + let uu___1 = FStarC_Compiler_Util.string_of_int i in + Prims.strcat "Delta_equational_at_level " uu___1 + | Delta_abstract d -> + let uu___1 = + let uu___2 = delta_depth_to_string d in Prims.strcat uu___2 ")" in + Prims.strcat "Delta_abstract (" uu___1 +let (showable_delta_depth : delta_depth FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = delta_depth_to_string } +let (showable_should_check_uvar : + should_check_uvar FStarC_Class_Show.showable) = + { + FStarC_Class_Show.show = + (fun uu___ -> + match uu___ with + | Allow_unresolved s -> Prims.strcat "Allow_unresolved " s + | Allow_untyped s -> Prims.strcat "Allow_untyped " s + | Allow_ghost s -> Prims.strcat "Allow_ghost " s + | Strict -> "Strict" + | Already_checked -> "Already_checked") + } +let (lazy_chooser : + (lazy_kind -> lazyinfo -> term) FStar_Pervasives_Native.option + FStarC_Compiler_Effect.ref) + = FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None +let (is_internal_qualifier : qualifier -> Prims.bool) = + fun q -> + match q with + | Visible_default -> true + | Discriminator uu___ -> true + | Projector uu___ -> true + | RecordType uu___ -> true + | RecordConstructor uu___ -> true + | Action uu___ -> true + | ExceptionConstructor -> true + | HasMaskedEffect -> true + | Effect -> true + | OnlyName -> true + | InternalAssumption -> true + | uu___ -> false +type tycon = (FStarC_Ident.lident * binders * typ) +type monad_abbrev = { + mabbrev: FStarC_Ident.lident ; + parms: binders ; + def: typ } +let (__proj__Mkmonad_abbrev__item__mabbrev : + monad_abbrev -> FStarC_Ident.lident) = + fun projectee -> match projectee with | { mabbrev; parms; def;_} -> mabbrev +let (__proj__Mkmonad_abbrev__item__parms : monad_abbrev -> binders) = + fun projectee -> match projectee with | { mabbrev; parms; def;_} -> parms +let (__proj__Mkmonad_abbrev__item__def : monad_abbrev -> typ) = + fun projectee -> match projectee with | { mabbrev; parms; def;_} -> def +type indexed_effect_binder_kind = + | Type_binder + | Substitutive_binder + | BindCont_no_abstraction_binder + | Range_binder + | Repr_binder + | Ad_hoc_binder +let (uu___is_Type_binder : indexed_effect_binder_kind -> Prims.bool) = + fun projectee -> + match projectee with | Type_binder -> true | uu___ -> false +let (uu___is_Substitutive_binder : indexed_effect_binder_kind -> Prims.bool) + = + fun projectee -> + match projectee with | Substitutive_binder -> true | uu___ -> false +let (uu___is_BindCont_no_abstraction_binder : + indexed_effect_binder_kind -> Prims.bool) = + fun projectee -> + match projectee with + | BindCont_no_abstraction_binder -> true + | uu___ -> false +let (uu___is_Range_binder : indexed_effect_binder_kind -> Prims.bool) = + fun projectee -> + match projectee with | Range_binder -> true | uu___ -> false +let (uu___is_Repr_binder : indexed_effect_binder_kind -> Prims.bool) = + fun projectee -> + match projectee with | Repr_binder -> true | uu___ -> false +let (uu___is_Ad_hoc_binder : indexed_effect_binder_kind -> Prims.bool) = + fun projectee -> + match projectee with | Ad_hoc_binder -> true | uu___ -> false +let (showable_indexed_effect_binder_kind : + indexed_effect_binder_kind FStarC_Class_Show.showable) = + { + FStarC_Class_Show.show = + (fun uu___ -> + match uu___ with + | Type_binder -> "Type_binder" + | Substitutive_binder -> "Substitutive_binder" + | BindCont_no_abstraction_binder -> "BindCont_no_abstraction_binder" + | Range_binder -> "Range_binder" + | Repr_binder -> "Repr_binder" + | Ad_hoc_binder -> "Ad_hoc_binder") + } +let (tagged_indexed_effect_binder_kind : + indexed_effect_binder_kind FStarC_Class_Tagged.tagged) = + { + FStarC_Class_Tagged.tag_of = + (fun uu___ -> + match uu___ with + | Type_binder -> "Type_binder" + | Substitutive_binder -> "Substitutive_binder" + | BindCont_no_abstraction_binder -> "BindCont_no_abstraction_binder" + | Range_binder -> "Range_binder" + | Repr_binder -> "Repr_binder" + | Ad_hoc_binder -> "Ad_hoc_binder") + } +type indexed_effect_combinator_kind = + | Substitutive_combinator of indexed_effect_binder_kind Prims.list + | Substitutive_invariant_combinator + | Ad_hoc_combinator +let (uu___is_Substitutive_combinator : + indexed_effect_combinator_kind -> Prims.bool) = + fun projectee -> + match projectee with + | Substitutive_combinator _0 -> true + | uu___ -> false +let (__proj__Substitutive_combinator__item___0 : + indexed_effect_combinator_kind -> indexed_effect_binder_kind Prims.list) = + fun projectee -> match projectee with | Substitutive_combinator _0 -> _0 +let (uu___is_Substitutive_invariant_combinator : + indexed_effect_combinator_kind -> Prims.bool) = + fun projectee -> + match projectee with + | Substitutive_invariant_combinator -> true + | uu___ -> false +let (uu___is_Ad_hoc_combinator : + indexed_effect_combinator_kind -> Prims.bool) = + fun projectee -> + match projectee with | Ad_hoc_combinator -> true | uu___ -> false +let (showable_indexed_effect_combinator_kind : + indexed_effect_combinator_kind FStarC_Class_Show.showable) = + { + FStarC_Class_Show.show = + (fun uu___ -> + match uu___ with + | Substitutive_combinator ks -> + let uu___1 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + showable_indexed_effect_binder_kind) ks in + Prims.strcat "Substitutive_combinator " uu___1 + | Substitutive_invariant_combinator -> + "Substitutive_invariant_combinator" + | Ad_hoc_combinator -> "Ad_hoc_combinator") + } +let (tagged_indexed_effect_combinator_kind : + indexed_effect_combinator_kind FStarC_Class_Tagged.tagged) = + { + FStarC_Class_Tagged.tag_of = + (fun uu___ -> + match uu___ with + | Substitutive_combinator uu___1 -> "Substitutive_combinator" + | Substitutive_invariant_combinator -> + "Substitutive_invariant_combinator" + | Ad_hoc_combinator -> "Ad_hoc_combinator") + } +type sub_eff = + { + source: FStarC_Ident.lident ; + target: FStarC_Ident.lident ; + lift_wp: tscheme FStar_Pervasives_Native.option ; + lift: tscheme FStar_Pervasives_Native.option ; + kind: indexed_effect_combinator_kind FStar_Pervasives_Native.option } +let (__proj__Mksub_eff__item__source : sub_eff -> FStarC_Ident.lident) = + fun projectee -> + match projectee with | { source; target; lift_wp; lift; kind;_} -> source +let (__proj__Mksub_eff__item__target : sub_eff -> FStarC_Ident.lident) = + fun projectee -> + match projectee with | { source; target; lift_wp; lift; kind;_} -> target +let (__proj__Mksub_eff__item__lift_wp : + sub_eff -> tscheme FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { source; target; lift_wp; lift; kind;_} -> lift_wp +let (__proj__Mksub_eff__item__lift : + sub_eff -> tscheme FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with | { source; target; lift_wp; lift; kind;_} -> lift +let (__proj__Mksub_eff__item__kind : + sub_eff -> indexed_effect_combinator_kind FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with | { source; target; lift_wp; lift; kind;_} -> kind +type action = + { + action_name: FStarC_Ident.lident ; + action_unqualified_name: FStarC_Ident.ident ; + action_univs: univ_names ; + action_params: binders ; + action_defn: term ; + action_typ: typ } +let (__proj__Mkaction__item__action_name : action -> FStarC_Ident.lident) = + fun projectee -> + match projectee with + | { action_name; action_unqualified_name; action_univs; action_params; + action_defn; action_typ;_} -> action_name +let (__proj__Mkaction__item__action_unqualified_name : + action -> FStarC_Ident.ident) = + fun projectee -> + match projectee with + | { action_name; action_unqualified_name; action_univs; action_params; + action_defn; action_typ;_} -> action_unqualified_name +let (__proj__Mkaction__item__action_univs : action -> univ_names) = + fun projectee -> + match projectee with + | { action_name; action_unqualified_name; action_univs; action_params; + action_defn; action_typ;_} -> action_univs +let (__proj__Mkaction__item__action_params : action -> binders) = + fun projectee -> + match projectee with + | { action_name; action_unqualified_name; action_univs; action_params; + action_defn; action_typ;_} -> action_params +let (__proj__Mkaction__item__action_defn : action -> term) = + fun projectee -> + match projectee with + | { action_name; action_unqualified_name; action_univs; action_params; + action_defn; action_typ;_} -> action_defn +let (__proj__Mkaction__item__action_typ : action -> typ) = + fun projectee -> + match projectee with + | { action_name; action_unqualified_name; action_univs; action_params; + action_defn; action_typ;_} -> action_typ +type wp_eff_combinators = + { + ret_wp: tscheme ; + bind_wp: tscheme ; + stronger: tscheme ; + if_then_else: tscheme ; + ite_wp: tscheme ; + close_wp: tscheme ; + trivial: tscheme ; + repr: tscheme FStar_Pervasives_Native.option ; + return_repr: tscheme FStar_Pervasives_Native.option ; + bind_repr: tscheme FStar_Pervasives_Native.option } +let (__proj__Mkwp_eff_combinators__item__ret_wp : + wp_eff_combinators -> tscheme) = + fun projectee -> + match projectee with + | { ret_wp; bind_wp; stronger; if_then_else; ite_wp; close_wp; trivial; + repr; return_repr; bind_repr;_} -> ret_wp +let (__proj__Mkwp_eff_combinators__item__bind_wp : + wp_eff_combinators -> tscheme) = + fun projectee -> + match projectee with + | { ret_wp; bind_wp; stronger; if_then_else; ite_wp; close_wp; trivial; + repr; return_repr; bind_repr;_} -> bind_wp +let (__proj__Mkwp_eff_combinators__item__stronger : + wp_eff_combinators -> tscheme) = + fun projectee -> + match projectee with + | { ret_wp; bind_wp; stronger; if_then_else; ite_wp; close_wp; trivial; + repr; return_repr; bind_repr;_} -> stronger +let (__proj__Mkwp_eff_combinators__item__if_then_else : + wp_eff_combinators -> tscheme) = + fun projectee -> + match projectee with + | { ret_wp; bind_wp; stronger; if_then_else; ite_wp; close_wp; trivial; + repr; return_repr; bind_repr;_} -> if_then_else +let (__proj__Mkwp_eff_combinators__item__ite_wp : + wp_eff_combinators -> tscheme) = + fun projectee -> + match projectee with + | { ret_wp; bind_wp; stronger; if_then_else; ite_wp; close_wp; trivial; + repr; return_repr; bind_repr;_} -> ite_wp +let (__proj__Mkwp_eff_combinators__item__close_wp : + wp_eff_combinators -> tscheme) = + fun projectee -> + match projectee with + | { ret_wp; bind_wp; stronger; if_then_else; ite_wp; close_wp; trivial; + repr; return_repr; bind_repr;_} -> close_wp +let (__proj__Mkwp_eff_combinators__item__trivial : + wp_eff_combinators -> tscheme) = + fun projectee -> + match projectee with + | { ret_wp; bind_wp; stronger; if_then_else; ite_wp; close_wp; trivial; + repr; return_repr; bind_repr;_} -> trivial +let (__proj__Mkwp_eff_combinators__item__repr : + wp_eff_combinators -> tscheme FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { ret_wp; bind_wp; stronger; if_then_else; ite_wp; close_wp; trivial; + repr; return_repr; bind_repr;_} -> repr +let (__proj__Mkwp_eff_combinators__item__return_repr : + wp_eff_combinators -> tscheme FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { ret_wp; bind_wp; stronger; if_then_else; ite_wp; close_wp; trivial; + repr; return_repr; bind_repr;_} -> return_repr +let (__proj__Mkwp_eff_combinators__item__bind_repr : + wp_eff_combinators -> tscheme FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { ret_wp; bind_wp; stronger; if_then_else; ite_wp; close_wp; trivial; + repr; return_repr; bind_repr;_} -> bind_repr +type layered_eff_combinators = + { + l_repr: (tscheme * tscheme) ; + l_return: (tscheme * tscheme) ; + l_bind: + (tscheme * tscheme * indexed_effect_combinator_kind + FStar_Pervasives_Native.option) + ; + l_subcomp: + (tscheme * tscheme * indexed_effect_combinator_kind + FStar_Pervasives_Native.option) + ; + l_if_then_else: + (tscheme * tscheme * indexed_effect_combinator_kind + FStar_Pervasives_Native.option) + ; + l_close: (tscheme * tscheme) FStar_Pervasives_Native.option } +let (__proj__Mklayered_eff_combinators__item__l_repr : + layered_eff_combinators -> (tscheme * tscheme)) = + fun projectee -> + match projectee with + | { l_repr; l_return; l_bind; l_subcomp; l_if_then_else; l_close;_} -> + l_repr +let (__proj__Mklayered_eff_combinators__item__l_return : + layered_eff_combinators -> (tscheme * tscheme)) = + fun projectee -> + match projectee with + | { l_repr; l_return; l_bind; l_subcomp; l_if_then_else; l_close;_} -> + l_return +let (__proj__Mklayered_eff_combinators__item__l_bind : + layered_eff_combinators -> + (tscheme * tscheme * indexed_effect_combinator_kind + FStar_Pervasives_Native.option)) + = + fun projectee -> + match projectee with + | { l_repr; l_return; l_bind; l_subcomp; l_if_then_else; l_close;_} -> + l_bind +let (__proj__Mklayered_eff_combinators__item__l_subcomp : + layered_eff_combinators -> + (tscheme * tscheme * indexed_effect_combinator_kind + FStar_Pervasives_Native.option)) + = + fun projectee -> + match projectee with + | { l_repr; l_return; l_bind; l_subcomp; l_if_then_else; l_close;_} -> + l_subcomp +let (__proj__Mklayered_eff_combinators__item__l_if_then_else : + layered_eff_combinators -> + (tscheme * tscheme * indexed_effect_combinator_kind + FStar_Pervasives_Native.option)) + = + fun projectee -> + match projectee with + | { l_repr; l_return; l_bind; l_subcomp; l_if_then_else; l_close;_} -> + l_if_then_else +let (__proj__Mklayered_eff_combinators__item__l_close : + layered_eff_combinators -> + (tscheme * tscheme) FStar_Pervasives_Native.option) + = + fun projectee -> + match projectee with + | { l_repr; l_return; l_bind; l_subcomp; l_if_then_else; l_close;_} -> + l_close +type eff_combinators = + | Primitive_eff of wp_eff_combinators + | DM4F_eff of wp_eff_combinators + | Layered_eff of layered_eff_combinators +let (uu___is_Primitive_eff : eff_combinators -> Prims.bool) = + fun projectee -> + match projectee with | Primitive_eff _0 -> true | uu___ -> false +let (__proj__Primitive_eff__item___0 : eff_combinators -> wp_eff_combinators) + = fun projectee -> match projectee with | Primitive_eff _0 -> _0 +let (uu___is_DM4F_eff : eff_combinators -> Prims.bool) = + fun projectee -> + match projectee with | DM4F_eff _0 -> true | uu___ -> false +let (__proj__DM4F_eff__item___0 : eff_combinators -> wp_eff_combinators) = + fun projectee -> match projectee with | DM4F_eff _0 -> _0 +let (uu___is_Layered_eff : eff_combinators -> Prims.bool) = + fun projectee -> + match projectee with | Layered_eff _0 -> true | uu___ -> false +let (__proj__Layered_eff__item___0 : + eff_combinators -> layered_eff_combinators) = + fun projectee -> match projectee with | Layered_eff _0 -> _0 +type effect_signature = + | Layered_eff_sig of (Prims.int * tscheme) + | WP_eff_sig of tscheme +let (uu___is_Layered_eff_sig : effect_signature -> Prims.bool) = + fun projectee -> + match projectee with | Layered_eff_sig _0 -> true | uu___ -> false +let (__proj__Layered_eff_sig__item___0 : + effect_signature -> (Prims.int * tscheme)) = + fun projectee -> match projectee with | Layered_eff_sig _0 -> _0 +let (uu___is_WP_eff_sig : effect_signature -> Prims.bool) = + fun projectee -> + match projectee with | WP_eff_sig _0 -> true | uu___ -> false +let (__proj__WP_eff_sig__item___0 : effect_signature -> tscheme) = + fun projectee -> match projectee with | WP_eff_sig _0 -> _0 +type eff_extraction_mode = + | Extract_none of Prims.string + | Extract_reify + | Extract_primitive +let (uu___is_Extract_none : eff_extraction_mode -> Prims.bool) = + fun projectee -> + match projectee with | Extract_none _0 -> true | uu___ -> false +let (__proj__Extract_none__item___0 : eff_extraction_mode -> Prims.string) = + fun projectee -> match projectee with | Extract_none _0 -> _0 +let (uu___is_Extract_reify : eff_extraction_mode -> Prims.bool) = + fun projectee -> + match projectee with | Extract_reify -> true | uu___ -> false +let (uu___is_Extract_primitive : eff_extraction_mode -> Prims.bool) = + fun projectee -> + match projectee with | Extract_primitive -> true | uu___ -> false +let (showable_eff_extraction_mode : + eff_extraction_mode FStarC_Class_Show.showable) = + { + FStarC_Class_Show.show = + (fun uu___ -> + match uu___ with + | Extract_none s -> Prims.strcat "Extract_none " s + | Extract_reify -> "Extract_reify" + | Extract_primitive -> "Extract_primitive") + } +let (tagged_eff_extraction_mode : + eff_extraction_mode FStarC_Class_Tagged.tagged) = + { + FStarC_Class_Tagged.tag_of = + (fun uu___ -> + match uu___ with + | Extract_none uu___1 -> "Extract_none" + | Extract_reify -> "Extract_reify" + | Extract_primitive -> "Extract_primitive") + } +type eff_decl = + { + mname: FStarC_Ident.lident ; + cattributes: cflag Prims.list ; + univs: univ_names ; + binders: binders ; + signature: effect_signature ; + combinators: eff_combinators ; + actions: action Prims.list ; + eff_attrs: attribute Prims.list ; + extraction_mode: eff_extraction_mode } +let (__proj__Mkeff_decl__item__mname : eff_decl -> FStarC_Ident.lident) = + fun projectee -> + match projectee with + | { mname; cattributes; univs; binders = binders1; signature; + combinators; actions; eff_attrs; extraction_mode;_} -> mname +let (__proj__Mkeff_decl__item__cattributes : eff_decl -> cflag Prims.list) = + fun projectee -> + match projectee with + | { mname; cattributes; univs; binders = binders1; signature; + combinators; actions; eff_attrs; extraction_mode;_} -> cattributes +let (__proj__Mkeff_decl__item__univs : eff_decl -> univ_names) = + fun projectee -> + match projectee with + | { mname; cattributes; univs; binders = binders1; signature; + combinators; actions; eff_attrs; extraction_mode;_} -> univs +let (__proj__Mkeff_decl__item__binders : eff_decl -> binders) = + fun projectee -> + match projectee with + | { mname; cattributes; univs; binders = binders1; signature; + combinators; actions; eff_attrs; extraction_mode;_} -> binders1 +let (__proj__Mkeff_decl__item__signature : eff_decl -> effect_signature) = + fun projectee -> + match projectee with + | { mname; cattributes; univs; binders = binders1; signature; + combinators; actions; eff_attrs; extraction_mode;_} -> signature +let (__proj__Mkeff_decl__item__combinators : eff_decl -> eff_combinators) = + fun projectee -> + match projectee with + | { mname; cattributes; univs; binders = binders1; signature; + combinators; actions; eff_attrs; extraction_mode;_} -> combinators +let (__proj__Mkeff_decl__item__actions : eff_decl -> action Prims.list) = + fun projectee -> + match projectee with + | { mname; cattributes; univs; binders = binders1; signature; + combinators; actions; eff_attrs; extraction_mode;_} -> actions +let (__proj__Mkeff_decl__item__eff_attrs : eff_decl -> attribute Prims.list) + = + fun projectee -> + match projectee with + | { mname; cattributes; univs; binders = binders1; signature; + combinators; actions; eff_attrs; extraction_mode;_} -> eff_attrs +let (__proj__Mkeff_decl__item__extraction_mode : + eff_decl -> eff_extraction_mode) = + fun projectee -> + match projectee with + | { mname; cattributes; univs; binders = binders1; signature; + combinators; actions; eff_attrs; extraction_mode;_} -> + extraction_mode +type sig_metadata = + { + sigmeta_active: Prims.bool ; + sigmeta_fact_db_ids: Prims.string Prims.list ; + sigmeta_admit: Prims.bool ; + sigmeta_spliced: Prims.bool ; + sigmeta_already_checked: Prims.bool ; + sigmeta_extension_data: (Prims.string * FStarC_Dyn.dyn) Prims.list } +let (__proj__Mksig_metadata__item__sigmeta_active : + sig_metadata -> Prims.bool) = + fun projectee -> + match projectee with + | { sigmeta_active; sigmeta_fact_db_ids; sigmeta_admit; sigmeta_spliced; + sigmeta_already_checked; sigmeta_extension_data;_} -> sigmeta_active +let (__proj__Mksig_metadata__item__sigmeta_fact_db_ids : + sig_metadata -> Prims.string Prims.list) = + fun projectee -> + match projectee with + | { sigmeta_active; sigmeta_fact_db_ids; sigmeta_admit; sigmeta_spliced; + sigmeta_already_checked; sigmeta_extension_data;_} -> + sigmeta_fact_db_ids +let (__proj__Mksig_metadata__item__sigmeta_admit : + sig_metadata -> Prims.bool) = + fun projectee -> + match projectee with + | { sigmeta_active; sigmeta_fact_db_ids; sigmeta_admit; sigmeta_spliced; + sigmeta_already_checked; sigmeta_extension_data;_} -> sigmeta_admit +let (__proj__Mksig_metadata__item__sigmeta_spliced : + sig_metadata -> Prims.bool) = + fun projectee -> + match projectee with + | { sigmeta_active; sigmeta_fact_db_ids; sigmeta_admit; sigmeta_spliced; + sigmeta_already_checked; sigmeta_extension_data;_} -> sigmeta_spliced +let (__proj__Mksig_metadata__item__sigmeta_already_checked : + sig_metadata -> Prims.bool) = + fun projectee -> + match projectee with + | { sigmeta_active; sigmeta_fact_db_ids; sigmeta_admit; sigmeta_spliced; + sigmeta_already_checked; sigmeta_extension_data;_} -> + sigmeta_already_checked +let (__proj__Mksig_metadata__item__sigmeta_extension_data : + sig_metadata -> (Prims.string * FStarC_Dyn.dyn) Prims.list) = + fun projectee -> + match projectee with + | { sigmeta_active; sigmeta_fact_db_ids; sigmeta_admit; sigmeta_spliced; + sigmeta_already_checked; sigmeta_extension_data;_} -> + sigmeta_extension_data +type open_kind = + | Open_module + | Open_namespace +let (uu___is_Open_module : open_kind -> Prims.bool) = + fun projectee -> + match projectee with | Open_module -> true | uu___ -> false +let (uu___is_Open_namespace : open_kind -> Prims.bool) = + fun projectee -> + match projectee with | Open_namespace -> true | uu___ -> false +type ident_alias = FStarC_Ident.ident FStar_Pervasives_Native.option +type restriction = + | Unrestricted + | AllowList of (FStarC_Ident.ident * ident_alias) Prims.list +let (uu___is_Unrestricted : restriction -> Prims.bool) = + fun projectee -> + match projectee with | Unrestricted -> true | uu___ -> false +let (uu___is_AllowList : restriction -> Prims.bool) = + fun projectee -> + match projectee with | AllowList _0 -> true | uu___ -> false +let (__proj__AllowList__item___0 : + restriction -> (FStarC_Ident.ident * ident_alias) Prims.list) = + fun projectee -> match projectee with | AllowList _0 -> _0 +type open_module_or_namespace = + (FStarC_Ident.lident * open_kind * restriction) +type module_abbrev = (FStarC_Ident.ident * FStarC_Ident.lident) +type sigelt'__Sig_inductive_typ__payload = + { + lid: FStarC_Ident.lident ; + us: univ_names ; + params: binders ; + num_uniform_params: Prims.int FStar_Pervasives_Native.option ; + t: typ ; + mutuals: FStarC_Ident.lident Prims.list ; + ds: FStarC_Ident.lident Prims.list ; + injective_type_params: Prims.bool } +and sigelt'__Sig_bundle__payload = + { + ses: sigelt Prims.list ; + lids: FStarC_Ident.lident Prims.list } +and sigelt'__Sig_datacon__payload = + { + lid1: FStarC_Ident.lident ; + us1: univ_names ; + t1: typ ; + ty_lid: FStarC_Ident.lident ; + num_ty_params: Prims.int ; + mutuals1: FStarC_Ident.lident Prims.list ; + injective_type_params1: Prims.bool } +and sigelt'__Sig_declare_typ__payload = + { + lid2: FStarC_Ident.lident ; + us2: univ_names ; + t2: typ } +and sigelt'__Sig_let__payload = + { + lbs1: letbindings ; + lids1: FStarC_Ident.lident Prims.list } +and sigelt'__Sig_assume__payload = + { + lid3: FStarC_Ident.lident ; + us3: univ_names ; + phi1: formula } +and sigelt'__Sig_effect_abbrev__payload = + { + lid4: FStarC_Ident.lident ; + us4: univ_names ; + bs2: binders ; + comp1: comp ; + cflags: cflag Prims.list } +and sigelt'__Sig_splice__payload = + { + is_typed: Prims.bool ; + lids2: FStarC_Ident.lident Prims.list ; + tac: term } +and sigelt'__Sig_polymonadic_bind__payload = + { + m_lid: FStarC_Ident.lident ; + n_lid: FStarC_Ident.lident ; + p_lid: FStarC_Ident.lident ; + tm3: tscheme ; + typ: tscheme ; + kind1: indexed_effect_combinator_kind FStar_Pervasives_Native.option } +and sigelt'__Sig_polymonadic_subcomp__payload = + { + m_lid1: FStarC_Ident.lident ; + n_lid1: FStarC_Ident.lident ; + tm4: tscheme ; + typ1: tscheme ; + kind2: indexed_effect_combinator_kind FStar_Pervasives_Native.option } +and sigelt'__Sig_fail__payload = + { + errs: Prims.int Prims.list ; + fail_in_lax: Prims.bool ; + ses1: sigelt Prims.list } +and sigelt' = + | Sig_inductive_typ of sigelt'__Sig_inductive_typ__payload + | Sig_bundle of sigelt'__Sig_bundle__payload + | Sig_datacon of sigelt'__Sig_datacon__payload + | Sig_declare_typ of sigelt'__Sig_declare_typ__payload + | Sig_let of sigelt'__Sig_let__payload + | Sig_assume of sigelt'__Sig_assume__payload + | Sig_new_effect of eff_decl + | Sig_sub_effect of sub_eff + | Sig_effect_abbrev of sigelt'__Sig_effect_abbrev__payload + | Sig_pragma of pragma + | Sig_splice of sigelt'__Sig_splice__payload + | Sig_polymonadic_bind of sigelt'__Sig_polymonadic_bind__payload + | Sig_polymonadic_subcomp of sigelt'__Sig_polymonadic_subcomp__payload + | Sig_fail of sigelt'__Sig_fail__payload +and sigelt = + { + sigel: sigelt' ; + sigrng: FStarC_Compiler_Range_Type.range ; + sigquals: qualifier Prims.list ; + sigmeta: sig_metadata ; + sigattrs: attribute Prims.list ; + sigopens_and_abbrevs: + (open_module_or_namespace, module_abbrev) FStar_Pervasives.either + Prims.list + ; + sigopts: FStarC_VConfig.vconfig FStar_Pervasives_Native.option } +let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__lid : + sigelt'__Sig_inductive_typ__payload -> FStarC_Ident.lident) = + fun projectee -> + match projectee with + | { lid; us; params; num_uniform_params; t; mutuals; ds; + injective_type_params;_} -> lid +let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__us : + sigelt'__Sig_inductive_typ__payload -> univ_names) = + fun projectee -> + match projectee with + | { lid; us; params; num_uniform_params; t; mutuals; ds; + injective_type_params;_} -> us +let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__params : + sigelt'__Sig_inductive_typ__payload -> binders) = + fun projectee -> + match projectee with + | { lid; us; params; num_uniform_params; t; mutuals; ds; + injective_type_params;_} -> params +let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__num_uniform_params + : + sigelt'__Sig_inductive_typ__payload -> + Prims.int FStar_Pervasives_Native.option) + = + fun projectee -> + match projectee with + | { lid; us; params; num_uniform_params; t; mutuals; ds; + injective_type_params;_} -> num_uniform_params +let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__t : + sigelt'__Sig_inductive_typ__payload -> typ) = + fun projectee -> + match projectee with + | { lid; us; params; num_uniform_params; t; mutuals; ds; + injective_type_params;_} -> t +let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__mutuals : + sigelt'__Sig_inductive_typ__payload -> FStarC_Ident.lident Prims.list) = + fun projectee -> + match projectee with + | { lid; us; params; num_uniform_params; t; mutuals; ds; + injective_type_params;_} -> mutuals +let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__ds : + sigelt'__Sig_inductive_typ__payload -> FStarC_Ident.lident Prims.list) = + fun projectee -> + match projectee with + | { lid; us; params; num_uniform_params; t; mutuals; ds; + injective_type_params;_} -> ds +let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__injective_type_params + : sigelt'__Sig_inductive_typ__payload -> Prims.bool) = + fun projectee -> + match projectee with + | { lid; us; params; num_uniform_params; t; mutuals; ds; + injective_type_params;_} -> injective_type_params +let (__proj__Mksigelt'__Sig_bundle__payload__item__ses : + sigelt'__Sig_bundle__payload -> sigelt Prims.list) = + fun projectee -> match projectee with | { ses; lids;_} -> ses +let (__proj__Mksigelt'__Sig_bundle__payload__item__lids : + sigelt'__Sig_bundle__payload -> FStarC_Ident.lident Prims.list) = + fun projectee -> match projectee with | { ses; lids;_} -> lids +let (__proj__Mksigelt'__Sig_datacon__payload__item__lid : + sigelt'__Sig_datacon__payload -> FStarC_Ident.lident) = + fun projectee -> + match projectee with + | { lid1 = lid; us1 = us; t1 = t; ty_lid; num_ty_params; + mutuals1 = mutuals; injective_type_params1 = injective_type_params;_} + -> lid +let (__proj__Mksigelt'__Sig_datacon__payload__item__us : + sigelt'__Sig_datacon__payload -> univ_names) = + fun projectee -> + match projectee with + | { lid1 = lid; us1 = us; t1 = t; ty_lid; num_ty_params; + mutuals1 = mutuals; injective_type_params1 = injective_type_params;_} + -> us +let (__proj__Mksigelt'__Sig_datacon__payload__item__t : + sigelt'__Sig_datacon__payload -> typ) = + fun projectee -> + match projectee with + | { lid1 = lid; us1 = us; t1 = t; ty_lid; num_ty_params; + mutuals1 = mutuals; injective_type_params1 = injective_type_params;_} + -> t +let (__proj__Mksigelt'__Sig_datacon__payload__item__ty_lid : + sigelt'__Sig_datacon__payload -> FStarC_Ident.lident) = + fun projectee -> + match projectee with + | { lid1 = lid; us1 = us; t1 = t; ty_lid; num_ty_params; + mutuals1 = mutuals; injective_type_params1 = injective_type_params;_} + -> ty_lid +let (__proj__Mksigelt'__Sig_datacon__payload__item__num_ty_params : + sigelt'__Sig_datacon__payload -> Prims.int) = + fun projectee -> + match projectee with + | { lid1 = lid; us1 = us; t1 = t; ty_lid; num_ty_params; + mutuals1 = mutuals; injective_type_params1 = injective_type_params;_} + -> num_ty_params +let (__proj__Mksigelt'__Sig_datacon__payload__item__mutuals : + sigelt'__Sig_datacon__payload -> FStarC_Ident.lident Prims.list) = + fun projectee -> + match projectee with + | { lid1 = lid; us1 = us; t1 = t; ty_lid; num_ty_params; + mutuals1 = mutuals; injective_type_params1 = injective_type_params;_} + -> mutuals +let (__proj__Mksigelt'__Sig_datacon__payload__item__injective_type_params : + sigelt'__Sig_datacon__payload -> Prims.bool) = + fun projectee -> + match projectee with + | { lid1 = lid; us1 = us; t1 = t; ty_lid; num_ty_params; + mutuals1 = mutuals; injective_type_params1 = injective_type_params;_} + -> injective_type_params +let (__proj__Mksigelt'__Sig_declare_typ__payload__item__lid : + sigelt'__Sig_declare_typ__payload -> FStarC_Ident.lident) = + fun projectee -> + match projectee with | { lid2 = lid; us2 = us; t2 = t;_} -> lid +let (__proj__Mksigelt'__Sig_declare_typ__payload__item__us : + sigelt'__Sig_declare_typ__payload -> univ_names) = + fun projectee -> + match projectee with | { lid2 = lid; us2 = us; t2 = t;_} -> us +let (__proj__Mksigelt'__Sig_declare_typ__payload__item__t : + sigelt'__Sig_declare_typ__payload -> typ) = + fun projectee -> + match projectee with | { lid2 = lid; us2 = us; t2 = t;_} -> t +let (__proj__Mksigelt'__Sig_let__payload__item__lbs : + sigelt'__Sig_let__payload -> letbindings) = + fun projectee -> + match projectee with | { lbs1 = lbs; lids1 = lids;_} -> lbs +let (__proj__Mksigelt'__Sig_let__payload__item__lids : + sigelt'__Sig_let__payload -> FStarC_Ident.lident Prims.list) = + fun projectee -> + match projectee with | { lbs1 = lbs; lids1 = lids;_} -> lids +let (__proj__Mksigelt'__Sig_assume__payload__item__lid : + sigelt'__Sig_assume__payload -> FStarC_Ident.lident) = + fun projectee -> + match projectee with | { lid3 = lid; us3 = us; phi1 = phi;_} -> lid +let (__proj__Mksigelt'__Sig_assume__payload__item__us : + sigelt'__Sig_assume__payload -> univ_names) = + fun projectee -> + match projectee with | { lid3 = lid; us3 = us; phi1 = phi;_} -> us +let (__proj__Mksigelt'__Sig_assume__payload__item__phi : + sigelt'__Sig_assume__payload -> formula) = + fun projectee -> + match projectee with | { lid3 = lid; us3 = us; phi1 = phi;_} -> phi +let (__proj__Mksigelt'__Sig_effect_abbrev__payload__item__lid : + sigelt'__Sig_effect_abbrev__payload -> FStarC_Ident.lident) = + fun projectee -> + match projectee with + | { lid4 = lid; us4 = us; bs2 = bs; comp1; cflags;_} -> lid +let (__proj__Mksigelt'__Sig_effect_abbrev__payload__item__us : + sigelt'__Sig_effect_abbrev__payload -> univ_names) = + fun projectee -> + match projectee with + | { lid4 = lid; us4 = us; bs2 = bs; comp1; cflags;_} -> us +let (__proj__Mksigelt'__Sig_effect_abbrev__payload__item__bs : + sigelt'__Sig_effect_abbrev__payload -> binders) = + fun projectee -> + match projectee with + | { lid4 = lid; us4 = us; bs2 = bs; comp1; cflags;_} -> bs +let (__proj__Mksigelt'__Sig_effect_abbrev__payload__item__comp : + sigelt'__Sig_effect_abbrev__payload -> comp) = + fun projectee -> + match projectee with + | { lid4 = lid; us4 = us; bs2 = bs; comp1; cflags;_} -> comp1 +let (__proj__Mksigelt'__Sig_effect_abbrev__payload__item__cflags : + sigelt'__Sig_effect_abbrev__payload -> cflag Prims.list) = + fun projectee -> + match projectee with + | { lid4 = lid; us4 = us; bs2 = bs; comp1; cflags;_} -> cflags +let (__proj__Mksigelt'__Sig_splice__payload__item__is_typed : + sigelt'__Sig_splice__payload -> Prims.bool) = + fun projectee -> + match projectee with | { is_typed; lids2 = lids; tac;_} -> is_typed +let (__proj__Mksigelt'__Sig_splice__payload__item__lids : + sigelt'__Sig_splice__payload -> FStarC_Ident.lident Prims.list) = + fun projectee -> + match projectee with | { is_typed; lids2 = lids; tac;_} -> lids +let (__proj__Mksigelt'__Sig_splice__payload__item__tac : + sigelt'__Sig_splice__payload -> term) = + fun projectee -> + match projectee with | { is_typed; lids2 = lids; tac;_} -> tac +let (__proj__Mksigelt'__Sig_polymonadic_bind__payload__item__m_lid : + sigelt'__Sig_polymonadic_bind__payload -> FStarC_Ident.lident) = + fun projectee -> + match projectee with + | { m_lid; n_lid; p_lid; tm3 = tm; typ = typ1; kind1 = kind;_} -> m_lid +let (__proj__Mksigelt'__Sig_polymonadic_bind__payload__item__n_lid : + sigelt'__Sig_polymonadic_bind__payload -> FStarC_Ident.lident) = + fun projectee -> + match projectee with + | { m_lid; n_lid; p_lid; tm3 = tm; typ = typ1; kind1 = kind;_} -> n_lid +let (__proj__Mksigelt'__Sig_polymonadic_bind__payload__item__p_lid : + sigelt'__Sig_polymonadic_bind__payload -> FStarC_Ident.lident) = + fun projectee -> + match projectee with + | { m_lid; n_lid; p_lid; tm3 = tm; typ = typ1; kind1 = kind;_} -> p_lid +let (__proj__Mksigelt'__Sig_polymonadic_bind__payload__item__tm : + sigelt'__Sig_polymonadic_bind__payload -> tscheme) = + fun projectee -> + match projectee with + | { m_lid; n_lid; p_lid; tm3 = tm; typ = typ1; kind1 = kind;_} -> tm +let (__proj__Mksigelt'__Sig_polymonadic_bind__payload__item__typ : + sigelt'__Sig_polymonadic_bind__payload -> tscheme) = + fun projectee -> + match projectee with + | { m_lid; n_lid; p_lid; tm3 = tm; typ = typ1; kind1 = kind;_} -> typ1 +let (__proj__Mksigelt'__Sig_polymonadic_bind__payload__item__kind : + sigelt'__Sig_polymonadic_bind__payload -> + indexed_effect_combinator_kind FStar_Pervasives_Native.option) + = + fun projectee -> + match projectee with + | { m_lid; n_lid; p_lid; tm3 = tm; typ = typ1; kind1 = kind;_} -> kind +let (__proj__Mksigelt'__Sig_polymonadic_subcomp__payload__item__m_lid : + sigelt'__Sig_polymonadic_subcomp__payload -> FStarC_Ident.lident) = + fun projectee -> + match projectee with + | { m_lid1 = m_lid; n_lid1 = n_lid; tm4 = tm; typ1; kind2 = kind;_} -> + m_lid +let (__proj__Mksigelt'__Sig_polymonadic_subcomp__payload__item__n_lid : + sigelt'__Sig_polymonadic_subcomp__payload -> FStarC_Ident.lident) = + fun projectee -> + match projectee with + | { m_lid1 = m_lid; n_lid1 = n_lid; tm4 = tm; typ1; kind2 = kind;_} -> + n_lid +let (__proj__Mksigelt'__Sig_polymonadic_subcomp__payload__item__tm : + sigelt'__Sig_polymonadic_subcomp__payload -> tscheme) = + fun projectee -> + match projectee with + | { m_lid1 = m_lid; n_lid1 = n_lid; tm4 = tm; typ1; kind2 = kind;_} -> tm +let (__proj__Mksigelt'__Sig_polymonadic_subcomp__payload__item__typ : + sigelt'__Sig_polymonadic_subcomp__payload -> tscheme) = + fun projectee -> + match projectee with + | { m_lid1 = m_lid; n_lid1 = n_lid; tm4 = tm; typ1; kind2 = kind;_} -> + typ1 +let (__proj__Mksigelt'__Sig_polymonadic_subcomp__payload__item__kind : + sigelt'__Sig_polymonadic_subcomp__payload -> + indexed_effect_combinator_kind FStar_Pervasives_Native.option) + = + fun projectee -> + match projectee with + | { m_lid1 = m_lid; n_lid1 = n_lid; tm4 = tm; typ1; kind2 = kind;_} -> + kind +let (__proj__Mksigelt'__Sig_fail__payload__item__errs : + sigelt'__Sig_fail__payload -> Prims.int Prims.list) = + fun projectee -> + match projectee with | { errs; fail_in_lax; ses1 = ses;_} -> errs +let (__proj__Mksigelt'__Sig_fail__payload__item__fail_in_lax : + sigelt'__Sig_fail__payload -> Prims.bool) = + fun projectee -> + match projectee with | { errs; fail_in_lax; ses1 = ses;_} -> fail_in_lax +let (__proj__Mksigelt'__Sig_fail__payload__item__ses : + sigelt'__Sig_fail__payload -> sigelt Prims.list) = + fun projectee -> + match projectee with | { errs; fail_in_lax; ses1 = ses;_} -> ses +let (uu___is_Sig_inductive_typ : sigelt' -> Prims.bool) = + fun projectee -> + match projectee with | Sig_inductive_typ _0 -> true | uu___ -> false +let (__proj__Sig_inductive_typ__item___0 : + sigelt' -> sigelt'__Sig_inductive_typ__payload) = + fun projectee -> match projectee with | Sig_inductive_typ _0 -> _0 +let (uu___is_Sig_bundle : sigelt' -> Prims.bool) = + fun projectee -> + match projectee with | Sig_bundle _0 -> true | uu___ -> false +let (__proj__Sig_bundle__item___0 : sigelt' -> sigelt'__Sig_bundle__payload) + = fun projectee -> match projectee with | Sig_bundle _0 -> _0 +let (uu___is_Sig_datacon : sigelt' -> Prims.bool) = + fun projectee -> + match projectee with | Sig_datacon _0 -> true | uu___ -> false +let (__proj__Sig_datacon__item___0 : + sigelt' -> sigelt'__Sig_datacon__payload) = + fun projectee -> match projectee with | Sig_datacon _0 -> _0 +let (uu___is_Sig_declare_typ : sigelt' -> Prims.bool) = + fun projectee -> + match projectee with | Sig_declare_typ _0 -> true | uu___ -> false +let (__proj__Sig_declare_typ__item___0 : + sigelt' -> sigelt'__Sig_declare_typ__payload) = + fun projectee -> match projectee with | Sig_declare_typ _0 -> _0 +let (uu___is_Sig_let : sigelt' -> Prims.bool) = + fun projectee -> match projectee with | Sig_let _0 -> true | uu___ -> false +let (__proj__Sig_let__item___0 : sigelt' -> sigelt'__Sig_let__payload) = + fun projectee -> match projectee with | Sig_let _0 -> _0 +let (uu___is_Sig_assume : sigelt' -> Prims.bool) = + fun projectee -> + match projectee with | Sig_assume _0 -> true | uu___ -> false +let (__proj__Sig_assume__item___0 : sigelt' -> sigelt'__Sig_assume__payload) + = fun projectee -> match projectee with | Sig_assume _0 -> _0 +let (uu___is_Sig_new_effect : sigelt' -> Prims.bool) = + fun projectee -> + match projectee with | Sig_new_effect _0 -> true | uu___ -> false +let (__proj__Sig_new_effect__item___0 : sigelt' -> eff_decl) = + fun projectee -> match projectee with | Sig_new_effect _0 -> _0 +let (uu___is_Sig_sub_effect : sigelt' -> Prims.bool) = + fun projectee -> + match projectee with | Sig_sub_effect _0 -> true | uu___ -> false +let (__proj__Sig_sub_effect__item___0 : sigelt' -> sub_eff) = + fun projectee -> match projectee with | Sig_sub_effect _0 -> _0 +let (uu___is_Sig_effect_abbrev : sigelt' -> Prims.bool) = + fun projectee -> + match projectee with | Sig_effect_abbrev _0 -> true | uu___ -> false +let (__proj__Sig_effect_abbrev__item___0 : + sigelt' -> sigelt'__Sig_effect_abbrev__payload) = + fun projectee -> match projectee with | Sig_effect_abbrev _0 -> _0 +let (uu___is_Sig_pragma : sigelt' -> Prims.bool) = + fun projectee -> + match projectee with | Sig_pragma _0 -> true | uu___ -> false +let (__proj__Sig_pragma__item___0 : sigelt' -> pragma) = + fun projectee -> match projectee with | Sig_pragma _0 -> _0 +let (uu___is_Sig_splice : sigelt' -> Prims.bool) = + fun projectee -> + match projectee with | Sig_splice _0 -> true | uu___ -> false +let (__proj__Sig_splice__item___0 : sigelt' -> sigelt'__Sig_splice__payload) + = fun projectee -> match projectee with | Sig_splice _0 -> _0 +let (uu___is_Sig_polymonadic_bind : sigelt' -> Prims.bool) = + fun projectee -> + match projectee with | Sig_polymonadic_bind _0 -> true | uu___ -> false +let (__proj__Sig_polymonadic_bind__item___0 : + sigelt' -> sigelt'__Sig_polymonadic_bind__payload) = + fun projectee -> match projectee with | Sig_polymonadic_bind _0 -> _0 +let (uu___is_Sig_polymonadic_subcomp : sigelt' -> Prims.bool) = + fun projectee -> + match projectee with + | Sig_polymonadic_subcomp _0 -> true + | uu___ -> false +let (__proj__Sig_polymonadic_subcomp__item___0 : + sigelt' -> sigelt'__Sig_polymonadic_subcomp__payload) = + fun projectee -> match projectee with | Sig_polymonadic_subcomp _0 -> _0 +let (uu___is_Sig_fail : sigelt' -> Prims.bool) = + fun projectee -> + match projectee with | Sig_fail _0 -> true | uu___ -> false +let (__proj__Sig_fail__item___0 : sigelt' -> sigelt'__Sig_fail__payload) = + fun projectee -> match projectee with | Sig_fail _0 -> _0 +let (__proj__Mksigelt__item__sigel : sigelt -> sigelt') = + fun projectee -> + match projectee with + | { sigel; sigrng; sigquals; sigmeta; sigattrs; sigopens_and_abbrevs; + sigopts;_} -> sigel +let (__proj__Mksigelt__item__sigrng : + sigelt -> FStarC_Compiler_Range_Type.range) = + fun projectee -> + match projectee with + | { sigel; sigrng; sigquals; sigmeta; sigattrs; sigopens_and_abbrevs; + sigopts;_} -> sigrng +let (__proj__Mksigelt__item__sigquals : sigelt -> qualifier Prims.list) = + fun projectee -> + match projectee with + | { sigel; sigrng; sigquals; sigmeta; sigattrs; sigopens_and_abbrevs; + sigopts;_} -> sigquals +let (__proj__Mksigelt__item__sigmeta : sigelt -> sig_metadata) = + fun projectee -> + match projectee with + | { sigel; sigrng; sigquals; sigmeta; sigattrs; sigopens_and_abbrevs; + sigopts;_} -> sigmeta +let (__proj__Mksigelt__item__sigattrs : sigelt -> attribute Prims.list) = + fun projectee -> + match projectee with + | { sigel; sigrng; sigquals; sigmeta; sigattrs; sigopens_and_abbrevs; + sigopts;_} -> sigattrs +let (__proj__Mksigelt__item__sigopens_and_abbrevs : + sigelt -> + (open_module_or_namespace, module_abbrev) FStar_Pervasives.either + Prims.list) + = + fun projectee -> + match projectee with + | { sigel; sigrng; sigquals; sigmeta; sigattrs; sigopens_and_abbrevs; + sigopts;_} -> sigopens_and_abbrevs +let (__proj__Mksigelt__item__sigopts : + sigelt -> FStarC_VConfig.vconfig FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { sigel; sigrng; sigquals; sigmeta; sigattrs; sigopens_and_abbrevs; + sigopts;_} -> sigopts +type sigelts = sigelt Prims.list +type modul = + { + name: FStarC_Ident.lident ; + declarations: sigelts ; + is_interface: Prims.bool } +let (__proj__Mkmodul__item__name : modul -> FStarC_Ident.lident) = + fun projectee -> + match projectee with | { name; declarations; is_interface;_} -> name +let (__proj__Mkmodul__item__declarations : modul -> sigelts) = + fun projectee -> + match projectee with + | { name; declarations; is_interface;_} -> declarations +let (__proj__Mkmodul__item__is_interface : modul -> Prims.bool) = + fun projectee -> + match projectee with + | { name; declarations; is_interface;_} -> is_interface +let (mod_name : modul -> FStarC_Ident.lident) = fun m -> m.name +let (contains_reflectable : qualifier Prims.list -> Prims.bool) = + fun l -> + FStarC_Compiler_Util.for_some + (fun uu___ -> + match uu___ with | Reflectable uu___1 -> true | uu___1 -> false) l +let withinfo : 'a . 'a -> FStarC_Compiler_Range_Type.range -> 'a withinfo_t = + fun v -> fun r -> { v; p = r } +let withsort : 'a . 'a -> 'a withinfo_t = + fun v -> withinfo v FStarC_Compiler_Range_Type.dummyRange +let (order_bv : bv -> bv -> Prims.int) = fun x -> fun y -> x.index - y.index +let (bv_eq : bv -> bv -> Prims.bool) = + fun x -> fun y -> let uu___ = order_bv x y in uu___ = Prims.int_zero +let (order_ident : FStarC_Ident.ident -> FStarC_Ident.ident -> Prims.int) = + fun x -> + fun y -> + let uu___ = FStarC_Ident.string_of_id x in + let uu___1 = FStarC_Ident.string_of_id y in + FStarC_Compiler_String.compare uu___ uu___1 +let (order_fv : FStarC_Ident.lident -> FStarC_Ident.lident -> Prims.int) = + fun x -> + fun y -> + let uu___ = FStarC_Ident.string_of_lid x in + let uu___1 = FStarC_Ident.string_of_lid y in + FStarC_Compiler_String.compare uu___ uu___1 +let (range_of_lbname : lbname -> FStarC_Compiler_Range_Type.range) = + fun l -> + match l with + | FStar_Pervasives.Inl x -> FStarC_Ident.range_of_id x.ppname + | FStar_Pervasives.Inr fv1 -> FStarC_Ident.range_of_lid (fv1.fv_name).v +let (range_of_bv : bv -> FStarC_Compiler_Range_Type.range) = + fun x -> FStarC_Ident.range_of_id x.ppname +let (set_range_of_bv : bv -> FStarC_Compiler_Range_Type.range -> bv) = + fun x -> + fun r -> + let uu___ = FStarC_Ident.set_id_range r x.ppname in + { ppname = uu___; index = (x.index); sort = (x.sort) } +let (on_antiquoted : (term -> term) -> quoteinfo -> quoteinfo) = + fun f -> + fun qi -> + let uu___ = qi.antiquotations in + match uu___ with + | (s, aqs) -> + let aqs' = FStarC_Compiler_List.map f aqs in + { qkind = (qi.qkind); antiquotations = (s, aqs') } +let (lookup_aq : bv -> antiquotations -> term) = + fun bv1 -> + fun aq -> + try + (fun uu___ -> + match () with + | () -> + FStarC_Compiler_List.nth (FStar_Pervasives_Native.snd aq) + ((((FStarC_Compiler_List.length + (FStar_Pervasives_Native.snd aq)) + - Prims.int_one) + - bv1.index) + + (FStar_Pervasives_Native.fst aq))) () + with | uu___ -> failwith "antiquotation out of bounds" +type path = Prims.string Prims.list +type subst_t = subst_elt Prims.list +let deq_instance_from_cmp : + 'uuuuu . + ('uuuuu -> 'uuuuu -> FStarC_Compiler_Order.order) -> + 'uuuuu FStarC_Class_Deq.deq + = + fun f -> + { + FStarC_Class_Deq.op_Equals_Question = + (fun x -> + fun y -> let uu___ = f x y in FStarC_Compiler_Order.eq uu___) + } +let ord_instance_from_cmp : + 'uuuuu . + ('uuuuu -> 'uuuuu -> FStarC_Compiler_Order.order) -> + 'uuuuu FStarC_Class_Ord.ord + = + fun f -> + { + FStarC_Class_Ord.super = (deq_instance_from_cmp f); + FStarC_Class_Ord.cmp = f + } +let (order_univ_name : univ_name -> univ_name -> Prims.int) = + fun x -> + fun y -> + let uu___ = FStarC_Ident.string_of_id x in + let uu___1 = FStarC_Ident.string_of_id y in + FStarC_Compiler_String.compare uu___ uu___1 +let (deq_bv : bv FStarC_Class_Deq.deq) = + deq_instance_from_cmp + (fun x -> + fun y -> + let uu___ = order_bv x y in + FStarC_Compiler_Order.order_from_int uu___) +let (deq_ident : FStarC_Ident.ident FStarC_Class_Deq.deq) = + deq_instance_from_cmp + (fun x -> + fun y -> + let uu___ = order_ident x y in + FStarC_Compiler_Order.order_from_int uu___) +let (deq_fv : FStarC_Ident.lident FStarC_Class_Deq.deq) = + deq_instance_from_cmp + (fun x -> + fun y -> + let uu___ = order_fv x y in + FStarC_Compiler_Order.order_from_int uu___) +let (deq_univ_name : univ_name FStarC_Class_Deq.deq) = + deq_instance_from_cmp + (fun x -> + fun y -> + let uu___ = order_univ_name x y in + FStarC_Compiler_Order.order_from_int uu___) +let (deq_delta_depth : delta_depth FStarC_Class_Deq.deq) = + { FStarC_Class_Deq.op_Equals_Question = (fun x -> fun y -> x = y) } +let (ord_bv : bv FStarC_Class_Ord.ord) = + ord_instance_from_cmp + (fun x -> + fun y -> + let uu___ = order_bv x y in + FStarC_Compiler_Order.order_from_int uu___) +let (ord_ident : FStarC_Ident.ident FStarC_Class_Ord.ord) = + ord_instance_from_cmp + (fun x -> + fun y -> + let uu___ = order_ident x y in + FStarC_Compiler_Order.order_from_int uu___) +let (ord_fv : FStarC_Ident.lident FStarC_Class_Ord.ord) = + ord_instance_from_cmp + (fun x -> + fun y -> + let uu___ = order_fv x y in + FStarC_Compiler_Order.order_from_int uu___) +let syn : + 'uuuuu 'uuuuu1 'uuuuu2 . + 'uuuuu -> 'uuuuu1 -> ('uuuuu1 -> 'uuuuu -> 'uuuuu2) -> 'uuuuu2 + = fun p -> fun k -> fun f -> f k p +let mk_fvs : + 'uuuuu . + unit -> 'uuuuu FStar_Pervasives_Native.option FStarC_Compiler_Effect.ref + = fun uu___ -> FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None +let mk_uvs : + 'uuuuu . + unit -> 'uuuuu FStar_Pervasives_Native.option FStarC_Compiler_Effect.ref + = fun uu___ -> FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None +let (list_of_freenames : freenames -> bv Prims.list) = + fun fvs -> + FStarC_Class_Setlike.elems () + (Obj.magic (FStarC_Compiler_FlatSet.setlike_flat_set ord_bv)) + (Obj.magic fvs) +let mk : 'a . 'a -> FStarC_Compiler_Range_Type.range -> 'a syntax = + fun t -> + fun r -> + let uu___ = FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None in + let uu___1 = FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None in + { n = t; pos = r; vars = uu___; hash_code = uu___1 } +let (bv_to_tm : bv -> term) = + fun bv1 -> let uu___ = range_of_bv bv1 in mk (Tm_bvar bv1) uu___ +let (bv_to_name : bv -> term) = + fun bv1 -> let uu___ = range_of_bv bv1 in mk (Tm_name bv1) uu___ +let (binders_to_names : binders -> term Prims.list) = + fun bs -> FStarC_Compiler_List.map (fun b -> bv_to_name b.binder_bv) bs +let (mk_Tm_app : term -> args -> FStarC_Compiler_Range_Type.range -> term) = + fun t1 -> + fun args1 -> + fun p -> + match args1 with + | [] -> t1 + | uu___ -> mk (Tm_app { hd = t1; args = args1 }) p +let (mk_Tm_uinst : term -> universes -> term) = + fun t -> + fun us -> + match t.n with + | Tm_fvar uu___ -> + (match us with | [] -> t | us1 -> mk (Tm_uinst (t, us1)) t.pos) + | uu___ -> failwith "Unexpected universe instantiation" +let (extend_app_n : term -> args -> FStarC_Compiler_Range_Type.range -> term) + = + fun t -> + fun args' -> + fun r -> + match t.n with + | Tm_app { hd; args = args1;_} -> + mk_Tm_app hd (FStarC_Compiler_List.op_At args1 args') r + | uu___ -> mk_Tm_app t args' r +let (extend_app : term -> arg -> FStarC_Compiler_Range_Type.range -> term) = + fun t -> fun arg1 -> fun r -> extend_app_n t [arg1] r +let (mk_Tm_delayed : + (term * subst_ts) -> FStarC_Compiler_Range_Type.range -> term) = + fun lr -> + fun pos -> + mk + (Tm_delayed + { + tm1 = (FStar_Pervasives_Native.fst lr); + substs = (FStar_Pervasives_Native.snd lr) + }) pos +let (mk_Total : typ -> comp) = fun t -> mk (Total t) t.pos +let (mk_GTotal : typ -> comp) = fun t -> mk (GTotal t) t.pos +let (mk_Comp : comp_typ -> comp) = fun ct -> mk (Comp ct) (ct.result_typ).pos +let (mk_lb : + (lbname * univ_name Prims.list * FStarC_Ident.lident * typ * term * + attribute Prims.list * FStarC_Compiler_Range_Type.range) -> letbinding) + = + fun uu___ -> + match uu___ with + | (x, univs, eff, t, e, attrs, pos) -> + { + lbname = x; + lbunivs = univs; + lbtyp = t; + lbeff = eff; + lbdef = e; + lbattrs = attrs; + lbpos = pos + } +let (mk_Tac : typ -> comp) = + fun t -> + mk_Comp + { + comp_univs = [U_zero]; + effect_name = FStarC_Parser_Const.effect_Tac_lid; + result_typ = t; + effect_args = []; + flags = [SOMETRIVIAL; TRIVIAL_POSTCONDITION] + } +let (default_sigmeta : sig_metadata) = + { + sigmeta_active = true; + sigmeta_fact_db_ids = []; + sigmeta_admit = false; + sigmeta_spliced = false; + sigmeta_already_checked = false; + sigmeta_extension_data = [] + } +let (mk_sigelt : sigelt' -> sigelt) = + fun e -> + { + sigel = e; + sigrng = FStarC_Compiler_Range_Type.dummyRange; + sigquals = []; + sigmeta = default_sigmeta; + sigattrs = []; + sigopens_and_abbrevs = []; + sigopts = FStar_Pervasives_Native.None + } +let (mk_subst : subst_t -> subst_t) = fun s -> s +let (extend_subst : subst_elt -> subst_elt Prims.list -> subst_t) = + fun x -> fun s -> x :: s +let (argpos : arg -> FStarC_Compiler_Range_Type.range) = + fun x -> (FStar_Pervasives_Native.fst x).pos +let (tun : term) = mk Tm_unknown FStarC_Compiler_Range_Type.dummyRange +let (teff : term) = + mk (Tm_constant FStarC_Const.Const_effect) + FStarC_Compiler_Range_Type.dummyRange +let (is_teff : term -> Prims.bool) = + fun t -> + match t.n with + | Tm_constant (FStarC_Const.Const_effect) -> true + | uu___ -> false +let (is_type : term -> Prims.bool) = + fun t -> match t.n with | Tm_type uu___ -> true | uu___ -> false +let (null_id : FStarC_Ident.ident) = + FStarC_Ident.mk_ident ("_", FStarC_Compiler_Range_Type.dummyRange) +let (null_bv : term -> bv) = + fun k -> + let uu___ = FStarC_GenSym.next_id () in + { ppname = null_id; index = uu___; sort = k } +let (is_null_bv : bv -> Prims.bool) = + fun b -> + let uu___ = FStarC_Ident.string_of_id b.ppname in + let uu___1 = FStarC_Ident.string_of_id null_id in uu___ = uu___1 +let (is_null_binder : binder -> Prims.bool) = fun b -> is_null_bv b.binder_bv +let (range_of_ropt : + FStarC_Compiler_Range_Type.range FStar_Pervasives_Native.option -> + FStarC_Compiler_Range_Type.range) + = + fun uu___ -> + match uu___ with + | FStar_Pervasives_Native.None -> FStarC_Compiler_Range_Type.dummyRange + | FStar_Pervasives_Native.Some r -> r +let (gen_bv' : + FStarC_Ident.ident -> + FStarC_Compiler_Range_Type.range FStar_Pervasives_Native.option -> + typ -> bv) + = + fun id -> + fun r -> + fun t -> + let uu___ = FStarC_GenSym.next_id () in + { ppname = id; index = uu___; sort = t } +let (gen_bv : + Prims.string -> + FStarC_Compiler_Range_Type.range FStar_Pervasives_Native.option -> + typ -> bv) + = + fun s -> + fun r -> + fun t -> + let id = FStarC_Ident.mk_ident (s, (range_of_ropt r)) in + gen_bv' id r t +let (new_bv : + FStarC_Compiler_Range_Type.range FStar_Pervasives_Native.option -> + typ -> bv) + = fun ropt -> fun t -> gen_bv FStarC_Ident.reserved_prefix ropt t +let (freshen_bv : bv -> bv) = + fun bv1 -> + let uu___ = is_null_bv bv1 in + if uu___ + then + let uu___1 = + let uu___2 = range_of_bv bv1 in FStar_Pervasives_Native.Some uu___2 in + new_bv uu___1 bv1.sort + else + (let uu___2 = FStarC_GenSym.next_id () in + { ppname = (bv1.ppname); index = uu___2; sort = (bv1.sort) }) +let (mk_binder_with_attrs : + bv -> + bqual -> + positivity_qualifier FStar_Pervasives_Native.option -> + attribute Prims.list -> binder) + = + fun bv1 -> + fun aqual1 -> + fun pqual -> + fun attrs -> + { + binder_bv = bv1; + binder_qual = aqual1; + binder_positivity = pqual; + binder_attrs = attrs + } +let (mk_binder : bv -> binder) = + fun a -> + mk_binder_with_attrs a FStar_Pervasives_Native.None + FStar_Pervasives_Native.None [] +let (null_binder : term -> binder) = + fun t -> let uu___ = null_bv t in mk_binder uu___ +let (imp_tag : binder_qualifier) = Implicit false +let (iarg : term -> arg) = + fun t -> + (t, + (FStar_Pervasives_Native.Some + { aqual_implicit = true; aqual_attributes = [] })) +let (as_arg : term -> arg) = fun t -> (t, FStar_Pervasives_Native.None) +let (is_top_level : letbinding Prims.list -> Prims.bool) = + fun uu___ -> + match uu___ with + | { lbname = FStar_Pervasives.Inr uu___1; lbunivs = uu___2; + lbtyp = uu___3; lbeff = uu___4; lbdef = uu___5; lbattrs = uu___6; + lbpos = uu___7;_}::uu___8 -> true + | uu___1 -> false +let (freenames_of_binders : binders -> freenames) = + fun bs -> + let uu___ = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic (FStarC_Compiler_FlatSet.setlike_flat_set ord_bv)) ()) in + FStarC_Compiler_List.fold_right + (fun uu___2 -> + fun uu___1 -> + (fun b -> + fun out -> + Obj.magic + (FStarC_Class_Setlike.add () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set ord_bv)) + b.binder_bv (Obj.magic out))) uu___2 uu___1) bs uu___ +let (binders_of_list : bv Prims.list -> binders) = + fun fvs -> FStarC_Compiler_List.map (fun t -> mk_binder t) fvs +let (binders_of_freenames : freenames -> binders) = + fun fvs -> + let uu___ = + FStarC_Class_Setlike.elems () + (Obj.magic (FStarC_Compiler_FlatSet.setlike_flat_set ord_bv)) + (Obj.magic fvs) in + binders_of_list uu___ +let (is_bqual_implicit : bqual -> Prims.bool) = + fun uu___ -> + match uu___ with + | FStar_Pervasives_Native.Some (Implicit uu___1) -> true + | uu___1 -> false +let (is_aqual_implicit : aqual -> Prims.bool) = + fun uu___ -> + match uu___ with + | FStar_Pervasives_Native.Some + { aqual_implicit = b; aqual_attributes = uu___1;_} -> b + | uu___1 -> false +let (is_bqual_implicit_or_meta : bqual -> Prims.bool) = + fun uu___ -> + match uu___ with + | FStar_Pervasives_Native.Some (Implicit uu___1) -> true + | FStar_Pervasives_Native.Some (Meta uu___1) -> true + | uu___1 -> false +let (as_bqual_implicit : Prims.bool -> bqual) = + fun uu___ -> + if uu___ + then FStar_Pervasives_Native.Some imp_tag + else FStar_Pervasives_Native.None +let (as_aqual_implicit : Prims.bool -> aqual) = + fun uu___ -> + if uu___ + then + FStar_Pervasives_Native.Some + { aqual_implicit = true; aqual_attributes = [] } + else FStar_Pervasives_Native.None +let (pat_bvs : pat -> bv Prims.list) = + fun p -> + let rec aux b p1 = + match p1.v with + | Pat_dot_term uu___ -> b + | Pat_constant uu___ -> b + | Pat_var x -> x :: b + | Pat_cons (uu___, uu___1, pats) -> + FStarC_Compiler_List.fold_left + (fun b1 -> + fun uu___2 -> match uu___2 with | (p2, uu___3) -> aux b1 p2) b + pats in + let uu___ = aux [] p in FStarC_Compiler_List.rev uu___ +let (freshen_binder : binder -> binder) = + fun b -> + let uu___ = freshen_bv b.binder_bv in + { + binder_bv = uu___; + binder_qual = (b.binder_qual); + binder_positivity = (b.binder_positivity); + binder_attrs = (b.binder_attrs) + } +let (new_univ_name : + FStarC_Compiler_Range_Type.range FStar_Pervasives_Native.option -> + univ_name) + = + fun ropt -> + let id = FStarC_GenSym.next_id () in + let uu___ = + let uu___1 = + let uu___2 = FStarC_Compiler_Util.string_of_int id in + Prims.strcat FStarC_Ident.reserved_prefix uu___2 in + (uu___1, (range_of_ropt ropt)) in + FStarC_Ident.mk_ident uu___ +let (lbname_eq : + (bv, FStarC_Ident.lident) FStar_Pervasives.either -> + (bv, FStarC_Ident.lident) FStar_Pervasives.either -> Prims.bool) + = + fun l1 -> + fun l2 -> + match (l1, l2) with + | (FStar_Pervasives.Inl x, FStar_Pervasives.Inl y) -> bv_eq x y + | (FStar_Pervasives.Inr l, FStar_Pervasives.Inr m) -> + FStarC_Ident.lid_equals l m + | uu___ -> false +let (fv_eq : fv -> fv -> Prims.bool) = + fun fv1 -> + fun fv2 -> FStarC_Ident.lid_equals (fv1.fv_name).v (fv2.fv_name).v +let (fv_eq_lid : fv -> FStarC_Ident.lident -> Prims.bool) = + fun fv1 -> fun lid -> FStarC_Ident.lid_equals (fv1.fv_name).v lid +let (set_bv_range : bv -> FStarC_Compiler_Range_Type.range -> bv) = + fun bv1 -> + fun r -> + let uu___ = FStarC_Ident.set_id_range r bv1.ppname in + { ppname = uu___; index = (bv1.index); sort = (bv1.sort) } +let (lid_and_dd_as_fv : + FStarC_Ident.lident -> fv_qual FStar_Pervasives_Native.option -> fv) = + fun l -> + fun dq -> + let uu___ = + let uu___1 = FStarC_Ident.range_of_lid l in withinfo l uu___1 in + { fv_name = uu___; fv_qual = dq } +let (lid_as_fv : + FStarC_Ident.lident -> fv_qual FStar_Pervasives_Native.option -> fv) = + fun l -> + fun dq -> + let uu___ = + let uu___1 = FStarC_Ident.range_of_lid l in withinfo l uu___1 in + { fv_name = uu___; fv_qual = dq } +let (fv_to_tm : fv -> term) = + fun fv1 -> + let uu___ = FStarC_Ident.range_of_lid (fv1.fv_name).v in + mk (Tm_fvar fv1) uu___ +let (fvar_with_dd : + FStarC_Ident.lident -> fv_qual FStar_Pervasives_Native.option -> term) = + fun l -> fun dq -> let uu___ = lid_and_dd_as_fv l dq in fv_to_tm uu___ +let (fvar : + FStarC_Ident.lident -> fv_qual FStar_Pervasives_Native.option -> term) = + fun l -> fun dq -> let uu___ = lid_as_fv l dq in fv_to_tm uu___ +let (lid_of_fv : fv -> FStarC_Ident.lid) = fun fv1 -> (fv1.fv_name).v +let (range_of_fv : fv -> FStarC_Compiler_Range_Type.range) = + fun fv1 -> let uu___ = lid_of_fv fv1 in FStarC_Ident.range_of_lid uu___ +let (set_range_of_fv : fv -> FStarC_Compiler_Range_Type.range -> fv) = + fun fv1 -> + fun r -> + let uu___ = + let uu___1 = fv1.fv_name in + let uu___2 = + let uu___3 = lid_of_fv fv1 in FStarC_Ident.set_lid_range uu___3 r in + { v = uu___2; p = (uu___1.p) } in + { fv_name = uu___; fv_qual = (fv1.fv_qual) } +let (has_simple_attribute : term Prims.list -> Prims.string -> Prims.bool) = + fun l -> + fun s -> + FStarC_Compiler_List.existsb + (fun uu___ -> + match uu___ with + | { n = Tm_constant (FStarC_Const.Const_string (data, uu___1)); + pos = uu___2; vars = uu___3; hash_code = uu___4;_} when + data = s -> true + | uu___1 -> false) l +let rec (eq_pat : pat -> pat -> Prims.bool) = + fun p1 -> + fun p2 -> + match ((p1.v), (p2.v)) with + | (Pat_constant c1, Pat_constant c2) -> FStarC_Const.eq_const c1 c2 + | (Pat_cons (fv1, us1, as1), Pat_cons (fv2, us2, as2)) -> + let uu___ = + (fv_eq fv1 fv2) && + ((FStarC_Compiler_List.length as1) = + (FStarC_Compiler_List.length as2)) in + if uu___ + then + (FStarC_Compiler_List.forall2 + (fun uu___1 -> + fun uu___2 -> + match (uu___1, uu___2) with + | ((p11, b1), (p21, b2)) -> (b1 = b2) && (eq_pat p11 p21)) + as1 as2) + && + ((match (us1, us2) with + | (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None) -> true + | (FStar_Pervasives_Native.Some us11, + FStar_Pervasives_Native.Some us21) -> + (FStarC_Compiler_List.length us11) = + (FStarC_Compiler_List.length us21) + | uu___1 -> false)) + else false + | (Pat_var uu___, Pat_var uu___1) -> true + | (Pat_dot_term uu___, Pat_dot_term uu___1) -> true + | (uu___, uu___1) -> false +let (delta_constant : delta_depth) = Delta_constant_at_level Prims.int_zero +let (delta_equational : delta_depth) = + Delta_equational_at_level Prims.int_zero +let (fvconst : FStarC_Ident.lident -> fv) = + fun l -> lid_and_dd_as_fv l FStar_Pervasives_Native.None +let (tconst : FStarC_Ident.lident -> term) = + fun l -> + let uu___ = let uu___1 = fvconst l in Tm_fvar uu___1 in + mk uu___ FStarC_Compiler_Range_Type.dummyRange +let (tabbrev : FStarC_Ident.lident -> term) = + fun l -> + let uu___ = + let uu___1 = lid_and_dd_as_fv l FStar_Pervasives_Native.None in + Tm_fvar uu___1 in + mk uu___ FStarC_Compiler_Range_Type.dummyRange +let (tdataconstr : FStarC_Ident.lident -> term) = + fun l -> + let uu___ = lid_and_dd_as_fv l (FStar_Pervasives_Native.Some Data_ctor) in + fv_to_tm uu___ +let (t_unit : term) = tconst FStarC_Parser_Const.unit_lid +let (t_bool : term) = tconst FStarC_Parser_Const.bool_lid +let (t_int : term) = tconst FStarC_Parser_Const.int_lid +let (t_string : term) = tconst FStarC_Parser_Const.string_lid +let (t_exn : term) = tconst FStarC_Parser_Const.exn_lid +let (t_real : term) = tconst FStarC_Parser_Const.real_lid +let (t_float : term) = tconst FStarC_Parser_Const.float_lid +let (t_char : term) = tabbrev FStarC_Parser_Const.char_lid +let (t_range : term) = tconst FStarC_Parser_Const.range_lid +let (t___range : term) = tconst FStarC_Parser_Const.__range_lid +let (t_vconfig : term) = tconst FStarC_Parser_Const.vconfig_lid +let (t_term : term) = tconst FStarC_Parser_Const.term_lid +let (t_term_view : term) = tabbrev FStarC_Parser_Const.term_view_lid +let (t_order : term) = tconst FStarC_Parser_Const.order_lid +let (t_decls : term) = tabbrev FStarC_Parser_Const.decls_lid +let (t_binder : term) = tconst FStarC_Parser_Const.binder_lid +let (t_binders : term) = tconst FStarC_Parser_Const.binders_lid +let (t_bv : term) = tconst FStarC_Parser_Const.bv_lid +let (t_fv : term) = tconst FStarC_Parser_Const.fv_lid +let (t_norm_step : term) = tconst FStarC_Parser_Const.norm_step_lid +let (t_tac_of : term -> term -> term) = + fun a -> + fun b -> + let uu___ = + let uu___1 = tabbrev FStarC_Parser_Const.tac_lid in + mk_Tm_uinst uu___1 [U_zero; U_zero] in + let uu___1 = + let uu___2 = as_arg a in + let uu___3 = let uu___4 = as_arg b in [uu___4] in uu___2 :: uu___3 in + mk_Tm_app uu___ uu___1 FStarC_Compiler_Range_Type.dummyRange +let (t_tactic_of : term -> term) = + fun t -> + let uu___ = + let uu___1 = tabbrev FStarC_Parser_Const.tactic_lid in + mk_Tm_uinst uu___1 [U_zero] in + let uu___1 = let uu___2 = as_arg t in [uu___2] in + mk_Tm_app uu___ uu___1 FStarC_Compiler_Range_Type.dummyRange +let (t_tactic_unit : term) = t_tactic_of t_unit +let (t_list_of : term -> term) = + fun t -> + let uu___ = + let uu___1 = tabbrev FStarC_Parser_Const.list_lid in + mk_Tm_uinst uu___1 [U_zero] in + let uu___1 = let uu___2 = as_arg t in [uu___2] in + mk_Tm_app uu___ uu___1 FStarC_Compiler_Range_Type.dummyRange +let (t_option_of : term -> term) = + fun t -> + let uu___ = + let uu___1 = tabbrev FStarC_Parser_Const.option_lid in + mk_Tm_uinst uu___1 [U_zero] in + let uu___1 = let uu___2 = as_arg t in [uu___2] in + mk_Tm_app uu___ uu___1 FStarC_Compiler_Range_Type.dummyRange +let (t_tuple2_of : term -> term -> term) = + fun t1 -> + fun t2 -> + let uu___ = + let uu___1 = tabbrev FStarC_Parser_Const.lid_tuple2 in + mk_Tm_uinst uu___1 [U_zero; U_zero] in + let uu___1 = + let uu___2 = as_arg t1 in + let uu___3 = let uu___4 = as_arg t2 in [uu___4] in uu___2 :: uu___3 in + mk_Tm_app uu___ uu___1 FStarC_Compiler_Range_Type.dummyRange +let (t_tuple3_of : term -> term -> term -> term) = + fun t1 -> + fun t2 -> + fun t3 -> + let uu___ = + let uu___1 = tabbrev FStarC_Parser_Const.lid_tuple3 in + mk_Tm_uinst uu___1 [U_zero; U_zero; U_zero] in + let uu___1 = + let uu___2 = as_arg t1 in + let uu___3 = + let uu___4 = as_arg t2 in + let uu___5 = let uu___6 = as_arg t3 in [uu___6] in uu___4 :: + uu___5 in + uu___2 :: uu___3 in + mk_Tm_app uu___ uu___1 FStarC_Compiler_Range_Type.dummyRange +let (t_tuple4_of : term -> term -> term -> term -> term) = + fun t1 -> + fun t2 -> + fun t3 -> + fun t4 -> + let uu___ = + let uu___1 = tabbrev FStarC_Parser_Const.lid_tuple4 in + mk_Tm_uinst uu___1 [U_zero; U_zero; U_zero; U_zero] in + let uu___1 = + let uu___2 = as_arg t1 in + let uu___3 = + let uu___4 = as_arg t2 in + let uu___5 = + let uu___6 = as_arg t3 in + let uu___7 = let uu___8 = as_arg t4 in [uu___8] in uu___6 :: + uu___7 in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + mk_Tm_app uu___ uu___1 FStarC_Compiler_Range_Type.dummyRange +let (t_tuple5_of : term -> term -> term -> term -> term -> term) = + fun t1 -> + fun t2 -> + fun t3 -> + fun t4 -> + fun t5 -> + let uu___ = + let uu___1 = tabbrev FStarC_Parser_Const.lid_tuple5 in + mk_Tm_uinst uu___1 [U_zero; U_zero; U_zero; U_zero; U_zero] in + let uu___1 = + let uu___2 = as_arg t1 in + let uu___3 = + let uu___4 = as_arg t2 in + let uu___5 = + let uu___6 = as_arg t3 in + let uu___7 = + let uu___8 = as_arg t4 in + let uu___9 = let uu___10 = as_arg t5 in [uu___10] in + uu___8 :: uu___9 in + uu___6 :: uu___7 in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + mk_Tm_app uu___ uu___1 FStarC_Compiler_Range_Type.dummyRange +let (t_either_of : term -> term -> term) = + fun t1 -> + fun t2 -> + let uu___ = + let uu___1 = tabbrev FStarC_Parser_Const.either_lid in + mk_Tm_uinst uu___1 [U_zero; U_zero] in + let uu___1 = + let uu___2 = as_arg t1 in + let uu___3 = let uu___4 = as_arg t2 in [uu___4] in uu___2 :: uu___3 in + mk_Tm_app uu___ uu___1 FStarC_Compiler_Range_Type.dummyRange +let (t_sealed_of : term -> term) = + fun t -> + let uu___ = + let uu___1 = tabbrev FStarC_Parser_Const.sealed_lid in + mk_Tm_uinst uu___1 [U_zero] in + let uu___1 = let uu___2 = as_arg t in [uu___2] in + mk_Tm_app uu___ uu___1 FStarC_Compiler_Range_Type.dummyRange +let (t_erased_of : term -> term) = + fun t -> + let uu___ = + let uu___1 = tabbrev FStarC_Parser_Const.erased_lid in + mk_Tm_uinst uu___1 [U_zero] in + let uu___1 = let uu___2 = as_arg t in [uu___2] in + mk_Tm_app uu___ uu___1 FStarC_Compiler_Range_Type.dummyRange +let (unit_const_with_range : FStarC_Compiler_Range_Type.range -> term) = + fun r -> mk (Tm_constant FStarC_Const.Const_unit) r +let (unit_const : term) = + unit_const_with_range FStarC_Compiler_Range_Type.dummyRange +let (show_restriction : restriction FStarC_Class_Show.showable) = + { + FStarC_Class_Show.show = + (fun uu___ -> + match uu___ with + | Unrestricted -> "Unrestricted" + | AllowList allow_list -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + (FStarC_Class_Show.show_tuple2 + FStarC_Ident.showable_ident + (FStarC_Class_Show.show_option + FStarC_Ident.showable_ident))) allow_list in + Prims.strcat uu___2 ")" in + Prims.strcat "(AllowList " uu___1) + } +let (is_ident_allowed_by_restriction' : + FStarC_Ident.ident -> + restriction -> FStarC_Ident.ident FStar_Pervasives_Native.option) + = + fun id -> + fun uu___ -> + match uu___ with + | Unrestricted -> FStar_Pervasives_Native.Some id + | AllowList allow_list -> + let uu___1 = + FStarC_Compiler_List.find + (fun uu___2 -> + match uu___2 with + | (dest_id, renamed_id) -> + FStarC_Class_Deq.op_Equals_Question deq_univ_name + (FStarC_Compiler_Util.dflt dest_id renamed_id) id) + allow_list in + FStarC_Compiler_Util.map_opt uu___1 FStar_Pervasives_Native.fst +let (is_ident_allowed_by_restriction : + FStarC_Ident.ident -> + restriction -> FStarC_Ident.ident FStar_Pervasives_Native.option) + = + let debug = FStarC_Compiler_Debug.get_toggle "open_include_restrictions" in + fun id -> + fun restriction1 -> + let result = is_ident_allowed_by_restriction' id restriction1 in + (let uu___1 = FStarC_Compiler_Effect.op_Bang debug in + if uu___1 + then + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Class_Show.show FStarC_Ident.showable_ident id in + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Class_Show.show show_restriction restriction1 in + let uu___8 = + let uu___9 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_option + FStarC_Ident.showable_ident) result in + Prims.strcat ") = " uu___9 in + Prims.strcat uu___7 uu___8 in + Prims.strcat ", " uu___6 in + Prims.strcat uu___4 uu___5 in + Prims.strcat "is_ident_allowed_by_restriction(" uu___3 in + FStarC_Compiler_Util.print_endline uu___2 + else ()); + result +let has_range_syntax : 'a . unit -> 'a syntax FStarC_Class_HasRange.hasRange + = + fun uu___ -> + { + FStarC_Class_HasRange.pos = (fun t -> t.pos); + FStarC_Class_HasRange.setPos = + (fun r -> + fun t -> + { n = (t.n); pos = r; vars = (t.vars); hash_code = (t.hash_code) + }) + } +let has_range_withinfo : + 'a . unit -> 'a withinfo_t FStarC_Class_HasRange.hasRange = + fun uu___ -> + { + FStarC_Class_HasRange.pos = (fun t -> t.p); + FStarC_Class_HasRange.setPos = (fun r -> fun t -> { v = (t.v); p = r }) + } +let (has_range_sigelt : sigelt FStarC_Class_HasRange.hasRange) = + { + FStarC_Class_HasRange.pos = (fun t -> t.sigrng); + FStarC_Class_HasRange.setPos = + (fun r -> + fun t -> + { + sigel = (t.sigel); + sigrng = r; + sigquals = (t.sigquals); + sigmeta = (t.sigmeta); + sigattrs = (t.sigattrs); + sigopens_and_abbrevs = (t.sigopens_and_abbrevs); + sigopts = (t.sigopts) + }) + } +let (hasRange_fv : fv FStarC_Class_HasRange.hasRange) = + { + FStarC_Class_HasRange.pos = range_of_fv; + FStarC_Class_HasRange.setPos = (fun r -> fun f -> set_range_of_fv f r) + } +let (hasRange_bv : bv FStarC_Class_HasRange.hasRange) = + { + FStarC_Class_HasRange.pos = range_of_bv; + FStarC_Class_HasRange.setPos = (fun r -> fun f -> set_range_of_bv f r) + } +let (hasRange_binder : binder FStarC_Class_HasRange.hasRange) = + { + FStarC_Class_HasRange.pos = + (fun b -> FStarC_Class_HasRange.pos hasRange_bv b.binder_bv); + FStarC_Class_HasRange.setPos = + (fun r -> + fun b -> + let uu___ = FStarC_Class_HasRange.setPos hasRange_bv r b.binder_bv in + { + binder_bv = uu___; + binder_qual = (b.binder_qual); + binder_positivity = (b.binder_positivity); + binder_attrs = (b.binder_attrs) + }) + } +let (showable_lazy_kind : lazy_kind FStarC_Class_Show.showable) = + { + FStarC_Class_Show.show = + (fun uu___ -> + match uu___ with + | BadLazy -> "BadLazy" + | Lazy_bv -> "Lazy_bv" + | Lazy_namedv -> "Lazy_namedv" + | Lazy_binder -> "Lazy_binder" + | Lazy_optionstate -> "Lazy_optionstate" + | Lazy_fvar -> "Lazy_fvar" + | Lazy_comp -> "Lazy_comp" + | Lazy_env -> "Lazy_env" + | Lazy_proofstate -> "Lazy_proofstate" + | Lazy_goal -> "Lazy_goal" + | Lazy_sigelt -> "Lazy_sigelt" + | Lazy_letbinding -> "Lazy_letbinding" + | Lazy_uvar -> "Lazy_uvar" + | Lazy_universe -> "Lazy_universe" + | Lazy_universe_uvar -> "Lazy_universe_uvar" + | Lazy_issue -> "Lazy_issue" + | Lazy_doc -> "Lazy_doc" + | Lazy_ident -> "Lazy_ident" + | Lazy_tref -> "Lazy_tref" + | Lazy_embedding uu___1 -> "Lazy_embedding _" + | Lazy_extension s -> Prims.strcat "Lazy_extension " s + | uu___1 -> failwith "FIXME! lazy_kind_to_string must be complete") + } +let (deq_lazy_kind : lazy_kind FStarC_Class_Deq.deq) = + { + FStarC_Class_Deq.op_Equals_Question = + (fun k -> + fun k' -> + match (k, k') with + | (BadLazy, BadLazy) -> true + | (Lazy_bv, Lazy_bv) -> true + | (Lazy_namedv, Lazy_namedv) -> true + | (Lazy_binder, Lazy_binder) -> true + | (Lazy_optionstate, Lazy_optionstate) -> true + | (Lazy_fvar, Lazy_fvar) -> true + | (Lazy_comp, Lazy_comp) -> true + | (Lazy_env, Lazy_env) -> true + | (Lazy_proofstate, Lazy_proofstate) -> true + | (Lazy_goal, Lazy_goal) -> true + | (Lazy_sigelt, Lazy_sigelt) -> true + | (Lazy_letbinding, Lazy_letbinding) -> true + | (Lazy_uvar, Lazy_uvar) -> true + | (Lazy_universe, Lazy_universe) -> true + | (Lazy_universe_uvar, Lazy_universe_uvar) -> true + | (Lazy_issue, Lazy_issue) -> true + | (Lazy_ident, Lazy_ident) -> true + | (Lazy_doc, Lazy_doc) -> true + | (Lazy_tref, Lazy_tref) -> true + | (Lazy_extension s, Lazy_extension t) -> s = t + | (Lazy_embedding uu___, uu___1) -> false + | (uu___, Lazy_embedding uu___1) -> false + | uu___ -> false) + } +let (tagged_term : term FStarC_Class_Tagged.tagged) = + { + FStarC_Class_Tagged.tag_of = + (fun t -> + match t.n with + | Tm_bvar { ppname = uu___; index = uu___1; sort = uu___2;_} -> + "Tm_bvar" + | Tm_name { ppname = uu___; index = uu___1; sort = uu___2;_} -> + "Tm_name" + | Tm_fvar { fv_name = uu___; fv_qual = uu___1;_} -> "Tm_fvar" + | Tm_uinst (uu___, uu___1) -> "Tm_uinst" + | Tm_constant uu___ -> "Tm_constant" + | Tm_type uu___ -> "Tm_type" + | Tm_quoted + (uu___, { qkind = Quote_static; antiquotations = uu___1;_}) -> + "Tm_quoted(static)" + | Tm_quoted + (uu___, { qkind = Quote_dynamic; antiquotations = uu___1;_}) -> + "Tm_quoted(dynamic)" + | Tm_abs { bs = uu___; body = uu___1; rc_opt = uu___2;_} -> "Tm_abs" + | Tm_arrow { bs1 = uu___; comp = uu___1;_} -> "Tm_arrow" + | Tm_refine { b = uu___; phi = uu___1;_} -> "Tm_refine" + | Tm_app { hd = uu___; args = uu___1;_} -> "Tm_app" + | Tm_match + { scrutinee = uu___; ret_opt = uu___1; brs = uu___2; + rc_opt1 = uu___3;_} + -> "Tm_match" + | Tm_ascribed { tm = uu___; asc = uu___1; eff_opt = uu___2;_} -> + "Tm_ascribed" + | Tm_let { lbs = uu___; body1 = uu___1;_} -> "Tm_let" + | Tm_uvar (uu___, uu___1) -> "Tm_uvar" + | Tm_delayed { tm1 = uu___; substs = uu___1;_} -> "Tm_delayed" + | Tm_meta { tm2 = uu___; meta = uu___1;_} -> "Tm_meta" + | Tm_unknown -> "Tm_unknown" + | Tm_lazy + { blob = uu___; lkind = uu___1; ltyp = uu___2; rng = uu___3;_} + -> "Tm_lazy") + } +let (tagged_sigelt : sigelt FStarC_Class_Tagged.tagged) = + { + FStarC_Class_Tagged.tag_of = + (fun se -> + match se.sigel with + | Sig_inductive_typ + { lid = uu___; us = uu___1; params = uu___2; + num_uniform_params = uu___3; t = uu___4; mutuals = uu___5; + ds = uu___6; injective_type_params = uu___7;_} + -> "Sig_inductive_typ" + | Sig_bundle { ses = uu___; lids = uu___1;_} -> "Sig_bundle" + | Sig_datacon + { lid1 = uu___; us1 = uu___1; t1 = uu___2; ty_lid = uu___3; + num_ty_params = uu___4; mutuals1 = uu___5; + injective_type_params1 = uu___6;_} + -> "Sig_datacon" + | Sig_declare_typ { lid2 = uu___; us2 = uu___1; t2 = uu___2;_} -> + "Sig_declare_typ" + | Sig_let { lbs1 = uu___; lids1 = uu___1;_} -> "Sig_let" + | Sig_assume { lid3 = uu___; us3 = uu___1; phi1 = uu___2;_} -> + "Sig_assume" + | Sig_new_effect + { mname = uu___; cattributes = uu___1; univs = uu___2; + binders = uu___3; signature = uu___4; combinators = uu___5; + actions = uu___6; eff_attrs = uu___7; + extraction_mode = uu___8;_} + -> "Sig_new_effect" + | Sig_sub_effect + { source = uu___; target = uu___1; lift_wp = uu___2; + lift = uu___3; kind = uu___4;_} + -> "Sig_sub_effect" + | Sig_effect_abbrev + { lid4 = uu___; us4 = uu___1; bs2 = uu___2; comp1 = uu___3; + cflags = uu___4;_} + -> "Sig_effect_abbrev" + | Sig_pragma uu___ -> "Sig_pragma" + | Sig_splice { is_typed = uu___; lids2 = uu___1; tac = uu___2;_} -> + "Sig_splice" + | Sig_polymonadic_bind + { m_lid = uu___; n_lid = uu___1; p_lid = uu___2; tm3 = uu___3; + typ = uu___4; kind1 = uu___5;_} + -> "Sig_polymonadic_bind" + | Sig_polymonadic_subcomp + { m_lid1 = uu___; n_lid1 = uu___1; tm4 = uu___2; typ1 = uu___3; + kind2 = uu___4;_} + -> "Sig_polymonadic_subcomp" + | Sig_fail { errs = uu___; fail_in_lax = uu___1; ses1 = uu___2;_} -> + "Sig_fail") + } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Syntax_Unionfind.ml b/ocaml/fstar-lib/generated/FStarC_Syntax_Unionfind.ml new file mode 100644 index 00000000000..21623995bef --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Syntax_Unionfind.ml @@ -0,0 +1,418 @@ +open Prims +type vops_t = + { + next_major: unit -> FStarC_Syntax_Syntax.version ; + next_minor: unit -> FStarC_Syntax_Syntax.version } +let (__proj__Mkvops_t__item__next_major : + vops_t -> unit -> FStarC_Syntax_Syntax.version) = + fun projectee -> + match projectee with | { next_major; next_minor;_} -> next_major +let (__proj__Mkvops_t__item__next_minor : + vops_t -> unit -> FStarC_Syntax_Syntax.version) = + fun projectee -> + match projectee with | { next_major; next_minor;_} -> next_minor +let (vops : vops_t) = + let major = FStarC_Compiler_Util.mk_ref Prims.int_zero in + let minor = FStarC_Compiler_Util.mk_ref Prims.int_zero in + let next_major uu___ = + FStarC_Compiler_Effect.op_Colon_Equals minor Prims.int_zero; + (let uu___2 = + FStarC_Compiler_Util.incr major; FStarC_Compiler_Effect.op_Bang major in + { + FStarC_Syntax_Syntax.major = uu___2; + FStarC_Syntax_Syntax.minor = Prims.int_zero + }) in + let next_minor uu___ = + let uu___1 = FStarC_Compiler_Effect.op_Bang major in + let uu___2 = + FStarC_Compiler_Util.incr minor; FStarC_Compiler_Effect.op_Bang minor in + { + FStarC_Syntax_Syntax.major = uu___1; + FStarC_Syntax_Syntax.minor = uu___2 + } in + { next_major; next_minor } +type tgraph = + (FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option * + FStarC_Syntax_Syntax.uvar_decoration) FStarC_Unionfind.puf +type ugraph = + FStarC_Syntax_Syntax.universe FStar_Pervasives_Native.option + FStarC_Unionfind.puf +type uf = + { + term_graph: tgraph ; + univ_graph: ugraph ; + version: FStarC_Syntax_Syntax.version ; + ro: Prims.bool } +let (__proj__Mkuf__item__term_graph : uf -> tgraph) = + fun projectee -> + match projectee with + | { term_graph; univ_graph; version; ro;_} -> term_graph +let (__proj__Mkuf__item__univ_graph : uf -> ugraph) = + fun projectee -> + match projectee with + | { term_graph; univ_graph; version; ro;_} -> univ_graph +let (__proj__Mkuf__item__version : uf -> FStarC_Syntax_Syntax.version) = + fun projectee -> + match projectee with + | { term_graph; univ_graph; version; ro;_} -> version +let (__proj__Mkuf__item__ro : uf -> Prims.bool) = + fun projectee -> + match projectee with | { term_graph; univ_graph; version; ro;_} -> ro +let (empty : FStarC_Syntax_Syntax.version -> uf) = + fun v -> + let uu___ = FStarC_Unionfind.puf_empty () in + let uu___1 = FStarC_Unionfind.puf_empty () in + { term_graph = uu___; univ_graph = uu___1; version = v; ro = false } +let (version_to_string : FStarC_Syntax_Syntax.version -> Prims.string) = + fun v -> + let uu___ = + FStarC_Compiler_Util.string_of_int v.FStarC_Syntax_Syntax.major in + let uu___1 = + FStarC_Compiler_Util.string_of_int v.FStarC_Syntax_Syntax.minor in + FStarC_Compiler_Util.format2 "%s.%s" uu___ uu___1 +let (state : uf FStarC_Compiler_Effect.ref) = + let uu___ = let uu___1 = vops.next_major () in empty uu___1 in + FStarC_Compiler_Util.mk_ref uu___ +type tx = + | TX of uf +let (uu___is_TX : tx -> Prims.bool) = fun projectee -> true +let (__proj__TX__item___0 : tx -> uf) = + fun projectee -> match projectee with | TX _0 -> _0 +let (get : unit -> uf) = fun uu___ -> FStarC_Compiler_Effect.op_Bang state +let (set_ro : unit -> unit) = + fun uu___ -> + let s = get () in + FStarC_Compiler_Effect.op_Colon_Equals state + { + term_graph = (s.term_graph); + univ_graph = (s.univ_graph); + version = (s.version); + ro = true + } +let (set_rw : unit -> unit) = + fun uu___ -> + let s = get () in + FStarC_Compiler_Effect.op_Colon_Equals state + { + term_graph = (s.term_graph); + univ_graph = (s.univ_graph); + version = (s.version); + ro = false + } +let with_uf_enabled : 'a . (unit -> 'a) -> 'a = + fun f -> + let s = get () in + set_rw (); + (let restore uu___1 = if s.ro then set_ro () else () in + let r = + let uu___1 = FStarC_Options.trace_error () in + if uu___1 + then f () + else + (try (fun uu___3 -> match () with | () -> f ()) () + with | uu___3 -> (restore (); FStarC_Compiler_Effect.raise uu___3)) in + restore (); r) +let (fail_if_ro : unit -> unit) = + fun uu___ -> + let uu___1 = let uu___2 = get () in uu___2.ro in + if uu___1 + then + FStarC_Errors.raise_error0 FStarC_Errors_Codes.Fatal_BadUvar () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "Internal error: UF graph was in read-only mode") + else () +let (set : uf -> unit) = + fun u -> fail_if_ro (); FStarC_Compiler_Effect.op_Colon_Equals state u +let (reset : unit -> unit) = + fun uu___ -> + fail_if_ro (); + (let v = vops.next_major () in + let uu___2 = + let uu___3 = empty v in + { + term_graph = (uu___3.term_graph); + univ_graph = (uu___3.univ_graph); + version = (uu___3.version); + ro = false + } in + set uu___2) +let (new_transaction : unit -> tx) = + fun uu___ -> + let tx1 = let uu___1 = get () in TX uu___1 in + (let uu___2 = + let uu___3 = get () in + let uu___4 = vops.next_minor () in + { + term_graph = (uu___3.term_graph); + univ_graph = (uu___3.univ_graph); + version = uu___4; + ro = (uu___3.ro) + } in + set uu___2); + tx1 +let (commit : tx -> unit) = fun tx1 -> () +let (rollback : tx -> unit) = + fun uu___ -> match uu___ with | TX uf1 -> set uf1 +let update_in_tx : 'a . 'a FStarC_Compiler_Effect.ref -> 'a -> unit = + fun r -> fun x -> () +let (get_term_graph : unit -> tgraph) = + fun uu___ -> let uu___1 = get () in uu___1.term_graph +let (get_version : unit -> FStarC_Syntax_Syntax.version) = + fun uu___ -> let uu___1 = get () in uu___1.version +let (set_term_graph : tgraph -> unit) = + fun tg -> + let uu___ = + let uu___1 = get () in + { + term_graph = tg; + univ_graph = (uu___1.univ_graph); + version = (uu___1.version); + ro = (uu___1.ro) + } in + set uu___ +let (chk_v_t : + FStarC_Syntax_Syntax.uvar -> + (FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax + FStar_Pervasives_Native.option * FStarC_Syntax_Syntax.uvar_decoration) + FStarC_Unionfind.p_uvar) + = + fun su -> + let uu___ = su in + match uu___ with + | (u, v, rng) -> + let uvar_to_string u1 = + let uu___1 = + let uu___2 = FStarC_Unionfind.puf_unique_id u1 in + FStarC_Compiler_Util.string_of_int uu___2 in + Prims.strcat "?" uu___1 in + let expected = get_version () in + if + (v.FStarC_Syntax_Syntax.major = expected.FStarC_Syntax_Syntax.major) + && + (v.FStarC_Syntax_Syntax.minor <= + expected.FStarC_Syntax_Syntax.minor) + then u + else + (let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Errors_Msg.text + "Internal error: incompatible version for term unification variable" in + let uu___5 = + let uu___6 = uvar_to_string u in + FStarC_Pprint.doc_of_string uu___6 in + FStarC_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Errors_Msg.text "Current version: " in + let uu___7 = + let uu___8 = version_to_string expected in + FStarC_Pprint.doc_of_string uu___8 in + FStarC_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Errors_Msg.text "Got version: " in + let uu___9 = + let uu___10 = version_to_string v in + FStarC_Pprint.doc_of_string uu___10 in + FStarC_Pprint.op_Hat_Slash_Hat uu___8 uu___9 in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range rng + FStarC_Errors_Codes.Fatal_BadUvar () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___2)) +let (uvar_id : FStarC_Syntax_Syntax.uvar -> Prims.int) = + fun u -> + let uu___ = get_term_graph () in + let uu___1 = chk_v_t u in FStarC_Unionfind.puf_id uu___ uu___1 +let (uvar_unique_id : FStarC_Syntax_Syntax.uvar -> Prims.int) = + fun u -> let uu___ = chk_v_t u in FStarC_Unionfind.puf_unique_id uu___ +let (fresh : + FStarC_Syntax_Syntax.uvar_decoration -> + FStarC_Compiler_Range_Type.range -> FStarC_Syntax_Syntax.uvar) + = + fun decoration -> + fun rng -> + fail_if_ro (); + (let uu___1 = + let uu___2 = get_term_graph () in + FStarC_Unionfind.puf_fresh uu___2 + (FStar_Pervasives_Native.None, decoration) in + let uu___2 = get_version () in (uu___1, uu___2, rng)) +let (find_core : + FStarC_Syntax_Syntax.uvar -> + (FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option * + FStarC_Syntax_Syntax.uvar_decoration)) + = + fun u -> + let uu___ = get_term_graph () in + let uu___1 = chk_v_t u in FStarC_Unionfind.puf_find uu___ uu___1 +let (find : + FStarC_Syntax_Syntax.uvar -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = fun u -> let uu___ = find_core u in FStar_Pervasives_Native.fst uu___ +let (find_decoration : + FStarC_Syntax_Syntax.uvar -> FStarC_Syntax_Syntax.uvar_decoration) = + fun u -> let uu___ = find_core u in FStar_Pervasives_Native.snd uu___ +let (change : FStarC_Syntax_Syntax.uvar -> FStarC_Syntax_Syntax.term -> unit) + = + fun u -> + fun t -> + let uu___ = find_core u in + match uu___ with + | (uu___1, dec) -> + let uu___2 = + let uu___3 = get_term_graph () in + let uu___4 = chk_v_t u in + FStarC_Unionfind.puf_change uu___3 uu___4 + ((FStar_Pervasives_Native.Some t), dec) in + set_term_graph uu___2 +let (change_decoration : + FStarC_Syntax_Syntax.uvar -> FStarC_Syntax_Syntax.uvar_decoration -> unit) + = + fun u -> + fun d -> + let uu___ = find_core u in + match uu___ with + | (t, uu___1) -> + let uu___2 = + let uu___3 = get_term_graph () in + let uu___4 = chk_v_t u in + FStarC_Unionfind.puf_change uu___3 uu___4 (t, d) in + set_term_graph uu___2 +let (equiv : + FStarC_Syntax_Syntax.uvar -> FStarC_Syntax_Syntax.uvar -> Prims.bool) = + fun u -> + fun v -> + let uu___ = get_term_graph () in + let uu___1 = chk_v_t u in + let uu___2 = chk_v_t v in + FStarC_Unionfind.puf_equivalent uu___ uu___1 uu___2 +let (union : FStarC_Syntax_Syntax.uvar -> FStarC_Syntax_Syntax.uvar -> unit) + = + fun u -> + fun v -> + let uu___ = + let uu___1 = get_term_graph () in + let uu___2 = chk_v_t u in + let uu___3 = chk_v_t v in + FStarC_Unionfind.puf_union uu___1 uu___2 uu___3 in + set_term_graph uu___ +let (get_univ_graph : unit -> ugraph) = + fun uu___ -> let uu___1 = get () in uu___1.univ_graph +let chk_v_u : + 'uuuuu . + ('uuuuu FStarC_Unionfind.p_uvar * FStarC_Syntax_Syntax.version * + FStarC_Compiler_Range_Type.range) -> 'uuuuu FStarC_Unionfind.p_uvar + = + fun uu___ -> + match uu___ with + | (u, v, rng) -> + let uvar_to_string u1 = + let uu___1 = + let uu___2 = FStarC_Unionfind.puf_unique_id u1 in + FStarC_Compiler_Util.string_of_int uu___2 in + Prims.strcat "?" uu___1 in + let expected = get_version () in + if + (v.FStarC_Syntax_Syntax.major = expected.FStarC_Syntax_Syntax.major) + && + (v.FStarC_Syntax_Syntax.minor <= + expected.FStarC_Syntax_Syntax.minor) + then u + else + (let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Errors_Msg.text + "Internal error: incompatible version for universe unification variable" in + let uu___5 = + let uu___6 = uvar_to_string u in + FStarC_Pprint.doc_of_string uu___6 in + FStarC_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Errors_Msg.text "Current version: " in + let uu___7 = + let uu___8 = version_to_string expected in + FStarC_Pprint.doc_of_string uu___8 in + FStarC_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Errors_Msg.text "Got version: " in + let uu___9 = + let uu___10 = version_to_string v in + FStarC_Pprint.doc_of_string uu___10 in + FStarC_Pprint.op_Hat_Slash_Hat uu___8 uu___9 in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range rng + FStarC_Errors_Codes.Fatal_BadUvar () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___2)) +let (set_univ_graph : ugraph -> unit) = + fun ug -> + let uu___ = + let uu___1 = get () in + { + term_graph = (uu___1.term_graph); + univ_graph = ug; + version = (uu___1.version); + ro = (uu___1.ro) + } in + set uu___ +let (univ_uvar_id : FStarC_Syntax_Syntax.universe_uvar -> Prims.int) = + fun u -> + let uu___ = get_univ_graph () in + let uu___1 = chk_v_u u in FStarC_Unionfind.puf_id uu___ uu___1 +let (univ_fresh : + FStarC_Compiler_Range_Type.range -> FStarC_Syntax_Syntax.universe_uvar) = + fun rng -> + fail_if_ro (); + (let uu___1 = + let uu___2 = get_univ_graph () in + FStarC_Unionfind.puf_fresh uu___2 FStar_Pervasives_Native.None in + let uu___2 = get_version () in (uu___1, uu___2, rng)) +let (univ_find : + FStarC_Syntax_Syntax.universe_uvar -> + FStarC_Syntax_Syntax.universe FStar_Pervasives_Native.option) + = + fun u -> + let uu___ = get_univ_graph () in + let uu___1 = chk_v_u u in FStarC_Unionfind.puf_find uu___ uu___1 +let (univ_change : + FStarC_Syntax_Syntax.universe_uvar -> FStarC_Syntax_Syntax.universe -> unit) + = + fun u -> + fun t -> + let uu___ = + let uu___1 = get_univ_graph () in + let uu___2 = chk_v_u u in + FStarC_Unionfind.puf_change uu___1 uu___2 + (FStar_Pervasives_Native.Some t) in + set_univ_graph uu___ +let (univ_equiv : + FStarC_Syntax_Syntax.universe_uvar -> + FStarC_Syntax_Syntax.universe_uvar -> Prims.bool) + = + fun u -> + fun v -> + let uu___ = get_univ_graph () in + let uu___1 = chk_v_u u in + let uu___2 = chk_v_u v in + FStarC_Unionfind.puf_equivalent uu___ uu___1 uu___2 +let (univ_union : + FStarC_Syntax_Syntax.universe_uvar -> + FStarC_Syntax_Syntax.universe_uvar -> unit) + = + fun u -> + fun v -> + let uu___ = + let uu___1 = get_univ_graph () in + let uu___2 = chk_v_u u in + let uu___3 = chk_v_u v in + FStarC_Unionfind.puf_union uu___1 uu___2 uu___3 in + set_univ_graph uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Syntax_Util.ml b/ocaml/fstar-lib/generated/FStarC_Syntax_Util.ml new file mode 100644 index 00000000000..eb723624819 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Syntax_Util.ml @@ -0,0 +1,4747 @@ +open Prims +let (tts_f : + (FStarC_Syntax_Syntax.term -> Prims.string) FStar_Pervasives_Native.option + FStarC_Compiler_Effect.ref) + = FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None +let (tts : FStarC_Syntax_Syntax.term -> Prims.string) = + fun t -> + let uu___ = FStarC_Compiler_Effect.op_Bang tts_f in + match uu___ with + | FStar_Pervasives_Native.None -> "<>" + | FStar_Pervasives_Native.Some f -> f t +let (ttd_f : + (FStarC_Syntax_Syntax.term -> FStarC_Pprint.document) + FStar_Pervasives_Native.option FStarC_Compiler_Effect.ref) + = FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None +let (ttd : FStarC_Syntax_Syntax.term -> FStarC_Pprint.document) = + fun t -> + let uu___ = FStarC_Compiler_Effect.op_Bang ttd_f in + match uu___ with + | FStar_Pervasives_Native.None -> + FStarC_Pprint.doc_of_string "<>" + | FStar_Pervasives_Native.Some f -> f t +let (mk_discriminator : FStarC_Ident.lident -> FStarC_Ident.lident) = + fun lid -> + let uu___ = + let uu___1 = FStarC_Ident.ns_of_lid lid in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Ident.ident_of_lid lid in + FStarC_Ident.string_of_id uu___8 in + Prims.strcat "is_" uu___7 in + Prims.strcat FStarC_Ident.reserved_prefix uu___6 in + let uu___6 = FStarC_Ident.range_of_lid lid in (uu___5, uu___6) in + FStarC_Ident.mk_ident uu___4 in + [uu___3] in + FStarC_Compiler_List.op_At uu___1 uu___2 in + FStarC_Ident.lid_of_ids uu___ +let (is_name : FStarC_Ident.lident -> Prims.bool) = + fun lid -> + let c = + let uu___ = + let uu___1 = FStarC_Ident.ident_of_lid lid in + FStarC_Ident.string_of_id uu___1 in + FStarC_Compiler_Util.char_at uu___ Prims.int_zero in + FStarC_Compiler_Util.is_upper c +let (aqual_of_binder : + FStarC_Syntax_Syntax.binder -> FStarC_Syntax_Syntax.aqual) = + fun b -> + match ((b.FStarC_Syntax_Syntax.binder_qual), + (b.FStarC_Syntax_Syntax.binder_attrs)) + with + | (FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Implicit uu___), + uu___1) -> + FStar_Pervasives_Native.Some + { + FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = + (b.FStarC_Syntax_Syntax.binder_attrs) + } + | (FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Meta uu___), + uu___1) -> + FStar_Pervasives_Native.Some + { + FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = + (b.FStarC_Syntax_Syntax.binder_attrs) + } + | (uu___, uu___1::uu___2) -> + FStar_Pervasives_Native.Some + { + FStarC_Syntax_Syntax.aqual_implicit = false; + FStarC_Syntax_Syntax.aqual_attributes = + (b.FStarC_Syntax_Syntax.binder_attrs) + } + | uu___ -> FStar_Pervasives_Native.None +let (bqual_and_attrs_of_aqual : + FStarC_Syntax_Syntax.aqual -> + (FStarC_Syntax_Syntax.bqual * FStarC_Syntax_Syntax.attribute Prims.list)) + = + fun a -> + match a with + | FStar_Pervasives_Native.None -> (FStar_Pervasives_Native.None, []) + | FStar_Pervasives_Native.Some a1 -> + ((if a1.FStarC_Syntax_Syntax.aqual_implicit + then FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.imp_tag + else FStar_Pervasives_Native.None), + (a1.FStarC_Syntax_Syntax.aqual_attributes)) +let (arg_of_non_null_binder : + FStarC_Syntax_Syntax.binder -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.aqual)) + = + fun b -> + let uu___ = + FStarC_Syntax_Syntax.bv_to_name b.FStarC_Syntax_Syntax.binder_bv in + let uu___1 = aqual_of_binder b in (uu___, uu___1) +let (args_of_non_null_binders : + FStarC_Syntax_Syntax.binders -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.aqual) Prims.list) + = + fun binders -> + FStarC_Compiler_List.collect + (fun b -> + let uu___ = FStarC_Syntax_Syntax.is_null_binder b in + if uu___ + then [] + else (let uu___2 = arg_of_non_null_binder b in [uu___2])) binders +let (args_of_binders : + FStarC_Syntax_Syntax.binders -> + (FStarC_Syntax_Syntax.binders * FStarC_Syntax_Syntax.args)) + = + fun binders -> + let uu___ = + FStarC_Compiler_List.map + (fun b -> + let uu___1 = FStarC_Syntax_Syntax.is_null_binder b in + if uu___1 + then + let b1 = + let uu___2 = + FStarC_Syntax_Syntax.new_bv FStar_Pervasives_Native.None + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + { + FStarC_Syntax_Syntax.binder_bv = uu___2; + FStarC_Syntax_Syntax.binder_qual = + (b.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity = + (b.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs = + (b.FStarC_Syntax_Syntax.binder_attrs) + } in + let uu___2 = arg_of_non_null_binder b1 in (b1, uu___2) + else (let uu___3 = arg_of_non_null_binder b in (b, uu___3))) + binders in + FStarC_Compiler_List.unzip uu___ +let (name_binders : + FStarC_Syntax_Syntax.binder Prims.list -> + FStarC_Syntax_Syntax.binder Prims.list) + = + fun binders -> + FStarC_Compiler_List.mapi + (fun i -> + fun b -> + let uu___ = FStarC_Syntax_Syntax.is_null_binder b in + if uu___ + then + let bname = + let uu___1 = + let uu___2 = FStarC_Compiler_Util.string_of_int i in + Prims.strcat "_" uu___2 in + FStarC_Ident.id_of_text uu___1 in + let bv = + { + FStarC_Syntax_Syntax.ppname = bname; + FStarC_Syntax_Syntax.index = Prims.int_zero; + FStarC_Syntax_Syntax.sort = + ((b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort) + } in + { + FStarC_Syntax_Syntax.binder_bv = bv; + FStarC_Syntax_Syntax.binder_qual = + (b.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity = + (b.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs = + (b.FStarC_Syntax_Syntax.binder_attrs) + } + else b) binders +let (name_function_binders : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun t -> + match t.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = binders; + FStarC_Syntax_Syntax.comp = comp;_} + -> + let uu___ = + let uu___1 = + let uu___2 = name_binders binders in + { + FStarC_Syntax_Syntax.bs1 = uu___2; + FStarC_Syntax_Syntax.comp = comp + } in + FStarC_Syntax_Syntax.Tm_arrow uu___1 in + FStarC_Syntax_Syntax.mk uu___ t.FStarC_Syntax_Syntax.pos + | uu___ -> t +let (null_binders_of_tks : + (FStarC_Syntax_Syntax.typ * FStarC_Syntax_Syntax.bqual) Prims.list -> + FStarC_Syntax_Syntax.binders) + = + fun tks -> + FStarC_Compiler_List.map + (fun uu___ -> + match uu___ with + | (t, imp) -> + let uu___1 = FStarC_Syntax_Syntax.null_binder t in + { + FStarC_Syntax_Syntax.binder_bv = + (uu___1.FStarC_Syntax_Syntax.binder_bv); + FStarC_Syntax_Syntax.binder_qual = imp; + FStarC_Syntax_Syntax.binder_positivity = + (uu___1.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs = + (uu___1.FStarC_Syntax_Syntax.binder_attrs) + }) tks +let (binders_of_tks : + (FStarC_Syntax_Syntax.typ * FStarC_Syntax_Syntax.bqual) Prims.list -> + FStarC_Syntax_Syntax.binders) + = + fun tks -> + FStarC_Compiler_List.map + (fun uu___ -> + match uu___ with + | (t, imp) -> + let uu___1 = + FStarC_Syntax_Syntax.new_bv + (FStar_Pervasives_Native.Some (t.FStarC_Syntax_Syntax.pos)) + t in + FStarC_Syntax_Syntax.mk_binder_with_attrs uu___1 imp + FStar_Pervasives_Native.None []) tks +let mk_subst : 'uuuuu . 'uuuuu -> 'uuuuu Prims.list = fun s -> [s] +let (subst_of_list : + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.args -> FStarC_Syntax_Syntax.subst_t) + = + fun formals -> + fun actuals -> + if + (FStarC_Compiler_List.length formals) = + (FStarC_Compiler_List.length actuals) + then + FStarC_Compiler_List.fold_right2 + (fun f -> + fun a -> + fun out -> + (FStarC_Syntax_Syntax.NT + ((f.FStarC_Syntax_Syntax.binder_bv), + (FStar_Pervasives_Native.fst a))) + :: out) formals actuals [] + else failwith "Ill-formed substitution" +let (rename_binders : + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.binders -> FStarC_Syntax_Syntax.subst_t) + = + fun replace_xs -> + fun with_ys -> + if + (FStarC_Compiler_List.length replace_xs) = + (FStarC_Compiler_List.length with_ys) + then + FStarC_Compiler_List.map2 + (fun x -> + fun y -> + let uu___ = + let uu___1 = + FStarC_Syntax_Syntax.bv_to_name + y.FStarC_Syntax_Syntax.binder_bv in + ((x.FStarC_Syntax_Syntax.binder_bv), uu___1) in + FStarC_Syntax_Syntax.NT uu___) replace_xs with_ys + else failwith "Ill-formed substitution" +let rec (unmeta : FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) = + fun e -> + let e1 = FStarC_Syntax_Subst.compress e in + match e1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = e2; FStarC_Syntax_Syntax.meta = uu___;_} + -> unmeta e2 + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = e2; FStarC_Syntax_Syntax.asc = uu___; + FStarC_Syntax_Syntax.eff_opt = uu___1;_} + -> unmeta e2 + | uu___ -> e1 +let rec (unmeta_safe : + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) = + fun e -> + let e1 = FStarC_Syntax_Subst.compress e in + match e1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = e'; FStarC_Syntax_Syntax.meta = m;_} -> + (match m with + | FStarC_Syntax_Syntax.Meta_monadic uu___ -> e1 + | FStarC_Syntax_Syntax.Meta_monadic_lift uu___ -> e1 + | uu___ -> unmeta_safe e') + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = e2; FStarC_Syntax_Syntax.asc = uu___; + FStarC_Syntax_Syntax.eff_opt = uu___1;_} + -> unmeta_safe e2 + | uu___ -> e1 +let (unmeta_lift : FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) = + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t1; + FStarC_Syntax_Syntax.meta = FStarC_Syntax_Syntax.Meta_monadic_lift + uu___1;_} + -> t1 + | uu___1 -> t +let rec (univ_kernel : + FStarC_Syntax_Syntax.universe -> + (FStarC_Syntax_Syntax.universe * Prims.int)) + = + fun u -> + let uu___ = FStarC_Syntax_Subst.compress_univ u in + match uu___ with + | FStarC_Syntax_Syntax.U_unknown -> (u, Prims.int_zero) + | FStarC_Syntax_Syntax.U_name uu___1 -> (u, Prims.int_zero) + | FStarC_Syntax_Syntax.U_unif uu___1 -> (u, Prims.int_zero) + | FStarC_Syntax_Syntax.U_max uu___1 -> (u, Prims.int_zero) + | FStarC_Syntax_Syntax.U_zero -> (u, Prims.int_zero) + | FStarC_Syntax_Syntax.U_succ u1 -> + let uu___1 = univ_kernel u1 in + (match uu___1 with | (k, n) -> (k, (n + Prims.int_one))) + | FStarC_Syntax_Syntax.U_bvar i -> + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) i in + Prims.strcat uu___3 ")" in + Prims.strcat "Imposible: univ_kernel (U_bvar " uu___2 in + failwith uu___1 +let (constant_univ_as_nat : FStarC_Syntax_Syntax.universe -> Prims.int) = + fun u -> let uu___ = univ_kernel u in FStar_Pervasives_Native.snd uu___ +let rec (compare_univs : + FStarC_Syntax_Syntax.universe -> FStarC_Syntax_Syntax.universe -> Prims.int) + = + fun u1 -> + fun u2 -> + let rec compare_kernel uk1 uk2 = + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress_univ uk1 in + let uu___2 = FStarC_Syntax_Subst.compress_univ uk2 in + (uu___1, uu___2) in + match uu___ with + | (FStarC_Syntax_Syntax.U_bvar uu___1, uu___2) -> + failwith "Impossible: compare_kernel bvar" + | (uu___1, FStarC_Syntax_Syntax.U_bvar uu___2) -> + failwith "Impossible: compare_kernel bvar" + | (FStarC_Syntax_Syntax.U_succ uu___1, uu___2) -> + failwith "Impossible: compare_kernel succ" + | (uu___1, FStarC_Syntax_Syntax.U_succ uu___2) -> + failwith "Impossible: compare_kernel succ" + | (FStarC_Syntax_Syntax.U_unknown, FStarC_Syntax_Syntax.U_unknown) -> + Prims.int_zero + | (FStarC_Syntax_Syntax.U_unknown, uu___1) -> (Prims.of_int (-1)) + | (uu___1, FStarC_Syntax_Syntax.U_unknown) -> Prims.int_one + | (FStarC_Syntax_Syntax.U_zero, FStarC_Syntax_Syntax.U_zero) -> + Prims.int_zero + | (FStarC_Syntax_Syntax.U_zero, uu___1) -> (Prims.of_int (-1)) + | (uu___1, FStarC_Syntax_Syntax.U_zero) -> Prims.int_one + | (FStarC_Syntax_Syntax.U_name u11, FStarC_Syntax_Syntax.U_name u21) + -> + let uu___1 = FStarC_Ident.string_of_id u11 in + let uu___2 = FStarC_Ident.string_of_id u21 in + FStarC_Compiler_String.compare uu___1 uu___2 + | (FStarC_Syntax_Syntax.U_name uu___1, uu___2) -> (Prims.of_int (-1)) + | (uu___1, FStarC_Syntax_Syntax.U_name uu___2) -> Prims.int_one + | (FStarC_Syntax_Syntax.U_unif u11, FStarC_Syntax_Syntax.U_unif u21) + -> + let uu___1 = FStarC_Syntax_Unionfind.univ_uvar_id u11 in + let uu___2 = FStarC_Syntax_Unionfind.univ_uvar_id u21 in + uu___1 - uu___2 + | (FStarC_Syntax_Syntax.U_unif uu___1, uu___2) -> (Prims.of_int (-1)) + | (uu___1, FStarC_Syntax_Syntax.U_unif uu___2) -> Prims.int_one + | (FStarC_Syntax_Syntax.U_max us1, FStarC_Syntax_Syntax.U_max us2) -> + let n1 = FStarC_Compiler_List.length us1 in + let n2 = FStarC_Compiler_List.length us2 in + if n1 <> n2 + then n1 - n2 + else + (let copt = + let uu___2 = FStarC_Compiler_List.zip us1 us2 in + FStarC_Compiler_Util.find_map uu___2 + (fun uu___3 -> + match uu___3 with + | (u11, u21) -> + let c = compare_univs u11 u21 in + if c <> Prims.int_zero + then FStar_Pervasives_Native.Some c + else FStar_Pervasives_Native.None) in + match copt with + | FStar_Pervasives_Native.None -> Prims.int_zero + | FStar_Pervasives_Native.Some c -> c) in + let uu___ = univ_kernel u1 in + match uu___ with + | (uk1, n1) -> + let uu___1 = univ_kernel u2 in + (match uu___1 with + | (uk2, n2) -> + let uu___2 = compare_kernel uk1 uk2 in + (match uu___2 with + | uu___3 when uu___3 = Prims.int_zero -> n1 - n2 + | n -> n)) +let (eq_univs : + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.universe -> Prims.bool) + = + fun u1 -> + fun u2 -> let uu___ = compare_univs u1 u2 in uu___ = Prims.int_zero +let (eq_univs_list : + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.universes -> Prims.bool) + = + fun us -> + fun vs -> + ((FStarC_Compiler_List.length us) = (FStarC_Compiler_List.length vs)) + && (FStarC_Compiler_List.forall2 eq_univs us vs) +let (ml_comp : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Compiler_Range_Type.range -> FStarC_Syntax_Syntax.comp) + = + fun t -> + fun r -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Parser_Const.effect_ML_lid () in + FStarC_Ident.set_lid_range uu___2 r in + { + FStarC_Syntax_Syntax.comp_univs = [FStarC_Syntax_Syntax.U_zero]; + FStarC_Syntax_Syntax.effect_name = uu___1; + FStarC_Syntax_Syntax.result_typ = t; + FStarC_Syntax_Syntax.effect_args = []; + FStarC_Syntax_Syntax.flags = [FStarC_Syntax_Syntax.MLEFFECT] + } in + FStarC_Syntax_Syntax.mk_Comp uu___ +let (comp_effect_name : + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> + FStarC_Ident.lident) + = + fun c -> + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Comp c1 -> c1.FStarC_Syntax_Syntax.effect_name + | FStarC_Syntax_Syntax.Total uu___ -> FStarC_Parser_Const.effect_Tot_lid + | FStarC_Syntax_Syntax.GTotal uu___ -> + FStarC_Parser_Const.effect_GTot_lid +let (comp_flags : + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.cflag Prims.list) + = + fun c -> + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total uu___ -> [FStarC_Syntax_Syntax.TOTAL] + | FStarC_Syntax_Syntax.GTotal uu___ -> [FStarC_Syntax_Syntax.SOMETRIVIAL] + | FStarC_Syntax_Syntax.Comp ct -> ct.FStarC_Syntax_Syntax.flags +let (comp_eff_name_res_and_args : + FStarC_Syntax_Syntax.comp -> + (FStarC_Ident.lident * FStarC_Syntax_Syntax.typ * + FStarC_Syntax_Syntax.args)) + = + fun c -> + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total t -> + (FStarC_Parser_Const.effect_Tot_lid, t, []) + | FStarC_Syntax_Syntax.GTotal t -> + (FStarC_Parser_Const.effect_GTot_lid, t, []) + | FStarC_Syntax_Syntax.Comp c1 -> + ((c1.FStarC_Syntax_Syntax.effect_name), + (c1.FStarC_Syntax_Syntax.result_typ), + (c1.FStarC_Syntax_Syntax.effect_args)) +let (effect_indices_from_repr : + FStarC_Syntax_Syntax.term -> + Prims.bool -> + FStarC_Compiler_Range_Type.range -> + Prims.string -> FStarC_Syntax_Syntax.term Prims.list) + = + fun repr -> + fun is_layered -> + fun r -> + fun err -> + let err1 uu___ = + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_UnexpectedEffect () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic err) in + let repr1 = FStarC_Syntax_Subst.compress repr in + if is_layered + then + match repr1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = uu___; + FStarC_Syntax_Syntax.args = uu___1::is;_} + -> FStarC_Compiler_List.map FStar_Pervasives_Native.fst is + | uu___ -> err1 () + else + (match repr1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = uu___1; + FStarC_Syntax_Syntax.comp = c;_} + -> + let uu___2 = comp_eff_name_res_and_args c in + (match uu___2 with + | (uu___3, uu___4, args) -> + FStarC_Compiler_List.map FStar_Pervasives_Native.fst + args) + | uu___1 -> err1 ()) +let (destruct_comp : + FStarC_Syntax_Syntax.comp_typ -> + (FStarC_Syntax_Syntax.universe * FStarC_Syntax_Syntax.typ * + FStarC_Syntax_Syntax.typ)) + = + fun c -> + let wp = + match c.FStarC_Syntax_Syntax.effect_args with + | (wp1, uu___)::[] -> wp1 + | uu___ -> + let uu___1 = + let uu___2 = + FStarC_Ident.string_of_lid c.FStarC_Syntax_Syntax.effect_name in + let uu___3 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length + c.FStarC_Syntax_Syntax.effect_args) in + FStarC_Compiler_Util.format2 + "Impossible: Got a computation %s with %s effect args" uu___2 + uu___3 in + failwith uu___1 in + let uu___ = FStarC_Compiler_List.hd c.FStarC_Syntax_Syntax.comp_univs in + (uu___, (c.FStarC_Syntax_Syntax.result_typ), wp) +let (is_named_tot : + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> Prims.bool) = + fun c -> + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Comp c1 -> + FStarC_Ident.lid_equals c1.FStarC_Syntax_Syntax.effect_name + FStarC_Parser_Const.effect_Tot_lid + | FStarC_Syntax_Syntax.Total uu___ -> true + | FStarC_Syntax_Syntax.GTotal uu___ -> false +let (is_total_comp : + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> Prims.bool) = + fun c -> + (FStarC_Ident.lid_equals (comp_effect_name c) + FStarC_Parser_Const.effect_Tot_lid) + || + (FStarC_Compiler_Util.for_some + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.TOTAL -> true + | FStarC_Syntax_Syntax.RETURN -> true + | uu___1 -> false) (comp_flags c)) +let (is_partial_return : + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> Prims.bool) = + fun c -> + FStarC_Compiler_Util.for_some + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.RETURN -> true + | FStarC_Syntax_Syntax.PARTIAL_RETURN -> true + | uu___1 -> false) (comp_flags c) +let (is_tot_or_gtot_comp : + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> Prims.bool) = + fun c -> + (is_total_comp c) || + (FStarC_Ident.lid_equals FStarC_Parser_Const.effect_GTot_lid + (comp_effect_name c)) +let (is_pure_effect : FStarC_Ident.lident -> Prims.bool) = + fun l -> + ((FStarC_Ident.lid_equals l FStarC_Parser_Const.effect_Tot_lid) || + (FStarC_Ident.lid_equals l FStarC_Parser_Const.effect_PURE_lid)) + || (FStarC_Ident.lid_equals l FStarC_Parser_Const.effect_Pure_lid) +let (is_pure_comp : + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> Prims.bool) = + fun c -> + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total uu___ -> true + | FStarC_Syntax_Syntax.GTotal uu___ -> false + | FStarC_Syntax_Syntax.Comp ct -> + ((is_total_comp c) || + (is_pure_effect ct.FStarC_Syntax_Syntax.effect_name)) + || + (FStarC_Compiler_Util.for_some + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.LEMMA -> true + | uu___1 -> false) ct.FStarC_Syntax_Syntax.flags) +let (is_ghost_effect : FStarC_Ident.lident -> Prims.bool) = + fun l -> + ((FStarC_Ident.lid_equals FStarC_Parser_Const.effect_GTot_lid l) || + (FStarC_Ident.lid_equals FStarC_Parser_Const.effect_GHOST_lid l)) + || (FStarC_Ident.lid_equals FStarC_Parser_Const.effect_Ghost_lid l) +let (is_div_effect : FStarC_Ident.lident -> Prims.bool) = + fun l -> + ((FStarC_Ident.lid_equals l FStarC_Parser_Const.effect_DIV_lid) || + (FStarC_Ident.lid_equals l FStarC_Parser_Const.effect_Div_lid)) + || (FStarC_Ident.lid_equals l FStarC_Parser_Const.effect_Dv_lid) +let (is_pure_or_ghost_comp : + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> Prims.bool) = + fun c -> (is_pure_comp c) || (is_ghost_effect (comp_effect_name c)) +let (is_pure_or_ghost_effect : FStarC_Ident.lident -> Prims.bool) = + fun l -> (is_pure_effect l) || (is_ghost_effect l) +let (is_pure_or_ghost_function : FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = uu___1; FStarC_Syntax_Syntax.comp = c;_} + -> is_pure_or_ghost_comp c + | uu___1 -> true +let (is_lemma_comp : + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> Prims.bool) = + fun c -> + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Comp ct -> + FStarC_Ident.lid_equals ct.FStarC_Syntax_Syntax.effect_name + FStarC_Parser_Const.effect_Lemma_lid + | uu___ -> false +let (is_lemma : FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = uu___1; FStarC_Syntax_Syntax.comp = c;_} + -> is_lemma_comp c + | uu___1 -> false +let rec (head_of : FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) = + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = t1; FStarC_Syntax_Syntax.args = uu___1;_} + -> head_of t1 + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = t1; + FStarC_Syntax_Syntax.ret_opt = uu___1; + FStarC_Syntax_Syntax.brs = uu___2; + FStarC_Syntax_Syntax.rc_opt1 = uu___3;_} + -> head_of t1 + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = uu___1; FStarC_Syntax_Syntax.body = t1; + FStarC_Syntax_Syntax.rc_opt = uu___2;_} + -> head_of t1 + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t1; FStarC_Syntax_Syntax.asc = uu___1; + FStarC_Syntax_Syntax.eff_opt = uu___2;_} + -> head_of t1 + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t1; + FStarC_Syntax_Syntax.meta = uu___1;_} + -> head_of t1 + | uu___1 -> t +let (head_and_args : + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax * + (FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax * + FStarC_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) + Prims.list)) + = + fun t -> + let t1 = FStarC_Syntax_Subst.compress t in + match t1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head; FStarC_Syntax_Syntax.args = args;_} + -> (head, args) + | uu___ -> (t1, []) +let rec (__head_and_args_full : + (FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax * + FStarC_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) + Prims.list -> + Prims.bool -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * (FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax * FStarC_Syntax_Syntax.arg_qualifier + FStar_Pervasives_Native.option) Prims.list)) + = + fun acc -> + fun unmeta1 -> + fun t -> + let t1 = FStarC_Syntax_Subst.compress t in + match t1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = args;_} + -> + __head_and_args_full (FStarC_Compiler_List.op_At args acc) + unmeta1 head + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = tm; + FStarC_Syntax_Syntax.meta = uu___;_} + when unmeta1 -> __head_and_args_full acc unmeta1 tm + | uu___ -> (t1, acc) +let (head_and_args_full : + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * (FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax * FStarC_Syntax_Syntax.arg_qualifier + FStar_Pervasives_Native.option) Prims.list)) + = fun t -> __head_and_args_full [] false t +let (head_and_args_full_unmeta : + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * (FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax * FStarC_Syntax_Syntax.arg_qualifier + FStar_Pervasives_Native.option) Prims.list)) + = fun t -> __head_and_args_full [] true t +let rec (leftmost_head : + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) = + fun t -> + let t1 = FStarC_Syntax_Subst.compress t in + match t1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = t0; FStarC_Syntax_Syntax.args = uu___;_} + -> leftmost_head t0 + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t0; + FStarC_Syntax_Syntax.meta = FStarC_Syntax_Syntax.Meta_pattern uu___;_} + -> leftmost_head t0 + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t0; + FStarC_Syntax_Syntax.meta = FStarC_Syntax_Syntax.Meta_named uu___;_} + -> leftmost_head t0 + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t0; + FStarC_Syntax_Syntax.meta = FStarC_Syntax_Syntax.Meta_labeled uu___;_} + -> leftmost_head t0 + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t0; + FStarC_Syntax_Syntax.meta = FStarC_Syntax_Syntax.Meta_desugared + uu___;_} + -> leftmost_head t0 + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t0; FStarC_Syntax_Syntax.asc = uu___; + FStarC_Syntax_Syntax.eff_opt = uu___1;_} + -> leftmost_head t0 + | uu___ -> t1 +let (leftmost_head_and_args : + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * (FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax * FStarC_Syntax_Syntax.arg_qualifier + FStar_Pervasives_Native.option) Prims.list)) + = + fun t -> + let rec aux t1 args = + let t2 = FStarC_Syntax_Subst.compress t1 in + match t2.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = t0; + FStarC_Syntax_Syntax.args = args';_} + -> aux t0 (FStarC_Compiler_List.op_At args' args) + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t0; + FStarC_Syntax_Syntax.meta = FStarC_Syntax_Syntax.Meta_pattern + uu___;_} + -> aux t0 args + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t0; + FStarC_Syntax_Syntax.meta = FStarC_Syntax_Syntax.Meta_named uu___;_} + -> aux t0 args + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t0; + FStarC_Syntax_Syntax.meta = FStarC_Syntax_Syntax.Meta_labeled + uu___;_} + -> aux t0 args + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t0; + FStarC_Syntax_Syntax.meta = FStarC_Syntax_Syntax.Meta_desugared + uu___;_} + -> aux t0 args + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t0; FStarC_Syntax_Syntax.asc = uu___; + FStarC_Syntax_Syntax.eff_opt = uu___1;_} + -> aux t0 args + | uu___ -> (t2, args) in + aux t [] +let (un_uinst : FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) = + fun t -> + let t1 = FStarC_Syntax_Subst.compress t in + match t1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_uinst (t2, uu___) -> + FStarC_Syntax_Subst.compress t2 + | uu___ -> t1 +let (is_ml_comp : + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> Prims.bool) = + fun c -> + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Comp c1 -> + (let uu___ = FStarC_Parser_Const.effect_ML_lid () in + FStarC_Ident.lid_equals c1.FStarC_Syntax_Syntax.effect_name uu___) + || + (FStarC_Compiler_Util.for_some + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.MLEFFECT -> true + | uu___1 -> false) c1.FStarC_Syntax_Syntax.flags) + | uu___ -> false +let (comp_result : + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun c -> + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total t -> t + | FStarC_Syntax_Syntax.GTotal t -> t + | FStarC_Syntax_Syntax.Comp ct -> ct.FStarC_Syntax_Syntax.result_typ +let (set_result_typ : + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.comp) + = + fun c -> + fun t -> + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total uu___ -> FStarC_Syntax_Syntax.mk_Total t + | FStarC_Syntax_Syntax.GTotal uu___ -> FStarC_Syntax_Syntax.mk_GTotal t + | FStarC_Syntax_Syntax.Comp ct -> + FStarC_Syntax_Syntax.mk_Comp + { + FStarC_Syntax_Syntax.comp_univs = + (ct.FStarC_Syntax_Syntax.comp_univs); + FStarC_Syntax_Syntax.effect_name = + (ct.FStarC_Syntax_Syntax.effect_name); + FStarC_Syntax_Syntax.result_typ = t; + FStarC_Syntax_Syntax.effect_args = + (ct.FStarC_Syntax_Syntax.effect_args); + FStarC_Syntax_Syntax.flags = (ct.FStarC_Syntax_Syntax.flags) + } +let (is_trivial_wp : + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> Prims.bool) = + fun c -> + FStarC_Compiler_Util.for_some + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.TOTAL -> true + | FStarC_Syntax_Syntax.RETURN -> true + | uu___1 -> false) (comp_flags c) +let (comp_effect_args : + FStarC_Syntax_Syntax.comp -> FStarC_Syntax_Syntax.args) = + fun c -> + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total uu___ -> [] + | FStarC_Syntax_Syntax.GTotal uu___ -> [] + | FStarC_Syntax_Syntax.Comp ct -> ct.FStarC_Syntax_Syntax.effect_args +let (primops : FStarC_Ident.lident Prims.list) = + [FStarC_Parser_Const.op_Eq; + FStarC_Parser_Const.op_notEq; + FStarC_Parser_Const.op_LT; + FStarC_Parser_Const.op_LTE; + FStarC_Parser_Const.op_GT; + FStarC_Parser_Const.op_GTE; + FStarC_Parser_Const.op_Subtraction; + FStarC_Parser_Const.op_Minus; + FStarC_Parser_Const.op_Addition; + FStarC_Parser_Const.op_Multiply; + FStarC_Parser_Const.op_Division; + FStarC_Parser_Const.op_Modulus; + FStarC_Parser_Const.op_And; + FStarC_Parser_Const.op_Or; + FStarC_Parser_Const.op_Negation] +let (is_primop_lid : FStarC_Ident.lident -> Prims.bool) = + fun l -> FStarC_Compiler_Util.for_some (FStarC_Ident.lid_equals l) primops +let (is_primop : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> Prims.bool) = + fun f -> + match f.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + is_primop_lid + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + | uu___ -> false +let rec (unascribe : FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun e -> + let e1 = FStarC_Syntax_Subst.compress e in + match e1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = e2; FStarC_Syntax_Syntax.asc = uu___; + FStarC_Syntax_Syntax.eff_opt = uu___1;_} + -> unascribe e2 + | uu___ -> e1 +let rec (ascribe : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + ((FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax, + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax) + FStar_Pervasives.either * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax FStar_Pervasives_Native.option * + Prims.bool) -> FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun t -> + fun k -> + match t.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t'; FStarC_Syntax_Syntax.asc = uu___; + FStarC_Syntax_Syntax.eff_opt = uu___1;_} + -> ascribe t' k + | uu___ -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_ascribed + { + FStarC_Syntax_Syntax.tm = t; + FStarC_Syntax_Syntax.asc = k; + FStarC_Syntax_Syntax.eff_opt = FStar_Pervasives_Native.None + }) t.FStarC_Syntax_Syntax.pos +let (unfold_lazy : + FStarC_Syntax_Syntax.lazyinfo -> FStarC_Syntax_Syntax.term) = + fun i -> + let uu___ = + let uu___1 = + FStarC_Compiler_Effect.op_Bang FStarC_Syntax_Syntax.lazy_chooser in + FStarC_Compiler_Util.must uu___1 in + uu___ i.FStarC_Syntax_Syntax.lkind i +let rec (unlazy : FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) = + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_lazy i -> + let uu___1 = unfold_lazy i in unlazy uu___1 + | uu___1 -> t +let (unlazy_emb : FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) = + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_lazy i -> + (match i.FStarC_Syntax_Syntax.lkind with + | FStarC_Syntax_Syntax.Lazy_embedding uu___1 -> + let uu___2 = unfold_lazy i in unlazy uu___2 + | uu___1 -> t) + | uu___1 -> t +let unlazy_as_t : + 'uuuuu . + FStarC_Syntax_Syntax.lazy_kind -> FStarC_Syntax_Syntax.term -> 'uuuuu + = + fun k -> + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_lazy + { FStarC_Syntax_Syntax.blob = v; FStarC_Syntax_Syntax.lkind = k'; + FStarC_Syntax_Syntax.ltyp = uu___1; + FStarC_Syntax_Syntax.rng = uu___2;_} + -> + let uu___3 = + FStarC_Class_Deq.op_Equals_Question + FStarC_Syntax_Syntax.deq_lazy_kind k k' in + if uu___3 + then FStarC_Dyn.undyn v + else + (let uu___5 = + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Syntax.showable_lazy_kind k in + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Syntax.showable_lazy_kind k' in + FStarC_Compiler_Util.format2 + "Expected Tm_lazy of kind %s, got %s" uu___6 uu___7 in + failwith uu___5) + | uu___1 -> failwith "Not a Tm_lazy of the expected kind" +let mk_lazy : + 'a . + 'a -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.lazy_kind -> + FStarC_Compiler_Range_Type.range FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.term + = + fun t -> + fun typ -> + fun k -> + fun r -> + let rng = + match r with + | FStar_Pervasives_Native.Some r1 -> r1 + | FStar_Pervasives_Native.None -> + FStarC_Compiler_Range_Type.dummyRange in + let i = + let uu___ = FStarC_Dyn.mkdyn t in + { + FStarC_Syntax_Syntax.blob = uu___; + FStarC_Syntax_Syntax.lkind = k; + FStarC_Syntax_Syntax.ltyp = typ; + FStarC_Syntax_Syntax.rng = rng + } in + FStarC_Syntax_Syntax.mk (FStarC_Syntax_Syntax.Tm_lazy i) rng +let (canon_app : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term) + = + fun t -> + let uu___ = let uu___1 = unascribe t in head_and_args_full uu___1 in + match uu___ with + | (hd, args) -> + FStarC_Syntax_Syntax.mk_Tm_app hd args t.FStarC_Syntax_Syntax.pos +let rec (unrefine : FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) = + fun t -> + let t1 = FStarC_Syntax_Subst.compress t in + match t1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x; FStarC_Syntax_Syntax.phi = uu___;_} -> + unrefine x.FStarC_Syntax_Syntax.sort + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t2; FStarC_Syntax_Syntax.asc = uu___; + FStarC_Syntax_Syntax.eff_opt = uu___1;_} + -> unrefine t2 + | uu___ -> t1 +let rec (is_uvar : FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_uvar uu___1 -> true + | FStarC_Syntax_Syntax.Tm_uinst (t1, uu___1) -> is_uvar t1 + | FStarC_Syntax_Syntax.Tm_app uu___1 -> + let uu___2 = + let uu___3 = head_and_args t in FStar_Pervasives_Native.fst uu___3 in + is_uvar uu___2 + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t1; FStarC_Syntax_Syntax.asc = uu___1; + FStarC_Syntax_Syntax.eff_opt = uu___2;_} + -> is_uvar t1 + | uu___1 -> false +let rec (is_unit : FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t -> + let uu___ = let uu___1 = unrefine t in uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + ((FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.unit_lid) || + (FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.squash_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.auto_squash_lid) + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = uu___1;_} + -> is_unit head + | FStarC_Syntax_Syntax.Tm_uinst (t1, uu___1) -> is_unit t1 + | uu___1 -> false +let (is_eqtype_no_unrefine : FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.eqtype_lid + | uu___1 -> false +let (is_fun : FStarC_Syntax_Syntax.term -> Prims.bool) = + fun e -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress e in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_abs uu___1 -> true + | uu___1 -> false +let (is_function_typ : FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_arrow uu___1 -> true + | uu___1 -> false +let rec (pre_typ : FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) = + fun t -> + let t1 = FStarC_Syntax_Subst.compress t in + match t1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x; FStarC_Syntax_Syntax.phi = uu___;_} -> + pre_typ x.FStarC_Syntax_Syntax.sort + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t2; FStarC_Syntax_Syntax.asc = uu___; + FStarC_Syntax_Syntax.eff_opt = uu___1;_} + -> pre_typ t2 + | uu___ -> t1 +let (destruct : + FStarC_Syntax_Syntax.term -> + FStarC_Ident.lident -> + (FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax * + FStarC_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) + Prims.list FStar_Pervasives_Native.option) + = + fun typ -> + fun lid -> + let typ1 = FStarC_Syntax_Subst.compress typ in + let uu___ = let uu___1 = un_uinst typ1 in uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = args;_} + -> + let head1 = un_uinst head in + (match head1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_fvar tc when + FStarC_Syntax_Syntax.fv_eq_lid tc lid -> + FStar_Pervasives_Native.Some args + | uu___1 -> FStar_Pervasives_Native.None) + | FStarC_Syntax_Syntax.Tm_fvar tc when + FStarC_Syntax_Syntax.fv_eq_lid tc lid -> + FStar_Pervasives_Native.Some [] + | uu___1 -> FStar_Pervasives_Native.None +let (lids_of_sigelt : + FStarC_Syntax_Syntax.sigelt -> FStarC_Ident.lident Prims.list) = + fun se -> + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = uu___; + FStarC_Syntax_Syntax.lids1 = lids;_} + -> lids + | FStarC_Syntax_Syntax.Sig_splice + { FStarC_Syntax_Syntax.is_typed = uu___; + FStarC_Syntax_Syntax.lids2 = lids; + FStarC_Syntax_Syntax.tac = uu___1;_} + -> lids + | FStarC_Syntax_Syntax.Sig_bundle + { FStarC_Syntax_Syntax.ses = uu___; + FStarC_Syntax_Syntax.lids = lids;_} + -> lids + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = lid; FStarC_Syntax_Syntax.us = uu___; + FStarC_Syntax_Syntax.params = uu___1; + FStarC_Syntax_Syntax.num_uniform_params = uu___2; + FStarC_Syntax_Syntax.t = uu___3; + FStarC_Syntax_Syntax.mutuals = uu___4; + FStarC_Syntax_Syntax.ds = uu___5; + FStarC_Syntax_Syntax.injective_type_params = uu___6;_} + -> [lid] + | FStarC_Syntax_Syntax.Sig_effect_abbrev + { FStarC_Syntax_Syntax.lid4 = lid; FStarC_Syntax_Syntax.us4 = uu___; + FStarC_Syntax_Syntax.bs2 = uu___1; + FStarC_Syntax_Syntax.comp1 = uu___2; + FStarC_Syntax_Syntax.cflags = uu___3;_} + -> [lid] + | FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = lid; FStarC_Syntax_Syntax.us1 = uu___; + FStarC_Syntax_Syntax.t1 = uu___1; + FStarC_Syntax_Syntax.ty_lid = uu___2; + FStarC_Syntax_Syntax.num_ty_params = uu___3; + FStarC_Syntax_Syntax.mutuals1 = uu___4; + FStarC_Syntax_Syntax.injective_type_params1 = uu___5;_} + -> [lid] + | FStarC_Syntax_Syntax.Sig_declare_typ + { FStarC_Syntax_Syntax.lid2 = lid; FStarC_Syntax_Syntax.us2 = uu___; + FStarC_Syntax_Syntax.t2 = uu___1;_} + -> [lid] + | FStarC_Syntax_Syntax.Sig_assume + { FStarC_Syntax_Syntax.lid3 = lid; FStarC_Syntax_Syntax.us3 = uu___; + FStarC_Syntax_Syntax.phi1 = uu___1;_} + -> [lid] + | FStarC_Syntax_Syntax.Sig_new_effect d -> [d.FStarC_Syntax_Syntax.mname] + | FStarC_Syntax_Syntax.Sig_sub_effect uu___ -> [] + | FStarC_Syntax_Syntax.Sig_pragma uu___ -> [] + | FStarC_Syntax_Syntax.Sig_fail uu___ -> [] + | FStarC_Syntax_Syntax.Sig_polymonadic_bind uu___ -> [] + | FStarC_Syntax_Syntax.Sig_polymonadic_subcomp uu___ -> [] +let (lid_of_sigelt : + FStarC_Syntax_Syntax.sigelt -> + FStarC_Ident.lident FStar_Pervasives_Native.option) + = + fun se -> + match lids_of_sigelt se with + | l::[] -> FStar_Pervasives_Native.Some l + | uu___ -> FStar_Pervasives_Native.None +let (quals_of_sigelt : + FStarC_Syntax_Syntax.sigelt -> FStarC_Syntax_Syntax.qualifier Prims.list) = + fun x -> x.FStarC_Syntax_Syntax.sigquals +let (range_of_sigelt : + FStarC_Syntax_Syntax.sigelt -> FStarC_Compiler_Range_Type.range) = + fun x -> x.FStarC_Syntax_Syntax.sigrng +let range_of_arg : + 'uuuuu 'uuuuu1 . + ('uuuuu FStarC_Syntax_Syntax.syntax * 'uuuuu1) -> + FStarC_Compiler_Range_Type.range + = + fun uu___ -> match uu___ with | (hd, uu___1) -> hd.FStarC_Syntax_Syntax.pos +let range_of_args : + 'uuuuu 'uuuuu1 . + ('uuuuu FStarC_Syntax_Syntax.syntax * 'uuuuu1) Prims.list -> + FStarC_Compiler_Range_Type.range -> FStarC_Compiler_Range_Type.range + = + fun args -> + fun r -> + FStarC_Compiler_List.fold_left + (fun r1 -> + fun a -> + FStarC_Compiler_Range_Ops.union_ranges r1 (range_of_arg a)) r + args +let (mk_app : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + (FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax * + FStarC_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) + Prims.list -> FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun f -> + fun args -> + match args with + | [] -> f + | uu___ -> + let r = range_of_args args f.FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = f; + FStarC_Syntax_Syntax.args = args + }) r +let (mk_app_binders : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.binder Prims.list -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun f -> + fun bs -> + let uu___ = + FStarC_Compiler_List.map + (fun b -> + let uu___1 = + FStarC_Syntax_Syntax.bv_to_name + b.FStarC_Syntax_Syntax.binder_bv in + let uu___2 = aqual_of_binder b in (uu___1, uu___2)) bs in + mk_app f uu___ +let (field_projector_prefix : Prims.string) = "__proj__" +let (field_projector_sep : Prims.string) = "__item__" +let (field_projector_contains_constructor : Prims.string -> Prims.bool) = + fun s -> FStarC_Compiler_Util.starts_with s field_projector_prefix +let (mk_field_projector_name_from_string : + Prims.string -> Prims.string -> Prims.string) = + fun constr -> + fun field -> + Prims.strcat field_projector_prefix + (Prims.strcat constr (Prims.strcat field_projector_sep field)) +let (mk_field_projector_name_from_ident : + FStarC_Ident.lident -> FStarC_Ident.ident -> FStarC_Ident.lident) = + fun lid -> + fun i -> + let itext = FStarC_Ident.string_of_id i in + let newi = + if field_projector_contains_constructor itext + then i + else + (let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Ident.ident_of_lid lid in + FStarC_Ident.string_of_id uu___4 in + mk_field_projector_name_from_string uu___3 itext in + let uu___3 = FStarC_Ident.range_of_id i in (uu___2, uu___3) in + FStarC_Ident.mk_ident uu___1) in + let uu___ = + let uu___1 = FStarC_Ident.ns_of_lid lid in + FStarC_Compiler_List.op_At uu___1 [newi] in + FStarC_Ident.lid_of_ids uu___ +let (mk_field_projector_name : + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.bv -> Prims.int -> FStarC_Ident.lident) + = + fun lid -> + fun x -> + fun i -> + let nm = + let uu___ = FStarC_Syntax_Syntax.is_null_bv x in + if uu___ + then + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Compiler_Util.string_of_int i in + Prims.strcat "_" uu___3 in + let uu___3 = FStarC_Syntax_Syntax.range_of_bv x in + (uu___2, uu___3) in + FStarC_Ident.mk_ident uu___1 + else x.FStarC_Syntax_Syntax.ppname in + mk_field_projector_name_from_ident lid nm +let (ses_of_sigbundle : + FStarC_Syntax_Syntax.sigelt -> FStarC_Syntax_Syntax.sigelt Prims.list) = + fun se -> + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_bundle + { FStarC_Syntax_Syntax.ses = ses; + FStarC_Syntax_Syntax.lids = uu___;_} + -> ses + | uu___ -> failwith "ses_of_sigbundle: not a Sig_bundle" +let (set_uvar : + FStarC_Syntax_Syntax.uvar -> FStarC_Syntax_Syntax.term -> unit) = + fun uv -> + fun t -> + let uu___ = FStarC_Syntax_Unionfind.find uv in + match uu___ with + | FStar_Pervasives_Native.Some t' -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Unionfind.uvar_id uv in + FStarC_Compiler_Util.string_of_int uu___3 in + let uu___3 = tts t in + let uu___4 = tts t' in + FStarC_Compiler_Util.format3 + "Changing a fixed uvar! ?%s to %s but it is already set to %s\n" + uu___2 uu___3 uu___4 in + failwith uu___1 + | uu___1 -> FStarC_Syntax_Unionfind.change uv t +let (qualifier_equal : + FStarC_Syntax_Syntax.qualifier -> + FStarC_Syntax_Syntax.qualifier -> Prims.bool) + = + fun q1 -> + fun q2 -> + match (q1, q2) with + | (FStarC_Syntax_Syntax.Discriminator l1, + FStarC_Syntax_Syntax.Discriminator l2) -> + FStarC_Ident.lid_equals l1 l2 + | (FStarC_Syntax_Syntax.Projector (l1a, l1b), + FStarC_Syntax_Syntax.Projector (l2a, l2b)) -> + (FStarC_Ident.lid_equals l1a l2a) && + (let uu___ = FStarC_Ident.string_of_id l1b in + let uu___1 = FStarC_Ident.string_of_id l2b in uu___ = uu___1) + | (FStarC_Syntax_Syntax.RecordType (ns1, f1), + FStarC_Syntax_Syntax.RecordType (ns2, f2)) -> + ((((FStarC_Compiler_List.length ns1) = + (FStarC_Compiler_List.length ns2)) + && + (FStarC_Compiler_List.forall2 + (fun x1 -> + fun x2 -> + let uu___ = FStarC_Ident.string_of_id x1 in + let uu___1 = FStarC_Ident.string_of_id x2 in + uu___ = uu___1) f1 f2)) + && + ((FStarC_Compiler_List.length f1) = + (FStarC_Compiler_List.length f2))) + && + (FStarC_Compiler_List.forall2 + (fun x1 -> + fun x2 -> + let uu___ = FStarC_Ident.string_of_id x1 in + let uu___1 = FStarC_Ident.string_of_id x2 in + uu___ = uu___1) f1 f2) + | (FStarC_Syntax_Syntax.RecordConstructor (ns1, f1), + FStarC_Syntax_Syntax.RecordConstructor (ns2, f2)) -> + ((((FStarC_Compiler_List.length ns1) = + (FStarC_Compiler_List.length ns2)) + && + (FStarC_Compiler_List.forall2 + (fun x1 -> + fun x2 -> + let uu___ = FStarC_Ident.string_of_id x1 in + let uu___1 = FStarC_Ident.string_of_id x2 in + uu___ = uu___1) f1 f2)) + && + ((FStarC_Compiler_List.length f1) = + (FStarC_Compiler_List.length f2))) + && + (FStarC_Compiler_List.forall2 + (fun x1 -> + fun x2 -> + let uu___ = FStarC_Ident.string_of_id x1 in + let uu___1 = FStarC_Ident.string_of_id x2 in + uu___ = uu___1) f1 f2) + | uu___ -> q1 = q2 +let (abs : + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun bs -> + fun t -> + fun lopt -> + let close_lopt lopt1 = + match lopt1 with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some rc -> + let uu___ = + let uu___1 = + FStarC_Compiler_Util.map_opt + rc.FStarC_Syntax_Syntax.residual_typ + (FStarC_Syntax_Subst.close bs) in + { + FStarC_Syntax_Syntax.residual_effect = + (rc.FStarC_Syntax_Syntax.residual_effect); + FStarC_Syntax_Syntax.residual_typ = uu___1; + FStarC_Syntax_Syntax.residual_flags = + (rc.FStarC_Syntax_Syntax.residual_flags) + } in + FStar_Pervasives_Native.Some uu___ in + match bs with + | [] -> t + | uu___ -> + let body = + let uu___1 = FStarC_Syntax_Subst.close bs t in + FStarC_Syntax_Subst.compress uu___1 in + (match body.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs'; + FStarC_Syntax_Syntax.body = t1; + FStarC_Syntax_Syntax.rc_opt = lopt';_} + -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.close_binders bs in + FStarC_Compiler_List.op_At uu___4 bs' in + let uu___4 = close_lopt lopt' in + { + FStarC_Syntax_Syntax.bs = uu___3; + FStarC_Syntax_Syntax.body = t1; + FStarC_Syntax_Syntax.rc_opt = uu___4 + } in + FStarC_Syntax_Syntax.Tm_abs uu___2 in + FStarC_Syntax_Syntax.mk uu___1 t1.FStarC_Syntax_Syntax.pos + | uu___1 -> + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.close_binders bs in + let uu___5 = close_lopt lopt in + { + FStarC_Syntax_Syntax.bs = uu___4; + FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = uu___5 + } in + FStarC_Syntax_Syntax.Tm_abs uu___3 in + FStarC_Syntax_Syntax.mk uu___2 t.FStarC_Syntax_Syntax.pos) +let (arrow_ln : + FStarC_Syntax_Syntax.binder Prims.list -> + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun bs -> + fun c -> + match bs with + | [] -> comp_result c + | uu___ -> + let uu___1 = + FStarC_Compiler_List.fold_left + (fun a -> + fun b -> + FStarC_Compiler_Range_Ops.union_ranges a + ((b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort).FStarC_Syntax_Syntax.pos) + c.FStarC_Syntax_Syntax.pos bs in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; FStarC_Syntax_Syntax.comp = c + }) uu___1 +let (arrow : + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.comp -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun bs -> + fun c -> + let c1 = FStarC_Syntax_Subst.close_comp bs c in + let bs1 = FStarC_Syntax_Subst.close_binders bs in arrow_ln bs1 c1 +let (flat_arrow : + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.comp -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun bs -> + fun c -> + let t = arrow bs c in + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs1; FStarC_Syntax_Syntax.comp = c1;_} + -> + (match c1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total tres -> + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress tres in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs'; + FStarC_Syntax_Syntax.comp = c';_} + -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 = + (FStarC_Compiler_List.op_At bs1 bs'); + FStarC_Syntax_Syntax.comp = c' + }) t.FStarC_Syntax_Syntax.pos + | uu___2 -> t) + | uu___1 -> t) + | uu___1 -> t +let rec (canon_arrow : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; FStarC_Syntax_Syntax.comp = c;_} -> + let cn = + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total t1 -> + let uu___1 = canon_arrow t1 in + FStarC_Syntax_Syntax.Total uu___1 + | uu___1 -> c.FStarC_Syntax_Syntax.n in + let c1 = + { + FStarC_Syntax_Syntax.n = cn; + FStarC_Syntax_Syntax.pos = (c.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = (c.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (c.FStarC_Syntax_Syntax.hash_code) + } in + flat_arrow bs c1 + | uu___1 -> t +let (refine : + FStarC_Syntax_Syntax.bv -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun b -> + fun t -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Syntax.mk_binder b in [uu___4] in + FStarC_Syntax_Subst.close uu___3 t in + { FStarC_Syntax_Syntax.b = b; FStarC_Syntax_Syntax.phi = uu___2 } in + FStarC_Syntax_Syntax.Tm_refine uu___1 in + let uu___1 = + let uu___2 = FStarC_Syntax_Syntax.range_of_bv b in + FStarC_Compiler_Range_Ops.union_ranges uu___2 + t.FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.mk uu___ uu___1 +let (branch : FStarC_Syntax_Syntax.branch -> FStarC_Syntax_Syntax.branch) = + fun b -> FStarC_Syntax_Subst.close_branch b +let (has_decreases : FStarC_Syntax_Syntax.comp -> Prims.bool) = + fun c -> + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Comp ct -> + let uu___ = + FStarC_Compiler_Util.find_opt + (fun uu___1 -> + match uu___1 with + | FStarC_Syntax_Syntax.DECREASES uu___2 -> true + | uu___2 -> false) ct.FStarC_Syntax_Syntax.flags in + (match uu___ with + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.DECREASES + uu___1) -> true + | uu___1 -> false) + | uu___ -> false +let rec (arrow_formals_comp_ln : + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.binder Prims.list * FStarC_Syntax_Syntax.comp)) + = + fun k -> + let k1 = FStarC_Syntax_Subst.compress k in + match k1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; FStarC_Syntax_Syntax.comp = c;_} -> + let uu___ = + (is_total_comp c) && + (let uu___1 = has_decreases c in Prims.op_Negation uu___1) in + if uu___ + then + let uu___1 = arrow_formals_comp_ln (comp_result c) in + (match uu___1 with + | (bs', k2) -> ((FStarC_Compiler_List.op_At bs bs'), k2)) + else (bs, c) + | FStarC_Syntax_Syntax.Tm_refine + { + FStarC_Syntax_Syntax.b = + { FStarC_Syntax_Syntax.ppname = uu___; + FStarC_Syntax_Syntax.index = uu___1; + FStarC_Syntax_Syntax.sort = s;_}; + FStarC_Syntax_Syntax.phi = uu___2;_} + -> + let rec aux s1 k2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.compress s1 in + uu___4.FStarC_Syntax_Syntax.n in + match uu___3 with + | FStarC_Syntax_Syntax.Tm_arrow uu___4 -> arrow_formals_comp_ln s1 + | FStarC_Syntax_Syntax.Tm_refine + { + FStarC_Syntax_Syntax.b = + { FStarC_Syntax_Syntax.ppname = uu___4; + FStarC_Syntax_Syntax.index = uu___5; + FStarC_Syntax_Syntax.sort = s2;_}; + FStarC_Syntax_Syntax.phi = uu___6;_} + -> aux s2 k2 + | uu___4 -> + let uu___5 = FStarC_Syntax_Syntax.mk_Total k2 in ([], uu___5) in + aux s k1 + | uu___ -> let uu___1 = FStarC_Syntax_Syntax.mk_Total k1 in ([], uu___1) +let (arrow_formals_comp : + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.binders * FStarC_Syntax_Syntax.comp)) + = + fun k -> + let uu___ = arrow_formals_comp_ln k in + match uu___ with | (bs, c) -> FStarC_Syntax_Subst.open_comp bs c +let (arrow_formals_ln : + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.binder Prims.list * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax)) + = + fun k -> + let uu___ = arrow_formals_comp_ln k in + match uu___ with | (bs, c) -> (bs, (comp_result c)) +let (arrow_formals : + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.binders * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax)) + = + fun k -> + let uu___ = arrow_formals_comp k in + match uu___ with | (bs, c) -> (bs, (comp_result c)) +let (let_rec_arity : + FStarC_Syntax_Syntax.letbinding -> + (Prims.int * Prims.bool Prims.list FStar_Pervasives_Native.option)) + = + fun lb -> + let rec arrow_until_decreases k = + let k1 = FStarC_Syntax_Subst.compress k in + match k1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; FStarC_Syntax_Syntax.comp = c;_} + -> + let uu___ = FStarC_Syntax_Subst.open_comp bs c in + (match uu___ with + | (bs1, c1) -> + let uu___1 = + FStarC_Compiler_Util.find_opt + (fun uu___2 -> + match uu___2 with + | FStarC_Syntax_Syntax.DECREASES uu___3 -> true + | uu___3 -> false) (comp_flags c1) in + (match uu___1 with + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.DECREASES d) -> + (bs1, (FStar_Pervasives_Native.Some d)) + | uu___2 -> + let uu___3 = is_total_comp c1 in + if uu___3 + then + let uu___4 = arrow_until_decreases (comp_result c1) in + (match uu___4 with + | (bs', d) -> + ((FStarC_Compiler_List.op_At bs1 bs'), d)) + else (bs1, FStar_Pervasives_Native.None))) + | FStarC_Syntax_Syntax.Tm_refine + { + FStarC_Syntax_Syntax.b = + { FStarC_Syntax_Syntax.ppname = uu___; + FStarC_Syntax_Syntax.index = uu___1; + FStarC_Syntax_Syntax.sort = k2;_}; + FStarC_Syntax_Syntax.phi = uu___2;_} + -> arrow_until_decreases k2 + | uu___ -> ([], FStar_Pervasives_Native.None) in + let uu___ = arrow_until_decreases lb.FStarC_Syntax_Syntax.lbtyp in + match uu___ with + | (bs, dopt) -> + let n_univs = + FStarC_Compiler_List.length lb.FStarC_Syntax_Syntax.lbunivs in + let uu___1 = + FStarC_Compiler_Util.map_opt dopt + (fun d -> + let d_bvs = + match d with + | FStarC_Syntax_Syntax.Decreases_lex l -> + Obj.magic + (Obj.repr + (let uu___2 = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) ()) in + FStarC_Compiler_List.fold_left + (fun uu___4 -> + fun uu___3 -> + (fun s -> + fun t -> + let uu___3 = + FStarC_Syntax_Free.names t in + Obj.magic + (FStarC_Class_Setlike.union () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) + (Obj.magic s) (Obj.magic uu___3))) + uu___4 uu___3) uu___2 l)) + | FStarC_Syntax_Syntax.Decreases_wf (rel, e) -> + Obj.magic + (Obj.repr + (let uu___2 = FStarC_Syntax_Free.names rel in + let uu___3 = FStarC_Syntax_Free.names e in + FStarC_Class_Setlike.union () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) + (Obj.magic uu___2) (Obj.magic uu___3))) in + let uu___2 = + FStarC_Common.tabulate n_univs (fun uu___3 -> false) in + let uu___3 = + FStarC_Compiler_List.map + (fun b -> + FStarC_Class_Setlike.mem () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) + b.FStarC_Syntax_Syntax.binder_bv (Obj.magic d_bvs)) + bs in + FStarC_Compiler_List.op_At uu___2 uu___3) in + ((n_univs + (FStarC_Compiler_List.length bs)), uu___1) +let (abs_formals_maybe_unascribe_body : + Prims.bool -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.binders * FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option)) + = + fun maybe_unascribe -> + fun t -> + let subst_lcomp_opt s l = + match l with + | FStar_Pervasives_Native.Some rc -> + let uu___ = + let uu___1 = + FStarC_Compiler_Util.map_opt + rc.FStarC_Syntax_Syntax.residual_typ + (FStarC_Syntax_Subst.subst s) in + { + FStarC_Syntax_Syntax.residual_effect = + (rc.FStarC_Syntax_Syntax.residual_effect); + FStarC_Syntax_Syntax.residual_typ = uu___1; + FStarC_Syntax_Syntax.residual_flags = + (rc.FStarC_Syntax_Syntax.residual_flags) + } in + FStar_Pervasives_Native.Some uu___ + | uu___ -> l in + let rec aux t1 abs_body_lcomp = + let uu___ = + let uu___1 = unmeta_safe t1 in uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs; FStarC_Syntax_Syntax.body = t2; + FStarC_Syntax_Syntax.rc_opt = what;_} + -> + if maybe_unascribe + then + let uu___1 = aux t2 what in + (match uu___1 with + | (bs', t3, what1) -> + ((FStarC_Compiler_List.op_At bs bs'), t3, what1)) + else (bs, t2, what) + | uu___1 -> ([], t1, abs_body_lcomp) in + let uu___ = aux t FStar_Pervasives_Native.None in + match uu___ with + | (bs, t1, abs_body_lcomp) -> + let uu___1 = FStarC_Syntax_Subst.open_term' bs t1 in + (match uu___1 with + | (bs1, t2, opening) -> + let abs_body_lcomp1 = subst_lcomp_opt opening abs_body_lcomp in + (bs1, t2, abs_body_lcomp1)) +let (abs_formals : + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.binders * FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option)) + = fun t -> abs_formals_maybe_unascribe_body true t +let (remove_inacc : FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) = + fun t -> + let no_acc b = + let aq = + match b.FStarC_Syntax_Syntax.binder_qual with + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Implicit (true)) + -> + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Implicit false) + | aq1 -> aq1 in + { + FStarC_Syntax_Syntax.binder_bv = (b.FStarC_Syntax_Syntax.binder_bv); + FStarC_Syntax_Syntax.binder_qual = aq; + FStarC_Syntax_Syntax.binder_positivity = + (b.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs = + (b.FStarC_Syntax_Syntax.binder_attrs) + } in + let uu___ = arrow_formals_comp_ln t in + match uu___ with + | (bs, c) -> + (match bs with + | [] -> t + | uu___1 -> + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Compiler_List.map no_acc bs in + { + FStarC_Syntax_Syntax.bs1 = uu___4; + FStarC_Syntax_Syntax.comp = c + } in + FStarC_Syntax_Syntax.Tm_arrow uu___3 in + FStarC_Syntax_Syntax.mk uu___2 t.FStarC_Syntax_Syntax.pos) +let (mk_letbinding : + (FStarC_Syntax_Syntax.bv, FStarC_Syntax_Syntax.fv) FStar_Pervasives.either + -> + FStarC_Syntax_Syntax.univ_name Prims.list -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax Prims.list + -> + FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.letbinding) + = + fun lbname -> + fun univ_vars -> + fun typ -> + fun eff -> + fun def -> + fun lbattrs -> + fun pos -> + { + FStarC_Syntax_Syntax.lbname = lbname; + FStarC_Syntax_Syntax.lbunivs = univ_vars; + FStarC_Syntax_Syntax.lbtyp = typ; + FStarC_Syntax_Syntax.lbeff = eff; + FStarC_Syntax_Syntax.lbdef = def; + FStarC_Syntax_Syntax.lbattrs = lbattrs; + FStarC_Syntax_Syntax.lbpos = pos + } +let (close_univs_and_mk_letbinding : + FStarC_Syntax_Syntax.fv Prims.list FStar_Pervasives_Native.option -> + (FStarC_Syntax_Syntax.bv, FStarC_Syntax_Syntax.fv) + FStar_Pervasives.either -> + FStarC_Syntax_Syntax.univ_name Prims.list -> + FStarC_Syntax_Syntax.term -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax + Prims.list -> + FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.letbinding) + = + fun recs -> + fun lbname -> + fun univ_vars -> + fun typ -> + fun eff -> + fun def -> + fun attrs -> + fun pos -> + let def1 = + match (recs, univ_vars) with + | (FStar_Pervasives_Native.None, uu___) -> def + | (uu___, []) -> def + | (FStar_Pervasives_Native.Some fvs, uu___) -> + let universes = + FStarC_Compiler_List.map + (fun uu___1 -> FStarC_Syntax_Syntax.U_name uu___1) + univ_vars in + let inst = + FStarC_Compiler_List.map + (fun fv -> + (((fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v), + universes)) fvs in + FStarC_Syntax_InstFV.instantiate inst def in + let typ1 = + FStarC_Syntax_Subst.close_univ_vars univ_vars typ in + let def2 = + FStarC_Syntax_Subst.close_univ_vars univ_vars def1 in + mk_letbinding lbname univ_vars typ1 eff def2 attrs pos +let (open_univ_vars_binders_and_comp : + FStarC_Syntax_Syntax.univ_names -> + FStarC_Syntax_Syntax.binder Prims.list -> + FStarC_Syntax_Syntax.comp -> + (FStarC_Syntax_Syntax.univ_names * FStarC_Syntax_Syntax.binder + Prims.list * FStarC_Syntax_Syntax.comp)) + = + fun uvs -> + fun binders -> + fun c -> + match binders with + | [] -> + let uu___ = FStarC_Syntax_Subst.open_univ_vars_comp uvs c in + (match uu___ with | (uvs1, c1) -> (uvs1, [], c1)) + | uu___ -> + let t' = arrow binders c in + let uu___1 = FStarC_Syntax_Subst.open_univ_vars uvs t' in + (match uu___1 with + | (uvs1, t'1) -> + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress t'1 in + uu___3.FStarC_Syntax_Syntax.n in + (match uu___2 with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = binders1; + FStarC_Syntax_Syntax.comp = c1;_} + -> (uvs1, binders1, c1) + | uu___3 -> failwith "Impossible")) +let (is_tuple_constructor : FStarC_Syntax_Syntax.typ -> Prims.bool) = + fun t -> + match t.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let uu___ = + FStarC_Ident.string_of_lid + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + FStarC_Parser_Const.is_tuple_constructor_string uu___ + | uu___ -> false +let (is_dtuple_constructor : FStarC_Syntax_Syntax.typ -> Prims.bool) = + fun t -> + match t.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + FStarC_Parser_Const.is_dtuple_constructor_lid + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + | uu___ -> false +let (is_lid_equality : FStarC_Ident.lident -> Prims.bool) = + fun x -> FStarC_Ident.lid_equals x FStarC_Parser_Const.eq2_lid +let (is_forall : FStarC_Ident.lident -> Prims.bool) = + fun lid -> FStarC_Ident.lid_equals lid FStarC_Parser_Const.forall_lid +let (is_exists : FStarC_Ident.lident -> Prims.bool) = + fun lid -> FStarC_Ident.lid_equals lid FStarC_Parser_Const.exists_lid +let (is_qlid : FStarC_Ident.lident -> Prims.bool) = + fun lid -> (is_forall lid) || (is_exists lid) +let (is_equality : + FStarC_Ident.lident FStarC_Syntax_Syntax.withinfo_t -> Prims.bool) = + fun x -> is_lid_equality x.FStarC_Syntax_Syntax.v +let (lid_is_connective : FStarC_Ident.lident -> Prims.bool) = + let lst = + [FStarC_Parser_Const.and_lid; + FStarC_Parser_Const.or_lid; + FStarC_Parser_Const.not_lid; + FStarC_Parser_Const.iff_lid; + FStarC_Parser_Const.imp_lid] in + fun lid -> FStarC_Compiler_Util.for_some (FStarC_Ident.lid_equals lid) lst +let (is_constructor : + FStarC_Syntax_Syntax.term -> FStarC_Ident.lident -> Prims.bool) = + fun t -> + fun lid -> + let uu___ = let uu___1 = pre_typ t in uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_fvar tc -> + FStarC_Ident.lid_equals + (tc.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v lid + | uu___1 -> false +let rec (is_constructed_typ : + FStarC_Syntax_Syntax.term -> FStarC_Ident.lident -> Prims.bool) = + fun t -> + fun lid -> + let uu___ = let uu___1 = pre_typ t in uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_fvar uu___1 -> is_constructor t lid + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = t1; + FStarC_Syntax_Syntax.args = uu___1;_} + -> is_constructed_typ t1 lid + | FStarC_Syntax_Syntax.Tm_uinst (t1, uu___1) -> + is_constructed_typ t1 lid + | uu___1 -> false +let rec (get_tycon : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = + fun t -> + let t1 = pre_typ t in + match t1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_bvar uu___ -> FStar_Pervasives_Native.Some t1 + | FStarC_Syntax_Syntax.Tm_name uu___ -> FStar_Pervasives_Native.Some t1 + | FStarC_Syntax_Syntax.Tm_fvar uu___ -> FStar_Pervasives_Native.Some t1 + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = t2; FStarC_Syntax_Syntax.args = uu___;_} + -> get_tycon t2 + | uu___ -> FStar_Pervasives_Native.None +let (is_fstar_tactics_by_tactic : FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t -> + let uu___ = let uu___1 = un_uinst t in uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.by_tactic_lid + | uu___1 -> false +let (ktype : FStarC_Syntax_Syntax.term) = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_type FStarC_Syntax_Syntax.U_unknown) + FStarC_Compiler_Range_Type.dummyRange +let (ktype0 : FStarC_Syntax_Syntax.term) = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_type FStarC_Syntax_Syntax.U_zero) + FStarC_Compiler_Range_Type.dummyRange +let (type_u : + unit -> (FStarC_Syntax_Syntax.typ * FStarC_Syntax_Syntax.universe)) = + fun uu___ -> + let u = + let uu___1 = + FStarC_Syntax_Unionfind.univ_fresh + FStarC_Compiler_Range_Type.dummyRange in + FStarC_Syntax_Syntax.U_unif uu___1 in + let uu___1 = + FStarC_Syntax_Syntax.mk (FStarC_Syntax_Syntax.Tm_type u) + FStarC_Compiler_Range_Type.dummyRange in + (uu___1, u) +let (type_with_u : FStarC_Syntax_Syntax.universe -> FStarC_Syntax_Syntax.typ) + = + fun u -> + FStarC_Syntax_Syntax.mk (FStarC_Syntax_Syntax.Tm_type u) + FStarC_Compiler_Range_Type.dummyRange +let (attr_substitute : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) = + let uu___ = + let uu___1 = + FStarC_Syntax_Syntax.lid_as_fv FStarC_Parser_Const.attr_substitute_lid + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.Tm_fvar uu___1 in + FStarC_Syntax_Syntax.mk uu___ FStarC_Compiler_Range_Type.dummyRange +let (exp_bool : Prims.bool -> FStarC_Syntax_Syntax.term) = + fun b -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_constant (FStarC_Const.Const_bool b)) + FStarC_Compiler_Range_Type.dummyRange +let (exp_true_bool : FStarC_Syntax_Syntax.term) = exp_bool true +let (exp_false_bool : FStarC_Syntax_Syntax.term) = exp_bool false +let (exp_unit : FStarC_Syntax_Syntax.term) = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_constant FStarC_Const.Const_unit) + FStarC_Compiler_Range_Type.dummyRange +let (exp_int : Prims.string -> FStarC_Syntax_Syntax.term) = + fun s -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_int (s, FStar_Pervasives_Native.None))) + FStarC_Compiler_Range_Type.dummyRange +let (exp_char : FStarC_BaseTypes.char -> FStarC_Syntax_Syntax.term) = + fun c -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_constant (FStarC_Const.Const_char c)) + FStarC_Compiler_Range_Type.dummyRange +let (exp_string : Prims.string -> FStarC_Syntax_Syntax.term) = + fun s -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_string + (s, FStarC_Compiler_Range_Type.dummyRange))) + FStarC_Compiler_Range_Type.dummyRange +let (fvar_const : FStarC_Ident.lident -> FStarC_Syntax_Syntax.term) = + fun l -> FStarC_Syntax_Syntax.fvar_with_dd l FStar_Pervasives_Native.None +let (tand : FStarC_Syntax_Syntax.term) = + fvar_const FStarC_Parser_Const.and_lid +let (tor : FStarC_Syntax_Syntax.term) = fvar_const FStarC_Parser_Const.or_lid +let (timp : FStarC_Syntax_Syntax.term) = + FStarC_Syntax_Syntax.fvar_with_dd FStarC_Parser_Const.imp_lid + FStar_Pervasives_Native.None +let (tiff : FStarC_Syntax_Syntax.term) = + FStarC_Syntax_Syntax.fvar_with_dd FStarC_Parser_Const.iff_lid + FStar_Pervasives_Native.None +let (t_bool : FStarC_Syntax_Syntax.term) = + fvar_const FStarC_Parser_Const.bool_lid +let (b2t_v : FStarC_Syntax_Syntax.term) = + fvar_const FStarC_Parser_Const.b2t_lid +let (t_not : FStarC_Syntax_Syntax.term) = + fvar_const FStarC_Parser_Const.not_lid +let (t_false : FStarC_Syntax_Syntax.term) = + fvar_const FStarC_Parser_Const.false_lid +let (t_true : FStarC_Syntax_Syntax.term) = + fvar_const FStarC_Parser_Const.true_lid +let (tac_opaque_attr : FStarC_Syntax_Syntax.term) = exp_string "tac_opaque" +let (dm4f_bind_range_attr : FStarC_Syntax_Syntax.term) = + fvar_const FStarC_Parser_Const.dm4f_bind_range_attr +let (tcdecltime_attr : FStarC_Syntax_Syntax.term) = + fvar_const FStarC_Parser_Const.tcdecltime_attr +let (inline_let_attr : FStarC_Syntax_Syntax.term) = + fvar_const FStarC_Parser_Const.inline_let_attr +let (rename_let_attr : FStarC_Syntax_Syntax.term) = + fvar_const FStarC_Parser_Const.rename_let_attr +let (t_ctx_uvar_and_sust : FStarC_Syntax_Syntax.term) = + fvar_const FStarC_Parser_Const.ctx_uvar_and_subst_lid +let (t_universe_uvar : FStarC_Syntax_Syntax.term) = + fvar_const FStarC_Parser_Const.universe_uvar_lid +let (t_dsl_tac_typ : FStarC_Syntax_Syntax.term) = + FStarC_Syntax_Syntax.fvar FStarC_Parser_Const.dsl_tac_typ_lid + FStar_Pervasives_Native.None +let (mk_conj_opt : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax + FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax + FStar_Pervasives_Native.option) + = + fun phi1 -> + fun phi2 -> + match phi1 with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.Some phi2 + | FStar_Pervasives_Native.Some phi11 -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Syntax.as_arg phi11 in + let uu___5 = + let uu___6 = FStarC_Syntax_Syntax.as_arg phi2 in [uu___6] in + uu___4 :: uu___5 in + { + FStarC_Syntax_Syntax.hd = tand; + FStarC_Syntax_Syntax.args = uu___3 + } in + FStarC_Syntax_Syntax.Tm_app uu___2 in + let uu___2 = + FStarC_Compiler_Range_Ops.union_ranges + phi11.FStarC_Syntax_Syntax.pos phi2.FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.mk uu___1 uu___2 in + FStar_Pervasives_Native.Some uu___ +let (mk_binop : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun op_t -> + fun phi1 -> + fun phi2 -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.as_arg phi1 in + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.as_arg phi2 in [uu___5] in + uu___3 :: uu___4 in + { + FStarC_Syntax_Syntax.hd = op_t; + FStarC_Syntax_Syntax.args = uu___2 + } in + FStarC_Syntax_Syntax.Tm_app uu___1 in + let uu___1 = + FStarC_Compiler_Range_Ops.union_ranges + phi1.FStarC_Syntax_Syntax.pos phi2.FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.mk uu___ uu___1 +let (mk_neg : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun phi -> + let uu___ = + let uu___1 = + let uu___2 = let uu___3 = FStarC_Syntax_Syntax.as_arg phi in [uu___3] in + { FStarC_Syntax_Syntax.hd = t_not; FStarC_Syntax_Syntax.args = uu___2 + } in + FStarC_Syntax_Syntax.Tm_app uu___1 in + FStarC_Syntax_Syntax.mk uu___ phi.FStarC_Syntax_Syntax.pos +let (mk_conj : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = fun phi1 -> fun phi2 -> mk_binop tand phi1 phi2 +let (mk_conj_l : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax Prims.list -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun phi -> + match phi with + | [] -> + FStarC_Syntax_Syntax.fvar_with_dd FStarC_Parser_Const.true_lid + FStar_Pervasives_Native.None + | hd::tl -> FStarC_Compiler_List.fold_right mk_conj tl hd +let (mk_disj : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = fun phi1 -> fun phi2 -> mk_binop tor phi1 phi2 +let (mk_disj_l : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax Prims.list -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun phi -> + match phi with + | [] -> t_false + | hd::tl -> FStarC_Compiler_List.fold_right mk_disj tl hd +let (mk_imp : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term) + = fun phi1 -> fun phi2 -> mk_binop timp phi1 phi2 +let (mk_iff : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term) + = fun phi1 -> fun phi2 -> mk_binop tiff phi1 phi2 +let (b2t : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun e -> + let uu___ = + let uu___1 = + let uu___2 = let uu___3 = FStarC_Syntax_Syntax.as_arg e in [uu___3] in + { FStarC_Syntax_Syntax.hd = b2t_v; FStarC_Syntax_Syntax.args = uu___2 + } in + FStarC_Syntax_Syntax.Tm_app uu___1 in + FStarC_Syntax_Syntax.mk uu___ e.FStarC_Syntax_Syntax.pos +let (unb2t : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = + fun e -> + let uu___ = head_and_args e in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress hd in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, (e1, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.b2t_lid -> + FStar_Pervasives_Native.Some e1 + | uu___2 -> FStar_Pervasives_Native.None) +let (is_t_true : FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t -> + let uu___ = let uu___1 = unmeta t in uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.true_lid + | uu___1 -> false +let (mk_conj_simp : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun t1 -> + fun t2 -> + let uu___ = is_t_true t1 in + if uu___ + then t2 + else + (let uu___2 = is_t_true t2 in if uu___2 then t1 else mk_conj t1 t2) +let (mk_disj_simp : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun t1 -> + fun t2 -> + let uu___ = is_t_true t1 in + if uu___ + then t_true + else + (let uu___2 = is_t_true t2 in + if uu___2 then t_true else mk_disj t1 t2) +let (teq : FStarC_Syntax_Syntax.term) = + fvar_const FStarC_Parser_Const.eq2_lid +let (mk_untyped_eq2 : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun e1 -> + fun e2 -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.as_arg e1 in + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.as_arg e2 in [uu___5] in + uu___3 :: uu___4 in + { FStarC_Syntax_Syntax.hd = teq; FStarC_Syntax_Syntax.args = uu___2 + } in + FStarC_Syntax_Syntax.Tm_app uu___1 in + let uu___1 = + FStarC_Compiler_Range_Ops.union_ranges e1.FStarC_Syntax_Syntax.pos + e2.FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.mk uu___ uu___1 +let (mk_eq2 : + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun u -> + fun t -> + fun e1 -> + fun e2 -> + let eq_inst = FStarC_Syntax_Syntax.mk_Tm_uinst teq [u] in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.iarg t in + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.as_arg e1 in + let uu___6 = + let uu___7 = FStarC_Syntax_Syntax.as_arg e2 in [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + { + FStarC_Syntax_Syntax.hd = eq_inst; + FStarC_Syntax_Syntax.args = uu___2 + } in + FStarC_Syntax_Syntax.Tm_app uu___1 in + let uu___1 = + FStarC_Compiler_Range_Ops.union_ranges + e1.FStarC_Syntax_Syntax.pos e2.FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.mk uu___ uu___1 +let (mk_eq3_no_univ : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + let teq3 = fvar_const FStarC_Parser_Const.eq3_lid in + fun t1 -> + fun t2 -> + fun e1 -> + fun e2 -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.iarg t1 in + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.iarg t2 in + let uu___6 = + let uu___7 = FStarC_Syntax_Syntax.as_arg e1 in + let uu___8 = + let uu___9 = FStarC_Syntax_Syntax.as_arg e2 in [uu___9] in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + { + FStarC_Syntax_Syntax.hd = teq3; + FStarC_Syntax_Syntax.args = uu___2 + } in + FStarC_Syntax_Syntax.Tm_app uu___1 in + let uu___1 = + FStarC_Compiler_Range_Ops.union_ranges + e1.FStarC_Syntax_Syntax.pos e2.FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.mk uu___ uu___1 +let (mk_has_type : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun t -> + fun x -> + fun t' -> + let t_has_type = fvar_const FStarC_Parser_Const.has_type_lid in + let t_has_type1 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_uinst + (t_has_type, + [FStarC_Syntax_Syntax.U_zero; FStarC_Syntax_Syntax.U_zero])) + FStarC_Compiler_Range_Type.dummyRange in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.iarg t in + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.as_arg x in + let uu___6 = + let uu___7 = FStarC_Syntax_Syntax.as_arg t' in [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + { + FStarC_Syntax_Syntax.hd = t_has_type1; + FStarC_Syntax_Syntax.args = uu___2 + } in + FStarC_Syntax_Syntax.Tm_app uu___1 in + FStarC_Syntax_Syntax.mk uu___ FStarC_Compiler_Range_Type.dummyRange +let (tforall : FStarC_Syntax_Syntax.term) = + FStarC_Syntax_Syntax.fvar_with_dd FStarC_Parser_Const.forall_lid + FStar_Pervasives_Native.None +let (texists : FStarC_Syntax_Syntax.term) = + FStarC_Syntax_Syntax.fvar_with_dd FStarC_Parser_Const.exists_lid + FStar_Pervasives_Native.None +let (t_haseq : FStarC_Syntax_Syntax.term) = + FStarC_Syntax_Syntax.fvar_with_dd FStarC_Parser_Const.haseq_lid + FStar_Pervasives_Native.None +let (decidable_eq : FStarC_Syntax_Syntax.term) = + fvar_const FStarC_Parser_Const.op_Eq +let (mk_decidable_eq : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun t -> + fun e1 -> + fun e2 -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.iarg t in + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.as_arg e1 in + let uu___6 = + let uu___7 = FStarC_Syntax_Syntax.as_arg e2 in [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + { + FStarC_Syntax_Syntax.hd = decidable_eq; + FStarC_Syntax_Syntax.args = uu___2 + } in + FStarC_Syntax_Syntax.Tm_app uu___1 in + let uu___1 = + FStarC_Compiler_Range_Ops.union_ranges e1.FStarC_Syntax_Syntax.pos + e2.FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.mk uu___ uu___1 +let (b_and : FStarC_Syntax_Syntax.term) = + fvar_const FStarC_Parser_Const.op_And +let (mk_and : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun e1 -> + fun e2 -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.as_arg e1 in + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.as_arg e2 in [uu___5] in + uu___3 :: uu___4 in + { + FStarC_Syntax_Syntax.hd = b_and; + FStarC_Syntax_Syntax.args = uu___2 + } in + FStarC_Syntax_Syntax.Tm_app uu___1 in + let uu___1 = + FStarC_Compiler_Range_Ops.union_ranges e1.FStarC_Syntax_Syntax.pos + e2.FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.mk uu___ uu___1 +let (mk_and_l : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax Prims.list -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun l -> + match l with + | [] -> exp_true_bool + | hd::tl -> FStarC_Compiler_List.fold_left mk_and hd tl +let (mk_boolean_negation : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun b -> + let uu___ = + let uu___1 = + let uu___2 = fvar_const FStarC_Parser_Const.op_Negation in + let uu___3 = let uu___4 = FStarC_Syntax_Syntax.as_arg b in [uu___4] in + { + FStarC_Syntax_Syntax.hd = uu___2; + FStarC_Syntax_Syntax.args = uu___3 + } in + FStarC_Syntax_Syntax.Tm_app uu___1 in + FStarC_Syntax_Syntax.mk uu___ b.FStarC_Syntax_Syntax.pos +let (mk_residual_comp : + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax + FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.cflag Prims.list -> + FStarC_Syntax_Syntax.residual_comp) + = + fun l -> + fun t -> + fun f -> + { + FStarC_Syntax_Syntax.residual_effect = l; + FStarC_Syntax_Syntax.residual_typ = t; + FStarC_Syntax_Syntax.residual_flags = f + } +let (residual_tot : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.residual_comp) + = + fun t -> + { + FStarC_Syntax_Syntax.residual_effect = + FStarC_Parser_Const.effect_Tot_lid; + FStarC_Syntax_Syntax.residual_typ = (FStar_Pervasives_Native.Some t); + FStarC_Syntax_Syntax.residual_flags = [FStarC_Syntax_Syntax.TOTAL] + } +let (residual_gtot : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.residual_comp) + = + fun t -> + { + FStarC_Syntax_Syntax.residual_effect = + FStarC_Parser_Const.effect_GTot_lid; + FStarC_Syntax_Syntax.residual_typ = (FStar_Pervasives_Native.Some t); + FStarC_Syntax_Syntax.residual_flags = [FStarC_Syntax_Syntax.TOTAL] + } +let (residual_comp_of_comp : + FStarC_Syntax_Syntax.comp -> FStarC_Syntax_Syntax.residual_comp) = + fun c -> + let uu___ = + FStarC_Compiler_List.filter + (fun uu___1 -> + match uu___1 with + | FStarC_Syntax_Syntax.DECREASES uu___2 -> false + | uu___2 -> true) (comp_flags c) in + { + FStarC_Syntax_Syntax.residual_effect = (comp_effect_name c); + FStarC_Syntax_Syntax.residual_typ = + (FStar_Pervasives_Native.Some (comp_result c)); + FStarC_Syntax_Syntax.residual_flags = uu___ + } +let (mk_forall_aux : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.bv -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun fa -> + fun x -> + fun body -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Syntax_Syntax.iarg x.FStarC_Syntax_Syntax.sort in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Syntax_Syntax.mk_binder x in + [uu___8] in + abs uu___7 body + (FStar_Pervasives_Native.Some (residual_tot ktype0)) in + FStarC_Syntax_Syntax.as_arg uu___6 in + [uu___5] in + uu___3 :: uu___4 in + { + FStarC_Syntax_Syntax.hd = fa; + FStarC_Syntax_Syntax.args = uu___2 + } in + FStarC_Syntax_Syntax.Tm_app uu___1 in + FStarC_Syntax_Syntax.mk uu___ FStarC_Compiler_Range_Type.dummyRange +let (mk_forall_no_univ : + FStarC_Syntax_Syntax.bv -> + FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.typ) + = fun x -> fun body -> mk_forall_aux tforall x body +let (mk_forall : + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.bv -> + FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.typ) + = + fun u -> + fun x -> + fun body -> + let tforall1 = FStarC_Syntax_Syntax.mk_Tm_uinst tforall [u] in + mk_forall_aux tforall1 x body +let (close_forall_no_univs : + FStarC_Syntax_Syntax.binder Prims.list -> + FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.typ) + = + fun bs -> + fun f -> + FStarC_Compiler_List.fold_right + (fun b -> + fun f1 -> + let uu___ = FStarC_Syntax_Syntax.is_null_binder b in + if uu___ + then f1 + else mk_forall_no_univ b.FStarC_Syntax_Syntax.binder_bv f1) bs f +let (mk_exists_aux : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.bv -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun fa -> + fun x -> + fun body -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Syntax_Syntax.iarg x.FStarC_Syntax_Syntax.sort in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Syntax_Syntax.mk_binder x in + [uu___8] in + abs uu___7 body + (FStar_Pervasives_Native.Some (residual_tot ktype0)) in + FStarC_Syntax_Syntax.as_arg uu___6 in + [uu___5] in + uu___3 :: uu___4 in + { + FStarC_Syntax_Syntax.hd = fa; + FStarC_Syntax_Syntax.args = uu___2 + } in + FStarC_Syntax_Syntax.Tm_app uu___1 in + FStarC_Syntax_Syntax.mk uu___ FStarC_Compiler_Range_Type.dummyRange +let (mk_exists_no_univ : + FStarC_Syntax_Syntax.bv -> + FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.typ) + = fun x -> fun body -> mk_exists_aux texists x body +let (mk_exists : + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.bv -> + FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.typ) + = + fun u -> + fun x -> + fun body -> + let texists1 = FStarC_Syntax_Syntax.mk_Tm_uinst texists [u] in + mk_exists_aux texists1 x body +let (close_exists_no_univs : + FStarC_Syntax_Syntax.binder Prims.list -> + FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.typ) + = + fun bs -> + fun f -> + FStarC_Compiler_List.fold_right + (fun b -> + fun f1 -> + let uu___ = FStarC_Syntax_Syntax.is_null_binder b in + if uu___ + then f1 + else mk_exists_no_univ b.FStarC_Syntax_Syntax.binder_bv f1) bs f +let (if_then_else : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun b -> + fun t1 -> + fun t2 -> + let then_branch = + let uu___ = + FStarC_Syntax_Syntax.withinfo + (FStarC_Syntax_Syntax.Pat_constant + (FStarC_Const.Const_bool true)) t1.FStarC_Syntax_Syntax.pos in + (uu___, FStar_Pervasives_Native.None, t1) in + let else_branch = + let uu___ = + FStarC_Syntax_Syntax.withinfo + (FStarC_Syntax_Syntax.Pat_constant + (FStarC_Const.Const_bool false)) t2.FStarC_Syntax_Syntax.pos in + (uu___, FStar_Pervasives_Native.None, t2) in + let uu___ = + let uu___1 = + FStarC_Compiler_Range_Ops.union_ranges + t1.FStarC_Syntax_Syntax.pos t2.FStarC_Syntax_Syntax.pos in + FStarC_Compiler_Range_Ops.union_ranges b.FStarC_Syntax_Syntax.pos + uu___1 in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_match + { + FStarC_Syntax_Syntax.scrutinee = b; + FStarC_Syntax_Syntax.ret_opt = FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.brs = [then_branch; else_branch]; + FStarC_Syntax_Syntax.rc_opt1 = FStar_Pervasives_Native.None + }) uu___ +let (mk_squash : + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun u -> + fun p -> + let sq = + FStarC_Syntax_Syntax.fvar_with_dd FStarC_Parser_Const.squash_lid + FStar_Pervasives_Native.None in + let uu___ = FStarC_Syntax_Syntax.mk_Tm_uinst sq [u] in + let uu___1 = let uu___2 = FStarC_Syntax_Syntax.as_arg p in [uu___2] in + mk_app uu___ uu___1 +let (mk_auto_squash : + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun u -> + fun p -> + let sq = + FStarC_Syntax_Syntax.fvar_with_dd FStarC_Parser_Const.auto_squash_lid + FStar_Pervasives_Native.None in + let uu___ = FStarC_Syntax_Syntax.mk_Tm_uinst sq [u] in + let uu___1 = let uu___2 = FStarC_Syntax_Syntax.as_arg p in [uu___2] in + mk_app uu___ uu___1 +let (un_squash : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax + FStar_Pervasives_Native.option) + = + fun t -> + let uu___ = head_and_args t in + match uu___ with + | (head, args) -> + let head1 = unascribe head in + let head2 = un_uinst head1 in + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress head2 in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, (p, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.squash_lid + -> FStar_Pervasives_Native.Some p + | (FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = b; FStarC_Syntax_Syntax.phi = p;_}, + []) -> + (match (b.FStarC_Syntax_Syntax.sort).FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.unit_lid + -> + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Syntax.mk_binder b in + [uu___4] in + FStarC_Syntax_Subst.open_term uu___3 p in + (match uu___2 with + | (bs, p1) -> + let b1 = + match bs with + | b2::[] -> b2 + | uu___3 -> failwith "impossible" in + let uu___3 = + let uu___4 = FStarC_Syntax_Free.names p1 in + FStarC_Class_Setlike.mem () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) + b1.FStarC_Syntax_Syntax.binder_bv + (Obj.magic uu___4) in + if uu___3 + then FStar_Pervasives_Native.None + else FStar_Pervasives_Native.Some p1) + | uu___2 -> FStar_Pervasives_Native.None) + | uu___2 -> FStar_Pervasives_Native.None) +let (is_squash : + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.universe * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax) FStar_Pervasives_Native.option) + = + fun t -> + let uu___ = head_and_args t in + match uu___ with + | (head, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress head in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_uinst + ({ FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar fv; + FStarC_Syntax_Syntax.pos = uu___2; + FStarC_Syntax_Syntax.vars = uu___3; + FStarC_Syntax_Syntax.hash_code = uu___4;_}, + u::[]), + (t1, uu___5)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.squash_lid + -> FStar_Pervasives_Native.Some (u, t1) + | uu___2 -> FStar_Pervasives_Native.None) +let (is_auto_squash : + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.universe * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax) FStar_Pervasives_Native.option) + = + fun t -> + let uu___ = head_and_args t in + match uu___ with + | (head, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress head in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_uinst + ({ FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar fv; + FStarC_Syntax_Syntax.pos = uu___2; + FStarC_Syntax_Syntax.vars = uu___3; + FStarC_Syntax_Syntax.hash_code = uu___4;_}, + u::[]), + (t1, uu___5)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.auto_squash_lid + -> FStar_Pervasives_Native.Some (u, t1) + | uu___2 -> FStar_Pervasives_Native.None) +let (is_sub_singleton : FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t -> + let uu___ = let uu___1 = unmeta t in head_and_args uu___1 in + match uu___ with + | (head, uu___1) -> + let uu___2 = + let uu___3 = un_uinst head in uu___3.FStarC_Syntax_Syntax.n in + (match uu___2 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + (((((((((((((((((FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.unit_lid) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.squash_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.auto_squash_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.and_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.or_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.not_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.imp_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.iff_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.ite_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.exists_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.forall_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.true_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.false_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.eq2_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.b2t_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.haseq_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.has_type_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.precedes_lid) + | uu___3 -> false) +let (arrow_one_ln : + FStarC_Syntax_Syntax.typ -> + (FStarC_Syntax_Syntax.binder * FStarC_Syntax_Syntax.comp) + FStar_Pervasives_Native.option) + = + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = []; + FStarC_Syntax_Syntax.comp = uu___1;_} + -> failwith "fatal: empty binders on arrow?" + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = b::[]; FStarC_Syntax_Syntax.comp = c;_} + -> FStar_Pervasives_Native.Some (b, c) + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = b::bs; FStarC_Syntax_Syntax.comp = c;_} + -> + let rng' = + FStarC_Compiler_List.fold_left + (fun a -> + fun b1 -> + FStarC_Compiler_Range_Ops.union_ranges a + ((b1.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort).FStarC_Syntax_Syntax.pos) + c.FStarC_Syntax_Syntax.pos bs in + let c' = + let uu___1 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = c + }) rng' in + FStarC_Syntax_Syntax.mk_Total uu___1 in + FStar_Pervasives_Native.Some (b, c') + | uu___1 -> FStar_Pervasives_Native.None +let (arrow_one : + FStarC_Syntax_Syntax.typ -> + (FStarC_Syntax_Syntax.binder * FStarC_Syntax_Syntax.comp) + FStar_Pervasives_Native.option) + = + fun t -> + let uu___ = arrow_one_ln t in + FStarC_Compiler_Util.bind_opt uu___ + (fun uu___1 -> + match uu___1 with + | (b, c) -> + let uu___2 = FStarC_Syntax_Subst.open_comp [b] c in + (match uu___2 with + | (bs, c1) -> + let b1 = + match bs with + | b2::[] -> b2 + | uu___3 -> + failwith + "impossible: open_comp returned different amount of binders" in + FStar_Pervasives_Native.Some (b1, c1))) +let (abs_one_ln : + FStarC_Syntax_Syntax.typ -> + (FStarC_Syntax_Syntax.binder * FStarC_Syntax_Syntax.term) + FStar_Pervasives_Native.option) + = + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = []; FStarC_Syntax_Syntax.body = uu___1; + FStarC_Syntax_Syntax.rc_opt = uu___2;_} + -> failwith "fatal: empty binders on abs?" + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = b::[]; FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = uu___1;_} + -> FStar_Pervasives_Native.Some (b, body) + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = b::bs; FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = rc_opt;_} + -> + let uu___1 = let uu___2 = abs bs body rc_opt in (b, uu___2) in + FStar_Pervasives_Native.Some uu___1 + | uu___1 -> FStar_Pervasives_Native.None +let (is_free_in : + FStarC_Syntax_Syntax.bv -> FStarC_Syntax_Syntax.term -> Prims.bool) = + fun bv -> + fun t -> + let uu___ = FStarC_Syntax_Free.names t in + FStarC_Class_Setlike.mem () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) bv (Obj.magic uu___) +let (action_as_lb : + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.action -> + FStarC_Compiler_Range_Type.range -> FStarC_Syntax_Syntax.sigelt) + = + fun eff_lid -> + fun a -> + fun pos -> + let lb = + let uu___ = + let uu___1 = + FStarC_Syntax_Syntax.lid_and_dd_as_fv + a.FStarC_Syntax_Syntax.action_name + FStar_Pervasives_Native.None in + FStar_Pervasives.Inr uu___1 in + let uu___1 = + let uu___2 = + FStarC_Syntax_Syntax.mk_Total a.FStarC_Syntax_Syntax.action_typ in + arrow a.FStarC_Syntax_Syntax.action_params uu___2 in + let uu___2 = + abs a.FStarC_Syntax_Syntax.action_params + a.FStarC_Syntax_Syntax.action_defn FStar_Pervasives_Native.None in + close_univs_and_mk_letbinding FStar_Pervasives_Native.None uu___ + a.FStarC_Syntax_Syntax.action_univs uu___1 + FStarC_Parser_Const.effect_Tot_lid uu___2 [] pos in + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_let + { + FStarC_Syntax_Syntax.lbs1 = (false, [lb]); + FStarC_Syntax_Syntax.lids1 = + [a.FStarC_Syntax_Syntax.action_name] + }); + FStarC_Syntax_Syntax.sigrng = + ((a.FStarC_Syntax_Syntax.action_defn).FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.sigquals = + [FStarC_Syntax_Syntax.Visible_default; + FStarC_Syntax_Syntax.Action eff_lid]; + FStarC_Syntax_Syntax.sigmeta = FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs = []; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = []; + FStarC_Syntax_Syntax.sigopts = FStar_Pervasives_Native.None + } +let (mk_reify : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Ident.lident FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun t -> + fun lopt -> + let reify_ = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_constant (FStarC_Const.Const_reify lopt)) + t.FStarC_Syntax_Syntax.pos in + let uu___ = + let uu___1 = + let uu___2 = let uu___3 = FStarC_Syntax_Syntax.as_arg t in [uu___3] in + { + FStarC_Syntax_Syntax.hd = reify_; + FStarC_Syntax_Syntax.args = uu___2 + } in + FStarC_Syntax_Syntax.Tm_app uu___1 in + FStarC_Syntax_Syntax.mk uu___ t.FStarC_Syntax_Syntax.pos +let (mk_reflect : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun t -> + let reflect_ = + let uu___ = + let uu___1 = + let uu___2 = FStarC_Ident.lid_of_str "Bogus.Effect" in + FStarC_Const.Const_reflect uu___2 in + FStarC_Syntax_Syntax.Tm_constant uu___1 in + FStarC_Syntax_Syntax.mk uu___ t.FStarC_Syntax_Syntax.pos in + let uu___ = + let uu___1 = + let uu___2 = let uu___3 = FStarC_Syntax_Syntax.as_arg t in [uu___3] in + { + FStarC_Syntax_Syntax.hd = reflect_; + FStarC_Syntax_Syntax.args = uu___2 + } in + FStarC_Syntax_Syntax.Tm_app uu___1 in + FStarC_Syntax_Syntax.mk uu___ t.FStarC_Syntax_Syntax.pos +let rec (incr_delta_depth : + FStarC_Syntax_Syntax.delta_depth -> FStarC_Syntax_Syntax.delta_depth) = + fun d -> + match d with + | FStarC_Syntax_Syntax.Delta_constant_at_level i -> + FStarC_Syntax_Syntax.Delta_constant_at_level (i + Prims.int_one) + | FStarC_Syntax_Syntax.Delta_equational_at_level i -> + FStarC_Syntax_Syntax.Delta_equational_at_level (i + Prims.int_one) + | FStarC_Syntax_Syntax.Delta_abstract d1 -> incr_delta_depth d1 +let (is_unknown : FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_unknown -> true + | uu___1 -> false +let rec apply_last : + 'uuuuu . ('uuuuu -> 'uuuuu) -> 'uuuuu Prims.list -> 'uuuuu Prims.list = + fun f -> + fun l -> + match l with + | [] -> failwith "apply_last: got empty list" + | a::[] -> let uu___ = f a in [uu___] + | x::xs -> let uu___ = apply_last f xs in x :: uu___ +let (dm4f_lid : + FStarC_Syntax_Syntax.eff_decl -> Prims.string -> FStarC_Ident.lident) = + fun ed -> + fun name -> + let p = FStarC_Ident.path_of_lid ed.FStarC_Syntax_Syntax.mname in + let p' = + apply_last + (fun s -> + Prims.strcat "_dm4f_" (Prims.strcat s (Prims.strcat "_" name))) + p in + FStarC_Ident.lid_of_path p' FStarC_Compiler_Range_Type.dummyRange +let (mk_list : + FStarC_Syntax_Syntax.term -> + FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.term Prims.list -> FStarC_Syntax_Syntax.term) + = + fun typ -> + fun rng -> + fun l -> + let ctor l1 = + let uu___ = + let uu___1 = + FStarC_Syntax_Syntax.lid_as_fv l1 + (FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.Data_ctor) in + FStarC_Syntax_Syntax.Tm_fvar uu___1 in + FStarC_Syntax_Syntax.mk uu___ rng in + let cons args pos = + let uu___ = + let uu___1 = ctor FStarC_Parser_Const.cons_lid in + FStarC_Syntax_Syntax.mk_Tm_uinst uu___1 + [FStarC_Syntax_Syntax.U_zero] in + FStarC_Syntax_Syntax.mk_Tm_app uu___ args pos in + let nil args pos = + let uu___ = + let uu___1 = ctor FStarC_Parser_Const.nil_lid in + FStarC_Syntax_Syntax.mk_Tm_uinst uu___1 + [FStarC_Syntax_Syntax.U_zero] in + FStarC_Syntax_Syntax.mk_Tm_app uu___ args pos in + let uu___ = + let uu___1 = let uu___2 = FStarC_Syntax_Syntax.iarg typ in [uu___2] in + nil uu___1 rng in + FStarC_Compiler_List.fold_right + (fun t -> + fun a -> + let uu___1 = + let uu___2 = FStarC_Syntax_Syntax.iarg typ in + let uu___3 = + let uu___4 = FStarC_Syntax_Syntax.as_arg t in + let uu___5 = + let uu___6 = FStarC_Syntax_Syntax.as_arg a in [uu___6] in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + cons uu___1 t.FStarC_Syntax_Syntax.pos) l uu___ +let rec eqlist : + 'a . + ('a -> 'a -> Prims.bool) -> 'a Prims.list -> 'a Prims.list -> Prims.bool + = + fun eq -> + fun xs -> + fun ys -> + match (xs, ys) with + | ([], []) -> true + | (x::xs1, y::ys1) -> (eq x y) && (eqlist eq xs1 ys1) + | uu___ -> false +let eqsum : + 'a 'b . + ('a -> 'a -> Prims.bool) -> + ('b -> 'b -> Prims.bool) -> + ('a, 'b) FStar_Pervasives.either -> + ('a, 'b) FStar_Pervasives.either -> Prims.bool + = + fun e1 -> + fun e2 -> + fun x -> + fun y -> + match (x, y) with + | (FStar_Pervasives.Inl x1, FStar_Pervasives.Inl y1) -> e1 x1 y1 + | (FStar_Pervasives.Inr x1, FStar_Pervasives.Inr y1) -> e2 x1 y1 + | uu___ -> false +let eqprod : + 'a 'b . + ('a -> 'a -> Prims.bool) -> + ('b -> 'b -> Prims.bool) -> ('a * 'b) -> ('a * 'b) -> Prims.bool + = + fun e1 -> + fun e2 -> + fun x -> + fun y -> + match (x, y) with + | ((x1, x2), (y1, y2)) -> (e1 x1 y1) && (e2 x2 y2) +let eqopt : + 'a . + ('a -> 'a -> Prims.bool) -> + 'a FStar_Pervasives_Native.option -> + 'a FStar_Pervasives_Native.option -> Prims.bool + = + fun e -> + fun x -> + fun y -> + match (x, y) with + | (FStar_Pervasives_Native.Some x1, FStar_Pervasives_Native.Some y1) + -> e x1 y1 + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> + true + | uu___ -> false +let (debug_term_eq : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref false +let (check : Prims.bool -> Prims.string -> Prims.bool -> Prims.bool) = + fun dbg -> + fun msg -> + fun cond -> + if cond + then true + else + (if dbg + then FStarC_Compiler_Util.print1 ">>> term_eq failing: %s\n" msg + else (); + false) +let (fail : Prims.bool -> Prims.string -> Prims.bool) = + fun dbg -> fun msg -> check dbg msg false +let rec (term_eq_dbg : + Prims.bool -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term -> Prims.bool) + = + fun dbg -> + fun t1 -> + fun t2 -> + let t11 = let uu___ = unmeta_safe t1 in canon_app uu___ in + let t21 = let uu___ = unmeta_safe t2 in canon_app uu___ in + let check1 = check dbg in + let fail1 = fail dbg in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = un_uinst t11 in + FStarC_Syntax_Subst.compress uu___3 in + uu___2.FStarC_Syntax_Syntax.n in + let uu___2 = + let uu___3 = + let uu___4 = un_uinst t21 in + FStarC_Syntax_Subst.compress uu___4 in + uu___3.FStarC_Syntax_Syntax.n in + (uu___1, uu___2) in + match uu___ with + | (FStarC_Syntax_Syntax.Tm_uinst uu___1, uu___2) -> + failwith "term_eq: impossible, should have been removed" + | (uu___1, FStarC_Syntax_Syntax.Tm_uinst uu___2) -> + failwith "term_eq: impossible, should have been removed" + | (FStarC_Syntax_Syntax.Tm_delayed uu___1, uu___2) -> + failwith "term_eq: impossible, should have been removed" + | (uu___1, FStarC_Syntax_Syntax.Tm_delayed uu___2) -> + failwith "term_eq: impossible, should have been removed" + | (FStarC_Syntax_Syntax.Tm_ascribed uu___1, uu___2) -> + failwith "term_eq: impossible, should have been removed" + | (uu___1, FStarC_Syntax_Syntax.Tm_ascribed uu___2) -> + failwith "term_eq: impossible, should have been removed" + | (FStarC_Syntax_Syntax.Tm_bvar x, FStarC_Syntax_Syntax.Tm_bvar y) -> + check1 "bvar" + (x.FStarC_Syntax_Syntax.index = y.FStarC_Syntax_Syntax.index) + | (FStarC_Syntax_Syntax.Tm_name x, FStarC_Syntax_Syntax.Tm_name y) -> + check1 "name" + (x.FStarC_Syntax_Syntax.index = y.FStarC_Syntax_Syntax.index) + | (FStarC_Syntax_Syntax.Tm_fvar x, FStarC_Syntax_Syntax.Tm_fvar y) -> + let uu___1 = FStarC_Syntax_Syntax.fv_eq x y in + check1 "fvar" uu___1 + | (FStarC_Syntax_Syntax.Tm_constant c1, + FStarC_Syntax_Syntax.Tm_constant c2) -> + let uu___1 = FStarC_Const.eq_const c1 c2 in check1 "const" uu___1 + | (FStarC_Syntax_Syntax.Tm_type uu___1, FStarC_Syntax_Syntax.Tm_type + uu___2) -> true + | (FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = b1; FStarC_Syntax_Syntax.body = t12; + FStarC_Syntax_Syntax.rc_opt = k1;_}, + FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = b2; FStarC_Syntax_Syntax.body = t22; + FStarC_Syntax_Syntax.rc_opt = k2;_}) + -> + (let uu___1 = eqlist (binder_eq_dbg dbg) b1 b2 in + check1 "abs binders" uu___1) && + (let uu___1 = term_eq_dbg dbg t12 t22 in + check1 "abs bodies" uu___1) + | (FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = b1; FStarC_Syntax_Syntax.comp = c1;_}, + FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = b2; FStarC_Syntax_Syntax.comp = c2;_}) + -> + (let uu___1 = eqlist (binder_eq_dbg dbg) b1 b2 in + check1 "arrow binders" uu___1) && + (let uu___1 = comp_eq_dbg dbg c1 c2 in + check1 "arrow comp" uu___1) + | (FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = b1; FStarC_Syntax_Syntax.phi = t12;_}, + FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = b2; FStarC_Syntax_Syntax.phi = t22;_}) + -> + (let uu___1 = + term_eq_dbg dbg b1.FStarC_Syntax_Syntax.sort + b2.FStarC_Syntax_Syntax.sort in + check1 "refine bv sort" uu___1) && + (let uu___1 = term_eq_dbg dbg t12 t22 in + check1 "refine formula" uu___1) + | (FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = f1; FStarC_Syntax_Syntax.args = a1;_}, + FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = f2; FStarC_Syntax_Syntax.args = a2;_}) + -> + (let uu___1 = term_eq_dbg dbg f1 f2 in check1 "app head" uu___1) + && + (let uu___1 = eqlist (arg_eq_dbg dbg) a1 a2 in + check1 "app args" uu___1) + | (FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = t12; + FStarC_Syntax_Syntax.ret_opt = FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.brs = bs1; + FStarC_Syntax_Syntax.rc_opt1 = uu___1;_}, + FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = t22; + FStarC_Syntax_Syntax.ret_opt = FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.brs = bs2; + FStarC_Syntax_Syntax.rc_opt1 = uu___2;_}) + -> + (let uu___3 = term_eq_dbg dbg t12 t22 in + check1 "match head" uu___3) && + (let uu___3 = eqlist (branch_eq_dbg dbg) bs1 bs2 in + check1 "match branches" uu___3) + | (FStarC_Syntax_Syntax.Tm_lazy uu___1, uu___2) -> + let uu___3 = + let uu___4 = unlazy t11 in term_eq_dbg dbg uu___4 t21 in + check1 "lazy_l" uu___3 + | (uu___1, FStarC_Syntax_Syntax.Tm_lazy uu___2) -> + let uu___3 = + let uu___4 = unlazy t21 in term_eq_dbg dbg t11 uu___4 in + check1 "lazy_r" uu___3 + | (FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (b1, lbs1); + FStarC_Syntax_Syntax.body1 = t12;_}, + FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (b2, lbs2); + FStarC_Syntax_Syntax.body1 = t22;_}) + -> + ((check1 "let flag" (b1 = b2)) && + (let uu___1 = eqlist (letbinding_eq_dbg dbg) lbs1 lbs2 in + check1 "let lbs" uu___1)) + && + (let uu___1 = term_eq_dbg dbg t12 t22 in + check1 "let body" uu___1) + | (FStarC_Syntax_Syntax.Tm_uvar (u1, uu___1), + FStarC_Syntax_Syntax.Tm_uvar (u2, uu___2)) -> + check1 "uvar" + (u1.FStarC_Syntax_Syntax.ctx_uvar_head = + u2.FStarC_Syntax_Syntax.ctx_uvar_head) + | (FStarC_Syntax_Syntax.Tm_quoted (qt1, qi1), + FStarC_Syntax_Syntax.Tm_quoted (qt2, qi2)) -> + (let uu___1 = quote_info_eq_dbg dbg qi1 qi2 in + check1 "tm_quoted qi" uu___1) && + (let uu___1 = term_eq_dbg dbg qt1 qt2 in + check1 "tm_quoted payload" uu___1) + | (FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t12; + FStarC_Syntax_Syntax.meta = m1;_}, + FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t22; + FStarC_Syntax_Syntax.meta = m2;_}) + -> + (match (m1, m2) with + | (FStarC_Syntax_Syntax.Meta_monadic (n1, ty1), + FStarC_Syntax_Syntax.Meta_monadic (n2, ty2)) -> + (let uu___1 = FStarC_Ident.lid_equals n1 n2 in + check1 "meta_monadic lid" uu___1) && + (let uu___1 = term_eq_dbg dbg ty1 ty2 in + check1 "meta_monadic type" uu___1) + | (FStarC_Syntax_Syntax.Meta_monadic_lift (s1, t13, ty1), + FStarC_Syntax_Syntax.Meta_monadic_lift (s2, t23, ty2)) -> + ((let uu___1 = FStarC_Ident.lid_equals s1 s2 in + check1 "meta_monadic_lift src" uu___1) && + (let uu___1 = FStarC_Ident.lid_equals t13 t23 in + check1 "meta_monadic_lift tgt" uu___1)) + && + (let uu___1 = term_eq_dbg dbg ty1 ty2 in + check1 "meta_monadic_lift type" uu___1) + | uu___1 -> fail1 "metas") + | (FStarC_Syntax_Syntax.Tm_unknown, uu___1) -> fail1 "unk" + | (uu___1, FStarC_Syntax_Syntax.Tm_unknown) -> fail1 "unk" + | (FStarC_Syntax_Syntax.Tm_bvar uu___1, uu___2) -> fail1 "bottom" + | (FStarC_Syntax_Syntax.Tm_name uu___1, uu___2) -> fail1 "bottom" + | (FStarC_Syntax_Syntax.Tm_fvar uu___1, uu___2) -> fail1 "bottom" + | (FStarC_Syntax_Syntax.Tm_constant uu___1, uu___2) -> fail1 "bottom" + | (FStarC_Syntax_Syntax.Tm_type uu___1, uu___2) -> fail1 "bottom" + | (FStarC_Syntax_Syntax.Tm_abs uu___1, uu___2) -> fail1 "bottom" + | (FStarC_Syntax_Syntax.Tm_arrow uu___1, uu___2) -> fail1 "bottom" + | (FStarC_Syntax_Syntax.Tm_refine uu___1, uu___2) -> fail1 "bottom" + | (FStarC_Syntax_Syntax.Tm_app uu___1, uu___2) -> fail1 "bottom" + | (FStarC_Syntax_Syntax.Tm_match uu___1, uu___2) -> fail1 "bottom" + | (FStarC_Syntax_Syntax.Tm_let uu___1, uu___2) -> fail1 "bottom" + | (FStarC_Syntax_Syntax.Tm_uvar uu___1, uu___2) -> fail1 "bottom" + | (FStarC_Syntax_Syntax.Tm_meta uu___1, uu___2) -> fail1 "bottom" + | (uu___1, FStarC_Syntax_Syntax.Tm_bvar uu___2) -> fail1 "bottom" + | (uu___1, FStarC_Syntax_Syntax.Tm_name uu___2) -> fail1 "bottom" + | (uu___1, FStarC_Syntax_Syntax.Tm_fvar uu___2) -> fail1 "bottom" + | (uu___1, FStarC_Syntax_Syntax.Tm_constant uu___2) -> fail1 "bottom" + | (uu___1, FStarC_Syntax_Syntax.Tm_type uu___2) -> fail1 "bottom" + | (uu___1, FStarC_Syntax_Syntax.Tm_abs uu___2) -> fail1 "bottom" + | (uu___1, FStarC_Syntax_Syntax.Tm_arrow uu___2) -> fail1 "bottom" + | (uu___1, FStarC_Syntax_Syntax.Tm_refine uu___2) -> fail1 "bottom" + | (uu___1, FStarC_Syntax_Syntax.Tm_app uu___2) -> fail1 "bottom" + | (uu___1, FStarC_Syntax_Syntax.Tm_match uu___2) -> fail1 "bottom" + | (uu___1, FStarC_Syntax_Syntax.Tm_let uu___2) -> fail1 "bottom" + | (uu___1, FStarC_Syntax_Syntax.Tm_uvar uu___2) -> fail1 "bottom" + | (uu___1, FStarC_Syntax_Syntax.Tm_meta uu___2) -> fail1 "bottom" +and (arg_eq_dbg : + Prims.bool -> + (FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax * + FStarC_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) -> + (FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax * + FStarC_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) -> + Prims.bool) + = + fun dbg -> + fun a1 -> + fun a2 -> + eqprod + (fun t1 -> + fun t2 -> + let uu___ = term_eq_dbg dbg t1 t2 in check dbg "arg tm" uu___) + (fun q1 -> + fun q2 -> + let uu___ = aqual_eq_dbg dbg q1 q2 in + check dbg "arg qual" uu___) a1 a2 +and (binder_eq_dbg : + Prims.bool -> + FStarC_Syntax_Syntax.binder -> FStarC_Syntax_Syntax.binder -> Prims.bool) + = + fun dbg -> + fun b1 -> + fun b2 -> + ((let uu___ = + term_eq_dbg dbg + (b1.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort + (b2.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + check dbg "binder_sort" uu___) && + (let uu___ = + bqual_eq_dbg dbg b1.FStarC_Syntax_Syntax.binder_qual + b2.FStarC_Syntax_Syntax.binder_qual in + check dbg "binder qual" uu___)) + && + (let uu___ = + eqlist (term_eq_dbg dbg) b1.FStarC_Syntax_Syntax.binder_attrs + b2.FStarC_Syntax_Syntax.binder_attrs in + check dbg "binder attrs" uu___) +and (comp_eq_dbg : + Prims.bool -> + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> Prims.bool) + = + fun dbg -> + fun c1 -> + fun c2 -> + let uu___ = comp_eff_name_res_and_args c1 in + match uu___ with + | (eff1, res1, args1) -> + let uu___1 = comp_eff_name_res_and_args c2 in + (match uu___1 with + | (eff2, res2, args2) -> + ((let uu___2 = FStarC_Ident.lid_equals eff1 eff2 in + check dbg "comp eff" uu___2) && + (let uu___2 = term_eq_dbg dbg res1 res2 in + check dbg "comp result typ" uu___2)) + && true) +and (branch_eq_dbg : + Prims.bool -> + (FStarC_Syntax_Syntax.pat' FStarC_Syntax_Syntax.withinfo_t * + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax + FStar_Pervasives_Native.option * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax) -> + (FStarC_Syntax_Syntax.pat' FStarC_Syntax_Syntax.withinfo_t * + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax + FStar_Pervasives_Native.option * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax) -> Prims.bool) + = + fun dbg -> + fun uu___ -> + fun uu___1 -> + match (uu___, uu___1) with + | ((p1, w1, t1), (p2, w2, t2)) -> + ((let uu___2 = FStarC_Syntax_Syntax.eq_pat p1 p2 in + check dbg "branch pat" uu___2) && + (let uu___2 = term_eq_dbg dbg t1 t2 in + check dbg "branch body" uu___2)) + && + (let uu___2 = + match (w1, w2) with + | (FStar_Pervasives_Native.Some x, + FStar_Pervasives_Native.Some y) -> term_eq_dbg dbg x y + | (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None) -> true + | uu___3 -> false in + check dbg "branch when" uu___2) +and (letbinding_eq_dbg : + Prims.bool -> + FStarC_Syntax_Syntax.letbinding -> + FStarC_Syntax_Syntax.letbinding -> Prims.bool) + = + fun dbg -> + fun lb1 -> + fun lb2 -> + ((let uu___ = + eqsum (fun bv1 -> fun bv2 -> true) FStarC_Syntax_Syntax.fv_eq + lb1.FStarC_Syntax_Syntax.lbname lb2.FStarC_Syntax_Syntax.lbname in + check dbg "lb bv" uu___) && + (let uu___ = + term_eq_dbg dbg lb1.FStarC_Syntax_Syntax.lbtyp + lb2.FStarC_Syntax_Syntax.lbtyp in + check dbg "lb typ" uu___)) + && + (let uu___ = + term_eq_dbg dbg lb1.FStarC_Syntax_Syntax.lbdef + lb2.FStarC_Syntax_Syntax.lbdef in + check dbg "lb def" uu___) +and (quote_info_eq_dbg : + Prims.bool -> + FStarC_Syntax_Syntax.quoteinfo -> + FStarC_Syntax_Syntax.quoteinfo -> Prims.bool) + = + fun dbg -> + fun q1 -> + fun q2 -> + if q1.FStarC_Syntax_Syntax.qkind <> q2.FStarC_Syntax_Syntax.qkind + then false + else + antiquotations_eq_dbg dbg + (FStar_Pervasives_Native.snd + q1.FStarC_Syntax_Syntax.antiquotations) + (FStar_Pervasives_Native.snd + q2.FStarC_Syntax_Syntax.antiquotations) +and (antiquotations_eq_dbg : + Prims.bool -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax Prims.list -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax Prims.list -> + Prims.bool) + = + fun dbg -> + fun a1 -> + fun a2 -> + match (a1, a2) with + | ([], []) -> true + | ([], uu___) -> false + | (uu___, []) -> false + | (t1::a11, t2::a21) -> + let uu___ = + let uu___1 = term_eq_dbg dbg t1 t2 in Prims.op_Negation uu___1 in + if uu___ then false else antiquotations_eq_dbg dbg a11 a21 +and (bqual_eq_dbg : + Prims.bool -> + FStarC_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> + Prims.bool) + = + fun dbg -> + fun a1 -> + fun a2 -> + match (a1, a2) with + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> + true + | (FStar_Pervasives_Native.None, uu___) -> false + | (uu___, FStar_Pervasives_Native.None) -> false + | (FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Implicit b1), + FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Implicit b2)) + when b1 = b2 -> true + | (FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Meta t1), + FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Meta t2)) -> + term_eq_dbg dbg t1 t2 + | (FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Equality), + FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Equality)) -> + true + | uu___ -> false +and (aqual_eq_dbg : + Prims.bool -> + FStarC_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option -> + Prims.bool) + = + fun dbg -> + fun a1 -> + fun a2 -> + match (a1, a2) with + | (FStar_Pervasives_Native.Some a11, FStar_Pervasives_Native.Some + a21) -> + if + (a11.FStarC_Syntax_Syntax.aqual_implicit = + a21.FStarC_Syntax_Syntax.aqual_implicit) + && + ((FStarC_Compiler_List.length + a11.FStarC_Syntax_Syntax.aqual_attributes) + = + (FStarC_Compiler_List.length + a21.FStarC_Syntax_Syntax.aqual_attributes)) + then + FStarC_Compiler_List.fold_left2 + (fun out -> + fun t1 -> + fun t2 -> + if Prims.op_Negation out + then false + else term_eq_dbg dbg t1 t2) true + a11.FStarC_Syntax_Syntax.aqual_attributes + a21.FStarC_Syntax_Syntax.aqual_attributes + else false + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> + true + | uu___ -> false +let (eq_aqual : + FStarC_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option -> + Prims.bool) + = fun a1 -> fun a2 -> aqual_eq_dbg false a1 a2 +let (eq_bqual : + FStarC_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> + Prims.bool) + = fun b1 -> fun b2 -> bqual_eq_dbg false b1 b2 +let (term_eq : + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t1 -> + fun t2 -> + let r = + let uu___ = FStarC_Compiler_Effect.op_Bang debug_term_eq in + term_eq_dbg uu___ t1 t2 in + FStarC_Compiler_Effect.op_Colon_Equals debug_term_eq false; r +let rec (sizeof : FStarC_Syntax_Syntax.term -> Prims.int) = + fun t -> + match t.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_delayed uu___ -> + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress t in sizeof uu___2 in + Prims.int_one + uu___1 + | FStarC_Syntax_Syntax.Tm_bvar bv -> + let uu___ = sizeof bv.FStarC_Syntax_Syntax.sort in + Prims.int_one + uu___ + | FStarC_Syntax_Syntax.Tm_name bv -> + let uu___ = sizeof bv.FStarC_Syntax_Syntax.sort in + Prims.int_one + uu___ + | FStarC_Syntax_Syntax.Tm_uinst (t1, us) -> + let uu___ = sizeof t1 in (FStarC_Compiler_List.length us) + uu___ + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs; FStarC_Syntax_Syntax.body = t1; + FStarC_Syntax_Syntax.rc_opt = uu___;_} + -> + let uu___1 = sizeof t1 in + let uu___2 = + FStarC_Compiler_List.fold_left + (fun acc -> + fun b -> + let uu___3 = + sizeof + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + acc + uu___3) Prims.int_zero bs in + uu___1 + uu___2 + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = hd; FStarC_Syntax_Syntax.args = args;_} + -> + let uu___ = sizeof hd in + let uu___1 = + FStarC_Compiler_List.fold_left + (fun acc -> + fun uu___2 -> + match uu___2 with + | (arg, uu___3) -> let uu___4 = sizeof arg in acc + uu___4) + Prims.int_zero args in + uu___ + uu___1 + | uu___ -> Prims.int_one +let (is_fvar : + FStarC_Ident.lident -> FStarC_Syntax_Syntax.term -> Prims.bool) = + fun lid -> + fun t -> + let uu___ = let uu___1 = un_uinst t in uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + FStarC_Syntax_Syntax.fv_eq_lid fv lid + | uu___1 -> false +let (is_synth_by_tactic : FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t -> is_fvar FStarC_Parser_Const.synth_lid t +let (has_attribute : + FStarC_Syntax_Syntax.attribute Prims.list -> + FStarC_Ident.lident -> Prims.bool) + = + fun attrs -> fun attr -> FStarC_Compiler_Util.for_some (is_fvar attr) attrs +let (get_attribute : + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.attribute Prims.list -> + FStarC_Syntax_Syntax.args FStar_Pervasives_Native.option) + = + fun attr -> + fun attrs -> + FStarC_Compiler_List.tryPick + (fun t -> + let uu___ = head_and_args t in + match uu___ with + | (head, args) -> + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress head in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv attr -> + FStar_Pervasives_Native.Some args + | uu___2 -> FStar_Pervasives_Native.None)) attrs +let (remove_attr : + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.attribute Prims.list -> + FStarC_Syntax_Syntax.attribute Prims.list) + = + fun attr -> + fun attrs -> + FStarC_Compiler_List.filter + (fun a -> let uu___ = is_fvar attr a in Prims.op_Negation uu___) + attrs +let (process_pragma : + FStarC_Syntax_Syntax.pragma -> FStarC_Compiler_Range_Type.range -> unit) = + fun p -> + fun r -> + FStarC_Errors.set_option_warning_callback_range + (FStar_Pervasives_Native.Some r); + (let set_options s = + let uu___1 = FStarC_Options.set_options s in + match uu___1 with + | FStarC_Getopt.Success -> () + | FStarC_Getopt.Help -> + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_FailToProcessPragma () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Failed to process pragma: use 'fstar --help' to see which options are available") + | FStarC_Getopt.Error s1 -> + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_FailToProcessPragma () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic (Prims.strcat "Failed to process pragma: " s1)) in + match p with + | FStarC_Syntax_Syntax.ShowOptions -> () + | FStarC_Syntax_Syntax.SetOptions o -> set_options o + | FStarC_Syntax_Syntax.ResetOptions sopt -> + ((let uu___2 = FStarC_Options.restore_cmd_line_options false in ()); + (match sopt with + | FStar_Pervasives_Native.None -> () + | FStar_Pervasives_Native.Some s -> set_options s)) + | FStarC_Syntax_Syntax.PushOptions sopt -> + (FStarC_Options.internal_push (); + (match sopt with + | FStar_Pervasives_Native.None -> () + | FStar_Pervasives_Native.Some s -> set_options s)) + | FStarC_Syntax_Syntax.RestartSolver -> () + | FStarC_Syntax_Syntax.PopOptions -> + let uu___1 = + let uu___2 = FStarC_Options.internal_pop () in + Prims.op_Negation uu___2 in + if uu___1 + then + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_FailToProcessPragma () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "Cannot #pop-options, stack would become empty") + else () + | FStarC_Syntax_Syntax.PrintEffectsGraph -> ()) +let rec (unbound_variables : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.bv Prims.list) + = + fun tm -> + let t = FStarC_Syntax_Subst.compress tm in + match t.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_delayed uu___ -> failwith "Impossible" + | FStarC_Syntax_Syntax.Tm_name x -> [] + | FStarC_Syntax_Syntax.Tm_uvar uu___ -> [] + | FStarC_Syntax_Syntax.Tm_type u -> [] + | FStarC_Syntax_Syntax.Tm_bvar x -> [x] + | FStarC_Syntax_Syntax.Tm_fvar uu___ -> [] + | FStarC_Syntax_Syntax.Tm_constant uu___ -> [] + | FStarC_Syntax_Syntax.Tm_lazy uu___ -> [] + | FStarC_Syntax_Syntax.Tm_unknown -> [] + | FStarC_Syntax_Syntax.Tm_uinst (t1, us) -> unbound_variables t1 + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs; FStarC_Syntax_Syntax.body = t1; + FStarC_Syntax_Syntax.rc_opt = uu___;_} + -> + let uu___1 = FStarC_Syntax_Subst.open_term bs t1 in + (match uu___1 with + | (bs1, t2) -> + let uu___2 = + FStarC_Compiler_List.collect + (fun b -> + unbound_variables + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort) + bs1 in + let uu___3 = unbound_variables t2 in + FStarC_Compiler_List.op_At uu___2 uu___3) + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; FStarC_Syntax_Syntax.comp = c;_} -> + let uu___ = FStarC_Syntax_Subst.open_comp bs c in + (match uu___ with + | (bs1, c1) -> + let uu___1 = + FStarC_Compiler_List.collect + (fun b -> + unbound_variables + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort) + bs1 in + let uu___2 = unbound_variables_comp c1 in + FStarC_Compiler_List.op_At uu___1 uu___2) + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = b; FStarC_Syntax_Syntax.phi = t1;_} -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Syntax_Syntax.mk_binder b in [uu___2] in + FStarC_Syntax_Subst.open_term uu___1 t1 in + (match uu___ with + | (bs, t2) -> + let uu___1 = + FStarC_Compiler_List.collect + (fun b1 -> + unbound_variables + (b1.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort) + bs in + let uu___2 = unbound_variables t2 in + FStarC_Compiler_List.op_At uu___1 uu___2) + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = t1; FStarC_Syntax_Syntax.args = args;_} + -> + let uu___ = + FStarC_Compiler_List.collect + (fun uu___1 -> + match uu___1 with | (x, uu___2) -> unbound_variables x) args in + let uu___1 = unbound_variables t1 in + FStarC_Compiler_List.op_At uu___ uu___1 + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = t1; + FStarC_Syntax_Syntax.ret_opt = asc_opt; + FStarC_Syntax_Syntax.brs = pats; + FStarC_Syntax_Syntax.rc_opt1 = uu___;_} + -> + let uu___1 = unbound_variables t1 in + let uu___2 = + let uu___3 = + match asc_opt with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some (b, asc) -> + let uu___4 = FStarC_Syntax_Subst.open_ascription [b] asc in + (match uu___4 with + | (bs, asc1) -> + let uu___5 = + FStarC_Compiler_List.collect + (fun b1 -> + unbound_variables + (b1.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort) + bs in + let uu___6 = unbound_variables_ascription asc1 in + FStarC_Compiler_List.op_At uu___5 uu___6) in + let uu___4 = + FStarC_Compiler_List.collect + (fun br -> + let uu___5 = FStarC_Syntax_Subst.open_branch br in + match uu___5 with + | (p, wopt, t2) -> + let uu___6 = unbound_variables t2 in + let uu___7 = + match wopt with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some t3 -> + unbound_variables t3 in + FStarC_Compiler_List.op_At uu___6 uu___7) pats in + FStarC_Compiler_List.op_At uu___3 uu___4 in + FStarC_Compiler_List.op_At uu___1 uu___2 + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t1; FStarC_Syntax_Syntax.asc = asc; + FStarC_Syntax_Syntax.eff_opt = uu___;_} + -> + let uu___1 = unbound_variables t1 in + let uu___2 = unbound_variables_ascription asc in + FStarC_Compiler_List.op_At uu___1 uu___2 + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (false, lb::[]); + FStarC_Syntax_Syntax.body1 = t1;_} + -> + let uu___ = unbound_variables lb.FStarC_Syntax_Syntax.lbtyp in + let uu___1 = + let uu___2 = unbound_variables lb.FStarC_Syntax_Syntax.lbdef in + let uu___3 = + match lb.FStarC_Syntax_Syntax.lbname with + | FStar_Pervasives.Inr uu___4 -> unbound_variables t1 + | FStar_Pervasives.Inl bv -> + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Syntax_Syntax.mk_binder bv in + [uu___6] in + FStarC_Syntax_Subst.open_term uu___5 t1 in + (match uu___4 with | (uu___5, t2) -> unbound_variables t2) in + FStarC_Compiler_List.op_At uu___2 uu___3 in + FStarC_Compiler_List.op_At uu___ uu___1 + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (uu___, lbs); + FStarC_Syntax_Syntax.body1 = t1;_} + -> + let uu___1 = FStarC_Syntax_Subst.open_let_rec lbs t1 in + (match uu___1 with + | (lbs1, t2) -> + let uu___2 = unbound_variables t2 in + let uu___3 = + FStarC_Compiler_List.collect + (fun lb -> + let uu___4 = + unbound_variables lb.FStarC_Syntax_Syntax.lbtyp in + let uu___5 = + unbound_variables lb.FStarC_Syntax_Syntax.lbdef in + FStarC_Compiler_List.op_At uu___4 uu___5) lbs1 in + FStarC_Compiler_List.op_At uu___2 uu___3) + | FStarC_Syntax_Syntax.Tm_quoted (tm1, qi) -> + (match qi.FStarC_Syntax_Syntax.qkind with + | FStarC_Syntax_Syntax.Quote_static -> [] + | FStarC_Syntax_Syntax.Quote_dynamic -> unbound_variables tm1) + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t1; FStarC_Syntax_Syntax.meta = m;_} -> + let uu___ = unbound_variables t1 in + let uu___1 = + match m with + | FStarC_Syntax_Syntax.Meta_pattern (uu___2, args) -> + FStarC_Compiler_List.collect + (FStarC_Compiler_List.collect + (fun uu___3 -> + match uu___3 with | (a, uu___4) -> unbound_variables a)) + args + | FStarC_Syntax_Syntax.Meta_monadic_lift (uu___2, uu___3, t') -> + unbound_variables t' + | FStarC_Syntax_Syntax.Meta_monadic (uu___2, t') -> + unbound_variables t' + | FStarC_Syntax_Syntax.Meta_labeled uu___2 -> [] + | FStarC_Syntax_Syntax.Meta_desugared uu___2 -> [] + | FStarC_Syntax_Syntax.Meta_named uu___2 -> [] in + FStarC_Compiler_List.op_At uu___ uu___1 +and (unbound_variables_ascription : + ((FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax, + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax) + FStar_Pervasives.either * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax FStar_Pervasives_Native.option * Prims.bool) + -> FStarC_Syntax_Syntax.bv Prims.list) + = + fun asc -> + let uu___ = asc in + match uu___ with + | (asc1, topt, uu___1) -> + let uu___2 = + match asc1 with + | FStar_Pervasives.Inl t2 -> unbound_variables t2 + | FStar_Pervasives.Inr c2 -> unbound_variables_comp c2 in + let uu___3 = + match topt with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some tac -> unbound_variables tac in + FStarC_Compiler_List.op_At uu___2 uu___3 +and (unbound_variables_comp : + FStarC_Syntax_Syntax.comp -> FStarC_Syntax_Syntax.bv Prims.list) = + fun c -> + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total t -> unbound_variables t + | FStarC_Syntax_Syntax.GTotal t -> unbound_variables t + | FStarC_Syntax_Syntax.Comp ct -> + let uu___ = unbound_variables ct.FStarC_Syntax_Syntax.result_typ in + let uu___1 = + FStarC_Compiler_List.collect + (fun uu___2 -> + match uu___2 with | (a, uu___3) -> unbound_variables a) + ct.FStarC_Syntax_Syntax.effect_args in + FStarC_Compiler_List.op_At uu___ uu___1 +let (extract_attr' : + FStarC_Ident.lid -> + FStarC_Syntax_Syntax.term Prims.list -> + (FStarC_Syntax_Syntax.term Prims.list * FStarC_Syntax_Syntax.args) + FStar_Pervasives_Native.option) + = + fun attr_lid -> + fun attrs -> + let rec aux acc attrs1 = + match attrs1 with + | [] -> FStar_Pervasives_Native.None + | h::t -> + let uu___ = head_and_args h in + (match uu___ with + | (head, args) -> + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress head in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv attr_lid -> + let attrs' = FStarC_Compiler_List.rev_acc acc t in + FStar_Pervasives_Native.Some (attrs', args) + | uu___2 -> aux (h :: acc) t)) in + aux [] attrs +let (extract_attr : + FStarC_Ident.lid -> + FStarC_Syntax_Syntax.sigelt -> + (FStarC_Syntax_Syntax.sigelt * FStarC_Syntax_Syntax.args) + FStar_Pervasives_Native.option) + = + fun attr_lid -> + fun se -> + let uu___ = extract_attr' attr_lid se.FStarC_Syntax_Syntax.sigattrs in + match uu___ with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (attrs', t) -> + FStar_Pervasives_Native.Some + ({ + FStarC_Syntax_Syntax.sigel = (se.FStarC_Syntax_Syntax.sigel); + FStarC_Syntax_Syntax.sigrng = (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = attrs'; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se.FStarC_Syntax_Syntax.sigopts) + }, t) +let (is_smt_lemma : FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = uu___1; FStarC_Syntax_Syntax.comp = c;_} + -> + (match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Comp ct when + FStarC_Ident.lid_equals ct.FStarC_Syntax_Syntax.effect_name + FStarC_Parser_Const.effect_Lemma_lid + -> + (match ct.FStarC_Syntax_Syntax.effect_args with + | _req::_ens::(pats, uu___2)::uu___3 -> + let pats' = unmeta pats in + let uu___4 = head_and_args pats' in + (match uu___4 with + | (head, uu___5) -> + let uu___6 = + let uu___7 = un_uinst head in + uu___7.FStarC_Syntax_Syntax.n in + (match uu___6 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.cons_lid + | uu___7 -> false)) + | uu___2 -> false) + | uu___2 -> false) + | uu___1 -> false +let rec (list_elements : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term Prims.list FStar_Pervasives_Native.option) + = + fun e -> + let uu___ = let uu___1 = unmeta e in head_and_args uu___1 in + match uu___ with + | (head, args) -> + let uu___1 = + let uu___2 = + let uu___3 = un_uinst head in uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, uu___2) when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.nil_lid -> + FStar_Pervasives_Native.Some [] + | (FStarC_Syntax_Syntax.Tm_fvar fv, + uu___2::(hd, uu___3)::(tl, uu___4)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.cons_lid + -> + let uu___5 = + let uu___6 = + let uu___7 = list_elements tl in + FStarC_Compiler_Util.must uu___7 in + hd :: uu___6 in + FStar_Pervasives_Native.Some uu___5 + | uu___2 -> FStar_Pervasives_Native.None) +let (destruct_lemma_with_smt_patterns : + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.binders * FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.arg Prims.list + Prims.list) FStar_Pervasives_Native.option) + = + fun t -> + let lemma_pats p = + let smt_pat_or t1 = + let uu___ = let uu___1 = unmeta t1 in head_and_args uu___1 in + match uu___ with + | (head, args) -> + let uu___1 = + let uu___2 = + let uu___3 = un_uinst head in uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, (e, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.smtpatOr_lid + -> FStar_Pervasives_Native.Some e + | uu___2 -> FStar_Pervasives_Native.None) in + let one_pat p1 = + let uu___ = let uu___1 = unmeta p1 in head_and_args uu___1 in + match uu___ with + | (head, args) -> + let uu___1 = + let uu___2 = + let uu___3 = un_uinst head in uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, (uu___2, uu___3)::arg::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.smtpat_lid + -> arg + | uu___2 -> + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Errors_Msg.text "Not an atomic SMT pattern:" in + let uu___6 = ttd p1 in + FStarC_Pprint.prefix (Prims.of_int (2)) Prims.int_one + uu___5 uu___6 in + let uu___5 = + let uu___6 = + FStarC_Errors_Msg.text + "Patterns on lemmas must be a list of simple SMTPat's;or a single SMTPatOr containing a list;of lists of patterns." in + [uu___6] in + uu___4 :: uu___5 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) p1 + FStarC_Errors_Codes.Error_IllSMTPat () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___3)) in + let list_literal_elements e = + let uu___ = list_elements e in + match uu___ with + | FStar_Pervasives_Native.Some l -> l + | FStar_Pervasives_Native.None -> + (FStarC_Errors.log_issue + (FStarC_Syntax_Syntax.has_range_syntax ()) e + FStarC_Errors_Codes.Warning_NonListLiteralSMTPattern () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "SMT pattern is not a list literal; ignoring the pattern"); + []) in + let elts = list_literal_elements p in + match elts with + | t1::[] -> + let uu___ = smt_pat_or t1 in + (match uu___ with + | FStar_Pervasives_Native.Some e -> + let uu___1 = list_literal_elements e in + FStarC_Compiler_List.map + (fun branch1 -> + let uu___2 = list_literal_elements branch1 in + FStarC_Compiler_List.map one_pat uu___2) uu___1 + | uu___1 -> + let uu___2 = FStarC_Compiler_List.map one_pat elts in [uu___2]) + | uu___ -> + let uu___1 = FStarC_Compiler_List.map one_pat elts in [uu___1] in + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = binders; + FStarC_Syntax_Syntax.comp = c;_} + -> + let uu___1 = FStarC_Syntax_Subst.open_comp binders c in + (match uu___1 with + | (binders1, c1) -> + (match c1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Comp + { FStarC_Syntax_Syntax.comp_univs = uu___2; + FStarC_Syntax_Syntax.effect_name = uu___3; + FStarC_Syntax_Syntax.result_typ = uu___4; + FStarC_Syntax_Syntax.effect_args = + (pre, uu___5)::(post, uu___6)::(pats, uu___7)::[]; + FStarC_Syntax_Syntax.flags = uu___8;_} + -> + let uu___9 = + let uu___10 = lemma_pats pats in + (binders1, pre, post, uu___10) in + FStar_Pervasives_Native.Some uu___9 + | uu___2 -> failwith "impos")) + | uu___1 -> FStar_Pervasives_Native.None +let (triggers_of_smt_lemma : + FStarC_Syntax_Syntax.term -> FStarC_Ident.lident Prims.list Prims.list) = + fun t -> + let uu___ = destruct_lemma_with_smt_patterns t in + match uu___ with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some (uu___1, uu___2, uu___3, pats) -> + FStarC_Compiler_List.map + (FStarC_Compiler_List.collect + (fun uu___4 -> + match uu___4 with + | (t1, uu___5) -> + let uu___6 = FStarC_Syntax_Free.fvars t1 in + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Syntax.ord_fv)) (Obj.magic uu___6))) + pats +let (unthunk : FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) = + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = b::[]; FStarC_Syntax_Syntax.body = e; + FStarC_Syntax_Syntax.rc_opt = uu___1;_} + -> + let uu___2 = FStarC_Syntax_Subst.open_term [b] e in + (match uu___2 with + | (bs, e1) -> + let b1 = FStarC_Compiler_List.hd bs in + let uu___3 = is_free_in b1.FStarC_Syntax_Syntax.binder_bv e1 in + if uu___3 + then + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.as_arg exp_unit in + [uu___5] in + mk_app t uu___4 + else e1) + | uu___1 -> + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.as_arg exp_unit in [uu___3] in + mk_app t uu___2 +let (unthunk_lemma_post : + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) = + fun t -> unthunk t +let (smt_lemma_as_forall : + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.binders -> FStarC_Syntax_Syntax.universe Prims.list) + -> FStarC_Syntax_Syntax.term) + = + fun t -> + fun universe_of_binders -> + let uu___ = + let uu___1 = destruct_lemma_with_smt_patterns t in + match uu___1 with + | FStar_Pervasives_Native.None -> failwith "impos" + | FStar_Pervasives_Native.Some res -> res in + match uu___ with + | (binders, pre, post, patterns) -> + let post1 = unthunk_lemma_post post in + let body = + let uu___1 = + let uu___2 = + let uu___3 = mk_imp pre post1 in + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.binders_to_names binders in + (uu___6, patterns) in + FStarC_Syntax_Syntax.Meta_pattern uu___5 in + { + FStarC_Syntax_Syntax.tm2 = uu___3; + FStarC_Syntax_Syntax.meta = uu___4 + } in + FStarC_Syntax_Syntax.Tm_meta uu___2 in + FStarC_Syntax_Syntax.mk uu___1 t.FStarC_Syntax_Syntax.pos in + let quant = + let uu___1 = universe_of_binders binders in + FStarC_Compiler_List.fold_right2 + (fun b -> + fun u -> + fun out -> + mk_forall u b.FStarC_Syntax_Syntax.binder_bv out) + binders uu___1 body in + quant +let (effect_sig_ts : + FStarC_Syntax_Syntax.effect_signature -> FStarC_Syntax_Syntax.tscheme) = + fun sig1 -> + match sig1 with + | FStarC_Syntax_Syntax.Layered_eff_sig (uu___, ts) -> ts + | FStarC_Syntax_Syntax.WP_eff_sig ts -> ts +let (apply_eff_sig : + (FStarC_Syntax_Syntax.tscheme -> FStarC_Syntax_Syntax.tscheme) -> + FStarC_Syntax_Syntax.effect_signature -> + FStarC_Syntax_Syntax.effect_signature) + = + fun f -> + fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.Layered_eff_sig (n, ts) -> + let uu___1 = let uu___2 = f ts in (n, uu___2) in + FStarC_Syntax_Syntax.Layered_eff_sig uu___1 + | FStarC_Syntax_Syntax.WP_eff_sig ts -> + let uu___1 = f ts in FStarC_Syntax_Syntax.WP_eff_sig uu___1 +let (eff_decl_of_new_effect : + FStarC_Syntax_Syntax.sigelt -> FStarC_Syntax_Syntax.eff_decl) = + fun se -> + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_new_effect ne -> ne + | uu___ -> failwith "eff_decl_of_new_effect: not a Sig_new_effect" +let (is_layered : FStarC_Syntax_Syntax.eff_decl -> Prims.bool) = + fun ed -> + match ed.FStarC_Syntax_Syntax.combinators with + | FStarC_Syntax_Syntax.Layered_eff uu___ -> true + | uu___ -> false +let (is_dm4f : FStarC_Syntax_Syntax.eff_decl -> Prims.bool) = + fun ed -> + match ed.FStarC_Syntax_Syntax.combinators with + | FStarC_Syntax_Syntax.DM4F_eff uu___ -> true + | uu___ -> false +let (apply_wp_eff_combinators : + (FStarC_Syntax_Syntax.tscheme -> FStarC_Syntax_Syntax.tscheme) -> + FStarC_Syntax_Syntax.wp_eff_combinators -> + FStarC_Syntax_Syntax.wp_eff_combinators) + = + fun f -> + fun combs -> + let uu___ = f combs.FStarC_Syntax_Syntax.ret_wp in + let uu___1 = f combs.FStarC_Syntax_Syntax.bind_wp in + let uu___2 = f combs.FStarC_Syntax_Syntax.stronger in + let uu___3 = f combs.FStarC_Syntax_Syntax.if_then_else in + let uu___4 = f combs.FStarC_Syntax_Syntax.ite_wp in + let uu___5 = f combs.FStarC_Syntax_Syntax.close_wp in + let uu___6 = f combs.FStarC_Syntax_Syntax.trivial in + let uu___7 = + FStarC_Compiler_Util.map_option f combs.FStarC_Syntax_Syntax.repr in + let uu___8 = + FStarC_Compiler_Util.map_option f + combs.FStarC_Syntax_Syntax.return_repr in + let uu___9 = + FStarC_Compiler_Util.map_option f + combs.FStarC_Syntax_Syntax.bind_repr in + { + FStarC_Syntax_Syntax.ret_wp = uu___; + FStarC_Syntax_Syntax.bind_wp = uu___1; + FStarC_Syntax_Syntax.stronger = uu___2; + FStarC_Syntax_Syntax.if_then_else = uu___3; + FStarC_Syntax_Syntax.ite_wp = uu___4; + FStarC_Syntax_Syntax.close_wp = uu___5; + FStarC_Syntax_Syntax.trivial = uu___6; + FStarC_Syntax_Syntax.repr = uu___7; + FStarC_Syntax_Syntax.return_repr = uu___8; + FStarC_Syntax_Syntax.bind_repr = uu___9 + } +let (apply_layered_eff_combinators : + (FStarC_Syntax_Syntax.tscheme -> FStarC_Syntax_Syntax.tscheme) -> + FStarC_Syntax_Syntax.layered_eff_combinators -> + FStarC_Syntax_Syntax.layered_eff_combinators) + = + fun f -> + fun combs -> + let map2 uu___ = + match uu___ with + | (ts1, ts2) -> + let uu___1 = f ts1 in let uu___2 = f ts2 in (uu___1, uu___2) in + let map3 uu___ = + match uu___ with + | (ts1, ts2, k) -> + let uu___1 = f ts1 in let uu___2 = f ts2 in (uu___1, uu___2, k) in + let uu___ = map2 combs.FStarC_Syntax_Syntax.l_repr in + let uu___1 = map2 combs.FStarC_Syntax_Syntax.l_return in + let uu___2 = map3 combs.FStarC_Syntax_Syntax.l_bind in + let uu___3 = map3 combs.FStarC_Syntax_Syntax.l_subcomp in + let uu___4 = map3 combs.FStarC_Syntax_Syntax.l_if_then_else in + let uu___5 = + FStarC_Compiler_Util.map_option map2 + combs.FStarC_Syntax_Syntax.l_close in + { + FStarC_Syntax_Syntax.l_repr = uu___; + FStarC_Syntax_Syntax.l_return = uu___1; + FStarC_Syntax_Syntax.l_bind = uu___2; + FStarC_Syntax_Syntax.l_subcomp = uu___3; + FStarC_Syntax_Syntax.l_if_then_else = uu___4; + FStarC_Syntax_Syntax.l_close = uu___5 + } +let (apply_eff_combinators : + (FStarC_Syntax_Syntax.tscheme -> FStarC_Syntax_Syntax.tscheme) -> + FStarC_Syntax_Syntax.eff_combinators -> + FStarC_Syntax_Syntax.eff_combinators) + = + fun f -> + fun combs -> + match combs with + | FStarC_Syntax_Syntax.Primitive_eff combs1 -> + let uu___ = apply_wp_eff_combinators f combs1 in + FStarC_Syntax_Syntax.Primitive_eff uu___ + | FStarC_Syntax_Syntax.DM4F_eff combs1 -> + let uu___ = apply_wp_eff_combinators f combs1 in + FStarC_Syntax_Syntax.DM4F_eff uu___ + | FStarC_Syntax_Syntax.Layered_eff combs1 -> + let uu___ = apply_layered_eff_combinators f combs1 in + FStarC_Syntax_Syntax.Layered_eff uu___ +let (get_layered_close_combinator : + FStarC_Syntax_Syntax.eff_decl -> + FStarC_Syntax_Syntax.tscheme FStar_Pervasives_Native.option) + = + fun ed -> + match ed.FStarC_Syntax_Syntax.combinators with + | FStarC_Syntax_Syntax.Layered_eff + { FStarC_Syntax_Syntax.l_repr = uu___; + FStarC_Syntax_Syntax.l_return = uu___1; + FStarC_Syntax_Syntax.l_bind = uu___2; + FStarC_Syntax_Syntax.l_subcomp = uu___3; + FStarC_Syntax_Syntax.l_if_then_else = uu___4; + FStarC_Syntax_Syntax.l_close = FStar_Pervasives_Native.None;_} + -> FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Layered_eff + { FStarC_Syntax_Syntax.l_repr = uu___; + FStarC_Syntax_Syntax.l_return = uu___1; + FStarC_Syntax_Syntax.l_bind = uu___2; + FStarC_Syntax_Syntax.l_subcomp = uu___3; + FStarC_Syntax_Syntax.l_if_then_else = uu___4; + FStarC_Syntax_Syntax.l_close = FStar_Pervasives_Native.Some + (ts, uu___5);_} + -> FStar_Pervasives_Native.Some ts + | uu___ -> FStar_Pervasives_Native.None +let (get_wp_close_combinator : + FStarC_Syntax_Syntax.eff_decl -> + FStarC_Syntax_Syntax.tscheme FStar_Pervasives_Native.option) + = + fun ed -> + match ed.FStarC_Syntax_Syntax.combinators with + | FStarC_Syntax_Syntax.Primitive_eff combs -> + FStar_Pervasives_Native.Some (combs.FStarC_Syntax_Syntax.close_wp) + | FStarC_Syntax_Syntax.DM4F_eff combs -> + FStar_Pervasives_Native.Some (combs.FStarC_Syntax_Syntax.close_wp) + | uu___ -> FStar_Pervasives_Native.None +let (get_eff_repr : + FStarC_Syntax_Syntax.eff_decl -> + FStarC_Syntax_Syntax.tscheme FStar_Pervasives_Native.option) + = + fun ed -> + match ed.FStarC_Syntax_Syntax.combinators with + | FStarC_Syntax_Syntax.Primitive_eff combs -> + combs.FStarC_Syntax_Syntax.repr + | FStarC_Syntax_Syntax.DM4F_eff combs -> combs.FStarC_Syntax_Syntax.repr + | FStarC_Syntax_Syntax.Layered_eff combs -> + FStar_Pervasives_Native.Some + (FStar_Pervasives_Native.fst combs.FStarC_Syntax_Syntax.l_repr) +let (get_bind_vc_combinator : + FStarC_Syntax_Syntax.eff_decl -> + (FStarC_Syntax_Syntax.tscheme * + FStarC_Syntax_Syntax.indexed_effect_combinator_kind + FStar_Pervasives_Native.option)) + = + fun ed -> + match ed.FStarC_Syntax_Syntax.combinators with + | FStarC_Syntax_Syntax.Primitive_eff combs -> + ((combs.FStarC_Syntax_Syntax.bind_wp), FStar_Pervasives_Native.None) + | FStarC_Syntax_Syntax.DM4F_eff combs -> + ((combs.FStarC_Syntax_Syntax.bind_wp), FStar_Pervasives_Native.None) + | FStarC_Syntax_Syntax.Layered_eff combs -> + ((FStar_Pervasives_Native.__proj__Mktuple3__item___2 + combs.FStarC_Syntax_Syntax.l_bind), + (FStar_Pervasives_Native.__proj__Mktuple3__item___3 + combs.FStarC_Syntax_Syntax.l_bind)) +let (get_return_vc_combinator : + FStarC_Syntax_Syntax.eff_decl -> FStarC_Syntax_Syntax.tscheme) = + fun ed -> + match ed.FStarC_Syntax_Syntax.combinators with + | FStarC_Syntax_Syntax.Primitive_eff combs -> + combs.FStarC_Syntax_Syntax.ret_wp + | FStarC_Syntax_Syntax.DM4F_eff combs -> + combs.FStarC_Syntax_Syntax.ret_wp + | FStarC_Syntax_Syntax.Layered_eff combs -> + FStar_Pervasives_Native.snd combs.FStarC_Syntax_Syntax.l_return +let (get_bind_repr : + FStarC_Syntax_Syntax.eff_decl -> + FStarC_Syntax_Syntax.tscheme FStar_Pervasives_Native.option) + = + fun ed -> + match ed.FStarC_Syntax_Syntax.combinators with + | FStarC_Syntax_Syntax.Primitive_eff combs -> + combs.FStarC_Syntax_Syntax.bind_repr + | FStarC_Syntax_Syntax.DM4F_eff combs -> + combs.FStarC_Syntax_Syntax.bind_repr + | FStarC_Syntax_Syntax.Layered_eff combs -> + FStar_Pervasives_Native.Some + (FStar_Pervasives_Native.__proj__Mktuple3__item___1 + combs.FStarC_Syntax_Syntax.l_bind) +let (get_return_repr : + FStarC_Syntax_Syntax.eff_decl -> + FStarC_Syntax_Syntax.tscheme FStar_Pervasives_Native.option) + = + fun ed -> + match ed.FStarC_Syntax_Syntax.combinators with + | FStarC_Syntax_Syntax.Primitive_eff combs -> + combs.FStarC_Syntax_Syntax.return_repr + | FStarC_Syntax_Syntax.DM4F_eff combs -> + combs.FStarC_Syntax_Syntax.return_repr + | FStarC_Syntax_Syntax.Layered_eff combs -> + FStar_Pervasives_Native.Some + (FStar_Pervasives_Native.fst combs.FStarC_Syntax_Syntax.l_return) +let (get_wp_trivial_combinator : + FStarC_Syntax_Syntax.eff_decl -> + FStarC_Syntax_Syntax.tscheme FStar_Pervasives_Native.option) + = + fun ed -> + match ed.FStarC_Syntax_Syntax.combinators with + | FStarC_Syntax_Syntax.Primitive_eff combs -> + FStar_Pervasives_Native.Some (combs.FStarC_Syntax_Syntax.trivial) + | FStarC_Syntax_Syntax.DM4F_eff combs -> + FStar_Pervasives_Native.Some (combs.FStarC_Syntax_Syntax.trivial) + | uu___ -> FStar_Pervasives_Native.None +let (get_layered_if_then_else_combinator : + FStarC_Syntax_Syntax.eff_decl -> + (FStarC_Syntax_Syntax.tscheme * + FStarC_Syntax_Syntax.indexed_effect_combinator_kind + FStar_Pervasives_Native.option) FStar_Pervasives_Native.option) + = + fun ed -> + match ed.FStarC_Syntax_Syntax.combinators with + | FStarC_Syntax_Syntax.Layered_eff combs -> + FStar_Pervasives_Native.Some + ((FStar_Pervasives_Native.__proj__Mktuple3__item___1 + combs.FStarC_Syntax_Syntax.l_if_then_else), + (FStar_Pervasives_Native.__proj__Mktuple3__item___3 + combs.FStarC_Syntax_Syntax.l_if_then_else)) + | uu___ -> FStar_Pervasives_Native.None +let (get_wp_if_then_else_combinator : + FStarC_Syntax_Syntax.eff_decl -> + FStarC_Syntax_Syntax.tscheme FStar_Pervasives_Native.option) + = + fun ed -> + match ed.FStarC_Syntax_Syntax.combinators with + | FStarC_Syntax_Syntax.Primitive_eff combs -> + FStar_Pervasives_Native.Some + (combs.FStarC_Syntax_Syntax.if_then_else) + | FStarC_Syntax_Syntax.DM4F_eff combs -> + FStar_Pervasives_Native.Some + (combs.FStarC_Syntax_Syntax.if_then_else) + | uu___ -> FStar_Pervasives_Native.None +let (get_wp_ite_combinator : + FStarC_Syntax_Syntax.eff_decl -> + FStarC_Syntax_Syntax.tscheme FStar_Pervasives_Native.option) + = + fun ed -> + match ed.FStarC_Syntax_Syntax.combinators with + | FStarC_Syntax_Syntax.Primitive_eff combs -> + FStar_Pervasives_Native.Some (combs.FStarC_Syntax_Syntax.ite_wp) + | FStarC_Syntax_Syntax.DM4F_eff combs -> + FStar_Pervasives_Native.Some (combs.FStarC_Syntax_Syntax.ite_wp) + | uu___ -> FStar_Pervasives_Native.None +let (get_stronger_vc_combinator : + FStarC_Syntax_Syntax.eff_decl -> + (FStarC_Syntax_Syntax.tscheme * + FStarC_Syntax_Syntax.indexed_effect_combinator_kind + FStar_Pervasives_Native.option)) + = + fun ed -> + match ed.FStarC_Syntax_Syntax.combinators with + | FStarC_Syntax_Syntax.Primitive_eff combs -> + ((combs.FStarC_Syntax_Syntax.stronger), FStar_Pervasives_Native.None) + | FStarC_Syntax_Syntax.DM4F_eff combs -> + ((combs.FStarC_Syntax_Syntax.stronger), FStar_Pervasives_Native.None) + | FStarC_Syntax_Syntax.Layered_eff combs -> + ((FStar_Pervasives_Native.__proj__Mktuple3__item___2 + combs.FStarC_Syntax_Syntax.l_subcomp), + (FStar_Pervasives_Native.__proj__Mktuple3__item___3 + combs.FStarC_Syntax_Syntax.l_subcomp)) +let (get_stronger_repr : + FStarC_Syntax_Syntax.eff_decl -> + FStarC_Syntax_Syntax.tscheme FStar_Pervasives_Native.option) + = + fun ed -> + match ed.FStarC_Syntax_Syntax.combinators with + | FStarC_Syntax_Syntax.Primitive_eff uu___ -> + FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.DM4F_eff uu___ -> FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Layered_eff combs -> + FStar_Pervasives_Native.Some + (FStar_Pervasives_Native.__proj__Mktuple3__item___1 + combs.FStarC_Syntax_Syntax.l_subcomp) +let (aqual_is_erasable : FStarC_Syntax_Syntax.aqual -> Prims.bool) = + fun aq -> + match aq with + | FStar_Pervasives_Native.None -> false + | FStar_Pervasives_Native.Some aq1 -> + FStarC_Compiler_Util.for_some + (is_fvar FStarC_Parser_Const.erasable_attr) + aq1.FStarC_Syntax_Syntax.aqual_attributes +let (is_erased_head : + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.universe * FStarC_Syntax_Syntax.term) + FStar_Pervasives_Native.option) + = + fun t -> + let uu___ = head_and_args t in + match uu___ with + | (head, args) -> + (match ((head.FStarC_Syntax_Syntax.n), args) with + | (FStarC_Syntax_Syntax.Tm_uinst + ({ FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar fv; + FStarC_Syntax_Syntax.pos = uu___1; + FStarC_Syntax_Syntax.vars = uu___2; + FStarC_Syntax_Syntax.hash_code = uu___3;_}, + u::[]), + (ty, uu___4)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.erased_lid + -> FStar_Pervasives_Native.Some (u, ty) + | uu___1 -> FStar_Pervasives_Native.None) +let (apply_reveal : + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun u -> + fun ty -> + fun v -> + let head = + let uu___ = + FStarC_Ident.set_lid_range FStarC_Parser_Const.reveal + v.FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.fvar uu___ FStar_Pervasives_Native.None in + let uu___ = FStarC_Syntax_Syntax.mk_Tm_uinst head [u] in + let uu___1 = + let uu___2 = FStarC_Syntax_Syntax.iarg ty in + let uu___3 = let uu___4 = FStarC_Syntax_Syntax.as_arg v in [uu___4] in + uu___2 :: uu___3 in + FStarC_Syntax_Syntax.mk_Tm_app uu___ uu___1 + v.FStarC_Syntax_Syntax.pos +let (check_mutual_universes : + FStarC_Syntax_Syntax.letbinding Prims.list -> unit) = + fun lbs -> + let uu___ = lbs in + match uu___ with + | lb::lbs1 -> + let expected = lb.FStarC_Syntax_Syntax.lbunivs in + let expected_len = FStarC_Compiler_List.length expected in + FStarC_Compiler_List.iter + (fun lb1 -> + let uu___1 = + ((FStarC_Compiler_List.length lb1.FStarC_Syntax_Syntax.lbunivs) + <> expected_len) + || + (let uu___2 = + FStarC_Compiler_List.forall2 FStarC_Ident.ident_equals + lb1.FStarC_Syntax_Syntax.lbunivs expected in + Prims.op_Negation uu___2) in + if uu___1 + then + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range + lb1.FStarC_Syntax_Syntax.lbpos + FStarC_Errors_Codes.Fatal_IncompatibleUniverse () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Mutually recursive definitions do not abstract over the same universes") + else ()) lbs1 +let (ctx_uvar_should_check : + FStarC_Syntax_Syntax.ctx_uvar -> FStarC_Syntax_Syntax.should_check_uvar) = + fun u -> + let uu___ = + FStarC_Syntax_Unionfind.find_decoration + u.FStarC_Syntax_Syntax.ctx_uvar_head in + uu___.FStarC_Syntax_Syntax.uvar_decoration_should_check +let (ctx_uvar_typ : + FStarC_Syntax_Syntax.ctx_uvar -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun u -> + let uu___ = + FStarC_Syntax_Unionfind.find_decoration + u.FStarC_Syntax_Syntax.ctx_uvar_head in + uu___.FStarC_Syntax_Syntax.uvar_decoration_typ +let (ctx_uvar_typedness_deps : + FStarC_Syntax_Syntax.ctx_uvar -> FStarC_Syntax_Syntax.ctx_uvar Prims.list) + = + fun u -> + let uu___ = + FStarC_Syntax_Unionfind.find_decoration + u.FStarC_Syntax_Syntax.ctx_uvar_head in + uu___.FStarC_Syntax_Syntax.uvar_decoration_typedness_depends_on +let (flatten_refinement : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun t -> + let rec aux t1 unascribe1 = + let t2 = FStarC_Syntax_Subst.compress t1 in + match t2.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t3; FStarC_Syntax_Syntax.asc = uu___; + FStarC_Syntax_Syntax.eff_opt = uu___1;_} + when unascribe1 -> aux t3 true + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x; FStarC_Syntax_Syntax.phi = phi;_} -> + let t0 = aux x.FStarC_Syntax_Syntax.sort true in + (match t0.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = y; + FStarC_Syntax_Syntax.phi = phi1;_} + -> + let uu___ = + let uu___1 = + let uu___2 = mk_conj_simp phi1 phi in + { + FStarC_Syntax_Syntax.b = y; + FStarC_Syntax_Syntax.phi = uu___2 + } in + FStarC_Syntax_Syntax.Tm_refine uu___1 in + FStarC_Syntax_Syntax.mk uu___ t0.FStarC_Syntax_Syntax.pos + | uu___ -> t2) + | uu___ -> t2 in + aux t false +let (contains_strictly_positive_attribute : + FStarC_Syntax_Syntax.attribute Prims.list -> Prims.bool) = + fun attrs -> + has_attribute attrs FStarC_Parser_Const.binder_strictly_positive_attr +let (contains_unused_attribute : + FStarC_Syntax_Syntax.attribute Prims.list -> Prims.bool) = + fun attrs -> has_attribute attrs FStarC_Parser_Const.binder_unused_attr +let (parse_positivity_attributes : + FStarC_Syntax_Syntax.attribute Prims.list -> + (FStarC_Syntax_Syntax.positivity_qualifier FStar_Pervasives_Native.option + * FStarC_Syntax_Syntax.attribute Prims.list)) + = + fun attrs -> + let uu___ = contains_unused_attribute attrs in + if uu___ + then + ((FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.BinderUnused), + attrs) + else + (let uu___2 = contains_strictly_positive_attribute attrs in + if uu___2 + then + ((FStar_Pervasives_Native.Some + FStarC_Syntax_Syntax.BinderStrictlyPositive), attrs) + else (FStar_Pervasives_Native.None, attrs)) +let (encode_positivity_attributes : + FStarC_Syntax_Syntax.positivity_qualifier FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.attribute Prims.list -> + FStarC_Syntax_Syntax.attribute Prims.list) + = + fun pqual -> + fun attrs -> + match pqual with + | FStar_Pervasives_Native.None -> attrs + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.BinderStrictlyPositive) -> + let uu___ = contains_strictly_positive_attribute attrs in + if uu___ + then attrs + else + (let uu___2 = + let uu___3 = + FStarC_Syntax_Syntax.lid_as_fv + FStarC_Parser_Const.binder_strictly_positive_attr + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___3 in + uu___2 :: attrs) + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.BinderUnused) -> + let uu___ = contains_unused_attribute attrs in + if uu___ + then attrs + else + (let uu___2 = + let uu___3 = + FStarC_Syntax_Syntax.lid_as_fv + FStarC_Parser_Const.binder_unused_attr + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___3 in + uu___2 :: attrs) +let (is_binder_strictly_positive : FStarC_Syntax_Syntax.binder -> Prims.bool) + = + fun b -> + b.FStarC_Syntax_Syntax.binder_positivity = + (FStar_Pervasives_Native.Some + FStarC_Syntax_Syntax.BinderStrictlyPositive) +let (is_binder_unused : FStarC_Syntax_Syntax.binder -> Prims.bool) = + fun b -> + b.FStarC_Syntax_Syntax.binder_positivity = + (FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.BinderUnused) +let (deduplicate_terms : + FStarC_Syntax_Syntax.term Prims.list -> + FStarC_Syntax_Syntax.term Prims.list) + = + fun l -> FStarC_Compiler_List.deduplicate (fun x -> fun y -> term_eq x y) l +let (eq_binding : + FStarC_Syntax_Syntax.binding -> FStarC_Syntax_Syntax.binding -> Prims.bool) + = + fun b1 -> + fun b2 -> + match (b1, b2) with + | (FStarC_Syntax_Syntax.Binding_var bv1, + FStarC_Syntax_Syntax.Binding_var bv2) -> + (FStarC_Syntax_Syntax.bv_eq bv1 bv2) && + (term_eq bv1.FStarC_Syntax_Syntax.sort + bv2.FStarC_Syntax_Syntax.sort) + | (FStarC_Syntax_Syntax.Binding_lid (lid1, uu___), + FStarC_Syntax_Syntax.Binding_lid (lid2, uu___1)) -> + FStarC_Ident.lid_equals lid1 lid2 + | (FStarC_Syntax_Syntax.Binding_univ u1, + FStarC_Syntax_Syntax.Binding_univ u2) -> + FStarC_Ident.ident_equals u1 u2 + | uu___ -> false \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Syntax_Visit.ml b/ocaml/fstar-lib/generated/FStarC_Syntax_Visit.ml new file mode 100644 index 00000000000..bd04e079a31 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Syntax_Visit.ml @@ -0,0 +1,84 @@ +open Prims +type 'a id = + | I of 'a +let uu___is_I : 'a . 'a id -> Prims.bool = fun projectee -> true +let __proj__I__item__run : 'a . 'a id -> 'a = + fun projectee -> match projectee with | I run -> run +let (uu___0 : unit id FStarC_Class_Monad.monad) = + { + FStarC_Class_Monad.return = + (fun uu___1 -> + fun uu___ -> (fun a -> fun a1 -> Obj.magic (I a1)) uu___1 uu___); + FStarC_Class_Monad.op_let_Bang = + (fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun a -> + fun b -> + fun uu___ -> + let uu___ = Obj.magic uu___ in + fun f -> + let f = Obj.magic f in + match uu___ with | I a1 -> Obj.magic (f a1)) uu___3 + uu___2 uu___1 uu___) + } +let op_Less_Less : + 'uuuuu 'uuuuu1 'uuuuu2 . + ('uuuuu -> 'uuuuu1) -> ('uuuuu2 -> 'uuuuu) -> 'uuuuu2 -> 'uuuuu1 + = fun f -> fun g -> fun x -> let uu___ = g x in f uu___ +let (visit_term : + Prims.bool -> + (FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun pq -> + fun vt -> + fun t -> + let uu___ = + Obj.magic + (FStarC_Syntax_VisitM.visitM_term uu___0 pq + (fun uu___1 -> + (Obj.magic (op_Less_Less (fun uu___1 -> I uu___1) vt)) + uu___1) t) in + __proj__I__item__run uu___ +let (visit_term_univs : + Prims.bool -> + (FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) -> + (FStarC_Syntax_Syntax.universe -> FStarC_Syntax_Syntax.universe) -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun pq -> + fun vt -> + fun vu -> + fun t -> + let uu___ = + Obj.magic + (FStarC_Syntax_VisitM.visitM_term_univs uu___0 pq + (fun uu___1 -> + (Obj.magic (op_Less_Less (fun uu___1 -> I uu___1) vt)) + uu___1) + (fun uu___1 -> + (Obj.magic (op_Less_Less (fun uu___1 -> I uu___1) vu)) + uu___1) t) in + __proj__I__item__run uu___ +let (visit_sigelt : + Prims.bool -> + (FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) -> + (FStarC_Syntax_Syntax.universe -> FStarC_Syntax_Syntax.universe) -> + FStarC_Syntax_Syntax.sigelt -> FStarC_Syntax_Syntax.sigelt) + = + fun pq -> + fun vt -> + fun vu -> + fun se -> + let uu___ = + Obj.magic + (FStarC_Syntax_VisitM.visitM_sigelt uu___0 pq + (fun uu___1 -> + (Obj.magic (op_Less_Less (fun uu___1 -> I uu___1) vt)) + uu___1) + (fun uu___1 -> + (Obj.magic (op_Less_Less (fun uu___1 -> I uu___1) vu)) + uu___1) se) in + __proj__I__item__run uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Syntax_VisitM.ml b/ocaml/fstar-lib/generated/FStarC_Syntax_VisitM.ml new file mode 100644 index 00000000000..e59adad2db4 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Syntax_VisitM.ml @@ -0,0 +1,2312 @@ +open Prims +type ('m, 'a) endo = 'a -> 'm +type 'm lvm = + { + lvm_monad: 'm FStarC_Class_Monad.monad ; + f_term: ('m, FStarC_Syntax_Syntax.term) endo ; + f_binder: ('m, FStarC_Syntax_Syntax.binder) endo ; + f_binding_bv: ('m, FStarC_Syntax_Syntax.bv) endo ; + f_br: ('m, FStarC_Syntax_Syntax.branch) endo ; + f_comp: ('m, FStarC_Syntax_Syntax.comp) endo ; + f_residual_comp: ('m, FStarC_Syntax_Syntax.residual_comp) endo ; + f_univ: ('m, FStarC_Syntax_Syntax.universe) endo ; + proc_quotes: Prims.bool } +let __proj__Mklvm__item__lvm_monad : + 'm . 'm lvm -> 'm FStarC_Class_Monad.monad = + fun projectee -> + match projectee with + | { lvm_monad; f_term; f_binder; f_binding_bv; f_br; f_comp; + f_residual_comp; f_univ; proc_quotes;_} -> lvm_monad +let __proj__Mklvm__item__f_term : + 'm . 'm lvm -> ('m, FStarC_Syntax_Syntax.term) endo = + fun projectee -> + match projectee with + | { lvm_monad; f_term; f_binder; f_binding_bv; f_br; f_comp; + f_residual_comp; f_univ; proc_quotes;_} -> f_term +let __proj__Mklvm__item__f_binder : + 'm . 'm lvm -> ('m, FStarC_Syntax_Syntax.binder) endo = + fun projectee -> + match projectee with + | { lvm_monad; f_term; f_binder; f_binding_bv; f_br; f_comp; + f_residual_comp; f_univ; proc_quotes;_} -> f_binder +let __proj__Mklvm__item__f_binding_bv : + 'm . 'm lvm -> ('m, FStarC_Syntax_Syntax.bv) endo = + fun projectee -> + match projectee with + | { lvm_monad; f_term; f_binder; f_binding_bv; f_br; f_comp; + f_residual_comp; f_univ; proc_quotes;_} -> f_binding_bv +let __proj__Mklvm__item__f_br : + 'm . 'm lvm -> ('m, FStarC_Syntax_Syntax.branch) endo = + fun projectee -> + match projectee with + | { lvm_monad; f_term; f_binder; f_binding_bv; f_br; f_comp; + f_residual_comp; f_univ; proc_quotes;_} -> f_br +let __proj__Mklvm__item__f_comp : + 'm . 'm lvm -> ('m, FStarC_Syntax_Syntax.comp) endo = + fun projectee -> + match projectee with + | { lvm_monad; f_term; f_binder; f_binding_bv; f_br; f_comp; + f_residual_comp; f_univ; proc_quotes;_} -> f_comp +let __proj__Mklvm__item__f_residual_comp : + 'm . 'm lvm -> ('m, FStarC_Syntax_Syntax.residual_comp) endo = + fun projectee -> + match projectee with + | { lvm_monad; f_term; f_binder; f_binding_bv; f_br; f_comp; + f_residual_comp; f_univ; proc_quotes;_} -> f_residual_comp +let __proj__Mklvm__item__f_univ : + 'm . 'm lvm -> ('m, FStarC_Syntax_Syntax.universe) endo = + fun projectee -> + match projectee with + | { lvm_monad; f_term; f_binder; f_binding_bv; f_br; f_comp; + f_residual_comp; f_univ; proc_quotes;_} -> f_univ +let __proj__Mklvm__item__proc_quotes : 'm . 'm lvm -> Prims.bool = + fun projectee -> + match projectee with + | { lvm_monad; f_term; f_binder; f_binding_bv; f_br; f_comp; + f_residual_comp; f_univ; proc_quotes;_} -> proc_quotes +let lvm_monad : 'm . 'm lvm -> 'm FStarC_Class_Monad.monad = + fun projectee -> + match projectee with + | { lvm_monad = lvm_monad1; f_term; f_binder; f_binding_bv; f_br; + f_comp; f_residual_comp; f_univ; proc_quotes;_} -> lvm_monad1 +let f_term : 'm . 'm lvm -> ('m, FStarC_Syntax_Syntax.term) endo = + fun projectee -> + match projectee with + | { lvm_monad = lvm_monad1; f_term = f_term1; f_binder; f_binding_bv; + f_br; f_comp; f_residual_comp; f_univ; proc_quotes;_} -> f_term1 +let f_binder : 'm . 'm lvm -> ('m, FStarC_Syntax_Syntax.binder) endo = + fun projectee -> + match projectee with + | { lvm_monad = lvm_monad1; f_term = f_term1; f_binder = f_binder1; + f_binding_bv; f_br; f_comp; f_residual_comp; f_univ; proc_quotes;_} + -> f_binder1 +let f_binding_bv : 'm . 'm lvm -> ('m, FStarC_Syntax_Syntax.bv) endo = + fun projectee -> + match projectee with + | { lvm_monad = lvm_monad1; f_term = f_term1; f_binder = f_binder1; + f_binding_bv = f_binding_bv1; f_br; f_comp; f_residual_comp; + f_univ; proc_quotes;_} -> f_binding_bv1 +let f_br : 'm . 'm lvm -> ('m, FStarC_Syntax_Syntax.branch) endo = + fun projectee -> + match projectee with + | { lvm_monad = lvm_monad1; f_term = f_term1; f_binder = f_binder1; + f_binding_bv = f_binding_bv1; f_br = f_br1; f_comp; f_residual_comp; + f_univ; proc_quotes;_} -> f_br1 +let f_comp : 'm . 'm lvm -> ('m, FStarC_Syntax_Syntax.comp) endo = + fun projectee -> + match projectee with + | { lvm_monad = lvm_monad1; f_term = f_term1; f_binder = f_binder1; + f_binding_bv = f_binding_bv1; f_br = f_br1; f_comp = f_comp1; + f_residual_comp; f_univ; proc_quotes;_} -> f_comp1 +let f_residual_comp : + 'm . 'm lvm -> ('m, FStarC_Syntax_Syntax.residual_comp) endo = + fun projectee -> + match projectee with + | { lvm_monad = lvm_monad1; f_term = f_term1; f_binder = f_binder1; + f_binding_bv = f_binding_bv1; f_br = f_br1; f_comp = f_comp1; + f_residual_comp = f_residual_comp1; f_univ; proc_quotes;_} -> + f_residual_comp1 +let f_univ : 'm . 'm lvm -> ('m, FStarC_Syntax_Syntax.universe) endo = + fun projectee -> + match projectee with + | { lvm_monad = lvm_monad1; f_term = f_term1; f_binder = f_binder1; + f_binding_bv = f_binding_bv1; f_br = f_br1; f_comp = f_comp1; + f_residual_comp = f_residual_comp1; f_univ = f_univ1; proc_quotes;_} + -> f_univ1 +let proc_quotes : 'm . 'm lvm -> Prims.bool = + fun projectee -> + match projectee with + | { lvm_monad = lvm_monad1; f_term = f_term1; f_binder = f_binder1; + f_binding_bv = f_binding_bv1; f_br = f_br1; f_comp = f_comp1; + f_residual_comp = f_residual_comp1; f_univ = f_univ1; + proc_quotes = proc_quotes1;_} -> proc_quotes1 +let _lvm_monad : 'm . 'm lvm -> 'm FStarC_Class_Monad.monad = + fun uu___ -> lvm_monad uu___ +let novfs : 'm . 'm FStarC_Class_Monad.monad -> 'm lvm = + fun uu___ -> + { + lvm_monad = uu___; + f_term = (Obj.magic (FStarC_Class_Monad.return uu___ ())); + f_binder = (Obj.magic (FStarC_Class_Monad.return uu___ ())); + f_binding_bv = (Obj.magic (FStarC_Class_Monad.return uu___ ())); + f_br = (Obj.magic (FStarC_Class_Monad.return uu___ ())); + f_comp = (Obj.magic (FStarC_Class_Monad.return uu___ ())); + f_residual_comp = (Obj.magic (FStarC_Class_Monad.return uu___ ())); + f_univ = (Obj.magic (FStarC_Class_Monad.return uu___ ())); + proc_quotes = false + } +let f_aqual : 'm . 'm lvm -> FStarC_Syntax_Syntax.arg_qualifier -> 'm = + fun uu___ -> + fun aq -> + let uu___1 = aq in + match uu___1 with + | { FStarC_Syntax_Syntax.aqual_implicit = i; + FStarC_Syntax_Syntax.aqual_attributes = attrs;_} -> + let uu___2 = + FStarC_Class_Monad.mapM (_lvm_monad uu___) () () + (fun uu___3 -> (Obj.magic (f_term uu___)) uu___3) + (Obj.magic attrs) in + FStarC_Class_Monad.op_let_Bang (_lvm_monad uu___) () () uu___2 + (fun uu___3 -> + (fun attrs1 -> + let attrs1 = Obj.magic attrs1 in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad uu___) () + (Obj.magic + { + FStarC_Syntax_Syntax.aqual_implicit = i; + FStarC_Syntax_Syntax.aqual_attributes = attrs1 + }))) uu___3) +let on_sub_arg : 'm . 'm lvm -> FStarC_Syntax_Syntax.arg -> 'm = + fun uu___ -> + fun a -> + let uu___1 = a in + match uu___1 with + | (t, q) -> + let uu___2 = f_term uu___ t in + FStarC_Class_Monad.op_let_Bang (_lvm_monad uu___) () () uu___2 + (fun uu___3 -> + (fun t1 -> + let t1 = Obj.magic t1 in + let uu___3 = + FStarC_Class_Monad.map_optM (_lvm_monad uu___) () () + (fun uu___4 -> (Obj.magic (f_aqual uu___)) uu___4) + (Obj.magic q) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad uu___) () () + uu___3 + (fun uu___4 -> + (fun q1 -> + let q1 = Obj.magic q1 in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad uu___) + () (Obj.magic (t1, q1)))) uu___4))) uu___3) +let on_sub_tscheme : + 'm . + 'm FStarC_Class_Monad.monad -> + 'm lvm -> FStarC_Syntax_Syntax.tscheme -> 'm + = + fun uu___ -> + fun uu___1 -> + fun ts -> + let uu___2 = ts in + match uu___2 with + | (us, t) -> + let uu___3 = f_term uu___1 t in + FStarC_Class_Monad.op_let_Bang uu___ () () uu___3 + (fun uu___4 -> + (fun t1 -> + let t1 = Obj.magic t1 in + Obj.magic + (FStarC_Class_Monad.return uu___ () + (Obj.magic (us, t1)))) uu___4) +let f_arg : 'm . 'm lvm -> FStarC_Syntax_Syntax.arg -> 'm = + fun uu___ -> on_sub_arg uu___ +let f_args : 'm . 'm lvm -> FStarC_Syntax_Syntax.arg Prims.list -> 'm = + fun uu___1 -> + fun uu___ -> + (fun d -> + let uu___ = f_arg d in + Obj.magic + (FStarC_Class_Monad.mapM (_lvm_monad d) () () + (fun uu___1 -> (Obj.magic uu___) uu___1))) uu___1 uu___ +let f_tscheme : 'm . 'm lvm -> FStarC_Syntax_Syntax.tscheme -> 'm = + fun uu___ -> on_sub_tscheme (_lvm_monad uu___) uu___ +let on_sub_meta : 'm . 'm lvm -> FStarC_Syntax_Syntax.metadata -> 'm = + fun d -> + fun md -> + match md with + | FStarC_Syntax_Syntax.Meta_pattern (pats, args) -> + let uu___ = + FStarC_Class_Monad.mapM (_lvm_monad d) () () + (fun uu___1 -> (Obj.magic (f_term d)) uu___1) (Obj.magic pats) in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun pats1 -> + let pats1 = Obj.magic pats1 in + let uu___1 = + let uu___2 = f_args d in + FStarC_Class_Monad.mapM (_lvm_monad d) () () + (fun uu___3 -> (Obj.magic uu___2) uu___3) + (Obj.magic args) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () + uu___1 + (fun uu___2 -> + (fun args1 -> + let args1 = Obj.magic args1 in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic + (FStarC_Syntax_Syntax.Meta_pattern + (pats1, args1))))) uu___2))) uu___1) + | FStarC_Syntax_Syntax.Meta_monadic (m1, typ) -> + let uu___ = f_term d typ in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun typ1 -> + let typ1 = Obj.magic typ1 in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic + (FStarC_Syntax_Syntax.Meta_monadic (m1, typ1))))) + uu___1) + | FStarC_Syntax_Syntax.Meta_monadic_lift (m1, m2, typ) -> + let uu___ = f_term d typ in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun typ1 -> + let typ1 = Obj.magic typ1 in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic + (FStarC_Syntax_Syntax.Meta_monadic_lift + (m1, m2, typ1))))) uu___1) + | FStarC_Syntax_Syntax.Meta_named lid -> + FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic (FStarC_Syntax_Syntax.Meta_named lid)) + | FStarC_Syntax_Syntax.Meta_labeled (s, r, b) -> + FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic (FStarC_Syntax_Syntax.Meta_labeled (s, r, b))) + | FStarC_Syntax_Syntax.Meta_desugared i -> + FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic (FStarC_Syntax_Syntax.Meta_desugared i)) +let on_sub_letbinding : 'm . 'm lvm -> FStarC_Syntax_Syntax.letbinding -> 'm + = + fun uu___ -> + fun lb -> + let uu___1 = + match lb.FStarC_Syntax_Syntax.lbname with + | FStar_Pervasives.Inl bv -> + let uu___2 = f_binding_bv uu___ bv in + FStarC_Class_Monad.op_Less_Dollar_Greater (_lvm_monad uu___) () + () + (fun uu___3 -> + (fun uu___3 -> + let uu___3 = Obj.magic uu___3 in + Obj.magic (FStar_Pervasives.Inl uu___3)) uu___3) uu___2 + | FStar_Pervasives.Inr fv -> + FStarC_Class_Monad.return (_lvm_monad uu___) () + (Obj.magic (FStar_Pervasives.Inr fv)) in + FStarC_Class_Monad.op_let_Bang (_lvm_monad uu___) () () uu___1 + (fun uu___2 -> + (fun lbname -> + let lbname = Obj.magic lbname in + let lbunivs = lb.FStarC_Syntax_Syntax.lbunivs in + let uu___2 = f_term uu___ lb.FStarC_Syntax_Syntax.lbtyp in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad uu___) () () + uu___2 + (fun uu___3 -> + (fun lbtyp -> + let lbtyp = Obj.magic lbtyp in + let lbeff = lb.FStarC_Syntax_Syntax.lbeff in + let uu___3 = + FStarC_Class_Monad.mapM (_lvm_monad uu___) () () + (fun uu___4 -> (Obj.magic (f_term uu___)) uu___4) + (Obj.magic lb.FStarC_Syntax_Syntax.lbattrs) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad uu___) + () () uu___3 + (fun uu___4 -> + (fun lbattrs -> + let lbattrs = Obj.magic lbattrs in + let lbpos = lb.FStarC_Syntax_Syntax.lbpos in + let uu___4 = + f_term uu___ + lb.FStarC_Syntax_Syntax.lbdef in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + (_lvm_monad uu___) () () uu___4 + (fun uu___5 -> + (fun lbdef -> + let lbdef = Obj.magic lbdef in + Obj.magic + (FStarC_Class_Monad.return + (_lvm_monad uu___) () + (Obj.magic + { + FStarC_Syntax_Syntax.lbname + = lbname; + FStarC_Syntax_Syntax.lbunivs + = lbunivs; + FStarC_Syntax_Syntax.lbtyp + = lbtyp; + FStarC_Syntax_Syntax.lbeff + = lbeff; + FStarC_Syntax_Syntax.lbdef + = lbdef; + FStarC_Syntax_Syntax.lbattrs + = lbattrs; + FStarC_Syntax_Syntax.lbpos + = lbpos + }))) uu___5))) uu___4))) + uu___3))) uu___2) +let on_sub_ascription : 'm . 'm lvm -> FStarC_Syntax_Syntax.ascription -> 'm + = + fun uu___ -> + fun a -> + let uu___1 = a in + match uu___1 with + | (tc, tacopt, b) -> + let uu___2 = + match tc with + | FStar_Pervasives.Inl t -> + let uu___3 = f_term uu___ t in + FStarC_Class_Monad.op_Less_Dollar_Greater (_lvm_monad uu___) + () () + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + Obj.magic (FStar_Pervasives.Inl uu___4)) uu___4) + uu___3 + | FStar_Pervasives.Inr c -> + let uu___3 = f_comp uu___ c in + FStarC_Class_Monad.op_Less_Dollar_Greater (_lvm_monad uu___) + () () + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + Obj.magic (FStar_Pervasives.Inr uu___4)) uu___4) + uu___3 in + FStarC_Class_Monad.op_let_Bang (_lvm_monad uu___) () () uu___2 + (fun uu___3 -> + (fun tc1 -> + let tc1 = Obj.magic tc1 in + let uu___3 = + FStarC_Class_Monad.map_optM (_lvm_monad uu___) () () + (fun uu___4 -> (Obj.magic (f_term uu___)) uu___4) + (Obj.magic tacopt) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad uu___) () () + uu___3 + (fun uu___4 -> + (fun tacopt1 -> + let tacopt1 = Obj.magic tacopt1 in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad uu___) + () (Obj.magic (tc1, tacopt1, b)))) uu___4))) + uu___3) +let rec (compress : FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) = + fun tm -> + let tm1 = FStarC_Syntax_Subst.compress tm in + match tm1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_lazy li -> + let tm' = + let uu___ = + let uu___1 = + FStarC_Compiler_Effect.op_Bang + FStarC_Syntax_Syntax.lazy_chooser in + FStarC_Compiler_Util.must uu___1 in + uu___ li.FStarC_Syntax_Syntax.lkind li in + compress tm' + | uu___ -> tm1 +let on_sub_term : 'm . 'm lvm -> FStarC_Syntax_Syntax.term -> 'm = + fun d -> + fun tm -> + let mk t = FStarC_Syntax_Syntax.mk t tm.FStarC_Syntax_Syntax.pos in + let tm1 = compress tm in + match tm1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_lazy uu___ -> failwith "impos" + | FStarC_Syntax_Syntax.Tm_delayed uu___ -> failwith "impos" + | FStarC_Syntax_Syntax.Tm_fvar uu___ -> + FStarC_Class_Monad.return (_lvm_monad d) () (Obj.magic tm1) + | FStarC_Syntax_Syntax.Tm_constant uu___ -> + FStarC_Class_Monad.return (_lvm_monad d) () (Obj.magic tm1) + | FStarC_Syntax_Syntax.Tm_unknown -> + FStarC_Class_Monad.return (_lvm_monad d) () (Obj.magic tm1) + | FStarC_Syntax_Syntax.Tm_bvar uu___ -> + FStarC_Class_Monad.return (_lvm_monad d) () (Obj.magic tm1) + | FStarC_Syntax_Syntax.Tm_name uu___ -> + FStarC_Class_Monad.return (_lvm_monad d) () (Obj.magic tm1) + | FStarC_Syntax_Syntax.Tm_uvar uu___ -> + FStarC_Class_Monad.return (_lvm_monad d) () (Obj.magic tm1) + | FStarC_Syntax_Syntax.Tm_uinst (f, us) -> + let uu___ = f_term d f in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun f1 -> + let f1 = Obj.magic f1 in + let uu___1 = + FStarC_Class_Monad.mapM (_lvm_monad d) () () + (fun uu___2 -> (Obj.magic (f_univ d)) uu___2) + (Obj.magic us) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () + uu___1 + (fun uu___2 -> + (fun us1 -> + let us1 = Obj.magic us1 in + let uu___2 = + mk (FStarC_Syntax_Syntax.Tm_uinst (f1, us1)) in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic uu___2))) uu___2))) uu___1) + | FStarC_Syntax_Syntax.Tm_type u -> + let uu___ = f_univ d u in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun u1 -> + let u1 = Obj.magic u1 in + let uu___1 = mk (FStarC_Syntax_Syntax.Tm_type u1) in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic uu___1))) uu___1) + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = hd; FStarC_Syntax_Syntax.args = args;_} + -> + let uu___ = f_term d hd in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun hd1 -> + let hd1 = Obj.magic hd1 in + let uu___1 = + let uu___2 = f_arg d in + FStarC_Class_Monad.mapM (_lvm_monad d) () () + (fun uu___3 -> (Obj.magic uu___2) uu___3) + (Obj.magic args) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () + uu___1 + (fun uu___2 -> + (fun args1 -> + let args1 = Obj.magic args1 in + let uu___2 = + mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = hd1; + FStarC_Syntax_Syntax.args = args1 + }) in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic uu___2))) uu___2))) uu___1) + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs; FStarC_Syntax_Syntax.body = t; + FStarC_Syntax_Syntax.rc_opt = rc_opt;_} + -> + let uu___ = + FStarC_Class_Monad.mapM (_lvm_monad d) () () + (fun uu___1 -> (Obj.magic (f_binder d)) uu___1) (Obj.magic bs) in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun bs1 -> + let bs1 = Obj.magic bs1 in + let uu___1 = f_term d t in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () + uu___1 + (fun uu___2 -> + (fun t1 -> + let t1 = Obj.magic t1 in + let uu___2 = + FStarC_Class_Monad.map_optM (_lvm_monad d) () + () + (fun uu___3 -> + (Obj.magic (f_residual_comp d)) uu___3) + (Obj.magic rc_opt) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) + () () uu___2 + (fun uu___3 -> + (fun rc_opt1 -> + let rc_opt1 = Obj.magic rc_opt1 in + let uu___3 = + mk + (FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs = + bs1; + FStarC_Syntax_Syntax.body = + t1; + FStarC_Syntax_Syntax.rc_opt + = rc_opt1 + }) in + Obj.magic + (FStarC_Class_Monad.return + (_lvm_monad d) () + (Obj.magic uu___3))) uu___3))) + uu___2))) uu___1) + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; FStarC_Syntax_Syntax.comp = c;_} + -> + let uu___ = + FStarC_Class_Monad.mapM (_lvm_monad d) () () + (fun uu___1 -> (Obj.magic (f_binder d)) uu___1) (Obj.magic bs) in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun bs1 -> + let bs1 = Obj.magic bs1 in + let uu___1 = f_comp d c in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () + uu___1 + (fun uu___2 -> + (fun c1 -> + let c1 = Obj.magic c1 in + let uu___2 = + mk + (FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 = bs1; + FStarC_Syntax_Syntax.comp = c1 + }) in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic uu___2))) uu___2))) uu___1) + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = bv; FStarC_Syntax_Syntax.phi = phi;_} -> + let uu___ = f_binding_bv d bv in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun bv1 -> + let bv1 = Obj.magic bv1 in + let uu___1 = f_term d phi in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () + uu___1 + (fun uu___2 -> + (fun phi1 -> + let phi1 = Obj.magic phi1 in + let uu___2 = + mk + (FStarC_Syntax_Syntax.Tm_refine + { + FStarC_Syntax_Syntax.b = bv1; + FStarC_Syntax_Syntax.phi = phi1 + }) in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic uu___2))) uu___2))) uu___1) + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = sc; + FStarC_Syntax_Syntax.ret_opt = asc_opt; + FStarC_Syntax_Syntax.brs = brs; + FStarC_Syntax_Syntax.rc_opt1 = rc_opt;_} + -> + let uu___ = f_term d sc in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun sc1 -> + let sc1 = Obj.magic sc1 in + let uu___1 = + FStarC_Class_Monad.map_optM (_lvm_monad d) () () + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + match uu___2 with + | (b, asc) -> + let uu___3 = + let uu___4 = f_binder d b in + FStarC_Class_Monad.op_Less_Dollar_Greater + (_lvm_monad d) () () + (fun uu___5 -> + (fun uu___5 -> + let uu___5 = Obj.magic uu___5 in + Obj.magic + (fun uu___6 -> (uu___5, uu___6))) + uu___5) uu___4 in + let uu___4 = on_sub_ascription d asc in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + (_lvm_monad d) () () uu___3 uu___4)) + uu___2) (Obj.magic asc_opt) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () + uu___1 + (fun uu___2 -> + (fun asc_opt1 -> + let asc_opt1 = Obj.magic asc_opt1 in + let uu___2 = + FStarC_Class_Monad.mapM (_lvm_monad d) () () + (fun uu___3 -> (Obj.magic (f_br d)) uu___3) + (Obj.magic brs) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) + () () uu___2 + (fun uu___3 -> + (fun brs1 -> + let brs1 = Obj.magic brs1 in + let uu___3 = + FStarC_Class_Monad.map_optM + (_lvm_monad d) () () + (fun uu___4 -> + (Obj.magic (f_residual_comp d)) + uu___4) (Obj.magic rc_opt) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + (_lvm_monad d) () () uu___3 + (fun uu___4 -> + (fun rc_opt1 -> + let rc_opt1 = + Obj.magic rc_opt1 in + let uu___4 = + mk + (FStarC_Syntax_Syntax.Tm_match + { + FStarC_Syntax_Syntax.scrutinee + = sc1; + FStarC_Syntax_Syntax.ret_opt + = asc_opt1; + FStarC_Syntax_Syntax.brs + = brs1; + FStarC_Syntax_Syntax.rc_opt1 + = rc_opt1 + }) in + Obj.magic + (FStarC_Class_Monad.return + (_lvm_monad d) () + (Obj.magic uu___4))) + uu___4))) uu___3))) uu___2))) + uu___1) + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = e; FStarC_Syntax_Syntax.asc = a; + FStarC_Syntax_Syntax.eff_opt = lopt;_} + -> + let uu___ = f_term d e in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun e1 -> + let e1 = Obj.magic e1 in + let uu___1 = on_sub_ascription d a in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () + uu___1 + (fun uu___2 -> + (fun a1 -> + let a1 = Obj.magic a1 in + let uu___2 = + mk + (FStarC_Syntax_Syntax.Tm_ascribed + { + FStarC_Syntax_Syntax.tm = e1; + FStarC_Syntax_Syntax.asc = a1; + FStarC_Syntax_Syntax.eff_opt = lopt + }) in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic uu___2))) uu___2))) uu___1) + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (is_rec, lbs); + FStarC_Syntax_Syntax.body1 = t;_} + -> + let uu___ = + FStarC_Class_Monad.mapM (_lvm_monad d) () () + (fun uu___1 -> (Obj.magic (on_sub_letbinding d)) uu___1) + (Obj.magic lbs) in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun lbs1 -> + let lbs1 = Obj.magic lbs1 in + let uu___1 = f_term d t in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () + uu___1 + (fun uu___2 -> + (fun t1 -> + let t1 = Obj.magic t1 in + let uu___2 = + mk + (FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = + (is_rec, lbs1); + FStarC_Syntax_Syntax.body1 = t1 + }) in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic uu___2))) uu___2))) uu___1) + | FStarC_Syntax_Syntax.Tm_quoted (qtm, qi) -> + if + d.proc_quotes || + (qi.FStarC_Syntax_Syntax.qkind = + FStarC_Syntax_Syntax.Quote_dynamic) + then + let uu___ = f_term d qtm in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun qtm1 -> + let qtm1 = Obj.magic qtm1 in + let uu___1 = + mk (FStarC_Syntax_Syntax.Tm_quoted (qtm1, qi)) in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic uu___1))) uu___1) + else FStarC_Class_Monad.return (_lvm_monad d) () (Obj.magic tm1) + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t; FStarC_Syntax_Syntax.meta = md;_} + -> + let uu___ = f_term d t in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun t1 -> + let t1 = Obj.magic t1 in + let uu___1 = on_sub_meta d md in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () + uu___1 + (fun uu___2 -> + (fun md1 -> + let md1 = Obj.magic md1 in + let uu___2 = + mk + (FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 = t1; + FStarC_Syntax_Syntax.meta = md1 + }) in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic uu___2))) uu___2))) uu___1) +let on_sub_binding_bv : 'm . 'm lvm -> FStarC_Syntax_Syntax.bv -> 'm = + fun d -> + fun x -> + let uu___ = f_term d x.FStarC_Syntax_Syntax.sort in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun sort -> + let sort = Obj.magic sort in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic + { + FStarC_Syntax_Syntax.ppname = + (x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (x.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = sort + }))) uu___1) +let on_sub_binder : 'm . 'm lvm -> FStarC_Syntax_Syntax.binder -> 'm = + fun d -> + fun b -> + let uu___ = f_binding_bv d b.FStarC_Syntax_Syntax.binder_bv in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun binder_bv -> + let binder_bv = Obj.magic binder_bv in + let uu___1 = + FStarC_Class_Monad.map_optM (_lvm_monad d) () () + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + match uu___2 with + | FStarC_Syntax_Syntax.Meta t -> + let uu___3 = f_term d t in + Obj.magic + (FStarC_Class_Monad.op_Less_Dollar_Greater + (_lvm_monad d) () () + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + Obj.magic + (FStarC_Syntax_Syntax.Meta uu___4)) + uu___4) uu___3) + | q -> + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic q))) uu___2) + (Obj.magic b.FStarC_Syntax_Syntax.binder_qual) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___1 + (fun uu___2 -> + (fun binder_qual -> + let binder_qual = Obj.magic binder_qual in + let binder_positivity = + b.FStarC_Syntax_Syntax.binder_positivity in + let uu___2 = + FStarC_Class_Monad.mapM (_lvm_monad d) () () + (fun uu___3 -> (Obj.magic (f_term d)) uu___3) + (Obj.magic b.FStarC_Syntax_Syntax.binder_attrs) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () + () uu___2 + (fun uu___3 -> + (fun binder_attrs -> + let binder_attrs = Obj.magic binder_attrs in + Obj.magic + (FStarC_Class_Monad.return + (_lvm_monad d) () + (Obj.magic + { + FStarC_Syntax_Syntax.binder_bv + = binder_bv; + FStarC_Syntax_Syntax.binder_qual + = binder_qual; + FStarC_Syntax_Syntax.binder_positivity + = binder_positivity; + FStarC_Syntax_Syntax.binder_attrs + = binder_attrs + }))) uu___3))) uu___2))) uu___1) +let rec on_sub_pat : 'm . 'm lvm -> FStarC_Syntax_Syntax.pat -> 'm = + fun d -> + fun p0 -> + let mk p = + { + FStarC_Syntax_Syntax.v = p; + FStarC_Syntax_Syntax.p = (p0.FStarC_Syntax_Syntax.p) + } in + match p0.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_constant uu___ -> + FStarC_Class_Monad.return (_lvm_monad d) () (Obj.magic p0) + | FStarC_Syntax_Syntax.Pat_cons (fv, us, subpats) -> + let uu___ = + FStarC_Class_Monad.map_optM (_lvm_monad d) () () + (fun uu___1 -> + (Obj.magic + (FStarC_Class_Monad.mapM (_lvm_monad d) () () + (fun uu___1 -> (Obj.magic (f_univ d)) uu___1))) uu___1) + (Obj.magic us) in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun us1 -> + let us1 = Obj.magic us1 in + let uu___1 = + FStarC_Class_Monad.mapM (_lvm_monad d) () () + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + match uu___2 with + | (p, b) -> + let uu___3 = + let uu___4 = on_sub_pat d p in + FStarC_Class_Monad.op_Less_Dollar_Greater + (_lvm_monad d) () () + (fun uu___5 -> + (fun uu___5 -> + let uu___5 = Obj.magic uu___5 in + Obj.magic + (fun uu___6 -> (uu___5, uu___6))) + uu___5) uu___4 in + let uu___4 = + FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic b) in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + (_lvm_monad d) () () uu___3 uu___4)) + uu___2) (Obj.magic subpats) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () + uu___1 + (fun uu___2 -> + (fun subpats1 -> + let subpats1 = Obj.magic subpats1 in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic + (mk + (FStarC_Syntax_Syntax.Pat_cons + (fv, us1, subpats1)))))) uu___2))) + uu___1) + | FStarC_Syntax_Syntax.Pat_var bv -> + let uu___ = f_binding_bv d bv in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun bv1 -> + let bv1 = Obj.magic bv1 in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic (mk (FStarC_Syntax_Syntax.Pat_var bv1))))) + uu___1) + | FStarC_Syntax_Syntax.Pat_dot_term t -> + let uu___ = + FStarC_Class_Monad.map_optM (_lvm_monad d) () () + (fun uu___1 -> (Obj.magic (f_term d)) uu___1) (Obj.magic t) in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun t1 -> + let t1 = Obj.magic t1 in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic (mk (FStarC_Syntax_Syntax.Pat_dot_term t1))))) + uu___1) +let on_sub_br : + 'm . + 'm lvm -> + (FStarC_Syntax_Syntax.pat * FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option * FStarC_Syntax_Syntax.term) -> + 'm + = + fun d -> + fun br -> + let uu___ = br in + match uu___ with + | (pat, wopt, body) -> + let uu___1 = on_sub_pat d pat in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___1 + (fun uu___2 -> + (fun pat1 -> + let pat1 = Obj.magic pat1 in + let uu___2 = + FStarC_Class_Monad.map_optM (_lvm_monad d) () () + (fun uu___3 -> (Obj.magic (f_term d)) uu___3) + (Obj.magic wopt) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () + uu___2 + (fun uu___3 -> + (fun wopt1 -> + let wopt1 = Obj.magic wopt1 in + let uu___3 = f_term d body in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) + () () uu___3 + (fun uu___4 -> + (fun body1 -> + let body1 = Obj.magic body1 in + Obj.magic + (FStarC_Class_Monad.return + (_lvm_monad d) () + (Obj.magic (pat1, wopt1, body1)))) + uu___4))) uu___3))) uu___2) +let on_sub_comp_typ : 'm . 'm lvm -> FStarC_Syntax_Syntax.comp_typ -> 'm = + fun d -> + fun ct -> + let uu___ = + FStarC_Class_Monad.mapM (_lvm_monad d) () () + (fun uu___1 -> (Obj.magic (f_univ d)) uu___1) + (Obj.magic ct.FStarC_Syntax_Syntax.comp_univs) in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun comp_univs -> + let comp_univs = Obj.magic comp_univs in + let effect_name = ct.FStarC_Syntax_Syntax.effect_name in + let uu___1 = f_term d ct.FStarC_Syntax_Syntax.result_typ in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___1 + (fun uu___2 -> + (fun result_typ -> + let result_typ = Obj.magic result_typ in + let uu___2 = + let uu___3 = f_arg d in + FStarC_Class_Monad.mapM (_lvm_monad d) () () + (fun uu___4 -> (Obj.magic uu___3) uu___4) + (Obj.magic ct.FStarC_Syntax_Syntax.effect_args) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () + () uu___2 + (fun uu___3 -> + (fun effect_args -> + let effect_args = Obj.magic effect_args in + let flags = ct.FStarC_Syntax_Syntax.flags in + Obj.magic + (FStarC_Class_Monad.return + (_lvm_monad d) () + (Obj.magic + { + FStarC_Syntax_Syntax.comp_univs + = comp_univs; + FStarC_Syntax_Syntax.effect_name + = effect_name; + FStarC_Syntax_Syntax.result_typ + = result_typ; + FStarC_Syntax_Syntax.effect_args + = effect_args; + FStarC_Syntax_Syntax.flags = + flags + }))) uu___3))) uu___2))) uu___1) +let on_sub_comp : + 'm . 'm lvm -> FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> 'm + = + fun d -> + fun c -> + let uu___ = + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total typ -> + let uu___1 = f_term d typ in + FStarC_Class_Monad.op_Less_Dollar_Greater (_lvm_monad d) () () + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + Obj.magic (FStarC_Syntax_Syntax.Total uu___2)) uu___2) + uu___1 + | FStarC_Syntax_Syntax.GTotal typ -> + let uu___1 = f_term d typ in + FStarC_Class_Monad.op_Less_Dollar_Greater (_lvm_monad d) () () + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + Obj.magic (FStarC_Syntax_Syntax.GTotal uu___2)) uu___2) + uu___1 + | FStarC_Syntax_Syntax.Comp ct -> + let uu___1 = on_sub_comp_typ d ct in + FStarC_Class_Monad.op_Less_Dollar_Greater (_lvm_monad d) () () + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + Obj.magic (FStarC_Syntax_Syntax.Comp uu___2)) uu___2) + uu___1 in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun cn -> + let cn = Obj.magic cn in + let uu___1 = + FStarC_Syntax_Syntax.mk cn c.FStarC_Syntax_Syntax.pos in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic uu___1))) uu___1) +let __on_decreases : + 'm . + 'm lvm -> + (FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> 'm) -> + FStarC_Syntax_Syntax.cflag -> 'm + = + fun d -> + fun f -> + fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.DECREASES (FStarC_Syntax_Syntax.Decreases_lex + l) -> + let uu___1 = + let uu___2 = + FStarC_Class_Monad.mapM (_lvm_monad d) () () + (fun uu___3 -> (Obj.magic f) uu___3) (Obj.magic l) in + FStarC_Class_Monad.op_Less_Dollar_Greater (_lvm_monad d) () () + (fun uu___3 -> + (fun uu___3 -> + let uu___3 = Obj.magic uu___3 in + Obj.magic (FStarC_Syntax_Syntax.Decreases_lex uu___3)) + uu___3) uu___2 in + FStarC_Class_Monad.op_Less_Dollar_Greater (_lvm_monad d) () () + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + Obj.magic (FStarC_Syntax_Syntax.DECREASES uu___2)) uu___2) + uu___1 + | FStarC_Syntax_Syntax.DECREASES (FStarC_Syntax_Syntax.Decreases_wf + (r, t)) -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = f r in + FStarC_Class_Monad.op_Less_Dollar_Greater (_lvm_monad d) () + () + (fun uu___5 -> + (fun uu___5 -> + let uu___5 = Obj.magic uu___5 in + Obj.magic (fun uu___6 -> (uu___5, uu___6))) uu___5) + uu___4 in + let uu___4 = f t in + FStarC_Class_Monad.op_Less_Star_Greater (_lvm_monad d) () () + uu___3 uu___4 in + FStarC_Class_Monad.op_Less_Dollar_Greater (_lvm_monad d) () () + (fun uu___3 -> + (fun uu___3 -> + let uu___3 = Obj.magic uu___3 in + Obj.magic (FStarC_Syntax_Syntax.Decreases_wf uu___3)) + uu___3) uu___2 in + FStarC_Class_Monad.op_Less_Dollar_Greater (_lvm_monad d) () () + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + Obj.magic (FStarC_Syntax_Syntax.DECREASES uu___2)) uu___2) + uu___1 + | f1 -> FStarC_Class_Monad.return (_lvm_monad d) () (Obj.magic f1) +let on_sub_residual_comp : + 'm . 'm lvm -> FStarC_Syntax_Syntax.residual_comp -> 'm = + fun d -> + fun rc -> + let residual_effect = rc.FStarC_Syntax_Syntax.residual_effect in + let uu___ = + FStarC_Class_Monad.map_optM (_lvm_monad d) () () + (fun uu___1 -> (Obj.magic (f_term d)) uu___1) + (Obj.magic rc.FStarC_Syntax_Syntax.residual_typ) in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun residual_typ -> + let residual_typ = Obj.magic residual_typ in + let uu___1 = + let uu___2 = __on_decreases d (f_term d) in + FStarC_Class_Monad.mapM (_lvm_monad d) () () + (fun uu___3 -> (Obj.magic uu___2) uu___3) + (Obj.magic rc.FStarC_Syntax_Syntax.residual_flags) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___1 + (fun uu___2 -> + (fun residual_flags -> + let residual_flags = Obj.magic residual_flags in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic + { + FStarC_Syntax_Syntax.residual_effect = + residual_effect; + FStarC_Syntax_Syntax.residual_typ = + residual_typ; + FStarC_Syntax_Syntax.residual_flags = + residual_flags + }))) uu___2))) uu___1) +let on_sub_univ : 'm . 'm lvm -> FStarC_Syntax_Syntax.universe -> 'm = + fun d -> + fun u -> + let u1 = FStarC_Syntax_Subst.compress_univ u in + match u1 with + | FStarC_Syntax_Syntax.U_max us -> + let uu___ = + FStarC_Class_Monad.mapM (_lvm_monad d) () () + (fun uu___1 -> (Obj.magic (f_univ d)) uu___1) (Obj.magic us) in + FStarC_Class_Monad.op_Less_Dollar_Greater (_lvm_monad d) () () + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + Obj.magic (FStarC_Syntax_Syntax.U_max uu___1)) uu___1) + uu___ + | FStarC_Syntax_Syntax.U_succ u2 -> + let uu___ = f_univ d u2 in + FStarC_Class_Monad.op_Less_Dollar_Greater (_lvm_monad d) () () + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + Obj.magic (FStarC_Syntax_Syntax.U_succ uu___1)) uu___1) + uu___ + | FStarC_Syntax_Syntax.U_zero -> + FStarC_Class_Monad.return (_lvm_monad d) () (Obj.magic u1) + | FStarC_Syntax_Syntax.U_bvar uu___ -> + FStarC_Class_Monad.return (_lvm_monad d) () (Obj.magic u1) + | FStarC_Syntax_Syntax.U_name uu___ -> + FStarC_Class_Monad.return (_lvm_monad d) () (Obj.magic u1) + | FStarC_Syntax_Syntax.U_unknown -> + FStarC_Class_Monad.return (_lvm_monad d) () (Obj.magic u1) + | FStarC_Syntax_Syntax.U_unif uu___ -> + FStarC_Class_Monad.return (_lvm_monad d) () (Obj.magic u1) +let on_sub_wp_eff_combinators : + 'm . 'm lvm -> FStarC_Syntax_Syntax.wp_eff_combinators -> 'm = + fun d -> + fun wpcs -> + let uu___ = + let uu___1 = f_tscheme d in uu___1 wpcs.FStarC_Syntax_Syntax.ret_wp in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun ret_wp -> + let ret_wp = Obj.magic ret_wp in + let uu___1 = + let uu___2 = f_tscheme d in + uu___2 wpcs.FStarC_Syntax_Syntax.bind_wp in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___1 + (fun uu___2 -> + (fun bind_wp -> + let bind_wp = Obj.magic bind_wp in + let uu___2 = + let uu___3 = f_tscheme d in + uu___3 wpcs.FStarC_Syntax_Syntax.stronger in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () + () uu___2 + (fun uu___3 -> + (fun stronger -> + let stronger = Obj.magic stronger in + let uu___3 = + let uu___4 = f_tscheme d in + uu___4 + wpcs.FStarC_Syntax_Syntax.if_then_else in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + (_lvm_monad d) () () uu___3 + (fun uu___4 -> + (fun if_then_else -> + let if_then_else = + Obj.magic if_then_else in + let uu___4 = + let uu___5 = f_tscheme d in + uu___5 + wpcs.FStarC_Syntax_Syntax.ite_wp in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + (_lvm_monad d) () () + uu___4 + (fun uu___5 -> + (fun ite_wp -> + let ite_wp = + Obj.magic ite_wp in + let uu___5 = + let uu___6 = + f_tscheme d in + uu___6 + wpcs.FStarC_Syntax_Syntax.close_wp in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + (_lvm_monad d) + () () uu___5 + (fun uu___6 -> + (fun + close_wp + -> + let close_wp + = + Obj.magic + close_wp in + let uu___6 + = + let uu___7 + = + f_tscheme + d in + uu___7 + wpcs.FStarC_Syntax_Syntax.trivial in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + (_lvm_monad + d) () () + uu___6 + (fun + uu___7 -> + (fun + trivial + -> + let trivial + = + Obj.magic + trivial in + let uu___7 + = + let uu___8 + = + f_tscheme + d in + FStarC_Class_Monad.map_optM + (_lvm_monad + d) () () + (fun + uu___9 -> + (Obj.magic + uu___8) + uu___9) + (Obj.magic + wpcs.FStarC_Syntax_Syntax.repr) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + (_lvm_monad + d) () () + uu___7 + (fun + uu___8 -> + (fun repr + -> + let repr + = + Obj.magic + repr in + let uu___8 + = + let uu___9 + = + f_tscheme + d in + FStarC_Class_Monad.map_optM + (_lvm_monad + d) () () + (fun + uu___10 + -> + (Obj.magic + uu___9) + uu___10) + (Obj.magic + wpcs.FStarC_Syntax_Syntax.return_repr) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + (_lvm_monad + d) () () + uu___8 + (fun + uu___9 -> + (fun + return_repr + -> + let return_repr + = + Obj.magic + return_repr in + let uu___9 + = + let uu___10 + = + f_tscheme + d in + FStarC_Class_Monad.map_optM + (_lvm_monad + d) () () + (fun + uu___11 + -> + (Obj.magic + uu___10) + uu___11) + (Obj.magic + wpcs.FStarC_Syntax_Syntax.bind_repr) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + (_lvm_monad + d) () () + uu___9 + (fun + uu___10 + -> + (fun + bind_repr + -> + let bind_repr + = + Obj.magic + bind_repr in + Obj.magic + (FStarC_Class_Monad.return + (_lvm_monad + d) () + (Obj.magic + { + FStarC_Syntax_Syntax.ret_wp + = ret_wp; + FStarC_Syntax_Syntax.bind_wp + = bind_wp; + FStarC_Syntax_Syntax.stronger + = + stronger; + FStarC_Syntax_Syntax.if_then_else + = + if_then_else; + FStarC_Syntax_Syntax.ite_wp + = ite_wp; + FStarC_Syntax_Syntax.close_wp + = + close_wp; + FStarC_Syntax_Syntax.trivial + = trivial; + FStarC_Syntax_Syntax.repr + = repr; + FStarC_Syntax_Syntax.return_repr + = + return_repr; + FStarC_Syntax_Syntax.bind_repr + = + bind_repr + }))) + uu___10))) + uu___9))) + uu___8))) + uu___7))) + uu___6))) + uu___5))) uu___4))) + uu___3))) uu___2))) uu___1) +let mapTuple2 : + 'a 'b 'c 'd 'm . + 'm FStarC_Class_Monad.monad -> + ('a -> 'm) -> ('c -> 'm) -> ('a * 'c) -> 'm + = + fun uu___ -> + fun f -> + fun g -> + fun t -> + let uu___1 = + let uu___2 = + f (FStar_Pervasives_Native.__proj__Mktuple2__item___1 t) in + FStarC_Class_Monad.op_Less_Dollar_Greater uu___ () () + (fun uu___3 -> + (fun uu___3 -> + let uu___3 = Obj.magic uu___3 in + Obj.magic (fun uu___4 -> (uu___3, uu___4))) uu___3) + uu___2 in + let uu___2 = + g (FStar_Pervasives_Native.__proj__Mktuple2__item___2 t) in + FStarC_Class_Monad.op_Less_Star_Greater uu___ () () uu___1 uu___2 +let mapTuple3 : + 'a 'b 'c 'd 'e 'f 'm . + 'm FStarC_Class_Monad.monad -> + ('a -> 'm) -> ('c -> 'm) -> ('e -> 'm) -> ('a * 'c * 'e) -> 'm + = + fun uu___ -> + fun f1 -> + fun g -> + fun h -> + fun t -> + let uu___1 = + let uu___2 = + let uu___3 = + f1 (FStar_Pervasives_Native.__proj__Mktuple3__item___1 t) in + FStarC_Class_Monad.op_Less_Dollar_Greater uu___ () () + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + Obj.magic + (fun uu___5 -> + fun uu___6 -> (uu___4, uu___5, uu___6))) uu___4) + uu___3 in + let uu___3 = + g (FStar_Pervasives_Native.__proj__Mktuple3__item___2 t) in + FStarC_Class_Monad.op_Less_Star_Greater uu___ () () uu___2 + uu___3 in + let uu___2 = + h (FStar_Pervasives_Native.__proj__Mktuple3__item___3 t) in + FStarC_Class_Monad.op_Less_Star_Greater uu___ () () uu___1 uu___2 +let on_sub_layered_eff_combinators : + 'm . 'm lvm -> FStarC_Syntax_Syntax.layered_eff_combinators -> 'm = + fun d -> + fun lecs -> + let uu___ = + let uu___1 = f_tscheme d in + let uu___2 = f_tscheme d in + mapTuple2 (_lvm_monad d) uu___1 uu___2 + lecs.FStarC_Syntax_Syntax.l_repr in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun l_repr -> + let l_repr = Obj.magic l_repr in + let uu___1 = + let uu___2 = f_tscheme d in + let uu___3 = f_tscheme d in + mapTuple2 (_lvm_monad d) uu___2 uu___3 + lecs.FStarC_Syntax_Syntax.l_return in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___1 + (fun uu___2 -> + (fun l_return -> + let l_return = Obj.magic l_return in + let uu___2 = + let uu___3 = f_tscheme d in + let uu___4 = f_tscheme d in + mapTuple3 (_lvm_monad d) uu___3 uu___4 + (fun uu___5 -> + (Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) + ())) uu___5) + lecs.FStarC_Syntax_Syntax.l_bind in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () + () uu___2 + (fun uu___3 -> + (fun l_bind -> + let l_bind = Obj.magic l_bind in + let uu___3 = + let uu___4 = f_tscheme d in + let uu___5 = f_tscheme d in + mapTuple3 (_lvm_monad d) uu___4 uu___5 + (fun uu___6 -> + (Obj.magic + (FStarC_Class_Monad.return + (_lvm_monad d) ())) uu___6) + lecs.FStarC_Syntax_Syntax.l_subcomp in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + (_lvm_monad d) () () uu___3 + (fun uu___4 -> + (fun l_subcomp -> + let l_subcomp = + Obj.magic l_subcomp in + let uu___4 = + let uu___5 = f_tscheme d in + let uu___6 = f_tscheme d in + mapTuple3 (_lvm_monad d) + uu___5 uu___6 + (fun uu___7 -> + (Obj.magic + (FStarC_Class_Monad.return + (_lvm_monad d) ())) + uu___7) + lecs.FStarC_Syntax_Syntax.l_if_then_else in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + (_lvm_monad d) () () + uu___4 + (fun uu___5 -> + (fun l_if_then_else -> + let l_if_then_else + = + Obj.magic + l_if_then_else in + let uu___5 = + let uu___6 = + let uu___7 = + f_tscheme d in + let uu___8 = + f_tscheme d in + mapTuple2 + (_lvm_monad d) + uu___7 uu___8 in + FStarC_Class_Monad.map_optM + (_lvm_monad d) + () () + (fun uu___7 -> + (Obj.magic + uu___6) + uu___7) + (Obj.magic + lecs.FStarC_Syntax_Syntax.l_close) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + (_lvm_monad d) + () () uu___5 + (fun uu___6 -> + (fun + l_close + -> + let l_close + = + Obj.magic + l_close in + Obj.magic + (FStarC_Class_Monad.return + (_lvm_monad + d) () + (Obj.magic + { + FStarC_Syntax_Syntax.l_repr + = l_repr; + FStarC_Syntax_Syntax.l_return + = + l_return; + FStarC_Syntax_Syntax.l_bind + = l_bind; + FStarC_Syntax_Syntax.l_subcomp + = + l_subcomp; + FStarC_Syntax_Syntax.l_if_then_else + = + l_if_then_else; + FStarC_Syntax_Syntax.l_close + = l_close + }))) + uu___6))) + uu___5))) uu___4))) + uu___3))) uu___2))) uu___1) +let on_sub_combinators : + 'm . 'm lvm -> FStarC_Syntax_Syntax.eff_combinators -> 'm = + fun d -> + fun cbs -> + match cbs with + | FStarC_Syntax_Syntax.Primitive_eff wpcs -> + let uu___ = on_sub_wp_eff_combinators d wpcs in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun wpcs1 -> + let wpcs1 = Obj.magic wpcs1 in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic (FStarC_Syntax_Syntax.Primitive_eff wpcs1)))) + uu___1) + | FStarC_Syntax_Syntax.DM4F_eff wpcs -> + let uu___ = on_sub_wp_eff_combinators d wpcs in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun wpcs1 -> + let wpcs1 = Obj.magic wpcs1 in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic (FStarC_Syntax_Syntax.DM4F_eff wpcs1)))) + uu___1) + | FStarC_Syntax_Syntax.Layered_eff lecs -> + let uu___ = on_sub_layered_eff_combinators d lecs in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun lecs1 -> + let lecs1 = Obj.magic lecs1 in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic (FStarC_Syntax_Syntax.Layered_eff lecs1)))) + uu___1) +let on_sub_effect_signature : + 'm . 'm lvm -> FStarC_Syntax_Syntax.effect_signature -> 'm = + fun d -> + fun es -> + match es with + | FStarC_Syntax_Syntax.Layered_eff_sig (n, (us, t)) -> + let uu___ = f_term d t in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun t1 -> + let t1 = Obj.magic t1 in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic + (FStarC_Syntax_Syntax.Layered_eff_sig (n, (us, t1)))))) + uu___1) + | FStarC_Syntax_Syntax.WP_eff_sig (us, t) -> + let uu___ = f_term d t in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun t1 -> + let t1 = Obj.magic t1 in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic (FStarC_Syntax_Syntax.WP_eff_sig (us, t1))))) + uu___1) +let on_sub_action : 'm . 'm lvm -> FStarC_Syntax_Syntax.action -> 'm = + fun d -> + fun a -> + let action_name = a.FStarC_Syntax_Syntax.action_name in + let action_unqualified_name = + a.FStarC_Syntax_Syntax.action_unqualified_name in + let action_univs = a.FStarC_Syntax_Syntax.action_univs in + let uu___ = + FStarC_Class_Monad.mapM (_lvm_monad d) () () + (fun uu___1 -> (Obj.magic (f_binder d)) uu___1) + (Obj.magic a.FStarC_Syntax_Syntax.action_params) in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun action_params -> + let action_params = Obj.magic action_params in + let uu___1 = f_term d a.FStarC_Syntax_Syntax.action_defn in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___1 + (fun uu___2 -> + (fun action_defn -> + let action_defn = Obj.magic action_defn in + let uu___2 = + f_term d a.FStarC_Syntax_Syntax.action_typ in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () + () uu___2 + (fun uu___3 -> + (fun action_typ -> + let action_typ = Obj.magic action_typ in + Obj.magic + (FStarC_Class_Monad.return + (_lvm_monad d) () + (Obj.magic + { + FStarC_Syntax_Syntax.action_name + = action_name; + FStarC_Syntax_Syntax.action_unqualified_name + = action_unqualified_name; + FStarC_Syntax_Syntax.action_univs + = action_univs; + FStarC_Syntax_Syntax.action_params + = action_params; + FStarC_Syntax_Syntax.action_defn + = action_defn; + FStarC_Syntax_Syntax.action_typ + = action_typ + }))) uu___3))) uu___2))) uu___1) +let rec on_sub_sigelt' : 'm . 'm lvm -> FStarC_Syntax_Syntax.sigelt' -> 'm = + fun d -> + fun se -> + match se with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = lid; FStarC_Syntax_Syntax.us = us; + FStarC_Syntax_Syntax.params = params; + FStarC_Syntax_Syntax.num_uniform_params = num_uniform_params; + FStarC_Syntax_Syntax.t = t; + FStarC_Syntax_Syntax.mutuals = mutuals; + FStarC_Syntax_Syntax.ds = ds; + FStarC_Syntax_Syntax.injective_type_params = + injective_type_params;_} + -> + let uu___ = + FStarC_Class_Monad.mapM (_lvm_monad d) () () + (fun uu___1 -> (Obj.magic (f_binder d)) uu___1) + (Obj.magic params) in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun params1 -> + let params1 = Obj.magic params1 in + let uu___1 = f_term d t in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () + uu___1 + (fun uu___2 -> + (fun t1 -> + let t1 = Obj.magic t1 in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic + (FStarC_Syntax_Syntax.Sig_inductive_typ + { + FStarC_Syntax_Syntax.lid = lid; + FStarC_Syntax_Syntax.us = us; + FStarC_Syntax_Syntax.params = + params1; + FStarC_Syntax_Syntax.num_uniform_params + = num_uniform_params; + FStarC_Syntax_Syntax.t = t1; + FStarC_Syntax_Syntax.mutuals = + mutuals; + FStarC_Syntax_Syntax.ds = ds; + FStarC_Syntax_Syntax.injective_type_params + = injective_type_params + })))) uu___2))) uu___1) + | FStarC_Syntax_Syntax.Sig_bundle + { FStarC_Syntax_Syntax.ses = ses; + FStarC_Syntax_Syntax.lids = lids;_} + -> + let uu___ = + FStarC_Class_Monad.mapM (_lvm_monad d) () () + (fun uu___1 -> (Obj.magic (on_sub_sigelt d)) uu___1) + (Obj.magic ses) in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun ses1 -> + let ses1 = Obj.magic ses1 in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic + (FStarC_Syntax_Syntax.Sig_bundle + { + FStarC_Syntax_Syntax.ses = ses1; + FStarC_Syntax_Syntax.lids = lids + })))) uu___1) + | FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = lid; FStarC_Syntax_Syntax.us1 = us; + FStarC_Syntax_Syntax.t1 = t; + FStarC_Syntax_Syntax.ty_lid = ty_lid; + FStarC_Syntax_Syntax.num_ty_params = num_ty_params; + FStarC_Syntax_Syntax.mutuals1 = mutuals; + FStarC_Syntax_Syntax.injective_type_params1 = + injective_type_params;_} + -> + let uu___ = f_term d t in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun t1 -> + let t1 = Obj.magic t1 in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic + (FStarC_Syntax_Syntax.Sig_datacon + { + FStarC_Syntax_Syntax.lid1 = lid; + FStarC_Syntax_Syntax.us1 = us; + FStarC_Syntax_Syntax.t1 = t1; + FStarC_Syntax_Syntax.ty_lid = ty_lid; + FStarC_Syntax_Syntax.num_ty_params = + num_ty_params; + FStarC_Syntax_Syntax.mutuals1 = mutuals; + FStarC_Syntax_Syntax.injective_type_params1 = + injective_type_params + })))) uu___1) + | FStarC_Syntax_Syntax.Sig_declare_typ + { FStarC_Syntax_Syntax.lid2 = lid; FStarC_Syntax_Syntax.us2 = us; + FStarC_Syntax_Syntax.t2 = t;_} + -> + let uu___ = f_term d t in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun t1 -> + let t1 = Obj.magic t1 in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic + (FStarC_Syntax_Syntax.Sig_declare_typ + { + FStarC_Syntax_Syntax.lid2 = lid; + FStarC_Syntax_Syntax.us2 = us; + FStarC_Syntax_Syntax.t2 = t1 + })))) uu___1) + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (is_rec, lbs); + FStarC_Syntax_Syntax.lids1 = lids;_} + -> + let uu___ = + FStarC_Class_Monad.mapM (_lvm_monad d) () () + (fun uu___1 -> (Obj.magic (on_sub_letbinding d)) uu___1) + (Obj.magic lbs) in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun lbs1 -> + let lbs1 = Obj.magic lbs1 in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic + (FStarC_Syntax_Syntax.Sig_let + { + FStarC_Syntax_Syntax.lbs1 = (is_rec, lbs1); + FStarC_Syntax_Syntax.lids1 = lids + })))) uu___1) + | FStarC_Syntax_Syntax.Sig_assume + { FStarC_Syntax_Syntax.lid3 = lid; FStarC_Syntax_Syntax.us3 = us; + FStarC_Syntax_Syntax.phi1 = phi;_} + -> + let uu___ = f_term d phi in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun phi1 -> + let phi1 = Obj.magic phi1 in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic + (FStarC_Syntax_Syntax.Sig_assume + { + FStarC_Syntax_Syntax.lid3 = lid; + FStarC_Syntax_Syntax.us3 = us; + FStarC_Syntax_Syntax.phi1 = phi1 + })))) uu___1) + | FStarC_Syntax_Syntax.Sig_new_effect ed -> + let mname = ed.FStarC_Syntax_Syntax.mname in + let cattributes = ed.FStarC_Syntax_Syntax.cattributes in + let univs = ed.FStarC_Syntax_Syntax.univs in + let uu___ = + FStarC_Class_Monad.mapM (_lvm_monad d) () () + (fun uu___1 -> (Obj.magic (f_binder d)) uu___1) + (Obj.magic ed.FStarC_Syntax_Syntax.binders) in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun binders -> + let binders = Obj.magic binders in + let uu___1 = + on_sub_effect_signature d + ed.FStarC_Syntax_Syntax.signature in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () + uu___1 + (fun uu___2 -> + (fun signature -> + let signature = Obj.magic signature in + let uu___2 = + on_sub_combinators d + ed.FStarC_Syntax_Syntax.combinators in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) + () () uu___2 + (fun uu___3 -> + (fun combinators -> + let combinators = + Obj.magic combinators in + let uu___3 = + FStarC_Class_Monad.mapM + (_lvm_monad d) () () + (fun uu___4 -> + (Obj.magic (on_sub_action d)) + uu___4) + (Obj.magic + ed.FStarC_Syntax_Syntax.actions) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + (_lvm_monad d) () () uu___3 + (fun uu___4 -> + (fun actions -> + let actions = + Obj.magic actions in + let uu___4 = + FStarC_Class_Monad.mapM + (_lvm_monad d) () () + (fun uu___5 -> + (Obj.magic + (f_term d)) + uu___5) + (Obj.magic + ed.FStarC_Syntax_Syntax.eff_attrs) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + (_lvm_monad d) () () + uu___4 + (fun uu___5 -> + (fun eff_attrs -> + let eff_attrs = + Obj.magic + eff_attrs in + let extraction_mode + = + ed.FStarC_Syntax_Syntax.extraction_mode in + let ed1 = + { + FStarC_Syntax_Syntax.mname + = mname; + FStarC_Syntax_Syntax.cattributes + = + cattributes; + FStarC_Syntax_Syntax.univs + = univs; + FStarC_Syntax_Syntax.binders + = binders; + FStarC_Syntax_Syntax.signature + = + signature; + FStarC_Syntax_Syntax.combinators + = + combinators; + FStarC_Syntax_Syntax.actions + = actions; + FStarC_Syntax_Syntax.eff_attrs + = + eff_attrs; + FStarC_Syntax_Syntax.extraction_mode + = + extraction_mode + } in + Obj.magic + (FStarC_Class_Monad.return + (_lvm_monad + d) () + (Obj.magic + (FStarC_Syntax_Syntax.Sig_new_effect + ed1)))) + uu___5))) uu___4))) + uu___3))) uu___2))) uu___1) + | FStarC_Syntax_Syntax.Sig_sub_effect se1 -> + let source = se1.FStarC_Syntax_Syntax.source in + let target = se1.FStarC_Syntax_Syntax.target in + let uu___ = + let uu___1 = f_tscheme d in + FStarC_Class_Monad.map_optM (_lvm_monad d) () () + (fun uu___2 -> (Obj.magic uu___1) uu___2) + (Obj.magic se1.FStarC_Syntax_Syntax.lift_wp) in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun lift_wp -> + let lift_wp = Obj.magic lift_wp in + let uu___1 = + let uu___2 = f_tscheme d in + FStarC_Class_Monad.map_optM (_lvm_monad d) () () + (fun uu___3 -> (Obj.magic uu___2) uu___3) + (Obj.magic se1.FStarC_Syntax_Syntax.lift) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () + uu___1 + (fun uu___2 -> + (fun lift -> + let lift = Obj.magic lift in + let kind = se1.FStarC_Syntax_Syntax.kind in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic + (FStarC_Syntax_Syntax.Sig_sub_effect + { + FStarC_Syntax_Syntax.source = + source; + FStarC_Syntax_Syntax.target = + target; + FStarC_Syntax_Syntax.lift_wp = + lift_wp; + FStarC_Syntax_Syntax.lift = lift; + FStarC_Syntax_Syntax.kind = kind + })))) uu___2))) uu___1) + | FStarC_Syntax_Syntax.Sig_effect_abbrev + { FStarC_Syntax_Syntax.lid4 = lid; FStarC_Syntax_Syntax.us4 = us; + FStarC_Syntax_Syntax.bs2 = bs; FStarC_Syntax_Syntax.comp1 = comp; + FStarC_Syntax_Syntax.cflags = cflags;_} + -> + let uu___ = + FStarC_Class_Monad.mapM (_lvm_monad d) () () + (fun uu___1 -> (Obj.magic (f_binder d)) uu___1) (Obj.magic bs) in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun binders -> + let binders = Obj.magic binders in + let uu___1 = f_comp d comp in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () + uu___1 + (fun uu___2 -> + (fun comp1 -> + let comp1 = Obj.magic comp1 in + let uu___2 = + let uu___3 = __on_decreases d (f_term d) in + FStarC_Class_Monad.mapM (_lvm_monad d) () () + (fun uu___4 -> (Obj.magic uu___3) uu___4) + (Obj.magic cflags) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) + () () uu___2 + (fun uu___3 -> + (fun cflags1 -> + let cflags1 = Obj.magic cflags1 in + Obj.magic + (FStarC_Class_Monad.return + (_lvm_monad d) () + (Obj.magic + (FStarC_Syntax_Syntax.Sig_effect_abbrev + { + FStarC_Syntax_Syntax.lid4 + = lid; + FStarC_Syntax_Syntax.us4 + = us; + FStarC_Syntax_Syntax.bs2 + = bs; + FStarC_Syntax_Syntax.comp1 + = comp1; + FStarC_Syntax_Syntax.cflags + = cflags1 + })))) uu___3))) uu___2))) + uu___1) + | FStarC_Syntax_Syntax.Sig_pragma uu___ -> + FStarC_Class_Monad.return (_lvm_monad d) () (Obj.magic se) + | FStarC_Syntax_Syntax.Sig_polymonadic_bind + { FStarC_Syntax_Syntax.m_lid = m_lid; + FStarC_Syntax_Syntax.n_lid = n_lid; + FStarC_Syntax_Syntax.p_lid = p_lid; + FStarC_Syntax_Syntax.tm3 = tm; FStarC_Syntax_Syntax.typ = typ; + FStarC_Syntax_Syntax.kind1 = kind;_} + -> + let uu___ = let uu___1 = f_tscheme d in uu___1 tm in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun tm1 -> + let tm1 = Obj.magic tm1 in + let uu___1 = let uu___2 = f_tscheme d in uu___2 typ in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () + uu___1 + (fun uu___2 -> + (fun typ1 -> + let typ1 = Obj.magic typ1 in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic + (FStarC_Syntax_Syntax.Sig_polymonadic_bind + { + FStarC_Syntax_Syntax.m_lid = m_lid; + FStarC_Syntax_Syntax.n_lid = n_lid; + FStarC_Syntax_Syntax.p_lid = p_lid; + FStarC_Syntax_Syntax.tm3 = tm1; + FStarC_Syntax_Syntax.typ = typ1; + FStarC_Syntax_Syntax.kind1 = kind + })))) uu___2))) uu___1) + | FStarC_Syntax_Syntax.Sig_polymonadic_subcomp + { FStarC_Syntax_Syntax.m_lid1 = m_lid; + FStarC_Syntax_Syntax.n_lid1 = n_lid; + FStarC_Syntax_Syntax.tm4 = tm; FStarC_Syntax_Syntax.typ1 = typ; + FStarC_Syntax_Syntax.kind2 = kind;_} + -> + let uu___ = let uu___1 = f_tscheme d in uu___1 tm in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun tm1 -> + let tm1 = Obj.magic tm1 in + let uu___1 = let uu___2 = f_tscheme d in uu___2 typ in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () + uu___1 + (fun uu___2 -> + (fun typ1 -> + let typ1 = Obj.magic typ1 in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic + (FStarC_Syntax_Syntax.Sig_polymonadic_subcomp + { + FStarC_Syntax_Syntax.m_lid1 = m_lid; + FStarC_Syntax_Syntax.n_lid1 = n_lid; + FStarC_Syntax_Syntax.tm4 = tm1; + FStarC_Syntax_Syntax.typ1 = typ1; + FStarC_Syntax_Syntax.kind2 = kind + })))) uu___2))) uu___1) + | FStarC_Syntax_Syntax.Sig_fail + { FStarC_Syntax_Syntax.errs = errs; + FStarC_Syntax_Syntax.fail_in_lax = fail_in_lax; + FStarC_Syntax_Syntax.ses1 = ses;_} + -> + let uu___ = + FStarC_Class_Monad.mapM (_lvm_monad d) () () + (fun uu___1 -> (Obj.magic (on_sub_sigelt d)) uu___1) + (Obj.magic ses) in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun ses1 -> + let ses1 = Obj.magic ses1 in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic + (FStarC_Syntax_Syntax.Sig_fail + { + FStarC_Syntax_Syntax.errs = errs; + FStarC_Syntax_Syntax.fail_in_lax = fail_in_lax; + FStarC_Syntax_Syntax.ses1 = ses1 + })))) uu___1) + | FStarC_Syntax_Syntax.Sig_splice + { FStarC_Syntax_Syntax.is_typed = is_typed; + FStarC_Syntax_Syntax.lids2 = lids; + FStarC_Syntax_Syntax.tac = tac;_} + -> + let uu___ = f_term d tac in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun tac1 -> + let tac1 = Obj.magic tac1 in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic + (FStarC_Syntax_Syntax.Sig_splice + { + FStarC_Syntax_Syntax.is_typed = is_typed; + FStarC_Syntax_Syntax.lids2 = lids; + FStarC_Syntax_Syntax.tac = tac1 + })))) uu___1) + | uu___ -> failwith "on_sub_sigelt: missing case" +and on_sub_sigelt : 'm . 'm lvm -> FStarC_Syntax_Syntax.sigelt -> 'm = + fun d -> + fun se -> + let uu___ = on_sub_sigelt' d se.FStarC_Syntax_Syntax.sigel in + FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ + (fun uu___1 -> + (fun sigel -> + let sigel = Obj.magic sigel in + let sigrng = se.FStarC_Syntax_Syntax.sigrng in + let sigquals = se.FStarC_Syntax_Syntax.sigquals in + let sigmeta = se.FStarC_Syntax_Syntax.sigmeta in + let uu___1 = + FStarC_Class_Monad.mapM (_lvm_monad d) () () + (fun uu___2 -> (Obj.magic (f_term d)) uu___2) + (Obj.magic se.FStarC_Syntax_Syntax.sigattrs) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___1 + (fun uu___2 -> + (fun sigattrs -> + let sigattrs = Obj.magic sigattrs in + let sigopts = se.FStarC_Syntax_Syntax.sigopts in + let sigopens_and_abbrevs = + se.FStarC_Syntax_Syntax.sigopens_and_abbrevs in + Obj.magic + (FStarC_Class_Monad.return (_lvm_monad d) () + (Obj.magic + { + FStarC_Syntax_Syntax.sigel = sigel; + FStarC_Syntax_Syntax.sigrng = sigrng; + FStarC_Syntax_Syntax.sigquals = sigquals; + FStarC_Syntax_Syntax.sigmeta = sigmeta; + FStarC_Syntax_Syntax.sigattrs = sigattrs; + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = sigopens_and_abbrevs; + FStarC_Syntax_Syntax.sigopts = sigopts + }))) uu___2))) uu___1) +let op_Greater_Greater_Equals : + 'm . + 'm FStarC_Class_Monad.monad -> unit -> unit -> 'm -> (Obj.t -> 'm) -> 'm + = + fun uu___ -> + fun a -> + fun b -> + fun c -> + fun f -> + FStarC_Class_Monad.op_let_Bang uu___ () () c (fun x -> f x) +let op_Less_Less_Bar : + 'm . + 'm FStarC_Class_Monad.monad -> unit -> unit -> (Obj.t -> 'm) -> 'm -> 'm + = + fun uu___ -> + fun a -> + fun b -> + fun f -> + fun c -> + FStarC_Class_Monad.op_let_Bang uu___ () () c (fun x -> f x) +let tie_bu : 'm . 'm FStarC_Class_Monad.monad -> 'm lvm -> 'm lvm = + fun md -> + fun d -> + let r = let uu___ = novfs md in FStarC_Compiler_Util.mk_ref uu___ in + (let uu___1 = + let uu___2 = + let uu___3 = FStarC_Compiler_Effect.op_Bang r in uu___3.lvm_monad in + { + lvm_monad = uu___2; + f_term = + (fun x -> + let uu___3 = + let uu___4 = FStarC_Compiler_Effect.op_Bang r in + on_sub_term uu___4 x in + op_Less_Less_Bar md () () + (fun uu___4 -> (Obj.magic (f_term d)) uu___4) uu___3); + f_binder = + (fun x -> + let uu___3 = + let uu___4 = FStarC_Compiler_Effect.op_Bang r in + on_sub_binder uu___4 x in + op_Less_Less_Bar md () () + (fun uu___4 -> (Obj.magic (f_binder d)) uu___4) uu___3); + f_binding_bv = + (fun x -> + let uu___3 = + let uu___4 = FStarC_Compiler_Effect.op_Bang r in + on_sub_binding_bv uu___4 x in + op_Less_Less_Bar md () () + (fun uu___4 -> (Obj.magic (f_binding_bv d)) uu___4) uu___3); + f_br = + (fun x -> + let uu___3 = + let uu___4 = FStarC_Compiler_Effect.op_Bang r in + on_sub_br uu___4 x in + op_Less_Less_Bar md () () + (fun uu___4 -> (Obj.magic (f_br d)) uu___4) uu___3); + f_comp = + (fun x -> + let uu___3 = + let uu___4 = FStarC_Compiler_Effect.op_Bang r in + on_sub_comp uu___4 x in + op_Less_Less_Bar md () () + (fun uu___4 -> (Obj.magic (f_comp d)) uu___4) uu___3); + f_residual_comp = + (fun x -> + let uu___3 = + let uu___4 = FStarC_Compiler_Effect.op_Bang r in + on_sub_residual_comp uu___4 x in + op_Less_Less_Bar md () () + (fun uu___4 -> (Obj.magic (f_residual_comp d)) uu___4) + uu___3); + f_univ = + (fun x -> + let uu___3 = + let uu___4 = FStarC_Compiler_Effect.op_Bang r in + on_sub_univ uu___4 x in + op_Less_Less_Bar md () () + (fun uu___4 -> (Obj.magic (f_univ d)) uu___4) uu___3); + proc_quotes = (d.proc_quotes) + } in + FStarC_Compiler_Effect.op_Colon_Equals r uu___1); + FStarC_Compiler_Effect.op_Bang r +let visitM_term_univs : + 'm . + 'm FStarC_Class_Monad.monad -> + Prims.bool -> + (FStarC_Syntax_Syntax.term -> 'm) -> + (FStarC_Syntax_Syntax.universe -> 'm) -> + FStarC_Syntax_Syntax.term -> 'm + = + fun md -> + fun proc_quotes1 -> + fun vt -> + fun vu -> + fun tm -> + let dict = + let uu___ = + let uu___1 = novfs md in + { + lvm_monad = (uu___1.lvm_monad); + f_term = vt; + f_binder = (uu___1.f_binder); + f_binding_bv = (uu___1.f_binding_bv); + f_br = (uu___1.f_br); + f_comp = (uu___1.f_comp); + f_residual_comp = (uu___1.f_residual_comp); + f_univ = vu; + proc_quotes = proc_quotes1 + } in + tie_bu md uu___ in + f_term dict tm +let visitM_term : + 'm . + 'm FStarC_Class_Monad.monad -> + Prims.bool -> + (FStarC_Syntax_Syntax.term -> 'm) -> FStarC_Syntax_Syntax.term -> 'm + = + fun md -> + fun proc_quotes1 -> + fun vt -> + fun tm -> + visitM_term_univs md true vt + (fun uu___ -> (Obj.magic (FStarC_Class_Monad.return md ())) uu___) + tm +let visitM_sigelt : + 'm . + 'm FStarC_Class_Monad.monad -> + Prims.bool -> + (FStarC_Syntax_Syntax.term -> 'm) -> + (FStarC_Syntax_Syntax.universe -> 'm) -> + FStarC_Syntax_Syntax.sigelt -> 'm + = + fun md -> + fun proc_quotes1 -> + fun vt -> + fun vu -> + fun tm -> + let dict = + let uu___ = + let uu___1 = novfs md in + { + lvm_monad = (uu___1.lvm_monad); + f_term = vt; + f_binder = (uu___1.f_binder); + f_binding_bv = (uu___1.f_binding_bv); + f_br = (uu___1.f_br); + f_comp = (uu___1.f_comp); + f_residual_comp = (uu___1.f_residual_comp); + f_univ = vu; + proc_quotes = proc_quotes1 + } in + tie_bu md uu___ in + on_sub_sigelt dict tm \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Tactics_Common.ml b/ocaml/fstar-lib/generated/FStarC_Tactics_Common.ml new file mode 100644 index 00000000000..c786f742153 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Tactics_Common.ml @@ -0,0 +1,23 @@ +open Prims +exception NotAListLiteral +let (uu___is_NotAListLiteral : Prims.exn -> Prims.bool) = + fun projectee -> + match projectee with | NotAListLiteral -> true | uu___ -> false +exception TacticFailure of (FStarC_Errors_Msg.error_message * + FStarC_Compiler_Range_Type.range FStar_Pervasives_Native.option) +let (uu___is_TacticFailure : Prims.exn -> Prims.bool) = + fun projectee -> + match projectee with | TacticFailure uu___ -> true | uu___ -> false +let (__proj__TacticFailure__item__uu___ : + Prims.exn -> + (FStarC_Errors_Msg.error_message * FStarC_Compiler_Range_Type.range + FStar_Pervasives_Native.option)) + = fun projectee -> match projectee with | TacticFailure uu___ -> uu___ +exception EExn of FStarC_Syntax_Syntax.term +let (uu___is_EExn : Prims.exn -> Prims.bool) = + fun projectee -> match projectee with | EExn uu___ -> true | uu___ -> false +let (__proj__EExn__item__uu___ : Prims.exn -> FStarC_Syntax_Syntax.term) = + fun projectee -> match projectee with | EExn uu___ -> uu___ +exception SKIP +let (uu___is_SKIP : Prims.exn -> Prims.bool) = + fun projectee -> match projectee with | SKIP -> true | uu___ -> false \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Tactics_CtrlRewrite.ml b/ocaml/fstar-lib/generated/FStarC_Tactics_CtrlRewrite.ml new file mode 100644 index 00000000000..75d5911cd5d --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Tactics_CtrlRewrite.ml @@ -0,0 +1,1679 @@ +open Prims +type controller_ty = + FStarC_Syntax_Syntax.term -> + (Prims.bool * FStarC_Tactics_Types.ctrl_flag) FStarC_Tactics_Monad.tac +type rewriter_ty = unit FStarC_Tactics_Monad.tac +let (rangeof : FStarC_Tactics_Types.goal -> FStarC_Compiler_Range_Type.range) + = + fun g -> + (g.FStarC_Tactics_Types.goal_ctx_uvar).FStarC_Syntax_Syntax.ctx_uvar_range +let (__do_rewrite : + FStarC_Tactics_Types.goal -> + rewriter_ty -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term FStarC_Tactics_Monad.tac) + = + fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun g0 -> + fun rewriter -> + fun env -> + fun tm -> + let should_skip = + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress tm in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_reify uu___1) -> true + | FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_reflect uu___1) -> true + | FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_range_of) -> true + | FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_set_range_of) -> true + | uu___1 -> false in + if should_skip + then + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () (Obj.magic tm)) + else + (let res = + try + (fun uu___1 -> + match () with + | () -> + FStarC_Errors.with_ctx + "While typechecking a subterm for ctrl_rewrite" + (fun uu___2 -> + let uu___3 = + env.FStarC_TypeChecker_Env.tc_term + { + FStarC_TypeChecker_Env.solver = + (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule + = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig + = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache + = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ + = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp + = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize + = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level + = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars + = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict + = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + true; + FStarC_TypeChecker_Env.lax_universes + = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking + = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping + = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics + = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of + = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force + = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths + = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook + = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess + = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess + = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info + = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab + = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check + = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl + = + (env.FStarC_TypeChecker_Env.missing_decl) + } tm in + FStar_Pervasives_Native.Some uu___3)) + () + with + | FStarC_Errors.Error + (FStarC_Errors_Codes.Error_LayeredMissingAnnot, + uu___2, uu___3, uu___4) + -> FStar_Pervasives_Native.None + | e -> FStarC_Compiler_Effect.raise e in + match res with + | FStar_Pervasives_Native.None -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic tm)) + | FStar_Pervasives_Native.Some (uu___1, lcomp, g) -> + let uu___2 = + let uu___3 = + FStarC_TypeChecker_Common.is_pure_or_ghost_lcomp + lcomp in + Prims.op_Negation uu___3 in + if uu___2 + then + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic tm)) + else + (let g1 = + FStarC_TypeChecker_Rel.solve_deferred_constraints + env g in + let typ = + lcomp.FStarC_TypeChecker_Common.res_typ in + let typ1 = + let uu___4 = + let uu___5 = + FStarC_Options_Ext.get "__unrefine" in + uu___5 <> "" in + if uu___4 + then + let typ_norm = + FStarC_TypeChecker_Normalize.unfold_whnf' + [FStarC_TypeChecker_Env.DontUnfoldAttr + [FStarC_Parser_Const.do_not_unrefine_attr]] + env typ in + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Syntax_Subst.compress typ_norm in + uu___7.FStarC_Syntax_Syntax.n in + FStarC_Syntax_Syntax.uu___is_Tm_refine + uu___6 in + (if uu___5 + then + let typ' = + FStarC_TypeChecker_Normalize.unfold_whnf' + [FStarC_TypeChecker_Env.DontUnfoldAttr + [FStarC_Parser_Const.do_not_unrefine_attr]; + FStarC_TypeChecker_Env.Unrefine] env + typ_norm in + typ' + else typ) + else typ in + let should_check = + let uu___4 = + FStarC_TypeChecker_Common.is_total_lcomp + lcomp in + if uu___4 + then FStar_Pervasives_Native.None + else + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Allow_ghost + "do_rewrite.lhs") in + let uu___4 = + let uu___5 = + FStarC_Tactics_Monad.goal_typedness_deps g0 in + FStarC_Tactics_Monad.new_uvar "do_rewrite.rhs" + env typ1 should_check uu___5 (rangeof g0) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___4) + (fun uu___5 -> + (fun uu___5 -> + let uu___5 = Obj.magic uu___5 in + match uu___5 with + | (ut, uvar_t) -> + let uu___6 = + FStarC_Tactics_Monad.if_verbose + (fun uu___7 -> + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + tm in + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + ut in + FStarC_Compiler_Util.print2 + "do_rewrite: making equality\n\t%s ==\n\t%s\n" + uu___8 uu___9) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___6 + (fun uu___7 -> + (fun uu___7 -> + let uu___7 = + Obj.magic uu___7 in + let uu___8 = + let uu___9 = + let uu___10 = + env.FStarC_TypeChecker_Env.universe_of + env typ1 in + FStarC_Syntax_Util.mk_eq2 + uu___10 typ1 tm + ut in + FStarC_Tactics_Monad.add_irrelevant_goal + g0 "do_rewrite.eq" + env uu___9 + FStar_Pervasives_Native.None in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___8 + (fun uu___9 -> + (fun uu___9 -> + let uu___9 + = + Obj.magic + uu___9 in + let uu___10 + = + FStarC_Tactics_Monad.focus + rewriter in + Obj.magic + ( + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___10 + (fun + uu___11 + -> + (fun + uu___11 + -> + let uu___11 + = + Obj.magic + uu___11 in + let ut1 = + FStarC_TypeChecker_Normalize.reduce_uvar_solutions + env ut in + let uu___12 + = + FStarC_Tactics_Monad.if_verbose + (fun + uu___13 + -> + let uu___14 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + tm in + let uu___15 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + ut1 in + FStarC_Compiler_Util.print2 + "rewrite_rec: succeeded rewriting\n\t%s to\n\t%s\n" + uu___14 + uu___15) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___12 + (fun + uu___13 + -> + (fun + uu___13 + -> + let uu___13 + = + Obj.magic + uu___13 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + ut1))) + uu___13))) + uu___11))) + uu___9))) + uu___7))) uu___5))))) + uu___3 uu___2 uu___1 uu___ +let (do_rewrite : + FStarC_Tactics_Types.goal -> + rewriter_ty -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term FStarC_Tactics_Monad.tac) + = + fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun g0 -> + fun rewriter -> + fun env -> + fun tm -> + let uu___ = + let uu___1 = __do_rewrite g0 rewriter env tm in + FStarC_Tactics_Monad.catch uu___1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___) + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + match uu___1 with + | FStar_Pervasives.Inl + (FStarC_Tactics_Common.SKIP) -> + Obj.magic + (Obj.repr + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic tm))) + | FStar_Pervasives.Inl e -> + Obj.magic + (Obj.repr (FStarC_Tactics_Monad.traise e)) + | FStar_Pervasives.Inr tm' -> + Obj.magic + (Obj.repr + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic tm')))) uu___1))) uu___3 + uu___2 uu___1 uu___ +type 'a ctac = + 'a -> ('a * FStarC_Tactics_Types.ctrl_flag) FStarC_Tactics_Monad.tac +let seq_ctac : 'a . 'a ctac -> 'a ctac -> 'a ctac = + fun uu___1 -> + fun uu___ -> + (fun c1 -> + fun c2 -> + fun x -> + let uu___ = c1 x in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac + () () (Obj.magic uu___) + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + match uu___1 with + | (x', flag) -> + (match flag with + | FStarC_Tactics_Types.Abort -> + Obj.magic + (Obj.repr + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic + (x', FStarC_Tactics_Types.Abort)))) + | FStarC_Tactics_Types.Skip -> + Obj.magic + (Obj.repr + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic + (x', FStarC_Tactics_Types.Skip)))) + | FStarC_Tactics_Types.Continue -> + Obj.magic (Obj.repr (c2 x')))) uu___1))) + uu___1 uu___ +let (par_combine : + (FStarC_Tactics_Types.ctrl_flag * FStarC_Tactics_Types.ctrl_flag) -> + FStarC_Tactics_Types.ctrl_flag) + = + fun uu___ -> + match uu___ with + | (FStarC_Tactics_Types.Abort, uu___1) -> FStarC_Tactics_Types.Abort + | (uu___1, FStarC_Tactics_Types.Abort) -> FStarC_Tactics_Types.Abort + | (FStarC_Tactics_Types.Skip, uu___1) -> FStarC_Tactics_Types.Skip + | (uu___1, FStarC_Tactics_Types.Skip) -> FStarC_Tactics_Types.Skip + | (FStarC_Tactics_Types.Continue, FStarC_Tactics_Types.Continue) -> + FStarC_Tactics_Types.Continue +let par_ctac : 'a 'b . 'a ctac -> 'b ctac -> ('a * 'b) ctac = + fun uu___1 -> + fun uu___ -> + (fun cl -> + fun cr -> + fun uu___ -> + match uu___ with + | (x, y) -> + let uu___1 = cl x in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + match uu___2 with + | (x1, flag) -> + (match flag with + | FStarC_Tactics_Types.Abort -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic + ((x1, y), + FStarC_Tactics_Types.Abort))) + | fa -> + let uu___3 = cr y in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () + () (Obj.magic uu___3) + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + match uu___4 with + | (y1, flag1) -> + (match flag1 with + | FStarC_Tactics_Types.Abort + -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + ((x1, y1), + FStarC_Tactics_Types.Abort))) + | fb -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + ((x1, y1), + (par_combine + (fa, fb))))))) + uu___4)))) uu___2))) uu___1 + uu___ +let rec map_ctac : 'a . 'a ctac -> 'a Prims.list ctac = + fun uu___ -> + (fun c -> + fun xs -> + match xs with + | [] -> + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () + (Obj.magic ([], FStarC_Tactics_Types.Continue))) + | x::xs1 -> + let uu___ = + let uu___1 = let uu___2 = map_ctac c in par_ctac c uu___2 in + uu___1 (x, xs1) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac + () () (Obj.magic uu___) + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + match uu___1 with + | ((x1, xs2), flag) -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic ((x1 :: xs2), flag)))) uu___1))) + uu___ +let ctac_id : 'a . 'a ctac = + fun x -> + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () + (Obj.magic (x, FStarC_Tactics_Types.Continue))) +let (ctac_args : + FStarC_Syntax_Syntax.term ctac -> FStarC_Syntax_Syntax.args ctac) = + fun c -> + let uu___ = let uu___1 = ctac_id in par_ctac c uu___1 in map_ctac uu___ +let (maybe_rewrite : + FStarC_Tactics_Types.goal -> + controller_ty -> + rewriter_ty -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * FStarC_Tactics_Types.ctrl_flag) + FStarC_Tactics_Monad.tac) + = + fun uu___4 -> + fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun g0 -> + fun controller -> + fun rewriter -> + fun env -> + fun tm -> + let uu___ = controller tm in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___) + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + match uu___1 with + | (rw, ctrl_flag) -> + let uu___2 = + if rw + then + Obj.magic + (Obj.repr + (do_rewrite g0 rewriter env tm)) + else + Obj.magic + (Obj.repr + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () (Obj.magic tm))) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () + () (Obj.magic uu___2) + (fun uu___3 -> + (fun tm' -> + let tm' = Obj.magic tm' in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + (tm', ctrl_flag)))) + uu___3))) uu___1))) uu___4 + uu___3 uu___2 uu___1 uu___ +let rec (ctrl_fold_env : + FStarC_Tactics_Types.goal -> + FStarC_Tactics_Types.direction -> + controller_ty -> + rewriter_ty -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * FStarC_Tactics_Types.ctrl_flag) + FStarC_Tactics_Monad.tac) + = + fun g0 -> + fun d -> + fun controller -> + fun rewriter -> + fun env -> + fun tm -> + let recurse tm1 = + ctrl_fold_env g0 d controller rewriter env tm1 in + match d with + | FStarC_Tactics_Types.TopDown -> + let uu___ = + seq_ctac (maybe_rewrite g0 controller rewriter env) + (on_subterms g0 d controller rewriter env) in + uu___ tm + | FStarC_Tactics_Types.BottomUp -> + let uu___ = + seq_ctac (on_subterms g0 d controller rewriter env) + (maybe_rewrite g0 controller rewriter env) in + uu___ tm +and (recurse_option_residual_comp : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.subst_elt Prims.list -> + FStarC_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option -> + (FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax * + FStarC_Tactics_Types.ctrl_flag) FStarC_Tactics_Monad.tac) + -> + (FStarC_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option + * FStarC_Tactics_Types.ctrl_flag) FStarC_Tactics_Monad.tac) + = + fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun env -> + fun retyping_subst -> + fun rc_opt -> + fun recurse -> + match rc_opt with + | FStar_Pervasives_Native.None -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic + (FStar_Pervasives_Native.None, + FStarC_Tactics_Types.Continue))) + | FStar_Pervasives_Native.Some rc -> + (match rc.FStarC_Syntax_Syntax.residual_typ with + | FStar_Pervasives_Native.None -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic + ((FStar_Pervasives_Native.Some rc), + FStarC_Tactics_Types.Continue))) + | FStar_Pervasives_Native.Some t -> + let t1 = + FStarC_Syntax_Subst.subst retyping_subst t in + let uu___ = recurse env t1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___) + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + match uu___1 with + | (t2, flag) -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + ((FStar_Pervasives_Native.Some + { + FStarC_Syntax_Syntax.residual_effect + = + (rc.FStarC_Syntax_Syntax.residual_effect); + FStarC_Syntax_Syntax.residual_typ + = + (FStar_Pervasives_Native.Some + t2); + FStarC_Syntax_Syntax.residual_flags + = + (rc.FStarC_Syntax_Syntax.residual_flags) + }), flag)))) uu___1)))) + uu___3 uu___2 uu___1 uu___ +and (on_subterms : + FStarC_Tactics_Types.goal -> + FStarC_Tactics_Types.direction -> + controller_ty -> + rewriter_ty -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * FStarC_Tactics_Types.ctrl_flag) + FStarC_Tactics_Monad.tac) + = + fun uu___5 -> + fun uu___4 -> + fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun g0 -> + fun d -> + fun controller -> + fun rewriter -> + fun env -> + fun tm -> + let recurse env1 tm1 = + ctrl_fold_env g0 d controller rewriter env1 tm1 in + let rr = recurse env in + let rec descend_binders uu___8 uu___7 uu___6 + uu___5 uu___4 uu___3 uu___2 uu___1 uu___ = + (fun orig -> + fun accum_binders -> + fun retyping_subst -> + fun accum_flag -> + fun env1 -> + fun bs -> + fun t -> + fun k -> + fun rebuild -> + match bs with + | [] -> + let t1 = + FStarC_Syntax_Subst.subst + retyping_subst t in + let uu___ = + recurse env1 t1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic uu___) + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = + Obj.magic + uu___1 in + match uu___1 + with + | (t2, t_flag) + -> + (match t_flag + with + | + FStarC_Tactics_Types.Abort + -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + ((orig.FStarC_Syntax_Syntax.n), + t_flag))) + | + uu___2 -> + let uu___3 + = + recurse_option_residual_comp + env1 + retyping_subst + k recurse in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic + uu___3) + (fun + uu___4 -> + (fun + uu___4 -> + let uu___4 + = + Obj.magic + uu___4 in + match uu___4 + with + | + (k1, + k_flag) + -> + let bs1 = + FStarC_Compiler_List.rev + accum_binders in + let subst + = + FStarC_Syntax_Subst.closing_of_binders + bs1 in + let bs2 = + FStarC_Syntax_Subst.close_binders + bs1 in + let t3 = + FStarC_Syntax_Subst.subst + subst t2 in + let k2 = + FStarC_Compiler_Util.map_option + (FStarC_Syntax_Subst.subst_residual_comp + subst) k1 in + let uu___5 + = + let uu___6 + = + rebuild + bs2 t3 k2 in + (uu___6, + (par_combine + (accum_flag, + (par_combine + (t_flag, + k_flag))))) in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + uu___5))) + uu___4)))) + uu___1)) + | b::bs1 -> + let s = + FStarC_Syntax_Subst.subst + retyping_subst + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + let uu___ = + recurse env1 s in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic uu___) + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = + Obj.magic + uu___1 in + match uu___1 + with + | (s1, flag) + -> + (match flag + with + | + FStarC_Tactics_Types.Abort + -> + Obj.magic + (Obj.repr + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + ((orig.FStarC_Syntax_Syntax.n), + flag)))) + | + uu___2 -> + Obj.magic + (Obj.repr + (let bv = + let uu___3 + = + b.FStarC_Syntax_Syntax.binder_bv in + { + FStarC_Syntax_Syntax.ppname + = + (uu___3.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index + = + (uu___3.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort + = s1 + } in + let b1 = + { + FStarC_Syntax_Syntax.binder_bv + = bv; + FStarC_Syntax_Syntax.binder_qual + = + (b.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity + = + (b.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs + = + (b.FStarC_Syntax_Syntax.binder_attrs) + } in + let env2 + = + FStarC_TypeChecker_Env.push_binders + env1 + [b1] in + let retyping_subst1 + = + let uu___3 + = + let uu___4 + = + let uu___5 + = + FStarC_Syntax_Syntax.bv_to_name + bv in + (bv, + uu___5) in + FStarC_Syntax_Syntax.NT + uu___4 in + uu___3 :: + retyping_subst in + descend_binders + orig (b1 + :: + accum_binders) + retyping_subst1 + (par_combine + (accum_flag, + flag)) + env2 bs1 + t k + rebuild)))) + uu___1))) + uu___8 uu___7 uu___6 uu___5 uu___4 uu___3 + uu___2 uu___1 uu___ in + let go uu___ = + (fun uu___ -> + let tm1 = FStarC_Syntax_Subst.compress tm in + match tm1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = hd; + FStarC_Syntax_Syntax.args = args;_} + -> + Obj.magic + (Obj.repr + (let uu___1 = + let uu___2 = + let uu___3 = ctac_args rr in + par_ctac rr uu___3 in + uu___2 (hd, args) in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () + () (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = + Obj.magic uu___2 in + match uu___2 with + | ((hd1, args1), flag) -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + ((FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd + = hd1; + FStarC_Syntax_Syntax.args + = args1 + }), flag)))) + uu___2))) + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs; + FStarC_Syntax_Syntax.body = t; + FStarC_Syntax_Syntax.rc_opt = k;_} + -> + Obj.magic + (Obj.repr + (let uu___1 = + FStarC_Syntax_Subst.open_term' bs + t in + match uu___1 with + | (bs_orig, t1, subst) -> + let k1 = + FStarC_Compiler_Util.map_option + (FStarC_Syntax_Subst.subst_residual_comp + subst) k in + descend_binders tm1 [] [] + FStarC_Tactics_Types.Continue + env bs_orig t1 k1 + (fun bs1 -> + fun t2 -> + fun k2 -> + FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs + = bs1; + FStarC_Syntax_Syntax.body + = t2; + FStarC_Syntax_Syntax.rc_opt + = k2 + }))) + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x; + FStarC_Syntax_Syntax.phi = phi;_} + -> + Obj.magic + (Obj.repr + (let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Syntax_Syntax.mk_binder + x in + [uu___3] in + FStarC_Syntax_Subst.open_term + uu___2 phi in + match uu___1 with + | (bs, phi1) -> + descend_binders tm1 [] [] + FStarC_Tactics_Types.Continue + env bs phi1 + FStar_Pervasives_Native.None + (fun bs1 -> + fun phi2 -> + fun uu___2 -> + let x1 = + match bs1 with + | x2::[] -> + x2.FStarC_Syntax_Syntax.binder_bv + | uu___3 -> + failwith + "Impossible" in + FStarC_Syntax_Syntax.Tm_refine + { + FStarC_Syntax_Syntax.b + = x1; + FStarC_Syntax_Syntax.phi + = phi2 + }))) + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = comp;_} + -> + Obj.magic + (Obj.repr + (match comp.FStarC_Syntax_Syntax.n + with + | FStarC_Syntax_Syntax.Total t -> + Obj.repr + (let uu___1 = + FStarC_Syntax_Subst.open_term + bs t in + match uu___1 with + | (bs_orig, t1) -> + descend_binders tm1 [] + [] + FStarC_Tactics_Types.Continue + env bs_orig t1 + FStar_Pervasives_Native.None + (fun bs1 -> + fun t2 -> + fun uu___2 -> + FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 + = bs1; + FStarC_Syntax_Syntax.comp + = + { + FStarC_Syntax_Syntax.n + = + (FStarC_Syntax_Syntax.Total + t2); + FStarC_Syntax_Syntax.pos + = + (comp.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars + = + (comp.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code + = + (comp.FStarC_Syntax_Syntax.hash_code) + } + })) + | FStarC_Syntax_Syntax.GTotal t -> + Obj.repr + (let uu___1 = + FStarC_Syntax_Subst.open_term + bs t in + match uu___1 with + | (bs_orig, t1) -> + descend_binders tm1 [] + [] + FStarC_Tactics_Types.Continue + env bs_orig t1 + FStar_Pervasives_Native.None + (fun bs1 -> + fun t2 -> + fun uu___2 -> + FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 + = bs1; + FStarC_Syntax_Syntax.comp + = + { + FStarC_Syntax_Syntax.n + = + (FStarC_Syntax_Syntax.GTotal + t2); + FStarC_Syntax_Syntax.pos + = + (comp.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars + = + (comp.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code + = + (comp.FStarC_Syntax_Syntax.hash_code) + } + })) + | uu___1 -> + Obj.repr + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + ((tm1.FStarC_Syntax_Syntax.n), + FStarC_Tactics_Types.Continue))))) + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = hd; + FStarC_Syntax_Syntax.ret_opt = asc_opt; + FStarC_Syntax_Syntax.brs = brs; + FStarC_Syntax_Syntax.rc_opt1 = lopt;_} + -> + Obj.magic + (Obj.repr + (let c_branch uu___1 = + (fun br -> + let uu___1 = + FStarC_Syntax_Subst.open_branch + br in + match uu___1 with + | (pat, w, e) -> + let bvs = + FStarC_Syntax_Syntax.pat_bvs + pat in + let uu___2 = + let uu___3 = + FStarC_TypeChecker_Env.push_bvs + env bvs in + recurse uu___3 e in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic uu___2) + (fun uu___3 -> + (fun uu___3 -> + let uu___3 = + Obj.magic + uu___3 in + match uu___3 + with + | (e1, flag) -> + let br1 = + FStarC_Syntax_Subst.close_branch + (pat, w, + e1) in + Obj.magic + ( + FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + (br1, + flag)))) + uu___3))) uu___1 in + let uu___1 = + let uu___2 = + let uu___3 = map_ctac c_branch in + par_ctac rr uu___3 in + uu___2 (hd, brs) in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () + () (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = + Obj.magic uu___2 in + match uu___2 with + | ((hd1, brs1), flag) -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + ((FStarC_Syntax_Syntax.Tm_match + { + FStarC_Syntax_Syntax.scrutinee + = hd1; + FStarC_Syntax_Syntax.ret_opt + = asc_opt; + FStarC_Syntax_Syntax.brs + = brs1; + FStarC_Syntax_Syntax.rc_opt1 + = lopt + }), flag)))) + uu___2))) + | FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = + (false, + { + FStarC_Syntax_Syntax.lbname = + FStar_Pervasives.Inl bv; + FStarC_Syntax_Syntax.lbunivs = + uu___1; + FStarC_Syntax_Syntax.lbtyp = + uu___2; + FStarC_Syntax_Syntax.lbeff = + uu___3; + FStarC_Syntax_Syntax.lbdef = def; + FStarC_Syntax_Syntax.lbattrs = + uu___4; + FStarC_Syntax_Syntax.lbpos = + uu___5;_}::[]); + FStarC_Syntax_Syntax.body1 = e;_} + -> + Obj.magic + (Obj.repr + (let lb = + let uu___6 = + let uu___7 = + FStarC_Syntax_Subst.compress + tm1 in + uu___7.FStarC_Syntax_Syntax.n in + match uu___6 with + | FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = + (false, lb1::[]); + FStarC_Syntax_Syntax.body1 + = uu___7;_} + -> lb1 + | uu___7 -> failwith "impossible" in + let uu___6 = + FStarC_Syntax_Subst.open_term_bv + bv e in + match uu___6 with + | (bv1, e1) -> + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_TypeChecker_Env.push_bv + env bv1 in + recurse uu___10 in + par_ctac rr uu___9 in + uu___8 + ((lb.FStarC_Syntax_Syntax.lbdef), + e1) in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () (Obj.magic uu___7) + (fun uu___8 -> + (fun uu___8 -> + let uu___8 = + Obj.magic uu___8 in + match uu___8 with + | ((lbdef, e2), flag) + -> + let lb1 = + { + FStarC_Syntax_Syntax.lbname + = + (lb.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs + = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp + = + (lb.FStarC_Syntax_Syntax.lbtyp); + FStarC_Syntax_Syntax.lbeff + = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef + = lbdef; + FStarC_Syntax_Syntax.lbattrs + = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos + = + (lb.FStarC_Syntax_Syntax.lbpos) + } in + let e3 = + let uu___9 = + let uu___10 = + FStarC_Syntax_Syntax.mk_binder + bv1 in + [uu___10] in + FStarC_Syntax_Subst.close + uu___9 e2 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + ((FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs + = + (false, + [lb1]); + FStarC_Syntax_Syntax.body1 + = e3 + }), flag)))) + uu___8))) + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (true, lbs); + FStarC_Syntax_Syntax.body1 = e;_} + -> + Obj.magic + (Obj.repr + (let c_lb uu___1 = + (fun lb -> + let uu___1 = + rr + lb.FStarC_Syntax_Syntax.lbdef in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = + Obj.magic uu___2 in + match uu___2 with + | (def, flag) -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + ({ + FStarC_Syntax_Syntax.lbname + = + (lb.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs + = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp + = + (lb.FStarC_Syntax_Syntax.lbtyp); + FStarC_Syntax_Syntax.lbeff + = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef + = def; + FStarC_Syntax_Syntax.lbattrs + = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos + = + (lb.FStarC_Syntax_Syntax.lbpos) + }, flag)))) + uu___2))) uu___1 in + let uu___1 = + FStarC_Syntax_Subst.open_let_rec + lbs e in + match uu___1 with + | (lbs1, e1) -> + let uu___2 = + let uu___3 = + let uu___4 = map_ctac c_lb in + par_ctac uu___4 rr in + uu___3 (lbs1, e1) in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () (Obj.magic uu___2) + (fun uu___3 -> + (fun uu___3 -> + let uu___3 = + Obj.magic uu___3 in + match uu___3 with + | ((lbs2, e2), flag) -> + let uu___4 = + FStarC_Syntax_Subst.close_let_rec + lbs2 e2 in + (match uu___4 with + | (lbs3, e3) -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + ( + Obj.magic + ((FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs + = + (true, + lbs3); + FStarC_Syntax_Syntax.body1 + = e3 + }), flag))))) + uu___3))) + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t; + FStarC_Syntax_Syntax.asc = asc; + FStarC_Syntax_Syntax.eff_opt = eff;_} + -> + Obj.magic + (Obj.repr + (let uu___1 = rr t in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () + () (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = + Obj.magic uu___2 in + match uu___2 with + | (t1, flag) -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + ((FStarC_Syntax_Syntax.Tm_ascribed + { + FStarC_Syntax_Syntax.tm + = t1; + FStarC_Syntax_Syntax.asc + = asc; + FStarC_Syntax_Syntax.eff_opt + = eff + }), flag)))) + uu___2))) + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t; + FStarC_Syntax_Syntax.meta = m;_} + -> + Obj.magic + (Obj.repr + (let uu___1 = rr t in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () + () (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = + Obj.magic uu___2 in + match uu___2 with + | (t1, flag) -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + ((FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 + = t1; + FStarC_Syntax_Syntax.meta + = m + }), flag)))) + uu___2))) + | uu___1 -> + Obj.magic + (Obj.repr + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic + ((tm1.FStarC_Syntax_Syntax.n), + FStarC_Tactics_Types.Continue))))) + uu___ in + let uu___ = go () in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___) + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + match uu___1 with + | (tmn', flag) -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + ({ + FStarC_Syntax_Syntax.n = + tmn'; + FStarC_Syntax_Syntax.pos + = + (tm.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars + = + (tm.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code + = + (tm.FStarC_Syntax_Syntax.hash_code) + }, flag)))) uu___1))) + uu___5 uu___4 uu___3 uu___2 uu___1 uu___ +let (do_ctrl_rewrite : + FStarC_Tactics_Types.goal -> + FStarC_Tactics_Types.direction -> + controller_ty -> + rewriter_ty -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term FStarC_Tactics_Monad.tac) + = + fun uu___5 -> + fun uu___4 -> + fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun g0 -> + fun dir -> + fun controller -> + fun rewriter -> + fun env -> + fun tm -> + let uu___ = + ctrl_fold_env g0 dir controller rewriter env tm in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___) + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + match uu___1 with + | (tm', uu___2) -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () (Obj.magic tm'))) uu___1))) + uu___5 uu___4 uu___3 uu___2 uu___1 uu___ +let (ctrl_rewrite : + FStarC_Tactics_Types.direction -> + controller_ty -> rewriter_ty -> unit FStarC_Tactics_Monad.tac) + = + fun dir -> + fun controller -> + fun rewriter -> + let uu___ = + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___1 -> + (fun ps -> + let ps = Obj.magic ps in + let uu___1 = + match ps.FStarC_Tactics_Types.goals with + | g::gs -> (g, gs) + | [] -> failwith "no goals" in + match uu___1 with + | (g, gs) -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + FStarC_Tactics_Monad.dismiss_all + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + let gt = FStarC_Tactics_Types.goal_type g in + let uu___3 = + FStarC_Tactics_Monad.if_verbose + (fun uu___4 -> + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + gt in + FStarC_Compiler_Util.print1 + "ctrl_rewrite starting with %s\n" + uu___5) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + uu___3 + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + let uu___5 = + let uu___6 = + FStarC_Tactics_Types.goal_env + g in + do_ctrl_rewrite g dir + controller rewriter uu___6 gt in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () (Obj.magic uu___5) + (fun uu___6 -> + (fun gt' -> + let gt' = + Obj.magic gt' in + let uu___6 = + FStarC_Tactics_Monad.if_verbose + (fun uu___7 -> + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + gt' in + FStarC_Compiler_Util.print1 + "ctrl_rewrite seems to have succeded with %s\n" + uu___8) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___6 + (fun uu___7 -> + (fun uu___7 -> + let uu___7 + = + Obj.magic + uu___7 in + let uu___8 + = + FStarC_Tactics_Monad.push_goals + gs in + Obj.magic + ( + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___8 + (fun + uu___9 -> + (fun + uu___9 -> + let uu___9 + = + Obj.magic + uu___9 in + let g1 = + FStarC_Tactics_Monad.goal_with_type + g gt' in + Obj.magic + (FStarC_Tactics_Monad.add_goals + [g1])) + uu___9))) + uu___7))) + uu___6))) uu___4))) + uu___2))) uu___1) in + FStarC_Tactics_Monad.wrap_err "ctrl_rewrite" uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Tactics_Embedding.ml b/ocaml/fstar-lib/generated/FStarC_Tactics_Embedding.ml new file mode 100644 index 00000000000..44fcd04b21e --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Tactics_Embedding.ml @@ -0,0 +1,1086 @@ +open Prims +type name = FStarC_Syntax_Syntax.bv +let (fstar_tactics_lid' : Prims.string Prims.list -> FStarC_Ident.lid) = + fun s -> FStarC_Parser_Const.fstar_tactics_lid' s +let (fstar_stubs_tactics_lid' : Prims.string Prims.list -> FStarC_Ident.lid) + = fun s -> FStarC_Parser_Const.fstar_stubs_tactics_lid' s +let (lid_as_tm : FStarC_Ident.lident -> FStarC_Syntax_Syntax.term) = + fun l -> + let uu___ = FStarC_Syntax_Syntax.lid_as_fv l FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___ +let (mk_tactic_lid_as_term : Prims.string -> FStarC_Syntax_Syntax.term) = + fun s -> let uu___ = fstar_tactics_lid' ["Effect"; s] in lid_as_tm uu___ +type tac_constant = + { + lid: FStarC_Ident.lid ; + fv: FStarC_Syntax_Syntax.fv ; + t: FStarC_Syntax_Syntax.term } +let (__proj__Mktac_constant__item__lid : tac_constant -> FStarC_Ident.lid) = + fun projectee -> match projectee with | { lid; fv; t;_} -> lid +let (__proj__Mktac_constant__item__fv : + tac_constant -> FStarC_Syntax_Syntax.fv) = + fun projectee -> match projectee with | { lid; fv; t;_} -> fv +let (__proj__Mktac_constant__item__t : + tac_constant -> FStarC_Syntax_Syntax.term) = + fun projectee -> match projectee with | { lid; fv; t;_} -> t +let (lid_as_data_fv : FStarC_Ident.lident -> FStarC_Syntax_Syntax.fv) = + fun l -> + FStarC_Syntax_Syntax.lid_as_fv l + (FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.Data_ctor) +let (lid_as_data_tm : FStarC_Ident.lident -> FStarC_Syntax_Syntax.term) = + fun l -> + let uu___ = lid_as_data_fv l in FStarC_Syntax_Syntax.fv_to_tm uu___ +let (fstar_tactics_data : Prims.string Prims.list -> tac_constant) = + fun ns -> + let lid = fstar_stubs_tactics_lid' ns in + let uu___ = lid_as_data_fv lid in + let uu___1 = lid_as_data_tm lid in { lid; fv = uu___; t = uu___1 } +let (fstar_tactics_const : Prims.string Prims.list -> tac_constant) = + fun ns -> + let lid = fstar_stubs_tactics_lid' ns in + let uu___ = FStarC_Syntax_Syntax.fvconst lid in + let uu___1 = FStarC_Syntax_Syntax.tconst lid in + { lid; fv = uu___; t = uu___1 } +let (fstar_tc_core_lid : Prims.string -> FStarC_Ident.lid) = + fun s -> + FStarC_Ident.lid_of_path + (FStarC_Compiler_List.op_At ["FStar"; "Stubs"; "TypeChecker"; "Core"] + [s]) FStarC_Compiler_Range_Type.dummyRange +let (fstar_tc_core_data : Prims.string -> tac_constant) = + fun s -> + let lid = fstar_tc_core_lid s in + let uu___ = lid_as_data_fv lid in + let uu___1 = lid_as_data_tm lid in { lid; fv = uu___; t = uu___1 } +let (fstar_tc_core_const : Prims.string -> tac_constant) = + fun s -> + let lid = fstar_tc_core_lid s in + let uu___ = FStarC_Syntax_Syntax.fvconst lid in + let uu___1 = FStarC_Syntax_Syntax.tconst lid in + { lid; fv = uu___; t = uu___1 } +let (fstar_tactics_proofstate : tac_constant) = + fstar_tactics_const ["Types"; "proofstate"] +let (fstar_tactics_goal : tac_constant) = + fstar_tactics_const ["Types"; "goal"] +let (fstar_tactics_TacticFailure : tac_constant) = + fstar_tactics_data ["Common"; "TacticFailure"] +let (fstar_tactics_SKIP : tac_constant) = + fstar_tactics_data ["Common"; "SKIP"] +let (fstar_tactics_result : tac_constant) = + fstar_tactics_const ["Result"; "__result"] +let (fstar_tactics_Success : tac_constant) = + fstar_tactics_data ["Result"; "Success"] +let (fstar_tactics_Failed : tac_constant) = + fstar_tactics_data ["Result"; "Failed"] +let (fstar_tactics_direction : tac_constant) = + fstar_tactics_const ["Types"; "direction"] +let (fstar_tactics_topdown : tac_constant) = + fstar_tactics_data ["Types"; "TopDown"] +let (fstar_tactics_bottomup : tac_constant) = + fstar_tactics_data ["Types"; "BottomUp"] +let (fstar_tactics_ctrl_flag : tac_constant) = + fstar_tactics_const ["Types"; "ctrl_flag"] +let (fstar_tactics_Continue : tac_constant) = + fstar_tactics_data ["Types"; "Continue"] +let (fstar_tactics_Skip : tac_constant) = + fstar_tactics_data ["Types"; "Skip"] +let (fstar_tactics_Abort : tac_constant) = + fstar_tactics_data ["Types"; "Abort"] +let (fstar_tc_core_unfold_side : tac_constant) = + fstar_tc_core_const "unfold_side" +let (fstar_tc_core_unfold_side_Left : tac_constant) = + fstar_tc_core_data "Left" +let (fstar_tc_core_unfold_side_Right : tac_constant) = + fstar_tc_core_data "Right" +let (fstar_tc_core_unfold_side_Both : tac_constant) = + fstar_tc_core_data "Both" +let (fstar_tc_core_unfold_side_Neither : tac_constant) = + fstar_tc_core_data "Neither" +let (fstar_tc_core_tot_or_ghost : tac_constant) = + fstar_tc_core_const "tot_or_ghost" +let (fstar_tc_core_tot_or_ghost_ETotal : tac_constant) = + fstar_tc_core_data "E_Total" +let (fstar_tc_core_tot_or_ghost_EGhost : tac_constant) = + fstar_tc_core_data "E_Ghost" +let (fstar_tactics_guard_policy : tac_constant) = + fstar_tactics_const ["Types"; "guard_policy"] +let (fstar_tactics_SMT : tac_constant) = fstar_tactics_data ["Types"; "SMT"] +let (fstar_tactics_SMTSync : tac_constant) = + fstar_tactics_data ["Types"; "SMTSync"] +let (fstar_tactics_Goal : tac_constant) = + fstar_tactics_data ["Types"; "Goal"] +let (fstar_tactics_Drop : tac_constant) = + fstar_tactics_data ["Types"; "Drop"] +let (fstar_tactics_Force : tac_constant) = + fstar_tactics_data ["Types"; "Force"] +let mk_emb : + 'a . + (FStarC_Compiler_Range_Type.range -> 'a -> FStarC_Syntax_Syntax.term) -> + (FStarC_Syntax_Syntax.term -> 'a FStar_Pervasives_Native.option) -> + FStarC_Syntax_Syntax.term -> + 'a FStarC_Syntax_Embeddings_Base.embedding + = + fun em -> + fun un -> + fun t -> + let uu___ = FStarC_Syntax_Embeddings_Base.term_as_fv t in + FStarC_Syntax_Embeddings_Base.mk_emb + (fun x -> fun r -> fun _topt -> fun _norm -> em r x) + (fun x -> fun _norm -> un x) uu___ +let embed : + 'a . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_Compiler_Range_Type.range -> 'a -> FStarC_Syntax_Syntax.term + = + fun uu___ -> + fun r -> + fun x -> + let uu___1 = FStarC_Syntax_Embeddings_Base.embed uu___ x in + uu___1 r FStar_Pervasives_Native.None + FStarC_Syntax_Embeddings_Base.id_norm_cb +let unembed' : + 'a . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_Syntax_Syntax.term -> 'a FStar_Pervasives_Native.option + = + fun uu___ -> + fun x -> + FStarC_Syntax_Embeddings_Base.unembed uu___ x + FStarC_Syntax_Embeddings_Base.id_norm_cb +let (t_result_of : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun t -> + let uu___ = let uu___1 = FStarC_Syntax_Syntax.as_arg t in [uu___1] in + FStarC_Syntax_Util.mk_app fstar_tactics_result.t uu___ +let (hd'_and_args : + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term' * (FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax * FStarC_Syntax_Syntax.arg_qualifier + FStar_Pervasives_Native.option) Prims.list)) + = + fun tm -> + let tm1 = FStarC_Syntax_Util.unascribe tm in + let uu___ = FStarC_Syntax_Util.head_and_args tm1 in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = FStarC_Syntax_Util.un_uinst hd in + uu___2.FStarC_Syntax_Syntax.n in + (uu___1, args) +let (e_proofstate : + FStarC_Tactics_Types.proofstate FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Syntax_Embeddings_Base.e_lazy FStarC_Syntax_Syntax.Lazy_proofstate + fstar_tactics_proofstate.t +let (e_goal : + FStarC_Tactics_Types.goal FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Syntax_Embeddings_Base.e_lazy FStarC_Syntax_Syntax.Lazy_goal + fstar_tactics_goal.t +let (unfold_lazy_proofstate : + FStarC_Syntax_Syntax.lazyinfo -> FStarC_Syntax_Syntax.term) = + fun i -> FStarC_Syntax_Util.exp_string "(((proofstate)))" +let (unfold_lazy_goal : + FStarC_Syntax_Syntax.lazyinfo -> FStarC_Syntax_Syntax.term) = + fun i -> FStarC_Syntax_Util.exp_string "(((goal)))" +let (mkFV : + FStarC_Syntax_Syntax.fv -> + FStarC_Syntax_Syntax.universe Prims.list -> + (FStarC_TypeChecker_NBETerm.t * FStarC_Syntax_Syntax.aqual) Prims.list + -> FStarC_TypeChecker_NBETerm.t) + = + fun fv -> + fun us -> + fun ts -> + FStarC_TypeChecker_NBETerm.mkFV fv (FStarC_Compiler_List.rev us) + (FStarC_Compiler_List.rev ts) +let (mkConstruct : + FStarC_Syntax_Syntax.fv -> + FStarC_Syntax_Syntax.universe Prims.list -> + (FStarC_TypeChecker_NBETerm.t * FStarC_Syntax_Syntax.aqual) Prims.list + -> FStarC_TypeChecker_NBETerm.t) + = + fun fv -> + fun us -> + fun ts -> + FStarC_TypeChecker_NBETerm.mkConstruct fv + (FStarC_Compiler_List.rev us) (FStarC_Compiler_List.rev ts) +let (fv_as_emb_typ : FStarC_Syntax_Syntax.fv -> FStarC_Syntax_Syntax.emb_typ) + = + fun fv -> + let uu___ = + let uu___1 = + FStarC_Class_Show.show FStarC_Ident.showable_lident + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + (uu___1, []) in + FStarC_Syntax_Syntax.ET_app uu___ +let (e_proofstate_nbe : + FStarC_Tactics_Types.proofstate FStarC_TypeChecker_NBETerm.embedding) = + let embed_proofstate _cb ps = + let li = + let uu___ = FStarC_Dyn.mkdyn ps in + { + FStarC_Syntax_Syntax.blob = uu___; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_proofstate; + FStarC_Syntax_Syntax.ltyp = (fstar_tactics_proofstate.t); + FStarC_Syntax_Syntax.rng = FStarC_Compiler_Range_Type.dummyRange + } in + let thunk = + FStarC_Thunk.mk + (fun uu___ -> + FStarC_TypeChecker_NBETerm.mk_t + (FStarC_TypeChecker_NBETerm.Constant + (FStarC_TypeChecker_NBETerm.String + ("(((proofstate.nbe)))", + FStarC_Compiler_Range_Type.dummyRange)))) in + FStarC_TypeChecker_NBETerm.mk_t + (FStarC_TypeChecker_NBETerm.Lazy ((FStar_Pervasives.Inl li), thunk)) in + let unembed_proofstate _cb t = + let uu___ = FStarC_TypeChecker_NBETerm.nbe_t_of_t t in + match uu___ with + | FStarC_TypeChecker_NBETerm.Lazy + (FStar_Pervasives.Inl + { FStarC_Syntax_Syntax.blob = b; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_proofstate; + FStarC_Syntax_Syntax.ltyp = uu___1; + FStarC_Syntax_Syntax.rng = uu___2;_}, + uu___3) + -> + let uu___4 = FStarC_Dyn.undyn b in + FStar_Pervasives_Native.Some uu___4 + | uu___1 -> + ((let uu___3 = + FStarC_Compiler_Effect.op_Bang FStarC_Options.debug_embedding in + if uu___3 + then + let uu___4 = + let uu___5 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 + "Not an embedded NBE proofstate: %s\n" uu___5 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded + () (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4) + else ()); + FStar_Pervasives_Native.None) in + { + FStarC_TypeChecker_NBETerm.em = embed_proofstate; + FStarC_TypeChecker_NBETerm.un = unembed_proofstate; + FStarC_TypeChecker_NBETerm.typ = + (fun uu___ -> mkFV fstar_tactics_proofstate.fv [] []); + FStarC_TypeChecker_NBETerm.e_typ = + (fun uu___ -> fv_as_emb_typ fstar_tactics_proofstate.fv) + } +let (e_goal_nbe : + FStarC_Tactics_Types.goal FStarC_TypeChecker_NBETerm.embedding) = + let embed_goal _cb ps = + let li = + let uu___ = FStarC_Dyn.mkdyn ps in + { + FStarC_Syntax_Syntax.blob = uu___; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_goal; + FStarC_Syntax_Syntax.ltyp = (fstar_tactics_goal.t); + FStarC_Syntax_Syntax.rng = FStarC_Compiler_Range_Type.dummyRange + } in + let thunk = + FStarC_Thunk.mk + (fun uu___ -> + FStarC_TypeChecker_NBETerm.mk_t + (FStarC_TypeChecker_NBETerm.Constant + (FStarC_TypeChecker_NBETerm.String + ("(((goal.nbe)))", FStarC_Compiler_Range_Type.dummyRange)))) in + FStarC_TypeChecker_NBETerm.mk_t + (FStarC_TypeChecker_NBETerm.Lazy ((FStar_Pervasives.Inl li), thunk)) in + let unembed_goal _cb t = + let uu___ = FStarC_TypeChecker_NBETerm.nbe_t_of_t t in + match uu___ with + | FStarC_TypeChecker_NBETerm.Lazy + (FStar_Pervasives.Inl + { FStarC_Syntax_Syntax.blob = b; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_goal; + FStarC_Syntax_Syntax.ltyp = uu___1; + FStarC_Syntax_Syntax.rng = uu___2;_}, + uu___3) + -> + let uu___4 = FStarC_Dyn.undyn b in + FStar_Pervasives_Native.Some uu___4 + | uu___1 -> + ((let uu___3 = + FStarC_Compiler_Effect.op_Bang FStarC_Options.debug_embedding in + if uu___3 + then + let uu___4 = + let uu___5 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded NBE goal: %s" + uu___5 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded + () (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4) + else ()); + FStar_Pervasives_Native.None) in + { + FStarC_TypeChecker_NBETerm.em = embed_goal; + FStarC_TypeChecker_NBETerm.un = unembed_goal; + FStarC_TypeChecker_NBETerm.typ = + (fun uu___ -> mkFV fstar_tactics_goal.fv [] []); + FStarC_TypeChecker_NBETerm.e_typ = + (fun uu___ -> fv_as_emb_typ fstar_tactics_goal.fv) + } +let (e_exn : Prims.exn FStarC_Syntax_Embeddings_Base.embedding) = + let embed_exn e rng uu___ uu___1 = + match e with + | FStarC_Tactics_Common.TacticFailure s -> + let uu___2 = + let uu___3 = + let uu___4 = + embed + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_document) + (FStarC_Syntax_Embeddings.e_option + FStarC_Syntax_Embeddings.e_range)) rng s in + FStarC_Syntax_Syntax.as_arg uu___4 in + [uu___3] in + FStarC_Syntax_Syntax.mk_Tm_app fstar_tactics_TacticFailure.t uu___2 + rng + | FStarC_Tactics_Common.SKIP -> + let uu___2 = fstar_tactics_SKIP.t in + { + FStarC_Syntax_Syntax.n = (uu___2.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = rng; + FStarC_Syntax_Syntax.vars = (uu___2.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (uu___2.FStarC_Syntax_Syntax.hash_code) + } + | FStarC_Tactics_Common.EExn t -> + { + FStarC_Syntax_Syntax.n = (t.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = rng; + FStarC_Syntax_Syntax.vars = (t.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = (t.FStarC_Syntax_Syntax.hash_code) + } + | e1 -> + let msg = + let uu___2 = FStarC_Errors_Msg.text "Uncaught exception" in + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Compiler_Util.message_of_exn e1 in + FStarC_Pprint.arbitrary_string uu___5 in + [uu___4] in + uu___2 :: uu___3 in + let uu___2 = + let uu___3 = + let uu___4 = + embed + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_document) + (FStarC_Syntax_Embeddings.e_option + FStarC_Syntax_Embeddings.e_range)) rng + (msg, FStar_Pervasives_Native.None) in + FStarC_Syntax_Syntax.as_arg uu___4 in + [uu___3] in + FStarC_Syntax_Syntax.mk_Tm_app fstar_tactics_TacticFailure.t uu___2 + rng in + let unembed_exn t uu___ = + let uu___1 = hd'_and_args t in + match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, (s, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tactics_TacticFailure.lid -> + let uu___3 = + unembed' + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_document) + (FStarC_Syntax_Embeddings.e_option + FStarC_Syntax_Embeddings.e_range)) s in + FStarC_Compiler_Util.bind_opt uu___3 + (fun s1 -> + FStar_Pervasives_Native.Some + (FStarC_Tactics_Common.TacticFailure s1)) + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tactics_SKIP.lid -> + FStar_Pervasives_Native.Some FStarC_Tactics_Common.SKIP + | uu___2 -> FStar_Pervasives_Native.Some (FStarC_Tactics_Common.EExn t) in + FStarC_Syntax_Embeddings_Base.mk_emb_full embed_exn unembed_exn + (fun uu___ -> FStarC_Syntax_Syntax.t_exn) (fun uu___ -> "(exn)") + (fun uu___ -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Ident.showable_lident + FStarC_Parser_Const.exn_lid in + (uu___2, []) in + FStarC_Syntax_Syntax.ET_app uu___1) +let (e_exn_nbe : Prims.exn FStarC_TypeChecker_NBETerm.embedding) = + let embed_exn cb e = + match e with + | FStarC_Tactics_Common.TacticFailure s -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_tuple2 + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_document) + (FStarC_TypeChecker_NBETerm.e_option + FStarC_TypeChecker_NBETerm.e_range)) cb s in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + mkConstruct fstar_tactics_TacticFailure.fv [] uu___ + | FStarC_Tactics_Common.SKIP -> mkConstruct fstar_tactics_SKIP.fv [] [] + | uu___ -> + let uu___1 = + let uu___2 = FStarC_Compiler_Util.message_of_exn e in + FStarC_Compiler_Util.format1 "cannot embed exn (NBE) : %s" uu___2 in + failwith uu___1 in + let unembed_exn cb t = + let uu___ = FStarC_TypeChecker_NBETerm.nbe_t_of_t t in + match uu___ with + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___1, (s, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tactics_TacticFailure.lid -> + let uu___3 = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_TypeChecker_NBETerm.e_tuple2 + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_document) + (FStarC_TypeChecker_NBETerm.e_option + FStarC_TypeChecker_NBETerm.e_range)) cb s in + FStarC_Compiler_Util.bind_opt uu___3 + (fun s1 -> + FStar_Pervasives_Native.Some + (FStarC_Tactics_Common.TacticFailure s1)) + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___1, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tactics_SKIP.lid -> + FStar_Pervasives_Native.Some FStarC_Tactics_Common.SKIP + | uu___1 -> FStar_Pervasives_Native.None in + let fv_exn = FStarC_Syntax_Syntax.fvconst FStarC_Parser_Const.exn_lid in + { + FStarC_TypeChecker_NBETerm.em = embed_exn; + FStarC_TypeChecker_NBETerm.un = unembed_exn; + FStarC_TypeChecker_NBETerm.typ = (fun uu___ -> mkFV fv_exn [] []); + FStarC_TypeChecker_NBETerm.e_typ = (fun uu___ -> fv_as_emb_typ fv_exn) + } +let e_result : + 'a . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'a FStarC_Tactics_Result.__result + FStarC_Syntax_Embeddings_Base.embedding + = + fun ea -> + let embed_result res rng sh cbs = + match res with + | FStarC_Tactics_Result.Success (a1, ps) -> + let uu___ = + FStarC_Syntax_Syntax.mk_Tm_uinst fstar_tactics_Success.t + [FStarC_Syntax_Syntax.U_zero] in + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Embeddings_Base.type_of ea in + FStarC_Syntax_Syntax.iarg uu___3 in + let uu___3 = + let uu___4 = + let uu___5 = embed ea rng a1 in + FStarC_Syntax_Syntax.as_arg uu___5 in + let uu___5 = + let uu___6 = + let uu___7 = embed e_proofstate rng ps in + FStarC_Syntax_Syntax.as_arg uu___7 in + [uu___6] in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + FStarC_Syntax_Syntax.mk_Tm_app uu___ uu___1 rng + | FStarC_Tactics_Result.Failed (e, ps) -> + let uu___ = + FStarC_Syntax_Syntax.mk_Tm_uinst fstar_tactics_Failed.t + [FStarC_Syntax_Syntax.U_zero] in + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Embeddings_Base.type_of ea in + FStarC_Syntax_Syntax.iarg uu___3 in + let uu___3 = + let uu___4 = + let uu___5 = embed e_exn rng e in + FStarC_Syntax_Syntax.as_arg uu___5 in + let uu___5 = + let uu___6 = + let uu___7 = embed e_proofstate rng ps in + FStarC_Syntax_Syntax.as_arg uu___7 in + [uu___6] in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + FStarC_Syntax_Syntax.mk_Tm_app uu___ uu___1 rng in + let unembed_result t uu___ = + let uu___1 = hd'_and_args t in + match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, _t::(a1, uu___2)::(ps, uu___3)::[]) + when FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Success.lid -> + let uu___4 = unembed' ea a1 in + FStarC_Compiler_Util.bind_opt uu___4 + (fun a2 -> + let uu___5 = unembed' e_proofstate ps in + FStarC_Compiler_Util.bind_opt uu___5 + (fun ps1 -> + FStar_Pervasives_Native.Some + (FStarC_Tactics_Result.Success (a2, ps1)))) + | (FStarC_Syntax_Syntax.Tm_fvar fv, _t::(e, uu___2)::(ps, uu___3)::[]) + when FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Failed.lid -> + let uu___4 = unembed' e_exn e in + FStarC_Compiler_Util.bind_opt uu___4 + (fun e1 -> + let uu___5 = unembed' e_proofstate ps in + FStarC_Compiler_Util.bind_opt uu___5 + (fun ps1 -> + FStar_Pervasives_Native.Some + (FStarC_Tactics_Result.Failed (e1, ps1)))) + | uu___2 -> FStar_Pervasives_Native.None in + FStarC_Syntax_Embeddings_Base.mk_emb_full embed_result unembed_result + (fun uu___ -> + let uu___1 = FStarC_Syntax_Embeddings_Base.type_of ea in + t_result_of uu___1) (fun uu___ -> "") + (fun uu___ -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Ident.showable_lident + fstar_tactics_result.lid in + let uu___3 = + let uu___4 = FStarC_Syntax_Embeddings_Base.emb_typ_of ea () in + [uu___4] in + (uu___2, uu___3) in + FStarC_Syntax_Syntax.ET_app uu___1) +let e_result_nbe : + 'a . + 'a FStarC_TypeChecker_NBETerm.embedding -> + 'a FStarC_Tactics_Result.__result FStarC_TypeChecker_NBETerm.embedding + = + fun ea -> + let embed_result cb res = + match res with + | FStarC_Tactics_Result.Failed (e, ps) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.type_of ea in + FStarC_TypeChecker_NBETerm.as_iarg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_TypeChecker_NBETerm.embed e_exn_nbe cb e in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_TypeChecker_NBETerm.embed e_proofstate_nbe cb ps in + FStarC_TypeChecker_NBETerm.as_arg uu___6 in + [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mkConstruct fstar_tactics_Failed.fv [FStarC_Syntax_Syntax.U_zero] + uu___ + | FStarC_Tactics_Result.Success (a1, ps) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.type_of ea in + FStarC_TypeChecker_NBETerm.as_iarg uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_TypeChecker_NBETerm.embed ea cb a1 in + FStarC_TypeChecker_NBETerm.as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_TypeChecker_NBETerm.embed e_proofstate_nbe cb ps in + FStarC_TypeChecker_NBETerm.as_arg uu___6 in + [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + mkConstruct fstar_tactics_Success.fv [FStarC_Syntax_Syntax.U_zero] + uu___ in + let unembed_result cb t = + let uu___ = FStarC_TypeChecker_NBETerm.nbe_t_of_t t in + match uu___ with + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___1, (ps, uu___2)::(a1, uu___3)::_t::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Success.lid -> + let uu___4 = FStarC_TypeChecker_NBETerm.unembed ea cb a1 in + FStarC_Compiler_Util.bind_opt uu___4 + (fun a2 -> + let uu___5 = + FStarC_TypeChecker_NBETerm.unembed e_proofstate_nbe cb ps in + FStarC_Compiler_Util.bind_opt uu___5 + (fun ps1 -> + FStar_Pervasives_Native.Some + (FStarC_Tactics_Result.Success (a2, ps1)))) + | FStarC_TypeChecker_NBETerm.Construct + (fv, uu___1, (ps, uu___2)::(e, uu___3)::_t::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Failed.lid -> + let uu___4 = FStarC_TypeChecker_NBETerm.unembed e_exn_nbe cb e in + FStarC_Compiler_Util.bind_opt uu___4 + (fun e1 -> + let uu___5 = + FStarC_TypeChecker_NBETerm.unembed e_proofstate_nbe cb ps in + FStarC_Compiler_Util.bind_opt uu___5 + (fun ps1 -> + FStar_Pervasives_Native.Some + (FStarC_Tactics_Result.Failed (e1, ps1)))) + | uu___1 -> FStar_Pervasives_Native.None in + { + FStarC_TypeChecker_NBETerm.em = embed_result; + FStarC_TypeChecker_NBETerm.un = unembed_result; + FStarC_TypeChecker_NBETerm.typ = + (fun uu___ -> mkFV fstar_tactics_result.fv [] []); + FStarC_TypeChecker_NBETerm.e_typ = + (fun uu___ -> fv_as_emb_typ fstar_tactics_result.fv) + } +let (e_direction : + FStarC_Tactics_Types.direction FStarC_Syntax_Embeddings_Base.embedding) = + let embed_direction rng d = + match d with + | FStarC_Tactics_Types.TopDown -> fstar_tactics_topdown.t + | FStarC_Tactics_Types.BottomUp -> fstar_tactics_bottomup.t in + let unembed_direction t = + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tactics_topdown.lid -> + FStar_Pervasives_Native.Some FStarC_Tactics_Types.TopDown + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tactics_bottomup.lid -> + FStar_Pervasives_Native.Some FStarC_Tactics_Types.BottomUp + | uu___1 -> FStar_Pervasives_Native.None in + mk_emb embed_direction unembed_direction fstar_tactics_direction.t +let (e_direction_nbe : + FStarC_Tactics_Types.direction FStarC_TypeChecker_NBETerm.embedding) = + let embed_direction cb res = + match res with + | FStarC_Tactics_Types.TopDown -> + mkConstruct fstar_tactics_topdown.fv [] [] + | FStarC_Tactics_Types.BottomUp -> + mkConstruct fstar_tactics_bottomup.fv [] [] in + let unembed_direction cb t = + let uu___ = FStarC_TypeChecker_NBETerm.nbe_t_of_t t in + match uu___ with + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___1, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tactics_topdown.lid -> + FStar_Pervasives_Native.Some FStarC_Tactics_Types.TopDown + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___1, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tactics_bottomup.lid -> + FStar_Pervasives_Native.Some FStarC_Tactics_Types.BottomUp + | uu___1 -> + ((let uu___3 = + FStarC_Compiler_Effect.op_Bang FStarC_Options.debug_embedding in + if uu___3 + then + let uu___4 = + let uu___5 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded direction: %s" + uu___5 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded + () (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4) + else ()); + FStar_Pervasives_Native.None) in + { + FStarC_TypeChecker_NBETerm.em = embed_direction; + FStarC_TypeChecker_NBETerm.un = unembed_direction; + FStarC_TypeChecker_NBETerm.typ = + (fun uu___ -> mkFV fstar_tactics_direction.fv [] []); + FStarC_TypeChecker_NBETerm.e_typ = + (fun uu___ -> fv_as_emb_typ fstar_tactics_direction.fv) + } +let (e_ctrl_flag : + FStarC_Tactics_Types.ctrl_flag FStarC_Syntax_Embeddings_Base.embedding) = + let embed_ctrl_flag rng d = + match d with + | FStarC_Tactics_Types.Continue -> fstar_tactics_Continue.t + | FStarC_Tactics_Types.Skip -> fstar_tactics_Skip.t + | FStarC_Tactics_Types.Abort -> fstar_tactics_Abort.t in + let unembed_ctrl_flag t = + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Continue.lid -> + FStar_Pervasives_Native.Some FStarC_Tactics_Types.Continue + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Skip.lid -> + FStar_Pervasives_Native.Some FStarC_Tactics_Types.Skip + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Abort.lid -> + FStar_Pervasives_Native.Some FStarC_Tactics_Types.Abort + | uu___1 -> FStar_Pervasives_Native.None in + mk_emb embed_ctrl_flag unembed_ctrl_flag fstar_tactics_ctrl_flag.t +let (e_ctrl_flag_nbe : + FStarC_Tactics_Types.ctrl_flag FStarC_TypeChecker_NBETerm.embedding) = + let embed_ctrl_flag cb res = + match res with + | FStarC_Tactics_Types.Continue -> + mkConstruct fstar_tactics_Continue.fv [] [] + | FStarC_Tactics_Types.Skip -> mkConstruct fstar_tactics_Skip.fv [] [] + | FStarC_Tactics_Types.Abort -> mkConstruct fstar_tactics_Abort.fv [] [] in + let unembed_ctrl_flag cb t = + let uu___ = FStarC_TypeChecker_NBETerm.nbe_t_of_t t in + match uu___ with + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___1, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Continue.lid -> + FStar_Pervasives_Native.Some FStarC_Tactics_Types.Continue + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___1, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Skip.lid -> + FStar_Pervasives_Native.Some FStarC_Tactics_Types.Skip + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___1, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Abort.lid -> + FStar_Pervasives_Native.Some FStarC_Tactics_Types.Abort + | uu___1 -> + ((let uu___3 = + FStarC_Compiler_Effect.op_Bang FStarC_Options.debug_embedding in + if uu___3 + then + let uu___4 = + let uu___5 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded ctrl_flag: %s" + uu___5 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded + () (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4) + else ()); + FStar_Pervasives_Native.None) in + { + FStarC_TypeChecker_NBETerm.em = embed_ctrl_flag; + FStarC_TypeChecker_NBETerm.un = unembed_ctrl_flag; + FStarC_TypeChecker_NBETerm.typ = + (fun uu___ -> mkFV fstar_tactics_ctrl_flag.fv [] []); + FStarC_TypeChecker_NBETerm.e_typ = + (fun uu___ -> fv_as_emb_typ fstar_tactics_ctrl_flag.fv) + } +let (e_unfold_side : + FStarC_TypeChecker_Core.side FStarC_Syntax_Embeddings_Base.embedding) = + let embed_unfold_side rng s = + match s with + | FStarC_TypeChecker_Core.Left -> fstar_tc_core_unfold_side_Left.t + | FStarC_TypeChecker_Core.Right -> fstar_tc_core_unfold_side_Right.t + | FStarC_TypeChecker_Core.Both -> fstar_tc_core_unfold_side_Both.t + | FStarC_TypeChecker_Core.Neither -> fstar_tc_core_unfold_side_Neither.t in + let unembed_unfold_side t = + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tc_core_unfold_side_Left.lid + -> FStar_Pervasives_Native.Some FStarC_TypeChecker_Core.Left + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tc_core_unfold_side_Right.lid + -> FStar_Pervasives_Native.Some FStarC_TypeChecker_Core.Right + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tc_core_unfold_side_Both.lid + -> FStar_Pervasives_Native.Some FStarC_TypeChecker_Core.Both + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv + fstar_tc_core_unfold_side_Neither.lid + -> FStar_Pervasives_Native.Some FStarC_TypeChecker_Core.Neither + | uu___1 -> FStar_Pervasives_Native.None in + mk_emb embed_unfold_side unembed_unfold_side fstar_tc_core_unfold_side.t +let (e_unfold_side_nbe : + FStarC_TypeChecker_Core.side FStarC_TypeChecker_NBETerm.embedding) = + let embed_unfold_side cb res = + match res with + | FStarC_TypeChecker_Core.Left -> + mkConstruct fstar_tc_core_unfold_side_Left.fv [] [] + | FStarC_TypeChecker_Core.Right -> + mkConstruct fstar_tc_core_unfold_side_Right.fv [] [] + | FStarC_TypeChecker_Core.Both -> + mkConstruct fstar_tc_core_unfold_side_Both.fv [] [] + | FStarC_TypeChecker_Core.Neither -> + mkConstruct fstar_tc_core_unfold_side_Neither.fv [] [] in + let unembed_unfold_side cb t = + let uu___ = FStarC_TypeChecker_NBETerm.nbe_t_of_t t in + match uu___ with + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___1, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tc_core_unfold_side_Left.lid + -> FStar_Pervasives_Native.Some FStarC_TypeChecker_Core.Left + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___1, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tc_core_unfold_side_Right.lid + -> FStar_Pervasives_Native.Some FStarC_TypeChecker_Core.Right + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___1, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tc_core_unfold_side_Both.lid + -> FStar_Pervasives_Native.Some FStarC_TypeChecker_Core.Both + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___1, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + fstar_tc_core_unfold_side_Neither.lid + -> FStar_Pervasives_Native.Some FStarC_TypeChecker_Core.Neither + | uu___1 -> + ((let uu___3 = + FStarC_Compiler_Effect.op_Bang FStarC_Options.debug_embedding in + if uu___3 + then + let uu___4 = + let uu___5 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded unfold_side: %s" + uu___5 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded + () (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4) + else ()); + FStar_Pervasives_Native.None) in + { + FStarC_TypeChecker_NBETerm.em = embed_unfold_side; + FStarC_TypeChecker_NBETerm.un = unembed_unfold_side; + FStarC_TypeChecker_NBETerm.typ = + (fun uu___ -> mkFV fstar_tc_core_unfold_side.fv [] []); + FStarC_TypeChecker_NBETerm.e_typ = + (fun uu___ -> fv_as_emb_typ fstar_tc_core_unfold_side.fv) + } +let (e_tot_or_ghost : + FStarC_TypeChecker_Core.tot_or_ghost + FStarC_Syntax_Embeddings_Base.embedding) + = + let embed_tot_or_ghost rng s = + match s with + | FStarC_TypeChecker_Core.E_Total -> fstar_tc_core_tot_or_ghost_ETotal.t + | FStarC_TypeChecker_Core.E_Ghost -> fstar_tc_core_tot_or_ghost_EGhost.t in + let unembed_tot_or_ghost t = + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv + fstar_tc_core_tot_or_ghost_ETotal.lid + -> FStar_Pervasives_Native.Some FStarC_TypeChecker_Core.E_Total + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv + fstar_tc_core_tot_or_ghost_EGhost.lid + -> FStar_Pervasives_Native.Some FStarC_TypeChecker_Core.E_Ghost + | uu___1 -> FStar_Pervasives_Native.None in + mk_emb embed_tot_or_ghost unembed_tot_or_ghost fstar_tc_core_tot_or_ghost.t +let (e_tot_or_ghost_nbe : + FStarC_TypeChecker_Core.tot_or_ghost FStarC_TypeChecker_NBETerm.embedding) + = + let embed_tot_or_ghost cb res = + match res with + | FStarC_TypeChecker_Core.E_Total -> + mkConstruct fstar_tc_core_tot_or_ghost_ETotal.fv [] [] + | FStarC_TypeChecker_Core.E_Ghost -> + mkConstruct fstar_tc_core_tot_or_ghost_EGhost.fv [] [] in + let unembed_tot_or_ghost cb t = + let uu___ = FStarC_TypeChecker_NBETerm.nbe_t_of_t t in + match uu___ with + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___1, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + fstar_tc_core_tot_or_ghost_ETotal.lid + -> FStar_Pervasives_Native.Some FStarC_TypeChecker_Core.E_Total + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___1, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv + fstar_tc_core_tot_or_ghost_EGhost.lid + -> FStar_Pervasives_Native.Some FStarC_TypeChecker_Core.E_Ghost + | uu___1 -> + ((let uu___3 = + FStarC_Compiler_Effect.op_Bang FStarC_Options.debug_embedding in + if uu___3 + then + let uu___4 = + let uu___5 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded tot_or_ghost: %s" + uu___5 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded + () (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4) + else ()); + FStar_Pervasives_Native.None) in + { + FStarC_TypeChecker_NBETerm.em = embed_tot_or_ghost; + FStarC_TypeChecker_NBETerm.un = unembed_tot_or_ghost; + FStarC_TypeChecker_NBETerm.typ = + (fun uu___ -> mkFV fstar_tc_core_tot_or_ghost.fv [] []); + FStarC_TypeChecker_NBETerm.e_typ = + (fun uu___ -> fv_as_emb_typ fstar_tc_core_tot_or_ghost.fv) + } +let (t_tref : FStarC_Syntax_Syntax.term) = + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Syntax_Syntax.lid_as_fv FStarC_Parser_Const.tref_lid + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___2 in + FStarC_Syntax_Syntax.mk_Tm_uinst uu___1 [FStarC_Syntax_Syntax.U_zero] in + let uu___1 = + let uu___2 = FStarC_Syntax_Syntax.iarg FStarC_Syntax_Syntax.t_term in + [uu___2] in + FStarC_Syntax_Syntax.mk_Tm_app uu___ uu___1 + FStarC_Compiler_Range_Type.dummyRange +let e_tref : + 'a . + unit -> + 'a FStarC_Tactics_Types.tref FStarC_Syntax_Embeddings_Base.embedding + = + fun uu___ -> + let em r rng _shadow _norm = + FStarC_Syntax_Util.mk_lazy r t_tref FStarC_Syntax_Syntax.Lazy_tref + (FStar_Pervasives_Native.Some rng) in + let un t uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress t in + uu___3.FStarC_Syntax_Syntax.n in + match uu___2 with + | FStarC_Syntax_Syntax.Tm_lazy + { FStarC_Syntax_Syntax.blob = blob; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_tref; + FStarC_Syntax_Syntax.ltyp = uu___3; + FStarC_Syntax_Syntax.rng = uu___4;_} + -> + let uu___5 = FStarC_Dyn.undyn blob in + FStar_Pervasives_Native.Some uu___5 + | uu___3 -> FStar_Pervasives_Native.None in + FStarC_Syntax_Embeddings_Base.mk_emb_full em un (fun uu___1 -> t_tref) + (fun i -> "tref") + (fun uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Ident.string_of_lid FStarC_Parser_Const.tref_lid in + (uu___3, [FStarC_Syntax_Syntax.ET_abstract]) in + FStarC_Syntax_Syntax.ET_app uu___2) +let e_tref_nbe : + 'a . + unit -> 'a FStarC_Tactics_Types.tref FStarC_TypeChecker_NBETerm.embedding + = + fun uu___ -> + let embed_tref _cb r = + let li = + let uu___1 = FStarC_Dyn.mkdyn r in + { + FStarC_Syntax_Syntax.blob = uu___1; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_tref; + FStarC_Syntax_Syntax.ltyp = t_tref; + FStarC_Syntax_Syntax.rng = FStarC_Compiler_Range_Type.dummyRange + } in + let thunk = + FStarC_Thunk.mk + (fun uu___1 -> + FStarC_TypeChecker_NBETerm.mk_t + (FStarC_TypeChecker_NBETerm.Constant + (FStarC_TypeChecker_NBETerm.String + ("(((tref.nbe)))", + FStarC_Compiler_Range_Type.dummyRange)))) in + FStarC_TypeChecker_NBETerm.mk_t + (FStarC_TypeChecker_NBETerm.Lazy ((FStar_Pervasives.Inl li), thunk)) in + let unembed_tref _cb t = + let uu___1 = FStarC_TypeChecker_NBETerm.nbe_t_of_t t in + match uu___1 with + | FStarC_TypeChecker_NBETerm.Lazy + (FStar_Pervasives.Inl + { FStarC_Syntax_Syntax.blob = b; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_tref; + FStarC_Syntax_Syntax.ltyp = uu___2; + FStarC_Syntax_Syntax.rng = uu___3;_}, + uu___4) + -> + let uu___5 = FStarC_Dyn.undyn b in + FStar_Pervasives_Native.Some uu___5 + | uu___2 -> + ((let uu___4 = + FStarC_Compiler_Effect.op_Bang FStarC_Options.debug_embedding in + if uu___4 + then + let uu___5 = + let uu___6 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.format1 "Not an embedded NBE tref: %s\n" + uu___6 in + FStarC_Errors.log_issue0 + FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___5) + else ()); + FStar_Pervasives_Native.None) in + { + FStarC_TypeChecker_NBETerm.em = embed_tref; + FStarC_TypeChecker_NBETerm.un = unembed_tref; + FStarC_TypeChecker_NBETerm.typ = + (fun uu___1 -> + let term_t = + let uu___2 = + FStarC_Syntax_Syntax.lid_as_fv + FStarC_Parser_Const.fstar_syntax_syntax_term + FStar_Pervasives_Native.None in + mkFV uu___2 [] [] in + let uu___2 = + FStarC_Syntax_Syntax.lid_as_fv FStarC_Parser_Const.tref_lid + FStar_Pervasives_Native.None in + let uu___3 = + let uu___4 = FStarC_TypeChecker_NBETerm.as_arg term_t in + [uu___4] in + mkFV uu___2 [FStarC_Syntax_Syntax.U_zero] uu___3); + FStarC_TypeChecker_NBETerm.e_typ = + (fun uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Ident.string_of_lid FStarC_Parser_Const.tref_lid in + (uu___3, [FStarC_Syntax_Syntax.ET_abstract]) in + FStarC_Syntax_Syntax.ET_app uu___2) + } +let (e_guard_policy : + FStarC_Tactics_Types.guard_policy FStarC_Syntax_Embeddings_Base.embedding) + = + let embed_guard_policy rng p = + match p with + | FStarC_Tactics_Types.SMT -> fstar_tactics_SMT.t + | FStarC_Tactics_Types.SMTSync -> fstar_tactics_SMTSync.t + | FStarC_Tactics_Types.Goal -> fstar_tactics_Goal.t + | FStarC_Tactics_Types.Force -> fstar_tactics_Force.t + | FStarC_Tactics_Types.Drop -> fstar_tactics_Drop.t in + let unembed_guard_policy t = + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tactics_SMT.lid -> + FStar_Pervasives_Native.Some FStarC_Tactics_Types.SMT + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tactics_SMTSync.lid -> + FStar_Pervasives_Native.Some FStarC_Tactics_Types.SMTSync + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Goal.lid -> + FStar_Pervasives_Native.Some FStarC_Tactics_Types.Goal + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Force.lid -> + FStar_Pervasives_Native.Some FStarC_Tactics_Types.Force + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Drop.lid -> + FStar_Pervasives_Native.Some FStarC_Tactics_Types.Drop + | uu___1 -> FStar_Pervasives_Native.None in + mk_emb embed_guard_policy unembed_guard_policy fstar_tactics_guard_policy.t +let (e_guard_policy_nbe : + FStarC_Tactics_Types.guard_policy FStarC_TypeChecker_NBETerm.embedding) = + let embed_guard_policy cb p = + match p with + | FStarC_Tactics_Types.SMT -> mkConstruct fstar_tactics_SMT.fv [] [] + | FStarC_Tactics_Types.SMTSync -> + mkConstruct fstar_tactics_SMTSync.fv [] [] + | FStarC_Tactics_Types.Goal -> mkConstruct fstar_tactics_Goal.fv [] [] + | FStarC_Tactics_Types.Force -> mkConstruct fstar_tactics_Force.fv [] [] + | FStarC_Tactics_Types.Drop -> mkConstruct fstar_tactics_Drop.fv [] [] in + let unembed_guard_policy cb t = + let uu___ = FStarC_TypeChecker_NBETerm.nbe_t_of_t t in + match uu___ with + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___1, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tactics_SMT.lid -> + FStar_Pervasives_Native.Some FStarC_Tactics_Types.SMT + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___1, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tactics_SMTSync.lid -> + FStar_Pervasives_Native.Some FStarC_Tactics_Types.SMTSync + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___1, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Goal.lid -> + FStar_Pervasives_Native.Some FStarC_Tactics_Types.Goal + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___1, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Force.lid -> + FStar_Pervasives_Native.Some FStarC_Tactics_Types.Force + | FStarC_TypeChecker_NBETerm.Construct (fv, uu___1, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Drop.lid -> + FStar_Pervasives_Native.Some FStarC_Tactics_Types.Drop + | uu___1 -> FStar_Pervasives_Native.None in + { + FStarC_TypeChecker_NBETerm.em = embed_guard_policy; + FStarC_TypeChecker_NBETerm.un = unembed_guard_policy; + FStarC_TypeChecker_NBETerm.typ = + (fun uu___ -> mkFV fstar_tactics_guard_policy.fv [] []); + FStarC_TypeChecker_NBETerm.e_typ = + (fun uu___ -> fv_as_emb_typ fstar_tactics_guard_policy.fv) + } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Tactics_Hooks.ml b/ocaml/fstar-lib/generated/FStarC_Tactics_Hooks.ml new file mode 100644 index 00000000000..372fc7ed26f --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Tactics_Hooks.ml @@ -0,0 +1,2534 @@ +open Prims +let (dbg_Tac : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Tac" +let (dbg_SpinoffAll : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "SpinoffAll" +let (run_tactic_on_typ : + FStarC_Compiler_Range_Type.range -> + FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.term -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Tactics_Types.goal Prims.list * + FStarC_Syntax_Syntax.term)) + = + fun rng_tac -> + fun rng_goal -> + fun tactic -> + fun env -> + fun typ -> + let rng = + let uu___ = FStarC_Compiler_Range_Type.use_range rng_tac in + let uu___1 = FStarC_Compiler_Range_Type.use_range rng_goal in + FStarC_Compiler_Range_Type.range_of_rng uu___ uu___1 in + let uu___ = + FStarC_Tactics_V2_Basic.proofstate_of_goal_ty rng env typ in + match uu___ with + | (ps, w) -> + let tactic_already_typed = false in + let uu___1 = + FStarC_Tactics_Interpreter.run_tactic_on_ps rng_tac + rng_goal false FStarC_Syntax_Embeddings.e_unit () + FStarC_Syntax_Embeddings.e_unit tactic + tactic_already_typed ps in + (match uu___1 with | (gs, _res) -> (gs, w)) +let (run_tactic_on_all_implicits : + FStarC_Compiler_Range_Type.range -> + FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.term -> + FStarC_TypeChecker_Env.env -> + FStarC_TypeChecker_Env.implicits -> + FStarC_Tactics_Types.goal Prims.list) + = + fun rng_tac -> + fun rng_goal -> + fun tactic -> + fun env -> + fun imps -> + let uu___ = + FStarC_Tactics_V2_Basic.proofstate_of_all_implicits rng_goal + env imps in + match uu___ with + | (ps, uu___1) -> + let tactic_already_typed = false in + let uu___2 = + let uu___3 = FStarC_TypeChecker_Env.get_range env in + FStarC_Tactics_Interpreter.run_tactic_on_ps uu___3 rng_goal + true FStarC_Syntax_Embeddings.e_unit () + FStarC_Syntax_Embeddings.e_unit tactic + tactic_already_typed ps in + (match uu___2 with | (goals, ()) -> goals) +type pol = + | StrictlyPositive + | Pos + | Neg + | Both +let (uu___is_StrictlyPositive : pol -> Prims.bool) = + fun projectee -> + match projectee with | StrictlyPositive -> true | uu___ -> false +let (uu___is_Pos : pol -> Prims.bool) = + fun projectee -> match projectee with | Pos -> true | uu___ -> false +let (uu___is_Neg : pol -> Prims.bool) = + fun projectee -> match projectee with | Neg -> true | uu___ -> false +let (uu___is_Both : pol -> Prims.bool) = + fun projectee -> match projectee with | Both -> true | uu___ -> false +type 'a tres_m = + | Unchanged of 'a + | Simplified of ('a * FStarC_Tactics_Types.goal Prims.list) + | Dual of ('a * 'a * FStarC_Tactics_Types.goal Prims.list) +let uu___is_Unchanged : 'a . 'a tres_m -> Prims.bool = + fun projectee -> + match projectee with | Unchanged _0 -> true | uu___ -> false +let __proj__Unchanged__item___0 : 'a . 'a tres_m -> 'a = + fun projectee -> match projectee with | Unchanged _0 -> _0 +let uu___is_Simplified : 'a . 'a tres_m -> Prims.bool = + fun projectee -> + match projectee with | Simplified _0 -> true | uu___ -> false +let __proj__Simplified__item___0 : + 'a . 'a tres_m -> ('a * FStarC_Tactics_Types.goal Prims.list) = + fun projectee -> match projectee with | Simplified _0 -> _0 +let uu___is_Dual : 'a . 'a tres_m -> Prims.bool = + fun projectee -> match projectee with | Dual _0 -> true | uu___ -> false +let __proj__Dual__item___0 : + 'a . 'a tres_m -> ('a * 'a * FStarC_Tactics_Types.goal Prims.list) = + fun projectee -> match projectee with | Dual _0 -> _0 +type tres = FStarC_Syntax_Syntax.term tres_m +let tpure : 'uuuuu . 'uuuuu -> 'uuuuu tres_m = fun x -> Unchanged x +let (flip : pol -> pol) = + fun p -> + match p with + | StrictlyPositive -> Neg + | Pos -> Neg + | Neg -> Pos + | Both -> Both +let (getprop : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = + fun e -> + fun t -> + let tn = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Weak; + FStarC_TypeChecker_Env.HNF; + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant] e t in + FStarC_Syntax_Util.un_squash tn +let (by_tactic_interp : + pol -> FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.term -> tres) = + fun pol1 -> + fun e -> + fun t -> + let uu___ = FStarC_Syntax_Util.head_and_args t in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst hd in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (tactic, FStar_Pervasives_Native.None)::(assertion, + FStar_Pervasives_Native.None)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.by_tactic_lid + -> + (match pol1 with + | StrictlyPositive -> + let uu___2 = + run_tactic_on_typ tactic.FStarC_Syntax_Syntax.pos + assertion.FStarC_Syntax_Syntax.pos tactic e + assertion in + (match uu___2 with + | (gs, uu___3) -> + Simplified (FStarC_Syntax_Util.t_true, gs)) + | Pos -> + let uu___2 = + run_tactic_on_typ tactic.FStarC_Syntax_Syntax.pos + assertion.FStarC_Syntax_Syntax.pos tactic e + assertion in + (match uu___2 with + | (gs, uu___3) -> + Simplified (FStarC_Syntax_Util.t_true, gs)) + | Both -> + let uu___2 = + run_tactic_on_typ tactic.FStarC_Syntax_Syntax.pos + assertion.FStarC_Syntax_Syntax.pos tactic e + assertion in + (match uu___2 with + | (gs, uu___3) -> + Dual (assertion, FStarC_Syntax_Util.t_true, gs)) + | Neg -> Simplified (assertion, [])) + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (assertion, FStar_Pervasives_Native.None)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.spinoff_lid + -> + (match pol1 with + | StrictlyPositive -> + let g = + let uu___2 = + FStarC_Tactics_Types.goal_of_goal_ty e assertion in + FStar_Pervasives_Native.fst uu___2 in + let g1 = + FStarC_Tactics_Types.set_label "spun-off assertion" g in + Simplified (FStarC_Syntax_Util.t_true, [g1]) + | Pos -> + let g = + let uu___2 = + FStarC_Tactics_Types.goal_of_goal_ty e assertion in + FStar_Pervasives_Native.fst uu___2 in + let g1 = + FStarC_Tactics_Types.set_label "spun-off assertion" g in + Simplified (FStarC_Syntax_Util.t_true, [g1]) + | Both -> + let g = + let uu___2 = + FStarC_Tactics_Types.goal_of_goal_ty e assertion in + FStar_Pervasives_Native.fst uu___2 in + let g1 = + FStarC_Tactics_Types.set_label "spun-off assertion" g in + Dual (assertion, FStarC_Syntax_Util.t_true, [g1]) + | Neg -> Simplified (assertion, [])) + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (tactic, FStar_Pervasives_Native.None)::(typ, + FStar_Pervasives_Native.Some + { + FStarC_Syntax_Syntax.aqual_implicit + = true; + FStarC_Syntax_Syntax.aqual_attributes + = uu___2;_}):: + (tm, FStar_Pervasives_Native.None)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.rewrite_by_tactic_lid + -> + let uu___3 = + FStarC_TypeChecker_Env.new_implicit_var_aux + "rewrite_with_tactic RHS" tm.FStarC_Syntax_Syntax.pos e + typ FStarC_Syntax_Syntax.Strict + FStar_Pervasives_Native.None false in + (match uu___3 with + | (uvtm, uu___4, g_imp) -> + let u = e.FStarC_TypeChecker_Env.universe_of e typ in + let goal = + let uu___5 = FStarC_Syntax_Util.mk_eq2 u typ tm uvtm in + FStarC_Syntax_Util.mk_squash + FStarC_Syntax_Syntax.U_zero uu___5 in + let uu___5 = + run_tactic_on_typ tactic.FStarC_Syntax_Syntax.pos + tm.FStarC_Syntax_Syntax.pos tactic e goal in + (match uu___5 with + | (gs, uu___6) -> + let tagged_imps = + FStarC_TypeChecker_Rel.resolve_implicits_tac e + g_imp in + (FStarC_Tactics_Interpreter.report_implicits + tm.FStarC_Syntax_Syntax.pos tagged_imps; + Simplified (uvtm, gs)))) + | uu___2 -> Unchanged t) +let explode : + 'a . 'a tres_m -> ('a * 'a * FStarC_Tactics_Types.goal Prims.list) = + fun t -> + match t with + | Unchanged t1 -> (t1, t1, []) + | Simplified (t1, gs) -> (t1, t1, gs) + | Dual (tn, tp, gs) -> (tn, tp, gs) +let comb1 : 'a 'b . ('a -> 'b) -> 'a tres_m -> 'b tres_m = + fun f -> + fun uu___ -> + match uu___ with + | Unchanged t -> let uu___1 = f t in Unchanged uu___1 + | Simplified (t, gs) -> + let uu___1 = let uu___2 = f t in (uu___2, gs) in Simplified uu___1 + | Dual (tn, tp, gs) -> + let uu___1 = + let uu___2 = f tn in let uu___3 = f tp in (uu___2, uu___3, gs) in + Dual uu___1 +let comb2 : + 'a 'b 'c . ('a -> 'b -> 'c) -> 'a tres_m -> 'b tres_m -> 'c tres_m = + fun f -> + fun x -> + fun y -> + match (x, y) with + | (Unchanged t1, Unchanged t2) -> + let uu___ = f t1 t2 in Unchanged uu___ + | (Unchanged t1, Simplified (t2, gs)) -> + let uu___ = let uu___1 = f t1 t2 in (uu___1, gs) in + Simplified uu___ + | (Simplified (t1, gs), Unchanged t2) -> + let uu___ = let uu___1 = f t1 t2 in (uu___1, gs) in + Simplified uu___ + | (Simplified (t1, gs1), Simplified (t2, gs2)) -> + let uu___ = + let uu___1 = f t1 t2 in + (uu___1, (FStarC_Compiler_List.op_At gs1 gs2)) in + Simplified uu___ + | uu___ -> + let uu___1 = explode x in + (match uu___1 with + | (n1, p1, gs1) -> + let uu___2 = explode y in + (match uu___2 with + | (n2, p2, gs2) -> + let uu___3 = + let uu___4 = f n1 n2 in + let uu___5 = f p1 p2 in + (uu___4, uu___5, + (FStarC_Compiler_List.op_At gs1 gs2)) in + Dual uu___3)) +let comb_list : 'a . 'a tres_m Prims.list -> 'a Prims.list tres_m = + fun rs -> + let rec aux rs1 acc = + match rs1 with + | [] -> acc + | hd::tl -> + let uu___ = comb2 (fun l -> fun r -> l :: r) hd acc in aux tl uu___ in + aux (FStarC_Compiler_List.rev rs) (tpure []) +let emit : + 'a . FStarC_Tactics_Types.goal Prims.list -> 'a tres_m -> 'a tres_m = + fun gs -> fun m -> comb2 (fun uu___ -> fun x -> x) (Simplified ((), gs)) m +let rec (traverse : + (pol -> FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.term -> tres) -> + pol -> FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.term -> tres) + = + fun f -> + fun pol1 -> + fun e -> + fun t -> + let r = + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_uinst (t1, us) -> + let tr = traverse f pol1 e t1 in + let uu___1 = + comb1 (fun t' -> FStarC_Syntax_Syntax.Tm_uinst (t', us)) in + uu___1 tr + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t1; + FStarC_Syntax_Syntax.meta = m;_} + -> + let tr = traverse f pol1 e t1 in + let uu___1 = + comb1 + (fun t' -> + FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 = t'; + FStarC_Syntax_Syntax.meta = m + }) in + uu___1 tr + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar + fv; + FStarC_Syntax_Syntax.pos = uu___1; + FStarC_Syntax_Syntax.vars = uu___2; + FStarC_Syntax_Syntax.hash_code = uu___3;_}; + FStarC_Syntax_Syntax.args = (p, uu___4)::(q, uu___5)::[];_} + when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.imp_lid + -> + let x = + FStarC_Syntax_Syntax.new_bv FStar_Pervasives_Native.None p in + let r1 = traverse f (flip pol1) e p in + let r2 = + let uu___6 = FStarC_TypeChecker_Env.push_bv e x in + traverse f pol1 uu___6 q in + comb2 + (fun l -> + fun r3 -> + let uu___6 = FStarC_Syntax_Util.mk_imp l r3 in + uu___6.FStarC_Syntax_Syntax.n) r1 r2 + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar + fv; + FStarC_Syntax_Syntax.pos = uu___1; + FStarC_Syntax_Syntax.vars = uu___2; + FStarC_Syntax_Syntax.hash_code = uu___3;_}; + FStarC_Syntax_Syntax.args = (p, uu___4)::(q, uu___5)::[];_} + when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.iff_lid + -> + let xp = + FStarC_Syntax_Syntax.new_bv FStar_Pervasives_Native.None p in + let xq = + FStarC_Syntax_Syntax.new_bv FStar_Pervasives_Native.None q in + let r1 = + let uu___6 = FStarC_TypeChecker_Env.push_bv e xq in + traverse f Both uu___6 p in + let r2 = + let uu___6 = FStarC_TypeChecker_Env.push_bv e xp in + traverse f Both uu___6 q in + (match (r1, r2) with + | (Unchanged uu___6, Unchanged uu___7) -> + comb2 + (fun l -> + fun r3 -> + let uu___8 = FStarC_Syntax_Util.mk_iff l r3 in + uu___8.FStarC_Syntax_Syntax.n) r1 r2 + | uu___6 -> + let uu___7 = explode r1 in + (match uu___7 with + | (pn, pp, gs1) -> + let uu___8 = explode r2 in + (match uu___8 with + | (qn, qp, gs2) -> + let t1 = + let uu___9 = FStarC_Syntax_Util.mk_imp pn qp in + let uu___10 = + FStarC_Syntax_Util.mk_imp qn pp in + FStarC_Syntax_Util.mk_conj uu___9 uu___10 in + Simplified + ((t1.FStarC_Syntax_Syntax.n), + (FStarC_Compiler_List.op_At gs1 gs2))))) + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = hd; + FStarC_Syntax_Syntax.args = args;_} + -> + let r0 = traverse f pol1 e hd in + let r1 = + FStarC_Compiler_List.fold_right + (fun uu___1 -> + fun r2 -> + match uu___1 with + | (a, q) -> + let r' = traverse f pol1 e a in + comb2 (fun a1 -> fun args1 -> (a1, q) :: args1) + r' r2) args (tpure []) in + comb2 + (fun hd1 -> + fun args1 -> + FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = hd1; + FStarC_Syntax_Syntax.args = args1 + }) r0 r1 + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs; + FStarC_Syntax_Syntax.body = t1; + FStarC_Syntax_Syntax.rc_opt = k;_} + -> + let uu___1 = FStarC_Syntax_Subst.open_term bs t1 in + (match uu___1 with + | (bs1, topen) -> + let e' = FStarC_TypeChecker_Env.push_binders e bs1 in + let r0 = + FStarC_Compiler_List.map + (fun b -> + let r1 = + traverse f (flip pol1) e + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + let uu___2 = + comb1 + (fun s' -> + { + FStarC_Syntax_Syntax.binder_bv = + (let uu___3 = + b.FStarC_Syntax_Syntax.binder_bv in + { + FStarC_Syntax_Syntax.ppname = + (uu___3.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (uu___3.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = s' + }); + FStarC_Syntax_Syntax.binder_qual = + (b.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity = + (b.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs = + (b.FStarC_Syntax_Syntax.binder_attrs) + }) in + uu___2 r1) bs1 in + let rbs = comb_list r0 in + let rt = traverse f pol1 e' topen in + comb2 + (fun bs2 -> + fun t2 -> + let uu___2 = FStarC_Syntax_Util.abs bs2 t2 k in + uu___2.FStarC_Syntax_Syntax.n) rbs rt) + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t1; + FStarC_Syntax_Syntax.asc = asc; + FStarC_Syntax_Syntax.eff_opt = ef;_} + -> + let uu___1 = traverse f pol1 e t1 in + let uu___2 = + comb1 + (fun t2 -> + FStarC_Syntax_Syntax.Tm_ascribed + { + FStarC_Syntax_Syntax.tm = t2; + FStarC_Syntax_Syntax.asc = asc; + FStarC_Syntax_Syntax.eff_opt = ef + }) in + uu___2 uu___1 + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = sc; + FStarC_Syntax_Syntax.ret_opt = asc_opt; + FStarC_Syntax_Syntax.brs = brs; + FStarC_Syntax_Syntax.rc_opt1 = lopt;_} + -> + let uu___1 = traverse f pol1 e sc in + let uu___2 = + let uu___3 = + FStarC_Compiler_List.map + (fun br -> + let uu___4 = FStarC_Syntax_Subst.open_branch br in + match uu___4 with + | (pat, w, exp) -> + let bvs = FStarC_Syntax_Syntax.pat_bvs pat in + let e1 = FStarC_TypeChecker_Env.push_bvs e bvs in + let r1 = traverse f pol1 e1 exp in + let uu___5 = + comb1 + (fun exp1 -> + FStarC_Syntax_Subst.close_branch + (pat, w, exp1)) in + uu___5 r1) brs in + comb_list uu___3 in + comb2 + (fun sc1 -> + fun brs1 -> + FStarC_Syntax_Syntax.Tm_match + { + FStarC_Syntax_Syntax.scrutinee = sc1; + FStarC_Syntax_Syntax.ret_opt = asc_opt; + FStarC_Syntax_Syntax.brs = brs1; + FStarC_Syntax_Syntax.rc_opt1 = lopt + }) uu___1 uu___2 + | x -> tpure x in + match r with + | Unchanged tn' -> + f pol1 e + { + FStarC_Syntax_Syntax.n = tn'; + FStarC_Syntax_Syntax.pos = (t.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = (t.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (t.FStarC_Syntax_Syntax.hash_code) + } + | Simplified (tn', gs) -> + let uu___ = + f pol1 e + { + FStarC_Syntax_Syntax.n = tn'; + FStarC_Syntax_Syntax.pos = (t.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = (t.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (t.FStarC_Syntax_Syntax.hash_code) + } in + emit gs uu___ + | Dual (tn, tp, gs) -> + let rp = + f pol1 e + { + FStarC_Syntax_Syntax.n = tp; + FStarC_Syntax_Syntax.pos = (t.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = (t.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (t.FStarC_Syntax_Syntax.hash_code) + } in + let uu___ = explode rp in + (match uu___ with + | (uu___1, p', gs') -> + Dual + ({ + FStarC_Syntax_Syntax.n = tn; + FStarC_Syntax_Syntax.pos = + (t.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = + (t.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (t.FStarC_Syntax_Syntax.hash_code) + }, p', (FStarC_Compiler_List.op_At gs gs'))) +let (preprocess : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + (Prims.bool * (FStarC_TypeChecker_Env.env * FStarC_Syntax_Syntax.term * + FStarC_Options.optionstate) Prims.list)) + = + fun env -> + fun goal -> + FStarC_Errors.with_ctx "While preprocessing VC with a tactic" + (fun uu___ -> + (let uu___2 = FStarC_Compiler_Effect.op_Bang dbg_Tac in + if uu___2 + then + let uu___3 = + let uu___4 = FStarC_TypeChecker_Env.all_binders env in + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binder) uu___4 in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term goal in + FStarC_Compiler_Util.print2 "About to preprocess %s |= %s\n" + uu___3 uu___4 + else ()); + (let initial = (Prims.int_one, []) in + let uu___2 = + let uu___3 = traverse by_tactic_interp Pos env goal in + match uu___3 with + | Unchanged t' -> (false, (t', [])) + | Simplified (t', gs) -> (true, (t', gs)) + | uu___4 -> + failwith "preprocess: impossible, traverse returned a Dual" in + match uu___2 with + | (did_anything, (t', gs)) -> + ((let uu___4 = FStarC_Compiler_Effect.op_Bang dbg_Tac in + if uu___4 + then + let uu___5 = + let uu___6 = FStarC_TypeChecker_Env.all_binders env in + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binder) uu___6 in + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t' in + FStarC_Compiler_Util.print2 + "Main goal simplified to: %s |- %s\n" uu___5 uu___6 + else ()); + (let s = initial in + let s1 = + FStarC_Compiler_List.fold_left + (fun uu___4 -> + fun g -> + match uu___4 with + | (n, gs1) -> + let phi = + let uu___5 = + let uu___6 = + FStarC_Tactics_Types.goal_env g in + let uu___7 = + FStarC_Tactics_Types.goal_type g in + getprop uu___6 uu___7 in + match uu___5 with + | FStar_Pervasives_Native.None -> + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Tactics_Types.goal_type g in + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + uu___8 in + FStarC_Compiler_Util.format1 + "Tactic returned proof-relevant goal: %s" + uu___7 in + FStarC_Errors.raise_error + FStarC_TypeChecker_Env.hasRange_env + env + FStarC_Errors_Codes.Fatal_TacticProofRelevantGoal + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___6) + | FStar_Pervasives_Native.Some phi1 -> phi1 in + ((let uu___6 = + FStarC_Compiler_Effect.op_Bang dbg_Tac in + if uu___6 + then + let uu___7 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + n in + let uu___8 = + let uu___9 = + FStarC_Tactics_Types.goal_type g in + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + uu___9 in + FStarC_Compiler_Util.print2 + "Got goal #%s: %s\n" uu___7 uu___8 + else ()); + (let label = + let uu___6 = + let uu___7 = + FStarC_Pprint.doc_of_string + "Could not prove goal #" in + let uu___8 = + let uu___9 = + FStarC_Class_PP.pp + FStarC_Class_PP.pp_int n in + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Tactics_Types.get_label g in + uu___12 = "" in + if uu___11 + then FStarC_Pprint.empty + else + (let uu___13 = + let uu___14 = + FStarC_Tactics_Types.get_label + g in + FStarC_Pprint.doc_of_string + uu___14 in + FStarC_Pprint.parens uu___13) in + FStarC_Pprint.op_Hat_Slash_Hat uu___9 + uu___10 in + FStarC_Pprint.op_Hat_Hat uu___7 uu___8 in + [uu___6] in + let gt' = + let uu___6 = + FStarC_Tactics_Types.goal_range g in + FStarC_TypeChecker_Util.label label uu___6 + phi in + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Tactics_Types.goal_env g in + let uu___9 = + FStarC_Tactics_Types.goal_opts g in + (uu___8, gt', uu___9) in + uu___7 :: gs1 in + ((n + Prims.int_one), uu___6)))) s gs in + let uu___4 = s1 in + match uu___4 with + | (uu___5, gs1) -> + let gs2 = FStarC_Compiler_List.rev gs1 in + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Options.peek () in + (env, t', uu___8) in + uu___7 :: gs2 in + (did_anything, uu___6))))) +let rec (traverse_for_spinoff : + pol -> + (FStarC_Pprint.document Prims.list * FStarC_Compiler_Range_Type.range) + FStar_Pervasives_Native.option -> + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.term -> tres) + = + fun pol1 -> + fun label_ctx -> + fun e -> + fun t -> + let debug_any = FStarC_Compiler_Debug.any () in + let traverse1 pol2 e1 t1 = + traverse_for_spinoff pol2 label_ctx e1 t1 in + let traverse_ctx pol2 ctx e1 t1 = + let print_lc uu___ = + match uu___ with + | (msg, rng) -> + let uu___1 = + FStarC_Compiler_Range_Ops.string_of_def_range rng in + let uu___2 = + FStarC_Compiler_Range_Ops.string_of_use_range rng in + let uu___3 = FStarC_Errors_Msg.rendermsg msg in + FStarC_Compiler_Util.format3 "(%s,%s) : %s" uu___1 uu___2 + uu___3 in + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_SpinoffAll in + if uu___1 + then + let uu___2 = + match label_ctx with + | FStar_Pervasives_Native.None -> "None" + | FStar_Pervasives_Native.Some lc -> print_lc lc in + let uu___3 = print_lc ctx in + FStarC_Compiler_Util.print2 + "Changing label context from %s to %s" uu___2 uu___3 + else ()); + traverse_for_spinoff pol2 (FStar_Pervasives_Native.Some ctx) e1 + t1 in + let should_descend t1 = + let uu___ = FStarC_Syntax_Util.head_and_args t1 in + match uu___ with + | (hd, args) -> + let res = + let uu___1 = + let uu___2 = FStarC_Syntax_Util.un_uinst hd in + uu___2.FStarC_Syntax_Syntax.n in + match uu___1 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + ((((FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.and_lid) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.imp_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.forall_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.auto_squash_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.squash_lid) + | FStarC_Syntax_Syntax.Tm_meta uu___2 -> true + | FStarC_Syntax_Syntax.Tm_ascribed uu___2 -> true + | FStarC_Syntax_Syntax.Tm_abs uu___2 -> true + | uu___2 -> false in + res in + let maybe_spinoff pol2 label_ctx1 e1 t1 = + let label_goal uu___ = + match uu___ with + | (env, t2) -> + let t3 = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress t2 in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, label_ctx1) in + match uu___1 with + | (FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = uu___2; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_labeled uu___3;_}, + uu___4) -> t2 + | (uu___2, FStar_Pervasives_Native.Some (msg, r)) -> + FStarC_TypeChecker_Util.label msg r t2 + | uu___2 -> t2 in + let t4 = + let uu___1 = FStarC_Syntax_Util.is_sub_singleton t3 in + if uu___1 + then t3 + else + FStarC_Syntax_Util.mk_auto_squash + FStarC_Syntax_Syntax.U_zero t3 in + let uu___1 = FStarC_Tactics_Types.goal_of_goal_ty env t4 in + FStar_Pervasives_Native.fst uu___1 in + let spinoff t2 = + match pol2 with + | StrictlyPositive -> + ((let uu___1 = + FStarC_Compiler_Effect.op_Bang dbg_SpinoffAll in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t2 in + FStarC_Compiler_Util.print1 "Spinning off %s\n" uu___2 + else ()); + (let uu___1 = + let uu___2 = + let uu___3 = label_goal (e1, t2) in [uu___3] in + (FStarC_Syntax_Util.t_true, uu___2) in + Simplified uu___1)) + | uu___ -> Unchanged t2 in + let t2 = FStarC_Syntax_Subst.compress t1 in + let uu___ = + let uu___1 = should_descend t2 in Prims.op_Negation uu___1 in + if uu___ then spinoff t2 else Unchanged t2 in + let rewrite_boolean_conjunction t1 = + let uu___ = FStarC_Syntax_Util.head_and_args t1 in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst hd in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, (t2, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.b2t_lid + -> + let uu___3 = FStarC_Syntax_Util.head_and_args t2 in + (match uu___3 with + | (hd1, args1) -> + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Syntax_Util.un_uinst hd1 in + uu___6.FStarC_Syntax_Syntax.n in + (uu___5, args1) in + (match uu___4 with + | (FStarC_Syntax_Syntax.Tm_fvar fv1, + (t0, uu___5)::(t11, uu___6)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv1 + FStarC_Parser_Const.op_And + -> + let t3 = + let uu___7 = FStarC_Syntax_Util.b2t t0 in + let uu___8 = FStarC_Syntax_Util.b2t t11 in + FStarC_Syntax_Util.mk_conj uu___7 uu___8 in + FStar_Pervasives_Native.Some t3 + | uu___5 -> FStar_Pervasives_Native.None)) + | uu___2 -> FStar_Pervasives_Native.None) in + let try_rewrite_match env t1 = + let rec pat_as_exp env1 p = + let uu___ = + FStarC_TypeChecker_PatternUtils.raw_pat_as_exp env1 p in + match uu___ with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (e1, uu___1) -> + let uu___2 = FStarC_TypeChecker_Env.clear_expected_typ env1 in + (match uu___2 with + | (env2, uu___3) -> + let uu___4 = + FStarC_TypeChecker_TcTerm.tc_trivial_guard + { + FStarC_TypeChecker_Env.solver = + (env2.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env2.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env2.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env2.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env2.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env2.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env2.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env2.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env2.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env2.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env2.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env2.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env2.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env2.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env2.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env2.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env2.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env2.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = true; + FStarC_TypeChecker_Env.lax_universes = + (env2.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env2.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env2.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env2.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env2.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env2.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env2.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env2.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env2.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env2.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env2.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env2.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env2.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env2.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env2.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env2.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env2.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env2.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (env2.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env2.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env2.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env2.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env2.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env2.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env2.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env2.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env2.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env2.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env2.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env2.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env2.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env2.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env2.FStarC_TypeChecker_Env.missing_decl) + } e1 in + (match uu___4 with + | (e2, lc) -> + let u = + FStarC_TypeChecker_TcTerm.universe_of env2 + lc.FStarC_TypeChecker_Common.res_typ in + FStar_Pervasives_Native.Some + (e2, (lc.FStarC_TypeChecker_Common.res_typ), u))) in + let bv_universes env1 bvs = + FStarC_Compiler_List.map + (fun x -> + let uu___ = + FStarC_TypeChecker_TcTerm.universe_of env1 + x.FStarC_Syntax_Syntax.sort in + (x, uu___)) bvs in + let mk_forall_l bv_univs term = + FStarC_Compiler_List.fold_right + (fun uu___ -> + fun out -> + match uu___ with + | (x, u) -> FStarC_Syntax_Util.mk_forall u x out) + bv_univs term in + let mk_exists_l bv_univs term = + FStarC_Compiler_List.fold_right + (fun uu___ -> + fun out -> + match uu___ with + | (x, u) -> FStarC_Syntax_Util.mk_exists u x out) + bv_univs term in + if pol1 <> StrictlyPositive + then FStar_Pervasives_Native.None + else + (let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress t1 in + uu___2.FStarC_Syntax_Syntax.n in + match uu___1 with + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = sc; + FStarC_Syntax_Syntax.ret_opt = asc_opt; + FStarC_Syntax_Syntax.brs = brs; + FStarC_Syntax_Syntax.rc_opt1 = lopt;_} + -> + let rec rewrite_branches path_condition branches = + match branches with + | [] -> + let uu___2 = + FStarC_Syntax_Util.mk_imp path_condition + FStarC_Syntax_Util.t_false in + FStar_Pervasives.Inr uu___2 + | br::branches1 -> + let uu___2 = FStarC_Syntax_Subst.open_branch br in + (match uu___2 with + | (pat, w, body) -> + (match w with + | FStar_Pervasives_Native.Some uu___3 -> + FStar_Pervasives.Inl "when clause" + | uu___3 -> + let bvs = FStarC_Syntax_Syntax.pat_bvs pat in + let env1 = + FStarC_TypeChecker_Env.push_bvs env bvs in + let bvs_univs = bv_universes env1 bvs in + let uu___4 = pat_as_exp env1 pat in + (match uu___4 with + | FStar_Pervasives_Native.None -> + FStar_Pervasives.Inl + "Ill-typed pattern" + | FStar_Pervasives_Native.Some + (p_e, t2, u) -> + let eqn = + FStarC_Syntax_Util.mk_eq2 u t2 sc + p_e in + let branch_goal = + let uu___5 = + FStarC_Syntax_Util.mk_imp eqn + body in + mk_forall_l bvs_univs uu___5 in + let branch_goal1 = + FStarC_Syntax_Util.mk_imp + path_condition branch_goal in + let next_path_condition = + let uu___5 = + let uu___6 = + mk_exists_l bvs_univs eqn in + FStarC_Syntax_Util.mk_neg uu___6 in + FStarC_Syntax_Util.mk_conj + path_condition uu___5 in + let uu___5 = + rewrite_branches + next_path_condition branches1 in + (match uu___5 with + | FStar_Pervasives.Inl msg -> + FStar_Pervasives.Inl msg + | FStar_Pervasives.Inr rest -> + let uu___6 = + FStarC_Syntax_Util.mk_conj + branch_goal1 rest in + FStar_Pervasives.Inr uu___6)))) in + let res = rewrite_branches FStarC_Syntax_Util.t_true brs in + (match res with + | FStar_Pervasives.Inl msg -> + (if debug_any + then + (let uu___3 = FStarC_TypeChecker_Env.get_range env in + let uu___4 = + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.format2 + "Failed to split match term because %s (%s)" + msg uu___5 in + FStarC_Errors.diag + FStarC_Class_HasRange.hasRange_range uu___3 () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4)) + else (); + FStar_Pervasives_Native.None) + | FStar_Pervasives.Inr res1 -> + (if debug_any + then + (let uu___3 = FStarC_TypeChecker_Env.get_range env in + let uu___4 = + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t1 in + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term res1 in + FStarC_Compiler_Util.format2 + "Rewrote match term\n%s\ninto %s\n" uu___5 + uu___6 in + FStarC_Errors.diag + FStarC_Class_HasRange.hasRange_range uu___3 () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4)) + else (); + FStar_Pervasives_Native.Some res1)) + | uu___2 -> FStar_Pervasives_Native.None) in + let maybe_rewrite_term t1 = + if pol1 <> StrictlyPositive + then FStar_Pervasives_Native.None + else + (let uu___1 = rewrite_boolean_conjunction t1 in + match uu___1 with + | FStar_Pervasives_Native.Some t2 -> + FStar_Pervasives_Native.Some t2 + | FStar_Pervasives_Native.None -> try_rewrite_match e t1) in + let uu___ = maybe_rewrite_term t in + match uu___ with + | FStar_Pervasives_Native.Some t1 -> traverse1 pol1 e t1 + | uu___1 -> + let r = + let t1 = FStarC_Syntax_Subst.compress t in + let uu___2 = + let uu___3 = should_descend t1 in Prims.op_Negation uu___3 in + if uu___2 + then tpure t1.FStarC_Syntax_Syntax.n + else + (match t1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_uinst (t2, us) -> + let tr = traverse1 pol1 e t2 in + let uu___4 = + comb1 + (fun t' -> FStarC_Syntax_Syntax.Tm_uinst (t', us)) in + uu___4 tr + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t2; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_labeled + (msg, r1, uu___4);_} + -> + let tr = traverse_ctx pol1 (msg, r1) e t2 in + let uu___5 = + comb1 + (fun t' -> + FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 = t'; + FStarC_Syntax_Syntax.meta = + (FStarC_Syntax_Syntax.Meta_labeled + (msg, r1, false)) + }) in + uu___5 tr + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t2; + FStarC_Syntax_Syntax.meta = m;_} + -> + let tr = traverse1 pol1 e t2 in + let uu___4 = + comb1 + (fun t' -> + FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 = t'; + FStarC_Syntax_Syntax.meta = m + }) in + uu___4 tr + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t2; + FStarC_Syntax_Syntax.asc = asc; + FStarC_Syntax_Syntax.eff_opt = ef;_} + -> + let uu___4 = traverse1 pol1 e t2 in + let uu___5 = + comb1 + (fun t3 -> + FStarC_Syntax_Syntax.Tm_ascribed + { + FStarC_Syntax_Syntax.tm = t3; + FStarC_Syntax_Syntax.asc = asc; + FStarC_Syntax_Syntax.eff_opt = ef + }) in + uu___5 uu___4 + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Tm_fvar fv; + FStarC_Syntax_Syntax.pos = uu___4; + FStarC_Syntax_Syntax.vars = uu___5; + FStarC_Syntax_Syntax.hash_code = uu___6;_}; + FStarC_Syntax_Syntax.args = + (p, uu___7)::(q, uu___8)::[];_} + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.imp_lid + -> + let x = + FStarC_Syntax_Syntax.new_bv + FStar_Pervasives_Native.None p in + let r1 = traverse1 (flip pol1) e p in + let r2 = + let uu___9 = FStarC_TypeChecker_Env.push_bv e x in + traverse1 pol1 uu___9 q in + comb2 + (fun l -> + fun r3 -> + let uu___9 = FStarC_Syntax_Util.mk_imp l r3 in + uu___9.FStarC_Syntax_Syntax.n) r1 r2 + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = hd; + FStarC_Syntax_Syntax.args = args;_} + -> + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Syntax_Util.un_uinst hd in + uu___6.FStarC_Syntax_Syntax.n in + (uu___5, args) in + (match uu___4 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (t2, FStar_Pervasives_Native.Some aq0)::(body, aq)::[]) + when + ((FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.forall_lid) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.exists_lid)) + && aq0.FStarC_Syntax_Syntax.aqual_implicit + -> + let r0 = traverse1 pol1 e hd in + let rt = traverse1 (flip pol1) e t2 in + let rbody = traverse1 pol1 e body in + let rargs = + comb2 + (fun t3 -> + fun body1 -> + [(t3, + (FStar_Pervasives_Native.Some aq0)); + (body1, aq)]) rt rbody in + comb2 + (fun hd1 -> + fun args1 -> + FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = hd1; + FStarC_Syntax_Syntax.args = args1 + }) r0 rargs + | uu___5 -> + let r0 = traverse1 pol1 e hd in + let r1 = + FStarC_Compiler_List.fold_right + (fun uu___6 -> + fun r2 -> + match uu___6 with + | (a, q) -> + let r' = traverse1 pol1 e a in + comb2 + (fun a1 -> + fun args1 -> (a1, q) :: args1) + r' r2) args (tpure []) in + let simplified = + (uu___is_Simplified r0) || + (uu___is_Simplified r1) in + comb2 + (fun hd1 -> + fun args1 -> + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Util.un_uinst hd1 in + uu___8.FStarC_Syntax_Syntax.n in + (uu___7, args1) in + match uu___6 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (t2, uu___7)::[]) when + (simplified && + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.squash_lid)) + && + (let uu___8 = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm + e t2 FStarC_Syntax_Util.t_true in + uu___8 = + FStarC_TypeChecker_TermEqAndSimplify.Equal) + -> + ((let uu___9 = + FStarC_Compiler_Effect.op_Bang + dbg_SpinoffAll in + if uu___9 + then + FStarC_Compiler_Util.print_string + "Simplified squash True to True" + else ()); + FStarC_Syntax_Util.t_true.FStarC_Syntax_Syntax.n) + | uu___7 -> + let t' = + FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = hd1; + FStarC_Syntax_Syntax.args = + args1 + } in + t') r0 r1) + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs; + FStarC_Syntax_Syntax.body = t2; + FStarC_Syntax_Syntax.rc_opt = k;_} + -> + let uu___4 = FStarC_Syntax_Subst.open_term bs t2 in + (match uu___4 with + | (bs1, topen) -> + let e' = + FStarC_TypeChecker_Env.push_binders e bs1 in + let r0 = + FStarC_Compiler_List.map + (fun b -> + let r1 = + traverse1 (flip pol1) e + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + let uu___5 = + comb1 + (fun s' -> + { + FStarC_Syntax_Syntax.binder_bv = + (let uu___6 = + b.FStarC_Syntax_Syntax.binder_bv in + { + FStarC_Syntax_Syntax.ppname + = + (uu___6.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (uu___6.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = + s' + }); + FStarC_Syntax_Syntax.binder_qual + = + (b.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity + = + (b.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs + = + (b.FStarC_Syntax_Syntax.binder_attrs) + }) in + uu___5 r1) bs1 in + let rbs = comb_list r0 in + let rt = traverse1 pol1 e' topen in + comb2 + (fun bs2 -> + fun t3 -> + let uu___5 = + FStarC_Syntax_Util.abs bs2 t3 k in + uu___5.FStarC_Syntax_Syntax.n) rbs rt) + | x -> tpure x) in + (match r with + | Unchanged tn' -> + maybe_spinoff pol1 label_ctx e + { + FStarC_Syntax_Syntax.n = tn'; + FStarC_Syntax_Syntax.pos = + (t.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = + (t.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (t.FStarC_Syntax_Syntax.hash_code) + } + | Simplified (tn', gs) -> + let uu___2 = + maybe_spinoff pol1 label_ctx e + { + FStarC_Syntax_Syntax.n = tn'; + FStarC_Syntax_Syntax.pos = + (t.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = + (t.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (t.FStarC_Syntax_Syntax.hash_code) + } in + emit gs uu___2 + | Dual (tn, tp, gs) -> + let rp = + maybe_spinoff pol1 label_ctx e + { + FStarC_Syntax_Syntax.n = tp; + FStarC_Syntax_Syntax.pos = + (t.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = + (t.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (t.FStarC_Syntax_Syntax.hash_code) + } in + let uu___2 = explode rp in + (match uu___2 with + | (uu___3, p', gs') -> + Dual + ({ + FStarC_Syntax_Syntax.n = tn; + FStarC_Syntax_Syntax.pos = + (t.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = + (t.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (t.FStarC_Syntax_Syntax.hash_code) + }, p', (FStarC_Compiler_List.op_At gs gs')))) +let (pol_to_string : pol -> Prims.string) = + fun uu___ -> + match uu___ with + | StrictlyPositive -> "StrictlyPositive" + | Pos -> "Positive" + | Neg -> "Negative" + | Both -> "Both" +let (spinoff_strictly_positive_goals : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + (FStarC_TypeChecker_Env.env * FStarC_Syntax_Syntax.term) Prims.list) + = + fun env -> + fun goal -> + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_SpinoffAll in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term goal in + FStarC_Compiler_Util.print1 "spinoff_all called with %s\n" uu___2 + else ()); + FStarC_Errors.with_ctx "While spinning off all goals" + (fun uu___1 -> + let initial = (Prims.int_one, []) in + let uu___2 = + let uu___3 = + traverse_for_spinoff StrictlyPositive + FStar_Pervasives_Native.None env goal in + match uu___3 with + | Unchanged t' -> (t', []) + | Simplified (t', gs) -> (t', gs) + | uu___4 -> + failwith "preprocess: impossible, traverse returned a Dual" in + match uu___2 with + | (t', gs) -> + let t'1 = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.Simplify; + FStarC_TypeChecker_Env.Primops] env t' in + let main_goal = + let t = FStarC_TypeChecker_Common.check_trivial t'1 in + match t with + | FStarC_TypeChecker_Common.Trivial -> [] + | FStarC_TypeChecker_Common.NonTrivial t1 -> + ((let uu___4 = + FStarC_Compiler_Effect.op_Bang dbg_SpinoffAll in + if uu___4 + then + let msg = + let uu___5 = + let uu___6 = + FStarC_TypeChecker_Env.all_binders env in + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binder) uu___6 in + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.format2 + "Main goal simplified to: %s |- %s\n" uu___5 + uu___6 in + let uu___5 = FStarC_TypeChecker_Env.get_range env in + let uu___6 = + FStarC_Compiler_Util.format1 + "Verification condition was to be split into several atomic sub-goals, but this query had some sub-goals that couldn't be split---the error report, if any, may be inaccurate.\n%s\n" + msg in + FStarC_Errors.diag + FStarC_Class_HasRange.hasRange_range uu___5 () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___6) + else ()); + [(env, t1)]) in + let s = initial in + let s1 = + FStarC_Compiler_List.fold_left + (fun uu___3 -> + fun g -> + match uu___3 with + | (n, gs1) -> + let phi = FStarC_Tactics_Types.goal_type g in + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Tactics_Types.goal_env g in + (uu___6, phi) in + uu___5 :: gs1 in + ((n + Prims.int_one), uu___4)) s gs in + let uu___3 = s1 in + (match uu___3 with + | (uu___4, gs1) -> + let gs2 = FStarC_Compiler_List.rev gs1 in + let gs3 = + FStarC_Compiler_List.filter_map + (fun uu___5 -> + match uu___5 with + | (env1, t) -> + let t1 = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.Simplify; + FStarC_TypeChecker_Env.Primops] env1 t in + let uu___6 = + FStarC_TypeChecker_Common.check_trivial t1 in + (match uu___6 with + | FStarC_TypeChecker_Common.Trivial -> + FStar_Pervasives_Native.None + | FStarC_TypeChecker_Common.NonTrivial t2 -> + ((let uu___8 = + FStarC_Compiler_Effect.op_Bang + dbg_SpinoffAll in + if uu___8 + then + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t2 in + FStarC_Compiler_Util.print1 + "Got goal: %s\n" uu___9 + else ()); + FStar_Pervasives_Native.Some (env1, t2)))) + gs2 in + ((let uu___6 = FStarC_TypeChecker_Env.get_range env in + let uu___7 = + let uu___8 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_nat) + (FStarC_Compiler_List.length gs3) in + FStarC_Compiler_Util.format1 + "Split query into %s sub-goals" uu___8 in + FStarC_Errors.diag FStarC_Class_HasRange.hasRange_range + uu___6 () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___7)); + FStarC_Compiler_List.op_At main_goal gs3))) +let (synthesize : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun env -> + fun typ -> + fun tau -> + FStarC_Errors.with_ctx "While synthesizing term with a tactic" + (fun uu___ -> + if env.FStarC_TypeChecker_Env.flychecking + then + let uu___1 = + FStarC_TypeChecker_Util.fvar_env env + FStarC_Parser_Const.magic_lid in + let uu___2 = + let uu___3 = + FStarC_Syntax_Syntax.as_arg FStarC_Syntax_Util.exp_unit in + [uu___3] in + FStarC_Syntax_Syntax.mk_Tm_app uu___1 uu___2 + typ.FStarC_Syntax_Syntax.pos + else + (let uu___2 = + run_tactic_on_typ tau.FStarC_Syntax_Syntax.pos + typ.FStarC_Syntax_Syntax.pos tau env typ in + match uu___2 with + | (gs, w) -> + (FStarC_Compiler_List.iter + (fun g -> + let uu___4 = + let uu___5 = FStarC_Tactics_Types.goal_env g in + let uu___6 = FStarC_Tactics_Types.goal_type g in + getprop uu___5 uu___6 in + match uu___4 with + | FStar_Pervasives_Native.Some vc -> + ((let uu___6 = + FStarC_Compiler_Effect.op_Bang dbg_Tac in + if uu___6 + then + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term vc in + FStarC_Compiler_Util.print1 + "Synthesis left a goal: %s\n" uu___7 + else ()); + (let guard = + FStarC_TypeChecker_Env.guard_of_guard_formula + (FStarC_TypeChecker_Common.NonTrivial vc) in + let uu___6 = FStarC_Tactics_Types.goal_env g in + FStarC_TypeChecker_Rel.force_trivial_guard + uu___6 guard)) + | FStar_Pervasives_Native.None -> + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) + typ + FStarC_Errors_Codes.Fatal_OpenGoalsInSynthesis + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "synthesis left open goals")) gs; + w))) +let (solve_implicits : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_TypeChecker_Env.implicits -> unit) + = + fun env -> + fun tau -> + fun imps -> + FStarC_Errors.with_ctx "While solving implicits with a tactic" + (fun uu___ -> + if env.FStarC_TypeChecker_Env.flychecking + then () + else + (let gs = + let uu___2 = FStarC_TypeChecker_Env.get_range env in + run_tactic_on_all_implicits tau.FStarC_Syntax_Syntax.pos + uu___2 tau env imps in + (let uu___3 = + FStarC_Options.profile_enabled + FStar_Pervasives_Native.None "FStarC.TypeChecker" in + if uu___3 + then + let uu___4 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_nat) + (FStarC_Compiler_List.length gs) in + FStarC_Compiler_Util.print1 + "solve_implicits produced %s goals\n" uu___4 + else ()); + FStarC_Options.with_saved_options + (fun uu___3 -> + let uu___4 = FStarC_Options.set_options "--no_tactics" in + FStarC_Compiler_List.iter + (fun g -> + (let uu___6 = FStarC_Tactics_Types.goal_opts g in + FStarC_Options.set uu___6); + (let uu___6 = + let uu___7 = FStarC_Tactics_Types.goal_env g in + let uu___8 = FStarC_Tactics_Types.goal_type g in + getprop uu___7 uu___8 in + match uu___6 with + | FStar_Pervasives_Native.Some vc -> + ((let uu___8 = + FStarC_Compiler_Effect.op_Bang dbg_Tac in + if uu___8 + then + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term vc in + FStarC_Compiler_Util.print1 + "Synthesis left a goal: %s\n" uu___9 + else ()); + if + Prims.op_Negation + env.FStarC_TypeChecker_Env.admit + then + (let guard = + FStarC_TypeChecker_Env.guard_of_guard_formula + (FStarC_TypeChecker_Common.NonTrivial + vc) in + FStarC_Profiling.profile + (fun uu___8 -> + let uu___9 = + FStarC_Tactics_Types.goal_env g in + FStarC_TypeChecker_Rel.force_trivial_guard + uu___9 guard) + FStar_Pervasives_Native.None + "FStarC.TypeChecker.Hooks.force_trivial_guard") + else ()) + | FStar_Pervasives_Native.None -> + FStarC_Errors.raise_error + FStarC_TypeChecker_Env.hasRange_env env + FStarC_Errors_Codes.Fatal_OpenGoalsInSynthesis + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "synthesis left open goals"))) gs))) +let (find_user_tac_for_attr : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.sigelt FStar_Pervasives_Native.option) + = + fun env -> + fun a -> + let hooks = + FStarC_TypeChecker_Env.lookup_attr env + FStarC_Parser_Const.handle_smt_goals_attr_string in + FStarC_Compiler_Util.try_find (fun uu___ -> true) hooks +let (handle_smt_goal : + FStarC_TypeChecker_Env.env -> + FStarC_TypeChecker_Env.goal -> + (FStarC_TypeChecker_Env.env * FStarC_Syntax_Syntax.term) Prims.list) + = + fun env -> + fun goal -> + let uu___ = FStarC_TypeChecker_Common.check_trivial goal in + match uu___ with + | FStarC_TypeChecker_Common.Trivial -> [(env, goal)] + | FStarC_TypeChecker_Common.NonTrivial goal1 -> + let uu___1 = + let uu___2 = + FStarC_Syntax_Syntax.tconst + FStarC_Parser_Const.handle_smt_goals_attr in + find_user_tac_for_attr env uu___2 in + (match uu___1 with + | FStar_Pervasives_Native.Some tac -> + let tau = + match tac.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = uu___2; + FStarC_Syntax_Syntax.lids1 = lid::[];_} + -> + let qn = FStarC_TypeChecker_Env.lookup_qname env lid in + let fv = + FStarC_Syntax_Syntax.lid_as_fv lid + FStar_Pervasives_Native.None in + let uu___3 = + FStarC_Syntax_Syntax.lid_as_fv lid + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___3 + | uu___2 -> failwith "Resolve_tac not found" in + let gs = + FStarC_Errors.with_ctx + "While handling an SMT goal with a tactic" + (fun uu___2 -> + let uu___3 = + let uu___4 = FStarC_TypeChecker_Env.get_range env in + let uu___5 = + FStarC_Syntax_Util.mk_squash + FStarC_Syntax_Syntax.U_zero goal1 in + run_tactic_on_typ tau.FStarC_Syntax_Syntax.pos uu___4 + tau env uu___5 in + match uu___3 with + | (gs1, uu___4) -> + FStarC_Compiler_List.map + (fun g -> + let uu___5 = + let uu___6 = FStarC_Tactics_Types.goal_env g in + let uu___7 = + FStarC_Tactics_Types.goal_type g in + getprop uu___6 uu___7 in + match uu___5 with + | FStar_Pervasives_Native.Some vc -> + ((let uu___7 = + FStarC_Compiler_Effect.op_Bang dbg_Tac in + if uu___7 + then + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + vc in + FStarC_Compiler_Util.print1 + "handle_smt_goals left a goal: %s\n" + uu___8 + else ()); + (let uu___7 = + FStarC_Tactics_Types.goal_env g in + (uu___7, vc))) + | FStar_Pervasives_Native.None -> + FStarC_Errors.raise_error + FStarC_TypeChecker_Env.hasRange_env env + FStarC_Errors_Codes.Fatal_OpenGoalsInSynthesis + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Handling an SMT goal by tactic left non-prop open goals")) + gs1) in + gs + | FStar_Pervasives_Native.None -> [(env, goal1)]) +let (uu___0 : + FStarC_Syntax_Syntax.term FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Reflection_V2_Embeddings.e_term +type blob_t = + (Prims.string * FStarC_Syntax_Syntax.term) FStar_Pervasives_Native.option +type dsl_typed_sigelt_t = (Prims.bool * FStarC_Syntax_Syntax.sigelt * blob_t) +type dsl_tac_result_t = + (dsl_typed_sigelt_t Prims.list * dsl_typed_sigelt_t * dsl_typed_sigelt_t + Prims.list) +let (splice : + FStarC_TypeChecker_Env.env -> + Prims.bool -> + FStarC_Ident.lident Prims.list -> + FStarC_Syntax_Syntax.term -> + FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.sigelt Prims.list) + = + fun env -> + fun is_typed -> + fun lids -> + fun tau -> + fun rng -> + FStarC_Errors.with_ctx "While running splice with a tactic" + (fun uu___ -> + if env.FStarC_TypeChecker_Env.flychecking + then [] + else + (let uu___2 = + if is_typed + then + FStarC_TypeChecker_TcTerm.tc_check_tot_or_gtot_term + env tau FStarC_Syntax_Util.t_dsl_tac_typ + FStar_Pervasives_Native.None + else + FStarC_TypeChecker_TcTerm.tc_tactic + FStarC_Syntax_Syntax.t_unit + FStarC_Syntax_Syntax.t_decls env tau in + match uu___2 with + | (tau1, uu___3, g) -> + (FStarC_TypeChecker_Rel.force_trivial_guard env g; + (let ps = + FStarC_Tactics_V2_Basic.proofstate_of_goals + tau1.FStarC_Syntax_Syntax.pos env [] [] in + let tactic_already_typed = true in + let uu___5 = + if is_typed + then + (if + (FStarC_Compiler_List.length lids) > + Prims.int_one + then + let uu___6 = + let uu___7 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Ident.showable_lident) lids in + FStarC_Compiler_Util.format1 + "Typed splice: unexpected lids length (> 1) (%s)" + uu___7 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range rng + FStarC_Errors_Codes.Error_BadSplice () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___6) + else + (let val_t = + if + (FStarC_Compiler_List.length lids) = + Prims.int_zero + then FStar_Pervasives_Native.None + else + (let uu___8 = + let uu___9 = + FStarC_Compiler_List.hd lids in + FStarC_TypeChecker_Env.try_lookup_val_decl + env uu___9 in + match uu___8 with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some + ((uvs, tval), uu___9) -> + if + (FStarC_Compiler_List.length uvs) + <> Prims.int_zero + then + let uu___10 = + let uu___11 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_nat) + (FStarC_Compiler_List.length + uvs) in + FStarC_Compiler_Util.format1 + "Typed splice: val declaration for %s is universe polymorphic in %s universes, expected 0" + uu___11 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + rng + FStarC_Errors_Codes.Error_BadSplice + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___10) + else + FStar_Pervasives_Native.Some + tval) in + let uu___7 = + FStarC_Tactics_Interpreter.run_tactic_on_ps + tau1.FStarC_Syntax_Syntax.pos + tau1.FStarC_Syntax_Syntax.pos false + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Reflection_V2_Embeddings.e_env + (FStarC_Syntax_Embeddings.e_option + uu___0)) + ({ + FStarC_TypeChecker_Env.solver = + (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = []; + FStarC_TypeChecker_Env.gamma_sig = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ + = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp + = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict + = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = false; + FStarC_TypeChecker_Env.lax_universes + = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping + = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force + = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths + = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info + = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab + = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl + = + (env.FStarC_TypeChecker_Env.missing_decl) + }, val_t) + (FStarC_Syntax_Embeddings.e_tuple3 + (FStarC_Syntax_Embeddings.e_list + (FStarC_Syntax_Embeddings.e_tuple3 + FStarC_Syntax_Embeddings.e_bool + FStarC_Reflection_V2_Embeddings.e_sigelt + (FStarC_Syntax_Embeddings.e_option + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Syntax_Embeddings.e_string + uu___0)))) + (FStarC_Syntax_Embeddings.e_tuple3 + FStarC_Syntax_Embeddings.e_bool + FStarC_Reflection_V2_Embeddings.e_sigelt + (FStarC_Syntax_Embeddings.e_option + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Syntax_Embeddings.e_string + uu___0))) + (FStarC_Syntax_Embeddings.e_list + (FStarC_Syntax_Embeddings.e_tuple3 + FStarC_Syntax_Embeddings.e_bool + FStarC_Reflection_V2_Embeddings.e_sigelt + (FStarC_Syntax_Embeddings.e_option + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Syntax_Embeddings.e_string + uu___0))))) tau1 + tactic_already_typed ps in + match uu___7 with + | (gs, + (sig_blobs_before, sig_blob, + sig_blobs_after)) -> + let uu___8 = uu___7 in + let sig_blobs = + FStarC_Compiler_List.op_At + sig_blobs_before (sig_blob :: + sig_blobs_after) in + let sigelts = + FStarC_Compiler_List.map + (fun uu___9 -> + match uu___9 with + | (checked, se, blob_opt) -> + let uu___10 = + let uu___11 = + se.FStarC_Syntax_Syntax.sigmeta in + let uu___12 = + match blob_opt with + | FStar_Pervasives_Native.Some + (s, blob) -> + let uu___13 = + let uu___14 = + FStarC_Dyn.mkdyn + blob in + (s, uu___14) in + [uu___13] + | FStar_Pervasives_Native.None + -> [] in + { + FStarC_Syntax_Syntax.sigmeta_active + = + (uu___11.FStarC_Syntax_Syntax.sigmeta_active); + FStarC_Syntax_Syntax.sigmeta_fact_db_ids + = + (uu___11.FStarC_Syntax_Syntax.sigmeta_fact_db_ids); + FStarC_Syntax_Syntax.sigmeta_admit + = + (uu___11.FStarC_Syntax_Syntax.sigmeta_admit); + FStarC_Syntax_Syntax.sigmeta_spliced + = + (uu___11.FStarC_Syntax_Syntax.sigmeta_spliced); + FStarC_Syntax_Syntax.sigmeta_already_checked + = checked; + FStarC_Syntax_Syntax.sigmeta_extension_data + = uu___12 + } in + { + FStarC_Syntax_Syntax.sigel + = + (se.FStarC_Syntax_Syntax.sigel); + FStarC_Syntax_Syntax.sigrng + = + (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals + = + (se.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta + = uu___10; + FStarC_Syntax_Syntax.sigattrs + = + (se.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts + = + (se.FStarC_Syntax_Syntax.sigopts) + }) sig_blobs in + (gs, sigelts))) + else + FStarC_Tactics_Interpreter.run_tactic_on_ps + tau1.FStarC_Syntax_Syntax.pos + tau1.FStarC_Syntax_Syntax.pos false + FStarC_Syntax_Embeddings.e_unit () + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_sigelt) + tau1 tactic_already_typed ps in + match uu___5 with + | (gs, sigelts) -> + let sigelts1 = + let set_lb_dd lb = + let uu___6 = lb in + match uu___6 with + | { + FStarC_Syntax_Syntax.lbname = + FStar_Pervasives.Inr fv; + FStarC_Syntax_Syntax.lbunivs = uu___7; + FStarC_Syntax_Syntax.lbtyp = uu___8; + FStarC_Syntax_Syntax.lbeff = uu___9; + FStarC_Syntax_Syntax.lbdef = lbdef; + FStarC_Syntax_Syntax.lbattrs = uu___10; + FStarC_Syntax_Syntax.lbpos = uu___11;_} + -> + { + FStarC_Syntax_Syntax.lbname = + (FStar_Pervasives.Inr fv); + FStarC_Syntax_Syntax.lbunivs = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = + (lb.FStarC_Syntax_Syntax.lbtyp); + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = + (lb.FStarC_Syntax_Syntax.lbdef); + FStarC_Syntax_Syntax.lbattrs = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + } in + FStarC_Compiler_List.map + (fun se -> + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_let + { + FStarC_Syntax_Syntax.lbs1 = + (is_rec, lbs); + FStarC_Syntax_Syntax.lids1 = lids1;_} + -> + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Compiler_List.map + set_lb_dd lbs in + (is_rec, uu___9) in + { + FStarC_Syntax_Syntax.lbs1 = + uu___8; + FStarC_Syntax_Syntax.lids1 = + lids1 + } in + FStarC_Syntax_Syntax.Sig_let + uu___7 in + { + FStarC_Syntax_Syntax.sigel = + uu___6; + FStarC_Syntax_Syntax.sigrng = + (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se.FStarC_Syntax_Syntax.sigopts) + } + | uu___6 -> se) sigelts in + (FStarC_Options.with_saved_options + (fun uu___7 -> + FStarC_Compiler_List.iter + (fun g1 -> + (let uu___9 = + FStarC_Tactics_Types.goal_opts g1 in + FStarC_Options.set uu___9); + (let uu___9 = + let uu___10 = + FStarC_Tactics_Types.goal_env + g1 in + let uu___11 = + FStarC_Tactics_Types.goal_type + g1 in + getprop uu___10 uu___11 in + match uu___9 with + | FStar_Pervasives_Native.Some vc + -> + ((let uu___11 = + FStarC_Compiler_Effect.op_Bang + dbg_Tac in + if uu___11 + then + let uu___12 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + vc in + FStarC_Compiler_Util.print1 + "Splice left a goal: %s\n" + uu___12 + else ()); + (let guard = + FStarC_TypeChecker_Env.guard_of_guard_formula + (FStarC_TypeChecker_Common.NonTrivial + vc) in + let uu___11 = + FStarC_Tactics_Types.goal_env + g1 in + FStarC_TypeChecker_Rel.force_trivial_guard + uu___11 guard)) + | FStar_Pervasives_Native.None -> + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + rng + FStarC_Errors_Codes.Fatal_OpenGoalsInSynthesis + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "splice left open goals"))) + gs); + (let lids' = + FStarC_Compiler_List.collect + FStarC_Syntax_Util.lids_of_sigelt + sigelts1 in + FStarC_Compiler_List.iter + (fun lid -> + let uu___8 = + FStarC_Compiler_List.tryFind + (FStarC_Ident.lid_equals lid) lids' in + match uu___8 with + | FStar_Pervasives_Native.None when + Prims.op_Negation + env.FStarC_TypeChecker_Env.flychecking + -> + let uu___9 = + let uu___10 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + lid in + let uu___11 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Ident.showable_lident) + lids' in + FStarC_Compiler_Util.format2 + "Splice declared the name %s but it was not defined.\nThose defined were: %s" + uu___10 uu___11 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + rng + FStarC_Errors_Codes.Fatal_SplicedUndef + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___9) + | uu___9 -> ()) lids; + (let uu___9 = + FStarC_Compiler_Effect.op_Bang dbg_Tac in + if uu___9 + then + let uu___10 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_sigelt) + sigelts1 in + FStarC_Compiler_Util.print1 + "splice: got decls = {\n\n%s\n\n}\n" + uu___10 + else ()); + (let sigelts2 = + FStarC_Compiler_List.map + (fun se -> + (match se.FStarC_Syntax_Syntax.sigel + with + | FStarC_Syntax_Syntax.Sig_datacon + uu___10 -> + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Errors_Msg.text + "Tactic returned bad sigelt:" in + let uu___14 = + let uu___15 = + FStarC_Syntax_Print.sigelt_to_string_short + se in + FStarC_Pprint.doc_of_string + uu___15 in + FStarC_Pprint.op_Hat_Slash_Hat + uu___13 uu___14 in + let uu___13 = + let uu___14 = + FStarC_Errors_Msg.text + "If you wanted to splice an inductive type, call `pack` providing a `Sg_Inductive` to get a proper sigelt." in + [uu___14] in + uu___12 :: uu___13 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + rng + FStarC_Errors_Codes.Error_BadSplice + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___11) + | FStarC_Syntax_Syntax.Sig_inductive_typ + uu___10 -> + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Errors_Msg.text + "Tactic returned bad sigelt:" in + let uu___14 = + let uu___15 = + FStarC_Syntax_Print.sigelt_to_string_short + se in + FStarC_Pprint.doc_of_string + uu___15 in + FStarC_Pprint.op_Hat_Slash_Hat + uu___13 uu___14 in + let uu___13 = + let uu___14 = + FStarC_Errors_Msg.text + "If you wanted to splice an inductive type, call `pack` providing a `Sg_Inductive` to get a proper sigelt." in + [uu___14] in + uu___12 :: uu___13 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + rng + FStarC_Errors_Codes.Error_BadSplice + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___11) + | uu___10 -> ()); + { + FStarC_Syntax_Syntax.sigel = + (se.FStarC_Syntax_Syntax.sigel); + FStarC_Syntax_Syntax.sigrng = rng; + FStarC_Syntax_Syntax.sigquals = + (se.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se.FStarC_Syntax_Syntax.sigopts) + }) sigelts1 in + if is_typed + then () + else + FStarC_Compiler_List.iter + (fun se -> + FStarC_Compiler_List.iter + (fun q -> + let uu___11 = + FStarC_Syntax_Syntax.is_internal_qualifier + q in + if uu___11 + then + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_qualifier + q in + FStarC_Compiler_Util.format1 + "The qualifier %s is internal." + uu___15 in + FStarC_Errors_Msg.text + uu___14 in + let uu___14 = + let uu___15 = + let uu___16 = + FStarC_Errors_Msg.text + "It cannot be attached to spliced declaration:" in + let uu___17 = + let uu___18 = + FStarC_Syntax_Print.sigelt_to_string_short + se in + FStarC_Pprint.arbitrary_string + uu___18 in + FStarC_Pprint.prefix + (Prims.of_int (2)) + Prims.int_one uu___16 + uu___17 in + [uu___15] in + uu___13 :: uu___14 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + rng + FStarC_Errors_Codes.Error_InternalQualifier + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___12) + else ()) + se.FStarC_Syntax_Syntax.sigquals) + sigelts2; + (match () with | () -> sigelts2)))))))) +let (mpreprocess : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun env -> + fun tau -> + fun tm -> + FStarC_Errors.with_ctx + "While preprocessing a definition with a tactic" + (fun uu___ -> + if env.FStarC_TypeChecker_Env.flychecking + then tm + else + (let ps = + FStarC_Tactics_V2_Basic.proofstate_of_goals + tm.FStarC_Syntax_Syntax.pos env [] [] in + let tactic_already_typed = false in + let uu___2 = + FStarC_Tactics_Interpreter.run_tactic_on_ps + tau.FStarC_Syntax_Syntax.pos tm.FStarC_Syntax_Syntax.pos + false FStarC_Reflection_V2_Embeddings.e_term tm + FStarC_Reflection_V2_Embeddings.e_term tau + tactic_already_typed ps in + match uu___2 with | (gs, tm1) -> tm1)) +let (postprocess : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun env -> + fun tau -> + fun typ -> + fun tm -> + FStarC_Errors.with_ctx + "While postprocessing a definition with a tactic" + (fun uu___ -> + if env.FStarC_TypeChecker_Env.flychecking + then tm + else + (let uu___2 = + FStarC_TypeChecker_Env.new_implicit_var_aux + "postprocess RHS" tm.FStarC_Syntax_Syntax.pos env typ + (FStarC_Syntax_Syntax.Allow_untyped "postprocess") + FStar_Pervasives_Native.None false in + match uu___2 with + | (uvtm, uu___3, g_imp) -> + let u = env.FStarC_TypeChecker_Env.universe_of env typ in + let goal = + let uu___4 = FStarC_Syntax_Util.mk_eq2 u typ tm uvtm in + FStarC_Syntax_Util.mk_squash + FStarC_Syntax_Syntax.U_zero uu___4 in + let uu___4 = + run_tactic_on_typ tau.FStarC_Syntax_Syntax.pos + tm.FStarC_Syntax_Syntax.pos tau env goal in + (match uu___4 with + | (gs, w) -> + (FStarC_Compiler_List.iter + (fun g -> + let uu___6 = + let uu___7 = + FStarC_Tactics_Types.goal_env g in + let uu___8 = + FStarC_Tactics_Types.goal_type g in + getprop uu___7 uu___8 in + match uu___6 with + | FStar_Pervasives_Native.Some vc -> + ((let uu___8 = + FStarC_Compiler_Effect.op_Bang + dbg_Tac in + if uu___8 + then + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + vc in + FStarC_Compiler_Util.print1 + "Postprocessing left a goal: %s\n" + uu___9 + else ()); + (let guard = + FStarC_TypeChecker_Env.guard_of_guard_formula + (FStarC_TypeChecker_Common.NonTrivial + vc) in + let uu___8 = + FStarC_Tactics_Types.goal_env g in + FStarC_TypeChecker_Rel.force_trivial_guard + uu___8 guard)) + | FStar_Pervasives_Native.None -> + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax + ()) typ + FStarC_Errors_Codes.Fatal_OpenGoalsInSynthesis + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "postprocessing left open goals")) + gs; + (let tagged_imps = + FStarC_TypeChecker_Rel.resolve_implicits_tac + env g_imp in + FStarC_Tactics_Interpreter.report_implicits + tm.FStarC_Syntax_Syntax.pos tagged_imps; + uvtm))))) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Tactics_InterpFuns.ml b/ocaml/fstar-lib/generated/FStarC_Tactics_InterpFuns.ml new file mode 100644 index 00000000000..2790c874a96 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Tactics_InterpFuns.ml @@ -0,0 +1,13508 @@ +open Prims +let solve : 'a . 'a -> 'a = fun ev -> ev +let embed : + 'a . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_Compiler_Range_Type.range -> + 'a -> + FStarC_Syntax_Embeddings_Base.norm_cb -> FStarC_Syntax_Syntax.term + = + fun e -> + fun rng -> + fun t -> + fun n -> + let uu___ = FStarC_Syntax_Embeddings_Base.embed e t in + uu___ rng FStar_Pervasives_Native.None n +let unembed : + 'a . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + 'a FStar_Pervasives_Native.option + = fun e -> fun t -> fun n -> FStarC_Syntax_Embeddings_Base.unembed e t n +let interp_ctx : 'a . Prims.string -> (unit -> 'a) -> 'a = + fun s -> + fun f -> + FStarC_Errors.with_ctx (Prims.strcat "While running primitive " s) f +let run_wrap : + 'a . + Prims.string -> + 'a FStarC_Tactics_Monad.tac -> + FStarC_Tactics_Types.proofstate -> 'a FStarC_Tactics_Result.__result + = + fun label -> + fun t -> + fun ps -> + interp_ctx label (fun uu___ -> FStarC_Tactics_Monad.run_safe t ps) +let (builtin_lid : Prims.string -> FStarC_Ident.lid) = + fun nm -> + FStarC_Parser_Const.fstar_stubs_tactics_lid' ["V2"; "Builtins"; nm] +let (types_lid : Prims.string -> FStarC_Ident.lid) = + fun nm -> FStarC_Parser_Const.fstar_stubs_tactics_lid' ["Types"; nm] +let (set_auto_reflect : + Prims.int -> + FStarC_TypeChecker_Primops_Base.primitive_step -> + FStarC_TypeChecker_Primops_Base.primitive_step) + = + fun arity -> + fun p -> + { + FStarC_TypeChecker_Primops_Base.name = + (p.FStarC_TypeChecker_Primops_Base.name); + FStarC_TypeChecker_Primops_Base.arity = + (p.FStarC_TypeChecker_Primops_Base.arity); + FStarC_TypeChecker_Primops_Base.univ_arity = + (p.FStarC_TypeChecker_Primops_Base.univ_arity); + FStarC_TypeChecker_Primops_Base.auto_reflect = + (FStar_Pervasives_Native.Some arity); + FStarC_TypeChecker_Primops_Base.strong_reduction_ok = + (p.FStarC_TypeChecker_Primops_Base.strong_reduction_ok); + FStarC_TypeChecker_Primops_Base.requires_binder_substitution = + (p.FStarC_TypeChecker_Primops_Base.requires_binder_substitution); + FStarC_TypeChecker_Primops_Base.renorm_after = + (p.FStarC_TypeChecker_Primops_Base.renorm_after); + FStarC_TypeChecker_Primops_Base.interpretation = + (p.FStarC_TypeChecker_Primops_Base.interpretation); + FStarC_TypeChecker_Primops_Base.interpretation_nbe = + (p.FStarC_TypeChecker_Primops_Base.interpretation_nbe) + } +let mk_tot_step_1 : + 'nres 'nt1 'res 't1 . + Prims.int -> + Prims.string -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 'res FStarC_Syntax_Embeddings_Base.embedding -> + 'nt1 FStarC_TypeChecker_NBETerm.embedding -> + 'nres FStarC_TypeChecker_NBETerm.embedding -> + ('t1 -> 'res) -> + ('nt1 -> 'nres) -> + FStarC_TypeChecker_Primops_Base.primitive_step + = + fun uarity -> + fun nm -> + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun f -> + fun nbe_f -> + let lid = types_lid nm in + FStarC_TypeChecker_Primops_Base.mk1' uarity lid uu___ + uu___2 uu___1 uu___3 + (fun x -> + let uu___4 = f x in + FStar_Pervasives_Native.Some uu___4) + (fun x -> + let uu___4 = nbe_f x in + FStar_Pervasives_Native.Some uu___4) +let mk_tot_step_2 : + 'nres 'nt1 'nt2 'res 't1 't2 . + Prims.int -> + Prims.string -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 'res FStarC_Syntax_Embeddings_Base.embedding -> + 'nt1 FStarC_TypeChecker_NBETerm.embedding -> + 'nt2 FStarC_TypeChecker_NBETerm.embedding -> + 'nres FStarC_TypeChecker_NBETerm.embedding -> + ('t1 -> 't2 -> 'res) -> + ('nt1 -> 'nt2 -> 'nres) -> + FStarC_TypeChecker_Primops_Base.primitive_step + = + fun uarity -> + fun nm -> + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun uu___4 -> + fun uu___5 -> + fun f -> + fun nbe_f -> + let lid = types_lid nm in + FStarC_TypeChecker_Primops_Base.mk2' uarity lid uu___ + uu___3 uu___1 uu___4 uu___2 uu___5 + (fun x -> + fun y -> + let uu___6 = f x y in + FStar_Pervasives_Native.Some uu___6) + (fun x -> + fun y -> + let uu___6 = nbe_f x y in + FStar_Pervasives_Native.Some uu___6) +let mk_tot_step_1_psc : + 'nres 'nt1 'res 't1 . + Prims.int -> + Prims.string -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 'res FStarC_Syntax_Embeddings_Base.embedding -> + 'nt1 FStarC_TypeChecker_NBETerm.embedding -> + 'nres FStarC_TypeChecker_NBETerm.embedding -> + (FStarC_TypeChecker_Primops_Base.psc -> 't1 -> 'res) -> + (FStarC_TypeChecker_Primops_Base.psc -> 'nt1 -> 'nres) -> + FStarC_TypeChecker_Primops_Base.primitive_step + = + fun us -> + fun nm -> + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun f -> + fun nbe_f -> + let lid = types_lid nm in + FStarC_TypeChecker_Primops_Base.mk1_psc' us lid uu___ + uu___2 uu___1 uu___3 + (fun psc -> + fun x -> + let uu___4 = f psc x in + FStar_Pervasives_Native.Some uu___4) + (fun psc -> + fun x -> + let uu___4 = nbe_f psc x in + FStar_Pervasives_Native.Some uu___4) +let mk_tac_step_1 : + 'nres 'nt1 'res 't1 . + Prims.int -> + Prims.string -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 'res FStarC_Syntax_Embeddings_Base.embedding -> + 'nt1 FStarC_TypeChecker_NBETerm.embedding -> + 'nres FStarC_TypeChecker_NBETerm.embedding -> + ('t1 -> 'res FStarC_Tactics_Monad.tac) -> + ('nt1 -> 'nres FStarC_Tactics_Monad.tac) -> + FStarC_TypeChecker_Primops_Base.primitive_step + = + fun univ_arity -> + fun nm -> + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun f -> + fun nbe_f -> + let lid = builtin_lid nm in + let uu___4 = + FStarC_TypeChecker_Primops_Base.mk2' univ_arity lid uu___ + uu___2 FStarC_Tactics_Embedding.e_proofstate + FStarC_Tactics_Embedding.e_proofstate_nbe + (FStarC_Tactics_Embedding.e_result uu___1) + (FStarC_Tactics_Embedding.e_result_nbe uu___3) + (fun a -> + fun ps -> + let uu___5 = + let uu___6 = f a in run_wrap nm uu___6 ps in + FStar_Pervasives_Native.Some uu___5) + (fun a -> + fun ps -> + let uu___5 = + let uu___6 = nbe_f a in run_wrap nm uu___6 ps in + FStar_Pervasives_Native.Some uu___5) in + set_auto_reflect Prims.int_one uu___4 +let mk_tac_step_2 : + 'nres 'nt1 'nt2 'res 't1 't2 . + Prims.int -> + Prims.string -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 'res FStarC_Syntax_Embeddings_Base.embedding -> + 'nt1 FStarC_TypeChecker_NBETerm.embedding -> + 'nt2 FStarC_TypeChecker_NBETerm.embedding -> + 'nres FStarC_TypeChecker_NBETerm.embedding -> + ('t1 -> 't2 -> 'res FStarC_Tactics_Monad.tac) -> + ('nt1 -> 'nt2 -> 'nres FStarC_Tactics_Monad.tac) -> + FStarC_TypeChecker_Primops_Base.primitive_step + = + fun univ_arity -> + fun nm -> + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun uu___4 -> + fun uu___5 -> + fun f -> + fun nbe_f -> + let lid = builtin_lid nm in + let uu___6 = + FStarC_TypeChecker_Primops_Base.mk3' univ_arity lid + uu___ uu___3 uu___1 uu___4 + FStarC_Tactics_Embedding.e_proofstate + FStarC_Tactics_Embedding.e_proofstate_nbe + (FStarC_Tactics_Embedding.e_result uu___2) + (FStarC_Tactics_Embedding.e_result_nbe uu___5) + (fun a -> + fun b -> + fun ps -> + let uu___7 = + let uu___8 = f a b in + run_wrap nm uu___8 ps in + FStar_Pervasives_Native.Some uu___7) + (fun a -> + fun b -> + fun ps -> + let uu___7 = + let uu___8 = nbe_f a b in + run_wrap nm uu___8 ps in + FStar_Pervasives_Native.Some uu___7) in + set_auto_reflect (Prims.of_int (2)) uu___6 +let mk_tac_step_3 : + 'nres 'nt1 'nt2 'nt3 'res 't1 't2 't3 . + Prims.int -> + Prims.string -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 'res FStarC_Syntax_Embeddings_Base.embedding -> + 'nt1 FStarC_TypeChecker_NBETerm.embedding -> + 'nt2 FStarC_TypeChecker_NBETerm.embedding -> + 'nt3 FStarC_TypeChecker_NBETerm.embedding -> + 'nres FStarC_TypeChecker_NBETerm.embedding -> + ('t1 -> 't2 -> 't3 -> 'res FStarC_Tactics_Monad.tac) + -> + ('nt1 -> + 'nt2 -> 'nt3 -> 'nres FStarC_Tactics_Monad.tac) + -> FStarC_TypeChecker_Primops_Base.primitive_step + = + fun univ_arity -> + fun nm -> + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun uu___4 -> + fun uu___5 -> + fun uu___6 -> + fun uu___7 -> + fun f -> + fun nbe_f -> + let lid = builtin_lid nm in + let uu___8 = + FStarC_TypeChecker_Primops_Base.mk4' univ_arity + lid uu___ uu___4 uu___1 uu___5 uu___2 uu___6 + FStarC_Tactics_Embedding.e_proofstate + FStarC_Tactics_Embedding.e_proofstate_nbe + (FStarC_Tactics_Embedding.e_result uu___3) + (FStarC_Tactics_Embedding.e_result_nbe uu___7) + (fun a -> + fun b -> + fun c -> + fun ps -> + let uu___9 = + let uu___10 = f a b c in + run_wrap nm uu___10 ps in + FStar_Pervasives_Native.Some uu___9) + (fun a -> + fun b -> + fun c -> + fun ps -> + let uu___9 = + let uu___10 = nbe_f a b c in + run_wrap nm uu___10 ps in + FStar_Pervasives_Native.Some uu___9) in + set_auto_reflect (Prims.of_int (3)) uu___8 +let mk_tac_step_4 : + 'nres 'nt1 'nt2 'nt3 'nt4 'res 't1 't2 't3 't4 . + Prims.int -> + Prims.string -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 'res FStarC_Syntax_Embeddings_Base.embedding -> + 'nt1 FStarC_TypeChecker_NBETerm.embedding -> + 'nt2 FStarC_TypeChecker_NBETerm.embedding -> + 'nt3 FStarC_TypeChecker_NBETerm.embedding -> + 'nt4 FStarC_TypeChecker_NBETerm.embedding -> + 'nres FStarC_TypeChecker_NBETerm.embedding -> + ('t1 -> + 't2 -> + 't3 -> 't4 -> 'res FStarC_Tactics_Monad.tac) + -> + ('nt1 -> + 'nt2 -> + 'nt3 -> + 'nt4 -> 'nres FStarC_Tactics_Monad.tac) + -> + FStarC_TypeChecker_Primops_Base.primitive_step + = + fun univ_arity -> + fun nm -> + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun uu___4 -> + fun uu___5 -> + fun uu___6 -> + fun uu___7 -> + fun uu___8 -> + fun uu___9 -> + fun f -> + fun nbe_f -> + let lid = builtin_lid nm in + let uu___10 = + FStarC_TypeChecker_Primops_Base.mk5' + univ_arity lid uu___ uu___5 uu___1 uu___6 + uu___2 uu___7 uu___3 uu___8 + FStarC_Tactics_Embedding.e_proofstate + FStarC_Tactics_Embedding.e_proofstate_nbe + (FStarC_Tactics_Embedding.e_result uu___4) + (FStarC_Tactics_Embedding.e_result_nbe + uu___9) + (fun a -> + fun b -> + fun c -> + fun d -> + fun ps -> + let uu___11 = + let uu___12 = f a b c d in + run_wrap nm uu___12 ps in + FStar_Pervasives_Native.Some + uu___11) + (fun a -> + fun b -> + fun c -> + fun d -> + fun ps -> + let uu___11 = + let uu___12 = nbe_f a b c d in + run_wrap nm uu___12 ps in + FStar_Pervasives_Native.Some + uu___11) in + set_auto_reflect (Prims.of_int (4)) uu___10 +let mk_tac_step_5 : + 'nres 'nt1 'nt2 'nt3 'nt4 'nt5 'res 't1 't2 't3 't4 't5 . + Prims.int -> + Prims.string -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 'res FStarC_Syntax_Embeddings_Base.embedding -> + 'nt1 FStarC_TypeChecker_NBETerm.embedding -> + 'nt2 FStarC_TypeChecker_NBETerm.embedding -> + 'nt3 FStarC_TypeChecker_NBETerm.embedding -> + 'nt4 FStarC_TypeChecker_NBETerm.embedding -> + 'nt5 FStarC_TypeChecker_NBETerm.embedding -> + 'nres FStarC_TypeChecker_NBETerm.embedding -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> 'res FStarC_Tactics_Monad.tac) + -> + ('nt1 -> + 'nt2 -> + 'nt3 -> + 'nt4 -> + 'nt5 -> + 'nres FStarC_Tactics_Monad.tac) + -> + FStarC_TypeChecker_Primops_Base.primitive_step + = + fun univ_arity -> + fun nm -> + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun uu___4 -> + fun uu___5 -> + fun uu___6 -> + fun uu___7 -> + fun uu___8 -> + fun uu___9 -> + fun uu___10 -> + fun uu___11 -> + fun f -> + fun nbe_f -> + let lid = builtin_lid nm in + let uu___12 = + FStarC_TypeChecker_Primops_Base.mk6' + univ_arity lid uu___ uu___6 uu___1 + uu___7 uu___2 uu___8 uu___3 uu___9 + uu___4 uu___10 + FStarC_Tactics_Embedding.e_proofstate + FStarC_Tactics_Embedding.e_proofstate_nbe + (FStarC_Tactics_Embedding.e_result + uu___5) + (FStarC_Tactics_Embedding.e_result_nbe + uu___11) + (fun a -> + fun b -> + fun c -> + fun d -> + fun e -> + fun ps -> + let uu___13 = + let uu___14 = + f a b c d e in + run_wrap nm uu___14 ps in + FStar_Pervasives_Native.Some + uu___13) + (fun a -> + fun b -> + fun c -> + fun d -> + fun e -> + fun ps -> + let uu___13 = + let uu___14 = + nbe_f a b c d e in + run_wrap nm uu___14 ps in + FStar_Pervasives_Native.Some + uu___13) in + set_auto_reflect (Prims.of_int (5)) uu___12 +let (max_tac_arity : Prims.int) = (Prims.of_int (20)) +let mk_tactic_interpretation_1 : + 'r 't1 . + Prims.string -> + ('t1 -> 'r FStarC_Tactics_Monad.tac) -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option + = + fun name -> + fun t -> + fun e1 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::[] -> + let uu___2 = unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt uu___2 + (fun a11 -> + let uu___3 = + unembed FStarC_Tactics_Embedding.e_proofstate a2 + ncb in + FStarC_Compiler_Util.bind_opt uu___3 + (fun ps -> + let ps1 = + FStarC_Tactics_Types.set_ps_psc psc ps in + let r1 = + interp_ctx name + (fun uu___4 -> + let uu___5 = t a11 in + FStarC_Tactics_Monad.run_safe uu___5 + ps1) in + let uu___4 = + let uu___5 = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed + (FStarC_Tactics_Embedding.e_result er) + uu___5 r1 ncb in + FStar_Pervasives_Native.Some uu___4)) + | uu___ -> FStar_Pervasives_Native.None +let mk_tactic_interpretation_2 : + 'r 't1 't2 . + Prims.string -> + ('t1 -> 't2 -> 'r FStarC_Tactics_Monad.tac) -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun t -> + fun e1 -> + fun e2 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2)::[] -> + let uu___3 = unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt uu___3 + (fun a11 -> + let uu___4 = unembed e2 a2 ncb in + FStarC_Compiler_Util.bind_opt uu___4 + (fun a21 -> + let uu___5 = + unembed + FStarC_Tactics_Embedding.e_proofstate + a3 ncb in + FStarC_Compiler_Util.bind_opt uu___5 + (fun ps -> + let ps1 = + FStarC_Tactics_Types.set_ps_psc psc + ps in + let r1 = + interp_ctx name + (fun uu___6 -> + let uu___7 = t a11 a21 in + FStarC_Tactics_Monad.run_safe + uu___7 ps1) in + let uu___6 = + let uu___7 = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed + (FStarC_Tactics_Embedding.e_result + er) uu___7 r1 ncb in + FStar_Pervasives_Native.Some uu___6))) + | uu___ -> FStar_Pervasives_Native.None +let mk_tactic_interpretation_3 : + 'r 't1 't2 't3 . + Prims.string -> + ('t1 -> 't2 -> 't3 -> 'r FStarC_Tactics_Monad.tac) -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2)::(a4, uu___3)::[] + -> + let uu___4 = unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt uu___4 + (fun a11 -> + let uu___5 = unembed e2 a2 ncb in + FStarC_Compiler_Util.bind_opt uu___5 + (fun a21 -> + let uu___6 = unembed e3 a3 ncb in + FStarC_Compiler_Util.bind_opt uu___6 + (fun a31 -> + let uu___7 = + unembed + FStarC_Tactics_Embedding.e_proofstate + a4 ncb in + FStarC_Compiler_Util.bind_opt uu___7 + (fun ps -> + let ps1 = + FStarC_Tactics_Types.set_ps_psc + psc ps in + let r1 = + interp_ctx name + (fun uu___8 -> + let uu___9 = + t a11 a21 a31 in + FStarC_Tactics_Monad.run_safe + uu___9 ps1) in + let uu___8 = + let uu___9 = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed + (FStarC_Tactics_Embedding.e_result + er) uu___9 r1 ncb in + FStar_Pervasives_Native.Some + uu___8)))) + | uu___ -> FStar_Pervasives_Native.None +let mk_tactic_interpretation_4 : + 'r 't1 't2 't3 't4 . + Prims.string -> + ('t1 -> 't2 -> 't3 -> 't4 -> 'r FStarC_Tactics_Monad.tac) -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2)::(a4, + uu___3):: + (a5, uu___4)::[] -> + let uu___5 = unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt uu___5 + (fun a11 -> + let uu___6 = unembed e2 a2 ncb in + FStarC_Compiler_Util.bind_opt uu___6 + (fun a21 -> + let uu___7 = unembed e3 a3 ncb in + FStarC_Compiler_Util.bind_opt uu___7 + (fun a31 -> + let uu___8 = unembed e4 a4 ncb in + FStarC_Compiler_Util.bind_opt + uu___8 + (fun a41 -> + let uu___9 = + unembed + FStarC_Tactics_Embedding.e_proofstate + a5 ncb in + FStarC_Compiler_Util.bind_opt + uu___9 + (fun ps -> + let ps1 = + FStarC_Tactics_Types.set_ps_psc + psc ps in + let r1 = + interp_ctx name + (fun uu___10 -> + let uu___11 = + t a11 a21 a31 + a41 in + FStarC_Tactics_Monad.run_safe + uu___11 ps1) in + let uu___10 = + let uu___11 = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed + (FStarC_Tactics_Embedding.e_result + er) uu___11 r1 + ncb in + FStar_Pervasives_Native.Some + uu___10))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_tactic_interpretation_5 : + 'r 't1 't2 't3 't4 't5 . + Prims.string -> + ('t1 -> 't2 -> 't3 -> 't4 -> 't5 -> 'r FStarC_Tactics_Monad.tac) -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: + (a4, uu___3)::(a5, uu___4)::(a6, uu___5)::[] -> + let uu___6 = unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt uu___6 + (fun a11 -> + let uu___7 = unembed e2 a2 ncb in + FStarC_Compiler_Util.bind_opt uu___7 + (fun a21 -> + let uu___8 = unembed e3 a3 ncb in + FStarC_Compiler_Util.bind_opt uu___8 + (fun a31 -> + let uu___9 = unembed e4 a4 ncb in + FStarC_Compiler_Util.bind_opt + uu___9 + (fun a41 -> + let uu___10 = + unembed e5 a5 ncb in + FStarC_Compiler_Util.bind_opt + uu___10 + (fun a51 -> + let uu___11 = + unembed + FStarC_Tactics_Embedding.e_proofstate + a6 ncb in + FStarC_Compiler_Util.bind_opt + uu___11 + (fun ps -> + let ps1 = + FStarC_Tactics_Types.set_ps_psc + psc ps in + let r1 = + interp_ctx name + (fun uu___12 + -> + let uu___13 + = + t a11 a21 + a31 a41 + a51 in + FStarC_Tactics_Monad.run_safe + uu___13 + ps1) in + let uu___12 = + let uu___13 = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed + (FStarC_Tactics_Embedding.e_result + er) + uu___13 r1 + ncb in + FStar_Pervasives_Native.Some + uu___12)))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_tactic_interpretation_6 : + 'r 't1 't2 't3 't4 't5 't6 . + Prims.string -> + ('t1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 'r FStarC_Tactics_Monad.tac) + -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 't6 FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: + (a4, uu___3)::(a5, uu___4)::(a6, uu___5):: + (a7, uu___6)::[] -> + let uu___7 = unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt uu___7 + (fun a11 -> + let uu___8 = unembed e2 a2 ncb in + FStarC_Compiler_Util.bind_opt uu___8 + (fun a21 -> + let uu___9 = unembed e3 a3 ncb in + FStarC_Compiler_Util.bind_opt + uu___9 + (fun a31 -> + let uu___10 = + unembed e4 a4 ncb in + FStarC_Compiler_Util.bind_opt + uu___10 + (fun a41 -> + let uu___11 = + unembed e5 a5 ncb in + FStarC_Compiler_Util.bind_opt + uu___11 + (fun a51 -> + let uu___12 = + unembed e6 a6 ncb in + FStarC_Compiler_Util.bind_opt + uu___12 + (fun a61 -> + let uu___13 = + unembed + FStarC_Tactics_Embedding.e_proofstate + a7 ncb in + FStarC_Compiler_Util.bind_opt + uu___13 + (fun ps -> + let ps1 = + FStarC_Tactics_Types.set_ps_psc + psc ps in + let r1 = + interp_ctx + name + (fun + uu___14 + -> + let uu___15 + = + t a11 a21 + a31 a41 + a51 a61 in + FStarC_Tactics_Monad.run_safe + uu___15 + ps1) in + let uu___14 + = + let uu___15 + = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed + (FStarC_Tactics_Embedding.e_result + er) + uu___15 + r1 ncb in + FStar_Pervasives_Native.Some + uu___14))))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_tactic_interpretation_7 : + 'r 't1 't2 't3 't4 't5 't6 't7 . + Prims.string -> + ('t1 -> + 't2 -> + 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 'r FStarC_Tactics_Monad.tac) + -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 't6 FStarC_Syntax_Embeddings_Base.embedding -> + 't7 FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: + (a4, uu___3)::(a5, uu___4)::(a6, uu___5):: + (a7, uu___6)::(a8, uu___7)::[] -> + let uu___8 = unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt uu___8 + (fun a11 -> + let uu___9 = unembed e2 a2 ncb in + FStarC_Compiler_Util.bind_opt uu___9 + (fun a21 -> + let uu___10 = unembed e3 a3 ncb in + FStarC_Compiler_Util.bind_opt + uu___10 + (fun a31 -> + let uu___11 = + unembed e4 a4 ncb in + FStarC_Compiler_Util.bind_opt + uu___11 + (fun a41 -> + let uu___12 = + unembed e5 a5 ncb in + FStarC_Compiler_Util.bind_opt + uu___12 + (fun a51 -> + let uu___13 = + unembed e6 a6 + ncb in + FStarC_Compiler_Util.bind_opt + uu___13 + (fun a61 -> + let uu___14 = + unembed e7 + a7 ncb in + FStarC_Compiler_Util.bind_opt + uu___14 + (fun a71 -> + let uu___15 + = + unembed + FStarC_Tactics_Embedding.e_proofstate + a8 ncb in + FStarC_Compiler_Util.bind_opt + uu___15 + (fun ps + -> + let ps1 = + FStarC_Tactics_Types.set_ps_psc + psc ps in + let r1 = + interp_ctx + name + (fun + uu___16 + -> + let uu___17 + = + t a11 a21 + a31 a41 + a51 a61 + a71 in + FStarC_Tactics_Monad.run_safe + uu___17 + ps1) in + let uu___16 + = + let uu___17 + = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed + (FStarC_Tactics_Embedding.e_result + er) + uu___17 + r1 ncb in + FStar_Pervasives_Native.Some + uu___16)))))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_tactic_interpretation_8 : + 'r 't1 't2 't3 't4 't5 't6 't7 't8 . + Prims.string -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 'r FStarC_Tactics_Monad.tac) + -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 't6 FStarC_Syntax_Embeddings_Base.embedding -> + 't7 FStarC_Syntax_Embeddings_Base.embedding -> + 't8 FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: + (a4, uu___3)::(a5, uu___4)::(a6, uu___5):: + (a7, uu___6)::(a8, uu___7)::(a9, uu___8)::[] + -> + let uu___9 = unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt uu___9 + (fun a11 -> + let uu___10 = unembed e2 a2 ncb in + FStarC_Compiler_Util.bind_opt + uu___10 + (fun a21 -> + let uu___11 = unembed e3 a3 ncb in + FStarC_Compiler_Util.bind_opt + uu___11 + (fun a31 -> + let uu___12 = + unembed e4 a4 ncb in + FStarC_Compiler_Util.bind_opt + uu___12 + (fun a41 -> + let uu___13 = + unembed e5 a5 ncb in + FStarC_Compiler_Util.bind_opt + uu___13 + (fun a51 -> + let uu___14 = + unembed e6 a6 + ncb in + FStarC_Compiler_Util.bind_opt + uu___14 + (fun a61 -> + let uu___15 + = + unembed + e7 a7 ncb in + FStarC_Compiler_Util.bind_opt + uu___15 + ( + fun a71 + -> + let uu___16 + = + unembed + e8 a8 ncb in + FStarC_Compiler_Util.bind_opt + uu___16 + (fun a81 + -> + let uu___17 + = + unembed + FStarC_Tactics_Embedding.e_proofstate + a9 ncb in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun ps + -> + let ps1 = + FStarC_Tactics_Types.set_ps_psc + psc ps in + let r1 = + interp_ctx + name + (fun + uu___18 + -> + let uu___19 + = + t a11 a21 + a31 a41 + a51 a61 + a71 a81 in + FStarC_Tactics_Monad.run_safe + uu___19 + ps1) in + let uu___18 + = + let uu___19 + = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed + (FStarC_Tactics_Embedding.e_result + er) + uu___19 + r1 ncb in + FStar_Pervasives_Native.Some + uu___18))))))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_tactic_interpretation_9 : + 'r 't1 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 'r FStarC_Tactics_Monad.tac) + -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 't6 FStarC_Syntax_Embeddings_Base.embedding -> + 't7 FStarC_Syntax_Embeddings_Base.embedding -> + 't8 FStarC_Syntax_Embeddings_Base.embedding -> + 't9 FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: + (a4, uu___3)::(a5, uu___4)::(a6, + uu___5):: + (a7, uu___6)::(a8, uu___7)::(a9, + uu___8):: + (a10, uu___9)::[] -> + let uu___10 = unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt uu___10 + (fun a11 -> + let uu___11 = unembed e2 a2 ncb in + FStarC_Compiler_Util.bind_opt + uu___11 + (fun a21 -> + let uu___12 = + unembed e3 a3 ncb in + FStarC_Compiler_Util.bind_opt + uu___12 + (fun a31 -> + let uu___13 = + unembed e4 a4 ncb in + FStarC_Compiler_Util.bind_opt + uu___13 + (fun a41 -> + let uu___14 = + unembed e5 a5 ncb in + FStarC_Compiler_Util.bind_opt + uu___14 + (fun a51 -> + let uu___15 = + unembed e6 + a6 ncb in + FStarC_Compiler_Util.bind_opt + uu___15 + (fun a61 -> + let uu___16 + = + unembed + e7 a7 ncb in + FStarC_Compiler_Util.bind_opt + uu___16 + (fun a71 + -> + let uu___17 + = + unembed + e8 a8 ncb in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a81 + -> + let uu___18 + = + unembed + e9 a9 ncb in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a91 + -> + let uu___19 + = + unembed + FStarC_Tactics_Embedding.e_proofstate + a10 ncb in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun ps + -> + let ps1 = + FStarC_Tactics_Types.set_ps_psc + psc ps in + let r1 = + interp_ctx + name + (fun + uu___20 + -> + let uu___21 + = + t a11 a21 + a31 a41 + a51 a61 + a71 a81 + a91 in + FStarC_Tactics_Monad.run_safe + uu___21 + ps1) in + let uu___20 + = + let uu___21 + = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed + (FStarC_Tactics_Embedding.e_result + er) + uu___21 + r1 ncb in + FStar_Pervasives_Native.Some + uu___20)))))))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_tactic_interpretation_10 : + 'r 't1 't10 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> 't8 -> 't9 -> 't10 -> 'r FStarC_Tactics_Monad.tac) + -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 't6 FStarC_Syntax_Embeddings_Base.embedding -> + 't7 FStarC_Syntax_Embeddings_Base.embedding -> + 't8 FStarC_Syntax_Embeddings_Base.embedding -> + 't9 FStarC_Syntax_Embeddings_Base.embedding -> + 't10 FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: + (a4, uu___3)::(a5, uu___4)::(a6, + uu___5):: + (a7, uu___6)::(a8, uu___7)::(a9, + uu___8):: + (a10, uu___9)::(a11, uu___10)::[] -> + let uu___11 = unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt uu___11 + (fun a12 -> + let uu___12 = unembed e2 a2 ncb in + FStarC_Compiler_Util.bind_opt + uu___12 + (fun a21 -> + let uu___13 = + unembed e3 a3 ncb in + FStarC_Compiler_Util.bind_opt + uu___13 + (fun a31 -> + let uu___14 = + unembed e4 a4 ncb in + FStarC_Compiler_Util.bind_opt + uu___14 + (fun a41 -> + let uu___15 = + unembed e5 a5 + ncb in + FStarC_Compiler_Util.bind_opt + uu___15 + (fun a51 -> + let uu___16 + = + unembed e6 + a6 ncb in + FStarC_Compiler_Util.bind_opt + uu___16 + (fun a61 + -> + let uu___17 + = + unembed + e7 a7 ncb in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a71 + -> + let uu___18 + = + unembed + e8 a8 ncb in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a81 + -> + let uu___19 + = + unembed + e9 a9 ncb in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a91 + -> + let uu___20 + = + unembed + e10 a10 + ncb in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a101 + -> + let uu___21 + = + unembed + FStarC_Tactics_Embedding.e_proofstate + a11 ncb in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun ps + -> + let ps1 = + FStarC_Tactics_Types.set_ps_psc + psc ps in + let r1 = + interp_ctx + name + (fun + uu___22 + -> + let uu___23 + = + t a12 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 in + FStarC_Tactics_Monad.run_safe + uu___23 + ps1) in + let uu___22 + = + let uu___23 + = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed + (FStarC_Tactics_Embedding.e_result + er) + uu___23 + r1 ncb in + FStar_Pervasives_Native.Some + uu___22))))))))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_tactic_interpretation_11 : + 'r 't1 't10 't11 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> 't10 -> 't11 -> 'r FStarC_Tactics_Monad.tac) + -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 't6 FStarC_Syntax_Embeddings_Base.embedding -> + 't7 FStarC_Syntax_Embeddings_Base.embedding -> + 't8 FStarC_Syntax_Embeddings_Base.embedding -> + 't9 FStarC_Syntax_Embeddings_Base.embedding -> + 't10 FStarC_Syntax_Embeddings_Base.embedding -> + 't11 FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, + uu___2):: + (a4, uu___3)::(a5, uu___4):: + (a6, uu___5)::(a7, uu___6):: + (a8, uu___7)::(a9, uu___8):: + (a10, uu___9)::(a11, uu___10):: + (a12, uu___11)::[] -> + let uu___12 = unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt + uu___12 + (fun a13 -> + let uu___13 = + unembed e2 a2 ncb in + FStarC_Compiler_Util.bind_opt + uu___13 + (fun a21 -> + let uu___14 = + unembed e3 a3 ncb in + FStarC_Compiler_Util.bind_opt + uu___14 + (fun a31 -> + let uu___15 = + unembed e4 a4 ncb in + FStarC_Compiler_Util.bind_opt + uu___15 + (fun a41 -> + let uu___16 = + unembed e5 a5 + ncb in + FStarC_Compiler_Util.bind_opt + uu___16 + (fun a51 -> + let uu___17 + = + unembed + e6 a6 ncb in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a61 + -> + let uu___18 + = + unembed + e7 a7 ncb in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a71 + -> + let uu___19 + = + unembed + e8 a8 ncb in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a81 + -> + let uu___20 + = + unembed + e9 a9 ncb in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a91 + -> + let uu___21 + = + unembed + e10 a10 + ncb in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a101 + -> + let uu___22 + = + unembed + e11 a11 + ncb in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a111 + -> + let uu___23 + = + unembed + FStarC_Tactics_Embedding.e_proofstate + a12 ncb in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun ps + -> + let ps1 = + FStarC_Tactics_Types.set_ps_psc + psc ps in + let r1 = + interp_ctx + name + (fun + uu___24 + -> + let uu___25 + = + t a13 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 + a111 in + FStarC_Tactics_Monad.run_safe + uu___25 + ps1) in + let uu___24 + = + let uu___25 + = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed + (FStarC_Tactics_Embedding.e_result + er) + uu___25 + r1 ncb in + FStar_Pervasives_Native.Some + uu___24)))))))))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_tactic_interpretation_12 : + 'r 't1 't10 't11 't12 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> + 't10 -> 't11 -> 't12 -> 'r FStarC_Tactics_Monad.tac) + -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 't6 FStarC_Syntax_Embeddings_Base.embedding -> + 't7 FStarC_Syntax_Embeddings_Base.embedding -> + 't8 FStarC_Syntax_Embeddings_Base.embedding -> + 't9 FStarC_Syntax_Embeddings_Base.embedding -> + 't10 FStarC_Syntax_Embeddings_Base.embedding -> + 't11 FStarC_Syntax_Embeddings_Base.embedding -> + 't12 FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1):: + (a3, uu___2)::(a4, uu___3):: + (a5, uu___4)::(a6, uu___5):: + (a7, uu___6)::(a8, uu___7):: + (a9, uu___8)::(a10, uu___9):: + (a11, uu___10)::(a12, uu___11):: + (a13, uu___12)::[] -> + let uu___13 = unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt + uu___13 + (fun a14 -> + let uu___14 = + unembed e2 a2 ncb in + FStarC_Compiler_Util.bind_opt + uu___14 + (fun a21 -> + let uu___15 = + unembed e3 a3 ncb in + FStarC_Compiler_Util.bind_opt + uu___15 + (fun a31 -> + let uu___16 = + unembed e4 a4 + ncb in + FStarC_Compiler_Util.bind_opt + uu___16 + (fun a41 -> + let uu___17 = + unembed e5 + a5 ncb in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a51 -> + let uu___18 + = + unembed + e6 a6 ncb in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a61 + -> + let uu___19 + = + unembed + e7 a7 ncb in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a71 + -> + let uu___20 + = + unembed + e8 a8 ncb in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a81 + -> + let uu___21 + = + unembed + e9 a9 ncb in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a91 + -> + let uu___22 + = + unembed + e10 a10 + ncb in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a101 + -> + let uu___23 + = + unembed + e11 a11 + ncb in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a111 + -> + let uu___24 + = + unembed + e12 a12 + ncb in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a121 + -> + let uu___25 + = + unembed + FStarC_Tactics_Embedding.e_proofstate + a13 ncb in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun ps + -> + let ps1 = + FStarC_Tactics_Types.set_ps_psc + psc ps in + let r1 = + interp_ctx + name + (fun + uu___26 + -> + let uu___27 + = + t a14 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 + a111 a121 in + FStarC_Tactics_Monad.run_safe + uu___27 + ps1) in + let uu___26 + = + let uu___27 + = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed + (FStarC_Tactics_Embedding.e_result + er) + uu___27 + r1 ncb in + FStar_Pervasives_Native.Some + uu___26))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_tactic_interpretation_13 : + 'r 't1 't10 't11 't12 't13 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> + 't10 -> + 't11 -> + 't12 -> 't13 -> 'r FStarC_Tactics_Monad.tac) + -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 't6 FStarC_Syntax_Embeddings_Base.embedding -> + 't7 FStarC_Syntax_Embeddings_Base.embedding -> + 't8 FStarC_Syntax_Embeddings_Base.embedding -> + 't9 FStarC_Syntax_Embeddings_Base.embedding -> + 't10 FStarC_Syntax_Embeddings_Base.embedding -> + 't11 FStarC_Syntax_Embeddings_Base.embedding -> + 't12 FStarC_Syntax_Embeddings_Base.embedding -> + 't13 FStarC_Syntax_Embeddings_Base.embedding + -> + 'r FStarC_Syntax_Embeddings_Base.embedding + -> + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb + -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1):: + (a3, uu___2)::(a4, uu___3):: + (a5, uu___4)::(a6, uu___5):: + (a7, uu___6)::(a8, uu___7):: + (a9, uu___8)::(a10, uu___9):: + (a11, uu___10)::(a12, uu___11):: + (a13, uu___12)::(a14, uu___13)::[] + -> + let uu___14 = unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt + uu___14 + (fun a15 -> + let uu___15 = + unembed e2 a2 ncb in + FStarC_Compiler_Util.bind_opt + uu___15 + (fun a21 -> + let uu___16 = + unembed e3 a3 ncb in + FStarC_Compiler_Util.bind_opt + uu___16 + (fun a31 -> + let uu___17 = + unembed e4 a4 + ncb in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a41 -> + let uu___18 + = + unembed + e5 a5 ncb in + FStarC_Compiler_Util.bind_opt + uu___18 + ( + fun a51 + -> + let uu___19 + = + unembed + e6 a6 ncb in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a61 + -> + let uu___20 + = + unembed + e7 a7 ncb in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a71 + -> + let uu___21 + = + unembed + e8 a8 ncb in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a81 + -> + let uu___22 + = + unembed + e9 a9 ncb in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a91 + -> + let uu___23 + = + unembed + e10 a10 + ncb in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a101 + -> + let uu___24 + = + unembed + e11 a11 + ncb in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a111 + -> + let uu___25 + = + unembed + e12 a12 + ncb in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a121 + -> + let uu___26 + = + unembed + e13 a13 + ncb in + FStarC_Compiler_Util.bind_opt + uu___26 + (fun a131 + -> + let uu___27 + = + unembed + FStarC_Tactics_Embedding.e_proofstate + a14 ncb in + FStarC_Compiler_Util.bind_opt + uu___27 + (fun ps + -> + let ps1 = + FStarC_Tactics_Types.set_ps_psc + psc ps in + let r1 = + interp_ctx + name + (fun + uu___28 + -> + let uu___29 + = + t a15 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 + a111 a121 + a131 in + FStarC_Tactics_Monad.run_safe + uu___29 + ps1) in + let uu___28 + = + let uu___29 + = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed + (FStarC_Tactics_Embedding.e_result + er) + uu___29 + r1 ncb in + FStar_Pervasives_Native.Some + uu___28)))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_tactic_interpretation_14 : + 'r 't1 't10 't11 't12 't13 't14 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> + 't10 -> + 't11 -> + 't12 -> + 't13 -> 't14 -> 'r FStarC_Tactics_Monad.tac) + -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 't6 FStarC_Syntax_Embeddings_Base.embedding -> + 't7 FStarC_Syntax_Embeddings_Base.embedding -> + 't8 FStarC_Syntax_Embeddings_Base.embedding -> + 't9 FStarC_Syntax_Embeddings_Base.embedding -> + 't10 FStarC_Syntax_Embeddings_Base.embedding -> + 't11 FStarC_Syntax_Embeddings_Base.embedding -> + 't12 FStarC_Syntax_Embeddings_Base.embedding -> + 't13 FStarC_Syntax_Embeddings_Base.embedding + -> + 't14 + FStarC_Syntax_Embeddings_Base.embedding + -> + 'r + FStarC_Syntax_Embeddings_Base.embedding + -> + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb + -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun e14 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1):: + (a3, uu___2)::(a4, uu___3):: + (a5, uu___4)::(a6, uu___5):: + (a7, uu___6)::(a8, uu___7):: + (a9, uu___8)::(a10, uu___9):: + (a11, uu___10)::(a12, + uu___11):: + (a13, uu___12)::(a14, + uu___13):: + (a15, uu___14)::[] -> + let uu___15 = + unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt + uu___15 + (fun a16 -> + let uu___16 = + unembed e2 a2 ncb in + FStarC_Compiler_Util.bind_opt + uu___16 + (fun a21 -> + let uu___17 = + unembed e3 a3 ncb in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a31 -> + let uu___18 = + unembed e4 + a4 ncb in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a41 -> + let uu___19 + = + unembed + e5 a5 ncb in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a51 + -> + let uu___20 + = + unembed + e6 a6 ncb in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a61 + -> + let uu___21 + = + unembed + e7 a7 ncb in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a71 + -> + let uu___22 + = + unembed + e8 a8 ncb in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a81 + -> + let uu___23 + = + unembed + e9 a9 ncb in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a91 + -> + let uu___24 + = + unembed + e10 a10 + ncb in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a101 + -> + let uu___25 + = + unembed + e11 a11 + ncb in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a111 + -> + let uu___26 + = + unembed + e12 a12 + ncb in + FStarC_Compiler_Util.bind_opt + uu___26 + (fun a121 + -> + let uu___27 + = + unembed + e13 a13 + ncb in + FStarC_Compiler_Util.bind_opt + uu___27 + (fun a131 + -> + let uu___28 + = + unembed + e14 a14 + ncb in + FStarC_Compiler_Util.bind_opt + uu___28 + (fun a141 + -> + let uu___29 + = + unembed + FStarC_Tactics_Embedding.e_proofstate + a15 ncb in + FStarC_Compiler_Util.bind_opt + uu___29 + (fun ps + -> + let ps1 = + FStarC_Tactics_Types.set_ps_psc + psc ps in + let r1 = + interp_ctx + name + (fun + uu___30 + -> + let uu___31 + = + t a16 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 + a111 a121 + a131 a141 in + FStarC_Tactics_Monad.run_safe + uu___31 + ps1) in + let uu___30 + = + let uu___31 + = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed + (FStarC_Tactics_Embedding.e_result + er) + uu___31 + r1 ncb in + FStar_Pervasives_Native.Some + uu___30))))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_tactic_interpretation_15 : + 'r 't1 't10 't11 't12 't13 't14 't15 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> + 't10 -> + 't11 -> + 't12 -> + 't13 -> + 't14 -> 't15 -> 'r FStarC_Tactics_Monad.tac) + -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 't6 FStarC_Syntax_Embeddings_Base.embedding -> + 't7 FStarC_Syntax_Embeddings_Base.embedding -> + 't8 FStarC_Syntax_Embeddings_Base.embedding -> + 't9 FStarC_Syntax_Embeddings_Base.embedding -> + 't10 FStarC_Syntax_Embeddings_Base.embedding -> + 't11 FStarC_Syntax_Embeddings_Base.embedding -> + 't12 FStarC_Syntax_Embeddings_Base.embedding -> + 't13 FStarC_Syntax_Embeddings_Base.embedding + -> + 't14 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't15 + FStarC_Syntax_Embeddings_Base.embedding + -> + 'r + FStarC_Syntax_Embeddings_Base.embedding + -> + FStarC_TypeChecker_Primops_Base.psc + -> + FStarC_Syntax_Embeddings_Base.norm_cb + -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun e14 -> + fun e15 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1):: + (a3, uu___2)::(a4, uu___3):: + (a5, uu___4)::(a6, uu___5):: + (a7, uu___6)::(a8, uu___7):: + (a9, uu___8)::(a10, uu___9):: + (a11, uu___10)::(a12, + uu___11):: + (a13, uu___12)::(a14, + uu___13):: + (a15, uu___14)::(a16, + uu___15)::[] + -> + let uu___16 = + unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt + uu___16 + (fun a17 -> + let uu___17 = + unembed e2 a2 ncb in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a21 -> + let uu___18 = + unembed e3 a3 + ncb in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a31 -> + let uu___19 + = + unembed e4 + a4 ncb in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a41 + -> + let uu___20 + = + unembed + e5 a5 ncb in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a51 + -> + let uu___21 + = + unembed + e6 a6 ncb in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a61 + -> + let uu___22 + = + unembed + e7 a7 ncb in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a71 + -> + let uu___23 + = + unembed + e8 a8 ncb in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a81 + -> + let uu___24 + = + unembed + e9 a9 ncb in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a91 + -> + let uu___25 + = + unembed + e10 a10 + ncb in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a101 + -> + let uu___26 + = + unembed + e11 a11 + ncb in + FStarC_Compiler_Util.bind_opt + uu___26 + (fun a111 + -> + let uu___27 + = + unembed + e12 a12 + ncb in + FStarC_Compiler_Util.bind_opt + uu___27 + (fun a121 + -> + let uu___28 + = + unembed + e13 a13 + ncb in + FStarC_Compiler_Util.bind_opt + uu___28 + (fun a131 + -> + let uu___29 + = + unembed + e14 a14 + ncb in + FStarC_Compiler_Util.bind_opt + uu___29 + (fun a141 + -> + let uu___30 + = + unembed + e15 a15 + ncb in + FStarC_Compiler_Util.bind_opt + uu___30 + (fun a151 + -> + let uu___31 + = + unembed + FStarC_Tactics_Embedding.e_proofstate + a16 ncb in + FStarC_Compiler_Util.bind_opt + uu___31 + (fun ps + -> + let ps1 = + FStarC_Tactics_Types.set_ps_psc + psc ps in + let r1 = + interp_ctx + name + (fun + uu___32 + -> + let uu___33 + = + t a17 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 + a111 a121 + a131 a141 + a151 in + FStarC_Tactics_Monad.run_safe + uu___33 + ps1) in + let uu___32 + = + let uu___33 + = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed + (FStarC_Tactics_Embedding.e_result + er) + uu___33 + r1 ncb in + FStar_Pervasives_Native.Some + uu___32)))))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_tactic_interpretation_16 : + 'r 't1 't10 't11 't12 't13 't14 't15 't16 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> + 't10 -> + 't11 -> + 't12 -> + 't13 -> + 't14 -> + 't15 -> + 't16 -> 'r FStarC_Tactics_Monad.tac) + -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 't6 FStarC_Syntax_Embeddings_Base.embedding -> + 't7 FStarC_Syntax_Embeddings_Base.embedding -> + 't8 FStarC_Syntax_Embeddings_Base.embedding -> + 't9 FStarC_Syntax_Embeddings_Base.embedding -> + 't10 FStarC_Syntax_Embeddings_Base.embedding -> + 't11 FStarC_Syntax_Embeddings_Base.embedding -> + 't12 FStarC_Syntax_Embeddings_Base.embedding -> + 't13 FStarC_Syntax_Embeddings_Base.embedding + -> + 't14 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't15 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't16 + FStarC_Syntax_Embeddings_Base.embedding + -> + 'r + FStarC_Syntax_Embeddings_Base.embedding + -> + FStarC_TypeChecker_Primops_Base.psc + -> + FStarC_Syntax_Embeddings_Base.norm_cb + -> + FStarC_Syntax_Syntax.universes + -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun e14 -> + fun e15 -> + fun e16 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1):: + (a3, uu___2)::(a4, + uu___3):: + (a5, uu___4)::(a6, + uu___5):: + (a7, uu___6)::(a8, + uu___7):: + (a9, uu___8)::(a10, + uu___9):: + (a11, uu___10)::(a12, + uu___11):: + (a13, uu___12)::(a14, + uu___13):: + (a15, uu___14)::(a16, + uu___15):: + (a17, uu___16)::[] -> + let uu___17 = + unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a18 -> + let uu___18 = + unembed e2 a2 ncb in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a21 -> + let uu___19 = + unembed e3 a3 + ncb in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a31 -> + let uu___20 + = + unembed + e4 a4 ncb in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a41 + -> + let uu___21 + = + unembed + e5 a5 ncb in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a51 + -> + let uu___22 + = + unembed + e6 a6 ncb in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a61 + -> + let uu___23 + = + unembed + e7 a7 ncb in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a71 + -> + let uu___24 + = + unembed + e8 a8 ncb in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a81 + -> + let uu___25 + = + unembed + e9 a9 ncb in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a91 + -> + let uu___26 + = + unembed + e10 a10 + ncb in + FStarC_Compiler_Util.bind_opt + uu___26 + (fun a101 + -> + let uu___27 + = + unembed + e11 a11 + ncb in + FStarC_Compiler_Util.bind_opt + uu___27 + (fun a111 + -> + let uu___28 + = + unembed + e12 a12 + ncb in + FStarC_Compiler_Util.bind_opt + uu___28 + (fun a121 + -> + let uu___29 + = + unembed + e13 a13 + ncb in + FStarC_Compiler_Util.bind_opt + uu___29 + (fun a131 + -> + let uu___30 + = + unembed + e14 a14 + ncb in + FStarC_Compiler_Util.bind_opt + uu___30 + (fun a141 + -> + let uu___31 + = + unembed + e15 a15 + ncb in + FStarC_Compiler_Util.bind_opt + uu___31 + (fun a151 + -> + let uu___32 + = + unembed + e16 a16 + ncb in + FStarC_Compiler_Util.bind_opt + uu___32 + (fun a161 + -> + let uu___33 + = + unembed + FStarC_Tactics_Embedding.e_proofstate + a17 ncb in + FStarC_Compiler_Util.bind_opt + uu___33 + (fun ps + -> + let ps1 = + FStarC_Tactics_Types.set_ps_psc + psc ps in + let r1 = + interp_ctx + name + (fun + uu___34 + -> + let uu___35 + = + t a18 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 + a111 a121 + a131 a141 + a151 a161 in + FStarC_Tactics_Monad.run_safe + uu___35 + ps1) in + let uu___34 + = + let uu___35 + = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed + (FStarC_Tactics_Embedding.e_result + er) + uu___35 + r1 ncb in + FStar_Pervasives_Native.Some + uu___34))))))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_tactic_interpretation_17 : + 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't2 't3 't4 't5 't6 't7 't8 + 't9 . + Prims.string -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> + 't10 -> + 't11 -> + 't12 -> + 't13 -> + 't14 -> + 't15 -> + 't16 -> + 't17 -> 'r FStarC_Tactics_Monad.tac) + -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 't6 FStarC_Syntax_Embeddings_Base.embedding -> + 't7 FStarC_Syntax_Embeddings_Base.embedding -> + 't8 FStarC_Syntax_Embeddings_Base.embedding -> + 't9 FStarC_Syntax_Embeddings_Base.embedding -> + 't10 FStarC_Syntax_Embeddings_Base.embedding -> + 't11 FStarC_Syntax_Embeddings_Base.embedding -> + 't12 FStarC_Syntax_Embeddings_Base.embedding -> + 't13 FStarC_Syntax_Embeddings_Base.embedding + -> + 't14 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't15 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't16 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't17 + FStarC_Syntax_Embeddings_Base.embedding + -> + 'r + FStarC_Syntax_Embeddings_Base.embedding + -> + FStarC_TypeChecker_Primops_Base.psc + -> + FStarC_Syntax_Embeddings_Base.norm_cb + -> + FStarC_Syntax_Syntax.universes + -> + FStarC_Syntax_Syntax.args + -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun e14 -> + fun e15 -> + fun e16 -> + fun e17 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1):: + (a3, uu___2)::(a4, + uu___3):: + (a5, uu___4)::(a6, + uu___5):: + (a7, uu___6)::(a8, + uu___7):: + (a9, uu___8)::(a10, + uu___9):: + (a11, uu___10):: + (a12, uu___11):: + (a13, uu___12):: + (a14, uu___13):: + (a15, uu___14):: + (a16, uu___15):: + (a17, uu___16):: + (a18, uu___17)::[] -> + let uu___18 = + unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a19 -> + let uu___19 = + unembed e2 a2 + ncb in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a21 -> + let uu___20 = + unembed e3 + a3 ncb in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a31 -> + let uu___21 + = + unembed + e4 a4 ncb in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a41 + -> + let uu___22 + = + unembed + e5 a5 ncb in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a51 + -> + let uu___23 + = + unembed + e6 a6 ncb in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a61 + -> + let uu___24 + = + unembed + e7 a7 ncb in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a71 + -> + let uu___25 + = + unembed + e8 a8 ncb in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a81 + -> + let uu___26 + = + unembed + e9 a9 ncb in + FStarC_Compiler_Util.bind_opt + uu___26 + (fun a91 + -> + let uu___27 + = + unembed + e10 a10 + ncb in + FStarC_Compiler_Util.bind_opt + uu___27 + (fun a101 + -> + let uu___28 + = + unembed + e11 a11 + ncb in + FStarC_Compiler_Util.bind_opt + uu___28 + (fun a111 + -> + let uu___29 + = + unembed + e12 a12 + ncb in + FStarC_Compiler_Util.bind_opt + uu___29 + (fun a121 + -> + let uu___30 + = + unembed + e13 a13 + ncb in + FStarC_Compiler_Util.bind_opt + uu___30 + (fun a131 + -> + let uu___31 + = + unembed + e14 a14 + ncb in + FStarC_Compiler_Util.bind_opt + uu___31 + (fun a141 + -> + let uu___32 + = + unembed + e15 a15 + ncb in + FStarC_Compiler_Util.bind_opt + uu___32 + (fun a151 + -> + let uu___33 + = + unembed + e16 a16 + ncb in + FStarC_Compiler_Util.bind_opt + uu___33 + (fun a161 + -> + let uu___34 + = + unembed + e17 a17 + ncb in + FStarC_Compiler_Util.bind_opt + uu___34 + (fun a171 + -> + let uu___35 + = + unembed + FStarC_Tactics_Embedding.e_proofstate + a18 ncb in + FStarC_Compiler_Util.bind_opt + uu___35 + (fun ps + -> + let ps1 = + FStarC_Tactics_Types.set_ps_psc + psc ps in + let r1 = + interp_ctx + name + (fun + uu___36 + -> + let uu___37 + = + t a19 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 + a111 a121 + a131 a141 + a151 a161 + a171 in + FStarC_Tactics_Monad.run_safe + uu___37 + ps1) in + let uu___36 + = + let uu___37 + = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed + (FStarC_Tactics_Embedding.e_result + er) + uu___37 + r1 ncb in + FStar_Pervasives_Native.Some + uu___36)))))))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_tactic_interpretation_18 : + 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't18 't2 't3 't4 't5 't6 't7 + 't8 't9 . + Prims.string -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> + 't10 -> + 't11 -> + 't12 -> + 't13 -> + 't14 -> + 't15 -> + 't16 -> + 't17 -> + 't18 -> 'r FStarC_Tactics_Monad.tac) + -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 't6 FStarC_Syntax_Embeddings_Base.embedding -> + 't7 FStarC_Syntax_Embeddings_Base.embedding -> + 't8 FStarC_Syntax_Embeddings_Base.embedding -> + 't9 FStarC_Syntax_Embeddings_Base.embedding -> + 't10 FStarC_Syntax_Embeddings_Base.embedding -> + 't11 FStarC_Syntax_Embeddings_Base.embedding -> + 't12 FStarC_Syntax_Embeddings_Base.embedding -> + 't13 FStarC_Syntax_Embeddings_Base.embedding + -> + 't14 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't15 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't16 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't17 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't18 + FStarC_Syntax_Embeddings_Base.embedding + -> + 'r + FStarC_Syntax_Embeddings_Base.embedding + -> + FStarC_TypeChecker_Primops_Base.psc + -> + FStarC_Syntax_Embeddings_Base.norm_cb + -> + FStarC_Syntax_Syntax.universes + -> + FStarC_Syntax_Syntax.args + -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun e14 -> + fun e15 -> + fun e16 -> + fun e17 -> + fun e18 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, + uu___1):: + (a3, uu___2):: + (a4, uu___3):: + (a5, uu___4):: + (a6, uu___5):: + (a7, uu___6):: + (a8, uu___7):: + (a9, uu___8):: + (a10, uu___9):: + (a11, uu___10):: + (a12, uu___11):: + (a13, uu___12):: + (a14, uu___13):: + (a15, uu___14):: + (a16, uu___15):: + (a17, uu___16):: + (a18, uu___17):: + (a19, uu___18)::[] -> + let uu___19 = + unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a110 -> + let uu___20 = + unembed e2 a2 + ncb in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a21 -> + let uu___21 + = + unembed + e3 a3 ncb in + FStarC_Compiler_Util.bind_opt + uu___21 + ( + fun a31 + -> + let uu___22 + = + unembed + e4 a4 ncb in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a41 + -> + let uu___23 + = + unembed + e5 a5 ncb in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a51 + -> + let uu___24 + = + unembed + e6 a6 ncb in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a61 + -> + let uu___25 + = + unembed + e7 a7 ncb in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a71 + -> + let uu___26 + = + unembed + e8 a8 ncb in + FStarC_Compiler_Util.bind_opt + uu___26 + (fun a81 + -> + let uu___27 + = + unembed + e9 a9 ncb in + FStarC_Compiler_Util.bind_opt + uu___27 + (fun a91 + -> + let uu___28 + = + unembed + e10 a10 + ncb in + FStarC_Compiler_Util.bind_opt + uu___28 + (fun a101 + -> + let uu___29 + = + unembed + e11 a11 + ncb in + FStarC_Compiler_Util.bind_opt + uu___29 + (fun a111 + -> + let uu___30 + = + unembed + e12 a12 + ncb in + FStarC_Compiler_Util.bind_opt + uu___30 + (fun a121 + -> + let uu___31 + = + unembed + e13 a13 + ncb in + FStarC_Compiler_Util.bind_opt + uu___31 + (fun a131 + -> + let uu___32 + = + unembed + e14 a14 + ncb in + FStarC_Compiler_Util.bind_opt + uu___32 + (fun a141 + -> + let uu___33 + = + unembed + e15 a15 + ncb in + FStarC_Compiler_Util.bind_opt + uu___33 + (fun a151 + -> + let uu___34 + = + unembed + e16 a16 + ncb in + FStarC_Compiler_Util.bind_opt + uu___34 + (fun a161 + -> + let uu___35 + = + unembed + e17 a17 + ncb in + FStarC_Compiler_Util.bind_opt + uu___35 + (fun a171 + -> + let uu___36 + = + unembed + e18 a18 + ncb in + FStarC_Compiler_Util.bind_opt + uu___36 + (fun a181 + -> + let uu___37 + = + unembed + FStarC_Tactics_Embedding.e_proofstate + a19 ncb in + FStarC_Compiler_Util.bind_opt + uu___37 + (fun ps + -> + let ps1 = + FStarC_Tactics_Types.set_ps_psc + psc ps in + let r1 = + interp_ctx + name + (fun + uu___38 + -> + let uu___39 + = + t a110 + a21 a31 + a41 a51 + a61 a71 + a81 a91 + a101 a111 + a121 a131 + a141 a151 + a161 a171 + a181 in + FStarC_Tactics_Monad.run_safe + uu___39 + ps1) in + let uu___38 + = + let uu___39 + = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed + (FStarC_Tactics_Embedding.e_result + er) + uu___39 + r1 ncb in + FStar_Pervasives_Native.Some + uu___38))))))))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_tactic_interpretation_19 : + 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't18 't19 't2 't3 't4 't5 + 't6 't7 't8 't9 . + Prims.string -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> + 't10 -> + 't11 -> + 't12 -> + 't13 -> + 't14 -> + 't15 -> + 't16 -> + 't17 -> + 't18 -> + 't19 -> + 'r FStarC_Tactics_Monad.tac) + -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 't6 FStarC_Syntax_Embeddings_Base.embedding -> + 't7 FStarC_Syntax_Embeddings_Base.embedding -> + 't8 FStarC_Syntax_Embeddings_Base.embedding -> + 't9 FStarC_Syntax_Embeddings_Base.embedding -> + 't10 FStarC_Syntax_Embeddings_Base.embedding -> + 't11 FStarC_Syntax_Embeddings_Base.embedding -> + 't12 FStarC_Syntax_Embeddings_Base.embedding -> + 't13 FStarC_Syntax_Embeddings_Base.embedding + -> + 't14 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't15 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't16 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't17 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't18 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't19 + FStarC_Syntax_Embeddings_Base.embedding + -> + 'r + FStarC_Syntax_Embeddings_Base.embedding + -> + FStarC_TypeChecker_Primops_Base.psc + -> + FStarC_Syntax_Embeddings_Base.norm_cb + -> + FStarC_Syntax_Syntax.universes + -> + FStarC_Syntax_Syntax.args + -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun e14 -> + fun e15 -> + fun e16 -> + fun e17 -> + fun e18 -> + fun e19 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___):: + (a2, uu___1):: + (a3, uu___2):: + (a4, uu___3):: + (a5, uu___4):: + (a6, uu___5):: + (a7, uu___6):: + (a8, uu___7):: + (a9, uu___8):: + (a10, uu___9):: + (a11, uu___10):: + (a12, uu___11):: + (a13, uu___12):: + (a14, uu___13):: + (a15, uu___14):: + (a16, uu___15):: + (a17, uu___16):: + (a18, uu___17):: + (a19, uu___18):: + (a20, uu___19)::[] + -> + let uu___20 = + unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a110 -> + let uu___21 = + unembed e2 + a2 ncb in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a21 -> + let uu___22 + = + unembed + e3 a3 ncb in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a31 + -> + let uu___23 + = + unembed + e4 a4 ncb in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a41 + -> + let uu___24 + = + unembed + e5 a5 ncb in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a51 + -> + let uu___25 + = + unembed + e6 a6 ncb in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a61 + -> + let uu___26 + = + unembed + e7 a7 ncb in + FStarC_Compiler_Util.bind_opt + uu___26 + (fun a71 + -> + let uu___27 + = + unembed + e8 a8 ncb in + FStarC_Compiler_Util.bind_opt + uu___27 + (fun a81 + -> + let uu___28 + = + unembed + e9 a9 ncb in + FStarC_Compiler_Util.bind_opt + uu___28 + (fun a91 + -> + let uu___29 + = + unembed + e10 a10 + ncb in + FStarC_Compiler_Util.bind_opt + uu___29 + (fun a101 + -> + let uu___30 + = + unembed + e11 a11 + ncb in + FStarC_Compiler_Util.bind_opt + uu___30 + (fun a111 + -> + let uu___31 + = + unembed + e12 a12 + ncb in + FStarC_Compiler_Util.bind_opt + uu___31 + (fun a121 + -> + let uu___32 + = + unembed + e13 a13 + ncb in + FStarC_Compiler_Util.bind_opt + uu___32 + (fun a131 + -> + let uu___33 + = + unembed + e14 a14 + ncb in + FStarC_Compiler_Util.bind_opt + uu___33 + (fun a141 + -> + let uu___34 + = + unembed + e15 a15 + ncb in + FStarC_Compiler_Util.bind_opt + uu___34 + (fun a151 + -> + let uu___35 + = + unembed + e16 a16 + ncb in + FStarC_Compiler_Util.bind_opt + uu___35 + (fun a161 + -> + let uu___36 + = + unembed + e17 a17 + ncb in + FStarC_Compiler_Util.bind_opt + uu___36 + (fun a171 + -> + let uu___37 + = + unembed + e18 a18 + ncb in + FStarC_Compiler_Util.bind_opt + uu___37 + (fun a181 + -> + let uu___38 + = + unembed + e19 a19 + ncb in + FStarC_Compiler_Util.bind_opt + uu___38 + (fun a191 + -> + let uu___39 + = + unembed + FStarC_Tactics_Embedding.e_proofstate + a20 ncb in + FStarC_Compiler_Util.bind_opt + uu___39 + (fun ps + -> + let ps1 = + FStarC_Tactics_Types.set_ps_psc + psc ps in + let r1 = + interp_ctx + name + (fun + uu___40 + -> + let uu___41 + = + t a110 + a21 a31 + a41 a51 + a61 a71 + a81 a91 + a101 a111 + a121 a131 + a141 a151 + a161 a171 + a181 a191 in + FStarC_Tactics_Monad.run_safe + uu___41 + ps1) in + let uu___40 + = + let uu___41 + = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed + (FStarC_Tactics_Embedding.e_result + er) + uu___41 + r1 ncb in + FStar_Pervasives_Native.Some + uu___40)))))))))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_tactic_interpretation_20 : + 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't18 't19 't2 't20 't3 't4 + 't5 't6 't7 't8 't9 . + Prims.string -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> + 't10 -> + 't11 -> + 't12 -> + 't13 -> + 't14 -> + 't15 -> + 't16 -> + 't17 -> + 't18 -> + 't19 -> + 't20 -> + 'r FStarC_Tactics_Monad.tac) + -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 't6 FStarC_Syntax_Embeddings_Base.embedding -> + 't7 FStarC_Syntax_Embeddings_Base.embedding -> + 't8 FStarC_Syntax_Embeddings_Base.embedding -> + 't9 FStarC_Syntax_Embeddings_Base.embedding -> + 't10 FStarC_Syntax_Embeddings_Base.embedding -> + 't11 FStarC_Syntax_Embeddings_Base.embedding -> + 't12 FStarC_Syntax_Embeddings_Base.embedding -> + 't13 FStarC_Syntax_Embeddings_Base.embedding + -> + 't14 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't15 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't16 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't17 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't18 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't19 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't20 + FStarC_Syntax_Embeddings_Base.embedding + -> + 'r + FStarC_Syntax_Embeddings_Base.embedding + -> + FStarC_TypeChecker_Primops_Base.psc + -> + FStarC_Syntax_Embeddings_Base.norm_cb + -> + FStarC_Syntax_Syntax.universes + -> + FStarC_Syntax_Syntax.args + -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun e14 -> + fun e15 -> + fun e16 -> + fun e17 -> + fun e18 -> + fun e19 -> + fun e20 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___):: + (a2, uu___1):: + (a3, uu___2):: + (a4, uu___3):: + (a5, uu___4):: + (a6, uu___5):: + (a7, uu___6):: + (a8, uu___7):: + (a9, uu___8):: + (a10, uu___9):: + (a11, uu___10):: + (a12, uu___11):: + (a13, uu___12):: + (a14, uu___13):: + (a15, uu___14):: + (a16, uu___15):: + (a17, uu___16):: + (a18, uu___17):: + (a19, uu___18):: + (a20, uu___19):: + (a21, uu___20)::[] + -> + let uu___21 = + unembed e1 a1 + ncb in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a110 -> + let uu___22 + = + unembed e2 + a2 ncb in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a22 + -> + let uu___23 + = + unembed + e3 a3 ncb in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a31 + -> + let uu___24 + = + unembed + e4 a4 ncb in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a41 + -> + let uu___25 + = + unembed + e5 a5 ncb in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a51 + -> + let uu___26 + = + unembed + e6 a6 ncb in + FStarC_Compiler_Util.bind_opt + uu___26 + (fun a61 + -> + let uu___27 + = + unembed + e7 a7 ncb in + FStarC_Compiler_Util.bind_opt + uu___27 + (fun a71 + -> + let uu___28 + = + unembed + e8 a8 ncb in + FStarC_Compiler_Util.bind_opt + uu___28 + (fun a81 + -> + let uu___29 + = + unembed + e9 a9 ncb in + FStarC_Compiler_Util.bind_opt + uu___29 + (fun a91 + -> + let uu___30 + = + unembed + e10 a10 + ncb in + FStarC_Compiler_Util.bind_opt + uu___30 + (fun a101 + -> + let uu___31 + = + unembed + e11 a11 + ncb in + FStarC_Compiler_Util.bind_opt + uu___31 + (fun a111 + -> + let uu___32 + = + unembed + e12 a12 + ncb in + FStarC_Compiler_Util.bind_opt + uu___32 + (fun a121 + -> + let uu___33 + = + unembed + e13 a13 + ncb in + FStarC_Compiler_Util.bind_opt + uu___33 + (fun a131 + -> + let uu___34 + = + unembed + e14 a14 + ncb in + FStarC_Compiler_Util.bind_opt + uu___34 + (fun a141 + -> + let uu___35 + = + unembed + e15 a15 + ncb in + FStarC_Compiler_Util.bind_opt + uu___35 + (fun a151 + -> + let uu___36 + = + unembed + e16 a16 + ncb in + FStarC_Compiler_Util.bind_opt + uu___36 + (fun a161 + -> + let uu___37 + = + unembed + e17 a17 + ncb in + FStarC_Compiler_Util.bind_opt + uu___37 + (fun a171 + -> + let uu___38 + = + unembed + e18 a18 + ncb in + FStarC_Compiler_Util.bind_opt + uu___38 + (fun a181 + -> + let uu___39 + = + unembed + e19 a19 + ncb in + FStarC_Compiler_Util.bind_opt + uu___39 + (fun a191 + -> + let uu___40 + = + unembed + e20 a20 + ncb in + FStarC_Compiler_Util.bind_opt + uu___40 + (fun a201 + -> + let uu___41 + = + unembed + FStarC_Tactics_Embedding.e_proofstate + a21 ncb in + FStarC_Compiler_Util.bind_opt + uu___41 + (fun ps + -> + let ps1 = + FStarC_Tactics_Types.set_ps_psc + psc ps in + let r1 = + interp_ctx + name + (fun + uu___42 + -> + let uu___43 + = + t a110 + a22 a31 + a41 a51 + a61 a71 + a81 a91 + a101 a111 + a121 a131 + a141 a151 + a161 a171 + a181 a191 + a201 in + FStarC_Tactics_Monad.run_safe + uu___43 + ps1) in + let uu___42 + = + let uu___43 + = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed + (FStarC_Tactics_Embedding.e_result + er) + uu___43 + r1 ncb in + FStar_Pervasives_Native.Some + uu___42))))))))))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_tactic_nbe_interpretation_1 : + 'r 't1 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> 'r FStarC_Tactics_Monad.tac) -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args -> + FStarC_TypeChecker_NBETerm.t FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun t -> + fun e1 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::[] -> + let uu___2 = FStarC_TypeChecker_NBETerm.unembed e1 cb a1 in + FStarC_Compiler_Util.bind_opt uu___2 + (fun a11 -> + let uu___3 = + FStarC_TypeChecker_NBETerm.unembed + FStarC_Tactics_Embedding.e_proofstate_nbe cb a2 in + FStarC_Compiler_Util.bind_opt uu___3 + (fun ps -> + let r1 = + interp_ctx name + (fun uu___4 -> + let uu___5 = t a11 in + FStarC_Tactics_Monad.run_safe uu___5 ps) in + let uu___4 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_Tactics_Embedding.e_result_nbe er) + cb r1 in + FStar_Pervasives_Native.Some uu___4)) + | uu___ -> FStar_Pervasives_Native.None +let mk_tactic_nbe_interpretation_2 : + 'r 't1 't2 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> 't2 -> 'r FStarC_Tactics_Monad.tac) -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun t -> + fun e1 -> + fun e2 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2)::[] -> + let uu___3 = + FStarC_TypeChecker_NBETerm.unembed e1 cb a1 in + FStarC_Compiler_Util.bind_opt uu___3 + (fun a11 -> + let uu___4 = + FStarC_TypeChecker_NBETerm.unembed e2 cb a2 in + FStarC_Compiler_Util.bind_opt uu___4 + (fun a21 -> + let uu___5 = + FStarC_TypeChecker_NBETerm.unembed + FStarC_Tactics_Embedding.e_proofstate_nbe + cb a3 in + FStarC_Compiler_Util.bind_opt uu___5 + (fun ps -> + let r1 = + interp_ctx name + (fun uu___6 -> + let uu___7 = t a11 a21 in + FStarC_Tactics_Monad.run_safe + uu___7 ps) in + let uu___6 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_Tactics_Embedding.e_result_nbe + er) cb r1 in + FStar_Pervasives_Native.Some uu___6))) + | uu___ -> FStar_Pervasives_Native.None +let mk_tactic_nbe_interpretation_3 : + 'r 't1 't2 't3 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> 't2 -> 't3 -> 'r FStarC_Tactics_Monad.tac) -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2)::(a4, uu___3)::[] + -> + let uu___4 = + FStarC_TypeChecker_NBETerm.unembed e1 cb a1 in + FStarC_Compiler_Util.bind_opt uu___4 + (fun a11 -> + let uu___5 = + FStarC_TypeChecker_NBETerm.unembed e2 cb a2 in + FStarC_Compiler_Util.bind_opt uu___5 + (fun a21 -> + let uu___6 = + FStarC_TypeChecker_NBETerm.unembed e3 cb + a3 in + FStarC_Compiler_Util.bind_opt uu___6 + (fun a31 -> + let uu___7 = + FStarC_TypeChecker_NBETerm.unembed + FStarC_Tactics_Embedding.e_proofstate_nbe + cb a4 in + FStarC_Compiler_Util.bind_opt uu___7 + (fun ps -> + let r1 = + interp_ctx name + (fun uu___8 -> + let uu___9 = t a11 a21 a31 in + FStarC_Tactics_Monad.run_safe + uu___9 ps) in + let uu___8 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_Tactics_Embedding.e_result_nbe + er) cb r1 in + FStar_Pervasives_Native.Some + uu___8)))) + | uu___ -> FStar_Pervasives_Native.None +let mk_tactic_nbe_interpretation_4 : + 'r 't1 't2 't3 't4 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> 't2 -> 't3 -> 't4 -> 'r FStarC_Tactics_Monad.tac) -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2)::(a4, uu___3):: + (a5, uu___4)::[] -> + let uu___5 = + FStarC_TypeChecker_NBETerm.unembed e1 cb a1 in + FStarC_Compiler_Util.bind_opt uu___5 + (fun a11 -> + let uu___6 = + FStarC_TypeChecker_NBETerm.unembed e2 cb a2 in + FStarC_Compiler_Util.bind_opt uu___6 + (fun a21 -> + let uu___7 = + FStarC_TypeChecker_NBETerm.unembed e3 + cb a3 in + FStarC_Compiler_Util.bind_opt uu___7 + (fun a31 -> + let uu___8 = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt uu___8 + (fun a41 -> + let uu___9 = + FStarC_TypeChecker_NBETerm.unembed + FStarC_Tactics_Embedding.e_proofstate_nbe + cb a5 in + FStarC_Compiler_Util.bind_opt + uu___9 + (fun ps -> + let r1 = + interp_ctx name + (fun uu___10 -> + let uu___11 = + t a11 a21 a31 a41 in + FStarC_Tactics_Monad.run_safe + uu___11 ps) in + let uu___10 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_Tactics_Embedding.e_result_nbe + er) cb r1 in + FStar_Pervasives_Native.Some + uu___10))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_tactic_nbe_interpretation_5 : + 'r 't1 't2 't3 't4 't5 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> 't2 -> 't3 -> 't4 -> 't5 -> 'r FStarC_Tactics_Monad.tac) -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2)::(a4, + uu___3):: + (a5, uu___4)::(a6, uu___5)::[] -> + let uu___6 = + FStarC_TypeChecker_NBETerm.unembed e1 cb a1 in + FStarC_Compiler_Util.bind_opt uu___6 + (fun a11 -> + let uu___7 = + FStarC_TypeChecker_NBETerm.unembed e2 cb + a2 in + FStarC_Compiler_Util.bind_opt uu___7 + (fun a21 -> + let uu___8 = + FStarC_TypeChecker_NBETerm.unembed e3 + cb a3 in + FStarC_Compiler_Util.bind_opt uu___8 + (fun a31 -> + let uu___9 = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___9 + (fun a41 -> + let uu___10 = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___10 + (fun a51 -> + let uu___11 = + FStarC_TypeChecker_NBETerm.unembed + FStarC_Tactics_Embedding.e_proofstate_nbe + cb a6 in + FStarC_Compiler_Util.bind_opt + uu___11 + (fun ps -> + let r1 = + interp_ctx name + (fun uu___12 -> + let uu___13 + = + t a11 a21 + a31 a41 + a51 in + FStarC_Tactics_Monad.run_safe + uu___13 ps) in + let uu___12 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_Tactics_Embedding.e_result_nbe + er) cb r1 in + FStar_Pervasives_Native.Some + uu___12)))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_tactic_nbe_interpretation_6 : + 'r 't1 't2 't3 't4 't5 't6 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> + 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 'r FStarC_Tactics_Monad.tac) + -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 't6 FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: + (a4, uu___3)::(a5, uu___4)::(a6, uu___5):: + (a7, uu___6)::[] -> + let uu___7 = + FStarC_TypeChecker_NBETerm.unembed e1 cb a1 in + FStarC_Compiler_Util.bind_opt uu___7 + (fun a11 -> + let uu___8 = + FStarC_TypeChecker_NBETerm.unembed e2 cb + a2 in + FStarC_Compiler_Util.bind_opt uu___8 + (fun a21 -> + let uu___9 = + FStarC_TypeChecker_NBETerm.unembed + e3 cb a3 in + FStarC_Compiler_Util.bind_opt uu___9 + (fun a31 -> + let uu___10 = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___10 + (fun a41 -> + let uu___11 = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___11 + (fun a51 -> + let uu___12 = + FStarC_TypeChecker_NBETerm.unembed + e6 cb a6 in + FStarC_Compiler_Util.bind_opt + uu___12 + (fun a61 -> + let uu___13 = + FStarC_TypeChecker_NBETerm.unembed + FStarC_Tactics_Embedding.e_proofstate_nbe + cb a7 in + FStarC_Compiler_Util.bind_opt + uu___13 + (fun ps -> + let r1 = + interp_ctx + name + (fun + uu___14 + -> + let uu___15 + = + t a11 a21 + a31 a41 + a51 a61 in + FStarC_Tactics_Monad.run_safe + uu___15 + ps) in + let uu___14 + = + FStarC_TypeChecker_NBETerm.embed + (FStarC_Tactics_Embedding.e_result_nbe + er) cb r1 in + FStar_Pervasives_Native.Some + uu___14))))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_tactic_nbe_interpretation_7 : + 'r 't1 't2 't3 't4 't5 't6 't7 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> + 't2 -> + 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 'r FStarC_Tactics_Monad.tac) + -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 't6 FStarC_TypeChecker_NBETerm.embedding -> + 't7 FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: + (a4, uu___3)::(a5, uu___4)::(a6, uu___5):: + (a7, uu___6)::(a8, uu___7)::[] -> + let uu___8 = + FStarC_TypeChecker_NBETerm.unembed e1 cb a1 in + FStarC_Compiler_Util.bind_opt uu___8 + (fun a11 -> + let uu___9 = + FStarC_TypeChecker_NBETerm.unembed e2 + cb a2 in + FStarC_Compiler_Util.bind_opt uu___9 + (fun a21 -> + let uu___10 = + FStarC_TypeChecker_NBETerm.unembed + e3 cb a3 in + FStarC_Compiler_Util.bind_opt + uu___10 + (fun a31 -> + let uu___11 = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___11 + (fun a41 -> + let uu___12 = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___12 + (fun a51 -> + let uu___13 = + FStarC_TypeChecker_NBETerm.unembed + e6 cb a6 in + FStarC_Compiler_Util.bind_opt + uu___13 + (fun a61 -> + let uu___14 = + FStarC_TypeChecker_NBETerm.unembed + e7 cb a7 in + FStarC_Compiler_Util.bind_opt + uu___14 + (fun a71 -> + let uu___15 + = + FStarC_TypeChecker_NBETerm.unembed + FStarC_Tactics_Embedding.e_proofstate_nbe + cb a8 in + FStarC_Compiler_Util.bind_opt + uu___15 + (fun ps + -> + let r1 = + interp_ctx + name + (fun + uu___16 + -> + let uu___17 + = + t a11 a21 + a31 a41 + a51 a61 + a71 in + FStarC_Tactics_Monad.run_safe + uu___17 + ps) in + let uu___16 + = + FStarC_TypeChecker_NBETerm.embed + (FStarC_Tactics_Embedding.e_result_nbe + er) cb r1 in + FStar_Pervasives_Native.Some + uu___16)))))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_tactic_nbe_interpretation_8 : + 'r 't1 't2 't3 't4 't5 't6 't7 't8 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 'r FStarC_Tactics_Monad.tac) + -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 't6 FStarC_TypeChecker_NBETerm.embedding -> + 't7 FStarC_TypeChecker_NBETerm.embedding -> + 't8 FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: + (a4, uu___3)::(a5, uu___4)::(a6, uu___5):: + (a7, uu___6)::(a8, uu___7)::(a9, uu___8)::[] + -> + let uu___9 = + FStarC_TypeChecker_NBETerm.unembed e1 cb + a1 in + FStarC_Compiler_Util.bind_opt uu___9 + (fun a11 -> + let uu___10 = + FStarC_TypeChecker_NBETerm.unembed + e2 cb a2 in + FStarC_Compiler_Util.bind_opt uu___10 + (fun a21 -> + let uu___11 = + FStarC_TypeChecker_NBETerm.unembed + e3 cb a3 in + FStarC_Compiler_Util.bind_opt + uu___11 + (fun a31 -> + let uu___12 = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___12 + (fun a41 -> + let uu___13 = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___13 + (fun a51 -> + let uu___14 = + FStarC_TypeChecker_NBETerm.unembed + e6 cb a6 in + FStarC_Compiler_Util.bind_opt + uu___14 + (fun a61 -> + let uu___15 = + FStarC_TypeChecker_NBETerm.unembed + e7 cb a7 in + FStarC_Compiler_Util.bind_opt + uu___15 + (fun a71 -> + let uu___16 + = + FStarC_TypeChecker_NBETerm.unembed + e8 cb a8 in + FStarC_Compiler_Util.bind_opt + uu___16 + (fun a81 + -> + let uu___17 + = + FStarC_TypeChecker_NBETerm.unembed + FStarC_Tactics_Embedding.e_proofstate_nbe + cb a9 in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun ps + -> + let r1 = + interp_ctx + name + (fun + uu___18 + -> + let uu___19 + = + t a11 a21 + a31 a41 + a51 a61 + a71 a81 in + FStarC_Tactics_Monad.run_safe + uu___19 + ps) in + let uu___18 + = + FStarC_TypeChecker_NBETerm.embed + (FStarC_Tactics_Embedding.e_result_nbe + er) cb r1 in + FStar_Pervasives_Native.Some + uu___18))))))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_tactic_nbe_interpretation_9 : + 'r 't1 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> 't7 -> 't8 -> 't9 -> 'r FStarC_Tactics_Monad.tac) + -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 't6 FStarC_TypeChecker_NBETerm.embedding -> + 't7 FStarC_TypeChecker_NBETerm.embedding -> + 't8 FStarC_TypeChecker_NBETerm.embedding -> + 't9 FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: + (a4, uu___3)::(a5, uu___4)::(a6, uu___5):: + (a7, uu___6)::(a8, uu___7)::(a9, uu___8):: + (a10, uu___9)::[] -> + let uu___10 = + FStarC_TypeChecker_NBETerm.unembed e1 + cb a1 in + FStarC_Compiler_Util.bind_opt uu___10 + (fun a11 -> + let uu___11 = + FStarC_TypeChecker_NBETerm.unembed + e2 cb a2 in + FStarC_Compiler_Util.bind_opt + uu___11 + (fun a21 -> + let uu___12 = + FStarC_TypeChecker_NBETerm.unembed + e3 cb a3 in + FStarC_Compiler_Util.bind_opt + uu___12 + (fun a31 -> + let uu___13 = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___13 + (fun a41 -> + let uu___14 = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___14 + (fun a51 -> + let uu___15 = + FStarC_TypeChecker_NBETerm.unembed + e6 cb a6 in + FStarC_Compiler_Util.bind_opt + uu___15 + (fun a61 -> + let uu___16 + = + FStarC_TypeChecker_NBETerm.unembed + e7 cb a7 in + FStarC_Compiler_Util.bind_opt + uu___16 + ( + fun a71 + -> + let uu___17 + = + FStarC_TypeChecker_NBETerm.unembed + e8 cb a8 in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a81 + -> + let uu___18 + = + FStarC_TypeChecker_NBETerm.unembed + e9 cb a9 in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a91 + -> + let uu___19 + = + FStarC_TypeChecker_NBETerm.unembed + FStarC_Tactics_Embedding.e_proofstate_nbe + cb a10 in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun ps + -> + let r1 = + interp_ctx + name + (fun + uu___20 + -> + let uu___21 + = + t a11 a21 + a31 a41 + a51 a61 + a71 a81 + a91 in + FStarC_Tactics_Monad.run_safe + uu___21 + ps) in + let uu___20 + = + FStarC_TypeChecker_NBETerm.embed + (FStarC_Tactics_Embedding.e_result_nbe + er) cb r1 in + FStar_Pervasives_Native.Some + uu___20)))))))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_tactic_nbe_interpretation_10 : + 'r 't1 't10 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> 't8 -> 't9 -> 't10 -> 'r FStarC_Tactics_Monad.tac) + -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 't6 FStarC_TypeChecker_NBETerm.embedding -> + 't7 FStarC_TypeChecker_NBETerm.embedding -> + 't8 FStarC_TypeChecker_NBETerm.embedding -> + 't9 FStarC_TypeChecker_NBETerm.embedding -> + 't10 FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: + (a4, uu___3)::(a5, uu___4)::(a6, + uu___5):: + (a7, uu___6)::(a8, uu___7)::(a9, + uu___8):: + (a10, uu___9)::(a11, uu___10)::[] -> + let uu___11 = + FStarC_TypeChecker_NBETerm.unembed e1 + cb a1 in + FStarC_Compiler_Util.bind_opt uu___11 + (fun a12 -> + let uu___12 = + FStarC_TypeChecker_NBETerm.unembed + e2 cb a2 in + FStarC_Compiler_Util.bind_opt + uu___12 + (fun a21 -> + let uu___13 = + FStarC_TypeChecker_NBETerm.unembed + e3 cb a3 in + FStarC_Compiler_Util.bind_opt + uu___13 + (fun a31 -> + let uu___14 = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___14 + (fun a41 -> + let uu___15 = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___15 + (fun a51 -> + let uu___16 = + FStarC_TypeChecker_NBETerm.unembed + e6 cb a6 in + FStarC_Compiler_Util.bind_opt + uu___16 + (fun a61 -> + let uu___17 + = + FStarC_TypeChecker_NBETerm.unembed + e7 cb a7 in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a71 + -> + let uu___18 + = + FStarC_TypeChecker_NBETerm.unembed + e8 cb a8 in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a81 + -> + let uu___19 + = + FStarC_TypeChecker_NBETerm.unembed + e9 cb a9 in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a91 + -> + let uu___20 + = + FStarC_TypeChecker_NBETerm.unembed + e10 cb + a10 in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a101 + -> + let uu___21 + = + FStarC_TypeChecker_NBETerm.unembed + FStarC_Tactics_Embedding.e_proofstate_nbe + cb a11 in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun ps + -> + let r1 = + interp_ctx + name + (fun + uu___22 + -> + let uu___23 + = + t a12 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 in + FStarC_Tactics_Monad.run_safe + uu___23 + ps) in + let uu___22 + = + FStarC_TypeChecker_NBETerm.embed + (FStarC_Tactics_Embedding.e_result_nbe + er) cb r1 in + FStar_Pervasives_Native.Some + uu___22))))))))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_tactic_nbe_interpretation_11 : + 'r 't1 't10 't11 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> 't10 -> 't11 -> 'r FStarC_Tactics_Monad.tac) + -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 't6 FStarC_TypeChecker_NBETerm.embedding -> + 't7 FStarC_TypeChecker_NBETerm.embedding -> + 't8 FStarC_TypeChecker_NBETerm.embedding -> + 't9 FStarC_TypeChecker_NBETerm.embedding -> + 't10 FStarC_TypeChecker_NBETerm.embedding -> + 't11 FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: + (a4, uu___3)::(a5, uu___4)::(a6, + uu___5):: + (a7, uu___6)::(a8, uu___7)::(a9, + uu___8):: + (a10, uu___9)::(a11, uu___10):: + (a12, uu___11)::[] -> + let uu___12 = + FStarC_TypeChecker_NBETerm.unembed + e1 cb a1 in + FStarC_Compiler_Util.bind_opt uu___12 + (fun a13 -> + let uu___13 = + FStarC_TypeChecker_NBETerm.unembed + e2 cb a2 in + FStarC_Compiler_Util.bind_opt + uu___13 + (fun a21 -> + let uu___14 = + FStarC_TypeChecker_NBETerm.unembed + e3 cb a3 in + FStarC_Compiler_Util.bind_opt + uu___14 + (fun a31 -> + let uu___15 = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___15 + (fun a41 -> + let uu___16 = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___16 + (fun a51 -> + let uu___17 + = + FStarC_TypeChecker_NBETerm.unembed + e6 cb a6 in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a61 + -> + let uu___18 + = + FStarC_TypeChecker_NBETerm.unembed + e7 cb a7 in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a71 + -> + let uu___19 + = + FStarC_TypeChecker_NBETerm.unembed + e8 cb a8 in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a81 + -> + let uu___20 + = + FStarC_TypeChecker_NBETerm.unembed + e9 cb a9 in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a91 + -> + let uu___21 + = + FStarC_TypeChecker_NBETerm.unembed + e10 cb + a10 in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a101 + -> + let uu___22 + = + FStarC_TypeChecker_NBETerm.unembed + e11 cb + a11 in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a111 + -> + let uu___23 + = + FStarC_TypeChecker_NBETerm.unembed + FStarC_Tactics_Embedding.e_proofstate_nbe + cb a12 in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun ps + -> + let r1 = + interp_ctx + name + (fun + uu___24 + -> + let uu___25 + = + t a13 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 + a111 in + FStarC_Tactics_Monad.run_safe + uu___25 + ps) in + let uu___24 + = + FStarC_TypeChecker_NBETerm.embed + (FStarC_Tactics_Embedding.e_result_nbe + er) cb r1 in + FStar_Pervasives_Native.Some + uu___24)))))))))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_tactic_nbe_interpretation_12 : + 'r 't1 't10 't11 't12 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> + 't10 -> + 't11 -> 't12 -> 'r FStarC_Tactics_Monad.tac) + -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 't6 FStarC_TypeChecker_NBETerm.embedding -> + 't7 FStarC_TypeChecker_NBETerm.embedding -> + 't8 FStarC_TypeChecker_NBETerm.embedding -> + 't9 FStarC_TypeChecker_NBETerm.embedding -> + 't10 FStarC_TypeChecker_NBETerm.embedding -> + 't11 FStarC_TypeChecker_NBETerm.embedding -> + 't12 FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, + uu___2):: + (a4, uu___3)::(a5, uu___4):: + (a6, uu___5)::(a7, uu___6):: + (a8, uu___7)::(a9, uu___8):: + (a10, uu___9)::(a11, uu___10):: + (a12, uu___11)::(a13, uu___12)::[] + -> + let uu___13 = + FStarC_TypeChecker_NBETerm.unembed + e1 cb a1 in + FStarC_Compiler_Util.bind_opt + uu___13 + (fun a14 -> + let uu___14 = + FStarC_TypeChecker_NBETerm.unembed + e2 cb a2 in + FStarC_Compiler_Util.bind_opt + uu___14 + (fun a21 -> + let uu___15 = + FStarC_TypeChecker_NBETerm.unembed + e3 cb a3 in + FStarC_Compiler_Util.bind_opt + uu___15 + (fun a31 -> + let uu___16 = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___16 + (fun a41 -> + let uu___17 = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a51 -> + let uu___18 + = + FStarC_TypeChecker_NBETerm.unembed + e6 cb a6 in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a61 + -> + let uu___19 + = + FStarC_TypeChecker_NBETerm.unembed + e7 cb a7 in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a71 + -> + let uu___20 + = + FStarC_TypeChecker_NBETerm.unembed + e8 cb a8 in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a81 + -> + let uu___21 + = + FStarC_TypeChecker_NBETerm.unembed + e9 cb a9 in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a91 + -> + let uu___22 + = + FStarC_TypeChecker_NBETerm.unembed + e10 cb + a10 in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a101 + -> + let uu___23 + = + FStarC_TypeChecker_NBETerm.unembed + e11 cb + a11 in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a111 + -> + let uu___24 + = + FStarC_TypeChecker_NBETerm.unembed + e12 cb + a12 in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a121 + -> + let uu___25 + = + FStarC_TypeChecker_NBETerm.unembed + FStarC_Tactics_Embedding.e_proofstate_nbe + cb a13 in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun ps + -> + let r1 = + interp_ctx + name + (fun + uu___26 + -> + let uu___27 + = + t a14 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 + a111 a121 in + FStarC_Tactics_Monad.run_safe + uu___27 + ps) in + let uu___26 + = + FStarC_TypeChecker_NBETerm.embed + (FStarC_Tactics_Embedding.e_result_nbe + er) cb r1 in + FStar_Pervasives_Native.Some + uu___26))))))))))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_tactic_nbe_interpretation_13 : + 'r 't1 't10 't11 't12 't13 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> + 't10 -> + 't11 -> + 't12 -> 't13 -> 'r FStarC_Tactics_Monad.tac) + -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 't6 FStarC_TypeChecker_NBETerm.embedding -> + 't7 FStarC_TypeChecker_NBETerm.embedding -> + 't8 FStarC_TypeChecker_NBETerm.embedding -> + 't9 FStarC_TypeChecker_NBETerm.embedding -> + 't10 FStarC_TypeChecker_NBETerm.embedding -> + 't11 FStarC_TypeChecker_NBETerm.embedding -> + 't12 FStarC_TypeChecker_NBETerm.embedding -> + 't13 FStarC_TypeChecker_NBETerm.embedding + -> + 'r FStarC_TypeChecker_NBETerm.embedding + -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1):: + (a3, uu___2)::(a4, uu___3):: + (a5, uu___4)::(a6, uu___5):: + (a7, uu___6)::(a8, uu___7):: + (a9, uu___8)::(a10, uu___9):: + (a11, uu___10)::(a12, uu___11):: + (a13, uu___12)::(a14, uu___13)::[] + -> + let uu___14 = + FStarC_TypeChecker_NBETerm.unembed + e1 cb a1 in + FStarC_Compiler_Util.bind_opt + uu___14 + (fun a15 -> + let uu___15 = + FStarC_TypeChecker_NBETerm.unembed + e2 cb a2 in + FStarC_Compiler_Util.bind_opt + uu___15 + (fun a21 -> + let uu___16 = + FStarC_TypeChecker_NBETerm.unembed + e3 cb a3 in + FStarC_Compiler_Util.bind_opt + uu___16 + (fun a31 -> + let uu___17 = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a41 -> + let uu___18 = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a51 -> + let uu___19 + = + FStarC_TypeChecker_NBETerm.unembed + e6 cb a6 in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a61 + -> + let uu___20 + = + FStarC_TypeChecker_NBETerm.unembed + e7 cb a7 in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a71 + -> + let uu___21 + = + FStarC_TypeChecker_NBETerm.unembed + e8 cb a8 in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a81 + -> + let uu___22 + = + FStarC_TypeChecker_NBETerm.unembed + e9 cb a9 in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a91 + -> + let uu___23 + = + FStarC_TypeChecker_NBETerm.unembed + e10 cb + a10 in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a101 + -> + let uu___24 + = + FStarC_TypeChecker_NBETerm.unembed + e11 cb + a11 in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a111 + -> + let uu___25 + = + FStarC_TypeChecker_NBETerm.unembed + e12 cb + a12 in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a121 + -> + let uu___26 + = + FStarC_TypeChecker_NBETerm.unembed + e13 cb + a13 in + FStarC_Compiler_Util.bind_opt + uu___26 + (fun a131 + -> + let uu___27 + = + FStarC_TypeChecker_NBETerm.unembed + FStarC_Tactics_Embedding.e_proofstate_nbe + cb a14 in + FStarC_Compiler_Util.bind_opt + uu___27 + (fun ps + -> + let r1 = + interp_ctx + name + (fun + uu___28 + -> + let uu___29 + = + t a15 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 + a111 a121 + a131 in + FStarC_Tactics_Monad.run_safe + uu___29 + ps) in + let uu___28 + = + FStarC_TypeChecker_NBETerm.embed + (FStarC_Tactics_Embedding.e_result_nbe + er) cb r1 in + FStar_Pervasives_Native.Some + uu___28)))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_tactic_nbe_interpretation_14 : + 'r 't1 't10 't11 't12 't13 't14 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> + 't10 -> + 't11 -> + 't12 -> + 't13 -> 't14 -> 'r FStarC_Tactics_Monad.tac) + -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 't6 FStarC_TypeChecker_NBETerm.embedding -> + 't7 FStarC_TypeChecker_NBETerm.embedding -> + 't8 FStarC_TypeChecker_NBETerm.embedding -> + 't9 FStarC_TypeChecker_NBETerm.embedding -> + 't10 FStarC_TypeChecker_NBETerm.embedding -> + 't11 FStarC_TypeChecker_NBETerm.embedding -> + 't12 FStarC_TypeChecker_NBETerm.embedding -> + 't13 FStarC_TypeChecker_NBETerm.embedding + -> + 't14 FStarC_TypeChecker_NBETerm.embedding + -> + 'r FStarC_TypeChecker_NBETerm.embedding + -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun e14 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1):: + (a3, uu___2)::(a4, uu___3):: + (a5, uu___4)::(a6, uu___5):: + (a7, uu___6)::(a8, uu___7):: + (a9, uu___8)::(a10, uu___9):: + (a11, uu___10)::(a12, uu___11):: + (a13, uu___12)::(a14, uu___13):: + (a15, uu___14)::[] -> + let uu___15 = + FStarC_TypeChecker_NBETerm.unembed + e1 cb a1 in + FStarC_Compiler_Util.bind_opt + uu___15 + (fun a16 -> + let uu___16 = + FStarC_TypeChecker_NBETerm.unembed + e2 cb a2 in + FStarC_Compiler_Util.bind_opt + uu___16 + (fun a21 -> + let uu___17 = + FStarC_TypeChecker_NBETerm.unembed + e3 cb a3 in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a31 -> + let uu___18 = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a41 -> + let uu___19 + = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___19 + ( + fun a51 + -> + let uu___20 + = + FStarC_TypeChecker_NBETerm.unembed + e6 cb a6 in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a61 + -> + let uu___21 + = + FStarC_TypeChecker_NBETerm.unembed + e7 cb a7 in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a71 + -> + let uu___22 + = + FStarC_TypeChecker_NBETerm.unembed + e8 cb a8 in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a81 + -> + let uu___23 + = + FStarC_TypeChecker_NBETerm.unembed + e9 cb a9 in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a91 + -> + let uu___24 + = + FStarC_TypeChecker_NBETerm.unembed + e10 cb + a10 in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a101 + -> + let uu___25 + = + FStarC_TypeChecker_NBETerm.unembed + e11 cb + a11 in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a111 + -> + let uu___26 + = + FStarC_TypeChecker_NBETerm.unembed + e12 cb + a12 in + FStarC_Compiler_Util.bind_opt + uu___26 + (fun a121 + -> + let uu___27 + = + FStarC_TypeChecker_NBETerm.unembed + e13 cb + a13 in + FStarC_Compiler_Util.bind_opt + uu___27 + (fun a131 + -> + let uu___28 + = + FStarC_TypeChecker_NBETerm.unembed + e14 cb + a14 in + FStarC_Compiler_Util.bind_opt + uu___28 + (fun a141 + -> + let uu___29 + = + FStarC_TypeChecker_NBETerm.unembed + FStarC_Tactics_Embedding.e_proofstate_nbe + cb a15 in + FStarC_Compiler_Util.bind_opt + uu___29 + (fun ps + -> + let r1 = + interp_ctx + name + (fun + uu___30 + -> + let uu___31 + = + t a16 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 + a111 a121 + a131 a141 in + FStarC_Tactics_Monad.run_safe + uu___31 + ps) in + let uu___30 + = + FStarC_TypeChecker_NBETerm.embed + (FStarC_Tactics_Embedding.e_result_nbe + er) cb r1 in + FStar_Pervasives_Native.Some + uu___30))))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_tactic_nbe_interpretation_15 : + 'r 't1 't10 't11 't12 't13 't14 't15 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> + 't10 -> + 't11 -> + 't12 -> + 't13 -> + 't14 -> + 't15 -> 'r FStarC_Tactics_Monad.tac) + -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 't6 FStarC_TypeChecker_NBETerm.embedding -> + 't7 FStarC_TypeChecker_NBETerm.embedding -> + 't8 FStarC_TypeChecker_NBETerm.embedding -> + 't9 FStarC_TypeChecker_NBETerm.embedding -> + 't10 FStarC_TypeChecker_NBETerm.embedding -> + 't11 FStarC_TypeChecker_NBETerm.embedding -> + 't12 FStarC_TypeChecker_NBETerm.embedding -> + 't13 FStarC_TypeChecker_NBETerm.embedding + -> + 't14 FStarC_TypeChecker_NBETerm.embedding + -> + 't15 + FStarC_TypeChecker_NBETerm.embedding + -> + 'r + FStarC_TypeChecker_NBETerm.embedding + -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args + -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun e14 -> + fun e15 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1):: + (a3, uu___2)::(a4, uu___3):: + (a5, uu___4)::(a6, uu___5):: + (a7, uu___6)::(a8, uu___7):: + (a9, uu___8)::(a10, uu___9):: + (a11, uu___10)::(a12, + uu___11):: + (a13, uu___12)::(a14, + uu___13):: + (a15, uu___14)::(a16, + uu___15)::[] + -> + let uu___16 = + FStarC_TypeChecker_NBETerm.unembed + e1 cb a1 in + FStarC_Compiler_Util.bind_opt + uu___16 + (fun a17 -> + let uu___17 = + FStarC_TypeChecker_NBETerm.unembed + e2 cb a2 in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a21 -> + let uu___18 = + FStarC_TypeChecker_NBETerm.unembed + e3 cb a3 in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a31 -> + let uu___19 = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a41 -> + let uu___20 + = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a51 + -> + let uu___21 + = + FStarC_TypeChecker_NBETerm.unembed + e6 cb a6 in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a61 + -> + let uu___22 + = + FStarC_TypeChecker_NBETerm.unembed + e7 cb a7 in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a71 + -> + let uu___23 + = + FStarC_TypeChecker_NBETerm.unembed + e8 cb a8 in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a81 + -> + let uu___24 + = + FStarC_TypeChecker_NBETerm.unembed + e9 cb a9 in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a91 + -> + let uu___25 + = + FStarC_TypeChecker_NBETerm.unembed + e10 cb + a10 in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a101 + -> + let uu___26 + = + FStarC_TypeChecker_NBETerm.unembed + e11 cb + a11 in + FStarC_Compiler_Util.bind_opt + uu___26 + (fun a111 + -> + let uu___27 + = + FStarC_TypeChecker_NBETerm.unembed + e12 cb + a12 in + FStarC_Compiler_Util.bind_opt + uu___27 + (fun a121 + -> + let uu___28 + = + FStarC_TypeChecker_NBETerm.unembed + e13 cb + a13 in + FStarC_Compiler_Util.bind_opt + uu___28 + (fun a131 + -> + let uu___29 + = + FStarC_TypeChecker_NBETerm.unembed + e14 cb + a14 in + FStarC_Compiler_Util.bind_opt + uu___29 + (fun a141 + -> + let uu___30 + = + FStarC_TypeChecker_NBETerm.unembed + e15 cb + a15 in + FStarC_Compiler_Util.bind_opt + uu___30 + (fun a151 + -> + let uu___31 + = + FStarC_TypeChecker_NBETerm.unembed + FStarC_Tactics_Embedding.e_proofstate_nbe + cb a16 in + FStarC_Compiler_Util.bind_opt + uu___31 + (fun ps + -> + let r1 = + interp_ctx + name + (fun + uu___32 + -> + let uu___33 + = + t a17 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 + a111 a121 + a131 a141 + a151 in + FStarC_Tactics_Monad.run_safe + uu___33 + ps) in + let uu___32 + = + FStarC_TypeChecker_NBETerm.embed + (FStarC_Tactics_Embedding.e_result_nbe + er) cb r1 in + FStar_Pervasives_Native.Some + uu___32)))))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_tactic_nbe_interpretation_16 : + 'r 't1 't10 't11 't12 't13 't14 't15 't16 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> + 't10 -> + 't11 -> + 't12 -> + 't13 -> + 't14 -> + 't15 -> + 't16 -> 'r FStarC_Tactics_Monad.tac) + -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 't6 FStarC_TypeChecker_NBETerm.embedding -> + 't7 FStarC_TypeChecker_NBETerm.embedding -> + 't8 FStarC_TypeChecker_NBETerm.embedding -> + 't9 FStarC_TypeChecker_NBETerm.embedding -> + 't10 FStarC_TypeChecker_NBETerm.embedding -> + 't11 FStarC_TypeChecker_NBETerm.embedding -> + 't12 FStarC_TypeChecker_NBETerm.embedding -> + 't13 FStarC_TypeChecker_NBETerm.embedding + -> + 't14 FStarC_TypeChecker_NBETerm.embedding + -> + 't15 + FStarC_TypeChecker_NBETerm.embedding + -> + 't16 + FStarC_TypeChecker_NBETerm.embedding + -> + 'r + FStarC_TypeChecker_NBETerm.embedding + -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args + -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun e14 -> + fun e15 -> + fun e16 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1):: + (a3, uu___2)::(a4, uu___3):: + (a5, uu___4)::(a6, uu___5):: + (a7, uu___6)::(a8, uu___7):: + (a9, uu___8)::(a10, uu___9):: + (a11, uu___10)::(a12, + uu___11):: + (a13, uu___12)::(a14, + uu___13):: + (a15, uu___14)::(a16, + uu___15):: + (a17, uu___16)::[] -> + let uu___17 = + FStarC_TypeChecker_NBETerm.unembed + e1 cb a1 in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a18 -> + let uu___18 = + FStarC_TypeChecker_NBETerm.unembed + e2 cb a2 in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a21 -> + let uu___19 = + FStarC_TypeChecker_NBETerm.unembed + e3 cb a3 in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a31 -> + let uu___20 + = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a41 + -> + let uu___21 + = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a51 + -> + let uu___22 + = + FStarC_TypeChecker_NBETerm.unembed + e6 cb a6 in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a61 + -> + let uu___23 + = + FStarC_TypeChecker_NBETerm.unembed + e7 cb a7 in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a71 + -> + let uu___24 + = + FStarC_TypeChecker_NBETerm.unembed + e8 cb a8 in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a81 + -> + let uu___25 + = + FStarC_TypeChecker_NBETerm.unembed + e9 cb a9 in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a91 + -> + let uu___26 + = + FStarC_TypeChecker_NBETerm.unembed + e10 cb + a10 in + FStarC_Compiler_Util.bind_opt + uu___26 + (fun a101 + -> + let uu___27 + = + FStarC_TypeChecker_NBETerm.unembed + e11 cb + a11 in + FStarC_Compiler_Util.bind_opt + uu___27 + (fun a111 + -> + let uu___28 + = + FStarC_TypeChecker_NBETerm.unembed + e12 cb + a12 in + FStarC_Compiler_Util.bind_opt + uu___28 + (fun a121 + -> + let uu___29 + = + FStarC_TypeChecker_NBETerm.unembed + e13 cb + a13 in + FStarC_Compiler_Util.bind_opt + uu___29 + (fun a131 + -> + let uu___30 + = + FStarC_TypeChecker_NBETerm.unembed + e14 cb + a14 in + FStarC_Compiler_Util.bind_opt + uu___30 + (fun a141 + -> + let uu___31 + = + FStarC_TypeChecker_NBETerm.unembed + e15 cb + a15 in + FStarC_Compiler_Util.bind_opt + uu___31 + (fun a151 + -> + let uu___32 + = + FStarC_TypeChecker_NBETerm.unembed + e16 cb + a16 in + FStarC_Compiler_Util.bind_opt + uu___32 + (fun a161 + -> + let uu___33 + = + FStarC_TypeChecker_NBETerm.unembed + FStarC_Tactics_Embedding.e_proofstate_nbe + cb a17 in + FStarC_Compiler_Util.bind_opt + uu___33 + (fun ps + -> + let r1 = + interp_ctx + name + (fun + uu___34 + -> + let uu___35 + = + t a18 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 + a111 a121 + a131 a141 + a151 a161 in + FStarC_Tactics_Monad.run_safe + uu___35 + ps) in + let uu___34 + = + FStarC_TypeChecker_NBETerm.embed + (FStarC_Tactics_Embedding.e_result_nbe + er) cb r1 in + FStar_Pervasives_Native.Some + uu___34))))))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_tactic_nbe_interpretation_17 : + 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't2 't3 't4 't5 't6 't7 't8 + 't9 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> + 't10 -> + 't11 -> + 't12 -> + 't13 -> + 't14 -> + 't15 -> + 't16 -> + 't17 -> 'r FStarC_Tactics_Monad.tac) + -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 't6 FStarC_TypeChecker_NBETerm.embedding -> + 't7 FStarC_TypeChecker_NBETerm.embedding -> + 't8 FStarC_TypeChecker_NBETerm.embedding -> + 't9 FStarC_TypeChecker_NBETerm.embedding -> + 't10 FStarC_TypeChecker_NBETerm.embedding -> + 't11 FStarC_TypeChecker_NBETerm.embedding -> + 't12 FStarC_TypeChecker_NBETerm.embedding -> + 't13 FStarC_TypeChecker_NBETerm.embedding + -> + 't14 FStarC_TypeChecker_NBETerm.embedding + -> + 't15 + FStarC_TypeChecker_NBETerm.embedding + -> + 't16 + FStarC_TypeChecker_NBETerm.embedding + -> + 't17 + FStarC_TypeChecker_NBETerm.embedding + -> + 'r + FStarC_TypeChecker_NBETerm.embedding + -> + FStarC_Syntax_Syntax.universes + -> + FStarC_TypeChecker_NBETerm.args + -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun e14 -> + fun e15 -> + fun e16 -> + fun e17 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1):: + (a3, uu___2)::(a4, + uu___3):: + (a5, uu___4)::(a6, + uu___5):: + (a7, uu___6)::(a8, + uu___7):: + (a9, uu___8)::(a10, + uu___9):: + (a11, uu___10)::(a12, + uu___11):: + (a13, uu___12)::(a14, + uu___13):: + (a15, uu___14)::(a16, + uu___15):: + (a17, uu___16)::(a18, + uu___17)::[] + -> + let uu___18 = + FStarC_TypeChecker_NBETerm.unembed + e1 cb a1 in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a19 -> + let uu___19 = + FStarC_TypeChecker_NBETerm.unembed + e2 cb a2 in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a21 -> + let uu___20 = + FStarC_TypeChecker_NBETerm.unembed + e3 cb a3 in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a31 -> + let uu___21 + = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a41 + -> + let uu___22 + = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a51 + -> + let uu___23 + = + FStarC_TypeChecker_NBETerm.unembed + e6 cb a6 in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a61 + -> + let uu___24 + = + FStarC_TypeChecker_NBETerm.unembed + e7 cb a7 in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a71 + -> + let uu___25 + = + FStarC_TypeChecker_NBETerm.unembed + e8 cb a8 in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a81 + -> + let uu___26 + = + FStarC_TypeChecker_NBETerm.unembed + e9 cb a9 in + FStarC_Compiler_Util.bind_opt + uu___26 + (fun a91 + -> + let uu___27 + = + FStarC_TypeChecker_NBETerm.unembed + e10 cb + a10 in + FStarC_Compiler_Util.bind_opt + uu___27 + (fun a101 + -> + let uu___28 + = + FStarC_TypeChecker_NBETerm.unembed + e11 cb + a11 in + FStarC_Compiler_Util.bind_opt + uu___28 + (fun a111 + -> + let uu___29 + = + FStarC_TypeChecker_NBETerm.unembed + e12 cb + a12 in + FStarC_Compiler_Util.bind_opt + uu___29 + (fun a121 + -> + let uu___30 + = + FStarC_TypeChecker_NBETerm.unembed + e13 cb + a13 in + FStarC_Compiler_Util.bind_opt + uu___30 + (fun a131 + -> + let uu___31 + = + FStarC_TypeChecker_NBETerm.unembed + e14 cb + a14 in + FStarC_Compiler_Util.bind_opt + uu___31 + (fun a141 + -> + let uu___32 + = + FStarC_TypeChecker_NBETerm.unembed + e15 cb + a15 in + FStarC_Compiler_Util.bind_opt + uu___32 + (fun a151 + -> + let uu___33 + = + FStarC_TypeChecker_NBETerm.unembed + e16 cb + a16 in + FStarC_Compiler_Util.bind_opt + uu___33 + (fun a161 + -> + let uu___34 + = + FStarC_TypeChecker_NBETerm.unembed + e17 cb + a17 in + FStarC_Compiler_Util.bind_opt + uu___34 + (fun a171 + -> + let uu___35 + = + FStarC_TypeChecker_NBETerm.unembed + FStarC_Tactics_Embedding.e_proofstate_nbe + cb a18 in + FStarC_Compiler_Util.bind_opt + uu___35 + (fun ps + -> + let r1 = + interp_ctx + name + (fun + uu___36 + -> + let uu___37 + = + t a19 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 + a111 a121 + a131 a141 + a151 a161 + a171 in + FStarC_Tactics_Monad.run_safe + uu___37 + ps) in + let uu___36 + = + FStarC_TypeChecker_NBETerm.embed + (FStarC_Tactics_Embedding.e_result_nbe + er) cb r1 in + FStar_Pervasives_Native.Some + uu___36)))))))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_tactic_nbe_interpretation_18 : + 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't18 't2 't3 't4 't5 't6 't7 + 't8 't9 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> + 't10 -> + 't11 -> + 't12 -> + 't13 -> + 't14 -> + 't15 -> + 't16 -> + 't17 -> + 't18 -> + 'r FStarC_Tactics_Monad.tac) + -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 't6 FStarC_TypeChecker_NBETerm.embedding -> + 't7 FStarC_TypeChecker_NBETerm.embedding -> + 't8 FStarC_TypeChecker_NBETerm.embedding -> + 't9 FStarC_TypeChecker_NBETerm.embedding -> + 't10 FStarC_TypeChecker_NBETerm.embedding -> + 't11 FStarC_TypeChecker_NBETerm.embedding -> + 't12 FStarC_TypeChecker_NBETerm.embedding -> + 't13 FStarC_TypeChecker_NBETerm.embedding + -> + 't14 FStarC_TypeChecker_NBETerm.embedding + -> + 't15 + FStarC_TypeChecker_NBETerm.embedding + -> + 't16 + FStarC_TypeChecker_NBETerm.embedding + -> + 't17 + FStarC_TypeChecker_NBETerm.embedding + -> + 't18 + FStarC_TypeChecker_NBETerm.embedding + -> + 'r + FStarC_TypeChecker_NBETerm.embedding + -> + FStarC_Syntax_Syntax.universes + -> + FStarC_TypeChecker_NBETerm.args + -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun e14 -> + fun e15 -> + fun e16 -> + fun e17 -> + fun e18 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1):: + (a3, uu___2)::(a4, + uu___3):: + (a5, uu___4)::(a6, + uu___5):: + (a7, uu___6)::(a8, + uu___7):: + (a9, uu___8)::(a10, + uu___9):: + (a11, uu___10):: + (a12, uu___11):: + (a13, uu___12):: + (a14, uu___13):: + (a15, uu___14):: + (a16, uu___15):: + (a17, uu___16):: + (a18, uu___17):: + (a19, uu___18)::[] -> + let uu___19 = + FStarC_TypeChecker_NBETerm.unembed + e1 cb a1 in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a110 -> + let uu___20 = + FStarC_TypeChecker_NBETerm.unembed + e2 cb a2 in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a21 -> + let uu___21 = + FStarC_TypeChecker_NBETerm.unembed + e3 cb a3 in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a31 -> + let uu___22 + = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a41 + -> + let uu___23 + = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a51 + -> + let uu___24 + = + FStarC_TypeChecker_NBETerm.unembed + e6 cb a6 in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a61 + -> + let uu___25 + = + FStarC_TypeChecker_NBETerm.unembed + e7 cb a7 in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a71 + -> + let uu___26 + = + FStarC_TypeChecker_NBETerm.unembed + e8 cb a8 in + FStarC_Compiler_Util.bind_opt + uu___26 + (fun a81 + -> + let uu___27 + = + FStarC_TypeChecker_NBETerm.unembed + e9 cb a9 in + FStarC_Compiler_Util.bind_opt + uu___27 + (fun a91 + -> + let uu___28 + = + FStarC_TypeChecker_NBETerm.unembed + e10 cb + a10 in + FStarC_Compiler_Util.bind_opt + uu___28 + (fun a101 + -> + let uu___29 + = + FStarC_TypeChecker_NBETerm.unembed + e11 cb + a11 in + FStarC_Compiler_Util.bind_opt + uu___29 + (fun a111 + -> + let uu___30 + = + FStarC_TypeChecker_NBETerm.unembed + e12 cb + a12 in + FStarC_Compiler_Util.bind_opt + uu___30 + (fun a121 + -> + let uu___31 + = + FStarC_TypeChecker_NBETerm.unembed + e13 cb + a13 in + FStarC_Compiler_Util.bind_opt + uu___31 + (fun a131 + -> + let uu___32 + = + FStarC_TypeChecker_NBETerm.unembed + e14 cb + a14 in + FStarC_Compiler_Util.bind_opt + uu___32 + (fun a141 + -> + let uu___33 + = + FStarC_TypeChecker_NBETerm.unembed + e15 cb + a15 in + FStarC_Compiler_Util.bind_opt + uu___33 + (fun a151 + -> + let uu___34 + = + FStarC_TypeChecker_NBETerm.unembed + e16 cb + a16 in + FStarC_Compiler_Util.bind_opt + uu___34 + (fun a161 + -> + let uu___35 + = + FStarC_TypeChecker_NBETerm.unembed + e17 cb + a17 in + FStarC_Compiler_Util.bind_opt + uu___35 + (fun a171 + -> + let uu___36 + = + FStarC_TypeChecker_NBETerm.unembed + e18 cb + a18 in + FStarC_Compiler_Util.bind_opt + uu___36 + (fun a181 + -> + let uu___37 + = + FStarC_TypeChecker_NBETerm.unembed + FStarC_Tactics_Embedding.e_proofstate_nbe + cb a19 in + FStarC_Compiler_Util.bind_opt + uu___37 + (fun ps + -> + let r1 = + interp_ctx + name + (fun + uu___38 + -> + let uu___39 + = + t a110 + a21 a31 + a41 a51 + a61 a71 + a81 a91 + a101 a111 + a121 a131 + a141 a151 + a161 a171 + a181 in + FStarC_Tactics_Monad.run_safe + uu___39 + ps) in + let uu___38 + = + FStarC_TypeChecker_NBETerm.embed + (FStarC_Tactics_Embedding.e_result_nbe + er) cb r1 in + FStar_Pervasives_Native.Some + uu___38))))))))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_tactic_nbe_interpretation_19 : + 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't18 't19 't2 't3 't4 't5 + 't6 't7 't8 't9 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> + 't10 -> + 't11 -> + 't12 -> + 't13 -> + 't14 -> + 't15 -> + 't16 -> + 't17 -> + 't18 -> + 't19 -> + 'r FStarC_Tactics_Monad.tac) + -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 't6 FStarC_TypeChecker_NBETerm.embedding -> + 't7 FStarC_TypeChecker_NBETerm.embedding -> + 't8 FStarC_TypeChecker_NBETerm.embedding -> + 't9 FStarC_TypeChecker_NBETerm.embedding -> + 't10 FStarC_TypeChecker_NBETerm.embedding -> + 't11 FStarC_TypeChecker_NBETerm.embedding -> + 't12 FStarC_TypeChecker_NBETerm.embedding -> + 't13 FStarC_TypeChecker_NBETerm.embedding + -> + 't14 FStarC_TypeChecker_NBETerm.embedding + -> + 't15 + FStarC_TypeChecker_NBETerm.embedding + -> + 't16 + FStarC_TypeChecker_NBETerm.embedding + -> + 't17 + FStarC_TypeChecker_NBETerm.embedding + -> + 't18 + FStarC_TypeChecker_NBETerm.embedding + -> + 't19 + FStarC_TypeChecker_NBETerm.embedding + -> + 'r + FStarC_TypeChecker_NBETerm.embedding + -> + FStarC_Syntax_Syntax.universes + -> + FStarC_TypeChecker_NBETerm.args + -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun e14 -> + fun e15 -> + fun e16 -> + fun e17 -> + fun e18 -> + fun e19 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, + uu___1):: + (a3, uu___2):: + (a4, uu___3):: + (a5, uu___4):: + (a6, uu___5):: + (a7, uu___6):: + (a8, uu___7):: + (a9, uu___8):: + (a10, uu___9):: + (a11, uu___10):: + (a12, uu___11):: + (a13, uu___12):: + (a14, uu___13):: + (a15, uu___14):: + (a16, uu___15):: + (a17, uu___16):: + (a18, uu___17):: + (a19, uu___18):: + (a20, uu___19)::[] -> + let uu___20 = + FStarC_TypeChecker_NBETerm.unembed + e1 cb a1 in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a110 -> + let uu___21 = + FStarC_TypeChecker_NBETerm.unembed + e2 cb a2 in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a21 -> + let uu___22 + = + FStarC_TypeChecker_NBETerm.unembed + e3 cb a3 in + FStarC_Compiler_Util.bind_opt + uu___22 + ( + fun a31 + -> + let uu___23 + = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a41 + -> + let uu___24 + = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a51 + -> + let uu___25 + = + FStarC_TypeChecker_NBETerm.unembed + e6 cb a6 in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a61 + -> + let uu___26 + = + FStarC_TypeChecker_NBETerm.unembed + e7 cb a7 in + FStarC_Compiler_Util.bind_opt + uu___26 + (fun a71 + -> + let uu___27 + = + FStarC_TypeChecker_NBETerm.unembed + e8 cb a8 in + FStarC_Compiler_Util.bind_opt + uu___27 + (fun a81 + -> + let uu___28 + = + FStarC_TypeChecker_NBETerm.unembed + e9 cb a9 in + FStarC_Compiler_Util.bind_opt + uu___28 + (fun a91 + -> + let uu___29 + = + FStarC_TypeChecker_NBETerm.unembed + e10 cb + a10 in + FStarC_Compiler_Util.bind_opt + uu___29 + (fun a101 + -> + let uu___30 + = + FStarC_TypeChecker_NBETerm.unembed + e11 cb + a11 in + FStarC_Compiler_Util.bind_opt + uu___30 + (fun a111 + -> + let uu___31 + = + FStarC_TypeChecker_NBETerm.unembed + e12 cb + a12 in + FStarC_Compiler_Util.bind_opt + uu___31 + (fun a121 + -> + let uu___32 + = + FStarC_TypeChecker_NBETerm.unembed + e13 cb + a13 in + FStarC_Compiler_Util.bind_opt + uu___32 + (fun a131 + -> + let uu___33 + = + FStarC_TypeChecker_NBETerm.unembed + e14 cb + a14 in + FStarC_Compiler_Util.bind_opt + uu___33 + (fun a141 + -> + let uu___34 + = + FStarC_TypeChecker_NBETerm.unembed + e15 cb + a15 in + FStarC_Compiler_Util.bind_opt + uu___34 + (fun a151 + -> + let uu___35 + = + FStarC_TypeChecker_NBETerm.unembed + e16 cb + a16 in + FStarC_Compiler_Util.bind_opt + uu___35 + (fun a161 + -> + let uu___36 + = + FStarC_TypeChecker_NBETerm.unembed + e17 cb + a17 in + FStarC_Compiler_Util.bind_opt + uu___36 + (fun a171 + -> + let uu___37 + = + FStarC_TypeChecker_NBETerm.unembed + e18 cb + a18 in + FStarC_Compiler_Util.bind_opt + uu___37 + (fun a181 + -> + let uu___38 + = + FStarC_TypeChecker_NBETerm.unembed + e19 cb + a19 in + FStarC_Compiler_Util.bind_opt + uu___38 + (fun a191 + -> + let uu___39 + = + FStarC_TypeChecker_NBETerm.unembed + FStarC_Tactics_Embedding.e_proofstate_nbe + cb a20 in + FStarC_Compiler_Util.bind_opt + uu___39 + (fun ps + -> + let r1 = + interp_ctx + name + (fun + uu___40 + -> + let uu___41 + = + t a110 + a21 a31 + a41 a51 + a61 a71 + a81 a91 + a101 a111 + a121 a131 + a141 a151 + a161 a171 + a181 a191 in + FStarC_Tactics_Monad.run_safe + uu___41 + ps) in + let uu___40 + = + FStarC_TypeChecker_NBETerm.embed + (FStarC_Tactics_Embedding.e_result_nbe + er) cb r1 in + FStar_Pervasives_Native.Some + uu___40)))))))))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_tactic_nbe_interpretation_20 : + 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't18 't19 't2 't20 't3 't4 + 't5 't6 't7 't8 't9 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> + 't10 -> + 't11 -> + 't12 -> + 't13 -> + 't14 -> + 't15 -> + 't16 -> + 't17 -> + 't18 -> + 't19 -> + 't20 -> + 'r FStarC_Tactics_Monad.tac) + -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 't6 FStarC_TypeChecker_NBETerm.embedding -> + 't7 FStarC_TypeChecker_NBETerm.embedding -> + 't8 FStarC_TypeChecker_NBETerm.embedding -> + 't9 FStarC_TypeChecker_NBETerm.embedding -> + 't10 FStarC_TypeChecker_NBETerm.embedding -> + 't11 FStarC_TypeChecker_NBETerm.embedding -> + 't12 FStarC_TypeChecker_NBETerm.embedding -> + 't13 FStarC_TypeChecker_NBETerm.embedding + -> + 't14 FStarC_TypeChecker_NBETerm.embedding + -> + 't15 + FStarC_TypeChecker_NBETerm.embedding + -> + 't16 + FStarC_TypeChecker_NBETerm.embedding + -> + 't17 + FStarC_TypeChecker_NBETerm.embedding + -> + 't18 + FStarC_TypeChecker_NBETerm.embedding + -> + 't19 + FStarC_TypeChecker_NBETerm.embedding + -> + 't20 + FStarC_TypeChecker_NBETerm.embedding + -> + 'r + FStarC_TypeChecker_NBETerm.embedding + -> + FStarC_Syntax_Syntax.universes + -> + FStarC_TypeChecker_NBETerm.args + -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun t -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun e14 -> + fun e15 -> + fun e16 -> + fun e17 -> + fun e18 -> + fun e19 -> + fun e20 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___):: + (a2, uu___1):: + (a3, uu___2):: + (a4, uu___3):: + (a5, uu___4):: + (a6, uu___5):: + (a7, uu___6):: + (a8, uu___7):: + (a9, uu___8):: + (a10, uu___9):: + (a11, uu___10):: + (a12, uu___11):: + (a13, uu___12):: + (a14, uu___13):: + (a15, uu___14):: + (a16, uu___15):: + (a17, uu___16):: + (a18, uu___17):: + (a19, uu___18):: + (a20, uu___19):: + (a21, uu___20)::[] + -> + let uu___21 = + FStarC_TypeChecker_NBETerm.unembed + e1 cb a1 in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a110 -> + let uu___22 = + FStarC_TypeChecker_NBETerm.unembed + e2 cb a2 in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a22 -> + let uu___23 + = + FStarC_TypeChecker_NBETerm.unembed + e3 cb a3 in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a31 + -> + let uu___24 + = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a41 + -> + let uu___25 + = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a51 + -> + let uu___26 + = + FStarC_TypeChecker_NBETerm.unembed + e6 cb a6 in + FStarC_Compiler_Util.bind_opt + uu___26 + (fun a61 + -> + let uu___27 + = + FStarC_TypeChecker_NBETerm.unembed + e7 cb a7 in + FStarC_Compiler_Util.bind_opt + uu___27 + (fun a71 + -> + let uu___28 + = + FStarC_TypeChecker_NBETerm.unembed + e8 cb a8 in + FStarC_Compiler_Util.bind_opt + uu___28 + (fun a81 + -> + let uu___29 + = + FStarC_TypeChecker_NBETerm.unembed + e9 cb a9 in + FStarC_Compiler_Util.bind_opt + uu___29 + (fun a91 + -> + let uu___30 + = + FStarC_TypeChecker_NBETerm.unembed + e10 cb + a10 in + FStarC_Compiler_Util.bind_opt + uu___30 + (fun a101 + -> + let uu___31 + = + FStarC_TypeChecker_NBETerm.unembed + e11 cb + a11 in + FStarC_Compiler_Util.bind_opt + uu___31 + (fun a111 + -> + let uu___32 + = + FStarC_TypeChecker_NBETerm.unembed + e12 cb + a12 in + FStarC_Compiler_Util.bind_opt + uu___32 + (fun a121 + -> + let uu___33 + = + FStarC_TypeChecker_NBETerm.unembed + e13 cb + a13 in + FStarC_Compiler_Util.bind_opt + uu___33 + (fun a131 + -> + let uu___34 + = + FStarC_TypeChecker_NBETerm.unembed + e14 cb + a14 in + FStarC_Compiler_Util.bind_opt + uu___34 + (fun a141 + -> + let uu___35 + = + FStarC_TypeChecker_NBETerm.unembed + e15 cb + a15 in + FStarC_Compiler_Util.bind_opt + uu___35 + (fun a151 + -> + let uu___36 + = + FStarC_TypeChecker_NBETerm.unembed + e16 cb + a16 in + FStarC_Compiler_Util.bind_opt + uu___36 + (fun a161 + -> + let uu___37 + = + FStarC_TypeChecker_NBETerm.unembed + e17 cb + a17 in + FStarC_Compiler_Util.bind_opt + uu___37 + (fun a171 + -> + let uu___38 + = + FStarC_TypeChecker_NBETerm.unembed + e18 cb + a18 in + FStarC_Compiler_Util.bind_opt + uu___38 + (fun a181 + -> + let uu___39 + = + FStarC_TypeChecker_NBETerm.unembed + e19 cb + a19 in + FStarC_Compiler_Util.bind_opt + uu___39 + (fun a191 + -> + let uu___40 + = + FStarC_TypeChecker_NBETerm.unembed + e20 cb + a20 in + FStarC_Compiler_Util.bind_opt + uu___40 + (fun a201 + -> + let uu___41 + = + FStarC_TypeChecker_NBETerm.unembed + FStarC_Tactics_Embedding.e_proofstate_nbe + cb a21 in + FStarC_Compiler_Util.bind_opt + uu___41 + (fun ps + -> + let r1 = + interp_ctx + name + (fun + uu___42 + -> + let uu___43 + = + t a110 + a22 a31 + a41 a51 + a61 a71 + a81 a91 + a101 a111 + a121 a131 + a141 a151 + a161 a171 + a181 a191 + a201 in + FStarC_Tactics_Monad.run_safe + uu___43 + ps) in + let uu___42 + = + FStarC_TypeChecker_NBETerm.embed + (FStarC_Tactics_Embedding.e_result_nbe + er) cb r1 in + FStar_Pervasives_Native.Some + uu___42))))))))))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_total_interpretation_1 : + 'r 't1 . + Prims.string -> + ('t1 -> 'r) -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option + = + fun name -> + fun f -> + fun e1 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::[] -> + let uu___1 = unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt uu___1 + (fun a11 -> + let r1 = interp_ctx name (fun uu___2 -> f a11) in + let uu___2 = + let uu___3 = + FStarC_TypeChecker_Primops_Base.psc_range psc in + embed er uu___3 r1 ncb in + FStar_Pervasives_Native.Some uu___2) + | uu___ -> FStar_Pervasives_Native.None +let mk_total_interpretation_2 : + 'r 't1 't2 . + Prims.string -> + ('t1 -> 't2 -> 'r) -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun f -> + fun e1 -> + fun e2 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::[] -> + let uu___2 = unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt uu___2 + (fun a11 -> + let uu___3 = unembed e2 a2 ncb in + FStarC_Compiler_Util.bind_opt uu___3 + (fun a21 -> + let r1 = + interp_ctx name (fun uu___4 -> f a11 a21) in + let uu___4 = + let uu___5 = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed er uu___5 r1 ncb in + FStar_Pervasives_Native.Some uu___4)) + | uu___ -> FStar_Pervasives_Native.None +let mk_total_interpretation_3 : + 'r 't1 't2 't3 . + Prims.string -> + ('t1 -> 't2 -> 't3 -> 'r) -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2)::[] -> + let uu___3 = unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt uu___3 + (fun a11 -> + let uu___4 = unembed e2 a2 ncb in + FStarC_Compiler_Util.bind_opt uu___4 + (fun a21 -> + let uu___5 = unembed e3 a3 ncb in + FStarC_Compiler_Util.bind_opt uu___5 + (fun a31 -> + let r1 = + interp_ctx name + (fun uu___6 -> f a11 a21 a31) in + let uu___6 = + let uu___7 = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed er uu___7 r1 ncb in + FStar_Pervasives_Native.Some uu___6))) + | uu___ -> FStar_Pervasives_Native.None +let mk_total_interpretation_4 : + 'r 't1 't2 't3 't4 . + Prims.string -> + ('t1 -> 't2 -> 't3 -> 't4 -> 'r) -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2)::(a4, + uu___3)::[] + -> + let uu___4 = unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt uu___4 + (fun a11 -> + let uu___5 = unembed e2 a2 ncb in + FStarC_Compiler_Util.bind_opt uu___5 + (fun a21 -> + let uu___6 = unembed e3 a3 ncb in + FStarC_Compiler_Util.bind_opt uu___6 + (fun a31 -> + let uu___7 = unembed e4 a4 ncb in + FStarC_Compiler_Util.bind_opt + uu___7 + (fun a41 -> + let r1 = + interp_ctx name + (fun uu___8 -> + f a11 a21 a31 a41) in + let uu___8 = + let uu___9 = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed er uu___9 r1 ncb in + FStar_Pervasives_Native.Some + uu___8)))) + | uu___ -> FStar_Pervasives_Native.None +let mk_total_interpretation_5 : + 'r 't1 't2 't3 't4 't5 . + Prims.string -> + ('t1 -> 't2 -> 't3 -> 't4 -> 't5 -> 'r) -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: + (a4, uu___3)::(a5, uu___4)::[] -> + let uu___5 = unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt uu___5 + (fun a11 -> + let uu___6 = unembed e2 a2 ncb in + FStarC_Compiler_Util.bind_opt uu___6 + (fun a21 -> + let uu___7 = unembed e3 a3 ncb in + FStarC_Compiler_Util.bind_opt uu___7 + (fun a31 -> + let uu___8 = unembed e4 a4 ncb in + FStarC_Compiler_Util.bind_opt + uu___8 + (fun a41 -> + let uu___9 = + unembed e5 a5 ncb in + FStarC_Compiler_Util.bind_opt + uu___9 + (fun a51 -> + let r1 = + interp_ctx name + (fun uu___10 -> + f a11 a21 a31 + a41 a51) in + let uu___10 = + let uu___11 = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed er uu___11 r1 + ncb in + FStar_Pervasives_Native.Some + uu___10))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_total_interpretation_6 : + 'r 't1 't2 't3 't4 't5 't6 . + Prims.string -> + ('t1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 'r) -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 't6 FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: + (a4, uu___3)::(a5, uu___4)::(a6, uu___5)::[] + -> + let uu___6 = unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt uu___6 + (fun a11 -> + let uu___7 = unembed e2 a2 ncb in + FStarC_Compiler_Util.bind_opt uu___7 + (fun a21 -> + let uu___8 = unembed e3 a3 ncb in + FStarC_Compiler_Util.bind_opt + uu___8 + (fun a31 -> + let uu___9 = unembed e4 a4 ncb in + FStarC_Compiler_Util.bind_opt + uu___9 + (fun a41 -> + let uu___10 = + unembed e5 a5 ncb in + FStarC_Compiler_Util.bind_opt + uu___10 + (fun a51 -> + let uu___11 = + unembed e6 a6 ncb in + FStarC_Compiler_Util.bind_opt + uu___11 + (fun a61 -> + let r1 = + interp_ctx + name + (fun + uu___12 + -> + f a11 a21 + a31 a41 + a51 a61) in + let uu___12 = + let uu___13 = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed er + uu___13 r1 + ncb in + FStar_Pervasives_Native.Some + uu___12)))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_total_interpretation_7 : + 'r 't1 't2 't3 't4 't5 't6 't7 . + Prims.string -> + ('t1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 'r) -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 't6 FStarC_Syntax_Embeddings_Base.embedding -> + 't7 FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: + (a4, uu___3)::(a5, uu___4)::(a6, uu___5):: + (a7, uu___6)::[] -> + let uu___7 = unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt uu___7 + (fun a11 -> + let uu___8 = unembed e2 a2 ncb in + FStarC_Compiler_Util.bind_opt uu___8 + (fun a21 -> + let uu___9 = unembed e3 a3 ncb in + FStarC_Compiler_Util.bind_opt + uu___9 + (fun a31 -> + let uu___10 = + unembed e4 a4 ncb in + FStarC_Compiler_Util.bind_opt + uu___10 + (fun a41 -> + let uu___11 = + unembed e5 a5 ncb in + FStarC_Compiler_Util.bind_opt + uu___11 + (fun a51 -> + let uu___12 = + unembed e6 a6 + ncb in + FStarC_Compiler_Util.bind_opt + uu___12 + (fun a61 -> + let uu___13 = + unembed e7 + a7 ncb in + FStarC_Compiler_Util.bind_opt + uu___13 + (fun a71 -> + let r1 = + interp_ctx + name + (fun + uu___14 + -> + f a11 a21 + a31 a41 + a51 a61 + a71) in + let uu___14 + = + let uu___15 + = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed er + uu___15 + r1 ncb in + FStar_Pervasives_Native.Some + uu___14))))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_total_interpretation_8 : + 'r 't1 't2 't3 't4 't5 't6 't7 't8 . + Prims.string -> + ('t1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 'r) -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 't6 FStarC_Syntax_Embeddings_Base.embedding -> + 't7 FStarC_Syntax_Embeddings_Base.embedding -> + 't8 FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: + (a4, uu___3)::(a5, uu___4)::(a6, uu___5):: + (a7, uu___6)::(a8, uu___7)::[] -> + let uu___8 = unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt uu___8 + (fun a11 -> + let uu___9 = unembed e2 a2 ncb in + FStarC_Compiler_Util.bind_opt uu___9 + (fun a21 -> + let uu___10 = unembed e3 a3 ncb in + FStarC_Compiler_Util.bind_opt + uu___10 + (fun a31 -> + let uu___11 = + unembed e4 a4 ncb in + FStarC_Compiler_Util.bind_opt + uu___11 + (fun a41 -> + let uu___12 = + unembed e5 a5 ncb in + FStarC_Compiler_Util.bind_opt + uu___12 + (fun a51 -> + let uu___13 = + unembed e6 a6 + ncb in + FStarC_Compiler_Util.bind_opt + uu___13 + (fun a61 -> + let uu___14 + = + unembed + e7 a7 ncb in + FStarC_Compiler_Util.bind_opt + uu___14 + ( + fun a71 + -> + let uu___15 + = + unembed + e8 a8 ncb in + FStarC_Compiler_Util.bind_opt + uu___15 + (fun a81 + -> + let r1 = + interp_ctx + name + (fun + uu___16 + -> + f a11 a21 + a31 a41 + a51 a61 + a71 a81) in + let uu___16 + = + let uu___17 + = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed er + uu___17 + r1 ncb in + FStar_Pervasives_Native.Some + uu___16)))))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_total_interpretation_9 : + 'r 't1 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + ('t1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 'r) -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 't6 FStarC_Syntax_Embeddings_Base.embedding -> + 't7 FStarC_Syntax_Embeddings_Base.embedding -> + 't8 FStarC_Syntax_Embeddings_Base.embedding -> + 't9 FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: + (a4, uu___3)::(a5, uu___4)::(a6, + uu___5):: + (a7, uu___6)::(a8, uu___7)::(a9, + uu___8)::[] + -> + let uu___9 = unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt uu___9 + (fun a11 -> + let uu___10 = unembed e2 a2 ncb in + FStarC_Compiler_Util.bind_opt + uu___10 + (fun a21 -> + let uu___11 = + unembed e3 a3 ncb in + FStarC_Compiler_Util.bind_opt + uu___11 + (fun a31 -> + let uu___12 = + unembed e4 a4 ncb in + FStarC_Compiler_Util.bind_opt + uu___12 + (fun a41 -> + let uu___13 = + unembed e5 a5 ncb in + FStarC_Compiler_Util.bind_opt + uu___13 + (fun a51 -> + let uu___14 = + unembed e6 + a6 ncb in + FStarC_Compiler_Util.bind_opt + uu___14 + (fun a61 -> + let uu___15 + = + unembed + e7 a7 ncb in + FStarC_Compiler_Util.bind_opt + uu___15 + (fun a71 + -> + let uu___16 + = + unembed + e8 a8 ncb in + FStarC_Compiler_Util.bind_opt + uu___16 + (fun a81 + -> + let uu___17 + = + unembed + e9 a9 ncb in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a91 + -> + let r1 = + interp_ctx + name + (fun + uu___18 + -> + f a11 a21 + a31 a41 + a51 a61 + a71 a81 + a91) in + let uu___18 + = + let uu___19 + = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed er + uu___19 + r1 ncb in + FStar_Pervasives_Native.Some + uu___18))))))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_total_interpretation_10 : + 'r 't1 't10 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + ('t1 -> + 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 'r) + -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 't6 FStarC_Syntax_Embeddings_Base.embedding -> + 't7 FStarC_Syntax_Embeddings_Base.embedding -> + 't8 FStarC_Syntax_Embeddings_Base.embedding -> + 't9 FStarC_Syntax_Embeddings_Base.embedding -> + 't10 FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: + (a4, uu___3)::(a5, uu___4)::(a6, + uu___5):: + (a7, uu___6)::(a8, uu___7)::(a9, + uu___8):: + (a10, uu___9)::[] -> + let uu___10 = unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt uu___10 + (fun a11 -> + let uu___11 = unembed e2 a2 ncb in + FStarC_Compiler_Util.bind_opt + uu___11 + (fun a21 -> + let uu___12 = + unembed e3 a3 ncb in + FStarC_Compiler_Util.bind_opt + uu___12 + (fun a31 -> + let uu___13 = + unembed e4 a4 ncb in + FStarC_Compiler_Util.bind_opt + uu___13 + (fun a41 -> + let uu___14 = + unembed e5 a5 + ncb in + FStarC_Compiler_Util.bind_opt + uu___14 + (fun a51 -> + let uu___15 + = + unembed e6 + a6 ncb in + FStarC_Compiler_Util.bind_opt + uu___15 + (fun a61 + -> + let uu___16 + = + unembed + e7 a7 ncb in + FStarC_Compiler_Util.bind_opt + uu___16 + (fun a71 + -> + let uu___17 + = + unembed + e8 a8 ncb in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a81 + -> + let uu___18 + = + unembed + e9 a9 ncb in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a91 + -> + let uu___19 + = + unembed + e10 a10 + ncb in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a101 + -> + let r1 = + interp_ctx + name + (fun + uu___20 + -> + f a11 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101) in + let uu___20 + = + let uu___21 + = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed er + uu___21 + r1 ncb in + FStar_Pervasives_Native.Some + uu___20)))))))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_total_interpretation_11 : + 'r 't1 't10 't11 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 'r) + -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 't6 FStarC_Syntax_Embeddings_Base.embedding -> + 't7 FStarC_Syntax_Embeddings_Base.embedding -> + 't8 FStarC_Syntax_Embeddings_Base.embedding -> + 't9 FStarC_Syntax_Embeddings_Base.embedding -> + 't10 FStarC_Syntax_Embeddings_Base.embedding -> + 't11 FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, + uu___2):: + (a4, uu___3)::(a5, uu___4):: + (a6, uu___5)::(a7, uu___6):: + (a8, uu___7)::(a9, uu___8):: + (a10, uu___9)::(a11, uu___10)::[] + -> + let uu___11 = unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt + uu___11 + (fun a12 -> + let uu___12 = + unembed e2 a2 ncb in + FStarC_Compiler_Util.bind_opt + uu___12 + (fun a21 -> + let uu___13 = + unembed e3 a3 ncb in + FStarC_Compiler_Util.bind_opt + uu___13 + (fun a31 -> + let uu___14 = + unembed e4 a4 ncb in + FStarC_Compiler_Util.bind_opt + uu___14 + (fun a41 -> + let uu___15 = + unembed e5 a5 + ncb in + FStarC_Compiler_Util.bind_opt + uu___15 + (fun a51 -> + let uu___16 + = + unembed + e6 a6 ncb in + FStarC_Compiler_Util.bind_opt + uu___16 + (fun a61 + -> + let uu___17 + = + unembed + e7 a7 ncb in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a71 + -> + let uu___18 + = + unembed + e8 a8 ncb in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a81 + -> + let uu___19 + = + unembed + e9 a9 ncb in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a91 + -> + let uu___20 + = + unembed + e10 a10 + ncb in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a101 + -> + let uu___21 + = + unembed + e11 a11 + ncb in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a111 + -> + let r1 = + interp_ctx + name + (fun + uu___22 + -> + f a12 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 + a111) in + let uu___22 + = + let uu___23 + = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed er + uu___23 + r1 ncb in + FStar_Pervasives_Native.Some + uu___22))))))))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_total_interpretation_12 : + 'r 't1 't10 't11 't12 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 'r) + -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 't6 FStarC_Syntax_Embeddings_Base.embedding -> + 't7 FStarC_Syntax_Embeddings_Base.embedding -> + 't8 FStarC_Syntax_Embeddings_Base.embedding -> + 't9 FStarC_Syntax_Embeddings_Base.embedding -> + 't10 FStarC_Syntax_Embeddings_Base.embedding -> + 't11 FStarC_Syntax_Embeddings_Base.embedding -> + 't12 FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1):: + (a3, uu___2)::(a4, uu___3):: + (a5, uu___4)::(a6, uu___5):: + (a7, uu___6)::(a8, uu___7):: + (a9, uu___8)::(a10, uu___9):: + (a11, uu___10)::(a12, uu___11)::[] + -> + let uu___12 = unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt + uu___12 + (fun a13 -> + let uu___13 = + unembed e2 a2 ncb in + FStarC_Compiler_Util.bind_opt + uu___13 + (fun a21 -> + let uu___14 = + unembed e3 a3 ncb in + FStarC_Compiler_Util.bind_opt + uu___14 + (fun a31 -> + let uu___15 = + unembed e4 a4 + ncb in + FStarC_Compiler_Util.bind_opt + uu___15 + (fun a41 -> + let uu___16 = + unembed e5 + a5 ncb in + FStarC_Compiler_Util.bind_opt + uu___16 + (fun a51 -> + let uu___17 + = + unembed + e6 a6 ncb in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a61 + -> + let uu___18 + = + unembed + e7 a7 ncb in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a71 + -> + let uu___19 + = + unembed + e8 a8 ncb in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a81 + -> + let uu___20 + = + unembed + e9 a9 ncb in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a91 + -> + let uu___21 + = + unembed + e10 a10 + ncb in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a101 + -> + let uu___22 + = + unembed + e11 a11 + ncb in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a111 + -> + let uu___23 + = + unembed + e12 a12 + ncb in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a121 + -> + let r1 = + interp_ctx + name + (fun + uu___24 + -> + f a13 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 + a111 a121) in + let uu___24 + = + let uu___25 + = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed er + uu___25 + r1 ncb in + FStar_Pervasives_Native.Some + uu___24)))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_total_interpretation_13 : + 'r 't1 't10 't11 't12 't13 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 'r) + -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 't6 FStarC_Syntax_Embeddings_Base.embedding -> + 't7 FStarC_Syntax_Embeddings_Base.embedding -> + 't8 FStarC_Syntax_Embeddings_Base.embedding -> + 't9 FStarC_Syntax_Embeddings_Base.embedding -> + 't10 FStarC_Syntax_Embeddings_Base.embedding -> + 't11 FStarC_Syntax_Embeddings_Base.embedding -> + 't12 FStarC_Syntax_Embeddings_Base.embedding -> + 't13 FStarC_Syntax_Embeddings_Base.embedding + -> + 'r FStarC_Syntax_Embeddings_Base.embedding + -> + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb + -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1):: + (a3, uu___2)::(a4, uu___3):: + (a5, uu___4)::(a6, uu___5):: + (a7, uu___6)::(a8, uu___7):: + (a9, uu___8)::(a10, uu___9):: + (a11, uu___10)::(a12, uu___11):: + (a13, uu___12)::[] -> + let uu___13 = unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt + uu___13 + (fun a14 -> + let uu___14 = + unembed e2 a2 ncb in + FStarC_Compiler_Util.bind_opt + uu___14 + (fun a21 -> + let uu___15 = + unembed e3 a3 ncb in + FStarC_Compiler_Util.bind_opt + uu___15 + (fun a31 -> + let uu___16 = + unembed e4 a4 + ncb in + FStarC_Compiler_Util.bind_opt + uu___16 + (fun a41 -> + let uu___17 + = + unembed + e5 a5 ncb in + FStarC_Compiler_Util.bind_opt + uu___17 + ( + fun a51 + -> + let uu___18 + = + unembed + e6 a6 ncb in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a61 + -> + let uu___19 + = + unembed + e7 a7 ncb in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a71 + -> + let uu___20 + = + unembed + e8 a8 ncb in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a81 + -> + let uu___21 + = + unembed + e9 a9 ncb in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a91 + -> + let uu___22 + = + unembed + e10 a10 + ncb in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a101 + -> + let uu___23 + = + unembed + e11 a11 + ncb in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a111 + -> + let uu___24 + = + unembed + e12 a12 + ncb in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a121 + -> + let uu___25 + = + unembed + e13 a13 + ncb in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a131 + -> + let r1 = + interp_ctx + name + (fun + uu___26 + -> + f a14 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 + a111 a121 + a131) in + let uu___26 + = + let uu___27 + = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed er + uu___27 + r1 ncb in + FStar_Pervasives_Native.Some + uu___26))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_total_interpretation_14 : + 'r 't1 't10 't11 't12 't13 't14 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 'r) + -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 't6 FStarC_Syntax_Embeddings_Base.embedding -> + 't7 FStarC_Syntax_Embeddings_Base.embedding -> + 't8 FStarC_Syntax_Embeddings_Base.embedding -> + 't9 FStarC_Syntax_Embeddings_Base.embedding -> + 't10 FStarC_Syntax_Embeddings_Base.embedding -> + 't11 FStarC_Syntax_Embeddings_Base.embedding -> + 't12 FStarC_Syntax_Embeddings_Base.embedding -> + 't13 FStarC_Syntax_Embeddings_Base.embedding + -> + 't14 + FStarC_Syntax_Embeddings_Base.embedding + -> + 'r + FStarC_Syntax_Embeddings_Base.embedding + -> + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb + -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun e14 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1):: + (a3, uu___2)::(a4, uu___3):: + (a5, uu___4)::(a6, uu___5):: + (a7, uu___6)::(a8, uu___7):: + (a9, uu___8)::(a10, uu___9):: + (a11, uu___10)::(a12, + uu___11):: + (a13, uu___12)::(a14, + uu___13)::[] + -> + let uu___14 = + unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt + uu___14 + (fun a15 -> + let uu___15 = + unembed e2 a2 ncb in + FStarC_Compiler_Util.bind_opt + uu___15 + (fun a21 -> + let uu___16 = + unembed e3 a3 ncb in + FStarC_Compiler_Util.bind_opt + uu___16 + (fun a31 -> + let uu___17 = + unembed e4 + a4 ncb in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a41 -> + let uu___18 + = + unembed + e5 a5 ncb in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a51 + -> + let uu___19 + = + unembed + e6 a6 ncb in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a61 + -> + let uu___20 + = + unembed + e7 a7 ncb in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a71 + -> + let uu___21 + = + unembed + e8 a8 ncb in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a81 + -> + let uu___22 + = + unembed + e9 a9 ncb in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a91 + -> + let uu___23 + = + unembed + e10 a10 + ncb in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a101 + -> + let uu___24 + = + unembed + e11 a11 + ncb in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a111 + -> + let uu___25 + = + unembed + e12 a12 + ncb in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a121 + -> + let uu___26 + = + unembed + e13 a13 + ncb in + FStarC_Compiler_Util.bind_opt + uu___26 + (fun a131 + -> + let uu___27 + = + unembed + e14 a14 + ncb in + FStarC_Compiler_Util.bind_opt + uu___27 + (fun a141 + -> + let r1 = + interp_ctx + name + (fun + uu___28 + -> + f a15 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 + a111 a121 + a131 a141) in + let uu___28 + = + let uu___29 + = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed er + uu___29 + r1 ncb in + FStar_Pervasives_Native.Some + uu___28)))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_total_interpretation_15 : + 'r 't1 't10 't11 't12 't13 't14 't15 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> + 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 'r) + -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 't6 FStarC_Syntax_Embeddings_Base.embedding -> + 't7 FStarC_Syntax_Embeddings_Base.embedding -> + 't8 FStarC_Syntax_Embeddings_Base.embedding -> + 't9 FStarC_Syntax_Embeddings_Base.embedding -> + 't10 FStarC_Syntax_Embeddings_Base.embedding -> + 't11 FStarC_Syntax_Embeddings_Base.embedding -> + 't12 FStarC_Syntax_Embeddings_Base.embedding -> + 't13 FStarC_Syntax_Embeddings_Base.embedding + -> + 't14 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't15 + FStarC_Syntax_Embeddings_Base.embedding + -> + 'r + FStarC_Syntax_Embeddings_Base.embedding + -> + FStarC_TypeChecker_Primops_Base.psc + -> + FStarC_Syntax_Embeddings_Base.norm_cb + -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun e14 -> + fun e15 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1):: + (a3, uu___2)::(a4, uu___3):: + (a5, uu___4)::(a6, uu___5):: + (a7, uu___6)::(a8, uu___7):: + (a9, uu___8)::(a10, uu___9):: + (a11, uu___10)::(a12, + uu___11):: + (a13, uu___12)::(a14, + uu___13):: + (a15, uu___14)::[] -> + let uu___15 = + unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt + uu___15 + (fun a16 -> + let uu___16 = + unembed e2 a2 ncb in + FStarC_Compiler_Util.bind_opt + uu___16 + (fun a21 -> + let uu___17 = + unembed e3 a3 + ncb in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a31 -> + let uu___18 + = + unembed e4 + a4 ncb in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a41 + -> + let uu___19 + = + unembed + e5 a5 ncb in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a51 + -> + let uu___20 + = + unembed + e6 a6 ncb in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a61 + -> + let uu___21 + = + unembed + e7 a7 ncb in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a71 + -> + let uu___22 + = + unembed + e8 a8 ncb in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a81 + -> + let uu___23 + = + unembed + e9 a9 ncb in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a91 + -> + let uu___24 + = + unembed + e10 a10 + ncb in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a101 + -> + let uu___25 + = + unembed + e11 a11 + ncb in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a111 + -> + let uu___26 + = + unembed + e12 a12 + ncb in + FStarC_Compiler_Util.bind_opt + uu___26 + (fun a121 + -> + let uu___27 + = + unembed + e13 a13 + ncb in + FStarC_Compiler_Util.bind_opt + uu___27 + (fun a131 + -> + let uu___28 + = + unembed + e14 a14 + ncb in + FStarC_Compiler_Util.bind_opt + uu___28 + (fun a141 + -> + let uu___29 + = + unembed + e15 a15 + ncb in + FStarC_Compiler_Util.bind_opt + uu___29 + (fun a151 + -> + let r1 = + interp_ctx + name + (fun + uu___30 + -> + f a16 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 + a111 a121 + a131 a141 + a151) in + let uu___30 + = + let uu___31 + = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed er + uu___31 + r1 ncb in + FStar_Pervasives_Native.Some + uu___30))))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_total_interpretation_16 : + 'r 't1 't10 't11 't12 't13 't14 't15 't16 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> + 't10 -> + 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 'r) + -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 't6 FStarC_Syntax_Embeddings_Base.embedding -> + 't7 FStarC_Syntax_Embeddings_Base.embedding -> + 't8 FStarC_Syntax_Embeddings_Base.embedding -> + 't9 FStarC_Syntax_Embeddings_Base.embedding -> + 't10 FStarC_Syntax_Embeddings_Base.embedding -> + 't11 FStarC_Syntax_Embeddings_Base.embedding -> + 't12 FStarC_Syntax_Embeddings_Base.embedding -> + 't13 FStarC_Syntax_Embeddings_Base.embedding + -> + 't14 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't15 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't16 + FStarC_Syntax_Embeddings_Base.embedding + -> + 'r + FStarC_Syntax_Embeddings_Base.embedding + -> + FStarC_TypeChecker_Primops_Base.psc + -> + FStarC_Syntax_Embeddings_Base.norm_cb + -> + FStarC_Syntax_Syntax.universes + -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun e14 -> + fun e15 -> + fun e16 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1):: + (a3, uu___2)::(a4, + uu___3):: + (a5, uu___4)::(a6, + uu___5):: + (a7, uu___6)::(a8, + uu___7):: + (a9, uu___8)::(a10, + uu___9):: + (a11, uu___10)::(a12, + uu___11):: + (a13, uu___12)::(a14, + uu___13):: + (a15, uu___14)::(a16, + uu___15)::[] + -> + let uu___16 = + unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt + uu___16 + (fun a17 -> + let uu___17 = + unembed e2 a2 ncb in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a21 -> + let uu___18 = + unembed e3 a3 + ncb in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a31 -> + let uu___19 + = + unembed + e4 a4 ncb in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a41 + -> + let uu___20 + = + unembed + e5 a5 ncb in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a51 + -> + let uu___21 + = + unembed + e6 a6 ncb in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a61 + -> + let uu___22 + = + unembed + e7 a7 ncb in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a71 + -> + let uu___23 + = + unembed + e8 a8 ncb in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a81 + -> + let uu___24 + = + unembed + e9 a9 ncb in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a91 + -> + let uu___25 + = + unembed + e10 a10 + ncb in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a101 + -> + let uu___26 + = + unembed + e11 a11 + ncb in + FStarC_Compiler_Util.bind_opt + uu___26 + (fun a111 + -> + let uu___27 + = + unembed + e12 a12 + ncb in + FStarC_Compiler_Util.bind_opt + uu___27 + (fun a121 + -> + let uu___28 + = + unembed + e13 a13 + ncb in + FStarC_Compiler_Util.bind_opt + uu___28 + (fun a131 + -> + let uu___29 + = + unembed + e14 a14 + ncb in + FStarC_Compiler_Util.bind_opt + uu___29 + (fun a141 + -> + let uu___30 + = + unembed + e15 a15 + ncb in + FStarC_Compiler_Util.bind_opt + uu___30 + (fun a151 + -> + let uu___31 + = + unembed + e16 a16 + ncb in + FStarC_Compiler_Util.bind_opt + uu___31 + (fun a161 + -> + let r1 = + interp_ctx + name + (fun + uu___32 + -> + f a17 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 + a111 a121 + a131 a141 + a151 a161) in + let uu___32 + = + let uu___33 + = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed er + uu___33 + r1 ncb in + FStar_Pervasives_Native.Some + uu___32)))))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_total_interpretation_17 : + 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't2 't3 't4 't5 't6 't7 't8 + 't9 . + Prims.string -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> + 't10 -> + 't11 -> + 't12 -> + 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 'r) + -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 't6 FStarC_Syntax_Embeddings_Base.embedding -> + 't7 FStarC_Syntax_Embeddings_Base.embedding -> + 't8 FStarC_Syntax_Embeddings_Base.embedding -> + 't9 FStarC_Syntax_Embeddings_Base.embedding -> + 't10 FStarC_Syntax_Embeddings_Base.embedding -> + 't11 FStarC_Syntax_Embeddings_Base.embedding -> + 't12 FStarC_Syntax_Embeddings_Base.embedding -> + 't13 FStarC_Syntax_Embeddings_Base.embedding + -> + 't14 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't15 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't16 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't17 + FStarC_Syntax_Embeddings_Base.embedding + -> + 'r + FStarC_Syntax_Embeddings_Base.embedding + -> + FStarC_TypeChecker_Primops_Base.psc + -> + FStarC_Syntax_Embeddings_Base.norm_cb + -> + FStarC_Syntax_Syntax.universes + -> + FStarC_Syntax_Syntax.args + -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun e14 -> + fun e15 -> + fun e16 -> + fun e17 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1):: + (a3, uu___2)::(a4, + uu___3):: + (a5, uu___4)::(a6, + uu___5):: + (a7, uu___6)::(a8, + uu___7):: + (a9, uu___8)::(a10, + uu___9):: + (a11, uu___10):: + (a12, uu___11):: + (a13, uu___12):: + (a14, uu___13):: + (a15, uu___14):: + (a16, uu___15):: + (a17, uu___16)::[] -> + let uu___17 = + unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a18 -> + let uu___18 = + unembed e2 a2 + ncb in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a21 -> + let uu___19 = + unembed e3 + a3 ncb in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a31 -> + let uu___20 + = + unembed + e4 a4 ncb in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a41 + -> + let uu___21 + = + unembed + e5 a5 ncb in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a51 + -> + let uu___22 + = + unembed + e6 a6 ncb in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a61 + -> + let uu___23 + = + unembed + e7 a7 ncb in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a71 + -> + let uu___24 + = + unembed + e8 a8 ncb in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a81 + -> + let uu___25 + = + unembed + e9 a9 ncb in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a91 + -> + let uu___26 + = + unembed + e10 a10 + ncb in + FStarC_Compiler_Util.bind_opt + uu___26 + (fun a101 + -> + let uu___27 + = + unembed + e11 a11 + ncb in + FStarC_Compiler_Util.bind_opt + uu___27 + (fun a111 + -> + let uu___28 + = + unembed + e12 a12 + ncb in + FStarC_Compiler_Util.bind_opt + uu___28 + (fun a121 + -> + let uu___29 + = + unembed + e13 a13 + ncb in + FStarC_Compiler_Util.bind_opt + uu___29 + (fun a131 + -> + let uu___30 + = + unembed + e14 a14 + ncb in + FStarC_Compiler_Util.bind_opt + uu___30 + (fun a141 + -> + let uu___31 + = + unembed + e15 a15 + ncb in + FStarC_Compiler_Util.bind_opt + uu___31 + (fun a151 + -> + let uu___32 + = + unembed + e16 a16 + ncb in + FStarC_Compiler_Util.bind_opt + uu___32 + (fun a161 + -> + let uu___33 + = + unembed + e17 a17 + ncb in + FStarC_Compiler_Util.bind_opt + uu___33 + (fun a171 + -> + let r1 = + interp_ctx + name + (fun + uu___34 + -> + f a18 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 + a111 a121 + a131 a141 + a151 a161 + a171) in + let uu___34 + = + let uu___35 + = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed er + uu___35 + r1 ncb in + FStar_Pervasives_Native.Some + uu___34))))))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_total_interpretation_18 : + 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't18 't2 't3 't4 't5 't6 't7 + 't8 't9 . + Prims.string -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> + 't10 -> + 't11 -> + 't12 -> + 't13 -> + 't14 -> 't15 -> 't16 -> 't17 -> 't18 -> 'r) + -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 't6 FStarC_Syntax_Embeddings_Base.embedding -> + 't7 FStarC_Syntax_Embeddings_Base.embedding -> + 't8 FStarC_Syntax_Embeddings_Base.embedding -> + 't9 FStarC_Syntax_Embeddings_Base.embedding -> + 't10 FStarC_Syntax_Embeddings_Base.embedding -> + 't11 FStarC_Syntax_Embeddings_Base.embedding -> + 't12 FStarC_Syntax_Embeddings_Base.embedding -> + 't13 FStarC_Syntax_Embeddings_Base.embedding + -> + 't14 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't15 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't16 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't17 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't18 + FStarC_Syntax_Embeddings_Base.embedding + -> + 'r + FStarC_Syntax_Embeddings_Base.embedding + -> + FStarC_TypeChecker_Primops_Base.psc + -> + FStarC_Syntax_Embeddings_Base.norm_cb + -> + FStarC_Syntax_Syntax.universes + -> + FStarC_Syntax_Syntax.args + -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun e14 -> + fun e15 -> + fun e16 -> + fun e17 -> + fun e18 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, + uu___1):: + (a3, uu___2):: + (a4, uu___3):: + (a5, uu___4):: + (a6, uu___5):: + (a7, uu___6):: + (a8, uu___7):: + (a9, uu___8):: + (a10, uu___9):: + (a11, uu___10):: + (a12, uu___11):: + (a13, uu___12):: + (a14, uu___13):: + (a15, uu___14):: + (a16, uu___15):: + (a17, uu___16):: + (a18, uu___17)::[] -> + let uu___18 = + unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a19 -> + let uu___19 = + unembed e2 a2 + ncb in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a21 -> + let uu___20 + = + unembed + e3 a3 ncb in + FStarC_Compiler_Util.bind_opt + uu___20 + ( + fun a31 + -> + let uu___21 + = + unembed + e4 a4 ncb in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a41 + -> + let uu___22 + = + unembed + e5 a5 ncb in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a51 + -> + let uu___23 + = + unembed + e6 a6 ncb in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a61 + -> + let uu___24 + = + unembed + e7 a7 ncb in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a71 + -> + let uu___25 + = + unembed + e8 a8 ncb in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a81 + -> + let uu___26 + = + unembed + e9 a9 ncb in + FStarC_Compiler_Util.bind_opt + uu___26 + (fun a91 + -> + let uu___27 + = + unembed + e10 a10 + ncb in + FStarC_Compiler_Util.bind_opt + uu___27 + (fun a101 + -> + let uu___28 + = + unembed + e11 a11 + ncb in + FStarC_Compiler_Util.bind_opt + uu___28 + (fun a111 + -> + let uu___29 + = + unembed + e12 a12 + ncb in + FStarC_Compiler_Util.bind_opt + uu___29 + (fun a121 + -> + let uu___30 + = + unembed + e13 a13 + ncb in + FStarC_Compiler_Util.bind_opt + uu___30 + (fun a131 + -> + let uu___31 + = + unembed + e14 a14 + ncb in + FStarC_Compiler_Util.bind_opt + uu___31 + (fun a141 + -> + let uu___32 + = + unembed + e15 a15 + ncb in + FStarC_Compiler_Util.bind_opt + uu___32 + (fun a151 + -> + let uu___33 + = + unembed + e16 a16 + ncb in + FStarC_Compiler_Util.bind_opt + uu___33 + (fun a161 + -> + let uu___34 + = + unembed + e17 a17 + ncb in + FStarC_Compiler_Util.bind_opt + uu___34 + (fun a171 + -> + let uu___35 + = + unembed + e18 a18 + ncb in + FStarC_Compiler_Util.bind_opt + uu___35 + (fun a181 + -> + let r1 = + interp_ctx + name + (fun + uu___36 + -> + f a19 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 + a111 a121 + a131 a141 + a151 a161 + a171 a181) in + let uu___36 + = + let uu___37 + = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed er + uu___37 + r1 ncb in + FStar_Pervasives_Native.Some + uu___36)))))))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_total_interpretation_19 : + 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't18 't19 't2 't3 't4 't5 + 't6 't7 't8 't9 . + Prims.string -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> + 't10 -> + 't11 -> + 't12 -> + 't13 -> + 't14 -> + 't15 -> 't16 -> 't17 -> 't18 -> 't19 -> 'r) + -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 't6 FStarC_Syntax_Embeddings_Base.embedding -> + 't7 FStarC_Syntax_Embeddings_Base.embedding -> + 't8 FStarC_Syntax_Embeddings_Base.embedding -> + 't9 FStarC_Syntax_Embeddings_Base.embedding -> + 't10 FStarC_Syntax_Embeddings_Base.embedding -> + 't11 FStarC_Syntax_Embeddings_Base.embedding -> + 't12 FStarC_Syntax_Embeddings_Base.embedding -> + 't13 FStarC_Syntax_Embeddings_Base.embedding + -> + 't14 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't15 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't16 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't17 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't18 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't19 + FStarC_Syntax_Embeddings_Base.embedding + -> + 'r + FStarC_Syntax_Embeddings_Base.embedding + -> + FStarC_TypeChecker_Primops_Base.psc + -> + FStarC_Syntax_Embeddings_Base.norm_cb + -> + FStarC_Syntax_Syntax.universes + -> + FStarC_Syntax_Syntax.args + -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun e14 -> + fun e15 -> + fun e16 -> + fun e17 -> + fun e18 -> + fun e19 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___):: + (a2, uu___1):: + (a3, uu___2):: + (a4, uu___3):: + (a5, uu___4):: + (a6, uu___5):: + (a7, uu___6):: + (a8, uu___7):: + (a9, uu___8):: + (a10, uu___9):: + (a11, uu___10):: + (a12, uu___11):: + (a13, uu___12):: + (a14, uu___13):: + (a15, uu___14):: + (a16, uu___15):: + (a17, uu___16):: + (a18, uu___17):: + (a19, uu___18)::[] + -> + let uu___19 = + unembed e1 a1 ncb in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a110 -> + let uu___20 = + unembed e2 + a2 ncb in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a21 -> + let uu___21 + = + unembed + e3 a3 ncb in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a31 + -> + let uu___22 + = + unembed + e4 a4 ncb in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a41 + -> + let uu___23 + = + unembed + e5 a5 ncb in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a51 + -> + let uu___24 + = + unembed + e6 a6 ncb in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a61 + -> + let uu___25 + = + unembed + e7 a7 ncb in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a71 + -> + let uu___26 + = + unembed + e8 a8 ncb in + FStarC_Compiler_Util.bind_opt + uu___26 + (fun a81 + -> + let uu___27 + = + unembed + e9 a9 ncb in + FStarC_Compiler_Util.bind_opt + uu___27 + (fun a91 + -> + let uu___28 + = + unembed + e10 a10 + ncb in + FStarC_Compiler_Util.bind_opt + uu___28 + (fun a101 + -> + let uu___29 + = + unembed + e11 a11 + ncb in + FStarC_Compiler_Util.bind_opt + uu___29 + (fun a111 + -> + let uu___30 + = + unembed + e12 a12 + ncb in + FStarC_Compiler_Util.bind_opt + uu___30 + (fun a121 + -> + let uu___31 + = + unembed + e13 a13 + ncb in + FStarC_Compiler_Util.bind_opt + uu___31 + (fun a131 + -> + let uu___32 + = + unembed + e14 a14 + ncb in + FStarC_Compiler_Util.bind_opt + uu___32 + (fun a141 + -> + let uu___33 + = + unembed + e15 a15 + ncb in + FStarC_Compiler_Util.bind_opt + uu___33 + (fun a151 + -> + let uu___34 + = + unembed + e16 a16 + ncb in + FStarC_Compiler_Util.bind_opt + uu___34 + (fun a161 + -> + let uu___35 + = + unembed + e17 a17 + ncb in + FStarC_Compiler_Util.bind_opt + uu___35 + (fun a171 + -> + let uu___36 + = + unembed + e18 a18 + ncb in + FStarC_Compiler_Util.bind_opt + uu___36 + (fun a181 + -> + let uu___37 + = + unembed + e19 a19 + ncb in + FStarC_Compiler_Util.bind_opt + uu___37 + (fun a191 + -> + let r1 = + interp_ctx + name + (fun + uu___38 + -> + f a110 + a21 a31 + a41 a51 + a61 a71 + a81 a91 + a101 a111 + a121 a131 + a141 a151 + a161 a171 + a181 a191) in + let uu___38 + = + let uu___39 + = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed er + uu___39 + r1 ncb in + FStar_Pervasives_Native.Some + uu___38))))))))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_total_interpretation_20 : + 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't18 't19 't2 't20 't3 't4 + 't5 't6 't7 't8 't9 . + Prims.string -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> + 't10 -> + 't11 -> + 't12 -> + 't13 -> + 't14 -> + 't15 -> + 't16 -> + 't17 -> 't18 -> 't19 -> 't20 -> 'r) + -> + 't1 FStarC_Syntax_Embeddings_Base.embedding -> + 't2 FStarC_Syntax_Embeddings_Base.embedding -> + 't3 FStarC_Syntax_Embeddings_Base.embedding -> + 't4 FStarC_Syntax_Embeddings_Base.embedding -> + 't5 FStarC_Syntax_Embeddings_Base.embedding -> + 't6 FStarC_Syntax_Embeddings_Base.embedding -> + 't7 FStarC_Syntax_Embeddings_Base.embedding -> + 't8 FStarC_Syntax_Embeddings_Base.embedding -> + 't9 FStarC_Syntax_Embeddings_Base.embedding -> + 't10 FStarC_Syntax_Embeddings_Base.embedding -> + 't11 FStarC_Syntax_Embeddings_Base.embedding -> + 't12 FStarC_Syntax_Embeddings_Base.embedding -> + 't13 FStarC_Syntax_Embeddings_Base.embedding + -> + 't14 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't15 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't16 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't17 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't18 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't19 + FStarC_Syntax_Embeddings_Base.embedding + -> + 't20 + FStarC_Syntax_Embeddings_Base.embedding + -> + 'r + FStarC_Syntax_Embeddings_Base.embedding + -> + FStarC_TypeChecker_Primops_Base.psc + -> + FStarC_Syntax_Embeddings_Base.norm_cb + -> + FStarC_Syntax_Syntax.universes + -> + FStarC_Syntax_Syntax.args + -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun name -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun e14 -> + fun e15 -> + fun e16 -> + fun e17 -> + fun e18 -> + fun e19 -> + fun e20 -> + fun er -> + fun psc -> + fun ncb -> + fun us -> + fun args -> + match args with + | (a1, uu___):: + (a2, uu___1):: + (a3, uu___2):: + (a4, uu___3):: + (a5, uu___4):: + (a6, uu___5):: + (a7, uu___6):: + (a8, uu___7):: + (a9, uu___8):: + (a10, uu___9):: + (a11, uu___10):: + (a12, uu___11):: + (a13, uu___12):: + (a14, uu___13):: + (a15, uu___14):: + (a16, uu___15):: + (a17, uu___16):: + (a18, uu___17):: + (a19, uu___18):: + (a20, uu___19)::[] + -> + let uu___20 = + unembed e1 a1 + ncb in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a110 -> + let uu___21 + = + unembed e2 + a2 ncb in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a21 + -> + let uu___22 + = + unembed + e3 a3 ncb in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a31 + -> + let uu___23 + = + unembed + e4 a4 ncb in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a41 + -> + let uu___24 + = + unembed + e5 a5 ncb in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a51 + -> + let uu___25 + = + unembed + e6 a6 ncb in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a61 + -> + let uu___26 + = + unembed + e7 a7 ncb in + FStarC_Compiler_Util.bind_opt + uu___26 + (fun a71 + -> + let uu___27 + = + unembed + e8 a8 ncb in + FStarC_Compiler_Util.bind_opt + uu___27 + (fun a81 + -> + let uu___28 + = + unembed + e9 a9 ncb in + FStarC_Compiler_Util.bind_opt + uu___28 + (fun a91 + -> + let uu___29 + = + unembed + e10 a10 + ncb in + FStarC_Compiler_Util.bind_opt + uu___29 + (fun a101 + -> + let uu___30 + = + unembed + e11 a11 + ncb in + FStarC_Compiler_Util.bind_opt + uu___30 + (fun a111 + -> + let uu___31 + = + unembed + e12 a12 + ncb in + FStarC_Compiler_Util.bind_opt + uu___31 + (fun a121 + -> + let uu___32 + = + unembed + e13 a13 + ncb in + FStarC_Compiler_Util.bind_opt + uu___32 + (fun a131 + -> + let uu___33 + = + unembed + e14 a14 + ncb in + FStarC_Compiler_Util.bind_opt + uu___33 + (fun a141 + -> + let uu___34 + = + unembed + e15 a15 + ncb in + FStarC_Compiler_Util.bind_opt + uu___34 + (fun a151 + -> + let uu___35 + = + unembed + e16 a16 + ncb in + FStarC_Compiler_Util.bind_opt + uu___35 + (fun a161 + -> + let uu___36 + = + unembed + e17 a17 + ncb in + FStarC_Compiler_Util.bind_opt + uu___36 + (fun a171 + -> + let uu___37 + = + unembed + e18 a18 + ncb in + FStarC_Compiler_Util.bind_opt + uu___37 + (fun a181 + -> + let uu___38 + = + unembed + e19 a19 + ncb in + FStarC_Compiler_Util.bind_opt + uu___38 + (fun a191 + -> + let uu___39 + = + unembed + e20 a20 + ncb in + FStarC_Compiler_Util.bind_opt + uu___39 + (fun a201 + -> + let r1 = + interp_ctx + name + (fun + uu___40 + -> + f a110 + a21 a31 + a41 a51 + a61 a71 + a81 a91 + a101 a111 + a121 a131 + a141 a151 + a161 a171 + a181 a191 + a201) in + let uu___40 + = + let uu___41 + = + FStarC_TypeChecker_Primops_Base.psc_range + psc in + embed er + uu___41 + r1 ncb in + FStar_Pervasives_Native.Some + uu___40)))))))))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_total_nbe_interpretation_1 : + 'r 't1 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> 'r) -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args -> + FStarC_TypeChecker_NBETerm.t FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun f -> + fun e1 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::[] -> + let uu___1 = FStarC_TypeChecker_NBETerm.unembed e1 cb a1 in + FStarC_Compiler_Util.bind_opt uu___1 + (fun a11 -> + let r1 = interp_ctx name (fun uu___2 -> f a11) in + let uu___2 = + FStarC_TypeChecker_NBETerm.embed er cb r1 in + FStar_Pervasives_Native.Some uu___2) + | uu___ -> FStar_Pervasives_Native.None +let mk_total_nbe_interpretation_2 : + 'r 't1 't2 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> 't2 -> 'r) -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun f -> + fun e1 -> + fun e2 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::[] -> + let uu___2 = + FStarC_TypeChecker_NBETerm.unembed e1 cb a1 in + FStarC_Compiler_Util.bind_opt uu___2 + (fun a11 -> + let uu___3 = + FStarC_TypeChecker_NBETerm.unembed e2 cb a2 in + FStarC_Compiler_Util.bind_opt uu___3 + (fun a21 -> + let r1 = + interp_ctx name (fun uu___4 -> f a11 a21) in + let uu___4 = + FStarC_TypeChecker_NBETerm.embed er cb r1 in + FStar_Pervasives_Native.Some uu___4)) + | uu___ -> FStar_Pervasives_Native.None +let mk_total_nbe_interpretation_3 : + 'r 't1 't2 't3 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> 't2 -> 't3 -> 'r) -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2)::[] -> + let uu___3 = + FStarC_TypeChecker_NBETerm.unembed e1 cb a1 in + FStarC_Compiler_Util.bind_opt uu___3 + (fun a11 -> + let uu___4 = + FStarC_TypeChecker_NBETerm.unembed e2 cb a2 in + FStarC_Compiler_Util.bind_opt uu___4 + (fun a21 -> + let uu___5 = + FStarC_TypeChecker_NBETerm.unembed e3 cb + a3 in + FStarC_Compiler_Util.bind_opt uu___5 + (fun a31 -> + let r1 = + interp_ctx name + (fun uu___6 -> f a11 a21 a31) in + let uu___6 = + FStarC_TypeChecker_NBETerm.embed er + cb r1 in + FStar_Pervasives_Native.Some uu___6))) + | uu___ -> FStar_Pervasives_Native.None +let mk_total_nbe_interpretation_4 : + 'r 't1 't2 't3 't4 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> 't2 -> 't3 -> 't4 -> 'r) -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2)::(a4, uu___3)::[] + -> + let uu___4 = + FStarC_TypeChecker_NBETerm.unembed e1 cb a1 in + FStarC_Compiler_Util.bind_opt uu___4 + (fun a11 -> + let uu___5 = + FStarC_TypeChecker_NBETerm.unembed e2 cb a2 in + FStarC_Compiler_Util.bind_opt uu___5 + (fun a21 -> + let uu___6 = + FStarC_TypeChecker_NBETerm.unembed e3 + cb a3 in + FStarC_Compiler_Util.bind_opt uu___6 + (fun a31 -> + let uu___7 = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt uu___7 + (fun a41 -> + let r1 = + interp_ctx name + (fun uu___8 -> + f a11 a21 a31 a41) in + let uu___8 = + FStarC_TypeChecker_NBETerm.embed + er cb r1 in + FStar_Pervasives_Native.Some + uu___8)))) + | uu___ -> FStar_Pervasives_Native.None +let mk_total_nbe_interpretation_5 : + 'r 't1 't2 't3 't4 't5 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> 't2 -> 't3 -> 't4 -> 't5 -> 'r) -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2)::(a4, + uu___3):: + (a5, uu___4)::[] -> + let uu___5 = + FStarC_TypeChecker_NBETerm.unembed e1 cb a1 in + FStarC_Compiler_Util.bind_opt uu___5 + (fun a11 -> + let uu___6 = + FStarC_TypeChecker_NBETerm.unembed e2 cb + a2 in + FStarC_Compiler_Util.bind_opt uu___6 + (fun a21 -> + let uu___7 = + FStarC_TypeChecker_NBETerm.unembed e3 + cb a3 in + FStarC_Compiler_Util.bind_opt uu___7 + (fun a31 -> + let uu___8 = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___8 + (fun a41 -> + let uu___9 = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___9 + (fun a51 -> + let r1 = + interp_ctx name + (fun uu___10 -> + f a11 a21 a31 a41 + a51) in + let uu___10 = + FStarC_TypeChecker_NBETerm.embed + er cb r1 in + FStar_Pervasives_Native.Some + uu___10))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_total_nbe_interpretation_6 : + 'r 't1 't2 't3 't4 't5 't6 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 'r) -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 't6 FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: + (a4, uu___3)::(a5, uu___4)::(a6, uu___5)::[] -> + let uu___6 = + FStarC_TypeChecker_NBETerm.unembed e1 cb a1 in + FStarC_Compiler_Util.bind_opt uu___6 + (fun a11 -> + let uu___7 = + FStarC_TypeChecker_NBETerm.unembed e2 cb + a2 in + FStarC_Compiler_Util.bind_opt uu___7 + (fun a21 -> + let uu___8 = + FStarC_TypeChecker_NBETerm.unembed + e3 cb a3 in + FStarC_Compiler_Util.bind_opt uu___8 + (fun a31 -> + let uu___9 = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___9 + (fun a41 -> + let uu___10 = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___10 + (fun a51 -> + let uu___11 = + FStarC_TypeChecker_NBETerm.unembed + e6 cb a6 in + FStarC_Compiler_Util.bind_opt + uu___11 + (fun a61 -> + let r1 = + interp_ctx name + (fun uu___12 + -> + f a11 a21 + a31 a41 + a51 a61) in + let uu___12 = + FStarC_TypeChecker_NBETerm.embed + er cb r1 in + FStar_Pervasives_Native.Some + uu___12)))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_total_nbe_interpretation_7 : + 'r 't1 't2 't3 't4 't5 't6 't7 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 'r) -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 't6 FStarC_TypeChecker_NBETerm.embedding -> + 't7 FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: + (a4, uu___3)::(a5, uu___4)::(a6, uu___5):: + (a7, uu___6)::[] -> + let uu___7 = + FStarC_TypeChecker_NBETerm.unembed e1 cb a1 in + FStarC_Compiler_Util.bind_opt uu___7 + (fun a11 -> + let uu___8 = + FStarC_TypeChecker_NBETerm.unembed e2 + cb a2 in + FStarC_Compiler_Util.bind_opt uu___8 + (fun a21 -> + let uu___9 = + FStarC_TypeChecker_NBETerm.unembed + e3 cb a3 in + FStarC_Compiler_Util.bind_opt + uu___9 + (fun a31 -> + let uu___10 = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___10 + (fun a41 -> + let uu___11 = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___11 + (fun a51 -> + let uu___12 = + FStarC_TypeChecker_NBETerm.unembed + e6 cb a6 in + FStarC_Compiler_Util.bind_opt + uu___12 + (fun a61 -> + let uu___13 = + FStarC_TypeChecker_NBETerm.unembed + e7 cb a7 in + FStarC_Compiler_Util.bind_opt + uu___13 + (fun a71 -> + let r1 = + interp_ctx + name + (fun + uu___14 + -> + f a11 a21 + a31 a41 + a51 a61 + a71) in + let uu___14 + = + FStarC_TypeChecker_NBETerm.embed + er cb r1 in + FStar_Pervasives_Native.Some + uu___14))))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_total_nbe_interpretation_8 : + 'r 't1 't2 't3 't4 't5 't6 't7 't8 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 'r) -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 't6 FStarC_TypeChecker_NBETerm.embedding -> + 't7 FStarC_TypeChecker_NBETerm.embedding -> + 't8 FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: + (a4, uu___3)::(a5, uu___4)::(a6, uu___5):: + (a7, uu___6)::(a8, uu___7)::[] -> + let uu___8 = + FStarC_TypeChecker_NBETerm.unembed e1 cb + a1 in + FStarC_Compiler_Util.bind_opt uu___8 + (fun a11 -> + let uu___9 = + FStarC_TypeChecker_NBETerm.unembed + e2 cb a2 in + FStarC_Compiler_Util.bind_opt uu___9 + (fun a21 -> + let uu___10 = + FStarC_TypeChecker_NBETerm.unembed + e3 cb a3 in + FStarC_Compiler_Util.bind_opt + uu___10 + (fun a31 -> + let uu___11 = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___11 + (fun a41 -> + let uu___12 = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___12 + (fun a51 -> + let uu___13 = + FStarC_TypeChecker_NBETerm.unembed + e6 cb a6 in + FStarC_Compiler_Util.bind_opt + uu___13 + (fun a61 -> + let uu___14 = + FStarC_TypeChecker_NBETerm.unembed + e7 cb a7 in + FStarC_Compiler_Util.bind_opt + uu___14 + (fun a71 -> + let uu___15 + = + FStarC_TypeChecker_NBETerm.unembed + e8 cb a8 in + FStarC_Compiler_Util.bind_opt + uu___15 + (fun a81 + -> + let r1 = + interp_ctx + name + (fun + uu___16 + -> + f a11 a21 + a31 a41 + a51 a61 + a71 a81) in + let uu___16 + = + FStarC_TypeChecker_NBETerm.embed + er cb r1 in + FStar_Pervasives_Native.Some + uu___16)))))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_total_nbe_interpretation_9 : + 'r 't1 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 'r) + -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 't6 FStarC_TypeChecker_NBETerm.embedding -> + 't7 FStarC_TypeChecker_NBETerm.embedding -> + 't8 FStarC_TypeChecker_NBETerm.embedding -> + 't9 FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: + (a4, uu___3)::(a5, uu___4)::(a6, uu___5):: + (a7, uu___6)::(a8, uu___7)::(a9, uu___8)::[] + -> + let uu___9 = + FStarC_TypeChecker_NBETerm.unembed e1 + cb a1 in + FStarC_Compiler_Util.bind_opt uu___9 + (fun a11 -> + let uu___10 = + FStarC_TypeChecker_NBETerm.unembed + e2 cb a2 in + FStarC_Compiler_Util.bind_opt + uu___10 + (fun a21 -> + let uu___11 = + FStarC_TypeChecker_NBETerm.unembed + e3 cb a3 in + FStarC_Compiler_Util.bind_opt + uu___11 + (fun a31 -> + let uu___12 = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___12 + (fun a41 -> + let uu___13 = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___13 + (fun a51 -> + let uu___14 = + FStarC_TypeChecker_NBETerm.unembed + e6 cb a6 in + FStarC_Compiler_Util.bind_opt + uu___14 + (fun a61 -> + let uu___15 + = + FStarC_TypeChecker_NBETerm.unembed + e7 cb a7 in + FStarC_Compiler_Util.bind_opt + uu___15 + ( + fun a71 + -> + let uu___16 + = + FStarC_TypeChecker_NBETerm.unembed + e8 cb a8 in + FStarC_Compiler_Util.bind_opt + uu___16 + (fun a81 + -> + let uu___17 + = + FStarC_TypeChecker_NBETerm.unembed + e9 cb a9 in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a91 + -> + let r1 = + interp_ctx + name + (fun + uu___18 + -> + f a11 a21 + a31 a41 + a51 a61 + a71 a81 + a91) in + let uu___18 + = + FStarC_TypeChecker_NBETerm.embed + er cb r1 in + FStar_Pervasives_Native.Some + uu___18))))))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_total_nbe_interpretation_10 : + 'r 't1 't10 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> + 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 'r) + -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 't6 FStarC_TypeChecker_NBETerm.embedding -> + 't7 FStarC_TypeChecker_NBETerm.embedding -> + 't8 FStarC_TypeChecker_NBETerm.embedding -> + 't9 FStarC_TypeChecker_NBETerm.embedding -> + 't10 FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: + (a4, uu___3)::(a5, uu___4)::(a6, + uu___5):: + (a7, uu___6)::(a8, uu___7)::(a9, + uu___8):: + (a10, uu___9)::[] -> + let uu___10 = + FStarC_TypeChecker_NBETerm.unembed e1 + cb a1 in + FStarC_Compiler_Util.bind_opt uu___10 + (fun a11 -> + let uu___11 = + FStarC_TypeChecker_NBETerm.unembed + e2 cb a2 in + FStarC_Compiler_Util.bind_opt + uu___11 + (fun a21 -> + let uu___12 = + FStarC_TypeChecker_NBETerm.unembed + e3 cb a3 in + FStarC_Compiler_Util.bind_opt + uu___12 + (fun a31 -> + let uu___13 = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___13 + (fun a41 -> + let uu___14 = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___14 + (fun a51 -> + let uu___15 = + FStarC_TypeChecker_NBETerm.unembed + e6 cb a6 in + FStarC_Compiler_Util.bind_opt + uu___15 + (fun a61 -> + let uu___16 + = + FStarC_TypeChecker_NBETerm.unembed + e7 cb a7 in + FStarC_Compiler_Util.bind_opt + uu___16 + (fun a71 + -> + let uu___17 + = + FStarC_TypeChecker_NBETerm.unembed + e8 cb a8 in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a81 + -> + let uu___18 + = + FStarC_TypeChecker_NBETerm.unembed + e9 cb a9 in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a91 + -> + let uu___19 + = + FStarC_TypeChecker_NBETerm.unembed + e10 cb + a10 in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a101 + -> + let r1 = + interp_ctx + name + (fun + uu___20 + -> + f a11 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101) in + let uu___20 + = + FStarC_TypeChecker_NBETerm.embed + er cb r1 in + FStar_Pervasives_Native.Some + uu___20)))))))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_total_nbe_interpretation_11 : + 'r 't1 't10 't11 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 'r) + -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 't6 FStarC_TypeChecker_NBETerm.embedding -> + 't7 FStarC_TypeChecker_NBETerm.embedding -> + 't8 FStarC_TypeChecker_NBETerm.embedding -> + 't9 FStarC_TypeChecker_NBETerm.embedding -> + 't10 FStarC_TypeChecker_NBETerm.embedding -> + 't11 FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: + (a4, uu___3)::(a5, uu___4)::(a6, + uu___5):: + (a7, uu___6)::(a8, uu___7)::(a9, + uu___8):: + (a10, uu___9)::(a11, uu___10)::[] -> + let uu___11 = + FStarC_TypeChecker_NBETerm.unembed + e1 cb a1 in + FStarC_Compiler_Util.bind_opt uu___11 + (fun a12 -> + let uu___12 = + FStarC_TypeChecker_NBETerm.unembed + e2 cb a2 in + FStarC_Compiler_Util.bind_opt + uu___12 + (fun a21 -> + let uu___13 = + FStarC_TypeChecker_NBETerm.unembed + e3 cb a3 in + FStarC_Compiler_Util.bind_opt + uu___13 + (fun a31 -> + let uu___14 = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___14 + (fun a41 -> + let uu___15 = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___15 + (fun a51 -> + let uu___16 + = + FStarC_TypeChecker_NBETerm.unembed + e6 cb a6 in + FStarC_Compiler_Util.bind_opt + uu___16 + (fun a61 + -> + let uu___17 + = + FStarC_TypeChecker_NBETerm.unembed + e7 cb a7 in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a71 + -> + let uu___18 + = + FStarC_TypeChecker_NBETerm.unembed + e8 cb a8 in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a81 + -> + let uu___19 + = + FStarC_TypeChecker_NBETerm.unembed + e9 cb a9 in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a91 + -> + let uu___20 + = + FStarC_TypeChecker_NBETerm.unembed + e10 cb + a10 in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a101 + -> + let uu___21 + = + FStarC_TypeChecker_NBETerm.unembed + e11 cb + a11 in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a111 + -> + let r1 = + interp_ctx + name + (fun + uu___22 + -> + f a12 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 + a111) in + let uu___22 + = + FStarC_TypeChecker_NBETerm.embed + er cb r1 in + FStar_Pervasives_Native.Some + uu___22))))))))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_total_nbe_interpretation_12 : + 'r 't1 't10 't11 't12 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 'r) + -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 't6 FStarC_TypeChecker_NBETerm.embedding -> + 't7 FStarC_TypeChecker_NBETerm.embedding -> + 't8 FStarC_TypeChecker_NBETerm.embedding -> + 't9 FStarC_TypeChecker_NBETerm.embedding -> + 't10 FStarC_TypeChecker_NBETerm.embedding -> + 't11 FStarC_TypeChecker_NBETerm.embedding -> + 't12 FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1)::(a3, + uu___2):: + (a4, uu___3)::(a5, uu___4):: + (a6, uu___5)::(a7, uu___6):: + (a8, uu___7)::(a9, uu___8):: + (a10, uu___9)::(a11, uu___10):: + (a12, uu___11)::[] -> + let uu___12 = + FStarC_TypeChecker_NBETerm.unembed + e1 cb a1 in + FStarC_Compiler_Util.bind_opt + uu___12 + (fun a13 -> + let uu___13 = + FStarC_TypeChecker_NBETerm.unembed + e2 cb a2 in + FStarC_Compiler_Util.bind_opt + uu___13 + (fun a21 -> + let uu___14 = + FStarC_TypeChecker_NBETerm.unembed + e3 cb a3 in + FStarC_Compiler_Util.bind_opt + uu___14 + (fun a31 -> + let uu___15 = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___15 + (fun a41 -> + let uu___16 = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___16 + (fun a51 -> + let uu___17 + = + FStarC_TypeChecker_NBETerm.unembed + e6 cb a6 in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a61 + -> + let uu___18 + = + FStarC_TypeChecker_NBETerm.unembed + e7 cb a7 in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a71 + -> + let uu___19 + = + FStarC_TypeChecker_NBETerm.unembed + e8 cb a8 in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a81 + -> + let uu___20 + = + FStarC_TypeChecker_NBETerm.unembed + e9 cb a9 in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a91 + -> + let uu___21 + = + FStarC_TypeChecker_NBETerm.unembed + e10 cb + a10 in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a101 + -> + let uu___22 + = + FStarC_TypeChecker_NBETerm.unembed + e11 cb + a11 in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a111 + -> + let uu___23 + = + FStarC_TypeChecker_NBETerm.unembed + e12 cb + a12 in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a121 + -> + let r1 = + interp_ctx + name + (fun + uu___24 + -> + f a13 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 + a111 a121) in + let uu___24 + = + FStarC_TypeChecker_NBETerm.embed + er cb r1 in + FStar_Pervasives_Native.Some + uu___24)))))))))))) + | uu___ -> FStar_Pervasives_Native.None +let mk_total_nbe_interpretation_13 : + 'r 't1 't10 't11 't12 't13 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 'r) + -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 't6 FStarC_TypeChecker_NBETerm.embedding -> + 't7 FStarC_TypeChecker_NBETerm.embedding -> + 't8 FStarC_TypeChecker_NBETerm.embedding -> + 't9 FStarC_TypeChecker_NBETerm.embedding -> + 't10 FStarC_TypeChecker_NBETerm.embedding -> + 't11 FStarC_TypeChecker_NBETerm.embedding -> + 't12 FStarC_TypeChecker_NBETerm.embedding -> + 't13 FStarC_TypeChecker_NBETerm.embedding + -> + 'r FStarC_TypeChecker_NBETerm.embedding + -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1):: + (a3, uu___2)::(a4, uu___3):: + (a5, uu___4)::(a6, uu___5):: + (a7, uu___6)::(a8, uu___7):: + (a9, uu___8)::(a10, uu___9):: + (a11, uu___10)::(a12, uu___11):: + (a13, uu___12)::[] -> + let uu___13 = + FStarC_TypeChecker_NBETerm.unembed + e1 cb a1 in + FStarC_Compiler_Util.bind_opt + uu___13 + (fun a14 -> + let uu___14 = + FStarC_TypeChecker_NBETerm.unembed + e2 cb a2 in + FStarC_Compiler_Util.bind_opt + uu___14 + (fun a21 -> + let uu___15 = + FStarC_TypeChecker_NBETerm.unembed + e3 cb a3 in + FStarC_Compiler_Util.bind_opt + uu___15 + (fun a31 -> + let uu___16 = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___16 + (fun a41 -> + let uu___17 = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a51 -> + let uu___18 + = + FStarC_TypeChecker_NBETerm.unembed + e6 cb a6 in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a61 + -> + let uu___19 + = + FStarC_TypeChecker_NBETerm.unembed + e7 cb a7 in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a71 + -> + let uu___20 + = + FStarC_TypeChecker_NBETerm.unembed + e8 cb a8 in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a81 + -> + let uu___21 + = + FStarC_TypeChecker_NBETerm.unembed + e9 cb a9 in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a91 + -> + let uu___22 + = + FStarC_TypeChecker_NBETerm.unembed + e10 cb + a10 in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a101 + -> + let uu___23 + = + FStarC_TypeChecker_NBETerm.unembed + e11 cb + a11 in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a111 + -> + let uu___24 + = + FStarC_TypeChecker_NBETerm.unembed + e12 cb + a12 in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a121 + -> + let uu___25 + = + FStarC_TypeChecker_NBETerm.unembed + e13 cb + a13 in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a131 + -> + let r1 = + interp_ctx + name + (fun + uu___26 + -> + f a14 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 + a111 a121 + a131) in + let uu___26 + = + FStarC_TypeChecker_NBETerm.embed + er cb r1 in + FStar_Pervasives_Native.Some + uu___26))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_total_nbe_interpretation_14 : + 'r 't1 't10 't11 't12 't13 't14 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 'r) + -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 't6 FStarC_TypeChecker_NBETerm.embedding -> + 't7 FStarC_TypeChecker_NBETerm.embedding -> + 't8 FStarC_TypeChecker_NBETerm.embedding -> + 't9 FStarC_TypeChecker_NBETerm.embedding -> + 't10 FStarC_TypeChecker_NBETerm.embedding -> + 't11 FStarC_TypeChecker_NBETerm.embedding -> + 't12 FStarC_TypeChecker_NBETerm.embedding -> + 't13 FStarC_TypeChecker_NBETerm.embedding + -> + 't14 FStarC_TypeChecker_NBETerm.embedding + -> + 'r FStarC_TypeChecker_NBETerm.embedding + -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun e14 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1):: + (a3, uu___2)::(a4, uu___3):: + (a5, uu___4)::(a6, uu___5):: + (a7, uu___6)::(a8, uu___7):: + (a9, uu___8)::(a10, uu___9):: + (a11, uu___10)::(a12, uu___11):: + (a13, uu___12)::(a14, uu___13)::[] + -> + let uu___14 = + FStarC_TypeChecker_NBETerm.unembed + e1 cb a1 in + FStarC_Compiler_Util.bind_opt + uu___14 + (fun a15 -> + let uu___15 = + FStarC_TypeChecker_NBETerm.unembed + e2 cb a2 in + FStarC_Compiler_Util.bind_opt + uu___15 + (fun a21 -> + let uu___16 = + FStarC_TypeChecker_NBETerm.unembed + e3 cb a3 in + FStarC_Compiler_Util.bind_opt + uu___16 + (fun a31 -> + let uu___17 = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a41 -> + let uu___18 + = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___18 + ( + fun a51 + -> + let uu___19 + = + FStarC_TypeChecker_NBETerm.unembed + e6 cb a6 in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a61 + -> + let uu___20 + = + FStarC_TypeChecker_NBETerm.unembed + e7 cb a7 in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a71 + -> + let uu___21 + = + FStarC_TypeChecker_NBETerm.unembed + e8 cb a8 in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a81 + -> + let uu___22 + = + FStarC_TypeChecker_NBETerm.unembed + e9 cb a9 in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a91 + -> + let uu___23 + = + FStarC_TypeChecker_NBETerm.unembed + e10 cb + a10 in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a101 + -> + let uu___24 + = + FStarC_TypeChecker_NBETerm.unembed + e11 cb + a11 in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a111 + -> + let uu___25 + = + FStarC_TypeChecker_NBETerm.unembed + e12 cb + a12 in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a121 + -> + let uu___26 + = + FStarC_TypeChecker_NBETerm.unembed + e13 cb + a13 in + FStarC_Compiler_Util.bind_opt + uu___26 + (fun a131 + -> + let uu___27 + = + FStarC_TypeChecker_NBETerm.unembed + e14 cb + a14 in + FStarC_Compiler_Util.bind_opt + uu___27 + (fun a141 + -> + let r1 = + interp_ctx + name + (fun + uu___28 + -> + f a15 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 + a111 a121 + a131 a141) in + let uu___28 + = + FStarC_TypeChecker_NBETerm.embed + er cb r1 in + FStar_Pervasives_Native.Some + uu___28)))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_total_nbe_interpretation_15 : + 'r 't1 't10 't11 't12 't13 't14 't15 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> + 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 'r) + -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 't6 FStarC_TypeChecker_NBETerm.embedding -> + 't7 FStarC_TypeChecker_NBETerm.embedding -> + 't8 FStarC_TypeChecker_NBETerm.embedding -> + 't9 FStarC_TypeChecker_NBETerm.embedding -> + 't10 FStarC_TypeChecker_NBETerm.embedding -> + 't11 FStarC_TypeChecker_NBETerm.embedding -> + 't12 FStarC_TypeChecker_NBETerm.embedding -> + 't13 FStarC_TypeChecker_NBETerm.embedding + -> + 't14 FStarC_TypeChecker_NBETerm.embedding + -> + 't15 + FStarC_TypeChecker_NBETerm.embedding + -> + 'r + FStarC_TypeChecker_NBETerm.embedding + -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args + -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun e14 -> + fun e15 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1):: + (a3, uu___2)::(a4, uu___3):: + (a5, uu___4)::(a6, uu___5):: + (a7, uu___6)::(a8, uu___7):: + (a9, uu___8)::(a10, uu___9):: + (a11, uu___10)::(a12, + uu___11):: + (a13, uu___12)::(a14, + uu___13):: + (a15, uu___14)::[] -> + let uu___15 = + FStarC_TypeChecker_NBETerm.unembed + e1 cb a1 in + FStarC_Compiler_Util.bind_opt + uu___15 + (fun a16 -> + let uu___16 = + FStarC_TypeChecker_NBETerm.unembed + e2 cb a2 in + FStarC_Compiler_Util.bind_opt + uu___16 + (fun a21 -> + let uu___17 = + FStarC_TypeChecker_NBETerm.unembed + e3 cb a3 in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a31 -> + let uu___18 = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a41 -> + let uu___19 + = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a51 + -> + let uu___20 + = + FStarC_TypeChecker_NBETerm.unembed + e6 cb a6 in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a61 + -> + let uu___21 + = + FStarC_TypeChecker_NBETerm.unembed + e7 cb a7 in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a71 + -> + let uu___22 + = + FStarC_TypeChecker_NBETerm.unembed + e8 cb a8 in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a81 + -> + let uu___23 + = + FStarC_TypeChecker_NBETerm.unembed + e9 cb a9 in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a91 + -> + let uu___24 + = + FStarC_TypeChecker_NBETerm.unembed + e10 cb + a10 in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a101 + -> + let uu___25 + = + FStarC_TypeChecker_NBETerm.unembed + e11 cb + a11 in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a111 + -> + let uu___26 + = + FStarC_TypeChecker_NBETerm.unembed + e12 cb + a12 in + FStarC_Compiler_Util.bind_opt + uu___26 + (fun a121 + -> + let uu___27 + = + FStarC_TypeChecker_NBETerm.unembed + e13 cb + a13 in + FStarC_Compiler_Util.bind_opt + uu___27 + (fun a131 + -> + let uu___28 + = + FStarC_TypeChecker_NBETerm.unembed + e14 cb + a14 in + FStarC_Compiler_Util.bind_opt + uu___28 + (fun a141 + -> + let uu___29 + = + FStarC_TypeChecker_NBETerm.unembed + e15 cb + a15 in + FStarC_Compiler_Util.bind_opt + uu___29 + (fun a151 + -> + let r1 = + interp_ctx + name + (fun + uu___30 + -> + f a16 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 + a111 a121 + a131 a141 + a151) in + let uu___30 + = + FStarC_TypeChecker_NBETerm.embed + er cb r1 in + FStar_Pervasives_Native.Some + uu___30))))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_total_nbe_interpretation_16 : + 'r 't1 't10 't11 't12 't13 't14 't15 't16 't2 't3 't4 't5 't6 't7 't8 't9 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> + 't10 -> + 't11 -> + 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 'r) + -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 't6 FStarC_TypeChecker_NBETerm.embedding -> + 't7 FStarC_TypeChecker_NBETerm.embedding -> + 't8 FStarC_TypeChecker_NBETerm.embedding -> + 't9 FStarC_TypeChecker_NBETerm.embedding -> + 't10 FStarC_TypeChecker_NBETerm.embedding -> + 't11 FStarC_TypeChecker_NBETerm.embedding -> + 't12 FStarC_TypeChecker_NBETerm.embedding -> + 't13 FStarC_TypeChecker_NBETerm.embedding + -> + 't14 FStarC_TypeChecker_NBETerm.embedding + -> + 't15 + FStarC_TypeChecker_NBETerm.embedding + -> + 't16 + FStarC_TypeChecker_NBETerm.embedding + -> + 'r + FStarC_TypeChecker_NBETerm.embedding + -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args + -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun e14 -> + fun e15 -> + fun e16 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1):: + (a3, uu___2)::(a4, uu___3):: + (a5, uu___4)::(a6, uu___5):: + (a7, uu___6)::(a8, uu___7):: + (a9, uu___8)::(a10, uu___9):: + (a11, uu___10)::(a12, + uu___11):: + (a13, uu___12)::(a14, + uu___13):: + (a15, uu___14)::(a16, + uu___15)::[] + -> + let uu___16 = + FStarC_TypeChecker_NBETerm.unembed + e1 cb a1 in + FStarC_Compiler_Util.bind_opt + uu___16 + (fun a17 -> + let uu___17 = + FStarC_TypeChecker_NBETerm.unembed + e2 cb a2 in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a21 -> + let uu___18 = + FStarC_TypeChecker_NBETerm.unembed + e3 cb a3 in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a31 -> + let uu___19 + = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a41 + -> + let uu___20 + = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a51 + -> + let uu___21 + = + FStarC_TypeChecker_NBETerm.unembed + e6 cb a6 in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a61 + -> + let uu___22 + = + FStarC_TypeChecker_NBETerm.unembed + e7 cb a7 in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a71 + -> + let uu___23 + = + FStarC_TypeChecker_NBETerm.unembed + e8 cb a8 in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a81 + -> + let uu___24 + = + FStarC_TypeChecker_NBETerm.unembed + e9 cb a9 in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a91 + -> + let uu___25 + = + FStarC_TypeChecker_NBETerm.unembed + e10 cb + a10 in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a101 + -> + let uu___26 + = + FStarC_TypeChecker_NBETerm.unembed + e11 cb + a11 in + FStarC_Compiler_Util.bind_opt + uu___26 + (fun a111 + -> + let uu___27 + = + FStarC_TypeChecker_NBETerm.unembed + e12 cb + a12 in + FStarC_Compiler_Util.bind_opt + uu___27 + (fun a121 + -> + let uu___28 + = + FStarC_TypeChecker_NBETerm.unembed + e13 cb + a13 in + FStarC_Compiler_Util.bind_opt + uu___28 + (fun a131 + -> + let uu___29 + = + FStarC_TypeChecker_NBETerm.unembed + e14 cb + a14 in + FStarC_Compiler_Util.bind_opt + uu___29 + (fun a141 + -> + let uu___30 + = + FStarC_TypeChecker_NBETerm.unembed + e15 cb + a15 in + FStarC_Compiler_Util.bind_opt + uu___30 + (fun a151 + -> + let uu___31 + = + FStarC_TypeChecker_NBETerm.unembed + e16 cb + a16 in + FStarC_Compiler_Util.bind_opt + uu___31 + (fun a161 + -> + let r1 = + interp_ctx + name + (fun + uu___32 + -> + f a17 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 + a111 a121 + a131 a141 + a151 a161) in + let uu___32 + = + FStarC_TypeChecker_NBETerm.embed + er cb r1 in + FStar_Pervasives_Native.Some + uu___32)))))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_total_nbe_interpretation_17 : + 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't2 't3 't4 't5 't6 't7 't8 + 't9 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> + 't10 -> + 't11 -> + 't12 -> + 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 'r) + -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 't6 FStarC_TypeChecker_NBETerm.embedding -> + 't7 FStarC_TypeChecker_NBETerm.embedding -> + 't8 FStarC_TypeChecker_NBETerm.embedding -> + 't9 FStarC_TypeChecker_NBETerm.embedding -> + 't10 FStarC_TypeChecker_NBETerm.embedding -> + 't11 FStarC_TypeChecker_NBETerm.embedding -> + 't12 FStarC_TypeChecker_NBETerm.embedding -> + 't13 FStarC_TypeChecker_NBETerm.embedding + -> + 't14 FStarC_TypeChecker_NBETerm.embedding + -> + 't15 + FStarC_TypeChecker_NBETerm.embedding + -> + 't16 + FStarC_TypeChecker_NBETerm.embedding + -> + 't17 + FStarC_TypeChecker_NBETerm.embedding + -> + 'r + FStarC_TypeChecker_NBETerm.embedding + -> + FStarC_Syntax_Syntax.universes + -> + FStarC_TypeChecker_NBETerm.args + -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun e14 -> + fun e15 -> + fun e16 -> + fun e17 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1):: + (a3, uu___2)::(a4, + uu___3):: + (a5, uu___4)::(a6, + uu___5):: + (a7, uu___6)::(a8, + uu___7):: + (a9, uu___8)::(a10, + uu___9):: + (a11, uu___10)::(a12, + uu___11):: + (a13, uu___12)::(a14, + uu___13):: + (a15, uu___14)::(a16, + uu___15):: + (a17, uu___16)::[] -> + let uu___17 = + FStarC_TypeChecker_NBETerm.unembed + e1 cb a1 in + FStarC_Compiler_Util.bind_opt + uu___17 + (fun a18 -> + let uu___18 = + FStarC_TypeChecker_NBETerm.unembed + e2 cb a2 in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a21 -> + let uu___19 = + FStarC_TypeChecker_NBETerm.unembed + e3 cb a3 in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a31 -> + let uu___20 + = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a41 + -> + let uu___21 + = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a51 + -> + let uu___22 + = + FStarC_TypeChecker_NBETerm.unembed + e6 cb a6 in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a61 + -> + let uu___23 + = + FStarC_TypeChecker_NBETerm.unembed + e7 cb a7 in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a71 + -> + let uu___24 + = + FStarC_TypeChecker_NBETerm.unembed + e8 cb a8 in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a81 + -> + let uu___25 + = + FStarC_TypeChecker_NBETerm.unembed + e9 cb a9 in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a91 + -> + let uu___26 + = + FStarC_TypeChecker_NBETerm.unembed + e10 cb + a10 in + FStarC_Compiler_Util.bind_opt + uu___26 + (fun a101 + -> + let uu___27 + = + FStarC_TypeChecker_NBETerm.unembed + e11 cb + a11 in + FStarC_Compiler_Util.bind_opt + uu___27 + (fun a111 + -> + let uu___28 + = + FStarC_TypeChecker_NBETerm.unembed + e12 cb + a12 in + FStarC_Compiler_Util.bind_opt + uu___28 + (fun a121 + -> + let uu___29 + = + FStarC_TypeChecker_NBETerm.unembed + e13 cb + a13 in + FStarC_Compiler_Util.bind_opt + uu___29 + (fun a131 + -> + let uu___30 + = + FStarC_TypeChecker_NBETerm.unembed + e14 cb + a14 in + FStarC_Compiler_Util.bind_opt + uu___30 + (fun a141 + -> + let uu___31 + = + FStarC_TypeChecker_NBETerm.unembed + e15 cb + a15 in + FStarC_Compiler_Util.bind_opt + uu___31 + (fun a151 + -> + let uu___32 + = + FStarC_TypeChecker_NBETerm.unembed + e16 cb + a16 in + FStarC_Compiler_Util.bind_opt + uu___32 + (fun a161 + -> + let uu___33 + = + FStarC_TypeChecker_NBETerm.unembed + e17 cb + a17 in + FStarC_Compiler_Util.bind_opt + uu___33 + (fun a171 + -> + let r1 = + interp_ctx + name + (fun + uu___34 + -> + f a18 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 + a111 a121 + a131 a141 + a151 a161 + a171) in + let uu___34 + = + FStarC_TypeChecker_NBETerm.embed + er cb r1 in + FStar_Pervasives_Native.Some + uu___34))))))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_total_nbe_interpretation_18 : + 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't18 't2 't3 't4 't5 't6 't7 + 't8 't9 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> + 't10 -> + 't11 -> + 't12 -> + 't13 -> + 't14 -> 't15 -> 't16 -> 't17 -> 't18 -> 'r) + -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 't6 FStarC_TypeChecker_NBETerm.embedding -> + 't7 FStarC_TypeChecker_NBETerm.embedding -> + 't8 FStarC_TypeChecker_NBETerm.embedding -> + 't9 FStarC_TypeChecker_NBETerm.embedding -> + 't10 FStarC_TypeChecker_NBETerm.embedding -> + 't11 FStarC_TypeChecker_NBETerm.embedding -> + 't12 FStarC_TypeChecker_NBETerm.embedding -> + 't13 FStarC_TypeChecker_NBETerm.embedding + -> + 't14 FStarC_TypeChecker_NBETerm.embedding + -> + 't15 + FStarC_TypeChecker_NBETerm.embedding + -> + 't16 + FStarC_TypeChecker_NBETerm.embedding + -> + 't17 + FStarC_TypeChecker_NBETerm.embedding + -> + 't18 + FStarC_TypeChecker_NBETerm.embedding + -> + 'r + FStarC_TypeChecker_NBETerm.embedding + -> + FStarC_Syntax_Syntax.universes + -> + FStarC_TypeChecker_NBETerm.args + -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun e14 -> + fun e15 -> + fun e16 -> + fun e17 -> + fun e18 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, uu___1):: + (a3, uu___2)::(a4, + uu___3):: + (a5, uu___4)::(a6, + uu___5):: + (a7, uu___6)::(a8, + uu___7):: + (a9, uu___8)::(a10, + uu___9):: + (a11, uu___10):: + (a12, uu___11):: + (a13, uu___12):: + (a14, uu___13):: + (a15, uu___14):: + (a16, uu___15):: + (a17, uu___16):: + (a18, uu___17)::[] -> + let uu___18 = + FStarC_TypeChecker_NBETerm.unembed + e1 cb a1 in + FStarC_Compiler_Util.bind_opt + uu___18 + (fun a19 -> + let uu___19 = + FStarC_TypeChecker_NBETerm.unembed + e2 cb a2 in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a21 -> + let uu___20 = + FStarC_TypeChecker_NBETerm.unembed + e3 cb a3 in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a31 -> + let uu___21 + = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a41 + -> + let uu___22 + = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a51 + -> + let uu___23 + = + FStarC_TypeChecker_NBETerm.unembed + e6 cb a6 in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a61 + -> + let uu___24 + = + FStarC_TypeChecker_NBETerm.unembed + e7 cb a7 in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a71 + -> + let uu___25 + = + FStarC_TypeChecker_NBETerm.unembed + e8 cb a8 in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a81 + -> + let uu___26 + = + FStarC_TypeChecker_NBETerm.unembed + e9 cb a9 in + FStarC_Compiler_Util.bind_opt + uu___26 + (fun a91 + -> + let uu___27 + = + FStarC_TypeChecker_NBETerm.unembed + e10 cb + a10 in + FStarC_Compiler_Util.bind_opt + uu___27 + (fun a101 + -> + let uu___28 + = + FStarC_TypeChecker_NBETerm.unembed + e11 cb + a11 in + FStarC_Compiler_Util.bind_opt + uu___28 + (fun a111 + -> + let uu___29 + = + FStarC_TypeChecker_NBETerm.unembed + e12 cb + a12 in + FStarC_Compiler_Util.bind_opt + uu___29 + (fun a121 + -> + let uu___30 + = + FStarC_TypeChecker_NBETerm.unembed + e13 cb + a13 in + FStarC_Compiler_Util.bind_opt + uu___30 + (fun a131 + -> + let uu___31 + = + FStarC_TypeChecker_NBETerm.unembed + e14 cb + a14 in + FStarC_Compiler_Util.bind_opt + uu___31 + (fun a141 + -> + let uu___32 + = + FStarC_TypeChecker_NBETerm.unembed + e15 cb + a15 in + FStarC_Compiler_Util.bind_opt + uu___32 + (fun a151 + -> + let uu___33 + = + FStarC_TypeChecker_NBETerm.unembed + e16 cb + a16 in + FStarC_Compiler_Util.bind_opt + uu___33 + (fun a161 + -> + let uu___34 + = + FStarC_TypeChecker_NBETerm.unembed + e17 cb + a17 in + FStarC_Compiler_Util.bind_opt + uu___34 + (fun a171 + -> + let uu___35 + = + FStarC_TypeChecker_NBETerm.unembed + e18 cb + a18 in + FStarC_Compiler_Util.bind_opt + uu___35 + (fun a181 + -> + let r1 = + interp_ctx + name + (fun + uu___36 + -> + f a19 a21 + a31 a41 + a51 a61 + a71 a81 + a91 a101 + a111 a121 + a131 a141 + a151 a161 + a171 a181) in + let uu___36 + = + FStarC_TypeChecker_NBETerm.embed + er cb r1 in + FStar_Pervasives_Native.Some + uu___36)))))))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_total_nbe_interpretation_19 : + 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't18 't19 't2 't3 't4 't5 + 't6 't7 't8 't9 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> + 't10 -> + 't11 -> + 't12 -> + 't13 -> + 't14 -> + 't15 -> + 't16 -> 't17 -> 't18 -> 't19 -> 'r) + -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 't6 FStarC_TypeChecker_NBETerm.embedding -> + 't7 FStarC_TypeChecker_NBETerm.embedding -> + 't8 FStarC_TypeChecker_NBETerm.embedding -> + 't9 FStarC_TypeChecker_NBETerm.embedding -> + 't10 FStarC_TypeChecker_NBETerm.embedding -> + 't11 FStarC_TypeChecker_NBETerm.embedding -> + 't12 FStarC_TypeChecker_NBETerm.embedding -> + 't13 FStarC_TypeChecker_NBETerm.embedding + -> + 't14 FStarC_TypeChecker_NBETerm.embedding + -> + 't15 + FStarC_TypeChecker_NBETerm.embedding + -> + 't16 + FStarC_TypeChecker_NBETerm.embedding + -> + 't17 + FStarC_TypeChecker_NBETerm.embedding + -> + 't18 + FStarC_TypeChecker_NBETerm.embedding + -> + 't19 + FStarC_TypeChecker_NBETerm.embedding + -> + 'r + FStarC_TypeChecker_NBETerm.embedding + -> + FStarC_Syntax_Syntax.universes + -> + FStarC_TypeChecker_NBETerm.args + -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun e14 -> + fun e15 -> + fun e16 -> + fun e17 -> + fun e18 -> + fun e19 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___)::(a2, + uu___1):: + (a3, uu___2):: + (a4, uu___3):: + (a5, uu___4):: + (a6, uu___5):: + (a7, uu___6):: + (a8, uu___7):: + (a9, uu___8):: + (a10, uu___9):: + (a11, uu___10):: + (a12, uu___11):: + (a13, uu___12):: + (a14, uu___13):: + (a15, uu___14):: + (a16, uu___15):: + (a17, uu___16):: + (a18, uu___17):: + (a19, uu___18)::[] -> + let uu___19 = + FStarC_TypeChecker_NBETerm.unembed + e1 cb a1 in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun a110 -> + let uu___20 = + FStarC_TypeChecker_NBETerm.unembed + e2 cb a2 in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a21 -> + let uu___21 + = + FStarC_TypeChecker_NBETerm.unembed + e3 cb a3 in + FStarC_Compiler_Util.bind_opt + uu___21 + ( + fun a31 + -> + let uu___22 + = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a41 + -> + let uu___23 + = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a51 + -> + let uu___24 + = + FStarC_TypeChecker_NBETerm.unembed + e6 cb a6 in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a61 + -> + let uu___25 + = + FStarC_TypeChecker_NBETerm.unembed + e7 cb a7 in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a71 + -> + let uu___26 + = + FStarC_TypeChecker_NBETerm.unembed + e8 cb a8 in + FStarC_Compiler_Util.bind_opt + uu___26 + (fun a81 + -> + let uu___27 + = + FStarC_TypeChecker_NBETerm.unembed + e9 cb a9 in + FStarC_Compiler_Util.bind_opt + uu___27 + (fun a91 + -> + let uu___28 + = + FStarC_TypeChecker_NBETerm.unembed + e10 cb + a10 in + FStarC_Compiler_Util.bind_opt + uu___28 + (fun a101 + -> + let uu___29 + = + FStarC_TypeChecker_NBETerm.unembed + e11 cb + a11 in + FStarC_Compiler_Util.bind_opt + uu___29 + (fun a111 + -> + let uu___30 + = + FStarC_TypeChecker_NBETerm.unembed + e12 cb + a12 in + FStarC_Compiler_Util.bind_opt + uu___30 + (fun a121 + -> + let uu___31 + = + FStarC_TypeChecker_NBETerm.unembed + e13 cb + a13 in + FStarC_Compiler_Util.bind_opt + uu___31 + (fun a131 + -> + let uu___32 + = + FStarC_TypeChecker_NBETerm.unembed + e14 cb + a14 in + FStarC_Compiler_Util.bind_opt + uu___32 + (fun a141 + -> + let uu___33 + = + FStarC_TypeChecker_NBETerm.unembed + e15 cb + a15 in + FStarC_Compiler_Util.bind_opt + uu___33 + (fun a151 + -> + let uu___34 + = + FStarC_TypeChecker_NBETerm.unembed + e16 cb + a16 in + FStarC_Compiler_Util.bind_opt + uu___34 + (fun a161 + -> + let uu___35 + = + FStarC_TypeChecker_NBETerm.unembed + e17 cb + a17 in + FStarC_Compiler_Util.bind_opt + uu___35 + (fun a171 + -> + let uu___36 + = + FStarC_TypeChecker_NBETerm.unembed + e18 cb + a18 in + FStarC_Compiler_Util.bind_opt + uu___36 + (fun a181 + -> + let uu___37 + = + FStarC_TypeChecker_NBETerm.unembed + e19 cb + a19 in + FStarC_Compiler_Util.bind_opt + uu___37 + (fun a191 + -> + let r1 = + interp_ctx + name + (fun + uu___38 + -> + f a110 + a21 a31 + a41 a51 + a61 a71 + a81 a91 + a101 a111 + a121 a131 + a141 a151 + a161 a171 + a181 a191) in + let uu___38 + = + FStarC_TypeChecker_NBETerm.embed + er cb r1 in + FStar_Pervasives_Native.Some + uu___38))))))))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None +let mk_total_nbe_interpretation_20 : + 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't18 't19 't2 't20 't3 't4 + 't5 't6 't7 't8 't9 . + Prims.string -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + ('t1 -> + 't2 -> + 't3 -> + 't4 -> + 't5 -> + 't6 -> + 't7 -> + 't8 -> + 't9 -> + 't10 -> + 't11 -> + 't12 -> + 't13 -> + 't14 -> + 't15 -> + 't16 -> + 't17 -> 't18 -> 't19 -> 't20 -> 'r) + -> + 't1 FStarC_TypeChecker_NBETerm.embedding -> + 't2 FStarC_TypeChecker_NBETerm.embedding -> + 't3 FStarC_TypeChecker_NBETerm.embedding -> + 't4 FStarC_TypeChecker_NBETerm.embedding -> + 't5 FStarC_TypeChecker_NBETerm.embedding -> + 't6 FStarC_TypeChecker_NBETerm.embedding -> + 't7 FStarC_TypeChecker_NBETerm.embedding -> + 't8 FStarC_TypeChecker_NBETerm.embedding -> + 't9 FStarC_TypeChecker_NBETerm.embedding -> + 't10 FStarC_TypeChecker_NBETerm.embedding -> + 't11 FStarC_TypeChecker_NBETerm.embedding -> + 't12 FStarC_TypeChecker_NBETerm.embedding -> + 't13 FStarC_TypeChecker_NBETerm.embedding + -> + 't14 FStarC_TypeChecker_NBETerm.embedding + -> + 't15 + FStarC_TypeChecker_NBETerm.embedding + -> + 't16 + FStarC_TypeChecker_NBETerm.embedding + -> + 't17 + FStarC_TypeChecker_NBETerm.embedding + -> + 't18 + FStarC_TypeChecker_NBETerm.embedding + -> + 't19 + FStarC_TypeChecker_NBETerm.embedding + -> + 't20 + FStarC_TypeChecker_NBETerm.embedding + -> + 'r + FStarC_TypeChecker_NBETerm.embedding + -> + FStarC_Syntax_Syntax.universes + -> + FStarC_TypeChecker_NBETerm.args + -> + FStarC_TypeChecker_NBETerm.t + FStar_Pervasives_Native.option + = + fun name -> + fun cb -> + fun f -> + fun e1 -> + fun e2 -> + fun e3 -> + fun e4 -> + fun e5 -> + fun e6 -> + fun e7 -> + fun e8 -> + fun e9 -> + fun e10 -> + fun e11 -> + fun e12 -> + fun e13 -> + fun e14 -> + fun e15 -> + fun e16 -> + fun e17 -> + fun e18 -> + fun e19 -> + fun e20 -> + fun er -> + fun us -> + fun args -> + match args with + | (a1, uu___):: + (a2, uu___1):: + (a3, uu___2):: + (a4, uu___3):: + (a5, uu___4):: + (a6, uu___5):: + (a7, uu___6):: + (a8, uu___7):: + (a9, uu___8):: + (a10, uu___9):: + (a11, uu___10):: + (a12, uu___11):: + (a13, uu___12):: + (a14, uu___13):: + (a15, uu___14):: + (a16, uu___15):: + (a17, uu___16):: + (a18, uu___17):: + (a19, uu___18):: + (a20, uu___19)::[] + -> + let uu___20 = + FStarC_TypeChecker_NBETerm.unembed + e1 cb a1 in + FStarC_Compiler_Util.bind_opt + uu___20 + (fun a110 -> + let uu___21 = + FStarC_TypeChecker_NBETerm.unembed + e2 cb a2 in + FStarC_Compiler_Util.bind_opt + uu___21 + (fun a21 -> + let uu___22 + = + FStarC_TypeChecker_NBETerm.unembed + e3 cb a3 in + FStarC_Compiler_Util.bind_opt + uu___22 + (fun a31 + -> + let uu___23 + = + FStarC_TypeChecker_NBETerm.unembed + e4 cb a4 in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun a41 + -> + let uu___24 + = + FStarC_TypeChecker_NBETerm.unembed + e5 cb a5 in + FStarC_Compiler_Util.bind_opt + uu___24 + (fun a51 + -> + let uu___25 + = + FStarC_TypeChecker_NBETerm.unembed + e6 cb a6 in + FStarC_Compiler_Util.bind_opt + uu___25 + (fun a61 + -> + let uu___26 + = + FStarC_TypeChecker_NBETerm.unembed + e7 cb a7 in + FStarC_Compiler_Util.bind_opt + uu___26 + (fun a71 + -> + let uu___27 + = + FStarC_TypeChecker_NBETerm.unembed + e8 cb a8 in + FStarC_Compiler_Util.bind_opt + uu___27 + (fun a81 + -> + let uu___28 + = + FStarC_TypeChecker_NBETerm.unembed + e9 cb a9 in + FStarC_Compiler_Util.bind_opt + uu___28 + (fun a91 + -> + let uu___29 + = + FStarC_TypeChecker_NBETerm.unembed + e10 cb + a10 in + FStarC_Compiler_Util.bind_opt + uu___29 + (fun a101 + -> + let uu___30 + = + FStarC_TypeChecker_NBETerm.unembed + e11 cb + a11 in + FStarC_Compiler_Util.bind_opt + uu___30 + (fun a111 + -> + let uu___31 + = + FStarC_TypeChecker_NBETerm.unembed + e12 cb + a12 in + FStarC_Compiler_Util.bind_opt + uu___31 + (fun a121 + -> + let uu___32 + = + FStarC_TypeChecker_NBETerm.unembed + e13 cb + a13 in + FStarC_Compiler_Util.bind_opt + uu___32 + (fun a131 + -> + let uu___33 + = + FStarC_TypeChecker_NBETerm.unembed + e14 cb + a14 in + FStarC_Compiler_Util.bind_opt + uu___33 + (fun a141 + -> + let uu___34 + = + FStarC_TypeChecker_NBETerm.unembed + e15 cb + a15 in + FStarC_Compiler_Util.bind_opt + uu___34 + (fun a151 + -> + let uu___35 + = + FStarC_TypeChecker_NBETerm.unembed + e16 cb + a16 in + FStarC_Compiler_Util.bind_opt + uu___35 + (fun a161 + -> + let uu___36 + = + FStarC_TypeChecker_NBETerm.unembed + e17 cb + a17 in + FStarC_Compiler_Util.bind_opt + uu___36 + (fun a171 + -> + let uu___37 + = + FStarC_TypeChecker_NBETerm.unembed + e18 cb + a18 in + FStarC_Compiler_Util.bind_opt + uu___37 + (fun a181 + -> + let uu___38 + = + FStarC_TypeChecker_NBETerm.unembed + e19 cb + a19 in + FStarC_Compiler_Util.bind_opt + uu___38 + (fun a191 + -> + let uu___39 + = + FStarC_TypeChecker_NBETerm.unembed + e20 cb + a20 in + FStarC_Compiler_Util.bind_opt + uu___39 + (fun a201 + -> + let r1 = + interp_ctx + name + (fun + uu___40 + -> + f a110 + a21 a31 + a41 a51 + a61 a71 + a81 a91 + a101 a111 + a121 a131 + a141 a151 + a161 a171 + a181 a191 + a201) in + let uu___40 + = + FStarC_TypeChecker_NBETerm.embed + er cb r1 in + FStar_Pervasives_Native.Some + uu___40)))))))))))))))))))) + | uu___ -> + FStar_Pervasives_Native.None \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Tactics_Interpreter.ml b/ocaml/fstar-lib/generated/FStarC_Tactics_Interpreter.ml new file mode 100644 index 00000000000..16b9d9a7507 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Tactics_Interpreter.ml @@ -0,0 +1,1242 @@ +open Prims +let (dbg_Tac : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Tac" +let solve : 'a . 'a -> 'a = fun ev -> ev +let embed : + 'a . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_Compiler_Range_Type.range -> + 'a -> + FStarC_Syntax_Embeddings_Base.norm_cb -> FStarC_Syntax_Syntax.term + = + fun uu___ -> + fun r -> + fun x -> + fun norm_cb -> + let uu___1 = FStarC_Syntax_Embeddings_Base.embed uu___ x in + uu___1 r FStar_Pervasives_Native.None norm_cb +let unembed : + 'a . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + 'a FStar_Pervasives_Native.option + = + fun uu___ -> + fun a1 -> + fun norm_cb -> FStarC_Syntax_Embeddings_Base.unembed uu___ a1 norm_cb +let (native_tactics_steps : + unit -> FStarC_TypeChecker_Primops_Base.primitive_step Prims.list) = + fun uu___ -> + let step_from_native_step s = + { + FStarC_TypeChecker_Primops_Base.name = (s.FStarC_Tactics_Native.name); + FStarC_TypeChecker_Primops_Base.arity = + (s.FStarC_Tactics_Native.arity); + FStarC_TypeChecker_Primops_Base.univ_arity = Prims.int_zero; + FStarC_TypeChecker_Primops_Base.auto_reflect = + (FStar_Pervasives_Native.Some + (s.FStarC_Tactics_Native.arity - Prims.int_one)); + FStarC_TypeChecker_Primops_Base.strong_reduction_ok = + (s.FStarC_Tactics_Native.strong_reduction_ok); + FStarC_TypeChecker_Primops_Base.requires_binder_substitution = false; + FStarC_TypeChecker_Primops_Base.renorm_after = false; + FStarC_TypeChecker_Primops_Base.interpretation = + (s.FStarC_Tactics_Native.tactic); + FStarC_TypeChecker_Primops_Base.interpretation_nbe = + (fun _cb -> + fun _us -> + FStarC_TypeChecker_NBETerm.dummy_interp + s.FStarC_Tactics_Native.name) + } in + let uu___1 = FStarC_Tactics_Native.list_all () in + FStarC_Compiler_List.map step_from_native_step uu___1 +let (__primitive_steps_ref : + FStarC_TypeChecker_Primops_Base.primitive_step Prims.list + FStarC_Compiler_Effect.ref) + = FStarC_Compiler_Util.mk_ref [] +let (primitive_steps : + unit -> FStarC_TypeChecker_Primops_Base.primitive_step Prims.list) = + fun uu___ -> + let uu___1 = native_tactics_steps () in + let uu___2 = FStarC_Compiler_Effect.op_Bang __primitive_steps_ref in + FStarC_Compiler_List.op_At uu___1 uu___2 +let (register_tactic_primitive_step : + FStarC_TypeChecker_Primops_Base.primitive_step -> unit) = + fun s -> + let uu___ = + let uu___1 = FStarC_Compiler_Effect.op_Bang __primitive_steps_ref in s + :: uu___1 in + FStarC_Compiler_Effect.op_Colon_Equals __primitive_steps_ref uu___ +let rec (t_head_of : FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_app uu___1 -> + let uu___2 = FStarC_Syntax_Util.head_and_args_full t in + (match uu___2 with + | (h, args) -> + let h1 = FStarC_Syntax_Util.unmeta h in + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.compress h1 in + uu___4.FStarC_Syntax_Syntax.n in + (match uu___3 with + | FStarC_Syntax_Syntax.Tm_uinst uu___4 -> t + | FStarC_Syntax_Syntax.Tm_fvar uu___4 -> t + | FStarC_Syntax_Syntax.Tm_bvar uu___4 -> t + | FStarC_Syntax_Syntax.Tm_name uu___4 -> t + | FStarC_Syntax_Syntax.Tm_constant uu___4 -> t + | uu___4 -> t_head_of h1)) + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = t1; + FStarC_Syntax_Syntax.ret_opt = uu___1; + FStarC_Syntax_Syntax.brs = uu___2; + FStarC_Syntax_Syntax.rc_opt1 = uu___3;_} + -> t_head_of t1 + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t1; FStarC_Syntax_Syntax.asc = uu___1; + FStarC_Syntax_Syntax.eff_opt = uu___2;_} + -> t_head_of t1 + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t1; + FStarC_Syntax_Syntax.meta = uu___1;_} + -> t_head_of t1 + | uu___1 -> t +let unembed_tactic_0 : + 'b . + 'b FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Embeddings_Base.norm_cb -> 'b FStarC_Tactics_Monad.tac + = + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun eb -> + fun embedded_tac_b -> + fun ncb -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___ -> + (fun proof_state -> + let proof_state = Obj.magic proof_state in + let rng = embedded_tac_b.FStarC_Syntax_Syntax.pos in + let embedded_tac_b1 = + FStarC_Syntax_Util.mk_reify embedded_tac_b + (FStar_Pervasives_Native.Some + FStarC_Parser_Const.effect_TAC_lid) in + let tm = + let uu___ = + let uu___1 = + let uu___2 = + embed FStarC_Tactics_Embedding.e_proofstate + rng proof_state ncb in + FStarC_Syntax_Syntax.as_arg uu___2 in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app embedded_tac_b1 + uu___ rng in + let steps = + [FStarC_TypeChecker_Env.Weak; + FStarC_TypeChecker_Env.Reify; + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.DontUnfoldAttr + [FStarC_Parser_Const.tac_opaque_attr]; + FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.Unascribe; + FStarC_TypeChecker_Env.Tactics] in + let norm_f = + let uu___ = FStarC_Options.tactics_nbe () in + if uu___ + then FStarC_TypeChecker_NBE.normalize + else + FStarC_TypeChecker_Normalize.normalize_with_primitive_steps in + let result = + let uu___ = primitive_steps () in + norm_f uu___ steps + proof_state.FStarC_Tactics_Types.main_context + tm in + let res = + unembed (FStarC_Tactics_Embedding.e_result eb) + result ncb in + match res with + | FStar_Pervasives_Native.Some + (FStarC_Tactics_Result.Success (b1, ps)) -> + Obj.magic + (Obj.repr + (let uu___ = FStarC_Tactics_Monad.set ps in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () (Obj.magic b1))) uu___1))) + | FStar_Pervasives_Native.Some + (FStarC_Tactics_Result.Failed (e, ps)) -> + Obj.magic + (Obj.repr + (let uu___ = FStarC_Tactics_Monad.set ps in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + Obj.magic + (FStarC_Tactics_Monad.traise e)) + uu___1))) + | FStar_Pervasives_Native.None -> + Obj.magic + (Obj.repr + (let h_result = t_head_of result in + let maybe_admit_tip = + let r = + Obj.magic + (FStarC_Syntax_VisitM.visitM_term + FStarC_Class_Monad.monad_option + false + (fun uu___ -> + (fun t -> + match t.FStarC_Syntax_Syntax.n + with + | FStarC_Syntax_Syntax.Tm_fvar + fv when + FStarC_Syntax_Syntax.fv_eq_lid + fv + FStarC_Parser_Const.admit_lid + -> + Obj.magic + FStar_Pervasives_Native.None + | uu___ -> + Obj.magic + (FStar_Pervasives_Native.Some + t)) uu___) + h_result) in + if + FStar_Pervasives_Native.uu___is_None + r + then + FStarC_Pprint.doc_of_string + "The term contains an `admit`, which will not reduce. Did you mean `tadmit()`?" + else FStarC_Pprint.empty in + let uu___ = + let uu___1 = + FStarC_Pprint.doc_of_string + "Tactic got stuck!" in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Pprint.doc_of_string + "Reduction stopped at: " in + let uu___5 = + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_term + h_result in + FStarC_Pprint.op_Hat_Hat uu___4 + uu___5 in + [uu___3; maybe_admit_tip] in + uu___1 :: uu___2 in + FStarC_Errors.raise_error + FStarC_TypeChecker_Env.hasRange_env + proof_state.FStarC_Tactics_Types.main_context + FStarC_Errors_Codes.Fatal_TacticGotStuck + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___)))) uu___))) uu___2 + uu___1 uu___ +let unembed_tactic_nbe_0 : + 'b . + 'b FStarC_TypeChecker_NBETerm.embedding -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + FStarC_TypeChecker_NBETerm.t -> 'b FStarC_Tactics_Monad.tac + = + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun eb -> + fun cb -> + fun embedded_tac_b -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___ -> + (fun proof_state -> + let proof_state = Obj.magic proof_state in + let result = + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_NBETerm.embed + FStarC_Tactics_Embedding.e_proofstate_nbe + cb proof_state in + FStarC_TypeChecker_NBETerm.as_arg uu___2 in + [uu___1] in + FStarC_TypeChecker_NBETerm.iapp_cb cb + embedded_tac_b uu___ in + let res = + FStarC_TypeChecker_NBETerm.unembed + (FStarC_Tactics_Embedding.e_result_nbe eb) cb + result in + match res with + | FStar_Pervasives_Native.Some + (FStarC_Tactics_Result.Success (b1, ps)) -> + Obj.magic + (Obj.repr + (let uu___ = FStarC_Tactics_Monad.set ps in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () (Obj.magic b1))) uu___1))) + | FStar_Pervasives_Native.Some + (FStarC_Tactics_Result.Failed (e, ps)) -> + Obj.magic + (Obj.repr + (let uu___ = FStarC_Tactics_Monad.set ps in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + Obj.magic + (FStarC_Tactics_Monad.traise e)) + uu___1))) + | FStar_Pervasives_Native.None -> + Obj.magic + (Obj.repr + (let uu___ = + let uu___1 = + FStarC_Pprint.doc_of_string + "Tactic got stuck (in NBE)!" in + let uu___2 = + let uu___3 = + FStarC_Errors_Msg.text + "Please file a bug report with a minimal reproduction of this issue." in + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Pprint.doc_of_string + "Result = " in + let uu___7 = + let uu___8 = + FStarC_TypeChecker_NBETerm.t_to_string + result in + FStarC_Pprint.arbitrary_string + uu___8 in + FStarC_Pprint.op_Hat_Hat uu___6 + uu___7 in + [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Errors.raise_error + FStarC_TypeChecker_Env.hasRange_env + proof_state.FStarC_Tactics_Types.main_context + FStarC_Errors_Codes.Fatal_TacticGotStuck + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___)))) uu___))) uu___2 + uu___1 uu___ +let unembed_tactic_1 : + 'a 'r . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + 'a -> 'r FStarC_Tactics_Monad.tac + = + fun ea -> + fun er -> + fun f -> + fun ncb -> + fun x -> + let rng = FStarC_Compiler_Range_Type.dummyRange in + let x_tm = embed ea rng x ncb in + let app = + let uu___ = + let uu___1 = FStarC_Syntax_Syntax.as_arg x_tm in [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app f uu___ rng in + unembed_tactic_0 er app ncb +let unembed_tactic_nbe_1 : + 'a 'r . + 'a FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + FStarC_TypeChecker_NBETerm.nbe_cbs -> + FStarC_TypeChecker_NBETerm.t -> 'a -> 'r FStarC_Tactics_Monad.tac + = + fun ea -> + fun er -> + fun cb -> + fun f -> + fun x -> + let x_tm = FStarC_TypeChecker_NBETerm.embed ea cb x in + let app = + let uu___ = + let uu___1 = FStarC_TypeChecker_NBETerm.as_arg x_tm in + [uu___1] in + FStarC_TypeChecker_NBETerm.iapp_cb cb f uu___ in + unembed_tactic_nbe_0 er cb app +let e_tactic_thunk : + 'r . + 'r FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Tactics_Monad.tac FStarC_Syntax_Embeddings_Base.embedding + = + fun er -> + let uu___ = + FStarC_Syntax_Embeddings_Base.term_as_fv FStarC_Syntax_Syntax.t_unit in + FStarC_Syntax_Embeddings_Base.mk_emb + (fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun uu___4 -> failwith "Impossible: embedding tactic (thunk)?") + (fun t -> + fun cb -> + let uu___1 = + let uu___2 = + unembed_tactic_1 FStarC_Syntax_Embeddings.e_unit er t cb in + uu___2 () in + FStar_Pervasives_Native.Some uu___1) uu___ +let e_tactic_nbe_thunk : + 'r . + 'r FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_Tactics_Monad.tac FStarC_TypeChecker_NBETerm.embedding + = + fun er -> + FStarC_TypeChecker_NBETerm.mk_emb + (fun cb -> + fun uu___ -> failwith "Impossible: NBE embedding tactic (thunk)?") + (fun cb -> + fun t -> + let uu___ = + let uu___1 = + unembed_tactic_nbe_1 FStarC_TypeChecker_NBETerm.e_unit er cb t in + uu___1 () in + FStar_Pervasives_Native.Some uu___) + (fun uu___ -> + FStarC_TypeChecker_NBETerm.mk_t + (FStarC_TypeChecker_NBETerm.Constant + FStarC_TypeChecker_NBETerm.Unit)) + (FStarC_Syntax_Embeddings_Base.emb_typ_of + FStarC_Syntax_Embeddings.e_unit) +let e_tactic_1 : + 'a 'r . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + ('a -> 'r FStarC_Tactics_Monad.tac) + FStarC_Syntax_Embeddings_Base.embedding + = + fun ea -> + fun er -> + let uu___ = + FStarC_Syntax_Embeddings_Base.term_as_fv FStarC_Syntax_Syntax.t_unit in + FStarC_Syntax_Embeddings_Base.mk_emb + (fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun uu___4 -> failwith "Impossible: embedding tactic (1)?") + (fun t -> + fun cb -> + let uu___1 = unembed_tactic_1 ea er t cb in + FStar_Pervasives_Native.Some uu___1) uu___ +let e_tactic_nbe_1 : + 'a 'r . + 'a FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + ('a -> 'r FStarC_Tactics_Monad.tac) + FStarC_TypeChecker_NBETerm.embedding + = + fun ea -> + fun er -> + FStarC_TypeChecker_NBETerm.mk_emb + (fun cb -> + fun uu___ -> failwith "Impossible: NBE embedding tactic (1)?") + (fun cb -> + fun t -> + let uu___ = unembed_tactic_nbe_1 ea er cb t in + FStar_Pervasives_Native.Some uu___) + (fun uu___ -> + FStarC_TypeChecker_NBETerm.mk_t + (FStarC_TypeChecker_NBETerm.Constant + FStarC_TypeChecker_NBETerm.Unit)) + (FStarC_Syntax_Embeddings_Base.emb_typ_of + FStarC_Syntax_Embeddings.e_unit) +let unembed_tactic_1_alt : + 'a 'r . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + ('a -> 'r FStarC_Tactics_Monad.tac) + FStar_Pervasives_Native.option + = + fun ea -> + fun er -> + fun f -> + fun ncb -> + FStar_Pervasives_Native.Some + (fun x -> + let rng = FStarC_Compiler_Range_Type.dummyRange in + let x_tm = embed ea rng x ncb in + let app = + let uu___ = + let uu___1 = FStarC_Syntax_Syntax.as_arg x_tm in [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app f uu___ rng in + unembed_tactic_0 er app ncb) +let e_tactic_1_alt : + 'a 'r . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + ('a -> + FStarC_Tactics_Types.proofstate -> + 'r FStarC_Tactics_Result.__result) + FStarC_Syntax_Embeddings_Base.embedding + = + fun ea -> + fun er -> + let em uu___ uu___1 uu___2 uu___3 = + failwith "Impossible: embedding tactic (1)?" in + let un t0 n = + let uu___ = unembed_tactic_1_alt ea er t0 n in + match uu___ with + | FStar_Pervasives_Native.Some f -> + FStar_Pervasives_Native.Some + ((fun x -> let uu___1 = f x in FStarC_Tactics_Monad.run uu___1)) + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None in + let uu___ = + FStarC_Syntax_Embeddings_Base.term_as_fv FStarC_Syntax_Syntax.t_unit in + FStarC_Syntax_Embeddings_Base.mk_emb em un uu___ +let (report_implicits : + FStarC_Compiler_Range_Type.range -> + FStarC_TypeChecker_Rel.tagged_implicits -> unit) + = + fun rng -> + fun is -> + FStarC_Compiler_List.iter + (fun uu___1 -> + match uu___1 with + | (imp, tag) -> + (match tag with + | FStarC_TypeChecker_Rel.Implicit_unresolved -> + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Errors_Msg.text + "Tactic left uninstantiated unification variable:" in + let uu___5 = + FStarC_Class_PP.pp FStarC_Syntax_Print.pretty_uvar + (imp.FStarC_TypeChecker_Common.imp_uvar).FStarC_Syntax_Syntax.ctx_uvar_head in + FStarC_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Errors_Msg.text "Type:" in + let uu___7 = + let uu___8 = + FStarC_Syntax_Util.ctx_uvar_typ + imp.FStarC_TypeChecker_Common.imp_uvar in + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_term uu___8 in + FStarC_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Errors_Msg.text "Reason:" in + let uu___9 = + let uu___10 = + FStarC_Pprint.doc_of_string + imp.FStarC_TypeChecker_Common.imp_reason in + FStarC_Pprint.dquotes uu___10 in + FStarC_Pprint.op_Hat_Slash_Hat uu___8 uu___9 in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + FStarC_Errors.log_issue + FStarC_Class_HasRange.hasRange_range rng + FStarC_Errors_Codes.Error_UninstantiatedUnificationVarInTactic + () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___2) + | FStarC_TypeChecker_Rel.Implicit_checking_defers_univ_constraint + -> + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Errors_Msg.text + "Tactic left uninstantiated unification variable:" in + let uu___5 = + FStarC_Class_PP.pp FStarC_Syntax_Print.pretty_uvar + (imp.FStarC_TypeChecker_Common.imp_uvar).FStarC_Syntax_Syntax.ctx_uvar_head in + FStarC_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Errors_Msg.text "Type:" in + let uu___7 = + let uu___8 = + FStarC_Syntax_Util.ctx_uvar_typ + imp.FStarC_TypeChecker_Common.imp_uvar in + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_term uu___8 in + FStarC_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Errors_Msg.text "Reason:" in + let uu___9 = + let uu___10 = + FStarC_Pprint.doc_of_string + imp.FStarC_TypeChecker_Common.imp_reason in + FStarC_Pprint.dquotes uu___10 in + FStarC_Pprint.op_Hat_Slash_Hat uu___8 uu___9 in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + FStarC_Errors.log_issue + FStarC_Class_HasRange.hasRange_range rng + FStarC_Errors_Codes.Error_UninstantiatedUnificationVarInTactic + () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___2) + | FStarC_TypeChecker_Rel.Implicit_has_typing_guard (tm, ty) + -> + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Errors_Msg.text "Tactic solved goal:" in + let uu___5 = + FStarC_Class_PP.pp FStarC_Syntax_Print.pretty_uvar + (imp.FStarC_TypeChecker_Common.imp_uvar).FStarC_Syntax_Syntax.ctx_uvar_head in + FStarC_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Errors_Msg.text "Type:" in + let uu___7 = + let uu___8 = + FStarC_Syntax_Util.ctx_uvar_typ + imp.FStarC_TypeChecker_Common.imp_uvar in + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_term uu___8 in + FStarC_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Errors_Msg.text "To the term:" in + let uu___9 = + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_term tm in + FStarC_Pprint.op_Hat_Slash_Hat uu___8 uu___9 in + let uu___8 = + let uu___9 = + FStarC_Errors_Msg.text + "But it has a non-trivial typing guard. Use gather_or_solve_explicit_guards_for_resolved_goals to inspect and prove these goals" in + [uu___9] in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + FStarC_Errors.log_issue + FStarC_Class_HasRange.hasRange_range rng + FStarC_Errors_Codes.Error_UninstantiatedUnificationVarInTactic + () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___2))) is; + FStarC_Errors.stop_if_err () +let run_unembedded_tactic_on_ps : + 'a 'b . + FStarC_Compiler_Range_Type.range -> + FStarC_Compiler_Range_Type.range -> + Prims.bool -> + 'a -> + ('a -> 'b FStarC_Tactics_Monad.tac) -> + FStarC_Tactics_Types.proofstate -> + (FStarC_Tactics_Types.goal Prims.list * 'b) + = + fun rng_call -> + fun rng_goal -> + fun background -> + fun arg -> + fun tau -> + fun ps -> + let ps1 = + { + FStarC_Tactics_Types.main_context = + (let uu___ = ps.FStarC_Tactics_Types.main_context in + { + FStarC_TypeChecker_Env.solver = + (uu___.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (uu___.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (uu___.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (uu___.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (uu___.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (uu___.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (uu___.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (uu___.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (uu___.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (uu___.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (uu___.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (uu___.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (uu___.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (uu___.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (uu___.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (uu___.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (uu___.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (uu___.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (uu___.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (uu___.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (uu___.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (uu___.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (uu___.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (uu___.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = true; + FStarC_TypeChecker_Env.nocoerce = + (uu___.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (uu___.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (uu___.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (uu___.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (uu___.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (uu___.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (uu___.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (uu___.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (uu___.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (uu___.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (uu___.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (uu___.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (uu___.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (uu___.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (uu___.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (uu___.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (uu___.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (uu___.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (uu___.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (uu___.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (uu___.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (uu___.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (uu___.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (uu___.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (uu___.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (uu___.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (uu___.FStarC_TypeChecker_Env.missing_decl) + }); + FStarC_Tactics_Types.all_implicits = + (ps.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = + (ps.FStarC_Tactics_Types.goals); + FStarC_Tactics_Types.smt_goals = + (ps.FStarC_Tactics_Types.smt_goals); + FStarC_Tactics_Types.depth = + (ps.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = + (ps.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = (ps.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (ps.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = + (ps.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness = + (ps.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg = + (ps.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = + (ps.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency = + (ps.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure = + (ps.FStarC_Tactics_Types.dump_on_failure) + } in + let ps2 = + { + FStarC_Tactics_Types.main_context = + (let uu___ = ps1.FStarC_Tactics_Types.main_context in + { + FStarC_TypeChecker_Env.solver = + (uu___.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = rng_goal; + FStarC_TypeChecker_Env.curmodule = + (uu___.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (uu___.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (uu___.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (uu___.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (uu___.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (uu___.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (uu___.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (uu___.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (uu___.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (uu___.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (uu___.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (uu___.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (uu___.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (uu___.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (uu___.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (uu___.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (uu___.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (uu___.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (uu___.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (uu___.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (uu___.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (uu___.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (uu___.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (uu___.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (uu___.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (uu___.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (uu___.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (uu___.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (uu___.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (uu___.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (uu___.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (uu___.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (uu___.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (uu___.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (uu___.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (uu___.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (uu___.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (uu___.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (uu___.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (uu___.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (uu___.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (uu___.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (uu___.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (uu___.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (uu___.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (uu___.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (uu___.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (uu___.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (uu___.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (uu___.FStarC_TypeChecker_Env.missing_decl) + }); + FStarC_Tactics_Types.all_implicits = + (ps1.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = + (ps1.FStarC_Tactics_Types.goals); + FStarC_Tactics_Types.smt_goals = + (ps1.FStarC_Tactics_Types.smt_goals); + FStarC_Tactics_Types.depth = + (ps1.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = + (ps1.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = (ps1.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (ps1.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = + (ps1.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness = + (ps1.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg = + (ps1.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = + (ps1.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency = + (ps1.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure = + (ps1.FStarC_Tactics_Types.dump_on_failure) + } in + let env = ps2.FStarC_Tactics_Types.main_context in + let res = + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_Env.current_module + ps2.FStarC_Tactics_Types.main_context in + FStarC_Ident.string_of_lid uu___2 in + FStar_Pervasives_Native.Some uu___1 in + FStarC_Profiling.profile + (fun uu___1 -> + let uu___2 = tau arg in + FStarC_Tactics_Monad.run_safe uu___2 ps2) uu___ + "FStarC.Tactics.Interpreter.run_safe" in + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_Tac in + if uu___1 then FStarC_Compiler_Util.print_string "}\n" else ()); + (match res with + | FStarC_Tactics_Result.Success (ret, ps3) -> + ((let uu___2 = FStarC_Compiler_Effect.op_Bang dbg_Tac in + if uu___2 + then + FStarC_Tactics_Printing.do_dump_proofstate ps3 + "at the finish line" + else ()); + (let remaining_smt_goals = + FStarC_Compiler_List.op_At + ps3.FStarC_Tactics_Types.goals + ps3.FStarC_Tactics_Types.smt_goals in + FStarC_Compiler_List.iter + (fun g -> + FStarC_Tactics_Monad.mark_goal_implicit_already_checked + g; + (let uu___4 = FStarC_Tactics_Monad.is_irrelevant g in + if uu___4 + then + ((let uu___6 = + FStarC_Compiler_Effect.op_Bang dbg_Tac in + if uu___6 + then + let uu___7 = + let uu___8 = + FStarC_Tactics_Types.goal_witness g in + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term uu___8 in + FStarC_Compiler_Util.print1 + "Assigning irrelevant goal %s\n" uu___7 + else ()); + (let uu___6 = + let uu___7 = FStarC_Tactics_Types.goal_env g in + let uu___8 = + FStarC_Tactics_Types.goal_witness g in + FStarC_TypeChecker_Rel.teq_nosmt_force + uu___7 uu___8 FStarC_Syntax_Util.exp_unit in + if uu___6 + then () + else + (let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Tactics_Types.goal_witness g in + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + uu___10 in + FStarC_Compiler_Util.format1 + "Irrelevant tactic witness does not unify with (): %s" + uu___9 in + failwith uu___8))) + else ())) remaining_smt_goals; + FStarC_Errors.with_ctx + "While checking implicits left by a tactic" + (fun uu___4 -> + (let uu___6 = + FStarC_Compiler_Effect.op_Bang dbg_Tac in + if uu___6 + then + let uu___7 = + (FStarC_Common.string_of_list ()) + (fun imp -> + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_ctxu + imp.FStarC_TypeChecker_Common.imp_uvar) + ps3.FStarC_Tactics_Types.all_implicits in + FStarC_Compiler_Util.print1 + "About to check tactic implicits: %s\n" uu___7 + else ()); + (let g = + let uu___6 = + FStarC_Class_Listlike.from_list + (FStarC_Compiler_CList.listlike_clist ()) + ps3.FStarC_Tactics_Types.all_implicits in + { + FStarC_TypeChecker_Common.guard_f = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.guard_f); + FStarC_TypeChecker_Common.deferred_to_tac = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = uu___6 + } in + let g1 = + FStarC_TypeChecker_Rel.solve_deferred_constraints + env g in + (let uu___7 = + FStarC_Compiler_Effect.op_Bang dbg_Tac in + if uu___7 + then + let uu___8 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_nat) + (FStarC_Compiler_List.length + ps3.FStarC_Tactics_Types.all_implicits) in + let uu___9 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_TypeChecker_Common.showable_implicit) + ps3.FStarC_Tactics_Types.all_implicits in + FStarC_Compiler_Util.print2 + "Checked %s implicits (1): %s\n" uu___8 + uu___9 + else ()); + (let tagged_implicits = + FStarC_TypeChecker_Rel.resolve_implicits_tac + env g1 in + (let uu___8 = + FStarC_Compiler_Effect.op_Bang dbg_Tac in + if uu___8 + then + let uu___9 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_nat) + (FStarC_Compiler_List.length + ps3.FStarC_Tactics_Types.all_implicits) in + let uu___10 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_TypeChecker_Common.showable_implicit) + ps3.FStarC_Tactics_Types.all_implicits in + FStarC_Compiler_Util.print2 + "Checked %s implicits (2): %s\n" uu___9 + uu___10 + else ()); + report_implicits rng_goal tagged_implicits))); + (remaining_smt_goals, ret))) + | FStarC_Tactics_Result.Failed + (FStarC_Errors.Error (code, msg, rng, ctx), ps3) -> + let msg1 = + let uu___1 = FStarC_Pprint.doc_of_string "Tactic failed" in + uu___1 :: msg in + FStarC_Compiler_Effect.raise + (FStarC_Errors.Error (code, msg1, rng, ctx)) + | FStarC_Tactics_Result.Failed (e, ps3) -> + (if ps3.FStarC_Tactics_Types.dump_on_failure + then + FStarC_Tactics_Printing.do_dump_proofstate ps3 + "at the time of failure" + else (); + (let texn_to_doc e1 = + match e1 with + | FStarC_Tactics_Common.TacticFailure msg -> msg + | FStarC_Tactics_Common.EExn t -> + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + Prims.strcat "Uncaught exception: " uu___5 in + FStarC_Pprint.doc_of_string uu___4 in + [uu___3] in + (uu___2, FStar_Pervasives_Native.None) + | e2 -> FStarC_Compiler_Effect.raise e2 in + let uu___2 = texn_to_doc e in + match uu___2 with + | (doc, rng) -> + let rng1 = + if background + then + match ps3.FStarC_Tactics_Types.goals with + | g::uu___3 -> + (g.FStarC_Tactics_Types.goal_ctx_uvar).FStarC_Syntax_Syntax.ctx_uvar_range + | uu___3 -> rng_call + else + (match rng with + | FStar_Pervasives_Native.Some r -> r + | uu___4 -> + ps3.FStarC_Tactics_Types.entry_range) in + let uu___3 = + let uu___4 = + if ps3.FStarC_Tactics_Types.dump_on_failure + then + let uu___5 = + FStarC_Pprint.doc_of_string "Tactic failed" in + [uu___5] + else [] in + FStarC_Compiler_List.op_At uu___4 doc in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range rng1 + FStarC_Errors_Codes.Fatal_UserTacticFailure () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___3)))) +let run_tactic_on_ps' : + 'a 'b . + FStarC_Compiler_Range_Type.range -> + FStarC_Compiler_Range_Type.range -> + Prims.bool -> + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'a -> + 'b FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_Syntax_Syntax.term -> + Prims.bool -> + FStarC_Tactics_Types.proofstate -> + (FStarC_Tactics_Types.goal Prims.list * 'b) + = + fun rng_call -> + fun rng_goal -> + fun background -> + fun e_arg -> + fun arg -> + fun e_res -> + fun tactic -> + fun tactic_already_typed -> + fun ps -> + let env = ps.FStarC_Tactics_Types.main_context in + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_Tac in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term tactic in + let uu___3 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + tactic_already_typed in + FStarC_Compiler_Util.print2 + "Typechecking tactic: (%s) (already_typed: %s) {\n" + uu___2 uu___3 + else ()); + (let g = + if tactic_already_typed + then FStarC_TypeChecker_Env.trivial_guard + else + (let uu___2 = + let uu___3 = + FStarC_Syntax_Embeddings_Base.type_of e_arg in + let uu___4 = + FStarC_Syntax_Embeddings_Base.type_of e_res in + FStarC_TypeChecker_TcTerm.tc_tactic uu___3 uu___4 + env tactic in + match uu___2 with | (uu___3, uu___4, g1) -> g1) in + (let uu___2 = FStarC_Compiler_Effect.op_Bang dbg_Tac in + if uu___2 + then FStarC_Compiler_Util.print_string "}\n" + else ()); + FStarC_TypeChecker_Rel.force_trivial_guard env g; + FStarC_Errors.stop_if_err (); + (let tau = + unembed_tactic_1 e_arg e_res tactic + FStarC_Syntax_Embeddings_Base.id_norm_cb in + run_unembedded_tactic_on_ps rng_call rng_goal + background arg tau ps)) +let run_tactic_on_ps : + 'a 'b . + FStarC_Compiler_Range_Type.range -> + FStarC_Compiler_Range_Type.range -> + Prims.bool -> + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'a -> + 'b FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_Syntax_Syntax.term -> + Prims.bool -> + FStarC_Tactics_Types.proofstate -> + (FStarC_Tactics_Types.goal Prims.list * 'b) + = + fun rng_call -> + fun rng_goal -> + fun background -> + fun e_arg -> + fun arg -> + fun e_res -> + fun tactic -> + fun tactic_already_typed -> + fun ps -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_Env.current_module + ps.FStarC_Tactics_Types.main_context in + FStarC_Ident.string_of_lid uu___2 in + FStar_Pervasives_Native.Some uu___1 in + FStarC_Profiling.profile + (fun uu___1 -> + run_tactic_on_ps' rng_call rng_goal background e_arg + arg e_res tactic tactic_already_typed ps) uu___ + "FStarC.Tactics.Interpreter.run_tactic_on_ps" \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Tactics_Monad.ml b/ocaml/fstar-lib/generated/FStarC_Tactics_Monad.ml new file mode 100644 index 00000000000..dd8ac2f21c6 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Tactics_Monad.ml @@ -0,0 +1,1428 @@ +open Prims +let (dbg_Core : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Core" +let (dbg_CoreEq : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "CoreEq" +let (dbg_RegisterGoal : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "RegisterGoal" +let (dbg_TacFail : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "TacFail" +let (goal_ctr : Prims.int FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref Prims.int_zero +let (get_goal_ctr : unit -> Prims.int) = + fun uu___ -> FStarC_Compiler_Effect.op_Bang goal_ctr +let (incr_goal_ctr : unit -> Prims.int) = + fun uu___ -> + let v = FStarC_Compiler_Effect.op_Bang goal_ctr in + FStarC_Compiler_Effect.op_Colon_Equals goal_ctr (v + Prims.int_one); v +let (is_goal_safe_as_well_typed : FStarC_Tactics_Types.goal -> Prims.bool) = + fun g -> + let uv = g.FStarC_Tactics_Types.goal_ctx_uvar in + let all_deps_resolved = + let uu___ = FStarC_Syntax_Util.ctx_uvar_typedness_deps uv in + FStarC_Compiler_List.for_all + (fun uv1 -> + let uu___1 = + FStarC_Syntax_Unionfind.find + uv1.FStarC_Syntax_Syntax.ctx_uvar_head in + match uu___1 with + | FStar_Pervasives_Native.Some t -> + let uu___2 = FStarC_Syntax_Free.uvars t in + FStarC_Class_Setlike.is_empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) (Obj.magic uu___2) + | uu___2 -> false) uu___ in + all_deps_resolved +let (register_goal : FStarC_Tactics_Types.goal -> unit) = + fun g -> + let uu___ = + let uu___1 = FStarC_Options.compat_pre_core_should_register () in + Prims.op_Negation uu___1 in + if uu___ + then () + else + (let env = FStarC_Tactics_Types.goal_env g in + let uu___2 = + env.FStarC_TypeChecker_Env.phase1 || (FStarC_Options.lax ()) in + if uu___2 + then () + else + (let uv = g.FStarC_Tactics_Types.goal_ctx_uvar in + let i = FStarC_TypeChecker_Core.incr_goal_ctr () in + let uu___4 = + let uu___5 = + FStarC_Syntax_Util.ctx_uvar_should_check + g.FStarC_Tactics_Types.goal_ctx_uvar in + FStarC_Syntax_Syntax.uu___is_Allow_untyped uu___5 in + if uu___4 + then () + else + (let env1 = + { + FStarC_TypeChecker_Env.solver = + (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (uv.FStarC_Syntax_Syntax.ctx_uvar_gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env.FStarC_TypeChecker_Env.missing_decl) + } in + (let uu___7 = FStarC_Compiler_Effect.op_Bang dbg_CoreEq in + if uu___7 + then + let uu___8 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) i in + FStarC_Compiler_Util.print1 "(%s) Registering goal\n" uu___8 + else ()); + (let should_register = is_goal_safe_as_well_typed g in + if Prims.op_Negation should_register + then + let uu___8 = + (FStarC_Compiler_Effect.op_Bang dbg_Core) || + (FStarC_Compiler_Effect.op_Bang dbg_RegisterGoal) in + (if uu___8 + then + let uu___9 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) i in + FStarC_Compiler_Util.print1 + "(%s) Not registering goal since it has unresolved uvar deps\n" + uu___9 + else ()) + else + ((let uu___9 = + (FStarC_Compiler_Effect.op_Bang dbg_Core) || + (FStarC_Compiler_Effect.op_Bang dbg_RegisterGoal) in + if uu___9 + then + let uu___10 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) i in + let uu___11 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_ctxu uv in + FStarC_Compiler_Util.print2 + "(%s) Registering goal for %s\n" uu___10 uu___11 + else ()); + (let goal_ty = FStarC_Syntax_Util.ctx_uvar_typ uv in + let uu___9 = + FStarC_TypeChecker_Core.compute_term_type_handle_guards + env1 goal_ty (fun uu___10 -> fun uu___11 -> true) in + match uu___9 with + | FStar_Pervasives.Inl uu___10 -> () + | FStar_Pervasives.Inr err -> + let msg = + let uu___10 = + let uu___11 = FStarC_Syntax_Util.ctx_uvar_typ uv in + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term uu___11 in + let uu___11 = + FStarC_TypeChecker_Core.print_error_short err in + FStarC_Compiler_Util.format2 + "Failed to check initial tactic goal %s because %s" + uu___10 uu___11 in + FStarC_Errors.log_issue + FStarC_Class_HasRange.hasRange_range + uv.FStarC_Syntax_Syntax.ctx_uvar_range + FStarC_Errors_Codes.Warning_FailedToCheckInitialTacticGoal + () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic msg))))))) +type 'a tac = + { + tac_f: FStarC_Tactics_Types.proofstate -> 'a FStarC_Tactics_Result.__result } +let __proj__Mktac__item__tac_f : + 'a . + 'a tac -> + FStarC_Tactics_Types.proofstate -> 'a FStarC_Tactics_Result.__result + = fun projectee -> match projectee with | { tac_f;_} -> tac_f +let mk_tac : + 'a . + (FStarC_Tactics_Types.proofstate -> 'a FStarC_Tactics_Result.__result) -> + 'a tac + = fun f -> { tac_f = f } +let run : + 'a . + 'a tac -> + FStarC_Tactics_Types.proofstate -> 'a FStarC_Tactics_Result.__result + = fun t -> fun ps -> t.tac_f ps +let run_safe : + 'a . + 'a tac -> + FStarC_Tactics_Types.proofstate -> 'a FStarC_Tactics_Result.__result + = + fun t -> + fun ps -> + let uu___ = FStarC_Options.tactics_failhard () in + if uu___ + then run t ps + else + (try (fun uu___2 -> match () with | () -> run t ps) () + with | uu___2 -> FStarC_Tactics_Result.Failed (uu___2, ps)) +let ret : 'a . 'a -> 'a tac = + fun x -> mk_tac (fun ps -> FStarC_Tactics_Result.Success (x, ps)) +let bind : 'a 'b . 'a tac -> ('a -> 'b tac) -> 'b tac = + fun t1 -> + fun t2 -> + mk_tac + (fun ps -> + let uu___ = run t1 ps in + match uu___ with + | FStarC_Tactics_Result.Success (a1, q) -> + let uu___1 = t2 a1 in run uu___1 q + | FStarC_Tactics_Result.Failed (msg, q) -> + FStarC_Tactics_Result.Failed (msg, q)) +let (monad_tac : unit tac FStarC_Class_Monad.monad) = + { + FStarC_Class_Monad.return = + (fun uu___1 -> fun uu___ -> (fun uu___ -> Obj.magic ret) uu___1 uu___); + FStarC_Class_Monad.op_let_Bang = + (fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun uu___1 -> fun uu___ -> Obj.magic bind) uu___3 uu___2 + uu___1 uu___) + } +let (set : FStarC_Tactics_Types.proofstate -> unit tac) = + fun ps -> mk_tac (fun uu___ -> FStarC_Tactics_Result.Success ((), ps)) +let (get : FStarC_Tactics_Types.proofstate tac) = + mk_tac (fun ps -> FStarC_Tactics_Result.Success (ps, ps)) +let traise : 'a . Prims.exn -> 'a tac = + fun e -> mk_tac (fun ps -> FStarC_Tactics_Result.Failed (e, ps)) +let (do_log : FStarC_Tactics_Types.proofstate -> (unit -> unit) -> unit) = + fun ps -> + fun f -> if ps.FStarC_Tactics_Types.tac_verb_dbg then f () else () +let (log : (unit -> unit) -> unit tac) = + fun f -> + mk_tac (fun ps -> do_log ps f; FStarC_Tactics_Result.Success ((), ps)) +let fail_doc : 'a . FStarC_Errors_Msg.error_message -> 'a tac = + fun msg -> + mk_tac + (fun ps -> + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_TacFail in + if uu___1 + then + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Compiler_List.hd msg in + FStarC_Errors_Msg.renderdoc uu___4 in + Prims.strcat "TACTIC FAILING: " uu___3 in + FStarC_Tactics_Printing.do_dump_proofstate ps uu___2 + else ()); + FStarC_Tactics_Result.Failed + ((FStarC_Tactics_Common.TacticFailure + (msg, FStar_Pervasives_Native.None)), ps)) +let fail : 'a . Prims.string -> 'a tac = + fun msg -> + let uu___ = let uu___1 = FStarC_Errors_Msg.text msg in [uu___1] in + fail_doc uu___ +let catch : 'a . 'a tac -> (Prims.exn, 'a) FStar_Pervasives.either tac = + fun t -> + mk_tac + (fun ps -> + let idtable = + FStarC_Compiler_Effect.op_Bang + (ps.FStarC_Tactics_Types.main_context).FStarC_TypeChecker_Env.identifier_info in + let tx = FStarC_Syntax_Unionfind.new_transaction () in + let uu___ = run t ps in + match uu___ with + | FStarC_Tactics_Result.Success (a1, q) -> + (FStarC_Syntax_Unionfind.commit tx; + FStarC_Tactics_Result.Success ((FStar_Pervasives.Inr a1), q)) + | FStarC_Tactics_Result.Failed (m, q) -> + (FStarC_Syntax_Unionfind.rollback tx; + FStarC_Compiler_Effect.op_Colon_Equals + (ps.FStarC_Tactics_Types.main_context).FStarC_TypeChecker_Env.identifier_info + idtable; + (let ps1 = + { + FStarC_Tactics_Types.main_context = + (ps.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits = + (ps.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = + (ps.FStarC_Tactics_Types.goals); + FStarC_Tactics_Types.smt_goals = + (ps.FStarC_Tactics_Types.smt_goals); + FStarC_Tactics_Types.depth = + (ps.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = + (ps.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = (ps.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (ps.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = + (ps.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness = + (q.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg = + (ps.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = + (ps.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency = + (ps.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure = + (ps.FStarC_Tactics_Types.dump_on_failure) + } in + FStarC_Tactics_Result.Success ((FStar_Pervasives.Inl m), ps1)))) +let recover : 'a . 'a tac -> (Prims.exn, 'a) FStar_Pervasives.either tac = + fun t -> + mk_tac + (fun ps -> + let uu___ = run t ps in + match uu___ with + | FStarC_Tactics_Result.Success (a1, q) -> + FStarC_Tactics_Result.Success ((FStar_Pervasives.Inr a1), q) + | FStarC_Tactics_Result.Failed (m, q) -> + FStarC_Tactics_Result.Success ((FStar_Pervasives.Inl m), q)) +let trytac : 'a . 'a tac -> 'a FStar_Pervasives_Native.option tac = + fun t -> + let uu___ = catch t in + bind uu___ + (fun r -> + match r with + | FStar_Pervasives.Inr v -> ret (FStar_Pervasives_Native.Some v) + | FStar_Pervasives.Inl uu___1 -> ret FStar_Pervasives_Native.None) +let trytac_exn : 'a . 'a tac -> 'a FStar_Pervasives_Native.option tac = + fun t -> + mk_tac + (fun ps -> + try + (fun uu___ -> + match () with | () -> let uu___1 = trytac t in run uu___1 ps) + () + with + | FStarC_Errors.Error (uu___1, msg, uu___2, uu___3) -> + (do_log ps + (fun uu___5 -> + let uu___6 = FStarC_Errors_Msg.rendermsg msg in + FStarC_Compiler_Util.print1 "trytac_exn error: (%s)" + uu___6); + FStarC_Tactics_Result.Success + (FStar_Pervasives_Native.None, ps))) +let rec iter_tac : 'a . ('a -> unit tac) -> 'a Prims.list -> unit tac = + fun f -> + fun l -> + match l with + | [] -> ret () + | hd::tl -> + let uu___ = f hd in + FStarC_Class_Monad.op_let_Bang monad_tac () () uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in Obj.magic (iter_tac f tl)) + uu___1) +exception Bad of Prims.string +let (uu___is_Bad : Prims.exn -> Prims.bool) = + fun projectee -> match projectee with | Bad uu___ -> true | uu___ -> false +let (__proj__Bad__item__uu___ : Prims.exn -> Prims.string) = + fun projectee -> match projectee with | Bad uu___ -> uu___ +let (nwarn : Prims.int FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref Prims.int_zero +let (check_valid_goal : FStarC_Tactics_Types.goal -> unit) = + fun g -> + let uu___ = FStarC_Options.defensive () in + if uu___ + then + try + (fun uu___1 -> + match () with + | () -> + let env = FStarC_Tactics_Types.goal_env g in + ((let uu___3 = + let uu___4 = + let uu___5 = FStarC_Tactics_Types.goal_witness g in + FStarC_TypeChecker_Env.closed env uu___5 in + Prims.op_Negation uu___4 in + if uu___3 + then FStarC_Compiler_Effect.raise (Bad "witness") + else ()); + (let uu___4 = + let uu___5 = + let uu___6 = FStarC_Tactics_Types.goal_type g in + FStarC_TypeChecker_Env.closed env uu___6 in + Prims.op_Negation uu___5 in + if uu___4 + then FStarC_Compiler_Effect.raise (Bad "goal type") + else ()); + (let rec aux e = + let uu___4 = FStarC_TypeChecker_Env.pop_bv e in + match uu___4 with + | FStar_Pervasives_Native.None -> () + | FStar_Pervasives_Native.Some (bv, e1) -> + ((let uu___6 = + let uu___7 = + FStarC_TypeChecker_Env.closed e1 + bv.FStarC_Syntax_Syntax.sort in + Prims.op_Negation uu___7 in + if uu___6 + then + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_bv bv in + Prims.strcat "bv: " uu___9 in + Bad uu___8 in + FStarC_Compiler_Effect.raise uu___7 + else ()); + aux e1) in + aux env))) () + with + | Bad culprit -> + let uu___2 = + let uu___3 = FStarC_Compiler_Effect.op_Bang nwarn in + uu___3 < (Prims.of_int (5)) in + (if uu___2 + then + ((let uu___4 = FStarC_Tactics_Types.goal_type g in + let uu___5 = + let uu___6 = + FStarC_Tactics_Printing.goal_to_string_verbose g in + FStarC_Compiler_Util.format2 + "The following goal is ill-formed (%s). Keeping calm and carrying on...\n<%s>\n\n" + culprit uu___6 in + FStarC_Errors.log_issue + (FStarC_Syntax_Syntax.has_range_syntax ()) uu___4 + FStarC_Errors_Codes.Warning_IllFormedGoal () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___5)); + (let uu___4 = + let uu___5 = FStarC_Compiler_Effect.op_Bang nwarn in + uu___5 + Prims.int_one in + FStarC_Compiler_Effect.op_Colon_Equals nwarn uu___4)) + else ()) + else () +let (check_valid_goals : FStarC_Tactics_Types.goal Prims.list -> unit) = + fun gs -> + let uu___ = FStarC_Options.defensive () in + if uu___ then FStarC_Compiler_List.iter check_valid_goal gs else () +let (set_goals : FStarC_Tactics_Types.goal Prims.list -> unit tac) = + fun gs -> + bind get + (fun ps -> + set + { + FStarC_Tactics_Types.main_context = + (ps.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits = + (ps.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = gs; + FStarC_Tactics_Types.smt_goals = + (ps.FStarC_Tactics_Types.smt_goals); + FStarC_Tactics_Types.depth = (ps.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = (ps.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = (ps.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (ps.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = + (ps.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness = + (ps.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg = + (ps.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = + (ps.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency = (ps.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure = + (ps.FStarC_Tactics_Types.dump_on_failure) + }) +let (set_smt_goals : FStarC_Tactics_Types.goal Prims.list -> unit tac) = + fun gs -> + bind get + (fun ps -> + set + { + FStarC_Tactics_Types.main_context = + (ps.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits = + (ps.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = (ps.FStarC_Tactics_Types.goals); + FStarC_Tactics_Types.smt_goals = gs; + FStarC_Tactics_Types.depth = (ps.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = (ps.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = (ps.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (ps.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = + (ps.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness = + (ps.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg = + (ps.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = + (ps.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency = (ps.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure = + (ps.FStarC_Tactics_Types.dump_on_failure) + }) +let (cur_goals : FStarC_Tactics_Types.goal Prims.list tac) = + bind get (fun ps -> ret ps.FStarC_Tactics_Types.goals) +let (cur_goal_maybe_solved : FStarC_Tactics_Types.goal tac) = + bind cur_goals + (fun uu___ -> + match uu___ with | [] -> fail "No more goals" | hd::tl -> ret hd) +let (cur_goal : FStarC_Tactics_Types.goal tac) = + bind cur_goals + (fun uu___ -> + match uu___ with + | [] -> fail "No more goals" + | hd::tl -> + let uu___1 = FStarC_Tactics_Types.check_goal_solved' hd in + (match uu___1 with + | FStar_Pervasives_Native.None -> ret hd + | FStar_Pervasives_Native.Some t -> + ((let uu___3 = + FStarC_Tactics_Printing.goal_to_string_verbose hd in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + t in + FStarC_Compiler_Util.print2 + "!!!!!!!!!!!! GOAL IS ALREADY SOLVED! %s\nsol is %s\n" + uu___3 uu___4); + ret hd))) +let (remove_solved_goals : unit tac) = + bind cur_goals + (fun gs -> + let gs1 = + FStarC_Compiler_List.filter + (fun g -> + let uu___ = FStarC_Tactics_Types.check_goal_solved g in + Prims.op_Negation uu___) gs in + set_goals gs1) +let (dismiss_all : unit tac) = set_goals [] +let (dismiss : unit tac) = + bind get + (fun ps -> + let uu___ = + let uu___1 = FStarC_Compiler_List.tl ps.FStarC_Tactics_Types.goals in + { + FStarC_Tactics_Types.main_context = + (ps.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits = + (ps.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = uu___1; + FStarC_Tactics_Types.smt_goals = + (ps.FStarC_Tactics_Types.smt_goals); + FStarC_Tactics_Types.depth = (ps.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = (ps.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = (ps.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (ps.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = + (ps.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness = + (ps.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg = + (ps.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = + (ps.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency = (ps.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure = + (ps.FStarC_Tactics_Types.dump_on_failure) + } in + set uu___) +let (replace_cur : FStarC_Tactics_Types.goal -> unit tac) = + fun g -> + bind get + (fun ps -> + check_valid_goal g; + (let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Compiler_List.tl ps.FStarC_Tactics_Types.goals in + g :: uu___3 in + { + FStarC_Tactics_Types.main_context = + (ps.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits = + (ps.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = uu___2; + FStarC_Tactics_Types.smt_goals = + (ps.FStarC_Tactics_Types.smt_goals); + FStarC_Tactics_Types.depth = (ps.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = (ps.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = (ps.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (ps.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = + (ps.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness = + (ps.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg = + (ps.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = + (ps.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency = + (ps.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure = + (ps.FStarC_Tactics_Types.dump_on_failure) + } in + set uu___1)) +let (getopts : FStarC_Options.optionstate tac) = + let uu___ = trytac cur_goal_maybe_solved in + bind uu___ + (fun uu___1 -> + match uu___1 with + | FStar_Pervasives_Native.Some g -> ret g.FStarC_Tactics_Types.opts + | FStar_Pervasives_Native.None -> + let uu___2 = FStarC_Options.peek () in ret uu___2) +let (add_goals : FStarC_Tactics_Types.goal Prims.list -> unit tac) = + fun gs -> + bind get + (fun ps -> + check_valid_goals gs; + set + { + FStarC_Tactics_Types.main_context = + (ps.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits = + (ps.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = + (FStarC_Compiler_List.op_At gs ps.FStarC_Tactics_Types.goals); + FStarC_Tactics_Types.smt_goals = + (ps.FStarC_Tactics_Types.smt_goals); + FStarC_Tactics_Types.depth = (ps.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = (ps.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = (ps.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (ps.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = + (ps.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness = + (ps.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg = + (ps.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = + (ps.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency = (ps.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure = + (ps.FStarC_Tactics_Types.dump_on_failure) + }) +let (add_smt_goals : FStarC_Tactics_Types.goal Prims.list -> unit tac) = + fun gs -> + bind get + (fun ps -> + check_valid_goals gs; + set + { + FStarC_Tactics_Types.main_context = + (ps.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits = + (ps.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = (ps.FStarC_Tactics_Types.goals); + FStarC_Tactics_Types.smt_goals = + (FStarC_Compiler_List.op_At gs + ps.FStarC_Tactics_Types.smt_goals); + FStarC_Tactics_Types.depth = (ps.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = (ps.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = (ps.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (ps.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = + (ps.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness = + (ps.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg = + (ps.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = + (ps.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency = (ps.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure = + (ps.FStarC_Tactics_Types.dump_on_failure) + }) +let (push_goals : FStarC_Tactics_Types.goal Prims.list -> unit tac) = + fun gs -> + bind get + (fun ps -> + check_valid_goals gs; + set + { + FStarC_Tactics_Types.main_context = + (ps.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits = + (ps.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = + (FStarC_Compiler_List.op_At ps.FStarC_Tactics_Types.goals gs); + FStarC_Tactics_Types.smt_goals = + (ps.FStarC_Tactics_Types.smt_goals); + FStarC_Tactics_Types.depth = (ps.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = (ps.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = (ps.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (ps.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = + (ps.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness = + (ps.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg = + (ps.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = + (ps.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency = (ps.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure = + (ps.FStarC_Tactics_Types.dump_on_failure) + }) +let (push_smt_goals : FStarC_Tactics_Types.goal Prims.list -> unit tac) = + fun gs -> + bind get + (fun ps -> + check_valid_goals gs; + set + { + FStarC_Tactics_Types.main_context = + (ps.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits = + (ps.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = (ps.FStarC_Tactics_Types.goals); + FStarC_Tactics_Types.smt_goals = + (FStarC_Compiler_List.op_At ps.FStarC_Tactics_Types.smt_goals + gs); + FStarC_Tactics_Types.depth = (ps.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = (ps.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = (ps.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (ps.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = + (ps.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness = + (ps.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg = + (ps.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = + (ps.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency = (ps.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure = + (ps.FStarC_Tactics_Types.dump_on_failure) + }) +let (add_implicits : FStarC_TypeChecker_Env.implicits -> unit tac) = + fun i -> + bind get + (fun ps -> + set + { + FStarC_Tactics_Types.main_context = + (ps.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits = + (FStarC_Compiler_List.op_At i + ps.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = (ps.FStarC_Tactics_Types.goals); + FStarC_Tactics_Types.smt_goals = + (ps.FStarC_Tactics_Types.smt_goals); + FStarC_Tactics_Types.depth = (ps.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = (ps.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = (ps.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (ps.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = + (ps.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness = + (ps.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg = + (ps.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = + (ps.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency = (ps.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure = + (ps.FStarC_Tactics_Types.dump_on_failure) + }) +let (new_uvar : + Prims.string -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.should_check_uvar FStar_Pervasives_Native.option + -> + FStarC_Syntax_Syntax.ctx_uvar Prims.list -> + FStarC_Compiler_Range_Type.range -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.ctx_uvar) tac) + = + fun reason -> + fun env -> + fun typ -> + fun sc_opt -> + fun uvar_typedness_deps -> + fun rng -> + let should_check = + match sc_opt with + | FStar_Pervasives_Native.Some sc -> sc + | uu___ -> FStarC_Syntax_Syntax.Strict in + let uu___ = + FStarC_TypeChecker_Env.new_tac_implicit_var reason rng env + typ should_check uvar_typedness_deps + FStar_Pervasives_Native.None false in + match uu___ with + | (u, ctx_uvar, g_u) -> + let uu___1 = + let uu___2 = + FStarC_Class_Listlike.to_list + (FStarC_Compiler_CList.listlike_clist ()) + g_u.FStarC_TypeChecker_Common.implicits in + add_implicits uu___2 in + bind uu___1 + (fun uu___2 -> + ret (u, (FStar_Pervasives_Native.fst ctx_uvar))) +let (mk_irrelevant_goal : + Prims.string -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.should_check_uvar FStar_Pervasives_Native.option + -> + FStarC_Compiler_Range_Type.range -> + FStarC_Options.optionstate -> + Prims.string -> FStarC_Tactics_Types.goal tac) + = + fun reason -> + fun env -> + fun phi -> + fun sc_opt -> + fun rng -> + fun opts -> + fun label -> + let typ = + let uu___ = env.FStarC_TypeChecker_Env.universe_of env phi in + FStarC_Syntax_Util.mk_squash uu___ phi in + let uu___ = new_uvar reason env typ sc_opt [] rng in + bind uu___ + (fun uu___1 -> + match uu___1 with + | (uu___2, ctx_uvar) -> + let goal = + FStarC_Tactics_Types.mk_goal env ctx_uvar opts + false label in + ret goal) +let (add_irrelevant_goal' : + Prims.string -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.should_check_uvar FStar_Pervasives_Native.option + -> + FStarC_Compiler_Range_Type.range -> + FStarC_Options.optionstate -> Prims.string -> unit tac) + = + fun reason -> + fun env -> + fun phi -> + fun sc_opt -> + fun rng -> + fun opts -> + fun label -> + let uu___ = + mk_irrelevant_goal reason env phi sc_opt rng opts label in + bind uu___ (fun goal -> add_goals [goal]) +let (add_irrelevant_goal : + FStarC_Tactics_Types.goal -> + Prims.string -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.should_check_uvar + FStar_Pervasives_Native.option -> unit tac) + = + fun base_goal -> + fun reason -> + fun env -> + fun phi -> + fun sc_opt -> + add_irrelevant_goal' reason env phi sc_opt + (base_goal.FStarC_Tactics_Types.goal_ctx_uvar).FStarC_Syntax_Syntax.ctx_uvar_range + base_goal.FStarC_Tactics_Types.opts + base_goal.FStarC_Tactics_Types.label +let (goal_of_guard : + Prims.string -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.should_check_uvar FStar_Pervasives_Native.option + -> + FStarC_Compiler_Range_Type.range -> FStarC_Tactics_Types.goal tac) + = + fun reason -> + fun e -> + fun f -> + fun sc_opt -> + fun rng -> + bind getopts + (fun opts -> + let uu___ = mk_irrelevant_goal reason e f sc_opt rng opts "" in + bind uu___ + (fun goal -> + let goal1 = + { + FStarC_Tactics_Types.goal_main_env = + (goal.FStarC_Tactics_Types.goal_main_env); + FStarC_Tactics_Types.goal_ctx_uvar = + (goal.FStarC_Tactics_Types.goal_ctx_uvar); + FStarC_Tactics_Types.opts = + (goal.FStarC_Tactics_Types.opts); + FStarC_Tactics_Types.is_guard = true; + FStarC_Tactics_Types.label = + (goal.FStarC_Tactics_Types.label) + } in + ret goal1)) +let wrap_err_doc : 'a . FStarC_Errors_Msg.error_message -> 'a tac -> 'a tac = + fun pref -> + fun t -> + mk_tac + (fun ps -> + let uu___ = run t ps in + match uu___ with + | FStarC_Tactics_Result.Success (a1, q) -> + FStarC_Tactics_Result.Success (a1, q) + | FStarC_Tactics_Result.Failed + (FStarC_Tactics_Common.TacticFailure (msg, r), q) -> + FStarC_Tactics_Result.Failed + ((FStarC_Tactics_Common.TacticFailure + ((FStarC_Compiler_List.op_At pref msg), r)), q) + | FStarC_Tactics_Result.Failed (e, q) -> + FStarC_Tactics_Result.Failed (e, q)) +let wrap_err : 'a . Prims.string -> 'a tac -> 'a tac = + fun pref -> + fun t -> + let uu___ = + let uu___1 = + FStarC_Errors_Msg.text + (Prims.strcat "'" (Prims.strcat pref "' failed")) in + [uu___1] in + wrap_err_doc uu___ t +let mlog : 'a . (unit -> unit) -> (unit -> 'a tac) -> 'a tac = + fun uu___1 -> + fun uu___ -> + (fun f -> + fun cont -> + let uu___ = log f in + Obj.magic + (FStarC_Class_Monad.op_let_Bang monad_tac () () uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in Obj.magic (cont ())) + uu___1))) uu___1 uu___ +let (if_verbose_tac : (unit -> unit tac) -> unit tac) = + fun f -> + FStarC_Class_Monad.op_let_Bang monad_tac () () (Obj.magic get) + (fun uu___ -> + (fun ps -> + let ps = Obj.magic ps in + if ps.FStarC_Tactics_Types.tac_verb_dbg + then Obj.magic (f ()) + else Obj.magic (ret ())) uu___) +let (if_verbose : (unit -> unit) -> unit tac) = + fun f -> if_verbose_tac (fun uu___ -> f (); ret ()) +let (compress_implicits : unit tac) = + bind get + (fun ps -> + let imps = ps.FStarC_Tactics_Types.all_implicits in + let g = + let uu___ = + FStarC_Class_Listlike.from_list + (FStarC_Compiler_CList.listlike_clist ()) imps in + { + FStarC_TypeChecker_Common.guard_f = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.guard_f); + FStarC_TypeChecker_Common.deferred_to_tac = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = uu___ + } in + let imps1 = + FStarC_TypeChecker_Rel.resolve_implicits_tac + ps.FStarC_Tactics_Types.main_context g in + let ps' = + let uu___ = + FStarC_Compiler_List.map FStar_Pervasives_Native.fst imps1 in + { + FStarC_Tactics_Types.main_context = + (ps.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits = uu___; + FStarC_Tactics_Types.goals = (ps.FStarC_Tactics_Types.goals); + FStarC_Tactics_Types.smt_goals = + (ps.FStarC_Tactics_Types.smt_goals); + FStarC_Tactics_Types.depth = (ps.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = (ps.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = (ps.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (ps.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = + (ps.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness = + (ps.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg = + (ps.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = + (ps.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency = (ps.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure = + (ps.FStarC_Tactics_Types.dump_on_failure) + } in + set ps') +let (get_phi : + FStarC_Tactics_Types.goal -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = + fun g -> + let uu___ = + let uu___1 = FStarC_Tactics_Types.goal_env g in + let uu___2 = FStarC_Tactics_Types.goal_type g in + FStarC_TypeChecker_Normalize.unfold_whnf uu___1 uu___2 in + FStarC_Syntax_Util.un_squash uu___ +let (is_irrelevant : FStarC_Tactics_Types.goal -> Prims.bool) = + fun g -> let uu___ = get_phi g in FStarC_Compiler_Option.isSome uu___ +let (goal_typedness_deps : + FStarC_Tactics_Types.goal -> FStarC_Syntax_Syntax.ctx_uvar Prims.list) = + fun g -> + FStarC_Syntax_Util.ctx_uvar_typedness_deps + g.FStarC_Tactics_Types.goal_ctx_uvar +let (set_uvar_expected_typ : + FStarC_Syntax_Syntax.ctx_uvar -> FStarC_Syntax_Syntax.typ -> unit) = + fun u -> + fun t -> + let dec = + FStarC_Syntax_Unionfind.find_decoration + u.FStarC_Syntax_Syntax.ctx_uvar_head in + FStarC_Syntax_Unionfind.change_decoration + u.FStarC_Syntax_Syntax.ctx_uvar_head + { + FStarC_Syntax_Syntax.uvar_decoration_typ = t; + FStarC_Syntax_Syntax.uvar_decoration_typedness_depends_on = + (dec.FStarC_Syntax_Syntax.uvar_decoration_typedness_depends_on); + FStarC_Syntax_Syntax.uvar_decoration_should_check = + (dec.FStarC_Syntax_Syntax.uvar_decoration_should_check); + FStarC_Syntax_Syntax.uvar_decoration_should_unrefine = + (dec.FStarC_Syntax_Syntax.uvar_decoration_should_unrefine) + } +let (mark_uvar_with_should_check_tag : + FStarC_Syntax_Syntax.ctx_uvar -> + FStarC_Syntax_Syntax.should_check_uvar -> unit) + = + fun u -> + fun sc -> + let dec = + FStarC_Syntax_Unionfind.find_decoration + u.FStarC_Syntax_Syntax.ctx_uvar_head in + FStarC_Syntax_Unionfind.change_decoration + u.FStarC_Syntax_Syntax.ctx_uvar_head + { + FStarC_Syntax_Syntax.uvar_decoration_typ = + (dec.FStarC_Syntax_Syntax.uvar_decoration_typ); + FStarC_Syntax_Syntax.uvar_decoration_typedness_depends_on = + (dec.FStarC_Syntax_Syntax.uvar_decoration_typedness_depends_on); + FStarC_Syntax_Syntax.uvar_decoration_should_check = sc; + FStarC_Syntax_Syntax.uvar_decoration_should_unrefine = + (dec.FStarC_Syntax_Syntax.uvar_decoration_should_unrefine) + } +let (mark_uvar_as_already_checked : FStarC_Syntax_Syntax.ctx_uvar -> unit) = + fun u -> + mark_uvar_with_should_check_tag u FStarC_Syntax_Syntax.Already_checked +let (mark_goal_implicit_already_checked : FStarC_Tactics_Types.goal -> unit) + = + fun g -> mark_uvar_as_already_checked g.FStarC_Tactics_Types.goal_ctx_uvar +let (goal_with_type : + FStarC_Tactics_Types.goal -> + FStarC_Syntax_Syntax.typ -> FStarC_Tactics_Types.goal) + = + fun g -> + fun t -> + let u = g.FStarC_Tactics_Types.goal_ctx_uvar in + set_uvar_expected_typ u t; g +let divide : 'a 'b . FStarC_BigInt.t -> 'a tac -> 'b tac -> ('a * 'b) tac = + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun n -> + fun l -> + fun r -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang monad_tac () () + (Obj.magic get) + (fun uu___ -> + (fun p -> + let p = Obj.magic p in + let uu___ = + try + (fun uu___1 -> + (fun uu___1 -> + match () with + | () -> + let uu___2 = + let uu___3 = + FStarC_BigInt.to_int_fs n in + FStarC_Compiler_List.splitAt uu___3 + p.FStarC_Tactics_Types.goals in + Obj.magic + (FStarC_Class_Monad.return + monad_tac () (Obj.magic uu___2))) + uu___1) () + with | uu___1 -> fail "divide: not enough goals" in + Obj.magic + (FStarC_Class_Monad.op_let_Bang monad_tac () () + (Obj.magic uu___) + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + match uu___1 with + | (lgs, rgs) -> + let lp = + { + FStarC_Tactics_Types.main_context + = + (p.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits + = + (p.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = lgs; + FStarC_Tactics_Types.smt_goals = + []; + FStarC_Tactics_Types.depth = + (p.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = + (p.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = + (p.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range + = + (p.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy + = + (p.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness = + (p.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg + = + (p.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state + = + (p.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency = + (p.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure + = + (p.FStarC_Tactics_Types.dump_on_failure) + } in + let uu___2 = set lp in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + monad_tac () () uu___2 + (fun uu___3 -> + (fun uu___3 -> + let uu___3 = + Obj.magic uu___3 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + monad_tac () () + (Obj.magic l) + (fun uu___4 -> + (fun a1 -> + let a1 = + Obj.magic a1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + monad_tac + () () + ( + Obj.magic + get) + ( + fun + uu___4 -> + (fun lp' + -> + let lp' = + Obj.magic + lp' in + let rp = + { + FStarC_Tactics_Types.main_context + = + (lp'.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits + = + (lp'.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals + = rgs; + FStarC_Tactics_Types.smt_goals + = []; + FStarC_Tactics_Types.depth + = + (lp'.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump + = + (lp'.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc + = + (lp'.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range + = + (lp'.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy + = + (lp'.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness + = + (lp'.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg + = + (lp'.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state + = + (lp'.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency + = + (lp'.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure + = + (lp'.FStarC_Tactics_Types.dump_on_failure) + } in + let uu___4 + = set rp in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + monad_tac + () () + uu___4 + (fun + uu___5 -> + (fun + uu___5 -> + let uu___5 + = + Obj.magic + uu___5 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + monad_tac + () () + (Obj.magic + r) + (fun + uu___6 -> + (fun b1 + -> + let b1 = + Obj.magic + b1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + monad_tac + () () + (Obj.magic + get) + (fun + uu___6 -> + (fun rp' + -> + let rp' = + Obj.magic + rp' in + let p' = + { + FStarC_Tactics_Types.main_context + = + (rp'.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits + = + (rp'.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals + = + (FStarC_Compiler_List.op_At + lp'.FStarC_Tactics_Types.goals + rp'.FStarC_Tactics_Types.goals); + FStarC_Tactics_Types.smt_goals + = + (FStarC_Compiler_List.op_At + lp'.FStarC_Tactics_Types.smt_goals + (FStarC_Compiler_List.op_At + rp'.FStarC_Tactics_Types.smt_goals + p.FStarC_Tactics_Types.smt_goals)); + FStarC_Tactics_Types.depth + = + (rp'.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump + = + (rp'.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc + = + (rp'.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range + = + (rp'.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy + = + (rp'.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness + = + (rp'.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg + = + (rp'.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state + = + (rp'.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency + = + (rp'.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure + = + (rp'.FStarC_Tactics_Types.dump_on_failure) + } in + let uu___6 + = set p' in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + monad_tac + () () + uu___6 + (fun + uu___7 -> + (fun + uu___7 -> + let uu___7 + = + Obj.magic + uu___7 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + monad_tac + () () + remove_solved_goals + (fun + uu___8 -> + (fun + uu___8 -> + let uu___8 + = + Obj.magic + uu___8 in + Obj.magic + (FStarC_Class_Monad.return + monad_tac + () + (Obj.magic + (a1, b1)))) + uu___8))) + uu___7))) + uu___6))) + uu___6))) + uu___5))) + uu___4))) + uu___4))) + uu___3))) uu___1))) uu___))) + uu___2 uu___1 uu___ +let focus : 'a . 'a tac -> 'a tac = + fun uu___ -> + (fun f -> + let uu___ = + let uu___1 = FStarC_Class_Monad.return monad_tac () (Obj.repr ()) in + divide FStarC_BigInt.one f uu___1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang monad_tac () () (Obj.magic uu___) + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + match uu___1 with + | (a1, uu___2) -> + Obj.magic + (FStarC_Class_Monad.return monad_tac () + (Obj.magic a1))) uu___1))) uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Tactics_Printing.ml b/ocaml/fstar-lib/generated/FStarC_Tactics_Printing.ml new file mode 100644 index 00000000000..07485268460 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Tactics_Printing.ml @@ -0,0 +1,372 @@ +open Prims +let (dbg_Imp : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Imp" +let (term_to_string : + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.term -> Prims.string) = + fun e -> + fun t -> + FStarC_Syntax_Print.term_to_string' e.FStarC_TypeChecker_Env.dsenv t +let (goal_to_string_verbose : FStarC_Tactics_Types.goal -> Prims.string) = + fun g -> + let uu___ = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_ctxu + g.FStarC_Tactics_Types.goal_ctx_uvar in + let uu___1 = + let uu___2 = FStarC_Tactics_Types.check_goal_solved' g in + match uu___2 with + | FStar_Pervasives_Native.None -> "" + | FStar_Pervasives_Native.Some t -> + let uu___3 = + let uu___4 = FStarC_Tactics_Types.goal_env g in + term_to_string uu___4 t in + FStarC_Compiler_Util.format1 "\tGOAL ALREADY SOLVED!: %s" uu___3 in + FStarC_Compiler_Util.format2 "%s%s\n" uu___ uu___1 +let (unshadow : + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.binders * FStarC_Syntax_Syntax.term)) + = + fun bs -> + fun t -> + let sset bv s = + let uu___ = + let uu___1 = + FStarC_Ident.range_of_id bv.FStarC_Syntax_Syntax.ppname in + FStar_Pervasives_Native.Some uu___1 in + FStarC_Syntax_Syntax.gen_bv s uu___ bv.FStarC_Syntax_Syntax.sort in + let fresh_until b f = + let rec aux i = + let t1 = + let uu___ = + let uu___1 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) i in + Prims.strcat "'" uu___1 in + Prims.strcat b uu___ in + let uu___ = f t1 in if uu___ then t1 else aux (i + Prims.int_one) in + let uu___ = f b in if uu___ then b else aux Prims.int_zero in + let rec go seen subst bs1 bs' t1 = + match bs1 with + | [] -> + let uu___ = FStarC_Syntax_Subst.subst subst t1 in + ((FStarC_Compiler_List.rev bs'), uu___) + | b::bs2 -> + let b1 = + let uu___ = FStarC_Syntax_Subst.subst_binders subst [b] in + match uu___ with + | b2::[] -> b2 + | uu___1 -> failwith "impossible: unshadow subst_binders" in + let uu___ = + ((b1.FStarC_Syntax_Syntax.binder_bv), + (b1.FStarC_Syntax_Syntax.binder_qual)) in + (match uu___ with + | (bv0, q) -> + let nbs = + let uu___1 = + FStarC_Class_Show.show FStarC_Ident.showable_ident + bv0.FStarC_Syntax_Syntax.ppname in + fresh_until uu___1 + (fun s -> + Prims.op_Negation (FStarC_Compiler_List.mem s seen)) in + let bv = sset bv0 nbs in + let b2 = + FStarC_Syntax_Syntax.mk_binder_with_attrs bv q + b1.FStarC_Syntax_Syntax.binder_positivity + b1.FStarC_Syntax_Syntax.binder_attrs in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.bv_to_name bv in + (bv0, uu___5) in + FStarC_Syntax_Syntax.NT uu___4 in + [uu___3] in + FStarC_Compiler_List.op_At subst uu___2 in + go (nbs :: seen) uu___1 bs2 (b2 :: bs') t1) in + go [] [] bs [] t +let (goal_to_string : + Prims.string -> + (Prims.int * Prims.int) FStar_Pervasives_Native.option -> + FStarC_Tactics_Types.proofstate -> + FStarC_Tactics_Types.goal -> Prims.string) + = + fun kind -> + fun maybe_num -> + fun ps -> + fun g -> + let w = + let uu___ = FStarC_Options.print_implicits () in + if uu___ + then + let uu___1 = FStarC_Tactics_Types.goal_env g in + let uu___2 = FStarC_Tactics_Types.goal_witness g in + term_to_string uu___1 uu___2 + else + (let uu___2 = FStarC_Tactics_Types.check_goal_solved' g in + match uu___2 with + | FStar_Pervasives_Native.None -> "_" + | FStar_Pervasives_Native.Some t -> + let uu___3 = FStarC_Tactics_Types.goal_env g in + let uu___4 = FStarC_Tactics_Types.goal_witness g in + term_to_string uu___3 uu___4) in + let num = + match maybe_num with + | FStar_Pervasives_Native.None -> "" + | FStar_Pervasives_Native.Some (i, n) -> + let uu___ = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) i in + let uu___1 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) n in + FStarC_Compiler_Util.format2 " %s/%s" uu___ uu___1 in + let maybe_label = + match g.FStarC_Tactics_Types.label with + | "" -> "" + | l -> Prims.strcat " (" (Prims.strcat l ")") in + let uu___ = + let rename_binders subst bs = + FStarC_Compiler_List.map + (fun uu___1 -> + let x = uu___1.FStarC_Syntax_Syntax.binder_bv in + let y = + let uu___2 = FStarC_Syntax_Syntax.bv_to_name x in + FStarC_Syntax_Subst.subst subst uu___2 in + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress y in + uu___3.FStarC_Syntax_Syntax.n in + match uu___2 with + | FStarC_Syntax_Syntax.Tm_name y1 -> + let uu___3 = + let uu___4 = uu___1.FStarC_Syntax_Syntax.binder_bv in + let uu___5 = + FStarC_Syntax_Subst.subst subst + x.FStarC_Syntax_Syntax.sort in + { + FStarC_Syntax_Syntax.ppname = + (uu___4.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (uu___4.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = uu___5 + } in + { + FStarC_Syntax_Syntax.binder_bv = uu___3; + FStarC_Syntax_Syntax.binder_qual = + (uu___1.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity = + (uu___1.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs = + (uu___1.FStarC_Syntax_Syntax.binder_attrs) + } + | uu___3 -> failwith "Not a renaming") bs in + let goal_binders = + (g.FStarC_Tactics_Types.goal_ctx_uvar).FStarC_Syntax_Syntax.ctx_uvar_binders in + let goal_ty = FStarC_Tactics_Types.goal_type g in + let uu___1 = FStarC_Options.tactic_raw_binders () in + if uu___1 + then (goal_binders, goal_ty) + else + (let subst = + FStarC_TypeChecker_Primops_Base.psc_subst + ps.FStarC_Tactics_Types.psc in + let binders = rename_binders subst goal_binders in + let ty = FStarC_Syntax_Subst.subst subst goal_ty in + (binders, ty)) in + match uu___ with + | (goal_binders, goal_ty) -> + let uu___1 = unshadow goal_binders goal_ty in + (match uu___1 with + | (goal_binders1, goal_ty1) -> + let actual_goal = + if ps.FStarC_Tactics_Types.tac_verb_dbg + then goal_to_string_verbose g + else + (let uu___3 = + let uu___4 = + FStarC_Compiler_List.map + FStarC_Syntax_Print.binder_to_string_with_type + goal_binders1 in + FStarC_Compiler_String.concat ", " uu___4 in + let uu___4 = + let uu___5 = FStarC_Tactics_Types.goal_env g in + term_to_string uu___5 goal_ty1 in + FStarC_Compiler_Util.format3 "%s |- %s : %s\n" uu___3 + w uu___4) in + FStarC_Compiler_Util.format4 "%s%s%s:\n%s\n" kind num + maybe_label actual_goal) +let (ps_to_string : + (Prims.string * FStarC_Tactics_Types.proofstate) -> Prims.string) = + fun uu___ -> + match uu___ with + | (msg, ps) -> + let p_imp imp = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_uvar + (imp.FStarC_TypeChecker_Common.imp_uvar).FStarC_Syntax_Syntax.ctx_uvar_head in + let n_active = + FStarC_Compiler_List.length ps.FStarC_Tactics_Types.goals in + let n_smt = + FStarC_Compiler_List.length ps.FStarC_Tactics_Types.smt_goals in + let n = n_active + n_smt in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + ps.FStarC_Tactics_Types.depth in + FStarC_Compiler_Util.format2 "State dump @ depth %s (%s):\n" + uu___4 msg in + let uu___4 = + let uu___5 = + if + ps.FStarC_Tactics_Types.entry_range <> + FStarC_Compiler_Range_Type.dummyRange + then + let uu___6 = + FStarC_Compiler_Range_Ops.string_of_def_range + ps.FStarC_Tactics_Types.entry_range in + FStarC_Compiler_Util.format1 "Location: %s\n" uu___6 + else "" in + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Compiler_Effect.op_Bang dbg_Imp in + if uu___8 + then + let uu___9 = + (FStarC_Common.string_of_list ()) p_imp + ps.FStarC_Tactics_Types.all_implicits in + FStarC_Compiler_Util.format1 "Imps: %s\n" uu___9 + else "" in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + let uu___3 = + let uu___4 = + FStarC_Compiler_List.mapi + (fun i -> + fun g -> + goal_to_string "Goal" + (FStar_Pervasives_Native.Some ((Prims.int_one + i), n)) + ps g) ps.FStarC_Tactics_Types.goals in + let uu___5 = + FStarC_Compiler_List.mapi + (fun i -> + fun g -> + goal_to_string "SMT Goal" + (FStar_Pervasives_Native.Some + (((Prims.int_one + n_active) + i), n)) ps g) + ps.FStarC_Tactics_Types.smt_goals in + FStarC_Compiler_List.op_At uu___4 uu___5 in + FStarC_Compiler_List.op_At uu___2 uu___3 in + FStarC_Compiler_String.concat "" uu___1 +let (goal_to_json : FStarC_Tactics_Types.goal -> FStarC_Json.json) = + fun g -> + let g_binders = + (g.FStarC_Tactics_Types.goal_ctx_uvar).FStarC_Syntax_Syntax.ctx_uvar_binders in + let g_type = FStarC_Tactics_Types.goal_type g in + let uu___ = unshadow g_binders g_type in + match uu___ with + | (g_binders1, g_type1) -> + let j_binders = + let uu___1 = + let uu___2 = FStarC_Tactics_Types.goal_env g in + FStarC_TypeChecker_Env.dsenv uu___2 in + FStarC_Syntax_Print.binders_to_json uu___1 g_binders1 in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = FStarC_Tactics_Types.goal_env g in + let uu___10 = FStarC_Tactics_Types.goal_witness g in + term_to_string uu___9 uu___10 in + FStarC_Json.JsonStr uu___8 in + ("witness", uu___7) in + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = FStarC_Tactics_Types.goal_env g in + term_to_string uu___11 g_type1 in + FStarC_Json.JsonStr uu___10 in + ("type", uu___9) in + [uu___8; + ("label", + (FStarC_Json.JsonStr (g.FStarC_Tactics_Types.label)))] in + uu___6 :: uu___7 in + FStarC_Json.JsonAssoc uu___5 in + ("goal", uu___4) in + [uu___3] in + ("hyps", j_binders) :: uu___2 in + FStarC_Json.JsonAssoc uu___1 +let (ps_to_json : + (Prims.string * FStarC_Tactics_Types.proofstate) -> FStarC_Json.json) = + fun uu___ -> + match uu___ with + | (msg, ps) -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Compiler_List.map goal_to_json + ps.FStarC_Tactics_Types.goals in + FStarC_Json.JsonList uu___8 in + ("goals", uu___7) in + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Compiler_List.map goal_to_json + ps.FStarC_Tactics_Types.smt_goals in + FStarC_Json.JsonList uu___10 in + ("smt-goals", uu___9) in + [uu___8] in + uu___6 :: uu___7 in + ("urgency", + (FStarC_Json.JsonInt (ps.FStarC_Tactics_Types.urgency))) :: + uu___5 in + ("depth", + (FStarC_Json.JsonInt (ps.FStarC_Tactics_Types.depth))) :: + uu___4 in + ("label", (FStarC_Json.JsonStr msg)) :: uu___3 in + let uu___3 = + if + ps.FStarC_Tactics_Types.entry_range <> + FStarC_Compiler_Range_Type.dummyRange + then + let uu___4 = + let uu___5 = + FStarC_Compiler_Range_Ops.json_of_def_range + ps.FStarC_Tactics_Types.entry_range in + ("location", uu___5) in + [uu___4] + else [] in + FStarC_Compiler_List.op_At uu___2 uu___3 in + FStarC_Json.JsonAssoc uu___1 +let (do_dump_proofstate : + FStarC_Tactics_Types.proofstate -> Prims.string -> unit) = + fun ps -> + fun msg -> + let uu___ = + let uu___1 = FStarC_Options.silent () in Prims.op_Negation uu___1 in + if uu___ + then + FStarC_Options.with_saved_options + (fun uu___1 -> + FStarC_Options.set_option "print_effect_args" + (FStarC_Options.Bool true); + FStarC_Compiler_Util.print_generic "proof-state" ps_to_string + ps_to_json (msg, ps); + FStarC_Compiler_Util.flush_stdout ()) + else () \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Tactics_Result.ml b/ocaml/fstar-lib/generated/FStarC_Tactics_Result.ml new file mode 100644 index 00000000000..8f8513e1daa --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Tactics_Result.ml @@ -0,0 +1,15 @@ +open Prims +type 'a __result = + | Success of ('a * FStarC_Tactics_Types.proofstate) + | Failed of (Prims.exn * FStarC_Tactics_Types.proofstate) +let uu___is_Success : 'a . 'a __result -> Prims.bool = + fun projectee -> match projectee with | Success _0 -> true | uu___ -> false +let __proj__Success__item___0 : + 'a . 'a __result -> ('a * FStarC_Tactics_Types.proofstate) = + fun projectee -> match projectee with | Success _0 -> _0 +let uu___is_Failed : 'a . 'a __result -> Prims.bool = + fun projectee -> match projectee with | Failed _0 -> true | uu___ -> false +let __proj__Failed__item___0 : + 'a . 'a __result -> (Prims.exn * FStarC_Tactics_Types.proofstate) = + fun projectee -> match projectee with | Failed _0 -> _0 +type proofstate = FStarC_Tactics_Types.proofstate \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Tactics_Types.ml b/ocaml/fstar-lib/generated/FStarC_Tactics_Types.ml new file mode 100644 index 00000000000..83b39d3b744 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Tactics_Types.ml @@ -0,0 +1,498 @@ +open Prims +type goal = + { + goal_main_env: FStarC_TypeChecker_Env.env ; + goal_ctx_uvar: FStarC_Syntax_Syntax.ctx_uvar ; + opts: FStarC_Options.optionstate ; + is_guard: Prims.bool ; + label: Prims.string } +let (__proj__Mkgoal__item__goal_main_env : + goal -> FStarC_TypeChecker_Env.env) = + fun projectee -> + match projectee with + | { goal_main_env; goal_ctx_uvar; opts; is_guard; label;_} -> + goal_main_env +let (__proj__Mkgoal__item__goal_ctx_uvar : + goal -> FStarC_Syntax_Syntax.ctx_uvar) = + fun projectee -> + match projectee with + | { goal_main_env; goal_ctx_uvar; opts; is_guard; label;_} -> + goal_ctx_uvar +let (__proj__Mkgoal__item__opts : goal -> FStarC_Options.optionstate) = + fun projectee -> + match projectee with + | { goal_main_env; goal_ctx_uvar; opts; is_guard; label;_} -> opts +let (__proj__Mkgoal__item__is_guard : goal -> Prims.bool) = + fun projectee -> + match projectee with + | { goal_main_env; goal_ctx_uvar; opts; is_guard; label;_} -> is_guard +let (__proj__Mkgoal__item__label : goal -> Prims.string) = + fun projectee -> + match projectee with + | { goal_main_env; goal_ctx_uvar; opts; is_guard; label;_} -> label +type guard_policy = + | Goal + | SMT + | SMTSync + | Force + | ForceSMT + | Drop +let (uu___is_Goal : guard_policy -> Prims.bool) = + fun projectee -> match projectee with | Goal -> true | uu___ -> false +let (uu___is_SMT : guard_policy -> Prims.bool) = + fun projectee -> match projectee with | SMT -> true | uu___ -> false +let (uu___is_SMTSync : guard_policy -> Prims.bool) = + fun projectee -> match projectee with | SMTSync -> true | uu___ -> false +let (uu___is_Force : guard_policy -> Prims.bool) = + fun projectee -> match projectee with | Force -> true | uu___ -> false +let (uu___is_ForceSMT : guard_policy -> Prims.bool) = + fun projectee -> match projectee with | ForceSMT -> true | uu___ -> false +let (uu___is_Drop : guard_policy -> Prims.bool) = + fun projectee -> match projectee with | Drop -> true | uu___ -> false +type proofstate = + { + main_context: FStarC_TypeChecker_Env.env ; + all_implicits: FStarC_TypeChecker_Common.implicits ; + goals: goal Prims.list ; + smt_goals: goal Prims.list ; + depth: Prims.int ; + __dump: proofstate -> Prims.string -> unit ; + psc: FStarC_TypeChecker_Primops_Base.psc ; + entry_range: FStarC_Compiler_Range_Type.range ; + guard_policy: guard_policy ; + freshness: Prims.int ; + tac_verb_dbg: Prims.bool ; + local_state: FStarC_Syntax_Syntax.term FStarC_Compiler_Util.psmap ; + urgency: Prims.int ; + dump_on_failure: Prims.bool } +let (__proj__Mkproofstate__item__main_context : + proofstate -> FStarC_TypeChecker_Env.env) = + fun projectee -> + match projectee with + | { main_context; all_implicits; goals; smt_goals; depth; __dump; + psc; entry_range; guard_policy = guard_policy1; freshness; + tac_verb_dbg; local_state; urgency; dump_on_failure;_} -> + main_context +let (__proj__Mkproofstate__item__all_implicits : + proofstate -> FStarC_TypeChecker_Common.implicits) = + fun projectee -> + match projectee with + | { main_context; all_implicits; goals; smt_goals; depth; __dump; + psc; entry_range; guard_policy = guard_policy1; freshness; + tac_verb_dbg; local_state; urgency; dump_on_failure;_} -> + all_implicits +let (__proj__Mkproofstate__item__goals : proofstate -> goal Prims.list) = + fun projectee -> + match projectee with + | { main_context; all_implicits; goals; smt_goals; depth; __dump; + psc; entry_range; guard_policy = guard_policy1; freshness; + tac_verb_dbg; local_state; urgency; dump_on_failure;_} -> goals +let (__proj__Mkproofstate__item__smt_goals : proofstate -> goal Prims.list) = + fun projectee -> + match projectee with + | { main_context; all_implicits; goals; smt_goals; depth; __dump; + psc; entry_range; guard_policy = guard_policy1; freshness; + tac_verb_dbg; local_state; urgency; dump_on_failure;_} -> smt_goals +let (__proj__Mkproofstate__item__depth : proofstate -> Prims.int) = + fun projectee -> + match projectee with + | { main_context; all_implicits; goals; smt_goals; depth; __dump; + psc; entry_range; guard_policy = guard_policy1; freshness; + tac_verb_dbg; local_state; urgency; dump_on_failure;_} -> depth +let (__proj__Mkproofstate__item____dump : + proofstate -> proofstate -> Prims.string -> unit) = + fun projectee -> + match projectee with + | { main_context; all_implicits; goals; smt_goals; depth; __dump; + psc; entry_range; guard_policy = guard_policy1; freshness; + tac_verb_dbg; local_state; urgency; dump_on_failure;_} -> __dump +let (__proj__Mkproofstate__item__psc : + proofstate -> FStarC_TypeChecker_Primops_Base.psc) = + fun projectee -> + match projectee with + | { main_context; all_implicits; goals; smt_goals; depth; __dump; + psc; entry_range; guard_policy = guard_policy1; freshness; + tac_verb_dbg; local_state; urgency; dump_on_failure;_} -> psc +let (__proj__Mkproofstate__item__entry_range : + proofstate -> FStarC_Compiler_Range_Type.range) = + fun projectee -> + match projectee with + | { main_context; all_implicits; goals; smt_goals; depth; __dump; + psc; entry_range; guard_policy = guard_policy1; freshness; + tac_verb_dbg; local_state; urgency; dump_on_failure;_} -> entry_range +let (__proj__Mkproofstate__item__guard_policy : proofstate -> guard_policy) = + fun projectee -> + match projectee with + | { main_context; all_implicits; goals; smt_goals; depth; __dump; + psc; entry_range; guard_policy = guard_policy1; freshness; + tac_verb_dbg; local_state; urgency; dump_on_failure;_} -> + guard_policy1 +let (__proj__Mkproofstate__item__freshness : proofstate -> Prims.int) = + fun projectee -> + match projectee with + | { main_context; all_implicits; goals; smt_goals; depth; __dump; + psc; entry_range; guard_policy = guard_policy1; freshness; + tac_verb_dbg; local_state; urgency; dump_on_failure;_} -> freshness +let (__proj__Mkproofstate__item__tac_verb_dbg : proofstate -> Prims.bool) = + fun projectee -> + match projectee with + | { main_context; all_implicits; goals; smt_goals; depth; __dump; + psc; entry_range; guard_policy = guard_policy1; freshness; + tac_verb_dbg; local_state; urgency; dump_on_failure;_} -> + tac_verb_dbg +let (__proj__Mkproofstate__item__local_state : + proofstate -> FStarC_Syntax_Syntax.term FStarC_Compiler_Util.psmap) = + fun projectee -> + match projectee with + | { main_context; all_implicits; goals; smt_goals; depth; __dump; + psc; entry_range; guard_policy = guard_policy1; freshness; + tac_verb_dbg; local_state; urgency; dump_on_failure;_} -> local_state +let (__proj__Mkproofstate__item__urgency : proofstate -> Prims.int) = + fun projectee -> + match projectee with + | { main_context; all_implicits; goals; smt_goals; depth; __dump; + psc; entry_range; guard_policy = guard_policy1; freshness; + tac_verb_dbg; local_state; urgency; dump_on_failure;_} -> urgency +let (__proj__Mkproofstate__item__dump_on_failure : proofstate -> Prims.bool) + = + fun projectee -> + match projectee with + | { main_context; all_implicits; goals; smt_goals; depth; __dump; + psc; entry_range; guard_policy = guard_policy1; freshness; + tac_verb_dbg; local_state; urgency; dump_on_failure;_} -> + dump_on_failure +let (goal_env : goal -> FStarC_TypeChecker_Env.env) = + fun g -> g.goal_main_env +let (goal_range : goal -> FStarC_Compiler_Range_Type.range) = + fun g -> (g.goal_main_env).FStarC_TypeChecker_Env.range +let (goal_witness : goal -> FStarC_Syntax_Syntax.term) = + fun g -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_uvar + ((g.goal_ctx_uvar), ([], FStarC_Syntax_Syntax.NoUseRange))) + FStarC_Compiler_Range_Type.dummyRange +let (goal_type : goal -> FStarC_Syntax_Syntax.term) = + fun g -> FStarC_Syntax_Util.ctx_uvar_typ g.goal_ctx_uvar +let (goal_opts : goal -> FStarC_Options.optionstate) = fun g -> g.opts +let (goal_with_env : goal -> FStarC_TypeChecker_Env.env -> goal) = + fun g -> + fun env -> + let c = g.goal_ctx_uvar in + let c' = + let uu___ = FStarC_TypeChecker_Env.all_binders env in + { + FStarC_Syntax_Syntax.ctx_uvar_head = + (c.FStarC_Syntax_Syntax.ctx_uvar_head); + FStarC_Syntax_Syntax.ctx_uvar_gamma = + (env.FStarC_TypeChecker_Env.gamma); + FStarC_Syntax_Syntax.ctx_uvar_binders = uu___; + FStarC_Syntax_Syntax.ctx_uvar_reason = + (c.FStarC_Syntax_Syntax.ctx_uvar_reason); + FStarC_Syntax_Syntax.ctx_uvar_range = + (c.FStarC_Syntax_Syntax.ctx_uvar_range); + FStarC_Syntax_Syntax.ctx_uvar_meta = + (c.FStarC_Syntax_Syntax.ctx_uvar_meta) + } in + { + goal_main_env = env; + goal_ctx_uvar = c'; + opts = (g.opts); + is_guard = (g.is_guard); + label = (g.label) + } +let (goal_of_ctx_uvar : goal -> FStarC_Syntax_Syntax.ctx_uvar -> goal) = + fun g -> + fun ctx_u -> + { + goal_main_env = (g.goal_main_env); + goal_ctx_uvar = ctx_u; + opts = (g.opts); + is_guard = (g.is_guard); + label = (g.label) + } +let (mk_goal : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.ctx_uvar -> + FStarC_Options.optionstate -> Prims.bool -> Prims.string -> goal) + = + fun env -> + fun u -> + fun o -> + fun b -> + fun l -> + { + goal_main_env = env; + goal_ctx_uvar = u; + opts = o; + is_guard = b; + label = l + } +let (goal_of_goal_ty : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> (goal * FStarC_TypeChecker_Common.guard_t)) + = + fun env -> + fun typ -> + let uu___ = + FStarC_TypeChecker_Env.new_implicit_var_aux "proofstate_of_goal_ty" + typ.FStarC_Syntax_Syntax.pos env typ FStarC_Syntax_Syntax.Strict + FStar_Pervasives_Native.None false in + match uu___ with + | (u, (ctx_uvar, uu___1), g_u) -> + let g = + let uu___2 = FStarC_Options.peek () in + mk_goal env ctx_uvar uu___2 false "" in + (g, g_u) +let (goal_of_implicit : + FStarC_TypeChecker_Env.env -> FStarC_TypeChecker_Common.implicit -> goal) = + fun env -> + fun i -> + let uu___ = FStarC_Options.peek () in + mk_goal + { + FStarC_TypeChecker_Env.solver = (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + ((i.FStarC_TypeChecker_Common.imp_uvar).FStarC_Syntax_Syntax.ctx_uvar_gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = (env.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env.FStarC_TypeChecker_Env.missing_decl) + } i.FStarC_TypeChecker_Common.imp_uvar uu___ false + i.FStarC_TypeChecker_Common.imp_reason +let (decr_depth : proofstate -> proofstate) = + fun ps -> + { + main_context = (ps.main_context); + all_implicits = (ps.all_implicits); + goals = (ps.goals); + smt_goals = (ps.smt_goals); + depth = (ps.depth - Prims.int_one); + __dump = (ps.__dump); + psc = (ps.psc); + entry_range = (ps.entry_range); + guard_policy = (ps.guard_policy); + freshness = (ps.freshness); + tac_verb_dbg = (ps.tac_verb_dbg); + local_state = (ps.local_state); + urgency = (ps.urgency); + dump_on_failure = (ps.dump_on_failure) + } +let (incr_depth : proofstate -> proofstate) = + fun ps -> + { + main_context = (ps.main_context); + all_implicits = (ps.all_implicits); + goals = (ps.goals); + smt_goals = (ps.smt_goals); + depth = (ps.depth + Prims.int_one); + __dump = (ps.__dump); + psc = (ps.psc); + entry_range = (ps.entry_range); + guard_policy = (ps.guard_policy); + freshness = (ps.freshness); + tac_verb_dbg = (ps.tac_verb_dbg); + local_state = (ps.local_state); + urgency = (ps.urgency); + dump_on_failure = (ps.dump_on_failure) + } +let (set_ps_psc : + FStarC_TypeChecker_Primops_Base.psc -> proofstate -> proofstate) = + fun psc -> + fun ps -> + { + main_context = (ps.main_context); + all_implicits = (ps.all_implicits); + goals = (ps.goals); + smt_goals = (ps.smt_goals); + depth = (ps.depth); + __dump = (ps.__dump); + psc; + entry_range = (ps.entry_range); + guard_policy = (ps.guard_policy); + freshness = (ps.freshness); + tac_verb_dbg = (ps.tac_verb_dbg); + local_state = (ps.local_state); + urgency = (ps.urgency); + dump_on_failure = (ps.dump_on_failure) + } +let (tracepoint_with_psc : + FStarC_TypeChecker_Primops_Base.psc -> proofstate -> Prims.bool) = + fun psc -> + fun ps -> + (let uu___1 = + (FStarC_Options.tactic_trace ()) || + (let uu___2 = FStarC_Options.tactic_trace_d () in + ps.depth <= uu___2) in + if uu___1 + then let ps1 = set_ps_psc psc ps in ps1.__dump ps1 "TRACE" + else ()); + true +let (tracepoint : proofstate -> Prims.bool) = + fun ps -> + (let uu___1 = + (FStarC_Options.tactic_trace ()) || + (let uu___2 = FStarC_Options.tactic_trace_d () in ps.depth <= uu___2) in + if uu___1 then ps.__dump ps "TRACE" else ()); + true +let (set_proofstate_range : + proofstate -> FStarC_Compiler_Range_Type.range -> proofstate) = + fun ps -> + fun r -> + let uu___ = + let uu___1 = FStarC_Compiler_Range_Type.def_range r in + FStarC_Compiler_Range_Type.set_def_range ps.entry_range uu___1 in + { + main_context = (ps.main_context); + all_implicits = (ps.all_implicits); + goals = (ps.goals); + smt_goals = (ps.smt_goals); + depth = (ps.depth); + __dump = (ps.__dump); + psc = (ps.psc); + entry_range = uu___; + guard_policy = (ps.guard_policy); + freshness = (ps.freshness); + tac_verb_dbg = (ps.tac_verb_dbg); + local_state = (ps.local_state); + urgency = (ps.urgency); + dump_on_failure = (ps.dump_on_failure) + } +let (goals_of : proofstate -> goal Prims.list) = fun ps -> ps.goals +let (smt_goals_of : proofstate -> goal Prims.list) = fun ps -> ps.smt_goals +let (is_guard : goal -> Prims.bool) = fun g -> g.is_guard +let (get_label : goal -> Prims.string) = fun g -> g.label +let (set_label : Prims.string -> goal -> goal) = + fun l -> + fun g -> + { + goal_main_env = (g.goal_main_env); + goal_ctx_uvar = (g.goal_ctx_uvar); + opts = (g.opts); + is_guard = (g.is_guard); + label = l + } +type ctrl_flag = + | Continue + | Skip + | Abort +let (uu___is_Continue : ctrl_flag -> Prims.bool) = + fun projectee -> match projectee with | Continue -> true | uu___ -> false +let (uu___is_Skip : ctrl_flag -> Prims.bool) = + fun projectee -> match projectee with | Skip -> true | uu___ -> false +let (uu___is_Abort : ctrl_flag -> Prims.bool) = + fun projectee -> match projectee with | Abort -> true | uu___ -> false +type direction = + | TopDown + | BottomUp +let (uu___is_TopDown : direction -> Prims.bool) = + fun projectee -> match projectee with | TopDown -> true | uu___ -> false +let (uu___is_BottomUp : direction -> Prims.bool) = + fun projectee -> match projectee with | BottomUp -> true | uu___ -> false +let (check_goal_solved' : + goal -> FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) = + fun goal1 -> + let uu___ = + FStarC_Syntax_Unionfind.find + (goal1.goal_ctx_uvar).FStarC_Syntax_Syntax.ctx_uvar_head in + match uu___ with + | FStar_Pervasives_Native.Some t -> FStar_Pervasives_Native.Some t + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None +let (check_goal_solved : goal -> Prims.bool) = + fun goal1 -> + let uu___ = check_goal_solved' goal1 in + FStarC_Compiler_Option.isSome uu___ +type 'a tref = 'a FStarC_Compiler_Effect.ref +type ('g, 't) non_informative_token = unit +type ('g, 't0, 't1) subtyping_token = unit +type ('g, 't0, 't1) equiv_token = unit +type ('g, 'e, 'c) typing_token = unit +type ('g, 'sc, 't, 'pats) match_complete_token = unit \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Tactics_V1_Basic.ml b/ocaml/fstar-lib/generated/FStarC_Tactics_V1_Basic.ml new file mode 100644 index 00000000000..39878e68e2d --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Tactics_V1_Basic.ml @@ -0,0 +1,9495 @@ +open Prims +let (dbg_2635 : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "2635" +let (dbg_ReflTc : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "ReflTc" +let (dbg_Tac : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Tac" +let (dbg_TacUnify : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "TacUnify" +let ret : 'a . 'a -> 'a FStarC_Tactics_Monad.tac = + fun uu___ -> + (fun x -> + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () + (Obj.magic x))) uu___ +let bind : + 'a 'b . + unit -> + 'a FStarC_Tactics_Monad.tac -> + ('a -> 'b FStarC_Tactics_Monad.tac) -> 'b FStarC_Tactics_Monad.tac + = + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun uu___ -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac + () ())) uu___2 uu___1 uu___ +let (idtac : unit FStarC_Tactics_Monad.tac) = + FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () (Obj.repr ()) +let (get_phi : + FStarC_Tactics_Types.goal -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = + fun g -> + let uu___ = + let uu___1 = FStarC_Tactics_Types.goal_env g in + let uu___2 = FStarC_Tactics_Types.goal_type g in + FStarC_TypeChecker_Normalize.unfold_whnf uu___1 uu___2 in + FStarC_Syntax_Util.un_squash uu___ +let (is_irrelevant : FStarC_Tactics_Types.goal -> Prims.bool) = + fun g -> let uu___ = get_phi g in FStarC_Compiler_Option.isSome uu___ +let (core_check : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.typ -> + Prims.bool -> + (FStarC_Syntax_Syntax.typ FStar_Pervasives_Native.option, + FStarC_TypeChecker_Core.error) FStar_Pervasives.either) + = + fun env -> + fun sol -> + fun t -> + fun must_tot -> + let uu___ = + let uu___1 = FStarC_Options.compat_pre_core_should_check () in + Prims.op_Negation uu___1 in + if uu___ + then FStar_Pervasives.Inl FStar_Pervasives_Native.None + else + (let debug f = + let uu___2 = FStarC_Compiler_Debug.any () in + if uu___2 then f () else () in + let uu___2 = + FStarC_TypeChecker_Core.check_term env sol t must_tot in + match uu___2 with + | FStar_Pervasives.Inl (FStar_Pervasives_Native.None) -> + FStar_Pervasives.Inl FStar_Pervasives_Native.None + | FStar_Pervasives.Inl (FStar_Pervasives_Native.Some g) -> + let uu___3 = FStarC_Options.compat_pre_core_set () in + if uu___3 + then FStar_Pervasives.Inl FStar_Pervasives_Native.None + else FStar_Pervasives.Inl (FStar_Pervasives_Native.Some g) + | FStar_Pervasives.Inr err -> + (debug + (fun uu___4 -> + let uu___5 = + let uu___6 = FStarC_TypeChecker_Env.get_range env in + FStarC_Class_Show.show + FStarC_Compiler_Range_Ops.showable_range uu___6 in + let uu___6 = + FStarC_TypeChecker_Core.print_error_short err in + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term sol in + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + let uu___9 = FStarC_TypeChecker_Core.print_error err in + FStarC_Compiler_Util.print5 + "(%s) Core checking failed (%s) on term %s and type %s\n%s\n" + uu___5 uu___6 uu___7 uu___8 uu___9); + FStar_Pervasives.Inr err)) +type name = FStarC_Syntax_Syntax.bv +type env = FStarC_TypeChecker_Env.env +type implicits = FStarC_TypeChecker_Env.implicits +let (rangeof : FStarC_Tactics_Types.goal -> FStarC_Compiler_Range_Type.range) + = + fun g -> + (g.FStarC_Tactics_Types.goal_ctx_uvar).FStarC_Syntax_Syntax.ctx_uvar_range +let (normalize : + FStarC_TypeChecker_Env.steps -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = fun s -> fun e -> fun t -> FStarC_TypeChecker_Normalize.normalize s e t +let (bnorm : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = fun e -> fun t -> normalize [] e t +let (whnf : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = fun e -> fun t -> FStarC_TypeChecker_Normalize.unfold_whnf e t +let (tts : + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.term -> Prims.string) = + FStarC_TypeChecker_Normalize.term_to_string +let (set_uvar_expected_typ : + FStarC_Syntax_Syntax.ctx_uvar -> FStarC_Syntax_Syntax.typ -> unit) = + fun u -> + fun t -> + let dec = + FStarC_Syntax_Unionfind.find_decoration + u.FStarC_Syntax_Syntax.ctx_uvar_head in + FStarC_Syntax_Unionfind.change_decoration + u.FStarC_Syntax_Syntax.ctx_uvar_head + { + FStarC_Syntax_Syntax.uvar_decoration_typ = t; + FStarC_Syntax_Syntax.uvar_decoration_typedness_depends_on = + (dec.FStarC_Syntax_Syntax.uvar_decoration_typedness_depends_on); + FStarC_Syntax_Syntax.uvar_decoration_should_check = + (dec.FStarC_Syntax_Syntax.uvar_decoration_should_check); + FStarC_Syntax_Syntax.uvar_decoration_should_unrefine = + (dec.FStarC_Syntax_Syntax.uvar_decoration_should_unrefine) + } +let (mark_uvar_with_should_check_tag : + FStarC_Syntax_Syntax.ctx_uvar -> + FStarC_Syntax_Syntax.should_check_uvar -> unit) + = + fun u -> + fun sc -> + let dec = + FStarC_Syntax_Unionfind.find_decoration + u.FStarC_Syntax_Syntax.ctx_uvar_head in + FStarC_Syntax_Unionfind.change_decoration + u.FStarC_Syntax_Syntax.ctx_uvar_head + { + FStarC_Syntax_Syntax.uvar_decoration_typ = + (dec.FStarC_Syntax_Syntax.uvar_decoration_typ); + FStarC_Syntax_Syntax.uvar_decoration_typedness_depends_on = + (dec.FStarC_Syntax_Syntax.uvar_decoration_typedness_depends_on); + FStarC_Syntax_Syntax.uvar_decoration_should_check = sc; + FStarC_Syntax_Syntax.uvar_decoration_should_unrefine = + (dec.FStarC_Syntax_Syntax.uvar_decoration_should_unrefine) + } +let (mark_uvar_as_already_checked : FStarC_Syntax_Syntax.ctx_uvar -> unit) = + fun u -> + mark_uvar_with_should_check_tag u FStarC_Syntax_Syntax.Already_checked +let (mark_goal_implicit_already_checked : FStarC_Tactics_Types.goal -> unit) + = + fun g -> mark_uvar_as_already_checked g.FStarC_Tactics_Types.goal_ctx_uvar +let (goal_with_type : + FStarC_Tactics_Types.goal -> + FStarC_Syntax_Syntax.typ -> FStarC_Tactics_Types.goal) + = + fun g -> + fun t -> + let u = g.FStarC_Tactics_Types.goal_ctx_uvar in + set_uvar_expected_typ u t; g +let (bnorm_goal : FStarC_Tactics_Types.goal -> FStarC_Tactics_Types.goal) = + fun g -> + let uu___ = + let uu___1 = FStarC_Tactics_Types.goal_env g in + let uu___2 = FStarC_Tactics_Types.goal_type g in bnorm uu___1 uu___2 in + goal_with_type g uu___ +let (tacprint : Prims.string -> unit) = + fun s -> FStarC_Compiler_Util.print1 "TAC>> %s\n" s +let (tacprint1 : Prims.string -> Prims.string -> unit) = + fun s -> + fun x -> + let uu___ = FStarC_Compiler_Util.format1 s x in + FStarC_Compiler_Util.print1 "TAC>> %s\n" uu___ +let (tacprint2 : Prims.string -> Prims.string -> Prims.string -> unit) = + fun s -> + fun x -> + fun y -> + let uu___ = FStarC_Compiler_Util.format2 s x y in + FStarC_Compiler_Util.print1 "TAC>> %s\n" uu___ +let (tacprint3 : + Prims.string -> Prims.string -> Prims.string -> Prims.string -> unit) = + fun s -> + fun x -> + fun y -> + fun z -> + let uu___ = FStarC_Compiler_Util.format3 s x y z in + FStarC_Compiler_Util.print1 "TAC>> %s\n" uu___ +let (print : Prims.string -> unit FStarC_Tactics_Monad.tac) = + fun msg -> + (let uu___1 = + let uu___2 = FStarC_Options.silent () in Prims.op_Negation uu___2 in + if uu___1 then tacprint msg else ()); + ret () +let (debugging : unit -> Prims.bool FStarC_Tactics_Monad.tac) = + fun uu___ -> + let uu___1 = bind () in + uu___1 FStarC_Tactics_Monad.get + (fun ps -> + let uu___2 = FStarC_Compiler_Effect.op_Bang dbg_Tac in ret uu___2) +let (do_dump_ps : Prims.string -> FStarC_Tactics_Types.proofstate -> unit) = + fun msg -> + fun ps -> + let psc = ps.FStarC_Tactics_Types.psc in + let subst = FStarC_TypeChecker_Primops_Base.psc_subst psc in + FStarC_Tactics_Printing.do_dump_proofstate ps msg +let (dump : Prims.string -> unit FStarC_Tactics_Monad.tac) = + fun msg -> + FStarC_Tactics_Monad.mk_tac + (fun ps -> do_dump_ps msg ps; FStarC_Tactics_Result.Success ((), ps)) +let (dump_all : Prims.bool -> Prims.string -> unit FStarC_Tactics_Monad.tac) + = + fun print_resolved -> + fun msg -> + FStarC_Tactics_Monad.mk_tac + (fun ps -> + let gs = + FStarC_Compiler_List.map + (fun i -> + FStarC_Tactics_Types.goal_of_implicit + ps.FStarC_Tactics_Types.main_context i) + ps.FStarC_Tactics_Types.all_implicits in + let gs1 = + if print_resolved + then gs + else + FStarC_Compiler_List.filter + (fun g -> + let uu___1 = FStarC_Tactics_Types.check_goal_solved g in + Prims.op_Negation uu___1) gs in + let ps' = + { + FStarC_Tactics_Types.main_context = + (ps.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits = + (ps.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = gs1; + FStarC_Tactics_Types.smt_goals = []; + FStarC_Tactics_Types.depth = (ps.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = (ps.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = (ps.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (ps.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = + (ps.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness = + (ps.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg = + (ps.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = + (ps.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency = + (ps.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure = + (ps.FStarC_Tactics_Types.dump_on_failure) + } in + do_dump_ps msg ps'; FStarC_Tactics_Result.Success ((), ps)) +let (dump_uvars_of : + FStarC_Tactics_Types.goal -> Prims.string -> unit FStarC_Tactics_Monad.tac) + = + fun g -> + fun msg -> + FStarC_Tactics_Monad.mk_tac + (fun ps -> + let uvs = + let uu___ = + let uu___1 = FStarC_Tactics_Types.goal_type g in + FStarC_Syntax_Free.uvars uu___1 in + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) (Obj.magic uu___) in + let gs = + FStarC_Compiler_List.map + (FStarC_Tactics_Types.goal_of_ctx_uvar g) uvs in + let gs1 = + FStarC_Compiler_List.filter + (fun g1 -> + let uu___ = FStarC_Tactics_Types.check_goal_solved g1 in + Prims.op_Negation uu___) gs in + let ps' = + { + FStarC_Tactics_Types.main_context = + (ps.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits = + (ps.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = gs1; + FStarC_Tactics_Types.smt_goals = []; + FStarC_Tactics_Types.depth = (ps.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = (ps.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = (ps.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (ps.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = + (ps.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness = + (ps.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg = + (ps.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = + (ps.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency = + (ps.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure = + (ps.FStarC_Tactics_Types.dump_on_failure) + } in + do_dump_ps msg ps'; FStarC_Tactics_Result.Success ((), ps)) +let fail1 : + 'uuuuu . Prims.string -> Prims.string -> 'uuuuu FStarC_Tactics_Monad.tac = + fun msg -> + fun x -> + let uu___ = FStarC_Compiler_Util.format1 msg x in + FStarC_Tactics_Monad.fail uu___ +let fail2 : + 'uuuuu . + Prims.string -> + Prims.string -> Prims.string -> 'uuuuu FStarC_Tactics_Monad.tac + = + fun msg -> + fun x -> + fun y -> + let uu___ = FStarC_Compiler_Util.format2 msg x y in + FStarC_Tactics_Monad.fail uu___ +let fail3 : + 'uuuuu . + Prims.string -> + Prims.string -> + Prims.string -> Prims.string -> 'uuuuu FStarC_Tactics_Monad.tac + = + fun msg -> + fun x -> + fun y -> + fun z -> + let uu___ = FStarC_Compiler_Util.format3 msg x y z in + FStarC_Tactics_Monad.fail uu___ +let fail4 : + 'uuuuu . + Prims.string -> + Prims.string -> + Prims.string -> + Prims.string -> Prims.string -> 'uuuuu FStarC_Tactics_Monad.tac + = + fun msg -> + fun x -> + fun y -> + fun z -> + fun w -> + let uu___ = FStarC_Compiler_Util.format4 msg x y z w in + FStarC_Tactics_Monad.fail uu___ +let (destruct_eq' : + FStarC_Syntax_Syntax.typ -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.term) + FStar_Pervasives_Native.option) + = + fun typ -> + let uu___ = FStarC_Syntax_Formula.destruct_typ_as_formula typ in + match uu___ with + | FStar_Pervasives_Native.Some (FStarC_Syntax_Formula.BaseConn + (l, + uu___1::(e1, FStar_Pervasives_Native.None)::(e2, + FStar_Pervasives_Native.None)::[])) + when + (FStarC_Ident.lid_equals l FStarC_Parser_Const.eq2_lid) || + (FStarC_Ident.lid_equals l FStarC_Parser_Const.c_eq2_lid) + -> FStar_Pervasives_Native.Some (e1, e2) + | uu___1 -> + let uu___2 = FStarC_Syntax_Util.unb2t typ in + (match uu___2 with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some t -> + let uu___3 = FStarC_Syntax_Util.head_and_args t in + (match uu___3 with + | (hd, args) -> + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Syntax_Subst.compress hd in + uu___6.FStarC_Syntax_Syntax.n in + (uu___5, args) in + (match uu___4 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (uu___5, FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = uu___6;_}):: + (e1, FStar_Pervasives_Native.None)::(e2, + FStar_Pervasives_Native.None)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.op_Eq + -> FStar_Pervasives_Native.Some (e1, e2) + | uu___5 -> FStar_Pervasives_Native.None))) +let (destruct_eq : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.term) + FStar_Pervasives_Native.option) + = + fun env1 -> + fun typ -> + let typ1 = whnf env1 typ in + let uu___ = destruct_eq' typ1 in + match uu___ with + | FStar_Pervasives_Native.Some t -> FStar_Pervasives_Native.Some t + | FStar_Pervasives_Native.None -> + let uu___1 = FStarC_Syntax_Util.un_squash typ1 in + (match uu___1 with + | FStar_Pervasives_Native.Some typ2 -> + let typ3 = whnf env1 typ2 in destruct_eq' typ3 + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None) +let (get_guard_policy : + unit -> FStarC_Tactics_Types.guard_policy FStarC_Tactics_Monad.tac) = + fun uu___ -> + let uu___1 = bind () in + uu___1 FStarC_Tactics_Monad.get + (fun ps -> ret ps.FStarC_Tactics_Types.guard_policy) +let (set_guard_policy : + FStarC_Tactics_Types.guard_policy -> unit FStarC_Tactics_Monad.tac) = + fun pol -> + let uu___ = bind () in + uu___ FStarC_Tactics_Monad.get + (fun ps -> + FStarC_Tactics_Monad.set + { + FStarC_Tactics_Types.main_context = + (ps.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits = + (ps.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = (ps.FStarC_Tactics_Types.goals); + FStarC_Tactics_Types.smt_goals = + (ps.FStarC_Tactics_Types.smt_goals); + FStarC_Tactics_Types.depth = (ps.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = (ps.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = (ps.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (ps.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = pol; + FStarC_Tactics_Types.freshness = + (ps.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg = + (ps.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = + (ps.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency = (ps.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure = + (ps.FStarC_Tactics_Types.dump_on_failure) + }) +let with_policy : + 'a . + FStarC_Tactics_Types.guard_policy -> + 'a FStarC_Tactics_Monad.tac -> 'a FStarC_Tactics_Monad.tac + = + fun pol -> + fun t -> + let uu___ = get_guard_policy () in + let uu___1 = bind () in + uu___1 uu___ + (fun old_pol -> + let uu___2 = set_guard_policy pol in + let uu___3 = bind () in + uu___3 uu___2 + (fun uu___4 -> + let uu___5 = bind () in + uu___5 t + (fun r -> + let uu___6 = set_guard_policy old_pol in + let uu___7 = bind () in + uu___7 uu___6 (fun uu___8 -> ret r)))) +let (proc_guard' : + Prims.bool -> + Prims.string -> + env -> + FStarC_TypeChecker_Common.guard_t -> + FStarC_Syntax_Syntax.should_check_uvar + FStar_Pervasives_Native.option -> + FStarC_Compiler_Range_Type.range -> unit FStarC_Tactics_Monad.tac) + = + fun simplify -> + fun reason -> + fun e -> + fun g -> + fun sc_opt -> + fun rng -> + FStarC_Tactics_Monad.mlog + (fun uu___ -> + let uu___1 = FStarC_TypeChecker_Rel.guard_to_string e g in + FStarC_Compiler_Util.print2 "Processing guard (%s:%s)\n" + reason uu___1) + (fun uu___ -> + let imps = + FStarC_Class_Listlike.to_list + (FStarC_Compiler_CList.listlike_clist ()) + g.FStarC_TypeChecker_Common.implicits in + (match sc_opt with + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Allow_untyped r) -> + FStarC_Compiler_List.iter + (fun imp -> + mark_uvar_with_should_check_tag + imp.FStarC_TypeChecker_Common.imp_uvar + (FStarC_Syntax_Syntax.Allow_untyped r)) imps + | uu___2 -> ()); + (let uu___2 = FStarC_Tactics_Monad.add_implicits imps in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () uu___2 + (fun uu___3 -> + (fun uu___3 -> + let uu___3 = Obj.magic uu___3 in + let guard_f = + if simplify + then + let uu___4 = + FStarC_TypeChecker_Rel.simplify_guard e g in + uu___4.FStarC_TypeChecker_Common.guard_f + else g.FStarC_TypeChecker_Common.guard_f in + match guard_f with + | FStarC_TypeChecker_Common.Trivial -> + Obj.magic (ret ()) + | FStarC_TypeChecker_Common.NonTrivial f -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___4 -> + (fun ps -> + let ps = Obj.magic ps in + match ps.FStarC_Tactics_Types.guard_policy + with + | FStarC_Tactics_Types.Drop -> + ((let uu___5 = + let uu___6 = + FStarC_TypeChecker_Rel.guard_to_string + e g in + FStarC_Compiler_Util.format1 + "Tactics admitted guard <%s>\n\n" + uu___6 in + FStarC_Errors.log_issue + FStarC_TypeChecker_Env.hasRange_env + e + FStarC_Errors_Codes.Warning_TacAdmit + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___5)); + Obj.magic (ret ())) + | FStarC_Tactics_Types.Goal -> + Obj.magic + (FStarC_Tactics_Monad.mlog + (fun uu___4 -> + let uu___5 = + FStarC_TypeChecker_Rel.guard_to_string + e g in + FStarC_Compiler_Util.print2 + "Making guard (%s:%s) into a goal\n" + reason uu___5) + (fun uu___4 -> + let uu___5 = + FStarC_Tactics_Monad.goal_of_guard + reason e f sc_opt + rng in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic uu___5) + (fun uu___6 -> + (fun g1 -> + let g1 = + Obj.magic g1 in + Obj.magic + (FStarC_Tactics_Monad.push_goals + [g1])) + uu___6))) + | FStarC_Tactics_Types.SMT -> + Obj.magic + (FStarC_Tactics_Monad.mlog + (fun uu___4 -> + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + f in + FStarC_Compiler_Util.print2 + "Pushing guard (%s:%s) as SMT goal\n" + reason uu___5) + (fun uu___4 -> + let uu___5 = + FStarC_Tactics_Monad.goal_of_guard + reason e f sc_opt + rng in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic uu___5) + (fun uu___6 -> + (fun g1 -> + let g1 = + Obj.magic g1 in + Obj.magic + (FStarC_Tactics_Monad.push_smt_goals + [g1])) + uu___6))) + | FStarC_Tactics_Types.SMTSync -> + Obj.magic + (FStarC_Tactics_Monad.mlog + (fun uu___4 -> + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + f in + FStarC_Compiler_Util.print2 + "Sending guard (%s:%s) to SMT Synchronously\n" + reason uu___5) + (fun uu___4 -> + FStarC_TypeChecker_Rel.force_trivial_guard + e g; + ret ())) + | FStarC_Tactics_Types.Force -> + Obj.magic + (FStarC_Tactics_Monad.mlog + (fun uu___4 -> + let uu___5 = + FStarC_TypeChecker_Rel.guard_to_string + e g in + FStarC_Compiler_Util.print2 + "Forcing guard (%s:%s)\n" + reason uu___5) + (fun uu___4 -> + try + (fun uu___5 -> + match () with + | () -> + let uu___6 = + let uu___7 + = + let uu___8 + = + FStarC_TypeChecker_Rel.discharge_guard_no_smt + e g in + FStarC_TypeChecker_Env.is_trivial + uu___8 in + Prims.op_Negation + uu___7 in + if uu___6 + then + FStarC_Tactics_Monad.mlog + ( + fun + uu___7 -> + let uu___8 + = + FStarC_TypeChecker_Rel.guard_to_string + e g in + FStarC_Compiler_Util.print1 + "guard = %s\n" + uu___8) + ( + fun + uu___7 -> + fail1 + "Forcing the guard failed (%s)" + reason) + else ret ()) + () + with + | uu___5 -> + FStarC_Tactics_Monad.mlog + (fun uu___6 -> + let uu___7 = + FStarC_TypeChecker_Rel.guard_to_string + e g in + FStarC_Compiler_Util.print1 + "guard = %s\n" + uu___7) + (fun uu___6 -> + fail1 + "Forcing the guard failed (%s)" + reason)))) + uu___4))) uu___3))) +let (proc_guard : + Prims.string -> + env -> + FStarC_TypeChecker_Common.guard_t -> + FStarC_Syntax_Syntax.should_check_uvar FStar_Pervasives_Native.option + -> + FStarC_Compiler_Range_Type.range -> unit FStarC_Tactics_Monad.tac) + = proc_guard' true +let (tc_unifier_solved_implicits : + FStarC_TypeChecker_Env.env -> + Prims.bool -> + Prims.bool -> + FStarC_Syntax_Syntax.ctx_uvar Prims.list -> + unit FStarC_Tactics_Monad.tac) + = + fun env1 -> + fun must_tot -> + fun allow_guards -> + fun uvs -> + let aux u = + let dec = + FStarC_Syntax_Unionfind.find_decoration + u.FStarC_Syntax_Syntax.ctx_uvar_head in + let sc = dec.FStarC_Syntax_Syntax.uvar_decoration_should_check in + match sc with + | FStarC_Syntax_Syntax.Allow_untyped uu___ -> ret () + | FStarC_Syntax_Syntax.Already_checked -> ret () + | uu___ -> + let uu___1 = + FStarC_Syntax_Unionfind.find + u.FStarC_Syntax_Syntax.ctx_uvar_head in + (match uu___1 with + | FStar_Pervasives_Native.None -> ret () + | FStar_Pervasives_Native.Some sol -> + let env2 = + { + FStarC_TypeChecker_Env.solver = + (env1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (u.FStarC_Syntax_Syntax.ctx_uvar_gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env1.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env1.FStarC_TypeChecker_Env.missing_decl) + } in + let must_tot1 = + must_tot && + (Prims.op_Negation + (FStarC_Syntax_Syntax.uu___is_Allow_ghost + dec.FStarC_Syntax_Syntax.uvar_decoration_should_check)) in + let uu___2 = + let uu___3 = FStarC_Syntax_Util.ctx_uvar_typ u in + core_check env2 sol uu___3 must_tot1 in + (match uu___2 with + | FStar_Pervasives.Inl (FStar_Pervasives_Native.None) + -> (mark_uvar_as_already_checked u; ret ()) + | FStar_Pervasives.Inl (FStar_Pervasives_Native.Some g) + -> + let guard = + { + FStarC_TypeChecker_Common.guard_f = + (FStarC_TypeChecker_Common.NonTrivial g); + FStarC_TypeChecker_Common.deferred_to_tac = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.implicits) + } in + let guard1 = + FStarC_TypeChecker_Rel.simplify_guard env2 guard in + let uu___3 = + ((FStarC_Options.disallow_unification_guards ()) + && (Prims.op_Negation allow_guards)) + && + (FStarC_TypeChecker_Common.uu___is_NonTrivial + guard1.FStarC_TypeChecker_Common.guard_f) in + if uu___3 + then + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_uvar + u.FStarC_Syntax_Syntax.ctx_uvar_head in + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term sol in + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term g in + fail3 + "Could not typecheck unifier solved implicit %s to %s since it produced a guard and guards were not allowed;guard is\n%s" + uu___4 uu___5 uu___6 + else + (let uu___5 = + proc_guard' false "guard for implicit" env2 + guard1 (FStar_Pervasives_Native.Some sc) + u.FStarC_Syntax_Syntax.ctx_uvar_range in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () uu___5 + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = Obj.magic uu___6 in + mark_uvar_as_already_checked u; + Obj.magic (ret ())) uu___6)) + | FStar_Pervasives.Inr failed -> + let uu___3 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_uvar + u.FStarC_Syntax_Syntax.ctx_uvar_head in + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term sol in + let uu___5 = + FStarC_TypeChecker_Core.print_error failed in + fail3 + "Could not typecheck unifier solved implicit %s to %s because %s" + uu___3 uu___4 uu___5)) in + if env1.FStarC_TypeChecker_Env.phase1 + then ret () + else FStarC_Tactics_Monad.iter_tac aux uvs +type check_unifier_solved_implicits_side = + | Check_none + | Check_left_only + | Check_right_only + | Check_both +let (uu___is_Check_none : check_unifier_solved_implicits_side -> Prims.bool) + = + fun projectee -> match projectee with | Check_none -> true | uu___ -> false +let (uu___is_Check_left_only : + check_unifier_solved_implicits_side -> Prims.bool) = + fun projectee -> + match projectee with | Check_left_only -> true | uu___ -> false +let (uu___is_Check_right_only : + check_unifier_solved_implicits_side -> Prims.bool) = + fun projectee -> + match projectee with | Check_right_only -> true | uu___ -> false +let (uu___is_Check_both : check_unifier_solved_implicits_side -> Prims.bool) + = + fun projectee -> match projectee with | Check_both -> true | uu___ -> false +let (__do_unify_wflags : + Prims.bool -> + Prims.bool -> + Prims.bool -> + check_unifier_solved_implicits_side -> + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> + FStarC_TypeChecker_Common.guard_t + FStar_Pervasives_Native.option FStarC_Tactics_Monad.tac) + = + fun uu___6 -> + fun uu___5 -> + fun uu___4 -> + fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun dbg -> + fun allow_guards -> + fun must_tot -> + fun check_side -> + fun env1 -> + fun t1 -> + fun t2 -> + if dbg + then + (let uu___1 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t1 in + let uu___2 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t2 in + FStarC_Compiler_Util.print2 + "%%%%%%%%do_unify %s =? %s\n" uu___1 + uu___2) + else (); + (let all_uvars = + let uu___1 = + match check_side with + | Check_none -> + Obj.magic + (Obj.repr + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) + ())) + | Check_left_only -> + Obj.magic + (Obj.repr + (FStarC_Syntax_Free.uvars t1)) + | Check_right_only -> + Obj.magic + (Obj.repr + (FStarC_Syntax_Free.uvars t2)) + | Check_both -> + Obj.magic + (Obj.repr + (let uu___2 = + FStarC_Syntax_Free.uvars t1 in + let uu___3 = + FStarC_Syntax_Free.uvars t2 in + FStarC_Class_Setlike.union () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) + (Obj.magic uu___2) + (Obj.magic uu___3))) in + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) + (Obj.magic uu___1) in + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Tactics_Monad.trytac + FStarC_Tactics_Monad.cur_goal in + let uu___4 = bind () in + uu___4 uu___3 + (fun gopt -> + try + (fun uu___5 -> + (fun uu___5 -> + match () with + | () -> + let res = + if allow_guards + then + FStarC_TypeChecker_Rel.try_teq + true env1 t1 t2 + else + FStarC_TypeChecker_Rel.teq_nosmt + env1 t1 t2 in + (if dbg + then + (let uu___7 = + FStarC_Common.string_of_option + (FStarC_TypeChecker_Rel.guard_to_string + env1) res in + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t1 in + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t2 in + FStarC_Compiler_Util.print3 + "%%%%%%%%do_unify (RESULT %s) %s =? %s\n" + uu___7 uu___8 + uu___9) + else (); + (match res with + | FStar_Pervasives_Native.None + -> + Obj.magic + (Obj.repr + (ret + FStar_Pervasives_Native.None)) + | FStar_Pervasives_Native.Some + g -> + Obj.magic + (Obj.repr + (let uu___7 = + tc_unifier_solved_implicits + env1 + must_tot + allow_guards + all_uvars in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___7 + (fun + uu___8 -> + (fun + uu___8 -> + let uu___8 + = + Obj.magic + uu___8 in + let uu___9 + = + let uu___10 + = + FStarC_Class_Listlike.to_list + (FStarC_Compiler_CList.listlike_clist + ()) + g.FStarC_TypeChecker_Common.implicits in + FStarC_Tactics_Monad.add_implicits + uu___10 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___9 + (fun + uu___10 + -> + (fun + uu___10 + -> + let uu___10 + = + Obj.magic + uu___10 in + Obj.magic + (ret + (FStar_Pervasives_Native.Some + g))) + uu___10))) + uu___8)))))) + uu___5) () + with + | FStarC_Errors.Error + (uu___6, msg, r, uu___7) -> + FStarC_Tactics_Monad.mlog + (fun uu___8 -> + let uu___9 = + FStarC_Errors_Msg.rendermsg + msg in + let uu___10 = + FStarC_Class_Show.show + FStarC_Compiler_Range_Ops.showable_range + r in + FStarC_Compiler_Util.print2 + ">> do_unify error, (%s) at (%s)\n" + uu___9 uu___10) + (fun uu___8 -> + ret + FStar_Pervasives_Native.None)) in + FStarC_Tactics_Monad.catch uu___2 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + match uu___2 with + | FStar_Pervasives.Inl exn -> + Obj.magic + (FStarC_Tactics_Monad.traise + exn) + | FStar_Pervasives.Inr v -> + Obj.magic (ret v)) uu___2)))) + uu___6 uu___5 uu___4 uu___3 uu___2 uu___1 uu___ +let (__do_unify : + Prims.bool -> + Prims.bool -> + check_unifier_solved_implicits_side -> + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> + FStarC_TypeChecker_Common.guard_t + FStar_Pervasives_Native.option FStarC_Tactics_Monad.tac) + = + fun allow_guards -> + fun must_tot -> + fun check_side -> + fun env1 -> + fun t1 -> + fun t2 -> + let uu___ = bind () in + uu___ idtac + (fun uu___1 -> + (let uu___3 = FStarC_Compiler_Effect.op_Bang dbg_TacUnify in + if uu___3 + then + (FStarC_Options.push (); + (let uu___5 = + FStarC_Options.set_options "--debug Rel,RelCheck" in + ())) + else ()); + (let uu___3 = + let uu___4 = + FStarC_Compiler_Effect.op_Bang dbg_TacUnify in + __do_unify_wflags uu___4 allow_guards must_tot + check_side env1 t1 t2 in + let uu___4 = bind () in + uu___4 uu___3 + (fun r -> + (let uu___6 = + FStarC_Compiler_Effect.op_Bang dbg_TacUnify in + if uu___6 then FStarC_Options.pop () else ()); + ret r))) +let (do_unify_aux : + Prims.bool -> + check_unifier_solved_implicits_side -> + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> Prims.bool FStarC_Tactics_Monad.tac) + = + fun must_tot -> + fun check_side -> + fun env1 -> + fun t1 -> + fun t2 -> + let uu___ = __do_unify false must_tot check_side env1 t1 t2 in + let uu___1 = bind () in + uu___1 uu___ + (fun uu___2 -> + match uu___2 with + | FStar_Pervasives_Native.None -> ret false + | FStar_Pervasives_Native.Some g -> + ((let uu___4 = + let uu___5 = + FStarC_TypeChecker_Env.is_trivial_guard_formula g in + Prims.op_Negation uu___5 in + if uu___4 + then + failwith + "internal error: do_unify: guard is not trivial" + else ()); + ret true)) +let (do_unify : + Prims.bool -> + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> Prims.bool FStarC_Tactics_Monad.tac) + = + fun must_tot -> + fun env1 -> + fun t1 -> fun t2 -> do_unify_aux must_tot Check_both env1 t1 t2 +let (do_unify_maybe_guards : + Prims.bool -> + Prims.bool -> + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> + FStarC_TypeChecker_Common.guard_t FStar_Pervasives_Native.option + FStarC_Tactics_Monad.tac) + = + fun allow_guards -> + fun must_tot -> + fun env1 -> + fun t1 -> + fun t2 -> __do_unify allow_guards must_tot Check_both env1 t1 t2 +let (do_match : + Prims.bool -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> Prims.bool FStarC_Tactics_Monad.tac) + = + fun must_tot -> + fun env1 -> + fun t1 -> + fun t2 -> + let uu___ = + FStarC_Tactics_Monad.mk_tac + (fun ps -> + let tx = FStarC_Syntax_Unionfind.new_transaction () in + FStarC_Tactics_Result.Success (tx, ps)) in + let uu___1 = bind () in + uu___1 uu___ + (fun tx -> + let uvs1 = FStarC_Syntax_Free.uvars_uncached t1 in + let uu___2 = do_unify_aux must_tot Check_right_only env1 t1 t2 in + let uu___3 = bind () in + uu___3 uu___2 + (fun r -> + if r + then + let uvs2 = FStarC_Syntax_Free.uvars_uncached t1 in + let uu___4 = + let uu___5 = + FStarC_Class_Setlike.equal () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) + (Obj.magic uvs1) (Obj.magic uvs2) in + Prims.op_Negation uu___5 in + (if uu___4 + then (FStarC_Syntax_Unionfind.rollback tx; ret false) + else ret true) + else ret false)) +let (do_match_on_lhs : + Prims.bool -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> Prims.bool FStarC_Tactics_Monad.tac) + = + fun must_tot -> + fun env1 -> + fun t1 -> + fun t2 -> + let uu___ = + FStarC_Tactics_Monad.mk_tac + (fun ps -> + let tx = FStarC_Syntax_Unionfind.new_transaction () in + FStarC_Tactics_Result.Success (tx, ps)) in + let uu___1 = bind () in + uu___1 uu___ + (fun tx -> + let uu___2 = destruct_eq env1 t1 in + match uu___2 with + | FStar_Pervasives_Native.None -> + FStarC_Tactics_Monad.fail "do_match_on_lhs: not an eq" + | FStar_Pervasives_Native.Some (lhs, uu___3) -> + let uvs1 = FStarC_Syntax_Free.uvars_uncached lhs in + let uu___4 = + do_unify_aux must_tot Check_right_only env1 t1 t2 in + let uu___5 = bind () in + uu___5 uu___4 + (fun r -> + if r + then + let uvs2 = FStarC_Syntax_Free.uvars_uncached lhs in + let uu___6 = + let uu___7 = + FStarC_Class_Setlike.equal () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) + (Obj.magic uvs1) (Obj.magic uvs2) in + Prims.op_Negation uu___7 in + (if uu___6 + then + (FStarC_Syntax_Unionfind.rollback tx; ret false) + else ret true) + else ret false)) +let (set_solution : + FStarC_Tactics_Types.goal -> + FStarC_Syntax_Syntax.term -> unit FStarC_Tactics_Monad.tac) + = + fun goal -> + fun solution -> + let uu___ = + FStarC_Syntax_Unionfind.find + (goal.FStarC_Tactics_Types.goal_ctx_uvar).FStarC_Syntax_Syntax.ctx_uvar_head in + match uu___ with + | FStar_Pervasives_Native.Some uu___1 -> + let uu___2 = + let uu___3 = FStarC_Tactics_Printing.goal_to_string_verbose goal in + FStarC_Compiler_Util.format1 "Goal %s is already solved" uu___3 in + FStarC_Tactics_Monad.fail uu___2 + | FStar_Pervasives_Native.None -> + (FStarC_Syntax_Unionfind.change + (goal.FStarC_Tactics_Types.goal_ctx_uvar).FStarC_Syntax_Syntax.ctx_uvar_head + solution; + mark_goal_implicit_already_checked goal; + ret ()) +let (trysolve : + FStarC_Tactics_Types.goal -> + FStarC_Syntax_Syntax.term -> Prims.bool FStarC_Tactics_Monad.tac) + = + fun goal -> + fun solution -> + let must_tot = true in + let uu___ = FStarC_Tactics_Types.goal_env goal in + let uu___1 = FStarC_Tactics_Types.goal_witness goal in + do_unify must_tot uu___ solution uu___1 +let (solve : + FStarC_Tactics_Types.goal -> + FStarC_Syntax_Syntax.term -> unit FStarC_Tactics_Monad.tac) + = + fun goal -> + fun solution -> + let e = FStarC_Tactics_Types.goal_env goal in + FStarC_Tactics_Monad.mlog + (fun uu___ -> + let uu___1 = + let uu___2 = FStarC_Tactics_Types.goal_witness goal in + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term uu___2 in + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + solution in + FStarC_Compiler_Util.print2 "solve %s := %s\n" uu___1 uu___2) + (fun uu___ -> + let uu___1 = trysolve goal solution in + let uu___2 = bind () in + uu___2 uu___1 + (fun b -> + if b + then + let uu___3 = bind () in + uu___3 FStarC_Tactics_Monad.dismiss + (fun uu___4 -> FStarC_Tactics_Monad.remove_solved_goals) + else + (let uu___4 = + let uu___5 = + let uu___6 = FStarC_Tactics_Types.goal_env goal in + tts uu___6 solution in + let uu___6 = + let uu___7 = FStarC_Tactics_Types.goal_env goal in + let uu___8 = FStarC_Tactics_Types.goal_witness goal in + tts uu___7 uu___8 in + let uu___7 = + let uu___8 = FStarC_Tactics_Types.goal_env goal in + let uu___9 = FStarC_Tactics_Types.goal_type goal in + tts uu___8 uu___9 in + FStarC_Compiler_Util.format3 "%s does not solve %s : %s" + uu___5 uu___6 uu___7 in + FStarC_Tactics_Monad.fail uu___4))) +let (solve' : + FStarC_Tactics_Types.goal -> + FStarC_Syntax_Syntax.term -> unit FStarC_Tactics_Monad.tac) + = + fun goal -> + fun solution -> + let uu___ = set_solution goal solution in + let uu___1 = bind () in + uu___1 uu___ + (fun uu___2 -> + let uu___3 = bind () in + uu___3 FStarC_Tactics_Monad.dismiss + (fun uu___4 -> FStarC_Tactics_Monad.remove_solved_goals)) +let (is_true : FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t -> + let t1 = FStarC_Syntax_Util.unascribe t in + let uu___ = FStarC_Syntax_Util.un_squash t1 in + match uu___ with + | FStar_Pervasives_Native.Some t' -> + let t'1 = FStarC_Syntax_Util.unascribe t' in + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress t'1 in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.true_lid + | uu___2 -> false) + | uu___1 -> false +let (is_false : FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t -> + let uu___ = FStarC_Syntax_Util.un_squash t in + match uu___ with + | FStar_Pervasives_Native.Some t' -> + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress t' in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.false_lid + | uu___2 -> false) + | uu___1 -> false +let (tadmit_t : FStarC_Syntax_Syntax.term -> unit FStarC_Tactics_Monad.tac) = + fun t -> + let uu___ = + let uu___1 = bind () in + uu___1 FStarC_Tactics_Monad.get + (fun ps -> + let uu___2 = bind () in + uu___2 FStarC_Tactics_Monad.cur_goal + (fun g -> + (let uu___4 = FStarC_Tactics_Types.goal_type g in + let uu___5 = + let uu___6 = + FStarC_Tactics_Printing.goal_to_string "" + FStar_Pervasives_Native.None ps g in + FStarC_Compiler_Util.format1 + "Tactics admitted goal <%s>\n\n" uu___6 in + FStarC_Errors.log_issue + (FStarC_Syntax_Syntax.has_range_syntax ()) uu___4 + FStarC_Errors_Codes.Warning_TacAdmit () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___5)); + solve' g t)) in + FStarC_Tactics_Monad.wrap_err "tadmit_t" uu___ +let (fresh : unit -> FStarC_BigInt.t FStarC_Tactics_Monad.tac) = + fun uu___ -> + let uu___1 = bind () in + uu___1 FStarC_Tactics_Monad.get + (fun ps -> + let n = ps.FStarC_Tactics_Types.freshness in + let ps1 = + { + FStarC_Tactics_Types.main_context = + (ps.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits = + (ps.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = (ps.FStarC_Tactics_Types.goals); + FStarC_Tactics_Types.smt_goals = + (ps.FStarC_Tactics_Types.smt_goals); + FStarC_Tactics_Types.depth = (ps.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = (ps.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = (ps.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (ps.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = + (ps.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness = (n + Prims.int_one); + FStarC_Tactics_Types.tac_verb_dbg = + (ps.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = + (ps.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency = (ps.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure = + (ps.FStarC_Tactics_Types.dump_on_failure) + } in + let uu___2 = FStarC_Tactics_Monad.set ps1 in + let uu___3 = bind () in + uu___3 uu___2 + (fun uu___4 -> + let uu___5 = FStarC_BigInt.of_int_fs n in ret uu___5)) +let (curms : unit -> FStarC_BigInt.t FStarC_Tactics_Monad.tac) = + fun uu___ -> + let uu___1 = + let uu___2 = FStarC_Compiler_Util.now_ms () in + FStarC_BigInt.of_int_fs uu___2 in + ret uu___1 +let (__tc : + env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.typ * + FStarC_TypeChecker_Common.guard_t) FStarC_Tactics_Monad.tac) + = + fun e -> + fun t -> + let uu___ = bind () in + uu___ FStarC_Tactics_Monad.get + (fun ps -> + FStarC_Tactics_Monad.mlog + (fun uu___1 -> + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.print1 "Tac> __tc(%s)\n" uu___2) + (fun uu___1 -> + let e1 = + { + FStarC_TypeChecker_Env.solver = + (e.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (e.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (e.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (e.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (e.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (e.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (e.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (e.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (e.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (e.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (e.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (e.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (e.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (e.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (e.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (e.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (e.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (e.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (e.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (e.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (e.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (e.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (e.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = false; + FStarC_TypeChecker_Env.intactics = + (e.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (e.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (e.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (e.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (e.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (e.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (e.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (e.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (e.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (e.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (e.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (e.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (e.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (e.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (e.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (e.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (e.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (e.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (e.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (e.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (e.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (e.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (e.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (e.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (e.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (e.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (e.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (e.FStarC_TypeChecker_Env.missing_decl) + } in + try + (fun uu___2 -> + match () with + | () -> + let uu___3 = + FStarC_TypeChecker_TcTerm.typeof_tot_or_gtot_term + e1 t true in + ret uu___3) () + with + | FStarC_Errors.Error (uu___3, msg, uu___4, uu___5) -> + let uu___6 = tts e1 t in + let uu___7 = + let uu___8 = FStarC_TypeChecker_Env.all_binders e1 in + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binder) uu___8 in + let uu___8 = FStarC_Errors_Msg.rendermsg msg in + fail3 "Cannot type (1) %s in context (%s). Error = (%s)" + uu___6 uu___7 uu___8)) +let (__tc_ghost : + env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.typ * + FStarC_TypeChecker_Common.guard_t) FStarC_Tactics_Monad.tac) + = + fun e -> + fun t -> + let uu___ = bind () in + uu___ FStarC_Tactics_Monad.get + (fun ps -> + FStarC_Tactics_Monad.mlog + (fun uu___1 -> + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.print1 "Tac> __tc_ghost(%s)\n" uu___2) + (fun uu___1 -> + let e1 = + { + FStarC_TypeChecker_Env.solver = + (e.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (e.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (e.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (e.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (e.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (e.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (e.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (e.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (e.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (e.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (e.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (e.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (e.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (e.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (e.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (e.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (e.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (e.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (e.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (e.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (e.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (e.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (e.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = false; + FStarC_TypeChecker_Env.intactics = + (e.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (e.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (e.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (e.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (e.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (e.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (e.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (e.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (e.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (e.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (e.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (e.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (e.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (e.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (e.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (e.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (e.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (e.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (e.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (e.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (e.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (e.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (e.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (e.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (e.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (e.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (e.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (e.FStarC_TypeChecker_Env.missing_decl) + } in + let e2 = + { + FStarC_TypeChecker_Env.solver = + (e1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (e1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (e1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (e1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (e1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (e1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (e1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (e1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (e1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (e1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (e1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (e1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (e1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = []; + FStarC_TypeChecker_Env.top_level = + (e1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (e1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (e1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (e1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (e1.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (e1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (e1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (e1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (e1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (e1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (e1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (e1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (e1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (e1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (e1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (e1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (e1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (e1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (e1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (e1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (e1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (e1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (e1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (e1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (e1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (e1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (e1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (e1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (e1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (e1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (e1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (e1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (e1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (e1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (e1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (e1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (e1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (e1.FStarC_TypeChecker_Env.missing_decl) + } in + try + (fun uu___2 -> + match () with + | () -> + let uu___3 = + FStarC_TypeChecker_TcTerm.tc_tot_or_gtot_term e2 t in + (match uu___3 with + | (t1, lc, g) -> + ret + (t1, (lc.FStarC_TypeChecker_Common.res_typ), + g))) () + with + | FStarC_Errors.Error (uu___3, msg, uu___4, uu___5) -> + let uu___6 = tts e2 t in + let uu___7 = + let uu___8 = FStarC_TypeChecker_Env.all_binders e2 in + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binder) uu___8 in + let uu___8 = FStarC_Errors_Msg.rendermsg msg in + fail3 "Cannot type (2) %s in context (%s). Error = (%s)" + uu___6 uu___7 uu___8)) +let (__tc_lax : + env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.lcomp * + FStarC_TypeChecker_Common.guard_t) FStarC_Tactics_Monad.tac) + = + fun e -> + fun t -> + let uu___ = bind () in + uu___ FStarC_Tactics_Monad.get + (fun ps -> + FStarC_Tactics_Monad.mlog + (fun uu___1 -> + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + let uu___3 = + let uu___4 = FStarC_TypeChecker_Env.all_binders e in + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binder) uu___4 in + FStarC_Compiler_Util.print2 "Tac> __tc_lax(%s)(Context:%s)\n" + uu___2 uu___3) + (fun uu___1 -> + let e1 = + { + FStarC_TypeChecker_Env.solver = + (e.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (e.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (e.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (e.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (e.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (e.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (e.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (e.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (e.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (e.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (e.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (e.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (e.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (e.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (e.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (e.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (e.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (e.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (e.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (e.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (e.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (e.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (e.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = false; + FStarC_TypeChecker_Env.intactics = + (e.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (e.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (e.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (e.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (e.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (e.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (e.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (e.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (e.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (e.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (e.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (e.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (e.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (e.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (e.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (e.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (e.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (e.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (e.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (e.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (e.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (e.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (e.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (e.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (e.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (e.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (e.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (e.FStarC_TypeChecker_Env.missing_decl) + } in + let e2 = + { + FStarC_TypeChecker_Env.solver = + (e1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (e1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (e1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (e1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (e1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (e1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (e1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (e1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (e1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (e1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (e1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (e1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (e1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (e1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (e1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (e1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (e1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (e1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = true; + FStarC_TypeChecker_Env.lax_universes = + (e1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (e1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (e1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (e1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (e1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (e1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (e1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (e1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (e1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (e1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (e1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (e1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (e1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (e1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (e1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (e1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (e1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (e1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (e1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (e1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (e1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (e1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (e1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (e1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (e1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (e1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (e1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (e1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (e1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (e1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (e1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (e1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (e1.FStarC_TypeChecker_Env.missing_decl) + } in + let e3 = + { + FStarC_TypeChecker_Env.solver = + (e2.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (e2.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (e2.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (e2.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (e2.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (e2.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (e2.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (e2.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (e2.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (e2.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (e2.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (e2.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (e2.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = []; + FStarC_TypeChecker_Env.top_level = + (e2.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (e2.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (e2.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (e2.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (e2.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (e2.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (e2.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (e2.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (e2.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (e2.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (e2.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (e2.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (e2.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (e2.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (e2.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (e2.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (e2.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (e2.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (e2.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (e2.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (e2.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (e2.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (e2.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (e2.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (e2.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (e2.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (e2.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (e2.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (e2.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (e2.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (e2.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (e2.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (e2.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (e2.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (e2.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (e2.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (e2.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (e2.FStarC_TypeChecker_Env.missing_decl) + } in + try + (fun uu___2 -> + match () with + | () -> + let uu___3 = FStarC_TypeChecker_TcTerm.tc_term e3 t in + ret uu___3) () + with + | FStarC_Errors.Error (uu___3, msg, uu___4, uu___5) -> + let uu___6 = tts e3 t in + let uu___7 = + let uu___8 = FStarC_TypeChecker_Env.all_binders e3 in + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binder) uu___8 in + let uu___8 = FStarC_Errors_Msg.rendermsg msg in + fail3 "Cannot type (3) %s in context (%s). Error = (%s)" + uu___6 uu___7 uu___8)) +let (tcc : + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.comp FStarC_Tactics_Monad.tac) + = + fun e -> + fun t -> + let uu___ = + let uu___1 = __tc_lax e t in + let uu___2 = bind () in + uu___2 uu___1 + (fun uu___3 -> + match uu___3 with + | (uu___4, lc, uu___5) -> + let uu___6 = + let uu___7 = FStarC_TypeChecker_Common.lcomp_comp lc in + FStar_Pervasives_Native.fst uu___7 in + ret uu___6) in + FStarC_Tactics_Monad.wrap_err "tcc" uu___ +let (tc : + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.typ FStarC_Tactics_Monad.tac) + = + fun e -> + fun t -> + let uu___ = + let uu___1 = tcc e t in + let uu___2 = bind () in + uu___2 uu___1 (fun c -> ret (FStarC_Syntax_Util.comp_result c)) in + FStarC_Tactics_Monad.wrap_err "tc" uu___ +let divide : + 'a 'b . + FStarC_BigInt.t -> + 'a FStarC_Tactics_Monad.tac -> + 'b FStarC_Tactics_Monad.tac -> ('a * 'b) FStarC_Tactics_Monad.tac + = + fun n -> + fun l -> + fun r -> + let uu___ = bind () in + uu___ FStarC_Tactics_Monad.get + (fun p -> + let uu___1 = + try + (fun uu___2 -> + match () with + | () -> + let uu___3 = + let uu___4 = FStarC_BigInt.to_int_fs n in + FStarC_Compiler_List.splitAt uu___4 + p.FStarC_Tactics_Types.goals in + ret uu___3) () + with + | uu___2 -> + FStarC_Tactics_Monad.fail "divide: not enough goals" in + let uu___2 = bind () in + uu___2 uu___1 + (fun uu___3 -> + match uu___3 with + | (lgs, rgs) -> + let lp = + { + FStarC_Tactics_Types.main_context = + (p.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits = + (p.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = lgs; + FStarC_Tactics_Types.smt_goals = []; + FStarC_Tactics_Types.depth = + (p.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = + (p.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = + (p.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (p.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = + (p.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness = + (p.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg = + (p.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = + (p.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency = + (p.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure = + (p.FStarC_Tactics_Types.dump_on_failure) + } in + let uu___4 = FStarC_Tactics_Monad.set lp in + let uu___5 = bind () in + uu___5 uu___4 + (fun uu___6 -> + let uu___7 = bind () in + uu___7 l + (fun a1 -> + let uu___8 = bind () in + uu___8 FStarC_Tactics_Monad.get + (fun lp' -> + let rp = + { + FStarC_Tactics_Types.main_context = + (lp'.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits = + (lp'.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = rgs; + FStarC_Tactics_Types.smt_goals = []; + FStarC_Tactics_Types.depth = + (lp'.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = + (lp'.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = + (lp'.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (lp'.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = + (lp'.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness = + (lp'.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg = + (lp'.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = + (lp'.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency = + (lp'.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure + = + (lp'.FStarC_Tactics_Types.dump_on_failure) + } in + let uu___9 = FStarC_Tactics_Monad.set rp in + let uu___10 = bind () in + uu___10 uu___9 + (fun uu___11 -> + let uu___12 = bind () in + uu___12 r + (fun b1 -> + let uu___13 = bind () in + uu___13 + FStarC_Tactics_Monad.get + (fun rp' -> + let p' = + { + FStarC_Tactics_Types.main_context + = + (rp'.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits + = + (rp'.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals + = + (FStarC_Compiler_List.op_At + lp'.FStarC_Tactics_Types.goals + rp'.FStarC_Tactics_Types.goals); + FStarC_Tactics_Types.smt_goals + = + (FStarC_Compiler_List.op_At + lp'.FStarC_Tactics_Types.smt_goals + (FStarC_Compiler_List.op_At + rp'.FStarC_Tactics_Types.smt_goals + p.FStarC_Tactics_Types.smt_goals)); + FStarC_Tactics_Types.depth + = + (rp'.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump + = + (rp'.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc + = + (rp'.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range + = + (rp'.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy + = + (rp'.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness + = + (rp'.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg + = + (rp'.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state + = + (rp'.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency + = + (rp'.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure + = + (rp'.FStarC_Tactics_Types.dump_on_failure) + } in + let uu___14 = + FStarC_Tactics_Monad.set + p' in + let uu___15 = bind () in + uu___15 uu___14 + (fun uu___16 -> + let uu___17 = + bind () in + uu___17 + FStarC_Tactics_Monad.remove_solved_goals + (fun uu___18 -> + ret (a1, b1))))))))))) +let focus : 'a . 'a FStarC_Tactics_Monad.tac -> 'a FStarC_Tactics_Monad.tac = + fun f -> + let uu___ = divide FStarC_BigInt.one f idtac in + let uu___1 = bind () in + uu___1 uu___ (fun uu___2 -> match uu___2 with | (a1, ()) -> ret a1) +let rec map : + 'a . 'a FStarC_Tactics_Monad.tac -> 'a Prims.list FStarC_Tactics_Monad.tac + = + fun tau -> + let uu___ = bind () in + uu___ FStarC_Tactics_Monad.get + (fun p -> + match p.FStarC_Tactics_Types.goals with + | [] -> ret [] + | uu___1::uu___2 -> + let uu___3 = + let uu___4 = map tau in divide FStarC_BigInt.one tau uu___4 in + let uu___4 = bind () in + uu___4 uu___3 + (fun uu___5 -> match uu___5 with | (h, t) -> ret (h :: t))) +let (seq : + unit FStarC_Tactics_Monad.tac -> + unit FStarC_Tactics_Monad.tac -> unit FStarC_Tactics_Monad.tac) + = + fun t1 -> + fun t2 -> + let uu___ = + let uu___1 = bind () in + uu___1 t1 + (fun uu___2 -> + let uu___3 = map t2 in + let uu___4 = bind () in uu___4 uu___3 (fun uu___5 -> ret ())) in + focus uu___ +let (should_check_goal_uvar : + FStarC_Tactics_Types.goal -> FStarC_Syntax_Syntax.should_check_uvar) = + fun g -> + FStarC_Syntax_Util.ctx_uvar_should_check + g.FStarC_Tactics_Types.goal_ctx_uvar +let (goal_typedness_deps : + FStarC_Tactics_Types.goal -> FStarC_Syntax_Syntax.ctx_uvar Prims.list) = + fun g -> + FStarC_Syntax_Util.ctx_uvar_typedness_deps + g.FStarC_Tactics_Types.goal_ctx_uvar +let (bnorm_and_replace : + FStarC_Tactics_Types.goal -> unit FStarC_Tactics_Monad.tac) = + fun g -> let uu___ = bnorm_goal g in FStarC_Tactics_Monad.replace_cur uu___ +let (arrow_one : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + (FStarC_TypeChecker_Env.env * FStarC_Syntax_Syntax.binder * + FStarC_Syntax_Syntax.comp) FStar_Pervasives_Native.option) + = + fun env1 -> + fun t -> + let uu___ = FStarC_Syntax_Util.arrow_one_ln t in + match uu___ with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (b, c) -> + let uu___1 = + FStarC_TypeChecker_Core.open_binders_in_comp env1 [b] c in + (match uu___1 with + | (env2, b1::[], c1) -> + FStar_Pervasives_Native.Some (env2, b1, c1)) +let (intro : unit -> FStarC_Syntax_Syntax.binder FStarC_Tactics_Monad.tac) = + fun uu___ -> + let uu___1 = + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___2 -> + (fun goal -> + let goal = Obj.magic goal in + let uu___2 = + let uu___3 = FStarC_Tactics_Types.goal_env goal in + let uu___4 = + let uu___5 = FStarC_Tactics_Types.goal_env goal in + let uu___6 = FStarC_Tactics_Types.goal_type goal in + whnf uu___5 uu___6 in + arrow_one uu___3 uu___4 in + match uu___2 with + | FStar_Pervasives_Native.Some (env', b, c) -> + Obj.magic + (Obj.repr + (let uu___3 = + let uu___4 = FStarC_Syntax_Util.is_total_comp c in + Prims.op_Negation uu___4 in + if uu___3 + then + Obj.repr + (FStarC_Tactics_Monad.fail + "Codomain is effectful") + else + Obj.repr + (let typ' = FStarC_Syntax_Util.comp_result c in + let uu___5 = + let uu___6 = + let uu___7 = should_check_goal_uvar goal in + FStar_Pervasives_Native.Some uu___7 in + let uu___7 = goal_typedness_deps goal in + FStarC_Tactics_Monad.new_uvar "intro" env' + typ' uu___6 uu___7 (rangeof goal) in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___5) + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = Obj.magic uu___6 in + match uu___6 with + | (body, ctx_uvar) -> + let sol = + let uu___7 = + let uu___8 = + FStarC_Syntax_Util.residual_comp_of_comp + c in + FStar_Pervasives_Native.Some + uu___8 in + FStarC_Syntax_Util.abs + [b] body uu___7 in + let uu___7 = + set_solution goal sol in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___7 + (fun uu___8 -> + (fun uu___8 -> + let uu___8 = + Obj.magic uu___8 in + let g = + FStarC_Tactics_Types.mk_goal + env' ctx_uvar + goal.FStarC_Tactics_Types.opts + goal.FStarC_Tactics_Types.is_guard + goal.FStarC_Tactics_Types.label in + let uu___9 = + bnorm_and_replace g in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___9 + (fun uu___10 -> + (fun uu___10 + -> + let uu___10 + = + Obj.magic + uu___10 in + Obj.magic + ( + ret b)) + uu___10))) + uu___8))) uu___6)))) + | FStar_Pervasives_Native.None -> + Obj.magic + (Obj.repr + (let uu___3 = + let uu___4 = FStarC_Tactics_Types.goal_env goal in + let uu___5 = FStarC_Tactics_Types.goal_type goal in + tts uu___4 uu___5 in + fail1 "goal is not an arrow (%s)" uu___3))) uu___2)) in + FStarC_Tactics_Monad.wrap_err "intro" uu___1 +let (intro_rec : + unit -> + (FStarC_Syntax_Syntax.binder * FStarC_Syntax_Syntax.binder) + FStarC_Tactics_Monad.tac) + = + fun uu___ -> + (fun uu___ -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___1 -> + (fun goal -> + let goal = Obj.magic goal in + FStarC_Compiler_Util.print_string + "WARNING (intro_rec): calling this is known to cause normalizer loops\n"; + FStarC_Compiler_Util.print_string + "WARNING (intro_rec): proceed at your own risk...\n"; + (let uu___3 = + let uu___4 = FStarC_Tactics_Types.goal_env goal in + let uu___5 = + let uu___6 = FStarC_Tactics_Types.goal_env goal in + let uu___7 = FStarC_Tactics_Types.goal_type goal in + whnf uu___6 uu___7 in + arrow_one uu___4 uu___5 in + match uu___3 with + | FStar_Pervasives_Native.Some (env', b, c) -> + Obj.magic + (Obj.repr + (let uu___4 = + let uu___5 = + FStarC_Syntax_Util.is_total_comp c in + Prims.op_Negation uu___5 in + if uu___4 + then + Obj.repr + (FStarC_Tactics_Monad.fail + "Codomain is effectful") + else + Obj.repr + (let bv = + let uu___6 = + FStarC_Tactics_Types.goal_type goal in + FStarC_Syntax_Syntax.gen_bv "__recf" + FStar_Pervasives_Native.None uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + should_check_goal_uvar goal in + FStar_Pervasives_Native.Some uu___8 in + let uu___8 = goal_typedness_deps goal in + FStarC_Tactics_Monad.new_uvar "intro_rec" + env' (FStarC_Syntax_Util.comp_result c) + uu___7 uu___8 (rangeof goal) in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___6) + (fun uu___7 -> + (fun uu___7 -> + let uu___7 = Obj.magic uu___7 in + match uu___7 with + | (u, ctx_uvar_u) -> + let lb = + let uu___8 = + FStarC_Tactics_Types.goal_type + goal in + let uu___9 = + FStarC_Syntax_Util.abs + [b] u + FStar_Pervasives_Native.None in + FStarC_Syntax_Util.mk_letbinding + (FStar_Pervasives.Inl bv) + [] uu___8 + FStarC_Parser_Const.effect_Tot_lid + uu___9 [] + FStarC_Compiler_Range_Type.dummyRange in + let body = + FStarC_Syntax_Syntax.bv_to_name + bv in + let uu___8 = + FStarC_Syntax_Subst.close_let_rec + [lb] body in + (match uu___8 with + | (lbs, body1) -> + let tm = + let uu___9 = + let uu___10 = + FStarC_Tactics_Types.goal_witness + goal in + uu___10.FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs + = (true, lbs); + FStarC_Syntax_Syntax.body1 + = body1 + }) uu___9 in + let uu___9 = + set_solution goal tm in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___9 + (fun uu___10 -> + (fun uu___10 -> + let uu___10 = + Obj.magic + uu___10 in + let uu___11 = + bnorm_and_replace + { + FStarC_Tactics_Types.goal_main_env + = + (goal.FStarC_Tactics_Types.goal_main_env); + FStarC_Tactics_Types.goal_ctx_uvar + = + ctx_uvar_u; + FStarC_Tactics_Types.opts + = + (goal.FStarC_Tactics_Types.opts); + FStarC_Tactics_Types.is_guard + = + (goal.FStarC_Tactics_Types.is_guard); + FStarC_Tactics_Types.label + = + (goal.FStarC_Tactics_Types.label) + } in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___11 + (fun + uu___12 + -> + (fun + uu___12 + -> + let uu___12 + = + Obj.magic + uu___12 in + let uu___13 + = + let uu___14 + = + FStarC_Syntax_Syntax.mk_binder + bv in + (uu___14, + b) in + Obj.magic + (ret + uu___13)) + uu___12))) + uu___10)))) + uu___7)))) + | FStar_Pervasives_Native.None -> + Obj.magic + (Obj.repr + (let uu___4 = + let uu___5 = + FStarC_Tactics_Types.goal_env goal in + let uu___6 = + FStarC_Tactics_Types.goal_type goal in + tts uu___5 uu___6 in + fail1 "intro_rec: goal is not an arrow (%s)" + uu___4)))) uu___1))) uu___ +let (norm : + FStar_Pervasives.norm_step Prims.list -> unit FStarC_Tactics_Monad.tac) = + fun s -> + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___ -> + (fun goal -> + let goal = Obj.magic goal in + let uu___ = + FStarC_Tactics_Monad.if_verbose + (fun uu___1 -> + let uu___2 = + let uu___3 = FStarC_Tactics_Types.goal_witness goal in + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + uu___3 in + FStarC_Compiler_Util.print1 "norm: witness = %s\n" uu___2) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac + () () uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + let steps = + let uu___2 = + FStarC_TypeChecker_Cfg.translate_norm_steps s in + FStarC_Compiler_List.op_At + [FStarC_TypeChecker_Env.Reify; + FStarC_TypeChecker_Env.DontUnfoldAttr + [FStarC_Parser_Const.tac_opaque_attr]] uu___2 in + let t = + let uu___2 = FStarC_Tactics_Types.goal_env goal in + let uu___3 = FStarC_Tactics_Types.goal_type goal in + normalize steps uu___2 uu___3 in + let uu___2 = goal_with_type goal t in + Obj.magic (FStarC_Tactics_Monad.replace_cur uu___2)) + uu___1))) uu___) +let (norm_term_env : + env -> + FStar_Pervasives.norm_step Prims.list -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term FStarC_Tactics_Monad.tac) + = + fun e -> + fun s -> + fun t -> + let uu___ = + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () + () (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___1 -> + (fun ps -> + let ps = Obj.magic ps in + let uu___1 = + FStarC_Tactics_Monad.if_verbose + (fun uu___2 -> + let uu___3 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.print1 + "norm_term_env: t = %s\n" uu___3) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () uu___1 + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + let uu___3 = __tc_lax e t in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___3) + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + match uu___4 with + | (t1, uu___5, uu___6) -> + let steps = + let uu___7 = + FStarC_TypeChecker_Cfg.translate_norm_steps + s in + FStarC_Compiler_List.op_At + [FStarC_TypeChecker_Env.Reify; + FStarC_TypeChecker_Env.DontUnfoldAttr + [FStarC_Parser_Const.tac_opaque_attr]] + uu___7 in + let t2 = + normalize steps + ps.FStarC_Tactics_Types.main_context + t1 in + let uu___7 = + FStarC_Tactics_Monad.if_verbose + (fun uu___8 -> + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t2 in + FStarC_Compiler_Util.print1 + "norm_term_env: t' = %s\n" + uu___9) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___7 + (fun uu___8 -> + (fun uu___8 -> + let uu___8 = + Obj.magic uu___8 in + Obj.magic (ret t2)) + uu___8))) uu___4))) + uu___2))) uu___1)) in + FStarC_Tactics_Monad.wrap_err "norm_term" uu___ +let (refine_intro : unit -> unit FStarC_Tactics_Monad.tac) = + fun uu___ -> + let uu___1 = + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___2 -> + (fun g -> + let g = Obj.magic g in + let uu___2 = + let uu___3 = FStarC_Tactics_Types.goal_env g in + let uu___4 = FStarC_Tactics_Types.goal_type g in + FStarC_TypeChecker_Rel.base_and_refinement uu___3 uu___4 in + match uu___2 with + | (uu___3, FStar_Pervasives_Native.None) -> + Obj.magic (FStarC_Tactics_Monad.fail "not a refinement") + | (t, FStar_Pervasives_Native.Some (bv, phi)) -> + (mark_goal_implicit_already_checked g; + (let g1 = goal_with_type g t in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Syntax_Syntax.mk_binder bv in + [uu___7] in + FStarC_Syntax_Subst.open_term uu___6 phi in + match uu___5 with + | (bvs, phi1) -> + let uu___6 = + let uu___7 = FStarC_Compiler_List.hd bvs in + uu___7.FStarC_Syntax_Syntax.binder_bv in + (uu___6, phi1) in + match uu___4 with + | (bv1, phi1) -> + let uu___5 = + let uu___6 = FStarC_Tactics_Types.goal_env g in + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Tactics_Types.goal_witness g in + (bv1, uu___11) in + FStarC_Syntax_Syntax.NT uu___10 in + [uu___9] in + FStarC_Syntax_Subst.subst uu___8 phi1 in + let uu___8 = + let uu___9 = should_check_goal_uvar g in + FStar_Pervasives_Native.Some uu___9 in + FStarC_Tactics_Monad.mk_irrelevant_goal + "refine_intro refinement" uu___6 uu___7 uu___8 + (rangeof g) g.FStarC_Tactics_Types.opts + g.FStarC_Tactics_Types.label in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___5) + (fun uu___6 -> + (fun g2 -> + let g2 = Obj.magic g2 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + FStarC_Tactics_Monad.dismiss + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = Obj.magic uu___6 in + Obj.magic + (FStarC_Tactics_Monad.add_goals + [g1; g2])) uu___6))) + uu___6))))) uu___2) in + FStarC_Tactics_Monad.wrap_err "refine_intro" uu___1 +let (__exact_now : + Prims.bool -> FStarC_Syntax_Syntax.term -> unit FStarC_Tactics_Monad.tac) = + fun set_expected_typ -> + fun t -> + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___ -> + (fun goal -> + let goal = Obj.magic goal in + let env1 = + if set_expected_typ + then + let uu___ = FStarC_Tactics_Types.goal_env goal in + let uu___1 = FStarC_Tactics_Types.goal_type goal in + FStarC_TypeChecker_Env.set_expected_typ uu___ uu___1 + else FStarC_Tactics_Types.goal_env goal in + let uu___ = __tc env1 t in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () (Obj.magic uu___) + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + match uu___1 with + | (t1, typ, guard) -> + let uu___2 = + FStarC_Tactics_Monad.if_verbose + (fun uu___3 -> + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term typ in + let uu___5 = + let uu___6 = + FStarC_Tactics_Types.goal_env goal in + FStarC_TypeChecker_Rel.guard_to_string + uu___6 guard in + FStarC_Compiler_Util.print2 + "__exact_now: got type %s\n__exact_now: and guard %s\n" + uu___4 uu___5) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () uu___2 + (fun uu___3 -> + (fun uu___3 -> + let uu___3 = Obj.magic uu___3 in + let uu___4 = + let uu___5 = + FStarC_Tactics_Types.goal_env + goal in + let uu___6 = + let uu___7 = + should_check_goal_uvar goal in + FStar_Pervasives_Native.Some + uu___7 in + proc_guard "__exact typing" uu___5 + guard uu___6 (rangeof goal) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___4 + (fun uu___5 -> + (fun uu___5 -> + let uu___5 = + Obj.magic uu___5 in + let uu___6 = + FStarC_Tactics_Monad.if_verbose + (fun uu___7 -> + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + typ in + let uu___9 = + let uu___10 = + FStarC_Tactics_Types.goal_type + goal in + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + uu___10 in + FStarC_Compiler_Util.print2 + "__exact_now: unifying %s and %s\n" + uu___8 uu___9) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___6 + (fun uu___7 -> + (fun uu___7 -> + let uu___7 = + Obj.magic + uu___7 in + let uu___8 = + let uu___9 = + FStarC_Tactics_Types.goal_env + goal in + let uu___10 = + FStarC_Tactics_Types.goal_type + goal in + do_unify true + uu___9 typ + uu___10 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic + uu___8) + (fun + uu___9 -> + (fun b -> + let b = + Obj.magic + b in + if b + then + (mark_goal_implicit_already_checked + goal; + Obj.magic + (solve + goal t1)) + else + (let uu___10 + = + let uu___11 + = + let uu___12 + = + FStarC_Tactics_Types.goal_env + goal in + tts + uu___12 in + let uu___12 + = + FStarC_Tactics_Types.goal_type + goal in + FStarC_TypeChecker_Err.print_discrepancy + uu___11 + typ + uu___12 in + match uu___10 + with + | + (typ1, + goalt) -> + let uu___11 + = + let uu___12 + = + FStarC_Tactics_Types.goal_env + goal in + tts + uu___12 + t1 in + let uu___12 + = + let uu___13 + = + FStarC_Tactics_Types.goal_env + goal in + let uu___14 + = + FStarC_Tactics_Types.goal_witness + goal in + tts + uu___13 + uu___14 in + Obj.magic + (fail4 + "%s : %s does not exactly solve the goal %s (witness = %s)" + uu___11 + typ1 + goalt + uu___12))) + uu___9))) + uu___7))) uu___5))) + uu___3))) uu___1))) uu___) +let (t_exact : + Prims.bool -> + Prims.bool -> FStarC_Syntax_Syntax.term -> unit FStarC_Tactics_Monad.tac) + = + fun try_refine -> + fun set_expected_typ -> + fun tm -> + let uu___ = + let uu___1 = + FStarC_Tactics_Monad.if_verbose + (fun uu___2 -> + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + tm in + FStarC_Compiler_Util.print1 "t_exact: tm = %s\n" uu___3) in + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + uu___1 + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + let uu___3 = + let uu___4 = __exact_now set_expected_typ tm in + FStarC_Tactics_Monad.catch uu___4 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___3) + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + match uu___4 with + | FStar_Pervasives.Inr r -> Obj.magic (ret ()) + | FStar_Pervasives.Inl e when + Prims.op_Negation try_refine -> + Obj.magic (FStarC_Tactics_Monad.traise e) + | FStar_Pervasives.Inl e -> + let uu___5 = + FStarC_Tactics_Monad.if_verbose + (fun uu___6 -> + FStarC_Compiler_Util.print_string + "__exact_now failed, trying refine...\n") in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + uu___5 + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = Obj.magic uu___6 in + let uu___7 = + let uu___8 = + let uu___9 = + norm + [FStar_Pervasives.Delta] in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___9 + (fun uu___10 -> + (fun uu___10 -> + let uu___10 = + Obj.magic uu___10 in + let uu___11 = + refine_intro () in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___11 + (fun uu___12 -> + (fun uu___12 + -> + let uu___12 + = + Obj.magic + uu___12 in + Obj.magic + (__exact_now + set_expected_typ + tm)) + uu___12))) + uu___10) in + FStarC_Tactics_Monad.catch + uu___8 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () (Obj.magic uu___7) + (fun uu___8 -> + (fun uu___8 -> + let uu___8 = + Obj.magic uu___8 in + match uu___8 with + | FStar_Pervasives.Inr + r -> + let uu___9 = + FStarC_Tactics_Monad.if_verbose + (fun uu___10 + -> + FStarC_Compiler_Util.print_string + "__exact_now: failed after refining too\n") in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___9 + (fun uu___10 + -> + (fun + uu___10 + -> + let uu___10 + = + Obj.magic + uu___10 in + Obj.magic + (ret ())) + uu___10)) + | FStar_Pervasives.Inl + uu___9 -> + let uu___10 = + FStarC_Tactics_Monad.if_verbose + (fun uu___11 + -> + FStarC_Compiler_Util.print_string + "__exact_now: was not a refinement\n") in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___10 + (fun uu___11 + -> + (fun + uu___11 + -> + let uu___11 + = + Obj.magic + uu___11 in + Obj.magic + (FStarC_Tactics_Monad.traise + e)) + uu___11))) + uu___8))) uu___6))) + uu___4))) uu___2) in + FStarC_Tactics_Monad.wrap_err "exact" uu___ +let (try_unify_by_application : + FStarC_Syntax_Syntax.should_check_uvar FStar_Pervasives_Native.option -> + Prims.bool -> + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> + FStarC_Compiler_Range_Type.range -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.aqual * + FStarC_Syntax_Syntax.ctx_uvar) Prims.list + FStarC_Tactics_Monad.tac) + = + fun should_check -> + fun only_match -> + fun e -> + fun ty1 -> + fun ty2 -> + fun rng -> + let f = if only_match then do_match else do_unify in + let must_tot = true in + let rec aux uu___2 uu___1 uu___ = + (fun acc -> + fun typedness_deps -> + fun ty11 -> + let uu___ = f must_tot e ty2 ty11 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___) + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + if uu___1 + then Obj.magic (Obj.repr (ret acc)) + else + Obj.magic + (Obj.repr + (let uu___2 = + FStarC_Syntax_Util.arrow_one ty11 in + match uu___2 with + | FStar_Pervasives_Native.None -> + Obj.repr + (let uu___3 = tts e ty11 in + let uu___4 = tts e ty2 in + fail2 + "Could not instantiate, %s to %s" + uu___3 uu___4) + | FStar_Pervasives_Native.Some + (b, c) -> + Obj.repr + (let uu___3 = + let uu___4 = + FStarC_Syntax_Util.is_total_comp + c in + Prims.op_Negation uu___4 in + if uu___3 + then + Obj.repr + (FStarC_Tactics_Monad.fail + "Codomain is effectful") + else + Obj.repr + (let uu___5 = + FStarC_Tactics_Monad.new_uvar + "apply arg" e + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort + should_check + typedness_deps rng in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic uu___5) + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = + Obj.magic + uu___6 in + match uu___6 + with + | (uvt, uv) -> + let uu___7 + = + FStarC_Tactics_Monad.if_verbose + (fun + uu___8 -> + let uu___9 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_ctxu + uv in + FStarC_Compiler_Util.print1 + "t_apply: generated uvar %s\n" + uu___9) in + Obj.magic + ( + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___7 + (fun + uu___8 -> + (fun + uu___8 -> + let uu___8 + = + Obj.magic + uu___8 in + let typ = + FStarC_Syntax_Util.comp_result + c in + let typ' + = + FStarC_Syntax_Subst.subst + [ + FStarC_Syntax_Syntax.NT + ((b.FStarC_Syntax_Syntax.binder_bv), + uvt)] typ in + let uu___9 + = + let uu___10 + = + let uu___11 + = + FStarC_Syntax_Util.aqual_of_binder + b in + (uvt, + uu___11, + uv) in + uu___10 + :: acc in + Obj.magic + (aux + uu___9 + (uv :: + typedness_deps) + typ')) + uu___8))) + uu___6)))))) + uu___1))) uu___2 uu___1 uu___ in + aux [] [] ty1 +let (apply_implicits_as_goals : + FStarC_TypeChecker_Env.env -> + FStarC_Tactics_Types.goal FStar_Pervasives_Native.option -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.ctx_uvar) Prims.list + -> + FStarC_Tactics_Types.goal Prims.list Prims.list + FStarC_Tactics_Monad.tac) + = + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun env1 -> + fun gl -> + fun imps -> + let one_implicit_as_goal uu___ = + match uu___ with + | (term, ctx_uvar) -> + let uu___1 = FStarC_Syntax_Util.head_and_args term in + (match uu___1 with + | (hd, uu___2) -> + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.compress hd in + uu___4.FStarC_Syntax_Syntax.n in + (match uu___3 with + | FStarC_Syntax_Syntax.Tm_uvar (ctx_uvar1, uu___4) + -> + let gl1 = + match gl with + | FStar_Pervasives_Native.None -> + let uu___5 = FStarC_Options.peek () in + FStarC_Tactics_Types.mk_goal env1 + ctx_uvar1 uu___5 true + "goal for unsolved implicit" + | FStar_Pervasives_Native.Some gl2 -> + { + FStarC_Tactics_Types.goal_main_env = + (gl2.FStarC_Tactics_Types.goal_main_env); + FStarC_Tactics_Types.goal_ctx_uvar = + ctx_uvar1; + FStarC_Tactics_Types.opts = + (gl2.FStarC_Tactics_Types.opts); + FStarC_Tactics_Types.is_guard = + (gl2.FStarC_Tactics_Types.is_guard); + FStarC_Tactics_Types.label = + (gl2.FStarC_Tactics_Types.label) + } in + let gl2 = bnorm_goal gl1 in ret [gl2] + | uu___4 -> ret [])) in + Obj.magic + (FStarC_Class_Monad.mapM FStarC_Tactics_Monad.monad_tac () + () (fun uu___ -> (Obj.magic one_implicit_as_goal) uu___) + (Obj.magic imps))) uu___2 uu___1 uu___ +let (t_apply : + Prims.bool -> + Prims.bool -> + Prims.bool -> + FStarC_Syntax_Syntax.term -> unit FStarC_Tactics_Monad.tac) + = + fun uopt -> + fun only_match -> + fun tc_resolved_uvars -> + fun tm -> + let uu___ = + let tc_resolved_uvars1 = true in + let uu___1 = + FStarC_Tactics_Monad.if_verbose + (fun uu___2 -> + let uu___3 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) uopt in + let uu___4 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) only_match in + let uu___5 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + tc_resolved_uvars1 in + let uu___6 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + tm in + FStarC_Compiler_Util.print4 + "t_apply: uopt %s, only_match %s, tc_resolved_uvars %s, tm = %s\n" + uu___3 uu___4 uu___5 uu___6) in + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () + () uu___1 + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___3 -> + (fun ps -> + let ps = Obj.magic ps in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___3 -> + (fun goal -> + let goal = Obj.magic goal in + let e = + FStarC_Tactics_Types.goal_env + goal in + let should_check = + should_check_goal_uvar goal in + FStarC_Tactics_Monad.register_goal + goal; + (let uu___4 = __tc e tm in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () (Obj.magic uu___4) + (fun uu___5 -> + (fun uu___5 -> + let uu___5 = + Obj.magic uu___5 in + match uu___5 with + | (tm1, typ, guard) -> + let uu___6 = + FStarC_Tactics_Monad.if_verbose + (fun uu___7 -> + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + tm1 in + let uu___9 = + FStarC_Tactics_Printing.goal_to_string_verbose + goal in + let uu___10 + = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binding) + e.FStarC_TypeChecker_Env.gamma in + let uu___11 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + typ in + let uu___12 + = + FStarC_TypeChecker_Rel.guard_to_string + e guard in + FStarC_Compiler_Util.print5 + "t_apply: tm = %s\nt_apply: goal = %s\nenv.gamma=%s\ntyp=%s\nguard=%s\n" + uu___8 + uu___9 + uu___10 + uu___11 + uu___12) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___6 + (fun uu___7 -> + (fun uu___7 + -> + let uu___7 + = + Obj.magic + uu___7 in + let typ1 + = + bnorm e + typ in + let uu___8 + = + let uu___9 + = + FStarC_Tactics_Types.goal_type + goal in + try_unify_by_application + (FStar_Pervasives_Native.Some + should_check) + only_match + e typ1 + uu___9 + (rangeof + goal) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic + uu___8) + (fun + uu___9 -> + (fun uvs + -> + let uvs = + Obj.magic + uvs in + let uu___9 + = + FStarC_Tactics_Monad.if_verbose + (fun + uu___10 + -> + let uu___11 + = + (FStarC_Common.string_of_list + ()) + (fun + uu___12 + -> + match uu___12 + with + | + (t, + uu___13, + uu___14) + -> + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t) uvs in + FStarC_Compiler_Util.print1 + "t_apply: found args = %s\n" + uu___11) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___9 + (fun + uu___10 + -> + (fun + uu___10 + -> + let uu___10 + = + Obj.magic + uu___10 in + let w = + FStarC_Compiler_List.fold_right + (fun + uu___11 + -> + fun w1 -> + match uu___11 + with + | + (uvt, q, + uu___12) + -> + FStarC_Syntax_Util.mk_app + w1 + [ + (uvt, q)]) + uvs tm1 in + let uvset + = + let uu___11 + = + Obj.magic + (FStarC_Class_Setlike.empty + () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) + ()) in + FStarC_Compiler_List.fold_right + (fun + uu___13 + -> + fun + uu___12 + -> + (fun + uu___12 + -> + fun s -> + match uu___12 + with + | + (uu___13, + uu___14, + uv) -> + let uu___15 + = + let uu___16 + = + FStarC_Syntax_Util.ctx_uvar_typ + uv in + FStarC_Syntax_Free.uvars + uu___16 in + Obj.magic + (FStarC_Class_Setlike.union + () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) + (Obj.magic + s) + (Obj.magic + uu___15))) + uu___13 + uu___12) + uvs + uu___11 in + let free_in_some_goal + uv = + FStarC_Class_Setlike.mem + () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) + uv + (Obj.magic + uvset) in + let uu___11 + = + solve' + goal w in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___11 + (fun + uu___12 + -> + (fun + uu___12 + -> + let uu___12 + = + Obj.magic + uu___12 in + let uvt_uv_l + = + FStarC_Compiler_List.map + (fun + uu___13 + -> + match uu___13 + with + | + (uvt, _q, + uv) -> + (uvt, uv)) + uvs in + let uu___13 + = + apply_implicits_as_goals + e + (FStar_Pervasives_Native.Some + goal) + uvt_uv_l in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic + uu___13) + (fun + uu___14 + -> + (fun + sub_goals + -> + let sub_goals + = + Obj.magic + sub_goals in + let sub_goals1 + = + let uu___14 + = + let uu___15 + = + FStarC_Compiler_List.filter + (fun g -> + let uu___16 + = + uopt && + (free_in_some_goal + g.FStarC_Tactics_Types.goal_ctx_uvar) in + Prims.op_Negation + uu___16) + (FStarC_Compiler_List.flatten + sub_goals) in + FStarC_Compiler_List.map + bnorm_goal + uu___15 in + FStarC_Compiler_List.rev + uu___14 in + let uu___14 + = + FStarC_Tactics_Monad.add_goals + sub_goals1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___14 + (fun + uu___15 + -> + (fun + uu___15 + -> + let uu___15 + = + Obj.magic + uu___15 in + Obj.magic + (proc_guard + "apply guard" + e guard + (FStar_Pervasives_Native.Some + should_check) + (rangeof + goal))) + uu___15))) + uu___14))) + uu___12))) + uu___10))) + uu___9))) + uu___7))) + uu___5)))) uu___3))) + uu___3))) uu___2) in + FStarC_Tactics_Monad.wrap_err "apply" uu___ +let (lemma_or_sq : + FStarC_Syntax_Syntax.comp -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.term) + FStar_Pervasives_Native.option) + = + fun c -> + let uu___ = FStarC_Syntax_Util.comp_eff_name_res_and_args c in + match uu___ with + | (eff_name, res, args) -> + let uu___1 = + FStarC_Ident.lid_equals eff_name + FStarC_Parser_Const.effect_Lemma_lid in + if uu___1 + then + let uu___2 = + match args with + | pre::post::uu___3 -> + ((FStar_Pervasives_Native.fst pre), + (FStar_Pervasives_Native.fst post)) + | uu___3 -> failwith "apply_lemma: impossible: not a lemma" in + (match uu___2 with + | (pre, post) -> + let post1 = + let uu___3 = + let uu___4 = + FStarC_Syntax_Syntax.as_arg FStarC_Syntax_Util.exp_unit in + [uu___4] in + FStarC_Syntax_Util.mk_app post uu___3 in + FStar_Pervasives_Native.Some (pre, post1)) + else + (let uu___3 = + (FStarC_Syntax_Util.is_pure_effect eff_name) || + (FStarC_Syntax_Util.is_ghost_effect eff_name) in + if uu___3 + then + let uu___4 = FStarC_Syntax_Util.un_squash res in + FStarC_Compiler_Util.map_opt uu___4 + (fun post -> (FStarC_Syntax_Util.t_true, post)) + else FStar_Pervasives_Native.None) +let rec fold_left : + 'a 'b . + ('a -> 'b -> 'b FStarC_Tactics_Monad.tac) -> + 'b -> 'a Prims.list -> 'b FStarC_Tactics_Monad.tac + = + fun f -> + fun e -> + fun xs -> + match xs with + | [] -> ret e + | x::xs1 -> + let uu___ = f x e in + let uu___1 = bind () in + uu___1 uu___ (fun e' -> fold_left f e' xs1) +let (t_apply_lemma : + Prims.bool -> + Prims.bool -> FStarC_Syntax_Syntax.term -> unit FStarC_Tactics_Monad.tac) + = + fun noinst -> + fun noinst_lhs -> + fun tm -> + let uu___ = + let uu___1 = + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () + () (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___2 -> + (fun ps -> + let ps = Obj.magic ps in + let uu___2 = + FStarC_Tactics_Monad.if_verbose + (fun uu___3 -> + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term tm in + FStarC_Compiler_Util.print1 + "apply_lemma: tm = %s\n" uu___4) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () uu___2 + (fun uu___3 -> + (fun uu___3 -> + let uu___3 = Obj.magic uu___3 in + let is_unit_t t = + let uu___4 = + let uu___5 = + FStarC_Syntax_Subst.compress t in + uu___5.FStarC_Syntax_Syntax.n in + match uu___4 with + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.unit_lid + -> true + | uu___5 -> false in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___4 -> + (fun goal -> + let goal = Obj.magic goal in + let env1 = + FStarC_Tactics_Types.goal_env + goal in + FStarC_Tactics_Monad.register_goal + goal; + (let uu___5 = __tc env1 tm in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () (Obj.magic uu___5) + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = + Obj.magic uu___6 in + match uu___6 with + | (tm1, t, guard) -> + let uu___7 = + FStarC_Syntax_Util.arrow_formals_comp + t in + (match uu___7 with + | (bs, comp) -> + let uu___8 = + lemma_or_sq + comp in + (match uu___8 + with + | FStar_Pervasives_Native.None + -> + Obj.magic + (FStarC_Tactics_Monad.fail + "not a lemma or squashed function") + | FStar_Pervasives_Native.Some + (pre, + post) -> + let uu___9 + = + fold_left + (fun + uu___11 + -> + fun + uu___10 + -> + (fun + uu___10 + -> + fun + uu___11 + -> + match + (uu___10, + uu___11) + with + | + ({ + FStarC_Syntax_Syntax.binder_bv + = b; + FStarC_Syntax_Syntax.binder_qual + = aq; + FStarC_Syntax_Syntax.binder_positivity + = uu___12; + FStarC_Syntax_Syntax.binder_attrs + = uu___13;_}, + (uvs, + deps, + imps, + subst)) + -> + let b_t = + FStarC_Syntax_Subst.subst + subst + b.FStarC_Syntax_Syntax.sort in + let uu___14 + = + is_unit_t + b_t in + if + uu___14 + then + Obj.magic + (Obj.repr + (ret + (((FStarC_Syntax_Util.exp_unit, + aq) :: + uvs), + deps, + imps, + ((FStarC_Syntax_Syntax.NT + (b, + FStarC_Syntax_Util.exp_unit)) + :: + subst)))) + else + Obj.magic + (Obj.repr + (let uu___16 + = + let uu___17 + = + let uu___18 + = + let uu___19 + = + should_check_goal_uvar + goal in + match uu___19 + with + | + FStarC_Syntax_Syntax.Strict + -> + FStarC_Syntax_Syntax.Allow_ghost + "apply lemma uvar" + | + x -> x in + FStar_Pervasives_Native.Some + uu___18 in + FStarC_Tactics_Monad.new_uvar + "apply_lemma" + env1 b_t + uu___17 + deps + (rangeof + goal) in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic + uu___16) + (fun + uu___17 + -> + (fun + uu___17 + -> + let uu___17 + = + Obj.magic + uu___17 in + match uu___17 + with + | + (t1, u) + -> + (( + let uu___19 + = + (FStarC_Compiler_Debug.medium + ()) || + (FStarC_Compiler_Effect.op_Bang + dbg_2635) in + if + uu___19 + then + let uu___20 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_ctxu + u in + let uu___21 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + tm1 in + FStarC_Compiler_Util.print2 + "Apply lemma created a new uvar %s while applying %s\n" + uu___20 + uu___21 + else ()); + Obj.magic + (ret + (((t1, + aq) :: + uvs), (u + :: deps), + ((t1, u) + :: imps), + ((FStarC_Syntax_Syntax.NT + (b, t1)) + :: + subst))))) + uu___17)))) + uu___11 + uu___10) + ([], [], + [], []) + bs in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic + uu___9) + (fun + uu___10 + -> + (fun + uu___10 + -> + let uu___10 + = + Obj.magic + uu___10 in + match uu___10 + with + | + (uvs, + uu___11, + implicits1, + subst) -> + let implicits2 + = + FStarC_Compiler_List.rev + implicits1 in + let uvs1 + = + FStarC_Compiler_List.rev + uvs in + let pre1 + = + FStarC_Syntax_Subst.subst + subst pre in + let post1 + = + FStarC_Syntax_Subst.subst + subst + post in + let post_u + = + env1.FStarC_TypeChecker_Env.universe_of + env1 + post1 in + let cmp_func + = + if noinst + then + do_match + else + if + noinst_lhs + then + do_match_on_lhs + else + do_unify in + let uu___12 + = + let must_tot + = false in + let uu___13 + = + FStarC_Tactics_Types.goal_type + goal in + let uu___14 + = + FStarC_Syntax_Util.mk_squash + post_u + post1 in + cmp_func + must_tot + env1 + uu___13 + uu___14 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic + uu___12) + (fun + uu___13 + -> + (fun b -> + let b = + Obj.magic + b in + if + Prims.op_Negation + b + then + let uu___13 + = + let uu___14 + = + FStarC_Syntax_Util.mk_squash + post_u + post1 in + let uu___15 + = + FStarC_Tactics_Types.goal_type + goal in + FStarC_TypeChecker_Err.print_discrepancy + (tts env1) + uu___14 + uu___15 in + match uu___13 + with + | + (post2, + goalt) -> + let uu___14 + = + tts env1 + tm1 in + Obj.magic + (fail3 + "Cannot instantiate lemma %s (with postcondition: %s) to match goal (%s)" + uu___14 + post2 + goalt) + else + (let goal_sc + = + should_check_goal_uvar + goal in + let uu___14 + = + solve' + goal + FStarC_Syntax_Util.exp_unit in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___14 + (fun + uu___15 + -> + (fun + uu___15 + -> + let uu___15 + = + Obj.magic + uu___15 in + let is_free_uvar + uv t1 = + let free_uvars + = + let uu___16 + = + let uu___17 + = + FStarC_Syntax_Free.uvars + t1 in + FStarC_Class_Setlike.elems + () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) + (Obj.magic + uu___17) in + FStarC_Compiler_List.map + (fun x -> + x.FStarC_Syntax_Syntax.ctx_uvar_head) + uu___16 in + FStarC_Compiler_List.existsML + (fun u -> + FStarC_Syntax_Unionfind.equiv + u uv) + free_uvars in + let appears + uv goals + = + FStarC_Compiler_List.existsML + (fun g' + -> + let uu___16 + = + FStarC_Tactics_Types.goal_type + g' in + is_free_uvar + uv + uu___16) + goals in + let checkone + t1 goals + = + let uu___16 + = + FStarC_Syntax_Util.head_and_args + t1 in + match uu___16 + with + | + (hd, + uu___17) + -> + (match + hd.FStarC_Syntax_Syntax.n + with + | + FStarC_Syntax_Syntax.Tm_uvar + (uv, + uu___18) + -> + appears + uv.FStarC_Syntax_Syntax.ctx_uvar_head + goals + | + uu___18 + -> false) in + let must_tot + = false in + let uu___16 + = + apply_implicits_as_goals + env1 + (FStar_Pervasives_Native.Some + goal) + implicits2 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic + uu___16) + (fun + uu___17 + -> + (fun + sub_goals + -> + let sub_goals + = + Obj.magic + sub_goals in + let sub_goals1 + = + FStarC_Compiler_List.flatten + sub_goals in + let rec filter' + f xs = + match xs + with + | + [] -> [] + | + x::xs1 -> + let uu___17 + = f x xs1 in + if + uu___17 + then + let uu___18 + = + filter' f + xs1 in x + :: + uu___18 + else + filter' f + xs1 in + let sub_goals2 + = + filter' + (fun g -> + fun goals + -> + let uu___17 + = + let uu___18 + = + FStarC_Tactics_Types.goal_witness + g in + checkone + uu___18 + goals in + Prims.op_Negation + uu___17) + sub_goals1 in + let uu___17 + = + proc_guard + "apply_lemma guard" + env1 + guard + (FStar_Pervasives_Native.Some + goal_sc) + (rangeof + goal) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___17 + (fun + uu___18 + -> + (fun + uu___18 + -> + let uu___18 + = + Obj.magic + uu___18 in + let pre_u + = + env1.FStarC_TypeChecker_Env.universe_of + env1 pre1 in + let uu___19 + = + let uu___20 + = + let uu___21 + = + let uu___22 + = + FStarC_TypeChecker_Env.guard_of_guard_formula + (FStarC_TypeChecker_Common.NonTrivial + pre1) in + FStarC_TypeChecker_Rel.simplify_guard + env1 + uu___22 in + uu___21.FStarC_TypeChecker_Common.guard_f in + match uu___20 + with + | + FStarC_TypeChecker_Common.Trivial + -> + ret () + | + FStarC_TypeChecker_Common.NonTrivial + uu___21 + -> + FStarC_Tactics_Monad.add_irrelevant_goal + goal + "apply_lemma precondition" + env1 pre1 + (FStar_Pervasives_Native.Some + goal_sc) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___19 + (fun + uu___20 + -> + (fun + uu___20 + -> + let uu___20 + = + Obj.magic + uu___20 in + Obj.magic + (FStarC_Tactics_Monad.add_goals + sub_goals2)) + uu___20))) + uu___18))) + uu___17))) + uu___15)))) + uu___13))) + uu___10))))) + uu___6)))) uu___4))) + uu___3))) uu___2) in + focus uu___1 in + FStarC_Tactics_Monad.wrap_err "apply_lemma" uu___ +let (split_env : + FStarC_Syntax_Syntax.bv -> + env -> + (env * FStarC_Syntax_Syntax.bv * FStarC_Syntax_Syntax.bv Prims.list) + FStar_Pervasives_Native.option) + = + fun bvar -> + fun e -> + let rec aux e1 = + let uu___ = FStarC_TypeChecker_Env.pop_bv e1 in + match uu___ with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (bv', e') -> + let uu___1 = FStarC_Syntax_Syntax.bv_eq bvar bv' in + if uu___1 + then FStar_Pervasives_Native.Some (e', bv', []) + else + (let uu___3 = aux e' in + FStarC_Compiler_Util.map_opt uu___3 + (fun uu___4 -> + match uu___4 with + | (e'', bv, bvs) -> (e'', bv, (bv' :: bvs)))) in + let uu___ = aux e in + FStarC_Compiler_Util.map_opt uu___ + (fun uu___1 -> + match uu___1 with + | (e', bv, bvs) -> (e', bv, (FStarC_Compiler_List.rev bvs))) +let (subst_goal : + FStarC_Syntax_Syntax.bv -> + FStarC_Syntax_Syntax.bv -> + FStarC_Tactics_Types.goal -> + (FStarC_Syntax_Syntax.bv * FStarC_Tactics_Types.goal) + FStar_Pervasives_Native.option FStarC_Tactics_Monad.tac) + = + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun b1 -> + fun b2 -> + fun g -> + let uu___ = + let uu___1 = FStarC_Tactics_Types.goal_env g in + split_env b1 uu___1 in + match uu___ with + | FStar_Pervasives_Native.Some (e0, b11, bvs) -> + Obj.magic + (Obj.repr + (let bs = + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.mk_binder (b11 :: bvs) in + let t = FStarC_Tactics_Types.goal_type g in + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.close_binders bs in + let uu___3 = FStarC_Syntax_Subst.close bs t in + (uu___2, uu___3) in + match uu___1 with + | (bs', t') -> + let bs'1 = + let uu___2 = FStarC_Syntax_Syntax.mk_binder b2 in + let uu___3 = FStarC_Compiler_List.tail bs' in + uu___2 :: uu___3 in + let uu___2 = + FStarC_TypeChecker_Core.open_binders_in_term + e0 bs'1 t' in + (match uu___2 with + | (new_env, bs'', t'') -> + let b21 = + let uu___3 = FStarC_Compiler_List.hd bs'' in + uu___3.FStarC_Syntax_Syntax.binder_bv in + let uu___3 = + let uu___4 = + let uu___5 = should_check_goal_uvar g in + FStar_Pervasives_Native.Some uu___5 in + let uu___5 = goal_typedness_deps g in + FStarC_Tactics_Monad.new_uvar + "subst_goal" new_env t'' uu___4 uu___5 + (rangeof g) in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___3) + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + match uu___4 with + | (uvt, uv) -> + let goal' = + FStarC_Tactics_Types.mk_goal + new_env uv + g.FStarC_Tactics_Types.opts + g.FStarC_Tactics_Types.is_guard + g.FStarC_Tactics_Types.label in + let sol = + let uu___5 = + FStarC_Syntax_Util.abs bs'' + uvt + FStar_Pervasives_Native.None in + let uu___6 = + FStarC_Compiler_List.map + (fun uu___7 -> + match uu___7 with + | { + FStarC_Syntax_Syntax.binder_bv + = bv; + FStarC_Syntax_Syntax.binder_qual + = q; + FStarC_Syntax_Syntax.binder_positivity + = uu___8; + FStarC_Syntax_Syntax.binder_attrs + = uu___9;_} + -> + let uu___10 = + FStarC_Syntax_Syntax.bv_to_name + bv in + FStarC_Syntax_Syntax.as_arg + uu___10) bs in + FStarC_Syntax_Util.mk_app + uu___5 uu___6 in + let uu___5 = set_solution g sol in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___5 + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = + Obj.magic uu___6 in + Obj.magic + (ret + (FStar_Pervasives_Native.Some + (b21, goal')))) + uu___6))) uu___4)))) + | FStar_Pervasives_Native.None -> + Obj.magic (Obj.repr (ret FStar_Pervasives_Native.None))) + uu___2 uu___1 uu___ +let (rewrite : FStarC_Syntax_Syntax.binder -> unit FStarC_Tactics_Monad.tac) + = + fun h -> + let uu___ = + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___1 -> + (fun goal -> + let goal = Obj.magic goal in + let bv = h.FStarC_Syntax_Syntax.binder_bv in + let uu___1 = + FStarC_Tactics_Monad.if_verbose + (fun uu___2 -> + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_bv + bv in + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + bv.FStarC_Syntax_Syntax.sort in + FStarC_Compiler_Util.print2 "+++Rewrite %s : %s\n" + uu___3 uu___4) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () uu___1 + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + let uu___3 = + let uu___4 = FStarC_Tactics_Types.goal_env goal in + split_env bv uu___4 in + match uu___3 with + | FStar_Pervasives_Native.None -> + Obj.magic + (FStarC_Tactics_Monad.fail + "binder not found in environment") + | FStar_Pervasives_Native.Some (e0, bv1, bvs) -> + let uu___4 = + destruct_eq e0 bv1.FStarC_Syntax_Syntax.sort in + (match uu___4 with + | FStar_Pervasives_Native.Some (x, e) -> + let uu___5 = + let uu___6 = + FStarC_Syntax_Subst.compress x in + uu___6.FStarC_Syntax_Syntax.n in + (match uu___5 with + | FStarC_Syntax_Syntax.Tm_name x1 -> + let s = + [FStarC_Syntax_Syntax.NT (x1, e)] in + let t = + FStarC_Tactics_Types.goal_type goal in + let bs = + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.mk_binder bvs in + let uu___6 = + let uu___7 = + FStarC_Syntax_Subst.close_binders + bs in + let uu___8 = + FStarC_Syntax_Subst.close bs t in + (uu___7, uu___8) in + (match uu___6 with + | (bs', t') -> + let uu___7 = + let uu___8 = + FStarC_Syntax_Subst.subst_binders + s bs' in + let uu___9 = + FStarC_Syntax_Subst.subst s + t' in + (uu___8, uu___9) in + (match uu___7 with + | (bs'1, t'1) -> + let e01 = + FStarC_TypeChecker_Env.push_bvs + e0 [bv1] in + let uu___8 = + FStarC_TypeChecker_Core.open_binders_in_term + e01 bs'1 t'1 in + (match uu___8 with + | (new_env, bs'', t'') -> + let uu___9 = + let uu___10 = + let uu___11 = + should_check_goal_uvar + goal in + FStar_Pervasives_Native.Some + uu___11 in + let uu___11 = + goal_typedness_deps + goal in + FStarC_Tactics_Monad.new_uvar + "rewrite" new_env + t'' uu___10 uu___11 + (rangeof goal) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic uu___9) + (fun uu___10 -> + (fun uu___10 -> + let uu___10 + = + Obj.magic + uu___10 in + match uu___10 + with + | (uvt, uv) + -> + let goal' + = + FStarC_Tactics_Types.mk_goal + new_env + uv + goal.FStarC_Tactics_Types.opts + goal.FStarC_Tactics_Types.is_guard + goal.FStarC_Tactics_Types.label in + let sol = + let uu___11 + = + FStarC_Syntax_Util.abs + bs'' uvt + FStar_Pervasives_Native.None in + let uu___12 + = + FStarC_Compiler_List.map + (fun + uu___13 + -> + match uu___13 + with + | + { + FStarC_Syntax_Syntax.binder_bv + = bv2; + FStarC_Syntax_Syntax.binder_qual + = uu___14; + FStarC_Syntax_Syntax.binder_positivity + = uu___15; + FStarC_Syntax_Syntax.binder_attrs + = uu___16;_} + -> + let uu___17 + = + FStarC_Syntax_Syntax.bv_to_name + bv2 in + FStarC_Syntax_Syntax.as_arg + uu___17) + bs in + FStarC_Syntax_Util.mk_app + uu___11 + uu___12 in + let uu___11 + = + set_solution + goal sol in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___11 + (fun + uu___12 + -> + (fun + uu___12 + -> + let uu___12 + = + Obj.magic + uu___12 in + Obj.magic + (FStarC_Tactics_Monad.replace_cur + goal')) + uu___12))) + uu___10))))) + | uu___6 -> + Obj.magic + (FStarC_Tactics_Monad.fail + "Not an equality hypothesis with a variable on the LHS")) + | uu___5 -> + Obj.magic + (FStarC_Tactics_Monad.fail + "Not an equality hypothesis"))) uu___2))) + uu___1) in + FStarC_Tactics_Monad.wrap_err "rewrite" uu___ +let (rename_to : + FStarC_Syntax_Syntax.binder -> + Prims.string -> FStarC_Syntax_Syntax.binder FStarC_Tactics_Monad.tac) + = + fun b -> + fun s -> + let uu___ = + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () + () (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___1 -> + (fun goal -> + let goal = Obj.magic goal in + let bv = b.FStarC_Syntax_Syntax.binder_bv in + let bv' = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Ident.range_of_id + bv.FStarC_Syntax_Syntax.ppname in + (s, uu___4) in + FStarC_Ident.mk_ident uu___3 in + { + FStarC_Syntax_Syntax.ppname = uu___2; + FStarC_Syntax_Syntax.index = + (bv.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = + (bv.FStarC_Syntax_Syntax.sort) + } in + FStarC_Syntax_Syntax.freshen_bv uu___1 in + let uu___1 = subst_goal bv bv' goal in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + match uu___2 with + | FStar_Pervasives_Native.None -> + Obj.magic + (Obj.repr + (FStarC_Tactics_Monad.fail + "binder not found in environment")) + | FStar_Pervasives_Native.Some (bv'1, goal1) -> + Obj.magic + (Obj.repr + (let uu___3 = + FStarC_Tactics_Monad.replace_cur + goal1 in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () + () uu___3 + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + Obj.magic + (ret + { + FStarC_Syntax_Syntax.binder_bv + = bv'1; + FStarC_Syntax_Syntax.binder_qual + = + (b.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity + = + (b.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs + = + (b.FStarC_Syntax_Syntax.binder_attrs) + })) uu___4)))) uu___2))) + uu___1)) in + FStarC_Tactics_Monad.wrap_err "rename_to" uu___ +let (binder_retype : + FStarC_Syntax_Syntax.binder -> unit FStarC_Tactics_Monad.tac) = + fun b -> + let uu___ = + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___1 -> + (fun goal -> + let goal = Obj.magic goal in + let bv = b.FStarC_Syntax_Syntax.binder_bv in + let uu___1 = + let uu___2 = FStarC_Tactics_Types.goal_env goal in + split_env bv uu___2 in + match uu___1 with + | FStar_Pervasives_Native.None -> + Obj.magic + (FStarC_Tactics_Monad.fail + "binder is not present in environment") + | FStar_Pervasives_Native.Some (e0, bv1, bvs) -> + let uu___2 = FStarC_Syntax_Util.type_u () in + (match uu___2 with + | (ty, u) -> + let goal_sc = should_check_goal_uvar goal in + let uu___3 = + let uu___4 = goal_typedness_deps goal in + FStarC_Tactics_Monad.new_uvar "binder_retype" e0 ty + (FStar_Pervasives_Native.Some goal_sc) uu___4 + (rangeof goal) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___3) + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + match uu___4 with + | (t', u_t') -> + let bv'' = + { + FStarC_Syntax_Syntax.ppname = + (bv1.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (bv1.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = t' + } in + let s = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Syntax_Syntax.bv_to_name + bv'' in + (bv1, uu___7) in + FStarC_Syntax_Syntax.NT uu___6 in + [uu___5] in + let bvs1 = + FStarC_Compiler_List.map + (fun b1 -> + let uu___5 = + FStarC_Syntax_Subst.subst s + b1.FStarC_Syntax_Syntax.sort in + { + FStarC_Syntax_Syntax.ppname = + (b1.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (b1.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = + uu___5 + }) bvs in + let env' = + FStarC_TypeChecker_Env.push_bvs e0 + (bv'' :: bvs1) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () + () FStarC_Tactics_Monad.dismiss + (fun uu___5 -> + (fun uu___5 -> + let uu___5 = + Obj.magic uu___5 in + let new_goal = + let uu___6 = + FStarC_Tactics_Types.goal_with_env + goal env' in + let uu___7 = + let uu___8 = + FStarC_Tactics_Types.goal_type + goal in + FStarC_Syntax_Subst.subst + s uu___8 in + goal_with_type uu___6 + uu___7 in + let uu___6 = + FStarC_Tactics_Monad.add_goals + [new_goal] in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___6 + (fun uu___7 -> + (fun uu___7 -> + let uu___7 = + Obj.magic + uu___7 in + let uu___8 = + FStarC_Syntax_Util.mk_eq2 + (FStarC_Syntax_Syntax.U_succ + u) ty + bv1.FStarC_Syntax_Syntax.sort + t' in + Obj.magic + (FStarC_Tactics_Monad.add_irrelevant_goal + goal + "binder_retype equation" + e0 uu___8 + (FStar_Pervasives_Native.Some + goal_sc))) + uu___7))) uu___5))) + uu___4)))) uu___1) in + FStarC_Tactics_Monad.wrap_err "binder_retype" uu___ +let (norm_binder_type : + FStar_Pervasives.norm_step Prims.list -> + FStarC_Syntax_Syntax.binder -> unit FStarC_Tactics_Monad.tac) + = + fun s -> + fun b -> + let uu___ = + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___1 -> + (fun goal -> + let goal = Obj.magic goal in + let bv = b.FStarC_Syntax_Syntax.binder_bv in + let uu___1 = + let uu___2 = FStarC_Tactics_Types.goal_env goal in + split_env bv uu___2 in + match uu___1 with + | FStar_Pervasives_Native.None -> + Obj.magic + (FStarC_Tactics_Monad.fail + "binder is not present in environment") + | FStar_Pervasives_Native.Some (e0, bv1, bvs) -> + let steps = + let uu___2 = + FStarC_TypeChecker_Cfg.translate_norm_steps s in + FStarC_Compiler_List.op_At + [FStarC_TypeChecker_Env.Reify; + FStarC_TypeChecker_Env.DontUnfoldAttr + [FStarC_Parser_Const.tac_opaque_attr]] uu___2 in + let sort' = + normalize steps e0 bv1.FStarC_Syntax_Syntax.sort in + let bv' = + { + FStarC_Syntax_Syntax.ppname = + (bv1.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (bv1.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = sort' + } in + let env' = + FStarC_TypeChecker_Env.push_bvs e0 (bv' :: bvs) in + let uu___2 = FStarC_Tactics_Types.goal_with_env goal env' in + Obj.magic (FStarC_Tactics_Monad.replace_cur uu___2)) + uu___1) in + FStarC_Tactics_Monad.wrap_err "norm_binder_type" uu___ +let (revert : unit -> unit FStarC_Tactics_Monad.tac) = + fun uu___ -> + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___1 -> + (fun goal -> + let goal = Obj.magic goal in + let uu___1 = + let uu___2 = FStarC_Tactics_Types.goal_env goal in + FStarC_TypeChecker_Env.pop_bv uu___2 in + match uu___1 with + | FStar_Pervasives_Native.None -> + Obj.magic + (FStarC_Tactics_Monad.fail "Cannot revert; empty context") + | FStar_Pervasives_Native.Some (x, env') -> + let typ' = + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.mk_binder x in [uu___3] in + let uu___3 = + let uu___4 = FStarC_Tactics_Types.goal_type goal in + FStarC_Syntax_Syntax.mk_Total uu___4 in + FStarC_Syntax_Util.arrow uu___2 uu___3 in + let uu___2 = + let uu___3 = + let uu___4 = should_check_goal_uvar goal in + FStar_Pervasives_Native.Some uu___4 in + let uu___4 = goal_typedness_deps goal in + FStarC_Tactics_Monad.new_uvar "revert" env' typ' uu___3 + uu___4 (rangeof goal) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () (Obj.magic uu___2) + (fun uu___3 -> + (fun uu___3 -> + let uu___3 = Obj.magic uu___3 in + match uu___3 with + | (r, u_r) -> + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Syntax.bv_to_name x in + FStarC_Syntax_Syntax.as_arg uu___8 in + [uu___7] in + let uu___7 = + let uu___8 = + FStarC_Tactics_Types.goal_type goal in + uu___8.FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.mk_Tm_app r uu___6 + uu___7 in + set_solution goal uu___5 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + uu___4 + (fun uu___5 -> + (fun uu___5 -> + let uu___5 = Obj.magic uu___5 in + let g = + FStarC_Tactics_Types.mk_goal env' + u_r + goal.FStarC_Tactics_Types.opts + goal.FStarC_Tactics_Types.is_guard + goal.FStarC_Tactics_Types.label in + Obj.magic + (FStarC_Tactics_Monad.replace_cur + g)) uu___5))) uu___3))) uu___1) +let (free_in : + FStarC_Syntax_Syntax.bv -> FStarC_Syntax_Syntax.term -> Prims.bool) = + fun bv -> + fun t -> + let uu___ = FStarC_Syntax_Free.names t in + FStarC_Class_Setlike.mem () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) bv (Obj.magic uu___) +let (clear : FStarC_Syntax_Syntax.binder -> unit FStarC_Tactics_Monad.tac) = + fun b -> + let bv = b.FStarC_Syntax_Syntax.binder_bv in + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___ -> + (fun goal -> + let goal = Obj.magic goal in + let uu___ = + FStarC_Tactics_Monad.if_verbose + (fun uu___1 -> + let uu___2 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_binder b in + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Tactics_Types.goal_env goal in + FStarC_TypeChecker_Env.all_binders uu___6 in + FStarC_Compiler_List.length uu___5 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_nat) uu___4 in + FStarC_Compiler_Util.print2 + "Clear of (%s), env has %s binders\n" uu___2 uu___3) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac + () () uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + let uu___2 = + let uu___3 = FStarC_Tactics_Types.goal_env goal in + split_env bv uu___3 in + match uu___2 with + | FStar_Pervasives_Native.None -> + Obj.magic + (FStarC_Tactics_Monad.fail + "Cannot clear; binder not in environment") + | FStar_Pervasives_Native.Some (e', bv1, bvs) -> + let rec check bvs1 = + match bvs1 with + | [] -> ret () + | bv'::bvs2 -> + let uu___3 = + free_in bv1 bv'.FStarC_Syntax_Syntax.sort in + if uu___3 + then + let uu___4 = + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_bv bv' in + FStarC_Compiler_Util.format1 + "Cannot clear; binder present in the type of %s" + uu___5 in + FStarC_Tactics_Monad.fail uu___4 + else check bvs2 in + let uu___3 = + let uu___4 = FStarC_Tactics_Types.goal_type goal in + free_in bv1 uu___4 in + if uu___3 + then + Obj.magic + (FStarC_Tactics_Monad.fail + "Cannot clear; binder present in goal") + else + (let uu___5 = check bvs in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + uu___5 + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = Obj.magic uu___6 in + let env' = + FStarC_TypeChecker_Env.push_bvs e' + bvs in + let uu___7 = + let uu___8 = + FStarC_Tactics_Types.goal_type + goal in + let uu___9 = + let uu___10 = + should_check_goal_uvar goal in + FStar_Pervasives_Native.Some + uu___10 in + let uu___10 = + goal_typedness_deps goal in + FStarC_Tactics_Monad.new_uvar + "clear.witness" env' uu___8 + uu___9 uu___10 (rangeof goal) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () (Obj.magic uu___7) + (fun uu___8 -> + (fun uu___8 -> + let uu___8 = + Obj.magic uu___8 in + match uu___8 with + | (ut, uvar_ut) -> + let uu___9 = + set_solution goal + ut in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___9 + (fun uu___10 -> + (fun uu___10 + -> + let uu___10 + = + Obj.magic + uu___10 in + let uu___11 + = + FStarC_Tactics_Types.mk_goal + env' + uvar_ut + goal.FStarC_Tactics_Types.opts + goal.FStarC_Tactics_Types.is_guard + goal.FStarC_Tactics_Types.label in + Obj.magic + (FStarC_Tactics_Monad.replace_cur + uu___11)) + uu___10))) + uu___8))) uu___6)))) + uu___1))) uu___) +let (clear_top : unit -> unit FStarC_Tactics_Monad.tac) = + fun uu___ -> + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___1 -> + (fun goal -> + let goal = Obj.magic goal in + let uu___1 = + let uu___2 = FStarC_Tactics_Types.goal_env goal in + FStarC_TypeChecker_Env.pop_bv uu___2 in + match uu___1 with + | FStar_Pervasives_Native.None -> + Obj.magic + (FStarC_Tactics_Monad.fail "Cannot clear; empty context") + | FStar_Pervasives_Native.Some (x, uu___2) -> + let uu___3 = FStarC_Syntax_Syntax.mk_binder x in + Obj.magic (clear uu___3)) uu___1) +let (prune : Prims.string -> unit FStarC_Tactics_Monad.tac) = + fun s -> + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___ -> + (fun g -> + let g = Obj.magic g in + let ctx = FStarC_Tactics_Types.goal_env g in + let ctx' = + let uu___ = FStarC_Ident.path_of_text s in + FStarC_TypeChecker_Env.rem_proof_ns ctx uu___ in + let g' = FStarC_Tactics_Types.goal_with_env g ctx' in + Obj.magic (FStarC_Tactics_Monad.replace_cur g')) uu___) +let (addns : Prims.string -> unit FStarC_Tactics_Monad.tac) = + fun s -> + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___ -> + (fun g -> + let g = Obj.magic g in + let ctx = FStarC_Tactics_Types.goal_env g in + let ctx' = + let uu___ = FStarC_Ident.path_of_text s in + FStarC_TypeChecker_Env.add_proof_ns ctx uu___ in + let g' = FStarC_Tactics_Types.goal_with_env g ctx' in + Obj.magic (FStarC_Tactics_Monad.replace_cur g')) uu___) +let (guard_formula : + FStarC_TypeChecker_Common.guard_t -> FStarC_Syntax_Syntax.term) = + fun g -> + match g.FStarC_TypeChecker_Common.guard_f with + | FStarC_TypeChecker_Common.Trivial -> FStarC_Syntax_Util.t_true + | FStarC_TypeChecker_Common.NonTrivial f -> f +let (_t_trefl : + Prims.bool -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> unit FStarC_Tactics_Monad.tac) + = + fun allow_guards -> + fun l -> + fun r -> + let should_register_trefl g = + let should_register = true in + let skip_register = false in + let uu___ = + let uu___1 = FStarC_Options.compat_pre_core_should_register () in + Prims.op_Negation uu___1 in + if uu___ + then skip_register + else + (let is_uvar_untyped_or_already_checked u = + let dec = + FStarC_Syntax_Unionfind.find_decoration + u.FStarC_Syntax_Syntax.ctx_uvar_head in + match dec.FStarC_Syntax_Syntax.uvar_decoration_should_check + with + | FStarC_Syntax_Syntax.Allow_untyped uu___2 -> true + | FStarC_Syntax_Syntax.Already_checked -> true + | uu___2 -> false in + let is_uvar t = + let head = FStarC_Syntax_Util.leftmost_head t in + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress head in + uu___3.FStarC_Syntax_Syntax.n in + match uu___2 with + | FStarC_Syntax_Syntax.Tm_uvar (u, uu___3) -> + FStar_Pervasives.Inl (u, head, t) + | uu___3 -> FStar_Pervasives.Inr t in + let is_allow_untyped_uvar t = + let uu___2 = is_uvar t in + match uu___2 with + | FStar_Pervasives.Inr uu___3 -> false + | FStar_Pervasives.Inl (u, uu___3, uu___4) -> + is_uvar_untyped_or_already_checked u in + let t = + FStarC_Syntax_Util.ctx_uvar_typ + g.FStarC_Tactics_Types.goal_ctx_uvar in + let uvars = + let uu___2 = FStarC_Syntax_Free.uvars t in + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) (Obj.magic uu___2) in + let uu___2 = + FStarC_Compiler_Util.for_all + is_uvar_untyped_or_already_checked uvars in + if uu___2 + then skip_register + else + (let uu___4 = + let t1 = + let uu___5 = FStarC_Syntax_Util.un_squash t in + match uu___5 with + | FStar_Pervasives_Native.None -> t + | FStar_Pervasives_Native.Some t2 -> t2 in + FStarC_Syntax_Util.leftmost_head_and_args t1 in + match uu___4 with + | (head, args) -> + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Syntax_Util.un_uinst head in + FStarC_Syntax_Subst.compress uu___8 in + uu___7.FStarC_Syntax_Syntax.n in + (uu___6, args) in + (match uu___5 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (ty, uu___6)::(t1, uu___7)::(t2, uu___8)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.eq2_lid + -> + let uu___9 = + (is_allow_untyped_uvar t1) || + (is_allow_untyped_uvar t2) in + if uu___9 + then skip_register + else + (let uu___11 = + FStarC_Tactics_Monad.is_goal_safe_as_well_typed + g in + if uu___11 + then + let check_uvar_subtype u t3 = + let env1 = + let uu___12 = + FStarC_Tactics_Types.goal_env g in + { + FStarC_TypeChecker_Env.solver = + (uu___12.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (uu___12.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (uu___12.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + ((g.FStarC_Tactics_Types.goal_ctx_uvar).FStarC_Syntax_Syntax.ctx_uvar_gamma); + FStarC_TypeChecker_Env.gamma_sig = + (uu___12.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (uu___12.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (uu___12.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (uu___12.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (uu___12.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (uu___12.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (uu___12.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (uu___12.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (uu___12.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (uu___12.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (uu___12.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (uu___12.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (uu___12.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (uu___12.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (uu___12.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (uu___12.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (uu___12.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (uu___12.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (uu___12.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (uu___12.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (uu___12.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (uu___12.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (uu___12.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (uu___12.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (uu___12.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (uu___12.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (uu___12.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (uu___12.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (uu___12.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (uu___12.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (uu___12.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (uu___12.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (uu___12.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (uu___12.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (uu___12.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (uu___12.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (uu___12.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (uu___12.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (uu___12.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (uu___12.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (uu___12.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (uu___12.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (uu___12.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (uu___12.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (uu___12.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (uu___12.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (uu___12.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (uu___12.FStarC_TypeChecker_Env.missing_decl) + } in + let uu___12 = + FStarC_TypeChecker_Core.compute_term_type_handle_guards + env1 t3 + (fun uu___13 -> fun uu___14 -> true) in + match uu___12 with + | FStar_Pervasives.Inr uu___13 -> false + | FStar_Pervasives.Inl (uu___13, t_ty) -> + let uu___14 = + FStarC_TypeChecker_Core.check_term_subtyping + true true env1 ty t_ty in + (match uu___14 with + | FStar_Pervasives.Inl + (FStar_Pervasives_Native.None) -> + (mark_uvar_as_already_checked u; + true) + | uu___15 -> false) in + let uu___12 = + let uu___13 = is_uvar t1 in + let uu___14 = is_uvar t2 in + (uu___13, uu___14) in + match uu___12 with + | (FStar_Pervasives.Inl (u, uu___13, tu), + FStar_Pervasives.Inr uu___14) -> + let uu___15 = check_uvar_subtype u tu in + (if uu___15 + then skip_register + else should_register) + | (FStar_Pervasives.Inr uu___13, + FStar_Pervasives.Inl (u, uu___14, tu)) -> + let uu___15 = check_uvar_subtype u tu in + (if uu___15 + then skip_register + else should_register) + | uu___13 -> should_register + else should_register) + | uu___6 -> should_register))) in + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___ -> + (fun g -> + let g = Obj.magic g in + let should_check = should_check_goal_uvar g in + (let uu___1 = should_register_trefl g in + if uu___1 then FStarC_Tactics_Monad.register_goal g else ()); + (let must_tot = true in + let attempt uu___2 uu___1 = + (fun l1 -> + fun r1 -> + let uu___1 = + let uu___2 = FStarC_Tactics_Types.goal_env g in + do_unify_maybe_guards allow_guards must_tot uu___2 + l1 r1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + match uu___2 with + | FStar_Pervasives_Native.None -> + Obj.magic (Obj.repr (ret false)) + | FStar_Pervasives_Native.Some guard -> + Obj.magic + (Obj.repr + (let uu___3 = + solve' g + FStarC_Syntax_Util.exp_unit in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___3 + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = + Obj.magic uu___4 in + if allow_guards + then + Obj.magic + (Obj.repr + (let uu___5 = + let uu___6 = + FStarC_Tactics_Types.goal_env + g in + let uu___7 = + guard_formula + guard in + FStarC_Tactics_Monad.goal_of_guard + "t_trefl" + uu___6 + uu___7 + (FStar_Pervasives_Native.Some + should_check) + (rangeof g) in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic + uu___5) + (fun uu___6 -> + (fun goal + -> + let goal + = + Obj.magic + goal in + let uu___6 + = + FStarC_Tactics_Monad.push_goals + [goal] in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___6 + (fun + uu___7 -> + (fun + uu___7 -> + let uu___7 + = + Obj.magic + uu___7 in + Obj.magic + (ret true)) + uu___7))) + uu___6))) + else + Obj.magic + (Obj.repr + (let uu___6 = + FStarC_TypeChecker_Env.is_trivial_guard_formula + guard in + if uu___6 + then ret true + else + failwith + "internal error: _t_refl: guard is not trivial"))) + uu___4)))) uu___2))) + uu___2 uu___1 in + let uu___1 = attempt l r in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + if uu___2 + then Obj.magic (ret ()) + else + (let norm1 = + let uu___3 = FStarC_Tactics_Types.goal_env g in + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.DontUnfoldAttr + [FStarC_Parser_Const.tac_opaque_attr]] + uu___3 in + let uu___3 = + let uu___4 = norm1 l in + let uu___5 = norm1 r in + attempt uu___4 uu___5 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___3) + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + if uu___4 + then Obj.magic (ret ()) + else + (let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Tactics_Types.goal_env + g in + tts uu___7 in + FStarC_TypeChecker_Err.print_discrepancy + uu___6 l r in + match uu___5 with + | (ls, rs) -> + Obj.magic + (fail2 + "cannot unify (%s) and (%s)" + ls rs))) uu___4)))) + uu___2)))) uu___) +let (t_trefl : Prims.bool -> unit FStarC_Tactics_Monad.tac) = + fun allow_guards -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___3 -> + (fun g -> + let g = Obj.magic g in + let uu___3 = + let uu___4 = FStarC_Tactics_Types.goal_env g in + let uu___5 = FStarC_Tactics_Types.goal_type g in + destruct_eq uu___4 uu___5 in + match uu___3 with + | FStar_Pervasives_Native.Some (l, r) -> + Obj.magic (_t_trefl allow_guards l r) + | FStar_Pervasives_Native.None -> + let uu___4 = + let uu___5 = FStarC_Tactics_Types.goal_env g in + let uu___6 = FStarC_Tactics_Types.goal_type g in + tts uu___5 uu___6 in + Obj.magic (fail1 "not an equality (%s)" uu___4)) uu___3) in + FStarC_Tactics_Monad.catch uu___2 in + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + match uu___2 with + | FStar_Pervasives.Inr v -> Obj.magic (ret ()) + | FStar_Pervasives.Inl exn -> + Obj.magic (FStarC_Tactics_Monad.traise exn)) uu___2) in + FStarC_Tactics_Monad.wrap_err "t_trefl" uu___ +let (dup : unit -> unit FStarC_Tactics_Monad.tac) = + fun uu___ -> + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___1 -> + (fun g -> + let g = Obj.magic g in + let goal_sc = should_check_goal_uvar g in + let env1 = FStarC_Tactics_Types.goal_env g in + let uu___1 = + let uu___2 = FStarC_Tactics_Types.goal_type g in + let uu___3 = + let uu___4 = should_check_goal_uvar g in + FStar_Pervasives_Native.Some uu___4 in + let uu___4 = goal_typedness_deps g in + FStarC_Tactics_Monad.new_uvar "dup" env1 uu___2 uu___3 uu___4 + (rangeof g) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac + () () (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + match uu___2 with + | (u, u_uvar) -> + (mark_uvar_as_already_checked + g.FStarC_Tactics_Types.goal_ctx_uvar; + (let g' = + { + FStarC_Tactics_Types.goal_main_env = + (g.FStarC_Tactics_Types.goal_main_env); + FStarC_Tactics_Types.goal_ctx_uvar = u_uvar; + FStarC_Tactics_Types.opts = + (g.FStarC_Tactics_Types.opts); + FStarC_Tactics_Types.is_guard = + (g.FStarC_Tactics_Types.is_guard); + FStarC_Tactics_Types.label = + (g.FStarC_Tactics_Types.label) + } in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + FStarC_Tactics_Monad.dismiss + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + let t_eq = + let uu___5 = + let uu___6 = + FStarC_Tactics_Types.goal_type + g in + env1.FStarC_TypeChecker_Env.universe_of + env1 uu___6 in + let uu___6 = + FStarC_Tactics_Types.goal_type g in + let uu___7 = + FStarC_Tactics_Types.goal_witness + g in + FStarC_Syntax_Util.mk_eq2 uu___5 + uu___6 u uu___7 in + let uu___5 = + FStarC_Tactics_Monad.add_irrelevant_goal + g "dup equation" env1 t_eq + (FStar_Pervasives_Native.Some + goal_sc) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___5 + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = + Obj.magic uu___6 in + Obj.magic + (FStarC_Tactics_Monad.add_goals + [g'])) uu___6))) + uu___4))))) uu___2))) uu___1) +let longest_prefix : + 'a . + ('a -> 'a -> Prims.bool) -> + 'a Prims.list -> + 'a Prims.list -> ('a Prims.list * 'a Prims.list * 'a Prims.list) + = + fun f -> + fun l1 -> + fun l2 -> + let rec aux acc l11 l21 = + match (l11, l21) with + | (x::xs, y::ys) -> + let uu___ = f x y in + if uu___ + then aux (x :: acc) xs ys + else (acc, (x :: xs), (y :: ys)) + | uu___ -> (acc, l11, l21) in + let uu___ = aux [] l1 l2 in + match uu___ with + | (pr, t1, t2) -> ((FStarC_Compiler_List.rev pr), t1, t2) +let (eq_binding : + FStarC_Syntax_Syntax.binding -> FStarC_Syntax_Syntax.binding -> Prims.bool) + = + fun b1 -> + fun b2 -> + match (b1, b2) with + | (FStarC_Syntax_Syntax.Binding_var bv1, + FStarC_Syntax_Syntax.Binding_var bv2) -> + (FStarC_Syntax_Syntax.bv_eq bv1 bv2) && + (FStarC_Syntax_Util.term_eq bv1.FStarC_Syntax_Syntax.sort + bv2.FStarC_Syntax_Syntax.sort) + | (FStarC_Syntax_Syntax.Binding_lid (lid1, uu___), + FStarC_Syntax_Syntax.Binding_lid (lid2, uu___1)) -> + FStarC_Ident.lid_equals lid1 lid2 + | (FStarC_Syntax_Syntax.Binding_univ u1, + FStarC_Syntax_Syntax.Binding_univ u2) -> + FStarC_Ident.ident_equals u1 u2 + | uu___ -> false +let (join_goals : + FStarC_Tactics_Types.goal -> + FStarC_Tactics_Types.goal -> + FStarC_Tactics_Types.goal FStarC_Tactics_Monad.tac) + = + fun uu___1 -> + fun uu___ -> + (fun g1 -> + fun g2 -> + let close_forall_no_univs bs f = + FStarC_Compiler_List.fold_right + (fun b -> + fun f1 -> + FStarC_Syntax_Util.mk_forall_no_univ + b.FStarC_Syntax_Syntax.binder_bv f1) bs f in + let uu___ = get_phi g1 in + match uu___ with + | FStar_Pervasives_Native.None -> + Obj.magic + (Obj.repr + (FStarC_Tactics_Monad.fail "goal 1 is not irrelevant")) + | FStar_Pervasives_Native.Some phi1 -> + Obj.magic + (Obj.repr + (let uu___1 = get_phi g2 in + match uu___1 with + | FStar_Pervasives_Native.None -> + Obj.repr + (FStarC_Tactics_Monad.fail + "goal 2 is not irrelevant") + | FStar_Pervasives_Native.Some phi2 -> + Obj.repr + (let gamma1 = + (g1.FStarC_Tactics_Types.goal_ctx_uvar).FStarC_Syntax_Syntax.ctx_uvar_gamma in + let gamma2 = + (g2.FStarC_Tactics_Types.goal_ctx_uvar).FStarC_Syntax_Syntax.ctx_uvar_gamma in + let uu___2 = + longest_prefix eq_binding + (FStarC_Compiler_List.rev gamma1) + (FStarC_Compiler_List.rev gamma2) in + match uu___2 with + | (gamma, r1, r2) -> + let t1 = + let uu___3 = + FStarC_TypeChecker_Env.binders_of_bindings + (FStarC_Compiler_List.rev r1) in + close_forall_no_univs uu___3 phi1 in + let t2 = + let uu___3 = + FStarC_TypeChecker_Env.binders_of_bindings + (FStarC_Compiler_List.rev r2) in + close_forall_no_univs uu___3 phi2 in + let goal_sc = + let uu___3 = + let uu___4 = should_check_goal_uvar g1 in + let uu___5 = should_check_goal_uvar g2 in + (uu___4, uu___5) in + match uu___3 with + | (FStarC_Syntax_Syntax.Allow_untyped + reason1, + FStarC_Syntax_Syntax.Allow_untyped + uu___4) -> + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Allow_untyped + reason1) + | uu___4 -> FStar_Pervasives_Native.None in + let uu___3 = + set_solution g1 FStarC_Syntax_Util.exp_unit in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () uu___3 + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + let uu___5 = + set_solution g2 + FStarC_Syntax_Util.exp_unit in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___5 + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = + Obj.magic uu___6 in + let ng = + FStarC_Syntax_Util.mk_conj + t1 t2 in + let nenv = + let uu___7 = + FStarC_Tactics_Types.goal_env + g1 in + { + FStarC_TypeChecker_Env.solver + = + (uu___7.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range + = + (uu___7.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule + = + (uu___7.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma + = + (FStarC_Compiler_List.rev + gamma); + FStarC_TypeChecker_Env.gamma_sig + = + (uu___7.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache + = + (uu___7.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules + = + (uu___7.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ + = + (uu___7.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab + = + (uu___7.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab + = + (uu___7.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp + = + (uu___7.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects + = + (uu___7.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize + = + (uu___7.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs + = + (uu___7.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level + = + (uu___7.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars + = + (uu___7.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict + = + (uu___7.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface + = + (uu___7.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit + = + (uu___7.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes + = + (uu___7.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 + = + (uu___7.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard + = + (uu___7.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking + = + (uu___7.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping + = + (uu___7.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics + = + (uu___7.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce + = + (uu___7.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term + = + (uu___7.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (uu___7.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of + = + (uu___7.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (uu___7.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force + = + (uu___7.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (uu___7.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (uu___7.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (uu___7.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths + = + (uu___7.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns + = + (uu___7.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook + = + (uu___7.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (uu___7.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice + = + (uu___7.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess + = + (uu___7.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess + = + (uu___7.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info + = + (uu___7.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks + = + (uu___7.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv + = + (uu___7.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe + = + (uu___7.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab + = + (uu___7.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (uu___7.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (uu___7.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (uu___7.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (uu___7.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check + = + (uu___7.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl + = + (uu___7.FStarC_TypeChecker_Env.missing_decl) + } in + let uu___7 = + FStarC_Tactics_Monad.mk_irrelevant_goal + "joined" nenv ng + goal_sc (rangeof g1) + g1.FStarC_Tactics_Types.opts + g1.FStarC_Tactics_Types.label in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic uu___7) + (fun uu___8 -> + (fun goal -> + let goal = + Obj.magic + goal in + let uu___8 = + FStarC_Tactics_Monad.if_verbose + (fun uu___9 + -> + let uu___10 + = + FStarC_Tactics_Printing.goal_to_string_verbose + g1 in + let uu___11 + = + FStarC_Tactics_Printing.goal_to_string_verbose + g2 in + let uu___12 + = + FStarC_Tactics_Printing.goal_to_string_verbose + goal in + FStarC_Compiler_Util.print3 + "join_goals of\n(%s)\nand\n(%s)\n= (%s)\n" + uu___10 + uu___11 + uu___12) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___8 + (fun + uu___9 -> + (fun + uu___9 -> + let uu___9 + = + Obj.magic + uu___9 in + Obj.magic + (ret goal)) + uu___9))) + uu___8))) uu___6))) + uu___4))))) uu___1 uu___ +let (join : unit -> unit FStarC_Tactics_Monad.tac) = + fun uu___ -> + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___1 -> + (fun ps -> + let ps = Obj.magic ps in + match ps.FStarC_Tactics_Types.goals with + | g1::g2::gs -> + let uu___1 = + FStarC_Tactics_Monad.set + { + FStarC_Tactics_Types.main_context = + (ps.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits = + (ps.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = gs; + FStarC_Tactics_Types.smt_goals = + (ps.FStarC_Tactics_Types.smt_goals); + FStarC_Tactics_Types.depth = + (ps.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = + (ps.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = + (ps.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (ps.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = + (ps.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness = + (ps.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg = + (ps.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = + (ps.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency = + (ps.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure = + (ps.FStarC_Tactics_Types.dump_on_failure) + } in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () uu___1 + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + let uu___3 = join_goals g1 g2 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___3) + (fun uu___4 -> + (fun g12 -> + let g12 = Obj.magic g12 in + Obj.magic + (FStarC_Tactics_Monad.add_goals [g12])) + uu___4))) uu___2)) + | uu___1 -> + Obj.magic + (FStarC_Tactics_Monad.fail "join: less than 2 goals")) + uu___1) +let (set_options : Prims.string -> unit FStarC_Tactics_Monad.tac) = + fun s -> + let uu___ = + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___1 -> + (fun g -> + let g = Obj.magic g in + FStarC_Options.push (); + FStarC_Options.set g.FStarC_Tactics_Types.opts; + (let res = FStarC_Options.set_options s in + let opts' = FStarC_Options.peek () in + FStarC_Options.pop (); + (match res with + | FStarC_Getopt.Success -> + let g' = + { + FStarC_Tactics_Types.goal_main_env = + (g.FStarC_Tactics_Types.goal_main_env); + FStarC_Tactics_Types.goal_ctx_uvar = + (g.FStarC_Tactics_Types.goal_ctx_uvar); + FStarC_Tactics_Types.opts = opts'; + FStarC_Tactics_Types.is_guard = + (g.FStarC_Tactics_Types.is_guard); + FStarC_Tactics_Types.label = + (g.FStarC_Tactics_Types.label) + } in + Obj.magic (FStarC_Tactics_Monad.replace_cur g') + | FStarC_Getopt.Error err -> + Obj.magic (fail2 "Setting options `%s` failed: %s" s err) + | FStarC_Getopt.Help -> + Obj.magic + (fail1 "Setting options `%s` failed (got `Help`?)" s)))) + uu___1) in + FStarC_Tactics_Monad.wrap_err "set_options" uu___ +let (top_env : unit -> env FStarC_Tactics_Monad.tac) = + fun uu___ -> + let uu___1 = bind () in + uu___1 FStarC_Tactics_Monad.get + (fun ps -> ret ps.FStarC_Tactics_Types.main_context) +let (lax_on : unit -> Prims.bool FStarC_Tactics_Monad.tac) = + fun uu___ -> + (fun uu___ -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___1 -> + (fun g -> + let g = Obj.magic g in + let uu___1 = + (FStarC_Options.lax ()) || + (let uu___2 = FStarC_Tactics_Types.goal_env g in + uu___2.FStarC_TypeChecker_Env.admit) in + Obj.magic (ret uu___1)) uu___1))) uu___ +let (unquote : + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term FStarC_Tactics_Monad.tac) + = + fun ty -> + fun tm -> + let uu___ = + let uu___1 = + FStarC_Tactics_Monad.if_verbose + (fun uu___2 -> + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term tm in + FStarC_Compiler_Util.print1 "unquote: tm = %s\n" uu___3) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () + () uu___1 + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___3 -> + (fun goal -> + let goal = Obj.magic goal in + let env1 = + let uu___3 = + FStarC_Tactics_Types.goal_env goal in + FStarC_TypeChecker_Env.set_expected_typ + uu___3 ty in + let uu___3 = __tc_ghost env1 tm in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___3) + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + match uu___4 with + | (tm1, typ, guard) -> + let uu___5 = + FStarC_Tactics_Monad.if_verbose + (fun uu___6 -> + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + tm1 in + FStarC_Compiler_Util.print1 + "unquote: tm' = %s\n" + uu___7) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___5 + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = + Obj.magic uu___6 in + let uu___7 = + FStarC_Tactics_Monad.if_verbose + (fun uu___8 -> + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + typ in + FStarC_Compiler_Util.print1 + "unquote: typ = %s\n" + uu___9) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___7 + (fun uu___8 -> + (fun uu___8 + -> + let uu___8 + = + Obj.magic + uu___8 in + let uu___9 + = + let uu___10 + = + let uu___11 + = + should_check_goal_uvar + goal in + FStar_Pervasives_Native.Some + uu___11 in + proc_guard + "unquote" + env1 + guard + uu___10 + (rangeof + goal) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___9 + (fun + uu___10 + -> + (fun + uu___10 + -> + let uu___10 + = + Obj.magic + uu___10 in + Obj.magic + (ret tm1)) + uu___10))) + uu___8))) + uu___6))) uu___4))) + uu___3))) uu___2)) in + FStarC_Tactics_Monad.wrap_err "unquote" uu___ +let (uvar_env : + env -> + FStarC_Syntax_Syntax.typ FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.term FStarC_Tactics_Monad.tac) + = + fun uu___1 -> + fun uu___ -> + (fun env1 -> + fun ty -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac + () () (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___ -> + (fun ps -> + let ps = Obj.magic ps in + let uu___ = + match ty with + | FStar_Pervasives_Native.Some ty1 -> + let env2 = + let uu___1 = + let uu___2 = FStarC_Syntax_Util.type_u () in + FStar_Pervasives_Native.fst uu___2 in + FStarC_TypeChecker_Env.set_expected_typ env1 + uu___1 in + let uu___1 = __tc_ghost env2 ty1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + match uu___2 with + | (ty2, uu___3, g) -> + Obj.magic + (ret + (ty2, g, + (ty2.FStarC_Syntax_Syntax.pos)))) + uu___2)) + | FStar_Pervasives_Native.None -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.type_u () in + FStar_Pervasives_Native.fst uu___3 in + FStarC_Tactics_Monad.new_uvar "uvar_env.2" env1 + uu___2 FStar_Pervasives_Native.None [] + ps.FStarC_Tactics_Types.entry_range in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + match uu___2 with + | (typ, uvar_typ) -> + Obj.magic + (ret + (typ, + FStarC_TypeChecker_Env.trivial_guard, + FStarC_Compiler_Range_Type.dummyRange))) + uu___2)) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___) + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + match uu___1 with + | (typ, g, r) -> + let uu___2 = + proc_guard "uvar_env_typ" env1 g + FStar_Pervasives_Native.None r in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () + () uu___2 + (fun uu___3 -> + (fun uu___3 -> + let uu___3 = Obj.magic uu___3 in + let uu___4 = + FStarC_Tactics_Monad.new_uvar + "uvar_env" env1 typ + FStar_Pervasives_Native.None + [] + ps.FStarC_Tactics_Types.entry_range in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () (Obj.magic uu___4) + (fun uu___5 -> + (fun uu___5 -> + let uu___5 = + Obj.magic uu___5 in + match uu___5 with + | (t, uvar_t) -> + Obj.magic + (ret t)) + uu___5))) uu___3))) + uu___1))) uu___))) uu___1 uu___ +let (ghost_uvar_env : + env -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.term FStarC_Tactics_Monad.tac) + = + fun uu___1 -> + fun uu___ -> + (fun env1 -> + fun ty -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac + () () (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___ -> + (fun ps -> + let ps = Obj.magic ps in + let uu___ = __tc_ghost env1 ty in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___) + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + match uu___1 with + | (typ, uu___2, g) -> + let uu___3 = + proc_guard "ghost_uvar_env_typ" env1 g + FStar_Pervasives_Native.None + ty.FStarC_Syntax_Syntax.pos in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () + () uu___3 + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + let uu___5 = + FStarC_Tactics_Monad.new_uvar + "uvar_env" env1 typ + (FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Allow_ghost + "User ghost uvar")) + [] + ps.FStarC_Tactics_Types.entry_range in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () (Obj.magic uu___5) + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = + Obj.magic uu___6 in + match uu___6 with + | (t, uvar_t) -> + Obj.magic + (ret t)) + uu___6))) uu___4))) + uu___1))) uu___))) uu___1 uu___ +let (fresh_universe_uvar : + unit -> FStarC_Syntax_Syntax.term FStarC_Tactics_Monad.tac) = + fun uu___ -> + let uu___1 = + let uu___2 = FStarC_Syntax_Util.type_u () in + FStar_Pervasives_Native.fst uu___2 in + ret uu___1 +let (unshelve : FStarC_Syntax_Syntax.term -> unit FStarC_Tactics_Monad.tac) = + fun t -> + let uu___ = + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___1 -> + (fun ps -> + let ps = Obj.magic ps in + let env1 = ps.FStarC_Tactics_Types.main_context in + let opts = + match ps.FStarC_Tactics_Types.goals with + | g::uu___1 -> g.FStarC_Tactics_Types.opts + | uu___1 -> FStarC_Options.peek () in + let uu___1 = FStarC_Syntax_Util.head_and_args t in + match uu___1 with + | ({ + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_uvar + (ctx_uvar, uu___2); + FStarC_Syntax_Syntax.pos = uu___3; + FStarC_Syntax_Syntax.vars = uu___4; + FStarC_Syntax_Syntax.hash_code = uu___5;_}, + uu___6) -> + let env2 = + { + FStarC_TypeChecker_Env.solver = + (env1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (ctx_uvar.FStarC_Syntax_Syntax.ctx_uvar_gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env1.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env1.FStarC_TypeChecker_Env.missing_decl) + } in + let g = + FStarC_Tactics_Types.mk_goal env2 ctx_uvar opts false "" in + let g1 = bnorm_goal g in + Obj.magic (FStarC_Tactics_Monad.add_goals [g1]) + | uu___2 -> Obj.magic (FStarC_Tactics_Monad.fail "not a uvar")) + uu___1) in + FStarC_Tactics_Monad.wrap_err "unshelve" uu___ +let (tac_and : + Prims.bool FStarC_Tactics_Monad.tac -> + Prims.bool FStarC_Tactics_Monad.tac -> + Prims.bool FStarC_Tactics_Monad.tac) + = + fun uu___1 -> + fun uu___ -> + (fun t1 -> + fun t2 -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac + () () (Obj.magic t1) + (fun uu___ -> + (fun uu___ -> + let uu___ = Obj.magic uu___ in + if uu___ + then Obj.magic (Obj.repr t2) + else + Obj.magic + (Obj.repr + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic false)))) uu___))) uu___1 uu___ +let default_if_err : + 'a . 'a -> 'a FStarC_Tactics_Monad.tac -> 'a FStarC_Tactics_Monad.tac = + fun uu___1 -> + fun uu___ -> + (fun def -> + fun t -> + let uu___ = FStarC_Tactics_Monad.catch t in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac + () () (Obj.magic uu___) + (fun uu___1 -> + (fun r -> + let r = Obj.magic r in + match r with + | FStar_Pervasives.Inl uu___1 -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic def)) + | FStar_Pervasives.Inr v -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic v))) uu___1))) uu___1 uu___ +let (match_env : + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> Prims.bool FStarC_Tactics_Monad.tac) + = + fun e -> + fun t1 -> + fun t2 -> + let uu___ = + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () + () (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___1 -> + (fun ps -> + let ps = Obj.magic ps in + let uu___1 = __tc e t1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + match uu___2 with + | (t11, ty1, g1) -> + let uu___3 = __tc e t2 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___3) + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + match uu___4 with + | (t21, ty2, g2) -> + let uu___5 = + proc_guard + "match_env g1" e g1 + FStar_Pervasives_Native.None + ps.FStarC_Tactics_Types.entry_range in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___5 + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = + Obj.magic + uu___6 in + let uu___7 = + proc_guard + "match_env g2" + e g2 + FStar_Pervasives_Native.None + ps.FStarC_Tactics_Types.entry_range in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___7 + (fun + uu___8 -> + (fun + uu___8 -> + let uu___8 + = + Obj.magic + uu___8 in + let must_tot + = true in + let uu___9 + = + let uu___10 + = + do_match + must_tot + e ty1 ty2 in + let uu___11 + = + do_match + must_tot + e t11 t21 in + tac_and + uu___10 + uu___11 in + Obj.magic + (default_if_err + false + uu___9)) + uu___8))) + uu___6))) uu___4))) + uu___2))) uu___1)) in + FStarC_Tactics_Monad.wrap_err "match_env" uu___ +let (unify_env : + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> Prims.bool FStarC_Tactics_Monad.tac) + = + fun e -> + fun t1 -> + fun t2 -> + let uu___ = + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () + () (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___1 -> + (fun ps -> + let ps = Obj.magic ps in + let uu___1 = __tc e t1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + match uu___2 with + | (t11, ty1, g1) -> + let uu___3 = __tc e t2 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___3) + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + match uu___4 with + | (t21, ty2, g2) -> + let uu___5 = + proc_guard + "unify_env g1" e g1 + FStar_Pervasives_Native.None + ps.FStarC_Tactics_Types.entry_range in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___5 + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = + Obj.magic + uu___6 in + let uu___7 = + proc_guard + "unify_env g2" + e g2 + FStar_Pervasives_Native.None + ps.FStarC_Tactics_Types.entry_range in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___7 + (fun + uu___8 -> + (fun + uu___8 -> + let uu___8 + = + Obj.magic + uu___8 in + let must_tot + = true in + let uu___9 + = + let uu___10 + = + do_unify + must_tot + e ty1 ty2 in + let uu___11 + = + do_unify + must_tot + e t11 t21 in + tac_and + uu___10 + uu___11 in + Obj.magic + (default_if_err + false + uu___9)) + uu___8))) + uu___6))) uu___4))) + uu___2))) uu___1)) in + FStarC_Tactics_Monad.wrap_err "unify_env" uu___ +let (unify_guard_env : + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> Prims.bool FStarC_Tactics_Monad.tac) + = + fun e -> + fun t1 -> + fun t2 -> + let uu___ = + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () + () (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___1 -> + (fun ps -> + let ps = Obj.magic ps in + let uu___1 = __tc e t1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + match uu___2 with + | (t11, ty1, g1) -> + let uu___3 = __tc e t2 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___3) + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + match uu___4 with + | (t21, ty2, g2) -> + let uu___5 = + proc_guard + "unify_guard_env g1" e + g1 + FStar_Pervasives_Native.None + ps.FStarC_Tactics_Types.entry_range in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___5 + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = + Obj.magic + uu___6 in + let uu___7 = + proc_guard + "unify_guard_env g2" + e g2 + FStar_Pervasives_Native.None + ps.FStarC_Tactics_Types.entry_range in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___7 + (fun + uu___8 -> + (fun + uu___8 -> + let uu___8 + = + Obj.magic + uu___8 in + let must_tot + = true in + let uu___9 + = + do_unify_maybe_guards + true + must_tot + e ty1 ty2 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic + uu___9) + (fun + uu___10 + -> + (fun + uu___10 + -> + let uu___10 + = + Obj.magic + uu___10 in + match uu___10 + with + | + FStar_Pervasives_Native.None + -> + Obj.magic + (Obj.repr + (ret + false)) + | + FStar_Pervasives_Native.Some + g11 -> + Obj.magic + (Obj.repr + (let uu___11 + = + do_unify_maybe_guards + true + must_tot + e t11 t21 in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic + uu___11) + (fun + uu___12 + -> + (fun + uu___12 + -> + let uu___12 + = + Obj.magic + uu___12 in + match uu___12 + with + | + FStar_Pervasives_Native.None + -> + Obj.magic + (Obj.repr + (ret + false)) + | + FStar_Pervasives_Native.Some + g21 -> + Obj.magic + (Obj.repr + (let formula + = + let uu___13 + = + guard_formula + g11 in + let uu___14 + = + guard_formula + g21 in + FStarC_Syntax_Util.mk_conj + uu___13 + uu___14 in + let uu___13 + = + FStarC_Tactics_Monad.goal_of_guard + "unify_guard_env.g2" + e formula + FStar_Pervasives_Native.None + ps.FStarC_Tactics_Types.entry_range in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic + uu___13) + (fun + uu___14 + -> + (fun goal + -> + let goal + = + Obj.magic + goal in + let uu___14 + = + FStarC_Tactics_Monad.push_goals + [goal] in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___14 + (fun + uu___15 + -> + (fun + uu___15 + -> + let uu___15 + = + Obj.magic + uu___15 in + Obj.magic + (ret true)) + uu___15))) + uu___14)))) + uu___12)))) + uu___10))) + uu___8))) + uu___6))) uu___4))) + uu___2))) uu___1)) in + FStarC_Tactics_Monad.wrap_err "unify_guard_env" uu___ +let (launch_process : + Prims.string -> + Prims.string Prims.list -> + Prims.string -> Prims.string FStarC_Tactics_Monad.tac) + = + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun prog -> + fun args -> + fun input -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () idtac + (fun uu___ -> + (fun uu___ -> + let uu___ = Obj.magic uu___ in + let uu___1 = FStarC_Options.unsafe_tactic_exec () in + if uu___1 + then + let s = + FStarC_Compiler_Util.run_process + "tactic_launch" prog args + (FStar_Pervasives_Native.Some input) in + Obj.magic (ret s) + else + Obj.magic + (FStarC_Tactics_Monad.fail + "launch_process: will not run anything unless --unsafe_tactic_exec is provided")) + uu___))) uu___2 uu___1 uu___ +let (fresh_bv_named : + Prims.string -> FStarC_Syntax_Syntax.bv FStarC_Tactics_Monad.tac) = + fun uu___ -> + (fun nm -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + idtac + (fun uu___ -> + (fun uu___ -> + let uu___ = Obj.magic uu___ in + let uu___1 = + FStarC_Syntax_Syntax.gen_bv nm + FStar_Pervasives_Native.None FStarC_Syntax_Syntax.tun in + Obj.magic (ret uu___1)) uu___))) uu___ +let (change : FStarC_Syntax_Syntax.typ -> unit FStarC_Tactics_Monad.tac) = + fun ty -> + let uu___ = + let uu___1 = + FStarC_Tactics_Monad.if_verbose + (fun uu___2 -> + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term ty in + FStarC_Compiler_Util.print1 "change: ty = %s\n" uu___3) in + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + uu___1 + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___3 -> + (fun g -> + let g = Obj.magic g in + let uu___3 = + let uu___4 = FStarC_Tactics_Types.goal_env g in + __tc uu___4 ty in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___3) + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + match uu___4 with + | (ty1, uu___5, guard) -> + let uu___6 = + let uu___7 = + FStarC_Tactics_Types.goal_env g in + let uu___8 = + let uu___9 = + should_check_goal_uvar g in + FStar_Pervasives_Native.Some + uu___9 in + proc_guard "change" uu___7 guard + uu___8 (rangeof g) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___6 + (fun uu___7 -> + (fun uu___7 -> + let uu___7 = + Obj.magic uu___7 in + let must_tot = true in + let uu___8 = + let uu___9 = + FStarC_Tactics_Types.goal_env + g in + let uu___10 = + FStarC_Tactics_Types.goal_type + g in + do_unify must_tot uu___9 + uu___10 ty1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic uu___8) + (fun uu___9 -> + (fun bb -> + let bb = + Obj.magic bb in + if bb + then + let uu___9 = + goal_with_type + g ty1 in + Obj.magic + (FStarC_Tactics_Monad.replace_cur + uu___9) + else + (let steps = + [FStarC_TypeChecker_Env.AllowUnboundUniverses; + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.Primops] in + let ng = + let uu___10 + = + FStarC_Tactics_Types.goal_env + g in + let uu___11 + = + FStarC_Tactics_Types.goal_type + g in + normalize + steps + uu___10 + uu___11 in + let nty = + let uu___10 + = + FStarC_Tactics_Types.goal_env + g in + normalize + steps + uu___10 + ty1 in + let uu___10 + = + let uu___11 + = + FStarC_Tactics_Types.goal_env + g in + do_unify + must_tot + uu___11 + ng nty in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic + uu___10) + (fun + uu___11 + -> + (fun b -> + let b = + Obj.magic + b in + if b + then + let uu___11 + = + goal_with_type + g ty1 in + Obj.magic + (FStarC_Tactics_Monad.replace_cur + uu___11) + else + Obj.magic + (FStarC_Tactics_Monad.fail + "not convertible")) + uu___11)))) + uu___9))) uu___7))) + uu___4))) uu___3))) uu___2) in + FStarC_Tactics_Monad.wrap_err "change" uu___ +let (failwhen : Prims.bool -> Prims.string -> unit FStarC_Tactics_Monad.tac) + = fun b -> fun msg -> if b then FStarC_Tactics_Monad.fail msg else ret () +let (t_destruct : + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.fv * FStarC_BigInt.t) Prims.list + FStarC_Tactics_Monad.tac) + = + fun s_tm -> + let uu___ = + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___1 -> + (fun g -> + let g = Obj.magic g in + let uu___1 = + let uu___2 = FStarC_Tactics_Types.goal_env g in + __tc uu___2 s_tm in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + match uu___2 with + | (s_tm1, s_ty, guard) -> + let uu___3 = + let uu___4 = + FStarC_Tactics_Types.goal_env g in + let uu___5 = + let uu___6 = should_check_goal_uvar g in + FStar_Pervasives_Native.Some uu___6 in + proc_guard "destruct" uu___4 guard uu___5 + (rangeof g) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + uu___3 + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + let s_ty1 = + let uu___5 = + FStarC_Tactics_Types.goal_env + g in + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.DontUnfoldAttr + [FStarC_Parser_Const.tac_opaque_attr]; + FStarC_TypeChecker_Env.Weak; + FStarC_TypeChecker_Env.HNF; + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant] + uu___5 s_ty in + let uu___5 = + let uu___6 = + FStarC_Syntax_Util.unrefine + s_ty1 in + FStarC_Syntax_Util.head_and_args_full + uu___6 in + match uu___5 with + | (h, args) -> + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Subst.compress + h in + uu___8.FStarC_Syntax_Syntax.n in + match uu___7 with + | FStarC_Syntax_Syntax.Tm_fvar + fv -> ret (fv, []) + | FStarC_Syntax_Syntax.Tm_uinst + (h', us) -> + let uu___8 = + let uu___9 = + FStarC_Syntax_Subst.compress + h' in + uu___9.FStarC_Syntax_Syntax.n in + (match uu___8 with + | FStarC_Syntax_Syntax.Tm_fvar + fv -> ret (fv, us) + | uu___9 -> + failwith + "impossible: uinst over something that's not an fvar") + | uu___8 -> + FStarC_Tactics_Monad.fail + "type is not an fv" in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () (Obj.magic uu___6) + (fun uu___7 -> + (fun uu___7 -> + let uu___7 = + Obj.magic uu___7 in + match uu___7 with + | (fv, a_us) -> + let t_lid = + FStarC_Syntax_Syntax.lid_of_fv + fv in + let uu___8 = + let uu___9 = + FStarC_Tactics_Types.goal_env + g in + FStarC_TypeChecker_Env.lookup_sigelt + uu___9 + t_lid in + (match uu___8 + with + | FStar_Pervasives_Native.None + -> + Obj.magic + (Obj.repr + (FStarC_Tactics_Monad.fail + "type not found in environment")) + | FStar_Pervasives_Native.Some + se -> + Obj.magic + (Obj.repr + (match + se.FStarC_Syntax_Syntax.sigel + with + | + FStarC_Syntax_Syntax.Sig_inductive_typ + { + FStarC_Syntax_Syntax.lid + = uu___9; + FStarC_Syntax_Syntax.us + = t_us; + FStarC_Syntax_Syntax.params + = t_ps; + FStarC_Syntax_Syntax.num_uniform_params + = uu___10; + FStarC_Syntax_Syntax.t + = t_ty; + FStarC_Syntax_Syntax.mutuals + = mut; + FStarC_Syntax_Syntax.ds + = c_lids; + FStarC_Syntax_Syntax.injective_type_params + = uu___11;_} + -> + Obj.repr + (let erasable + = + FStarC_Syntax_Util.has_attribute + se.FStarC_Syntax_Syntax.sigattrs + FStarC_Parser_Const.erasable_attr in + let uu___12 + = + let uu___13 + = + erasable + && + (let uu___14 + = + is_irrelevant + g in + Prims.op_Negation + uu___14) in + failwhen + uu___13 + "cannot destruct erasable type to solve proof-relevant goal" in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___12 + (fun + uu___13 + -> + (fun + uu___13 + -> + let uu___13 + = + Obj.magic + uu___13 in + let uu___14 + = + failwhen + ((FStarC_Compiler_List.length + a_us) <> + (FStarC_Compiler_List.length + t_us)) + "t_us don't match?" in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___14 + (fun + uu___15 + -> + (fun + uu___15 + -> + let uu___15 + = + Obj.magic + uu___15 in + let uu___16 + = + FStarC_Syntax_Subst.open_term + t_ps t_ty in + match uu___16 + with + | + (t_ps1, + t_ty1) -> + let uu___17 + = + Obj.magic + (FStarC_Class_Monad.mapM + FStarC_Tactics_Monad.monad_tac + () () + (fun + uu___18 + -> + (fun + c_lid -> + let c_lid + = + Obj.magic + c_lid in + let uu___18 + = + let uu___19 + = + FStarC_Tactics_Types.goal_env + g in + FStarC_TypeChecker_Env.lookup_sigelt + uu___19 + c_lid in + match uu___18 + with + | + FStar_Pervasives_Native.None + -> + Obj.magic + (Obj.repr + (FStarC_Tactics_Monad.fail + "ctor not found?")) + | + FStar_Pervasives_Native.Some + se1 -> + Obj.magic + (Obj.repr + (match + se1.FStarC_Syntax_Syntax.sigel + with + | + FStarC_Syntax_Syntax.Sig_datacon + { + FStarC_Syntax_Syntax.lid1 + = uu___19; + FStarC_Syntax_Syntax.us1 + = c_us; + FStarC_Syntax_Syntax.t1 + = c_ty; + FStarC_Syntax_Syntax.ty_lid + = uu___20; + FStarC_Syntax_Syntax.num_ty_params + = nparam; + FStarC_Syntax_Syntax.mutuals1 + = mut1; + FStarC_Syntax_Syntax.injective_type_params1 + = uu___21;_} + -> + Obj.repr + (let fv1 + = + FStarC_Syntax_Syntax.lid_as_fv + c_lid + (FStar_Pervasives_Native.Some + FStarC_Syntax_Syntax.Data_ctor) in + let uu___22 + = + failwhen + ((FStarC_Compiler_List.length + a_us) <> + (FStarC_Compiler_List.length + c_us)) + "t_us don't match?" in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___22 + (fun + uu___23 + -> + (fun + uu___23 + -> + let uu___23 + = + Obj.magic + uu___23 in + let s = + FStarC_TypeChecker_Env.mk_univ_subst + c_us a_us in + let c_ty1 + = + FStarC_Syntax_Subst.subst + s c_ty in + let uu___24 + = + FStarC_TypeChecker_Env.inst_tscheme + (c_us, + c_ty1) in + match uu___24 + with + | + (c_us1, + c_ty2) -> + let uu___25 + = + FStarC_Syntax_Util.arrow_formals_comp + c_ty2 in + (match uu___25 + with + | + (bs, + comp) -> + let uu___26 + = + let rename_bv + bv = + let ppname + = + bv.FStarC_Syntax_Syntax.ppname in + let ppname1 + = + let uu___27 + = + let uu___28 + = + let uu___29 + = + FStarC_Class_Show.show + FStarC_Ident.showable_ident + ppname in + Prims.strcat + "a" + uu___29 in + let uu___29 + = + FStarC_Ident.range_of_id + ppname in + (uu___28, + uu___29) in + FStarC_Ident.mk_ident + uu___27 in + FStarC_Syntax_Syntax.freshen_bv + { + FStarC_Syntax_Syntax.ppname + = ppname1; + FStarC_Syntax_Syntax.index + = + (bv.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort + = + (bv.FStarC_Syntax_Syntax.sort) + } in + let bs' = + FStarC_Compiler_List.map + (fun b -> + let uu___27 + = + rename_bv + b.FStarC_Syntax_Syntax.binder_bv in + { + FStarC_Syntax_Syntax.binder_bv + = uu___27; + FStarC_Syntax_Syntax.binder_qual + = + (b.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity + = + (b.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs + = + (b.FStarC_Syntax_Syntax.binder_attrs) + }) bs in + let subst + = + FStarC_Compiler_List.map2 + (fun + uu___27 + -> + fun + uu___28 + -> + match + (uu___27, + uu___28) + with + | + ({ + FStarC_Syntax_Syntax.binder_bv + = bv; + FStarC_Syntax_Syntax.binder_qual + = uu___29; + FStarC_Syntax_Syntax.binder_positivity + = uu___30; + FStarC_Syntax_Syntax.binder_attrs + = uu___31;_}, + { + FStarC_Syntax_Syntax.binder_bv + = bv'; + FStarC_Syntax_Syntax.binder_qual + = uu___32; + FStarC_Syntax_Syntax.binder_positivity + = uu___33; + FStarC_Syntax_Syntax.binder_attrs + = uu___34;_}) + -> + let uu___35 + = + let uu___36 + = + FStarC_Syntax_Syntax.bv_to_name + bv' in + (bv, + uu___36) in + FStarC_Syntax_Syntax.NT + uu___35) + bs bs' in + let uu___27 + = + FStarC_Syntax_Subst.subst_binders + subst bs' in + let uu___28 + = + FStarC_Syntax_Subst.subst_comp + subst + comp in + (uu___27, + uu___28) in + (match uu___26 + with + | + (bs1, + comp1) -> + let uu___27 + = + FStarC_Compiler_List.splitAt + nparam + bs1 in + (match uu___27 + with + | + (d_ps, + bs2) -> + let uu___28 + = + let uu___29 + = + let uu___30 + = + FStarC_Syntax_Util.is_total_comp + comp1 in + Prims.op_Negation + uu___30 in + failwhen + uu___29 + "not total?" in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___28 + (fun + uu___29 + -> + (fun + uu___29 + -> + let uu___29 + = + Obj.magic + uu___29 in + let mk_pat + p = + { + FStarC_Syntax_Syntax.v + = p; + FStarC_Syntax_Syntax.p + = + (s_tm1.FStarC_Syntax_Syntax.pos) + } in + let is_imp + uu___30 = + match uu___30 + with + | + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Implicit + uu___31) + -> true + | + uu___31 + -> false in + let uu___30 + = + FStarC_Compiler_List.splitAt + nparam + args in + match uu___30 + with + | + (a_ps, + a_is) -> + let uu___31 + = + failwhen + ((FStarC_Compiler_List.length + a_ps) <> + (FStarC_Compiler_List.length + d_ps)) + "params not match?" in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___31 + (fun + uu___32 + -> + (fun + uu___32 + -> + let uu___32 + = + Obj.magic + uu___32 in + let d_ps_a_ps + = + FStarC_Compiler_List.zip + d_ps a_ps in + let subst + = + FStarC_Compiler_List.map + (fun + uu___33 + -> + match uu___33 + with + | + ({ + FStarC_Syntax_Syntax.binder_bv + = bv; + FStarC_Syntax_Syntax.binder_qual + = uu___34; + FStarC_Syntax_Syntax.binder_positivity + = uu___35; + FStarC_Syntax_Syntax.binder_attrs + = uu___36;_}, + (t, + uu___37)) + -> + FStarC_Syntax_Syntax.NT + (bv, t)) + d_ps_a_ps in + let bs3 = + FStarC_Syntax_Subst.subst_binders + subst bs2 in + let subpats_1 + = + FStarC_Compiler_List.map + (fun + uu___33 + -> + match uu___33 + with + | + ({ + FStarC_Syntax_Syntax.binder_bv + = bv; + FStarC_Syntax_Syntax.binder_qual + = uu___34; + FStarC_Syntax_Syntax.binder_positivity + = uu___35; + FStarC_Syntax_Syntax.binder_attrs + = uu___36;_}, + (t, + uu___37)) + -> + ((mk_pat + (FStarC_Syntax_Syntax.Pat_dot_term + (FStar_Pervasives_Native.Some + t))), + true)) + d_ps_a_ps in + let subpats_2 + = + FStarC_Compiler_List.map + (fun + uu___33 + -> + match uu___33 + with + | + { + FStarC_Syntax_Syntax.binder_bv + = bv; + FStarC_Syntax_Syntax.binder_qual + = bq; + FStarC_Syntax_Syntax.binder_positivity + = uu___34; + FStarC_Syntax_Syntax.binder_attrs + = uu___35;_} + -> + ((mk_pat + (FStarC_Syntax_Syntax.Pat_var + bv)), + (is_imp + bq))) bs3 in + let subpats + = + FStarC_Compiler_List.op_At + subpats_1 + subpats_2 in + let pat = + mk_pat + (FStarC_Syntax_Syntax.Pat_cons + (fv1, + (FStar_Pervasives_Native.Some + a_us), + subpats)) in + let env1 + = + FStarC_Tactics_Types.goal_env + g in + let cod = + FStarC_Tactics_Types.goal_type + g in + let equ = + env1.FStarC_TypeChecker_Env.universe_of + env1 + s_ty1 in + let uu___33 + = + FStarC_TypeChecker_TcTerm.tc_pat + { + FStarC_TypeChecker_Env.solver + = + (env1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range + = + (env1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule + = + (env1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma + = + (env1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig + = + (env1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache + = + (env1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules + = + (env1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ + = + (env1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab + = + (env1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab + = + (env1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp + = + (env1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects + = + (env1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize + = + (env1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs + = + (env1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level + = + (env1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars + = + (env1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict + = + (env1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface + = + (env1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit + = true; + FStarC_TypeChecker_Env.lax_universes + = + (env1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 + = + (env1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard + = + (env1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking + = + (env1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping + = + (env1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics + = + (env1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce + = + (env1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term + = + (env1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (env1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of + = + (env1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force + = + (env1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (env1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (env1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (env1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths + = + (env1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns + = + (env1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook + = + (env1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (env1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice + = + (env1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess + = + (env1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess + = + (env1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info + = + (env1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks + = + (env1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv + = + (env1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe + = + (env1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab + = + (env1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (env1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (env1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (env1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (env1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check + = + (env1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl + = + (env1.FStarC_TypeChecker_Env.missing_decl) + } s_ty1 + pat in + match uu___33 + with + | + (uu___34, + uu___35, + uu___36, + uu___37, + pat_t, + uu___38, + _guard_pat, + _erasable) + -> + let eq_b + = + let uu___39 + = + let uu___40 + = + FStarC_Syntax_Util.mk_eq2 + equ s_ty1 + s_tm1 + pat_t in + FStarC_Syntax_Util.mk_squash + FStarC_Syntax_Syntax.U_zero + uu___40 in + FStarC_Syntax_Syntax.gen_bv + "breq" + FStar_Pervasives_Native.None + uu___39 in + let cod1 + = + let uu___39 + = + let uu___40 + = + FStarC_Syntax_Syntax.mk_binder + eq_b in + [uu___40] in + let uu___40 + = + FStarC_Syntax_Syntax.mk_Total + cod in + FStarC_Syntax_Util.arrow + uu___39 + uu___40 in + let nty = + let uu___39 + = + FStarC_Syntax_Syntax.mk_Total + cod1 in + FStarC_Syntax_Util.arrow + bs3 + uu___39 in + let uu___39 + = + let uu___40 + = + goal_typedness_deps + g in + FStarC_Tactics_Monad.new_uvar + "destruct branch" + env1 nty + FStar_Pervasives_Native.None + uu___40 + (rangeof + g) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic + uu___39) + (fun + uu___40 + -> + (fun + uu___40 + -> + let uu___40 + = + Obj.magic + uu___40 in + match uu___40 + with + | + (uvt, uv) + -> + let g' = + FStarC_Tactics_Types.mk_goal + env1 uv + g.FStarC_Tactics_Types.opts + false + g.FStarC_Tactics_Types.label in + let brt = + FStarC_Syntax_Util.mk_app_binders + uvt bs3 in + let brt1 + = + let uu___41 + = + let uu___42 + = + FStarC_Syntax_Syntax.as_arg + FStarC_Syntax_Util.exp_unit in + [uu___42] in + FStarC_Syntax_Util.mk_app + brt + uu___41 in + let br = + FStarC_Syntax_Subst.close_branch + (pat, + FStar_Pervasives_Native.None, + brt1) in + let uu___41 + = + let uu___42 + = + let uu___43 + = + FStarC_BigInt.of_int_fs + (FStarC_Compiler_List.length + bs3) in + (fv1, + uu___43) in + (g', br, + uu___42) in + Obj.magic + (ret + uu___41)) + uu___40))) + uu___32))) + uu___29)))))) + uu___23)) + | + uu___19 + -> + Obj.repr + (FStarC_Tactics_Monad.fail + "impossible: not a ctor")))) + uu___18) + (Obj.magic + c_lids)) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic + uu___17) + (fun + uu___18 + -> + (fun + goal_brs + -> + let goal_brs + = + Obj.magic + goal_brs in + let uu___18 + = + FStarC_Compiler_List.unzip3 + goal_brs in + match uu___18 + with + | + (goals, + brs, + infos) -> + let w = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_match + { + FStarC_Syntax_Syntax.scrutinee + = s_tm1; + FStarC_Syntax_Syntax.ret_opt + = + FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.brs + = brs; + FStarC_Syntax_Syntax.rc_opt1 + = + FStar_Pervasives_Native.None + }) + s_tm1.FStarC_Syntax_Syntax.pos in + let uu___19 + = + solve' g + w in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___19 + (fun + uu___20 + -> + (fun + uu___20 + -> + let uu___20 + = + Obj.magic + uu___20 in + mark_goal_implicit_already_checked + g; + ( + let uu___22 + = + FStarC_Tactics_Monad.add_goals + goals in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___22 + (fun + uu___23 + -> + (fun + uu___23 + -> + let uu___23 + = + Obj.magic + uu___23 in + Obj.magic + (ret + infos)) + uu___23)))) + uu___20))) + uu___18))) + uu___15))) + uu___13)) + | + uu___9 -> + Obj.repr + (FStarC_Tactics_Monad.fail + "not an inductive type"))))) + uu___7))) uu___4))) + uu___2))) uu___1)) in + FStarC_Tactics_Monad.wrap_err "destruct" uu___ +let (gather_explicit_guards_for_resolved_goals : + unit -> unit FStarC_Tactics_Monad.tac) = fun uu___ -> ret () +let rec last : 'a . 'a Prims.list -> 'a = + fun l -> + match l with + | [] -> failwith "last: empty list" + | x::[] -> x + | uu___::xs -> last xs +let rec init : 'a . 'a Prims.list -> 'a Prims.list = + fun l -> + match l with + | [] -> failwith "init: empty list" + | x::[] -> [] + | x::xs -> let uu___ = init xs in x :: uu___ +let rec (inspect : + FStarC_Syntax_Syntax.term -> + FStarC_Reflection_V1_Data.term_view FStarC_Tactics_Monad.tac) + = + fun t -> + let uu___ = + let uu___1 = top_env () in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___1) + (fun uu___2 -> + (fun e -> + let e = Obj.magic e in + let t1 = FStarC_Syntax_Util.unlazy_emb t in + let t2 = FStarC_Syntax_Subst.compress t1 in + match t2.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t3; + FStarC_Syntax_Syntax.meta = uu___2;_} + -> Obj.magic (inspect t3) + | FStarC_Syntax_Syntax.Tm_name bv -> + Obj.magic (ret (FStarC_Reflection_V1_Data.Tv_Var bv)) + | FStarC_Syntax_Syntax.Tm_bvar bv -> + Obj.magic (ret (FStarC_Reflection_V1_Data.Tv_BVar bv)) + | FStarC_Syntax_Syntax.Tm_fvar fv -> + Obj.magic (ret (FStarC_Reflection_V1_Data.Tv_FVar fv)) + | FStarC_Syntax_Syntax.Tm_uinst (t3, us) -> + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.compress t3 in + FStarC_Syntax_Util.unascribe uu___4 in + uu___3.FStarC_Syntax_Syntax.n in + (match uu___2 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + Obj.magic + (ret + (FStarC_Reflection_V1_Data.Tv_UInst (fv, us))) + | uu___3 -> + Obj.magic + (failwith + "Tac::inspect: Tm_uinst head not an fvar")) + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t3; + FStarC_Syntax_Syntax.asc = + (FStar_Pervasives.Inl ty, tacopt, eq); + FStarC_Syntax_Syntax.eff_opt = uu___2;_} + -> + Obj.magic + (ret + (FStarC_Reflection_V1_Data.Tv_AscribedT + (t3, ty, tacopt, eq))) + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t3; + FStarC_Syntax_Syntax.asc = + (FStar_Pervasives.Inr cty, tacopt, eq); + FStarC_Syntax_Syntax.eff_opt = uu___2;_} + -> + Obj.magic + (ret + (FStarC_Reflection_V1_Data.Tv_AscribedC + (t3, cty, tacopt, eq))) + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = uu___2; + FStarC_Syntax_Syntax.args = [];_} + -> Obj.magic (failwith "empty arguments on Tm_app") + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = hd; + FStarC_Syntax_Syntax.args = args;_} + -> + let uu___2 = last args in + (match uu___2 with + | (a, q) -> + let q' = + FStarC_Reflection_V1_Builtins.inspect_aqual q in + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = init args in + FStarC_Syntax_Syntax.mk_Tm_app hd uu___6 + t2.FStarC_Syntax_Syntax.pos in + (uu___5, (a, q')) in + FStarC_Reflection_V1_Data.Tv_App uu___4 in + Obj.magic (ret uu___3)) + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = []; + FStarC_Syntax_Syntax.body = uu___2; + FStarC_Syntax_Syntax.rc_opt = uu___3;_} + -> Obj.magic (failwith "empty arguments on Tm_abs") + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs; + FStarC_Syntax_Syntax.body = t3; + FStarC_Syntax_Syntax.rc_opt = k;_} + -> + let uu___2 = FStarC_Syntax_Subst.open_term bs t3 in + (match uu___2 with + | (bs1, t4) -> + (match bs1 with + | [] -> Obj.magic (failwith "impossible") + | b::bs2 -> + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Syntax_Util.abs bs2 t4 k in + (b, uu___5) in + FStarC_Reflection_V1_Data.Tv_Abs uu___4 in + Obj.magic (ret uu___3))) + | FStarC_Syntax_Syntax.Tm_type u -> + Obj.magic (ret (FStarC_Reflection_V1_Data.Tv_Type u)) + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = []; + FStarC_Syntax_Syntax.comp = uu___2;_} + -> Obj.magic (failwith "empty binders on arrow") + | FStarC_Syntax_Syntax.Tm_arrow uu___2 -> + let uu___3 = FStarC_Syntax_Util.arrow_one t2 in + (match uu___3 with + | FStar_Pervasives_Native.Some (b, c) -> + Obj.magic + (ret (FStarC_Reflection_V1_Data.Tv_Arrow (b, c))) + | FStar_Pervasives_Native.None -> + Obj.magic (failwith "impossible")) + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = bv; + FStarC_Syntax_Syntax.phi = t3;_} + -> + let b = FStarC_Syntax_Syntax.mk_binder bv in + let uu___2 = FStarC_Syntax_Subst.open_term [b] t3 in + (match uu___2 with + | (b', t4) -> + let b1 = + match b' with + | b'1::[] -> b'1 + | uu___3 -> failwith "impossible" in + Obj.magic + (ret + (FStarC_Reflection_V1_Data.Tv_Refine + ((b1.FStarC_Syntax_Syntax.binder_bv), + ((b1.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort), + t4)))) + | FStarC_Syntax_Syntax.Tm_constant c -> + let uu___2 = + let uu___3 = + FStarC_Reflection_V1_Builtins.inspect_const c in + FStarC_Reflection_V1_Data.Tv_Const uu___3 in + Obj.magic (ret uu___2) + | FStarC_Syntax_Syntax.Tm_uvar (ctx_u, s) -> + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Syntax_Unionfind.uvar_unique_id + ctx_u.FStarC_Syntax_Syntax.ctx_uvar_head in + FStarC_BigInt.of_int_fs uu___5 in + (uu___4, (ctx_u, s)) in + FStarC_Reflection_V1_Data.Tv_Uvar uu___3 in + Obj.magic (ret uu___2) + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (false, lb::[]); + FStarC_Syntax_Syntax.body1 = t21;_} + -> + if lb.FStarC_Syntax_Syntax.lbunivs <> [] + then Obj.magic (ret FStarC_Reflection_V1_Data.Tv_Unsupp) + else + (match lb.FStarC_Syntax_Syntax.lbname with + | FStar_Pervasives.Inr uu___3 -> + Obj.magic + (ret FStarC_Reflection_V1_Data.Tv_Unsupp) + | FStar_Pervasives.Inl bv -> + let b = FStarC_Syntax_Syntax.mk_binder bv in + let uu___3 = + FStarC_Syntax_Subst.open_term [b] t21 in + (match uu___3 with + | (bs, t22) -> + let b1 = + match bs with + | b2::[] -> b2 + | uu___4 -> + failwith + "impossible: open_term returned different amount of binders" in + Obj.magic + (ret + (FStarC_Reflection_V1_Data.Tv_Let + (false, + (lb.FStarC_Syntax_Syntax.lbattrs), + (b1.FStarC_Syntax_Syntax.binder_bv), + (bv.FStarC_Syntax_Syntax.sort), + (lb.FStarC_Syntax_Syntax.lbdef), + t22))))) + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (true, lb::[]); + FStarC_Syntax_Syntax.body1 = t21;_} + -> + if lb.FStarC_Syntax_Syntax.lbunivs <> [] + then Obj.magic (ret FStarC_Reflection_V1_Data.Tv_Unsupp) + else + (match lb.FStarC_Syntax_Syntax.lbname with + | FStar_Pervasives.Inr uu___3 -> + Obj.magic + (ret FStarC_Reflection_V1_Data.Tv_Unsupp) + | FStar_Pervasives.Inl bv -> + let uu___3 = + FStarC_Syntax_Subst.open_let_rec [lb] t21 in + (match uu___3 with + | (lbs, t22) -> + (match lbs with + | lb1::[] -> + (match lb1.FStarC_Syntax_Syntax.lbname + with + | FStar_Pervasives.Inr uu___4 -> + Obj.magic + (ret + FStarC_Reflection_V1_Data.Tv_Unsupp) + | FStar_Pervasives.Inl bv1 -> + Obj.magic + (ret + (FStarC_Reflection_V1_Data.Tv_Let + (true, + (lb1.FStarC_Syntax_Syntax.lbattrs), + bv1, + (bv1.FStarC_Syntax_Syntax.sort), + (lb1.FStarC_Syntax_Syntax.lbdef), + t22)))) + | uu___4 -> + Obj.magic + (failwith + "impossible: open_term returned different amount of binders")))) + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = t3; + FStarC_Syntax_Syntax.ret_opt = ret_opt; + FStarC_Syntax_Syntax.brs = brs; + FStarC_Syntax_Syntax.rc_opt1 = uu___2;_} + -> + let rec inspect_pat p = + match p.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_constant c -> + let uu___3 = + FStarC_Reflection_V1_Builtins.inspect_const c in + FStarC_Reflection_V1_Data.Pat_Constant uu___3 + | FStarC_Syntax_Syntax.Pat_cons (fv, us_opt, ps) -> + let uu___3 = + let uu___4 = + FStarC_Compiler_List.map + (fun uu___5 -> + match uu___5 with + | (p1, b) -> + let uu___6 = inspect_pat p1 in + (uu___6, b)) ps in + (fv, us_opt, uu___4) in + FStarC_Reflection_V1_Data.Pat_Cons uu___3 + | FStarC_Syntax_Syntax.Pat_var bv -> + FStarC_Reflection_V1_Data.Pat_Var + (bv, + (FStarC_Compiler_Sealed.seal + bv.FStarC_Syntax_Syntax.sort)) + | FStarC_Syntax_Syntax.Pat_dot_term eopt -> + FStarC_Reflection_V1_Data.Pat_Dot_Term eopt in + let brs1 = + FStarC_Compiler_List.map + FStarC_Syntax_Subst.open_branch brs in + let brs2 = + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with + | (pat, uu___4, t4) -> + let uu___5 = inspect_pat pat in (uu___5, t4)) + brs1 in + Obj.magic + (ret + (FStarC_Reflection_V1_Data.Tv_Match + (t3, ret_opt, brs2))) + | FStarC_Syntax_Syntax.Tm_unknown -> + Obj.magic (ret FStarC_Reflection_V1_Data.Tv_Unknown) + | uu___2 -> + ((let uu___4 = + let uu___5 = + FStarC_Class_Tagged.tag_of + FStarC_Syntax_Syntax.tagged_term t2 in + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t2 in + FStarC_Compiler_Util.format2 + "inspect: outside of expected syntax (%s, %s)\n" + uu___5 uu___6 in + FStarC_Errors.log_issue + (FStarC_Syntax_Syntax.has_range_syntax ()) t2 + FStarC_Errors_Codes.Warning_CantInspect () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4)); + Obj.magic (ret FStarC_Reflection_V1_Data.Tv_Unsupp))) + uu___2)) in + FStarC_Tactics_Monad.wrap_err "inspect" uu___ +let (pack' : + FStarC_Reflection_V1_Data.term_view -> + Prims.bool -> FStarC_Syntax_Syntax.term FStarC_Tactics_Monad.tac) + = + fun tv -> + fun leave_curried -> + match tv with + | FStarC_Reflection_V1_Data.Tv_Var bv -> + let uu___ = FStarC_Syntax_Syntax.bv_to_name bv in ret uu___ + | FStarC_Reflection_V1_Data.Tv_BVar bv -> + let uu___ = FStarC_Syntax_Syntax.bv_to_tm bv in ret uu___ + | FStarC_Reflection_V1_Data.Tv_FVar fv -> + let uu___ = FStarC_Syntax_Syntax.fv_to_tm fv in ret uu___ + | FStarC_Reflection_V1_Data.Tv_UInst (fv, us) -> + let uu___ = + let uu___1 = FStarC_Syntax_Syntax.fv_to_tm fv in + FStarC_Syntax_Syntax.mk_Tm_uinst uu___1 us in + ret uu___ + | FStarC_Reflection_V1_Data.Tv_App (l, (r, q)) -> + let q' = FStarC_Reflection_V1_Builtins.pack_aqual q in + let uu___ = FStarC_Syntax_Util.mk_app l [(r, q')] in ret uu___ + | FStarC_Reflection_V1_Data.Tv_Abs (b, t) -> + let uu___ = + FStarC_Syntax_Util.abs [b] t FStar_Pervasives_Native.None in + ret uu___ + | FStarC_Reflection_V1_Data.Tv_Arrow (b, c) -> + let uu___ = + if leave_curried + then FStarC_Syntax_Util.arrow [b] c + else + (let uu___2 = FStarC_Syntax_Util.arrow [b] c in + FStarC_Syntax_Util.canon_arrow uu___2) in + ret uu___ + | FStarC_Reflection_V1_Data.Tv_Type u -> + let uu___ = + FStarC_Syntax_Syntax.mk (FStarC_Syntax_Syntax.Tm_type u) + FStarC_Compiler_Range_Type.dummyRange in + ret uu___ + | FStarC_Reflection_V1_Data.Tv_Refine (bv, sort, t) -> + let bv1 = + { + FStarC_Syntax_Syntax.ppname = (bv.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = (bv.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = sort + } in + let uu___ = FStarC_Syntax_Util.refine bv1 t in ret uu___ + | FStarC_Reflection_V1_Data.Tv_Const c -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Reflection_V1_Builtins.pack_const c in + FStarC_Syntax_Syntax.Tm_constant uu___2 in + FStarC_Syntax_Syntax.mk uu___1 + FStarC_Compiler_Range_Type.dummyRange in + ret uu___ + | FStarC_Reflection_V1_Data.Tv_Uvar (_u, ctx_u_s) -> + let uu___ = + FStarC_Syntax_Syntax.mk (FStarC_Syntax_Syntax.Tm_uvar ctx_u_s) + FStarC_Compiler_Range_Type.dummyRange in + ret uu___ + | FStarC_Reflection_V1_Data.Tv_Let (false, attrs, bv, ty, t1, t2) -> + let bv1 = + { + FStarC_Syntax_Syntax.ppname = (bv.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = (bv.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = ty + } in + let lb = + FStarC_Syntax_Util.mk_letbinding (FStar_Pervasives.Inl bv1) [] + bv1.FStarC_Syntax_Syntax.sort + FStarC_Parser_Const.effect_Tot_lid t1 attrs + FStarC_Compiler_Range_Type.dummyRange in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.mk_binder bv1 in + [uu___5] in + FStarC_Syntax_Subst.close uu___4 t2 in + { + FStarC_Syntax_Syntax.lbs = (false, [lb]); + FStarC_Syntax_Syntax.body1 = uu___3 + } in + FStarC_Syntax_Syntax.Tm_let uu___2 in + FStarC_Syntax_Syntax.mk uu___1 + FStarC_Compiler_Range_Type.dummyRange in + ret uu___ + | FStarC_Reflection_V1_Data.Tv_Let (true, attrs, bv, ty, t1, t2) -> + let bv1 = + { + FStarC_Syntax_Syntax.ppname = (bv.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = (bv.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = ty + } in + let lb = + FStarC_Syntax_Util.mk_letbinding (FStar_Pervasives.Inl bv1) [] + bv1.FStarC_Syntax_Syntax.sort + FStarC_Parser_Const.effect_Tot_lid t1 attrs + FStarC_Compiler_Range_Type.dummyRange in + let uu___ = FStarC_Syntax_Subst.close_let_rec [lb] t2 in + (match uu___ with + | (lbs, body) -> + let uu___1 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = (true, lbs); + FStarC_Syntax_Syntax.body1 = body + }) FStarC_Compiler_Range_Type.dummyRange in + ret uu___1) + | FStarC_Reflection_V1_Data.Tv_Match (t, ret_opt, brs) -> + let wrap v = + { + FStarC_Syntax_Syntax.v = v; + FStarC_Syntax_Syntax.p = FStarC_Compiler_Range_Type.dummyRange + } in + let rec pack_pat p = + match p with + | FStarC_Reflection_V1_Data.Pat_Constant c -> + let uu___ = + let uu___1 = FStarC_Reflection_V1_Builtins.pack_const c in + FStarC_Syntax_Syntax.Pat_constant uu___1 in + wrap uu___ + | FStarC_Reflection_V1_Data.Pat_Cons (fv, us_opt, ps) -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with + | (p1, b) -> + let uu___4 = pack_pat p1 in (uu___4, b)) ps in + (fv, us_opt, uu___2) in + FStarC_Syntax_Syntax.Pat_cons uu___1 in + wrap uu___ + | FStarC_Reflection_V1_Data.Pat_Var (bv, _sort) -> + wrap (FStarC_Syntax_Syntax.Pat_var bv) + | FStarC_Reflection_V1_Data.Pat_Dot_Term eopt -> + wrap (FStarC_Syntax_Syntax.Pat_dot_term eopt) in + let brs1 = + FStarC_Compiler_List.map + (fun uu___ -> + match uu___ with + | (pat, t1) -> + let uu___1 = pack_pat pat in + (uu___1, FStar_Pervasives_Native.None, t1)) brs in + let brs2 = + FStarC_Compiler_List.map FStarC_Syntax_Subst.close_branch brs1 in + let uu___ = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_match + { + FStarC_Syntax_Syntax.scrutinee = t; + FStarC_Syntax_Syntax.ret_opt = ret_opt; + FStarC_Syntax_Syntax.brs = brs2; + FStarC_Syntax_Syntax.rc_opt1 = + FStar_Pervasives_Native.None + }) FStarC_Compiler_Range_Type.dummyRange in + ret uu___ + | FStarC_Reflection_V1_Data.Tv_AscribedT (e, t, tacopt, use_eq) -> + let uu___ = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_ascribed + { + FStarC_Syntax_Syntax.tm = e; + FStarC_Syntax_Syntax.asc = + ((FStar_Pervasives.Inl t), tacopt, use_eq); + FStarC_Syntax_Syntax.eff_opt = + FStar_Pervasives_Native.None + }) FStarC_Compiler_Range_Type.dummyRange in + ret uu___ + | FStarC_Reflection_V1_Data.Tv_AscribedC (e, c, tacopt, use_eq) -> + let uu___ = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_ascribed + { + FStarC_Syntax_Syntax.tm = e; + FStarC_Syntax_Syntax.asc = + ((FStar_Pervasives.Inr c), tacopt, use_eq); + FStarC_Syntax_Syntax.eff_opt = + FStar_Pervasives_Native.None + }) FStarC_Compiler_Range_Type.dummyRange in + ret uu___ + | FStarC_Reflection_V1_Data.Tv_Unknown -> + let uu___ = + FStarC_Syntax_Syntax.mk FStarC_Syntax_Syntax.Tm_unknown + FStarC_Compiler_Range_Type.dummyRange in + ret uu___ + | FStarC_Reflection_V1_Data.Tv_Unsupp -> + FStarC_Tactics_Monad.fail "cannot pack Tv_Unsupp" +let (pack : + FStarC_Reflection_V1_Data.term_view -> + FStarC_Syntax_Syntax.term FStarC_Tactics_Monad.tac) + = fun tv -> pack' tv false +let (pack_curried : + FStarC_Reflection_V1_Data.term_view -> + FStarC_Syntax_Syntax.term FStarC_Tactics_Monad.tac) + = fun tv -> pack' tv true +let (lget : + FStarC_Syntax_Syntax.typ -> + Prims.string -> FStarC_Syntax_Syntax.term FStarC_Tactics_Monad.tac) + = + fun ty -> + fun k -> + let uu___ = + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () + () (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___1 -> + (fun ps -> + let ps = Obj.magic ps in + let uu___1 = + FStarC_Compiler_Util.psmap_try_find + ps.FStarC_Tactics_Types.local_state k in + match uu___1 with + | FStar_Pervasives_Native.None -> + Obj.magic (FStarC_Tactics_Monad.fail "not found") + | FStar_Pervasives_Native.Some t -> + Obj.magic (unquote ty t)) uu___1)) in + FStarC_Tactics_Monad.wrap_err "lget" uu___ +let (lset : + FStarC_Syntax_Syntax.typ -> + Prims.string -> + FStarC_Syntax_Syntax.term -> unit FStarC_Tactics_Monad.tac) + = + fun _ty -> + fun k -> + fun t -> + let uu___ = + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___1 -> + (fun ps -> + let ps = Obj.magic ps in + let ps1 = + let uu___1 = + FStarC_Compiler_Util.psmap_add + ps.FStarC_Tactics_Types.local_state k t in + { + FStarC_Tactics_Types.main_context = + (ps.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits = + (ps.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = + (ps.FStarC_Tactics_Types.goals); + FStarC_Tactics_Types.smt_goals = + (ps.FStarC_Tactics_Types.smt_goals); + FStarC_Tactics_Types.depth = + (ps.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = + (ps.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = + (ps.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (ps.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = + (ps.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness = + (ps.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg = + (ps.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = uu___1; + FStarC_Tactics_Types.urgency = + (ps.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure = + (ps.FStarC_Tactics_Types.dump_on_failure) + } in + Obj.magic (FStarC_Tactics_Monad.set ps1)) uu___1) in + FStarC_Tactics_Monad.wrap_err "lset" uu___ +let (set_urgency : FStarC_BigInt.t -> unit FStarC_Tactics_Monad.tac) = + fun u -> + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___ -> + (fun ps -> + let ps = Obj.magic ps in + let ps1 = + let uu___ = FStarC_BigInt.to_int_fs u in + { + FStarC_Tactics_Types.main_context = + (ps.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits = + (ps.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = (ps.FStarC_Tactics_Types.goals); + FStarC_Tactics_Types.smt_goals = + (ps.FStarC_Tactics_Types.smt_goals); + FStarC_Tactics_Types.depth = (ps.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = + (ps.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = (ps.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (ps.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = + (ps.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness = + (ps.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg = + (ps.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = + (ps.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency = uu___; + FStarC_Tactics_Types.dump_on_failure = + (ps.FStarC_Tactics_Types.dump_on_failure) + } in + Obj.magic (FStarC_Tactics_Monad.set ps1)) uu___) +let (t_commute_applied_match : unit -> unit FStarC_Tactics_Monad.tac) = + fun uu___ -> + let uu___1 = + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___2 -> + (fun g -> + let g = Obj.magic g in + let uu___2 = + let uu___3 = FStarC_Tactics_Types.goal_env g in + let uu___4 = FStarC_Tactics_Types.goal_type g in + destruct_eq uu___3 uu___4 in + match uu___2 with + | FStar_Pervasives_Native.Some (l, r) -> + let uu___3 = FStarC_Syntax_Util.head_and_args_full l in + (match uu___3 with + | (lh, las) -> + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Syntax_Util.unascribe lh in + FStarC_Syntax_Subst.compress uu___6 in + uu___5.FStarC_Syntax_Syntax.n in + (match uu___4 with + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = e; + FStarC_Syntax_Syntax.ret_opt = asc_opt; + FStarC_Syntax_Syntax.brs = brs; + FStarC_Syntax_Syntax.rc_opt1 = lopt;_} + -> + let brs' = + FStarC_Compiler_List.map + (fun uu___5 -> + match uu___5 with + | (p, w, e1) -> + let uu___6 = + FStarC_Syntax_Util.mk_app e1 las in + (p, w, uu___6)) brs in + let lopt' = + FStarC_Compiler_Util.map_option + (fun rc -> + let uu___5 = + FStarC_Compiler_Util.map_option + (fun t -> + let uu___6 = + let uu___7 = + FStarC_Tactics_Types.goal_env g in + FStarC_TypeChecker_Normalize.get_n_binders + uu___7 + (FStarC_Compiler_List.length + las) t in + match uu___6 with + | (bs, c) -> + let uu___7 = + FStarC_Syntax_Subst.open_comp + bs c in + (match uu___7 with + | (bs1, c1) -> + let ss = + FStarC_Compiler_List.map2 + (fun b -> + fun a -> + FStarC_Syntax_Syntax.NT + ((b.FStarC_Syntax_Syntax.binder_bv), + (FStar_Pervasives_Native.fst + a))) bs1 + las in + let c2 = + FStarC_Syntax_Subst.subst_comp + ss c1 in + FStarC_Syntax_Util.comp_result + c2)) + rc.FStarC_Syntax_Syntax.residual_typ in + { + FStarC_Syntax_Syntax.residual_effect = + (rc.FStarC_Syntax_Syntax.residual_effect); + FStarC_Syntax_Syntax.residual_typ = + uu___5; + FStarC_Syntax_Syntax.residual_flags = + (rc.FStarC_Syntax_Syntax.residual_flags) + }) lopt in + let l' = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_match + { + FStarC_Syntax_Syntax.scrutinee = e; + FStarC_Syntax_Syntax.ret_opt = asc_opt; + FStarC_Syntax_Syntax.brs = brs'; + FStarC_Syntax_Syntax.rc_opt1 = lopt' + }) l.FStarC_Syntax_Syntax.pos in + let must_tot = true in + let uu___5 = + let uu___6 = FStarC_Tactics_Types.goal_env g in + do_unify_maybe_guards false must_tot uu___6 l' + r in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___5) + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = Obj.magic uu___6 in + match uu___6 with + | FStar_Pervasives_Native.None -> + Obj.magic + (FStarC_Tactics_Monad.fail + "discharging the equality failed") + | FStar_Pervasives_Native.Some guard + -> + let uu___7 = + FStarC_TypeChecker_Env.is_trivial_guard_formula + guard in + if uu___7 + then + (mark_uvar_as_already_checked + g.FStarC_Tactics_Types.goal_ctx_uvar; + Obj.magic + (solve g + FStarC_Syntax_Util.exp_unit)) + else + Obj.magic + (failwith + "internal error: _t_refl: guard is not trivial")) + uu___6)) + | uu___5 -> + Obj.magic + (FStarC_Tactics_Monad.fail "lhs is not a match"))) + | FStar_Pervasives_Native.None -> + Obj.magic (FStarC_Tactics_Monad.fail "not an equality")) + uu___2) in + FStarC_Tactics_Monad.wrap_err "t_commute_applied_match" uu___1 +let (string_to_term : + env -> Prims.string -> FStarC_Syntax_Syntax.term FStarC_Tactics_Monad.tac) + = + fun e -> + fun s -> + let frag_of_text s1 = + { + FStarC_Parser_ParseIt.frag_fname = ""; + FStarC_Parser_ParseIt.frag_text = s1; + FStarC_Parser_ParseIt.frag_line = Prims.int_one; + FStarC_Parser_ParseIt.frag_col = Prims.int_zero + } in + let uu___ = + FStarC_Parser_ParseIt.parse FStar_Pervasives_Native.None + (FStarC_Parser_ParseIt.Fragment (frag_of_text s)) in + match uu___ with + | FStarC_Parser_ParseIt.Term t -> + let dsenv = + let uu___1 = FStarC_TypeChecker_Env.current_module e in + FStarC_Syntax_DsEnv.set_current_module + e.FStarC_TypeChecker_Env.dsenv uu___1 in + (try + (fun uu___1 -> + match () with + | () -> + let uu___2 = + FStarC_ToSyntax_ToSyntax.desugar_term dsenv t in + ret uu___2) () + with + | FStarC_Errors.Error (uu___2, e1, uu___3, uu___4) -> + let uu___5 = + let uu___6 = FStarC_Errors_Msg.rendermsg e1 in + Prims.strcat "string_to_term: " uu___6 in + FStarC_Tactics_Monad.fail uu___5 + | uu___2 -> + FStarC_Tactics_Monad.fail "string_to_term: Unknown error") + | FStarC_Parser_ParseIt.ASTFragment uu___1 -> + FStarC_Tactics_Monad.fail + "string_to_term: expected a Term as a result, got an ASTFragment" + | FStarC_Parser_ParseIt.ParseError (uu___1, err, uu___2) -> + let uu___3 = + let uu___4 = FStarC_Errors_Msg.rendermsg err in + Prims.strcat "string_to_term: got error " uu___4 in + FStarC_Tactics_Monad.fail uu___3 +let (push_bv_dsenv : + env -> + Prims.string -> (env * FStarC_Syntax_Syntax.bv) FStarC_Tactics_Monad.tac) + = + fun e -> + fun i -> + let ident = + FStarC_Ident.mk_ident (i, FStarC_Compiler_Range_Type.dummyRange) in + let uu___ = + FStarC_Syntax_DsEnv.push_bv e.FStarC_TypeChecker_Env.dsenv ident in + match uu___ with + | (dsenv, bv) -> + ret + ({ + FStarC_TypeChecker_Env.solver = + (e.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (e.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (e.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (e.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (e.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (e.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (e.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (e.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (e.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (e.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (e.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (e.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (e.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (e.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (e.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (e.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (e.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (e.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (e.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (e.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (e.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (e.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (e.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (e.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (e.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (e.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (e.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (e.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (e.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (e.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (e.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (e.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (e.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (e.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (e.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (e.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (e.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (e.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (e.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (e.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (e.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (e.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (e.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = dsenv; + FStarC_TypeChecker_Env.nbe = (e.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (e.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (e.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (e.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (e.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (e.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (e.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (e.FStarC_TypeChecker_Env.missing_decl) + }, bv) +let (term_to_string : + FStarC_Syntax_Syntax.term -> Prims.string FStarC_Tactics_Monad.tac) = + fun t -> + let s = FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + ret s +let (comp_to_string : + FStarC_Syntax_Syntax.comp -> Prims.string FStarC_Tactics_Monad.tac) = + fun c -> + let s = FStarC_Class_Show.show FStarC_Syntax_Print.showable_comp c in + ret s +let (range_to_string : + FStarC_Compiler_Range_Type.range -> Prims.string FStarC_Tactics_Monad.tac) + = + fun r -> + let uu___ = + FStarC_Class_Show.show FStarC_Compiler_Range_Ops.showable_range r in + ret uu___ +let (term_eq_old : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> Prims.bool FStarC_Tactics_Monad.tac) + = + fun uu___1 -> + fun uu___ -> + (fun t1 -> + fun t2 -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac + () () idtac + (fun uu___ -> + (fun uu___ -> + let uu___ = Obj.magic uu___ in + let uu___1 = FStarC_Syntax_Util.term_eq t1 t2 in + Obj.magic (ret uu___1)) uu___))) uu___1 uu___ +let with_compat_pre_core : + 'a . + FStarC_BigInt.t -> + 'a FStarC_Tactics_Monad.tac -> 'a FStarC_Tactics_Monad.tac + = + fun n -> + fun f -> + FStarC_Tactics_Monad.mk_tac + (fun ps -> + FStarC_Options.with_saved_options + (fun uu___ -> + let _res = FStarC_Options.set_options "--compat_pre_core 0" in + FStarC_Tactics_Monad.run f ps)) +let (get_vconfig : unit -> FStarC_VConfig.vconfig FStarC_Tactics_Monad.tac) = + fun uu___ -> + (fun uu___ -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___1 -> + (fun g -> + let g = Obj.magic g in + let vcfg = + FStarC_Options.with_saved_options + (fun uu___1 -> + FStarC_Options.set g.FStarC_Tactics_Types.opts; + FStarC_Options.get_vconfig ()) in + Obj.magic (ret vcfg)) uu___1))) uu___ +let (set_vconfig : FStarC_VConfig.vconfig -> unit FStarC_Tactics_Monad.tac) = + fun vcfg -> + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___ -> + (fun g -> + let g = Obj.magic g in + let opts' = + FStarC_Options.with_saved_options + (fun uu___ -> + FStarC_Options.set g.FStarC_Tactics_Types.opts; + FStarC_Options.set_vconfig vcfg; + FStarC_Options.peek ()) in + let g' = + { + FStarC_Tactics_Types.goal_main_env = + (g.FStarC_Tactics_Types.goal_main_env); + FStarC_Tactics_Types.goal_ctx_uvar = + (g.FStarC_Tactics_Types.goal_ctx_uvar); + FStarC_Tactics_Types.opts = opts'; + FStarC_Tactics_Types.is_guard = + (g.FStarC_Tactics_Types.is_guard); + FStarC_Tactics_Types.label = (g.FStarC_Tactics_Types.label) + } in + Obj.magic (FStarC_Tactics_Monad.replace_cur g')) uu___) +let (t_smt_sync : FStarC_VConfig.vconfig -> unit FStarC_Tactics_Monad.tac) = + fun vcfg -> + let uu___ = + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___1 -> + (fun goal -> + let goal = Obj.magic goal in + let uu___1 = get_phi goal in + match uu___1 with + | FStar_Pervasives_Native.None -> + Obj.magic + (FStarC_Tactics_Monad.fail "Goal is not irrelevant") + | FStar_Pervasives_Native.Some phi -> + let e = FStarC_Tactics_Types.goal_env goal in + let ans = + FStarC_Options.with_saved_options + (fun uu___2 -> + FStarC_Options.set_vconfig vcfg; + (e.FStarC_TypeChecker_Env.solver).FStarC_TypeChecker_Env.solve_sync + FStar_Pervasives_Native.None e phi) in + if ans + then + (mark_uvar_as_already_checked + goal.FStarC_Tactics_Types.goal_ctx_uvar; + Obj.magic (solve goal FStarC_Syntax_Util.exp_unit)) + else + Obj.magic + (FStarC_Tactics_Monad.fail + "SMT did not solve this goal")) uu___1) in + FStarC_Tactics_Monad.wrap_err "t_smt_sync" uu___ +let (free_uvars : + FStarC_Syntax_Syntax.term -> + FStarC_BigInt.t Prims.list FStarC_Tactics_Monad.tac) + = + fun uu___ -> + (fun tm -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + idtac + (fun uu___ -> + (fun uu___ -> + let uu___ = Obj.magic uu___ in + let uvs = + let uu___1 = + let uu___2 = FStarC_Syntax_Free.uvars_uncached tm in + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) + (Obj.magic uu___2) in + FStarC_Compiler_List.map + (fun u -> + let uu___2 = + FStarC_Syntax_Unionfind.uvar_id + u.FStarC_Syntax_Syntax.ctx_uvar_head in + FStarC_BigInt.of_int_fs uu___2) uu___1 in + Obj.magic (ret uvs)) uu___))) uu___ +let (dbg_refl : env -> (unit -> Prims.string) -> unit) = + fun g -> + fun msg -> + let uu___ = FStarC_Compiler_Effect.op_Bang dbg_ReflTc in + if uu___ + then let uu___1 = msg () in FStarC_Compiler_Util.print_string uu___1 + else () +type issues = FStarC_Errors.issue Prims.list +let refl_typing_builtin_wrapper : + 'a . + (unit -> 'a) -> + ('a FStar_Pervasives_Native.option * issues) FStarC_Tactics_Monad.tac + = + fun f -> + let tx = FStarC_Syntax_Unionfind.new_transaction () in + let uu___ = + try + (fun uu___1 -> + match () with | () -> FStarC_Errors.catch_errors_and_ignore_rest f) + () + with + | uu___1 -> + let issue = + let uu___2 = + let uu___3 = FStarC_Compiler_Util.print_exn uu___1 in + FStarC_Errors_Msg.mkmsg uu___3 in + let uu___3 = FStarC_Errors.get_ctx () in + { + FStarC_Errors.issue_msg = uu___2; + FStarC_Errors.issue_level = FStarC_Errors.EError; + FStarC_Errors.issue_range = FStar_Pervasives_Native.None; + FStarC_Errors.issue_number = + (FStar_Pervasives_Native.Some (Prims.of_int (17))); + FStarC_Errors.issue_ctx = uu___3 + } in + ([issue], FStar_Pervasives_Native.None) in + match uu___ with + | (errs, r) -> + (FStarC_Syntax_Unionfind.rollback tx; + if (FStarC_Compiler_List.length errs) > Prims.int_zero + then ret (FStar_Pervasives_Native.None, errs) + else ret (r, errs)) +let (no_uvars_in_term : FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t -> + (let uu___ = FStarC_Syntax_Free.uvars t in + FStarC_Class_Setlike.is_empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) (Obj.magic uu___)) + && + (let uu___ = FStarC_Syntax_Free.univs t in + FStarC_Class_Setlike.is_empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_univ_uvar)) (Obj.magic uu___)) +let (no_uvars_in_g : env -> Prims.bool) = + fun g -> + FStarC_Compiler_Util.for_all + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.Binding_var bv -> + no_uvars_in_term bv.FStarC_Syntax_Syntax.sort + | uu___1 -> true) g.FStarC_TypeChecker_Env.gamma +type relation = + | Subtyping + | Equality +let (uu___is_Subtyping : relation -> Prims.bool) = + fun projectee -> match projectee with | Subtyping -> true | uu___ -> false +let (uu___is_Equality : relation -> Prims.bool) = + fun projectee -> match projectee with | Equality -> true | uu___ -> false +let (unexpected_uvars_issue : + FStarC_Compiler_Range_Type.range -> FStarC_Errors.issue) = + fun r -> + let i = + let uu___ = FStarC_Errors_Msg.mkmsg "Cannot check relation with uvars" in + let uu___1 = + let uu___2 = + FStarC_Errors.errno + FStarC_Errors_Codes.Error_UnexpectedUnresolvedUvar in + FStar_Pervasives_Native.Some uu___2 in + { + FStarC_Errors.issue_msg = uu___; + FStarC_Errors.issue_level = FStarC_Errors.EError; + FStarC_Errors.issue_range = (FStar_Pervasives_Native.Some r); + FStarC_Errors.issue_number = uu___1; + FStarC_Errors.issue_ctx = [] + } in + i \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Tactics_V1_Primops.ml b/ocaml/fstar-lib/generated/FStarC_Tactics_V1_Primops.ml new file mode 100644 index 00000000000..e31cae822c5 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Tactics_V1_Primops.ml @@ -0,0 +1,1204 @@ +open Prims +let solve : 'a . 'a -> 'a = fun ev -> ev +let (uu___0 : + FStarC_Syntax_Syntax.term FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Reflection_V1_Embeddings.e_term +let (fix_module : + FStarC_TypeChecker_Primops_Base.primitive_step -> + FStarC_TypeChecker_Primops_Base.primitive_step) + = + fun ps -> + let p = FStarC_Ident.path_of_lid ps.FStarC_TypeChecker_Primops_Base.name in + let uu___ = + FStarC_Compiler_Path.is_under + (FStarC_Class_Ord.ord_eq FStarC_Class_Ord.ord_string) p + ["FStar"; "Stubs"; "Tactics"; "V2"; "Builtins"] in + if uu___ + then + let p' = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Compiler_List.tl p in + FStarC_Compiler_List.tl uu___5 in + FStarC_Compiler_List.tl uu___4 in + FStarC_Compiler_List.tl uu___3 in + FStarC_Compiler_List.tl uu___2 in + FStarC_Compiler_List.op_At + ["FStar"; "Stubs"; "Tactics"; "V1"; "Builtins"] uu___1 in + let uu___1 = + let uu___2 = + FStarC_Class_HasRange.pos FStarC_Ident.hasrange_lident + ps.FStarC_TypeChecker_Primops_Base.name in + FStarC_Ident.lid_of_path p' uu___2 in + { + FStarC_TypeChecker_Primops_Base.name = uu___1; + FStarC_TypeChecker_Primops_Base.arity = + (ps.FStarC_TypeChecker_Primops_Base.arity); + FStarC_TypeChecker_Primops_Base.univ_arity = + (ps.FStarC_TypeChecker_Primops_Base.univ_arity); + FStarC_TypeChecker_Primops_Base.auto_reflect = + (ps.FStarC_TypeChecker_Primops_Base.auto_reflect); + FStarC_TypeChecker_Primops_Base.strong_reduction_ok = + (ps.FStarC_TypeChecker_Primops_Base.strong_reduction_ok); + FStarC_TypeChecker_Primops_Base.requires_binder_substitution = + (ps.FStarC_TypeChecker_Primops_Base.requires_binder_substitution); + FStarC_TypeChecker_Primops_Base.renorm_after = + (ps.FStarC_TypeChecker_Primops_Base.renorm_after); + FStarC_TypeChecker_Primops_Base.interpretation = + (ps.FStarC_TypeChecker_Primops_Base.interpretation); + FStarC_TypeChecker_Primops_Base.interpretation_nbe = + (ps.FStarC_TypeChecker_Primops_Base.interpretation_nbe) + } + else failwith "huh?" +let (ops : FStarC_TypeChecker_Primops_Base.primitive_step Prims.list) = + let uu___ = + let uu___1 = + FStarC_Tactics_InterpFuns.mk_tac_step_1 Prims.int_zero "set_goals" + (FStarC_Syntax_Embeddings.e_list FStarC_Tactics_Embedding.e_goal) + FStarC_Syntax_Embeddings.e_unit + (FStarC_TypeChecker_NBETerm.e_list + FStarC_Tactics_Embedding.e_goal_nbe) + FStarC_TypeChecker_NBETerm.e_unit FStarC_Tactics_Monad.set_goals + FStarC_Tactics_Monad.set_goals in + let uu___2 = + let uu___3 = + FStarC_Tactics_InterpFuns.mk_tac_step_1 Prims.int_zero + "set_smt_goals" + (FStarC_Syntax_Embeddings.e_list FStarC_Tactics_Embedding.e_goal) + FStarC_Syntax_Embeddings.e_unit + (FStarC_TypeChecker_NBETerm.e_list + FStarC_Tactics_Embedding.e_goal_nbe) + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_Monad.set_smt_goals + FStarC_Tactics_Monad.set_smt_goals in + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Tactics_Interpreter.e_tactic_thunk + FStarC_Syntax_Embeddings.e_any in + let uu___7 = + FStarC_Tactics_Interpreter.e_tactic_nbe_thunk + FStarC_TypeChecker_NBETerm.e_any in + FStarC_Tactics_InterpFuns.mk_tac_step_2 Prims.int_one "catch" + FStarC_Syntax_Embeddings.e_any uu___6 + (FStarC_Syntax_Embeddings.e_either FStarC_Tactics_Embedding.e_exn + FStarC_Syntax_Embeddings.e_any) + FStarC_TypeChecker_NBETerm.e_any uu___7 + (FStarC_TypeChecker_NBETerm.e_either + FStarC_Tactics_Embedding.e_exn_nbe + FStarC_TypeChecker_NBETerm.e_any) + (fun uu___8 -> FStarC_Tactics_Monad.catch) + (fun uu___8 -> FStarC_Tactics_Monad.catch) in + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Tactics_Interpreter.e_tactic_thunk + FStarC_Syntax_Embeddings.e_any in + let uu___9 = + FStarC_Tactics_Interpreter.e_tactic_nbe_thunk + FStarC_TypeChecker_NBETerm.e_any in + FStarC_Tactics_InterpFuns.mk_tac_step_2 Prims.int_one "recover" + FStarC_Syntax_Embeddings.e_any uu___8 + (FStarC_Syntax_Embeddings.e_either + FStarC_Tactics_Embedding.e_exn + FStarC_Syntax_Embeddings.e_any) + FStarC_TypeChecker_NBETerm.e_any uu___9 + (FStarC_TypeChecker_NBETerm.e_either + FStarC_Tactics_Embedding.e_exn_nbe + FStarC_TypeChecker_NBETerm.e_any) + (fun uu___10 -> FStarC_Tactics_Monad.recover) + (fun uu___10 -> FStarC_Tactics_Monad.recover) in + let uu___8 = + let uu___9 = + FStarC_Tactics_InterpFuns.mk_tac_step_1 Prims.int_zero "intro" + FStarC_Syntax_Embeddings.e_unit + FStarC_Reflection_V2_Embeddings.e_binder + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Reflection_V2_NBEEmbeddings.e_binder + FStarC_Tactics_V1_Basic.intro FStarC_Tactics_V1_Basic.intro in + let uu___10 = + let uu___11 = + FStarC_Tactics_InterpFuns.mk_tac_step_1 Prims.int_zero + "intro_rec" FStarC_Syntax_Embeddings.e_unit + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Reflection_V2_Embeddings.e_binder + FStarC_Reflection_V2_Embeddings.e_binder) + FStarC_TypeChecker_NBETerm.e_unit + (FStarC_TypeChecker_NBETerm.e_tuple2 + FStarC_Reflection_V2_NBEEmbeddings.e_binder + FStarC_Reflection_V2_NBEEmbeddings.e_binder) + FStarC_Tactics_V1_Basic.intro_rec + FStarC_Tactics_V1_Basic.intro_rec in + let uu___12 = + let uu___13 = + FStarC_Tactics_InterpFuns.mk_tac_step_1 Prims.int_zero + "norm" + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_norm_step) + FStarC_Syntax_Embeddings.e_unit + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_norm_step) + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V1_Basic.norm FStarC_Tactics_V1_Basic.norm in + let uu___14 = + let uu___15 = + FStarC_Tactics_InterpFuns.mk_tac_step_3 Prims.int_zero + "norm_term_env" FStarC_Reflection_V2_Embeddings.e_env + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_norm_step) uu___0 uu___0 + FStarC_Reflection_V2_NBEEmbeddings.e_env + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_norm_step) + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Tactics_V1_Basic.norm_term_env + FStarC_Tactics_V1_Basic.norm_term_env in + let uu___16 = + let uu___17 = + FStarC_Tactics_InterpFuns.mk_tac_step_2 Prims.int_zero + "norm_binder_type" + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_norm_step) + FStarC_Reflection_V2_Embeddings.e_binder + FStarC_Syntax_Embeddings.e_unit + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_norm_step) + FStarC_Reflection_V2_NBEEmbeddings.e_binder + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V1_Basic.norm_binder_type + FStarC_Tactics_V1_Basic.norm_binder_type in + let uu___18 = + let uu___19 = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_zero "rename_to" + FStarC_Reflection_V2_Embeddings.e_binder + FStarC_Syntax_Embeddings.e_string + FStarC_Reflection_V2_Embeddings.e_binder + FStarC_Reflection_V2_NBEEmbeddings.e_binder + FStarC_TypeChecker_NBETerm.e_string + FStarC_Reflection_V2_NBEEmbeddings.e_binder + FStarC_Tactics_V1_Basic.rename_to + FStarC_Tactics_V1_Basic.rename_to in + let uu___20 = + let uu___21 = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero "binder_retype" + FStarC_Reflection_V2_Embeddings.e_binder + FStarC_Syntax_Embeddings.e_unit + FStarC_Reflection_V2_NBEEmbeddings.e_binder + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V1_Basic.binder_retype + FStarC_Tactics_V1_Basic.binder_retype in + let uu___22 = + let uu___23 = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero "revert" + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_unit + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V1_Basic.revert + FStarC_Tactics_V1_Basic.revert in + let uu___24 = + let uu___25 = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero "clear_top" + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_unit + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V1_Basic.clear_top + FStarC_Tactics_V1_Basic.clear_top in + let uu___26 = + let uu___27 = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero "clear" + FStarC_Reflection_V2_Embeddings.e_binder + FStarC_Syntax_Embeddings.e_unit + FStarC_Reflection_V2_NBEEmbeddings.e_binder + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V1_Basic.clear + FStarC_Tactics_V1_Basic.clear in + let uu___28 = + let uu___29 = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero "rewrite" + FStarC_Reflection_V2_Embeddings.e_binder + FStarC_Syntax_Embeddings.e_unit + FStarC_Reflection_V2_NBEEmbeddings.e_binder + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V1_Basic.rewrite + FStarC_Tactics_V1_Basic.rewrite in + let uu___30 = + let uu___31 = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero "refine_intro" + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_unit + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V1_Basic.refine_intro + FStarC_Tactics_V1_Basic.refine_intro in + let uu___32 = + let uu___33 = + FStarC_Tactics_InterpFuns.mk_tac_step_3 + Prims.int_zero "t_exact" + FStarC_Syntax_Embeddings.e_bool + FStarC_Syntax_Embeddings.e_bool + uu___0 + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_bool + FStarC_TypeChecker_NBETerm.e_bool + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V1_Basic.t_exact + FStarC_Tactics_V1_Basic.t_exact in + let uu___34 = + let uu___35 = + FStarC_Tactics_InterpFuns.mk_tac_step_4 + Prims.int_zero "t_apply" + FStarC_Syntax_Embeddings.e_bool + FStarC_Syntax_Embeddings.e_bool + FStarC_Syntax_Embeddings.e_bool + uu___0 + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_bool + FStarC_TypeChecker_NBETerm.e_bool + FStarC_TypeChecker_NBETerm.e_bool + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V1_Basic.t_apply + FStarC_Tactics_V1_Basic.t_apply in + let uu___36 = + let uu___37 = + FStarC_Tactics_InterpFuns.mk_tac_step_3 + Prims.int_zero "t_apply_lemma" + FStarC_Syntax_Embeddings.e_bool + FStarC_Syntax_Embeddings.e_bool + uu___0 + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_bool + FStarC_TypeChecker_NBETerm.e_bool + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V1_Basic.t_apply_lemma + FStarC_Tactics_V1_Basic.t_apply_lemma in + let uu___38 = + let uu___39 = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero "set_options" + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V1_Basic.set_options + FStarC_Tactics_V1_Basic.set_options in + let uu___40 = + let uu___41 = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_zero "tcc" + FStarC_Reflection_V2_Embeddings.e_env + uu___0 + FStarC_Reflection_V2_Embeddings.e_comp + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Reflection_V2_NBEEmbeddings.e_comp + FStarC_Tactics_V1_Basic.tcc + FStarC_Tactics_V1_Basic.tcc in + let uu___42 = + let uu___43 = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_zero "tc" + FStarC_Reflection_V2_Embeddings.e_env + uu___0 uu___0 + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Tactics_V1_Basic.tc + FStarC_Tactics_V1_Basic.tc in + let uu___44 = + let uu___45 = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero "unshelve" + uu___0 + FStarC_Syntax_Embeddings.e_unit + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V1_Basic.unshelve + FStarC_Tactics_V1_Basic.unshelve in + let uu___46 = + let uu___47 = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_one "unquote" + FStarC_Syntax_Embeddings.e_any + FStarC_Reflection_V1_Embeddings.e_term + FStarC_Syntax_Embeddings.e_any + FStarC_TypeChecker_NBETerm.e_any + FStarC_Reflection_V1_NBEEmbeddings.e_term + FStarC_TypeChecker_NBETerm.e_any + FStarC_Tactics_V1_Basic.unquote + (fun uu___48 -> + fun uu___49 -> + failwith + "NBE unquote") in + let uu___48 = + let uu___49 = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "prune" + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V1_Basic.prune + FStarC_Tactics_V1_Basic.prune in + let uu___50 = + let uu___51 = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "addns" + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V1_Basic.addns + FStarC_Tactics_V1_Basic.addns in + let uu___52 = + let uu___53 = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "print" + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V1_Basic.print + FStarC_Tactics_V1_Basic.print in + let uu___54 = + let uu___55 = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "debugging" + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_bool + FStarC_TypeChecker_NBETerm.e_unit + FStarC_TypeChecker_NBETerm.e_bool + FStarC_Tactics_V1_Basic.debugging + FStarC_Tactics_V1_Basic.debugging in + let uu___56 = + let uu___57 = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "dump" + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V1_Basic.dump + FStarC_Tactics_V1_Basic.dump in + let uu___58 = + let uu___59 = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_zero + "dump_all" + FStarC_Syntax_Embeddings.e_bool + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_bool + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V1_Basic.dump_all + FStarC_Tactics_V1_Basic.dump_all in + let uu___60 = + let uu___61 = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_zero + "dump_uvars_of" + FStarC_Tactics_Embedding.e_goal + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_unit + FStarC_Tactics_Embedding.e_goal_nbe + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V1_Basic.dump_uvars_of + FStarC_Tactics_V1_Basic.dump_uvars_of in + let uu___62 = + let uu___63 + = + let uu___64 + = + FStarC_Tactics_Interpreter.e_tactic_1 + FStarC_Reflection_V1_Embeddings.e_term + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Syntax_Embeddings.e_bool + FStarC_Tactics_Embedding.e_ctrl_flag) in + let uu___65 + = + FStarC_Tactics_Interpreter.e_tactic_thunk + FStarC_Syntax_Embeddings.e_unit in + let uu___66 + = + FStarC_Tactics_Interpreter.e_tactic_nbe_1 + FStarC_Reflection_V1_NBEEmbeddings.e_term + (FStarC_TypeChecker_NBETerm.e_tuple2 + FStarC_TypeChecker_NBETerm.e_bool + FStarC_Tactics_Embedding.e_ctrl_flag_nbe) in + let uu___67 + = + FStarC_Tactics_Interpreter.e_tactic_nbe_thunk + FStarC_TypeChecker_NBETerm.e_unit in + FStarC_Tactics_InterpFuns.mk_tac_step_3 + Prims.int_zero + "ctrl_rewrite" + FStarC_Tactics_Embedding.e_direction + uu___64 + uu___65 + FStarC_Syntax_Embeddings.e_unit + FStarC_Tactics_Embedding.e_direction_nbe + uu___66 + uu___67 + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_CtrlRewrite.ctrl_rewrite + FStarC_Tactics_CtrlRewrite.ctrl_rewrite in + let uu___64 + = + let uu___65 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "t_trefl" + FStarC_Syntax_Embeddings.e_bool + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_bool + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V1_Basic.t_trefl + FStarC_Tactics_V1_Basic.t_trefl in + let uu___66 + = + let uu___67 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "dup" + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_unit + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V1_Basic.dup + FStarC_Tactics_V1_Basic.dup in + let uu___68 + = + let uu___69 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "tadmit_t" + FStarC_Reflection_V1_Embeddings.e_term + FStarC_Syntax_Embeddings.e_unit + FStarC_Reflection_V1_NBEEmbeddings.e_term + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V1_Basic.tadmit_t + FStarC_Tactics_V1_Basic.tadmit_t in + let uu___70 + = + let uu___71 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "join" + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_unit + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V1_Basic.join + FStarC_Tactics_V1_Basic.join in + let uu___72 + = + let uu___73 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "t_destruct" + FStarC_Reflection_V1_Embeddings.e_term + (FStarC_Syntax_Embeddings.e_list + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Reflection_V2_Embeddings.e_fv + FStarC_Syntax_Embeddings.e_int)) + FStarC_Reflection_V1_NBEEmbeddings.e_term + (FStarC_TypeChecker_NBETerm.e_list + (FStarC_TypeChecker_NBETerm.e_tuple2 + FStarC_Reflection_V2_NBEEmbeddings.e_fv + FStarC_TypeChecker_NBETerm.e_int)) + FStarC_Tactics_V1_Basic.t_destruct + FStarC_Tactics_V1_Basic.t_destruct in + let uu___74 + = + let uu___75 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "top_env" + FStarC_Syntax_Embeddings.e_unit + FStarC_Reflection_V2_Embeddings.e_env + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_Tactics_V1_Basic.top_env + FStarC_Tactics_V1_Basic.top_env in + let uu___76 + = + let uu___77 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "inspect" + FStarC_Reflection_V1_Embeddings.e_term + FStarC_Reflection_V1_Embeddings.e_term_view + FStarC_Reflection_V1_NBEEmbeddings.e_term + FStarC_Reflection_V1_NBEEmbeddings.e_term_view + FStarC_Tactics_V1_Basic.inspect + FStarC_Tactics_V1_Basic.inspect in + let uu___78 + = + let uu___79 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "pack" + FStarC_Reflection_V1_Embeddings.e_term_view + FStarC_Reflection_V1_Embeddings.e_term + FStarC_Reflection_V1_NBEEmbeddings.e_term_view + FStarC_Reflection_V1_NBEEmbeddings.e_term + FStarC_Tactics_V1_Basic.pack + FStarC_Tactics_V1_Basic.pack in + let uu___80 + = + let uu___81 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "pack_curried" + FStarC_Reflection_V1_Embeddings.e_term_view + FStarC_Reflection_V1_Embeddings.e_term + FStarC_Reflection_V1_NBEEmbeddings.e_term_view + FStarC_Reflection_V1_NBEEmbeddings.e_term + FStarC_Tactics_V1_Basic.pack_curried + FStarC_Tactics_V1_Basic.pack_curried in + let uu___82 + = + let uu___83 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "fresh" + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_unit + FStarC_TypeChecker_NBETerm.e_int + FStarC_Tactics_V1_Basic.fresh + FStarC_Tactics_V1_Basic.fresh in + let uu___84 + = + let uu___85 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "curms" + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_unit + FStarC_TypeChecker_NBETerm.e_int + FStarC_Tactics_V1_Basic.curms + FStarC_Tactics_V1_Basic.curms in + let uu___86 + = + let uu___87 + = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_zero + "uvar_env" + FStarC_Reflection_V2_Embeddings.e_env + (FStarC_Syntax_Embeddings.e_option + FStarC_Reflection_V1_Embeddings.e_term) + FStarC_Reflection_V1_Embeddings.e_term + FStarC_Reflection_V2_NBEEmbeddings.e_env + (FStarC_TypeChecker_NBETerm.e_option + FStarC_Reflection_V1_NBEEmbeddings.e_term) + FStarC_Reflection_V1_NBEEmbeddings.e_term + FStarC_Tactics_V1_Basic.uvar_env + FStarC_Tactics_V1_Basic.uvar_env in + let uu___88 + = + let uu___89 + = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_zero + "ghost_uvar_env" + FStarC_Reflection_V2_Embeddings.e_env + FStarC_Reflection_V1_Embeddings.e_term + FStarC_Reflection_V1_Embeddings.e_term + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_Reflection_V1_NBEEmbeddings.e_term + FStarC_Reflection_V1_NBEEmbeddings.e_term + FStarC_Tactics_V1_Basic.ghost_uvar_env + FStarC_Tactics_V1_Basic.ghost_uvar_env in + let uu___90 + = + let uu___91 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "fresh_universe_uvar" + FStarC_Syntax_Embeddings.e_unit + FStarC_Reflection_V1_Embeddings.e_term + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Reflection_V1_NBEEmbeddings.e_term + FStarC_Tactics_V1_Basic.fresh_universe_uvar + FStarC_Tactics_V1_Basic.fresh_universe_uvar in + let uu___92 + = + let uu___93 + = + FStarC_Tactics_InterpFuns.mk_tac_step_3 + Prims.int_zero + "unify_env" + FStarC_Reflection_V1_Embeddings.e_env + FStarC_Reflection_V1_Embeddings.e_term + FStarC_Reflection_V1_Embeddings.e_term + FStarC_Syntax_Embeddings.e_bool + FStarC_Reflection_V1_NBEEmbeddings.e_env + FStarC_Reflection_V1_NBEEmbeddings.e_term + FStarC_Reflection_V1_NBEEmbeddings.e_term + FStarC_TypeChecker_NBETerm.e_bool + FStarC_Tactics_V1_Basic.unify_env + FStarC_Tactics_V1_Basic.unify_env in + let uu___94 + = + let uu___95 + = + FStarC_Tactics_InterpFuns.mk_tac_step_3 + Prims.int_zero + "unify_guard_env" + FStarC_Reflection_V1_Embeddings.e_env + FStarC_Reflection_V1_Embeddings.e_term + FStarC_Reflection_V1_Embeddings.e_term + FStarC_Syntax_Embeddings.e_bool + FStarC_Reflection_V1_NBEEmbeddings.e_env + FStarC_Reflection_V1_NBEEmbeddings.e_term + FStarC_Reflection_V1_NBEEmbeddings.e_term + FStarC_TypeChecker_NBETerm.e_bool + FStarC_Tactics_V1_Basic.unify_guard_env + FStarC_Tactics_V1_Basic.unify_guard_env in + let uu___96 + = + let uu___97 + = + FStarC_Tactics_InterpFuns.mk_tac_step_3 + Prims.int_zero + "match_env" + FStarC_Reflection_V1_Embeddings.e_env + FStarC_Reflection_V1_Embeddings.e_term + FStarC_Reflection_V1_Embeddings.e_term + FStarC_Syntax_Embeddings.e_bool + FStarC_Reflection_V1_NBEEmbeddings.e_env + FStarC_Reflection_V1_NBEEmbeddings.e_term + FStarC_Reflection_V1_NBEEmbeddings.e_term + FStarC_TypeChecker_NBETerm.e_bool + FStarC_Tactics_V1_Basic.match_env + FStarC_Tactics_V1_Basic.match_env in + let uu___98 + = + let uu___99 + = + FStarC_Tactics_InterpFuns.mk_tac_step_3 + Prims.int_zero + "launch_process" + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_string_list + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_string_list + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_string + FStarC_Tactics_V1_Basic.launch_process + FStarC_Tactics_V1_Basic.launch_process in + let uu___100 + = + let uu___101 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "fresh_bv_named" + FStarC_Syntax_Embeddings.e_string + FStarC_Reflection_V1_Embeddings.e_bv + FStarC_TypeChecker_NBETerm.e_string + FStarC_Reflection_V1_NBEEmbeddings.e_bv + FStarC_Tactics_V1_Basic.fresh_bv_named + FStarC_Tactics_V1_Basic.fresh_bv_named in + let uu___102 + = + let uu___103 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "change" + FStarC_Reflection_V1_Embeddings.e_term + FStarC_Syntax_Embeddings.e_unit + FStarC_Reflection_V1_NBEEmbeddings.e_term + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V1_Basic.change + FStarC_Tactics_V1_Basic.change in + let uu___104 + = + let uu___105 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "get_guard_policy" + FStarC_Syntax_Embeddings.e_unit + FStarC_Tactics_Embedding.e_guard_policy + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_Embedding.e_guard_policy_nbe + FStarC_Tactics_V1_Basic.get_guard_policy + FStarC_Tactics_V1_Basic.get_guard_policy in + let uu___106 + = + let uu___107 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "set_guard_policy" + FStarC_Tactics_Embedding.e_guard_policy + FStarC_Syntax_Embeddings.e_unit + FStarC_Tactics_Embedding.e_guard_policy_nbe + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V1_Basic.set_guard_policy + FStarC_Tactics_V1_Basic.set_guard_policy in + let uu___108 + = + let uu___109 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "lax_on" + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_bool + FStarC_TypeChecker_NBETerm.e_unit + FStarC_TypeChecker_NBETerm.e_bool + FStarC_Tactics_V1_Basic.lax_on + FStarC_Tactics_V1_Basic.lax_on in + let uu___110 + = + let uu___111 + = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_one + "lget" + FStarC_Syntax_Embeddings.e_any + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_any + FStarC_TypeChecker_NBETerm.e_any + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_any + FStarC_Tactics_V1_Basic.lget + (fun + uu___112 + -> + fun + uu___113 + -> + FStarC_Tactics_Monad.fail + "sorry, `lget` does not work in NBE") in + let uu___112 + = + let uu___113 + = + FStarC_Tactics_InterpFuns.mk_tac_step_3 + Prims.int_one + "lset" + FStarC_Syntax_Embeddings.e_any + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_any + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_any + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_any + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V1_Basic.lset + (fun + uu___114 + -> + fun + uu___115 + -> + fun + uu___116 + -> + FStarC_Tactics_Monad.fail + "sorry, `lset` does not work in NBE") in + let uu___114 + = + let uu___115 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "set_urgency" + FStarC_Syntax_Embeddings.e_int + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_int + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V1_Basic.set_urgency + FStarC_Tactics_V1_Basic.set_urgency in + let uu___116 + = + let uu___117 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "t_commute_applied_match" + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_unit + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V1_Basic.t_commute_applied_match + FStarC_Tactics_V1_Basic.t_commute_applied_match in + let uu___118 + = + let uu___119 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "gather_or_solve_explicit_guards_for_resolved_goals" + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_unit + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V1_Basic.gather_explicit_guards_for_resolved_goals + FStarC_Tactics_V1_Basic.gather_explicit_guards_for_resolved_goals in + let uu___120 + = + let uu___121 + = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_zero + "string_to_term" + FStarC_Reflection_V1_Embeddings.e_env + FStarC_Syntax_Embeddings.e_string + FStarC_Reflection_V1_Embeddings.e_term + FStarC_Reflection_V1_NBEEmbeddings.e_env + FStarC_TypeChecker_NBETerm.e_string + FStarC_Reflection_V1_NBEEmbeddings.e_term + FStarC_Tactics_V1_Basic.string_to_term + FStarC_Tactics_V1_Basic.string_to_term in + let uu___122 + = + let uu___123 + = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_zero + "push_bv_dsenv" + FStarC_Reflection_V1_Embeddings.e_env + FStarC_Syntax_Embeddings.e_string + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Reflection_V1_Embeddings.e_env + FStarC_Reflection_V1_Embeddings.e_bv) + FStarC_Reflection_V1_NBEEmbeddings.e_env + FStarC_TypeChecker_NBETerm.e_string + (FStarC_TypeChecker_NBETerm.e_tuple2 + FStarC_Reflection_V1_NBEEmbeddings.e_env + FStarC_Reflection_V1_NBEEmbeddings.e_bv) + FStarC_Tactics_V1_Basic.push_bv_dsenv + FStarC_Tactics_V1_Basic.push_bv_dsenv in + let uu___124 + = + let uu___125 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "term_to_string" + FStarC_Reflection_V1_Embeddings.e_term + FStarC_Syntax_Embeddings.e_string + FStarC_Reflection_V1_NBEEmbeddings.e_term + FStarC_TypeChecker_NBETerm.e_string + FStarC_Tactics_V1_Basic.term_to_string + FStarC_Tactics_V1_Basic.term_to_string in + let uu___126 + = + let uu___127 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "comp_to_string" + FStarC_Reflection_V2_Embeddings.e_comp + FStarC_Syntax_Embeddings.e_string + FStarC_Reflection_V2_NBEEmbeddings.e_comp + FStarC_TypeChecker_NBETerm.e_string + FStarC_Tactics_V1_Basic.comp_to_string + FStarC_Tactics_V1_Basic.comp_to_string in + let uu___128 + = + let uu___129 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "range_to_string" + FStarC_Syntax_Embeddings.e_range + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_range + FStarC_TypeChecker_NBETerm.e_string + FStarC_Tactics_V1_Basic.range_to_string + FStarC_Tactics_V1_Basic.range_to_string in + let uu___130 + = + let uu___131 + = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_zero + "term_eq_old" + FStarC_Reflection_V1_Embeddings.e_term + FStarC_Reflection_V1_Embeddings.e_term + FStarC_Syntax_Embeddings.e_bool + FStarC_Reflection_V1_NBEEmbeddings.e_term + FStarC_Reflection_V1_NBEEmbeddings.e_term + FStarC_TypeChecker_NBETerm.e_bool + FStarC_Tactics_V1_Basic.term_eq_old + FStarC_Tactics_V1_Basic.term_eq_old in + let uu___132 + = + let uu___133 + = + let uu___134 + = + FStarC_Tactics_Interpreter.e_tactic_thunk + FStarC_Syntax_Embeddings.e_any in + let uu___135 + = + FStarC_Tactics_Interpreter.e_tactic_nbe_thunk + FStarC_TypeChecker_NBETerm.e_any in + FStarC_Tactics_InterpFuns.mk_tac_step_3 + Prims.int_one + "with_compat_pre_core" + FStarC_Syntax_Embeddings.e_any + FStarC_Syntax_Embeddings.e_int + uu___134 + FStarC_Syntax_Embeddings.e_any + FStarC_TypeChecker_NBETerm.e_any + FStarC_TypeChecker_NBETerm.e_int + uu___135 + FStarC_TypeChecker_NBETerm.e_any + (fun + uu___136 + -> + FStarC_Tactics_V1_Basic.with_compat_pre_core) + (fun + uu___136 + -> + FStarC_Tactics_V1_Basic.with_compat_pre_core) in + let uu___134 + = + let uu___135 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "get_vconfig" + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_vconfig + FStarC_TypeChecker_NBETerm.e_unit + FStarC_TypeChecker_NBETerm.e_vconfig + FStarC_Tactics_V1_Basic.get_vconfig + FStarC_Tactics_V1_Basic.get_vconfig in + let uu___136 + = + let uu___137 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "set_vconfig" + FStarC_Syntax_Embeddings.e_vconfig + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_vconfig + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V1_Basic.set_vconfig + FStarC_Tactics_V1_Basic.set_vconfig in + let uu___138 + = + let uu___139 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "t_smt_sync" + FStarC_Syntax_Embeddings.e_vconfig + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_vconfig + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V1_Basic.t_smt_sync + FStarC_Tactics_V1_Basic.t_smt_sync in + let uu___140 + = + let uu___141 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "free_uvars" + FStarC_Reflection_V1_Embeddings.e_term + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_int) + FStarC_Reflection_V1_NBEEmbeddings.e_term + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_int) + FStarC_Tactics_V1_Basic.free_uvars + FStarC_Tactics_V1_Basic.free_uvars in + [uu___141] in + uu___139 + :: + uu___140 in + uu___137 + :: + uu___138 in + uu___135 + :: + uu___136 in + uu___133 + :: + uu___134 in + uu___131 + :: + uu___132 in + uu___129 + :: + uu___130 in + uu___127 + :: + uu___128 in + uu___125 + :: + uu___126 in + uu___123 + :: + uu___124 in + uu___121 + :: + uu___122 in + uu___119 + :: + uu___120 in + uu___117 + :: + uu___118 in + uu___115 + :: + uu___116 in + uu___113 + :: + uu___114 in + uu___111 + :: + uu___112 in + uu___109 + :: + uu___110 in + uu___107 + :: + uu___108 in + uu___105 + :: + uu___106 in + uu___103 + :: + uu___104 in + uu___101 + :: + uu___102 in + uu___99 + :: + uu___100 in + uu___97 + :: + uu___98 in + uu___95 + :: + uu___96 in + uu___93 + :: + uu___94 in + uu___91 + :: + uu___92 in + uu___89 + :: + uu___90 in + uu___87 + :: + uu___88 in + uu___85 + :: + uu___86 in + uu___83 + :: + uu___84 in + uu___81 + :: + uu___82 in + uu___79 + :: + uu___80 in + uu___77 + :: + uu___78 in + uu___75 + :: + uu___76 in + uu___73 + :: + uu___74 in + uu___71 + :: + uu___72 in + uu___69 + :: + uu___70 in + uu___67 + :: + uu___68 in + uu___65 + :: + uu___66 in + uu___63 :: + uu___64 in + uu___61 :: + uu___62 in + uu___59 :: + uu___60 in + uu___57 :: + uu___58 in + uu___55 :: uu___56 in + uu___53 :: uu___54 in + uu___51 :: uu___52 in + uu___49 :: uu___50 in + uu___47 :: uu___48 in + uu___45 :: uu___46 in + uu___43 :: uu___44 in + uu___41 :: uu___42 in + uu___39 :: uu___40 in + uu___37 :: uu___38 in + uu___35 :: uu___36 in + uu___33 :: uu___34 in + uu___31 :: uu___32 in + uu___29 :: uu___30 in + uu___27 :: uu___28 in + uu___25 :: uu___26 in + uu___23 :: uu___24 in + uu___21 :: uu___22 in + uu___19 :: uu___20 in + uu___17 :: uu___18 in + uu___15 :: uu___16 in + uu___13 :: uu___14 in + uu___11 :: uu___12 in + uu___9 :: uu___10 in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Compiler_List.map fix_module uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Tactics_V2_Basic.ml b/ocaml/fstar-lib/generated/FStarC_Tactics_V2_Basic.ml new file mode 100644 index 00000000000..1529f4cb115 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Tactics_V2_Basic.ml @@ -0,0 +1,13797 @@ +open Prims +let (dbg_Tac : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Tac" +let (dbg_TacUnify : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "TacUnify" +let (dbg_2635 : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "2635" +let (dbg_ReflTc : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "ReflTc" +let (dbg_TacVerbose : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "TacVerbose" +let (compress : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term FStarC_Tactics_Monad.tac) + = + fun uu___ -> + (fun t -> + let uu___ = + FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () + (Obj.repr ()) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + let uu___2 = FStarC_Syntax_Subst.compress t in + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac + () (Obj.magic uu___2))) uu___1))) uu___ +let (core_check : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.typ -> + Prims.bool -> + (FStarC_Syntax_Syntax.typ FStar_Pervasives_Native.option, + FStarC_TypeChecker_Core.error) FStar_Pervasives.either) + = + fun env -> + fun sol -> + fun t -> + fun must_tot -> + let uu___ = + let uu___1 = FStarC_Options.compat_pre_core_should_check () in + Prims.op_Negation uu___1 in + if uu___ + then FStar_Pervasives.Inl FStar_Pervasives_Native.None + else + (let debug f = + let uu___2 = FStarC_Compiler_Debug.any () in + if uu___2 then f () else () in + let uu___2 = + FStarC_TypeChecker_Core.check_term env sol t must_tot in + match uu___2 with + | FStar_Pervasives.Inl (FStar_Pervasives_Native.None) -> + FStar_Pervasives.Inl FStar_Pervasives_Native.None + | FStar_Pervasives.Inl (FStar_Pervasives_Native.Some g) -> + let uu___3 = FStarC_Options.compat_pre_core_set () in + if uu___3 + then FStar_Pervasives.Inl FStar_Pervasives_Native.None + else FStar_Pervasives.Inl (FStar_Pervasives_Native.Some g) + | FStar_Pervasives.Inr err -> + (debug + (fun uu___4 -> + let uu___5 = + let uu___6 = FStarC_TypeChecker_Env.get_range env in + FStarC_Class_Show.show + FStarC_Compiler_Range_Ops.showable_range uu___6 in + let uu___6 = + FStarC_TypeChecker_Core.print_error_short err in + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term sol in + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + let uu___9 = FStarC_TypeChecker_Core.print_error err in + FStarC_Compiler_Util.print5 + "(%s) Core checking failed (%s) on term %s and type %s\n%s\n" + uu___5 uu___6 uu___7 uu___8 uu___9); + FStar_Pervasives.Inr err)) +type name = FStarC_Syntax_Syntax.bv +type env = FStarC_TypeChecker_Env.env +type implicits = FStarC_TypeChecker_Env.implicits +let (rangeof : FStarC_Tactics_Types.goal -> FStarC_Compiler_Range_Type.range) + = + fun g -> + (g.FStarC_Tactics_Types.goal_ctx_uvar).FStarC_Syntax_Syntax.ctx_uvar_range +let (normalize : + FStarC_TypeChecker_Env.steps -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = fun s -> fun e -> fun t -> FStarC_TypeChecker_Normalize.normalize s e t +let (bnorm : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = fun e -> fun t -> normalize [] e t +let (whnf : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = fun e -> fun t -> FStarC_TypeChecker_Normalize.unfold_whnf e t +let (tts : + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.term -> Prims.string) = + FStarC_TypeChecker_Normalize.term_to_string +let (ttd : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Pprint.document) + = FStarC_TypeChecker_Normalize.term_to_doc +let (bnorm_goal : FStarC_Tactics_Types.goal -> FStarC_Tactics_Types.goal) = + fun g -> + let uu___ = + let uu___1 = FStarC_Tactics_Types.goal_env g in + let uu___2 = FStarC_Tactics_Types.goal_type g in bnorm uu___1 uu___2 in + FStarC_Tactics_Monad.goal_with_type g uu___ +let (tacprint : Prims.string -> unit) = + fun s -> FStarC_Compiler_Util.print1 "TAC>> %s\n" s +let (tacprint1 : Prims.string -> Prims.string -> unit) = + fun s -> + fun x -> + let uu___ = FStarC_Compiler_Util.format1 s x in + FStarC_Compiler_Util.print1 "TAC>> %s\n" uu___ +let (tacprint2 : Prims.string -> Prims.string -> Prims.string -> unit) = + fun s -> + fun x -> + fun y -> + let uu___ = FStarC_Compiler_Util.format2 s x y in + FStarC_Compiler_Util.print1 "TAC>> %s\n" uu___ +let (tacprint3 : + Prims.string -> Prims.string -> Prims.string -> Prims.string -> unit) = + fun s -> + fun x -> + fun y -> + fun z -> + let uu___ = FStarC_Compiler_Util.format3 s x y z in + FStarC_Compiler_Util.print1 "TAC>> %s\n" uu___ +let (print : Prims.string -> unit FStarC_Tactics_Monad.tac) = + fun msg -> + (let uu___1 = + let uu___2 = FStarC_Options.silent () in Prims.op_Negation uu___2 in + if uu___1 then tacprint msg else ()); + FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () (Obj.repr ()) +let (debugging : unit -> Prims.bool FStarC_Tactics_Monad.tac) = + fun uu___ -> + (fun uu___ -> + let uu___1 = + FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () + (Obj.repr ()) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + uu___1 + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + let uu___3 = FStarC_Compiler_Effect.op_Bang dbg_Tac in + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac + () (Obj.magic uu___3))) uu___2))) uu___ +let (ide : unit -> Prims.bool FStarC_Tactics_Monad.tac) = + fun uu___ -> + (fun uu___ -> + let uu___1 = + FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () + (Obj.repr ()) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + uu___1 + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + let uu___3 = FStarC_Options.ide () in + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac + () (Obj.magic uu___3))) uu___2))) uu___ +let (do_dump_ps : Prims.string -> FStarC_Tactics_Types.proofstate -> unit) = + fun msg -> + fun ps -> + let psc = ps.FStarC_Tactics_Types.psc in + let subst = FStarC_TypeChecker_Primops_Base.psc_subst psc in + FStarC_Tactics_Printing.do_dump_proofstate ps msg +let (dump : Prims.string -> unit FStarC_Tactics_Monad.tac) = + fun msg -> + FStarC_Tactics_Monad.mk_tac + (fun ps -> do_dump_ps msg ps; FStarC_Tactics_Result.Success ((), ps)) +let (dump_all : Prims.bool -> Prims.string -> unit FStarC_Tactics_Monad.tac) + = + fun print_resolved -> + fun msg -> + FStarC_Tactics_Monad.mk_tac + (fun ps -> + let gs = + FStarC_Compiler_List.map + (fun i -> + FStarC_Tactics_Types.goal_of_implicit + ps.FStarC_Tactics_Types.main_context i) + ps.FStarC_Tactics_Types.all_implicits in + let gs1 = + if print_resolved + then gs + else + FStarC_Compiler_List.filter + (fun g -> + let uu___1 = FStarC_Tactics_Types.check_goal_solved g in + Prims.op_Negation uu___1) gs in + let ps' = + { + FStarC_Tactics_Types.main_context = + (ps.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits = + (ps.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = gs1; + FStarC_Tactics_Types.smt_goals = []; + FStarC_Tactics_Types.depth = (ps.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = (ps.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = (ps.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (ps.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = + (ps.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness = + (ps.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg = + (ps.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = + (ps.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency = + (ps.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure = + (ps.FStarC_Tactics_Types.dump_on_failure) + } in + do_dump_ps msg ps'; FStarC_Tactics_Result.Success ((), ps)) +let (dump_uvars_of : + FStarC_Tactics_Types.goal -> Prims.string -> unit FStarC_Tactics_Monad.tac) + = + fun g -> + fun msg -> + FStarC_Tactics_Monad.mk_tac + (fun ps -> + let uvs = + let uu___ = + let uu___1 = FStarC_Tactics_Types.goal_type g in + FStarC_Syntax_Free.uvars uu___1 in + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) (Obj.magic uu___) in + let gs = + FStarC_Compiler_List.map + (FStarC_Tactics_Types.goal_of_ctx_uvar g) uvs in + let gs1 = + FStarC_Compiler_List.filter + (fun g1 -> + let uu___ = FStarC_Tactics_Types.check_goal_solved g1 in + Prims.op_Negation uu___) gs in + let ps' = + { + FStarC_Tactics_Types.main_context = + (ps.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits = + (ps.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = gs1; + FStarC_Tactics_Types.smt_goals = []; + FStarC_Tactics_Types.depth = (ps.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = (ps.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = (ps.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (ps.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = + (ps.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness = + (ps.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg = + (ps.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = + (ps.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency = + (ps.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure = + (ps.FStarC_Tactics_Types.dump_on_failure) + } in + do_dump_ps msg ps'; FStarC_Tactics_Result.Success ((), ps)) +let fail1 : + 'uuuuu . Prims.string -> Prims.string -> 'uuuuu FStarC_Tactics_Monad.tac = + fun msg -> + fun x -> + let uu___ = FStarC_Compiler_Util.format1 msg x in + FStarC_Tactics_Monad.fail uu___ +let fail2 : + 'uuuuu . + Prims.string -> + Prims.string -> Prims.string -> 'uuuuu FStarC_Tactics_Monad.tac + = + fun msg -> + fun x -> + fun y -> + let uu___ = FStarC_Compiler_Util.format2 msg x y in + FStarC_Tactics_Monad.fail uu___ +let fail3 : + 'uuuuu . + Prims.string -> + Prims.string -> + Prims.string -> Prims.string -> 'uuuuu FStarC_Tactics_Monad.tac + = + fun msg -> + fun x -> + fun y -> + fun z -> + let uu___ = FStarC_Compiler_Util.format3 msg x y z in + FStarC_Tactics_Monad.fail uu___ +let fail4 : + 'uuuuu . + Prims.string -> + Prims.string -> + Prims.string -> + Prims.string -> Prims.string -> 'uuuuu FStarC_Tactics_Monad.tac + = + fun msg -> + fun x -> + fun y -> + fun z -> + fun w -> + let uu___ = FStarC_Compiler_Util.format4 msg x y z w in + FStarC_Tactics_Monad.fail uu___ +let (destruct_eq' : + FStarC_Syntax_Syntax.typ -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.term) + FStar_Pervasives_Native.option) + = + fun typ -> + let uu___ = FStarC_Syntax_Formula.destruct_typ_as_formula typ in + match uu___ with + | FStar_Pervasives_Native.Some (FStarC_Syntax_Formula.BaseConn + (l, + uu___1::(e1, FStar_Pervasives_Native.None)::(e2, + FStar_Pervasives_Native.None)::[])) + when + (FStarC_Ident.lid_equals l FStarC_Parser_Const.eq2_lid) || + (FStarC_Ident.lid_equals l FStarC_Parser_Const.c_eq2_lid) + -> FStar_Pervasives_Native.Some (e1, e2) + | uu___1 -> + let uu___2 = FStarC_Syntax_Util.unb2t typ in + (match uu___2 with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some t -> + let uu___3 = FStarC_Syntax_Util.head_and_args t in + (match uu___3 with + | (hd, args) -> + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Syntax_Subst.compress hd in + uu___6.FStarC_Syntax_Syntax.n in + (uu___5, args) in + (match uu___4 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (uu___5, FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = uu___6;_}):: + (e1, FStar_Pervasives_Native.None)::(e2, + FStar_Pervasives_Native.None)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.op_Eq + -> FStar_Pervasives_Native.Some (e1, e2) + | uu___5 -> FStar_Pervasives_Native.None))) +let (destruct_eq : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.term) + FStar_Pervasives_Native.option) + = + fun env1 -> + fun typ -> + let uu___ = destruct_eq' typ in + match uu___ with + | FStar_Pervasives_Native.Some t -> FStar_Pervasives_Native.Some t + | FStar_Pervasives_Native.None -> + let uu___1 = FStarC_Syntax_Util.un_squash typ in + (match uu___1 with + | FStar_Pervasives_Native.Some typ1 -> destruct_eq' typ1 + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None) +let (get_guard_policy : + unit -> FStarC_Tactics_Types.guard_policy FStarC_Tactics_Monad.tac) = + fun uu___ -> + (fun uu___ -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___1 -> + (fun ps -> + let ps = Obj.magic ps in + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac + () (Obj.magic ps.FStarC_Tactics_Types.guard_policy))) + uu___1))) uu___ +let (set_guard_policy : + FStarC_Tactics_Types.guard_policy -> unit FStarC_Tactics_Monad.tac) = + fun pol -> + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___ -> + (fun ps -> + let ps = Obj.magic ps in + Obj.magic + (FStarC_Tactics_Monad.set + { + FStarC_Tactics_Types.main_context = + (ps.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits = + (ps.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = + (ps.FStarC_Tactics_Types.goals); + FStarC_Tactics_Types.smt_goals = + (ps.FStarC_Tactics_Types.smt_goals); + FStarC_Tactics_Types.depth = + (ps.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = + (ps.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = (ps.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (ps.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = pol; + FStarC_Tactics_Types.freshness = + (ps.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg = + (ps.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = + (ps.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency = + (ps.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure = + (ps.FStarC_Tactics_Types.dump_on_failure) + })) uu___) +let with_policy : + 'a . + FStarC_Tactics_Types.guard_policy -> + 'a FStarC_Tactics_Monad.tac -> 'a FStarC_Tactics_Monad.tac + = + fun uu___1 -> + fun uu___ -> + (fun pol -> + fun t -> + let uu___ = get_guard_policy () in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac + () () (Obj.magic uu___) + (fun uu___1 -> + (fun old_pol -> + let old_pol = Obj.magic old_pol in + let uu___1 = set_guard_policy pol in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () uu___1 + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic t) + (fun uu___3 -> + (fun r -> + let r = Obj.magic r in + let uu___3 = + set_guard_policy old_pol in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___3 + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = + Obj.magic uu___4 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () (Obj.magic r))) + uu___4))) uu___3))) + uu___2))) uu___1))) uu___1 uu___ +let (proc_guard_formula : + Prims.string -> + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.should_check_uvar FStar_Pervasives_Native.option + -> + FStarC_Compiler_Range_Type.range -> unit FStarC_Tactics_Monad.tac) + = + fun reason -> + fun e -> + fun f -> + fun sc_opt -> + fun rng -> + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () + () (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___ -> + (fun ps -> + let ps = Obj.magic ps in + match ps.FStarC_Tactics_Types.guard_policy with + | FStarC_Tactics_Types.Drop -> + ((let uu___1 = + let uu___2 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term f in + FStarC_Compiler_Util.format1 + "Tactics admitted guard <%s>\n\n" uu___2 in + FStarC_Errors.log_issue + FStarC_TypeChecker_Env.hasRange_env e + FStarC_Errors_Codes.Warning_TacAdmit () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1)); + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () (Obj.repr ()))) + | FStarC_Tactics_Types.Goal -> + let uu___ = + FStarC_Tactics_Monad.log + (fun uu___1 -> + let uu___2 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term f in + FStarC_Compiler_Util.print2 + "Making guard (%s:%s) into a goal\n" reason + uu___2) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + let uu___2 = + FStarC_Tactics_Monad.goal_of_guard + reason e f sc_opt rng in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___2) + (fun uu___3 -> + (fun g -> + let g = Obj.magic g in + Obj.magic + (FStarC_Tactics_Monad.push_goals + [g])) uu___3))) uu___1)) + | FStarC_Tactics_Types.SMT -> + let uu___ = + FStarC_Tactics_Monad.log + (fun uu___1 -> + let uu___2 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term f in + FStarC_Compiler_Util.print2 + "Pushing guard (%s:%s) as SMT goal\n" reason + uu___2) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + let uu___2 = + FStarC_Tactics_Monad.goal_of_guard + reason e f sc_opt rng in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___2) + (fun uu___3 -> + (fun g -> + let g = Obj.magic g in + Obj.magic + (FStarC_Tactics_Monad.push_smt_goals + [g])) uu___3))) uu___1)) + | FStarC_Tactics_Types.SMTSync -> + let uu___ = + FStarC_Tactics_Monad.log + (fun uu___1 -> + let uu___2 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term f in + FStarC_Compiler_Util.print2 + "Sending guard (%s:%s) to SMT Synchronously\n" + reason uu___2) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + let g = + { + FStarC_TypeChecker_Common.guard_f = + (FStarC_TypeChecker_Common.NonTrivial + f); + FStarC_TypeChecker_Common.deferred_to_tac + = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.implicits) + } in + FStarC_TypeChecker_Rel.force_trivial_guard + e g; + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.repr ()))) uu___1)) + | FStarC_Tactics_Types.Force -> + let uu___ = + FStarC_Tactics_Monad.log + (fun uu___1 -> + let uu___2 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term f in + FStarC_Compiler_Util.print2 + "Forcing guard (%s:%s)\n" reason uu___2) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + let g = + { + FStarC_TypeChecker_Common.guard_f = + (FStarC_TypeChecker_Common.NonTrivial + f); + FStarC_TypeChecker_Common.deferred_to_tac + = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.implicits) + } in + Obj.magic + (try + (fun uu___2 -> + match () with + | () -> + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_TypeChecker_Rel.discharge_guard_no_smt + e g in + FStarC_TypeChecker_Env.is_trivial + uu___5 in + Prims.op_Negation uu___4 in + if uu___3 + then + fail1 + "Forcing the guard failed (%s)" + reason + else + FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () (Obj.repr ())) () + with + | uu___2 -> + let uu___3 = + FStarC_Tactics_Monad.log + (fun uu___4 -> + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + f in + FStarC_Compiler_Util.print1 + "guard = %s\n" uu___5) in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () + () uu___3 + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = + Obj.magic uu___4 in + Obj.magic + (fail1 + "Forcing the guard failed (%s)" + reason)) uu___4))) + uu___1)) + | FStarC_Tactics_Types.ForceSMT -> + let uu___ = + FStarC_Tactics_Monad.log + (fun uu___1 -> + let uu___2 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term f in + FStarC_Compiler_Util.print2 + "Forcing guard WITH SMT (%s:%s)\n" reason + uu___2) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + let g = + { + FStarC_TypeChecker_Common.guard_f = + (FStarC_TypeChecker_Common.NonTrivial + f); + FStarC_TypeChecker_Common.deferred_to_tac + = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.implicits) + } in + Obj.magic + (try + (fun uu___2 -> + match () with + | () -> + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_TypeChecker_Rel.discharge_guard + e g in + FStarC_TypeChecker_Env.is_trivial + uu___5 in + Prims.op_Negation uu___4 in + if uu___3 + then + fail1 + "Forcing the guard failed (%s)" + reason + else + FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () (Obj.repr ())) () + with + | uu___2 -> + let uu___3 = + FStarC_Tactics_Monad.log + (fun uu___4 -> + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + f in + FStarC_Compiler_Util.print1 + "guard = %s\n" uu___5) in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () + () uu___3 + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = + Obj.magic uu___4 in + Obj.magic + (fail1 + "Forcing the guard failed (%s)" + reason)) uu___4))) + uu___1))) uu___) +let (proc_guard' : + Prims.bool -> + Prims.string -> + env -> + FStarC_TypeChecker_Common.guard_t -> + FStarC_Syntax_Syntax.should_check_uvar + FStar_Pervasives_Native.option -> + FStarC_Compiler_Range_Type.range -> unit FStarC_Tactics_Monad.tac) + = + fun simplify -> + fun reason -> + fun e -> + fun g -> + fun sc_opt -> + fun rng -> + let uu___ = + FStarC_Tactics_Monad.log + (fun uu___1 -> + let uu___2 = FStarC_TypeChecker_Rel.guard_to_string e g in + FStarC_Compiler_Util.print2 "Processing guard (%s:%s)\n" + reason uu___2) in + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac + () () uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + let imps = + FStarC_Class_Listlike.to_list + (FStarC_Compiler_CList.listlike_clist ()) + g.FStarC_TypeChecker_Common.implicits in + (match sc_opt with + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Allow_untyped r) -> + FStarC_Compiler_List.iter + (fun imp -> + FStarC_Tactics_Monad.mark_uvar_with_should_check_tag + imp.FStarC_TypeChecker_Common.imp_uvar + (FStarC_Syntax_Syntax.Allow_untyped r)) + imps + | uu___3 -> ()); + (let uu___3 = FStarC_Tactics_Monad.add_implicits imps in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () uu___3 + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + let guard_f = + if simplify + then + let uu___5 = + FStarC_TypeChecker_Rel.simplify_guard + e g in + uu___5.FStarC_TypeChecker_Common.guard_f + else g.FStarC_TypeChecker_Common.guard_f in + match guard_f with + | FStarC_TypeChecker_Common.Trivial -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.repr ())) + | FStarC_TypeChecker_Common.NonTrivial f -> + Obj.magic + (proc_guard_formula reason e f sc_opt + rng)) uu___4)))) uu___1) +let (proc_guard : + Prims.string -> + env -> + FStarC_TypeChecker_Common.guard_t -> + FStarC_Syntax_Syntax.should_check_uvar FStar_Pervasives_Native.option + -> + FStarC_Compiler_Range_Type.range -> unit FStarC_Tactics_Monad.tac) + = proc_guard' true +let (tc_unifier_solved_implicits : + FStarC_TypeChecker_Env.env -> + Prims.bool -> + Prims.bool -> + FStarC_Syntax_Syntax.ctx_uvar Prims.list -> + unit FStarC_Tactics_Monad.tac) + = + fun env1 -> + fun must_tot -> + fun allow_guards -> + fun uvs -> + let aux u = + let dec = + FStarC_Syntax_Unionfind.find_decoration + u.FStarC_Syntax_Syntax.ctx_uvar_head in + let sc = dec.FStarC_Syntax_Syntax.uvar_decoration_should_check in + match sc with + | FStarC_Syntax_Syntax.Allow_untyped uu___ -> + FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () + (Obj.repr ()) + | FStarC_Syntax_Syntax.Already_checked -> + FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () + (Obj.repr ()) + | uu___ -> + let uu___1 = + FStarC_Syntax_Unionfind.find + u.FStarC_Syntax_Syntax.ctx_uvar_head in + (match uu___1 with + | FStar_Pervasives_Native.None -> + FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac + () (Obj.repr ()) + | FStar_Pervasives_Native.Some sol -> + let env2 = + { + FStarC_TypeChecker_Env.solver = + (env1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (u.FStarC_Syntax_Syntax.ctx_uvar_gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env1.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env1.FStarC_TypeChecker_Env.missing_decl) + } in + let must_tot1 = + must_tot && + (Prims.op_Negation + (FStarC_Syntax_Syntax.uu___is_Allow_ghost + dec.FStarC_Syntax_Syntax.uvar_decoration_should_check)) in + let uu___2 = + let uu___3 = FStarC_Syntax_Util.ctx_uvar_typ u in + core_check env2 sol uu___3 must_tot1 in + (match uu___2 with + | FStar_Pervasives.Inl (FStar_Pervasives_Native.None) + -> + (FStarC_Tactics_Monad.mark_uvar_as_already_checked + u; + FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () (Obj.repr ())) + | FStar_Pervasives.Inl (FStar_Pervasives_Native.Some g) + -> + let guard = + { + FStarC_TypeChecker_Common.guard_f = + (FStarC_TypeChecker_Common.NonTrivial g); + FStarC_TypeChecker_Common.deferred_to_tac = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.implicits) + } in + let guard1 = + FStarC_TypeChecker_Rel.simplify_guard env2 guard in + let uu___3 = + ((FStarC_Options.disallow_unification_guards ()) + && (Prims.op_Negation allow_guards)) + && + (FStarC_TypeChecker_Common.uu___is_NonTrivial + guard1.FStarC_TypeChecker_Common.guard_f) in + if uu___3 + then + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Errors_Msg.text + "Could not typecheck unifier solved implicit" in + let uu___7 = + let uu___8 = + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_uvar + u.FStarC_Syntax_Syntax.ctx_uvar_head in + let uu___9 = + let uu___10 = FStarC_Errors_Msg.text "to" in + let uu___11 = + let uu___12 = + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_term sol in + let uu___13 = + FStarC_Errors_Msg.text + "since it produced a guard and guards were not allowed" in + FStarC_Pprint.op_Hat_Slash_Hat uu___12 + uu___13 in + FStarC_Pprint.op_Hat_Slash_Hat uu___10 + uu___11 in + FStarC_Pprint.op_Hat_Slash_Hat uu___8 + uu___9 in + FStarC_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Errors_Msg.text "Guard =" in + let uu___9 = + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_term g in + FStarC_Pprint.op_Hat_Slash_Hat uu___8 + uu___9 in + [uu___7] in + uu___5 :: uu___6 in + FStarC_Tactics_Monad.fail_doc uu___4 + else + (let uu___5 = + proc_guard' false "guard for implicit" env2 + guard1 (FStar_Pervasives_Native.Some sc) + u.FStarC_Syntax_Syntax.ctx_uvar_range in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () uu___5 + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = Obj.magic uu___6 in + FStarC_Tactics_Monad.mark_uvar_as_already_checked + u; + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.repr ()))) uu___6)) + | FStar_Pervasives.Inr failed -> + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Errors_Msg.text + "Could not typecheck unifier solved implicit" in + let uu___6 = + let uu___7 = + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_uvar + u.FStarC_Syntax_Syntax.ctx_uvar_head in + let uu___8 = + let uu___9 = FStarC_Errors_Msg.text "to" in + let uu___10 = + let uu___11 = + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_term sol in + let uu___12 = + let uu___13 = + FStarC_Errors_Msg.text "because" in + let uu___14 = + let uu___15 = + FStarC_TypeChecker_Core.print_error + failed in + FStarC_Pprint.doc_of_string uu___15 in + FStarC_Pprint.op_Hat_Slash_Hat uu___13 + uu___14 in + FStarC_Pprint.op_Hat_Slash_Hat uu___11 + uu___12 in + FStarC_Pprint.op_Hat_Slash_Hat uu___9 + uu___10 in + FStarC_Pprint.op_Hat_Slash_Hat uu___7 uu___8 in + FStarC_Pprint.op_Hat_Slash_Hat uu___5 uu___6 in + [uu___4] in + FStarC_Tactics_Monad.fail_doc uu___3)) in + if env1.FStarC_TypeChecker_Env.phase1 + then + FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () + (Obj.repr ()) + else FStarC_Tactics_Monad.iter_tac aux uvs +type check_unifier_solved_implicits_side = + | Check_none + | Check_left_only + | Check_right_only + | Check_both +let (uu___is_Check_none : check_unifier_solved_implicits_side -> Prims.bool) + = + fun projectee -> match projectee with | Check_none -> true | uu___ -> false +let (uu___is_Check_left_only : + check_unifier_solved_implicits_side -> Prims.bool) = + fun projectee -> + match projectee with | Check_left_only -> true | uu___ -> false +let (uu___is_Check_right_only : + check_unifier_solved_implicits_side -> Prims.bool) = + fun projectee -> + match projectee with | Check_right_only -> true | uu___ -> false +let (uu___is_Check_both : check_unifier_solved_implicits_side -> Prims.bool) + = + fun projectee -> match projectee with | Check_both -> true | uu___ -> false +let (__do_unify_wflags : + Prims.bool -> + Prims.bool -> + Prims.bool -> + check_unifier_solved_implicits_side -> + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> + FStarC_TypeChecker_Common.guard_t + FStar_Pervasives_Native.option FStarC_Tactics_Monad.tac) + = + fun uu___6 -> + fun uu___5 -> + fun uu___4 -> + fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun dbg -> + fun allow_guards -> + fun must_tot -> + fun check_side -> + fun env1 -> + fun t1 -> + fun t2 -> + if dbg + then + (let uu___1 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t1 in + let uu___2 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t2 in + FStarC_Compiler_Util.print2 + "%%%%%%%%do_unify %s =? %s\n" uu___1 + uu___2) + else (); + (let all_uvars = + let uu___1 = + match check_side with + | Check_none -> + Obj.magic + (Obj.repr + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) + ())) + | Check_left_only -> + Obj.magic + (Obj.repr + (FStarC_Syntax_Free.uvars t1)) + | Check_right_only -> + Obj.magic + (Obj.repr + (FStarC_Syntax_Free.uvars t2)) + | Check_both -> + Obj.magic + (Obj.repr + (let uu___2 = + FStarC_Syntax_Free.uvars t1 in + let uu___3 = + FStarC_Syntax_Free.uvars t2 in + FStarC_Class_Setlike.union () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) + (Obj.magic uu___2) + (Obj.magic uu___3))) in + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) + (Obj.magic uu___1) in + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Tactics_Monad.trytac + FStarC_Tactics_Monad.cur_goal in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___3) + (fun uu___4 -> + (fun gopt -> + let gopt = Obj.magic gopt in + Obj.magic + (try + (fun uu___4 -> + (fun uu___4 -> + match () with + | () -> + let res = + if + allow_guards + then + FStarC_TypeChecker_Rel.try_teq + true env1 + t1 t2 + else + FStarC_TypeChecker_Rel.teq_nosmt + env1 t1 + t2 in + (if dbg + then + (let uu___6 + = + FStarC_Common.string_of_option + (FStarC_TypeChecker_Rel.guard_to_string + env1) res in + let uu___7 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t1 in + let uu___8 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t2 in + FStarC_Compiler_Util.print3 + "%%%%%%%%do_unify (RESULT %s) %s =? %s\n" + uu___6 + uu___7 + uu___8) + else (); + (match res + with + | FStar_Pervasives_Native.None + -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + FStar_Pervasives_Native.None)) + | FStar_Pervasives_Native.Some + g -> + let uu___6 + = + tc_unifier_solved_implicits + env1 + must_tot + allow_guards + all_uvars in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___6 + (fun + uu___7 -> + (fun + uu___7 -> + let uu___7 + = + Obj.magic + uu___7 in + let uu___8 + = + let uu___9 + = + FStarC_Class_Listlike.to_list + (FStarC_Compiler_CList.listlike_clist + ()) + g.FStarC_TypeChecker_Common.implicits in + FStarC_Tactics_Monad.add_implicits + uu___9 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___8 + (fun + uu___9 -> + (fun + uu___9 -> + let uu___9 + = + Obj.magic + uu___9 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + (FStar_Pervasives_Native.Some + g)))) + uu___9))) + uu___7))))) + uu___4) () + with + | uu___4 -> + ((fun uu___4 -> + match uu___4 with + | FStarC_Errors.Error + (uu___5, msg, + r, uu___6) + -> + let uu___7 = + FStarC_Tactics_Monad.log + (fun uu___8 + -> + let uu___9 + = + FStarC_Errors_Msg.rendermsg + msg in + let uu___10 + = + FStarC_Class_Show.show + FStarC_Compiler_Range_Ops.showable_range + r in + FStarC_Compiler_Util.print2 + ">> do_unify error, (%s) at (%s)\n" + uu___9 + uu___10) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___7 + (fun + uu___8 -> + (fun + uu___8 -> + let uu___8 + = + Obj.magic + uu___8 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + FStar_Pervasives_Native.None))) + uu___8)))) + uu___4)) uu___4)) in + FStarC_Tactics_Monad.catch uu___2 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + match uu___2 with + | FStar_Pervasives.Inl exn -> + Obj.magic + (Obj.repr + (FStarC_Tactics_Monad.traise + exn)) + | FStar_Pervasives.Inr v -> + Obj.magic + (Obj.repr + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () (Obj.magic v)))) + uu___2)))) uu___6 uu___5 uu___4 + uu___3 uu___2 uu___1 uu___ +let (__do_unify : + Prims.bool -> + Prims.bool -> + check_unifier_solved_implicits_side -> + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> + FStarC_TypeChecker_Common.guard_t + FStar_Pervasives_Native.option FStarC_Tactics_Monad.tac) + = + fun uu___5 -> + fun uu___4 -> + fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun allow_guards -> + fun must_tot -> + fun check_side -> + fun env1 -> + fun t1 -> + fun t2 -> + let uu___ = + FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.repr ()) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + (let uu___3 = + FStarC_Compiler_Effect.op_Bang + dbg_TacUnify in + if uu___3 + then + (FStarC_Options.push (); + (let uu___5 = + FStarC_Options.set_options + "--debug Rel,RelCheck" in + ())) + else ()); + (let uu___3 = + let uu___4 = + FStarC_Compiler_Effect.op_Bang + dbg_TacUnify in + __do_unify_wflags uu___4 + allow_guards must_tot check_side + env1 t1 t2 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () + () (Obj.magic uu___3) + (fun uu___4 -> + (fun r -> + let r = Obj.magic r in + (let uu___5 = + FStarC_Compiler_Effect.op_Bang + dbg_TacUnify in + if uu___5 + then FStarC_Options.pop () + else ()); + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () (Obj.magic r))) + uu___4)))) uu___1))) uu___5 + uu___4 uu___3 uu___2 uu___1 uu___ +let (do_unify_aux : + Prims.bool -> + check_unifier_solved_implicits_side -> + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> Prims.bool FStarC_Tactics_Monad.tac) + = + fun uu___4 -> + fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun must_tot -> + fun check_side -> + fun env1 -> + fun t1 -> + fun t2 -> + let uu___ = + __do_unify false must_tot check_side env1 t1 t2 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___) + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + match uu___1 with + | FStar_Pervasives_Native.None -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic false)) + | FStar_Pervasives_Native.Some g -> + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_Env.is_trivial_guard_formula + g in + Prims.op_Negation uu___4 in + if uu___3 + then + failwith + "internal error: do_unify: guard is not trivial" + else + FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.repr ()) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () + () uu___2 + (fun uu___3 -> + (fun uu___3 -> + let uu___3 = + Obj.magic uu___3 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () (Obj.magic true))) + uu___3))) uu___1))) uu___4 + uu___3 uu___2 uu___1 uu___ +let (do_unify : + Prims.bool -> + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> Prims.bool FStarC_Tactics_Monad.tac) + = + fun must_tot -> + fun env1 -> + fun t1 -> fun t2 -> do_unify_aux must_tot Check_both env1 t1 t2 +let (do_unify_maybe_guards : + Prims.bool -> + Prims.bool -> + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> + FStarC_TypeChecker_Common.guard_t FStar_Pervasives_Native.option + FStarC_Tactics_Monad.tac) + = + fun allow_guards -> + fun must_tot -> + fun env1 -> + fun t1 -> + fun t2 -> __do_unify allow_guards must_tot Check_both env1 t1 t2 +let (do_match : + Prims.bool -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> Prims.bool FStarC_Tactics_Monad.tac) + = + fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun must_tot -> + fun env1 -> + fun t1 -> + fun t2 -> + let uu___ = + FStarC_Tactics_Monad.mk_tac + (fun ps -> + let tx = FStarC_Syntax_Unionfind.new_transaction () in + FStarC_Tactics_Result.Success (tx, ps)) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___) + (fun uu___1 -> + (fun tx -> + let tx = Obj.magic tx in + let uvs1 = FStarC_Syntax_Free.uvars_uncached t1 in + let uu___1 = + do_unify_aux must_tot Check_right_only env1 + t1 t2 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___1) + (fun uu___2 -> + (fun r -> + let r = Obj.magic r in + if r + then + let uvs2 = + FStarC_Syntax_Free.uvars_uncached + t1 in + let uu___2 = + let uu___3 = + FStarC_Class_Setlike.equal () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) + (Obj.magic uvs1) + (Obj.magic uvs2) in + Prims.op_Negation uu___3 in + (if uu___2 + then + (FStarC_Syntax_Unionfind.rollback + tx; + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () (Obj.magic false))) + else + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () (Obj.magic true))) + else + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () (Obj.magic false))) uu___2))) + uu___1))) uu___3 uu___2 uu___1 uu___ +let (do_match_on_lhs : + Prims.bool -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> Prims.bool FStarC_Tactics_Monad.tac) + = + fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun must_tot -> + fun env1 -> + fun t1 -> + fun t2 -> + let uu___ = + FStarC_Tactics_Monad.mk_tac + (fun ps -> + let tx = FStarC_Syntax_Unionfind.new_transaction () in + FStarC_Tactics_Result.Success (tx, ps)) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___) + (fun uu___1 -> + (fun tx -> + let tx = Obj.magic tx in + let uu___1 = destruct_eq env1 t1 in + match uu___1 with + | FStar_Pervasives_Native.None -> + Obj.magic + (Obj.repr + (FStarC_Tactics_Monad.fail + "do_match_on_lhs: not an eq")) + | FStar_Pervasives_Native.Some (lhs, uu___2) -> + Obj.magic + (Obj.repr + (let uvs1 = + FStarC_Syntax_Free.uvars_uncached + lhs in + let uu___3 = + do_unify_aux must_tot + Check_right_only env1 t1 t2 in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () + () (Obj.magic uu___3) + (fun uu___4 -> + (fun r -> + let r = Obj.magic r in + if r + then + let uvs2 = + FStarC_Syntax_Free.uvars_uncached + lhs in + let uu___4 = + let uu___5 = + FStarC_Class_Setlike.equal + () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) + (Obj.magic uvs1) + (Obj.magic uvs2) in + Prims.op_Negation uu___5 in + (if uu___4 + then + (FStarC_Syntax_Unionfind.rollback + tx; + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic false))) + else + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () (Obj.magic true))) + else + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () (Obj.magic false))) + uu___4)))) uu___1))) uu___3 + uu___2 uu___1 uu___ +let (set_solution : + FStarC_Tactics_Types.goal -> + FStarC_Syntax_Syntax.term -> unit FStarC_Tactics_Monad.tac) + = + fun goal -> + fun solution -> + let uu___ = + FStarC_Syntax_Unionfind.find + (goal.FStarC_Tactics_Types.goal_ctx_uvar).FStarC_Syntax_Syntax.ctx_uvar_head in + match uu___ with + | FStar_Pervasives_Native.Some uu___1 -> + let uu___2 = + let uu___3 = FStarC_Tactics_Printing.goal_to_string_verbose goal in + FStarC_Compiler_Util.format1 "Goal %s is already solved" uu___3 in + FStarC_Tactics_Monad.fail uu___2 + | FStar_Pervasives_Native.None -> + (FStarC_Syntax_Unionfind.change + (goal.FStarC_Tactics_Types.goal_ctx_uvar).FStarC_Syntax_Syntax.ctx_uvar_head + solution; + FStarC_Tactics_Monad.mark_goal_implicit_already_checked goal; + FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () + (Obj.repr ())) +let (trysolve : + FStarC_Tactics_Types.goal -> + FStarC_Syntax_Syntax.term -> Prims.bool FStarC_Tactics_Monad.tac) + = + fun goal -> + fun solution -> + let must_tot = true in + let uu___ = FStarC_Tactics_Types.goal_env goal in + let uu___1 = FStarC_Tactics_Types.goal_witness goal in + do_unify must_tot uu___ solution uu___1 +let (solve : + FStarC_Tactics_Types.goal -> + FStarC_Syntax_Syntax.term -> unit FStarC_Tactics_Monad.tac) + = + fun goal -> + fun solution -> + let e = FStarC_Tactics_Types.goal_env goal in + let uu___ = + FStarC_Tactics_Monad.log + (fun uu___1 -> + let uu___2 = + let uu___3 = FStarC_Tactics_Types.goal_witness goal in + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + uu___3 in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + solution in + FStarC_Compiler_Util.print2 "solve %s := %s\n" uu___2 uu___3) in + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + let uu___2 = trysolve goal solution in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () (Obj.magic uu___2) + (fun uu___3 -> + (fun b -> + let b = Obj.magic b in + if b + then + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + FStarC_Tactics_Monad.dismiss + (fun uu___3 -> + (fun uu___3 -> + let uu___3 = Obj.magic uu___3 in + Obj.magic + FStarC_Tactics_Monad.remove_solved_goals) + uu___3)) + else + (let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Tactics_Types.goal_env goal in + ttd uu___7 solution in + let uu___7 = + let uu___8 = + FStarC_Errors_Msg.text "does not solve" in + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Tactics_Types.goal_env goal in + let uu___12 = + FStarC_Tactics_Types.goal_witness + goal in + ttd uu___11 uu___12 in + let uu___11 = + let uu___12 = + FStarC_Errors_Msg.text ":" in + let uu___13 = + let uu___14 = + FStarC_Tactics_Types.goal_env goal in + let uu___15 = + FStarC_Tactics_Types.goal_type goal in + ttd uu___14 uu___15 in + FStarC_Pprint.op_Hat_Slash_Hat uu___12 + uu___13 in + FStarC_Pprint.op_Hat_Slash_Hat uu___10 + uu___11 in + FStarC_Pprint.op_Hat_Slash_Hat uu___8 + uu___9 in + FStarC_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in + [uu___5] in + Obj.magic (FStarC_Tactics_Monad.fail_doc uu___4))) + uu___3))) uu___1) +let (solve' : + FStarC_Tactics_Types.goal -> + FStarC_Syntax_Syntax.term -> unit FStarC_Tactics_Monad.tac) + = + fun goal -> + fun solution -> + let uu___ = set_solution goal solution in + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + FStarC_Tactics_Monad.dismiss + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + Obj.magic FStarC_Tactics_Monad.remove_solved_goals) + uu___2))) uu___1) +let (is_true : FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t -> + let t1 = FStarC_Syntax_Util.unascribe t in + let uu___ = FStarC_Syntax_Util.un_squash t1 in + match uu___ with + | FStar_Pervasives_Native.Some t' -> + let t'1 = FStarC_Syntax_Util.unascribe t' in + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress t'1 in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.true_lid + | uu___2 -> false) + | uu___1 -> false +let (is_false : FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t -> + let uu___ = FStarC_Syntax_Util.un_squash t in + match uu___ with + | FStar_Pervasives_Native.Some t' -> + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress t' in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.false_lid + | uu___2 -> false) + | uu___1 -> false +let meas : + 'a . + Prims.string -> + 'a FStarC_Tactics_Monad.tac -> 'a FStarC_Tactics_Monad.tac + = + fun s -> + fun f -> + FStarC_Tactics_Monad.mk_tac + (fun ps -> + let uu___ = + FStarC_Compiler_Util.record_time + (fun uu___1 -> FStarC_Tactics_Monad.run f ps) in + match uu___ with + | (r, ms) -> + ((let uu___2 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) ms in + FStarC_Compiler_Util.print2 "++ Tactic %s ran in \t\t%sms\n" + s uu___2); + r)) +let (tadmit_t : FStarC_Syntax_Syntax.term -> unit FStarC_Tactics_Monad.tac) = + fun t -> + let uu___ = + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___1 -> + (fun ps -> + let ps = Obj.magic ps in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___1 -> + (fun g -> + let g = Obj.magic g in + (let uu___2 = + let uu___3 = FStarC_Tactics_Types.goal_type g in + FStarC_Class_HasRange.pos + (FStarC_Syntax_Syntax.has_range_syntax ()) + uu___3 in + let uu___3 = + let uu___4 = + FStarC_Errors_Msg.text "Tactics admitted goal." in + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Errors_Msg.text "Goal" in + let uu___8 = + let uu___9 = + FStarC_Tactics_Printing.goal_to_string "" + FStar_Pervasives_Native.None ps g in + FStarC_Pprint.arbitrary_string uu___9 in + FStarC_Pprint.prefix (Prims.of_int (2)) + Prims.int_one uu___7 uu___8 in + [uu___6] in + uu___4 :: uu___5 in + FStarC_Errors.log_issue + FStarC_Class_HasRange.hasRange_range uu___2 + FStarC_Errors_Codes.Warning_TacAdmit () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___3)); + Obj.magic (solve' g t)) uu___1))) uu___1) in + FStarC_Tactics_Monad.wrap_err "tadmit_t" uu___ +let (fresh : unit -> FStarC_BigInt.t FStarC_Tactics_Monad.tac) = + fun uu___ -> + (fun uu___ -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___1 -> + (fun ps -> + let ps = Obj.magic ps in + let n = ps.FStarC_Tactics_Types.freshness in + let ps1 = + { + FStarC_Tactics_Types.main_context = + (ps.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits = + (ps.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = + (ps.FStarC_Tactics_Types.goals); + FStarC_Tactics_Types.smt_goals = + (ps.FStarC_Tactics_Types.smt_goals); + FStarC_Tactics_Types.depth = + (ps.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = + (ps.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = + (ps.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (ps.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = + (ps.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness = (n + Prims.int_one); + FStarC_Tactics_Types.tac_verb_dbg = + (ps.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = + (ps.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency = + (ps.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure = + (ps.FStarC_Tactics_Types.dump_on_failure) + } in + let uu___1 = FStarC_Tactics_Monad.set ps1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () uu___1 + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + let uu___3 = FStarC_BigInt.of_int_fs n in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic uu___3))) uu___2))) uu___1))) + uu___ +let (curms : unit -> FStarC_BigInt.t FStarC_Tactics_Monad.tac) = + fun uu___ -> + (fun uu___ -> + let uu___1 = + let uu___2 = FStarC_Compiler_Util.now_ms () in + FStarC_BigInt.of_int_fs uu___2 in + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () + (Obj.magic uu___1))) uu___ +let (__tc : + env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.typ * + FStarC_TypeChecker_Common.guard_t) FStarC_Tactics_Monad.tac) + = + fun uu___1 -> + fun uu___ -> + (fun e -> + fun t -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac + () () (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___ -> + (fun ps -> + let ps = Obj.magic ps in + let uu___ = + FStarC_Tactics_Monad.log + (fun uu___1 -> + let uu___2 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.print1 "Tac> __tc(%s)\n" + uu___2) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + Obj.magic + (try + (fun uu___2 -> + (fun uu___2 -> + match () with + | () -> + let uu___3 = + FStarC_TypeChecker_TcTerm.typeof_tot_or_gtot_term + e t true in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () (Obj.magic uu___3))) + uu___2) () + with + | FStarC_Errors.Error + (uu___3, msg, uu___4, uu___5) -> + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Errors_Msg.text + "Cannot type" in + let uu___11 = ttd e t in + FStarC_Pprint.prefix + (Prims.of_int (2)) + Prims.int_one uu___10 + uu___11 in + let uu___10 = + let uu___11 = + FStarC_Errors_Msg.text + "in context" in + let uu___12 = + let uu___13 = + FStarC_TypeChecker_Env.all_binders + e in + FStarC_Class_PP.pp + (FStarC_Class_PP.pp_list + FStarC_Syntax_Print.pretty_binder) + uu___13 in + FStarC_Pprint.prefix + (Prims.of_int (2)) + Prims.int_one uu___11 + uu___12 in + FStarC_Pprint.op_Hat_Slash_Hat + uu___9 uu___10 in + [uu___8] in + FStarC_Compiler_List.op_At uu___7 + msg in + FStarC_Tactics_Monad.fail_doc uu___6)) + uu___1))) uu___))) uu___1 uu___ +let (__tc_ghost : + env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.typ * + FStarC_TypeChecker_Common.guard_t) FStarC_Tactics_Monad.tac) + = + fun uu___1 -> + fun uu___ -> + (fun e -> + fun t -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac + () () (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___ -> + (fun ps -> + let ps = Obj.magic ps in + let uu___ = + FStarC_Tactics_Monad.log + (fun uu___1 -> + let uu___2 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.print1 + "Tac> __tc_ghost(%s)\n" uu___2) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + let e1 = + { + FStarC_TypeChecker_Env.solver = + (e.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (e.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (e.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (e.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (e.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (e.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (e.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (e.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (e.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (e.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (e.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (e.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (e.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = []; + FStarC_TypeChecker_Env.top_level = + (e.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (e.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (e.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (e.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (e.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (e.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (e.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (e.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (e.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (e.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (e.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (e.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (e.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (e.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (e.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (e.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (e.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (e.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (e.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (e.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (e.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (e.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (e.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (e.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (e.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (e.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (e.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (e.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (e.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (e.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (e.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (e.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (e.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (e.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (e.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (e.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (e.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (e.FStarC_TypeChecker_Env.missing_decl) + } in + Obj.magic + (try + (fun uu___2 -> + (fun uu___2 -> + match () with + | () -> + let uu___3 = + FStarC_TypeChecker_TcTerm.tc_tot_or_gtot_term + e1 t in + (match uu___3 with + | (t1, lc, g) -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + (t1, + (lc.FStarC_TypeChecker_Common.res_typ), + g))))) uu___2) + () + with + | FStarC_Errors.Error + (uu___3, msg, uu___4, uu___5) -> + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Errors_Msg.text + "Cannot type" in + let uu___11 = ttd e1 t in + FStarC_Pprint.prefix + (Prims.of_int (2)) + Prims.int_one uu___10 + uu___11 in + let uu___10 = + let uu___11 = + FStarC_Errors_Msg.text + "in context" in + let uu___12 = + let uu___13 = + FStarC_TypeChecker_Env.all_binders + e1 in + FStarC_Class_PP.pp + (FStarC_Class_PP.pp_list + FStarC_Syntax_Print.pretty_binder) + uu___13 in + FStarC_Pprint.prefix + (Prims.of_int (2)) + Prims.int_one uu___11 + uu___12 in + FStarC_Pprint.op_Hat_Slash_Hat + uu___9 uu___10 in + [uu___8] in + FStarC_Compiler_List.op_At uu___7 + msg in + FStarC_Tactics_Monad.fail_doc uu___6)) + uu___1))) uu___))) uu___1 uu___ +let (__tc_lax : + env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.lcomp * + FStarC_TypeChecker_Common.guard_t) FStarC_Tactics_Monad.tac) + = + fun uu___1 -> + fun uu___ -> + (fun e -> + fun t -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac + () () (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___ -> + (fun ps -> + let ps = Obj.magic ps in + let uu___ = + FStarC_Tactics_Monad.log + (fun uu___1 -> + let uu___2 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + let uu___3 = + let uu___4 = + FStarC_TypeChecker_Env.all_binders e in + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binder) + uu___4 in + FStarC_Compiler_Util.print2 + "Tac> __tc_lax(%s)(Context:%s)\n" uu___2 + uu___3) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + let e1 = + { + FStarC_TypeChecker_Env.solver = + (e.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (e.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (e.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (e.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (e.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (e.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (e.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (e.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (e.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (e.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (e.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (e.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (e.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (e.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (e.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (e.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (e.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (e.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = true; + FStarC_TypeChecker_Env.lax_universes = + (e.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (e.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (e.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (e.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (e.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (e.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (e.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (e.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (e.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (e.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (e.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (e.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (e.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (e.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (e.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (e.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (e.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (e.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (e.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (e.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (e.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (e.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (e.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (e.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (e.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (e.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (e.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (e.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (e.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (e.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (e.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (e.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (e.FStarC_TypeChecker_Env.missing_decl) + } in + let e2 = + { + FStarC_TypeChecker_Env.solver = + (e1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (e1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (e1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (e1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (e1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (e1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (e1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (e1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (e1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (e1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (e1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (e1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (e1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = []; + FStarC_TypeChecker_Env.top_level = + (e1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (e1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (e1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (e1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (e1.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (e1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (e1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (e1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (e1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (e1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (e1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (e1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (e1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (e1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (e1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (e1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (e1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (e1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (e1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (e1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (e1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (e1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (e1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (e1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (e1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (e1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (e1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (e1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (e1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (e1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (e1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (e1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (e1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (e1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (e1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (e1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (e1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (e1.FStarC_TypeChecker_Env.missing_decl) + } in + Obj.magic + (try + (fun uu___2 -> + (fun uu___2 -> + match () with + | () -> + let uu___3 = + FStarC_TypeChecker_TcTerm.tc_term + e2 t in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () (Obj.magic uu___3))) + uu___2) () + with + | FStarC_Errors.Error + (uu___3, msg, uu___4, uu___5) -> + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Errors_Msg.text + "Cannot type" in + let uu___11 = ttd e2 t in + FStarC_Pprint.prefix + (Prims.of_int (2)) + Prims.int_one uu___10 + uu___11 in + let uu___10 = + let uu___11 = + FStarC_Errors_Msg.text + "in context" in + let uu___12 = + let uu___13 = + FStarC_TypeChecker_Env.all_binders + e2 in + FStarC_Class_PP.pp + (FStarC_Class_PP.pp_list + FStarC_Syntax_Print.pretty_binder) + uu___13 in + FStarC_Pprint.prefix + (Prims.of_int (2)) + Prims.int_one uu___11 + uu___12 in + FStarC_Pprint.op_Hat_Slash_Hat + uu___9 uu___10 in + [uu___8] in + FStarC_Compiler_List.op_At uu___7 + msg in + FStarC_Tactics_Monad.fail_doc uu___6)) + uu___1))) uu___))) uu___1 uu___ +let (tcc : + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.comp FStarC_Tactics_Monad.tac) + = + fun e -> + fun t -> + let uu___ = + let uu___1 = __tc_lax e t in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () + () (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + match uu___2 with + | (uu___3, lc, uu___4) -> + let uu___5 = + let uu___6 = FStarC_TypeChecker_Common.lcomp_comp lc in + FStar_Pervasives_Native.fst uu___6 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic uu___5))) uu___2)) in + FStarC_Tactics_Monad.wrap_err "tcc" uu___ +let (tc : + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.typ FStarC_Tactics_Monad.tac) + = + fun e -> + fun t -> + let uu___ = + let uu___1 = tcc e t in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () + () (Obj.magic uu___1) + (fun uu___2 -> + (fun c -> + let c = Obj.magic c in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic (FStarC_Syntax_Util.comp_result c)))) + uu___2)) in + FStarC_Tactics_Monad.wrap_err "tc" uu___ +let rec map : + 'a . 'a FStarC_Tactics_Monad.tac -> 'a Prims.list FStarC_Tactics_Monad.tac + = + fun uu___ -> + (fun tau -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___ -> + (fun ps -> + let ps = Obj.magic ps in + match ps.FStarC_Tactics_Types.goals with + | [] -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () (Obj.magic [])) + | uu___::uu___1 -> + let uu___2 = + let uu___3 = map tau in + FStarC_Tactics_Monad.divide FStarC_BigInt.one tau + uu___3 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___2) + (fun uu___3 -> + (fun uu___3 -> + let uu___3 = Obj.magic uu___3 in + match uu___3 with + | (h, t) -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic (h :: t)))) uu___3))) + uu___))) uu___ +let (seq : + unit FStarC_Tactics_Monad.tac -> + unit FStarC_Tactics_Monad.tac -> unit FStarC_Tactics_Monad.tac) + = + fun t1 -> + fun t2 -> + let uu___ = + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + t1 + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + let uu___2 = map t2 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () (Obj.magic uu___2) + (fun uu___3 -> + (fun uu___3 -> + let uu___3 = Obj.magic uu___3 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.repr ()))) uu___3))) uu___1) in + FStarC_Tactics_Monad.focus uu___ +let (should_check_goal_uvar : + FStarC_Tactics_Types.goal -> FStarC_Syntax_Syntax.should_check_uvar) = + fun g -> + FStarC_Syntax_Util.ctx_uvar_should_check + g.FStarC_Tactics_Types.goal_ctx_uvar +let (bnorm_and_replace : + FStarC_Tactics_Types.goal -> unit FStarC_Tactics_Monad.tac) = + fun g -> let uu___ = bnorm_goal g in FStarC_Tactics_Monad.replace_cur uu___ +let (bv_to_binding : + FStarC_Syntax_Syntax.bv -> FStarC_Reflection_V2_Data.binding) = + fun bv -> + let uu___ = FStarC_BigInt.of_int_fs bv.FStarC_Syntax_Syntax.index in + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Ident.showable_ident + bv.FStarC_Syntax_Syntax.ppname in + FStarC_Compiler_Sealed.seal uu___2 in + { + FStarC_Reflection_V2_Data.uniq1 = uu___; + FStarC_Reflection_V2_Data.sort3 = (bv.FStarC_Syntax_Syntax.sort); + FStarC_Reflection_V2_Data.ppname3 = uu___1 + } +let (binder_to_binding : + FStarC_Syntax_Syntax.binder -> FStarC_Reflection_V2_Data.binding) = + fun b -> bv_to_binding b.FStarC_Syntax_Syntax.binder_bv +let (binding_to_string : FStarC_Reflection_V2_Data.binding -> Prims.string) = + fun b -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_BigInt.to_int_fs b.FStarC_Reflection_V2_Data.uniq1 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) uu___2 in + Prims.strcat "#" uu___1 in + Prims.strcat + (FStarC_Compiler_Sealed.unseal b.FStarC_Reflection_V2_Data.ppname3) + uu___ +let (binding_to_bv : + FStarC_Reflection_V2_Data.binding -> FStarC_Syntax_Syntax.bv) = + fun b -> + let uu___ = + FStarC_Ident.mk_ident + ((FStarC_Compiler_Sealed.unseal b.FStarC_Reflection_V2_Data.ppname3), + FStarC_Compiler_Range_Type.dummyRange) in + let uu___1 = FStarC_BigInt.to_int_fs b.FStarC_Reflection_V2_Data.uniq1 in + { + FStarC_Syntax_Syntax.ppname = uu___; + FStarC_Syntax_Syntax.index = uu___1; + FStarC_Syntax_Syntax.sort = (b.FStarC_Reflection_V2_Data.sort3) + } +let (binding_to_binder : + FStarC_Reflection_V2_Data.binding -> FStarC_Syntax_Syntax.binder) = + fun b -> let bv = binding_to_bv b in FStarC_Syntax_Syntax.mk_binder bv +let (arrow_one : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + (FStarC_TypeChecker_Env.env * FStarC_Syntax_Syntax.binder * + FStarC_Syntax_Syntax.comp) FStar_Pervasives_Native.option) + = + fun env1 -> + fun t -> + let uu___ = FStarC_Syntax_Util.arrow_one_ln t in + match uu___ with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (b, c) -> + let uu___1 = + FStarC_TypeChecker_Core.open_binders_in_comp env1 [b] c in + (match uu___1 with + | (env2, b1::[], c1) -> + FStar_Pervasives_Native.Some (env2, b1, c1)) +let (arrow_one_whnf : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + (FStarC_TypeChecker_Env.env * FStarC_Syntax_Syntax.binder * + FStarC_Syntax_Syntax.comp) FStar_Pervasives_Native.option) + = + fun env1 -> + fun t -> + let uu___ = arrow_one env1 t in + match uu___ with + | FStar_Pervasives_Native.Some r -> FStar_Pervasives_Native.Some r + | FStar_Pervasives_Native.None -> + let uu___1 = whnf env1 t in arrow_one env1 uu___1 +let (intro : + unit -> FStarC_Reflection_V2_Data.binding FStarC_Tactics_Monad.tac) = + fun uu___ -> + let uu___1 = + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___2 -> + (fun goal -> + let goal = Obj.magic goal in + let uu___2 = + let uu___3 = FStarC_Tactics_Types.goal_env goal in + let uu___4 = FStarC_Tactics_Types.goal_type goal in + arrow_one_whnf uu___3 uu___4 in + match uu___2 with + | FStar_Pervasives_Native.Some (uu___3, uu___4, c) when + let uu___5 = FStarC_Syntax_Util.is_total_comp c in + Prims.op_Negation uu___5 -> + Obj.magic + (Obj.repr + (FStarC_Tactics_Monad.fail "Codomain is effectful")) + | FStar_Pervasives_Native.Some (env', b, c) -> + Obj.magic + (Obj.repr + (let typ' = FStarC_Syntax_Util.comp_result c in + let uu___3 = + let uu___4 = + let uu___5 = should_check_goal_uvar goal in + FStar_Pervasives_Native.Some uu___5 in + let uu___5 = + FStarC_Tactics_Monad.goal_typedness_deps goal in + FStarC_Tactics_Monad.new_uvar "intro" env' typ' + uu___4 uu___5 (rangeof goal) in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___3) + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + match uu___4 with + | (body, ctx_uvar) -> + let sol = + let uu___5 = + let uu___6 = + FStarC_Syntax_Util.residual_comp_of_comp + c in + FStar_Pervasives_Native.Some + uu___6 in + FStarC_Syntax_Util.abs [b] body + uu___5 in + let uu___5 = set_solution goal sol in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () + () uu___5 + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = + Obj.magic uu___6 in + let g = + FStarC_Tactics_Types.mk_goal + env' ctx_uvar + goal.FStarC_Tactics_Types.opts + goal.FStarC_Tactics_Types.is_guard + goal.FStarC_Tactics_Types.label in + let uu___7 = + FStarC_Tactics_Monad.replace_cur + g in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___7 + (fun uu___8 -> + (fun uu___8 -> + let uu___8 = + Obj.magic + uu___8 in + let uu___9 = + binder_to_binding + b in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + uu___9))) + uu___8))) uu___6))) + uu___4))) + | FStar_Pervasives_Native.None -> + Obj.magic + (Obj.repr + (let uu___3 = + let uu___4 = FStarC_Tactics_Types.goal_env goal in + let uu___5 = FStarC_Tactics_Types.goal_type goal in + tts uu___4 uu___5 in + fail1 "goal is not an arrow (%s)" uu___3))) uu___2)) in + FStarC_Tactics_Monad.wrap_err "intro" uu___1 +let (intros : + FStarC_BigInt.t -> + FStarC_Reflection_V2_Data.binding Prims.list FStarC_Tactics_Monad.tac) + = + fun max -> + let uu___ = + let max1 = FStarC_BigInt.to_int_fs max in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___1 -> + (fun goal -> + let goal = Obj.magic goal in + let uu___1 = + let uu___2 = FStarC_Tactics_Types.goal_type goal in + FStarC_Syntax_Util.arrow_formals_comp_ln uu___2 in + match uu___1 with + | (bs, c) -> + let uu___2 = + if max1 >= Prims.int_zero + then + let uu___3 = FStarC_Compiler_List.splitAt max1 bs in + match uu___3 with + | (bs0, bs1) -> + let c1 = + let uu___4 = FStarC_Syntax_Util.arrow_ln bs1 c in + FStarC_Syntax_Syntax.mk_Total uu___4 in + (bs0, c1) + else (bs, c) in + (match uu___2 with + | (bs1, c1) -> + let uu___3 = + let uu___4 = FStarC_Tactics_Types.goal_env goal in + FStarC_TypeChecker_Core.open_binders_in_comp + uu___4 bs1 c1 in + (match uu___3 with + | (env', bs2, c2) -> + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Util.is_pure_comp c2 in + Prims.op_Negation uu___6 in + if uu___5 + then + let uu___6 = + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_comp c2 in + Prims.strcat "Codomain is effectful: " + uu___7 in + FStarC_Tactics_Monad.fail uu___6 + else + FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.repr ()) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + uu___4 + (fun uu___5 -> + (fun uu___5 -> + let uu___5 = Obj.magic uu___5 in + let typ' = + FStarC_Syntax_Util.comp_result c2 in + let uu___6 = + let uu___7 = + let uu___8 = + should_check_goal_uvar goal in + FStar_Pervasives_Native.Some + uu___8 in + let uu___8 = + FStarC_Tactics_Monad.goal_typedness_deps + goal in + FStarC_Tactics_Monad.new_uvar + "intros" env' typ' uu___7 + uu___8 (rangeof goal) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () (Obj.magic uu___6) + (fun uu___7 -> + (fun uu___7 -> + let uu___7 = + Obj.magic uu___7 in + match uu___7 with + | (body, ctx_uvar) -> + let sol = + let uu___8 = + let uu___9 = + FStarC_Syntax_Util.residual_comp_of_comp + c2 in + FStar_Pervasives_Native.Some + uu___9 in + FStarC_Syntax_Util.abs + bs2 body uu___8 in + let uu___8 = + set_solution goal + sol in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___8 + (fun uu___9 -> + (fun uu___9 + -> + let uu___9 + = + Obj.magic + uu___9 in + let g = + FStarC_Tactics_Types.mk_goal + env' + ctx_uvar + goal.FStarC_Tactics_Types.opts + goal.FStarC_Tactics_Types.is_guard + goal.FStarC_Tactics_Types.label in + let uu___10 + = + FStarC_Tactics_Monad.replace_cur + g in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___10 + (fun + uu___11 + -> + (fun + uu___11 + -> + let uu___11 + = + Obj.magic + uu___11 in + let uu___12 + = + FStarC_Compiler_List.map + binder_to_binding + bs2 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + uu___12))) + uu___11))) + uu___9))) + uu___7))) uu___5))))) + uu___1)) in + FStarC_Tactics_Monad.wrap_err "intros" uu___ +let (intro_rec : + unit -> + (FStarC_Reflection_V2_Data.binding * FStarC_Reflection_V2_Data.binding) + FStarC_Tactics_Monad.tac) + = + fun uu___ -> + (fun uu___ -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___1 -> + (fun goal -> + let goal = Obj.magic goal in + FStarC_Compiler_Util.print_string + "WARNING (intro_rec): calling this is known to cause normalizer loops\n"; + FStarC_Compiler_Util.print_string + "WARNING (intro_rec): proceed at your own risk...\n"; + (let uu___3 = + let uu___4 = FStarC_Tactics_Types.goal_env goal in + let uu___5 = + let uu___6 = FStarC_Tactics_Types.goal_env goal in + let uu___7 = FStarC_Tactics_Types.goal_type goal in + whnf uu___6 uu___7 in + arrow_one uu___4 uu___5 in + match uu___3 with + | FStar_Pervasives_Native.Some (env', b, c) -> + Obj.magic + (Obj.repr + (let uu___4 = + let uu___5 = + FStarC_Syntax_Util.is_total_comp c in + Prims.op_Negation uu___5 in + if uu___4 + then + Obj.repr + (FStarC_Tactics_Monad.fail + "Codomain is effectful") + else + Obj.repr + (let bv = + let uu___6 = + FStarC_Tactics_Types.goal_type goal in + FStarC_Syntax_Syntax.gen_bv "__recf" + FStar_Pervasives_Native.None uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + should_check_goal_uvar goal in + FStar_Pervasives_Native.Some uu___8 in + let uu___8 = + FStarC_Tactics_Monad.goal_typedness_deps + goal in + FStarC_Tactics_Monad.new_uvar "intro_rec" + env' (FStarC_Syntax_Util.comp_result c) + uu___7 uu___8 (rangeof goal) in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___6) + (fun uu___7 -> + (fun uu___7 -> + let uu___7 = Obj.magic uu___7 in + match uu___7 with + | (u, ctx_uvar_u) -> + let lb = + let uu___8 = + FStarC_Tactics_Types.goal_type + goal in + let uu___9 = + FStarC_Syntax_Util.abs + [b] u + FStar_Pervasives_Native.None in + FStarC_Syntax_Util.mk_letbinding + (FStar_Pervasives.Inl bv) + [] uu___8 + FStarC_Parser_Const.effect_Tot_lid + uu___9 [] + FStarC_Compiler_Range_Type.dummyRange in + let body = + FStarC_Syntax_Syntax.bv_to_name + bv in + let uu___8 = + FStarC_Syntax_Subst.close_let_rec + [lb] body in + (match uu___8 with + | (lbs, body1) -> + let tm = + let uu___9 = + let uu___10 = + FStarC_Tactics_Types.goal_witness + goal in + uu___10.FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs + = (true, lbs); + FStarC_Syntax_Syntax.body1 + = body1 + }) uu___9 in + let uu___9 = + set_solution goal tm in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___9 + (fun uu___10 -> + (fun uu___10 -> + let uu___10 = + Obj.magic + uu___10 in + let uu___11 = + bnorm_and_replace + { + FStarC_Tactics_Types.goal_main_env + = + (goal.FStarC_Tactics_Types.goal_main_env); + FStarC_Tactics_Types.goal_ctx_uvar + = + ctx_uvar_u; + FStarC_Tactics_Types.opts + = + (goal.FStarC_Tactics_Types.opts); + FStarC_Tactics_Types.is_guard + = + (goal.FStarC_Tactics_Types.is_guard); + FStarC_Tactics_Types.label + = + (goal.FStarC_Tactics_Types.label) + } in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___11 + (fun + uu___12 + -> + (fun + uu___12 + -> + let uu___12 + = + Obj.magic + uu___12 in + let uu___13 + = + let uu___14 + = + let uu___15 + = + FStarC_Syntax_Syntax.mk_binder + bv in + binder_to_binding + uu___15 in + let uu___15 + = + binder_to_binding + b in + (uu___14, + uu___15) in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + uu___13))) + uu___12))) + uu___10)))) + uu___7)))) + | FStar_Pervasives_Native.None -> + Obj.magic + (Obj.repr + (let uu___4 = + let uu___5 = + FStarC_Tactics_Types.goal_env goal in + let uu___6 = + FStarC_Tactics_Types.goal_type goal in + tts uu___5 uu___6 in + fail1 "intro_rec: goal is not an arrow (%s)" + uu___4)))) uu___1))) uu___ +let (norm : + FStar_Pervasives.norm_step Prims.list -> unit FStarC_Tactics_Monad.tac) = + fun s -> + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___ -> + (fun goal -> + let goal = Obj.magic goal in + let uu___ = + FStarC_Tactics_Monad.if_verbose + (fun uu___1 -> + let uu___2 = + let uu___3 = FStarC_Tactics_Types.goal_witness goal in + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + uu___3 in + FStarC_Compiler_Util.print1 "norm: witness = %s\n" uu___2) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac + () () uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + let steps = + let uu___2 = + FStarC_TypeChecker_Cfg.translate_norm_steps s in + FStarC_Compiler_List.op_At + [FStarC_TypeChecker_Env.Reify; + FStarC_TypeChecker_Env.DontUnfoldAttr + [FStarC_Parser_Const.tac_opaque_attr]] uu___2 in + let t = + let uu___2 = FStarC_Tactics_Types.goal_env goal in + let uu___3 = FStarC_Tactics_Types.goal_type goal in + normalize steps uu___2 uu___3 in + let uu___2 = + FStarC_Tactics_Monad.goal_with_type goal t in + Obj.magic (FStarC_Tactics_Monad.replace_cur uu___2)) + uu___1))) uu___) +let (__norm_term_env : + Prims.bool -> + env -> + FStar_Pervasives.norm_step Prims.list -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term FStarC_Tactics_Monad.tac) + = + fun well_typed -> + fun e -> + fun s -> + fun t -> + let uu___ = + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac + () () (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___1 -> + (fun ps -> + let ps = Obj.magic ps in + let uu___1 = + FStarC_Tactics_Monad.if_verbose + (fun uu___2 -> + let uu___3 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.print1 + "norm_term_env: t = %s\n" uu___3) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () uu___1 + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + let uu___3 = + if well_typed + then + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic t)) + else + (let uu___5 = __tc_lax e t in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () + () (Obj.magic uu___5) + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = + Obj.magic uu___6 in + match uu___6 with + | (t1, uu___7, uu___8) -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () (Obj.magic t1))) + uu___6))) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___3) + (fun uu___4 -> + (fun t1 -> + let t1 = Obj.magic t1 in + let steps = + let uu___4 = + FStarC_TypeChecker_Cfg.translate_norm_steps + s in + FStarC_Compiler_List.op_At + [FStarC_TypeChecker_Env.Reify; + FStarC_TypeChecker_Env.DontUnfoldAttr + [FStarC_Parser_Const.tac_opaque_attr]] + uu___4 in + let t2 = + normalize steps + ps.FStarC_Tactics_Types.main_context + t1 in + let uu___4 = + FStarC_Tactics_Monad.if_verbose + (fun uu___5 -> + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t2 in + FStarC_Compiler_Util.print1 + "norm_term_env: t' = %s\n" + uu___6) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___4 + (fun uu___5 -> + (fun uu___5 -> + let uu___5 = + Obj.magic uu___5 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic t2))) + uu___5))) uu___4))) + uu___2))) uu___1)) in + FStarC_Tactics_Monad.wrap_err "norm_term" uu___ +let (norm_term_env : + env -> + FStar_Pervasives.norm_step Prims.list -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term FStarC_Tactics_Monad.tac) + = fun e -> fun s -> fun t -> __norm_term_env false e s t +let (refl_norm_well_typed_term : + env -> + FStar_Pervasives.norm_step Prims.list -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term FStarC_Tactics_Monad.tac) + = fun e -> fun s -> fun t -> __norm_term_env true e s t +let (refine_intro : unit -> unit FStarC_Tactics_Monad.tac) = + fun uu___ -> + let uu___1 = + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___2 -> + (fun g -> + let g = Obj.magic g in + let uu___2 = + let uu___3 = FStarC_Tactics_Types.goal_env g in + let uu___4 = FStarC_Tactics_Types.goal_type g in + FStarC_TypeChecker_Rel.base_and_refinement uu___3 uu___4 in + match uu___2 with + | (uu___3, FStar_Pervasives_Native.None) -> + Obj.magic (FStarC_Tactics_Monad.fail "not a refinement") + | (t, FStar_Pervasives_Native.Some (bv, phi)) -> + (FStarC_Tactics_Monad.mark_goal_implicit_already_checked g; + (let g1 = FStarC_Tactics_Monad.goal_with_type g t in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Syntax_Syntax.mk_binder bv in + [uu___7] in + FStarC_Syntax_Subst.open_term uu___6 phi in + match uu___5 with + | (bvs, phi1) -> + let uu___6 = + let uu___7 = FStarC_Compiler_List.hd bvs in + uu___7.FStarC_Syntax_Syntax.binder_bv in + (uu___6, phi1) in + match uu___4 with + | (bv1, phi1) -> + let uu___5 = + let uu___6 = FStarC_Tactics_Types.goal_env g in + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Tactics_Types.goal_witness g in + (bv1, uu___11) in + FStarC_Syntax_Syntax.NT uu___10 in + [uu___9] in + FStarC_Syntax_Subst.subst uu___8 phi1 in + let uu___8 = + let uu___9 = should_check_goal_uvar g in + FStar_Pervasives_Native.Some uu___9 in + FStarC_Tactics_Monad.mk_irrelevant_goal + "refine_intro refinement" uu___6 uu___7 uu___8 + (rangeof g) g.FStarC_Tactics_Types.opts + g.FStarC_Tactics_Types.label in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___5) + (fun uu___6 -> + (fun g2 -> + let g2 = Obj.magic g2 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + FStarC_Tactics_Monad.dismiss + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = Obj.magic uu___6 in + Obj.magic + (FStarC_Tactics_Monad.add_goals + [g1; g2])) uu___6))) + uu___6))))) uu___2) in + FStarC_Tactics_Monad.wrap_err "refine_intro" uu___1 +let (__exact_now : + Prims.bool -> FStarC_Syntax_Syntax.term -> unit FStarC_Tactics_Monad.tac) = + fun set_expected_typ -> + fun t -> + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___ -> + (fun goal -> + let goal = Obj.magic goal in + let env1 = + if set_expected_typ + then + let uu___ = FStarC_Tactics_Types.goal_env goal in + let uu___1 = FStarC_Tactics_Types.goal_type goal in + FStarC_TypeChecker_Env.set_expected_typ uu___ uu___1 + else FStarC_Tactics_Types.goal_env goal in + let env2 = + { + FStarC_TypeChecker_Env.solver = + (env1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env1.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = false; + FStarC_TypeChecker_Env.intactics = + (env1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env1.FStarC_TypeChecker_Env.missing_decl) + } in + let uu___ = __tc env2 t in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () (Obj.magic uu___) + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + match uu___1 with + | (t1, typ, guard) -> + let uu___2 = + FStarC_Tactics_Monad.if_verbose + (fun uu___3 -> + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term typ in + let uu___5 = + let uu___6 = + FStarC_Tactics_Types.goal_env goal in + FStarC_TypeChecker_Rel.guard_to_string + uu___6 guard in + FStarC_Compiler_Util.print2 + "__exact_now: got type %s\n__exact_now: and guard %s\n" + uu___4 uu___5) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () uu___2 + (fun uu___3 -> + (fun uu___3 -> + let uu___3 = Obj.magic uu___3 in + let uu___4 = + let uu___5 = + FStarC_Tactics_Types.goal_env + goal in + let uu___6 = + let uu___7 = + should_check_goal_uvar goal in + FStar_Pervasives_Native.Some + uu___7 in + proc_guard "__exact typing" uu___5 + guard uu___6 (rangeof goal) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___4 + (fun uu___5 -> + (fun uu___5 -> + let uu___5 = + Obj.magic uu___5 in + let uu___6 = + FStarC_Tactics_Monad.if_verbose + (fun uu___7 -> + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + typ in + let uu___9 = + let uu___10 = + FStarC_Tactics_Types.goal_type + goal in + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + uu___10 in + FStarC_Compiler_Util.print2 + "__exact_now: unifying %s and %s\n" + uu___8 uu___9) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___6 + (fun uu___7 -> + (fun uu___7 -> + let uu___7 = + Obj.magic + uu___7 in + let uu___8 = + let uu___9 = + FStarC_Tactics_Types.goal_env + goal in + let uu___10 = + FStarC_Tactics_Types.goal_type + goal in + do_unify true + uu___9 typ + uu___10 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic + uu___8) + (fun + uu___9 -> + (fun b -> + let b = + Obj.magic + b in + if b + then + (FStarC_Tactics_Monad.mark_goal_implicit_already_checked + goal; + Obj.magic + (solve + goal t1)) + else + (let uu___10 + = + let uu___11 + = + let uu___12 + = + FStarC_Tactics_Types.goal_env + goal in + ttd + uu___12 in + let uu___12 + = + FStarC_Tactics_Types.goal_type + goal in + FStarC_TypeChecker_Err.print_discrepancy + uu___11 + typ + uu___12 in + match uu___10 + with + | + (typ1, + goalt) -> + let uu___11 + = + let uu___12 + = + let uu___13 + = + let uu___14 + = + FStarC_Errors_Msg.text + "Term" in + let uu___15 + = + let uu___16 + = + FStarC_Tactics_Types.goal_env + goal in + ttd + uu___16 + t1 in + FStarC_Pprint.prefix + (Prims.of_int (2)) + Prims.int_one + uu___14 + uu___15 in + let uu___14 + = + let uu___15 + = + let uu___16 + = + FStarC_Errors_Msg.text + "of type" in + FStarC_Pprint.prefix + (Prims.of_int (2)) + Prims.int_one + uu___16 + typ1 in + let uu___16 + = + let uu___17 + = + FStarC_Errors_Msg.text + "does not exactly solve the goal" in + FStarC_Pprint.prefix + (Prims.of_int (2)) + Prims.int_one + uu___17 + goalt in + FStarC_Pprint.op_Hat_Slash_Hat + uu___15 + uu___16 in + FStarC_Pprint.op_Hat_Slash_Hat + uu___13 + uu___14 in + [uu___12] in + Obj.magic + (FStarC_Tactics_Monad.fail_doc + uu___11))) + uu___9))) + uu___7))) uu___5))) + uu___3))) uu___1))) uu___) +let (t_exact : + Prims.bool -> + Prims.bool -> FStarC_Syntax_Syntax.term -> unit FStarC_Tactics_Monad.tac) + = + fun try_refine -> + fun set_expected_typ -> + fun tm -> + let uu___ = + let uu___1 = + FStarC_Tactics_Monad.if_verbose + (fun uu___2 -> + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + tm in + FStarC_Compiler_Util.print1 "t_exact: tm = %s\n" uu___3) in + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + uu___1 + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + let uu___3 = + let uu___4 = __exact_now set_expected_typ tm in + FStarC_Tactics_Monad.catch uu___4 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___3) + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + match uu___4 with + | FStar_Pervasives.Inr r -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.repr ())) + | FStar_Pervasives.Inl e when + Prims.op_Negation try_refine -> + Obj.magic (FStarC_Tactics_Monad.traise e) + | FStar_Pervasives.Inl e -> + let uu___5 = + FStarC_Tactics_Monad.if_verbose + (fun uu___6 -> + FStarC_Compiler_Util.print_string + "__exact_now failed, trying refine...\n") in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + uu___5 + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = Obj.magic uu___6 in + let uu___7 = + let uu___8 = + let uu___9 = + norm + [FStar_Pervasives.Delta] in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___9 + (fun uu___10 -> + (fun uu___10 -> + let uu___10 = + Obj.magic uu___10 in + let uu___11 = + refine_intro () in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___11 + (fun uu___12 -> + (fun uu___12 + -> + let uu___12 + = + Obj.magic + uu___12 in + Obj.magic + (__exact_now + set_expected_typ + tm)) + uu___12))) + uu___10) in + FStarC_Tactics_Monad.catch + uu___8 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () (Obj.magic uu___7) + (fun uu___8 -> + (fun uu___8 -> + let uu___8 = + Obj.magic uu___8 in + match uu___8 with + | FStar_Pervasives.Inr + r -> + let uu___9 = + FStarC_Tactics_Monad.if_verbose + (fun uu___10 + -> + FStarC_Compiler_Util.print_string + "__exact_now: failed after refining too\n") in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___9 + (fun uu___10 + -> + (fun + uu___10 + -> + let uu___10 + = + Obj.magic + uu___10 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.repr + ()))) + uu___10)) + | FStar_Pervasives.Inl + uu___9 -> + let uu___10 = + FStarC_Tactics_Monad.if_verbose + (fun uu___11 + -> + FStarC_Compiler_Util.print_string + "__exact_now: was not a refinement\n") in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___10 + (fun uu___11 + -> + (fun + uu___11 + -> + let uu___11 + = + Obj.magic + uu___11 in + Obj.magic + (FStarC_Tactics_Monad.traise + e)) + uu___11))) + uu___8))) uu___6))) + uu___4))) uu___2) in + FStarC_Tactics_Monad.wrap_err "exact" uu___ +let (try_unify_by_application : + FStarC_Syntax_Syntax.should_check_uvar FStar_Pervasives_Native.option -> + Prims.bool -> + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> + FStarC_Compiler_Range_Type.range -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.aqual * + FStarC_Syntax_Syntax.ctx_uvar) Prims.list + FStarC_Tactics_Monad.tac) + = + fun should_check -> + fun only_match -> + fun e -> + fun ty1 -> + fun ty2 -> + fun rng -> + let f = if only_match then do_match else do_unify in + let must_tot = true in + let rec aux uu___2 uu___1 uu___ = + (fun acc -> + fun typedness_deps -> + fun ty11 -> + let uu___ = f must_tot e ty2 ty11 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___) + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + if uu___1 + then + Obj.magic + (Obj.repr + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic acc))) + else + Obj.magic + (Obj.repr + (let uu___2 = + FStarC_Syntax_Util.arrow_one ty11 in + match uu___2 with + | FStar_Pervasives_Native.None -> + Obj.repr + (let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Errors_Msg.text + "Could not instantiate" in + let uu___7 = + ttd e ty11 in + FStarC_Pprint.prefix + (Prims.of_int (2)) + Prims.int_one uu___6 + uu___7 in + let uu___6 = + let uu___7 = + FStarC_Errors_Msg.text + "to" in + let uu___8 = ttd e ty2 in + FStarC_Pprint.prefix + (Prims.of_int (2)) + Prims.int_one uu___7 + uu___8 in + FStarC_Pprint.op_Hat_Slash_Hat + uu___5 uu___6 in + [uu___4] in + FStarC_Tactics_Monad.fail_doc + uu___3) + | FStar_Pervasives_Native.Some + (b, c) -> + Obj.repr + (let uu___3 = + let uu___4 = + FStarC_Syntax_Util.is_total_comp + c in + Prims.op_Negation uu___4 in + if uu___3 + then + Obj.repr + (FStarC_Tactics_Monad.fail + "Codomain is effectful") + else + Obj.repr + (let uu___5 = + FStarC_Tactics_Monad.new_uvar + "apply arg" e + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort + should_check + typedness_deps rng in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic uu___5) + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = + Obj.magic + uu___6 in + match uu___6 + with + | (uvt, uv) -> + let uu___7 + = + FStarC_Tactics_Monad.if_verbose + (fun + uu___8 -> + let uu___9 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_ctxu + uv in + FStarC_Compiler_Util.print1 + "t_apply: generated uvar %s\n" + uu___9) in + Obj.magic + ( + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___7 + (fun + uu___8 -> + (fun + uu___8 -> + let uu___8 + = + Obj.magic + uu___8 in + let typ = + FStarC_Syntax_Util.comp_result + c in + let typ' + = + FStarC_Syntax_Subst.subst + [ + FStarC_Syntax_Syntax.NT + ((b.FStarC_Syntax_Syntax.binder_bv), + uvt)] typ in + let uu___9 + = + let uu___10 + = + let uu___11 + = + FStarC_Syntax_Util.aqual_of_binder + b in + (uvt, + uu___11, + uv) in + uu___10 + :: acc in + Obj.magic + (aux + uu___9 + (uv :: + typedness_deps) + typ')) + uu___8))) + uu___6)))))) + uu___1))) uu___2 uu___1 uu___ in + aux [] [] ty1 +let (apply_implicits_as_goals : + FStarC_TypeChecker_Env.env -> + FStarC_Tactics_Types.goal FStar_Pervasives_Native.option -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.ctx_uvar) Prims.list + -> + FStarC_Tactics_Types.goal Prims.list Prims.list + FStarC_Tactics_Monad.tac) + = + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun env1 -> + fun gl -> + fun imps -> + let one_implicit_as_goal uu___ = + (fun uu___ -> + match uu___ with + | (term, ctx_uvar) -> + let uu___1 = FStarC_Syntax_Util.head_and_args term in + (match uu___1 with + | (hd, uu___2) -> + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.compress hd in + uu___4.FStarC_Syntax_Syntax.n in + (match uu___3 with + | FStarC_Syntax_Syntax.Tm_uvar + (ctx_uvar1, uu___4) -> + let gl1 = + match gl with + | FStar_Pervasives_Native.None -> + let uu___5 = FStarC_Options.peek () in + FStarC_Tactics_Types.mk_goal env1 + ctx_uvar1 uu___5 true + "goal for unsolved implicit" + | FStar_Pervasives_Native.Some gl2 -> + { + FStarC_Tactics_Types.goal_main_env + = + (gl2.FStarC_Tactics_Types.goal_main_env); + FStarC_Tactics_Types.goal_ctx_uvar + = ctx_uvar1; + FStarC_Tactics_Types.opts = + (gl2.FStarC_Tactics_Types.opts); + FStarC_Tactics_Types.is_guard = + (gl2.FStarC_Tactics_Types.is_guard); + FStarC_Tactics_Types.label = + (gl2.FStarC_Tactics_Types.label) + } in + let gl2 = bnorm_goal gl1 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic [gl2])) + | uu___4 -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic []))))) uu___ in + Obj.magic + (FStarC_Class_Monad.mapM FStarC_Tactics_Monad.monad_tac () + () (fun uu___ -> (Obj.magic one_implicit_as_goal) uu___) + (Obj.magic imps))) uu___2 uu___1 uu___ +let (t_apply : + Prims.bool -> + Prims.bool -> + Prims.bool -> + FStarC_Syntax_Syntax.term -> unit FStarC_Tactics_Monad.tac) + = + fun uopt -> + fun only_match -> + fun tc_resolved_uvars -> + fun tm -> + let uu___ = + let tc_resolved_uvars1 = true in + let uu___1 = + FStarC_Tactics_Monad.if_verbose + (fun uu___2 -> + let uu___3 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) uopt in + let uu___4 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) only_match in + let uu___5 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + tc_resolved_uvars1 in + let uu___6 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + tm in + FStarC_Compiler_Util.print4 + "t_apply: uopt %s, only_match %s, tc_resolved_uvars %s, tm = %s\n" + uu___3 uu___4 uu___5 uu___6) in + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () + () uu___1 + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___3 -> + (fun ps -> + let ps = Obj.magic ps in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___3 -> + (fun goal -> + let goal = Obj.magic goal in + let e = + FStarC_Tactics_Types.goal_env + goal in + let should_check = + should_check_goal_uvar goal in + FStarC_Tactics_Monad.register_goal + goal; + (let uu___4 = __tc e tm in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () (Obj.magic uu___4) + (fun uu___5 -> + (fun uu___5 -> + let uu___5 = + Obj.magic uu___5 in + match uu___5 with + | (tm1, typ, guard) -> + let uu___6 = + FStarC_Tactics_Monad.if_verbose + (fun uu___7 -> + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + tm1 in + let uu___9 = + FStarC_Tactics_Printing.goal_to_string_verbose + goal in + let uu___10 + = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binding) + e.FStarC_TypeChecker_Env.gamma in + let uu___11 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + typ in + let uu___12 + = + FStarC_TypeChecker_Rel.guard_to_string + e guard in + FStarC_Compiler_Util.print5 + "t_apply: tm = %s\nt_apply: goal = %s\nenv.gamma=%s\ntyp=%s\nguard=%s\n" + uu___8 + uu___9 + uu___10 + uu___11 + uu___12) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___6 + (fun uu___7 -> + (fun uu___7 + -> + let uu___7 + = + Obj.magic + uu___7 in + let typ1 + = + bnorm e + typ in + let uu___8 + = + let uu___9 + = + only_match + && + (let uu___10 + = + let uu___11 + = + FStarC_Syntax_Free.uvars_uncached + typ1 in + FStarC_Class_Setlike.is_empty + () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) + (Obj.magic + uu___11) in + Prims.op_Negation + uu___10) in + if uu___9 + then + FStarC_Tactics_Monad.fail + "t_apply: only_match is on, but the type of the term to apply is not a uvar" + else + FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.repr + ()) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___8 + (fun + uu___9 -> + (fun + uu___9 -> + let uu___9 + = + Obj.magic + uu___9 in + let uu___10 + = + let uu___11 + = + FStarC_Tactics_Types.goal_type + goal in + try_unify_by_application + (FStar_Pervasives_Native.Some + should_check) + only_match + e typ1 + uu___11 + (rangeof + goal) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic + uu___10) + (fun + uu___11 + -> + (fun uvs + -> + let uvs = + Obj.magic + uvs in + let uu___11 + = + FStarC_Tactics_Monad.if_verbose + (fun + uu___12 + -> + let uu___13 + = + (FStarC_Common.string_of_list + ()) + (fun + uu___14 + -> + match uu___14 + with + | + (t, + uu___15, + uu___16) + -> + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t) uvs in + FStarC_Compiler_Util.print1 + "t_apply: found args = %s\n" + uu___13) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___11 + (fun + uu___12 + -> + (fun + uu___12 + -> + let uu___12 + = + Obj.magic + uu___12 in + let w = + FStarC_Compiler_List.fold_right + (fun + uu___13 + -> + fun w1 -> + match uu___13 + with + | + (uvt, q, + uu___14) + -> + FStarC_Syntax_Util.mk_app + w1 + [ + (uvt, q)]) + uvs tm1 in + let uvset + = + let uu___13 + = + Obj.magic + (FStarC_Class_Setlike.empty + () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) + ()) in + FStarC_Compiler_List.fold_right + (fun + uu___15 + -> + fun + uu___14 + -> + (fun + uu___14 + -> + fun s -> + match uu___14 + with + | + (uu___15, + uu___16, + uv) -> + let uu___17 + = + let uu___18 + = + FStarC_Syntax_Util.ctx_uvar_typ + uv in + FStarC_Syntax_Free.uvars + uu___18 in + Obj.magic + (FStarC_Class_Setlike.union + () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) + (Obj.magic + s) + (Obj.magic + uu___17))) + uu___15 + uu___14) + uvs + uu___13 in + let free_in_some_goal + uv = + FStarC_Class_Setlike.mem + () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) + uv + (Obj.magic + uvset) in + let uu___13 + = + solve' + goal w in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___13 + (fun + uu___14 + -> + (fun + uu___14 + -> + let uu___14 + = + Obj.magic + uu___14 in + let uvt_uv_l + = + FStarC_Compiler_List.map + (fun + uu___15 + -> + match uu___15 + with + | + (uvt, _q, + uv) -> + (uvt, uv)) + uvs in + let uu___15 + = + apply_implicits_as_goals + e + (FStar_Pervasives_Native.Some + goal) + uvt_uv_l in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic + uu___15) + (fun + uu___16 + -> + (fun + sub_goals + -> + let sub_goals + = + Obj.magic + sub_goals in + let sub_goals1 + = + let uu___16 + = + let uu___17 + = + FStarC_Compiler_List.filter + (fun g -> + let uu___18 + = + uopt && + (free_in_some_goal + g.FStarC_Tactics_Types.goal_ctx_uvar) in + Prims.op_Negation + uu___18) + (FStarC_Compiler_List.flatten + sub_goals) in + FStarC_Compiler_List.map + bnorm_goal + uu___17 in + FStarC_Compiler_List.rev + uu___16 in + let uu___16 + = + FStarC_Tactics_Monad.add_goals + sub_goals1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___16 + (fun + uu___17 + -> + (fun + uu___17 + -> + let uu___17 + = + Obj.magic + uu___17 in + Obj.magic + (proc_guard + "apply guard" + e guard + (FStar_Pervasives_Native.Some + should_check) + (rangeof + goal))) + uu___17))) + uu___16))) + uu___14))) + uu___12))) + uu___11))) + uu___9))) + uu___7))) + uu___5)))) uu___3))) + uu___3))) uu___2) in + FStarC_Tactics_Monad.wrap_err "apply" uu___ +let (lemma_or_sq : + FStarC_Syntax_Syntax.comp -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.term) + FStar_Pervasives_Native.option) + = + fun c -> + let uu___ = FStarC_Syntax_Util.comp_eff_name_res_and_args c in + match uu___ with + | (eff_name, res, args) -> + let uu___1 = + FStarC_Ident.lid_equals eff_name + FStarC_Parser_Const.effect_Lemma_lid in + if uu___1 + then + let uu___2 = + match args with + | pre::post::uu___3 -> + ((FStar_Pervasives_Native.fst pre), + (FStar_Pervasives_Native.fst post)) + | uu___3 -> failwith "apply_lemma: impossible: not a lemma" in + (match uu___2 with + | (pre, post) -> + let post1 = + let uu___3 = + let uu___4 = + FStarC_Syntax_Syntax.as_arg FStarC_Syntax_Util.exp_unit in + [uu___4] in + FStarC_Syntax_Util.mk_app post uu___3 in + FStar_Pervasives_Native.Some (pre, post1)) + else + (let uu___3 = + (FStarC_Syntax_Util.is_pure_effect eff_name) || + (FStarC_Syntax_Util.is_ghost_effect eff_name) in + if uu___3 + then + let uu___4 = FStarC_Syntax_Util.un_squash res in + FStarC_Compiler_Util.map_opt uu___4 + (fun post -> (FStarC_Syntax_Util.t_true, post)) + else FStar_Pervasives_Native.None) +let (t_apply_lemma : + Prims.bool -> + Prims.bool -> FStarC_Syntax_Syntax.term -> unit FStarC_Tactics_Monad.tac) + = + fun noinst -> + fun noinst_lhs -> + fun tm -> + let uu___ = + let uu___1 = + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () + () (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___2 -> + (fun ps -> + let ps = Obj.magic ps in + let uu___2 = + FStarC_Tactics_Monad.if_verbose + (fun uu___3 -> + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term tm in + FStarC_Compiler_Util.print1 + "apply_lemma: tm = %s\n" uu___4) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () uu___2 + (fun uu___3 -> + (fun uu___3 -> + let uu___3 = Obj.magic uu___3 in + let is_unit_t t = + let uu___4 = + let uu___5 = + FStarC_Syntax_Subst.compress t in + uu___5.FStarC_Syntax_Syntax.n in + match uu___4 with + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.unit_lid + -> true + | uu___5 -> false in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___4 -> + (fun goal -> + let goal = Obj.magic goal in + let env1 = + FStarC_Tactics_Types.goal_env + goal in + FStarC_Tactics_Monad.register_goal + goal; + (let uu___5 = + let env2 = + { + FStarC_TypeChecker_Env.solver + = + (env1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range + = + (env1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule + = + (env1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma + = + (env1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig + = + (env1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache + = + (env1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules + = + (env1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ + = + (env1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab + = + (env1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab + = + (env1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp + = + (env1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects + = + (env1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize + = + (env1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs + = + (env1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level + = + (env1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars + = + (env1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict + = + (env1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface + = + (env1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit + = + (env1.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes + = + (env1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 + = + (env1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard + = + (env1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking + = + (env1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping + = false; + FStarC_TypeChecker_Env.intactics + = + (env1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce + = + (env1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term + = + (env1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (env1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of + = + (env1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force + = + (env1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (env1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (env1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (env1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths + = + (env1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns + = + (env1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook + = + (env1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (env1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice + = + (env1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess + = + (env1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess + = + (env1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info + = + (env1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks + = + (env1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv + = + (env1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab + = + (env1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (env1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (env1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (env1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (env1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check + = + (env1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl + = + (env1.FStarC_TypeChecker_Env.missing_decl) + } in + __tc env2 tm in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () (Obj.magic uu___5) + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = + Obj.magic uu___6 in + match uu___6 with + | (tm1, t, guard) -> + let uu___7 = + FStarC_Syntax_Util.arrow_formals_comp + t in + (match uu___7 with + | (bs, comp) -> + let uu___8 = + lemma_or_sq + comp in + (match uu___8 + with + | FStar_Pervasives_Native.None + -> + Obj.magic + (FStarC_Tactics_Monad.fail + "not a lemma or squashed function") + | FStar_Pervasives_Native.Some + (pre, + post) -> + let uu___9 + = + Obj.magic + (FStarC_Class_Monad.foldM_left + FStarC_Tactics_Monad.monad_tac + () () + (fun + uu___11 + -> + fun + uu___10 + -> + (fun + uu___10 + -> + let uu___10 + = + Obj.magic + uu___10 in + fun + uu___11 + -> + let uu___11 + = + Obj.magic + uu___11 in + match + (uu___10, + uu___11) + with + | + ((uvs, + deps, + imps, + subst), + { + FStarC_Syntax_Syntax.binder_bv + = b; + FStarC_Syntax_Syntax.binder_qual + = aq; + FStarC_Syntax_Syntax.binder_positivity + = uu___12; + FStarC_Syntax_Syntax.binder_attrs + = uu___13;_}) + -> + let b_t = + FStarC_Syntax_Subst.subst + subst + b.FStarC_Syntax_Syntax.sort in + let uu___14 + = + is_unit_t + b_t in + if + uu___14 + then + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + (((FStarC_Syntax_Util.exp_unit, + aq) :: + uvs), + deps, + imps, + ((FStarC_Syntax_Syntax.NT + (b, + FStarC_Syntax_Util.exp_unit)) + :: + subst)))) + else + (let uu___16 + = + let uu___17 + = + let uu___18 + = + let uu___19 + = + should_check_goal_uvar + goal in + match uu___19 + with + | + FStarC_Syntax_Syntax.Strict + -> + FStarC_Syntax_Syntax.Allow_ghost + "apply lemma uvar" + | + x -> x in + FStar_Pervasives_Native.Some + uu___18 in + FStarC_Tactics_Monad.new_uvar + "apply_lemma" + env1 b_t + uu___17 + deps + (rangeof + goal) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic + uu___16) + (fun + uu___17 + -> + (fun + uu___17 + -> + let uu___17 + = + Obj.magic + uu___17 in + match uu___17 + with + | + (t1, u) + -> + (( + let uu___19 + = + FStarC_Compiler_Effect.op_Bang + dbg_2635 in + if + uu___19 + then + let uu___20 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_ctxu + u in + let uu___21 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + tm1 in + FStarC_Compiler_Util.print2 + "Apply lemma created a new uvar %s while applying %s\n" + uu___20 + uu___21 + else ()); + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + (((t1, + aq) :: + uvs), (u + :: deps), + ((t1, u) + :: imps), + ((FStarC_Syntax_Syntax.NT + (b, t1)) + :: + subst)))))) + uu___17)))) + uu___11 + uu___10) + (Obj.magic + ([], [], + [], [])) + (Obj.magic + bs)) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic + uu___9) + (fun + uu___10 + -> + (fun + uu___10 + -> + let uu___10 + = + Obj.magic + uu___10 in + match uu___10 + with + | + (uvs, + uu___11, + implicits1, + subst) -> + let implicits2 + = + FStarC_Compiler_List.rev + implicits1 in + let uvs1 + = + FStarC_Compiler_List.rev + uvs in + let pre1 + = + FStarC_Syntax_Subst.subst + subst pre in + let post1 + = + FStarC_Syntax_Subst.subst + subst + post in + let post_u + = + env1.FStarC_TypeChecker_Env.universe_of + env1 + post1 in + let cmp_func + = + if noinst + then + do_match + else + if + noinst_lhs + then + do_match_on_lhs + else + do_unify in + let uu___12 + = + let must_tot + = false in + let uu___13 + = + FStarC_Tactics_Types.goal_type + goal in + let uu___14 + = + FStarC_Syntax_Util.mk_squash + post_u + post1 in + cmp_func + must_tot + env1 + uu___13 + uu___14 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic + uu___12) + (fun + uu___13 + -> + (fun b -> + let b = + Obj.magic + b in + if + Prims.op_Negation + b + then + let uu___13 + = + let uu___14 + = + let uu___15 + = + let uu___16 + = + FStarC_Errors_Msg.text + "Cannot instantiate lemma:" in + let uu___17 + = + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_term + tm1 in + FStarC_Pprint.prefix + (Prims.of_int (2)) + Prims.int_one + uu___16 + uu___17 in + let uu___16 + = + let uu___17 + = + let uu___18 + = + FStarC_Errors_Msg.text + "with postcondition:" in + let uu___19 + = + FStarC_TypeChecker_Normalize.term_to_doc + env1 + post1 in + FStarC_Pprint.prefix + (Prims.of_int (2)) + Prims.int_one + uu___18 + uu___19 in + let uu___18 + = + let uu___19 + = + FStarC_Errors_Msg.text + "to match goal:" in + let uu___20 + = + let uu___21 + = + FStarC_Tactics_Types.goal_type + goal in + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_term + uu___21 in + FStarC_Pprint.prefix + (Prims.of_int (2)) + Prims.int_one + uu___19 + uu___20 in + FStarC_Pprint.op_Hat_Slash_Hat + uu___17 + uu___18 in + FStarC_Pprint.op_Hat_Slash_Hat + uu___15 + uu___16 in + [uu___14] in + Obj.magic + (FStarC_Tactics_Monad.fail_doc + uu___13) + else + (let goal_sc + = + should_check_goal_uvar + goal in + let uu___14 + = + solve' + goal + FStarC_Syntax_Util.exp_unit in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___14 + (fun + uu___15 + -> + (fun + uu___15 + -> + let uu___15 + = + Obj.magic + uu___15 in + let is_free_uvar + uv t1 = + let uu___16 + = + FStarC_Syntax_Free.uvars + t1 in + FStarC_Class_Setlike.for_any + () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) + (fun u -> + FStarC_Syntax_Unionfind.equiv + u.FStarC_Syntax_Syntax.ctx_uvar_head + uv) + (Obj.magic + uu___16) in + let appears + uv goals + = + FStarC_Compiler_List.existsML + (fun g' + -> + let uu___16 + = + FStarC_Tactics_Types.goal_type + g' in + is_free_uvar + uv + uu___16) + goals in + let checkone + t1 goals + = + let uu___16 + = + FStarC_Syntax_Util.head_and_args + t1 in + match uu___16 + with + | + (hd, + uu___17) + -> + (match + hd.FStarC_Syntax_Syntax.n + with + | + FStarC_Syntax_Syntax.Tm_uvar + (uv, + uu___18) + -> + appears + uv.FStarC_Syntax_Syntax.ctx_uvar_head + goals + | + uu___18 + -> false) in + let must_tot + = false in + let uu___16 + = + apply_implicits_as_goals + env1 + (FStar_Pervasives_Native.Some + goal) + implicits2 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic + uu___16) + (fun + uu___17 + -> + (fun + sub_goals + -> + let sub_goals + = + Obj.magic + sub_goals in + let sub_goals1 + = + FStarC_Compiler_List.flatten + sub_goals in + let rec filter' + f xs = + match xs + with + | + [] -> [] + | + x::xs1 -> + let uu___17 + = f x xs1 in + if + uu___17 + then + let uu___18 + = + filter' f + xs1 in x + :: + uu___18 + else + filter' f + xs1 in + let sub_goals2 + = + filter' + (fun g -> + fun goals + -> + let uu___17 + = + let uu___18 + = + FStarC_Tactics_Types.goal_witness + g in + checkone + uu___18 + goals in + Prims.op_Negation + uu___17) + sub_goals1 in + let uu___17 + = + proc_guard + "apply_lemma guard" + env1 + guard + (FStar_Pervasives_Native.Some + goal_sc) + (rangeof + goal) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___17 + (fun + uu___18 + -> + (fun + uu___18 + -> + let uu___18 + = + Obj.magic + uu___18 in + let pre_u + = + env1.FStarC_TypeChecker_Env.universe_of + env1 pre1 in + let uu___19 + = + let uu___20 + = + let uu___21 + = + let uu___22 + = + FStarC_TypeChecker_Env.guard_of_guard_formula + (FStarC_TypeChecker_Common.NonTrivial + pre1) in + FStarC_TypeChecker_Rel.simplify_guard + env1 + uu___22 in + uu___21.FStarC_TypeChecker_Common.guard_f in + match uu___20 + with + | + FStarC_TypeChecker_Common.Trivial + -> + FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.repr + ()) + | + FStarC_TypeChecker_Common.NonTrivial + uu___21 + -> + FStarC_Tactics_Monad.add_irrelevant_goal + goal + "apply_lemma precondition" + env1 pre1 + (FStar_Pervasives_Native.Some + goal_sc) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___19 + (fun + uu___20 + -> + (fun + uu___20 + -> + let uu___20 + = + Obj.magic + uu___20 in + Obj.magic + (FStarC_Tactics_Monad.add_goals + sub_goals2)) + uu___20))) + uu___18))) + uu___17))) + uu___15)))) + uu___13))) + uu___10))))) + uu___6)))) uu___4))) + uu___3))) uu___2) in + FStarC_Tactics_Monad.focus uu___1 in + FStarC_Tactics_Monad.wrap_err "apply_lemma" uu___ +let (split_env : + FStarC_Syntax_Syntax.bv -> + env -> + (env * FStarC_Syntax_Syntax.bv * FStarC_Syntax_Syntax.bv Prims.list) + FStar_Pervasives_Native.option) + = + fun bvar -> + fun e -> + let rec aux e1 = + let uu___ = FStarC_TypeChecker_Env.pop_bv e1 in + match uu___ with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (bv', e') -> + let uu___1 = FStarC_Syntax_Syntax.bv_eq bvar bv' in + if uu___1 + then FStar_Pervasives_Native.Some (e', bv', []) + else + (let uu___3 = aux e' in + FStarC_Compiler_Util.map_opt uu___3 + (fun uu___4 -> + match uu___4 with + | (e'', bv, bvs) -> (e'', bv, (bv' :: bvs)))) in + let uu___ = aux e in + FStarC_Compiler_Util.map_opt uu___ + (fun uu___1 -> + match uu___1 with + | (e', bv, bvs) -> (e', bv, (FStarC_Compiler_List.rev bvs))) +let (subst_goal : + FStarC_Syntax_Syntax.bv -> + FStarC_Syntax_Syntax.bv -> + FStarC_Tactics_Types.goal -> + (FStarC_Syntax_Syntax.bv * FStarC_Tactics_Types.goal) + FStar_Pervasives_Native.option FStarC_Tactics_Monad.tac) + = + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun b1 -> + fun b2 -> + fun g -> + let uu___ = + let uu___1 = FStarC_Tactics_Types.goal_env g in + split_env b1 uu___1 in + match uu___ with + | FStar_Pervasives_Native.Some (e0, b11, bvs) -> + let bs = + FStarC_Compiler_List.map FStarC_Syntax_Syntax.mk_binder + (b11 :: bvs) in + let t = FStarC_Tactics_Types.goal_type g in + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.close_binders bs in + let uu___3 = FStarC_Syntax_Subst.close bs t in + (uu___2, uu___3) in + (match uu___1 with + | (bs', t') -> + let bs'1 = + let uu___2 = FStarC_Syntax_Syntax.mk_binder b2 in + let uu___3 = FStarC_Compiler_List.tail bs' in + uu___2 :: uu___3 in + let uu___2 = + FStarC_TypeChecker_Core.open_binders_in_term e0 + bs'1 t' in + (match uu___2 with + | (new_env, bs'', t'') -> + let b21 = + let uu___3 = FStarC_Compiler_List.hd bs'' in + uu___3.FStarC_Syntax_Syntax.binder_bv in + let uu___3 = + let uu___4 = + let uu___5 = should_check_goal_uvar g in + FStar_Pervasives_Native.Some uu___5 in + let uu___5 = + FStarC_Tactics_Monad.goal_typedness_deps g in + FStarC_Tactics_Monad.new_uvar "subst_goal" + new_env t'' uu___4 uu___5 (rangeof g) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___3) + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + match uu___4 with + | (uvt, uv) -> + let goal' = + FStarC_Tactics_Types.mk_goal + new_env uv + g.FStarC_Tactics_Types.opts + g.FStarC_Tactics_Types.is_guard + g.FStarC_Tactics_Types.label in + let sol = + let uu___5 = + FStarC_Syntax_Util.abs bs'' + uvt + FStar_Pervasives_Native.None in + let uu___6 = + FStarC_Compiler_List.map + (fun uu___7 -> + match uu___7 with + | { + FStarC_Syntax_Syntax.binder_bv + = bv; + FStarC_Syntax_Syntax.binder_qual + = q; + FStarC_Syntax_Syntax.binder_positivity + = uu___8; + FStarC_Syntax_Syntax.binder_attrs + = uu___9;_} + -> + let uu___10 = + FStarC_Syntax_Syntax.bv_to_name + bv in + FStarC_Syntax_Syntax.as_arg + uu___10) bs in + FStarC_Syntax_Util.mk_app + uu___5 uu___6 in + let uu___5 = set_solution g sol in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___5 + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = + Obj.magic uu___6 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + (FStar_Pervasives_Native.Some + (b21, + goal'))))) + uu___6))) uu___4)))) + | FStar_Pervasives_Native.None -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic FStar_Pervasives_Native.None))) uu___2 + uu___1 uu___ +let (rewrite : + FStarC_Reflection_V2_Data.binding -> unit FStarC_Tactics_Monad.tac) = + fun hh -> + let uu___ = + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___1 -> + (fun goal -> + let goal = Obj.magic goal in + let h = binding_to_binder hh in + let bv = h.FStarC_Syntax_Syntax.binder_bv in + let uu___1 = + FStarC_Tactics_Monad.if_verbose + (fun uu___2 -> + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_bv + bv in + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + bv.FStarC_Syntax_Syntax.sort in + FStarC_Compiler_Util.print2 "+++Rewrite %s : %s\n" + uu___3 uu___4) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () uu___1 + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + let uu___3 = + let uu___4 = FStarC_Tactics_Types.goal_env goal in + split_env bv uu___4 in + match uu___3 with + | FStar_Pervasives_Native.None -> + Obj.magic + (FStarC_Tactics_Monad.fail + "binder not found in environment") + | FStar_Pervasives_Native.Some (e0, bv1, bvs) -> + let uu___4 = + destruct_eq e0 bv1.FStarC_Syntax_Syntax.sort in + (match uu___4 with + | FStar_Pervasives_Native.Some (x, e) -> + let uu___5 = + let uu___6 = + FStarC_Syntax_Subst.compress x in + uu___6.FStarC_Syntax_Syntax.n in + (match uu___5 with + | FStarC_Syntax_Syntax.Tm_name x1 -> + let s = + [FStarC_Syntax_Syntax.NT (x1, e)] in + let t = + FStarC_Tactics_Types.goal_type goal in + let bs = + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.mk_binder bvs in + let uu___6 = + let uu___7 = + FStarC_Syntax_Subst.close_binders + bs in + let uu___8 = + FStarC_Syntax_Subst.close bs t in + (uu___7, uu___8) in + (match uu___6 with + | (bs', t') -> + let uu___7 = + let uu___8 = + FStarC_Syntax_Subst.subst_binders + s bs' in + let uu___9 = + FStarC_Syntax_Subst.subst s + t' in + (uu___8, uu___9) in + (match uu___7 with + | (bs'1, t'1) -> + let e01 = + FStarC_TypeChecker_Env.push_bvs + e0 [bv1] in + let uu___8 = + FStarC_TypeChecker_Core.open_binders_in_term + e01 bs'1 t'1 in + (match uu___8 with + | (new_env, bs'', t'') -> + let uu___9 = + let uu___10 = + let uu___11 = + should_check_goal_uvar + goal in + FStar_Pervasives_Native.Some + uu___11 in + let uu___11 = + FStarC_Tactics_Monad.goal_typedness_deps + goal in + FStarC_Tactics_Monad.new_uvar + "rewrite" new_env + t'' uu___10 uu___11 + (rangeof goal) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic uu___9) + (fun uu___10 -> + (fun uu___10 -> + let uu___10 + = + Obj.magic + uu___10 in + match uu___10 + with + | (uvt, uv) + -> + let goal' + = + FStarC_Tactics_Types.mk_goal + new_env + uv + goal.FStarC_Tactics_Types.opts + goal.FStarC_Tactics_Types.is_guard + goal.FStarC_Tactics_Types.label in + let sol = + let uu___11 + = + FStarC_Syntax_Util.abs + bs'' uvt + FStar_Pervasives_Native.None in + let uu___12 + = + FStarC_Compiler_List.map + (fun + uu___13 + -> + match uu___13 + with + | + { + FStarC_Syntax_Syntax.binder_bv + = bv2; + FStarC_Syntax_Syntax.binder_qual + = uu___14; + FStarC_Syntax_Syntax.binder_positivity + = uu___15; + FStarC_Syntax_Syntax.binder_attrs + = uu___16;_} + -> + let uu___17 + = + FStarC_Syntax_Syntax.bv_to_name + bv2 in + FStarC_Syntax_Syntax.as_arg + uu___17) + bs in + FStarC_Syntax_Util.mk_app + uu___11 + uu___12 in + let uu___11 + = + set_solution + goal sol in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___11 + (fun + uu___12 + -> + (fun + uu___12 + -> + let uu___12 + = + Obj.magic + uu___12 in + Obj.magic + (FStarC_Tactics_Monad.replace_cur + goal')) + uu___12))) + uu___10))))) + | uu___6 -> + Obj.magic + (FStarC_Tactics_Monad.fail + "Not an equality hypothesis with a variable on the LHS")) + | uu___5 -> + Obj.magic + (FStarC_Tactics_Monad.fail + "Not an equality hypothesis"))) uu___2))) + uu___1) in + FStarC_Tactics_Monad.wrap_err "rewrite" uu___ +let (replace : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun t1 -> + fun t2 -> + fun s -> + FStarC_Syntax_Visit.visit_term false + (fun t -> + let uu___ = FStarC_Syntax_Util.term_eq t t1 in + if uu___ then t2 else t) s +let (grewrite : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> unit FStarC_Tactics_Monad.tac) + = + fun t1 -> + fun t2 -> + let uu___ = + let uu___1 = + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___2 -> + (fun goal -> + let goal = Obj.magic goal in + let goal_t = FStarC_Tactics_Types.goal_type goal in + let env1 = FStarC_Tactics_Types.goal_env goal in + let uu___2 = __tc env1 t1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___2) + (fun uu___3 -> + (fun uu___3 -> + let uu___3 = Obj.magic uu___3 in + match uu___3 with + | (t11, typ1, g1) -> + let uu___4 = __tc env1 t2 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___4) + (fun uu___5 -> + (fun uu___5 -> + let uu___5 = Obj.magic uu___5 in + match uu___5 with + | (t21, typ2, g2) -> + let typ1' = + FStarC_TypeChecker_Normalize.unfold_whnf' + [FStarC_TypeChecker_Env.Unrefine] + env1 typ1 in + let typ2' = + FStarC_TypeChecker_Normalize.unfold_whnf' + [FStarC_TypeChecker_Env.Unrefine] + env1 typ2 in + let uu___6 = + let uu___7 = + do_unify false env1 typ1' + typ2' in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () (Obj.magic uu___7) + (fun uu___8 -> + (fun uu___8 -> + let uu___8 = + Obj.magic uu___8 in + if uu___8 + then + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.repr ())) + else + (let uu___10 = + let uu___11 = + FStarC_Errors_Msg.text + "Types do not match for grewrite" in + let uu___12 = + let uu___13 + = + let uu___14 + = + FStarC_Errors_Msg.text + "Type of" in + let uu___15 + = + let uu___16 + = + let uu___17 + = + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_term + t11 in + FStarC_Pprint.parens + uu___17 in + let uu___17 + = + let uu___18 + = + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_term + typ1 in + FStarC_Pprint.op_Hat_Slash_Hat + FStarC_Pprint.equals + uu___18 in + FStarC_Pprint.op_Hat_Slash_Hat + uu___16 + uu___17 in + FStarC_Pprint.op_Hat_Slash_Hat + uu___14 + uu___15 in + let uu___14 + = + let uu___15 + = + let uu___16 + = + FStarC_Errors_Msg.text + "Type of" in + let uu___17 + = + let uu___18 + = + let uu___19 + = + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_term + t21 in + FStarC_Pprint.parens + uu___19 in + let uu___19 + = + let uu___20 + = + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_term + typ2 in + FStarC_Pprint.op_Hat_Slash_Hat + FStarC_Pprint.equals + uu___20 in + FStarC_Pprint.op_Hat_Slash_Hat + uu___18 + uu___19 in + FStarC_Pprint.op_Hat_Slash_Hat + uu___16 + uu___17 in + [uu___15] in + uu___13 :: + uu___14 in + uu___11 :: + uu___12 in + Obj.magic + (FStarC_Tactics_Monad.fail_doc + uu___10))) + uu___8) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___6 + (fun uu___7 -> + (fun uu___7 -> + let uu___7 = + Obj.magic uu___7 in + let u = + env1.FStarC_TypeChecker_Env.universe_of + env1 typ1 in + let goal_t' = + replace t11 t21 + goal_t in + let uu___8 = + let uu___9 = + FStarC_Syntax_Util.mk_eq2 + u typ1 t11 + t21 in + FStarC_Tactics_Monad.mk_irrelevant_goal + "grewrite.eq" + env1 uu___9 + FStar_Pervasives_Native.None + (goal.FStarC_Tactics_Types.goal_ctx_uvar).FStarC_Syntax_Syntax.ctx_uvar_range + goal.FStarC_Tactics_Types.opts + goal.FStarC_Tactics_Types.label in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic + uu___8) + (fun uu___9 + -> + (fun g_eq + -> + let g_eq + = + Obj.magic + g_eq in + let uu___9 + = + let uu___10 + = + FStarC_Tactics_Monad.goal_with_type + goal + goal_t' in + FStarC_Tactics_Monad.replace_cur + uu___10 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___9 + (fun + uu___10 + -> + (fun + uu___10 + -> + let uu___10 + = + Obj.magic + uu___10 in + let uu___11 + = + FStarC_Tactics_Monad.push_goals + [g_eq] in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___11 + (fun + uu___12 + -> + (fun + uu___12 + -> + let uu___12 + = + Obj.magic + uu___12 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.repr + ()))) + uu___12))) + uu___10))) + uu___9))) + uu___7))) uu___5))) + uu___3))) uu___2) in + FStarC_Tactics_Monad.focus uu___1 in + FStarC_Tactics_Monad.wrap_err "grewrite" uu___ +let (rename_to : + FStarC_Reflection_V2_Data.binding -> + Prims.string -> + FStarC_Reflection_V2_Data.binding FStarC_Tactics_Monad.tac) + = + fun b -> + fun s -> + let uu___ = + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () + () (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___1 -> + (fun goal -> + let goal = Obj.magic goal in + let bv = binding_to_bv b in + let bv' = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Ident.range_of_id + bv.FStarC_Syntax_Syntax.ppname in + (s, uu___4) in + FStarC_Ident.mk_ident uu___3 in + { + FStarC_Syntax_Syntax.ppname = uu___2; + FStarC_Syntax_Syntax.index = + (bv.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = + (bv.FStarC_Syntax_Syntax.sort) + } in + FStarC_Syntax_Syntax.freshen_bv uu___1 in + let uu___1 = subst_goal bv bv' goal in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + match uu___2 with + | FStar_Pervasives_Native.None -> + Obj.magic + (Obj.repr + (FStarC_Tactics_Monad.fail + "binder not found in environment")) + | FStar_Pervasives_Native.Some (bv'1, goal1) -> + Obj.magic + (Obj.repr + (let uu___3 = + FStarC_Tactics_Monad.replace_cur + goal1 in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () + () uu___3 + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + let uniq = + FStarC_BigInt.of_int_fs + bv'1.FStarC_Syntax_Syntax.index in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + { + FStarC_Reflection_V2_Data.uniq1 + = uniq; + FStarC_Reflection_V2_Data.sort3 + = + (b.FStarC_Reflection_V2_Data.sort3); + FStarC_Reflection_V2_Data.ppname3 + = + (FStarC_Compiler_Sealed.seal + s) + }))) uu___4)))) + uu___2))) uu___1)) in + FStarC_Tactics_Monad.wrap_err "rename_to" uu___ +let (var_retype : + FStarC_Reflection_V2_Data.binding -> unit FStarC_Tactics_Monad.tac) = + fun b -> + let uu___ = + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___1 -> + (fun goal -> + let goal = Obj.magic goal in + let bv = binding_to_bv b in + let uu___1 = + let uu___2 = FStarC_Tactics_Types.goal_env goal in + split_env bv uu___2 in + match uu___1 with + | FStar_Pervasives_Native.None -> + Obj.magic + (FStarC_Tactics_Monad.fail + "binder is not present in environment") + | FStar_Pervasives_Native.Some (e0, bv1, bvs) -> + let uu___2 = FStarC_Syntax_Util.type_u () in + (match uu___2 with + | (ty, u) -> + let goal_sc = should_check_goal_uvar goal in + let uu___3 = + let uu___4 = + FStarC_Tactics_Monad.goal_typedness_deps goal in + FStarC_Tactics_Monad.new_uvar "binder_retype" e0 ty + (FStar_Pervasives_Native.Some goal_sc) uu___4 + (rangeof goal) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___3) + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + match uu___4 with + | (t', u_t') -> + let bv'' = + { + FStarC_Syntax_Syntax.ppname = + (bv1.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (bv1.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = t' + } in + let s = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Syntax_Syntax.bv_to_name + bv'' in + (bv1, uu___7) in + FStarC_Syntax_Syntax.NT uu___6 in + [uu___5] in + let bvs1 = + FStarC_Compiler_List.map + (fun b1 -> + let uu___5 = + FStarC_Syntax_Subst.subst s + b1.FStarC_Syntax_Syntax.sort in + { + FStarC_Syntax_Syntax.ppname = + (b1.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (b1.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = + uu___5 + }) bvs in + let env' = + FStarC_TypeChecker_Env.push_bvs e0 + (bv'' :: bvs1) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () + () FStarC_Tactics_Monad.dismiss + (fun uu___5 -> + (fun uu___5 -> + let uu___5 = + Obj.magic uu___5 in + let new_goal = + let uu___6 = + FStarC_Tactics_Types.goal_with_env + goal env' in + let uu___7 = + let uu___8 = + FStarC_Tactics_Types.goal_type + goal in + FStarC_Syntax_Subst.subst + s uu___8 in + FStarC_Tactics_Monad.goal_with_type + uu___6 uu___7 in + let uu___6 = + FStarC_Tactics_Monad.add_goals + [new_goal] in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___6 + (fun uu___7 -> + (fun uu___7 -> + let uu___7 = + Obj.magic + uu___7 in + let uu___8 = + FStarC_Syntax_Util.mk_eq2 + (FStarC_Syntax_Syntax.U_succ + u) ty + bv1.FStarC_Syntax_Syntax.sort + t' in + Obj.magic + (FStarC_Tactics_Monad.add_irrelevant_goal + goal + "binder_retype equation" + e0 uu___8 + (FStar_Pervasives_Native.Some + goal_sc))) + uu___7))) uu___5))) + uu___4)))) uu___1) in + FStarC_Tactics_Monad.wrap_err "binder_retype" uu___ +let (norm_binding_type : + FStar_Pervasives.norm_step Prims.list -> + FStarC_Reflection_V2_Data.binding -> unit FStarC_Tactics_Monad.tac) + = + fun s -> + fun b -> + let uu___ = + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___1 -> + (fun goal -> + let goal = Obj.magic goal in + let bv = binding_to_bv b in + let uu___1 = + let uu___2 = FStarC_Tactics_Types.goal_env goal in + split_env bv uu___2 in + match uu___1 with + | FStar_Pervasives_Native.None -> + Obj.magic + (FStarC_Tactics_Monad.fail + "binder is not present in environment") + | FStar_Pervasives_Native.Some (e0, bv1, bvs) -> + let steps = + let uu___2 = + FStarC_TypeChecker_Cfg.translate_norm_steps s in + FStarC_Compiler_List.op_At + [FStarC_TypeChecker_Env.Reify; + FStarC_TypeChecker_Env.DontUnfoldAttr + [FStarC_Parser_Const.tac_opaque_attr]] uu___2 in + let sort' = + normalize steps e0 bv1.FStarC_Syntax_Syntax.sort in + let bv' = + { + FStarC_Syntax_Syntax.ppname = + (bv1.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (bv1.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = sort' + } in + let env' = + FStarC_TypeChecker_Env.push_bvs e0 (bv' :: bvs) in + let uu___2 = FStarC_Tactics_Types.goal_with_env goal env' in + Obj.magic (FStarC_Tactics_Monad.replace_cur uu___2)) + uu___1) in + FStarC_Tactics_Monad.wrap_err "norm_binding_type" uu___ +let (revert : unit -> unit FStarC_Tactics_Monad.tac) = + fun uu___ -> + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___1 -> + (fun goal -> + let goal = Obj.magic goal in + let uu___1 = + let uu___2 = FStarC_Tactics_Types.goal_env goal in + FStarC_TypeChecker_Env.pop_bv uu___2 in + match uu___1 with + | FStar_Pervasives_Native.None -> + Obj.magic + (FStarC_Tactics_Monad.fail "Cannot revert; empty context") + | FStar_Pervasives_Native.Some (x, env') -> + let typ' = + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.mk_binder x in [uu___3] in + let uu___3 = + let uu___4 = FStarC_Tactics_Types.goal_type goal in + FStarC_Syntax_Syntax.mk_Total uu___4 in + FStarC_Syntax_Util.arrow uu___2 uu___3 in + let uu___2 = + let uu___3 = + let uu___4 = should_check_goal_uvar goal in + FStar_Pervasives_Native.Some uu___4 in + let uu___4 = FStarC_Tactics_Monad.goal_typedness_deps goal in + FStarC_Tactics_Monad.new_uvar "revert" env' typ' uu___3 + uu___4 (rangeof goal) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () (Obj.magic uu___2) + (fun uu___3 -> + (fun uu___3 -> + let uu___3 = Obj.magic uu___3 in + match uu___3 with + | (r, u_r) -> + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Syntax.bv_to_name x in + FStarC_Syntax_Syntax.as_arg uu___8 in + [uu___7] in + let uu___7 = + let uu___8 = + FStarC_Tactics_Types.goal_type goal in + uu___8.FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.mk_Tm_app r uu___6 + uu___7 in + set_solution goal uu___5 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + uu___4 + (fun uu___5 -> + (fun uu___5 -> + let uu___5 = Obj.magic uu___5 in + let g = + FStarC_Tactics_Types.mk_goal env' + u_r + goal.FStarC_Tactics_Types.opts + goal.FStarC_Tactics_Types.is_guard + goal.FStarC_Tactics_Types.label in + Obj.magic + (FStarC_Tactics_Monad.replace_cur + g)) uu___5))) uu___3))) uu___1) +let (free_in : + FStarC_Syntax_Syntax.bv -> FStarC_Syntax_Syntax.term -> Prims.bool) = + fun bv -> + fun t -> + let uu___ = FStarC_Syntax_Free.names t in + FStarC_Class_Setlike.mem () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) bv (Obj.magic uu___) +let (clear : + FStarC_Reflection_V2_Data.binding -> unit FStarC_Tactics_Monad.tac) = + fun b -> + let bv = binding_to_bv b in + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___ -> + (fun goal -> + let goal = Obj.magic goal in + let uu___ = + FStarC_Tactics_Monad.if_verbose + (fun uu___1 -> + let uu___2 = binding_to_string b in + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Tactics_Types.goal_env goal in + FStarC_TypeChecker_Env.all_binders uu___6 in + FStarC_Compiler_List.length uu___5 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_nat) uu___4 in + FStarC_Compiler_Util.print2 + "Clear of (%s), env has %s binders\n" uu___2 uu___3) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac + () () uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + let uu___2 = + let uu___3 = FStarC_Tactics_Types.goal_env goal in + split_env bv uu___3 in + match uu___2 with + | FStar_Pervasives_Native.None -> + Obj.magic + (FStarC_Tactics_Monad.fail + "Cannot clear; binder not in environment") + | FStar_Pervasives_Native.Some (e', bv1, bvs) -> + let rec check bvs1 = + match bvs1 with + | [] -> + FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.repr ()) + | bv'::bvs2 -> + let uu___3 = + free_in bv1 bv'.FStarC_Syntax_Syntax.sort in + if uu___3 + then + let uu___4 = + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_bv bv' in + FStarC_Compiler_Util.format1 + "Cannot clear; binder present in the type of %s" + uu___5 in + FStarC_Tactics_Monad.fail uu___4 + else check bvs2 in + let uu___3 = + let uu___4 = FStarC_Tactics_Types.goal_type goal in + free_in bv1 uu___4 in + if uu___3 + then + Obj.magic + (FStarC_Tactics_Monad.fail + "Cannot clear; binder present in goal") + else + (let uu___5 = check bvs in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + uu___5 + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = Obj.magic uu___6 in + let env' = + FStarC_TypeChecker_Env.push_bvs e' + bvs in + let uu___7 = + let uu___8 = + FStarC_Tactics_Types.goal_type + goal in + let uu___9 = + let uu___10 = + should_check_goal_uvar goal in + FStar_Pervasives_Native.Some + uu___10 in + let uu___10 = + FStarC_Tactics_Monad.goal_typedness_deps + goal in + FStarC_Tactics_Monad.new_uvar + "clear.witness" env' uu___8 + uu___9 uu___10 (rangeof goal) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () (Obj.magic uu___7) + (fun uu___8 -> + (fun uu___8 -> + let uu___8 = + Obj.magic uu___8 in + match uu___8 with + | (ut, uvar_ut) -> + let uu___9 = + set_solution goal + ut in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___9 + (fun uu___10 -> + (fun uu___10 + -> + let uu___10 + = + Obj.magic + uu___10 in + let uu___11 + = + FStarC_Tactics_Types.mk_goal + env' + uvar_ut + goal.FStarC_Tactics_Types.opts + goal.FStarC_Tactics_Types.is_guard + goal.FStarC_Tactics_Types.label in + Obj.magic + (FStarC_Tactics_Monad.replace_cur + uu___11)) + uu___10))) + uu___8))) uu___6)))) + uu___1))) uu___) +let (clear_top : unit -> unit FStarC_Tactics_Monad.tac) = + fun uu___ -> + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___1 -> + (fun goal -> + let goal = Obj.magic goal in + let uu___1 = + let uu___2 = FStarC_Tactics_Types.goal_env goal in + FStarC_TypeChecker_Env.pop_bv uu___2 in + match uu___1 with + | FStar_Pervasives_Native.None -> + Obj.magic + (FStarC_Tactics_Monad.fail "Cannot clear; empty context") + | FStar_Pervasives_Native.Some (x, uu___2) -> + let uu___3 = bv_to_binding x in Obj.magic (clear uu___3)) + uu___1) +let (prune : Prims.string -> unit FStarC_Tactics_Monad.tac) = + fun s -> + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___ -> + (fun g -> + let g = Obj.magic g in + let ctx = FStarC_Tactics_Types.goal_env g in + let ctx' = + let uu___ = FStarC_Ident.path_of_text s in + FStarC_TypeChecker_Env.rem_proof_ns ctx uu___ in + let g' = FStarC_Tactics_Types.goal_with_env g ctx' in + Obj.magic (FStarC_Tactics_Monad.replace_cur g')) uu___) +let (addns : Prims.string -> unit FStarC_Tactics_Monad.tac) = + fun s -> + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___ -> + (fun g -> + let g = Obj.magic g in + let ctx = FStarC_Tactics_Types.goal_env g in + let ctx' = + let uu___ = FStarC_Ident.path_of_text s in + FStarC_TypeChecker_Env.add_proof_ns ctx uu___ in + let g' = FStarC_Tactics_Types.goal_with_env g ctx' in + Obj.magic (FStarC_Tactics_Monad.replace_cur g')) uu___) +let (guard_formula : + FStarC_TypeChecker_Common.guard_t -> FStarC_Syntax_Syntax.term) = + fun g -> + match g.FStarC_TypeChecker_Common.guard_f with + | FStarC_TypeChecker_Common.Trivial -> FStarC_Syntax_Util.t_true + | FStarC_TypeChecker_Common.NonTrivial f -> f +let (_t_trefl : + Prims.bool -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> unit FStarC_Tactics_Monad.tac) + = + fun allow_guards -> + fun l -> + fun r -> + let should_register_trefl g = + let should_register = true in + let skip_register = false in + let uu___ = + let uu___1 = FStarC_Options.compat_pre_core_should_register () in + Prims.op_Negation uu___1 in + if uu___ + then skip_register + else + (let is_uvar_untyped_or_already_checked u = + let dec = + FStarC_Syntax_Unionfind.find_decoration + u.FStarC_Syntax_Syntax.ctx_uvar_head in + match dec.FStarC_Syntax_Syntax.uvar_decoration_should_check + with + | FStarC_Syntax_Syntax.Allow_untyped uu___2 -> true + | FStarC_Syntax_Syntax.Already_checked -> true + | uu___2 -> false in + let is_uvar t = + let head = FStarC_Syntax_Util.leftmost_head t in + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress head in + uu___3.FStarC_Syntax_Syntax.n in + match uu___2 with + | FStarC_Syntax_Syntax.Tm_uvar (u, uu___3) -> + FStar_Pervasives.Inl (u, head, t) + | uu___3 -> FStar_Pervasives.Inr t in + let is_allow_untyped_uvar t = + let uu___2 = is_uvar t in + match uu___2 with + | FStar_Pervasives.Inr uu___3 -> false + | FStar_Pervasives.Inl (u, uu___3, uu___4) -> + is_uvar_untyped_or_already_checked u in + let t = + FStarC_Syntax_Util.ctx_uvar_typ + g.FStarC_Tactics_Types.goal_ctx_uvar in + let uvars = FStarC_Syntax_Free.uvars t in + let uu___2 = + FStarC_Class_Setlike.for_all () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) + is_uvar_untyped_or_already_checked (Obj.magic uvars) in + if uu___2 + then skip_register + else + (let uu___4 = + let t1 = + let uu___5 = FStarC_Syntax_Util.un_squash t in + match uu___5 with + | FStar_Pervasives_Native.None -> t + | FStar_Pervasives_Native.Some t2 -> t2 in + FStarC_Syntax_Util.leftmost_head_and_args t1 in + match uu___4 with + | (head, args) -> + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Syntax_Util.un_uinst head in + FStarC_Syntax_Subst.compress uu___8 in + uu___7.FStarC_Syntax_Syntax.n in + (uu___6, args) in + (match uu___5 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (ty, uu___6)::(t1, uu___7)::(t2, uu___8)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.eq2_lid + -> + let uu___9 = + (is_allow_untyped_uvar t1) || + (is_allow_untyped_uvar t2) in + if uu___9 + then skip_register + else + (let uu___11 = + FStarC_Tactics_Monad.is_goal_safe_as_well_typed + g in + if uu___11 + then + let check_uvar_subtype u t3 = + let env1 = + let uu___12 = + FStarC_Tactics_Types.goal_env g in + { + FStarC_TypeChecker_Env.solver = + (uu___12.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (uu___12.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (uu___12.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + ((g.FStarC_Tactics_Types.goal_ctx_uvar).FStarC_Syntax_Syntax.ctx_uvar_gamma); + FStarC_TypeChecker_Env.gamma_sig = + (uu___12.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (uu___12.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (uu___12.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (uu___12.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (uu___12.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (uu___12.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (uu___12.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (uu___12.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (uu___12.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (uu___12.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (uu___12.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (uu___12.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (uu___12.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (uu___12.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (uu___12.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (uu___12.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (uu___12.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (uu___12.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (uu___12.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (uu___12.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (uu___12.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (uu___12.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (uu___12.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (uu___12.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (uu___12.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (uu___12.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (uu___12.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (uu___12.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (uu___12.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (uu___12.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (uu___12.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (uu___12.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (uu___12.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (uu___12.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (uu___12.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (uu___12.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (uu___12.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (uu___12.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (uu___12.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (uu___12.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (uu___12.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (uu___12.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (uu___12.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (uu___12.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (uu___12.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (uu___12.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (uu___12.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (uu___12.FStarC_TypeChecker_Env.missing_decl) + } in + let uu___12 = + FStarC_TypeChecker_Core.compute_term_type_handle_guards + env1 t3 + (fun uu___13 -> fun uu___14 -> true) in + match uu___12 with + | FStar_Pervasives.Inr uu___13 -> false + | FStar_Pervasives.Inl (uu___13, t_ty) -> + let uu___14 = + FStarC_TypeChecker_Core.check_term_subtyping + true true env1 ty t_ty in + (match uu___14 with + | FStar_Pervasives.Inl + (FStar_Pervasives_Native.None) -> + (FStarC_Tactics_Monad.mark_uvar_as_already_checked + u; + true) + | uu___15 -> false) in + let uu___12 = + let uu___13 = is_uvar t1 in + let uu___14 = is_uvar t2 in + (uu___13, uu___14) in + match uu___12 with + | (FStar_Pervasives.Inl (u, uu___13, tu), + FStar_Pervasives.Inr uu___14) -> + let uu___15 = check_uvar_subtype u tu in + (if uu___15 + then skip_register + else should_register) + | (FStar_Pervasives.Inr uu___13, + FStar_Pervasives.Inl (u, uu___14, tu)) -> + let uu___15 = check_uvar_subtype u tu in + (if uu___15 + then skip_register + else should_register) + | uu___13 -> should_register + else should_register) + | uu___6 -> should_register))) in + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___ -> + (fun g -> + let g = Obj.magic g in + let should_check = should_check_goal_uvar g in + (let uu___1 = should_register_trefl g in + if uu___1 then FStarC_Tactics_Monad.register_goal g else ()); + (let must_tot = true in + let attempt uu___2 uu___1 = + (fun l1 -> + fun r1 -> + let uu___1 = + let uu___2 = FStarC_Tactics_Types.goal_env g in + do_unify_maybe_guards allow_guards must_tot uu___2 + l1 r1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + match uu___2 with + | FStar_Pervasives_Native.None -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic false)) + | FStar_Pervasives_Native.Some guard -> + let uu___3 = + solve' g FStarC_Syntax_Util.exp_unit in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () + () uu___3 + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = + Obj.magic uu___4 in + if allow_guards + then + Obj.magic + (Obj.repr + (let uu___5 = + let uu___6 = + FStarC_Tactics_Types.goal_env + g in + let uu___7 = + guard_formula + guard in + FStarC_Tactics_Monad.goal_of_guard + "t_trefl" + uu___6 uu___7 + (FStar_Pervasives_Native.Some + should_check) + (rangeof g) in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic uu___5) + (fun uu___6 -> + (fun goal -> + let goal = + Obj.magic + goal in + let uu___6 + = + FStarC_Tactics_Monad.push_goals + [goal] in + Obj.magic + ( + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___6 + (fun + uu___7 -> + (fun + uu___7 -> + let uu___7 + = + Obj.magic + uu___7 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + true))) + uu___7))) + uu___6))) + else + Obj.magic + (Obj.repr + (let uu___6 = + FStarC_TypeChecker_Env.is_trivial_guard_formula + guard in + if uu___6 + then + Obj.repr + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + true)) + else + Obj.repr + (failwith + "internal error: _t_refl: guard is not trivial")))) + uu___4))) uu___2))) uu___2 + uu___1 in + let uu___1 = attempt l r in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + if uu___2 + then + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.repr ())) + else + (let norm1 = + let uu___3 = FStarC_Tactics_Types.goal_env g in + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.DontUnfoldAttr + [FStarC_Parser_Const.tac_opaque_attr]] + uu___3 in + let uu___3 = + let uu___4 = norm1 l in + let uu___5 = norm1 r in + attempt uu___4 uu___5 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___3) + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + if uu___4 + then + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () (Obj.repr ())) + else + (let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Tactics_Types.goal_env + g in + tts uu___7 in + FStarC_TypeChecker_Err.print_discrepancy + uu___6 l r in + match uu___5 with + | (ls, rs) -> + Obj.magic + (fail2 + "cannot unify (%s) and (%s)" + ls rs))) uu___4)))) + uu___2)))) uu___) +let (t_trefl : Prims.bool -> unit FStarC_Tactics_Monad.tac) = + fun allow_guards -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___3 -> + (fun g -> + let g = Obj.magic g in + let uu___3 = + let uu___4 = FStarC_Tactics_Types.goal_env g in + let uu___5 = FStarC_Tactics_Types.goal_type g in + destruct_eq uu___4 uu___5 in + match uu___3 with + | FStar_Pervasives_Native.Some (l, r) -> + Obj.magic (_t_trefl allow_guards l r) + | FStar_Pervasives_Native.None -> + let uu___4 = + let uu___5 = FStarC_Tactics_Types.goal_env g in + let uu___6 = FStarC_Tactics_Types.goal_type g in + tts uu___5 uu___6 in + Obj.magic (fail1 "not an equality (%s)" uu___4)) uu___3) in + FStarC_Tactics_Monad.catch uu___2 in + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + match uu___2 with + | FStar_Pervasives.Inr v -> + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac + () (Obj.repr ())) + | FStar_Pervasives.Inl exn -> + Obj.magic (FStarC_Tactics_Monad.traise exn)) uu___2) in + FStarC_Tactics_Monad.wrap_err "t_trefl" uu___ +let (dup : unit -> unit FStarC_Tactics_Monad.tac) = + fun uu___ -> + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___1 -> + (fun g -> + let g = Obj.magic g in + let goal_sc = should_check_goal_uvar g in + let env1 = FStarC_Tactics_Types.goal_env g in + let uu___1 = + let uu___2 = FStarC_Tactics_Types.goal_type g in + let uu___3 = + let uu___4 = should_check_goal_uvar g in + FStar_Pervasives_Native.Some uu___4 in + let uu___4 = FStarC_Tactics_Monad.goal_typedness_deps g in + FStarC_Tactics_Monad.new_uvar "dup" env1 uu___2 uu___3 uu___4 + (rangeof g) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac + () () (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + match uu___2 with + | (u, u_uvar) -> + (FStarC_Tactics_Monad.mark_uvar_as_already_checked + g.FStarC_Tactics_Types.goal_ctx_uvar; + (let g' = + { + FStarC_Tactics_Types.goal_main_env = + (g.FStarC_Tactics_Types.goal_main_env); + FStarC_Tactics_Types.goal_ctx_uvar = u_uvar; + FStarC_Tactics_Types.opts = + (g.FStarC_Tactics_Types.opts); + FStarC_Tactics_Types.is_guard = + (g.FStarC_Tactics_Types.is_guard); + FStarC_Tactics_Types.label = + (g.FStarC_Tactics_Types.label) + } in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + FStarC_Tactics_Monad.dismiss + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + let t_eq = + let uu___5 = + let uu___6 = + FStarC_Tactics_Types.goal_type + g in + env1.FStarC_TypeChecker_Env.universe_of + env1 uu___6 in + let uu___6 = + FStarC_Tactics_Types.goal_type g in + let uu___7 = + FStarC_Tactics_Types.goal_witness + g in + FStarC_Syntax_Util.mk_eq2 uu___5 + uu___6 u uu___7 in + let uu___5 = + FStarC_Tactics_Monad.add_irrelevant_goal + g "dup equation" env1 t_eq + (FStar_Pervasives_Native.Some + goal_sc) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___5 + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = + Obj.magic uu___6 in + Obj.magic + (FStarC_Tactics_Monad.add_goals + [g'])) uu___6))) + uu___4))))) uu___2))) uu___1) +let longest_prefix : + 'a . + ('a -> 'a -> Prims.bool) -> + 'a Prims.list -> + 'a Prims.list -> ('a Prims.list * 'a Prims.list * 'a Prims.list) + = + fun f -> + fun l1 -> + fun l2 -> + let rec aux acc l11 l21 = + match (l11, l21) with + | (x::xs, y::ys) -> + let uu___ = f x y in + if uu___ + then aux (x :: acc) xs ys + else (acc, (x :: xs), (y :: ys)) + | uu___ -> (acc, l11, l21) in + let uu___ = aux [] l1 l2 in + match uu___ with + | (pr, t1, t2) -> ((FStarC_Compiler_List.rev pr), t1, t2) +let (eq_binding : + FStarC_Syntax_Syntax.binding -> FStarC_Syntax_Syntax.binding -> Prims.bool) + = fun b1 -> fun b2 -> false +let (join_goals : + FStarC_Tactics_Types.goal -> + FStarC_Tactics_Types.goal -> + FStarC_Tactics_Types.goal FStarC_Tactics_Monad.tac) + = + fun uu___1 -> + fun uu___ -> + (fun g1 -> + fun g2 -> + let close_forall_no_univs bs f = + FStarC_Compiler_List.fold_right + (fun b -> + fun f1 -> + FStarC_Syntax_Util.mk_forall_no_univ + b.FStarC_Syntax_Syntax.binder_bv f1) bs f in + let uu___ = FStarC_Tactics_Monad.get_phi g1 in + match uu___ with + | FStar_Pervasives_Native.None -> + Obj.magic + (Obj.repr + (FStarC_Tactics_Monad.fail "goal 1 is not irrelevant")) + | FStar_Pervasives_Native.Some phi1 -> + Obj.magic + (Obj.repr + (let uu___1 = FStarC_Tactics_Monad.get_phi g2 in + match uu___1 with + | FStar_Pervasives_Native.None -> + Obj.repr + (FStarC_Tactics_Monad.fail + "goal 2 is not irrelevant") + | FStar_Pervasives_Native.Some phi2 -> + Obj.repr + (let gamma1 = + (g1.FStarC_Tactics_Types.goal_ctx_uvar).FStarC_Syntax_Syntax.ctx_uvar_gamma in + let gamma2 = + (g2.FStarC_Tactics_Types.goal_ctx_uvar).FStarC_Syntax_Syntax.ctx_uvar_gamma in + let uu___2 = + longest_prefix eq_binding + (FStarC_Compiler_List.rev gamma1) + (FStarC_Compiler_List.rev gamma2) in + match uu___2 with + | (gamma, r1, r2) -> + let t1 = + let uu___3 = + FStarC_TypeChecker_Env.binders_of_bindings + (FStarC_Compiler_List.rev r1) in + close_forall_no_univs uu___3 phi1 in + let t2 = + let uu___3 = + FStarC_TypeChecker_Env.binders_of_bindings + (FStarC_Compiler_List.rev r2) in + close_forall_no_univs uu___3 phi2 in + let goal_sc = + let uu___3 = + let uu___4 = should_check_goal_uvar g1 in + let uu___5 = should_check_goal_uvar g2 in + (uu___4, uu___5) in + match uu___3 with + | (FStarC_Syntax_Syntax.Allow_untyped + reason1, + FStarC_Syntax_Syntax.Allow_untyped + uu___4) -> + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Allow_untyped + reason1) + | uu___4 -> FStar_Pervasives_Native.None in + let ng = FStarC_Syntax_Util.mk_conj t1 t2 in + let nenv = + let uu___3 = + FStarC_Tactics_Types.goal_env g1 in + { + FStarC_TypeChecker_Env.solver = + (uu___3.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (uu___3.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (uu___3.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (FStarC_Compiler_List.rev gamma); + FStarC_TypeChecker_Env.gamma_sig = + (uu___3.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (uu___3.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (uu___3.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (uu___3.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (uu___3.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (uu___3.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (uu___3.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (uu___3.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (uu___3.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (uu___3.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (uu___3.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (uu___3.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (uu___3.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (uu___3.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (uu___3.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (uu___3.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (uu___3.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (uu___3.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (uu___3.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (uu___3.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (uu___3.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (uu___3.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (uu___3.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (uu___3.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (uu___3.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (uu___3.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (uu___3.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (uu___3.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (uu___3.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (uu___3.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (uu___3.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (uu___3.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (uu___3.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (uu___3.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (uu___3.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (uu___3.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (uu___3.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (uu___3.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (uu___3.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (uu___3.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (uu___3.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (uu___3.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (uu___3.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (uu___3.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (uu___3.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (uu___3.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (uu___3.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (uu___3.FStarC_TypeChecker_Env.missing_decl) + } in + let uu___3 = + FStarC_Tactics_Monad.mk_irrelevant_goal + "joined" nenv ng goal_sc (rangeof g1) + g1.FStarC_Tactics_Types.opts + g1.FStarC_Tactics_Types.label in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___3) + (fun uu___4 -> + (fun goal -> + let goal = Obj.magic goal in + let uu___4 = + FStarC_Tactics_Monad.if_verbose + (fun uu___5 -> + let uu___6 = + FStarC_Tactics_Printing.goal_to_string_verbose + g1 in + let uu___7 = + FStarC_Tactics_Printing.goal_to_string_verbose + g2 in + let uu___8 = + FStarC_Tactics_Printing.goal_to_string_verbose + goal in + FStarC_Compiler_Util.print3 + "join_goals of\n(%s)\nand\n(%s)\n= (%s)\n" + uu___6 uu___7 uu___8) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___4 + (fun uu___5 -> + (fun uu___5 -> + let uu___5 = + Obj.magic uu___5 in + let uu___6 = + set_solution g1 + FStarC_Syntax_Util.exp_unit in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___6 + (fun uu___7 -> + (fun uu___7 -> + let uu___7 = + Obj.magic + uu___7 in + let uu___8 = + set_solution + g2 + FStarC_Syntax_Util.exp_unit in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___8 + (fun + uu___9 -> + (fun + uu___9 -> + let uu___9 + = + Obj.magic + uu___9 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + goal))) + uu___9))) + uu___7))) uu___5))) + uu___4))))) uu___1 uu___ +let (join : unit -> unit FStarC_Tactics_Monad.tac) = + fun uu___ -> + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___1 -> + (fun ps -> + let ps = Obj.magic ps in + match ps.FStarC_Tactics_Types.goals with + | g1::g2::gs -> + let uu___1 = + FStarC_Tactics_Monad.set + { + FStarC_Tactics_Types.main_context = + (ps.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits = + (ps.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = gs; + FStarC_Tactics_Types.smt_goals = + (ps.FStarC_Tactics_Types.smt_goals); + FStarC_Tactics_Types.depth = + (ps.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = + (ps.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = + (ps.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (ps.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = + (ps.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness = + (ps.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg = + (ps.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = + (ps.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency = + (ps.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure = + (ps.FStarC_Tactics_Types.dump_on_failure) + } in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () uu___1 + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + let uu___3 = join_goals g1 g2 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___3) + (fun uu___4 -> + (fun g12 -> + let g12 = Obj.magic g12 in + Obj.magic + (FStarC_Tactics_Monad.add_goals [g12])) + uu___4))) uu___2)) + | uu___1 -> + Obj.magic + (FStarC_Tactics_Monad.fail "join: less than 2 goals")) + uu___1) +let (set_options : Prims.string -> unit FStarC_Tactics_Monad.tac) = + fun s -> + let uu___ = + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___1 -> + (fun g -> + let g = Obj.magic g in + FStarC_Options.push (); + FStarC_Options.set g.FStarC_Tactics_Types.opts; + (let res = FStarC_Options.set_options s in + let opts' = FStarC_Options.peek () in + FStarC_Options.pop (); + (match res with + | FStarC_Getopt.Success -> + let g' = + { + FStarC_Tactics_Types.goal_main_env = + (g.FStarC_Tactics_Types.goal_main_env); + FStarC_Tactics_Types.goal_ctx_uvar = + (g.FStarC_Tactics_Types.goal_ctx_uvar); + FStarC_Tactics_Types.opts = opts'; + FStarC_Tactics_Types.is_guard = + (g.FStarC_Tactics_Types.is_guard); + FStarC_Tactics_Types.label = + (g.FStarC_Tactics_Types.label) + } in + Obj.magic (FStarC_Tactics_Monad.replace_cur g') + | FStarC_Getopt.Error err -> + Obj.magic (fail2 "Setting options `%s` failed: %s" s err) + | FStarC_Getopt.Help -> + Obj.magic + (fail1 "Setting options `%s` failed (got `Help`?)" s)))) + uu___1) in + FStarC_Tactics_Monad.wrap_err "set_options" uu___ +let (top_env : unit -> env FStarC_Tactics_Monad.tac) = + fun uu___ -> + (fun uu___ -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___1 -> + (fun ps -> + let ps = Obj.magic ps in + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac + () (Obj.magic ps.FStarC_Tactics_Types.main_context))) + uu___1))) uu___ +let (lax_on : unit -> Prims.bool FStarC_Tactics_Monad.tac) = + fun uu___ -> + (fun uu___ -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___1 -> + (fun ps -> + let ps = Obj.magic ps in + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + (ps.FStarC_Tactics_Types.main_context).FStarC_TypeChecker_Env.admit))) + uu___1))) uu___ +let (unquote : + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term FStarC_Tactics_Monad.tac) + = + fun ty -> + fun tm -> + let uu___ = + let uu___1 = + FStarC_Tactics_Monad.if_verbose + (fun uu___2 -> + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term tm in + FStarC_Compiler_Util.print1 "unquote: tm = %s\n" uu___3) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () + () uu___1 + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___3 -> + (fun goal -> + let goal = Obj.magic goal in + let env1 = + let uu___3 = + FStarC_Tactics_Types.goal_env goal in + FStarC_TypeChecker_Env.set_expected_typ + uu___3 ty in + let uu___3 = __tc_ghost env1 tm in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___3) + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + match uu___4 with + | (tm1, typ, guard) -> + let uu___5 = + FStarC_Tactics_Monad.if_verbose + (fun uu___6 -> + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + tm1 in + FStarC_Compiler_Util.print1 + "unquote: tm' = %s\n" + uu___7) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___5 + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = + Obj.magic uu___6 in + let uu___7 = + FStarC_Tactics_Monad.if_verbose + (fun uu___8 -> + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + typ in + FStarC_Compiler_Util.print1 + "unquote: typ = %s\n" + uu___9) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___7 + (fun uu___8 -> + (fun uu___8 + -> + let uu___8 + = + Obj.magic + uu___8 in + let uu___9 + = + let uu___10 + = + let uu___11 + = + should_check_goal_uvar + goal in + FStar_Pervasives_Native.Some + uu___11 in + proc_guard + "unquote" + env1 + guard + uu___10 + (rangeof + goal) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___9 + (fun + uu___10 + -> + (fun + uu___10 + -> + let uu___10 + = + Obj.magic + uu___10 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + tm1))) + uu___10))) + uu___8))) + uu___6))) uu___4))) + uu___3))) uu___2)) in + FStarC_Tactics_Monad.wrap_err "unquote" uu___ +let (uvar_env : + env -> + FStarC_Syntax_Syntax.typ FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.term FStarC_Tactics_Monad.tac) + = + fun uu___1 -> + fun uu___ -> + (fun env1 -> + fun ty -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac + () () (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___ -> + (fun ps -> + let ps = Obj.magic ps in + let uu___ = + match ty with + | FStar_Pervasives_Native.Some ty1 -> + let env2 = + let uu___1 = + let uu___2 = FStarC_Syntax_Util.type_u () in + FStar_Pervasives_Native.fst uu___2 in + FStarC_TypeChecker_Env.set_expected_typ env1 + uu___1 in + let uu___1 = __tc_ghost env2 ty1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + match uu___2 with + | (ty2, uu___3, g) -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + (ty2, g, + (ty2.FStarC_Syntax_Syntax.pos))))) + uu___2)) + | FStar_Pervasives_Native.None -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.type_u () in + FStar_Pervasives_Native.fst uu___3 in + FStarC_Tactics_Monad.new_uvar "uvar_env.2" env1 + uu___2 FStar_Pervasives_Native.None [] + ps.FStarC_Tactics_Types.entry_range in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + match uu___2 with + | (typ, uvar_typ) -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + (typ, + FStarC_TypeChecker_Env.trivial_guard, + FStarC_Compiler_Range_Type.dummyRange)))) + uu___2)) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___) + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + match uu___1 with + | (typ, g, r) -> + let uu___2 = + proc_guard "uvar_env_typ" env1 g + FStar_Pervasives_Native.None r in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () + () uu___2 + (fun uu___3 -> + (fun uu___3 -> + let uu___3 = Obj.magic uu___3 in + let uu___4 = + FStarC_Tactics_Monad.new_uvar + "uvar_env" env1 typ + FStar_Pervasives_Native.None + [] + ps.FStarC_Tactics_Types.entry_range in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () (Obj.magic uu___4) + (fun uu___5 -> + (fun uu___5 -> + let uu___5 = + Obj.magic uu___5 in + match uu___5 with + | (t, uvar_t) -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + ( + Obj.magic + t))) + uu___5))) uu___3))) + uu___1))) uu___))) uu___1 uu___ +let (ghost_uvar_env : + env -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.term FStarC_Tactics_Monad.tac) + = + fun uu___1 -> + fun uu___ -> + (fun env1 -> + fun ty -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac + () () (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___ -> + (fun ps -> + let ps = Obj.magic ps in + let uu___ = __tc_ghost env1 ty in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___) + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + match uu___1 with + | (typ, uu___2, g) -> + let uu___3 = + proc_guard "ghost_uvar_env_typ" env1 g + FStar_Pervasives_Native.None + ty.FStarC_Syntax_Syntax.pos in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () + () uu___3 + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + let uu___5 = + FStarC_Tactics_Monad.new_uvar + "uvar_env" env1 typ + (FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Allow_ghost + "User ghost uvar")) + [] + ps.FStarC_Tactics_Types.entry_range in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () (Obj.magic uu___5) + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = + Obj.magic uu___6 in + match uu___6 with + | (t, uvar_t) -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + ( + Obj.magic + t))) + uu___6))) uu___4))) + uu___1))) uu___))) uu___1 uu___ +let (fresh_universe_uvar : + unit -> FStarC_Syntax_Syntax.term FStarC_Tactics_Monad.tac) = + fun uu___ -> + (fun uu___ -> + let uu___1 = + let uu___2 = FStarC_Syntax_Util.type_u () in + FStar_Pervasives_Native.fst uu___2 in + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () + (Obj.magic uu___1))) uu___ +let (unshelve : FStarC_Syntax_Syntax.term -> unit FStarC_Tactics_Monad.tac) = + fun t -> + let uu___ = + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___1 -> + (fun ps -> + let ps = Obj.magic ps in + let env1 = ps.FStarC_Tactics_Types.main_context in + let opts = + match ps.FStarC_Tactics_Types.goals with + | g::uu___1 -> g.FStarC_Tactics_Types.opts + | uu___1 -> FStarC_Options.peek () in + let uu___1 = FStarC_Syntax_Util.head_and_args t in + match uu___1 with + | ({ + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_uvar + (ctx_uvar, uu___2); + FStarC_Syntax_Syntax.pos = uu___3; + FStarC_Syntax_Syntax.vars = uu___4; + FStarC_Syntax_Syntax.hash_code = uu___5;_}, + uu___6) -> + let env2 = + { + FStarC_TypeChecker_Env.solver = + (env1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (ctx_uvar.FStarC_Syntax_Syntax.ctx_uvar_gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env1.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env1.FStarC_TypeChecker_Env.missing_decl) + } in + let g = + FStarC_Tactics_Types.mk_goal env2 ctx_uvar opts false "" in + let g1 = bnorm_goal g in + Obj.magic (FStarC_Tactics_Monad.add_goals [g1]) + | uu___2 -> Obj.magic (FStarC_Tactics_Monad.fail "not a uvar")) + uu___1) in + FStarC_Tactics_Monad.wrap_err "unshelve" uu___ +let (tac_and : + Prims.bool FStarC_Tactics_Monad.tac -> + Prims.bool FStarC_Tactics_Monad.tac -> + Prims.bool FStarC_Tactics_Monad.tac) + = + fun uu___1 -> + fun uu___ -> + (fun t1 -> + fun t2 -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac + () () (Obj.magic t1) + (fun uu___ -> + (fun uu___ -> + let uu___ = Obj.magic uu___ in + if uu___ + then Obj.magic (Obj.repr t2) + else + Obj.magic + (Obj.repr + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic false)))) uu___))) uu___1 uu___ +let default_if_err : + 'a . 'a -> 'a FStarC_Tactics_Monad.tac -> 'a FStarC_Tactics_Monad.tac = + fun uu___1 -> + fun uu___ -> + (fun def -> + fun t -> + let uu___ = FStarC_Tactics_Monad.catch t in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac + () () (Obj.magic uu___) + (fun uu___1 -> + (fun r -> + let r = Obj.magic r in + match r with + | FStar_Pervasives.Inl uu___1 -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic def)) + | FStar_Pervasives.Inr v -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic v))) uu___1))) uu___1 uu___ +let (match_env : + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> Prims.bool FStarC_Tactics_Monad.tac) + = + fun e -> + fun t1 -> + fun t2 -> + let uu___ = + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () + () (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___1 -> + (fun ps -> + let ps = Obj.magic ps in + let uu___1 = __tc e t1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + match uu___2 with + | (t11, ty1, g1) -> + let uu___3 = __tc e t2 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___3) + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + match uu___4 with + | (t21, ty2, g2) -> + let uu___5 = + proc_guard + "match_env g1" e g1 + FStar_Pervasives_Native.None + ps.FStarC_Tactics_Types.entry_range in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___5 + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = + Obj.magic + uu___6 in + let uu___7 = + proc_guard + "match_env g2" + e g2 + FStar_Pervasives_Native.None + ps.FStarC_Tactics_Types.entry_range in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___7 + (fun + uu___8 -> + (fun + uu___8 -> + let uu___8 + = + Obj.magic + uu___8 in + let must_tot + = true in + let uu___9 + = + let uu___10 + = + do_match + must_tot + e ty1 ty2 in + let uu___11 + = + do_match + must_tot + e t11 t21 in + tac_and + uu___10 + uu___11 in + Obj.magic + (default_if_err + false + uu___9)) + uu___8))) + uu___6))) uu___4))) + uu___2))) uu___1)) in + FStarC_Tactics_Monad.wrap_err "match_env" uu___ +let (unify_env : + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> Prims.bool FStarC_Tactics_Monad.tac) + = + fun e -> + fun t1 -> + fun t2 -> + let uu___ = + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () + () (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___1 -> + (fun ps -> + let ps = Obj.magic ps in + let uu___1 = __tc e t1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + match uu___2 with + | (t11, ty1, g1) -> + let uu___3 = __tc e t2 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___3) + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + match uu___4 with + | (t21, ty2, g2) -> + let uu___5 = + proc_guard + "unify_env g1" e g1 + FStar_Pervasives_Native.None + ps.FStarC_Tactics_Types.entry_range in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___5 + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = + Obj.magic + uu___6 in + let uu___7 = + proc_guard + "unify_env g2" + e g2 + FStar_Pervasives_Native.None + ps.FStarC_Tactics_Types.entry_range in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___7 + (fun + uu___8 -> + (fun + uu___8 -> + let uu___8 + = + Obj.magic + uu___8 in + let must_tot + = true in + let uu___9 + = + let uu___10 + = + do_unify + must_tot + e ty1 ty2 in + let uu___11 + = + do_unify + must_tot + e t11 t21 in + tac_and + uu___10 + uu___11 in + Obj.magic + (default_if_err + false + uu___9)) + uu___8))) + uu___6))) uu___4))) + uu___2))) uu___1)) in + FStarC_Tactics_Monad.wrap_err "unify_env" uu___ +let (unify_guard_env : + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> Prims.bool FStarC_Tactics_Monad.tac) + = + fun e -> + fun t1 -> + fun t2 -> + let uu___ = + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () + () (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___1 -> + (fun ps -> + let ps = Obj.magic ps in + let uu___1 = __tc e t1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + match uu___2 with + | (t11, ty1, g1) -> + let uu___3 = __tc e t2 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___3) + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + match uu___4 with + | (t21, ty2, g2) -> + let uu___5 = + proc_guard + "unify_guard_env g1" e + g1 + FStar_Pervasives_Native.None + ps.FStarC_Tactics_Types.entry_range in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___5 + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = + Obj.magic + uu___6 in + let uu___7 = + proc_guard + "unify_guard_env g2" + e g2 + FStar_Pervasives_Native.None + ps.FStarC_Tactics_Types.entry_range in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___7 + (fun + uu___8 -> + (fun + uu___8 -> + let uu___8 + = + Obj.magic + uu___8 in + let must_tot + = true in + let uu___9 + = + do_unify_maybe_guards + true + must_tot + e ty1 ty2 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic + uu___9) + (fun + uu___10 + -> + (fun + uu___10 + -> + let uu___10 + = + Obj.magic + uu___10 in + match uu___10 + with + | + FStar_Pervasives_Native.None + -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + false)) + | + FStar_Pervasives_Native.Some + g11 -> + let uu___11 + = + do_unify_maybe_guards + true + must_tot + e t11 t21 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic + uu___11) + (fun + uu___12 + -> + (fun + uu___12 + -> + let uu___12 + = + Obj.magic + uu___12 in + match uu___12 + with + | + FStar_Pervasives_Native.None + -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + false)) + | + FStar_Pervasives_Native.Some + g21 -> + let formula + = + let uu___13 + = + guard_formula + g11 in + let uu___14 + = + guard_formula + g21 in + FStarC_Syntax_Util.mk_conj + uu___13 + uu___14 in + let uu___13 + = + FStarC_Tactics_Monad.goal_of_guard + "unify_guard_env.g2" + e formula + FStar_Pervasives_Native.None + ps.FStarC_Tactics_Types.entry_range in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic + uu___13) + (fun + uu___14 + -> + (fun goal + -> + let goal + = + Obj.magic + goal in + let uu___14 + = + FStarC_Tactics_Monad.push_goals + [goal] in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___14 + (fun + uu___15 + -> + (fun + uu___15 + -> + let uu___15 + = + Obj.magic + uu___15 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + true))) + uu___15))) + uu___14))) + uu___12))) + uu___10))) + uu___8))) + uu___6))) uu___4))) + uu___2))) uu___1)) in + FStarC_Tactics_Monad.wrap_err "unify_guard_env" uu___ +let (launch_process : + Prims.string -> + Prims.string Prims.list -> + Prims.string -> Prims.string FStarC_Tactics_Monad.tac) + = + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun prog -> + fun args -> + fun input -> + let uu___ = + FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () + (Obj.repr ()) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + let uu___2 = FStarC_Options.unsafe_tactic_exec () in + if uu___2 + then + Obj.magic + (Obj.repr + (let s = + FStarC_Compiler_Util.run_process + "tactic_launch" prog args + (FStar_Pervasives_Native.Some input) in + FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic s))) + else + Obj.magic + (Obj.repr + (FStarC_Tactics_Monad.fail + "launch_process: will not run anything unless --unsafe_tactic_exec is provided"))) + uu___1))) uu___2 uu___1 uu___ +let (fresh_bv_named : + Prims.string -> FStarC_Syntax_Syntax.bv FStarC_Tactics_Monad.tac) = + fun uu___ -> + (fun nm -> + let uu___ = + FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () + (Obj.repr ()) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + let uu___2 = + FStarC_Syntax_Syntax.gen_bv nm + FStar_Pervasives_Native.None FStarC_Syntax_Syntax.tun in + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac + () (Obj.magic uu___2))) uu___1))) uu___ +let (change : FStarC_Syntax_Syntax.typ -> unit FStarC_Tactics_Monad.tac) = + fun ty -> + let uu___ = + let uu___1 = + FStarC_Tactics_Monad.if_verbose + (fun uu___2 -> + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term ty in + FStarC_Compiler_Util.print1 "change: ty = %s\n" uu___3) in + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + uu___1 + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___3 -> + (fun g -> + let g = Obj.magic g in + let uu___3 = + let uu___4 = FStarC_Tactics_Types.goal_env g in + __tc uu___4 ty in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___3) + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + match uu___4 with + | (ty1, uu___5, guard) -> + let uu___6 = + let uu___7 = + FStarC_Tactics_Types.goal_env g in + let uu___8 = + let uu___9 = + should_check_goal_uvar g in + FStar_Pervasives_Native.Some + uu___9 in + proc_guard "change" uu___7 guard + uu___8 (rangeof g) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () uu___6 + (fun uu___7 -> + (fun uu___7 -> + let uu___7 = + Obj.magic uu___7 in + let must_tot = true in + let uu___8 = + let uu___9 = + FStarC_Tactics_Types.goal_env + g in + let uu___10 = + FStarC_Tactics_Types.goal_type + g in + do_unify must_tot uu___9 + uu___10 ty1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic uu___8) + (fun uu___9 -> + (fun bb -> + let bb = + Obj.magic bb in + if bb + then + let uu___9 = + FStarC_Tactics_Monad.goal_with_type + g ty1 in + Obj.magic + (FStarC_Tactics_Monad.replace_cur + uu___9) + else + (let steps = + [FStarC_TypeChecker_Env.AllowUnboundUniverses; + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.Primops] in + let ng = + let uu___10 + = + FStarC_Tactics_Types.goal_env + g in + let uu___11 + = + FStarC_Tactics_Types.goal_type + g in + normalize + steps + uu___10 + uu___11 in + let nty = + let uu___10 + = + FStarC_Tactics_Types.goal_env + g in + normalize + steps + uu___10 + ty1 in + let uu___10 + = + let uu___11 + = + FStarC_Tactics_Types.goal_env + g in + do_unify + must_tot + uu___11 + ng nty in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic + uu___10) + (fun + uu___11 + -> + (fun b -> + let b = + Obj.magic + b in + if b + then + let uu___11 + = + FStarC_Tactics_Monad.goal_with_type + g ty1 in + Obj.magic + (FStarC_Tactics_Monad.replace_cur + uu___11) + else + Obj.magic + (FStarC_Tactics_Monad.fail + "not convertible")) + uu___11)))) + uu___9))) uu___7))) + uu___4))) uu___3))) uu___2) in + FStarC_Tactics_Monad.wrap_err "change" uu___ +let (failwhen : Prims.bool -> Prims.string -> unit FStarC_Tactics_Monad.tac) + = + fun b -> + fun msg -> + if b + then FStarC_Tactics_Monad.fail msg + else + FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () + (Obj.repr ()) +let (t_destruct : + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.fv * FStarC_BigInt.t) Prims.list + FStarC_Tactics_Monad.tac) + = + fun s_tm -> + let uu___ = + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___1 -> + (fun g -> + let g = Obj.magic g in + let uu___1 = + let uu___2 = FStarC_Tactics_Types.goal_env g in + __tc uu___2 s_tm in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + match uu___2 with + | (s_tm1, s_ty, guard) -> + let uu___3 = + let uu___4 = + FStarC_Tactics_Types.goal_env g in + let uu___5 = + let uu___6 = should_check_goal_uvar g in + FStar_Pervasives_Native.Some uu___6 in + proc_guard "destruct" uu___4 guard uu___5 + (rangeof g) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + uu___3 + (fun uu___4 -> + (fun uu___4 -> + let uu___4 = Obj.magic uu___4 in + let s_ty1 = + let uu___5 = + FStarC_Tactics_Types.goal_env + g in + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.DontUnfoldAttr + [FStarC_Parser_Const.tac_opaque_attr]; + FStarC_TypeChecker_Env.Weak; + FStarC_TypeChecker_Env.HNF; + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant] + uu___5 s_ty in + let uu___5 = + let uu___6 = + FStarC_Syntax_Util.unrefine + s_ty1 in + FStarC_Syntax_Util.head_and_args_full + uu___6 in + match uu___5 with + | (h, args) -> + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Subst.compress + h in + uu___8.FStarC_Syntax_Syntax.n in + match uu___7 with + | FStarC_Syntax_Syntax.Tm_fvar + fv -> + Obj.magic + (Obj.repr + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + (fv, [])))) + | FStarC_Syntax_Syntax.Tm_uinst + (h', us) -> + Obj.magic + (Obj.repr + (let uu___8 = + let uu___9 = + FStarC_Syntax_Subst.compress + h' in + uu___9.FStarC_Syntax_Syntax.n in + match uu___8 with + | FStarC_Syntax_Syntax.Tm_fvar + fv -> + Obj.repr + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + ( + Obj.magic + (fv, us))) + | uu___9 -> + Obj.repr + (failwith + "impossible: uinst over something that's not an fvar"))) + | uu___8 -> + Obj.magic + (Obj.repr + (FStarC_Tactics_Monad.fail + "type is not an fv")) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () (Obj.magic uu___6) + (fun uu___7 -> + (fun uu___7 -> + let uu___7 = + Obj.magic uu___7 in + match uu___7 with + | (fv, a_us) -> + let t_lid = + FStarC_Syntax_Syntax.lid_of_fv + fv in + let uu___8 = + let uu___9 = + FStarC_Tactics_Types.goal_env + g in + FStarC_TypeChecker_Env.lookup_sigelt + uu___9 + t_lid in + (match uu___8 + with + | FStar_Pervasives_Native.None + -> + Obj.magic + (Obj.repr + (FStarC_Tactics_Monad.fail + "type not found in environment")) + | FStar_Pervasives_Native.Some + se -> + Obj.magic + (Obj.repr + (match + se.FStarC_Syntax_Syntax.sigel + with + | + FStarC_Syntax_Syntax.Sig_inductive_typ + { + FStarC_Syntax_Syntax.lid + = uu___9; + FStarC_Syntax_Syntax.us + = t_us; + FStarC_Syntax_Syntax.params + = t_ps; + FStarC_Syntax_Syntax.num_uniform_params + = uu___10; + FStarC_Syntax_Syntax.t + = t_ty; + FStarC_Syntax_Syntax.mutuals + = mut; + FStarC_Syntax_Syntax.ds + = c_lids; + FStarC_Syntax_Syntax.injective_type_params + = uu___11;_} + -> + Obj.repr + (let erasable + = + FStarC_Syntax_Util.has_attribute + se.FStarC_Syntax_Syntax.sigattrs + FStarC_Parser_Const.erasable_attr in + let uu___12 + = + let uu___13 + = + erasable + && + (let uu___14 + = + FStarC_Tactics_Monad.is_irrelevant + g in + Prims.op_Negation + uu___14) in + failwhen + uu___13 + "cannot destruct erasable type to solve proof-relevant goal" in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___12 + (fun + uu___13 + -> + (fun + uu___13 + -> + let uu___13 + = + Obj.magic + uu___13 in + let uu___14 + = + failwhen + ((FStarC_Compiler_List.length + a_us) <> + (FStarC_Compiler_List.length + t_us)) + "t_us don't match?" in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___14 + (fun + uu___15 + -> + (fun + uu___15 + -> + let uu___15 + = + Obj.magic + uu___15 in + let uu___16 + = + FStarC_Syntax_Subst.open_term + t_ps t_ty in + match uu___16 + with + | + (t_ps1, + t_ty1) -> + let uu___17 + = + Obj.magic + (FStarC_Class_Monad.mapM + FStarC_Tactics_Monad.monad_tac + () () + (fun + uu___18 + -> + (fun + c_lid -> + let c_lid + = + Obj.magic + c_lid in + let uu___18 + = + let uu___19 + = + FStarC_Tactics_Types.goal_env + g in + FStarC_TypeChecker_Env.lookup_sigelt + uu___19 + c_lid in + match uu___18 + with + | + FStar_Pervasives_Native.None + -> + Obj.magic + (Obj.repr + (FStarC_Tactics_Monad.fail + "ctor not found?")) + | + FStar_Pervasives_Native.Some + se1 -> + Obj.magic + (Obj.repr + (match + se1.FStarC_Syntax_Syntax.sigel + with + | + FStarC_Syntax_Syntax.Sig_datacon + { + FStarC_Syntax_Syntax.lid1 + = uu___19; + FStarC_Syntax_Syntax.us1 + = c_us; + FStarC_Syntax_Syntax.t1 + = c_ty; + FStarC_Syntax_Syntax.ty_lid + = uu___20; + FStarC_Syntax_Syntax.num_ty_params + = nparam; + FStarC_Syntax_Syntax.mutuals1 + = mut1; + FStarC_Syntax_Syntax.injective_type_params1 + = uu___21;_} + -> + Obj.repr + (let qual + = + let fallback + uu___22 = + FStar_Pervasives_Native.Some + FStarC_Syntax_Syntax.Data_ctor in + let qninfo + = + let uu___22 + = + FStarC_Tactics_Types.goal_env + g in + FStarC_TypeChecker_Env.lookup_qname + uu___22 + c_lid in + match qninfo + with + | + FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr + (se2, + _us), + _rng) -> + FStarC_Syntax_DsEnv.fv_qual_of_se + se2 + | + uu___22 + -> + fallback + () in + let fv1 = + FStarC_Syntax_Syntax.lid_as_fv + c_lid + qual in + let uu___22 + = + failwhen + ((FStarC_Compiler_List.length + a_us) <> + (FStarC_Compiler_List.length + c_us)) + "t_us don't match?" in + FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___22 + (fun + uu___23 + -> + (fun + uu___23 + -> + let uu___23 + = + Obj.magic + uu___23 in + let s = + FStarC_TypeChecker_Env.mk_univ_subst + c_us a_us in + let c_ty1 + = + FStarC_Syntax_Subst.subst + s c_ty in + let uu___24 + = + FStarC_TypeChecker_Env.inst_tscheme + (c_us, + c_ty1) in + match uu___24 + with + | + (c_us1, + c_ty2) -> + let uu___25 + = + FStarC_Syntax_Util.arrow_formals_comp + c_ty2 in + (match uu___25 + with + | + (bs, + comp) -> + let uu___26 + = + let rename_bv + bv = + let ppname + = + bv.FStarC_Syntax_Syntax.ppname in + let ppname1 + = + let uu___27 + = + let uu___28 + = + let uu___29 + = + FStarC_Class_Show.show + FStarC_Ident.showable_ident + ppname in + Prims.strcat + "a" + uu___29 in + let uu___29 + = + FStarC_Ident.range_of_id + ppname in + (uu___28, + uu___29) in + FStarC_Ident.mk_ident + uu___27 in + FStarC_Syntax_Syntax.freshen_bv + { + FStarC_Syntax_Syntax.ppname + = ppname1; + FStarC_Syntax_Syntax.index + = + (bv.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort + = + (bv.FStarC_Syntax_Syntax.sort) + } in + let bs' = + FStarC_Compiler_List.map + (fun b -> + let uu___27 + = + rename_bv + b.FStarC_Syntax_Syntax.binder_bv in + { + FStarC_Syntax_Syntax.binder_bv + = uu___27; + FStarC_Syntax_Syntax.binder_qual + = + (b.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity + = + (b.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs + = + (b.FStarC_Syntax_Syntax.binder_attrs) + }) bs in + let subst + = + FStarC_Compiler_List.map2 + (fun + uu___27 + -> + fun + uu___28 + -> + match + (uu___27, + uu___28) + with + | + ({ + FStarC_Syntax_Syntax.binder_bv + = bv; + FStarC_Syntax_Syntax.binder_qual + = uu___29; + FStarC_Syntax_Syntax.binder_positivity + = uu___30; + FStarC_Syntax_Syntax.binder_attrs + = uu___31;_}, + { + FStarC_Syntax_Syntax.binder_bv + = bv'; + FStarC_Syntax_Syntax.binder_qual + = uu___32; + FStarC_Syntax_Syntax.binder_positivity + = uu___33; + FStarC_Syntax_Syntax.binder_attrs + = uu___34;_}) + -> + let uu___35 + = + let uu___36 + = + FStarC_Syntax_Syntax.bv_to_name + bv' in + (bv, + uu___36) in + FStarC_Syntax_Syntax.NT + uu___35) + bs bs' in + let uu___27 + = + FStarC_Syntax_Subst.subst_binders + subst bs' in + let uu___28 + = + FStarC_Syntax_Subst.subst_comp + subst + comp in + (uu___27, + uu___28) in + (match uu___26 + with + | + (bs1, + comp1) -> + let uu___27 + = + FStarC_Compiler_List.splitAt + nparam + bs1 in + (match uu___27 + with + | + (d_ps, + bs2) -> + let uu___28 + = + let uu___29 + = + let uu___30 + = + FStarC_Syntax_Util.is_total_comp + comp1 in + Prims.op_Negation + uu___30 in + failwhen + uu___29 + "not total?" in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___28 + (fun + uu___29 + -> + (fun + uu___29 + -> + let uu___29 + = + Obj.magic + uu___29 in + let mk_pat + p = + { + FStarC_Syntax_Syntax.v + = p; + FStarC_Syntax_Syntax.p + = + (s_tm1.FStarC_Syntax_Syntax.pos) + } in + let is_imp + uu___30 = + match uu___30 + with + | + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Implicit + uu___31) + -> true + | + uu___31 + -> false in + let uu___30 + = + FStarC_Compiler_List.splitAt + nparam + args in + match uu___30 + with + | + (a_ps, + a_is) -> + let uu___31 + = + failwhen + ((FStarC_Compiler_List.length + a_ps) <> + (FStarC_Compiler_List.length + d_ps)) + "params not match?" in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___31 + (fun + uu___32 + -> + (fun + uu___32 + -> + let uu___32 + = + Obj.magic + uu___32 in + let d_ps_a_ps + = + FStarC_Compiler_List.zip + d_ps a_ps in + let subst + = + FStarC_Compiler_List.map + (fun + uu___33 + -> + match uu___33 + with + | + ({ + FStarC_Syntax_Syntax.binder_bv + = bv; + FStarC_Syntax_Syntax.binder_qual + = uu___34; + FStarC_Syntax_Syntax.binder_positivity + = uu___35; + FStarC_Syntax_Syntax.binder_attrs + = uu___36;_}, + (t, + uu___37)) + -> + FStarC_Syntax_Syntax.NT + (bv, t)) + d_ps_a_ps in + let bs3 = + FStarC_Syntax_Subst.subst_binders + subst bs2 in + let subpats_1 + = + FStarC_Compiler_List.map + (fun + uu___33 + -> + match uu___33 + with + | + ({ + FStarC_Syntax_Syntax.binder_bv + = bv; + FStarC_Syntax_Syntax.binder_qual + = uu___34; + FStarC_Syntax_Syntax.binder_positivity + = uu___35; + FStarC_Syntax_Syntax.binder_attrs + = uu___36;_}, + (t, + uu___37)) + -> + ((mk_pat + (FStarC_Syntax_Syntax.Pat_dot_term + (FStar_Pervasives_Native.Some + t))), + true)) + d_ps_a_ps in + let subpats_2 + = + FStarC_Compiler_List.map + (fun + uu___33 + -> + match uu___33 + with + | + { + FStarC_Syntax_Syntax.binder_bv + = bv; + FStarC_Syntax_Syntax.binder_qual + = bq; + FStarC_Syntax_Syntax.binder_positivity + = uu___34; + FStarC_Syntax_Syntax.binder_attrs + = uu___35;_} + -> + ((mk_pat + (FStarC_Syntax_Syntax.Pat_var + bv)), + (is_imp + bq))) bs3 in + let subpats + = + FStarC_Compiler_List.op_At + subpats_1 + subpats_2 in + let pat = + mk_pat + (FStarC_Syntax_Syntax.Pat_cons + (fv1, + (FStar_Pervasives_Native.Some + a_us), + subpats)) in + let env1 + = + FStarC_Tactics_Types.goal_env + g in + let cod = + FStarC_Tactics_Types.goal_type + g in + let equ = + env1.FStarC_TypeChecker_Env.universe_of + env1 + s_ty1 in + let uu___33 + = + FStarC_TypeChecker_TcTerm.tc_pat + { + FStarC_TypeChecker_Env.solver + = + (env1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range + = + (env1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule + = + (env1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma + = + (env1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig + = + (env1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache + = + (env1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules + = + (env1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ + = + (env1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab + = + (env1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab + = + (env1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp + = + (env1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects + = + (env1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize + = + (env1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs + = + (env1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level + = + (env1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars + = + (env1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict + = + (env1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface + = + (env1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit + = true; + FStarC_TypeChecker_Env.lax_universes + = + (env1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 + = + (env1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard + = + (env1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking + = + (env1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping + = + (env1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics + = + (env1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce + = + (env1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term + = + (env1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (env1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of + = + (env1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force + = + (env1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (env1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (env1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (env1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths + = + (env1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns + = + (env1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook + = + (env1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (env1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice + = + (env1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess + = + (env1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess + = + (env1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info + = + (env1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks + = + (env1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv + = + (env1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe + = + (env1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab + = + (env1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (env1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (env1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (env1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (env1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check + = + (env1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl + = + (env1.FStarC_TypeChecker_Env.missing_decl) + } s_ty1 + pat in + match uu___33 + with + | + (uu___34, + uu___35, + uu___36, + uu___37, + pat_t, + uu___38, + _guard_pat, + _erasable) + -> + let eq_b + = + let uu___39 + = + let uu___40 + = + FStarC_Syntax_Util.mk_eq2 + equ s_ty1 + s_tm1 + pat_t in + FStarC_Syntax_Util.mk_squash + FStarC_Syntax_Syntax.U_zero + uu___40 in + FStarC_Syntax_Syntax.gen_bv + "breq" + FStar_Pervasives_Native.None + uu___39 in + let cod1 + = + let uu___39 + = + let uu___40 + = + FStarC_Syntax_Syntax.mk_binder + eq_b in + [uu___40] in + let uu___40 + = + FStarC_Syntax_Syntax.mk_Total + cod in + FStarC_Syntax_Util.arrow + uu___39 + uu___40 in + let nty = + let uu___39 + = + FStarC_Syntax_Syntax.mk_Total + cod1 in + FStarC_Syntax_Util.arrow + bs3 + uu___39 in + let uu___39 + = + let uu___40 + = + FStarC_Tactics_Monad.goal_typedness_deps + g in + FStarC_Tactics_Monad.new_uvar + "destruct branch" + env1 nty + FStar_Pervasives_Native.None + uu___40 + (rangeof + g) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic + uu___39) + (fun + uu___40 + -> + (fun + uu___40 + -> + let uu___40 + = + Obj.magic + uu___40 in + match uu___40 + with + | + (uvt, uv) + -> + let g' = + FStarC_Tactics_Types.mk_goal + env1 uv + g.FStarC_Tactics_Types.opts + false + g.FStarC_Tactics_Types.label in + let brt = + FStarC_Syntax_Util.mk_app_binders + uvt bs3 in + let brt1 + = + let uu___41 + = + let uu___42 + = + FStarC_Syntax_Syntax.as_arg + FStarC_Syntax_Util.exp_unit in + [uu___42] in + FStarC_Syntax_Util.mk_app + brt + uu___41 in + let br = + FStarC_Syntax_Subst.close_branch + (pat, + FStar_Pervasives_Native.None, + brt1) in + let uu___41 + = + let uu___42 + = + let uu___43 + = + FStarC_BigInt.of_int_fs + (FStarC_Compiler_List.length + bs3) in + (fv1, + uu___43) in + (g', br, + uu___42) in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + uu___41))) + uu___40))) + uu___32))) + uu___29)))))) + uu___23)) + | + uu___19 + -> + Obj.repr + (FStarC_Tactics_Monad.fail + "impossible: not a ctor")))) + uu___18) + (Obj.magic + c_lids)) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + (Obj.magic + uu___17) + (fun + uu___18 + -> + (fun + goal_brs + -> + let goal_brs + = + Obj.magic + goal_brs in + let uu___18 + = + FStarC_Compiler_List.unzip3 + goal_brs in + match uu___18 + with + | + (goals, + brs, + infos) -> + let w = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_match + { + FStarC_Syntax_Syntax.scrutinee + = s_tm1; + FStarC_Syntax_Syntax.ret_opt + = + FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.brs + = brs; + FStarC_Syntax_Syntax.rc_opt1 + = + FStar_Pervasives_Native.None + }) + s_tm1.FStarC_Syntax_Syntax.pos in + let uu___19 + = + solve' g + w in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___19 + (fun + uu___20 + -> + (fun + uu___20 + -> + let uu___20 + = + Obj.magic + uu___20 in + FStarC_Tactics_Monad.mark_goal_implicit_already_checked + g; + ( + let uu___22 + = + FStarC_Tactics_Monad.add_goals + goals in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac + () () + uu___22 + (fun + uu___23 + -> + (fun + uu___23 + -> + let uu___23 + = + Obj.magic + uu___23 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + infos))) + uu___23)))) + uu___20))) + uu___18))) + uu___15))) + uu___13)) + | + uu___9 -> + Obj.repr + (FStarC_Tactics_Monad.fail + "not an inductive type"))))) + uu___7))) uu___4))) + uu___2))) uu___1)) in + FStarC_Tactics_Monad.wrap_err "destruct" uu___ +let (gather_explicit_guards_for_resolved_goals : + unit -> unit FStarC_Tactics_Monad.tac) = + fun uu___ -> + FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () (Obj.repr ()) +let rec last : 'a . 'a Prims.list -> 'a = + fun l -> + match l with + | [] -> failwith "last: empty list" + | x::[] -> x + | uu___::xs -> last xs +let rec init : 'a . 'a Prims.list -> 'a Prims.list = + fun l -> + match l with + | [] -> failwith "init: empty list" + | x::[] -> [] + | x::xs -> let uu___ = init xs in x :: uu___ +let (lget : + FStarC_Syntax_Syntax.typ -> + Prims.string -> FStarC_Syntax_Syntax.term FStarC_Tactics_Monad.tac) + = + fun ty -> + fun k -> + let uu___ = + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () + () (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___1 -> + (fun ps -> + let ps = Obj.magic ps in + let uu___1 = + FStarC_Compiler_Util.psmap_try_find + ps.FStarC_Tactics_Types.local_state k in + match uu___1 with + | FStar_Pervasives_Native.None -> + Obj.magic (FStarC_Tactics_Monad.fail "not found") + | FStar_Pervasives_Native.Some t -> + Obj.magic (unquote ty t)) uu___1)) in + FStarC_Tactics_Monad.wrap_err "lget" uu___ +let (lset : + FStarC_Syntax_Syntax.typ -> + Prims.string -> + FStarC_Syntax_Syntax.term -> unit FStarC_Tactics_Monad.tac) + = + fun _ty -> + fun k -> + fun t -> + let uu___ = + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___1 -> + (fun ps -> + let ps = Obj.magic ps in + let ps1 = + let uu___1 = + FStarC_Compiler_Util.psmap_add + ps.FStarC_Tactics_Types.local_state k t in + { + FStarC_Tactics_Types.main_context = + (ps.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits = + (ps.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = + (ps.FStarC_Tactics_Types.goals); + FStarC_Tactics_Types.smt_goals = + (ps.FStarC_Tactics_Types.smt_goals); + FStarC_Tactics_Types.depth = + (ps.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = + (ps.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = + (ps.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (ps.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = + (ps.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness = + (ps.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg = + (ps.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = uu___1; + FStarC_Tactics_Types.urgency = + (ps.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure = + (ps.FStarC_Tactics_Types.dump_on_failure) + } in + Obj.magic (FStarC_Tactics_Monad.set ps1)) uu___1) in + FStarC_Tactics_Monad.wrap_err "lset" uu___ +let (set_urgency : FStarC_BigInt.t -> unit FStarC_Tactics_Monad.tac) = + fun u -> + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___ -> + (fun ps -> + let ps = Obj.magic ps in + let ps1 = + let uu___ = FStarC_BigInt.to_int_fs u in + { + FStarC_Tactics_Types.main_context = + (ps.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits = + (ps.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = (ps.FStarC_Tactics_Types.goals); + FStarC_Tactics_Types.smt_goals = + (ps.FStarC_Tactics_Types.smt_goals); + FStarC_Tactics_Types.depth = (ps.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = + (ps.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = (ps.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (ps.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = + (ps.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness = + (ps.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg = + (ps.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = + (ps.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency = uu___; + FStarC_Tactics_Types.dump_on_failure = + (ps.FStarC_Tactics_Types.dump_on_failure) + } in + Obj.magic (FStarC_Tactics_Monad.set ps1)) uu___) +let (set_dump_on_failure : Prims.bool -> unit FStarC_Tactics_Monad.tac) = + fun b -> + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___ -> + (fun ps -> + let ps = Obj.magic ps in + let ps1 = + { + FStarC_Tactics_Types.main_context = + (ps.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits = + (ps.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = (ps.FStarC_Tactics_Types.goals); + FStarC_Tactics_Types.smt_goals = + (ps.FStarC_Tactics_Types.smt_goals); + FStarC_Tactics_Types.depth = (ps.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = + (ps.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = (ps.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (ps.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = + (ps.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness = + (ps.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg = + (ps.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = + (ps.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency = + (ps.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure = b + } in + Obj.magic (FStarC_Tactics_Monad.set ps1)) uu___) +let (t_commute_applied_match : unit -> unit FStarC_Tactics_Monad.tac) = + fun uu___ -> + let uu___1 = + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___2 -> + (fun g -> + let g = Obj.magic g in + let uu___2 = + let uu___3 = FStarC_Tactics_Types.goal_env g in + let uu___4 = FStarC_Tactics_Types.goal_type g in + destruct_eq uu___3 uu___4 in + match uu___2 with + | FStar_Pervasives_Native.Some (l, r) -> + let uu___3 = FStarC_Syntax_Util.head_and_args_full l in + (match uu___3 with + | (lh, las) -> + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Syntax_Util.unascribe lh in + FStarC_Syntax_Subst.compress uu___6 in + uu___5.FStarC_Syntax_Syntax.n in + (match uu___4 with + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = e; + FStarC_Syntax_Syntax.ret_opt = asc_opt; + FStarC_Syntax_Syntax.brs = brs; + FStarC_Syntax_Syntax.rc_opt1 = lopt;_} + -> + let brs' = + FStarC_Compiler_List.map + (fun uu___5 -> + match uu___5 with + | (p, w, e1) -> + let uu___6 = + FStarC_Syntax_Util.mk_app e1 las in + (p, w, uu___6)) brs in + let lopt' = + FStarC_Compiler_Util.map_option + (fun rc -> + let uu___5 = + FStarC_Compiler_Util.map_option + (fun t -> + let uu___6 = + let uu___7 = + FStarC_Tactics_Types.goal_env g in + FStarC_TypeChecker_Normalize.get_n_binders + uu___7 + (FStarC_Compiler_List.length + las) t in + match uu___6 with + | (bs, c) -> + let uu___7 = + FStarC_Syntax_Subst.open_comp + bs c in + (match uu___7 with + | (bs1, c1) -> + let ss = + FStarC_Compiler_List.map2 + (fun b -> + fun a -> + FStarC_Syntax_Syntax.NT + ((b.FStarC_Syntax_Syntax.binder_bv), + (FStar_Pervasives_Native.fst + a))) bs1 + las in + let c2 = + FStarC_Syntax_Subst.subst_comp + ss c1 in + FStarC_Syntax_Util.comp_result + c2)) + rc.FStarC_Syntax_Syntax.residual_typ in + { + FStarC_Syntax_Syntax.residual_effect = + (rc.FStarC_Syntax_Syntax.residual_effect); + FStarC_Syntax_Syntax.residual_typ = + uu___5; + FStarC_Syntax_Syntax.residual_flags = + (rc.FStarC_Syntax_Syntax.residual_flags) + }) lopt in + let l' = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_match + { + FStarC_Syntax_Syntax.scrutinee = e; + FStarC_Syntax_Syntax.ret_opt = asc_opt; + FStarC_Syntax_Syntax.brs = brs'; + FStarC_Syntax_Syntax.rc_opt1 = lopt' + }) l.FStarC_Syntax_Syntax.pos in + let must_tot = true in + let uu___5 = + let uu___6 = FStarC_Tactics_Types.goal_env g in + do_unify_maybe_guards false must_tot uu___6 l' + r in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___5) + (fun uu___6 -> + (fun uu___6 -> + let uu___6 = Obj.magic uu___6 in + match uu___6 with + | FStar_Pervasives_Native.None -> + Obj.magic + (FStarC_Tactics_Monad.fail + "discharging the equality failed") + | FStar_Pervasives_Native.Some guard + -> + let uu___7 = + FStarC_TypeChecker_Env.is_trivial_guard_formula + guard in + if uu___7 + then + (FStarC_Tactics_Monad.mark_uvar_as_already_checked + g.FStarC_Tactics_Types.goal_ctx_uvar; + Obj.magic + (solve g + FStarC_Syntax_Util.exp_unit)) + else + Obj.magic + (failwith + "internal error: _t_refl: guard is not trivial")) + uu___6)) + | uu___5 -> + Obj.magic + (FStarC_Tactics_Monad.fail "lhs is not a match"))) + | FStar_Pervasives_Native.None -> + Obj.magic (FStarC_Tactics_Monad.fail "not an equality")) + uu___2) in + FStarC_Tactics_Monad.wrap_err "t_commute_applied_match" uu___1 +let (string_to_term : + env -> Prims.string -> FStarC_Syntax_Syntax.term FStarC_Tactics_Monad.tac) + = + fun e -> + fun s -> + let frag_of_text s1 = + { + FStarC_Parser_ParseIt.frag_fname = ""; + FStarC_Parser_ParseIt.frag_text = s1; + FStarC_Parser_ParseIt.frag_line = Prims.int_one; + FStarC_Parser_ParseIt.frag_col = Prims.int_zero + } in + let uu___ = + FStarC_Parser_ParseIt.parse FStar_Pervasives_Native.None + (FStarC_Parser_ParseIt.Fragment (frag_of_text s)) in + match uu___ with + | FStarC_Parser_ParseIt.Term t -> + let dsenv = + let uu___1 = FStarC_TypeChecker_Env.current_module e in + FStarC_Syntax_DsEnv.set_current_module + e.FStarC_TypeChecker_Env.dsenv uu___1 in + (try + (fun uu___1 -> + (fun uu___1 -> + match () with + | () -> + let uu___2 = + FStarC_ToSyntax_ToSyntax.desugar_term dsenv t in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic uu___2))) uu___1) () + with + | FStarC_Errors.Error (uu___2, e1, uu___3, uu___4) -> + let uu___5 = + let uu___6 = FStarC_Errors_Msg.rendermsg e1 in + Prims.strcat "string_to_term: " uu___6 in + FStarC_Tactics_Monad.fail uu___5 + | uu___2 -> + FStarC_Tactics_Monad.fail "string_to_term: Unknown error") + | FStarC_Parser_ParseIt.ASTFragment uu___1 -> + FStarC_Tactics_Monad.fail + "string_to_term: expected a Term as a result, got an ASTFragment" + | FStarC_Parser_ParseIt.ParseError (uu___1, err, uu___2) -> + let uu___3 = + let uu___4 = FStarC_Errors_Msg.rendermsg err in + Prims.strcat "string_to_term: got error " uu___4 in + FStarC_Tactics_Monad.fail uu___3 +let (push_bv_dsenv : + env -> + Prims.string -> + (env * FStarC_Reflection_V2_Data.binding) FStarC_Tactics_Monad.tac) + = + fun uu___1 -> + fun uu___ -> + (fun e -> + fun i -> + let ident = + FStarC_Ident.mk_ident (i, FStarC_Compiler_Range_Type.dummyRange) in + let uu___ = + FStarC_Syntax_DsEnv.push_bv e.FStarC_TypeChecker_Env.dsenv ident in + match uu___ with + | (dsenv, bv) -> + let uu___1 = + let uu___2 = bv_to_binding bv in + ({ + FStarC_TypeChecker_Env.solver = + (e.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (e.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (e.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (e.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (e.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (e.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (e.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (e.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (e.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (e.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (e.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (e.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (e.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (e.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (e.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (e.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (e.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (e.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (e.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (e.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (e.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (e.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (e.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (e.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (e.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (e.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (e.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (e.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (e.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (e.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (e.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (e.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (e.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (e.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (e.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (e.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (e.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (e.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (e.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (e.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (e.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (e.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (e.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = dsenv; + FStarC_TypeChecker_Env.nbe = + (e.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (e.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (e.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (e.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (e.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (e.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (e.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (e.FStarC_TypeChecker_Env.missing_decl) + }, uu___2) in + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () + (Obj.magic uu___1))) uu___1 uu___ +let (term_to_string : + FStarC_Syntax_Syntax.term -> Prims.string FStarC_Tactics_Monad.tac) = + fun uu___ -> + (fun t -> + let uu___ = top_env () in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___) + (fun uu___1 -> + (fun g -> + let g = Obj.magic g in + let s = + FStarC_Syntax_Print.term_to_string' + g.FStarC_TypeChecker_Env.dsenv t in + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac + () (Obj.magic s))) uu___1))) uu___ +let (comp_to_string : + FStarC_Syntax_Syntax.comp -> Prims.string FStarC_Tactics_Monad.tac) = + fun uu___ -> + (fun c -> + let uu___ = top_env () in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___) + (fun uu___1 -> + (fun g -> + let g = Obj.magic g in + let s = + FStarC_Syntax_Print.comp_to_string' + g.FStarC_TypeChecker_Env.dsenv c in + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac + () (Obj.magic s))) uu___1))) uu___ +let (term_to_doc : + FStarC_Syntax_Syntax.term -> + FStarC_Pprint.document FStarC_Tactics_Monad.tac) + = + fun uu___ -> + (fun t -> + let uu___ = top_env () in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___) + (fun uu___1 -> + (fun g -> + let g = Obj.magic g in + let s = + FStarC_Syntax_Print.term_to_doc' + g.FStarC_TypeChecker_Env.dsenv t in + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac + () (Obj.magic s))) uu___1))) uu___ +let (comp_to_doc : + FStarC_Syntax_Syntax.comp -> + FStarC_Pprint.document FStarC_Tactics_Monad.tac) + = + fun uu___ -> + (fun c -> + let uu___ = top_env () in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___) + (fun uu___1 -> + (fun g -> + let g = Obj.magic g in + let s = + FStarC_Syntax_Print.comp_to_doc' + g.FStarC_TypeChecker_Env.dsenv c in + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac + () (Obj.magic s))) uu___1))) uu___ +let (range_to_string : + FStarC_Compiler_Range_Type.range -> Prims.string FStarC_Tactics_Monad.tac) + = + fun uu___ -> + (fun r -> + let uu___ = + FStarC_Class_Show.show FStarC_Compiler_Range_Ops.showable_range r in + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () + (Obj.magic uu___))) uu___ +let (term_eq_old : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> Prims.bool FStarC_Tactics_Monad.tac) + = + fun uu___1 -> + fun uu___ -> + (fun t1 -> + fun t2 -> + let uu___ = + FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () + (Obj.repr ()) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac + () () uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + let uu___2 = FStarC_Syntax_Util.term_eq t1 t2 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic uu___2))) uu___1))) uu___1 uu___ +let with_compat_pre_core : + 'a . + FStarC_BigInt.t -> + 'a FStarC_Tactics_Monad.tac -> 'a FStarC_Tactics_Monad.tac + = + fun n -> + fun f -> + FStarC_Tactics_Monad.mk_tac + (fun ps -> + FStarC_Options.with_saved_options + (fun uu___ -> + let _res = FStarC_Options.set_options "--compat_pre_core 0" in + FStarC_Tactics_Monad.run f ps)) +let (get_vconfig : unit -> FStarC_VConfig.vconfig FStarC_Tactics_Monad.tac) = + fun uu___ -> + (fun uu___ -> + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___1 -> + (fun g -> + let g = Obj.magic g in + let vcfg = + FStarC_Options.with_saved_options + (fun uu___1 -> + FStarC_Options.set g.FStarC_Tactics_Types.opts; + FStarC_Options.get_vconfig ()) in + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac + () (Obj.magic vcfg))) uu___1))) uu___ +let (set_vconfig : FStarC_VConfig.vconfig -> unit FStarC_Tactics_Monad.tac) = + fun vcfg -> + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___ -> + (fun g -> + let g = Obj.magic g in + let opts' = + FStarC_Options.with_saved_options + (fun uu___ -> + FStarC_Options.set g.FStarC_Tactics_Types.opts; + FStarC_Options.set_vconfig vcfg; + FStarC_Options.peek ()) in + let g' = + { + FStarC_Tactics_Types.goal_main_env = + (g.FStarC_Tactics_Types.goal_main_env); + FStarC_Tactics_Types.goal_ctx_uvar = + (g.FStarC_Tactics_Types.goal_ctx_uvar); + FStarC_Tactics_Types.opts = opts'; + FStarC_Tactics_Types.is_guard = + (g.FStarC_Tactics_Types.is_guard); + FStarC_Tactics_Types.label = (g.FStarC_Tactics_Types.label) + } in + Obj.magic (FStarC_Tactics_Monad.replace_cur g')) uu___) +let (t_smt_sync : FStarC_VConfig.vconfig -> unit FStarC_Tactics_Monad.tac) = + fun vcfg -> + let uu___ = + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.cur_goal) + (fun uu___1 -> + (fun goal -> + let goal = Obj.magic goal in + let uu___1 = FStarC_Tactics_Monad.get_phi goal in + match uu___1 with + | FStar_Pervasives_Native.None -> + Obj.magic + (FStarC_Tactics_Monad.fail "Goal is not irrelevant") + | FStar_Pervasives_Native.Some phi -> + let e = FStarC_Tactics_Types.goal_env goal in + let ans = + FStarC_Options.with_saved_options + (fun uu___2 -> + FStarC_Options.set_vconfig vcfg; + (e.FStarC_TypeChecker_Env.solver).FStarC_TypeChecker_Env.solve_sync + FStar_Pervasives_Native.None e phi) in + if ans + then + (FStarC_Tactics_Monad.mark_uvar_as_already_checked + goal.FStarC_Tactics_Types.goal_ctx_uvar; + Obj.magic (solve goal FStarC_Syntax_Util.exp_unit)) + else + Obj.magic + (FStarC_Tactics_Monad.fail + "SMT did not solve this goal")) uu___1) in + FStarC_Tactics_Monad.wrap_err "t_smt_sync" uu___ +let (free_uvars : + FStarC_Syntax_Syntax.term -> + FStarC_BigInt.t Prims.list FStarC_Tactics_Monad.tac) + = + fun uu___ -> + (fun tm -> + let uu___ = + FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () + (Obj.repr ()) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + let uvs = + let uu___2 = + let uu___3 = FStarC_Syntax_Free.uvars_uncached tm in + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) + (Obj.magic uu___3) in + FStarC_Compiler_List.map + (fun u -> + let uu___3 = + FStarC_Syntax_Unionfind.uvar_id + u.FStarC_Syntax_Syntax.ctx_uvar_head in + FStarC_BigInt.of_int_fs uu___3) uu___2 in + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac + () (Obj.magic uvs))) uu___1))) uu___ +let (all_ext_options : + unit -> (Prims.string * Prims.string) Prims.list FStarC_Tactics_Monad.tac) + = + fun uu___ -> + (fun uu___ -> + let uu___1 = + FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () + (Obj.repr ()) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + uu___1 + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + let uu___3 = FStarC_Options_Ext.all () in + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac + () (Obj.magic uu___3))) uu___2))) uu___ +let (ext_getv : Prims.string -> Prims.string FStarC_Tactics_Monad.tac) = + fun uu___ -> + (fun k -> + let uu___ = + FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () + (Obj.repr ()) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + let uu___2 = FStarC_Options_Ext.get k in + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac + () (Obj.magic uu___2))) uu___1))) uu___ +let (ext_getns : + Prims.string -> + (Prims.string * Prims.string) Prims.list FStarC_Tactics_Monad.tac) + = + fun uu___ -> + (fun ns -> + let uu___ = + FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () + (Obj.repr ()) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + let uu___2 = FStarC_Options_Ext.getns ns in + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac + () (Obj.magic uu___2))) uu___1))) uu___ +let alloc : 'a . 'a -> 'a FStarC_Tactics_Types.tref FStarC_Tactics_Monad.tac + = + fun uu___ -> + (fun x -> + let uu___ = + FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () + (Obj.repr ()) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + let uu___2 = FStarC_Compiler_Util.mk_ref x in + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac + () (Obj.magic uu___2))) uu___1))) uu___ +let read : 'a . 'a FStarC_Tactics_Types.tref -> 'a FStarC_Tactics_Monad.tac = + fun uu___ -> + (fun r -> + let uu___ = + FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () + (Obj.repr ()) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + let uu___2 = FStarC_Compiler_Effect.op_Bang r in + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac + () (Obj.magic uu___2))) uu___1))) uu___ +let write : + 'a . 'a FStarC_Tactics_Types.tref -> 'a -> unit FStarC_Tactics_Monad.tac = + fun r -> + fun x -> + let uu___ = + FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () + (Obj.repr ()) in + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + FStarC_Compiler_Effect.op_Colon_Equals r x; + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () + (Obj.repr ()))) uu___1) +let (dbg_refl : env -> (unit -> Prims.string) -> unit) = + fun g -> + fun msg -> + let uu___ = FStarC_Compiler_Effect.op_Bang dbg_ReflTc in + if uu___ + then let uu___1 = msg () in FStarC_Compiler_Util.print_string uu___1 + else () +type issues = FStarC_Errors.issue Prims.list +let (refl_typing_guard : + env -> FStarC_Syntax_Syntax.typ -> unit FStarC_Tactics_Monad.tac) = + fun e -> + fun g -> + let reason = "refl_typing_guard" in + let uu___ = FStarC_TypeChecker_Env.get_range e in + proc_guard_formula "refl_typing_guard" e g FStar_Pervasives_Native.None + uu___ +let uncurry : + 'uuuuu 'uuuuu1 'uuuuu2 . + ('uuuuu -> 'uuuuu1 -> 'uuuuu2) -> ('uuuuu * 'uuuuu1) -> 'uuuuu2 + = fun f -> fun uu___ -> match uu___ with | (x, y) -> f x y +let __refl_typing_builtin_wrapper : + 'a . + (unit -> ('a * (env * FStarC_Syntax_Syntax.typ) Prims.list)) -> + ('a FStar_Pervasives_Native.option * issues) FStarC_Tactics_Monad.tac + = + fun uu___ -> + (fun f -> + let tx = FStarC_Syntax_Unionfind.new_transaction () in + let uu___ = + try + (fun uu___1 -> + match () with + | () -> FStarC_Errors.catch_errors_and_ignore_rest f) () + with + | uu___1 -> + let issue = + let uu___2 = + let uu___3 = FStarC_Compiler_Util.print_exn uu___1 in + FStarC_Errors_Msg.mkmsg uu___3 in + let uu___3 = FStarC_Errors.get_ctx () in + { + FStarC_Errors.issue_msg = uu___2; + FStarC_Errors.issue_level = FStarC_Errors.EError; + FStarC_Errors.issue_range = FStar_Pervasives_Native.None; + FStarC_Errors.issue_number = + (FStar_Pervasives_Native.Some (Prims.of_int (17))); + FStarC_Errors.issue_ctx = uu___3 + } in + ([issue], FStar_Pervasives_Native.None) in + match uu___ with + | (errs, r) -> + let gs = + if FStar_Pervasives_Native.uu___is_Some r + then + let allow_uvars = false in + let allow_names = true in + FStarC_Compiler_List.map + (fun uu___1 -> + match uu___1 with + | (e, g) -> + let uu___2 = + FStarC_Syntax_Compress.deep_compress allow_uvars + allow_names g in + (e, uu___2)) + (FStar_Pervasives_Native.snd + (FStar_Pervasives_Native.__proj__Some__item__v r)) + else [] in + let r1 = + FStarC_Compiler_Util.map_opt r FStar_Pervasives_Native.fst in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac + () () (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___1 -> + (fun ps -> + let ps = Obj.magic ps in + FStarC_TypeChecker_Env.promote_id_info + ps.FStarC_Tactics_Types.main_context + (FStarC_TypeChecker_Tc.compress_and_norm + ps.FStarC_Tactics_Types.main_context); + FStarC_Syntax_Unionfind.rollback tx; + if (FStarC_Compiler_List.length errs) > Prims.int_zero + then + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic (FStar_Pervasives_Native.None, errs))) + else + (let uu___4 = + FStarC_Tactics_Monad.iter_tac + (uncurry refl_typing_guard) gs in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () uu___4 + (fun uu___5 -> + (fun uu___5 -> + let uu___5 = Obj.magic uu___5 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic (r1, errs)))) uu___5)))) + uu___1))) uu___ +let catch_all : + 'a . + 'a FStarC_Tactics_Monad.tac -> + (issues, 'a) FStar_Pervasives.either FStarC_Tactics_Monad.tac + = + fun f -> + FStarC_Tactics_Monad.mk_tac + (fun ps -> + let uu___ = + FStarC_Errors.catch_errors_and_ignore_rest + (fun uu___1 -> FStarC_Tactics_Monad.run f ps) in + match uu___ with + | ([], FStar_Pervasives_Native.Some (FStarC_Tactics_Result.Success + (v, ps'))) -> + FStarC_Tactics_Result.Success ((FStar_Pervasives.Inr v), ps') + | (errs, uu___1) -> + FStarC_Tactics_Result.Success ((FStar_Pervasives.Inl errs), ps)) +let refl_typing_builtin_wrapper : + 'a . + Prims.string -> + (unit -> ('a * (env * FStarC_Syntax_Syntax.typ) Prims.list)) -> + ('a FStar_Pervasives_Native.option * issues) FStarC_Tactics_Monad.tac + = + fun uu___1 -> + fun uu___ -> + (fun label -> + fun f -> + let uu___ = + let uu___1 = + let uu___2 = __refl_typing_builtin_wrapper f in + catch_all uu___2 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac + () () (Obj.magic uu___1) + (fun uu___2 -> + (fun uu___2 -> + let uu___2 = Obj.magic uu___2 in + match uu___2 with + | FStar_Pervasives.Inl errs -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic + (FStar_Pervasives_Native.None, errs))) + | FStar_Pervasives.Inr r -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic r))) uu___2)) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac + () () (Obj.magic uu___) + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + match uu___1 with + | (o, errs) -> + let errs1 = + FStarC_Compiler_List.map + (fun is -> + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Errors_Msg.text + (Prims.strcat + "Raised within Tactics." label) in + [uu___4] in + FStarC_Compiler_List.op_At + is.FStarC_Errors.issue_msg uu___3 in + { + FStarC_Errors.issue_msg = uu___2; + FStarC_Errors.issue_level = + (is.FStarC_Errors.issue_level); + FStarC_Errors.issue_range = + (is.FStarC_Errors.issue_range); + FStarC_Errors.issue_number = + (is.FStarC_Errors.issue_number); + FStarC_Errors.issue_ctx = + (is.FStarC_Errors.issue_ctx) + }) errs in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic (o, errs1)))) uu___1))) uu___1 + uu___ +let (no_uvars_in_term : FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t -> + (let uu___ = FStarC_Syntax_Free.uvars t in + FStarC_Class_Setlike.is_empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) (Obj.magic uu___)) + && + (let uu___ = FStarC_Syntax_Free.univs t in + FStarC_Class_Setlike.is_empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_univ_uvar)) (Obj.magic uu___)) +let (no_univ_uvars_in_term : FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t -> + let uu___ = FStarC_Syntax_Free.univs t in + FStarC_Class_Setlike.is_empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_univ_uvar)) (Obj.magic uu___) +let (no_uvars_in_g : env -> Prims.bool) = + fun g -> + FStarC_Compiler_Util.for_all + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.Binding_var bv -> + no_uvars_in_term bv.FStarC_Syntax_Syntax.sort + | uu___1 -> true) g.FStarC_TypeChecker_Env.gamma +type relation = + | Subtyping + | Equality +let (uu___is_Subtyping : relation -> Prims.bool) = + fun projectee -> match projectee with | Subtyping -> true | uu___ -> false +let (uu___is_Equality : relation -> Prims.bool) = + fun projectee -> match projectee with | Equality -> true | uu___ -> false +let (unexpected_uvars_issue : + FStarC_Compiler_Range_Type.range -> FStarC_Errors.issue) = + fun r -> + let i = + let uu___ = FStarC_Errors_Msg.mkmsg "Cannot check relation with uvars" in + let uu___1 = + let uu___2 = + FStarC_Errors.errno + FStarC_Errors_Codes.Error_UnexpectedUnresolvedUvar in + FStar_Pervasives_Native.Some uu___2 in + { + FStarC_Errors.issue_msg = uu___; + FStarC_Errors.issue_level = FStarC_Errors.EError; + FStarC_Errors.issue_range = (FStar_Pervasives_Native.Some r); + FStarC_Errors.issue_number = uu___1; + FStarC_Errors.issue_ctx = [] + } in + i +let (refl_is_non_informative : + env -> + FStarC_Syntax_Syntax.typ -> + (unit FStar_Pervasives_Native.option * issues) FStarC_Tactics_Monad.tac) + = + fun uu___1 -> + fun uu___ -> + (fun g -> + fun t -> + let uu___ = (no_uvars_in_g g) && (no_uvars_in_term t) in + if uu___ + then + Obj.magic + (Obj.repr + (refl_typing_builtin_wrapper "refl_is_non_informative" + (fun uu___1 -> + let g1 = + FStarC_TypeChecker_Env.set_range g + t.FStarC_Syntax_Syntax.pos in + dbg_refl g1 + (fun uu___3 -> + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.format1 + "refl_is_non_informative: %s\n" uu___4); + (let b = + FStarC_TypeChecker_Core.is_non_informative g1 t in + dbg_refl g1 + (fun uu___4 -> + let uu___5 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) b in + FStarC_Compiler_Util.format1 + "refl_is_non_informative: returned %s" uu___5); + if b + then ((), []) + else + FStarC_Errors.raise_error + FStarC_TypeChecker_Env.hasRange_env g1 + FStarC_Errors_Codes.Fatal_UnexpectedTerm () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "is_non_informative returned false"))))) + else + Obj.magic + (Obj.repr + (let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_TypeChecker_Env.get_range g in + unexpected_uvars_issue uu___5 in + [uu___4] in + (FStar_Pervasives_Native.None, uu___3) in + FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac + () (Obj.magic uu___2)))) uu___1 uu___ +let (refl_check_relation : + relation -> + Prims.bool -> + Prims.bool -> + env -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.typ -> + (unit FStar_Pervasives_Native.option * issues) + FStarC_Tactics_Monad.tac) + = + fun uu___5 -> + fun uu___4 -> + fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun rel -> + fun smt_ok -> + fun unfolding_ok -> + fun g -> + fun t0 -> + fun t1 -> + let uu___ = + ((no_uvars_in_g g) && (no_uvars_in_term t0)) && + (no_uvars_in_term t1) in + if uu___ + then + Obj.magic + (Obj.repr + (refl_typing_builtin_wrapper + "refl_check_relation" + (fun uu___1 -> + let g1 = + FStarC_TypeChecker_Env.set_range g + t0.FStarC_Syntax_Syntax.pos in + dbg_refl g1 + (fun uu___3 -> + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t0 in + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t1 in + FStarC_Compiler_Util.format3 + "refl_check_relation: %s %s %s\n" + uu___4 + (if rel = Subtyping + then "<:?" + else "=?=") uu___5); + (let f = + if rel = Subtyping + then + FStarC_TypeChecker_Core.check_term_subtyping + else + FStarC_TypeChecker_Core.check_term_equality in + let uu___3 = + f smt_ok unfolding_ok g1 t0 t1 in + match uu___3 with + | FStar_Pervasives.Inl + (FStar_Pervasives_Native.None) + -> + (dbg_refl g1 + (fun uu___5 -> + "refl_check_relation: succeeded (no guard)\n"); + ((), [])) + | FStar_Pervasives.Inl + (FStar_Pervasives_Native.Some + guard_f) -> + (dbg_refl g1 + (fun uu___5 -> + "refl_check_relation: succeeded\n"); + ((), [(g1, guard_f)])) + | FStar_Pervasives.Inr err -> + (dbg_refl g1 + (fun uu___5 -> + let uu___6 = + FStarC_TypeChecker_Core.print_error + err in + FStarC_Compiler_Util.format1 + "refl_check_relation failed: %s\n" + uu___6); + (let uu___5 = + let uu___6 = + FStarC_TypeChecker_Core.print_error + err in + Prims.strcat + "check_relation failed: " + uu___6 in + FStarC_Errors.raise_error + FStarC_TypeChecker_Env.hasRange_env + g1 + FStarC_Errors_Codes.Fatal_IllTyped + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___5))))))) + else + Obj.magic + (Obj.repr + (let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_TypeChecker_Env.get_range g in + unexpected_uvars_issue uu___5 in + [uu___4] in + (FStar_Pervasives_Native.None, uu___3) in + FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic uu___2)))) uu___5 uu___4 + uu___3 uu___2 uu___1 uu___ +let (refl_check_subtyping : + env -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.typ -> + (unit FStar_Pervasives_Native.option * issues) + FStarC_Tactics_Monad.tac) + = + fun g -> + fun t0 -> fun t1 -> refl_check_relation Subtyping true true g t0 t1 +let (t_refl_check_equiv : + Prims.bool -> + Prims.bool -> + env -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.typ -> + (unit FStar_Pervasives_Native.option * issues) + FStarC_Tactics_Monad.tac) + = refl_check_relation Equality +let (to_must_tot : FStarC_TypeChecker_Core.tot_or_ghost -> Prims.bool) = + fun eff -> + match eff with + | FStarC_TypeChecker_Core.E_Total -> true + | FStarC_TypeChecker_Core.E_Ghost -> false +let (tot_or_ghost_to_string : + FStarC_TypeChecker_Core.tot_or_ghost -> Prims.string) = + fun uu___ -> + match uu___ with + | FStarC_TypeChecker_Core.E_Total -> "E_Total" + | FStarC_TypeChecker_Core.E_Ghost -> "E_Ghost" +let (refl_norm_type : + env -> FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.typ) = + fun g -> + fun t -> + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Exclude FStarC_TypeChecker_Env.Zeta] g t +let (refl_core_compute_term_type : + env -> + FStarC_Syntax_Syntax.term -> + ((FStarC_TypeChecker_Core.tot_or_ghost * FStarC_Syntax_Syntax.typ) + FStar_Pervasives_Native.option * issues) FStarC_Tactics_Monad.tac) + = + fun uu___1 -> + fun uu___ -> + (fun g -> + fun e -> + let uu___ = (no_uvars_in_g g) && (no_uvars_in_term e) in + if uu___ + then + Obj.magic + (Obj.repr + (refl_typing_builtin_wrapper "refl_core_compute_term_type" + (fun uu___1 -> + let g1 = + FStarC_TypeChecker_Env.set_range g + e.FStarC_Syntax_Syntax.pos in + dbg_refl g1 + (fun uu___3 -> + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term e in + FStarC_Compiler_Util.format1 + "refl_core_compute_term_type: %s\n" uu___4); + (let guards = FStarC_Compiler_Util.mk_ref [] in + let gh g2 guard = + (let uu___4 = + let uu___5 = + FStarC_Compiler_Effect.op_Bang guards in + (g2, guard) :: uu___5 in + FStarC_Compiler_Effect.op_Colon_Equals guards + uu___4); + true in + let uu___3 = + FStarC_TypeChecker_Core.compute_term_type_handle_guards + g1 e gh in + match uu___3 with + | FStar_Pervasives.Inl (eff, t) -> + let t1 = refl_norm_type g1 t in + (dbg_refl g1 + (fun uu___5 -> + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term e in + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.format2 + "refl_core_compute_term_type for %s computed type %s\n" + uu___6 uu___7); + (let uu___5 = + FStarC_Compiler_Effect.op_Bang guards in + ((eff, t1), uu___5))) + | FStar_Pervasives.Inr err -> + (dbg_refl g1 + (fun uu___5 -> + let uu___6 = + FStarC_TypeChecker_Core.print_error err in + FStarC_Compiler_Util.format1 + "refl_core_compute_term_type: %s\n" + uu___6); + (let uu___5 = + let uu___6 = + FStarC_TypeChecker_Core.print_error err in + Prims.strcat + "core_compute_term_type failed: " uu___6 in + FStarC_Errors.raise_error + FStarC_TypeChecker_Env.hasRange_env g1 + FStarC_Errors_Codes.Fatal_IllTyped () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___5))))))) + else + Obj.magic + (Obj.repr + (let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_TypeChecker_Env.get_range g in + unexpected_uvars_issue uu___5 in + [uu___4] in + (FStar_Pervasives_Native.None, uu___3) in + FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac + () (Obj.magic uu___2)))) uu___1 uu___ +let (refl_core_check_term : + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.typ -> + FStarC_TypeChecker_Core.tot_or_ghost -> + (unit FStar_Pervasives_Native.option * issues) + FStarC_Tactics_Monad.tac) + = + fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun g -> + fun e -> + fun t -> + fun eff -> + let uu___ = + ((no_uvars_in_g g) && (no_uvars_in_term e)) && + (no_uvars_in_term t) in + if uu___ + then + Obj.magic + (Obj.repr + (refl_typing_builtin_wrapper "refl_core_check_term" + (fun uu___1 -> + let g1 = + FStarC_TypeChecker_Env.set_range g + e.FStarC_Syntax_Syntax.pos in + dbg_refl g1 + (fun uu___3 -> + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term e in + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.format3 + "refl_core_check_term: term: %s, type: %s, eff: %s\n" + uu___4 uu___5 + (tot_or_ghost_to_string eff)); + (let must_tot = to_must_tot eff in + let uu___3 = + FStarC_TypeChecker_Core.check_term g1 e t + must_tot in + match uu___3 with + | FStar_Pervasives.Inl + (FStar_Pervasives_Native.None) -> + (dbg_refl g1 + (fun uu___5 -> + "refl_core_check_term: succeeded with no guard\n"); + ((), [])) + | FStar_Pervasives.Inl + (FStar_Pervasives_Native.Some guard) -> + (dbg_refl g1 + (fun uu___5 -> + "refl_core_check_term: succeeded with guard\n"); + ((), [(g1, guard)])) + | FStar_Pervasives.Inr err -> + (dbg_refl g1 + (fun uu___5 -> + let uu___6 = + FStarC_TypeChecker_Core.print_error + err in + FStarC_Compiler_Util.format1 + "refl_core_check_term failed: %s\n" + uu___6); + (let uu___5 = + let uu___6 = + FStarC_TypeChecker_Core.print_error + err in + Prims.strcat + "refl_core_check_term failed: " + uu___6 in + FStarC_Errors.raise_error + FStarC_TypeChecker_Env.hasRange_env + g1 + FStarC_Errors_Codes.Fatal_IllTyped + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___5))))))) + else + Obj.magic + (Obj.repr + (let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_TypeChecker_Env.get_range g in + unexpected_uvars_issue uu___5 in + [uu___4] in + (FStar_Pervasives_Native.None, uu___3) in + FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic uu___2)))) uu___3 uu___2 uu___1 uu___ +let (refl_core_check_term_at_type : + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.typ -> + (FStarC_TypeChecker_Core.tot_or_ghost FStar_Pervasives_Native.option + * issues) FStarC_Tactics_Monad.tac) + = + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun g -> + fun e -> + fun t -> + let uu___ = + ((no_uvars_in_g g) && (no_uvars_in_term e)) && + (no_uvars_in_term t) in + if uu___ + then + Obj.magic + (Obj.repr + (refl_typing_builtin_wrapper + "refl_core_check_term_at_type" + (fun uu___1 -> + let g1 = + FStarC_TypeChecker_Env.set_range g + e.FStarC_Syntax_Syntax.pos in + dbg_refl g1 + (fun uu___3 -> + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term e in + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.format2 + "refl_core_check_term_at_type: term: %s, type: %s\n" + uu___4 uu___5); + (let uu___3 = + FStarC_TypeChecker_Core.check_term_at_type g1 + e t in + match uu___3 with + | FStar_Pervasives.Inl + (eff, FStar_Pervasives_Native.None) -> + (dbg_refl g1 + (fun uu___5 -> + FStarC_Compiler_Util.format1 + "refl_core_check_term_at_type: succeeded with eff %s and no guard\n" + (tot_or_ghost_to_string eff)); + (eff, [])) + | FStar_Pervasives.Inl + (eff, FStar_Pervasives_Native.Some guard) -> + (dbg_refl g1 + (fun uu___5 -> + FStarC_Compiler_Util.format1 + "refl_core_check_term_at_type: succeeded with eff %s and guard\n" + (tot_or_ghost_to_string eff)); + (eff, [(g1, guard)])) + | FStar_Pervasives.Inr err -> + (dbg_refl g1 + (fun uu___5 -> + let uu___6 = + FStarC_TypeChecker_Core.print_error + err in + FStarC_Compiler_Util.format1 + "refl_core_check_term_at_type failed: %s\n" + uu___6); + (let uu___5 = + let uu___6 = + FStarC_TypeChecker_Core.print_error + err in + Prims.strcat + "refl_core_check_term failed: " uu___6 in + FStarC_Errors.raise_error + FStarC_TypeChecker_Env.hasRange_env g1 + FStarC_Errors_Codes.Fatal_IllTyped () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___5))))))) + else + Obj.magic + (Obj.repr + (let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_TypeChecker_Env.get_range g in + unexpected_uvars_issue uu___5 in + [uu___4] in + (FStar_Pervasives_Native.None, uu___3) in + FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () (Obj.magic uu___2)))) + uu___2 uu___1 uu___ +let (refl_tc_term : + env -> + FStarC_Syntax_Syntax.term -> + ((FStarC_Syntax_Syntax.term * (FStarC_TypeChecker_Core.tot_or_ghost * + FStarC_Syntax_Syntax.typ)) FStar_Pervasives_Native.option * issues) + FStarC_Tactics_Monad.tac) + = + fun uu___1 -> + fun uu___ -> + (fun g -> + fun e -> + let uu___ = (no_uvars_in_g g) && (no_uvars_in_term e) in + if uu___ + then + Obj.magic + (Obj.repr + (refl_typing_builtin_wrapper "refl_tc_term" + (fun uu___1 -> + let g1 = + FStarC_TypeChecker_Env.set_range g + e.FStarC_Syntax_Syntax.pos in + dbg_refl g1 + (fun uu___3 -> + let uu___4 = + FStarC_Class_Show.show + FStarC_Compiler_Range_Ops.showable_range + e.FStarC_Syntax_Syntax.pos in + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term e in + FStarC_Compiler_Util.format2 + "refl_tc_term@%s: %s\n" uu___4 uu___5); + dbg_refl g1 + (fun uu___4 -> "refl_tc_term: starting tc {\n"); + (let g2 = + { + FStarC_TypeChecker_Env.solver = + (g1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (g1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (g1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (g1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (g1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (g1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (g1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (g1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (g1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (g1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = false; + FStarC_TypeChecker_Env.effects = + (g1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (g1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (g1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (g1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (g1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (g1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (g1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (g1.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (g1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (g1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (g1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (g1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (g1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (g1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (g1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (g1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (g1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (g1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (g1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (g1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (g1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (g1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (g1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (g1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (g1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (g1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (g1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (g1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (g1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (g1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (g1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (g1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (g1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (g1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (g1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (g1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (g1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (g1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (g1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (g1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (g1.FStarC_TypeChecker_Env.missing_decl) + } in + let e1 = + let g3 = + { + FStarC_TypeChecker_Env.solver = + (g2.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (g2.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (g2.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (g2.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (g2.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (g2.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (g2.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (g2.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (g2.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (g2.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (g2.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (g2.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (g2.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (g2.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (g2.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (g2.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (g2.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (g2.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = true; + FStarC_TypeChecker_Env.lax_universes = + (g2.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = true; + FStarC_TypeChecker_Env.failhard = + (g2.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (g2.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (g2.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (g2.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (g2.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (g2.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (g2.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (g2.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (g2.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (g2.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (g2.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (g2.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (g2.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (g2.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (g2.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (g2.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (g2.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (g2.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (g2.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (g2.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (g2.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (g2.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (g2.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (g2.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (g2.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (g2.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (g2.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (g2.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (g2.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (g2.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (g2.FStarC_TypeChecker_Env.missing_decl) + } in + let must_tot = false in + let uu___4 = + g3.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + g3 e must_tot in + match uu___4 with + | (e2, uu___5, guard) -> + (FStarC_TypeChecker_Rel.force_trivial_guard g3 + guard; + e2) in + try + (fun uu___4 -> + match () with + | () -> + let uu___5 = + let uu___6 = no_uvars_in_term e1 in + Prims.op_Negation uu___6 in + if uu___5 + then + let uu___6 = + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + e1 in + FStarC_Compiler_Util.format1 + "Elaborated term has unresolved implicits: %s" + uu___7 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax + ()) e1 + FStarC_Errors_Codes.Error_UnexpectedUnresolvedUvar + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___6) + else + (let allow_uvars = false in + let allow_names = true in + let e2 = + FStarC_Syntax_Compress.deep_compress + allow_uvars allow_names e1 in + dbg_refl g2 + (fun uu___8 -> + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + e2 in + FStarC_Compiler_Util.format1 + "} finished tc with e = %s\n" + uu___9); + (let guards = + FStarC_Compiler_Util.mk_ref [] in + let gh g3 guard = + dbg_refl g3 + (fun uu___9 -> + let uu___10 = + let uu___11 = + FStarC_TypeChecker_Env.get_range + g3 in + FStarC_Class_Show.show + FStarC_Compiler_Range_Ops.showable_range + uu___11 in + let uu___11 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + guard in + let uu___12 = + FStarC_Class_Show.show + FStarC_Compiler_Range_Ops.showable_range + guard.FStarC_Syntax_Syntax.pos in + FStarC_Compiler_Util.format3 + "Got guard in Env@%s |- %s@%s\n" + uu___10 uu___11 uu___12); + (let uu___10 = + let uu___11 = + FStarC_Compiler_Effect.op_Bang + guards in + (g3, guard) :: uu___11 in + FStarC_Compiler_Effect.op_Colon_Equals + guards uu___10); + true in + let uu___8 = + FStarC_TypeChecker_Core.compute_term_type_handle_guards + g2 e2 gh in + match uu___8 with + | FStar_Pervasives.Inl (eff, t) -> + let t1 = refl_norm_type g2 t in + (dbg_refl g2 + (fun uu___10 -> + let uu___11 = + FStarC_Class_Show.show + FStarC_Compiler_Range_Ops.showable_range + e2.FStarC_Syntax_Syntax.pos in + let uu___12 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + e2 in + let uu___13 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t1 in + FStarC_Compiler_Util.format3 + "refl_tc_term@%s for %s computed type %s\n" + uu___11 uu___12 uu___13); + (let uu___10 = + FStarC_Compiler_Effect.op_Bang + guards in + ((e2, (eff, t1)), uu___10))) + | FStar_Pervasives.Inr err -> + (dbg_refl g2 + (fun uu___10 -> + let uu___11 = + FStarC_TypeChecker_Core.print_error + err in + FStarC_Compiler_Util.format1 + "refl_tc_term failed: %s\n" + uu___11); + (let uu___10 = + let uu___11 = + FStarC_TypeChecker_Core.print_error + err in + Prims.strcat + "tc_term callback failed: " + uu___11 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax + ()) e2 + FStarC_Errors_Codes.Fatal_IllTyped + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___10)))))) () + with + | FStarC_Errors.Error + (FStarC_Errors_Codes.Error_UnexpectedUnresolvedUvar, + uu___5, uu___6, uu___7) + -> + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) e1 + FStarC_Errors_Codes.Fatal_IllTyped () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "UVars remaing in term after tc_term callback"))))) + else + Obj.magic + (Obj.repr + (let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_TypeChecker_Env.get_range g in + unexpected_uvars_issue uu___5 in + [uu___4] in + (FStar_Pervasives_Native.None, uu___3) in + FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac + () (Obj.magic uu___2)))) uu___1 uu___ +let (refl_universe_of : + env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.universe FStar_Pervasives_Native.option * issues) + FStarC_Tactics_Monad.tac) + = + fun uu___1 -> + fun uu___ -> + (fun g -> + fun e -> + let check_univ_var_resolved g1 u = + let uu___ = FStarC_Syntax_Subst.compress_univ u in + match uu___ with + | FStarC_Syntax_Syntax.U_unif uu___1 -> + FStarC_Errors.raise_error + FStarC_TypeChecker_Env.hasRange_env g1 + FStarC_Errors_Codes.Fatal_IllTyped () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "Unresolved variable in universe_of callback") + | u1 -> u1 in + let uu___ = (no_uvars_in_g g) && (no_uvars_in_term e) in + if uu___ + then + Obj.magic + (Obj.repr + (refl_typing_builtin_wrapper "refl_universe_of" + (fun uu___1 -> + let g1 = + FStarC_TypeChecker_Env.set_range g + e.FStarC_Syntax_Syntax.pos in + let uu___2 = FStarC_Syntax_Util.type_u () in + match uu___2 with + | (t, u) -> + let must_tot = false in + let uu___3 = + FStarC_TypeChecker_Core.check_term g1 e t + must_tot in + (match uu___3 with + | FStar_Pervasives.Inl + (FStar_Pervasives_Native.None) -> + let uu___4 = check_univ_var_resolved g1 u in + (uu___4, []) + | FStar_Pervasives.Inl + (FStar_Pervasives_Native.Some guard) -> + let uu___4 = check_univ_var_resolved g1 u in + (uu___4, [(g1, guard)]) + | FStar_Pervasives.Inr err -> + (dbg_refl g1 + (fun uu___5 -> + let uu___6 = + FStarC_TypeChecker_Core.print_error + err in + FStarC_Compiler_Util.format1 + "refl_universe_of failed: %s\n" + uu___6); + (let uu___5 = + let uu___6 = + FStarC_TypeChecker_Core.print_error + err in + Prims.strcat "universe_of failed: " + uu___6 in + FStarC_Errors.raise_error + FStarC_TypeChecker_Env.hasRange_env g1 + FStarC_Errors_Codes.Fatal_IllTyped () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___5))))))) + else + Obj.magic + (Obj.repr + (let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_TypeChecker_Env.get_range g in + unexpected_uvars_issue uu___5 in + [uu___4] in + (FStar_Pervasives_Native.None, uu___3) in + FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac + () (Obj.magic uu___2)))) uu___1 uu___ +let (refl_check_prop_validity : + env -> + FStarC_Syntax_Syntax.term -> + (unit FStar_Pervasives_Native.option * issues) FStarC_Tactics_Monad.tac) + = + fun uu___1 -> + fun uu___ -> + (fun g -> + fun e -> + let uu___ = (no_uvars_in_g g) && (no_uvars_in_term e) in + if uu___ + then + Obj.magic + (Obj.repr + (refl_typing_builtin_wrapper "refl_check_prop_validity" + (fun uu___1 -> + let g1 = + FStarC_TypeChecker_Env.set_range g + e.FStarC_Syntax_Syntax.pos in + dbg_refl g1 + (fun uu___3 -> + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term e in + FStarC_Compiler_Util.format1 + "refl_check_prop_validity: %s\n" uu___4); + (let must_tot = false in + (let uu___4 = + let uu___5 = + FStarC_Syntax_Util.fvar_const + FStarC_Parser_Const.prop_lid in + FStarC_TypeChecker_Core.check_term g1 e uu___5 + must_tot in + match uu___4 with + | FStar_Pervasives.Inl + (FStar_Pervasives_Native.None) -> () + | FStar_Pervasives.Inl + (FStar_Pervasives_Native.Some guard) -> + FStarC_TypeChecker_Rel.force_trivial_guard g1 + { + FStarC_TypeChecker_Common.guard_f = + (FStarC_TypeChecker_Common.NonTrivial + guard); + FStarC_TypeChecker_Common.deferred_to_tac = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = + (FStarC_TypeChecker_Env.trivial_guard.FStarC_TypeChecker_Common.implicits) + } + | FStar_Pervasives.Inr err -> + let msg = + let uu___5 = + FStarC_TypeChecker_Core.print_error err in + FStarC_Compiler_Util.format1 + "refl_check_prop_validity failed (not a prop): %s\n" + uu___5 in + (dbg_refl g1 (fun uu___6 -> msg); + FStarC_Errors.raise_error + FStarC_TypeChecker_Env.hasRange_env g1 + FStarC_Errors_Codes.Fatal_IllTyped () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic msg))); + ((), [(g1, e)]))))) + else + Obj.magic + (Obj.repr + (let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_TypeChecker_Env.get_range g in + unexpected_uvars_issue uu___5 in + [uu___4] in + (FStar_Pervasives_Native.None, uu___3) in + FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac + () (Obj.magic uu___2)))) uu___1 uu___ +let (refl_check_match_complete : + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> + FStarC_Reflection_V2_Data.pattern Prims.list -> + (FStarC_Reflection_V2_Data.pattern Prims.list * + FStarC_Reflection_V2_Data.binding Prims.list Prims.list) + FStar_Pervasives_Native.option FStarC_Tactics_Monad.tac) + = + fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun g -> + fun sc -> + fun scty -> + fun pats -> + let uu___ = + FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac + () (Obj.repr ()) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + let one = FStarC_Syntax_Util.exp_int "1" in + let brs = + FStarC_Compiler_List.map + (fun p -> + let p1 = + FStarC_Reflection_V2_Builtins.pack_pat + p in + (p1, FStar_Pervasives_Native.None, one)) + pats in + let mm = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_match + { + FStarC_Syntax_Syntax.scrutinee = sc; + FStarC_Syntax_Syntax.ret_opt = + FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.brs = brs; + FStarC_Syntax_Syntax.rc_opt1 = + FStar_Pervasives_Native.None + }) sc.FStarC_Syntax_Syntax.pos in + let env1 = g in + let env2 = + FStarC_TypeChecker_Env.set_expected_typ env1 + FStarC_Syntax_Syntax.t_int in + let uu___2 = __tc env2 mm in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () + (Obj.magic uu___2) + (fun uu___3 -> + (fun uu___3 -> + let uu___3 = Obj.magic uu___3 in + match uu___3 with + | (mm1, uu___4, g1) -> + let uu___5 = + FStarC_Errors.catch_errors_and_ignore_rest + (fun uu___6 -> + let uu___7 = + FStarC_TypeChecker_Rel.discharge_guard + env2 g1 in + FStarC_TypeChecker_Env.is_trivial + uu___7) in + (match uu___5 with + | (errs, b) -> + (match (errs, b) with + | ([], + FStar_Pervasives_Native.Some + (true)) -> + let get_pats t = + let uu___6 = + let uu___7 = + FStarC_Syntax_Util.unmeta + t in + uu___7.FStarC_Syntax_Syntax.n in + match uu___6 with + | FStarC_Syntax_Syntax.Tm_match + { + FStarC_Syntax_Syntax.scrutinee + = uu___7; + FStarC_Syntax_Syntax.ret_opt + = uu___8; + FStarC_Syntax_Syntax.brs + = brs1; + FStarC_Syntax_Syntax.rc_opt1 + = uu___9;_} + -> + FStarC_Compiler_List.map + (fun uu___10 + -> + match uu___10 + with + | (p, + uu___11, + uu___12) + -> p) + brs1 + | uu___7 -> + failwith + "refl_check_match_complete: not a match?" in + let pats1 = + get_pats mm1 in + let rec bnds_for_pat p + = + match p.FStarC_Syntax_Syntax.v + with + | FStarC_Syntax_Syntax.Pat_constant + uu___6 -> [] + | FStarC_Syntax_Syntax.Pat_cons + (fv, uu___6, + pats2) + -> + FStarC_Compiler_List.concatMap + (fun uu___7 -> + match uu___7 + with + | (p1, + uu___8) + -> + bnds_for_pat + p1) pats2 + | FStarC_Syntax_Syntax.Pat_var + bv -> + let uu___6 = + bv_to_binding + bv in + [uu___6] + | FStarC_Syntax_Syntax.Pat_dot_term + uu___6 -> [] in + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Compiler_List.map + FStarC_Reflection_V2_Builtins.inspect_pat + pats1 in + let uu___9 = + FStarC_Compiler_List.map + bnds_for_pat + pats1 in + (uu___8, uu___9) in + FStar_Pervasives_Native.Some + uu___7 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic uu___6)) + | uu___6 -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac + () + (Obj.magic + FStar_Pervasives_Native.None))))) + uu___3))) uu___1))) uu___3 uu___2 + uu___1 uu___ +let (refl_instantiate_implicits : + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option -> + (((FStarC_Syntax_Syntax.bv * FStarC_Syntax_Syntax.typ) Prims.list * + FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.typ) + FStar_Pervasives_Native.option * issues) FStarC_Tactics_Monad.tac) + = + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun g -> + fun e -> + fun expected_typ -> + let uu___ = (no_uvars_in_g g) && (no_uvars_in_term e) in + if uu___ + then + Obj.magic + (Obj.repr + (refl_typing_builtin_wrapper + "refl_instantiate_implicits" + (fun uu___1 -> + let g1 = + FStarC_TypeChecker_Env.set_range g + e.FStarC_Syntax_Syntax.pos in + dbg_refl g1 + (fun uu___3 -> + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term e in + FStarC_Compiler_Util.format1 + "refl_instantiate_implicits: %s\n" uu___4); + dbg_refl g1 + (fun uu___4 -> + "refl_instantiate_implicits: starting tc {\n"); + (let must_tot = false in + let g2 = + match expected_typ with + | FStar_Pervasives_Native.None -> + let uu___4 = + FStarC_TypeChecker_Env.clear_expected_typ + g1 in + FStar_Pervasives_Native.fst uu___4 + | FStar_Pervasives_Native.Some typ -> + FStarC_TypeChecker_Env.set_expected_typ g1 + typ in + let g3 = + { + FStarC_TypeChecker_Env.solver = + (g2.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (g2.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (g2.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (g2.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (g2.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (g2.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (g2.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (g2.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (g2.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (g2.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + false; + FStarC_TypeChecker_Env.effects = + (g2.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (g2.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (g2.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (g2.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (g2.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (g2.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (g2.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = true; + FStarC_TypeChecker_Env.lax_universes = + (g2.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = true; + FStarC_TypeChecker_Env.failhard = + (g2.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (g2.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (g2.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (g2.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (g2.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (g2.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (g2.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (g2.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (g2.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (g2.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (g2.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (g2.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (g2.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (g2.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (g2.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (g2.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (g2.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (g2.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (g2.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (g2.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (g2.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (g2.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (g2.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (g2.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (g2.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (g2.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (g2.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (g2.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (g2.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (g2.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (g2.FStarC_TypeChecker_Env.missing_decl) + } in + let uu___4 = + g3.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + g3 e must_tot in + match uu___4 with + | (e1, t, guard) -> + let guard1 = + let uu___5 = + FStarC_TypeChecker_Rel.solve_deferred_constraints + g3 guard in + FStarC_TypeChecker_Rel.resolve_implicits + g3 uu___5 in + let bvs_and_ts = + let uu___5 = + FStarC_Class_Listlike.to_list + (FStarC_Compiler_CList.listlike_clist + ()) + guard1.FStarC_TypeChecker_Common.implicits in + match uu___5 with + | [] -> [] + | imps -> + let l = + FStarC_Compiler_List.map + (fun uu___6 -> + match uu___6 with + | { + FStarC_TypeChecker_Common.imp_reason + = uu___7; + FStarC_TypeChecker_Common.imp_uvar + = imp_uvar; + FStarC_TypeChecker_Common.imp_tm + = uu___8; + FStarC_TypeChecker_Common.imp_range + = uu___9;_} + -> + let uu___10 = + FStarC_Syntax_Util.ctx_uvar_typ + imp_uvar in + let uu___11 = + let uu___12 = + FStarC_Syntax_Syntax.mk + FStarC_Syntax_Syntax.Tm_unknown + FStarC_Compiler_Range_Type.dummyRange in + FStarC_Syntax_Syntax.new_bv + FStar_Pervasives_Native.None + uu___12 in + ((imp_uvar.FStarC_Syntax_Syntax.ctx_uvar_head), + uu___10, uu___11)) imps in + (FStarC_Compiler_List.iter + (fun uu___7 -> + match uu___7 with + | (uv, uu___8, bv) -> + let uu___9 = + FStarC_Syntax_Syntax.bv_to_name + bv in + FStarC_Syntax_Util.set_uvar + uv uu___9) l; + FStarC_Compiler_List.map + (fun uu___7 -> + match uu___7 with + | (uu___8, t1, bv) -> (bv, t1)) + l) in + (dbg_refl g3 + (fun uu___6 -> + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + e1 in + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t in + FStarC_Compiler_Util.format2 + "refl_instantiate_implicits: inferred %s : %s" + uu___7 uu___8); + (let uu___7 = + let uu___8 = no_univ_uvars_in_term e1 in + Prims.op_Negation uu___8 in + if uu___7 + then + let uu___8 = + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + e1 in + FStarC_Compiler_Util.format1 + "Elaborated term has unresolved univ uvars: %s" + uu___9 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax + ()) e1 + FStarC_Errors_Codes.Error_UnexpectedUnresolvedUvar + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___8) + else ()); + (let uu___8 = + let uu___9 = no_univ_uvars_in_term t in + Prims.op_Negation uu___9 in + if uu___8 + then + let uu___9 = + let uu___10 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t in + FStarC_Compiler_Util.format1 + "Inferred type has unresolved univ uvars: %s" + uu___10 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax + ()) e1 + FStarC_Errors_Codes.Error_UnexpectedUnresolvedUvar + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___9) + else ()); + FStarC_Compiler_List.iter + (fun uu___9 -> + match uu___9 with + | (x, t1) -> + let uu___10 = + let uu___11 = + no_univ_uvars_in_term t1 in + Prims.op_Negation uu___11 in + if uu___10 + then + let uu___11 = + let uu___12 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_bv + x in + let uu___13 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t1 in + FStarC_Compiler_Util.format2 + "Inferred type has unresolved univ uvars: %s:%s" + uu___12 uu___13 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax + ()) e1 + FStarC_Errors_Codes.Error_UnexpectedUnresolvedUvar + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___11) + else ()) bvs_and_ts; + (let g4 = + let uu___9 = + FStarC_Compiler_List.map + (fun uu___10 -> + match uu___10 with + | (bv, t1) -> + { + FStarC_Syntax_Syntax.ppname + = + (bv.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index + = + (bv.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = + t1 + }) bvs_and_ts in + FStarC_TypeChecker_Env.push_bvs g3 + uu___9 in + let allow_uvars = false in + let allow_names = true in + let e2 = + FStarC_Syntax_Compress.deep_compress + allow_uvars allow_names e1 in + let t1 = + let uu___9 = refl_norm_type g4 t in + FStarC_Syntax_Compress.deep_compress + allow_uvars allow_names uu___9 in + let bvs_and_ts1 = + FStarC_Compiler_List.map + (fun uu___9 -> + match uu___9 with + | (bv, t2) -> + let uu___10 = + FStarC_Syntax_Compress.deep_compress + allow_uvars allow_names t2 in + (bv, uu___10)) bvs_and_ts in + dbg_refl g4 + (fun uu___10 -> + let uu___11 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + e2 in + let uu___12 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t1 in + FStarC_Compiler_Util.format2 + "} finished tc with e = %s and t = %s\n" + uu___11 uu___12); + ((bvs_and_ts1, e2, t1), []))))))) + else + Obj.magic + (Obj.repr + (let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_TypeChecker_Env.get_range g in + unexpected_uvars_issue uu___5 in + [uu___4] in + (FStar_Pervasives_Native.None, uu___3) in + FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () (Obj.magic uu___2)))) + uu___2 uu___1 uu___ +let (refl_try_unify : + env -> + (FStarC_Syntax_Syntax.bv * FStarC_Syntax_Syntax.typ) Prims.list -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> + ((FStarC_Syntax_Syntax.bv * FStarC_Syntax_Syntax.term) Prims.list + FStar_Pervasives_Native.option * issues) FStarC_Tactics_Monad.tac) + = + fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun g -> + fun uvs -> + fun t0 -> + fun t1 -> + let uu___ = + (((no_uvars_in_g g) && (no_uvars_in_term t0)) && + (no_uvars_in_term t1)) + && + (let uu___1 = + FStarC_Compiler_List.map + FStar_Pervasives_Native.snd uvs in + FStarC_Compiler_List.for_all no_uvars_in_term uu___1) in + if uu___ + then + Obj.magic + (Obj.repr + (refl_typing_builtin_wrapper "refl_try_unify" + (fun uu___1 -> + dbg_refl g + (fun uu___3 -> + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t0 in + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t1 in + let uu___6 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + (FStarC_Class_Show.show_tuple2 + FStarC_Syntax_Print.showable_bv + FStarC_Syntax_Print.showable_term)) + uvs in + FStarC_Compiler_Util.format3 + "refl_try_unify %s and %s, with uvs: %s {\n" + uu___4 uu___5 uu___6); + (let g1 = + FStarC_TypeChecker_Env.set_range g + t0.FStarC_Syntax_Syntax.pos in + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Compiler_Util.pimap_empty () in + (FStarC_TypeChecker_Env.trivial_guard, + [], uu___5) in + FStarC_Compiler_List.fold_left + (fun uu___5 -> + fun uu___6 -> + match (uu___5, uu___6) with + | ((guard_uvs, ss, tbl), (bv, t)) + -> + let t2 = + FStarC_Syntax_Subst.subst ss + t in + let uu___7 = + let reason = + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_bv + bv in + FStarC_Compiler_Util.format1 + "refl_try_unify for %s" + uu___8 in + let should_check_uvar = + FStarC_Syntax_Syntax.Allow_untyped + "refl_try_unify" in + FStarC_TypeChecker_Env.new_implicit_var_aux + reason + t0.FStarC_Syntax_Syntax.pos + g1 t2 should_check_uvar + FStar_Pervasives_Native.None + false in + (match uu___7 with + | (uv_t, (ctx_u, uu___8), + guard_uv) -> + let uv_id = + FStarC_Syntax_Unionfind.uvar_unique_id + ctx_u.FStarC_Syntax_Syntax.ctx_uvar_head in + let uu___9 = + FStarC_TypeChecker_Env.conj_guard + guard_uvs guard_uv in + let uu___10 = + FStarC_Compiler_Util.pimap_add + tbl uv_id + ((ctx_u.FStarC_Syntax_Syntax.ctx_uvar_head), + bv) in + (uu___9, + ((FStarC_Syntax_Syntax.NT + (bv, uv_t)) :: ss), + uu___10))) uu___4 uvs in + match uu___3 with + | (guard_uvs, ss, tbl) -> + let uu___4 = + let uu___5 = + FStarC_Syntax_Subst.subst ss t0 in + let uu___6 = + FStarC_Syntax_Subst.subst ss t1 in + (uu___5, uu___6) in + (match uu___4 with + | (t01, t11) -> + let g2 = + { + FStarC_TypeChecker_Env.solver = + (g1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (g1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule + = + (g1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (g1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig + = + (g1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache + = + (g1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules + = + (g1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ + = + (g1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (g1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab + = + (g1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp + = + (g1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects + = + (g1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize + = + (g1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs + = + (g1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level + = + (g1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars + = + (g1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict + = + (g1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface + = + (g1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + true; + FStarC_TypeChecker_Env.lax_universes + = + (g1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + true; + FStarC_TypeChecker_Env.failhard + = + (g1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking + = + (g1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping + = + (g1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics + = + (g1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce + = + (g1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term + = + (g1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (g1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of + = + (g1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (g1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force + = + (g1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (g1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (g1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (g1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths + = + (g1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns + = + (g1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook + = + (g1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (g1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (g1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess + = + (g1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess + = + (g1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info + = + (g1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks + = + (g1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (g1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (g1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab + = + (g1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (g1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (g1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (g1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (g1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check + = + (g1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl + = + (g1.FStarC_TypeChecker_Env.missing_decl) + } in + let guard_eq = + let smt_ok = true in + FStarC_TypeChecker_Rel.try_teq + smt_ok g2 t01 t11 in + let l = + match guard_eq with + | FStar_Pervasives_Native.None -> + [] + | FStar_Pervasives_Native.Some + guard -> + let guard1 = + FStarC_TypeChecker_Env.conj_guard + guard_uvs guard in + let guard2 = + let uu___5 = + FStarC_TypeChecker_Rel.solve_deferred_constraints + g2 guard1 in + FStarC_TypeChecker_Rel.resolve_implicits + g2 uu___5 in + let b = + let uu___5 = + FStarC_Class_Listlike.to_list + (FStarC_Compiler_CList.listlike_clist + ()) + guard2.FStarC_TypeChecker_Common.implicits in + FStarC_Compiler_List.existsb + (fun uu___6 -> + match uu___6 with + | { + FStarC_TypeChecker_Common.imp_reason + = uu___7; + FStarC_TypeChecker_Common.imp_uvar + = + { + FStarC_Syntax_Syntax.ctx_uvar_head + = + (uv, uu___8, + uu___9); + FStarC_Syntax_Syntax.ctx_uvar_gamma + = uu___10; + FStarC_Syntax_Syntax.ctx_uvar_binders + = uu___11; + FStarC_Syntax_Syntax.ctx_uvar_reason + = uu___12; + FStarC_Syntax_Syntax.ctx_uvar_range + = uu___13; + FStarC_Syntax_Syntax.ctx_uvar_meta + = uu___14;_}; + FStarC_TypeChecker_Common.imp_tm + = uu___15; + FStarC_TypeChecker_Common.imp_range + = uu___16;_} + -> + let uu___17 = + let uu___18 = + FStarC_Unionfind.puf_unique_id + uv in + FStarC_Compiler_Util.pimap_try_find + tbl uu___18 in + uu___17 = + FStar_Pervasives_Native.None) + uu___5 in + if b + then [] + else + FStarC_Compiler_Util.pimap_fold + tbl + (fun id -> + fun uu___6 -> + fun l1 -> + match uu___6 with + | (uvar, bv) -> + let uu___7 = + FStarC_Syntax_Unionfind.find + uvar in + (match uu___7 + with + | FStar_Pervasives_Native.Some + t -> + let allow_uvars + = true in + let allow_names + = true in + let t2 = + FStarC_Syntax_Compress.deep_compress + allow_uvars + allow_names + t in + let uu___8 + = + let uu___9 + = + FStarC_Syntax_Free.uvars_full + t2 in + FStarC_Class_Setlike.is_empty + () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) + (Obj.magic + uu___9) in + if uu___8 + then + (bv, t2) + :: l1 + else l1 + | FStar_Pervasives_Native.None + -> l1)) + [] in + (dbg_refl g2 + (fun uu___6 -> + let uu___7 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + (FStarC_Class_Show.show_tuple2 + FStarC_Syntax_Print.showable_bv + FStarC_Syntax_Print.showable_term)) + l in + FStarC_Compiler_Util.format1 + "} refl_try_unify, substitution is: %s\n" + uu___7); + (l, []))))))) + else + Obj.magic + (Obj.repr + (let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_TypeChecker_Env.get_range g in + unexpected_uvars_issue uu___5 in + [uu___4] in + (FStar_Pervasives_Native.None, uu___3) in + FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic uu___2)))) uu___3 uu___2 uu___1 uu___ +let (refl_maybe_relate_after_unfolding : + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> + (FStarC_TypeChecker_Core.side FStar_Pervasives_Native.option * + issues) FStarC_Tactics_Monad.tac) + = + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun g -> + fun t0 -> + fun t1 -> + let uu___ = + ((no_uvars_in_g g) && (no_uvars_in_term t0)) && + (no_uvars_in_term t1) in + if uu___ + then + Obj.magic + (Obj.repr + (refl_typing_builtin_wrapper + "refl_maybe_relate_after_unfolding" + (fun uu___1 -> + let g1 = + FStarC_TypeChecker_Env.set_range g + t0.FStarC_Syntax_Syntax.pos in + dbg_refl g1 + (fun uu___3 -> + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t0 in + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.format2 + "refl_maybe_relate_after_unfolding: %s and %s {\n" + uu___4 uu___5); + (let s = + FStarC_TypeChecker_Core.maybe_relate_after_unfolding + g1 t0 t1 in + dbg_refl g1 + (fun uu___4 -> + let uu___5 = + FStarC_Class_Show.show + FStarC_TypeChecker_Core.showable_side s in + FStarC_Compiler_Util.format1 + "} returning side: %s\n" uu___5); + (s, []))))) + else + Obj.magic + (Obj.repr + (let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_TypeChecker_Env.get_range g in + unexpected_uvars_issue uu___5 in + [uu___4] in + (FStar_Pervasives_Native.None, uu___3) in + FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () (Obj.magic uu___2)))) + uu___2 uu___1 uu___ +let (refl_maybe_unfold_head : + env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option * issues) + FStarC_Tactics_Monad.tac) + = + fun uu___1 -> + fun uu___ -> + (fun g -> + fun e -> + let uu___ = (no_uvars_in_g g) && (no_uvars_in_term e) in + if uu___ + then + Obj.magic + (Obj.repr + (refl_typing_builtin_wrapper "refl_maybe_unfold_head" + (fun uu___1 -> + let g1 = + FStarC_TypeChecker_Env.set_range g + e.FStarC_Syntax_Syntax.pos in + dbg_refl g1 + (fun uu___3 -> + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term e in + FStarC_Compiler_Util.format1 + "refl_maybe_unfold_head: %s {\n" uu___4); + (let eopt = + FStarC_TypeChecker_Normalize.maybe_unfold_head g1 + e in + dbg_refl g1 + (fun uu___4 -> + let uu___5 = + match eopt with + | FStar_Pervasives_Native.None -> "none" + | FStar_Pervasives_Native.Some e1 -> + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term e1 in + FStarC_Compiler_Util.format1 "} eopt = %s\n" + uu___5); + if eopt = FStar_Pervasives_Native.None + then + (let uu___4 = + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term e in + FStarC_Compiler_Util.format1 + "Could not unfold head: %s\n" uu___5 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) e + FStarC_Errors_Codes.Fatal_UnexpectedTerm () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4)) + else + (let uu___5 = FStarC_Compiler_Util.must eopt in + (uu___5, [])))))) + else + Obj.magic + (Obj.repr + (let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_TypeChecker_Env.get_range g in + unexpected_uvars_issue uu___5 in + [uu___4] in + (FStar_Pervasives_Native.None, uu___3) in + FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac + () (Obj.magic uu___2)))) uu___1 uu___ +let (push_open_namespace : + env -> Prims.string Prims.list -> env FStarC_Tactics_Monad.tac) = + fun uu___1 -> + fun uu___ -> + (fun e -> + fun ns -> + let lid = + FStarC_Ident.lid_of_path ns + FStarC_Compiler_Range_Type.dummyRange in + let uu___ = + let uu___1 = + FStarC_Syntax_DsEnv.push_namespace + e.FStarC_TypeChecker_Env.dsenv lid + FStarC_Syntax_Syntax.Unrestricted in + { + FStarC_TypeChecker_Env.solver = + (e.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (e.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (e.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (e.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (e.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (e.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (e.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (e.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (e.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (e.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (e.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (e.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (e.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (e.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (e.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (e.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (e.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (e.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (e.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (e.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (e.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (e.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (e.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (e.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (e.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (e.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (e.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (e.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (e.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (e.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (e.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (e.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (e.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (e.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (e.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (e.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (e.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (e.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (e.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (e.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (e.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (e.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (e.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = uu___1; + FStarC_TypeChecker_Env.nbe = (e.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (e.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (e.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (e.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (e.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (e.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (e.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (e.FStarC_TypeChecker_Env.missing_decl) + } in + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () + (Obj.magic uu___))) uu___1 uu___ +let (push_module_abbrev : + env -> + Prims.string -> Prims.string Prims.list -> env FStarC_Tactics_Monad.tac) + = + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun e -> + fun n -> + fun m -> + let mlid = + FStarC_Ident.lid_of_path m + FStarC_Compiler_Range_Type.dummyRange in + let ident = FStarC_Ident.id_of_text n in + let uu___ = + let uu___1 = + FStarC_Syntax_DsEnv.push_module_abbrev + e.FStarC_TypeChecker_Env.dsenv ident mlid in + { + FStarC_TypeChecker_Env.solver = + (e.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (e.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (e.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (e.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (e.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (e.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (e.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (e.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (e.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (e.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (e.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (e.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (e.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (e.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (e.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (e.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (e.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (e.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (e.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (e.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (e.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (e.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (e.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (e.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (e.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (e.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (e.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (e.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (e.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (e.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (e.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (e.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (e.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (e.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (e.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (e.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (e.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (e.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (e.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (e.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (e.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (e.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (e.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = uu___1; + FStarC_TypeChecker_Env.nbe = + (e.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (e.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (e.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (e.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (e.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (e.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (e.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (e.FStarC_TypeChecker_Env.missing_decl) + } in + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () + (Obj.magic uu___))) uu___2 uu___1 uu___ +let (resolve_name : + env -> + Prims.string Prims.list -> + (FStarC_Syntax_Syntax.bv, FStarC_Syntax_Syntax.fv) + FStar_Pervasives.either FStar_Pervasives_Native.option + FStarC_Tactics_Monad.tac) + = + fun uu___1 -> + fun uu___ -> + (fun e -> + fun n -> + let l = + FStarC_Ident.lid_of_path n FStarC_Compiler_Range_Type.dummyRange in + let uu___ = + FStarC_Syntax_DsEnv.resolve_name e.FStarC_TypeChecker_Env.dsenv + l in + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () + (Obj.magic uu___))) uu___1 uu___ +let (log_issues : + FStarC_Errors.issue Prims.list -> unit FStarC_Tactics_Monad.tac) = + fun is -> + FStarC_Class_Monad.op_let_Bang FStarC_Tactics_Monad.monad_tac () () + (Obj.magic FStarC_Tactics_Monad.get) + (fun uu___ -> + (fun ps -> + let ps = Obj.magic ps in + let is1 = + if ps.FStarC_Tactics_Types.dump_on_failure + then + FStarC_Compiler_List.map + (fun i -> + let uu___ = + let uu___1 = + FStarC_Errors_Msg.text "Tactic logged issue:" in + uu___1 :: (i.FStarC_Errors.issue_msg) in + { + FStarC_Errors.issue_msg = uu___; + FStarC_Errors.issue_level = + (i.FStarC_Errors.issue_level); + FStarC_Errors.issue_range = + (i.FStarC_Errors.issue_range); + FStarC_Errors.issue_number = + (i.FStarC_Errors.issue_number); + FStarC_Errors.issue_ctx = (i.FStarC_Errors.issue_ctx) + }) is + else is in + FStarC_Errors.add_issues is1; + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () + (Obj.repr ()))) uu___) +let (tac_env : FStarC_TypeChecker_Env.env -> FStarC_TypeChecker_Env.env) = + fun env1 -> + let uu___ = FStarC_TypeChecker_Env.clear_expected_typ env1 in + match uu___ with + | (env2, uu___1) -> + let env3 = + { + FStarC_TypeChecker_Env.solver = + (env2.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env2.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env2.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env2.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env2.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env2.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env2.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env2.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env2.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env2.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = false; + FStarC_TypeChecker_Env.effects = + (env2.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env2.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env2.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env2.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env2.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env2.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env2.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env2.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env2.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env2.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env2.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env2.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env2.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env2.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env2.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env2.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env2.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env2.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env2.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env2.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env2.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env2.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env2.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env2.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env2.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env2.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env2.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env2.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env2.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env2.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env2.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env2.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env2.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = (env2.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env2.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env2.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env2.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env2.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env2.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env2.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env2.FStarC_TypeChecker_Env.missing_decl) + } in + let env4 = + { + FStarC_TypeChecker_Env.solver = + (env3.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env3.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env3.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env3.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env3.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env3.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env3.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env3.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env3.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env3.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env3.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env3.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env3.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env3.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env3.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env3.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env3.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env3.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env3.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env3.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env3.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = true; + FStarC_TypeChecker_Env.flychecking = + (env3.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env3.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env3.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env3.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env3.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env3.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env3.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env3.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env3.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env3.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env3.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env3.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env3.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env3.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env3.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env3.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env3.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env3.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env3.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env3.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env3.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env3.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = (env3.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env3.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env3.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env3.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env3.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env3.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env3.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env3.FStarC_TypeChecker_Env.missing_decl) + } in + let env5 = + { + FStarC_TypeChecker_Env.solver = + (env4.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env4.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env4.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env4.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env4.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env4.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env4.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env4.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env4.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env4.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env4.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env4.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env4.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env4.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env4.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env4.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env4.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env4.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env4.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env4.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env4.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env4.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env4.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env4.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env4.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env4.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env4.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env4.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env4.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env4.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env4.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env4.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env4.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env4.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env4.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env4.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env4.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env4.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env4.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env4.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env4.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env4.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env4.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env4.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = (env4.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env4.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env4.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = false; + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env4.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env4.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env4.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env4.FStarC_TypeChecker_Env.missing_decl) + } in + env5 +let (proofstate_of_goals : + FStarC_Compiler_Range_Type.range -> + env -> + FStarC_Tactics_Types.goal Prims.list -> + FStarC_TypeChecker_Common.implicit Prims.list -> + FStarC_Tactics_Types.proofstate) + = + fun rng -> + fun env1 -> + fun goals -> + fun imps -> + let env2 = tac_env env1 in + let ps = + let uu___ = FStarC_Compiler_Effect.op_Bang dbg_TacVerbose in + let uu___1 = FStarC_Compiler_Util.psmap_empty () in + { + FStarC_Tactics_Types.main_context = env2; + FStarC_Tactics_Types.all_implicits = imps; + FStarC_Tactics_Types.goals = goals; + FStarC_Tactics_Types.smt_goals = []; + FStarC_Tactics_Types.depth = Prims.int_zero; + FStarC_Tactics_Types.__dump = + FStarC_Tactics_Printing.do_dump_proofstate; + FStarC_Tactics_Types.psc = + FStarC_TypeChecker_Primops_Base.null_psc; + FStarC_Tactics_Types.entry_range = rng; + FStarC_Tactics_Types.guard_policy = FStarC_Tactics_Types.SMT; + FStarC_Tactics_Types.freshness = Prims.int_zero; + FStarC_Tactics_Types.tac_verb_dbg = uu___; + FStarC_Tactics_Types.local_state = uu___1; + FStarC_Tactics_Types.urgency = Prims.int_one; + FStarC_Tactics_Types.dump_on_failure = true + } in + ps +let (proofstate_of_goal_ty : + FStarC_Compiler_Range_Type.range -> + env -> + FStarC_Syntax_Syntax.typ -> + (FStarC_Tactics_Types.proofstate * FStarC_Syntax_Syntax.term)) + = + fun rng -> + fun env1 -> + fun typ -> + let env2 = + { + FStarC_TypeChecker_Env.solver = + (env1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = rng; + FStarC_TypeChecker_Env.curmodule = + (env1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env1.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = (env1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env1.FStarC_TypeChecker_Env.missing_decl) + } in + let env3 = tac_env env2 in + let uu___ = FStarC_Tactics_Types.goal_of_goal_ty env3 typ in + match uu___ with + | (g, g_u) -> + let ps = + let uu___1 = + FStarC_Class_Listlike.to_list + (FStarC_Compiler_CList.listlike_clist ()) + g_u.FStarC_TypeChecker_Common.implicits in + proofstate_of_goals rng env3 [g] uu___1 in + let uu___1 = FStarC_Tactics_Types.goal_witness g in (ps, uu___1) +let (proofstate_of_all_implicits : + FStarC_Compiler_Range_Type.range -> + env -> + implicits -> + (FStarC_Tactics_Types.proofstate * FStarC_Syntax_Syntax.term)) + = + fun rng -> + fun env1 -> + fun imps -> + let env2 = tac_env env1 in + let goals = + FStarC_Compiler_List.map + (FStarC_Tactics_Types.goal_of_implicit env2) imps in + let w = + let uu___ = FStarC_Compiler_List.hd goals in + FStarC_Tactics_Types.goal_witness uu___ in + let ps = + let uu___ = FStarC_Compiler_Effect.op_Bang dbg_TacVerbose in + let uu___1 = FStarC_Compiler_Util.psmap_empty () in + { + FStarC_Tactics_Types.main_context = env2; + FStarC_Tactics_Types.all_implicits = imps; + FStarC_Tactics_Types.goals = goals; + FStarC_Tactics_Types.smt_goals = []; + FStarC_Tactics_Types.depth = Prims.int_zero; + FStarC_Tactics_Types.__dump = + FStarC_Tactics_Printing.do_dump_proofstate; + FStarC_Tactics_Types.psc = + FStarC_TypeChecker_Primops_Base.null_psc; + FStarC_Tactics_Types.entry_range = rng; + FStarC_Tactics_Types.guard_policy = FStarC_Tactics_Types.SMT; + FStarC_Tactics_Types.freshness = Prims.int_zero; + FStarC_Tactics_Types.tac_verb_dbg = uu___; + FStarC_Tactics_Types.local_state = uu___1; + FStarC_Tactics_Types.urgency = Prims.int_one; + FStarC_Tactics_Types.dump_on_failure = true + } in + (ps, w) +let (getprop : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = + fun e -> + fun t -> + let tn = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Weak; + FStarC_TypeChecker_Env.HNF; + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant] e t in + FStarC_Syntax_Util.un_squash tn +let run_unembedded_tactic_on_ps_and_solve_remaining : + 'a 'b . + FStarC_Compiler_Range_Type.range -> + FStarC_Compiler_Range_Type.range -> + Prims.bool -> + 'a -> + ('a -> 'b FStarC_Tactics_Monad.tac) -> + FStarC_Tactics_Types.proofstate -> 'b + = + fun t_range -> + fun g_range -> + fun background -> + fun t -> + fun f -> + fun ps -> + let uu___ = + FStarC_Tactics_Interpreter.run_unembedded_tactic_on_ps + t_range g_range background t f ps in + match uu___ with + | (remaining_goals, r) -> + (FStarC_Compiler_List.iter + (fun g -> + let uu___2 = + let uu___3 = FStarC_Tactics_Types.goal_env g in + let uu___4 = FStarC_Tactics_Types.goal_type g in + getprop uu___3 uu___4 in + match uu___2 with + | FStar_Pervasives_Native.Some vc -> + let guard = + FStarC_TypeChecker_Env.guard_of_guard_formula + (FStarC_TypeChecker_Common.NonTrivial vc) in + let uu___3 = FStarC_Tactics_Types.goal_env g in + FStarC_TypeChecker_Rel.force_trivial_guard uu___3 + guard + | FStar_Pervasives_Native.None -> + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range g_range + FStarC_Errors_Codes.Fatal_OpenGoalsInSynthesis + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "tactic left a computationally-relevant goal unsolved")) + remaining_goals; + r) +let (call_subtac : + env -> + unit FStarC_Tactics_Monad.tac -> + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.typ -> + (FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option * issues) + FStarC_Tactics_Monad.tac) + = + fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun g -> + fun f -> + fun _u -> + fun goal_ty -> + let uu___ = + FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac + () (Obj.repr ()) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + let rng = FStarC_TypeChecker_Env.get_range g in + let uu___2 = + proofstate_of_goal_ty rng g goal_ty in + match uu___2 with + | (ps, w) -> + let ps1 = + { + FStarC_Tactics_Types.main_context = + (ps.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits = + (ps.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = + (ps.FStarC_Tactics_Types.goals); + FStarC_Tactics_Types.smt_goals = + (ps.FStarC_Tactics_Types.smt_goals); + FStarC_Tactics_Types.depth = + (ps.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = + (ps.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = + (ps.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (ps.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = + (ps.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness = + (ps.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg = + (ps.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = + (ps.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency = + (ps.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure = + false + } in + let uu___3 = + FStarC_Errors.catch_errors_and_ignore_rest + (fun uu___4 -> + run_unembedded_tactic_on_ps_and_solve_remaining + rng rng false () (fun uu___5 -> f) + ps1) in + (match uu___3 with + | ([], FStar_Pervasives_Native.Some ()) -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic + ((FStar_Pervasives_Native.Some + w), []))) + | (issues1, uu___4) -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic + (FStar_Pervasives_Native.None, + issues1))))) uu___1))) + uu___3 uu___2 uu___1 uu___ +let run_tactic_on_ps_and_solve_remaining : + 'a 'b . + FStarC_Compiler_Range_Type.range -> + FStarC_Compiler_Range_Type.range -> + Prims.bool -> + 'a -> + FStarC_Syntax_Syntax.term -> + FStarC_Tactics_Types.proofstate -> unit + = + fun t_range -> + fun g_range -> + fun background -> + fun t -> + fun f_tm -> + fun ps -> + let uu___ = + FStarC_Tactics_Interpreter.run_tactic_on_ps t_range g_range + background FStarC_Syntax_Embeddings.e_unit () + FStarC_Syntax_Embeddings.e_unit f_tm false ps in + match uu___ with + | (remaining_goals, r) -> + FStarC_Compiler_List.iter + (fun g -> + let uu___2 = + let uu___3 = FStarC_Tactics_Types.goal_env g in + let uu___4 = FStarC_Tactics_Types.goal_type g in + getprop uu___3 uu___4 in + match uu___2 with + | FStar_Pervasives_Native.Some vc -> + let guard = + FStarC_TypeChecker_Env.guard_of_guard_formula + (FStarC_TypeChecker_Common.NonTrivial vc) in + let uu___3 = FStarC_Tactics_Types.goal_env g in + FStarC_TypeChecker_Rel.force_trivial_guard uu___3 + guard + | FStar_Pervasives_Native.None -> + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range g_range + FStarC_Errors_Codes.Fatal_OpenGoalsInSynthesis + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "tactic left a computationally-relevant goal unsolved")) + remaining_goals +let (call_subtac_tm : + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.typ -> + (FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option * issues) + FStarC_Tactics_Monad.tac) + = + fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun g -> + fun f_tm -> + fun _u -> + fun goal_ty -> + let uu___ = + FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac + () (Obj.repr ()) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Tactics_Monad.monad_tac () () uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + let rng = FStarC_TypeChecker_Env.get_range g in + let uu___2 = + proofstate_of_goal_ty rng g goal_ty in + match uu___2 with + | (ps, w) -> + let ps1 = + { + FStarC_Tactics_Types.main_context = + (ps.FStarC_Tactics_Types.main_context); + FStarC_Tactics_Types.all_implicits = + (ps.FStarC_Tactics_Types.all_implicits); + FStarC_Tactics_Types.goals = + (ps.FStarC_Tactics_Types.goals); + FStarC_Tactics_Types.smt_goals = + (ps.FStarC_Tactics_Types.smt_goals); + FStarC_Tactics_Types.depth = + (ps.FStarC_Tactics_Types.depth); + FStarC_Tactics_Types.__dump = + (ps.FStarC_Tactics_Types.__dump); + FStarC_Tactics_Types.psc = + (ps.FStarC_Tactics_Types.psc); + FStarC_Tactics_Types.entry_range = + (ps.FStarC_Tactics_Types.entry_range); + FStarC_Tactics_Types.guard_policy = + (ps.FStarC_Tactics_Types.guard_policy); + FStarC_Tactics_Types.freshness = + (ps.FStarC_Tactics_Types.freshness); + FStarC_Tactics_Types.tac_verb_dbg = + (ps.FStarC_Tactics_Types.tac_verb_dbg); + FStarC_Tactics_Types.local_state = + (ps.FStarC_Tactics_Types.local_state); + FStarC_Tactics_Types.urgency = + (ps.FStarC_Tactics_Types.urgency); + FStarC_Tactics_Types.dump_on_failure = + false + } in + let uu___3 = + FStarC_Errors.catch_errors_and_ignore_rest + (fun uu___4 -> + run_tactic_on_ps_and_solve_remaining + rng rng false () f_tm ps1) in + (match uu___3 with + | ([], FStar_Pervasives_Native.Some ()) -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic + ((FStar_Pervasives_Native.Some + w), []))) + | (issues1, uu___4) -> + Obj.magic + (FStarC_Class_Monad.return + FStarC_Tactics_Monad.monad_tac () + (Obj.magic + (FStar_Pervasives_Native.None, + issues1))))) uu___1))) + uu___3 uu___2 uu___1 uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Tactics_V2_Primops.ml b/ocaml/fstar-lib/generated/FStarC_Tactics_V2_Primops.ml new file mode 100644 index 00000000000..ee7a1ff8cde --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Tactics_V2_Primops.ml @@ -0,0 +1,2229 @@ +open Prims +let solve : 'a . 'a -> 'a = fun ev -> ev +let (uu___0 : + FStarC_Syntax_Syntax.term FStarC_Syntax_Embeddings_Base.embedding) = + FStarC_Reflection_V2_Embeddings.e_term +let unseal : + 'uuuuu 'a . + 'uuuuu -> 'a FStarC_Compiler_Sealed.sealed -> 'a FStarC_Tactics_Monad.tac + = + fun uu___1 -> + fun uu___ -> + (fun _typ -> + fun x -> + Obj.magic + (FStarC_Class_Monad.return FStarC_Tactics_Monad.monad_tac () + (Obj.magic (FStarC_Compiler_Sealed.unseal x)))) uu___1 uu___ +let (unseal_step : FStarC_TypeChecker_Primops_Base.primitive_step) = + let s = + FStarC_Tactics_InterpFuns.mk_tac_step_2 Prims.int_one "unseal" + FStarC_Syntax_Embeddings.e_any + (FStarC_Syntax_Embeddings.e_sealed FStarC_Syntax_Embeddings.e_any) + FStarC_Syntax_Embeddings.e_any FStarC_TypeChecker_NBETerm.e_any + (FStarC_TypeChecker_NBETerm.e_sealed FStarC_TypeChecker_NBETerm.e_any) + FStarC_TypeChecker_NBETerm.e_any unseal unseal in + { + FStarC_TypeChecker_Primops_Base.name = FStarC_Parser_Const.unseal_lid; + FStarC_TypeChecker_Primops_Base.arity = + (s.FStarC_TypeChecker_Primops_Base.arity); + FStarC_TypeChecker_Primops_Base.univ_arity = + (s.FStarC_TypeChecker_Primops_Base.univ_arity); + FStarC_TypeChecker_Primops_Base.auto_reflect = + (s.FStarC_TypeChecker_Primops_Base.auto_reflect); + FStarC_TypeChecker_Primops_Base.strong_reduction_ok = + (s.FStarC_TypeChecker_Primops_Base.strong_reduction_ok); + FStarC_TypeChecker_Primops_Base.requires_binder_substitution = + (s.FStarC_TypeChecker_Primops_Base.requires_binder_substitution); + FStarC_TypeChecker_Primops_Base.renorm_after = + (s.FStarC_TypeChecker_Primops_Base.renorm_after); + FStarC_TypeChecker_Primops_Base.interpretation = + (s.FStarC_TypeChecker_Primops_Base.interpretation); + FStarC_TypeChecker_Primops_Base.interpretation_nbe = + (s.FStarC_TypeChecker_Primops_Base.interpretation_nbe) + } +let e_ret_t : + 'a . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + ('a FStar_Pervasives_Native.option * FStarC_Tactics_V2_Basic.issues) + FStarC_Syntax_Embeddings_Base.embedding + = + fun d -> + solve + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_option d) + (FStarC_Syntax_Embeddings.e_list FStarC_Syntax_Embeddings.e_issue)) +let nbe_e_ret_t : + 'a . + 'a FStarC_TypeChecker_NBETerm.embedding -> + ('a FStar_Pervasives_Native.option * FStarC_Tactics_V2_Basic.issues) + FStarC_TypeChecker_NBETerm.embedding + = + fun d -> + solve + (FStarC_TypeChecker_NBETerm.e_tuple2 + (FStarC_TypeChecker_NBETerm.e_option d) + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_issue)) +let (ops : FStarC_TypeChecker_Primops_Base.primitive_step Prims.list) = + let uu___ = + FStarC_Tactics_InterpFuns.mk_tot_step_1_psc Prims.int_zero "tracepoint" + FStarC_Tactics_Embedding.e_proofstate FStarC_Syntax_Embeddings.e_bool + FStarC_Tactics_Embedding.e_proofstate_nbe + FStarC_TypeChecker_NBETerm.e_bool + FStarC_Tactics_Types.tracepoint_with_psc + FStarC_Tactics_Types.tracepoint_with_psc in + let uu___1 = + let uu___2 = + FStarC_Tactics_InterpFuns.mk_tot_step_2 Prims.int_zero + "set_proofstate_range" FStarC_Tactics_Embedding.e_proofstate + FStarC_Syntax_Embeddings.e_range + FStarC_Tactics_Embedding.e_proofstate + FStarC_Tactics_Embedding.e_proofstate_nbe + FStarC_TypeChecker_NBETerm.e_range + FStarC_Tactics_Embedding.e_proofstate_nbe + FStarC_Tactics_Types.set_proofstate_range + FStarC_Tactics_Types.set_proofstate_range in + let uu___3 = + let uu___4 = + FStarC_Tactics_InterpFuns.mk_tot_step_1 Prims.int_zero "incr_depth" + FStarC_Tactics_Embedding.e_proofstate + FStarC_Tactics_Embedding.e_proofstate + FStarC_Tactics_Embedding.e_proofstate_nbe + FStarC_Tactics_Embedding.e_proofstate_nbe + FStarC_Tactics_Types.incr_depth FStarC_Tactics_Types.incr_depth in + let uu___5 = + let uu___6 = + FStarC_Tactics_InterpFuns.mk_tot_step_1 Prims.int_zero "decr_depth" + FStarC_Tactics_Embedding.e_proofstate + FStarC_Tactics_Embedding.e_proofstate + FStarC_Tactics_Embedding.e_proofstate_nbe + FStarC_Tactics_Embedding.e_proofstate_nbe + FStarC_Tactics_Types.decr_depth FStarC_Tactics_Types.decr_depth in + let uu___7 = + let uu___8 = + FStarC_Tactics_InterpFuns.mk_tot_step_1 Prims.int_zero "goals_of" + FStarC_Tactics_Embedding.e_proofstate + (FStarC_Syntax_Embeddings.e_list + FStarC_Tactics_Embedding.e_goal) + FStarC_Tactics_Embedding.e_proofstate_nbe + (FStarC_TypeChecker_NBETerm.e_list + FStarC_Tactics_Embedding.e_goal_nbe) + FStarC_Tactics_Types.goals_of FStarC_Tactics_Types.goals_of in + let uu___9 = + let uu___10 = + FStarC_Tactics_InterpFuns.mk_tot_step_1 Prims.int_zero + "smt_goals_of" FStarC_Tactics_Embedding.e_proofstate + (FStarC_Syntax_Embeddings.e_list + FStarC_Tactics_Embedding.e_goal) + FStarC_Tactics_Embedding.e_proofstate_nbe + (FStarC_TypeChecker_NBETerm.e_list + FStarC_Tactics_Embedding.e_goal_nbe) + FStarC_Tactics_Types.smt_goals_of + FStarC_Tactics_Types.smt_goals_of in + let uu___11 = + let uu___12 = + FStarC_Tactics_InterpFuns.mk_tot_step_1 Prims.int_zero + "goal_env" FStarC_Tactics_Embedding.e_goal + FStarC_Reflection_V2_Embeddings.e_env + FStarC_Tactics_Embedding.e_goal_nbe + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_Tactics_Types.goal_env FStarC_Tactics_Types.goal_env in + let uu___13 = + let uu___14 = + FStarC_Tactics_InterpFuns.mk_tot_step_1 Prims.int_zero + "goal_type" FStarC_Tactics_Embedding.e_goal uu___0 + FStarC_Tactics_Embedding.e_goal_nbe + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Tactics_Types.goal_type + FStarC_Tactics_Types.goal_type in + let uu___15 = + let uu___16 = + FStarC_Tactics_InterpFuns.mk_tot_step_1 Prims.int_zero + "goal_witness" FStarC_Tactics_Embedding.e_goal uu___0 + FStarC_Tactics_Embedding.e_goal_nbe + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Tactics_Types.goal_witness + FStarC_Tactics_Types.goal_witness in + let uu___17 = + let uu___18 = + FStarC_Tactics_InterpFuns.mk_tot_step_1 Prims.int_zero + "is_guard" FStarC_Tactics_Embedding.e_goal + FStarC_Syntax_Embeddings.e_bool + FStarC_Tactics_Embedding.e_goal_nbe + FStarC_TypeChecker_NBETerm.e_bool + FStarC_Tactics_Types.is_guard + FStarC_Tactics_Types.is_guard in + let uu___19 = + let uu___20 = + FStarC_Tactics_InterpFuns.mk_tot_step_1 + Prims.int_zero "get_label" + FStarC_Tactics_Embedding.e_goal + FStarC_Syntax_Embeddings.e_string + FStarC_Tactics_Embedding.e_goal_nbe + FStarC_TypeChecker_NBETerm.e_string + FStarC_Tactics_Types.get_label + FStarC_Tactics_Types.get_label in + let uu___21 = + let uu___22 = + FStarC_Tactics_InterpFuns.mk_tot_step_2 + Prims.int_zero "set_label" + FStarC_Syntax_Embeddings.e_string + FStarC_Tactics_Embedding.e_goal + FStarC_Tactics_Embedding.e_goal + FStarC_TypeChecker_NBETerm.e_string + FStarC_Tactics_Embedding.e_goal_nbe + FStarC_Tactics_Embedding.e_goal_nbe + FStarC_Tactics_Types.set_label + FStarC_Tactics_Types.set_label in + let uu___23 = + let uu___24 = + let uu___25 = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero "compress" uu___0 uu___0 + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Tactics_V2_Basic.compress + FStarC_Tactics_V2_Basic.compress in + let uu___26 = + let uu___27 = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero "set_goals" + (FStarC_Syntax_Embeddings.e_list + FStarC_Tactics_Embedding.e_goal) + FStarC_Syntax_Embeddings.e_unit + (FStarC_TypeChecker_NBETerm.e_list + FStarC_Tactics_Embedding.e_goal_nbe) + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_Monad.set_goals + FStarC_Tactics_Monad.set_goals in + let uu___28 = + let uu___29 = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero "set_smt_goals" + (FStarC_Syntax_Embeddings.e_list + FStarC_Tactics_Embedding.e_goal) + FStarC_Syntax_Embeddings.e_unit + (FStarC_TypeChecker_NBETerm.e_list + FStarC_Tactics_Embedding.e_goal_nbe) + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_Monad.set_smt_goals + FStarC_Tactics_Monad.set_smt_goals in + let uu___30 = + let uu___31 = + let uu___32 = + FStarC_Tactics_Interpreter.e_tactic_thunk + FStarC_Syntax_Embeddings.e_any in + let uu___33 = + FStarC_Tactics_Interpreter.e_tactic_nbe_thunk + FStarC_TypeChecker_NBETerm.e_any in + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_one "catch" + FStarC_Syntax_Embeddings.e_any uu___32 + (FStarC_Syntax_Embeddings.e_either + FStarC_Tactics_Embedding.e_exn + FStarC_Syntax_Embeddings.e_any) + FStarC_TypeChecker_NBETerm.e_any + uu___33 + (FStarC_TypeChecker_NBETerm.e_either + FStarC_Tactics_Embedding.e_exn_nbe + FStarC_TypeChecker_NBETerm.e_any) + (fun uu___34 -> + FStarC_Tactics_Monad.catch) + (fun uu___34 -> + FStarC_Tactics_Monad.catch) in + let uu___32 = + let uu___33 = + let uu___34 = + FStarC_Tactics_Interpreter.e_tactic_thunk + FStarC_Syntax_Embeddings.e_any in + let uu___35 = + FStarC_Tactics_Interpreter.e_tactic_nbe_thunk + FStarC_TypeChecker_NBETerm.e_any in + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_one "recover" + FStarC_Syntax_Embeddings.e_any + uu___34 + (FStarC_Syntax_Embeddings.e_either + FStarC_Tactics_Embedding.e_exn + FStarC_Syntax_Embeddings.e_any) + FStarC_TypeChecker_NBETerm.e_any + uu___35 + (FStarC_TypeChecker_NBETerm.e_either + FStarC_Tactics_Embedding.e_exn_nbe + FStarC_TypeChecker_NBETerm.e_any) + (fun uu___36 -> + FStarC_Tactics_Monad.recover) + (fun uu___36 -> + FStarC_Tactics_Monad.recover) in + let uu___34 = + let uu___35 = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero "intro" + FStarC_Syntax_Embeddings.e_unit + FStarC_Reflection_V2_Embeddings.e_binding + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Reflection_V2_NBEEmbeddings.e_binding + FStarC_Tactics_V2_Basic.intro + FStarC_Tactics_V2_Basic.intro in + let uu___36 = + let uu___37 = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero "intros" + FStarC_Syntax_Embeddings.e_int + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_binding) + FStarC_TypeChecker_NBETerm.e_int + (FStarC_TypeChecker_NBETerm.e_list + FStarC_Reflection_V2_NBEEmbeddings.e_binding) + FStarC_Tactics_V2_Basic.intros + FStarC_Tactics_V2_Basic.intros in + let uu___38 = + let uu___39 = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero "intro_rec" + FStarC_Syntax_Embeddings.e_unit + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Reflection_V2_Embeddings.e_binding + FStarC_Reflection_V2_Embeddings.e_binding) + FStarC_TypeChecker_NBETerm.e_unit + (FStarC_TypeChecker_NBETerm.e_tuple2 + FStarC_Reflection_V2_NBEEmbeddings.e_binding + FStarC_Reflection_V2_NBEEmbeddings.e_binding) + FStarC_Tactics_V2_Basic.intro_rec + FStarC_Tactics_V2_Basic.intro_rec in + let uu___40 = + let uu___41 = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero "norm" + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_norm_step) + FStarC_Syntax_Embeddings.e_unit + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_norm_step) + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.norm + FStarC_Tactics_V2_Basic.norm in + let uu___42 = + let uu___43 = + FStarC_Tactics_InterpFuns.mk_tac_step_3 + Prims.int_zero + "norm_term_env" + FStarC_Reflection_V2_Embeddings.e_env + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_norm_step) + uu___0 uu___0 + FStarC_Reflection_V2_NBEEmbeddings.e_env + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_norm_step) + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Tactics_V2_Basic.norm_term_env + FStarC_Tactics_V2_Basic.norm_term_env in + let uu___44 = + let uu___45 = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_zero + "norm_binding_type" + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_norm_step) + FStarC_Reflection_V2_Embeddings.e_binding + FStarC_Syntax_Embeddings.e_unit + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_norm_step) + FStarC_Reflection_V2_NBEEmbeddings.e_binding + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.norm_binding_type + FStarC_Tactics_V2_Basic.norm_binding_type in + let uu___46 = + let uu___47 = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_zero + "rename_to" + FStarC_Reflection_V2_Embeddings.e_binding + FStarC_Syntax_Embeddings.e_string + FStarC_Reflection_V2_Embeddings.e_binding + FStarC_Reflection_V2_NBEEmbeddings.e_binding + FStarC_TypeChecker_NBETerm.e_string + FStarC_Reflection_V2_NBEEmbeddings.e_binding + FStarC_Tactics_V2_Basic.rename_to + FStarC_Tactics_V2_Basic.rename_to in + let uu___48 = + let uu___49 = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "var_retype" + FStarC_Reflection_V2_Embeddings.e_binding + FStarC_Syntax_Embeddings.e_unit + FStarC_Reflection_V2_NBEEmbeddings.e_binding + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.var_retype + FStarC_Tactics_V2_Basic.var_retype in + let uu___50 = + let uu___51 = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "revert" + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_unit + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.revert + FStarC_Tactics_V2_Basic.revert in + let uu___52 = + let uu___53 = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "clear_top" + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_unit + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.clear_top + FStarC_Tactics_V2_Basic.clear_top in + let uu___54 = + let uu___55 = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "clear" + FStarC_Reflection_V2_Embeddings.e_binding + FStarC_Syntax_Embeddings.e_unit + FStarC_Reflection_V2_NBEEmbeddings.e_binding + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.clear + FStarC_Tactics_V2_Basic.clear in + let uu___56 = + let uu___57 = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "rewrite" + FStarC_Reflection_V2_Embeddings.e_binding + FStarC_Syntax_Embeddings.e_unit + FStarC_Reflection_V2_NBEEmbeddings.e_binding + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.rewrite + FStarC_Tactics_V2_Basic.rewrite in + let uu___58 = + let uu___59 = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_zero + "grewrite" + uu___0 + uu___0 + FStarC_Syntax_Embeddings.e_unit + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.grewrite + FStarC_Tactics_V2_Basic.grewrite in + let uu___60 = + let uu___61 = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "refine_intro" + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_unit + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.refine_intro + FStarC_Tactics_V2_Basic.refine_intro in + let uu___62 = + let uu___63 + = + FStarC_Tactics_InterpFuns.mk_tac_step_3 + Prims.int_zero + "t_exact" + FStarC_Syntax_Embeddings.e_bool + FStarC_Syntax_Embeddings.e_bool + uu___0 + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_bool + FStarC_TypeChecker_NBETerm.e_bool + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.t_exact + FStarC_Tactics_V2_Basic.t_exact in + let uu___64 + = + let uu___65 + = + FStarC_Tactics_InterpFuns.mk_tac_step_4 + Prims.int_zero + "t_apply" + FStarC_Syntax_Embeddings.e_bool + FStarC_Syntax_Embeddings.e_bool + FStarC_Syntax_Embeddings.e_bool + uu___0 + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_bool + FStarC_TypeChecker_NBETerm.e_bool + FStarC_TypeChecker_NBETerm.e_bool + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.t_apply + FStarC_Tactics_V2_Basic.t_apply in + let uu___66 + = + let uu___67 + = + FStarC_Tactics_InterpFuns.mk_tac_step_3 + Prims.int_zero + "t_apply_lemma" + FStarC_Syntax_Embeddings.e_bool + FStarC_Syntax_Embeddings.e_bool + uu___0 + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_bool + FStarC_TypeChecker_NBETerm.e_bool + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.t_apply_lemma + FStarC_Tactics_V2_Basic.t_apply_lemma in + let uu___68 + = + let uu___69 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "set_options" + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.set_options + FStarC_Tactics_V2_Basic.set_options in + let uu___70 + = + let uu___71 + = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_zero + "tcc" + FStarC_Reflection_V2_Embeddings.e_env + uu___0 + FStarC_Reflection_V2_Embeddings.e_comp + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Reflection_V2_NBEEmbeddings.e_comp + FStarC_Tactics_V2_Basic.tcc + FStarC_Tactics_V2_Basic.tcc in + let uu___72 + = + let uu___73 + = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_zero + "tc" + FStarC_Reflection_V2_Embeddings.e_env + uu___0 + uu___0 + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Tactics_V2_Basic.tc + FStarC_Tactics_V2_Basic.tc in + let uu___74 + = + let uu___75 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "unshelve" + uu___0 + FStarC_Syntax_Embeddings.e_unit + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.unshelve + FStarC_Tactics_V2_Basic.unshelve in + let uu___76 + = + let uu___77 + = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_one + "unquote" + FStarC_Syntax_Embeddings.e_any + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Syntax_Embeddings.e_any + FStarC_TypeChecker_NBETerm.e_any + FStarC_Reflection_V2_NBEEmbeddings.e_term + FStarC_TypeChecker_NBETerm.e_any + FStarC_Tactics_V2_Basic.unquote + (fun + uu___78 + -> + fun + uu___79 + -> + failwith + "NBE unquote") in + let uu___78 + = + let uu___79 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "prune" + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.prune + FStarC_Tactics_V2_Basic.prune in + let uu___80 + = + let uu___81 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "addns" + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.addns + FStarC_Tactics_V2_Basic.addns in + let uu___82 + = + let uu___83 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "print" + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.print + FStarC_Tactics_V2_Basic.print in + let uu___84 + = + let uu___85 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "debugging" + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_bool + FStarC_TypeChecker_NBETerm.e_unit + FStarC_TypeChecker_NBETerm.e_bool + FStarC_Tactics_V2_Basic.debugging + FStarC_Tactics_V2_Basic.debugging in + let uu___86 + = + let uu___87 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "ide" + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_bool + FStarC_TypeChecker_NBETerm.e_unit + FStarC_TypeChecker_NBETerm.e_bool + FStarC_Tactics_V2_Basic.ide + FStarC_Tactics_V2_Basic.ide in + let uu___88 + = + let uu___89 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "dump" + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.dump + FStarC_Tactics_V2_Basic.dump in + let uu___90 + = + let uu___91 + = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_zero + "dump_all" + FStarC_Syntax_Embeddings.e_bool + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_bool + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.dump_all + FStarC_Tactics_V2_Basic.dump_all in + let uu___92 + = + let uu___93 + = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_zero + "dump_uvars_of" + FStarC_Tactics_Embedding.e_goal + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_unit + FStarC_Tactics_Embedding.e_goal_nbe + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.dump_uvars_of + FStarC_Tactics_V2_Basic.dump_uvars_of in + let uu___94 + = + let uu___95 + = + let uu___96 + = + FStarC_Tactics_Interpreter.e_tactic_1 + FStarC_Reflection_V2_Embeddings.e_term + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Syntax_Embeddings.e_bool + FStarC_Tactics_Embedding.e_ctrl_flag) in + let uu___97 + = + FStarC_Tactics_Interpreter.e_tactic_thunk + FStarC_Syntax_Embeddings.e_unit in + let uu___98 + = + FStarC_Tactics_Interpreter.e_tactic_nbe_1 + FStarC_Reflection_V2_NBEEmbeddings.e_term + (FStarC_TypeChecker_NBETerm.e_tuple2 + FStarC_TypeChecker_NBETerm.e_bool + FStarC_Tactics_Embedding.e_ctrl_flag_nbe) in + let uu___99 + = + FStarC_Tactics_Interpreter.e_tactic_nbe_thunk + FStarC_TypeChecker_NBETerm.e_unit in + FStarC_Tactics_InterpFuns.mk_tac_step_3 + Prims.int_zero + "ctrl_rewrite" + FStarC_Tactics_Embedding.e_direction + uu___96 + uu___97 + FStarC_Syntax_Embeddings.e_unit + FStarC_Tactics_Embedding.e_direction_nbe + uu___98 + uu___99 + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_CtrlRewrite.ctrl_rewrite + FStarC_Tactics_CtrlRewrite.ctrl_rewrite in + let uu___96 + = + let uu___97 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "t_trefl" + FStarC_Syntax_Embeddings.e_bool + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_bool + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.t_trefl + FStarC_Tactics_V2_Basic.t_trefl in + let uu___98 + = + let uu___99 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "dup" + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_unit + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.dup + FStarC_Tactics_V2_Basic.dup in + let uu___100 + = + let uu___101 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "tadmit_t" + uu___0 + FStarC_Syntax_Embeddings.e_unit + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.tadmit_t + FStarC_Tactics_V2_Basic.tadmit_t in + let uu___102 + = + let uu___103 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "join" + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_unit + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.join + FStarC_Tactics_V2_Basic.join in + let uu___104 + = + let uu___105 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "t_destruct" + uu___0 + (FStarC_Syntax_Embeddings.e_list + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Reflection_V2_Embeddings.e_fv + FStarC_Syntax_Embeddings.e_int)) + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + (FStarC_TypeChecker_NBETerm.e_list + (FStarC_TypeChecker_NBETerm.e_tuple2 + FStarC_Reflection_V2_NBEEmbeddings.e_fv + FStarC_TypeChecker_NBETerm.e_int)) + FStarC_Tactics_V2_Basic.t_destruct + FStarC_Tactics_V2_Basic.t_destruct in + let uu___106 + = + let uu___107 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "top_env" + FStarC_Syntax_Embeddings.e_unit + FStarC_Reflection_V2_Embeddings.e_env + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_Tactics_V2_Basic.top_env + FStarC_Tactics_V2_Basic.top_env in + let uu___108 + = + let uu___109 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "fresh" + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_unit + FStarC_TypeChecker_NBETerm.e_int + FStarC_Tactics_V2_Basic.fresh + FStarC_Tactics_V2_Basic.fresh in + let uu___110 + = + let uu___111 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "curms" + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_unit + FStarC_TypeChecker_NBETerm.e_int + FStarC_Tactics_V2_Basic.curms + FStarC_Tactics_V2_Basic.curms in + let uu___112 + = + let uu___113 + = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_zero + "uvar_env" + FStarC_Reflection_V2_Embeddings.e_env + (FStarC_Syntax_Embeddings.e_option + uu___0) + uu___0 + FStarC_Reflection_V2_NBEEmbeddings.e_env + (FStarC_TypeChecker_NBETerm.e_option + FStarC_Reflection_V2_NBEEmbeddings.e_attribute) + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Tactics_V2_Basic.uvar_env + FStarC_Tactics_V2_Basic.uvar_env in + let uu___114 + = + let uu___115 + = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_zero + "ghost_uvar_env" + FStarC_Reflection_V2_Embeddings.e_env + uu___0 + uu___0 + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Tactics_V2_Basic.ghost_uvar_env + FStarC_Tactics_V2_Basic.ghost_uvar_env in + let uu___116 + = + let uu___117 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "fresh_universe_uvar" + FStarC_Syntax_Embeddings.e_unit + uu___0 + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Tactics_V2_Basic.fresh_universe_uvar + FStarC_Tactics_V2_Basic.fresh_universe_uvar in + let uu___118 + = + let uu___119 + = + FStarC_Tactics_InterpFuns.mk_tac_step_3 + Prims.int_zero + "unify_env" + FStarC_Reflection_V2_Embeddings.e_env + uu___0 + uu___0 + FStarC_Syntax_Embeddings.e_bool + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_TypeChecker_NBETerm.e_bool + FStarC_Tactics_V2_Basic.unify_env + FStarC_Tactics_V2_Basic.unify_env in + let uu___120 + = + let uu___121 + = + FStarC_Tactics_InterpFuns.mk_tac_step_3 + Prims.int_zero + "unify_guard_env" + FStarC_Reflection_V2_Embeddings.e_env + uu___0 + uu___0 + FStarC_Syntax_Embeddings.e_bool + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_TypeChecker_NBETerm.e_bool + FStarC_Tactics_V2_Basic.unify_guard_env + FStarC_Tactics_V2_Basic.unify_guard_env in + let uu___122 + = + let uu___123 + = + FStarC_Tactics_InterpFuns.mk_tac_step_3 + Prims.int_zero + "match_env" + FStarC_Reflection_V2_Embeddings.e_env + uu___0 + uu___0 + FStarC_Syntax_Embeddings.e_bool + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_TypeChecker_NBETerm.e_bool + FStarC_Tactics_V2_Basic.match_env + FStarC_Tactics_V2_Basic.match_env in + let uu___124 + = + let uu___125 + = + FStarC_Tactics_InterpFuns.mk_tac_step_3 + Prims.int_zero + "launch_process" + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_string_list + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_string_list + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_string + FStarC_Tactics_V2_Basic.launch_process + FStarC_Tactics_V2_Basic.launch_process in + let uu___126 + = + let uu___127 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "change" + uu___0 + FStarC_Syntax_Embeddings.e_unit + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.change + FStarC_Tactics_V2_Basic.change in + let uu___128 + = + let uu___129 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "get_guard_policy" + FStarC_Syntax_Embeddings.e_unit + FStarC_Tactics_Embedding.e_guard_policy + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_Embedding.e_guard_policy_nbe + FStarC_Tactics_V2_Basic.get_guard_policy + FStarC_Tactics_V2_Basic.get_guard_policy in + let uu___130 + = + let uu___131 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "set_guard_policy" + FStarC_Tactics_Embedding.e_guard_policy + FStarC_Syntax_Embeddings.e_unit + FStarC_Tactics_Embedding.e_guard_policy_nbe + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.set_guard_policy + FStarC_Tactics_V2_Basic.set_guard_policy in + let uu___132 + = + let uu___133 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "lax_on" + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_bool + FStarC_TypeChecker_NBETerm.e_unit + FStarC_TypeChecker_NBETerm.e_bool + FStarC_Tactics_V2_Basic.lax_on + FStarC_Tactics_V2_Basic.lax_on in + let uu___134 + = + let uu___135 + = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_one + "lget" + FStarC_Syntax_Embeddings.e_any + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_any + FStarC_TypeChecker_NBETerm.e_any + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_any + FStarC_Tactics_V2_Basic.lget + (fun + uu___136 + -> + fun + uu___137 + -> + FStarC_Tactics_Monad.fail + "sorry, `lget` does not work in NBE") in + let uu___136 + = + let uu___137 + = + FStarC_Tactics_InterpFuns.mk_tac_step_3 + Prims.int_one + "lset" + FStarC_Syntax_Embeddings.e_any + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_any + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_any + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_any + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.lset + (fun + uu___138 + -> + fun + uu___139 + -> + fun + uu___140 + -> + FStarC_Tactics_Monad.fail + "sorry, `lset` does not work in NBE") in + let uu___138 + = + let uu___139 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_one + "set_urgency" + FStarC_Syntax_Embeddings.e_int + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_int + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.set_urgency + FStarC_Tactics_V2_Basic.set_urgency in + let uu___140 + = + let uu___141 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_one + "set_dump_on_failure" + FStarC_Syntax_Embeddings.e_bool + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_bool + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.set_dump_on_failure + FStarC_Tactics_V2_Basic.set_dump_on_failure in + let uu___142 + = + let uu___143 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_one + "t_commute_applied_match" + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_unit + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.t_commute_applied_match + FStarC_Tactics_V2_Basic.t_commute_applied_match in + let uu___144 + = + let uu___145 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "gather_or_solve_explicit_guards_for_resolved_goals" + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_unit + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.gather_explicit_guards_for_resolved_goals + FStarC_Tactics_V2_Basic.gather_explicit_guards_for_resolved_goals in + let uu___146 + = + let uu___147 + = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_zero + "string_to_term" + FStarC_Reflection_V2_Embeddings.e_env + FStarC_Syntax_Embeddings.e_string + uu___0 + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_TypeChecker_NBETerm.e_string + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Tactics_V2_Basic.string_to_term + FStarC_Tactics_V2_Basic.string_to_term in + let uu___148 + = + let uu___149 + = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_zero + "push_bv_dsenv" + FStarC_Reflection_V2_Embeddings.e_env + FStarC_Syntax_Embeddings.e_string + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Reflection_V2_Embeddings.e_env + FStarC_Reflection_V2_Embeddings.e_binding) + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_TypeChecker_NBETerm.e_string + (FStarC_TypeChecker_NBETerm.e_tuple2 + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_Reflection_V2_NBEEmbeddings.e_binding) + FStarC_Tactics_V2_Basic.push_bv_dsenv + FStarC_Tactics_V2_Basic.push_bv_dsenv in + let uu___150 + = + let uu___151 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "term_to_string" + uu___0 + FStarC_Syntax_Embeddings.e_string + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_TypeChecker_NBETerm.e_string + FStarC_Tactics_V2_Basic.term_to_string + FStarC_Tactics_V2_Basic.term_to_string in + let uu___152 + = + let uu___153 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "comp_to_string" + FStarC_Reflection_V2_Embeddings.e_comp + FStarC_Syntax_Embeddings.e_string + FStarC_Reflection_V2_NBEEmbeddings.e_comp + FStarC_TypeChecker_NBETerm.e_string + FStarC_Tactics_V2_Basic.comp_to_string + FStarC_Tactics_V2_Basic.comp_to_string in + let uu___154 + = + let uu___155 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "term_to_doc" + uu___0 + FStarC_Syntax_Embeddings.e_document + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_TypeChecker_NBETerm.e_document + FStarC_Tactics_V2_Basic.term_to_doc + FStarC_Tactics_V2_Basic.term_to_doc in + let uu___156 + = + let uu___157 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "comp_to_doc" + FStarC_Reflection_V2_Embeddings.e_comp + FStarC_Syntax_Embeddings.e_document + FStarC_Reflection_V2_NBEEmbeddings.e_comp + FStarC_TypeChecker_NBETerm.e_document + FStarC_Tactics_V2_Basic.comp_to_doc + FStarC_Tactics_V2_Basic.comp_to_doc in + let uu___158 + = + let uu___159 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "range_to_string" + FStarC_Syntax_Embeddings.e_range + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_range + FStarC_TypeChecker_NBETerm.e_string + FStarC_Tactics_V2_Basic.range_to_string + FStarC_Tactics_V2_Basic.range_to_string in + let uu___160 + = + let uu___161 + = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_zero + "term_eq_old" + uu___0 + uu___0 + FStarC_Syntax_Embeddings.e_bool + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_TypeChecker_NBETerm.e_bool + FStarC_Tactics_V2_Basic.term_eq_old + FStarC_Tactics_V2_Basic.term_eq_old in + let uu___162 + = + let uu___163 + = + let uu___164 + = + FStarC_Tactics_Interpreter.e_tactic_thunk + FStarC_Syntax_Embeddings.e_any in + let uu___165 + = + FStarC_Tactics_Interpreter.e_tactic_nbe_thunk + FStarC_TypeChecker_NBETerm.e_any in + FStarC_Tactics_InterpFuns.mk_tac_step_3 + Prims.int_one + "with_compat_pre_core" + FStarC_Syntax_Embeddings.e_any + FStarC_Syntax_Embeddings.e_int + uu___164 + FStarC_Syntax_Embeddings.e_any + FStarC_TypeChecker_NBETerm.e_any + FStarC_TypeChecker_NBETerm.e_int + uu___165 + FStarC_TypeChecker_NBETerm.e_any + (fun + uu___166 + -> + FStarC_Tactics_V2_Basic.with_compat_pre_core) + (fun + uu___166 + -> + FStarC_Tactics_V2_Basic.with_compat_pre_core) in + let uu___164 + = + let uu___165 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "get_vconfig" + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_vconfig + FStarC_TypeChecker_NBETerm.e_unit + FStarC_TypeChecker_NBETerm.e_vconfig + FStarC_Tactics_V2_Basic.get_vconfig + FStarC_Tactics_V2_Basic.get_vconfig in + let uu___166 + = + let uu___167 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "set_vconfig" + FStarC_Syntax_Embeddings.e_vconfig + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_vconfig + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.set_vconfig + FStarC_Tactics_V2_Basic.set_vconfig in + let uu___168 + = + let uu___169 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "t_smt_sync" + FStarC_Syntax_Embeddings.e_vconfig + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_vconfig + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.t_smt_sync + FStarC_Tactics_V2_Basic.t_smt_sync in + let uu___170 + = + let uu___171 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "free_uvars" + uu___0 + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_int) + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_int) + FStarC_Tactics_V2_Basic.free_uvars + FStarC_Tactics_V2_Basic.free_uvars in + let uu___172 + = + let uu___173 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "all_ext_options" + FStarC_Syntax_Embeddings.e_unit + (FStarC_Syntax_Embeddings.e_list + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_string)) + FStarC_TypeChecker_NBETerm.e_unit + (FStarC_TypeChecker_NBETerm.e_list + (FStarC_TypeChecker_NBETerm.e_tuple2 + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_string)) + FStarC_Tactics_V2_Basic.all_ext_options + FStarC_Tactics_V2_Basic.all_ext_options in + let uu___174 + = + let uu___175 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "ext_getv" + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_string + FStarC_Tactics_V2_Basic.ext_getv + FStarC_Tactics_V2_Basic.ext_getv in + let uu___176 + = + let uu___177 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "ext_getns" + FStarC_Syntax_Embeddings.e_string + (FStarC_Syntax_Embeddings.e_list + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_string)) + FStarC_TypeChecker_NBETerm.e_string + (FStarC_TypeChecker_NBETerm.e_list + (FStarC_TypeChecker_NBETerm.e_tuple2 + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_string)) + FStarC_Tactics_V2_Basic.ext_getns + FStarC_Tactics_V2_Basic.ext_getns in + let uu___178 + = + let uu___179 + = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_one + "alloc" + FStarC_Syntax_Embeddings.e_any + FStarC_Syntax_Embeddings.e_any + (FStarC_Tactics_Embedding.e_tref + ()) + FStarC_TypeChecker_NBETerm.e_any + FStarC_TypeChecker_NBETerm.e_any + (FStarC_Tactics_Embedding.e_tref_nbe + ()) + (fun + uu___180 + -> + FStarC_Tactics_V2_Basic.alloc) + (fun + uu___180 + -> + FStarC_Tactics_V2_Basic.alloc) in + let uu___180 + = + let uu___181 + = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_one + "read" + FStarC_Syntax_Embeddings.e_any + (FStarC_Tactics_Embedding.e_tref + ()) + FStarC_Syntax_Embeddings.e_any + FStarC_TypeChecker_NBETerm.e_any + (FStarC_Tactics_Embedding.e_tref_nbe + ()) + FStarC_TypeChecker_NBETerm.e_any + (fun + uu___182 + -> + FStarC_Tactics_V2_Basic.read) + (fun + uu___182 + -> + FStarC_Tactics_V2_Basic.read) in + let uu___182 + = + let uu___183 + = + FStarC_Tactics_InterpFuns.mk_tac_step_3 + Prims.int_one + "write" + FStarC_Syntax_Embeddings.e_any + (FStarC_Tactics_Embedding.e_tref + ()) + FStarC_Syntax_Embeddings.e_any + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_any + (FStarC_Tactics_Embedding.e_tref_nbe + ()) + FStarC_TypeChecker_NBETerm.e_any + FStarC_TypeChecker_NBETerm.e_unit + (fun + uu___184 + -> + FStarC_Tactics_V2_Basic.write) + (fun + uu___184 + -> + FStarC_Tactics_V2_Basic.write) in + let uu___184 + = + let uu___185 + = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_zero + "is_non_informative" + FStarC_Reflection_V2_Embeddings.e_env + uu___0 + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_option + FStarC_Syntax_Embeddings.e_unit) + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_issue)) + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + (FStarC_TypeChecker_NBETerm.e_tuple2 + (FStarC_TypeChecker_NBETerm.e_option + FStarC_TypeChecker_NBETerm.e_unit) + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_issue)) + FStarC_Tactics_V2_Basic.refl_is_non_informative + FStarC_Tactics_V2_Basic.refl_is_non_informative in + let uu___186 + = + let uu___187 + = + FStarC_Tactics_InterpFuns.mk_tac_step_3 + Prims.int_zero + "check_subtyping" + FStarC_Reflection_V2_Embeddings.e_env + uu___0 + uu___0 + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_option + FStarC_Syntax_Embeddings.e_unit) + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_issue)) + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + (FStarC_TypeChecker_NBETerm.e_tuple2 + (FStarC_TypeChecker_NBETerm.e_option + FStarC_TypeChecker_NBETerm.e_unit) + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_issue)) + FStarC_Tactics_V2_Basic.refl_check_subtyping + FStarC_Tactics_V2_Basic.refl_check_subtyping in + let uu___188 + = + let uu___189 + = + FStarC_Tactics_InterpFuns.mk_tac_step_5 + Prims.int_zero + "t_check_equiv" + FStarC_Syntax_Embeddings.e_bool + FStarC_Syntax_Embeddings.e_bool + FStarC_Reflection_V2_Embeddings.e_env + uu___0 + uu___0 + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_option + FStarC_Syntax_Embeddings.e_unit) + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_issue)) + FStarC_TypeChecker_NBETerm.e_bool + FStarC_TypeChecker_NBETerm.e_bool + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + (FStarC_TypeChecker_NBETerm.e_tuple2 + (FStarC_TypeChecker_NBETerm.e_option + FStarC_TypeChecker_NBETerm.e_unit) + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_issue)) + FStarC_Tactics_V2_Basic.t_refl_check_equiv + FStarC_Tactics_V2_Basic.t_refl_check_equiv in + let uu___190 + = + let uu___191 + = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_zero + "core_compute_term_type" + FStarC_Reflection_V2_Embeddings.e_env + uu___0 + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_option + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Tactics_Embedding.e_tot_or_ghost + uu___0)) + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_issue)) + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + (FStarC_TypeChecker_NBETerm.e_tuple2 + (FStarC_TypeChecker_NBETerm.e_option + (FStarC_TypeChecker_NBETerm.e_tuple2 + FStarC_Tactics_Embedding.e_tot_or_ghost_nbe + FStarC_Reflection_V2_NBEEmbeddings.e_attribute)) + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_issue)) + FStarC_Tactics_V2_Basic.refl_core_compute_term_type + FStarC_Tactics_V2_Basic.refl_core_compute_term_type in + let uu___192 + = + let uu___193 + = + FStarC_Tactics_InterpFuns.mk_tac_step_4 + Prims.int_zero + "core_check_term" + FStarC_Reflection_V2_Embeddings.e_env + uu___0 + uu___0 + FStarC_Tactics_Embedding.e_tot_or_ghost + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_option + FStarC_Syntax_Embeddings.e_unit) + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_issue)) + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Tactics_Embedding.e_tot_or_ghost_nbe + (FStarC_TypeChecker_NBETerm.e_tuple2 + (FStarC_TypeChecker_NBETerm.e_option + FStarC_TypeChecker_NBETerm.e_unit) + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_issue)) + FStarC_Tactics_V2_Basic.refl_core_check_term + FStarC_Tactics_V2_Basic.refl_core_check_term in + let uu___194 + = + let uu___195 + = + FStarC_Tactics_InterpFuns.mk_tac_step_3 + Prims.int_zero + "core_check_term_at_type" + FStarC_Reflection_V2_Embeddings.e_env + uu___0 + uu___0 + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_option + FStarC_Tactics_Embedding.e_tot_or_ghost) + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_issue)) + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + (FStarC_TypeChecker_NBETerm.e_tuple2 + (FStarC_TypeChecker_NBETerm.e_option + FStarC_Tactics_Embedding.e_tot_or_ghost_nbe) + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_issue)) + FStarC_Tactics_V2_Basic.refl_core_check_term_at_type + FStarC_Tactics_V2_Basic.refl_core_check_term_at_type in + let uu___196 + = + let uu___197 + = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_zero + "tc_term" + FStarC_Reflection_V2_Embeddings.e_env + uu___0 + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_option + (FStarC_Syntax_Embeddings.e_tuple2 + uu___0 + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Tactics_Embedding.e_tot_or_ghost + uu___0))) + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_issue)) + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + (FStarC_TypeChecker_NBETerm.e_tuple2 + (FStarC_TypeChecker_NBETerm.e_option + (FStarC_TypeChecker_NBETerm.e_tuple2 + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + (FStarC_TypeChecker_NBETerm.e_tuple2 + FStarC_Tactics_Embedding.e_tot_or_ghost_nbe + FStarC_Reflection_V2_NBEEmbeddings.e_attribute))) + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_issue)) + FStarC_Tactics_V2_Basic.refl_tc_term + FStarC_Tactics_V2_Basic.refl_tc_term in + let uu___198 + = + let uu___199 + = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_zero + "universe_of" + FStarC_Reflection_V2_Embeddings.e_env + uu___0 + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_option + FStarC_Reflection_V2_Embeddings.e_universe) + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_issue)) + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + (FStarC_TypeChecker_NBETerm.e_tuple2 + (FStarC_TypeChecker_NBETerm.e_option + FStarC_Reflection_V2_NBEEmbeddings.e_universe) + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_issue)) + FStarC_Tactics_V2_Basic.refl_universe_of + FStarC_Tactics_V2_Basic.refl_universe_of in + let uu___200 + = + let uu___201 + = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_zero + "check_prop_validity" + FStarC_Reflection_V2_Embeddings.e_env + uu___0 + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_option + FStarC_Syntax_Embeddings.e_unit) + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_issue)) + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + (FStarC_TypeChecker_NBETerm.e_tuple2 + (FStarC_TypeChecker_NBETerm.e_option + FStarC_TypeChecker_NBETerm.e_unit) + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_issue)) + FStarC_Tactics_V2_Basic.refl_check_prop_validity + FStarC_Tactics_V2_Basic.refl_check_prop_validity in + let uu___202 + = + let uu___203 + = + FStarC_Tactics_InterpFuns.mk_tac_step_4 + Prims.int_zero + "check_match_complete" + FStarC_Reflection_V2_Embeddings.e_env + uu___0 + uu___0 + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_pattern) + (FStarC_Syntax_Embeddings.e_option + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_pattern) + (FStarC_Syntax_Embeddings.e_list + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_binding)))) + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + (FStarC_TypeChecker_NBETerm.e_list + FStarC_Reflection_V2_NBEEmbeddings.e_pattern) + (FStarC_TypeChecker_NBETerm.e_option + (FStarC_TypeChecker_NBETerm.e_tuple2 + (FStarC_TypeChecker_NBETerm.e_list + FStarC_Reflection_V2_NBEEmbeddings.e_pattern) + (FStarC_TypeChecker_NBETerm.e_list + (FStarC_TypeChecker_NBETerm.e_list + FStarC_Reflection_V2_NBEEmbeddings.e_binding)))) + FStarC_Tactics_V2_Basic.refl_check_match_complete + FStarC_Tactics_V2_Basic.refl_check_match_complete in + let uu___204 + = + let uu___205 + = + let uu___206 + = + e_ret_t + (FStarC_Syntax_Embeddings.e_tuple3 + (FStarC_Syntax_Embeddings.e_list + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Reflection_V2_Embeddings.e_namedv + (solve + uu___0))) + (solve + uu___0) + (solve + uu___0)) in + let uu___207 + = + nbe_e_ret_t + (FStarC_TypeChecker_NBETerm.e_tuple3 + (FStarC_TypeChecker_NBETerm.e_list + (FStarC_TypeChecker_NBETerm.e_tuple2 + FStarC_Reflection_V2_NBEEmbeddings.e_namedv + (solve + FStarC_Reflection_V2_NBEEmbeddings.e_attribute))) + (solve + FStarC_Reflection_V2_NBEEmbeddings.e_attribute) + (solve + FStarC_Reflection_V2_NBEEmbeddings.e_attribute)) in + FStarC_Tactics_InterpFuns.mk_tac_step_3 + Prims.int_zero + "instantiate_implicits" + FStarC_Reflection_V2_Embeddings.e_env + uu___0 + (FStarC_Syntax_Embeddings.e_option + uu___0) + uu___206 + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + (FStarC_TypeChecker_NBETerm.e_option + FStarC_Reflection_V2_NBEEmbeddings.e_attribute) + uu___207 + FStarC_Tactics_V2_Basic.refl_instantiate_implicits + FStarC_Tactics_V2_Basic.refl_instantiate_implicits in + let uu___206 + = + let uu___207 + = + let uu___208 + = + e_ret_t + (FStarC_Syntax_Embeddings.e_list + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Reflection_V2_Embeddings.e_namedv + FStarC_Reflection_V2_Embeddings.e_term)) in + let uu___209 + = + nbe_e_ret_t + (FStarC_TypeChecker_NBETerm.e_list + (FStarC_TypeChecker_NBETerm.e_tuple2 + FStarC_Reflection_V2_NBEEmbeddings.e_namedv + FStarC_Reflection_V2_NBEEmbeddings.e_term)) in + FStarC_Tactics_InterpFuns.mk_tac_step_4 + Prims.int_zero + "try_unify" + FStarC_Reflection_V2_Embeddings.e_env + (FStarC_Syntax_Embeddings.e_list + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Reflection_V2_Embeddings.e_namedv + FStarC_Reflection_V2_Embeddings.e_term)) + uu___0 + uu___0 + uu___208 + FStarC_Reflection_V2_NBEEmbeddings.e_env + (FStarC_TypeChecker_NBETerm.e_list + (FStarC_TypeChecker_NBETerm.e_tuple2 + FStarC_Reflection_V2_NBEEmbeddings.e_namedv + FStarC_Reflection_V2_NBEEmbeddings.e_term)) + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + uu___209 + FStarC_Tactics_V2_Basic.refl_try_unify + FStarC_Tactics_V2_Basic.refl_try_unify in + let uu___208 + = + let uu___209 + = + FStarC_Tactics_InterpFuns.mk_tac_step_3 + Prims.int_zero + "maybe_relate_after_unfolding" + FStarC_Reflection_V2_Embeddings.e_env + uu___0 + uu___0 + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_option + FStarC_Tactics_Embedding.e_unfold_side) + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_issue)) + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + (FStarC_TypeChecker_NBETerm.e_tuple2 + (FStarC_TypeChecker_NBETerm.e_option + FStarC_Tactics_Embedding.e_unfold_side_nbe) + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_issue)) + FStarC_Tactics_V2_Basic.refl_maybe_relate_after_unfolding + FStarC_Tactics_V2_Basic.refl_maybe_relate_after_unfolding in + let uu___210 + = + let uu___211 + = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_zero + "maybe_unfold_head" + FStarC_Reflection_V2_Embeddings.e_env + uu___0 + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_option + uu___0) + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_issue)) + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + (FStarC_TypeChecker_NBETerm.e_tuple2 + (FStarC_TypeChecker_NBETerm.e_option + FStarC_Reflection_V2_NBEEmbeddings.e_attribute) + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_issue)) + FStarC_Tactics_V2_Basic.refl_maybe_unfold_head + FStarC_Tactics_V2_Basic.refl_maybe_unfold_head in + let uu___212 + = + let uu___213 + = + FStarC_Tactics_InterpFuns.mk_tac_step_3 + Prims.int_zero + "norm_well_typed_term" + FStarC_Reflection_V2_Embeddings.e_env + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_norm_step) + uu___0 + uu___0 + FStarC_Reflection_V2_NBEEmbeddings.e_env + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_norm_step) + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Tactics_V2_Basic.refl_norm_well_typed_term + FStarC_Tactics_V2_Basic.refl_norm_well_typed_term in + let uu___214 + = + let uu___215 + = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_zero + "push_open_namespace" + FStarC_Reflection_V2_Embeddings.e_env + FStarC_Syntax_Embeddings.e_string_list + FStarC_Reflection_V2_Embeddings.e_env + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_TypeChecker_NBETerm.e_string_list + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_Tactics_V2_Basic.push_open_namespace + FStarC_Tactics_V2_Basic.push_open_namespace in + let uu___216 + = + let uu___217 + = + FStarC_Tactics_InterpFuns.mk_tac_step_3 + Prims.int_zero + "push_module_abbrev" + FStarC_Reflection_V2_Embeddings.e_env + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_string_list + FStarC_Reflection_V2_Embeddings.e_env + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_string_list + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_Tactics_V2_Basic.push_module_abbrev + FStarC_Tactics_V2_Basic.push_module_abbrev in + let uu___218 + = + let uu___219 + = + FStarC_Tactics_InterpFuns.mk_tac_step_2 + Prims.int_zero + "resolve_name" + FStarC_Reflection_V2_Embeddings.e_env + FStarC_Syntax_Embeddings.e_string_list + (FStarC_Syntax_Embeddings.e_option + (FStarC_Syntax_Embeddings.e_either + FStarC_Reflection_V2_Embeddings.e_bv + (solve + FStarC_Reflection_V2_Embeddings.e_fv))) + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_TypeChecker_NBETerm.e_string_list + (FStarC_TypeChecker_NBETerm.e_option + (FStarC_TypeChecker_NBETerm.e_either + FStarC_Reflection_V2_NBEEmbeddings.e_bv + (solve + FStarC_Reflection_V2_NBEEmbeddings.e_fv))) + FStarC_Tactics_V2_Basic.resolve_name + FStarC_Tactics_V2_Basic.resolve_name in + let uu___220 + = + let uu___221 + = + FStarC_Tactics_InterpFuns.mk_tac_step_1 + Prims.int_zero + "log_issues" + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_issue) + FStarC_Syntax_Embeddings.e_unit + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_issue) + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Tactics_V2_Basic.log_issues + FStarC_Tactics_V2_Basic.log_issues in + let uu___222 + = + let uu___223 + = + let uu___224 + = + FStarC_Tactics_Interpreter.e_tactic_thunk + FStarC_Syntax_Embeddings.e_unit in + let uu___225 + = + FStarC_Tactics_Interpreter.e_tactic_nbe_thunk + FStarC_TypeChecker_NBETerm.e_unit in + FStarC_Tactics_InterpFuns.mk_tac_step_4 + Prims.int_zero + "call_subtac" + FStarC_Reflection_V2_Embeddings.e_env + uu___224 + FStarC_Reflection_V2_Embeddings.e_universe + uu___0 + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_option + uu___0) + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_issue)) + FStarC_Reflection_V2_NBEEmbeddings.e_env + uu___225 + FStarC_Reflection_V2_NBEEmbeddings.e_universe + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + (FStarC_TypeChecker_NBETerm.e_tuple2 + (FStarC_TypeChecker_NBETerm.e_option + FStarC_Reflection_V2_NBEEmbeddings.e_attribute) + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_issue)) + FStarC_Tactics_V2_Basic.call_subtac + FStarC_Tactics_V2_Basic.call_subtac in + let uu___224 + = + let uu___225 + = + FStarC_Tactics_InterpFuns.mk_tac_step_4 + Prims.int_zero + "call_subtac_tm" + FStarC_Reflection_V2_Embeddings.e_env + uu___0 + FStarC_Reflection_V2_Embeddings.e_universe + uu___0 + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_option + uu___0) + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_issue)) + FStarC_Reflection_V2_NBEEmbeddings.e_env + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + FStarC_Reflection_V2_NBEEmbeddings.e_universe + FStarC_Reflection_V2_NBEEmbeddings.e_attribute + (FStarC_TypeChecker_NBETerm.e_tuple2 + (FStarC_TypeChecker_NBETerm.e_option + FStarC_Reflection_V2_NBEEmbeddings.e_attribute) + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_issue)) + FStarC_Tactics_V2_Basic.call_subtac_tm + FStarC_Tactics_V2_Basic.call_subtac_tm in + [uu___225] in + uu___223 + :: + uu___224 in + uu___221 + :: + uu___222 in + uu___219 + :: + uu___220 in + uu___217 + :: + uu___218 in + uu___215 + :: + uu___216 in + uu___213 + :: + uu___214 in + uu___211 + :: + uu___212 in + uu___209 + :: + uu___210 in + uu___207 + :: + uu___208 in + uu___205 + :: + uu___206 in + uu___203 + :: + uu___204 in + uu___201 + :: + uu___202 in + uu___199 + :: + uu___200 in + uu___197 + :: + uu___198 in + uu___195 + :: + uu___196 in + uu___193 + :: + uu___194 in + uu___191 + :: + uu___192 in + uu___189 + :: + uu___190 in + uu___187 + :: + uu___188 in + uu___185 + :: + uu___186 in + uu___183 + :: + uu___184 in + uu___181 + :: + uu___182 in + uu___179 + :: + uu___180 in + uu___177 + :: + uu___178 in + uu___175 + :: + uu___176 in + uu___173 + :: + uu___174 in + uu___171 + :: + uu___172 in + uu___169 + :: + uu___170 in + uu___167 + :: + uu___168 in + uu___165 + :: + uu___166 in + uu___163 + :: + uu___164 in + uu___161 + :: + uu___162 in + uu___159 + :: + uu___160 in + uu___157 + :: + uu___158 in + uu___155 + :: + uu___156 in + uu___153 + :: + uu___154 in + uu___151 + :: + uu___152 in + uu___149 + :: + uu___150 in + uu___147 + :: + uu___148 in + uu___145 + :: + uu___146 in + uu___143 + :: + uu___144 in + uu___141 + :: + uu___142 in + uu___139 + :: + uu___140 in + uu___137 + :: + uu___138 in + uu___135 + :: + uu___136 in + uu___133 + :: + uu___134 in + uu___131 + :: + uu___132 in + uu___129 + :: + uu___130 in + uu___127 + :: + uu___128 in + uu___125 + :: + uu___126 in + uu___123 + :: + uu___124 in + uu___121 + :: + uu___122 in + uu___119 + :: + uu___120 in + uu___117 + :: + uu___118 in + uu___115 + :: + uu___116 in + uu___113 + :: + uu___114 in + uu___111 + :: + uu___112 in + uu___109 + :: + uu___110 in + uu___107 + :: + uu___108 in + uu___105 + :: + uu___106 in + uu___103 + :: + uu___104 in + uu___101 + :: + uu___102 in + uu___99 + :: + uu___100 in + uu___97 + :: + uu___98 in + uu___95 + :: + uu___96 in + uu___93 + :: + uu___94 in + uu___91 + :: + uu___92 in + uu___89 + :: + uu___90 in + uu___87 + :: + uu___88 in + uu___85 + :: + uu___86 in + uu___83 + :: + uu___84 in + uu___81 + :: + uu___82 in + uu___79 + :: + uu___80 in + uu___77 + :: + uu___78 in + uu___75 + :: + uu___76 in + uu___73 + :: + uu___74 in + uu___71 + :: + uu___72 in + uu___69 + :: + uu___70 in + uu___67 + :: + uu___68 in + uu___65 + :: + uu___66 in + uu___63 :: + uu___64 in + uu___61 :: + uu___62 in + uu___59 :: + uu___60 in + uu___57 :: + uu___58 in + uu___55 :: uu___56 in + uu___53 :: uu___54 in + uu___51 :: uu___52 in + uu___49 :: uu___50 in + uu___47 :: uu___48 in + uu___45 :: uu___46 in + uu___43 :: uu___44 in + uu___41 :: uu___42 in + uu___39 :: uu___40 in + uu___37 :: uu___38 in + uu___35 :: uu___36 in + uu___33 :: uu___34 in + uu___31 :: uu___32 in + uu___29 :: uu___30 in + uu___27 :: uu___28 in + uu___25 :: uu___26 in + unseal_step :: uu___24 in + uu___22 :: uu___23 in + uu___20 :: uu___21 in + uu___18 :: uu___19 in + uu___16 :: uu___17 in + uu___14 :: uu___15 in + uu___12 :: uu___13 in + uu___10 :: uu___11 in + uu___8 :: uu___9 in + uu___6 :: uu___7 in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + uu___ :: uu___1 \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Thunk.ml b/ocaml/fstar-lib/generated/FStarC_Thunk.ml new file mode 100644 index 00000000000..f8f89d3cac2 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Thunk.ml @@ -0,0 +1,19 @@ +open Prims +type 'a thunk = + (unit -> 'a, 'a) FStar_Pervasives.either FStarC_Compiler_Effect.ref +type 'a t = 'a thunk +let mk : 'a . (unit -> 'a) -> 'a thunk = + fun f -> FStarC_Compiler_Effect.alloc (FStar_Pervasives.Inl f) +let mkv : 'a . 'a -> 'a thunk = + fun v -> FStarC_Compiler_Effect.alloc (FStar_Pervasives.Inr v) +let force : 'a . 'a thunk -> 'a = + fun t1 -> + let uu___ = FStarC_Compiler_Effect.op_Bang t1 in + match uu___ with + | FStar_Pervasives.Inr a1 -> a1 + | FStar_Pervasives.Inl f -> + let a1 = f () in + (FStarC_Compiler_Effect.op_Colon_Equals t1 (FStar_Pervasives.Inr a1); + a1) +let map : 'a 'b . ('a -> 'b) -> 'a thunk -> 'b thunk = + fun f -> fun t1 -> mk (fun uu___ -> let uu___1 = force t1 in f uu___1) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_ToSyntax_Interleave.ml b/ocaml/fstar-lib/generated/FStarC_ToSyntax_Interleave.ml new file mode 100644 index 00000000000..7c3b5c7eb9c --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_ToSyntax_Interleave.ml @@ -0,0 +1,782 @@ +open Prims +let (id_eq_lid : FStarC_Ident.ident -> FStarC_Ident.lident -> Prims.bool) = + fun i -> + fun l -> + let uu___ = FStarC_Ident.string_of_id i in + let uu___1 = + let uu___2 = FStarC_Ident.ident_of_lid l in + FStarC_Ident.string_of_id uu___2 in + uu___ = uu___1 +let (is_val : FStarC_Ident.ident -> FStarC_Parser_AST.decl -> Prims.bool) = + fun x -> + fun d -> + match d.FStarC_Parser_AST.d with + | FStarC_Parser_AST.Val (y, uu___) -> + let uu___1 = FStarC_Ident.string_of_id x in + let uu___2 = FStarC_Ident.string_of_id y in uu___1 = uu___2 + | uu___ -> false +let (is_type : FStarC_Ident.ident -> FStarC_Parser_AST.decl -> Prims.bool) = + fun x -> + fun d -> + match d.FStarC_Parser_AST.d with + | FStarC_Parser_AST.Tycon (uu___, uu___1, tys) -> + FStarC_Compiler_Util.for_some + (fun t -> + let uu___2 = FStarC_Parser_AST.id_of_tycon t in + let uu___3 = FStarC_Ident.string_of_id x in uu___2 = uu___3) + tys + | uu___ -> false +let (definition_lids : + FStarC_Parser_AST.decl -> FStarC_Ident.lident Prims.list) = + fun d -> + match d.FStarC_Parser_AST.d with + | FStarC_Parser_AST.TopLevelLet (uu___, defs) -> + FStarC_Parser_AST.lids_of_let defs + | FStarC_Parser_AST.Tycon (uu___, uu___1, tys) -> + FStarC_Compiler_List.collect + (fun uu___2 -> + match uu___2 with + | FStarC_Parser_AST.TyconAbbrev (id, uu___3, uu___4, uu___5) -> + let uu___6 = FStarC_Ident.lid_of_ids [id] in [uu___6] + | FStarC_Parser_AST.TyconRecord + (id, uu___3, uu___4, uu___5, uu___6) -> + let uu___7 = FStarC_Ident.lid_of_ids [id] in [uu___7] + | FStarC_Parser_AST.TyconVariant (id, uu___3, uu___4, uu___5) -> + let uu___6 = FStarC_Ident.lid_of_ids [id] in [uu___6] + | uu___3 -> []) tys + | FStarC_Parser_AST.Splice (uu___, ids, uu___1) -> + FStarC_Compiler_List.map (fun id -> FStarC_Ident.lid_of_ids [id]) ids + | FStarC_Parser_AST.DeclToBeDesugared + { FStarC_Parser_AST.lang_name = uu___; + FStarC_Parser_AST.blob = uu___1; FStarC_Parser_AST.idents = ids; + FStarC_Parser_AST.to_string = uu___2; + FStarC_Parser_AST.eq = uu___3; + FStarC_Parser_AST.dep_scan = uu___4;_} + -> + FStarC_Compiler_List.map (fun id -> FStarC_Ident.lid_of_ids [id]) ids + | FStarC_Parser_AST.DeclSyntaxExtension + (extension_name, code, uu___, range) -> + let ext_parser = + FStarC_Parser_AST_Util.lookup_extension_parser extension_name in + (match ext_parser with + | FStar_Pervasives_Native.None -> + let uu___1 = + FStarC_Compiler_Util.format1 "Unknown syntax extension %s" + extension_name in + FStarC_Errors.raise_error FStarC_Parser_AST.hasRange_decl d + FStarC_Errors_Codes.Fatal_SyntaxError () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) + | FStar_Pervasives_Native.Some parser -> + let uu___1 = + parser.FStarC_Parser_AST_Util.parse_decl_name code range in + (match uu___1 with + | FStar_Pervasives.Inl error -> + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + error.FStarC_Parser_AST_Util.range + FStarC_Errors_Codes.Fatal_SyntaxError () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic error.FStarC_Parser_AST_Util.message) + | FStar_Pervasives.Inr id -> + let uu___2 = FStarC_Ident.lid_of_ids [id] in [uu___2])) + | uu___ -> [] +let (is_definition_of : + FStarC_Ident.ident -> FStarC_Parser_AST.decl -> Prims.bool) = + fun x -> + fun d -> + let uu___ = definition_lids d in + FStarC_Compiler_Util.for_some (id_eq_lid x) uu___ +let rec (prefix_with_iface_decls : + FStarC_Parser_AST.decl Prims.list -> + FStarC_Parser_AST.decl -> + (FStarC_Parser_AST.decl Prims.list * FStarC_Parser_AST.decl Prims.list)) + = + fun iface -> + fun impl -> + let qualify_karamel_private impl1 = + let karamel_private = + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.Const + (FStarC_Const.Const_string + ("KrmlPrivate", (impl1.FStarC_Parser_AST.drange)))) + impl1.FStarC_Parser_AST.drange FStarC_Parser_AST.Expr in + { + FStarC_Parser_AST.d = (impl1.FStarC_Parser_AST.d); + FStarC_Parser_AST.drange = (impl1.FStarC_Parser_AST.drange); + FStarC_Parser_AST.quals = (impl1.FStarC_Parser_AST.quals); + FStarC_Parser_AST.attrs = (karamel_private :: + (impl1.FStarC_Parser_AST.attrs)); + FStarC_Parser_AST.interleaved = + (impl1.FStarC_Parser_AST.interleaved) + } in + match iface with + | [] -> + let uu___ = let uu___1 = qualify_karamel_private impl in [uu___1] in + ([], uu___) + | iface_hd::iface_tl -> + (match iface_hd.FStarC_Parser_AST.d with + | FStarC_Parser_AST.Tycon (uu___, uu___1, tys) when + FStarC_Compiler_Util.for_some + (fun uu___2 -> + match uu___2 with + | FStarC_Parser_AST.TyconAbstract uu___3 -> true + | uu___3 -> false) tys + -> + let uu___2 = + let uu___3 = + FStarC_Errors_Msg.text + "Interface contains an abstract 'type' declaration; use 'val' instead." in + [uu___3] in + FStarC_Errors.raise_error FStarC_Parser_AST.hasRange_decl impl + FStarC_Errors_Codes.Fatal_AbstractTypeDeclarationInInterface + () (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___2) + | FStarC_Parser_AST.Splice (uu___, x::[], uu___1) -> + let def_ids = definition_lids impl in + let defines_x = + FStarC_Compiler_Util.for_some (id_eq_lid x) def_ids in + if Prims.op_Negation defines_x + then + ((let uu___3 = + FStarC_Compiler_Util.for_some + (fun y -> + let uu___4 = + let uu___5 = FStarC_Ident.ident_of_lid y in + is_val uu___5 in + FStarC_Compiler_Util.for_some uu___4 iface_tl) + def_ids in + if uu___3 + then + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Errors_Msg.text + "Expected the definition of" in + let uu___7 = + let uu___8 = + FStarC_Class_PP.pp FStarC_Ident.pretty_ident x in + let uu___9 = + let uu___10 = + FStarC_Errors_Msg.text "to precede" in + let uu___11 = + FStarC_Class_PP.pp + (FStarC_Class_PP.pp_list + FStarC_Ident.pretty_lident) def_ids in + FStarC_Pprint.op_Hat_Slash_Hat uu___10 uu___11 in + FStarC_Pprint.op_Hat_Slash_Hat uu___8 uu___9 in + FStarC_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in + [uu___5] in + FStarC_Errors.raise_error + FStarC_Parser_AST.hasRange_decl impl + FStarC_Errors_Codes.Fatal_WrongDefinitionOrder () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___4) + else ()); + (let uu___3 = + let uu___4 = qualify_karamel_private impl in [uu___4] in + (iface, uu___3))) + else + (let mutually_defined_with_x = + FStarC_Compiler_List.filter + (fun y -> + let uu___3 = id_eq_lid x y in + Prims.op_Negation uu___3) def_ids in + let rec aux mutuals iface1 = + match (mutuals, iface1) with + | ([], uu___3) -> ([], iface1) + | (uu___3::uu___4, []) -> ([], []) + | (y::ys, iface_hd1::iface_tl1) when + let uu___3 = FStarC_Ident.ident_of_lid y in + is_val uu___3 iface_hd1 -> + let uu___3 = aux ys iface_tl1 in + (match uu___3 with + | (val_ys, iface2) -> + ((iface_hd1 :: val_ys), iface2)) + | (y::ys, iface_hd1::iface_tl1) when + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Ident.ident_of_lid y in + is_val uu___5 in + FStarC_Compiler_List.tryFind uu___4 iface_tl1 in + FStarC_Compiler_Option.isSome uu___3 -> + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Class_Show.show + FStarC_Parser_AST.showable_decl iface_hd1 in + let uu___7 = FStarC_Ident.string_of_lid y in + FStarC_Compiler_Util.format2 + "%s is out of order with the definition of %s" + uu___6 uu___7 in + FStarC_Errors_Msg.text uu___5 in + [uu___4] in + FStarC_Errors.raise_error + FStarC_Parser_AST.hasRange_decl iface_hd1 + FStarC_Errors_Codes.Fatal_WrongDefinitionOrder () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___3) + | (y::ys, iface_hd1::iface_tl1) -> aux ys iface1 in + let uu___3 = aux mutually_defined_with_x iface_tl in + match uu___3 with + | (take_iface, rest_iface) -> + (rest_iface, + (FStarC_Compiler_List.op_At (iface_hd :: take_iface) + [impl]))) + | FStarC_Parser_AST.Val (x, uu___) -> + let def_ids = definition_lids impl in + let defines_x = + FStarC_Compiler_Util.for_some (id_eq_lid x) def_ids in + if Prims.op_Negation defines_x + then + ((let uu___2 = + FStarC_Compiler_Util.for_some + (fun y -> + let uu___3 = + let uu___4 = FStarC_Ident.ident_of_lid y in + is_val uu___4 in + FStarC_Compiler_Util.for_some uu___3 iface_tl) + def_ids in + if uu___2 + then + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Errors_Msg.text + "Expected the definition of" in + let uu___6 = + let uu___7 = + FStarC_Class_PP.pp FStarC_Ident.pretty_ident x in + let uu___8 = + let uu___9 = FStarC_Errors_Msg.text "to precede" in + let uu___10 = + FStarC_Class_PP.pp + (FStarC_Class_PP.pp_list + FStarC_Ident.pretty_lident) def_ids in + FStarC_Pprint.op_Hat_Slash_Hat uu___9 uu___10 in + FStarC_Pprint.op_Hat_Slash_Hat uu___7 uu___8 in + FStarC_Pprint.op_Hat_Slash_Hat uu___5 uu___6 in + [uu___4] in + FStarC_Errors.raise_error + FStarC_Parser_AST.hasRange_decl impl + FStarC_Errors_Codes.Fatal_WrongDefinitionOrder () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___3) + else ()); + (let uu___2 = + let uu___3 = qualify_karamel_private impl in [uu___3] in + (iface, uu___2))) + else + (let mutually_defined_with_x = + FStarC_Compiler_List.filter + (fun y -> + let uu___2 = id_eq_lid x y in + Prims.op_Negation uu___2) def_ids in + let rec aux mutuals iface1 = + match (mutuals, iface1) with + | ([], uu___2) -> ([], iface1) + | (uu___2::uu___3, []) -> ([], []) + | (y::ys, iface_hd1::iface_tl1) when + let uu___2 = FStarC_Ident.ident_of_lid y in + is_val uu___2 iface_hd1 -> + let uu___2 = aux ys iface_tl1 in + (match uu___2 with + | (val_ys, iface2) -> + ((iface_hd1 :: val_ys), iface2)) + | (y::ys, iface_hd1::iface_tl1) when + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Ident.ident_of_lid y in + is_val uu___4 in + FStarC_Compiler_List.tryFind uu___3 iface_tl1 in + FStarC_Compiler_Option.isSome uu___2 -> + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Class_Show.show + FStarC_Parser_AST.showable_decl iface_hd1 in + let uu___6 = FStarC_Ident.string_of_lid y in + FStarC_Compiler_Util.format2 + "%s is out of order with the definition of %s" + uu___5 uu___6 in + FStarC_Errors_Msg.text uu___4 in + [uu___3] in + FStarC_Errors.raise_error + FStarC_Parser_AST.hasRange_decl iface_hd1 + FStarC_Errors_Codes.Fatal_WrongDefinitionOrder () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___2) + | (y::ys, iface_hd1::iface_tl1) -> aux ys iface1 in + let uu___2 = aux mutually_defined_with_x iface_tl in + match uu___2 with + | (take_iface, rest_iface) -> + (rest_iface, + (FStarC_Compiler_List.op_At (iface_hd :: take_iface) + [impl]))) + | FStarC_Parser_AST.Pragma uu___ -> + prefix_with_iface_decls iface_tl impl + | uu___ -> + let uu___1 = prefix_with_iface_decls iface_tl impl in + (match uu___1 with + | (iface1, ds) -> (iface1, (iface_hd :: ds)))) +let (check_initial_interface : + FStarC_Parser_AST.decl Prims.list -> FStarC_Parser_AST.decl Prims.list) = + fun iface -> + let rec aux iface1 = + match iface1 with + | [] -> () + | hd::tl -> + (match hd.FStarC_Parser_AST.d with + | FStarC_Parser_AST.Tycon (uu___, uu___1, tys) when + FStarC_Compiler_Util.for_some + (fun uu___2 -> + match uu___2 with + | FStarC_Parser_AST.TyconAbstract uu___3 -> true + | uu___3 -> false) tys + -> + FStarC_Errors.raise_error FStarC_Parser_AST.hasRange_decl hd + FStarC_Errors_Codes.Fatal_AbstractTypeDeclarationInInterface + () (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Interface contains an abstract 'type' declaration; use 'val' instead") + | FStarC_Parser_AST.Val (x, t) -> + let uu___ = + FStarC_Compiler_Util.for_some (is_definition_of x) tl in + if uu___ + then + let uu___1 = + let uu___2 = FStarC_Ident.string_of_id x in + let uu___3 = FStarC_Ident.string_of_id x in + FStarC_Compiler_Util.format2 + "'val %s' and 'let %s' cannot both be provided in an interface" + uu___2 uu___3 in + FStarC_Errors.raise_error FStarC_Parser_AST.hasRange_decl hd + FStarC_Errors_Codes.Fatal_BothValAndLetInInterface () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) + else + if + FStarC_Compiler_List.contains FStarC_Parser_AST.Assumption + hd.FStarC_Parser_AST.quals + then + FStarC_Errors.raise_error FStarC_Parser_AST.hasRange_decl + hd FStarC_Errors_Codes.Fatal_AssumeValInInterface () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Interfaces cannot use `assume val x : t`; just write `val x : t` instead") + else () + | uu___ -> ()) in + aux iface; + FStarC_Compiler_List.filter + (fun d -> + match d.FStarC_Parser_AST.d with + | FStarC_Parser_AST.TopLevelModule uu___1 -> false + | uu___1 -> true) iface +let (ml_mode_prefix_with_iface_decls : + FStarC_Parser_AST.decl Prims.list -> + FStarC_Parser_AST.decl -> + (FStarC_Parser_AST.decl Prims.list * FStarC_Parser_AST.decl Prims.list)) + = + fun iface -> + fun impl -> + match impl.FStarC_Parser_AST.d with + | FStarC_Parser_AST.TopLevelModule uu___ -> + let uu___1 = + FStarC_Compiler_List.span + (fun d -> + match d.FStarC_Parser_AST.d with + | FStarC_Parser_AST.Open uu___2 -> true + | FStarC_Parser_AST.ModuleAbbrev uu___2 -> true + | uu___2 -> false) iface in + (match uu___1 with + | (iface_prefix_opens, iface1) -> + let iface2 = + FStarC_Compiler_List.filter + (fun d -> + match d.FStarC_Parser_AST.d with + | FStarC_Parser_AST.Val uu___2 -> true + | FStarC_Parser_AST.Tycon uu___2 -> true + | uu___2 -> false) iface1 in + (iface2, + (FStarC_Compiler_List.op_At [impl] iface_prefix_opens))) + | FStarC_Parser_AST.Open uu___ -> + let uu___1 = + FStarC_Compiler_List.span + (fun d -> + match d.FStarC_Parser_AST.d with + | FStarC_Parser_AST.Open uu___2 -> true + | FStarC_Parser_AST.ModuleAbbrev uu___2 -> true + | uu___2 -> false) iface in + (match uu___1 with + | (iface_prefix_opens, iface1) -> + let iface2 = + FStarC_Compiler_List.filter + (fun d -> + match d.FStarC_Parser_AST.d with + | FStarC_Parser_AST.Val uu___2 -> true + | FStarC_Parser_AST.Tycon uu___2 -> true + | uu___2 -> false) iface1 in + (iface2, + (FStarC_Compiler_List.op_At [impl] iface_prefix_opens))) + | FStarC_Parser_AST.Friend uu___ -> + let uu___1 = + FStarC_Compiler_List.span + (fun d -> + match d.FStarC_Parser_AST.d with + | FStarC_Parser_AST.Open uu___2 -> true + | FStarC_Parser_AST.ModuleAbbrev uu___2 -> true + | uu___2 -> false) iface in + (match uu___1 with + | (iface_prefix_opens, iface1) -> + let iface2 = + FStarC_Compiler_List.filter + (fun d -> + match d.FStarC_Parser_AST.d with + | FStarC_Parser_AST.Val uu___2 -> true + | FStarC_Parser_AST.Tycon uu___2 -> true + | uu___2 -> false) iface1 in + (iface2, + (FStarC_Compiler_List.op_At [impl] iface_prefix_opens))) + | FStarC_Parser_AST.Include uu___ -> + let uu___1 = + FStarC_Compiler_List.span + (fun d -> + match d.FStarC_Parser_AST.d with + | FStarC_Parser_AST.Open uu___2 -> true + | FStarC_Parser_AST.ModuleAbbrev uu___2 -> true + | uu___2 -> false) iface in + (match uu___1 with + | (iface_prefix_opens, iface1) -> + let iface2 = + FStarC_Compiler_List.filter + (fun d -> + match d.FStarC_Parser_AST.d with + | FStarC_Parser_AST.Val uu___2 -> true + | FStarC_Parser_AST.Tycon uu___2 -> true + | uu___2 -> false) iface1 in + (iface2, + (FStarC_Compiler_List.op_At [impl] iface_prefix_opens))) + | FStarC_Parser_AST.ModuleAbbrev uu___ -> + let uu___1 = + FStarC_Compiler_List.span + (fun d -> + match d.FStarC_Parser_AST.d with + | FStarC_Parser_AST.Open uu___2 -> true + | FStarC_Parser_AST.ModuleAbbrev uu___2 -> true + | uu___2 -> false) iface in + (match uu___1 with + | (iface_prefix_opens, iface1) -> + let iface2 = + FStarC_Compiler_List.filter + (fun d -> + match d.FStarC_Parser_AST.d with + | FStarC_Parser_AST.Val uu___2 -> true + | FStarC_Parser_AST.Tycon uu___2 -> true + | uu___2 -> false) iface1 in + (iface2, + (FStarC_Compiler_List.op_At [impl] iface_prefix_opens))) + | uu___ -> + let uu___1 = + FStarC_Compiler_List.span + (fun d -> + match d.FStarC_Parser_AST.d with + | FStarC_Parser_AST.Tycon uu___2 -> true + | uu___2 -> false) iface in + (match uu___1 with + | (iface_prefix_tycons, iface1) -> + let maybe_get_iface_vals lids iface2 = + FStarC_Compiler_List.partition + (fun d -> + FStarC_Compiler_Util.for_some + (fun x -> + let uu___2 = FStarC_Ident.ident_of_lid x in + is_val uu___2 d) lids) iface2 in + (match impl.FStarC_Parser_AST.d with + | FStarC_Parser_AST.TopLevelLet uu___2 -> + let xs = definition_lids impl in + let uu___3 = maybe_get_iface_vals xs iface1 in + (match uu___3 with + | (val_xs, rest_iface) -> + (rest_iface, + (FStarC_Compiler_List.op_At iface_prefix_tycons + (FStarC_Compiler_List.op_At val_xs [impl])))) + | FStarC_Parser_AST.Tycon uu___2 -> + let xs = definition_lids impl in + let uu___3 = maybe_get_iface_vals xs iface1 in + (match uu___3 with + | (val_xs, rest_iface) -> + (rest_iface, + (FStarC_Compiler_List.op_At iface_prefix_tycons + (FStarC_Compiler_List.op_At val_xs [impl])))) + | uu___2 -> + (iface1, + (FStarC_Compiler_List.op_At iface_prefix_tycons [impl])))) +let ml_mode_check_initial_interface : + 'uuuuu . + 'uuuuu -> + FStarC_Parser_AST.decl Prims.list -> FStarC_Parser_AST.decl Prims.list + = + fun mname -> + fun iface -> + FStarC_Compiler_List.filter + (fun d -> + match d.FStarC_Parser_AST.d with + | FStarC_Parser_AST.Tycon (uu___, uu___1, tys) when + FStarC_Compiler_Util.for_some + (fun uu___2 -> + match uu___2 with + | FStarC_Parser_AST.TyconAbstract uu___3 -> true + | uu___3 -> false) tys + -> + FStarC_Errors.raise_error FStarC_Parser_AST.hasRange_decl d + FStarC_Errors_Codes.Fatal_AbstractTypeDeclarationInInterface + () (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Interface contains an abstract 'type' declaration; use 'val' instead") + | FStarC_Parser_AST.Tycon uu___ -> true + | FStarC_Parser_AST.Val uu___ -> true + | FStarC_Parser_AST.Open uu___ -> true + | FStarC_Parser_AST.ModuleAbbrev uu___ -> true + | uu___ -> false) iface +let (ulib_modules : Prims.string Prims.list) = + ["FStar.Calc"; + "FStar.TSet"; + "FStar.Seq.Base"; + "FStar.Seq.Properties"; + "FStar.UInt"; + "FStar.UInt8"; + "FStar.UInt16"; + "FStar.UInt32"; + "FStar.UInt64"; + "FStar.Int"; + "FStar.Int8"; + "FStar.Int16"; + "FStar.Int32"; + "FStar.Int64"] +let (apply_ml_mode_optimizations : FStarC_Ident.lident -> Prims.bool) = + fun mname -> + ((FStarC_Options.ml_ish ()) && + (let uu___ = + let uu___1 = FStarC_Ident.string_of_lid mname in + let uu___2 = FStarC_Parser_Dep.core_modules () in + FStarC_Compiler_List.contains uu___1 uu___2 in + Prims.op_Negation uu___)) + && + (let uu___ = + let uu___1 = FStarC_Ident.string_of_lid mname in + FStarC_Compiler_List.contains uu___1 ulib_modules in + Prims.op_Negation uu___) +let (prefix_one_decl : + FStarC_Ident.lident -> + FStarC_Parser_AST.decl Prims.list -> + FStarC_Parser_AST.decl -> + (FStarC_Parser_AST.decl Prims.list * FStarC_Parser_AST.decl + Prims.list)) + = + fun mname -> + fun iface -> + fun impl -> + match impl.FStarC_Parser_AST.d with + | FStarC_Parser_AST.TopLevelModule uu___ -> (iface, [impl]) + | uu___ -> + let uu___1 = apply_ml_mode_optimizations mname in + if uu___1 + then ml_mode_prefix_with_iface_decls iface impl + else prefix_with_iface_decls iface impl +let (initialize_interface : + FStarC_Ident.lident -> + FStarC_Parser_AST.decl Prims.list -> unit FStarC_Syntax_DsEnv.withenv) + = + fun mname -> + fun l -> + fun env -> + let decls = + let uu___ = apply_ml_mode_optimizations mname in + if uu___ + then ml_mode_check_initial_interface mname l + else check_initial_interface l in + let uu___ = FStarC_Syntax_DsEnv.iface_decls env mname in + match uu___ with + | FStar_Pervasives_Native.Some uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Ident.showable_lident mname in + FStarC_Compiler_Util.format1 + "Interface %s has already been processed" uu___3 in + FStarC_Errors.raise_error FStarC_Ident.hasrange_lident mname + FStarC_Errors_Codes.Fatal_InterfaceAlreadyProcessed () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2) + | FStar_Pervasives_Native.None -> + let uu___1 = FStarC_Syntax_DsEnv.set_iface_decls env mname decls in + ((), uu___1) +let (fixup_interleaved_decls : + FStarC_Parser_AST.decl Prims.list -> FStarC_Parser_AST.decl Prims.list) = + fun iface -> + let fix1 d = + let d1 = + { + FStarC_Parser_AST.d = (d.FStarC_Parser_AST.d); + FStarC_Parser_AST.drange = (d.FStarC_Parser_AST.drange); + FStarC_Parser_AST.quals = (d.FStarC_Parser_AST.quals); + FStarC_Parser_AST.attrs = (d.FStarC_Parser_AST.attrs); + FStarC_Parser_AST.interleaved = true + } in + d1 in + FStarC_Compiler_List.map fix1 iface +let (prefix_with_interface_decls : + FStarC_Ident.lident -> + FStarC_Parser_AST.decl -> + FStarC_Parser_AST.decl Prims.list FStarC_Syntax_DsEnv.withenv) + = + fun mname -> + fun impl -> + fun env -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Syntax_DsEnv.current_module env in + FStarC_Syntax_DsEnv.iface_decls env uu___2 in + match uu___1 with + | FStar_Pervasives_Native.None -> ([impl], env) + | FStar_Pervasives_Native.Some iface -> + let iface1 = fixup_interleaved_decls iface in + let uu___2 = prefix_one_decl mname iface1 impl in + (match uu___2 with + | (iface2, impl1) -> + let env1 = + let uu___3 = FStarC_Syntax_DsEnv.current_module env in + FStarC_Syntax_DsEnv.set_iface_decls env uu___3 iface2 in + (impl1, env1)) in + match uu___ with + | (decls, env1) -> + ((let uu___2 = + let uu___3 = FStarC_Ident.string_of_lid mname in + FStarC_Options.dump_module uu___3 in + if uu___2 + then + let uu___3 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Parser_AST.showable_decl) decls in + FStarC_Compiler_Util.print1 "Interleaved decls:\n%s\n" uu___3 + else ()); + (decls, env1)) +let (interleave_module : + FStarC_Parser_AST.modul -> + Prims.bool -> FStarC_Parser_AST.modul FStarC_Syntax_DsEnv.withenv) + = + fun a -> + fun expect_complete_modul -> + fun env -> + match a with + | FStarC_Parser_AST.Interface uu___ -> (a, env) + | FStarC_Parser_AST.Module (l, impls) -> + let uu___ = FStarC_Syntax_DsEnv.iface_decls env l in + (match uu___ with + | FStar_Pervasives_Native.None -> (a, env) + | FStar_Pervasives_Native.Some iface -> + let iface1 = fixup_interleaved_decls iface in + let uu___1 = + FStarC_Compiler_List.fold_left + (fun uu___2 -> + fun impl -> + match uu___2 with + | (iface2, impls1) -> + let uu___3 = prefix_one_decl l iface2 impl in + (match uu___3 with + | (iface3, impls') -> + (iface3, + (FStarC_Compiler_List.op_At impls1 + impls')))) (iface1, []) impls in + (match uu___1 with + | (iface2, impls1) -> + let uu___2 = + let uu___3 = + FStarC_Compiler_Util.prefix_until + (fun uu___4 -> + match uu___4 with + | { + FStarC_Parser_AST.d = + FStarC_Parser_AST.Val uu___5; + FStarC_Parser_AST.drange = uu___6; + FStarC_Parser_AST.quals = uu___7; + FStarC_Parser_AST.attrs = uu___8; + FStarC_Parser_AST.interleaved = uu___9;_} + -> true + | { + FStarC_Parser_AST.d = + FStarC_Parser_AST.Splice uu___5; + FStarC_Parser_AST.drange = uu___6; + FStarC_Parser_AST.quals = uu___7; + FStarC_Parser_AST.attrs = uu___8; + FStarC_Parser_AST.interleaved = uu___9;_} + -> true + | uu___5 -> false) iface2 in + match uu___3 with + | FStar_Pervasives_Native.None -> (iface2, []) + | FStar_Pervasives_Native.Some (lets, one_val, rest) + -> (lets, (one_val :: rest)) in + (match uu___2 with + | (iface_lets, remaining_iface_vals) -> + let impls2 = + FStarC_Compiler_List.op_At impls1 iface_lets in + let env1 = + let uu___3 = FStarC_Options.interactive () in + if uu___3 + then + FStarC_Syntax_DsEnv.set_iface_decls env l + remaining_iface_vals + else env in + let a1 = FStarC_Parser_AST.Module (l, impls2) in + (match remaining_iface_vals with + | uu___3::uu___4 when expect_complete_modul -> + ((let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident l in + FStarC_Compiler_Util.format1 + "Some interface elements were not implemented by module %s:" + uu___10 in + FStarC_Errors_Msg.text uu___9 in + let uu___9 = + let uu___10 = + FStarC_Compiler_List.map + (fun d -> + let uu___11 = + FStarC_Class_Show.show + FStarC_Parser_AST.showable_decl + d in + FStarC_Pprint.doc_of_string + uu___11) + remaining_iface_vals in + FStarC_Errors_Msg.sublist + FStarC_Pprint.empty uu___10 in + FStarC_Pprint.op_Hat_Hat uu___8 uu___9 in + [uu___7] in + FStarC_Errors.log_issue + FStarC_Ident.hasrange_lident l + FStarC_Errors_Codes.Fatal_InterfaceNotImplementedByModule + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___6)); + (a1, env1)) + | uu___3 -> + ((let uu___5 = + let uu___6 = FStarC_Ident.string_of_lid l in + FStarC_Options.dump_module uu___6 in + if uu___5 + then + let uu___6 = + FStarC_Parser_AST.modul_to_string a1 in + FStarC_Compiler_Util.print1 + "Interleaved module is:\n%s\n" uu___6 + else ()); + (a1, env1)))))) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_ToSyntax_ToSyntax.ml b/ocaml/fstar-lib/generated/FStarC_ToSyntax_ToSyntax.ml new file mode 100644 index 00000000000..c7536450885 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_ToSyntax_ToSyntax.ml @@ -0,0 +1,10947 @@ +open Prims +type extension_tosyntax_decl_t = + FStarC_Syntax_DsEnv.env -> + FStarC_Dyn.dyn -> + FStarC_Ident.lident Prims.list -> + FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.sigelt' Prims.list +let (extension_tosyntax_table : + extension_tosyntax_decl_t FStarC_Compiler_Util.smap) = + FStarC_Compiler_Util.smap_create (Prims.of_int (20)) +let (register_extension_tosyntax : + Prims.string -> extension_tosyntax_decl_t -> unit) = + fun lang_name -> + fun cb -> + FStarC_Compiler_Util.smap_add extension_tosyntax_table lang_name cb +let (lookup_extension_tosyntax : + Prims.string -> extension_tosyntax_decl_t FStar_Pervasives_Native.option) = + fun lang_name -> + FStarC_Compiler_Util.smap_try_find extension_tosyntax_table lang_name +let (dbg_attrs : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "attrs" +let (dbg_ToSyntax : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "ToSyntax" +type antiquotations_temp = + (FStarC_Syntax_Syntax.bv * FStarC_Syntax_Syntax.term) Prims.list +let (tun_r : FStarC_Compiler_Range_Type.range -> FStarC_Syntax_Syntax.term) = + fun r -> + { + FStarC_Syntax_Syntax.n = + (FStarC_Syntax_Syntax.tun.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = r; + FStarC_Syntax_Syntax.vars = + (FStarC_Syntax_Syntax.tun.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (FStarC_Syntax_Syntax.tun.FStarC_Syntax_Syntax.hash_code) + } +type annotated_pat = + (FStarC_Syntax_Syntax.pat * (FStarC_Syntax_Syntax.bv * + FStarC_Syntax_Syntax.typ * FStarC_Syntax_Syntax.term Prims.list) + Prims.list) +let (mk_thunk : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun e -> + let b = + let uu___ = + FStarC_Syntax_Syntax.new_bv FStar_Pervasives_Native.None + FStarC_Syntax_Syntax.tun in + FStarC_Syntax_Syntax.mk_binder uu___ in + FStarC_Syntax_Util.abs [b] e FStar_Pervasives_Native.None +let (mk_binder_with_attrs : + FStarC_Syntax_Syntax.bv -> + FStarC_Syntax_Syntax.bqual -> + FStarC_Syntax_Syntax.attribute Prims.list -> + FStarC_Syntax_Syntax.binder) + = + fun bv -> + fun aq -> + fun attrs -> + let uu___ = FStarC_Syntax_Util.parse_positivity_attributes attrs in + match uu___ with + | (pqual, attrs1) -> + FStarC_Syntax_Syntax.mk_binder_with_attrs bv aq pqual attrs1 +let (qualify_field_names : + FStarC_Ident.lident -> + FStarC_Ident.lident Prims.list -> FStarC_Ident.lident Prims.list) + = + fun record_or_dc_lid -> + fun field_names -> + let qualify_to_record l = + let ns = FStarC_Ident.ns_of_lid record_or_dc_lid in + let uu___ = FStarC_Ident.ident_of_lid l in + FStarC_Ident.lid_of_ns_and_id ns uu___ in + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun l -> + match uu___1 with + | (ns_opt, out) -> + let uu___2 = FStarC_Ident.nsstr l in + (match uu___2 with + | "" -> + if FStarC_Compiler_Option.isSome ns_opt + then + let uu___3 = + let uu___4 = qualify_to_record l in uu___4 :: out in + (ns_opt, uu___3) + else (ns_opt, (l :: out)) + | ns -> + (match ns_opt with + | FStar_Pervasives_Native.Some ns' -> + if ns <> ns' + then + let uu___3 = + let uu___4 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident l in + FStarC_Compiler_Util.format2 + "Field %s of record type was expected to be scoped to namespace %s" + uu___4 ns' in + FStarC_Errors.raise_error + FStarC_Ident.hasrange_lident l + FStarC_Errors_Codes.Fatal_MissingFieldInRecord + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___3) + else + (let uu___4 = + let uu___5 = qualify_to_record l in uu___5 + :: out in + (ns_opt, uu___4)) + | FStar_Pervasives_Native.None -> + let uu___3 = + let uu___4 = qualify_to_record l in uu___4 :: + out in + ((FStar_Pervasives_Native.Some ns), uu___3)))) + (FStar_Pervasives_Native.None, []) field_names in + match uu___ with + | (uu___1, field_names_rev) -> FStarC_Compiler_List.rev field_names_rev +let desugar_disjunctive_pattern : + 'uuuuu . + (FStarC_Syntax_Syntax.pat' FStarC_Syntax_Syntax.withinfo_t * + (FStarC_Syntax_Syntax.bv * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax * 'uuuuu) Prims.list) Prims.list -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax + FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.branch Prims.list + = + fun annotated_pats -> + fun when_opt -> + fun branch -> + FStarC_Compiler_List.map + (fun uu___ -> + match uu___ with + | (pat, annots) -> + let branch1 = + FStarC_Compiler_List.fold_left + (fun br -> + fun uu___1 -> + match uu___1 with + | (bv, ty, uu___2) -> + let lb = + let uu___3 = + FStarC_Syntax_Syntax.bv_to_name bv in + FStarC_Syntax_Util.mk_letbinding + (FStar_Pervasives.Inl bv) [] ty + FStarC_Parser_Const.effect_Tot_lid uu___3 + [] br.FStarC_Syntax_Syntax.pos in + let branch2 = + let uu___3 = + let uu___4 = + FStarC_Syntax_Syntax.mk_binder bv in + [uu___4] in + FStarC_Syntax_Subst.close uu___3 branch in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = (false, [lb]); + FStarC_Syntax_Syntax.body1 = branch2 + }) br.FStarC_Syntax_Syntax.pos) branch + annots in + FStarC_Syntax_Util.branch (pat, when_opt, branch1)) + annotated_pats +let (trans_qual : + FStarC_Compiler_Range_Type.range -> + FStarC_Ident.lident FStar_Pervasives_Native.option -> + FStarC_Parser_AST.qualifier -> FStarC_Syntax_Syntax.qualifier) + = + fun r -> + fun maybe_effect_id -> + fun uu___ -> + match uu___ with + | FStarC_Parser_AST.Private -> FStarC_Syntax_Syntax.Private + | FStarC_Parser_AST.Assumption -> FStarC_Syntax_Syntax.Assumption + | FStarC_Parser_AST.Unfold_for_unification_and_vcgen -> + FStarC_Syntax_Syntax.Unfold_for_unification_and_vcgen + | FStarC_Parser_AST.Inline_for_extraction -> + FStarC_Syntax_Syntax.Inline_for_extraction + | FStarC_Parser_AST.NoExtract -> FStarC_Syntax_Syntax.NoExtract + | FStarC_Parser_AST.Irreducible -> FStarC_Syntax_Syntax.Irreducible + | FStarC_Parser_AST.Logic -> FStarC_Syntax_Syntax.Logic + | FStarC_Parser_AST.TotalEffect -> FStarC_Syntax_Syntax.TotalEffect + | FStarC_Parser_AST.Effect_qual -> FStarC_Syntax_Syntax.Effect + | FStarC_Parser_AST.New -> FStarC_Syntax_Syntax.New + | FStarC_Parser_AST.Opaque -> + ((let uu___2 = + let uu___3 = + FStarC_Errors_Msg.text + "The 'opaque' qualifier is deprecated since its use was strangely schizophrenic." in + let uu___4 = + let uu___5 = + FStarC_Errors_Msg.text + "There were two overloaded uses: (1) Given 'opaque val f : t', the behavior was to exclude the definition of 'f' to the SMT solver. This corresponds roughly to the new 'irreducible' qualifier. (2) Given 'opaque type t = t'', the behavior was to provide the definition of 't' to the SMT solver, but not to inline it, unless absolutely required for unification. This corresponds roughly to the behavior of 'unfoldable' (which is currently the default)." in + [uu___5] in + uu___3 :: uu___4 in + FStarC_Errors.log_issue FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Warning_DeprecatedOpaqueQualifier () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___2)); + FStarC_Syntax_Syntax.Visible_default) + | FStarC_Parser_AST.Reflectable -> + (match maybe_effect_id with + | FStar_Pervasives_Native.None -> + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_ReflectOnlySupportedOnEffects () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "Qualifier reflect only supported on effects") + | FStar_Pervasives_Native.Some effect_id -> + FStarC_Syntax_Syntax.Reflectable effect_id) + | FStarC_Parser_AST.Reifiable -> FStarC_Syntax_Syntax.Reifiable + | FStarC_Parser_AST.Noeq -> FStarC_Syntax_Syntax.Noeq + | FStarC_Parser_AST.Unopteq -> FStarC_Syntax_Syntax.Unopteq + | FStarC_Parser_AST.DefaultEffect -> + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_DefaultQualifierNotAllowedOnEffects + () (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "The 'default' qualifier on effects is no longer supported") + | FStarC_Parser_AST.Inline -> + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_UnsupportedQualifier () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "Unsupported qualifier") + | FStarC_Parser_AST.Visible -> + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_UnsupportedQualifier () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "Unsupported qualifier") +let (trans_pragma : FStarC_Parser_AST.pragma -> FStarC_Syntax_Syntax.pragma) + = + fun uu___ -> + match uu___ with + | FStarC_Parser_AST.ShowOptions -> FStarC_Syntax_Syntax.ShowOptions + | FStarC_Parser_AST.SetOptions s -> FStarC_Syntax_Syntax.SetOptions s + | FStarC_Parser_AST.ResetOptions sopt -> + FStarC_Syntax_Syntax.ResetOptions sopt + | FStarC_Parser_AST.PushOptions sopt -> + FStarC_Syntax_Syntax.PushOptions sopt + | FStarC_Parser_AST.PopOptions -> FStarC_Syntax_Syntax.PopOptions + | FStarC_Parser_AST.RestartSolver -> FStarC_Syntax_Syntax.RestartSolver + | FStarC_Parser_AST.PrintEffectsGraph -> + FStarC_Syntax_Syntax.PrintEffectsGraph +let (as_imp : + FStarC_Parser_AST.imp -> + FStarC_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) + = + fun uu___ -> + match uu___ with + | FStarC_Parser_AST.Hash -> FStarC_Syntax_Syntax.as_aqual_implicit true + | uu___1 -> FStar_Pervasives_Native.None +let arg_withimp_t : + 'uuuuu . + FStarC_Parser_AST.imp -> + 'uuuuu -> + ('uuuuu * FStarC_Syntax_Syntax.arg_qualifier + FStar_Pervasives_Native.option) + = fun imp -> fun t -> let uu___ = as_imp imp in (t, uu___) +let (contains_binder : FStarC_Parser_AST.binder Prims.list -> Prims.bool) = + fun binders -> + FStarC_Compiler_Util.for_some + (fun b -> + match b.FStarC_Parser_AST.b with + | FStarC_Parser_AST.Annotated uu___ -> true + | uu___ -> false) binders +let rec (unparen : FStarC_Parser_AST.term -> FStarC_Parser_AST.term) = + fun t -> + match t.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Paren t1 -> unparen t1 + | uu___ -> t +let (tm_type_z : FStarC_Compiler_Range_Type.range -> FStarC_Parser_AST.term) + = + fun r -> + let uu___ = + let uu___1 = FStarC_Ident.lid_of_path ["Type0"] r in + FStarC_Parser_AST.Name uu___1 in + FStarC_Parser_AST.mk_term uu___ r FStarC_Parser_AST.Kind +let (tm_type : FStarC_Compiler_Range_Type.range -> FStarC_Parser_AST.term) = + fun r -> + let uu___ = + let uu___1 = FStarC_Ident.lid_of_path ["Type"] r in + FStarC_Parser_AST.Name uu___1 in + FStarC_Parser_AST.mk_term uu___ r FStarC_Parser_AST.Kind +let rec (is_comp_type : + FStarC_Syntax_DsEnv.env -> FStarC_Parser_AST.term -> Prims.bool) = + fun env -> + fun t -> + let uu___ = let uu___1 = unparen t in uu___1.FStarC_Parser_AST.tm in + match uu___ with + | FStarC_Parser_AST.Name l when + (let uu___1 = FStarC_Syntax_DsEnv.current_module env in + FStarC_Ident.lid_equals uu___1 FStarC_Parser_Const.prims_lid) && + (let s = + let uu___1 = FStarC_Ident.ident_of_lid l in + FStarC_Ident.string_of_id uu___1 in + (s = "Tot") || (s = "GTot")) + -> true + | FStarC_Parser_AST.Name l -> + let uu___1 = FStarC_Syntax_DsEnv.try_lookup_effect_name env l in + FStarC_Compiler_Option.isSome uu___1 + | FStarC_Parser_AST.Construct (l, uu___1) -> + let uu___2 = FStarC_Syntax_DsEnv.try_lookup_effect_name env l in + FStarC_Compiler_Option.isSome uu___2 + | FStarC_Parser_AST.App (head, uu___1, uu___2) -> is_comp_type env head + | FStarC_Parser_AST.Paren t1 -> failwith "impossible" + | FStarC_Parser_AST.Ascribed (t1, uu___1, uu___2, uu___3) -> + is_comp_type env t1 + | FStarC_Parser_AST.LetOpen (uu___1, t1) -> is_comp_type env t1 + | uu___1 -> false +let (unit_ty : FStarC_Compiler_Range_Type.range -> FStarC_Parser_AST.term) = + fun rng -> + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.Name FStarC_Parser_Const.unit_lid) rng + FStarC_Parser_AST.Type_level +type env_t = FStarC_Syntax_DsEnv.env +type lenv_t = FStarC_Syntax_Syntax.bv Prims.list +let (desugar_name' : + (FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) -> + env_t -> + Prims.bool -> + FStarC_Ident.lid -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = + fun setpos -> + fun env -> + fun resolve -> + fun l -> + let tm_attrs_opt = + if resolve + then FStarC_Syntax_DsEnv.try_lookup_lid_with_attributes env l + else + FStarC_Syntax_DsEnv.try_lookup_lid_with_attributes_no_resolve + env l in + match tm_attrs_opt with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (tm, attrs) -> + let tm1 = setpos tm in FStar_Pervasives_Native.Some tm1 +let desugar_name : + 'uuuuu . + 'uuuuu -> + (FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) -> + env_t -> + Prims.bool -> FStarC_Ident.lident -> FStarC_Syntax_Syntax.term + = + fun mk -> + fun setpos -> + fun env -> + fun resolve -> + fun l -> + FStarC_Syntax_DsEnv.fail_or env + (desugar_name' setpos env resolve) l +let (compile_op_lid : + Prims.int -> + Prims.string -> FStarC_Compiler_Range_Type.range -> FStarC_Ident.lident) + = + fun n -> + fun s -> + fun r -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Parser_AST.compile_op n s r in (uu___3, r) in + FStarC_Ident.mk_ident uu___2 in + [uu___1] in + FStarC_Ident.lid_of_ids uu___ +let (op_as_term : + env_t -> + Prims.int -> + FStarC_Ident.ident -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = + fun env -> + fun arity -> + fun op -> + let r l = + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Ident.range_of_id op in + FStarC_Ident.set_lid_range l uu___3 in + FStarC_Syntax_Syntax.lid_and_dd_as_fv uu___2 + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___1 in + FStar_Pervasives_Native.Some uu___ in + let fallback uu___ = + let uu___1 = FStarC_Ident.string_of_id op in + match uu___1 with + | "=" -> r FStarC_Parser_Const.op_Eq + | "<" -> r FStarC_Parser_Const.op_LT + | "<=" -> r FStarC_Parser_Const.op_LTE + | ">" -> r FStarC_Parser_Const.op_GT + | ">=" -> r FStarC_Parser_Const.op_GTE + | "&&" -> r FStarC_Parser_Const.op_And + | "||" -> r FStarC_Parser_Const.op_Or + | "+" -> r FStarC_Parser_Const.op_Addition + | "-" when arity = Prims.int_one -> r FStarC_Parser_Const.op_Minus + | "-" -> r FStarC_Parser_Const.op_Subtraction + | "/" -> r FStarC_Parser_Const.op_Division + | "%" -> r FStarC_Parser_Const.op_Modulus + | "@" -> + ((let uu___3 = + let uu___4 = + FStarC_Errors_Msg.text + "The operator '@' has been resolved to FStar.List.Tot.append even though FStar.List.Tot is not in scope. Please add an 'open FStar.List.Tot' to stop relying on this deprecated, special treatment of '@'." in + [uu___4] in + FStarC_Errors.log_issue FStarC_Ident.hasrange_ident op + FStarC_Errors_Codes.Warning_DeprecatedGeneric () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___3)); + r FStarC_Parser_Const.list_tot_append_lid) + | "<>" -> r FStarC_Parser_Const.op_notEq + | "~" -> r FStarC_Parser_Const.not_lid + | "==" -> r FStarC_Parser_Const.eq2_lid + | "<<" -> r FStarC_Parser_Const.precedes_lid + | "/\\" -> r FStarC_Parser_Const.and_lid + | "\\/" -> r FStarC_Parser_Const.or_lid + | "==>" -> r FStarC_Parser_Const.imp_lid + | "<==>" -> r FStarC_Parser_Const.iff_lid + | uu___2 -> FStar_Pervasives_Native.None in + let uu___ = + let uu___1 = + let uu___2 = FStarC_Ident.string_of_id op in + let uu___3 = FStarC_Ident.range_of_id op in + compile_op_lid arity uu___2 uu___3 in + desugar_name' + (fun t -> + let uu___2 = FStarC_Ident.range_of_id op in + { + FStarC_Syntax_Syntax.n = (t.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = uu___2; + FStarC_Syntax_Syntax.vars = (t.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (t.FStarC_Syntax_Syntax.hash_code) + }) env true uu___1 in + match uu___ with + | FStar_Pervasives_Native.Some t -> FStar_Pervasives_Native.Some t + | uu___1 -> fallback () +let (sort_ftv : + FStarC_Ident.ident Prims.list -> FStarC_Ident.ident Prims.list) = + fun ftv -> + let uu___ = + FStarC_Compiler_Util.remove_dups + (fun x -> + fun y -> + let uu___1 = FStarC_Ident.string_of_id x in + let uu___2 = FStarC_Ident.string_of_id y in uu___1 = uu___2) ftv in + FStarC_Compiler_Util.sort_with + (fun x -> + fun y -> + let uu___1 = FStarC_Ident.string_of_id x in + let uu___2 = FStarC_Ident.string_of_id y in + FStarC_Compiler_String.compare uu___1 uu___2) uu___ +let rec (free_vars_b : + Prims.bool -> + FStarC_Syntax_DsEnv.env -> + FStarC_Parser_AST.binder -> + (FStarC_Syntax_DsEnv.env * FStarC_Ident.ident Prims.list)) + = + fun tvars_only -> + fun env -> + fun binder -> + match binder.FStarC_Parser_AST.b with + | FStarC_Parser_AST.Variable x -> + if tvars_only + then (env, []) + else + (let uu___1 = FStarC_Syntax_DsEnv.push_bv env x in + match uu___1 with | (env1, uu___2) -> (env1, [])) + | FStarC_Parser_AST.TVariable x -> + let uu___ = FStarC_Syntax_DsEnv.push_bv env x in + (match uu___ with | (env1, uu___1) -> (env1, [x])) + | FStarC_Parser_AST.Annotated (x, term) -> + if tvars_only + then let uu___ = free_vars tvars_only env term in (env, uu___) + else + (let uu___1 = FStarC_Syntax_DsEnv.push_bv env x in + match uu___1 with + | (env', uu___2) -> + let uu___3 = free_vars tvars_only env term in + (env', uu___3)) + | FStarC_Parser_AST.TAnnotated (id, term) -> + let uu___ = FStarC_Syntax_DsEnv.push_bv env id in + (match uu___ with + | (env', uu___1) -> + let uu___2 = free_vars tvars_only env term in (env', uu___2)) + | FStarC_Parser_AST.NoName t -> + let uu___ = free_vars tvars_only env t in (env, uu___) +and (free_vars_bs : + Prims.bool -> + FStarC_Syntax_DsEnv.env -> + FStarC_Parser_AST.binder Prims.list -> + (FStarC_Syntax_DsEnv.env * FStarC_Ident.ident Prims.list)) + = + fun tvars_only -> + fun env -> + fun binders -> + FStarC_Compiler_List.fold_left + (fun uu___ -> + fun binder -> + match uu___ with + | (env1, free) -> + let uu___1 = free_vars_b tvars_only env1 binder in + (match uu___1 with + | (env2, f) -> + (env2, (FStarC_Compiler_List.op_At f free)))) + (env, []) binders +and (free_vars : + Prims.bool -> + FStarC_Syntax_DsEnv.env -> + FStarC_Parser_AST.term -> FStarC_Ident.ident Prims.list) + = + fun tvars_only -> + fun env -> + fun t -> + let uu___ = let uu___1 = unparen t in uu___1.FStarC_Parser_AST.tm in + match uu___ with + | FStarC_Parser_AST.Labeled uu___1 -> + failwith "Impossible --- labeled source term" + | FStarC_Parser_AST.Tvar a -> + let uu___1 = FStarC_Syntax_DsEnv.try_lookup_id env a in + (match uu___1 with + | FStar_Pervasives_Native.None -> [a] + | uu___2 -> []) + | FStarC_Parser_AST.Var x -> + if tvars_only + then [] + else + (let ids = FStarC_Ident.ids_of_lid x in + match ids with + | id::[] -> + let uu___2 = + (let uu___3 = FStarC_Syntax_DsEnv.try_lookup_id env id in + FStar_Pervasives_Native.uu___is_None uu___3) && + (let uu___3 = FStarC_Syntax_DsEnv.try_lookup_lid env x in + FStar_Pervasives_Native.uu___is_None uu___3) in + if uu___2 then [id] else [] + | uu___2 -> []) + | FStarC_Parser_AST.Wild -> [] + | FStarC_Parser_AST.Const uu___1 -> [] + | FStarC_Parser_AST.Uvar uu___1 -> [] + | FStarC_Parser_AST.Projector uu___1 -> [] + | FStarC_Parser_AST.Discrim uu___1 -> [] + | FStarC_Parser_AST.Name uu___1 -> [] + | FStarC_Parser_AST.Requires (t1, uu___1) -> + free_vars tvars_only env t1 + | FStarC_Parser_AST.Ensures (t1, uu___1) -> + free_vars tvars_only env t1 + | FStarC_Parser_AST.Decreases (t1, uu___1) -> + free_vars tvars_only env t1 + | FStarC_Parser_AST.NamedTyp (uu___1, t1) -> + free_vars tvars_only env t1 + | FStarC_Parser_AST.LexList l -> + FStarC_Compiler_List.collect (free_vars tvars_only env) l + | FStarC_Parser_AST.WFOrder (rel, e) -> + let uu___1 = free_vars tvars_only env rel in + let uu___2 = free_vars tvars_only env e in + FStarC_Compiler_List.op_At uu___1 uu___2 + | FStarC_Parser_AST.Paren t1 -> failwith "impossible" + | FStarC_Parser_AST.Ascribed (t1, t', tacopt, uu___1) -> + let ts = t1 :: t' :: + (match tacopt with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some t2 -> [t2]) in + FStarC_Compiler_List.collect (free_vars tvars_only env) ts + | FStarC_Parser_AST.Construct (uu___1, ts) -> + FStarC_Compiler_List.collect + (fun uu___2 -> + match uu___2 with + | (t1, uu___3) -> free_vars tvars_only env t1) ts + | FStarC_Parser_AST.Op (uu___1, ts) -> + FStarC_Compiler_List.collect (free_vars tvars_only env) ts + | FStarC_Parser_AST.App (t1, t2, uu___1) -> + let uu___2 = free_vars tvars_only env t1 in + let uu___3 = free_vars tvars_only env t2 in + FStarC_Compiler_List.op_At uu___2 uu___3 + | FStarC_Parser_AST.Refine (b, t1) -> + let uu___1 = free_vars_b tvars_only env b in + (match uu___1 with + | (env1, f) -> + let uu___2 = free_vars tvars_only env1 t1 in + FStarC_Compiler_List.op_At f uu___2) + | FStarC_Parser_AST.Sum (binders, body) -> + let uu___1 = + FStarC_Compiler_List.fold_left + (fun uu___2 -> + fun bt -> + match uu___2 with + | (env1, free) -> + let uu___3 = + match bt with + | FStar_Pervasives.Inl binder -> + free_vars_b tvars_only env1 binder + | FStar_Pervasives.Inr t1 -> + let uu___4 = free_vars tvars_only env1 t1 in + (env1, uu___4) in + (match uu___3 with + | (env2, f) -> + (env2, (FStarC_Compiler_List.op_At f free)))) + (env, []) binders in + (match uu___1 with + | (env1, free) -> + let uu___2 = free_vars tvars_only env1 body in + FStarC_Compiler_List.op_At free uu___2) + | FStarC_Parser_AST.Product (binders, body) -> + let uu___1 = free_vars_bs tvars_only env binders in + (match uu___1 with + | (env1, free) -> + let uu___2 = free_vars tvars_only env1 body in + FStarC_Compiler_List.op_At free uu___2) + | FStarC_Parser_AST.Project (t1, uu___1) -> + free_vars tvars_only env t1 + | FStarC_Parser_AST.Attributes cattributes -> + FStarC_Compiler_List.collect (free_vars tvars_only env) + cattributes + | FStarC_Parser_AST.CalcProof (rel, init, steps) -> + let uu___1 = free_vars tvars_only env rel in + let uu___2 = + let uu___3 = free_vars tvars_only env init in + let uu___4 = + FStarC_Compiler_List.collect + (fun uu___5 -> + match uu___5 with + | FStarC_Parser_AST.CalcStep (rel1, just, next) -> + let uu___6 = free_vars tvars_only env rel1 in + let uu___7 = + let uu___8 = free_vars tvars_only env just in + let uu___9 = free_vars tvars_only env next in + FStarC_Compiler_List.op_At uu___8 uu___9 in + FStarC_Compiler_List.op_At uu___6 uu___7) steps in + FStarC_Compiler_List.op_At uu___3 uu___4 in + FStarC_Compiler_List.op_At uu___1 uu___2 + | FStarC_Parser_AST.ElimForall (bs, t1, ts) -> + let uu___1 = free_vars_bs tvars_only env bs in + (match uu___1 with + | (env', free) -> + let uu___2 = + let uu___3 = free_vars tvars_only env' t1 in + let uu___4 = + FStarC_Compiler_List.collect (free_vars tvars_only env') + ts in + FStarC_Compiler_List.op_At uu___3 uu___4 in + FStarC_Compiler_List.op_At free uu___2) + | FStarC_Parser_AST.ElimExists (binders, p, q, y, e) -> + let uu___1 = free_vars_bs tvars_only env binders in + (match uu___1 with + | (env', free) -> + let uu___2 = free_vars_b tvars_only env' y in + (match uu___2 with + | (env'', free') -> + let uu___3 = + let uu___4 = free_vars tvars_only env' p in + let uu___5 = + let uu___6 = free_vars tvars_only env q in + let uu___7 = + let uu___8 = free_vars tvars_only env'' e in + FStarC_Compiler_List.op_At free' uu___8 in + FStarC_Compiler_List.op_At uu___6 uu___7 in + FStarC_Compiler_List.op_At uu___4 uu___5 in + FStarC_Compiler_List.op_At free uu___3)) + | FStarC_Parser_AST.ElimImplies (p, q, e) -> + let uu___1 = free_vars tvars_only env p in + let uu___2 = + let uu___3 = free_vars tvars_only env q in + let uu___4 = free_vars tvars_only env e in + FStarC_Compiler_List.op_At uu___3 uu___4 in + FStarC_Compiler_List.op_At uu___1 uu___2 + | FStarC_Parser_AST.ElimOr (p, q, r, x, e, x', e') -> + let uu___1 = free_vars tvars_only env p in + let uu___2 = + let uu___3 = free_vars tvars_only env q in + let uu___4 = + let uu___5 = free_vars tvars_only env r in + let uu___6 = + let uu___7 = + let uu___8 = free_vars_b tvars_only env x in + match uu___8 with + | (env', free) -> + let uu___9 = free_vars tvars_only env' e in + FStarC_Compiler_List.op_At free uu___9 in + let uu___8 = + let uu___9 = free_vars_b tvars_only env x' in + match uu___9 with + | (env', free) -> + let uu___10 = free_vars tvars_only env' e' in + FStarC_Compiler_List.op_At free uu___10 in + FStarC_Compiler_List.op_At uu___7 uu___8 in + FStarC_Compiler_List.op_At uu___5 uu___6 in + FStarC_Compiler_List.op_At uu___3 uu___4 in + FStarC_Compiler_List.op_At uu___1 uu___2 + | FStarC_Parser_AST.ElimAnd (p, q, r, x, y, e) -> + let uu___1 = free_vars tvars_only env p in + let uu___2 = + let uu___3 = free_vars tvars_only env q in + let uu___4 = + let uu___5 = free_vars tvars_only env r in + let uu___6 = + let uu___7 = free_vars_bs tvars_only env [x; y] in + match uu___7 with + | (env', free) -> + let uu___8 = free_vars tvars_only env' e in + FStarC_Compiler_List.op_At free uu___8 in + FStarC_Compiler_List.op_At uu___5 uu___6 in + FStarC_Compiler_List.op_At uu___3 uu___4 in + FStarC_Compiler_List.op_At uu___1 uu___2 + | FStarC_Parser_AST.ListLiteral ts -> + FStarC_Compiler_List.collect (free_vars tvars_only env) ts + | FStarC_Parser_AST.SeqLiteral ts -> + FStarC_Compiler_List.collect (free_vars tvars_only env) ts + | FStarC_Parser_AST.Abs uu___1 -> [] + | FStarC_Parser_AST.Function uu___1 -> [] + | FStarC_Parser_AST.Let uu___1 -> [] + | FStarC_Parser_AST.LetOpen uu___1 -> [] + | FStarC_Parser_AST.If uu___1 -> [] + | FStarC_Parser_AST.QForall uu___1 -> [] + | FStarC_Parser_AST.QExists uu___1 -> [] + | FStarC_Parser_AST.QuantOp uu___1 -> [] + | FStarC_Parser_AST.Record uu___1 -> [] + | FStarC_Parser_AST.Match uu___1 -> [] + | FStarC_Parser_AST.TryWith uu___1 -> [] + | FStarC_Parser_AST.Bind uu___1 -> [] + | FStarC_Parser_AST.Quote uu___1 -> [] + | FStarC_Parser_AST.VQuote uu___1 -> [] + | FStarC_Parser_AST.Antiquote uu___1 -> [] + | FStarC_Parser_AST.Seq uu___1 -> [] +let (free_type_vars : + FStarC_Syntax_DsEnv.env -> + FStarC_Parser_AST.term -> FStarC_Ident.ident Prims.list) + = free_vars true +let (head_and_args : + FStarC_Parser_AST.term -> + (FStarC_Parser_AST.term * (FStarC_Parser_AST.term * + FStarC_Parser_AST.imp) Prims.list)) + = + fun t -> + let rec aux args t1 = + let uu___ = let uu___1 = unparen t1 in uu___1.FStarC_Parser_AST.tm in + match uu___ with + | FStarC_Parser_AST.App (t2, arg, imp) -> aux ((arg, imp) :: args) t2 + | FStarC_Parser_AST.Construct (l, args') -> + ({ + FStarC_Parser_AST.tm = (FStarC_Parser_AST.Name l); + FStarC_Parser_AST.range = (t1.FStarC_Parser_AST.range); + FStarC_Parser_AST.level = (t1.FStarC_Parser_AST.level) + }, (FStarC_Compiler_List.op_At args' args)) + | uu___1 -> (t1, args) in + aux [] t +let (close : + FStarC_Syntax_DsEnv.env -> FStarC_Parser_AST.term -> FStarC_Parser_AST.term) + = + fun env -> + fun t -> + let ftv = let uu___ = free_type_vars env t in sort_ftv uu___ in + if (FStarC_Compiler_List.length ftv) = Prims.int_zero + then t + else + (let binders = + FStarC_Compiler_List.map + (fun x -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Ident.range_of_id x in + tm_type uu___4 in + (x, uu___3) in + FStarC_Parser_AST.TAnnotated uu___2 in + let uu___2 = FStarC_Ident.range_of_id x in + FStarC_Parser_AST.mk_binder uu___1 uu___2 + FStarC_Parser_AST.Type_level + (FStar_Pervasives_Native.Some FStarC_Parser_AST.Implicit)) + ftv in + let result = + FStarC_Parser_AST.mk_term (FStarC_Parser_AST.Product (binders, t)) + t.FStarC_Parser_AST.range t.FStarC_Parser_AST.level in + result) +let (close_fun : + FStarC_Syntax_DsEnv.env -> FStarC_Parser_AST.term -> FStarC_Parser_AST.term) + = + fun env -> + fun t -> + let ftv = let uu___ = free_type_vars env t in sort_ftv uu___ in + if (FStarC_Compiler_List.length ftv) = Prims.int_zero + then t + else + (let binders = + FStarC_Compiler_List.map + (fun x -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Ident.range_of_id x in + tm_type uu___4 in + (x, uu___3) in + FStarC_Parser_AST.TAnnotated uu___2 in + let uu___2 = FStarC_Ident.range_of_id x in + FStarC_Parser_AST.mk_binder uu___1 uu___2 + FStarC_Parser_AST.Type_level + (FStar_Pervasives_Native.Some FStarC_Parser_AST.Implicit)) + ftv in + let t1 = + let uu___1 = let uu___2 = unparen t in uu___2.FStarC_Parser_AST.tm in + match uu___1 with + | FStarC_Parser_AST.Product uu___2 -> t + | uu___2 -> + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.Name + FStarC_Parser_Const.effect_Tot_lid) + t.FStarC_Parser_AST.range t.FStarC_Parser_AST.level in + (uu___5, t, FStarC_Parser_AST.Nothing) in + FStarC_Parser_AST.App uu___4 in + FStarC_Parser_AST.mk_term uu___3 t.FStarC_Parser_AST.range + t.FStarC_Parser_AST.level in + let result = + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.Product (binders, t1)) + t1.FStarC_Parser_AST.range t1.FStarC_Parser_AST.level in + result) +let rec (uncurry : + FStarC_Parser_AST.binder Prims.list -> + FStarC_Parser_AST.term -> + (FStarC_Parser_AST.binder Prims.list * FStarC_Parser_AST.term)) + = + fun bs -> + fun t -> + match t.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Product (binders, t1) -> + uncurry (FStarC_Compiler_List.op_At bs binders) t1 + | uu___ -> (bs, t) +let rec (is_var_pattern : FStarC_Parser_AST.pattern -> Prims.bool) = + fun p -> + match p.FStarC_Parser_AST.pat with + | FStarC_Parser_AST.PatWild uu___ -> true + | FStarC_Parser_AST.PatTvar uu___ -> true + | FStarC_Parser_AST.PatVar uu___ -> true + | FStarC_Parser_AST.PatAscribed (p1, uu___) -> is_var_pattern p1 + | uu___ -> false +let rec (is_app_pattern : FStarC_Parser_AST.pattern -> Prims.bool) = + fun p -> + match p.FStarC_Parser_AST.pat with + | FStarC_Parser_AST.PatAscribed (p1, uu___) -> is_app_pattern p1 + | FStarC_Parser_AST.PatApp + ({ FStarC_Parser_AST.pat = FStarC_Parser_AST.PatVar uu___; + FStarC_Parser_AST.prange = uu___1;_}, + uu___2) + -> true + | uu___ -> false +let (replace_unit_pattern : + FStarC_Parser_AST.pattern -> FStarC_Parser_AST.pattern) = + fun p -> + match p.FStarC_Parser_AST.pat with + | FStarC_Parser_AST.PatConst (FStarC_Const.Const_unit) -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Parser_AST.mk_pattern + (FStarC_Parser_AST.PatWild (FStar_Pervasives_Native.None, [])) + p.FStarC_Parser_AST.prange in + let uu___3 = + let uu___4 = unit_ty p.FStarC_Parser_AST.prange in + (uu___4, FStar_Pervasives_Native.None) in + (uu___2, uu___3) in + FStarC_Parser_AST.PatAscribed uu___1 in + FStarC_Parser_AST.mk_pattern uu___ p.FStarC_Parser_AST.prange + | uu___ -> p +let rec (destruct_app_pattern : + env_t -> + Prims.bool -> + FStarC_Parser_AST.pattern -> + ((FStarC_Ident.ident, FStarC_Ident.lid) FStar_Pervasives.either * + FStarC_Parser_AST.pattern Prims.list * (FStarC_Parser_AST.term * + FStarC_Parser_AST.term FStar_Pervasives_Native.option) + FStar_Pervasives_Native.option)) + = + fun env -> + fun is_top_level -> + fun p -> + match p.FStarC_Parser_AST.pat with + | FStarC_Parser_AST.PatAscribed (p1, t) -> + let uu___ = destruct_app_pattern env is_top_level p1 in + (match uu___ with + | (name, args, uu___1) -> + (name, args, (FStar_Pervasives_Native.Some t))) + | FStarC_Parser_AST.PatApp + ({ + FStarC_Parser_AST.pat = FStarC_Parser_AST.PatVar + (id, uu___, uu___1); + FStarC_Parser_AST.prange = uu___2;_}, + args) + when is_top_level -> + let uu___3 = + let uu___4 = FStarC_Syntax_DsEnv.qualify env id in + FStar_Pervasives.Inr uu___4 in + (uu___3, args, FStar_Pervasives_Native.None) + | FStarC_Parser_AST.PatApp + ({ + FStarC_Parser_AST.pat = FStarC_Parser_AST.PatVar + (id, uu___, uu___1); + FStarC_Parser_AST.prange = uu___2;_}, + args) + -> + ((FStar_Pervasives.Inl id), args, FStar_Pervasives_Native.None) + | uu___ -> failwith "Not an app pattern" +let rec (gather_pattern_bound_vars_maybe_top : + FStarC_Ident.ident FStarC_Compiler_FlatSet.t -> + FStarC_Parser_AST.pattern -> FStarC_Ident.ident FStarC_Compiler_FlatSet.t) + = + fun uu___1 -> + fun uu___ -> + (fun acc -> + fun p -> + let gather_pattern_bound_vars_from_list = + FStarC_Compiler_List.fold_left + gather_pattern_bound_vars_maybe_top acc in + match p.FStarC_Parser_AST.pat with + | FStarC_Parser_AST.PatWild uu___ -> Obj.magic (Obj.repr acc) + | FStarC_Parser_AST.PatConst uu___ -> Obj.magic (Obj.repr acc) + | FStarC_Parser_AST.PatVQuote uu___ -> Obj.magic (Obj.repr acc) + | FStarC_Parser_AST.PatName uu___ -> Obj.magic (Obj.repr acc) + | FStarC_Parser_AST.PatOp uu___ -> Obj.magic (Obj.repr acc) + | FStarC_Parser_AST.PatApp (phead, pats) -> + Obj.magic + (Obj.repr + (gather_pattern_bound_vars_from_list (phead :: pats))) + | FStarC_Parser_AST.PatTvar (x, uu___, uu___1) -> + Obj.magic + (Obj.repr + (FStarC_Class_Setlike.add () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_ident)) x + (Obj.magic acc))) + | FStarC_Parser_AST.PatVar (x, uu___, uu___1) -> + Obj.magic + (Obj.repr + (FStarC_Class_Setlike.add () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_ident)) x + (Obj.magic acc))) + | FStarC_Parser_AST.PatList pats -> + Obj.magic + (Obj.repr (gather_pattern_bound_vars_from_list pats)) + | FStarC_Parser_AST.PatTuple (pats, uu___) -> + Obj.magic + (Obj.repr (gather_pattern_bound_vars_from_list pats)) + | FStarC_Parser_AST.PatOr pats -> + Obj.magic + (Obj.repr (gather_pattern_bound_vars_from_list pats)) + | FStarC_Parser_AST.PatRecord guarded_pats -> + Obj.magic + (Obj.repr + (let uu___ = + FStarC_Compiler_List.map FStar_Pervasives_Native.snd + guarded_pats in + gather_pattern_bound_vars_from_list uu___)) + | FStarC_Parser_AST.PatAscribed (pat, uu___) -> + Obj.magic + (Obj.repr (gather_pattern_bound_vars_maybe_top acc pat))) + uu___1 uu___ +let (gather_pattern_bound_vars : + FStarC_Parser_AST.pattern -> FStarC_Ident.ident FStarC_Compiler_FlatSet.t) + = + let acc = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_ident)) ()) in + fun p -> gather_pattern_bound_vars_maybe_top acc p +type bnd = + | LocalBinder of (FStarC_Syntax_Syntax.bv * FStarC_Syntax_Syntax.bqual * + FStarC_Syntax_Syntax.term Prims.list) + | LetBinder of (FStarC_Ident.lident * (FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option)) +let (uu___is_LocalBinder : bnd -> Prims.bool) = + fun projectee -> + match projectee with | LocalBinder _0 -> true | uu___ -> false +let (__proj__LocalBinder__item___0 : + bnd -> + (FStarC_Syntax_Syntax.bv * FStarC_Syntax_Syntax.bqual * + FStarC_Syntax_Syntax.term Prims.list)) + = fun projectee -> match projectee with | LocalBinder _0 -> _0 +let (uu___is_LetBinder : bnd -> Prims.bool) = + fun projectee -> + match projectee with | LetBinder _0 -> true | uu___ -> false +let (__proj__LetBinder__item___0 : + bnd -> + (FStarC_Ident.lident * (FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option))) + = fun projectee -> match projectee with | LetBinder _0 -> _0 +let (is_implicit : bnd -> Prims.bool) = + fun b -> + match b with + | LocalBinder + (uu___, FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Implicit + uu___1), uu___2) + -> true + | uu___ -> false +let (binder_of_bnd : + bnd -> + (FStarC_Syntax_Syntax.bv * FStarC_Syntax_Syntax.bqual * + FStarC_Syntax_Syntax.term Prims.list)) + = + fun uu___ -> + match uu___ with + | LocalBinder (a, aq, attrs) -> (a, aq, attrs) + | uu___1 -> failwith "Impossible" +let (mk_lb : + (FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax Prims.list * + (FStarC_Syntax_Syntax.bv, FStarC_Syntax_Syntax.fv) + FStar_Pervasives.either * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax * FStarC_Compiler_Range_Type.range) -> + FStarC_Syntax_Syntax.letbinding) + = + fun uu___ -> + match uu___ with + | (attrs, n, t, e, pos) -> + let uu___1 = FStarC_Parser_Const.effect_ALL_lid () in + { + FStarC_Syntax_Syntax.lbname = n; + FStarC_Syntax_Syntax.lbunivs = []; + FStarC_Syntax_Syntax.lbtyp = t; + FStarC_Syntax_Syntax.lbeff = uu___1; + FStarC_Syntax_Syntax.lbdef = e; + FStarC_Syntax_Syntax.lbattrs = attrs; + FStarC_Syntax_Syntax.lbpos = pos + } +let (no_annot_abs : + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun bs -> fun t -> FStarC_Syntax_Util.abs bs t FStar_Pervasives_Native.None +let rec (generalize_annotated_univs : + FStarC_Syntax_Syntax.sigelt -> FStarC_Syntax_Syntax.sigelt) = + fun s -> + let vars = FStarC_Compiler_Util.mk_ref [] in + let seen = + let uu___ = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Syntax.ord_ident)) ()) in + FStarC_Compiler_Util.mk_ref uu___ in + let reg u = + let uu___ = + let uu___1 = + let uu___2 = FStarC_Compiler_Effect.op_Bang seen in + FStarC_Class_Setlike.mem () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Syntax.ord_ident)) u (Obj.magic uu___2) in + Prims.op_Negation uu___1 in + if uu___ + then + ((let uu___2 = + let uu___3 = FStarC_Compiler_Effect.op_Bang seen in + Obj.magic + (FStarC_Class_Setlike.add () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Syntax.ord_ident)) u (Obj.magic uu___3)) in + FStarC_Compiler_Effect.op_Colon_Equals seen uu___2); + (let uu___2 = + let uu___3 = FStarC_Compiler_Effect.op_Bang vars in u :: uu___3 in + FStarC_Compiler_Effect.op_Colon_Equals vars uu___2)) + else () in + let get uu___ = + let uu___1 = FStarC_Compiler_Effect.op_Bang vars in + FStarC_Compiler_List.rev uu___1 in + let uu___ = + FStarC_Syntax_Visit.visit_sigelt false (fun t -> t) + (fun u -> + (match u with + | FStarC_Syntax_Syntax.U_name nm -> reg nm + | uu___3 -> ()); + u) s in + let unames = get () in + match s.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_inductive_typ uu___1 -> + failwith + "Impossible: collect_annotated_universes: bare data/type constructor" + | FStarC_Syntax_Syntax.Sig_datacon uu___1 -> + failwith + "Impossible: collect_annotated_universes: bare data/type constructor" + | FStarC_Syntax_Syntax.Sig_bundle + { FStarC_Syntax_Syntax.ses = sigs; + FStarC_Syntax_Syntax.lids = lids;_} + -> + let usubst = FStarC_Syntax_Subst.univ_var_closing unames in + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Compiler_List.map + (fun se -> + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = lid; + FStarC_Syntax_Syntax.us = uu___4; + FStarC_Syntax_Syntax.params = bs; + FStarC_Syntax_Syntax.num_uniform_params = + num_uniform; + FStarC_Syntax_Syntax.t = t; + FStarC_Syntax_Syntax.mutuals = lids1; + FStarC_Syntax_Syntax.ds = lids2; + FStarC_Syntax_Syntax.injective_type_params = uu___5;_} + -> + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Subst.subst_binders usubst bs in + let uu___9 = + let uu___10 = + FStarC_Syntax_Subst.shift_subst + (FStarC_Compiler_List.length bs) usubst in + FStarC_Syntax_Subst.subst uu___10 t in + { + FStarC_Syntax_Syntax.lid = lid; + FStarC_Syntax_Syntax.us = unames; + FStarC_Syntax_Syntax.params = uu___8; + FStarC_Syntax_Syntax.num_uniform_params = + num_uniform; + FStarC_Syntax_Syntax.t = uu___9; + FStarC_Syntax_Syntax.mutuals = lids1; + FStarC_Syntax_Syntax.ds = lids2; + FStarC_Syntax_Syntax.injective_type_params = + false + } in + FStarC_Syntax_Syntax.Sig_inductive_typ uu___7 in + { + FStarC_Syntax_Syntax.sigel = uu___6; + FStarC_Syntax_Syntax.sigrng = + (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se.FStarC_Syntax_Syntax.sigopts) + } + | FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = lid; + FStarC_Syntax_Syntax.us1 = uu___4; + FStarC_Syntax_Syntax.t1 = t; + FStarC_Syntax_Syntax.ty_lid = tlid; + FStarC_Syntax_Syntax.num_ty_params = n; + FStarC_Syntax_Syntax.mutuals1 = lids1; + FStarC_Syntax_Syntax.injective_type_params1 = uu___5;_} + -> + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Syntax_Subst.subst usubst t in + { + FStarC_Syntax_Syntax.lid1 = lid; + FStarC_Syntax_Syntax.us1 = unames; + FStarC_Syntax_Syntax.t1 = uu___8; + FStarC_Syntax_Syntax.ty_lid = tlid; + FStarC_Syntax_Syntax.num_ty_params = n; + FStarC_Syntax_Syntax.mutuals1 = lids1; + FStarC_Syntax_Syntax.injective_type_params1 = + false + } in + FStarC_Syntax_Syntax.Sig_datacon uu___7 in + { + FStarC_Syntax_Syntax.sigel = uu___6; + FStarC_Syntax_Syntax.sigrng = + (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se.FStarC_Syntax_Syntax.sigopts) + } + | uu___4 -> + failwith + "Impossible: collect_annotated_universes: Sig_bundle should not have a non data/type sigelt") + sigs in + { + FStarC_Syntax_Syntax.ses = uu___3; + FStarC_Syntax_Syntax.lids = lids + } in + FStarC_Syntax_Syntax.Sig_bundle uu___2 in + { + FStarC_Syntax_Syntax.sigel = uu___1; + FStarC_Syntax_Syntax.sigrng = (s.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = (s.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = (s.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = (s.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (s.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = (s.FStarC_Syntax_Syntax.sigopts) + } + | FStarC_Syntax_Syntax.Sig_declare_typ + { FStarC_Syntax_Syntax.lid2 = lid; FStarC_Syntax_Syntax.us2 = uu___1; + FStarC_Syntax_Syntax.t2 = t;_} + -> + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.close_univ_vars unames t in + { + FStarC_Syntax_Syntax.lid2 = lid; + FStarC_Syntax_Syntax.us2 = unames; + FStarC_Syntax_Syntax.t2 = uu___4 + } in + FStarC_Syntax_Syntax.Sig_declare_typ uu___3 in + { + FStarC_Syntax_Syntax.sigel = uu___2; + FStarC_Syntax_Syntax.sigrng = (s.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = (s.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = (s.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = (s.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (s.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = (s.FStarC_Syntax_Syntax.sigopts) + } + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (b, lbs); + FStarC_Syntax_Syntax.lids1 = lids;_} + -> + let usubst = FStarC_Syntax_Subst.univ_var_closing unames in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Compiler_List.map + (fun lb -> + let uu___5 = + FStarC_Syntax_Subst.subst usubst + lb.FStarC_Syntax_Syntax.lbtyp in + let uu___6 = + FStarC_Syntax_Subst.subst usubst + lb.FStarC_Syntax_Syntax.lbdef in + { + FStarC_Syntax_Syntax.lbname = + (lb.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs = unames; + FStarC_Syntax_Syntax.lbtyp = uu___5; + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = uu___6; + FStarC_Syntax_Syntax.lbattrs = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + }) lbs in + (b, uu___4) in + { + FStarC_Syntax_Syntax.lbs1 = uu___3; + FStarC_Syntax_Syntax.lids1 = lids + } in + FStarC_Syntax_Syntax.Sig_let uu___2 in + { + FStarC_Syntax_Syntax.sigel = uu___1; + FStarC_Syntax_Syntax.sigrng = (s.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = (s.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = (s.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = (s.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (s.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = (s.FStarC_Syntax_Syntax.sigopts) + } + | FStarC_Syntax_Syntax.Sig_assume + { FStarC_Syntax_Syntax.lid3 = lid; FStarC_Syntax_Syntax.us3 = uu___1; + FStarC_Syntax_Syntax.phi1 = fml;_} + -> + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.close_univ_vars unames fml in + { + FStarC_Syntax_Syntax.lid3 = lid; + FStarC_Syntax_Syntax.us3 = unames; + FStarC_Syntax_Syntax.phi1 = uu___4 + } in + FStarC_Syntax_Syntax.Sig_assume uu___3 in + { + FStarC_Syntax_Syntax.sigel = uu___2; + FStarC_Syntax_Syntax.sigrng = (s.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = (s.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = (s.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = (s.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (s.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = (s.FStarC_Syntax_Syntax.sigopts) + } + | FStarC_Syntax_Syntax.Sig_effect_abbrev + { FStarC_Syntax_Syntax.lid4 = lid; FStarC_Syntax_Syntax.us4 = uu___1; + FStarC_Syntax_Syntax.bs2 = bs; FStarC_Syntax_Syntax.comp1 = c; + FStarC_Syntax_Syntax.cflags = flags;_} + -> + let usubst = FStarC_Syntax_Subst.univ_var_closing unames in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.subst_binders usubst bs in + let uu___5 = FStarC_Syntax_Subst.subst_comp usubst c in + { + FStarC_Syntax_Syntax.lid4 = lid; + FStarC_Syntax_Syntax.us4 = unames; + FStarC_Syntax_Syntax.bs2 = uu___4; + FStarC_Syntax_Syntax.comp1 = uu___5; + FStarC_Syntax_Syntax.cflags = flags + } in + FStarC_Syntax_Syntax.Sig_effect_abbrev uu___3 in + { + FStarC_Syntax_Syntax.sigel = uu___2; + FStarC_Syntax_Syntax.sigrng = (s.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = (s.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = (s.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = (s.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (s.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = (s.FStarC_Syntax_Syntax.sigopts) + } + | FStarC_Syntax_Syntax.Sig_fail + { FStarC_Syntax_Syntax.errs = errs; + FStarC_Syntax_Syntax.fail_in_lax = lax; + FStarC_Syntax_Syntax.ses1 = ses;_} + -> + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Compiler_List.map generalize_annotated_univs ses in + { + FStarC_Syntax_Syntax.errs = errs; + FStarC_Syntax_Syntax.fail_in_lax = lax; + FStarC_Syntax_Syntax.ses1 = uu___3 + } in + FStarC_Syntax_Syntax.Sig_fail uu___2 in + { + FStarC_Syntax_Syntax.sigel = uu___1; + FStarC_Syntax_Syntax.sigrng = (s.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = (s.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = (s.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = (s.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (s.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = (s.FStarC_Syntax_Syntax.sigopts) + } + | FStarC_Syntax_Syntax.Sig_new_effect ed -> + let generalize_annotated_univs_signature s1 = + match s1 with + | FStarC_Syntax_Syntax.Layered_eff_sig (n, (uu___1, t)) -> + let uvs = + let uu___2 = FStarC_Syntax_Free.univnames t in + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_ident)) (Obj.magic uu___2) in + let usubst = FStarC_Syntax_Subst.univ_var_closing uvs in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.subst usubst t in + (uvs, uu___4) in + (n, uu___3) in + FStarC_Syntax_Syntax.Layered_eff_sig uu___2 + | FStarC_Syntax_Syntax.WP_eff_sig (uu___1, t) -> + let uvs = + let uu___2 = FStarC_Syntax_Free.univnames t in + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_ident)) (Obj.magic uu___2) in + let usubst = FStarC_Syntax_Subst.univ_var_closing uvs in + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.subst usubst t in + (uvs, uu___3) in + FStarC_Syntax_Syntax.WP_eff_sig uu___2 in + let uu___1 = + let uu___2 = + let uu___3 = + generalize_annotated_univs_signature + ed.FStarC_Syntax_Syntax.signature in + { + FStarC_Syntax_Syntax.mname = (ed.FStarC_Syntax_Syntax.mname); + FStarC_Syntax_Syntax.cattributes = + (ed.FStarC_Syntax_Syntax.cattributes); + FStarC_Syntax_Syntax.univs = (ed.FStarC_Syntax_Syntax.univs); + FStarC_Syntax_Syntax.binders = + (ed.FStarC_Syntax_Syntax.binders); + FStarC_Syntax_Syntax.signature = uu___3; + FStarC_Syntax_Syntax.combinators = + (ed.FStarC_Syntax_Syntax.combinators); + FStarC_Syntax_Syntax.actions = + (ed.FStarC_Syntax_Syntax.actions); + FStarC_Syntax_Syntax.eff_attrs = + (ed.FStarC_Syntax_Syntax.eff_attrs); + FStarC_Syntax_Syntax.extraction_mode = + (ed.FStarC_Syntax_Syntax.extraction_mode) + } in + FStarC_Syntax_Syntax.Sig_new_effect uu___2 in + { + FStarC_Syntax_Syntax.sigel = uu___1; + FStarC_Syntax_Syntax.sigrng = (s.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = (s.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = (s.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = (s.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (s.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = (s.FStarC_Syntax_Syntax.sigopts) + } + | FStarC_Syntax_Syntax.Sig_sub_effect uu___1 -> s + | FStarC_Syntax_Syntax.Sig_polymonadic_bind uu___1 -> s + | FStarC_Syntax_Syntax.Sig_polymonadic_subcomp uu___1 -> s + | FStarC_Syntax_Syntax.Sig_splice uu___1 -> s + | FStarC_Syntax_Syntax.Sig_pragma uu___1 -> s +let (is_special_effect_combinator : Prims.string -> Prims.bool) = + fun uu___ -> + match uu___ with + | "lift1" -> true + | "lift2" -> true + | "pure" -> true + | "app" -> true + | "push" -> true + | "wp_if_then_else" -> true + | "wp_assert" -> true + | "wp_assume" -> true + | "wp_close" -> true + | "stronger" -> true + | "ite_wp" -> true + | "wp_trivial" -> true + | "ctx" -> true + | "gctx" -> true + | "lift_from_pure" -> true + | "return_wp" -> true + | "return_elab" -> true + | "bind_wp" -> true + | "bind_elab" -> true + | "repr" -> true + | "post" -> true + | "pre" -> true + | "wp" -> true + | uu___1 -> false +let rec (sum_to_universe : + FStarC_Syntax_Syntax.universe -> Prims.int -> FStarC_Syntax_Syntax.universe) + = + fun u -> + fun n -> + if n = Prims.int_zero + then u + else + (let uu___1 = sum_to_universe u (n - Prims.int_one) in + FStarC_Syntax_Syntax.U_succ uu___1) +let (int_to_universe : Prims.int -> FStarC_Syntax_Syntax.universe) = + fun n -> sum_to_universe FStarC_Syntax_Syntax.U_zero n +let rec (desugar_maybe_non_constant_universe : + FStarC_Parser_AST.term -> + (Prims.int, FStarC_Syntax_Syntax.universe) FStar_Pervasives.either) + = + fun t -> + let uu___ = let uu___1 = unparen t in uu___1.FStarC_Parser_AST.tm in + match uu___ with + | FStarC_Parser_AST.Wild -> + FStar_Pervasives.Inr FStarC_Syntax_Syntax.U_unknown + | FStarC_Parser_AST.Uvar u -> + FStar_Pervasives.Inr (FStarC_Syntax_Syntax.U_name u) + | FStarC_Parser_AST.Const (FStarC_Const.Const_int (repr, uu___1)) -> + let n = FStarC_Compiler_Util.int_of_string repr in + (if n < Prims.int_zero + then + FStarC_Errors.raise_error FStarC_Parser_AST.hasRange_term t + FStarC_Errors_Codes.Fatal_NegativeUniverseConstFatal_NotSupported + () (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + (Prims.strcat + "Negative universe constant are not supported : " repr)) + else (); + FStar_Pervasives.Inl n) + | FStarC_Parser_AST.Op (op_plus, t1::t2::[]) -> + let u1 = desugar_maybe_non_constant_universe t1 in + let u2 = desugar_maybe_non_constant_universe t2 in + (match (u1, u2) with + | (FStar_Pervasives.Inl n1, FStar_Pervasives.Inl n2) -> + FStar_Pervasives.Inl (n1 + n2) + | (FStar_Pervasives.Inl n, FStar_Pervasives.Inr u) -> + let uu___2 = sum_to_universe u n in FStar_Pervasives.Inr uu___2 + | (FStar_Pervasives.Inr u, FStar_Pervasives.Inl n) -> + let uu___2 = sum_to_universe u n in FStar_Pervasives.Inr uu___2 + | (FStar_Pervasives.Inr u11, FStar_Pervasives.Inr u21) -> + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Parser_AST.showable_term t in + Prims.strcat + "This universe might contain a sum of two universe variables " + uu___3 in + FStarC_Errors.raise_error FStarC_Parser_AST.hasRange_term t + FStarC_Errors_Codes.Fatal_UniverseMightContainSumOfTwoUnivVars + () (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)) + | FStarC_Parser_AST.App uu___1 -> + let rec aux t1 univargs = + let uu___2 = let uu___3 = unparen t1 in uu___3.FStarC_Parser_AST.tm in + match uu___2 with + | FStarC_Parser_AST.App (t2, targ, uu___3) -> + let uarg = desugar_maybe_non_constant_universe targ in + aux t2 (uarg :: univargs) + | FStarC_Parser_AST.Var max_lid -> + let uu___4 = + FStarC_Compiler_List.existsb + (fun uu___5 -> + match uu___5 with + | FStar_Pervasives.Inr uu___6 -> true + | uu___6 -> false) univargs in + if uu___4 + then + let uu___5 = + let uu___6 = + FStarC_Compiler_List.map + (fun uu___7 -> + match uu___7 with + | FStar_Pervasives.Inl n -> int_to_universe n + | FStar_Pervasives.Inr u -> u) univargs in + FStarC_Syntax_Syntax.U_max uu___6 in + FStar_Pervasives.Inr uu___5 + else + (let nargs = + FStarC_Compiler_List.map + (fun uu___6 -> + match uu___6 with + | FStar_Pervasives.Inl n -> n + | FStar_Pervasives.Inr uu___7 -> + failwith "impossible") univargs in + let uu___6 = + FStarC_Compiler_List.fold_left + (fun m -> fun n -> if m > n then m else n) + Prims.int_zero nargs in + FStar_Pervasives.Inl uu___6) + | uu___3 -> + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Parser_AST.term_to_string t1 in + Prims.strcat uu___6 " in universe context" in + Prims.strcat "Unexpected term " uu___5 in + FStarC_Errors.raise_error FStarC_Parser_AST.hasRange_term t1 + FStarC_Errors_Codes.Fatal_UnexpectedTermInUniverse () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4) in + aux t [] + | uu___1 -> + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Parser_AST.term_to_string t in + Prims.strcat uu___4 " in universe context" in + Prims.strcat "Unexpected term " uu___3 in + FStarC_Errors.raise_error FStarC_Parser_AST.hasRange_term t + FStarC_Errors_Codes.Fatal_UnexpectedTermInUniverse () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2) +let (desugar_universe : + FStarC_Parser_AST.term -> FStarC_Syntax_Syntax.universe) = + fun t -> + let u = desugar_maybe_non_constant_universe t in + match u with + | FStar_Pervasives.Inl n -> int_to_universe n + | FStar_Pervasives.Inr u1 -> u1 +let (check_no_aq : antiquotations_temp -> unit) = + fun aq -> + match aq with + | [] -> () + | (bv, + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_quoted + (e, + { + FStarC_Syntax_Syntax.qkind = FStarC_Syntax_Syntax.Quote_dynamic; + FStarC_Syntax_Syntax.antiquotations = uu___;_}); + FStarC_Syntax_Syntax.pos = uu___1; + FStarC_Syntax_Syntax.vars = uu___2; + FStarC_Syntax_Syntax.hash_code = uu___3;_})::uu___4 + -> + let uu___5 = + let uu___6 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + FStarC_Compiler_Util.format1 "Unexpected antiquotation: `@(%s)" + uu___6 in + FStarC_Errors.raise_error (FStarC_Syntax_Syntax.has_range_syntax ()) + e FStarC_Errors_Codes.Fatal_UnexpectedAntiquotation () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___5) + | (bv, e)::uu___ -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + FStarC_Compiler_Util.format1 "Unexpected antiquotation: `#(%s)" + uu___2 in + FStarC_Errors.raise_error (FStarC_Syntax_Syntax.has_range_syntax ()) + e FStarC_Errors_Codes.Fatal_UnexpectedAntiquotation () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) +let (check_linear_pattern_variables : + FStarC_Syntax_Syntax.pat' FStarC_Syntax_Syntax.withinfo_t Prims.list -> + FStarC_Compiler_Range_Type.range -> unit) + = + fun pats -> + fun r -> + let rec pat_vars uu___ = + (fun p -> + match p.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_dot_term uu___ -> + Obj.magic + (Obj.repr + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Syntax.ord_bv)) ())) + | FStarC_Syntax_Syntax.Pat_constant uu___ -> + Obj.magic + (Obj.repr + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Syntax.ord_bv)) ())) + | FStarC_Syntax_Syntax.Pat_var x -> + Obj.magic + (Obj.repr + (let uu___ = + let uu___1 = + FStarC_Ident.string_of_id + x.FStarC_Syntax_Syntax.ppname in + uu___1 = FStarC_Ident.reserved_prefix in + if uu___ + then + FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Syntax.ord_bv)) () + else + FStarC_Class_Setlike.singleton () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Syntax.ord_bv)) x)) + | FStarC_Syntax_Syntax.Pat_cons (uu___, uu___1, pats1) -> + Obj.magic + (Obj.repr + (let aux uu___3 uu___2 = + (fun out -> + fun uu___2 -> + match uu___2 with + | (p1, uu___3) -> + let p_vars = pat_vars p1 in + let intersection = + Obj.magic + (FStarC_Class_Setlike.inter () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Syntax.ord_bv)) + (Obj.magic p_vars) (Obj.magic out)) in + let uu___4 = + FStarC_Class_Setlike.is_empty () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Syntax.ord_bv)) + (Obj.magic intersection) in + if uu___4 + then + Obj.magic + (Obj.repr + (FStarC_Class_Setlike.union () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Syntax.ord_bv)) + (Obj.magic out) (Obj.magic p_vars))) + else + Obj.magic + (Obj.repr + (let duplicate_bv = + let uu___6 = + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Syntax.ord_bv)) + (Obj.magic intersection) in + FStarC_Compiler_List.hd uu___6 in + let uu___6 = + let uu___7 = + FStarC_Class_Show.show + FStarC_Ident.showable_ident + duplicate_bv.FStarC_Syntax_Syntax.ppname in + FStarC_Compiler_Util.format1 + "Non-linear patterns are not permitted: `%s` appears more than once in this pattern." + uu___7 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + r + FStarC_Errors_Codes.Fatal_NonLinearPatternNotPermitted + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___6)))) uu___3 uu___2 in + let uu___2 = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Syntax.ord_bv)) ()) in + FStarC_Compiler_List.fold_left aux uu___2 pats1))) uu___ in + match pats with + | [] -> () + | p::[] -> let uu___ = pat_vars p in () + | p::ps -> + let pvars = pat_vars p in + let aux p1 = + let uu___ = + let uu___1 = pat_vars p1 in + FStarC_Class_Setlike.equal () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Syntax.ord_bv)) (Obj.magic pvars) + (Obj.magic uu___1) in + if uu___ + then () + else + (let symdiff uu___3 uu___2 = + (fun s1 -> + fun s2 -> + let uu___2 = + Obj.magic + (FStarC_Class_Setlike.diff () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Syntax.ord_bv)) + (Obj.magic s1) (Obj.magic s2)) in + let uu___3 = + Obj.magic + (FStarC_Class_Setlike.diff () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Syntax.ord_bv)) + (Obj.magic s2) (Obj.magic s1)) in + Obj.magic + (FStarC_Class_Setlike.union () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Syntax.ord_bv)) + (Obj.magic uu___2) (Obj.magic uu___3))) uu___3 + uu___2 in + let nonlinear_vars = + let uu___2 = pat_vars p1 in symdiff pvars uu___2 in + let first_nonlinear_var = + let uu___2 = + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Syntax.ord_bv)) + (Obj.magic nonlinear_vars) in + FStarC_Compiler_List.hd uu___2 in + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Ident.showable_ident + first_nonlinear_var.FStarC_Syntax_Syntax.ppname in + FStarC_Compiler_Util.format1 + "Patterns in this match are incoherent, variable %s is bound in some but not all patterns." + uu___3 in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range + r FStarC_Errors_Codes.Fatal_IncoherentPatterns () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)) in + FStarC_Compiler_List.iter aux ps +let (smt_pat_lid : FStarC_Compiler_Range_Type.range -> FStarC_Ident.lident) = + fun r -> FStarC_Ident.set_lid_range FStarC_Parser_Const.smtpat_lid r +let (smt_pat_or_lid : + FStarC_Compiler_Range_Type.range -> FStarC_Ident.lident) = + fun r -> FStarC_Ident.set_lid_range FStarC_Parser_Const.smtpatOr_lid r +let rec (hoist_pat_ascription' : + FStarC_Parser_AST.pattern -> + (FStarC_Parser_AST.pattern * FStarC_Parser_AST.term + FStar_Pervasives_Native.option)) + = + fun pat -> + let mk tm = + FStarC_Parser_AST.mk_term tm pat.FStarC_Parser_AST.prange + FStarC_Parser_AST.Type_level in + let handle_list type_lid pat_cons pats = + let uu___ = + let uu___1 = FStarC_Compiler_List.map hoist_pat_ascription' pats in + FStarC_Compiler_List.unzip uu___1 in + match uu___ with + | (pats1, terms) -> + let uu___1 = + FStarC_Compiler_List.for_all FStar_Pervasives_Native.uu___is_None + terms in + if uu___1 + then (pat, FStar_Pervasives_Native.None) + else + (let terms1 = + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with + | FStar_Pervasives_Native.Some t -> t + | FStar_Pervasives_Native.None -> + mk FStarC_Parser_AST.Wild) terms in + let uu___3 = + let uu___4 = pat_cons pats1 in + { + FStarC_Parser_AST.pat = uu___4; + FStarC_Parser_AST.prange = (pat.FStarC_Parser_AST.prange) + } in + let uu___4 = + let uu___5 = + let uu___6 = mk type_lid in + let uu___7 = + FStarC_Compiler_List.map + (fun t -> (t, FStarC_Parser_AST.Nothing)) terms1 in + FStarC_Parser_AST.mkApp uu___6 uu___7 + pat.FStarC_Parser_AST.prange in + FStar_Pervasives_Native.Some uu___5 in + (uu___3, uu___4)) in + match pat.FStarC_Parser_AST.pat with + | FStarC_Parser_AST.PatList pats -> + handle_list (FStarC_Parser_AST.Var FStarC_Parser_Const.list_lid) + (fun uu___ -> FStarC_Parser_AST.PatList uu___) pats + | FStarC_Parser_AST.PatTuple (pats, dep) -> + let uu___ = + let uu___1 = + (if dep + then FStarC_Parser_Const.mk_dtuple_lid + else FStarC_Parser_Const.mk_tuple_lid) + (FStarC_Compiler_List.length pats) pat.FStarC_Parser_AST.prange in + FStarC_Parser_AST.Var uu___1 in + handle_list uu___ + (fun pats1 -> FStarC_Parser_AST.PatTuple (pats1, dep)) pats + | FStarC_Parser_AST.PatAscribed + (pat1, (typ, FStar_Pervasives_Native.None)) -> + (pat1, (FStar_Pervasives_Native.Some typ)) + | uu___ -> (pat, FStar_Pervasives_Native.None) +let (hoist_pat_ascription : + FStarC_Parser_AST.pattern -> FStarC_Parser_AST.pattern) = + fun pat -> + let uu___ = hoist_pat_ascription' pat in + match uu___ with + | (pat1, typ) -> + (match typ with + | FStar_Pervasives_Native.Some typ1 -> + { + FStarC_Parser_AST.pat = + (FStarC_Parser_AST.PatAscribed + (pat1, (typ1, FStar_Pervasives_Native.None))); + FStarC_Parser_AST.prange = (pat1.FStarC_Parser_AST.prange) + } + | FStar_Pervasives_Native.None -> pat1) +let rec (desugar_data_pat : + Prims.bool -> + env_t -> + FStarC_Parser_AST.pattern -> + ((env_t * bnd * annotated_pat Prims.list) * antiquotations_temp)) + = + fun top_level_ascr_allowed -> + fun env -> + fun p -> + let resolvex l e x = + let uu___ = + FStarC_Compiler_Util.find_opt + (fun y -> + let uu___1 = + FStarC_Ident.string_of_id y.FStarC_Syntax_Syntax.ppname in + let uu___2 = FStarC_Ident.string_of_id x in uu___1 = uu___2) + l in + match uu___ with + | FStar_Pervasives_Native.Some y -> (l, e, y) + | uu___1 -> + let uu___2 = FStarC_Syntax_DsEnv.push_bv e x in + (match uu___2 with | (e1, xbv) -> ((xbv :: l), e1, xbv)) in + let rec aux' top loc aqs env1 p1 = + let pos q = + FStarC_Syntax_Syntax.withinfo q p1.FStarC_Parser_AST.prange in + let pos_r r q = FStarC_Syntax_Syntax.withinfo q r in + let orig = p1 in + match p1.FStarC_Parser_AST.pat with + | FStarC_Parser_AST.PatOr uu___ -> + failwith "impossible: PatOr handled below" + | FStarC_Parser_AST.PatOp op -> + let id_op = + let uu___ = + let uu___1 = + let uu___2 = FStarC_Ident.string_of_id op in + let uu___3 = FStarC_Ident.range_of_id op in + FStarC_Parser_AST.compile_op Prims.int_zero uu___2 uu___3 in + let uu___2 = FStarC_Ident.range_of_id op in + (uu___1, uu___2) in + FStarC_Ident.mk_ident uu___ in + let p2 = + { + FStarC_Parser_AST.pat = + (FStarC_Parser_AST.PatVar + (id_op, FStar_Pervasives_Native.None, [])); + FStarC_Parser_AST.prange = (p1.FStarC_Parser_AST.prange) + } in + aux loc aqs env1 p2 + | FStarC_Parser_AST.PatAscribed (p2, (t, tacopt)) -> + ((match tacopt with + | FStar_Pervasives_Native.None -> () + | FStar_Pervasives_Native.Some uu___1 -> + FStarC_Errors.raise_error + FStarC_Parser_AST.hasRange_pattern orig + FStarC_Errors_Codes.Fatal_TypeWithinPatternsAllowedOnVariablesOnly + () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Type ascriptions within patterns cannot be associated with a tactic")); + (let uu___1 = aux loc aqs env1 p2 in + match uu___1 with + | (loc1, aqs1, env', binder, p3, annots) -> + let uu___2 = + match binder with + | LetBinder uu___3 -> failwith "impossible" + | LocalBinder (x, aq, attrs) -> + let uu___3 = + let uu___4 = close_fun env1 t in + desugar_term_aq env1 uu___4 in + (match uu___3 with + | (t1, aqs') -> + let x1 = + { + FStarC_Syntax_Syntax.ppname = + (x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (x.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = t1 + } in + ([(x1, t1, attrs)], + (LocalBinder (x1, aq, attrs)), + (FStarC_Compiler_List.op_At aqs' aqs1))) in + (match uu___2 with + | (annots', binder1, aqs2) -> + ((match p3.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_var uu___4 -> () + | uu___4 when top && top_level_ascr_allowed -> () + | uu___4 -> + FStarC_Errors.raise_error + FStarC_Parser_AST.hasRange_pattern orig + FStarC_Errors_Codes.Fatal_TypeWithinPatternsAllowedOnVariablesOnly + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Type ascriptions within patterns are only allowed on variables")); + (loc1, aqs2, env', binder1, p3, + (FStarC_Compiler_List.op_At annots' annots)))))) + | FStarC_Parser_AST.PatWild (aq, attrs) -> + let aq1 = trans_bqual env1 aq in + let attrs1 = FStarC_Compiler_List.map (desugar_term env1) attrs in + let x = + let uu___ = tun_r p1.FStarC_Parser_AST.prange in + FStarC_Syntax_Syntax.new_bv + (FStar_Pervasives_Native.Some (p1.FStarC_Parser_AST.prange)) + uu___ in + let uu___ = pos (FStarC_Syntax_Syntax.Pat_var x) in + (loc, aqs, env1, (LocalBinder (x, aq1, attrs1)), uu___, []) + | FStarC_Parser_AST.PatConst c -> + let x = + let uu___ = tun_r p1.FStarC_Parser_AST.prange in + FStarC_Syntax_Syntax.new_bv + (FStar_Pervasives_Native.Some (p1.FStarC_Parser_AST.prange)) + uu___ in + let uu___ = pos (FStarC_Syntax_Syntax.Pat_constant c) in + (loc, aqs, env1, + (LocalBinder (x, FStar_Pervasives_Native.None, [])), uu___, + []) + | FStarC_Parser_AST.PatVQuote e -> + let pat = + let uu___ = + let uu___1 = + let uu___2 = + desugar_vquote env1 e p1.FStarC_Parser_AST.prange in + (uu___2, (p1.FStarC_Parser_AST.prange)) in + FStarC_Const.Const_string uu___1 in + FStarC_Parser_AST.PatConst uu___ in + aux' top loc aqs env1 + { + FStarC_Parser_AST.pat = pat; + FStarC_Parser_AST.prange = (p1.FStarC_Parser_AST.prange) + } + | FStarC_Parser_AST.PatTvar (x, aq, attrs) -> + let aq1 = trans_bqual env1 aq in + let attrs1 = FStarC_Compiler_List.map (desugar_term env1) attrs in + let uu___ = resolvex loc env1 x in + (match uu___ with + | (loc1, env2, xbv) -> + let uu___1 = pos (FStarC_Syntax_Syntax.Pat_var xbv) in + (loc1, aqs, env2, (LocalBinder (xbv, aq1, attrs1)), + uu___1, [])) + | FStarC_Parser_AST.PatVar (x, aq, attrs) -> + let aq1 = trans_bqual env1 aq in + let attrs1 = FStarC_Compiler_List.map (desugar_term env1) attrs in + let uu___ = resolvex loc env1 x in + (match uu___ with + | (loc1, env2, xbv) -> + let uu___1 = pos (FStarC_Syntax_Syntax.Pat_var xbv) in + (loc1, aqs, env2, (LocalBinder (xbv, aq1, attrs1)), + uu___1, [])) + | FStarC_Parser_AST.PatName l -> + let l1 = + FStarC_Syntax_DsEnv.fail_or env1 + (FStarC_Syntax_DsEnv.try_lookup_datacon env1) l in + let x = + let uu___ = tun_r p1.FStarC_Parser_AST.prange in + FStarC_Syntax_Syntax.new_bv + (FStar_Pervasives_Native.Some (p1.FStarC_Parser_AST.prange)) + uu___ in + let uu___ = + pos + (FStarC_Syntax_Syntax.Pat_cons + (l1, FStar_Pervasives_Native.None, [])) in + (loc, aqs, env1, + (LocalBinder (x, FStar_Pervasives_Native.None, [])), uu___, + []) + | FStarC_Parser_AST.PatApp + ({ FStarC_Parser_AST.pat = FStarC_Parser_AST.PatName l; + FStarC_Parser_AST.prange = uu___;_}, + args) + -> + let uu___1 = + FStarC_Compiler_List.fold_right + (fun arg -> + fun uu___2 -> + match uu___2 with + | (loc1, aqs1, env2, annots, args1) -> + let uu___3 = aux loc1 aqs1 env2 arg in + (match uu___3 with + | (loc2, aqs2, env3, b, arg1, ans) -> + let imp = is_implicit b in + (loc2, aqs2, env3, + (FStarC_Compiler_List.op_At ans annots), + ((arg1, imp) :: args1)))) args + (loc, aqs, env1, [], []) in + (match uu___1 with + | (loc1, aqs1, env2, annots, args1) -> + let l1 = + FStarC_Syntax_DsEnv.fail_or env2 + (FStarC_Syntax_DsEnv.try_lookup_datacon env2) l in + let x = + let uu___2 = tun_r p1.FStarC_Parser_AST.prange in + FStarC_Syntax_Syntax.new_bv + (FStar_Pervasives_Native.Some + (p1.FStarC_Parser_AST.prange)) uu___2 in + let uu___2 = + pos + (FStarC_Syntax_Syntax.Pat_cons + (l1, FStar_Pervasives_Native.None, args1)) in + (loc1, aqs1, env2, + (LocalBinder (x, FStar_Pervasives_Native.None, [])), + uu___2, annots)) + | FStarC_Parser_AST.PatApp uu___ -> + FStarC_Errors.raise_error FStarC_Parser_AST.hasRange_pattern p1 + FStarC_Errors_Codes.Fatal_UnexpectedPattern () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "Unexpected pattern") + | FStarC_Parser_AST.PatList pats -> + let uu___ = + FStarC_Compiler_List.fold_right + (fun pat -> + fun uu___1 -> + match uu___1 with + | (loc1, aqs1, env2, annots, pats1) -> + let uu___2 = aux loc1 aqs1 env2 pat in + (match uu___2 with + | (loc2, aqs2, env3, uu___3, pat1, ans) -> + (loc2, aqs2, env3, + (FStarC_Compiler_List.op_At ans annots), + (pat1 :: pats1)))) pats + (loc, aqs, env1, [], []) in + (match uu___ with + | (loc1, aqs1, env2, annots, pats1) -> + let pat = + let uu___1 = + let uu___2 = + FStarC_Compiler_Range_Ops.end_range + p1.FStarC_Parser_AST.prange in + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Syntax_Syntax.lid_and_dd_as_fv + FStarC_Parser_Const.nil_lid + (FStar_Pervasives_Native.Some + FStarC_Syntax_Syntax.Data_ctor) in + (uu___5, FStar_Pervasives_Native.None, []) in + FStarC_Syntax_Syntax.Pat_cons uu___4 in + pos_r uu___2 uu___3 in + FStarC_Compiler_List.fold_right + (fun hd -> + fun tl -> + let r = + FStarC_Compiler_Range_Ops.union_ranges + hd.FStarC_Syntax_Syntax.p + tl.FStarC_Syntax_Syntax.p in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Syntax_Syntax.lid_and_dd_as_fv + FStarC_Parser_Const.cons_lid + (FStar_Pervasives_Native.Some + FStarC_Syntax_Syntax.Data_ctor) in + (uu___4, FStar_Pervasives_Native.None, + [(hd, false); (tl, false)]) in + FStarC_Syntax_Syntax.Pat_cons uu___3 in + pos_r r uu___2) pats1 uu___1 in + let x = + let uu___1 = tun_r p1.FStarC_Parser_AST.prange in + FStarC_Syntax_Syntax.new_bv + (FStar_Pervasives_Native.Some + (p1.FStarC_Parser_AST.prange)) uu___1 in + (loc1, aqs1, env2, + (LocalBinder (x, FStar_Pervasives_Native.None, [])), + pat, annots)) + | FStarC_Parser_AST.PatTuple (args, dep) -> + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun p2 -> + match uu___1 with + | (loc1, aqs1, env2, annots, pats) -> + let uu___2 = aux loc1 aqs1 env2 p2 in + (match uu___2 with + | (loc2, aqs2, env3, uu___3, pat, ans) -> + (loc2, aqs2, env3, + (FStarC_Compiler_List.op_At ans annots), + ((pat, false) :: pats)))) + (loc, aqs, env1, [], []) args in + (match uu___ with + | (loc1, aqs1, env2, annots, args1) -> + let args2 = FStarC_Compiler_List.rev args1 in + let l = + if dep + then + FStarC_Parser_Const.mk_dtuple_data_lid + (FStarC_Compiler_List.length args2) + p1.FStarC_Parser_AST.prange + else + FStarC_Parser_Const.mk_tuple_data_lid + (FStarC_Compiler_List.length args2) + p1.FStarC_Parser_AST.prange in + let constr = + FStarC_Syntax_DsEnv.fail_or env2 + (FStarC_Syntax_DsEnv.try_lookup_lid env2) l in + let l1 = + match constr.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_fvar fv -> fv + | uu___1 -> failwith "impossible" in + let x = + let uu___1 = tun_r p1.FStarC_Parser_AST.prange in + FStarC_Syntax_Syntax.new_bv + (FStar_Pervasives_Native.Some + (p1.FStarC_Parser_AST.prange)) uu___1 in + let uu___1 = + pos + (FStarC_Syntax_Syntax.Pat_cons + (l1, FStar_Pervasives_Native.None, args2)) in + (loc1, aqs1, env2, + (LocalBinder (x, FStar_Pervasives_Native.None, [])), + uu___1, annots)) + | FStarC_Parser_AST.PatRecord fields -> + let uu___ = FStarC_Compiler_List.unzip fields in + (match uu___ with + | (field_names, pats) -> + let uu___1 = + match fields with + | [] -> (FStar_Pervasives_Native.None, field_names) + | (f, uu___2)::uu___3 -> + let uu___4 = + FStarC_Syntax_DsEnv.try_lookup_record_by_field_name + env1 f in + (match uu___4 with + | FStar_Pervasives_Native.None -> + (FStar_Pervasives_Native.None, field_names) + | FStar_Pervasives_Native.Some r -> + let uu___5 = + qualify_field_names + r.FStarC_Syntax_DsEnv.typename field_names in + ((FStar_Pervasives_Native.Some + (r.FStarC_Syntax_DsEnv.typename)), uu___5)) in + (match uu___1 with + | (typename, field_names1) -> + let candidate_constructor = + let lid = + FStarC_Ident.lid_of_path ["__dummy__"] + p1.FStarC_Parser_AST.prange in + FStarC_Syntax_Syntax.lid_and_dd_as_fv lid + (FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Unresolved_constructor + { + FStarC_Syntax_Syntax.uc_base_term = false; + FStarC_Syntax_Syntax.uc_typename = + typename; + FStarC_Syntax_Syntax.uc_fields = + field_names1 + })) in + let uu___2 = + FStarC_Compiler_List.fold_left + (fun uu___3 -> + fun p2 -> + match uu___3 with + | (loc1, aqs1, env2, annots, pats1) -> + let uu___4 = aux loc1 aqs1 env2 p2 in + (match uu___4 with + | (loc2, aqs2, env3, uu___5, pat, ann) + -> + (loc2, aqs2, env3, + (FStarC_Compiler_List.op_At ann + annots), ((pat, false) :: + pats1)))) + (loc, aqs, env1, [], []) pats in + (match uu___2 with + | (loc1, aqs1, env2, annots, pats1) -> + let pats2 = FStarC_Compiler_List.rev pats1 in + let pat = + pos + (FStarC_Syntax_Syntax.Pat_cons + (candidate_constructor, + FStar_Pervasives_Native.None, pats2)) in + let x = + let uu___3 = tun_r p1.FStarC_Parser_AST.prange in + FStarC_Syntax_Syntax.new_bv + (FStar_Pervasives_Native.Some + (p1.FStarC_Parser_AST.prange)) uu___3 in + (loc1, aqs1, env2, + (LocalBinder + (x, FStar_Pervasives_Native.None, [])), + pat, annots)))) + and aux loc aqs env1 p1 = aux' false loc aqs env1 p1 in + let aux_maybe_or env1 p1 = + let loc = [] in + match p1.FStarC_Parser_AST.pat with + | FStarC_Parser_AST.PatOr [] -> failwith "impossible" + | FStarC_Parser_AST.PatOr (p2::ps) -> + let uu___ = aux' true loc [] env1 p2 in + (match uu___ with + | (loc1, aqs, env2, var, p3, ans) -> + let uu___1 = + FStarC_Compiler_List.fold_left + (fun uu___2 -> + fun p4 -> + match uu___2 with + | (loc2, aqs1, env3, ps1) -> + let uu___3 = aux' true loc2 aqs1 env3 p4 in + (match uu___3 with + | (loc3, aqs2, env4, uu___4, p5, ans1) -> + (loc3, aqs2, env4, ((p5, ans1) :: ps1)))) + (loc1, aqs, env2, []) ps in + (match uu___1 with + | (loc2, aqs1, env3, ps1) -> + let pats = (p3, ans) :: + (FStarC_Compiler_List.rev ps1) in + ((env3, var, pats), aqs1))) + | uu___ -> + let uu___1 = aux' true loc [] env1 p1 in + (match uu___1 with + | (loc1, aqs, env2, var, pat, ans) -> + ((env2, var, [(pat, ans)]), aqs)) in + let uu___ = aux_maybe_or env p in + match uu___ with + | ((env1, b, pats), aqs) -> + ((let uu___2 = + FStarC_Compiler_List.map FStar_Pervasives_Native.fst pats in + check_linear_pattern_variables uu___2 + p.FStarC_Parser_AST.prange); + ((env1, b, pats), aqs)) +and (desugar_binding_pat_maybe_top : + Prims.bool -> + FStarC_Syntax_DsEnv.env -> + FStarC_Parser_AST.pattern -> + ((env_t * bnd * annotated_pat Prims.list) * antiquotations_temp)) + = + fun top -> + fun env -> + fun p -> + if top + then + let mklet x ty tacopt = + let uu___ = + let uu___1 = + let uu___2 = FStarC_Syntax_DsEnv.qualify env x in + (uu___2, (ty, tacopt)) in + LetBinder uu___1 in + (env, uu___, []) in + let op_to_ident x = + let uu___ = + let uu___1 = + let uu___2 = FStarC_Ident.string_of_id x in + let uu___3 = FStarC_Ident.range_of_id x in + FStarC_Parser_AST.compile_op Prims.int_zero uu___2 uu___3 in + let uu___2 = FStarC_Ident.range_of_id x in (uu___1, uu___2) in + FStarC_Ident.mk_ident uu___ in + match p.FStarC_Parser_AST.pat with + | FStarC_Parser_AST.PatOp x -> + let uu___ = + let uu___1 = op_to_ident x in + let uu___2 = + let uu___3 = FStarC_Ident.range_of_id x in tun_r uu___3 in + mklet uu___1 uu___2 FStar_Pervasives_Native.None in + (uu___, []) + | FStarC_Parser_AST.PatVar (x, uu___, uu___1) -> + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Ident.range_of_id x in tun_r uu___4 in + mklet x uu___3 FStar_Pervasives_Native.None in + (uu___2, []) + | FStarC_Parser_AST.PatAscribed + ({ FStarC_Parser_AST.pat = FStarC_Parser_AST.PatOp x; + FStarC_Parser_AST.prange = uu___;_}, + (t, tacopt)) + -> + let tacopt1 = + FStarC_Compiler_Util.map_opt tacopt (desugar_term env) in + let uu___1 = desugar_term_aq env t in + (match uu___1 with + | (t1, aq) -> + let uu___2 = + let uu___3 = op_to_ident x in mklet uu___3 t1 tacopt1 in + (uu___2, aq)) + | FStarC_Parser_AST.PatAscribed + ({ + FStarC_Parser_AST.pat = FStarC_Parser_AST.PatVar + (x, uu___, uu___1); + FStarC_Parser_AST.prange = uu___2;_}, + (t, tacopt)) + -> + let tacopt1 = + FStarC_Compiler_Util.map_opt tacopt (desugar_term env) in + let uu___3 = desugar_term_aq env t in + (match uu___3 with + | (t1, aq) -> let uu___4 = mklet x t1 tacopt1 in (uu___4, aq)) + | uu___ -> + FStarC_Errors.raise_error FStarC_Parser_AST.hasRange_pattern p + FStarC_Errors_Codes.Fatal_UnexpectedPattern () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "Unexpected pattern at the top-level") + else + (let uu___1 = desugar_data_pat true env p in + match uu___1 with + | ((env1, binder, p1), aq) -> + let p2 = + match p1 with + | ({ + FStarC_Syntax_Syntax.v = FStarC_Syntax_Syntax.Pat_var + uu___2; + FStarC_Syntax_Syntax.p = uu___3;_}, + uu___4)::[] -> [] + | uu___2 -> p1 in + ((env1, binder, p2), aq)) +and (desugar_binding_pat_aq : + FStarC_Syntax_DsEnv.env -> + FStarC_Parser_AST.pattern -> + ((env_t * bnd * annotated_pat Prims.list) * antiquotations_temp)) + = fun env -> fun p -> desugar_binding_pat_maybe_top false env p +and (desugar_match_pat_maybe_top : + Prims.bool -> + env_t -> + FStarC_Parser_AST.pattern -> + ((env_t * annotated_pat Prims.list) * antiquotations_temp)) + = + fun uu___ -> + fun env -> + fun pat -> + let uu___1 = desugar_data_pat false env pat in + match uu___1 with + | ((env1, uu___2, pat1), aqs) -> ((env1, pat1), aqs) +and (desugar_match_pat : + env_t -> + FStarC_Parser_AST.pattern -> + ((env_t * annotated_pat Prims.list) * antiquotations_temp)) + = fun env -> fun p -> desugar_match_pat_maybe_top false env p +and (desugar_term_aq : + env_t -> + FStarC_Parser_AST.term -> + (FStarC_Syntax_Syntax.term * antiquotations_temp)) + = + fun env -> + fun e -> + let env1 = FStarC_Syntax_DsEnv.set_expect_typ env false in + desugar_term_maybe_top false env1 e +and (desugar_term : + FStarC_Syntax_DsEnv.env -> + FStarC_Parser_AST.term -> FStarC_Syntax_Syntax.term) + = + fun env -> + fun e -> + let uu___ = desugar_term_aq env e in + match uu___ with | (t, aq) -> (check_no_aq aq; t) +and (desugar_typ_aq : + FStarC_Syntax_DsEnv.env -> + FStarC_Parser_AST.term -> + (FStarC_Syntax_Syntax.term * antiquotations_temp)) + = + fun env -> + fun e -> + let env1 = FStarC_Syntax_DsEnv.set_expect_typ env true in + desugar_term_maybe_top false env1 e +and (desugar_typ : + FStarC_Syntax_DsEnv.env -> + FStarC_Parser_AST.term -> FStarC_Syntax_Syntax.term) + = + fun env -> + fun e -> + let uu___ = desugar_typ_aq env e in + match uu___ with | (t, aq) -> (check_no_aq aq; t) +and (desugar_machine_integer : + FStarC_Syntax_DsEnv.env -> + Prims.string -> + (FStarC_Const.signedness * FStarC_Const.width) -> + FStarC_Compiler_Range_Type.range -> FStarC_Syntax_Syntax.term) + = + fun env -> + fun repr -> + fun uu___ -> + fun range -> + match uu___ with + | (signedness, width) -> + let tnm = + if width = FStarC_Const.Sizet + then "FStar.SizeT" + else + Prims.strcat "FStar." + (Prims.strcat + (match signedness with + | FStarC_Const.Unsigned -> "U" + | FStarC_Const.Signed -> "") + (Prims.strcat "Int" + (match width with + | FStarC_Const.Int8 -> "8" + | FStarC_Const.Int16 -> "16" + | FStarC_Const.Int32 -> "32" + | FStarC_Const.Int64 -> "64"))) in + ((let uu___2 = + let uu___3 = + FStarC_Const.within_bounds repr signedness width in + Prims.op_Negation uu___3 in + if uu___2 + then + let uu___3 = + FStarC_Compiler_Util.format2 + "%s is not in the expected range for %s" repr tnm in + FStarC_Errors.log_issue + FStarC_Class_HasRange.hasRange_range range + FStarC_Errors_Codes.Error_OutOfRange () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___3) + else ()); + (let private_intro_nm = + Prims.strcat tnm + (Prims.strcat ".__" + (Prims.strcat + (match signedness with + | FStarC_Const.Unsigned -> "u" + | FStarC_Const.Signed -> "") "int_to_t")) in + let intro_nm = + Prims.strcat tnm + (Prims.strcat "." + (Prims.strcat + (match signedness with + | FStarC_Const.Unsigned -> "u" + | FStarC_Const.Signed -> "") "int_to_t")) in + let lid = + let uu___2 = FStarC_Ident.path_of_text intro_nm in + FStarC_Ident.lid_of_path uu___2 range in + let lid1 = + let uu___2 = FStarC_Syntax_DsEnv.try_lookup_lid env lid in + match uu___2 with + | FStar_Pervasives_Native.Some intro_term -> + (match intro_term.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let private_lid = + let uu___3 = + FStarC_Ident.path_of_text private_intro_nm in + FStarC_Ident.lid_of_path uu___3 range in + let private_fv = + FStarC_Syntax_Syntax.lid_and_dd_as_fv + private_lid fv.FStarC_Syntax_Syntax.fv_qual in + { + FStarC_Syntax_Syntax.n = + (FStarC_Syntax_Syntax.Tm_fvar private_fv); + FStarC_Syntax_Syntax.pos = + (intro_term.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = + (intro_term.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (intro_term.FStarC_Syntax_Syntax.hash_code) + } + | uu___3 -> + failwith + (Prims.strcat "Unexpected non-fvar for " + intro_nm)) + | FStar_Pervasives_Native.None -> + let uu___3 = + FStarC_Compiler_Util.format1 + "Unexpected numeric literal. Restart F* to load %s." + tnm in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range range + FStarC_Errors_Codes.Fatal_UnexpectedNumericLiteral () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___3) in + let repr' = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_int + (repr, FStar_Pervasives_Native.None))) range in + let app = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.as_aqual_implicit false in + (repr', uu___6) in + [uu___5] in + { + FStarC_Syntax_Syntax.hd = lid1; + FStarC_Syntax_Syntax.args = uu___4 + } in + FStarC_Syntax_Syntax.Tm_app uu___3 in + FStarC_Syntax_Syntax.mk uu___2 range in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 = app; + FStarC_Syntax_Syntax.meta = + (FStarC_Syntax_Syntax.Meta_desugared + (FStarC_Syntax_Syntax.Machine_integer + (signedness, width))) + }) range)) +and (desugar_term_maybe_top : + Prims.bool -> + env_t -> + FStarC_Parser_AST.term -> + (FStarC_Syntax_Syntax.term * antiquotations_temp)) + = + fun top_level -> + fun env -> + fun top -> + let mk e = FStarC_Syntax_Syntax.mk e top.FStarC_Parser_AST.range in + let noaqs = [] in + let join_aqs aqs = FStarC_Compiler_List.flatten aqs in + let setpos e = + { + FStarC_Syntax_Syntax.n = (e.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = (top.FStarC_Parser_AST.range); + FStarC_Syntax_Syntax.vars = (e.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (e.FStarC_Syntax_Syntax.hash_code) + } in + let desugar_binders env1 binders = + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun b -> + match uu___1 with + | (env2, bs) -> + let bb = desugar_binder env2 b in + let uu___2 = + as_binder env2 b.FStarC_Parser_AST.aqual bb in + (match uu___2 with | (b1, env3) -> (env3, (b1 :: bs)))) + (env1, []) binders in + match uu___ with + | (env2, bs_rev) -> (env2, (FStarC_Compiler_List.rev bs_rev)) in + let unqual_bv_of_binder b = + match b with + | { FStarC_Syntax_Syntax.binder_bv = x; + FStarC_Syntax_Syntax.binder_qual = FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.binder_positivity = uu___; + FStarC_Syntax_Syntax.binder_attrs = [];_} -> x + | uu___ -> + FStarC_Errors.raise_error FStarC_Syntax_Syntax.hasRange_binder + b FStarC_Errors_Codes.Fatal_UnexpectedTerm () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "Unexpected qualified binder in ELIM_EXISTS") in + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_ToSyntax in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show FStarC_Parser_AST.showable_term top in + FStarC_Compiler_Util.print1 "desugaring (%s)\n\n" uu___2 + else ()); + (let uu___1 = let uu___2 = unparen top in uu___2.FStarC_Parser_AST.tm in + match uu___1 with + | FStarC_Parser_AST.Wild -> + ((setpos FStarC_Syntax_Syntax.tun), noaqs) + | FStarC_Parser_AST.Labeled uu___2 -> + let uu___3 = desugar_formula env top in (uu___3, noaqs) + | FStarC_Parser_AST.Requires (t, lopt) -> + let uu___2 = desugar_formula env t in (uu___2, noaqs) + | FStarC_Parser_AST.Ensures (t, lopt) -> + let uu___2 = desugar_formula env t in (uu___2, noaqs) + | FStarC_Parser_AST.Attributes ts -> + failwith + "Attributes should not be desugared by desugar_term_maybe_top" + | FStarC_Parser_AST.Const (FStarC_Const.Const_int + (i, FStar_Pervasives_Native.Some size)) -> + let uu___2 = + desugar_machine_integer env i size top.FStarC_Parser_AST.range in + (uu___2, noaqs) + | FStarC_Parser_AST.Const c -> + let uu___2 = mk (FStarC_Syntax_Syntax.Tm_constant c) in + (uu___2, noaqs) + | FStarC_Parser_AST.Op (id, args) when + let uu___2 = FStarC_Ident.string_of_id id in uu___2 = "=!=" -> + let r = FStarC_Ident.range_of_id id in + let e = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Ident.mk_ident ("==", r) in + (uu___4, args) in + FStarC_Parser_AST.Op uu___3 in + FStarC_Parser_AST.mk_term uu___2 top.FStarC_Parser_AST.range + top.FStarC_Parser_AST.level in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Ident.mk_ident ("~", r) in + (uu___5, [e]) in + FStarC_Parser_AST.Op uu___4 in + FStarC_Parser_AST.mk_term uu___3 top.FStarC_Parser_AST.range + top.FStarC_Parser_AST.level in + desugar_term_aq env uu___2 + | FStarC_Parser_AST.Op (op_star, lhs::rhs::[]) when + (let uu___2 = FStarC_Ident.string_of_id op_star in uu___2 = "*") + && + (let uu___2 = op_as_term env (Prims.of_int (2)) op_star in + FStarC_Compiler_Option.isNone uu___2) + -> + let rec flatten t = + match t.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Op (id, t1::t2::[]) when + (let uu___2 = FStarC_Ident.string_of_id id in uu___2 = "*") + && + (let uu___2 = op_as_term env (Prims.of_int (2)) op_star in + FStarC_Compiler_Option.isNone uu___2) + -> + let uu___2 = flatten t1 in + FStarC_Compiler_List.op_At uu___2 [t2] + | uu___2 -> [t] in + let terms = flatten lhs in + let t = + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Compiler_List.map + (fun uu___5 -> FStar_Pervasives.Inr uu___5) terms in + (uu___4, rhs) in + FStarC_Parser_AST.Sum uu___3 in + { + FStarC_Parser_AST.tm = uu___2; + FStarC_Parser_AST.range = (top.FStarC_Parser_AST.range); + FStarC_Parser_AST.level = (top.FStarC_Parser_AST.level) + } in + desugar_term_maybe_top top_level env t + | FStarC_Parser_AST.Tvar a -> + let uu___2 = + let uu___3 = + FStarC_Syntax_DsEnv.fail_or2 + (FStarC_Syntax_DsEnv.try_lookup_id env) a in + setpos uu___3 in + (uu___2, noaqs) + | FStarC_Parser_AST.Uvar u -> + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Ident.string_of_id u in + Prims.strcat uu___4 " in non-universe context" in + Prims.strcat "Unexpected universe variable " uu___3 in + FStarC_Errors.raise_error FStarC_Parser_AST.hasRange_term top + FStarC_Errors_Codes.Fatal_UnexpectedUniverseVariable () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2) + | FStarC_Parser_AST.Op (s, f::e::[]) when + let uu___2 = FStarC_Ident.string_of_id s in uu___2 = "<|" -> + let uu___2 = + FStarC_Parser_AST.mkApp f [(e, FStarC_Parser_AST.Nothing)] + top.FStarC_Parser_AST.range in + desugar_term_maybe_top top_level env uu___2 + | FStarC_Parser_AST.Op (s, e::f::[]) when + let uu___2 = FStarC_Ident.string_of_id s in uu___2 = "|>" -> + let uu___2 = + FStarC_Parser_AST.mkApp f [(e, FStarC_Parser_AST.Nothing)] + top.FStarC_Parser_AST.range in + desugar_term_maybe_top top_level env uu___2 + | FStarC_Parser_AST.Op (s, args) -> + let uu___2 = op_as_term env (FStarC_Compiler_List.length args) s in + (match uu___2 with + | FStar_Pervasives_Native.None -> + let uu___3 = + let uu___4 = FStarC_Ident.string_of_id s in + Prims.strcat "Unexpected or unbound operator: " uu___4 in + FStarC_Errors.raise_error FStarC_Ident.hasrange_ident s + FStarC_Errors_Codes.Fatal_UnepxectedOrUnboundOperator () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___3) + | FStar_Pervasives_Native.Some op -> + if (FStarC_Compiler_List.length args) > Prims.int_zero + then + let uu___3 = + let uu___4 = + FStarC_Compiler_List.map + (fun t -> + let uu___5 = desugar_term_aq env t in + match uu___5 with + | (t', s1) -> + ((t', FStar_Pervasives_Native.None), s1)) + args in + FStarC_Compiler_List.unzip uu___4 in + (match uu___3 with + | (args1, aqs) -> + let uu___4 = + mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = op; + FStarC_Syntax_Syntax.args = args1 + }) in + (uu___4, (join_aqs aqs))) + else (op, noaqs)) + | FStarC_Parser_AST.Construct (n, (a, uu___2)::[]) when + let uu___3 = FStarC_Ident.string_of_lid n in uu___3 = "SMTPat" + -> + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = smt_pat_lid top.FStarC_Parser_AST.range in + FStarC_Parser_AST.Var uu___8 in + { + FStarC_Parser_AST.tm = uu___7; + FStarC_Parser_AST.range = + (top.FStarC_Parser_AST.range); + FStarC_Parser_AST.level = + (top.FStarC_Parser_AST.level) + } in + (uu___6, a, FStarC_Parser_AST.Nothing) in + FStarC_Parser_AST.App uu___5 in + { + FStarC_Parser_AST.tm = uu___4; + FStarC_Parser_AST.range = (top.FStarC_Parser_AST.range); + FStarC_Parser_AST.level = (top.FStarC_Parser_AST.level) + } in + desugar_term_maybe_top top_level env uu___3 + | FStarC_Parser_AST.Construct (n, (a, uu___2)::[]) when + let uu___3 = FStarC_Ident.string_of_lid n in uu___3 = "SMTPatT" + -> + (FStarC_Errors.log_issue FStarC_Parser_AST.hasRange_term top + FStarC_Errors_Codes.Warning_SMTPatTDeprecated () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "SMTPatT is deprecated; please just use SMTPat"); + (let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = smt_pat_lid top.FStarC_Parser_AST.range in + FStarC_Parser_AST.Var uu___9 in + { + FStarC_Parser_AST.tm = uu___8; + FStarC_Parser_AST.range = + (top.FStarC_Parser_AST.range); + FStarC_Parser_AST.level = + (top.FStarC_Parser_AST.level) + } in + (uu___7, a, FStarC_Parser_AST.Nothing) in + FStarC_Parser_AST.App uu___6 in + { + FStarC_Parser_AST.tm = uu___5; + FStarC_Parser_AST.range = (top.FStarC_Parser_AST.range); + FStarC_Parser_AST.level = (top.FStarC_Parser_AST.level) + } in + desugar_term_maybe_top top_level env uu___4)) + | FStarC_Parser_AST.Construct (n, (a, uu___2)::[]) when + let uu___3 = FStarC_Ident.string_of_lid n in uu___3 = "SMTPatOr" + -> + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + smt_pat_or_lid top.FStarC_Parser_AST.range in + FStarC_Parser_AST.Var uu___8 in + { + FStarC_Parser_AST.tm = uu___7; + FStarC_Parser_AST.range = + (top.FStarC_Parser_AST.range); + FStarC_Parser_AST.level = + (top.FStarC_Parser_AST.level) + } in + (uu___6, a, FStarC_Parser_AST.Nothing) in + FStarC_Parser_AST.App uu___5 in + { + FStarC_Parser_AST.tm = uu___4; + FStarC_Parser_AST.range = (top.FStarC_Parser_AST.range); + FStarC_Parser_AST.level = (top.FStarC_Parser_AST.level) + } in + desugar_term_maybe_top top_level env uu___3 + | FStarC_Parser_AST.Name lid when + let uu___2 = FStarC_Ident.string_of_lid lid in uu___2 = "Type0" + -> + let uu___2 = + mk (FStarC_Syntax_Syntax.Tm_type FStarC_Syntax_Syntax.U_zero) in + (uu___2, noaqs) + | FStarC_Parser_AST.Name lid when + let uu___2 = FStarC_Ident.string_of_lid lid in uu___2 = "Type" + -> + let uu___2 = + mk + (FStarC_Syntax_Syntax.Tm_type FStarC_Syntax_Syntax.U_unknown) in + (uu___2, noaqs) + | FStarC_Parser_AST.Construct + (lid, (t, FStarC_Parser_AST.UnivApp)::[]) when + let uu___2 = FStarC_Ident.string_of_lid lid in uu___2 = "Type" + -> + let uu___2 = + let uu___3 = + let uu___4 = desugar_universe t in + FStarC_Syntax_Syntax.Tm_type uu___4 in + mk uu___3 in + (uu___2, noaqs) + | FStarC_Parser_AST.Name lid when + let uu___2 = FStarC_Ident.string_of_lid lid in uu___2 = "Effect" + -> + let uu___2 = + mk + (FStarC_Syntax_Syntax.Tm_constant FStarC_Const.Const_effect) in + (uu___2, noaqs) + | FStarC_Parser_AST.Name lid when + let uu___2 = FStarC_Ident.string_of_lid lid in uu___2 = "True" + -> + let uu___2 = + let uu___3 = + FStarC_Ident.set_lid_range FStarC_Parser_Const.true_lid + top.FStarC_Parser_AST.range in + FStarC_Syntax_Syntax.fvar_with_dd uu___3 + FStar_Pervasives_Native.None in + (uu___2, noaqs) + | FStarC_Parser_AST.Name lid when + let uu___2 = FStarC_Ident.string_of_lid lid in uu___2 = "False" + -> + let uu___2 = + let uu___3 = + FStarC_Ident.set_lid_range FStarC_Parser_Const.false_lid + top.FStarC_Parser_AST.range in + FStarC_Syntax_Syntax.fvar_with_dd uu___3 + FStar_Pervasives_Native.None in + (uu___2, noaqs) + | FStarC_Parser_AST.Projector (eff_name, id) when + (let uu___2 = FStarC_Ident.string_of_id id in + is_special_effect_combinator uu___2) && + (FStarC_Syntax_DsEnv.is_effect_name env eff_name) + -> + let txt = FStarC_Ident.string_of_id id in + let uu___2 = + FStarC_Syntax_DsEnv.try_lookup_effect_defn env eff_name in + (match uu___2 with + | FStar_Pervasives_Native.Some ed -> + let lid = FStarC_Syntax_Util.dm4f_lid ed txt in + let uu___3 = + FStarC_Syntax_Syntax.fvar_with_dd lid + FStar_Pervasives_Native.None in + (uu___3, noaqs) + | FStar_Pervasives_Native.None -> + let uu___3 = + let uu___4 = FStarC_Ident.string_of_lid eff_name in + FStarC_Compiler_Util.format2 + "Member %s of effect %s is not accessible (using an effect abbreviation instead of the original effect ?)" + uu___4 txt in + failwith uu___3) + | FStarC_Parser_AST.Var l -> + let uu___2 = desugar_name mk setpos env true l in + (uu___2, noaqs) + | FStarC_Parser_AST.Name l -> + let uu___2 = desugar_name mk setpos env true l in + (uu___2, noaqs) + | FStarC_Parser_AST.Projector (l, i) -> + let name = + let uu___2 = FStarC_Syntax_DsEnv.try_lookup_datacon env l in + match uu___2 with + | FStar_Pervasives_Native.Some uu___3 -> + FStar_Pervasives_Native.Some (true, l) + | FStar_Pervasives_Native.None -> + let uu___3 = + FStarC_Syntax_DsEnv.try_lookup_root_effect_name env l in + (match uu___3 with + | FStar_Pervasives_Native.Some new_name -> + FStar_Pervasives_Native.Some (false, new_name) + | uu___4 -> FStar_Pervasives_Native.None) in + (match name with + | FStar_Pervasives_Native.Some (resolve, new_name) -> + let uu___2 = + let uu___3 = + FStarC_Syntax_Util.mk_field_projector_name_from_ident + new_name i in + desugar_name mk setpos env resolve uu___3 in + (uu___2, noaqs) + | uu___2 -> + let uu___3 = + let uu___4 = FStarC_Ident.string_of_lid l in + FStarC_Compiler_Util.format1 + "Data constructor or effect %s not found" uu___4 in + FStarC_Errors.raise_error FStarC_Parser_AST.hasRange_term + top FStarC_Errors_Codes.Fatal_EffectNotFound () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___3)) + | FStarC_Parser_AST.Discrim lid -> + let uu___2 = FStarC_Syntax_DsEnv.try_lookup_datacon env lid in + (match uu___2 with + | FStar_Pervasives_Native.None -> + let uu___3 = + let uu___4 = FStarC_Ident.string_of_lid lid in + FStarC_Compiler_Util.format1 + "Data constructor %s not found" uu___4 in + FStarC_Errors.raise_error FStarC_Parser_AST.hasRange_term + top FStarC_Errors_Codes.Fatal_DataContructorNotFound () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___3) + | uu___3 -> + let lid' = FStarC_Syntax_Util.mk_discriminator lid in + let uu___4 = desugar_name mk setpos env true lid' in + (uu___4, noaqs)) + | FStarC_Parser_AST.Construct (l, args) -> + let uu___2 = FStarC_Syntax_DsEnv.try_lookup_datacon env l in + (match uu___2 with + | FStar_Pervasives_Native.Some head -> + let head1 = mk (FStarC_Syntax_Syntax.Tm_fvar head) in + (match args with + | [] -> (head1, noaqs) + | uu___3 -> + let uu___4 = + FStarC_Compiler_Util.take + (fun uu___5 -> + match uu___5 with + | (uu___6, imp) -> + imp = FStarC_Parser_AST.UnivApp) args in + (match uu___4 with + | (universes, args1) -> + let universes1 = + FStarC_Compiler_List.map + (fun x -> + desugar_universe + (FStar_Pervasives_Native.fst x)) + universes in + let uu___5 = + let uu___6 = + FStarC_Compiler_List.map + (fun uu___7 -> + match uu___7 with + | (t, imp) -> + let uu___8 = desugar_term_aq env t in + (match uu___8 with + | (te, aq) -> + let uu___9 = + arg_withimp_t imp te in + (uu___9, aq))) args1 in + FStarC_Compiler_List.unzip uu___6 in + (match uu___5 with + | (args2, aqs) -> + let head2 = + if universes1 = [] + then head1 + else + mk + (FStarC_Syntax_Syntax.Tm_uinst + (head1, universes1)) in + let tm = + if + (FStarC_Compiler_List.length args2) = + Prims.int_zero + then head2 + else + mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = head2; + FStarC_Syntax_Syntax.args = args2 + }) in + (tm, (join_aqs aqs))))) + | FStar_Pervasives_Native.None -> + let uu___3 = + FStarC_Syntax_DsEnv.try_lookup_effect_name env l in + (match uu___3 with + | FStar_Pervasives_Native.None -> + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Ident.string_of_lid l in + Prims.strcat uu___6 " not found" in + Prims.strcat "Constructor " uu___5 in + FStarC_Errors.raise_error FStarC_Ident.hasrange_lident + l FStarC_Errors_Codes.Fatal_ConstructorNotFound () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4) + | FStar_Pervasives_Native.Some uu___4 -> + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Ident.string_of_lid l in + Prims.strcat uu___7 + " used at an unexpected position" in + Prims.strcat "Effect " uu___6 in + FStarC_Errors.raise_error FStarC_Ident.hasrange_lident + l FStarC_Errors_Codes.Fatal_UnexpectedEffect () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___5))) + | FStarC_Parser_AST.Sum (binders, t) when + FStarC_Compiler_Util.for_all + (fun uu___2 -> + match uu___2 with + | FStar_Pervasives.Inr uu___3 -> true + | uu___3 -> false) binders + -> + let terms = + let uu___2 = + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with + | FStar_Pervasives.Inr x -> x + | FStar_Pervasives.Inl uu___4 -> failwith "Impossible") + binders in + FStarC_Compiler_List.op_At uu___2 [t] in + let uu___2 = + let uu___3 = + FStarC_Compiler_List.map + (fun t1 -> + let uu___4 = desugar_typ_aq env t1 in + match uu___4 with + | (t', aq) -> + let uu___5 = FStarC_Syntax_Syntax.as_arg t' in + (uu___5, aq)) terms in + FStarC_Compiler_List.unzip uu___3 in + (match uu___2 with + | (targs, aqs) -> + let tup = + let uu___3 = + FStarC_Parser_Const.mk_tuple_lid + (FStarC_Compiler_List.length targs) + top.FStarC_Parser_AST.range in + FStarC_Syntax_DsEnv.fail_or env + (FStarC_Syntax_DsEnv.try_lookup_lid env) uu___3 in + let uu___3 = + mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = tup; + FStarC_Syntax_Syntax.args = targs + }) in + (uu___3, (join_aqs aqs))) + | FStarC_Parser_AST.Sum (binders, t) -> + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Parser_AST.mk_binder + (FStarC_Parser_AST.NoName t) + t.FStarC_Parser_AST.range + FStarC_Parser_AST.Type_level + FStar_Pervasives_Native.None in + FStar_Pervasives.Inl uu___6 in + [uu___5] in + FStarC_Compiler_List.op_At binders uu___4 in + FStarC_Compiler_List.fold_left + (fun uu___4 -> + fun b -> + match uu___4 with + | (env1, tparams, typs) -> + let uu___5 = + match b with + | FStar_Pervasives.Inl b1 -> + desugar_binder env1 b1 + | FStar_Pervasives.Inr t1 -> + let uu___6 = desugar_typ env1 t1 in + (FStar_Pervasives_Native.None, uu___6, []) in + (match uu___5 with + | (xopt, t1, attrs) -> + let uu___6 = + match xopt with + | FStar_Pervasives_Native.None -> + let uu___7 = + FStarC_Syntax_Syntax.new_bv + (FStar_Pervasives_Native.Some + (top.FStarC_Parser_AST.range)) + (setpos FStarC_Syntax_Syntax.tun) in + (env1, uu___7) + | FStar_Pervasives_Native.Some x -> + FStarC_Syntax_DsEnv.push_bv env1 x in + (match uu___6 with + | (env2, x) -> + let uu___7 = + let uu___8 = + let uu___9 = + mk_binder_with_attrs + { + FStarC_Syntax_Syntax.ppname = + (x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (x.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = t1 + } FStar_Pervasives_Native.None + attrs in + [uu___9] in + FStarC_Compiler_List.op_At tparams + uu___8 in + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + no_annot_abs tparams t1 in + FStarC_Syntax_Syntax.as_arg uu___11 in + [uu___10] in + FStarC_Compiler_List.op_At typs uu___9 in + (env2, uu___7, uu___8)))) (env, [], []) + uu___3 in + (match uu___2 with + | (env1, uu___3, targs) -> + let tup = + let uu___4 = + FStarC_Parser_Const.mk_dtuple_lid + (FStarC_Compiler_List.length targs) + top.FStarC_Parser_AST.range in + FStarC_Syntax_DsEnv.fail_or env1 + (FStarC_Syntax_DsEnv.try_lookup_lid env1) uu___4 in + let uu___4 = + mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = tup; + FStarC_Syntax_Syntax.args = targs + }) in + (uu___4, noaqs)) + | FStarC_Parser_AST.Product (binders, t) -> + let uu___2 = uncurry binders t in + (match uu___2 with + | (bs, t1) -> + let rec aux env1 aqs bs1 uu___3 = + match uu___3 with + | [] -> + let cod = + desugar_comp top.FStarC_Parser_AST.range true env1 + t1 in + let uu___4 = + let uu___5 = + FStarC_Syntax_Util.arrow + (FStarC_Compiler_List.rev bs1) cod in + setpos uu___5 in + (uu___4, aqs) + | hd::tl -> + let uu___4 = desugar_binder_aq env1 hd in + (match uu___4 with + | (bb, aqs') -> + let uu___5 = + as_binder env1 hd.FStarC_Parser_AST.aqual bb in + (match uu___5 with + | (b, env2) -> + aux env2 + (FStarC_Compiler_List.op_At aqs' aqs) (b + :: bs1) tl)) in + aux env [] [] bs) + | FStarC_Parser_AST.Refine (b, f) -> + let uu___2 = desugar_binder env b in + (match uu___2 with + | (FStar_Pervasives_Native.None, uu___3, uu___4) -> + failwith "Missing binder in refinement" + | b1 -> + let uu___3 = as_binder env FStar_Pervasives_Native.None b1 in + (match uu___3 with + | (b2, env1) -> + let f1 = desugar_formula env1 f in + let uu___4 = + let uu___5 = + FStarC_Syntax_Util.refine + b2.FStarC_Syntax_Syntax.binder_bv f1 in + setpos uu___5 in + (uu___4, noaqs))) + | FStarC_Parser_AST.Function (branches, r1) -> + let x = FStarC_Ident.gen r1 in + let t' = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Parser_AST.mk_pattern + (FStarC_Parser_AST.PatVar + (x, FStar_Pervasives_Native.None, [])) r1 in + [uu___5] in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = FStarC_Ident.lid_of_ids [x] in + FStarC_Parser_AST.Var uu___10 in + FStarC_Parser_AST.mk_term uu___9 r1 + FStarC_Parser_AST.Expr in + (uu___8, FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None, branches) in + FStarC_Parser_AST.Match uu___7 in + FStarC_Parser_AST.mk_term uu___6 + top.FStarC_Parser_AST.range FStarC_Parser_AST.Expr in + (uu___4, uu___5) in + FStarC_Parser_AST.Abs uu___3 in + FStarC_Parser_AST.mk_term uu___2 top.FStarC_Parser_AST.range + FStarC_Parser_AST.Expr in + desugar_term_maybe_top top_level env t' + | FStarC_Parser_AST.Abs (binders, body) -> + let bvss = + FStarC_Compiler_List.map gather_pattern_bound_vars binders in + let check_disjoint sets = + let rec aux acc sets1 = + match sets1 with + | [] -> FStar_Pervasives_Native.None + | set::sets2 -> + let i = + Obj.magic + (FStarC_Class_Setlike.inter () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_ident)) + (Obj.magic acc) (Obj.magic set)) in + let uu___2 = + FStarC_Class_Setlike.is_empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_ident)) (Obj.magic i) in + if uu___2 + then + let uu___3 = + Obj.magic + (FStarC_Class_Setlike.union () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_ident)) + (Obj.magic acc) (Obj.magic set)) in + aux uu___3 sets2 + else + (let uu___4 = + let uu___5 = + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_ident)) + (Obj.magic i) in + FStarC_Compiler_List.hd uu___5 in + FStar_Pervasives_Native.Some uu___4) in + let uu___2 = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_ident)) ()) in + aux uu___2 sets in + ((let uu___3 = check_disjoint bvss in + match uu___3 with + | FStar_Pervasives_Native.None -> () + | FStar_Pervasives_Native.Some id -> + let uu___4 = + let uu___5 = + FStarC_Errors_Msg.text + "Non-linear patterns are not permitted." in + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Errors_Msg.text "The variable " in + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Class_PP.pp FStarC_Ident.pretty_ident + id in + FStarC_Pprint.squotes uu___11 in + let uu___11 = + FStarC_Errors_Msg.text + " appears more than once in this function definition." in + FStarC_Pprint.op_Hat_Slash_Hat uu___10 uu___11 in + FStarC_Pprint.op_Hat_Slash_Hat uu___8 uu___9 in + [uu___7] in + uu___5 :: uu___6 in + FStarC_Errors.raise_error FStarC_Ident.hasrange_ident id + FStarC_Errors_Codes.Fatal_NonLinearPatternNotPermitted + () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___4)); + (let binders1 = + FStarC_Compiler_List.map replace_unit_pattern binders in + let uu___3 = + FStarC_Compiler_List.fold_left + (fun uu___4 -> + fun pat -> + match uu___4 with + | (env1, ftvs) -> + (match pat.FStarC_Parser_AST.pat with + | FStarC_Parser_AST.PatAscribed + (uu___5, (t, FStar_Pervasives_Native.None)) + -> + let uu___6 = + let uu___7 = free_type_vars env1 t in + FStarC_Compiler_List.op_At uu___7 ftvs in + (env1, uu___6) + | FStarC_Parser_AST.PatAscribed + (uu___5, + (t, FStar_Pervasives_Native.Some tac)) + -> + let uu___6 = + let uu___7 = free_type_vars env1 t in + let uu___8 = + let uu___9 = free_type_vars env1 tac in + FStarC_Compiler_List.op_At uu___9 ftvs in + FStarC_Compiler_List.op_At uu___7 uu___8 in + (env1, uu___6) + | uu___5 -> (env1, ftvs))) (env, []) binders1 in + match uu___3 with + | (uu___4, ftv) -> + let ftv1 = sort_ftv ftv in + let binders2 = + let uu___5 = + FStarC_Compiler_List.map + (fun a -> + FStarC_Parser_AST.mk_pattern + (FStarC_Parser_AST.PatTvar + (a, + (FStar_Pervasives_Native.Some + FStarC_Parser_AST.Implicit), [])) + top.FStarC_Parser_AST.range) ftv1 in + FStarC_Compiler_List.op_At uu___5 binders1 in + let rec aux aqs env1 bs sc_pat_opt pats = + match pats with + | [] -> + let uu___5 = desugar_term_aq env1 body in + (match uu___5 with + | (body1, aq) -> + let body2 = + match sc_pat_opt with + | FStar_Pervasives_Native.Some (sc, pat) -> + let body3 = + let uu___6 = + let uu___7 = + FStarC_Syntax_Syntax.pat_bvs pat in + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.mk_binder + uu___7 in + FStarC_Syntax_Subst.close uu___6 body1 in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_match + { + FStarC_Syntax_Syntax.scrutinee = + sc; + FStarC_Syntax_Syntax.ret_opt = + FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.brs = + [(pat, + FStar_Pervasives_Native.None, + body3)]; + FStarC_Syntax_Syntax.rc_opt1 = + FStar_Pervasives_Native.None + }) body3.FStarC_Syntax_Syntax.pos + | FStar_Pervasives_Native.None -> body1 in + let uu___6 = + let uu___7 = + no_annot_abs (FStarC_Compiler_List.rev bs) + body2 in + setpos uu___7 in + (uu___6, (FStarC_Compiler_List.op_At aq aqs))) + | p::rest -> + let uu___5 = desugar_binding_pat_aq env1 p in + (match uu___5 with + | ((env2, b, pat), aq) -> + let pat1 = + match pat with + | [] -> FStar_Pervasives_Native.None + | (p1, uu___6)::[] -> + FStar_Pervasives_Native.Some p1 + | uu___6 -> + FStarC_Errors.raise_error + FStarC_Parser_AST.hasRange_pattern p + FStarC_Errors_Codes.Fatal_UnsupportedDisjuctivePatterns + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Disjunctive patterns are not supported in abstractions") in + let uu___6 = + match b with + | LetBinder uu___7 -> failwith "Impossible" + | LocalBinder (x, aq1, attrs) -> + let sc_pat_opt1 = + match (pat1, sc_pat_opt) with + | (FStar_Pervasives_Native.None, + uu___7) -> sc_pat_opt + | (FStar_Pervasives_Native.Some p1, + FStar_Pervasives_Native.None) -> + let uu___7 = + let uu___8 = + FStarC_Syntax_Syntax.bv_to_name + x in + (uu___8, p1) in + FStar_Pervasives_Native.Some uu___7 + | (FStar_Pervasives_Native.Some p1, + FStar_Pervasives_Native.Some + (sc, p')) -> + (match ((sc.FStarC_Syntax_Syntax.n), + (p'.FStarC_Syntax_Syntax.v)) + with + | (FStarC_Syntax_Syntax.Tm_name + uu___7, uu___8) -> + let tup2 = + let uu___9 = + FStarC_Parser_Const.mk_tuple_data_lid + (Prims.of_int (2)) + top.FStarC_Parser_AST.range in + FStarC_Syntax_Syntax.lid_and_dd_as_fv + uu___9 + (FStar_Pervasives_Native.Some + FStarC_Syntax_Syntax.Data_ctor) in + let sc1 = + let uu___9 = + let uu___10 = + let uu___11 = + mk + (FStarC_Syntax_Syntax.Tm_fvar + tup2) in + let uu___12 = + let uu___13 = + FStarC_Syntax_Syntax.as_arg + sc in + let uu___14 = + let uu___15 = + let uu___16 = + FStarC_Syntax_Syntax.bv_to_name + x in + FStarC_Syntax_Syntax.as_arg + uu___16 in + [uu___15] in + uu___13 :: uu___14 in + { + FStarC_Syntax_Syntax.hd + = uu___11; + FStarC_Syntax_Syntax.args + = uu___12 + } in + FStarC_Syntax_Syntax.Tm_app + uu___10 in + FStarC_Syntax_Syntax.mk + uu___9 + top.FStarC_Parser_AST.range in + let p2 = + let uu___9 = + FStarC_Compiler_Range_Ops.union_ranges + p'.FStarC_Syntax_Syntax.p + p1.FStarC_Syntax_Syntax.p in + FStarC_Syntax_Syntax.withinfo + (FStarC_Syntax_Syntax.Pat_cons + (tup2, + FStar_Pervasives_Native.None, + [(p', false); + (p1, false)])) uu___9 in + FStar_Pervasives_Native.Some + (sc1, p2) + | (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + uu___7; + FStarC_Syntax_Syntax.args = + args;_}, + FStarC_Syntax_Syntax.Pat_cons + (uu___8, uu___9, pats1)) -> + let tupn = + let uu___10 = + FStarC_Parser_Const.mk_tuple_data_lid + (Prims.int_one + + (FStarC_Compiler_List.length + args)) + top.FStarC_Parser_AST.range in + FStarC_Syntax_Syntax.lid_and_dd_as_fv + uu___10 + (FStar_Pervasives_Native.Some + FStarC_Syntax_Syntax.Data_ctor) in + let sc1 = + let uu___10 = + let uu___11 = + let uu___12 = + mk + (FStarC_Syntax_Syntax.Tm_fvar + tupn) in + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = + FStarC_Syntax_Syntax.bv_to_name + x in + FStarC_Syntax_Syntax.as_arg + uu___16 in + [uu___15] in + FStarC_Compiler_List.op_At + args uu___14 in + { + FStarC_Syntax_Syntax.hd + = uu___12; + FStarC_Syntax_Syntax.args + = uu___13 + } in + FStarC_Syntax_Syntax.Tm_app + uu___11 in + mk uu___10 in + let p2 = + let uu___10 = + FStarC_Compiler_Range_Ops.union_ranges + p'.FStarC_Syntax_Syntax.p + p1.FStarC_Syntax_Syntax.p in + FStarC_Syntax_Syntax.withinfo + (FStarC_Syntax_Syntax.Pat_cons + (tupn, + FStar_Pervasives_Native.None, + (FStarC_Compiler_List.op_At + pats1 + [(p1, false)]))) + uu___10 in + FStar_Pervasives_Native.Some + (sc1, p2) + | uu___7 -> failwith "Impossible") in + let uu___7 = + mk_binder_with_attrs x aq1 attrs in + (uu___7, sc_pat_opt1) in + (match uu___6 with + | (b1, sc_pat_opt1) -> + aux (FStarC_Compiler_List.op_At aq aqs) + env2 (b1 :: bs) sc_pat_opt1 rest)) in + aux [] env [] FStar_Pervasives_Native.None binders2)) + | FStarC_Parser_AST.App (uu___2, uu___3, FStarC_Parser_AST.UnivApp) + -> + let rec aux universes e = + let uu___4 = + let uu___5 = unparen e in uu___5.FStarC_Parser_AST.tm in + match uu___4 with + | FStarC_Parser_AST.App (e1, t, FStarC_Parser_AST.UnivApp) -> + let univ_arg = desugar_universe t in + aux (univ_arg :: universes) e1 + | uu___5 -> + let uu___6 = desugar_term_aq env e in + (match uu___6 with + | (head, aq) -> + let uu___7 = + mk + (FStarC_Syntax_Syntax.Tm_uinst (head, universes)) in + (uu___7, aq)) in + aux [] top + | FStarC_Parser_AST.App (e, t, imp) -> + let uu___2 = desugar_term_aq env e in + (match uu___2 with + | (head, aq1) -> + let uu___3 = desugar_term_aq env t in + (match uu___3 with + | (t1, aq2) -> + let arg = arg_withimp_t imp t1 in + let uu___4 = + FStarC_Syntax_Syntax.extend_app head arg + top.FStarC_Parser_AST.range in + (uu___4, (FStarC_Compiler_List.op_At aq1 aq2)))) + | FStarC_Parser_AST.Bind (x, t1, t2) -> + let xpat = + let uu___2 = FStarC_Ident.range_of_id x in + FStarC_Parser_AST.mk_pattern + (FStarC_Parser_AST.PatVar + (x, FStar_Pervasives_Native.None, [])) uu___2 in + let k = + FStarC_Parser_AST.mk_term (FStarC_Parser_AST.Abs ([xpat], t2)) + t2.FStarC_Parser_AST.range t2.FStarC_Parser_AST.level in + let bind_lid = + let uu___2 = FStarC_Ident.range_of_id x in + FStarC_Ident.lid_of_path ["bind"] uu___2 in + let bind = + let uu___2 = FStarC_Ident.range_of_id x in + FStarC_Parser_AST.mk_term (FStarC_Parser_AST.Var bind_lid) + uu___2 FStarC_Parser_AST.Expr in + let uu___2 = + FStarC_Parser_AST.mkExplicitApp bind [t1; k] + top.FStarC_Parser_AST.range in + desugar_term_aq env uu___2 + | FStarC_Parser_AST.Seq (t1, t2) -> + let p = + FStarC_Parser_AST.mk_pattern + (FStarC_Parser_AST.PatWild + (FStar_Pervasives_Native.None, [])) + t1.FStarC_Parser_AST.range in + let p1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = unit_ty p.FStarC_Parser_AST.prange in + (uu___5, FStar_Pervasives_Native.None) in + (p, uu___4) in + FStarC_Parser_AST.PatAscribed uu___3 in + FStarC_Parser_AST.mk_pattern uu___2 p.FStarC_Parser_AST.prange in + let t = + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.Let + (FStarC_Parser_AST.NoLetQualifier, + [(FStar_Pervasives_Native.None, (p1, t1))], t2)) + top.FStarC_Parser_AST.range FStarC_Parser_AST.Expr in + let uu___2 = desugar_term_aq env t in + (match uu___2 with + | (tm, s) -> + let uu___3 = + mk + (FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 = tm; + FStarC_Syntax_Syntax.meta = + (FStarC_Syntax_Syntax.Meta_desugared + FStarC_Syntax_Syntax.Sequence) + }) in + (uu___3, s)) + | FStarC_Parser_AST.LetOpen (lid, e) -> + let env1 = + FStarC_Syntax_DsEnv.push_namespace env lid + FStarC_Syntax_Syntax.Unrestricted in + let uu___2 = + let uu___3 = FStarC_Syntax_DsEnv.expect_typ env1 in + if uu___3 then desugar_typ_aq else desugar_term_aq in + uu___2 env1 e + | FStarC_Parser_AST.LetOpenRecord (r, rty, e) -> + let rec head_of t = + match t.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.App (t1, uu___2, uu___3) -> head_of t1 + | uu___2 -> t in + let tycon = head_of rty in + let tycon_name = + match tycon.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Var l -> l + | uu___2 -> + let uu___3 = + let uu___4 = FStarC_Parser_AST.term_to_string rty in + FStarC_Compiler_Util.format1 + "This type must be a (possibly applied) record name" + uu___4 in + FStarC_Errors.raise_error FStarC_Parser_AST.hasRange_term + rty FStarC_Errors_Codes.Error_BadLetOpenRecord () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___3) in + let record = + let uu___2 = + FStarC_Syntax_DsEnv.try_lookup_record_type env tycon_name in + match uu___2 with + | FStar_Pervasives_Native.Some r1 -> r1 + | FStar_Pervasives_Native.None -> + let uu___3 = + let uu___4 = FStarC_Parser_AST.term_to_string rty in + FStarC_Compiler_Util.format1 "Not a record type: `%s`" + uu___4 in + FStarC_Errors.raise_error FStarC_Parser_AST.hasRange_term + rty FStarC_Errors_Codes.Error_BadLetOpenRecord () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___3) in + let constrname = + let uu___2 = + FStarC_Ident.ns_of_lid record.FStarC_Syntax_DsEnv.typename in + FStarC_Ident.lid_of_ns_and_id uu___2 + record.FStarC_Syntax_DsEnv.constrname in + let mk_pattern p = + FStarC_Parser_AST.mk_pattern p r.FStarC_Parser_AST.range in + let elab = + let pat = + let uu___2 = + let uu___3 = + let uu___4 = + mk_pattern (FStarC_Parser_AST.PatName constrname) in + let uu___5 = + FStarC_Compiler_List.map + (fun uu___6 -> + match uu___6 with + | (field, uu___7) -> + mk_pattern + (FStarC_Parser_AST.PatVar + (field, FStar_Pervasives_Native.None, + []))) + record.FStarC_Syntax_DsEnv.fields in + (uu___4, uu___5) in + FStarC_Parser_AST.PatApp uu___3 in + mk_pattern uu___2 in + let branch = (pat, FStar_Pervasives_Native.None, e) in + let r1 = + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.Ascribed + (r, rty, FStar_Pervasives_Native.None, false)) + r.FStarC_Parser_AST.range FStarC_Parser_AST.Expr in + { + FStarC_Parser_AST.tm = + (FStarC_Parser_AST.Match + (r1, FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None, [branch])); + FStarC_Parser_AST.range = (top.FStarC_Parser_AST.range); + FStarC_Parser_AST.level = (top.FStarC_Parser_AST.level) + } in + desugar_term_maybe_top top_level env elab + | FStarC_Parser_AST.LetOperator (lets, body) -> + (match lets with + | [] -> + failwith + "Impossible: a LetOperator (e.g. let+, let*...) cannot contain zero let binding" + | (letOp, letPat, letDef)::tl -> + let term_of_op op = + let uu___2 = FStarC_Ident.range_of_id op in + FStarC_Parser_AST.mk_term (FStarC_Parser_AST.Op (op, [])) + uu___2 FStarC_Parser_AST.Expr in + let mproduct_def = + FStarC_Compiler_List.fold_left + (fun def -> + fun uu___2 -> + match uu___2 with + | (andOp, andPat, andDef) -> + let uu___3 = term_of_op andOp in + FStarC_Parser_AST.mkExplicitApp uu___3 + [def; andDef] top.FStarC_Parser_AST.range) + letDef tl in + let mproduct_pat = + FStarC_Compiler_List.fold_left + (fun pat -> + fun uu___2 -> + match uu___2 with + | (andOp, andPat, andDef) -> + FStarC_Parser_AST.mk_pattern + (FStarC_Parser_AST.PatTuple + ([pat; andPat], false)) + andPat.FStarC_Parser_AST.prange) letPat tl in + let fn = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = hoist_pat_ascription mproduct_pat in + [uu___5] in + (uu___4, body) in + FStarC_Parser_AST.Abs uu___3 in + FStarC_Parser_AST.mk_term uu___2 + body.FStarC_Parser_AST.range + body.FStarC_Parser_AST.level in + let let_op = term_of_op letOp in + let t = + FStarC_Parser_AST.mkExplicitApp let_op [mproduct_def; fn] + top.FStarC_Parser_AST.range in + desugar_term_aq env t) + | FStarC_Parser_AST.Let (qual, lbs, body) -> + let is_rec = qual = FStarC_Parser_AST.Rec in + let ds_let_rec_or_app uu___2 = + let bindings = lbs in + let funs = + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with + | (attr_opt, (p, def)) -> + let uu___4 = is_app_pattern p in + if uu___4 + then + let uu___5 = destruct_app_pattern env top_level p in + (attr_opt, uu___5, def) + else + (let uu___6 = FStarC_Parser_AST.un_function p def in + match uu___6 with + | FStar_Pervasives_Native.Some (p1, def1) -> + let uu___7 = + destruct_app_pattern env top_level p1 in + (attr_opt, uu___7, def1) + | uu___7 -> + (match p.FStarC_Parser_AST.pat with + | FStarC_Parser_AST.PatAscribed + ({ + FStarC_Parser_AST.pat = + FStarC_Parser_AST.PatVar + (id, uu___8, uu___9); + FStarC_Parser_AST.prange = uu___10;_}, + t) + -> + if top_level + then + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Syntax_DsEnv.qualify env + id in + FStar_Pervasives.Inr uu___13 in + (uu___12, [], + (FStar_Pervasives_Native.Some t)) in + (attr_opt, uu___11, def) + else + (attr_opt, + ((FStar_Pervasives.Inl id), [], + (FStar_Pervasives_Native.Some t)), + def) + | FStarC_Parser_AST.PatVar + (id, uu___8, uu___9) -> + if top_level + then + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Syntax_DsEnv.qualify env + id in + FStar_Pervasives.Inr uu___12 in + (uu___11, [], + FStar_Pervasives_Native.None) in + (attr_opt, uu___10, def) + else + (attr_opt, + ((FStar_Pervasives.Inl id), [], + FStar_Pervasives_Native.None), + def) + | uu___8 -> + FStarC_Errors.raise_error + FStarC_Parser_AST.hasRange_pattern p + FStarC_Errors_Codes.Fatal_UnexpectedLetBinding + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "Unexpected let binding")))) + bindings in + let uu___3 = + FStarC_Compiler_List.fold_left + (fun uu___4 -> + fun uu___5 -> + match (uu___4, uu___5) with + | ((env1, fnames, rec_bindings, used_markers), + (_attr_opt, (f, uu___6, uu___7), uu___8)) -> + let uu___9 = + match f with + | FStar_Pervasives.Inl x -> + let uu___10 = + FStarC_Syntax_DsEnv.push_bv' env1 x in + (match uu___10 with + | (env2, xx, used_marker) -> + let dummy_ref = + FStarC_Compiler_Util.mk_ref true in + let uu___11 = + let uu___12 = + FStarC_Syntax_Syntax.mk_binder xx in + uu___12 :: rec_bindings in + (env2, (FStar_Pervasives.Inl xx), + uu___11, (used_marker :: + used_markers))) + | FStar_Pervasives.Inr l -> + let uu___10 = + let uu___11 = FStarC_Ident.ident_of_lid l in + FStarC_Syntax_DsEnv.push_top_level_rec_binding + env1 uu___11 in + (match uu___10 with + | (env2, used_marker) -> + (env2, (FStar_Pervasives.Inr l), + rec_bindings, (used_marker :: + used_markers))) in + (match uu___9 with + | (env2, lbname, rec_bindings1, used_markers1) + -> + (env2, (lbname :: fnames), rec_bindings1, + used_markers1))) (env, [], [], []) funs in + match uu___3 with + | (env', fnames, rec_bindings, used_markers) -> + let fnames1 = FStarC_Compiler_List.rev fnames in + let rec_bindings1 = FStarC_Compiler_List.rev rec_bindings in + let used_markers1 = FStarC_Compiler_List.rev used_markers in + let desugar_one_def env1 lbname uu___4 = + match uu___4 with + | (attrs_opt, (uu___5, args, result_t), def) -> + let args1 = + FStarC_Compiler_List.map replace_unit_pattern args in + let pos = def.FStarC_Parser_AST.range in + let def1 = + match result_t with + | FStar_Pervasives_Native.None -> def + | FStar_Pervasives_Native.Some (t, tacopt) -> + let t1 = + let uu___6 = is_comp_type env1 t in + if uu___6 + then + ((let uu___8 = + FStarC_Compiler_List.tryFind + (fun x -> + let uu___9 = is_var_pattern x in + Prims.op_Negation uu___9) args1 in + match uu___8 with + | FStar_Pervasives_Native.None -> () + | FStar_Pervasives_Native.Some p -> + FStarC_Errors.raise_error + FStarC_Parser_AST.hasRange_pattern + p + FStarC_Errors_Codes.Fatal_ComputationTypeNotAllowed + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Computation type annotations are only permitted on let-bindings without inlined patterns; replace this pattern with a variable")); + t) + else + (let uu___8 = + ((FStarC_Options.ml_ish ()) && + (let uu___9 = + let uu___10 = + FStarC_Parser_Const.effect_ML_lid + () in + FStarC_Syntax_DsEnv.try_lookup_effect_name + env1 uu___10 in + FStarC_Compiler_Option.isSome + uu___9)) + && + ((Prims.op_Negation is_rec) || + ((FStarC_Compiler_List.length + args1) + <> Prims.int_zero)) in + if uu___8 + then FStarC_Parser_AST.ml_comp t + else FStarC_Parser_AST.tot_comp t) in + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.Ascribed + (def, t1, tacopt, false)) + def.FStarC_Parser_AST.range + FStarC_Parser_AST.Expr in + let def2 = + match args1 with + | [] -> def1 + | uu___6 -> + let uu___7 = + FStarC_Parser_AST.un_curry_abs args1 def1 in + FStarC_Parser_AST.mk_term uu___7 + top.FStarC_Parser_AST.range + top.FStarC_Parser_AST.level in + let uu___6 = desugar_term_aq env1 def2 in + (match uu___6 with + | (body1, aq) -> + let lbname1 = + match lbname with + | FStar_Pervasives.Inl x -> + FStar_Pervasives.Inl x + | FStar_Pervasives.Inr l -> + let uu___7 = + FStarC_Syntax_Syntax.lid_and_dd_as_fv l + FStar_Pervasives_Native.None in + FStar_Pervasives.Inr uu___7 in + let body2 = + if is_rec + then + FStarC_Syntax_Subst.close rec_bindings1 + body1 + else body1 in + let attrs = + match attrs_opt with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some l -> + FStarC_Compiler_List.map + (desugar_term env1) l in + let uu___7 = + mk_lb + (attrs, lbname1, + (setpos FStarC_Syntax_Syntax.tun), body2, + pos) in + (uu___7, aq)) in + let uu___4 = + let uu___5 = + FStarC_Compiler_List.map2 + (desugar_one_def (if is_rec then env' else env)) + fnames1 funs in + FStarC_Compiler_List.unzip uu___5 in + (match uu___4 with + | (lbs1, aqss) -> + let uu___5 = desugar_term_aq env' body in + (match uu___5 with + | (body1, aq) -> + (if is_rec + then + FStarC_Compiler_List.iter2 + (fun uu___7 -> + fun used_marker -> + match uu___7 with + | (_attr_opt, (f, uu___8, uu___9), + uu___10) -> + let uu___11 = + let uu___12 = + FStarC_Compiler_Effect.op_Bang + used_marker in + Prims.op_Negation uu___12 in + if uu___11 + then + let uu___12 = + match f with + | FStar_Pervasives.Inl x -> + let uu___13 = + FStarC_Ident.string_of_id + x in + let uu___14 = + FStarC_Ident.range_of_id + x in + (uu___13, "Local binding", + uu___14) + | FStar_Pervasives.Inr l -> + let uu___13 = + FStarC_Ident.string_of_lid + l in + let uu___14 = + FStarC_Ident.range_of_lid + l in + (uu___13, + "Global binding", + uu___14) in + (match uu___12 with + | (nm, gl, rng) -> + let uu___13 = + let uu___14 = + let uu___15 = + FStarC_Errors_Msg.text + gl in + let uu___16 = + let uu___17 = + FStarC_Pprint.doc_of_string + nm in + FStarC_Pprint.squotes + uu___17 in + let uu___17 = + FStarC_Errors_Msg.text + "is recursive but not used in its body" in + FStarC_Pprint.surround + (Prims.of_int (4)) + Prims.int_one uu___15 + uu___16 uu___17 in + [uu___14] in + FStarC_Errors.log_issue + FStarC_Class_HasRange.hasRange_range + rng + FStarC_Errors_Codes.Warning_UnusedLetRec + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___13)) + else ()) funs used_markers1 + else (); + (let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Syntax_Subst.close + rec_bindings1 body1 in + { + FStarC_Syntax_Syntax.lbs = + (is_rec, lbs1); + FStarC_Syntax_Syntax.body1 = uu___10 + } in + FStarC_Syntax_Syntax.Tm_let uu___9 in + mk uu___8 in + (uu___7, + (FStarC_Compiler_List.op_At aq + (FStarC_Compiler_List.flatten aqss))))))) in + let ds_non_rec attrs_opt pat t1 t2 = + let attrs = + match attrs_opt with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some l -> + FStarC_Compiler_List.map (desugar_term env) l in + let uu___2 = desugar_term_aq env t1 in + match uu___2 with + | (t11, aq0) -> + let uu___3 = + desugar_binding_pat_maybe_top top_level env pat in + (match uu___3 with + | ((env1, binder, pat1), aqs) -> + (check_no_aq aqs; + (let uu___5 = + match binder with + | LetBinder (l, (t, tacopt)) -> + (if FStarC_Compiler_Util.is_some tacopt + then + (let uu___7 = + FStarC_Compiler_Util.must tacopt in + FStarC_Errors.log_issue + (FStarC_Syntax_Syntax.has_range_syntax + ()) uu___7 + FStarC_Errors_Codes.Warning_DefinitionNotTranslated + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Tactic annotation with a value type is not supported yet, try annotating with a computation type; this tactic annotation will be ignored")) + else (); + (let uu___7 = desugar_term_aq env1 t2 in + match uu___7 with + | (body1, aq) -> + let fv = + FStarC_Syntax_Syntax.lid_and_dd_as_fv + l FStar_Pervasives_Native.None in + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + mk_lb + (attrs, + (FStar_Pervasives.Inr + fv), t, t11, + (t11.FStarC_Syntax_Syntax.pos)) in + [uu___13] in + (false, uu___12) in + { + FStarC_Syntax_Syntax.lbs = + uu___11; + FStarC_Syntax_Syntax.body1 = + body1 + } in + FStarC_Syntax_Syntax.Tm_let uu___10 in + mk uu___9 in + (uu___8, aq))) + | LocalBinder (x, uu___6, uu___7) -> + let uu___8 = desugar_term_aq env1 t2 in + (match uu___8 with + | (body1, aq) -> + let body2 = + match pat1 with + | [] -> body1 + | uu___9 -> + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Syntax_Syntax.bv_to_name + x in + let uu___13 = + desugar_disjunctive_pattern + pat1 + FStar_Pervasives_Native.None + body1 in + { + FStarC_Syntax_Syntax.scrutinee + = uu___12; + FStarC_Syntax_Syntax.ret_opt + = + FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.brs = + uu___13; + FStarC_Syntax_Syntax.rc_opt1 + = + FStar_Pervasives_Native.None + } in + FStarC_Syntax_Syntax.Tm_match + uu___11 in + FStarC_Syntax_Syntax.mk uu___10 + top.FStarC_Parser_AST.range in + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + mk_lb + (attrs, + (FStar_Pervasives.Inl x), + (x.FStarC_Syntax_Syntax.sort), + t11, + (t11.FStarC_Syntax_Syntax.pos)) in + [uu___14] in + (false, uu___13) in + let uu___13 = + let uu___14 = + let uu___15 = + FStarC_Syntax_Syntax.mk_binder + x in + [uu___15] in + FStarC_Syntax_Subst.close + uu___14 body2 in + { + FStarC_Syntax_Syntax.lbs = + uu___12; + FStarC_Syntax_Syntax.body1 = + uu___13 + } in + FStarC_Syntax_Syntax.Tm_let uu___11 in + mk uu___10 in + (uu___9, aq)) in + match uu___5 with + | (tm, aq1) -> + (tm, (FStarC_Compiler_List.op_At aq0 aq1))))) in + let uu___2 = FStarC_Compiler_List.hd lbs in + (match uu___2 with + | (attrs, (head_pat, defn)) -> + let uu___3 = is_rec || (is_app_pattern head_pat) in + if uu___3 + then ds_let_rec_or_app () + else ds_non_rec attrs head_pat defn body) + | FStarC_Parser_AST.If + (e, FStar_Pervasives_Native.Some op, asc_opt, t2, t3) -> + let var_id = + FStarC_Ident.mk_ident + ((Prims.strcat FStarC_Ident.reserved_prefix "if_op_head"), + (e.FStarC_Parser_AST.range)) in + let var = + let uu___2 = + let uu___3 = FStarC_Ident.lid_of_ids [var_id] in + FStarC_Parser_AST.Var uu___3 in + FStarC_Parser_AST.mk_term uu___2 e.FStarC_Parser_AST.range + FStarC_Parser_AST.Expr in + let pat = + FStarC_Parser_AST.mk_pattern + (FStarC_Parser_AST.PatVar + (var_id, FStar_Pervasives_Native.None, [])) + e.FStarC_Parser_AST.range in + let if_ = + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.If + (var, FStar_Pervasives_Native.None, asc_opt, t2, t3)) + top.FStarC_Parser_AST.range FStarC_Parser_AST.Expr in + let t = + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.LetOperator ([(op, pat, e)], if_)) + e.FStarC_Parser_AST.range FStarC_Parser_AST.Expr in + desugar_term_aq env t + | FStarC_Parser_AST.If + (t1, FStar_Pervasives_Native.None, asc_opt, t2, t3) -> + let x = + let uu___2 = tun_r t3.FStarC_Parser_AST.range in + FStarC_Syntax_Syntax.new_bv + (FStar_Pervasives_Native.Some (t3.FStarC_Parser_AST.range)) + uu___2 in + let t_bool = + let uu___2 = + let uu___3 = + FStarC_Syntax_Syntax.lid_and_dd_as_fv + FStarC_Parser_Const.bool_lid + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.Tm_fvar uu___3 in + mk uu___2 in + let uu___2 = desugar_term_aq env t1 in + (match uu___2 with + | (t1', aq1) -> + let t1'1 = + FStarC_Syntax_Util.ascribe t1' + ((FStar_Pervasives.Inl t_bool), + FStar_Pervasives_Native.None, false) in + let uu___3 = desugar_match_returns env t1'1 asc_opt in + (match uu___3 with + | (asc_opt1, aq0) -> + let uu___4 = desugar_term_aq env t2 in + (match uu___4 with + | (t2', aq2) -> + let uu___5 = desugar_term_aq env t3 in + (match uu___5 with + | (t3', aq3) -> + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Syntax_Syntax.withinfo + (FStarC_Syntax_Syntax.Pat_constant + (FStarC_Const.Const_bool + true)) + t1.FStarC_Parser_AST.range in + (uu___11, + FStar_Pervasives_Native.None, + t2') in + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Syntax_Syntax.withinfo + (FStarC_Syntax_Syntax.Pat_var + x) + t1.FStarC_Parser_AST.range in + (uu___13, + FStar_Pervasives_Native.None, + t3') in + [uu___12] in + uu___10 :: uu___11 in + { + FStarC_Syntax_Syntax.scrutinee = + t1'1; + FStarC_Syntax_Syntax.ret_opt = + asc_opt1; + FStarC_Syntax_Syntax.brs = uu___9; + FStarC_Syntax_Syntax.rc_opt1 = + FStar_Pervasives_Native.None + } in + FStarC_Syntax_Syntax.Tm_match uu___8 in + mk uu___7 in + (uu___6, (join_aqs [aq1; aq0; aq2; aq3])))))) + | FStarC_Parser_AST.TryWith (e, branches) -> + let r = top.FStarC_Parser_AST.range in + let handler = FStarC_Parser_AST.mk_function branches r r in + let body = + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Parser_AST.mk_pattern + (FStarC_Parser_AST.PatConst FStarC_Const.Const_unit) r in + (uu___4, FStar_Pervasives_Native.None, e) in + [uu___3] in + FStarC_Parser_AST.mk_function uu___2 r r in + let try_with_lid = FStarC_Ident.lid_of_path ["try_with"] r in + let try_with = + FStarC_Parser_AST.mk_term (FStarC_Parser_AST.Var try_with_lid) + r FStarC_Parser_AST.Expr in + let a1 = + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.App + (try_with, body, FStarC_Parser_AST.Nothing)) r + top.FStarC_Parser_AST.level in + let a2 = + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.App + (a1, handler, FStarC_Parser_AST.Nothing)) r + top.FStarC_Parser_AST.level in + desugar_term_aq env a2 + | FStarC_Parser_AST.Match + (e, FStar_Pervasives_Native.Some op, topt, branches) -> + let var_id = + FStarC_Ident.mk_ident + ((Prims.strcat FStarC_Ident.reserved_prefix "match_op_head"), + (e.FStarC_Parser_AST.range)) in + let var = + let uu___2 = + let uu___3 = FStarC_Ident.lid_of_ids [var_id] in + FStarC_Parser_AST.Var uu___3 in + FStarC_Parser_AST.mk_term uu___2 e.FStarC_Parser_AST.range + FStarC_Parser_AST.Expr in + let pat = + FStarC_Parser_AST.mk_pattern + (FStarC_Parser_AST.PatVar + (var_id, FStar_Pervasives_Native.None, [])) + e.FStarC_Parser_AST.range in + let mt = + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.Match + (var, FStar_Pervasives_Native.None, topt, branches)) + top.FStarC_Parser_AST.range FStarC_Parser_AST.Expr in + let t = + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.LetOperator ([(op, pat, e)], mt)) + e.FStarC_Parser_AST.range FStarC_Parser_AST.Expr in + desugar_term_aq env t + | FStarC_Parser_AST.Match + (e, FStar_Pervasives_Native.None, topt, branches) -> + let desugar_branch uu___2 = + match uu___2 with + | (pat, wopt, b) -> + let uu___3 = desugar_match_pat env pat in + (match uu___3 with + | ((env1, pat1), aqP) -> + let wopt1 = + match wopt with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some e1 -> + let uu___4 = desugar_term env1 e1 in + FStar_Pervasives_Native.Some uu___4 in + let uu___4 = desugar_term_aq env1 b in + (match uu___4 with + | (b1, aqB) -> + let uu___5 = + desugar_disjunctive_pattern pat1 wopt1 b1 in + (uu___5, (FStarC_Compiler_List.op_At aqP aqB)))) in + let uu___2 = desugar_term_aq env e in + (match uu___2 with + | (e1, aq) -> + let uu___3 = desugar_match_returns env e1 topt in + (match uu___3 with + | (asc_opt, aq0) -> + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Compiler_List.map desugar_branch branches in + FStarC_Compiler_List.unzip uu___6 in + match uu___5 with + | (x, y) -> ((FStarC_Compiler_List.flatten x), y) in + (match uu___4 with + | (brs, aqs) -> + let uu___5 = + mk + (FStarC_Syntax_Syntax.Tm_match + { + FStarC_Syntax_Syntax.scrutinee = e1; + FStarC_Syntax_Syntax.ret_opt = asc_opt; + FStarC_Syntax_Syntax.brs = brs; + FStarC_Syntax_Syntax.rc_opt1 = + FStar_Pervasives_Native.None + }) in + (uu___5, (join_aqs (aq :: aq0 :: aqs)))))) + | FStarC_Parser_AST.Ascribed (e, t, tac_opt, use_eq) -> + let uu___2 = desugar_ascription env t tac_opt use_eq in + (match uu___2 with + | (asc, aq0) -> + let uu___3 = desugar_term_aq env e in + (match uu___3 with + | (e1, aq) -> + let uu___4 = + mk + (FStarC_Syntax_Syntax.Tm_ascribed + { + FStarC_Syntax_Syntax.tm = e1; + FStarC_Syntax_Syntax.asc = asc; + FStarC_Syntax_Syntax.eff_opt = + FStar_Pervasives_Native.None + }) in + (uu___4, (FStarC_Compiler_List.op_At aq0 aq)))) + | FStarC_Parser_AST.Record (uu___2, []) -> + FStarC_Errors.raise_error FStarC_Parser_AST.hasRange_term top + FStarC_Errors_Codes.Fatal_UnexpectedEmptyRecord () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "Unexpected empty record") + | FStarC_Parser_AST.Record (eopt, fields) -> + let record_opt = + let uu___2 = FStarC_Compiler_List.hd fields in + match uu___2 with + | (f, uu___3) -> + FStarC_Syntax_DsEnv.try_lookup_record_by_field_name env f in + let uu___2 = + let uu___3 = + FStarC_Compiler_List.map + (fun uu___4 -> + match uu___4 with + | (fn, fval) -> + let uu___5 = desugar_term_aq env fval in + (match uu___5 with + | (fval1, aq) -> ((fn, fval1), aq))) fields in + FStarC_Compiler_List.unzip uu___3 in + (match uu___2 with + | (fields1, aqs) -> + let uu___3 = FStarC_Compiler_List.unzip fields1 in + (match uu___3 with + | (field_names, assignments) -> + let args = + FStarC_Compiler_List.map + (fun f -> (f, FStar_Pervasives_Native.None)) + assignments in + let aqs1 = FStarC_Compiler_List.flatten aqs in + let uc = + match record_opt with + | FStar_Pervasives_Native.None -> + { + FStarC_Syntax_Syntax.uc_base_term = + (FStarC_Compiler_Option.isSome eopt); + FStarC_Syntax_Syntax.uc_typename = + FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.uc_fields = field_names + } + | FStar_Pervasives_Native.Some record -> + let uu___4 = + qualify_field_names + record.FStarC_Syntax_DsEnv.typename + field_names in + { + FStarC_Syntax_Syntax.uc_base_term = + (FStarC_Compiler_Option.isSome eopt); + FStarC_Syntax_Syntax.uc_typename = + (FStar_Pervasives_Native.Some + (record.FStarC_Syntax_DsEnv.typename)); + FStarC_Syntax_Syntax.uc_fields = uu___4 + } in + let head = + let lid = + FStarC_Ident.lid_of_path ["__dummy__"] + top.FStarC_Parser_AST.range in + FStarC_Syntax_Syntax.fvar_with_dd lid + (FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Unresolved_constructor uc)) in + let mk_result args1 = + FStarC_Syntax_Syntax.mk_Tm_app head args1 + top.FStarC_Parser_AST.range in + (match eopt with + | FStar_Pervasives_Native.None -> + let uu___4 = mk_result args in (uu___4, aqs1) + | FStar_Pervasives_Native.Some e -> + let uu___4 = desugar_term_aq env e in + (match uu___4 with + | (e1, aq) -> + let tm = + let uu___5 = + let uu___6 = + FStarC_Syntax_Subst.compress e1 in + uu___6.FStarC_Syntax_Syntax.n in + match uu___5 with + | FStarC_Syntax_Syntax.Tm_name uu___6 -> + mk_result + ((e1, FStar_Pervasives_Native.None) + :: args) + | FStarC_Syntax_Syntax.Tm_fvar uu___6 -> + mk_result + ((e1, FStar_Pervasives_Native.None) + :: args) + | uu___6 -> + let x = + FStarC_Ident.gen + e1.FStarC_Syntax_Syntax.pos in + let uu___7 = + FStarC_Syntax_DsEnv.push_bv env x in + (match uu___7 with + | (env', bv_x) -> + let nm = + FStarC_Syntax_Syntax.bv_to_name + bv_x in + let body = + mk_result + ((nm, + FStar_Pervasives_Native.None) + :: args) in + let body1 = + let uu___8 = + let uu___9 = + FStarC_Syntax_Syntax.mk_binder + bv_x in + [uu___9] in + FStarC_Syntax_Subst.close + uu___8 body in + let lb = + mk_lb + ([], + (FStar_Pervasives.Inl bv_x), + FStarC_Syntax_Syntax.tun, + e1, + (e1.FStarC_Syntax_Syntax.pos)) in + mk + (FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = + (false, [lb]); + FStarC_Syntax_Syntax.body1 + = body1 + })) in + (tm, (FStarC_Compiler_List.op_At aq aqs1)))))) + | FStarC_Parser_AST.Project (e, f) -> + let uu___2 = desugar_term_aq env e in + (match uu___2 with + | (e1, s) -> + let head = + let uu___3 = + FStarC_Syntax_DsEnv.try_lookup_dc_by_field_name env f in + match uu___3 with + | FStar_Pervasives_Native.None -> + FStarC_Syntax_Syntax.fvar_with_dd f + (FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Unresolved_projector + FStar_Pervasives_Native.None)) + | FStar_Pervasives_Native.Some (constrname, is_rec) -> + let projname = + let uu___4 = FStarC_Ident.ident_of_lid f in + FStarC_Syntax_Util.mk_field_projector_name_from_ident + constrname uu___4 in + let qual = + if is_rec + then + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Ident.ident_of_lid f in + (constrname, uu___6) in + FStarC_Syntax_Syntax.Record_projector uu___5 in + FStar_Pervasives_Native.Some uu___4 + else FStar_Pervasives_Native.None in + let candidate_projector = + let uu___4 = + FStarC_Ident.set_lid_range projname + top.FStarC_Parser_AST.range in + FStarC_Syntax_Syntax.lid_and_dd_as_fv uu___4 qual in + let qual1 = + FStarC_Syntax_Syntax.Unresolved_projector + (FStar_Pervasives_Native.Some candidate_projector) in + let f1 = + let uu___4 = qualify_field_names constrname [f] in + FStarC_Compiler_List.hd uu___4 in + FStarC_Syntax_Syntax.fvar_with_dd f1 + (FStar_Pervasives_Native.Some qual1) in + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Syntax_Syntax.as_arg e1 in + [uu___7] in + { + FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = uu___6 + } in + FStarC_Syntax_Syntax.Tm_app uu___5 in + mk uu___4 in + (uu___3, s)) + | FStarC_Parser_AST.NamedTyp (n, e) -> + (FStarC_Errors.log_issue FStarC_Ident.hasrange_ident n + FStarC_Errors_Codes.Warning_IgnoredBinding () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "This name is being ignored"); + desugar_term_aq env e) + | FStarC_Parser_AST.Paren e -> failwith "impossible" + | FStarC_Parser_AST.VQuote e -> + let uu___2 = + let uu___3 = + let uu___4 = + desugar_vquote env e top.FStarC_Parser_AST.range in + FStarC_Syntax_Util.exp_string uu___4 in + { + FStarC_Syntax_Syntax.n = (uu___3.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = (e.FStarC_Parser_AST.range); + FStarC_Syntax_Syntax.vars = + (uu___3.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (uu___3.FStarC_Syntax_Syntax.hash_code) + } in + (uu___2, noaqs) + | FStarC_Parser_AST.Quote (e, FStarC_Parser_AST.Static) -> + let uu___2 = desugar_term_aq env e in + (match uu___2 with + | (tm, vts) -> + let vt_binders = + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with + | (bv, _tm) -> FStarC_Syntax_Syntax.mk_binder bv) + vts in + let vt_tms = + FStarC_Compiler_List.map FStar_Pervasives_Native.snd vts in + let tm1 = FStarC_Syntax_Subst.close vt_binders tm in + ((let fvs = FStarC_Syntax_Free.names tm1 in + let uu___4 = + let uu___5 = + FStarC_Class_Setlike.is_empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) (Obj.magic fvs) in + Prims.op_Negation uu___5 in + if uu___4 + then + let uu___5 = + let uu___6 = + FStarC_Class_Show.show + (FStarC_Compiler_FlatSet.showable_set + FStarC_Syntax_Syntax.ord_bv + FStarC_Syntax_Print.showable_bv) fvs in + FStarC_Compiler_Util.format1 + "Static quotation refers to external variables: %s" + uu___6 in + FStarC_Errors.raise_error + FStarC_Parser_AST.hasRange_term e + FStarC_Errors_Codes.Fatal_MissingFieldInRecord () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___5) + else ()); + (match () with + | () -> + let qi = + { + FStarC_Syntax_Syntax.qkind = + FStarC_Syntax_Syntax.Quote_static; + FStarC_Syntax_Syntax.antiquotations = + (Prims.int_zero, vt_tms) + } in + let uu___4 = + mk (FStarC_Syntax_Syntax.Tm_quoted (tm1, qi)) in + (uu___4, noaqs)))) + | FStarC_Parser_AST.Antiquote e -> + let bv = + FStarC_Syntax_Syntax.new_bv + (FStar_Pervasives_Native.Some (e.FStarC_Parser_AST.range)) + FStarC_Syntax_Syntax.tun in + let tm = desugar_term env e in + let uu___2 = FStarC_Syntax_Syntax.bv_to_name bv in + (uu___2, [(bv, tm)]) + | FStarC_Parser_AST.Quote (e, FStarC_Parser_AST.Dynamic) -> + let qi = + { + FStarC_Syntax_Syntax.qkind = + FStarC_Syntax_Syntax.Quote_dynamic; + FStarC_Syntax_Syntax.antiquotations = (Prims.int_zero, []) + } in + let uu___2 = + let uu___3 = + let uu___4 = let uu___5 = desugar_term env e in (uu___5, qi) in + FStarC_Syntax_Syntax.Tm_quoted uu___4 in + mk uu___3 in + (uu___2, noaqs) + | FStarC_Parser_AST.CalcProof (rel, init_expr, steps) -> + let is_impl rel1 = + let is_impl_t t = + match t.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.imp_lid + | uu___2 -> false in + let uu___2 = + let uu___3 = unparen rel1 in uu___3.FStarC_Parser_AST.tm in + match uu___2 with + | FStarC_Parser_AST.Op (id, uu___3) -> + let uu___4 = op_as_term env (Prims.of_int (2)) id in + (match uu___4 with + | FStar_Pervasives_Native.Some t -> is_impl_t t + | FStar_Pervasives_Native.None -> false) + | FStarC_Parser_AST.Var lid -> + let uu___3 = desugar_name' (fun x -> x) env true lid in + (match uu___3 with + | FStar_Pervasives_Native.Some t -> is_impl_t t + | FStar_Pervasives_Native.None -> false) + | FStarC_Parser_AST.Tvar id -> + let uu___3 = FStarC_Syntax_DsEnv.try_lookup_id env id in + (match uu___3 with + | FStar_Pervasives_Native.Some t -> is_impl_t t + | FStar_Pervasives_Native.None -> false) + | uu___3 -> false in + let eta_and_annot rel1 = + let x = FStarC_Ident.gen' "x" rel1.FStarC_Parser_AST.range in + let y = FStarC_Ident.gen' "y" rel1.FStarC_Parser_AST.range in + let xt = + FStarC_Parser_AST.mk_term (FStarC_Parser_AST.Tvar x) + rel1.FStarC_Parser_AST.range FStarC_Parser_AST.Expr in + let yt = + FStarC_Parser_AST.mk_term (FStarC_Parser_AST.Tvar y) + rel1.FStarC_Parser_AST.range FStarC_Parser_AST.Expr in + let pats = + let uu___2 = + FStarC_Parser_AST.mk_pattern + (FStarC_Parser_AST.PatVar + (x, FStar_Pervasives_Native.None, [])) + rel1.FStarC_Parser_AST.range in + let uu___3 = + let uu___4 = + FStarC_Parser_AST.mk_pattern + (FStarC_Parser_AST.PatVar + (y, FStar_Pervasives_Native.None, [])) + rel1.FStarC_Parser_AST.range in + [uu___4] in + uu___2 :: uu___3 in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Parser_AST.mkApp rel1 + [(xt, FStarC_Parser_AST.Nothing); + (yt, FStarC_Parser_AST.Nothing)] + rel1.FStarC_Parser_AST.range in + let uu___8 = + let uu___9 = + let uu___10 = FStarC_Ident.lid_of_str "Type0" in + FStarC_Parser_AST.Name uu___10 in + FStarC_Parser_AST.mk_term uu___9 + rel1.FStarC_Parser_AST.range + FStarC_Parser_AST.Expr in + (uu___7, uu___8, FStar_Pervasives_Native.None, + false) in + FStarC_Parser_AST.Ascribed uu___6 in + FStarC_Parser_AST.mk_term uu___5 + rel1.FStarC_Parser_AST.range FStarC_Parser_AST.Expr in + (pats, uu___4) in + FStarC_Parser_AST.Abs uu___3 in + FStarC_Parser_AST.mk_term uu___2 rel1.FStarC_Parser_AST.range + FStarC_Parser_AST.Expr in + let rel1 = eta_and_annot rel in + let wild r = + FStarC_Parser_AST.mk_term FStarC_Parser_AST.Wild r + FStarC_Parser_AST.Expr in + let init = + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.Var FStarC_Parser_Const.calc_init_lid) + init_expr.FStarC_Parser_AST.range FStarC_Parser_AST.Expr in + let push_impl r = + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.Var + FStarC_Parser_Const.calc_push_impl_lid) r + FStarC_Parser_AST.Expr in + let last_expr = + let uu___2 = FStarC_Compiler_List.last_opt steps in + match uu___2 with + | FStar_Pervasives_Native.Some (FStarC_Parser_AST.CalcStep + (uu___3, uu___4, last_expr1)) -> last_expr1 + | FStar_Pervasives_Native.None -> init_expr in + let step r = + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.Var FStarC_Parser_Const.calc_step_lid) r + FStarC_Parser_AST.Expr in + let finish = + let uu___2 = + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.Var FStarC_Parser_Const.calc_finish_lid) + top.FStarC_Parser_AST.range FStarC_Parser_AST.Expr in + FStarC_Parser_AST.mkApp uu___2 + [(rel1, FStarC_Parser_AST.Nothing)] + top.FStarC_Parser_AST.range in + let e = + FStarC_Parser_AST.mkApp init + [(init_expr, FStarC_Parser_AST.Nothing)] + init_expr.FStarC_Parser_AST.range in + let uu___2 = + FStarC_Compiler_List.fold_left + (fun uu___3 -> + fun uu___4 -> + match (uu___3, uu___4) with + | ((e1, prev), FStarC_Parser_AST.CalcStep + (rel2, just, next_expr)) -> + let just1 = + let uu___5 = is_impl rel2 in + if uu___5 + then + let uu___6 = + push_impl just.FStarC_Parser_AST.range in + let uu___7 = + let uu___8 = + let uu___9 = FStarC_Parser_AST.thunk just in + (uu___9, FStarC_Parser_AST.Nothing) in + [uu___8] in + FStarC_Parser_AST.mkApp uu___6 uu___7 + just.FStarC_Parser_AST.range + else just in + let pf = + let uu___5 = step rel2.FStarC_Parser_AST.range in + let uu___6 = + let uu___7 = + let uu___8 = + wild rel2.FStarC_Parser_AST.range in + (uu___8, FStarC_Parser_AST.Hash) in + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = eta_and_annot rel2 in + (uu___12, FStarC_Parser_AST.Nothing) in + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + FStarC_Parser_AST.thunk e1 in + (uu___15, + FStarC_Parser_AST.Nothing) in + let uu___15 = + let uu___16 = + let uu___17 = + FStarC_Parser_AST.thunk just1 in + (uu___17, + FStarC_Parser_AST.Nothing) in + [uu___16] in + uu___14 :: uu___15 in + (next_expr, FStarC_Parser_AST.Nothing) + :: uu___13 in + uu___11 :: uu___12 in + (prev, FStarC_Parser_AST.Hash) :: uu___10 in + (init_expr, FStarC_Parser_AST.Hash) :: uu___9 in + uu___7 :: uu___8 in + FStarC_Parser_AST.mkApp uu___5 uu___6 + FStarC_Compiler_Range_Type.dummyRange in + (pf, next_expr)) (e, init_expr) steps in + (match uu___2 with + | (e1, uu___3) -> + let e2 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Parser_AST.thunk e1 in + (uu___8, FStarC_Parser_AST.Nothing) in + [uu___7] in + (last_expr, FStarC_Parser_AST.Hash) :: uu___6 in + (init_expr, FStarC_Parser_AST.Hash) :: uu___5 in + FStarC_Parser_AST.mkApp finish uu___4 + top.FStarC_Parser_AST.range in + desugar_term_maybe_top top_level env e2) + | FStarC_Parser_AST.IntroForall (bs, p, e) -> + let uu___2 = desugar_binders env bs in + (match uu___2 with + | (env', bs1) -> + let p1 = desugar_term env' p in + let e1 = desugar_term env' e in + let mk_forall_intro t p2 pf = + let head = + let uu___3 = + FStarC_Syntax_Syntax.lid_and_dd_as_fv + FStarC_Parser_Const.forall_intro_lid + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___3 in + let args = + [(t, FStar_Pervasives_Native.None); + (p2, FStar_Pervasives_Native.None); + (pf, FStar_Pervasives_Native.None)] in + FStarC_Syntax_Syntax.mk_Tm_app head args + top.FStarC_Parser_AST.range in + let rec aux bs2 = + match bs2 with + | [] -> + let sq_p = + FStarC_Syntax_Util.mk_squash + FStarC_Syntax_Syntax.U_unknown p1 in + FStarC_Syntax_Util.ascribe e1 + ((FStar_Pervasives.Inl sq_p), + FStar_Pervasives_Native.None, false) + | b::bs3 -> + let tail = aux bs3 in + let x = unqual_bv_of_binder b in + let uu___3 = + let uu___4 = + FStarC_Syntax_Util.close_forall_no_univs bs3 p1 in + FStarC_Syntax_Util.abs [b] uu___4 + FStar_Pervasives_Native.None in + let uu___4 = + FStarC_Syntax_Util.abs [b] tail + FStar_Pervasives_Native.None in + mk_forall_intro x.FStarC_Syntax_Syntax.sort uu___3 + uu___4 in + let uu___3 = aux bs1 in (uu___3, noaqs)) + | FStarC_Parser_AST.IntroExists (bs, p, vs, e) -> + let uu___2 = desugar_binders env bs in + (match uu___2 with + | (env', bs1) -> + let p1 = desugar_term env' p in + let vs1 = FStarC_Compiler_List.map (desugar_term env) vs in + let e1 = desugar_term env e in + let mk_exists_intro t p2 v e2 = + let head = + let uu___3 = + FStarC_Syntax_Syntax.lid_and_dd_as_fv + FStarC_Parser_Const.exists_intro_lid + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___3 in + let args = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = mk_thunk e2 in + (uu___7, FStar_Pervasives_Native.None) in + [uu___6] in + (v, FStar_Pervasives_Native.None) :: uu___5 in + (p2, FStar_Pervasives_Native.None) :: uu___4 in + (t, FStar_Pervasives_Native.None) :: uu___3 in + FStarC_Syntax_Syntax.mk_Tm_app head args + top.FStarC_Parser_AST.range in + let rec aux bs2 vs2 sub token = + match (bs2, vs2) with + | ([], []) -> token + | (b::bs3, v::vs3) -> + let x = unqual_bv_of_binder b in + let token1 = + let uu___3 = + FStarC_Syntax_Subst.subst_binders + ((FStarC_Syntax_Syntax.NT (x, v)) :: sub) bs3 in + aux uu___3 vs3 ((FStarC_Syntax_Syntax.NT (x, v)) :: + sub) token in + let token2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Subst.subst sub p1 in + FStarC_Syntax_Util.close_exists_no_univs bs3 + uu___5 in + FStarC_Syntax_Util.abs [b] uu___4 + FStar_Pervasives_Native.None in + mk_exists_intro x.FStarC_Syntax_Syntax.sort uu___3 + v token1 in + token2 + | uu___3 -> + FStarC_Errors.raise_error + FStarC_Parser_AST.hasRange_term top + FStarC_Errors_Codes.Fatal_UnexpectedTerm () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Unexpected number of instantiations in _intro_ exists") in + let uu___3 = aux bs1 vs1 [] e1 in (uu___3, noaqs)) + | FStarC_Parser_AST.IntroImplies (p, q, x, e) -> + let p1 = desugar_term env p in + let q1 = desugar_term env q in + let uu___2 = desugar_binders env [x] in + (match uu___2 with + | (env', x1::[]) -> + let e1 = desugar_term env' e in + let head = + let uu___3 = + FStarC_Syntax_Syntax.lid_and_dd_as_fv + FStarC_Parser_Const.implies_intro_lid + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___3 in + let args = + let uu___3 = + let uu___4 = + let uu___5 = mk_thunk q1 in + (uu___5, FStar_Pervasives_Native.None) in + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Syntax_Util.abs [x1] e1 + FStar_Pervasives_Native.None in + (uu___7, FStar_Pervasives_Native.None) in + [uu___6] in + uu___4 :: uu___5 in + (p1, FStar_Pervasives_Native.None) :: uu___3 in + let uu___3 = + FStarC_Syntax_Syntax.mk_Tm_app head args + top.FStarC_Parser_AST.range in + (uu___3, noaqs)) + | FStarC_Parser_AST.IntroOr (lr, p, q, e) -> + let p1 = desugar_term env p in + let q1 = desugar_term env q in + let e1 = desugar_term env e in + let lid = + if lr + then FStarC_Parser_Const.or_intro_left_lid + else FStarC_Parser_Const.or_intro_right_lid in + let head = + let uu___2 = + FStarC_Syntax_Syntax.lid_and_dd_as_fv lid + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___2 in + let args = + let uu___2 = + let uu___3 = + let uu___4 = mk_thunk q1 in + (uu___4, FStar_Pervasives_Native.None) in + let uu___4 = + let uu___5 = + let uu___6 = mk_thunk e1 in + (uu___6, FStar_Pervasives_Native.None) in + [uu___5] in + uu___3 :: uu___4 in + (p1, FStar_Pervasives_Native.None) :: uu___2 in + let uu___2 = + FStarC_Syntax_Syntax.mk_Tm_app head args + top.FStarC_Parser_AST.range in + (uu___2, noaqs) + | FStarC_Parser_AST.IntroAnd (p, q, e1, e2) -> + let p1 = desugar_term env p in + let q1 = desugar_term env q in + let e11 = desugar_term env e1 in + let e21 = desugar_term env e2 in + let head = + let uu___2 = + FStarC_Syntax_Syntax.lid_and_dd_as_fv + FStarC_Parser_Const.and_intro_lid + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___2 in + let args = + let uu___2 = + let uu___3 = + let uu___4 = mk_thunk q1 in + (uu___4, FStar_Pervasives_Native.None) in + let uu___4 = + let uu___5 = + let uu___6 = mk_thunk e11 in + (uu___6, FStar_Pervasives_Native.None) in + let uu___6 = + let uu___7 = + let uu___8 = mk_thunk e21 in + (uu___8, FStar_Pervasives_Native.None) in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + (p1, FStar_Pervasives_Native.None) :: uu___2 in + let uu___2 = + FStarC_Syntax_Syntax.mk_Tm_app head args + top.FStarC_Parser_AST.range in + (uu___2, noaqs) + | FStarC_Parser_AST.ElimForall (bs, p, vs) -> + let uu___2 = desugar_binders env bs in + (match uu___2 with + | (env', bs1) -> + let p1 = desugar_term env' p in + let vs1 = FStarC_Compiler_List.map (desugar_term env) vs in + let mk_forall_elim a p2 v tok = + let head = + let uu___3 = + FStarC_Syntax_Syntax.lid_and_dd_as_fv + FStarC_Parser_Const.forall_elim_lid + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___3 in + let args = + let uu___3 = + let uu___4 = + FStarC_Syntax_Syntax.as_aqual_implicit true in + (a, uu___4) in + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.as_aqual_implicit true in + (p2, uu___6) in + [uu___5; + (v, FStar_Pervasives_Native.None); + (tok, FStar_Pervasives_Native.None)] in + uu___3 :: uu___4 in + FStarC_Syntax_Syntax.mk_Tm_app head args + tok.FStarC_Syntax_Syntax.pos in + let rec aux bs2 vs2 sub token = + match (bs2, vs2) with + | ([], []) -> token + | (b::bs3, v::vs3) -> + let x = unqual_bv_of_binder b in + let token1 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Subst.subst sub p1 in + FStarC_Syntax_Util.close_forall_no_univs bs3 + uu___5 in + FStarC_Syntax_Util.abs [b] uu___4 + FStar_Pervasives_Native.None in + mk_forall_elim x.FStarC_Syntax_Syntax.sort uu___3 v + token in + let sub1 = (FStarC_Syntax_Syntax.NT (x, v)) :: sub in + let uu___3 = + FStarC_Syntax_Subst.subst_binders sub1 bs3 in + aux uu___3 vs3 sub1 token1 + | uu___3 -> + FStarC_Errors.raise_error + FStarC_Parser_AST.hasRange_term top + FStarC_Errors_Codes.Fatal_UnexpectedTerm () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Unexpected number of instantiations in _elim_forall_") in + let range = + FStarC_Compiler_List.fold_right + (fun bs2 -> + fun r -> + let uu___3 = + FStarC_Syntax_Syntax.range_of_bv + bs2.FStarC_Syntax_Syntax.binder_bv in + FStarC_Compiler_Range_Ops.union_ranges uu___3 r) + bs1 p1.FStarC_Syntax_Syntax.pos in + let uu___3 = + aux bs1 vs1 [] + { + FStarC_Syntax_Syntax.n = + (FStarC_Syntax_Util.exp_unit.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = range; + FStarC_Syntax_Syntax.vars = + (FStarC_Syntax_Util.exp_unit.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (FStarC_Syntax_Util.exp_unit.FStarC_Syntax_Syntax.hash_code) + } in + (uu___3, noaqs)) + | FStarC_Parser_AST.ElimExists (binders, p, q, binder, e) -> + let uu___2 = desugar_binders env binders in + (match uu___2 with + | (env', bs) -> + let p1 = desugar_term env' p in + let q1 = desugar_term env q in + let sq_q = + FStarC_Syntax_Util.mk_squash + FStarC_Syntax_Syntax.U_unknown q1 in + let uu___3 = desugar_binders env' [binder] in + (match uu___3 with + | (env'', b_pf_p::[]) -> + let e1 = desugar_term env'' e in + let rec mk_exists bs1 p2 = + match bs1 with + | [] -> failwith "Impossible" + | b::[] -> + let x = b.FStarC_Syntax_Syntax.binder_bv in + let head = + let uu___4 = + FStarC_Syntax_Syntax.lid_and_dd_as_fv + FStarC_Parser_Const.exists_lid + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___4 in + let args = + let uu___4 = + let uu___5 = + FStarC_Syntax_Syntax.as_aqual_implicit + true in + ((x.FStarC_Syntax_Syntax.sort), uu___5) in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Compiler_List.hd bs1 in + [uu___9] in + FStarC_Syntax_Util.abs uu___8 p2 + FStar_Pervasives_Native.None in + (uu___7, FStar_Pervasives_Native.None) in + [uu___6] in + uu___4 :: uu___5 in + FStarC_Syntax_Syntax.mk_Tm_app head args + p2.FStarC_Syntax_Syntax.pos + | b::bs2 -> + let body = mk_exists bs2 p2 in + mk_exists [b] body in + let mk_exists_elim t x_p s_ex_p f r = + let head = + let uu___4 = + FStarC_Syntax_Syntax.lid_and_dd_as_fv + FStarC_Parser_Const.exists_elim_lid + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___4 in + let args = + let uu___4 = + let uu___5 = + FStarC_Syntax_Syntax.as_aqual_implicit true in + (t, uu___5) in + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Syntax_Syntax.as_aqual_implicit true in + (x_p, uu___7) in + [uu___6; + (s_ex_p, FStar_Pervasives_Native.None); + (f, FStar_Pervasives_Native.None)] in + uu___4 :: uu___5 in + FStarC_Syntax_Syntax.mk_Tm_app head args r in + let rec aux binders1 squash_token = + match binders1 with + | [] -> + FStarC_Errors.raise_error + FStarC_Parser_AST.hasRange_term top + FStarC_Errors_Codes.Fatal_UnexpectedTerm () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "Empty binders in ELIM_EXISTS") + | b::[] -> + let x = unqual_bv_of_binder b in + let uu___4 = + FStarC_Syntax_Util.abs [b] p1 + FStar_Pervasives_Native.None in + let uu___5 = + let uu___6 = + FStarC_Syntax_Util.ascribe e1 + ((FStar_Pervasives.Inl sq_q), + FStar_Pervasives_Native.None, false) in + FStarC_Syntax_Util.abs [b; b_pf_p] uu___6 + FStar_Pervasives_Native.None in + mk_exists_elim x.FStarC_Syntax_Syntax.sort + uu___4 squash_token uu___5 + squash_token.FStarC_Syntax_Syntax.pos + | b::bs1 -> + let pf_i = + let uu___4 = + let uu___5 = + FStarC_Syntax_Syntax.range_of_bv + b.FStarC_Syntax_Syntax.binder_bv in + FStar_Pervasives_Native.Some uu___5 in + FStarC_Syntax_Syntax.gen_bv "pf" uu___4 + FStarC_Syntax_Syntax.tun in + let k = + let uu___4 = + FStarC_Syntax_Syntax.bv_to_name pf_i in + aux bs1 uu___4 in + let x = unqual_bv_of_binder b in + let uu___4 = + let uu___5 = mk_exists bs1 p1 in + FStarC_Syntax_Util.abs [b] uu___5 + FStar_Pervasives_Native.None in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Syntax.mk_binder pf_i in + [uu___8] in + b :: uu___7 in + FStarC_Syntax_Util.abs uu___6 k + FStar_Pervasives_Native.None in + mk_exists_elim x.FStarC_Syntax_Syntax.sort + uu___4 squash_token uu___5 + squash_token.FStarC_Syntax_Syntax.pos in + let range = + FStarC_Compiler_List.fold_right + (fun bs1 -> + fun r -> + let uu___4 = + FStarC_Syntax_Syntax.range_of_bv + bs1.FStarC_Syntax_Syntax.binder_bv in + FStarC_Compiler_Range_Ops.union_ranges uu___4 + r) bs p1.FStarC_Syntax_Syntax.pos in + let uu___4 = + aux bs + { + FStarC_Syntax_Syntax.n = + (FStarC_Syntax_Util.exp_unit.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = range; + FStarC_Syntax_Syntax.vars = + (FStarC_Syntax_Util.exp_unit.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (FStarC_Syntax_Util.exp_unit.FStarC_Syntax_Syntax.hash_code) + } in + (uu___4, noaqs))) + | FStarC_Parser_AST.ElimImplies (p, q, e) -> + let p1 = desugar_term env p in + let q1 = desugar_term env q in + let e1 = desugar_term env e in + let head = + let uu___2 = + FStarC_Syntax_Syntax.lid_and_dd_as_fv + FStarC_Parser_Const.implies_elim_lid + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___2 in + let args = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Compiler_Range_Ops.union_ranges + p1.FStarC_Syntax_Syntax.pos + q1.FStarC_Syntax_Syntax.pos in + { + FStarC_Syntax_Syntax.n = + (FStarC_Syntax_Util.exp_unit.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = uu___6; + FStarC_Syntax_Syntax.vars = + (FStarC_Syntax_Util.exp_unit.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (FStarC_Syntax_Util.exp_unit.FStarC_Syntax_Syntax.hash_code) + } in + (uu___5, FStar_Pervasives_Native.None) in + let uu___5 = + let uu___6 = + let uu___7 = mk_thunk e1 in + (uu___7, FStar_Pervasives_Native.None) in + [uu___6] in + uu___4 :: uu___5 in + (q1, FStar_Pervasives_Native.None) :: uu___3 in + (p1, FStar_Pervasives_Native.None) :: uu___2 in + let uu___2 = + FStarC_Syntax_Syntax.mk_Tm_app head args + top.FStarC_Parser_AST.range in + (uu___2, noaqs) + | FStarC_Parser_AST.ElimOr (p, q, r, x, e1, y, e2) -> + let p1 = desugar_term env p in + let q1 = desugar_term env q in + let r1 = desugar_term env r in + let uu___2 = desugar_binders env [x] in + (match uu___2 with + | (env_x, x1::[]) -> + let e11 = desugar_term env_x e1 in + let uu___3 = desugar_binders env [y] in + (match uu___3 with + | (env_y, y1::[]) -> + let e21 = desugar_term env_y e2 in + let head = + let uu___4 = + FStarC_Syntax_Syntax.lid_and_dd_as_fv + FStarC_Parser_Const.or_elim_lid + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___4 in + let extra_binder = + let uu___4 = + FStarC_Syntax_Syntax.new_bv + FStar_Pervasives_Native.None + FStarC_Syntax_Syntax.tun in + FStarC_Syntax_Syntax.mk_binder uu___4 in + let args = + let uu___4 = + let uu___5 = + let uu___6 = mk_thunk q1 in + (uu___6, FStar_Pervasives_Native.None) in + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Compiler_Range_Ops.union_ranges + p1.FStarC_Syntax_Syntax.pos + q1.FStarC_Syntax_Syntax.pos in + { + FStarC_Syntax_Syntax.n = + (FStarC_Syntax_Util.exp_unit.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = uu___10; + FStarC_Syntax_Syntax.vars = + (FStarC_Syntax_Util.exp_unit.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (FStarC_Syntax_Util.exp_unit.FStarC_Syntax_Syntax.hash_code) + } in + (uu___9, FStar_Pervasives_Native.None) in + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Syntax_Util.abs [x1] e11 + FStar_Pervasives_Native.None in + (uu___11, FStar_Pervasives_Native.None) in + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Syntax_Util.abs + [extra_binder; y1] e21 + FStar_Pervasives_Native.None in + (uu___13, FStar_Pervasives_Native.None) in + [uu___12] in + uu___10 :: uu___11 in + uu___8 :: uu___9 in + (r1, FStar_Pervasives_Native.None) :: uu___7 in + uu___5 :: uu___6 in + (p1, FStar_Pervasives_Native.None) :: uu___4 in + let uu___4 = + FStarC_Syntax_Syntax.mk_Tm_app head args + top.FStarC_Parser_AST.range in + (uu___4, noaqs))) + | FStarC_Parser_AST.ElimAnd (p, q, r, x, y, e) -> + let p1 = desugar_term env p in + let q1 = desugar_term env q in + let r1 = desugar_term env r in + let uu___2 = desugar_binders env [x; y] in + (match uu___2 with + | (env', x1::y1::[]) -> + let e1 = desugar_term env' e in + let head = + let uu___3 = + FStarC_Syntax_Syntax.lid_and_dd_as_fv + FStarC_Parser_Const.and_elim_lid + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___3 in + let args = + let uu___3 = + let uu___4 = + let uu___5 = mk_thunk q1 in + (uu___5, FStar_Pervasives_Native.None) in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Compiler_Range_Ops.union_ranges + p1.FStarC_Syntax_Syntax.pos + q1.FStarC_Syntax_Syntax.pos in + { + FStarC_Syntax_Syntax.n = + (FStarC_Syntax_Util.exp_unit.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = uu___9; + FStarC_Syntax_Syntax.vars = + (FStarC_Syntax_Util.exp_unit.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (FStarC_Syntax_Util.exp_unit.FStarC_Syntax_Syntax.hash_code) + } in + (uu___8, FStar_Pervasives_Native.None) in + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Syntax_Util.abs [x1; y1] e1 + FStar_Pervasives_Native.None in + (uu___10, FStar_Pervasives_Native.None) in + [uu___9] in + uu___7 :: uu___8 in + (r1, FStar_Pervasives_Native.None) :: uu___6 in + uu___4 :: uu___5 in + (p1, FStar_Pervasives_Native.None) :: uu___3 in + let uu___3 = + FStarC_Syntax_Syntax.mk_Tm_app head args + top.FStarC_Parser_AST.range in + (uu___3, noaqs)) + | FStarC_Parser_AST.ListLiteral ts -> + let nil r = + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.Construct + (FStarC_Parser_Const.nil_lid, [])) r + FStarC_Parser_AST.Expr in + let cons r hd tl = + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.Construct + (FStarC_Parser_Const.cons_lid, + [(hd, FStarC_Parser_AST.Nothing); + (tl, FStarC_Parser_AST.Nothing)])) r + FStarC_Parser_AST.Expr in + let t' = + let uu___2 = nil top.FStarC_Parser_AST.range in + FStarC_Compiler_List.fold_right + (cons top.FStarC_Parser_AST.range) ts uu___2 in + desugar_term_aq env t' + | FStarC_Parser_AST.SeqLiteral ts -> + let nil r = + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.Var FStarC_Parser_Const.seq_empty_lid) r + FStarC_Parser_AST.Expr in + let cons r hd tl = + let uu___2 = + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.Var FStarC_Parser_Const.seq_cons_lid) r + FStarC_Parser_AST.Expr in + FStarC_Parser_AST.mkApp uu___2 + [(hd, FStarC_Parser_AST.Nothing); + (tl, FStarC_Parser_AST.Nothing)] r in + let t' = + let uu___2 = nil top.FStarC_Parser_AST.range in + FStarC_Compiler_List.fold_right + (cons top.FStarC_Parser_AST.range) ts uu___2 in + desugar_term_aq env t' + | uu___2 when + top.FStarC_Parser_AST.level = FStarC_Parser_AST.Formula -> + let uu___3 = desugar_formula env top in (uu___3, noaqs) + | uu___2 -> + let uu___3 = + let uu___4 = FStarC_Parser_AST.term_to_string top in + Prims.strcat "Unexpected term: " uu___4 in + FStarC_Errors.raise_error FStarC_Parser_AST.hasRange_term top + FStarC_Errors_Codes.Fatal_UnexpectedTerm () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___3)) +and (desugar_match_returns : + env_t -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + (FStarC_Ident.ident FStar_Pervasives_Native.option * + FStarC_Parser_AST.term * Prims.bool) FStar_Pervasives_Native.option + -> + ((FStarC_Syntax_Syntax.binder * + ((FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax, + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax) + FStar_Pervasives.either * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax FStar_Pervasives_Native.option * + Prims.bool)) FStar_Pervasives_Native.option * + (FStarC_Syntax_Syntax.bv * FStarC_Syntax_Syntax.term) Prims.list)) + = + fun env -> + fun scrutinee -> + fun asc_opt -> + match asc_opt with + | FStar_Pervasives_Native.None -> (FStar_Pervasives_Native.None, []) + | FStar_Pervasives_Native.Some asc -> + let uu___ = asc in + (match uu___ with + | (asc_b, asc_tc, asc_use_eq) -> + let uu___1 = + match asc_b with + | FStar_Pervasives_Native.None -> + let bv = + FStarC_Syntax_Syntax.gen_bv + FStarC_Parser_Const.match_returns_def_name + (FStar_Pervasives_Native.Some + (scrutinee.FStarC_Syntax_Syntax.pos)) + FStarC_Syntax_Syntax.tun in + let uu___2 = FStarC_Syntax_Syntax.mk_binder bv in + (env, uu___2) + | FStar_Pervasives_Native.Some b -> + let uu___2 = FStarC_Syntax_DsEnv.push_bv env b in + (match uu___2 with + | (env1, bv) -> + let uu___3 = FStarC_Syntax_Syntax.mk_binder bv in + (env1, uu___3)) in + (match uu___1 with + | (env_asc, b) -> + let uu___2 = + desugar_ascription env_asc asc_tc + FStar_Pervasives_Native.None asc_use_eq in + (match uu___2 with + | (asc1, aq) -> + let asc2 = + let uu___3 = + let uu___4 = + FStarC_Syntax_Util.unascribe scrutinee in + uu___4.FStarC_Syntax_Syntax.n in + match uu___3 with + | FStarC_Syntax_Syntax.Tm_name sbv -> + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Syntax_Syntax.bv_to_name + b.FStarC_Syntax_Syntax.binder_bv in + (sbv, uu___7) in + FStarC_Syntax_Syntax.NT uu___6 in + [uu___5] in + FStarC_Syntax_Subst.subst_ascription uu___4 + asc1 + | uu___4 -> asc1 in + let asc3 = + FStarC_Syntax_Subst.close_ascription [b] asc2 in + let b1 = + let uu___3 = + FStarC_Syntax_Subst.close_binders [b] in + FStarC_Compiler_List.hd uu___3 in + ((FStar_Pervasives_Native.Some (b1, asc3)), aq)))) +and (desugar_ascription : + env_t -> + FStarC_Parser_AST.term -> + FStarC_Parser_AST.term FStar_Pervasives_Native.option -> + Prims.bool -> (FStarC_Syntax_Syntax.ascription * antiquotations_temp)) + = + fun env -> + fun t -> + fun tac_opt -> + fun use_eq -> + let uu___ = + let uu___1 = is_comp_type env t in + if uu___1 + then + (if use_eq + then + FStarC_Errors.raise_error FStarC_Parser_AST.hasRange_term t + FStarC_Errors_Codes.Fatal_NotSupported () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Equality ascription with computation types is not supported yet") + else + (let comp = + desugar_comp t.FStarC_Parser_AST.range true env t in + ((FStar_Pervasives.Inr comp), []))) + else + (let uu___3 = desugar_term_aq env t in + match uu___3 with + | (tm, aq) -> ((FStar_Pervasives.Inl tm), aq)) in + match uu___ with + | (annot, aq0) -> + let uu___1 = + let uu___2 = + FStarC_Compiler_Util.map_opt tac_opt (desugar_term env) in + (annot, uu___2, use_eq) in + (uu___1, aq0) +and (desugar_args : + FStarC_Syntax_DsEnv.env -> + (FStarC_Parser_AST.term * FStarC_Parser_AST.imp) Prims.list -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.arg_qualifier + FStar_Pervasives_Native.option) Prims.list) + = + fun env -> + fun args -> + FStarC_Compiler_List.map + (fun uu___ -> + match uu___ with + | (a, imp) -> + let uu___1 = desugar_term env a in arg_withimp_t imp uu___1) + args +and (desugar_comp : + FStarC_Compiler_Range_Type.range -> + Prims.bool -> + FStarC_Syntax_DsEnv.env -> + FStarC_Parser_AST.term -> FStarC_Syntax_Syntax.comp) + = + fun r -> + fun allow_type_promotion -> + fun env -> + fun t -> + let fail code msg = + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range r + code () (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic msg) in + let is_requires uu___ = + match uu___ with + | (t1, uu___1) -> + let uu___2 = + let uu___3 = unparen t1 in uu___3.FStarC_Parser_AST.tm in + (match uu___2 with + | FStarC_Parser_AST.Requires uu___3 -> true + | uu___3 -> false) in + let is_ensures uu___ = + match uu___ with + | (t1, uu___1) -> + let uu___2 = + let uu___3 = unparen t1 in uu___3.FStarC_Parser_AST.tm in + (match uu___2 with + | FStarC_Parser_AST.Ensures uu___3 -> true + | uu___3 -> false) in + let is_decreases uu___ = + match uu___ with + | (t1, uu___1) -> + let uu___2 = + let uu___3 = unparen t1 in uu___3.FStarC_Parser_AST.tm in + (match uu___2 with + | FStarC_Parser_AST.Decreases uu___3 -> true + | uu___3 -> false) in + let is_smt_pat1 t1 = + let uu___ = + let uu___1 = unparen t1 in uu___1.FStarC_Parser_AST.tm in + match uu___ with + | FStarC_Parser_AST.Construct (smtpat, uu___1) -> + FStarC_Compiler_Util.for_some + (fun s -> + let uu___2 = FStarC_Ident.string_of_lid smtpat in + uu___2 = s) ["SMTPat"; "SMTPatT"; "SMTPatOr"] + | FStarC_Parser_AST.Var smtpat -> + FStarC_Compiler_Util.for_some + (fun s -> + let uu___1 = FStarC_Ident.string_of_lid smtpat in + uu___1 = s) ["smt_pat"; "smt_pat_or"] + | uu___1 -> false in + let is_smt_pat uu___ = + match uu___ with + | (t1, uu___1) -> + let uu___2 = + let uu___3 = unparen t1 in uu___3.FStarC_Parser_AST.tm in + (match uu___2 with + | FStarC_Parser_AST.ListLiteral ts -> + FStarC_Compiler_Util.for_all is_smt_pat1 ts + | uu___3 -> false) in + let pre_process_comp_typ t1 = + let uu___ = head_and_args t1 in + match uu___ with + | (head, args) -> + (match head.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Name lemma when + let uu___1 = + let uu___2 = FStarC_Ident.ident_of_lid lemma in + FStarC_Ident.string_of_id uu___2 in + uu___1 = "Lemma" -> + let unit_tm = + let uu___1 = + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.Name + FStarC_Parser_Const.unit_lid) + t1.FStarC_Parser_AST.range + FStarC_Parser_AST.Type_level in + (uu___1, FStarC_Parser_AST.Nothing) in + let nil_pat = + let uu___1 = + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.Name + FStarC_Parser_Const.nil_lid) + t1.FStarC_Parser_AST.range FStarC_Parser_AST.Expr in + (uu___1, FStarC_Parser_AST.Nothing) in + let req_true = + let req = + let uu___1 = + let uu___2 = + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.Name + FStarC_Parser_Const.true_lid) + t1.FStarC_Parser_AST.range + FStarC_Parser_AST.Formula in + (uu___2, FStar_Pervasives_Native.None) in + FStarC_Parser_AST.Requires uu___1 in + let uu___1 = + FStarC_Parser_AST.mk_term req + t1.FStarC_Parser_AST.range + FStarC_Parser_AST.Type_level in + (uu___1, FStarC_Parser_AST.Nothing) in + let thunk_ens uu___1 = + match uu___1 with + | (e, i) -> + let uu___2 = FStarC_Parser_AST.thunk e in + (uu___2, i) in + let fail_lemma uu___1 = + let expected_one_of = + ["Lemma post"; + "Lemma (ensures post)"; + "Lemma (requires pre) (ensures post)"; + "Lemma post [SMTPat ...]"; + "Lemma (ensures post) [SMTPat ...]"; + "Lemma (ensures post) (decreases d)"; + "Lemma (ensures post) (decreases d) [SMTPat ...]"; + "Lemma (requires pre) (ensures post) (decreases d)"; + "Lemma (requires pre) (ensures post) [SMTPat ...]"; + "Lemma (requires pre) (ensures post) (decreases d) [SMTPat ...]"] in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Errors_Msg.text + "Invalid arguments to 'Lemma'; expected one of the following" in + let uu___5 = + let uu___6 = + FStarC_Compiler_List.map + FStarC_Pprint.doc_of_string expected_one_of in + FStarC_Errors_Msg.sublist FStarC_Pprint.empty + uu___6 in + FStarC_Pprint.op_Hat_Hat uu___4 uu___5 in + [uu___3] in + FStarC_Errors.raise_error + FStarC_Parser_AST.hasRange_term t1 + FStarC_Errors_Codes.Fatal_InvalidLemmaArgument () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___2) in + let args1 = + match args with + | [] -> fail_lemma () + | req::[] when is_requires req -> fail_lemma () + | smtpat::[] when is_smt_pat smtpat -> fail_lemma () + | dec::[] when is_decreases dec -> fail_lemma () + | ens::[] -> + let uu___1 = + let uu___2 = + let uu___3 = thunk_ens ens in + [uu___3; nil_pat] in + req_true :: uu___2 in + unit_tm :: uu___1 + | req::ens::[] when + (is_requires req) && (is_ensures ens) -> + let uu___1 = + let uu___2 = + let uu___3 = thunk_ens ens in + [uu___3; nil_pat] in + req :: uu___2 in + unit_tm :: uu___1 + | ens::smtpat::[] when + (((let uu___1 = is_requires ens in + Prims.op_Negation uu___1) && + (let uu___1 = is_smt_pat ens in + Prims.op_Negation uu___1)) + && + (let uu___1 = is_decreases ens in + Prims.op_Negation uu___1)) + && (is_smt_pat smtpat) + -> + let uu___1 = + let uu___2 = + let uu___3 = thunk_ens ens in [uu___3; smtpat] in + req_true :: uu___2 in + unit_tm :: uu___1 + | ens::dec::[] when + (is_ensures ens) && (is_decreases dec) -> + let uu___1 = + let uu___2 = + let uu___3 = thunk_ens ens in + [uu___3; nil_pat; dec] in + req_true :: uu___2 in + unit_tm :: uu___1 + | ens::dec::smtpat::[] when + ((is_ensures ens) && (is_decreases dec)) && + (is_smt_pat smtpat) + -> + let uu___1 = + let uu___2 = + let uu___3 = thunk_ens ens in + [uu___3; smtpat; dec] in + req_true :: uu___2 in + unit_tm :: uu___1 + | req::ens::dec::[] when + ((is_requires req) && (is_ensures ens)) && + (is_decreases dec) + -> + let uu___1 = + let uu___2 = + let uu___3 = thunk_ens ens in + [uu___3; nil_pat; dec] in + req :: uu___2 in + unit_tm :: uu___1 + | req::ens::smtpat::[] when + ((is_requires req) && (is_ensures ens)) && + (is_smt_pat smtpat) + -> + let uu___1 = + let uu___2 = + let uu___3 = thunk_ens ens in [uu___3; smtpat] in + req :: uu___2 in + unit_tm :: uu___1 + | req::ens::dec::smtpat::[] when + (((is_requires req) && (is_ensures ens)) && + (is_smt_pat smtpat)) + && (is_decreases dec) + -> + let uu___1 = + let uu___2 = + let uu___3 = thunk_ens ens in + [uu___3; dec; smtpat] in + req :: uu___2 in + unit_tm :: uu___1 + | _other -> fail_lemma () in + let head_and_attributes = + FStarC_Syntax_DsEnv.fail_or env + (FStarC_Syntax_DsEnv.try_lookup_effect_name_and_attributes + env) lemma in + (head_and_attributes, args1) + | FStarC_Parser_AST.Name l when + FStarC_Syntax_DsEnv.is_effect_name env l -> + let uu___1 = + FStarC_Syntax_DsEnv.fail_or env + (FStarC_Syntax_DsEnv.try_lookup_effect_name_and_attributes + env) l in + (uu___1, args) + | FStarC_Parser_AST.Name l when + (let uu___1 = FStarC_Syntax_DsEnv.current_module env in + FStarC_Ident.lid_equals uu___1 + FStarC_Parser_Const.prims_lid) + && + (let uu___1 = + let uu___2 = FStarC_Ident.ident_of_lid l in + FStarC_Ident.string_of_id uu___2 in + uu___1 = "Tot") + -> + let uu___1 = + let uu___2 = + FStarC_Ident.set_lid_range + FStarC_Parser_Const.effect_Tot_lid + head.FStarC_Parser_AST.range in + (uu___2, []) in + (uu___1, args) + | FStarC_Parser_AST.Name l when + (let uu___1 = FStarC_Syntax_DsEnv.current_module env in + FStarC_Ident.lid_equals uu___1 + FStarC_Parser_Const.prims_lid) + && + (let uu___1 = + let uu___2 = FStarC_Ident.ident_of_lid l in + FStarC_Ident.string_of_id uu___2 in + uu___1 = "GTot") + -> + let uu___1 = + let uu___2 = + FStarC_Ident.set_lid_range + FStarC_Parser_Const.effect_GTot_lid + head.FStarC_Parser_AST.range in + (uu___2, []) in + (uu___1, args) + | FStarC_Parser_AST.Name l when + ((let uu___1 = + let uu___2 = FStarC_Ident.ident_of_lid l in + FStarC_Ident.string_of_id uu___2 in + uu___1 = "Type") || + (let uu___1 = + let uu___2 = FStarC_Ident.ident_of_lid l in + FStarC_Ident.string_of_id uu___2 in + uu___1 = "Type0")) + || + (let uu___1 = + let uu___2 = FStarC_Ident.ident_of_lid l in + FStarC_Ident.string_of_id uu___2 in + uu___1 = "Effect") + -> + let uu___1 = + let uu___2 = + FStarC_Ident.set_lid_range + FStarC_Parser_Const.effect_Tot_lid + head.FStarC_Parser_AST.range in + (uu___2, []) in + (uu___1, [(t1, FStarC_Parser_AST.Nothing)]) + | uu___1 when allow_type_promotion -> + let default_effect = + let uu___2 = FStarC_Options.ml_ish () in + if uu___2 + then FStarC_Parser_Const.effect_ML_lid () + else + ((let uu___5 = + FStarC_Options.warn_default_effects () in + if uu___5 + then + FStarC_Errors.log_issue + FStarC_Parser_AST.hasRange_term head + FStarC_Errors_Codes.Warning_UseDefaultEffect + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "Using default effect Tot") + else ()); + FStarC_Parser_Const.effect_Tot_lid) in + let uu___2 = + let uu___3 = + FStarC_Ident.set_lid_range default_effect + head.FStarC_Parser_AST.range in + (uu___3, []) in + (uu___2, [(t1, FStarC_Parser_AST.Nothing)]) + | uu___1 -> + FStarC_Errors.raise_error + FStarC_Parser_AST.hasRange_term t1 + FStarC_Errors_Codes.Fatal_EffectNotFound () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "Expected an effect constructor")) in + let uu___ = pre_process_comp_typ t in + match uu___ with + | ((eff, cattributes), args) -> + (if (FStarC_Compiler_List.length args) = Prims.int_zero + then + (let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Ident.showable_lident eff in + FStarC_Compiler_Util.format1 + "Not enough args to effect %s" uu___3 in + fail FStarC_Errors_Codes.Fatal_NotEnoughArgsToEffect uu___2) + else (); + (let is_universe uu___2 = + match uu___2 with + | (uu___3, imp) -> imp = FStarC_Parser_AST.UnivApp in + let uu___2 = FStarC_Compiler_Util.take is_universe args in + match uu___2 with + | (universes, args1) -> + let universes1 = + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with | (u, imp) -> desugar_universe u) + universes in + let uu___3 = + let uu___4 = FStarC_Compiler_List.hd args1 in + let uu___5 = FStarC_Compiler_List.tl args1 in + (uu___4, uu___5) in + (match uu___3 with + | (result_arg, rest) -> + let result_typ = + desugar_typ env + (FStar_Pervasives_Native.fst result_arg) in + let uu___4 = + let is_decrease t1 = + let uu___5 = + let uu___6 = + unparen (FStar_Pervasives_Native.fst t1) in + uu___6.FStarC_Parser_AST.tm in + match uu___5 with + | FStarC_Parser_AST.Decreases uu___6 -> true + | uu___6 -> false in + FStarC_Compiler_List.partition is_decrease rest in + (match uu___4 with + | (dec, rest1) -> + let rest2 = desugar_args env rest1 in + let decreases_clause = + FStarC_Compiler_List.map + (fun t1 -> + let uu___5 = + let uu___6 = + unparen + (FStar_Pervasives_Native.fst t1) in + uu___6.FStarC_Parser_AST.tm in + match uu___5 with + | FStarC_Parser_AST.Decreases + (t2, uu___6) -> + let dec_order = + let t3 = unparen t2 in + match t3.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.LexList l -> + let uu___7 = + FStarC_Compiler_List.map + (desugar_term env) l in + FStarC_Syntax_Syntax.Decreases_lex + uu___7 + | FStarC_Parser_AST.WFOrder + (t11, t21) -> + let uu___7 = + let uu___8 = + desugar_term env t11 in + let uu___9 = + desugar_term env t21 in + (uu___8, uu___9) in + FStarC_Syntax_Syntax.Decreases_wf + uu___7 + | uu___7 -> + let uu___8 = + let uu___9 = + desugar_term env t3 in + [uu___9] in + FStarC_Syntax_Syntax.Decreases_lex + uu___8 in + FStarC_Syntax_Syntax.DECREASES + dec_order + | uu___6 -> + fail + FStarC_Errors_Codes.Fatal_UnexpectedComputationTypeForLetRec + "Unexpected decreases clause") dec in + let no_additional_args = + let is_empty l = + match l with | [] -> true | uu___5 -> false in + (((is_empty decreases_clause) && + (is_empty rest2)) + && (is_empty cattributes)) + && (is_empty universes1) in + let uu___5 = + no_additional_args && + (FStarC_Ident.lid_equals eff + FStarC_Parser_Const.effect_Tot_lid) in + if uu___5 + then FStarC_Syntax_Syntax.mk_Total result_typ + else + (let uu___7 = + no_additional_args && + (FStarC_Ident.lid_equals eff + FStarC_Parser_Const.effect_GTot_lid) in + if uu___7 + then + FStarC_Syntax_Syntax.mk_GTotal result_typ + else + (let flags = + let uu___9 = + FStarC_Ident.lid_equals eff + FStarC_Parser_Const.effect_Lemma_lid in + if uu___9 + then [FStarC_Syntax_Syntax.LEMMA] + else + (let uu___11 = + FStarC_Ident.lid_equals eff + FStarC_Parser_Const.effect_Tot_lid in + if uu___11 + then [FStarC_Syntax_Syntax.TOTAL] + else + (let uu___13 = + let uu___14 = + FStarC_Parser_Const.effect_ML_lid + () in + FStarC_Ident.lid_equals eff + uu___14 in + if uu___13 + then + [FStarC_Syntax_Syntax.MLEFFECT] + else + (let uu___15 = + FStarC_Ident.lid_equals eff + FStarC_Parser_Const.effect_GTot_lid in + if uu___15 + then + [FStarC_Syntax_Syntax.SOMETRIVIAL] + else []))) in + let flags1 = + FStarC_Compiler_List.op_At flags + cattributes in + let rest3 = + let uu___9 = + FStarC_Ident.lid_equals eff + FStarC_Parser_Const.effect_Lemma_lid in + if uu___9 + then + match rest2 with + | req::ens::(pat, aq)::[] -> + let pat1 = + match pat.FStarC_Syntax_Syntax.n + with + | FStarC_Syntax_Syntax.Tm_fvar + fv when + FStarC_Syntax_Syntax.fv_eq_lid + fv + FStarC_Parser_Const.nil_lid + -> + let nil = + FStarC_Syntax_Syntax.mk_Tm_uinst + pat + [FStarC_Syntax_Syntax.U_zero] in + let pattern = + let uu___10 = + FStarC_Ident.set_lid_range + FStarC_Parser_Const.pattern_lid + pat.FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.fvar_with_dd + uu___10 + FStar_Pervasives_Native.None in + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Syntax_Syntax.as_aqual_implicit + true in + (pattern, uu___12) in + [uu___11] in + FStarC_Syntax_Syntax.mk_Tm_app + nil uu___10 + pat.FStarC_Syntax_Syntax.pos + | uu___10 -> pat in + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 + = pat1; + FStarC_Syntax_Syntax.meta + = + (FStarC_Syntax_Syntax.Meta_desugared + FStarC_Syntax_Syntax.Meta_smt_pat) + }) + pat1.FStarC_Syntax_Syntax.pos in + (uu___13, aq) in + [uu___12] in + ens :: uu___11 in + req :: uu___10 + | uu___10 -> rest2 + else rest2 in + FStarC_Syntax_Syntax.mk_Comp + { + FStarC_Syntax_Syntax.comp_univs = + universes1; + FStarC_Syntax_Syntax.effect_name = + eff; + FStarC_Syntax_Syntax.result_typ = + result_typ; + FStarC_Syntax_Syntax.effect_args = + rest3; + FStarC_Syntax_Syntax.flags = + (FStarC_Compiler_List.op_At flags1 + decreases_clause) + })))))) +and (desugar_formula : + FStarC_Syntax_DsEnv.env -> + FStarC_Parser_AST.term -> FStarC_Syntax_Syntax.term) + = + fun env -> + fun f -> + let mk t = FStarC_Syntax_Syntax.mk t f.FStarC_Parser_AST.range in + let setpos t = + { + FStarC_Syntax_Syntax.n = (t.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = (f.FStarC_Parser_AST.range); + FStarC_Syntax_Syntax.vars = (t.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = (t.FStarC_Syntax_Syntax.hash_code) + } in + let desugar_quant q_head b pats should_wrap_with_pat body = + let tk = + desugar_binder env + { + FStarC_Parser_AST.b = (b.FStarC_Parser_AST.b); + FStarC_Parser_AST.brange = (b.FStarC_Parser_AST.brange); + FStarC_Parser_AST.blevel = FStarC_Parser_AST.Formula; + FStarC_Parser_AST.aqual = (b.FStarC_Parser_AST.aqual); + FStarC_Parser_AST.battributes = + (b.FStarC_Parser_AST.battributes) + } in + let with_pats env1 uu___ body1 = + match uu___ with + | (names, pats1) -> + (match (names, pats1) with + | ([], []) -> body1 + | ([], uu___1::uu___2) -> + failwith + "Impossible: Annotated pattern without binders in scope" + | uu___1 -> + let names1 = + FStarC_Compiler_List.map + (fun i -> + let uu___2 = + FStarC_Syntax_DsEnv.fail_or2 + (FStarC_Syntax_DsEnv.try_lookup_id env1) i in + let uu___3 = FStarC_Ident.range_of_id i in + { + FStarC_Syntax_Syntax.n = + (uu___2.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = uu___3; + FStarC_Syntax_Syntax.vars = + (uu___2.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (uu___2.FStarC_Syntax_Syntax.hash_code) + }) names in + let pats2 = + FStarC_Compiler_List.map + (fun es -> + FStarC_Compiler_List.map + (fun e -> + let uu___2 = desugar_term env1 e in + arg_withimp_t FStarC_Parser_AST.Nothing uu___2) + es) pats1 in + (match pats2 with + | [] when Prims.op_Negation should_wrap_with_pat -> body1 + | uu___2 -> + mk + (FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 = body1; + FStarC_Syntax_Syntax.meta = + (FStarC_Syntax_Syntax.Meta_pattern + (names1, pats2)) + }))) in + match tk with + | (FStar_Pervasives_Native.Some a, k, uu___) -> + let uu___1 = FStarC_Syntax_DsEnv.push_bv env a in + (match uu___1 with + | (env1, a1) -> + let a2 = + { + FStarC_Syntax_Syntax.ppname = + (a1.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (a1.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = k + } in + let body1 = desugar_formula env1 body in + let body2 = with_pats env1 pats body1 in + let body3 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Syntax.mk_binder a2 in + [uu___4] in + no_annot_abs uu___3 body2 in + setpos uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.as_arg body3 in + [uu___5] in + { + FStarC_Syntax_Syntax.hd = q_head; + FStarC_Syntax_Syntax.args = uu___4 + } in + FStarC_Syntax_Syntax.Tm_app uu___3 in + mk uu___2) + | uu___ -> failwith "impossible" in + let push_quant q binders pats body = + match binders with + | b::b'::_rest -> + let rest = b' :: _rest in + let body1 = + let uu___ = q (rest, pats, body) in + let uu___1 = + FStarC_Compiler_Range_Ops.union_ranges + b'.FStarC_Parser_AST.brange body.FStarC_Parser_AST.range in + FStarC_Parser_AST.mk_term uu___ uu___1 + FStarC_Parser_AST.Formula in + let uu___ = q ([b], ([], []), body1) in + FStarC_Parser_AST.mk_term uu___ f.FStarC_Parser_AST.range + FStarC_Parser_AST.Formula + | uu___ -> failwith "impossible" in + let uu___ = let uu___1 = unparen f in uu___1.FStarC_Parser_AST.tm in + match uu___ with + | FStarC_Parser_AST.Labeled (f1, l, p) -> + let f2 = desugar_formula env f1 in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Errors_Msg.mkmsg l in + (uu___5, (f2.FStarC_Syntax_Syntax.pos), p) in + FStarC_Syntax_Syntax.Meta_labeled uu___4 in + { + FStarC_Syntax_Syntax.tm2 = f2; + FStarC_Syntax_Syntax.meta = uu___3 + } in + FStarC_Syntax_Syntax.Tm_meta uu___2 in + mk uu___1 + | FStarC_Parser_AST.QForall ([], uu___1, uu___2) -> + failwith "Impossible: Quantifier without binders" + | FStarC_Parser_AST.QExists ([], uu___1, uu___2) -> + failwith "Impossible: Quantifier without binders" + | FStarC_Parser_AST.QuantOp (uu___1, [], uu___2, uu___3) -> + failwith "Impossible: Quantifier without binders" + | FStarC_Parser_AST.QForall (_1::_2::_3, pats, body) -> + let binders = _1 :: _2 :: _3 in + let uu___1 = + push_quant (fun x -> FStarC_Parser_AST.QForall x) binders pats + body in + desugar_formula env uu___1 + | FStarC_Parser_AST.QExists (_1::_2::_3, pats, body) -> + let binders = _1 :: _2 :: _3 in + let uu___1 = + push_quant (fun x -> FStarC_Parser_AST.QExists x) binders pats + body in + desugar_formula env uu___1 + | FStarC_Parser_AST.QuantOp (i, _1::_2::_3, pats, body) -> + let binders = _1 :: _2 :: _3 in + let uu___1 = + push_quant + (fun uu___2 -> + match uu___2 with + | (x, y, z) -> FStarC_Parser_AST.QuantOp (i, x, y, z)) + binders pats body in + desugar_formula env uu___1 + | FStarC_Parser_AST.QForall (b::[], pats, body) -> + let q = FStarC_Parser_Const.forall_lid in + let q_head = + let uu___1 = + FStarC_Ident.set_lid_range q b.FStarC_Parser_AST.brange in + FStarC_Syntax_Syntax.fvar_with_dd uu___1 + FStar_Pervasives_Native.None in + desugar_quant q_head b pats true body + | FStarC_Parser_AST.QExists (b::[], pats, body) -> + let q = FStarC_Parser_Const.exists_lid in + let q_head = + let uu___1 = + FStarC_Ident.set_lid_range q b.FStarC_Parser_AST.brange in + FStarC_Syntax_Syntax.fvar_with_dd uu___1 + FStar_Pervasives_Native.None in + desugar_quant q_head b pats true body + | FStarC_Parser_AST.QuantOp (i, b::[], pats, body) -> + let q_head = + let uu___1 = op_as_term env Prims.int_zero i in + match uu___1 with + | FStar_Pervasives_Native.None -> + let uu___2 = + let uu___3 = FStarC_Ident.string_of_id i in + FStarC_Compiler_Util.format1 + "quantifier operator %s not found" uu___3 in + FStarC_Errors.raise_error FStarC_Ident.hasrange_ident i + FStarC_Errors_Codes.Fatal_VariableNotFound () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2) + | FStar_Pervasives_Native.Some t -> t in + desugar_quant q_head b pats false body + | FStarC_Parser_AST.Paren f1 -> failwith "impossible" + | uu___1 -> desugar_term env f +and (desugar_binder_aq : + FStarC_Syntax_DsEnv.env -> + FStarC_Parser_AST.binder -> + ((FStarC_Ident.ident FStar_Pervasives_Native.option * + FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.attribute + Prims.list) * antiquotations_temp)) + = + fun env -> + fun b -> + let attrs = + FStarC_Compiler_List.map (desugar_term env) + b.FStarC_Parser_AST.battributes in + match b.FStarC_Parser_AST.b with + | FStarC_Parser_AST.TAnnotated (x, t) -> + let uu___ = desugar_typ_aq env t in + (match uu___ with + | (ty, aqs) -> + (((FStar_Pervasives_Native.Some x), ty, attrs), aqs)) + | FStarC_Parser_AST.Annotated (x, t) -> + let uu___ = desugar_typ_aq env t in + (match uu___ with + | (ty, aqs) -> + (((FStar_Pervasives_Native.Some x), ty, attrs), aqs)) + | FStarC_Parser_AST.NoName t -> + let uu___ = desugar_typ_aq env t in + (match uu___ with + | (ty, aqs) -> ((FStar_Pervasives_Native.None, ty, attrs), aqs)) + | FStarC_Parser_AST.TVariable x -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Ident.range_of_id x in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_type FStarC_Syntax_Syntax.U_unknown) + uu___2 in + ((FStar_Pervasives_Native.Some x), uu___1, attrs) in + (uu___, []) + | FStarC_Parser_AST.Variable x -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Ident.range_of_id x in tun_r uu___2 in + ((FStar_Pervasives_Native.Some x), uu___1, attrs) in + (uu___, []) +and (desugar_binder : + FStarC_Syntax_DsEnv.env -> + FStarC_Parser_AST.binder -> + (FStarC_Ident.ident FStar_Pervasives_Native.option * + FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.attribute + Prims.list)) + = + fun env -> + fun b -> + let uu___ = desugar_binder_aq env b in + match uu___ with | (r, aqs) -> (check_no_aq aqs; r) +and (desugar_vquote : + env_t -> + FStarC_Parser_AST.term -> + FStarC_Compiler_Range_Type.range -> Prims.string) + = + fun env -> + fun e -> + fun r -> + let tm = desugar_term env e in + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress tm in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let uu___1 = FStarC_Syntax_Syntax.lid_of_fv fv in + FStarC_Ident.string_of_lid uu___1 + | uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term tm in + Prims.strcat "VQuote, expected an fvar, got: " uu___3 in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_UnexpectedTermVQuote () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2) +and (as_binder : + FStarC_Syntax_DsEnv.env -> + FStarC_Parser_AST.arg_qualifier FStar_Pervasives_Native.option -> + (FStarC_Ident.ident FStar_Pervasives_Native.option * + FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.attribute + Prims.list) -> + (FStarC_Syntax_Syntax.binder * FStarC_Syntax_DsEnv.env)) + = + fun env -> + fun imp -> + fun uu___ -> + match uu___ with + | (FStar_Pervasives_Native.None, k, attrs) -> + let uu___1 = + let uu___2 = FStarC_Syntax_Syntax.null_bv k in + let uu___3 = trans_bqual env imp in + mk_binder_with_attrs uu___2 uu___3 attrs in + (uu___1, env) + | (FStar_Pervasives_Native.Some a, k, attrs) -> + let uu___1 = FStarC_Syntax_DsEnv.push_bv env a in + (match uu___1 with + | (env1, a1) -> + let uu___2 = + let uu___3 = trans_bqual env1 imp in + mk_binder_with_attrs + { + FStarC_Syntax_Syntax.ppname = + (a1.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (a1.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = k + } uu___3 attrs in + (uu___2, env1)) +and (trans_bqual : + env_t -> + FStarC_Parser_AST.arg_qualifier FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.bqual) + = + fun env -> + fun uu___ -> + match uu___ with + | FStar_Pervasives_Native.Some (FStarC_Parser_AST.Implicit) -> + FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.imp_tag + | FStar_Pervasives_Native.Some (FStarC_Parser_AST.Equality) -> + FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.Equality + | FStar_Pervasives_Native.Some (FStarC_Parser_AST.Meta t) -> + let uu___1 = + let uu___2 = desugar_term env t in + FStarC_Syntax_Syntax.Meta uu___2 in + FStar_Pervasives_Native.Some uu___1 + | FStar_Pervasives_Native.Some (FStarC_Parser_AST.TypeClassArg) -> + let tcresolve = + let uu___1 = + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.Var FStarC_Parser_Const.tcresolve_lid) + FStarC_Compiler_Range_Type.dummyRange FStarC_Parser_AST.Expr in + desugar_term env uu___1 in + FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Meta tcresolve) + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None +let (typars_of_binders : + FStarC_Syntax_DsEnv.env -> + FStarC_Parser_AST.binder Prims.list -> + (FStarC_Syntax_DsEnv.env * FStarC_Syntax_Syntax.binders)) + = + fun env -> + fun bs -> + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun b -> + match uu___1 with + | (env1, out) -> + let tk = + desugar_binder env1 + { + FStarC_Parser_AST.b = (b.FStarC_Parser_AST.b); + FStarC_Parser_AST.brange = + (b.FStarC_Parser_AST.brange); + FStarC_Parser_AST.blevel = FStarC_Parser_AST.Formula; + FStarC_Parser_AST.aqual = + (b.FStarC_Parser_AST.aqual); + FStarC_Parser_AST.battributes = + (b.FStarC_Parser_AST.battributes) + } in + (match tk with + | (FStar_Pervasives_Native.Some a, k, attrs) -> + let uu___2 = FStarC_Syntax_DsEnv.push_bv env1 a in + (match uu___2 with + | (env2, a1) -> + let a2 = + { + FStarC_Syntax_Syntax.ppname = + (a1.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (a1.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = k + } in + let uu___3 = + let uu___4 = + let uu___5 = + trans_bqual env2 b.FStarC_Parser_AST.aqual in + mk_binder_with_attrs a2 uu___5 attrs in + uu___4 :: out in + (env2, uu___3)) + | uu___2 -> + FStarC_Errors.raise_error + FStarC_Parser_AST.hasRange_binder b + FStarC_Errors_Codes.Fatal_UnexpectedBinder () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "Unexpected binder"))) (env, []) bs in + match uu___ with + | (env1, tpars) -> (env1, (FStarC_Compiler_List.rev tpars)) +let (desugar_attributes : + env_t -> + FStarC_Parser_AST.term Prims.list -> + FStarC_Syntax_Syntax.cflag Prims.list) + = + fun env -> + fun cattributes -> + let desugar_attribute t = + let uu___ = let uu___1 = unparen t in uu___1.FStarC_Parser_AST.tm in + match uu___ with + | FStarC_Parser_AST.Var lid when + let uu___1 = FStarC_Ident.string_of_lid lid in uu___1 = "cps" -> + FStarC_Syntax_Syntax.CPS + | uu___1 -> + let uu___2 = + let uu___3 = FStarC_Parser_AST.term_to_string t in + Prims.strcat "Unknown attribute " uu___3 in + FStarC_Errors.raise_error FStarC_Parser_AST.hasRange_term t + FStarC_Errors_Codes.Fatal_UnknownAttribute () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2) in + FStarC_Compiler_List.map desugar_attribute cattributes +let (binder_ident : + FStarC_Parser_AST.binder -> + FStarC_Ident.ident FStar_Pervasives_Native.option) + = + fun b -> + match b.FStarC_Parser_AST.b with + | FStarC_Parser_AST.TAnnotated (x, uu___) -> + FStar_Pervasives_Native.Some x + | FStarC_Parser_AST.Annotated (x, uu___) -> + FStar_Pervasives_Native.Some x + | FStarC_Parser_AST.TVariable x -> FStar_Pervasives_Native.Some x + | FStarC_Parser_AST.Variable x -> FStar_Pervasives_Native.Some x + | FStarC_Parser_AST.NoName uu___ -> FStar_Pervasives_Native.None +let (binder_idents : + FStarC_Parser_AST.binder Prims.list -> FStarC_Ident.ident Prims.list) = + fun bs -> + FStarC_Compiler_List.collect + (fun b -> + let uu___ = binder_ident b in FStarC_Common.list_of_option uu___) bs +let (mk_data_discriminators : + FStarC_Syntax_Syntax.qualifier Prims.list -> + FStarC_Syntax_DsEnv.env -> + FStarC_Ident.lident Prims.list -> + FStarC_Syntax_Syntax.attribute Prims.list -> + FStarC_Syntax_Syntax.sigelt Prims.list) + = + fun quals -> + fun env -> + fun datas -> + fun attrs -> + let quals1 = + FStarC_Compiler_List.filter + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.NoExtract -> true + | FStarC_Syntax_Syntax.Private -> true + | uu___1 -> false) quals in + let quals2 q = + let uu___ = + (let uu___1 = FStarC_Syntax_DsEnv.iface env in + Prims.op_Negation uu___1) || + (FStarC_Syntax_DsEnv.admitted_iface env) in + if uu___ + then + FStarC_Compiler_List.op_At (FStarC_Syntax_Syntax.Assumption :: + q) quals1 + else FStarC_Compiler_List.op_At q quals1 in + FStarC_Compiler_List.map + (fun d -> + let disc_name = FStarC_Syntax_Util.mk_discriminator d in + let uu___ = FStarC_Ident.range_of_lid disc_name in + let uu___1 = + quals2 + [FStarC_Syntax_Syntax.OnlyName; + FStarC_Syntax_Syntax.Discriminator d] in + let uu___2 = FStarC_Syntax_DsEnv.opens_and_abbrevs env in + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_declare_typ + { + FStarC_Syntax_Syntax.lid2 = disc_name; + FStarC_Syntax_Syntax.us2 = []; + FStarC_Syntax_Syntax.t2 = FStarC_Syntax_Syntax.tun + }); + FStarC_Syntax_Syntax.sigrng = uu___; + FStarC_Syntax_Syntax.sigquals = uu___1; + FStarC_Syntax_Syntax.sigmeta = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs = attrs; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___2; + FStarC_Syntax_Syntax.sigopts = FStar_Pervasives_Native.None + }) datas +let (mk_indexed_projector_names : + FStarC_Syntax_Syntax.qualifier Prims.list -> + FStarC_Syntax_Syntax.fv_qual -> + FStarC_Syntax_Syntax.attribute Prims.list -> + FStarC_Syntax_DsEnv.env -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.binder Prims.list -> + FStarC_Syntax_Syntax.sigelt Prims.list) + = + fun iquals -> + fun fvq -> + fun attrs -> + fun env -> + fun lid -> + fun fields -> + let p = FStarC_Ident.range_of_lid lid in + let uu___ = + FStarC_Compiler_List.mapi + (fun i -> + fun fld -> + let x = fld.FStarC_Syntax_Syntax.binder_bv in + let field_name = + FStarC_Syntax_Util.mk_field_projector_name lid x i in + let only_decl = + ((let uu___1 = + FStarC_Syntax_DsEnv.current_module env in + FStarC_Ident.lid_equals + FStarC_Parser_Const.prims_lid uu___1) + || (fvq <> FStarC_Syntax_Syntax.Data_ctor)) + || + (FStarC_Syntax_Util.has_attribute attrs + FStarC_Parser_Const.no_auto_projectors_attr) in + let no_decl = + FStarC_Syntax_Syntax.is_type + x.FStarC_Syntax_Syntax.sort in + let quals q = + if only_decl + then FStarC_Syntax_Syntax.Assumption :: q + else q in + let quals1 = + let iquals1 = + FStarC_Compiler_List.filter + (fun uu___1 -> + match uu___1 with + | FStarC_Syntax_Syntax.NoExtract -> true + | FStarC_Syntax_Syntax.Private -> true + | uu___2 -> false) iquals in + quals (FStarC_Syntax_Syntax.OnlyName :: + (FStarC_Syntax_Syntax.Projector + (lid, (x.FStarC_Syntax_Syntax.ppname))) :: + iquals1) in + let decl = + let uu___1 = FStarC_Ident.range_of_lid field_name in + let uu___2 = + FStarC_Syntax_DsEnv.opens_and_abbrevs env in + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_declare_typ + { + FStarC_Syntax_Syntax.lid2 = field_name; + FStarC_Syntax_Syntax.us2 = []; + FStarC_Syntax_Syntax.t2 = + FStarC_Syntax_Syntax.tun + }); + FStarC_Syntax_Syntax.sigrng = uu___1; + FStarC_Syntax_Syntax.sigquals = quals1; + FStarC_Syntax_Syntax.sigmeta = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs = attrs; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___2; + FStarC_Syntax_Syntax.sigopts = + FStar_Pervasives_Native.None + } in + if only_decl + then [decl] + else + (let lb = + let uu___2 = + let uu___3 = + FStarC_Syntax_Syntax.lid_and_dd_as_fv + field_name FStar_Pervasives_Native.None in + FStar_Pervasives.Inr uu___3 in + { + FStarC_Syntax_Syntax.lbname = uu___2; + FStarC_Syntax_Syntax.lbunivs = []; + FStarC_Syntax_Syntax.lbtyp = + FStarC_Syntax_Syntax.tun; + FStarC_Syntax_Syntax.lbeff = + FStarC_Parser_Const.effect_Tot_lid; + FStarC_Syntax_Syntax.lbdef = + FStarC_Syntax_Syntax.tun; + FStarC_Syntax_Syntax.lbattrs = []; + FStarC_Syntax_Syntax.lbpos = + FStarC_Compiler_Range_Type.dummyRange + } in + let impl = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Compiler_Util.right + lb.FStarC_Syntax_Syntax.lbname in + (uu___6.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + [uu___5] in + { + FStarC_Syntax_Syntax.lbs1 = (false, [lb]); + FStarC_Syntax_Syntax.lids1 = uu___4 + } in + FStarC_Syntax_Syntax.Sig_let uu___3 in + let uu___3 = + FStarC_Syntax_DsEnv.opens_and_abbrevs env in + { + FStarC_Syntax_Syntax.sigel = uu___2; + FStarC_Syntax_Syntax.sigrng = p; + FStarC_Syntax_Syntax.sigquals = quals1; + FStarC_Syntax_Syntax.sigmeta = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs = attrs; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + uu___3; + FStarC_Syntax_Syntax.sigopts = + FStar_Pervasives_Native.None + } in + if no_decl then [impl] else [decl; impl])) fields in + FStarC_Compiler_List.flatten uu___ +let (mk_data_projector_names : + FStarC_Syntax_Syntax.qualifier Prims.list -> + FStarC_Syntax_DsEnv.env -> + FStarC_Syntax_Syntax.sigelt -> FStarC_Syntax_Syntax.sigelt Prims.list) + = + fun iquals -> + fun env -> + fun se -> + if + (FStarC_Syntax_Util.has_attribute se.FStarC_Syntax_Syntax.sigattrs + FStarC_Parser_Const.no_auto_projectors_decls_attr) + || + (FStarC_Syntax_Util.has_attribute + se.FStarC_Syntax_Syntax.sigattrs + FStarC_Parser_Const.meta_projectors_attr) + then [] + else + (match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = lid; + FStarC_Syntax_Syntax.us1 = uu___; + FStarC_Syntax_Syntax.t1 = t; + FStarC_Syntax_Syntax.ty_lid = uu___1; + FStarC_Syntax_Syntax.num_ty_params = n; + FStarC_Syntax_Syntax.mutuals1 = uu___2; + FStarC_Syntax_Syntax.injective_type_params1 = uu___3;_} + -> + let uu___4 = FStarC_Syntax_Util.arrow_formals t in + (match uu___4 with + | (formals, uu___5) -> + (match formals with + | [] -> [] + | uu___6 -> + let filter_records uu___7 = + match uu___7 with + | FStarC_Syntax_Syntax.RecordConstructor + (uu___8, fns) -> + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Record_ctor (lid, fns)) + | uu___8 -> FStar_Pervasives_Native.None in + let fv_qual = + let uu___7 = + FStarC_Compiler_Util.find_map + se.FStarC_Syntax_Syntax.sigquals + filter_records in + match uu___7 with + | FStar_Pervasives_Native.None -> + FStarC_Syntax_Syntax.Data_ctor + | FStar_Pervasives_Native.Some q -> q in + let uu___7 = FStarC_Compiler_Util.first_N n formals in + (match uu___7 with + | (uu___8, rest) -> + mk_indexed_projector_names iquals fv_qual + se.FStarC_Syntax_Syntax.sigattrs env lid rest))) + | uu___ -> []) +let (mk_typ_abbrev : + FStarC_Syntax_DsEnv.env -> + FStarC_Parser_AST.decl -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.univ_name Prims.list -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.typ FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Ident.lident Prims.list -> + FStarC_Syntax_Syntax.qualifier Prims.list -> + FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.sigelt) + = + fun env -> + fun d -> + fun lid -> + fun uvs -> + fun typars -> + fun kopt -> + fun t -> + fun lids -> + fun quals -> + fun rng -> + let attrs = + let uu___ = + FStarC_Compiler_List.map (desugar_term env) + d.FStarC_Parser_AST.attrs in + FStarC_Syntax_Util.deduplicate_terms uu___ in + let val_attrs = + let uu___ = + FStarC_Syntax_DsEnv.lookup_letbinding_quals_and_attrs + env lid in + FStar_Pervasives_Native.snd uu___ in + let lb = + let uu___ = + let uu___1 = + FStarC_Syntax_Syntax.lid_and_dd_as_fv lid + FStar_Pervasives_Native.None in + FStar_Pervasives.Inr uu___1 in + let uu___1 = + if FStarC_Compiler_Util.is_some kopt + then + let uu___2 = + let uu___3 = FStarC_Compiler_Util.must kopt in + FStarC_Syntax_Syntax.mk_Total uu___3 in + FStarC_Syntax_Util.arrow typars uu___2 + else FStarC_Syntax_Syntax.tun in + let uu___2 = no_annot_abs typars t in + { + FStarC_Syntax_Syntax.lbname = uu___; + FStarC_Syntax_Syntax.lbunivs = uvs; + FStarC_Syntax_Syntax.lbtyp = uu___1; + FStarC_Syntax_Syntax.lbeff = + FStarC_Parser_Const.effect_Tot_lid; + FStarC_Syntax_Syntax.lbdef = uu___2; + FStarC_Syntax_Syntax.lbattrs = []; + FStarC_Syntax_Syntax.lbpos = rng + } in + let uu___ = + FStarC_Syntax_Util.deduplicate_terms + (FStarC_Compiler_List.op_At val_attrs attrs) in + let uu___1 = FStarC_Syntax_DsEnv.opens_and_abbrevs env in + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_let + { + FStarC_Syntax_Syntax.lbs1 = (false, [lb]); + FStarC_Syntax_Syntax.lids1 = lids + }); + FStarC_Syntax_Syntax.sigrng = rng; + FStarC_Syntax_Syntax.sigquals = quals; + FStarC_Syntax_Syntax.sigmeta = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs = uu___; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___1; + FStarC_Syntax_Syntax.sigopts = + FStar_Pervasives_Native.None + } +let rec (desugar_tycon : + FStarC_Syntax_DsEnv.env -> + FStarC_Parser_AST.decl -> + FStarC_Syntax_Syntax.term Prims.list -> + FStarC_Syntax_Syntax.qualifier Prims.list -> + FStarC_Parser_AST.tycon Prims.list -> + (env_t * FStarC_Syntax_Syntax.sigelts)) + = + fun env -> + fun d -> + fun d_attrs_initial -> + fun quals -> + fun tcs -> + let rng = d.FStarC_Parser_AST.drange in + let tycon_id uu___ = + match uu___ with + | FStarC_Parser_AST.TyconAbstract (id, uu___1, uu___2) -> id + | FStarC_Parser_AST.TyconAbbrev (id, uu___1, uu___2, uu___3) -> + id + | FStarC_Parser_AST.TyconRecord + (id, uu___1, uu___2, uu___3, uu___4) -> id + | FStarC_Parser_AST.TyconVariant (id, uu___1, uu___2, uu___3) + -> id in + let binder_to_term b = + match b.FStarC_Parser_AST.b with + | FStarC_Parser_AST.Annotated (x, uu___) -> + let uu___1 = + let uu___2 = FStarC_Ident.lid_of_ids [x] in + FStarC_Parser_AST.Var uu___2 in + let uu___2 = FStarC_Ident.range_of_id x in + FStarC_Parser_AST.mk_term uu___1 uu___2 + FStarC_Parser_AST.Expr + | FStarC_Parser_AST.Variable x -> + let uu___ = + let uu___1 = FStarC_Ident.lid_of_ids [x] in + FStarC_Parser_AST.Var uu___1 in + let uu___1 = FStarC_Ident.range_of_id x in + FStarC_Parser_AST.mk_term uu___ uu___1 + FStarC_Parser_AST.Expr + | FStarC_Parser_AST.TAnnotated (a, uu___) -> + let uu___1 = FStarC_Ident.range_of_id a in + FStarC_Parser_AST.mk_term (FStarC_Parser_AST.Tvar a) uu___1 + FStarC_Parser_AST.Type_level + | FStarC_Parser_AST.TVariable a -> + let uu___ = FStarC_Ident.range_of_id a in + FStarC_Parser_AST.mk_term (FStarC_Parser_AST.Tvar a) uu___ + FStarC_Parser_AST.Type_level + | FStarC_Parser_AST.NoName t -> t in + let desugar_tycon_variant_record uu___ = + match uu___ with + | FStarC_Parser_AST.TyconVariant (id, bds, k, variants) -> + let uu___1 = + let uu___2 = + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with + | (cid, payload, attrs) -> + (match payload with + | FStar_Pervasives_Native.Some + (FStarC_Parser_AST.VpRecord (r, k1)) -> + let record_id = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Ident.string_of_id id in + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Ident.string_of_id cid in + Prims.strcat uu___9 "__payload" in + Prims.strcat "__" uu___8 in + Prims.strcat uu___6 uu___7 in + let uu___6 = + FStarC_Ident.range_of_id cid in + (uu___5, uu___6) in + FStarC_Ident.mk_ident uu___4 in + let record_id_t = + let uu___4 = + let uu___5 = + FStarC_Ident.lid_of_ns_and_id [] + record_id in + FStarC_Parser_AST.Var uu___5 in + let uu___5 = + FStarC_Ident.range_of_id cid in + { + FStarC_Parser_AST.tm = uu___4; + FStarC_Parser_AST.range = uu___5; + FStarC_Parser_AST.level = + FStarC_Parser_AST.Type_level + } in + let payload_typ = + let uu___4 = + FStarC_Compiler_List.map + (fun bd -> + let uu___5 = binder_to_term bd in + (uu___5, + FStarC_Parser_AST.Nothing)) + bds in + let uu___5 = + FStarC_Ident.range_of_id record_id in + FStarC_Parser_AST.mkApp record_id_t + uu___4 uu___5 in + let desugar_marker = + let range = + FStarC_Ident.range_of_id record_id in + let desugar_attr_fv = + { + FStarC_Syntax_Syntax.fv_name = + { + FStarC_Syntax_Syntax.v = + FStarC_Parser_Const.desugar_of_variant_record_lid; + FStarC_Syntax_Syntax.p = range + }; + FStarC_Syntax_Syntax.fv_qual = + FStar_Pervasives_Native.None + } in + let desugar_attr = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_fvar + desugar_attr_fv) range in + let cid_as_constant = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_DsEnv.qualify env + cid in + FStarC_Ident.string_of_lid uu___6 in + FStarC_Syntax_Embeddings_Base.embed + FStarC_Syntax_Embeddings.e_string + uu___5 in + uu___4 range + FStar_Pervasives_Native.None + FStarC_Syntax_Embeddings_Base.id_norm_cb in + FStarC_Syntax_Syntax.mk_Tm_app + desugar_attr + [(cid_as_constant, + FStar_Pervasives_Native.None)] + range in + let uu___4 = + let uu___5 = + let uu___6 = + match k1 with + | FStar_Pervasives_Native.None -> + FStarC_Parser_AST.VpOfNotation + payload_typ + | FStar_Pervasives_Native.Some k2 + -> + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Ident.range_of_id + record_id in + FStarC_Parser_AST.mk_binder + (FStarC_Parser_AST.NoName + payload_typ) + uu___12 + FStarC_Parser_AST.Type_level + FStar_Pervasives_Native.None in + [uu___11] in + (uu___10, k2) in + FStarC_Parser_AST.Product + uu___9 in + { + FStarC_Parser_AST.tm = + uu___8; + FStarC_Parser_AST.range = + (payload_typ.FStarC_Parser_AST.range); + FStarC_Parser_AST.level = + FStarC_Parser_AST.Type_level + } in + FStarC_Parser_AST.VpArbitrary + uu___7 in + FStar_Pervasives_Native.Some uu___6 in + (cid, uu___5, attrs) in + ((FStar_Pervasives_Native.Some + ((FStarC_Parser_AST.TyconRecord + (record_id, bds, + FStar_Pervasives_Native.None, + attrs, r)), (desugar_marker :: + d_attrs_initial))), uu___4) + | uu___4 -> + (FStar_Pervasives_Native.None, + (cid, payload, attrs)))) variants in + FStarC_Compiler_List.unzip uu___2 in + (match uu___1 with + | (additional_records, variants1) -> + let concat_options = + FStarC_Compiler_List.filter_map (fun r -> r) in + let uu___2 = concat_options additional_records in + FStarC_Compiler_List.op_At uu___2 + [((FStarC_Parser_AST.TyconVariant + (id, bds, k, variants1)), d_attrs_initial)]) + | tycon -> [(tycon, d_attrs_initial)] in + let tcs1 = + FStarC_Compiler_List.concatMap desugar_tycon_variant_record tcs in + let tot rng1 = + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.Name FStarC_Parser_Const.effect_Tot_lid) + rng1 FStarC_Parser_AST.Expr in + let with_constructor_effect t = + let uu___ = + let uu___1 = + let uu___2 = tot t.FStarC_Parser_AST.range in + (uu___2, t, FStarC_Parser_AST.Nothing) in + FStarC_Parser_AST.App uu___1 in + FStarC_Parser_AST.mk_term uu___ t.FStarC_Parser_AST.range + t.FStarC_Parser_AST.level in + let apply_binders t binders = + let imp_of_aqual b = + match b.FStarC_Parser_AST.aqual with + | FStar_Pervasives_Native.Some (FStarC_Parser_AST.Implicit) + -> FStarC_Parser_AST.Hash + | FStar_Pervasives_Native.Some (FStarC_Parser_AST.Meta uu___) + -> FStarC_Parser_AST.Hash + | FStar_Pervasives_Native.Some + (FStarC_Parser_AST.TypeClassArg) -> + FStarC_Parser_AST.Hash + | uu___ -> FStarC_Parser_AST.Nothing in + FStarC_Compiler_List.fold_left + (fun out -> + fun b -> + let uu___ = + let uu___1 = + let uu___2 = binder_to_term b in + (out, uu___2, (imp_of_aqual b)) in + FStarC_Parser_AST.App uu___1 in + FStarC_Parser_AST.mk_term uu___ + out.FStarC_Parser_AST.range + out.FStarC_Parser_AST.level) t binders in + let tycon_record_as_variant uu___ = + match uu___ with + | FStarC_Parser_AST.TyconRecord + (id, parms, kopt, attrs, fields) -> + let constrName = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Ident.string_of_id id in + Prims.strcat "Mk" uu___3 in + let uu___3 = FStarC_Ident.range_of_id id in + (uu___2, uu___3) in + FStarC_Ident.mk_ident uu___1 in + let mfields = + FStarC_Compiler_List.map + (fun uu___1 -> + match uu___1 with + | (x, q, attrs1, t) -> + let uu___2 = FStarC_Ident.range_of_id x in + FStarC_Parser_AST.mk_binder_with_attrs + (FStarC_Parser_AST.Annotated (x, t)) uu___2 + FStarC_Parser_AST.Expr q attrs1) fields in + let result = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Ident.lid_of_ids [id] in + FStarC_Parser_AST.Var uu___3 in + let uu___3 = FStarC_Ident.range_of_id id in + FStarC_Parser_AST.mk_term uu___2 uu___3 + FStarC_Parser_AST.Type_level in + apply_binders uu___1 parms in + let constrTyp = + let uu___1 = + let uu___2 = + let uu___3 = with_constructor_effect result in + (mfields, uu___3) in + FStarC_Parser_AST.Product uu___2 in + let uu___2 = FStarC_Ident.range_of_id id in + FStarC_Parser_AST.mk_term uu___1 uu___2 + FStarC_Parser_AST.Type_level in + let names = + let uu___1 = binder_idents parms in id :: uu___1 in + (FStarC_Compiler_List.iter + (fun uu___2 -> + match uu___2 with + | (f, uu___3, uu___4, uu___5) -> + let uu___6 = + FStarC_Compiler_Util.for_some + (fun i -> FStarC_Ident.ident_equals f i) + names in + if uu___6 + then + let uu___7 = + let uu___8 = FStarC_Ident.string_of_id f in + FStarC_Compiler_Util.format1 + "Field %s shadows the record's name or a parameter of it, please rename it" + uu___8 in + FStarC_Errors.raise_error + FStarC_Ident.hasrange_ident f + FStarC_Errors_Codes.Error_FieldShadow () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___7) + else ()) fields; + (let uu___2 = + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with + | (f, uu___4, uu___5, uu___6) -> f) fields in + ((FStarC_Parser_AST.TyconVariant + (id, parms, kopt, + [(constrName, + (FStar_Pervasives_Native.Some + (FStarC_Parser_AST.VpArbitrary constrTyp)), + attrs)])), uu___2))) + | uu___1 -> failwith "impossible" in + let desugar_abstract_tc quals1 _env mutuals d_attrs uu___ = + match uu___ with + | FStarC_Parser_AST.TyconAbstract (id, binders, kopt) -> + let uu___1 = typars_of_binders _env binders in + (match uu___1 with + | (_env', typars) -> + let k = + match kopt with + | FStar_Pervasives_Native.None -> + FStarC_Syntax_Util.ktype + | FStar_Pervasives_Native.Some k1 -> + desugar_term _env' k1 in + let tconstr = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Ident.lid_of_ids [id] in + FStarC_Parser_AST.Var uu___4 in + let uu___4 = FStarC_Ident.range_of_id id in + FStarC_Parser_AST.mk_term uu___3 uu___4 + FStarC_Parser_AST.Type_level in + apply_binders uu___2 binders in + let qlid = FStarC_Syntax_DsEnv.qualify _env id in + let typars1 = FStarC_Syntax_Subst.close_binders typars in + let k1 = FStarC_Syntax_Subst.close typars1 k in + let se = + let uu___2 = FStarC_Ident.range_of_id id in + let uu___3 = + FStarC_Syntax_DsEnv.opens_and_abbrevs env in + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_inductive_typ + { + FStarC_Syntax_Syntax.lid = qlid; + FStarC_Syntax_Syntax.us = []; + FStarC_Syntax_Syntax.params = typars1; + FStarC_Syntax_Syntax.num_uniform_params = + FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.t = k1; + FStarC_Syntax_Syntax.mutuals = mutuals; + FStarC_Syntax_Syntax.ds = []; + FStarC_Syntax_Syntax.injective_type_params + = false + }); + FStarC_Syntax_Syntax.sigrng = uu___2; + FStarC_Syntax_Syntax.sigquals = quals1; + FStarC_Syntax_Syntax.sigmeta = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs = d_attrs; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___3; + FStarC_Syntax_Syntax.sigopts = + FStar_Pervasives_Native.None + } in + let uu___2 = + FStarC_Syntax_DsEnv.push_top_level_rec_binding _env + id in + (match uu___2 with + | (_env1, uu___3) -> + let uu___4 = + FStarC_Syntax_DsEnv.push_top_level_rec_binding + _env' id in + (match uu___4 with + | (_env2, uu___5) -> (_env1, _env2, se, tconstr)))) + | uu___1 -> failwith "Unexpected tycon" in + let push_tparams env1 bs = + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun b -> + match uu___1 with + | (env2, tps) -> + let uu___2 = + FStarC_Syntax_DsEnv.push_bv env2 + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.ppname in + (match uu___2 with + | (env3, y) -> + let uu___3 = + let uu___4 = + mk_binder_with_attrs y + b.FStarC_Syntax_Syntax.binder_qual + b.FStarC_Syntax_Syntax.binder_attrs in + uu___4 :: tps in + (env3, uu___3))) (env1, []) bs in + match uu___ with + | (env2, bs1) -> (env2, (FStarC_Compiler_List.rev bs1)) in + match tcs1 with + | (FStarC_Parser_AST.TyconAbstract (id, bs, kopt), d_attrs)::[] + -> + let kopt1 = + match kopt with + | FStar_Pervasives_Native.None -> + let uu___ = + let uu___1 = FStarC_Ident.range_of_id id in + tm_type_z uu___1 in + FStar_Pervasives_Native.Some uu___ + | uu___ -> kopt in + let tc = FStarC_Parser_AST.TyconAbstract (id, bs, kopt1) in + let uu___ = desugar_abstract_tc quals env [] d_attrs tc in + (match uu___ with + | (uu___1, uu___2, se, uu___3) -> + let se1 = + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = l; + FStarC_Syntax_Syntax.us = uu___4; + FStarC_Syntax_Syntax.params = typars; + FStarC_Syntax_Syntax.num_uniform_params = uu___5; + FStarC_Syntax_Syntax.t = k; + FStarC_Syntax_Syntax.mutuals = []; + FStarC_Syntax_Syntax.ds = []; + FStarC_Syntax_Syntax.injective_type_params = + uu___6;_} + -> + let quals1 = se.FStarC_Syntax_Syntax.sigquals in + let quals2 = + if + FStarC_Compiler_List.contains + FStarC_Syntax_Syntax.Assumption quals1 + then quals1 + else + ((let uu___9 = + let uu___10 = FStarC_Options.ml_ish () in + Prims.op_Negation uu___10 in + if uu___9 + then + let uu___10 = + let uu___11 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident l in + FStarC_Compiler_Util.format1 + "Adding an implicit 'assume new' qualifier on %s" + uu___11 in + FStarC_Errors.log_issue + FStarC_Syntax_Syntax.has_range_sigelt se + FStarC_Errors_Codes.Warning_AddImplicitAssumeNewQualifier + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___10) + else ()); + FStarC_Syntax_Syntax.Assumption + :: + FStarC_Syntax_Syntax.New + :: + quals1) in + let t = + match typars with + | [] -> k + | uu___7 -> + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Syntax_Syntax.mk_Total k in + { + FStarC_Syntax_Syntax.bs1 = typars; + FStarC_Syntax_Syntax.comp = uu___10 + } in + FStarC_Syntax_Syntax.Tm_arrow uu___9 in + FStarC_Syntax_Syntax.mk uu___8 + se.FStarC_Syntax_Syntax.sigrng in + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_declare_typ + { + FStarC_Syntax_Syntax.lid2 = l; + FStarC_Syntax_Syntax.us2 = []; + FStarC_Syntax_Syntax.t2 = t + }); + FStarC_Syntax_Syntax.sigrng = + (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = quals2; + FStarC_Syntax_Syntax.sigmeta = + (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se.FStarC_Syntax_Syntax.sigopts) + } + | uu___4 -> failwith "Impossible" in + let env1 = FStarC_Syntax_DsEnv.push_sigelt env se1 in + (env1, [se1])) + | (FStarC_Parser_AST.TyconAbbrev (id, binders, kopt, t), + _d_attrs)::[] -> + let uu___ = typars_of_binders env binders in + (match uu___ with + | (env', typars) -> + let kopt1 = + match kopt with + | FStar_Pervasives_Native.None -> + let uu___1 = + FStarC_Compiler_Util.for_some + (fun uu___2 -> + match uu___2 with + | FStarC_Syntax_Syntax.Effect -> true + | uu___3 -> false) quals in + if uu___1 + then + FStar_Pervasives_Native.Some + FStarC_Syntax_Syntax.teff + else FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some k -> + let uu___1 = desugar_term env' k in + FStar_Pervasives_Native.Some uu___1 in + let t0 = t in + let quals1 = + let uu___1 = + FStarC_Compiler_Util.for_some + (fun uu___2 -> + match uu___2 with + | FStarC_Syntax_Syntax.Logic -> true + | uu___3 -> false) quals in + if uu___1 + then quals + else + if + t0.FStarC_Parser_AST.level = + FStarC_Parser_AST.Formula + then FStarC_Syntax_Syntax.Logic :: quals + else quals in + let qlid = FStarC_Syntax_DsEnv.qualify env id in + let se = + if + FStarC_Compiler_List.contains + FStarC_Syntax_Syntax.Effect quals1 + then + let uu___1 = + let uu___2 = + let uu___3 = unparen t in + uu___3.FStarC_Parser_AST.tm in + match uu___2 with + | FStarC_Parser_AST.Construct (head, args) -> + let uu___3 = + match FStarC_Compiler_List.rev args with + | (last_arg, uu___4)::args_rev -> + let uu___5 = + let uu___6 = unparen last_arg in + uu___6.FStarC_Parser_AST.tm in + (match uu___5 with + | FStarC_Parser_AST.Attributes ts -> + (ts, + (FStarC_Compiler_List.rev + args_rev)) + | uu___6 -> ([], args)) + | uu___4 -> ([], args) in + (match uu___3 with + | (cattributes, args1) -> + let uu___4 = + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.Construct + (head, args1)) + t.FStarC_Parser_AST.range + t.FStarC_Parser_AST.level in + let uu___5 = + desugar_attributes env cattributes in + (uu___4, uu___5)) + | uu___3 -> (t, []) in + match uu___1 with + | (t1, cattributes) -> + let c = + desugar_comp t1.FStarC_Parser_AST.range false + env' t1 in + let typars1 = + FStarC_Syntax_Subst.close_binders typars in + let c1 = + FStarC_Syntax_Subst.close_comp typars1 c in + let quals2 = + FStarC_Compiler_List.filter + (fun uu___2 -> + match uu___2 with + | FStarC_Syntax_Syntax.Effect -> false + | uu___3 -> true) quals1 in + let uu___2 = FStarC_Ident.range_of_id id in + let uu___3 = + FStarC_Syntax_DsEnv.opens_and_abbrevs env in + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_effect_abbrev + { + FStarC_Syntax_Syntax.lid4 = qlid; + FStarC_Syntax_Syntax.us4 = []; + FStarC_Syntax_Syntax.bs2 = typars1; + FStarC_Syntax_Syntax.comp1 = c1; + FStarC_Syntax_Syntax.cflags = + (FStarC_Compiler_List.op_At + cattributes + (FStarC_Syntax_Util.comp_flags c1)) + }); + FStarC_Syntax_Syntax.sigrng = uu___2; + FStarC_Syntax_Syntax.sigquals = quals2; + FStarC_Syntax_Syntax.sigmeta = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs = []; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + uu___3; + FStarC_Syntax_Syntax.sigopts = + FStar_Pervasives_Native.None + } + else + (let t1 = desugar_typ env' t in + let uu___2 = FStarC_Ident.range_of_id id in + mk_typ_abbrev env d qlid [] typars kopt1 t1 + [qlid] quals1 uu___2) in + let env1 = FStarC_Syntax_DsEnv.push_sigelt env se in + (env1, [se])) + | (FStarC_Parser_AST.TyconRecord payload, d_attrs)::[] -> + let trec = FStarC_Parser_AST.TyconRecord payload in + let uu___ = tycon_record_as_variant trec in + (match uu___ with + | (t, fs) -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Syntax_DsEnv.current_module env in + FStarC_Ident.ids_of_lid uu___5 in + (uu___4, fs) in + FStarC_Syntax_Syntax.RecordType uu___3 in + uu___2 :: quals in + desugar_tycon env d d_attrs uu___1 [t]) + | uu___::uu___1 -> + let env0 = env in + let mutuals = + FStarC_Compiler_List.map + (fun uu___2 -> + match uu___2 with + | (x, uu___3) -> + FStarC_Syntax_DsEnv.qualify env (tycon_id x)) tcs1 in + let rec collect_tcs quals1 et uu___2 = + match uu___2 with + | (tc, d_attrs) -> + let uu___3 = et in + (match uu___3 with + | (env1, tcs2) -> + (match tc with + | FStarC_Parser_AST.TyconRecord uu___4 -> + let trec = tc in + let uu___5 = tycon_record_as_variant trec in + (match uu___5 with + | (t, fs) -> + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Syntax_DsEnv.current_module + env1 in + FStarC_Ident.ids_of_lid uu___10 in + (uu___9, fs) in + FStarC_Syntax_Syntax.RecordType + uu___8 in + uu___7 :: quals1 in + collect_tcs uu___6 (env1, tcs2) + (t, d_attrs)) + | FStarC_Parser_AST.TyconVariant + (id, binders, kopt, constructors) -> + let uu___4 = + desugar_abstract_tc quals1 env1 mutuals + d_attrs + (FStarC_Parser_AST.TyconAbstract + (id, binders, kopt)) in + (match uu___4 with + | (env2, uu___5, se, tconstr) -> + (env2, + (((FStar_Pervasives.Inl + (se, constructors, tconstr, + quals1)), d_attrs) :: tcs2))) + | FStarC_Parser_AST.TyconAbbrev + (id, binders, kopt, t) -> + let uu___4 = + desugar_abstract_tc quals1 env1 mutuals + d_attrs + (FStarC_Parser_AST.TyconAbstract + (id, binders, kopt)) in + (match uu___4 with + | (env2, uu___5, se, tconstr) -> + (env2, + (((FStar_Pervasives.Inr + (se, binders, t, quals1)), + d_attrs) :: tcs2))) + | uu___4 -> + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range rng + FStarC_Errors_Codes.Fatal_NonInductiveInMutuallyDefinedType + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Mutually defined type contains a non-inductive element"))) in + let uu___2 = + FStarC_Compiler_List.fold_left (collect_tcs quals) + (env, []) tcs1 in + (match uu___2 with + | (env1, tcs2) -> + let tcs3 = FStarC_Compiler_List.rev tcs2 in + let tps_sigelts = + FStarC_Compiler_List.collect + (fun uu___3 -> + match uu___3 with + | (tc, d_attrs) -> + (match tc with + | FStar_Pervasives.Inr + ({ + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = id; + FStarC_Syntax_Syntax.us = uvs; + FStarC_Syntax_Syntax.params = + tpars; + FStarC_Syntax_Syntax.num_uniform_params + = uu___4; + FStarC_Syntax_Syntax.t = k; + FStarC_Syntax_Syntax.mutuals = + uu___5; + FStarC_Syntax_Syntax.ds = uu___6; + FStarC_Syntax_Syntax.injective_type_params + = uu___7;_}; + FStarC_Syntax_Syntax.sigrng = uu___8; + FStarC_Syntax_Syntax.sigquals = + uu___9; + FStarC_Syntax_Syntax.sigmeta = + uu___10; + FStarC_Syntax_Syntax.sigattrs = + uu___11; + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = uu___12; + FStarC_Syntax_Syntax.sigopts = + uu___13;_}, + binders, t, quals1) + -> + let t1 = + let uu___14 = + typars_of_binders env1 binders in + match uu___14 with + | (env2, tpars1) -> + let uu___15 = + push_tparams env2 tpars1 in + (match uu___15 with + | (env_tps, tpars2) -> + let t2 = + desugar_typ env_tps t in + let tpars3 = + FStarC_Syntax_Subst.close_binders + tpars2 in + FStarC_Syntax_Subst.close + tpars3 t2) in + let uu___14 = + let uu___15 = + let uu___16 = + FStarC_Ident.range_of_lid id in + mk_typ_abbrev env1 d id uvs tpars + (FStar_Pervasives_Native.Some k) + t1 [id] quals1 uu___16 in + ([], uu___15) in + [uu___14] + | FStar_Pervasives.Inl + ({ + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = tname; + FStarC_Syntax_Syntax.us = univs; + FStarC_Syntax_Syntax.params = + tpars; + FStarC_Syntax_Syntax.num_uniform_params + = num_uniform; + FStarC_Syntax_Syntax.t = k; + FStarC_Syntax_Syntax.mutuals = + mutuals1; + FStarC_Syntax_Syntax.ds = uu___4; + FStarC_Syntax_Syntax.injective_type_params + = injective_type_params;_}; + FStarC_Syntax_Syntax.sigrng = uu___5; + FStarC_Syntax_Syntax.sigquals = + tname_quals; + FStarC_Syntax_Syntax.sigmeta = uu___6; + FStarC_Syntax_Syntax.sigattrs = + uu___7; + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = uu___8; + FStarC_Syntax_Syntax.sigopts = uu___9;_}, + constrs, tconstr, quals1) + -> + let mk_tot t = + let tot1 = + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.Name + FStarC_Parser_Const.effect_Tot_lid) + t.FStarC_Parser_AST.range + t.FStarC_Parser_AST.level in + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.App + (tot1, t, + FStarC_Parser_AST.Nothing)) + t.FStarC_Parser_AST.range + t.FStarC_Parser_AST.level in + let tycon = (tname, tpars, k) in + let uu___10 = push_tparams env1 tpars in + (match uu___10 with + | (env_tps, tps) -> + let data_tpars = + FStarC_Compiler_List.map + (fun tp -> + { + FStarC_Syntax_Syntax.binder_bv + = + (tp.FStarC_Syntax_Syntax.binder_bv); + FStarC_Syntax_Syntax.binder_qual + = + (FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Implicit + true)); + FStarC_Syntax_Syntax.binder_positivity + = + (tp.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs + = + (tp.FStarC_Syntax_Syntax.binder_attrs) + }) tps in + let tot_tconstr = mk_tot tconstr in + let val_attrs = + let uu___11 = + FStarC_Syntax_DsEnv.lookup_letbinding_quals_and_attrs + env0 tname in + FStar_Pervasives_Native.snd + uu___11 in + let uu___11 = + let uu___12 = + FStarC_Compiler_List.map + (fun uu___13 -> + match uu___13 with + | (id, payload, + cons_attrs) -> + let t = + match payload with + | FStar_Pervasives_Native.Some + (FStarC_Parser_AST.VpArbitrary + t1) -> t1 + | FStar_Pervasives_Native.Some + (FStarC_Parser_AST.VpOfNotation + t1) -> + let uu___14 = + let uu___15 = + let uu___16 + = + let uu___17 + = + FStarC_Parser_AST.mk_binder + (FStarC_Parser_AST.NoName + t1) + t1.FStarC_Parser_AST.range + t1.FStarC_Parser_AST.level + FStar_Pervasives_Native.None in + [uu___17] in + (uu___16, + tot_tconstr) in + FStarC_Parser_AST.Product + uu___15 in + FStarC_Parser_AST.mk_term + uu___14 + t1.FStarC_Parser_AST.range + t1.FStarC_Parser_AST.level + | FStar_Pervasives_Native.Some + (FStarC_Parser_AST.VpRecord + uu___14) -> + failwith + "Impossible: [VpRecord _] should have disappeared after [desugar_tycon_variant_record]" + | FStar_Pervasives_Native.None + -> + let uu___14 = + FStarC_Ident.range_of_id + id in + { + FStarC_Parser_AST.tm + = + (tconstr.FStarC_Parser_AST.tm); + FStarC_Parser_AST.range + = uu___14; + FStarC_Parser_AST.level + = + (tconstr.FStarC_Parser_AST.level) + } in + let t1 = + let uu___14 = + close env_tps t in + desugar_term env_tps + uu___14 in + let name = + FStarC_Syntax_DsEnv.qualify + env1 id in + let quals2 = + FStarC_Compiler_List.collect + (fun uu___14 -> + match uu___14 + with + | FStarC_Syntax_Syntax.RecordType + fns -> + [FStarC_Syntax_Syntax.RecordConstructor + fns] + | uu___15 -> []) + tname_quals in + let ntps = + FStarC_Compiler_List.length + data_tpars in + let uu___14 = + let uu___15 = + let uu___16 = + let uu___17 = + let uu___18 = + let uu___19 + = + let uu___20 + = + FStarC_Syntax_Util.name_function_binders + t1 in + FStarC_Syntax_Syntax.mk_Total + uu___20 in + FStarC_Syntax_Util.arrow + data_tpars + uu___19 in + { + FStarC_Syntax_Syntax.lid1 + = name; + FStarC_Syntax_Syntax.us1 + = univs; + FStarC_Syntax_Syntax.t1 + = uu___18; + FStarC_Syntax_Syntax.ty_lid + = tname; + FStarC_Syntax_Syntax.num_ty_params + = ntps; + FStarC_Syntax_Syntax.mutuals1 + = mutuals1; + FStarC_Syntax_Syntax.injective_type_params1 + = + injective_type_params + } in + FStarC_Syntax_Syntax.Sig_datacon + uu___17 in + let uu___17 = + FStarC_Ident.range_of_lid + name in + let uu___18 = + let uu___19 = + let uu___20 = + let uu___21 + = + FStarC_Compiler_List.map + (desugar_term + env1) + cons_attrs in + FStarC_Compiler_List.op_At + d_attrs + uu___21 in + FStarC_Compiler_List.op_At + val_attrs + uu___20 in + FStarC_Syntax_Util.deduplicate_terms + uu___19 in + let uu___19 = + FStarC_Syntax_DsEnv.opens_and_abbrevs + env1 in + { + FStarC_Syntax_Syntax.sigel + = uu___16; + FStarC_Syntax_Syntax.sigrng + = uu___17; + FStarC_Syntax_Syntax.sigquals + = quals2; + FStarC_Syntax_Syntax.sigmeta + = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs + = uu___18; + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = uu___19; + FStarC_Syntax_Syntax.sigopts + = + FStar_Pervasives_Native.None + } in + (tps, uu___15) in + (name, uu___14)) + constrs in + FStarC_Compiler_List.split + uu___12 in + (match uu___11 with + | (constrNames, constrs1) -> + ((let uu___13 = + FStarC_Compiler_Effect.op_Bang + dbg_attrs in + if uu___13 + then + let uu___14 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + tname in + let uu___15 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_term) + val_attrs in + let uu___16 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_term) + d_attrs in + FStarC_Compiler_Util.print3 + "Adding attributes to type %s: val_attrs=[@@%s] attrs=[@@%s]\n" + uu___14 uu___15 uu___16 + else ()); + (let uu___13 = + let uu___14 = + let uu___15 = + FStarC_Ident.range_of_lid + tname in + let uu___16 = + FStarC_Syntax_Util.deduplicate_terms + (FStarC_Compiler_List.op_At + val_attrs d_attrs) in + let uu___17 = + FStarC_Syntax_DsEnv.opens_and_abbrevs + env1 in + { + FStarC_Syntax_Syntax.sigel + = + (FStarC_Syntax_Syntax.Sig_inductive_typ + { + FStarC_Syntax_Syntax.lid + = tname; + FStarC_Syntax_Syntax.us + = univs; + FStarC_Syntax_Syntax.params + = tpars; + FStarC_Syntax_Syntax.num_uniform_params + = num_uniform; + FStarC_Syntax_Syntax.t + = k; + FStarC_Syntax_Syntax.mutuals + = mutuals1; + FStarC_Syntax_Syntax.ds + = constrNames; + FStarC_Syntax_Syntax.injective_type_params + = + injective_type_params + }); + FStarC_Syntax_Syntax.sigrng + = uu___15; + FStarC_Syntax_Syntax.sigquals + = tname_quals; + FStarC_Syntax_Syntax.sigmeta + = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs + = uu___16; + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = uu___17; + FStarC_Syntax_Syntax.sigopts + = + FStar_Pervasives_Native.None + } in + ([], uu___14) in + uu___13 :: constrs1)))) + | uu___4 -> failwith "impossible")) tcs3 in + let sigelts = + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with | (uu___4, se) -> se) + tps_sigelts in + let uu___3 = + let uu___4 = + FStarC_Compiler_List.collect + FStarC_Syntax_Util.lids_of_sigelt sigelts in + FStarC_Syntax_MutRecTy.disentangle_abbrevs_from_bundle + sigelts quals uu___4 rng in + (match uu___3 with + | (bundle, abbrevs) -> + ((let uu___5 = + FStarC_Compiler_Effect.op_Bang dbg_attrs in + if uu___5 + then + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_sigelt bundle in + FStarC_Compiler_Util.print1 + "After disentangling: %s\n" uu___6 + else ()); + (let env2 = + FStarC_Syntax_DsEnv.push_sigelt env0 bundle in + let env3 = + FStarC_Compiler_List.fold_left + FStarC_Syntax_DsEnv.push_sigelt env2 abbrevs in + let data_ops = + FStarC_Compiler_List.collect + (fun uu___5 -> + match uu___5 with + | (tps, se) -> + mk_data_projector_names quals env3 se) + tps_sigelts in + let discs = + FStarC_Compiler_List.collect + (fun se -> + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = tname; + FStarC_Syntax_Syntax.us = uu___5; + FStarC_Syntax_Syntax.params = tps; + FStarC_Syntax_Syntax.num_uniform_params + = uu___6; + FStarC_Syntax_Syntax.t = k; + FStarC_Syntax_Syntax.mutuals = + uu___7; + FStarC_Syntax_Syntax.ds = constrs; + FStarC_Syntax_Syntax.injective_type_params + = uu___8;_} + -> + let quals1 = + se.FStarC_Syntax_Syntax.sigquals in + let uu___9 = + FStarC_Compiler_List.filter + (fun data_lid -> + let data_quals = + let data_se = + let uu___10 = + FStarC_Compiler_List.find + (fun se1 -> + match se1.FStarC_Syntax_Syntax.sigel + with + | FStarC_Syntax_Syntax.Sig_datacon + { + FStarC_Syntax_Syntax.lid1 + = name; + FStarC_Syntax_Syntax.us1 + = uu___11; + FStarC_Syntax_Syntax.t1 + = uu___12; + FStarC_Syntax_Syntax.ty_lid + = uu___13; + FStarC_Syntax_Syntax.num_ty_params + = uu___14; + FStarC_Syntax_Syntax.mutuals1 + = uu___15; + FStarC_Syntax_Syntax.injective_type_params1 + = uu___16;_} + -> + FStarC_Ident.lid_equals + name data_lid + | uu___11 -> false) + sigelts in + FStarC_Compiler_Util.must + uu___10 in + data_se.FStarC_Syntax_Syntax.sigquals in + let uu___10 = + FStarC_Compiler_List.existsb + (fun uu___11 -> + match uu___11 with + | FStarC_Syntax_Syntax.RecordConstructor + uu___12 -> true + | uu___12 -> false) + data_quals in + Prims.op_Negation uu___10) + constrs in + mk_data_discriminators quals1 env3 + uu___9 + se.FStarC_Syntax_Syntax.sigattrs + | uu___5 -> []) sigelts in + let ops = + FStarC_Compiler_List.op_At discs data_ops in + let env4 = + FStarC_Compiler_List.fold_left + FStarC_Syntax_DsEnv.push_sigelt env3 ops in + (env4, + (FStarC_Compiler_List.op_At [bundle] + (FStarC_Compiler_List.op_At abbrevs ops))))))) + | [] -> failwith "impossible" +let (desugar_binders : + FStarC_Syntax_DsEnv.env -> + FStarC_Parser_AST.binder Prims.list -> + (FStarC_Syntax_DsEnv.env * FStarC_Syntax_Syntax.binder Prims.list)) + = + fun env -> + fun binders -> + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun b -> + match uu___1 with + | (env1, binders1) -> + let uu___2 = desugar_binder env1 b in + (match uu___2 with + | (FStar_Pervasives_Native.Some a, k, attrs) -> + let uu___3 = + as_binder env1 b.FStarC_Parser_AST.aqual + ((FStar_Pervasives_Native.Some a), k, attrs) in + (match uu___3 with + | (binder, env2) -> (env2, (binder :: binders1))) + | uu___3 -> + FStarC_Errors.raise_error + FStarC_Parser_AST.hasRange_binder b + FStarC_Errors_Codes.Fatal_MissingNameInBinder () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "Missing name in binder"))) (env, []) + binders in + match uu___ with + | (env1, binders1) -> (env1, (FStarC_Compiler_List.rev binders1)) +let (push_reflect_effect : + FStarC_Syntax_DsEnv.env -> + FStarC_Syntax_Syntax.qualifier Prims.list -> + FStarC_Ident.lid -> + FStarC_Compiler_Range_Type.range -> FStarC_Syntax_DsEnv.env) + = + fun env -> + fun quals -> + fun effect_name -> + fun range -> + let uu___ = + FStarC_Compiler_Util.for_some + (fun uu___1 -> + match uu___1 with + | FStarC_Syntax_Syntax.Reflectable uu___2 -> true + | uu___2 -> false) quals in + if uu___ + then + let monad_env = + let uu___1 = FStarC_Ident.ident_of_lid effect_name in + FStarC_Syntax_DsEnv.enter_monad_scope env uu___1 in + let reflect_lid = + let uu___1 = FStarC_Ident.id_of_text "reflect" in + FStarC_Syntax_DsEnv.qualify monad_env uu___1 in + let quals1 = + [FStarC_Syntax_Syntax.Assumption; + FStarC_Syntax_Syntax.Reflectable effect_name] in + let refl_decl = + let uu___1 = FStarC_Syntax_DsEnv.opens_and_abbrevs env in + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_declare_typ + { + FStarC_Syntax_Syntax.lid2 = reflect_lid; + FStarC_Syntax_Syntax.us2 = []; + FStarC_Syntax_Syntax.t2 = FStarC_Syntax_Syntax.tun + }); + FStarC_Syntax_Syntax.sigrng = range; + FStarC_Syntax_Syntax.sigquals = quals1; + FStarC_Syntax_Syntax.sigmeta = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs = []; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___1; + FStarC_Syntax_Syntax.sigopts = FStar_Pervasives_Native.None + } in + FStarC_Syntax_DsEnv.push_sigelt env refl_decl + else env +let (parse_attr_with_list : + Prims.bool -> + FStarC_Syntax_Syntax.term -> + FStarC_Ident.lident -> + (Prims.int Prims.list FStar_Pervasives_Native.option * Prims.bool)) + = + fun warn -> + fun at -> + fun head -> + let warn1 uu___ = + if warn + then + let uu___1 = + let uu___2 = FStarC_Ident.string_of_lid head in + FStarC_Compiler_Util.format1 + "Found ill-applied '%s', argument should be a non-empty list of integer literals" + uu___2 in + FStarC_Errors.log_issue + (FStarC_Syntax_Syntax.has_range_syntax ()) at + FStarC_Errors_Codes.Warning_UnappliedFail () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) + else () in + let uu___ = FStarC_Syntax_Util.head_and_args at in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress hd in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv head -> + (match args with + | [] -> ((FStar_Pervasives_Native.Some []), true) + | (a1, uu___2)::[] -> + let uu___3 = + FStarC_Syntax_Embeddings_Base.unembed + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_int) a1 + FStarC_Syntax_Embeddings_Base.id_norm_cb in + (match uu___3 with + | FStar_Pervasives_Native.Some es -> + let uu___4 = + let uu___5 = + FStarC_Compiler_List.map + FStarC_BigInt.to_int_fs es in + FStar_Pervasives_Native.Some uu___5 in + (uu___4, true) + | uu___4 -> + (warn1 (); (FStar_Pervasives_Native.None, true))) + | uu___2 -> + (warn1 (); (FStar_Pervasives_Native.None, true))) + | uu___2 -> (FStar_Pervasives_Native.None, false)) +let (get_fail_attr1 : + Prims.bool -> + FStarC_Syntax_Syntax.term -> + (Prims.int Prims.list * Prims.bool) FStar_Pervasives_Native.option) + = + fun warn -> + fun at -> + let rebind res b = + match res with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some l -> + FStar_Pervasives_Native.Some (l, b) in + let uu___ = parse_attr_with_list warn at FStarC_Parser_Const.fail_attr in + match uu___ with + | (res, matched) -> + if matched + then rebind res false + else + (let uu___2 = + parse_attr_with_list warn at FStarC_Parser_Const.fail_lax_attr in + match uu___2 with | (res1, uu___3) -> rebind res1 true) +let (get_fail_attr : + Prims.bool -> + FStarC_Syntax_Syntax.term Prims.list -> + (Prims.int Prims.list * Prims.bool) FStar_Pervasives_Native.option) + = + fun warn -> + fun ats -> + let comb f1 f2 = + match (f1, f2) with + | (FStar_Pervasives_Native.Some (e1, l1), + FStar_Pervasives_Native.Some (e2, l2)) -> + FStar_Pervasives_Native.Some + ((FStarC_Compiler_List.op_At e1 e2), (l1 || l2)) + | (FStar_Pervasives_Native.Some (e, l), FStar_Pervasives_Native.None) + -> FStar_Pervasives_Native.Some (e, l) + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.Some (e, l)) + -> FStar_Pervasives_Native.Some (e, l) + | uu___ -> FStar_Pervasives_Native.None in + FStarC_Compiler_List.fold_right + (fun at -> + fun acc -> let uu___ = get_fail_attr1 warn at in comb uu___ acc) + ats FStar_Pervasives_Native.None +let (lookup_effect_lid : + FStarC_Syntax_DsEnv.env -> + FStarC_Ident.lident -> + FStarC_Compiler_Range_Type.range -> FStarC_Syntax_Syntax.eff_decl) + = + fun env -> + fun l -> + fun r -> + let uu___ = FStarC_Syntax_DsEnv.try_lookup_effect_defn env l in + match uu___ with + | FStar_Pervasives_Native.None -> + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Ident.showable_lident l in + Prims.strcat uu___3 " not found" in + Prims.strcat "Effect name " uu___2 in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_EffectNotFound () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) + | FStar_Pervasives_Native.Some l1 -> l1 +let rec (desugar_effect : + FStarC_Syntax_DsEnv.env -> + FStarC_Parser_AST.decl -> + FStarC_Syntax_Syntax.term Prims.list -> + FStarC_Parser_AST.qualifiers -> + Prims.bool -> + FStarC_Ident.ident -> + FStarC_Parser_AST.binder Prims.list -> + FStarC_Parser_AST.term -> + FStarC_Parser_AST.decl Prims.list -> + (FStarC_Syntax_DsEnv.env * FStarC_Syntax_Syntax.sigelt + Prims.list)) + = + fun env -> + fun d -> + fun d_attrs -> + fun quals -> + fun is_layered -> + fun eff_name -> + fun eff_binders -> + fun eff_typ -> + fun eff_decls -> + let env0 = env in + let monad_env = + FStarC_Syntax_DsEnv.enter_monad_scope env eff_name in + let uu___ = desugar_binders monad_env eff_binders in + match uu___ with + | (env1, binders) -> + let eff_t = desugar_term env1 eff_typ in + let num_indices = + let uu___1 = + let uu___2 = + FStarC_Syntax_Util.arrow_formals eff_t in + FStar_Pervasives_Native.fst uu___2 in + FStarC_Compiler_List.length uu___1 in + let for_free = + (num_indices = Prims.int_one) && + (Prims.op_Negation is_layered) in + (if for_free + then + (let uu___2 = + let uu___3 = FStarC_Ident.string_of_id eff_name in + FStarC_Compiler_Util.format1 + "DM4Free feature is deprecated and will be removed soon, use layered effects to define %s" + uu___3 in + FStarC_Errors.log_issue + FStarC_Parser_AST.hasRange_decl d + FStarC_Errors_Codes.Warning_DeprecatedGeneric + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)) + else (); + (let mandatory_members = + let rr_members = ["repr"; "return"; "bind"] in + if for_free + then rr_members + else + if is_layered + then + FStarC_Compiler_List.op_At rr_members + ["subcomp"; "if_then_else"; "close"] + else + FStarC_Compiler_List.op_At rr_members + ["return_wp"; + "bind_wp"; + "if_then_else"; + "ite_wp"; + "stronger"; + "close_wp"; + "trivial"] in + let name_of_eff_decl decl = + match decl.FStarC_Parser_AST.d with + | FStarC_Parser_AST.Tycon + (uu___2, uu___3, + (FStarC_Parser_AST.TyconAbbrev + (name, uu___4, uu___5, uu___6))::[]) + -> FStarC_Ident.string_of_id name + | uu___2 -> + failwith + "Malformed effect member declaration." in + let uu___2 = + FStarC_Compiler_List.partition + (fun decl -> + let uu___3 = name_of_eff_decl decl in + FStarC_Compiler_List.mem uu___3 + mandatory_members) eff_decls in + match uu___2 with + | (mandatory_members_decls, actions) -> + let uu___3 = + FStarC_Compiler_List.fold_left + (fun uu___4 -> + fun decl -> + match uu___4 with + | (env2, out) -> + let uu___5 = + desugar_decl env2 decl in + (match uu___5 with + | (env3, ses) -> + let uu___6 = + let uu___7 = + FStarC_Compiler_List.hd + ses in + uu___7 :: out in + (env3, uu___6))) (env1, []) + mandatory_members_decls in + (match uu___3 with + | (env2, decls) -> + let binders1 = + FStarC_Syntax_Subst.close_binders + binders in + let actions1 = + FStarC_Compiler_List.map + (fun d1 -> + match d1.FStarC_Parser_AST.d with + | FStarC_Parser_AST.Tycon + (uu___4, uu___5, + (FStarC_Parser_AST.TyconAbbrev + (name, action_params, uu___6, + { + FStarC_Parser_AST.tm = + FStarC_Parser_AST.Construct + (uu___7, + (def, uu___8)::(cps_type, + uu___9)::[]); + FStarC_Parser_AST.range = + uu___10; + FStarC_Parser_AST.level = + uu___11;_}))::[]) + when Prims.op_Negation for_free + -> + let uu___12 = + desugar_binders env2 + action_params in + (match uu___12 with + | (env3, action_params1) -> + let action_params2 = + FStarC_Syntax_Subst.close_binders + action_params1 in + let uu___13 = + FStarC_Syntax_DsEnv.qualify + env3 name in + let uu___14 = + let uu___15 = + desugar_term env3 def in + FStarC_Syntax_Subst.close + (FStarC_Compiler_List.op_At + binders1 + action_params2) + uu___15 in + let uu___15 = + let uu___16 = + desugar_typ env3 + cps_type in + FStarC_Syntax_Subst.close + (FStarC_Compiler_List.op_At + binders1 + action_params2) + uu___16 in + { + FStarC_Syntax_Syntax.action_name + = uu___13; + FStarC_Syntax_Syntax.action_unqualified_name + = name; + FStarC_Syntax_Syntax.action_univs + = []; + FStarC_Syntax_Syntax.action_params + = action_params2; + FStarC_Syntax_Syntax.action_defn + = uu___14; + FStarC_Syntax_Syntax.action_typ + = uu___15 + }) + | FStarC_Parser_AST.Tycon + (uu___4, uu___5, + (FStarC_Parser_AST.TyconAbbrev + (name, action_params, uu___6, + defn))::[]) + when for_free || is_layered -> + let uu___7 = + desugar_binders env2 + action_params in + (match uu___7 with + | (env3, action_params1) -> + let action_params2 = + FStarC_Syntax_Subst.close_binders + action_params1 in + let uu___8 = + FStarC_Syntax_DsEnv.qualify + env3 name in + let uu___9 = + let uu___10 = + desugar_term env3 defn in + FStarC_Syntax_Subst.close + (FStarC_Compiler_List.op_At + binders1 + action_params2) + uu___10 in + { + FStarC_Syntax_Syntax.action_name + = uu___8; + FStarC_Syntax_Syntax.action_unqualified_name + = name; + FStarC_Syntax_Syntax.action_univs + = []; + FStarC_Syntax_Syntax.action_params + = action_params2; + FStarC_Syntax_Syntax.action_defn + = uu___9; + FStarC_Syntax_Syntax.action_typ + = + FStarC_Syntax_Syntax.tun + }) + | uu___4 -> + FStarC_Errors.raise_error + FStarC_Parser_AST.hasRange_decl + d1 + FStarC_Errors_Codes.Fatal_MalformedActionDeclaration + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Malformed action declaration; if this is an \"effect for free\", just provide the direct-style declaration. If this is not an \"effect for free\", please provide a pair of the definition and its cps-type with arrows inserted in the right place (see examples).")) + actions in + let eff_t1 = + FStarC_Syntax_Subst.close binders1 eff_t in + let lookup s = + let l = + let uu___4 = + FStarC_Ident.mk_ident + (s, (d.FStarC_Parser_AST.drange)) in + FStarC_Syntax_DsEnv.qualify env2 + uu___4 in + let uu___4 = + let uu___5 = + FStarC_Syntax_DsEnv.fail_or env2 + (FStarC_Syntax_DsEnv.try_lookup_definition + env2) l in + FStarC_Syntax_Subst.close binders1 + uu___5 in + ([], uu___4) in + let mname = + FStarC_Syntax_DsEnv.qualify env0 + eff_name in + let qualifiers = + FStarC_Compiler_List.map + (trans_qual d.FStarC_Parser_AST.drange + (FStar_Pervasives_Native.Some mname)) + quals in + let dummy_tscheme = + ([], FStarC_Syntax_Syntax.tun) in + let uu___4 = + if for_free + then + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = lookup "repr" in + FStar_Pervasives_Native.Some + uu___8 in + let uu___8 = + let uu___9 = lookup "return" in + FStar_Pervasives_Native.Some + uu___9 in + let uu___9 = + let uu___10 = lookup "bind" in + FStar_Pervasives_Native.Some + uu___10 in + { + FStarC_Syntax_Syntax.ret_wp = + dummy_tscheme; + FStarC_Syntax_Syntax.bind_wp = + dummy_tscheme; + FStarC_Syntax_Syntax.stronger = + dummy_tscheme; + FStarC_Syntax_Syntax.if_then_else + = dummy_tscheme; + FStarC_Syntax_Syntax.ite_wp = + dummy_tscheme; + FStarC_Syntax_Syntax.close_wp = + dummy_tscheme; + FStarC_Syntax_Syntax.trivial = + dummy_tscheme; + FStarC_Syntax_Syntax.repr = + uu___7; + FStarC_Syntax_Syntax.return_repr + = uu___8; + FStarC_Syntax_Syntax.bind_repr = + uu___9 + } in + FStarC_Syntax_Syntax.DM4F_eff uu___6 in + ((FStarC_Syntax_Syntax.WP_eff_sig + ([], eff_t1)), uu___5) + else + if is_layered + then + (let has_subcomp = + FStarC_Compiler_List.existsb + (fun decl -> + let uu___6 = + name_of_eff_decl decl in + uu___6 = "subcomp") + eff_decls in + let has_if_then_else = + FStarC_Compiler_List.existsb + (fun decl -> + let uu___6 = + name_of_eff_decl decl in + uu___6 = "if_then_else") + eff_decls in + let has_close = + FStarC_Compiler_List.existsb + (fun decl -> + let uu___6 = + name_of_eff_decl decl in + uu___6 = "close") eff_decls in + let to_comb uu___6 = + match uu___6 with + | (us, t) -> + ((us, t), dummy_tscheme, + FStar_Pervasives_Native.None) in + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Subst.compress + eff_t1 in + uu___8.FStarC_Syntax_Syntax.n in + match uu___7 with + | FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 = + bs; + FStarC_Syntax_Syntax.comp = + c;_} + -> + let uu___8 = bs in + (match uu___8 with + | a::bs1 -> + let uu___9 = + FStarC_Compiler_List.fold_left + (fun uu___10 -> + fun b -> + match uu___10 + with + | (n, + allow_param, + bs2) -> + let b_attrs + = + b.FStarC_Syntax_Syntax.binder_attrs in + let is_param + = + FStarC_Syntax_Util.has_attribute + b_attrs + FStarC_Parser_Const.effect_parameter_attr in + (if + is_param + && + (Prims.op_Negation + allow_param) + then + FStarC_Errors.raise_error + FStarC_Parser_AST.hasRange_decl + d + FStarC_Errors_Codes.Fatal_UnexpectedEffect + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Effect parameters must all be upfront") + else (); + (let b_attrs1 + = + FStarC_Syntax_Util.remove_attr + FStarC_Parser_Const.effect_parameter_attr + b_attrs in + ((if + is_param + then + n + + Prims.int_one + else n), + (allow_param + && + is_param), + (FStarC_Compiler_List.op_At + bs2 + [ + { + FStarC_Syntax_Syntax.binder_bv + = + (b.FStarC_Syntax_Syntax.binder_bv); + FStarC_Syntax_Syntax.binder_qual + = + (b.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity + = + (b.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs + = + b_attrs1 + }]))))) + (Prims.int_zero, + true, []) bs1 in + (match uu___9 with + | (n, uu___10, bs2) -> + ({ + FStarC_Syntax_Syntax.n + = + (FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 + = (a :: + bs2); + FStarC_Syntax_Syntax.comp + = c + }); + FStarC_Syntax_Syntax.pos + = + (eff_t1.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars + = + (eff_t1.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code + = + (eff_t1.FStarC_Syntax_Syntax.hash_code) + }, n))) + | uu___8 -> + failwith + "desugaring indexed effect: effect type not an arrow" in + match uu___6 with + | (eff_t2, num_effect_params) -> + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + lookup "repr" in + (uu___10, dummy_tscheme) in + let uu___10 = + let uu___11 = + lookup "return" in + (uu___11, dummy_tscheme) in + let uu___11 = + let uu___12 = + lookup "bind" in + to_comb uu___12 in + let uu___12 = + if has_subcomp + then + let uu___13 = + lookup "subcomp" in + to_comb uu___13 + else + (dummy_tscheme, + dummy_tscheme, + FStar_Pervasives_Native.None) in + let uu___13 = + if has_if_then_else + then + let uu___14 = + lookup "if_then_else" in + to_comb uu___14 + else + (dummy_tscheme, + dummy_tscheme, + FStar_Pervasives_Native.None) in + let uu___14 = + if has_close + then + let uu___15 = + let uu___16 = + lookup "close" in + (uu___16, + dummy_tscheme) in + FStar_Pervasives_Native.Some + uu___15 + else + FStar_Pervasives_Native.None in + { + FStarC_Syntax_Syntax.l_repr + = uu___9; + FStarC_Syntax_Syntax.l_return + = uu___10; + FStarC_Syntax_Syntax.l_bind + = uu___11; + FStarC_Syntax_Syntax.l_subcomp + = uu___12; + FStarC_Syntax_Syntax.l_if_then_else + = uu___13; + FStarC_Syntax_Syntax.l_close + = uu___14 + } in + FStarC_Syntax_Syntax.Layered_eff + uu___8 in + ((FStarC_Syntax_Syntax.Layered_eff_sig + (num_effect_params, + ([], eff_t2))), uu___7)) + else + (let rr = + FStarC_Compiler_Util.for_some + (fun uu___7 -> + match uu___7 with + | FStarC_Syntax_Syntax.Reifiable + -> true + | FStarC_Syntax_Syntax.Reflectable + uu___8 -> true + | uu___8 -> false) + qualifiers in + let uu___7 = + let uu___8 = + let uu___9 = lookup "return_wp" in + let uu___10 = lookup "bind_wp" in + let uu___11 = lookup "stronger" in + let uu___12 = + lookup "if_then_else" in + let uu___13 = lookup "ite_wp" in + let uu___14 = lookup "close_wp" in + let uu___15 = lookup "trivial" in + let uu___16 = + if rr + then + let uu___17 = lookup "repr" in + FStar_Pervasives_Native.Some + uu___17 + else + FStar_Pervasives_Native.None in + let uu___17 = + if rr + then + let uu___18 = + lookup "return" in + FStar_Pervasives_Native.Some + uu___18 + else + FStar_Pervasives_Native.None in + let uu___18 = + if rr + then + let uu___19 = lookup "bind" in + FStar_Pervasives_Native.Some + uu___19 + else + FStar_Pervasives_Native.None in + { + FStarC_Syntax_Syntax.ret_wp = + uu___9; + FStarC_Syntax_Syntax.bind_wp + = uu___10; + FStarC_Syntax_Syntax.stronger + = uu___11; + FStarC_Syntax_Syntax.if_then_else + = uu___12; + FStarC_Syntax_Syntax.ite_wp = + uu___13; + FStarC_Syntax_Syntax.close_wp + = uu___14; + FStarC_Syntax_Syntax.trivial + = uu___15; + FStarC_Syntax_Syntax.repr = + uu___16; + FStarC_Syntax_Syntax.return_repr + = uu___17; + FStarC_Syntax_Syntax.bind_repr + = uu___18 + } in + FStarC_Syntax_Syntax.Primitive_eff + uu___8 in + ((FStarC_Syntax_Syntax.WP_eff_sig + ([], eff_t1)), uu___7)) in + (match uu___4 with + | (eff_sig, combinators) -> + let extraction_mode = + if is_layered + then + FStarC_Syntax_Syntax.Extract_none + "" + else + if for_free + then + (let uu___6 = + FStarC_Compiler_Util.for_some + (fun uu___7 -> + match uu___7 with + | FStarC_Syntax_Syntax.Reifiable + -> true + | uu___8 -> false) + qualifiers in + if uu___6 + then + FStarC_Syntax_Syntax.Extract_reify + else + FStarC_Syntax_Syntax.Extract_primitive) + else + FStarC_Syntax_Syntax.Extract_primitive in + let sigel = + FStarC_Syntax_Syntax.Sig_new_effect + { + FStarC_Syntax_Syntax.mname = + mname; + FStarC_Syntax_Syntax.cattributes + = []; + FStarC_Syntax_Syntax.univs = []; + FStarC_Syntax_Syntax.binders = + binders1; + FStarC_Syntax_Syntax.signature + = eff_sig; + FStarC_Syntax_Syntax.combinators + = combinators; + FStarC_Syntax_Syntax.actions = + actions1; + FStarC_Syntax_Syntax.eff_attrs + = d_attrs; + FStarC_Syntax_Syntax.extraction_mode + = extraction_mode + } in + let se = + let uu___5 = + FStarC_Syntax_DsEnv.opens_and_abbrevs + env2 in + { + FStarC_Syntax_Syntax.sigel = + sigel; + FStarC_Syntax_Syntax.sigrng = + (d.FStarC_Parser_AST.drange); + FStarC_Syntax_Syntax.sigquals = + qualifiers; + FStarC_Syntax_Syntax.sigmeta = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs = + d_attrs; + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = uu___5; + FStarC_Syntax_Syntax.sigopts = + FStar_Pervasives_Native.None + } in + let env3 = + FStarC_Syntax_DsEnv.push_sigelt + env0 se in + let env4 = + FStarC_Compiler_List.fold_left + (fun env5 -> + fun a -> + let uu___5 = + FStarC_Syntax_Util.action_as_lb + mname a + (a.FStarC_Syntax_Syntax.action_defn).FStarC_Syntax_Syntax.pos in + FStarC_Syntax_DsEnv.push_sigelt + env5 uu___5) env3 actions1 in + let env5 = + push_reflect_effect env4 qualifiers + mname d.FStarC_Parser_AST.drange in + (env5, [se]))))) +and (desugar_redefine_effect : + FStarC_Syntax_DsEnv.env -> + FStarC_Parser_AST.decl -> + FStarC_Syntax_Syntax.attribute Prims.list -> + (FStarC_Ident.lident FStar_Pervasives_Native.option -> + FStarC_Parser_AST.qualifier -> FStarC_Syntax_Syntax.qualifier) + -> + FStarC_Parser_AST.qualifier Prims.list -> + FStarC_Ident.ident -> + FStarC_Parser_AST.binder Prims.list -> + FStarC_Parser_AST.term -> + (FStarC_Syntax_DsEnv.env * FStarC_Syntax_Syntax.sigelt + Prims.list)) + = + fun env -> + fun d -> + fun d_attrs -> + fun trans_qual1 -> + fun quals -> + fun eff_name -> + fun eff_binders -> + fun defn -> + let env0 = env in + let env1 = + FStarC_Syntax_DsEnv.enter_monad_scope env eff_name in + let uu___ = desugar_binders env1 eff_binders in + match uu___ with + | (env2, binders) -> + let uu___1 = + let uu___2 = head_and_args defn in + match uu___2 with + | (head, args) -> + let lid = + match head.FStarC_Parser_AST.tm with + | FStarC_Parser_AST.Name l -> l + | uu___3 -> + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Parser_AST.term_to_string head in + Prims.strcat uu___6 " not found" in + Prims.strcat "Effect " uu___5 in + FStarC_Errors.raise_error + FStarC_Parser_AST.hasRange_decl d + FStarC_Errors_Codes.Fatal_EffectNotFound + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4) in + let ed = + FStarC_Syntax_DsEnv.fail_or env2 + (FStarC_Syntax_DsEnv.try_lookup_effect_defn + env2) lid in + let uu___3 = + match FStarC_Compiler_List.rev args with + | (last_arg, uu___4)::args_rev -> + let uu___5 = + let uu___6 = unparen last_arg in + uu___6.FStarC_Parser_AST.tm in + (match uu___5 with + | FStarC_Parser_AST.Attributes ts -> + (ts, + (FStarC_Compiler_List.rev args_rev)) + | uu___6 -> ([], args)) + | uu___4 -> ([], args) in + (match uu___3 with + | (cattributes, args1) -> + let uu___4 = desugar_args env2 args1 in + let uu___5 = + desugar_attributes env2 cattributes in + (lid, ed, uu___4, uu___5)) in + (match uu___1 with + | (ed_lid, ed, args, cattributes) -> + let binders1 = + FStarC_Syntax_Subst.close_binders binders in + (if + (FStarC_Compiler_List.length args) <> + (FStarC_Compiler_List.length + ed.FStarC_Syntax_Syntax.binders) + then + FStarC_Errors.raise_error + FStarC_Parser_AST.hasRange_term defn + FStarC_Errors_Codes.Fatal_ArgumentLengthMismatch + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Unexpected number of arguments to effect constructor") + else (); + (let uu___3 = + FStarC_Syntax_Subst.open_term' + ed.FStarC_Syntax_Syntax.binders + FStarC_Syntax_Syntax.t_unit in + match uu___3 with + | (ed_binders, uu___4, ed_binders_opening) -> + let sub' shift_n uu___5 = + match uu___5 with + | (us, x) -> + let x1 = + let uu___6 = + FStarC_Syntax_Subst.shift_subst + (shift_n + + (FStarC_Compiler_List.length + us)) ed_binders_opening in + FStarC_Syntax_Subst.subst uu___6 x in + let s = + FStarC_Syntax_Util.subst_of_list + ed_binders args in + let uu___6 = + let uu___7 = + FStarC_Syntax_Subst.subst s x1 in + (us, uu___7) in + FStarC_Syntax_Subst.close_tscheme + binders1 uu___6 in + let sub = sub' Prims.int_zero in + let mname = + FStarC_Syntax_DsEnv.qualify env0 eff_name in + let ed1 = + let uu___5 = + FStarC_Syntax_Util.apply_eff_sig sub + ed.FStarC_Syntax_Syntax.signature in + let uu___6 = + FStarC_Syntax_Util.apply_eff_combinators + sub + ed.FStarC_Syntax_Syntax.combinators in + let uu___7 = + FStarC_Compiler_List.map + (fun action -> + let nparam = + FStarC_Compiler_List.length + action.FStarC_Syntax_Syntax.action_params in + let uu___8 = + FStarC_Syntax_DsEnv.qualify env2 + action.FStarC_Syntax_Syntax.action_unqualified_name in + let uu___9 = + let uu___10 = + sub' nparam + ([], + (action.FStarC_Syntax_Syntax.action_defn)) in + FStar_Pervasives_Native.snd + uu___10 in + let uu___10 = + let uu___11 = + sub' nparam + ([], + (action.FStarC_Syntax_Syntax.action_typ)) in + FStar_Pervasives_Native.snd + uu___11 in + { + FStarC_Syntax_Syntax.action_name + = uu___8; + FStarC_Syntax_Syntax.action_unqualified_name + = + (action.FStarC_Syntax_Syntax.action_unqualified_name); + FStarC_Syntax_Syntax.action_univs + = + (action.FStarC_Syntax_Syntax.action_univs); + FStarC_Syntax_Syntax.action_params + = + (action.FStarC_Syntax_Syntax.action_params); + FStarC_Syntax_Syntax.action_defn + = uu___9; + FStarC_Syntax_Syntax.action_typ = + uu___10 + }) ed.FStarC_Syntax_Syntax.actions in + { + FStarC_Syntax_Syntax.mname = mname; + FStarC_Syntax_Syntax.cattributes = + cattributes; + FStarC_Syntax_Syntax.univs = + (ed.FStarC_Syntax_Syntax.univs); + FStarC_Syntax_Syntax.binders = binders1; + FStarC_Syntax_Syntax.signature = uu___5; + FStarC_Syntax_Syntax.combinators = + uu___6; + FStarC_Syntax_Syntax.actions = uu___7; + FStarC_Syntax_Syntax.eff_attrs = + (ed.FStarC_Syntax_Syntax.eff_attrs); + FStarC_Syntax_Syntax.extraction_mode = + (ed.FStarC_Syntax_Syntax.extraction_mode) + } in + let se = + let uu___5 = + let uu___6 = + trans_qual1 + (FStar_Pervasives_Native.Some mname) in + FStarC_Compiler_List.map uu___6 quals in + let uu___6 = + FStarC_Syntax_DsEnv.opens_and_abbrevs + env2 in + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_new_effect + ed1); + FStarC_Syntax_Syntax.sigrng = + (d.FStarC_Parser_AST.drange); + FStarC_Syntax_Syntax.sigquals = uu___5; + FStarC_Syntax_Syntax.sigmeta = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs = d_attrs; + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = uu___6; + FStarC_Syntax_Syntax.sigopts = + FStar_Pervasives_Native.None + } in + let monad_env = env2 in + let env3 = + FStarC_Syntax_DsEnv.push_sigelt env0 se in + let env4 = + FStarC_Compiler_List.fold_left + (fun env5 -> + fun a -> + let uu___5 = + FStarC_Syntax_Util.action_as_lb + mname a + (a.FStarC_Syntax_Syntax.action_defn).FStarC_Syntax_Syntax.pos in + FStarC_Syntax_DsEnv.push_sigelt + env5 uu___5) env3 + ed1.FStarC_Syntax_Syntax.actions in + let env5 = + if + FStarC_Compiler_List.contains + FStarC_Parser_AST.Reflectable quals + then + let reflect_lid = + let uu___5 = + FStarC_Ident.id_of_text "reflect" in + FStarC_Syntax_DsEnv.qualify monad_env + uu___5 in + let quals1 = + [FStarC_Syntax_Syntax.Assumption; + FStarC_Syntax_Syntax.Reflectable mname] in + let refl_decl = + let uu___5 = + FStarC_Syntax_DsEnv.opens_and_abbrevs + env4 in + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_declare_typ + { + FStarC_Syntax_Syntax.lid2 = + reflect_lid; + FStarC_Syntax_Syntax.us2 = []; + FStarC_Syntax_Syntax.t2 = + FStarC_Syntax_Syntax.tun + }); + FStarC_Syntax_Syntax.sigrng = + (d.FStarC_Parser_AST.drange); + FStarC_Syntax_Syntax.sigquals = + quals1; + FStarC_Syntax_Syntax.sigmeta = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs = []; + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = uu___5; + FStarC_Syntax_Syntax.sigopts = + FStar_Pervasives_Native.None + } in + FStarC_Syntax_DsEnv.push_sigelt env4 + refl_decl + else env4 in + (env5, [se])))) +and (desugar_decl_maybe_fail_attr : + FStarC_Syntax_DsEnv.env -> + FStarC_Parser_AST.decl -> (env_t * FStarC_Syntax_Syntax.sigelts)) + = + fun env -> + fun d -> + let no_fail_attrs ats = + FStarC_Compiler_List.filter + (fun at -> + let uu___ = get_fail_attr1 false at in + FStarC_Compiler_Option.isNone uu___) ats in + let env0 = + let uu___ = FStarC_Syntax_DsEnv.snapshot env in + FStar_Pervasives_Native.snd uu___ in + let uu___ = + let attrs = + let uu___1 = + FStarC_Compiler_List.map (desugar_term env) + d.FStarC_Parser_AST.attrs in + FStarC_Syntax_Util.deduplicate_terms uu___1 in + let uu___1 = get_fail_attr false attrs in + match uu___1 with + | FStar_Pervasives_Native.Some (expected_errs, lax) -> + let d1 = + { + FStarC_Parser_AST.d = (d.FStarC_Parser_AST.d); + FStarC_Parser_AST.drange = (d.FStarC_Parser_AST.drange); + FStarC_Parser_AST.quals = (d.FStarC_Parser_AST.quals); + FStarC_Parser_AST.attrs = []; + FStarC_Parser_AST.interleaved = + (d.FStarC_Parser_AST.interleaved) + } in + let uu___2 = + FStarC_Errors.catch_errors + (fun uu___3 -> + FStarC_Options.with_saved_options + (fun uu___4 -> desugar_decl_core env attrs d1)) in + (match uu___2 with + | (errs, r) -> + (match (errs, r) with + | ([], FStar_Pervasives_Native.Some (env1, ses)) -> + let ses1 = + FStarC_Compiler_List.map + (fun se -> + let uu___3 = no_fail_attrs attrs in + { + FStarC_Syntax_Syntax.sigel = + (se.FStarC_Syntax_Syntax.sigel); + FStarC_Syntax_Syntax.sigrng = + (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = uu___3; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se.FStarC_Syntax_Syntax.sigopts) + }) ses in + let se = + let uu___3 = + FStarC_Syntax_DsEnv.opens_and_abbrevs env1 in + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_fail + { + FStarC_Syntax_Syntax.errs = expected_errs; + FStarC_Syntax_Syntax.fail_in_lax = lax; + FStarC_Syntax_Syntax.ses1 = ses1 + }); + FStarC_Syntax_Syntax.sigrng = + (d1.FStarC_Parser_AST.drange); + FStarC_Syntax_Syntax.sigquals = []; + FStarC_Syntax_Syntax.sigmeta = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs = attrs; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___3; + FStarC_Syntax_Syntax.sigopts = + FStar_Pervasives_Native.None + } in + (env0, [se]) + | (errs1, ropt) -> + let errnos = + FStarC_Compiler_List.concatMap + (fun i -> + FStarC_Common.list_of_option + i.FStarC_Errors.issue_number) errs1 in + ((let uu___4 = + FStarC_Options.print_expected_failures () in + if uu___4 + then + (FStarC_Compiler_Util.print_string + ">> Got issues: [\n"; + FStarC_Compiler_List.iter + FStarC_Errors.print_issue errs1; + FStarC_Compiler_Util.print_string ">>]\n") + else ()); + if expected_errs = [] + then (env0, []) + else + (let uu___5 = + FStarC_Errors.find_multiset_discrepancy + expected_errs errnos in + match uu___5 with + | FStar_Pervasives_Native.None -> (env0, []) + | FStar_Pervasives_Native.Some (e, n1, n2) -> + (FStarC_Compiler_List.iter + FStarC_Errors.print_issue errs1; + (let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Errors_Msg.text + "This top-level definition was expected to raise error codes" in + let uu___12 = + FStarC_Class_PP.pp + (FStarC_Class_PP.pp_list + FStarC_Class_PP.pp_int) + expected_errs in + FStarC_Pprint.prefix (Prims.of_int (2)) + Prims.int_one uu___11 uu___12 in + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Errors_Msg.text + "but it raised" in + let uu___14 = + FStarC_Class_PP.pp + (FStarC_Class_PP.pp_list + FStarC_Class_PP.pp_int) errnos in + FStarC_Pprint.prefix + (Prims.of_int (2)) Prims.int_one + uu___13 uu___14 in + let uu___13 = + let uu___14 = + FStarC_Errors_Msg.text + "(at desugaring time)" in + FStarC_Pprint.op_Hat_Hat uu___14 + FStarC_Pprint.dot in + FStarC_Pprint.op_Hat_Hat uu___12 + uu___13 in + FStarC_Pprint.op_Hat_Slash_Hat uu___10 + uu___11 in + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + e in + let uu___14 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + n2 in + let uu___15 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + n1 in + FStarC_Compiler_Util.format3 + "Error #%s was raised %s times, instead of %s." + uu___13 uu___14 uu___15 in + FStarC_Errors_Msg.text uu___12 in + [uu___11] in + uu___9 :: uu___10 in + FStarC_Errors.log_issue + FStarC_Parser_AST.hasRange_decl d1 + FStarC_Errors_Codes.Error_DidNotFail () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___8)); + (env0, [])))))) + | FStar_Pervasives_Native.None -> desugar_decl_core env attrs d in + match uu___ with | (env1, sigelts) -> (env1, sigelts) +and (desugar_decl : + env_t -> FStarC_Parser_AST.decl -> (env_t * FStarC_Syntax_Syntax.sigelts)) + = + fun env -> + fun d -> + FStarC_GenSym.reset_gensym (); + (let uu___1 = desugar_decl_maybe_fail_attr env d in + match uu___1 with + | (env1, ses) -> + let uu___2 = + FStarC_Compiler_List.map generalize_annotated_univs ses in + (env1, uu___2)) +and (desugar_decl_core : + FStarC_Syntax_DsEnv.env -> + FStarC_Syntax_Syntax.term Prims.list -> + FStarC_Parser_AST.decl -> (env_t * FStarC_Syntax_Syntax.sigelts)) + = + fun env -> + fun d_attrs -> + fun d -> + let trans_qual1 = trans_qual d.FStarC_Parser_AST.drange in + match d.FStarC_Parser_AST.d with + | FStarC_Parser_AST.Pragma p -> + let p1 = trans_pragma p in + (FStarC_Syntax_Util.process_pragma p1 d.FStarC_Parser_AST.drange; + (let se = + let uu___1 = FStarC_Syntax_DsEnv.opens_and_abbrevs env in + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_pragma p1); + FStarC_Syntax_Syntax.sigrng = (d.FStarC_Parser_AST.drange); + FStarC_Syntax_Syntax.sigquals = []; + FStarC_Syntax_Syntax.sigmeta = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs = d_attrs; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___1; + FStarC_Syntax_Syntax.sigopts = FStar_Pervasives_Native.None + } in + (env, [se]))) + | FStarC_Parser_AST.TopLevelModule id -> (env, []) + | FStarC_Parser_AST.Open (lid, restriction) -> + let env1 = FStarC_Syntax_DsEnv.push_namespace env lid restriction in + (env1, []) + | FStarC_Parser_AST.Friend lid -> + let uu___ = FStarC_Syntax_DsEnv.iface env in + if uu___ + then + FStarC_Errors.raise_error FStarC_Parser_AST.hasRange_decl d + FStarC_Errors_Codes.Fatal_FriendInterface () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "'friend' declarations are not allowed in interfaces") + else + (let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_DsEnv.dep_graph env in + let uu___5 = FStarC_Syntax_DsEnv.current_module env in + FStarC_Parser_Dep.module_has_interface uu___4 uu___5 in + Prims.op_Negation uu___3 in + if uu___2 + then + FStarC_Errors.raise_error FStarC_Parser_AST.hasRange_decl d + FStarC_Errors_Codes.Fatal_FriendInterface () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "'friend' declarations are not allowed in modules that lack interfaces") + else + (let uu___4 = + let uu___5 = + let uu___6 = FStarC_Syntax_DsEnv.dep_graph env in + FStarC_Parser_Dep.module_has_interface uu___6 lid in + Prims.op_Negation uu___5 in + if uu___4 + then + FStarC_Errors.raise_error FStarC_Parser_AST.hasRange_decl + d FStarC_Errors_Codes.Fatal_FriendInterface () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "'friend' declarations cannot refer to modules that lack interfaces") + else + (let uu___6 = + let uu___7 = + let uu___8 = FStarC_Syntax_DsEnv.dep_graph env in + FStarC_Parser_Dep.deps_has_implementation uu___8 lid in + Prims.op_Negation uu___7 in + if uu___6 + then + FStarC_Errors.raise_error + FStarC_Parser_AST.hasRange_decl d + FStarC_Errors_Codes.Fatal_FriendInterface () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "'friend' module has not been loaded; recompute dependences (C-c C-r) if in interactive mode") + else (env, [])))) + | FStarC_Parser_AST.Include (lid, restriction) -> + let env1 = FStarC_Syntax_DsEnv.push_include env lid restriction in + (env1, []) + | FStarC_Parser_AST.ModuleAbbrev (x, l) -> + let uu___ = FStarC_Syntax_DsEnv.push_module_abbrev env x l in + (uu___, []) + | FStarC_Parser_AST.Tycon (is_effect, typeclass, tcs) -> + let quals = d.FStarC_Parser_AST.quals in + let quals1 = + if is_effect + then FStarC_Parser_AST.Effect_qual :: quals + else quals in + let quals2 = + if typeclass + then + match tcs with + | (FStarC_Parser_AST.TyconRecord uu___)::[] -> + FStarC_Parser_AST.Noeq :: quals1 + | uu___ -> + FStarC_Errors.raise_error FStarC_Parser_AST.hasRange_decl + d FStarC_Errors_Codes.Error_BadClassDecl () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Ill-formed `class` declaration: definition must be a record type") + else quals1 in + let uu___ = + let uu___1 = + FStarC_Compiler_List.map + (trans_qual1 FStar_Pervasives_Native.None) quals2 in + desugar_tycon env d d_attrs uu___1 tcs in + (match uu___ with + | (env1, ses) -> + ((let uu___2 = FStarC_Compiler_Effect.op_Bang dbg_attrs in + if uu___2 + then + let uu___3 = + FStarC_Class_Show.show FStarC_Parser_AST.showable_decl + d in + let uu___4 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_sigelt) ses in + FStarC_Compiler_Util.print2 + "Desugared tycon from {%s} to {%s}\n" uu___3 uu___4 + else ()); + (let mkclass lid = + let r = FStarC_Ident.range_of_lid lid in + let body = + let uu___2 = + FStarC_Syntax_Util.has_attribute d_attrs + FStarC_Parser_Const.meta_projectors_attr in + if uu___2 + then + let uu___3 = + FStarC_Syntax_Syntax.tabbrev + FStarC_Parser_Const.mk_projs_lid in + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Syntax_Util.exp_bool true in + FStarC_Syntax_Syntax.as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = FStarC_Ident.string_of_lid lid in + FStarC_Syntax_Util.exp_string uu___9 in + FStarC_Syntax_Syntax.as_arg uu___8 in + [uu___7] in + uu___5 :: uu___6 in + FStarC_Syntax_Util.mk_app uu___3 uu___4 + else + (let uu___4 = + FStarC_Syntax_Syntax.tabbrev + FStarC_Parser_Const.mk_class_lid in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Ident.string_of_lid lid in + FStarC_Syntax_Util.exp_string uu___8 in + FStarC_Syntax_Syntax.as_arg uu___7 in + [uu___6] in + FStarC_Syntax_Util.mk_app uu___4 uu___5) in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = tun_r r in + FStarC_Syntax_Syntax.new_bv + (FStar_Pervasives_Native.Some r) uu___5 in + FStarC_Syntax_Syntax.mk_binder uu___4 in + [uu___3] in + FStarC_Syntax_Util.abs uu___2 body + FStar_Pervasives_Native.None in + let get_meths se = + let rec get_fname quals3 = + match quals3 with + | (FStarC_Syntax_Syntax.Projector + (uu___2, id))::uu___3 -> + FStar_Pervasives_Native.Some id + | uu___2::quals4 -> get_fname quals4 + | [] -> FStar_Pervasives_Native.None in + let uu___2 = get_fname se.FStarC_Syntax_Syntax.sigquals in + match uu___2 with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some id -> + let uu___3 = FStarC_Syntax_DsEnv.qualify env1 id in + [uu___3] in + let formals = + let bndl = + FStarC_Compiler_Util.try_find + (fun uu___2 -> + match uu___2 with + | { + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_bundle uu___3; + FStarC_Syntax_Syntax.sigrng = uu___4; + FStarC_Syntax_Syntax.sigquals = uu___5; + FStarC_Syntax_Syntax.sigmeta = uu___6; + FStarC_Syntax_Syntax.sigattrs = uu___7; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + uu___8; + FStarC_Syntax_Syntax.sigopts = uu___9;_} -> + true + | uu___3 -> false) ses in + match bndl with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some bndl1 -> + (match bndl1.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_bundle + { FStarC_Syntax_Syntax.ses = ses1; + FStarC_Syntax_Syntax.lids = uu___2;_} + -> + FStarC_Compiler_Util.find_map ses1 + (fun se -> + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = uu___3; + FStarC_Syntax_Syntax.us1 = uu___4; + FStarC_Syntax_Syntax.t1 = t; + FStarC_Syntax_Syntax.ty_lid = uu___5; + FStarC_Syntax_Syntax.num_ty_params = + uu___6; + FStarC_Syntax_Syntax.mutuals1 = + uu___7; + FStarC_Syntax_Syntax.injective_type_params1 + = uu___8;_} + -> + let uu___9 = + FStarC_Syntax_Util.arrow_formals t in + (match uu___9 with + | (formals1, uu___10) -> + FStar_Pervasives_Native.Some + formals1) + | uu___3 -> FStar_Pervasives_Native.None) + | uu___2 -> FStar_Pervasives_Native.None) in + let rec splice_decl meths se = + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_bundle + { FStarC_Syntax_Syntax.ses = ses1; + FStarC_Syntax_Syntax.lids = uu___2;_} + -> + FStarC_Compiler_List.concatMap (splice_decl meths) + ses1 + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = lid; + FStarC_Syntax_Syntax.us = uu___2; + FStarC_Syntax_Syntax.params = uu___3; + FStarC_Syntax_Syntax.num_uniform_params = uu___4; + FStarC_Syntax_Syntax.t = ty; + FStarC_Syntax_Syntax.mutuals = uu___5; + FStarC_Syntax_Syntax.ds = uu___6; + FStarC_Syntax_Syntax.injective_type_params = + uu___7;_} + -> + let formals1 = + match formals with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some formals2 -> + formals2 in + let has_no_method_attr meth = + let i = FStarC_Ident.ident_of_lid meth in + FStarC_Compiler_Util.for_some + (fun formal -> + let uu___8 = + FStarC_Ident.ident_equals i + (formal.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.ppname in + if uu___8 + then + FStarC_Compiler_Util.for_some + (fun attr -> + let uu___9 = + let uu___10 = + FStarC_Syntax_Subst.compress attr in + uu___10.FStarC_Syntax_Syntax.n in + match uu___9 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.no_method_lid + | uu___10 -> false) + formal.FStarC_Syntax_Syntax.binder_attrs + else false) formals1 in + let meths1 = + FStarC_Compiler_List.filter + (fun x -> + let uu___8 = has_no_method_attr x in + Prims.op_Negation uu___8) meths in + let is_typed = false in + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = mkclass lid in + { + FStarC_Syntax_Syntax.is_typed = is_typed; + FStarC_Syntax_Syntax.lids2 = meths1; + FStarC_Syntax_Syntax.tac = uu___11 + } in + FStarC_Syntax_Syntax.Sig_splice uu___10 in + let uu___10 = + FStarC_Syntax_DsEnv.opens_and_abbrevs env1 in + { + FStarC_Syntax_Syntax.sigel = uu___9; + FStarC_Syntax_Syntax.sigrng = + (d.FStarC_Parser_AST.drange); + FStarC_Syntax_Syntax.sigquals = []; + FStarC_Syntax_Syntax.sigmeta = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs = []; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + uu___10; + FStarC_Syntax_Syntax.sigopts = + FStar_Pervasives_Native.None + } in + [uu___8] + | uu___2 -> [] in + let uu___2 = + if typeclass + then + let meths = + FStarC_Compiler_List.concatMap get_meths ses in + let rec add_class_attr se = + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_bundle + { FStarC_Syntax_Syntax.ses = ses1; + FStarC_Syntax_Syntax.lids = lids;_} + -> + let ses2 = + FStarC_Compiler_List.map add_class_attr ses1 in + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Syntax_Syntax.fvar_with_dd + FStarC_Parser_Const.tcclass_lid + FStar_Pervasives_Native.None in + uu___5 :: (se.FStarC_Syntax_Syntax.sigattrs) in + FStarC_Syntax_Util.deduplicate_terms uu___4 in + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_bundle + { + FStarC_Syntax_Syntax.ses = ses2; + FStarC_Syntax_Syntax.lids = lids + }); + FStarC_Syntax_Syntax.sigrng = + (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = uu___3; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se.FStarC_Syntax_Syntax.sigopts) + } + | FStarC_Syntax_Syntax.Sig_inductive_typ uu___3 -> + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.fvar_with_dd + FStarC_Parser_Const.tcclass_lid + FStar_Pervasives_Native.None in + uu___6 :: (se.FStarC_Syntax_Syntax.sigattrs) in + FStarC_Syntax_Util.deduplicate_terms uu___5 in + { + FStarC_Syntax_Syntax.sigel = + (se.FStarC_Syntax_Syntax.sigel); + FStarC_Syntax_Syntax.sigrng = + (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = uu___4; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se.FStarC_Syntax_Syntax.sigopts) + } + | uu___3 -> se in + let uu___3 = + FStarC_Compiler_List.map add_class_attr ses in + let uu___4 = + FStarC_Compiler_List.concatMap (splice_decl meths) + ses in + (uu___3, uu___4) + else (ses, []) in + match uu___2 with + | (ses1, extra) -> + let env2 = + FStarC_Compiler_List.fold_left + FStarC_Syntax_DsEnv.push_sigelt env1 extra in + (env2, (FStarC_Compiler_List.op_At ses1 extra))))) + | FStarC_Parser_AST.TopLevelLet (isrec, lets) -> + let quals = d.FStarC_Parser_AST.quals in + let expand_toplevel_pattern = + (isrec = FStarC_Parser_AST.NoLetQualifier) && + (match lets with + | ({ FStarC_Parser_AST.pat = FStarC_Parser_AST.PatOp uu___; + FStarC_Parser_AST.prange = uu___1;_}, + uu___2)::[] -> false + | ({ FStarC_Parser_AST.pat = FStarC_Parser_AST.PatVar uu___; + FStarC_Parser_AST.prange = uu___1;_}, + uu___2)::[] -> false + | ({ + FStarC_Parser_AST.pat = FStarC_Parser_AST.PatAscribed + ({ + FStarC_Parser_AST.pat = FStarC_Parser_AST.PatOp + uu___; + FStarC_Parser_AST.prange = uu___1;_}, + uu___2); + FStarC_Parser_AST.prange = uu___3;_}, + uu___4)::[] -> false + | ({ + FStarC_Parser_AST.pat = FStarC_Parser_AST.PatAscribed + ({ + FStarC_Parser_AST.pat = FStarC_Parser_AST.PatVar + uu___; + FStarC_Parser_AST.prange = uu___1;_}, + uu___2); + FStarC_Parser_AST.prange = uu___3;_}, + uu___4)::[] -> false + | (p, uu___)::[] -> + let uu___1 = is_app_pattern p in + Prims.op_Negation uu___1 + | uu___ -> false) in + if Prims.op_Negation expand_toplevel_pattern + then + let lets1 = + FStarC_Compiler_List.map + (fun x -> (FStar_Pervasives_Native.None, x)) lets in + let as_inner_let = + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.Const FStarC_Const.Const_unit) + d.FStarC_Parser_AST.drange FStarC_Parser_AST.Expr in + (isrec, lets1, uu___2) in + FStarC_Parser_AST.Let uu___1 in + FStarC_Parser_AST.mk_term uu___ d.FStarC_Parser_AST.drange + FStarC_Parser_AST.Expr in + let uu___ = desugar_term_maybe_top true env as_inner_let in + (match uu___ with + | (ds_lets, aq) -> + (check_no_aq aq; + (let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress ds_lets in + uu___3.FStarC_Syntax_Syntax.n in + match uu___2 with + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = lbs; + FStarC_Syntax_Syntax.body1 = uu___3;_} + -> + let fvs = + FStarC_Compiler_List.map + (fun lb -> + FStarC_Compiler_Util.right + lb.FStarC_Syntax_Syntax.lbname) + (FStar_Pervasives_Native.snd lbs) in + let uu___4 = + FStarC_Compiler_List.fold_right + (fun fv -> + fun uu___5 -> + match uu___5 with + | (qs, ats) -> + let uu___6 = + FStarC_Syntax_DsEnv.lookup_letbinding_quals_and_attrs + env + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + (match uu___6 with + | (qs', ats') -> + ((FStarC_Compiler_List.op_At qs' + qs), + (FStarC_Compiler_List.op_At ats' + ats)))) fvs ([], []) in + (match uu___4 with + | (val_quals, val_attrs) -> + let top_attrs = d_attrs in + let lbs1 = + let uu___5 = lbs in + match uu___5 with + | (isrec1, lbs0) -> + let lbs01 = + FStarC_Compiler_List.map + (fun lb -> + let uu___6 = + FStarC_Syntax_Util.deduplicate_terms + (FStarC_Compiler_List.op_At + lb.FStarC_Syntax_Syntax.lbattrs + (FStarC_Compiler_List.op_At + val_attrs top_attrs)) in + { + FStarC_Syntax_Syntax.lbname = + (lb.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = + (lb.FStarC_Syntax_Syntax.lbtyp); + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = + (lb.FStarC_Syntax_Syntax.lbdef); + FStarC_Syntax_Syntax.lbattrs = + uu___6; + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + }) lbs0 in + (isrec1, lbs01) in + let quals1 = + match quals with + | uu___5::uu___6 -> + FStarC_Compiler_List.map + (trans_qual1 + FStar_Pervasives_Native.None) quals + | uu___5 -> val_quals in + let quals2 = + let uu___5 = + FStarC_Compiler_Util.for_some + (fun uu___6 -> + match uu___6 with + | (uu___7, (uu___8, t)) -> + t.FStarC_Parser_AST.level = + FStarC_Parser_AST.Formula) lets1 in + if uu___5 + then FStarC_Syntax_Syntax.Logic :: quals1 + else quals1 in + let names = + FStarC_Compiler_List.map + (fun fv -> + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v) + fvs in + let s = + let uu___5 = + FStarC_Syntax_Util.deduplicate_terms + (FStarC_Compiler_List.op_At val_attrs + top_attrs) in + let uu___6 = + FStarC_Syntax_DsEnv.opens_and_abbrevs env in + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_let + { + FStarC_Syntax_Syntax.lbs1 = lbs1; + FStarC_Syntax_Syntax.lids1 = names + }); + FStarC_Syntax_Syntax.sigrng = + (d.FStarC_Parser_AST.drange); + FStarC_Syntax_Syntax.sigquals = quals2; + FStarC_Syntax_Syntax.sigmeta = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs = uu___5; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + uu___6; + FStarC_Syntax_Syntax.sigopts = + FStar_Pervasives_Native.None + } in + let env1 = + FStarC_Syntax_DsEnv.push_sigelt env s in + (env1, [s])) + | uu___3 -> + failwith "Desugaring a let did not produce a let"))) + else + (let uu___1 = + match lets with + | (pat, body)::[] -> (pat, body) + | uu___2 -> + failwith + "expand_toplevel_pattern should only allow single definition lets" in + match uu___1 with + | (pat, body) -> + let rec gen_fresh_toplevel_name uu___2 = + let nm = + FStarC_Ident.gen FStarC_Compiler_Range_Type.dummyRange in + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Ident.lid_of_ids [nm] in + FStarC_Syntax_DsEnv.resolve_name env uu___5 in + FStar_Pervasives_Native.uu___is_Some uu___4 in + if uu___3 then gen_fresh_toplevel_name () else nm in + let fresh_toplevel_name = gen_fresh_toplevel_name () in + let fresh_pat = + let var_pat = + FStarC_Parser_AST.mk_pattern + (FStarC_Parser_AST.PatVar + (fresh_toplevel_name, + FStar_Pervasives_Native.None, [])) + FStarC_Compiler_Range_Type.dummyRange in + match pat.FStarC_Parser_AST.pat with + | FStarC_Parser_AST.PatAscribed (pat1, ty) -> + { + FStarC_Parser_AST.pat = + (FStarC_Parser_AST.PatAscribed (var_pat, ty)); + FStarC_Parser_AST.prange = + (pat1.FStarC_Parser_AST.prange) + } + | uu___2 -> var_pat in + let main_let = + let quals1 = + if + FStarC_Compiler_List.mem FStarC_Parser_AST.Private + d.FStarC_Parser_AST.quals + then d.FStarC_Parser_AST.quals + else FStarC_Parser_AST.Private :: + (d.FStarC_Parser_AST.quals) in + desugar_decl env + { + FStarC_Parser_AST.d = + (FStarC_Parser_AST.TopLevelLet + (isrec, [(fresh_pat, body)])); + FStarC_Parser_AST.drange = + (d.FStarC_Parser_AST.drange); + FStarC_Parser_AST.quals = quals1; + FStarC_Parser_AST.attrs = + (d.FStarC_Parser_AST.attrs); + FStarC_Parser_AST.interleaved = + (d.FStarC_Parser_AST.interleaved) + } in + let main = + let uu___2 = + let uu___3 = + FStarC_Ident.lid_of_ids [fresh_toplevel_name] in + FStarC_Parser_AST.Var uu___3 in + FStarC_Parser_AST.mk_term uu___2 + pat.FStarC_Parser_AST.prange FStarC_Parser_AST.Expr in + let build_generic_projection uu___2 id_opt = + match uu___2 with + | (env1, ses) -> + let uu___3 = + match id_opt with + | FStar_Pervasives_Native.Some id -> + let lid = FStarC_Ident.lid_of_ids [id] in + let branch = + let uu___4 = FStarC_Ident.range_of_lid lid in + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.Var lid) uu___4 + FStarC_Parser_AST.Expr in + let bv_pat = + let uu___4 = FStarC_Ident.range_of_id id in + FStarC_Parser_AST.mk_pattern + (FStarC_Parser_AST.PatVar + (id, FStar_Pervasives_Native.None, [])) + uu___4 in + (bv_pat, branch) + | FStar_Pervasives_Native.None -> + let id = gen_fresh_toplevel_name () in + let branch = + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.Const + FStarC_Const.Const_unit) + FStarC_Compiler_Range_Type.dummyRange + FStarC_Parser_AST.Expr in + let bv_pat = + let uu___4 = FStarC_Ident.range_of_id id in + FStarC_Parser_AST.mk_pattern + (FStarC_Parser_AST.PatVar + (id, FStar_Pervasives_Native.None, [])) + uu___4 in + let bv_pat1 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Ident.range_of_id id in + unit_ty uu___8 in + (uu___7, FStar_Pervasives_Native.None) in + (bv_pat, uu___6) in + FStarC_Parser_AST.PatAscribed uu___5 in + let uu___5 = FStarC_Ident.range_of_id id in + FStarC_Parser_AST.mk_pattern uu___4 uu___5 in + (bv_pat1, branch) in + (match uu___3 with + | (bv_pat, branch) -> + let body1 = + FStarC_Parser_AST.mk_term + (FStarC_Parser_AST.Match + (main, FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None, + [(pat, FStar_Pervasives_Native.None, + branch)])) + main.FStarC_Parser_AST.range + FStarC_Parser_AST.Expr in + let id_decl = + FStarC_Parser_AST.mk_decl + (FStarC_Parser_AST.TopLevelLet + (FStarC_Parser_AST.NoLetQualifier, + [(bv_pat, body1)])) + FStarC_Compiler_Range_Type.dummyRange [] in + let id_decl1 = + { + FStarC_Parser_AST.d = + (id_decl.FStarC_Parser_AST.d); + FStarC_Parser_AST.drange = + (id_decl.FStarC_Parser_AST.drange); + FStarC_Parser_AST.quals = + (d.FStarC_Parser_AST.quals); + FStarC_Parser_AST.attrs = + (id_decl.FStarC_Parser_AST.attrs); + FStarC_Parser_AST.interleaved = + (id_decl.FStarC_Parser_AST.interleaved) + } in + let uu___4 = desugar_decl env1 id_decl1 in + (match uu___4 with + | (env2, ses') -> + (env2, + (FStarC_Compiler_List.op_At ses ses')))) in + let build_projection uu___2 id = + match uu___2 with + | (env1, ses) -> + build_generic_projection (env1, ses) + (FStar_Pervasives_Native.Some id) in + let build_coverage_check uu___2 = + match uu___2 with + | (env1, ses) -> + build_generic_projection (env1, ses) + FStar_Pervasives_Native.None in + let bvs = + let uu___2 = gather_pattern_bound_vars pat in + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_ident)) + (Obj.magic uu___2) in + let uu___2 = + (FStarC_Compiler_List.isEmpty bvs) && + (let uu___3 = is_var_pattern pat in + Prims.op_Negation uu___3) in + if uu___2 + then build_coverage_check main_let + else + FStarC_Compiler_List.fold_left build_projection main_let + bvs) + | FStarC_Parser_AST.Assume (id, t) -> + let f = desugar_formula env t in + let lid = FStarC_Syntax_DsEnv.qualify env id in + let uu___ = + let uu___1 = + let uu___2 = FStarC_Syntax_DsEnv.opens_and_abbrevs env in + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_assume + { + FStarC_Syntax_Syntax.lid3 = lid; + FStarC_Syntax_Syntax.us3 = []; + FStarC_Syntax_Syntax.phi1 = f + }); + FStarC_Syntax_Syntax.sigrng = (d.FStarC_Parser_AST.drange); + FStarC_Syntax_Syntax.sigquals = + [FStarC_Syntax_Syntax.Assumption]; + FStarC_Syntax_Syntax.sigmeta = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs = d_attrs; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___2; + FStarC_Syntax_Syntax.sigopts = FStar_Pervasives_Native.None + } in + [uu___1] in + (env, uu___) + | FStarC_Parser_AST.Val (id, t) -> + let quals = d.FStarC_Parser_AST.quals in + let t1 = let uu___ = close_fun env t in desugar_term env uu___ in + let quals1 = + let uu___ = + (FStarC_Syntax_DsEnv.iface env) && + (FStarC_Syntax_DsEnv.admitted_iface env) in + if uu___ then FStarC_Parser_AST.Assumption :: quals else quals in + let lid = FStarC_Syntax_DsEnv.qualify env id in + let se = + let uu___ = + FStarC_Compiler_List.map + (trans_qual1 FStar_Pervasives_Native.None) quals1 in + let uu___1 = FStarC_Syntax_DsEnv.opens_and_abbrevs env in + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_declare_typ + { + FStarC_Syntax_Syntax.lid2 = lid; + FStarC_Syntax_Syntax.us2 = []; + FStarC_Syntax_Syntax.t2 = t1 + }); + FStarC_Syntax_Syntax.sigrng = (d.FStarC_Parser_AST.drange); + FStarC_Syntax_Syntax.sigquals = uu___; + FStarC_Syntax_Syntax.sigmeta = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs = d_attrs; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___1; + FStarC_Syntax_Syntax.sigopts = FStar_Pervasives_Native.None + } in + let env1 = FStarC_Syntax_DsEnv.push_sigelt env se in (env1, [se]) + | FStarC_Parser_AST.Exception (id, t_opt) -> + let t = + match t_opt with + | FStar_Pervasives_Native.None -> + FStarC_Syntax_DsEnv.fail_or env + (FStarC_Syntax_DsEnv.try_lookup_lid env) + FStarC_Parser_Const.exn_lid + | FStar_Pervasives_Native.Some term -> + let t1 = desugar_term env term in + let uu___ = + let uu___1 = FStarC_Syntax_Syntax.null_binder t1 in + [uu___1] in + let uu___1 = + let uu___2 = + FStarC_Syntax_DsEnv.fail_or env + (FStarC_Syntax_DsEnv.try_lookup_lid env) + FStarC_Parser_Const.exn_lid in + FStarC_Syntax_Syntax.mk_Total uu___2 in + FStarC_Syntax_Util.arrow uu___ uu___1 in + let l = FStarC_Syntax_DsEnv.qualify env id in + let qual = [FStarC_Syntax_Syntax.ExceptionConstructor] in + let top_attrs = d_attrs in + let se = + let uu___ = FStarC_Syntax_DsEnv.opens_and_abbrevs env in + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_datacon + { + FStarC_Syntax_Syntax.lid1 = l; + FStarC_Syntax_Syntax.us1 = []; + FStarC_Syntax_Syntax.t1 = t; + FStarC_Syntax_Syntax.ty_lid = + FStarC_Parser_Const.exn_lid; + FStarC_Syntax_Syntax.num_ty_params = Prims.int_zero; + FStarC_Syntax_Syntax.mutuals1 = + [FStarC_Parser_Const.exn_lid]; + FStarC_Syntax_Syntax.injective_type_params1 = false + }); + FStarC_Syntax_Syntax.sigrng = (d.FStarC_Parser_AST.drange); + FStarC_Syntax_Syntax.sigquals = qual; + FStarC_Syntax_Syntax.sigmeta = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs = top_attrs; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___; + FStarC_Syntax_Syntax.sigopts = FStar_Pervasives_Native.None + } in + let se' = + let uu___ = FStarC_Syntax_DsEnv.opens_and_abbrevs env in + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_bundle + { + FStarC_Syntax_Syntax.ses = [se]; + FStarC_Syntax_Syntax.lids = [l] + }); + FStarC_Syntax_Syntax.sigrng = (d.FStarC_Parser_AST.drange); + FStarC_Syntax_Syntax.sigquals = qual; + FStarC_Syntax_Syntax.sigmeta = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs = top_attrs; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___; + FStarC_Syntax_Syntax.sigopts = FStar_Pervasives_Native.None + } in + let env1 = FStarC_Syntax_DsEnv.push_sigelt env se' in + let data_ops = mk_data_projector_names [] env1 se in + let discs = mk_data_discriminators [] env1 [l] top_attrs in + let env2 = + FStarC_Compiler_List.fold_left FStarC_Syntax_DsEnv.push_sigelt + env1 (FStarC_Compiler_List.op_At discs data_ops) in + (env2, (FStarC_Compiler_List.op_At (se' :: discs) data_ops)) + | FStarC_Parser_AST.NewEffect (FStarC_Parser_AST.RedefineEffect + (eff_name, eff_binders, defn)) -> + let quals = d.FStarC_Parser_AST.quals in + desugar_redefine_effect env d d_attrs trans_qual1 quals eff_name + eff_binders defn + | FStarC_Parser_AST.NewEffect (FStarC_Parser_AST.DefineEffect + (eff_name, eff_binders, eff_typ, eff_decls)) -> + let quals = d.FStarC_Parser_AST.quals in + desugar_effect env d d_attrs quals false eff_name eff_binders + eff_typ eff_decls + | FStarC_Parser_AST.LayeredEffect (FStarC_Parser_AST.DefineEffect + (eff_name, eff_binders, eff_typ, eff_decls)) -> + let quals = d.FStarC_Parser_AST.quals in + desugar_effect env d d_attrs quals true eff_name eff_binders + eff_typ eff_decls + | FStarC_Parser_AST.LayeredEffect (FStarC_Parser_AST.RedefineEffect + uu___) -> + failwith + "Impossible: LayeredEffect (RedefineEffect _) (should not be parseable)" + | FStarC_Parser_AST.SubEffect l -> + let src_ed = + lookup_effect_lid env l.FStarC_Parser_AST.msource + d.FStarC_Parser_AST.drange in + let dst_ed = + lookup_effect_lid env l.FStarC_Parser_AST.mdest + d.FStarC_Parser_AST.drange in + let top_attrs = d_attrs in + let uu___ = + let uu___1 = + (FStarC_Syntax_Util.is_layered src_ed) || + (FStarC_Syntax_Util.is_layered dst_ed) in + Prims.op_Negation uu___1 in + if uu___ + then + let uu___1 = + match l.FStarC_Parser_AST.lift_op with + | FStarC_Parser_AST.NonReifiableLift t -> + let uu___2 = + let uu___3 = + let uu___4 = desugar_term env t in ([], uu___4) in + FStar_Pervasives_Native.Some uu___3 in + (uu___2, FStar_Pervasives_Native.None) + | FStarC_Parser_AST.ReifiableLift (wp, t) -> + let uu___2 = + let uu___3 = + let uu___4 = desugar_term env wp in ([], uu___4) in + FStar_Pervasives_Native.Some uu___3 in + let uu___3 = + let uu___4 = + let uu___5 = desugar_term env t in ([], uu___5) in + FStar_Pervasives_Native.Some uu___4 in + (uu___2, uu___3) + | FStarC_Parser_AST.LiftForFree t -> + let uu___2 = + let uu___3 = + let uu___4 = desugar_term env t in ([], uu___4) in + FStar_Pervasives_Native.Some uu___3 in + (FStar_Pervasives_Native.None, uu___2) in + (match uu___1 with + | (lift_wp, lift) -> + let se = + let uu___2 = FStarC_Syntax_DsEnv.opens_and_abbrevs env in + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_sub_effect + { + FStarC_Syntax_Syntax.source = + (src_ed.FStarC_Syntax_Syntax.mname); + FStarC_Syntax_Syntax.target = + (dst_ed.FStarC_Syntax_Syntax.mname); + FStarC_Syntax_Syntax.lift_wp = lift_wp; + FStarC_Syntax_Syntax.lift = lift; + FStarC_Syntax_Syntax.kind = + FStar_Pervasives_Native.None + }); + FStarC_Syntax_Syntax.sigrng = + (d.FStarC_Parser_AST.drange); + FStarC_Syntax_Syntax.sigquals = []; + FStarC_Syntax_Syntax.sigmeta = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs = top_attrs; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___2; + FStarC_Syntax_Syntax.sigopts = + FStar_Pervasives_Native.None + } in + (env, [se])) + else + (match l.FStarC_Parser_AST.lift_op with + | FStarC_Parser_AST.NonReifiableLift t -> + let sub_eff = + let uu___2 = + let uu___3 = + let uu___4 = desugar_term env t in ([], uu___4) in + FStar_Pervasives_Native.Some uu___3 in + { + FStarC_Syntax_Syntax.source = + (src_ed.FStarC_Syntax_Syntax.mname); + FStarC_Syntax_Syntax.target = + (dst_ed.FStarC_Syntax_Syntax.mname); + FStarC_Syntax_Syntax.lift_wp = + FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.lift = uu___2; + FStarC_Syntax_Syntax.kind = + FStar_Pervasives_Native.None + } in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_DsEnv.opens_and_abbrevs env in + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_sub_effect sub_eff); + FStarC_Syntax_Syntax.sigrng = + (d.FStarC_Parser_AST.drange); + FStarC_Syntax_Syntax.sigquals = []; + FStarC_Syntax_Syntax.sigmeta = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs = top_attrs; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___4; + FStarC_Syntax_Syntax.sigopts = + FStar_Pervasives_Native.None + } in + [uu___3] in + (env, uu___2) + | uu___2 -> + failwith + "Impossible! unexpected lift_op for lift to a layered effect") + | FStarC_Parser_AST.Polymonadic_bind (m_eff, n_eff, p_eff, bind) -> + let m = lookup_effect_lid env m_eff d.FStarC_Parser_AST.drange in + let n = lookup_effect_lid env n_eff d.FStarC_Parser_AST.drange in + let p = lookup_effect_lid env p_eff d.FStarC_Parser_AST.drange in + let top_attrs = d_attrs in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = desugar_term env bind in ([], uu___5) in + { + FStarC_Syntax_Syntax.m_lid = + (m.FStarC_Syntax_Syntax.mname); + FStarC_Syntax_Syntax.n_lid = + (n.FStarC_Syntax_Syntax.mname); + FStarC_Syntax_Syntax.p_lid = + (p.FStarC_Syntax_Syntax.mname); + FStarC_Syntax_Syntax.tm3 = uu___4; + FStarC_Syntax_Syntax.typ = + ([], FStarC_Syntax_Syntax.tun); + FStarC_Syntax_Syntax.kind1 = + FStar_Pervasives_Native.None + } in + FStarC_Syntax_Syntax.Sig_polymonadic_bind uu___3 in + let uu___3 = FStarC_Syntax_DsEnv.opens_and_abbrevs env in + { + FStarC_Syntax_Syntax.sigel = uu___2; + FStarC_Syntax_Syntax.sigrng = (d.FStarC_Parser_AST.drange); + FStarC_Syntax_Syntax.sigquals = []; + FStarC_Syntax_Syntax.sigmeta = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs = top_attrs; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___3; + FStarC_Syntax_Syntax.sigopts = FStar_Pervasives_Native.None + } in + [uu___1] in + (env, uu___) + | FStarC_Parser_AST.Polymonadic_subcomp (m_eff, n_eff, subcomp) -> + let m = lookup_effect_lid env m_eff d.FStarC_Parser_AST.drange in + let n = lookup_effect_lid env n_eff d.FStarC_Parser_AST.drange in + let top_attrs = d_attrs in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = desugar_term env subcomp in ([], uu___5) in + { + FStarC_Syntax_Syntax.m_lid1 = + (m.FStarC_Syntax_Syntax.mname); + FStarC_Syntax_Syntax.n_lid1 = + (n.FStarC_Syntax_Syntax.mname); + FStarC_Syntax_Syntax.tm4 = uu___4; + FStarC_Syntax_Syntax.typ1 = + ([], FStarC_Syntax_Syntax.tun); + FStarC_Syntax_Syntax.kind2 = + FStar_Pervasives_Native.None + } in + FStarC_Syntax_Syntax.Sig_polymonadic_subcomp uu___3 in + let uu___3 = FStarC_Syntax_DsEnv.opens_and_abbrevs env in + { + FStarC_Syntax_Syntax.sigel = uu___2; + FStarC_Syntax_Syntax.sigrng = (d.FStarC_Parser_AST.drange); + FStarC_Syntax_Syntax.sigquals = []; + FStarC_Syntax_Syntax.sigmeta = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs = top_attrs; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___3; + FStarC_Syntax_Syntax.sigopts = FStar_Pervasives_Native.None + } in + [uu___1] in + (env, uu___) + | FStarC_Parser_AST.Splice (is_typed, ids, t) -> + let ids1 = if d.FStarC_Parser_AST.interleaved then [] else ids in + let t1 = desugar_term env t in + let top_attrs = d_attrs in + let se = + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Compiler_List.map + (FStarC_Syntax_DsEnv.qualify env) ids1 in + { + FStarC_Syntax_Syntax.is_typed = is_typed; + FStarC_Syntax_Syntax.lids2 = uu___2; + FStarC_Syntax_Syntax.tac = t1 + } in + FStarC_Syntax_Syntax.Sig_splice uu___1 in + let uu___1 = + FStarC_Compiler_List.map + (trans_qual1 FStar_Pervasives_Native.None) + d.FStarC_Parser_AST.quals in + let uu___2 = FStarC_Syntax_DsEnv.opens_and_abbrevs env in + { + FStarC_Syntax_Syntax.sigel = uu___; + FStarC_Syntax_Syntax.sigrng = (d.FStarC_Parser_AST.drange); + FStarC_Syntax_Syntax.sigquals = uu___1; + FStarC_Syntax_Syntax.sigmeta = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs = top_attrs; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___2; + FStarC_Syntax_Syntax.sigopts = FStar_Pervasives_Native.None + } in + let env1 = FStarC_Syntax_DsEnv.push_sigelt env se in (env1, [se]) + | FStarC_Parser_AST.UseLangDecls uu___ -> (env, []) + | FStarC_Parser_AST.Unparseable -> + FStarC_Errors.raise_error FStarC_Parser_AST.hasRange_decl d + FStarC_Errors_Codes.Fatal_SyntaxError () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "Syntax error") + | FStarC_Parser_AST.DeclSyntaxExtension + (extension_name, code, uu___, range) -> + let extension_parser = + FStarC_Parser_AST_Util.lookup_extension_parser extension_name in + (match extension_parser with + | FStar_Pervasives_Native.None -> + let uu___1 = + FStarC_Compiler_Util.format1 "Unknown syntax extension %s" + extension_name in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range range + FStarC_Errors_Codes.Fatal_SyntaxError () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) + | FStar_Pervasives_Native.Some parser -> + let opens = + let uu___1 = + FStarC_Syntax_DsEnv.open_modules_and_namespaces env in + let uu___2 = FStarC_Syntax_DsEnv.module_abbrevs env in + { + FStarC_Parser_AST_Util.open_namespaces = uu___1; + FStarC_Parser_AST_Util.module_abbreviations = uu___2 + } in + let uu___1 = + parser.FStarC_Parser_AST_Util.parse_decl opens code range in + (match uu___1 with + | FStar_Pervasives.Inl error -> + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + error.FStarC_Parser_AST_Util.range + FStarC_Errors_Codes.Fatal_SyntaxError () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic error.FStarC_Parser_AST_Util.message) + | FStar_Pervasives.Inr d' -> + let quals = + FStarC_Compiler_List.op_At d'.FStarC_Parser_AST.quals + d.FStarC_Parser_AST.quals in + let attrs = + FStarC_Compiler_List.op_At d'.FStarC_Parser_AST.attrs + d.FStarC_Parser_AST.attrs in + desugar_decl_maybe_fail_attr env + { + FStarC_Parser_AST.d = (d'.FStarC_Parser_AST.d); + FStarC_Parser_AST.drange = + (d.FStarC_Parser_AST.drange); + FStarC_Parser_AST.quals = quals; + FStarC_Parser_AST.attrs = attrs; + FStarC_Parser_AST.interleaved = + (d.FStarC_Parser_AST.interleaved) + })) + | FStarC_Parser_AST.DeclToBeDesugared tbs -> + let uu___ = + lookup_extension_tosyntax tbs.FStarC_Parser_AST.lang_name in + (match uu___ with + | FStar_Pervasives_Native.None -> + let uu___1 = + FStarC_Compiler_Util.format1 + "Could not find desugaring callback for extension %s" + tbs.FStarC_Parser_AST.lang_name in + FStarC_Errors.raise_error FStarC_Parser_AST.hasRange_decl d + FStarC_Errors_Codes.Fatal_SyntaxError () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) + | FStar_Pervasives_Native.Some desugar -> + let mk_sig sigel = + let top_attrs = d_attrs in + let sigel1 = + if d.FStarC_Parser_AST.interleaved + then + match sigel with + | FStarC_Syntax_Syntax.Sig_splice s -> + FStarC_Syntax_Syntax.Sig_splice + { + FStarC_Syntax_Syntax.is_typed = + (s.FStarC_Syntax_Syntax.is_typed); + FStarC_Syntax_Syntax.lids2 = []; + FStarC_Syntax_Syntax.tac = + (s.FStarC_Syntax_Syntax.tac) + } + | uu___1 -> sigel + else sigel in + let se = + let uu___1 = + FStarC_Compiler_List.map + (trans_qual1 FStar_Pervasives_Native.None) + d.FStarC_Parser_AST.quals in + let uu___2 = FStarC_Syntax_DsEnv.opens_and_abbrevs env in + { + FStarC_Syntax_Syntax.sigel = sigel1; + FStarC_Syntax_Syntax.sigrng = + (d.FStarC_Parser_AST.drange); + FStarC_Syntax_Syntax.sigquals = uu___1; + FStarC_Syntax_Syntax.sigmeta = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs = top_attrs; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___2; + FStarC_Syntax_Syntax.sigopts = + FStar_Pervasives_Native.None + } in + se in + let lids = + FStarC_Compiler_List.map (FStarC_Syntax_DsEnv.qualify env) + tbs.FStarC_Parser_AST.idents in + let sigelts' = + desugar env tbs.FStarC_Parser_AST.blob lids + d.FStarC_Parser_AST.drange in + let sigelts = FStarC_Compiler_List.map mk_sig sigelts' in + let env1 = + FStarC_Compiler_List.fold_left + FStarC_Syntax_DsEnv.push_sigelt env sigelts in + (env1, sigelts)) +let (desugar_decls : + env_t -> + FStarC_Parser_AST.decl Prims.list -> + (env_t * FStarC_Syntax_Syntax.sigelt Prims.list)) + = + fun env -> + fun decls -> + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun d -> + match uu___1 with + | (env1, sigelts) -> + let uu___2 = desugar_decl env1 d in + (match uu___2 with + | (env2, se) -> + (env2, (FStarC_Compiler_List.op_At sigelts se)))) + (env, []) decls in + match uu___ with | (env1, sigelts) -> (env1, sigelts) +let (desugar_modul_common : + FStarC_Syntax_Syntax.modul FStar_Pervasives_Native.option -> + FStarC_Syntax_DsEnv.env -> + FStarC_Parser_AST.modul -> + (env_t * FStarC_Syntax_Syntax.modul * Prims.bool)) + = + fun curmod -> + fun env -> + fun m -> + let env1 = + match (curmod, m) with + | (FStar_Pervasives_Native.None, uu___) -> env + | (FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.name = prev_lid; + FStarC_Syntax_Syntax.declarations = uu___; + FStarC_Syntax_Syntax.is_interface = uu___1;_}, + FStarC_Parser_AST.Module (current_lid, uu___2)) when + (FStarC_Ident.lid_equals prev_lid current_lid) && + (FStarC_Options.interactive ()) + -> env + | (FStar_Pervasives_Native.Some prev_mod, uu___) -> + let uu___1 = + FStarC_Syntax_DsEnv.finish_module_or_interface env prev_mod in + FStar_Pervasives_Native.fst uu___1 in + let uu___ = + match m with + | FStarC_Parser_AST.Interface (mname, decls, admitted) -> + let uu___1 = + FStarC_Syntax_DsEnv.prepare_module_or_interface true admitted + env1 mname FStarC_Syntax_DsEnv.default_mii in + (uu___1, mname, decls, true) + | FStarC_Parser_AST.Module (mname, decls) -> + let uu___1 = + FStarC_Syntax_DsEnv.prepare_module_or_interface false false + env1 mname FStarC_Syntax_DsEnv.default_mii in + (uu___1, mname, decls, false) in + match uu___ with + | ((env2, pop_when_done), mname, decls, intf) -> + let uu___1 = desugar_decls env2 decls in + (match uu___1 with + | (env3, sigelts) -> + let modul = + { + FStarC_Syntax_Syntax.name = mname; + FStarC_Syntax_Syntax.declarations = sigelts; + FStarC_Syntax_Syntax.is_interface = intf + } in + (env3, modul, pop_when_done)) +let (as_interface : FStarC_Parser_AST.modul -> FStarC_Parser_AST.modul) = + fun m -> + match m with + | FStarC_Parser_AST.Module (mname, decls) -> + FStarC_Parser_AST.Interface (mname, decls, true) + | i -> i +let (desugar_partial_modul : + FStarC_Syntax_Syntax.modul FStar_Pervasives_Native.option -> + env_t -> FStarC_Parser_AST.modul -> (env_t * FStarC_Syntax_Syntax.modul)) + = + fun curmod -> + fun env -> + fun m -> + let m1 = + let uu___ = + (FStarC_Options.interactive ()) && + (let uu___1 = + let uu___2 = + let uu___3 = FStarC_Options.file_list () in + FStarC_Compiler_List.hd uu___3 in + FStarC_Compiler_Util.get_file_extension uu___2 in + FStarC_Compiler_List.mem uu___1 ["fsti"; "fsi"]) in + if uu___ then as_interface m else m in + let uu___ = desugar_modul_common curmod env m1 in + match uu___ with + | (env1, modul, pop_when_done) -> + if pop_when_done + then let uu___1 = FStarC_Syntax_DsEnv.pop () in (uu___1, modul) + else (env1, modul) +let (desugar_modul : + FStarC_Syntax_DsEnv.env -> + FStarC_Parser_AST.modul -> (env_t * FStarC_Syntax_Syntax.modul)) + = + fun env -> + fun m -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Parser_AST.lid_of_modul m in + FStarC_Class_Show.show FStarC_Ident.showable_lident uu___2 in + Prims.strcat "While desugaring module " uu___1 in + FStarC_Errors.with_ctx uu___ + (fun uu___1 -> + let uu___2 = + desugar_modul_common FStar_Pervasives_Native.None env m in + match uu___2 with + | (env1, modul, pop_when_done) -> + let uu___3 = + FStarC_Syntax_DsEnv.finish_module_or_interface env1 modul in + (match uu___3 with + | (env2, modul1) -> + ((let uu___5 = + let uu___6 = + FStarC_Ident.string_of_lid + modul1.FStarC_Syntax_Syntax.name in + FStarC_Options.dump_module uu___6 in + if uu___5 + then + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_modul modul1 in + FStarC_Compiler_Util.print1 + "Module after desugaring:\n%s\n" uu___6 + else ()); + (let uu___5 = + if pop_when_done + then + FStarC_Syntax_DsEnv.export_interface + modul1.FStarC_Syntax_Syntax.name env2 + else env2 in + (uu___5, modul1))))) +let with_options : 'a . (unit -> 'a) -> 'a = + fun f -> + let uu___ = + FStarC_Options.with_saved_options + (fun uu___1 -> + let r = f () in let light = FStarC_Options.ml_ish () in (light, r)) in + match uu___ with + | (light, r) -> (if light then FStarC_Options.set_ml_ish () else (); r) +let (ast_modul_to_modul : + FStarC_Parser_AST.modul -> + FStarC_Syntax_Syntax.modul FStarC_Syntax_DsEnv.withenv) + = + fun modul -> + fun env -> + with_options + (fun uu___ -> + let uu___1 = desugar_modul env modul in + match uu___1 with | (e, m) -> (m, e)) +let (decls_to_sigelts : + FStarC_Parser_AST.decl Prims.list -> + FStarC_Syntax_Syntax.sigelts FStarC_Syntax_DsEnv.withenv) + = + fun decls -> + fun env -> + with_options + (fun uu___ -> + let uu___1 = desugar_decls env decls in + match uu___1 with | (env1, sigelts) -> (sigelts, env1)) +let (partial_ast_modul_to_modul : + FStarC_Syntax_Syntax.modul FStar_Pervasives_Native.option -> + FStarC_Parser_AST.modul -> + FStarC_Syntax_Syntax.modul FStarC_Syntax_DsEnv.withenv) + = + fun modul -> + fun a_modul -> + fun env -> + with_options + (fun uu___ -> + let uu___1 = desugar_partial_modul modul env a_modul in + match uu___1 with | (env1, modul1) -> (modul1, env1)) +let (add_modul_to_env_core : + Prims.bool -> + FStarC_Syntax_Syntax.modul -> + FStarC_Syntax_DsEnv.module_inclusion_info -> + (FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) -> + unit FStarC_Syntax_DsEnv.withenv) + = + fun finish -> + fun m -> + fun mii -> + fun erase_univs -> + fun en -> + let erase_univs_ed ed = + let erase_binders bs = + match bs with + | [] -> [] + | uu___ -> + let t = + let uu___1 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs = bs; + FStarC_Syntax_Syntax.body = + FStarC_Syntax_Syntax.t_unit; + FStarC_Syntax_Syntax.rc_opt = + FStar_Pervasives_Native.None + }) FStarC_Compiler_Range_Type.dummyRange in + erase_univs uu___1 in + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress t in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs1; + FStarC_Syntax_Syntax.body = uu___2; + FStarC_Syntax_Syntax.rc_opt = uu___3;_} + -> bs1 + | uu___2 -> failwith "Impossible") in + let uu___ = + let uu___1 = erase_binders ed.FStarC_Syntax_Syntax.binders in + FStarC_Syntax_Subst.open_term' uu___1 + FStarC_Syntax_Syntax.t_unit in + match uu___ with + | (binders, uu___1, binders_opening) -> + let erase_term t = + let uu___2 = + let uu___3 = + FStarC_Syntax_Subst.subst binders_opening t in + erase_univs uu___3 in + FStarC_Syntax_Subst.close binders uu___2 in + let erase_tscheme uu___2 = + match uu___2 with + | (us, t) -> + let t1 = + let uu___3 = + FStarC_Syntax_Subst.shift_subst + (FStarC_Compiler_List.length us) + binders_opening in + FStarC_Syntax_Subst.subst uu___3 t in + let uu___3 = + let uu___4 = erase_univs t1 in + FStarC_Syntax_Subst.close binders uu___4 in + ([], uu___3) in + let erase_action action = + let opening = + FStarC_Syntax_Subst.shift_subst + (FStarC_Compiler_List.length + action.FStarC_Syntax_Syntax.action_univs) + binders_opening in + let erased_action_params = + match action.FStarC_Syntax_Syntax.action_params with + | [] -> [] + | uu___2 -> + let bs = + let uu___3 = + FStarC_Syntax_Subst.subst_binders opening + action.FStarC_Syntax_Syntax.action_params in + erase_binders uu___3 in + let t = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs = bs; + FStarC_Syntax_Syntax.body = + FStarC_Syntax_Syntax.t_unit; + FStarC_Syntax_Syntax.rc_opt = + FStar_Pervasives_Native.None + }) FStarC_Compiler_Range_Type.dummyRange in + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Syntax_Subst.close binders t in + FStarC_Syntax_Subst.compress uu___5 in + uu___4.FStarC_Syntax_Syntax.n in + (match uu___3 with + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs1; + FStarC_Syntax_Syntax.body = uu___4; + FStarC_Syntax_Syntax.rc_opt = uu___5;_} + -> bs1 + | uu___4 -> failwith "Impossible") in + let erase_term1 t = + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.subst opening t in + erase_univs uu___3 in + FStarC_Syntax_Subst.close binders uu___2 in + let uu___2 = + erase_term1 action.FStarC_Syntax_Syntax.action_defn in + let uu___3 = + erase_term1 action.FStarC_Syntax_Syntax.action_typ in + { + FStarC_Syntax_Syntax.action_name = + (action.FStarC_Syntax_Syntax.action_name); + FStarC_Syntax_Syntax.action_unqualified_name = + (action.FStarC_Syntax_Syntax.action_unqualified_name); + FStarC_Syntax_Syntax.action_univs = []; + FStarC_Syntax_Syntax.action_params = + erased_action_params; + FStarC_Syntax_Syntax.action_defn = uu___2; + FStarC_Syntax_Syntax.action_typ = uu___3 + } in + let uu___2 = FStarC_Syntax_Subst.close_binders binders in + let uu___3 = + FStarC_Syntax_Util.apply_eff_sig erase_tscheme + ed.FStarC_Syntax_Syntax.signature in + let uu___4 = + FStarC_Syntax_Util.apply_eff_combinators erase_tscheme + ed.FStarC_Syntax_Syntax.combinators in + let uu___5 = + FStarC_Compiler_List.map erase_action + ed.FStarC_Syntax_Syntax.actions in + { + FStarC_Syntax_Syntax.mname = + (ed.FStarC_Syntax_Syntax.mname); + FStarC_Syntax_Syntax.cattributes = + (ed.FStarC_Syntax_Syntax.cattributes); + FStarC_Syntax_Syntax.univs = []; + FStarC_Syntax_Syntax.binders = uu___2; + FStarC_Syntax_Syntax.signature = uu___3; + FStarC_Syntax_Syntax.combinators = uu___4; + FStarC_Syntax_Syntax.actions = uu___5; + FStarC_Syntax_Syntax.eff_attrs = + (ed.FStarC_Syntax_Syntax.eff_attrs); + FStarC_Syntax_Syntax.extraction_mode = + (ed.FStarC_Syntax_Syntax.extraction_mode) + } in + let push_sigelt env se = + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_new_effect ed -> + let se' = + let uu___ = + let uu___1 = erase_univs_ed ed in + FStarC_Syntax_Syntax.Sig_new_effect uu___1 in + { + FStarC_Syntax_Syntax.sigel = uu___; + FStarC_Syntax_Syntax.sigrng = + (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se.FStarC_Syntax_Syntax.sigopts) + } in + let env1 = FStarC_Syntax_DsEnv.push_sigelt env se' in + push_reflect_effect env1 se.FStarC_Syntax_Syntax.sigquals + ed.FStarC_Syntax_Syntax.mname + se.FStarC_Syntax_Syntax.sigrng + | uu___ -> FStarC_Syntax_DsEnv.push_sigelt env se in + let uu___ = + FStarC_Syntax_DsEnv.prepare_module_or_interface false false en + m.FStarC_Syntax_Syntax.name mii in + match uu___ with + | (en1, pop_when_done) -> + let en2 = + let uu___1 = + FStarC_Syntax_DsEnv.set_current_module en1 + m.FStarC_Syntax_Syntax.name in + FStarC_Compiler_List.fold_left push_sigelt uu___1 + m.FStarC_Syntax_Syntax.declarations in + let en3 = + if finish then FStarC_Syntax_DsEnv.finish en2 m else en2 in + let uu___1 = + if pop_when_done + then + FStarC_Syntax_DsEnv.export_interface + m.FStarC_Syntax_Syntax.name en3 + else en3 in + ((), uu___1) +let (add_partial_modul_to_env : + FStarC_Syntax_Syntax.modul -> + FStarC_Syntax_DsEnv.module_inclusion_info -> + (FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) -> + unit FStarC_Syntax_DsEnv.withenv) + = add_modul_to_env_core false +let (add_modul_to_env : + FStarC_Syntax_Syntax.modul -> + FStarC_Syntax_DsEnv.module_inclusion_info -> + (FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) -> + unit FStarC_Syntax_DsEnv.withenv) + = add_modul_to_env_core true \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_Cfg.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Cfg.ml new file mode 100644 index 00000000000..90f688bb614 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Cfg.ml @@ -0,0 +1,2736 @@ +open Prims +type fsteps = + { + beta: Prims.bool ; + iota: Prims.bool ; + zeta: Prims.bool ; + zeta_full: Prims.bool ; + weak: Prims.bool ; + hnf: Prims.bool ; + primops: Prims.bool ; + do_not_unfold_pure_lets: Prims.bool ; + unfold_until: + FStarC_Syntax_Syntax.delta_depth FStar_Pervasives_Native.option ; + unfold_only: FStarC_Ident.lid Prims.list FStar_Pervasives_Native.option ; + unfold_fully: FStarC_Ident.lid Prims.list FStar_Pervasives_Native.option ; + unfold_attr: FStarC_Ident.lid Prims.list FStar_Pervasives_Native.option ; + unfold_qual: Prims.string Prims.list FStar_Pervasives_Native.option ; + unfold_namespace: + (Prims.string, Prims.bool) FStarC_Compiler_Path.forest + FStar_Pervasives_Native.option + ; + dont_unfold_attr: + FStarC_Ident.lid Prims.list FStar_Pervasives_Native.option ; + pure_subterms_within_computations: Prims.bool ; + simplify: Prims.bool ; + erase_universes: Prims.bool ; + allow_unbound_universes: Prims.bool ; + reify_: Prims.bool ; + compress_uvars: Prims.bool ; + no_full_norm: Prims.bool ; + check_no_uvars: Prims.bool ; + unmeta: Prims.bool ; + unascribe: Prims.bool ; + in_full_norm_request: Prims.bool ; + weakly_reduce_scrutinee: Prims.bool ; + nbe_step: Prims.bool ; + for_extraction: Prims.bool ; + unrefine: Prims.bool ; + default_univs_to_zero: Prims.bool ; + tactics: Prims.bool } +let (__proj__Mkfsteps__item__beta : fsteps -> Prims.bool) = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> beta +let (__proj__Mkfsteps__item__iota : fsteps -> Prims.bool) = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> iota +let (__proj__Mkfsteps__item__zeta : fsteps -> Prims.bool) = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> zeta +let (__proj__Mkfsteps__item__zeta_full : fsteps -> Prims.bool) = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> zeta_full +let (__proj__Mkfsteps__item__weak : fsteps -> Prims.bool) = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> weak +let (__proj__Mkfsteps__item__hnf : fsteps -> Prims.bool) = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> hnf +let (__proj__Mkfsteps__item__primops : fsteps -> Prims.bool) = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> primops +let (__proj__Mkfsteps__item__do_not_unfold_pure_lets : fsteps -> Prims.bool) + = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> do_not_unfold_pure_lets +let (__proj__Mkfsteps__item__unfold_until : + fsteps -> FStarC_Syntax_Syntax.delta_depth FStar_Pervasives_Native.option) + = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> unfold_until +let (__proj__Mkfsteps__item__unfold_only : + fsteps -> FStarC_Ident.lid Prims.list FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> unfold_only +let (__proj__Mkfsteps__item__unfold_fully : + fsteps -> FStarC_Ident.lid Prims.list FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> unfold_fully +let (__proj__Mkfsteps__item__unfold_attr : + fsteps -> FStarC_Ident.lid Prims.list FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> unfold_attr +let (__proj__Mkfsteps__item__unfold_qual : + fsteps -> Prims.string Prims.list FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> unfold_qual +let (__proj__Mkfsteps__item__unfold_namespace : + fsteps -> + (Prims.string, Prims.bool) FStarC_Compiler_Path.forest + FStar_Pervasives_Native.option) + = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> unfold_namespace +let (__proj__Mkfsteps__item__dont_unfold_attr : + fsteps -> FStarC_Ident.lid Prims.list FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> dont_unfold_attr +let (__proj__Mkfsteps__item__pure_subterms_within_computations : + fsteps -> Prims.bool) = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> + pure_subterms_within_computations +let (__proj__Mkfsteps__item__simplify : fsteps -> Prims.bool) = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> simplify +let (__proj__Mkfsteps__item__erase_universes : fsteps -> Prims.bool) = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> erase_universes +let (__proj__Mkfsteps__item__allow_unbound_universes : fsteps -> Prims.bool) + = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> allow_unbound_universes +let (__proj__Mkfsteps__item__reify_ : fsteps -> Prims.bool) = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> reify_ +let (__proj__Mkfsteps__item__compress_uvars : fsteps -> Prims.bool) = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> compress_uvars +let (__proj__Mkfsteps__item__no_full_norm : fsteps -> Prims.bool) = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> no_full_norm +let (__proj__Mkfsteps__item__check_no_uvars : fsteps -> Prims.bool) = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> check_no_uvars +let (__proj__Mkfsteps__item__unmeta : fsteps -> Prims.bool) = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> unmeta +let (__proj__Mkfsteps__item__unascribe : fsteps -> Prims.bool) = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> unascribe +let (__proj__Mkfsteps__item__in_full_norm_request : fsteps -> Prims.bool) = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> in_full_norm_request +let (__proj__Mkfsteps__item__weakly_reduce_scrutinee : fsteps -> Prims.bool) + = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> weakly_reduce_scrutinee +let (__proj__Mkfsteps__item__nbe_step : fsteps -> Prims.bool) = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> nbe_step +let (__proj__Mkfsteps__item__for_extraction : fsteps -> Prims.bool) = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> for_extraction +let (__proj__Mkfsteps__item__unrefine : fsteps -> Prims.bool) = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> unrefine +let (__proj__Mkfsteps__item__default_univs_to_zero : fsteps -> Prims.bool) = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> default_univs_to_zero +let (__proj__Mkfsteps__item__tactics : fsteps -> Prims.bool) = + fun projectee -> + match projectee with + | { beta; iota; zeta; zeta_full; weak; hnf; primops; + do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; + unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; + pure_subterms_within_computations; simplify; erase_universes; + allow_unbound_universes; reify_; compress_uvars; no_full_norm; + check_no_uvars; unmeta; unascribe; in_full_norm_request; + weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; + default_univs_to_zero; tactics;_} -> tactics +let (steps_to_string : fsteps -> Prims.string) = + fun f -> + let format_opt f1 o = + match o with + | FStar_Pervasives_Native.None -> "None" + | FStar_Pervasives_Native.Some x -> + let uu___ = + let uu___1 = f1 x in FStarC_Compiler_String.op_Hat uu___1 ")" in + FStarC_Compiler_String.op_Hat "Some (" uu___ in + let b = FStarC_Compiler_Util.string_of_bool in + let uu___ = + let uu___1 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) f.beta in + let uu___2 = + let uu___3 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) f.iota in + let uu___4 = + let uu___5 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) f.zeta in + let uu___6 = + let uu___7 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) f.zeta_full in + let uu___8 = + let uu___9 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) f.weak in + let uu___10 = + let uu___11 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) f.hnf in + let uu___12 = + let uu___13 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) f.primops in + let uu___14 = + let uu___15 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + f.do_not_unfold_pure_lets in + let uu___16 = + let uu___17 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_option + FStarC_Syntax_Syntax.showable_delta_depth) + f.unfold_until in + let uu___18 = + let uu___19 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_option + (FStarC_Class_Show.show_list + FStarC_Ident.showable_lident)) + f.unfold_only in + let uu___20 = + let uu___21 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_option + (FStarC_Class_Show.show_list + FStarC_Ident.showable_lident)) + f.unfold_fully in + let uu___22 = + let uu___23 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_option + (FStarC_Class_Show.show_list + FStarC_Ident.showable_lident)) + f.unfold_attr in + let uu___24 = + let uu___25 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_option + (FStarC_Class_Show.show_list + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_string))) + f.unfold_qual in + let uu___26 = + let uu___27 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_option + (FStarC_Class_Show.show_tuple2 + (FStarC_Class_Show.show_list + (FStarC_Class_Show.show_tuple2 + (FStarC_Class_Show.show_list + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_string)) + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool))) + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool))) + f.unfold_namespace in + let uu___28 = + let uu___29 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_option + (FStarC_Class_Show.show_list + FStarC_Ident.showable_lident)) + f.dont_unfold_attr in + let uu___30 = + let uu___31 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + f.pure_subterms_within_computations in + let uu___32 = + let uu___33 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + f.simplify in + let uu___34 = + let uu___35 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + f.erase_universes in + let uu___36 = + let uu___37 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + f.allow_unbound_universes in + let uu___38 = + let uu___39 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + f.reify_ in + let uu___40 = + let uu___41 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + f.compress_uvars in + let uu___42 = + let uu___43 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + f.no_full_norm in + let uu___44 = + let uu___45 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + f.check_no_uvars in + let uu___46 = + let uu___47 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + f.unmeta in + let uu___48 = + let uu___49 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + f.unascribe in + let uu___50 = + let uu___51 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + f.in_full_norm_request in + let uu___52 = + let uu___53 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + f.weakly_reduce_scrutinee in + let uu___54 = + let uu___55 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + f.for_extraction in + let uu___56 = + let uu___57 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + f.unrefine in + let uu___58 = + let uu___59 = + FStarC_Class_Show.show + ( + FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + f.default_univs_to_zero in + let uu___60 = + let uu___61 + = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + f.tactics in + [uu___61] in + uu___59 :: + uu___60 in + uu___57 :: + uu___58 in + uu___55 :: + uu___56 in + uu___53 :: uu___54 in + uu___51 :: uu___52 in + uu___49 :: uu___50 in + uu___47 :: uu___48 in + uu___45 :: uu___46 in + uu___43 :: uu___44 in + uu___41 :: uu___42 in + uu___39 :: uu___40 in + uu___37 :: uu___38 in + uu___35 :: uu___36 in + uu___33 :: uu___34 in + uu___31 :: uu___32 in + uu___29 :: uu___30 in + uu___27 :: uu___28 in + uu___25 :: uu___26 in + uu___23 :: uu___24 in + uu___21 :: uu___22 in + uu___19 :: uu___20 in + uu___17 :: uu___18 in + uu___15 :: uu___16 in + uu___13 :: uu___14 in + uu___11 :: uu___12 in + uu___9 :: uu___10 in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Compiler_Util.format + "{\nbeta = %s;\niota = %s;\nzeta = %s;\nzeta_full = %s;\nweak = %s;\nhnf = %s;\nprimops = %s;\ndo_not_unfold_pure_lets = %s;\nunfold_until = %s;\nunfold_only = %s;\nunfold_fully = %s;\nunfold_attr = %s;\nunfold_qual = %s;\nunfold_namespace = %s;\ndont_unfold_attr = %s;\npure_subterms_within_computations = %s;\nsimplify = %s;\nerase_universes = %s;\nallow_unbound_universes = %s;\nreify_ = %s;\ncompress_uvars = %s;\nno_full_norm = %s;\ncheck_no_uvars = %s;\nunmeta = %s;\nunascribe = %s;\nin_full_norm_request = %s;\nweakly_reduce_scrutinee = %s;\nfor_extraction = %s;\nunrefine = %s;\ndefault_univs_to_zero = %s;\ntactics = %s;\n}" + uu___ +let (deq_fsteps : fsteps FStarC_Class_Deq.deq) = + { + FStarC_Class_Deq.op_Equals_Question = + (fun f1 -> + fun f2 -> + (((((((((((((((((((((((((((((((FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq + FStarC_Class_Ord.ord_bool) + f1.beta f2.beta) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq + FStarC_Class_Ord.ord_bool) + f1.iota f2.iota)) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq + FStarC_Class_Ord.ord_bool) + f1.zeta f2.zeta)) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq + FStarC_Class_Ord.ord_bool) + f1.zeta_full f2.zeta_full)) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq + FStarC_Class_Ord.ord_bool) + f1.weak f2.weak)) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq + FStarC_Class_Ord.ord_bool) + f1.hnf f2.hnf)) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq + FStarC_Class_Ord.ord_bool) + f1.primops f2.primops)) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq + FStarC_Class_Ord.ord_bool) + f1.do_not_unfold_pure_lets + f2.do_not_unfold_pure_lets)) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Deq.deq_option + FStarC_Syntax_Syntax.deq_delta_depth) + f1.unfold_until f2.unfold_until)) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq + (FStarC_Class_Ord.ord_option + (FStarC_Class_Ord.ord_list + FStarC_Syntax_Syntax.ord_fv))) + f1.unfold_only f2.unfold_only)) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq + (FStarC_Class_Ord.ord_option + (FStarC_Class_Ord.ord_list + FStarC_Syntax_Syntax.ord_fv))) + f1.unfold_fully f2.unfold_fully)) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq + (FStarC_Class_Ord.ord_option + (FStarC_Class_Ord.ord_list + FStarC_Syntax_Syntax.ord_fv))) + f1.unfold_attr f2.unfold_attr)) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq + (FStarC_Class_Ord.ord_option + (FStarC_Class_Ord.ord_list + FStarC_Class_Ord.ord_string))) + f1.unfold_qual f2.unfold_qual)) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq + (FStarC_Class_Ord.ord_option + (FStarC_Class_Ord.ord_tuple2 + (FStarC_Class_Ord.ord_list + (FStarC_Class_Ord.ord_tuple2 + (FStarC_Class_Ord.ord_list + FStarC_Class_Ord.ord_string) + FStarC_Class_Ord.ord_bool)) + FStarC_Class_Ord.ord_bool))) + f1.unfold_namespace f2.unfold_namespace)) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq + (FStarC_Class_Ord.ord_option + (FStarC_Class_Ord.ord_list + FStarC_Syntax_Syntax.ord_fv))) + f1.dont_unfold_attr f2.dont_unfold_attr)) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq + FStarC_Class_Ord.ord_bool) + f1.pure_subterms_within_computations + f2.pure_subterms_within_computations)) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq + FStarC_Class_Ord.ord_bool) f1.simplify + f2.simplify)) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq + FStarC_Class_Ord.ord_bool) + f1.erase_universes f2.erase_universes)) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq + FStarC_Class_Ord.ord_bool) + f1.allow_unbound_universes + f2.allow_unbound_universes)) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq + FStarC_Class_Ord.ord_bool) f1.reify_ f2.reify_)) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq FStarC_Class_Ord.ord_bool) + f1.compress_uvars f2.compress_uvars)) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq FStarC_Class_Ord.ord_bool) + f1.no_full_norm f2.no_full_norm)) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq FStarC_Class_Ord.ord_bool) + f1.check_no_uvars f2.check_no_uvars)) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq FStarC_Class_Ord.ord_bool) + f1.unmeta f2.unmeta)) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq FStarC_Class_Ord.ord_bool) + f1.unascribe f2.unascribe)) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq FStarC_Class_Ord.ord_bool) + f1.in_full_norm_request f2.in_full_norm_request)) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq FStarC_Class_Ord.ord_bool) + f1.weakly_reduce_scrutinee f2.weakly_reduce_scrutinee)) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq FStarC_Class_Ord.ord_bool) + f1.nbe_step f2.nbe_step)) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq FStarC_Class_Ord.ord_bool) + f1.for_extraction f2.for_extraction)) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq FStarC_Class_Ord.ord_bool) + f1.unrefine f2.unrefine)) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq FStarC_Class_Ord.ord_bool) + f1.default_univs_to_zero f2.default_univs_to_zero)) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq FStarC_Class_Ord.ord_bool) + f1.tactics f2.tactics)) + } +let (default_steps : fsteps) = + { + beta = true; + iota = true; + zeta = true; + zeta_full = false; + weak = false; + hnf = false; + primops = false; + do_not_unfold_pure_lets = false; + unfold_until = FStar_Pervasives_Native.None; + unfold_only = FStar_Pervasives_Native.None; + unfold_fully = FStar_Pervasives_Native.None; + unfold_attr = FStar_Pervasives_Native.None; + unfold_qual = FStar_Pervasives_Native.None; + unfold_namespace = FStar_Pervasives_Native.None; + dont_unfold_attr = FStar_Pervasives_Native.None; + pure_subterms_within_computations = false; + simplify = false; + erase_universes = false; + allow_unbound_universes = false; + reify_ = false; + compress_uvars = false; + no_full_norm = false; + check_no_uvars = false; + unmeta = false; + unascribe = false; + in_full_norm_request = false; + weakly_reduce_scrutinee = true; + nbe_step = false; + for_extraction = false; + unrefine = false; + default_univs_to_zero = false; + tactics = false + } +let (fstep_add_one : FStarC_TypeChecker_Env.step -> fsteps -> fsteps) = + fun s -> + fun fs -> + match s with + | FStarC_TypeChecker_Env.Beta -> + { + beta = true; + iota = (fs.iota); + zeta = (fs.zeta); + zeta_full = (fs.zeta_full); + weak = (fs.weak); + hnf = (fs.hnf); + primops = (fs.primops); + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (fs.unfold_until); + unfold_only = (fs.unfold_only); + unfold_fully = (fs.unfold_fully); + unfold_attr = (fs.unfold_attr); + unfold_qual = (fs.unfold_qual); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = (fs.simplify); + erase_universes = (fs.erase_universes); + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = (fs.reify_); + compress_uvars = (fs.compress_uvars); + no_full_norm = (fs.no_full_norm); + check_no_uvars = (fs.check_no_uvars); + unmeta = (fs.unmeta); + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = (fs.for_extraction); + unrefine = (fs.unrefine); + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = (fs.tactics) + } + | FStarC_TypeChecker_Env.Iota -> + { + beta = (fs.beta); + iota = true; + zeta = (fs.zeta); + zeta_full = (fs.zeta_full); + weak = (fs.weak); + hnf = (fs.hnf); + primops = (fs.primops); + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (fs.unfold_until); + unfold_only = (fs.unfold_only); + unfold_fully = (fs.unfold_fully); + unfold_attr = (fs.unfold_attr); + unfold_qual = (fs.unfold_qual); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = (fs.simplify); + erase_universes = (fs.erase_universes); + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = (fs.reify_); + compress_uvars = (fs.compress_uvars); + no_full_norm = (fs.no_full_norm); + check_no_uvars = (fs.check_no_uvars); + unmeta = (fs.unmeta); + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = (fs.for_extraction); + unrefine = (fs.unrefine); + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = (fs.tactics) + } + | FStarC_TypeChecker_Env.Zeta -> + { + beta = (fs.beta); + iota = (fs.iota); + zeta = true; + zeta_full = (fs.zeta_full); + weak = (fs.weak); + hnf = (fs.hnf); + primops = (fs.primops); + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (fs.unfold_until); + unfold_only = (fs.unfold_only); + unfold_fully = (fs.unfold_fully); + unfold_attr = (fs.unfold_attr); + unfold_qual = (fs.unfold_qual); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = (fs.simplify); + erase_universes = (fs.erase_universes); + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = (fs.reify_); + compress_uvars = (fs.compress_uvars); + no_full_norm = (fs.no_full_norm); + check_no_uvars = (fs.check_no_uvars); + unmeta = (fs.unmeta); + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = (fs.for_extraction); + unrefine = (fs.unrefine); + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = (fs.tactics) + } + | FStarC_TypeChecker_Env.ZetaFull -> + { + beta = (fs.beta); + iota = (fs.iota); + zeta = (fs.zeta); + zeta_full = true; + weak = (fs.weak); + hnf = (fs.hnf); + primops = (fs.primops); + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (fs.unfold_until); + unfold_only = (fs.unfold_only); + unfold_fully = (fs.unfold_fully); + unfold_attr = (fs.unfold_attr); + unfold_qual = (fs.unfold_qual); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = (fs.simplify); + erase_universes = (fs.erase_universes); + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = (fs.reify_); + compress_uvars = (fs.compress_uvars); + no_full_norm = (fs.no_full_norm); + check_no_uvars = (fs.check_no_uvars); + unmeta = (fs.unmeta); + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = (fs.for_extraction); + unrefine = (fs.unrefine); + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = (fs.tactics) + } + | FStarC_TypeChecker_Env.Exclude (FStarC_TypeChecker_Env.Beta) -> + { + beta = false; + iota = (fs.iota); + zeta = (fs.zeta); + zeta_full = (fs.zeta_full); + weak = (fs.weak); + hnf = (fs.hnf); + primops = (fs.primops); + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (fs.unfold_until); + unfold_only = (fs.unfold_only); + unfold_fully = (fs.unfold_fully); + unfold_attr = (fs.unfold_attr); + unfold_qual = (fs.unfold_qual); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = (fs.simplify); + erase_universes = (fs.erase_universes); + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = (fs.reify_); + compress_uvars = (fs.compress_uvars); + no_full_norm = (fs.no_full_norm); + check_no_uvars = (fs.check_no_uvars); + unmeta = (fs.unmeta); + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = (fs.for_extraction); + unrefine = (fs.unrefine); + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = (fs.tactics) + } + | FStarC_TypeChecker_Env.Exclude (FStarC_TypeChecker_Env.Iota) -> + { + beta = (fs.beta); + iota = false; + zeta = (fs.zeta); + zeta_full = (fs.zeta_full); + weak = (fs.weak); + hnf = (fs.hnf); + primops = (fs.primops); + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (fs.unfold_until); + unfold_only = (fs.unfold_only); + unfold_fully = (fs.unfold_fully); + unfold_attr = (fs.unfold_attr); + unfold_qual = (fs.unfold_qual); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = (fs.simplify); + erase_universes = (fs.erase_universes); + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = (fs.reify_); + compress_uvars = (fs.compress_uvars); + no_full_norm = (fs.no_full_norm); + check_no_uvars = (fs.check_no_uvars); + unmeta = (fs.unmeta); + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = (fs.for_extraction); + unrefine = (fs.unrefine); + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = (fs.tactics) + } + | FStarC_TypeChecker_Env.Exclude (FStarC_TypeChecker_Env.Zeta) -> + { + beta = (fs.beta); + iota = (fs.iota); + zeta = false; + zeta_full = (fs.zeta_full); + weak = (fs.weak); + hnf = (fs.hnf); + primops = (fs.primops); + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (fs.unfold_until); + unfold_only = (fs.unfold_only); + unfold_fully = (fs.unfold_fully); + unfold_attr = (fs.unfold_attr); + unfold_qual = (fs.unfold_qual); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = (fs.simplify); + erase_universes = (fs.erase_universes); + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = (fs.reify_); + compress_uvars = (fs.compress_uvars); + no_full_norm = (fs.no_full_norm); + check_no_uvars = (fs.check_no_uvars); + unmeta = (fs.unmeta); + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = (fs.for_extraction); + unrefine = (fs.unrefine); + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = (fs.tactics) + } + | FStarC_TypeChecker_Env.Exclude uu___ -> failwith "Bad exclude" + | FStarC_TypeChecker_Env.Weak -> + { + beta = (fs.beta); + iota = (fs.iota); + zeta = (fs.zeta); + zeta_full = (fs.zeta_full); + weak = true; + hnf = (fs.hnf); + primops = (fs.primops); + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (fs.unfold_until); + unfold_only = (fs.unfold_only); + unfold_fully = (fs.unfold_fully); + unfold_attr = (fs.unfold_attr); + unfold_qual = (fs.unfold_qual); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = (fs.simplify); + erase_universes = (fs.erase_universes); + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = (fs.reify_); + compress_uvars = (fs.compress_uvars); + no_full_norm = (fs.no_full_norm); + check_no_uvars = (fs.check_no_uvars); + unmeta = (fs.unmeta); + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = (fs.for_extraction); + unrefine = (fs.unrefine); + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = (fs.tactics) + } + | FStarC_TypeChecker_Env.HNF -> + { + beta = (fs.beta); + iota = (fs.iota); + zeta = (fs.zeta); + zeta_full = (fs.zeta_full); + weak = (fs.weak); + hnf = true; + primops = (fs.primops); + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (fs.unfold_until); + unfold_only = (fs.unfold_only); + unfold_fully = (fs.unfold_fully); + unfold_attr = (fs.unfold_attr); + unfold_qual = (fs.unfold_qual); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = (fs.simplify); + erase_universes = (fs.erase_universes); + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = (fs.reify_); + compress_uvars = (fs.compress_uvars); + no_full_norm = (fs.no_full_norm); + check_no_uvars = (fs.check_no_uvars); + unmeta = (fs.unmeta); + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = (fs.for_extraction); + unrefine = (fs.unrefine); + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = (fs.tactics) + } + | FStarC_TypeChecker_Env.Primops -> + { + beta = (fs.beta); + iota = (fs.iota); + zeta = (fs.zeta); + zeta_full = (fs.zeta_full); + weak = (fs.weak); + hnf = (fs.hnf); + primops = true; + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (fs.unfold_until); + unfold_only = (fs.unfold_only); + unfold_fully = (fs.unfold_fully); + unfold_attr = (fs.unfold_attr); + unfold_qual = (fs.unfold_qual); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = (fs.simplify); + erase_universes = (fs.erase_universes); + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = (fs.reify_); + compress_uvars = (fs.compress_uvars); + no_full_norm = (fs.no_full_norm); + check_no_uvars = (fs.check_no_uvars); + unmeta = (fs.unmeta); + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = (fs.for_extraction); + unrefine = (fs.unrefine); + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = (fs.tactics) + } + | FStarC_TypeChecker_Env.Eager_unfolding -> fs + | FStarC_TypeChecker_Env.Inlining -> fs + | FStarC_TypeChecker_Env.DoNotUnfoldPureLets -> + { + beta = (fs.beta); + iota = (fs.iota); + zeta = (fs.zeta); + zeta_full = (fs.zeta_full); + weak = (fs.weak); + hnf = (fs.hnf); + primops = (fs.primops); + do_not_unfold_pure_lets = true; + unfold_until = (fs.unfold_until); + unfold_only = (fs.unfold_only); + unfold_fully = (fs.unfold_fully); + unfold_attr = (fs.unfold_attr); + unfold_qual = (fs.unfold_qual); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = (fs.simplify); + erase_universes = (fs.erase_universes); + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = (fs.reify_); + compress_uvars = (fs.compress_uvars); + no_full_norm = (fs.no_full_norm); + check_no_uvars = (fs.check_no_uvars); + unmeta = (fs.unmeta); + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = (fs.for_extraction); + unrefine = (fs.unrefine); + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = (fs.tactics) + } + | FStarC_TypeChecker_Env.UnfoldUntil d -> + { + beta = (fs.beta); + iota = (fs.iota); + zeta = (fs.zeta); + zeta_full = (fs.zeta_full); + weak = (fs.weak); + hnf = (fs.hnf); + primops = (fs.primops); + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (FStar_Pervasives_Native.Some d); + unfold_only = (fs.unfold_only); + unfold_fully = (fs.unfold_fully); + unfold_attr = (fs.unfold_attr); + unfold_qual = (fs.unfold_qual); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = (fs.simplify); + erase_universes = (fs.erase_universes); + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = (fs.reify_); + compress_uvars = (fs.compress_uvars); + no_full_norm = (fs.no_full_norm); + check_no_uvars = (fs.check_no_uvars); + unmeta = (fs.unmeta); + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = (fs.for_extraction); + unrefine = (fs.unrefine); + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = (fs.tactics) + } + | FStarC_TypeChecker_Env.UnfoldOnly lids -> + { + beta = (fs.beta); + iota = (fs.iota); + zeta = (fs.zeta); + zeta_full = (fs.zeta_full); + weak = (fs.weak); + hnf = (fs.hnf); + primops = (fs.primops); + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (fs.unfold_until); + unfold_only = (FStar_Pervasives_Native.Some lids); + unfold_fully = (fs.unfold_fully); + unfold_attr = (fs.unfold_attr); + unfold_qual = (fs.unfold_qual); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = (fs.simplify); + erase_universes = (fs.erase_universes); + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = (fs.reify_); + compress_uvars = (fs.compress_uvars); + no_full_norm = (fs.no_full_norm); + check_no_uvars = (fs.check_no_uvars); + unmeta = (fs.unmeta); + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = (fs.for_extraction); + unrefine = (fs.unrefine); + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = (fs.tactics) + } + | FStarC_TypeChecker_Env.UnfoldFully lids -> + { + beta = (fs.beta); + iota = (fs.iota); + zeta = (fs.zeta); + zeta_full = (fs.zeta_full); + weak = (fs.weak); + hnf = (fs.hnf); + primops = (fs.primops); + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (fs.unfold_until); + unfold_only = (fs.unfold_only); + unfold_fully = (FStar_Pervasives_Native.Some lids); + unfold_attr = (fs.unfold_attr); + unfold_qual = (fs.unfold_qual); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = (fs.simplify); + erase_universes = (fs.erase_universes); + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = (fs.reify_); + compress_uvars = (fs.compress_uvars); + no_full_norm = (fs.no_full_norm); + check_no_uvars = (fs.check_no_uvars); + unmeta = (fs.unmeta); + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = (fs.for_extraction); + unrefine = (fs.unrefine); + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = (fs.tactics) + } + | FStarC_TypeChecker_Env.UnfoldAttr lids -> + { + beta = (fs.beta); + iota = (fs.iota); + zeta = (fs.zeta); + zeta_full = (fs.zeta_full); + weak = (fs.weak); + hnf = (fs.hnf); + primops = (fs.primops); + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (fs.unfold_until); + unfold_only = (fs.unfold_only); + unfold_fully = (fs.unfold_fully); + unfold_attr = (FStar_Pervasives_Native.Some lids); + unfold_qual = (fs.unfold_qual); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = (fs.simplify); + erase_universes = (fs.erase_universes); + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = (fs.reify_); + compress_uvars = (fs.compress_uvars); + no_full_norm = (fs.no_full_norm); + check_no_uvars = (fs.check_no_uvars); + unmeta = (fs.unmeta); + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = (fs.for_extraction); + unrefine = (fs.unrefine); + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = (fs.tactics) + } + | FStarC_TypeChecker_Env.UnfoldQual strs -> + let fs1 = + { + beta = (fs.beta); + iota = (fs.iota); + zeta = (fs.zeta); + zeta_full = (fs.zeta_full); + weak = (fs.weak); + hnf = (fs.hnf); + primops = (fs.primops); + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (fs.unfold_until); + unfold_only = (fs.unfold_only); + unfold_fully = (fs.unfold_fully); + unfold_attr = (fs.unfold_attr); + unfold_qual = (FStar_Pervasives_Native.Some strs); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = (fs.simplify); + erase_universes = (fs.erase_universes); + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = (fs.reify_); + compress_uvars = (fs.compress_uvars); + no_full_norm = (fs.no_full_norm); + check_no_uvars = (fs.check_no_uvars); + unmeta = (fs.unmeta); + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = (fs.for_extraction); + unrefine = (fs.unrefine); + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = (fs.tactics) + } in + if + FStarC_Compiler_List.contains "pure_subterms_within_computations" + strs + then + { + beta = (fs1.beta); + iota = (fs1.iota); + zeta = (fs1.zeta); + zeta_full = (fs1.zeta_full); + weak = (fs1.weak); + hnf = (fs1.hnf); + primops = (fs1.primops); + do_not_unfold_pure_lets = (fs1.do_not_unfold_pure_lets); + unfold_until = (fs1.unfold_until); + unfold_only = (fs1.unfold_only); + unfold_fully = (fs1.unfold_fully); + unfold_attr = (fs1.unfold_attr); + unfold_qual = (fs1.unfold_qual); + unfold_namespace = (fs1.unfold_namespace); + dont_unfold_attr = (fs1.dont_unfold_attr); + pure_subterms_within_computations = true; + simplify = (fs1.simplify); + erase_universes = (fs1.erase_universes); + allow_unbound_universes = (fs1.allow_unbound_universes); + reify_ = (fs1.reify_); + compress_uvars = (fs1.compress_uvars); + no_full_norm = (fs1.no_full_norm); + check_no_uvars = (fs1.check_no_uvars); + unmeta = (fs1.unmeta); + unascribe = (fs1.unascribe); + in_full_norm_request = (fs1.in_full_norm_request); + weakly_reduce_scrutinee = (fs1.weakly_reduce_scrutinee); + nbe_step = (fs1.nbe_step); + for_extraction = (fs1.for_extraction); + unrefine = (fs1.unrefine); + default_univs_to_zero = (fs1.default_univs_to_zero); + tactics = (fs1.tactics) + } + else fs1 + | FStarC_TypeChecker_Env.UnfoldNamespace strs -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Compiler_List.map + (fun s1 -> + let uu___3 = FStarC_Ident.path_of_text s1 in + (uu___3, true)) strs in + (uu___2, false) in + FStar_Pervasives_Native.Some uu___1 in + { + beta = (fs.beta); + iota = (fs.iota); + zeta = (fs.zeta); + zeta_full = (fs.zeta_full); + weak = (fs.weak); + hnf = (fs.hnf); + primops = (fs.primops); + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (fs.unfold_until); + unfold_only = (fs.unfold_only); + unfold_fully = (fs.unfold_fully); + unfold_attr = (fs.unfold_attr); + unfold_qual = (fs.unfold_qual); + unfold_namespace = uu___; + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = (fs.simplify); + erase_universes = (fs.erase_universes); + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = (fs.reify_); + compress_uvars = (fs.compress_uvars); + no_full_norm = (fs.no_full_norm); + check_no_uvars = (fs.check_no_uvars); + unmeta = (fs.unmeta); + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = (fs.for_extraction); + unrefine = (fs.unrefine); + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = (fs.tactics) + } + | FStarC_TypeChecker_Env.DontUnfoldAttr lids -> + { + beta = (fs.beta); + iota = (fs.iota); + zeta = (fs.zeta); + zeta_full = (fs.zeta_full); + weak = (fs.weak); + hnf = (fs.hnf); + primops = (fs.primops); + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (fs.unfold_until); + unfold_only = (fs.unfold_only); + unfold_fully = (fs.unfold_fully); + unfold_attr = (fs.unfold_attr); + unfold_qual = (fs.unfold_qual); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (FStar_Pervasives_Native.Some lids); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = (fs.simplify); + erase_universes = (fs.erase_universes); + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = (fs.reify_); + compress_uvars = (fs.compress_uvars); + no_full_norm = (fs.no_full_norm); + check_no_uvars = (fs.check_no_uvars); + unmeta = (fs.unmeta); + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = (fs.for_extraction); + unrefine = (fs.unrefine); + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = (fs.tactics) + } + | FStarC_TypeChecker_Env.PureSubtermsWithinComputations -> + { + beta = (fs.beta); + iota = (fs.iota); + zeta = (fs.zeta); + zeta_full = (fs.zeta_full); + weak = (fs.weak); + hnf = (fs.hnf); + primops = (fs.primops); + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (fs.unfold_until); + unfold_only = (fs.unfold_only); + unfold_fully = (fs.unfold_fully); + unfold_attr = (fs.unfold_attr); + unfold_qual = (fs.unfold_qual); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = true; + simplify = (fs.simplify); + erase_universes = (fs.erase_universes); + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = (fs.reify_); + compress_uvars = (fs.compress_uvars); + no_full_norm = (fs.no_full_norm); + check_no_uvars = (fs.check_no_uvars); + unmeta = (fs.unmeta); + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = (fs.for_extraction); + unrefine = (fs.unrefine); + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = (fs.tactics) + } + | FStarC_TypeChecker_Env.Simplify -> + { + beta = (fs.beta); + iota = (fs.iota); + zeta = (fs.zeta); + zeta_full = (fs.zeta_full); + weak = (fs.weak); + hnf = (fs.hnf); + primops = (fs.primops); + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (fs.unfold_until); + unfold_only = (fs.unfold_only); + unfold_fully = (fs.unfold_fully); + unfold_attr = (fs.unfold_attr); + unfold_qual = (fs.unfold_qual); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = true; + erase_universes = (fs.erase_universes); + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = (fs.reify_); + compress_uvars = (fs.compress_uvars); + no_full_norm = (fs.no_full_norm); + check_no_uvars = (fs.check_no_uvars); + unmeta = (fs.unmeta); + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = (fs.for_extraction); + unrefine = (fs.unrefine); + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = (fs.tactics) + } + | FStarC_TypeChecker_Env.EraseUniverses -> + { + beta = (fs.beta); + iota = (fs.iota); + zeta = (fs.zeta); + zeta_full = (fs.zeta_full); + weak = (fs.weak); + hnf = (fs.hnf); + primops = (fs.primops); + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (fs.unfold_until); + unfold_only = (fs.unfold_only); + unfold_fully = (fs.unfold_fully); + unfold_attr = (fs.unfold_attr); + unfold_qual = (fs.unfold_qual); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = (fs.simplify); + erase_universes = true; + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = (fs.reify_); + compress_uvars = (fs.compress_uvars); + no_full_norm = (fs.no_full_norm); + check_no_uvars = (fs.check_no_uvars); + unmeta = (fs.unmeta); + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = (fs.for_extraction); + unrefine = (fs.unrefine); + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = (fs.tactics) + } + | FStarC_TypeChecker_Env.AllowUnboundUniverses -> + { + beta = (fs.beta); + iota = (fs.iota); + zeta = (fs.zeta); + zeta_full = (fs.zeta_full); + weak = (fs.weak); + hnf = (fs.hnf); + primops = (fs.primops); + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (fs.unfold_until); + unfold_only = (fs.unfold_only); + unfold_fully = (fs.unfold_fully); + unfold_attr = (fs.unfold_attr); + unfold_qual = (fs.unfold_qual); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = (fs.simplify); + erase_universes = (fs.erase_universes); + allow_unbound_universes = true; + reify_ = (fs.reify_); + compress_uvars = (fs.compress_uvars); + no_full_norm = (fs.no_full_norm); + check_no_uvars = (fs.check_no_uvars); + unmeta = (fs.unmeta); + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = (fs.for_extraction); + unrefine = (fs.unrefine); + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = (fs.tactics) + } + | FStarC_TypeChecker_Env.Reify -> + { + beta = (fs.beta); + iota = (fs.iota); + zeta = (fs.zeta); + zeta_full = (fs.zeta_full); + weak = (fs.weak); + hnf = (fs.hnf); + primops = (fs.primops); + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (fs.unfold_until); + unfold_only = (fs.unfold_only); + unfold_fully = (fs.unfold_fully); + unfold_attr = (fs.unfold_attr); + unfold_qual = (fs.unfold_qual); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = (fs.simplify); + erase_universes = (fs.erase_universes); + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = true; + compress_uvars = (fs.compress_uvars); + no_full_norm = (fs.no_full_norm); + check_no_uvars = (fs.check_no_uvars); + unmeta = (fs.unmeta); + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = (fs.for_extraction); + unrefine = (fs.unrefine); + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = (fs.tactics) + } + | FStarC_TypeChecker_Env.CompressUvars -> + { + beta = (fs.beta); + iota = (fs.iota); + zeta = (fs.zeta); + zeta_full = (fs.zeta_full); + weak = (fs.weak); + hnf = (fs.hnf); + primops = (fs.primops); + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (fs.unfold_until); + unfold_only = (fs.unfold_only); + unfold_fully = (fs.unfold_fully); + unfold_attr = (fs.unfold_attr); + unfold_qual = (fs.unfold_qual); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = (fs.simplify); + erase_universes = (fs.erase_universes); + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = (fs.reify_); + compress_uvars = true; + no_full_norm = (fs.no_full_norm); + check_no_uvars = (fs.check_no_uvars); + unmeta = (fs.unmeta); + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = (fs.for_extraction); + unrefine = (fs.unrefine); + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = (fs.tactics) + } + | FStarC_TypeChecker_Env.NoFullNorm -> + { + beta = (fs.beta); + iota = (fs.iota); + zeta = (fs.zeta); + zeta_full = (fs.zeta_full); + weak = (fs.weak); + hnf = (fs.hnf); + primops = (fs.primops); + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (fs.unfold_until); + unfold_only = (fs.unfold_only); + unfold_fully = (fs.unfold_fully); + unfold_attr = (fs.unfold_attr); + unfold_qual = (fs.unfold_qual); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = (fs.simplify); + erase_universes = (fs.erase_universes); + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = (fs.reify_); + compress_uvars = (fs.compress_uvars); + no_full_norm = true; + check_no_uvars = (fs.check_no_uvars); + unmeta = (fs.unmeta); + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = (fs.for_extraction); + unrefine = (fs.unrefine); + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = (fs.tactics) + } + | FStarC_TypeChecker_Env.CheckNoUvars -> + { + beta = (fs.beta); + iota = (fs.iota); + zeta = (fs.zeta); + zeta_full = (fs.zeta_full); + weak = (fs.weak); + hnf = (fs.hnf); + primops = (fs.primops); + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (fs.unfold_until); + unfold_only = (fs.unfold_only); + unfold_fully = (fs.unfold_fully); + unfold_attr = (fs.unfold_attr); + unfold_qual = (fs.unfold_qual); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = (fs.simplify); + erase_universes = (fs.erase_universes); + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = (fs.reify_); + compress_uvars = (fs.compress_uvars); + no_full_norm = (fs.no_full_norm); + check_no_uvars = true; + unmeta = (fs.unmeta); + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = (fs.for_extraction); + unrefine = (fs.unrefine); + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = (fs.tactics) + } + | FStarC_TypeChecker_Env.Unmeta -> + { + beta = (fs.beta); + iota = (fs.iota); + zeta = (fs.zeta); + zeta_full = (fs.zeta_full); + weak = (fs.weak); + hnf = (fs.hnf); + primops = (fs.primops); + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (fs.unfold_until); + unfold_only = (fs.unfold_only); + unfold_fully = (fs.unfold_fully); + unfold_attr = (fs.unfold_attr); + unfold_qual = (fs.unfold_qual); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = (fs.simplify); + erase_universes = (fs.erase_universes); + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = (fs.reify_); + compress_uvars = (fs.compress_uvars); + no_full_norm = (fs.no_full_norm); + check_no_uvars = (fs.check_no_uvars); + unmeta = true; + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = (fs.for_extraction); + unrefine = (fs.unrefine); + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = (fs.tactics) + } + | FStarC_TypeChecker_Env.Unascribe -> + { + beta = (fs.beta); + iota = (fs.iota); + zeta = (fs.zeta); + zeta_full = (fs.zeta_full); + weak = (fs.weak); + hnf = (fs.hnf); + primops = (fs.primops); + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (fs.unfold_until); + unfold_only = (fs.unfold_only); + unfold_fully = (fs.unfold_fully); + unfold_attr = (fs.unfold_attr); + unfold_qual = (fs.unfold_qual); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = (fs.simplify); + erase_universes = (fs.erase_universes); + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = (fs.reify_); + compress_uvars = (fs.compress_uvars); + no_full_norm = (fs.no_full_norm); + check_no_uvars = (fs.check_no_uvars); + unmeta = (fs.unmeta); + unascribe = true; + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = (fs.for_extraction); + unrefine = (fs.unrefine); + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = (fs.tactics) + } + | FStarC_TypeChecker_Env.NBE -> + { + beta = (fs.beta); + iota = (fs.iota); + zeta = (fs.zeta); + zeta_full = (fs.zeta_full); + weak = (fs.weak); + hnf = (fs.hnf); + primops = (fs.primops); + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (fs.unfold_until); + unfold_only = (fs.unfold_only); + unfold_fully = (fs.unfold_fully); + unfold_attr = (fs.unfold_attr); + unfold_qual = (fs.unfold_qual); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = (fs.simplify); + erase_universes = (fs.erase_universes); + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = (fs.reify_); + compress_uvars = (fs.compress_uvars); + no_full_norm = (fs.no_full_norm); + check_no_uvars = (fs.check_no_uvars); + unmeta = (fs.unmeta); + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = true; + for_extraction = (fs.for_extraction); + unrefine = (fs.unrefine); + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = (fs.tactics) + } + | FStarC_TypeChecker_Env.ForExtraction -> + { + beta = (fs.beta); + iota = (fs.iota); + zeta = (fs.zeta); + zeta_full = (fs.zeta_full); + weak = (fs.weak); + hnf = (fs.hnf); + primops = (fs.primops); + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (fs.unfold_until); + unfold_only = (fs.unfold_only); + unfold_fully = (fs.unfold_fully); + unfold_attr = (fs.unfold_attr); + unfold_qual = (fs.unfold_qual); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = (fs.simplify); + erase_universes = (fs.erase_universes); + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = (fs.reify_); + compress_uvars = (fs.compress_uvars); + no_full_norm = (fs.no_full_norm); + check_no_uvars = (fs.check_no_uvars); + unmeta = (fs.unmeta); + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = true; + unrefine = (fs.unrefine); + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = (fs.tactics) + } + | FStarC_TypeChecker_Env.Unrefine -> + { + beta = (fs.beta); + iota = (fs.iota); + zeta = (fs.zeta); + zeta_full = (fs.zeta_full); + weak = (fs.weak); + hnf = (fs.hnf); + primops = (fs.primops); + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (fs.unfold_until); + unfold_only = (fs.unfold_only); + unfold_fully = (fs.unfold_fully); + unfold_attr = (fs.unfold_attr); + unfold_qual = (fs.unfold_qual); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = (fs.simplify); + erase_universes = (fs.erase_universes); + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = (fs.reify_); + compress_uvars = (fs.compress_uvars); + no_full_norm = (fs.no_full_norm); + check_no_uvars = (fs.check_no_uvars); + unmeta = (fs.unmeta); + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = (fs.for_extraction); + unrefine = true; + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = (fs.tactics) + } + | FStarC_TypeChecker_Env.NormDebug -> fs + | FStarC_TypeChecker_Env.DefaultUnivsToZero -> + { + beta = (fs.beta); + iota = (fs.iota); + zeta = (fs.zeta); + zeta_full = (fs.zeta_full); + weak = (fs.weak); + hnf = (fs.hnf); + primops = (fs.primops); + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (fs.unfold_until); + unfold_only = (fs.unfold_only); + unfold_fully = (fs.unfold_fully); + unfold_attr = (fs.unfold_attr); + unfold_qual = (fs.unfold_qual); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = (fs.simplify); + erase_universes = (fs.erase_universes); + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = (fs.reify_); + compress_uvars = (fs.compress_uvars); + no_full_norm = (fs.no_full_norm); + check_no_uvars = (fs.check_no_uvars); + unmeta = (fs.unmeta); + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = (fs.for_extraction); + unrefine = (fs.unrefine); + default_univs_to_zero = true; + tactics = (fs.tactics) + } + | FStarC_TypeChecker_Env.Tactics -> + { + beta = (fs.beta); + iota = (fs.iota); + zeta = (fs.zeta); + zeta_full = (fs.zeta_full); + weak = (fs.weak); + hnf = (fs.hnf); + primops = (fs.primops); + do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); + unfold_until = (fs.unfold_until); + unfold_only = (fs.unfold_only); + unfold_fully = (fs.unfold_fully); + unfold_attr = (fs.unfold_attr); + unfold_qual = (fs.unfold_qual); + unfold_namespace = (fs.unfold_namespace); + dont_unfold_attr = (fs.dont_unfold_attr); + pure_subterms_within_computations = + (fs.pure_subterms_within_computations); + simplify = (fs.simplify); + erase_universes = (fs.erase_universes); + allow_unbound_universes = (fs.allow_unbound_universes); + reify_ = (fs.reify_); + compress_uvars = (fs.compress_uvars); + no_full_norm = (fs.no_full_norm); + check_no_uvars = (fs.check_no_uvars); + unmeta = (fs.unmeta); + unascribe = (fs.unascribe); + in_full_norm_request = (fs.in_full_norm_request); + weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); + nbe_step = (fs.nbe_step); + for_extraction = (fs.for_extraction); + unrefine = (fs.unrefine); + default_univs_to_zero = (fs.default_univs_to_zero); + tactics = true + } +let (to_fsteps : FStarC_TypeChecker_Env.step Prims.list -> fsteps) = + fun s -> FStarC_Compiler_List.fold_right fstep_add_one s default_steps +type debug_switches = + { + gen: Prims.bool ; + top: Prims.bool ; + cfg: Prims.bool ; + primop: Prims.bool ; + unfolding: Prims.bool ; + b380: Prims.bool ; + wpe: Prims.bool ; + norm_delayed: Prims.bool ; + print_normalized: Prims.bool ; + debug_nbe: Prims.bool ; + erase_erasable_args: Prims.bool } +let (__proj__Mkdebug_switches__item__gen : debug_switches -> Prims.bool) = + fun projectee -> + match projectee with + | { gen; top; cfg; primop; unfolding; b380; wpe; norm_delayed; + print_normalized; debug_nbe; erase_erasable_args;_} -> gen +let (__proj__Mkdebug_switches__item__top : debug_switches -> Prims.bool) = + fun projectee -> + match projectee with + | { gen; top; cfg; primop; unfolding; b380; wpe; norm_delayed; + print_normalized; debug_nbe; erase_erasable_args;_} -> top +let (__proj__Mkdebug_switches__item__cfg : debug_switches -> Prims.bool) = + fun projectee -> + match projectee with + | { gen; top; cfg; primop; unfolding; b380; wpe; norm_delayed; + print_normalized; debug_nbe; erase_erasable_args;_} -> cfg +let (__proj__Mkdebug_switches__item__primop : debug_switches -> Prims.bool) = + fun projectee -> + match projectee with + | { gen; top; cfg; primop; unfolding; b380; wpe; norm_delayed; + print_normalized; debug_nbe; erase_erasable_args;_} -> primop +let (__proj__Mkdebug_switches__item__unfolding : + debug_switches -> Prims.bool) = + fun projectee -> + match projectee with + | { gen; top; cfg; primop; unfolding; b380; wpe; norm_delayed; + print_normalized; debug_nbe; erase_erasable_args;_} -> unfolding +let (__proj__Mkdebug_switches__item__b380 : debug_switches -> Prims.bool) = + fun projectee -> + match projectee with + | { gen; top; cfg; primop; unfolding; b380; wpe; norm_delayed; + print_normalized; debug_nbe; erase_erasable_args;_} -> b380 +let (__proj__Mkdebug_switches__item__wpe : debug_switches -> Prims.bool) = + fun projectee -> + match projectee with + | { gen; top; cfg; primop; unfolding; b380; wpe; norm_delayed; + print_normalized; debug_nbe; erase_erasable_args;_} -> wpe +let (__proj__Mkdebug_switches__item__norm_delayed : + debug_switches -> Prims.bool) = + fun projectee -> + match projectee with + | { gen; top; cfg; primop; unfolding; b380; wpe; norm_delayed; + print_normalized; debug_nbe; erase_erasable_args;_} -> norm_delayed +let (__proj__Mkdebug_switches__item__print_normalized : + debug_switches -> Prims.bool) = + fun projectee -> + match projectee with + | { gen; top; cfg; primop; unfolding; b380; wpe; norm_delayed; + print_normalized; debug_nbe; erase_erasable_args;_} -> + print_normalized +let (__proj__Mkdebug_switches__item__debug_nbe : + debug_switches -> Prims.bool) = + fun projectee -> + match projectee with + | { gen; top; cfg; primop; unfolding; b380; wpe; norm_delayed; + print_normalized; debug_nbe; erase_erasable_args;_} -> debug_nbe +let (__proj__Mkdebug_switches__item__erase_erasable_args : + debug_switches -> Prims.bool) = + fun projectee -> + match projectee with + | { gen; top; cfg; primop; unfolding; b380; wpe; norm_delayed; + print_normalized; debug_nbe; erase_erasable_args;_} -> + erase_erasable_args +let (no_debug_switches : debug_switches) = + { + gen = false; + top = false; + cfg = false; + primop = false; + unfolding = false; + b380 = false; + wpe = false; + norm_delayed = false; + print_normalized = false; + debug_nbe = false; + erase_erasable_args = false + } +type cfg = + { + steps: fsteps ; + tcenv: FStarC_TypeChecker_Env.env ; + debug: debug_switches ; + delta_level: FStarC_TypeChecker_Env.delta_level Prims.list ; + primitive_steps: + FStarC_TypeChecker_Primops_Base.primitive_step FStarC_Compiler_Util.psmap ; + strong: Prims.bool ; + memoize_lazy: Prims.bool ; + normalize_pure_lets: Prims.bool ; + reifying: Prims.bool ; + compat_memo_ignore_cfg: Prims.bool } +let (__proj__Mkcfg__item__steps : cfg -> fsteps) = + fun projectee -> + match projectee with + | { steps; tcenv; debug; delta_level; primitive_steps; strong; + memoize_lazy; normalize_pure_lets; reifying; + compat_memo_ignore_cfg;_} -> steps +let (__proj__Mkcfg__item__tcenv : cfg -> FStarC_TypeChecker_Env.env) = + fun projectee -> + match projectee with + | { steps; tcenv; debug; delta_level; primitive_steps; strong; + memoize_lazy; normalize_pure_lets; reifying; + compat_memo_ignore_cfg;_} -> tcenv +let (__proj__Mkcfg__item__debug : cfg -> debug_switches) = + fun projectee -> + match projectee with + | { steps; tcenv; debug; delta_level; primitive_steps; strong; + memoize_lazy; normalize_pure_lets; reifying; + compat_memo_ignore_cfg;_} -> debug +let (__proj__Mkcfg__item__delta_level : + cfg -> FStarC_TypeChecker_Env.delta_level Prims.list) = + fun projectee -> + match projectee with + | { steps; tcenv; debug; delta_level; primitive_steps; strong; + memoize_lazy; normalize_pure_lets; reifying; + compat_memo_ignore_cfg;_} -> delta_level +let (__proj__Mkcfg__item__primitive_steps : + cfg -> + FStarC_TypeChecker_Primops_Base.primitive_step FStarC_Compiler_Util.psmap) + = + fun projectee -> + match projectee with + | { steps; tcenv; debug; delta_level; primitive_steps; strong; + memoize_lazy; normalize_pure_lets; reifying; + compat_memo_ignore_cfg;_} -> primitive_steps +let (__proj__Mkcfg__item__strong : cfg -> Prims.bool) = + fun projectee -> + match projectee with + | { steps; tcenv; debug; delta_level; primitive_steps; strong; + memoize_lazy; normalize_pure_lets; reifying; + compat_memo_ignore_cfg;_} -> strong +let (__proj__Mkcfg__item__memoize_lazy : cfg -> Prims.bool) = + fun projectee -> + match projectee with + | { steps; tcenv; debug; delta_level; primitive_steps; strong; + memoize_lazy; normalize_pure_lets; reifying; + compat_memo_ignore_cfg;_} -> memoize_lazy +let (__proj__Mkcfg__item__normalize_pure_lets : cfg -> Prims.bool) = + fun projectee -> + match projectee with + | { steps; tcenv; debug; delta_level; primitive_steps; strong; + memoize_lazy; normalize_pure_lets; reifying; + compat_memo_ignore_cfg;_} -> normalize_pure_lets +let (__proj__Mkcfg__item__reifying : cfg -> Prims.bool) = + fun projectee -> + match projectee with + | { steps; tcenv; debug; delta_level; primitive_steps; strong; + memoize_lazy; normalize_pure_lets; reifying; + compat_memo_ignore_cfg;_} -> reifying +let (__proj__Mkcfg__item__compat_memo_ignore_cfg : cfg -> Prims.bool) = + fun projectee -> + match projectee with + | { steps; tcenv; debug; delta_level; primitive_steps; strong; + memoize_lazy; normalize_pure_lets; reifying; + compat_memo_ignore_cfg;_} -> compat_memo_ignore_cfg +type prim_step_set = + FStarC_TypeChecker_Primops_Base.primitive_step FStarC_Compiler_Util.psmap +let (empty_prim_steps : unit -> prim_step_set) = + fun uu___ -> FStarC_Compiler_Util.psmap_empty () +let (add_step : + FStarC_TypeChecker_Primops_Base.primitive_step -> + prim_step_set -> + FStarC_TypeChecker_Primops_Base.primitive_step + FStarC_Compiler_Util.psmap) + = + fun s -> + fun ss -> + let uu___ = + FStarC_Ident.string_of_lid s.FStarC_TypeChecker_Primops_Base.name in + FStarC_Compiler_Util.psmap_add ss uu___ s +let (merge_steps : prim_step_set -> prim_step_set -> prim_step_set) = + fun s1 -> fun s2 -> FStarC_Compiler_Util.psmap_merge s1 s2 +let (add_steps : + prim_step_set -> + FStarC_TypeChecker_Primops_Base.primitive_step Prims.list -> + prim_step_set) + = fun m -> fun l -> FStarC_Compiler_List.fold_right add_step l m +let (prim_from_list : + FStarC_TypeChecker_Primops_Base.primitive_step Prims.list -> prim_step_set) + = fun l -> let uu___ = empty_prim_steps () in add_steps uu___ l +let (built_in_primitive_steps : + FStarC_TypeChecker_Primops_Base.primitive_step FStarC_Compiler_Util.psmap) + = prim_from_list FStarC_TypeChecker_Primops.built_in_primitive_steps_list +let (env_dependent_ops : FStarC_TypeChecker_Env.env_t -> prim_step_set) = + fun env -> + let uu___ = FStarC_TypeChecker_Primops.env_dependent_ops env in + prim_from_list uu___ +let (simplification_steps : + FStarC_TypeChecker_Env.env_t -> + FStarC_TypeChecker_Primops_Base.primitive_step FStarC_Compiler_Util.psmap) + = + fun env -> + let uu___ = FStarC_TypeChecker_Primops.simplification_ops_list env in + prim_from_list uu___ +let (showable_cfg : cfg FStarC_Class_Show.showable) = + { + FStarC_Class_Show.show = + (fun cfg1 -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = steps_to_string cfg1.steps in + FStarC_Compiler_Util.format1 " steps = %s;" uu___3 in + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_TypeChecker_Env.showable_delta_level) + cfg1.delta_level in + FStarC_Compiler_Util.format1 " delta_level = %s;" uu___5 in + [uu___4; "}"] in + uu___2 :: uu___3 in + "{" :: uu___1 in + FStarC_Compiler_String.concat "\n" uu___) + } +let (cfg_env : cfg -> FStarC_TypeChecker_Env.env) = fun cfg1 -> cfg1.tcenv +let (find_prim_step : + cfg -> + FStarC_Syntax_Syntax.fv -> + FStarC_TypeChecker_Primops_Base.primitive_step + FStar_Pervasives_Native.option) + = + fun cfg1 -> + fun fv -> + let uu___ = + FStarC_Ident.string_of_lid + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + FStarC_Compiler_Util.psmap_try_find cfg1.primitive_steps uu___ +let (is_prim_step : cfg -> FStarC_Syntax_Syntax.fv -> Prims.bool) = + fun cfg1 -> + fun fv -> + let uu___ = + let uu___1 = + FStarC_Ident.string_of_lid + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + FStarC_Compiler_Util.psmap_try_find cfg1.primitive_steps uu___1 in + FStarC_Compiler_Util.is_some uu___ +let (log : cfg -> (unit -> unit) -> unit) = + fun cfg1 -> fun f -> if (cfg1.debug).gen then f () else () +let (log_top : cfg -> (unit -> unit) -> unit) = + fun cfg1 -> fun f -> if (cfg1.debug).top then f () else () +let (log_cfg : cfg -> (unit -> unit) -> unit) = + fun cfg1 -> fun f -> if (cfg1.debug).cfg then f () else () +let (log_primops : cfg -> (unit -> unit) -> unit) = + fun cfg1 -> fun f -> if (cfg1.debug).primop then f () else () +let (dbg_unfolding : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Unfolding" +let (log_unfolding : cfg -> (unit -> unit) -> unit) = + fun cfg1 -> + fun f -> + let uu___ = FStarC_Compiler_Effect.op_Bang dbg_unfolding in + if uu___ then f () else () +let (log_nbe : cfg -> (unit -> unit) -> unit) = + fun cfg1 -> fun f -> if (cfg1.debug).debug_nbe then f () else () +let (primop_time_map : Prims.int FStarC_Compiler_Util.smap) = + FStarC_Compiler_Util.smap_create (Prims.of_int (50)) +let (primop_time_reset : unit -> unit) = + fun uu___ -> FStarC_Compiler_Util.smap_clear primop_time_map +let (primop_time_count : Prims.string -> Prims.int -> unit) = + fun nm -> + fun ms -> + let uu___ = FStarC_Compiler_Util.smap_try_find primop_time_map nm in + match uu___ with + | FStar_Pervasives_Native.None -> + FStarC_Compiler_Util.smap_add primop_time_map nm ms + | FStar_Pervasives_Native.Some ms0 -> + FStarC_Compiler_Util.smap_add primop_time_map nm (ms0 + ms) +let (fixto : Prims.int -> Prims.string -> Prims.string) = + fun n -> + fun s -> + if (FStarC_Compiler_String.length s) < n + then + let uu___ = + FStarC_Compiler_String.make (n - (FStarC_Compiler_String.length s)) + 32 in + FStarC_Compiler_String.op_Hat uu___ s + else s +let (primop_time_report : unit -> Prims.string) = + fun uu___ -> + let pairs = + FStarC_Compiler_Util.smap_fold primop_time_map + (fun nm -> fun ms -> fun rest -> (nm, ms) :: rest) [] in + let pairs1 = + FStarC_Compiler_Util.sort_with + (fun uu___1 -> + fun uu___2 -> + match (uu___1, uu___2) with + | ((uu___3, t1), (uu___4, t2)) -> t1 - t2) pairs in + FStarC_Compiler_List.fold_right + (fun uu___1 -> + fun rest -> + match uu___1 with + | (nm, ms) -> + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Compiler_Util.string_of_int ms in + fixto (Prims.of_int (10)) uu___4 in + FStarC_Compiler_Util.format2 "%sms --- %s\n" uu___3 nm in + FStarC_Compiler_String.op_Hat uu___2 rest) pairs1 "" +let (extendable_primops_dirty : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref true +type register_prim_step_t = + FStarC_TypeChecker_Primops_Base.primitive_step -> unit +type retrieve_prim_step_t = unit -> prim_step_set +let (mk_extendable_primop_set : + unit -> (register_prim_step_t * retrieve_prim_step_t)) = + fun uu___ -> + let steps = + let uu___1 = empty_prim_steps () in FStarC_Compiler_Util.mk_ref uu___1 in + let register p = + FStarC_Compiler_Effect.op_Colon_Equals extendable_primops_dirty true; + (let uu___2 = + let uu___3 = FStarC_Compiler_Effect.op_Bang steps in + add_step p uu___3 in + FStarC_Compiler_Effect.op_Colon_Equals steps uu___2) in + let retrieve uu___1 = FStarC_Compiler_Effect.op_Bang steps in + (register, retrieve) +let (plugins : (register_prim_step_t * retrieve_prim_step_t)) = + mk_extendable_primop_set () +let (extra_steps : (register_prim_step_t * retrieve_prim_step_t)) = + mk_extendable_primop_set () +let (register_plugin : + FStarC_TypeChecker_Primops_Base.primitive_step -> unit) = + fun p -> FStar_Pervasives_Native.fst plugins p +let (retrieve_plugins : unit -> prim_step_set) = + fun uu___ -> + let uu___1 = FStarC_Options.no_plugins () in + if uu___1 + then empty_prim_steps () + else FStar_Pervasives_Native.snd plugins () +let (register_extra_step : + FStarC_TypeChecker_Primops_Base.primitive_step -> unit) = + fun p -> FStar_Pervasives_Native.fst extra_steps p +let (retrieve_extra_steps : unit -> prim_step_set) = + fun uu___ -> FStar_Pervasives_Native.snd extra_steps () +let (list_plugins : + unit -> FStarC_TypeChecker_Primops_Base.primitive_step Prims.list) = + fun uu___ -> + let uu___1 = retrieve_plugins () in FStarC_Common.psmap_values uu___1 +let (list_extra_steps : + unit -> FStarC_TypeChecker_Primops_Base.primitive_step Prims.list) = + fun uu___ -> + let uu___1 = retrieve_extra_steps () in FStarC_Common.psmap_values uu___1 +let (cached_steps : unit -> prim_step_set) = + let memo = + let uu___ = empty_prim_steps () in FStarC_Compiler_Util.mk_ref uu___ in + fun uu___ -> + let uu___1 = FStarC_Compiler_Effect.op_Bang extendable_primops_dirty in + if uu___1 + then + let steps = + let uu___2 = + let uu___3 = retrieve_plugins () in + let uu___4 = retrieve_extra_steps () in merge_steps uu___3 uu___4 in + merge_steps built_in_primitive_steps uu___2 in + (FStarC_Compiler_Effect.op_Colon_Equals memo steps; + FStarC_Compiler_Effect.op_Colon_Equals extendable_primops_dirty false; + steps) + else FStarC_Compiler_Effect.op_Bang memo +let (add_nbe : fsteps -> fsteps) = + fun s -> + let uu___ = FStarC_Options.use_nbe () in + if uu___ + then + { + beta = (s.beta); + iota = (s.iota); + zeta = (s.zeta); + zeta_full = (s.zeta_full); + weak = (s.weak); + hnf = (s.hnf); + primops = (s.primops); + do_not_unfold_pure_lets = (s.do_not_unfold_pure_lets); + unfold_until = (s.unfold_until); + unfold_only = (s.unfold_only); + unfold_fully = (s.unfold_fully); + unfold_attr = (s.unfold_attr); + unfold_qual = (s.unfold_qual); + unfold_namespace = (s.unfold_namespace); + dont_unfold_attr = (s.dont_unfold_attr); + pure_subterms_within_computations = + (s.pure_subterms_within_computations); + simplify = (s.simplify); + erase_universes = (s.erase_universes); + allow_unbound_universes = (s.allow_unbound_universes); + reify_ = (s.reify_); + compress_uvars = (s.compress_uvars); + no_full_norm = (s.no_full_norm); + check_no_uvars = (s.check_no_uvars); + unmeta = (s.unmeta); + unascribe = (s.unascribe); + in_full_norm_request = (s.in_full_norm_request); + weakly_reduce_scrutinee = (s.weakly_reduce_scrutinee); + nbe_step = true; + for_extraction = (s.for_extraction); + unrefine = (s.unrefine); + default_univs_to_zero = (s.default_univs_to_zero); + tactics = (s.tactics) + } + else s +let (dbg_Norm : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Norm" +let (dbg_NormTop : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "NormTop" +let (dbg_NormCfg : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "NormCfg" +let (dbg_Primops : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Primops" +let (dbg_Unfolding : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Unfolding" +let (dbg_380 : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "380" +let (dbg_WPE : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "WPE" +let (dbg_NormDelayed : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "NormDelayed" +let (dbg_print_normalized : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "print_normalized_terms" +let (dbg_NBE : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "NBE" +let (dbg_UNSOUND_EraseErasableArgs : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "UNSOUND_EraseErasableArgs" +let (config' : + FStarC_TypeChecker_Primops_Base.primitive_step Prims.list -> + FStarC_TypeChecker_Env.step Prims.list -> + FStarC_TypeChecker_Env.env -> cfg) + = + fun psteps -> + fun s -> + fun e -> + let d = + let uu___ = + FStarC_Compiler_List.collect + (fun uu___1 -> + match uu___1 with + | FStarC_TypeChecker_Env.UnfoldUntil k -> + [FStarC_TypeChecker_Env.Unfold k] + | FStarC_TypeChecker_Env.Eager_unfolding -> + [FStarC_TypeChecker_Env.Eager_unfolding_only] + | FStarC_TypeChecker_Env.UnfoldQual l when + FStarC_Compiler_List.contains "unfold" l -> + [FStarC_TypeChecker_Env.Eager_unfolding_only] + | FStarC_TypeChecker_Env.Inlining -> + [FStarC_TypeChecker_Env.InliningDelta] + | FStarC_TypeChecker_Env.UnfoldQual l when + FStarC_Compiler_List.contains "inline_for_extraction" l + -> [FStarC_TypeChecker_Env.InliningDelta] + | uu___2 -> []) s in + FStarC_Compiler_List.unique uu___ in + let d1 = + match d with | [] -> [FStarC_TypeChecker_Env.NoDelta] | uu___ -> d in + let steps = let uu___ = to_fsteps s in add_nbe uu___ in + let psteps1 = + let uu___ = + let uu___1 = env_dependent_ops e in + let uu___2 = cached_steps () in merge_steps uu___1 uu___2 in + add_steps uu___ psteps in + let dbg_flag = + FStarC_Compiler_List.contains FStarC_TypeChecker_Env.NormDebug s in + let uu___ = + let uu___1 = (FStarC_Compiler_Effect.op_Bang dbg_Norm) || dbg_flag in + let uu___2 = + (FStarC_Compiler_Effect.op_Bang dbg_NormTop) || dbg_flag in + let uu___3 = FStarC_Compiler_Effect.op_Bang dbg_NormCfg in + let uu___4 = FStarC_Compiler_Effect.op_Bang dbg_Primops in + let uu___5 = FStarC_Compiler_Effect.op_Bang dbg_Unfolding in + let uu___6 = FStarC_Compiler_Effect.op_Bang dbg_380 in + let uu___7 = FStarC_Compiler_Effect.op_Bang dbg_WPE in + let uu___8 = FStarC_Compiler_Effect.op_Bang dbg_NormDelayed in + let uu___9 = FStarC_Compiler_Effect.op_Bang dbg_print_normalized in + let uu___10 = FStarC_Compiler_Effect.op_Bang dbg_NBE in + let uu___11 = + (let uu___13 = + FStarC_Compiler_Effect.op_Bang dbg_UNSOUND_EraseErasableArgs in + if uu___13 + then + FStarC_Errors.log_issue FStarC_TypeChecker_Env.hasRange_env e + FStarC_Errors_Codes.Warning_WarnOnUse () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "The 'UNSOUND_EraseErasableArgs' setting is for debugging only; it is not sound") + else ()); + FStarC_Compiler_Effect.op_Bang dbg_UNSOUND_EraseErasableArgs in + { + gen = uu___1; + top = uu___2; + cfg = uu___3; + primop = uu___4; + unfolding = uu___5; + b380 = uu___6; + wpe = uu___7; + norm_delayed = uu___8; + print_normalized = uu___9; + debug_nbe = uu___10; + erase_erasable_args = uu___11 + } in + let uu___1 = + (Prims.op_Negation steps.pure_subterms_within_computations) || + (FStarC_Options.normalize_pure_terms_for_extraction ()) in + let uu___2 = + let uu___3 = + FStarC_Options_Ext.get "compat:normalizer_memo_ignore_cfg" in + uu___3 <> "" in + { + steps; + tcenv = e; + debug = uu___; + delta_level = d1; + primitive_steps = psteps1; + strong = false; + memoize_lazy = true; + normalize_pure_lets = uu___1; + reifying = false; + compat_memo_ignore_cfg = uu___2 + } +let (config : + FStarC_TypeChecker_Env.step Prims.list -> FStarC_TypeChecker_Env.env -> cfg) + = fun s -> fun e -> config' [] s e +let (should_reduce_local_let : + cfg -> FStarC_Syntax_Syntax.letbinding -> Prims.bool) = + fun cfg1 -> + fun lb -> + if (cfg1.steps).do_not_unfold_pure_lets + then false + else + (let uu___1 = + (cfg1.steps).pure_subterms_within_computations && + (FStarC_Syntax_Util.has_attribute + lb.FStarC_Syntax_Syntax.lbattrs + FStarC_Parser_Const.inline_let_attr) in + if uu___1 + then true + else + (let n = + FStarC_TypeChecker_Env.norm_eff_name cfg1.tcenv + lb.FStarC_Syntax_Syntax.lbeff in + let uu___3 = + (FStarC_Syntax_Util.is_pure_effect n) && + (cfg1.normalize_pure_lets || + (FStarC_Syntax_Util.has_attribute + lb.FStarC_Syntax_Syntax.lbattrs + FStarC_Parser_Const.inline_let_attr)) in + if uu___3 + then true + else + (FStarC_Syntax_Util.is_ghost_effect n) && + (Prims.op_Negation + (cfg1.steps).pure_subterms_within_computations))) +let (translate_norm_step : + FStar_Pervasives.norm_step -> FStarC_TypeChecker_Env.step Prims.list) = + fun uu___ -> + match uu___ with + | FStar_Pervasives.Zeta -> [FStarC_TypeChecker_Env.Zeta] + | FStar_Pervasives.ZetaFull -> [FStarC_TypeChecker_Env.ZetaFull] + | FStar_Pervasives.Iota -> [FStarC_TypeChecker_Env.Iota] + | FStar_Pervasives.Delta -> + [FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant] + | FStar_Pervasives.Simpl -> [FStarC_TypeChecker_Env.Simplify] + | FStar_Pervasives.Weak -> [FStarC_TypeChecker_Env.Weak] + | FStar_Pervasives.HNF -> [FStarC_TypeChecker_Env.HNF] + | FStar_Pervasives.Primops -> [FStarC_TypeChecker_Env.Primops] + | FStar_Pervasives.Reify -> [FStarC_TypeChecker_Env.Reify] + | FStar_Pervasives.NormDebug -> [FStarC_TypeChecker_Env.NormDebug] + | FStar_Pervasives.UnfoldOnly names -> + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Compiler_List.map FStarC_Ident.lid_of_str names in + FStarC_TypeChecker_Env.UnfoldOnly uu___3 in + [uu___2] in + (FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant) + :: uu___1 + | FStar_Pervasives.UnfoldFully names -> + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Compiler_List.map FStarC_Ident.lid_of_str names in + FStarC_TypeChecker_Env.UnfoldFully uu___3 in + [uu___2] in + (FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant) + :: uu___1 + | FStar_Pervasives.UnfoldAttr names -> + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Compiler_List.map FStarC_Ident.lid_of_str names in + FStarC_TypeChecker_Env.UnfoldAttr uu___3 in + [uu___2] in + (FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant) + :: uu___1 + | FStar_Pervasives.UnfoldQual names -> + [FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.UnfoldQual names] + | FStar_Pervasives.UnfoldNamespace names -> + [FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.UnfoldNamespace names] + | FStar_Pervasives.Unascribe -> [FStarC_TypeChecker_Env.Unascribe] + | FStar_Pervasives.NBE -> [FStarC_TypeChecker_Env.NBE] + | FStar_Pervasives.Unmeta -> [FStarC_TypeChecker_Env.Unmeta] +let (translate_norm_steps : + FStar_Pervasives.norm_step Prims.list -> + FStarC_TypeChecker_Env.step Prims.list) + = + fun s -> + let s1 = FStarC_Compiler_List.concatMap translate_norm_step s in + let add_exclude s2 z = + let uu___ = + FStarC_Compiler_Util.for_some + (FStarC_Class_Deq.op_Equals_Question + FStarC_TypeChecker_Env.deq_step z) s2 in + if uu___ then s2 else (FStarC_TypeChecker_Env.Exclude z) :: s2 in + let s2 = FStarC_TypeChecker_Env.Beta :: s1 in + let s3 = add_exclude s2 FStarC_TypeChecker_Env.Zeta in + let s4 = add_exclude s3 FStarC_TypeChecker_Env.Iota in s4 \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_Common.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Common.ml new file mode 100644 index 00000000000..a026e9a1cc7 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Common.ml @@ -0,0 +1,1006 @@ +open Prims +type rel = + | EQ + | SUB + | SUBINV +let (uu___is_EQ : rel -> Prims.bool) = + fun projectee -> match projectee with | EQ -> true | uu___ -> false +let (uu___is_SUB : rel -> Prims.bool) = + fun projectee -> match projectee with | SUB -> true | uu___ -> false +let (uu___is_SUBINV : rel -> Prims.bool) = + fun projectee -> match projectee with | SUBINV -> true | uu___ -> false +type rank_t = + | Rigid_rigid + | Flex_rigid_eq + | Flex_flex_pattern_eq + | Flex_rigid + | Rigid_flex + | Flex_flex +let (uu___is_Rigid_rigid : rank_t -> Prims.bool) = + fun projectee -> + match projectee with | Rigid_rigid -> true | uu___ -> false +let (uu___is_Flex_rigid_eq : rank_t -> Prims.bool) = + fun projectee -> + match projectee with | Flex_rigid_eq -> true | uu___ -> false +let (uu___is_Flex_flex_pattern_eq : rank_t -> Prims.bool) = + fun projectee -> + match projectee with | Flex_flex_pattern_eq -> true | uu___ -> false +let (uu___is_Flex_rigid : rank_t -> Prims.bool) = + fun projectee -> match projectee with | Flex_rigid -> true | uu___ -> false +let (uu___is_Rigid_flex : rank_t -> Prims.bool) = + fun projectee -> match projectee with | Rigid_flex -> true | uu___ -> false +let (uu___is_Flex_flex : rank_t -> Prims.bool) = + fun projectee -> match projectee with | Flex_flex -> true | uu___ -> false +type 'a problem = + { + pid: Prims.int ; + lhs: 'a ; + relation: rel ; + rhs: 'a ; + element: FStarC_Syntax_Syntax.bv FStar_Pervasives_Native.option ; + logical_guard: FStarC_Syntax_Syntax.term ; + logical_guard_uvar: FStarC_Syntax_Syntax.ctx_uvar ; + reason: Prims.string Prims.list ; + loc: FStarC_Compiler_Range_Type.range ; + rank: rank_t FStar_Pervasives_Native.option ; + logical: Prims.bool } +let __proj__Mkproblem__item__pid : 'a . 'a problem -> Prims.int = + fun projectee -> + match projectee with + | { pid; lhs; relation; rhs; element; logical_guard; logical_guard_uvar; + reason; loc; rank; logical;_} -> pid +let __proj__Mkproblem__item__lhs : 'a . 'a problem -> 'a = + fun projectee -> + match projectee with + | { pid; lhs; relation; rhs; element; logical_guard; logical_guard_uvar; + reason; loc; rank; logical;_} -> lhs +let __proj__Mkproblem__item__relation : 'a . 'a problem -> rel = + fun projectee -> + match projectee with + | { pid; lhs; relation; rhs; element; logical_guard; logical_guard_uvar; + reason; loc; rank; logical;_} -> relation +let __proj__Mkproblem__item__rhs : 'a . 'a problem -> 'a = + fun projectee -> + match projectee with + | { pid; lhs; relation; rhs; element; logical_guard; logical_guard_uvar; + reason; loc; rank; logical;_} -> rhs +let __proj__Mkproblem__item__element : + 'a . 'a problem -> FStarC_Syntax_Syntax.bv FStar_Pervasives_Native.option = + fun projectee -> + match projectee with + | { pid; lhs; relation; rhs; element; logical_guard; logical_guard_uvar; + reason; loc; rank; logical;_} -> element +let __proj__Mkproblem__item__logical_guard : + 'a . 'a problem -> FStarC_Syntax_Syntax.term = + fun projectee -> + match projectee with + | { pid; lhs; relation; rhs; element; logical_guard; logical_guard_uvar; + reason; loc; rank; logical;_} -> logical_guard +let __proj__Mkproblem__item__logical_guard_uvar : + 'a . 'a problem -> FStarC_Syntax_Syntax.ctx_uvar = + fun projectee -> + match projectee with + | { pid; lhs; relation; rhs; element; logical_guard; logical_guard_uvar; + reason; loc; rank; logical;_} -> logical_guard_uvar +let __proj__Mkproblem__item__reason : + 'a . 'a problem -> Prims.string Prims.list = + fun projectee -> + match projectee with + | { pid; lhs; relation; rhs; element; logical_guard; logical_guard_uvar; + reason; loc; rank; logical;_} -> reason +let __proj__Mkproblem__item__loc : + 'a . 'a problem -> FStarC_Compiler_Range_Type.range = + fun projectee -> + match projectee with + | { pid; lhs; relation; rhs; element; logical_guard; logical_guard_uvar; + reason; loc; rank; logical;_} -> loc +let __proj__Mkproblem__item__rank : + 'a . 'a problem -> rank_t FStar_Pervasives_Native.option = + fun projectee -> + match projectee with + | { pid; lhs; relation; rhs; element; logical_guard; logical_guard_uvar; + reason; loc; rank; logical;_} -> rank +let __proj__Mkproblem__item__logical : 'a . 'a problem -> Prims.bool = + fun projectee -> + match projectee with + | { pid; lhs; relation; rhs; element; logical_guard; logical_guard_uvar; + reason; loc; rank; logical;_} -> logical +type prob = + | TProb of FStarC_Syntax_Syntax.typ problem + | CProb of FStarC_Syntax_Syntax.comp problem +let (uu___is_TProb : prob -> Prims.bool) = + fun projectee -> match projectee with | TProb _0 -> true | uu___ -> false +let (__proj__TProb__item___0 : prob -> FStarC_Syntax_Syntax.typ problem) = + fun projectee -> match projectee with | TProb _0 -> _0 +let (uu___is_CProb : prob -> Prims.bool) = + fun projectee -> match projectee with | CProb _0 -> true | uu___ -> false +let (__proj__CProb__item___0 : prob -> FStarC_Syntax_Syntax.comp problem) = + fun projectee -> match projectee with | CProb _0 -> _0 +type prob_t = prob +let (as_tprob : prob -> FStarC_Syntax_Syntax.typ problem) = + fun uu___ -> + match uu___ with | TProb p -> p | uu___1 -> failwith "Expected a TProb" +type probs = prob Prims.list +type guard_formula = + | Trivial + | NonTrivial of FStarC_Syntax_Syntax.formula +let (uu___is_Trivial : guard_formula -> Prims.bool) = + fun projectee -> match projectee with | Trivial -> true | uu___ -> false +let (uu___is_NonTrivial : guard_formula -> Prims.bool) = + fun projectee -> + match projectee with | NonTrivial _0 -> true | uu___ -> false +let (__proj__NonTrivial__item___0 : + guard_formula -> FStarC_Syntax_Syntax.formula) = + fun projectee -> match projectee with | NonTrivial _0 -> _0 +let (mk_by_tactic : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun tac -> + fun f -> + let t_by_tactic = + let uu___ = + FStarC_Syntax_Syntax.tabbrev FStarC_Parser_Const.by_tactic_lid in + FStarC_Syntax_Syntax.mk_Tm_uinst uu___ [FStarC_Syntax_Syntax.U_zero] in + let uu___ = + let uu___1 = FStarC_Syntax_Syntax.as_arg tac in + let uu___2 = let uu___3 = FStarC_Syntax_Syntax.as_arg f in [uu___3] in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app t_by_tactic uu___ + FStarC_Compiler_Range_Type.dummyRange +let rec (delta_depth_greater_than : + FStarC_Syntax_Syntax.delta_depth -> + FStarC_Syntax_Syntax.delta_depth -> Prims.bool) + = + fun l -> + fun m -> + match (l, m) with + | (FStarC_Syntax_Syntax.Delta_equational_at_level i, + FStarC_Syntax_Syntax.Delta_equational_at_level j) -> i > j + | (FStarC_Syntax_Syntax.Delta_constant_at_level i, + FStarC_Syntax_Syntax.Delta_constant_at_level j) -> i > j + | (FStarC_Syntax_Syntax.Delta_abstract d, uu___) -> + delta_depth_greater_than d m + | (uu___, FStarC_Syntax_Syntax.Delta_abstract d) -> + delta_depth_greater_than l d + | (FStarC_Syntax_Syntax.Delta_equational_at_level uu___, uu___1) -> + true + | (uu___, FStarC_Syntax_Syntax.Delta_equational_at_level uu___1) -> + false +let rec (decr_delta_depth : + FStarC_Syntax_Syntax.delta_depth -> + FStarC_Syntax_Syntax.delta_depth FStar_Pervasives_Native.option) + = + fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.Delta_constant_at_level uu___1 when + uu___1 = Prims.int_zero -> FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Delta_equational_at_level uu___1 when + uu___1 = Prims.int_zero -> FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Delta_constant_at_level i -> + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Delta_constant_at_level (i - Prims.int_one)) + | FStarC_Syntax_Syntax.Delta_equational_at_level i -> + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Delta_equational_at_level (i - Prims.int_one)) + | FStarC_Syntax_Syntax.Delta_abstract d -> decr_delta_depth d +let (showable_guard_formula : guard_formula FStarC_Class_Show.showable) = + { + FStarC_Class_Show.show = + (fun uu___ -> + match uu___ with + | Trivial -> "Trivial" + | NonTrivial f -> + let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term f in + Prims.strcat "NonTrivial " uu___1) + } +type deferred_reason = + | Deferred_univ_constraint + | Deferred_occur_check_failed + | Deferred_first_order_heuristic_failed + | Deferred_flex + | Deferred_free_names_check_failed + | Deferred_not_a_pattern + | Deferred_flex_flex_nonpattern + | Deferred_delay_match_heuristic + | Deferred_to_user_tac +let (uu___is_Deferred_univ_constraint : deferred_reason -> Prims.bool) = + fun projectee -> + match projectee with | Deferred_univ_constraint -> true | uu___ -> false +let (uu___is_Deferred_occur_check_failed : deferred_reason -> Prims.bool) = + fun projectee -> + match projectee with + | Deferred_occur_check_failed -> true + | uu___ -> false +let (uu___is_Deferred_first_order_heuristic_failed : + deferred_reason -> Prims.bool) = + fun projectee -> + match projectee with + | Deferred_first_order_heuristic_failed -> true + | uu___ -> false +let (uu___is_Deferred_flex : deferred_reason -> Prims.bool) = + fun projectee -> + match projectee with | Deferred_flex -> true | uu___ -> false +let (uu___is_Deferred_free_names_check_failed : + deferred_reason -> Prims.bool) = + fun projectee -> + match projectee with + | Deferred_free_names_check_failed -> true + | uu___ -> false +let (uu___is_Deferred_not_a_pattern : deferred_reason -> Prims.bool) = + fun projectee -> + match projectee with | Deferred_not_a_pattern -> true | uu___ -> false +let (uu___is_Deferred_flex_flex_nonpattern : deferred_reason -> Prims.bool) = + fun projectee -> + match projectee with + | Deferred_flex_flex_nonpattern -> true + | uu___ -> false +let (uu___is_Deferred_delay_match_heuristic : deferred_reason -> Prims.bool) + = + fun projectee -> + match projectee with + | Deferred_delay_match_heuristic -> true + | uu___ -> false +let (uu___is_Deferred_to_user_tac : deferred_reason -> Prims.bool) = + fun projectee -> + match projectee with | Deferred_to_user_tac -> true | uu___ -> false +let (showable_deferred_reason : deferred_reason FStarC_Class_Show.showable) = + { + FStarC_Class_Show.show = + (fun uu___ -> + match uu___ with + | Deferred_univ_constraint -> "Deferred_univ_constraint" + | Deferred_occur_check_failed -> "Deferred_occur_check_failed" + | Deferred_first_order_heuristic_failed -> + "Deferred_first_order_heuristic_failed" + | Deferred_flex -> "Deferred_flex" + | Deferred_free_names_check_failed -> + "Deferred_free_names_check_failed" + | Deferred_not_a_pattern -> "Deferred_not_a_pattern" + | Deferred_flex_flex_nonpattern -> "Deferred_flex_flex_nonpattern" + | Deferred_delay_match_heuristic -> "Deferred_delay_match_heuristic" + | Deferred_to_user_tac -> "Deferred_to_user_tac") + } +type deferred = + (deferred_reason * Prims.string * prob) FStarC_Compiler_CList.clist +type univ_ineq = + (FStarC_Syntax_Syntax.universe * FStarC_Syntax_Syntax.universe) +type identifier_info = + { + identifier: + (FStarC_Syntax_Syntax.bv, FStarC_Syntax_Syntax.fv) + FStar_Pervasives.either + ; + identifier_ty: FStarC_Syntax_Syntax.typ ; + identifier_range: FStarC_Compiler_Range_Type.range } +let (__proj__Mkidentifier_info__item__identifier : + identifier_info -> + (FStarC_Syntax_Syntax.bv, FStarC_Syntax_Syntax.fv) + FStar_Pervasives.either) + = + fun projectee -> + match projectee with + | { identifier; identifier_ty; identifier_range;_} -> identifier +let (__proj__Mkidentifier_info__item__identifier_ty : + identifier_info -> FStarC_Syntax_Syntax.typ) = + fun projectee -> + match projectee with + | { identifier; identifier_ty; identifier_range;_} -> identifier_ty +let (__proj__Mkidentifier_info__item__identifier_range : + identifier_info -> FStarC_Compiler_Range_Type.range) = + fun projectee -> + match projectee with + | { identifier; identifier_ty; identifier_range;_} -> identifier_range +type id_info_by_col = (Prims.int * identifier_info) Prims.list +type col_info_by_row = id_info_by_col FStarC_Compiler_Util.pimap +type row_info_by_file = col_info_by_row FStarC_Compiler_Util.psmap +type id_info_table = + { + id_info_enabled: Prims.bool ; + id_info_db: row_info_by_file ; + id_info_buffer: identifier_info Prims.list } +let (__proj__Mkid_info_table__item__id_info_enabled : + id_info_table -> Prims.bool) = + fun projectee -> + match projectee with + | { id_info_enabled; id_info_db; id_info_buffer;_} -> id_info_enabled +let (__proj__Mkid_info_table__item__id_info_db : + id_info_table -> row_info_by_file) = + fun projectee -> + match projectee with + | { id_info_enabled; id_info_db; id_info_buffer;_} -> id_info_db +let (__proj__Mkid_info_table__item__id_info_buffer : + id_info_table -> identifier_info Prims.list) = + fun projectee -> + match projectee with + | { id_info_enabled; id_info_db; id_info_buffer;_} -> id_info_buffer +let (insert_col_info : + Prims.int -> + identifier_info -> + (Prims.int * identifier_info) Prims.list -> + (Prims.int * identifier_info) Prims.list) + = + fun col -> + fun info -> + fun col_infos -> + let rec __insert aux rest = + match rest with + | [] -> (aux, [(col, info)]) + | (c, i)::rest' -> + if col < c + then (aux, ((col, info) :: rest)) + else __insert ((c, i) :: aux) rest' in + let uu___ = __insert [] col_infos in + match uu___ with + | (l, r) -> FStarC_Compiler_List.op_At (FStarC_Compiler_List.rev l) r +let (find_nearest_preceding_col_info : + Prims.int -> + (Prims.int * identifier_info) Prims.list -> + identifier_info FStar_Pervasives_Native.option) + = + fun col -> + fun col_infos -> + let rec aux out uu___ = + match uu___ with + | [] -> out + | (c, i)::rest -> + if c > col + then out + else aux (FStar_Pervasives_Native.Some i) rest in + aux FStar_Pervasives_Native.None col_infos +let (id_info_table_empty : id_info_table) = + let uu___ = FStarC_Compiler_Util.psmap_empty () in + { id_info_enabled = false; id_info_db = uu___; id_info_buffer = [] } +let (print_identifier_info : identifier_info -> Prims.string) = + fun info -> + let uu___ = + FStarC_Compiler_Range_Ops.string_of_range info.identifier_range in + let uu___1 = + match info.identifier with + | FStar_Pervasives.Inl x -> + FStarC_Class_Show.show FStarC_Syntax_Print.showable_bv x + | FStar_Pervasives.Inr fv -> + FStarC_Class_Show.show FStarC_Syntax_Print.showable_fv fv in + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + info.identifier_ty in + FStarC_Compiler_Util.format3 "id info { %s, %s : %s}" uu___ uu___1 uu___2 +let (id_info__insert : + (FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.typ FStar_Pervasives_Native.option) + -> + (Prims.int * identifier_info) Prims.list FStarC_Compiler_Util.pimap + FStarC_Compiler_Util.psmap -> + identifier_info -> + (Prims.int * identifier_info) Prims.list FStarC_Compiler_Util.pimap + FStarC_Compiler_Util.psmap) + = + fun ty_map -> + fun db -> + fun info -> + let range = info.identifier_range in + let use_range = + let uu___ = FStarC_Compiler_Range_Type.use_range range in + FStarC_Compiler_Range_Type.set_def_range range uu___ in + let id_ty = + match info.identifier with + | FStar_Pervasives.Inr uu___ -> ty_map info.identifier_ty + | FStar_Pervasives.Inl x -> ty_map info.identifier_ty in + match id_ty with + | FStar_Pervasives_Native.None -> db + | FStar_Pervasives_Native.Some id_ty1 -> + let info1 = + { + identifier = (info.identifier); + identifier_ty = id_ty1; + identifier_range = use_range + } in + let fn = FStarC_Compiler_Range_Ops.file_of_range use_range in + let start = FStarC_Compiler_Range_Ops.start_of_range use_range in + let uu___ = + let uu___1 = FStarC_Compiler_Range_Ops.line_of_pos start in + let uu___2 = FStarC_Compiler_Range_Ops.col_of_pos start in + (uu___1, uu___2) in + (match uu___ with + | (row, col) -> + let rows = + let uu___1 = FStarC_Compiler_Util.pimap_empty () in + FStarC_Compiler_Util.psmap_find_default db fn uu___1 in + let cols = + FStarC_Compiler_Util.pimap_find_default rows row [] in + let uu___1 = + let uu___2 = insert_col_info col info1 cols in + FStarC_Compiler_Util.pimap_add rows row uu___2 in + FStarC_Compiler_Util.psmap_add db fn uu___1) +let (id_info_insert : + id_info_table -> + (FStarC_Syntax_Syntax.bv, FStarC_Syntax_Syntax.fv) + FStar_Pervasives.either -> + FStarC_Syntax_Syntax.typ -> + FStarC_Compiler_Range_Type.range -> id_info_table) + = + fun table -> + fun id -> + fun ty -> + fun range -> + let info = + { identifier = id; identifier_ty = ty; identifier_range = range } in + { + id_info_enabled = (table.id_info_enabled); + id_info_db = (table.id_info_db); + id_info_buffer = (info :: (table.id_info_buffer)) + } +let (id_info_insert_bv : + id_info_table -> + FStarC_Syntax_Syntax.bv -> FStarC_Syntax_Syntax.typ -> id_info_table) + = + fun table -> + fun bv -> + fun ty -> + if table.id_info_enabled + then + let uu___ = FStarC_Syntax_Syntax.range_of_bv bv in + id_info_insert table (FStar_Pervasives.Inl bv) ty uu___ + else table +let (id_info_insert_fv : + id_info_table -> + FStarC_Syntax_Syntax.fv -> FStarC_Syntax_Syntax.typ -> id_info_table) + = + fun table -> + fun fv -> + fun ty -> + if table.id_info_enabled + then + let uu___ = FStarC_Syntax_Syntax.range_of_fv fv in + id_info_insert table (FStar_Pervasives.Inr fv) ty uu___ + else table +let (id_info_toggle : id_info_table -> Prims.bool -> id_info_table) = + fun table -> + fun enabled -> + { + id_info_enabled = enabled; + id_info_db = (table.id_info_db); + id_info_buffer = (table.id_info_buffer) + } +let (id_info_promote : + id_info_table -> + (FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.typ FStar_Pervasives_Native.option) + -> id_info_table) + = + fun table -> + fun ty_map -> + let uu___ = + FStarC_Compiler_List.fold_left (id_info__insert ty_map) + table.id_info_db table.id_info_buffer in + { + id_info_enabled = (table.id_info_enabled); + id_info_db = uu___; + id_info_buffer = [] + } +let (id_info_at_pos : + id_info_table -> + Prims.string -> + Prims.int -> + Prims.int -> identifier_info FStar_Pervasives_Native.option) + = + fun table -> + fun fn -> + fun row -> + fun col -> + let rows = + let uu___ = FStarC_Compiler_Util.pimap_empty () in + FStarC_Compiler_Util.psmap_find_default table.id_info_db fn uu___ in + let cols = FStarC_Compiler_Util.pimap_find_default rows row [] in + let uu___ = find_nearest_preceding_col_info col cols in + match uu___ with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some info -> + let last_col = + let uu___1 = + FStarC_Compiler_Range_Ops.end_of_range + info.identifier_range in + FStarC_Compiler_Range_Ops.col_of_pos uu___1 in + if col <= last_col + then FStar_Pervasives_Native.Some info + else FStar_Pervasives_Native.None +let (check_uvar_ctx_invariant : + Prims.string -> + FStarC_Compiler_Range_Type.range -> + Prims.bool -> + FStarC_Syntax_Syntax.gamma -> FStarC_Syntax_Syntax.binders -> unit) + = + fun reason -> + fun r -> + fun should_check -> + fun g -> + fun bs -> + let fail uu___ = + let uu___1 = + let uu___2 = FStarC_Compiler_Range_Ops.string_of_range r in + let uu___3 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binding) g in + let uu___4 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binder) bs in + FStarC_Compiler_Util.format5 + "Invariant violation: gamma and binders are out of sync\n\treason=%s, range=%s, should_check=%s\n\t\n gamma=%s\n\tbinders=%s\n" + reason uu___2 (if should_check then "true" else "false") + uu___3 uu___4 in + failwith uu___1 in + if Prims.op_Negation should_check + then () + else + (let uu___1 = + let uu___2 = + FStarC_Compiler_Util.prefix_until + (fun uu___3 -> + match uu___3 with + | FStarC_Syntax_Syntax.Binding_var uu___4 -> true + | uu___4 -> false) g in + (uu___2, bs) in + match uu___1 with + | (FStar_Pervasives_Native.None, []) -> () + | (FStar_Pervasives_Native.Some (uu___2, hd, gamma_tail), + uu___3::uu___4) -> + let uu___5 = FStarC_Compiler_Util.prefix bs in + (match uu___5 with + | (uu___6, x) -> + (match hd with + | FStarC_Syntax_Syntax.Binding_var x' when + FStarC_Syntax_Syntax.bv_eq + x.FStarC_Syntax_Syntax.binder_bv x' + -> () + | uu___7 -> fail ())) + | uu___2 -> fail ()) +type implicit = + { + imp_reason: Prims.string ; + imp_uvar: FStarC_Syntax_Syntax.ctx_uvar ; + imp_tm: FStarC_Syntax_Syntax.term ; + imp_range: FStarC_Compiler_Range_Type.range } +let (__proj__Mkimplicit__item__imp_reason : implicit -> Prims.string) = + fun projectee -> + match projectee with + | { imp_reason; imp_uvar; imp_tm; imp_range;_} -> imp_reason +let (__proj__Mkimplicit__item__imp_uvar : + implicit -> FStarC_Syntax_Syntax.ctx_uvar) = + fun projectee -> + match projectee with + | { imp_reason; imp_uvar; imp_tm; imp_range;_} -> imp_uvar +let (__proj__Mkimplicit__item__imp_tm : + implicit -> FStarC_Syntax_Syntax.term) = + fun projectee -> + match projectee with + | { imp_reason; imp_uvar; imp_tm; imp_range;_} -> imp_tm +let (__proj__Mkimplicit__item__imp_range : + implicit -> FStarC_Compiler_Range_Type.range) = + fun projectee -> + match projectee with + | { imp_reason; imp_uvar; imp_tm; imp_range;_} -> imp_range +let (showable_implicit : implicit FStarC_Class_Show.showable) = + { + FStarC_Class_Show.show = + (fun i -> + FStarC_Class_Show.show FStarC_Syntax_Print.showable_uvar + (i.imp_uvar).FStarC_Syntax_Syntax.ctx_uvar_head) + } +type implicits = implicit Prims.list +let (implicits_to_string : implicits -> Prims.string) = + fun imps -> + let imp_to_string i = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_uvar + (i.imp_uvar).FStarC_Syntax_Syntax.ctx_uvar_head in + (FStarC_Common.string_of_list ()) imp_to_string imps +type implicits_t = implicit FStarC_Compiler_CList.t +type guard_t = + { + guard_f: guard_formula ; + deferred_to_tac: deferred ; + deferred: deferred ; + univ_ineqs: + (FStarC_Syntax_Syntax.universe FStarC_Compiler_CList.clist * univ_ineq + FStarC_Compiler_CList.clist) + ; + implicits: implicits_t } +let (__proj__Mkguard_t__item__guard_f : guard_t -> guard_formula) = + fun projectee -> + match projectee with + | { guard_f; deferred_to_tac; deferred = deferred1; univ_ineqs; + implicits = implicits1;_} -> guard_f +let (__proj__Mkguard_t__item__deferred_to_tac : guard_t -> deferred) = + fun projectee -> + match projectee with + | { guard_f; deferred_to_tac; deferred = deferred1; univ_ineqs; + implicits = implicits1;_} -> deferred_to_tac +let (__proj__Mkguard_t__item__deferred : guard_t -> deferred) = + fun projectee -> + match projectee with + | { guard_f; deferred_to_tac; deferred = deferred1; univ_ineqs; + implicits = implicits1;_} -> deferred1 +let (__proj__Mkguard_t__item__univ_ineqs : + guard_t -> + (FStarC_Syntax_Syntax.universe FStarC_Compiler_CList.clist * univ_ineq + FStarC_Compiler_CList.clist)) + = + fun projectee -> + match projectee with + | { guard_f; deferred_to_tac; deferred = deferred1; univ_ineqs; + implicits = implicits1;_} -> univ_ineqs +let (__proj__Mkguard_t__item__implicits : guard_t -> implicits_t) = + fun projectee -> + match projectee with + | { guard_f; deferred_to_tac; deferred = deferred1; univ_ineqs; + implicits = implicits1;_} -> implicits1 +let (trivial_guard : guard_t) = + { + guard_f = Trivial; + deferred_to_tac = + (Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic (FStarC_Compiler_CList.listlike_clist ())))); + deferred = + (Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic (FStarC_Compiler_CList.listlike_clist ())))); + univ_ineqs = + ((Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic (FStarC_Compiler_CList.listlike_clist ())))), + (Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic (FStarC_Compiler_CList.listlike_clist ()))))); + implicits = + (Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic (FStarC_Compiler_CList.listlike_clist ())))) + } +let (conj_guard_f : guard_formula -> guard_formula -> guard_formula) = + fun g1 -> + fun g2 -> + match (g1, g2) with + | (Trivial, g) -> g + | (g, Trivial) -> g + | (NonTrivial f1, NonTrivial f2) -> + let uu___ = FStarC_Syntax_Util.mk_conj f1 f2 in NonTrivial uu___ +let (binop_guard : + (guard_formula -> guard_formula -> guard_formula) -> + guard_t -> guard_t -> guard_t) + = + fun f -> + fun g1 -> + fun g2 -> + let uu___ = f g1.guard_f g2.guard_f in + let uu___1 = + FStarC_Class_Monoid.op_Plus_Plus + (FStarC_Compiler_CList.monoid_clist ()) g1.deferred_to_tac + g2.deferred_to_tac in + let uu___2 = + FStarC_Class_Monoid.op_Plus_Plus + (FStarC_Compiler_CList.monoid_clist ()) g1.deferred g2.deferred in + let uu___3 = + let uu___4 = + FStarC_Class_Monoid.op_Plus_Plus + (FStarC_Compiler_CList.monoid_clist ()) + (FStar_Pervasives_Native.fst g1.univ_ineqs) + (FStar_Pervasives_Native.fst g2.univ_ineqs) in + let uu___5 = + FStarC_Class_Monoid.op_Plus_Plus + (FStarC_Compiler_CList.monoid_clist ()) + (FStar_Pervasives_Native.snd g1.univ_ineqs) + (FStar_Pervasives_Native.snd g2.univ_ineqs) in + (uu___4, uu___5) in + let uu___4 = + FStarC_Class_Monoid.op_Plus_Plus + (FStarC_Compiler_CList.monoid_clist ()) g1.implicits g2.implicits in + { + guard_f = uu___; + deferred_to_tac = uu___1; + deferred = uu___2; + univ_ineqs = uu___3; + implicits = uu___4 + } +let (conj_guard : guard_t -> guard_t -> guard_t) = + fun g1 -> fun g2 -> binop_guard conj_guard_f g1 g2 +let (monoid_guard_t : guard_t FStarC_Class_Monoid.monoid) = + { + FStarC_Class_Monoid.mzero = trivial_guard; + FStarC_Class_Monoid.mplus = conj_guard + } +let rec (check_trivial : FStarC_Syntax_Syntax.term -> guard_formula) = + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Util.unmeta t in + FStarC_Syntax_Util.head_and_args uu___1 in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Util.unmeta hd in + FStarC_Syntax_Util.un_uinst uu___4 in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar tc, []) when + FStarC_Syntax_Syntax.fv_eq_lid tc FStarC_Parser_Const.true_lid + -> Trivial + | (FStarC_Syntax_Syntax.Tm_fvar sq, (v, uu___2)::[]) when + (FStarC_Syntax_Syntax.fv_eq_lid sq + FStarC_Parser_Const.squash_lid) + || + (FStarC_Syntax_Syntax.fv_eq_lid sq + FStarC_Parser_Const.auto_squash_lid) + -> + let uu___3 = check_trivial v in + (match uu___3 with | Trivial -> Trivial | uu___4 -> NonTrivial t) + | uu___2 -> NonTrivial t) +let (imp_guard_f : guard_formula -> guard_formula -> guard_formula) = + fun g1 -> + fun g2 -> + match (g1, g2) with + | (Trivial, g) -> g + | (g, Trivial) -> Trivial + | (NonTrivial f1, NonTrivial f2) -> + let imp = FStarC_Syntax_Util.mk_imp f1 f2 in check_trivial imp +let (imp_guard : guard_t -> guard_t -> guard_t) = + fun g1 -> fun g2 -> binop_guard imp_guard_f g1 g2 +let (conj_guards : guard_t Prims.list -> guard_t) = + fun gs -> FStarC_Compiler_List.fold_left conj_guard trivial_guard gs +let (split_guard : guard_t -> (guard_t * guard_t)) = + fun g -> + ({ + guard_f = Trivial; + deferred_to_tac = (g.deferred_to_tac); + deferred = (g.deferred); + univ_ineqs = (g.univ_ineqs); + implicits = (g.implicits) + }, + { + guard_f = (g.guard_f); + deferred_to_tac = (trivial_guard.deferred_to_tac); + deferred = (trivial_guard.deferred); + univ_ineqs = (trivial_guard.univ_ineqs); + implicits = (trivial_guard.implicits) + }) +let (weaken_guard_formula : guard_t -> FStarC_Syntax_Syntax.typ -> guard_t) = + fun g -> + fun fml -> + match g.guard_f with + | Trivial -> g + | NonTrivial f -> + let uu___ = + let uu___1 = FStarC_Syntax_Util.mk_imp fml f in + check_trivial uu___1 in + { + guard_f = uu___; + deferred_to_tac = (g.deferred_to_tac); + deferred = (g.deferred); + univ_ineqs = (g.univ_ineqs); + implicits = (g.implicits) + } +type lcomp = + { + eff_name: FStarC_Ident.lident ; + res_typ: FStarC_Syntax_Syntax.typ ; + cflags: FStarC_Syntax_Syntax.cflag Prims.list ; + comp_thunk: + (unit -> (FStarC_Syntax_Syntax.comp * guard_t), + FStarC_Syntax_Syntax.comp) FStar_Pervasives.either + FStarC_Compiler_Effect.ref + } +let (__proj__Mklcomp__item__eff_name : lcomp -> FStarC_Ident.lident) = + fun projectee -> + match projectee with + | { eff_name; res_typ; cflags; comp_thunk;_} -> eff_name +let (__proj__Mklcomp__item__res_typ : lcomp -> FStarC_Syntax_Syntax.typ) = + fun projectee -> + match projectee with + | { eff_name; res_typ; cflags; comp_thunk;_} -> res_typ +let (__proj__Mklcomp__item__cflags : + lcomp -> FStarC_Syntax_Syntax.cflag Prims.list) = + fun projectee -> + match projectee with + | { eff_name; res_typ; cflags; comp_thunk;_} -> cflags +let (__proj__Mklcomp__item__comp_thunk : + lcomp -> + (unit -> (FStarC_Syntax_Syntax.comp * guard_t), + FStarC_Syntax_Syntax.comp) FStar_Pervasives.either + FStarC_Compiler_Effect.ref) + = + fun projectee -> + match projectee with + | { eff_name; res_typ; cflags; comp_thunk;_} -> comp_thunk +let (mk_lcomp : + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.cflag Prims.list -> + (unit -> (FStarC_Syntax_Syntax.comp * guard_t)) -> lcomp) + = + fun eff_name -> + fun res_typ -> + fun cflags -> + fun comp_thunk -> + let uu___ = + FStarC_Compiler_Util.mk_ref (FStar_Pervasives.Inl comp_thunk) in + { eff_name; res_typ; cflags; comp_thunk = uu___ } +let (lcomp_comp : lcomp -> (FStarC_Syntax_Syntax.comp * guard_t)) = + fun lc -> + let uu___ = FStarC_Compiler_Effect.op_Bang lc.comp_thunk in + match uu___ with + | FStar_Pervasives.Inl thunk -> + let uu___1 = thunk () in + (match uu___1 with + | (c, g) -> + (FStarC_Compiler_Effect.op_Colon_Equals lc.comp_thunk + (FStar_Pervasives.Inr c); + (c, g))) + | FStar_Pervasives.Inr c -> (c, trivial_guard) +let (apply_lcomp : + (FStarC_Syntax_Syntax.comp -> FStarC_Syntax_Syntax.comp) -> + (guard_t -> guard_t) -> lcomp -> lcomp) + = + fun fc -> + fun fg -> + fun lc -> + mk_lcomp lc.eff_name lc.res_typ lc.cflags + (fun uu___ -> + let uu___1 = lcomp_comp lc in + match uu___1 with + | (c, g) -> + let uu___2 = fc c in let uu___3 = fg g in (uu___2, uu___3)) +let (lcomp_to_string : lcomp -> Prims.string) = + fun lc -> + let uu___ = FStarC_Options.print_effect_args () in + if uu___ + then + let uu___1 = + let uu___2 = lcomp_comp lc in FStar_Pervasives_Native.fst uu___2 in + FStarC_Class_Show.show FStarC_Syntax_Print.showable_comp uu___1 + else + (let uu___2 = + FStarC_Class_Show.show FStarC_Ident.showable_lident lc.eff_name in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term lc.res_typ in + FStarC_Compiler_Util.format2 "%s %s" uu___2 uu___3) +let (lcomp_set_flags : + lcomp -> FStarC_Syntax_Syntax.cflag Prims.list -> lcomp) = + fun lc -> + fun fs -> + let comp_typ_set_flags c = + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total uu___ -> c + | FStarC_Syntax_Syntax.GTotal uu___ -> c + | FStarC_Syntax_Syntax.Comp ct -> + let ct1 = + { + FStarC_Syntax_Syntax.comp_univs = + (ct.FStarC_Syntax_Syntax.comp_univs); + FStarC_Syntax_Syntax.effect_name = + (ct.FStarC_Syntax_Syntax.effect_name); + FStarC_Syntax_Syntax.result_typ = + (ct.FStarC_Syntax_Syntax.result_typ); + FStarC_Syntax_Syntax.effect_args = + (ct.FStarC_Syntax_Syntax.effect_args); + FStarC_Syntax_Syntax.flags = fs + } in + { + FStarC_Syntax_Syntax.n = (FStarC_Syntax_Syntax.Comp ct1); + FStarC_Syntax_Syntax.pos = (c.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = (c.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (c.FStarC_Syntax_Syntax.hash_code) + } in + mk_lcomp lc.eff_name lc.res_typ fs + (fun uu___ -> + let uu___1 = lcomp_comp lc in + match uu___1 with | (c, g) -> ((comp_typ_set_flags c), g)) +let (is_total_lcomp : lcomp -> Prims.bool) = + fun c -> + (FStarC_Ident.lid_equals c.eff_name FStarC_Parser_Const.effect_Tot_lid) + || + (FStarC_Compiler_Util.for_some + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.TOTAL -> true + | FStarC_Syntax_Syntax.RETURN -> true + | uu___1 -> false) c.cflags) +let (is_tot_or_gtot_lcomp : lcomp -> Prims.bool) = + fun c -> + ((FStarC_Ident.lid_equals c.eff_name FStarC_Parser_Const.effect_Tot_lid) + || + (FStarC_Ident.lid_equals c.eff_name + FStarC_Parser_Const.effect_GTot_lid)) + || + (FStarC_Compiler_Util.for_some + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.TOTAL -> true + | FStarC_Syntax_Syntax.RETURN -> true + | uu___1 -> false) c.cflags) +let (is_lcomp_partial_return : lcomp -> Prims.bool) = + fun c -> + FStarC_Compiler_Util.for_some + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.RETURN -> true + | FStarC_Syntax_Syntax.PARTIAL_RETURN -> true + | uu___1 -> false) c.cflags +let (is_pure_lcomp : lcomp -> Prims.bool) = + fun lc -> + ((is_total_lcomp lc) || (FStarC_Syntax_Util.is_pure_effect lc.eff_name)) + || + (FStarC_Compiler_Util.for_some + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.LEMMA -> true + | uu___1 -> false) lc.cflags) +let (is_pure_or_ghost_lcomp : lcomp -> Prims.bool) = + fun lc -> + (is_pure_lcomp lc) || (FStarC_Syntax_Util.is_ghost_effect lc.eff_name) +let (set_result_typ_lc : lcomp -> FStarC_Syntax_Syntax.typ -> lcomp) = + fun lc -> + fun t -> + mk_lcomp lc.eff_name t lc.cflags + (fun uu___ -> + let uu___1 = lcomp_comp lc in + match uu___1 with + | (c, g) -> + let uu___2 = FStarC_Syntax_Util.set_result_typ c t in + (uu___2, g)) +let (residual_comp_of_lcomp : lcomp -> FStarC_Syntax_Syntax.residual_comp) = + fun lc -> + { + FStarC_Syntax_Syntax.residual_effect = (lc.eff_name); + FStarC_Syntax_Syntax.residual_typ = + (FStar_Pervasives_Native.Some (lc.res_typ)); + FStarC_Syntax_Syntax.residual_flags = (lc.cflags) + } +let (lcomp_of_comp_guard : FStarC_Syntax_Syntax.comp -> guard_t -> lcomp) = + fun c0 -> + fun g -> + let uu___ = + match c0.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total uu___1 -> + (FStarC_Parser_Const.effect_Tot_lid, + [FStarC_Syntax_Syntax.TOTAL]) + | FStarC_Syntax_Syntax.GTotal uu___1 -> + (FStarC_Parser_Const.effect_GTot_lid, + [FStarC_Syntax_Syntax.SOMETRIVIAL]) + | FStarC_Syntax_Syntax.Comp c -> + ((c.FStarC_Syntax_Syntax.effect_name), + (c.FStarC_Syntax_Syntax.flags)) in + match uu___ with + | (eff_name, flags) -> + mk_lcomp eff_name (FStarC_Syntax_Util.comp_result c0) flags + (fun uu___1 -> (c0, g)) +let (lcomp_of_comp : FStarC_Syntax_Syntax.comp -> lcomp) = + fun c0 -> lcomp_of_comp_guard c0 trivial_guard +let (check_positivity_qual : + Prims.bool -> + FStarC_Syntax_Syntax.positivity_qualifier FStar_Pervasives_Native.option + -> + FStarC_Syntax_Syntax.positivity_qualifier + FStar_Pervasives_Native.option -> Prims.bool) + = + fun subtyping -> + fun p0 -> + fun p1 -> + if p0 = p1 + then true + else + if subtyping + then + (match (p0, p1) with + | (FStar_Pervasives_Native.Some uu___1, + FStar_Pervasives_Native.None) -> true + | (FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.BinderUnused), + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.BinderStrictlyPositive)) -> true + | uu___1 -> false) + else false \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_Core.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Core.ml new file mode 100644 index 00000000000..3a244f47e12 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Core.ml @@ -0,0 +1,8280 @@ +open Prims +type tot_or_ghost = + | E_Total + | E_Ghost +let (uu___is_E_Total : tot_or_ghost -> Prims.bool) = + fun projectee -> match projectee with | E_Total -> true | uu___ -> false +let (uu___is_E_Ghost : tot_or_ghost -> Prims.bool) = + fun projectee -> match projectee with | E_Ghost -> true | uu___ -> false +let (dbg : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Core" +let (dbg_Eq : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "CoreEq" +let (dbg_Top : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "CoreTop" +let (dbg_Exit : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "CoreExit" +let (goal_ctr : Prims.int FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref Prims.int_zero +let (get_goal_ctr : unit -> Prims.int) = + fun uu___ -> FStarC_Compiler_Effect.op_Bang goal_ctr +let (incr_goal_ctr : unit -> Prims.int) = + fun uu___ -> + let v = FStarC_Compiler_Effect.op_Bang goal_ctr in + FStarC_Compiler_Effect.op_Colon_Equals goal_ctr (v + Prims.int_one); + v + Prims.int_one +type guard_handler_t = + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.typ -> Prims.bool +type env = + { + tcenv: FStarC_TypeChecker_Env.env ; + allow_universe_instantiation: Prims.bool ; + max_binder_index: Prims.int ; + guard_handler: guard_handler_t FStar_Pervasives_Native.option ; + should_read_cache: Prims.bool } +let (__proj__Mkenv__item__tcenv : env -> FStarC_TypeChecker_Env.env) = + fun projectee -> + match projectee with + | { tcenv; allow_universe_instantiation; max_binder_index; guard_handler; + should_read_cache;_} -> tcenv +let (__proj__Mkenv__item__allow_universe_instantiation : env -> Prims.bool) = + fun projectee -> + match projectee with + | { tcenv; allow_universe_instantiation; max_binder_index; guard_handler; + should_read_cache;_} -> allow_universe_instantiation +let (__proj__Mkenv__item__max_binder_index : env -> Prims.int) = + fun projectee -> + match projectee with + | { tcenv; allow_universe_instantiation; max_binder_index; guard_handler; + should_read_cache;_} -> max_binder_index +let (__proj__Mkenv__item__guard_handler : + env -> guard_handler_t FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { tcenv; allow_universe_instantiation; max_binder_index; guard_handler; + should_read_cache;_} -> guard_handler +let (__proj__Mkenv__item__should_read_cache : env -> Prims.bool) = + fun projectee -> + match projectee with + | { tcenv; allow_universe_instantiation; max_binder_index; guard_handler; + should_read_cache;_} -> should_read_cache +let (push_binder : env -> FStarC_Syntax_Syntax.binder -> env) = + fun g -> + fun b -> + if + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.index <= + g.max_binder_index + then + failwith + "Assertion failed: unexpected shadowing in the core environment" + else + (let uu___1 = FStarC_TypeChecker_Env.push_binders g.tcenv [b] in + { + tcenv = uu___1; + allow_universe_instantiation = (g.allow_universe_instantiation); + max_binder_index = + ((b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.index); + guard_handler = (g.guard_handler); + should_read_cache = (g.should_read_cache) + }) +let (push_binders : env -> FStarC_Syntax_Syntax.binder Prims.list -> env) = + FStarC_Compiler_List.fold_left push_binder +let (fresh_binder : + env -> FStarC_Syntax_Syntax.binder -> (env * FStarC_Syntax_Syntax.binder)) + = + fun g -> + fun old -> + let ctr = g.max_binder_index + Prims.int_one in + let bv = + let uu___ = old.FStarC_Syntax_Syntax.binder_bv in + { + FStarC_Syntax_Syntax.ppname = (uu___.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = ctr; + FStarC_Syntax_Syntax.sort = (uu___.FStarC_Syntax_Syntax.sort) + } in + let b = + FStarC_Syntax_Syntax.mk_binder_with_attrs bv + old.FStarC_Syntax_Syntax.binder_qual + old.FStarC_Syntax_Syntax.binder_positivity + old.FStarC_Syntax_Syntax.binder_attrs in + let uu___ = push_binder g b in (uu___, b) +let (open_binders : + env -> + FStarC_Syntax_Syntax.binders -> + (env * FStarC_Syntax_Syntax.binder Prims.list * + FStarC_Syntax_Syntax.subst_elt Prims.list)) + = + fun g -> + fun bs -> + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun b -> + match uu___1 with + | (g1, bs1, subst) -> + let bv = + let uu___2 = b.FStarC_Syntax_Syntax.binder_bv in + let uu___3 = + FStarC_Syntax_Subst.subst subst + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + { + FStarC_Syntax_Syntax.ppname = + (uu___2.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (uu___2.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = uu___3 + } in + let b1 = + let uu___2 = + FStarC_Syntax_Subst.subst_bqual subst + b.FStarC_Syntax_Syntax.binder_qual in + let uu___3 = + FStarC_Compiler_List.map + (FStarC_Syntax_Subst.subst subst) + b.FStarC_Syntax_Syntax.binder_attrs in + { + FStarC_Syntax_Syntax.binder_bv = bv; + FStarC_Syntax_Syntax.binder_qual = uu___2; + FStarC_Syntax_Syntax.binder_positivity = + (b.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs = uu___3 + } in + let uu___2 = fresh_binder g1 b1 in + (match uu___2 with + | (g2, b') -> + let uu___3 = + let uu___4 = + FStarC_Syntax_Subst.shift_subst Prims.int_one + subst in + (FStarC_Syntax_Syntax.DB + (Prims.int_zero, + (b'.FStarC_Syntax_Syntax.binder_bv))) + :: uu___4 in + (g2, (b' :: bs1), uu___3))) (g, [], []) bs in + match uu___ with + | (g1, bs_rev, subst) -> (g1, (FStarC_Compiler_List.rev bs_rev), subst) +let (open_pat : + env -> + FStarC_Syntax_Syntax.pat -> + (env * FStarC_Syntax_Syntax.pat * FStarC_Syntax_Syntax.subst_t)) + = + fun g -> + fun p -> + let rec open_pat_aux g1 p1 sub = + match p1.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_constant uu___ -> (g1, p1, sub) + | FStarC_Syntax_Syntax.Pat_cons (fv, us_opt, pats) -> + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun uu___2 -> + match (uu___1, uu___2) with + | ((g2, pats1, sub1), (p2, imp)) -> + let uu___3 = open_pat_aux g2 p2 sub1 in + (match uu___3 with + | (g3, p3, sub2) -> + (g3, ((p3, imp) :: pats1), sub2))) + (g1, [], sub) pats in + (match uu___ with + | (g2, pats1, sub1) -> + (g2, + { + FStarC_Syntax_Syntax.v = + (FStarC_Syntax_Syntax.Pat_cons + (fv, us_opt, (FStarC_Compiler_List.rev pats1))); + FStarC_Syntax_Syntax.p = (p1.FStarC_Syntax_Syntax.p) + }, sub1)) + | FStarC_Syntax_Syntax.Pat_var x -> + let bx = + let uu___ = + let uu___1 = + FStarC_Syntax_Subst.subst sub x.FStarC_Syntax_Syntax.sort in + { + FStarC_Syntax_Syntax.ppname = + (x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = (x.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = uu___1 + } in + FStarC_Syntax_Syntax.mk_binder uu___ in + let uu___ = fresh_binder g1 bx in + (match uu___ with + | (g2, bx') -> + let sub1 = + let uu___1 = + FStarC_Syntax_Subst.shift_subst Prims.int_one sub in + (FStarC_Syntax_Syntax.DB + (Prims.int_zero, (bx'.FStarC_Syntax_Syntax.binder_bv))) + :: uu___1 in + (g2, + { + FStarC_Syntax_Syntax.v = + (FStarC_Syntax_Syntax.Pat_var + (bx'.FStarC_Syntax_Syntax.binder_bv)); + FStarC_Syntax_Syntax.p = (p1.FStarC_Syntax_Syntax.p) + }, sub1)) + | FStarC_Syntax_Syntax.Pat_dot_term eopt -> + let eopt1 = + FStarC_Compiler_Util.map_option (FStarC_Syntax_Subst.subst sub) + eopt in + (g1, + { + FStarC_Syntax_Syntax.v = + (FStarC_Syntax_Syntax.Pat_dot_term eopt1); + FStarC_Syntax_Syntax.p = (p1.FStarC_Syntax_Syntax.p) + }, sub) in + open_pat_aux g p [] +let (open_term : + env -> + FStarC_Syntax_Syntax.binder -> + FStarC_Syntax_Syntax.term -> + (env * FStarC_Syntax_Syntax.binder * FStarC_Syntax_Syntax.term)) + = + fun g -> + fun b -> + fun t -> + let uu___ = fresh_binder g b in + match uu___ with + | (g1, b') -> + let t1 = + FStarC_Syntax_Subst.subst + [FStarC_Syntax_Syntax.DB + (Prims.int_zero, (b'.FStarC_Syntax_Syntax.binder_bv))] t in + (g1, b', t1) +let (open_term_binders : + env -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.term -> + (env * FStarC_Syntax_Syntax.binders * FStarC_Syntax_Syntax.term)) + = + fun g -> + fun bs -> + fun t -> + let uu___ = open_binders g bs in + match uu___ with + | (g1, bs1, subst) -> + let uu___1 = FStarC_Syntax_Subst.subst subst t in + (g1, bs1, uu___1) +let (open_comp : + env -> + FStarC_Syntax_Syntax.binder -> + FStarC_Syntax_Syntax.comp -> + (env * FStarC_Syntax_Syntax.binder * FStarC_Syntax_Syntax.comp)) + = + fun g -> + fun b -> + fun c -> + let uu___ = fresh_binder g b in + match uu___ with + | (g1, bx) -> + let c1 = + FStarC_Syntax_Subst.subst_comp + [FStarC_Syntax_Syntax.DB + (Prims.int_zero, (bx.FStarC_Syntax_Syntax.binder_bv))] c in + (g1, bx, c1) +let (open_comp_binders : + env -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.comp -> + (env * FStarC_Syntax_Syntax.binders * FStarC_Syntax_Syntax.comp)) + = + fun g -> + fun bs -> + fun c -> + let uu___ = open_binders g bs in + match uu___ with + | (g1, bs1, s) -> + let c1 = FStarC_Syntax_Subst.subst_comp s c in (g1, bs1, c1) +let (arrow_formals_comp : + env -> + FStarC_Syntax_Syntax.term -> + (env * FStarC_Syntax_Syntax.binder Prims.list * + FStarC_Syntax_Syntax.comp)) + = + fun g -> + fun c -> + let uu___ = FStarC_Syntax_Util.arrow_formals_comp_ln c in + match uu___ with + | (bs, c1) -> + let uu___1 = open_binders g bs in + (match uu___1 with + | (g1, bs1, subst) -> + let uu___2 = FStarC_Syntax_Subst.subst_comp subst c1 in + (g1, bs1, uu___2)) +let (open_branch : + env -> FStarC_Syntax_Syntax.branch -> (env * FStarC_Syntax_Syntax.branch)) + = + fun g -> + fun br -> + let uu___ = br in + match uu___ with + | (p, wopt, e) -> + let uu___1 = open_pat g p in + (match uu___1 with + | (g1, p1, s) -> + let uu___2 = + let uu___3 = + FStarC_Compiler_Util.map_option + (FStarC_Syntax_Subst.subst s) wopt in + let uu___4 = FStarC_Syntax_Subst.subst s e in + (p1, uu___3, uu___4) in + (g1, uu___2)) +let (open_branches_eq_pat : + env -> + FStarC_Syntax_Syntax.branch -> + FStarC_Syntax_Syntax.branch -> + (env * (FStarC_Syntax_Syntax.pat * FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option * FStarC_Syntax_Syntax.term) * + (FStarC_Syntax_Syntax.pat * FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option * FStarC_Syntax_Syntax.term))) + = + fun g -> + fun br0 -> + fun br1 -> + let uu___ = br0 in + match uu___ with + | (p0, wopt0, e0) -> + let uu___1 = br1 in + (match uu___1 with + | (uu___2, wopt1, e1) -> + let uu___3 = open_pat g p0 in + (match uu___3 with + | (g1, p01, s) -> + let uu___4 = + let uu___5 = + FStarC_Compiler_Util.map_option + (FStarC_Syntax_Subst.subst s) wopt0 in + let uu___6 = FStarC_Syntax_Subst.subst s e0 in + (p01, uu___5, uu___6) in + let uu___5 = + let uu___6 = + FStarC_Compiler_Util.map_option + (FStarC_Syntax_Subst.subst s) wopt1 in + let uu___7 = FStarC_Syntax_Subst.subst s e1 in + (p01, uu___6, uu___7) in + (g1, uu___4, uu___5))) +type precondition = FStarC_Syntax_Syntax.typ FStar_Pervasives_Native.option +type 'a success = ('a * precondition) +type relation = + | EQUALITY + | SUBTYPING of FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option +let (uu___is_EQUALITY : relation -> Prims.bool) = + fun projectee -> match projectee with | EQUALITY -> true | uu___ -> false +let (uu___is_SUBTYPING : relation -> Prims.bool) = + fun projectee -> + match projectee with | SUBTYPING _0 -> true | uu___ -> false +let (__proj__SUBTYPING__item___0 : + relation -> FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) = + fun projectee -> match projectee with | SUBTYPING _0 -> _0 +let (relation_to_string : relation -> Prims.string) = + fun uu___ -> + match uu___ with + | EQUALITY -> "=?=" + | SUBTYPING (FStar_Pervasives_Native.None) -> "<:?" + | SUBTYPING (FStar_Pervasives_Native.Some tm) -> + let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term tm in + FStarC_Compiler_Util.format1 "( <:? %s)" uu___1 +type context_term = + | CtxTerm of FStarC_Syntax_Syntax.term + | CtxRel of FStarC_Syntax_Syntax.term * relation * + FStarC_Syntax_Syntax.term +let (uu___is_CtxTerm : context_term -> Prims.bool) = + fun projectee -> match projectee with | CtxTerm _0 -> true | uu___ -> false +let (__proj__CtxTerm__item___0 : context_term -> FStarC_Syntax_Syntax.term) = + fun projectee -> match projectee with | CtxTerm _0 -> _0 +let (uu___is_CtxRel : context_term -> Prims.bool) = + fun projectee -> + match projectee with | CtxRel (_0, _1, _2) -> true | uu___ -> false +let (__proj__CtxRel__item___0 : context_term -> FStarC_Syntax_Syntax.term) = + fun projectee -> match projectee with | CtxRel (_0, _1, _2) -> _0 +let (__proj__CtxRel__item___1 : context_term -> relation) = + fun projectee -> match projectee with | CtxRel (_0, _1, _2) -> _1 +let (__proj__CtxRel__item___2 : context_term -> FStarC_Syntax_Syntax.term) = + fun projectee -> match projectee with | CtxRel (_0, _1, _2) -> _2 +let (context_term_to_string : context_term -> Prims.string) = + fun c -> + match c with + | CtxTerm term -> + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term term + | CtxRel (t0, r, t1) -> + let uu___ = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t0 in + let uu___1 = relation_to_string r in + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.format3 "%s %s %s" uu___ uu___1 uu___2 +type context = + { + no_guard: Prims.bool ; + unfolding_ok: Prims.bool ; + error_context: + (Prims.string * context_term FStar_Pervasives_Native.option) Prims.list } +let (__proj__Mkcontext__item__no_guard : context -> Prims.bool) = + fun projectee -> + match projectee with + | { no_guard; unfolding_ok; error_context;_} -> no_guard +let (__proj__Mkcontext__item__unfolding_ok : context -> Prims.bool) = + fun projectee -> + match projectee with + | { no_guard; unfolding_ok; error_context;_} -> unfolding_ok +let (__proj__Mkcontext__item__error_context : + context -> + (Prims.string * context_term FStar_Pervasives_Native.option) Prims.list) + = + fun projectee -> + match projectee with + | { no_guard; unfolding_ok; error_context;_} -> error_context +let (showable_context : context FStarC_Class_Show.showable) = + { + FStarC_Class_Show.show = + (fun context1 -> + let uu___ = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) context1.no_guard in + let uu___1 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) context1.unfolding_ok in + let uu___2 = + let uu___3 = + FStarC_Compiler_List.map FStar_Pervasives_Native.fst + context1.error_context in + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_string)) uu___3 in + FStarC_Compiler_Util.format3 + "{no_guard=%s; unfolding_ok=%s; error_context=%s}" uu___ uu___1 + uu___2) + } +let (print_context : context -> Prims.string) = + fun ctx -> + let rec aux depth ctx1 = + match ctx1 with + | [] -> "" + | (msg, ctx_term)::tl -> + let hd = + let uu___ = + match ctx_term with + | FStar_Pervasives_Native.None -> "" + | FStar_Pervasives_Native.Some ctx_term1 -> + context_term_to_string ctx_term1 in + FStarC_Compiler_Util.format3 "%s %s (%s)\n" depth msg uu___ in + let tl1 = aux (Prims.strcat depth ">") tl in Prims.strcat hd tl1 in + aux "" (FStarC_Compiler_List.rev ctx.error_context) +type error = (context * Prims.string) +let (print_error : error -> Prims.string) = + fun err -> + let uu___ = err in + match uu___ with + | (ctx, msg) -> + let uu___1 = print_context ctx in + FStarC_Compiler_Util.format2 "%s%s" uu___1 msg +let (print_error_short : error -> Prims.string) = + fun err -> FStar_Pervasives_Native.snd err +type 'a __result = + | Success of 'a + | Error of error +let uu___is_Success : 'a . 'a __result -> Prims.bool = + fun projectee -> match projectee with | Success _0 -> true | uu___ -> false +let __proj__Success__item___0 : 'a . 'a __result -> 'a = + fun projectee -> match projectee with | Success _0 -> _0 +let uu___is_Error : 'a . 'a __result -> Prims.bool = + fun projectee -> match projectee with | Error _0 -> true | uu___ -> false +let __proj__Error__item___0 : 'a . 'a __result -> error = + fun projectee -> match projectee with | Error _0 -> _0 +let showable_result : + 'a . + 'a FStarC_Class_Show.showable -> 'a __result FStarC_Class_Show.showable + = + fun uu___ -> + { + FStarC_Class_Show.show = + (fun uu___1 -> + match uu___1 with + | Success a1 -> + let uu___2 = FStarC_Class_Show.show uu___ a1 in + Prims.strcat "Success " uu___2 + | Error e -> + let uu___2 = print_error_short e in + Prims.strcat "Error " uu___2) + } +type 'a result = context -> 'a success __result +type hash_entry = + { + he_term: FStarC_Syntax_Syntax.term ; + he_gamma: FStarC_Syntax_Syntax.binding Prims.list ; + he_res: (tot_or_ghost * FStarC_Syntax_Syntax.typ) success } +let (__proj__Mkhash_entry__item__he_term : + hash_entry -> FStarC_Syntax_Syntax.term) = + fun projectee -> + match projectee with | { he_term; he_gamma; he_res;_} -> he_term +let (__proj__Mkhash_entry__item__he_gamma : + hash_entry -> FStarC_Syntax_Syntax.binding Prims.list) = + fun projectee -> + match projectee with | { he_term; he_gamma; he_res;_} -> he_gamma +let (__proj__Mkhash_entry__item__he_res : + hash_entry -> (tot_or_ghost * FStarC_Syntax_Syntax.typ) success) = + fun projectee -> + match projectee with | { he_term; he_gamma; he_res;_} -> he_res +type tc_table = hash_entry FStarC_Syntax_TermHashTable.hashtable +let (equal_term_for_hash : + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t1 -> + fun t2 -> + FStarC_Profiling.profile + (fun uu___ -> FStarC_Syntax_Hash.equal_term t1 t2) + FStar_Pervasives_Native.None + "FStarC.TypeChecker.Core.equal_term_for_hash" +let (equal_term : + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t1 -> + fun t2 -> + FStarC_Profiling.profile + (fun uu___ -> FStarC_Syntax_Hash.equal_term t1 t2) + FStar_Pervasives_Native.None "FStarC.TypeChecker.Core.equal_term" +let (table : tc_table) = + FStarC_Syntax_TermHashTable.create (Prims.parse_int "1048576") +type cache_stats_t = { + hits: Prims.int ; + misses: Prims.int } +let (__proj__Mkcache_stats_t__item__hits : cache_stats_t -> Prims.int) = + fun projectee -> match projectee with | { hits; misses;_} -> hits +let (__proj__Mkcache_stats_t__item__misses : cache_stats_t -> Prims.int) = + fun projectee -> match projectee with | { hits; misses;_} -> misses +let (cache_stats : cache_stats_t FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref + { hits = Prims.int_zero; misses = Prims.int_zero } +let (record_cache_hit : unit -> unit) = + fun uu___ -> + let cs = FStarC_Compiler_Effect.op_Bang cache_stats in + FStarC_Compiler_Effect.op_Colon_Equals cache_stats + { hits = (cs.hits + Prims.int_one); misses = (cs.misses) } +let (record_cache_miss : unit -> unit) = + fun uu___ -> + let cs = FStarC_Compiler_Effect.op_Bang cache_stats in + FStarC_Compiler_Effect.op_Colon_Equals cache_stats + { hits = (cs.hits); misses = (cs.misses + Prims.int_one) } +let (reset_cache_stats : unit -> unit) = + fun uu___ -> + FStarC_Compiler_Effect.op_Colon_Equals cache_stats + { hits = Prims.int_zero; misses = Prims.int_zero } +let (report_cache_stats : unit -> cache_stats_t) = + fun uu___ -> FStarC_Compiler_Effect.op_Bang cache_stats +let (clear_memo_table : unit -> unit) = + fun uu___ -> FStarC_Syntax_TermHashTable.clear table +type side = + | Left + | Right + | Both + | Neither +let (uu___is_Left : side -> Prims.bool) = + fun projectee -> match projectee with | Left -> true | uu___ -> false +let (uu___is_Right : side -> Prims.bool) = + fun projectee -> match projectee with | Right -> true | uu___ -> false +let (uu___is_Both : side -> Prims.bool) = + fun projectee -> match projectee with | Both -> true | uu___ -> false +let (uu___is_Neither : side -> Prims.bool) = + fun projectee -> match projectee with | Neither -> true | uu___ -> false +let (insert : + env -> + FStarC_Syntax_Syntax.term -> + (tot_or_ghost * FStarC_Syntax_Syntax.typ) success -> unit) + = + fun g -> + fun e -> + fun res -> + let entry = + { + he_term = e; + he_gamma = ((g.tcenv).FStarC_TypeChecker_Env.gamma); + he_res = res + } in + FStarC_Syntax_TermHashTable.insert e entry table +let return : 'a . 'a -> 'a result = + fun x -> fun uu___ -> Success (x, FStar_Pervasives_Native.None) +let (and_pre : + precondition -> + precondition -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax + FStar_Pervasives_Native.option) + = + fun p1 -> + fun p2 -> + match (p1, p2) with + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> + FStar_Pervasives_Native.None + | (FStar_Pervasives_Native.Some p, FStar_Pervasives_Native.None) -> + FStar_Pervasives_Native.Some p + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.Some p) -> + FStar_Pervasives_Native.Some p + | (FStar_Pervasives_Native.Some p11, FStar_Pervasives_Native.Some p21) + -> + let uu___ = FStarC_Syntax_Util.mk_conj p11 p21 in + FStar_Pervasives_Native.Some uu___ +let op_let_Bang : 'a 'b . 'a result -> ('a -> 'b result) -> 'b result = + fun x -> + fun y -> + fun ctx0 -> + let uu___ = x ctx0 in + match uu___ with + | Success (x1, g1) -> + let uu___1 = let uu___2 = y x1 in uu___2 ctx0 in + (match uu___1 with + | Success (y1, g2) -> + let uu___2 = let uu___3 = and_pre g1 g2 in (y1, uu___3) in + Success uu___2 + | err -> err) + | Error err -> Error err +let op_and_Bang : 'a 'b . 'a result -> 'b result -> ('a * 'b) result = + fun x -> + fun y -> + fun ctx0 -> + let uu___ = x ctx0 in + match uu___ with + | Success (x1, g1) -> + let uu___1 = + let uu___2 ctx01 = + let uu___3 = y ctx01 in + match uu___3 with + | Success (x2, g11) -> + let uu___4 = + let uu___5 uu___6 = + Success ((x1, x2), FStar_Pervasives_Native.None) in + uu___5 ctx01 in + (match uu___4 with + | Success (y1, g2) -> + let uu___5 = + let uu___6 = and_pre g11 g2 in (y1, uu___6) in + Success uu___5 + | err -> err) + | Error err -> Error err in + uu___2 ctx0 in + (match uu___1 with + | Success (y1, g2) -> + let uu___2 = let uu___3 = and_pre g1 g2 in (y1, uu___3) in + Success uu___2 + | err -> err) + | Error err -> Error err +let op_let_Question : + 'a 'b . + 'a FStar_Pervasives_Native.option -> + ('a -> 'b FStar_Pervasives_Native.option) -> + 'b FStar_Pervasives_Native.option + = + fun x -> + fun f -> + match x with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some x1 -> f x1 +let fail : 'a . Prims.string -> 'a result = + fun msg -> fun ctx -> Error (ctx, msg) +let (dump_context : unit result) = + fun ctx -> + (let uu___1 = print_context ctx in + FStarC_Compiler_Util.print_string uu___1); + (let uu___1 uu___2 = Success ((), FStar_Pervasives_Native.None) in + uu___1 ctx) +let handle_with : 'a . 'a result -> (unit -> 'a result) -> 'a result = + fun x -> + fun h -> + fun ctx -> + let uu___ = x ctx in + match uu___ with + | Error uu___1 -> let uu___2 = h () in uu___2 ctx + | res -> res +let with_context : + 'a . + Prims.string -> + context_term FStar_Pervasives_Native.option -> + (unit -> 'a result) -> 'a result + = + fun msg -> + fun t -> + fun x -> + fun ctx -> + let ctx1 = + { + no_guard = (ctx.no_guard); + unfolding_ok = (ctx.unfolding_ok); + error_context = ((msg, t) :: (ctx.error_context)) + } in + let uu___ = x () in uu___ ctx1 +let (mk_type : + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun u -> + FStarC_Syntax_Syntax.mk (FStarC_Syntax_Syntax.Tm_type u) + FStarC_Compiler_Range_Type.dummyRange +let (is_type : + env -> FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.universe result) = + fun g -> + fun t -> + let aux t1 = + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t1 in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_type u -> + (fun uu___1 -> Success (u, FStar_Pervasives_Native.None)) + | uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.format1 "Expected a type; got %s" uu___3 in + fail uu___2 in + fun ctx -> + let ctx1 = + { + no_guard = (ctx.no_guard); + unfolding_ok = (ctx.unfolding_ok); + error_context = + (("is_type", (FStar_Pervasives_Native.Some (CtxTerm t))) :: + (ctx.error_context)) + } in + let uu___ = + let uu___1 = aux t in + fun ctx2 -> + let uu___2 = uu___1 ctx2 in + match uu___2 with + | Error uu___3 -> + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_TypeChecker_Normalize.unfold_whnf g.tcenv t in + FStarC_Syntax_Util.unrefine uu___6 in + aux uu___5 in + uu___4 ctx2 + | res -> res in + uu___ ctx1 +let rec (is_arrow : + env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.binder * tot_or_ghost * FStarC_Syntax_Syntax.typ) + result) + = + fun g -> + fun t -> + let rec aux t1 = + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t1 in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = x::[]; + FStarC_Syntax_Syntax.comp = c;_} + -> + let uu___1 = FStarC_Syntax_Util.is_tot_or_gtot_comp c in + if uu___1 + then + let uu___2 = open_comp g x c in + (match uu___2 with + | (g1, x1, c1) -> + let eff = + let uu___3 = FStarC_Syntax_Util.is_total_comp c1 in + if uu___3 then E_Total else E_Ghost in + (fun uu___3 -> + Success + ((x1, eff, (FStarC_Syntax_Util.comp_result c1)), + FStar_Pervasives_Native.None))) + else + (let e_tag = + let uu___3 = c.FStarC_Syntax_Syntax.n in + match uu___3 with + | FStarC_Syntax_Syntax.Comp ct -> + let uu___4 = + (FStarC_Ident.lid_equals + ct.FStarC_Syntax_Syntax.effect_name + FStarC_Parser_Const.effect_Pure_lid) + || + (FStarC_Ident.lid_equals + ct.FStarC_Syntax_Syntax.effect_name + FStarC_Parser_Const.effect_Lemma_lid) in + if uu___4 + then FStar_Pervasives_Native.Some E_Total + else + (let uu___6 = + FStarC_Ident.lid_equals + ct.FStarC_Syntax_Syntax.effect_name + FStarC_Parser_Const.effect_Ghost_lid in + if uu___6 + then FStar_Pervasives_Native.Some E_Ghost + else FStar_Pervasives_Native.None) in + match e_tag with + | FStar_Pervasives_Native.None -> + let uu___3 = + let uu___4 = + FStarC_Ident.string_of_lid + (FStarC_Syntax_Util.comp_effect_name c) in + FStarC_Compiler_Util.format1 + "Expected total or gtot arrow, got %s" uu___4 in + fail uu___3 + | FStar_Pervasives_Native.Some e_tag1 -> + let uu___3 = arrow_formals_comp g t1 in + (match uu___3 with + | (g1, x1::[], c1) -> + let uu___4 = FStarC_Syntax_Util.comp_effect_args c1 in + (match uu___4 with + | (pre, uu___5)::(post, uu___6)::uu___7 -> + let arg_typ = + FStarC_Syntax_Util.refine + x1.FStarC_Syntax_Syntax.binder_bv pre in + let res_typ = + let r = + FStarC_Syntax_Syntax.new_bv + FStar_Pervasives_Native.None + (FStarC_Syntax_Util.comp_result c1) in + let post1 = + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Syntax_Syntax.bv_to_name r in + (uu___10, FStar_Pervasives_Native.None) in + [uu___9] in + FStarC_Syntax_Syntax.mk_Tm_app post uu___8 + post.FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Util.refine r post1 in + let xbv = + let uu___8 = x1.FStarC_Syntax_Syntax.binder_bv in + { + FStarC_Syntax_Syntax.ppname = + (uu___8.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (uu___8.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = arg_typ + } in + let x2 = + { + FStarC_Syntax_Syntax.binder_bv = xbv; + FStarC_Syntax_Syntax.binder_qual = + (x1.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity = + (x1.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs = + (x1.FStarC_Syntax_Syntax.binder_attrs) + } in + (fun uu___8 -> + Success + ((x2, e_tag1, res_typ), + FStar_Pervasives_Native.None))))) + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = x::xs; + FStarC_Syntax_Syntax.comp = c;_} + -> + let t2 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 = xs; + FStarC_Syntax_Syntax.comp = c + }) t1.FStarC_Syntax_Syntax.pos in + let uu___1 = open_term g x t2 in + (match uu___1 with + | (g1, x1, t3) -> + (fun uu___2 -> + Success ((x1, E_Total, t3), FStar_Pervasives_Native.None))) + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x; + FStarC_Syntax_Syntax.phi = uu___1;_} + -> is_arrow g x.FStarC_Syntax_Syntax.sort + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t2; + FStarC_Syntax_Syntax.meta = uu___1;_} + -> aux t2 + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t2; + FStarC_Syntax_Syntax.asc = uu___1; + FStarC_Syntax_Syntax.eff_opt = uu___2;_} + -> aux t2 + | uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term + t1 in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.format2 "Expected an arrow, got (%s) %s" + uu___3 uu___4 in + fail uu___2 in + fun ctx -> + let ctx1 = + { + no_guard = (ctx.no_guard); + unfolding_ok = (ctx.unfolding_ok); + error_context = (("is_arrow", FStar_Pervasives_Native.None) :: + (ctx.error_context)) + } in + let uu___ = + let uu___1 = aux t in + fun ctx2 -> + let uu___2 = uu___1 ctx2 in + match uu___2 with + | Error uu___3 -> + let uu___4 = + let uu___5 = + FStarC_TypeChecker_Normalize.unfold_whnf g.tcenv t in + aux uu___5 in + uu___4 ctx2 + | res -> res in + uu___ ctx1 +let (check_arg_qual : + FStarC_Syntax_Syntax.aqual -> FStarC_Syntax_Syntax.bqual -> unit result) = + fun a -> + fun b -> + match b with + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Implicit uu___) -> + (match a with + | FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = uu___1;_} + -> (fun uu___2 -> Success ((), FStar_Pervasives_Native.None)) + | uu___1 -> fail "missing arg qualifier implicit") + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Meta uu___) -> + (match a with + | FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = uu___1;_} + -> (fun uu___2 -> Success ((), FStar_Pervasives_Native.None)) + | uu___1 -> fail "missing arg qualifier implicit") + | uu___ -> + (match a with + | FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = uu___1;_} + -> fail "extra arg qualifier implicit" + | uu___1 -> + (fun uu___2 -> Success ((), FStar_Pervasives_Native.None))) +let (check_bqual : + FStarC_Syntax_Syntax.bqual -> FStarC_Syntax_Syntax.bqual -> unit result) = + fun b0 -> + fun b1 -> + match (b0, b1) with + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> + (fun uu___ -> Success ((), FStar_Pervasives_Native.None)) + | (FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Implicit b01), + FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Implicit b11)) -> + (fun uu___ -> Success ((), FStar_Pervasives_Native.None)) + | (FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Equality), + FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Equality)) -> + (fun uu___ -> Success ((), FStar_Pervasives_Native.None)) + | (FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Meta t1), + FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Meta t2)) -> + let uu___ = equal_term t1 t2 in + if uu___ + then (fun uu___1 -> Success ((), FStar_Pervasives_Native.None)) + else fail "Binder qualifier mismatch" + | uu___ -> fail "Binder qualifier mismatch" +let (check_aqual : + FStarC_Syntax_Syntax.aqual -> FStarC_Syntax_Syntax.aqual -> unit result) = + fun a0 -> + fun a1 -> + match (a0, a1) with + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> + (fun uu___ -> Success ((), FStar_Pervasives_Native.None)) + | (FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = b0; + FStarC_Syntax_Syntax.aqual_attributes = uu___;_}, + FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = b1; + FStarC_Syntax_Syntax.aqual_attributes = uu___1;_}) + -> + if b0 = b1 + then (fun uu___2 -> Success ((), FStar_Pervasives_Native.None)) + else + (let uu___3 = + let uu___4 = FStarC_Compiler_Util.string_of_bool b0 in + let uu___5 = FStarC_Compiler_Util.string_of_bool b1 in + FStarC_Compiler_Util.format2 + "Unequal arg qualifiers: lhs implicit=%s and rhs implicit=%s" + uu___4 uu___5 in + fail uu___3) + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = false; + FStarC_Syntax_Syntax.aqual_attributes = uu___;_}) + -> (fun uu___1 -> Success ((), FStar_Pervasives_Native.None)) + | (FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = false; + FStarC_Syntax_Syntax.aqual_attributes = uu___;_}, + FStar_Pervasives_Native.None) -> + (fun uu___1 -> Success ((), FStar_Pervasives_Native.None)) + | uu___ -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_aqual a0 in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_aqual a1 in + FStarC_Compiler_Util.format2 + "Unequal arg qualifiers: lhs %s and rhs %s" uu___2 uu___3 in + fail uu___1 +let (check_positivity_qual : + relation -> + FStarC_Syntax_Syntax.positivity_qualifier FStar_Pervasives_Native.option + -> + FStarC_Syntax_Syntax.positivity_qualifier + FStar_Pervasives_Native.option -> unit result) + = + fun rel -> + fun p0 -> + fun p1 -> + let uu___ = + FStarC_TypeChecker_Common.check_positivity_qual + (uu___is_SUBTYPING rel) p0 p1 in + if uu___ + then fun uu___1 -> Success ((), FStar_Pervasives_Native.None) + else fail "Unequal positivity qualifiers" +let (mk_forall_l : + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun us -> + fun xs -> + fun t -> + FStarC_Compiler_List.fold_right2 + (fun u -> + fun x -> + fun t1 -> + FStarC_Syntax_Util.mk_forall u + x.FStarC_Syntax_Syntax.binder_bv t1) us xs t +let (close_guard : + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.universes -> precondition -> precondition) + = + fun xs -> + fun us -> + fun g -> + match g with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some t -> + let uu___ = mk_forall_l us xs t in + FStar_Pervasives_Native.Some uu___ +let (close_guard_with_definition : + FStarC_Syntax_Syntax.binder -> + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.term -> precondition -> precondition) + = + fun x -> + fun u -> + fun t -> + fun g -> + match g with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some t1 -> + let uu___ = + let t2 = + let uu___1 = + let uu___2 = + FStarC_Syntax_Syntax.bv_to_name + x.FStarC_Syntax_Syntax.binder_bv in + FStarC_Syntax_Util.mk_eq2 u + (x.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort + uu___2 t1 in + FStarC_Syntax_Util.mk_imp uu___1 t1 in + FStarC_Syntax_Util.mk_forall u + x.FStarC_Syntax_Syntax.binder_bv t2 in + FStar_Pervasives_Native.Some uu___ +let with_binders : + 'a . + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.universes -> 'a result -> 'a result + = + fun xs -> + fun us -> + fun f -> + fun ctx -> + let uu___ = f ctx in + match uu___ with + | Success (t, g) -> + let uu___1 = let uu___2 = close_guard xs us g in (t, uu___2) in + Success uu___1 + | err -> err +let with_definition : + 'a . + FStarC_Syntax_Syntax.binder -> + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.term -> 'a result -> 'a result + = + fun x -> + fun u -> + fun t -> + fun f -> + fun ctx -> + let uu___ = f ctx in + match uu___ with + | Success (a1, g) -> + let uu___1 = + let uu___2 = close_guard_with_definition x u t g in + (a1, uu___2) in + Success uu___1 + | err -> err +let (guard : FStarC_Syntax_Syntax.typ -> unit result) = + fun t -> fun uu___ -> Success ((), (FStar_Pervasives_Native.Some t)) +let (abs : + FStarC_Syntax_Syntax.typ -> + (FStarC_Syntax_Syntax.binder -> FStarC_Syntax_Syntax.term) -> + FStarC_Syntax_Syntax.term) + = + fun a -> + fun f -> + let x = FStarC_Syntax_Syntax.new_bv FStar_Pervasives_Native.None a in + let xb = FStarC_Syntax_Syntax.mk_binder x in + let uu___ = f xb in + FStarC_Syntax_Util.abs [xb] uu___ FStar_Pervasives_Native.None +let (weaken_subtyping_guard : + FStarC_Syntax_Syntax.term -> precondition -> precondition) = + fun p -> + fun g -> + FStarC_Compiler_Util.map_opt g (fun q -> FStarC_Syntax_Util.mk_imp p q) +let (strengthen_subtyping_guard : + FStarC_Syntax_Syntax.term -> precondition -> precondition) = + fun p -> + fun g -> + let uu___ = + let uu___1 = + FStarC_Compiler_Util.map_opt g + (fun q -> FStarC_Syntax_Util.mk_conj p q) in + FStarC_Compiler_Util.dflt p uu___1 in + FStar_Pervasives_Native.Some uu___ +let weaken : + 'a . + FStarC_Syntax_Syntax.term -> 'a result -> context -> 'a success __result + = + fun p -> + fun g -> + fun ctx -> + let uu___ = g ctx in + match uu___ with + | Success (x, q) -> + let uu___1 = + let uu___2 = weaken_subtyping_guard p q in (x, uu___2) in + Success uu___1 + | err -> err +let weaken_with_guard_formula : + 'a . + FStarC_TypeChecker_Common.guard_formula -> + 'a result -> context -> 'a success __result + = + fun p -> + fun g -> + match p with + | FStarC_TypeChecker_Common.Trivial -> g + | FStarC_TypeChecker_Common.NonTrivial p1 -> weaken p1 g +let (push_hypothesis : env -> FStarC_Syntax_Syntax.term -> env) = + fun g -> + fun h -> + let bv = + FStarC_Syntax_Syntax.new_bv + (FStar_Pervasives_Native.Some (h.FStarC_Syntax_Syntax.pos)) h in + let b = FStarC_Syntax_Syntax.mk_binder bv in + let uu___ = fresh_binder g b in FStar_Pervasives_Native.fst uu___ +let strengthen : + 'a . + FStarC_Syntax_Syntax.term -> 'a result -> context -> 'a success __result + = + fun p -> + fun g -> + fun ctx -> + let uu___ = g ctx in + match uu___ with + | Success (x, q) -> + let uu___1 = + let uu___2 = strengthen_subtyping_guard p q in (x, uu___2) in + Success uu___1 + | err -> err +let no_guard : 'a . 'a result -> 'a result = + fun g -> + fun ctx -> + let uu___ = + g + { + no_guard = true; + unfolding_ok = (ctx.unfolding_ok); + error_context = (ctx.error_context) + } in + match uu___ with + | Success (x, FStar_Pervasives_Native.None) -> + Success (x, FStar_Pervasives_Native.None) + | Success (x, FStar_Pervasives_Native.Some g1) -> + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term g1 in + FStarC_Compiler_Util.format1 "Unexpected guard: %s" uu___3 in + fail uu___2 in + uu___1 ctx + | err -> err +let (equatable : env -> FStarC_Syntax_Syntax.term -> Prims.bool) = + fun g -> + fun t -> + let uu___ = FStarC_Syntax_Util.leftmost_head t in + FStarC_TypeChecker_Rel.may_relate_with_logical_guard g.tcenv true uu___ +let (apply_predicate : + FStarC_Syntax_Syntax.binder -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term) + = + fun x -> + fun p -> + fun e -> + FStarC_Syntax_Subst.subst + [FStarC_Syntax_Syntax.NT ((x.FStarC_Syntax_Syntax.binder_bv), e)] p +let (curry_arrow : + FStarC_Syntax_Syntax.binder -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.comp -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun x -> + fun xs -> + fun c -> + let tail = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = xs; FStarC_Syntax_Syntax.comp = c + }) FStarC_Compiler_Range_Type.dummyRange in + let uu___ = + let uu___1 = + let uu___2 = FStarC_Syntax_Syntax.mk_Total tail in + { + FStarC_Syntax_Syntax.bs1 = [x]; + FStarC_Syntax_Syntax.comp = uu___2 + } in + FStarC_Syntax_Syntax.Tm_arrow uu___1 in + FStarC_Syntax_Syntax.mk uu___ FStarC_Compiler_Range_Type.dummyRange +let (curry_abs : + FStarC_Syntax_Syntax.binder -> + FStarC_Syntax_Syntax.binder -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option + -> FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun b0 -> + fun b1 -> + fun bs -> + fun body -> + fun ropt -> + let tail = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs = (b1 :: bs); + FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = ropt + }) body.FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs = [b0]; + FStarC_Syntax_Syntax.body = tail; + FStarC_Syntax_Syntax.rc_opt = FStar_Pervasives_Native.None + }) body.FStarC_Syntax_Syntax.pos +let (is_gtot_comp : + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> Prims.bool) = + fun c -> + (FStarC_Syntax_Util.is_tot_or_gtot_comp c) && + (let uu___ = FStarC_Syntax_Util.is_total_comp c in + Prims.op_Negation uu___) +let rec (context_included : + FStarC_Syntax_Syntax.binding Prims.list -> + FStarC_Syntax_Syntax.binding Prims.list -> Prims.bool) + = + fun g0 -> + fun g1 -> + let uu___ = FStarC_Compiler_Util.physical_equality g0 g1 in + if uu___ + then true + else + (match (g0, g1) with + | ([], uu___2) -> true + | (b0::g0', b1::g1') -> + (match (b0, b1) with + | (FStarC_Syntax_Syntax.Binding_var x0, + FStarC_Syntax_Syntax.Binding_var x1) -> + if + x0.FStarC_Syntax_Syntax.index = + x1.FStarC_Syntax_Syntax.index + then + (equal_term x0.FStarC_Syntax_Syntax.sort + x1.FStarC_Syntax_Syntax.sort) + && (context_included g0' g1') + else context_included g0 g1' + | (FStarC_Syntax_Syntax.Binding_lid uu___2, + FStarC_Syntax_Syntax.Binding_lid uu___3) -> true + | (FStarC_Syntax_Syntax.Binding_univ uu___2, + FStarC_Syntax_Syntax.Binding_univ uu___3) -> true + | uu___2 -> false) + | uu___2 -> false) +let (curry_application : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + (FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax * + FStarC_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) -> + (FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax * + FStarC_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) + Prims.list -> + FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun hd -> + fun arg -> + fun args -> + fun p -> + let head = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = hd; + FStarC_Syntax_Syntax.args = [arg] + }) p in + let t = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = args + }) p in + t +let (lookup : + env -> + FStarC_Syntax_Syntax.term -> + (tot_or_ghost * FStarC_Syntax_Syntax.typ) result) + = + fun g -> + fun e -> + let uu___ = FStarC_Syntax_TermHashTable.lookup e table in + match uu___ with + | FStar_Pervasives_Native.None -> + (record_cache_miss (); fail "not in cache") + | FStar_Pervasives_Native.Some he -> + let uu___1 = + context_included he.he_gamma + (g.tcenv).FStarC_TypeChecker_Env.gamma in + if uu___1 + then + (record_cache_hit (); + (let uu___4 = FStarC_Compiler_Effect.op_Bang dbg in + if uu___4 + then + let uu___5 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binding) + (g.tcenv).FStarC_TypeChecker_Env.gamma in + let uu___6 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + let uu___7 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + (FStar_Pervasives_Native.snd + (FStar_Pervasives_Native.fst he.he_res)) in + let uu___8 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binding) he.he_gamma in + FStarC_Compiler_Util.print4 + "cache hit\n %s |- %s : %s\nmatching env %s\n" uu___5 + uu___6 uu___7 uu___8 + else ()); + (fun uu___4 -> Success (he.he_res))) + else fail "not in cache" +let (check_no_escape : + FStarC_Syntax_Syntax.binders -> FStarC_Syntax_Syntax.term -> unit result) = + fun bs -> + fun t -> + let xs = FStarC_Syntax_Free.names t in + let uu___ = + FStarC_Compiler_Util.for_all + (fun b -> + let uu___1 = + FStarC_Class_Setlike.mem () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) + b.FStarC_Syntax_Syntax.binder_bv (Obj.magic xs) in + Prims.op_Negation uu___1) bs in + if uu___ + then fun uu___1 -> Success ((), FStar_Pervasives_Native.None) + else fail "Name escapes its scope" +let rec map : + 'a 'b . ('a -> 'b result) -> 'a Prims.list -> 'b Prims.list result = + fun f -> + fun l -> + match l with + | [] -> (fun uu___ -> Success ([], FStar_Pervasives_Native.None)) + | hd::tl -> + let uu___ = f hd in + (fun ctx0 -> + let uu___1 = uu___ ctx0 in + match uu___1 with + | Success (x, g1) -> + let uu___2 = + let uu___3 = + let uu___4 = map f tl in + fun ctx01 -> + let uu___5 = uu___4 ctx01 in + match uu___5 with + | Success (x1, g11) -> + let uu___6 = + let uu___7 uu___8 = + Success + ((x :: x1), FStar_Pervasives_Native.None) in + uu___7 ctx01 in + (match uu___6 with + | Success (y, g2) -> + let uu___7 = + let uu___8 = and_pre g11 g2 in (y, uu___8) in + Success uu___7 + | err -> err) + | Error err -> Error err in + uu___3 ctx0 in + (match uu___2 with + | Success (y, g2) -> + let uu___3 = let uu___4 = and_pre g1 g2 in (y, uu___4) in + Success uu___3 + | err -> err) + | Error err -> Error err) +let mapi : + 'a 'b . + (Prims.int -> 'a -> 'b result) -> 'a Prims.list -> 'b Prims.list result + = + fun f -> + fun l -> + let rec aux i l1 = + match l1 with + | [] -> (fun uu___ -> Success ([], FStar_Pervasives_Native.None)) + | hd::tl -> + let uu___ = f i hd in + (fun ctx0 -> + let uu___1 = uu___ ctx0 in + match uu___1 with + | Success (x, g1) -> + let uu___2 = + let uu___3 = + let uu___4 = aux (i + Prims.int_one) tl in + fun ctx01 -> + let uu___5 = uu___4 ctx01 in + match uu___5 with + | Success (x1, g11) -> + let uu___6 = + let uu___7 uu___8 = + Success + ((x :: x1), FStar_Pervasives_Native.None) in + uu___7 ctx01 in + (match uu___6 with + | Success (y, g2) -> + let uu___7 = + let uu___8 = and_pre g11 g2 in + (y, uu___8) in + Success uu___7 + | err -> err) + | Error err -> Error err in + uu___3 ctx0 in + (match uu___2 with + | Success (y, g2) -> + let uu___3 = + let uu___4 = and_pre g1 g2 in (y, uu___4) in + Success uu___3 + | err -> err) + | Error err -> Error err) in + aux Prims.int_zero l +let rec map2 : + 'a 'b 'c . + ('a -> 'b -> 'c result) -> + 'a Prims.list -> 'b Prims.list -> 'c Prims.list result + = + fun f -> + fun l1 -> + fun l2 -> + match (l1, l2) with + | ([], []) -> + (fun uu___ -> Success ([], FStar_Pervasives_Native.None)) + | (hd1::tl1, hd2::tl2) -> + let uu___ = f hd1 hd2 in + (fun ctx0 -> + let uu___1 = uu___ ctx0 in + match uu___1 with + | Success (x, g1) -> + let uu___2 = + let uu___3 = + let uu___4 = map2 f tl1 tl2 in + fun ctx01 -> + let uu___5 = uu___4 ctx01 in + match uu___5 with + | Success (x1, g11) -> + let uu___6 = + let uu___7 uu___8 = + Success + ((x :: x1), FStar_Pervasives_Native.None) in + uu___7 ctx01 in + (match uu___6 with + | Success (y, g2) -> + let uu___7 = + let uu___8 = and_pre g11 g2 in + (y, uu___8) in + Success uu___7 + | err -> err) + | Error err -> Error err in + uu___3 ctx0 in + (match uu___2 with + | Success (y, g2) -> + let uu___3 = + let uu___4 = and_pre g1 g2 in (y, uu___4) in + Success uu___3 + | err -> err) + | Error err -> Error err) +let rec fold : + 'a 'b . ('a -> 'b -> 'a result) -> 'a -> 'b Prims.list -> 'a result = + fun f -> + fun x -> + fun l -> + match l with + | [] -> (fun uu___ -> Success (x, FStar_Pervasives_Native.None)) + | hd::tl -> + let uu___ = f x hd in + (fun ctx0 -> + let uu___1 = uu___ ctx0 in + match uu___1 with + | Success (x1, g1) -> + let uu___2 = let uu___3 = fold f x1 tl in uu___3 ctx0 in + (match uu___2 with + | Success (y, g2) -> + let uu___3 = + let uu___4 = and_pre g1 g2 in (y, uu___4) in + Success uu___3 + | err -> err) + | Error err -> Error err) +let rec fold2 : + 'a 'b 'c . + ('a -> 'b -> 'c -> 'a result) -> + 'a -> 'b Prims.list -> 'c Prims.list -> 'a result + = + fun f -> + fun x -> + fun l1 -> + fun l2 -> + match (l1, l2) with + | ([], []) -> + (fun uu___ -> Success (x, FStar_Pervasives_Native.None)) + | (hd1::tl1, hd2::tl2) -> + let uu___ = f x hd1 hd2 in + (fun ctx0 -> + let uu___1 = uu___ ctx0 in + match uu___1 with + | Success (x1, g1) -> + let uu___2 = + let uu___3 = fold2 f x1 tl1 tl2 in uu___3 ctx0 in + (match uu___2 with + | Success (y, g2) -> + let uu___3 = + let uu___4 = and_pre g1 g2 in (y, uu___4) in + Success uu___3 + | err -> err) + | Error err -> Error err) +let rec iter2 : + 'a 'b . + 'a Prims.list -> + 'a Prims.list -> ('a -> 'a -> 'b -> 'b result) -> 'b -> 'b result + = + fun xs -> + fun ys -> + fun f -> + fun b1 -> + match (xs, ys) with + | ([], []) -> + (fun uu___ -> Success (b1, FStar_Pervasives_Native.None)) + | (x::xs1, y::ys1) -> + let uu___ = f x y b1 in + (fun ctx0 -> + let uu___1 = uu___ ctx0 in + match uu___1 with + | Success (x1, g1) -> + let uu___2 = + let uu___3 = iter2 xs1 ys1 f x1 in uu___3 ctx0 in + (match uu___2 with + | Success (y1, g2) -> + let uu___3 = + let uu___4 = and_pre g1 g2 in (y1, uu___4) in + Success uu___3 + | err -> err) + | Error err -> Error err) + | uu___ -> fail "Lists of differing length" +let (is_non_informative : + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.typ -> Prims.bool) = + fun g -> fun t -> FStarC_TypeChecker_Normalize.non_info_norm g t +let (non_informative : env -> FStarC_Syntax_Syntax.typ -> Prims.bool) = + fun g -> fun t -> is_non_informative g.tcenv t +let (as_comp : + env -> + (tot_or_ghost * FStarC_Syntax_Syntax.typ) -> FStarC_Syntax_Syntax.comp) + = + fun g -> + fun et -> + match et with + | (E_Total, t) -> FStarC_Syntax_Syntax.mk_Total t + | (E_Ghost, t) -> + let uu___ = non_informative g t in + if uu___ + then FStarC_Syntax_Syntax.mk_Total t + else FStarC_Syntax_Syntax.mk_GTotal t +let (comp_as_tot_or_ghost_and_type : + FStarC_Syntax_Syntax.comp -> + (tot_or_ghost * FStarC_Syntax_Syntax.typ) FStar_Pervasives_Native.option) + = + fun c -> + let uu___ = FStarC_Syntax_Util.is_total_comp c in + if uu___ + then + FStar_Pervasives_Native.Some + (E_Total, (FStarC_Syntax_Util.comp_result c)) + else + (let uu___2 = FStarC_Syntax_Util.is_tot_or_gtot_comp c in + if uu___2 + then + FStar_Pervasives_Native.Some + (E_Ghost, (FStarC_Syntax_Util.comp_result c)) + else FStar_Pervasives_Native.None) +let (join_eff : tot_or_ghost -> tot_or_ghost -> tot_or_ghost) = + fun e0 -> + fun e1 -> + match (e0, e1) with + | (E_Ghost, uu___) -> E_Ghost + | (uu___, E_Ghost) -> E_Ghost + | uu___ -> E_Total +let (join_eff_l : tot_or_ghost Prims.list -> tot_or_ghost) = + fun es -> FStar_List_Tot_Base.fold_right join_eff es E_Total +let (guard_not_allowed : Prims.bool result) = + fun ctx -> Success ((ctx.no_guard), FStar_Pervasives_Native.None) +let (unfolding_ok : Prims.bool result) = + fun ctx -> Success ((ctx.unfolding_ok), FStar_Pervasives_Native.None) +let debug : 'uuuuu . 'uuuuu -> (unit -> unit) -> unit = + fun g -> + fun f -> + let uu___ = FStarC_Compiler_Effect.op_Bang dbg in + if uu___ then f () else () +let (showable_side : side FStarC_Class_Show.showable) = + { + FStarC_Class_Show.show = + (fun uu___ -> + match uu___ with + | Left -> "Left" + | Right -> "Right" + | Both -> "Both" + | Neither -> "Neither") + } +let (boolean_negation_simp : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax + FStar_Pervasives_Native.option) + = + fun b -> + let uu___ = + FStarC_Syntax_Hash.equal_term b FStarC_Syntax_Util.exp_false_bool in + if uu___ + then FStar_Pervasives_Native.None + else + (let uu___2 = FStarC_Syntax_Util.mk_boolean_negation b in + FStar_Pervasives_Native.Some uu___2) +let (combine_path_and_branch_condition : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.term)) + = + fun path_condition -> + fun branch_condition -> + fun branch_equality -> + let this_path_condition = + let bc = + match branch_condition with + | FStar_Pervasives_Native.None -> branch_equality + | FStar_Pervasives_Native.Some bc1 -> + let uu___ = + let uu___1 = FStarC_Syntax_Util.b2t bc1 in + [uu___1; branch_equality] in + FStarC_Syntax_Util.mk_conj_l uu___ in + let uu___ = FStarC_Syntax_Util.b2t path_condition in + FStarC_Syntax_Util.mk_conj uu___ bc in + let next_path_condition = + match branch_condition with + | FStar_Pervasives_Native.None -> FStarC_Syntax_Util.exp_false_bool + | FStar_Pervasives_Native.Some bc -> + let uu___ = + FStarC_Syntax_Hash.equal_term path_condition + FStarC_Syntax_Util.exp_true_bool in + if uu___ + then FStarC_Syntax_Util.mk_boolean_negation bc + else + (let uu___2 = FStarC_Syntax_Util.mk_boolean_negation bc in + FStarC_Syntax_Util.mk_and path_condition uu___2) in + (this_path_condition, next_path_condition) +let (maybe_relate_after_unfolding : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term -> side) + = + fun g -> + fun t0 -> + fun t1 -> + let dd0 = FStarC_TypeChecker_Env.delta_depth_of_term g t0 in + let dd1 = FStarC_TypeChecker_Env.delta_depth_of_term g t1 in + if dd0 = dd1 + then Both + else + (let uu___1 = + FStarC_TypeChecker_Common.delta_depth_greater_than dd0 dd1 in + if uu___1 then Left else Right) +let rec (check_relation : + env -> + relation -> + FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.typ -> unit result) + = + fun g -> + fun rel -> + fun t0 -> + fun t1 -> + let err uu___ = + match rel with + | EQUALITY -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + t0 in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + t1 in + FStarC_Compiler_Util.format2 "not equal terms: %s <> %s" + uu___2 uu___3 in + fail uu___1 + | uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + t0 in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + t1 in + FStarC_Compiler_Util.format2 "%s is not a subtype of %s" + uu___3 uu___4 in + fail uu___2 in + let rel_to_string rel1 = + match rel1 with | EQUALITY -> "=?=" | SUBTYPING uu___ -> "<:?" in + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg in + if uu___1 + then + let uu___2 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t0 in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t0 in + let uu___4 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t1 in + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.print5 + "check_relation (%s) %s %s (%s) %s\n" uu___2 uu___3 + (rel_to_string rel) uu___4 uu___5 + else ()); + (fun ctx0 -> + let uu___1 = guard_not_allowed ctx0 in + match uu___1 with + | Success (x, g1) -> + let uu___2 = + let uu___3 = + let guard_ok = Prims.op_Negation x in + let head_matches t01 t11 = + let head0 = FStarC_Syntax_Util.leftmost_head t01 in + let head1 = FStarC_Syntax_Util.leftmost_head t11 in + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Syntax_Util.un_uinst head0 in + uu___6.FStarC_Syntax_Syntax.n in + let uu___6 = + let uu___7 = FStarC_Syntax_Util.un_uinst head1 in + uu___7.FStarC_Syntax_Syntax.n in + (uu___5, uu___6) in + match uu___4 with + | (FStarC_Syntax_Syntax.Tm_fvar fv0, + FStarC_Syntax_Syntax.Tm_fvar fv1) -> + FStarC_Syntax_Syntax.fv_eq fv0 fv1 + | (FStarC_Syntax_Syntax.Tm_name x0, + FStarC_Syntax_Syntax.Tm_name x1) -> + FStarC_Syntax_Syntax.bv_eq x0 x1 + | (FStarC_Syntax_Syntax.Tm_constant c0, + FStarC_Syntax_Syntax.Tm_constant c1) -> + equal_term head0 head1 + | (FStarC_Syntax_Syntax.Tm_type uu___5, + FStarC_Syntax_Syntax.Tm_type uu___6) -> true + | (FStarC_Syntax_Syntax.Tm_arrow uu___5, + FStarC_Syntax_Syntax.Tm_arrow uu___6) -> true + | (FStarC_Syntax_Syntax.Tm_match uu___5, + FStarC_Syntax_Syntax.Tm_match uu___6) -> true + | uu___5 -> false in + let which_side_to_unfold t01 t11 = + maybe_relate_after_unfolding g.tcenv t01 t11 in + let maybe_unfold_side side1 t01 t11 = + FStarC_Profiling.profile + (fun uu___4 -> + match side1 with + | Neither -> FStar_Pervasives_Native.None + | Both -> + let uu___5 = + let uu___6 = + FStarC_TypeChecker_Normalize.maybe_unfold_head + g.tcenv t01 in + let uu___7 = + FStarC_TypeChecker_Normalize.maybe_unfold_head + g.tcenv t11 in + (uu___6, uu___7) in + (match uu___5 with + | (FStar_Pervasives_Native.Some t02, + FStar_Pervasives_Native.Some t12) -> + FStar_Pervasives_Native.Some (t02, t12) + | (FStar_Pervasives_Native.Some t02, + FStar_Pervasives_Native.None) -> + FStar_Pervasives_Native.Some (t02, t11) + | (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.Some t12) -> + FStar_Pervasives_Native.Some (t01, t12) + | uu___6 -> FStar_Pervasives_Native.None) + | Left -> + let uu___5 = + FStarC_TypeChecker_Normalize.maybe_unfold_head + g.tcenv t01 in + (match uu___5 with + | FStar_Pervasives_Native.Some t02 -> + FStar_Pervasives_Native.Some (t02, t11) + | uu___6 -> FStar_Pervasives_Native.None) + | Right -> + let uu___5 = + FStarC_TypeChecker_Normalize.maybe_unfold_head + g.tcenv t11 in + (match uu___5 with + | FStar_Pervasives_Native.Some t12 -> + FStar_Pervasives_Native.Some (t01, t12) + | uu___6 -> FStar_Pervasives_Native.None)) + FStar_Pervasives_Native.None + "FStarC.TypeChecker.Core.maybe_unfold_side" in + let maybe_unfold t01 t11 ctx01 = + let uu___4 = unfolding_ok ctx01 in + match uu___4 with + | Success (x1, g11) -> + let uu___5 = + let uu___6 = + if x1 + then + let uu___7 = + let uu___8 = which_side_to_unfold t01 t11 in + maybe_unfold_side uu___8 t01 t11 in + fun uu___8 -> + Success + (uu___7, FStar_Pervasives_Native.None) + else + (fun uu___8 -> + Success + (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None)) in + uu___6 ctx01 in + (match uu___5 with + | Success (y, g2) -> + let uu___6 = + let uu___7 = and_pre g11 g2 in (y, uu___7) in + Success uu___6 + | err1 -> err1) + | Error err1 -> Error err1 in + let emit_guard t01 t11 = + let uu___4 ctx = + let ctx1 = + { + no_guard = (ctx.no_guard); + unfolding_ok = (ctx.unfolding_ok); + error_context = + (("checking lhs while emitting guard", + FStar_Pervasives_Native.None) :: + (ctx.error_context)) + } in + let uu___5 = do_check g t01 in uu___5 ctx1 in + fun ctx01 -> + let uu___5 = uu___4 ctx01 in + match uu___5 with + | Success (x1, g11) -> + let uu___6 = + let uu___7 = + match x1 with + | (uu___8, t_typ) -> + let uu___9 = universe_of g t_typ in + (fun ctx02 -> + let uu___10 = uu___9 ctx02 in + match uu___10 with + | Success (x2, g12) -> + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Syntax_Util.mk_eq2 + x2 t_typ t01 t11 in + guard uu___13 in + uu___12 ctx02 in + (match uu___11 with + | Success (y, g2) -> + let uu___12 = + let uu___13 = + and_pre g12 g2 in + ((), uu___13) in + Success uu___12 + | err1 -> err1) + | Error err1 -> Error err1) in + uu___7 ctx01 in + (match uu___6 with + | Success (y, g2) -> + let uu___7 = + let uu___8 = and_pre g11 g2 in + ((), uu___8) in + Success uu___7 + | err1 -> err1) + | Error err1 -> Error err1 in + let fallback t01 t11 = + if guard_ok + then + let uu___4 = (equatable g t01) || (equatable g t11) in + (if uu___4 then emit_guard t01 t11 else err ()) + else err () in + let maybe_unfold_side_and_retry side1 t01 t11 ctx01 = + let uu___4 = unfolding_ok ctx01 in + match uu___4 with + | Success (x1, g11) -> + let uu___5 = + let uu___6 = + if x1 + then + let uu___7 = maybe_unfold_side side1 t01 t11 in + match uu___7 with + | FStar_Pervasives_Native.None -> + fallback t01 t11 + | FStar_Pervasives_Native.Some (t02, t12) -> + check_relation g rel t02 t12 + else fallback t01 t11 in + uu___6 ctx01 in + (match uu___5 with + | Success (y, g2) -> + let uu___6 = + let uu___7 = and_pre g11 g2 in ((), uu___7) in + Success uu___6 + | err1 -> err1) + | Error err1 -> Error err1 in + let maybe_unfold_and_retry t01 t11 = + let uu___4 = which_side_to_unfold t01 t11 in + maybe_unfold_side_and_retry uu___4 t01 t11 in + let beta_iota_reduce t = + let t2 = FStarC_Syntax_Subst.compress t in + let t3 = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.HNF; + FStarC_TypeChecker_Env.Weak; + FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Iota; + FStarC_TypeChecker_Env.Primops] g.tcenv t2 in + match t3.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_refine uu___4 -> + FStarC_Syntax_Util.flatten_refinement t3 + | uu___4 -> t3 in + let beta_iota_reduce1 t = + FStarC_Profiling.profile + (fun uu___4 -> beta_iota_reduce t) + FStar_Pervasives_Native.None + "FStarC.TypeChecker.Core.beta_iota_reduce" in + let t01 = + let uu___4 = + let uu___5 = beta_iota_reduce1 t0 in + FStarC_Syntax_Subst.compress uu___5 in + FStarC_Syntax_Util.unlazy_emb uu___4 in + let t11 = + let uu___4 = + let uu___5 = beta_iota_reduce1 t1 in + FStarC_Syntax_Subst.compress uu___5 in + FStarC_Syntax_Util.unlazy_emb uu___4 in + let check_relation1 g2 rel1 t02 t12 ctx = + let ctx1 = + { + no_guard = (ctx.no_guard); + unfolding_ok = (ctx.unfolding_ok); + error_context = + (("check_relation", + (FStar_Pervasives_Native.Some + (CtxRel (t02, rel1, t12)))) :: + (ctx.error_context)) + } in + let uu___4 = check_relation g2 rel1 t02 t12 in + uu___4 ctx1 in + let uu___4 = equal_term t01 t11 in + if uu___4 + then + fun uu___5 -> + Success ((), FStar_Pervasives_Native.None) + else + (match ((t01.FStarC_Syntax_Syntax.n), + (t11.FStarC_Syntax_Syntax.n)) + with + | (FStarC_Syntax_Syntax.Tm_type u0, + FStarC_Syntax_Syntax.Tm_type u1) -> + let uu___6 = + FStarC_TypeChecker_Rel.teq_nosmt_force + g.tcenv t01 t11 in + if uu___6 + then + (fun uu___7 -> + Success ((), FStar_Pervasives_Native.None)) + else err () + | (FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t02; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_pattern uu___6;_}, + uu___7) -> check_relation1 g rel t02 t11 + | (FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t02; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_named uu___6;_}, + uu___7) -> check_relation1 g rel t02 t11 + | (FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t02; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_labeled uu___6;_}, + uu___7) -> check_relation1 g rel t02 t11 + | (FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t02; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_desugared uu___6;_}, + uu___7) -> check_relation1 g rel t02 t11 + | (FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t02; + FStarC_Syntax_Syntax.asc = uu___6; + FStarC_Syntax_Syntax.eff_opt = uu___7;_}, + uu___8) -> check_relation1 g rel t02 t11 + | (uu___6, FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t12; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_pattern uu___7;_}) + -> check_relation1 g rel t01 t12 + | (uu___6, FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t12; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_named uu___7;_}) + -> check_relation1 g rel t01 t12 + | (uu___6, FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t12; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_labeled uu___7;_}) + -> check_relation1 g rel t01 t12 + | (uu___6, FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t12; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_desugared uu___7;_}) + -> check_relation1 g rel t01 t12 + | (uu___6, FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t12; + FStarC_Syntax_Syntax.asc = uu___7; + FStarC_Syntax_Syntax.eff_opt = uu___8;_}) + -> check_relation1 g rel t01 t12 + | (FStarC_Syntax_Syntax.Tm_uinst (f0, us0), + FStarC_Syntax_Syntax.Tm_uinst (f1, us1)) -> + let uu___6 = equal_term f0 f1 in + if uu___6 + then + let uu___7 = + FStarC_TypeChecker_Rel.teq_nosmt_force + g.tcenv t01 t11 in + (if uu___7 + then + fun uu___8 -> + Success ((), FStar_Pervasives_Native.None) + else err ()) + else maybe_unfold_and_retry t01 t11 + | (FStarC_Syntax_Syntax.Tm_fvar uu___6, + FStarC_Syntax_Syntax.Tm_fvar uu___7) -> + maybe_unfold_and_retry t01 t11 + | (FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x0; + FStarC_Syntax_Syntax.phi = f0;_}, + FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x1; + FStarC_Syntax_Syntax.phi = f1;_}) + -> + let uu___6 = + head_matches x0.FStarC_Syntax_Syntax.sort + x1.FStarC_Syntax_Syntax.sort in + if uu___6 + then + let uu___7 = + check_relation1 g EQUALITY + x0.FStarC_Syntax_Syntax.sort + x1.FStarC_Syntax_Syntax.sort in + (fun ctx01 -> + let uu___8 = uu___7 ctx01 in + match uu___8 with + | Success (x2, g11) -> + let uu___9 = + let uu___10 = + let uu___11 = + universe_of g + x0.FStarC_Syntax_Syntax.sort in + fun ctx02 -> + let uu___12 = uu___11 ctx02 in + match uu___12 with + | Success (x3, g12) -> + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = + FStarC_Syntax_Syntax.mk_binder + x0 in + open_term g uu___16 f0 in + match uu___15 with + | (g2, b, f01) -> + let f11 = + FStarC_Syntax_Subst.subst + [FStarC_Syntax_Syntax.DB + (Prims.int_zero, + (b.FStarC_Syntax_Syntax.binder_bv))] + f1 in + (fun ctx03 -> + let uu___16 = + guard_not_allowed + ctx03 in + match uu___16 with + | Success (x4, g13) + -> + let uu___17 = + let uu___18 = + if x4 + then + let uu___19 + = + check_relation1 + g2 + EQUALITY + f01 f11 in + with_binders + [b] + [x3] + uu___19 + else + ( + match rel + with + | + EQUALITY + -> + let uu___20 + = + let uu___21 + = + check_relation1 + g2 + EQUALITY + f01 f11 in + fun ctx + -> + let uu___22 + = + uu___21 + ctx in + match uu___22 + with + | + Error + uu___23 + -> + let uu___24 + = + let uu___25 + = + FStarC_Syntax_Util.mk_iff + f01 f11 in + guard + uu___25 in + uu___24 + ctx + | + res -> + res in + with_binders + [b] + [x3] + uu___20 + | + SUBTYPING + (FStar_Pervasives_Native.Some + tm) -> + let uu___20 + = + let uu___21 + = + FStarC_Syntax_Util.mk_imp + f01 f11 in + FStarC_Syntax_Subst.subst + [ + FStarC_Syntax_Syntax.NT + ((b.FStarC_Syntax_Syntax.binder_bv), + tm)] + uu___21 in + guard + uu___20 + | + SUBTYPING + (FStar_Pervasives_Native.None) + -> + let uu___20 + = + let uu___21 + = + FStarC_Syntax_Util.mk_imp + f01 f11 in + FStarC_Syntax_Util.mk_forall + x3 + b.FStarC_Syntax_Syntax.binder_bv + uu___21 in + guard + uu___20) in + uu___18 ctx03 in + (match uu___17 + with + | Success + (y, g21) + -> + let uu___18 + = + let uu___19 + = + and_pre + g13 g21 in + ((), + uu___19) in + Success + uu___18 + | err1 -> err1) + | Error err1 -> + Error err1) in + uu___14 ctx02 in + (match uu___13 with + | Success (y, g2) -> + let uu___14 = + let uu___15 = + and_pre g12 g2 in + ((), uu___15) in + Success uu___14 + | err1 -> err1) + | Error err1 -> Error err1 in + uu___10 ctx01 in + (match uu___9 with + | Success (y, g2) -> + let uu___10 = + let uu___11 = and_pre g11 g2 in + ((), uu___11) in + Success uu___10 + | err1 -> err1) + | Error err1 -> Error err1) + else + (let uu___8 = + maybe_unfold x0.FStarC_Syntax_Syntax.sort + x1.FStarC_Syntax_Syntax.sort in + fun ctx01 -> + let uu___9 = uu___8 ctx01 in + match uu___9 with + | Success (x2, g11) -> + let uu___10 = + let uu___11 = + match x2 with + | FStar_Pervasives_Native.None -> + ((let uu___13 = + FStarC_Compiler_Effect.op_Bang + dbg in + if uu___13 + then + let uu___14 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + x0.FStarC_Syntax_Syntax.sort in + let uu___15 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + x1.FStarC_Syntax_Syntax.sort in + FStarC_Compiler_Util.print2 + "Cannot match ref heads %s and %s\n" + uu___14 uu___15 + else ()); + fallback t01 t11) + | FStar_Pervasives_Native.Some + (t02, t12) -> + let lhs = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_refine + { + FStarC_Syntax_Syntax.b + = + { + FStarC_Syntax_Syntax.ppname + = + (x0.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index + = + (x0.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort + = t02 + }; + FStarC_Syntax_Syntax.phi + = f0 + }) + t02.FStarC_Syntax_Syntax.pos in + let rhs = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_refine + { + FStarC_Syntax_Syntax.b + = + { + FStarC_Syntax_Syntax.ppname + = + (x1.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index + = + (x1.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort + = t12 + }; + FStarC_Syntax_Syntax.phi + = f1 + }) + t12.FStarC_Syntax_Syntax.pos in + let uu___12 = + FStarC_Syntax_Util.flatten_refinement + lhs in + let uu___13 = + FStarC_Syntax_Util.flatten_refinement + rhs in + check_relation1 g rel uu___12 + uu___13 in + uu___11 ctx01 in + (match uu___10 with + | Success (y, g2) -> + let uu___11 = + let uu___12 = and_pre g11 g2 in + ((), uu___12) in + Success uu___11 + | err1 -> err1) + | Error err1 -> Error err1) + | (FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x0; + FStarC_Syntax_Syntax.phi = f0;_}, + uu___6) -> + let uu___7 = + head_matches x0.FStarC_Syntax_Syntax.sort t11 in + if uu___7 + then + let uu___8 = + if rel = EQUALITY + then + let uu___9 = + universe_of g + x0.FStarC_Syntax_Syntax.sort in + fun ctx01 -> + let uu___10 = uu___9 ctx01 in + match uu___10 with + | Success (x1, g11) -> + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_Syntax_Syntax.mk_binder + x0 in + open_term g uu___14 f0 in + match uu___13 with + | (g2, b0, f01) -> + (fun ctx02 -> + let uu___14 = + guard_not_allowed ctx02 in + match uu___14 with + | Success (x2, g12) -> + let uu___15 = + let uu___16 = + if x2 + then + let uu___17 = + check_relation1 + g2 EQUALITY + FStarC_Syntax_Util.t_true + f01 in + with_binders + [b0] [x1] + uu___17 + else + (let uu___18 = + let uu___19 = + check_relation1 + g2 + EQUALITY + FStarC_Syntax_Util.t_true + f01 in + fun ctx -> + let uu___20 + = + uu___19 + ctx in + match uu___20 + with + | Error + uu___21 + -> + let uu___22 + = + guard f01 in + uu___22 + ctx + | res -> + res in + with_binders + [b0] + [x1] uu___18) in + uu___16 ctx02 in + (match uu___15 with + | Success (y, g21) -> + let uu___16 = + let uu___17 = + and_pre g12 + g21 in + ((), uu___17) in + Success uu___16 + | err1 -> err1) + | Error err1 -> Error err1) in + uu___12 ctx01 in + (match uu___11 with + | Success (y, g2) -> + let uu___12 = + let uu___13 = and_pre g11 g2 in + ((), uu___13) in + Success uu___12 + | err1 -> err1) + | Error err1 -> Error err1 + else + (fun uu___10 -> + Success + ((), FStar_Pervasives_Native.None)) in + (fun ctx01 -> + let uu___9 = uu___8 ctx01 in + match uu___9 with + | Success (x1, g11) -> + let uu___10 = + let uu___11 = + check_relation1 g rel + x0.FStarC_Syntax_Syntax.sort t11 in + uu___11 ctx01 in + (match uu___10 with + | Success (y, g2) -> + let uu___11 = + let uu___12 = and_pre g11 g2 in + ((), uu___12) in + Success uu___11 + | err1 -> err1) + | Error err1 -> Error err1) + else + (let uu___9 = + maybe_unfold x0.FStarC_Syntax_Syntax.sort + t11 in + fun ctx01 -> + let uu___10 = uu___9 ctx01 in + match uu___10 with + | Success (x1, g11) -> + let uu___11 = + let uu___12 = + match x1 with + | FStar_Pervasives_Native.None -> + fallback t01 t11 + | FStar_Pervasives_Native.Some + (t02, t12) -> + let lhs = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_refine + { + FStarC_Syntax_Syntax.b + = + { + FStarC_Syntax_Syntax.ppname + = + (x0.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index + = + (x0.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort + = t02 + }; + FStarC_Syntax_Syntax.phi + = f0 + }) + t02.FStarC_Syntax_Syntax.pos in + let uu___13 = + FStarC_Syntax_Util.flatten_refinement + lhs in + check_relation1 g rel uu___13 + t12 in + uu___12 ctx01 in + (match uu___11 with + | Success (y, g2) -> + let uu___12 = + let uu___13 = and_pre g11 g2 in + ((), uu___13) in + Success uu___12 + | err1 -> err1) + | Error err1 -> Error err1) + | (uu___6, FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x1; + FStarC_Syntax_Syntax.phi = f1;_}) + -> + let uu___7 = + head_matches t01 x1.FStarC_Syntax_Syntax.sort in + if uu___7 + then + let uu___8 = + universe_of g x1.FStarC_Syntax_Syntax.sort in + (fun ctx01 -> + let uu___9 = uu___8 ctx01 in + match uu___9 with + | Success (x2, g11) -> + let uu___10 = + let uu___11 = + let uu___12 = + check_relation1 g EQUALITY t01 + x1.FStarC_Syntax_Syntax.sort in + fun ctx02 -> + let uu___13 = uu___12 ctx02 in + match uu___13 with + | Success (x3, g12) -> + let uu___14 = + let uu___15 = + let uu___16 = + let uu___17 = + FStarC_Syntax_Syntax.mk_binder + x1 in + open_term g uu___17 f1 in + match uu___16 with + | (g2, b1, f11) -> + (fun ctx03 -> + let uu___17 = + guard_not_allowed + ctx03 in + match uu___17 with + | Success (x4, g13) + -> + let uu___18 = + let uu___19 = + if x4 + then + let uu___20 + = + check_relation1 + g2 + EQUALITY + FStarC_Syntax_Util.t_true + f11 in + with_binders + [b1] + [x2] + uu___20 + else + ( + match rel + with + | + EQUALITY + -> + let uu___21 + = + let uu___22 + = + check_relation1 + g2 + EQUALITY + FStarC_Syntax_Util.t_true + f11 in + fun ctx + -> + let uu___23 + = + uu___22 + ctx in + match uu___23 + with + | + Error + uu___24 + -> + let uu___25 + = + guard f11 in + uu___25 + ctx + | + res -> + res in + with_binders + [b1] + [x2] + uu___21 + | + SUBTYPING + (FStar_Pervasives_Native.Some + tm) -> + let uu___21 + = + FStarC_Syntax_Subst.subst + [ + FStarC_Syntax_Syntax.NT + ((b1.FStarC_Syntax_Syntax.binder_bv), + tm)] f11 in + guard + uu___21 + | + SUBTYPING + (FStar_Pervasives_Native.None) + -> + let uu___21 + = + FStarC_Syntax_Util.mk_forall + x2 + b1.FStarC_Syntax_Syntax.binder_bv + f11 in + guard + uu___21) in + uu___19 ctx03 in + (match uu___18 + with + | Success + (y, g21) + -> + let uu___19 + = + let uu___20 + = + and_pre + g13 g21 in + ((), + uu___20) in + Success + uu___19 + | err1 -> err1) + | Error err1 -> + Error err1) in + uu___15 ctx02 in + (match uu___14 with + | Success (y, g2) -> + let uu___15 = + let uu___16 = + and_pre g12 g2 in + ((), uu___16) in + Success uu___15 + | err1 -> err1) + | Error err1 -> Error err1 in + uu___11 ctx01 in + (match uu___10 with + | Success (y, g2) -> + let uu___11 = + let uu___12 = and_pre g11 g2 in + ((), uu___12) in + Success uu___11 + | err1 -> err1) + | Error err1 -> Error err1) + else + (let uu___9 = + maybe_unfold t01 + x1.FStarC_Syntax_Syntax.sort in + fun ctx01 -> + let uu___10 = uu___9 ctx01 in + match uu___10 with + | Success (x2, g11) -> + let uu___11 = + let uu___12 = + match x2 with + | FStar_Pervasives_Native.None -> + fallback t01 t11 + | FStar_Pervasives_Native.Some + (t02, t12) -> + let rhs = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_refine + { + FStarC_Syntax_Syntax.b + = + { + FStarC_Syntax_Syntax.ppname + = + (x1.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index + = + (x1.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort + = t12 + }; + FStarC_Syntax_Syntax.phi + = f1 + }) + t12.FStarC_Syntax_Syntax.pos in + let uu___13 = + FStarC_Syntax_Util.flatten_refinement + rhs in + check_relation1 g rel t02 + uu___13 in + uu___12 ctx01 in + (match uu___11 with + | Success (y, g2) -> + let uu___12 = + let uu___13 = and_pre g11 g2 in + ((), uu___13) in + Success uu___12 + | err1 -> err1) + | Error err1 -> Error err1) + | (FStarC_Syntax_Syntax.Tm_uinst uu___6, uu___7) -> + let head_matches1 = head_matches t01 t11 in + let uu___8 = + FStarC_Syntax_Util.leftmost_head_and_args t01 in + (match uu___8 with + | (head0, args0) -> + let uu___9 = + FStarC_Syntax_Util.leftmost_head_and_args + t11 in + (match uu___9 with + | (head1, args1) -> + if + Prims.op_Negation + (head_matches1 && + ((FStarC_Compiler_List.length + args0) + = + (FStarC_Compiler_List.length + args1))) + then maybe_unfold_and_retry t01 t11 + else + (let compare_head_and_args uu___11 = + let uu___12 = + let uu___13 = + check_relation1 g EQUALITY + head0 head1 in + fun ctx01 -> + let uu___14 = uu___13 ctx01 in + match uu___14 with + | Success (x1, g11) -> + let uu___15 = + let uu___16 = + check_relation_args g + EQUALITY args0 args1 in + uu___16 ctx01 in + (match uu___15 with + | Success (y, g2) -> + let uu___16 = + let uu___17 = + and_pre g11 g2 in + ((), uu___17) in + Success uu___16 + | err1 -> err1) + | Error err1 -> Error err1 in + fun ctx -> + let uu___13 = uu___12 ctx in + match uu___13 with + | Error uu___14 -> + let uu___15 = + maybe_unfold_side_and_retry + Both t01 t11 in + uu___15 ctx + | res -> res in + let uu___11 = + (guard_ok && (rel = EQUALITY)) && + ((equatable g t01) || + (equatable g t11)) in + if uu___11 + then + let uu___12 = + let uu___13 = + compare_head_and_args () in + no_guard uu___13 in + fun ctx -> + let uu___13 = uu___12 ctx in + match uu___13 with + | Error uu___14 -> + let uu___15 = + emit_guard t01 t11 in + uu___15 ctx + | res -> res + else compare_head_and_args ()))) + | (FStarC_Syntax_Syntax.Tm_fvar uu___6, uu___7) -> + let head_matches1 = head_matches t01 t11 in + let uu___8 = + FStarC_Syntax_Util.leftmost_head_and_args t01 in + (match uu___8 with + | (head0, args0) -> + let uu___9 = + FStarC_Syntax_Util.leftmost_head_and_args + t11 in + (match uu___9 with + | (head1, args1) -> + if + Prims.op_Negation + (head_matches1 && + ((FStarC_Compiler_List.length + args0) + = + (FStarC_Compiler_List.length + args1))) + then maybe_unfold_and_retry t01 t11 + else + (let compare_head_and_args uu___11 = + let uu___12 = + let uu___13 = + check_relation1 g EQUALITY + head0 head1 in + fun ctx01 -> + let uu___14 = uu___13 ctx01 in + match uu___14 with + | Success (x1, g11) -> + let uu___15 = + let uu___16 = + check_relation_args g + EQUALITY args0 args1 in + uu___16 ctx01 in + (match uu___15 with + | Success (y, g2) -> + let uu___16 = + let uu___17 = + and_pre g11 g2 in + ((), uu___17) in + Success uu___16 + | err1 -> err1) + | Error err1 -> Error err1 in + fun ctx -> + let uu___13 = uu___12 ctx in + match uu___13 with + | Error uu___14 -> + let uu___15 = + maybe_unfold_side_and_retry + Both t01 t11 in + uu___15 ctx + | res -> res in + let uu___11 = + (guard_ok && (rel = EQUALITY)) && + ((equatable g t01) || + (equatable g t11)) in + if uu___11 + then + let uu___12 = + let uu___13 = + compare_head_and_args () in + no_guard uu___13 in + fun ctx -> + let uu___13 = uu___12 ctx in + match uu___13 with + | Error uu___14 -> + let uu___15 = + emit_guard t01 t11 in + uu___15 ctx + | res -> res + else compare_head_and_args ()))) + | (FStarC_Syntax_Syntax.Tm_app uu___6, uu___7) -> + let head_matches1 = head_matches t01 t11 in + let uu___8 = + FStarC_Syntax_Util.leftmost_head_and_args t01 in + (match uu___8 with + | (head0, args0) -> + let uu___9 = + FStarC_Syntax_Util.leftmost_head_and_args + t11 in + (match uu___9 with + | (head1, args1) -> + if + Prims.op_Negation + (head_matches1 && + ((FStarC_Compiler_List.length + args0) + = + (FStarC_Compiler_List.length + args1))) + then maybe_unfold_and_retry t01 t11 + else + (let compare_head_and_args uu___11 = + let uu___12 = + let uu___13 = + check_relation1 g EQUALITY + head0 head1 in + fun ctx01 -> + let uu___14 = uu___13 ctx01 in + match uu___14 with + | Success (x1, g11) -> + let uu___15 = + let uu___16 = + check_relation_args g + EQUALITY args0 args1 in + uu___16 ctx01 in + (match uu___15 with + | Success (y, g2) -> + let uu___16 = + let uu___17 = + and_pre g11 g2 in + ((), uu___17) in + Success uu___16 + | err1 -> err1) + | Error err1 -> Error err1 in + fun ctx -> + let uu___13 = uu___12 ctx in + match uu___13 with + | Error uu___14 -> + let uu___15 = + maybe_unfold_side_and_retry + Both t01 t11 in + uu___15 ctx + | res -> res in + let uu___11 = + (guard_ok && (rel = EQUALITY)) && + ((equatable g t01) || + (equatable g t11)) in + if uu___11 + then + let uu___12 = + let uu___13 = + compare_head_and_args () in + no_guard uu___13 in + fun ctx -> + let uu___13 = uu___12 ctx in + match uu___13 with + | Error uu___14 -> + let uu___15 = + emit_guard t01 t11 in + uu___15 ctx + | res -> res + else compare_head_and_args ()))) + | (uu___6, FStarC_Syntax_Syntax.Tm_uinst uu___7) -> + let head_matches1 = head_matches t01 t11 in + let uu___8 = + FStarC_Syntax_Util.leftmost_head_and_args t01 in + (match uu___8 with + | (head0, args0) -> + let uu___9 = + FStarC_Syntax_Util.leftmost_head_and_args + t11 in + (match uu___9 with + | (head1, args1) -> + if + Prims.op_Negation + (head_matches1 && + ((FStarC_Compiler_List.length + args0) + = + (FStarC_Compiler_List.length + args1))) + then maybe_unfold_and_retry t01 t11 + else + (let compare_head_and_args uu___11 = + let uu___12 = + let uu___13 = + check_relation1 g EQUALITY + head0 head1 in + fun ctx01 -> + let uu___14 = uu___13 ctx01 in + match uu___14 with + | Success (x1, g11) -> + let uu___15 = + let uu___16 = + check_relation_args g + EQUALITY args0 args1 in + uu___16 ctx01 in + (match uu___15 with + | Success (y, g2) -> + let uu___16 = + let uu___17 = + and_pre g11 g2 in + ((), uu___17) in + Success uu___16 + | err1 -> err1) + | Error err1 -> Error err1 in + fun ctx -> + let uu___13 = uu___12 ctx in + match uu___13 with + | Error uu___14 -> + let uu___15 = + maybe_unfold_side_and_retry + Both t01 t11 in + uu___15 ctx + | res -> res in + let uu___11 = + (guard_ok && (rel = EQUALITY)) && + ((equatable g t01) || + (equatable g t11)) in + if uu___11 + then + let uu___12 = + let uu___13 = + compare_head_and_args () in + no_guard uu___13 in + fun ctx -> + let uu___13 = uu___12 ctx in + match uu___13 with + | Error uu___14 -> + let uu___15 = + emit_guard t01 t11 in + uu___15 ctx + | res -> res + else compare_head_and_args ()))) + | (uu___6, FStarC_Syntax_Syntax.Tm_fvar uu___7) -> + let head_matches1 = head_matches t01 t11 in + let uu___8 = + FStarC_Syntax_Util.leftmost_head_and_args t01 in + (match uu___8 with + | (head0, args0) -> + let uu___9 = + FStarC_Syntax_Util.leftmost_head_and_args + t11 in + (match uu___9 with + | (head1, args1) -> + if + Prims.op_Negation + (head_matches1 && + ((FStarC_Compiler_List.length + args0) + = + (FStarC_Compiler_List.length + args1))) + then maybe_unfold_and_retry t01 t11 + else + (let compare_head_and_args uu___11 = + let uu___12 = + let uu___13 = + check_relation1 g EQUALITY + head0 head1 in + fun ctx01 -> + let uu___14 = uu___13 ctx01 in + match uu___14 with + | Success (x1, g11) -> + let uu___15 = + let uu___16 = + check_relation_args g + EQUALITY args0 args1 in + uu___16 ctx01 in + (match uu___15 with + | Success (y, g2) -> + let uu___16 = + let uu___17 = + and_pre g11 g2 in + ((), uu___17) in + Success uu___16 + | err1 -> err1) + | Error err1 -> Error err1 in + fun ctx -> + let uu___13 = uu___12 ctx in + match uu___13 with + | Error uu___14 -> + let uu___15 = + maybe_unfold_side_and_retry + Both t01 t11 in + uu___15 ctx + | res -> res in + let uu___11 = + (guard_ok && (rel = EQUALITY)) && + ((equatable g t01) || + (equatable g t11)) in + if uu___11 + then + let uu___12 = + let uu___13 = + compare_head_and_args () in + no_guard uu___13 in + fun ctx -> + let uu___13 = uu___12 ctx in + match uu___13 with + | Error uu___14 -> + let uu___15 = + emit_guard t01 t11 in + uu___15 ctx + | res -> res + else compare_head_and_args ()))) + | (uu___6, FStarC_Syntax_Syntax.Tm_app uu___7) -> + let head_matches1 = head_matches t01 t11 in + let uu___8 = + FStarC_Syntax_Util.leftmost_head_and_args t01 in + (match uu___8 with + | (head0, args0) -> + let uu___9 = + FStarC_Syntax_Util.leftmost_head_and_args + t11 in + (match uu___9 with + | (head1, args1) -> + if + Prims.op_Negation + (head_matches1 && + ((FStarC_Compiler_List.length + args0) + = + (FStarC_Compiler_List.length + args1))) + then maybe_unfold_and_retry t01 t11 + else + (let compare_head_and_args uu___11 = + let uu___12 = + let uu___13 = + check_relation1 g EQUALITY + head0 head1 in + fun ctx01 -> + let uu___14 = uu___13 ctx01 in + match uu___14 with + | Success (x1, g11) -> + let uu___15 = + let uu___16 = + check_relation_args g + EQUALITY args0 args1 in + uu___16 ctx01 in + (match uu___15 with + | Success (y, g2) -> + let uu___16 = + let uu___17 = + and_pre g11 g2 in + ((), uu___17) in + Success uu___16 + | err1 -> err1) + | Error err1 -> Error err1 in + fun ctx -> + let uu___13 = uu___12 ctx in + match uu___13 with + | Error uu___14 -> + let uu___15 = + maybe_unfold_side_and_retry + Both t01 t11 in + uu___15 ctx + | res -> res in + let uu___11 = + (guard_ok && (rel = EQUALITY)) && + ((equatable g t01) || + (equatable g t11)) in + if uu___11 + then + let uu___12 = + let uu___13 = + compare_head_and_args () in + no_guard uu___13 in + fun ctx -> + let uu___13 = uu___12 ctx in + match uu___13 with + | Error uu___14 -> + let uu___15 = + emit_guard t01 t11 in + uu___15 ctx + | res -> res + else compare_head_and_args ()))) + | (FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = b0::b1::bs; + FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = ropt;_}, + uu___6) -> + let t02 = curry_abs b0 b1 bs body ropt in + check_relation1 g rel t02 t11 + | (uu___6, FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = b0::b1::bs; + FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = ropt;_}) + -> + let t12 = curry_abs b0 b1 bs body ropt in + check_relation1 g rel t01 t12 + | (FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = b0::[]; + FStarC_Syntax_Syntax.body = body0; + FStarC_Syntax_Syntax.rc_opt = uu___6;_}, + FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = b1::[]; + FStarC_Syntax_Syntax.body = body1; + FStarC_Syntax_Syntax.rc_opt = uu___7;_}) + -> + let uu___8 = + check_relation1 g EQUALITY + (b0.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort + (b1.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + (fun ctx01 -> + let uu___9 = uu___8 ctx01 in + match uu___9 with + | Success (x1, g11) -> + let uu___10 = + let uu___11 = + let uu___12 = + check_bqual + b0.FStarC_Syntax_Syntax.binder_qual + b1.FStarC_Syntax_Syntax.binder_qual in + fun ctx02 -> + let uu___13 = uu___12 ctx02 in + match uu___13 with + | Success (x2, g12) -> + let uu___14 = + let uu___15 = + let uu___16 = + check_positivity_qual + EQUALITY + b0.FStarC_Syntax_Syntax.binder_positivity + b1.FStarC_Syntax_Syntax.binder_positivity in + fun ctx03 -> + let uu___17 = + uu___16 ctx03 in + match uu___17 with + | Success (x3, g13) -> + let uu___18 = + let uu___19 = + let uu___20 = + universe_of g + (b0.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + fun ctx04 -> + let uu___21 = + uu___20 ctx04 in + match uu___21 + with + | Success + (x4, g14) -> + let uu___22 + = + let uu___23 + = + let uu___24 + = + open_term + g b0 + body0 in + match uu___24 + with + | + (g2, b01, + body01) + -> + let body11 + = + FStarC_Syntax_Subst.subst + [ + FStarC_Syntax_Syntax.DB + (Prims.int_zero, + (b01.FStarC_Syntax_Syntax.binder_bv))] + body1 in + let uu___25 + = + check_relation1 + g2 + EQUALITY + body01 + body11 in + with_binders + [b01] + [x4] + uu___25 in + uu___23 + ctx04 in + (match uu___22 + with + | Success + (y, g2) + -> + let uu___23 + = + let uu___24 + = + and_pre + g14 g2 in + ((), + uu___24) in + Success + uu___23 + | err1 -> + err1) + | Error err1 -> + Error err1 in + uu___19 ctx03 in + (match uu___18 with + | Success (y, g2) -> + let uu___19 = + let uu___20 = + and_pre g13 + g2 in + ((), uu___20) in + Success uu___19 + | err1 -> err1) + | Error err1 -> Error err1 in + uu___15 ctx02 in + (match uu___14 with + | Success (y, g2) -> + let uu___15 = + let uu___16 = + and_pre g12 g2 in + ((), uu___16) in + Success uu___15 + | err1 -> err1) + | Error err1 -> Error err1 in + uu___11 ctx01 in + (match uu___10 with + | Success (y, g2) -> + let uu___11 = + let uu___12 = and_pre g11 g2 in + ((), uu___12) in + Success uu___11 + | err1 -> err1) + | Error err1 -> Error err1) + | (FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = x0::x1::xs; + FStarC_Syntax_Syntax.comp = c0;_}, + uu___6) -> + let uu___7 = curry_arrow x0 (x1 :: xs) c0 in + check_relation1 g rel uu___7 t11 + | (uu___6, FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = x0::x1::xs; + FStarC_Syntax_Syntax.comp = c1;_}) + -> + let uu___7 = curry_arrow x0 (x1 :: xs) c1 in + check_relation1 g rel t01 uu___7 + | (FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = x0::[]; + FStarC_Syntax_Syntax.comp = c0;_}, + FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = x1::[]; + FStarC_Syntax_Syntax.comp = c1;_}) + -> + (fun ctx -> + let ctx1 = + { + no_guard = (ctx.no_guard); + unfolding_ok = (ctx.unfolding_ok); + error_context = + (("subtype arrow", + FStar_Pervasives_Native.None) :: + (ctx.error_context)) + } in + let uu___6 = + let uu___7 = + check_bqual + x0.FStarC_Syntax_Syntax.binder_qual + x1.FStarC_Syntax_Syntax.binder_qual in + fun ctx01 -> + let uu___8 = uu___7 ctx01 in + match uu___8 with + | Success (x2, g11) -> + let uu___9 = + let uu___10 = + let uu___11 = + check_positivity_qual rel + x0.FStarC_Syntax_Syntax.binder_positivity + x1.FStarC_Syntax_Syntax.binder_positivity in + fun ctx02 -> + let uu___12 = uu___11 ctx02 in + match uu___12 with + | Success (x3, g12) -> + let uu___13 = + let uu___14 = + let uu___15 = + universe_of g + (x1.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + fun ctx03 -> + let uu___16 = + uu___15 ctx03 in + match uu___16 with + | Success (x4, g13) -> + let uu___17 = + let uu___18 = + let uu___19 = + open_comp g + x1 c1 in + match uu___19 + with + | (g_x1, x11, + c11) -> + let c01 = + FStarC_Syntax_Subst.subst_comp + [ + FStarC_Syntax_Syntax.DB + (Prims.int_zero, + (x11.FStarC_Syntax_Syntax.binder_bv))] + c0 in + let uu___20 + = + let rel_arg + = + match rel + with + | + EQUALITY + -> + EQUALITY + | + uu___21 + -> + let uu___22 + = + let uu___23 + = + FStarC_Syntax_Syntax.bv_to_name + x11.FStarC_Syntax_Syntax.binder_bv in + FStar_Pervasives_Native.Some + uu___23 in + SUBTYPING + uu___22 in + let rel_comp + = + match rel + with + | + EQUALITY + -> + EQUALITY + | + SUBTYPING + e -> + let uu___21 + = + let uu___22 + = + FStarC_Syntax_Util.is_pure_or_ghost_comp + c01 in + if + uu___22 + then + op_let_Question + e + (fun e1 + -> + let uu___23 + = + let uu___24 + = + let uu___25 + = + FStarC_Syntax_Util.args_of_binders + [x11] in + FStar_Pervasives_Native.snd + uu___25 in + FStarC_Syntax_Syntax.mk_Tm_app + e1 + uu___24 + FStarC_Compiler_Range_Type.dummyRange in + FStar_Pervasives_Native.Some + uu___23) + else + FStar_Pervasives_Native.None in + SUBTYPING + uu___21 in + let uu___21 + = + check_relation1 + g rel + (x11.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort + (x0.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + fun ctx04 + -> + let uu___22 + = + uu___21 + ctx04 in + match uu___22 + with + | + Success + (x5, g14) + -> + let uu___23 + = + let uu___24 + ctx2 = + let ctx3 + = + { + no_guard + = + (ctx2.no_guard); + unfolding_ok + = + (ctx2.unfolding_ok); + error_context + = + (("check_subcomp", + FStar_Pervasives_Native.None) + :: + (ctx2.error_context)) + } in + let uu___25 + = + check_relation_comp + g_x1 + rel_comp + c01 c11 in + uu___25 + ctx3 in + uu___24 + ctx04 in + (match uu___23 + with + | + Success + (y, g2) + -> + let uu___24 + = + let uu___25 + = + and_pre + g14 g2 in + ((), + uu___25) in + Success + uu___24 + | + err1 -> + err1) + | + Error + err1 -> + Error + err1 in + with_binders + [x11] + [x4] + uu___20 in + uu___18 ctx03 in + (match uu___17 + with + | Success + (y, g2) -> + let uu___18 = + let uu___19 + = + and_pre + g13 g2 in + ((), + uu___19) in + Success + uu___18 + | err1 -> err1) + | Error err1 -> + Error err1 in + uu___14 ctx02 in + (match uu___13 with + | Success (y, g2) -> + let uu___14 = + let uu___15 = + and_pre g12 g2 in + ((), uu___15) in + Success uu___14 + | err1 -> err1) + | Error err1 -> Error err1 in + uu___10 ctx01 in + (match uu___9 with + | Success (y, g2) -> + let uu___10 = + let uu___11 = and_pre g11 g2 in + ((), uu___11) in + Success uu___10 + | err1 -> err1) + | Error err1 -> Error err1 in + uu___6 ctx1) + | (FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = e0; + FStarC_Syntax_Syntax.ret_opt = uu___6; + FStarC_Syntax_Syntax.brs = brs0; + FStarC_Syntax_Syntax.rc_opt1 = uu___7;_}, + FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = e1; + FStarC_Syntax_Syntax.ret_opt = uu___8; + FStarC_Syntax_Syntax.brs = brs1; + FStarC_Syntax_Syntax.rc_opt1 = uu___9;_}) + -> + let relate_branch br0 br1 uu___10 = + match (br0, br1) with + | ((p0, FStar_Pervasives_Native.None, body0), + (p1, FStar_Pervasives_Native.None, body1)) + -> + let uu___11 = + let uu___12 = + FStarC_Syntax_Syntax.eq_pat p0 p1 in + Prims.op_Negation uu___12 in + if uu___11 + then fail "patterns not equal" + else + (let uu___13 = + open_branches_eq_pat g + (p0, FStar_Pervasives_Native.None, + body0) + (p1, FStar_Pervasives_Native.None, + body1) in + match uu___13 with + | (g', (p01, uu___14, body01), + (p11, uu___15, body11)) -> + let uu___16 = + FStarC_TypeChecker_PatternUtils.raw_pat_as_exp + g.tcenv p01 in + (match uu___16 with + | FStar_Pervasives_Native.Some + (uu___17, bvs0) -> + let bs0 = + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.mk_binder + bvs0 in + let uu___18 = + check_binders g bs0 in + (fun ctx01 -> + let uu___19 = uu___18 ctx01 in + match uu___19 with + | Success (x1, g11) -> + let uu___20 = + let uu___21 ctx = + let ctx1 = + { + no_guard = + (ctx.no_guard); + unfolding_ok = + (ctx.unfolding_ok); + error_context = + (("relate_branch", + FStar_Pervasives_Native.None) + :: + (ctx.error_context)) + } in + let uu___22 = + let uu___23 = + check_relation1 + g' rel body01 + body11 in + with_binders bs0 + x1 uu___23 in + uu___22 ctx1 in + uu___21 ctx01 in + (match uu___20 with + | Success (y, g2) -> + let uu___21 = + let uu___22 = + and_pre g11 g2 in + ((), uu___22) in + Success uu___21 + | err1 -> err1) + | Error err1 -> Error err1) + | uu___17 -> + fail + "raw_pat_as_exp failed in check_equality match rule")) + | uu___11 -> + fail + "Core does not support branches with when" in + let uu___10 = + let uu___11 = check_relation1 g EQUALITY e0 e1 in + fun ctx01 -> + let uu___12 = uu___11 ctx01 in + match uu___12 with + | Success (x1, g11) -> + let uu___13 = + let uu___14 = + iter2 brs0 brs1 relate_branch () in + uu___14 ctx01 in + (match uu___13 with + | Success (y, g2) -> + let uu___14 = + let uu___15 = and_pre g11 g2 in + ((), uu___15) in + Success uu___14 + | err1 -> err1) + | Error err1 -> Error err1 in + (fun ctx -> + let uu___11 = uu___10 ctx in + match uu___11 with + | Error uu___12 -> + let uu___13 = fallback t01 t11 in + uu___13 ctx + | res -> res) + | uu___6 -> fallback t01 t11) in + uu___3 ctx0 in + (match uu___2 with + | Success (y, g2) -> + let uu___3 = let uu___4 = and_pre g1 g2 in ((), uu___4) in + Success uu___3 + | err1 -> err1) + | Error err1 -> Error err1) +and (check_relation_args : + env -> + relation -> + FStarC_Syntax_Syntax.args -> FStarC_Syntax_Syntax.args -> unit result) + = + fun g -> + fun rel -> + fun a0 -> + fun a1 -> + if + (FStarC_Compiler_List.length a0) = + (FStarC_Compiler_List.length a1) + then + iter2 a0 a1 + (fun uu___ -> + fun uu___1 -> + fun uu___2 -> + match (uu___, uu___1) with + | ((t0, q0), (t1, q1)) -> + let uu___3 = check_aqual q0 q1 in + (fun ctx0 -> + let uu___4 = uu___3 ctx0 in + match uu___4 with + | Success (x, g1) -> + let uu___5 = + let uu___6 = check_relation g rel t0 t1 in + uu___6 ctx0 in + (match uu___5 with + | Success (y, g2) -> + let uu___6 = + let uu___7 = and_pre g1 g2 in + ((), uu___7) in + Success uu___6 + | err -> err) + | Error err -> Error err)) () + else fail "Unequal number of arguments" +and (check_relation_comp : + env -> + relation -> + FStarC_Syntax_Syntax.comp -> FStarC_Syntax_Syntax.comp -> unit result) + = + fun g -> + fun rel -> + fun c0 -> + fun c1 -> + let destruct_comp c = + let uu___ = FStarC_Syntax_Util.is_total_comp c in + if uu___ + then + FStar_Pervasives_Native.Some + (E_Total, (FStarC_Syntax_Util.comp_result c)) + else + (let uu___2 = FStarC_Syntax_Util.is_tot_or_gtot_comp c in + if uu___2 + then + FStar_Pervasives_Native.Some + (E_Ghost, (FStarC_Syntax_Util.comp_result c)) + else FStar_Pervasives_Native.None) in + let uu___ = + let uu___1 = destruct_comp c0 in + let uu___2 = destruct_comp c1 in (uu___1, uu___2) in + match uu___ with + | (FStar_Pervasives_Native.None, uu___1) -> + let uu___2 = + let uu___3 = + FStarC_TypeChecker_TermEqAndSimplify.eq_comp g.tcenv c0 c1 in + uu___3 = FStarC_TypeChecker_TermEqAndSimplify.Equal in + if uu___2 + then (fun uu___3 -> Success ((), FStar_Pervasives_Native.None)) + else + (let ct_eq res0 args0 res1 args1 = + let uu___4 = check_relation g EQUALITY res0 res1 in + fun ctx0 -> + let uu___5 = uu___4 ctx0 in + match uu___5 with + | Success (x, g1) -> + let uu___6 = + let uu___7 = + check_relation_args g EQUALITY args0 args1 in + uu___7 ctx0 in + (match uu___6 with + | Success (y, g2) -> + let uu___7 = + let uu___8 = and_pre g1 g2 in ((), uu___8) in + Success uu___7 + | err -> err) + | Error err -> Error err in + let uu___4 = + FStarC_Syntax_Util.comp_eff_name_res_and_args c0 in + match uu___4 with + | (eff0, res0, args0) -> + let uu___5 = + FStarC_Syntax_Util.comp_eff_name_res_and_args c1 in + (match uu___5 with + | (eff1, res1, args1) -> + let uu___6 = FStarC_Ident.lid_equals eff0 eff1 in + if uu___6 + then ct_eq res0 args0 res1 args1 + else + (let ct0 = + FStarC_TypeChecker_Env.unfold_effect_abbrev + g.tcenv c0 in + let ct1 = + FStarC_TypeChecker_Env.unfold_effect_abbrev + g.tcenv c1 in + let uu___8 = + FStarC_Ident.lid_equals + ct0.FStarC_Syntax_Syntax.effect_name + ct1.FStarC_Syntax_Syntax.effect_name in + if uu___8 + then + ct_eq ct0.FStarC_Syntax_Syntax.result_typ + ct0.FStarC_Syntax_Syntax.effect_args + ct1.FStarC_Syntax_Syntax.result_typ + ct1.FStarC_Syntax_Syntax.effect_args + else + (let uu___10 = + let uu___11 = + FStarC_Ident.string_of_lid + ct0.FStarC_Syntax_Syntax.effect_name in + let uu___12 = + FStarC_Ident.string_of_lid + ct1.FStarC_Syntax_Syntax.effect_name in + FStarC_Compiler_Util.format2 + "Subcomp failed: Unequal computation types %s and %s" + uu___11 uu___12 in + fail uu___10)))) + | (uu___1, FStar_Pervasives_Native.None) -> + let uu___2 = + let uu___3 = + FStarC_TypeChecker_TermEqAndSimplify.eq_comp g.tcenv c0 c1 in + uu___3 = FStarC_TypeChecker_TermEqAndSimplify.Equal in + if uu___2 + then (fun uu___3 -> Success ((), FStar_Pervasives_Native.None)) + else + (let ct_eq res0 args0 res1 args1 = + let uu___4 = check_relation g EQUALITY res0 res1 in + fun ctx0 -> + let uu___5 = uu___4 ctx0 in + match uu___5 with + | Success (x, g1) -> + let uu___6 = + let uu___7 = + check_relation_args g EQUALITY args0 args1 in + uu___7 ctx0 in + (match uu___6 with + | Success (y, g2) -> + let uu___7 = + let uu___8 = and_pre g1 g2 in ((), uu___8) in + Success uu___7 + | err -> err) + | Error err -> Error err in + let uu___4 = + FStarC_Syntax_Util.comp_eff_name_res_and_args c0 in + match uu___4 with + | (eff0, res0, args0) -> + let uu___5 = + FStarC_Syntax_Util.comp_eff_name_res_and_args c1 in + (match uu___5 with + | (eff1, res1, args1) -> + let uu___6 = FStarC_Ident.lid_equals eff0 eff1 in + if uu___6 + then ct_eq res0 args0 res1 args1 + else + (let ct0 = + FStarC_TypeChecker_Env.unfold_effect_abbrev + g.tcenv c0 in + let ct1 = + FStarC_TypeChecker_Env.unfold_effect_abbrev + g.tcenv c1 in + let uu___8 = + FStarC_Ident.lid_equals + ct0.FStarC_Syntax_Syntax.effect_name + ct1.FStarC_Syntax_Syntax.effect_name in + if uu___8 + then + ct_eq ct0.FStarC_Syntax_Syntax.result_typ + ct0.FStarC_Syntax_Syntax.effect_args + ct1.FStarC_Syntax_Syntax.result_typ + ct1.FStarC_Syntax_Syntax.effect_args + else + (let uu___10 = + let uu___11 = + FStarC_Ident.string_of_lid + ct0.FStarC_Syntax_Syntax.effect_name in + let uu___12 = + FStarC_Ident.string_of_lid + ct1.FStarC_Syntax_Syntax.effect_name in + FStarC_Compiler_Util.format2 + "Subcomp failed: Unequal computation types %s and %s" + uu___11 uu___12 in + fail uu___10)))) + | (FStar_Pervasives_Native.Some (E_Total, t0), + FStar_Pervasives_Native.Some (uu___1, t1)) -> + check_relation g rel t0 t1 + | (FStar_Pervasives_Native.Some (E_Ghost, t0), + FStar_Pervasives_Native.Some (E_Ghost, t1)) -> + check_relation g rel t0 t1 + | (FStar_Pervasives_Native.Some (E_Ghost, t0), + FStar_Pervasives_Native.Some (E_Total, t1)) -> + let uu___1 = non_informative g t1 in + if uu___1 + then check_relation g rel t0 t1 + else fail "Expected a Total computation, but got Ghost" +and (check_subtype : + env -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.typ -> context -> unit success __result) + = + fun g -> + fun e -> + fun t0 -> + fun t1 -> + fun ctx -> + FStarC_Profiling.profile + (fun uu___ -> + let rel = SUBTYPING e in + let uu___1 ctx1 = + let ctx2 = + { + no_guard = (ctx1.no_guard); + unfolding_ok = (ctx1.unfolding_ok); + error_context = + (((if ctx.no_guard + then "check_subtype(no_guard)" + else "check_subtype"), + (FStar_Pervasives_Native.Some + (CtxRel (t0, rel, t1)))) :: + (ctx1.error_context)) + } in + let uu___2 = check_relation g rel t0 t1 in uu___2 ctx2 in + uu___1 ctx) FStar_Pervasives_Native.None + "FStarC.TypeChecker.Core.check_subtype" +and (memo_check : + env -> + FStarC_Syntax_Syntax.term -> + (tot_or_ghost * FStarC_Syntax_Syntax.typ) result) + = + fun g -> + fun e -> + let check_then_memo g1 e1 ctx = + let r = let uu___ = do_check_and_promote g1 e1 in uu___ ctx in + match r with + | Success (res, FStar_Pervasives_Native.None) -> + (insert g1 e1 (res, FStar_Pervasives_Native.None); r) + | Success (res, FStar_Pervasives_Native.Some guard1) -> + (match g1.guard_handler with + | FStar_Pervasives_Native.None -> + (insert g1 e1 (res, (FStar_Pervasives_Native.Some guard1)); + r) + | FStar_Pervasives_Native.Some gh -> + let uu___ = gh g1.tcenv guard1 in + if uu___ + then + let r1 = (res, FStar_Pervasives_Native.None) in + (insert g1 e1 r1; Success r1) + else + (let uu___2 = fail "guard handler failed" in uu___2 ctx)) + | uu___ -> r in + fun ctx -> + if Prims.op_Negation g.should_read_cache + then check_then_memo g e ctx + else + (let uu___1 = let uu___2 = lookup g e in uu___2 ctx in + match uu___1 with + | Error uu___2 -> check_then_memo g e ctx + | Success (et, FStar_Pervasives_Native.None) -> + Success (et, FStar_Pervasives_Native.None) + | Success (et, FStar_Pervasives_Native.Some pre) -> + (match g.guard_handler with + | FStar_Pervasives_Native.None -> + Success (et, (FStar_Pervasives_Native.Some pre)) + | FStar_Pervasives_Native.Some uu___2 -> + check_then_memo + { + tcenv = (g.tcenv); + allow_universe_instantiation = + (g.allow_universe_instantiation); + max_binder_index = (g.max_binder_index); + guard_handler = (g.guard_handler); + should_read_cache = false + } e ctx)) +and (check : + Prims.string -> + env -> + FStarC_Syntax_Syntax.term -> + (tot_or_ghost * FStarC_Syntax_Syntax.typ) result) + = + fun msg -> + fun g -> + fun e -> + fun ctx -> + let ctx1 = + { + no_guard = (ctx.no_guard); + unfolding_ok = (ctx.unfolding_ok); + error_context = + ((msg, (FStar_Pervasives_Native.Some (CtxTerm e))) :: + (ctx.error_context)) + } in + let uu___ = memo_check g e in uu___ ctx1 +and (do_check_and_promote : + env -> + FStarC_Syntax_Syntax.term -> + (tot_or_ghost * FStarC_Syntax_Syntax.typ) result) + = + fun g -> + fun e -> + let uu___ = do_check g e in + fun ctx0 -> + let uu___1 = uu___ ctx0 in + match uu___1 with + | Success (x, g1) -> + let uu___2 = + let uu___3 = + match x with + | (eff, t) -> + let eff1 = + match eff with + | E_Total -> E_Total + | E_Ghost -> + let uu___4 = non_informative g t in + if uu___4 then E_Total else E_Ghost in + (fun uu___4 -> + Success ((eff1, t), FStar_Pervasives_Native.None)) in + uu___3 ctx0 in + (match uu___2 with + | Success (y, g2) -> + let uu___3 = let uu___4 = and_pre g1 g2 in (y, uu___4) in + Success uu___3 + | err -> err) + | Error err -> Error err +and (do_check : + env -> + FStarC_Syntax_Syntax.term -> + (tot_or_ghost * FStarC_Syntax_Syntax.typ) result) + = + fun g -> + fun e -> + let e1 = FStarC_Syntax_Subst.compress e in + match e1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_lazy + { FStarC_Syntax_Syntax.blob = uu___; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_embedding + uu___1; + FStarC_Syntax_Syntax.ltyp = uu___2; + FStarC_Syntax_Syntax.rng = uu___3;_} + -> let uu___4 = FStarC_Syntax_Util.unlazy e1 in do_check g uu___4 + | FStarC_Syntax_Syntax.Tm_lazy i -> + (fun uu___ -> + Success + ((E_Total, (i.FStarC_Syntax_Syntax.ltyp)), + FStar_Pervasives_Native.None)) + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t; + FStarC_Syntax_Syntax.meta = uu___;_} + -> memo_check g t + | FStarC_Syntax_Syntax.Tm_uvar (uv, s) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Syntax_Util.ctx_uvar_typ uv in + FStarC_Syntax_Subst.subst' s uu___2 in + (E_Total, uu___1) in + (fun uu___1 -> Success (uu___, FStar_Pervasives_Native.None)) + | FStarC_Syntax_Syntax.Tm_name x -> + let uu___ = FStarC_TypeChecker_Env.try_lookup_bv g.tcenv x in + (match uu___ with + | FStar_Pervasives_Native.None -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_bv x in + FStarC_Compiler_Util.format1 "Variable not found: %s" uu___2 in + fail uu___1 + | FStar_Pervasives_Native.Some (t, uu___1) -> + (fun uu___2 -> + Success ((E_Total, t), FStar_Pervasives_Native.None))) + | FStarC_Syntax_Syntax.Tm_fvar f -> + let uu___ = + FStarC_TypeChecker_Env.try_lookup_lid g.tcenv + (f.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + (match uu___ with + | FStar_Pervasives_Native.Some (([], t), uu___1) -> + (fun uu___2 -> + Success ((E_Total, t), FStar_Pervasives_Native.None)) + | uu___1 -> fail "Missing universes instantiation") + | FStarC_Syntax_Syntax.Tm_uinst + ({ FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar f; + FStarC_Syntax_Syntax.pos = uu___; + FStarC_Syntax_Syntax.vars = uu___1; + FStarC_Syntax_Syntax.hash_code = uu___2;_}, + us) + -> + let uu___3 = + FStarC_TypeChecker_Env.try_lookup_and_inst_lid g.tcenv us + (f.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + (match uu___3 with + | FStar_Pervasives_Native.None -> + let uu___4 = + let uu___5 = + FStarC_Ident.string_of_lid + (f.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + FStarC_Compiler_Util.format1 "Top-level name not found: %s" + uu___5 in + fail uu___4 + | FStar_Pervasives_Native.Some (t, uu___4) -> + (fun uu___5 -> + Success ((E_Total, t), FStar_Pervasives_Native.None))) + | FStarC_Syntax_Syntax.Tm_constant c -> + (match c with + | FStarC_Const.Const_range_of -> fail "Unhandled constant" + | FStarC_Const.Const_set_range_of -> fail "Unhandled constant" + | FStarC_Const.Const_reify uu___ -> fail "Unhandled constant" + | FStarC_Const.Const_reflect uu___ -> fail "Unhandled constant" + | uu___ -> + let t = + FStarC_TypeChecker_TcTerm.tc_constant g.tcenv + e1.FStarC_Syntax_Syntax.pos c in + (fun uu___1 -> + Success ((E_Total, t), FStar_Pervasives_Native.None))) + | FStarC_Syntax_Syntax.Tm_type u -> + let uu___ = + let uu___1 = mk_type (FStarC_Syntax_Syntax.U_succ u) in + (E_Total, uu___1) in + (fun uu___1 -> Success (uu___, FStar_Pervasives_Native.None)) + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x; FStarC_Syntax_Syntax.phi = phi;_} -> + let uu___ = check "refinement head" g x.FStarC_Syntax_Syntax.sort in + (fun ctx0 -> + let uu___1 = uu___ ctx0 in + match uu___1 with + | Success (x1, g1) -> + let uu___2 = + let uu___3 = + match x1 with + | (uu___4, t) -> + let uu___5 = is_type g t in + (fun ctx01 -> + let uu___6 = uu___5 ctx01 in + match uu___6 with + | Success (x2, g11) -> + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Syntax_Syntax.mk_binder x in + open_term g uu___10 phi in + match uu___9 with + | (g', x3, phi1) -> + let uu___10 = + let uu___11 = + check "refinement formula" g' + phi1 in + fun ctx02 -> + let uu___12 = uu___11 ctx02 in + match uu___12 with + | Success (x4, g12) -> + let uu___13 = + let uu___14 = + match x4 with + | (uu___15, t') -> + let uu___16 = + is_type g' t' in + (fun ctx03 -> + let uu___17 = + uu___16 ctx03 in + match uu___17 with + | Success + (x5, g13) -> + let uu___18 = + let uu___19 + uu___20 = + Success + ((E_Total, + t), + FStar_Pervasives_Native.None) in + uu___19 + ctx03 in + (match uu___18 + with + | Success + (y, g2) + -> + let uu___19 + = + let uu___20 + = + and_pre + g13 g2 in + (y, + uu___20) in + Success + uu___19 + | err -> err) + | Error err -> + Error err) in + uu___14 ctx02 in + (match uu___13 with + | Success (y, g2) -> + let uu___14 = + let uu___15 = + and_pre g12 g2 in + (y, uu___15) in + Success uu___14 + | err -> err) + | Error err -> Error err in + with_binders [x3] [x2] uu___10 in + uu___8 ctx01 in + (match uu___7 with + | Success (y, g2) -> + let uu___8 = + let uu___9 = and_pre g11 g2 in + (y, uu___9) in + Success uu___8 + | err -> err) + | Error err -> Error err) in + uu___3 ctx0 in + (match uu___2 with + | Success (y, g2) -> + let uu___3 = let uu___4 = and_pre g1 g2 in (y, uu___4) in + Success uu___3 + | err -> err) + | Error err -> Error err) + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = xs; FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = uu___;_} + -> + let uu___1 = open_term_binders g xs body in + (match uu___1 with + | (g', xs1, body1) -> + let uu___2 ctx = + let ctx1 = + { + no_guard = (ctx.no_guard); + unfolding_ok = (ctx.unfolding_ok); + error_context = + (("abs binders", FStar_Pervasives_Native.None) :: + (ctx.error_context)) + } in + let uu___3 = check_binders g xs1 in uu___3 ctx1 in + (fun ctx0 -> + let uu___3 = uu___2 ctx0 in + match uu___3 with + | Success (x, g1) -> + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = check "abs body" g' body1 in + fun ctx01 -> + let uu___8 = uu___7 ctx01 in + match uu___8 with + | Success (x1, g11) -> + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = as_comp g x1 in + FStarC_Syntax_Util.arrow xs1 + uu___13 in + (E_Total, uu___12) in + fun uu___12 -> + Success + (uu___11, + FStar_Pervasives_Native.None) in + uu___10 ctx01 in + (match uu___9 with + | Success (y, g2) -> + let uu___10 = + let uu___11 = and_pre g11 g2 in + (y, uu___11) in + Success uu___10 + | err -> err) + | Error err -> Error err in + with_binders xs1 x uu___6 in + uu___5 ctx0 in + (match uu___4 with + | Success (y, g2) -> + let uu___5 = + let uu___6 = and_pre g1 g2 in (y, uu___6) in + Success uu___5 + | err -> err) + | Error err -> Error err)) + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = xs; FStarC_Syntax_Syntax.comp = c;_} + -> + let uu___ = open_comp_binders g xs c in + (match uu___ with + | (g', xs1, c1) -> + let uu___1 ctx = + let ctx1 = + { + no_guard = (ctx.no_guard); + unfolding_ok = (ctx.unfolding_ok); + error_context = + (("arrow binders", FStar_Pervasives_Native.None) :: + (ctx.error_context)) + } in + let uu___2 = check_binders g xs1 in uu___2 ctx1 in + (fun ctx0 -> + let uu___2 = uu___1 ctx0 in + match uu___2 with + | Success (x, g1) -> + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 ctx = + let ctx1 = + { + no_guard = (ctx.no_guard); + unfolding_ok = (ctx.unfolding_ok); + error_context = + (("arrow comp", + FStar_Pervasives_Native.None) :: + (ctx.error_context)) + } in + let uu___7 = check_comp g' c1 in uu___7 ctx1 in + fun ctx01 -> + let uu___7 = uu___6 ctx01 in + match uu___7 with + | Success (x1, g11) -> + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + mk_type + (FStarC_Syntax_Syntax.U_max (x1 + :: x)) in + (E_Total, uu___11) in + fun uu___11 -> + Success + (uu___10, + FStar_Pervasives_Native.None) in + uu___9 ctx01 in + (match uu___8 with + | Success (y, g2) -> + let uu___9 = + let uu___10 = and_pre g11 g2 in + (y, uu___10) in + Success uu___9 + | err -> err) + | Error err -> Error err in + with_binders xs1 x uu___5 in + uu___4 ctx0 in + (match uu___3 with + | Success (y, g2) -> + let uu___4 = + let uu___5 = and_pre g1 g2 in (y, uu___5) in + Success uu___4 + | err -> err) + | Error err -> Error err)) + | FStarC_Syntax_Syntax.Tm_app uu___ -> + let rec check_app_arg uu___1 uu___2 = + match (uu___1, uu___2) with + | ((eff_hd, t_hd), (arg, arg_qual)) -> + let uu___3 = is_arrow g t_hd in + (fun ctx0 -> + let uu___4 = uu___3 ctx0 in + match uu___4 with + | Success (x, g1) -> + let uu___5 = + let uu___6 = + match x with + | (x1, eff_arr, t') -> + let uu___7 = check "app arg" g arg in + (fun ctx01 -> + let uu___8 = uu___7 ctx01 in + match uu___8 with + | Success (x2, g11) -> + let uu___9 = + let uu___10 = + match x2 with + | (eff_arg, t_arg) -> + let uu___11 ctx = + let ctx1 = + { + no_guard = (ctx.no_guard); + unfolding_ok = + (ctx.unfolding_ok); + error_context = + (("app subtyping", + FStar_Pervasives_Native.None) + :: (ctx.error_context)) + } in + let uu___12 = + check_subtype g + (FStar_Pervasives_Native.Some + arg) t_arg + (x1.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + uu___12 ctx1 in + (fun ctx02 -> + let uu___12 = uu___11 ctx02 in + match uu___12 with + | Success (x3, g12) -> + let uu___13 = + let uu___14 = + let uu___15 ctx = + let ctx1 = + { + no_guard = + (ctx.no_guard); + unfolding_ok = + (ctx.unfolding_ok); + error_context + = + (("app arg qual", + FStar_Pervasives_Native.None) + :: + (ctx.error_context)) + } in + let uu___16 = + check_arg_qual + arg_qual + x1.FStarC_Syntax_Syntax.binder_qual in + uu___16 ctx1 in + fun ctx03 -> + let uu___16 = + uu___15 ctx03 in + match uu___16 with + | Success + (x4, g13) -> + let uu___17 = + let uu___18 + = + let uu___19 + = + let uu___20 + = + FStarC_Syntax_Subst.subst + [ + FStarC_Syntax_Syntax.NT + ((x1.FStarC_Syntax_Syntax.binder_bv), + arg)] t' in + ((join_eff + eff_hd + (join_eff + eff_arr + eff_arg)), + uu___20) in + fun + uu___20 + -> + Success + (uu___19, + FStar_Pervasives_Native.None) in + uu___18 + ctx03 in + (match uu___17 + with + | Success + (y, g2) + -> + let uu___18 + = + let uu___19 + = + and_pre + g13 g2 in + (y, + uu___19) in + Success + uu___18 + | err -> err) + | Error err -> + Error err in + uu___14 ctx02 in + (match uu___13 with + | Success (y, g2) -> + let uu___14 = + let uu___15 = + and_pre g12 g2 in + (y, uu___15) in + Success uu___14 + | err -> err) + | Error err -> Error err) in + uu___10 ctx01 in + (match uu___9 with + | Success (y, g2) -> + let uu___10 = + let uu___11 = and_pre g11 g2 in + (y, uu___11) in + Success uu___10 + | err -> err) + | Error err -> Error err) in + uu___6 ctx0 in + (match uu___5 with + | Success (y, g2) -> + let uu___6 = + let uu___7 = and_pre g1 g2 in (y, uu___7) in + Success uu___6 + | err -> err) + | Error err -> Error err) in + let check_app hd args = + let uu___1 = check "app head" g hd in + fun ctx0 -> + let uu___2 = uu___1 ctx0 in + match uu___2 with + | Success (x, g1) -> + let uu___3 = + let uu___4 = + match x with + | (eff_hd, t) -> fold check_app_arg (eff_hd, t) args in + uu___4 ctx0 in + (match uu___3 with + | Success (y, g2) -> + let uu___4 = let uu___5 = and_pre g1 g2 in (y, uu___5) in + Success uu___4 + | err -> err) + | Error err -> Error err in + let uu___1 = FStarC_Syntax_Util.head_and_args_full e1 in + (match uu___1 with + | (hd, args) -> + (match args with + | (t1, FStar_Pervasives_Native.None)::(t2, + FStar_Pervasives_Native.None)::[] + when FStarC_TypeChecker_Util.short_circuit_head hd -> + let uu___2 = check "app head" g hd in + (fun ctx0 -> + let uu___3 = uu___2 ctx0 in + match uu___3 with + | Success (x, g1) -> + let uu___4 = + let uu___5 = + match x with + | (eff_hd, t_hd) -> + let uu___6 = is_arrow g t_hd in + (fun ctx01 -> + let uu___7 = uu___6 ctx01 in + match uu___7 with + | Success (x1, g11) -> + let uu___8 = + let uu___9 = + match x1 with + | (x2, eff_arr1, s1) -> + let uu___10 = + check "app arg" g t1 in + (fun ctx02 -> + let uu___11 = + uu___10 ctx02 in + match uu___11 with + | Success (x3, g12) -> + let uu___12 = + let uu___13 = + match x3 with + | (eff_arg1, + t_t1) -> + let uu___14 + ctx = + let ctx1 = + { + no_guard + = + (ctx.no_guard); + unfolding_ok + = + (ctx.unfolding_ok); + error_context + = + (("operator arg1", + FStar_Pervasives_Native.None) + :: + (ctx.error_context)) + } in + let uu___15 + = + check_subtype + g + (FStar_Pervasives_Native.Some + t1) t_t1 + (x2.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + uu___15 + ctx1 in + (fun ctx03 + -> + let uu___15 + = + uu___14 + ctx03 in + match uu___15 + with + | + Success + (x4, g13) + -> + let uu___16 + = + let uu___17 + = + let s11 = + FStarC_Syntax_Subst.subst + [ + FStarC_Syntax_Syntax.NT + ((x2.FStarC_Syntax_Syntax.binder_bv), + t1)] s1 in + let uu___18 + = + is_arrow + g s11 in + fun ctx04 + -> + let uu___19 + = + uu___18 + ctx04 in + match uu___19 + with + | + Success + (x5, g14) + -> + let uu___20 + = + let uu___21 + = + match x5 + with + | + (y, + eff_arr2, + s2) -> + let guard_formula + = + FStarC_TypeChecker_Util.short_circuit + hd + [ + (t1, + FStar_Pervasives_Native.None)] in + let g' = + match guard_formula + with + | + FStarC_TypeChecker_Common.Trivial + -> g + | + FStarC_TypeChecker_Common.NonTrivial + gf -> + push_hypothesis + g gf in + let uu___22 + = + let uu___23 + = + check + "app arg" + g' t2 in + weaken_with_guard_formula + guard_formula + uu___23 in + (fun + ctx05 -> + let uu___23 + = + uu___22 + ctx05 in + match uu___23 + with + | + Success + (x6, g15) + -> + let uu___24 + = + let uu___25 + = + match x6 + with + | + (eff_arg2, + t_t2) -> + let uu___26 + ctx = + let ctx1 + = + { + no_guard + = + (ctx.no_guard); + unfolding_ok + = + (ctx.unfolding_ok); + error_context + = + (("operator arg2", + FStar_Pervasives_Native.None) + :: + (ctx.error_context)) + } in + let uu___27 + = + check_subtype + g' + (FStar_Pervasives_Native.Some + t2) t_t2 + (y.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + uu___27 + ctx1 in + (fun + ctx06 -> + let uu___27 + = + uu___26 + ctx06 in + match uu___27 + with + | + Success + (x7, g16) + -> + let uu___28 + = + let uu___29 + = + let uu___30 + = + let uu___31 + = + FStarC_Syntax_Subst.subst + [ + FStarC_Syntax_Syntax.NT + ((y.FStarC_Syntax_Syntax.binder_bv), + t2)] s2 in + ((join_eff_l + [eff_hd; + eff_arr1; + eff_arr2; + eff_arg1; + eff_arg2]), + uu___31) in + fun + uu___31 + -> + Success + (uu___30, + FStar_Pervasives_Native.None) in + uu___29 + ctx06 in + (match uu___28 + with + | + Success + (y1, g2) + -> + let uu___29 + = + let uu___30 + = + and_pre + g16 g2 in + (y1, + uu___30) in + Success + uu___29 + | + err -> + err) + | + Error err + -> + Error err) in + uu___25 + ctx05 in + (match uu___24 + with + | + Success + (y1, g2) + -> + let uu___25 + = + let uu___26 + = + and_pre + g15 g2 in + (y1, + uu___26) in + Success + uu___25 + | + err -> + err) + | + Error err + -> + Error err) in + uu___21 + ctx04 in + (match uu___20 + with + | + Success + (y, g2) + -> + let uu___21 + = + let uu___22 + = + and_pre + g14 g2 in + (y, + uu___22) in + Success + uu___21 + | + err -> + err) + | + Error err + -> + Error err in + uu___17 + ctx03 in + (match uu___16 + with + | + Success + (y, g2) + -> + let uu___17 + = + let uu___18 + = + and_pre + g13 g2 in + (y, + uu___18) in + Success + uu___17 + | + err -> + err) + | + Error err + -> + Error err) in + uu___13 ctx02 in + (match uu___12 with + | Success (y, g2) + -> + let uu___13 = + let uu___14 = + and_pre g12 + g2 in + (y, uu___14) in + Success uu___13 + | err -> err) + | Error err -> Error err) in + uu___9 ctx01 in + (match uu___8 with + | Success (y, g2) -> + let uu___9 = + let uu___10 = and_pre g11 g2 in + (y, uu___10) in + Success uu___9 + | err -> err) + | Error err -> Error err) in + uu___5 ctx0 in + (match uu___4 with + | Success (y, g2) -> + let uu___5 = + let uu___6 = and_pre g1 g2 in (y, uu___6) in + Success uu___5 + | err -> err) + | Error err -> Error err) + | uu___2 -> check_app hd args)) + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = e2; + FStarC_Syntax_Syntax.asc = (FStar_Pervasives.Inl t, uu___, eq); + FStarC_Syntax_Syntax.eff_opt = uu___1;_} + -> + let uu___2 = check "ascription head" g e2 in + (fun ctx0 -> + let uu___3 = uu___2 ctx0 in + match uu___3 with + | Success (x, g1) -> + let uu___4 = + let uu___5 = + match x with + | (eff, te) -> + let uu___6 = check "ascription type" g t in + (fun ctx01 -> + let uu___7 = uu___6 ctx01 in + match uu___7 with + | Success (x1, g11) -> + let uu___8 = + let uu___9 = + match x1 with + | (uu___10, t') -> + let uu___11 = is_type g t' in + (fun ctx02 -> + let uu___12 = uu___11 ctx02 in + match uu___12 with + | Success (x2, g12) -> + let uu___13 = + let uu___14 = + let uu___15 ctx = + let ctx1 = + { + no_guard = + (ctx.no_guard); + unfolding_ok = + (ctx.unfolding_ok); + error_context = + (("ascription subtyping", + FStar_Pervasives_Native.None) + :: + (ctx.error_context)) + } in + let uu___16 = + check_subtype g + (FStar_Pervasives_Native.Some + e2) te t in + uu___16 ctx1 in + fun ctx03 -> + let uu___16 = + uu___15 ctx03 in + match uu___16 with + | Success (x3, g13) -> + let uu___17 = + let uu___18 + uu___19 = + Success + ((eff, t), + FStar_Pervasives_Native.None) in + uu___18 ctx03 in + (match uu___17 with + | Success (y, g2) + -> + let uu___18 = + let uu___19 = + and_pre g13 + g2 in + (y, uu___19) in + Success uu___18 + | err -> err) + | Error err -> Error err in + uu___14 ctx02 in + (match uu___13 with + | Success (y, g2) -> + let uu___14 = + let uu___15 = + and_pre g12 g2 in + (y, uu___15) in + Success uu___14 + | err -> err) + | Error err -> Error err) in + uu___9 ctx01 in + (match uu___8 with + | Success (y, g2) -> + let uu___9 = + let uu___10 = and_pre g11 g2 in + (y, uu___10) in + Success uu___9 + | err -> err) + | Error err -> Error err) in + uu___5 ctx0 in + (match uu___4 with + | Success (y, g2) -> + let uu___5 = let uu___6 = and_pre g1 g2 in (y, uu___6) in + Success uu___5 + | err -> err) + | Error err -> Error err) + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = e2; + FStarC_Syntax_Syntax.asc = + (FStar_Pervasives.Inr c, uu___, uu___1); + FStarC_Syntax_Syntax.eff_opt = uu___2;_} + -> + let uu___3 = FStarC_Syntax_Util.is_tot_or_gtot_comp c in + if uu___3 + then + let uu___4 = check "ascription head" g e2 in + (fun ctx0 -> + let uu___5 = uu___4 ctx0 in + match uu___5 with + | Success (x, g1) -> + let uu___6 = + let uu___7 = + match x with + | (eff, te) -> + let uu___8 ctx = + let ctx1 = + { + no_guard = (ctx.no_guard); + unfolding_ok = (ctx.unfolding_ok); + error_context = + (("ascription comp", + FStar_Pervasives_Native.None) :: + (ctx.error_context)) + } in + let uu___9 = check_comp g c in uu___9 ctx1 in + (fun ctx01 -> + let uu___9 = uu___8 ctx01 in + match uu___9 with + | Success (x1, g11) -> + let uu___10 = + let uu___11 = + let c_e = as_comp g (eff, te) in + let uu___12 ctx = + let ctx1 = + { + no_guard = (ctx.no_guard); + unfolding_ok = (ctx.unfolding_ok); + error_context = + (("ascription subtyping (comp)", + FStar_Pervasives_Native.None) + :: (ctx.error_context)) + } in + let uu___13 = + check_relation_comp g + (SUBTYPING + (FStar_Pervasives_Native.Some + e2)) c_e c in + uu___13 ctx1 in + fun ctx02 -> + let uu___13 = uu___12 ctx02 in + match uu___13 with + | Success (x2, g12) -> + let uu___14 = + let uu___15 = + let uu___16 = + comp_as_tot_or_ghost_and_type + c in + match uu___16 with + | FStar_Pervasives_Native.Some + (eff1, t) -> + (fun uu___17 -> + Success + ((eff1, t), + FStar_Pervasives_Native.None)) in + uu___15 ctx02 in + (match uu___14 with + | Success (y, g2) -> + let uu___15 = + let uu___16 = + and_pre g12 g2 in + (y, uu___16) in + Success uu___15 + | err -> err) + | Error err -> Error err in + uu___11 ctx01 in + (match uu___10 with + | Success (y, g2) -> + let uu___11 = + let uu___12 = and_pre g11 g2 in + (y, uu___12) in + Success uu___11 + | err -> err) + | Error err -> Error err) in + uu___7 ctx0 in + (match uu___6 with + | Success (y, g2) -> + let uu___7 = + let uu___8 = and_pre g1 g2 in (y, uu___8) in + Success uu___7 + | err -> err) + | Error err -> Error err) + else + (let uu___5 = + let uu___6 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_comp c in + FStarC_Compiler_Util.format1 + "Effect ascriptions are not fully handled yet: %s" uu___6 in + fail uu___5) + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (false, lb::[]); + FStarC_Syntax_Syntax.body1 = body;_} + -> + let uu___ = lb.FStarC_Syntax_Syntax.lbname in + (match uu___ with + | FStar_Pervasives.Inl x -> + let uu___1 = + let uu___2 = FStarC_Syntax_Syntax.mk_binder x in + open_term g uu___2 body in + (match uu___1 with + | (g', x1, body1) -> + let uu___2 = + FStarC_Syntax_Util.is_pure_or_ghost_effect + lb.FStarC_Syntax_Syntax.lbeff in + if uu___2 + then + let uu___3 = + check "let definition" g + lb.FStarC_Syntax_Syntax.lbdef in + (fun ctx0 -> + let uu___4 = uu___3 ctx0 in + match uu___4 with + | Success (x2, g1) -> + let uu___5 = + let uu___6 = + match x2 with + | (eff_def, tdef) -> + let uu___7 = + check "let type" g + lb.FStarC_Syntax_Syntax.lbtyp in + (fun ctx01 -> + let uu___8 = uu___7 ctx01 in + match uu___8 with + | Success (x3, g11) -> + let uu___9 = + let uu___10 = + match x3 with + | (uu___11, ttyp) -> + let uu___12 = + is_type g ttyp in + (fun ctx02 -> + let uu___13 = + uu___12 ctx02 in + match uu___13 with + | Success (x4, g12) -> + let uu___14 = + let uu___15 = + let uu___16 + ctx = + let ctx1 = + { + no_guard + = + (ctx.no_guard); + unfolding_ok + = + (ctx.unfolding_ok); + error_context + = + (("let subtyping", + FStar_Pervasives_Native.None) + :: + (ctx.error_context)) + } in + let uu___17 + = + check_subtype + g + (FStar_Pervasives_Native.Some + (lb.FStarC_Syntax_Syntax.lbdef)) + tdef + lb.FStarC_Syntax_Syntax.lbtyp in + uu___17 ctx1 in + fun ctx03 -> + let uu___17 + = + uu___16 + ctx03 in + match uu___17 + with + | Success + (x5, g13) + -> + let uu___18 + = + let uu___19 + = + let uu___20 + = + let uu___21 + = + check + "let body" + g' body1 in + fun ctx04 + -> + let uu___22 + = + uu___21 + ctx04 in + match uu___22 + with + | + Success + (x6, g14) + -> + let uu___23 + = + let uu___24 + = + match x6 + with + | + (eff_body, + t) -> + let uu___25 + = + check_no_escape + [x1] t in + (fun + ctx05 -> + let uu___26 + = + uu___25 + ctx05 in + match uu___26 + with + | + Success + (x7, g15) + -> + let uu___27 + = + let uu___28 + uu___29 = + Success + (((join_eff + eff_def + eff_body), + t), + FStar_Pervasives_Native.None) in + uu___28 + ctx05 in + (match uu___27 + with + | + Success + (y, g2) + -> + let uu___28 + = + let uu___29 + = + and_pre + g15 g2 in + (y, + uu___29) in + Success + uu___28 + | + err -> + err) + | + Error err + -> + Error err) in + uu___24 + ctx04 in + (match uu___23 + with + | + Success + (y, g2) + -> + let uu___24 + = + let uu___25 + = + and_pre + g14 g2 in + (y, + uu___25) in + Success + uu___24 + | + err -> + err) + | + Error err + -> + Error err in + with_definition + x1 x4 + lb.FStarC_Syntax_Syntax.lbdef + uu___20 in + uu___19 + ctx03 in + (match uu___18 + with + | + Success + (y, g2) + -> + let uu___19 + = + let uu___20 + = + and_pre + g13 g2 in + (y, + uu___20) in + Success + uu___19 + | + err -> + err) + | Error err + -> + Error err in + uu___15 ctx02 in + (match uu___14 + with + | Success + (y, g2) -> + let uu___15 = + let uu___16 + = + and_pre + g12 g2 in + (y, + uu___16) in + Success + uu___15 + | err -> err) + | Error err -> + Error err) in + uu___10 ctx01 in + (match uu___9 with + | Success (y, g2) -> + let uu___10 = + let uu___11 = + and_pre g11 g2 in + (y, uu___11) in + Success uu___10 + | err -> err) + | Error err -> Error err) in + uu___6 ctx0 in + (match uu___5 with + | Success (y, g2) -> + let uu___6 = + let uu___7 = and_pre g1 g2 in (y, uu___7) in + Success uu___6 + | err -> err) + | Error err -> Error err) + else + (let uu___4 = + let uu___5 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + lb.FStarC_Syntax_Syntax.lbeff in + FStarC_Compiler_Util.format1 + "Let binding is effectful (lbeff = %s)" uu___5 in + fail uu___4))) + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = sc; + FStarC_Syntax_Syntax.ret_opt = FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.brs = branches; + FStarC_Syntax_Syntax.rc_opt1 = rc_opt;_} + -> + let uu___ = check "scrutinee" g sc in + (fun ctx0 -> + let uu___1 = uu___ ctx0 in + match uu___1 with + | Success (x, g1) -> + let uu___2 = + let uu___3 = + match x with + | (eff_sc, t_sc) -> + let uu___4 ctx = + let ctx1 = + { + no_guard = (ctx.no_guard); + unfolding_ok = (ctx.unfolding_ok); + error_context = + (("universe_of", + (FStar_Pervasives_Native.Some + (CtxTerm t_sc))) :: + (ctx.error_context)) + } in + let uu___5 = universe_of g t_sc in uu___5 ctx1 in + (fun ctx01 -> + let uu___5 = uu___4 ctx01 in + match uu___5 with + | Success (x1, g11) -> + let uu___6 = + let uu___7 = + let rec check_branches path_condition + branch_typ_opt branches1 = + match branches1 with + | [] -> + (match branch_typ_opt with + | FStar_Pervasives_Native.None -> + fail + "could not compute a type for the match" + | FStar_Pervasives_Native.Some et + -> + let uu___8 = + boolean_negation_simp + path_condition in + (match uu___8 with + | FStar_Pervasives_Native.None + -> + (fun uu___9 -> + Success + (et, + FStar_Pervasives_Native.None)) + | FStar_Pervasives_Native.Some + g2 -> + let uu___9 = + let uu___10 = + FStarC_Syntax_Util.b2t + g2 in + guard uu___10 in + (fun ctx02 -> + let uu___10 = + uu___9 ctx02 in + match uu___10 with + | Success (x2, g12) -> + let uu___11 = + let uu___12 + uu___13 = + Success + (et, + FStar_Pervasives_Native.None) in + uu___12 ctx02 in + (match uu___11 + with + | Success + (y, g21) -> + let uu___12 = + let uu___13 + = + and_pre + g12 g21 in + (y, + uu___13) in + Success + uu___12 + | err -> err) + | Error err -> + Error err))) + | (p, FStar_Pervasives_Native.None, b)::rest + -> + let uu___8 = + open_branch g + (p, + FStar_Pervasives_Native.None, + b) in + (match uu___8 with + | (uu___9, (p1, uu___10, b1)) -> + let uu___11 ctx = + let ctx1 = + { + no_guard = + (ctx.no_guard); + unfolding_ok = + (ctx.unfolding_ok); + error_context = + (("check_pat", + FStar_Pervasives_Native.None) + :: + (ctx.error_context)) + } in + let uu___12 = + check_pat g p1 t_sc in + uu___12 ctx1 in + (fun ctx02 -> + let uu___12 = uu___11 ctx02 in + match uu___12 with + | Success (x2, g12) -> + let uu___13 = + let uu___14 = + match x2 with + | (bs, us) -> + let uu___15 = + pattern_branch_condition + g sc p1 in + (fun ctx03 -> + let uu___16 + = + uu___15 + ctx03 in + match uu___16 + with + | Success + (x3, g13) + -> + let uu___17 + = + let uu___18 + = + let pat_sc_eq + = + let uu___19 + = + let uu___20 + = + let uu___21 + = + FStarC_TypeChecker_PatternUtils.raw_pat_as_exp + g.tcenv + p1 in + FStarC_Compiler_Util.must + uu___21 in + FStar_Pervasives_Native.fst + uu___20 in + FStarC_Syntax_Util.mk_eq2 + x1 t_sc + sc + uu___19 in + let uu___19 + = + combine_path_and_branch_condition + path_condition + x3 + pat_sc_eq in + match uu___19 + with + | + (this_path_condition, + next_path_condition) + -> + let g' = + push_binders + g bs in + let g'1 = + push_hypothesis + g' + this_path_condition in + let uu___20 + = + let uu___21 + = + let uu___22 + = + let uu___23 + ctx = + let ctx1 + = + { + no_guard + = + (ctx.no_guard); + unfolding_ok + = + (ctx.unfolding_ok); + error_context + = + (("branch", + (FStar_Pervasives_Native.Some + (CtxTerm + b1))) :: + (ctx.error_context)) + } in + let uu___24 + = + check + "branch" + g'1 b1 in + uu___24 + ctx1 in + fun ctx04 + -> + let uu___24 + = + uu___23 + ctx04 in + match uu___24 + with + | + Success + (x4, g14) + -> + let uu___25 + = + let uu___26 + = + match x4 + with + | + (eff_br, + tbr) -> + (match branch_typ_opt + with + | + FStar_Pervasives_Native.None + -> + let uu___27 + = + check_no_escape + bs tbr in + (fun + ctx05 -> + let uu___28 + = + uu___27 + ctx05 in + match uu___28 + with + | + Success + (x5, g15) + -> + let uu___29 + = + let uu___30 + uu___31 = + Success + ((eff_br, + tbr), + FStar_Pervasives_Native.None) in + uu___30 + ctx05 in + (match uu___29 + with + | + Success + (y, g2) + -> + let uu___30 + = + let uu___31 + = + and_pre + g15 g2 in + (y, + uu___31) in + Success + uu___30 + | + err -> + err) + | + Error err + -> + Error err) + | + FStar_Pervasives_Native.Some + (acc_eff, + expect_tbr) + -> + let uu___27 + ctx = + let ctx1 + = + { + no_guard + = + (ctx.no_guard); + unfolding_ok + = + (ctx.unfolding_ok); + error_context + = + (("check_branch_subtype", + (FStar_Pervasives_Native.Some + (CtxRel + (tbr, + (SUBTYPING + (FStar_Pervasives_Native.Some + b1)), + expect_tbr)))) + :: + (ctx.error_context)) + } in + let uu___28 + = + check_subtype + g'1 + (FStar_Pervasives_Native.Some + b1) tbr + expect_tbr in + uu___28 + ctx1 in + (fun + ctx05 -> + let uu___28 + = + uu___27 + ctx05 in + match uu___28 + with + | + Success + (x5, g15) + -> + let uu___29 + = + let uu___30 + uu___31 = + Success + (((join_eff + eff_br + acc_eff), + expect_tbr), + FStar_Pervasives_Native.None) in + uu___30 + ctx05 in + (match uu___29 + with + | + Success + (y, g2) + -> + let uu___30 + = + let uu___31 + = + and_pre + g15 g2 in + (y, + uu___31) in + Success + uu___30 + | + err -> + err) + | + Error err + -> + Error err)) in + uu___26 + ctx04 in + (match uu___25 + with + | + Success + (y, g2) + -> + let uu___26 + = + let uu___27 + = + and_pre + g14 g2 in + (y, + uu___27) in + Success + uu___26 + | + err -> + err) + | + Error err + -> + Error err in + weaken + this_path_condition + uu___22 in + with_binders + bs us + uu___21 in + (fun + ctx04 -> + let uu___21 + = + uu___20 + ctx04 in + match uu___21 + with + | + Success + (x4, g14) + -> + let uu___22 + = + let uu___23 + = + match x4 + with + | + (eff_br, + tbr) -> + (match + p1.FStarC_Syntax_Syntax.v + with + | + FStarC_Syntax_Syntax.Pat_var + uu___24 + -> + (match rest + with + | + uu___25::uu___26 + -> + fail + "Redundant branches after wildcard" + | + uu___25 + -> + (fun + uu___26 + -> + Success + ((eff_br, + tbr), + FStar_Pervasives_Native.None))) + | + uu___24 + -> + check_branches + next_path_condition + (FStar_Pervasives_Native.Some + (eff_br, + tbr)) + rest) in + uu___23 + ctx04 in + (match uu___22 + with + | + Success + (y, g2) + -> + let uu___23 + = + let uu___24 + = + and_pre + g14 g2 in + (y, + uu___24) in + Success + uu___23 + | + err -> + err) + | + Error err + -> + Error err) in + uu___18 + ctx03 in + (match uu___17 + with + | + Success + (y, g2) + -> + let uu___18 + = + let uu___19 + = + and_pre + g13 g2 in + (y, + uu___19) in + Success + uu___18 + | + err -> + err) + | Error err + -> + Error err) in + uu___14 ctx02 in + (match uu___13 with + | Success (y, g2) -> + let uu___14 = + let uu___15 = + and_pre g12 g2 in + (y, uu___15) in + Success uu___14 + | err -> err) + | Error err -> Error err)) in + let uu___8 = + match rc_opt with + | FStar_Pervasives_Native.Some + { + FStarC_Syntax_Syntax.residual_effect + = uu___9; + FStarC_Syntax_Syntax.residual_typ + = FStar_Pervasives_Native.Some + t; + FStarC_Syntax_Syntax.residual_flags + = uu___10;_} + -> + let uu___11 ctx = + let ctx1 = + { + no_guard = (ctx.no_guard); + unfolding_ok = + (ctx.unfolding_ok); + error_context = + (("residual type", + (FStar_Pervasives_Native.Some + (CtxTerm t))) :: + (ctx.error_context)) + } in + let uu___12 = universe_of g t in + uu___12 ctx1 in + (fun ctx02 -> + let uu___12 = uu___11 ctx02 in + match uu___12 with + | Success (x2, g12) -> + let uu___13 = + let uu___14 uu___15 = + Success + ((FStar_Pervasives_Native.Some + (E_Total, t)), + FStar_Pervasives_Native.None) in + uu___14 ctx02 in + (match uu___13 with + | Success (y, g2) -> + let uu___14 = + let uu___15 = + and_pre g12 g2 in + (y, uu___15) in + Success uu___14 + | err -> err) + | Error err -> Error err) + | uu___9 -> + (fun uu___10 -> + Success + (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None)) in + fun ctx02 -> + let uu___9 = uu___8 ctx02 in + match uu___9 with + | Success (x2, g12) -> + let uu___10 = + let uu___11 = + let uu___12 = + let ctx = + match x2 with + | FStar_Pervasives_Native.None + -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some + (uu___13, t) -> + FStar_Pervasives_Native.Some + (CtxTerm t) in + fun ctx1 -> + let ctx2 = + { + no_guard = + (ctx1.no_guard); + unfolding_ok = + (ctx1.unfolding_ok); + error_context = + (("check_branches", + ctx) :: + (ctx1.error_context)) + } in + let uu___13 = + check_branches + FStarC_Syntax_Util.exp_true_bool + x2 branches in + uu___13 ctx2 in + fun ctx03 -> + let uu___13 = uu___12 ctx03 in + match uu___13 with + | Success (x3, g13) -> + let uu___14 = + let uu___15 = + match x3 with + | (eff_br, t_br) -> + (fun uu___16 -> + Success + (((join_eff + eff_sc + eff_br), + t_br), + FStar_Pervasives_Native.None)) in + uu___15 ctx03 in + (match uu___14 with + | Success (y, g2) -> + let uu___15 = + let uu___16 = + and_pre g13 g2 in + (y, uu___16) in + Success uu___15 + | err -> err) + | Error err -> Error err in + uu___11 ctx02 in + (match uu___10 with + | Success (y, g2) -> + let uu___11 = + let uu___12 = and_pre g12 g2 in + (y, uu___12) in + Success uu___11 + | err -> err) + | Error err -> Error err in + uu___7 ctx01 in + (match uu___6 with + | Success (y, g2) -> + let uu___7 = + let uu___8 = and_pre g11 g2 in + (y, uu___8) in + Success uu___7 + | err -> err) + | Error err -> Error err) in + uu___3 ctx0 in + (match uu___2 with + | Success (y, g2) -> + let uu___3 = let uu___4 = and_pre g1 g2 in (y, uu___4) in + Success uu___3 + | err -> err) + | Error err -> Error err) + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = sc; + FStarC_Syntax_Syntax.ret_opt = FStar_Pervasives_Native.Some + (as_x, + (FStar_Pervasives.Inl returns_ty, + FStar_Pervasives_Native.None, eq)); + FStarC_Syntax_Syntax.brs = branches; + FStarC_Syntax_Syntax.rc_opt1 = rc_opt;_} + -> + let uu___ = check "scrutinee" g sc in + (fun ctx0 -> + let uu___1 = uu___ ctx0 in + match uu___1 with + | Success (x, g1) -> + let uu___2 = + let uu___3 = + match x with + | (eff_sc, t_sc) -> + let uu___4 ctx = + let ctx1 = + { + no_guard = (ctx.no_guard); + unfolding_ok = (ctx.unfolding_ok); + error_context = + (("universe_of", + (FStar_Pervasives_Native.Some + (CtxTerm t_sc))) :: + (ctx.error_context)) + } in + let uu___5 = universe_of g t_sc in uu___5 ctx1 in + (fun ctx01 -> + let uu___5 = uu___4 ctx01 in + match uu___5 with + | Success (x1, g11) -> + let uu___6 = + let uu___7 = + let as_x1 = + { + FStarC_Syntax_Syntax.binder_bv = + (let uu___8 = + as_x.FStarC_Syntax_Syntax.binder_bv in + { + FStarC_Syntax_Syntax.ppname = + (uu___8.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (uu___8.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = t_sc + }); + FStarC_Syntax_Syntax.binder_qual = + (as_x.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity + = + (as_x.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs = + (as_x.FStarC_Syntax_Syntax.binder_attrs) + } in + let uu___8 = open_term g as_x1 returns_ty in + match uu___8 with + | (g_as_x, as_x2, returns_ty1) -> + let uu___9 = + let uu___10 = + check "return type" g_as_x + returns_ty1 in + with_binders [as_x2] [x1] uu___10 in + (fun ctx02 -> + let uu___10 = uu___9 ctx02 in + match uu___10 with + | Success (x2, g12) -> + let uu___11 = + let uu___12 = + match x2 with + | (_eff_t, returns_ty_t) + -> + let uu___13 = + is_type g_as_x + returns_ty_t in + (fun ctx03 -> + let uu___14 = + uu___13 ctx03 in + match uu___14 with + | Success (x3, g13) + -> + let uu___15 = + let uu___16 = + let rec check_branches + path_condition + branches1 + acc_eff = + match branches1 + with + | + [] -> + let uu___17 + = + boolean_negation_simp + path_condition in + (match uu___17 + with + | + FStar_Pervasives_Native.None + -> + (fun + uu___18 + -> + Success + (acc_eff, + FStar_Pervasives_Native.None)) + | + FStar_Pervasives_Native.Some + g2 -> + let uu___18 + = + let uu___19 + = + FStarC_Syntax_Util.b2t + g2 in + guard + uu___19 in + (fun + ctx04 -> + let uu___19 + = + uu___18 + ctx04 in + match uu___19 + with + | + Success + (x4, g14) + -> + let uu___20 + = + let uu___21 + uu___22 = + Success + (acc_eff, + FStar_Pervasives_Native.None) in + uu___21 + ctx04 in + (match uu___20 + with + | + Success + (y, g21) + -> + let uu___21 + = + let uu___22 + = + and_pre + g14 g21 in + (y, + uu___22) in + Success + uu___21 + | + err -> + err) + | + Error err + -> + Error err)) + | + (p, + FStar_Pervasives_Native.None, + b)::rest + -> + let uu___17 + = + open_branch + g + (p, + FStar_Pervasives_Native.None, + b) in + (match uu___17 + with + | + (uu___18, + (p1, + uu___19, + b1)) -> + let uu___20 + ctx = + let ctx1 + = + { + no_guard + = + (ctx.no_guard); + unfolding_ok + = + (ctx.unfolding_ok); + error_context + = + (("check_pat", + FStar_Pervasives_Native.None) + :: + (ctx.error_context)) + } in + let uu___21 + = + check_pat + g p1 t_sc in + uu___21 + ctx1 in + (fun + ctx04 -> + let uu___21 + = + uu___20 + ctx04 in + match uu___21 + with + | + Success + (x4, g14) + -> + let uu___22 + = + let uu___23 + = + match x4 + with + | + (bs, us) + -> + let uu___24 + = + pattern_branch_condition + g sc p1 in + (fun + ctx05 -> + let uu___25 + = + uu___24 + ctx05 in + match uu___25 + with + | + Success + (x5, g15) + -> + let uu___26 + = + let uu___27 + = + let pat_sc_eq + = + let uu___28 + = + let uu___29 + = + let uu___30 + = + FStarC_TypeChecker_PatternUtils.raw_pat_as_exp + g.tcenv + p1 in + FStarC_Compiler_Util.must + uu___30 in + FStar_Pervasives_Native.fst + uu___29 in + FStarC_Syntax_Util.mk_eq2 + x1 t_sc + sc + uu___28 in + let uu___28 + = + combine_path_and_branch_condition + path_condition + x5 + pat_sc_eq in + match uu___28 + with + | + (this_path_condition, + next_path_condition) + -> + let g' = + push_binders + g bs in + let g'1 = + push_hypothesis + g' + this_path_condition in + let uu___29 + = + let uu___30 + = + let uu___31 + = + let uu___32 + = + check + "branch" + g'1 b1 in + fun ctx06 + -> + let uu___33 + = + uu___32 + ctx06 in + match uu___33 + with + | + Success + (x6, g16) + -> + let uu___34 + = + let uu___35 + = + match x6 + with + | + (eff_br, + tbr) -> + let expect_tbr + = + FStarC_Syntax_Subst.subst + [ + FStarC_Syntax_Syntax.NT + ((as_x2.FStarC_Syntax_Syntax.binder_bv), + sc)] + returns_ty1 in + let rel = + if eq + then + EQUALITY + else + SUBTYPING + (FStar_Pervasives_Native.Some + b1) in + let uu___36 + ctx = + let ctx1 + = + { + no_guard + = + (ctx.no_guard); + unfolding_ok + = + (ctx.unfolding_ok); + error_context + = + (("branch check relation", + FStar_Pervasives_Native.None) + :: + (ctx.error_context)) + } in + let uu___37 + = + check_relation + g'1 rel + tbr + expect_tbr in + uu___37 + ctx1 in + (fun + ctx07 -> + let uu___37 + = + uu___36 + ctx07 in + match uu___37 + with + | + Success + (x7, g17) + -> + let uu___38 + = + let uu___39 + uu___40 = + Success + (((join_eff + eff_br + acc_eff), + expect_tbr), + FStar_Pervasives_Native.None) in + uu___39 + ctx07 in + (match uu___38 + with + | + Success + (y, g2) + -> + let uu___39 + = + let uu___40 + = + and_pre + g17 g2 in + (y, + uu___40) in + Success + uu___39 + | + err -> + err) + | + Error err + -> + Error err) in + uu___35 + ctx06 in + (match uu___34 + with + | + Success + (y, g2) + -> + let uu___35 + = + let uu___36 + = + and_pre + g16 g2 in + (y, + uu___36) in + Success + uu___35 + | + err -> + err) + | + Error err + -> + Error err in + weaken + this_path_condition + uu___31 in + with_binders + bs us + uu___30 in + (fun + ctx06 -> + let uu___30 + = + uu___29 + ctx06 in + match uu___30 + with + | + Success + (x6, g16) + -> + let uu___31 + = + let uu___32 + = + match x6 + with + | + (eff_br, + tbr) -> + (match + p1.FStarC_Syntax_Syntax.v + with + | + FStarC_Syntax_Syntax.Pat_var + uu___33 + -> + (match rest + with + | + uu___34::uu___35 + -> + fail + "Redundant branches after wildcard" + | + uu___34 + -> + (fun + uu___35 + -> + Success + (eff_br, + FStar_Pervasives_Native.None))) + | + uu___33 + -> + check_branches + next_path_condition + rest + eff_br) in + uu___32 + ctx06 in + (match uu___31 + with + | + Success + (y, g2) + -> + let uu___32 + = + let uu___33 + = + and_pre + g16 g2 in + (y, + uu___33) in + Success + uu___32 + | + err -> + err) + | + Error err + -> + Error err) in + uu___27 + ctx05 in + (match uu___26 + with + | + Success + (y, g2) + -> + let uu___27 + = + let uu___28 + = + and_pre + g15 g2 in + (y, + uu___28) in + Success + uu___27 + | + err -> + err) + | + Error err + -> + Error err) in + uu___23 + ctx04 in + (match uu___22 + with + | + Success + (y, g2) + -> + let uu___23 + = + let uu___24 + = + and_pre + g14 g2 in + (y, + uu___24) in + Success + uu___23 + | + err -> + err) + | + Error err + -> + Error err)) in + let uu___17 + = + check_branches + FStarC_Syntax_Util.exp_true_bool + branches + E_Total in + fun ctx04 + -> + let uu___18 + = + uu___17 + ctx04 in + match uu___18 + with + | + Success + (x4, g14) + -> + let uu___19 + = + let uu___20 + = + let ty = + FStarC_Syntax_Subst.subst + [ + FStarC_Syntax_Syntax.NT + ((as_x2.FStarC_Syntax_Syntax.binder_bv), + sc)] + returns_ty1 in + fun + uu___21 + -> + Success + ((x4, ty), + FStar_Pervasives_Native.None) in + uu___20 + ctx04 in + (match uu___19 + with + | + Success + (y, g2) + -> + let uu___20 + = + let uu___21 + = + and_pre + g14 g2 in + (y, + uu___21) in + Success + uu___20 + | + err -> + err) + | + Error err + -> + Error err in + uu___16 ctx03 in + (match uu___15 + with + | Success + (y, g2) -> + let uu___16 + = + let uu___17 + = + and_pre + g13 g2 in + (y, + uu___17) in + Success + uu___16 + | err -> err) + | Error err -> + Error err) in + uu___12 ctx02 in + (match uu___11 with + | Success (y, g2) -> + let uu___12 = + let uu___13 = + and_pre g12 g2 in + (y, uu___13) in + Success uu___12 + | err -> err) + | Error err -> Error err) in + uu___7 ctx01 in + (match uu___6 with + | Success (y, g2) -> + let uu___7 = + let uu___8 = and_pre g11 g2 in + (y, uu___8) in + Success uu___7 + | err -> err) + | Error err -> Error err) in + uu___3 ctx0 in + (match uu___2 with + | Success (y, g2) -> + let uu___3 = let uu___4 = and_pre g1 g2 in (y, uu___4) in + Success uu___3 + | err -> err) + | Error err -> Error err) + | FStarC_Syntax_Syntax.Tm_match uu___ -> + fail "Match with effect returns ascription, or tactic handler" + | uu___ -> + let uu___1 = + let uu___2 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term e1 in + FStarC_Compiler_Util.format1 "Unexpected term: %s" uu___2 in + fail uu___1 +and (check_binders : + env -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.universe Prims.list result) + = + fun g_initial -> + fun xs -> + let rec aux g xs1 = + match xs1 with + | [] -> (fun uu___ -> Success ([], FStar_Pervasives_Native.None)) + | x::xs2 -> + let uu___ = + check "binder sort" g + (x.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + (fun ctx0 -> + let uu___1 = uu___ ctx0 in + match uu___1 with + | Success (x1, g1) -> + let uu___2 = + let uu___3 = + match x1 with + | (uu___4, t) -> + let uu___5 = is_type g t in + (fun ctx01 -> + let uu___6 = uu___5 ctx01 in + match uu___6 with + | Success (x2, g11) -> + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = push_binder g x in + aux uu___11 xs2 in + fun ctx02 -> + let uu___11 = uu___10 ctx02 in + match uu___11 with + | Success (x3, g12) -> + let uu___12 = + let uu___13 uu___14 = + Success + ((x2 :: x3), + FStar_Pervasives_Native.None) in + uu___13 ctx02 in + (match uu___12 with + | Success (y, g2) -> + let uu___13 = + let uu___14 = + and_pre g12 g2 in + (y, uu___14) in + Success uu___13 + | err -> err) + | Error err -> Error err in + with_binders [x] [x2] uu___9 in + uu___8 ctx01 in + (match uu___7 with + | Success (y, g2) -> + let uu___8 = + let uu___9 = and_pre g11 g2 in + (y, uu___9) in + Success uu___8 + | err -> err) + | Error err -> Error err) in + uu___3 ctx0 in + (match uu___2 with + | Success (y, g2) -> + let uu___3 = + let uu___4 = and_pre g1 g2 in (y, uu___4) in + Success uu___3 + | err -> err) + | Error err -> Error err) in + aux g_initial xs +and (check_comp : + env -> FStarC_Syntax_Syntax.comp -> FStarC_Syntax_Syntax.universe result) = + fun g -> + fun c -> + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total t -> + let uu___ = + check "(G)Tot comp result" g (FStarC_Syntax_Util.comp_result c) in + (fun ctx0 -> + let uu___1 = uu___ ctx0 in + match uu___1 with + | Success (x, g1) -> + let uu___2 = + let uu___3 = match x with | (uu___4, t1) -> is_type g t1 in + uu___3 ctx0 in + (match uu___2 with + | Success (y, g2) -> + let uu___3 = let uu___4 = and_pre g1 g2 in (y, uu___4) in + Success uu___3 + | err -> err) + | Error err -> Error err) + | FStarC_Syntax_Syntax.GTotal t -> + let uu___ = + check "(G)Tot comp result" g (FStarC_Syntax_Util.comp_result c) in + (fun ctx0 -> + let uu___1 = uu___ ctx0 in + match uu___1 with + | Success (x, g1) -> + let uu___2 = + let uu___3 = match x with | (uu___4, t1) -> is_type g t1 in + uu___3 ctx0 in + (match uu___2 with + | Success (y, g2) -> + let uu___3 = let uu___4 = and_pre g1 g2 in (y, uu___4) in + Success uu___3 + | err -> err) + | Error err -> Error err) + | FStarC_Syntax_Syntax.Comp ct -> + if + (FStarC_Compiler_List.length ct.FStarC_Syntax_Syntax.comp_univs) + <> Prims.int_one + then fail "Unexpected/missing universe instantitation in comp" + else + (let u = + FStarC_Compiler_List.hd ct.FStarC_Syntax_Syntax.comp_univs in + let effect_app_tm = + let head = + let uu___1 = + FStarC_Syntax_Syntax.fvar + ct.FStarC_Syntax_Syntax.effect_name + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.mk_Tm_uinst uu___1 [u] in + let uu___1 = + let uu___2 = + FStarC_Syntax_Syntax.as_arg + ct.FStarC_Syntax_Syntax.result_typ in + uu___2 :: (ct.FStarC_Syntax_Syntax.effect_args) in + FStarC_Syntax_Syntax.mk_Tm_app head uu___1 + (ct.FStarC_Syntax_Syntax.result_typ).FStarC_Syntax_Syntax.pos in + let uu___1 = check "effectful comp" g effect_app_tm in + fun ctx0 -> + let uu___2 = uu___1 ctx0 in + match uu___2 with + | Success (x, g1) -> + let uu___3 = + let uu___4 = + match x with + | (uu___5, t) -> + let uu___6 ctx = + let ctx1 = + { + no_guard = (ctx.no_guard); + unfolding_ok = (ctx.unfolding_ok); + error_context = + (("comp fully applied", + FStar_Pervasives_Native.None) :: + (ctx.error_context)) + } in + let uu___7 = + check_subtype g FStar_Pervasives_Native.None t + FStarC_Syntax_Syntax.teff in + uu___7 ctx1 in + (fun ctx01 -> + let uu___7 = uu___6 ctx01 in + match uu___7 with + | Success (x1, g11) -> + let uu___8 = + let uu___9 = + let c_lid = + FStarC_TypeChecker_Env.norm_eff_name + g.tcenv + ct.FStarC_Syntax_Syntax.effect_name in + let is_total = + let uu___10 = + FStarC_TypeChecker_Env.lookup_effect_quals + g.tcenv c_lid in + FStarC_Compiler_List.existsb + (fun q -> + q = + FStarC_Syntax_Syntax.TotalEffect) + uu___10 in + if Prims.op_Negation is_total + then + fun uu___10 -> + Success + (FStarC_Syntax_Syntax.U_zero, + FStar_Pervasives_Native.None) + else + (let uu___11 = + FStarC_Syntax_Util.is_pure_or_ghost_effect + c_lid in + if uu___11 + then + fun uu___12 -> + Success + (u, + FStar_Pervasives_Native.None) + else + (let uu___13 = + FStarC_TypeChecker_Env.effect_repr + g.tcenv c u in + match uu___13 with + | FStar_Pervasives_Native.None -> + let uu___14 = + let uu___15 = + FStarC_Ident.string_of_lid + (FStarC_Syntax_Util.comp_effect_name + c) in + let uu___16 = + FStarC_Ident.string_of_lid + c_lid in + FStarC_Compiler_Util.format2 + "Total effect %s (normalized to %s) does not have a representation" + uu___15 uu___16 in + fail uu___14 + | FStar_Pervasives_Native.Some tm + -> universe_of g tm)) in + uu___9 ctx01 in + (match uu___8 with + | Success (y, g2) -> + let uu___9 = + let uu___10 = and_pre g11 g2 in + (y, uu___10) in + Success uu___9 + | err -> err) + | Error err -> Error err) in + uu___4 ctx0 in + (match uu___3 with + | Success (y, g2) -> + let uu___4 = + let uu___5 = and_pre g1 g2 in (y, uu___5) in + Success uu___4 + | err -> err) + | Error err -> Error err) +and (universe_of : + env -> FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.universe result) = + fun g -> + fun t -> + let uu___ = check "universe of" g t in + fun ctx0 -> + let uu___1 = uu___ ctx0 in + match uu___1 with + | Success (x, g1) -> + let uu___2 = + let uu___3 = match x with | (uu___4, t1) -> is_type g t1 in + uu___3 ctx0 in + (match uu___2 with + | Success (y, g2) -> + let uu___3 = let uu___4 = and_pre g1 g2 in (y, uu___4) in + Success uu___3 + | err -> err) + | Error err -> Error err +and (check_pat : + env -> + FStarC_Syntax_Syntax.pat -> + FStarC_Syntax_Syntax.typ -> + (FStarC_Syntax_Syntax.binders * FStarC_Syntax_Syntax.universes) + result) + = + fun g -> + fun p -> + fun t_sc -> + let unrefine_tsc t_sc1 = + let uu___ = + FStarC_TypeChecker_Normalize.normalize_refinement + FStarC_TypeChecker_Normalize.whnf_steps g.tcenv t_sc1 in + FStarC_Syntax_Util.unrefine uu___ in + match p.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_constant c -> + let e = + match c with + | FStarC_Const.Const_int + (repr, FStar_Pervasives_Native.Some sw) -> + FStarC_ToSyntax_ToSyntax.desugar_machine_integer + (g.tcenv).FStarC_TypeChecker_Env.dsenv repr sw + p.FStarC_Syntax_Syntax.p + | uu___ -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_constant c) + p.FStarC_Syntax_Syntax.p in + let uu___ = check "pat_const" g e in + (fun ctx0 -> + let uu___1 = uu___ ctx0 in + match uu___1 with + | Success (x, g1) -> + let uu___2 = + let uu___3 = + match x with + | (uu___4, t_const) -> + let uu___5 ctx = + let ctx1 = + { + no_guard = (ctx.no_guard); + unfolding_ok = (ctx.unfolding_ok); + error_context = + (("check_pat constant", + FStar_Pervasives_Native.None) :: + (ctx.error_context)) + } in + let uu___6 = + let uu___7 = unrefine_tsc t_sc in + check_subtype g + (FStar_Pervasives_Native.Some e) t_const + uu___7 in + uu___6 ctx1 in + (fun ctx01 -> + let uu___6 = uu___5 ctx01 in + match uu___6 with + | Success (x1, g11) -> + let uu___7 = + let uu___8 uu___9 = + Success + (([], []), + FStar_Pervasives_Native.None) in + uu___8 ctx01 in + (match uu___7 with + | Success (y, g2) -> + let uu___8 = + let uu___9 = and_pre g11 g2 in + (y, uu___9) in + Success uu___8 + | err -> err) + | Error err -> Error err) in + uu___3 ctx0 in + (match uu___2 with + | Success (y, g2) -> + let uu___3 = + let uu___4 = and_pre g1 g2 in (y, uu___4) in + Success uu___3 + | err -> err) + | Error err -> Error err) + | FStarC_Syntax_Syntax.Pat_var bv -> + let b = + FStarC_Syntax_Syntax.mk_binder + { + FStarC_Syntax_Syntax.ppname = + (bv.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (bv.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = t_sc + } in + let uu___ ctx = + let ctx1 = + { + no_guard = (ctx.no_guard); + unfolding_ok = (ctx.unfolding_ok); + error_context = + (("check_pat_binder", FStar_Pervasives_Native.None) :: + (ctx.error_context)) + } in + let uu___1 = check_binders g [b] in uu___1 ctx1 in + (fun ctx0 -> + let uu___1 = uu___ ctx0 in + match uu___1 with + | Success (x, g1) -> + let uu___2 = + let uu___3 = + match x with + | u::[] -> + (fun uu___4 -> + Success + (([b], [u]), FStar_Pervasives_Native.None)) in + uu___3 ctx0 in + (match uu___2 with + | Success (y, g2) -> + let uu___3 = + let uu___4 = and_pre g1 g2 in (y, uu___4) in + Success uu___3 + | err -> err) + | Error err -> Error err) + | FStarC_Syntax_Syntax.Pat_cons (fv, usopt, pats) -> + let us = + if FStarC_Compiler_Util.is_none usopt + then [] + else FStarC_Compiler_Util.must usopt in + let uu___ = + let uu___1 = + let uu___2 = FStarC_Syntax_Syntax.lid_of_fv fv in + FStarC_TypeChecker_Env.lookup_and_inst_datacon g.tcenv us + uu___2 in + FStarC_Syntax_Util.arrow_formals uu___1 in + (match uu___ with + | (formals, t_pat) -> + let uu___1 = + let pats1 = + FStarC_Compiler_List.map FStar_Pervasives_Native.fst + pats in + let uu___2 = + let uu___3 = + FStarC_Compiler_Util.prefix_until + (fun p1 -> + match p1.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_dot_term uu___4 -> + false + | uu___4 -> true) pats1 in + FStarC_Compiler_Util.map_option + (fun uu___4 -> + match uu___4 with + | (dot_pats, pat, rest_pats) -> + (dot_pats, (pat :: rest_pats))) uu___3 in + FStarC_Compiler_Util.dflt (pats1, []) uu___2 in + (match uu___1 with + | (dot_pats, rest_pats) -> + let uu___2 = + FStarC_Compiler_List.splitAt + (FStarC_Compiler_List.length dot_pats) formals in + (match uu___2 with + | (dot_formals, rest_formals) -> + let uu___3 = + fold2 + (fun ss -> + fun uu___4 -> + fun p1 -> + match uu___4 with + | { FStarC_Syntax_Syntax.binder_bv = f; + FStarC_Syntax_Syntax.binder_qual = + uu___5; + FStarC_Syntax_Syntax.binder_positivity + = uu___6; + FStarC_Syntax_Syntax.binder_attrs = + uu___7;_} + -> + let expected_t = + FStarC_Syntax_Subst.subst ss + f.FStarC_Syntax_Syntax.sort in + let uu___8 = + match p1.FStarC_Syntax_Syntax.v + with + | FStarC_Syntax_Syntax.Pat_dot_term + (FStar_Pervasives_Native.Some + t) -> + (fun uu___9 -> + Success + (t, + FStar_Pervasives_Native.None)) + | uu___9 -> + fail + "check_pat in core has unset dot pattern" in + (fun ctx0 -> + let uu___9 = uu___8 ctx0 in + match uu___9 with + | Success (x, g1) -> + let uu___10 = + let uu___11 = + let uu___12 = + check "pat dot term" g + x in + fun ctx01 -> + let uu___13 = + uu___12 ctx01 in + match uu___13 with + | Success (x1, g11) -> + let uu___14 = + let uu___15 = + match x1 with + | (uu___16, + p_t) -> + let uu___17 + ctx = + let ctx1 + = + { + no_guard + = + (ctx.no_guard); + unfolding_ok + = + (ctx.unfolding_ok); + error_context + = + (("check_pat cons", + FStar_Pervasives_Native.None) + :: + (ctx.error_context)) + } in + let uu___18 + = + check_subtype + g + (FStar_Pervasives_Native.Some + x) p_t + expected_t in + uu___18 + ctx1 in + (fun ctx02 + -> + let uu___18 + = + uu___17 + ctx02 in + match uu___18 + with + | + Success + (x2, g12) + -> + let uu___19 + = + let uu___20 + uu___21 = + Success + ((FStar_List_Tot_Base.op_At + ss + [ + FStarC_Syntax_Syntax.NT + (f, x)]), + FStar_Pervasives_Native.None) in + uu___20 + ctx02 in + (match uu___19 + with + | + Success + (y, g2) + -> + let uu___20 + = + let uu___21 + = + and_pre + g12 g2 in + (y, + uu___21) in + Success + uu___20 + | + err -> + err) + | + Error err + -> + Error err) in + uu___15 ctx01 in + (match uu___14 + with + | Success + (y, g2) -> + let uu___15 = + let uu___16 + = + and_pre + g11 g2 in + (y, + uu___16) in + Success + uu___15 + | err -> err) + | Error err -> + Error err in + uu___11 ctx0 in + (match uu___10 with + | Success (y, g2) -> + let uu___11 = + let uu___12 = + and_pre g1 g2 in + (y, uu___12) in + Success uu___11 + | err -> err) + | Error err -> Error err)) [] + dot_formals dot_pats in + (fun ctx0 -> + let uu___4 = uu___3 ctx0 in + match uu___4 with + | Success (x, g1) -> + let uu___5 = + let uu___6 = + let uu___7 = + fold2 + (fun uu___8 -> + fun uu___9 -> + fun p1 -> + match (uu___8, uu___9) with + | ((g2, ss, bs, us1), + { + FStarC_Syntax_Syntax.binder_bv + = f; + FStarC_Syntax_Syntax.binder_qual + = uu___10; + FStarC_Syntax_Syntax.binder_positivity + = uu___11; + FStarC_Syntax_Syntax.binder_attrs + = uu___12;_}) + -> + let expected_t = + FStarC_Syntax_Subst.subst + ss + f.FStarC_Syntax_Syntax.sort in + let uu___13 = + let uu___14 = + check_pat g2 p1 + expected_t in + with_binders bs us1 + uu___14 in + (fun ctx01 -> + let uu___14 = + uu___13 ctx01 in + match uu___14 with + | Success (x1, g11) + -> + let uu___15 = + let uu___16 = + match x1 with + | (bs_p, + us_p) -> + let p_e = + let uu___17 + = + let uu___18 + = + FStarC_TypeChecker_PatternUtils.raw_pat_as_exp + g2.tcenv + p1 in + FStarC_Compiler_Util.must + uu___18 in + FStar_Pervasives_Native.fst + uu___17 in + let uu___17 + = + let uu___18 + = + push_binders + g2 bs_p in + (uu___18, + (FStar_List_Tot_Base.op_At + ss + [ + FStarC_Syntax_Syntax.NT + (f, p_e)]), + (FStar_List_Tot_Base.op_At + bs bs_p), + (FStar_List_Tot_Base.op_At + us1 us_p)) in + (fun + uu___18 + -> + Success + (uu___17, + FStar_Pervasives_Native.None)) in + uu___16 ctx01 in + (match uu___15 + with + | Success + (y, g21) -> + let uu___16 + = + let uu___17 + = + and_pre + g11 g21 in + (y, + uu___17) in + Success + uu___16 + | err -> err) + | Error err -> + Error err)) + (g, x, [], []) rest_formals + rest_pats in + fun ctx01 -> + let uu___8 = uu___7 ctx01 in + match uu___8 with + | Success (x1, g11) -> + let uu___9 = + let uu___10 = + match x1 with + | (uu___11, ss, bs, us1) -> + let t_pat1 = + FStarC_Syntax_Subst.subst + ss t_pat in + let uu___12 = + let uu___13 = + let uu___14 = + unrefine_tsc t_sc in + check_scrutinee_pattern_type_compatible + g uu___14 t_pat1 in + no_guard uu___13 in + (fun ctx02 -> + let uu___13 = + uu___12 ctx02 in + match uu___13 with + | Success (x2, g12) -> + let uu___14 = + let uu___15 + uu___16 = + Success + ((bs, us1), + FStar_Pervasives_Native.None) in + uu___15 ctx02 in + (match uu___14 + with + | Success + (y, g2) -> + let uu___15 = + let uu___16 + = + and_pre + g12 g2 in + (y, + uu___16) in + Success + uu___15 + | err -> err) + | Error err -> + Error err) in + uu___10 ctx01 in + (match uu___9 with + | Success (y, g2) -> + let uu___10 = + let uu___11 = + and_pre g11 g2 in + (y, uu___11) in + Success uu___10 + | err -> err) + | Error err -> Error err in + uu___6 ctx0 in + (match uu___5 with + | Success (y, g2) -> + let uu___6 = + let uu___7 = and_pre g1 g2 in + (y, uu___7) in + Success uu___6 + | err -> err) + | Error err -> Error err)))) + | uu___ -> fail "check_pat called with a dot pattern" +and (check_scrutinee_pattern_type_compatible : + env -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.typ -> precondition result) + = + fun g -> + fun t_sc -> + fun t_pat -> + let err s = + let uu___ = + let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t_sc in + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t_pat in + FStarC_Compiler_Util.format3 + "Scrutinee type %s and Pattern type %s are not compatible because %s" + uu___1 uu___2 s in + fail uu___ in + let uu___ = FStarC_Syntax_Util.head_and_args t_sc in + match uu___ with + | (head_sc, args_sc) -> + let uu___1 = FStarC_Syntax_Util.head_and_args t_pat in + (match uu___1 with + | (head_pat, args_pat) -> + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Subst.compress head_sc in + uu___5.FStarC_Syntax_Syntax.n in + let uu___5 = + let uu___6 = FStarC_Syntax_Subst.compress head_pat in + uu___6.FStarC_Syntax_Syntax.n in + (uu___4, uu___5) in + match uu___3 with + | (FStarC_Syntax_Syntax.Tm_fvar fv_head, + FStarC_Syntax_Syntax.Tm_fvar fv_pat) when + let uu___4 = FStarC_Syntax_Syntax.lid_of_fv fv_head in + let uu___5 = FStarC_Syntax_Syntax.lid_of_fv fv_pat in + FStarC_Ident.lid_equals uu___4 uu___5 -> + (fun uu___4 -> + Success (fv_head, FStar_Pervasives_Native.None)) + | (FStarC_Syntax_Syntax.Tm_uinst + ({ + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Tm_fvar fv_head; + FStarC_Syntax_Syntax.pos = uu___4; + FStarC_Syntax_Syntax.vars = uu___5; + FStarC_Syntax_Syntax.hash_code = uu___6;_}, + us_head), + FStarC_Syntax_Syntax.Tm_uinst + ({ + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Tm_fvar fv_pat; + FStarC_Syntax_Syntax.pos = uu___7; + FStarC_Syntax_Syntax.vars = uu___8; + FStarC_Syntax_Syntax.hash_code = uu___9;_}, + us_pat)) when + let uu___10 = FStarC_Syntax_Syntax.lid_of_fv fv_head in + let uu___11 = FStarC_Syntax_Syntax.lid_of_fv fv_pat in + FStarC_Ident.lid_equals uu___10 uu___11 -> + let uu___10 = + FStarC_TypeChecker_Rel.teq_nosmt_force g.tcenv + head_sc head_pat in + if uu___10 + then + (fun uu___11 -> + Success (fv_head, FStar_Pervasives_Native.None)) + else err "Incompatible universe instantiations" + | (uu___4, uu___5) -> + let uu___6 = + let uu___7 = + FStarC_Class_Tagged.tag_of + FStarC_Syntax_Syntax.tagged_term head_sc in + let uu___8 = + FStarC_Class_Tagged.tag_of + FStarC_Syntax_Syntax.tagged_term head_pat in + FStarC_Compiler_Util.format2 + "Head constructors(%s and %s) not fvar" uu___7 + uu___8 in + err uu___6 in + (fun ctx0 -> + let uu___3 = uu___2 ctx0 in + match uu___3 with + | Success (x, g1) -> + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Syntax_Syntax.lid_of_fv x in + FStarC_TypeChecker_Env.is_type_constructor + g.tcenv uu___8 in + if uu___7 + then + fun uu___8 -> + Success (x, FStar_Pervasives_Native.None) + else + (let uu___9 = + let uu___10 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_fv x in + FStarC_Compiler_Util.format1 + "%s is not a type constructor" uu___10 in + err uu___9) in + fun ctx01 -> + let uu___7 = uu___6 ctx01 in + match uu___7 with + | Success (x1, g11) -> + let uu___8 = + let uu___9 = + let uu___10 = + if + (FStarC_Compiler_List.length + args_sc) + = + (FStarC_Compiler_List.length + args_pat) + then + fun uu___11 -> + Success + (x, + FStar_Pervasives_Native.None) + else + (let uu___12 = + let uu___13 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length + args_sc) in + let uu___14 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length + args_pat) in + FStarC_Compiler_Util.format2 + "Number of arguments don't match (%s and %s)" + uu___13 uu___14 in + err uu___12) in + fun ctx02 -> + let uu___11 = uu___10 ctx02 in + match uu___11 with + | Success (x2, g12) -> + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = + FStarC_Syntax_Syntax.lid_of_fv + x in + FStarC_TypeChecker_Env.num_inductive_ty_params + g.tcenv uu___16 in + match uu___15 with + | FStar_Pervasives_Native.None + -> (args_sc, args_pat) + | FStar_Pervasives_Native.Some + n -> + let uu___16 = + let uu___17 = + FStarC_Compiler_Util.first_N + n args_sc in + FStar_Pervasives_Native.fst + uu___17 in + let uu___17 = + let uu___18 = + FStarC_Compiler_Util.first_N + n args_pat in + FStar_Pervasives_Native.fst + uu___18 in + (uu___16, uu___17) in + match uu___14 with + | (params_sc, params_pat) -> + let uu___15 = + iter2 params_sc + params_pat + (fun uu___16 -> + fun uu___17 -> + fun uu___18 -> + match + (uu___16, + uu___17) + with + | ((t_sc1, + uu___19), + (t_pat1, + uu___20)) + -> + check_relation + g + EQUALITY + t_sc1 + t_pat1) + () in + (fun ctx03 -> + let uu___16 = + uu___15 ctx03 in + match uu___16 with + | Success (x3, g13) -> + let uu___17 = + let uu___18 + uu___19 = + Success + (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None) in + uu___18 ctx03 in + (match uu___17 + with + | Success + (y, g2) -> + let uu___18 = + let uu___19 + = + and_pre + g13 g2 in + (y, + uu___19) in + Success + uu___18 + | err1 -> err1) + | Error err1 -> + Error err1) in + uu___13 ctx02 in + (match uu___12 with + | Success (y, g2) -> + let uu___13 = + let uu___14 = + and_pre g12 g2 in + (y, uu___14) in + Success uu___13 + | err1 -> err1) + | Error err1 -> Error err1 in + uu___9 ctx01 in + (match uu___8 with + | Success (y, g2) -> + let uu___9 = + let uu___10 = and_pre g11 g2 in + (y, uu___10) in + Success uu___9 + | err1 -> err1) + | Error err1 -> Error err1 in + uu___5 ctx0 in + (match uu___4 with + | Success (y, g2) -> + let uu___5 = + let uu___6 = and_pre g1 g2 in (y, uu___6) in + Success uu___5 + | err1 -> err1) + | Error err1 -> Error err1)) +and (pattern_branch_condition : + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.pat -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option result) + = + fun g -> + fun scrutinee -> + fun pat -> + match pat.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_var uu___ -> + (fun uu___1 -> + Success + (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None)) + | FStarC_Syntax_Syntax.Pat_constant c -> + let const_exp = + let uu___ = + FStarC_TypeChecker_PatternUtils.raw_pat_as_exp g.tcenv pat in + match uu___ with + | FStar_Pervasives_Native.None -> failwith "Impossible" + | FStar_Pervasives_Native.Some (e, uu___1) -> e in + let uu___ = check "constant pattern" g const_exp in + (fun ctx0 -> + let uu___1 = uu___ ctx0 in + match uu___1 with + | Success (x, g1) -> + let uu___2 = + let uu___3 = + match x with + | (uu___4, t_const) -> + let uu___5 = + let uu___6 = + FStarC_Syntax_Util.mk_decidable_eq t_const + scrutinee const_exp in + FStar_Pervasives_Native.Some uu___6 in + (fun uu___6 -> + Success (uu___5, FStar_Pervasives_Native.None)) in + uu___3 ctx0 in + (match uu___2 with + | Success (y, g2) -> + let uu___3 = + let uu___4 = and_pre g1 g2 in (y, uu___4) in + Success uu___3 + | err -> err) + | Error err -> Error err) + | FStarC_Syntax_Syntax.Pat_cons (fv, us_opt, sub_pats) -> + let wild_pat pos = + let uu___ = + let uu___1 = + FStarC_Syntax_Syntax.new_bv FStar_Pervasives_Native.None + FStarC_Syntax_Syntax.tun in + FStarC_Syntax_Syntax.Pat_var uu___1 in + FStarC_Syntax_Syntax.withinfo uu___ pos in + let mk_head_discriminator uu___ = + let pat1 = + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Compiler_List.map + (fun uu___4 -> + match uu___4 with + | (s, b) -> + let uu___5 = wild_pat s.FStarC_Syntax_Syntax.p in + (uu___5, b)) sub_pats in + (fv, us_opt, uu___3) in + FStarC_Syntax_Syntax.Pat_cons uu___2 in + FStarC_Syntax_Syntax.withinfo uu___1 + pat.FStarC_Syntax_Syntax.p in + let branch1 = + (pat1, FStar_Pervasives_Native.None, + FStarC_Syntax_Util.exp_true_bool) in + let branch2 = + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Syntax_Syntax.new_bv + FStar_Pervasives_Native.None FStarC_Syntax_Syntax.tun in + FStarC_Syntax_Syntax.Pat_var uu___3 in + FStarC_Syntax_Syntax.withinfo uu___2 + pat1.FStarC_Syntax_Syntax.p in + (uu___1, FStar_Pervasives_Native.None, + FStarC_Syntax_Util.exp_false_bool) in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_match + { + FStarC_Syntax_Syntax.scrutinee = scrutinee; + FStarC_Syntax_Syntax.ret_opt = + FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.brs = [branch1; branch2]; + FStarC_Syntax_Syntax.rc_opt1 = + FStar_Pervasives_Native.None + }) scrutinee.FStarC_Syntax_Syntax.pos in + let mk_ith_projector i = + let uu___ = + let bv = + FStarC_Syntax_Syntax.new_bv FStar_Pervasives_Native.None + FStarC_Syntax_Syntax.tun in + let uu___1 = + FStarC_Syntax_Syntax.withinfo + (FStarC_Syntax_Syntax.Pat_var bv) + scrutinee.FStarC_Syntax_Syntax.pos in + (bv, uu___1) in + match uu___ with + | (ith_pat_var, ith_pat) -> + let sub_pats1 = + FStarC_Compiler_List.mapi + (fun j -> + fun uu___1 -> + match uu___1 with + | (s, b) -> + if i <> j + then + let uu___2 = + wild_pat s.FStarC_Syntax_Syntax.p in + (uu___2, b) + else (ith_pat, b)) sub_pats in + let pat1 = + FStarC_Syntax_Syntax.withinfo + (FStarC_Syntax_Syntax.Pat_cons (fv, us_opt, sub_pats1)) + pat.FStarC_Syntax_Syntax.p in + let branch = FStarC_Syntax_Syntax.bv_to_name ith_pat_var in + let eqn = + FStarC_Syntax_Subst.close_branch + (pat1, FStar_Pervasives_Native.None, branch) in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_match + { + FStarC_Syntax_Syntax.scrutinee = scrutinee; + FStarC_Syntax_Syntax.ret_opt = + FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.brs = [eqn]; + FStarC_Syntax_Syntax.rc_opt1 = + FStar_Pervasives_Native.None + }) scrutinee.FStarC_Syntax_Syntax.pos in + let discrimination = + let uu___ = + let uu___1 = + FStarC_TypeChecker_Env.typ_of_datacon g.tcenv + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + FStarC_TypeChecker_Env.datacons_of_typ g.tcenv uu___1 in + match uu___ with + | (is_induc, datacons) -> + if + (Prims.op_Negation is_induc) || + ((FStarC_Compiler_List.length datacons) > Prims.int_one) + then + let discriminator = + FStarC_Syntax_Util.mk_discriminator + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + let uu___1 = + FStarC_TypeChecker_Env.try_lookup_lid g.tcenv + discriminator in + (match uu___1 with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | uu___2 -> + let uu___3 = mk_head_discriminator () in + FStar_Pervasives_Native.Some uu___3) + else FStar_Pervasives_Native.None in + let uu___ = + mapi + (fun i -> + fun uu___1 -> + match uu___1 with + | (pi, uu___2) -> + (match pi.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_dot_term uu___3 -> + (fun uu___4 -> + Success + (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None)) + | FStarC_Syntax_Syntax.Pat_var uu___3 -> + (fun uu___4 -> + Success + (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None)) + | uu___3 -> + let scrutinee_sub_term = mk_ith_projector i in + let uu___4 = mk_ith_projector i in + pattern_branch_condition g uu___4 pi)) sub_pats in + (fun ctx0 -> + let uu___1 = uu___ ctx0 in + match uu___1 with + | Success (x, g1) -> + let uu___2 = + let uu___3 = + let guards = + FStarC_Compiler_List.collect + (fun uu___4 -> + match uu___4 with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some t -> [t]) + (discrimination :: x) in + match guards with + | [] -> + (fun uu___4 -> + Success + (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None)) + | guards1 -> + let uu___4 = + let uu___5 = FStarC_Syntax_Util.mk_and_l guards1 in + FStar_Pervasives_Native.Some uu___5 in + (fun uu___5 -> + Success (uu___4, FStar_Pervasives_Native.None)) in + uu___3 ctx0 in + (match uu___2 with + | Success (y, g2) -> + let uu___3 = + let uu___4 = and_pre g1 g2 in (y, uu___4) in + Success uu___3 + | err -> err) + | Error err -> Error err) +let (initial_env : + FStarC_TypeChecker_Env.env -> + guard_handler_t FStar_Pervasives_Native.option -> env) + = + fun g -> + fun gh -> + let max_index = + FStarC_Compiler_List.fold_left + (fun index -> + fun b -> + match b with + | FStarC_Syntax_Syntax.Binding_var x -> + if x.FStarC_Syntax_Syntax.index > index + then x.FStarC_Syntax_Syntax.index + else index + | uu___ -> index) Prims.int_zero + g.FStarC_TypeChecker_Env.gamma in + { + tcenv = g; + allow_universe_instantiation = false; + max_binder_index = max_index; + guard_handler = gh; + should_read_cache = true + } +let (check_term_top : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.typ FStar_Pervasives_Native.option -> + Prims.bool -> + guard_handler_t FStar_Pervasives_Native.option -> + (tot_or_ghost * FStarC_Syntax_Syntax.typ) result) + = + fun g -> + fun e -> + fun topt -> + fun must_tot -> + fun gh -> + let g1 = initial_env g gh in + let uu___ = check "top" g1 e in + fun ctx0 -> + let uu___1 = uu___ ctx0 in + match uu___1 with + | Success (x, g11) -> + let uu___2 = + let uu___3 = + match topt with + | FStar_Pervasives_Native.None -> + if must_tot + then + let uu___4 = x in + (match uu___4 with + | (eff, t) -> + let uu___5 = + (eff = E_Ghost) && + (let uu___6 = non_informative g1 t in + Prims.op_Negation uu___6) in + if uu___5 + then + fail "expected total effect, found ghost" + else + (fun uu___7 -> + Success + ((E_Total, t), + FStar_Pervasives_Native.None))) + else + (fun uu___5 -> + Success (x, FStar_Pervasives_Native.None)) + | FStar_Pervasives_Native.Some t -> + let uu___4 = + if + must_tot || + ((FStar_Pervasives_Native.fst x) = E_Total) + then + let uu___5 = FStarC_Syntax_Syntax.mk_Total t in + (uu___5, E_Total) + else + (let uu___6 = FStarC_Syntax_Syntax.mk_GTotal t in + (uu___6, E_Ghost)) in + (match uu___4 with + | (target_comp, eff) -> + let uu___5 ctx = + let ctx1 = + { + no_guard = (ctx.no_guard); + unfolding_ok = (ctx.unfolding_ok); + error_context = + (("top-level subtyping", + FStar_Pervasives_Native.None) :: + (ctx.error_context)) + } in + let uu___6 = + let uu___7 = as_comp g1 x in + check_relation_comp + { + tcenv = (g1.tcenv); + allow_universe_instantiation = true; + max_binder_index = + (g1.max_binder_index); + guard_handler = (g1.guard_handler); + should_read_cache = + (g1.should_read_cache) + } + (SUBTYPING + (FStar_Pervasives_Native.Some e)) + uu___7 target_comp in + uu___6 ctx1 in + (fun ctx01 -> + let uu___6 = uu___5 ctx01 in + match uu___6 with + | Success (x1, g12) -> + let uu___7 = + let uu___8 uu___9 = + Success + ((eff, t), + FStar_Pervasives_Native.None) in + uu___8 ctx01 in + (match uu___7 with + | Success (y, g2) -> + let uu___8 = + let uu___9 = and_pre g12 g2 in + (y, uu___9) in + Success uu___8 + | err -> err) + | Error err -> Error err)) in + uu___3 ctx0 in + (match uu___2 with + | Success (y, g2) -> + let uu___3 = + let uu___4 = and_pre g11 g2 in (y, uu___4) in + Success uu___3 + | err -> err) + | Error err -> Error err +let (simplify_steps : FStarC_TypeChecker_Env.step Prims.list) = + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.UnfoldUntil FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.UnfoldQual ["unfold"]; + FStarC_TypeChecker_Env.UnfoldOnly + [FStarC_Parser_Const.pure_wp_monotonic_lid; + FStarC_Parser_Const.pure_wp_monotonic0_lid]; + FStarC_TypeChecker_Env.Simplify; + FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.NoFullNorm] +let (check_term_top_gh : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.typ FStar_Pervasives_Native.option -> + Prims.bool -> + guard_handler_t FStar_Pervasives_Native.option -> + ((tot_or_ghost * FStarC_Syntax_Syntax.typ) * precondition) + __result) + = + fun g -> + fun e -> + fun topt -> + fun must_tot -> + fun gh -> + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_Eq in + if uu___1 + then + let uu___2 = + let uu___3 = get_goal_ctr () in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) uu___3 in + FStarC_Compiler_Util.print1 "(%s) Entering core ... \n" uu___2 + else ()); + (let uu___2 = + (FStarC_Compiler_Effect.op_Bang dbg) || + (FStarC_Compiler_Effect.op_Bang dbg_Top) in + if uu___2 + then + let uu___3 = + let uu___4 = get_goal_ctr () in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) uu___4 in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + let uu___5 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_option + FStarC_Syntax_Print.showable_term) topt in + FStarC_Compiler_Util.print3 + "(%s) Entering core with %s <: %s\n" uu___3 uu___4 uu___5 + else ()); + FStarC_Syntax_TermHashTable.reset_counters table; + reset_cache_stats (); + (let ctx = + { + no_guard = false; + unfolding_ok = true; + error_context = [("Top", FStar_Pervasives_Native.None)] + } in + let res = + FStarC_Profiling.profile + (fun uu___4 -> + let uu___5 = + let uu___6 = check_term_top g e topt must_tot gh in + uu___6 ctx in + match uu___5 with + | Success (et, g1) -> Success (et, g1) + | Error err -> Error err) FStar_Pervasives_Native.None + "FStarC.TypeChecker.Core.check_term_top" in + let res1 = + match res with + | Success (et, FStar_Pervasives_Native.Some guard0) -> + let guard1 = + FStarC_TypeChecker_Normalize.normalize simplify_steps g + guard0 in + ((let uu___5 = + ((FStarC_Compiler_Effect.op_Bang dbg) || + (FStarC_Compiler_Effect.op_Bang dbg_Top)) + || (FStarC_Compiler_Effect.op_Bang dbg_Exit) in + if uu___5 + then + ((let uu___7 = + let uu___8 = get_goal_ctr () in + FStarC_Compiler_Util.string_of_int uu___8 in + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term guard0 in + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term guard1 in + FStarC_Compiler_Util.print3 + "(%s) Exiting core: Simplified guard from {{%s}} to {{%s}}\n" + uu___7 uu___8 uu___9); + (let guard_names = + let uu___7 = FStarC_Syntax_Free.names guard1 in + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) + (Obj.magic uu___7) in + let uu___7 = + FStarC_Compiler_List.tryFind + (fun bv -> + FStarC_Compiler_List.for_all + (fun binding_env -> + match binding_env with + | FStarC_Syntax_Syntax.Binding_var + bv_env -> + let uu___8 = + FStarC_Syntax_Syntax.bv_eq bv_env + bv in + Prims.op_Negation uu___8 + | uu___8 -> true) + g.FStarC_TypeChecker_Env.gamma) guard_names in + match uu___7 with + | FStar_Pervasives_Native.Some bv -> + let uu___8 = + let uu___9 = + FStarC_Syntax_Syntax.bv_to_name bv in + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term uu___9 in + FStarC_Compiler_Util.print1 + "WARNING: %s is free in the core generated guard\n" + uu___8 + | uu___8 -> ())) + else ()); + Success (et, (FStar_Pervasives_Native.Some guard1))) + | Success uu___4 -> + ((let uu___6 = + (FStarC_Compiler_Effect.op_Bang dbg) || + (FStarC_Compiler_Effect.op_Bang dbg_Top) in + if uu___6 + then + let uu___7 = + let uu___8 = get_goal_ctr () in + FStarC_Compiler_Util.string_of_int uu___8 in + FStarC_Compiler_Util.print1 "(%s) Exiting core (ok)\n" + uu___7 + else ()); + res) + | Error uu___4 -> + ((let uu___6 = + (FStarC_Compiler_Effect.op_Bang dbg) || + (FStarC_Compiler_Effect.op_Bang dbg_Top) in + if uu___6 + then + let uu___7 = + let uu___8 = get_goal_ctr () in + FStarC_Compiler_Util.string_of_int uu___8 in + FStarC_Compiler_Util.print1 + "(%s) Exiting core (failed)\n" uu___7 + else ()); + res) in + (let uu___5 = FStarC_Compiler_Effect.op_Bang dbg_Eq in + if uu___5 + then + (FStarC_Syntax_TermHashTable.print_stats table; + (let cs = report_cache_stats () in + let uu___7 = FStarC_Compiler_Util.string_of_int cs.hits in + let uu___8 = FStarC_Compiler_Util.string_of_int cs.misses in + FStarC_Compiler_Util.print2 + "Cache_stats { hits = %s; misses = %s }\n" uu___7 uu___8)) + else ()); + res1) +let (check_term : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.typ -> + Prims.bool -> + (FStarC_Syntax_Syntax.typ FStar_Pervasives_Native.option, error) + FStar_Pervasives.either) + = + fun g -> + fun e -> + fun t -> + fun must_tot -> + let uu___ = + check_term_top_gh g e (FStar_Pervasives_Native.Some t) must_tot + FStar_Pervasives_Native.None in + match uu___ with + | Success (uu___1, g1) -> FStar_Pervasives.Inl g1 + | Error err -> FStar_Pervasives.Inr err +let (check_term_at_type : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.typ -> + ((tot_or_ghost * FStarC_Syntax_Syntax.typ + FStar_Pervasives_Native.option), + error) FStar_Pervasives.either) + = + fun g -> + fun e -> + fun t -> + let must_tot = false in + let uu___ = + check_term_top_gh g e (FStar_Pervasives_Native.Some t) must_tot + FStar_Pervasives_Native.None in + match uu___ with + | Success ((eff, uu___1), g1) -> FStar_Pervasives.Inl (eff, g1) + | Error err -> FStar_Pervasives.Inr err +let (compute_term_type_handle_guards : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + (FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.typ -> Prims.bool) + -> + ((tot_or_ghost * FStarC_Syntax_Syntax.typ), error) + FStar_Pervasives.either) + = + fun g -> + fun e -> + fun gh -> + let e1 = FStarC_Syntax_Compress.deep_compress true true e in + let must_tot = false in + let uu___ = + check_term_top_gh g e1 FStar_Pervasives_Native.None must_tot + (FStar_Pervasives_Native.Some gh) in + match uu___ with + | Success (r, FStar_Pervasives_Native.None) -> FStar_Pervasives.Inl r + | Success (uu___1, FStar_Pervasives_Native.Some uu___2) -> + failwith + "Impossible: All guards should have been handled already" + | Error err -> FStar_Pervasives.Inr err +let (open_binders_in_term : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.term -> + (FStarC_TypeChecker_Env.env * FStarC_Syntax_Syntax.binders * + FStarC_Syntax_Syntax.term)) + = + fun env1 -> + fun bs -> + fun t -> + let g = initial_env env1 FStar_Pervasives_Native.None in + let uu___ = open_term_binders g bs t in + match uu___ with | (g', bs1, t1) -> ((g'.tcenv), bs1, t1) +let (open_binders_in_comp : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.comp -> + (FStarC_TypeChecker_Env.env * FStarC_Syntax_Syntax.binders * + FStarC_Syntax_Syntax.comp)) + = + fun env1 -> + fun bs -> + fun c -> + let g = initial_env env1 FStar_Pervasives_Native.None in + let uu___ = open_comp_binders g bs c in + match uu___ with | (g', bs1, c1) -> ((g'.tcenv), bs1, c1) +let (check_term_equality : + Prims.bool -> + Prims.bool -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.typ -> + (FStarC_Syntax_Syntax.typ FStar_Pervasives_Native.option, + error) FStar_Pervasives.either) + = + fun guard_ok -> + fun unfolding_ok1 -> + fun g -> + fun t0 -> + fun t1 -> + let g1 = initial_env g FStar_Pervasives_Native.None in + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_Top in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t0 in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + let uu___4 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) guard_ok in + let uu___5 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) unfolding_ok1 in + FStarC_Compiler_Util.print4 + "Entering check_term_equality with %s and %s (guard_ok=%s; unfolding_ok=%s) {\n" + uu___2 uu___3 uu___4 uu___5 + else ()); + (let ctx = + { + no_guard = (Prims.op_Negation guard_ok); + unfolding_ok = unfolding_ok1; + error_context = [("Eq", FStar_Pervasives_Native.None)] + } in + let r = + let uu___1 = check_relation g1 EQUALITY t0 t1 in uu___1 ctx in + (let uu___2 = FStarC_Compiler_Effect.op_Bang dbg_Top in + if uu___2 + then + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t0 in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + let uu___5 = + FStarC_Class_Show.show + (showable_result + (FStarC_Class_Show.show_tuple2 + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_unit) + (FStarC_Class_Show.show_option + FStarC_Syntax_Print.showable_term))) r in + FStarC_Compiler_Util.print3 + "} Exiting check_term_equality (%s, %s). Result = %s.\n" + uu___3 uu___4 uu___5 + else ()); + (let r1 = + match r with + | Success (uu___2, g2) -> FStar_Pervasives.Inl g2 + | Error err -> FStar_Pervasives.Inr err in + r1)) +let (check_term_subtyping : + Prims.bool -> + Prims.bool -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.typ -> + (FStarC_Syntax_Syntax.typ FStar_Pervasives_Native.option, + error) FStar_Pervasives.either) + = + fun guard_ok -> + fun unfolding_ok1 -> + fun g -> + fun t0 -> + fun t1 -> + let g1 = initial_env g FStar_Pervasives_Native.None in + let ctx = + { + no_guard = (Prims.op_Negation guard_ok); + unfolding_ok = unfolding_ok1; + error_context = [("Subtyping", FStar_Pervasives_Native.None)] + } in + let uu___ = + let uu___1 = + check_relation g1 (SUBTYPING FStar_Pervasives_Native.None) t0 + t1 in + uu___1 ctx in + match uu___ with + | Success (uu___1, g2) -> FStar_Pervasives.Inl g2 + | Error err -> FStar_Pervasives.Inr err \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_DMFF.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_DMFF.ml new file mode 100644 index 00000000000..04eb13bc702 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_DMFF.ml @@ -0,0 +1,5348 @@ +open Prims +type env = + { + tcenv: FStarC_TypeChecker_Env.env ; + subst: FStarC_Syntax_Syntax.subst_elt Prims.list ; + tc_const: FStarC_Const.sconst -> FStarC_Syntax_Syntax.typ } +let (__proj__Mkenv__item__tcenv : env -> FStarC_TypeChecker_Env.env) = + fun projectee -> + match projectee with | { tcenv; subst; tc_const;_} -> tcenv +let (__proj__Mkenv__item__subst : + env -> FStarC_Syntax_Syntax.subst_elt Prims.list) = + fun projectee -> + match projectee with | { tcenv; subst; tc_const;_} -> subst +let (__proj__Mkenv__item__tc_const : + env -> FStarC_Const.sconst -> FStarC_Syntax_Syntax.typ) = + fun projectee -> + match projectee with | { tcenv; subst; tc_const;_} -> tc_const +let (dbg : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "ED" +let (d : Prims.string -> unit) = + fun s -> FStarC_Compiler_Util.print1 "\027[01;36m%s\027[00m\n" s +let (mk_toplevel_definition : + FStarC_TypeChecker_Env.env_t -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.sigelt * FStarC_Syntax_Syntax.term)) + = + fun env1 -> + fun lident -> + fun def -> + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg in + if uu___1 + then + ((let uu___3 = FStarC_Ident.string_of_lid lident in d uu___3); + (let uu___3 = + FStarC_Class_Show.show FStarC_Ident.showable_lident lident in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term def in + FStarC_Compiler_Util.print2 + "Registering top-level definition: %s\n%s\n" uu___3 uu___4)) + else ()); + (let fv = + FStarC_Syntax_Syntax.lid_and_dd_as_fv lident + FStar_Pervasives_Native.None in + let lbname = FStar_Pervasives.Inr fv in + let lb = + (false, + [FStarC_Syntax_Util.mk_letbinding lbname [] + FStarC_Syntax_Syntax.tun FStarC_Parser_Const.effect_Tot_lid + def [] FStarC_Compiler_Range_Type.dummyRange]) in + let sig_ctx = + FStarC_Syntax_Syntax.mk_sigelt + (FStarC_Syntax_Syntax.Sig_let + { + FStarC_Syntax_Syntax.lbs1 = lb; + FStarC_Syntax_Syntax.lids1 = [lident] + }) in + let uu___1 = + FStarC_Syntax_Syntax.mk (FStarC_Syntax_Syntax.Tm_fvar fv) + FStarC_Compiler_Range_Type.dummyRange in + ({ + FStarC_Syntax_Syntax.sigel = (sig_ctx.FStarC_Syntax_Syntax.sigel); + FStarC_Syntax_Syntax.sigrng = + (sig_ctx.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + [FStarC_Syntax_Syntax.Unfold_for_unification_and_vcgen]; + FStarC_Syntax_Syntax.sigmeta = + (sig_ctx.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (sig_ctx.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (sig_ctx.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (sig_ctx.FStarC_Syntax_Syntax.sigopts) + }, uu___1)) +let (empty : + FStarC_TypeChecker_Env.env -> + (FStarC_Const.sconst -> FStarC_Syntax_Syntax.typ) -> env) + = fun env1 -> fun tc_const -> { tcenv = env1; subst = []; tc_const } +let (gen_wps_for_free : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.bv -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.eff_decl -> + (FStarC_Syntax_Syntax.sigelts * FStarC_Syntax_Syntax.eff_decl)) + = + fun env1 -> + fun binders -> + fun a -> + fun wp_a -> + fun ed -> + let wp_a1 = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.EraseUniverses] env1 wp_a in + let a1 = + let uu___ = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.EraseUniverses] env1 + a.FStarC_Syntax_Syntax.sort in + { + FStarC_Syntax_Syntax.ppname = (a.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = (a.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = uu___ + } in + let d1 s = + FStarC_Compiler_Util.print1 "\027[01;36m%s\027[00m\n" s in + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg in + if uu___1 + then + (d1 "Elaborating extra WP combinators"; + (let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + wp_a1 in + FStarC_Compiler_Util.print1 "wp_a is: %s\n" uu___3)) + else ()); + (let rec collect_binders t = + let t1 = FStarC_Syntax_Util.unascribe t in + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress t1 in + uu___2.FStarC_Syntax_Syntax.n in + match uu___1 with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = comp;_} + -> + let rest = + match comp.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total t2 -> t2 + | uu___2 -> + let uu___3 = + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_comp comp in + FStarC_Compiler_Util.format1 + "wp_a contains non-Tot arrow: %s" uu___4 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) comp + FStarC_Errors_Codes.Error_UnexpectedDM4FType () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___3) in + let uu___2 = collect_binders rest in + FStarC_Compiler_List.op_At bs uu___2 + | FStarC_Syntax_Syntax.Tm_type uu___2 -> [] + | uu___2 -> + let uu___3 = + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.format1 + "wp_a doesn't end in Type0, but rather in %s" uu___4 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) t1 + FStarC_Errors_Codes.Error_UnexpectedDM4FType () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___3) in + let mk_lid name = FStarC_Syntax_Util.dm4f_lid ed name in + let gamma = + let uu___1 = collect_binders wp_a1 in + FStarC_Syntax_Util.name_binders uu___1 in + (let uu___2 = FStarC_Compiler_Effect.op_Bang dbg in + if uu___2 + then + let uu___3 = + let uu___4 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binder) gamma in + FStarC_Compiler_Util.format1 "Gamma is %s\n" uu___4 in + d1 uu___3 + else ()); + (let unknown = FStarC_Syntax_Syntax.tun in + let mk x = + FStarC_Syntax_Syntax.mk x + FStarC_Compiler_Range_Type.dummyRange in + let sigelts = FStarC_Compiler_Util.mk_ref [] in + let register env2 lident def = + let uu___2 = mk_toplevel_definition env2 lident def in + match uu___2 with + | (sigelt, fv) -> + let sigelt1 = + { + FStarC_Syntax_Syntax.sigel = + (sigelt.FStarC_Syntax_Syntax.sigel); + FStarC_Syntax_Syntax.sigrng = + (sigelt.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (sigelt.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (let uu___3 = sigelt.FStarC_Syntax_Syntax.sigmeta in + { + FStarC_Syntax_Syntax.sigmeta_active = + (uu___3.FStarC_Syntax_Syntax.sigmeta_active); + FStarC_Syntax_Syntax.sigmeta_fact_db_ids = + (uu___3.FStarC_Syntax_Syntax.sigmeta_fact_db_ids); + FStarC_Syntax_Syntax.sigmeta_admit = true; + FStarC_Syntax_Syntax.sigmeta_spliced = + (uu___3.FStarC_Syntax_Syntax.sigmeta_spliced); + FStarC_Syntax_Syntax.sigmeta_already_checked = + (uu___3.FStarC_Syntax_Syntax.sigmeta_already_checked); + FStarC_Syntax_Syntax.sigmeta_extension_data = + (uu___3.FStarC_Syntax_Syntax.sigmeta_extension_data) + }); + FStarC_Syntax_Syntax.sigattrs = + (sigelt.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (sigelt.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (sigelt.FStarC_Syntax_Syntax.sigopts) + } in + ((let uu___4 = + let uu___5 = FStarC_Compiler_Effect.op_Bang sigelts in + sigelt1 :: uu___5 in + FStarC_Compiler_Effect.op_Colon_Equals sigelts uu___4); + fv) in + let binders_of_list = + FStarC_Compiler_List.map + (fun uu___2 -> + match uu___2 with + | (t, b) -> + let uu___3 = + FStarC_Syntax_Syntax.as_bqual_implicit b in + FStarC_Syntax_Syntax.mk_binder_with_attrs t uu___3 + FStar_Pervasives_Native.None []) in + let mk_all_implicit = + FStarC_Compiler_List.map + (fun t -> + let uu___2 = FStarC_Syntax_Syntax.as_bqual_implicit true in + { + FStarC_Syntax_Syntax.binder_bv = + (t.FStarC_Syntax_Syntax.binder_bv); + FStarC_Syntax_Syntax.binder_qual = uu___2; + FStarC_Syntax_Syntax.binder_positivity = + (t.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs = + (t.FStarC_Syntax_Syntax.binder_attrs) + }) in + let args_of_binders = + FStarC_Compiler_List.map + (fun bv -> + let uu___2 = + FStarC_Syntax_Syntax.bv_to_name + bv.FStarC_Syntax_Syntax.binder_bv in + FStarC_Syntax_Syntax.as_arg uu___2) in + let uu___2 = + let uu___3 = + let mk1 f = + let t = + FStarC_Syntax_Syntax.gen_bv "t" + FStar_Pervasives_Native.None FStarC_Syntax_Util.ktype in + let body = + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.bv_to_name t in + f uu___5 in + FStarC_Syntax_Util.arrow gamma uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Syntax_Syntax.mk_binder a1 in + let uu___7 = + let uu___8 = FStarC_Syntax_Syntax.mk_binder t in + [uu___8] in + uu___6 :: uu___7 in + FStarC_Compiler_List.op_At binders uu___5 in + FStarC_Syntax_Util.abs uu___4 body + FStar_Pervasives_Native.None in + let uu___4 = mk1 FStarC_Syntax_Syntax.mk_Total in + let uu___5 = mk1 FStarC_Syntax_Syntax.mk_GTotal in + (uu___4, uu___5) in + match uu___3 with + | (ctx_def, gctx_def) -> + let ctx_lid = mk_lid "ctx" in + let ctx_fv = register env1 ctx_lid ctx_def in + let gctx_lid = mk_lid "gctx" in + let gctx_fv = register env1 gctx_lid gctx_def in + let mk_app fv t = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Compiler_List.map + (fun uu___8 -> + match uu___8 with + | { FStarC_Syntax_Syntax.binder_bv = bv; + FStarC_Syntax_Syntax.binder_qual = + uu___9; + FStarC_Syntax_Syntax.binder_positivity + = uu___10; + FStarC_Syntax_Syntax.binder_attrs = + uu___11;_} + -> + let uu___12 = + FStarC_Syntax_Syntax.bv_to_name bv in + let uu___13 = + FStarC_Syntax_Syntax.as_aqual_implicit + false in + (uu___12, uu___13)) binders in + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Syntax_Syntax.bv_to_name a1 in + let uu___11 = + FStarC_Syntax_Syntax.as_aqual_implicit + false in + (uu___10, uu___11) in + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Syntax_Syntax.as_aqual_implicit + false in + (t, uu___12) in + [uu___11] in + uu___9 :: uu___10 in + FStarC_Compiler_List.op_At uu___7 uu___8 in + { + FStarC_Syntax_Syntax.hd = fv; + FStarC_Syntax_Syntax.args = uu___6 + } in + FStarC_Syntax_Syntax.Tm_app uu___5 in + mk uu___4 in + (env1, (mk_app ctx_fv), (mk_app gctx_fv)) in + match uu___2 with + | (env2, mk_ctx, mk_gctx) -> + let c_pure = + let t = + FStarC_Syntax_Syntax.gen_bv "t" + FStar_Pervasives_Native.None FStarC_Syntax_Util.ktype in + let x = + let uu___3 = FStarC_Syntax_Syntax.bv_to_name t in + FStarC_Syntax_Syntax.gen_bv "x" + FStar_Pervasives_Native.None uu___3 in + let ret = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.bv_to_name t in + mk_ctx uu___5 in + FStarC_Syntax_Util.residual_tot uu___4 in + FStar_Pervasives_Native.Some uu___3 in + let body = + let uu___3 = FStarC_Syntax_Syntax.bv_to_name x in + FStarC_Syntax_Util.abs gamma uu___3 ret in + let uu___3 = + let uu___4 = mk_all_implicit binders in + let uu___5 = + binders_of_list [(a1, true); (t, true); (x, false)] in + FStarC_Compiler_List.op_At uu___4 uu___5 in + FStarC_Syntax_Util.abs uu___3 body ret in + let c_pure1 = + let uu___3 = mk_lid "pure" in register env2 uu___3 c_pure in + let c_app = + let t1 = + FStarC_Syntax_Syntax.gen_bv "t1" + FStar_Pervasives_Native.None FStarC_Syntax_Util.ktype in + let t2 = + FStarC_Syntax_Syntax.gen_bv "t2" + FStar_Pervasives_Native.None FStarC_Syntax_Util.ktype in + let l = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Syntax.bv_to_name t1 in + FStarC_Syntax_Syntax.new_bv + FStar_Pervasives_Native.None uu___8 in + FStarC_Syntax_Syntax.mk_binder uu___7 in + [uu___6] in + let uu___6 = + let uu___7 = FStarC_Syntax_Syntax.bv_to_name t2 in + FStarC_Syntax_Syntax.mk_GTotal uu___7 in + FStarC_Syntax_Util.arrow uu___5 uu___6 in + mk_gctx uu___4 in + FStarC_Syntax_Syntax.gen_bv "l" + FStar_Pervasives_Native.None uu___3 in + let r = + let uu___3 = + let uu___4 = FStarC_Syntax_Syntax.bv_to_name t1 in + mk_gctx uu___4 in + FStarC_Syntax_Syntax.gen_bv "r" + FStar_Pervasives_Native.None uu___3 in + let ret = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.bv_to_name t2 in + mk_gctx uu___5 in + FStarC_Syntax_Util.residual_tot uu___4 in + FStar_Pervasives_Native.Some uu___3 in + let outer_body = + let gamma_as_args = args_of_binders gamma in + let inner_body = + let uu___3 = FStarC_Syntax_Syntax.bv_to_name l in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Syntax.bv_to_name r in + FStarC_Syntax_Util.mk_app uu___8 + gamma_as_args in + FStarC_Syntax_Syntax.as_arg uu___7 in + [uu___6] in + FStarC_Compiler_List.op_At gamma_as_args uu___5 in + FStarC_Syntax_Util.mk_app uu___3 uu___4 in + FStarC_Syntax_Util.abs gamma inner_body ret in + let uu___3 = + let uu___4 = mk_all_implicit binders in + let uu___5 = + binders_of_list + [(a1, true); + (t1, true); + (t2, true); + (l, false); + (r, false)] in + FStarC_Compiler_List.op_At uu___4 uu___5 in + FStarC_Syntax_Util.abs uu___3 outer_body ret in + let c_app1 = + let uu___3 = mk_lid "app" in register env2 uu___3 c_app in + let c_lift1 = + let t1 = + FStarC_Syntax_Syntax.gen_bv "t1" + FStar_Pervasives_Native.None FStarC_Syntax_Util.ktype in + let t2 = + FStarC_Syntax_Syntax.gen_bv "t2" + FStar_Pervasives_Native.None FStarC_Syntax_Util.ktype in + let t_f = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.bv_to_name t1 in + FStarC_Syntax_Syntax.null_binder uu___5 in + [uu___4] in + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.bv_to_name t2 in + FStarC_Syntax_Syntax.mk_GTotal uu___5 in + FStarC_Syntax_Util.arrow uu___3 uu___4 in + let f = + FStarC_Syntax_Syntax.gen_bv "f" + FStar_Pervasives_Native.None t_f in + let a11 = + let uu___3 = + let uu___4 = FStarC_Syntax_Syntax.bv_to_name t1 in + mk_gctx uu___4 in + FStarC_Syntax_Syntax.gen_bv "a1" + FStar_Pervasives_Native.None uu___3 in + let ret = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.bv_to_name t2 in + mk_gctx uu___5 in + FStarC_Syntax_Util.residual_tot uu___4 in + FStar_Pervasives_Native.Some uu___3 in + let uu___3 = + let uu___4 = mk_all_implicit binders in + let uu___5 = + binders_of_list + [(a1, true); + (t1, true); + (t2, true); + (f, false); + (a11, false)] in + FStarC_Compiler_List.op_At uu___4 uu___5 in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Syntax_Syntax.bv_to_name f in + [uu___10] in + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.as_arg uu___9 in + FStarC_Syntax_Util.mk_app c_pure1 uu___8 in + let uu___8 = + let uu___9 = FStarC_Syntax_Syntax.bv_to_name a11 in + [uu___9] in + uu___7 :: uu___8 in + FStarC_Compiler_List.map FStarC_Syntax_Syntax.as_arg + uu___6 in + FStarC_Syntax_Util.mk_app c_app1 uu___5 in + FStarC_Syntax_Util.abs uu___3 uu___4 ret in + let c_lift11 = + let uu___3 = mk_lid "lift1" in + register env2 uu___3 c_lift1 in + let c_lift2 = + let t1 = + FStarC_Syntax_Syntax.gen_bv "t1" + FStar_Pervasives_Native.None FStarC_Syntax_Util.ktype in + let t2 = + FStarC_Syntax_Syntax.gen_bv "t2" + FStar_Pervasives_Native.None FStarC_Syntax_Util.ktype in + let t3 = + FStarC_Syntax_Syntax.gen_bv "t3" + FStar_Pervasives_Native.None FStarC_Syntax_Util.ktype in + let t_f = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.bv_to_name t1 in + FStarC_Syntax_Syntax.null_binder uu___5 in + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Syntax_Syntax.bv_to_name t2 in + FStarC_Syntax_Syntax.null_binder uu___7 in + [uu___6] in + uu___4 :: uu___5 in + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.bv_to_name t3 in + FStarC_Syntax_Syntax.mk_GTotal uu___5 in + FStarC_Syntax_Util.arrow uu___3 uu___4 in + let f = + FStarC_Syntax_Syntax.gen_bv "f" + FStar_Pervasives_Native.None t_f in + let a11 = + let uu___3 = + let uu___4 = FStarC_Syntax_Syntax.bv_to_name t1 in + mk_gctx uu___4 in + FStarC_Syntax_Syntax.gen_bv "a1" + FStar_Pervasives_Native.None uu___3 in + let a2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Syntax.bv_to_name t2 in + mk_gctx uu___4 in + FStarC_Syntax_Syntax.gen_bv "a2" + FStar_Pervasives_Native.None uu___3 in + let ret = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.bv_to_name t3 in + mk_gctx uu___5 in + FStarC_Syntax_Util.residual_tot uu___4 in + FStar_Pervasives_Native.Some uu___3 in + let uu___3 = + let uu___4 = mk_all_implicit binders in + let uu___5 = + binders_of_list + [(a1, true); + (t1, true); + (t2, true); + (t3, true); + (f, false); + (a11, false); + (a2, false)] in + FStarC_Compiler_List.op_At uu___4 uu___5 in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Syntax_Syntax.bv_to_name f in + [uu___13] in + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.as_arg uu___12 in + FStarC_Syntax_Util.mk_app c_pure1 uu___11 in + let uu___11 = + let uu___12 = + FStarC_Syntax_Syntax.bv_to_name a11 in + [uu___12] in + uu___10 :: uu___11 in + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.as_arg uu___9 in + FStarC_Syntax_Util.mk_app c_app1 uu___8 in + let uu___8 = + let uu___9 = FStarC_Syntax_Syntax.bv_to_name a2 in + [uu___9] in + uu___7 :: uu___8 in + FStarC_Compiler_List.map FStarC_Syntax_Syntax.as_arg + uu___6 in + FStarC_Syntax_Util.mk_app c_app1 uu___5 in + FStarC_Syntax_Util.abs uu___3 uu___4 ret in + let c_lift21 = + let uu___3 = mk_lid "lift2" in + register env2 uu___3 c_lift2 in + let c_push = + let t1 = + FStarC_Syntax_Syntax.gen_bv "t1" + FStar_Pervasives_Native.None FStarC_Syntax_Util.ktype in + let t2 = + FStarC_Syntax_Syntax.gen_bv "t2" + FStar_Pervasives_Native.None FStarC_Syntax_Util.ktype in + let t_f = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.bv_to_name t1 in + FStarC_Syntax_Syntax.null_binder uu___5 in + [uu___4] in + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Syntax_Syntax.bv_to_name t2 in + mk_gctx uu___6 in + FStarC_Syntax_Syntax.mk_Total uu___5 in + FStarC_Syntax_Util.arrow uu___3 uu___4 in + let f = + FStarC_Syntax_Syntax.gen_bv "f" + FStar_Pervasives_Native.None t_f in + let ret = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Syntax.bv_to_name t1 in + FStarC_Syntax_Syntax.null_binder uu___8 in + [uu___7] in + let uu___7 = + let uu___8 = FStarC_Syntax_Syntax.bv_to_name t2 in + FStarC_Syntax_Syntax.mk_GTotal uu___8 in + FStarC_Syntax_Util.arrow uu___6 uu___7 in + mk_ctx uu___5 in + FStarC_Syntax_Util.residual_tot uu___4 in + FStar_Pervasives_Native.Some uu___3 in + let e1 = + let uu___3 = FStarC_Syntax_Syntax.bv_to_name t1 in + FStarC_Syntax_Syntax.gen_bv "e1" + FStar_Pervasives_Native.None uu___3 in + let body = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.mk_binder e1 in + [uu___5] in + FStarC_Compiler_List.op_At gamma uu___4 in + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.bv_to_name f in + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Syntax_Syntax.bv_to_name e1 in + FStarC_Syntax_Syntax.as_arg uu___8 in + let uu___8 = args_of_binders gamma in uu___7 :: + uu___8 in + FStarC_Syntax_Util.mk_app uu___5 uu___6 in + FStarC_Syntax_Util.abs uu___3 uu___4 ret in + let uu___3 = + let uu___4 = mk_all_implicit binders in + let uu___5 = + binders_of_list + [(a1, true); (t1, true); (t2, true); (f, false)] in + FStarC_Compiler_List.op_At uu___4 uu___5 in + FStarC_Syntax_Util.abs uu___3 body ret in + let c_push1 = + let uu___3 = mk_lid "push" in register env2 uu___3 c_push in + let ret_tot_wp_a = + FStar_Pervasives_Native.Some + (FStarC_Syntax_Util.residual_tot wp_a1) in + let mk_generic_app c = + if (FStarC_Compiler_List.length binders) > Prims.int_zero + then + let uu___3 = + let uu___4 = + let uu___5 = args_of_binders binders in + { + FStarC_Syntax_Syntax.hd = c; + FStarC_Syntax_Syntax.args = uu___5 + } in + FStarC_Syntax_Syntax.Tm_app uu___4 in + mk uu___3 + else c in + let wp_if_then_else = + let result_comp = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.null_binder wp_a1 in + let uu___6 = + let uu___7 = + FStarC_Syntax_Syntax.null_binder wp_a1 in + [uu___7] in + uu___5 :: uu___6 in + let uu___5 = FStarC_Syntax_Syntax.mk_Total wp_a1 in + FStarC_Syntax_Util.arrow uu___4 uu___5 in + FStarC_Syntax_Syntax.mk_Total uu___3 in + let c = + FStarC_Syntax_Syntax.gen_bv "c" + FStar_Pervasives_Native.None FStarC_Syntax_Util.ktype in + let uu___3 = + let uu___4 = + FStarC_Syntax_Syntax.binders_of_list [a1; c] in + FStarC_Compiler_List.op_At binders uu___4 in + let uu___4 = + let l_ite = + FStarC_Syntax_Syntax.fvar_with_dd + FStarC_Parser_Const.ite_lid + FStar_Pervasives_Native.None in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Syntax_Syntax.bv_to_name c in + FStarC_Syntax_Syntax.as_arg uu___11 in + [uu___10] in + FStarC_Syntax_Util.mk_app l_ite uu___9 in + [uu___8] in + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.as_arg uu___7 in + FStarC_Syntax_Util.mk_app c_lift21 uu___6 in + FStarC_Syntax_Util.ascribe uu___5 + ((FStar_Pervasives.Inr result_comp), + FStar_Pervasives_Native.None, false) in + let uu___5 = + let uu___6 = + FStarC_Syntax_Util.residual_comp_of_comp result_comp in + FStar_Pervasives_Native.Some uu___6 in + FStarC_Syntax_Util.abs uu___3 uu___4 uu___5 in + let wp_if_then_else1 = + let uu___3 = mk_lid "wp_if_then_else" in + register env2 uu___3 wp_if_then_else in + let wp_if_then_else2 = mk_generic_app wp_if_then_else1 in + let wp_close = + let b = + FStarC_Syntax_Syntax.gen_bv "b" + FStar_Pervasives_Native.None FStarC_Syntax_Util.ktype in + let t_f = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.bv_to_name b in + FStarC_Syntax_Syntax.null_binder uu___5 in + [uu___4] in + let uu___4 = FStarC_Syntax_Syntax.mk_Total wp_a1 in + FStarC_Syntax_Util.arrow uu___3 uu___4 in + let f = + FStarC_Syntax_Syntax.gen_bv "f" + FStar_Pervasives_Native.None t_f in + let body = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.as_arg + [FStarC_Syntax_Util.tforall] in + FStarC_Syntax_Util.mk_app c_pure1 uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Syntax_Syntax.bv_to_name f in + [uu___10] in + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.as_arg uu___9 in + FStarC_Syntax_Util.mk_app c_push1 uu___8 in + [uu___7] in + uu___5 :: uu___6 in + FStarC_Compiler_List.map FStarC_Syntax_Syntax.as_arg + uu___4 in + FStarC_Syntax_Util.mk_app c_app1 uu___3 in + let uu___3 = + let uu___4 = + FStarC_Syntax_Syntax.binders_of_list [a1; b; f] in + FStarC_Compiler_List.op_At binders uu___4 in + FStarC_Syntax_Util.abs uu___3 body ret_tot_wp_a in + let wp_close1 = + let uu___3 = mk_lid "wp_close" in + register env2 uu___3 wp_close in + let wp_close2 = mk_generic_app wp_close1 in + let ret_tot_type = + FStar_Pervasives_Native.Some + (FStarC_Syntax_Util.residual_tot + FStarC_Syntax_Util.ktype) in + let ret_gtot_type = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Syntax_Syntax.mk_GTotal + FStarC_Syntax_Util.ktype in + FStarC_TypeChecker_Common.lcomp_of_comp uu___5 in + FStarC_TypeChecker_Common.residual_comp_of_lcomp uu___4 in + FStar_Pervasives_Native.Some uu___3 in + let mk_forall x body = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = FStarC_Syntax_Syntax.mk_binder x in + [uu___9] in + FStarC_Syntax_Util.abs uu___8 body ret_tot_type in + FStarC_Syntax_Syntax.as_arg uu___7 in + [uu___6] in + { + FStarC_Syntax_Syntax.hd = + FStarC_Syntax_Util.tforall; + FStarC_Syntax_Syntax.args = uu___5 + } in + FStarC_Syntax_Syntax.Tm_app uu___4 in + FStarC_Syntax_Syntax.mk uu___3 + FStarC_Compiler_Range_Type.dummyRange in + let rec is_discrete t = + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.compress t in + uu___4.FStarC_Syntax_Syntax.n in + match uu___3 with + | FStarC_Syntax_Syntax.Tm_type uu___4 -> false + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = c;_} + -> + (FStarC_Compiler_List.for_all + (fun uu___4 -> + match uu___4 with + | { FStarC_Syntax_Syntax.binder_bv = b; + FStarC_Syntax_Syntax.binder_qual = uu___5; + FStarC_Syntax_Syntax.binder_positivity = + uu___6; + FStarC_Syntax_Syntax.binder_attrs = uu___7;_} + -> is_discrete b.FStarC_Syntax_Syntax.sort) + bs) + && (is_discrete (FStarC_Syntax_Util.comp_result c)) + | uu___4 -> true in + let rec is_monotonic t = + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.compress t in + uu___4.FStarC_Syntax_Syntax.n in + match uu___3 with + | FStarC_Syntax_Syntax.Tm_type uu___4 -> true + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = c;_} + -> + (FStarC_Compiler_List.for_all + (fun uu___4 -> + match uu___4 with + | { FStarC_Syntax_Syntax.binder_bv = b; + FStarC_Syntax_Syntax.binder_qual = uu___5; + FStarC_Syntax_Syntax.binder_positivity = + uu___6; + FStarC_Syntax_Syntax.binder_attrs = uu___7;_} + -> is_discrete b.FStarC_Syntax_Syntax.sort) + bs) + && + (is_monotonic (FStarC_Syntax_Util.comp_result c)) + | uu___4 -> is_discrete t in + let rec mk_rel rel t x y = + let mk_rel1 = mk_rel rel in + let t1 = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.DontUnfoldAttr + [FStarC_Parser_Const.tac_opaque_attr]; + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant] env2 t in + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.compress t1 in + uu___4.FStarC_Syntax_Syntax.n in + match uu___3 with + | FStarC_Syntax_Syntax.Tm_type uu___4 -> rel x y + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = binder::[]; + FStarC_Syntax_Syntax.comp = + { + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.GTotal b; + FStarC_Syntax_Syntax.pos = uu___4; + FStarC_Syntax_Syntax.vars = uu___5; + FStarC_Syntax_Syntax.hash_code = uu___6;_};_} + -> + let a2 = + (binder.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + let uu___7 = (is_monotonic a2) || (is_monotonic b) in + if uu___7 + then + let a11 = + FStarC_Syntax_Syntax.gen_bv "a1" + FStar_Pervasives_Native.None a2 in + let body = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Syntax_Syntax.bv_to_name a11 in + FStarC_Syntax_Syntax.as_arg uu___11 in + [uu___10] in + FStarC_Syntax_Util.mk_app x uu___9 in + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Syntax_Syntax.bv_to_name a11 in + FStarC_Syntax_Syntax.as_arg uu___12 in + [uu___11] in + FStarC_Syntax_Util.mk_app y uu___10 in + mk_rel1 b uu___8 uu___9 in + mk_forall a11 body + else + (let a11 = + FStarC_Syntax_Syntax.gen_bv "a1" + FStar_Pervasives_Native.None a2 in + let a21 = + FStarC_Syntax_Syntax.gen_bv "a2" + FStar_Pervasives_Native.None a2 in + let body = + let uu___9 = + let uu___10 = + FStarC_Syntax_Syntax.bv_to_name a11 in + let uu___11 = + FStarC_Syntax_Syntax.bv_to_name a21 in + mk_rel1 a2 uu___10 uu___11 in + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_Syntax_Syntax.bv_to_name a11 in + FStarC_Syntax_Syntax.as_arg uu___14 in + [uu___13] in + FStarC_Syntax_Util.mk_app x uu___12 in + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + FStarC_Syntax_Syntax.bv_to_name a21 in + FStarC_Syntax_Syntax.as_arg uu___15 in + [uu___14] in + FStarC_Syntax_Util.mk_app y uu___13 in + mk_rel1 b uu___11 uu___12 in + FStarC_Syntax_Util.mk_imp uu___9 uu___10 in + let uu___9 = mk_forall a21 body in + mk_forall a11 uu___9) + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = binder::[]; + FStarC_Syntax_Syntax.comp = + { + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Total b; + FStarC_Syntax_Syntax.pos = uu___4; + FStarC_Syntax_Syntax.vars = uu___5; + FStarC_Syntax_Syntax.hash_code = uu___6;_};_} + -> + let a2 = + (binder.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + let uu___7 = (is_monotonic a2) || (is_monotonic b) in + if uu___7 + then + let a11 = + FStarC_Syntax_Syntax.gen_bv "a1" + FStar_Pervasives_Native.None a2 in + let body = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Syntax_Syntax.bv_to_name a11 in + FStarC_Syntax_Syntax.as_arg uu___11 in + [uu___10] in + FStarC_Syntax_Util.mk_app x uu___9 in + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Syntax_Syntax.bv_to_name a11 in + FStarC_Syntax_Syntax.as_arg uu___12 in + [uu___11] in + FStarC_Syntax_Util.mk_app y uu___10 in + mk_rel1 b uu___8 uu___9 in + mk_forall a11 body + else + (let a11 = + FStarC_Syntax_Syntax.gen_bv "a1" + FStar_Pervasives_Native.None a2 in + let a21 = + FStarC_Syntax_Syntax.gen_bv "a2" + FStar_Pervasives_Native.None a2 in + let body = + let uu___9 = + let uu___10 = + FStarC_Syntax_Syntax.bv_to_name a11 in + let uu___11 = + FStarC_Syntax_Syntax.bv_to_name a21 in + mk_rel1 a2 uu___10 uu___11 in + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_Syntax_Syntax.bv_to_name a11 in + FStarC_Syntax_Syntax.as_arg uu___14 in + [uu___13] in + FStarC_Syntax_Util.mk_app x uu___12 in + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + FStarC_Syntax_Syntax.bv_to_name a21 in + FStarC_Syntax_Syntax.as_arg uu___15 in + [uu___14] in + FStarC_Syntax_Util.mk_app y uu___13 in + mk_rel1 b uu___11 uu___12 in + FStarC_Syntax_Util.mk_imp uu___9 uu___10 in + let uu___9 = mk_forall a21 body in + mk_forall a11 uu___9) + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = binder::binders1; + FStarC_Syntax_Syntax.comp = comp;_} + -> + let t2 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Syntax_Util.arrow binders1 comp in + FStarC_Syntax_Syntax.mk_Total uu___7 in + { + FStarC_Syntax_Syntax.bs1 = [binder]; + FStarC_Syntax_Syntax.comp = uu___6 + } in + FStarC_Syntax_Syntax.Tm_arrow uu___5 in + { + FStarC_Syntax_Syntax.n = uu___4; + FStarC_Syntax_Syntax.pos = + (t1.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = + (t1.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (t1.FStarC_Syntax_Syntax.hash_code) + } in + mk_rel1 t2 x y + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = []; + FStarC_Syntax_Syntax.comp = uu___4;_} + -> failwith "impossible: arrow with empty binders" + | uu___4 -> FStarC_Syntax_Util.mk_untyped_eq2 x y in + let stronger = + let wp1 = + FStarC_Syntax_Syntax.gen_bv "wp1" + FStar_Pervasives_Native.None wp_a1 in + let wp2 = + FStarC_Syntax_Syntax.gen_bv "wp2" + FStar_Pervasives_Native.None wp_a1 in + let rec mk_stronger t x y = + let t1 = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.DontUnfoldAttr + [FStarC_Parser_Const.tac_opaque_attr]; + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant] env2 t in + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.compress t1 in + uu___4.FStarC_Syntax_Syntax.n in + match uu___3 with + | FStarC_Syntax_Syntax.Tm_type uu___4 -> + FStarC_Syntax_Util.mk_imp x y + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = args;_} + when + let uu___4 = FStarC_Syntax_Subst.compress head in + FStarC_Syntax_Util.is_tuple_constructor uu___4 -> + let project i tuple = + let projector = + let uu___4 = + let uu___5 = + FStarC_Parser_Const.mk_tuple_data_lid + (FStarC_Compiler_List.length args) + FStarC_Compiler_Range_Type.dummyRange in + FStarC_TypeChecker_Env.lookup_projector env2 + uu___5 i in + FStarC_Syntax_Syntax.fvar_with_dd uu___4 + FStar_Pervasives_Native.None in + FStarC_Syntax_Util.mk_app projector + [(tuple, FStar_Pervasives_Native.None)] in + let uu___4 = + let uu___5 = + FStarC_Compiler_List.mapi + (fun i -> + fun uu___6 -> + match uu___6 with + | (t2, q) -> + let uu___7 = project i x in + let uu___8 = project i y in + mk_stronger t2 uu___7 uu___8) args in + match uu___5 with + | [] -> + failwith + "Impossible: empty application when creating stronger relation in DM4F" + | rel0::rels -> (rel0, rels) in + (match uu___4 with + | (rel0, rels) -> + FStarC_Compiler_List.fold_left + FStarC_Syntax_Util.mk_conj rel0 rels) + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = binders1; + FStarC_Syntax_Syntax.comp = + { + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.GTotal b; + FStarC_Syntax_Syntax.pos = uu___4; + FStarC_Syntax_Syntax.vars = uu___5; + FStarC_Syntax_Syntax.hash_code = uu___6;_};_} + -> + let bvs = + FStarC_Compiler_List.mapi + (fun i -> + fun uu___7 -> + match uu___7 with + | { FStarC_Syntax_Syntax.binder_bv = bv; + FStarC_Syntax_Syntax.binder_qual = q; + FStarC_Syntax_Syntax.binder_positivity + = uu___8; + FStarC_Syntax_Syntax.binder_attrs = + uu___9;_} + -> + let uu___10 = + let uu___11 = + FStarC_Compiler_Util.string_of_int + i in + Prims.strcat "a" uu___11 in + FStarC_Syntax_Syntax.gen_bv uu___10 + FStar_Pervasives_Native.None + bv.FStarC_Syntax_Syntax.sort) + binders1 in + let args = + FStarC_Compiler_List.map + (fun ai -> + let uu___7 = + FStarC_Syntax_Syntax.bv_to_name ai in + FStarC_Syntax_Syntax.as_arg uu___7) bvs in + let body = + let uu___7 = FStarC_Syntax_Util.mk_app x args in + let uu___8 = FStarC_Syntax_Util.mk_app y args in + mk_stronger b uu___7 uu___8 in + FStarC_Compiler_List.fold_right + (fun bv -> fun body1 -> mk_forall bv body1) bvs + body + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = binders1; + FStarC_Syntax_Syntax.comp = + { + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Total b; + FStarC_Syntax_Syntax.pos = uu___4; + FStarC_Syntax_Syntax.vars = uu___5; + FStarC_Syntax_Syntax.hash_code = uu___6;_};_} + -> + let bvs = + FStarC_Compiler_List.mapi + (fun i -> + fun uu___7 -> + match uu___7 with + | { FStarC_Syntax_Syntax.binder_bv = bv; + FStarC_Syntax_Syntax.binder_qual = q; + FStarC_Syntax_Syntax.binder_positivity + = uu___8; + FStarC_Syntax_Syntax.binder_attrs = + uu___9;_} + -> + let uu___10 = + let uu___11 = + FStarC_Compiler_Util.string_of_int + i in + Prims.strcat "a" uu___11 in + FStarC_Syntax_Syntax.gen_bv uu___10 + FStar_Pervasives_Native.None + bv.FStarC_Syntax_Syntax.sort) + binders1 in + let args = + FStarC_Compiler_List.map + (fun ai -> + let uu___7 = + FStarC_Syntax_Syntax.bv_to_name ai in + FStarC_Syntax_Syntax.as_arg uu___7) bvs in + let body = + let uu___7 = FStarC_Syntax_Util.mk_app x args in + let uu___8 = FStarC_Syntax_Util.mk_app y args in + mk_stronger b uu___7 uu___8 in + FStarC_Compiler_List.fold_right + (fun bv -> fun body1 -> mk_forall bv body1) bvs + body + | uu___4 -> failwith "Not a DM elaborated type" in + let body = + let uu___3 = FStarC_Syntax_Util.unascribe wp_a1 in + let uu___4 = FStarC_Syntax_Syntax.bv_to_name wp1 in + let uu___5 = FStarC_Syntax_Syntax.bv_to_name wp2 in + mk_stronger uu___3 uu___4 uu___5 in + let uu___3 = + let uu___4 = + binders_of_list + [(a1, false); (wp1, false); (wp2, false)] in + FStarC_Compiler_List.op_At binders uu___4 in + FStarC_Syntax_Util.abs uu___3 body ret_tot_type in + let stronger1 = + let uu___3 = mk_lid "stronger" in + register env2 uu___3 stronger in + let stronger2 = mk_generic_app stronger1 in + let ite_wp = + let wp = + FStarC_Syntax_Syntax.gen_bv "wp" + FStar_Pervasives_Native.None wp_a1 in + let uu___3 = FStarC_Compiler_Util.prefix gamma in + match uu___3 with + | (wp_args, post) -> + let k = + FStarC_Syntax_Syntax.gen_bv "k" + FStar_Pervasives_Native.None + (post.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + let equiv = + let k_tm = FStarC_Syntax_Syntax.bv_to_name k in + let eq = + let uu___4 = + FStarC_Syntax_Syntax.bv_to_name + post.FStarC_Syntax_Syntax.binder_bv in + mk_rel FStarC_Syntax_Util.mk_iff + k.FStarC_Syntax_Syntax.sort k_tm uu___4 in + let uu___4 = + FStarC_Syntax_Formula.destruct_typ_as_formula eq in + match uu___4 with + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Formula.QAll + (binders1, [], body)) -> + let k_app = + let uu___5 = args_of_binders binders1 in + FStarC_Syntax_Util.mk_app k_tm uu___5 in + let guard_free = + let uu___5 = + FStarC_Syntax_Syntax.lid_and_dd_as_fv + FStarC_Parser_Const.guard_free + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___5 in + let pat = + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.as_arg k_app in + [uu___6] in + FStarC_Syntax_Util.mk_app guard_free uu___5 in + let pattern_guarded_body = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Syntax_Syntax.binders_to_names + binders1 in + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Syntax_Syntax.as_arg pat in + [uu___12] in + [uu___11] in + (uu___9, uu___10) in + FStarC_Syntax_Syntax.Meta_pattern + uu___8 in + { + FStarC_Syntax_Syntax.tm2 = body; + FStarC_Syntax_Syntax.meta = uu___7 + } in + FStarC_Syntax_Syntax.Tm_meta uu___6 in + mk uu___5 in + FStarC_Syntax_Util.close_forall_no_univs + binders1 pattern_guarded_body + | uu___5 -> + failwith + "Impossible: Expected the equivalence to be a quantified formula" in + let body = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Syntax_Syntax.bv_to_name wp in + let uu___8 = + let uu___9 = args_of_binders wp_args in + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Syntax_Syntax.bv_to_name k in + FStarC_Syntax_Syntax.as_arg uu___12 in + [uu___11] in + FStarC_Compiler_List.op_At uu___9 uu___10 in + FStarC_Syntax_Util.mk_app uu___7 uu___8 in + FStarC_Syntax_Util.mk_imp equiv uu___6 in + FStarC_Syntax_Util.mk_forall_no_univ k uu___5 in + FStarC_Syntax_Util.abs gamma uu___4 ret_gtot_type in + let uu___4 = + let uu___5 = + FStarC_Syntax_Syntax.binders_of_list [a1; wp] in + FStarC_Compiler_List.op_At binders uu___5 in + FStarC_Syntax_Util.abs uu___4 body ret_gtot_type in + let ite_wp1 = + let uu___3 = mk_lid "ite_wp" in + register env2 uu___3 ite_wp in + let ite_wp2 = mk_generic_app ite_wp1 in + let null_wp = + let wp = + FStarC_Syntax_Syntax.gen_bv "wp" + FStar_Pervasives_Native.None wp_a1 in + let uu___3 = FStarC_Compiler_Util.prefix gamma in + match uu___3 with + | (wp_args, post) -> + let x = + FStarC_Syntax_Syntax.gen_bv "x" + FStar_Pervasives_Native.None + FStarC_Syntax_Syntax.tun in + let body = + let uu___4 = + let uu___5 = + FStarC_Syntax_Syntax.bv_to_name + post.FStarC_Syntax_Syntax.binder_bv in + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Syntax.bv_to_name x in + FStarC_Syntax_Syntax.as_arg uu___8 in + [uu___7] in + FStarC_Syntax_Util.mk_app uu___5 uu___6 in + FStarC_Syntax_Util.mk_forall_no_univ x uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.binders_of_list [a1] in + FStarC_Compiler_List.op_At uu___6 gamma in + FStarC_Compiler_List.op_At binders uu___5 in + FStarC_Syntax_Util.abs uu___4 body ret_gtot_type in + let null_wp1 = + let uu___3 = mk_lid "null_wp" in + register env2 uu___3 null_wp in + let null_wp2 = mk_generic_app null_wp1 in + let wp_trivial = + let wp = + FStarC_Syntax_Syntax.gen_bv "wp" + FStar_Pervasives_Native.None wp_a1 in + let body = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.bv_to_name a1 in + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Syntax_Syntax.bv_to_name a1 in + FStarC_Syntax_Syntax.as_arg uu___10 in + [uu___9] in + FStarC_Syntax_Util.mk_app null_wp2 uu___8 in + let uu___8 = + let uu___9 = FStarC_Syntax_Syntax.bv_to_name wp in + [uu___9] in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + FStarC_Compiler_List.map FStarC_Syntax_Syntax.as_arg + uu___4 in + FStarC_Syntax_Util.mk_app stronger2 uu___3 in + let uu___3 = + let uu___4 = + FStarC_Syntax_Syntax.binders_of_list [a1; wp] in + FStarC_Compiler_List.op_At binders uu___4 in + FStarC_Syntax_Util.abs uu___3 body ret_tot_type in + let wp_trivial1 = + let uu___3 = mk_lid "wp_trivial" in + register env2 uu___3 wp_trivial in + let wp_trivial2 = mk_generic_app wp_trivial1 in + ((let uu___4 = FStarC_Compiler_Effect.op_Bang dbg in + if uu___4 then d1 "End Dijkstra monads for free" else ()); + (let c = FStarC_Syntax_Subst.close binders in + let ed_combs = + match ed.FStarC_Syntax_Syntax.combinators with + | FStarC_Syntax_Syntax.DM4F_eff combs -> + let uu___4 = + let uu___5 = + let uu___6 = c stronger2 in ([], uu___6) in + let uu___6 = + let uu___7 = c wp_if_then_else2 in ([], uu___7) in + let uu___7 = + let uu___8 = c ite_wp2 in ([], uu___8) in + let uu___8 = + let uu___9 = c wp_close2 in ([], uu___9) in + let uu___9 = + let uu___10 = c wp_trivial2 in ([], uu___10) in + { + FStarC_Syntax_Syntax.ret_wp = + (combs.FStarC_Syntax_Syntax.ret_wp); + FStarC_Syntax_Syntax.bind_wp = + (combs.FStarC_Syntax_Syntax.bind_wp); + FStarC_Syntax_Syntax.stronger = uu___5; + FStarC_Syntax_Syntax.if_then_else = uu___6; + FStarC_Syntax_Syntax.ite_wp = uu___7; + FStarC_Syntax_Syntax.close_wp = uu___8; + FStarC_Syntax_Syntax.trivial = uu___9; + FStarC_Syntax_Syntax.repr = + (combs.FStarC_Syntax_Syntax.repr); + FStarC_Syntax_Syntax.return_repr = + (combs.FStarC_Syntax_Syntax.return_repr); + FStarC_Syntax_Syntax.bind_repr = + (combs.FStarC_Syntax_Syntax.bind_repr) + } in + FStarC_Syntax_Syntax.DM4F_eff uu___4 + | uu___4 -> + failwith + "Impossible! For a DM4F effect combinators must be in DM4f_eff" in + let uu___4 = + let uu___5 = FStarC_Compiler_Effect.op_Bang sigelts in + FStarC_Compiler_List.rev uu___5 in + (uu___4, + { + FStarC_Syntax_Syntax.mname = + (ed.FStarC_Syntax_Syntax.mname); + FStarC_Syntax_Syntax.cattributes = + (ed.FStarC_Syntax_Syntax.cattributes); + FStarC_Syntax_Syntax.univs = + (ed.FStarC_Syntax_Syntax.univs); + FStarC_Syntax_Syntax.binders = + (ed.FStarC_Syntax_Syntax.binders); + FStarC_Syntax_Syntax.signature = + (ed.FStarC_Syntax_Syntax.signature); + FStarC_Syntax_Syntax.combinators = ed_combs; + FStarC_Syntax_Syntax.actions = + (ed.FStarC_Syntax_Syntax.actions); + FStarC_Syntax_Syntax.eff_attrs = + (ed.FStarC_Syntax_Syntax.eff_attrs); + FStarC_Syntax_Syntax.extraction_mode = + (ed.FStarC_Syntax_Syntax.extraction_mode) + }))))) +type env_ = env +let (get_env : env -> FStarC_TypeChecker_Env.env) = fun env1 -> env1.tcenv +let (set_env : env -> FStarC_TypeChecker_Env.env -> env) = + fun dmff_env -> + fun env' -> + { + tcenv = env'; + subst = (dmff_env.subst); + tc_const = (dmff_env.tc_const) + } +type nm = + | N of FStarC_Syntax_Syntax.typ + | M of FStarC_Syntax_Syntax.typ +let (uu___is_N : nm -> Prims.bool) = + fun projectee -> match projectee with | N _0 -> true | uu___ -> false +let (__proj__N__item___0 : nm -> FStarC_Syntax_Syntax.typ) = + fun projectee -> match projectee with | N _0 -> _0 +let (uu___is_M : nm -> Prims.bool) = + fun projectee -> match projectee with | M _0 -> true | uu___ -> false +let (__proj__M__item___0 : nm -> FStarC_Syntax_Syntax.typ) = + fun projectee -> match projectee with | M _0 -> _0 +type nm_ = nm +let (nm_of_comp : + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> nm) = + fun c -> + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total t -> N t + | FStarC_Syntax_Syntax.Comp c1 when + FStarC_Compiler_Util.for_some + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.CPS -> true + | uu___1 -> false) c1.FStarC_Syntax_Syntax.flags + -> M (c1.FStarC_Syntax_Syntax.result_typ) + | uu___ -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_comp c in + FStarC_Compiler_Util.format1 + "[nm_of_comp]: unexpected computation type %s" uu___2 in + FStarC_Errors.raise_error (FStarC_Syntax_Syntax.has_range_syntax ()) + c FStarC_Errors_Codes.Error_UnexpectedDM4FType () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) +let (string_of_nm : nm -> Prims.string) = + fun uu___ -> + match uu___ with + | N t -> + let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.format1 "N[%s]" uu___1 + | M t -> + let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.format1 "M[%s]" uu___1 +let (is_monadic_arrow : FStarC_Syntax_Syntax.term' -> nm) = + fun n -> + match n with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = uu___; FStarC_Syntax_Syntax.comp = c;_} + -> nm_of_comp c + | uu___ -> failwith "unexpected_argument: [is_monadic_arrow]" +let (is_monadic_comp : + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> Prims.bool) = + fun c -> + let uu___ = nm_of_comp c in + match uu___ with | M uu___1 -> true | N uu___1 -> false +exception Not_found +let (uu___is_Not_found : Prims.exn -> Prims.bool) = + fun projectee -> match projectee with | Not_found -> true | uu___ -> false +let (double_star : FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.typ) = + fun typ -> + let star_once typ1 = + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Syntax_Syntax.new_bv FStar_Pervasives_Native.None typ1 in + FStarC_Syntax_Syntax.mk_binder uu___2 in + [uu___1] in + let uu___1 = FStarC_Syntax_Syntax.mk_Total FStarC_Syntax_Util.ktype0 in + FStarC_Syntax_Util.arrow uu___ uu___1 in + let uu___ = star_once typ in star_once uu___ +let rec (mk_star_to_type : + (FStarC_Syntax_Syntax.term' -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + -> + env -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun mk -> + fun env1 -> + fun a -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = star_type' env1 a in + FStarC_Syntax_Syntax.null_bv uu___5 in + let uu___5 = FStarC_Syntax_Syntax.as_bqual_implicit false in + FStarC_Syntax_Syntax.mk_binder_with_attrs uu___4 uu___5 + FStar_Pervasives_Native.None [] in + [uu___3] in + let uu___3 = + FStarC_Syntax_Syntax.mk_Total FStarC_Syntax_Util.ktype0 in + { + FStarC_Syntax_Syntax.bs1 = uu___2; + FStarC_Syntax_Syntax.comp = uu___3 + } in + FStarC_Syntax_Syntax.Tm_arrow uu___1 in + mk uu___ +and (star_type' : + env -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term) + = + fun env1 -> + fun t -> + let mk x = FStarC_Syntax_Syntax.mk x t.FStarC_Syntax_Syntax.pos in + let mk_star_to_type1 = mk_star_to_type mk in + let t1 = FStarC_Syntax_Subst.compress t in + match t1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = binders; + FStarC_Syntax_Syntax.comp = uu___;_} + -> + let binders1 = + FStarC_Compiler_List.map + (fun b -> + let uu___1 = + let uu___2 = b.FStarC_Syntax_Syntax.binder_bv in + let uu___3 = + star_type' env1 + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + { + FStarC_Syntax_Syntax.ppname = + (uu___2.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (uu___2.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = uu___3 + } in + { + FStarC_Syntax_Syntax.binder_bv = uu___1; + FStarC_Syntax_Syntax.binder_qual = + (b.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity = + (b.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs = + (b.FStarC_Syntax_Syntax.binder_attrs) + }) binders in + (match t1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = uu___1; + FStarC_Syntax_Syntax.comp = + { FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.GTotal hn; + FStarC_Syntax_Syntax.pos = uu___2; + FStarC_Syntax_Syntax.vars = uu___3; + FStarC_Syntax_Syntax.hash_code = uu___4;_};_} + -> + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = star_type' env1 hn in + FStarC_Syntax_Syntax.mk_GTotal uu___8 in + { + FStarC_Syntax_Syntax.bs1 = binders1; + FStarC_Syntax_Syntax.comp = uu___7 + } in + FStarC_Syntax_Syntax.Tm_arrow uu___6 in + mk uu___5 + | uu___1 -> + let uu___2 = is_monadic_arrow t1.FStarC_Syntax_Syntax.n in + (match uu___2 with + | N hn -> + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = star_type' env1 hn in + FStarC_Syntax_Syntax.mk_Total uu___6 in + { + FStarC_Syntax_Syntax.bs1 = binders1; + FStarC_Syntax_Syntax.comp = uu___5 + } in + FStarC_Syntax_Syntax.Tm_arrow uu___4 in + mk uu___3 + | M a -> + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = mk_star_to_type1 env1 a in + FStarC_Syntax_Syntax.null_bv uu___9 in + let uu___9 = + FStarC_Syntax_Syntax.as_bqual_implicit false in + FStarC_Syntax_Syntax.mk_binder_with_attrs + uu___8 uu___9 FStar_Pervasives_Native.None [] in + [uu___7] in + FStarC_Compiler_List.op_At binders1 uu___6 in + let uu___6 = + FStarC_Syntax_Syntax.mk_Total + FStarC_Syntax_Util.ktype0 in + { + FStarC_Syntax_Syntax.bs1 = uu___5; + FStarC_Syntax_Syntax.comp = uu___6 + } in + FStarC_Syntax_Syntax.Tm_arrow uu___4 in + mk uu___3)) + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = args;_} + -> + let debug t2 s = + let uu___ = + let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t2 in + let uu___2 = + FStarC_Class_Show.show + (FStarC_Compiler_FlatSet.showable_set + FStarC_Syntax_Syntax.ord_bv + FStarC_Syntax_Print.showable_bv) s in + FStarC_Compiler_Util.format2 "Dependency found in term %s : %s" + uu___1 uu___2 in + FStarC_Errors.log_issue + (FStarC_Syntax_Syntax.has_range_syntax ()) t2 + FStarC_Errors_Codes.Warning_DependencyFound () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___) in + let rec is_non_dependent_arrow ty n = + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress ty in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = binders; + FStarC_Syntax_Syntax.comp = c;_} + -> + let uu___1 = + let uu___2 = FStarC_Syntax_Util.is_tot_or_gtot_comp c in + Prims.op_Negation uu___2 in + if uu___1 + then false + else + (try + (fun uu___3 -> + match () with + | () -> + let non_dependent_or_raise s ty1 = + let sinter = + let uu___4 = FStarC_Syntax_Free.names ty1 in + Obj.magic + (FStarC_Class_Setlike.inter () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) + (Obj.magic uu___4) (Obj.magic s)) in + let uu___4 = + let uu___5 = + FStarC_Class_Setlike.is_empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) + (Obj.magic sinter) in + Prims.op_Negation uu___5 in + if uu___4 + then + (debug ty1 sinter; + FStarC_Compiler_Effect.raise Not_found) + else () in + let uu___4 = + FStarC_Syntax_Subst.open_comp binders c in + (match uu___4 with + | (binders1, c1) -> + let s = + let uu___5 = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) + ()) in + FStarC_Compiler_List.fold_left + (fun uu___7 -> + fun uu___6 -> + (fun s1 -> + fun uu___6 -> + match uu___6 with + | { + FStarC_Syntax_Syntax.binder_bv + = bv; + FStarC_Syntax_Syntax.binder_qual + = uu___7; + FStarC_Syntax_Syntax.binder_positivity + = uu___8; + FStarC_Syntax_Syntax.binder_attrs + = uu___9;_} + -> + (non_dependent_or_raise s1 + bv.FStarC_Syntax_Syntax.sort; + Obj.magic + (FStarC_Class_Setlike.add + () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) + bv (Obj.magic s1)))) + uu___7 uu___6) uu___5 binders1 in + let ct = FStarC_Syntax_Util.comp_result c1 in + (non_dependent_or_raise s ct; + (let k = + n - + (FStarC_Compiler_List.length binders1) in + if k > Prims.int_zero + then is_non_dependent_arrow ct k + else true)))) () + with | Not_found -> false) + | uu___1 -> + ((let uu___3 = + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term ty in + FStarC_Compiler_Util.format1 "Not a dependent arrow : %s" + uu___4 in + FStarC_Errors.log_issue + (FStarC_Syntax_Syntax.has_range_syntax ()) ty + FStarC_Errors_Codes.Warning_NotDependentArrow () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___3)); + false) in + let rec is_valid_application head1 = + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress head1 in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_fvar fv when + (((FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.option_lid) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.either_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.eq2_lid)) + || + (let uu___1 = FStarC_Syntax_Subst.compress head1 in + FStarC_Syntax_Util.is_tuple_constructor uu___1) + -> true + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let uu___1 = + FStarC_TypeChecker_Env.lookup_lid env1.tcenv + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + (match uu___1 with + | ((uu___2, ty), uu___3) -> + let uu___4 = + is_non_dependent_arrow ty + (FStarC_Compiler_List.length args) in + if uu___4 + then + let res = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.EraseUniverses; + FStarC_TypeChecker_Env.Inlining; + FStarC_TypeChecker_Env.DontUnfoldAttr + [FStarC_Parser_Const.tac_opaque_attr]; + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant] env1.tcenv + t1 in + let uu___5 = + let uu___6 = FStarC_Syntax_Subst.compress res in + uu___6.FStarC_Syntax_Syntax.n in + (match uu___5 with + | FStarC_Syntax_Syntax.Tm_app uu___6 -> true + | uu___6 -> + ((let uu___8 = + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head1 in + FStarC_Compiler_Util.format1 + "Got a term which might be a non-dependent user-defined data-type %s\n" + uu___9 in + FStarC_Errors.log_issue + (FStarC_Syntax_Syntax.has_range_syntax ()) + head1 + FStarC_Errors_Codes.Warning_NondependentUserDefinedDataType + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___8)); + false)) + else false) + | FStarC_Syntax_Syntax.Tm_bvar uu___1 -> true + | FStarC_Syntax_Syntax.Tm_name uu___1 -> true + | FStarC_Syntax_Syntax.Tm_uinst (t2, uu___1) -> + is_valid_application t2 + | uu___1 -> false in + let uu___ = is_valid_application head in + if uu___ + then + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Compiler_List.map + (fun uu___4 -> + match uu___4 with + | (t2, qual) -> + let uu___5 = star_type' env1 t2 in (uu___5, qual)) + args in + { + FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = uu___3 + } in + FStarC_Syntax_Syntax.Tm_app uu___2 in + mk uu___1 + else + (let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.format1 + "For now, only [either], [option] and [eq2] are supported in the definition language (got: %s)" + uu___3 in + FStarC_Errors.raise_error0 FStarC_Errors_Codes.Fatal_WrongTerm + () (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)) + | FStarC_Syntax_Syntax.Tm_bvar uu___ -> t1 + | FStarC_Syntax_Syntax.Tm_name uu___ -> t1 + | FStarC_Syntax_Syntax.Tm_type uu___ -> t1 + | FStarC_Syntax_Syntax.Tm_fvar uu___ -> t1 + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = binders; + FStarC_Syntax_Syntax.body = repr; + FStarC_Syntax_Syntax.rc_opt = something;_} + -> + let uu___ = FStarC_Syntax_Subst.open_term binders repr in + (match uu___ with + | (binders1, repr1) -> + let env2 = + let uu___1 = + FStarC_TypeChecker_Env.push_binders env1.tcenv binders1 in + { + tcenv = uu___1; + subst = (env1.subst); + tc_const = (env1.tc_const) + } in + let repr2 = star_type' env2 repr1 in + FStarC_Syntax_Util.abs binders1 repr2 something) + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x; FStarC_Syntax_Syntax.phi = t2;_} when + false -> + let x1 = FStarC_Syntax_Syntax.freshen_bv x in + let sort = star_type' env1 x1.FStarC_Syntax_Syntax.sort in + let subst = [FStarC_Syntax_Syntax.DB (Prims.int_zero, x1)] in + let t3 = FStarC_Syntax_Subst.subst subst t2 in + let t4 = star_type' env1 t3 in + let subst1 = [FStarC_Syntax_Syntax.NM (x1, Prims.int_zero)] in + let t5 = FStarC_Syntax_Subst.subst subst1 t4 in + mk + (FStarC_Syntax_Syntax.Tm_refine + { + FStarC_Syntax_Syntax.b = + { + FStarC_Syntax_Syntax.ppname = + (x1.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (x1.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = sort + }; + FStarC_Syntax_Syntax.phi = t5 + }) + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t2; FStarC_Syntax_Syntax.meta = m;_} + -> + let uu___ = + let uu___1 = + let uu___2 = star_type' env1 t2 in + { + FStarC_Syntax_Syntax.tm2 = uu___2; + FStarC_Syntax_Syntax.meta = m + } in + FStarC_Syntax_Syntax.Tm_meta uu___1 in + mk uu___ + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = e; + FStarC_Syntax_Syntax.asc = + (FStar_Pervasives.Inl t2, FStar_Pervasives_Native.None, use_eq); + FStarC_Syntax_Syntax.eff_opt = something;_} + -> + let uu___ = + let uu___1 = + let uu___2 = star_type' env1 e in + let uu___3 = + let uu___4 = + let uu___5 = star_type' env1 t2 in + FStar_Pervasives.Inl uu___5 in + (uu___4, FStar_Pervasives_Native.None, use_eq) in + { + FStarC_Syntax_Syntax.tm = uu___2; + FStarC_Syntax_Syntax.asc = uu___3; + FStarC_Syntax_Syntax.eff_opt = something + } in + FStarC_Syntax_Syntax.Tm_ascribed uu___1 in + mk uu___ + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = e; + FStarC_Syntax_Syntax.asc = + (FStar_Pervasives.Inr c, FStar_Pervasives_Native.None, use_eq); + FStarC_Syntax_Syntax.eff_opt = something;_} + -> + let uu___ = + let uu___1 = + let uu___2 = star_type' env1 e in + let uu___3 = + let uu___4 = + let uu___5 = + star_type' env1 (FStarC_Syntax_Util.comp_result c) in + FStar_Pervasives.Inl uu___5 in + (uu___4, FStar_Pervasives_Native.None, use_eq) in + { + FStarC_Syntax_Syntax.tm = uu___2; + FStarC_Syntax_Syntax.asc = uu___3; + FStarC_Syntax_Syntax.eff_opt = something + } in + FStarC_Syntax_Syntax.Tm_ascribed uu___1 in + mk uu___ + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = uu___; + FStarC_Syntax_Syntax.asc = + (uu___1, FStar_Pervasives_Native.Some uu___2, uu___3); + FStarC_Syntax_Syntax.eff_opt = uu___4;_} + -> + let uu___5 = + let uu___6 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.format1 + "Ascriptions with tactics are outside of the definition language: %s" + uu___6 in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_TermOutsideOfDefLanguage () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___5) + | FStarC_Syntax_Syntax.Tm_refine uu___ -> + let uu___1 = + let uu___2 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t1 in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.format2 + "%s is outside of the definition language: %s" uu___2 uu___3 in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_TermOutsideOfDefLanguage () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) + | FStarC_Syntax_Syntax.Tm_uinst uu___ -> + let uu___1 = + let uu___2 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t1 in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.format2 + "%s is outside of the definition language: %s" uu___2 uu___3 in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_TermOutsideOfDefLanguage () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) + | FStarC_Syntax_Syntax.Tm_quoted uu___ -> + let uu___1 = + let uu___2 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t1 in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.format2 + "%s is outside of the definition language: %s" uu___2 uu___3 in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_TermOutsideOfDefLanguage () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) + | FStarC_Syntax_Syntax.Tm_constant uu___ -> + let uu___1 = + let uu___2 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t1 in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.format2 + "%s is outside of the definition language: %s" uu___2 uu___3 in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_TermOutsideOfDefLanguage () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) + | FStarC_Syntax_Syntax.Tm_match uu___ -> + let uu___1 = + let uu___2 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t1 in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.format2 + "%s is outside of the definition language: %s" uu___2 uu___3 in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_TermOutsideOfDefLanguage () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) + | FStarC_Syntax_Syntax.Tm_let uu___ -> + let uu___1 = + let uu___2 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t1 in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.format2 + "%s is outside of the definition language: %s" uu___2 uu___3 in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_TermOutsideOfDefLanguage () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) + | FStarC_Syntax_Syntax.Tm_uvar uu___ -> + let uu___1 = + let uu___2 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t1 in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.format2 + "%s is outside of the definition language: %s" uu___2 uu___3 in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_TermOutsideOfDefLanguage () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) + | FStarC_Syntax_Syntax.Tm_unknown -> + let uu___ = + let uu___1 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t1 in + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.format2 + "%s is outside of the definition language: %s" uu___1 uu___2 in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_TermOutsideOfDefLanguage () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___) + | FStarC_Syntax_Syntax.Tm_lazy i -> + let uu___ = FStarC_Syntax_Util.unfold_lazy i in + star_type' env1 uu___ + | FStarC_Syntax_Syntax.Tm_delayed uu___ -> failwith "impossible" +let (is_monadic : + FStarC_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option -> + Prims.bool) + = + fun uu___ -> + match uu___ with + | FStar_Pervasives_Native.None -> failwith "un-annotated lambda?!" + | FStar_Pervasives_Native.Some rc -> + FStarC_Compiler_Util.for_some + (fun uu___1 -> + match uu___1 with + | FStarC_Syntax_Syntax.CPS -> true + | uu___2 -> false) rc.FStarC_Syntax_Syntax.residual_flags +let rec (is_C : FStarC_Syntax_Syntax.typ -> Prims.bool) = + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head; FStarC_Syntax_Syntax.args = args;_} + when FStarC_Syntax_Util.is_tuple_constructor head -> + let r = + let uu___1 = + let uu___2 = FStarC_Compiler_List.hd args in + FStar_Pervasives_Native.fst uu___2 in + is_C uu___1 in + if r + then + ((let uu___2 = + let uu___3 = + FStarC_Compiler_List.for_all + (fun uu___4 -> match uu___4 with | (h, uu___5) -> is_C h) + args in + Prims.op_Negation uu___3 in + if uu___2 + then + let uu___3 = + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.format1 "Not a C-type (A * C): %s" + uu___4 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) t + FStarC_Errors_Codes.Error_UnexpectedDM4FType () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___3) + else ()); + true) + else + ((let uu___3 = + let uu___4 = + FStarC_Compiler_List.for_all + (fun uu___5 -> + match uu___5 with + | (h, uu___6) -> + let uu___7 = is_C h in Prims.op_Negation uu___7) + args in + Prims.op_Negation uu___4 in + if uu___3 + then + let uu___4 = + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.format1 "Not a C-type (C * A): %s" + uu___5 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) t + FStarC_Errors_Codes.Error_UnexpectedDM4FType () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4) + else ()); + false) + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = binders; + FStarC_Syntax_Syntax.comp = comp;_} + -> + let uu___1 = nm_of_comp comp in + (match uu___1 with + | M t1 -> + ((let uu___3 = is_C t1 in + if uu___3 + then + let uu___4 = + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + t1 in + FStarC_Compiler_Util.format1 "Not a C-type (C -> C): %s" + uu___5 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) t1 + FStarC_Errors_Codes.Error_UnexpectedDM4FType () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4) + else ()); + true) + | N t1 -> is_C t1) + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t1; + FStarC_Syntax_Syntax.meta = uu___1;_} + -> is_C t1 + | FStarC_Syntax_Syntax.Tm_uinst (t1, uu___1) -> is_C t1 + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t1; FStarC_Syntax_Syntax.asc = uu___1; + FStarC_Syntax_Syntax.eff_opt = uu___2;_} + -> is_C t1 + | uu___1 -> false +let (mk_return : + env -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun env1 -> + fun t -> + fun e -> + let mk x = FStarC_Syntax_Syntax.mk x e.FStarC_Syntax_Syntax.pos in + let p_type = mk_star_to_type mk env1 t in + let p = + FStarC_Syntax_Syntax.gen_bv "p'" FStar_Pervasives_Native.None + p_type in + let body = + let uu___ = + let uu___1 = + let uu___2 = FStarC_Syntax_Syntax.bv_to_name p in + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.as_aqual_implicit false in + (e, uu___5) in + [uu___4] in + { + FStarC_Syntax_Syntax.hd = uu___2; + FStarC_Syntax_Syntax.args = uu___3 + } in + FStarC_Syntax_Syntax.Tm_app uu___1 in + mk uu___ in + let uu___ = let uu___1 = FStarC_Syntax_Syntax.mk_binder p in [uu___1] in + FStarC_Syntax_Util.abs uu___ body + (FStar_Pervasives_Native.Some + (FStarC_Syntax_Util.residual_tot FStarC_Syntax_Util.ktype0)) +let (is_unknown : FStarC_Syntax_Syntax.term' -> Prims.bool) = + fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.Tm_unknown -> true + | uu___1 -> false +let rec (check : + env -> + FStarC_Syntax_Syntax.term -> + nm -> (nm * FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.term)) + = + fun env1 -> + fun e -> + fun context_nm -> + let return_if uu___ = + match uu___ with + | (rec_nm, s_e, u_e) -> + let check1 t1 t2 = + let uu___1 = + (Prims.op_Negation (is_unknown t2.FStarC_Syntax_Syntax.n)) + && + (let uu___2 = + let uu___3 = + FStarC_TypeChecker_Rel.teq env1.tcenv t1 t2 in + FStarC_TypeChecker_Env.is_trivial uu___3 in + Prims.op_Negation uu___2) in + if uu___1 + then + let uu___2 = + let uu___3 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term e in + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t1 in + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t2 in + FStarC_Compiler_Util.format3 + "[check]: the expression [%s] has type [%s] but should have type [%s]" + uu___3 uu___4 uu___5 in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_TypeMismatch () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2) + else () in + (match (rec_nm, context_nm) with + | (N t1, N t2) -> (check1 t1 t2; (rec_nm, s_e, u_e)) + | (M t1, M t2) -> (check1 t1 t2; (rec_nm, s_e, u_e)) + | (N t1, M t2) -> + (check1 t1 t2; + (let uu___2 = mk_return env1 t1 s_e in + ((M t1), uu___2, u_e))) + | (M t1, N t2) -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term e in + let uu___3 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t1 in + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t2 in + FStarC_Compiler_Util.format3 + "[check %s]: got an effectful computation [%s] in lieu of a pure computation [%s]" + uu___2 uu___3 uu___4 in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_EffectfulAndPureComputationMismatch + () (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1)) in + let ensure_m env2 e2 = + let strip_m uu___ = + match uu___ with + | (M t, s_e, u_e) -> (t, s_e, u_e) + | uu___1 -> failwith "impossible" in + match context_nm with + | N t -> + let uu___ = + let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + Prims.strcat + "let-bound monadic body has a non-monadic continuation or a branch of a match is monadic and the others aren't : " + uu___1 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) e2 + FStarC_Errors_Codes.Fatal_LetBoundMonadicMismatch () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___) + | M uu___ -> + let uu___1 = check env2 e2 context_nm in strip_m uu___1 in + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress e in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_bvar uu___1 -> + let uu___2 = infer env1 e in return_if uu___2 + | FStarC_Syntax_Syntax.Tm_name uu___1 -> + let uu___2 = infer env1 e in return_if uu___2 + | FStarC_Syntax_Syntax.Tm_fvar uu___1 -> + let uu___2 = infer env1 e in return_if uu___2 + | FStarC_Syntax_Syntax.Tm_abs uu___1 -> + let uu___2 = infer env1 e in return_if uu___2 + | FStarC_Syntax_Syntax.Tm_constant uu___1 -> + let uu___2 = infer env1 e in return_if uu___2 + | FStarC_Syntax_Syntax.Tm_quoted uu___1 -> + let uu___2 = infer env1 e in return_if uu___2 + | FStarC_Syntax_Syntax.Tm_app uu___1 -> + let uu___2 = infer env1 e in return_if uu___2 + | FStarC_Syntax_Syntax.Tm_lazy i -> + let uu___1 = FStarC_Syntax_Util.unfold_lazy i in + check env1 uu___1 context_nm + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (false, binding::[]); + FStarC_Syntax_Syntax.body1 = e2;_} + -> + mk_let env1 binding e2 + (fun env2 -> fun e21 -> check env2 e21 context_nm) ensure_m + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = e0; + FStarC_Syntax_Syntax.ret_opt = uu___1; + FStarC_Syntax_Syntax.brs = branches; + FStarC_Syntax_Syntax.rc_opt1 = uu___2;_} + -> + mk_match env1 e0 branches + (fun env2 -> fun body -> check env2 body context_nm) + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = e1; + FStarC_Syntax_Syntax.meta = uu___1;_} + -> check env1 e1 context_nm + | FStarC_Syntax_Syntax.Tm_uinst (e1, uu___1) -> + check env1 e1 context_nm + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = e1; + FStarC_Syntax_Syntax.asc = uu___1; + FStarC_Syntax_Syntax.eff_opt = uu___2;_} + -> check env1 e1 context_nm + | FStarC_Syntax_Syntax.Tm_let uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + FStarC_Compiler_Util.format1 "[check]: Tm_let %s" uu___3 in + failwith uu___2 + | FStarC_Syntax_Syntax.Tm_type uu___1 -> + failwith "impossible (DM stratification)" + | FStarC_Syntax_Syntax.Tm_arrow uu___1 -> + failwith "impossible (DM stratification)" + | FStarC_Syntax_Syntax.Tm_refine uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + FStarC_Compiler_Util.format1 "[check]: Tm_refine %s" uu___3 in + failwith uu___2 + | FStarC_Syntax_Syntax.Tm_uvar uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + FStarC_Compiler_Util.format1 "[check]: Tm_uvar %s" uu___3 in + failwith uu___2 + | FStarC_Syntax_Syntax.Tm_delayed uu___1 -> + failwith "impossible (compressed)" + | FStarC_Syntax_Syntax.Tm_unknown -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + FStarC_Compiler_Util.format1 "[check]: Tm_unknown %s" uu___2 in + failwith uu___1 +and (infer : + env -> + FStarC_Syntax_Syntax.term -> + (nm * FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.term)) + = + fun env1 -> + fun e -> + let mk x = FStarC_Syntax_Syntax.mk x e.FStarC_Syntax_Syntax.pos in + let normalize = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.DontUnfoldAttr + [FStarC_Parser_Const.tac_opaque_attr]; + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.EraseUniverses] env1.tcenv in + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress e in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_bvar bv -> + failwith "I failed to open a binder... boo" + | FStarC_Syntax_Syntax.Tm_name bv -> + ((N (bv.FStarC_Syntax_Syntax.sort)), e, e) + | FStarC_Syntax_Syntax.Tm_lazy i -> + let uu___1 = FStarC_Syntax_Util.unfold_lazy i in infer env1 uu___1 + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = binders; + FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = rc_opt;_} + -> + let subst_rc_opt subst rc_opt1 = + match rc_opt1 with + | FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.residual_effect = uu___1; + FStarC_Syntax_Syntax.residual_typ = + FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.residual_flags = uu___2;_} + -> rc_opt1 + | FStar_Pervasives_Native.None -> rc_opt1 + | FStar_Pervasives_Native.Some rc -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Compiler_Util.must + rc.FStarC_Syntax_Syntax.residual_typ in + FStarC_Syntax_Subst.subst subst uu___4 in + FStar_Pervasives_Native.Some uu___3 in + { + FStarC_Syntax_Syntax.residual_effect = + (rc.FStarC_Syntax_Syntax.residual_effect); + FStarC_Syntax_Syntax.residual_typ = uu___2; + FStarC_Syntax_Syntax.residual_flags = + (rc.FStarC_Syntax_Syntax.residual_flags) + } in + FStar_Pervasives_Native.Some uu___1 in + let binders1 = FStarC_Syntax_Subst.open_binders binders in + let subst = FStarC_Syntax_Subst.opening_of_binders binders1 in + let body1 = FStarC_Syntax_Subst.subst subst body in + let rc_opt1 = subst_rc_opt subst rc_opt in + let env2 = + let uu___1 = + FStarC_TypeChecker_Env.push_binders env1.tcenv binders1 in + { + tcenv = uu___1; + subst = (env1.subst); + tc_const = (env1.tc_const) + } in + let s_binders = + FStarC_Compiler_List.map + (fun b -> + let sort = + star_type' env2 + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + { + FStarC_Syntax_Syntax.binder_bv = + (let uu___1 = b.FStarC_Syntax_Syntax.binder_bv in + { + FStarC_Syntax_Syntax.ppname = + (uu___1.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (uu___1.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = sort + }); + FStarC_Syntax_Syntax.binder_qual = + (b.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity = + (b.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs = + (b.FStarC_Syntax_Syntax.binder_attrs) + }) binders1 in + let uu___1 = + FStarC_Compiler_List.fold_left + (fun uu___2 -> + fun uu___3 -> + match (uu___2, uu___3) with + | ((env3, acc), + { FStarC_Syntax_Syntax.binder_bv = bv; + FStarC_Syntax_Syntax.binder_qual = uu___4; + FStarC_Syntax_Syntax.binder_positivity = uu___5; + FStarC_Syntax_Syntax.binder_attrs = uu___6;_}) + -> + let c = bv.FStarC_Syntax_Syntax.sort in + let uu___7 = is_C c in + if uu___7 + then + let xw = + let uu___8 = + let uu___9 = + FStarC_Ident.string_of_id + bv.FStarC_Syntax_Syntax.ppname in + Prims.strcat uu___9 "__w" in + let uu___9 = star_type' env3 c in + FStarC_Syntax_Syntax.gen_bv uu___8 + FStar_Pervasives_Native.None uu___9 in + let x = + let uu___8 = + let uu___9 = FStarC_Syntax_Syntax.bv_to_name xw in + trans_F_ env3 c uu___9 in + { + FStarC_Syntax_Syntax.ppname = + (bv.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (bv.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = uu___8 + } in + let env4 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Syntax_Syntax.bv_to_name xw in + (bv, uu___11) in + FStarC_Syntax_Syntax.NT uu___10 in + uu___9 :: (env3.subst) in + { + tcenv = (env3.tcenv); + subst = uu___8; + tc_const = (env3.tc_const) + } in + let uu___8 = + let uu___9 = FStarC_Syntax_Syntax.mk_binder x in + let uu___10 = + let uu___11 = FStarC_Syntax_Syntax.mk_binder xw in + uu___11 :: acc in + uu___9 :: uu___10 in + (env4, uu___8) + else + (let x = + let uu___9 = + star_type' env3 bv.FStarC_Syntax_Syntax.sort in + { + FStarC_Syntax_Syntax.ppname = + (bv.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (bv.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = uu___9 + } in + let uu___9 = + let uu___10 = FStarC_Syntax_Syntax.mk_binder x in + uu___10 :: acc in + (env3, uu___9))) (env2, []) binders1 in + (match uu___1 with + | (env3, u_binders) -> + let u_binders1 = FStarC_Compiler_List.rev u_binders in + let uu___2 = + let check_what = + let uu___3 = is_monadic rc_opt1 in + if uu___3 then check_m else check_n in + let uu___3 = check_what env3 body1 in + match uu___3 with + | (t, s_body, u_body) -> + let uu___4 = + let uu___5 = + let uu___6 = is_monadic rc_opt1 in + if uu___6 then M t else N t in + comp_of_nm uu___5 in + (uu___4, s_body, u_body) in + (match uu___2 with + | (comp, s_body, u_body) -> + let t = FStarC_Syntax_Util.arrow binders1 comp in + let s_rc_opt = + match rc_opt1 with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some rc -> + (match rc.FStarC_Syntax_Syntax.residual_typ with + | FStar_Pervasives_Native.None -> + let rc1 = + let uu___3 = + FStarC_Compiler_Util.for_some + (fun uu___4 -> + match uu___4 with + | FStarC_Syntax_Syntax.CPS -> true + | uu___5 -> false) + rc.FStarC_Syntax_Syntax.residual_flags in + if uu___3 + then + let uu___4 = + FStarC_Compiler_List.filter + (fun uu___5 -> + match uu___5 with + | FStarC_Syntax_Syntax.CPS -> false + | uu___6 -> true) + rc.FStarC_Syntax_Syntax.residual_flags in + FStarC_Syntax_Util.mk_residual_comp + FStarC_Parser_Const.effect_Tot_lid + FStar_Pervasives_Native.None uu___4 + else rc in + FStar_Pervasives_Native.Some rc1 + | FStar_Pervasives_Native.Some rt -> + let rt1 = + let uu___3 = get_env env3 in + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.DontUnfoldAttr + [FStarC_Parser_Const.tac_opaque_attr]; + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.EraseUniverses] + uu___3 rt in + let uu___3 = + FStarC_Compiler_Util.for_some + (fun uu___4 -> + match uu___4 with + | FStarC_Syntax_Syntax.CPS -> true + | uu___5 -> false) + rc.FStarC_Syntax_Syntax.residual_flags in + if uu___3 + then + let flags = + FStarC_Compiler_List.filter + (fun uu___4 -> + match uu___4 with + | FStarC_Syntax_Syntax.CPS -> false + | uu___5 -> true) + rc.FStarC_Syntax_Syntax.residual_flags in + let uu___4 = + let uu___5 = + let uu___6 = double_star rt1 in + FStar_Pervasives_Native.Some uu___6 in + FStarC_Syntax_Util.mk_residual_comp + FStarC_Parser_Const.effect_Tot_lid + uu___5 flags in + FStar_Pervasives_Native.Some uu___4 + else + (let uu___5 = + let uu___6 = + let uu___7 = star_type' env3 rt1 in + FStar_Pervasives_Native.Some uu___7 in + { + FStarC_Syntax_Syntax.residual_effect = + (rc.FStarC_Syntax_Syntax.residual_effect); + FStarC_Syntax_Syntax.residual_typ = + uu___6; + FStarC_Syntax_Syntax.residual_flags = + (rc.FStarC_Syntax_Syntax.residual_flags) + } in + FStar_Pervasives_Native.Some uu___5)) in + let uu___3 = + let comp1 = + let uu___4 = is_monadic rc_opt1 in + let uu___5 = + FStarC_Syntax_Subst.subst env3.subst s_body in + trans_G env3 (FStarC_Syntax_Util.comp_result comp) + uu___4 uu___5 in + let uu___4 = + FStarC_Syntax_Util.ascribe u_body + ((FStar_Pervasives.Inr comp1), + FStar_Pervasives_Native.None, false) in + let uu___5 = + let uu___6 = + FStarC_Syntax_Util.residual_comp_of_comp comp1 in + FStar_Pervasives_Native.Some uu___6 in + (uu___4, uu___5) in + (match uu___3 with + | (u_body1, u_rc_opt) -> + let s_body1 = + FStarC_Syntax_Subst.close s_binders s_body in + let s_binders1 = + FStarC_Syntax_Subst.close_binders s_binders in + let s_term = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Syntax_Subst.closing_of_binders + s_binders1 in + subst_rc_opt uu___7 s_rc_opt in + { + FStarC_Syntax_Syntax.bs = s_binders1; + FStarC_Syntax_Syntax.body = s_body1; + FStarC_Syntax_Syntax.rc_opt = uu___6 + } in + FStarC_Syntax_Syntax.Tm_abs uu___5 in + mk uu___4 in + let u_body2 = + FStarC_Syntax_Subst.close u_binders1 u_body1 in + let u_binders2 = + FStarC_Syntax_Subst.close_binders u_binders1 in + let u_term = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Syntax_Subst.closing_of_binders + u_binders2 in + subst_rc_opt uu___7 u_rc_opt in + { + FStarC_Syntax_Syntax.bs = u_binders2; + FStarC_Syntax_Syntax.body = u_body2; + FStarC_Syntax_Syntax.rc_opt = uu___6 + } in + FStarC_Syntax_Syntax.Tm_abs uu___5 in + mk uu___4 in + ((N t), s_term, u_term)))) + | FStarC_Syntax_Syntax.Tm_fvar + { + FStarC_Syntax_Syntax.fv_name = + { FStarC_Syntax_Syntax.v = lid; + FStarC_Syntax_Syntax.p = uu___1;_}; + FStarC_Syntax_Syntax.fv_qual = uu___2;_} + -> + let uu___3 = + let uu___4 = FStarC_TypeChecker_Env.lookup_lid env1.tcenv lid in + FStar_Pervasives_Native.fst uu___4 in + (match uu___3 with + | (uu___4, t) -> + let uu___5 = let uu___6 = normalize t in N uu___6 in + (uu___5, e, e)) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_range_of); + FStarC_Syntax_Syntax.pos = uu___1; + FStarC_Syntax_Syntax.vars = uu___2; + FStarC_Syntax_Syntax.hash_code = uu___3;_}; + FStarC_Syntax_Syntax.args = a::hd::rest;_} + -> + let rest1 = hd :: rest in + let uu___4 = FStarC_Syntax_Util.head_and_args e in + (match uu___4 with + | (unary_op, uu___5) -> + let head = + mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = unary_op; + FStarC_Syntax_Syntax.args = [a] + }) in + let t = + mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = rest1 + }) in + infer env1 t) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_set_range_of); + FStarC_Syntax_Syntax.pos = uu___1; + FStarC_Syntax_Syntax.vars = uu___2; + FStarC_Syntax_Syntax.hash_code = uu___3;_}; + FStarC_Syntax_Syntax.args = a1::a2::hd::rest;_} + -> + let rest1 = hd :: rest in + let uu___4 = FStarC_Syntax_Util.head_and_args e in + (match uu___4 with + | (unary_op, uu___5) -> + let head = + mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = unary_op; + FStarC_Syntax_Syntax.args = [a1; a2] + }) in + let t = + mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = rest1 + }) in + infer env1 t) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_range_of); + FStarC_Syntax_Syntax.pos = uu___1; + FStarC_Syntax_Syntax.vars = uu___2; + FStarC_Syntax_Syntax.hash_code = uu___3;_}; + FStarC_Syntax_Syntax.args = (a, FStar_Pervasives_Native.None)::[];_} + -> + let uu___4 = infer env1 a in + (match uu___4 with + | (t, s, u) -> + let uu___5 = FStarC_Syntax_Util.head_and_args e in + (match uu___5 with + | (head, uu___6) -> + let uu___7 = + let uu___8 = + FStarC_Syntax_Syntax.tabbrev + FStarC_Parser_Const.range_lid in + N uu___8 in + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = FStarC_Syntax_Syntax.as_arg s in + [uu___12] in + { + FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = uu___11 + } in + FStarC_Syntax_Syntax.Tm_app uu___10 in + mk uu___9 in + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = FStarC_Syntax_Syntax.as_arg u in + [uu___13] in + { + FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = uu___12 + } in + FStarC_Syntax_Syntax.Tm_app uu___11 in + mk uu___10 in + (uu___7, uu___8, uu___9))) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_set_range_of); + FStarC_Syntax_Syntax.pos = uu___1; + FStarC_Syntax_Syntax.vars = uu___2; + FStarC_Syntax_Syntax.hash_code = uu___3;_}; + FStarC_Syntax_Syntax.args = (a1, uu___4)::a2::[];_} + -> + let uu___5 = infer env1 a1 in + (match uu___5 with + | (t, s, u) -> + let uu___6 = FStarC_Syntax_Util.head_and_args e in + (match uu___6 with + | (head, uu___7) -> + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = FStarC_Syntax_Syntax.as_arg s in + [uu___12; a2] in + { + FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = uu___11 + } in + FStarC_Syntax_Syntax.Tm_app uu___10 in + mk uu___9 in + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = FStarC_Syntax_Syntax.as_arg u in + [uu___13; a2] in + { + FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = uu___12 + } in + FStarC_Syntax_Syntax.Tm_app uu___11 in + mk uu___10 in + (t, uu___8, uu___9))) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_range_of); + FStarC_Syntax_Syntax.pos = uu___1; + FStarC_Syntax_Syntax.vars = uu___2; + FStarC_Syntax_Syntax.hash_code = uu___3;_}; + FStarC_Syntax_Syntax.args = uu___4;_} + -> + let uu___5 = + let uu___6 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + FStarC_Compiler_Util.format1 "DMFF: Ill-applied constant %s" + uu___6 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) e + FStarC_Errors_Codes.Fatal_IllAppliedConstant () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___5) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_set_range_of); + FStarC_Syntax_Syntax.pos = uu___1; + FStarC_Syntax_Syntax.vars = uu___2; + FStarC_Syntax_Syntax.hash_code = uu___3;_}; + FStarC_Syntax_Syntax.args = uu___4;_} + -> + let uu___5 = + let uu___6 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + FStarC_Compiler_Util.format1 "DMFF: Ill-applied constant %s" + uu___6 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) e + FStarC_Errors_Codes.Fatal_IllAppliedConstant () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___5) + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = args;_} + -> + let uu___1 = check_n env1 head in + (match uu___1 with + | (t_head, s_head, u_head) -> + let is_arrow t = + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress t in + uu___3.FStarC_Syntax_Syntax.n in + match uu___2 with + | FStarC_Syntax_Syntax.Tm_arrow uu___3 -> true + | uu___3 -> false in + let rec flatten t = + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress t in + uu___3.FStarC_Syntax_Syntax.n in + match uu___2 with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = binders; + FStarC_Syntax_Syntax.comp = + { + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Total t1; + FStarC_Syntax_Syntax.pos = uu___3; + FStarC_Syntax_Syntax.vars = uu___4; + FStarC_Syntax_Syntax.hash_code = uu___5;_};_} + when is_arrow t1 -> + let uu___6 = flatten t1 in + (match uu___6 with + | (binders', comp) -> + ((FStarC_Compiler_List.op_At binders binders'), + comp)) + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = binders; + FStarC_Syntax_Syntax.comp = comp;_} + -> (binders, comp) + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = e1; + FStarC_Syntax_Syntax.asc = uu___3; + FStarC_Syntax_Syntax.eff_opt = uu___4;_} + -> flatten e1 + | uu___3 -> + let uu___4 = + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t_head in + FStarC_Compiler_Util.format1 "%s: not a function type" + uu___5 in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_NotFunctionType () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4) in + let uu___2 = flatten t_head in + (match uu___2 with + | (binders, comp) -> + let n = FStarC_Compiler_List.length binders in + let n' = FStarC_Compiler_List.length args in + (if + (FStarC_Compiler_List.length binders) < + (FStarC_Compiler_List.length args) + then + (let uu___4 = + let uu___5 = FStarC_Compiler_Util.string_of_int n in + let uu___6 = + FStarC_Compiler_Util.string_of_int (n' - n) in + let uu___7 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_nat) n in + FStarC_Compiler_Util.format3 + "The head of this application, after being applied to %s arguments, is an effectful computation (leaving %s arguments to be applied). Please let-bind the head applied to the %s first arguments." + uu___5 uu___6 uu___7 in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_BinderAndArgsLengthMismatch + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4)) + else (); + (let uu___4 = FStarC_Syntax_Subst.open_comp binders comp in + match uu___4 with + | (binders1, comp1) -> + let rec final_type subst uu___5 args1 = + match uu___5 with + | (binders2, comp2) -> + (match (binders2, args1) with + | ([], []) -> + let uu___6 = + FStarC_Syntax_Subst.subst_comp subst + comp2 in + nm_of_comp uu___6 + | (binders3, []) -> + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + mk + (FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 + = binders3; + FStarC_Syntax_Syntax.comp + = comp2 + }) in + FStarC_Syntax_Subst.subst subst + uu___9 in + FStarC_Syntax_Subst.compress uu___8 in + uu___7.FStarC_Syntax_Syntax.n in + (match uu___6 with + | FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 = + binders4; + FStarC_Syntax_Syntax.comp = comp3;_} + -> + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Syntax_Subst.close_comp + binders4 comp3 in + { + FStarC_Syntax_Syntax.bs1 = + binders4; + FStarC_Syntax_Syntax.comp = + uu___10 + } in + FStarC_Syntax_Syntax.Tm_arrow + uu___9 in + mk uu___8 in + N uu___7 + | uu___7 -> failwith "wat?") + | ([], uu___6::uu___7) -> + failwith "just checked that?!" + | ({ FStarC_Syntax_Syntax.binder_bv = bv; + FStarC_Syntax_Syntax.binder_qual = + uu___6; + FStarC_Syntax_Syntax.binder_positivity + = uu___7; + FStarC_Syntax_Syntax.binder_attrs = + uu___8;_}::binders3, + (arg, uu___9)::args2) -> + final_type + ((FStarC_Syntax_Syntax.NT (bv, arg)) + :: subst) (binders3, comp2) args2) in + let final_type1 = + final_type [] (binders1, comp1) args in + let uu___5 = + FStarC_Compiler_List.splitAt n' binders1 in + (match uu___5 with + | (binders2, uu___6) -> + let uu___7 = + let uu___8 = + FStarC_Compiler_List.map2 + (fun uu___9 -> + fun uu___10 -> + match (uu___9, uu___10) with + | ({ + FStarC_Syntax_Syntax.binder_bv + = bv; + FStarC_Syntax_Syntax.binder_qual + = uu___11; + FStarC_Syntax_Syntax.binder_positivity + = uu___12; + FStarC_Syntax_Syntax.binder_attrs + = uu___13;_}, + (arg, q)) -> + let uu___14 = + let uu___15 = + FStarC_Syntax_Subst.compress + bv.FStarC_Syntax_Syntax.sort in + uu___15.FStarC_Syntax_Syntax.n in + (match uu___14 with + | FStarC_Syntax_Syntax.Tm_type + uu___15 -> + let uu___16 = + let uu___17 = + star_type' env1 arg in + (uu___17, q) in + (uu___16, [(arg, q)]) + | uu___15 -> + let uu___16 = + check_n env1 arg in + (match uu___16 with + | (uu___17, s_arg, u_arg) + -> + let uu___18 = + let uu___19 = + is_C + bv.FStarC_Syntax_Syntax.sort in + if uu___19 + then + let uu___20 = + let uu___21 = + FStarC_Syntax_Subst.subst + env1.subst + s_arg in + (uu___21, q) in + [uu___20; + (u_arg, q)] + else [(u_arg, q)] in + ((s_arg, q), uu___18)))) + binders2 args in + FStarC_Compiler_List.split uu___8 in + (match uu___7 with + | (s_args, u_args) -> + let u_args1 = + FStarC_Compiler_List.flatten u_args in + let uu___8 = + mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = s_head; + FStarC_Syntax_Syntax.args = + s_args + }) in + let uu___9 = + mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = u_head; + FStarC_Syntax_Syntax.args = + u_args1 + }) in + (final_type1, uu___8, uu___9))))))) + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (false, binding::[]); + FStarC_Syntax_Syntax.body1 = e2;_} + -> mk_let env1 binding e2 infer check_m + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = e0; + FStarC_Syntax_Syntax.ret_opt = uu___1; + FStarC_Syntax_Syntax.brs = branches; + FStarC_Syntax_Syntax.rc_opt1 = uu___2;_} + -> mk_match env1 e0 branches infer + | FStarC_Syntax_Syntax.Tm_uinst (e1, uu___1) -> infer env1 e1 + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = e1; + FStarC_Syntax_Syntax.meta = uu___1;_} + -> infer env1 e1 + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = e1; FStarC_Syntax_Syntax.asc = uu___1; + FStarC_Syntax_Syntax.eff_opt = uu___2;_} + -> infer env1 e1 + | FStarC_Syntax_Syntax.Tm_constant c -> + let uu___1 = let uu___2 = env1.tc_const c in N uu___2 in + (uu___1, e, e) + | FStarC_Syntax_Syntax.Tm_quoted (tm, qt) -> + ((N FStarC_Syntax_Syntax.t_term), e, e) + | FStarC_Syntax_Syntax.Tm_let uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + FStarC_Compiler_Util.format1 "[infer]: Tm_let %s" uu___3 in + failwith uu___2 + | FStarC_Syntax_Syntax.Tm_type uu___1 -> + failwith "impossible (DM stratification)" + | FStarC_Syntax_Syntax.Tm_arrow uu___1 -> + failwith "impossible (DM stratification)" + | FStarC_Syntax_Syntax.Tm_refine uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + FStarC_Compiler_Util.format1 "[infer]: Tm_refine %s" uu___3 in + failwith uu___2 + | FStarC_Syntax_Syntax.Tm_uvar uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + FStarC_Compiler_Util.format1 "[infer]: Tm_uvar %s" uu___3 in + failwith uu___2 + | FStarC_Syntax_Syntax.Tm_delayed uu___1 -> + failwith "impossible (compressed)" + | FStarC_Syntax_Syntax.Tm_unknown -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + FStarC_Compiler_Util.format1 "[infer]: Tm_unknown %s" uu___2 in + failwith uu___1 +and (mk_match : + env -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + (FStarC_Syntax_Syntax.pat' FStarC_Syntax_Syntax.withinfo_t * + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax + FStar_Pervasives_Native.option * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax) Prims.list -> + (env -> + FStarC_Syntax_Syntax.term -> + (nm * FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.term)) + -> (nm * FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.term)) + = + fun env1 -> + fun e0 -> + fun branches -> + fun f -> + let mk x = FStarC_Syntax_Syntax.mk x e0.FStarC_Syntax_Syntax.pos in + let uu___ = check_n env1 e0 in + match uu___ with + | (uu___1, s_e0, u_e0) -> + let uu___2 = + let uu___3 = + FStarC_Compiler_List.map + (fun b -> + let uu___4 = FStarC_Syntax_Subst.open_branch b in + match uu___4 with + | (pat, FStar_Pervasives_Native.None, body) -> + let env2 = + let uu___5 = + let uu___6 = FStarC_Syntax_Syntax.pat_bvs pat in + FStarC_Compiler_List.fold_left + FStarC_TypeChecker_Env.push_bv env1.tcenv + uu___6 in + { + tcenv = uu___5; + subst = (env1.subst); + tc_const = (env1.tc_const) + } in + let uu___5 = f env2 body in + (match uu___5 with + | (nm1, s_body, u_body) -> + (nm1, + (pat, FStar_Pervasives_Native.None, + (s_body, u_body, body)))) + | uu___5 -> + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_WhenClauseNotSupported + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "No when clauses in the definition language")) + branches in + FStarC_Compiler_List.split uu___3 in + (match uu___2 with + | (nms, branches1) -> + let t1 = + let uu___3 = FStarC_Compiler_List.hd nms in + match uu___3 with | M t11 -> t11 | N t11 -> t11 in + let has_m = + FStarC_Compiler_List.existsb + (fun uu___3 -> + match uu___3 with + | M uu___4 -> true + | uu___4 -> false) nms in + let uu___3 = + let uu___4 = + FStarC_Compiler_List.map2 + (fun nm1 -> + fun uu___5 -> + match uu___5 with + | (pat, guard, (s_body, u_body, original_body)) + -> + (match (nm1, has_m) with + | (N t2, false) -> + (nm1, (pat, guard, s_body), + (pat, guard, u_body)) + | (M t2, true) -> + (nm1, (pat, guard, s_body), + (pat, guard, u_body)) + | (N t2, true) -> + let uu___6 = + check env1 original_body (M t2) in + (match uu___6 with + | (uu___7, s_body1, u_body1) -> + ((M t2), (pat, guard, s_body1), + (pat, guard, u_body1))) + | (M uu___6, false) -> + failwith "impossible")) nms branches1 in + FStarC_Compiler_List.unzip3 uu___4 in + (match uu___3 with + | (nms1, s_branches, u_branches) -> + if has_m + then + let p_type = mk_star_to_type mk env1 t1 in + let p = + FStarC_Syntax_Syntax.gen_bv "p''" + FStar_Pervasives_Native.None p_type in + let s_branches1 = + FStarC_Compiler_List.map + (fun uu___4 -> + match uu___4 with + | (pat, guard, s_body) -> + let s_body1 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Syntax_Syntax.bv_to_name + p in + let uu___10 = + FStarC_Syntax_Syntax.as_aqual_implicit + false in + (uu___9, uu___10) in + [uu___8] in + { + FStarC_Syntax_Syntax.hd = s_body; + FStarC_Syntax_Syntax.args = + uu___7 + } in + FStarC_Syntax_Syntax.Tm_app uu___6 in + mk uu___5 in + (pat, guard, s_body1)) s_branches in + let s_branches2 = + FStarC_Compiler_List.map + FStarC_Syntax_Subst.close_branch s_branches1 in + let u_branches1 = + FStarC_Compiler_List.map + FStarC_Syntax_Subst.close_branch u_branches in + let s_e = + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.mk_binder p in + [uu___5] in + let uu___5 = + mk + (FStarC_Syntax_Syntax.Tm_match + { + FStarC_Syntax_Syntax.scrutinee = s_e0; + FStarC_Syntax_Syntax.ret_opt = + FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.brs = s_branches2; + FStarC_Syntax_Syntax.rc_opt1 = + FStar_Pervasives_Native.None + }) in + FStarC_Syntax_Util.abs uu___4 uu___5 + (FStar_Pervasives_Native.Some + (FStarC_Syntax_Util.residual_tot + FStarC_Syntax_Util.ktype0)) in + let t1_star = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.new_bv + FStar_Pervasives_Native.None p_type in + FStarC_Syntax_Syntax.mk_binder uu___6 in + [uu___5] in + let uu___5 = + FStarC_Syntax_Syntax.mk_Total + FStarC_Syntax_Util.ktype0 in + FStarC_Syntax_Util.arrow uu___4 uu___5 in + let uu___4 = + mk + (FStarC_Syntax_Syntax.Tm_ascribed + { + FStarC_Syntax_Syntax.tm = s_e; + FStarC_Syntax_Syntax.asc = + ((FStar_Pervasives.Inl t1_star), + FStar_Pervasives_Native.None, false); + FStarC_Syntax_Syntax.eff_opt = + FStar_Pervasives_Native.None + }) in + let uu___5 = + mk + (FStarC_Syntax_Syntax.Tm_match + { + FStarC_Syntax_Syntax.scrutinee = u_e0; + FStarC_Syntax_Syntax.ret_opt = + FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.brs = u_branches1; + FStarC_Syntax_Syntax.rc_opt1 = + FStar_Pervasives_Native.None + }) in + ((M t1), uu___4, uu___5) + else + (let s_branches1 = + FStarC_Compiler_List.map + FStarC_Syntax_Subst.close_branch s_branches in + let u_branches1 = + FStarC_Compiler_List.map + FStarC_Syntax_Subst.close_branch u_branches in + let t1_star = t1 in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + mk + (FStarC_Syntax_Syntax.Tm_match + { + FStarC_Syntax_Syntax.scrutinee = + s_e0; + FStarC_Syntax_Syntax.ret_opt = + FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.brs = + s_branches1; + FStarC_Syntax_Syntax.rc_opt1 = + FStar_Pervasives_Native.None + }) in + { + FStarC_Syntax_Syntax.tm = uu___8; + FStarC_Syntax_Syntax.asc = + ((FStar_Pervasives.Inl t1_star), + FStar_Pervasives_Native.None, false); + FStarC_Syntax_Syntax.eff_opt = + FStar_Pervasives_Native.None + } in + FStarC_Syntax_Syntax.Tm_ascribed uu___7 in + mk uu___6 in + let uu___6 = + mk + (FStarC_Syntax_Syntax.Tm_match + { + FStarC_Syntax_Syntax.scrutinee = u_e0; + FStarC_Syntax_Syntax.ret_opt = + FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.brs = u_branches1; + FStarC_Syntax_Syntax.rc_opt1 = + FStar_Pervasives_Native.None + }) in + ((N t1), uu___5, uu___6)))) +and (mk_let : + env_ -> + FStarC_Syntax_Syntax.letbinding -> + FStarC_Syntax_Syntax.term -> + (env_ -> + FStarC_Syntax_Syntax.term -> + (nm * FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.term)) + -> + (env_ -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.term)) + -> (nm * FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.term)) + = + fun env1 -> + fun binding -> + fun e2 -> + fun proceed -> + fun ensure_m -> + let mk x = FStarC_Syntax_Syntax.mk x e2.FStarC_Syntax_Syntax.pos in + let e1 = binding.FStarC_Syntax_Syntax.lbdef in + let x = + FStarC_Compiler_Util.left binding.FStarC_Syntax_Syntax.lbname in + let x_binders = + let uu___ = FStarC_Syntax_Syntax.mk_binder x in [uu___] in + let uu___ = FStarC_Syntax_Subst.open_term x_binders e2 in + match uu___ with + | (x_binders1, e21) -> + let uu___1 = infer env1 e1 in + (match uu___1 with + | (N t1, s_e1, u_e1) -> + let u_binding = + let uu___2 = is_C t1 in + if uu___2 + then + let uu___3 = + let uu___4 = + FStarC_Syntax_Subst.subst env1.subst s_e1 in + trans_F_ env1 t1 uu___4 in + { + FStarC_Syntax_Syntax.lbname = + (binding.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs = + (binding.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = uu___3; + FStarC_Syntax_Syntax.lbeff = + (binding.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = + (binding.FStarC_Syntax_Syntax.lbdef); + FStarC_Syntax_Syntax.lbattrs = + (binding.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (binding.FStarC_Syntax_Syntax.lbpos) + } + else binding in + let env2 = + let uu___2 = + FStarC_TypeChecker_Env.push_bv env1.tcenv + { + FStarC_Syntax_Syntax.ppname = + (x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (x.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = t1 + } in + { + tcenv = uu___2; + subst = (env1.subst); + tc_const = (env1.tc_const) + } in + let uu___2 = proceed env2 e21 in + (match uu___2 with + | (nm_rec, s_e2, u_e2) -> + let s_binding = + let uu___3 = + star_type' env2 + binding.FStarC_Syntax_Syntax.lbtyp in + { + FStarC_Syntax_Syntax.lbname = + (binding.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs = + (binding.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = uu___3; + FStarC_Syntax_Syntax.lbeff = + (binding.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = + (binding.FStarC_Syntax_Syntax.lbdef); + FStarC_Syntax_Syntax.lbattrs = + (binding.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (binding.FStarC_Syntax_Syntax.lbpos) + } in + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Subst.close x_binders1 s_e2 in + { + FStarC_Syntax_Syntax.lbs = + (false, + [{ + FStarC_Syntax_Syntax.lbname = + (s_binding.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs = + (s_binding.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = + (s_binding.FStarC_Syntax_Syntax.lbtyp); + FStarC_Syntax_Syntax.lbeff = + (s_binding.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = s_e1; + FStarC_Syntax_Syntax.lbattrs = + (s_binding.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (s_binding.FStarC_Syntax_Syntax.lbpos) + }]); + FStarC_Syntax_Syntax.body1 = uu___6 + } in + FStarC_Syntax_Syntax.Tm_let uu___5 in + mk uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Syntax_Subst.close x_binders1 u_e2 in + { + FStarC_Syntax_Syntax.lbs = + (false, + [{ + FStarC_Syntax_Syntax.lbname = + (u_binding.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs = + (u_binding.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = + (u_binding.FStarC_Syntax_Syntax.lbtyp); + FStarC_Syntax_Syntax.lbeff = + (u_binding.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = u_e1; + FStarC_Syntax_Syntax.lbattrs = + (u_binding.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (u_binding.FStarC_Syntax_Syntax.lbpos) + }]); + FStarC_Syntax_Syntax.body1 = uu___7 + } in + FStarC_Syntax_Syntax.Tm_let uu___6 in + mk uu___5 in + (nm_rec, uu___3, uu___4)) + | (M t1, s_e1, u_e1) -> + let u_binding = + { + FStarC_Syntax_Syntax.lbname = + (binding.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs = + (binding.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = t1; + FStarC_Syntax_Syntax.lbeff = + FStarC_Parser_Const.effect_PURE_lid; + FStarC_Syntax_Syntax.lbdef = + (binding.FStarC_Syntax_Syntax.lbdef); + FStarC_Syntax_Syntax.lbattrs = + (binding.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (binding.FStarC_Syntax_Syntax.lbpos) + } in + let env2 = + let uu___2 = + FStarC_TypeChecker_Env.push_bv env1.tcenv + { + FStarC_Syntax_Syntax.ppname = + (x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (x.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = t1 + } in + { + tcenv = uu___2; + subst = (env1.subst); + tc_const = (env1.tc_const) + } in + let uu___2 = ensure_m env2 e21 in + (match uu___2 with + | (t2, s_e2, u_e2) -> + let p_type = mk_star_to_type mk env2 t2 in + let p = + FStarC_Syntax_Syntax.gen_bv "p''" + FStar_Pervasives_Native.None p_type in + let s_e21 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Syntax_Syntax.bv_to_name p in + let uu___8 = + FStarC_Syntax_Syntax.as_aqual_implicit + false in + (uu___7, uu___8) in + [uu___6] in + { + FStarC_Syntax_Syntax.hd = s_e2; + FStarC_Syntax_Syntax.args = uu___5 + } in + FStarC_Syntax_Syntax.Tm_app uu___4 in + mk uu___3 in + let s_e22 = + FStarC_Syntax_Util.abs x_binders1 s_e21 + (FStar_Pervasives_Native.Some + (FStarC_Syntax_Util.residual_tot + FStarC_Syntax_Util.ktype0)) in + let body = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Syntax_Syntax.as_aqual_implicit + false in + (s_e22, uu___7) in + [uu___6] in + { + FStarC_Syntax_Syntax.hd = s_e1; + FStarC_Syntax_Syntax.args = uu___5 + } in + FStarC_Syntax_Syntax.Tm_app uu___4 in + mk uu___3 in + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.mk_binder p in + [uu___5] in + FStarC_Syntax_Util.abs uu___4 body + (FStar_Pervasives_Native.Some + (FStarC_Syntax_Util.residual_tot + FStarC_Syntax_Util.ktype0)) in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Syntax_Subst.close x_binders1 u_e2 in + { + FStarC_Syntax_Syntax.lbs = + (false, + [{ + FStarC_Syntax_Syntax.lbname = + (u_binding.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs = + (u_binding.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = + (u_binding.FStarC_Syntax_Syntax.lbtyp); + FStarC_Syntax_Syntax.lbeff = + (u_binding.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = u_e1; + FStarC_Syntax_Syntax.lbattrs = + (u_binding.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (u_binding.FStarC_Syntax_Syntax.lbpos) + }]); + FStarC_Syntax_Syntax.body1 = uu___7 + } in + FStarC_Syntax_Syntax.Tm_let uu___6 in + mk uu___5 in + ((M t2), uu___3, uu___4))) +and (check_n : + env_ -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.typ * FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.term)) + = + fun env1 -> + fun e -> + let mn = + let uu___ = + FStarC_Syntax_Syntax.mk FStarC_Syntax_Syntax.Tm_unknown + e.FStarC_Syntax_Syntax.pos in + N uu___ in + let uu___ = check env1 e mn in + match uu___ with + | (N t, s_e, u_e) -> (t, s_e, u_e) + | uu___1 -> failwith "[check_n]: impossible" +and (check_m : + env_ -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.typ * FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.term)) + = + fun env1 -> + fun e -> + let mn = + let uu___ = + FStarC_Syntax_Syntax.mk FStarC_Syntax_Syntax.Tm_unknown + e.FStarC_Syntax_Syntax.pos in + M uu___ in + let uu___ = check env1 e mn in + match uu___ with + | (M t, s_e, u_e) -> (t, s_e, u_e) + | uu___1 -> failwith "[check_m]: impossible" +and (comp_of_nm : nm_ -> FStarC_Syntax_Syntax.comp) = + fun nm1 -> + match nm1 with | N t -> FStarC_Syntax_Syntax.mk_Total t | M t -> mk_M t +and (mk_M : FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.comp) = + fun t -> + FStarC_Syntax_Syntax.mk_Comp + { + FStarC_Syntax_Syntax.comp_univs = [FStarC_Syntax_Syntax.U_unknown]; + FStarC_Syntax_Syntax.effect_name = FStarC_Parser_Const.monadic_lid; + FStarC_Syntax_Syntax.result_typ = t; + FStarC_Syntax_Syntax.effect_args = []; + FStarC_Syntax_Syntax.flags = + [FStarC_Syntax_Syntax.CPS; FStarC_Syntax_Syntax.TOTAL] + } +and (type_of_comp : + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = fun t -> FStarC_Syntax_Util.comp_result t +and (trans_F_ : + env_ -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun env1 -> + fun c -> + fun wp -> + (let uu___1 = let uu___2 = is_C c in Prims.op_Negation uu___2 in + if uu___1 + then + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term c in + FStarC_Compiler_Util.format1 "Not a DM4F C-type: %s" uu___3 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) c + FStarC_Errors_Codes.Error_UnexpectedDM4FType () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2) + else ()); + (let mk x = FStarC_Syntax_Syntax.mk x c.FStarC_Syntax_Syntax.pos in + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress c in + uu___2.FStarC_Syntax_Syntax.n in + match uu___1 with + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = args;_} + -> + let uu___2 = FStarC_Syntax_Util.head_and_args wp in + (match uu___2 with + | (wp_head, wp_args) -> + ((let uu___4 = + (Prims.op_Negation + ((FStarC_Compiler_List.length wp_args) = + (FStarC_Compiler_List.length args))) + || + (let uu___5 = + let uu___6 = + FStarC_Parser_Const.mk_tuple_data_lid + (FStarC_Compiler_List.length wp_args) + FStarC_Compiler_Range_Type.dummyRange in + FStarC_Syntax_Util.is_constructor wp_head uu___6 in + Prims.op_Negation uu___5) in + if uu___4 then failwith "mismatch" else ()); + (let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Compiler_List.map2 + (fun uu___7 -> + fun uu___8 -> + match (uu___7, uu___8) with + | ((arg, q), (wp_arg, q')) -> + let print_implicit q1 = + let uu___9 = + FStarC_Syntax_Syntax.is_aqual_implicit + q1 in + if uu___9 + then "implicit" + else "explicit" in + ((let uu___10 = + let uu___11 = + FStarC_Syntax_Util.eq_aqual q q' in + Prims.op_Negation uu___11 in + if uu___10 + then + let uu___11 = + let uu___12 = print_implicit q in + let uu___13 = print_implicit q' in + FStarC_Compiler_Util.format2 + "Incoherent implicit qualifiers %s %s\n" + uu___12 uu___13 in + FStarC_Errors.log_issue + FStarC_Class_HasRange.hasRange_range + head.FStarC_Syntax_Syntax.pos + FStarC_Errors_Codes.Warning_IncoherentImplicitQualifier + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___11) + else ()); + (let uu___10 = trans_F_ env1 arg wp_arg in + (uu___10, q)))) args wp_args in + { + FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = uu___6 + } in + FStarC_Syntax_Syntax.Tm_app uu___5 in + mk uu___4))) + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = binders; + FStarC_Syntax_Syntax.comp = comp;_} + -> + let binders1 = FStarC_Syntax_Util.name_binders binders in + let uu___2 = FStarC_Syntax_Subst.open_comp binders1 comp in + (match uu___2 with + | (binders_orig, comp1) -> + let uu___3 = + let uu___4 = + FStarC_Compiler_List.map + (fun b -> + let uu___5 = + ((b.FStarC_Syntax_Syntax.binder_bv), + (b.FStarC_Syntax_Syntax.binder_qual)) in + match uu___5 with + | (bv, q) -> + let h = bv.FStarC_Syntax_Syntax.sort in + let uu___6 = is_C h in + if uu___6 + then + let w' = + let uu___7 = + let uu___8 = + FStarC_Ident.string_of_id + bv.FStarC_Syntax_Syntax.ppname in + Prims.strcat uu___8 "__w'" in + let uu___8 = star_type' env1 h in + FStarC_Syntax_Syntax.gen_bv uu___7 + FStar_Pervasives_Native.None uu___8 in + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Syntax_Syntax.bv_to_name + w' in + trans_F_ env1 h uu___12 in + FStarC_Syntax_Syntax.null_bv uu___11 in + { + FStarC_Syntax_Syntax.binder_bv = + uu___10; + FStarC_Syntax_Syntax.binder_qual = + (b.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity + = + (b.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs = + (b.FStarC_Syntax_Syntax.binder_attrs) + } in + [uu___9] in + { + FStarC_Syntax_Syntax.binder_bv = w'; + FStarC_Syntax_Syntax.binder_qual = + (b.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity = + (b.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs = + (b.FStarC_Syntax_Syntax.binder_attrs) + } :: uu___8 in + (w', uu___7) + else + (let x = + let uu___8 = + let uu___9 = + FStarC_Ident.string_of_id + bv.FStarC_Syntax_Syntax.ppname in + Prims.strcat uu___9 "__x" in + let uu___9 = star_type' env1 h in + FStarC_Syntax_Syntax.gen_bv uu___8 + FStar_Pervasives_Native.None uu___9 in + (x, + [{ + FStarC_Syntax_Syntax.binder_bv = x; + FStarC_Syntax_Syntax.binder_qual = + (b.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity + = + (b.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs = + (b.FStarC_Syntax_Syntax.binder_attrs) + }]))) binders_orig in + FStarC_Compiler_List.split uu___4 in + (match uu___3 with + | (bvs, binders2) -> + let binders3 = FStarC_Compiler_List.flatten binders2 in + let comp2 = + let uu___4 = + let uu___5 = + FStarC_Syntax_Syntax.binders_of_list bvs in + FStarC_Syntax_Util.rename_binders binders_orig + uu___5 in + FStarC_Syntax_Subst.subst_comp uu___4 comp1 in + let app = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Compiler_List.map + (fun bv -> + let uu___7 = + FStarC_Syntax_Syntax.bv_to_name bv in + let uu___8 = + FStarC_Syntax_Syntax.as_aqual_implicit + false in + (uu___7, uu___8)) bvs in + { + FStarC_Syntax_Syntax.hd = wp; + FStarC_Syntax_Syntax.args = uu___6 + } in + FStarC_Syntax_Syntax.Tm_app uu___5 in + mk uu___4 in + let comp3 = + let uu___4 = type_of_comp comp2 in + let uu___5 = is_monadic_comp comp2 in + trans_G env1 uu___4 uu___5 app in + FStarC_Syntax_Util.arrow binders3 comp3)) + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = e; + FStarC_Syntax_Syntax.asc = uu___2; + FStarC_Syntax_Syntax.eff_opt = uu___3;_} + -> trans_F_ env1 e wp + | uu___2 -> failwith "impossible trans_F_") +and (trans_G : + env_ -> + FStarC_Syntax_Syntax.typ -> + Prims.bool -> FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.comp) + = + fun env1 -> + fun h -> + fun is_monadic1 -> + fun wp -> + if is_monadic1 + then + let uu___ = + let uu___1 = star_type' env1 h in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Syntax.as_aqual_implicit false in + (wp, uu___4) in + [uu___3] in + { + FStarC_Syntax_Syntax.comp_univs = + [FStarC_Syntax_Syntax.U_unknown]; + FStarC_Syntax_Syntax.effect_name = + FStarC_Parser_Const.effect_PURE_lid; + FStarC_Syntax_Syntax.result_typ = uu___1; + FStarC_Syntax_Syntax.effect_args = uu___2; + FStarC_Syntax_Syntax.flags = [] + } in + FStarC_Syntax_Syntax.mk_Comp uu___ + else + (let uu___1 = trans_F_ env1 h wp in + FStarC_Syntax_Syntax.mk_Total uu___1) +let (n : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.DontUnfoldAttr + [FStarC_Parser_Const.tac_opaque_attr]; + FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.UnfoldUntil FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.DoNotUnfoldPureLets; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.EraseUniverses] +let (star_type : env -> FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.typ) + = fun env1 -> fun t -> let uu___ = n env1.tcenv t in star_type' env1 uu___ +let (star_expr : + env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.typ * FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.term)) + = fun env1 -> fun t -> let uu___ = n env1.tcenv t in check_n env1 uu___ +let (trans_F : + env -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun env1 -> + fun c -> + fun wp -> + let uu___ = n env1.tcenv c in + let uu___1 = n env1.tcenv wp in trans_F_ env1 uu___ uu___1 +let (recheck_debug : + Prims.string -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun s -> + fun env1 -> + fun t -> + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.print2 + "Term has been %s-transformed to:\n%s\n----------\n" s uu___2 + else ()); + (let uu___1 = FStarC_TypeChecker_TcTerm.tc_term env1 t in + match uu___1 with + | (t', uu___2, uu___3) -> + ((let uu___5 = FStarC_Compiler_Effect.op_Bang dbg in + if uu___5 + then + let uu___6 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + t' in + FStarC_Compiler_Util.print1 + "Re-checked; got:\n%s\n----------\n" uu___6 + else ()); + t')) +let (cps_and_elaborate : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.eff_decl -> + (FStarC_Syntax_Syntax.sigelt Prims.list * FStarC_Syntax_Syntax.eff_decl + * FStarC_Syntax_Syntax.sigelt FStar_Pervasives_Native.option)) + = + fun env1 -> + fun ed -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Syntax_Util.effect_sig_ts + ed.FStarC_Syntax_Syntax.signature in + FStar_Pervasives_Native.snd uu___2 in + FStarC_Syntax_Subst.open_term ed.FStarC_Syntax_Syntax.binders uu___1 in + match uu___ with + | (effect_binders_un, signature_un) -> + let uu___1 = + FStarC_TypeChecker_TcTerm.tc_tparams env1 effect_binders_un in + (match uu___1 with + | (effect_binders, env2, uu___2) -> + let uu___3 = + FStarC_TypeChecker_TcTerm.tc_trivial_guard env2 signature_un in + (match uu___3 with + | (signature, uu___4) -> + let raise_error code msg = + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + signature.FStarC_Syntax_Syntax.pos code () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic msg) in + let effect_binders1 = + FStarC_Compiler_List.map + (fun b -> + let uu___5 = + let uu___6 = b.FStarC_Syntax_Syntax.binder_bv in + let uu___7 = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.EraseUniverses] env2 + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + { + FStarC_Syntax_Syntax.ppname = + (uu___6.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (uu___6.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = uu___7 + } in + { + FStarC_Syntax_Syntax.binder_bv = uu___5; + FStarC_Syntax_Syntax.binder_qual = + (b.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity = + (b.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs = + (b.FStarC_Syntax_Syntax.binder_attrs) + }) effect_binders in + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Syntax_Subst.compress signature_un in + uu___7.FStarC_Syntax_Syntax.n in + match uu___6 with + | FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 = + { FStarC_Syntax_Syntax.binder_bv = a; + FStarC_Syntax_Syntax.binder_qual = uu___7; + FStarC_Syntax_Syntax.binder_positivity = + uu___8; + FStarC_Syntax_Syntax.binder_attrs = uu___9;_}::[]; + FStarC_Syntax_Syntax.comp = effect_marker;_} + -> (a, effect_marker) + | uu___7 -> + raise_error + FStarC_Errors_Codes.Fatal_BadSignatureShape + "bad shape for effect-for-free signature" in + (match uu___5 with + | (a, effect_marker) -> + let a1 = + let uu___6 = FStarC_Syntax_Syntax.is_null_bv a in + if uu___6 + then + let uu___7 = + let uu___8 = + FStarC_Syntax_Syntax.range_of_bv a in + FStar_Pervasives_Native.Some uu___8 in + FStarC_Syntax_Syntax.gen_bv "a" uu___7 + a.FStarC_Syntax_Syntax.sort + else a in + let open_and_check env3 other_binders t = + let subst = + FStarC_Syntax_Subst.opening_of_binders + (FStarC_Compiler_List.op_At effect_binders1 + other_binders) in + let t1 = FStarC_Syntax_Subst.subst subst t in + let uu___6 = + FStarC_TypeChecker_TcTerm.tc_term env3 t1 in + match uu___6 with + | (t2, comp, uu___7) -> (t2, comp) in + let mk x = + FStarC_Syntax_Syntax.mk x + signature.FStarC_Syntax_Syntax.pos in + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Syntax_Util.get_eff_repr ed in + FStarC_Compiler_Util.must uu___9 in + FStar_Pervasives_Native.snd uu___8 in + open_and_check env2 [] uu___7 in + (match uu___6 with + | (repr, _comp) -> + ((let uu___8 = + FStarC_Compiler_Effect.op_Bang dbg in + if uu___8 + then + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term repr in + FStarC_Compiler_Util.print1 + "Representation is: %s\n" uu___9 + else ()); + (let ed_range = + FStarC_TypeChecker_Env.get_range env2 in + let dmff_env = + empty env2 + (FStarC_TypeChecker_TcTerm.tc_constant + env2 + FStarC_Compiler_Range_Type.dummyRange) in + let wp_type = star_type dmff_env repr in + let uu___8 = recheck_debug "*" env2 wp_type in + let wp_a = + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_Syntax_Syntax.bv_to_name + a1 in + let uu___15 = + FStarC_Syntax_Syntax.as_aqual_implicit + false in + (uu___14, uu___15) in + [uu___13] in + { + FStarC_Syntax_Syntax.hd = wp_type; + FStarC_Syntax_Syntax.args = uu___12 + } in + FStarC_Syntax_Syntax.Tm_app uu___11 in + mk uu___10 in + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Beta] env2 uu___9 in + let effect_signature = + let binders = + let uu___9 = + let uu___10 = + FStarC_Syntax_Syntax.as_bqual_implicit + false in + FStarC_Syntax_Syntax.mk_binder_with_attrs + a1 uu___10 + FStar_Pervasives_Native.None [] in + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Syntax_Syntax.gen_bv + "dijkstra_wp" + FStar_Pervasives_Native.None wp_a in + FStarC_Syntax_Syntax.mk_binder + uu___12 in + [uu___11] in + uu___9 :: uu___10 in + let binders1 = + FStarC_Syntax_Subst.close_binders binders in + mk + (FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 = binders1; + FStarC_Syntax_Syntax.comp = + effect_marker + }) in + let uu___9 = + recheck_debug + "turned into the effect signature" env2 + effect_signature in + let sigelts = FStarC_Compiler_Util.mk_ref [] in + let mk_lid name = + FStarC_Syntax_Util.dm4f_lid ed name in + let elaborate_and_star dmff_env1 + other_binders item = + let env3 = get_env dmff_env1 in + let uu___10 = item in + match uu___10 with + | (u_item, item1) -> + let uu___11 = + open_and_check env3 other_binders + item1 in + (match uu___11 with + | (item2, item_comp) -> + ((let uu___13 = + let uu___14 = + FStarC_TypeChecker_Common.is_total_lcomp + item_comp in + Prims.op_Negation uu___14 in + if uu___13 + then + let uu___14 = + let uu___15 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + item2 in + let uu___16 = + FStarC_TypeChecker_Common.lcomp_to_string + item_comp in + FStarC_Compiler_Util.format2 + "Computation for [%s] is not total : %s !" + uu___15 uu___16 in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_ComputationNotTotal + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___14) + else ()); + (let uu___13 = + star_expr dmff_env1 item2 in + match uu___13 with + | (item_t, item_wp, item_elab) + -> + let uu___14 = + recheck_debug "*" env3 + item_wp in + let uu___15 = + recheck_debug "_" env3 + item_elab in + (dmff_env1, item_t, item_wp, + item_elab)))) in + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Syntax_Util.get_bind_repr ed in + FStarC_Compiler_Util.must uu___12 in + elaborate_and_star dmff_env [] uu___11 in + match uu___10 with + | (dmff_env1, uu___11, bind_wp, bind_elab) -> + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_Syntax_Util.get_return_repr + ed in + FStarC_Compiler_Util.must uu___14 in + elaborate_and_star dmff_env1 [] uu___13 in + (match uu___12 with + | (dmff_env2, uu___13, return_wp, + return_elab) -> + let rc_gtot = + { + FStarC_Syntax_Syntax.residual_effect + = + FStarC_Parser_Const.effect_GTot_lid; + FStarC_Syntax_Syntax.residual_typ + = FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.residual_flags + = [] + } in + let lift_from_pure_wp = + let uu___14 = + let uu___15 = + FStarC_Syntax_Subst.compress + return_wp in + uu___15.FStarC_Syntax_Syntax.n in + match uu___14 with + | FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs = + b1::b2::bs; + FStarC_Syntax_Syntax.body = + body; + FStarC_Syntax_Syntax.rc_opt + = what;_} + -> + let uu___15 = + let uu___16 = + let uu___17 = + FStarC_Syntax_Util.abs + bs body + FStar_Pervasives_Native.None in + FStarC_Syntax_Subst.open_term + [b1; b2] uu___17 in + match uu___16 with + | (b11::b21::[], body1) -> + (b11, b21, body1) + | uu___17 -> + failwith + "Impossible : open_term not preserving binders arity" in + (match uu___15 with + | (b11, b21, body1) -> + let env0 = + let uu___16 = + get_env dmff_env2 in + FStarC_TypeChecker_Env.push_binders + uu___16 [b11; b21] in + let wp_b1 = + let raw_wp_b1 = + let uu___16 = + let uu___17 = + let uu___18 = + let uu___19 = + let uu___20 = + FStarC_Syntax_Syntax.bv_to_name + b11.FStarC_Syntax_Syntax.binder_bv in + let uu___21 = + FStarC_Syntax_Syntax.as_aqual_implicit + false in + (uu___20, + uu___21) in + [uu___19] in + { + FStarC_Syntax_Syntax.hd + = wp_type; + FStarC_Syntax_Syntax.args + = uu___18 + } in + FStarC_Syntax_Syntax.Tm_app + uu___17 in + mk uu___16 in + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Beta] + env0 raw_wp_b1 in + let uu___16 = + let uu___17 = + let uu___18 = + FStarC_Syntax_Util.unascribe + wp_b1 in + FStarC_TypeChecker_Normalize.eta_expand_with_type + env0 body1 uu___18 in + FStarC_Syntax_Util.abs_formals + uu___17 in + (match uu___16 with + | (bs1, body2, what') -> + let fail uu___17 = + let error_msg = + let uu___18 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + body2 in + let uu___19 = + match what' + with + | FStar_Pervasives_Native.None + -> "None" + | FStar_Pervasives_Native.Some + rc -> + FStarC_Ident.string_of_lid + rc.FStarC_Syntax_Syntax.residual_effect in + FStarC_Compiler_Util.format2 + "The body of return_wp (%s) should be of type Type0 but is of type %s" + uu___18 + uu___19 in + raise_error + FStarC_Errors_Codes.Fatal_WrongBodyTypeForReturnWP + error_msg in + ((match what' with + | FStar_Pervasives_Native.None + -> fail () + | FStar_Pervasives_Native.Some + rc -> + ((let uu___19 + = + let uu___20 + = + FStarC_Syntax_Util.is_pure_effect + rc.FStarC_Syntax_Syntax.residual_effect in + Prims.op_Negation + uu___20 in + if uu___19 + then fail () + else ()); + (let uu___19 + = + FStarC_Compiler_Util.map_opt + rc.FStarC_Syntax_Syntax.residual_typ + (fun rt + -> + let g_opt + = + FStarC_TypeChecker_Rel.try_teq + true env2 + rt + FStarC_Syntax_Util.ktype0 in + match g_opt + with + | + FStar_Pervasives_Native.Some + g' -> + FStarC_TypeChecker_Rel.force_trivial_guard + env2 g' + | + FStar_Pervasives_Native.None + -> + fail ()) in + ()))); + (let wp = + let t2 = + (b21.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + let pure_wp_type + = + double_star t2 in + FStarC_Syntax_Syntax.gen_bv + "wp" + FStar_Pervasives_Native.None + pure_wp_type in + let body3 = + let uu___18 = + FStarC_Syntax_Syntax.bv_to_name + wp in + let uu___19 = + let uu___20 = + let uu___21 + = + FStarC_Syntax_Util.abs + [b21] + body2 + what' in + (uu___21, + FStar_Pervasives_Native.None) in + [uu___20] in + FStarC_Syntax_Syntax.mk_Tm_app + uu___18 + uu___19 + ed_range in + let uu___18 = + let uu___19 = + let uu___20 = + FStarC_Syntax_Syntax.mk_binder + wp in + [uu___20] in + b11 :: uu___19 in + let uu___19 = + FStarC_Syntax_Util.abs + bs1 body3 what in + FStarC_Syntax_Util.abs + uu___18 uu___19 + (FStar_Pervasives_Native.Some + rc_gtot))))) + | uu___15 -> + raise_error + FStarC_Errors_Codes.Fatal_UnexpectedReturnShape + "unexpected shape for return" in + let return_wp1 = + let uu___14 = + let uu___15 = + FStarC_Syntax_Subst.compress + return_wp in + uu___15.FStarC_Syntax_Syntax.n in + match uu___14 with + | FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs = + b1::b2::bs; + FStarC_Syntax_Syntax.body = + body; + FStarC_Syntax_Syntax.rc_opt + = what;_} + -> + let uu___15 = + FStarC_Syntax_Util.abs bs + body what in + FStarC_Syntax_Util.abs + [b1; b2] uu___15 + (FStar_Pervasives_Native.Some + rc_gtot) + | uu___15 -> + raise_error + FStarC_Errors_Codes.Fatal_UnexpectedReturnShape + "unexpected shape for return" in + let bind_wp1 = + let uu___14 = + let uu___15 = + FStarC_Syntax_Subst.compress + bind_wp in + uu___15.FStarC_Syntax_Syntax.n in + match uu___14 with + | FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs = + binders; + FStarC_Syntax_Syntax.body = + body; + FStarC_Syntax_Syntax.rc_opt + = what;_} + -> + FStarC_Syntax_Util.abs binders + body what + | uu___15 -> + raise_error + FStarC_Errors_Codes.Fatal_UnexpectedBindShape + "unexpected shape for bind" in + let apply_close t = + if + (FStarC_Compiler_List.length + effect_binders1) + = Prims.int_zero + then t + else + (let uu___15 = + let uu___16 = + let uu___17 = + let uu___18 = + let uu___19 = + FStarC_Syntax_Util.args_of_binders + effect_binders1 in + FStar_Pervasives_Native.snd + uu___19 in + { + FStarC_Syntax_Syntax.hd + = t; + FStarC_Syntax_Syntax.args + = uu___18 + } in + FStarC_Syntax_Syntax.Tm_app + uu___17 in + mk uu___16 in + FStarC_Syntax_Subst.close + effect_binders1 uu___15) in + let rec apply_last f l = + match l with + | [] -> + failwith + "impossible: empty path.." + | a2::[] -> + let uu___14 = f a2 in + [uu___14] + | x::xs -> + let uu___14 = apply_last f xs in + x :: uu___14 in + let register maybe_admit name item = + let maybe_admit1 = true in + let p = + FStarC_Ident.path_of_lid + ed.FStarC_Syntax_Syntax.mname in + let p' = + apply_last + (fun s -> + Prims.strcat "__" + (Prims.strcat s + (Prims.strcat + "_eff_override_" + name))) p in + let l' = + FStarC_Ident.lid_of_path p' + ed_range in + let uu___14 = + FStarC_TypeChecker_Env.try_lookup_lid + env2 l' in + match uu___14 with + | FStar_Pervasives_Native.Some + (_us, _t) -> + ((let uu___16 = + FStarC_Compiler_Debug.any + () in + if uu___16 + then + let uu___17 = + FStarC_Ident.string_of_lid + l' in + FStarC_Compiler_Util.print1 + "DM4F: Applying override %s\n" + uu___17 + else ()); + (let uu___16 = + FStarC_Syntax_Syntax.lid_and_dd_as_fv + l' + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm + uu___16)) + | FStar_Pervasives_Native.None -> + let uu___15 = + let uu___16 = mk_lid name in + let uu___17 = + FStarC_Syntax_Util.abs + effect_binders1 item + FStar_Pervasives_Native.None in + mk_toplevel_definition env2 + uu___16 uu___17 in + (match uu___15 with + | (sigelt, fv) -> + let sigelt1 = + if maybe_admit1 + then + { + FStarC_Syntax_Syntax.sigel + = + (sigelt.FStarC_Syntax_Syntax.sigel); + FStarC_Syntax_Syntax.sigrng + = + (sigelt.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals + = + (sigelt.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta + = + (let uu___16 = + sigelt.FStarC_Syntax_Syntax.sigmeta in + { + FStarC_Syntax_Syntax.sigmeta_active + = + (uu___16.FStarC_Syntax_Syntax.sigmeta_active); + FStarC_Syntax_Syntax.sigmeta_fact_db_ids + = + (uu___16.FStarC_Syntax_Syntax.sigmeta_fact_db_ids); + FStarC_Syntax_Syntax.sigmeta_admit + = true; + FStarC_Syntax_Syntax.sigmeta_spliced + = + (uu___16.FStarC_Syntax_Syntax.sigmeta_spliced); + FStarC_Syntax_Syntax.sigmeta_already_checked + = + (uu___16.FStarC_Syntax_Syntax.sigmeta_already_checked); + FStarC_Syntax_Syntax.sigmeta_extension_data + = + (uu___16.FStarC_Syntax_Syntax.sigmeta_extension_data) + }); + FStarC_Syntax_Syntax.sigattrs + = + (sigelt.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = + (sigelt.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts + = + (sigelt.FStarC_Syntax_Syntax.sigopts) + } + else sigelt in + ((let uu___17 = + let uu___18 = + FStarC_Compiler_Effect.op_Bang + sigelts in + sigelt1 :: uu___18 in + FStarC_Compiler_Effect.op_Colon_Equals + sigelts uu___17); + fv)) in + let register_admit = register true in + let register1 = register false in + let lift_from_pure_wp1 = + register1 "lift_from_pure" + lift_from_pure_wp in + let mk_sigelt se = + let uu___14 = + FStarC_Syntax_Syntax.mk_sigelt + se in + { + FStarC_Syntax_Syntax.sigel = + (uu___14.FStarC_Syntax_Syntax.sigel); + FStarC_Syntax_Syntax.sigrng = + ed_range; + FStarC_Syntax_Syntax.sigquals = + (uu___14.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (uu___14.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (uu___14.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = + (uu___14.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (uu___14.FStarC_Syntax_Syntax.sigopts) + } in + let return_wp2 = + register1 "return_wp" return_wp1 in + let return_elab1 = + register_admit "return_elab" + return_elab in + let bind_wp2 = + register1 "bind_wp" bind_wp1 in + let bind_elab1 = + register_admit "bind_elab" + bind_elab in + let uu___14 = + FStarC_Compiler_List.fold_left + (fun uu___15 -> + fun action -> + match uu___15 with + | (dmff_env3, actions) -> + let params_un = + FStarC_Syntax_Subst.open_binders + action.FStarC_Syntax_Syntax.action_params in + let uu___16 = + let uu___17 = + get_env dmff_env3 in + FStarC_TypeChecker_TcTerm.tc_tparams + uu___17 params_un in + (match uu___16 with + | (action_params, + env', uu___17) -> + let action_params1 + = + FStarC_Compiler_List.map + (fun b -> + let uu___18 + = + let uu___19 + = + b.FStarC_Syntax_Syntax.binder_bv in + let uu___20 + = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.EraseUniverses] + env' + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + { + FStarC_Syntax_Syntax.ppname + = + (uu___19.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index + = + (uu___19.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort + = uu___20 + } in + { + FStarC_Syntax_Syntax.binder_bv + = uu___18; + FStarC_Syntax_Syntax.binder_qual + = + (b.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity + = + (b.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs + = + (b.FStarC_Syntax_Syntax.binder_attrs) + }) + action_params in + let dmff_env' = + set_env + dmff_env3 env' in + let uu___18 = + elaborate_and_star + dmff_env' + action_params1 + ((action.FStarC_Syntax_Syntax.action_univs), + (action.FStarC_Syntax_Syntax.action_defn)) in + (match uu___18 + with + | (dmff_env4, + action_t, + action_wp, + action_elab) + -> + let name = + let uu___19 + = + FStarC_Ident.ident_of_lid + action.FStarC_Syntax_Syntax.action_name in + FStarC_Ident.string_of_id + uu___19 in + let action_typ_with_wp + = + trans_F + dmff_env' + action_t + action_wp in + let action_params2 + = + FStarC_Syntax_Subst.close_binders + action_params1 in + let action_elab1 + = + FStarC_Syntax_Subst.close + action_params2 + action_elab in + let action_typ_with_wp1 + = + FStarC_Syntax_Subst.close + action_params2 + action_typ_with_wp in + let action_elab2 + = + FStarC_Syntax_Util.abs + action_params2 + action_elab1 + FStar_Pervasives_Native.None in + let action_typ_with_wp2 + = + match action_params2 + with + | [] -> + action_typ_with_wp1 + | uu___19 + -> + let uu___20 + = + FStarC_Syntax_Syntax.mk_Total + action_typ_with_wp1 in + FStarC_Syntax_Util.flat_arrow + action_params2 + uu___20 in + ((let uu___20 + = + FStarC_Compiler_Effect.op_Bang + dbg in + if uu___20 + then + let uu___21 + = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binder) + params_un in + let uu___22 + = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binder) + action_params2 in + let uu___23 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + action_typ_with_wp2 in + let uu___24 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + action_elab2 in + FStarC_Compiler_Util.print4 + "original action_params %s, end action_params %s, type %s, term %s\n" + uu___21 + uu___22 + uu___23 + uu___24 + else ()); + (let action_elab3 + = + register1 + (Prims.strcat + name + "_elab") + action_elab2 in + let action_typ_with_wp3 + = + register1 + (Prims.strcat + name + "_complete_type") + action_typ_with_wp2 in + let uu___20 + = + let uu___21 + = + let uu___22 + = + apply_close + action_elab3 in + let uu___23 + = + apply_close + action_typ_with_wp3 in + { + FStarC_Syntax_Syntax.action_name + = + (action.FStarC_Syntax_Syntax.action_name); + FStarC_Syntax_Syntax.action_unqualified_name + = + (action.FStarC_Syntax_Syntax.action_unqualified_name); + FStarC_Syntax_Syntax.action_univs + = + (action.FStarC_Syntax_Syntax.action_univs); + FStarC_Syntax_Syntax.action_params + = []; + FStarC_Syntax_Syntax.action_defn + = uu___22; + FStarC_Syntax_Syntax.action_typ + = uu___23 + } in + uu___21 + :: + actions in + (dmff_env4, + uu___20)))))) + (dmff_env2, []) + ed.FStarC_Syntax_Syntax.actions in + (match uu___14 with + | (dmff_env3, actions) -> + let actions1 = + FStarC_Compiler_List.rev + actions in + let repr1 = + let wp = + FStarC_Syntax_Syntax.gen_bv + "wp_a" + FStar_Pervasives_Native.None + wp_a in + let binders = + let uu___15 = + FStarC_Syntax_Syntax.mk_binder + a1 in + let uu___16 = + let uu___17 = + FStarC_Syntax_Syntax.mk_binder + wp in + [uu___17] in + uu___15 :: uu___16 in + let uu___15 = + let uu___16 = + let uu___17 = + let uu___18 = + let uu___19 = + let uu___20 = + let uu___21 = + FStarC_Syntax_Syntax.bv_to_name + a1 in + let uu___22 = + FStarC_Syntax_Syntax.as_aqual_implicit + false in + (uu___21, + uu___22) in + [uu___20] in + { + FStarC_Syntax_Syntax.hd + = repr; + FStarC_Syntax_Syntax.args + = uu___19 + } in + FStarC_Syntax_Syntax.Tm_app + uu___18 in + mk uu___17 in + let uu___17 = + FStarC_Syntax_Syntax.bv_to_name + wp in + trans_F dmff_env3 uu___16 + uu___17 in + FStarC_Syntax_Util.abs + binders uu___15 + FStar_Pervasives_Native.None in + let uu___15 = + recheck_debug "FC" env2 repr1 in + let repr2 = + register1 "repr" repr1 in + let uu___16 = + let uu___17 = + let uu___18 = + let uu___19 = + FStarC_Syntax_Subst.compress + wp_type in + FStarC_Syntax_Util.unascribe + uu___19 in + uu___18.FStarC_Syntax_Syntax.n in + match uu___17 with + | FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs + = + type_param::effect_param; + FStarC_Syntax_Syntax.body + = arrow; + FStarC_Syntax_Syntax.rc_opt + = uu___18;_} + -> + let uu___19 = + let uu___20 = + FStarC_Syntax_Subst.open_term + (type_param :: + effect_param) arrow in + match uu___20 with + | (b::bs, body) -> + (b, bs, body) + | uu___21 -> + failwith + "Impossible : open_term nt preserving binders arity" in + (match uu___19 with + | (type_param1, + effect_param1, + arrow1) -> + let uu___20 = + let uu___21 = + let uu___22 = + FStarC_Syntax_Subst.compress + arrow1 in + FStarC_Syntax_Util.unascribe + uu___22 in + uu___21.FStarC_Syntax_Syntax.n in + (match uu___20 with + | FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 + = + wp_binders; + FStarC_Syntax_Syntax.comp + = c;_} + -> + let uu___21 = + FStarC_Syntax_Subst.open_comp + wp_binders + c in + (match uu___21 + with + | (wp_binders1, + c1) -> + let uu___22 + = + FStarC_Compiler_List.partition + (fun + uu___23 + -> + match uu___23 + with + | + { + FStarC_Syntax_Syntax.binder_bv + = bv; + FStarC_Syntax_Syntax.binder_qual + = uu___24; + FStarC_Syntax_Syntax.binder_positivity + = uu___25; + FStarC_Syntax_Syntax.binder_attrs + = uu___26;_} + -> + let uu___27 + = + let uu___28 + = + FStarC_Syntax_Free.names + bv.FStarC_Syntax_Syntax.sort in + FStarC_Class_Setlike.mem + () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) + type_param1.FStarC_Syntax_Syntax.binder_bv + (Obj.magic + uu___28) in + Prims.op_Negation + uu___27) + wp_binders1 in + (match uu___22 + with + | + (pre_args, + post_args) + -> + let post + = + match post_args + with + | + post1::[] + -> post1 + | + [] -> + let err_msg + = + let uu___23 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + arrow1 in + FStarC_Compiler_Util.format1 + "Impossible to generate DM effect: no post candidate %s (Type variable does not appear)" + uu___23 in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_ImpossibleToGenerateDMEffect + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + err_msg) + | + uu___23 + -> + let err_msg + = + let uu___24 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + arrow1 in + FStarC_Compiler_Util.format1 + "Impossible to generate DM effect: multiple post candidates %s" + uu___24 in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_ImpossibleToGenerateDMEffect + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + err_msg) in + let uu___23 + = + FStarC_Syntax_Util.arrow + pre_args + c1 in + let uu___24 + = + FStarC_Syntax_Util.abs + (type_param1 + :: + effect_param1) + (post.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort + FStar_Pervasives_Native.None in + (uu___23, + uu___24))) + | uu___21 -> + let uu___22 = + let uu___23 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + arrow1 in + FStarC_Compiler_Util.format1 + "Impossible: pre/post arrow %s" + uu___23 in + raise_error + FStarC_Errors_Codes.Fatal_ImpossiblePrePostArrow + uu___22)) + | uu___18 -> + let uu___19 = + let uu___20 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + wp_type in + FStarC_Compiler_Util.format1 + "Impossible: pre/post abs %s" + uu___20 in + raise_error + FStarC_Errors_Codes.Fatal_ImpossiblePrePostAbs + uu___19 in + (match uu___16 with + | (pre, post) -> + ((let uu___18 = + register1 "pre" pre in + ()); + (let uu___19 = + register1 "post" post in + ()); + (let uu___20 = + register1 "wp" wp_type in + ()); + (let ed_combs = + match ed.FStarC_Syntax_Syntax.combinators + with + | FStarC_Syntax_Syntax.DM4F_eff + combs -> + let uu___20 = + let uu___21 = + let uu___22 = + apply_close + return_wp2 in + ([], uu___22) in + let uu___22 = + let uu___23 = + apply_close + bind_wp2 in + ([], uu___23) in + let uu___23 = + let uu___24 = + let uu___25 + = + apply_close + repr2 in + ([], + uu___25) in + FStar_Pervasives_Native.Some + uu___24 in + let uu___24 = + let uu___25 = + let uu___26 + = + apply_close + return_elab1 in + ([], + uu___26) in + FStar_Pervasives_Native.Some + uu___25 in + let uu___25 = + let uu___26 = + let uu___27 + = + apply_close + bind_elab1 in + ([], + uu___27) in + FStar_Pervasives_Native.Some + uu___26 in + { + FStarC_Syntax_Syntax.ret_wp + = uu___21; + FStarC_Syntax_Syntax.bind_wp + = uu___22; + FStarC_Syntax_Syntax.stronger + = + (combs.FStarC_Syntax_Syntax.stronger); + FStarC_Syntax_Syntax.if_then_else + = + (combs.FStarC_Syntax_Syntax.if_then_else); + FStarC_Syntax_Syntax.ite_wp + = + (combs.FStarC_Syntax_Syntax.ite_wp); + FStarC_Syntax_Syntax.close_wp + = + (combs.FStarC_Syntax_Syntax.close_wp); + FStarC_Syntax_Syntax.trivial + = + (combs.FStarC_Syntax_Syntax.trivial); + FStarC_Syntax_Syntax.repr + = uu___23; + FStarC_Syntax_Syntax.return_repr + = uu___24; + FStarC_Syntax_Syntax.bind_repr + = uu___25 + } in + FStarC_Syntax_Syntax.DM4F_eff + uu___20 + | uu___20 -> + failwith + "Impossible! For a DM4F effect combinators must be in DM4f_eff" in + let ed1 = + let uu___20 = + FStarC_Syntax_Subst.close_binders + effect_binders1 in + let uu___21 = + let uu___22 = + let uu___23 = + FStarC_Syntax_Subst.close + effect_binders1 + effect_signature in + ([], uu___23) in + FStarC_Syntax_Syntax.WP_eff_sig + uu___22 in + { + FStarC_Syntax_Syntax.mname + = + (ed.FStarC_Syntax_Syntax.mname); + FStarC_Syntax_Syntax.cattributes + = + (ed.FStarC_Syntax_Syntax.cattributes); + FStarC_Syntax_Syntax.univs + = + (ed.FStarC_Syntax_Syntax.univs); + FStarC_Syntax_Syntax.binders + = uu___20; + FStarC_Syntax_Syntax.signature + = uu___21; + FStarC_Syntax_Syntax.combinators + = ed_combs; + FStarC_Syntax_Syntax.actions + = actions1; + FStarC_Syntax_Syntax.eff_attrs + = + (ed.FStarC_Syntax_Syntax.eff_attrs); + FStarC_Syntax_Syntax.extraction_mode + = + (ed.FStarC_Syntax_Syntax.extraction_mode) + } in + let uu___20 = + gen_wps_for_free env2 + effect_binders1 a1 + wp_a ed1 in + match uu___20 with + | (sigelts', ed2) -> + ((let uu___22 = + FStarC_Compiler_Effect.op_Bang + dbg in + if uu___22 + then + let uu___23 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_eff_decl + ed2 in + FStarC_Compiler_Util.print_string + uu___23 + else ()); + (let lift_from_pure_opt + = + if + (FStarC_Compiler_List.length + effect_binders1) + = + Prims.int_zero + then + let lift_from_pure + = + let uu___22 + = + let uu___23 + = + let uu___24 + = + apply_close + lift_from_pure_wp1 in + ([], + uu___24) in + FStar_Pervasives_Native.Some + uu___23 in + { + FStarC_Syntax_Syntax.source + = + FStarC_Parser_Const.effect_PURE_lid; + FStarC_Syntax_Syntax.target + = + (ed2.FStarC_Syntax_Syntax.mname); + FStarC_Syntax_Syntax.lift_wp + = uu___22; + FStarC_Syntax_Syntax.lift + = + FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.kind + = + FStar_Pervasives_Native.None + } in + let uu___22 = + mk_sigelt + (FStarC_Syntax_Syntax.Sig_sub_effect + lift_from_pure) in + FStar_Pervasives_Native.Some + uu___22 + else + FStar_Pervasives_Native.None in + let uu___22 = + let uu___23 = + let uu___24 = + FStarC_Compiler_Effect.op_Bang + sigelts in + FStarC_Compiler_List.rev + uu___24 in + FStarC_Compiler_List.op_At + uu___23 + sigelts' in + (uu___22, ed2, + lift_from_pure_opt)))))))))))))) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_DeferredImplicits.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_DeferredImplicits.ml new file mode 100644 index 00000000000..cce680972df --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_DeferredImplicits.ml @@ -0,0 +1,780 @@ +open Prims +let (is_flex : FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t -> + let uu___ = FStarC_Syntax_Util.head_and_args_full t in + match uu___ with + | (head, _args) -> + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress head in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_uvar uu___2 -> true + | uu___2 -> false) +let (flex_uvar_head : + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.ctx_uvar) = + fun t -> + let uu___ = FStarC_Syntax_Util.head_and_args_full t in + match uu___ with + | (head, _args) -> + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress head in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_uvar (u, uu___2) -> u + | uu___2 -> failwith "Not a flex-uvar") +type goal_type = + | FlexRigid of (FStarC_Syntax_Syntax.ctx_uvar * FStarC_Syntax_Syntax.term) + + | FlexFlex of (FStarC_Syntax_Syntax.ctx_uvar * + FStarC_Syntax_Syntax.ctx_uvar) + | Can_be_split_into of (FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.ctx_uvar) + | Imp of FStarC_Syntax_Syntax.ctx_uvar +let (uu___is_FlexRigid : goal_type -> Prims.bool) = + fun projectee -> + match projectee with | FlexRigid _0 -> true | uu___ -> false +let (__proj__FlexRigid__item___0 : + goal_type -> (FStarC_Syntax_Syntax.ctx_uvar * FStarC_Syntax_Syntax.term)) = + fun projectee -> match projectee with | FlexRigid _0 -> _0 +let (uu___is_FlexFlex : goal_type -> Prims.bool) = + fun projectee -> + match projectee with | FlexFlex _0 -> true | uu___ -> false +let (__proj__FlexFlex__item___0 : + goal_type -> + (FStarC_Syntax_Syntax.ctx_uvar * FStarC_Syntax_Syntax.ctx_uvar)) + = fun projectee -> match projectee with | FlexFlex _0 -> _0 +let (uu___is_Can_be_split_into : goal_type -> Prims.bool) = + fun projectee -> + match projectee with | Can_be_split_into _0 -> true | uu___ -> false +let (__proj__Can_be_split_into__item___0 : + goal_type -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.ctx_uvar)) + = fun projectee -> match projectee with | Can_be_split_into _0 -> _0 +let (uu___is_Imp : goal_type -> Prims.bool) = + fun projectee -> match projectee with | Imp _0 -> true | uu___ -> false +let (__proj__Imp__item___0 : goal_type -> FStarC_Syntax_Syntax.ctx_uvar) = + fun projectee -> match projectee with | Imp _0 -> _0 +let (find_user_tac_for_uvar : + FStarC_TypeChecker_Env.env_t -> + FStarC_Syntax_Syntax.ctx_uvar -> + FStarC_Syntax_Syntax.sigelt FStar_Pervasives_Native.option) + = + fun env -> + fun u -> + let rec attr_list_elements e = + let uu___ = + let uu___1 = FStarC_Syntax_Util.unmeta e in + FStarC_Syntax_Util.head_and_args uu___1 in + match uu___ with + | (head, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst head in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, uu___2) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.nil_lid + -> FStar_Pervasives_Native.Some [] + | (FStarC_Syntax_Syntax.Tm_fvar fv, + uu___2::(hd, uu___3)::(tl, uu___4)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.cons_lid + -> + (match hd.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_string (s, uu___5)) -> + let uu___6 = attr_list_elements tl in + (match uu___6 with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some tl1 -> + FStar_Pervasives_Native.Some (s :: tl1)) + | uu___5 -> FStar_Pervasives_Native.None) + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (hd, uu___2)::(tl, uu___3)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.cons_lid + -> + (match hd.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_string (s, uu___4)) -> + let uu___5 = attr_list_elements tl in + (match uu___5 with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some tl1 -> + FStar_Pervasives_Native.Some (s :: tl1)) + | uu___4 -> FStar_Pervasives_Native.None) + | uu___2 -> FStar_Pervasives_Native.None) in + let candidate_names candidates = + let uu___ = + let uu___1 = + FStarC_Compiler_List.collect FStarC_Syntax_Util.lids_of_sigelt + candidates in + FStarC_Compiler_List.map FStarC_Ident.string_of_lid uu___1 in + FStarC_Compiler_String.concat ", " uu___ in + match u.FStarC_Syntax_Syntax.ctx_uvar_meta with + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Ctx_uvar_meta_attr + a) -> + let hooks = + FStarC_TypeChecker_Env.lookup_attr env + FStarC_Parser_Const.resolve_implicits_attr_string in + let candidates = + FStarC_Compiler_List.filter + (fun hook -> + FStarC_Compiler_Util.for_some + (FStarC_TypeChecker_TermEqAndSimplify.eq_tm_bool env a) + hook.FStarC_Syntax_Syntax.sigattrs) hooks in + let candidates1 = + FStarC_Compiler_Util.remove_dups + (fun s0 -> + fun s1 -> + let l0 = FStarC_Syntax_Util.lids_of_sigelt s0 in + let l1 = FStarC_Syntax_Util.lids_of_sigelt s1 in + if + (FStarC_Compiler_List.length l0) = + (FStarC_Compiler_List.length l1) + then + FStarC_Compiler_List.forall2 + (fun l01 -> fun l11 -> FStarC_Ident.lid_equals l01 l11) + l0 l1 + else false) candidates in + let is_overridden candidate = + let candidate_lids = FStarC_Syntax_Util.lids_of_sigelt candidate in + FStarC_Compiler_Util.for_some + (fun other -> + FStarC_Compiler_Util.for_some + (fun attr -> + let uu___ = FStarC_Syntax_Util.head_and_args attr in + match uu___ with + | (head, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst head in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, + uu___2::(a', uu___3)::(overrides, uu___4)::[]) + when + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.override_resolve_implicits_handler_lid) + && + (FStarC_TypeChecker_TermEqAndSimplify.eq_tm_bool + env a a') + -> + let uu___5 = attr_list_elements overrides in + (match uu___5 with + | FStar_Pervasives_Native.None -> false + | FStar_Pervasives_Native.Some names -> + FStarC_Compiler_Util.for_some + (fun n -> + FStarC_Compiler_Util.for_some + (fun l -> + let uu___6 = + FStarC_Ident.string_of_lid l in + uu___6 = n) candidate_lids) + names) + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (a', uu___2)::(overrides, uu___3)::[]) when + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.override_resolve_implicits_handler_lid) + && + (FStarC_TypeChecker_TermEqAndSimplify.eq_tm_bool + env a a') + -> + let uu___4 = attr_list_elements overrides in + (match uu___4 with + | FStar_Pervasives_Native.None -> false + | FStar_Pervasives_Native.Some names -> + FStarC_Compiler_Util.for_some + (fun n -> + FStarC_Compiler_Util.for_some + (fun l -> + let uu___5 = + FStarC_Ident.string_of_lid l in + uu___5 = n) candidate_lids) + names) + | uu___2 -> false)) + other.FStarC_Syntax_Syntax.sigattrs) candidates1 in + let candidates2 = + FStarC_Compiler_List.filter + (fun c -> + let uu___ = is_overridden c in Prims.op_Negation uu___) + candidates1 in + (match candidates2 with + | [] -> FStar_Pervasives_Native.None + | c::[] -> FStar_Pervasives_Native.Some c + | uu___ -> + let candidates3 = candidate_names candidates2 in + let attr = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term a in + ((let uu___2 = + FStarC_Compiler_Util.format2 + "Multiple resolve_implicits hooks are eligible for attribute %s; \nplease resolve the ambiguity by using the `override_resolve_implicits_handler` attribute to choose among these candidates {%s}" + attr candidates3 in + FStarC_Errors.log_issue FStarC_Class_HasRange.hasRange_range + u.FStarC_Syntax_Syntax.ctx_uvar_range + FStarC_Errors_Codes.Warning_AmbiguousResolveImplicitsHook + () (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None)) + | uu___ -> FStar_Pervasives_Native.None +let (should_defer_uvar_to_user_tac : + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.ctx_uvar -> Prims.bool) + = + fun env -> + fun u -> + if Prims.op_Negation env.FStarC_TypeChecker_Env.enable_defer_to_tac + then false + else + (let uu___1 = find_user_tac_for_uvar env u in + FStar_Pervasives_Native.uu___is_Some uu___1) +let solve_goals_with_tac : + 'uuuuu . + FStarC_TypeChecker_Env.env -> + 'uuuuu -> + FStarC_TypeChecker_Common.implicits -> + FStarC_Syntax_Syntax.sigelt -> unit + = + fun env -> + fun g -> + fun deferred_goals -> + fun tac -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_Env.current_module env in + FStarC_Ident.string_of_lid uu___2 in + FStar_Pervasives_Native.Some uu___1 in + FStarC_Profiling.profile + (fun uu___1 -> + let resolve_tac = + match tac.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = uu___2; + FStarC_Syntax_Syntax.lids1 = lid::[];_} + -> + let qn = FStarC_TypeChecker_Env.lookup_qname env lid in + let fv = + FStarC_Syntax_Syntax.lid_as_fv lid + FStar_Pervasives_Native.None in + let term = + let uu___3 = + FStarC_Syntax_Syntax.lid_as_fv lid + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___3 in + term + | uu___2 -> failwith "Resolve_tac not found" in + let env1 = + { + FStarC_TypeChecker_Env.solver = + (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = false; + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env.FStarC_TypeChecker_Env.missing_decl) + } in + env1.FStarC_TypeChecker_Env.try_solve_implicits_hook env1 + resolve_tac deferred_goals) uu___ + "FStarC.TypeChecker.DeferredImplicits.solve_goals_with_tac" +let (solve_deferred_to_tactic_goals : + FStarC_TypeChecker_Env.env -> + FStarC_TypeChecker_Common.guard_t -> FStarC_TypeChecker_Common.guard_t) + = + fun env -> + fun g -> + if Prims.op_Negation env.FStarC_TypeChecker_Env.enable_defer_to_tac + then g + else + (let deferred = g.FStarC_TypeChecker_Common.deferred_to_tac in + let prob_as_implicit uu___1 = + match uu___1 with + | (uu___2, reason, prob) -> + (match prob with + | FStarC_TypeChecker_Common.TProb tp when + tp.FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.EQ + -> + let uu___3 = + FStarC_TypeChecker_Env.clear_expected_typ env in + (match uu___3 with + | (env1, uu___4) -> + let env2 = + { + FStarC_TypeChecker_Env.solver = + (env1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + ((tp.FStarC_TypeChecker_Common.logical_guard_uvar).FStarC_Syntax_Syntax.ctx_uvar_gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env1.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (env1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env1.FStarC_TypeChecker_Env.missing_decl) + } in + let env_lax = + { + FStarC_TypeChecker_Env.solver = + (env2.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env2.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env2.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env2.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env2.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env2.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env2.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env2.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env2.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env2.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env2.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env2.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env2.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env2.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env2.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env2.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env2.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env2.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = true; + FStarC_TypeChecker_Env.lax_universes = + (env2.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env2.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env2.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env2.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env2.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env2.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env2.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env2.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env2.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env2.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env2.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env2.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env2.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env2.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env2.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env2.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env2.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env2.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (env2.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env2.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env2.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env2.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env2.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env2.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env2.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env2.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env2.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env2.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + false; + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env2.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env2.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env2.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env2.FStarC_TypeChecker_Env.missing_decl) + } in + let uu___5 = + let t = + let uu___6 = + is_flex tp.FStarC_TypeChecker_Common.lhs in + if uu___6 + then tp.FStarC_TypeChecker_Common.lhs + else tp.FStarC_TypeChecker_Common.rhs in + env2.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + env_lax t true in + (match uu___5 with + | (uu___6, t_eq, uu___7) -> + let goal_ty = + let uu___8 = + env2.FStarC_TypeChecker_Env.universe_of + env_lax t_eq in + FStarC_Syntax_Util.mk_eq2 uu___8 t_eq + tp.FStarC_TypeChecker_Common.lhs + tp.FStarC_TypeChecker_Common.rhs in + let uu___8 = + FStarC_TypeChecker_Env.new_implicit_var_aux + reason + (tp.FStarC_TypeChecker_Common.lhs).FStarC_Syntax_Syntax.pos + env2 goal_ty FStarC_Syntax_Syntax.Strict + FStar_Pervasives_Native.None false in + (match uu___8 with + | (goal, ctx_uvar, uu___9) -> + let imp = + { + FStarC_TypeChecker_Common.imp_reason = + ""; + FStarC_TypeChecker_Common.imp_uvar = + (FStar_Pervasives_Native.fst + ctx_uvar); + FStarC_TypeChecker_Common.imp_tm = + goal; + FStarC_TypeChecker_Common.imp_range = + ((tp.FStarC_TypeChecker_Common.lhs).FStarC_Syntax_Syntax.pos) + } in + let sigelt = + let uu___10 = + is_flex + tp.FStarC_TypeChecker_Common.lhs in + if uu___10 + then + let uu___11 = + let uu___12 = + flex_uvar_head + tp.FStarC_TypeChecker_Common.lhs in + find_user_tac_for_uvar env2 uu___12 in + match uu___11 with + | FStar_Pervasives_Native.None -> + let uu___12 = + is_flex + tp.FStarC_TypeChecker_Common.rhs in + (if uu___12 + then + let uu___13 = + flex_uvar_head + tp.FStarC_TypeChecker_Common.rhs in + find_user_tac_for_uvar env2 + uu___13 + else FStar_Pervasives_Native.None) + | v -> v + else + (let uu___12 = + is_flex + tp.FStarC_TypeChecker_Common.rhs in + if uu___12 + then + let uu___13 = + flex_uvar_head + tp.FStarC_TypeChecker_Common.rhs in + find_user_tac_for_uvar env2 uu___13 + else FStar_Pervasives_Native.None) in + (match sigelt with + | FStar_Pervasives_Native.None -> + failwith + "Impossible: No tactic associated with deferred problem" + | FStar_Pervasives_Native.Some se -> + (imp, se))))) + | uu___3 -> failwith "Unexpected problem deferred to tactic") in + let eqs = + let uu___1 = + FStarC_Class_Listlike.to_list + (FStarC_Compiler_CList.listlike_clist ()) + g.FStarC_TypeChecker_Common.deferred_to_tac in + FStarC_Compiler_List.map prob_as_implicit uu___1 in + let uu___1 = + let uu___2 = + FStarC_Class_Listlike.to_list + (FStarC_Compiler_CList.listlike_clist ()) + g.FStarC_TypeChecker_Common.implicits in + FStarC_Compiler_List.fold_right + (fun imp -> + fun uu___3 -> + match uu___3 with + | (more, imps) -> + let uu___4 = + FStarC_Syntax_Unionfind.find + (imp.FStarC_TypeChecker_Common.imp_uvar).FStarC_Syntax_Syntax.ctx_uvar_head in + (match uu___4 with + | FStar_Pervasives_Native.Some uu___5 -> + (more, (imp :: imps)) + | FStar_Pervasives_Native.None -> + let se = + find_user_tac_for_uvar env + imp.FStarC_TypeChecker_Common.imp_uvar in + (match se with + | FStar_Pervasives_Native.None -> + (more, (imp :: imps)) + | FStar_Pervasives_Native.Some se1 -> + (((imp, se1) :: more), imps)))) uu___2 + ([], []) in + match uu___1 with + | (more, imps) -> + let bucketize is = + let map = FStarC_Compiler_Util.smap_create (Prims.of_int (17)) in + FStarC_Compiler_List.iter + (fun uu___3 -> + match uu___3 with + | (i, s) -> + let uu___4 = FStarC_Syntax_Util.lid_of_sigelt s in + (match uu___4 with + | FStar_Pervasives_Native.None -> + failwith "Unexpected: tactic without a name" + | FStar_Pervasives_Native.Some l -> + let lstr = FStarC_Ident.string_of_lid l in + let uu___5 = + FStarC_Compiler_Util.smap_try_find map lstr in + (match uu___5 with + | FStar_Pervasives_Native.None -> + FStarC_Compiler_Util.smap_add map lstr + ([i], s) + | FStar_Pervasives_Native.Some (is1, s1) -> + (FStarC_Compiler_Util.smap_remove map lstr; + FStarC_Compiler_Util.smap_add map lstr + ((i :: is1), s1))))) is; + FStarC_Compiler_Util.smap_fold map + (fun uu___3 -> fun is1 -> fun out -> is1 :: out) [] in + let buckets = bucketize (FStarC_Compiler_List.op_At eqs more) in + (FStarC_Compiler_List.iter + (fun uu___3 -> + match uu___3 with + | (imps1, sigel) -> solve_goals_with_tac env g imps1 sigel) + buckets; + (let uu___3 = + FStarC_Class_Listlike.from_list + (FStarC_Compiler_CList.listlike_clist ()) imps in + { + FStarC_TypeChecker_Common.guard_f = + (g.FStarC_TypeChecker_Common.guard_f); + FStarC_TypeChecker_Common.deferred_to_tac = + (Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic (FStarC_Compiler_CList.listlike_clist ())))); + FStarC_TypeChecker_Common.deferred = + (g.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (g.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = uu___3 + }))) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_Env.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Env.ml new file mode 100644 index 00000000000..6ffc8427b59 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Env.ml @@ -0,0 +1,7499 @@ +open Prims +type step = + | Beta + | Iota + | Zeta + | ZetaFull + | Exclude of step + | Weak + | HNF + | Primops + | Eager_unfolding + | Inlining + | DoNotUnfoldPureLets + | UnfoldUntil of FStarC_Syntax_Syntax.delta_depth + | UnfoldOnly of FStarC_Ident.lid Prims.list + | UnfoldFully of FStarC_Ident.lid Prims.list + | UnfoldAttr of FStarC_Ident.lid Prims.list + | UnfoldQual of Prims.string Prims.list + | UnfoldNamespace of Prims.string Prims.list + | DontUnfoldAttr of FStarC_Ident.lid Prims.list + | PureSubtermsWithinComputations + | Simplify + | EraseUniverses + | AllowUnboundUniverses + | Reify + | CompressUvars + | NoFullNorm + | CheckNoUvars + | Unmeta + | Unascribe + | NBE + | ForExtraction + | Unrefine + | NormDebug + | DefaultUnivsToZero + | Tactics +let (uu___is_Beta : step -> Prims.bool) = + fun projectee -> match projectee with | Beta -> true | uu___ -> false +let (uu___is_Iota : step -> Prims.bool) = + fun projectee -> match projectee with | Iota -> true | uu___ -> false +let (uu___is_Zeta : step -> Prims.bool) = + fun projectee -> match projectee with | Zeta -> true | uu___ -> false +let (uu___is_ZetaFull : step -> Prims.bool) = + fun projectee -> match projectee with | ZetaFull -> true | uu___ -> false +let (uu___is_Exclude : step -> Prims.bool) = + fun projectee -> match projectee with | Exclude _0 -> true | uu___ -> false +let (__proj__Exclude__item___0 : step -> step) = + fun projectee -> match projectee with | Exclude _0 -> _0 +let (uu___is_Weak : step -> Prims.bool) = + fun projectee -> match projectee with | Weak -> true | uu___ -> false +let (uu___is_HNF : step -> Prims.bool) = + fun projectee -> match projectee with | HNF -> true | uu___ -> false +let (uu___is_Primops : step -> Prims.bool) = + fun projectee -> match projectee with | Primops -> true | uu___ -> false +let (uu___is_Eager_unfolding : step -> Prims.bool) = + fun projectee -> + match projectee with | Eager_unfolding -> true | uu___ -> false +let (uu___is_Inlining : step -> Prims.bool) = + fun projectee -> match projectee with | Inlining -> true | uu___ -> false +let (uu___is_DoNotUnfoldPureLets : step -> Prims.bool) = + fun projectee -> + match projectee with | DoNotUnfoldPureLets -> true | uu___ -> false +let (uu___is_UnfoldUntil : step -> Prims.bool) = + fun projectee -> + match projectee with | UnfoldUntil _0 -> true | uu___ -> false +let (__proj__UnfoldUntil__item___0 : + step -> FStarC_Syntax_Syntax.delta_depth) = + fun projectee -> match projectee with | UnfoldUntil _0 -> _0 +let (uu___is_UnfoldOnly : step -> Prims.bool) = + fun projectee -> + match projectee with | UnfoldOnly _0 -> true | uu___ -> false +let (__proj__UnfoldOnly__item___0 : step -> FStarC_Ident.lid Prims.list) = + fun projectee -> match projectee with | UnfoldOnly _0 -> _0 +let (uu___is_UnfoldFully : step -> Prims.bool) = + fun projectee -> + match projectee with | UnfoldFully _0 -> true | uu___ -> false +let (__proj__UnfoldFully__item___0 : step -> FStarC_Ident.lid Prims.list) = + fun projectee -> match projectee with | UnfoldFully _0 -> _0 +let (uu___is_UnfoldAttr : step -> Prims.bool) = + fun projectee -> + match projectee with | UnfoldAttr _0 -> true | uu___ -> false +let (__proj__UnfoldAttr__item___0 : step -> FStarC_Ident.lid Prims.list) = + fun projectee -> match projectee with | UnfoldAttr _0 -> _0 +let (uu___is_UnfoldQual : step -> Prims.bool) = + fun projectee -> + match projectee with | UnfoldQual _0 -> true | uu___ -> false +let (__proj__UnfoldQual__item___0 : step -> Prims.string Prims.list) = + fun projectee -> match projectee with | UnfoldQual _0 -> _0 +let (uu___is_UnfoldNamespace : step -> Prims.bool) = + fun projectee -> + match projectee with | UnfoldNamespace _0 -> true | uu___ -> false +let (__proj__UnfoldNamespace__item___0 : step -> Prims.string Prims.list) = + fun projectee -> match projectee with | UnfoldNamespace _0 -> _0 +let (uu___is_DontUnfoldAttr : step -> Prims.bool) = + fun projectee -> + match projectee with | DontUnfoldAttr _0 -> true | uu___ -> false +let (__proj__DontUnfoldAttr__item___0 : step -> FStarC_Ident.lid Prims.list) + = fun projectee -> match projectee with | DontUnfoldAttr _0 -> _0 +let (uu___is_PureSubtermsWithinComputations : step -> Prims.bool) = + fun projectee -> + match projectee with + | PureSubtermsWithinComputations -> true + | uu___ -> false +let (uu___is_Simplify : step -> Prims.bool) = + fun projectee -> match projectee with | Simplify -> true | uu___ -> false +let (uu___is_EraseUniverses : step -> Prims.bool) = + fun projectee -> + match projectee with | EraseUniverses -> true | uu___ -> false +let (uu___is_AllowUnboundUniverses : step -> Prims.bool) = + fun projectee -> + match projectee with | AllowUnboundUniverses -> true | uu___ -> false +let (uu___is_Reify : step -> Prims.bool) = + fun projectee -> match projectee with | Reify -> true | uu___ -> false +let (uu___is_CompressUvars : step -> Prims.bool) = + fun projectee -> + match projectee with | CompressUvars -> true | uu___ -> false +let (uu___is_NoFullNorm : step -> Prims.bool) = + fun projectee -> match projectee with | NoFullNorm -> true | uu___ -> false +let (uu___is_CheckNoUvars : step -> Prims.bool) = + fun projectee -> + match projectee with | CheckNoUvars -> true | uu___ -> false +let (uu___is_Unmeta : step -> Prims.bool) = + fun projectee -> match projectee with | Unmeta -> true | uu___ -> false +let (uu___is_Unascribe : step -> Prims.bool) = + fun projectee -> match projectee with | Unascribe -> true | uu___ -> false +let (uu___is_NBE : step -> Prims.bool) = + fun projectee -> match projectee with | NBE -> true | uu___ -> false +let (uu___is_ForExtraction : step -> Prims.bool) = + fun projectee -> + match projectee with | ForExtraction -> true | uu___ -> false +let (uu___is_Unrefine : step -> Prims.bool) = + fun projectee -> match projectee with | Unrefine -> true | uu___ -> false +let (uu___is_NormDebug : step -> Prims.bool) = + fun projectee -> match projectee with | NormDebug -> true | uu___ -> false +let (uu___is_DefaultUnivsToZero : step -> Prims.bool) = + fun projectee -> + match projectee with | DefaultUnivsToZero -> true | uu___ -> false +let (uu___is_Tactics : step -> Prims.bool) = + fun projectee -> match projectee with | Tactics -> true | uu___ -> false +type steps = step Prims.list +let (dbg_ImplicitTrace : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "ImplicitTrace" +let (dbg_LayeredEffectsEqns : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "LayeredEffectsEqns" +let rec (eq_step : step -> step -> Prims.bool) = + fun s1 -> + fun s2 -> + match (s1, s2) with + | (Beta, Beta) -> true + | (Iota, Iota) -> true + | (Zeta, Zeta) -> true + | (ZetaFull, ZetaFull) -> true + | (Weak, Weak) -> true + | (HNF, HNF) -> true + | (Primops, Primops) -> true + | (Eager_unfolding, Eager_unfolding) -> true + | (Inlining, Inlining) -> true + | (DoNotUnfoldPureLets, DoNotUnfoldPureLets) -> true + | (PureSubtermsWithinComputations, PureSubtermsWithinComputations) -> + true + | (Simplify, Simplify) -> true + | (EraseUniverses, EraseUniverses) -> true + | (AllowUnboundUniverses, AllowUnboundUniverses) -> true + | (Reify, Reify) -> true + | (CompressUvars, CompressUvars) -> true + | (NoFullNorm, NoFullNorm) -> true + | (CheckNoUvars, CheckNoUvars) -> true + | (Unmeta, Unmeta) -> true + | (Unascribe, Unascribe) -> true + | (NBE, NBE) -> true + | (Unrefine, Unrefine) -> true + | (Exclude s11, Exclude s21) -> eq_step s11 s21 + | (UnfoldUntil s11, UnfoldUntil s21) -> s11 = s21 + | (UnfoldOnly lids1, UnfoldOnly lids2) -> + FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq + (FStarC_Class_Ord.ord_list FStarC_Syntax_Syntax.ord_fv)) lids1 + lids2 + | (UnfoldFully lids1, UnfoldFully lids2) -> + FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq + (FStarC_Class_Ord.ord_list FStarC_Syntax_Syntax.ord_fv)) lids1 + lids2 + | (UnfoldAttr lids1, UnfoldAttr lids2) -> + FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq + (FStarC_Class_Ord.ord_list FStarC_Syntax_Syntax.ord_fv)) lids1 + lids2 + | (UnfoldQual strs1, UnfoldQual strs2) -> + FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq + (FStarC_Class_Ord.ord_list FStarC_Class_Ord.ord_string)) strs1 + strs2 + | (UnfoldNamespace strs1, UnfoldNamespace strs2) -> + FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq + (FStarC_Class_Ord.ord_list FStarC_Class_Ord.ord_string)) strs1 + strs2 + | (DontUnfoldAttr lids1, DontUnfoldAttr lids2) -> + FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq + (FStarC_Class_Ord.ord_list FStarC_Syntax_Syntax.ord_fv)) lids1 + lids2 + | uu___ -> false +let (deq_step : step FStarC_Class_Deq.deq) = + { FStarC_Class_Deq.op_Equals_Question = eq_step } +let rec (step_to_string : step -> Prims.string) = + fun s -> + match s with + | Beta -> "Beta" + | Iota -> "Iota" + | Zeta -> "Zeta" + | ZetaFull -> "ZetaFull" + | Exclude s1 -> + let uu___ = step_to_string s1 in Prims.strcat "Exclude " uu___ + | Weak -> "Weak" + | HNF -> "HNF" + | Primops -> "Primops" + | Eager_unfolding -> "Eager_unfolding" + | Inlining -> "Inlining" + | DoNotUnfoldPureLets -> "DoNotUnfoldPureLets" + | UnfoldUntil s1 -> + let uu___ = + FStarC_Class_Show.show FStarC_Syntax_Syntax.showable_delta_depth s1 in + Prims.strcat "UnfoldUntil " uu___ + | UnfoldOnly lids1 -> + let uu___ = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list FStarC_Ident.showable_lident) lids1 in + Prims.strcat "UnfoldOnly " uu___ + | UnfoldFully lids1 -> + let uu___ = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list FStarC_Ident.showable_lident) lids1 in + Prims.strcat "UnfoldFully " uu___ + | UnfoldAttr lids1 -> + let uu___ = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list FStarC_Ident.showable_lident) lids1 in + Prims.strcat "UnfoldAttr " uu___ + | UnfoldQual strs1 -> + let uu___ = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_string)) strs1 in + Prims.strcat "UnfoldQual " uu___ + | UnfoldNamespace strs1 -> + let uu___ = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_string)) strs1 in + Prims.strcat "UnfoldNamespace " uu___ + | DontUnfoldAttr lids1 -> + let uu___ = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list FStarC_Ident.showable_lident) lids1 in + Prims.strcat "DontUnfoldAttr " uu___ + | PureSubtermsWithinComputations -> "PureSubtermsWithinComputations" + | Simplify -> "Simplify" + | EraseUniverses -> "EraseUniverses" + | AllowUnboundUniverses -> "AllowUnboundUniverses" + | Reify -> "Reify" + | CompressUvars -> "CompressUvars" + | NoFullNorm -> "NoFullNorm" + | CheckNoUvars -> "CheckNoUvars" + | Unmeta -> "Unmeta" + | Unascribe -> "Unascribe" + | NBE -> "NBE" + | ForExtraction -> "ForExtraction" + | Unrefine -> "Unrefine" + | NormDebug -> "NormDebug" + | DefaultUnivsToZero -> "DefaultUnivsToZero" + | Tactics -> "Tactics" +let (showable_step : step FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = step_to_string } +type sig_binding = + (FStarC_Ident.lident Prims.list * FStarC_Syntax_Syntax.sigelt) +type delta_level = + | NoDelta + | InliningDelta + | Eager_unfolding_only + | Unfold of FStarC_Syntax_Syntax.delta_depth +let (uu___is_NoDelta : delta_level -> Prims.bool) = + fun projectee -> match projectee with | NoDelta -> true | uu___ -> false +let (uu___is_InliningDelta : delta_level -> Prims.bool) = + fun projectee -> + match projectee with | InliningDelta -> true | uu___ -> false +let (uu___is_Eager_unfolding_only : delta_level -> Prims.bool) = + fun projectee -> + match projectee with | Eager_unfolding_only -> true | uu___ -> false +let (uu___is_Unfold : delta_level -> Prims.bool) = + fun projectee -> match projectee with | Unfold _0 -> true | uu___ -> false +let (__proj__Unfold__item___0 : + delta_level -> FStarC_Syntax_Syntax.delta_depth) = + fun projectee -> match projectee with | Unfold _0 -> _0 +let (deq_delta_level : delta_level FStarC_Class_Deq.deq) = + { + FStarC_Class_Deq.op_Equals_Question = + (fun x -> + fun y -> + match (x, y) with + | (NoDelta, NoDelta) -> true + | (InliningDelta, InliningDelta) -> true + | (Eager_unfolding_only, Eager_unfolding_only) -> true + | (Unfold x1, Unfold y1) -> + FStarC_Class_Deq.op_Equals_Question + FStarC_Syntax_Syntax.deq_delta_depth x1 y1 + | uu___ -> false) + } +let (showable_delta_level : delta_level FStarC_Class_Show.showable) = + { + FStarC_Class_Show.show = + (fun uu___ -> + match uu___ with + | NoDelta -> "NoDelta" + | InliningDelta -> "Inlining" + | Eager_unfolding_only -> "Eager_unfolding_only" + | Unfold d -> + let uu___1 = + FStarC_Class_Show.show + FStarC_Syntax_Syntax.showable_delta_depth d in + Prims.strcat "Unfold " uu___1) + } +type name_prefix = FStarC_Ident.path +type proof_namespace = (name_prefix * Prims.bool) Prims.list +type cached_elt = + (((FStarC_Syntax_Syntax.universes * FStarC_Syntax_Syntax.typ), + (FStarC_Syntax_Syntax.sigelt * FStarC_Syntax_Syntax.universes + FStar_Pervasives_Native.option)) + FStar_Pervasives.either * FStarC_Compiler_Range_Type.range) +type goal = FStarC_Syntax_Syntax.term +type must_tot = Prims.bool +type mlift = + { + mlift_wp: + env -> + FStarC_Syntax_Syntax.comp -> + (FStarC_Syntax_Syntax.comp * FStarC_TypeChecker_Common.guard_t) + ; + mlift_term: + (FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + FStar_Pervasives_Native.option + } +and edge = + { + msource: FStarC_Ident.lident ; + mtarget: FStarC_Ident.lident ; + mlift: mlift ; + mpath: FStarC_Ident.lident Prims.list } +and effects = + { + decls: + (FStarC_Syntax_Syntax.eff_decl * FStarC_Syntax_Syntax.qualifier + Prims.list) Prims.list + ; + order: edge Prims.list ; + joins: + (FStarC_Ident.lident * FStarC_Ident.lident * FStarC_Ident.lident * mlift + * mlift) Prims.list + ; + polymonadic_binds: + (FStarC_Ident.lident * FStarC_Ident.lident * FStarC_Ident.lident * + (env -> + FStarC_Syntax_Syntax.comp_typ -> + FStarC_Syntax_Syntax.bv FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.comp_typ -> + FStarC_Syntax_Syntax.cflag Prims.list -> + FStarC_Compiler_Range_Type.range -> + (FStarC_Syntax_Syntax.comp * + FStarC_TypeChecker_Common.guard_t))) + Prims.list + ; + polymonadic_subcomps: + (FStarC_Ident.lident * FStarC_Ident.lident * FStarC_Syntax_Syntax.tscheme + * FStarC_Syntax_Syntax.indexed_effect_combinator_kind) Prims.list + } +and env = + { + solver: solver_t ; + range: FStarC_Compiler_Range_Type.range ; + curmodule: FStarC_Ident.lident ; + gamma: FStarC_Syntax_Syntax.binding Prims.list ; + gamma_sig: sig_binding Prims.list ; + gamma_cache: cached_elt FStarC_Compiler_Util.smap ; + modules: FStarC_Syntax_Syntax.modul Prims.list ; + expected_typ: + (FStarC_Syntax_Syntax.typ * Prims.bool) FStar_Pervasives_Native.option ; + sigtab: FStarC_Syntax_Syntax.sigelt FStarC_Compiler_Util.smap ; + attrtab: FStarC_Syntax_Syntax.sigelt Prims.list FStarC_Compiler_Util.smap ; + instantiate_imp: Prims.bool ; + effects: effects ; + generalize: Prims.bool ; + letrecs: + (FStarC_Syntax_Syntax.lbname * Prims.int * FStarC_Syntax_Syntax.typ * + FStarC_Syntax_Syntax.univ_names) Prims.list + ; + top_level: Prims.bool ; + check_uvars: Prims.bool ; + use_eq_strict: Prims.bool ; + is_iface: Prims.bool ; + admit: Prims.bool ; + lax_universes: Prims.bool ; + phase1: Prims.bool ; + failhard: Prims.bool ; + flychecking: Prims.bool ; + uvar_subtyping: Prims.bool ; + intactics: Prims.bool ; + nocoerce: Prims.bool ; + tc_term: + env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.lcomp * + FStarC_TypeChecker_Common.guard_t) + ; + typeof_tot_or_gtot_term: + env -> + FStarC_Syntax_Syntax.term -> + must_tot -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.typ * + FStarC_TypeChecker_Common.guard_t) + ; + universe_of: + env -> FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.universe ; + typeof_well_typed_tot_or_gtot_term: + env -> + FStarC_Syntax_Syntax.term -> + must_tot -> + (FStarC_Syntax_Syntax.typ * FStarC_TypeChecker_Common.guard_t) + ; + teq_nosmt_force: + env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term -> Prims.bool + ; + subtype_nosmt_force: + env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term -> Prims.bool + ; + qtbl_name_and_index: + ((FStarC_Ident.lident * FStarC_Syntax_Syntax.typ * Prims.int) + FStar_Pervasives_Native.option * Prims.int FStarC_Compiler_Util.smap) + ; + normalized_eff_names: FStarC_Ident.lident FStarC_Compiler_Util.smap ; + fv_delta_depths: FStarC_Syntax_Syntax.delta_depth FStarC_Compiler_Util.smap ; + proof_ns: proof_namespace ; + synth_hook: + env -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term + ; + try_solve_implicits_hook: + env -> + FStarC_Syntax_Syntax.term -> + FStarC_TypeChecker_Common.implicits -> unit + ; + splice: + env -> + Prims.bool -> + FStarC_Ident.lident Prims.list -> + FStarC_Syntax_Syntax.term -> + FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.sigelt Prims.list + ; + mpreprocess: + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term + ; + postprocess: + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term + ; + identifier_info: + FStarC_TypeChecker_Common.id_info_table FStarC_Compiler_Effect.ref ; + tc_hooks: tcenv_hooks ; + dsenv: FStarC_Syntax_DsEnv.env ; + nbe: + step Prims.list -> + env -> FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term + ; + strict_args_tab: + Prims.int Prims.list FStar_Pervasives_Native.option + FStarC_Compiler_Util.smap + ; + erasable_types_tab: Prims.bool FStarC_Compiler_Util.smap ; + enable_defer_to_tac: Prims.bool ; + unif_allow_ref_guards: Prims.bool ; + erase_erasable_args: Prims.bool ; + core_check: + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.typ -> + Prims.bool -> + (FStarC_Syntax_Syntax.typ FStar_Pervasives_Native.option, + Prims.bool -> Prims.string) FStar_Pervasives.either + ; + missing_decl: FStarC_Ident.lident FStarC_Compiler_RBSet.t } +and solver_t = + { + init: env -> unit ; + snapshot: Prims.string -> ((Prims.int * Prims.int * Prims.int) * unit) ; + rollback: + Prims.string -> + (Prims.int * Prims.int * Prims.int) FStar_Pervasives_Native.option -> + unit + ; + encode_sig: env -> FStarC_Syntax_Syntax.sigelt -> unit ; + preprocess: + env -> + goal -> + (Prims.bool * (env * goal * FStarC_Options.optionstate) Prims.list) + ; + spinoff_strictly_positive_goals: + (env -> goal -> (env * goal) Prims.list) FStar_Pervasives_Native.option ; + handle_smt_goal: env -> goal -> (env * goal) Prims.list ; + solve: + (unit -> Prims.string) FStar_Pervasives_Native.option -> + env -> goal -> unit + ; + solve_sync: + (unit -> Prims.string) FStar_Pervasives_Native.option -> + env -> goal -> Prims.bool + ; + finish: unit -> unit ; + refresh: proof_namespace FStar_Pervasives_Native.option -> unit } +and tcenv_hooks = + { + tc_push_in_gamma_hook: + env -> + (FStarC_Syntax_Syntax.binding, sig_binding) FStar_Pervasives.either -> + unit + } +let (__proj__Mkmlift__item__mlift_wp : + mlift -> + env -> + FStarC_Syntax_Syntax.comp -> + (FStarC_Syntax_Syntax.comp * FStarC_TypeChecker_Common.guard_t)) + = + fun projectee -> + match projectee with | { mlift_wp; mlift_term;_} -> mlift_wp +let (__proj__Mkmlift__item__mlift_term : + mlift -> + (FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + FStar_Pervasives_Native.option) + = + fun projectee -> + match projectee with | { mlift_wp; mlift_term;_} -> mlift_term +let (__proj__Mkedge__item__msource : edge -> FStarC_Ident.lident) = + fun projectee -> + match projectee with + | { msource; mtarget; mlift = mlift1; mpath;_} -> msource +let (__proj__Mkedge__item__mtarget : edge -> FStarC_Ident.lident) = + fun projectee -> + match projectee with + | { msource; mtarget; mlift = mlift1; mpath;_} -> mtarget +let (__proj__Mkedge__item__mlift : edge -> mlift) = + fun projectee -> + match projectee with + | { msource; mtarget; mlift = mlift1; mpath;_} -> mlift1 +let (__proj__Mkedge__item__mpath : edge -> FStarC_Ident.lident Prims.list) = + fun projectee -> + match projectee with + | { msource; mtarget; mlift = mlift1; mpath;_} -> mpath +let (__proj__Mkeffects__item__decls : + effects -> + (FStarC_Syntax_Syntax.eff_decl * FStarC_Syntax_Syntax.qualifier + Prims.list) Prims.list) + = + fun projectee -> + match projectee with + | { decls; order; joins; polymonadic_binds; polymonadic_subcomps;_} -> + decls +let (__proj__Mkeffects__item__order : effects -> edge Prims.list) = + fun projectee -> + match projectee with + | { decls; order; joins; polymonadic_binds; polymonadic_subcomps;_} -> + order +let (__proj__Mkeffects__item__joins : + effects -> + (FStarC_Ident.lident * FStarC_Ident.lident * FStarC_Ident.lident * mlift + * mlift) Prims.list) + = + fun projectee -> + match projectee with + | { decls; order; joins; polymonadic_binds; polymonadic_subcomps;_} -> + joins +let (__proj__Mkeffects__item__polymonadic_binds : + effects -> + (FStarC_Ident.lident * FStarC_Ident.lident * FStarC_Ident.lident * + (env -> + FStarC_Syntax_Syntax.comp_typ -> + FStarC_Syntax_Syntax.bv FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.comp_typ -> + FStarC_Syntax_Syntax.cflag Prims.list -> + FStarC_Compiler_Range_Type.range -> + (FStarC_Syntax_Syntax.comp * + FStarC_TypeChecker_Common.guard_t))) + Prims.list) + = + fun projectee -> + match projectee with + | { decls; order; joins; polymonadic_binds; polymonadic_subcomps;_} -> + polymonadic_binds +let (__proj__Mkeffects__item__polymonadic_subcomps : + effects -> + (FStarC_Ident.lident * FStarC_Ident.lident * FStarC_Syntax_Syntax.tscheme + * FStarC_Syntax_Syntax.indexed_effect_combinator_kind) Prims.list) + = + fun projectee -> + match projectee with + | { decls; order; joins; polymonadic_binds; polymonadic_subcomps;_} -> + polymonadic_subcomps +let (__proj__Mkenv__item__solver : env -> solver_t) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> solver +let (__proj__Mkenv__item__range : env -> FStarC_Compiler_Range_Type.range) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> range +let (__proj__Mkenv__item__curmodule : env -> FStarC_Ident.lident) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> curmodule +let (__proj__Mkenv__item__gamma : + env -> FStarC_Syntax_Syntax.binding Prims.list) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> gamma +let (__proj__Mkenv__item__gamma_sig : env -> sig_binding Prims.list) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> gamma_sig +let (__proj__Mkenv__item__gamma_cache : + env -> cached_elt FStarC_Compiler_Util.smap) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> gamma_cache +let (__proj__Mkenv__item__modules : + env -> FStarC_Syntax_Syntax.modul Prims.list) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> modules +let (__proj__Mkenv__item__expected_typ : + env -> + (FStarC_Syntax_Syntax.typ * Prims.bool) FStar_Pervasives_Native.option) + = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> expected_typ +let (__proj__Mkenv__item__sigtab : + env -> FStarC_Syntax_Syntax.sigelt FStarC_Compiler_Util.smap) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> sigtab +let (__proj__Mkenv__item__attrtab : + env -> FStarC_Syntax_Syntax.sigelt Prims.list FStarC_Compiler_Util.smap) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> attrtab +let (__proj__Mkenv__item__instantiate_imp : env -> Prims.bool) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> instantiate_imp +let (__proj__Mkenv__item__effects : env -> effects) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> effects1 +let (__proj__Mkenv__item__generalize : env -> Prims.bool) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> generalize +let (__proj__Mkenv__item__letrecs : + env -> + (FStarC_Syntax_Syntax.lbname * Prims.int * FStarC_Syntax_Syntax.typ * + FStarC_Syntax_Syntax.univ_names) Prims.list) + = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> letrecs +let (__proj__Mkenv__item__top_level : env -> Prims.bool) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> top_level +let (__proj__Mkenv__item__check_uvars : env -> Prims.bool) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> check_uvars +let (__proj__Mkenv__item__use_eq_strict : env -> Prims.bool) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> use_eq_strict +let (__proj__Mkenv__item__is_iface : env -> Prims.bool) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> is_iface +let (__proj__Mkenv__item__admit : env -> Prims.bool) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> admit +let (__proj__Mkenv__item__lax_universes : env -> Prims.bool) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> lax_universes +let (__proj__Mkenv__item__phase1 : env -> Prims.bool) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> phase1 +let (__proj__Mkenv__item__failhard : env -> Prims.bool) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> failhard +let (__proj__Mkenv__item__flychecking : env -> Prims.bool) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> flychecking +let (__proj__Mkenv__item__uvar_subtyping : env -> Prims.bool) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> uvar_subtyping +let (__proj__Mkenv__item__intactics : env -> Prims.bool) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> intactics +let (__proj__Mkenv__item__nocoerce : env -> Prims.bool) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> nocoerce +let (__proj__Mkenv__item__tc_term : + env -> + env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.lcomp * + FStarC_TypeChecker_Common.guard_t)) + = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> tc_term +let (__proj__Mkenv__item__typeof_tot_or_gtot_term : + env -> + env -> + FStarC_Syntax_Syntax.term -> + must_tot -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.typ * + FStarC_TypeChecker_Common.guard_t)) + = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> typeof_tot_or_gtot_term +let (__proj__Mkenv__item__universe_of : + env -> env -> FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.universe) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> universe_of +let (__proj__Mkenv__item__typeof_well_typed_tot_or_gtot_term : + env -> + env -> + FStarC_Syntax_Syntax.term -> + must_tot -> + (FStarC_Syntax_Syntax.typ * FStarC_TypeChecker_Common.guard_t)) + = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> typeof_well_typed_tot_or_gtot_term +let (__proj__Mkenv__item__teq_nosmt_force : + env -> + env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term -> Prims.bool) + = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> teq_nosmt_force +let (__proj__Mkenv__item__subtype_nosmt_force : + env -> + env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term -> Prims.bool) + = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> subtype_nosmt_force +let (__proj__Mkenv__item__qtbl_name_and_index : + env -> + ((FStarC_Ident.lident * FStarC_Syntax_Syntax.typ * Prims.int) + FStar_Pervasives_Native.option * Prims.int FStarC_Compiler_Util.smap)) + = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> qtbl_name_and_index +let (__proj__Mkenv__item__normalized_eff_names : + env -> FStarC_Ident.lident FStarC_Compiler_Util.smap) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> normalized_eff_names +let (__proj__Mkenv__item__fv_delta_depths : + env -> FStarC_Syntax_Syntax.delta_depth FStarC_Compiler_Util.smap) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> fv_delta_depths +let (__proj__Mkenv__item__proof_ns : env -> proof_namespace) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> proof_ns +let (__proj__Mkenv__item__synth_hook : + env -> + env -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> synth_hook +let (__proj__Mkenv__item__try_solve_implicits_hook : + env -> + env -> + FStarC_Syntax_Syntax.term -> + FStarC_TypeChecker_Common.implicits -> unit) + = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> try_solve_implicits_hook +let (__proj__Mkenv__item__splice : + env -> + env -> + Prims.bool -> + FStarC_Ident.lident Prims.list -> + FStarC_Syntax_Syntax.term -> + FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.sigelt Prims.list) + = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> splice +let (__proj__Mkenv__item__mpreprocess : + env -> + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> mpreprocess +let (__proj__Mkenv__item__postprocess : + env -> + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> postprocess +let (__proj__Mkenv__item__identifier_info : + env -> FStarC_TypeChecker_Common.id_info_table FStarC_Compiler_Effect.ref) + = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> identifier_info +let (__proj__Mkenv__item__tc_hooks : env -> tcenv_hooks) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> tc_hooks +let (__proj__Mkenv__item__dsenv : env -> FStarC_Syntax_DsEnv.env) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> dsenv +let (__proj__Mkenv__item__nbe : + env -> + step Prims.list -> + env -> FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> nbe +let (__proj__Mkenv__item__strict_args_tab : + env -> + Prims.int Prims.list FStar_Pervasives_Native.option + FStarC_Compiler_Util.smap) + = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> strict_args_tab +let (__proj__Mkenv__item__erasable_types_tab : + env -> Prims.bool FStarC_Compiler_Util.smap) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> erasable_types_tab +let (__proj__Mkenv__item__enable_defer_to_tac : env -> Prims.bool) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> enable_defer_to_tac +let (__proj__Mkenv__item__unif_allow_ref_guards : env -> Prims.bool) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> unif_allow_ref_guards +let (__proj__Mkenv__item__erase_erasable_args : env -> Prims.bool) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> erase_erasable_args +let (__proj__Mkenv__item__core_check : + env -> + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.typ -> + Prims.bool -> + (FStarC_Syntax_Syntax.typ FStar_Pervasives_Native.option, + Prims.bool -> Prims.string) FStar_Pervasives.either) + = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> core_check +let (__proj__Mkenv__item__missing_decl : + env -> FStarC_Ident.lident FStarC_Compiler_RBSet.t) = + fun projectee -> + match projectee with + | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; + expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; + generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; + admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; + intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; + typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; + subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; + fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; + splice; mpreprocess; postprocess; identifier_info; tc_hooks; + dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; + unif_allow_ref_guards; erase_erasable_args; core_check; + missing_decl;_} -> missing_decl +let (__proj__Mksolver_t__item__init : solver_t -> env -> unit) = + fun projectee -> + match projectee with + | { init; snapshot; rollback; encode_sig; preprocess; + spinoff_strictly_positive_goals; handle_smt_goal; solve; solve_sync; + finish; refresh;_} -> init +let (__proj__Mksolver_t__item__snapshot : + solver_t -> Prims.string -> ((Prims.int * Prims.int * Prims.int) * unit)) = + fun projectee -> + match projectee with + | { init; snapshot; rollback; encode_sig; preprocess; + spinoff_strictly_positive_goals; handle_smt_goal; solve; solve_sync; + finish; refresh;_} -> snapshot +let (__proj__Mksolver_t__item__rollback : + solver_t -> + Prims.string -> + (Prims.int * Prims.int * Prims.int) FStar_Pervasives_Native.option -> + unit) + = + fun projectee -> + match projectee with + | { init; snapshot; rollback; encode_sig; preprocess; + spinoff_strictly_positive_goals; handle_smt_goal; solve; solve_sync; + finish; refresh;_} -> rollback +let (__proj__Mksolver_t__item__encode_sig : + solver_t -> env -> FStarC_Syntax_Syntax.sigelt -> unit) = + fun projectee -> + match projectee with + | { init; snapshot; rollback; encode_sig; preprocess; + spinoff_strictly_positive_goals; handle_smt_goal; solve; solve_sync; + finish; refresh;_} -> encode_sig +let (__proj__Mksolver_t__item__preprocess : + solver_t -> + env -> + goal -> + (Prims.bool * (env * goal * FStarC_Options.optionstate) Prims.list)) + = + fun projectee -> + match projectee with + | { init; snapshot; rollback; encode_sig; preprocess; + spinoff_strictly_positive_goals; handle_smt_goal; solve; solve_sync; + finish; refresh;_} -> preprocess +let (__proj__Mksolver_t__item__spinoff_strictly_positive_goals : + solver_t -> + (env -> goal -> (env * goal) Prims.list) FStar_Pervasives_Native.option) + = + fun projectee -> + match projectee with + | { init; snapshot; rollback; encode_sig; preprocess; + spinoff_strictly_positive_goals; handle_smt_goal; solve; solve_sync; + finish; refresh;_} -> spinoff_strictly_positive_goals +let (__proj__Mksolver_t__item__handle_smt_goal : + solver_t -> env -> goal -> (env * goal) Prims.list) = + fun projectee -> + match projectee with + | { init; snapshot; rollback; encode_sig; preprocess; + spinoff_strictly_positive_goals; handle_smt_goal; solve; solve_sync; + finish; refresh;_} -> handle_smt_goal +let (__proj__Mksolver_t__item__solve : + solver_t -> + (unit -> Prims.string) FStar_Pervasives_Native.option -> + env -> goal -> unit) + = + fun projectee -> + match projectee with + | { init; snapshot; rollback; encode_sig; preprocess; + spinoff_strictly_positive_goals; handle_smt_goal; solve; solve_sync; + finish; refresh;_} -> solve +let (__proj__Mksolver_t__item__solve_sync : + solver_t -> + (unit -> Prims.string) FStar_Pervasives_Native.option -> + env -> goal -> Prims.bool) + = + fun projectee -> + match projectee with + | { init; snapshot; rollback; encode_sig; preprocess; + spinoff_strictly_positive_goals; handle_smt_goal; solve; solve_sync; + finish; refresh;_} -> solve_sync +let (__proj__Mksolver_t__item__finish : solver_t -> unit -> unit) = + fun projectee -> + match projectee with + | { init; snapshot; rollback; encode_sig; preprocess; + spinoff_strictly_positive_goals; handle_smt_goal; solve; solve_sync; + finish; refresh;_} -> finish +let (__proj__Mksolver_t__item__refresh : + solver_t -> proof_namespace FStar_Pervasives_Native.option -> unit) = + fun projectee -> + match projectee with + | { init; snapshot; rollback; encode_sig; preprocess; + spinoff_strictly_positive_goals; handle_smt_goal; solve; solve_sync; + finish; refresh;_} -> refresh +let (__proj__Mktcenv_hooks__item__tc_push_in_gamma_hook : + tcenv_hooks -> + env -> + (FStarC_Syntax_Syntax.binding, sig_binding) FStar_Pervasives.either -> + unit) + = + fun projectee -> + match projectee with + | { tc_push_in_gamma_hook;_} -> tc_push_in_gamma_hook +type lift_comp_t = + env -> + FStarC_Syntax_Syntax.comp -> + (FStarC_Syntax_Syntax.comp * FStarC_TypeChecker_Common.guard_t) +type polymonadic_bind_t = + env -> + FStarC_Syntax_Syntax.comp_typ -> + FStarC_Syntax_Syntax.bv FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.comp_typ -> + FStarC_Syntax_Syntax.cflag Prims.list -> + FStarC_Compiler_Range_Type.range -> + (FStarC_Syntax_Syntax.comp * FStarC_TypeChecker_Common.guard_t) +type solver_depth_t = (Prims.int * Prims.int * Prims.int) +type core_check_t = + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.typ -> + Prims.bool -> + (FStarC_Syntax_Syntax.typ FStar_Pervasives_Native.option, + Prims.bool -> Prims.string) FStar_Pervasives.either +let (preprocess : + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = fun env1 -> fun tau -> fun tm -> env1.mpreprocess env1 tau tm +let (postprocess : + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun env1 -> fun tau -> fun ty -> fun tm -> env1.postprocess env1 tau ty tm +let (rename_gamma : + FStarC_Syntax_Syntax.subst_t -> + FStarC_Syntax_Syntax.gamma -> FStarC_Syntax_Syntax.gamma) + = + fun subst -> + fun gamma -> + FStarC_Compiler_List.map + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.Binding_var x -> + let y = + let uu___1 = FStarC_Syntax_Syntax.bv_to_name x in + FStarC_Syntax_Subst.subst subst uu___1 in + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress y in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_name y1 -> + let uu___2 = + let uu___3 = + FStarC_Syntax_Subst.subst subst + x.FStarC_Syntax_Syntax.sort in + { + FStarC_Syntax_Syntax.ppname = + (y1.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (y1.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = uu___3 + } in + FStarC_Syntax_Syntax.Binding_var uu___2 + | uu___2 -> failwith "Not a renaming") + | b -> b) gamma +let (rename_env : FStarC_Syntax_Syntax.subst_t -> env -> env) = + fun subst -> + fun env1 -> + let uu___ = rename_gamma subst env1.gamma in + { + solver = (env1.solver); + range = (env1.range); + curmodule = (env1.curmodule); + gamma = uu___; + gamma_sig = (env1.gamma_sig); + gamma_cache = (env1.gamma_cache); + modules = (env1.modules); + expected_typ = (env1.expected_typ); + sigtab = (env1.sigtab); + attrtab = (env1.attrtab); + instantiate_imp = (env1.instantiate_imp); + effects = (env1.effects); + generalize = (env1.generalize); + letrecs = (env1.letrecs); + top_level = (env1.top_level); + check_uvars = (env1.check_uvars); + use_eq_strict = (env1.use_eq_strict); + is_iface = (env1.is_iface); + admit = (env1.admit); + lax_universes = (env1.lax_universes); + phase1 = (env1.phase1); + failhard = (env1.failhard); + flychecking = (env1.flychecking); + uvar_subtyping = (env1.uvar_subtyping); + intactics = (env1.intactics); + nocoerce = (env1.nocoerce); + tc_term = (env1.tc_term); + typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); + universe_of = (env1.universe_of); + typeof_well_typed_tot_or_gtot_term = + (env1.typeof_well_typed_tot_or_gtot_term); + teq_nosmt_force = (env1.teq_nosmt_force); + subtype_nosmt_force = (env1.subtype_nosmt_force); + qtbl_name_and_index = (env1.qtbl_name_and_index); + normalized_eff_names = (env1.normalized_eff_names); + fv_delta_depths = (env1.fv_delta_depths); + proof_ns = (env1.proof_ns); + synth_hook = (env1.synth_hook); + try_solve_implicits_hook = (env1.try_solve_implicits_hook); + splice = (env1.splice); + mpreprocess = (env1.mpreprocess); + postprocess = (env1.postprocess); + identifier_info = (env1.identifier_info); + tc_hooks = (env1.tc_hooks); + dsenv = (env1.dsenv); + nbe = (env1.nbe); + strict_args_tab = (env1.strict_args_tab); + erasable_types_tab = (env1.erasable_types_tab); + enable_defer_to_tac = (env1.enable_defer_to_tac); + unif_allow_ref_guards = (env1.unif_allow_ref_guards); + erase_erasable_args = (env1.erase_erasable_args); + core_check = (env1.core_check); + missing_decl = (env1.missing_decl) + } +let (default_tc_hooks : tcenv_hooks) = + { tc_push_in_gamma_hook = (fun uu___ -> fun uu___1 -> ()) } +let (tc_hooks : env -> tcenv_hooks) = fun env1 -> env1.tc_hooks +let (set_tc_hooks : env -> tcenv_hooks -> env) = + fun env1 -> + fun hooks -> + { + solver = (env1.solver); + range = (env1.range); + curmodule = (env1.curmodule); + gamma = (env1.gamma); + gamma_sig = (env1.gamma_sig); + gamma_cache = (env1.gamma_cache); + modules = (env1.modules); + expected_typ = (env1.expected_typ); + sigtab = (env1.sigtab); + attrtab = (env1.attrtab); + instantiate_imp = (env1.instantiate_imp); + effects = (env1.effects); + generalize = (env1.generalize); + letrecs = (env1.letrecs); + top_level = (env1.top_level); + check_uvars = (env1.check_uvars); + use_eq_strict = (env1.use_eq_strict); + is_iface = (env1.is_iface); + admit = (env1.admit); + lax_universes = (env1.lax_universes); + phase1 = (env1.phase1); + failhard = (env1.failhard); + flychecking = (env1.flychecking); + uvar_subtyping = (env1.uvar_subtyping); + intactics = (env1.intactics); + nocoerce = (env1.nocoerce); + tc_term = (env1.tc_term); + typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); + universe_of = (env1.universe_of); + typeof_well_typed_tot_or_gtot_term = + (env1.typeof_well_typed_tot_or_gtot_term); + teq_nosmt_force = (env1.teq_nosmt_force); + subtype_nosmt_force = (env1.subtype_nosmt_force); + qtbl_name_and_index = (env1.qtbl_name_and_index); + normalized_eff_names = (env1.normalized_eff_names); + fv_delta_depths = (env1.fv_delta_depths); + proof_ns = (env1.proof_ns); + synth_hook = (env1.synth_hook); + try_solve_implicits_hook = (env1.try_solve_implicits_hook); + splice = (env1.splice); + mpreprocess = (env1.mpreprocess); + postprocess = (env1.postprocess); + identifier_info = (env1.identifier_info); + tc_hooks = hooks; + dsenv = (env1.dsenv); + nbe = (env1.nbe); + strict_args_tab = (env1.strict_args_tab); + erasable_types_tab = (env1.erasable_types_tab); + enable_defer_to_tac = (env1.enable_defer_to_tac); + unif_allow_ref_guards = (env1.unif_allow_ref_guards); + erase_erasable_args = (env1.erase_erasable_args); + core_check = (env1.core_check); + missing_decl = (env1.missing_decl) + } +let (set_dep_graph : env -> FStarC_Parser_Dep.deps -> env) = + fun e -> + fun g -> + let uu___ = FStarC_Syntax_DsEnv.set_dep_graph e.dsenv g in + { + solver = (e.solver); + range = (e.range); + curmodule = (e.curmodule); + gamma = (e.gamma); + gamma_sig = (e.gamma_sig); + gamma_cache = (e.gamma_cache); + modules = (e.modules); + expected_typ = (e.expected_typ); + sigtab = (e.sigtab); + attrtab = (e.attrtab); + instantiate_imp = (e.instantiate_imp); + effects = (e.effects); + generalize = (e.generalize); + letrecs = (e.letrecs); + top_level = (e.top_level); + check_uvars = (e.check_uvars); + use_eq_strict = (e.use_eq_strict); + is_iface = (e.is_iface); + admit = (e.admit); + lax_universes = (e.lax_universes); + phase1 = (e.phase1); + failhard = (e.failhard); + flychecking = (e.flychecking); + uvar_subtyping = (e.uvar_subtyping); + intactics = (e.intactics); + nocoerce = (e.nocoerce); + tc_term = (e.tc_term); + typeof_tot_or_gtot_term = (e.typeof_tot_or_gtot_term); + universe_of = (e.universe_of); + typeof_well_typed_tot_or_gtot_term = + (e.typeof_well_typed_tot_or_gtot_term); + teq_nosmt_force = (e.teq_nosmt_force); + subtype_nosmt_force = (e.subtype_nosmt_force); + qtbl_name_and_index = (e.qtbl_name_and_index); + normalized_eff_names = (e.normalized_eff_names); + fv_delta_depths = (e.fv_delta_depths); + proof_ns = (e.proof_ns); + synth_hook = (e.synth_hook); + try_solve_implicits_hook = (e.try_solve_implicits_hook); + splice = (e.splice); + mpreprocess = (e.mpreprocess); + postprocess = (e.postprocess); + identifier_info = (e.identifier_info); + tc_hooks = (e.tc_hooks); + dsenv = uu___; + nbe = (e.nbe); + strict_args_tab = (e.strict_args_tab); + erasable_types_tab = (e.erasable_types_tab); + enable_defer_to_tac = (e.enable_defer_to_tac); + unif_allow_ref_guards = (e.unif_allow_ref_guards); + erase_erasable_args = (e.erase_erasable_args); + core_check = (e.core_check); + missing_decl = (e.missing_decl) + } +let (dep_graph : env -> FStarC_Parser_Dep.deps) = + fun e -> FStarC_Syntax_DsEnv.dep_graph e.dsenv +let (record_val_for : env -> FStarC_Ident.lident -> env) = + fun e -> + fun l -> + let uu___ = + Obj.magic + (FStarC_Class_Setlike.add () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Syntax.ord_fv)) l (Obj.magic e.missing_decl)) in + { + solver = (e.solver); + range = (e.range); + curmodule = (e.curmodule); + gamma = (e.gamma); + gamma_sig = (e.gamma_sig); + gamma_cache = (e.gamma_cache); + modules = (e.modules); + expected_typ = (e.expected_typ); + sigtab = (e.sigtab); + attrtab = (e.attrtab); + instantiate_imp = (e.instantiate_imp); + effects = (e.effects); + generalize = (e.generalize); + letrecs = (e.letrecs); + top_level = (e.top_level); + check_uvars = (e.check_uvars); + use_eq_strict = (e.use_eq_strict); + is_iface = (e.is_iface); + admit = (e.admit); + lax_universes = (e.lax_universes); + phase1 = (e.phase1); + failhard = (e.failhard); + flychecking = (e.flychecking); + uvar_subtyping = (e.uvar_subtyping); + intactics = (e.intactics); + nocoerce = (e.nocoerce); + tc_term = (e.tc_term); + typeof_tot_or_gtot_term = (e.typeof_tot_or_gtot_term); + universe_of = (e.universe_of); + typeof_well_typed_tot_or_gtot_term = + (e.typeof_well_typed_tot_or_gtot_term); + teq_nosmt_force = (e.teq_nosmt_force); + subtype_nosmt_force = (e.subtype_nosmt_force); + qtbl_name_and_index = (e.qtbl_name_and_index); + normalized_eff_names = (e.normalized_eff_names); + fv_delta_depths = (e.fv_delta_depths); + proof_ns = (e.proof_ns); + synth_hook = (e.synth_hook); + try_solve_implicits_hook = (e.try_solve_implicits_hook); + splice = (e.splice); + mpreprocess = (e.mpreprocess); + postprocess = (e.postprocess); + identifier_info = (e.identifier_info); + tc_hooks = (e.tc_hooks); + dsenv = (e.dsenv); + nbe = (e.nbe); + strict_args_tab = (e.strict_args_tab); + erasable_types_tab = (e.erasable_types_tab); + enable_defer_to_tac = (e.enable_defer_to_tac); + unif_allow_ref_guards = (e.unif_allow_ref_guards); + erase_erasable_args = (e.erase_erasable_args); + core_check = (e.core_check); + missing_decl = uu___ + } +let (record_definition_for : env -> FStarC_Ident.lident -> env) = + fun e -> + fun l -> + let uu___ = + Obj.magic + (FStarC_Class_Setlike.remove () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Syntax.ord_fv)) l (Obj.magic e.missing_decl)) in + { + solver = (e.solver); + range = (e.range); + curmodule = (e.curmodule); + gamma = (e.gamma); + gamma_sig = (e.gamma_sig); + gamma_cache = (e.gamma_cache); + modules = (e.modules); + expected_typ = (e.expected_typ); + sigtab = (e.sigtab); + attrtab = (e.attrtab); + instantiate_imp = (e.instantiate_imp); + effects = (e.effects); + generalize = (e.generalize); + letrecs = (e.letrecs); + top_level = (e.top_level); + check_uvars = (e.check_uvars); + use_eq_strict = (e.use_eq_strict); + is_iface = (e.is_iface); + admit = (e.admit); + lax_universes = (e.lax_universes); + phase1 = (e.phase1); + failhard = (e.failhard); + flychecking = (e.flychecking); + uvar_subtyping = (e.uvar_subtyping); + intactics = (e.intactics); + nocoerce = (e.nocoerce); + tc_term = (e.tc_term); + typeof_tot_or_gtot_term = (e.typeof_tot_or_gtot_term); + universe_of = (e.universe_of); + typeof_well_typed_tot_or_gtot_term = + (e.typeof_well_typed_tot_or_gtot_term); + teq_nosmt_force = (e.teq_nosmt_force); + subtype_nosmt_force = (e.subtype_nosmt_force); + qtbl_name_and_index = (e.qtbl_name_and_index); + normalized_eff_names = (e.normalized_eff_names); + fv_delta_depths = (e.fv_delta_depths); + proof_ns = (e.proof_ns); + synth_hook = (e.synth_hook); + try_solve_implicits_hook = (e.try_solve_implicits_hook); + splice = (e.splice); + mpreprocess = (e.mpreprocess); + postprocess = (e.postprocess); + identifier_info = (e.identifier_info); + tc_hooks = (e.tc_hooks); + dsenv = (e.dsenv); + nbe = (e.nbe); + strict_args_tab = (e.strict_args_tab); + erasable_types_tab = (e.erasable_types_tab); + enable_defer_to_tac = (e.enable_defer_to_tac); + unif_allow_ref_guards = (e.unif_allow_ref_guards); + erase_erasable_args = (e.erase_erasable_args); + core_check = (e.core_check); + missing_decl = uu___ + } +let (missing_definition_list : env -> FStarC_Ident.lident Prims.list) = + fun e -> + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset FStarC_Syntax_Syntax.ord_fv)) + (Obj.magic e.missing_decl) +type implicit = FStarC_TypeChecker_Common.implicit +type implicits = FStarC_TypeChecker_Common.implicits +type guard_t = FStarC_TypeChecker_Common.guard_t +type tcenv_depth_t = (Prims.int * Prims.int * solver_depth_t * Prims.int) +type qninfo = + (((FStarC_Syntax_Syntax.universes * FStarC_Syntax_Syntax.typ), + (FStarC_Syntax_Syntax.sigelt * FStarC_Syntax_Syntax.universes + FStar_Pervasives_Native.option)) + FStar_Pervasives.either * FStarC_Compiler_Range_Type.range) + FStar_Pervasives_Native.option +type env_t = env +type sigtable = FStarC_Syntax_Syntax.sigelt FStarC_Compiler_Util.smap +let (should_verify : env -> Prims.bool) = + fun env1 -> + ((let uu___ = FStarC_Options.lax () in Prims.op_Negation uu___) && + (Prims.op_Negation env1.admit)) + && + (let uu___ = FStarC_Ident.string_of_lid env1.curmodule in + FStarC_Options.should_verify uu___) +let (visible_at : + delta_level -> FStarC_Syntax_Syntax.qualifier -> Prims.bool) = + fun d -> + fun q -> + match (d, q) with + | (NoDelta, uu___) -> true + | (Eager_unfolding_only, + FStarC_Syntax_Syntax.Unfold_for_unification_and_vcgen) -> true + | (Unfold uu___, FStarC_Syntax_Syntax.Unfold_for_unification_and_vcgen) + -> true + | (Unfold uu___, FStarC_Syntax_Syntax.Visible_default) -> true + | (InliningDelta, FStarC_Syntax_Syntax.Inline_for_extraction) -> true + | uu___ -> false +let (default_table_size : Prims.int) = (Prims.of_int (200)) +let new_sigtab : 'uuuuu . unit -> 'uuuuu FStarC_Compiler_Util.smap = + fun uu___ -> FStarC_Compiler_Util.smap_create default_table_size +let new_gamma_cache : 'uuuuu . unit -> 'uuuuu FStarC_Compiler_Util.smap = + fun uu___ -> FStarC_Compiler_Util.smap_create (Prims.of_int (100)) +let (initial_env : + FStarC_Parser_Dep.deps -> + (env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.lcomp * + guard_t)) + -> + (env -> + FStarC_Syntax_Syntax.term -> + must_tot -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.typ * guard_t)) + -> + (env -> + FStarC_Syntax_Syntax.term -> + must_tot -> + FStarC_Syntax_Syntax.typ FStar_Pervasives_Native.option) + -> + (env -> FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.universe) + -> + (env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> Prims.bool) + -> + (env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> Prims.bool) + -> + solver_t -> + FStarC_Ident.lident -> + (step Prims.list -> + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term) + -> core_check_t -> env) + = + fun deps -> + fun tc_term -> + fun typeof_tot_or_gtot_term -> + fun typeof_tot_or_gtot_term_fastpath -> + fun universe_of -> + fun teq_nosmt_force -> + fun subtype_nosmt_force -> + fun solver -> + fun module_lid -> + fun nbe -> + fun core_check -> + let uu___ = new_gamma_cache () in + let uu___1 = new_sigtab () in + let uu___2 = new_sigtab () in + let uu___3 = + let uu___4 = + FStarC_Compiler_Util.smap_create + (Prims.of_int (10)) in + (FStar_Pervasives_Native.None, uu___4) in + let uu___4 = + FStarC_Compiler_Util.smap_create + (Prims.of_int (20)) in + let uu___5 = + FStarC_Compiler_Util.smap_create + (Prims.of_int (50)) in + let uu___6 = FStarC_Options.using_facts_from () in + let uu___7 = + FStarC_Compiler_Util.mk_ref + FStarC_TypeChecker_Common.id_info_table_empty in + let uu___8 = FStarC_Syntax_DsEnv.empty_env deps in + let uu___9 = + FStarC_Compiler_Util.smap_create + (Prims.of_int (20)) in + let uu___10 = + FStarC_Compiler_Util.smap_create + (Prims.of_int (20)) in + let uu___11 = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Syntax.ord_fv)) ()) in + { + solver; + range = FStarC_Compiler_Range_Type.dummyRange; + curmodule = module_lid; + gamma = []; + gamma_sig = []; + gamma_cache = uu___; + modules = []; + expected_typ = FStar_Pervasives_Native.None; + sigtab = uu___1; + attrtab = uu___2; + instantiate_imp = true; + effects = + { + decls = []; + order = []; + joins = []; + polymonadic_binds = []; + polymonadic_subcomps = [] + }; + generalize = true; + letrecs = []; + top_level = false; + check_uvars = false; + use_eq_strict = false; + is_iface = false; + admit = false; + lax_universes = false; + phase1 = false; + failhard = false; + flychecking = false; + uvar_subtyping = true; + intactics = false; + nocoerce = false; + tc_term; + typeof_tot_or_gtot_term; + universe_of; + typeof_well_typed_tot_or_gtot_term = + (fun env1 -> + fun t -> + fun must_tot1 -> + let uu___12 = + typeof_tot_or_gtot_term_fastpath env1 t + must_tot1 in + match uu___12 with + | FStar_Pervasives_Native.Some k -> + (k, + FStarC_TypeChecker_Common.trivial_guard) + | FStar_Pervasives_Native.None -> + let uu___13 = + typeof_tot_or_gtot_term env1 t + must_tot1 in + (match uu___13 with + | (t', k, g) -> (k, g))); + teq_nosmt_force; + subtype_nosmt_force; + qtbl_name_and_index = uu___3; + normalized_eff_names = uu___4; + fv_delta_depths = uu___5; + proof_ns = uu___6; + synth_hook = + (fun e -> + fun g -> + fun tau -> + failwith "no synthesizer available"); + try_solve_implicits_hook = + (fun e -> + fun tau -> + fun imps -> + failwith "no implicit hook available"); + splice = + (fun e -> + fun is_typed -> + fun lids -> + fun tau -> + fun range -> + failwith "no splicer available"); + mpreprocess = + (fun e -> + fun tau -> + fun tm -> + failwith "no preprocessor available"); + postprocess = + (fun e -> + fun tau -> + fun typ -> + fun tm -> + failwith "no postprocessor available"); + identifier_info = uu___7; + tc_hooks = default_tc_hooks; + dsenv = uu___8; + nbe; + strict_args_tab = uu___9; + erasable_types_tab = uu___10; + enable_defer_to_tac = true; + unif_allow_ref_guards = false; + erase_erasable_args = false; + core_check; + missing_decl = uu___11 + } +let (dsenv : env -> FStarC_Syntax_DsEnv.env) = fun env1 -> env1.dsenv +let (sigtab : env -> FStarC_Syntax_Syntax.sigelt FStarC_Compiler_Util.smap) = + fun env1 -> env1.sigtab +let (attrtab : + env -> FStarC_Syntax_Syntax.sigelt Prims.list FStarC_Compiler_Util.smap) = + fun env1 -> env1.attrtab +let (gamma_cache : env -> cached_elt FStarC_Compiler_Util.smap) = + fun env1 -> env1.gamma_cache +let (query_indices : + (FStarC_Ident.lident * Prims.int) Prims.list Prims.list + FStarC_Compiler_Effect.ref) + = FStarC_Compiler_Util.mk_ref [[]] +let (push_query_indices : unit -> unit) = + fun uu___ -> + let uu___1 = FStarC_Compiler_Effect.op_Bang query_indices in + match uu___1 with + | [] -> failwith "Empty query indices!" + | uu___2 -> + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Compiler_Effect.op_Bang query_indices in + FStarC_Compiler_List.hd uu___5 in + let uu___5 = FStarC_Compiler_Effect.op_Bang query_indices in uu___4 + :: uu___5 in + FStarC_Compiler_Effect.op_Colon_Equals query_indices uu___3 +let (pop_query_indices : unit -> unit) = + fun uu___ -> + let uu___1 = FStarC_Compiler_Effect.op_Bang query_indices in + match uu___1 with + | [] -> failwith "Empty query indices!" + | hd::tl -> FStarC_Compiler_Effect.op_Colon_Equals query_indices tl +let (snapshot_query_indices : unit -> (Prims.int * unit)) = + fun uu___ -> FStarC_Common.snapshot push_query_indices query_indices () +let (rollback_query_indices : + Prims.int FStar_Pervasives_Native.option -> unit) = + fun depth -> FStarC_Common.rollback pop_query_indices query_indices depth +let (add_query_index : (FStarC_Ident.lident * Prims.int) -> unit) = + fun uu___ -> + match uu___ with + | (l, n) -> + let uu___1 = FStarC_Compiler_Effect.op_Bang query_indices in + (match uu___1 with + | hd::tl -> + FStarC_Compiler_Effect.op_Colon_Equals query_indices (((l, n) :: + hd) :: tl) + | uu___2 -> failwith "Empty query indices") +let (peek_query_indices : + unit -> (FStarC_Ident.lident * Prims.int) Prims.list) = + fun uu___ -> + let uu___1 = FStarC_Compiler_Effect.op_Bang query_indices in + FStarC_Compiler_List.hd uu___1 +let (stack : env Prims.list FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref [] +let (push_stack : env -> env) = + fun env1 -> + (let uu___1 = + let uu___2 = FStarC_Compiler_Effect.op_Bang stack in env1 :: uu___2 in + FStarC_Compiler_Effect.op_Colon_Equals stack uu___1); + (let uu___1 = FStarC_Compiler_Util.smap_copy (gamma_cache env1) in + let uu___2 = FStarC_Compiler_Util.smap_copy (sigtab env1) in + let uu___3 = FStarC_Compiler_Util.smap_copy (attrtab env1) in + let uu___4 = + let uu___5 = + FStarC_Compiler_Util.smap_copy + (FStar_Pervasives_Native.snd env1.qtbl_name_and_index) in + ((FStar_Pervasives_Native.fst env1.qtbl_name_and_index), uu___5) in + let uu___5 = FStarC_Compiler_Util.smap_copy env1.normalized_eff_names in + let uu___6 = FStarC_Compiler_Util.smap_copy env1.fv_delta_depths in + let uu___7 = + let uu___8 = FStarC_Compiler_Effect.op_Bang env1.identifier_info in + FStarC_Compiler_Util.mk_ref uu___8 in + let uu___8 = FStarC_Compiler_Util.smap_copy env1.strict_args_tab in + let uu___9 = FStarC_Compiler_Util.smap_copy env1.erasable_types_tab in + { + solver = (env1.solver); + range = (env1.range); + curmodule = (env1.curmodule); + gamma = (env1.gamma); + gamma_sig = (env1.gamma_sig); + gamma_cache = uu___1; + modules = (env1.modules); + expected_typ = (env1.expected_typ); + sigtab = uu___2; + attrtab = uu___3; + instantiate_imp = (env1.instantiate_imp); + effects = (env1.effects); + generalize = (env1.generalize); + letrecs = (env1.letrecs); + top_level = (env1.top_level); + check_uvars = (env1.check_uvars); + use_eq_strict = (env1.use_eq_strict); + is_iface = (env1.is_iface); + admit = (env1.admit); + lax_universes = (env1.lax_universes); + phase1 = (env1.phase1); + failhard = (env1.failhard); + flychecking = (env1.flychecking); + uvar_subtyping = (env1.uvar_subtyping); + intactics = (env1.intactics); + nocoerce = (env1.nocoerce); + tc_term = (env1.tc_term); + typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); + universe_of = (env1.universe_of); + typeof_well_typed_tot_or_gtot_term = + (env1.typeof_well_typed_tot_or_gtot_term); + teq_nosmt_force = (env1.teq_nosmt_force); + subtype_nosmt_force = (env1.subtype_nosmt_force); + qtbl_name_and_index = uu___4; + normalized_eff_names = uu___5; + fv_delta_depths = uu___6; + proof_ns = (env1.proof_ns); + synth_hook = (env1.synth_hook); + try_solve_implicits_hook = (env1.try_solve_implicits_hook); + splice = (env1.splice); + mpreprocess = (env1.mpreprocess); + postprocess = (env1.postprocess); + identifier_info = uu___7; + tc_hooks = (env1.tc_hooks); + dsenv = (env1.dsenv); + nbe = (env1.nbe); + strict_args_tab = uu___8; + erasable_types_tab = uu___9; + enable_defer_to_tac = (env1.enable_defer_to_tac); + unif_allow_ref_guards = (env1.unif_allow_ref_guards); + erase_erasable_args = (env1.erase_erasable_args); + core_check = (env1.core_check); + missing_decl = (env1.missing_decl) + }) +let (pop_stack : unit -> env) = + fun uu___ -> + let uu___1 = FStarC_Compiler_Effect.op_Bang stack in + match uu___1 with + | env1::tl -> (FStarC_Compiler_Effect.op_Colon_Equals stack tl; env1) + | uu___2 -> failwith "Impossible: Too many pops" +let (snapshot_stack : env -> (Prims.int * env)) = + fun env1 -> FStarC_Common.snapshot push_stack stack env1 +let (rollback_stack : Prims.int FStar_Pervasives_Native.option -> env) = + fun depth -> FStarC_Common.rollback pop_stack stack depth +let (snapshot : env -> Prims.string -> (tcenv_depth_t * env)) = + fun env1 -> + fun msg -> + FStarC_Compiler_Util.atomically + (fun uu___ -> + let uu___1 = snapshot_stack env1 in + match uu___1 with + | (stack_depth, env2) -> + let uu___2 = snapshot_query_indices () in + (match uu___2 with + | (query_indices_depth, ()) -> + let uu___3 = (env2.solver).snapshot msg in + (match uu___3 with + | (solver_depth, ()) -> + let uu___4 = FStarC_Syntax_DsEnv.snapshot env2.dsenv in + (match uu___4 with + | (dsenv_depth, dsenv1) -> + ((stack_depth, query_indices_depth, + solver_depth, dsenv_depth), + { + solver = (env2.solver); + range = (env2.range); + curmodule = (env2.curmodule); + gamma = (env2.gamma); + gamma_sig = (env2.gamma_sig); + gamma_cache = (env2.gamma_cache); + modules = (env2.modules); + expected_typ = (env2.expected_typ); + sigtab = (env2.sigtab); + attrtab = (env2.attrtab); + instantiate_imp = (env2.instantiate_imp); + effects = (env2.effects); + generalize = (env2.generalize); + letrecs = (env2.letrecs); + top_level = (env2.top_level); + check_uvars = (env2.check_uvars); + use_eq_strict = (env2.use_eq_strict); + is_iface = (env2.is_iface); + admit = (env2.admit); + lax_universes = (env2.lax_universes); + phase1 = (env2.phase1); + failhard = (env2.failhard); + flychecking = (env2.flychecking); + uvar_subtyping = (env2.uvar_subtyping); + intactics = (env2.intactics); + nocoerce = (env2.nocoerce); + tc_term = (env2.tc_term); + typeof_tot_or_gtot_term = + (env2.typeof_tot_or_gtot_term); + universe_of = (env2.universe_of); + typeof_well_typed_tot_or_gtot_term = + (env2.typeof_well_typed_tot_or_gtot_term); + teq_nosmt_force = (env2.teq_nosmt_force); + subtype_nosmt_force = + (env2.subtype_nosmt_force); + qtbl_name_and_index = + (env2.qtbl_name_and_index); + normalized_eff_names = + (env2.normalized_eff_names); + fv_delta_depths = (env2.fv_delta_depths); + proof_ns = (env2.proof_ns); + synth_hook = (env2.synth_hook); + try_solve_implicits_hook = + (env2.try_solve_implicits_hook); + splice = (env2.splice); + mpreprocess = (env2.mpreprocess); + postprocess = (env2.postprocess); + identifier_info = (env2.identifier_info); + tc_hooks = (env2.tc_hooks); + dsenv = dsenv1; + nbe = (env2.nbe); + strict_args_tab = (env2.strict_args_tab); + erasable_types_tab = + (env2.erasable_types_tab); + enable_defer_to_tac = + (env2.enable_defer_to_tac); + unif_allow_ref_guards = + (env2.unif_allow_ref_guards); + erase_erasable_args = + (env2.erase_erasable_args); + core_check = (env2.core_check); + missing_decl = (env2.missing_decl) + }))))) +let (rollback : + solver_t -> + Prims.string -> tcenv_depth_t FStar_Pervasives_Native.option -> env) + = + fun solver -> + fun msg -> + fun depth -> + FStarC_Compiler_Util.atomically + (fun uu___ -> + let uu___1 = + match depth with + | FStar_Pervasives_Native.Some (s1, s2, s3, s4) -> + ((FStar_Pervasives_Native.Some s1), + (FStar_Pervasives_Native.Some s2), + (FStar_Pervasives_Native.Some s3), + (FStar_Pervasives_Native.Some s4)) + | FStar_Pervasives_Native.None -> + (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None) in + match uu___1 with + | (stack_depth, query_indices_depth, solver_depth, dsenv_depth) + -> + (solver.rollback msg solver_depth; + (match () with + | () -> + (rollback_query_indices query_indices_depth; + (match () with + | () -> + let tcenv = rollback_stack stack_depth in + let dsenv1 = + FStarC_Syntax_DsEnv.rollback dsenv_depth in + ((let uu___5 = + FStarC_Compiler_Util.physical_equality + tcenv.dsenv dsenv1 in + FStarC_Common.runtime_assert uu___5 + "Inconsistent stack state"); + tcenv)))))) +let (push : env -> Prims.string -> env) = + fun env1 -> + fun msg -> + let uu___ = snapshot env1 msg in FStar_Pervasives_Native.snd uu___ +let (pop : env -> Prims.string -> env) = + fun env1 -> + fun msg -> rollback env1.solver msg FStar_Pervasives_Native.None +let (incr_query_index : env -> env) = + fun env1 -> + let qix = peek_query_indices () in + match env1.qtbl_name_and_index with + | (FStar_Pervasives_Native.None, uu___) -> env1 + | (FStar_Pervasives_Native.Some (l, typ, n), tbl) -> + let uu___ = + FStarC_Compiler_List.tryFind + (fun uu___1 -> + match uu___1 with | (m, uu___2) -> FStarC_Ident.lid_equals l m) + qix in + (match uu___ with + | FStar_Pervasives_Native.None -> + let next = n + Prims.int_one in + (add_query_index (l, next); + (let uu___3 = FStarC_Ident.string_of_lid l in + FStarC_Compiler_Util.smap_add tbl uu___3 next); + { + solver = (env1.solver); + range = (env1.range); + curmodule = (env1.curmodule); + gamma = (env1.gamma); + gamma_sig = (env1.gamma_sig); + gamma_cache = (env1.gamma_cache); + modules = (env1.modules); + expected_typ = (env1.expected_typ); + sigtab = (env1.sigtab); + attrtab = (env1.attrtab); + instantiate_imp = (env1.instantiate_imp); + effects = (env1.effects); + generalize = (env1.generalize); + letrecs = (env1.letrecs); + top_level = (env1.top_level); + check_uvars = (env1.check_uvars); + use_eq_strict = (env1.use_eq_strict); + is_iface = (env1.is_iface); + admit = (env1.admit); + lax_universes = (env1.lax_universes); + phase1 = (env1.phase1); + failhard = (env1.failhard); + flychecking = (env1.flychecking); + uvar_subtyping = (env1.uvar_subtyping); + intactics = (env1.intactics); + nocoerce = (env1.nocoerce); + tc_term = (env1.tc_term); + typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); + universe_of = (env1.universe_of); + typeof_well_typed_tot_or_gtot_term = + (env1.typeof_well_typed_tot_or_gtot_term); + teq_nosmt_force = (env1.teq_nosmt_force); + subtype_nosmt_force = (env1.subtype_nosmt_force); + qtbl_name_and_index = + ((FStar_Pervasives_Native.Some (l, typ, next)), tbl); + normalized_eff_names = (env1.normalized_eff_names); + fv_delta_depths = (env1.fv_delta_depths); + proof_ns = (env1.proof_ns); + synth_hook = (env1.synth_hook); + try_solve_implicits_hook = (env1.try_solve_implicits_hook); + splice = (env1.splice); + mpreprocess = (env1.mpreprocess); + postprocess = (env1.postprocess); + identifier_info = (env1.identifier_info); + tc_hooks = (env1.tc_hooks); + dsenv = (env1.dsenv); + nbe = (env1.nbe); + strict_args_tab = (env1.strict_args_tab); + erasable_types_tab = (env1.erasable_types_tab); + enable_defer_to_tac = (env1.enable_defer_to_tac); + unif_allow_ref_guards = (env1.unif_allow_ref_guards); + erase_erasable_args = (env1.erase_erasable_args); + core_check = (env1.core_check); + missing_decl = (env1.missing_decl) + }) + | FStar_Pervasives_Native.Some (uu___1, m) -> + let next = m + Prims.int_one in + (add_query_index (l, next); + (let uu___4 = FStarC_Ident.string_of_lid l in + FStarC_Compiler_Util.smap_add tbl uu___4 next); + { + solver = (env1.solver); + range = (env1.range); + curmodule = (env1.curmodule); + gamma = (env1.gamma); + gamma_sig = (env1.gamma_sig); + gamma_cache = (env1.gamma_cache); + modules = (env1.modules); + expected_typ = (env1.expected_typ); + sigtab = (env1.sigtab); + attrtab = (env1.attrtab); + instantiate_imp = (env1.instantiate_imp); + effects = (env1.effects); + generalize = (env1.generalize); + letrecs = (env1.letrecs); + top_level = (env1.top_level); + check_uvars = (env1.check_uvars); + use_eq_strict = (env1.use_eq_strict); + is_iface = (env1.is_iface); + admit = (env1.admit); + lax_universes = (env1.lax_universes); + phase1 = (env1.phase1); + failhard = (env1.failhard); + flychecking = (env1.flychecking); + uvar_subtyping = (env1.uvar_subtyping); + intactics = (env1.intactics); + nocoerce = (env1.nocoerce); + tc_term = (env1.tc_term); + typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); + universe_of = (env1.universe_of); + typeof_well_typed_tot_or_gtot_term = + (env1.typeof_well_typed_tot_or_gtot_term); + teq_nosmt_force = (env1.teq_nosmt_force); + subtype_nosmt_force = (env1.subtype_nosmt_force); + qtbl_name_and_index = + ((FStar_Pervasives_Native.Some (l, typ, next)), tbl); + normalized_eff_names = (env1.normalized_eff_names); + fv_delta_depths = (env1.fv_delta_depths); + proof_ns = (env1.proof_ns); + synth_hook = (env1.synth_hook); + try_solve_implicits_hook = (env1.try_solve_implicits_hook); + splice = (env1.splice); + mpreprocess = (env1.mpreprocess); + postprocess = (env1.postprocess); + identifier_info = (env1.identifier_info); + tc_hooks = (env1.tc_hooks); + dsenv = (env1.dsenv); + nbe = (env1.nbe); + strict_args_tab = (env1.strict_args_tab); + erasable_types_tab = (env1.erasable_types_tab); + enable_defer_to_tac = (env1.enable_defer_to_tac); + unif_allow_ref_guards = (env1.unif_allow_ref_guards); + erase_erasable_args = (env1.erase_erasable_args); + core_check = (env1.core_check); + missing_decl = (env1.missing_decl) + })) +let (set_range : env -> FStarC_Compiler_Range_Type.range -> env) = + fun e -> + fun r -> + if r = FStarC_Compiler_Range_Type.dummyRange + then e + else + { + solver = (e.solver); + range = r; + curmodule = (e.curmodule); + gamma = (e.gamma); + gamma_sig = (e.gamma_sig); + gamma_cache = (e.gamma_cache); + modules = (e.modules); + expected_typ = (e.expected_typ); + sigtab = (e.sigtab); + attrtab = (e.attrtab); + instantiate_imp = (e.instantiate_imp); + effects = (e.effects); + generalize = (e.generalize); + letrecs = (e.letrecs); + top_level = (e.top_level); + check_uvars = (e.check_uvars); + use_eq_strict = (e.use_eq_strict); + is_iface = (e.is_iface); + admit = (e.admit); + lax_universes = (e.lax_universes); + phase1 = (e.phase1); + failhard = (e.failhard); + flychecking = (e.flychecking); + uvar_subtyping = (e.uvar_subtyping); + intactics = (e.intactics); + nocoerce = (e.nocoerce); + tc_term = (e.tc_term); + typeof_tot_or_gtot_term = (e.typeof_tot_or_gtot_term); + universe_of = (e.universe_of); + typeof_well_typed_tot_or_gtot_term = + (e.typeof_well_typed_tot_or_gtot_term); + teq_nosmt_force = (e.teq_nosmt_force); + subtype_nosmt_force = (e.subtype_nosmt_force); + qtbl_name_and_index = (e.qtbl_name_and_index); + normalized_eff_names = (e.normalized_eff_names); + fv_delta_depths = (e.fv_delta_depths); + proof_ns = (e.proof_ns); + synth_hook = (e.synth_hook); + try_solve_implicits_hook = (e.try_solve_implicits_hook); + splice = (e.splice); + mpreprocess = (e.mpreprocess); + postprocess = (e.postprocess); + identifier_info = (e.identifier_info); + tc_hooks = (e.tc_hooks); + dsenv = (e.dsenv); + nbe = (e.nbe); + strict_args_tab = (e.strict_args_tab); + erasable_types_tab = (e.erasable_types_tab); + enable_defer_to_tac = (e.enable_defer_to_tac); + unif_allow_ref_guards = (e.unif_allow_ref_guards); + erase_erasable_args = (e.erase_erasable_args); + core_check = (e.core_check); + missing_decl = (e.missing_decl) + } +let (get_range : env -> FStarC_Compiler_Range_Type.range) = fun e -> e.range +let (hasRange_env : env FStarC_Class_HasRange.hasRange) = + { + FStarC_Class_HasRange.pos = get_range; + FStarC_Class_HasRange.setPos = (fun r -> fun e -> set_range e r) + } +let (toggle_id_info : env -> Prims.bool -> unit) = + fun env1 -> + fun enabled -> + let uu___ = + let uu___1 = FStarC_Compiler_Effect.op_Bang env1.identifier_info in + FStarC_TypeChecker_Common.id_info_toggle uu___1 enabled in + FStarC_Compiler_Effect.op_Colon_Equals env1.identifier_info uu___ +let (insert_bv_info : + env -> FStarC_Syntax_Syntax.bv -> FStarC_Syntax_Syntax.typ -> unit) = + fun env1 -> + fun bv -> + fun ty -> + let uu___ = + let uu___1 = FStarC_Compiler_Effect.op_Bang env1.identifier_info in + FStarC_TypeChecker_Common.id_info_insert_bv uu___1 bv ty in + FStarC_Compiler_Effect.op_Colon_Equals env1.identifier_info uu___ +let (insert_fv_info : + env -> FStarC_Syntax_Syntax.fv -> FStarC_Syntax_Syntax.typ -> unit) = + fun env1 -> + fun fv -> + fun ty -> + let uu___ = + let uu___1 = FStarC_Compiler_Effect.op_Bang env1.identifier_info in + FStarC_TypeChecker_Common.id_info_insert_fv uu___1 fv ty in + FStarC_Compiler_Effect.op_Colon_Equals env1.identifier_info uu___ +let (promote_id_info : + env -> + (FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.typ FStar_Pervasives_Native.option) + -> unit) + = + fun env1 -> + fun ty_map -> + let uu___ = + let uu___1 = FStarC_Compiler_Effect.op_Bang env1.identifier_info in + FStarC_TypeChecker_Common.id_info_promote uu___1 ty_map in + FStarC_Compiler_Effect.op_Colon_Equals env1.identifier_info uu___ +let (modules : env -> FStarC_Syntax_Syntax.modul Prims.list) = + fun env1 -> env1.modules +let (current_module : env -> FStarC_Ident.lident) = + fun env1 -> env1.curmodule +let (set_current_module : env -> FStarC_Ident.lident -> env) = + fun env1 -> + fun lid -> + { + solver = (env1.solver); + range = (env1.range); + curmodule = lid; + gamma = (env1.gamma); + gamma_sig = (env1.gamma_sig); + gamma_cache = (env1.gamma_cache); + modules = (env1.modules); + expected_typ = (env1.expected_typ); + sigtab = (env1.sigtab); + attrtab = (env1.attrtab); + instantiate_imp = (env1.instantiate_imp); + effects = (env1.effects); + generalize = (env1.generalize); + letrecs = (env1.letrecs); + top_level = (env1.top_level); + check_uvars = (env1.check_uvars); + use_eq_strict = (env1.use_eq_strict); + is_iface = (env1.is_iface); + admit = (env1.admit); + lax_universes = (env1.lax_universes); + phase1 = (env1.phase1); + failhard = (env1.failhard); + flychecking = (env1.flychecking); + uvar_subtyping = (env1.uvar_subtyping); + intactics = (env1.intactics); + nocoerce = (env1.nocoerce); + tc_term = (env1.tc_term); + typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); + universe_of = (env1.universe_of); + typeof_well_typed_tot_or_gtot_term = + (env1.typeof_well_typed_tot_or_gtot_term); + teq_nosmt_force = (env1.teq_nosmt_force); + subtype_nosmt_force = (env1.subtype_nosmt_force); + qtbl_name_and_index = (env1.qtbl_name_and_index); + normalized_eff_names = (env1.normalized_eff_names); + fv_delta_depths = (env1.fv_delta_depths); + proof_ns = (env1.proof_ns); + synth_hook = (env1.synth_hook); + try_solve_implicits_hook = (env1.try_solve_implicits_hook); + splice = (env1.splice); + mpreprocess = (env1.mpreprocess); + postprocess = (env1.postprocess); + identifier_info = (env1.identifier_info); + tc_hooks = (env1.tc_hooks); + dsenv = (env1.dsenv); + nbe = (env1.nbe); + strict_args_tab = (env1.strict_args_tab); + erasable_types_tab = (env1.erasable_types_tab); + enable_defer_to_tac = (env1.enable_defer_to_tac); + unif_allow_ref_guards = (env1.unif_allow_ref_guards); + erase_erasable_args = (env1.erase_erasable_args); + core_check = (env1.core_check); + missing_decl = (env1.missing_decl) + } +let (has_interface : env -> FStarC_Ident.lident -> Prims.bool) = + fun env1 -> + fun l -> + FStarC_Compiler_Util.for_some + (fun m -> + m.FStarC_Syntax_Syntax.is_interface && + (FStarC_Ident.lid_equals m.FStarC_Syntax_Syntax.name l)) + env1.modules +let (find_in_sigtab : + env -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.sigelt FStar_Pervasives_Native.option) + = + fun env1 -> + fun lid -> + let uu___ = FStarC_Ident.string_of_lid lid in + FStarC_Compiler_Util.smap_try_find (sigtab env1) uu___ +let (new_u_univ : unit -> FStarC_Syntax_Syntax.universe) = + fun uu___ -> + let uu___1 = + FStarC_Syntax_Unionfind.univ_fresh + FStarC_Compiler_Range_Type.dummyRange in + FStarC_Syntax_Syntax.U_unif uu___1 +let (mk_univ_subst : + FStarC_Syntax_Syntax.univ_name Prims.list -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.subst_elt Prims.list) + = + fun formals -> + fun us -> + let n = (FStarC_Compiler_List.length formals) - Prims.int_one in + FStarC_Compiler_List.mapi + (fun i -> fun u -> FStarC_Syntax_Syntax.UN ((n - i), u)) us +let (inst_tscheme_with : + FStarC_Syntax_Syntax.tscheme -> + FStarC_Syntax_Syntax.universes -> + (FStarC_Syntax_Syntax.universes * FStarC_Syntax_Syntax.term)) + = + fun ts -> + fun us -> + match (ts, us) with + | (([], t), []) -> ([], t) + | ((formals, t), uu___) -> + let vs = mk_univ_subst formals us in + let uu___1 = FStarC_Syntax_Subst.subst vs t in (us, uu___1) +let (inst_tscheme : + FStarC_Syntax_Syntax.tscheme -> + (FStarC_Syntax_Syntax.universes * FStarC_Syntax_Syntax.term)) + = + fun uu___ -> + match uu___ with + | ([], t) -> ([], t) + | (us, t) -> + let us' = FStarC_Compiler_List.map (fun uu___1 -> new_u_univ ()) us in + inst_tscheme_with (us, t) us' +let (inst_tscheme_with_range : + FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.tscheme -> + (FStarC_Syntax_Syntax.universes * FStarC_Syntax_Syntax.term)) + = + fun r -> + fun t -> + let uu___ = inst_tscheme t in + match uu___ with + | (us, t1) -> + let uu___1 = FStarC_Syntax_Subst.set_use_range r t1 in (us, uu___1) +let (check_effect_is_not_a_template : + FStarC_Syntax_Syntax.eff_decl -> FStarC_Compiler_Range_Type.range -> unit) + = + fun ed -> + fun rng -> + if + ((FStarC_Compiler_List.length ed.FStarC_Syntax_Syntax.univs) <> + Prims.int_zero) + || + ((FStarC_Compiler_List.length ed.FStarC_Syntax_Syntax.binders) <> + Prims.int_zero) + then + let msg = + let uu___ = + FStarC_Class_Show.show FStarC_Ident.showable_lident + ed.FStarC_Syntax_Syntax.mname in + let uu___1 = + let uu___2 = + FStarC_Compiler_List.map + FStarC_Syntax_Print.binder_to_string_with_type + ed.FStarC_Syntax_Syntax.binders in + FStarC_Compiler_String.concat "," uu___2 in + FStarC_Compiler_Util.format2 + "Effect template %s should be applied to arguments for its binders (%s) before it can be used at an effect position" + uu___ uu___1 in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range rng + FStarC_Errors_Codes.Fatal_NotEnoughArgumentsForEffect () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic msg) + else () +let (inst_effect_fun_with : + FStarC_Syntax_Syntax.universes -> + env -> + FStarC_Syntax_Syntax.eff_decl -> + FStarC_Syntax_Syntax.tscheme -> FStarC_Syntax_Syntax.term) + = + fun insts -> + fun env1 -> + fun ed -> + fun uu___ -> + match uu___ with + | (us, t) -> + (check_effect_is_not_a_template ed env1.range; + if + (FStarC_Compiler_List.length insts) <> + (FStarC_Compiler_List.length us) + then + (let uu___3 = + let uu___4 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length us) in + let uu___5 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length insts) in + let uu___6 = + FStarC_Class_Show.show FStarC_Ident.showable_lident + ed.FStarC_Syntax_Syntax.mname in + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.format4 + "Expected %s instantiations; got %s; failed universe instantiation in effect %s\n\t%s\n" + uu___4 uu___5 uu___6 uu___7 in + failwith uu___3) + else (); + (let uu___3 = inst_tscheme_with (us, t) insts in + FStar_Pervasives_Native.snd uu___3)) +type tri = + | Yes + | No + | Maybe +let (uu___is_Yes : tri -> Prims.bool) = + fun projectee -> match projectee with | Yes -> true | uu___ -> false +let (uu___is_No : tri -> Prims.bool) = + fun projectee -> match projectee with | No -> true | uu___ -> false +let (uu___is_Maybe : tri -> Prims.bool) = + fun projectee -> match projectee with | Maybe -> true | uu___ -> false +let (in_cur_mod : env -> FStarC_Ident.lident -> tri) = + fun env1 -> + fun l -> + let cur = current_module env1 in + let uu___ = + let uu___1 = FStarC_Ident.nsstr l in + let uu___2 = FStarC_Ident.string_of_lid cur in uu___1 = uu___2 in + if uu___ + then Yes + else + (let uu___2 = + let uu___3 = FStarC_Ident.nsstr l in + let uu___4 = FStarC_Ident.string_of_lid cur in + FStarC_Compiler_Util.starts_with uu___3 uu___4 in + if uu___2 + then + let lns = + let uu___3 = FStarC_Ident.ns_of_lid l in + let uu___4 = + let uu___5 = FStarC_Ident.ident_of_lid l in [uu___5] in + FStarC_Compiler_List.op_At uu___3 uu___4 in + let cur1 = + let uu___3 = FStarC_Ident.ns_of_lid cur in + let uu___4 = + let uu___5 = FStarC_Ident.ident_of_lid cur in [uu___5] in + FStarC_Compiler_List.op_At uu___3 uu___4 in + let rec aux c l1 = + match (c, l1) with + | ([], uu___3) -> Maybe + | (uu___3, []) -> No + | (hd::tl, hd'::tl') when + let uu___3 = FStarC_Ident.string_of_id hd in + let uu___4 = FStarC_Ident.string_of_id hd' in + uu___3 = uu___4 -> aux tl tl' + | uu___3 -> No in + aux cur1 lns + else No) +let (lookup_qname : env -> FStarC_Ident.lident -> qninfo) = + fun env1 -> + fun lid -> + let cur_mod = in_cur_mod env1 lid in + let cache t = + (let uu___1 = FStarC_Ident.string_of_lid lid in + FStarC_Compiler_Util.smap_add (gamma_cache env1) uu___1 t); + FStar_Pervasives_Native.Some t in + let found = + if cur_mod <> No + then + let uu___ = + let uu___1 = FStarC_Ident.string_of_lid lid in + FStarC_Compiler_Util.smap_try_find (gamma_cache env1) uu___1 in + match uu___ with + | FStar_Pervasives_Native.None -> + let uu___1 = + FStarC_Compiler_Util.find_map env1.gamma + (fun uu___2 -> + match uu___2 with + | FStarC_Syntax_Syntax.Binding_lid (l, (us_names, t)) + when FStarC_Ident.lid_equals lid l -> + let us = + FStarC_Compiler_List.map + (fun uu___3 -> + FStarC_Syntax_Syntax.U_name uu___3) us_names in + let uu___3 = + let uu___4 = FStarC_Ident.range_of_lid l in + ((FStar_Pervasives.Inl (us, t)), uu___4) in + FStar_Pervasives_Native.Some uu___3 + | uu___3 -> FStar_Pervasives_Native.None) in + FStarC_Compiler_Util.catch_opt uu___1 + (fun uu___2 -> + FStarC_Compiler_Util.find_map env1.gamma_sig + (fun uu___3 -> + match uu___3 with + | (uu___4, + { + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_bundle + { FStarC_Syntax_Syntax.ses = ses; + FStarC_Syntax_Syntax.lids = uu___5;_}; + FStarC_Syntax_Syntax.sigrng = uu___6; + FStarC_Syntax_Syntax.sigquals = uu___7; + FStarC_Syntax_Syntax.sigmeta = uu___8; + FStarC_Syntax_Syntax.sigattrs = uu___9; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + uu___10; + FStarC_Syntax_Syntax.sigopts = uu___11;_}) + -> + FStarC_Compiler_Util.find_map ses + (fun se -> + let uu___12 = + FStarC_Compiler_Util.for_some + (FStarC_Ident.lid_equals lid) + (FStarC_Syntax_Util.lids_of_sigelt se) in + if uu___12 + then + cache + ((FStar_Pervasives.Inr + (se, FStar_Pervasives_Native.None)), + (FStarC_Syntax_Util.range_of_sigelt se)) + else FStar_Pervasives_Native.None) + | (lids, s) -> + let maybe_cache t = + match s.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_declare_typ uu___4 + -> FStar_Pervasives_Native.Some t + | uu___4 -> cache t in + let uu___4 = + FStarC_Compiler_List.tryFind + (FStarC_Ident.lid_equals lid) lids in + (match uu___4 with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some l -> + let uu___5 = + let uu___6 = FStarC_Ident.range_of_lid l in + ((FStar_Pervasives.Inr + (s, FStar_Pervasives_Native.None)), + uu___6) in + maybe_cache uu___5))) + | se -> se + else FStar_Pervasives_Native.None in + if FStarC_Compiler_Util.is_some found + then found + else + (let uu___1 = find_in_sigtab env1 lid in + match uu___1 with + | FStar_Pervasives_Native.Some se -> + FStar_Pervasives_Native.Some + ((FStar_Pervasives.Inr (se, FStar_Pervasives_Native.None)), + (FStarC_Syntax_Util.range_of_sigelt se)) + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None) +let (lookup_sigelt : + env -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.sigelt FStar_Pervasives_Native.option) + = + fun env1 -> + fun lid -> + let uu___ = lookup_qname env1 lid in + match uu___ with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (FStar_Pervasives.Inl uu___1, rng) -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (FStar_Pervasives.Inr (se, us), rng) -> + FStar_Pervasives_Native.Some se +let (lookup_attr : + env -> Prims.string -> FStarC_Syntax_Syntax.sigelt Prims.list) = + fun env1 -> + fun attr -> + let uu___ = FStarC_Compiler_Util.smap_try_find (attrtab env1) attr in + match uu___ with + | FStar_Pervasives_Native.Some ses -> ses + | FStar_Pervasives_Native.None -> [] +let (add_se_to_attrtab : env -> FStarC_Syntax_Syntax.sigelt -> unit) = + fun env1 -> + fun se -> + let add_one env2 se1 attr = + let uu___ = let uu___1 = lookup_attr env2 attr in se1 :: uu___1 in + FStarC_Compiler_Util.smap_add (attrtab env2) attr uu___ in + FStarC_Compiler_List.iter + (fun attr -> + let uu___ = FStarC_Syntax_Util.head_and_args attr in + match uu___ with + | (hd, uu___1) -> + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress hd in + uu___3.FStarC_Syntax_Syntax.n in + (match uu___2 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let uu___3 = + let uu___4 = FStarC_Syntax_Syntax.lid_of_fv fv in + FStarC_Ident.string_of_lid uu___4 in + add_one env1 se uu___3 + | uu___3 -> ())) se.FStarC_Syntax_Syntax.sigattrs +let (try_add_sigelt : + Prims.bool -> + env -> FStarC_Syntax_Syntax.sigelt -> FStarC_Ident.lident -> unit) + = + fun force -> + fun env1 -> + fun se -> + fun l -> + let s = FStarC_Ident.string_of_lid l in + (let uu___1 = + (Prims.op_Negation force) && + (let uu___2 = + FStarC_Compiler_Util.smap_try_find (sigtab env1) s in + FStar_Pervasives_Native.uu___is_Some uu___2) in + if uu___1 + then + let old_se = + let uu___2 = + FStarC_Compiler_Util.smap_try_find (sigtab env1) s in + FStar_Pervasives_Native.__proj__Some__item__v uu___2 in + (if + (FStarC_Syntax_Syntax.uu___is_Sig_declare_typ + old_se.FStarC_Syntax_Syntax.sigel) + && + (((FStarC_Syntax_Syntax.uu___is_Sig_let + se.FStarC_Syntax_Syntax.sigel) + || + (FStarC_Syntax_Syntax.uu___is_Sig_inductive_typ + se.FStarC_Syntax_Syntax.sigel)) + || + (FStarC_Syntax_Syntax.uu___is_Sig_datacon + se.FStarC_Syntax_Syntax.sigel)) + then () + else + (let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Errors_Msg.text "Duplicate top-level names" in + let uu___6 = FStarC_Pprint.arbitrary_string s in + FStarC_Pprint.op_Hat_Slash_Hat uu___5 uu___6 in + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Errors_Msg.text "Previously declared at" in + let uu___8 = + let uu___9 = + let uu___10 = FStarC_Ident.range_of_lid l in + FStarC_Compiler_Range_Ops.string_of_range uu___10 in + FStarC_Pprint.arbitrary_string uu___9 in + FStarC_Pprint.op_Hat_Slash_Hat uu___7 uu___8 in + [uu___6] in + uu___4 :: uu___5 in + FStarC_Errors.raise_error FStarC_Ident.hasrange_lident l + FStarC_Errors_Codes.Fatal_DuplicateTopLevelNames () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___3))) + else ()); + FStarC_Compiler_Util.smap_add (sigtab env1) s se +let rec (add_sigelt : + Prims.bool -> env -> FStarC_Syntax_Syntax.sigelt -> unit) = + fun force -> + fun env1 -> + fun se -> + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_bundle + { FStarC_Syntax_Syntax.ses = ses; + FStarC_Syntax_Syntax.lids = uu___;_} + -> add_sigelts force env1 ses + | uu___ -> + let lids = FStarC_Syntax_Util.lids_of_sigelt se in + (FStarC_Compiler_List.iter (try_add_sigelt force env1 se) lids; + add_se_to_attrtab env1 se) +and (add_sigelts : + Prims.bool -> env -> FStarC_Syntax_Syntax.sigelt Prims.list -> unit) = + fun force -> + fun env1 -> + fun ses -> FStarC_Compiler_List.iter (add_sigelt force env1) ses +let (try_lookup_bv : + env -> + FStarC_Syntax_Syntax.bv -> + (FStarC_Syntax_Syntax.typ * FStarC_Compiler_Range_Type.range) + FStar_Pervasives_Native.option) + = + fun env1 -> + fun bv -> + FStarC_Compiler_Util.find_map env1.gamma + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.Binding_var id when + FStarC_Syntax_Syntax.bv_eq id bv -> + let uu___1 = + let uu___2 = + FStarC_Ident.range_of_id id.FStarC_Syntax_Syntax.ppname in + ((id.FStarC_Syntax_Syntax.sort), uu___2) in + FStar_Pervasives_Native.Some uu___1 + | uu___1 -> FStar_Pervasives_Native.None) +let (lookup_type_of_let : + FStarC_Syntax_Syntax.universes FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.sigelt -> + FStarC_Ident.lident -> + ((FStarC_Syntax_Syntax.universes * FStarC_Syntax_Syntax.term) * + FStarC_Compiler_Range_Type.range) FStar_Pervasives_Native.option) + = + fun us_opt -> + fun se -> + fun lid -> + let inst_tscheme1 ts = + match us_opt with + | FStar_Pervasives_Native.None -> inst_tscheme ts + | FStar_Pervasives_Native.Some us -> inst_tscheme_with ts us in + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (uu___, lb::[]); + FStarC_Syntax_Syntax.lids1 = uu___1;_} + -> + let uu___2 = + let uu___3 = + inst_tscheme1 + ((lb.FStarC_Syntax_Syntax.lbunivs), + (lb.FStarC_Syntax_Syntax.lbtyp)) in + let uu___4 = + FStarC_Syntax_Syntax.range_of_lbname + lb.FStarC_Syntax_Syntax.lbname in + (uu___3, uu___4) in + FStar_Pervasives_Native.Some uu___2 + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (uu___, lbs); + FStarC_Syntax_Syntax.lids1 = uu___1;_} + -> + FStarC_Compiler_Util.find_map lbs + (fun lb -> + match lb.FStarC_Syntax_Syntax.lbname with + | FStar_Pervasives.Inl uu___2 -> failwith "impossible" + | FStar_Pervasives.Inr fv -> + let uu___2 = FStarC_Syntax_Syntax.fv_eq_lid fv lid in + if uu___2 + then + let uu___3 = + let uu___4 = + inst_tscheme1 + ((lb.FStarC_Syntax_Syntax.lbunivs), + (lb.FStarC_Syntax_Syntax.lbtyp)) in + let uu___5 = FStarC_Syntax_Syntax.range_of_fv fv in + (uu___4, uu___5) in + FStar_Pervasives_Native.Some uu___3 + else FStar_Pervasives_Native.None) + | uu___ -> FStar_Pervasives_Native.None +let (effect_signature : + FStarC_Syntax_Syntax.universes FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.sigelt -> + FStarC_Compiler_Range_Type.range -> + ((FStarC_Syntax_Syntax.universes * FStarC_Syntax_Syntax.typ) * + FStarC_Compiler_Range_Type.range) FStar_Pervasives_Native.option) + = + fun us_opt -> + fun se -> + fun rng -> + let inst_ts us_opt1 ts = + match us_opt1 with + | FStar_Pervasives_Native.None -> inst_tscheme ts + | FStar_Pervasives_Native.Some us -> inst_tscheme_with ts us in + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_new_effect ne -> + let sig_ts = + FStarC_Syntax_Util.effect_sig_ts + ne.FStarC_Syntax_Syntax.signature in + (check_effect_is_not_a_template ne rng; + (match us_opt with + | FStar_Pervasives_Native.None -> () + | FStar_Pervasives_Native.Some us -> + if + (FStarC_Compiler_List.length us) <> + (FStarC_Compiler_List.length + (FStar_Pervasives_Native.fst sig_ts)) + then + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Ident.string_of_lid + ne.FStarC_Syntax_Syntax.mname in + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length + (FStar_Pervasives_Native.fst sig_ts)) in + let uu___8 = + let uu___9 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length us) in + Prims.strcat ", got " uu___9 in + Prims.strcat uu___7 uu___8 in + Prims.strcat ", expected " uu___6 in + Prims.strcat uu___4 uu___5 in + Prims.strcat + "effect_signature: incorrect number of universes for the signature of " + uu___3 in + failwith uu___2 + else ()); + (let uu___2 = + let uu___3 = inst_ts us_opt sig_ts in + (uu___3, (se.FStarC_Syntax_Syntax.sigrng)) in + FStar_Pervasives_Native.Some uu___2)) + | FStarC_Syntax_Syntax.Sig_effect_abbrev + { FStarC_Syntax_Syntax.lid4 = lid; FStarC_Syntax_Syntax.us4 = us; + FStarC_Syntax_Syntax.bs2 = binders; + FStarC_Syntax_Syntax.comp1 = uu___; + FStarC_Syntax_Syntax.cflags = uu___1;_} + -> + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.mk_Total FStarC_Syntax_Syntax.teff in + FStarC_Syntax_Util.arrow binders uu___6 in + (us, uu___5) in + inst_ts us_opt uu___4 in + (uu___3, (se.FStarC_Syntax_Syntax.sigrng)) in + FStar_Pervasives_Native.Some uu___2 + | uu___ -> FStar_Pervasives_Native.None +let (try_lookup_lid_aux : + FStarC_Syntax_Syntax.universes FStar_Pervasives_Native.option -> + env -> + FStarC_Ident.lident -> + ((FStarC_Syntax_Syntax.universes * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax) * FStarC_Compiler_Range_Type.range) + FStar_Pervasives_Native.option) + = + fun us_opt -> + fun env1 -> + fun lid -> + let inst_tscheme1 ts = + match us_opt with + | FStar_Pervasives_Native.None -> inst_tscheme ts + | FStar_Pervasives_Native.Some us -> inst_tscheme_with ts us in + let mapper uu___ = + match uu___ with + | (lr, rng) -> + (match lr with + | FStar_Pervasives.Inl t -> + FStar_Pervasives_Native.Some (t, rng) + | FStar_Pervasives.Inr + ({ + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = uu___1; + FStarC_Syntax_Syntax.us1 = uvs; + FStarC_Syntax_Syntax.t1 = t; + FStarC_Syntax_Syntax.ty_lid = uu___2; + FStarC_Syntax_Syntax.num_ty_params = uu___3; + FStarC_Syntax_Syntax.mutuals1 = uu___4; + FStarC_Syntax_Syntax.injective_type_params1 = + uu___5;_}; + FStarC_Syntax_Syntax.sigrng = uu___6; + FStarC_Syntax_Syntax.sigquals = uu___7; + FStarC_Syntax_Syntax.sigmeta = uu___8; + FStarC_Syntax_Syntax.sigattrs = uu___9; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___10; + FStarC_Syntax_Syntax.sigopts = uu___11;_}, + FStar_Pervasives_Native.None) + -> + let uu___12 = + let uu___13 = inst_tscheme1 (uvs, t) in (uu___13, rng) in + FStar_Pervasives_Native.Some uu___12 + | FStar_Pervasives.Inr + ({ + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_declare_typ + { FStarC_Syntax_Syntax.lid2 = l; + FStarC_Syntax_Syntax.us2 = uvs; + FStarC_Syntax_Syntax.t2 = t;_}; + FStarC_Syntax_Syntax.sigrng = uu___1; + FStarC_Syntax_Syntax.sigquals = qs; + FStarC_Syntax_Syntax.sigmeta = uu___2; + FStarC_Syntax_Syntax.sigattrs = uu___3; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___4; + FStarC_Syntax_Syntax.sigopts = uu___5;_}, + FStar_Pervasives_Native.None) + -> + let uu___6 = + let uu___7 = in_cur_mod env1 l in uu___7 = Yes in + if uu___6 + then + (if + (FStarC_Compiler_List.contains + FStarC_Syntax_Syntax.Assumption qs) + || env1.is_iface + then + let uu___7 = + let uu___8 = inst_tscheme1 (uvs, t) in + (uu___8, rng) in + FStar_Pervasives_Native.Some uu___7 + else FStar_Pervasives_Native.None) + else + (let uu___8 = + let uu___9 = inst_tscheme1 (uvs, t) in (uu___9, rng) in + FStar_Pervasives_Native.Some uu___8) + | FStar_Pervasives.Inr + ({ + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = lid1; + FStarC_Syntax_Syntax.us = uvs; + FStarC_Syntax_Syntax.params = tps; + FStarC_Syntax_Syntax.num_uniform_params = uu___1; + FStarC_Syntax_Syntax.t = k; + FStarC_Syntax_Syntax.mutuals = uu___2; + FStarC_Syntax_Syntax.ds = uu___3; + FStarC_Syntax_Syntax.injective_type_params = uu___4;_}; + FStarC_Syntax_Syntax.sigrng = uu___5; + FStarC_Syntax_Syntax.sigquals = uu___6; + FStarC_Syntax_Syntax.sigmeta = uu___7; + FStarC_Syntax_Syntax.sigattrs = uu___8; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___9; + FStarC_Syntax_Syntax.sigopts = uu___10;_}, + FStar_Pervasives_Native.None) + -> + (match tps with + | [] -> + let uu___11 = + let uu___12 = inst_tscheme1 (uvs, k) in + (uu___12, rng) in + FStar_Pervasives_Native.Some uu___11 + | uu___11 -> + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = FStarC_Syntax_Syntax.mk_Total k in + FStarC_Syntax_Util.flat_arrow tps uu___16 in + (uvs, uu___15) in + inst_tscheme1 uu___14 in + (uu___13, rng) in + FStar_Pervasives_Native.Some uu___12) + | FStar_Pervasives.Inr + ({ + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = lid1; + FStarC_Syntax_Syntax.us = uvs; + FStarC_Syntax_Syntax.params = tps; + FStarC_Syntax_Syntax.num_uniform_params = uu___1; + FStarC_Syntax_Syntax.t = k; + FStarC_Syntax_Syntax.mutuals = uu___2; + FStarC_Syntax_Syntax.ds = uu___3; + FStarC_Syntax_Syntax.injective_type_params = uu___4;_}; + FStarC_Syntax_Syntax.sigrng = uu___5; + FStarC_Syntax_Syntax.sigquals = uu___6; + FStarC_Syntax_Syntax.sigmeta = uu___7; + FStarC_Syntax_Syntax.sigattrs = uu___8; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___9; + FStarC_Syntax_Syntax.sigopts = uu___10;_}, + FStar_Pervasives_Native.Some us) + -> + (match tps with + | [] -> + let uu___11 = + let uu___12 = inst_tscheme_with (uvs, k) us in + (uu___12, rng) in + FStar_Pervasives_Native.Some uu___11 + | uu___11 -> + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = FStarC_Syntax_Syntax.mk_Total k in + FStarC_Syntax_Util.flat_arrow tps uu___16 in + (uvs, uu___15) in + inst_tscheme_with uu___14 us in + (uu___13, rng) in + FStar_Pervasives_Native.Some uu___12) + | FStar_Pervasives.Inr se -> + let uu___1 = + match se with + | ({ + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_let uu___2; + FStarC_Syntax_Syntax.sigrng = uu___3; + FStarC_Syntax_Syntax.sigquals = uu___4; + FStarC_Syntax_Syntax.sigmeta = uu___5; + FStarC_Syntax_Syntax.sigattrs = uu___6; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___7; + FStarC_Syntax_Syntax.sigopts = uu___8;_}, + FStar_Pervasives_Native.None) -> + lookup_type_of_let us_opt + (FStar_Pervasives_Native.fst se) lid + | uu___2 -> + effect_signature us_opt + (FStar_Pervasives_Native.fst se) env1.range in + FStarC_Compiler_Util.map_option + (fun uu___2 -> + match uu___2 with | (us_t, rng1) -> (us_t, rng1)) + uu___1) in + let uu___ = + let uu___1 = lookup_qname env1 lid in + FStarC_Compiler_Util.bind_opt uu___1 mapper in + match uu___ with + | FStar_Pervasives_Native.Some ((us, t), r) -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Ident.range_of_lid lid in + { + FStarC_Syntax_Syntax.n = (t.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = uu___4; + FStarC_Syntax_Syntax.vars = (t.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (t.FStarC_Syntax_Syntax.hash_code) + } in + (us, uu___3) in + (uu___2, r) in + FStar_Pervasives_Native.Some uu___1 + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None +let (lid_exists : env -> FStarC_Ident.lident -> Prims.bool) = + fun env1 -> + fun l -> + let uu___ = lookup_qname env1 l in + match uu___ with + | FStar_Pervasives_Native.None -> false + | FStar_Pervasives_Native.Some uu___1 -> true +let (lookup_bv : + env -> + FStarC_Syntax_Syntax.bv -> + (FStarC_Syntax_Syntax.typ * FStarC_Compiler_Range_Type.range)) + = + fun env1 -> + fun bv -> + let bvr = FStarC_Syntax_Syntax.range_of_bv bv in + let uu___ = try_lookup_bv env1 bv in + match uu___ with + | FStar_Pervasives_Native.None -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_bv bv in + FStarC_Compiler_Util.format1 "Variable \"%s\" not found" uu___2 in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range bvr + FStarC_Errors_Codes.Fatal_VariableNotFound () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) + | FStar_Pervasives_Native.Some (t, r) -> + let uu___1 = FStarC_Syntax_Subst.set_use_range bvr t in + let uu___2 = + let uu___3 = FStarC_Compiler_Range_Type.use_range bvr in + FStarC_Compiler_Range_Type.set_use_range r uu___3 in + (uu___1, uu___2) +let (try_lookup_lid : + env -> + FStarC_Ident.lident -> + ((FStarC_Syntax_Syntax.universes * FStarC_Syntax_Syntax.typ) * + FStarC_Compiler_Range_Type.range) FStar_Pervasives_Native.option) + = + fun env1 -> + fun l -> + let uu___ = try_lookup_lid_aux FStar_Pervasives_Native.None env1 l in + match uu___ with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some ((us, t), r) -> + let use_range = FStarC_Ident.range_of_lid l in + let r1 = + let uu___1 = FStarC_Compiler_Range_Type.use_range use_range in + FStarC_Compiler_Range_Type.set_use_range r uu___1 in + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.set_use_range use_range t in + (us, uu___3) in + (uu___2, r1) in + FStar_Pervasives_Native.Some uu___1 +let (try_lookup_and_inst_lid : + env -> + FStarC_Syntax_Syntax.universes -> + FStarC_Ident.lident -> + (FStarC_Syntax_Syntax.typ * FStarC_Compiler_Range_Type.range) + FStar_Pervasives_Native.option) + = + fun env1 -> + fun us -> + fun l -> + let uu___ = + try_lookup_lid_aux (FStar_Pervasives_Native.Some us) env1 l in + match uu___ with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some ((uu___1, t), r) -> + let use_range = FStarC_Ident.range_of_lid l in + let r1 = + let uu___2 = FStarC_Compiler_Range_Type.use_range use_range in + FStarC_Compiler_Range_Type.set_use_range r uu___2 in + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.set_use_range use_range t in + (uu___3, r1) in + FStar_Pervasives_Native.Some uu___2 +let name_not_found : 'a . FStarC_Ident.lid -> 'a = + fun l -> + let uu___ = + let uu___1 = FStarC_Ident.string_of_lid l in + FStarC_Compiler_Util.format1 "Name \"%s\" not found" uu___1 in + FStarC_Errors.raise_error FStarC_Ident.hasrange_lident l + FStarC_Errors_Codes.Fatal_NameNotFound () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) (Obj.magic uu___) +let (lookup_lid : + env -> + FStarC_Ident.lident -> + ((FStarC_Syntax_Syntax.universes * FStarC_Syntax_Syntax.typ) * + FStarC_Compiler_Range_Type.range)) + = + fun env1 -> + fun l -> + let uu___ = try_lookup_lid env1 l in + match uu___ with + | FStar_Pervasives_Native.Some v -> v + | FStar_Pervasives_Native.None -> name_not_found l +let (lookup_univ : env -> FStarC_Syntax_Syntax.univ_name -> Prims.bool) = + fun env1 -> + fun x -> + let uu___ = + FStarC_Compiler_List.find + (fun uu___1 -> + match uu___1 with + | FStarC_Syntax_Syntax.Binding_univ y -> + let uu___2 = FStarC_Ident.string_of_id x in + let uu___3 = FStarC_Ident.string_of_id y in uu___2 = uu___3 + | uu___2 -> false) env1.gamma in + FStarC_Compiler_Option.isSome uu___ +let (try_lookup_val_decl : + env -> + FStarC_Ident.lident -> + (FStarC_Syntax_Syntax.tscheme * FStarC_Syntax_Syntax.qualifier + Prims.list) FStar_Pervasives_Native.option) + = + fun env1 -> + fun lid -> + let uu___ = lookup_qname env1 lid in + match uu___ with + | FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr + ({ + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_declare_typ + { FStarC_Syntax_Syntax.lid2 = uu___1; + FStarC_Syntax_Syntax.us2 = uvs; + FStarC_Syntax_Syntax.t2 = t;_}; + FStarC_Syntax_Syntax.sigrng = uu___2; + FStarC_Syntax_Syntax.sigquals = q; + FStarC_Syntax_Syntax.sigmeta = uu___3; + FStarC_Syntax_Syntax.sigattrs = uu___4; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___5; + FStarC_Syntax_Syntax.sigopts = uu___6;_}, + FStar_Pervasives_Native.None), + uu___7) + -> + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = FStarC_Ident.range_of_lid lid in + FStarC_Syntax_Subst.set_use_range uu___11 t in + (uvs, uu___10) in + (uu___9, q) in + FStar_Pervasives_Native.Some uu___8 + | uu___1 -> FStar_Pervasives_Native.None +let (lookup_val_decl : + env -> + FStarC_Ident.lident -> + (FStarC_Syntax_Syntax.universes * FStarC_Syntax_Syntax.typ)) + = + fun env1 -> + fun lid -> + let uu___ = lookup_qname env1 lid in + match uu___ with + | FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr + ({ + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_declare_typ + { FStarC_Syntax_Syntax.lid2 = uu___1; + FStarC_Syntax_Syntax.us2 = uvs; + FStarC_Syntax_Syntax.t2 = t;_}; + FStarC_Syntax_Syntax.sigrng = uu___2; + FStarC_Syntax_Syntax.sigquals = uu___3; + FStarC_Syntax_Syntax.sigmeta = uu___4; + FStarC_Syntax_Syntax.sigattrs = uu___5; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___6; + FStarC_Syntax_Syntax.sigopts = uu___7;_}, + FStar_Pervasives_Native.None), + uu___8) + -> + let uu___9 = FStarC_Ident.range_of_lid lid in + inst_tscheme_with_range uu___9 (uvs, t) + | uu___1 -> name_not_found lid +let (lookup_datacon : + env -> + FStarC_Ident.lident -> + (FStarC_Syntax_Syntax.universes * FStarC_Syntax_Syntax.typ)) + = + fun env1 -> + fun lid -> + let uu___ = lookup_qname env1 lid in + match uu___ with + | FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr + ({ + FStarC_Syntax_Syntax.sigel = FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = uu___1; + FStarC_Syntax_Syntax.us1 = uvs; + FStarC_Syntax_Syntax.t1 = t; + FStarC_Syntax_Syntax.ty_lid = uu___2; + FStarC_Syntax_Syntax.num_ty_params = uu___3; + FStarC_Syntax_Syntax.mutuals1 = uu___4; + FStarC_Syntax_Syntax.injective_type_params1 = uu___5;_}; + FStarC_Syntax_Syntax.sigrng = uu___6; + FStarC_Syntax_Syntax.sigquals = uu___7; + FStarC_Syntax_Syntax.sigmeta = uu___8; + FStarC_Syntax_Syntax.sigattrs = uu___9; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___10; + FStarC_Syntax_Syntax.sigopts = uu___11;_}, + FStar_Pervasives_Native.None), + uu___12) + -> + let uu___13 = FStarC_Ident.range_of_lid lid in + inst_tscheme_with_range uu___13 (uvs, t) + | uu___1 -> name_not_found lid +let (lookup_and_inst_datacon : + env -> + FStarC_Syntax_Syntax.universes -> + FStarC_Ident.lident -> FStarC_Syntax_Syntax.typ) + = + fun env1 -> + fun us -> + fun lid -> + let uu___ = lookup_qname env1 lid in + match uu___ with + | FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr + ({ + FStarC_Syntax_Syntax.sigel = FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = uu___1; + FStarC_Syntax_Syntax.us1 = uvs; + FStarC_Syntax_Syntax.t1 = t; + FStarC_Syntax_Syntax.ty_lid = uu___2; + FStarC_Syntax_Syntax.num_ty_params = uu___3; + FStarC_Syntax_Syntax.mutuals1 = uu___4; + FStarC_Syntax_Syntax.injective_type_params1 = uu___5;_}; + FStarC_Syntax_Syntax.sigrng = uu___6; + FStarC_Syntax_Syntax.sigquals = uu___7; + FStarC_Syntax_Syntax.sigmeta = uu___8; + FStarC_Syntax_Syntax.sigattrs = uu___9; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___10; + FStarC_Syntax_Syntax.sigopts = uu___11;_}, + FStar_Pervasives_Native.None), + uu___12) + -> + let uu___13 = inst_tscheme_with (uvs, t) us in + FStar_Pervasives_Native.snd uu___13 + | uu___1 -> name_not_found lid +let (datacons_of_typ : + env -> FStarC_Ident.lident -> (Prims.bool * FStarC_Ident.lident Prims.list)) + = + fun env1 -> + fun lid -> + let uu___ = lookup_qname env1 lid in + match uu___ with + | FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr + ({ + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = uu___1; + FStarC_Syntax_Syntax.us = uu___2; + FStarC_Syntax_Syntax.params = uu___3; + FStarC_Syntax_Syntax.num_uniform_params = uu___4; + FStarC_Syntax_Syntax.t = uu___5; + FStarC_Syntax_Syntax.mutuals = uu___6; + FStarC_Syntax_Syntax.ds = dcs; + FStarC_Syntax_Syntax.injective_type_params = uu___7;_}; + FStarC_Syntax_Syntax.sigrng = uu___8; + FStarC_Syntax_Syntax.sigquals = uu___9; + FStarC_Syntax_Syntax.sigmeta = uu___10; + FStarC_Syntax_Syntax.sigattrs = uu___11; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___12; + FStarC_Syntax_Syntax.sigopts = uu___13;_}, + uu___14), + uu___15) + -> (true, dcs) + | uu___1 -> (false, []) +let (typ_of_datacon : env -> FStarC_Ident.lident -> FStarC_Ident.lident) = + fun env1 -> + fun lid -> + let uu___ = lookup_qname env1 lid in + match uu___ with + | FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr + ({ + FStarC_Syntax_Syntax.sigel = FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = uu___1; + FStarC_Syntax_Syntax.us1 = uu___2; + FStarC_Syntax_Syntax.t1 = uu___3; + FStarC_Syntax_Syntax.ty_lid = l; + FStarC_Syntax_Syntax.num_ty_params = uu___4; + FStarC_Syntax_Syntax.mutuals1 = uu___5; + FStarC_Syntax_Syntax.injective_type_params1 = uu___6;_}; + FStarC_Syntax_Syntax.sigrng = uu___7; + FStarC_Syntax_Syntax.sigquals = uu___8; + FStarC_Syntax_Syntax.sigmeta = uu___9; + FStarC_Syntax_Syntax.sigattrs = uu___10; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___11; + FStarC_Syntax_Syntax.sigopts = uu___12;_}, + uu___13), + uu___14) + -> l + | uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Ident.showable_lident lid in + FStarC_Compiler_Util.format1 "Not a datacon: %s" uu___3 in + failwith uu___2 +let (num_datacon_non_injective_ty_params : + env -> FStarC_Ident.lident -> Prims.int FStar_Pervasives_Native.option) = + fun env1 -> + fun lid -> + let uu___ = lookup_qname env1 lid in + match uu___ with + | FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr + ({ + FStarC_Syntax_Syntax.sigel = FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = uu___1; + FStarC_Syntax_Syntax.us1 = uu___2; + FStarC_Syntax_Syntax.t1 = uu___3; + FStarC_Syntax_Syntax.ty_lid = uu___4; + FStarC_Syntax_Syntax.num_ty_params = num_ty_params; + FStarC_Syntax_Syntax.mutuals1 = uu___5; + FStarC_Syntax_Syntax.injective_type_params1 = + injective_type_params;_}; + FStarC_Syntax_Syntax.sigrng = uu___6; + FStarC_Syntax_Syntax.sigquals = uu___7; + FStarC_Syntax_Syntax.sigmeta = uu___8; + FStarC_Syntax_Syntax.sigattrs = uu___9; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___10; + FStarC_Syntax_Syntax.sigopts = uu___11;_}, + uu___12), + uu___13) + -> + if injective_type_params + then FStar_Pervasives_Native.Some Prims.int_zero + else FStar_Pervasives_Native.Some num_ty_params + | uu___1 -> FStar_Pervasives_Native.None +let (visible_with : + delta_level Prims.list -> + FStarC_Syntax_Syntax.qualifier Prims.list -> Prims.bool) + = + fun delta_levels -> + fun quals -> + FStarC_Compiler_Util.for_some + (fun dl -> FStarC_Compiler_Util.for_some (visible_at dl) quals) + delta_levels +let (lookup_definition_qninfo_aux : + Prims.bool -> + delta_level Prims.list -> + FStarC_Ident.lident -> + qninfo -> + (FStarC_Syntax_Syntax.univ_name Prims.list * + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + FStar_Pervasives_Native.option) + = + fun rec_ok -> + fun delta_levels -> + fun lid -> + fun qninfo1 -> + match qninfo1 with + | FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr (se, FStar_Pervasives_Native.None), + uu___) + -> + (match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (is_rec, lbs); + FStarC_Syntax_Syntax.lids1 = uu___1;_} + when + (visible_with delta_levels + se.FStarC_Syntax_Syntax.sigquals) + && ((Prims.op_Negation is_rec) || rec_ok) + -> + FStarC_Compiler_Util.find_map lbs + (fun lb -> + let fv = + FStarC_Compiler_Util.right + lb.FStarC_Syntax_Syntax.lbname in + let uu___2 = FStarC_Syntax_Syntax.fv_eq_lid fv lid in + if uu___2 + then + FStar_Pervasives_Native.Some + ((lb.FStarC_Syntax_Syntax.lbunivs), + (lb.FStarC_Syntax_Syntax.lbdef)) + else FStar_Pervasives_Native.None) + | uu___1 -> FStar_Pervasives_Native.None) + | uu___ -> FStar_Pervasives_Native.None +let (lookup_definition_qninfo : + delta_level Prims.list -> + FStarC_Ident.lident -> + qninfo -> + (FStarC_Syntax_Syntax.univ_names * FStarC_Syntax_Syntax.term) + FStar_Pervasives_Native.option) + = + fun delta_levels -> + fun lid -> + fun qninfo1 -> + lookup_definition_qninfo_aux true delta_levels lid qninfo1 +let (lookup_definition : + delta_level Prims.list -> + env -> + FStarC_Ident.lident -> + (FStarC_Syntax_Syntax.univ_names * FStarC_Syntax_Syntax.term) + FStar_Pervasives_Native.option) + = + fun delta_levels -> + fun env1 -> + fun lid -> + let uu___ = lookup_qname env1 lid in + lookup_definition_qninfo delta_levels lid uu___ +let (lookup_nonrec_definition : + delta_level Prims.list -> + env -> + FStarC_Ident.lident -> + (FStarC_Syntax_Syntax.univ_names * FStarC_Syntax_Syntax.term) + FStar_Pervasives_Native.option) + = + fun delta_levels -> + fun env1 -> + fun lid -> + let uu___ = lookup_qname env1 lid in + lookup_definition_qninfo_aux false delta_levels lid uu___ +let rec (delta_depth_of_qninfo_lid : + env -> FStarC_Ident.lident -> qninfo -> FStarC_Syntax_Syntax.delta_depth) = + fun env1 -> + fun lid -> + fun qn -> + match qn with + | FStar_Pervasives_Native.None -> FStarC_Syntax_Syntax.delta_constant + | FStar_Pervasives_Native.Some (FStar_Pervasives.Inl uu___, uu___1) + -> FStarC_Syntax_Syntax.delta_constant + | FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr (se, uu___), uu___1) -> + (match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_inductive_typ uu___2 -> + FStarC_Syntax_Syntax.delta_constant + | FStarC_Syntax_Syntax.Sig_bundle uu___2 -> + FStarC_Syntax_Syntax.delta_constant + | FStarC_Syntax_Syntax.Sig_datacon uu___2 -> + FStarC_Syntax_Syntax.delta_constant + | FStarC_Syntax_Syntax.Sig_declare_typ uu___2 -> + let d0 = + let uu___3 = FStarC_Syntax_Util.is_primop_lid lid in + if uu___3 + then FStarC_Syntax_Syntax.delta_equational + else FStarC_Syntax_Syntax.delta_constant in + let uu___3 = + (FStarC_Compiler_Util.for_some + FStarC_Syntax_Syntax.uu___is_Assumption + se.FStarC_Syntax_Syntax.sigquals) + && + (let uu___4 = + FStarC_Compiler_Util.for_some + FStarC_Syntax_Syntax.uu___is_New + se.FStarC_Syntax_Syntax.sigquals in + Prims.op_Negation uu___4) in + if uu___3 + then FStarC_Syntax_Syntax.Delta_abstract d0 + else d0 + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (uu___2, lbs); + FStarC_Syntax_Syntax.lids1 = uu___3;_} + -> + let uu___4 = + FStarC_Compiler_Util.find_map lbs + (fun lb -> + let fv = + FStarC_Compiler_Util.right + lb.FStarC_Syntax_Syntax.lbname in + let uu___5 = FStarC_Syntax_Syntax.fv_eq_lid fv lid in + if uu___5 + then + let uu___6 = + let uu___7 = + delta_depth_of_term env1 + lb.FStarC_Syntax_Syntax.lbdef in + FStarC_Syntax_Util.incr_delta_depth uu___7 in + FStar_Pervasives_Native.Some uu___6 + else FStar_Pervasives_Native.None) in + FStarC_Compiler_Util.must uu___4 + | FStarC_Syntax_Syntax.Sig_fail uu___2 -> + failwith "impossible: delta_depth_of_qninfo" + | FStarC_Syntax_Syntax.Sig_splice uu___2 -> + failwith "impossible: delta_depth_of_qninfo" + | FStarC_Syntax_Syntax.Sig_assume uu___2 -> + FStarC_Syntax_Syntax.delta_constant + | FStarC_Syntax_Syntax.Sig_new_effect uu___2 -> + FStarC_Syntax_Syntax.delta_constant + | FStarC_Syntax_Syntax.Sig_sub_effect uu___2 -> + FStarC_Syntax_Syntax.delta_constant + | FStarC_Syntax_Syntax.Sig_effect_abbrev uu___2 -> + FStarC_Syntax_Syntax.delta_constant + | FStarC_Syntax_Syntax.Sig_pragma uu___2 -> + FStarC_Syntax_Syntax.delta_constant + | FStarC_Syntax_Syntax.Sig_polymonadic_bind uu___2 -> + FStarC_Syntax_Syntax.delta_constant + | FStarC_Syntax_Syntax.Sig_polymonadic_subcomp uu___2 -> + FStarC_Syntax_Syntax.delta_constant) +and (delta_depth_of_qninfo : + env -> + FStarC_Syntax_Syntax.fv -> qninfo -> FStarC_Syntax_Syntax.delta_depth) + = + fun env1 -> + fun fv -> + fun qn -> + delta_depth_of_qninfo_lid env1 + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v qn +and (delta_depth_of_fv : + env -> FStarC_Syntax_Syntax.fv -> FStarC_Syntax_Syntax.delta_depth) = + fun env1 -> + fun fv -> + let lid = (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + let uu___ = + let uu___1 = FStarC_Ident.string_of_lid lid in + FStarC_Compiler_Util.smap_try_find env1.fv_delta_depths uu___1 in + match uu___ with + | FStar_Pervasives_Native.Some dd -> dd + | FStar_Pervasives_Native.None -> + ((let uu___2 = FStarC_Ident.string_of_lid lid in + FStarC_Compiler_Util.smap_add env1.fv_delta_depths uu___2 + FStarC_Syntax_Syntax.delta_equational); + (let d = + let uu___2 = + lookup_qname env1 + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + delta_depth_of_qninfo env1 fv uu___2 in + (let uu___3 = FStarC_Ident.string_of_lid lid in + FStarC_Compiler_Util.smap_add env1.fv_delta_depths uu___3 d); + d)) +and (fv_delta_depth : + env -> FStarC_Syntax_Syntax.fv -> FStarC_Syntax_Syntax.delta_depth) = + fun env1 -> + fun fv -> + let d = delta_depth_of_fv env1 fv in + match d with + | FStarC_Syntax_Syntax.Delta_abstract + (FStarC_Syntax_Syntax.Delta_constant_at_level l) -> + let uu___ = + (let uu___1 = FStarC_Ident.string_of_lid env1.curmodule in + let uu___2 = + FStarC_Ident.nsstr + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + uu___1 = uu___2) && (Prims.op_Negation env1.is_iface) in + if uu___ + then FStarC_Syntax_Syntax.Delta_constant_at_level l + else FStarC_Syntax_Syntax.delta_constant + | d1 -> d1 +and (delta_depth_of_term : + env -> FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.delta_depth) = + fun env1 -> + fun t -> + let t1 = FStarC_Syntax_Util.unmeta t in + match t1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_meta uu___ -> + failwith "Impossible (delta depth of term)" + | FStarC_Syntax_Syntax.Tm_delayed uu___ -> + failwith "Impossible (delta depth of term)" + | FStarC_Syntax_Syntax.Tm_lazy i -> + let uu___ = FStarC_Syntax_Util.unfold_lazy i in + delta_depth_of_term env1 uu___ + | FStarC_Syntax_Syntax.Tm_fvar fv -> fv_delta_depth env1 fv + | FStarC_Syntax_Syntax.Tm_bvar uu___ -> + FStarC_Syntax_Syntax.delta_equational + | FStarC_Syntax_Syntax.Tm_name uu___ -> + FStarC_Syntax_Syntax.delta_equational + | FStarC_Syntax_Syntax.Tm_match uu___ -> + FStarC_Syntax_Syntax.delta_equational + | FStarC_Syntax_Syntax.Tm_uvar uu___ -> + FStarC_Syntax_Syntax.delta_equational + | FStarC_Syntax_Syntax.Tm_unknown -> + FStarC_Syntax_Syntax.delta_equational + | FStarC_Syntax_Syntax.Tm_type uu___ -> + FStarC_Syntax_Syntax.delta_constant + | FStarC_Syntax_Syntax.Tm_quoted uu___ -> + FStarC_Syntax_Syntax.delta_constant + | FStarC_Syntax_Syntax.Tm_constant uu___ -> + FStarC_Syntax_Syntax.delta_constant + | FStarC_Syntax_Syntax.Tm_arrow uu___ -> + FStarC_Syntax_Syntax.delta_constant + | FStarC_Syntax_Syntax.Tm_uinst (t2, uu___) -> + delta_depth_of_term env1 t2 + | FStarC_Syntax_Syntax.Tm_refine + { + FStarC_Syntax_Syntax.b = + { FStarC_Syntax_Syntax.ppname = uu___; + FStarC_Syntax_Syntax.index = uu___1; + FStarC_Syntax_Syntax.sort = t2;_}; + FStarC_Syntax_Syntax.phi = uu___2;_} + -> delta_depth_of_term env1 t2 + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t2; FStarC_Syntax_Syntax.asc = uu___; + FStarC_Syntax_Syntax.eff_opt = uu___1;_} + -> delta_depth_of_term env1 t2 + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = t2; + FStarC_Syntax_Syntax.args = uu___;_} + -> delta_depth_of_term env1 t2 + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = uu___; FStarC_Syntax_Syntax.body = t2; + FStarC_Syntax_Syntax.rc_opt = uu___1;_} + -> delta_depth_of_term env1 t2 + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = uu___; + FStarC_Syntax_Syntax.body1 = t2;_} + -> delta_depth_of_term env1 t2 +let (quals_of_qninfo : + qninfo -> + FStarC_Syntax_Syntax.qualifier Prims.list FStar_Pervasives_Native.option) + = + fun qninfo1 -> + match qninfo1 with + | FStar_Pervasives_Native.Some (FStar_Pervasives.Inr (se, uu___), uu___1) + -> FStar_Pervasives_Native.Some (se.FStarC_Syntax_Syntax.sigquals) + | uu___ -> FStar_Pervasives_Native.None +let (attrs_of_qninfo : + qninfo -> + FStarC_Syntax_Syntax.attribute Prims.list FStar_Pervasives_Native.option) + = + fun qninfo1 -> + match qninfo1 with + | FStar_Pervasives_Native.Some (FStar_Pervasives.Inr (se, uu___), uu___1) + -> FStar_Pervasives_Native.Some (se.FStarC_Syntax_Syntax.sigattrs) + | uu___ -> FStar_Pervasives_Native.None +let (lookup_attrs_of_lid : + env -> + FStarC_Ident.lid -> + FStarC_Syntax_Syntax.attribute Prims.list + FStar_Pervasives_Native.option) + = + fun env1 -> + fun lid -> let uu___ = lookup_qname env1 lid in attrs_of_qninfo uu___ +let (fv_exists_and_has_attr : + env -> FStarC_Ident.lid -> FStarC_Ident.lident -> (Prims.bool * Prims.bool)) + = + fun env1 -> + fun fv_lid -> + fun attr_lid -> + let uu___ = lookup_attrs_of_lid env1 fv_lid in + match uu___ with + | FStar_Pervasives_Native.None -> (false, false) + | FStar_Pervasives_Native.Some attrs -> + let uu___1 = + FStarC_Compiler_Util.for_some + (fun tm -> + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst tm in + uu___3.FStarC_Syntax_Syntax.n in + match uu___2 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + FStarC_Syntax_Syntax.fv_eq_lid fv attr_lid + | uu___3 -> false) attrs in + (true, uu___1) +let (fv_with_lid_has_attr : + env -> FStarC_Ident.lid -> FStarC_Ident.lid -> Prims.bool) = + fun env1 -> + fun fv_lid -> + fun attr_lid -> + let uu___ = fv_exists_and_has_attr env1 fv_lid attr_lid in + FStar_Pervasives_Native.snd uu___ +let (fv_has_attr : + env -> FStarC_Syntax_Syntax.fv -> FStarC_Ident.lid -> Prims.bool) = + fun env1 -> + fun fv -> + fun attr_lid -> + fv_with_lid_has_attr env1 + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v attr_lid +let cache_in_fv_tab : + 'a . + 'a FStarC_Compiler_Util.smap -> + FStarC_Syntax_Syntax.fv -> (unit -> (Prims.bool * 'a)) -> 'a + = + fun tab -> + fun fv -> + fun f -> + let s = + let uu___ = FStarC_Syntax_Syntax.lid_of_fv fv in + FStarC_Ident.string_of_lid uu___ in + let uu___ = FStarC_Compiler_Util.smap_try_find tab s in + match uu___ with + | FStar_Pervasives_Native.None -> + let uu___1 = f () in + (match uu___1 with + | (should_cache, res) -> + (if should_cache + then FStarC_Compiler_Util.smap_add tab s res + else (); + res)) + | FStar_Pervasives_Native.Some r -> r +let (fv_has_erasable_attr : env -> FStarC_Syntax_Syntax.fv -> Prims.bool) = + fun env1 -> + fun fv -> + let f uu___ = + let uu___1 = + fv_exists_and_has_attr env1 + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + FStarC_Parser_Const.erasable_attr in + match uu___1 with | (ex, erasable) -> (ex, erasable) in + cache_in_fv_tab env1.erasable_types_tab fv f +let (fv_has_strict_args : + env -> + FStarC_Syntax_Syntax.fv -> + Prims.int Prims.list FStar_Pervasives_Native.option) + = + fun env1 -> + fun fv -> + let f uu___ = + let attrs = + let uu___1 = FStarC_Syntax_Syntax.lid_of_fv fv in + lookup_attrs_of_lid env1 uu___1 in + match attrs with + | FStar_Pervasives_Native.None -> + (false, FStar_Pervasives_Native.None) + | FStar_Pervasives_Native.Some attrs1 -> + let res = + FStarC_Compiler_Util.find_map attrs1 + (fun x -> + let uu___1 = + FStarC_ToSyntax_ToSyntax.parse_attr_with_list false x + FStarC_Parser_Const.strict_on_arguments_attr in + FStar_Pervasives_Native.fst uu___1) in + (true, res) in + cache_in_fv_tab env1.strict_args_tab fv f +let (try_lookup_effect_lid : + env -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = + fun env1 -> + fun ftv -> + let uu___ = lookup_qname env1 ftv in + match uu___ with + | FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr (se, FStar_Pervasives_Native.None), uu___1) + -> + let uu___2 = + effect_signature FStar_Pervasives_Native.None se env1.range in + (match uu___2 with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some ((uu___3, t), r) -> + let uu___4 = + let uu___5 = FStarC_Ident.range_of_lid ftv in + FStarC_Syntax_Subst.set_use_range uu___5 t in + FStar_Pervasives_Native.Some uu___4) + | uu___1 -> FStar_Pervasives_Native.None +let (lookup_effect_lid : + env -> FStarC_Ident.lident -> FStarC_Syntax_Syntax.term) = + fun env1 -> + fun ftv -> + let uu___ = try_lookup_effect_lid env1 ftv in + match uu___ with + | FStar_Pervasives_Native.None -> name_not_found ftv + | FStar_Pervasives_Native.Some k -> k +let (lookup_effect_abbrev : + env -> + FStarC_Syntax_Syntax.universes -> + FStarC_Ident.lident -> + (FStarC_Syntax_Syntax.binders * FStarC_Syntax_Syntax.comp) + FStar_Pervasives_Native.option) + = + fun env1 -> + fun univ_insts -> + fun lid0 -> + let uu___ = lookup_qname env1 lid0 in + match uu___ with + | FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr + ({ + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_effect_abbrev + { FStarC_Syntax_Syntax.lid4 = lid; + FStarC_Syntax_Syntax.us4 = univs; + FStarC_Syntax_Syntax.bs2 = binders; + FStarC_Syntax_Syntax.comp1 = c; + FStarC_Syntax_Syntax.cflags = uu___1;_}; + FStarC_Syntax_Syntax.sigrng = uu___2; + FStarC_Syntax_Syntax.sigquals = quals; + FStarC_Syntax_Syntax.sigmeta = uu___3; + FStarC_Syntax_Syntax.sigattrs = uu___4; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___5; + FStarC_Syntax_Syntax.sigopts = uu___6;_}, + FStar_Pervasives_Native.None), + uu___7) + -> + let lid1 = + let uu___8 = + let uu___9 = FStarC_Ident.range_of_lid lid in + let uu___10 = + let uu___11 = FStarC_Ident.range_of_lid lid0 in + FStarC_Compiler_Range_Type.use_range uu___11 in + FStarC_Compiler_Range_Type.set_use_range uu___9 uu___10 in + FStarC_Ident.set_lid_range lid uu___8 in + let uu___8 = + FStarC_Compiler_Util.for_some + (fun uu___9 -> + match uu___9 with + | FStarC_Syntax_Syntax.Irreducible -> true + | uu___10 -> false) quals in + if uu___8 + then FStar_Pervasives_Native.None + else + (let insts = + if + (FStarC_Compiler_List.length univ_insts) = + (FStarC_Compiler_List.length univs) + then univ_insts + else + (let uu___11 = + let uu___12 = + let uu___13 = get_range env1 in + FStarC_Compiler_Range_Ops.string_of_range uu___13 in + let uu___13 = + FStarC_Class_Show.show FStarC_Ident.showable_lident + lid1 in + let uu___14 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length univ_insts) in + FStarC_Compiler_Util.format3 + "(%s) Unexpected instantiation of effect %s with %s universes" + uu___12 uu___13 uu___14 in + failwith uu___11) in + match (binders, univs) with + | ([], uu___10) -> + failwith + "Unexpected effect abbreviation with no arguments" + | (uu___10, uu___11::uu___12::uu___13) -> + let uu___14 = + let uu___15 = + FStarC_Class_Show.show FStarC_Ident.showable_lident + lid1 in + let uu___16 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length univs) in + FStarC_Compiler_Util.format2 + "Unexpected effect abbreviation %s; polymorphic in %s universes" + uu___15 uu___16 in + failwith uu___14 + | uu___10 -> + let uu___11 = + let uu___12 = + let uu___13 = FStarC_Syntax_Util.arrow binders c in + (univs, uu___13) in + inst_tscheme_with uu___12 insts in + (match uu___11 with + | (uu___12, t) -> + let t1 = + let uu___13 = FStarC_Ident.range_of_lid lid1 in + FStarC_Syntax_Subst.set_use_range uu___13 t in + let uu___13 = + let uu___14 = FStarC_Syntax_Subst.compress t1 in + uu___14.FStarC_Syntax_Syntax.n in + (match uu___13 with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = binders1; + FStarC_Syntax_Syntax.comp = c1;_} + -> FStar_Pervasives_Native.Some (binders1, c1) + | uu___14 -> failwith "Impossible"))) + | uu___1 -> FStar_Pervasives_Native.None +let (norm_eff_name : env -> FStarC_Ident.lident -> FStarC_Ident.lident) = + fun env1 -> + fun l -> + let rec find l1 = + let uu___ = + lookup_effect_abbrev env1 [FStarC_Syntax_Syntax.U_unknown] l1 in + match uu___ with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (uu___1, c) -> + let l2 = FStarC_Syntax_Util.comp_effect_name c in + let uu___2 = find l2 in + (match uu___2 with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.Some l2 + | FStar_Pervasives_Native.Some l' -> + FStar_Pervasives_Native.Some l') in + let res = + let uu___ = + let uu___1 = FStarC_Ident.string_of_lid l in + FStarC_Compiler_Util.smap_try_find env1.normalized_eff_names uu___1 in + match uu___ with + | FStar_Pervasives_Native.Some l1 -> l1 + | FStar_Pervasives_Native.None -> + let uu___1 = find l in + (match uu___1 with + | FStar_Pervasives_Native.None -> l + | FStar_Pervasives_Native.Some m -> + ((let uu___3 = FStarC_Ident.string_of_lid l in + FStarC_Compiler_Util.smap_add env1.normalized_eff_names + uu___3 m); + m)) in + let uu___ = FStarC_Ident.range_of_lid l in + FStarC_Ident.set_lid_range res uu___ +let (is_erasable_effect : env -> FStarC_Ident.lident -> Prims.bool) = + fun env1 -> + fun l -> + let uu___ = norm_eff_name env1 l in + (FStarC_Ident.lid_equals uu___ FStarC_Parser_Const.effect_GHOST_lid) || + (let uu___1 = + FStarC_Syntax_Syntax.lid_as_fv uu___ FStar_Pervasives_Native.None in + fv_has_erasable_attr env1 uu___1) +let rec (non_informative : env -> FStarC_Syntax_Syntax.typ -> Prims.bool) = + fun env1 -> + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Util.unrefine t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_type uu___1 -> true + | FStarC_Syntax_Syntax.Tm_fvar fv -> + (((FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.unit_lid) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.squash_lid)) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.erased_lid)) + || (fv_has_erasable_attr env1 fv) + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = uu___1;_} + -> non_informative env1 head + | FStarC_Syntax_Syntax.Tm_uinst (t1, uu___1) -> non_informative env1 t1 + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = uu___1; + FStarC_Syntax_Syntax.comp = c;_} + -> + ((FStarC_Syntax_Util.is_pure_or_ghost_comp c) && + (non_informative env1 (FStarC_Syntax_Util.comp_result c))) + || + (is_erasable_effect env1 (FStarC_Syntax_Util.comp_effect_name c)) + | uu___1 -> false +let (num_effect_indices : + env -> FStarC_Ident.lident -> FStarC_Compiler_Range_Type.range -> Prims.int) + = + fun env1 -> + fun name -> + fun r -> + let sig_t = + let uu___ = lookup_effect_lid env1 name in + FStarC_Syntax_Subst.compress uu___ in + match sig_t.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = _a::bs; + FStarC_Syntax_Syntax.comp = uu___;_} + -> FStarC_Compiler_List.length bs + | uu___ -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Ident.showable_lident name in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + sig_t in + FStarC_Compiler_Util.format2 + "Signature for %s not an arrow (%s)" uu___2 uu___3 in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_UnexpectedSignatureForMonad () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) +let (lookup_effect_quals : + env -> FStarC_Ident.lident -> FStarC_Syntax_Syntax.qualifier Prims.list) = + fun env1 -> + fun l -> + let l1 = norm_eff_name env1 l in + let uu___ = lookup_qname env1 l1 in + match uu___ with + | FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr + ({ + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_new_effect uu___1; + FStarC_Syntax_Syntax.sigrng = uu___2; + FStarC_Syntax_Syntax.sigquals = q; + FStarC_Syntax_Syntax.sigmeta = uu___3; + FStarC_Syntax_Syntax.sigattrs = uu___4; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___5; + FStarC_Syntax_Syntax.sigopts = uu___6;_}, + uu___7), + uu___8) + -> q + | uu___1 -> [] +let (lookup_projector : + env -> FStarC_Ident.lident -> Prims.int -> FStarC_Ident.lident) = + fun env1 -> + fun lid -> + fun i -> + let fail uu___ = + let uu___1 = + let uu___2 = FStarC_Compiler_Util.string_of_int i in + let uu___3 = + FStarC_Class_Show.show FStarC_Ident.showable_lident lid in + FStarC_Compiler_Util.format2 + "Impossible: projecting field #%s from constructor %s is undefined" + uu___2 uu___3 in + failwith uu___1 in + let uu___ = lookup_datacon env1 lid in + match uu___ with + | (uu___1, t) -> + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress t in + uu___3.FStarC_Syntax_Syntax.n in + (match uu___2 with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = binders; + FStarC_Syntax_Syntax.comp = uu___3;_} + -> + if + (i < Prims.int_zero) || + (i >= (FStarC_Compiler_List.length binders)) + then fail () + else + (let b = FStarC_Compiler_List.nth binders i in + FStarC_Syntax_Util.mk_field_projector_name lid + b.FStarC_Syntax_Syntax.binder_bv i) + | uu___3 -> fail ()) +let (is_projector : env -> FStarC_Ident.lident -> Prims.bool) = + fun env1 -> + fun l -> + let uu___ = lookup_qname env1 l in + match uu___ with + | FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr + ({ + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_declare_typ uu___1; + FStarC_Syntax_Syntax.sigrng = uu___2; + FStarC_Syntax_Syntax.sigquals = quals; + FStarC_Syntax_Syntax.sigmeta = uu___3; + FStarC_Syntax_Syntax.sigattrs = uu___4; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___5; + FStarC_Syntax_Syntax.sigopts = uu___6;_}, + uu___7), + uu___8) + -> + FStarC_Compiler_Util.for_some + (fun uu___9 -> + match uu___9 with + | FStarC_Syntax_Syntax.Projector uu___10 -> true + | uu___10 -> false) quals + | uu___1 -> false +let (is_datacon : env -> FStarC_Ident.lident -> Prims.bool) = + fun env1 -> + fun lid -> + let uu___ = lookup_qname env1 lid in + match uu___ with + | FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr + ({ + FStarC_Syntax_Syntax.sigel = FStarC_Syntax_Syntax.Sig_datacon + uu___1; + FStarC_Syntax_Syntax.sigrng = uu___2; + FStarC_Syntax_Syntax.sigquals = uu___3; + FStarC_Syntax_Syntax.sigmeta = uu___4; + FStarC_Syntax_Syntax.sigattrs = uu___5; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___6; + FStarC_Syntax_Syntax.sigopts = uu___7;_}, + uu___8), + uu___9) + -> true + | uu___1 -> false +let (is_record : env -> FStarC_Ident.lident -> Prims.bool) = + fun env1 -> + fun lid -> + let uu___ = lookup_qname env1 lid in + match uu___ with + | FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr + ({ + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_inductive_typ uu___1; + FStarC_Syntax_Syntax.sigrng = uu___2; + FStarC_Syntax_Syntax.sigquals = quals; + FStarC_Syntax_Syntax.sigmeta = uu___3; + FStarC_Syntax_Syntax.sigattrs = uu___4; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___5; + FStarC_Syntax_Syntax.sigopts = uu___6;_}, + uu___7), + uu___8) + -> + FStarC_Compiler_Util.for_some + (fun uu___9 -> + match uu___9 with + | FStarC_Syntax_Syntax.RecordType uu___10 -> true + | FStarC_Syntax_Syntax.RecordConstructor uu___10 -> true + | uu___10 -> false) quals + | uu___1 -> false +let (qninfo_is_action : qninfo -> Prims.bool) = + fun qninfo1 -> + match qninfo1 with + | FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr + ({ FStarC_Syntax_Syntax.sigel = FStarC_Syntax_Syntax.Sig_let uu___; + FStarC_Syntax_Syntax.sigrng = uu___1; + FStarC_Syntax_Syntax.sigquals = quals; + FStarC_Syntax_Syntax.sigmeta = uu___2; + FStarC_Syntax_Syntax.sigattrs = uu___3; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___4; + FStarC_Syntax_Syntax.sigopts = uu___5;_}, + uu___6), + uu___7) + -> + FStarC_Compiler_Util.for_some + (fun uu___8 -> + match uu___8 with + | FStarC_Syntax_Syntax.Action uu___9 -> true + | uu___9 -> false) quals + | uu___ -> false +let (is_action : env -> FStarC_Ident.lident -> Prims.bool) = + fun env1 -> + fun lid -> let uu___ = lookup_qname env1 lid in qninfo_is_action uu___ +let (is_interpreted : env -> FStarC_Syntax_Syntax.term -> Prims.bool) = + let interpreted_symbols = + [FStarC_Parser_Const.op_Eq; + FStarC_Parser_Const.op_notEq; + FStarC_Parser_Const.op_LT; + FStarC_Parser_Const.op_LTE; + FStarC_Parser_Const.op_GT; + FStarC_Parser_Const.op_GTE; + FStarC_Parser_Const.op_Subtraction; + FStarC_Parser_Const.op_Minus; + FStarC_Parser_Const.op_Addition; + FStarC_Parser_Const.op_Multiply; + FStarC_Parser_Const.op_Division; + FStarC_Parser_Const.op_Modulus; + FStarC_Parser_Const.op_And; + FStarC_Parser_Const.op_Or; + FStarC_Parser_Const.op_Negation] in + fun env1 -> + fun head -> + let uu___ = + let uu___1 = FStarC_Syntax_Util.un_uinst head in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + (FStarC_Compiler_Util.for_some + (FStarC_Ident.lid_equals + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v) + interpreted_symbols) + || + (let uu___1 = delta_depth_of_fv env1 fv in + (match uu___1 with + | FStarC_Syntax_Syntax.Delta_equational_at_level uu___2 -> true + | uu___2 -> false)) + | uu___1 -> false +let (is_irreducible : env -> FStarC_Ident.lident -> Prims.bool) = + fun env1 -> + fun l -> + let uu___ = lookup_qname env1 l in + match uu___ with + | FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr (se, uu___1), uu___2) -> + FStarC_Compiler_Util.for_some + (fun uu___3 -> + match uu___3 with + | FStarC_Syntax_Syntax.Irreducible -> true + | uu___4 -> false) se.FStarC_Syntax_Syntax.sigquals + | uu___1 -> false +let (is_type_constructor : env -> FStarC_Ident.lident -> Prims.bool) = + fun env1 -> + fun lid -> + let mapper x = + match FStar_Pervasives_Native.fst x with + | FStar_Pervasives.Inl uu___ -> FStar_Pervasives_Native.Some false + | FStar_Pervasives.Inr (se, uu___) -> + (match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_declare_typ uu___1 -> + FStar_Pervasives_Native.Some + (FStarC_Compiler_List.contains FStarC_Syntax_Syntax.New + se.FStarC_Syntax_Syntax.sigquals) + | FStarC_Syntax_Syntax.Sig_inductive_typ uu___1 -> + FStar_Pervasives_Native.Some true + | uu___1 -> FStar_Pervasives_Native.Some false) in + let uu___ = + let uu___1 = lookup_qname env1 lid in + FStarC_Compiler_Util.bind_opt uu___1 mapper in + match uu___ with + | FStar_Pervasives_Native.Some b -> b + | FStar_Pervasives_Native.None -> false +let (num_inductive_ty_params : + env -> FStarC_Ident.lident -> Prims.int FStar_Pervasives_Native.option) = + fun env1 -> + fun lid -> + let uu___ = lookup_qname env1 lid in + match uu___ with + | FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr + ({ + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = uu___1; + FStarC_Syntax_Syntax.us = uu___2; + FStarC_Syntax_Syntax.params = tps; + FStarC_Syntax_Syntax.num_uniform_params = uu___3; + FStarC_Syntax_Syntax.t = uu___4; + FStarC_Syntax_Syntax.mutuals = uu___5; + FStarC_Syntax_Syntax.ds = uu___6; + FStarC_Syntax_Syntax.injective_type_params = uu___7;_}; + FStarC_Syntax_Syntax.sigrng = uu___8; + FStarC_Syntax_Syntax.sigquals = uu___9; + FStarC_Syntax_Syntax.sigmeta = uu___10; + FStarC_Syntax_Syntax.sigattrs = uu___11; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___12; + FStarC_Syntax_Syntax.sigopts = uu___13;_}, + uu___14), + uu___15) + -> FStar_Pervasives_Native.Some (FStarC_Compiler_List.length tps) + | uu___1 -> FStar_Pervasives_Native.None +let (num_inductive_uniform_ty_params : + env -> FStarC_Ident.lident -> Prims.int FStar_Pervasives_Native.option) = + fun env1 -> + fun lid -> + let uu___ = lookup_qname env1 lid in + match uu___ with + | FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr + ({ + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = uu___1; + FStarC_Syntax_Syntax.us = uu___2; + FStarC_Syntax_Syntax.params = uu___3; + FStarC_Syntax_Syntax.num_uniform_params = num_uniform; + FStarC_Syntax_Syntax.t = uu___4; + FStarC_Syntax_Syntax.mutuals = uu___5; + FStarC_Syntax_Syntax.ds = uu___6; + FStarC_Syntax_Syntax.injective_type_params = uu___7;_}; + FStarC_Syntax_Syntax.sigrng = uu___8; + FStarC_Syntax_Syntax.sigquals = uu___9; + FStarC_Syntax_Syntax.sigmeta = uu___10; + FStarC_Syntax_Syntax.sigattrs = uu___11; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___12; + FStarC_Syntax_Syntax.sigopts = uu___13;_}, + uu___14), + uu___15) + -> + (match num_uniform with + | FStar_Pervasives_Native.None -> + let uu___16 = + let uu___17 = + FStarC_Class_Show.show FStarC_Ident.showable_lident lid in + FStarC_Compiler_Util.format1 + "Internal error: Inductive %s is not decorated with its uniform type parameters" + uu___17 in + FStarC_Errors.raise_error FStarC_Ident.hasrange_lident lid + FStarC_Errors_Codes.Fatal_UnexpectedInductivetype () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___16) + | FStar_Pervasives_Native.Some n -> FStar_Pervasives_Native.Some n) + | uu___1 -> FStar_Pervasives_Native.None +let (effect_decl_opt : + env -> + FStarC_Ident.lident -> + (FStarC_Syntax_Syntax.eff_decl * FStarC_Syntax_Syntax.qualifier + Prims.list) FStar_Pervasives_Native.option) + = + fun env1 -> + fun l -> + FStarC_Compiler_Util.find_opt + (fun uu___ -> + match uu___ with + | (d, uu___1) -> + FStarC_Ident.lid_equals d.FStarC_Syntax_Syntax.mname l) + (env1.effects).decls +let (get_effect_decl : + env -> FStarC_Ident.lident -> FStarC_Syntax_Syntax.eff_decl) = + fun env1 -> + fun l -> + let uu___ = effect_decl_opt env1 l in + match uu___ with + | FStar_Pervasives_Native.None -> name_not_found l + | FStar_Pervasives_Native.Some md -> FStar_Pervasives_Native.fst md +let (get_lid_valued_effect_attr : + env -> + FStarC_Ident.lident -> + FStarC_Ident.lident -> + FStarC_Ident.lident FStar_Pervasives_Native.option -> + FStarC_Ident.lident FStar_Pervasives_Native.option) + = + fun env1 -> + fun eff_lid -> + fun attr_name_lid -> + fun default_if_attr_has_no_arg -> + let attr_args = + let uu___ = + let uu___1 = + let uu___2 = norm_eff_name env1 eff_lid in + lookup_attrs_of_lid env1 uu___2 in + FStarC_Compiler_Util.dflt [] uu___1 in + FStarC_Syntax_Util.get_attribute attr_name_lid uu___ in + match attr_args with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some args -> + if (FStarC_Compiler_List.length args) = Prims.int_zero + then default_if_attr_has_no_arg + else + (let uu___1 = FStarC_Compiler_List.hd args in + match uu___1 with + | (t, uu___2) -> + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.compress t in + uu___4.FStarC_Syntax_Syntax.n in + (match uu___3 with + | FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_string (s, uu___4)) -> + let uu___5 = FStarC_Ident.lid_of_str s in + FStar_Pervasives_Native.Some uu___5 + | uu___4 -> + let uu___5 = + let uu___6 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident eff_lid in + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.format2 + "The argument for the effect attribute for %s is not a constant string, it is %s\n" + uu___6 uu___7 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) t + FStarC_Errors_Codes.Fatal_UnexpectedEffect () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___5))) +let (get_default_effect : + env -> + FStarC_Ident.lident -> FStarC_Ident.lident FStar_Pervasives_Native.option) + = + fun env1 -> + fun lid -> + get_lid_valued_effect_attr env1 lid + FStarC_Parser_Const.default_effect_attr FStar_Pervasives_Native.None +let (get_top_level_effect : + env -> + FStarC_Ident.lident -> FStarC_Ident.lident FStar_Pervasives_Native.option) + = + fun env1 -> + fun lid -> + get_lid_valued_effect_attr env1 lid + FStarC_Parser_Const.top_level_effect_attr + (FStar_Pervasives_Native.Some lid) +let (is_layered_effect : env -> FStarC_Ident.lident -> Prims.bool) = + fun env1 -> + fun l -> + let uu___ = get_effect_decl env1 l in + FStarC_Syntax_Util.is_layered uu___ +let (identity_mlift : mlift) = + { + mlift_wp = + (fun uu___ -> fun c -> (c, FStarC_TypeChecker_Common.trivial_guard)); + mlift_term = + (FStar_Pervasives_Native.Some + (fun uu___ -> + fun uu___1 -> fun e -> FStarC_Compiler_Util.return_all e)) + } +let (join_opt : + env -> + FStarC_Ident.lident -> + FStarC_Ident.lident -> + (FStarC_Ident.lident * mlift * mlift) FStar_Pervasives_Native.option) + = + fun env1 -> + fun l1 -> + fun l2 -> + let uu___ = FStarC_Ident.lid_equals l1 l2 in + if uu___ + then + FStar_Pervasives_Native.Some (l1, identity_mlift, identity_mlift) + else + (let uu___2 = + ((FStarC_Ident.lid_equals l1 FStarC_Parser_Const.effect_GTot_lid) + && + (FStarC_Ident.lid_equals l2 + FStarC_Parser_Const.effect_Tot_lid)) + || + ((FStarC_Ident.lid_equals l2 + FStarC_Parser_Const.effect_GTot_lid) + && + (FStarC_Ident.lid_equals l1 + FStarC_Parser_Const.effect_Tot_lid)) in + if uu___2 + then + FStar_Pervasives_Native.Some + (FStarC_Parser_Const.effect_GTot_lid, identity_mlift, + identity_mlift) + else + (let uu___4 = + FStarC_Compiler_Util.find_opt + (fun uu___5 -> + match uu___5 with + | (m1, m2, uu___6, uu___7, uu___8) -> + (FStarC_Ident.lid_equals l1 m1) && + (FStarC_Ident.lid_equals l2 m2)) + (env1.effects).joins in + match uu___4 with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (uu___5, uu___6, m3, j1, j2) -> + FStar_Pervasives_Native.Some (m3, j1, j2))) +let (join : + env -> + FStarC_Ident.lident -> + FStarC_Ident.lident -> (FStarC_Ident.lident * mlift * mlift)) + = + fun env1 -> + fun l1 -> + fun l2 -> + let uu___ = join_opt env1 l1 l2 in + match uu___ with + | FStar_Pervasives_Native.None -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Ident.showable_lident l1 in + let uu___3 = + FStarC_Class_Show.show FStarC_Ident.showable_lident l2 in + FStarC_Compiler_Util.format2 + "Effects %s and %s cannot be composed" uu___2 uu___3 in + FStarC_Errors.raise_error hasRange_env env1 + FStarC_Errors_Codes.Fatal_EffectsCannotBeComposed () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) + | FStar_Pervasives_Native.Some t -> t +let (monad_leq : + env -> + FStarC_Ident.lident -> + FStarC_Ident.lident -> edge FStar_Pervasives_Native.option) + = + fun env1 -> + fun l1 -> + fun l2 -> + let uu___ = + (FStarC_Ident.lid_equals l1 l2) || + ((FStarC_Ident.lid_equals l1 FStarC_Parser_Const.effect_Tot_lid) + && + (FStarC_Ident.lid_equals l2 + FStarC_Parser_Const.effect_GTot_lid)) in + if uu___ + then + FStar_Pervasives_Native.Some + { msource = l1; mtarget = l2; mlift = identity_mlift; mpath = [] + } + else + FStarC_Compiler_Util.find_opt + (fun e -> + (FStarC_Ident.lid_equals l1 e.msource) && + (FStarC_Ident.lid_equals l2 e.mtarget)) (env1.effects).order +let wp_sig_aux : + 'uuuuu . + (FStarC_Syntax_Syntax.eff_decl * 'uuuuu) Prims.list -> + FStarC_Ident.lident -> + (FStarC_Syntax_Syntax.bv * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax) + = + fun decls -> + fun m -> + let uu___ = + FStarC_Compiler_Util.find_opt + (fun uu___1 -> + match uu___1 with + | (d, uu___2) -> + FStarC_Ident.lid_equals d.FStarC_Syntax_Syntax.mname m) + decls in + match uu___ with + | FStar_Pervasives_Native.None -> + let uu___1 = + let uu___2 = FStarC_Ident.string_of_lid m in + FStarC_Compiler_Util.format1 + "Impossible: declaration for monad %s not found" uu___2 in + failwith uu___1 + | FStar_Pervasives_Native.Some (md, _q) -> + let uu___1 = + let uu___2 = + FStarC_Syntax_Util.effect_sig_ts + md.FStarC_Syntax_Syntax.signature in + inst_tscheme uu___2 in + (match uu___1 with + | (uu___2, s) -> + let s1 = FStarC_Syntax_Subst.compress s in + (match ((md.FStarC_Syntax_Syntax.binders), + (s1.FStarC_Syntax_Syntax.n)) + with + | ([], FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = b::wp_b::[]; + FStarC_Syntax_Syntax.comp = c;_}) + when + FStarC_Syntax_Syntax.is_teff + (FStarC_Syntax_Util.comp_result c) + -> + ((b.FStarC_Syntax_Syntax.binder_bv), + ((wp_b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort)) + | uu___3 -> failwith "Impossible")) +let (wp_signature : + env -> + FStarC_Ident.lident -> + (FStarC_Syntax_Syntax.bv * FStarC_Syntax_Syntax.term)) + = fun env1 -> fun m -> wp_sig_aux (env1.effects).decls m +let (bound_vars_of_bindings : + FStarC_Syntax_Syntax.binding Prims.list -> + FStarC_Syntax_Syntax.bv Prims.list) + = + fun bs -> + FStarC_Compiler_List.collect + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.Binding_var x -> [x] + | FStarC_Syntax_Syntax.Binding_lid uu___1 -> [] + | FStarC_Syntax_Syntax.Binding_univ uu___1 -> []) bs +let (binders_of_bindings : + FStarC_Syntax_Syntax.binding Prims.list -> FStarC_Syntax_Syntax.binders) = + fun bs -> + let uu___ = + let uu___1 = bound_vars_of_bindings bs in + FStarC_Compiler_List.map FStarC_Syntax_Syntax.mk_binder uu___1 in + FStarC_Compiler_List.rev uu___ +let (all_binders : env -> FStarC_Syntax_Syntax.binders) = + fun env1 -> binders_of_bindings env1.gamma +let (bound_vars : env -> FStarC_Syntax_Syntax.bv Prims.list) = + fun env1 -> bound_vars_of_bindings env1.gamma +let (hasBinders_env : env FStarC_Class_Binders.hasBinders) = + { + FStarC_Class_Binders.boundNames = + (fun uu___ -> + (fun e -> + let uu___ = bound_vars e in + Obj.magic + (FStarC_Class_Setlike.from_list () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) uu___)) uu___) + } +let (hasNames_lcomp : + FStarC_TypeChecker_Common.lcomp FStarC_Class_Binders.hasNames) = + { + FStarC_Class_Binders.freeNames = + (fun lc -> + let uu___ = + let uu___1 = FStarC_TypeChecker_Common.lcomp_comp lc in + FStar_Pervasives_Native.fst uu___1 in + FStarC_Class_Binders.freeNames FStarC_Class_Binders.hasNames_comp + uu___) + } +let (pretty_lcomp : FStarC_TypeChecker_Common.lcomp FStarC_Class_PP.pretty) = + { FStarC_Class_PP.pp = (fun lc -> FStarC_Pprint.empty) } +let (hasNames_guard : guard_t FStarC_Class_Binders.hasNames) = + { + FStarC_Class_Binders.freeNames = + (fun uu___ -> + (fun g -> + match g.FStarC_TypeChecker_Common.guard_f with + | FStarC_TypeChecker_Common.Trivial -> + Obj.magic + (Obj.repr + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) ())) + | FStarC_TypeChecker_Common.NonTrivial f -> + Obj.magic + (Obj.repr + (FStarC_Class_Binders.freeNames + FStarC_Class_Binders.hasNames_term f))) uu___) + } +let (pretty_guard : guard_t FStarC_Class_PP.pretty) = + { + FStarC_Class_PP.pp = + (fun g -> + match g.FStarC_TypeChecker_Common.guard_f with + | FStarC_TypeChecker_Common.Trivial -> + FStarC_Pprint.doc_of_string "Trivial" + | FStarC_TypeChecker_Common.NonTrivial f -> + let uu___ = FStarC_Pprint.doc_of_string "NonTrivial" in + let uu___1 = + FStarC_Class_PP.pp FStarC_Syntax_Print.pretty_term f in + FStarC_Pprint.op_Hat_Slash_Hat uu___ uu___1) + } +let (comp_to_comp_typ : + env -> FStarC_Syntax_Syntax.comp -> FStarC_Syntax_Syntax.comp_typ) = + fun env1 -> + fun c -> + FStarC_Defensive.def_check_scoped hasBinders_env + FStarC_Class_Binders.hasNames_comp FStarC_Syntax_Print.pretty_comp + c.FStarC_Syntax_Syntax.pos "comp_to_comp_typ" env1 c; + (match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Comp ct -> ct + | uu___1 -> + let uu___2 = + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total t -> + (FStarC_Parser_Const.effect_Tot_lid, t) + | FStarC_Syntax_Syntax.GTotal t -> + (FStarC_Parser_Const.effect_GTot_lid, t) in + (match uu___2 with + | (effect_name, result_typ) -> + let uu___3 = + let uu___4 = env1.universe_of env1 result_typ in [uu___4] in + { + FStarC_Syntax_Syntax.comp_univs = uu___3; + FStarC_Syntax_Syntax.effect_name = effect_name; + FStarC_Syntax_Syntax.result_typ = result_typ; + FStarC_Syntax_Syntax.effect_args = []; + FStarC_Syntax_Syntax.flags = + (FStarC_Syntax_Util.comp_flags c) + })) +let (comp_set_flags : + env -> + FStarC_Syntax_Syntax.comp -> + FStarC_Syntax_Syntax.cflag Prims.list -> FStarC_Syntax_Syntax.comp) + = + fun env1 -> + fun c -> + fun f -> + FStarC_Defensive.def_check_scoped hasBinders_env + FStarC_Class_Binders.hasNames_comp FStarC_Syntax_Print.pretty_comp + c.FStarC_Syntax_Syntax.pos "comp_set_flags.IN" env1 c; + (let r = + let uu___1 = + let uu___2 = + let uu___3 = comp_to_comp_typ env1 c in + { + FStarC_Syntax_Syntax.comp_univs = + (uu___3.FStarC_Syntax_Syntax.comp_univs); + FStarC_Syntax_Syntax.effect_name = + (uu___3.FStarC_Syntax_Syntax.effect_name); + FStarC_Syntax_Syntax.result_typ = + (uu___3.FStarC_Syntax_Syntax.result_typ); + FStarC_Syntax_Syntax.effect_args = + (uu___3.FStarC_Syntax_Syntax.effect_args); + FStarC_Syntax_Syntax.flags = f + } in + FStarC_Syntax_Syntax.Comp uu___2 in + { + FStarC_Syntax_Syntax.n = uu___1; + FStarC_Syntax_Syntax.pos = (c.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = (c.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (c.FStarC_Syntax_Syntax.hash_code) + } in + FStarC_Defensive.def_check_scoped hasBinders_env + FStarC_Class_Binders.hasNames_comp FStarC_Syntax_Print.pretty_comp + c.FStarC_Syntax_Syntax.pos "comp_set_flags.OUT" env1 r; + r) +let rec (unfold_effect_abbrev : + env -> FStarC_Syntax_Syntax.comp -> FStarC_Syntax_Syntax.comp_typ) = + fun env1 -> + fun comp -> + FStarC_Defensive.def_check_scoped hasBinders_env + FStarC_Class_Binders.hasNames_comp FStarC_Syntax_Print.pretty_comp + comp.FStarC_Syntax_Syntax.pos "unfold_effect_abbrev" env1 comp; + (let c = comp_to_comp_typ env1 comp in + let uu___1 = + lookup_effect_abbrev env1 c.FStarC_Syntax_Syntax.comp_univs + c.FStarC_Syntax_Syntax.effect_name in + match uu___1 with + | FStar_Pervasives_Native.None -> c + | FStar_Pervasives_Native.Some (binders, cdef) -> + let uu___2 = FStarC_Syntax_Subst.open_comp binders cdef in + (match uu___2 with + | (binders1, cdef1) -> + (if + (FStarC_Compiler_List.length binders1) <> + ((FStarC_Compiler_List.length + c.FStarC_Syntax_Syntax.effect_args) + + Prims.int_one) + then + (let uu___4 = + let uu___5 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_nat) + (FStarC_Compiler_List.length binders1) in + let uu___6 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + ((FStarC_Compiler_List.length + c.FStarC_Syntax_Syntax.effect_args) + + Prims.int_one) in + let uu___7 = + let uu___8 = FStarC_Syntax_Syntax.mk_Comp c in + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_comp uu___8 in + FStarC_Compiler_Util.format3 + "Effect constructor is not fully applied; expected %s args, got %s args, i.e., %s" + uu___5 uu___6 uu___7 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) comp + FStarC_Errors_Codes.Fatal_ConstructorArgLengthMismatch + () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4)) + else (); + (let inst = + let uu___4 = + let uu___5 = + FStarC_Syntax_Syntax.as_arg + c.FStarC_Syntax_Syntax.result_typ in + uu___5 :: (c.FStarC_Syntax_Syntax.effect_args) in + FStarC_Compiler_List.map2 + (fun b -> + fun uu___5 -> + match uu___5 with + | (t, uu___6) -> + FStarC_Syntax_Syntax.NT + ((b.FStarC_Syntax_Syntax.binder_bv), t)) + binders1 uu___4 in + let c1 = FStarC_Syntax_Subst.subst_comp inst cdef1 in + let c2 = + let uu___4 = + let uu___5 = comp_to_comp_typ env1 c1 in + { + FStarC_Syntax_Syntax.comp_univs = + (uu___5.FStarC_Syntax_Syntax.comp_univs); + FStarC_Syntax_Syntax.effect_name = + (uu___5.FStarC_Syntax_Syntax.effect_name); + FStarC_Syntax_Syntax.result_typ = + (uu___5.FStarC_Syntax_Syntax.result_typ); + FStarC_Syntax_Syntax.effect_args = + (uu___5.FStarC_Syntax_Syntax.effect_args); + FStarC_Syntax_Syntax.flags = + (c.FStarC_Syntax_Syntax.flags) + } in + FStarC_Syntax_Syntax.mk_Comp uu___4 in + unfold_effect_abbrev env1 c2)))) +let effect_repr_aux : + 'uuuuu . + 'uuuuu -> + env -> + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax + FStar_Pervasives_Native.option + = + fun only_reifiable -> + fun env1 -> + fun c -> + fun u_res -> + let check_partial_application eff_name args = + let r = get_range env1 in + let uu___ = + let uu___1 = num_effect_indices env1 eff_name r in + ((FStarC_Compiler_List.length args), uu___1) in + match uu___ with + | (given, expected) -> + if given = expected + then () + else + (let message = + let uu___2 = FStarC_Ident.string_of_lid eff_name in + let uu___3 = FStarC_Compiler_Util.string_of_int given in + let uu___4 = FStarC_Compiler_Util.string_of_int expected in + FStarC_Compiler_Util.format3 + "Not enough arguments for effect %s, This usually happens when you use a partially applied DM4F effect, like [TAC int] instead of [Tac int] (given:%s, expected:%s)." + uu___2 uu___3 uu___4 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_NotEnoughArgumentsForEffect () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic message)) in + let effect_name = + norm_eff_name env1 (FStarC_Syntax_Util.comp_effect_name c) in + let uu___ = effect_decl_opt env1 effect_name in + match uu___ with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (ed, uu___1) -> + let uu___2 = FStarC_Syntax_Util.get_eff_repr ed in + (match uu___2 with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some ts -> + let c1 = unfold_effect_abbrev env1 c in + let res_typ = c1.FStarC_Syntax_Syntax.result_typ in + let repr = inst_effect_fun_with [u_res] env1 ed ts in + (check_partial_application effect_name + c1.FStarC_Syntax_Syntax.effect_args; + (let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Syntax_Syntax.as_arg res_typ in + uu___8 :: (c1.FStarC_Syntax_Syntax.effect_args) in + { + FStarC_Syntax_Syntax.hd = repr; + FStarC_Syntax_Syntax.args = uu___7 + } in + FStarC_Syntax_Syntax.Tm_app uu___6 in + let uu___6 = get_range env1 in + FStarC_Syntax_Syntax.mk uu___5 uu___6 in + FStar_Pervasives_Native.Some uu___4))) +let (effect_repr : + env -> + FStarC_Syntax_Syntax.comp -> + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = fun env1 -> fun c -> fun u_res -> effect_repr_aux false env1 c u_res +let (is_user_reifiable_effect : env -> FStarC_Ident.lident -> Prims.bool) = + fun env1 -> + fun effect_lid -> + let effect_lid1 = norm_eff_name env1 effect_lid in + let quals = lookup_effect_quals env1 effect_lid1 in + FStarC_Compiler_List.contains FStarC_Syntax_Syntax.Reifiable quals +let (is_user_reflectable_effect : env -> FStarC_Ident.lident -> Prims.bool) = + fun env1 -> + fun effect_lid -> + let effect_lid1 = norm_eff_name env1 effect_lid in + let quals = lookup_effect_quals env1 effect_lid1 in + FStarC_Compiler_List.existsb + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.Reflectable uu___1 -> true + | uu___1 -> false) quals +let (is_total_effect : env -> FStarC_Ident.lident -> Prims.bool) = + fun env1 -> + fun effect_lid -> + let effect_lid1 = norm_eff_name env1 effect_lid in + let quals = lookup_effect_quals env1 effect_lid1 in + FStarC_Compiler_List.contains FStarC_Syntax_Syntax.TotalEffect quals +let (is_reifiable_effect : env -> FStarC_Ident.lident -> Prims.bool) = + fun env1 -> + fun effect_lid -> + let effect_lid1 = norm_eff_name env1 effect_lid in + (is_user_reifiable_effect env1 effect_lid1) || + (FStarC_Ident.lid_equals effect_lid1 + FStarC_Parser_Const.effect_TAC_lid) +let (is_reifiable_rc : + env -> FStarC_Syntax_Syntax.residual_comp -> Prims.bool) = + fun env1 -> + fun c -> is_reifiable_effect env1 c.FStarC_Syntax_Syntax.residual_effect +let (is_reifiable_comp : env -> FStarC_Syntax_Syntax.comp -> Prims.bool) = + fun env1 -> + fun c -> + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Comp ct -> + is_reifiable_effect env1 ct.FStarC_Syntax_Syntax.effect_name + | uu___ -> false +let (is_reifiable_function : env -> FStarC_Syntax_Syntax.term -> Prims.bool) + = + fun env1 -> + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = uu___1; + FStarC_Syntax_Syntax.comp = c;_} + -> is_reifiable_comp env1 c + | uu___1 -> false +let (reify_comp : + env -> + FStarC_Syntax_Syntax.comp -> + FStarC_Syntax_Syntax.universe -> FStarC_Syntax_Syntax.term) + = + fun env1 -> + fun c -> + fun u_c -> + let l = FStarC_Syntax_Util.comp_effect_name c in + (let uu___1 = + let uu___2 = is_reifiable_effect env1 l in + Prims.op_Negation uu___2 in + if uu___1 + then + let uu___2 = + let uu___3 = FStarC_Ident.string_of_lid l in + FStarC_Compiler_Util.format1 "Effect %s cannot be reified" + uu___3 in + FStarC_Errors.raise_error hasRange_env env1 + FStarC_Errors_Codes.Fatal_EffectCannotBeReified () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2) + else ()); + (let uu___1 = effect_repr_aux true env1 c u_c in + match uu___1 with + | FStar_Pervasives_Native.None -> + failwith "internal error: reifiable effect has no repr?" + | FStar_Pervasives_Native.Some tm -> tm) +let rec (record_vals_and_defns : env -> FStarC_Syntax_Syntax.sigelt -> env) = + fun g -> + fun se -> + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_declare_typ uu___ when + FStarC_Compiler_Util.for_some + (fun uu___1 -> + match uu___1 with + | FStarC_Syntax_Syntax.OnlyName -> true + | uu___2 -> false) se.FStarC_Syntax_Syntax.sigquals + -> g + | FStarC_Syntax_Syntax.Sig_let uu___ when + FStarC_Compiler_Util.for_some + (fun uu___1 -> + match uu___1 with + | FStarC_Syntax_Syntax.OnlyName -> true + | uu___2 -> false) se.FStarC_Syntax_Syntax.sigquals + -> g + | FStarC_Syntax_Syntax.Sig_declare_typ + { FStarC_Syntax_Syntax.lid2 = lid; + FStarC_Syntax_Syntax.us2 = uu___; + FStarC_Syntax_Syntax.t2 = uu___1;_} + -> + if + (FStarC_Compiler_List.contains FStarC_Syntax_Syntax.Assumption + se.FStarC_Syntax_Syntax.sigquals) + || g.is_iface + then g + else record_val_for g lid + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = uu___; + FStarC_Syntax_Syntax.lids1 = lids;_} + -> FStarC_Compiler_List.fold_left record_definition_for g lids + | FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = lid; + FStarC_Syntax_Syntax.us1 = uu___; + FStarC_Syntax_Syntax.t1 = uu___1; + FStarC_Syntax_Syntax.ty_lid = uu___2; + FStarC_Syntax_Syntax.num_ty_params = uu___3; + FStarC_Syntax_Syntax.mutuals1 = uu___4; + FStarC_Syntax_Syntax.injective_type_params1 = uu___5;_} + -> record_definition_for g lid + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = lid; FStarC_Syntax_Syntax.us = uu___; + FStarC_Syntax_Syntax.params = uu___1; + FStarC_Syntax_Syntax.num_uniform_params = uu___2; + FStarC_Syntax_Syntax.t = uu___3; + FStarC_Syntax_Syntax.mutuals = uu___4; + FStarC_Syntax_Syntax.ds = uu___5; + FStarC_Syntax_Syntax.injective_type_params = uu___6;_} + -> record_definition_for g lid + | FStarC_Syntax_Syntax.Sig_bundle + { FStarC_Syntax_Syntax.ses = ses; + FStarC_Syntax_Syntax.lids = uu___;_} + -> FStarC_Compiler_List.fold_left record_vals_and_defns g ses + | uu___ -> g +let (push_sigelt' : Prims.bool -> env -> FStarC_Syntax_Syntax.sigelt -> env) + = + fun force -> + fun env1 -> + fun s -> + let sb = ((FStarC_Syntax_Util.lids_of_sigelt s), s) in + let env2 = + { + solver = (env1.solver); + range = (env1.range); + curmodule = (env1.curmodule); + gamma = (env1.gamma); + gamma_sig = (sb :: (env1.gamma_sig)); + gamma_cache = (env1.gamma_cache); + modules = (env1.modules); + expected_typ = (env1.expected_typ); + sigtab = (env1.sigtab); + attrtab = (env1.attrtab); + instantiate_imp = (env1.instantiate_imp); + effects = (env1.effects); + generalize = (env1.generalize); + letrecs = (env1.letrecs); + top_level = (env1.top_level); + check_uvars = (env1.check_uvars); + use_eq_strict = (env1.use_eq_strict); + is_iface = (env1.is_iface); + admit = (env1.admit); + lax_universes = (env1.lax_universes); + phase1 = (env1.phase1); + failhard = (env1.failhard); + flychecking = (env1.flychecking); + uvar_subtyping = (env1.uvar_subtyping); + intactics = (env1.intactics); + nocoerce = (env1.nocoerce); + tc_term = (env1.tc_term); + typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); + universe_of = (env1.universe_of); + typeof_well_typed_tot_or_gtot_term = + (env1.typeof_well_typed_tot_or_gtot_term); + teq_nosmt_force = (env1.teq_nosmt_force); + subtype_nosmt_force = (env1.subtype_nosmt_force); + qtbl_name_and_index = (env1.qtbl_name_and_index); + normalized_eff_names = (env1.normalized_eff_names); + fv_delta_depths = (env1.fv_delta_depths); + proof_ns = (env1.proof_ns); + synth_hook = (env1.synth_hook); + try_solve_implicits_hook = (env1.try_solve_implicits_hook); + splice = (env1.splice); + mpreprocess = (env1.mpreprocess); + postprocess = (env1.postprocess); + identifier_info = (env1.identifier_info); + tc_hooks = (env1.tc_hooks); + dsenv = (env1.dsenv); + nbe = (env1.nbe); + strict_args_tab = (env1.strict_args_tab); + erasable_types_tab = (env1.erasable_types_tab); + enable_defer_to_tac = (env1.enable_defer_to_tac); + unif_allow_ref_guards = (env1.unif_allow_ref_guards); + erase_erasable_args = (env1.erase_erasable_args); + core_check = (env1.core_check); + missing_decl = (env1.missing_decl) + } in + add_sigelt force env2 s; + (env2.tc_hooks).tc_push_in_gamma_hook env2 (FStar_Pervasives.Inr sb); + (let env3 = record_vals_and_defns env2 s in env3) +let (push_sigelt : env -> FStarC_Syntax_Syntax.sigelt -> env) = + push_sigelt' false +let (push_sigelt_force : env -> FStarC_Syntax_Syntax.sigelt -> env) = + push_sigelt' true +let (push_new_effect : + env -> + (FStarC_Syntax_Syntax.eff_decl * FStarC_Syntax_Syntax.qualifier + Prims.list) -> env) + = + fun env1 -> + fun uu___ -> + match uu___ with + | (ed, quals) -> + let effects1 = + let uu___1 = env1.effects in + { + decls = + (FStarC_Compiler_List.op_At (env1.effects).decls + [(ed, quals)]); + order = (uu___1.order); + joins = (uu___1.joins); + polymonadic_binds = (uu___1.polymonadic_binds); + polymonadic_subcomps = (uu___1.polymonadic_subcomps) + } in + { + solver = (env1.solver); + range = (env1.range); + curmodule = (env1.curmodule); + gamma = (env1.gamma); + gamma_sig = (env1.gamma_sig); + gamma_cache = (env1.gamma_cache); + modules = (env1.modules); + expected_typ = (env1.expected_typ); + sigtab = (env1.sigtab); + attrtab = (env1.attrtab); + instantiate_imp = (env1.instantiate_imp); + effects = effects1; + generalize = (env1.generalize); + letrecs = (env1.letrecs); + top_level = (env1.top_level); + check_uvars = (env1.check_uvars); + use_eq_strict = (env1.use_eq_strict); + is_iface = (env1.is_iface); + admit = (env1.admit); + lax_universes = (env1.lax_universes); + phase1 = (env1.phase1); + failhard = (env1.failhard); + flychecking = (env1.flychecking); + uvar_subtyping = (env1.uvar_subtyping); + intactics = (env1.intactics); + nocoerce = (env1.nocoerce); + tc_term = (env1.tc_term); + typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); + universe_of = (env1.universe_of); + typeof_well_typed_tot_or_gtot_term = + (env1.typeof_well_typed_tot_or_gtot_term); + teq_nosmt_force = (env1.teq_nosmt_force); + subtype_nosmt_force = (env1.subtype_nosmt_force); + qtbl_name_and_index = (env1.qtbl_name_and_index); + normalized_eff_names = (env1.normalized_eff_names); + fv_delta_depths = (env1.fv_delta_depths); + proof_ns = (env1.proof_ns); + synth_hook = (env1.synth_hook); + try_solve_implicits_hook = (env1.try_solve_implicits_hook); + splice = (env1.splice); + mpreprocess = (env1.mpreprocess); + postprocess = (env1.postprocess); + identifier_info = (env1.identifier_info); + tc_hooks = (env1.tc_hooks); + dsenv = (env1.dsenv); + nbe = (env1.nbe); + strict_args_tab = (env1.strict_args_tab); + erasable_types_tab = (env1.erasable_types_tab); + enable_defer_to_tac = (env1.enable_defer_to_tac); + unif_allow_ref_guards = (env1.unif_allow_ref_guards); + erase_erasable_args = (env1.erase_erasable_args); + core_check = (env1.core_check); + missing_decl = (env1.missing_decl) + } +let (exists_polymonadic_bind : + env -> + FStarC_Ident.lident -> + FStarC_Ident.lident -> + (FStarC_Ident.lident * polymonadic_bind_t) + FStar_Pervasives_Native.option) + = + fun env1 -> + fun m -> + fun n -> + let uu___ = + FStarC_Compiler_Util.find_opt + (fun uu___1 -> + match uu___1 with + | (m1, n1, uu___2, uu___3) -> + (FStarC_Ident.lid_equals m m1) && + (FStarC_Ident.lid_equals n n1)) + (env1.effects).polymonadic_binds in + match uu___ with + | FStar_Pervasives_Native.Some (uu___1, uu___2, p, t) -> + FStar_Pervasives_Native.Some (p, t) + | uu___1 -> FStar_Pervasives_Native.None +let (exists_polymonadic_subcomp : + env -> + FStarC_Ident.lident -> + FStarC_Ident.lident -> + (FStarC_Syntax_Syntax.tscheme * + FStarC_Syntax_Syntax.indexed_effect_combinator_kind) + FStar_Pervasives_Native.option) + = + fun env1 -> + fun m -> + fun n -> + let uu___ = + FStarC_Compiler_Util.find_opt + (fun uu___1 -> + match uu___1 with + | (m1, n1, uu___2, uu___3) -> + (FStarC_Ident.lid_equals m m1) && + (FStarC_Ident.lid_equals n n1)) + (env1.effects).polymonadic_subcomps in + match uu___ with + | FStar_Pervasives_Native.Some (uu___1, uu___2, ts, k) -> + FStar_Pervasives_Native.Some (ts, k) + | uu___1 -> FStar_Pervasives_Native.None +let (print_effects_graph : env -> Prims.string) = + fun env1 -> + let eff_name lid = + let uu___ = FStarC_Ident.ident_of_lid lid in + FStarC_Ident.string_of_id uu___ in + let path_str path = + let uu___ = FStarC_Compiler_List.map eff_name path in + FStarC_Compiler_String.concat ";" uu___ in + let pbinds = FStarC_Compiler_Util.smap_create (Prims.of_int (10)) in + let lifts = FStarC_Compiler_Util.smap_create (Prims.of_int (20)) in + let psubcomps = FStarC_Compiler_Util.smap_create (Prims.of_int (10)) in + FStarC_Compiler_List.iter + (fun uu___1 -> + match uu___1 with + | { msource = src; mtarget = tgt; mlift = uu___2; mpath = path;_} -> + let key = eff_name src in + let m = + let uu___3 = FStarC_Compiler_Util.smap_try_find lifts key in + match uu___3 with + | FStar_Pervasives_Native.None -> + let m1 = + FStarC_Compiler_Util.smap_create (Prims.of_int (10)) in + (FStarC_Compiler_Util.smap_add lifts key m1; m1) + | FStar_Pervasives_Native.Some m1 -> m1 in + let uu___3 = + let uu___4 = eff_name tgt in + FStarC_Compiler_Util.smap_try_find m uu___4 in + (match uu___3 with + | FStar_Pervasives_Native.Some uu___4 -> () + | FStar_Pervasives_Native.None -> + let uu___4 = eff_name tgt in + let uu___5 = path_str path in + FStarC_Compiler_Util.smap_add m uu___4 uu___5)) + (env1.effects).order; + FStarC_Compiler_List.iter + (fun uu___2 -> + match uu___2 with + | (m, n, p, uu___3) -> + let key = + let uu___4 = eff_name m in + let uu___5 = eff_name n in + let uu___6 = eff_name p in + FStarC_Compiler_Util.format3 "%s, %s |> %s" uu___4 uu___5 + uu___6 in + FStarC_Compiler_Util.smap_add pbinds key "") + (env1.effects).polymonadic_binds; + FStarC_Compiler_List.iter + (fun uu___3 -> + match uu___3 with + | (m, n, uu___4, uu___5) -> + let key = + let uu___6 = eff_name m in + let uu___7 = eff_name n in + FStarC_Compiler_Util.format2 "%s <: %s" uu___6 uu___7 in + FStarC_Compiler_Util.smap_add psubcomps key "") + (env1.effects).polymonadic_subcomps; + (let uu___3 = + let uu___4 = + FStarC_Compiler_Util.smap_fold lifts + (fun src -> + fun m -> + fun s -> + FStarC_Compiler_Util.smap_fold m + (fun tgt -> + fun path -> + fun s1 -> + let uu___5 = + FStarC_Compiler_Util.format3 + "%s -> %s [label=\"%s\"]" src tgt path in + uu___5 :: s1) s) [] in + FStarC_Compiler_String.concat "\n" uu___4 in + let uu___4 = + let uu___5 = + FStarC_Compiler_Util.smap_fold pbinds + (fun k -> + fun uu___6 -> + fun s -> + let uu___7 = + FStarC_Compiler_Util.format1 + "\"%s\" [shape=\"plaintext\"]" k in + uu___7 :: s) [] in + FStarC_Compiler_String.concat "\n" uu___5 in + let uu___5 = + let uu___6 = + FStarC_Compiler_Util.smap_fold psubcomps + (fun k -> + fun uu___7 -> + fun s -> + let uu___8 = + FStarC_Compiler_Util.format1 + "\"%s\" [shape=\"plaintext\"]" k in + uu___8 :: s) [] in + FStarC_Compiler_String.concat "\n" uu___6 in + FStarC_Compiler_Util.format3 + "digraph {\nlabel=\"Effects ordering\"\nsubgraph cluster_lifts {\nlabel = \"Lifts\"\n\n %s\n}\nsubgraph cluster_polymonadic_binds {\nlabel = \"Polymonadic binds\"\n%s\n}\nsubgraph cluster_polymonadic_subcomps {\nlabel = \"Polymonadic subcomps\"\n%s\n}}\n" + uu___3 uu___4 uu___5) +let (update_effect_lattice : + env -> FStarC_Ident.lident -> FStarC_Ident.lident -> mlift -> env) = + fun env1 -> + fun src -> + fun tgt -> + fun st_mlift -> + let compose_edges e1 e2 = + let composed_lift = + let mlift_wp env2 c = + let uu___ = (e1.mlift).mlift_wp env2 c in + match uu___ with + | (c1, g1) -> + let uu___1 = (e2.mlift).mlift_wp env2 c1 in + (match uu___1 with + | (c2, g2) -> + let uu___2 = + FStarC_TypeChecker_Common.conj_guard g1 g2 in + (c2, uu___2)) in + let mlift_term = + match (((e1.mlift).mlift_term), ((e2.mlift).mlift_term)) with + | (FStar_Pervasives_Native.Some l1, + FStar_Pervasives_Native.Some l2) -> + FStar_Pervasives_Native.Some + ((fun u -> + fun t -> + fun e -> let uu___ = l1 u t e in l2 u t uu___)) + | uu___ -> FStar_Pervasives_Native.None in + { mlift_wp; mlift_term } in + { + msource = (e1.msource); + mtarget = (e2.mtarget); + mlift = composed_lift; + mpath = + (FStarC_Compiler_List.op_At e1.mpath + (FStarC_Compiler_List.op_At [e1.mtarget] e2.mpath)) + } in + let edge1 = + { msource = src; mtarget = tgt; mlift = st_mlift; mpath = [] } in + let id_edge l = + { + msource = src; + mtarget = tgt; + mlift = identity_mlift; + mpath = [] + } in + let find_edge order uu___ = + match uu___ with + | (i, j) -> + let uu___1 = FStarC_Ident.lid_equals i j in + if uu___1 + then FStar_Pervasives_Native.Some (id_edge i) + else + FStarC_Compiler_Util.find_opt + (fun e -> + (FStarC_Ident.lid_equals e.msource i) && + (FStarC_Ident.lid_equals e.mtarget j)) order in + let ms = + FStarC_Compiler_List.map + (fun uu___ -> + match uu___ with + | (e, uu___1) -> e.FStarC_Syntax_Syntax.mname) + (env1.effects).decls in + let all_i_src = + FStarC_Compiler_List.fold_left + (fun edges -> + fun i -> + let uu___ = FStarC_Ident.lid_equals i edge1.msource in + if uu___ + then edges + else + (let uu___2 = + find_edge (env1.effects).order (i, (edge1.msource)) in + match uu___2 with + | FStar_Pervasives_Native.Some e -> e :: edges + | FStar_Pervasives_Native.None -> edges)) [] ms in + let all_tgt_j = + FStarC_Compiler_List.fold_left + (fun edges -> + fun j -> + let uu___ = FStarC_Ident.lid_equals edge1.mtarget j in + if uu___ + then edges + else + (let uu___2 = + find_edge (env1.effects).order ((edge1.mtarget), j) in + match uu___2 with + | FStar_Pervasives_Native.Some e -> e :: edges + | FStar_Pervasives_Native.None -> edges)) [] ms in + let check_cycle src1 tgt1 = + let uu___ = FStarC_Ident.lid_equals src1 tgt1 in + if uu___ + then + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Ident.showable_lident + edge1.msource in + let uu___3 = + FStarC_Class_Show.show FStarC_Ident.showable_lident + edge1.mtarget in + let uu___4 = + FStarC_Class_Show.show FStarC_Ident.showable_lident src1 in + FStarC_Compiler_Util.format3 + "Adding an edge %s~>%s induces a cycle %s" uu___2 uu___3 + uu___4 in + FStarC_Errors.raise_error hasRange_env env1 + FStarC_Errors_Codes.Fatal_Effects_Ordering_Coherence () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) + else () in + let new_i_edge_target = + FStarC_Compiler_List.fold_left + (fun edges -> + fun i_src -> + check_cycle i_src.msource edge1.mtarget; + (let uu___1 = compose_edges i_src edge1 in uu___1 :: edges)) + [] all_i_src in + let new_edge_source_j = + FStarC_Compiler_List.fold_left + (fun edges -> + fun tgt_j -> + check_cycle edge1.msource tgt_j.mtarget; + (let uu___1 = compose_edges edge1 tgt_j in uu___1 :: edges)) + [] all_tgt_j in + let new_i_j = + FStarC_Compiler_List.fold_left + (fun edges -> + fun i_src -> + FStarC_Compiler_List.fold_left + (fun edges1 -> + fun tgt_j -> + check_cycle i_src.msource tgt_j.mtarget; + (let uu___1 = + let uu___2 = compose_edges i_src edge1 in + compose_edges uu___2 tgt_j in + uu___1 :: edges1)) edges all_tgt_j) [] all_i_src in + let new_edges = edge1 :: + (FStarC_Compiler_List.op_At new_i_edge_target + (FStarC_Compiler_List.op_At new_edge_source_j new_i_j)) in + let order = + FStarC_Compiler_List.op_At new_edges (env1.effects).order in + FStarC_Compiler_List.iter + (fun edge2 -> + let uu___1 = + (FStarC_Ident.lid_equals edge2.msource + FStarC_Parser_Const.effect_DIV_lid) + && + (let uu___2 = lookup_effect_quals env1 edge2.mtarget in + FStarC_Compiler_List.contains + FStarC_Syntax_Syntax.TotalEffect uu___2) in + if uu___1 + then + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Ident.showable_lident + edge2.mtarget in + FStarC_Compiler_Util.format1 + "Divergent computations cannot be included in an effect %s marked 'total'" + uu___3 in + FStarC_Errors.raise_error hasRange_env env1 + FStarC_Errors_Codes.Fatal_DivergentComputationCannotBeIncludedInTotal + () (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2) + else ()) order; + (let joins = + let ubs = FStarC_Compiler_Util.smap_create (Prims.of_int (10)) in + let add_ub i j k ik jk = + let key = + let uu___1 = FStarC_Ident.string_of_lid i in + let uu___2 = + let uu___3 = FStarC_Ident.string_of_lid j in + Prims.strcat ":" uu___3 in + Prims.strcat uu___1 uu___2 in + let v = + let uu___1 = FStarC_Compiler_Util.smap_try_find ubs key in + match uu___1 with + | FStar_Pervasives_Native.Some ubs1 -> (i, j, k, ik, jk) :: + ubs1 + | FStar_Pervasives_Native.None -> [(i, j, k, ik, jk)] in + FStarC_Compiler_Util.smap_add ubs key v in + FStarC_Compiler_List.iter + (fun i -> + FStarC_Compiler_List.iter + (fun j -> + let uu___2 = FStarC_Ident.lid_equals i j in + if uu___2 + then () + else + FStarC_Compiler_List.iter + (fun k -> + let uu___4 = + let uu___5 = find_edge order (i, k) in + let uu___6 = find_edge order (j, k) in + (uu___5, uu___6) in + match uu___4 with + | (FStar_Pervasives_Native.Some ik, + FStar_Pervasives_Native.Some jk) -> + add_ub i j k ik.mlift jk.mlift + | uu___5 -> ()) ms) ms) ms; + FStarC_Compiler_Util.smap_fold ubs + (fun s -> + fun l -> + fun joins1 -> + let lubs = + FStarC_Compiler_List.filter + (fun uu___2 -> + match uu___2 with + | (i, j, k, ik, jk) -> + FStarC_Compiler_List.for_all + (fun uu___3 -> + match uu___3 with + | (uu___4, uu___5, k', uu___6, uu___7) + -> + let uu___8 = + find_edge order (k, k') in + FStarC_Compiler_Util.is_some uu___8) + l) l in + if (FStarC_Compiler_List.length lubs) <> Prims.int_one + then + let uu___2 = + FStarC_Compiler_Util.format1 + "Effects %s have incomparable upper bounds" s in + FStarC_Errors.raise_error hasRange_env env1 + FStarC_Errors_Codes.Fatal_Effects_Ordering_Coherence + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2) + else FStarC_Compiler_List.op_At lubs joins1) [] in + let effects1 = + let uu___1 = env1.effects in + { + decls = (uu___1.decls); + order; + joins; + polymonadic_binds = (uu___1.polymonadic_binds); + polymonadic_subcomps = (uu___1.polymonadic_subcomps) + } in + { + solver = (env1.solver); + range = (env1.range); + curmodule = (env1.curmodule); + gamma = (env1.gamma); + gamma_sig = (env1.gamma_sig); + gamma_cache = (env1.gamma_cache); + modules = (env1.modules); + expected_typ = (env1.expected_typ); + sigtab = (env1.sigtab); + attrtab = (env1.attrtab); + instantiate_imp = (env1.instantiate_imp); + effects = effects1; + generalize = (env1.generalize); + letrecs = (env1.letrecs); + top_level = (env1.top_level); + check_uvars = (env1.check_uvars); + use_eq_strict = (env1.use_eq_strict); + is_iface = (env1.is_iface); + admit = (env1.admit); + lax_universes = (env1.lax_universes); + phase1 = (env1.phase1); + failhard = (env1.failhard); + flychecking = (env1.flychecking); + uvar_subtyping = (env1.uvar_subtyping); + intactics = (env1.intactics); + nocoerce = (env1.nocoerce); + tc_term = (env1.tc_term); + typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); + universe_of = (env1.universe_of); + typeof_well_typed_tot_or_gtot_term = + (env1.typeof_well_typed_tot_or_gtot_term); + teq_nosmt_force = (env1.teq_nosmt_force); + subtype_nosmt_force = (env1.subtype_nosmt_force); + qtbl_name_and_index = (env1.qtbl_name_and_index); + normalized_eff_names = (env1.normalized_eff_names); + fv_delta_depths = (env1.fv_delta_depths); + proof_ns = (env1.proof_ns); + synth_hook = (env1.synth_hook); + try_solve_implicits_hook = (env1.try_solve_implicits_hook); + splice = (env1.splice); + mpreprocess = (env1.mpreprocess); + postprocess = (env1.postprocess); + identifier_info = (env1.identifier_info); + tc_hooks = (env1.tc_hooks); + dsenv = (env1.dsenv); + nbe = (env1.nbe); + strict_args_tab = (env1.strict_args_tab); + erasable_types_tab = (env1.erasable_types_tab); + enable_defer_to_tac = (env1.enable_defer_to_tac); + unif_allow_ref_guards = (env1.unif_allow_ref_guards); + erase_erasable_args = (env1.erase_erasable_args); + core_check = (env1.core_check); + missing_decl = (env1.missing_decl) + }) +let (add_polymonadic_bind : + env -> + FStarC_Ident.lident -> + FStarC_Ident.lident -> FStarC_Ident.lident -> polymonadic_bind_t -> env) + = + fun env1 -> + fun m -> + fun n -> + fun p -> + fun ty -> + { + solver = (env1.solver); + range = (env1.range); + curmodule = (env1.curmodule); + gamma = (env1.gamma); + gamma_sig = (env1.gamma_sig); + gamma_cache = (env1.gamma_cache); + modules = (env1.modules); + expected_typ = (env1.expected_typ); + sigtab = (env1.sigtab); + attrtab = (env1.attrtab); + instantiate_imp = (env1.instantiate_imp); + effects = + (let uu___ = env1.effects in + { + decls = (uu___.decls); + order = (uu___.order); + joins = (uu___.joins); + polymonadic_binds = ((m, n, p, ty) :: + ((env1.effects).polymonadic_binds)); + polymonadic_subcomps = (uu___.polymonadic_subcomps) + }); + generalize = (env1.generalize); + letrecs = (env1.letrecs); + top_level = (env1.top_level); + check_uvars = (env1.check_uvars); + use_eq_strict = (env1.use_eq_strict); + is_iface = (env1.is_iface); + admit = (env1.admit); + lax_universes = (env1.lax_universes); + phase1 = (env1.phase1); + failhard = (env1.failhard); + flychecking = (env1.flychecking); + uvar_subtyping = (env1.uvar_subtyping); + intactics = (env1.intactics); + nocoerce = (env1.nocoerce); + tc_term = (env1.tc_term); + typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); + universe_of = (env1.universe_of); + typeof_well_typed_tot_or_gtot_term = + (env1.typeof_well_typed_tot_or_gtot_term); + teq_nosmt_force = (env1.teq_nosmt_force); + subtype_nosmt_force = (env1.subtype_nosmt_force); + qtbl_name_and_index = (env1.qtbl_name_and_index); + normalized_eff_names = (env1.normalized_eff_names); + fv_delta_depths = (env1.fv_delta_depths); + proof_ns = (env1.proof_ns); + synth_hook = (env1.synth_hook); + try_solve_implicits_hook = (env1.try_solve_implicits_hook); + splice = (env1.splice); + mpreprocess = (env1.mpreprocess); + postprocess = (env1.postprocess); + identifier_info = (env1.identifier_info); + tc_hooks = (env1.tc_hooks); + dsenv = (env1.dsenv); + nbe = (env1.nbe); + strict_args_tab = (env1.strict_args_tab); + erasable_types_tab = (env1.erasable_types_tab); + enable_defer_to_tac = (env1.enable_defer_to_tac); + unif_allow_ref_guards = (env1.unif_allow_ref_guards); + erase_erasable_args = (env1.erase_erasable_args); + core_check = (env1.core_check); + missing_decl = (env1.missing_decl) + } +let (add_polymonadic_subcomp : + env -> + FStarC_Ident.lident -> + FStarC_Ident.lident -> + (FStarC_Syntax_Syntax.tscheme * + FStarC_Syntax_Syntax.indexed_effect_combinator_kind) -> env) + = + fun env1 -> + fun m -> + fun n -> + fun uu___ -> + match uu___ with + | (ts, k) -> + { + solver = (env1.solver); + range = (env1.range); + curmodule = (env1.curmodule); + gamma = (env1.gamma); + gamma_sig = (env1.gamma_sig); + gamma_cache = (env1.gamma_cache); + modules = (env1.modules); + expected_typ = (env1.expected_typ); + sigtab = (env1.sigtab); + attrtab = (env1.attrtab); + instantiate_imp = (env1.instantiate_imp); + effects = + (let uu___1 = env1.effects in + { + decls = (uu___1.decls); + order = (uu___1.order); + joins = (uu___1.joins); + polymonadic_binds = (uu___1.polymonadic_binds); + polymonadic_subcomps = ((m, n, ts, k) :: + ((env1.effects).polymonadic_subcomps)) + }); + generalize = (env1.generalize); + letrecs = (env1.letrecs); + top_level = (env1.top_level); + check_uvars = (env1.check_uvars); + use_eq_strict = (env1.use_eq_strict); + is_iface = (env1.is_iface); + admit = (env1.admit); + lax_universes = (env1.lax_universes); + phase1 = (env1.phase1); + failhard = (env1.failhard); + flychecking = (env1.flychecking); + uvar_subtyping = (env1.uvar_subtyping); + intactics = (env1.intactics); + nocoerce = (env1.nocoerce); + tc_term = (env1.tc_term); + typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); + universe_of = (env1.universe_of); + typeof_well_typed_tot_or_gtot_term = + (env1.typeof_well_typed_tot_or_gtot_term); + teq_nosmt_force = (env1.teq_nosmt_force); + subtype_nosmt_force = (env1.subtype_nosmt_force); + qtbl_name_and_index = (env1.qtbl_name_and_index); + normalized_eff_names = (env1.normalized_eff_names); + fv_delta_depths = (env1.fv_delta_depths); + proof_ns = (env1.proof_ns); + synth_hook = (env1.synth_hook); + try_solve_implicits_hook = (env1.try_solve_implicits_hook); + splice = (env1.splice); + mpreprocess = (env1.mpreprocess); + postprocess = (env1.postprocess); + identifier_info = (env1.identifier_info); + tc_hooks = (env1.tc_hooks); + dsenv = (env1.dsenv); + nbe = (env1.nbe); + strict_args_tab = (env1.strict_args_tab); + erasable_types_tab = (env1.erasable_types_tab); + enable_defer_to_tac = (env1.enable_defer_to_tac); + unif_allow_ref_guards = (env1.unif_allow_ref_guards); + erase_erasable_args = (env1.erase_erasable_args); + core_check = (env1.core_check); + missing_decl = (env1.missing_decl) + } +let (push_local_binding : env -> FStarC_Syntax_Syntax.binding -> env) = + fun env1 -> + fun b -> + { + solver = (env1.solver); + range = (env1.range); + curmodule = (env1.curmodule); + gamma = (b :: (env1.gamma)); + gamma_sig = (env1.gamma_sig); + gamma_cache = (env1.gamma_cache); + modules = (env1.modules); + expected_typ = (env1.expected_typ); + sigtab = (env1.sigtab); + attrtab = (env1.attrtab); + instantiate_imp = (env1.instantiate_imp); + effects = (env1.effects); + generalize = (env1.generalize); + letrecs = (env1.letrecs); + top_level = (env1.top_level); + check_uvars = (env1.check_uvars); + use_eq_strict = (env1.use_eq_strict); + is_iface = (env1.is_iface); + admit = (env1.admit); + lax_universes = (env1.lax_universes); + phase1 = (env1.phase1); + failhard = (env1.failhard); + flychecking = (env1.flychecking); + uvar_subtyping = (env1.uvar_subtyping); + intactics = (env1.intactics); + nocoerce = (env1.nocoerce); + tc_term = (env1.tc_term); + typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); + universe_of = (env1.universe_of); + typeof_well_typed_tot_or_gtot_term = + (env1.typeof_well_typed_tot_or_gtot_term); + teq_nosmt_force = (env1.teq_nosmt_force); + subtype_nosmt_force = (env1.subtype_nosmt_force); + qtbl_name_and_index = (env1.qtbl_name_and_index); + normalized_eff_names = (env1.normalized_eff_names); + fv_delta_depths = (env1.fv_delta_depths); + proof_ns = (env1.proof_ns); + synth_hook = (env1.synth_hook); + try_solve_implicits_hook = (env1.try_solve_implicits_hook); + splice = (env1.splice); + mpreprocess = (env1.mpreprocess); + postprocess = (env1.postprocess); + identifier_info = (env1.identifier_info); + tc_hooks = (env1.tc_hooks); + dsenv = (env1.dsenv); + nbe = (env1.nbe); + strict_args_tab = (env1.strict_args_tab); + erasable_types_tab = (env1.erasable_types_tab); + enable_defer_to_tac = (env1.enable_defer_to_tac); + unif_allow_ref_guards = (env1.unif_allow_ref_guards); + erase_erasable_args = (env1.erase_erasable_args); + core_check = (env1.core_check); + missing_decl = (env1.missing_decl) + } +let (push_bv : env -> FStarC_Syntax_Syntax.bv -> env) = + fun env1 -> + fun x -> push_local_binding env1 (FStarC_Syntax_Syntax.Binding_var x) +let (push_bvs : env -> FStarC_Syntax_Syntax.bv Prims.list -> env) = + fun env1 -> + fun bvs -> + FStarC_Compiler_List.fold_left (fun env2 -> fun bv -> push_bv env2 bv) + env1 bvs +let (pop_bv : + env -> (FStarC_Syntax_Syntax.bv * env) FStar_Pervasives_Native.option) = + fun env1 -> + match env1.gamma with + | (FStarC_Syntax_Syntax.Binding_var x)::rest -> + FStar_Pervasives_Native.Some + (x, + { + solver = (env1.solver); + range = (env1.range); + curmodule = (env1.curmodule); + gamma = rest; + gamma_sig = (env1.gamma_sig); + gamma_cache = (env1.gamma_cache); + modules = (env1.modules); + expected_typ = (env1.expected_typ); + sigtab = (env1.sigtab); + attrtab = (env1.attrtab); + instantiate_imp = (env1.instantiate_imp); + effects = (env1.effects); + generalize = (env1.generalize); + letrecs = (env1.letrecs); + top_level = (env1.top_level); + check_uvars = (env1.check_uvars); + use_eq_strict = (env1.use_eq_strict); + is_iface = (env1.is_iface); + admit = (env1.admit); + lax_universes = (env1.lax_universes); + phase1 = (env1.phase1); + failhard = (env1.failhard); + flychecking = (env1.flychecking); + uvar_subtyping = (env1.uvar_subtyping); + intactics = (env1.intactics); + nocoerce = (env1.nocoerce); + tc_term = (env1.tc_term); + typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); + universe_of = (env1.universe_of); + typeof_well_typed_tot_or_gtot_term = + (env1.typeof_well_typed_tot_or_gtot_term); + teq_nosmt_force = (env1.teq_nosmt_force); + subtype_nosmt_force = (env1.subtype_nosmt_force); + qtbl_name_and_index = (env1.qtbl_name_and_index); + normalized_eff_names = (env1.normalized_eff_names); + fv_delta_depths = (env1.fv_delta_depths); + proof_ns = (env1.proof_ns); + synth_hook = (env1.synth_hook); + try_solve_implicits_hook = (env1.try_solve_implicits_hook); + splice = (env1.splice); + mpreprocess = (env1.mpreprocess); + postprocess = (env1.postprocess); + identifier_info = (env1.identifier_info); + tc_hooks = (env1.tc_hooks); + dsenv = (env1.dsenv); + nbe = (env1.nbe); + strict_args_tab = (env1.strict_args_tab); + erasable_types_tab = (env1.erasable_types_tab); + enable_defer_to_tac = (env1.enable_defer_to_tac); + unif_allow_ref_guards = (env1.unif_allow_ref_guards); + erase_erasable_args = (env1.erase_erasable_args); + core_check = (env1.core_check); + missing_decl = (env1.missing_decl) + }) + | uu___ -> FStar_Pervasives_Native.None +let (push_binders : env -> FStarC_Syntax_Syntax.binders -> env) = + fun env1 -> + fun bs -> + FStarC_Compiler_List.fold_left + (fun env2 -> fun b -> push_bv env2 b.FStarC_Syntax_Syntax.binder_bv) + env1 bs +let (binding_of_lb : + FStarC_Syntax_Syntax.lbname -> + (FStarC_Syntax_Syntax.univ_names * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax) -> FStarC_Syntax_Syntax.binding) + = + fun x -> + fun t -> + match x with + | FStar_Pervasives.Inl x1 -> + let x2 = + { + FStarC_Syntax_Syntax.ppname = (x1.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = (x1.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = (FStar_Pervasives_Native.snd t) + } in + FStarC_Syntax_Syntax.Binding_var x2 + | FStar_Pervasives.Inr fv -> + FStarC_Syntax_Syntax.Binding_lid + (((fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v), t) +let (push_let_binding : + env -> FStarC_Syntax_Syntax.lbname -> FStarC_Syntax_Syntax.tscheme -> env) + = + fun env1 -> + fun lb -> fun ts -> push_local_binding env1 (binding_of_lb lb ts) +let (push_univ_vars : env -> FStarC_Syntax_Syntax.univ_names -> env) = + fun env1 -> + fun xs -> + FStarC_Compiler_List.fold_left + (fun env2 -> + fun x -> + push_local_binding env2 (FStarC_Syntax_Syntax.Binding_univ x)) + env1 xs +let (open_universes_in : + env -> + FStarC_Syntax_Syntax.univ_names -> + FStarC_Syntax_Syntax.term Prims.list -> + (env * FStarC_Syntax_Syntax.univ_names * FStarC_Syntax_Syntax.term + Prims.list)) + = + fun env1 -> + fun uvs -> + fun terms -> + let uu___ = FStarC_Syntax_Subst.univ_var_opening uvs in + match uu___ with + | (univ_subst, univ_vars) -> + let env' = push_univ_vars env1 univ_vars in + let uu___1 = + FStarC_Compiler_List.map (FStarC_Syntax_Subst.subst univ_subst) + terms in + (env', univ_vars, uu___1) +let (set_expected_typ : env -> FStarC_Syntax_Syntax.typ -> env) = + fun env1 -> + fun t -> + { + solver = (env1.solver); + range = (env1.range); + curmodule = (env1.curmodule); + gamma = (env1.gamma); + gamma_sig = (env1.gamma_sig); + gamma_cache = (env1.gamma_cache); + modules = (env1.modules); + expected_typ = (FStar_Pervasives_Native.Some (t, false)); + sigtab = (env1.sigtab); + attrtab = (env1.attrtab); + instantiate_imp = (env1.instantiate_imp); + effects = (env1.effects); + generalize = (env1.generalize); + letrecs = (env1.letrecs); + top_level = (env1.top_level); + check_uvars = (env1.check_uvars); + use_eq_strict = (env1.use_eq_strict); + is_iface = (env1.is_iface); + admit = (env1.admit); + lax_universes = (env1.lax_universes); + phase1 = (env1.phase1); + failhard = (env1.failhard); + flychecking = (env1.flychecking); + uvar_subtyping = (env1.uvar_subtyping); + intactics = (env1.intactics); + nocoerce = (env1.nocoerce); + tc_term = (env1.tc_term); + typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); + universe_of = (env1.universe_of); + typeof_well_typed_tot_or_gtot_term = + (env1.typeof_well_typed_tot_or_gtot_term); + teq_nosmt_force = (env1.teq_nosmt_force); + subtype_nosmt_force = (env1.subtype_nosmt_force); + qtbl_name_and_index = (env1.qtbl_name_and_index); + normalized_eff_names = (env1.normalized_eff_names); + fv_delta_depths = (env1.fv_delta_depths); + proof_ns = (env1.proof_ns); + synth_hook = (env1.synth_hook); + try_solve_implicits_hook = (env1.try_solve_implicits_hook); + splice = (env1.splice); + mpreprocess = (env1.mpreprocess); + postprocess = (env1.postprocess); + identifier_info = (env1.identifier_info); + tc_hooks = (env1.tc_hooks); + dsenv = (env1.dsenv); + nbe = (env1.nbe); + strict_args_tab = (env1.strict_args_tab); + erasable_types_tab = (env1.erasable_types_tab); + enable_defer_to_tac = (env1.enable_defer_to_tac); + unif_allow_ref_guards = (env1.unif_allow_ref_guards); + erase_erasable_args = (env1.erase_erasable_args); + core_check = (env1.core_check); + missing_decl = (env1.missing_decl) + } +let (set_expected_typ_maybe_eq : + env -> FStarC_Syntax_Syntax.typ -> Prims.bool -> env) = + fun env1 -> + fun t -> + fun use_eq -> + { + solver = (env1.solver); + range = (env1.range); + curmodule = (env1.curmodule); + gamma = (env1.gamma); + gamma_sig = (env1.gamma_sig); + gamma_cache = (env1.gamma_cache); + modules = (env1.modules); + expected_typ = (FStar_Pervasives_Native.Some (t, use_eq)); + sigtab = (env1.sigtab); + attrtab = (env1.attrtab); + instantiate_imp = (env1.instantiate_imp); + effects = (env1.effects); + generalize = (env1.generalize); + letrecs = (env1.letrecs); + top_level = (env1.top_level); + check_uvars = (env1.check_uvars); + use_eq_strict = (env1.use_eq_strict); + is_iface = (env1.is_iface); + admit = (env1.admit); + lax_universes = (env1.lax_universes); + phase1 = (env1.phase1); + failhard = (env1.failhard); + flychecking = (env1.flychecking); + uvar_subtyping = (env1.uvar_subtyping); + intactics = (env1.intactics); + nocoerce = (env1.nocoerce); + tc_term = (env1.tc_term); + typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); + universe_of = (env1.universe_of); + typeof_well_typed_tot_or_gtot_term = + (env1.typeof_well_typed_tot_or_gtot_term); + teq_nosmt_force = (env1.teq_nosmt_force); + subtype_nosmt_force = (env1.subtype_nosmt_force); + qtbl_name_and_index = (env1.qtbl_name_and_index); + normalized_eff_names = (env1.normalized_eff_names); + fv_delta_depths = (env1.fv_delta_depths); + proof_ns = (env1.proof_ns); + synth_hook = (env1.synth_hook); + try_solve_implicits_hook = (env1.try_solve_implicits_hook); + splice = (env1.splice); + mpreprocess = (env1.mpreprocess); + postprocess = (env1.postprocess); + identifier_info = (env1.identifier_info); + tc_hooks = (env1.tc_hooks); + dsenv = (env1.dsenv); + nbe = (env1.nbe); + strict_args_tab = (env1.strict_args_tab); + erasable_types_tab = (env1.erasable_types_tab); + enable_defer_to_tac = (env1.enable_defer_to_tac); + unif_allow_ref_guards = (env1.unif_allow_ref_guards); + erase_erasable_args = (env1.erase_erasable_args); + core_check = (env1.core_check); + missing_decl = (env1.missing_decl) + } +let (expected_typ : + env -> + (FStarC_Syntax_Syntax.typ * Prims.bool) FStar_Pervasives_Native.option) + = + fun env1 -> + match env1.expected_typ with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some t -> FStar_Pervasives_Native.Some t +let (clear_expected_typ : + env -> + (env * (FStarC_Syntax_Syntax.typ * Prims.bool) + FStar_Pervasives_Native.option)) + = + fun env_ -> + let uu___ = expected_typ env_ in + ({ + solver = (env_.solver); + range = (env_.range); + curmodule = (env_.curmodule); + gamma = (env_.gamma); + gamma_sig = (env_.gamma_sig); + gamma_cache = (env_.gamma_cache); + modules = (env_.modules); + expected_typ = FStar_Pervasives_Native.None; + sigtab = (env_.sigtab); + attrtab = (env_.attrtab); + instantiate_imp = (env_.instantiate_imp); + effects = (env_.effects); + generalize = (env_.generalize); + letrecs = (env_.letrecs); + top_level = (env_.top_level); + check_uvars = (env_.check_uvars); + use_eq_strict = (env_.use_eq_strict); + is_iface = (env_.is_iface); + admit = (env_.admit); + lax_universes = (env_.lax_universes); + phase1 = (env_.phase1); + failhard = (env_.failhard); + flychecking = (env_.flychecking); + uvar_subtyping = (env_.uvar_subtyping); + intactics = (env_.intactics); + nocoerce = (env_.nocoerce); + tc_term = (env_.tc_term); + typeof_tot_or_gtot_term = (env_.typeof_tot_or_gtot_term); + universe_of = (env_.universe_of); + typeof_well_typed_tot_or_gtot_term = + (env_.typeof_well_typed_tot_or_gtot_term); + teq_nosmt_force = (env_.teq_nosmt_force); + subtype_nosmt_force = (env_.subtype_nosmt_force); + qtbl_name_and_index = (env_.qtbl_name_and_index); + normalized_eff_names = (env_.normalized_eff_names); + fv_delta_depths = (env_.fv_delta_depths); + proof_ns = (env_.proof_ns); + synth_hook = (env_.synth_hook); + try_solve_implicits_hook = (env_.try_solve_implicits_hook); + splice = (env_.splice); + mpreprocess = (env_.mpreprocess); + postprocess = (env_.postprocess); + identifier_info = (env_.identifier_info); + tc_hooks = (env_.tc_hooks); + dsenv = (env_.dsenv); + nbe = (env_.nbe); + strict_args_tab = (env_.strict_args_tab); + erasable_types_tab = (env_.erasable_types_tab); + enable_defer_to_tac = (env_.enable_defer_to_tac); + unif_allow_ref_guards = (env_.unif_allow_ref_guards); + erase_erasable_args = (env_.erase_erasable_args); + core_check = (env_.core_check); + missing_decl = (env_.missing_decl) + }, uu___) +let (finish_module : env -> FStarC_Syntax_Syntax.modul -> env) = + let empty_lid = + let uu___ = let uu___1 = FStarC_Ident.id_of_text "" in [uu___1] in + FStarC_Ident.lid_of_ids uu___ in + fun env1 -> + fun m -> + let sigs = + let uu___ = + FStarC_Ident.lid_equals m.FStarC_Syntax_Syntax.name + FStarC_Parser_Const.prims_lid in + if uu___ + then + let uu___1 = + FStarC_Compiler_List.map FStar_Pervasives_Native.snd + env1.gamma_sig in + FStarC_Compiler_List.rev uu___1 + else m.FStarC_Syntax_Syntax.declarations in + { + solver = (env1.solver); + range = (env1.range); + curmodule = empty_lid; + gamma = []; + gamma_sig = []; + gamma_cache = (env1.gamma_cache); + modules = (m :: (env1.modules)); + expected_typ = (env1.expected_typ); + sigtab = (env1.sigtab); + attrtab = (env1.attrtab); + instantiate_imp = (env1.instantiate_imp); + effects = (env1.effects); + generalize = (env1.generalize); + letrecs = (env1.letrecs); + top_level = (env1.top_level); + check_uvars = (env1.check_uvars); + use_eq_strict = (env1.use_eq_strict); + is_iface = (env1.is_iface); + admit = (env1.admit); + lax_universes = (env1.lax_universes); + phase1 = (env1.phase1); + failhard = (env1.failhard); + flychecking = (env1.flychecking); + uvar_subtyping = (env1.uvar_subtyping); + intactics = (env1.intactics); + nocoerce = (env1.nocoerce); + tc_term = (env1.tc_term); + typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); + universe_of = (env1.universe_of); + typeof_well_typed_tot_or_gtot_term = + (env1.typeof_well_typed_tot_or_gtot_term); + teq_nosmt_force = (env1.teq_nosmt_force); + subtype_nosmt_force = (env1.subtype_nosmt_force); + qtbl_name_and_index = (env1.qtbl_name_and_index); + normalized_eff_names = (env1.normalized_eff_names); + fv_delta_depths = (env1.fv_delta_depths); + proof_ns = (env1.proof_ns); + synth_hook = (env1.synth_hook); + try_solve_implicits_hook = (env1.try_solve_implicits_hook); + splice = (env1.splice); + mpreprocess = (env1.mpreprocess); + postprocess = (env1.postprocess); + identifier_info = (env1.identifier_info); + tc_hooks = (env1.tc_hooks); + dsenv = (env1.dsenv); + nbe = (env1.nbe); + strict_args_tab = (env1.strict_args_tab); + erasable_types_tab = (env1.erasable_types_tab); + enable_defer_to_tac = (env1.enable_defer_to_tac); + unif_allow_ref_guards = (env1.unif_allow_ref_guards); + erase_erasable_args = (env1.erase_erasable_args); + core_check = (env1.core_check); + missing_decl = (env1.missing_decl) + } +let (uvars_in_env : env -> FStarC_Syntax_Syntax.uvars) = + fun env1 -> + let no_uvs = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) ()) in + let rec aux out g = + match g with + | [] -> out + | (FStarC_Syntax_Syntax.Binding_univ uu___)::tl -> aux out tl + | (FStarC_Syntax_Syntax.Binding_lid (uu___, (uu___1, t)))::tl -> + let uu___2 = + let uu___3 = FStarC_Syntax_Free.uvars t in + Obj.magic + (FStarC_Class_Setlike.union () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) (Obj.magic out) + (Obj.magic uu___3)) in + aux uu___2 tl + | (FStarC_Syntax_Syntax.Binding_var + { FStarC_Syntax_Syntax.ppname = uu___; + FStarC_Syntax_Syntax.index = uu___1; + FStarC_Syntax_Syntax.sort = t;_})::tl + -> + let uu___2 = + let uu___3 = FStarC_Syntax_Free.uvars t in + Obj.magic + (FStarC_Class_Setlike.union () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) (Obj.magic out) + (Obj.magic uu___3)) in + aux uu___2 tl in + aux no_uvs env1.gamma +let (univ_vars : + env -> FStarC_Syntax_Syntax.universe_uvar FStarC_Compiler_FlatSet.t) = + fun env1 -> + let no_univs = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_univ_uvar)) ()) in + let rec aux out g = + match g with + | [] -> out + | (FStarC_Syntax_Syntax.Binding_univ uu___)::tl -> aux out tl + | (FStarC_Syntax_Syntax.Binding_lid (uu___, (uu___1, t)))::tl -> + let uu___2 = + let uu___3 = FStarC_Syntax_Free.univs t in + Obj.magic + (FStarC_Class_Setlike.union () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_univ_uvar)) (Obj.magic out) + (Obj.magic uu___3)) in + aux uu___2 tl + | (FStarC_Syntax_Syntax.Binding_var + { FStarC_Syntax_Syntax.ppname = uu___; + FStarC_Syntax_Syntax.index = uu___1; + FStarC_Syntax_Syntax.sort = t;_})::tl + -> + let uu___2 = + let uu___3 = FStarC_Syntax_Free.univs t in + Obj.magic + (FStarC_Class_Setlike.union () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_univ_uvar)) (Obj.magic out) + (Obj.magic uu___3)) in + aux uu___2 tl in + aux no_univs env1.gamma +let (univnames : + env -> FStarC_Syntax_Syntax.univ_name FStarC_Compiler_FlatSet.t) = + fun env1 -> + let no_univ_names = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_ident)) ()) in + let rec aux out g = + match g with + | [] -> out + | (FStarC_Syntax_Syntax.Binding_univ uname)::tl -> + let uu___ = + Obj.magic + (FStarC_Class_Setlike.add () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_ident)) uname (Obj.magic out)) in + aux uu___ tl + | (FStarC_Syntax_Syntax.Binding_lid (uu___, (uu___1, t)))::tl -> + let uu___2 = + let uu___3 = FStarC_Syntax_Free.univnames t in + Obj.magic + (FStarC_Class_Setlike.union () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_ident)) (Obj.magic out) + (Obj.magic uu___3)) in + aux uu___2 tl + | (FStarC_Syntax_Syntax.Binding_var + { FStarC_Syntax_Syntax.ppname = uu___; + FStarC_Syntax_Syntax.index = uu___1; + FStarC_Syntax_Syntax.sort = t;_})::tl + -> + let uu___2 = + let uu___3 = FStarC_Syntax_Free.univnames t in + Obj.magic + (FStarC_Class_Setlike.union () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_ident)) (Obj.magic out) + (Obj.magic uu___3)) in + aux uu___2 tl in + aux no_univ_names env1.gamma +let (lidents : env -> FStarC_Ident.lident Prims.list) = + fun env1 -> + let keys = + FStarC_Compiler_List.collect FStar_Pervasives_Native.fst env1.gamma_sig in + FStarC_Compiler_Util.smap_fold (sigtab env1) + (fun uu___ -> + fun v -> + fun keys1 -> + FStarC_Compiler_List.op_At (FStarC_Syntax_Util.lids_of_sigelt v) + keys1) keys +let (should_enc_path : + (Prims.string Prims.list * Prims.bool) Prims.list -> + Prims.string Prims.list -> Prims.bool) + = + fun proof_ns -> + fun path -> + let rec str_i_prefix xs ys = + match (xs, ys) with + | ([], uu___) -> true + | (x::xs1, y::ys1) -> + ((FStarC_Compiler_String.lowercase x) = + (FStarC_Compiler_String.lowercase y)) + && (str_i_prefix xs1 ys1) + | (uu___, uu___1) -> false in + let uu___ = + FStarC_Compiler_List.tryFind + (fun uu___1 -> + match uu___1 with | (p, uu___2) -> str_i_prefix p path) proof_ns in + match uu___ with + | FStar_Pervasives_Native.None -> false + | FStar_Pervasives_Native.Some (uu___1, b) -> b +let (should_enc_lid : proof_namespace -> FStarC_Ident.lident -> Prims.bool) = + fun proof_ns -> + fun lid -> + let uu___ = FStarC_Ident.path_of_lid lid in + should_enc_path proof_ns uu___ +let (cons_proof_ns : Prims.bool -> env -> name_prefix -> env) = + fun b -> + fun e -> + fun path -> + { + solver = (e.solver); + range = (e.range); + curmodule = (e.curmodule); + gamma = (e.gamma); + gamma_sig = (e.gamma_sig); + gamma_cache = (e.gamma_cache); + modules = (e.modules); + expected_typ = (e.expected_typ); + sigtab = (e.sigtab); + attrtab = (e.attrtab); + instantiate_imp = (e.instantiate_imp); + effects = (e.effects); + generalize = (e.generalize); + letrecs = (e.letrecs); + top_level = (e.top_level); + check_uvars = (e.check_uvars); + use_eq_strict = (e.use_eq_strict); + is_iface = (e.is_iface); + admit = (e.admit); + lax_universes = (e.lax_universes); + phase1 = (e.phase1); + failhard = (e.failhard); + flychecking = (e.flychecking); + uvar_subtyping = (e.uvar_subtyping); + intactics = (e.intactics); + nocoerce = (e.nocoerce); + tc_term = (e.tc_term); + typeof_tot_or_gtot_term = (e.typeof_tot_or_gtot_term); + universe_of = (e.universe_of); + typeof_well_typed_tot_or_gtot_term = + (e.typeof_well_typed_tot_or_gtot_term); + teq_nosmt_force = (e.teq_nosmt_force); + subtype_nosmt_force = (e.subtype_nosmt_force); + qtbl_name_and_index = (e.qtbl_name_and_index); + normalized_eff_names = (e.normalized_eff_names); + fv_delta_depths = (e.fv_delta_depths); + proof_ns = ((path, b) :: (e.proof_ns)); + synth_hook = (e.synth_hook); + try_solve_implicits_hook = (e.try_solve_implicits_hook); + splice = (e.splice); + mpreprocess = (e.mpreprocess); + postprocess = (e.postprocess); + identifier_info = (e.identifier_info); + tc_hooks = (e.tc_hooks); + dsenv = (e.dsenv); + nbe = (e.nbe); + strict_args_tab = (e.strict_args_tab); + erasable_types_tab = (e.erasable_types_tab); + enable_defer_to_tac = (e.enable_defer_to_tac); + unif_allow_ref_guards = (e.unif_allow_ref_guards); + erase_erasable_args = (e.erase_erasable_args); + core_check = (e.core_check); + missing_decl = (e.missing_decl) + } +let (add_proof_ns : env -> name_prefix -> env) = + fun e -> fun path -> cons_proof_ns true e path +let (rem_proof_ns : env -> name_prefix -> env) = + fun e -> fun path -> cons_proof_ns false e path +let (get_proof_ns : env -> proof_namespace) = fun e -> e.proof_ns +let (set_proof_ns : proof_namespace -> env -> env) = + fun ns -> + fun e -> + { + solver = (e.solver); + range = (e.range); + curmodule = (e.curmodule); + gamma = (e.gamma); + gamma_sig = (e.gamma_sig); + gamma_cache = (e.gamma_cache); + modules = (e.modules); + expected_typ = (e.expected_typ); + sigtab = (e.sigtab); + attrtab = (e.attrtab); + instantiate_imp = (e.instantiate_imp); + effects = (e.effects); + generalize = (e.generalize); + letrecs = (e.letrecs); + top_level = (e.top_level); + check_uvars = (e.check_uvars); + use_eq_strict = (e.use_eq_strict); + is_iface = (e.is_iface); + admit = (e.admit); + lax_universes = (e.lax_universes); + phase1 = (e.phase1); + failhard = (e.failhard); + flychecking = (e.flychecking); + uvar_subtyping = (e.uvar_subtyping); + intactics = (e.intactics); + nocoerce = (e.nocoerce); + tc_term = (e.tc_term); + typeof_tot_or_gtot_term = (e.typeof_tot_or_gtot_term); + universe_of = (e.universe_of); + typeof_well_typed_tot_or_gtot_term = + (e.typeof_well_typed_tot_or_gtot_term); + teq_nosmt_force = (e.teq_nosmt_force); + subtype_nosmt_force = (e.subtype_nosmt_force); + qtbl_name_and_index = (e.qtbl_name_and_index); + normalized_eff_names = (e.normalized_eff_names); + fv_delta_depths = (e.fv_delta_depths); + proof_ns = ns; + synth_hook = (e.synth_hook); + try_solve_implicits_hook = (e.try_solve_implicits_hook); + splice = (e.splice); + mpreprocess = (e.mpreprocess); + postprocess = (e.postprocess); + identifier_info = (e.identifier_info); + tc_hooks = (e.tc_hooks); + dsenv = (e.dsenv); + nbe = (e.nbe); + strict_args_tab = (e.strict_args_tab); + erasable_types_tab = (e.erasable_types_tab); + enable_defer_to_tac = (e.enable_defer_to_tac); + unif_allow_ref_guards = (e.unif_allow_ref_guards); + erase_erasable_args = (e.erase_erasable_args); + core_check = (e.core_check); + missing_decl = (e.missing_decl) + } +let (unbound_vars : + env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.bv FStarC_Compiler_FlatSet.t) + = + fun e -> + fun t -> + let uu___ = FStarC_Syntax_Free.names t in + let uu___1 = bound_vars e in + FStarC_Compiler_List.fold_left + (fun uu___3 -> + fun uu___2 -> + (fun s -> + fun bv -> + Obj.magic + (FStarC_Class_Setlike.remove () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) bv (Obj.magic s))) + uu___3 uu___2) uu___ uu___1 +let (closed : env -> FStarC_Syntax_Syntax.term -> Prims.bool) = + fun e -> + fun t -> + let uu___ = unbound_vars e t in + FStarC_Class_Setlike.is_empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) (Obj.magic uu___) +let (closed' : FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t -> + let uu___ = FStarC_Syntax_Free.names t in + FStarC_Class_Setlike.is_empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) (Obj.magic uu___) +let (string_of_proof_ns : env -> Prims.string) = + fun env1 -> + let aux uu___ = + match uu___ with + | (p, b) -> + if (p = []) && b + then "*" + else + (let uu___2 = FStarC_Ident.text_of_path p in + Prims.strcat (if b then "+" else "-") uu___2) in + let uu___ = + let uu___1 = FStarC_Compiler_List.map aux env1.proof_ns in + FStarC_Compiler_List.rev uu___1 in + FStarC_Compiler_String.concat " " uu___ +let (guard_of_guard_formula : + FStarC_TypeChecker_Common.guard_formula -> guard_t) = + fun g -> + { + FStarC_TypeChecker_Common.guard_f = g; + FStarC_TypeChecker_Common.deferred_to_tac = + (Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic (FStarC_Compiler_CList.listlike_clist ())))); + FStarC_TypeChecker_Common.deferred = + (Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic (FStarC_Compiler_CList.listlike_clist ())))); + FStarC_TypeChecker_Common.univ_ineqs = + ((Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic (FStarC_Compiler_CList.listlike_clist ())))), + (Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic (FStarC_Compiler_CList.listlike_clist ()))))); + FStarC_TypeChecker_Common.implicits = + (Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic (FStarC_Compiler_CList.listlike_clist ())))) + } +let (guard_form : guard_t -> FStarC_TypeChecker_Common.guard_formula) = + fun g -> g.FStarC_TypeChecker_Common.guard_f +let (is_trivial : guard_t -> Prims.bool) = + fun g -> + let uu___ = + (((FStarC_TypeChecker_Common.uu___is_Trivial + g.FStarC_TypeChecker_Common.guard_f) + && + (FStarC_Class_Listlike.is_empty + (FStarC_Compiler_CList.listlike_clist ()) + g.FStarC_TypeChecker_Common.deferred)) + && + (FStarC_Class_Listlike.is_empty + (FStarC_Compiler_CList.listlike_clist ()) + (FStar_Pervasives_Native.fst + g.FStarC_TypeChecker_Common.univ_ineqs))) + && + (FStarC_Class_Listlike.is_empty + (FStarC_Compiler_CList.listlike_clist ()) + (FStar_Pervasives_Native.snd + g.FStarC_TypeChecker_Common.univ_ineqs)) in + if uu___ + then + FStarC_Compiler_CList.for_all + (fun imp -> + (let uu___1 = + FStarC_Syntax_Util.ctx_uvar_should_check + imp.FStarC_TypeChecker_Common.imp_uvar in + FStarC_Syntax_Syntax.uu___is_Allow_unresolved uu___1) || + (let uu___1 = + FStarC_Syntax_Unionfind.find + (imp.FStarC_TypeChecker_Common.imp_uvar).FStarC_Syntax_Syntax.ctx_uvar_head in + match uu___1 with + | FStar_Pervasives_Native.Some uu___2 -> true + | FStar_Pervasives_Native.None -> false)) + g.FStarC_TypeChecker_Common.implicits + else false +let (is_trivial_guard_formula : guard_t -> Prims.bool) = + fun g -> + match g with + | { + FStarC_TypeChecker_Common.guard_f = FStarC_TypeChecker_Common.Trivial; + FStarC_TypeChecker_Common.deferred_to_tac = uu___; + FStarC_TypeChecker_Common.deferred = uu___1; + FStarC_TypeChecker_Common.univ_ineqs = uu___2; + FStarC_TypeChecker_Common.implicits = uu___3;_} -> true + | uu___ -> false +let (trivial_guard : guard_t) = FStarC_TypeChecker_Common.trivial_guard +let (abstract_guard_n : + FStarC_Syntax_Syntax.binder Prims.list -> guard_t -> guard_t) = + fun bs -> + fun g -> + match g.FStarC_TypeChecker_Common.guard_f with + | FStarC_TypeChecker_Common.Trivial -> g + | FStarC_TypeChecker_Common.NonTrivial f -> + let f' = + FStarC_Syntax_Util.abs bs f + (FStar_Pervasives_Native.Some + (FStarC_Syntax_Util.residual_tot FStarC_Syntax_Util.ktype0)) in + { + FStarC_TypeChecker_Common.guard_f = + (FStarC_TypeChecker_Common.NonTrivial f'); + FStarC_TypeChecker_Common.deferred_to_tac = + (g.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (g.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (g.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = + (g.FStarC_TypeChecker_Common.implicits) + } +let (abstract_guard : FStarC_Syntax_Syntax.binder -> guard_t -> guard_t) = + fun b -> fun g -> abstract_guard_n [b] g +let (too_early_in_prims : env -> Prims.bool) = + fun env1 -> + let uu___ = lid_exists env1 FStarC_Parser_Const.effect_GTot_lid in + Prims.op_Negation uu___ +let (apply_guard : guard_t -> FStarC_Syntax_Syntax.term -> guard_t) = + fun g -> + fun e -> + match g.FStarC_TypeChecker_Common.guard_f with + | FStarC_TypeChecker_Common.Trivial -> g + | FStarC_TypeChecker_Common.NonTrivial f -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.as_arg e in [uu___5] in + { + FStarC_Syntax_Syntax.hd = f; + FStarC_Syntax_Syntax.args = uu___4 + } in + FStarC_Syntax_Syntax.Tm_app uu___3 in + FStarC_Syntax_Syntax.mk uu___2 f.FStarC_Syntax_Syntax.pos in + FStarC_TypeChecker_Common.NonTrivial uu___1 in + { + FStarC_TypeChecker_Common.guard_f = uu___; + FStarC_TypeChecker_Common.deferred_to_tac = + (g.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (g.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (g.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = + (g.FStarC_TypeChecker_Common.implicits) + } +let (map_guard : + guard_t -> + (FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) -> guard_t) + = + fun g -> + fun map -> + match g.FStarC_TypeChecker_Common.guard_f with + | FStarC_TypeChecker_Common.Trivial -> g + | FStarC_TypeChecker_Common.NonTrivial f -> + let uu___ = + let uu___1 = map f in FStarC_TypeChecker_Common.NonTrivial uu___1 in + { + FStarC_TypeChecker_Common.guard_f = uu___; + FStarC_TypeChecker_Common.deferred_to_tac = + (g.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (g.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (g.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = + (g.FStarC_TypeChecker_Common.implicits) + } +let (always_map_guard : + guard_t -> + (FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) -> guard_t) + = + fun g -> + fun map -> + match g.FStarC_TypeChecker_Common.guard_f with + | FStarC_TypeChecker_Common.Trivial -> + let uu___ = + let uu___1 = map FStarC_Syntax_Util.t_true in + FStarC_TypeChecker_Common.NonTrivial uu___1 in + { + FStarC_TypeChecker_Common.guard_f = uu___; + FStarC_TypeChecker_Common.deferred_to_tac = + (g.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (g.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (g.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = + (g.FStarC_TypeChecker_Common.implicits) + } + | FStarC_TypeChecker_Common.NonTrivial f -> + let uu___ = + let uu___1 = map f in FStarC_TypeChecker_Common.NonTrivial uu___1 in + { + FStarC_TypeChecker_Common.guard_f = uu___; + FStarC_TypeChecker_Common.deferred_to_tac = + (g.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (g.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (g.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = + (g.FStarC_TypeChecker_Common.implicits) + } +let (trivial : FStarC_TypeChecker_Common.guard_formula -> unit) = + fun t -> + match t with + | FStarC_TypeChecker_Common.Trivial -> () + | FStarC_TypeChecker_Common.NonTrivial uu___ -> failwith "impossible" +let (check_trivial : + FStarC_Syntax_Syntax.term -> FStarC_TypeChecker_Common.guard_formula) = + fun t -> FStarC_TypeChecker_Common.check_trivial t +let (conj_guard : guard_t -> guard_t -> guard_t) = + fun g1 -> fun g2 -> FStarC_TypeChecker_Common.conj_guard g1 g2 +let (conj_guards : guard_t Prims.list -> guard_t) = + fun gs -> FStarC_TypeChecker_Common.conj_guards gs +let (imp_guard : guard_t -> guard_t -> guard_t) = + fun g1 -> fun g2 -> FStarC_TypeChecker_Common.imp_guard g1 g2 +let (close_guard_univs : + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.binders -> guard_t -> guard_t) + = + fun us -> + fun bs -> + fun g -> + match g.FStarC_TypeChecker_Common.guard_f with + | FStarC_TypeChecker_Common.Trivial -> g + | FStarC_TypeChecker_Common.NonTrivial f -> + let f1 = + FStarC_Compiler_List.fold_right2 + (fun u -> + fun b -> + fun f2 -> + let uu___ = FStarC_Syntax_Syntax.is_null_binder b in + if uu___ + then f2 + else + FStarC_Syntax_Util.mk_forall u + b.FStarC_Syntax_Syntax.binder_bv f2) us bs f in + { + FStarC_TypeChecker_Common.guard_f = + (FStarC_TypeChecker_Common.NonTrivial f1); + FStarC_TypeChecker_Common.deferred_to_tac = + (g.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (g.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (g.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = + (g.FStarC_TypeChecker_Common.implicits) + } +let (close_forall : + env -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun env1 -> + fun bs -> + fun f -> + FStarC_Errors.with_ctx "While closing a formula" + (fun uu___ -> + (let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.mk_Total f in + FStarC_Syntax_Util.arrow bs uu___3 in + FStarC_Defensive.def_check_scoped hasBinders_env + FStarC_Class_Binders.hasNames_term + FStarC_Syntax_Print.pretty_term f.FStarC_Syntax_Syntax.pos + "close_forall" env1 uu___2); + (let bvs = + FStarC_Compiler_List.map + (fun b -> b.FStarC_Syntax_Syntax.binder_bv) bs in + let env_full = push_bvs env1 bvs in + let uu___2 = + FStarC_Compiler_List.fold_right + (fun bv -> + fun uu___3 -> + match uu___3 with + | (f1, e) -> + let e' = + let uu___4 = + let uu___5 = pop_bv e in + FStarC_Compiler_Util.must uu___5 in + FStar_Pervasives_Native.snd uu___4 in + (FStarC_Defensive.def_check_scoped hasBinders_env + FStarC_Class_Binders.hasNames_term + FStarC_Syntax_Print.pretty_term + FStarC_Compiler_Range_Type.dummyRange + "close_forall.sort" e' + bv.FStarC_Syntax_Syntax.sort; + (let f' = + let uu___5 = + FStarC_Syntax_Syntax.is_null_bv bv in + if uu___5 + then f1 + else + (let u = + e'.universe_of e' + bv.FStarC_Syntax_Syntax.sort in + FStarC_Syntax_Util.mk_forall u bv f1) in + (f', e')))) bvs (f, env_full) in + match uu___2 with | (f', e) -> f')) +let (close_guard : env -> FStarC_Syntax_Syntax.binders -> guard_t -> guard_t) + = + fun env1 -> + fun binders -> + fun g -> + match g.FStarC_TypeChecker_Common.guard_f with + | FStarC_TypeChecker_Common.Trivial -> g + | FStarC_TypeChecker_Common.NonTrivial f -> + let uu___ = + let uu___1 = close_forall env1 binders f in + FStarC_TypeChecker_Common.NonTrivial uu___1 in + { + FStarC_TypeChecker_Common.guard_f = uu___; + FStarC_TypeChecker_Common.deferred_to_tac = + (g.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (g.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (g.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = + (g.FStarC_TypeChecker_Common.implicits) + } +let (new_tac_implicit_var : + Prims.string -> + FStarC_Compiler_Range_Type.range -> + env -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.should_check_uvar -> + FStarC_Syntax_Syntax.ctx_uvar Prims.list -> + FStarC_Syntax_Syntax.ctx_uvar_meta_t + FStar_Pervasives_Native.option -> + Prims.bool -> + (FStarC_Syntax_Syntax.term * (FStarC_Syntax_Syntax.ctx_uvar + * FStarC_Compiler_Range_Type.range) * guard_t)) + = + fun reason -> + fun r -> + fun env1 -> + fun uvar_typ -> + fun should_check -> + fun uvar_typedness_deps -> + fun meta -> + fun unrefine -> + let binders = all_binders env1 in + let gamma = env1.gamma in + let decoration = + { + FStarC_Syntax_Syntax.uvar_decoration_typ = uvar_typ; + FStarC_Syntax_Syntax.uvar_decoration_typedness_depends_on + = uvar_typedness_deps; + FStarC_Syntax_Syntax.uvar_decoration_should_check = + should_check; + FStarC_Syntax_Syntax.uvar_decoration_should_unrefine = + unrefine + } in + let ctx_uvar = + let uu___ = FStarC_Syntax_Unionfind.fresh decoration r in + { + FStarC_Syntax_Syntax.ctx_uvar_head = uu___; + FStarC_Syntax_Syntax.ctx_uvar_gamma = gamma; + FStarC_Syntax_Syntax.ctx_uvar_binders = binders; + FStarC_Syntax_Syntax.ctx_uvar_reason = reason; + FStarC_Syntax_Syntax.ctx_uvar_range = r; + FStarC_Syntax_Syntax.ctx_uvar_meta = meta + } in + FStarC_TypeChecker_Common.check_uvar_ctx_invariant reason r + true gamma binders; + (let t = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_uvar + (ctx_uvar, ([], FStarC_Syntax_Syntax.NoUseRange))) + r in + let imp = + { + FStarC_TypeChecker_Common.imp_reason = reason; + FStarC_TypeChecker_Common.imp_uvar = ctx_uvar; + FStarC_TypeChecker_Common.imp_tm = t; + FStarC_TypeChecker_Common.imp_range = r + } in + (let uu___2 = + FStarC_Compiler_Effect.op_Bang dbg_ImplicitTrace in + if uu___2 + then + let uu___3 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_uvar + ctx_uvar.FStarC_Syntax_Syntax.ctx_uvar_head in + FStarC_Compiler_Util.print1 + "Just created uvar for implicit {%s}\n" uu___3 + else ()); + (let g = + let uu___2 = + Obj.magic + (FStarC_Class_Listlike.cons () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist ())) + imp + (FStarC_Class_Listlike.empty () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist ())))) in + { + FStarC_TypeChecker_Common.guard_f = + (trivial_guard.FStarC_TypeChecker_Common.guard_f); + FStarC_TypeChecker_Common.deferred_to_tac = + (trivial_guard.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (trivial_guard.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (trivial_guard.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = uu___2 + } in + (t, (ctx_uvar, r), g))) +let (new_implicit_var_aux : + Prims.string -> + FStarC_Compiler_Range_Type.range -> + env -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.should_check_uvar -> + FStarC_Syntax_Syntax.ctx_uvar_meta_t + FStar_Pervasives_Native.option -> + Prims.bool -> + (FStarC_Syntax_Syntax.term * (FStarC_Syntax_Syntax.ctx_uvar * + FStarC_Compiler_Range_Type.range) * guard_t)) + = + fun reason -> + fun r -> + fun env1 -> + fun k -> + fun should_check -> + fun meta -> + fun unrefine -> + new_tac_implicit_var reason r env1 k should_check [] meta + unrefine +let (uvar_meta_for_binder : + FStarC_Syntax_Syntax.binder -> + (FStarC_Syntax_Syntax.ctx_uvar_meta_t FStar_Pervasives_Native.option * + Prims.bool)) + = + fun b -> + let should_unrefine = + FStarC_Syntax_Util.has_attribute b.FStarC_Syntax_Syntax.binder_attrs + FStarC_Parser_Const.unrefine_binder_attr in + let meta = + match b.FStarC_Syntax_Syntax.binder_qual with + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Meta tau) -> + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Ctx_uvar_meta_tac tau) + | uu___ -> + let is_unification_tag t = + let uu___1 = FStarC_Syntax_Util.head_and_args t in + match uu___1 with + | (hd, args) -> + let hd1 = FStarC_Syntax_Util.un_uinst hd in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.compress hd1 in + uu___4.FStarC_Syntax_Syntax.n in + (uu___3, args) in + (match uu___2 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (uu___3, FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = uu___4;_}):: + (a, FStar_Pervasives_Native.None)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.unification_tag_lid + -> FStar_Pervasives_Native.Some a + | uu___3 -> FStar_Pervasives_Native.None) in + let uu___1 = + FStarC_Compiler_List.tryPick is_unification_tag + b.FStarC_Syntax_Syntax.binder_attrs in + (match uu___1 with + | FStar_Pervasives_Native.Some tag -> + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Ctx_uvar_meta_attr tag) + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None) in + (meta, should_unrefine) +let (uvars_for_binders : + env -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.subst_t -> + (FStarC_Syntax_Syntax.binder -> Prims.string) -> + FStarC_Compiler_Range_Type.range -> + (FStarC_Syntax_Syntax.term Prims.list * guard_t)) + = + fun env1 -> + fun bs -> + fun substs -> + fun reason -> + fun r -> + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun b -> + match uu___1 with + | (substs1, uvars, g) -> + let sort = + FStarC_Syntax_Subst.subst substs1 + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + let uu___2 = uvar_meta_for_binder b in + (match uu___2 with + | (ctx_uvar_meta, should_unrefine) -> + let uu___3 = + let uu___4 = reason b in + let uu___5 = + let uu___6 = + FStarC_Options.compat_pre_typed_indexed_effects + () in + if uu___6 + then + FStarC_Syntax_Syntax.Allow_untyped + "indexed effect uvar in compat mode" + else FStarC_Syntax_Syntax.Strict in + new_implicit_var_aux uu___4 r env1 sort + uu___5 ctx_uvar_meta should_unrefine in + (match uu___3 with + | (t, l_ctx_uvars, g_t) -> + ((let uu___5 = + FStarC_Compiler_Effect.op_Bang + dbg_LayeredEffectsEqns in + if uu___5 + then + let uu___6 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_tuple2 + FStarC_Syntax_Print.showable_ctxu + FStarC_Compiler_Range_Ops.showable_range) + l_ctx_uvars in + FStarC_Compiler_Util.print1 + "Layered Effect uvar: %s\n" uu___6 + else ()); + (let uu___5 = conj_guards [g; g_t] in + ((FStarC_Compiler_List.op_At substs1 + [FStarC_Syntax_Syntax.NT + ((b.FStarC_Syntax_Syntax.binder_bv), + t)]), + (FStarC_Compiler_List.op_At uvars [t]), + uu___5)))))) + (substs, [], trivial_guard) bs in + match uu___ with | (uu___1, uvars, g) -> (uvars, g) +let (pure_precondition_for_trivial_post : + env -> + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.typ -> + FStarC_Compiler_Range_Type.range -> FStarC_Syntax_Syntax.typ) + = + fun env1 -> + fun u -> + fun t -> + fun wp -> + fun r -> + let trivial_post = + let post_ts = + let uu___ = + lookup_definition [NoDelta] env1 + FStarC_Parser_Const.trivial_pure_post_lid in + FStarC_Compiler_Util.must uu___ in + let uu___ = inst_tscheme_with post_ts [u] in + match uu___ with + | (uu___1, post) -> + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.as_arg t in [uu___3] in + FStarC_Syntax_Syntax.mk_Tm_app post uu___2 r in + let uu___ = + let uu___1 = FStarC_Syntax_Syntax.as_arg trivial_post in + [uu___1] in + FStarC_Syntax_Syntax.mk_Tm_app wp uu___ r +let (get_letrec_arity : + env -> + FStarC_Syntax_Syntax.lbname -> Prims.int FStar_Pervasives_Native.option) + = + fun env1 -> + fun lbname -> + let compare_either f1 f2 e1 e2 = + match (e1, e2) with + | (FStar_Pervasives.Inl v1, FStar_Pervasives.Inl v2) -> f1 v1 v2 + | (FStar_Pervasives.Inr v1, FStar_Pervasives.Inr v2) -> f2 v1 v2 + | uu___ -> false in + let uu___ = + FStarC_Compiler_Util.find_opt + (fun uu___1 -> + match uu___1 with + | (lbname', uu___2, uu___3, uu___4) -> + compare_either FStarC_Syntax_Syntax.bv_eq + FStarC_Syntax_Syntax.fv_eq lbname lbname') env1.letrecs in + match uu___ with + | FStar_Pervasives_Native.Some (uu___1, arity, uu___2, uu___3) -> + FStar_Pervasives_Native.Some arity + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None +let (fvar_of_nonqual_lid : + env -> FStarC_Ident.lident -> FStarC_Syntax_Syntax.term) = + fun env1 -> + fun lid -> + let qn = lookup_qname env1 lid in + FStarC_Syntax_Syntax.fvar lid FStar_Pervasives_Native.None +let (split_smt_query : + env -> + FStarC_Syntax_Syntax.term -> + (env * FStarC_Syntax_Syntax.term) Prims.list + FStar_Pervasives_Native.option) + = + fun e -> + fun q -> + match (e.solver).spinoff_strictly_positive_goals with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some p -> + let uu___ = p e q in FStar_Pervasives_Native.Some uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_Err.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Err.ml new file mode 100644 index 00000000000..1cfb4464221 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Err.ml @@ -0,0 +1,822 @@ +open Prims +let (info_at_pos : + FStarC_TypeChecker_Env.env -> + Prims.string -> + Prims.int -> + Prims.int -> + ((Prims.string, FStarC_Ident.lident) FStar_Pervasives.either * + FStarC_Syntax_Syntax.typ * FStarC_Compiler_Range_Type.range) + FStar_Pervasives_Native.option) + = + fun env -> + fun file -> + fun row -> + fun col -> + let uu___ = + let uu___1 = + FStarC_Compiler_Effect.op_Bang + env.FStarC_TypeChecker_Env.identifier_info in + FStarC_TypeChecker_Common.id_info_at_pos uu___1 file row col in + match uu___ with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some info -> + (match info.FStarC_TypeChecker_Common.identifier with + | FStar_Pervasives.Inl bv -> + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Ident.showable_ident + bv.FStarC_Syntax_Syntax.ppname in + FStar_Pervasives.Inl uu___3 in + let uu___3 = FStarC_Syntax_Syntax.range_of_bv bv in + (uu___2, (info.FStarC_TypeChecker_Common.identifier_ty), + uu___3) in + FStar_Pervasives_Native.Some uu___1 + | FStar_Pervasives.Inr fv -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.lid_of_fv fv in + FStar_Pervasives.Inr uu___3 in + let uu___3 = FStarC_Syntax_Syntax.range_of_fv fv in + (uu___2, (info.FStarC_TypeChecker_Common.identifier_ty), + uu___3) in + FStar_Pervasives_Native.Some uu___1) +let print_discrepancy : 'a 'b . ('a -> 'b) -> 'a -> 'a -> ('b * 'b) = + fun f -> + fun x -> + fun y -> + let print uu___ = + let xs = f x in let ys = f y in (xs, ys, (xs <> ys)) in + let rec blist_leq l1 l2 = + match (l1, l2) with + | (h1::t1, h2::t2) -> + ((Prims.op_Negation h1) || h2) && (blist_leq t1 t2) + | ([], []) -> true + | uu___ -> failwith "print_discrepancy: bad lists" in + let rec succ l = + match l with + | (false)::t -> true :: t + | (true)::t -> let uu___ = succ t in false :: uu___ + | [] -> failwith "" in + let full l = FStarC_Compiler_List.for_all (fun b1 -> b1) l in + let get_bool_option s = + let uu___ = FStarC_Options.get_option s in + match uu___ with + | FStarC_Options.Bool b1 -> b1 + | uu___1 -> failwith "print_discrepancy: impossible" in + let set_bool_option s b1 = + FStarC_Options.set_option s (FStarC_Options.Bool b1) in + let get uu___ = + let pi = get_bool_option "print_implicits" in + let pu = get_bool_option "print_universes" in + let pea = get_bool_option "print_effect_args" in + let pf = get_bool_option "print_full_names" in [pi; pu; pea; pf] in + let set l = + match l with + | pi::pu::pea::pf::[] -> + (set_bool_option "print_implicits" pi; + set_bool_option "print_universes" pu; + set_bool_option "print_effect_args" pea; + set_bool_option "print_full_names " pf) + | uu___ -> failwith "impossible: print_discrepancy" in + let bas = get () in + let rec go cur = + if full cur + then + let uu___ = print () in + match uu___ with | (xs, ys, uu___1) -> (xs, ys) + else + if (let uu___ = blist_leq bas cur in Prims.op_Negation uu___) + then (let uu___ = succ cur in go uu___) + else + (set cur; + (let uu___1 = print () in + match uu___1 with + | (xs, ys, true) -> (xs, ys) + | uu___2 -> let uu___3 = succ cur in go uu___3)) in + FStarC_Options.with_saved_options (fun uu___ -> go bas) +let (errors_smt_detail : + FStarC_TypeChecker_Env.env -> + FStarC_Errors.error Prims.list -> + FStarC_Errors_Msg.error_message -> FStarC_Errors.error Prims.list) + = + fun env -> + fun errs -> + fun smt_detail -> + let errs1 = + FStarC_Compiler_List.map + (fun uu___ -> + match uu___ with + | (e, msg, r, ctx) -> + let uu___1 = + let msg1 = FStarC_Compiler_List.op_At msg smt_detail in + if r = FStarC_Compiler_Range_Type.dummyRange + then + let uu___2 = FStarC_TypeChecker_Env.get_range env in + (e, msg1, uu___2, ctx) + else + (let r' = + let uu___3 = FStarC_Compiler_Range_Type.use_range r in + FStarC_Compiler_Range_Type.set_def_range r uu___3 in + let uu___3 = + let uu___4 = + FStarC_Compiler_Range_Ops.file_of_range r' in + let uu___5 = + let uu___6 = FStarC_TypeChecker_Env.get_range env in + FStarC_Compiler_Range_Ops.file_of_range uu___6 in + uu___4 <> uu___5 in + if uu___3 + then + let msg2 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Compiler_Range_Ops.string_of_use_range + r in + Prims.strcat "Also see: " uu___7 in + FStarC_Pprint.doc_of_string uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Compiler_Range_Type.use_range r in + let uu___10 = + FStarC_Compiler_Range_Type.def_range r in + uu___9 <> uu___10 in + if uu___8 + then + let uu___9 = + let uu___10 = + FStarC_Compiler_Range_Ops.string_of_def_range + r in + Prims.strcat + "Other related locations: " uu___10 in + FStarC_Pprint.doc_of_string uu___9 + else FStarC_Pprint.empty in + [uu___7] in + uu___5 :: uu___6 in + FStarC_Compiler_List.op_At msg1 uu___4 in + let uu___4 = FStarC_TypeChecker_Env.get_range env in + (e, msg2, uu___4, ctx) + else (e, msg1, r, ctx)) in + (match uu___1 with + | (e1, msg1, r1, ctx1) -> (e1, msg1, r1, ctx1))) errs in + errs1 +let (add_errors : + FStarC_TypeChecker_Env.env -> FStarC_Errors.error Prims.list -> unit) = + fun env -> + fun errs -> + let uu___ = errors_smt_detail env errs [] in + FStarC_Errors.add_errors uu___ +let (log_issue : + FStarC_TypeChecker_Env.env -> + FStarC_Compiler_Range_Type.range -> + (FStarC_Errors_Codes.error_code * FStarC_Errors_Msg.error_message) -> + unit) + = + fun env -> + fun r -> + fun uu___ -> + match uu___ with + | (e, m) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Errors.get_ctx () in (e, m, r, uu___3) in + [uu___2] in + add_errors env uu___1 +let (log_issue_text : + FStarC_TypeChecker_Env.env -> + FStarC_Compiler_Range_Type.range -> + (FStarC_Errors_Codes.error_code * Prims.string) -> unit) + = + fun env -> + fun r -> + fun uu___ -> + match uu___ with + | (e, m) -> + let uu___1 = + let uu___2 = let uu___3 = FStarC_Errors_Msg.text m in [uu___3] in + (e, uu___2) in + log_issue env r uu___1 +let (err_msg_type_strings : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> (Prims.string * Prims.string)) + = + fun env -> + fun t1 -> + fun t2 -> + print_discrepancy (FStarC_TypeChecker_Normalize.term_to_string env) + t1 t2 +let (err_msg_comp_strings : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.comp -> + FStarC_Syntax_Syntax.comp -> (Prims.string * Prims.string)) + = + fun env -> + fun c1 -> + fun c2 -> + print_discrepancy (FStarC_TypeChecker_Normalize.comp_to_string env) + c1 c2 +let (exhaustiveness_check : FStarC_Pprint.document Prims.list) = + let uu___ = FStarC_Errors_Msg.text "Patterns are incomplete" in [uu___] +let (subtyping_failed : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.typ -> unit -> FStarC_Errors_Msg.error_message) + = + fun env -> + fun t1 -> + fun t2 -> + fun uu___ -> + let ppt = FStarC_TypeChecker_Normalize.term_to_doc env in + let uu___1 = FStarC_Errors_Msg.text "Subtyping check failed" in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Errors_Msg.text "Expected type" in + let uu___6 = ppt t2 in + FStarC_Pprint.prefix (Prims.of_int (2)) Prims.int_one uu___5 + uu___6 in + let uu___5 = + let uu___6 = FStarC_Errors_Msg.text "got type" in + let uu___7 = ppt t1 in + FStarC_Pprint.prefix (Prims.of_int (2)) Prims.int_one uu___6 + uu___7 in + FStarC_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in + [uu___3] in + uu___1 :: uu___2 +let (ill_kinded_type : FStarC_Errors_Msg.error_message) = + FStarC_Errors_Msg.mkmsg "Ill-kinded type" +let unexpected_signature_for_monad : + 'a . + FStarC_TypeChecker_Env.env -> + FStarC_Compiler_Range_Type.range -> + FStarC_Ident.lident -> FStarC_Syntax_Syntax.term -> 'a + = + fun env -> + fun rng -> + fun m -> + fun k -> + let uu___ = + let uu___1 = + FStarC_Class_Show.show FStarC_Ident.showable_lident m in + let uu___2 = FStarC_TypeChecker_Normalize.term_to_string env k in + FStarC_Compiler_Util.format2 + "Unexpected signature for monad \"%s\". Expected a signature of the form (a:Type -> WP a -> Effect); got %s" + uu___1 uu___2 in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range rng + FStarC_Errors_Codes.Fatal_UnexpectedSignatureForMonad () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___) +let expected_a_term_of_type_t_got_a_function : + 'uuuuu . + FStarC_TypeChecker_Env.env -> + FStarC_Compiler_Range_Type.range -> + Prims.string -> + FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.term -> 'uuuuu + = + fun env -> + fun rng -> + fun msg -> + fun t -> + fun e -> + let uu___ = + let uu___1 = FStarC_TypeChecker_Normalize.term_to_string env t in + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + FStarC_Compiler_Util.format3 + "Expected a term of type \"%s\"; got a function \"%s\" (%s)" + uu___1 uu___2 msg in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range + rng FStarC_Errors_Codes.Fatal_ExpectTermGotFunction () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___) +let (unexpected_implicit_argument : + (FStarC_Errors_Codes.error_code * Prims.string)) = + (FStarC_Errors_Codes.Fatal_UnexpectedImplicitArgument, + "Unexpected instantiation of an implicit argument to a function that only expects explicit arguments") +let expected_expression_of_type : + 'a . + FStarC_TypeChecker_Env.env -> + FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term -> 'a + = + fun env -> + fun rng -> + fun t1 -> + fun e -> + fun t2 -> + let d1 = FStarC_TypeChecker_Normalize.term_to_doc env t1 in + let d2 = FStarC_TypeChecker_Normalize.term_to_doc env t2 in + let ed = FStarC_TypeChecker_Normalize.term_to_doc env e in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Errors_Msg.text "Expected expression of type" in + FStarC_Pprint.prefix (Prims.of_int (4)) Prims.int_one + uu___3 d1 in + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Errors_Msg.text "got expression" in + FStarC_Pprint.prefix (Prims.of_int (4)) Prims.int_one + uu___5 ed in + let uu___5 = + let uu___6 = FStarC_Errors_Msg.text "of type" in + FStarC_Pprint.prefix (Prims.of_int (4)) Prims.int_one + uu___6 d2 in + FStarC_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in + FStarC_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in + [uu___1] in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range + rng FStarC_Errors_Codes.Fatal_UnexpectedExpressionType () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___) +let (expected_pattern_of_type : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> + (FStarC_Errors_Codes.error_code * Prims.string)) + = + fun env -> + fun t1 -> + fun e -> + fun t2 -> + let uu___ = err_msg_type_strings env t1 t2 in + match uu___ with + | (s1, s2) -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + FStarC_Compiler_Util.format3 + "Expected pattern of type \"%s\"; got pattern \"%s\" of type \"%s\"" + s1 uu___2 s2 in + (FStarC_Errors_Codes.Fatal_UnexpectedPattern, uu___1) +let (basic_type_error : + FStarC_TypeChecker_Env.env -> + FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term -> unit) + = + fun env -> + fun rng -> + fun eopt -> + fun t1 -> + fun t2 -> + let uu___ = err_msg_type_strings env t1 t2 in + match uu___ with + | (s1, s2) -> + let msg = + match eopt with + | FStar_Pervasives_Native.None -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Errors_Msg.text "Expected type" in + let uu___4 = + FStarC_TypeChecker_Normalize.term_to_doc env t1 in + FStarC_Pprint.prefix (Prims.of_int (4)) + Prims.int_one uu___3 uu___4 in + let uu___3 = + let uu___4 = FStarC_Errors_Msg.text "got type" in + let uu___5 = + FStarC_TypeChecker_Normalize.term_to_doc env t2 in + FStarC_Pprint.prefix (Prims.of_int (4)) + Prims.int_one uu___4 uu___5 in + FStarC_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in + [uu___1] + | FStar_Pervasives_Native.Some e -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Errors_Msg.text "Expected type" in + let uu___4 = + FStarC_TypeChecker_Normalize.term_to_doc env t1 in + FStarC_Pprint.prefix (Prims.of_int (4)) + Prims.int_one uu___3 uu___4 in + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Errors_Msg.text "but" in + let uu___6 = + FStarC_TypeChecker_Normalize.term_to_doc env e in + FStarC_Pprint.prefix (Prims.of_int (4)) + Prims.int_one uu___5 uu___6 in + let uu___5 = + let uu___6 = FStarC_Errors_Msg.text "has type" in + let uu___7 = + FStarC_TypeChecker_Normalize.term_to_doc env t2 in + FStarC_Pprint.prefix (Prims.of_int (4)) + Prims.int_one uu___6 uu___7 in + FStarC_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in + FStarC_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in + [uu___1] in + FStarC_Errors.log_issue FStarC_Class_HasRange.hasRange_range + rng FStarC_Errors_Codes.Error_TypeError () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic msg) +let raise_basic_type_error : + 'a . + FStarC_TypeChecker_Env.env -> + FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term -> 'a + = + fun env -> + fun rng -> + fun eopt -> + fun t1 -> + fun t2 -> + let uu___ = err_msg_type_strings env t1 t2 in + match uu___ with + | (s1, s2) -> + let msg = + match eopt with + | FStar_Pervasives_Native.None -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Errors_Msg.text "Expected type" in + let uu___4 = + FStarC_TypeChecker_Normalize.term_to_doc env t1 in + FStarC_Pprint.prefix (Prims.of_int (4)) + Prims.int_one uu___3 uu___4 in + let uu___3 = + let uu___4 = FStarC_Errors_Msg.text "got type" in + let uu___5 = + FStarC_TypeChecker_Normalize.term_to_doc env t2 in + FStarC_Pprint.prefix (Prims.of_int (4)) + Prims.int_one uu___4 uu___5 in + FStarC_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in + [uu___1] + | FStar_Pervasives_Native.Some e -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Errors_Msg.text "Expected type" in + let uu___4 = + FStarC_TypeChecker_Normalize.term_to_doc env t1 in + FStarC_Pprint.prefix (Prims.of_int (4)) + Prims.int_one uu___3 uu___4 in + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Errors_Msg.text "but" in + let uu___6 = + FStarC_TypeChecker_Normalize.term_to_doc env e in + FStarC_Pprint.prefix (Prims.of_int (4)) + Prims.int_one uu___5 uu___6 in + let uu___5 = + let uu___6 = FStarC_Errors_Msg.text "has type" in + let uu___7 = + FStarC_TypeChecker_Normalize.term_to_doc env t2 in + FStarC_Pprint.prefix (Prims.of_int (4)) + Prims.int_one uu___6 uu___7 in + FStarC_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in + FStarC_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in + [uu___1] in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range rng + FStarC_Errors_Codes.Error_TypeError () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic msg) +let (occurs_check : (FStarC_Errors_Codes.error_code * Prims.string)) = + (FStarC_Errors_Codes.Fatal_PossibleInfiniteTyp, + "Possibly infinite typ (occurs check failed)") +let constructor_fails_the_positivity_check : + 'uuuuu . + 'uuuuu -> + FStarC_Syntax_Syntax.term -> + FStarC_Ident.lid -> (FStarC_Errors_Codes.error_code * Prims.string) + = + fun env -> + fun d -> + fun l -> + let uu___ = + let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term d in + let uu___2 = FStarC_Class_Show.show FStarC_Ident.showable_lident l in + FStarC_Compiler_Util.format2 + "Constructor \"%s\" fails the strict positivity check; the constructed type \"%s\" occurs to the left of a pure function type" + uu___1 uu___2 in + (FStarC_Errors_Codes.Fatal_ConstructorFailedCheck, uu___) +let (inline_type_annotation_and_val_decl : + FStarC_Ident.lid -> (FStarC_Errors_Codes.error_code * Prims.string)) = + fun l -> + let uu___ = + let uu___1 = FStarC_Class_Show.show FStarC_Ident.showable_lident l in + FStarC_Compiler_Util.format1 + "\"%s\" has a val declaration as well as an inlined type annotation; remove one" + uu___1 in + (FStarC_Errors_Codes.Fatal_DuplicateTypeAnnotationAndValDecl, uu___) +let (inferred_type_causes_variable_to_escape : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.bv -> + (FStarC_Errors_Codes.error_code * Prims.string)) + = + fun env -> + fun t -> + fun x -> + let uu___ = + let uu___1 = FStarC_TypeChecker_Normalize.term_to_string env t in + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_bv x in + FStarC_Compiler_Util.format2 + "Inferred type \"%s\" causes variable \"%s\" to escape its scope" + uu___1 uu___2 in + (FStarC_Errors_Codes.Fatal_InferredTypeCauseVarEscape, uu___) +let expected_function_typ : + 'a . + FStarC_TypeChecker_Env.env -> + FStarC_Compiler_Range_Type.range -> FStarC_Syntax_Syntax.term -> 'a + = + fun env -> + fun rng -> + fun t -> + let uu___ = + let uu___1 = FStarC_Errors_Msg.text "Expected a function." in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Errors_Msg.text "Got an expression of type:" in + let uu___5 = FStarC_TypeChecker_Normalize.term_to_doc env t in + FStarC_Pprint.prefix (Prims.of_int (2)) Prims.int_one uu___4 + uu___5 in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range rng + FStarC_Errors_Codes.Fatal_FunctionTypeExpected () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___) +let (expected_poly_typ : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> + (FStarC_Errors_Codes.error_code * Prims.string)) + = + fun env -> + fun f -> + fun t -> + fun targ -> + let uu___ = + let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term f in + let uu___2 = FStarC_TypeChecker_Normalize.term_to_string env t in + let uu___3 = FStarC_TypeChecker_Normalize.term_to_string env targ in + FStarC_Compiler_Util.format3 + "Expected a polymorphic function; got an expression \"%s\" of type \"%s\" applied to a type \"%s\"" + uu___1 uu___2 uu___3 in + (FStarC_Errors_Codes.Fatal_PolyTypeExpected, uu___) +let (disjunctive_pattern_vars : + FStarC_Syntax_Syntax.bv Prims.list -> + FStarC_Syntax_Syntax.bv Prims.list -> + (FStarC_Errors_Codes.error_code * Prims.string)) + = + fun v1 -> + fun v2 -> + let vars v = + let uu___ = + FStarC_Compiler_List.map + (FStarC_Class_Show.show FStarC_Syntax_Print.showable_bv) v in + FStarC_Compiler_String.concat ", " uu___ in + let uu___ = + let uu___1 = vars v1 in + let uu___2 = vars v2 in + FStarC_Compiler_Util.format2 + "Every alternative of an 'or' pattern must bind the same variables; here one branch binds (\"%s\") and another (\"%s\")" + uu___1 uu___2 in + (FStarC_Errors_Codes.Fatal_DisjuctivePatternVarsMismatch, uu___) +let (name_and_result : + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> + (Prims.string * FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax)) + = + fun c -> + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total t -> ("Tot", t) + | FStarC_Syntax_Syntax.GTotal t -> ("GTot", t) + | FStarC_Syntax_Syntax.Comp ct -> + let uu___ = + FStarC_Class_Show.show FStarC_Ident.showable_lident + ct.FStarC_Syntax_Syntax.effect_name in + (uu___, (ct.FStarC_Syntax_Syntax.result_typ)) +let computed_computation_type_does_not_match_annotation : + 'uuuuu 'a . + FStarC_TypeChecker_Env.env -> + FStarC_Compiler_Range_Type.range -> + 'uuuuu -> + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> 'a + = + fun env -> + fun r -> + fun e -> + fun c -> + fun c' -> + let ppt = FStarC_TypeChecker_Normalize.term_to_doc env in + let uu___ = name_and_result c in + match uu___ with + | (f1, r1) -> + let uu___1 = name_and_result c' in + (match uu___1 with + | (f2, r2) -> + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Errors_Msg.text "Computed type" in + let uu___6 = ppt r1 in + FStarC_Pprint.prefix (Prims.of_int (2)) + Prims.int_one uu___5 uu___6 in + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Errors_Msg.text "and effect" in + let uu___8 = FStarC_Errors_Msg.text f1 in + FStarC_Pprint.prefix (Prims.of_int (2)) + Prims.int_one uu___7 uu___8 in + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Errors_Msg.text + "is not compatible with the annotated type" in + let uu___10 = ppt r2 in + FStarC_Pprint.prefix (Prims.of_int (2)) + Prims.int_one uu___9 uu___10 in + let uu___9 = + let uu___10 = + FStarC_Errors_Msg.text "and effect" in + let uu___11 = FStarC_Errors_Msg.text f2 in + FStarC_Pprint.prefix (Prims.of_int (2)) + Prims.int_one uu___10 uu___11 in + FStarC_Pprint.op_Hat_Slash_Hat uu___8 uu___9 in + FStarC_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in + FStarC_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in + [uu___3] in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_ComputedTypeNotMatchAnnotation + () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___2)) +let computed_computation_type_does_not_match_annotation_eq : + 'uuuuu 'a . + FStarC_TypeChecker_Env.env -> + FStarC_Compiler_Range_Type.range -> + 'uuuuu -> + FStarC_Syntax_Syntax.comp -> FStarC_Syntax_Syntax.comp -> 'a + = + fun env -> + fun r -> + fun e -> + fun c -> + fun c' -> + let ppc = FStarC_TypeChecker_Normalize.comp_to_doc env in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Errors_Msg.text "Computed type" in + let uu___4 = ppc c in + FStarC_Pprint.prefix (Prims.of_int (2)) Prims.int_one + uu___3 uu___4 in + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Errors_Msg.text "does not match annotated type" in + let uu___6 = ppc c' in + FStarC_Pprint.prefix (Prims.of_int (2)) Prims.int_one + uu___5 uu___6 in + let uu___5 = + FStarC_Errors_Msg.text "and no subtyping was allowed" in + FStarC_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in + FStarC_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in + [uu___1] in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_ComputedTypeNotMatchAnnotation () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___) +let unexpected_non_trivial_precondition_on_term : + 'a . FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.term -> 'a = + fun env -> + fun f -> + let uu___ = + let uu___1 = FStarC_TypeChecker_Normalize.term_to_string env f in + FStarC_Compiler_Util.format1 + "Term has an unexpected non-trivial pre-condition: %s" uu___1 in + FStarC_Errors.raise_error FStarC_TypeChecker_Env.hasRange_env env + FStarC_Errors_Codes.Fatal_UnExpectedPreCondition () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___) +let __expected_eff_expression : + 'uuuuu . + Prims.string -> + FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.comp -> + Prims.string FStar_Pervasives_Native.option -> 'uuuuu + = + fun effname -> + fun rng -> + fun e -> + fun c -> + fun reason -> + let uu___ = + let uu___1 = + FStarC_Errors_Msg.text + (Prims.strcat "Expected a " + (Prims.strcat effname " expression.")) in + let uu___2 = + let uu___3 = + match reason with + | FStar_Pervasives_Native.None -> FStarC_Pprint.empty + | FStar_Pervasives_Native.Some msg -> + let uu___4 = FStarC_Pprint.break_ Prims.int_one in + let uu___5 = + let uu___6 = FStarC_Pprint.doc_of_string "Because:" in + let uu___7 = + FStarC_Pprint.words (Prims.strcat msg ".") in + uu___6 :: uu___7 in + FStarC_Pprint.flow uu___4 uu___5 in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Errors_Msg.text "Got an expression" in + let uu___8 = + FStarC_Class_PP.pp FStarC_Syntax_Print.pretty_term e in + FStarC_Pprint.prefix (Prims.of_int (2)) Prims.int_one + uu___7 uu___8 in + let uu___7 = + let uu___8 = + let uu___9 = FStarC_Errors_Msg.text "with effect" in + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = name_and_result c in + FStar_Pervasives_Native.fst uu___13 in + FStarC_Pprint.doc_of_string uu___12 in + FStarC_Pprint.squotes uu___11 in + FStarC_Pprint.prefix (Prims.of_int (2)) Prims.int_one + uu___9 uu___10 in + FStarC_Pprint.op_Hat_Hat uu___8 FStarC_Pprint.dot in + FStarC_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in + [uu___5] in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range + rng FStarC_Errors_Codes.Fatal_ExpectedGhostExpression () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___) +let expected_pure_expression : + 'uuuuu . + FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.comp -> + Prims.string FStar_Pervasives_Native.option -> 'uuuuu + = + fun rng -> + fun e -> + fun c -> fun reason -> __expected_eff_expression "pure" rng e c reason +let expected_ghost_expression : + 'uuuuu . + FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.comp -> + Prims.string FStar_Pervasives_Native.option -> 'uuuuu + = + fun rng -> + fun e -> + fun c -> fun reason -> __expected_eff_expression "ghost" rng e c reason +let (expected_effect_1_got_effect_2 : + FStarC_Ident.lident -> + FStarC_Ident.lident -> (FStarC_Errors_Codes.error_code * Prims.string)) + = + fun c1 -> + fun c2 -> + let uu___ = + let uu___1 = FStarC_Class_Show.show FStarC_Ident.showable_lident c1 in + let uu___2 = FStarC_Class_Show.show FStarC_Ident.showable_lident c2 in + FStarC_Compiler_Util.format2 + "Expected a computation with effect %s; but it has effect %s" + uu___1 uu___2 in + (FStarC_Errors_Codes.Fatal_UnexpectedEffect, uu___) +let (failed_to_prove_specification_of : + FStarC_Syntax_Syntax.lbname -> + Prims.string Prims.list -> + (FStarC_Errors_Codes.error_code * Prims.string)) + = + fun l -> + fun lbls -> + let uu___ = + let uu___1 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_either FStarC_Syntax_Print.showable_bv + FStarC_Syntax_Print.showable_fv) l in + FStarC_Compiler_Util.format2 + "Failed to prove specification of %s; assertions at [%s] may fail" + uu___1 (FStarC_Compiler_String.concat ", " lbls) in + (FStarC_Errors_Codes.Error_TypeCheckerFailToProve, uu___) +let (warn_top_level_effect : FStarC_Compiler_Range_Type.range -> unit) = + fun rng -> + FStarC_Errors.log_issue FStarC_Class_HasRange.hasRange_range rng + FStarC_Errors_Codes.Warning_TopLevelEffect () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Top-level let-bindings must be total; this term may have effects") \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_Generalize.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Generalize.ml new file mode 100644 index 00000000000..b003d8addee --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Generalize.ml @@ -0,0 +1,713 @@ +open Prims +let (dbg_Gen : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Gen" +let (showable_univ_var : + FStarC_Syntax_Syntax.universe_uvar FStarC_Class_Show.showable) = + { + FStarC_Class_Show.show = + (fun u -> + FStarC_Class_Show.show FStarC_Syntax_Print.showable_univ + (FStarC_Syntax_Syntax.U_unif u)) + } +let (gen_univs : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.universe_uvar FStarC_Compiler_FlatSet.t -> + FStarC_Syntax_Syntax.univ_name Prims.list) + = + fun env -> + fun x -> + let uu___ = + FStarC_Class_Setlike.is_empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_univ_uvar)) (Obj.magic x) in + if uu___ + then [] + else + (let s = + let uu___2 = + let uu___3 = FStarC_TypeChecker_Env.univ_vars env in + Obj.magic + (FStarC_Class_Setlike.diff () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_univ_uvar)) (Obj.magic x) + (Obj.magic uu___3)) in + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_univ_uvar)) (Obj.magic uu___2) in + (let uu___3 = FStarC_Compiler_Effect.op_Bang dbg_Gen in + if uu___3 + then + let uu___4 = + let uu___5 = FStarC_TypeChecker_Env.univ_vars env in + FStarC_Class_Show.show + (FStarC_Compiler_FlatSet.showable_set + FStarC_Syntax_Free.ord_univ_uvar showable_univ_var) uu___5 in + FStarC_Compiler_Util.print1 "univ_vars in env: %s\n" uu___4 + else ()); + (let r = + let uu___3 = FStarC_TypeChecker_Env.get_range env in + FStar_Pervasives_Native.Some uu___3 in + let u_names = + FStarC_Compiler_List.map + (fun u -> + let u_name = FStarC_Syntax_Syntax.new_univ_name r in + (let uu___4 = FStarC_Compiler_Effect.op_Bang dbg_Gen in + if uu___4 + then + let uu___5 = + let uu___6 = FStarC_Syntax_Unionfind.univ_uvar_id u in + FStarC_Compiler_Util.string_of_int uu___6 in + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_univ + (FStarC_Syntax_Syntax.U_unif u) in + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_univ + (FStarC_Syntax_Syntax.U_name u_name) in + FStarC_Compiler_Util.print3 "Setting ?%s (%s) to %s\n" + uu___5 uu___6 uu___7 + else ()); + FStarC_Syntax_Unionfind.univ_change u + (FStarC_Syntax_Syntax.U_name u_name); + u_name) s in + u_names)) +let (gather_free_univnames : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.univ_name FStarC_Compiler_FlatSet.t) + = + fun env -> + fun t -> + let ctx_univnames = FStarC_TypeChecker_Env.univnames env in + let tm_univnames = FStarC_Syntax_Free.univnames t in + let univnames = + Obj.magic + (FStarC_Class_Setlike.diff () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_ident)) (Obj.magic tm_univnames) + (Obj.magic ctx_univnames)) in + univnames +let (check_universe_generalization : + FStarC_Syntax_Syntax.univ_name Prims.list -> + FStarC_Syntax_Syntax.univ_name Prims.list -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.univ_name Prims.list) + = + fun explicit_univ_names -> + fun generalized_univ_names -> + fun t -> + match (explicit_univ_names, generalized_univ_names) with + | ([], uu___) -> generalized_univ_names + | (uu___, []) -> explicit_univ_names + | uu___ -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + Prims.strcat + "Generalized universe in a term containing explicit universe annotation : " + uu___2 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) t + FStarC_Errors_Codes.Fatal_UnexpectedGeneralizedUniverse () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) +let (generalize_universes : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.tscheme) + = + fun env -> + fun t0 -> + FStarC_Errors.with_ctx "While generalizing universes" + (fun uu___ -> + let t = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.NoFullNorm; + FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.DoNotUnfoldPureLets] env t0 in + let univnames = + let uu___1 = gather_free_univnames env t in + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_ident)) (Obj.magic uu___1) in + (let uu___2 = FStarC_Compiler_Effect.op_Bang dbg_Gen in + if uu___2 + then + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + let uu___4 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list FStarC_Ident.showable_ident) + univnames in + FStarC_Compiler_Util.print2 + "generalizing universes in the term (post norm): %s with univnames: %s\n" + uu___3 uu___4 + else ()); + (let univs = FStarC_Syntax_Free.univs t in + (let uu___3 = FStarC_Compiler_Effect.op_Bang dbg_Gen in + if uu___3 + then + let uu___4 = + FStarC_Class_Show.show + (FStarC_Compiler_FlatSet.showable_set + FStarC_Syntax_Free.ord_univ_uvar showable_univ_var) + univs in + FStarC_Compiler_Util.print1 "univs to gen : %s\n" uu___4 + else ()); + (let gen = gen_univs env univs in + (let uu___4 = FStarC_Compiler_Effect.op_Bang dbg_Gen in + if uu___4 + then + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + let uu___6 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list FStarC_Ident.showable_ident) + gen in + FStarC_Compiler_Util.print2 + "After generalization, t: %s and univs: %s\n" uu___5 uu___6 + else ()); + (let univs1 = check_universe_generalization univnames gen t0 in + let t1 = + FStarC_TypeChecker_Normalize.reduce_uvar_solutions env t in + let ts = FStarC_Syntax_Subst.close_univ_vars univs1 t1 in + (univs1, ts))))) +let (gen : + FStarC_TypeChecker_Env.env -> + Prims.bool -> + (FStarC_Syntax_Syntax.lbname * FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.comp) Prims.list -> + (FStarC_Syntax_Syntax.lbname * FStarC_Syntax_Syntax.univ_name + Prims.list * FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.comp + * FStarC_Syntax_Syntax.binder Prims.list) Prims.list + FStar_Pervasives_Native.option) + = + fun env -> + fun is_rec -> + fun lecs -> + let uu___ = + let uu___1 = + FStarC_Compiler_Util.for_all + (fun uu___2 -> + match uu___2 with + | (uu___3, uu___4, c) -> + FStarC_Syntax_Util.is_pure_or_ghost_comp c) lecs in + Prims.op_Negation uu___1 in + if uu___ + then FStar_Pervasives_Native.None + else + (let norm c = + (let uu___3 = FStarC_Compiler_Debug.medium () in + if uu___3 + then + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_comp c in + FStarC_Compiler_Util.print1 + "Normalizing before generalizing:\n\t %s\n" uu___4 + else ()); + (let c1 = + FStarC_TypeChecker_Normalize.normalize_comp + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Exclude FStarC_TypeChecker_Env.Zeta; + FStarC_TypeChecker_Env.NoFullNorm; + FStarC_TypeChecker_Env.DoNotUnfoldPureLets] env c in + (let uu___4 = FStarC_Compiler_Debug.medium () in + if uu___4 + then + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_comp + c1 in + FStarC_Compiler_Util.print1 "Normalized to:\n\t %s\n" uu___5 + else ()); + c1) in + let env_uvars = FStarC_TypeChecker_Env.uvars_in_env env in + let gen_uvars uvs = + let uu___2 = + Obj.magic + (FStarC_Class_Setlike.diff () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) (Obj.magic uvs) + (Obj.magic env_uvars)) in + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) (Obj.magic uu___2) in + let univs_and_uvars_of_lec uu___2 = + match uu___2 with + | (lbname, e, c) -> + let c1 = norm c in + let t = FStarC_Syntax_Util.comp_result c1 in + let univs = FStarC_Syntax_Free.univs t in + let uvt = FStarC_Syntax_Free.uvars t in + ((let uu___4 = FStarC_Compiler_Effect.op_Bang dbg_Gen in + if uu___4 + then + let uu___5 = + FStarC_Class_Show.show + (FStarC_Compiler_FlatSet.showable_set + FStarC_Syntax_Free.ord_univ_uvar + showable_univ_var) univs in + let uu___6 = + FStarC_Class_Show.show + (FStarC_Compiler_FlatSet.showable_set + FStarC_Syntax_Free.ord_ctx_uvar + FStarC_Syntax_Print.showable_ctxu) uvt in + FStarC_Compiler_Util.print2 + "^^^^\n\tFree univs = %s\n\tFree uvt=%s\n" uu___5 + uu___6 + else ()); + (let univs1 = + let uu___4 = + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) + (Obj.magic uvt) in + FStarC_Compiler_List.fold_left + (fun uu___6 -> + fun uu___5 -> + (fun univs2 -> + fun uv -> + let uu___5 = + let uu___6 = + FStarC_Syntax_Util.ctx_uvar_typ uv in + FStarC_Syntax_Free.univs uu___6 in + Obj.magic + (FStarC_Class_Setlike.union () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_univ_uvar)) + (Obj.magic univs2) (Obj.magic uu___5))) + uu___6 uu___5) univs uu___4 in + let uvs = gen_uvars uvt in + (let uu___5 = FStarC_Compiler_Effect.op_Bang dbg_Gen in + if uu___5 + then + let uu___6 = + FStarC_Class_Show.show + (FStarC_Compiler_FlatSet.showable_set + FStarC_Syntax_Free.ord_univ_uvar + showable_univ_var) univs1 in + let uu___7 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_ctxu) uvs in + FStarC_Compiler_Util.print2 + "^^^^\n\tFree univs = %s\n\tgen_uvars = %s\n" uu___6 + uu___7 + else ()); + (univs1, uvs, (lbname, e, c1)))) in + let uu___2 = + let uu___3 = FStarC_Compiler_List.hd lecs in + univs_and_uvars_of_lec uu___3 in + match uu___2 with + | (univs, uvs, lec_hd) -> + let force_univs_eq lec2 u1 u2 = + let uu___3 = + FStarC_Class_Setlike.equal () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_univ_uvar)) (Obj.magic u1) + (Obj.magic u2) in + if uu___3 + then () + else + (let uu___5 = lec_hd in + match uu___5 with + | (lb1, uu___6, uu___7) -> + let uu___8 = lec2 in + (match uu___8 with + | (lb2, uu___9, uu___10) -> + let msg = + let uu___11 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_either + FStarC_Syntax_Print.showable_bv + FStarC_Syntax_Print.showable_fv) lb1 in + let uu___12 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_either + FStarC_Syntax_Print.showable_bv + FStarC_Syntax_Print.showable_fv) lb2 in + FStarC_Compiler_Util.format2 + "Generalizing the types of these mutually recursive definitions requires an incompatible set of universes for %s and %s" + uu___11 uu___12 in + FStarC_Errors.raise_error + FStarC_TypeChecker_Env.hasRange_env env + FStarC_Errors_Codes.Fatal_IncompatibleSetOfUniverse + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic msg))) in + let force_uvars_eq lec2 u1 u2 = + let uvars_subseteq u11 u21 = + FStarC_Compiler_Util.for_all + (fun u -> + FStarC_Compiler_Util.for_some + (fun u' -> + FStarC_Syntax_Unionfind.equiv + u.FStarC_Syntax_Syntax.ctx_uvar_head + u'.FStarC_Syntax_Syntax.ctx_uvar_head) u21) + u11 in + let uu___3 = + (uvars_subseteq u1 u2) && (uvars_subseteq u2 u1) in + if uu___3 + then () + else + (let uu___5 = lec_hd in + match uu___5 with + | (lb1, uu___6, uu___7) -> + let uu___8 = lec2 in + (match uu___8 with + | (lb2, uu___9, uu___10) -> + let msg = + let uu___11 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_either + FStarC_Syntax_Print.showable_bv + FStarC_Syntax_Print.showable_fv) lb1 in + let uu___12 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_either + FStarC_Syntax_Print.showable_bv + FStarC_Syntax_Print.showable_fv) lb2 in + FStarC_Compiler_Util.format2 + "Generalizing the types of these mutually recursive definitions requires an incompatible number of types for %s and %s" + uu___11 uu___12 in + FStarC_Errors.raise_error + FStarC_TypeChecker_Env.hasRange_env env + FStarC_Errors_Codes.Fatal_IncompatibleNumberOfTypes + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic msg))) in + let lecs1 = + let uu___3 = FStarC_Compiler_List.tl lecs in + FStarC_Compiler_List.fold_right + (fun this_lec -> + fun lecs2 -> + let uu___4 = univs_and_uvars_of_lec this_lec in + match uu___4 with + | (this_univs, this_uvs, this_lec1) -> + (force_univs_eq this_lec1 univs this_univs; + force_uvars_eq this_lec1 uvs this_uvs; + this_lec1 + :: + lecs2)) uu___3 [] in + let lecs2 = lec_hd :: lecs1 in + let gen_types uvs1 = + FStarC_Compiler_List.concatMap + (fun u -> + if + FStar_Pervasives_Native.uu___is_Some + u.FStarC_Syntax_Syntax.ctx_uvar_meta + then [] + else + (let uu___4 = + FStarC_Syntax_Unionfind.find + u.FStarC_Syntax_Syntax.ctx_uvar_head in + match uu___4 with + | FStar_Pervasives_Native.Some uu___5 -> + failwith + "Unexpected instantiation of mutually recursive uvar" + | uu___5 -> + let k = + let uu___6 = FStarC_Syntax_Util.ctx_uvar_typ u in + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Exclude + FStarC_TypeChecker_Env.Zeta] env uu___6 in + let uu___6 = FStarC_Syntax_Util.arrow_formals k in + (match uu___6 with + | (bs, kres) -> + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_TypeChecker_Normalize.unfold_whnf + env kres in + FStarC_Syntax_Util.unrefine uu___9 in + uu___8.FStarC_Syntax_Syntax.n in + (match uu___7 with + | FStarC_Syntax_Syntax.Tm_type uu___8 -> + let free = + FStarC_Syntax_Free.names kres in + let uu___9 = + let uu___10 = + FStarC_Class_Setlike.is_empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) + (Obj.magic free) in + Prims.op_Negation uu___10 in + if uu___9 + then [] + else + (let a = + let uu___11 = + let uu___12 = + FStarC_TypeChecker_Env.get_range + env in + FStar_Pervasives_Native.Some + uu___12 in + FStarC_Syntax_Syntax.new_bv + uu___11 kres in + let t = + match bs with + | [] -> + FStarC_Syntax_Syntax.bv_to_name + a + | uu___11 -> + let uu___12 = + FStarC_Syntax_Syntax.bv_to_name + a in + FStarC_Syntax_Util.abs bs + uu___12 + (FStar_Pervasives_Native.Some + (FStarC_Syntax_Util.residual_tot + kres)) in + FStarC_Syntax_Util.set_uvar + u.FStarC_Syntax_Syntax.ctx_uvar_head + t; + (let uu___12 = + let uu___13 = + FStarC_Syntax_Syntax.as_bqual_implicit + true in + (a, uu___13) in + [uu___12])) + | uu___8 -> [])))) uvs1 in + let gen_univs1 = gen_univs env univs in + let gen_tvars = gen_types uvs in + let ecs = + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with + | (lbname, e, c) -> + let uu___4 = + match (gen_tvars, gen_univs1) with + | ([], []) -> (e, c, []) + | uu___5 -> + let uu___6 = (e, c) in + (match uu___6 with + | (e0, c0) -> + let c1 = + FStarC_TypeChecker_Normalize.normalize_comp + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.DoNotUnfoldPureLets; + FStarC_TypeChecker_Env.CompressUvars; + FStarC_TypeChecker_Env.NoFullNorm; + FStarC_TypeChecker_Env.Exclude + FStarC_TypeChecker_Env.Zeta] env c in + let e1 = + FStarC_TypeChecker_Normalize.reduce_uvar_solutions + env e in + let e2 = + if is_rec + then + let tvar_args = + FStarC_Compiler_List.map + (fun uu___7 -> + match uu___7 with + | (x, uu___8) -> + let uu___9 = + FStarC_Syntax_Syntax.bv_to_name + x in + FStarC_Syntax_Syntax.iarg + uu___9) gen_tvars in + let instantiate_lbname_with_app tm + fv = + let uu___7 = + let uu___8 = + FStarC_Compiler_Util.right + lbname in + FStarC_Syntax_Syntax.fv_eq fv + uu___8 in + if uu___7 + then + FStarC_Syntax_Syntax.mk_Tm_app + tm tvar_args + tm.FStarC_Syntax_Syntax.pos + else tm in + FStarC_Syntax_InstFV.inst + instantiate_lbname_with_app e1 + else e1 in + let tvars_bs = + FStarC_Compiler_List.map + (fun uu___7 -> + match uu___7 with + | (x, q) -> + FStarC_Syntax_Syntax.mk_binder_with_attrs + x q + FStar_Pervasives_Native.None + []) gen_tvars in + let t = + let uu___7 = + let uu___8 = + FStarC_Syntax_Subst.compress + (FStarC_Syntax_Util.comp_result + c1) in + uu___8.FStarC_Syntax_Syntax.n in + match uu___7 with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = cod;_} + -> + let uu___8 = + FStarC_Syntax_Subst.open_comp bs + cod in + (match uu___8 with + | (bs1, cod1) -> + FStarC_Syntax_Util.arrow + (FStarC_Compiler_List.op_At + tvars_bs bs1) cod1) + | uu___8 -> + FStarC_Syntax_Util.arrow tvars_bs + c1 in + let e' = + let uu___7 = + let uu___8 = + FStarC_Syntax_Util.residual_comp_of_comp + c1 in + FStar_Pervasives_Native.Some uu___8 in + FStarC_Syntax_Util.abs tvars_bs e2 + uu___7 in + let uu___7 = + FStarC_Syntax_Syntax.mk_Total t in + (e', uu___7, tvars_bs)) in + (match uu___4 with + | (e1, c1, gvs) -> + (lbname, gen_univs1, e1, c1, gvs))) lecs2 in + FStar_Pervasives_Native.Some ecs) +let (generalize' : + FStarC_TypeChecker_Env.env -> + Prims.bool -> + (FStarC_Syntax_Syntax.lbname * FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.comp) Prims.list -> + (FStarC_Syntax_Syntax.lbname * FStarC_Syntax_Syntax.univ_names * + FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.comp * + FStarC_Syntax_Syntax.binder Prims.list) Prims.list) + = + fun env -> + fun is_rec -> + fun lecs -> + (let uu___2 = FStarC_Compiler_Debug.low () in + if uu___2 + then + let uu___3 = + let uu___4 = + FStarC_Compiler_List.map + (fun uu___5 -> + match uu___5 with + | (lb, uu___6, uu___7) -> + FStarC_Class_Show.show + (FStarC_Class_Show.show_either + FStarC_Syntax_Print.showable_bv + FStarC_Syntax_Print.showable_fv) lb) lecs in + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_string)) uu___4 in + FStarC_Compiler_Util.print1 "Generalizing: %s\n" uu___3 + else ()); + (let univnames_lecs = + let empty = + Obj.magic + (FStarC_Class_Setlike.from_list () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_ident)) []) in + FStarC_Compiler_List.fold_left + (fun uu___3 -> + fun uu___2 -> + (fun out -> + fun uu___2 -> + match uu___2 with + | (l, t, c) -> + let uu___3 = gather_free_univnames env t in + Obj.magic + (FStarC_Class_Setlike.union () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_ident)) + (Obj.magic out) (Obj.magic uu___3))) uu___3 + uu___2) empty lecs in + let univnames_lecs1 = + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_ident)) + (Obj.magic univnames_lecs) in + let generalized_lecs = + let uu___2 = gen env is_rec lecs in + match uu___2 with + | FStar_Pervasives_Native.None -> + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with | (l, t, c) -> (l, [], t, c, [])) lecs + | FStar_Pervasives_Native.Some luecs -> + ((let uu___4 = FStarC_Compiler_Debug.medium () in + if uu___4 + then + FStarC_Compiler_List.iter + (fun uu___5 -> + match uu___5 with + | (l, us, e, c, gvs) -> + let uu___6 = + FStarC_Class_Show.show + FStarC_Compiler_Range_Ops.showable_range + e.FStarC_Syntax_Syntax.pos in + let uu___7 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_either + FStarC_Syntax_Print.showable_bv + FStarC_Syntax_Print.showable_fv) l in + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + (FStarC_Syntax_Util.comp_result c) in + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term e in + let uu___10 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binder) gvs in + FStarC_Compiler_Util.print5 + "(%s) Generalized %s at type %s\n%s\nVars = (%s)\n" + uu___6 uu___7 uu___8 uu___9 uu___10) luecs + else ()); + luecs) in + FStarC_Compiler_List.map + (fun uu___2 -> + match uu___2 with + | (l, generalized_univs, t, c, gvs) -> + let uu___3 = + check_universe_generalization univnames_lecs1 + generalized_univs t in + (l, uu___3, t, c, gvs)) generalized_lecs) +let (generalize : + FStarC_TypeChecker_Env.env -> + Prims.bool -> + (FStarC_Syntax_Syntax.lbname * FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.comp) Prims.list -> + (FStarC_Syntax_Syntax.lbname * FStarC_Syntax_Syntax.univ_names * + FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.comp * + FStarC_Syntax_Syntax.binder Prims.list) Prims.list) + = + fun env -> + fun is_rec -> + fun lecs -> + FStarC_Errors.with_ctx "While generalizing" + (fun uu___ -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_TypeChecker_Env.current_module env in + FStarC_Ident.string_of_lid uu___3 in + FStar_Pervasives_Native.Some uu___2 in + FStarC_Profiling.profile + (fun uu___2 -> generalize' env is_rec lecs) uu___1 + "FStarC.TypeChecker.Util.generalize") \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_NBE.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_NBE.ml new file mode 100644 index 00000000000..c021c8124a0 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_NBE.ml @@ -0,0 +1,3567 @@ +open Prims +let (dbg_NBE : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "NBE" +let (dbg_NBETop : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "NBETop" +let (max : Prims.int -> Prims.int -> Prims.int) = + fun a -> fun b -> if a > b then a else b +let map_rev : 'a 'b . ('a -> 'b) -> 'a Prims.list -> 'b Prims.list = + fun f -> + fun l -> + let rec aux l1 acc = + match l1 with + | [] -> acc + | x::xs -> + let uu___ = let uu___1 = f x in uu___1 :: acc in aux xs uu___ in + aux l [] +let map_rev_append : + 'a 'b . ('a -> 'b) -> 'a Prims.list -> 'b Prims.list -> 'b Prims.list = + fun f -> + fun l1 -> + fun l2 -> + let rec aux l acc = + match l with + | [] -> l2 + | x::xs -> + let uu___ = let uu___1 = f x in uu___1 :: acc in aux xs uu___ in + aux l1 l2 +let rec map_append : + 'a 'b . ('a -> 'b) -> 'a Prims.list -> 'b Prims.list -> 'b Prims.list = + fun f -> + fun l1 -> + fun l2 -> + match l1 with + | [] -> l2 + | x::xs -> + let uu___ = f x in + let uu___1 = map_append f xs l2 in uu___ :: uu___1 +let rec drop : 'a . ('a -> Prims.bool) -> 'a Prims.list -> 'a Prims.list = + fun p -> + fun l -> + match l with + | [] -> [] + | x::xs -> let uu___ = p x in if uu___ then x :: xs else drop p xs +let fmap_opt : + 'a 'b . + ('a -> 'b) -> + 'a FStar_Pervasives_Native.option -> 'b FStar_Pervasives_Native.option + = + fun f -> + fun x -> + FStarC_Compiler_Util.bind_opt x + (fun x1 -> let uu___ = f x1 in FStar_Pervasives_Native.Some uu___) +let drop_until : 'a . ('a -> Prims.bool) -> 'a Prims.list -> 'a Prims.list = + fun f -> + fun l -> + let rec aux l1 = + match l1 with + | [] -> [] + | x::xs -> let uu___ = f x in if uu___ then l1 else aux xs in + aux l +let (trim : Prims.bool Prims.list -> Prims.bool Prims.list) = + fun l -> + let uu___ = drop_until (fun x -> x) (FStarC_Compiler_List.rev l) in + FStarC_Compiler_List.rev uu___ +let (implies : Prims.bool -> Prims.bool -> Prims.bool) = + fun b1 -> + fun b2 -> + match (b1, b2) with | (false, uu___) -> true | (true, b21) -> b21 +let (let_rec_arity : + FStarC_Syntax_Syntax.letbinding -> (Prims.int * Prims.bool Prims.list)) = + fun b -> + let uu___ = FStarC_Syntax_Util.let_rec_arity b in + match uu___ with + | (ar, maybe_lst) -> + (match maybe_lst with + | FStar_Pervasives_Native.None -> + let uu___1 = FStarC_Common.tabulate ar (fun uu___2 -> true) in + (ar, uu___1) + | FStar_Pervasives_Native.Some lst -> (ar, lst)) +let (debug_term : FStarC_Syntax_Syntax.term -> unit) = + fun t -> + let uu___ = FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.print1 "%s\n" uu___ +let (debug_sigmap : + FStarC_Syntax_Syntax.sigelt FStarC_Compiler_Util.smap -> unit) = + fun m -> + FStarC_Compiler_Util.smap_fold m + (fun k -> + fun v -> + fun u -> + let uu___ = FStarC_Syntax_Print.sigelt_to_string_short v in + FStarC_Compiler_Util.print2 "%s -> %%s\n" k uu___) () +type config = + { + core_cfg: FStarC_TypeChecker_Cfg.cfg ; + fv_cache: FStarC_TypeChecker_NBETerm.t FStarC_Compiler_Util.smap } +let (__proj__Mkconfig__item__core_cfg : config -> FStarC_TypeChecker_Cfg.cfg) + = + fun projectee -> match projectee with | { core_cfg; fv_cache;_} -> core_cfg +let (__proj__Mkconfig__item__fv_cache : + config -> FStarC_TypeChecker_NBETerm.t FStarC_Compiler_Util.smap) = + fun projectee -> match projectee with | { core_cfg; fv_cache;_} -> fv_cache +let (new_config : FStarC_TypeChecker_Cfg.cfg -> config) = + fun cfg -> + let uu___ = FStarC_Compiler_Util.smap_create (Prims.of_int (51)) in + { core_cfg = cfg; fv_cache = uu___ } +let (reifying_false : config -> config) = + fun cfg -> + if (cfg.core_cfg).FStarC_TypeChecker_Cfg.reifying + then + new_config + (let uu___ = cfg.core_cfg in + { + FStarC_TypeChecker_Cfg.steps = + (uu___.FStarC_TypeChecker_Cfg.steps); + FStarC_TypeChecker_Cfg.tcenv = + (uu___.FStarC_TypeChecker_Cfg.tcenv); + FStarC_TypeChecker_Cfg.debug = + (uu___.FStarC_TypeChecker_Cfg.debug); + FStarC_TypeChecker_Cfg.delta_level = + (uu___.FStarC_TypeChecker_Cfg.delta_level); + FStarC_TypeChecker_Cfg.primitive_steps = + (uu___.FStarC_TypeChecker_Cfg.primitive_steps); + FStarC_TypeChecker_Cfg.strong = + (uu___.FStarC_TypeChecker_Cfg.strong); + FStarC_TypeChecker_Cfg.memoize_lazy = + (uu___.FStarC_TypeChecker_Cfg.memoize_lazy); + FStarC_TypeChecker_Cfg.normalize_pure_lets = + (uu___.FStarC_TypeChecker_Cfg.normalize_pure_lets); + FStarC_TypeChecker_Cfg.reifying = false; + FStarC_TypeChecker_Cfg.compat_memo_ignore_cfg = + (uu___.FStarC_TypeChecker_Cfg.compat_memo_ignore_cfg) + }) + else cfg +let (reifying_true : config -> config) = + fun cfg -> + if Prims.op_Negation (cfg.core_cfg).FStarC_TypeChecker_Cfg.reifying + then + new_config + (let uu___ = cfg.core_cfg in + { + FStarC_TypeChecker_Cfg.steps = + (uu___.FStarC_TypeChecker_Cfg.steps); + FStarC_TypeChecker_Cfg.tcenv = + (uu___.FStarC_TypeChecker_Cfg.tcenv); + FStarC_TypeChecker_Cfg.debug = + (uu___.FStarC_TypeChecker_Cfg.debug); + FStarC_TypeChecker_Cfg.delta_level = + (uu___.FStarC_TypeChecker_Cfg.delta_level); + FStarC_TypeChecker_Cfg.primitive_steps = + (uu___.FStarC_TypeChecker_Cfg.primitive_steps); + FStarC_TypeChecker_Cfg.strong = + (uu___.FStarC_TypeChecker_Cfg.strong); + FStarC_TypeChecker_Cfg.memoize_lazy = + (uu___.FStarC_TypeChecker_Cfg.memoize_lazy); + FStarC_TypeChecker_Cfg.normalize_pure_lets = + (uu___.FStarC_TypeChecker_Cfg.normalize_pure_lets); + FStarC_TypeChecker_Cfg.reifying = true; + FStarC_TypeChecker_Cfg.compat_memo_ignore_cfg = + (uu___.FStarC_TypeChecker_Cfg.compat_memo_ignore_cfg) + }) + else cfg +let (zeta_false : config -> config) = + fun cfg -> + let cfg_core = cfg.core_cfg in + if (cfg_core.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.zeta + then + let cfg_core' = + { + FStarC_TypeChecker_Cfg.steps = + (let uu___ = cfg_core.FStarC_TypeChecker_Cfg.steps in + { + FStarC_TypeChecker_Cfg.beta = + (uu___.FStarC_TypeChecker_Cfg.beta); + FStarC_TypeChecker_Cfg.iota = + (uu___.FStarC_TypeChecker_Cfg.iota); + FStarC_TypeChecker_Cfg.zeta = false; + FStarC_TypeChecker_Cfg.zeta_full = + (uu___.FStarC_TypeChecker_Cfg.zeta_full); + FStarC_TypeChecker_Cfg.weak = + (uu___.FStarC_TypeChecker_Cfg.weak); + FStarC_TypeChecker_Cfg.hnf = + (uu___.FStarC_TypeChecker_Cfg.hnf); + FStarC_TypeChecker_Cfg.primops = + (uu___.FStarC_TypeChecker_Cfg.primops); + FStarC_TypeChecker_Cfg.do_not_unfold_pure_lets = + (uu___.FStarC_TypeChecker_Cfg.do_not_unfold_pure_lets); + FStarC_TypeChecker_Cfg.unfold_until = + (uu___.FStarC_TypeChecker_Cfg.unfold_until); + FStarC_TypeChecker_Cfg.unfold_only = + (uu___.FStarC_TypeChecker_Cfg.unfold_only); + FStarC_TypeChecker_Cfg.unfold_fully = + (uu___.FStarC_TypeChecker_Cfg.unfold_fully); + FStarC_TypeChecker_Cfg.unfold_attr = + (uu___.FStarC_TypeChecker_Cfg.unfold_attr); + FStarC_TypeChecker_Cfg.unfold_qual = + (uu___.FStarC_TypeChecker_Cfg.unfold_qual); + FStarC_TypeChecker_Cfg.unfold_namespace = + (uu___.FStarC_TypeChecker_Cfg.unfold_namespace); + FStarC_TypeChecker_Cfg.dont_unfold_attr = + (uu___.FStarC_TypeChecker_Cfg.dont_unfold_attr); + FStarC_TypeChecker_Cfg.pure_subterms_within_computations = + (uu___.FStarC_TypeChecker_Cfg.pure_subterms_within_computations); + FStarC_TypeChecker_Cfg.simplify = + (uu___.FStarC_TypeChecker_Cfg.simplify); + FStarC_TypeChecker_Cfg.erase_universes = + (uu___.FStarC_TypeChecker_Cfg.erase_universes); + FStarC_TypeChecker_Cfg.allow_unbound_universes = + (uu___.FStarC_TypeChecker_Cfg.allow_unbound_universes); + FStarC_TypeChecker_Cfg.reify_ = + (uu___.FStarC_TypeChecker_Cfg.reify_); + FStarC_TypeChecker_Cfg.compress_uvars = + (uu___.FStarC_TypeChecker_Cfg.compress_uvars); + FStarC_TypeChecker_Cfg.no_full_norm = + (uu___.FStarC_TypeChecker_Cfg.no_full_norm); + FStarC_TypeChecker_Cfg.check_no_uvars = + (uu___.FStarC_TypeChecker_Cfg.check_no_uvars); + FStarC_TypeChecker_Cfg.unmeta = + (uu___.FStarC_TypeChecker_Cfg.unmeta); + FStarC_TypeChecker_Cfg.unascribe = + (uu___.FStarC_TypeChecker_Cfg.unascribe); + FStarC_TypeChecker_Cfg.in_full_norm_request = + (uu___.FStarC_TypeChecker_Cfg.in_full_norm_request); + FStarC_TypeChecker_Cfg.weakly_reduce_scrutinee = + (uu___.FStarC_TypeChecker_Cfg.weakly_reduce_scrutinee); + FStarC_TypeChecker_Cfg.nbe_step = + (uu___.FStarC_TypeChecker_Cfg.nbe_step); + FStarC_TypeChecker_Cfg.for_extraction = + (uu___.FStarC_TypeChecker_Cfg.for_extraction); + FStarC_TypeChecker_Cfg.unrefine = + (uu___.FStarC_TypeChecker_Cfg.unrefine); + FStarC_TypeChecker_Cfg.default_univs_to_zero = + (uu___.FStarC_TypeChecker_Cfg.default_univs_to_zero); + FStarC_TypeChecker_Cfg.tactics = + (uu___.FStarC_TypeChecker_Cfg.tactics) + }); + FStarC_TypeChecker_Cfg.tcenv = + (cfg_core.FStarC_TypeChecker_Cfg.tcenv); + FStarC_TypeChecker_Cfg.debug = + (cfg_core.FStarC_TypeChecker_Cfg.debug); + FStarC_TypeChecker_Cfg.delta_level = + (cfg_core.FStarC_TypeChecker_Cfg.delta_level); + FStarC_TypeChecker_Cfg.primitive_steps = + (cfg_core.FStarC_TypeChecker_Cfg.primitive_steps); + FStarC_TypeChecker_Cfg.strong = + (cfg_core.FStarC_TypeChecker_Cfg.strong); + FStarC_TypeChecker_Cfg.memoize_lazy = + (cfg_core.FStarC_TypeChecker_Cfg.memoize_lazy); + FStarC_TypeChecker_Cfg.normalize_pure_lets = + (cfg_core.FStarC_TypeChecker_Cfg.normalize_pure_lets); + FStarC_TypeChecker_Cfg.reifying = + (cfg_core.FStarC_TypeChecker_Cfg.reifying); + FStarC_TypeChecker_Cfg.compat_memo_ignore_cfg = + (cfg_core.FStarC_TypeChecker_Cfg.compat_memo_ignore_cfg) + } in + new_config cfg_core' + else cfg +let (cache_add : + config -> FStarC_Syntax_Syntax.fv -> FStarC_TypeChecker_NBETerm.t -> unit) + = + fun cfg -> + fun fv -> + fun v -> + let lid = (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + let uu___ = FStarC_Ident.string_of_lid lid in + FStarC_Compiler_Util.smap_add cfg.fv_cache uu___ v +let (try_in_cache : + config -> + FStarC_Syntax_Syntax.fv -> + FStarC_TypeChecker_NBETerm.t FStar_Pervasives_Native.option) + = + fun cfg -> + fun fv -> + let lid = (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + let uu___ = FStarC_Ident.string_of_lid lid in + FStarC_Compiler_Util.smap_try_find cfg.fv_cache uu___ +let (debug : config -> (unit -> unit) -> unit) = + fun cfg -> fun f -> FStarC_TypeChecker_Cfg.log_nbe cfg.core_cfg f +let rec (unlazy_unmeta : + FStarC_TypeChecker_NBETerm.t -> FStarC_TypeChecker_NBETerm.t) = + fun t -> + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Lazy (uu___, t1) -> + let uu___1 = FStarC_Thunk.force t1 in unlazy_unmeta uu___1 + | FStarC_TypeChecker_NBETerm.Meta (t0, m) -> + let uu___ = FStarC_Thunk.force m in + (match uu___ with + | FStarC_Syntax_Syntax.Meta_monadic (uu___1, uu___2) -> t + | FStarC_Syntax_Syntax.Meta_monadic_lift (uu___1, uu___2, uu___3) -> + t + | uu___1 -> unlazy_unmeta t0) + | uu___ -> t +let (pickBranch : + config -> + FStarC_TypeChecker_NBETerm.t -> + FStarC_Syntax_Syntax.branch Prims.list -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_NBETerm.t Prims.list) + FStar_Pervasives_Native.option) + = + fun cfg -> + fun scrut -> + fun branches -> + let all_branches = branches in + let rec pickBranch_aux scrut1 branches1 branches0 = + let rec matches_pat scrutinee0 p = + debug cfg + (fun uu___1 -> + let uu___2 = + FStarC_TypeChecker_NBETerm.t_to_string scrutinee0 in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_pat p in + FStarC_Compiler_Util.print2 "matches_pat (%s, %s)\n" uu___2 + uu___3); + (let scrutinee = unlazy_unmeta scrutinee0 in + let r = + match p.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_var bv -> + FStar_Pervasives.Inl [scrutinee0] + | FStarC_Syntax_Syntax.Pat_dot_term uu___1 -> + FStar_Pervasives.Inl [] + | FStarC_Syntax_Syntax.Pat_constant s -> + let matches_const c s1 = + debug cfg + (fun uu___2 -> + let uu___3 = + FStarC_TypeChecker_NBETerm.t_to_string c in + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_const s1 in + FStarC_Compiler_Util.print2 + "Testing term %s against pattern %s\n" uu___3 + uu___4); + (match c.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Constant + (FStarC_TypeChecker_NBETerm.Unit) -> + s1 = FStarC_Const.Const_unit + | FStarC_TypeChecker_NBETerm.Constant + (FStarC_TypeChecker_NBETerm.Bool b) -> + (match s1 with + | FStarC_Const.Const_bool p1 -> b = p1 + | uu___2 -> false) + | FStarC_TypeChecker_NBETerm.Constant + (FStarC_TypeChecker_NBETerm.Int i) -> + (match s1 with + | FStarC_Const.Const_int + (p1, FStar_Pervasives_Native.None) -> + let uu___2 = + FStarC_BigInt.big_int_of_string p1 in + i = uu___2 + | uu___2 -> false) + | FStarC_TypeChecker_NBETerm.Constant + (FStarC_TypeChecker_NBETerm.String (st, uu___2)) -> + (match s1 with + | FStarC_Const.Const_string (p1, uu___3) -> + st = p1 + | uu___3 -> false) + | FStarC_TypeChecker_NBETerm.Constant + (FStarC_TypeChecker_NBETerm.Char c1) -> + (match s1 with + | FStarC_Const.Const_char p1 -> c1 = p1 + | uu___2 -> false) + | uu___2 -> false) in + let uu___1 = matches_const scrutinee s in + if uu___1 + then FStar_Pervasives.Inl [] + else FStar_Pervasives.Inr false + | FStarC_Syntax_Syntax.Pat_cons (fv, _us_opt, arg_pats) -> + let rec matches_args out a p1 = + match (a, p1) with + | ([], []) -> FStar_Pervasives.Inl out + | ((t, uu___1)::rest_a, (p2, uu___2)::rest_p) -> + let uu___3 = matches_pat t p2 in + (match uu___3 with + | FStar_Pervasives.Inl s -> + matches_args (FStarC_Compiler_List.op_At out s) + rest_a rest_p + | m -> m) + | uu___1 -> FStar_Pervasives.Inr false in + (match scrutinee.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Construct + (fv', _us, args_rev) -> + let uu___1 = FStarC_Syntax_Syntax.fv_eq fv fv' in + if uu___1 + then + matches_args [] (FStarC_Compiler_List.rev args_rev) + arg_pats + else FStar_Pervasives.Inr false + | uu___1 -> FStar_Pervasives.Inr true) in + let res_to_string uu___1 = + match uu___1 with + | FStar_Pervasives.Inr b -> + let uu___2 = FStarC_Compiler_Util.string_of_bool b in + Prims.strcat "Inr " uu___2 + | FStar_Pervasives.Inl bs -> + let uu___2 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length bs) in + Prims.strcat "Inl " uu___2 in + debug cfg + (fun uu___2 -> + let uu___3 = + FStarC_TypeChecker_NBETerm.t_to_string scrutinee in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_pat p in + let uu___5 = res_to_string r in + FStarC_Compiler_Util.print3 "matches_pat (%s, %s) = %s\n" + uu___3 uu___4 uu___5); + r) in + match branches1 with + | [] -> FStar_Pervasives_Native.None + | (p, _wopt, e)::branches2 -> + let uu___ = matches_pat scrut1 p in + (match uu___ with + | FStar_Pervasives.Inl matches -> + (debug cfg + (fun uu___2 -> + let uu___3 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_pat p in + FStarC_Compiler_Util.print1 "Pattern %s matches\n" + uu___3); + FStar_Pervasives_Native.Some (e, matches)) + | FStar_Pervasives.Inr (false) -> + pickBranch_aux scrut1 branches2 branches0 + | FStar_Pervasives.Inr (true) -> FStar_Pervasives_Native.None) in + pickBranch_aux scrut branches branches +let (should_reduce_recursive_definition : + FStarC_TypeChecker_NBETerm.args -> + Prims.bool Prims.list -> + (Prims.bool * FStarC_TypeChecker_NBETerm.args * + FStarC_TypeChecker_NBETerm.args)) + = + fun arguments -> + fun formals_in_decreases -> + let rec aux ts ar_list acc = + match (ts, ar_list) with + | (uu___, []) -> (true, acc, ts) + | ([], uu___::uu___1) -> (false, acc, []) + | (t::ts1, in_decreases_clause::bs) -> + let uu___ = + in_decreases_clause && + (FStarC_TypeChecker_NBETerm.isAccu + (FStar_Pervasives_Native.fst t)) in + if uu___ + then (false, (FStarC_Compiler_List.rev_append ts1 acc), []) + else aux ts1 bs (t :: acc) in + aux arguments formals_in_decreases [] +let (find_sigelt_in_gamma : + config -> + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.sigelt FStar_Pervasives_Native.option) + = + fun cfg -> + fun env -> + fun lid -> + let mapper uu___ = + match uu___ with + | (lr, rng) -> + (match lr with + | FStar_Pervasives.Inr (elt, FStar_Pervasives_Native.None) -> + FStar_Pervasives_Native.Some elt + | FStar_Pervasives.Inr (elt, FStar_Pervasives_Native.Some us) + -> + (debug cfg + (fun uu___2 -> + let uu___3 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_univ) us in + FStarC_Compiler_Util.print1 + "Universes in local declaration: %s\n" uu___3); + FStar_Pervasives_Native.Some elt) + | uu___1 -> FStar_Pervasives_Native.None) in + let uu___ = FStarC_TypeChecker_Env.lookup_qname env lid in + FStarC_Compiler_Util.bind_opt uu___ mapper +let (is_univ : FStarC_TypeChecker_NBETerm.t -> Prims.bool) = + fun tm -> + match tm.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Univ uu___ -> true + | uu___ -> false +let (un_univ : FStarC_TypeChecker_NBETerm.t -> FStarC_Syntax_Syntax.universe) + = + fun tm -> + match tm.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Univ u -> u + | uu___ -> + let uu___1 = + let uu___2 = FStarC_TypeChecker_NBETerm.t_to_string tm in + Prims.strcat "Not a universe: " uu___2 in + failwith uu___1 +let (is_constr_fv : FStarC_Syntax_Syntax.fv -> Prims.bool) = + fun fvar -> + fvar.FStarC_Syntax_Syntax.fv_qual = + (FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.Data_ctor) +let (is_constr : FStarC_TypeChecker_Env.qninfo -> Prims.bool) = + fun q -> + match q with + | FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr + ({ + FStarC_Syntax_Syntax.sigel = FStarC_Syntax_Syntax.Sig_datacon + uu___; + FStarC_Syntax_Syntax.sigrng = uu___1; + FStarC_Syntax_Syntax.sigquals = uu___2; + FStarC_Syntax_Syntax.sigmeta = uu___3; + FStarC_Syntax_Syntax.sigattrs = uu___4; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___5; + FStarC_Syntax_Syntax.sigopts = uu___6;_}, + uu___7), + uu___8) + -> true + | uu___ -> false +let (translate_univ : + config -> + FStarC_TypeChecker_NBETerm.t Prims.list -> + FStarC_Syntax_Syntax.universe -> FStarC_Syntax_Syntax.universe) + = + fun cfg -> + fun bs -> + fun u -> + let rec aux u1 = + let u2 = FStarC_Syntax_Subst.compress_univ u1 in + match u2 with + | FStarC_Syntax_Syntax.U_bvar i -> + if i < (FStarC_Compiler_List.length bs) + then let u' = FStarC_Compiler_List.nth bs i in un_univ u' + else + if + ((cfg.core_cfg).FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.allow_unbound_universes + then FStarC_Syntax_Syntax.U_zero + else failwith "Universe index out of bounds" + | FStarC_Syntax_Syntax.U_succ u3 -> + let uu___ = aux u3 in FStarC_Syntax_Syntax.U_succ uu___ + | FStarC_Syntax_Syntax.U_max us -> + let uu___ = FStarC_Compiler_List.map aux us in + FStarC_Syntax_Syntax.U_max uu___ + | FStarC_Syntax_Syntax.U_unknown -> u2 + | FStarC_Syntax_Syntax.U_name uu___ -> u2 + | FStarC_Syntax_Syntax.U_unif uu___ -> u2 + | FStarC_Syntax_Syntax.U_zero -> u2 in + aux u +let (find_let : + FStarC_Syntax_Syntax.letbinding Prims.list -> + FStarC_Syntax_Syntax.fv -> + FStarC_Syntax_Syntax.letbinding FStar_Pervasives_Native.option) + = + fun lbs -> + fun fvar -> + FStarC_Compiler_Util.find_map lbs + (fun lb -> + match lb.FStarC_Syntax_Syntax.lbname with + | FStar_Pervasives.Inl uu___ -> failwith "find_let : impossible" + | FStar_Pervasives.Inr name -> + let uu___ = FStarC_Syntax_Syntax.fv_eq name fvar in + if uu___ + then FStar_Pervasives_Native.Some lb + else FStar_Pervasives_Native.None) +let (mk_rt : + FStarC_Compiler_Range_Type.range -> + FStarC_TypeChecker_NBETerm.t' -> FStarC_TypeChecker_NBETerm.t) + = + fun r -> + fun t -> + { + FStarC_TypeChecker_NBETerm.nbe_t = t; + FStarC_TypeChecker_NBETerm.nbe_r = r + } +let (mk_t : FStarC_TypeChecker_NBETerm.t' -> FStarC_TypeChecker_NBETerm.t) = + fun t -> + { + FStarC_TypeChecker_NBETerm.nbe_t = t; + FStarC_TypeChecker_NBETerm.nbe_r = + FStarC_Compiler_Range_Type.dummyRange + } +let rec (translate : + config -> + FStarC_TypeChecker_NBETerm.t Prims.list -> + FStarC_Syntax_Syntax.term -> FStarC_TypeChecker_NBETerm.t) + = + fun cfg -> + fun bs -> + fun e -> + let debug1 = debug cfg in + let mk_t1 t = mk_rt e.FStarC_Syntax_Syntax.pos t in + debug1 + (fun uu___1 -> + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress e in + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term + uu___3 in + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.compress e in + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + uu___4 in + FStarC_Compiler_Util.print2 "Term: %s - %s\n" uu___2 uu___3); + (let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress e in + uu___2.FStarC_Syntax_Syntax.n in + match uu___1 with + | FStarC_Syntax_Syntax.Tm_delayed uu___2 -> + failwith "Tm_delayed: Impossible" + | FStarC_Syntax_Syntax.Tm_unknown -> + mk_t1 FStarC_TypeChecker_NBETerm.Unknown + | FStarC_Syntax_Syntax.Tm_constant c -> + let uu___2 = + let uu___3 = translate_constant c in + FStarC_TypeChecker_NBETerm.Constant uu___3 in + mk_t1 uu___2 + | FStarC_Syntax_Syntax.Tm_bvar db -> + if + db.FStarC_Syntax_Syntax.index < + (FStarC_Compiler_List.length bs) + then + let t = + FStarC_Compiler_List.nth bs db.FStarC_Syntax_Syntax.index in + (debug1 + (fun uu___3 -> + let uu___4 = FStarC_TypeChecker_NBETerm.t_to_string t in + let uu___5 = + let uu___6 = + FStarC_Compiler_List.map + FStarC_TypeChecker_NBETerm.t_to_string bs in + FStarC_Compiler_String.concat "; " uu___6 in + FStarC_Compiler_Util.print2 + "Resolved bvar to %s\n\tcontext is [%s]\n" uu___4 + uu___5); + t) + else failwith "de Bruijn index out of bounds" + | FStarC_Syntax_Syntax.Tm_uinst (t, us) -> + (debug1 + (fun uu___3 -> + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + t in + let uu___5 = + let uu___6 = + FStarC_Compiler_List.map + (FStarC_Class_Show.show + FStarC_Syntax_Print.showable_univ) us in + FStarC_Compiler_String.concat ", " uu___6 in + FStarC_Compiler_Util.print2 + "Uinst term : %s\nUnivs : %s\n" uu___4 uu___5); + (let uu___3 = translate cfg bs t in + let uu___4 = + FStarC_Compiler_List.map + (fun x -> + let uu___5 = + let uu___6 = + let uu___7 = translate_univ cfg bs x in + FStarC_TypeChecker_NBETerm.Univ uu___7 in + mk_t1 uu___6 in + FStarC_TypeChecker_NBETerm.as_arg uu___5) us in + iapp cfg uu___3 uu___4)) + | FStarC_Syntax_Syntax.Tm_type u -> + let uu___2 = + let uu___3 = translate_univ cfg bs u in + FStarC_TypeChecker_NBETerm.Type_t uu___3 in + mk_t1 uu___2 + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = xs; + FStarC_Syntax_Syntax.comp = c;_} + -> + let norm uu___2 = + let uu___3 = + FStarC_Compiler_List.fold_left + (fun uu___4 -> + fun b -> + match uu___4 with + | (ctx, binders_rev) -> + let x = b.FStarC_Syntax_Syntax.binder_bv in + let t = + let uu___5 = + translate cfg ctx x.FStarC_Syntax_Syntax.sort in + readback cfg uu___5 in + let x1 = + let uu___5 = FStarC_Syntax_Syntax.freshen_bv x in + { + FStarC_Syntax_Syntax.ppname = + (uu___5.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (uu___5.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = t + } in + let ctx1 = + let uu___5 = + FStarC_TypeChecker_NBETerm.mkAccuVar x1 in + uu___5 :: ctx in + (ctx1, + ({ + FStarC_Syntax_Syntax.binder_bv = x1; + FStarC_Syntax_Syntax.binder_qual = + (b.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity = + (b.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs = + (b.FStarC_Syntax_Syntax.binder_attrs) + } :: binders_rev))) (bs, []) xs in + match uu___3 with + | (ctx, binders_rev) -> + let c1 = + let uu___4 = translate_comp cfg ctx c in + readback_comp cfg uu___4 in + FStarC_Syntax_Util.arrow + (FStarC_Compiler_List.rev binders_rev) c1 in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Thunk.mk norm in + FStar_Pervasives.Inl uu___4 in + FStarC_TypeChecker_NBETerm.Arrow uu___3 in + mk_t1 uu___2 + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = bv; FStarC_Syntax_Syntax.phi = tm;_} + -> + if + ((cfg.core_cfg).FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.for_extraction + || + ((cfg.core_cfg).FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unrefine + then translate cfg bs bv.FStarC_Syntax_Syntax.sort + else + mk_t1 + (FStarC_TypeChecker_NBETerm.Refinement + ((fun y -> translate cfg (y :: bs) tm), + (fun uu___3 -> + let uu___4 = + translate cfg bs bv.FStarC_Syntax_Syntax.sort in + FStarC_TypeChecker_NBETerm.as_arg uu___4))) + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t; + FStarC_Syntax_Syntax.asc = uu___2; + FStarC_Syntax_Syntax.eff_opt = uu___3;_} + -> translate cfg bs t + | FStarC_Syntax_Syntax.Tm_uvar (u, (subst, set_use_range)) -> + let norm_uvar uu___2 = + let norm_subst_elt uu___3 = + match uu___3 with + | FStarC_Syntax_Syntax.NT (x, t) -> + let uu___4 = + let uu___5 = + let uu___6 = translate cfg bs t in + readback cfg uu___6 in + (x, uu___5) in + FStarC_Syntax_Syntax.NT uu___4 + | FStarC_Syntax_Syntax.NM (x, i) -> + let x_i = + FStarC_Syntax_Syntax.bv_to_tm + { + FStarC_Syntax_Syntax.ppname = + (x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = i; + FStarC_Syntax_Syntax.sort = + (x.FStarC_Syntax_Syntax.sort) + } in + let t = + let uu___4 = translate cfg bs x_i in + readback cfg uu___4 in + (match t.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_bvar x_j -> + FStarC_Syntax_Syntax.NM + (x, (x_j.FStarC_Syntax_Syntax.index)) + | uu___4 -> FStarC_Syntax_Syntax.NT (x, t)) + | uu___4 -> + failwith "Impossible: subst invariant of uvar nodes" in + let subst1 = + FStarC_Compiler_List.map + (FStarC_Compiler_List.map norm_subst_elt) subst in + { + FStarC_Syntax_Syntax.n = + (FStarC_Syntax_Syntax.Tm_uvar (u, (subst1, set_use_range))); + FStarC_Syntax_Syntax.pos = (e.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = (e.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (e.FStarC_Syntax_Syntax.hash_code) + } in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Thunk.mk norm_uvar in + FStarC_TypeChecker_NBETerm.UVar uu___5 in + (uu___4, []) in + FStarC_TypeChecker_NBETerm.Accu uu___3 in + mk_t1 uu___2 + | FStarC_Syntax_Syntax.Tm_name x -> + FStarC_TypeChecker_NBETerm.mkAccuVar x + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = []; + FStarC_Syntax_Syntax.body = uu___2; + FStarC_Syntax_Syntax.rc_opt = uu___3;_} + -> failwith "Impossible: abstraction with no binders" + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = xs; + FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = resc;_} + -> + mk_t1 + (FStarC_TypeChecker_NBETerm.Lam + { + FStarC_TypeChecker_NBETerm.interp = + (fun ys -> + let uu___2 = + let uu___3 = + FStarC_Compiler_List.map + FStar_Pervasives_Native.fst ys in + FStarC_Compiler_List.append uu___3 bs in + translate cfg uu___2 body); + FStarC_TypeChecker_NBETerm.shape = + (FStarC_TypeChecker_NBETerm.Lam_bs (bs, xs, resc)); + FStarC_TypeChecker_NBETerm.arity = + (FStarC_Compiler_List.length xs) + }) + | FStarC_Syntax_Syntax.Tm_fvar fvar -> + let uu___2 = try_in_cache cfg fvar in + (match uu___2 with + | FStar_Pervasives_Native.Some t -> t + | uu___3 -> + let uu___4 = + FStarC_Syntax_Syntax.set_range_of_fv fvar + e.FStarC_Syntax_Syntax.pos in + translate_fv cfg bs uu___4) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_reify uu___2); + FStarC_Syntax_Syntax.pos = uu___3; + FStarC_Syntax_Syntax.vars = uu___4; + FStarC_Syntax_Syntax.hash_code = uu___5;_}; + FStarC_Syntax_Syntax.args = arg::more::args;_} + -> + let uu___6 = FStarC_Syntax_Util.head_and_args e in + (match uu___6 with + | (head, uu___7) -> + let head1 = + FStarC_Syntax_Syntax.mk_Tm_app head [arg] + e.FStarC_Syntax_Syntax.pos in + let uu___8 = + FStarC_Syntax_Syntax.mk_Tm_app head1 (more :: args) + e.FStarC_Syntax_Syntax.pos in + translate cfg bs uu___8) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_reflect uu___2); + FStarC_Syntax_Syntax.pos = uu___3; + FStarC_Syntax_Syntax.vars = uu___4; + FStarC_Syntax_Syntax.hash_code = uu___5;_}; + FStarC_Syntax_Syntax.args = arg::more::args;_} + -> + let uu___6 = FStarC_Syntax_Util.head_and_args e in + (match uu___6 with + | (head, uu___7) -> + let head1 = + FStarC_Syntax_Syntax.mk_Tm_app head [arg] + e.FStarC_Syntax_Syntax.pos in + let uu___8 = + FStarC_Syntax_Syntax.mk_Tm_app head1 (more :: args) + e.FStarC_Syntax_Syntax.pos in + translate cfg bs uu___8) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_reflect uu___2); + FStarC_Syntax_Syntax.pos = uu___3; + FStarC_Syntax_Syntax.vars = uu___4; + FStarC_Syntax_Syntax.hash_code = uu___5;_}; + FStarC_Syntax_Syntax.args = arg::[];_} + when (cfg.core_cfg).FStarC_TypeChecker_Cfg.reifying -> + let cfg1 = reifying_false cfg in + translate cfg1 bs (FStar_Pervasives_Native.fst arg) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_reflect uu___2); + FStarC_Syntax_Syntax.pos = uu___3; + FStarC_Syntax_Syntax.vars = uu___4; + FStarC_Syntax_Syntax.hash_code = uu___5;_}; + FStarC_Syntax_Syntax.args = arg::[];_} + -> + let uu___6 = + let uu___7 = + translate cfg bs (FStar_Pervasives_Native.fst arg) in + FStarC_TypeChecker_NBETerm.Reflect uu___7 in + mk_t1 uu___6 + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_reify uu___2); + FStarC_Syntax_Syntax.pos = uu___3; + FStarC_Syntax_Syntax.vars = uu___4; + FStarC_Syntax_Syntax.hash_code = uu___5;_}; + FStarC_Syntax_Syntax.args = arg::[];_} + when + ((cfg.core_cfg).FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.reify_ + -> + let cfg1 = reifying_true cfg in + translate cfg1 bs (FStar_Pervasives_Native.fst arg) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_reflect uu___2); + FStarC_Syntax_Syntax.pos = uu___3; + FStarC_Syntax_Syntax.vars = uu___4; + FStarC_Syntax_Syntax.hash_code = uu___5;_}; + FStarC_Syntax_Syntax.args = arg::[];_} + -> + let uu___6 = + let uu___7 = + translate cfg bs (FStar_Pervasives_Native.fst arg) in + FStarC_TypeChecker_NBETerm.Reflect uu___7 in + mk_t1 uu___6 + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar fv; + FStarC_Syntax_Syntax.pos = uu___2; + FStarC_Syntax_Syntax.vars = uu___3; + FStarC_Syntax_Syntax.hash_code = uu___4;_}; + FStarC_Syntax_Syntax.args = uu___5::[];_} + when + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.assert_lid) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.assert_norm_lid) + -> + (debug1 + (fun uu___7 -> + FStarC_Compiler_Util.print_string "Eliminated assertion\n"); + mk_t1 + (FStarC_TypeChecker_NBETerm.Constant + FStarC_TypeChecker_NBETerm.Unit)) + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = args;_} + when + ((let uu___2 = FStarC_TypeChecker_Cfg.cfg_env cfg.core_cfg in + uu___2.FStarC_TypeChecker_Env.erase_erasable_args) || + ((cfg.core_cfg).FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.for_extraction) + || + ((cfg.core_cfg).FStarC_TypeChecker_Cfg.debug).FStarC_TypeChecker_Cfg.erase_erasable_args + -> + let uu___2 = translate cfg bs head in + let uu___3 = + FStarC_Compiler_List.map + (fun x -> + let uu___4 = + FStarC_Syntax_Util.aqual_is_erasable + (FStar_Pervasives_Native.snd x) in + if uu___4 + then + (debug1 + (fun uu___6 -> + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + (FStar_Pervasives_Native.fst x) in + FStarC_Compiler_Util.print1 "Erasing %s\n" uu___7); + ((mk_t1 + (FStarC_TypeChecker_NBETerm.Constant + FStarC_TypeChecker_NBETerm.Unit)), + (FStar_Pervasives_Native.snd x))) + else + (let uu___6 = + translate cfg bs (FStar_Pervasives_Native.fst x) in + (uu___6, (FStar_Pervasives_Native.snd x)))) args in + iapp cfg uu___2 uu___3 + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = args;_} + -> + (debug1 + (fun uu___3 -> + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + head in + let uu___5 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + (FStarC_Class_Show.show_tuple2 + FStarC_Syntax_Print.showable_term + FStarC_Syntax_Print.showable_aqual)) args in + FStarC_Compiler_Util.print2 "Application: %s @ %s\n" + uu___4 uu___5); + (let uu___3 = translate cfg bs head in + let uu___4 = + FStarC_Compiler_List.map + (fun x -> + let uu___5 = + translate cfg bs (FStar_Pervasives_Native.fst x) in + (uu___5, (FStar_Pervasives_Native.snd x))) args in + iapp cfg uu___3 uu___4)) + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = scrut; + FStarC_Syntax_Syntax.ret_opt = ret_opt; + FStarC_Syntax_Syntax.brs = branches; + FStarC_Syntax_Syntax.rc_opt1 = rc;_} + -> + let make_returns uu___2 = + match ret_opt with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (b, asc) -> + let uu___3 = + let x = + let uu___4 = + let uu___5 = + translate cfg bs + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + readback cfg uu___5 in + FStarC_Syntax_Syntax.gen_bv' + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.ppname + FStar_Pervasives_Native.None uu___4 in + let uu___4 = FStarC_Syntax_Syntax.mk_binder x in + let uu___5 = + let uu___6 = FStarC_TypeChecker_NBETerm.mkAccuVar x in + uu___6 :: bs in + (uu___4, uu___5) in + (match uu___3 with + | (b1, bs1) -> + let asc1 = + match asc with + | (FStar_Pervasives.Inl t, tacopt, use_eq) -> + let uu___4 = + let uu___5 = + let uu___6 = translate cfg bs1 t in + readback cfg uu___6 in + FStar_Pervasives.Inl uu___5 in + (uu___4, tacopt, use_eq) + | (FStar_Pervasives.Inr c, tacopt, use_eq) -> + let uu___4 = + let uu___5 = + let uu___6 = translate_comp cfg bs1 c in + readback_comp cfg uu___6 in + FStar_Pervasives.Inr uu___5 in + (uu___4, tacopt, use_eq) in + let asc2 = + FStarC_Syntax_Subst.close_ascription [b1] asc1 in + let b2 = + let uu___4 = FStarC_Syntax_Subst.close_binders [b1] in + FStarC_Compiler_List.hd uu___4 in + FStar_Pervasives_Native.Some (b2, asc2)) in + let make_rc uu___2 = + match rc with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some rc1 -> + let uu___3 = + let uu___4 = translate_residual_comp cfg bs rc1 in + readback_residual_comp cfg uu___4 in + FStar_Pervasives_Native.Some uu___3 in + let make_branches uu___2 = + let cfg1 = zeta_false cfg in + let rec process_pattern bs1 p = + let uu___3 = + match p.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_constant c -> + (bs1, (FStarC_Syntax_Syntax.Pat_constant c)) + | FStarC_Syntax_Syntax.Pat_cons (fvar, us_opt, args) -> + let uu___4 = + FStarC_Compiler_List.fold_left + (fun uu___5 -> + fun uu___6 -> + match (uu___5, uu___6) with + | ((bs2, args1), (arg, b)) -> + let uu___7 = process_pattern bs2 arg in + (match uu___7 with + | (bs', arg') -> + (bs', ((arg', b) :: args1)))) + (bs1, []) args in + (match uu___4 with + | (bs', args') -> + let us_opt1 = + match us_opt with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some us -> + let uu___5 = + FStarC_Compiler_List.map + (translate_univ cfg1 bs1) us in + FStar_Pervasives_Native.Some uu___5 in + (bs', + (FStarC_Syntax_Syntax.Pat_cons + (fvar, us_opt1, + (FStarC_Compiler_List.rev args'))))) + | FStarC_Syntax_Syntax.Pat_var bvar -> + let x = + let uu___4 = + let uu___5 = + translate cfg1 bs1 + bvar.FStarC_Syntax_Syntax.sort in + readback cfg1 uu___5 in + FStarC_Syntax_Syntax.gen_bv' + bvar.FStarC_Syntax_Syntax.ppname + FStar_Pervasives_Native.None uu___4 in + let uu___4 = + let uu___5 = FStarC_TypeChecker_NBETerm.mkAccuVar x in + uu___5 :: bs1 in + (uu___4, (FStarC_Syntax_Syntax.Pat_var x)) + | FStarC_Syntax_Syntax.Pat_dot_term eopt -> + let uu___4 = + let uu___5 = + FStarC_Compiler_Util.map_option + (fun e1 -> + let uu___6 = translate cfg1 bs1 e1 in + readback cfg1 uu___6) eopt in + FStarC_Syntax_Syntax.Pat_dot_term uu___5 in + (bs1, uu___4) in + match uu___3 with + | (bs2, p_new) -> + (bs2, + { + FStarC_Syntax_Syntax.v = p_new; + FStarC_Syntax_Syntax.p = (p.FStarC_Syntax_Syntax.p) + }) in + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with + | (pat, when_clause, e1) -> + let uu___4 = process_pattern bs pat in + (match uu___4 with + | (bs', pat') -> + let uu___5 = + let uu___6 = + let uu___7 = translate cfg1 bs' e1 in + readback cfg1 uu___7 in + (pat', when_clause, uu___6) in + FStarC_Syntax_Util.branch uu___5)) branches in + let scrut1 = translate cfg bs scrut in + (debug1 + (fun uu___3 -> + let uu___4 = + FStarC_Compiler_Range_Ops.string_of_range + e.FStarC_Syntax_Syntax.pos in + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + e in + FStarC_Compiler_Util.print2 "%s: Translating match %s\n" + uu___4 uu___5); + (let scrut2 = unlazy_unmeta scrut1 in + match scrut2.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Construct (c, us, args) -> + (debug1 + (fun uu___4 -> + let uu___5 = + let uu___6 = + FStarC_Compiler_List.map + (fun uu___7 -> + match uu___7 with + | (x, q) -> + let uu___8 = + FStarC_TypeChecker_NBETerm.t_to_string + x in + Prims.strcat + (if FStarC_Compiler_Util.is_some q + then "#" + else "") uu___8) args in + FStarC_Compiler_String.concat "; " uu___6 in + FStarC_Compiler_Util.print1 "Match args: %s\n" + uu___5); + (let uu___4 = pickBranch cfg scrut2 branches in + match uu___4 with + | FStar_Pervasives_Native.Some (branch, args1) -> + let uu___5 = + FStarC_Compiler_List.fold_left + (fun bs1 -> fun x -> x :: bs1) bs args1 in + translate cfg uu___5 branch + | FStar_Pervasives_Native.None -> + FStarC_TypeChecker_NBETerm.mkAccuMatch scrut2 + make_returns make_branches make_rc)) + | FStarC_TypeChecker_NBETerm.Constant c -> + (debug1 + (fun uu___4 -> + let uu___5 = + FStarC_TypeChecker_NBETerm.t_to_string scrut2 in + FStarC_Compiler_Util.print1 "Match constant : %s\n" + uu___5); + (let uu___4 = pickBranch cfg scrut2 branches in + match uu___4 with + | FStar_Pervasives_Native.Some (branch, []) -> + translate cfg bs branch + | FStar_Pervasives_Native.Some (branch, arg::[]) -> + translate cfg (arg :: bs) branch + | FStar_Pervasives_Native.None -> + FStarC_TypeChecker_NBETerm.mkAccuMatch scrut2 + make_returns make_branches make_rc + | FStar_Pervasives_Native.Some (uu___5, hd::tl) -> + failwith + "Impossible: Matching on constants cannot bind more than one variable")) + | uu___3 -> + FStarC_TypeChecker_NBETerm.mkAccuMatch scrut2 make_returns + make_branches make_rc)) + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = e1; + FStarC_Syntax_Syntax.meta = FStarC_Syntax_Syntax.Meta_monadic + (m, t);_} + when (cfg.core_cfg).FStarC_TypeChecker_Cfg.reifying -> + translate_monadic (m, t) cfg bs e1 + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = e1; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_monadic_lift (m, m', t);_} + when (cfg.core_cfg).FStarC_TypeChecker_Cfg.reifying -> + translate_monadic_lift (m, m', t) cfg bs e1 + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = e1; + FStarC_Syntax_Syntax.meta = meta;_} + -> + let norm_meta uu___2 = + let norm t = + let uu___3 = translate cfg bs t in readback cfg uu___3 in + match meta with + | FStarC_Syntax_Syntax.Meta_named uu___3 -> meta + | FStarC_Syntax_Syntax.Meta_labeled uu___3 -> meta + | FStarC_Syntax_Syntax.Meta_desugared uu___3 -> meta + | FStarC_Syntax_Syntax.Meta_pattern (ts, args) -> + let uu___3 = + let uu___4 = FStarC_Compiler_List.map norm ts in + let uu___5 = + FStarC_Compiler_List.map + (FStarC_Compiler_List.map + (fun uu___6 -> + match uu___6 with + | (t, a) -> let uu___7 = norm t in (uu___7, a))) + args in + (uu___4, uu___5) in + FStarC_Syntax_Syntax.Meta_pattern uu___3 + | FStarC_Syntax_Syntax.Meta_monadic (m, t) -> + let uu___3 = let uu___4 = norm t in (m, uu___4) in + FStarC_Syntax_Syntax.Meta_monadic uu___3 + | FStarC_Syntax_Syntax.Meta_monadic_lift (m0, m1, t) -> + let uu___3 = let uu___4 = norm t in (m0, m1, uu___4) in + FStarC_Syntax_Syntax.Meta_monadic_lift uu___3 in + let uu___2 = + let uu___3 = + let uu___4 = translate cfg bs e1 in + let uu___5 = FStarC_Thunk.mk norm_meta in (uu___4, uu___5) in + FStarC_TypeChecker_NBETerm.Meta uu___3 in + mk_t1 uu___2 + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (false, lb::[]); + FStarC_Syntax_Syntax.body1 = body;_} + -> + let uu___2 = + FStarC_TypeChecker_Cfg.should_reduce_local_let cfg.core_cfg lb in + if uu___2 + then + let uu___3 = + (((cfg.core_cfg).FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.for_extraction + && + (FStarC_Syntax_Util.is_unit lb.FStarC_Syntax_Syntax.lbtyp)) + && + (FStarC_Syntax_Util.is_pure_or_ghost_effect + lb.FStarC_Syntax_Syntax.lbeff) in + (if uu___3 + then + let bs1 = + let uu___4 = + let uu___5 = + FStarC_Syntax_Syntax.range_of_lbname + lb.FStarC_Syntax_Syntax.lbname in + mk_rt uu___5 + (FStarC_TypeChecker_NBETerm.Constant + FStarC_TypeChecker_NBETerm.Unit) in + uu___4 :: bs in + translate cfg bs1 body + else + (let bs1 = + let uu___5 = translate_letbinding cfg bs lb in uu___5 :: + bs in + translate cfg bs1 body)) + else + (let def uu___4 = + let uu___5 = + (((cfg.core_cfg).FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.for_extraction + && + (FStarC_Syntax_Util.is_unit + lb.FStarC_Syntax_Syntax.lbtyp)) + && + (FStarC_Syntax_Util.is_pure_or_ghost_effect + lb.FStarC_Syntax_Syntax.lbeff) in + if uu___5 + then + mk_t1 + (FStarC_TypeChecker_NBETerm.Constant + FStarC_TypeChecker_NBETerm.Unit) + else translate cfg bs lb.FStarC_Syntax_Syntax.lbdef in + let typ uu___4 = + translate cfg bs lb.FStarC_Syntax_Syntax.lbtyp in + let name = + let uu___4 = + FStarC_Compiler_Util.left lb.FStarC_Syntax_Syntax.lbname in + FStarC_Syntax_Syntax.freshen_bv uu___4 in + let bs1 = + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.range_of_bv name in + mk_rt uu___5 + (FStarC_TypeChecker_NBETerm.Accu + ((FStarC_TypeChecker_NBETerm.Var name), [])) in + uu___4 :: bs in + let body1 uu___4 = translate cfg bs1 body in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Thunk.mk typ in + let uu___9 = FStarC_Thunk.mk def in + let uu___10 = FStarC_Thunk.mk body1 in + (name, uu___8, uu___9, uu___10, lb) in + FStarC_TypeChecker_NBETerm.UnreducedLet uu___7 in + (uu___6, []) in + FStarC_TypeChecker_NBETerm.Accu uu___5 in + mk_t1 uu___4) + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (_rec, lbs); + FStarC_Syntax_Syntax.body1 = body;_} + -> + if + (Prims.op_Negation + ((cfg.core_cfg).FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.zeta) + && + ((cfg.core_cfg).FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.pure_subterms_within_computations + then + let vars = + FStarC_Compiler_List.map + (fun lb -> + let uu___2 = + FStarC_Compiler_Util.left + lb.FStarC_Syntax_Syntax.lbname in + FStarC_Syntax_Syntax.freshen_bv uu___2) lbs in + let typs = + FStarC_Compiler_List.map + (fun lb -> translate cfg bs lb.FStarC_Syntax_Syntax.lbtyp) + lbs in + let rec_bs = + let uu___2 = + FStarC_Compiler_List.map + (fun v -> + let uu___3 = FStarC_Syntax_Syntax.range_of_bv v in + mk_rt uu___3 + (FStarC_TypeChecker_NBETerm.Accu + ((FStarC_TypeChecker_NBETerm.Var v), []))) vars in + FStarC_Compiler_List.op_At uu___2 bs in + let defs = + FStarC_Compiler_List.map + (fun lb -> + translate cfg rec_bs lb.FStarC_Syntax_Syntax.lbdef) lbs in + let body1 = translate cfg rec_bs body in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Compiler_List.zip3 vars typs defs in + (uu___6, body1, lbs) in + FStarC_TypeChecker_NBETerm.UnreducedLetRec uu___5 in + (uu___4, []) in + FStarC_TypeChecker_NBETerm.Accu uu___3 in + mk_t1 uu___2 + else + (let uu___3 = make_rec_env lbs bs in translate cfg uu___3 body) + | FStarC_Syntax_Syntax.Tm_quoted (qt, qi) -> + let close t = + let bvs = + FStarC_Compiler_List.map + (fun uu___2 -> + FStarC_Syntax_Syntax.new_bv + FStar_Pervasives_Native.None FStarC_Syntax_Syntax.tun) + bs in + let s1 = + FStarC_Compiler_List.mapi + (fun i -> fun bv -> FStarC_Syntax_Syntax.DB (i, bv)) bvs in + let s2 = + let uu___2 = FStarC_Compiler_List.zip bvs bs in + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with + | (bv, t1) -> + let uu___4 = + let uu___5 = readback cfg t1 in (bv, uu___5) in + FStarC_Syntax_Syntax.NT uu___4) uu___2 in + let uu___2 = FStarC_Syntax_Subst.subst s1 t in + FStarC_Syntax_Subst.subst s2 uu___2 in + (match qi.FStarC_Syntax_Syntax.qkind with + | FStarC_Syntax_Syntax.Quote_dynamic -> + let qt1 = close qt in + mk_t1 (FStarC_TypeChecker_NBETerm.Quote (qt1, qi)) + | FStarC_Syntax_Syntax.Quote_static -> + let qi1 = FStarC_Syntax_Syntax.on_antiquoted close qi in + mk_t1 (FStarC_TypeChecker_NBETerm.Quote (qt, qi1))) + | FStarC_Syntax_Syntax.Tm_lazy li -> + let f uu___2 = + let t = FStarC_Syntax_Util.unfold_lazy li in + debug1 + (fun uu___4 -> + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.print1 + ">> Unfolding Tm_lazy to %s\n" uu___5); + translate cfg bs t in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Thunk.mk f in + ((FStar_Pervasives.Inl li), uu___4) in + FStarC_TypeChecker_NBETerm.Lazy uu___3 in + mk_t1 uu___2) +and (translate_comp : + config -> + FStarC_TypeChecker_NBETerm.t Prims.list -> + FStarC_Syntax_Syntax.comp -> FStarC_TypeChecker_NBETerm.comp) + = + fun cfg -> + fun bs -> + fun c -> + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total typ -> + let uu___ = translate cfg bs typ in + FStarC_TypeChecker_NBETerm.Tot uu___ + | FStarC_Syntax_Syntax.GTotal typ -> + let uu___ = translate cfg bs typ in + FStarC_TypeChecker_NBETerm.GTot uu___ + | FStarC_Syntax_Syntax.Comp ctyp -> + let uu___ = translate_comp_typ cfg bs ctyp in + FStarC_TypeChecker_NBETerm.Comp uu___ +and (iapp : + config -> + FStarC_TypeChecker_NBETerm.t -> + FStarC_TypeChecker_NBETerm.args -> FStarC_TypeChecker_NBETerm.t) + = + fun cfg -> + fun f -> + fun args -> + let mk t = mk_rt f.FStarC_TypeChecker_NBETerm.nbe_r t in + let uu___ = + let uu___1 = unlazy_unmeta f in + uu___1.FStarC_TypeChecker_NBETerm.nbe_t in + match uu___ with + | FStarC_TypeChecker_NBETerm.Lam + { FStarC_TypeChecker_NBETerm.interp = f1; + FStarC_TypeChecker_NBETerm.shape = shape; + FStarC_TypeChecker_NBETerm.arity = n;_} + -> + let m = FStarC_Compiler_List.length args in + if m < n + then + let arg_values_rev = FStarC_Compiler_List.rev args in + let shape1 = + match shape with + | FStarC_TypeChecker_NBETerm.Lam_args raw_args -> + let uu___1 = FStarC_Compiler_List.splitAt m raw_args in + (match uu___1 with + | (uu___2, raw_args1) -> + FStarC_TypeChecker_NBETerm.Lam_args raw_args1) + | FStarC_TypeChecker_NBETerm.Lam_bs (ctx, xs, rc) -> + let uu___1 = FStarC_Compiler_List.splitAt m xs in + (match uu___1 with + | (uu___2, xs1) -> + let ctx1 = + let uu___3 = + FStarC_Compiler_List.map + FStar_Pervasives_Native.fst arg_values_rev in + FStarC_Compiler_List.append uu___3 ctx in + FStarC_TypeChecker_NBETerm.Lam_bs (ctx1, xs1, rc)) + | FStarC_TypeChecker_NBETerm.Lam_primop (f2, args_acc) -> + FStarC_TypeChecker_NBETerm.Lam_primop + (f2, (FStarC_Compiler_List.op_At args_acc args)) in + mk + (FStarC_TypeChecker_NBETerm.Lam + { + FStarC_TypeChecker_NBETerm.interp = + (fun l -> + f1 (FStarC_Compiler_List.append l arg_values_rev)); + FStarC_TypeChecker_NBETerm.shape = shape1; + FStarC_TypeChecker_NBETerm.arity = (n - m) + }) + else + if m = n + then + (let arg_values_rev = FStarC_Compiler_List.rev args in + f1 arg_values_rev) + else + (let uu___3 = FStarC_Compiler_List.splitAt n args in + match uu___3 with + | (args1, args') -> + let uu___4 = f1 (FStarC_Compiler_List.rev args1) in + iapp cfg uu___4 args') + | FStarC_TypeChecker_NBETerm.Accu (a, ts) -> + mk + (FStarC_TypeChecker_NBETerm.Accu + (a, (FStarC_Compiler_List.rev_append args ts))) + | FStarC_TypeChecker_NBETerm.Construct (i, us, ts) -> + let rec aux args1 us1 ts1 = + match args1 with + | ({ + FStarC_TypeChecker_NBETerm.nbe_t = + FStarC_TypeChecker_NBETerm.Univ u; + FStarC_TypeChecker_NBETerm.nbe_r = uu___1;_}, + uu___2)::args2 -> aux args2 (u :: us1) ts1 + | a::args2 -> aux args2 us1 (a :: ts1) + | [] -> (us1, ts1) in + let uu___1 = aux args us ts in + (match uu___1 with + | (us', ts') -> + mk (FStarC_TypeChecker_NBETerm.Construct (i, us', ts'))) + | FStarC_TypeChecker_NBETerm.FV (i, us, ts) -> + let rec aux args1 us1 ts1 = + match args1 with + | ({ + FStarC_TypeChecker_NBETerm.nbe_t = + FStarC_TypeChecker_NBETerm.Univ u; + FStarC_TypeChecker_NBETerm.nbe_r = uu___1;_}, + uu___2)::args2 -> aux args2 (u :: us1) ts1 + | a::args2 -> aux args2 us1 (a :: ts1) + | [] -> (us1, ts1) in + let uu___1 = aux args us ts in + (match uu___1 with + | (us', ts') -> mk (FStarC_TypeChecker_NBETerm.FV (i, us', ts'))) + | FStarC_TypeChecker_NBETerm.TopLevelLet (lb, arity, args_rev) -> + let args_rev1 = FStarC_Compiler_List.rev_append args args_rev in + let n_args_rev = FStarC_Compiler_List.length args_rev1 in + let n_univs = + FStarC_Compiler_List.length lb.FStarC_Syntax_Syntax.lbunivs in + (debug cfg + (fun uu___2 -> + let uu___3 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_either + FStarC_Syntax_Print.showable_bv + FStarC_Syntax_Print.showable_fv) + lb.FStarC_Syntax_Syntax.lbname in + let uu___4 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) arity in + let uu___5 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_nat) n_args_rev in + FStarC_Compiler_Util.print3 + "Reached iapp for %s with arity %s and n_args = %s\n" + uu___3 uu___4 uu___5); + if n_args_rev >= arity + then + (let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Syntax_Util.unascribe + lb.FStarC_Syntax_Syntax.lbdef in + uu___4.FStarC_Syntax_Syntax.n in + match uu___3 with + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs; + FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = uu___4;_} + -> (bs, body) + | uu___4 -> ([], (lb.FStarC_Syntax_Syntax.lbdef)) in + match uu___2 with + | (bs, body) -> + if (n_univs + (FStarC_Compiler_List.length bs)) = arity + then + let uu___3 = + FStarC_Compiler_Util.first_N (n_args_rev - arity) + args_rev1 in + (match uu___3 with + | (extra, args_rev2) -> + (debug cfg + (fun uu___5 -> + let uu___6 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_either + FStarC_Syntax_Print.showable_bv + FStarC_Syntax_Print.showable_fv) + lb.FStarC_Syntax_Syntax.lbname in + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term body in + let uu___8 = + FStarC_Class_Show.show + FStarC_TypeChecker_NBETerm.showable_args + args_rev2 in + FStarC_Compiler_Util.print3 + "Reducing body of %s = %s,\n\twith args = %s\n" + uu___6 uu___7 uu___8); + (let t = + let uu___5 = + FStarC_Compiler_List.map + FStar_Pervasives_Native.fst args_rev2 in + translate cfg uu___5 body in + match extra with + | [] -> t + | uu___5 -> + iapp cfg t (FStarC_Compiler_List.rev extra)))) + else + (let uu___4 = + FStarC_Compiler_Util.first_N (n_args_rev - n_univs) + args_rev1 in + match uu___4 with + | (extra, univs) -> + let uu___5 = + let uu___6 = + FStarC_Compiler_List.map + FStar_Pervasives_Native.fst univs in + translate cfg uu___6 + lb.FStarC_Syntax_Syntax.lbdef in + iapp cfg uu___5 (FStarC_Compiler_List.rev extra))) + else + mk + (FStarC_TypeChecker_NBETerm.TopLevelLet + (lb, arity, args_rev1))) + | FStarC_TypeChecker_NBETerm.TopLevelRec + (lb, arity, decreases_list, args') -> + let args1 = FStarC_Compiler_List.append args' args in + if (FStarC_Compiler_List.length args1) >= arity + then + let uu___1 = + should_reduce_recursive_definition args1 decreases_list in + (match uu___1 with + | (should_reduce, uu___2, uu___3) -> + if Prims.op_Negation should_reduce + then + let fv = + FStarC_Compiler_Util.right + lb.FStarC_Syntax_Syntax.lbname in + (debug cfg + (fun uu___5 -> + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_fv fv in + FStarC_Compiler_Util.print1 + "Decided to not unfold recursive definition %s\n" + uu___6); + (let uu___5 = + let uu___6 = FStarC_Syntax_Syntax.range_of_fv fv in + mk_rt uu___6 + (FStarC_TypeChecker_NBETerm.FV (fv, [], [])) in + iapp cfg uu___5 args1)) + else + (debug cfg + (fun uu___6 -> + let uu___7 = + let uu___8 = + FStarC_Compiler_Util.right + lb.FStarC_Syntax_Syntax.lbname in + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_fv uu___8 in + FStarC_Compiler_Util.print1 + "Yes, Decided to unfold recursive definition %s\n" + uu___7); + (let uu___6 = + FStarC_Compiler_Util.first_N + (FStarC_Compiler_List.length + lb.FStarC_Syntax_Syntax.lbunivs) args1 in + match uu___6 with + | (univs, rest) -> + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Compiler_List.map + FStar_Pervasives_Native.fst univs in + FStarC_Compiler_List.rev uu___9 in + translate cfg uu___8 + lb.FStarC_Syntax_Syntax.lbdef in + iapp cfg uu___7 rest))) + else + mk + (FStarC_TypeChecker_NBETerm.TopLevelRec + (lb, arity, decreases_list, args1)) + | FStarC_TypeChecker_NBETerm.LocalLetRec + (i, lb, mutual_lbs, local_env, acc_args, remaining_arity, + decreases_list) + -> + if remaining_arity = Prims.int_zero + then + mk + (FStarC_TypeChecker_NBETerm.LocalLetRec + (i, lb, mutual_lbs, local_env, + (FStarC_Compiler_List.op_At acc_args args), + remaining_arity, decreases_list)) + else + (let n_args = FStarC_Compiler_List.length args in + if n_args < remaining_arity + then + mk + (FStarC_TypeChecker_NBETerm.LocalLetRec + (i, lb, mutual_lbs, local_env, + (FStarC_Compiler_List.op_At acc_args args), + (remaining_arity - n_args), decreases_list)) + else + (let args1 = FStarC_Compiler_List.op_At acc_args args in + let uu___3 = + should_reduce_recursive_definition args1 decreases_list in + match uu___3 with + | (should_reduce, uu___4, uu___5) -> + if Prims.op_Negation should_reduce + then + mk + (FStarC_TypeChecker_NBETerm.LocalLetRec + (i, lb, mutual_lbs, local_env, args1, + Prims.int_zero, decreases_list)) + else + (let env = make_rec_env mutual_lbs local_env in + debug cfg + (fun uu___8 -> + (let uu___10 = + let uu___11 = + FStarC_Compiler_List.map + FStarC_TypeChecker_NBETerm.t_to_string + env in + FStarC_Compiler_String.concat ",\n\t " + uu___11 in + FStarC_Compiler_Util.print1 + "LocalLetRec Env = {\n\t%s\n}\n" uu___10); + (let uu___10 = + let uu___11 = + FStarC_Compiler_List.map + (fun uu___12 -> + match uu___12 with + | (t, uu___13) -> + FStarC_TypeChecker_NBETerm.t_to_string + t) args1 in + FStarC_Compiler_String.concat ",\n\t " + uu___11 in + FStarC_Compiler_Util.print1 + "LocalLetRec Args = {\n\t%s\n}\n" uu___10)); + (let uu___8 = + translate cfg env lb.FStarC_Syntax_Syntax.lbdef in + iapp cfg uu___8 args1)))) + | FStarC_TypeChecker_NBETerm.Constant + (FStarC_TypeChecker_NBETerm.SConst (FStarC_Const.Const_range_of)) + -> + let callbacks = + { + FStarC_TypeChecker_NBETerm.iapp = (iapp cfg); + FStarC_TypeChecker_NBETerm.translate = (translate cfg []) + } in + (match args with + | (a, uu___1)::[] -> + FStarC_TypeChecker_NBETerm.embed + FStarC_TypeChecker_NBETerm.e_range callbacks + a.FStarC_TypeChecker_NBETerm.nbe_r + | uu___1 -> + let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string f in + Prims.strcat "NBE ill-typed application Const_range_of: " + uu___3 in + failwith uu___2) + | FStarC_TypeChecker_NBETerm.Constant + (FStarC_TypeChecker_NBETerm.SConst + (FStarC_Const.Const_set_range_of)) -> + let callbacks = + { + FStarC_TypeChecker_NBETerm.iapp = (iapp cfg); + FStarC_TypeChecker_NBETerm.translate = (translate cfg []) + } in + (match args with + | (t, uu___1)::(r, uu___2)::[] -> + let uu___3 = + FStarC_TypeChecker_NBETerm.unembed + FStarC_TypeChecker_NBETerm.e_range callbacks r in + (match uu___3 with + | FStar_Pervasives_Native.Some rr -> + { + FStarC_TypeChecker_NBETerm.nbe_t = + (t.FStarC_TypeChecker_NBETerm.nbe_t); + FStarC_TypeChecker_NBETerm.nbe_r = rr + } + | FStar_Pervasives_Native.None -> Prims.magic ()) + | uu___1 -> + let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string f in + Prims.strcat + "NBE ill-typed application Const_set_range_of: " uu___3 in + failwith uu___2) + | uu___1 -> + let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string f in + Prims.strcat "NBE ill-typed application: " uu___3 in + failwith uu___2 +and (translate_fv : + config -> + FStarC_TypeChecker_NBETerm.t Prims.list -> + FStarC_Syntax_Syntax.fv -> FStarC_TypeChecker_NBETerm.t) + = + fun cfg -> + fun bs -> + fun fvar -> + let debug1 = debug cfg in + let qninfo = + let uu___ = FStarC_TypeChecker_Cfg.cfg_env cfg.core_cfg in + let uu___1 = FStarC_Syntax_Syntax.lid_of_fv fvar in + FStarC_TypeChecker_Env.lookup_qname uu___ uu___1 in + let uu___ = (is_constr qninfo) || (is_constr_fv fvar) in + if uu___ + then FStarC_TypeChecker_NBETerm.mkConstruct fvar [] [] + else + (let uu___2 = + FStarC_TypeChecker_Normalize_Unfolding.should_unfold + cfg.core_cfg + (fun uu___3 -> (cfg.core_cfg).FStarC_TypeChecker_Cfg.reifying) + fvar qninfo in + match uu___2 with + | FStarC_TypeChecker_Normalize_Unfolding.Should_unfold_fully -> + failwith "Not yet handled" + | FStarC_TypeChecker_Normalize_Unfolding.Should_unfold_no -> + (debug1 + (fun uu___4 -> + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_fv + fvar in + FStarC_Compiler_Util.print1 + "(1) Decided to not unfold %s\n" uu___5); + (let uu___4 = + FStarC_TypeChecker_Cfg.find_prim_step cfg.core_cfg fvar in + match uu___4 with + | FStar_Pervasives_Native.Some prim_step when + prim_step.FStarC_TypeChecker_Primops_Base.strong_reduction_ok + -> + let arity = + prim_step.FStarC_TypeChecker_Primops_Base.arity + + prim_step.FStarC_TypeChecker_Primops_Base.univ_arity in + (debug1 + (fun uu___6 -> + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_fv fvar in + FStarC_Compiler_Util.print1 "Found a primop %s\n" + uu___7); + mk_t + (FStarC_TypeChecker_NBETerm.Lam + { + FStarC_TypeChecker_NBETerm.interp = + (fun args_rev -> + let args' = + FStarC_Compiler_List.rev args_rev in + let callbacks = + { + FStarC_TypeChecker_NBETerm.iapp = + (iapp cfg); + FStarC_TypeChecker_NBETerm.translate = + (translate cfg bs) + } in + debug1 + (fun uu___7 -> + let uu___8 = + FStarC_Class_Show.show + FStarC_TypeChecker_NBETerm.showable_args + args' in + FStarC_Compiler_Util.print1 + "Caling primop with args = [%s]\n" + uu___8); + (let uu___7 = + FStarC_Compiler_List.span + (fun uu___8 -> + match uu___8 with + | ({ + FStarC_TypeChecker_NBETerm.nbe_t + = + FStarC_TypeChecker_NBETerm.Univ + uu___9; + FStarC_TypeChecker_NBETerm.nbe_r + = uu___10;_}, + uu___11) -> true + | uu___9 -> false) args' in + match uu___7 with + | (univs, rest) -> + let univs1 = + FStarC_Compiler_List.map + (fun uu___8 -> + match uu___8 with + | ({ + FStarC_TypeChecker_NBETerm.nbe_t + = + FStarC_TypeChecker_NBETerm.Univ + u; + FStarC_TypeChecker_NBETerm.nbe_r + = uu___9;_}, + uu___10) -> u + | uu___9 -> + failwith "Impossible") + univs in + let uu___8 = + prim_step.FStarC_TypeChecker_Primops_Base.interpretation_nbe + callbacks univs1 rest in + (match uu___8 with + | FStar_Pervasives_Native.Some x -> + (debug1 + (fun uu___10 -> + let uu___11 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_fv + fvar in + let uu___12 = + FStarC_TypeChecker_NBETerm.t_to_string + x in + FStarC_Compiler_Util.print2 + "Primitive operator %s returned %s\n" + uu___11 uu___12); + x) + | FStar_Pervasives_Native.None -> + (debug1 + (fun uu___10 -> + let uu___11 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_fv + fvar in + FStarC_Compiler_Util.print1 + "Primitive operator %s failed\n" + uu___11); + (let uu___10 = + FStarC_TypeChecker_NBETerm.mkFV + fvar [] [] in + iapp cfg uu___10 args'))))); + FStarC_TypeChecker_NBETerm.shape = + (FStarC_TypeChecker_NBETerm.Lam_primop + (fvar, [])); + FStarC_TypeChecker_NBETerm.arity = arity + })) + | FStar_Pervasives_Native.Some uu___5 -> + (debug1 + (fun uu___7 -> + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_fv fvar in + FStarC_Compiler_Util.print1 + "(2) Decided to not unfold %s\n" uu___8); + FStarC_TypeChecker_NBETerm.mkFV fvar [] []) + | uu___5 -> + (debug1 + (fun uu___7 -> + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_fv fvar in + FStarC_Compiler_Util.print1 + "(3) Decided to not unfold %s\n" uu___8); + FStarC_TypeChecker_NBETerm.mkFV fvar [] []))) + | FStarC_TypeChecker_Normalize_Unfolding.Should_unfold_reify -> + let t = + let is_qninfo_visible = + let uu___3 = + FStarC_TypeChecker_Env.lookup_definition_qninfo + (cfg.core_cfg).FStarC_TypeChecker_Cfg.delta_level + (fvar.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + qninfo in + FStarC_Compiler_Option.isSome uu___3 in + if is_qninfo_visible + then + match qninfo with + | FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr + ({ + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (is_rec, lbs); + FStarC_Syntax_Syntax.lids1 = names;_}; + FStarC_Syntax_Syntax.sigrng = uu___3; + FStarC_Syntax_Syntax.sigquals = uu___4; + FStarC_Syntax_Syntax.sigmeta = uu___5; + FStarC_Syntax_Syntax.sigattrs = uu___6; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___7; + FStarC_Syntax_Syntax.sigopts = uu___8;_}, + _us_opt), + _rng) + -> + (debug1 + (fun uu___10 -> + let uu___11 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_fv fvar in + FStarC_Compiler_Util.print1 + "(1) Decided to unfold %s\n" uu___11); + (let lbm = find_let lbs fvar in + match lbm with + | FStar_Pervasives_Native.Some lb -> + if + is_rec && + ((cfg.core_cfg).FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.zeta + then + let uu___10 = let_rec_arity lb in + (match uu___10 with + | (ar, lst) -> + let uu___11 = + FStarC_Syntax_Syntax.range_of_fv fvar in + mk_rt uu___11 + (FStarC_TypeChecker_NBETerm.TopLevelRec + (lb, ar, lst, []))) + else translate_letbinding cfg bs lb + | FStar_Pervasives_Native.None -> + failwith "Could not find let binding")) + | uu___3 -> + (debug1 + (fun uu___5 -> + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_fv fvar in + FStarC_Compiler_Util.print1 + "(1) qninfo is None for (%s)\n" uu___6); + FStarC_TypeChecker_NBETerm.mkFV fvar [] []) + else + (debug1 + (fun uu___5 -> + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_fv fvar in + FStarC_Compiler_Util.print1 + "(1) qninfo is not visible at this level (%s)\n" + uu___6); + FStarC_TypeChecker_NBETerm.mkFV fvar [] []) in + (cache_add cfg fvar t; t) + | FStarC_TypeChecker_Normalize_Unfolding.Should_unfold_yes -> + let t = + let is_qninfo_visible = + let uu___3 = + FStarC_TypeChecker_Env.lookup_definition_qninfo + (cfg.core_cfg).FStarC_TypeChecker_Cfg.delta_level + (fvar.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + qninfo in + FStarC_Compiler_Option.isSome uu___3 in + if is_qninfo_visible + then + match qninfo with + | FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr + ({ + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (is_rec, lbs); + FStarC_Syntax_Syntax.lids1 = names;_}; + FStarC_Syntax_Syntax.sigrng = uu___3; + FStarC_Syntax_Syntax.sigquals = uu___4; + FStarC_Syntax_Syntax.sigmeta = uu___5; + FStarC_Syntax_Syntax.sigattrs = uu___6; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___7; + FStarC_Syntax_Syntax.sigopts = uu___8;_}, + _us_opt), + _rng) + -> + (debug1 + (fun uu___10 -> + let uu___11 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_fv fvar in + FStarC_Compiler_Util.print1 + "(1) Decided to unfold %s\n" uu___11); + (let lbm = find_let lbs fvar in + match lbm with + | FStar_Pervasives_Native.Some lb -> + if + is_rec && + ((cfg.core_cfg).FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.zeta + then + let uu___10 = let_rec_arity lb in + (match uu___10 with + | (ar, lst) -> + let uu___11 = + FStarC_Syntax_Syntax.range_of_fv fvar in + mk_rt uu___11 + (FStarC_TypeChecker_NBETerm.TopLevelRec + (lb, ar, lst, []))) + else translate_letbinding cfg bs lb + | FStar_Pervasives_Native.None -> + failwith "Could not find let binding")) + | uu___3 -> + (debug1 + (fun uu___5 -> + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_fv fvar in + FStarC_Compiler_Util.print1 + "(1) qninfo is None for (%s)\n" uu___6); + FStarC_TypeChecker_NBETerm.mkFV fvar [] []) + else + (debug1 + (fun uu___5 -> + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_fv fvar in + FStarC_Compiler_Util.print1 + "(1) qninfo is not visible at this level (%s)\n" + uu___6); + FStarC_TypeChecker_NBETerm.mkFV fvar [] []) in + (cache_add cfg fvar t; t)) +and (translate_letbinding : + config -> + FStarC_TypeChecker_NBETerm.t Prims.list -> + FStarC_Syntax_Syntax.letbinding -> FStarC_TypeChecker_NBETerm.t) + = + fun cfg -> + fun bs -> + fun lb -> + let debug1 = debug cfg in + let us = lb.FStarC_Syntax_Syntax.lbunivs in + let uu___ = + FStarC_Syntax_Util.arrow_formals lb.FStarC_Syntax_Syntax.lbtyp in + match uu___ with + | (formals, uu___1) -> + let arity = + (FStarC_Compiler_List.length us) + + (FStarC_Compiler_List.length formals) in + if arity = Prims.int_zero + then translate cfg bs lb.FStarC_Syntax_Syntax.lbdef + else + (let uu___3 = + FStarC_Compiler_Util.is_right lb.FStarC_Syntax_Syntax.lbname in + if uu___3 + then + (debug1 + (fun uu___5 -> + let uu___6 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_either + FStarC_Syntax_Print.showable_bv + FStarC_Syntax_Print.showable_fv) + lb.FStarC_Syntax_Syntax.lbname in + let uu___7 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) arity in + FStarC_Compiler_Util.print2 + "Making TopLevelLet for %s with arity %s\n" uu___6 + uu___7); + (let uu___5 = + FStarC_Syntax_Syntax.range_of_lbname + lb.FStarC_Syntax_Syntax.lbname in + mk_rt uu___5 + (FStarC_TypeChecker_NBETerm.TopLevelLet (lb, arity, [])))) + else translate cfg bs lb.FStarC_Syntax_Syntax.lbdef) +and (mkRec : + Prims.int -> + FStarC_Syntax_Syntax.letbinding -> + FStarC_Syntax_Syntax.letbinding Prims.list -> + FStarC_TypeChecker_NBETerm.t Prims.list -> + FStarC_TypeChecker_NBETerm.t) + = + fun i -> + fun b -> + fun bs -> + fun env -> + let uu___ = let_rec_arity b in + match uu___ with + | (ar, ar_lst) -> + mk_t + (FStarC_TypeChecker_NBETerm.LocalLetRec + (i, b, bs, env, [], ar, ar_lst)) +and (make_rec_env : + FStarC_Syntax_Syntax.letbinding Prims.list -> + FStarC_TypeChecker_NBETerm.t Prims.list -> + FStarC_TypeChecker_NBETerm.t Prims.list) + = + fun all_lbs -> + fun all_outer_bs -> + let rec_bindings = + FStarC_Compiler_List.mapi + (fun i -> fun lb -> mkRec i lb all_lbs all_outer_bs) all_lbs in + FStarC_Compiler_List.rev_append rec_bindings all_outer_bs +and (translate_constant : + FStarC_Syntax_Syntax.sconst -> FStarC_TypeChecker_NBETerm.constant) = + fun c -> + match c with + | FStarC_Const.Const_unit -> FStarC_TypeChecker_NBETerm.Unit + | FStarC_Const.Const_bool b -> FStarC_TypeChecker_NBETerm.Bool b + | FStarC_Const.Const_int (s, FStar_Pervasives_Native.None) -> + let uu___ = FStarC_BigInt.big_int_of_string s in + FStarC_TypeChecker_NBETerm.Int uu___ + | FStarC_Const.Const_string (s, r) -> + FStarC_TypeChecker_NBETerm.String (s, r) + | FStarC_Const.Const_char c1 -> FStarC_TypeChecker_NBETerm.Char c1 + | FStarC_Const.Const_range r -> FStarC_TypeChecker_NBETerm.Range r + | FStarC_Const.Const_real r -> FStarC_TypeChecker_NBETerm.Real r + | uu___ -> FStarC_TypeChecker_NBETerm.SConst c +and (readback_comp : + config -> FStarC_TypeChecker_NBETerm.comp -> FStarC_Syntax_Syntax.comp) = + fun cfg -> + fun c -> + let c' = + match c with + | FStarC_TypeChecker_NBETerm.Tot typ -> + let uu___ = readback cfg typ in FStarC_Syntax_Syntax.Total uu___ + | FStarC_TypeChecker_NBETerm.GTot typ -> + let uu___ = readback cfg typ in FStarC_Syntax_Syntax.GTotal uu___ + | FStarC_TypeChecker_NBETerm.Comp ctyp -> + let uu___ = readback_comp_typ cfg ctyp in + FStarC_Syntax_Syntax.Comp uu___ in + FStarC_Syntax_Syntax.mk c' FStarC_Compiler_Range_Type.dummyRange +and (translate_comp_typ : + config -> + FStarC_TypeChecker_NBETerm.t Prims.list -> + FStarC_Syntax_Syntax.comp_typ -> FStarC_TypeChecker_NBETerm.comp_typ) + = + fun cfg -> + fun bs -> + fun c -> + let uu___ = c in + match uu___ with + | { FStarC_Syntax_Syntax.comp_univs = comp_univs; + FStarC_Syntax_Syntax.effect_name = effect_name; + FStarC_Syntax_Syntax.result_typ = result_typ; + FStarC_Syntax_Syntax.effect_args = effect_args; + FStarC_Syntax_Syntax.flags = flags;_} -> + let uu___1 = + FStarC_Compiler_List.map (translate_univ cfg bs) comp_univs in + let uu___2 = translate cfg bs result_typ in + let uu___3 = + FStarC_Compiler_List.map + (fun x -> + let uu___4 = + translate cfg bs (FStar_Pervasives_Native.fst x) in + (uu___4, (FStar_Pervasives_Native.snd x))) effect_args in + let uu___4 = + FStarC_Compiler_List.map (translate_flag cfg bs) flags in + { + FStarC_TypeChecker_NBETerm.comp_univs = uu___1; + FStarC_TypeChecker_NBETerm.effect_name = effect_name; + FStarC_TypeChecker_NBETerm.result_typ = uu___2; + FStarC_TypeChecker_NBETerm.effect_args = uu___3; + FStarC_TypeChecker_NBETerm.flags = uu___4 + } +and (readback_comp_typ : + config -> + FStarC_TypeChecker_NBETerm.comp_typ -> FStarC_Syntax_Syntax.comp_typ) + = + fun cfg -> + fun c -> + let uu___ = readback cfg c.FStarC_TypeChecker_NBETerm.result_typ in + let uu___1 = + FStarC_Compiler_List.map + (fun x -> + let uu___2 = readback cfg (FStar_Pervasives_Native.fst x) in + (uu___2, (FStar_Pervasives_Native.snd x))) + c.FStarC_TypeChecker_NBETerm.effect_args in + let uu___2 = + FStarC_Compiler_List.map (readback_flag cfg) + c.FStarC_TypeChecker_NBETerm.flags in + { + FStarC_Syntax_Syntax.comp_univs = + (c.FStarC_TypeChecker_NBETerm.comp_univs); + FStarC_Syntax_Syntax.effect_name = + (c.FStarC_TypeChecker_NBETerm.effect_name); + FStarC_Syntax_Syntax.result_typ = uu___; + FStarC_Syntax_Syntax.effect_args = uu___1; + FStarC_Syntax_Syntax.flags = uu___2 + } +and (translate_residual_comp : + config -> + FStarC_TypeChecker_NBETerm.t Prims.list -> + FStarC_Syntax_Syntax.residual_comp -> + FStarC_TypeChecker_NBETerm.residual_comp) + = + fun cfg -> + fun bs -> + fun c -> + let uu___ = c in + match uu___ with + | { FStarC_Syntax_Syntax.residual_effect = residual_effect; + FStarC_Syntax_Syntax.residual_typ = residual_typ; + FStarC_Syntax_Syntax.residual_flags = residual_flags;_} -> + let uu___1 = + if + ((cfg.core_cfg).FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.for_extraction + then FStar_Pervasives_Native.None + else + FStarC_Compiler_Util.map_opt residual_typ (translate cfg bs) in + let uu___2 = + FStarC_Compiler_List.map (translate_flag cfg bs) residual_flags in + { + FStarC_TypeChecker_NBETerm.residual_effect = residual_effect; + FStarC_TypeChecker_NBETerm.residual_typ = uu___1; + FStarC_TypeChecker_NBETerm.residual_flags = uu___2 + } +and (readback_residual_comp : + config -> + FStarC_TypeChecker_NBETerm.residual_comp -> + FStarC_Syntax_Syntax.residual_comp) + = + fun cfg -> + fun c -> + let uu___ = + FStarC_Compiler_Util.map_opt + c.FStarC_TypeChecker_NBETerm.residual_typ + (fun x -> + debug cfg + (fun uu___2 -> + let uu___3 = FStarC_TypeChecker_NBETerm.t_to_string x in + FStarC_Compiler_Util.print1 + "Reading back residualtype %s\n" uu___3); + readback cfg x) in + let uu___1 = + FStarC_Compiler_List.map (readback_flag cfg) + c.FStarC_TypeChecker_NBETerm.residual_flags in + { + FStarC_Syntax_Syntax.residual_effect = + (c.FStarC_TypeChecker_NBETerm.residual_effect); + FStarC_Syntax_Syntax.residual_typ = uu___; + FStarC_Syntax_Syntax.residual_flags = uu___1 + } +and (translate_flag : + config -> + FStarC_TypeChecker_NBETerm.t Prims.list -> + FStarC_Syntax_Syntax.cflag -> FStarC_TypeChecker_NBETerm.cflag) + = + fun cfg -> + fun bs -> + fun f -> + match f with + | FStarC_Syntax_Syntax.TOTAL -> FStarC_TypeChecker_NBETerm.TOTAL + | FStarC_Syntax_Syntax.MLEFFECT -> + FStarC_TypeChecker_NBETerm.MLEFFECT + | FStarC_Syntax_Syntax.RETURN -> FStarC_TypeChecker_NBETerm.RETURN + | FStarC_Syntax_Syntax.PARTIAL_RETURN -> + FStarC_TypeChecker_NBETerm.PARTIAL_RETURN + | FStarC_Syntax_Syntax.SOMETRIVIAL -> + FStarC_TypeChecker_NBETerm.SOMETRIVIAL + | FStarC_Syntax_Syntax.TRIVIAL_POSTCONDITION -> + FStarC_TypeChecker_NBETerm.TRIVIAL_POSTCONDITION + | FStarC_Syntax_Syntax.SHOULD_NOT_INLINE -> + FStarC_TypeChecker_NBETerm.SHOULD_NOT_INLINE + | FStarC_Syntax_Syntax.LEMMA -> FStarC_TypeChecker_NBETerm.LEMMA + | FStarC_Syntax_Syntax.CPS -> FStarC_TypeChecker_NBETerm.CPS + | FStarC_Syntax_Syntax.DECREASES (FStarC_Syntax_Syntax.Decreases_lex + l) -> + let uu___ = FStarC_Compiler_List.map (translate cfg bs) l in + FStarC_TypeChecker_NBETerm.DECREASES_lex uu___ + | FStarC_Syntax_Syntax.DECREASES (FStarC_Syntax_Syntax.Decreases_wf + (rel, e)) -> + let uu___ = + let uu___1 = translate cfg bs rel in + let uu___2 = translate cfg bs e in (uu___1, uu___2) in + FStarC_TypeChecker_NBETerm.DECREASES_wf uu___ +and (readback_flag : + config -> FStarC_TypeChecker_NBETerm.cflag -> FStarC_Syntax_Syntax.cflag) = + fun cfg -> + fun f -> + match f with + | FStarC_TypeChecker_NBETerm.TOTAL -> FStarC_Syntax_Syntax.TOTAL + | FStarC_TypeChecker_NBETerm.MLEFFECT -> FStarC_Syntax_Syntax.MLEFFECT + | FStarC_TypeChecker_NBETerm.RETURN -> FStarC_Syntax_Syntax.RETURN + | FStarC_TypeChecker_NBETerm.PARTIAL_RETURN -> + FStarC_Syntax_Syntax.PARTIAL_RETURN + | FStarC_TypeChecker_NBETerm.SOMETRIVIAL -> + FStarC_Syntax_Syntax.SOMETRIVIAL + | FStarC_TypeChecker_NBETerm.TRIVIAL_POSTCONDITION -> + FStarC_Syntax_Syntax.TRIVIAL_POSTCONDITION + | FStarC_TypeChecker_NBETerm.SHOULD_NOT_INLINE -> + FStarC_Syntax_Syntax.SHOULD_NOT_INLINE + | FStarC_TypeChecker_NBETerm.LEMMA -> FStarC_Syntax_Syntax.LEMMA + | FStarC_TypeChecker_NBETerm.CPS -> FStarC_Syntax_Syntax.CPS + | FStarC_TypeChecker_NBETerm.DECREASES_lex l -> + let uu___ = + let uu___1 = FStarC_Compiler_List.map (readback cfg) l in + FStarC_Syntax_Syntax.Decreases_lex uu___1 in + FStarC_Syntax_Syntax.DECREASES uu___ + | FStarC_TypeChecker_NBETerm.DECREASES_wf (rel, e) -> + let uu___ = + let uu___1 = + let uu___2 = readback cfg rel in + let uu___3 = readback cfg e in (uu___2, uu___3) in + FStarC_Syntax_Syntax.Decreases_wf uu___1 in + FStarC_Syntax_Syntax.DECREASES uu___ +and (translate_monadic : + (FStarC_Syntax_Syntax.monad_name * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax) -> + config -> + FStarC_TypeChecker_NBETerm.t Prims.list -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_TypeChecker_NBETerm.t) + = + fun uu___ -> + fun cfg -> + fun bs -> + fun e -> + match uu___ with + | (m, ty) -> + let e1 = FStarC_Syntax_Util.unascribe e in + (match e1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (false, lb::[]); + FStarC_Syntax_Syntax.body1 = body;_} + -> + let uu___1 = + let uu___2 = + FStarC_TypeChecker_Env.norm_eff_name + (cfg.core_cfg).FStarC_TypeChecker_Cfg.tcenv m in + FStarC_TypeChecker_Env.effect_decl_opt + (cfg.core_cfg).FStarC_TypeChecker_Cfg.tcenv uu___2 in + (match uu___1 with + | FStar_Pervasives_Native.None -> + let uu___2 = + let uu___3 = FStarC_Ident.string_of_lid m in + FStarC_Compiler_Util.format1 + "Effect declaration not found: %s" uu___3 in + failwith uu___2 + | FStar_Pervasives_Native.Some (ed, q) -> + let cfg' = reifying_false cfg in + let body_lam = + let body_rc = + { + FStarC_Syntax_Syntax.residual_effect = m; + FStarC_Syntax_Syntax.residual_typ = + (FStar_Pervasives_Native.Some ty); + FStarC_Syntax_Syntax.residual_flags = [] + } in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Compiler_Util.left + lb.FStarC_Syntax_Syntax.lbname in + FStarC_Syntax_Syntax.mk_binder uu___6 in + [uu___5] in + { + FStarC_Syntax_Syntax.bs = uu___4; + FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = + (FStar_Pervasives_Native.Some body_rc) + } in + FStarC_Syntax_Syntax.Tm_abs uu___3 in + FStarC_Syntax_Syntax.mk uu___2 + body.FStarC_Syntax_Syntax.pos in + let maybe_range_arg = + let uu___2 = + FStarC_Compiler_Util.for_some + (FStarC_TypeChecker_TermEqAndSimplify.eq_tm_bool + (cfg.core_cfg).FStarC_TypeChecker_Cfg.tcenv + FStarC_Syntax_Util.dm4f_bind_range_attr) + ed.FStarC_Syntax_Syntax.eff_attrs in + if uu___2 + then + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_TypeChecker_Primops_Base.embed_simple + FStarC_Syntax_Embeddings.e_range + lb.FStarC_Syntax_Syntax.lbpos + lb.FStarC_Syntax_Syntax.lbpos in + translate cfg [] uu___5 in + (uu___4, FStar_Pervasives_Native.None) in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_TypeChecker_Primops_Base.embed_simple + FStarC_Syntax_Embeddings.e_range + body.FStarC_Syntax_Syntax.pos + body.FStarC_Syntax_Syntax.pos in + translate cfg [] uu___7 in + (uu___6, FStar_Pervasives_Native.None) in + [uu___5] in + uu___3 :: uu___4 + else [] in + let t = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Syntax_Util.get_bind_repr ed in + FStarC_Compiler_Util.must uu___7 in + FStar_Pervasives_Native.snd uu___6 in + FStarC_Syntax_Util.un_uinst uu___5 in + translate cfg' [] uu___4 in + iapp cfg uu___3 + [((mk_t + (FStarC_TypeChecker_NBETerm.Univ + FStarC_Syntax_Syntax.U_unknown)), + FStar_Pervasives_Native.None); + ((mk_t + (FStarC_TypeChecker_NBETerm.Univ + FStarC_Syntax_Syntax.U_unknown)), + FStar_Pervasives_Native.None)] in + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + translate cfg' bs + lb.FStarC_Syntax_Syntax.lbtyp in + (uu___6, FStar_Pervasives_Native.None) in + let uu___6 = + let uu___7 = + let uu___8 = translate cfg' bs ty in + (uu___8, FStar_Pervasives_Native.None) in + [uu___7] in + uu___5 :: uu___6 in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + translate cfg bs + lb.FStarC_Syntax_Syntax.lbdef in + (uu___9, FStar_Pervasives_Native.None) in + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + translate cfg bs body_lam in + (uu___12, + FStar_Pervasives_Native.None) in + [uu___11] in + ((mk_t FStarC_TypeChecker_NBETerm.Unknown), + FStar_Pervasives_Native.None) :: + uu___10 in + uu___8 :: uu___9 in + ((mk_t FStarC_TypeChecker_NBETerm.Unknown), + FStar_Pervasives_Native.None) :: uu___7 in + FStarC_Compiler_List.op_At maybe_range_arg + uu___6 in + FStarC_Compiler_List.op_At uu___4 uu___5 in + iapp cfg uu___2 uu___3 in + (debug cfg + (fun uu___3 -> + let uu___4 = + FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.print1 + "translate_monadic: %s\n" uu___4); + t)) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_reflect uu___1); + FStarC_Syntax_Syntax.pos = uu___2; + FStarC_Syntax_Syntax.vars = uu___3; + FStarC_Syntax_Syntax.hash_code = uu___4;_}; + FStarC_Syntax_Syntax.args = (e2, uu___5)::[];_} + -> + let uu___6 = reifying_false cfg in translate uu___6 bs e2 + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = args;_} + -> + (debug cfg + (fun uu___2 -> + let uu___3 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head in + let uu___4 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + (FStarC_Class_Show.show_tuple2 + FStarC_Syntax_Print.showable_term + FStarC_Syntax_Print.showable_aqual)) args in + FStarC_Compiler_Util.print2 + "translate_monadic app (%s) @ (%s)\n" uu___3 + uu___4); + (let fallback1 uu___2 = translate cfg bs e1 in + let fallback2 uu___2 = + let uu___3 = reifying_false cfg in + let uu___4 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 = e1; + FStarC_Syntax_Syntax.meta = + (FStarC_Syntax_Syntax.Meta_monadic (m, ty)) + }) e1.FStarC_Syntax_Syntax.pos in + translate uu___3 bs uu___4 in + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst head in + uu___3.FStarC_Syntax_Syntax.n in + match uu___2 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let lid = FStarC_Syntax_Syntax.lid_of_fv fv in + let qninfo = + FStarC_TypeChecker_Env.lookup_qname + (cfg.core_cfg).FStarC_TypeChecker_Cfg.tcenv lid in + let uu___3 = + let uu___4 = + FStarC_TypeChecker_Env.is_action + (cfg.core_cfg).FStarC_TypeChecker_Cfg.tcenv + lid in + Prims.op_Negation uu___4 in + if uu___3 + then fallback1 () + else + (let uu___5 = + let uu___6 = + FStarC_TypeChecker_Env.lookup_definition_qninfo + (cfg.core_cfg).FStarC_TypeChecker_Cfg.delta_level + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + qninfo in + FStarC_Compiler_Option.isNone uu___6 in + if uu___5 + then fallback2 () + else + (let e2 = + let uu___7 = + FStarC_Syntax_Util.mk_reify head + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.mk_Tm_app uu___7 args + e1.FStarC_Syntax_Syntax.pos in + let uu___7 = reifying_false cfg in + translate uu___7 bs e2)) + | uu___3 -> fallback1 ())) + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = sc; + FStarC_Syntax_Syntax.ret_opt = asc_opt; + FStarC_Syntax_Syntax.brs = branches; + FStarC_Syntax_Syntax.rc_opt1 = lopt;_} + -> + let branches1 = + FStarC_Compiler_List.map + (fun uu___1 -> + match uu___1 with + | (pat, wopt, tm) -> + let uu___2 = + FStarC_Syntax_Util.mk_reify tm + (FStar_Pervasives_Native.Some m) in + (pat, wopt, uu___2)) branches in + let tm = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_match + { + FStarC_Syntax_Syntax.scrutinee = sc; + FStarC_Syntax_Syntax.ret_opt = asc_opt; + FStarC_Syntax_Syntax.brs = branches1; + FStarC_Syntax_Syntax.rc_opt1 = lopt + }) e1.FStarC_Syntax_Syntax.pos in + let uu___1 = reifying_false cfg in translate uu___1 bs tm + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_monadic uu___1;_} + -> translate_monadic (m, ty) cfg bs e1 + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_monadic_lift + (msrc, mtgt, ty');_} + -> translate_monadic_lift (msrc, mtgt, ty') cfg bs e1 + | uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Tagged.tag_of + FStarC_Syntax_Syntax.tagged_term e1 in + FStarC_Compiler_Util.format1 + "Unexpected case in translate_monadic: %s" uu___3 in + failwith uu___2) +and (translate_monadic_lift : + (FStarC_Syntax_Syntax.monad_name * FStarC_Syntax_Syntax.monad_name * + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) -> + config -> + FStarC_TypeChecker_NBETerm.t Prims.list -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_TypeChecker_NBETerm.t) + = + fun uu___ -> + fun cfg -> + fun bs -> + fun e -> + match uu___ with + | (msrc, mtgt, ty) -> + let e1 = FStarC_Syntax_Util.unascribe e in + let uu___1 = + (FStarC_Syntax_Util.is_pure_effect msrc) || + (FStarC_Syntax_Util.is_div_effect msrc) in + if uu___1 + then + let ed = + let uu___2 = + FStarC_TypeChecker_Env.norm_eff_name + (cfg.core_cfg).FStarC_TypeChecker_Cfg.tcenv mtgt in + FStarC_TypeChecker_Env.get_effect_decl + (cfg.core_cfg).FStarC_TypeChecker_Cfg.tcenv uu___2 in + let ret = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Syntax_Util.get_return_repr ed in + FStarC_Compiler_Util.must uu___6 in + FStar_Pervasives_Native.snd uu___5 in + FStarC_Syntax_Subst.compress uu___4 in + uu___3.FStarC_Syntax_Syntax.n in + match uu___2 with + | FStarC_Syntax_Syntax.Tm_uinst (ret1, uu___3::[]) -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_uinst + (ret1, [FStarC_Syntax_Syntax.U_unknown])) + e1.FStarC_Syntax_Syntax.pos + | uu___3 -> + failwith "NYI: Reification of indexed effect (NBE)" in + let cfg' = reifying_false cfg in + let t = + let uu___2 = + let uu___3 = translate cfg' [] ret in + iapp cfg' uu___3 + [((mk_t + (FStarC_TypeChecker_NBETerm.Univ + FStarC_Syntax_Syntax.U_unknown)), + FStar_Pervasives_Native.None)] in + let uu___3 = + let uu___4 = + let uu___5 = translate cfg' bs ty in + (uu___5, FStar_Pervasives_Native.None) in + let uu___5 = + let uu___6 = + let uu___7 = translate cfg' bs e1 in + (uu___7, FStar_Pervasives_Native.None) in + [uu___6] in + uu___4 :: uu___5 in + iapp cfg' uu___2 uu___3 in + (debug cfg + (fun uu___3 -> + let uu___4 = FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.print1 + "translate_monadic_lift(1): %s\n" uu___4); + t) + else + (let uu___3 = + FStarC_TypeChecker_Env.monad_leq + (cfg.core_cfg).FStarC_TypeChecker_Cfg.tcenv msrc mtgt in + match uu___3 with + | FStar_Pervasives_Native.None -> + let uu___4 = + let uu___5 = FStarC_Ident.string_of_lid msrc in + let uu___6 = FStarC_Ident.string_of_lid mtgt in + FStarC_Compiler_Util.format2 + "Impossible : trying to reify a lift between unrelated effects (%s and %s)" + uu___5 uu___6 in + failwith uu___4 + | FStar_Pervasives_Native.Some + { FStarC_TypeChecker_Env.msource = uu___4; + FStarC_TypeChecker_Env.mtarget = uu___5; + FStarC_TypeChecker_Env.mlift = + { FStarC_TypeChecker_Env.mlift_wp = uu___6; + FStarC_TypeChecker_Env.mlift_term = + FStar_Pervasives_Native.None;_}; + FStarC_TypeChecker_Env.mpath = uu___7;_} + -> + let uu___8 = + let uu___9 = FStarC_Ident.string_of_lid msrc in + let uu___10 = FStarC_Ident.string_of_lid mtgt in + FStarC_Compiler_Util.format2 + "Impossible : trying to reify a non-reifiable lift (from %s to %s)" + uu___9 uu___10 in + failwith uu___8 + | FStar_Pervasives_Native.Some + { FStarC_TypeChecker_Env.msource = uu___4; + FStarC_TypeChecker_Env.mtarget = uu___5; + FStarC_TypeChecker_Env.mlift = + { FStarC_TypeChecker_Env.mlift_wp = uu___6; + FStarC_TypeChecker_Env.mlift_term = + FStar_Pervasives_Native.Some lift;_}; + FStarC_TypeChecker_Env.mpath = uu___7;_} + -> + let lift_lam = + let x = + FStarC_Syntax_Syntax.new_bv + FStar_Pervasives_Native.None + FStarC_Syntax_Syntax.tun in + let uu___8 = + let uu___9 = FStarC_Syntax_Syntax.mk_binder x in + [uu___9] in + let uu___9 = + let uu___10 = FStarC_Syntax_Syntax.bv_to_name x in + lift FStarC_Syntax_Syntax.U_unknown ty uu___10 in + FStarC_Syntax_Util.abs uu___8 uu___9 + FStar_Pervasives_Native.None in + let cfg' = reifying_false cfg in + let t = + let uu___8 = translate cfg' [] lift_lam in + let uu___9 = + let uu___10 = + let uu___11 = translate cfg bs e1 in + (uu___11, FStar_Pervasives_Native.None) in + [uu___10] in + iapp cfg uu___8 uu___9 in + (debug cfg + (fun uu___9 -> + let uu___10 = + FStarC_TypeChecker_NBETerm.t_to_string t in + FStarC_Compiler_Util.print1 + "translate_monadic_lift(2): %s\n" uu___10); + t)) +and (readback : + config -> FStarC_TypeChecker_NBETerm.t -> FStarC_Syntax_Syntax.term) = + fun cfg -> + fun x -> + let debug1 = debug cfg in + let readback_args cfg1 args = + map_rev + (fun uu___ -> + match uu___ with + | (x1, q) -> let uu___1 = readback cfg1 x1 in (uu___1, q)) args in + let with_range t = + { + FStarC_Syntax_Syntax.n = (t.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = (x.FStarC_TypeChecker_NBETerm.nbe_r); + FStarC_Syntax_Syntax.vars = (t.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = (t.FStarC_Syntax_Syntax.hash_code) + } in + let mk t = FStarC_Syntax_Syntax.mk t x.FStarC_TypeChecker_NBETerm.nbe_r in + debug1 + (fun uu___1 -> + let uu___2 = FStarC_TypeChecker_NBETerm.t_to_string x in + FStarC_Compiler_Util.print1 "Readback: %s\n" uu___2); + (match x.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.Univ u -> + failwith "Readback of universes should not occur" + | FStarC_TypeChecker_NBETerm.Unknown -> + FStarC_Syntax_Syntax.mk FStarC_Syntax_Syntax.Tm_unknown + x.FStarC_TypeChecker_NBETerm.nbe_r + | FStarC_TypeChecker_NBETerm.Constant + (FStarC_TypeChecker_NBETerm.Unit) -> + with_range FStarC_Syntax_Syntax.unit_const + | FStarC_TypeChecker_NBETerm.Constant (FStarC_TypeChecker_NBETerm.Bool + (true)) -> with_range FStarC_Syntax_Util.exp_true_bool + | FStarC_TypeChecker_NBETerm.Constant (FStarC_TypeChecker_NBETerm.Bool + (false)) -> with_range FStarC_Syntax_Util.exp_false_bool + | FStarC_TypeChecker_NBETerm.Constant (FStarC_TypeChecker_NBETerm.Int + i) -> + let uu___1 = + let uu___2 = FStarC_BigInt.string_of_big_int i in + FStarC_Syntax_Util.exp_int uu___2 in + with_range uu___1 + | FStarC_TypeChecker_NBETerm.Constant + (FStarC_TypeChecker_NBETerm.String (s, r)) -> + mk + (FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_string (s, r))) + | FStarC_TypeChecker_NBETerm.Constant (FStarC_TypeChecker_NBETerm.Char + c) -> + let uu___1 = FStarC_Syntax_Util.exp_char c in with_range uu___1 + | FStarC_TypeChecker_NBETerm.Constant + (FStarC_TypeChecker_NBETerm.Range r) -> + FStarC_TypeChecker_Primops_Base.embed_simple + FStarC_Syntax_Embeddings.e___range + x.FStarC_TypeChecker_NBETerm.nbe_r r + | FStarC_TypeChecker_NBETerm.Constant (FStarC_TypeChecker_NBETerm.Real + r) -> + FStarC_TypeChecker_Primops_Base.embed_simple + FStarC_Syntax_Embeddings.e_real + x.FStarC_TypeChecker_NBETerm.nbe_r (FStarC_Compiler_Real.Real r) + | FStarC_TypeChecker_NBETerm.Constant + (FStarC_TypeChecker_NBETerm.SConst c) -> + mk (FStarC_Syntax_Syntax.Tm_constant c) + | FStarC_TypeChecker_NBETerm.Meta (t, m) -> + let uu___1 = + let uu___2 = + let uu___3 = readback cfg t in + let uu___4 = FStarC_Thunk.force m in + { + FStarC_Syntax_Syntax.tm2 = uu___3; + FStarC_Syntax_Syntax.meta = uu___4 + } in + FStarC_Syntax_Syntax.Tm_meta uu___2 in + mk uu___1 + | FStarC_TypeChecker_NBETerm.Type_t u -> + mk (FStarC_Syntax_Syntax.Tm_type u) + | FStarC_TypeChecker_NBETerm.Lam + { FStarC_TypeChecker_NBETerm.interp = f; + FStarC_TypeChecker_NBETerm.shape = shape; + FStarC_TypeChecker_NBETerm.arity = arity;_} + -> + (match shape with + | FStarC_TypeChecker_NBETerm.Lam_bs (ctx, binders, rc) -> + let uu___1 = + FStarC_Compiler_List.fold_left + (fun uu___2 -> + fun b -> + match uu___2 with + | (ctx1, binders_rev, accus_rev) -> + let x1 = b.FStarC_Syntax_Syntax.binder_bv in + let tnorm = + let uu___3 = + translate cfg ctx1 + x1.FStarC_Syntax_Syntax.sort in + readback cfg uu___3 in + let x2 = + let uu___3 = + FStarC_Syntax_Syntax.freshen_bv x1 in + { + FStarC_Syntax_Syntax.ppname = + (uu___3.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (uu___3.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = tnorm + } in + let ax = FStarC_TypeChecker_NBETerm.mkAccuVar x2 in + let ctx2 = ax :: ctx1 in + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Syntax_Util.aqual_of_binder b in + (ax, uu___5) in + uu___4 :: accus_rev in + (ctx2, + ({ + FStarC_Syntax_Syntax.binder_bv = x2; + FStarC_Syntax_Syntax.binder_qual = + (b.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity = + (b.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs = + (b.FStarC_Syntax_Syntax.binder_attrs) + } :: binders_rev), uu___3)) (ctx, [], []) + binders in + (match uu___1 with + | (ctx1, binders_rev, accus_rev) -> + let rc1 = + match rc with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some rc2 -> + let uu___2 = + let uu___3 = + translate_residual_comp cfg ctx1 rc2 in + readback_residual_comp cfg uu___3 in + FStar_Pervasives_Native.Some uu___2 in + let binders1 = FStarC_Compiler_List.rev binders_rev in + let body = + let uu___2 = f accus_rev in readback cfg uu___2 in + let uu___2 = FStarC_Syntax_Util.abs binders1 body rc1 in + with_range uu___2) + | FStarC_TypeChecker_NBETerm.Lam_args args -> + let uu___1 = + FStarC_Compiler_List.fold_right + (fun uu___2 -> + fun uu___3 -> + match (uu___2, uu___3) with + | ((t, aq), (binders, accus)) -> + let uu___4 = + FStarC_Syntax_Util.bqual_and_attrs_of_aqual aq in + (match uu___4 with + | (bqual, battrs) -> + let uu___5 = + FStarC_Syntax_Util.parse_positivity_attributes + battrs in + (match uu___5 with + | (pqual, battrs1) -> + let x1 = + let uu___6 = readback cfg t in + FStarC_Syntax_Syntax.new_bv + FStar_Pervasives_Native.None + uu___6 in + let uu___6 = + let uu___7 = + FStarC_Syntax_Syntax.mk_binder_with_attrs + x1 bqual pqual battrs1 in + uu___7 :: binders in + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_TypeChecker_NBETerm.mkAccuVar + x1 in + (uu___9, aq) in + uu___8 :: accus in + (uu___6, uu___7)))) args ([], []) in + (match uu___1 with + | (binders, accus_rev) -> + let accus = FStarC_Compiler_List.rev accus_rev in + let rc = FStar_Pervasives_Native.None in + let body = + let uu___2 = f accus_rev in readback cfg uu___2 in + let uu___2 = FStarC_Syntax_Util.abs binders body rc in + with_range uu___2) + | FStarC_TypeChecker_NBETerm.Lam_primop (fv, args) -> + let body = + let uu___1 = + let uu___2 = FStarC_Syntax_Syntax.range_of_fv fv in + FStarC_Syntax_Syntax.mk (FStarC_Syntax_Syntax.Tm_fvar fv) + uu___2 in + let uu___2 = readback_args cfg args in + FStarC_Syntax_Util.mk_app uu___1 uu___2 in + with_range body) + | FStarC_TypeChecker_NBETerm.Refinement (f, targ) -> + if + ((cfg.core_cfg).FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.for_extraction + then + let uu___1 = + let uu___2 = targ () in FStar_Pervasives_Native.fst uu___2 in + readback cfg uu___1 + else + (let x1 = + let uu___2 = + let uu___3 = + let uu___4 = targ () in + FStar_Pervasives_Native.fst uu___4 in + readback cfg uu___3 in + FStarC_Syntax_Syntax.new_bv FStar_Pervasives_Native.None + uu___2 in + let body = + let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.mkAccuVar x1 in + f uu___3 in + readback cfg uu___2 in + let refinement = FStarC_Syntax_Util.refine x1 body in + let uu___2 = + if + ((cfg.core_cfg).FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.simplify + then + FStarC_TypeChecker_TermEqAndSimplify.simplify + ((cfg.core_cfg).FStarC_TypeChecker_Cfg.debug).FStarC_TypeChecker_Cfg.wpe + (cfg.core_cfg).FStarC_TypeChecker_Cfg.tcenv refinement + else refinement in + with_range uu___2) + | FStarC_TypeChecker_NBETerm.Reflect t -> + let tm = readback cfg t in + let uu___1 = FStarC_Syntax_Util.mk_reflect tm in with_range uu___1 + | FStarC_TypeChecker_NBETerm.Arrow (FStar_Pervasives.Inl f) -> + let uu___1 = FStarC_Thunk.force f in with_range uu___1 + | FStarC_TypeChecker_NBETerm.Arrow (FStar_Pervasives.Inr (args, c)) -> + let binders = + FStarC_Compiler_List.map + (fun uu___1 -> + match uu___1 with + | (t, q) -> + let t1 = readback cfg t in + let x1 = + FStarC_Syntax_Syntax.new_bv + FStar_Pervasives_Native.None t1 in + let uu___2 = + FStarC_Syntax_Util.bqual_and_attrs_of_aqual q in + (match uu___2 with + | (q1, attrs) -> + let uu___3 = + FStarC_Syntax_Util.parse_positivity_attributes + attrs in + (match uu___3 with + | (pqual, attrs1) -> + FStarC_Syntax_Syntax.mk_binder_with_attrs x1 + q1 pqual attrs1))) args in + let c1 = readback_comp cfg c in + let uu___1 = FStarC_Syntax_Util.arrow binders c1 in + with_range uu___1 + | FStarC_TypeChecker_NBETerm.Construct (fv, us, args) -> + let args1 = + map_rev + (fun uu___1 -> + match uu___1 with + | (x1, q) -> let uu___2 = readback cfg x1 in (uu___2, q)) + args in + let fv1 = + let uu___1 = FStarC_Syntax_Syntax.range_of_fv fv in + FStarC_Syntax_Syntax.mk (FStarC_Syntax_Syntax.Tm_fvar fv) uu___1 in + let app = + let uu___1 = + FStarC_Syntax_Syntax.mk_Tm_uinst fv1 + (FStarC_Compiler_List.rev us) in + FStarC_Syntax_Util.mk_app uu___1 args1 in + with_range app + | FStarC_TypeChecker_NBETerm.FV (fv, us, args) -> + let args1 = + map_rev + (fun uu___1 -> + match uu___1 with + | (x1, q) -> let uu___2 = readback cfg x1 in (uu___2, q)) + args in + let fv1 = + FStarC_Syntax_Syntax.mk (FStarC_Syntax_Syntax.Tm_fvar fv) + FStarC_Compiler_Range_Type.dummyRange in + let app = + let uu___1 = + FStarC_Syntax_Syntax.mk_Tm_uinst fv1 + (FStarC_Compiler_List.rev us) in + FStarC_Syntax_Util.mk_app uu___1 args1 in + let uu___1 = + if + ((cfg.core_cfg).FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.simplify + then + FStarC_TypeChecker_TermEqAndSimplify.simplify + ((cfg.core_cfg).FStarC_TypeChecker_Cfg.debug).FStarC_TypeChecker_Cfg.wpe + (cfg.core_cfg).FStarC_TypeChecker_Cfg.tcenv app + else app in + with_range uu___1 + | FStarC_TypeChecker_NBETerm.Accu + (FStarC_TypeChecker_NBETerm.Var bv, []) -> + let uu___1 = FStarC_Syntax_Syntax.bv_to_name bv in + with_range uu___1 + | FStarC_TypeChecker_NBETerm.Accu + (FStarC_TypeChecker_NBETerm.Var bv, args) -> + let args1 = readback_args cfg args in + let app = + let uu___1 = FStarC_Syntax_Syntax.bv_to_name bv in + FStarC_Syntax_Util.mk_app uu___1 args1 in + let uu___1 = + if + ((cfg.core_cfg).FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.simplify + then + FStarC_TypeChecker_TermEqAndSimplify.simplify + ((cfg.core_cfg).FStarC_TypeChecker_Cfg.debug).FStarC_TypeChecker_Cfg.wpe + (cfg.core_cfg).FStarC_TypeChecker_Cfg.tcenv app + else app in + with_range uu___1 + | FStarC_TypeChecker_NBETerm.Accu + (FStarC_TypeChecker_NBETerm.Match + (scrut, make_returns, make_branches, make_rc), args) + -> + let args1 = readback_args cfg args in + let head = + let scrut_new = readback cfg scrut in + let returns_new = make_returns () in + let branches_new = make_branches () in + let rc_new = make_rc () in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_match + { + FStarC_Syntax_Syntax.scrutinee = scrut_new; + FStarC_Syntax_Syntax.ret_opt = returns_new; + FStarC_Syntax_Syntax.brs = branches_new; + FStarC_Syntax_Syntax.rc_opt1 = rc_new + }) scrut.FStarC_TypeChecker_NBETerm.nbe_r in + let app = FStarC_Syntax_Util.mk_app head args1 in + let uu___1 = + if + ((cfg.core_cfg).FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.simplify + then + FStarC_TypeChecker_TermEqAndSimplify.simplify + ((cfg.core_cfg).FStarC_TypeChecker_Cfg.debug).FStarC_TypeChecker_Cfg.wpe + (cfg.core_cfg).FStarC_TypeChecker_Cfg.tcenv app + else app in + with_range uu___1 + | FStarC_TypeChecker_NBETerm.Accu + (FStarC_TypeChecker_NBETerm.UnreducedLet + (var, typ, defn, body, lb), args) + -> + let typ1 = + let uu___1 = FStarC_Thunk.force typ in readback cfg uu___1 in + let defn1 = + let uu___1 = FStarC_Thunk.force defn in readback cfg uu___1 in + let body1 = + let uu___1 = + let uu___2 = FStarC_Syntax_Syntax.mk_binder var in [uu___2] in + let uu___2 = + let uu___3 = FStarC_Thunk.force body in readback cfg uu___3 in + FStarC_Syntax_Subst.close uu___1 uu___2 in + let lbname = + let uu___1 = + let uu___2 = + FStarC_Compiler_Util.left lb.FStarC_Syntax_Syntax.lbname in + { + FStarC_Syntax_Syntax.ppname = + (uu___2.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (uu___2.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = typ1 + } in + FStar_Pervasives.Inl uu___1 in + let lb1 = + { + FStarC_Syntax_Syntax.lbname = lbname; + FStarC_Syntax_Syntax.lbunivs = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = typ1; + FStarC_Syntax_Syntax.lbeff = (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = defn1; + FStarC_Syntax_Syntax.lbattrs = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = (lb.FStarC_Syntax_Syntax.lbpos) + } in + let hd = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = (false, [lb1]); + FStarC_Syntax_Syntax.body1 = body1 + }) FStarC_Compiler_Range_Type.dummyRange in + let args1 = readback_args cfg args in + let uu___1 = FStarC_Syntax_Util.mk_app hd args1 in + with_range uu___1 + | FStarC_TypeChecker_NBETerm.Accu + (FStarC_TypeChecker_NBETerm.UnreducedLetRec + (vars_typs_defns, body, lbs), args) + -> + let lbs1 = + FStarC_Compiler_List.map2 + (fun uu___1 -> + fun lb -> + match uu___1 with + | (v, t, d) -> + let t1 = readback cfg t in + let def = readback cfg d in + let v1 = + { + FStarC_Syntax_Syntax.ppname = + (v.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (v.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = t1 + } in + { + FStarC_Syntax_Syntax.lbname = + (FStar_Pervasives.Inl v1); + FStarC_Syntax_Syntax.lbunivs = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = t1; + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = def; + FStarC_Syntax_Syntax.lbattrs = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + }) vars_typs_defns lbs in + let body1 = readback cfg body in + let uu___1 = FStarC_Syntax_Subst.close_let_rec lbs1 body1 in + (match uu___1 with + | (lbs2, body2) -> + let hd = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = (true, lbs2); + FStarC_Syntax_Syntax.body1 = body2 + }) FStarC_Compiler_Range_Type.dummyRange in + let args1 = readback_args cfg args in + let uu___2 = FStarC_Syntax_Util.mk_app hd args1 in + with_range uu___2) + | FStarC_TypeChecker_NBETerm.Accu + (FStarC_TypeChecker_NBETerm.UVar f, args) -> + let hd = FStarC_Thunk.force f in + let args1 = readback_args cfg args in + let uu___1 = FStarC_Syntax_Util.mk_app hd args1 in + with_range uu___1 + | FStarC_TypeChecker_NBETerm.TopLevelLet (lb, arity, args_rev) -> + let n_univs = + FStarC_Compiler_List.length lb.FStarC_Syntax_Syntax.lbunivs in + let n_args = FStarC_Compiler_List.length args_rev in + let uu___1 = + FStarC_Compiler_Util.first_N (n_args - n_univs) args_rev in + (match uu___1 with + | (args_rev1, univs) -> + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Compiler_List.map FStar_Pervasives_Native.fst + univs in + translate cfg uu___4 lb.FStarC_Syntax_Syntax.lbdef in + iapp cfg uu___3 (FStarC_Compiler_List.rev args_rev1) in + readback cfg uu___2) + | FStarC_TypeChecker_NBETerm.TopLevelRec (lb, uu___1, uu___2, args) -> + let fv = FStarC_Compiler_Util.right lb.FStarC_Syntax_Syntax.lbname in + let head = + FStarC_Syntax_Syntax.mk (FStarC_Syntax_Syntax.Tm_fvar fv) + FStarC_Compiler_Range_Type.dummyRange in + let args1 = + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with + | (t, q) -> let uu___4 = readback cfg t in (uu___4, q)) + args in + let uu___3 = FStarC_Syntax_Util.mk_app head args1 in + with_range uu___3 + | FStarC_TypeChecker_NBETerm.LocalLetRec + (i, uu___1, lbs, bs, args, _ar, _ar_lst) -> + let lbnames = + FStarC_Compiler_List.map + (fun lb -> + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Compiler_Util.left + lb.FStarC_Syntax_Syntax.lbname in + uu___4.FStarC_Syntax_Syntax.ppname in + FStarC_Ident.string_of_id uu___3 in + FStarC_Syntax_Syntax.gen_bv uu___2 + FStar_Pervasives_Native.None + lb.FStarC_Syntax_Syntax.lbtyp) lbs in + let let_rec_env = + let uu___2 = + FStarC_Compiler_List.map + (fun x1 -> + let uu___3 = FStarC_Syntax_Syntax.range_of_bv x1 in + mk_rt uu___3 + (FStarC_TypeChecker_NBETerm.Accu + ((FStarC_TypeChecker_NBETerm.Var x1), []))) lbnames in + FStarC_Compiler_List.rev_append uu___2 bs in + let lbs1 = + FStarC_Compiler_List.map2 + (fun lb -> + fun lbname -> + let lbdef = + let uu___2 = + translate cfg let_rec_env + lb.FStarC_Syntax_Syntax.lbdef in + readback cfg uu___2 in + let lbtyp = + let uu___2 = + translate cfg bs lb.FStarC_Syntax_Syntax.lbtyp in + readback cfg uu___2 in + { + FStarC_Syntax_Syntax.lbname = + (FStar_Pervasives.Inl lbname); + FStarC_Syntax_Syntax.lbunivs = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = lbtyp; + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = lbdef; + FStarC_Syntax_Syntax.lbattrs = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + }) lbs lbnames in + let body = + let uu___2 = FStarC_Compiler_List.nth lbnames i in + FStarC_Syntax_Syntax.bv_to_name uu___2 in + let uu___2 = FStarC_Syntax_Subst.close_let_rec lbs1 body in + (match uu___2 with + | (lbs2, body1) -> + let head = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = (true, lbs2); + FStarC_Syntax_Syntax.body1 = body1 + }) FStarC_Compiler_Range_Type.dummyRange in + let args1 = + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with + | (x1, q) -> + let uu___4 = readback cfg x1 in (uu___4, q)) args in + let uu___3 = FStarC_Syntax_Util.mk_app head args1 in + with_range uu___3) + | FStarC_TypeChecker_NBETerm.Quote (qt, qi) -> + mk (FStarC_Syntax_Syntax.Tm_quoted (qt, qi)) + | FStarC_TypeChecker_NBETerm.Lazy (FStar_Pervasives.Inl li, uu___1) -> + mk (FStarC_Syntax_Syntax.Tm_lazy li) + | FStarC_TypeChecker_NBETerm.Lazy (uu___1, thunk) -> + let uu___2 = FStarC_Thunk.force thunk in readback cfg uu___2) +let (reduce_application : + FStarC_TypeChecker_Cfg.cfg -> + FStarC_TypeChecker_NBETerm.t -> + FStarC_TypeChecker_NBETerm.args -> FStarC_TypeChecker_NBETerm.t) + = + fun cfg -> + fun t -> fun args -> let uu___ = new_config cfg in iapp uu___ t args +let (normalize : + FStarC_TypeChecker_Primops_Base.primitive_step Prims.list -> + FStarC_TypeChecker_Env.step Prims.list -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun psteps -> + fun steps -> + fun env -> + fun e -> + let cfg = FStarC_TypeChecker_Cfg.config' psteps steps env in + let cfg1 = + { + FStarC_TypeChecker_Cfg.steps = + (let uu___ = cfg.FStarC_TypeChecker_Cfg.steps in + { + FStarC_TypeChecker_Cfg.beta = + (uu___.FStarC_TypeChecker_Cfg.beta); + FStarC_TypeChecker_Cfg.iota = + (uu___.FStarC_TypeChecker_Cfg.iota); + FStarC_TypeChecker_Cfg.zeta = + (uu___.FStarC_TypeChecker_Cfg.zeta); + FStarC_TypeChecker_Cfg.zeta_full = + (uu___.FStarC_TypeChecker_Cfg.zeta_full); + FStarC_TypeChecker_Cfg.weak = + (uu___.FStarC_TypeChecker_Cfg.weak); + FStarC_TypeChecker_Cfg.hnf = + (uu___.FStarC_TypeChecker_Cfg.hnf); + FStarC_TypeChecker_Cfg.primops = + (uu___.FStarC_TypeChecker_Cfg.primops); + FStarC_TypeChecker_Cfg.do_not_unfold_pure_lets = + (uu___.FStarC_TypeChecker_Cfg.do_not_unfold_pure_lets); + FStarC_TypeChecker_Cfg.unfold_until = + (uu___.FStarC_TypeChecker_Cfg.unfold_until); + FStarC_TypeChecker_Cfg.unfold_only = + (uu___.FStarC_TypeChecker_Cfg.unfold_only); + FStarC_TypeChecker_Cfg.unfold_fully = + (uu___.FStarC_TypeChecker_Cfg.unfold_fully); + FStarC_TypeChecker_Cfg.unfold_attr = + (uu___.FStarC_TypeChecker_Cfg.unfold_attr); + FStarC_TypeChecker_Cfg.unfold_qual = + (uu___.FStarC_TypeChecker_Cfg.unfold_qual); + FStarC_TypeChecker_Cfg.unfold_namespace = + (uu___.FStarC_TypeChecker_Cfg.unfold_namespace); + FStarC_TypeChecker_Cfg.dont_unfold_attr = + (uu___.FStarC_TypeChecker_Cfg.dont_unfold_attr); + FStarC_TypeChecker_Cfg.pure_subterms_within_computations = + (uu___.FStarC_TypeChecker_Cfg.pure_subterms_within_computations); + FStarC_TypeChecker_Cfg.simplify = + (uu___.FStarC_TypeChecker_Cfg.simplify); + FStarC_TypeChecker_Cfg.erase_universes = + (uu___.FStarC_TypeChecker_Cfg.erase_universes); + FStarC_TypeChecker_Cfg.allow_unbound_universes = + (uu___.FStarC_TypeChecker_Cfg.allow_unbound_universes); + FStarC_TypeChecker_Cfg.reify_ = true; + FStarC_TypeChecker_Cfg.compress_uvars = + (uu___.FStarC_TypeChecker_Cfg.compress_uvars); + FStarC_TypeChecker_Cfg.no_full_norm = + (uu___.FStarC_TypeChecker_Cfg.no_full_norm); + FStarC_TypeChecker_Cfg.check_no_uvars = + (uu___.FStarC_TypeChecker_Cfg.check_no_uvars); + FStarC_TypeChecker_Cfg.unmeta = + (uu___.FStarC_TypeChecker_Cfg.unmeta); + FStarC_TypeChecker_Cfg.unascribe = + (uu___.FStarC_TypeChecker_Cfg.unascribe); + FStarC_TypeChecker_Cfg.in_full_norm_request = + (uu___.FStarC_TypeChecker_Cfg.in_full_norm_request); + FStarC_TypeChecker_Cfg.weakly_reduce_scrutinee = + (uu___.FStarC_TypeChecker_Cfg.weakly_reduce_scrutinee); + FStarC_TypeChecker_Cfg.nbe_step = + (uu___.FStarC_TypeChecker_Cfg.nbe_step); + FStarC_TypeChecker_Cfg.for_extraction = + (uu___.FStarC_TypeChecker_Cfg.for_extraction); + FStarC_TypeChecker_Cfg.unrefine = + (uu___.FStarC_TypeChecker_Cfg.unrefine); + FStarC_TypeChecker_Cfg.default_univs_to_zero = + (uu___.FStarC_TypeChecker_Cfg.default_univs_to_zero); + FStarC_TypeChecker_Cfg.tactics = + (uu___.FStarC_TypeChecker_Cfg.tactics) + }); + FStarC_TypeChecker_Cfg.tcenv = + (cfg.FStarC_TypeChecker_Cfg.tcenv); + FStarC_TypeChecker_Cfg.debug = + (cfg.FStarC_TypeChecker_Cfg.debug); + FStarC_TypeChecker_Cfg.delta_level = + (cfg.FStarC_TypeChecker_Cfg.delta_level); + FStarC_TypeChecker_Cfg.primitive_steps = + (cfg.FStarC_TypeChecker_Cfg.primitive_steps); + FStarC_TypeChecker_Cfg.strong = + (cfg.FStarC_TypeChecker_Cfg.strong); + FStarC_TypeChecker_Cfg.memoize_lazy = + (cfg.FStarC_TypeChecker_Cfg.memoize_lazy); + FStarC_TypeChecker_Cfg.normalize_pure_lets = + (cfg.FStarC_TypeChecker_Cfg.normalize_pure_lets); + FStarC_TypeChecker_Cfg.reifying = + (cfg.FStarC_TypeChecker_Cfg.reifying); + FStarC_TypeChecker_Cfg.compat_memo_ignore_cfg = + (cfg.FStarC_TypeChecker_Cfg.compat_memo_ignore_cfg) + } in + (let uu___1 = + (FStarC_Compiler_Effect.op_Bang dbg_NBETop) || + (FStarC_Compiler_Effect.op_Bang dbg_NBE) in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + FStarC_Compiler_Util.print1 "Calling NBE with (%s) {\n" uu___2 + else ()); + (let cfg2 = new_config cfg1 in + let r = let uu___1 = translate cfg2 [] e in readback cfg2 uu___1 in + (let uu___2 = + (FStarC_Compiler_Effect.op_Bang dbg_NBETop) || + (FStarC_Compiler_Effect.op_Bang dbg_NBE) in + if uu___2 + then + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term r in + FStarC_Compiler_Util.print1 "}\nNBE returned (%s)\n" uu___3 + else ()); + r) +let (normalize_for_unit_test : + FStarC_TypeChecker_Env.step Prims.list -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun steps -> + fun env -> + fun e -> + let cfg = FStarC_TypeChecker_Cfg.config steps env in + let cfg1 = + { + FStarC_TypeChecker_Cfg.steps = + (let uu___ = cfg.FStarC_TypeChecker_Cfg.steps in + { + FStarC_TypeChecker_Cfg.beta = + (uu___.FStarC_TypeChecker_Cfg.beta); + FStarC_TypeChecker_Cfg.iota = + (uu___.FStarC_TypeChecker_Cfg.iota); + FStarC_TypeChecker_Cfg.zeta = + (uu___.FStarC_TypeChecker_Cfg.zeta); + FStarC_TypeChecker_Cfg.zeta_full = + (uu___.FStarC_TypeChecker_Cfg.zeta_full); + FStarC_TypeChecker_Cfg.weak = + (uu___.FStarC_TypeChecker_Cfg.weak); + FStarC_TypeChecker_Cfg.hnf = + (uu___.FStarC_TypeChecker_Cfg.hnf); + FStarC_TypeChecker_Cfg.primops = + (uu___.FStarC_TypeChecker_Cfg.primops); + FStarC_TypeChecker_Cfg.do_not_unfold_pure_lets = + (uu___.FStarC_TypeChecker_Cfg.do_not_unfold_pure_lets); + FStarC_TypeChecker_Cfg.unfold_until = + (uu___.FStarC_TypeChecker_Cfg.unfold_until); + FStarC_TypeChecker_Cfg.unfold_only = + (uu___.FStarC_TypeChecker_Cfg.unfold_only); + FStarC_TypeChecker_Cfg.unfold_fully = + (uu___.FStarC_TypeChecker_Cfg.unfold_fully); + FStarC_TypeChecker_Cfg.unfold_attr = + (uu___.FStarC_TypeChecker_Cfg.unfold_attr); + FStarC_TypeChecker_Cfg.unfold_qual = + (uu___.FStarC_TypeChecker_Cfg.unfold_qual); + FStarC_TypeChecker_Cfg.unfold_namespace = + (uu___.FStarC_TypeChecker_Cfg.unfold_namespace); + FStarC_TypeChecker_Cfg.dont_unfold_attr = + (uu___.FStarC_TypeChecker_Cfg.dont_unfold_attr); + FStarC_TypeChecker_Cfg.pure_subterms_within_computations = + (uu___.FStarC_TypeChecker_Cfg.pure_subterms_within_computations); + FStarC_TypeChecker_Cfg.simplify = + (uu___.FStarC_TypeChecker_Cfg.simplify); + FStarC_TypeChecker_Cfg.erase_universes = + (uu___.FStarC_TypeChecker_Cfg.erase_universes); + FStarC_TypeChecker_Cfg.allow_unbound_universes = + (uu___.FStarC_TypeChecker_Cfg.allow_unbound_universes); + FStarC_TypeChecker_Cfg.reify_ = true; + FStarC_TypeChecker_Cfg.compress_uvars = + (uu___.FStarC_TypeChecker_Cfg.compress_uvars); + FStarC_TypeChecker_Cfg.no_full_norm = + (uu___.FStarC_TypeChecker_Cfg.no_full_norm); + FStarC_TypeChecker_Cfg.check_no_uvars = + (uu___.FStarC_TypeChecker_Cfg.check_no_uvars); + FStarC_TypeChecker_Cfg.unmeta = + (uu___.FStarC_TypeChecker_Cfg.unmeta); + FStarC_TypeChecker_Cfg.unascribe = + (uu___.FStarC_TypeChecker_Cfg.unascribe); + FStarC_TypeChecker_Cfg.in_full_norm_request = + (uu___.FStarC_TypeChecker_Cfg.in_full_norm_request); + FStarC_TypeChecker_Cfg.weakly_reduce_scrutinee = + (uu___.FStarC_TypeChecker_Cfg.weakly_reduce_scrutinee); + FStarC_TypeChecker_Cfg.nbe_step = + (uu___.FStarC_TypeChecker_Cfg.nbe_step); + FStarC_TypeChecker_Cfg.for_extraction = + (uu___.FStarC_TypeChecker_Cfg.for_extraction); + FStarC_TypeChecker_Cfg.unrefine = + (uu___.FStarC_TypeChecker_Cfg.unrefine); + FStarC_TypeChecker_Cfg.default_univs_to_zero = + (uu___.FStarC_TypeChecker_Cfg.default_univs_to_zero); + FStarC_TypeChecker_Cfg.tactics = + (uu___.FStarC_TypeChecker_Cfg.tactics) + }); + FStarC_TypeChecker_Cfg.tcenv = (cfg.FStarC_TypeChecker_Cfg.tcenv); + FStarC_TypeChecker_Cfg.debug = (cfg.FStarC_TypeChecker_Cfg.debug); + FStarC_TypeChecker_Cfg.delta_level = + (cfg.FStarC_TypeChecker_Cfg.delta_level); + FStarC_TypeChecker_Cfg.primitive_steps = + (cfg.FStarC_TypeChecker_Cfg.primitive_steps); + FStarC_TypeChecker_Cfg.strong = + (cfg.FStarC_TypeChecker_Cfg.strong); + FStarC_TypeChecker_Cfg.memoize_lazy = + (cfg.FStarC_TypeChecker_Cfg.memoize_lazy); + FStarC_TypeChecker_Cfg.normalize_pure_lets = + (cfg.FStarC_TypeChecker_Cfg.normalize_pure_lets); + FStarC_TypeChecker_Cfg.reifying = + (cfg.FStarC_TypeChecker_Cfg.reifying); + FStarC_TypeChecker_Cfg.compat_memo_ignore_cfg = + (cfg.FStarC_TypeChecker_Cfg.compat_memo_ignore_cfg) + } in + let cfg2 = new_config cfg1 in + debug cfg2 + (fun uu___1 -> + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + FStarC_Compiler_Util.print1 "Calling NBE with (%s) {\n" uu___2); + (let r = let uu___1 = translate cfg2 [] e in readback cfg2 uu___1 in + debug cfg2 + (fun uu___2 -> + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term r in + FStarC_Compiler_Util.print1 "}\nNBE returned (%s)\n" uu___3); + r) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_NBETerm.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_NBETerm.ml new file mode 100644 index 00000000000..714f4299e20 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_NBETerm.ml @@ -0,0 +1,2563 @@ +open Prims +let (interleave_hack : Prims.int) = (Prims.of_int (123)) +type var = FStarC_Syntax_Syntax.bv +type sort = Prims.int +type constant = + | Unit + | Bool of Prims.bool + | Int of FStarC_BigInt.t + | String of (Prims.string * FStarC_Compiler_Range_Type.range) + | Char of FStar_Char.char + | Range of FStarC_Compiler_Range_Type.range + | SConst of FStarC_Const.sconst + | Real of Prims.string +let (uu___is_Unit : constant -> Prims.bool) = + fun projectee -> match projectee with | Unit -> true | uu___ -> false +let (uu___is_Bool : constant -> Prims.bool) = + fun projectee -> match projectee with | Bool _0 -> true | uu___ -> false +let (__proj__Bool__item___0 : constant -> Prims.bool) = + fun projectee -> match projectee with | Bool _0 -> _0 +let (uu___is_Int : constant -> Prims.bool) = + fun projectee -> match projectee with | Int _0 -> true | uu___ -> false +let (__proj__Int__item___0 : constant -> FStarC_BigInt.t) = + fun projectee -> match projectee with | Int _0 -> _0 +let (uu___is_String : constant -> Prims.bool) = + fun projectee -> match projectee with | String _0 -> true | uu___ -> false +let (__proj__String__item___0 : + constant -> (Prims.string * FStarC_Compiler_Range_Type.range)) = + fun projectee -> match projectee with | String _0 -> _0 +let (uu___is_Char : constant -> Prims.bool) = + fun projectee -> match projectee with | Char _0 -> true | uu___ -> false +let (__proj__Char__item___0 : constant -> FStar_Char.char) = + fun projectee -> match projectee with | Char _0 -> _0 +let (uu___is_Range : constant -> Prims.bool) = + fun projectee -> match projectee with | Range _0 -> true | uu___ -> false +let (__proj__Range__item___0 : constant -> FStarC_Compiler_Range_Type.range) + = fun projectee -> match projectee with | Range _0 -> _0 +let (uu___is_SConst : constant -> Prims.bool) = + fun projectee -> match projectee with | SConst _0 -> true | uu___ -> false +let (__proj__SConst__item___0 : constant -> FStarC_Const.sconst) = + fun projectee -> match projectee with | SConst _0 -> _0 +let (uu___is_Real : constant -> Prims.bool) = + fun projectee -> match projectee with | Real _0 -> true | uu___ -> false +let (__proj__Real__item___0 : constant -> Prims.string) = + fun projectee -> match projectee with | Real _0 -> _0 +type atom = + | Var of var + | Match of (t * + (unit -> + FStarC_Syntax_Syntax.match_returns_ascription + FStar_Pervasives_Native.option) + * (unit -> FStarC_Syntax_Syntax.branch Prims.list) * + (unit -> FStarC_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option)) + + | UnreducedLet of (var * t FStarC_Thunk.t * t FStarC_Thunk.t * t + FStarC_Thunk.t * FStarC_Syntax_Syntax.letbinding) + | UnreducedLetRec of ((var * t * t) Prims.list * t * + FStarC_Syntax_Syntax.letbinding Prims.list) + | UVar of FStarC_Syntax_Syntax.term FStarC_Thunk.t +and lam_shape = + | Lam_bs of (t Prims.list * FStarC_Syntax_Syntax.binders * + FStarC_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option) + | Lam_args of (t * FStarC_Syntax_Syntax.aqual) Prims.list + | Lam_primop of (FStarC_Syntax_Syntax.fv * (t * FStarC_Syntax_Syntax.aqual) + Prims.list) +and t'__Lam__payload = + { + interp: (t * FStarC_Syntax_Syntax.aqual) Prims.list -> t ; + shape: lam_shape ; + arity: Prims.int } +and t' = + | Lam of t'__Lam__payload + | Accu of (atom * (t * FStarC_Syntax_Syntax.aqual) Prims.list) + | Construct of (FStarC_Syntax_Syntax.fv * FStarC_Syntax_Syntax.universe + Prims.list * (t * FStarC_Syntax_Syntax.aqual) Prims.list) + | FV of (FStarC_Syntax_Syntax.fv * FStarC_Syntax_Syntax.universe Prims.list + * (t * FStarC_Syntax_Syntax.aqual) Prims.list) + | Constant of constant + | Type_t of FStarC_Syntax_Syntax.universe + | Univ of FStarC_Syntax_Syntax.universe + | Unknown + | Arrow of (FStarC_Syntax_Syntax.term FStarC_Thunk.t, + ((t * FStarC_Syntax_Syntax.aqual) Prims.list * comp)) + FStar_Pervasives.either + | Refinement of ((t -> t) * (unit -> (t * FStarC_Syntax_Syntax.aqual))) + | Reflect of t + | Quote of (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.quoteinfo) + | Lazy of ((FStarC_Syntax_Syntax.lazyinfo, + (FStarC_Dyn.dyn * FStarC_Syntax_Syntax.emb_typ)) FStar_Pervasives.either * + t FStarC_Thunk.t) + | Meta of (t * FStarC_Syntax_Syntax.metadata FStarC_Thunk.t) + | TopLevelLet of (FStarC_Syntax_Syntax.letbinding * Prims.int * (t * + FStarC_Syntax_Syntax.aqual) Prims.list) + | TopLevelRec of (FStarC_Syntax_Syntax.letbinding * Prims.int * Prims.bool + Prims.list * (t * FStarC_Syntax_Syntax.aqual) Prims.list) + | LocalLetRec of (Prims.int * FStarC_Syntax_Syntax.letbinding * + FStarC_Syntax_Syntax.letbinding Prims.list * t Prims.list * (t * + FStarC_Syntax_Syntax.aqual) Prims.list * Prims.int * Prims.bool Prims.list) +and t = { + nbe_t: t' ; + nbe_r: FStarC_Compiler_Range_Type.range } +and comp = + | Tot of t + | GTot of t + | Comp of comp_typ +and comp_typ = + { + comp_univs: FStarC_Syntax_Syntax.universes ; + effect_name: FStarC_Ident.lident ; + result_typ: t ; + effect_args: (t * FStarC_Syntax_Syntax.aqual) Prims.list ; + flags: cflag Prims.list } +and residual_comp = + { + residual_effect: FStarC_Ident.lident ; + residual_typ: t FStar_Pervasives_Native.option ; + residual_flags: cflag Prims.list } +and cflag = + | TOTAL + | MLEFFECT + | RETURN + | PARTIAL_RETURN + | SOMETRIVIAL + | TRIVIAL_POSTCONDITION + | SHOULD_NOT_INLINE + | LEMMA + | CPS + | DECREASES_lex of t Prims.list + | DECREASES_wf of (t * t) +let (uu___is_Var : atom -> Prims.bool) = + fun projectee -> match projectee with | Var _0 -> true | uu___ -> false +let (__proj__Var__item___0 : atom -> var) = + fun projectee -> match projectee with | Var _0 -> _0 +let (uu___is_Match : atom -> Prims.bool) = + fun projectee -> match projectee with | Match _0 -> true | uu___ -> false +let (__proj__Match__item___0 : + atom -> + (t * + (unit -> + FStarC_Syntax_Syntax.match_returns_ascription + FStar_Pervasives_Native.option) + * (unit -> FStarC_Syntax_Syntax.branch Prims.list) * + (unit -> + FStarC_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option))) + = fun projectee -> match projectee with | Match _0 -> _0 +let (uu___is_UnreducedLet : atom -> Prims.bool) = + fun projectee -> + match projectee with | UnreducedLet _0 -> true | uu___ -> false +let (__proj__UnreducedLet__item___0 : + atom -> + (var * t FStarC_Thunk.t * t FStarC_Thunk.t * t FStarC_Thunk.t * + FStarC_Syntax_Syntax.letbinding)) + = fun projectee -> match projectee with | UnreducedLet _0 -> _0 +let (uu___is_UnreducedLetRec : atom -> Prims.bool) = + fun projectee -> + match projectee with | UnreducedLetRec _0 -> true | uu___ -> false +let (__proj__UnreducedLetRec__item___0 : + atom -> + ((var * t * t) Prims.list * t * FStarC_Syntax_Syntax.letbinding + Prims.list)) + = fun projectee -> match projectee with | UnreducedLetRec _0 -> _0 +let (uu___is_UVar : atom -> Prims.bool) = + fun projectee -> match projectee with | UVar _0 -> true | uu___ -> false +let (__proj__UVar__item___0 : + atom -> FStarC_Syntax_Syntax.term FStarC_Thunk.t) = + fun projectee -> match projectee with | UVar _0 -> _0 +let (uu___is_Lam_bs : lam_shape -> Prims.bool) = + fun projectee -> match projectee with | Lam_bs _0 -> true | uu___ -> false +let (__proj__Lam_bs__item___0 : + lam_shape -> + (t Prims.list * FStarC_Syntax_Syntax.binders * + FStarC_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option)) + = fun projectee -> match projectee with | Lam_bs _0 -> _0 +let (uu___is_Lam_args : lam_shape -> Prims.bool) = + fun projectee -> + match projectee with | Lam_args _0 -> true | uu___ -> false +let (__proj__Lam_args__item___0 : + lam_shape -> (t * FStarC_Syntax_Syntax.aqual) Prims.list) = + fun projectee -> match projectee with | Lam_args _0 -> _0 +let (uu___is_Lam_primop : lam_shape -> Prims.bool) = + fun projectee -> + match projectee with | Lam_primop _0 -> true | uu___ -> false +let (__proj__Lam_primop__item___0 : + lam_shape -> + (FStarC_Syntax_Syntax.fv * (t * FStarC_Syntax_Syntax.aqual) Prims.list)) + = fun projectee -> match projectee with | Lam_primop _0 -> _0 +let (__proj__Mkt'__Lam__payload__item__interp : + t'__Lam__payload -> (t * FStarC_Syntax_Syntax.aqual) Prims.list -> t) = + fun projectee -> match projectee with | { interp; shape; arity;_} -> interp +let (__proj__Mkt'__Lam__payload__item__shape : t'__Lam__payload -> lam_shape) + = + fun projectee -> match projectee with | { interp; shape; arity;_} -> shape +let (__proj__Mkt'__Lam__payload__item__arity : t'__Lam__payload -> Prims.int) + = + fun projectee -> match projectee with | { interp; shape; arity;_} -> arity +let (uu___is_Lam : t' -> Prims.bool) = + fun projectee -> match projectee with | Lam _0 -> true | uu___ -> false +let (__proj__Lam__item___0 : t' -> t'__Lam__payload) = + fun projectee -> match projectee with | Lam _0 -> _0 +let (uu___is_Accu : t' -> Prims.bool) = + fun projectee -> match projectee with | Accu _0 -> true | uu___ -> false +let (__proj__Accu__item___0 : + t' -> (atom * (t * FStarC_Syntax_Syntax.aqual) Prims.list)) = + fun projectee -> match projectee with | Accu _0 -> _0 +let (uu___is_Construct : t' -> Prims.bool) = + fun projectee -> + match projectee with | Construct _0 -> true | uu___ -> false +let (__proj__Construct__item___0 : + t' -> + (FStarC_Syntax_Syntax.fv * FStarC_Syntax_Syntax.universe Prims.list * (t + * FStarC_Syntax_Syntax.aqual) Prims.list)) + = fun projectee -> match projectee with | Construct _0 -> _0 +let (uu___is_FV : t' -> Prims.bool) = + fun projectee -> match projectee with | FV _0 -> true | uu___ -> false +let (__proj__FV__item___0 : + t' -> + (FStarC_Syntax_Syntax.fv * FStarC_Syntax_Syntax.universe Prims.list * (t + * FStarC_Syntax_Syntax.aqual) Prims.list)) + = fun projectee -> match projectee with | FV _0 -> _0 +let (uu___is_Constant : t' -> Prims.bool) = + fun projectee -> + match projectee with | Constant _0 -> true | uu___ -> false +let (__proj__Constant__item___0 : t' -> constant) = + fun projectee -> match projectee with | Constant _0 -> _0 +let (uu___is_Type_t : t' -> Prims.bool) = + fun projectee -> match projectee with | Type_t _0 -> true | uu___ -> false +let (__proj__Type_t__item___0 : t' -> FStarC_Syntax_Syntax.universe) = + fun projectee -> match projectee with | Type_t _0 -> _0 +let (uu___is_Univ : t' -> Prims.bool) = + fun projectee -> match projectee with | Univ _0 -> true | uu___ -> false +let (__proj__Univ__item___0 : t' -> FStarC_Syntax_Syntax.universe) = + fun projectee -> match projectee with | Univ _0 -> _0 +let (uu___is_Unknown : t' -> Prims.bool) = + fun projectee -> match projectee with | Unknown -> true | uu___ -> false +let (uu___is_Arrow : t' -> Prims.bool) = + fun projectee -> match projectee with | Arrow _0 -> true | uu___ -> false +let (__proj__Arrow__item___0 : + t' -> + (FStarC_Syntax_Syntax.term FStarC_Thunk.t, + ((t * FStarC_Syntax_Syntax.aqual) Prims.list * comp)) + FStar_Pervasives.either) + = fun projectee -> match projectee with | Arrow _0 -> _0 +let (uu___is_Refinement : t' -> Prims.bool) = + fun projectee -> + match projectee with | Refinement _0 -> true | uu___ -> false +let (__proj__Refinement__item___0 : + t' -> ((t -> t) * (unit -> (t * FStarC_Syntax_Syntax.aqual)))) = + fun projectee -> match projectee with | Refinement _0 -> _0 +let (uu___is_Reflect : t' -> Prims.bool) = + fun projectee -> match projectee with | Reflect _0 -> true | uu___ -> false +let (__proj__Reflect__item___0 : t' -> t) = + fun projectee -> match projectee with | Reflect _0 -> _0 +let (uu___is_Quote : t' -> Prims.bool) = + fun projectee -> match projectee with | Quote _0 -> true | uu___ -> false +let (__proj__Quote__item___0 : + t' -> (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.quoteinfo)) = + fun projectee -> match projectee with | Quote _0 -> _0 +let (uu___is_Lazy : t' -> Prims.bool) = + fun projectee -> match projectee with | Lazy _0 -> true | uu___ -> false +let (__proj__Lazy__item___0 : + t' -> + ((FStarC_Syntax_Syntax.lazyinfo, + (FStarC_Dyn.dyn * FStarC_Syntax_Syntax.emb_typ)) + FStar_Pervasives.either * t FStarC_Thunk.t)) + = fun projectee -> match projectee with | Lazy _0 -> _0 +let (uu___is_Meta : t' -> Prims.bool) = + fun projectee -> match projectee with | Meta _0 -> true | uu___ -> false +let (__proj__Meta__item___0 : + t' -> (t * FStarC_Syntax_Syntax.metadata FStarC_Thunk.t)) = + fun projectee -> match projectee with | Meta _0 -> _0 +let (uu___is_TopLevelLet : t' -> Prims.bool) = + fun projectee -> + match projectee with | TopLevelLet _0 -> true | uu___ -> false +let (__proj__TopLevelLet__item___0 : + t' -> + (FStarC_Syntax_Syntax.letbinding * Prims.int * (t * + FStarC_Syntax_Syntax.aqual) Prims.list)) + = fun projectee -> match projectee with | TopLevelLet _0 -> _0 +let (uu___is_TopLevelRec : t' -> Prims.bool) = + fun projectee -> + match projectee with | TopLevelRec _0 -> true | uu___ -> false +let (__proj__TopLevelRec__item___0 : + t' -> + (FStarC_Syntax_Syntax.letbinding * Prims.int * Prims.bool Prims.list * (t + * FStarC_Syntax_Syntax.aqual) Prims.list)) + = fun projectee -> match projectee with | TopLevelRec _0 -> _0 +let (uu___is_LocalLetRec : t' -> Prims.bool) = + fun projectee -> + match projectee with | LocalLetRec _0 -> true | uu___ -> false +let (__proj__LocalLetRec__item___0 : + t' -> + (Prims.int * FStarC_Syntax_Syntax.letbinding * + FStarC_Syntax_Syntax.letbinding Prims.list * t Prims.list * (t * + FStarC_Syntax_Syntax.aqual) Prims.list * Prims.int * Prims.bool + Prims.list)) + = fun projectee -> match projectee with | LocalLetRec _0 -> _0 +let (__proj__Mkt__item__nbe_t : t -> t') = + fun projectee -> match projectee with | { nbe_t; nbe_r;_} -> nbe_t +let (__proj__Mkt__item__nbe_r : t -> FStarC_Compiler_Range_Type.range) = + fun projectee -> match projectee with | { nbe_t; nbe_r;_} -> nbe_r +let (uu___is_Tot : comp -> Prims.bool) = + fun projectee -> match projectee with | Tot _0 -> true | uu___ -> false +let (__proj__Tot__item___0 : comp -> t) = + fun projectee -> match projectee with | Tot _0 -> _0 +let (uu___is_GTot : comp -> Prims.bool) = + fun projectee -> match projectee with | GTot _0 -> true | uu___ -> false +let (__proj__GTot__item___0 : comp -> t) = + fun projectee -> match projectee with | GTot _0 -> _0 +let (uu___is_Comp : comp -> Prims.bool) = + fun projectee -> match projectee with | Comp _0 -> true | uu___ -> false +let (__proj__Comp__item___0 : comp -> comp_typ) = + fun projectee -> match projectee with | Comp _0 -> _0 +let (__proj__Mkcomp_typ__item__comp_univs : + comp_typ -> FStarC_Syntax_Syntax.universes) = + fun projectee -> + match projectee with + | { comp_univs; effect_name; result_typ; effect_args; flags;_} -> + comp_univs +let (__proj__Mkcomp_typ__item__effect_name : comp_typ -> FStarC_Ident.lident) + = + fun projectee -> + match projectee with + | { comp_univs; effect_name; result_typ; effect_args; flags;_} -> + effect_name +let (__proj__Mkcomp_typ__item__result_typ : comp_typ -> t) = + fun projectee -> + match projectee with + | { comp_univs; effect_name; result_typ; effect_args; flags;_} -> + result_typ +let (__proj__Mkcomp_typ__item__effect_args : + comp_typ -> (t * FStarC_Syntax_Syntax.aqual) Prims.list) = + fun projectee -> + match projectee with + | { comp_univs; effect_name; result_typ; effect_args; flags;_} -> + effect_args +let (__proj__Mkcomp_typ__item__flags : comp_typ -> cflag Prims.list) = + fun projectee -> + match projectee with + | { comp_univs; effect_name; result_typ; effect_args; flags;_} -> flags +let (__proj__Mkresidual_comp__item__residual_effect : + residual_comp -> FStarC_Ident.lident) = + fun projectee -> + match projectee with + | { residual_effect; residual_typ; residual_flags;_} -> residual_effect +let (__proj__Mkresidual_comp__item__residual_typ : + residual_comp -> t FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { residual_effect; residual_typ; residual_flags;_} -> residual_typ +let (__proj__Mkresidual_comp__item__residual_flags : + residual_comp -> cflag Prims.list) = + fun projectee -> + match projectee with + | { residual_effect; residual_typ; residual_flags;_} -> residual_flags +let (uu___is_TOTAL : cflag -> Prims.bool) = + fun projectee -> match projectee with | TOTAL -> true | uu___ -> false +let (uu___is_MLEFFECT : cflag -> Prims.bool) = + fun projectee -> match projectee with | MLEFFECT -> true | uu___ -> false +let (uu___is_RETURN : cflag -> Prims.bool) = + fun projectee -> match projectee with | RETURN -> true | uu___ -> false +let (uu___is_PARTIAL_RETURN : cflag -> Prims.bool) = + fun projectee -> + match projectee with | PARTIAL_RETURN -> true | uu___ -> false +let (uu___is_SOMETRIVIAL : cflag -> Prims.bool) = + fun projectee -> + match projectee with | SOMETRIVIAL -> true | uu___ -> false +let (uu___is_TRIVIAL_POSTCONDITION : cflag -> Prims.bool) = + fun projectee -> + match projectee with | TRIVIAL_POSTCONDITION -> true | uu___ -> false +let (uu___is_SHOULD_NOT_INLINE : cflag -> Prims.bool) = + fun projectee -> + match projectee with | SHOULD_NOT_INLINE -> true | uu___ -> false +let (uu___is_LEMMA : cflag -> Prims.bool) = + fun projectee -> match projectee with | LEMMA -> true | uu___ -> false +let (uu___is_CPS : cflag -> Prims.bool) = + fun projectee -> match projectee with | CPS -> true | uu___ -> false +let (uu___is_DECREASES_lex : cflag -> Prims.bool) = + fun projectee -> + match projectee with | DECREASES_lex _0 -> true | uu___ -> false +let (__proj__DECREASES_lex__item___0 : cflag -> t Prims.list) = + fun projectee -> match projectee with | DECREASES_lex _0 -> _0 +let (uu___is_DECREASES_wf : cflag -> Prims.bool) = + fun projectee -> + match projectee with | DECREASES_wf _0 -> true | uu___ -> false +let (__proj__DECREASES_wf__item___0 : cflag -> (t * t)) = + fun projectee -> match projectee with | DECREASES_wf _0 -> _0 +type arg = (t * FStarC_Syntax_Syntax.aqual) +type args = (t * FStarC_Syntax_Syntax.aqual) Prims.list +let (isAccu : t -> Prims.bool) = + fun trm -> match trm.nbe_t with | Accu uu___ -> true | uu___ -> false +let (isNotAccu : t -> Prims.bool) = + fun x -> match x.nbe_t with | Accu (uu___, uu___1) -> false | uu___ -> true +let (mk_rt : FStarC_Compiler_Range_Type.range -> t' -> t) = + fun r -> fun t1 -> { nbe_t = t1; nbe_r = r } +let (mk_t : t' -> t) = + fun t1 -> mk_rt FStarC_Compiler_Range_Type.dummyRange t1 +let (nbe_t_of_t : t -> t') = fun t1 -> t1.nbe_t +let (mkConstruct : + FStarC_Syntax_Syntax.fv -> + FStarC_Syntax_Syntax.universe Prims.list -> args -> t) + = fun i -> fun us -> fun ts -> mk_t (Construct (i, us, ts)) +let (mkFV : + FStarC_Syntax_Syntax.fv -> + FStarC_Syntax_Syntax.universe Prims.list -> args -> t) + = + fun i -> + fun us -> + fun ts -> + let uu___ = FStarC_Syntax_Syntax.range_of_fv i in + mk_rt uu___ (FV (i, us, ts)) +let (mkAccuVar : var -> t) = + fun v -> + let uu___ = FStarC_Syntax_Syntax.range_of_bv v in + mk_rt uu___ (Accu ((Var v), [])) +let (mkAccuMatch : + t -> + (unit -> + FStarC_Syntax_Syntax.match_returns_ascription + FStar_Pervasives_Native.option) + -> + (unit -> FStarC_Syntax_Syntax.branch Prims.list) -> + (unit -> + FStarC_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option) + -> t) + = + fun s -> + fun ret -> fun bs -> fun rc -> mk_t (Accu ((Match (s, ret, bs, rc)), [])) +let (equal_if : Prims.bool -> FStarC_TypeChecker_TermEqAndSimplify.eq_result) + = + fun uu___ -> + if uu___ + then FStarC_TypeChecker_TermEqAndSimplify.Equal + else FStarC_TypeChecker_TermEqAndSimplify.Unknown +let (equal_iff : + Prims.bool -> FStarC_TypeChecker_TermEqAndSimplify.eq_result) = + fun uu___ -> + if uu___ + then FStarC_TypeChecker_TermEqAndSimplify.Equal + else FStarC_TypeChecker_TermEqAndSimplify.NotEqual +let (eq_inj : + FStarC_TypeChecker_TermEqAndSimplify.eq_result -> + FStarC_TypeChecker_TermEqAndSimplify.eq_result -> + FStarC_TypeChecker_TermEqAndSimplify.eq_result) + = + fun r1 -> + fun r2 -> + match (r1, r2) with + | (FStarC_TypeChecker_TermEqAndSimplify.Equal, + FStarC_TypeChecker_TermEqAndSimplify.Equal) -> + FStarC_TypeChecker_TermEqAndSimplify.Equal + | (FStarC_TypeChecker_TermEqAndSimplify.NotEqual, uu___) -> + FStarC_TypeChecker_TermEqAndSimplify.NotEqual + | (uu___, FStarC_TypeChecker_TermEqAndSimplify.NotEqual) -> + FStarC_TypeChecker_TermEqAndSimplify.NotEqual + | (FStarC_TypeChecker_TermEqAndSimplify.Unknown, uu___) -> + FStarC_TypeChecker_TermEqAndSimplify.Unknown + | (uu___, FStarC_TypeChecker_TermEqAndSimplify.Unknown) -> + FStarC_TypeChecker_TermEqAndSimplify.Unknown +let (eq_and : + FStarC_TypeChecker_TermEqAndSimplify.eq_result -> + (unit -> FStarC_TypeChecker_TermEqAndSimplify.eq_result) -> + FStarC_TypeChecker_TermEqAndSimplify.eq_result) + = + fun f -> + fun g -> + match f with + | FStarC_TypeChecker_TermEqAndSimplify.Equal -> g () + | uu___ -> FStarC_TypeChecker_TermEqAndSimplify.Unknown +let (eq_constant : + constant -> constant -> FStarC_TypeChecker_TermEqAndSimplify.eq_result) = + fun c1 -> + fun c2 -> + match (c1, c2) with + | (Unit, Unit) -> FStarC_TypeChecker_TermEqAndSimplify.Equal + | (Bool b1, Bool b2) -> equal_iff (b1 = b2) + | (Int i1, Int i2) -> equal_iff (i1 = i2) + | (String (s1, uu___), String (s2, uu___1)) -> equal_iff (s1 = s2) + | (Char c11, Char c21) -> equal_iff (c11 = c21) + | (Range r1, Range r2) -> FStarC_TypeChecker_TermEqAndSimplify.Unknown + | (Real r1, Real r2) -> equal_if (r1 = r2) + | (uu___, uu___1) -> FStarC_TypeChecker_TermEqAndSimplify.NotEqual +let rec (eq_t : + FStarC_TypeChecker_Env.env_t -> + t -> t -> FStarC_TypeChecker_TermEqAndSimplify.eq_result) + = + fun env -> + fun t1 -> + fun t2 -> + match ((t1.nbe_t), (t2.nbe_t)) with + | (Lam uu___, Lam uu___1) -> + FStarC_TypeChecker_TermEqAndSimplify.Unknown + | (Accu (a1, as1), Accu (a2, as2)) -> + let uu___ = eq_atom a1 a2 in + eq_and uu___ (fun uu___1 -> eq_args env as1 as2) + | (Construct (v1, us1, args1), Construct (v2, us2, args2)) -> + let uu___ = FStarC_Syntax_Syntax.fv_eq v1 v2 in + if uu___ + then + (if + (FStarC_Compiler_List.length args1) <> + (FStarC_Compiler_List.length args2) + then failwith "eq_t, different number of args on Construct" + else (); + (let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.lid_of_fv v1 in + FStarC_TypeChecker_Env.num_datacon_non_injective_ty_params + env uu___3 in + match uu___2 with + | FStar_Pervasives_Native.None -> + FStarC_TypeChecker_TermEqAndSimplify.Unknown + | FStar_Pervasives_Native.Some n -> + if n <= (FStarC_Compiler_List.length args1) + then + let eq_args1 as1 as2 = + FStarC_Compiler_List.fold_left2 + (fun acc -> + fun uu___3 -> + fun uu___4 -> + match (uu___3, uu___4) with + | ((a1, uu___5), (a2, uu___6)) -> + let uu___7 = eq_t env a1 a2 in + eq_inj acc uu___7) + FStarC_TypeChecker_TermEqAndSimplify.Equal as1 as2 in + let uu___3 = FStarC_Compiler_List.splitAt n args1 in + (match uu___3 with + | (parms1, args11) -> + let uu___4 = FStarC_Compiler_List.splitAt n args2 in + (match uu___4 with + | (parms2, args21) -> eq_args1 args11 args21)) + else FStarC_TypeChecker_TermEqAndSimplify.Unknown)) + else FStarC_TypeChecker_TermEqAndSimplify.NotEqual + | (FV (v1, us1, args1), FV (v2, us2, args2)) -> + let uu___ = FStarC_Syntax_Syntax.fv_eq v1 v2 in + if uu___ + then + let uu___1 = + let uu___2 = FStarC_Syntax_Util.eq_univs_list us1 us2 in + equal_iff uu___2 in + eq_and uu___1 (fun uu___2 -> eq_args env args1 args2) + else FStarC_TypeChecker_TermEqAndSimplify.Unknown + | (Constant c1, Constant c2) -> eq_constant c1 c2 + | (Type_t u1, Type_t u2) -> + let uu___ = FStarC_Syntax_Util.eq_univs u1 u2 in equal_iff uu___ + | (Univ u1, Univ u2) -> + let uu___ = FStarC_Syntax_Util.eq_univs u1 u2 in equal_iff uu___ + | (Refinement (r1, t11), Refinement (r2, t21)) -> + let x = + FStarC_Syntax_Syntax.new_bv FStar_Pervasives_Native.None + FStarC_Syntax_Syntax.t_unit in + let uu___ = + let uu___1 = + let uu___2 = t11 () in FStar_Pervasives_Native.fst uu___2 in + let uu___2 = + let uu___3 = t21 () in FStar_Pervasives_Native.fst uu___3 in + eq_t env uu___1 uu___2 in + eq_and uu___ + (fun uu___1 -> + let uu___2 = let uu___3 = mkAccuVar x in r1 uu___3 in + let uu___3 = let uu___4 = mkAccuVar x in r2 uu___4 in + eq_t env uu___2 uu___3) + | (Unknown, Unknown) -> FStarC_TypeChecker_TermEqAndSimplify.Equal + | (uu___, uu___1) -> FStarC_TypeChecker_TermEqAndSimplify.Unknown +and (eq_atom : + atom -> atom -> FStarC_TypeChecker_TermEqAndSimplify.eq_result) = + fun a1 -> + fun a2 -> + match (a1, a2) with + | (Var bv1, Var bv2) -> + let uu___ = FStarC_Syntax_Syntax.bv_eq bv1 bv2 in equal_if uu___ + | (uu___, uu___1) -> FStarC_TypeChecker_TermEqAndSimplify.Unknown +and (eq_arg : + FStarC_TypeChecker_Env.env_t -> + arg -> arg -> FStarC_TypeChecker_TermEqAndSimplify.eq_result) + = + fun env -> + fun a1 -> + fun a2 -> + eq_t env (FStar_Pervasives_Native.fst a1) + (FStar_Pervasives_Native.fst a2) +and (eq_args : + FStarC_TypeChecker_Env.env_t -> + args -> args -> FStarC_TypeChecker_TermEqAndSimplify.eq_result) + = + fun env -> + fun as1 -> + fun as2 -> + match (as1, as2) with + | ([], []) -> FStarC_TypeChecker_TermEqAndSimplify.Equal + | (x::xs, y::ys) -> + let uu___ = eq_arg env x y in + eq_and uu___ (fun uu___1 -> eq_args env xs ys) + | (uu___, uu___1) -> FStarC_TypeChecker_TermEqAndSimplify.Unknown +let (constant_to_string : constant -> Prims.string) = + fun c -> + match c with + | Unit -> "Unit" + | Bool b -> if b then "Bool true" else "Bool false" + | Int i -> FStarC_BigInt.string_of_big_int i + | Char c1 -> + FStarC_Compiler_Util.format1 "'%s'" + (FStarC_Compiler_Util.string_of_char c1) + | String (s, uu___) -> FStarC_Compiler_Util.format1 "\"%s\"" s + | Range r -> + let uu___ = FStarC_Compiler_Range_Ops.string_of_range r in + FStarC_Compiler_Util.format1 "Range %s" uu___ + | SConst s -> FStarC_Class_Show.show FStarC_Syntax_Print.showable_const s + | Real s -> FStarC_Compiler_Util.format1 "Real %s" s +let rec (t_to_string : t -> Prims.string) = + fun x -> + match x.nbe_t with + | Lam { interp = b; shape = uu___; arity;_} -> + let uu___1 = FStarC_Compiler_Util.string_of_int arity in + FStarC_Compiler_Util.format1 "Lam (_, %s args)" uu___1 + | Accu (a, l) -> + let uu___ = + let uu___1 = atom_to_string a in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Compiler_List.map + (fun x1 -> t_to_string (FStar_Pervasives_Native.fst x1)) + l in + FStarC_Compiler_String.concat "; " uu___5 in + Prims.strcat uu___4 ")" in + Prims.strcat ") (" uu___3 in + Prims.strcat uu___1 uu___2 in + Prims.strcat "Accu (" uu___ + | Construct (fv, us, l) -> + let uu___ = + let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_fv fv in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Compiler_List.map + (FStarC_Class_Show.show FStarC_Syntax_Print.showable_univ) + us in + FStarC_Compiler_String.concat "; " uu___5 in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Compiler_List.map + (fun x1 -> + t_to_string (FStar_Pervasives_Native.fst x1)) l in + FStarC_Compiler_String.concat "; " uu___8 in + Prims.strcat uu___7 "]" in + Prims.strcat "] [" uu___6 in + Prims.strcat uu___4 uu___5 in + Prims.strcat ") [" uu___3 in + Prims.strcat uu___1 uu___2 in + Prims.strcat "Construct (" uu___ + | FV (fv, us, l) -> + let uu___ = + let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_fv fv in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Compiler_List.map + (FStarC_Class_Show.show FStarC_Syntax_Print.showable_univ) + us in + FStarC_Compiler_String.concat "; " uu___5 in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Compiler_List.map + (fun x1 -> + t_to_string (FStar_Pervasives_Native.fst x1)) l in + FStarC_Compiler_String.concat "; " uu___8 in + Prims.strcat uu___7 "]" in + Prims.strcat "] [" uu___6 in + Prims.strcat uu___4 uu___5 in + Prims.strcat ") [" uu___3 in + Prims.strcat uu___1 uu___2 in + Prims.strcat "FV (" uu___ + | Constant c -> constant_to_string c + | Univ u -> + let uu___ = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_univ u in + Prims.strcat "Universe " uu___ + | Type_t u -> + let uu___ = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_univ u in + Prims.strcat "Type_t " uu___ + | Arrow uu___ -> "Arrow" + | Refinement (f, t1) -> + let x1 = + FStarC_Syntax_Syntax.new_bv FStar_Pervasives_Native.None + FStarC_Syntax_Syntax.t_unit in + let t2 = let uu___ = t1 () in FStar_Pervasives_Native.fst uu___ in + let uu___ = + let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_bv x1 in + let uu___2 = + let uu___3 = + let uu___4 = t_to_string t2 in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = let uu___9 = mkAccuVar x1 in f uu___9 in + t_to_string uu___8 in + Prims.strcat uu___7 "}" in + Prims.strcat "{" uu___6 in + Prims.strcat uu___4 uu___5 in + Prims.strcat ":" uu___3 in + Prims.strcat uu___1 uu___2 in + Prims.strcat "Refinement " uu___ + | Unknown -> "Unknown" + | Reflect t1 -> + let uu___ = t_to_string t1 in Prims.strcat "Reflect " uu___ + | Quote uu___ -> "Quote _" + | Lazy (FStar_Pervasives.Inl li, uu___) -> + let uu___1 = + let uu___2 = FStarC_Syntax_Util.unfold_lazy li in + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term uu___2 in + FStarC_Compiler_Util.format1 "Lazy (Inl {%s})" uu___1 + | Lazy (FStar_Pervasives.Inr (uu___, et), uu___1) -> + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Syntax.showable_emb_typ et in + FStarC_Compiler_Util.format1 "Lazy (Inr (?, %s))" uu___2 + | LocalLetRec (uu___, l, uu___1, uu___2, uu___3, uu___4, uu___5) -> + let uu___6 = + let uu___7 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_tuple2 + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_letbinding)) (true, [l]) in + Prims.strcat uu___7 ")" in + Prims.strcat "LocalLetRec (" uu___6 + | TopLevelLet (lb, uu___, uu___1) -> + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Compiler_Util.right lb.FStarC_Syntax_Syntax.lbname in + FStarC_Class_Show.show FStarC_Syntax_Print.showable_fv uu___4 in + Prims.strcat uu___3 ")" in + Prims.strcat "TopLevelLet (" uu___2 + | TopLevelRec (lb, uu___, uu___1, uu___2) -> + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Compiler_Util.right lb.FStarC_Syntax_Syntax.lbname in + FStarC_Class_Show.show FStarC_Syntax_Print.showable_fv uu___5 in + Prims.strcat uu___4 ")" in + Prims.strcat "TopLevelRec (" uu___3 + | Meta (t1, uu___) -> + let uu___1 = t_to_string t1 in Prims.strcat "Meta " uu___1 +and (atom_to_string : atom -> Prims.string) = + fun a -> + match a with + | Var v -> + let uu___ = FStarC_Class_Show.show FStarC_Syntax_Print.showable_bv v in + Prims.strcat "Var " uu___ + | Match (t1, uu___, uu___1, uu___2) -> + let uu___3 = t_to_string t1 in Prims.strcat "Match " uu___3 + | UnreducedLet (var1, typ, def, body, lb) -> + let uu___ = + let uu___1 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_tuple2 + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_letbinding)) (false, [lb]) in + Prims.strcat uu___1 " in ...)" in + Prims.strcat "UnreducedLet(" uu___ + | UnreducedLetRec (uu___, body, lbs) -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_tuple2 + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_letbinding)) (true, lbs) in + let uu___3 = + let uu___4 = + let uu___5 = t_to_string body in Prims.strcat uu___5 ")" in + Prims.strcat " in " uu___4 in + Prims.strcat uu___2 uu___3 in + Prims.strcat "UnreducedLetRec(" uu___1 + | UVar uu___ -> "UVar" +let (arg_to_string : arg -> Prims.string) = + fun a -> t_to_string (FStar_Pervasives_Native.fst a) +let (args_to_string : args -> Prims.string) = + fun args1 -> + let uu___ = FStarC_Compiler_List.map arg_to_string args1 in + FStarC_Compiler_String.concat " " uu___ +let (showable_t : t FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = t_to_string } +let (showable_args : args FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = args_to_string } +type head = t +type annot = t FStar_Pervasives_Native.option +type nbe_cbs = + { + iapp: t -> args -> t ; + translate: FStarC_Syntax_Syntax.term -> t } +let (__proj__Mknbe_cbs__item__iapp : nbe_cbs -> t -> args -> t) = + fun projectee -> match projectee with | { iapp; translate;_} -> iapp +let (__proj__Mknbe_cbs__item__translate : + nbe_cbs -> FStarC_Syntax_Syntax.term -> t) = + fun projectee -> match projectee with | { iapp; translate;_} -> translate +type 'a embedding = + { + em: nbe_cbs -> 'a -> t ; + un: nbe_cbs -> t -> 'a FStar_Pervasives_Native.option ; + typ: unit -> t ; + e_typ: unit -> FStarC_Syntax_Syntax.emb_typ } +let __proj__Mkembedding__item__em : 'a . 'a embedding -> nbe_cbs -> 'a -> t = + fun projectee -> match projectee with | { em; un; typ; e_typ;_} -> em +let __proj__Mkembedding__item__un : + 'a . 'a embedding -> nbe_cbs -> t -> 'a FStar_Pervasives_Native.option = + fun projectee -> match projectee with | { em; un; typ; e_typ;_} -> un +let __proj__Mkembedding__item__typ : 'a . 'a embedding -> unit -> t = + fun projectee -> match projectee with | { em; un; typ; e_typ;_} -> typ +let __proj__Mkembedding__item__e_typ : + 'a . 'a embedding -> unit -> FStarC_Syntax_Syntax.emb_typ = + fun projectee -> match projectee with | { em; un; typ; e_typ;_} -> e_typ +let em : 'a . 'a embedding -> nbe_cbs -> 'a -> t = + fun projectee -> + match projectee with | { em = em1; un; typ; e_typ;_} -> em1 +let un : + 'a . 'a embedding -> nbe_cbs -> t -> 'a FStar_Pervasives_Native.option = + fun projectee -> + match projectee with | { em = em1; un = un1; typ; e_typ;_} -> un1 +let typ : 'a . 'a embedding -> unit -> t = + fun projectee -> + match projectee with | { em = em1; un = un1; typ = typ1; e_typ;_} -> typ1 +let e_typ : 'a . 'a embedding -> unit -> FStarC_Syntax_Syntax.emb_typ = + fun projectee -> + match projectee with + | { em = em1; un = un1; typ = typ1; e_typ = e_typ1;_} -> e_typ1 +let (iapp_cb : nbe_cbs -> t -> args -> t) = + fun cbs -> fun h -> fun a -> cbs.iapp h a +let (translate_cb : nbe_cbs -> FStarC_Syntax_Syntax.term -> t) = + fun cbs -> fun t1 -> cbs.translate t1 +let embed : 'a . 'a embedding -> nbe_cbs -> 'a -> t = + fun e -> fun cb -> fun x -> e.em cb x +let unembed : + 'a . 'a embedding -> nbe_cbs -> t -> 'a FStar_Pervasives_Native.option = + fun e -> fun cb -> fun trm -> e.un cb trm +let type_of : 'a . 'a embedding -> t = fun e -> e.typ () +let set_type : 'a . t -> 'a embedding -> 'a embedding = + fun ty -> + fun e -> + { em = (e.em); un = (e.un); typ = (fun uu___ -> ty); e_typ = (e.e_typ) + } +let mk_emb : + 'a . + (nbe_cbs -> 'a -> t) -> + (nbe_cbs -> t -> 'a FStar_Pervasives_Native.option) -> + (unit -> t) -> (unit -> FStarC_Syntax_Syntax.emb_typ) -> 'a embedding + = + fun em1 -> + fun un1 -> + fun typ1 -> fun et -> { em = em1; un = un1; typ = typ1; e_typ = et } +let mk_emb' : + 'uuuuu . + (nbe_cbs -> 'uuuuu -> t') -> + (nbe_cbs -> t' -> 'uuuuu FStar_Pervasives_Native.option) -> + (unit -> t) -> + (unit -> FStarC_Syntax_Syntax.emb_typ) -> 'uuuuu embedding + = + fun em1 -> + fun un1 -> + mk_emb (fun cbs -> fun t1 -> let uu___ = em1 cbs t1 in mk_t uu___) + (fun cbs -> fun t1 -> un1 cbs t1.nbe_t) +let embed_as : + 'a 'b . + 'a embedding -> + ('a -> 'b) -> + ('b -> 'a) -> t FStar_Pervasives_Native.option -> 'b embedding + = + fun ea -> + fun ab -> + fun ba -> + fun ot -> + mk_emb (fun cbs -> fun x -> let uu___ = ba x in embed ea cbs uu___) + (fun cbs -> + fun t1 -> + let uu___ = unembed ea cbs t1 in + FStarC_Compiler_Util.map_opt uu___ ab) + (fun uu___ -> + match ot with + | FStar_Pervasives_Native.Some t1 -> t1 + | FStar_Pervasives_Native.None -> ea.typ ()) ea.e_typ +let (lid_as_constr : + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.universe Prims.list -> args -> t) + = + fun l -> + fun us -> + fun args1 -> + let uu___ = + FStarC_Syntax_Syntax.lid_as_fv l + (FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.Data_ctor) in + mkConstruct uu___ us args1 +let (lid_as_typ : + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.universe Prims.list -> args -> t) + = + fun l -> + fun us -> + fun args1 -> + let uu___ = + FStarC_Syntax_Syntax.lid_as_fv l FStar_Pervasives_Native.None in + mkFV uu___ us args1 +let (as_iarg : t -> arg) = + fun a -> + let uu___ = FStarC_Syntax_Syntax.as_aqual_implicit true in (a, uu___) +let (as_arg : t -> arg) = fun a -> (a, FStar_Pervasives_Native.None) +let (make_arrow1 : t -> arg -> t) = + fun t1 -> fun a -> mk_t (Arrow (FStar_Pervasives.Inr ([a], (Tot t1)))) +let lazy_embed : + 'a . (unit -> FStarC_Syntax_Syntax.emb_typ) -> 'a -> (unit -> t) -> t = + fun et -> + fun x -> + fun f -> + (let uu___1 = + FStarC_Compiler_Effect.op_Bang FStarC_Options.debug_embedding in + if uu___1 + then + let uu___2 = + let uu___3 = et () in + FStarC_Class_Show.show FStarC_Syntax_Syntax.showable_emb_typ + uu___3 in + FStarC_Compiler_Util.print1 "Embedding\n\temb_typ=%s\n" uu___2 + else ()); + (let uu___1 = + FStarC_Compiler_Effect.op_Bang FStarC_Options.eager_embedding in + if uu___1 + then f () + else + (let thunk = FStarC_Thunk.mk f in + let li = + let uu___3 = FStarC_Dyn.mkdyn x in + let uu___4 = et () in (uu___3, uu___4) in + mk_t (Lazy ((FStar_Pervasives.Inr li), thunk)))) +let lazy_unembed : + 'a . + (unit -> FStarC_Syntax_Syntax.emb_typ) -> + t -> + (t -> 'a FStar_Pervasives_Native.option) -> + 'a FStar_Pervasives_Native.option + = + fun et -> + fun x -> + fun f -> + match x.nbe_t with + | Lazy (FStar_Pervasives.Inl li, thunk) -> + let uu___ = FStarC_Thunk.force thunk in f uu___ + | Lazy (FStar_Pervasives.Inr (b, et'), thunk) -> + let uu___ = + (let uu___1 = et () in uu___1 <> et') || + (FStarC_Compiler_Effect.op_Bang + FStarC_Options.eager_embedding) in + if uu___ + then + let res = let uu___1 = FStarC_Thunk.force thunk in f uu___1 in + ((let uu___2 = + FStarC_Compiler_Effect.op_Bang + FStarC_Options.debug_embedding in + if uu___2 + then + let uu___3 = + let uu___4 = et () in + FStarC_Class_Show.show + FStarC_Syntax_Syntax.showable_emb_typ uu___4 in + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Syntax.showable_emb_typ et' in + FStarC_Compiler_Util.print2 + "Unembed cancellation failed\n\t%s <> %s\n" uu___3 uu___4 + else ()); + res) + else + (let a1 = FStarC_Dyn.undyn b in + (let uu___3 = + FStarC_Compiler_Effect.op_Bang + FStarC_Options.debug_embedding in + if uu___3 + then + let uu___4 = + let uu___5 = et () in + FStarC_Class_Show.show + FStarC_Syntax_Syntax.showable_emb_typ uu___5 in + FStarC_Compiler_Util.print1 "Unembed cancelled for %s\n" + uu___4 + else ()); + FStar_Pervasives_Native.Some a1) + | uu___ -> + let aopt = f x in + ((let uu___2 = + FStarC_Compiler_Effect.op_Bang FStarC_Options.debug_embedding in + if uu___2 + then + let uu___3 = + let uu___4 = et () in + FStarC_Class_Show.show + FStarC_Syntax_Syntax.showable_emb_typ uu___4 in + FStarC_Compiler_Util.print1 "Unembedding:\n\temb_typ=%s\n" + uu___3 + else ()); + aopt) +let lazy_unembed_lazy_kind : + 'a . + FStarC_Syntax_Syntax.lazy_kind -> t -> 'a FStar_Pervasives_Native.option + = + fun k -> + fun x -> + match x.nbe_t with + | Lazy (FStar_Pervasives.Inl li, uu___) -> + if li.FStarC_Syntax_Syntax.lkind = k + then + let uu___1 = FStarC_Dyn.undyn li.FStarC_Syntax_Syntax.blob in + FStar_Pervasives_Native.Some uu___1 + else FStar_Pervasives_Native.None + | uu___ -> FStar_Pervasives_Native.None +type abstract_nbe_term = + | AbstractNBE of t +let (uu___is_AbstractNBE : abstract_nbe_term -> Prims.bool) = + fun projectee -> true +let (__proj__AbstractNBE__item__t : abstract_nbe_term -> t) = + fun projectee -> match projectee with | AbstractNBE t1 -> t1 +let (mk_any_emb : t -> t embedding) = + fun ty -> + let em1 _cb a = a in + let un1 _cb t1 = FStar_Pervasives_Native.Some t1 in + mk_emb em1 un1 (fun uu___ -> ty) + (fun uu___ -> FStarC_Syntax_Syntax.ET_abstract) +let (e_any : t embedding) = + let em1 _cb a = a in + let un1 _cb t1 = FStar_Pervasives_Native.Some t1 in + mk_emb em1 un1 (fun uu___ -> lid_as_typ FStarC_Parser_Const.term_lid [] []) + (fun uu___ -> FStarC_Syntax_Syntax.ET_abstract) +let (e_unit : unit embedding) = + let em1 _cb a = Constant Unit in + let un1 _cb t1 = FStar_Pervasives_Native.Some () in + mk_emb' em1 un1 + (fun uu___ -> lid_as_typ FStarC_Parser_Const.unit_lid [] []) + (FStarC_Syntax_Embeddings_Base.emb_typ_of FStarC_Syntax_Embeddings.e_unit) +let (e_bool : Prims.bool embedding) = + let em1 _cb a = Constant (Bool a) in + let un1 _cb t1 = + match t1 with + | Constant (Bool a) -> FStar_Pervasives_Native.Some a + | uu___ -> FStar_Pervasives_Native.None in + mk_emb' em1 un1 + (fun uu___ -> lid_as_typ FStarC_Parser_Const.bool_lid [] []) + (FStarC_Syntax_Embeddings_Base.emb_typ_of FStarC_Syntax_Embeddings.e_bool) +let (e_char : FStar_String.char embedding) = + let em1 _cb c = Constant (Char c) in + let un1 _cb c = + match c with + | Constant (Char a) -> FStar_Pervasives_Native.Some a + | uu___ -> FStar_Pervasives_Native.None in + mk_emb' em1 un1 + (fun uu___ -> lid_as_typ FStarC_Parser_Const.char_lid [] []) + (FStarC_Syntax_Embeddings_Base.emb_typ_of FStarC_Syntax_Embeddings.e_char) +let (e_string : Prims.string embedding) = + let em1 _cb s = + Constant (String (s, FStarC_Compiler_Range_Type.dummyRange)) in + let un1 _cb s = + match s with + | Constant (String (s1, uu___)) -> FStar_Pervasives_Native.Some s1 + | uu___ -> FStar_Pervasives_Native.None in + mk_emb' em1 un1 + (fun uu___ -> lid_as_typ FStarC_Parser_Const.string_lid [] []) + (FStarC_Syntax_Embeddings_Base.emb_typ_of + FStarC_Syntax_Embeddings.e_string) +let (e_int : FStarC_BigInt.t embedding) = + let em1 _cb c = Constant (Int c) in + let un1 _cb c = + match c with + | Constant (Int a) -> FStar_Pervasives_Native.Some a + | uu___ -> FStar_Pervasives_Native.None in + mk_emb' em1 un1 (fun uu___ -> lid_as_typ FStarC_Parser_Const.int_lid [] []) + (FStarC_Syntax_Embeddings_Base.emb_typ_of + FStarC_Syntax_Embeddings.e_fsint) +let (e_real : FStarC_Compiler_Real.real embedding) = + let em1 _cb uu___ = + match uu___ with | FStarC_Compiler_Real.Real c -> Constant (Real c) in + let un1 _cb c = + match c with + | Constant (Real a) -> + FStar_Pervasives_Native.Some (FStarC_Compiler_Real.Real a) + | uu___ -> FStar_Pervasives_Native.None in + mk_emb' em1 un1 + (fun uu___ -> lid_as_typ FStarC_Parser_Const.real_lid [] []) + (FStarC_Syntax_Embeddings_Base.emb_typ_of FStarC_Syntax_Embeddings.e_real) +let (e_fsint : Prims.int embedding) = + embed_as e_int FStarC_BigInt.to_int_fs FStarC_BigInt.of_int_fs + FStar_Pervasives_Native.None +let e_option : + 'a . 'a embedding -> 'a FStar_Pervasives_Native.option embedding = + fun ea -> + let etyp uu___ = + let uu___1 = + let uu___2 = + FStarC_Ident.string_of_lid FStarC_Parser_Const.option_lid in + let uu___3 = let uu___4 = ea.e_typ () in [uu___4] in (uu___2, uu___3) in + FStarC_Syntax_Syntax.ET_app uu___1 in + let em1 cb o = + lazy_embed etyp o + (fun uu___ -> + match o with + | FStar_Pervasives_Native.None -> + let uu___1 = + let uu___2 = let uu___3 = type_of ea in as_iarg uu___3 in + [uu___2] in + lid_as_constr FStarC_Parser_Const.none_lid + [FStarC_Syntax_Syntax.U_zero] uu___1 + | FStar_Pervasives_Native.Some x -> + let uu___1 = + let uu___2 = let uu___3 = embed ea cb x in as_arg uu___3 in + let uu___3 = + let uu___4 = let uu___5 = type_of ea in as_iarg uu___5 in + [uu___4] in + uu___2 :: uu___3 in + lid_as_constr FStarC_Parser_Const.some_lid + [FStarC_Syntax_Syntax.U_zero] uu___1) in + let un1 cb trm = + lazy_unembed etyp trm + (fun trm1 -> + match trm1.nbe_t with + | Construct (fvar, us, args1) when + FStarC_Syntax_Syntax.fv_eq_lid fvar + FStarC_Parser_Const.none_lid + -> FStar_Pervasives_Native.Some FStar_Pervasives_Native.None + | Construct (fvar, us, (a1, uu___)::uu___1::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fvar + FStarC_Parser_Const.some_lid + -> + let uu___2 = unembed ea cb a1 in + FStarC_Compiler_Util.bind_opt uu___2 + (fun a2 -> + FStar_Pervasives_Native.Some + (FStar_Pervasives_Native.Some a2)) + | uu___ -> FStar_Pervasives_Native.None) in + mk_emb em1 un1 + (fun uu___ -> + let uu___1 = + let uu___2 = let uu___3 = type_of ea in as_arg uu___3 in [uu___2] in + lid_as_typ FStarC_Parser_Const.option_lid + [FStarC_Syntax_Syntax.U_zero] uu___1) etyp +let e_tuple2 : 'a 'b . 'a embedding -> 'b embedding -> ('a * 'b) embedding = + fun ea -> + fun eb -> + let etyp uu___ = + let uu___1 = + let uu___2 = + FStarC_Ident.string_of_lid FStarC_Parser_Const.lid_tuple2 in + let uu___3 = + let uu___4 = ea.e_typ () in + let uu___5 = let uu___6 = eb.e_typ () in [uu___6] in uu___4 :: + uu___5 in + (uu___2, uu___3) in + FStarC_Syntax_Syntax.ET_app uu___1 in + let em1 cb x = + lazy_embed etyp x + (fun uu___ -> + let uu___1 = + let uu___2 = + let uu___3 = embed eb cb (FStar_Pervasives_Native.snd x) in + as_arg uu___3 in + let uu___3 = + let uu___4 = + let uu___5 = embed ea cb (FStar_Pervasives_Native.fst x) in + as_arg uu___5 in + let uu___5 = + let uu___6 = let uu___7 = type_of eb in as_iarg uu___7 in + let uu___7 = + let uu___8 = let uu___9 = type_of ea in as_iarg uu___9 in + [uu___8] in + uu___6 :: uu___7 in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + lid_as_constr FStarC_Parser_Const.lid_Mktuple2 + [FStarC_Syntax_Syntax.U_zero; FStarC_Syntax_Syntax.U_zero] + uu___1) in + let un1 cb trm = + lazy_unembed etyp trm + (fun uu___ -> + (fun trm1 -> + match trm1.nbe_t with + | Construct + (fvar, us, (b1, uu___)::(a1, uu___1)::uu___2::uu___3::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fvar + FStarC_Parser_Const.lid_Mktuple2 + -> + Obj.magic + (Obj.repr + (let uu___4 = unembed ea cb a1 in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () + (Obj.magic uu___4) + (fun uu___5 -> + (fun a2 -> + let a2 = Obj.magic a2 in + let uu___5 = unembed eb cb b1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () + (Obj.magic uu___5) + (fun uu___6 -> + (fun b2 -> + let b2 = Obj.magic b2 in + Obj.magic + (FStar_Pervasives_Native.Some + (a2, b2))) uu___6))) uu___5))) + | uu___ -> Obj.magic (Obj.repr FStar_Pervasives_Native.None)) + uu___) in + mk_emb em1 un1 + (fun uu___ -> + let uu___1 = + let uu___2 = let uu___3 = type_of eb in as_arg uu___3 in + let uu___3 = + let uu___4 = let uu___5 = type_of ea in as_arg uu___5 in + [uu___4] in + uu___2 :: uu___3 in + lid_as_typ FStarC_Parser_Const.lid_tuple2 + [FStarC_Syntax_Syntax.U_zero; FStarC_Syntax_Syntax.U_zero] + uu___1) etyp +let e_tuple3 : + 'a 'b 'c . + 'a embedding -> 'b embedding -> 'c embedding -> ('a * 'b * 'c) embedding + = + fun ea -> + fun eb -> + fun ec -> + let etyp uu___ = + let uu___1 = + let uu___2 = + FStarC_Ident.string_of_lid FStarC_Parser_Const.lid_tuple3 in + let uu___3 = + let uu___4 = ea.e_typ () in + let uu___5 = + let uu___6 = eb.e_typ () in + let uu___7 = let uu___8 = ec.e_typ () in [uu___8] in uu___6 + :: uu___7 in + uu___4 :: uu___5 in + (uu___2, uu___3) in + FStarC_Syntax_Syntax.ET_app uu___1 in + let em1 cb uu___ = + match uu___ with + | (x1, x2, x3) -> + lazy_embed etyp (x1, x2, x3) + (fun uu___1 -> + let uu___2 = + let uu___3 = + let uu___4 = embed ec cb x3 in as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = embed eb cb x2 in as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = embed ea cb x1 in as_arg uu___8 in + let uu___8 = + let uu___9 = + let uu___10 = type_of ec in as_iarg uu___10 in + let uu___10 = + let uu___11 = + let uu___12 = type_of eb in as_iarg uu___12 in + let uu___12 = + let uu___13 = + let uu___14 = type_of ea in as_iarg uu___14 in + [uu___13] in + uu___11 :: uu___12 in + uu___9 :: uu___10 in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + lid_as_constr FStarC_Parser_Const.lid_Mktuple3 + [FStarC_Syntax_Syntax.U_zero; + FStarC_Syntax_Syntax.U_zero; + FStarC_Syntax_Syntax.U_zero] uu___2) in + let un1 cb trm = + lazy_unembed etyp trm + (fun uu___ -> + (fun trm1 -> + match trm1.nbe_t with + | Construct + (fvar, us, + (c1, uu___)::(b1, uu___1)::(a1, uu___2)::uu___3::uu___4::uu___5::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fvar + FStarC_Parser_Const.lid_Mktuple3 + -> + Obj.magic + (Obj.repr + (let uu___6 = unembed ea cb a1 in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () + (Obj.magic uu___6) + (fun uu___7 -> + (fun a2 -> + let a2 = Obj.magic a2 in + let uu___7 = unembed eb cb b1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () + () (Obj.magic uu___7) + (fun uu___8 -> + (fun b2 -> + let b2 = Obj.magic b2 in + let uu___8 = unembed ec cb c1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___8) + (fun uu___9 -> + (fun c2 -> + let c2 = + Obj.magic c2 in + Obj.magic + (FStar_Pervasives_Native.Some + (a2, b2, c2))) + uu___9))) uu___8))) + uu___7))) + | uu___ -> + Obj.magic (Obj.repr FStar_Pervasives_Native.None)) + uu___) in + mk_emb em1 un1 + (fun uu___ -> + let uu___1 = + let uu___2 = let uu___3 = type_of ec in as_arg uu___3 in + let uu___3 = + let uu___4 = let uu___5 = type_of eb in as_arg uu___5 in + let uu___5 = + let uu___6 = let uu___7 = type_of ea in as_arg uu___7 in + [uu___6] in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + lid_as_typ FStarC_Parser_Const.lid_tuple3 + [FStarC_Syntax_Syntax.U_zero; + FStarC_Syntax_Syntax.U_zero; + FStarC_Syntax_Syntax.U_zero] uu___1) etyp +let e_tuple4 : + 'a 'b 'c 'd . + 'a embedding -> + 'b embedding -> + 'c embedding -> 'd embedding -> ('a * 'b * 'c * 'd) embedding + = + fun ea -> + fun eb -> + fun ec -> + fun ed -> + let etyp uu___ = + let uu___1 = + let uu___2 = + FStarC_Ident.string_of_lid FStarC_Parser_Const.lid_tuple4 in + let uu___3 = + let uu___4 = ea.e_typ () in + let uu___5 = + let uu___6 = eb.e_typ () in + let uu___7 = + let uu___8 = ec.e_typ () in + let uu___9 = let uu___10 = ed.e_typ () in [uu___10] in + uu___8 :: uu___9 in + uu___6 :: uu___7 in + uu___4 :: uu___5 in + (uu___2, uu___3) in + FStarC_Syntax_Syntax.ET_app uu___1 in + let em1 cb uu___ = + match uu___ with + | (x1, x2, x3, x4) -> + lazy_embed etyp (x1, x2, x3, x4) + (fun uu___1 -> + let uu___2 = + let uu___3 = + let uu___4 = embed ed cb x4 in as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = embed ec cb x3 in as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = embed eb cb x2 in as_arg uu___8 in + let uu___8 = + let uu___9 = + let uu___10 = embed ea cb x1 in as_arg uu___10 in + let uu___10 = + let uu___11 = + let uu___12 = type_of ed in as_iarg uu___12 in + let uu___12 = + let uu___13 = + let uu___14 = type_of ec in + as_iarg uu___14 in + let uu___14 = + let uu___15 = + let uu___16 = type_of eb in + as_iarg uu___16 in + let uu___16 = + let uu___17 = + let uu___18 = type_of ea in + as_iarg uu___18 in + [uu___17] in + uu___15 :: uu___16 in + uu___13 :: uu___14 in + uu___11 :: uu___12 in + uu___9 :: uu___10 in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + lid_as_constr FStarC_Parser_Const.lid_Mktuple4 + [FStarC_Syntax_Syntax.U_zero; + FStarC_Syntax_Syntax.U_zero; + FStarC_Syntax_Syntax.U_zero; + FStarC_Syntax_Syntax.U_zero] uu___2) in + let un1 cb trm = + lazy_unembed etyp trm + (fun uu___ -> + (fun trm1 -> + match trm1.nbe_t with + | Construct + (fvar, us, + (d1, uu___)::(c1, uu___1)::(b1, uu___2)::(a1, + uu___3)::uu___4::uu___5::uu___6::uu___7::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fvar + FStarC_Parser_Const.lid_Mktuple4 + -> + Obj.magic + (Obj.repr + (let uu___8 = unembed ea cb a1 in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () + (Obj.magic uu___8) + (fun uu___9 -> + (fun a2 -> + let a2 = Obj.magic a2 in + let uu___9 = unembed eb cb b1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () + () (Obj.magic uu___9) + (fun uu___10 -> + (fun b2 -> + let b2 = Obj.magic b2 in + let uu___10 = + unembed ec cb c1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () + (Obj.magic uu___10) + (fun uu___11 -> + (fun c2 -> + let c2 = + Obj.magic c2 in + let uu___11 = + unembed ed cb + d1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () + (Obj.magic + uu___11) + (fun uu___12 + -> + (fun d2 + -> + let d2 = + Obj.magic + d2 in + Obj.magic + (FStar_Pervasives_Native.Some + (a2, b2, + c2, d2))) + uu___12))) + uu___11))) uu___10))) + uu___9))) + | uu___ -> + Obj.magic (Obj.repr FStar_Pervasives_Native.None)) + uu___) in + mk_emb em1 un1 + (fun uu___ -> + let uu___1 = + let uu___2 = let uu___3 = type_of ed in as_arg uu___3 in + let uu___3 = + let uu___4 = let uu___5 = type_of ec in as_arg uu___5 in + let uu___5 = + let uu___6 = let uu___7 = type_of eb in as_arg uu___7 in + let uu___7 = + let uu___8 = let uu___9 = type_of ea in as_arg uu___9 in + [uu___8] in + uu___6 :: uu___7 in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + lid_as_typ FStarC_Parser_Const.lid_tuple4 + [FStarC_Syntax_Syntax.U_zero; + FStarC_Syntax_Syntax.U_zero; + FStarC_Syntax_Syntax.U_zero; + FStarC_Syntax_Syntax.U_zero] uu___1) etyp +let e_tuple5 : + 'a 'b 'c 'd 'e . + 'a embedding -> + 'b embedding -> + 'c embedding -> + 'd embedding -> 'e embedding -> ('a * 'b * 'c * 'd * 'e) embedding + = + fun ea -> + fun eb -> + fun ec -> + fun ed -> + fun ee -> + let etyp uu___ = + let uu___1 = + let uu___2 = + FStarC_Ident.string_of_lid FStarC_Parser_Const.lid_tuple5 in + let uu___3 = + let uu___4 = ea.e_typ () in + let uu___5 = + let uu___6 = eb.e_typ () in + let uu___7 = + let uu___8 = ec.e_typ () in + let uu___9 = + let uu___10 = ed.e_typ () in + let uu___11 = let uu___12 = ee.e_typ () in [uu___12] in + uu___10 :: uu___11 in + uu___8 :: uu___9 in + uu___6 :: uu___7 in + uu___4 :: uu___5 in + (uu___2, uu___3) in + FStarC_Syntax_Syntax.ET_app uu___1 in + let em1 cb uu___ = + match uu___ with + | (x1, x2, x3, x4, x5) -> + lazy_embed etyp (x1, x2, x3, x4, x5) + (fun uu___1 -> + let uu___2 = + let uu___3 = + let uu___4 = embed ee cb x5 in as_arg uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = embed ed cb x4 in as_arg uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = embed ec cb x3 in as_arg uu___8 in + let uu___8 = + let uu___9 = + let uu___10 = embed eb cb x2 in + as_arg uu___10 in + let uu___10 = + let uu___11 = + let uu___12 = embed ea cb x1 in + as_arg uu___12 in + let uu___12 = + let uu___13 = + let uu___14 = type_of ee in + as_iarg uu___14 in + let uu___14 = + let uu___15 = + let uu___16 = type_of ed in + as_iarg uu___16 in + let uu___16 = + let uu___17 = + let uu___18 = type_of ec in + as_iarg uu___18 in + let uu___18 = + let uu___19 = + let uu___20 = type_of eb in + as_iarg uu___20 in + let uu___20 = + let uu___21 = + let uu___22 = type_of ea in + as_iarg uu___22 in + [uu___21] in + uu___19 :: uu___20 in + uu___17 :: uu___18 in + uu___15 :: uu___16 in + uu___13 :: uu___14 in + uu___11 :: uu___12 in + uu___9 :: uu___10 in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + lid_as_constr FStarC_Parser_Const.lid_Mktuple5 + [FStarC_Syntax_Syntax.U_zero; + FStarC_Syntax_Syntax.U_zero; + FStarC_Syntax_Syntax.U_zero; + FStarC_Syntax_Syntax.U_zero; + FStarC_Syntax_Syntax.U_zero] uu___2) in + let un1 cb trm = + lazy_unembed etyp trm + (fun uu___ -> + (fun trm1 -> + match trm1.nbe_t with + | Construct + (fvar, us, + (e1, uu___)::(d1, uu___1)::(c1, uu___2)::(b1, + uu___3):: + (a1, uu___4)::uu___5::uu___6::uu___7::uu___8::uu___9::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fvar + FStarC_Parser_Const.lid_Mktuple5 + -> + Obj.magic + (Obj.repr + (let uu___10 = unembed ea cb a1 in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () + (Obj.magic uu___10) + (fun uu___11 -> + (fun a2 -> + let a2 = Obj.magic a2 in + let uu___11 = unembed eb cb b1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___11) + (fun uu___12 -> + (fun b2 -> + let b2 = Obj.magic b2 in + let uu___12 = + unembed ec cb c1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () + (Obj.magic uu___12) + (fun uu___13 -> + (fun c2 -> + let c2 = + Obj.magic c2 in + let uu___13 = + unembed ed cb + d1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () + (Obj.magic + uu___13) + (fun + uu___14 + -> + (fun d2 + -> + let d2 = + Obj.magic + d2 in + let uu___14 + = + unembed + ee cb e1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () + (Obj.magic + uu___14) + (fun + uu___15 + -> + (fun e2 + -> + let e2 = + Obj.magic + e2 in + Obj.magic + (FStar_Pervasives_Native.Some + (a2, b2, + c2, d2, + e2))) + uu___15))) + uu___14))) + uu___13))) + uu___12))) uu___11))) + | uu___ -> + Obj.magic (Obj.repr FStar_Pervasives_Native.None)) + uu___) in + mk_emb em1 un1 + (fun uu___ -> + let uu___1 = + let uu___2 = let uu___3 = type_of ee in as_arg uu___3 in + let uu___3 = + let uu___4 = let uu___5 = type_of ed in as_arg uu___5 in + let uu___5 = + let uu___6 = let uu___7 = type_of ec in as_arg uu___7 in + let uu___7 = + let uu___8 = + let uu___9 = type_of eb in as_arg uu___9 in + let uu___9 = + let uu___10 = + let uu___11 = type_of ea in as_arg uu___11 in + [uu___10] in + uu___8 :: uu___9 in + uu___6 :: uu___7 in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + lid_as_typ FStarC_Parser_Const.lid_tuple5 + [FStarC_Syntax_Syntax.U_zero; + FStarC_Syntax_Syntax.U_zero; + FStarC_Syntax_Syntax.U_zero; + FStarC_Syntax_Syntax.U_zero; + FStarC_Syntax_Syntax.U_zero] uu___1) etyp +let e_either : + 'a 'b . + 'a embedding -> + 'b embedding -> ('a, 'b) FStar_Pervasives.either embedding + = + fun ea -> + fun eb -> + let etyp uu___ = + let uu___1 = + let uu___2 = + FStarC_Ident.string_of_lid FStarC_Parser_Const.either_lid in + let uu___3 = + let uu___4 = ea.e_typ () in + let uu___5 = let uu___6 = eb.e_typ () in [uu___6] in uu___4 :: + uu___5 in + (uu___2, uu___3) in + FStarC_Syntax_Syntax.ET_app uu___1 in + let em1 cb s = + lazy_embed etyp s + (fun uu___ -> + match s with + | FStar_Pervasives.Inl a1 -> + let uu___1 = + let uu___2 = let uu___3 = embed ea cb a1 in as_arg uu___3 in + let uu___3 = + let uu___4 = let uu___5 = type_of eb in as_iarg uu___5 in + let uu___5 = + let uu___6 = let uu___7 = type_of ea in as_iarg uu___7 in + [uu___6] in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + lid_as_constr FStarC_Parser_Const.inl_lid + [FStarC_Syntax_Syntax.U_zero; FStarC_Syntax_Syntax.U_zero] + uu___1 + | FStar_Pervasives.Inr b1 -> + let uu___1 = + let uu___2 = let uu___3 = embed eb cb b1 in as_arg uu___3 in + let uu___3 = + let uu___4 = let uu___5 = type_of eb in as_iarg uu___5 in + let uu___5 = + let uu___6 = let uu___7 = type_of ea in as_iarg uu___7 in + [uu___6] in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + lid_as_constr FStarC_Parser_Const.inr_lid + [FStarC_Syntax_Syntax.U_zero; FStarC_Syntax_Syntax.U_zero] + uu___1) in + let un1 cb trm = + lazy_unembed etyp trm + (fun trm1 -> + match trm1.nbe_t with + | Construct (fvar, us, (a1, uu___)::uu___1::uu___2::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fvar + FStarC_Parser_Const.inl_lid + -> + let uu___3 = unembed ea cb a1 in + FStarC_Compiler_Util.bind_opt uu___3 + (fun a2 -> + FStar_Pervasives_Native.Some (FStar_Pervasives.Inl a2)) + | Construct (fvar, us, (b1, uu___)::uu___1::uu___2::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fvar + FStarC_Parser_Const.inr_lid + -> + let uu___3 = unembed eb cb b1 in + FStarC_Compiler_Util.bind_opt uu___3 + (fun b2 -> + FStar_Pervasives_Native.Some (FStar_Pervasives.Inr b2)) + | uu___ -> FStar_Pervasives_Native.None) in + mk_emb em1 un1 + (fun uu___ -> + let uu___1 = + let uu___2 = let uu___3 = type_of eb in as_arg uu___3 in + let uu___3 = + let uu___4 = let uu___5 = type_of ea in as_arg uu___5 in + [uu___4] in + uu___2 :: uu___3 in + lid_as_typ FStarC_Parser_Const.either_lid + [FStarC_Syntax_Syntax.U_zero; FStarC_Syntax_Syntax.U_zero] + uu___1) etyp +let (e___range : FStarC_Compiler_Range_Type.range embedding) = + let em1 cb r = Constant (Range r) in + let un1 cb t1 = + match t1 with + | Constant (Range r) -> FStar_Pervasives_Native.Some r + | uu___ -> FStar_Pervasives_Native.None in + mk_emb' em1 un1 + (fun uu___ -> lid_as_typ FStarC_Parser_Const.__range_lid [] []) + (FStarC_Syntax_Embeddings_Base.emb_typ_of + FStarC_Syntax_Embeddings.e_range) +let e_sealed : + 'a . 'a embedding -> 'a FStarC_Compiler_Sealed.sealed embedding = + fun ea -> + let etyp uu___ = + let uu___1 = + let uu___2 = + FStarC_Ident.string_of_lid FStarC_Parser_Const.sealed_lid in + let uu___3 = let uu___4 = ea.e_typ () in [uu___4] in (uu___2, uu___3) in + FStarC_Syntax_Syntax.ET_app uu___1 in + let em1 cb x = + lazy_embed etyp x + (fun uu___ -> + let uu___1 = + let uu___2 = + let uu___3 = embed ea cb (FStarC_Compiler_Sealed.unseal x) in + as_arg uu___3 in + let uu___3 = + let uu___4 = let uu___5 = type_of ea in as_iarg uu___5 in + [uu___4] in + uu___2 :: uu___3 in + lid_as_constr FStarC_Parser_Const.seal_lid + [FStarC_Syntax_Syntax.U_zero] uu___1) in + let un1 cb trm = + lazy_unembed etyp trm + (fun uu___ -> + (fun trm1 -> + match trm1.nbe_t with + | Construct (fvar, us, (a1, uu___)::uu___1::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fvar + FStarC_Parser_Const.seal_lid + -> + Obj.magic + (Obj.repr + (let uu___2 = unembed ea cb a1 in + FStarC_Class_Monad.fmap + FStarC_Class_Monad.monad_option () () + (fun uu___3 -> + (Obj.magic FStarC_Compiler_Sealed.seal) uu___3) + (Obj.magic uu___2))) + | uu___ -> Obj.magic (Obj.repr FStar_Pervasives_Native.None)) + uu___) in + mk_emb em1 un1 + (fun uu___ -> + let uu___1 = + let uu___2 = let uu___3 = type_of ea in as_arg uu___3 in [uu___2] in + lid_as_typ FStarC_Parser_Const.sealed_lid + [FStarC_Syntax_Syntax.U_zero] uu___1) etyp +let (e_range : FStarC_Compiler_Range_Type.range embedding) = + embed_as (e_sealed e___range) FStarC_Compiler_Sealed.unseal + FStarC_Compiler_Sealed.seal FStar_Pervasives_Native.None +let (e_issue : FStarC_Errors.issue embedding) = + let t_issue = + FStarC_Syntax_Embeddings_Base.type_of FStarC_Syntax_Embeddings.e_issue in + let li blob rng = + let uu___ = FStarC_Dyn.mkdyn blob in + { + FStarC_Syntax_Syntax.blob = uu___; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_issue; + FStarC_Syntax_Syntax.ltyp = t_issue; + FStarC_Syntax_Syntax.rng = rng + } in + let em1 cb iss = + let uu___ = + let uu___1 = + let uu___2 = li iss FStarC_Compiler_Range_Type.dummyRange in + FStar_Pervasives.Inl uu___2 in + let uu___2 = + FStarC_Thunk.mk (fun uu___3 -> failwith "Cannot unembed issue") in + (uu___1, uu___2) in + Lazy uu___ in + let un1 cb t1 = + match t1 with + | Lazy + (FStar_Pervasives.Inl + { FStarC_Syntax_Syntax.blob = blob; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_issue; + FStarC_Syntax_Syntax.ltyp = uu___; + FStarC_Syntax_Syntax.rng = uu___1;_}, + uu___2) + -> + let uu___3 = FStarC_Dyn.undyn blob in + FStar_Pervasives_Native.Some uu___3 + | uu___ -> FStar_Pervasives_Native.None in + mk_emb' em1 un1 + (fun uu___ -> lid_as_typ FStarC_Parser_Const.issue_lid [] []) + (FStarC_Syntax_Embeddings_Base.emb_typ_of + FStarC_Syntax_Embeddings.e_issue) +let (e_document : FStarC_Pprint.document embedding) = + let t_document = + FStarC_Syntax_Embeddings_Base.type_of FStarC_Syntax_Embeddings.e_document in + let li blob rng = + let uu___ = FStarC_Dyn.mkdyn blob in + { + FStarC_Syntax_Syntax.blob = uu___; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_doc; + FStarC_Syntax_Syntax.ltyp = t_document; + FStarC_Syntax_Syntax.rng = rng + } in + let em1 cb doc = + let uu___ = + let uu___1 = + let uu___2 = li doc FStarC_Compiler_Range_Type.dummyRange in + FStar_Pervasives.Inl uu___2 in + let uu___2 = + FStarC_Thunk.mk (fun uu___3 -> failwith "Cannot unembed document") in + (uu___1, uu___2) in + Lazy uu___ in + let un1 cb t1 = + match t1 with + | Lazy + (FStar_Pervasives.Inl + { FStarC_Syntax_Syntax.blob = blob; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_doc; + FStarC_Syntax_Syntax.ltyp = uu___; + FStarC_Syntax_Syntax.rng = uu___1;_}, + uu___2) + -> + let uu___3 = FStarC_Dyn.undyn blob in + FStar_Pervasives_Native.Some uu___3 + | uu___ -> FStar_Pervasives_Native.None in + mk_emb' em1 un1 + (fun uu___ -> lid_as_typ FStarC_Parser_Const.document_lid [] []) + (FStarC_Syntax_Embeddings_Base.emb_typ_of + FStarC_Syntax_Embeddings.e_document) +let (e_vconfig : FStarC_VConfig.vconfig embedding) = + let em1 cb r = failwith "e_vconfig NBE" in + let un1 cb t1 = failwith "e_vconfig NBE" in + mk_emb' em1 un1 + (fun uu___ -> lid_as_typ FStarC_Parser_Const.vconfig_lid [] []) + (FStarC_Syntax_Embeddings_Base.emb_typ_of + FStarC_Syntax_Embeddings.e_vconfig) +let e_list : 'a . 'a embedding -> 'a Prims.list embedding = + fun ea -> + let etyp uu___ = + let uu___1 = + let uu___2 = FStarC_Ident.string_of_lid FStarC_Parser_Const.list_lid in + let uu___3 = let uu___4 = ea.e_typ () in [uu___4] in (uu___2, uu___3) in + FStarC_Syntax_Syntax.ET_app uu___1 in + let em1 cb l = + lazy_embed etyp l + (fun uu___ -> + let typ1 = let uu___1 = type_of ea in as_iarg uu___1 in + let nil = + lid_as_constr FStarC_Parser_Const.nil_lid + [FStarC_Syntax_Syntax.U_zero] [typ1] in + let cons hd tl = + let uu___1 = + let uu___2 = as_arg tl in + let uu___3 = + let uu___4 = let uu___5 = embed ea cb hd in as_arg uu___5 in + [uu___4; typ1] in + uu___2 :: uu___3 in + lid_as_constr FStarC_Parser_Const.cons_lid + [FStarC_Syntax_Syntax.U_zero] uu___1 in + FStarC_Compiler_List.fold_right cons l nil) in + let rec un1 cb trm = + lazy_unembed etyp trm + (fun trm1 -> + match trm1.nbe_t with + | Construct (fv, uu___, uu___1) when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.nil_lid + -> FStar_Pervasives_Native.Some [] + | Construct + (fv, uu___, + (tl, FStar_Pervasives_Native.None)::(hd, + FStar_Pervasives_Native.None):: + (uu___1, FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = uu___2;_})::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.cons_lid + -> + let uu___3 = unembed ea cb hd in + FStarC_Compiler_Util.bind_opt uu___3 + (fun hd1 -> + let uu___4 = un1 cb tl in + FStarC_Compiler_Util.bind_opt uu___4 + (fun tl1 -> FStar_Pervasives_Native.Some (hd1 :: tl1))) + | Construct + (fv, uu___, + (tl, FStar_Pervasives_Native.None)::(hd, + FStar_Pervasives_Native.None)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.cons_lid + -> + let uu___1 = unembed ea cb hd in + FStarC_Compiler_Util.bind_opt uu___1 + (fun hd1 -> + let uu___2 = un1 cb tl in + FStarC_Compiler_Util.bind_opt uu___2 + (fun tl1 -> FStar_Pervasives_Native.Some (hd1 :: tl1))) + | uu___ -> FStar_Pervasives_Native.None) in + mk_emb em1 un1 + (fun uu___ -> + let uu___1 = + let uu___2 = let uu___3 = type_of ea in as_arg uu___3 in [uu___2] in + lid_as_typ FStarC_Parser_Const.list_lid + [FStarC_Syntax_Syntax.U_zero] uu___1) etyp +let (e_string_list : Prims.string Prims.list embedding) = e_list e_string +let e_arrow : 'a 'b . 'a embedding -> 'b embedding -> ('a -> 'b) embedding = + fun ea -> + fun eb -> + let etyp uu___ = + let uu___1 = + let uu___2 = ea.e_typ () in + let uu___3 = eb.e_typ () in (uu___2, uu___3) in + FStarC_Syntax_Syntax.ET_fun uu___1 in + let em1 cb f = + lazy_embed etyp f + (fun uu___ -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = let uu___6 = type_of eb in as_arg uu___6 in + [uu___5] in + Lam_args uu___4 in + { + interp = + (fun tas -> + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Compiler_List.hd tas in + FStar_Pervasives_Native.fst uu___6 in + unembed ea cb uu___5 in + match uu___4 with + | FStar_Pervasives_Native.Some a1 -> + let uu___5 = f a1 in embed eb cb uu___5 + | FStar_Pervasives_Native.None -> + failwith "cannot unembed function argument"); + shape = uu___3; + arity = Prims.int_one + } in + Lam uu___2 in + mk_t uu___1) in + let un1 cb lam = + let k lam1 = + FStar_Pervasives_Native.Some + (fun x -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = let uu___4 = embed ea cb x in as_arg uu___4 in + [uu___3] in + cb.iapp lam1 uu___2 in + unembed eb cb uu___1 in + match uu___ with + | FStar_Pervasives_Native.Some y -> y + | FStar_Pervasives_Native.None -> + failwith "cannot unembed function result") in + lazy_unembed etyp lam k in + mk_emb em1 un1 + (fun uu___ -> + let uu___1 = type_of ea in + let uu___2 = let uu___3 = type_of eb in as_iarg uu___3 in + make_arrow1 uu___1 uu___2) etyp +let (e_abstract_nbe_term : abstract_nbe_term embedding) = + embed_as e_any (fun x -> AbstractNBE x) + (fun x -> match x with | AbstractNBE x1 -> x1) + FStar_Pervasives_Native.None +let e_unsupported : 'a . unit -> 'a embedding = + fun uu___ -> + let em1 _cb a1 = failwith "Unsupported NBE embedding" in + let un1 _cb t1 = failwith "Unsupported NBE embedding" in + mk_emb em1 un1 + (fun uu___1 -> lid_as_typ FStarC_Parser_Const.term_lid [] []) + (fun uu___1 -> FStarC_Syntax_Syntax.ET_abstract) +let (e_norm_step : FStar_Pervasives.norm_step embedding) = + let em1 cb n = + match n with + | FStar_Pervasives.Simpl -> + let uu___ = + FStarC_Syntax_Syntax.lid_as_fv FStarC_Parser_Const.steps_simpl + FStar_Pervasives_Native.None in + mkFV uu___ [] [] + | FStar_Pervasives.Weak -> + let uu___ = + FStarC_Syntax_Syntax.lid_as_fv FStarC_Parser_Const.steps_weak + FStar_Pervasives_Native.None in + mkFV uu___ [] [] + | FStar_Pervasives.HNF -> + let uu___ = + FStarC_Syntax_Syntax.lid_as_fv FStarC_Parser_Const.steps_hnf + FStar_Pervasives_Native.None in + mkFV uu___ [] [] + | FStar_Pervasives.Primops -> + let uu___ = + FStarC_Syntax_Syntax.lid_as_fv FStarC_Parser_Const.steps_primops + FStar_Pervasives_Native.None in + mkFV uu___ [] [] + | FStar_Pervasives.Delta -> + let uu___ = + FStarC_Syntax_Syntax.lid_as_fv FStarC_Parser_Const.steps_delta + FStar_Pervasives_Native.None in + mkFV uu___ [] [] + | FStar_Pervasives.Zeta -> + let uu___ = + FStarC_Syntax_Syntax.lid_as_fv FStarC_Parser_Const.steps_zeta + FStar_Pervasives_Native.None in + mkFV uu___ [] [] + | FStar_Pervasives.Iota -> + let uu___ = + FStarC_Syntax_Syntax.lid_as_fv FStarC_Parser_Const.steps_iota + FStar_Pervasives_Native.None in + mkFV uu___ [] [] + | FStar_Pervasives.Reify -> + let uu___ = + FStarC_Syntax_Syntax.lid_as_fv FStarC_Parser_Const.steps_reify + FStar_Pervasives_Native.None in + mkFV uu___ [] [] + | FStar_Pervasives.NBE -> + let uu___ = + FStarC_Syntax_Syntax.lid_as_fv FStarC_Parser_Const.steps_nbe + FStar_Pervasives_Native.None in + mkFV uu___ [] [] + | FStar_Pervasives.UnfoldOnly l -> + let uu___ = + FStarC_Syntax_Syntax.lid_as_fv FStarC_Parser_Const.steps_unfoldonly + FStar_Pervasives_Native.None in + let uu___1 = + let uu___2 = + let uu___3 = embed (e_list e_string) cb l in as_arg uu___3 in + [uu___2] in + mkFV uu___ [] uu___1 + | FStar_Pervasives.UnfoldFully l -> + let uu___ = + FStarC_Syntax_Syntax.lid_as_fv + FStarC_Parser_Const.steps_unfoldfully + FStar_Pervasives_Native.None in + let uu___1 = + let uu___2 = + let uu___3 = embed (e_list e_string) cb l in as_arg uu___3 in + [uu___2] in + mkFV uu___ [] uu___1 + | FStar_Pervasives.UnfoldAttr l -> + let uu___ = + FStarC_Syntax_Syntax.lid_as_fv FStarC_Parser_Const.steps_unfoldattr + FStar_Pervasives_Native.None in + let uu___1 = + let uu___2 = + let uu___3 = embed (e_list e_string) cb l in as_arg uu___3 in + [uu___2] in + mkFV uu___ [] uu___1 + | FStar_Pervasives.UnfoldQual l -> + let uu___ = + FStarC_Syntax_Syntax.lid_as_fv FStarC_Parser_Const.steps_unfoldqual + FStar_Pervasives_Native.None in + let uu___1 = + let uu___2 = + let uu___3 = embed (e_list e_string) cb l in as_arg uu___3 in + [uu___2] in + mkFV uu___ [] uu___1 + | FStar_Pervasives.UnfoldNamespace l -> + let uu___ = + FStarC_Syntax_Syntax.lid_as_fv + FStarC_Parser_Const.steps_unfoldnamespace + FStar_Pervasives_Native.None in + let uu___1 = + let uu___2 = + let uu___3 = embed (e_list e_string) cb l in as_arg uu___3 in + [uu___2] in + mkFV uu___ [] uu___1 + | FStar_Pervasives.ZetaFull -> + let uu___ = + FStarC_Syntax_Syntax.lid_as_fv FStarC_Parser_Const.steps_zeta_full + FStar_Pervasives_Native.None in + mkFV uu___ [] [] + | FStar_Pervasives.Unascribe -> + let uu___ = + FStarC_Syntax_Syntax.lid_as_fv FStarC_Parser_Const.steps_unascribe + FStar_Pervasives_Native.None in + mkFV uu___ [] [] in + let un1 cb t0 = + match t0.nbe_t with + | FV (fv, uu___, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.steps_simpl -> + FStar_Pervasives_Native.Some FStar_Pervasives.Simpl + | FV (fv, uu___, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.steps_weak -> + FStar_Pervasives_Native.Some FStar_Pervasives.Weak + | FV (fv, uu___, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.steps_hnf -> + FStar_Pervasives_Native.Some FStar_Pervasives.HNF + | FV (fv, uu___, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.steps_primops + -> FStar_Pervasives_Native.Some FStar_Pervasives.Primops + | FV (fv, uu___, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.steps_delta -> + FStar_Pervasives_Native.Some FStar_Pervasives.Delta + | FV (fv, uu___, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.steps_zeta -> + FStar_Pervasives_Native.Some FStar_Pervasives.Zeta + | FV (fv, uu___, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.steps_iota -> + FStar_Pervasives_Native.Some FStar_Pervasives.Iota + | FV (fv, uu___, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.steps_nbe -> + FStar_Pervasives_Native.Some FStar_Pervasives.NBE + | FV (fv, uu___, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.steps_reify -> + FStar_Pervasives_Native.Some FStar_Pervasives.Reify + | FV (fv, uu___, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.steps_zeta_full + -> FStar_Pervasives_Native.Some FStar_Pervasives.ZetaFull + | FV (fv, uu___, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.steps_unascribe + -> FStar_Pervasives_Native.Some FStar_Pervasives.Unascribe + | FV (fv, uu___, (l, uu___1)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.steps_unfoldonly + -> + let uu___2 = unembed (e_list e_string) cb l in + FStarC_Compiler_Util.bind_opt uu___2 + (fun ss -> + FStar_Pervasives_Native.Some (FStar_Pervasives.UnfoldOnly ss)) + | FV (fv, uu___, (l, uu___1)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.steps_unfoldfully + -> + let uu___2 = unembed (e_list e_string) cb l in + FStarC_Compiler_Util.bind_opt uu___2 + (fun ss -> + FStar_Pervasives_Native.Some (FStar_Pervasives.UnfoldFully ss)) + | FV (fv, uu___, (l, uu___1)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.steps_unfoldattr + -> + let uu___2 = unembed (e_list e_string) cb l in + FStarC_Compiler_Util.bind_opt uu___2 + (fun ss -> + FStar_Pervasives_Native.Some (FStar_Pervasives.UnfoldAttr ss)) + | FV (fv, uu___, (l, uu___1)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.steps_unfoldqual + -> + let uu___2 = unembed (e_list e_string) cb l in + FStarC_Compiler_Util.bind_opt uu___2 + (fun ss -> + FStar_Pervasives_Native.Some (FStar_Pervasives.UnfoldQual ss)) + | FV (fv, uu___, (l, uu___1)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.steps_unfoldnamespace + -> + let uu___2 = unembed (e_list e_string) cb l in + FStarC_Compiler_Util.bind_opt uu___2 + (fun ss -> + FStar_Pervasives_Native.Some + (FStar_Pervasives.UnfoldNamespace ss)) + | uu___ -> + ((let uu___2 = + let uu___3 = t_to_string t0 in + FStarC_Compiler_Util.format1 "Not an embedded norm_step: %s" + uu___3 in + FStarC_Errors.log_issue0 FStarC_Errors_Codes.Warning_NotEmbedded () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + FStar_Pervasives_Native.None) in + mk_emb em1 un1 + (fun uu___ -> + let uu___1 = + FStarC_Syntax_Syntax.lid_as_fv FStarC_Parser_Const.norm_step_lid + FStar_Pervasives_Native.None in + mkFV uu___1 [] []) + (FStarC_Syntax_Embeddings_Base.emb_typ_of + FStarC_Syntax_Embeddings.e_norm_step) +let (bogus_cbs : nbe_cbs) = + { + iapp = (fun h -> fun _args -> h); + translate = (fun uu___ -> failwith "bogus_cbs translate") + } +let (arg_as_int : arg -> FStarC_BigInt.t FStar_Pervasives_Native.option) = + fun a -> unembed e_int bogus_cbs (FStar_Pervasives_Native.fst a) +let (arg_as_bool : arg -> Prims.bool FStar_Pervasives_Native.option) = + fun a -> unembed e_bool bogus_cbs (FStar_Pervasives_Native.fst a) +let arg_as_list : + 'a . 'a embedding -> arg -> 'a Prims.list FStar_Pervasives_Native.option = + fun e -> + fun a1 -> unembed (e_list e) bogus_cbs (FStar_Pervasives_Native.fst a1) +let lift_unary : + 'a 'b . + ('a -> 'b) -> + 'a FStar_Pervasives_Native.option Prims.list -> + 'b FStar_Pervasives_Native.option + = + fun f -> + fun aopts -> + match aopts with + | (FStar_Pervasives_Native.Some a1)::[] -> + let uu___ = f a1 in FStar_Pervasives_Native.Some uu___ + | uu___ -> FStar_Pervasives_Native.None +let lift_binary : + 'a 'b . + ('a -> 'a -> 'b) -> + 'a FStar_Pervasives_Native.option Prims.list -> + 'b FStar_Pervasives_Native.option + = + fun f -> + fun aopts -> + match aopts with + | (FStar_Pervasives_Native.Some a0)::(FStar_Pervasives_Native.Some + a1)::[] -> + let uu___ = f a0 a1 in FStar_Pervasives_Native.Some uu___ + | uu___ -> FStar_Pervasives_Native.None +let mixed_binary_op : + 'a 'b 'c . + (arg -> 'a FStar_Pervasives_Native.option) -> + (arg -> 'b FStar_Pervasives_Native.option) -> + ('c -> t) -> + (FStarC_Syntax_Syntax.universes -> + 'a -> 'b -> 'c FStar_Pervasives_Native.option) + -> + FStarC_Syntax_Syntax.universes -> + args -> t FStar_Pervasives_Native.option + = + fun as_a -> + fun as_b -> + fun embed_c -> + fun f -> + fun us -> + fun args1 -> + match args1 with + | a1::b1::[] -> + let uu___ = + let uu___1 = as_a a1 in + let uu___2 = as_b b1 in (uu___1, uu___2) in + (match uu___ with + | (FStar_Pervasives_Native.Some a2, + FStar_Pervasives_Native.Some b2) -> + let uu___1 = f us a2 b2 in + (match uu___1 with + | FStar_Pervasives_Native.Some c1 -> + let uu___2 = embed_c c1 in + FStar_Pervasives_Native.Some uu___2 + | uu___2 -> FStar_Pervasives_Native.None) + | uu___1 -> FStar_Pervasives_Native.None) + | uu___ -> FStar_Pervasives_Native.None +let mixed_ternary_op : + 'a 'b 'c 'd . + (arg -> 'a FStar_Pervasives_Native.option) -> + (arg -> 'b FStar_Pervasives_Native.option) -> + (arg -> 'c FStar_Pervasives_Native.option) -> + ('d -> t) -> + (FStarC_Syntax_Syntax.universes -> + 'a -> 'b -> 'c -> 'd FStar_Pervasives_Native.option) + -> + FStarC_Syntax_Syntax.universes -> + args -> t FStar_Pervasives_Native.option + = + fun as_a -> + fun as_b -> + fun as_c -> + fun embed_d -> + fun f -> + fun us -> + fun args1 -> + match args1 with + | a1::b1::c1::[] -> + let uu___ = + let uu___1 = as_a a1 in + let uu___2 = as_b b1 in + let uu___3 = as_c c1 in (uu___1, uu___2, uu___3) in + (match uu___ with + | (FStar_Pervasives_Native.Some a2, + FStar_Pervasives_Native.Some b2, + FStar_Pervasives_Native.Some c2) -> + let uu___1 = f us a2 b2 c2 in + (match uu___1 with + | FStar_Pervasives_Native.Some d1 -> + let uu___2 = embed_d d1 in + FStar_Pervasives_Native.Some uu___2 + | uu___2 -> FStar_Pervasives_Native.None) + | uu___1 -> FStar_Pervasives_Native.None) + | uu___ -> FStar_Pervasives_Native.None +let (dummy_interp : + FStarC_Ident.lid -> args -> t FStar_Pervasives_Native.option) = + fun lid -> + fun args1 -> + let uu___ = + let uu___1 = FStarC_Ident.string_of_lid lid in + Prims.strcat "No interpretation for " uu___1 in + failwith uu___ +let (and_op : args -> t FStar_Pervasives_Native.option) = + fun args1 -> + match args1 with + | a1::a2::[] -> + let uu___ = arg_as_bool a1 in + (match uu___ with + | FStar_Pervasives_Native.Some (false) -> + let uu___1 = embed e_bool bogus_cbs false in + FStar_Pervasives_Native.Some uu___1 + | FStar_Pervasives_Native.Some (true) -> + FStar_Pervasives_Native.Some (FStar_Pervasives_Native.fst a2) + | uu___1 -> FStar_Pervasives_Native.None) + | uu___ -> failwith "Unexpected number of arguments" +let (or_op : args -> t FStar_Pervasives_Native.option) = + fun args1 -> + match args1 with + | a1::a2::[] -> + let uu___ = arg_as_bool a1 in + (match uu___ with + | FStar_Pervasives_Native.Some (true) -> + let uu___1 = embed e_bool bogus_cbs true in + FStar_Pervasives_Native.Some uu___1 + | FStar_Pervasives_Native.Some (false) -> + FStar_Pervasives_Native.Some (FStar_Pervasives_Native.fst a2) + | uu___1 -> FStar_Pervasives_Native.None) + | uu___ -> failwith "Unexpected number of arguments" +let arrow_as_prim_step_1 : + 'a 'b . + 'a embedding -> + 'b embedding -> + ('a -> 'b) -> + FStarC_Ident.lid -> + nbe_cbs -> + FStarC_Syntax_Syntax.universes -> + args -> t FStar_Pervasives_Native.option + = + fun ea -> + fun eb -> + fun f -> + fun _fv_lid -> + fun cb -> + let f_wrapped _us args1 = + let uu___ = FStarC_Compiler_List.hd args1 in + match uu___ with + | (x, uu___1) -> + let uu___2 = unembed ea cb x in + FStarC_Compiler_Util.map_opt uu___2 + (fun x1 -> let uu___3 = f x1 in embed eb cb uu___3) in + f_wrapped +let arrow_as_prim_step_2 : + 'a 'b 'c . + 'a embedding -> + 'b embedding -> + 'c embedding -> + ('a -> 'b -> 'c) -> + FStarC_Ident.lid -> + nbe_cbs -> + FStarC_Syntax_Syntax.universes -> + args -> t FStar_Pervasives_Native.option + = + fun ea -> + fun eb -> + fun ec -> + fun f -> + fun _fv_lid -> + fun cb -> + let f_wrapped _us args1 = + let uu___ = FStarC_Compiler_List.hd args1 in + match uu___ with + | (x, uu___1) -> + let uu___2 = + let uu___3 = FStarC_Compiler_List.tl args1 in + FStarC_Compiler_List.hd uu___3 in + (match uu___2 with + | (y, uu___3) -> + let uu___4 = unembed ea cb x in + FStarC_Compiler_Util.bind_opt uu___4 + (fun x1 -> + let uu___5 = unembed eb cb y in + FStarC_Compiler_Util.bind_opt uu___5 + (fun y1 -> + let uu___6 = + let uu___7 = f x1 y1 in + embed ec cb uu___7 in + FStar_Pervasives_Native.Some uu___6))) in + f_wrapped +let arrow_as_prim_step_3 : + 'a 'b 'c 'd . + 'a embedding -> + 'b embedding -> + 'c embedding -> + 'd embedding -> + ('a -> 'b -> 'c -> 'd) -> + FStarC_Ident.lid -> + nbe_cbs -> + FStarC_Syntax_Syntax.universes -> + args -> t FStar_Pervasives_Native.option + = + fun ea -> + fun eb -> + fun ec -> + fun ed -> + fun f -> + fun _fv_lid -> + fun cb -> + let f_wrapped _us args1 = + let uu___ = FStarC_Compiler_List.hd args1 in + match uu___ with + | (x, uu___1) -> + let uu___2 = + let uu___3 = FStarC_Compiler_List.tl args1 in + FStarC_Compiler_List.hd uu___3 in + (match uu___2 with + | (y, uu___3) -> + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Compiler_List.tl args1 in + FStarC_Compiler_List.tl uu___6 in + FStarC_Compiler_List.hd uu___5 in + (match uu___4 with + | (z, uu___5) -> + let uu___6 = unembed ea cb x in + FStarC_Compiler_Util.bind_opt uu___6 + (fun x1 -> + let uu___7 = unembed eb cb y in + FStarC_Compiler_Util.bind_opt uu___7 + (fun y1 -> + let uu___8 = unembed ec cb z in + FStarC_Compiler_Util.bind_opt + uu___8 + (fun z1 -> + let uu___9 = + let uu___10 = f x1 y1 z1 in + embed ed cb uu___10 in + FStar_Pervasives_Native.Some + uu___9))))) in + f_wrapped +let (e_order : FStar_Order.order embedding) = + let ord_Lt_lid = + FStarC_Ident.lid_of_path ["FStar"; "Order"; "Lt"] + FStarC_Compiler_Range_Type.dummyRange in + let ord_Eq_lid = + FStarC_Ident.lid_of_path ["FStar"; "Order"; "Eq"] + FStarC_Compiler_Range_Type.dummyRange in + let ord_Gt_lid = + FStarC_Ident.lid_of_path ["FStar"; "Order"; "Gt"] + FStarC_Compiler_Range_Type.dummyRange in + let ord_Lt = FStarC_Syntax_Syntax.tdataconstr ord_Lt_lid in + let ord_Eq = FStarC_Syntax_Syntax.tdataconstr ord_Eq_lid in + let ord_Gt = FStarC_Syntax_Syntax.tdataconstr ord_Gt_lid in + let ord_Lt_fv = + FStarC_Syntax_Syntax.lid_as_fv ord_Lt_lid + (FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.Data_ctor) in + let ord_Eq_fv = + FStarC_Syntax_Syntax.lid_as_fv ord_Eq_lid + (FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.Data_ctor) in + let ord_Gt_fv = + FStarC_Syntax_Syntax.lid_as_fv ord_Gt_lid + (FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.Data_ctor) in + let embed_order cb o = + match o with + | FStar_Order.Lt -> mkConstruct ord_Lt_fv [] [] + | FStar_Order.Eq -> mkConstruct ord_Eq_fv [] [] + | FStar_Order.Gt -> mkConstruct ord_Gt_fv [] [] in + let unembed_order cb t1 = + match t1.nbe_t with + | Construct (fv, uu___, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv ord_Lt_lid -> + FStar_Pervasives_Native.Some FStar_Order.Lt + | Construct (fv, uu___, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv ord_Eq_lid -> + FStar_Pervasives_Native.Some FStar_Order.Eq + | Construct (fv, uu___, []) when + FStarC_Syntax_Syntax.fv_eq_lid fv ord_Gt_lid -> + FStar_Pervasives_Native.Some FStar_Order.Gt + | uu___ -> FStar_Pervasives_Native.None in + let fv_as_emb_typ fv = + let uu___ = + let uu___1 = + FStarC_Ident.string_of_lid + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + (uu___1, []) in + FStarC_Syntax_Syntax.ET_app uu___ in + let fv = + FStarC_Syntax_Syntax.lid_as_fv FStarC_Parser_Const.order_lid + FStar_Pervasives_Native.None in + mk_emb embed_order unembed_order (fun uu___ -> mkFV fv [] []) + (fun uu___ -> fv_as_emb_typ fv) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_Normalize.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Normalize.ml new file mode 100644 index 00000000000..7975f23357b --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Normalize.ml @@ -0,0 +1,9394 @@ +open Prims +let (dbg_univ_norm : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "univ_norm" +let (dbg_NormRebuild : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "NormRebuild" +let (maybe_debug : + FStarC_TypeChecker_Cfg.cfg -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * FStarC_Compiler_Util.time) + FStar_Pervasives_Native.option -> unit) + = + fun cfg -> + fun t -> + fun dbg -> + if + (cfg.FStarC_TypeChecker_Cfg.debug).FStarC_TypeChecker_Cfg.print_normalized + then + match dbg with + | FStar_Pervasives_Native.Some (tm, time_then) -> + let time_now = FStarC_Compiler_Util.now () in + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Compiler_Util.time_diff time_then time_now in + FStar_Pervasives_Native.snd uu___2 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) uu___1 in + let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term tm in + let uu___2 = + FStarC_Class_Show.show FStarC_TypeChecker_Cfg.showable_cfg + cfg in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.print4 + "Normalizer result timing (%s ms){\nOn term {\n%s\n}\nwith steps {%s}\nresult is{\n\n%s\n}\n}\n" + uu___ uu___1 uu___2 uu___3 + | uu___ -> () + else () +let cases : + 'uuuuu 'uuuuu1 . + ('uuuuu -> 'uuuuu1) -> + 'uuuuu1 -> 'uuuuu FStar_Pervasives_Native.option -> 'uuuuu1 + = + fun f -> + fun d -> + fun uu___ -> + match uu___ with + | FStar_Pervasives_Native.Some x -> f x + | FStar_Pervasives_Native.None -> d +type 'a cfg_memo = + (FStarC_TypeChecker_Cfg.cfg * 'a) FStarC_Syntax_Syntax.memo +let fresh_memo : 'a . unit -> 'a FStarC_Syntax_Syntax.memo = + fun uu___ -> FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None +type closure = + | Clos of ((FStarC_Syntax_Syntax.binder FStar_Pervasives_Native.option * + closure * FStarC_Syntax_Syntax.subst_t FStarC_Syntax_Syntax.memo) + Prims.list * FStarC_Syntax_Syntax.term * ((FStarC_Syntax_Syntax.binder + FStar_Pervasives_Native.option * closure * FStarC_Syntax_Syntax.subst_t + FStarC_Syntax_Syntax.memo) Prims.list * FStarC_Syntax_Syntax.term) cfg_memo + * Prims.bool) + | Univ of FStarC_Syntax_Syntax.universe + | Dummy +let (uu___is_Clos : closure -> Prims.bool) = + fun projectee -> match projectee with | Clos _0 -> true | uu___ -> false +let (__proj__Clos__item___0 : + closure -> + ((FStarC_Syntax_Syntax.binder FStar_Pervasives_Native.option * closure * + FStarC_Syntax_Syntax.subst_t FStarC_Syntax_Syntax.memo) Prims.list * + FStarC_Syntax_Syntax.term * ((FStarC_Syntax_Syntax.binder + FStar_Pervasives_Native.option * closure * FStarC_Syntax_Syntax.subst_t + FStarC_Syntax_Syntax.memo) Prims.list * FStarC_Syntax_Syntax.term) + cfg_memo * Prims.bool)) + = fun projectee -> match projectee with | Clos _0 -> _0 +let (uu___is_Univ : closure -> Prims.bool) = + fun projectee -> match projectee with | Univ _0 -> true | uu___ -> false +let (__proj__Univ__item___0 : closure -> FStarC_Syntax_Syntax.universe) = + fun projectee -> match projectee with | Univ _0 -> _0 +let (uu___is_Dummy : closure -> Prims.bool) = + fun projectee -> match projectee with | Dummy -> true | uu___ -> false +type env = + (FStarC_Syntax_Syntax.binder FStar_Pervasives_Native.option * closure * + FStarC_Syntax_Syntax.subst_t FStarC_Syntax_Syntax.memo) Prims.list +let showable_memo : + 'a . + 'a FStarC_Class_Show.showable -> + 'a FStarC_Syntax_Syntax.memo FStarC_Class_Show.showable + = + fun uu___ -> + { + FStarC_Class_Show.show = + (fun m -> + let uu___1 = FStarC_Compiler_Effect.op_Bang m in + match uu___1 with + | FStar_Pervasives_Native.None -> "no_memo" + | FStar_Pervasives_Native.Some x -> + let uu___2 = FStarC_Class_Show.show uu___ x in + Prims.strcat "memo=" uu___2) + } +let (empty_env : env) = [] +let (dummy : + unit -> + (FStarC_Syntax_Syntax.binder FStar_Pervasives_Native.option * closure * + FStarC_Syntax_Syntax.subst_t FStarC_Syntax_Syntax.memo)) + = + fun uu___ -> + let uu___1 = fresh_memo () in + (FStar_Pervasives_Native.None, Dummy, uu___1) +type branches = + (FStarC_Syntax_Syntax.pat * FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option * FStarC_Syntax_Syntax.term) Prims.list +type stack_elt = + | Arg of (closure * FStarC_Syntax_Syntax.aqual * + FStarC_Compiler_Range_Type.range) + | UnivArgs of (FStarC_Syntax_Syntax.universe Prims.list * + FStarC_Compiler_Range_Type.range) + | MemoLazy of (env * FStarC_Syntax_Syntax.term) cfg_memo + | Match of (env * FStarC_Syntax_Syntax.match_returns_ascription + FStar_Pervasives_Native.option * branches * + FStarC_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option * + FStarC_TypeChecker_Cfg.cfg * FStarC_Compiler_Range_Type.range) + | Abs of (env * FStarC_Syntax_Syntax.binders * env * + FStarC_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option * + FStarC_Compiler_Range_Type.range) + | App of (env * FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.aqual * + FStarC_Compiler_Range_Type.range) + | CBVApp of (env * FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.aqual * + FStarC_Compiler_Range_Type.range) + | Meta of (env * FStarC_Syntax_Syntax.metadata * + FStarC_Compiler_Range_Type.range) + | Let of (env * FStarC_Syntax_Syntax.binders * + FStarC_Syntax_Syntax.letbinding * FStarC_Compiler_Range_Type.range) +let (uu___is_Arg : stack_elt -> Prims.bool) = + fun projectee -> match projectee with | Arg _0 -> true | uu___ -> false +let (__proj__Arg__item___0 : + stack_elt -> + (closure * FStarC_Syntax_Syntax.aqual * FStarC_Compiler_Range_Type.range)) + = fun projectee -> match projectee with | Arg _0 -> _0 +let (uu___is_UnivArgs : stack_elt -> Prims.bool) = + fun projectee -> + match projectee with | UnivArgs _0 -> true | uu___ -> false +let (__proj__UnivArgs__item___0 : + stack_elt -> + (FStarC_Syntax_Syntax.universe Prims.list * + FStarC_Compiler_Range_Type.range)) + = fun projectee -> match projectee with | UnivArgs _0 -> _0 +let (uu___is_MemoLazy : stack_elt -> Prims.bool) = + fun projectee -> + match projectee with | MemoLazy _0 -> true | uu___ -> false +let (__proj__MemoLazy__item___0 : + stack_elt -> (env * FStarC_Syntax_Syntax.term) cfg_memo) = + fun projectee -> match projectee with | MemoLazy _0 -> _0 +let (uu___is_Match : stack_elt -> Prims.bool) = + fun projectee -> match projectee with | Match _0 -> true | uu___ -> false +let (__proj__Match__item___0 : + stack_elt -> + (env * FStarC_Syntax_Syntax.match_returns_ascription + FStar_Pervasives_Native.option * branches * + FStarC_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option * + FStarC_TypeChecker_Cfg.cfg * FStarC_Compiler_Range_Type.range)) + = fun projectee -> match projectee with | Match _0 -> _0 +let (uu___is_Abs : stack_elt -> Prims.bool) = + fun projectee -> match projectee with | Abs _0 -> true | uu___ -> false +let (__proj__Abs__item___0 : + stack_elt -> + (env * FStarC_Syntax_Syntax.binders * env * + FStarC_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option * + FStarC_Compiler_Range_Type.range)) + = fun projectee -> match projectee with | Abs _0 -> _0 +let (uu___is_App : stack_elt -> Prims.bool) = + fun projectee -> match projectee with | App _0 -> true | uu___ -> false +let (__proj__App__item___0 : + stack_elt -> + (env * FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.aqual * + FStarC_Compiler_Range_Type.range)) + = fun projectee -> match projectee with | App _0 -> _0 +let (uu___is_CBVApp : stack_elt -> Prims.bool) = + fun projectee -> match projectee with | CBVApp _0 -> true | uu___ -> false +let (__proj__CBVApp__item___0 : + stack_elt -> + (env * FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.aqual * + FStarC_Compiler_Range_Type.range)) + = fun projectee -> match projectee with | CBVApp _0 -> _0 +let (uu___is_Meta : stack_elt -> Prims.bool) = + fun projectee -> match projectee with | Meta _0 -> true | uu___ -> false +let (__proj__Meta__item___0 : + stack_elt -> + (env * FStarC_Syntax_Syntax.metadata * FStarC_Compiler_Range_Type.range)) + = fun projectee -> match projectee with | Meta _0 -> _0 +let (uu___is_Let : stack_elt -> Prims.bool) = + fun projectee -> match projectee with | Let _0 -> true | uu___ -> false +let (__proj__Let__item___0 : + stack_elt -> + (env * FStarC_Syntax_Syntax.binders * FStarC_Syntax_Syntax.letbinding * + FStarC_Compiler_Range_Type.range)) + = fun projectee -> match projectee with | Let _0 -> _0 +type stack = stack_elt Prims.list +let (head_of : FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) = + fun t -> + let uu___ = FStarC_Syntax_Util.head_and_args_full t in + match uu___ with | (hd, uu___1) -> hd +let (cfg_equivalent : + FStarC_TypeChecker_Cfg.cfg -> FStarC_TypeChecker_Cfg.cfg -> Prims.bool) = + fun c1 -> + fun c2 -> + ((FStarC_Class_Deq.op_Equals_Question FStarC_TypeChecker_Cfg.deq_fsteps + c1.FStarC_TypeChecker_Cfg.steps c2.FStarC_TypeChecker_Cfg.steps) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Deq.deq_list FStarC_TypeChecker_Env.deq_delta_level) + c1.FStarC_TypeChecker_Cfg.delta_level + c2.FStarC_TypeChecker_Cfg.delta_level)) + && + (FStarC_Class_Deq.op_Equals_Question + (FStarC_Class_Ord.ord_eq FStarC_Class_Ord.ord_bool) + c1.FStarC_TypeChecker_Cfg.normalize_pure_lets + c2.FStarC_TypeChecker_Cfg.normalize_pure_lets) +let read_memo : + 'a . + FStarC_TypeChecker_Cfg.cfg -> + (FStarC_TypeChecker_Cfg.cfg * 'a) FStarC_Syntax_Syntax.memo -> + 'a FStar_Pervasives_Native.option + = + fun cfg -> + fun r -> + let uu___ = FStarC_Compiler_Effect.op_Bang r in + match uu___ with + | FStar_Pervasives_Native.Some (cfg', a1) when + (cfg.FStarC_TypeChecker_Cfg.compat_memo_ignore_cfg || + (FStarC_Compiler_Util.physical_equality cfg cfg')) + || (cfg_equivalent cfg' cfg) + -> FStar_Pervasives_Native.Some a1 + | uu___1 -> FStar_Pervasives_Native.None +let set_memo : + 'a . + FStarC_TypeChecker_Cfg.cfg -> + (FStarC_TypeChecker_Cfg.cfg * 'a) FStarC_Syntax_Syntax.memo -> + 'a -> unit + = + fun cfg -> + fun r -> + fun t -> + if cfg.FStarC_TypeChecker_Cfg.memoize_lazy + then + ((let uu___1 = + let uu___2 = read_memo cfg r in + FStarC_Compiler_Option.isSome uu___2 in + if uu___1 + then failwith "Unexpected set_memo: thunk already evaluated" + else ()); + FStarC_Compiler_Effect.op_Colon_Equals r + (FStar_Pervasives_Native.Some (cfg, t))) + else () +let (closure_to_string : closure -> Prims.string) = + fun uu___ -> + match uu___ with + | Clos (env1, t, uu___1, uu___2) -> + let uu___3 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length env1) in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.format2 "(env=%s elts; %s)" uu___3 uu___4 + | Univ uu___1 -> "Univ" + | Dummy -> "dummy" +let (showable_closure : closure FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = closure_to_string } +let (showable_stack_elt : stack_elt FStarC_Class_Show.showable) = + { + FStarC_Class_Show.show = + (fun uu___ -> + match uu___ with + | Arg (c, uu___1, uu___2) -> + let uu___3 = FStarC_Class_Show.show showable_closure c in + FStarC_Compiler_Util.format1 "Closure %s" uu___3 + | MemoLazy uu___1 -> "MemoLazy" + | Abs (uu___1, bs, uu___2, uu___3, uu___4) -> + let uu___5 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_nat) + (FStarC_Compiler_List.length bs) in + FStarC_Compiler_Util.format1 "Abs %s" uu___5 + | UnivArgs uu___1 -> "UnivArgs" + | Match uu___1 -> "Match" + | App (uu___1, t, uu___2, uu___3) -> + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.format1 "App %s" uu___4 + | CBVApp (uu___1, t, uu___2, uu___3) -> + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.format1 "CBVApp %s" uu___4 + | Meta (uu___1, m, uu___2) -> "Meta" + | Let uu___1 -> "Let") + } +let is_empty : 'uuuuu . 'uuuuu Prims.list -> Prims.bool = + fun uu___ -> match uu___ with | [] -> true | uu___1 -> false +let (lookup_bvar : env -> FStarC_Syntax_Syntax.bv -> closure) = + fun env1 -> + fun x -> + try + (fun uu___ -> + match () with + | () -> + let uu___1 = + FStarC_Compiler_List.nth env1 x.FStarC_Syntax_Syntax.index in + FStar_Pervasives_Native.__proj__Mktuple3__item___2 uu___1) () + with + | uu___ -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_bv x in + let uu___3 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + (FStarC_Class_Show.show_tuple3 + (FStarC_Class_Show.show_option + FStarC_Syntax_Print.showable_binder) + showable_closure + (showable_memo + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_subst_elt)))) env1 in + FStarC_Compiler_Util.format2 "Failed to find %s\nEnv is %s\n" + uu___2 uu___3 in + failwith uu___1 +let (downgrade_ghost_effect_name : + FStarC_Ident.lident -> FStarC_Ident.lident FStar_Pervasives_Native.option) + = + fun l -> + let uu___ = + FStarC_Ident.lid_equals l FStarC_Parser_Const.effect_Ghost_lid in + if uu___ + then FStar_Pervasives_Native.Some FStarC_Parser_Const.effect_Pure_lid + else + (let uu___2 = + FStarC_Ident.lid_equals l FStarC_Parser_Const.effect_GTot_lid in + if uu___2 + then FStar_Pervasives_Native.Some FStarC_Parser_Const.effect_Tot_lid + else + (let uu___4 = + FStarC_Ident.lid_equals l FStarC_Parser_Const.effect_GHOST_lid in + if uu___4 + then + FStar_Pervasives_Native.Some FStarC_Parser_Const.effect_PURE_lid + else FStar_Pervasives_Native.None)) +let (norm_universe : + FStarC_TypeChecker_Cfg.cfg -> + env -> FStarC_Syntax_Syntax.universe -> FStarC_Syntax_Syntax.universe) + = + fun cfg -> + fun env1 -> + fun u -> + let norm_univs_for_max us = + let us1 = + FStarC_Compiler_Util.sort_with FStarC_Syntax_Util.compare_univs + us in + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun u1 -> + match uu___1 with + | (cur_kernel, cur_max, out) -> + let uu___2 = FStarC_Syntax_Util.univ_kernel u1 in + (match uu___2 with + | (k_u, n) -> + let uu___3 = + FStarC_Syntax_Util.eq_univs cur_kernel k_u in + if uu___3 + then (cur_kernel, u1, out) + else (k_u, u1, (cur_max :: out)))) + (FStarC_Syntax_Syntax.U_zero, FStarC_Syntax_Syntax.U_zero, []) + us1 in + match uu___ with + | (uu___1, u1, out) -> FStarC_Compiler_List.rev (u1 :: out) in + let rec aux u1 = + let u2 = FStarC_Syntax_Subst.compress_univ u1 in + match u2 with + | FStarC_Syntax_Syntax.U_bvar x -> + (try + (fun uu___ -> + match () with + | () -> + let uu___1 = + let uu___2 = FStarC_Compiler_List.nth env1 x in + FStar_Pervasives_Native.__proj__Mktuple3__item___2 + uu___2 in + (match uu___1 with + | Univ u3 -> + ((let uu___3 = + FStarC_Compiler_Effect.op_Bang dbg_univ_norm in + if uu___3 + then + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_univ u3 in + FStarC_Compiler_Util.print1 + "Univ (in norm_universe): %s\n" uu___4 + else ()); + aux u3) + | Dummy -> [u2] + | uu___2 -> + let uu___3 = + let uu___4 = + FStarC_Compiler_Util.string_of_int x in + FStarC_Compiler_Util.format1 + "Impossible: universe variable u@%s bound to a term" + uu___4 in + failwith uu___3)) () + with + | uu___ -> + if + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.allow_unbound_universes + then [FStarC_Syntax_Syntax.U_unknown] + else + (let uu___2 = + let uu___3 = FStarC_Compiler_Util.string_of_int x in + Prims.strcat "Universe variable not found: u@" uu___3 in + failwith uu___2)) + | FStarC_Syntax_Syntax.U_unif uu___ when + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.default_univs_to_zero + -> [FStarC_Syntax_Syntax.U_zero] + | FStarC_Syntax_Syntax.U_unif uu___ when + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.check_no_uvars + -> + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_TypeChecker_Env.get_range + cfg.FStarC_TypeChecker_Cfg.tcenv in + FStarC_Compiler_Range_Ops.string_of_range uu___3 in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_univ u2 in + FStarC_Compiler_Util.format2 + "(%s) CheckNoUvars: unexpected universes variable remains: %s" + uu___2 uu___3 in + failwith uu___1 + | FStarC_Syntax_Syntax.U_zero -> [u2] + | FStarC_Syntax_Syntax.U_unif uu___ -> [u2] + | FStarC_Syntax_Syntax.U_name uu___ -> [u2] + | FStarC_Syntax_Syntax.U_unknown -> [u2] + | FStarC_Syntax_Syntax.U_max [] -> [FStarC_Syntax_Syntax.U_zero] + | FStarC_Syntax_Syntax.U_max us -> + let us1 = + let uu___ = FStarC_Compiler_List.collect aux us in + norm_univs_for_max uu___ in + (match us1 with + | u_k::hd::rest -> + let rest1 = hd :: rest in + let uu___ = FStarC_Syntax_Util.univ_kernel u_k in + (match uu___ with + | (FStarC_Syntax_Syntax.U_zero, n) -> + let uu___1 = + FStarC_Compiler_List.for_all + (fun u3 -> + let uu___2 = FStarC_Syntax_Util.univ_kernel u3 in + match uu___2 with | (uu___3, m) -> n <= m) + rest1 in + if uu___1 then rest1 else us1 + | uu___1 -> us1) + | uu___ -> us1) + | FStarC_Syntax_Syntax.U_succ u3 -> + let uu___ = aux u3 in + FStarC_Compiler_List.map + (fun uu___1 -> FStarC_Syntax_Syntax.U_succ uu___1) uu___ in + if + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.erase_universes + then FStarC_Syntax_Syntax.U_unknown + else + (let uu___1 = aux u in + match uu___1 with + | [] -> FStarC_Syntax_Syntax.U_zero + | (FStarC_Syntax_Syntax.U_zero)::[] -> FStarC_Syntax_Syntax.U_zero + | (FStarC_Syntax_Syntax.U_zero)::u1::[] -> u1 + | (FStarC_Syntax_Syntax.U_zero)::us -> + FStarC_Syntax_Syntax.U_max us + | u1::[] -> u1 + | us -> FStarC_Syntax_Syntax.U_max us) +let memo_or : 'a . 'a FStarC_Syntax_Syntax.memo -> (unit -> 'a) -> 'a = + fun m -> + fun f -> + let uu___ = FStarC_Compiler_Effect.op_Bang m in + match uu___ with + | FStar_Pervasives_Native.Some v -> v + | FStar_Pervasives_Native.None -> + let v = f () in + (FStarC_Compiler_Effect.op_Colon_Equals m + (FStar_Pervasives_Native.Some v); + v) +let rec (env_subst : env -> FStarC_Syntax_Syntax.subst_t) = + fun env1 -> + let compute uu___ = + let uu___1 = + FStarC_Compiler_List.fold_left + (fun uu___2 -> + fun uu___3 -> + match (uu___2, uu___3) with + | ((s, i), (uu___4, c, uu___5)) -> + (match c with + | Clos (e, t, memo, fix) -> + let es = env_subst e in + let t1 = + let uu___6 = FStarC_Syntax_Subst.subst es t in + FStarC_Syntax_Subst.compress uu___6 in + (((FStarC_Syntax_Syntax.DT (i, t1)) :: s), + (i + Prims.int_one)) + | Univ u -> + (((FStarC_Syntax_Syntax.UN (i, u)) :: s), + (i + Prims.int_one)) + | Dummy -> (s, (i + Prims.int_one)))) + ([], Prims.int_zero) env1 in + match uu___1 with | (s, uu___2) -> s in + match env1 with + | [] -> [] + | (uu___, uu___1, memo)::uu___2 -> + let uu___3 = FStarC_Compiler_Effect.op_Bang memo in + (match uu___3 with + | FStar_Pervasives_Native.Some s -> s + | FStar_Pervasives_Native.None -> + let s = compute () in + (FStarC_Compiler_Effect.op_Colon_Equals memo + (FStar_Pervasives_Native.Some s); + s)) +let (filter_out_lcomp_cflags : + FStarC_Syntax_Syntax.cflag Prims.list -> + FStarC_Syntax_Syntax.cflag Prims.list) + = + fun flags -> + FStarC_Compiler_List.filter + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.DECREASES uu___1 -> false + | uu___1 -> true) flags +let (default_univ_uvars_to_zero : + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) = + fun t -> + FStarC_Syntax_Visit.visit_term_univs false (fun t1 -> t1) + (fun u -> + match u with + | FStarC_Syntax_Syntax.U_unif uu___ -> FStarC_Syntax_Syntax.U_zero + | uu___ -> u) t +let (_erase_universes : + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) = + fun t -> + FStarC_Syntax_Visit.visit_term_univs false (fun t1 -> t1) + (fun u -> FStarC_Syntax_Syntax.U_unknown) t +let (closure_as_term : + FStarC_TypeChecker_Cfg.cfg -> + env -> FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun cfg -> + fun env1 -> + fun t -> + FStarC_TypeChecker_Cfg.log cfg + (fun uu___1 -> + let uu___2 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t in + let uu___3 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + (FStarC_Class_Show.show_tuple3 + (FStarC_Class_Show.show_option + FStarC_Syntax_Print.showable_binder) + showable_closure + (showable_memo + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_subst_elt)))) env1 in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.print3 + ">>> %s (env=%s)\nClosure_as_term %s\n" uu___2 uu___3 uu___4); + (let es = env_subst env1 in + let t1 = FStarC_Syntax_Subst.subst es t in + let t2 = + if + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.erase_universes + then _erase_universes t1 + else + if + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.default_univs_to_zero + then default_univ_uvars_to_zero t1 + else t1 in + let t3 = FStarC_Syntax_Subst.compress t2 in + FStarC_TypeChecker_Cfg.log cfg + (fun uu___2 -> + let uu___3 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term + t3 in + let uu___4 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + (FStarC_Class_Show.show_tuple3 + (FStarC_Class_Show.show_option + FStarC_Syntax_Print.showable_binder) + showable_closure + (showable_memo + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_subst_elt)))) env1 in + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t3 in + FStarC_Compiler_Util.print3 + ">>> %s (env=%s)\nClosure_as_term RESULT %s\n" uu___3 uu___4 + uu___5); + t3) +let (unembed_binder_knot : + FStarC_Syntax_Syntax.binder FStarC_Syntax_Embeddings_Base.embedding + FStar_Pervasives_Native.option FStarC_Compiler_Effect.ref) + = FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None +let (unembed_binder : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.binder FStar_Pervasives_Native.option) + = + fun t -> + let uu___ = FStarC_Compiler_Effect.op_Bang unembed_binder_knot in + match uu___ with + | FStar_Pervasives_Native.Some e -> + FStarC_Syntax_Embeddings_Base.try_unembed e t + FStarC_Syntax_Embeddings_Base.id_norm_cb + | FStar_Pervasives_Native.None -> + (FStarC_Errors.log_issue (FStarC_Syntax_Syntax.has_range_syntax ()) t + FStarC_Errors_Codes.Warning_UnembedBinderKnot () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "unembed_binder_knot is unset!"); + FStar_Pervasives_Native.None) +let (mk_psc_subst : + FStarC_TypeChecker_Cfg.cfg -> + env -> FStarC_Syntax_Syntax.subst_elt Prims.list) + = + fun cfg -> + fun env1 -> + FStarC_Compiler_List.fold_right + (fun uu___ -> + fun subst -> + match uu___ with + | (binder_opt, closure1, uu___1) -> + (match (binder_opt, closure1) with + | (FStar_Pervasives_Native.Some b, Clos + (env2, term, uu___2, uu___3)) -> + let bv = b.FStarC_Syntax_Syntax.binder_bv in + let uu___4 = + let uu___5 = + FStarC_Syntax_Util.is_constructed_typ + bv.FStarC_Syntax_Syntax.sort + FStarC_Parser_Const.binder_lid in + Prims.op_Negation uu___5 in + if uu___4 + then subst + else + (let term1 = closure_as_term cfg env2 term in + let uu___6 = unembed_binder term1 in + match uu___6 with + | FStar_Pervasives_Native.None -> subst + | FStar_Pervasives_Native.Some x -> + let b1 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Subst.subst subst + (x.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + { + FStarC_Syntax_Syntax.ppname = + (bv.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (bv.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = uu___8 + } in + FStarC_Syntax_Syntax.freshen_bv uu___7 in + let b_for_x = + let uu___7 = + let uu___8 = + FStarC_Syntax_Syntax.bv_to_name b1 in + ((x.FStarC_Syntax_Syntax.binder_bv), uu___8) in + FStarC_Syntax_Syntax.NT uu___7 in + let subst1 = + FStarC_Compiler_List.filter + (fun uu___7 -> + match uu___7 with + | FStarC_Syntax_Syntax.NT + (uu___8, + { + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Tm_name b'; + FStarC_Syntax_Syntax.pos = uu___9; + FStarC_Syntax_Syntax.vars = + uu___10; + FStarC_Syntax_Syntax.hash_code = + uu___11;_}) + -> + let uu___12 = + FStarC_Ident.ident_equals + b1.FStarC_Syntax_Syntax.ppname + b'.FStarC_Syntax_Syntax.ppname in + Prims.op_Negation uu___12 + | uu___8 -> true) subst in + b_for_x :: subst1) + | uu___2 -> subst)) env1 [] +let (reduce_primops : + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_TypeChecker_Cfg.cfg -> + env -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + (FStarC_Syntax_Syntax.term * Prims.bool)) + = + fun norm_cb -> + fun cfg -> + fun env1 -> + fun tm -> + if + Prims.op_Negation + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.primops + then (tm, false) + else + (let uu___1 = FStarC_Syntax_Util.head_and_args_full tm in + match uu___1 with + | (head, args) -> + let uu___2 = + let head1 = + let uu___3 = FStarC_Syntax_Util.unmeta head in + FStarC_Syntax_Subst.compress uu___3 in + match head1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_uinst (fv, us) -> (fv, us) + | uu___3 -> (head1, []) in + (match uu___2 with + | (head_term, universes) -> + (match head_term.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let uu___3 = + FStarC_TypeChecker_Cfg.find_prim_step cfg fv in + (match uu___3 with + | FStar_Pervasives_Native.Some prim_step when + prim_step.FStarC_TypeChecker_Primops_Base.strong_reduction_ok + || + (Prims.op_Negation + cfg.FStarC_TypeChecker_Cfg.strong) + -> + let l = FStarC_Compiler_List.length args in + if + l < + prim_step.FStarC_TypeChecker_Primops_Base.arity + then + (FStarC_TypeChecker_Cfg.log_primops cfg + (fun uu___5 -> + let uu___6 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + prim_step.FStarC_TypeChecker_Primops_Base.name in + let uu___7 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_nat) + l in + let uu___8 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + prim_step.FStarC_TypeChecker_Primops_Base.arity in + FStarC_Compiler_Util.print3 + "primop: found partially applied %s (%s/%s args)\n" + uu___6 uu___7 uu___8); + (tm, false)) + else + (let uu___5 = + if + l = + prim_step.FStarC_TypeChecker_Primops_Base.arity + then (args, []) + else + FStarC_Compiler_List.splitAt + prim_step.FStarC_TypeChecker_Primops_Base.arity + args in + match uu___5 with + | (args_1, args_2) -> + (FStarC_TypeChecker_Cfg.log_primops + cfg + (fun uu___7 -> + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + tm in + FStarC_Compiler_Util.print1 + "primop: trying to reduce <%s>\n" + uu___8); + (let psc = + { + FStarC_TypeChecker_Primops_Base.psc_range + = + (head.FStarC_Syntax_Syntax.pos); + FStarC_TypeChecker_Primops_Base.psc_subst + = + (fun uu___7 -> + if + prim_step.FStarC_TypeChecker_Primops_Base.requires_binder_substitution + then mk_psc_subst cfg env1 + else []) + } in + let r = + prim_step.FStarC_TypeChecker_Primops_Base.interpretation + psc norm_cb universes args_1 in + match r with + | FStar_Pervasives_Native.None -> + (FStarC_TypeChecker_Cfg.log_primops + cfg + (fun uu___8 -> + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + tm in + FStarC_Compiler_Util.print1 + "primop: <%s> did not reduce\n" + uu___9); + (tm, false)) + | FStar_Pervasives_Native.Some + reduced -> + (FStarC_TypeChecker_Cfg.log_primops + cfg + (fun uu___8 -> + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + tm in + let uu___10 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + reduced in + FStarC_Compiler_Util.print2 + "primop: <%s> reduced to %s\n" + uu___9 uu___10); + (let uu___8 = + FStarC_Syntax_Util.mk_app + reduced args_2 in + (uu___8, + (prim_step.FStarC_TypeChecker_Primops_Base.renorm_after))))))) + | FStar_Pervasives_Native.Some uu___4 -> + (FStarC_TypeChecker_Cfg.log_primops cfg + (fun uu___6 -> + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + tm in + FStarC_Compiler_Util.print1 + "primop: not reducing <%s> since we're doing strong reduction\n" + uu___7); + (tm, false)) + | FStar_Pervasives_Native.None -> (tm, false)) + | FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_range_of) when + Prims.op_Negation + cfg.FStarC_TypeChecker_Cfg.strong + -> + (FStarC_TypeChecker_Cfg.log_primops cfg + (fun uu___4 -> + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term tm in + FStarC_Compiler_Util.print1 + "primop: reducing <%s>\n" uu___5); + (match args with + | (a1, uu___4)::[] -> + let uu___5 = + FStarC_TypeChecker_Primops_Base.embed_simple + FStarC_Syntax_Embeddings.e_range + a1.FStarC_Syntax_Syntax.pos + tm.FStarC_Syntax_Syntax.pos in + (uu___5, false) + | uu___4 -> (tm, false))) + | FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_set_range_of) when + Prims.op_Negation + cfg.FStarC_TypeChecker_Cfg.strong + -> + (FStarC_TypeChecker_Cfg.log_primops cfg + (fun uu___4 -> + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term tm in + FStarC_Compiler_Util.print1 + "primop: reducing <%s>\n" uu___5); + (match args with + | (t, uu___4)::(r, uu___5)::[] -> + let uu___6 = + FStarC_TypeChecker_Primops_Base.try_unembed_simple + FStarC_Syntax_Embeddings.e_range r in + (match uu___6 with + | FStar_Pervasives_Native.Some rng -> + let uu___7 = + FStarC_Syntax_Subst.set_use_range rng + t in + (uu___7, false) + | FStar_Pervasives_Native.None -> + (tm, false)) + | uu___4 -> (tm, false))) + | uu___3 -> (tm, false)))) +let (reduce_equality : + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_TypeChecker_Cfg.cfg -> + env -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + (FStarC_Syntax_Syntax.term * Prims.bool)) + = + fun norm_cb -> + fun cfg -> + fun tm -> + let uu___ = + let uu___1 = + FStarC_TypeChecker_Cfg.simplification_steps + cfg.FStarC_TypeChecker_Cfg.tcenv in + { + FStarC_TypeChecker_Cfg.steps = + { + FStarC_TypeChecker_Cfg.beta = + (FStarC_TypeChecker_Cfg.default_steps.FStarC_TypeChecker_Cfg.beta); + FStarC_TypeChecker_Cfg.iota = + (FStarC_TypeChecker_Cfg.default_steps.FStarC_TypeChecker_Cfg.iota); + FStarC_TypeChecker_Cfg.zeta = + (FStarC_TypeChecker_Cfg.default_steps.FStarC_TypeChecker_Cfg.zeta); + FStarC_TypeChecker_Cfg.zeta_full = + (FStarC_TypeChecker_Cfg.default_steps.FStarC_TypeChecker_Cfg.zeta_full); + FStarC_TypeChecker_Cfg.weak = + (FStarC_TypeChecker_Cfg.default_steps.FStarC_TypeChecker_Cfg.weak); + FStarC_TypeChecker_Cfg.hnf = + (FStarC_TypeChecker_Cfg.default_steps.FStarC_TypeChecker_Cfg.hnf); + FStarC_TypeChecker_Cfg.primops = true; + FStarC_TypeChecker_Cfg.do_not_unfold_pure_lets = + (FStarC_TypeChecker_Cfg.default_steps.FStarC_TypeChecker_Cfg.do_not_unfold_pure_lets); + FStarC_TypeChecker_Cfg.unfold_until = + (FStarC_TypeChecker_Cfg.default_steps.FStarC_TypeChecker_Cfg.unfold_until); + FStarC_TypeChecker_Cfg.unfold_only = + (FStarC_TypeChecker_Cfg.default_steps.FStarC_TypeChecker_Cfg.unfold_only); + FStarC_TypeChecker_Cfg.unfold_fully = + (FStarC_TypeChecker_Cfg.default_steps.FStarC_TypeChecker_Cfg.unfold_fully); + FStarC_TypeChecker_Cfg.unfold_attr = + (FStarC_TypeChecker_Cfg.default_steps.FStarC_TypeChecker_Cfg.unfold_attr); + FStarC_TypeChecker_Cfg.unfold_qual = + (FStarC_TypeChecker_Cfg.default_steps.FStarC_TypeChecker_Cfg.unfold_qual); + FStarC_TypeChecker_Cfg.unfold_namespace = + (FStarC_TypeChecker_Cfg.default_steps.FStarC_TypeChecker_Cfg.unfold_namespace); + FStarC_TypeChecker_Cfg.dont_unfold_attr = + (FStarC_TypeChecker_Cfg.default_steps.FStarC_TypeChecker_Cfg.dont_unfold_attr); + FStarC_TypeChecker_Cfg.pure_subterms_within_computations = + (FStarC_TypeChecker_Cfg.default_steps.FStarC_TypeChecker_Cfg.pure_subterms_within_computations); + FStarC_TypeChecker_Cfg.simplify = + (FStarC_TypeChecker_Cfg.default_steps.FStarC_TypeChecker_Cfg.simplify); + FStarC_TypeChecker_Cfg.erase_universes = + (FStarC_TypeChecker_Cfg.default_steps.FStarC_TypeChecker_Cfg.erase_universes); + FStarC_TypeChecker_Cfg.allow_unbound_universes = + (FStarC_TypeChecker_Cfg.default_steps.FStarC_TypeChecker_Cfg.allow_unbound_universes); + FStarC_TypeChecker_Cfg.reify_ = + (FStarC_TypeChecker_Cfg.default_steps.FStarC_TypeChecker_Cfg.reify_); + FStarC_TypeChecker_Cfg.compress_uvars = + (FStarC_TypeChecker_Cfg.default_steps.FStarC_TypeChecker_Cfg.compress_uvars); + FStarC_TypeChecker_Cfg.no_full_norm = + (FStarC_TypeChecker_Cfg.default_steps.FStarC_TypeChecker_Cfg.no_full_norm); + FStarC_TypeChecker_Cfg.check_no_uvars = + (FStarC_TypeChecker_Cfg.default_steps.FStarC_TypeChecker_Cfg.check_no_uvars); + FStarC_TypeChecker_Cfg.unmeta = + (FStarC_TypeChecker_Cfg.default_steps.FStarC_TypeChecker_Cfg.unmeta); + FStarC_TypeChecker_Cfg.unascribe = + (FStarC_TypeChecker_Cfg.default_steps.FStarC_TypeChecker_Cfg.unascribe); + FStarC_TypeChecker_Cfg.in_full_norm_request = + (FStarC_TypeChecker_Cfg.default_steps.FStarC_TypeChecker_Cfg.in_full_norm_request); + FStarC_TypeChecker_Cfg.weakly_reduce_scrutinee = + (FStarC_TypeChecker_Cfg.default_steps.FStarC_TypeChecker_Cfg.weakly_reduce_scrutinee); + FStarC_TypeChecker_Cfg.nbe_step = + (FStarC_TypeChecker_Cfg.default_steps.FStarC_TypeChecker_Cfg.nbe_step); + FStarC_TypeChecker_Cfg.for_extraction = + (FStarC_TypeChecker_Cfg.default_steps.FStarC_TypeChecker_Cfg.for_extraction); + FStarC_TypeChecker_Cfg.unrefine = + (FStarC_TypeChecker_Cfg.default_steps.FStarC_TypeChecker_Cfg.unrefine); + FStarC_TypeChecker_Cfg.default_univs_to_zero = + (FStarC_TypeChecker_Cfg.default_steps.FStarC_TypeChecker_Cfg.default_univs_to_zero); + FStarC_TypeChecker_Cfg.tactics = + (FStarC_TypeChecker_Cfg.default_steps.FStarC_TypeChecker_Cfg.tactics) + }; + FStarC_TypeChecker_Cfg.tcenv = (cfg.FStarC_TypeChecker_Cfg.tcenv); + FStarC_TypeChecker_Cfg.debug = (cfg.FStarC_TypeChecker_Cfg.debug); + FStarC_TypeChecker_Cfg.delta_level = + (cfg.FStarC_TypeChecker_Cfg.delta_level); + FStarC_TypeChecker_Cfg.primitive_steps = uu___1; + FStarC_TypeChecker_Cfg.strong = + (cfg.FStarC_TypeChecker_Cfg.strong); + FStarC_TypeChecker_Cfg.memoize_lazy = + (cfg.FStarC_TypeChecker_Cfg.memoize_lazy); + FStarC_TypeChecker_Cfg.normalize_pure_lets = + (cfg.FStarC_TypeChecker_Cfg.normalize_pure_lets); + FStarC_TypeChecker_Cfg.reifying = + (cfg.FStarC_TypeChecker_Cfg.reifying); + FStarC_TypeChecker_Cfg.compat_memo_ignore_cfg = + (cfg.FStarC_TypeChecker_Cfg.compat_memo_ignore_cfg) + } in + reduce_primops norm_cb uu___ tm +type norm_request_t = + | Norm_request_none + | Norm_request_ready + | Norm_request_requires_rejig +let (uu___is_Norm_request_none : norm_request_t -> Prims.bool) = + fun projectee -> + match projectee with | Norm_request_none -> true | uu___ -> false +let (uu___is_Norm_request_ready : norm_request_t -> Prims.bool) = + fun projectee -> + match projectee with | Norm_request_ready -> true | uu___ -> false +let (uu___is_Norm_request_requires_rejig : norm_request_t -> Prims.bool) = + fun projectee -> + match projectee with + | Norm_request_requires_rejig -> true + | uu___ -> false +let (is_norm_request : + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.args -> norm_request_t) = + fun hd -> + fun args -> + let aux min_args = + if (FStarC_Compiler_List.length args) < min_args + then Norm_request_none + else + if (FStarC_Compiler_List.length args) = min_args + then Norm_request_ready + else Norm_request_requires_rejig in + let uu___ = + let uu___1 = FStarC_Syntax_Util.un_uinst hd in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.normalize_term + -> aux (Prims.of_int (2)) + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.normalize -> + aux Prims.int_one + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.norm -> + aux (Prims.of_int (3)) + | uu___1 -> Norm_request_none +let (should_consider_norm_requests : + FStarC_TypeChecker_Cfg.cfg -> Prims.bool) = + fun cfg -> + (Prims.op_Negation + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.no_full_norm) + && + (let uu___ = + FStarC_Ident.lid_equals + (cfg.FStarC_TypeChecker_Cfg.tcenv).FStarC_TypeChecker_Env.curmodule + FStarC_Parser_Const.prims_lid in + Prims.op_Negation uu___) +let (rejig_norm_request : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.args -> FStarC_Syntax_Syntax.term) + = + fun hd -> + fun args -> + let uu___ = + let uu___1 = FStarC_Syntax_Util.un_uinst hd in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.normalize_term + -> + (match args with + | t1::t2::rest when + (FStarC_Compiler_List.length rest) > Prims.int_zero -> + let uu___1 = FStarC_Syntax_Util.mk_app hd [t1; t2] in + FStarC_Syntax_Util.mk_app uu___1 rest + | uu___1 -> + failwith + "Impossible! invalid rejig_norm_request for normalize_term") + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.normalize -> + (match args with + | t::rest when (FStarC_Compiler_List.length rest) > Prims.int_zero + -> + let uu___1 = FStarC_Syntax_Util.mk_app hd [t] in + FStarC_Syntax_Util.mk_app uu___1 rest + | uu___1 -> + failwith + "Impossible! invalid rejig_norm_request for normalize") + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.norm -> + (match args with + | t1::t2::t3::rest when + (FStarC_Compiler_List.length rest) > Prims.int_zero -> + let uu___1 = FStarC_Syntax_Util.mk_app hd [t1; t2; t3] in + FStarC_Syntax_Util.mk_app uu___1 rest + | uu___1 -> + failwith "Impossible! invalid rejig_norm_request for norm") + | uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term hd in + Prims.strcat "Impossible! invalid rejig_norm_request for: %s" + uu___3 in + failwith uu___2 +let (is_nbe_request : FStarC_TypeChecker_Env.step Prims.list -> Prims.bool) = + fun s -> + FStarC_Compiler_Util.for_some + (FStarC_Class_Deq.op_Equals_Question FStarC_TypeChecker_Env.deq_step + FStarC_TypeChecker_Env.NBE) s +let get_norm_request : + 'uuuuu . + FStarC_TypeChecker_Cfg.cfg -> + (FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) -> + (FStarC_Syntax_Syntax.term * 'uuuuu) Prims.list -> + (FStarC_TypeChecker_Env.step Prims.list * + FStarC_Syntax_Syntax.term) FStar_Pervasives_Native.option + = + fun cfg -> + fun full_norm -> + fun args -> + let parse_steps s = + let uu___ = + FStarC_TypeChecker_Primops_Base.try_unembed_simple + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_norm_step) s in + match uu___ with + | FStar_Pervasives_Native.Some steps -> + let uu___1 = FStarC_TypeChecker_Cfg.translate_norm_steps steps in + FStar_Pervasives_Native.Some uu___1 + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None in + let inherited_steps = + FStarC_Compiler_List.op_At + (if + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.erase_universes + then [FStarC_TypeChecker_Env.EraseUniverses] + else []) + (FStarC_Compiler_List.op_At + (if + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.allow_unbound_universes + then [FStarC_TypeChecker_Env.AllowUnboundUniverses] + else []) + (if + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.nbe_step + then [FStarC_TypeChecker_Env.NBE] + else [])) in + match args with + | uu___::(tm, uu___1)::[] -> + let s = + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Zeta; + FStarC_TypeChecker_Env.Iota; + FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.Reify] in + FStar_Pervasives_Native.Some + ((FStarC_Compiler_List.op_At + ((FStarC_TypeChecker_Env.DontUnfoldAttr + [FStarC_Parser_Const.tac_opaque_attr]) :: + inherited_steps) s), tm) + | (tm, uu___)::[] -> + let s = + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Zeta; + FStarC_TypeChecker_Env.Iota; + FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.Reify] in + FStar_Pervasives_Native.Some + ((FStarC_Compiler_List.op_At + ((FStarC_TypeChecker_Env.DontUnfoldAttr + [FStarC_Parser_Const.tac_opaque_attr]) :: + inherited_steps) s), tm) + | (steps, uu___)::uu___1::(tm, uu___2)::[] -> + let uu___3 = let uu___4 = full_norm steps in parse_steps uu___4 in + (match uu___3 with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some s -> + FStar_Pervasives_Native.Some + ((FStarC_Compiler_List.op_At + ((FStarC_TypeChecker_Env.DontUnfoldAttr + [FStarC_Parser_Const.tac_opaque_attr]) :: + inherited_steps) s), tm)) + | uu___ -> FStar_Pervasives_Native.None +let (nbe_eval : + FStarC_TypeChecker_Cfg.cfg -> + FStarC_TypeChecker_Env.steps -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun cfg -> + fun s -> + fun tm -> + let delta_level = + let uu___ = + FStarC_Compiler_Util.for_some + (fun uu___1 -> + match uu___1 with + | FStarC_TypeChecker_Env.UnfoldUntil uu___2 -> true + | FStarC_TypeChecker_Env.UnfoldOnly uu___2 -> true + | FStarC_TypeChecker_Env.UnfoldFully uu___2 -> true + | uu___2 -> false) s in + if uu___ + then + [FStarC_TypeChecker_Env.Unfold + FStarC_Syntax_Syntax.delta_constant] + else [FStarC_TypeChecker_Env.NoDelta] in + FStarC_TypeChecker_Cfg.log_nbe cfg + (fun uu___1 -> + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term tm in + FStarC_Compiler_Util.print1 "Invoking NBE with %s\n" uu___2); + (let tm_norm = + let uu___1 = FStarC_TypeChecker_Cfg.cfg_env cfg in + uu___1.FStarC_TypeChecker_Env.nbe s + cfg.FStarC_TypeChecker_Cfg.tcenv tm in + FStarC_TypeChecker_Cfg.log_nbe cfg + (fun uu___2 -> + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + tm_norm in + FStarC_Compiler_Util.print1 "Result of NBE is %s\n" uu___3); + tm_norm) +let firstn : + 'uuuuu . + Prims.int -> 'uuuuu Prims.list -> ('uuuuu Prims.list * 'uuuuu Prims.list) + = + fun k -> + fun l -> + if (FStarC_Compiler_List.length l) < k + then (l, []) + else FStarC_Compiler_Util.first_N k l +let (should_reify : + FStarC_TypeChecker_Cfg.cfg -> stack_elt Prims.list -> Prims.bool) = + fun cfg -> + fun stack1 -> + let rec drop_irrel uu___ = + match uu___ with + | (MemoLazy uu___1)::s -> drop_irrel s + | (UnivArgs uu___1)::s -> drop_irrel s + | s -> s in + let uu___ = drop_irrel stack1 in + match uu___ with + | (App + (uu___1, + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_reify uu___2); + FStarC_Syntax_Syntax.pos = uu___3; + FStarC_Syntax_Syntax.vars = uu___4; + FStarC_Syntax_Syntax.hash_code = uu___5;_}, + uu___6, uu___7))::uu___8 + -> (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.reify_ + | uu___1 -> false +let rec (maybe_weakly_reduced : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> Prims.bool) = + fun tm -> + let aux_comp c = + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.GTotal t -> maybe_weakly_reduced t + | FStarC_Syntax_Syntax.Total t -> maybe_weakly_reduced t + | FStarC_Syntax_Syntax.Comp ct -> + (maybe_weakly_reduced ct.FStarC_Syntax_Syntax.result_typ) || + (FStarC_Compiler_Util.for_some + (fun uu___ -> + match uu___ with | (a, uu___1) -> maybe_weakly_reduced a) + ct.FStarC_Syntax_Syntax.effect_args) in + let t = FStarC_Syntax_Subst.compress tm in + match t.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_delayed uu___ -> failwith "Impossible" + | FStarC_Syntax_Syntax.Tm_name uu___ -> false + | FStarC_Syntax_Syntax.Tm_uvar uu___ -> false + | FStarC_Syntax_Syntax.Tm_type uu___ -> false + | FStarC_Syntax_Syntax.Tm_bvar uu___ -> false + | FStarC_Syntax_Syntax.Tm_fvar uu___ -> false + | FStarC_Syntax_Syntax.Tm_constant uu___ -> false + | FStarC_Syntax_Syntax.Tm_lazy uu___ -> false + | FStarC_Syntax_Syntax.Tm_unknown -> false + | FStarC_Syntax_Syntax.Tm_uinst uu___ -> false + | FStarC_Syntax_Syntax.Tm_quoted uu___ -> false + | FStarC_Syntax_Syntax.Tm_let uu___ -> true + | FStarC_Syntax_Syntax.Tm_abs uu___ -> true + | FStarC_Syntax_Syntax.Tm_arrow uu___ -> true + | FStarC_Syntax_Syntax.Tm_refine uu___ -> true + | FStarC_Syntax_Syntax.Tm_match uu___ -> true + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = t1; FStarC_Syntax_Syntax.args = args;_} + -> + (maybe_weakly_reduced t1) || + (FStarC_Compiler_Util.for_some + (fun uu___ -> + match uu___ with | (a, uu___1) -> maybe_weakly_reduced a) + args) + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t1; FStarC_Syntax_Syntax.asc = asc; + FStarC_Syntax_Syntax.eff_opt = uu___;_} + -> + (maybe_weakly_reduced t1) || + (let uu___1 = asc in + (match uu___1 with + | (asc_tc, asc_tac, uu___2) -> + (match asc_tc with + | FStar_Pervasives.Inl t2 -> maybe_weakly_reduced t2 + | FStar_Pervasives.Inr c2 -> aux_comp c2) || + ((match asc_tac with + | FStar_Pervasives_Native.None -> false + | FStar_Pervasives_Native.Some tac -> + maybe_weakly_reduced tac)))) + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t1; FStarC_Syntax_Syntax.meta = m;_} -> + (maybe_weakly_reduced t1) || + ((match m with + | FStarC_Syntax_Syntax.Meta_pattern (uu___, args) -> + FStarC_Compiler_Util.for_some + (FStarC_Compiler_Util.for_some + (fun uu___1 -> + match uu___1 with + | (a, uu___2) -> maybe_weakly_reduced a)) args + | FStarC_Syntax_Syntax.Meta_monadic_lift (uu___, uu___1, t') -> + maybe_weakly_reduced t' + | FStarC_Syntax_Syntax.Meta_monadic (uu___, t') -> + maybe_weakly_reduced t' + | FStarC_Syntax_Syntax.Meta_labeled uu___ -> false + | FStarC_Syntax_Syntax.Meta_desugared uu___ -> false + | FStarC_Syntax_Syntax.Meta_named uu___ -> false)) +let (decide_unfolding : + FStarC_TypeChecker_Cfg.cfg -> + stack_elt Prims.list -> + FStarC_Syntax_Syntax.fv -> + FStarC_TypeChecker_Env.qninfo -> + (FStarC_TypeChecker_Cfg.cfg FStar_Pervasives_Native.option * + stack_elt Prims.list) FStar_Pervasives_Native.option) + = + fun cfg -> + fun stack1 -> + fun fv -> + fun qninfo -> + let res = + FStarC_TypeChecker_Normalize_Unfolding.should_unfold cfg + (fun cfg1 -> should_reify cfg1 stack1) fv qninfo in + match res with + | FStarC_TypeChecker_Normalize_Unfolding.Should_unfold_no -> + FStar_Pervasives_Native.None + | FStarC_TypeChecker_Normalize_Unfolding.Should_unfold_yes -> + FStar_Pervasives_Native.Some + (FStar_Pervasives_Native.None, stack1) + | FStarC_TypeChecker_Normalize_Unfolding.Should_unfold_fully -> + let cfg' = + { + FStarC_TypeChecker_Cfg.steps = + (let uu___ = cfg.FStarC_TypeChecker_Cfg.steps in + { + FStarC_TypeChecker_Cfg.beta = + (uu___.FStarC_TypeChecker_Cfg.beta); + FStarC_TypeChecker_Cfg.iota = + (uu___.FStarC_TypeChecker_Cfg.iota); + FStarC_TypeChecker_Cfg.zeta = + (uu___.FStarC_TypeChecker_Cfg.zeta); + FStarC_TypeChecker_Cfg.zeta_full = + (uu___.FStarC_TypeChecker_Cfg.zeta_full); + FStarC_TypeChecker_Cfg.weak = + (uu___.FStarC_TypeChecker_Cfg.weak); + FStarC_TypeChecker_Cfg.hnf = + (uu___.FStarC_TypeChecker_Cfg.hnf); + FStarC_TypeChecker_Cfg.primops = + (uu___.FStarC_TypeChecker_Cfg.primops); + FStarC_TypeChecker_Cfg.do_not_unfold_pure_lets = + (uu___.FStarC_TypeChecker_Cfg.do_not_unfold_pure_lets); + FStarC_TypeChecker_Cfg.unfold_until = + (FStar_Pervasives_Native.Some + FStarC_Syntax_Syntax.delta_constant); + FStarC_TypeChecker_Cfg.unfold_only = + FStar_Pervasives_Native.None; + FStarC_TypeChecker_Cfg.unfold_fully = + FStar_Pervasives_Native.None; + FStarC_TypeChecker_Cfg.unfold_attr = + FStar_Pervasives_Native.None; + FStarC_TypeChecker_Cfg.unfold_qual = + FStar_Pervasives_Native.None; + FStarC_TypeChecker_Cfg.unfold_namespace = + FStar_Pervasives_Native.None; + FStarC_TypeChecker_Cfg.dont_unfold_attr = + (uu___.FStarC_TypeChecker_Cfg.dont_unfold_attr); + FStarC_TypeChecker_Cfg.pure_subterms_within_computations + = + (uu___.FStarC_TypeChecker_Cfg.pure_subterms_within_computations); + FStarC_TypeChecker_Cfg.simplify = + (uu___.FStarC_TypeChecker_Cfg.simplify); + FStarC_TypeChecker_Cfg.erase_universes = + (uu___.FStarC_TypeChecker_Cfg.erase_universes); + FStarC_TypeChecker_Cfg.allow_unbound_universes = + (uu___.FStarC_TypeChecker_Cfg.allow_unbound_universes); + FStarC_TypeChecker_Cfg.reify_ = + (uu___.FStarC_TypeChecker_Cfg.reify_); + FStarC_TypeChecker_Cfg.compress_uvars = + (uu___.FStarC_TypeChecker_Cfg.compress_uvars); + FStarC_TypeChecker_Cfg.no_full_norm = + (uu___.FStarC_TypeChecker_Cfg.no_full_norm); + FStarC_TypeChecker_Cfg.check_no_uvars = + (uu___.FStarC_TypeChecker_Cfg.check_no_uvars); + FStarC_TypeChecker_Cfg.unmeta = + (uu___.FStarC_TypeChecker_Cfg.unmeta); + FStarC_TypeChecker_Cfg.unascribe = + (uu___.FStarC_TypeChecker_Cfg.unascribe); + FStarC_TypeChecker_Cfg.in_full_norm_request = + (uu___.FStarC_TypeChecker_Cfg.in_full_norm_request); + FStarC_TypeChecker_Cfg.weakly_reduce_scrutinee = + (uu___.FStarC_TypeChecker_Cfg.weakly_reduce_scrutinee); + FStarC_TypeChecker_Cfg.nbe_step = + (uu___.FStarC_TypeChecker_Cfg.nbe_step); + FStarC_TypeChecker_Cfg.for_extraction = + (uu___.FStarC_TypeChecker_Cfg.for_extraction); + FStarC_TypeChecker_Cfg.unrefine = + (uu___.FStarC_TypeChecker_Cfg.unrefine); + FStarC_TypeChecker_Cfg.default_univs_to_zero = + (uu___.FStarC_TypeChecker_Cfg.default_univs_to_zero); + FStarC_TypeChecker_Cfg.tactics = + (uu___.FStarC_TypeChecker_Cfg.tactics) + }); + FStarC_TypeChecker_Cfg.tcenv = + (cfg.FStarC_TypeChecker_Cfg.tcenv); + FStarC_TypeChecker_Cfg.debug = + (cfg.FStarC_TypeChecker_Cfg.debug); + FStarC_TypeChecker_Cfg.delta_level = + (cfg.FStarC_TypeChecker_Cfg.delta_level); + FStarC_TypeChecker_Cfg.primitive_steps = + (cfg.FStarC_TypeChecker_Cfg.primitive_steps); + FStarC_TypeChecker_Cfg.strong = + (cfg.FStarC_TypeChecker_Cfg.strong); + FStarC_TypeChecker_Cfg.memoize_lazy = + (cfg.FStarC_TypeChecker_Cfg.memoize_lazy); + FStarC_TypeChecker_Cfg.normalize_pure_lets = + (cfg.FStarC_TypeChecker_Cfg.normalize_pure_lets); + FStarC_TypeChecker_Cfg.reifying = + (cfg.FStarC_TypeChecker_Cfg.reifying); + FStarC_TypeChecker_Cfg.compat_memo_ignore_cfg = + (cfg.FStarC_TypeChecker_Cfg.compat_memo_ignore_cfg) + } in + FStar_Pervasives_Native.Some + ((FStar_Pervasives_Native.Some cfg'), stack1) + | FStarC_TypeChecker_Normalize_Unfolding.Should_unfold_reify -> + let rec push e s = + match s with + | [] -> [e] + | (UnivArgs (us, r))::t -> + let uu___ = push e t in (UnivArgs (us, r)) :: uu___ + | h::t -> e :: h :: t in + let ref = + let uu___ = + let uu___1 = + let uu___2 = FStarC_Syntax_Syntax.lid_of_fv fv in + FStarC_Const.Const_reflect uu___2 in + FStarC_Syntax_Syntax.Tm_constant uu___1 in + FStarC_Syntax_Syntax.mk uu___ + FStarC_Compiler_Range_Type.dummyRange in + let stack2 = + push + (App + (empty_env, ref, FStar_Pervasives_Native.None, + FStarC_Compiler_Range_Type.dummyRange)) stack1 in + FStar_Pervasives_Native.Some + (FStar_Pervasives_Native.None, stack2) +let (on_domain_lids : FStarC_Ident.lident Prims.list) = + [FStarC_Parser_Const.fext_on_domain_lid; + FStarC_Parser_Const.fext_on_dom_lid; + FStarC_Parser_Const.fext_on_domain_g_lid; + FStarC_Parser_Const.fext_on_dom_g_lid] +let (is_fext_on_domain : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = + fun t -> + let is_on_dom fv = + FStarC_Compiler_List.existsb + (fun l -> FStarC_Syntax_Syntax.fv_eq_lid fv l) on_domain_lids in + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = hd; FStarC_Syntax_Syntax.args = args;_} + -> + let uu___1 = + let uu___2 = FStarC_Syntax_Util.un_uinst hd in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_fvar fv when + (is_on_dom fv) && + ((FStarC_Compiler_List.length args) = (Prims.of_int (3))) + -> + let f = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Compiler_List.tl args in + FStarC_Compiler_List.tl uu___4 in + FStarC_Compiler_List.hd uu___3 in + FStar_Pervasives_Native.fst uu___2 in + FStar_Pervasives_Native.Some f + | uu___2 -> FStar_Pervasives_Native.None) + | uu___1 -> FStar_Pervasives_Native.None +let (__get_n_binders : + (FStarC_TypeChecker_Env.env -> + FStarC_TypeChecker_Env.step Prims.list -> + Prims.int -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.binder Prims.list * + FStarC_Syntax_Syntax.comp)) + FStarC_Compiler_Effect.ref) + = + FStarC_Compiler_Util.mk_ref + (fun e -> + fun s -> + fun n -> fun t -> failwith "Impossible: __get_n_binders unset") +let (is_partial_primop_app : + FStarC_TypeChecker_Cfg.cfg -> FStarC_Syntax_Syntax.term -> Prims.bool) = + fun cfg -> + fun t -> + let uu___ = FStarC_Syntax_Util.head_and_args t in + match uu___ with + | (hd, args) -> + let uu___1 = + let uu___2 = FStarC_Syntax_Util.un_uinst hd in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let uu___2 = FStarC_TypeChecker_Cfg.find_prim_step cfg fv in + (match uu___2 with + | FStar_Pervasives_Native.Some prim_step -> + prim_step.FStarC_TypeChecker_Primops_Base.arity > + (FStarC_Compiler_List.length args) + | FStar_Pervasives_Native.None -> false) + | uu___2 -> false) +let (maybe_drop_rc_typ : + FStarC_TypeChecker_Cfg.cfg -> + FStarC_Syntax_Syntax.residual_comp -> FStarC_Syntax_Syntax.residual_comp) + = + fun cfg -> + fun rc -> + if + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.for_extraction + then + { + FStarC_Syntax_Syntax.residual_effect = + (rc.FStarC_Syntax_Syntax.residual_effect); + FStarC_Syntax_Syntax.residual_typ = FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.residual_flags = + (rc.FStarC_Syntax_Syntax.residual_flags) + } + else rc +let (get_extraction_mode : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident -> FStarC_Syntax_Syntax.eff_extraction_mode) + = + fun env1 -> + fun m -> + let norm_m = FStarC_TypeChecker_Env.norm_eff_name env1 m in + let uu___ = FStarC_TypeChecker_Env.get_effect_decl env1 norm_m in + uu___.FStarC_Syntax_Syntax.extraction_mode +let (can_reify_for_extraction : + FStarC_TypeChecker_Env.env -> FStarC_Ident.lident -> Prims.bool) = + fun env1 -> + fun m -> + let uu___ = get_extraction_mode env1 m in + uu___ = FStarC_Syntax_Syntax.Extract_reify +let rec args_are_binders : + 'uuuuu . + (FStarC_Syntax_Syntax.term * 'uuuuu) Prims.list -> + FStarC_Syntax_Syntax.binder Prims.list -> Prims.bool + = + fun args -> + fun bs -> + match (args, bs) with + | ((t, uu___)::args1, b::bs1) -> + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress t in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_name bv' -> + (FStarC_Syntax_Syntax.bv_eq b.FStarC_Syntax_Syntax.binder_bv + bv') + && (args_are_binders args1 bs1) + | uu___2 -> false) + | ([], []) -> true + | (uu___, uu___1) -> false +let (is_applied : + FStarC_TypeChecker_Cfg.cfg -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.bv FStar_Pervasives_Native.option) + = + fun cfg -> + fun bs -> + fun t -> + if (cfg.FStarC_TypeChecker_Cfg.debug).FStarC_TypeChecker_Cfg.wpe + then + (let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + let uu___2 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t in + FStarC_Compiler_Util.print2 "WPE> is_applied %s -- %s\n" uu___1 + uu___2) + else (); + (let uu___1 = FStarC_Syntax_Util.head_and_args_full t in + match uu___1 with + | (hd, args) -> + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress hd in + uu___3.FStarC_Syntax_Syntax.n in + (match uu___2 with + | FStarC_Syntax_Syntax.Tm_name bv when args_are_binders args bs + -> + (if + (cfg.FStarC_TypeChecker_Cfg.debug).FStarC_TypeChecker_Cfg.wpe + then + (let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_bv bv in + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term hd in + FStarC_Compiler_Util.print3 + "WPE> got it\n>>>>top = %s\n>>>>b = %s\n>>>>hd = %s\n" + uu___4 uu___5 uu___6) + else (); + FStar_Pervasives_Native.Some bv) + | uu___3 -> FStar_Pervasives_Native.None)) +let (is_applied_maybe_squashed : + FStarC_TypeChecker_Cfg.cfg -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.bv FStar_Pervasives_Native.option) + = + fun cfg -> + fun bs -> + fun t -> + if (cfg.FStarC_TypeChecker_Cfg.debug).FStarC_TypeChecker_Cfg.wpe + then + (let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + let uu___2 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t in + FStarC_Compiler_Util.print2 + "WPE> is_applied_maybe_squashed %s -- %s\n" uu___1 uu___2) + else (); + (let uu___1 = FStarC_Syntax_Util.is_squash t in + match uu___1 with + | FStar_Pervasives_Native.Some (uu___2, t') -> is_applied cfg bs t' + | uu___2 -> + let uu___3 = FStarC_Syntax_Util.is_auto_squash t in + (match uu___3 with + | FStar_Pervasives_Native.Some (uu___4, t') -> + is_applied cfg bs t' + | uu___4 -> is_applied cfg bs t)) +let (is_quantified_const : + FStarC_TypeChecker_Cfg.cfg -> + FStarC_Syntax_Syntax.bv -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun cfg -> + fun bv -> + fun phi -> + let guard b = + if b + then FStar_Pervasives_Native.Some () + else FStar_Pervasives_Native.None in + let phi0 = phi in + let types_match bs = + let uu___ = + let uu___1 = + FStarC_Compiler_Effect.op_Bang __get_n_binders in + uu___1 cfg.FStarC_TypeChecker_Cfg.tcenv + [FStarC_TypeChecker_Env.AllowUnboundUniverses] + (FStarC_Compiler_List.length bs) + bv.FStarC_Syntax_Syntax.sort in + match uu___ with + | (bs_q, uu___1) -> + let rec unrefine_true t = + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress t in + uu___3.FStarC_Syntax_Syntax.n in + match uu___2 with + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = b; + FStarC_Syntax_Syntax.phi = phi1;_} + when + FStarC_Syntax_Util.term_eq phi1 + FStarC_Syntax_Util.t_true + -> unrefine_true b.FStarC_Syntax_Syntax.sort + | uu___3 -> t in + ((FStarC_Compiler_List.length bs) = + (FStarC_Compiler_List.length bs_q)) + && + (FStarC_Compiler_List.forall2 + (fun b1 -> + fun b2 -> + let s1 = + unrefine_true + (b1.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + let s2 = + unrefine_true + (b2.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + FStarC_Syntax_Util.term_eq s1 s2) bs bs_q) in + let is_bv bv1 t = + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_name bv' -> + FStarC_Syntax_Syntax.bv_eq bv1 bv' + | uu___1 -> false in + let replace_full_applications_with bv1 arity s t = + let chgd = FStarC_Compiler_Util.mk_ref false in + let t' = + FStarC_Syntax_Visit.visit_term false + (fun t1 -> + let uu___ = FStarC_Syntax_Util.head_and_args t1 in + match uu___ with + | (hd, args) -> + let uu___1 = + ((FStarC_Compiler_List.length args) = arity) && + (is_bv bv1 hd) in + if uu___1 + then + (FStarC_Compiler_Effect.op_Colon_Equals chgd + true; + s) + else t1) t in + let uu___ = FStarC_Compiler_Effect.op_Bang chgd in + (t', uu___) in + let uu___ = FStarC_Syntax_Formula.destruct_typ_as_formula phi in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () (Obj.magic uu___) + (fun uu___1 -> + (fun form -> + let form = Obj.magic form in + match form with + | FStarC_Syntax_Formula.BaseConn + (lid, (p, uu___1)::(q, uu___2)::[]) when + FStarC_Ident.lid_equals lid + FStarC_Parser_Const.imp_lid + -> + Obj.magic + (Obj.repr + (if + (cfg.FStarC_TypeChecker_Cfg.debug).FStarC_TypeChecker_Cfg.wpe + then + (let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + p in + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + q in + FStarC_Compiler_Util.print2 + "WPE> p = (%s); q = (%s)\n" uu___4 + uu___5) + else (); + (let uu___4 = + let uu___5 = + FStarC_Syntax_Formula.destruct_typ_as_formula + p in + match uu___5 with + | FStar_Pervasives_Native.None -> + Obj.magic + (Obj.repr + (let uu___6 = + let uu___7 = + FStarC_Syntax_Subst.compress + p in + uu___7.FStarC_Syntax_Syntax.n in + match uu___6 with + | FStarC_Syntax_Syntax.Tm_bvar + bv' when + FStarC_Syntax_Syntax.bv_eq + bv bv' + -> + (if + (cfg.FStarC_TypeChecker_Cfg.debug).FStarC_TypeChecker_Cfg.wpe + then + FStarC_Compiler_Util.print_string + "WPE> Case 1\n" + else (); + (let q' = + FStarC_Syntax_Subst.subst + [FStarC_Syntax_Syntax.NT + (bv, + FStarC_Syntax_Util.t_true)] + q in + FStar_Pervasives_Native.Some + q')) + | uu___7 -> + FStar_Pervasives_Native.None)) + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Formula.BaseConn + (lid1, (p1, uu___6)::[])) when + FStarC_Ident.lid_equals lid1 + FStarC_Parser_Const.not_lid + -> + Obj.magic + (Obj.repr + (let uu___7 = + let uu___8 = + FStarC_Syntax_Subst.compress + p1 in + uu___8.FStarC_Syntax_Syntax.n in + match uu___7 with + | FStarC_Syntax_Syntax.Tm_bvar + bv' when + FStarC_Syntax_Syntax.bv_eq + bv bv' + -> + (if + (cfg.FStarC_TypeChecker_Cfg.debug).FStarC_TypeChecker_Cfg.wpe + then + FStarC_Compiler_Util.print_string + "WPE> Case 2\n" + else (); + (let q' = + FStarC_Syntax_Subst.subst + [FStarC_Syntax_Syntax.NT + (bv, + FStarC_Syntax_Util.t_false)] + q in + FStar_Pervasives_Native.Some + q')) + | uu___8 -> + FStar_Pervasives_Native.None)) + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Formula.QAll + (bs, pats, phi1)) when + types_match bs -> + Obj.magic + (Obj.repr + (let uu___6 = + FStarC_Syntax_Formula.destruct_typ_as_formula + phi1 in + match uu___6 with + | FStar_Pervasives_Native.None + -> + Obj.repr + (let uu___7 = + is_applied_maybe_squashed + cfg bs phi1 in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () + (Obj.magic uu___7) + (fun uu___8 -> + (fun bv' -> + let bv' = + Obj.magic + bv' in + let uu___8 = + let uu___9 + = + FStarC_Syntax_Syntax.bv_eq + bv bv' in + guard + uu___9 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () + uu___8 + (fun + uu___9 -> + (fun + uu___9 -> + let uu___9 + = + Obj.magic + uu___9 in + if + (cfg.FStarC_TypeChecker_Cfg.debug).FStarC_TypeChecker_Cfg.wpe + then + FStarC_Compiler_Util.print_string + "WPE> Case 3\n" + else (); + ( + let uu___11 + = + replace_full_applications_with + bv + (FStarC_Compiler_List.length + bs) + FStarC_Syntax_Util.t_true + q in + match uu___11 + with + | + (q', + chgd) -> + let uu___12 + = + guard + chgd in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () + uu___12 + (fun + uu___13 + -> + (fun + uu___13 + -> + let uu___13 + = + Obj.magic + uu___13 in + Obj.magic + (FStar_Pervasives_Native.Some + q')) + uu___13)))) + uu___9))) + uu___8)) + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Formula.BaseConn + (lid1, (p1, uu___7)::[])) + when + FStarC_Ident.lid_equals + lid1 + FStarC_Parser_Const.not_lid + -> + Obj.repr + (let uu___8 = + is_applied_maybe_squashed + cfg bs p1 in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () + (Obj.magic uu___8) + (fun uu___9 -> + (fun bv' -> + let bv' = + Obj.magic + bv' in + let uu___9 = + let uu___10 + = + FStarC_Syntax_Syntax.bv_eq + bv bv' in + guard + uu___10 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () + uu___9 + (fun + uu___10 + -> + (fun + uu___10 + -> + let uu___10 + = + Obj.magic + uu___10 in + if + (cfg.FStarC_TypeChecker_Cfg.debug).FStarC_TypeChecker_Cfg.wpe + then + FStarC_Compiler_Util.print_string + "WPE> Case 4\n" + else (); + ( + let uu___12 + = + replace_full_applications_with + bv + (FStarC_Compiler_List.length + bs) + FStarC_Syntax_Util.t_false + q in + match uu___12 + with + | + (q', + chgd) -> + let uu___13 + = + guard + chgd in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () + uu___13 + (fun + uu___14 + -> + (fun + uu___14 + -> + let uu___14 + = + Obj.magic + uu___14 in + Obj.magic + (FStar_Pervasives_Native.Some + q')) + uu___14)))) + uu___10))) + uu___9)) + | uu___7 -> + Obj.repr + FStar_Pervasives_Native.None)) + | uu___6 -> + Obj.magic + (Obj.repr + FStar_Pervasives_Native.None) in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () + (Obj.magic uu___4) + (fun uu___5 -> + (fun q' -> + let q' = Obj.magic q' in + let phi' = + let uu___5 = + FStarC_Syntax_Syntax.fvar + FStarC_Parser_Const.imp_lid + FStar_Pervasives_Native.None in + let uu___6 = + let uu___7 = + FStarC_Syntax_Syntax.as_arg + p in + let uu___8 = + let uu___9 = + FStarC_Syntax_Syntax.as_arg + q' in + [uu___9] in + uu___7 :: uu___8 in + FStarC_Syntax_Util.mk_app + uu___5 uu___6 in + Obj.magic + (FStar_Pervasives_Native.Some + phi')) uu___5)))) + | uu___1 -> + Obj.magic + (Obj.repr FStar_Pervasives_Native.None)) + uu___1))) uu___2 uu___1 uu___ +let (is_forall_const : + FStarC_TypeChecker_Cfg.cfg -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = + fun uu___1 -> + fun uu___ -> + (fun cfg -> + fun phi -> + let uu___ = FStarC_Syntax_Formula.destruct_typ_as_formula phi in + match uu___ with + | FStar_Pervasives_Native.Some (FStarC_Syntax_Formula.QAll + (b::[], uu___1, phi')) -> + Obj.magic + (Obj.repr + (if + (cfg.FStarC_TypeChecker_Cfg.debug).FStarC_TypeChecker_Cfg.wpe + then + (let uu___3 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_bv + b.FStarC_Syntax_Syntax.binder_bv in + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term phi' in + FStarC_Compiler_Util.print2 "WPE> QAll [%s] %s\n" + uu___3 uu___4) + else (); + (let uu___3 = + is_quantified_const cfg + b.FStarC_Syntax_Syntax.binder_bv phi' in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () + (Obj.magic uu___3) + (fun uu___4 -> + (fun phi'1 -> + let phi'1 = Obj.magic phi'1 in + let uu___4 = + let uu___5 = + (cfg.FStarC_TypeChecker_Cfg.tcenv).FStarC_TypeChecker_Env.universe_of + cfg.FStarC_TypeChecker_Cfg.tcenv + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + FStarC_Syntax_Util.mk_forall uu___5 + b.FStarC_Syntax_Syntax.binder_bv phi'1 in + Obj.magic (FStar_Pervasives_Native.Some uu___4)) + uu___4)))) + | uu___1 -> Obj.magic (Obj.repr FStar_Pervasives_Native.None)) + uu___1 uu___ +let (is_extract_as_attr : + FStarC_Syntax_Syntax.attribute -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = + fun attr -> + let uu___ = FStarC_Syntax_Util.head_and_args attr in + match uu___ with + | (head, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress head in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, (t, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.extract_as_lid + -> + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.compress t in + uu___4.FStarC_Syntax_Syntax.n in + (match uu___3 with + | FStarC_Syntax_Syntax.Tm_quoted (impl, uu___4) -> + FStar_Pervasives_Native.Some impl + | uu___4 -> FStar_Pervasives_Native.None) + | uu___2 -> FStar_Pervasives_Native.None) +let (has_extract_as_attr : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lid -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = + fun g -> + fun lid -> + let uu___ = FStarC_TypeChecker_Env.lookup_attrs_of_lid g lid in + match uu___ with + | FStar_Pervasives_Native.Some attrs -> + FStarC_Compiler_Util.find_map attrs is_extract_as_attr + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None +let rec (norm : + FStarC_TypeChecker_Cfg.cfg -> + env -> stack -> FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun cfg -> + fun env1 -> + fun stack1 -> + fun t -> + let rec collapse_metas st = + match st with + | (Meta + (uu___, FStarC_Syntax_Syntax.Meta_monadic uu___1, uu___2))::(Meta + (e, FStarC_Syntax_Syntax.Meta_monadic m, r))::st' -> + collapse_metas + ((Meta (e, (FStarC_Syntax_Syntax.Meta_monadic m), r)) :: + st') + | uu___ -> st in + let stack2 = collapse_metas stack1 in + let t1 = + if + (cfg.FStarC_TypeChecker_Cfg.debug).FStarC_TypeChecker_Cfg.norm_delayed + then + (match t.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_delayed uu___1 -> + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + t in + FStarC_Compiler_Util.print1 "NORM delayed: %s\n" uu___2 + | uu___1 -> ()) + else (); + FStarC_Syntax_Subst.compress t in + FStarC_TypeChecker_Cfg.log cfg + (fun uu___1 -> + let uu___2 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term + t1 in + let uu___3 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.no_full_norm in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + let uu___5 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_nat) + (FStarC_Compiler_List.length env1) in + let uu___6 = + let uu___7 = + let uu___8 = firstn (Prims.of_int (4)) stack2 in + FStar_Pervasives_Native.fst uu___8 in + FStarC_Class_Show.show + (FStarC_Class_Show.show_list showable_stack_elt) uu___7 in + FStarC_Compiler_Util.print5 + ">>> %s (no_full_norm=%s)\nNorm %s with %s env elements; top of the stack = %s\n" + uu___2 uu___3 uu___4 uu___5 uu___6); + FStarC_TypeChecker_Cfg.log_cfg cfg + (fun uu___2 -> + let uu___3 = + FStarC_Class_Show.show FStarC_TypeChecker_Cfg.showable_cfg + cfg in + FStarC_Compiler_Util.print1 ">>> cfg = %s\n" uu___3); + (match t1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_unknown -> + rebuild cfg empty_env stack2 t1 + | FStarC_Syntax_Syntax.Tm_constant uu___2 -> + rebuild cfg empty_env stack2 t1 + | FStarC_Syntax_Syntax.Tm_name uu___2 -> + rebuild cfg empty_env stack2 t1 + | FStarC_Syntax_Syntax.Tm_lazy uu___2 -> + rebuild cfg empty_env stack2 t1 + | FStarC_Syntax_Syntax.Tm_fvar + { FStarC_Syntax_Syntax.fv_name = uu___2; + FStarC_Syntax_Syntax.fv_qual = FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Data_ctor);_} + -> + (FStarC_TypeChecker_Cfg.log_unfolding cfg + (fun uu___4 -> + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.print1 + " >> This is a constructor: %s\n" uu___5); + rebuild cfg empty_env stack2 t1) + | FStarC_Syntax_Syntax.Tm_fvar + { FStarC_Syntax_Syntax.fv_name = uu___2; + FStarC_Syntax_Syntax.fv_qual = FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Record_ctor uu___3);_} + -> + (FStarC_TypeChecker_Cfg.log_unfolding cfg + (fun uu___5 -> + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.print1 + " >> This is a constructor: %s\n" uu___6); + rebuild cfg empty_env stack2 t1) + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let lid = FStarC_Syntax_Syntax.lid_of_fv fv in + let qninfo = + FStarC_TypeChecker_Env.lookup_qname + cfg.FStarC_TypeChecker_Cfg.tcenv lid in + let uu___2 = + FStarC_TypeChecker_Env.delta_depth_of_qninfo + cfg.FStarC_TypeChecker_Cfg.tcenv fv qninfo in + (match uu___2 with + | FStarC_Syntax_Syntax.Delta_constant_at_level uu___3 when + uu___3 = Prims.int_zero -> + (FStarC_TypeChecker_Cfg.log_unfolding cfg + (fun uu___5 -> + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.print1 + " >> This is a constant: %s\n" uu___6); + rebuild cfg empty_env stack2 t1) + | uu___3 -> + let uu___4 = decide_unfolding cfg stack2 fv qninfo in + (match uu___4 with + | FStar_Pervasives_Native.Some + (FStar_Pervasives_Native.None, stack3) -> + do_unfold_fv cfg stack3 t1 qninfo fv + | FStar_Pervasives_Native.Some + (FStar_Pervasives_Native.Some cfg1, stack3) -> + let uu___5 = do_unfold_fv cfg1 [] t1 qninfo fv in + rebuild cfg1 empty_env stack3 uu___5 + | FStar_Pervasives_Native.None -> + rebuild cfg empty_env stack2 t1)) + | FStarC_Syntax_Syntax.Tm_quoted (qt, qi) -> + let qi1 = + FStarC_Syntax_Syntax.on_antiquoted (norm cfg env1 []) qi in + let t2 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_quoted (qt, qi1)) + t1.FStarC_Syntax_Syntax.pos in + let uu___2 = closure_as_term cfg env1 t2 in + rebuild cfg env1 stack2 uu___2 + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = hd; + FStarC_Syntax_Syntax.args = args;_} + when + (should_consider_norm_requests cfg) && + (let uu___2 = is_norm_request hd args in + uu___2 = Norm_request_requires_rejig) + -> + (if + (cfg.FStarC_TypeChecker_Cfg.debug).FStarC_TypeChecker_Cfg.print_normalized + then + FStarC_Compiler_Util.print_string + "Rejigging norm request ... \n" + else (); + (let uu___3 = rejig_norm_request hd args in + norm cfg env1 stack2 uu___3)) + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = hd; + FStarC_Syntax_Syntax.args = args;_} + when + (should_consider_norm_requests cfg) && + (let uu___2 = is_norm_request hd args in + uu___2 = Norm_request_ready) + -> + (if + (cfg.FStarC_TypeChecker_Cfg.debug).FStarC_TypeChecker_Cfg.print_normalized + then + (let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + hd in + let uu___4 = FStarC_Syntax_Print.args_to_string args in + FStarC_Compiler_Util.print2 + "Potential norm request with hd = %s and args = %s ... \n" + uu___3 uu___4) + else (); + (let cfg' = + { + FStarC_TypeChecker_Cfg.steps = + (let uu___3 = cfg.FStarC_TypeChecker_Cfg.steps in + { + FStarC_TypeChecker_Cfg.beta = + (uu___3.FStarC_TypeChecker_Cfg.beta); + FStarC_TypeChecker_Cfg.iota = + (uu___3.FStarC_TypeChecker_Cfg.iota); + FStarC_TypeChecker_Cfg.zeta = + (uu___3.FStarC_TypeChecker_Cfg.zeta); + FStarC_TypeChecker_Cfg.zeta_full = + (uu___3.FStarC_TypeChecker_Cfg.zeta_full); + FStarC_TypeChecker_Cfg.weak = + (uu___3.FStarC_TypeChecker_Cfg.weak); + FStarC_TypeChecker_Cfg.hnf = + (uu___3.FStarC_TypeChecker_Cfg.hnf); + FStarC_TypeChecker_Cfg.primops = + (uu___3.FStarC_TypeChecker_Cfg.primops); + FStarC_TypeChecker_Cfg.do_not_unfold_pure_lets = + false; + FStarC_TypeChecker_Cfg.unfold_until = + (uu___3.FStarC_TypeChecker_Cfg.unfold_until); + FStarC_TypeChecker_Cfg.unfold_only = + FStar_Pervasives_Native.None; + FStarC_TypeChecker_Cfg.unfold_fully = + FStar_Pervasives_Native.None; + FStarC_TypeChecker_Cfg.unfold_attr = + (uu___3.FStarC_TypeChecker_Cfg.unfold_attr); + FStarC_TypeChecker_Cfg.unfold_qual = + (uu___3.FStarC_TypeChecker_Cfg.unfold_qual); + FStarC_TypeChecker_Cfg.unfold_namespace = + (uu___3.FStarC_TypeChecker_Cfg.unfold_namespace); + FStarC_TypeChecker_Cfg.dont_unfold_attr = + (uu___3.FStarC_TypeChecker_Cfg.dont_unfold_attr); + FStarC_TypeChecker_Cfg.pure_subterms_within_computations + = + (uu___3.FStarC_TypeChecker_Cfg.pure_subterms_within_computations); + FStarC_TypeChecker_Cfg.simplify = + (uu___3.FStarC_TypeChecker_Cfg.simplify); + FStarC_TypeChecker_Cfg.erase_universes = + (uu___3.FStarC_TypeChecker_Cfg.erase_universes); + FStarC_TypeChecker_Cfg.allow_unbound_universes = + (uu___3.FStarC_TypeChecker_Cfg.allow_unbound_universes); + FStarC_TypeChecker_Cfg.reify_ = + (uu___3.FStarC_TypeChecker_Cfg.reify_); + FStarC_TypeChecker_Cfg.compress_uvars = + (uu___3.FStarC_TypeChecker_Cfg.compress_uvars); + FStarC_TypeChecker_Cfg.no_full_norm = + (uu___3.FStarC_TypeChecker_Cfg.no_full_norm); + FStarC_TypeChecker_Cfg.check_no_uvars = + (uu___3.FStarC_TypeChecker_Cfg.check_no_uvars); + FStarC_TypeChecker_Cfg.unmeta = + (uu___3.FStarC_TypeChecker_Cfg.unmeta); + FStarC_TypeChecker_Cfg.unascribe = + (uu___3.FStarC_TypeChecker_Cfg.unascribe); + FStarC_TypeChecker_Cfg.in_full_norm_request = + (uu___3.FStarC_TypeChecker_Cfg.in_full_norm_request); + FStarC_TypeChecker_Cfg.weakly_reduce_scrutinee = + (uu___3.FStarC_TypeChecker_Cfg.weakly_reduce_scrutinee); + FStarC_TypeChecker_Cfg.nbe_step = + (uu___3.FStarC_TypeChecker_Cfg.nbe_step); + FStarC_TypeChecker_Cfg.for_extraction = + (uu___3.FStarC_TypeChecker_Cfg.for_extraction); + FStarC_TypeChecker_Cfg.unrefine = + (uu___3.FStarC_TypeChecker_Cfg.unrefine); + FStarC_TypeChecker_Cfg.default_univs_to_zero = + (uu___3.FStarC_TypeChecker_Cfg.default_univs_to_zero); + FStarC_TypeChecker_Cfg.tactics = + (uu___3.FStarC_TypeChecker_Cfg.tactics) + }); + FStarC_TypeChecker_Cfg.tcenv = + (cfg.FStarC_TypeChecker_Cfg.tcenv); + FStarC_TypeChecker_Cfg.debug = + (cfg.FStarC_TypeChecker_Cfg.debug); + FStarC_TypeChecker_Cfg.delta_level = + [FStarC_TypeChecker_Env.Unfold + FStarC_Syntax_Syntax.delta_constant]; + FStarC_TypeChecker_Cfg.primitive_steps = + (cfg.FStarC_TypeChecker_Cfg.primitive_steps); + FStarC_TypeChecker_Cfg.strong = + (cfg.FStarC_TypeChecker_Cfg.strong); + FStarC_TypeChecker_Cfg.memoize_lazy = + (cfg.FStarC_TypeChecker_Cfg.memoize_lazy); + FStarC_TypeChecker_Cfg.normalize_pure_lets = true; + FStarC_TypeChecker_Cfg.reifying = + (cfg.FStarC_TypeChecker_Cfg.reifying); + FStarC_TypeChecker_Cfg.compat_memo_ignore_cfg = + (cfg.FStarC_TypeChecker_Cfg.compat_memo_ignore_cfg) + } in + let uu___3 = get_norm_request cfg (norm cfg' env1 []) args in + match uu___3 with + | FStar_Pervasives_Native.None -> + (if + (cfg.FStarC_TypeChecker_Cfg.debug).FStarC_TypeChecker_Cfg.print_normalized + then + FStarC_Compiler_Util.print_string + "Norm request None ... \n" + else (); + (let stack3 = + FStarC_Compiler_List.fold_right + (fun uu___5 -> + fun stack4 -> + match uu___5 with + | (a, aq) -> + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = fresh_memo () in + (env1, a, uu___10, false) in + Clos uu___9 in + (uu___8, aq, + (t1.FStarC_Syntax_Syntax.pos)) in + Arg uu___7 in + uu___6 :: stack4) args stack2 in + FStarC_TypeChecker_Cfg.log cfg + (fun uu___6 -> + let uu___7 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length args) in + FStarC_Compiler_Util.print1 + "\tPushed %s arguments\n" uu___7); + norm cfg env1 stack3 hd)) + | FStar_Pervasives_Native.Some (s, tm) when is_nbe_request s + -> + let tm' = closure_as_term cfg env1 tm in + let start = FStarC_Compiler_Util.now () in + let tm_norm = nbe_eval cfg s tm' in + let fin = FStarC_Compiler_Util.now () in + (if + (cfg.FStarC_TypeChecker_Cfg.debug).FStarC_TypeChecker_Cfg.print_normalized + then + (let cfg'1 = + FStarC_TypeChecker_Cfg.config s + cfg.FStarC_TypeChecker_Cfg.tcenv in + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Compiler_Util.time_diff start fin in + FStar_Pervasives_Native.snd uu___7 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) uu___6 in + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term tm' in + let uu___7 = + FStarC_Class_Show.show + FStarC_TypeChecker_Cfg.showable_cfg cfg'1 in + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term tm_norm in + FStarC_Compiler_Util.print4 + "NBE result timing (%s ms){\nOn term {\n%s\n}\nwith steps {%s}\nresult is{\n\n%s\n}\n}\n" + uu___5 uu___6 uu___7 uu___8) + else (); + rebuild cfg env1 stack2 tm_norm) + | FStar_Pervasives_Native.Some (s, tm) -> + (if + (cfg.FStarC_TypeChecker_Cfg.debug).FStarC_TypeChecker_Cfg.print_normalized + then + (let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term tm in + FStarC_Compiler_Util.format1 + "Starting norm request on `%s`." uu___8 in + FStarC_Errors_Msg.text uu___7 in + let uu___7 = + let uu___8 = + let uu___9 = FStarC_Errors_Msg.text "Steps =" in + let uu___10 = + let uu___11 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_TypeChecker_Env.showable_step) + s in + FStarC_Errors_Msg.text uu___11 in + FStarC_Pprint.op_Hat_Slash_Hat uu___9 uu___10 in + [uu___8] in + uu___6 :: uu___7 in + FStarC_Errors.diag + FStarC_Class_HasRange.hasRange_range + tm.FStarC_Syntax_Syntax.pos () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___5)) + else (); + (let delta_level = + let uu___5 = + FStarC_Compiler_Util.for_some + (fun uu___6 -> + match uu___6 with + | FStarC_TypeChecker_Env.UnfoldUntil uu___7 + -> true + | FStarC_TypeChecker_Env.UnfoldOnly uu___7 -> + true + | FStarC_TypeChecker_Env.UnfoldFully uu___7 + -> true + | uu___7 -> false) s in + if uu___5 + then + [FStarC_TypeChecker_Env.Unfold + FStarC_Syntax_Syntax.delta_constant] + else + if + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.for_extraction + then + [FStarC_TypeChecker_Env.Eager_unfolding_only; + FStarC_TypeChecker_Env.InliningDelta] + else [FStarC_TypeChecker_Env.NoDelta] in + let cfg'1 = + let uu___5 = + let uu___6 = FStarC_TypeChecker_Cfg.to_fsteps s in + { + FStarC_TypeChecker_Cfg.beta = + (uu___6.FStarC_TypeChecker_Cfg.beta); + FStarC_TypeChecker_Cfg.iota = + (uu___6.FStarC_TypeChecker_Cfg.iota); + FStarC_TypeChecker_Cfg.zeta = + (uu___6.FStarC_TypeChecker_Cfg.zeta); + FStarC_TypeChecker_Cfg.zeta_full = + (uu___6.FStarC_TypeChecker_Cfg.zeta_full); + FStarC_TypeChecker_Cfg.weak = + (uu___6.FStarC_TypeChecker_Cfg.weak); + FStarC_TypeChecker_Cfg.hnf = + (uu___6.FStarC_TypeChecker_Cfg.hnf); + FStarC_TypeChecker_Cfg.primops = + (uu___6.FStarC_TypeChecker_Cfg.primops); + FStarC_TypeChecker_Cfg.do_not_unfold_pure_lets = + (uu___6.FStarC_TypeChecker_Cfg.do_not_unfold_pure_lets); + FStarC_TypeChecker_Cfg.unfold_until = + (uu___6.FStarC_TypeChecker_Cfg.unfold_until); + FStarC_TypeChecker_Cfg.unfold_only = + (uu___6.FStarC_TypeChecker_Cfg.unfold_only); + FStarC_TypeChecker_Cfg.unfold_fully = + (uu___6.FStarC_TypeChecker_Cfg.unfold_fully); + FStarC_TypeChecker_Cfg.unfold_attr = + (uu___6.FStarC_TypeChecker_Cfg.unfold_attr); + FStarC_TypeChecker_Cfg.unfold_qual = + (uu___6.FStarC_TypeChecker_Cfg.unfold_qual); + FStarC_TypeChecker_Cfg.unfold_namespace = + (uu___6.FStarC_TypeChecker_Cfg.unfold_namespace); + FStarC_TypeChecker_Cfg.dont_unfold_attr = + (uu___6.FStarC_TypeChecker_Cfg.dont_unfold_attr); + FStarC_TypeChecker_Cfg.pure_subterms_within_computations + = + (uu___6.FStarC_TypeChecker_Cfg.pure_subterms_within_computations); + FStarC_TypeChecker_Cfg.simplify = + (uu___6.FStarC_TypeChecker_Cfg.simplify); + FStarC_TypeChecker_Cfg.erase_universes = + (uu___6.FStarC_TypeChecker_Cfg.erase_universes); + FStarC_TypeChecker_Cfg.allow_unbound_universes = + (uu___6.FStarC_TypeChecker_Cfg.allow_unbound_universes); + FStarC_TypeChecker_Cfg.reify_ = + (uu___6.FStarC_TypeChecker_Cfg.reify_); + FStarC_TypeChecker_Cfg.compress_uvars = + (uu___6.FStarC_TypeChecker_Cfg.compress_uvars); + FStarC_TypeChecker_Cfg.no_full_norm = + (uu___6.FStarC_TypeChecker_Cfg.no_full_norm); + FStarC_TypeChecker_Cfg.check_no_uvars = + (uu___6.FStarC_TypeChecker_Cfg.check_no_uvars); + FStarC_TypeChecker_Cfg.unmeta = + (uu___6.FStarC_TypeChecker_Cfg.unmeta); + FStarC_TypeChecker_Cfg.unascribe = + (uu___6.FStarC_TypeChecker_Cfg.unascribe); + FStarC_TypeChecker_Cfg.in_full_norm_request = + true; + FStarC_TypeChecker_Cfg.weakly_reduce_scrutinee = + (uu___6.FStarC_TypeChecker_Cfg.weakly_reduce_scrutinee); + FStarC_TypeChecker_Cfg.nbe_step = + (uu___6.FStarC_TypeChecker_Cfg.nbe_step); + FStarC_TypeChecker_Cfg.for_extraction = + ((cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.for_extraction); + FStarC_TypeChecker_Cfg.unrefine = + (uu___6.FStarC_TypeChecker_Cfg.unrefine); + FStarC_TypeChecker_Cfg.default_univs_to_zero = + (uu___6.FStarC_TypeChecker_Cfg.default_univs_to_zero); + FStarC_TypeChecker_Cfg.tactics = + (uu___6.FStarC_TypeChecker_Cfg.tactics) + } in + { + FStarC_TypeChecker_Cfg.steps = uu___5; + FStarC_TypeChecker_Cfg.tcenv = + (cfg.FStarC_TypeChecker_Cfg.tcenv); + FStarC_TypeChecker_Cfg.debug = + (cfg.FStarC_TypeChecker_Cfg.debug); + FStarC_TypeChecker_Cfg.delta_level = delta_level; + FStarC_TypeChecker_Cfg.primitive_steps = + (cfg.FStarC_TypeChecker_Cfg.primitive_steps); + FStarC_TypeChecker_Cfg.strong = + (cfg.FStarC_TypeChecker_Cfg.strong); + FStarC_TypeChecker_Cfg.memoize_lazy = + (cfg.FStarC_TypeChecker_Cfg.memoize_lazy); + FStarC_TypeChecker_Cfg.normalize_pure_lets = true; + FStarC_TypeChecker_Cfg.reifying = + (cfg.FStarC_TypeChecker_Cfg.reifying); + FStarC_TypeChecker_Cfg.compat_memo_ignore_cfg = + (cfg.FStarC_TypeChecker_Cfg.compat_memo_ignore_cfg) + } in + let t0 = FStarC_Compiler_Util.now () in + let uu___5 = + FStarC_Compiler_Util.record_time + (fun uu___6 -> norm cfg'1 env1 [] tm) in + match uu___5 with + | (tm_normed, ms) -> + (maybe_debug cfg tm_normed + (FStar_Pervasives_Native.Some (tm, t0)); + rebuild cfg env1 stack2 tm_normed))))) + | FStarC_Syntax_Syntax.Tm_type u -> + let u1 = norm_universe cfg env1 u in + let uu___2 = + FStarC_Syntax_Syntax.mk (FStarC_Syntax_Syntax.Tm_type u1) + t1.FStarC_Syntax_Syntax.pos in + rebuild cfg env1 stack2 uu___2 + | FStarC_Syntax_Syntax.Tm_uinst (t', us) -> + if + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.erase_universes + then norm cfg env1 stack2 t' + else + (let us1 = + let uu___3 = + let uu___4 = + FStarC_Compiler_List.map (norm_universe cfg env1) us in + (uu___4, (t1.FStarC_Syntax_Syntax.pos)) in + UnivArgs uu___3 in + let stack3 = us1 :: stack2 in norm cfg env1 stack3 t') + | FStarC_Syntax_Syntax.Tm_bvar x -> + let uu___2 = lookup_bvar env1 x in + (match uu___2 with + | Univ uu___3 -> + failwith + "Impossible: term variable is bound to a universe" + | Dummy -> failwith "Term variable not found" + | Clos (env2, t0, r, fix) -> + if + ((Prims.op_Negation fix) || + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.zeta) + || + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.zeta_full + then + let uu___3 = read_memo cfg r in + (match uu___3 with + | FStar_Pervasives_Native.Some (env3, t') -> + (FStarC_TypeChecker_Cfg.log cfg + (fun uu___5 -> + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t1 in + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t' in + FStarC_Compiler_Util.print2 + "Lazy hit: %s cached to %s\n" uu___6 + uu___7); + (let uu___5 = maybe_weakly_reduced t' in + if uu___5 + then + match stack2 with + | [] when + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.weak + || + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.compress_uvars + -> rebuild cfg env3 stack2 t' + | uu___6 -> norm cfg env3 stack2 t' + else rebuild cfg env3 stack2 t')) + | FStar_Pervasives_Native.None -> + norm cfg env2 ((MemoLazy r) :: stack2) t0) + else norm cfg env2 stack2 t0) + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs; + FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = rc_opt;_} + -> + let rec maybe_strip_meta_divs stack3 = + match stack3 with + | [] -> FStar_Pervasives_Native.None + | (Meta + (uu___2, FStarC_Syntax_Syntax.Meta_monadic (m, uu___3), + uu___4))::tl + when + FStarC_Ident.lid_equals m + FStarC_Parser_Const.effect_DIV_lid + -> maybe_strip_meta_divs tl + | (Meta + (uu___2, FStarC_Syntax_Syntax.Meta_monadic_lift + (src, tgt, uu___3), uu___4))::tl + when + (FStarC_Ident.lid_equals src + FStarC_Parser_Const.effect_PURE_lid) + && + (FStarC_Ident.lid_equals tgt + FStarC_Parser_Const.effect_DIV_lid) + -> maybe_strip_meta_divs tl + | (Arg uu___2)::uu___3 -> + FStar_Pervasives_Native.Some stack3 + | uu___2 -> FStar_Pervasives_Native.None in + let fallback uu___2 = + if + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.weak + then + let t2 = closure_as_term cfg env1 t1 in + rebuild cfg env1 stack2 t2 + else + (let uu___4 = FStarC_Syntax_Subst.open_term' bs body in + match uu___4 with + | (bs1, body1, opening) -> + let env' = + FStarC_Compiler_List.fold_left + (fun env2 -> + fun uu___5 -> + let uu___6 = dummy () in uu___6 :: env2) + env1 bs1 in + let rc_opt1 = + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () + (Obj.magic rc_opt) + (fun uu___5 -> + (fun rc -> + let rc = Obj.magic rc in + let rc1 = maybe_drop_rc_typ cfg rc in + let uu___5 = + let uu___6 = + FStarC_Compiler_Util.map_option + (FStarC_Syntax_Subst.subst opening) + rc1.FStarC_Syntax_Syntax.residual_typ in + { + FStarC_Syntax_Syntax.residual_effect + = + (rc1.FStarC_Syntax_Syntax.residual_effect); + FStarC_Syntax_Syntax.residual_typ = + uu___6; + FStarC_Syntax_Syntax.residual_flags + = + (rc1.FStarC_Syntax_Syntax.residual_flags) + } in + Obj.magic + (FStar_Pervasives_Native.Some uu___5)) + uu___5)) in + (FStarC_TypeChecker_Cfg.log cfg + (fun uu___6 -> + let uu___7 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length bs1) in + FStarC_Compiler_Util.print1 + "\tShifted %s dummies\n" uu___7); + (let cfg' = + { + FStarC_TypeChecker_Cfg.steps = + (cfg.FStarC_TypeChecker_Cfg.steps); + FStarC_TypeChecker_Cfg.tcenv = + (cfg.FStarC_TypeChecker_Cfg.tcenv); + FStarC_TypeChecker_Cfg.debug = + (cfg.FStarC_TypeChecker_Cfg.debug); + FStarC_TypeChecker_Cfg.delta_level = + (cfg.FStarC_TypeChecker_Cfg.delta_level); + FStarC_TypeChecker_Cfg.primitive_steps = + (cfg.FStarC_TypeChecker_Cfg.primitive_steps); + FStarC_TypeChecker_Cfg.strong = true; + FStarC_TypeChecker_Cfg.memoize_lazy = + (cfg.FStarC_TypeChecker_Cfg.memoize_lazy); + FStarC_TypeChecker_Cfg.normalize_pure_lets = + (cfg.FStarC_TypeChecker_Cfg.normalize_pure_lets); + FStarC_TypeChecker_Cfg.reifying = + (cfg.FStarC_TypeChecker_Cfg.reifying); + FStarC_TypeChecker_Cfg.compat_memo_ignore_cfg = + (cfg.FStarC_TypeChecker_Cfg.compat_memo_ignore_cfg) + } in + let body_norm = + norm cfg env' + [Abs + (env1, bs1, env', rc_opt1, + (t1.FStarC_Syntax_Syntax.pos))] body1 in + rebuild cfg env1 stack2 body_norm))) in + (match stack2 with + | (UnivArgs uu___2)::uu___3 -> + failwith + "Ill-typed term: universes cannot be applied to term abstraction" + | (Arg (Univ u, uu___2, uu___3))::stack_rest -> + let uu___4 = + let uu___5 = + let uu___6 = fresh_memo () in + (FStar_Pervasives_Native.None, (Univ u), uu___6) in + uu___5 :: env1 in + norm cfg uu___4 stack_rest t1 + | (Arg (c, uu___2, uu___3))::stack_rest -> + (match bs with + | [] -> failwith "Impossible" + | b::[] -> + (FStarC_TypeChecker_Cfg.log cfg + (fun uu___5 -> + let uu___6 = + FStarC_Class_Show.show showable_closure c in + FStarC_Compiler_Util.print1 "\tShifted %s\n" + uu___6); + (let uu___5 = + let uu___6 = + let uu___7 = fresh_memo () in + ((FStar_Pervasives_Native.Some b), c, uu___7) in + uu___6 :: env1 in + norm cfg uu___5 stack_rest body)) + | b::tl -> + (FStarC_TypeChecker_Cfg.log cfg + (fun uu___5 -> + let uu___6 = + FStarC_Class_Show.show showable_closure c in + FStarC_Compiler_Util.print1 "\tShifted %s\n" + uu___6); + (let body1 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs = tl; + FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = rc_opt + }) t1.FStarC_Syntax_Syntax.pos in + let uu___5 = + let uu___6 = + let uu___7 = fresh_memo () in + ((FStar_Pervasives_Native.Some b), c, uu___7) in + uu___6 :: env1 in + norm cfg uu___5 stack_rest body1))) + | (MemoLazy r)::stack3 -> + (set_memo cfg r (env1, t1); + FStarC_TypeChecker_Cfg.log cfg + (fun uu___4 -> + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.print1 "\tSet memo %s\n" + uu___5); + norm cfg env1 stack3 t1) + | (Meta uu___2)::uu___3 -> + let uu___4 = maybe_strip_meta_divs stack2 in + (match uu___4 with + | FStar_Pervasives_Native.None -> fallback () + | FStar_Pervasives_Native.Some stack3 -> + norm cfg env1 stack3 t1) + | (Match uu___2)::uu___3 -> fallback () + | (Let uu___2)::uu___3 -> fallback () + | (App uu___2)::uu___3 -> fallback () + | (CBVApp uu___2)::uu___3 -> fallback () + | (Abs uu___2)::uu___3 -> fallback () + | [] -> fallback ()) + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = args;_} + -> + let strict_args = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Util.unascribe head in + FStarC_Syntax_Util.un_uinst uu___4 in + uu___3.FStarC_Syntax_Syntax.n in + match uu___2 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + FStarC_TypeChecker_Env.fv_has_strict_args + cfg.FStarC_TypeChecker_Cfg.tcenv fv + | uu___3 -> FStar_Pervasives_Native.None in + (match strict_args with + | FStar_Pervasives_Native.None -> + let stack3 = + FStarC_Compiler_List.fold_right + (fun uu___2 -> + fun stack4 -> + match uu___2 with + | (a, aq) -> + let a1 = + let uu___3 = + (((let uu___4 = + FStarC_TypeChecker_Cfg.cfg_env cfg in + uu___4.FStarC_TypeChecker_Env.erase_erasable_args) + || + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.for_extraction) + || + (cfg.FStarC_TypeChecker_Cfg.debug).FStarC_TypeChecker_Cfg.erase_erasable_args) + && + (FStarC_Syntax_Util.aqual_is_erasable + aq) in + if uu___3 + then FStarC_Syntax_Util.exp_unit + else a in + let env2 = + let uu___3 = + let uu___4 = + FStarC_Syntax_Subst.compress a1 in + uu___4.FStarC_Syntax_Syntax.n in + match uu___3 with + | FStarC_Syntax_Syntax.Tm_name uu___4 -> + empty_env + | FStarC_Syntax_Syntax.Tm_constant uu___4 + -> empty_env + | FStarC_Syntax_Syntax.Tm_lazy uu___4 -> + empty_env + | FStarC_Syntax_Syntax.Tm_fvar uu___4 -> + empty_env + | uu___4 -> env1 in + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = fresh_memo () in + (env2, a1, uu___7, false) in + Clos uu___6 in + (uu___5, aq, + (t1.FStarC_Syntax_Syntax.pos)) in + Arg uu___4 in + uu___3 :: stack4) args stack2 in + (FStarC_TypeChecker_Cfg.log cfg + (fun uu___3 -> + let uu___4 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length args) in + FStarC_Compiler_Util.print1 + "\tPushed %s arguments\n" uu___4); + norm cfg env1 stack3 head) + | FStar_Pervasives_Native.Some strict_args1 -> + let norm_args = + FStarC_Compiler_List.map + (fun uu___2 -> + match uu___2 with + | (a, i) -> + let uu___3 = norm cfg env1 [] a in (uu___3, i)) + args in + let norm_args_len = FStarC_Compiler_List.length norm_args in + let uu___2 = + FStarC_Compiler_List.for_all + (fun i -> + if i >= norm_args_len + then false + else + (let uu___4 = + FStarC_Compiler_List.nth norm_args i in + match uu___4 with + | (arg_i, uu___5) -> + let uu___6 = + let uu___7 = + FStarC_Syntax_Util.unmeta_safe arg_i in + FStarC_Syntax_Util.head_and_args uu___7 in + (match uu___6 with + | (head1, uu___7) -> + let uu___8 = + let uu___9 = + FStarC_Syntax_Util.un_uinst head1 in + uu___9.FStarC_Syntax_Syntax.n in + (match uu___8 with + | FStarC_Syntax_Syntax.Tm_constant + uu___9 -> true + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let uu___9 = + FStarC_Syntax_Syntax.lid_of_fv + fv in + FStarC_TypeChecker_Env.is_datacon + cfg.FStarC_TypeChecker_Cfg.tcenv + uu___9 + | uu___9 -> false)))) strict_args1 in + if uu___2 + then + let stack3 = + FStarC_Compiler_List.fold_right + (fun uu___3 -> + fun stack4 -> + match uu___3 with + | (a, aq) -> + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Compiler_Util.mk_ref + (FStar_Pervasives_Native.Some + (cfg, ([], a))) in + (env1, a, uu___8, false) in + Clos uu___7 in + (uu___6, aq, + (t1.FStarC_Syntax_Syntax.pos)) in + Arg uu___5 in + uu___4 :: stack4) norm_args stack2 in + (FStarC_TypeChecker_Cfg.log cfg + (fun uu___4 -> + let uu___5 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length args) in + FStarC_Compiler_Util.print1 + "\tPushed %s arguments\n" uu___5); + norm cfg env1 stack3 head) + else + (let head1 = closure_as_term cfg env1 head in + let term = + FStarC_Syntax_Syntax.mk_Tm_app head1 norm_args + t1.FStarC_Syntax_Syntax.pos in + rebuild cfg env1 stack2 term)) + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x; + FStarC_Syntax_Syntax.phi = uu___2;_} + when + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.for_extraction + || + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unrefine + -> norm cfg env1 stack2 x.FStarC_Syntax_Syntax.sort + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x; FStarC_Syntax_Syntax.phi = f;_} + -> + if + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.weak + then + (match (env1, stack2) with + | ([], []) -> + let t_x = norm cfg env1 [] x.FStarC_Syntax_Syntax.sort in + let t2 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_refine + { + FStarC_Syntax_Syntax.b = + { + FStarC_Syntax_Syntax.ppname = + (x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (x.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = t_x + }; + FStarC_Syntax_Syntax.phi = f + }) t1.FStarC_Syntax_Syntax.pos in + rebuild cfg env1 stack2 t2 + | uu___2 -> + let uu___3 = closure_as_term cfg env1 t1 in + rebuild cfg env1 stack2 uu___3) + else + (let t_x = norm cfg env1 [] x.FStarC_Syntax_Syntax.sort in + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.mk_binder x in + [uu___5] in + FStarC_Syntax_Subst.open_term uu___4 f in + match uu___3 with + | (closing, f1) -> + let f2 = + let uu___4 = let uu___5 = dummy () in uu___5 :: env1 in + norm cfg uu___4 [] f1 in + let t2 = + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Syntax_Subst.close closing f2 in + { + FStarC_Syntax_Syntax.b = + { + FStarC_Syntax_Syntax.ppname = + (x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (x.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = t_x + }; + FStarC_Syntax_Syntax.phi = uu___6 + } in + FStarC_Syntax_Syntax.Tm_refine uu___5 in + FStarC_Syntax_Syntax.mk uu___4 + t1.FStarC_Syntax_Syntax.pos in + rebuild cfg env1 stack2 t2) + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = c;_} + -> + if + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.weak + then + let uu___2 = closure_as_term cfg env1 t1 in + rebuild cfg env1 stack2 uu___2 + else + (let uu___3 = FStarC_Syntax_Subst.open_comp bs c in + match uu___3 with + | (bs1, c1) -> + let c2 = + let uu___4 = + FStarC_Compiler_List.fold_left + (fun env2 -> + fun uu___5 -> + let uu___6 = dummy () in uu___6 :: env2) + env1 bs1 in + norm_comp cfg uu___4 c1 in + let close_binders env2 bs2 = + let uu___4 = env_subst env2 in + FStarC_Syntax_Subst.subst_binders uu___4 bs2 in + let bs2 = + if + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.hnf + then close_binders env1 bs1 + else norm_binders cfg env1 bs1 in + let t2 = FStarC_Syntax_Util.arrow bs2 c2 in + rebuild cfg env1 stack2 t2) + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t11; + FStarC_Syntax_Syntax.asc = uu___2; + FStarC_Syntax_Syntax.eff_opt = l;_} + when + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unascribe + -> norm cfg env1 stack2 t11 + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t11; + FStarC_Syntax_Syntax.asc = asc; + FStarC_Syntax_Syntax.eff_opt = l;_} + -> + let rec stack_may_reduce s = + match s with + | (Match uu___2)::uu___3 when + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.beta + -> true + | (Arg uu___2)::uu___3 when + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.beta + -> true + | (App + (uu___2, + { + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_reify uu___3); + FStarC_Syntax_Syntax.pos = uu___4; + FStarC_Syntax_Syntax.vars = uu___5; + FStarC_Syntax_Syntax.hash_code = uu___6;_}, + uu___7, uu___8))::uu___9 + when + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.beta + -> true + | (MemoLazy uu___2)::uu___3 when + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.beta + -> true + | uu___2 -> false in + let uu___2 = stack_may_reduce stack2 in + if uu___2 + then + (FStarC_TypeChecker_Cfg.log cfg + (fun uu___4 -> + FStarC_Compiler_Util.print_string + "+++ Dropping ascription \n"); + norm cfg env1 stack2 t11) + else + (FStarC_TypeChecker_Cfg.log cfg + (fun uu___5 -> + FStarC_Compiler_Util.print_string + "+++ Keeping ascription \n"); + (let t12 = norm cfg env1 [] t11 in + FStarC_TypeChecker_Cfg.log cfg + (fun uu___6 -> + FStarC_Compiler_Util.print_string + "+++ Normalizing ascription \n"); + (let asc1 = norm_ascription cfg env1 asc in + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = FStarC_Syntax_Util.unascribe t12 in + { + FStarC_Syntax_Syntax.tm = uu___9; + FStarC_Syntax_Syntax.asc = asc1; + FStarC_Syntax_Syntax.eff_opt = l + } in + FStarC_Syntax_Syntax.Tm_ascribed uu___8 in + FStarC_Syntax_Syntax.mk uu___7 + t1.FStarC_Syntax_Syntax.pos in + rebuild cfg env1 stack2 uu___6))) + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = head; + FStarC_Syntax_Syntax.ret_opt = asc_opt; + FStarC_Syntax_Syntax.brs = branches1; + FStarC_Syntax_Syntax.rc_opt1 = lopt;_} + -> + let lopt1 = + FStarC_Compiler_Util.map_option (maybe_drop_rc_typ cfg) lopt in + let stack3 = + (Match + (env1, asc_opt, branches1, lopt1, cfg, + (t1.FStarC_Syntax_Syntax.pos))) + :: stack2 in + if + ((cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.iota + && + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.weakly_reduce_scrutinee) + && + (Prims.op_Negation + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.weak) + then + let cfg' = + { + FStarC_TypeChecker_Cfg.steps = + (let uu___2 = cfg.FStarC_TypeChecker_Cfg.steps in + { + FStarC_TypeChecker_Cfg.beta = + (uu___2.FStarC_TypeChecker_Cfg.beta); + FStarC_TypeChecker_Cfg.iota = + (uu___2.FStarC_TypeChecker_Cfg.iota); + FStarC_TypeChecker_Cfg.zeta = + (uu___2.FStarC_TypeChecker_Cfg.zeta); + FStarC_TypeChecker_Cfg.zeta_full = + (uu___2.FStarC_TypeChecker_Cfg.zeta_full); + FStarC_TypeChecker_Cfg.weak = true; + FStarC_TypeChecker_Cfg.hnf = + (uu___2.FStarC_TypeChecker_Cfg.hnf); + FStarC_TypeChecker_Cfg.primops = + (uu___2.FStarC_TypeChecker_Cfg.primops); + FStarC_TypeChecker_Cfg.do_not_unfold_pure_lets = + (uu___2.FStarC_TypeChecker_Cfg.do_not_unfold_pure_lets); + FStarC_TypeChecker_Cfg.unfold_until = + (uu___2.FStarC_TypeChecker_Cfg.unfold_until); + FStarC_TypeChecker_Cfg.unfold_only = + (uu___2.FStarC_TypeChecker_Cfg.unfold_only); + FStarC_TypeChecker_Cfg.unfold_fully = + (uu___2.FStarC_TypeChecker_Cfg.unfold_fully); + FStarC_TypeChecker_Cfg.unfold_attr = + (uu___2.FStarC_TypeChecker_Cfg.unfold_attr); + FStarC_TypeChecker_Cfg.unfold_qual = + (uu___2.FStarC_TypeChecker_Cfg.unfold_qual); + FStarC_TypeChecker_Cfg.unfold_namespace = + (uu___2.FStarC_TypeChecker_Cfg.unfold_namespace); + FStarC_TypeChecker_Cfg.dont_unfold_attr = + (uu___2.FStarC_TypeChecker_Cfg.dont_unfold_attr); + FStarC_TypeChecker_Cfg.pure_subterms_within_computations + = + (uu___2.FStarC_TypeChecker_Cfg.pure_subterms_within_computations); + FStarC_TypeChecker_Cfg.simplify = + (uu___2.FStarC_TypeChecker_Cfg.simplify); + FStarC_TypeChecker_Cfg.erase_universes = + (uu___2.FStarC_TypeChecker_Cfg.erase_universes); + FStarC_TypeChecker_Cfg.allow_unbound_universes = + (uu___2.FStarC_TypeChecker_Cfg.allow_unbound_universes); + FStarC_TypeChecker_Cfg.reify_ = + (uu___2.FStarC_TypeChecker_Cfg.reify_); + FStarC_TypeChecker_Cfg.compress_uvars = + (uu___2.FStarC_TypeChecker_Cfg.compress_uvars); + FStarC_TypeChecker_Cfg.no_full_norm = + (uu___2.FStarC_TypeChecker_Cfg.no_full_norm); + FStarC_TypeChecker_Cfg.check_no_uvars = + (uu___2.FStarC_TypeChecker_Cfg.check_no_uvars); + FStarC_TypeChecker_Cfg.unmeta = + (uu___2.FStarC_TypeChecker_Cfg.unmeta); + FStarC_TypeChecker_Cfg.unascribe = + (uu___2.FStarC_TypeChecker_Cfg.unascribe); + FStarC_TypeChecker_Cfg.in_full_norm_request = + (uu___2.FStarC_TypeChecker_Cfg.in_full_norm_request); + FStarC_TypeChecker_Cfg.weakly_reduce_scrutinee = + (uu___2.FStarC_TypeChecker_Cfg.weakly_reduce_scrutinee); + FStarC_TypeChecker_Cfg.nbe_step = + (uu___2.FStarC_TypeChecker_Cfg.nbe_step); + FStarC_TypeChecker_Cfg.for_extraction = + (uu___2.FStarC_TypeChecker_Cfg.for_extraction); + FStarC_TypeChecker_Cfg.unrefine = + (uu___2.FStarC_TypeChecker_Cfg.unrefine); + FStarC_TypeChecker_Cfg.default_univs_to_zero = + (uu___2.FStarC_TypeChecker_Cfg.default_univs_to_zero); + FStarC_TypeChecker_Cfg.tactics = + (uu___2.FStarC_TypeChecker_Cfg.tactics) + }); + FStarC_TypeChecker_Cfg.tcenv = + (cfg.FStarC_TypeChecker_Cfg.tcenv); + FStarC_TypeChecker_Cfg.debug = + (cfg.FStarC_TypeChecker_Cfg.debug); + FStarC_TypeChecker_Cfg.delta_level = + (cfg.FStarC_TypeChecker_Cfg.delta_level); + FStarC_TypeChecker_Cfg.primitive_steps = + (cfg.FStarC_TypeChecker_Cfg.primitive_steps); + FStarC_TypeChecker_Cfg.strong = + (cfg.FStarC_TypeChecker_Cfg.strong); + FStarC_TypeChecker_Cfg.memoize_lazy = + (cfg.FStarC_TypeChecker_Cfg.memoize_lazy); + FStarC_TypeChecker_Cfg.normalize_pure_lets = + (cfg.FStarC_TypeChecker_Cfg.normalize_pure_lets); + FStarC_TypeChecker_Cfg.reifying = + (cfg.FStarC_TypeChecker_Cfg.reifying); + FStarC_TypeChecker_Cfg.compat_memo_ignore_cfg = + (cfg.FStarC_TypeChecker_Cfg.compat_memo_ignore_cfg) + } in + let head_norm = norm cfg' env1 [] head in + rebuild cfg env1 stack3 head_norm + else norm cfg env1 stack3 head + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (b, lbs); + FStarC_Syntax_Syntax.body1 = lbody;_} + when + (FStarC_Syntax_Syntax.is_top_level lbs) && + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.compress_uvars + -> + let lbs1 = + FStarC_Compiler_List.map + (fun lb -> + let uu___2 = + FStarC_Syntax_Subst.univ_var_opening + lb.FStarC_Syntax_Syntax.lbunivs in + match uu___2 with + | (openings, lbunivs) -> + let cfg1 = + let uu___3 = + FStarC_TypeChecker_Env.push_univ_vars + cfg.FStarC_TypeChecker_Cfg.tcenv lbunivs in + { + FStarC_TypeChecker_Cfg.steps = + (cfg.FStarC_TypeChecker_Cfg.steps); + FStarC_TypeChecker_Cfg.tcenv = uu___3; + FStarC_TypeChecker_Cfg.debug = + (cfg.FStarC_TypeChecker_Cfg.debug); + FStarC_TypeChecker_Cfg.delta_level = + (cfg.FStarC_TypeChecker_Cfg.delta_level); + FStarC_TypeChecker_Cfg.primitive_steps = + (cfg.FStarC_TypeChecker_Cfg.primitive_steps); + FStarC_TypeChecker_Cfg.strong = + (cfg.FStarC_TypeChecker_Cfg.strong); + FStarC_TypeChecker_Cfg.memoize_lazy = + (cfg.FStarC_TypeChecker_Cfg.memoize_lazy); + FStarC_TypeChecker_Cfg.normalize_pure_lets = + (cfg.FStarC_TypeChecker_Cfg.normalize_pure_lets); + FStarC_TypeChecker_Cfg.reifying = + (cfg.FStarC_TypeChecker_Cfg.reifying); + FStarC_TypeChecker_Cfg.compat_memo_ignore_cfg = + (cfg.FStarC_TypeChecker_Cfg.compat_memo_ignore_cfg) + } in + let norm1 t2 = + let uu___3 = + let uu___4 = + FStarC_Syntax_Subst.subst openings t2 in + norm cfg1 env1 [] uu___4 in + FStarC_Syntax_Subst.close_univ_vars lbunivs + uu___3 in + let lbtyp = norm1 lb.FStarC_Syntax_Syntax.lbtyp in + let lbdef = norm1 lb.FStarC_Syntax_Syntax.lbdef in + { + FStarC_Syntax_Syntax.lbname = + (lb.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs = lbunivs; + FStarC_Syntax_Syntax.lbtyp = lbtyp; + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = lbdef; + FStarC_Syntax_Syntax.lbattrs = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + }) lbs in + let uu___2 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = (b, lbs1); + FStarC_Syntax_Syntax.body1 = lbody + }) t1.FStarC_Syntax_Syntax.pos in + rebuild cfg env1 stack2 uu___2 + | FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = + (uu___2, + { + FStarC_Syntax_Syntax.lbname = FStar_Pervasives.Inr + uu___3; + FStarC_Syntax_Syntax.lbunivs = uu___4; + FStarC_Syntax_Syntax.lbtyp = uu___5; + FStarC_Syntax_Syntax.lbeff = uu___6; + FStarC_Syntax_Syntax.lbdef = uu___7; + FStarC_Syntax_Syntax.lbattrs = uu___8; + FStarC_Syntax_Syntax.lbpos = uu___9;_}::uu___10); + FStarC_Syntax_Syntax.body1 = uu___11;_} + -> rebuild cfg env1 stack2 t1 + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (false, lb::[]); + FStarC_Syntax_Syntax.body1 = body;_} + -> + let uu___2 = + FStarC_TypeChecker_Cfg.should_reduce_local_let cfg lb in + if uu___2 + then + let binder = + let uu___3 = + FStarC_Compiler_Util.left lb.FStarC_Syntax_Syntax.lbname in + FStarC_Syntax_Syntax.mk_binder uu___3 in + let def = + FStarC_Syntax_Util.unmeta_lift + lb.FStarC_Syntax_Syntax.lbdef in + let env2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = fresh_memo () in + (env1, def, uu___6, false) in + Clos uu___5 in + let uu___5 = fresh_memo () in + ((FStar_Pervasives_Native.Some binder), uu___4, uu___5) in + uu___3 :: env1 in + (FStarC_TypeChecker_Cfg.log cfg + (fun uu___4 -> + FStarC_Compiler_Util.print_string + "+++ Reducing Tm_let\n"); + norm cfg env2 stack2 body) + else + (let uu___4 = + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.tactics + && + (let uu___5 = + FStarC_TypeChecker_Env.norm_eff_name + cfg.FStarC_TypeChecker_Cfg.tcenv + lb.FStarC_Syntax_Syntax.lbeff in + FStarC_Syntax_Util.is_div_effect uu___5) in + if uu___4 + then + let ffun = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Compiler_Util.left + lb.FStarC_Syntax_Syntax.lbname in + FStarC_Syntax_Syntax.mk_binder uu___9 in + [uu___8] in + { + FStarC_Syntax_Syntax.bs = uu___7; + FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = + FStar_Pervasives_Native.None + } in + FStarC_Syntax_Syntax.Tm_abs uu___6 in + FStarC_Syntax_Syntax.mk uu___5 + t1.FStarC_Syntax_Syntax.pos in + let stack3 = + (CBVApp + (env1, ffun, FStar_Pervasives_Native.None, + (t1.FStarC_Syntax_Syntax.pos))) + :: stack2 in + (FStarC_TypeChecker_Cfg.log cfg + (fun uu___6 -> + FStarC_Compiler_Util.print_string + "+++ Evaluating DIV Tm_let\n"); + norm cfg env1 stack3 lb.FStarC_Syntax_Syntax.lbdef) + else + if + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.weak + then + (FStarC_TypeChecker_Cfg.log cfg + (fun uu___7 -> + FStarC_Compiler_Util.print_string + "+++ Not touching Tm_let\n"); + (let uu___7 = closure_as_term cfg env1 t1 in + rebuild cfg env1 stack2 uu___7)) + else + (let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Compiler_Util.left + lb.FStarC_Syntax_Syntax.lbname in + FStarC_Syntax_Syntax.mk_binder uu___10 in + [uu___9] in + FStarC_Syntax_Subst.open_term uu___8 body in + match uu___7 with + | (bs, body1) -> + (FStarC_TypeChecker_Cfg.log cfg + (fun uu___9 -> + FStarC_Compiler_Util.print_string + "+++ Normalizing Tm_let -- type"); + (let ty = + norm cfg env1 [] lb.FStarC_Syntax_Syntax.lbtyp in + let lbname = + let x = + let uu___9 = FStarC_Compiler_List.hd bs in + uu___9.FStarC_Syntax_Syntax.binder_bv in + FStar_Pervasives.Inl + { + FStarC_Syntax_Syntax.ppname = + (x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (x.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = ty + } in + FStarC_TypeChecker_Cfg.log cfg + (fun uu___10 -> + FStarC_Compiler_Util.print_string + "+++ Normalizing Tm_let -- definiens\n"); + (let lb1 = + let uu___10 = + norm cfg env1 [] + lb.FStarC_Syntax_Syntax.lbdef in + let uu___11 = + FStarC_Compiler_List.map (norm cfg env1 []) + lb.FStarC_Syntax_Syntax.lbattrs in + { + FStarC_Syntax_Syntax.lbname = lbname; + FStarC_Syntax_Syntax.lbunivs = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = ty; + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = uu___10; + FStarC_Syntax_Syntax.lbattrs = uu___11; + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + } in + let env' = + FStarC_Compiler_List.fold_left + (fun env2 -> + fun uu___10 -> + let uu___11 = dummy () in uu___11 :: + env2) env1 bs in + FStarC_TypeChecker_Cfg.log cfg + (fun uu___11 -> + FStarC_Compiler_Util.print_string + "+++ Normalizing Tm_let -- body\n"); + (let cfg' = + { + FStarC_TypeChecker_Cfg.steps = + (cfg.FStarC_TypeChecker_Cfg.steps); + FStarC_TypeChecker_Cfg.tcenv = + (cfg.FStarC_TypeChecker_Cfg.tcenv); + FStarC_TypeChecker_Cfg.debug = + (cfg.FStarC_TypeChecker_Cfg.debug); + FStarC_TypeChecker_Cfg.delta_level = + (cfg.FStarC_TypeChecker_Cfg.delta_level); + FStarC_TypeChecker_Cfg.primitive_steps = + (cfg.FStarC_TypeChecker_Cfg.primitive_steps); + FStarC_TypeChecker_Cfg.strong = true; + FStarC_TypeChecker_Cfg.memoize_lazy = + (cfg.FStarC_TypeChecker_Cfg.memoize_lazy); + FStarC_TypeChecker_Cfg.normalize_pure_lets + = + (cfg.FStarC_TypeChecker_Cfg.normalize_pure_lets); + FStarC_TypeChecker_Cfg.reifying = + (cfg.FStarC_TypeChecker_Cfg.reifying); + FStarC_TypeChecker_Cfg.compat_memo_ignore_cfg + = + (cfg.FStarC_TypeChecker_Cfg.compat_memo_ignore_cfg) + } in + let body_norm = + norm cfg' env' + [Let + (env1, bs, lb1, + (t1.FStarC_Syntax_Syntax.pos))] body1 in + rebuild cfg env1 stack2 body_norm)))))) + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (true, lbs); + FStarC_Syntax_Syntax.body1 = body;_} + when + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.compress_uvars + || + (((Prims.op_Negation + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.zeta) + && + (Prims.op_Negation + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.zeta_full)) + && + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.pure_subterms_within_computations) + -> + let uu___2 = FStarC_Syntax_Subst.open_let_rec lbs body in + (match uu___2 with + | (lbs1, body1) -> + let lbs2 = + FStarC_Compiler_List.map + (fun lb -> + let ty = + norm cfg env1 [] lb.FStarC_Syntax_Syntax.lbtyp in + let lbname = + let uu___3 = + let uu___4 = + FStarC_Compiler_Util.left + lb.FStarC_Syntax_Syntax.lbname in + { + FStarC_Syntax_Syntax.ppname = + (uu___4.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (uu___4.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = ty + } in + FStar_Pervasives.Inl uu___3 in + let uu___3 = + FStarC_Syntax_Util.abs_formals + lb.FStarC_Syntax_Syntax.lbdef in + match uu___3 with + | (xs, def_body, lopt) -> + let xs1 = norm_binders cfg env1 xs in + let env2 = + let uu___4 = + FStarC_Compiler_List.map + (fun uu___5 -> dummy ()) xs1 in + let uu___5 = + let uu___6 = + FStarC_Compiler_List.map + (fun uu___7 -> dummy ()) lbs1 in + FStarC_Compiler_List.op_At uu___6 env1 in + FStarC_Compiler_List.op_At uu___4 uu___5 in + let def_body1 = norm cfg env2 [] def_body in + let lopt1 = + match lopt with + | FStar_Pervasives_Native.Some rc -> + let uu___4 = + let uu___5 = + FStarC_Compiler_Util.map_opt + rc.FStarC_Syntax_Syntax.residual_typ + (norm cfg env2 []) in + { + FStarC_Syntax_Syntax.residual_effect + = + (rc.FStarC_Syntax_Syntax.residual_effect); + FStarC_Syntax_Syntax.residual_typ = + uu___5; + FStarC_Syntax_Syntax.residual_flags + = + (rc.FStarC_Syntax_Syntax.residual_flags) + } in + FStar_Pervasives_Native.Some uu___4 + | uu___4 -> lopt in + let def = + FStarC_Syntax_Util.abs xs1 def_body1 lopt1 in + { + FStarC_Syntax_Syntax.lbname = lbname; + FStarC_Syntax_Syntax.lbunivs = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = ty; + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = def; + FStarC_Syntax_Syntax.lbattrs = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + }) lbs1 in + let env' = + let uu___3 = + FStarC_Compiler_List.map (fun uu___4 -> dummy ()) + lbs2 in + FStarC_Compiler_List.op_At uu___3 env1 in + let body2 = norm cfg env' [] body1 in + let uu___3 = FStarC_Syntax_Subst.close_let_rec lbs2 body2 in + (match uu___3 with + | (lbs3, body3) -> + let t2 = + { + FStarC_Syntax_Syntax.n = + (FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = (true, lbs3); + FStarC_Syntax_Syntax.body1 = body3 + }); + FStarC_Syntax_Syntax.pos = + (t1.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = + (t1.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (t1.FStarC_Syntax_Syntax.hash_code) + } in + rebuild cfg env1 stack2 t2)) + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = lbs; + FStarC_Syntax_Syntax.body1 = body;_} + when + (Prims.op_Negation + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.zeta) + && + (Prims.op_Negation + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.zeta_full) + -> + let uu___2 = closure_as_term cfg env1 t1 in + rebuild cfg env1 stack2 uu___2 + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = lbs; + FStarC_Syntax_Syntax.body1 = body;_} + -> + let uu___2 = + FStarC_Compiler_List.fold_right + (fun lb -> + fun uu___3 -> + match uu___3 with + | (rec_env, memos, i) -> + let bv = + let uu___4 = + FStarC_Compiler_Util.left + lb.FStarC_Syntax_Syntax.lbname in + { + FStarC_Syntax_Syntax.ppname = + (uu___4.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = i; + FStarC_Syntax_Syntax.sort = + (uu___4.FStarC_Syntax_Syntax.sort) + } in + let f_i = FStarC_Syntax_Syntax.bv_to_tm bv in + let fix_f_i = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = lbs; + FStarC_Syntax_Syntax.body1 = f_i + }) t1.FStarC_Syntax_Syntax.pos in + let memo = fresh_memo () in + let rec_env1 = + let uu___4 = + let uu___5 = fresh_memo () in + (FStar_Pervasives_Native.None, + (Clos (env1, fix_f_i, memo, true)), uu___5) in + uu___4 :: rec_env in + (rec_env1, (memo :: memos), (i + Prims.int_one))) + (FStar_Pervasives_Native.snd lbs) + (env1, [], Prims.int_zero) in + (match uu___2 with + | (rec_env, memos, uu___3) -> + let uu___4 = + FStarC_Compiler_List.map2 + (fun lb -> + fun memo -> + FStarC_Compiler_Effect.op_Colon_Equals memo + (FStar_Pervasives_Native.Some + (cfg, + (rec_env, + (lb.FStarC_Syntax_Syntax.lbdef))))) + (FStar_Pervasives_Native.snd lbs) memos in + let body_env = + FStarC_Compiler_List.fold_left + (fun env2 -> + fun lb -> + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = fresh_memo () in + (rec_env, (lb.FStarC_Syntax_Syntax.lbdef), + uu___8, false) in + Clos uu___7 in + let uu___7 = fresh_memo () in + (FStar_Pervasives_Native.None, uu___6, uu___7) in + uu___5 :: env2) env1 + (FStar_Pervasives_Native.snd lbs) in + (FStarC_TypeChecker_Cfg.log cfg + (fun uu___6 -> + FStarC_Compiler_Util.print1 + "reducing with knot %s\n" ""); + norm cfg body_env stack2 body)) + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = head; + FStarC_Syntax_Syntax.meta = m;_} + -> + (FStarC_TypeChecker_Cfg.log cfg + (fun uu___3 -> + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_metadata m in + FStarC_Compiler_Util.print1 ">> metadata = %s\n" uu___4); + (match m with + | FStarC_Syntax_Syntax.Meta_monadic (m_from, ty) -> + if + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.for_extraction + then + let uu___3 = + (FStarC_TypeChecker_Env.is_erasable_effect + cfg.FStarC_TypeChecker_Cfg.tcenv m_from) + || + ((FStarC_Syntax_Util.is_pure_effect m_from) && + (FStarC_TypeChecker_Env.non_informative + cfg.FStarC_TypeChecker_Cfg.tcenv ty)) in + (if uu___3 + then + let uu___4 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 = + FStarC_Syntax_Util.exp_unit; + FStarC_Syntax_Syntax.meta = m + }) t1.FStarC_Syntax_Syntax.pos in + rebuild cfg env1 stack2 uu___4 + else + reduce_impure_comp cfg env1 stack2 head + (FStar_Pervasives.Inl m_from) ty) + else + reduce_impure_comp cfg env1 stack2 head + (FStar_Pervasives.Inl m_from) ty + | FStarC_Syntax_Syntax.Meta_monadic_lift (m_from, m_to, ty) + -> + if + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.for_extraction + then + let uu___3 = + ((FStarC_TypeChecker_Env.is_erasable_effect + cfg.FStarC_TypeChecker_Cfg.tcenv m_from) + || + (FStarC_TypeChecker_Env.is_erasable_effect + cfg.FStarC_TypeChecker_Cfg.tcenv m_to)) + || + ((FStarC_Syntax_Util.is_pure_effect m_from) && + (FStarC_TypeChecker_Env.non_informative + cfg.FStarC_TypeChecker_Cfg.tcenv ty)) in + (if uu___3 + then + let uu___4 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 = + FStarC_Syntax_Util.exp_unit; + FStarC_Syntax_Syntax.meta = m + }) t1.FStarC_Syntax_Syntax.pos in + rebuild cfg env1 stack2 uu___4 + else + reduce_impure_comp cfg env1 stack2 head + (FStar_Pervasives.Inr (m_from, m_to)) ty) + else + reduce_impure_comp cfg env1 stack2 head + (FStar_Pervasives.Inr (m_from, m_to)) ty + | uu___3 -> + if + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unmeta + then norm cfg env1 stack2 head + else + (match stack2 with + | uu___5::uu___6 -> + (match m with + | FStarC_Syntax_Syntax.Meta_labeled + (l, r, uu___7) -> + norm cfg env1 ((Meta (env1, m, r)) :: + stack2) head + | FStarC_Syntax_Syntax.Meta_pattern + (names, args) -> + let args1 = norm_pattern_args cfg env1 args in + let names1 = + FStarC_Compiler_List.map + (norm cfg env1 []) names in + norm cfg env1 + ((Meta + (env1, + (FStarC_Syntax_Syntax.Meta_pattern + (names1, args1)), + (t1.FStarC_Syntax_Syntax.pos))) :: + stack2) head + | FStarC_Syntax_Syntax.Meta_desugared + (FStarC_Syntax_Syntax.Sequence) when + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.do_not_unfold_pure_lets + -> + norm cfg env1 + ((Meta + (env1, m, + (t1.FStarC_Syntax_Syntax.pos))) :: + stack2) head + | FStarC_Syntax_Syntax.Meta_desugared + (FStarC_Syntax_Syntax.Machine_integer + (uu___7, uu___8)) -> + norm cfg env1 + ((Meta + (env1, m, + (t1.FStarC_Syntax_Syntax.pos))) :: + stack2) head + | uu___7 -> norm cfg env1 stack2 head) + | [] -> + let head1 = norm cfg env1 [] head in + let m1 = + match m with + | FStarC_Syntax_Syntax.Meta_pattern + (names, args) -> + let names1 = + FStarC_Compiler_List.map + (norm cfg env1 []) names in + let uu___5 = + let uu___6 = + norm_pattern_args cfg env1 args in + (names1, uu___6) in + FStarC_Syntax_Syntax.Meta_pattern uu___5 + | uu___5 -> m in + let t2 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 = head1; + FStarC_Syntax_Syntax.meta = m1 + }) t1.FStarC_Syntax_Syntax.pos in + rebuild cfg env1 stack2 t2))) + | FStarC_Syntax_Syntax.Tm_delayed uu___2 -> + failwith "impossible: Tm_delayed on norm" + | FStarC_Syntax_Syntax.Tm_uvar uu___2 -> + (if + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.check_no_uvars + then + (let uu___4 = + let uu___5 = + FStarC_Class_Show.show + FStarC_Compiler_Range_Ops.showable_range + t1.FStarC_Syntax_Syntax.pos in + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t1 in + FStarC_Compiler_Util.format2 + "(%s) CheckNoUvars: Unexpected unification variable remains: %s" + uu___5 uu___6 in + failwith uu___4) + else (); + (let t2 = + FStarC_Errors.with_ctx "inlining" + (fun uu___4 -> closure_as_term cfg env1 t1) in + rebuild cfg env1 stack2 t2))) +and (do_unfold_fv : + FStarC_TypeChecker_Cfg.cfg -> + stack_elt Prims.list -> + FStarC_Syntax_Syntax.term -> + FStarC_TypeChecker_Env.qninfo -> + FStarC_Syntax_Syntax.fv -> FStarC_Syntax_Syntax.term) + = + fun cfg -> + fun stack1 -> + fun t0 -> + fun qninfo -> + fun f -> + let defn uu___ = + FStarC_TypeChecker_Env.lookup_definition_qninfo + cfg.FStarC_TypeChecker_Cfg.delta_level + (f.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + qninfo in + let defn1 uu___ = + if + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.for_extraction + then + match qninfo with + | FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr (se, FStar_Pervasives_Native.None), + uu___1) + when + FStarC_TypeChecker_Env.visible_with + cfg.FStarC_TypeChecker_Cfg.delta_level + se.FStarC_Syntax_Syntax.sigquals + -> + let uu___2 = + FStarC_Compiler_Util.find_map + se.FStarC_Syntax_Syntax.sigattrs is_extract_as_attr in + (match uu___2 with + | FStar_Pervasives_Native.Some impl -> + FStar_Pervasives_Native.Some ([], impl) + | FStar_Pervasives_Native.None -> defn ()) + | uu___1 -> defn () + else defn () in + let uu___ = defn1 () in + match uu___ with + | FStar_Pervasives_Native.None -> + (FStarC_TypeChecker_Cfg.log_unfolding cfg + (fun uu___2 -> + let uu___3 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_fv f in + let uu___4 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_TypeChecker_Env.showable_delta_level) + cfg.FStarC_TypeChecker_Cfg.delta_level in + FStarC_Compiler_Util.print2 + " >> No definition found for %s (delta_level = %s)\n" + uu___3 uu___4); + rebuild cfg empty_env stack1 t0) + | FStar_Pervasives_Native.Some (us, t) -> + (FStarC_TypeChecker_Cfg.log_unfolding cfg + (fun uu___2 -> + let uu___3 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t0 in + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.print2 " >> Unfolded %s to %s\n" + uu___3 uu___4); + (let t1 = + if + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unfold_until + = + (FStar_Pervasives_Native.Some + FStarC_Syntax_Syntax.delta_constant) + then t + else + FStarC_Syntax_Subst.set_use_range + t0.FStarC_Syntax_Syntax.pos t in + let n = FStarC_Compiler_List.length us in + if n > Prims.int_zero + then + match stack1 with + | (UnivArgs (us', uu___2))::stack2 -> + ((let uu___4 = + FStarC_Compiler_Effect.op_Bang dbg_univ_norm in + if uu___4 + then + FStarC_Compiler_List.iter + (fun x -> + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_univ x in + FStarC_Compiler_Util.print1 + "Univ (normalizer) %s\n" uu___5) us' + else ()); + (let env1 = + FStarC_Compiler_List.fold_left + (fun env2 -> + fun u -> + let uu___4 = + let uu___5 = fresh_memo () in + (FStar_Pervasives_Native.None, ( + Univ u), uu___5) in + uu___4 :: env2) empty_env us' in + norm cfg env1 stack2 t1)) + | uu___2 when + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.erase_universes + || + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.allow_unbound_universes + -> norm cfg empty_env stack1 t1 + | uu___2 -> + let uu___3 = + let uu___4 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + (f.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + FStarC_Compiler_Util.format1 + "Impossible: missing universe instantiation on %s" + uu___4 in + failwith uu___3 + else norm cfg empty_env stack1 t1)) +and (reduce_impure_comp : + FStarC_TypeChecker_Cfg.cfg -> + env -> + stack_elt Prims.list -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.monad_name, + (FStarC_Syntax_Syntax.monad_name * + FStarC_Syntax_Syntax.monad_name)) + FStar_Pervasives.either -> + FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.term) + = + fun cfg -> + fun env1 -> + fun stack1 -> + fun head -> + fun m -> + fun t -> + let t1 = norm cfg env1 [] t in + let metadata = + match m with + | FStar_Pervasives.Inl m1 -> + FStarC_Syntax_Syntax.Meta_monadic (m1, t1) + | FStar_Pervasives.Inr (m1, m') -> + FStarC_Syntax_Syntax.Meta_monadic_lift (m1, m', t1) in + norm cfg env1 + ((Meta (env1, metadata, (head.FStarC_Syntax_Syntax.pos))) :: + stack1) head +and (do_reify_monadic : + (unit -> FStarC_Syntax_Syntax.term) -> + FStarC_TypeChecker_Cfg.cfg -> + env -> + stack_elt Prims.list -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.monad_name -> + FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.term) + = + fun fallback -> + fun cfg -> + fun env1 -> + fun stack1 -> + fun top -> + fun m -> + fun t -> + (match stack1 with + | (App + (uu___1, + { + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_reify uu___2); + FStarC_Syntax_Syntax.pos = uu___3; + FStarC_Syntax_Syntax.vars = uu___4; + FStarC_Syntax_Syntax.hash_code = uu___5;_}, + uu___6, uu___7))::uu___8 + -> () + | uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list showable_stack_elt) + stack1 in + FStarC_Compiler_Util.format1 + "INTERNAL ERROR: do_reify_monadic: bad stack: %s" + uu___3 in + failwith uu___2); + (let top0 = top in + let top1 = FStarC_Syntax_Util.unascribe top in + FStarC_TypeChecker_Cfg.log cfg + (fun uu___2 -> + let uu___3 = + FStarC_Class_Tagged.tag_of + FStarC_Syntax_Syntax.tagged_term top1 in + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term top1 in + FStarC_Compiler_Util.print2 "Reifying: (%s) %s\n" + uu___3 uu___4); + (let top2 = FStarC_Syntax_Util.unmeta_safe top1 in + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress top2 in + uu___3.FStarC_Syntax_Syntax.n in + match uu___2 with + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (false, lb::[]); + FStarC_Syntax_Syntax.body1 = body;_} + -> + let eff_name = + FStarC_TypeChecker_Env.norm_eff_name + cfg.FStarC_TypeChecker_Cfg.tcenv m in + let ed = + FStarC_TypeChecker_Env.get_effect_decl + cfg.FStarC_TypeChecker_Cfg.tcenv eff_name in + let uu___3 = + let uu___4 = FStarC_Syntax_Util.get_eff_repr ed in + FStarC_Compiler_Util.must uu___4 in + (match uu___3 with + | (uu___4, repr) -> + let uu___5 = + let uu___6 = FStarC_Syntax_Util.get_bind_repr ed in + FStarC_Compiler_Util.must uu___6 in + (match uu___5 with + | (uu___6, bind_repr) -> + (match lb.FStarC_Syntax_Syntax.lbname with + | FStar_Pervasives.Inr uu___7 -> + failwith + "Cannot reify a top-level let binding" + | FStar_Pervasives.Inl x -> + let is_return e = + let uu___7 = + let uu___8 = + FStarC_Syntax_Subst.compress e in + uu___8.FStarC_Syntax_Syntax.n in + match uu___7 with + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = e1; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_monadic + (uu___8, uu___9);_} + -> + let uu___10 = + let uu___11 = + FStarC_Syntax_Subst.compress + e1 in + uu___11.FStarC_Syntax_Syntax.n in + (match uu___10 with + | FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 = + e2; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_monadic_lift + (uu___11, msrc, uu___12);_} + when + FStarC_Syntax_Util.is_pure_effect + msrc + -> + let uu___13 = + FStarC_Syntax_Subst.compress + e2 in + FStar_Pervasives_Native.Some + uu___13 + | uu___11 -> + FStar_Pervasives_Native.None) + | uu___8 -> + FStar_Pervasives_Native.None in + let uu___7 = + is_return + lb.FStarC_Syntax_Syntax.lbdef in + (match uu___7 with + | FStar_Pervasives_Native.Some e -> + let lb1 = + { + FStarC_Syntax_Syntax.lbname = + (lb.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = + (lb.FStarC_Syntax_Syntax.lbtyp); + FStarC_Syntax_Syntax.lbeff = + FStarC_Parser_Const.effect_PURE_lid; + FStarC_Syntax_Syntax.lbdef = e; + FStarC_Syntax_Syntax.lbattrs = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + } in + let uu___8 = + FStarC_Compiler_List.tl stack1 in + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Syntax_Util.mk_reify + body + (FStar_Pervasives_Native.Some + m) in + { + FStarC_Syntax_Syntax.lbs = + (false, [lb1]); + FStarC_Syntax_Syntax.body1 + = uu___12 + } in + FStarC_Syntax_Syntax.Tm_let + uu___11 in + FStarC_Syntax_Syntax.mk uu___10 + top2.FStarC_Syntax_Syntax.pos in + norm cfg env1 uu___8 uu___9 + | FStar_Pervasives_Native.None -> + let uu___8 = + let uu___9 = is_return body in + match uu___9 with + | FStar_Pervasives_Native.Some + { + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Tm_bvar + y; + FStarC_Syntax_Syntax.pos = + uu___10; + FStarC_Syntax_Syntax.vars = + uu___11; + FStarC_Syntax_Syntax.hash_code + = uu___12;_} + -> + FStarC_Syntax_Syntax.bv_eq x + y + | uu___10 -> false in + if uu___8 + then + norm cfg env1 stack1 + lb.FStarC_Syntax_Syntax.lbdef + else + (let rng = + top2.FStarC_Syntax_Syntax.pos in + let head = + FStarC_Syntax_Util.mk_reify + lb.FStarC_Syntax_Syntax.lbdef + (FStar_Pervasives_Native.Some + m) in + let body1 = + FStarC_Syntax_Util.mk_reify + body + (FStar_Pervasives_Native.Some + m) in + let body_rc = + { + FStarC_Syntax_Syntax.residual_effect + = m; + FStarC_Syntax_Syntax.residual_typ + = + (FStar_Pervasives_Native.Some + t); + FStarC_Syntax_Syntax.residual_flags + = [] + } in + let body2 = + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Syntax_Syntax.mk_binder + x in + [uu___13] in + { + FStarC_Syntax_Syntax.bs + = uu___12; + FStarC_Syntax_Syntax.body + = body1; + FStarC_Syntax_Syntax.rc_opt + = + (FStar_Pervasives_Native.Some + body_rc) + } in + FStarC_Syntax_Syntax.Tm_abs + uu___11 in + FStarC_Syntax_Syntax.mk + uu___10 + body1.FStarC_Syntax_Syntax.pos in + let close = + closure_as_term cfg env1 in + let bind_inst = + let uu___10 = + let uu___11 = + FStarC_Syntax_Subst.compress + bind_repr in + uu___11.FStarC_Syntax_Syntax.n in + match uu___10 with + | FStarC_Syntax_Syntax.Tm_uinst + (bind, + uu___11::uu___12::[]) + -> + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = + let uu___17 = + close + lb.FStarC_Syntax_Syntax.lbtyp in + (cfg.FStarC_TypeChecker_Cfg.tcenv).FStarC_TypeChecker_Env.universe_of + cfg.FStarC_TypeChecker_Cfg.tcenv + uu___17 in + let uu___17 = + let uu___18 = + let uu___19 = + close t in + (cfg.FStarC_TypeChecker_Cfg.tcenv).FStarC_TypeChecker_Env.universe_of + cfg.FStarC_TypeChecker_Cfg.tcenv + uu___19 in + [uu___18] in + uu___16 :: uu___17 in + (bind, uu___15) in + FStarC_Syntax_Syntax.Tm_uinst + uu___14 in + FStarC_Syntax_Syntax.mk + uu___13 rng + | uu___11 -> + failwith + "NIY : Reification of indexed effects" in + let bind_inst_args f_arg = + let uu___10 = + FStarC_Syntax_Util.is_layered + ed in + if uu___10 + then + let bind_has_range_args = + FStarC_Syntax_Util.has_attribute + ed.FStarC_Syntax_Syntax.eff_attrs + FStarC_Parser_Const.bind_has_range_args_attr in + let num_fixed_binders = + if bind_has_range_args + then (Prims.of_int (4)) + else (Prims.of_int (2)) in + let unit_args = + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + FStarC_Syntax_Util.get_bind_vc_combinator + ed in + FStar_Pervasives_Native.fst + uu___15 in + FStar_Pervasives_Native.snd + uu___14 in + FStarC_Syntax_Subst.compress + uu___13 in + uu___12.FStarC_Syntax_Syntax.n in + match uu___11 with + | FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 + = + uu___12::uu___13::bs; + FStarC_Syntax_Syntax.comp + = uu___14;_} + when + (FStarC_Compiler_List.length + bs) + >= num_fixed_binders + -> + let uu___15 = + let uu___16 = + FStarC_Compiler_List.splitAt + ((FStarC_Compiler_List.length + bs) + - + num_fixed_binders) + bs in + FStar_Pervasives_Native.fst + uu___16 in + FStarC_Compiler_List.map + (fun uu___16 -> + FStarC_Syntax_Syntax.as_arg + FStarC_Syntax_Syntax.unit_const) + uu___15 + | uu___12 -> + let uu___13 = + let uu___14 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + ed.FStarC_Syntax_Syntax.mname in + let uu___15 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + num_fixed_binders in + let uu___16 = + let uu___17 = + let uu___18 = + let uu___19 = + FStarC_Syntax_Util.get_bind_vc_combinator + ed in + FStar_Pervasives_Native.fst + uu___19 in + FStar_Pervasives_Native.snd + uu___18 in + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + uu___17 in + FStarC_Compiler_Util.format3 + "bind_wp for layered effect %s is not an arrow with >= %s arguments (%s)" + uu___14 uu___15 + uu___16 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + rng + FStarC_Errors_Codes.Fatal_UnexpectedEffect + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___13) in + let range_args = + if bind_has_range_args + then + let uu___11 = + let uu___12 = + FStarC_TypeChecker_Primops_Base.embed_simple + FStarC_Syntax_Embeddings.e_range + lb.FStarC_Syntax_Syntax.lbpos + lb.FStarC_Syntax_Syntax.lbpos in + FStarC_Syntax_Syntax.as_arg + uu___12 in + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_TypeChecker_Primops_Base.embed_simple + FStarC_Syntax_Embeddings.e_range + body2.FStarC_Syntax_Syntax.pos + body2.FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.as_arg + uu___14 in + [uu___13] in + uu___11 :: uu___12 + else [] in + let uu___11 = + FStarC_Syntax_Syntax.as_arg + lb.FStarC_Syntax_Syntax.lbtyp in + let uu___12 = + let uu___13 = + FStarC_Syntax_Syntax.as_arg + t in + let uu___14 = + let uu___15 = + let uu___16 = + let uu___17 = + FStarC_Syntax_Syntax.as_arg + f_arg in + let uu___18 = + let uu___19 = + FStarC_Syntax_Syntax.as_arg + body2 in + [uu___19] in + uu___17 :: uu___18 in + FStarC_Compiler_List.op_At + range_args uu___16 in + FStarC_Compiler_List.op_At + unit_args uu___15 in + uu___13 :: uu___14 in + uu___11 :: uu___12 + else + (let maybe_range_arg = + let uu___12 = + FStarC_Compiler_Util.for_some + (FStarC_TypeChecker_TermEqAndSimplify.eq_tm_bool + cfg.FStarC_TypeChecker_Cfg.tcenv + FStarC_Syntax_Util.dm4f_bind_range_attr) + ed.FStarC_Syntax_Syntax.eff_attrs in + if uu___12 + then + let uu___13 = + let uu___14 = + FStarC_TypeChecker_Primops_Base.embed_simple + FStarC_Syntax_Embeddings.e_range + lb.FStarC_Syntax_Syntax.lbpos + lb.FStarC_Syntax_Syntax.lbpos in + FStarC_Syntax_Syntax.as_arg + uu___14 in + let uu___14 = + let uu___15 = + let uu___16 = + FStarC_TypeChecker_Primops_Base.embed_simple + FStarC_Syntax_Embeddings.e_range + body2.FStarC_Syntax_Syntax.pos + body2.FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.as_arg + uu___16 in + [uu___15] in + uu___13 :: uu___14 + else [] in + let uu___12 = + let uu___13 = + FStarC_Syntax_Syntax.as_arg + lb.FStarC_Syntax_Syntax.lbtyp in + let uu___14 = + let uu___15 = + FStarC_Syntax_Syntax.as_arg + t in + [uu___15] in + uu___13 :: uu___14 in + let uu___13 = + let uu___14 = + let uu___15 = + FStarC_Syntax_Syntax.as_arg + FStarC_Syntax_Syntax.tun in + let uu___16 = + let uu___17 = + FStarC_Syntax_Syntax.as_arg + f_arg in + let uu___18 = + let uu___19 = + FStarC_Syntax_Syntax.as_arg + FStarC_Syntax_Syntax.tun in + let uu___20 = + let uu___21 = + FStarC_Syntax_Syntax.as_arg + body2 in + [uu___21] in + uu___19 :: uu___20 in + uu___17 :: uu___18 in + uu___15 :: uu___16 in + FStarC_Compiler_List.op_At + maybe_range_arg uu___14 in + FStarC_Compiler_List.op_At + uu___12 uu___13) in + let reified = + let is_total_effect = + FStarC_TypeChecker_Env.is_total_effect + cfg.FStarC_TypeChecker_Cfg.tcenv + eff_name in + if is_total_effect + then + let uu___10 = + let uu___11 = + let uu___12 = + bind_inst_args head in + { + FStarC_Syntax_Syntax.hd + = bind_inst; + FStarC_Syntax_Syntax.args + = uu___12 + } in + FStarC_Syntax_Syntax.Tm_app + uu___11 in + FStarC_Syntax_Syntax.mk + uu___10 rng + else + (let uu___11 = + let bv = + FStarC_Syntax_Syntax.new_bv + FStar_Pervasives_Native.None + x.FStarC_Syntax_Syntax.sort in + let lb1 = + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_Syntax_Syntax.as_arg + x.FStarC_Syntax_Syntax.sort in + [uu___14] in + FStarC_Syntax_Util.mk_app + repr uu___13 in + { + FStarC_Syntax_Syntax.lbname + = + (FStar_Pervasives.Inl + bv); + FStarC_Syntax_Syntax.lbunivs + = []; + FStarC_Syntax_Syntax.lbtyp + = uu___12; + FStarC_Syntax_Syntax.lbeff + = + (if is_total_effect + then + FStarC_Parser_Const.effect_Tot_lid + else + FStarC_Parser_Const.effect_Dv_lid); + FStarC_Syntax_Syntax.lbdef + = head; + FStarC_Syntax_Syntax.lbattrs + = []; + FStarC_Syntax_Syntax.lbpos + = + (head.FStarC_Syntax_Syntax.pos) + } in + let uu___12 = + FStarC_Syntax_Syntax.bv_to_name + bv in + (lb1, bv, uu___12) in + match uu___11 with + | (lb_head, head_bv, head1) + -> + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = + FStarC_Syntax_Syntax.mk_binder + head_bv in + [uu___16] in + let uu___16 = + let uu___17 = + let uu___18 = + let uu___19 + = + bind_inst_args + head1 in + { + FStarC_Syntax_Syntax.hd + = + bind_inst; + FStarC_Syntax_Syntax.args + = uu___19 + } in + FStarC_Syntax_Syntax.Tm_app + uu___18 in + FStarC_Syntax_Syntax.mk + uu___17 rng in + FStarC_Syntax_Subst.close + uu___15 uu___16 in + { + FStarC_Syntax_Syntax.lbs + = + (false, + [lb_head]); + FStarC_Syntax_Syntax.body1 + = uu___14 + } in + FStarC_Syntax_Syntax.Tm_let + uu___13 in + FStarC_Syntax_Syntax.mk + uu___12 rng) in + FStarC_TypeChecker_Cfg.log cfg + (fun uu___11 -> + let uu___12 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + top0 in + let uu___13 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + reified in + FStarC_Compiler_Util.print2 + "Reified (1) <%s> to %s\n" + uu___12 uu___13); + (let uu___11 = + FStarC_Compiler_List.tl + stack1 in + norm cfg env1 uu___11 reified)))))) + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = args;_} + -> + ((let uu___4 = FStarC_Options.defensive () in + if uu___4 + then + let is_arg_impure uu___5 = + match uu___5 with + | (e, q) -> + let uu___6 = + let uu___7 = FStarC_Syntax_Subst.compress e in + uu___7.FStarC_Syntax_Syntax.n in + (match uu___6 with + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = e0; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_monadic_lift + (m1, m2, t');_} + -> + let uu___7 = + FStarC_Syntax_Util.is_pure_effect m1 in + Prims.op_Negation uu___7 + | uu___7 -> false) in + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Syntax_Syntax.as_arg head in + uu___7 :: args in + FStarC_Compiler_Util.for_some is_arg_impure + uu___6 in + (if uu___5 + then + let uu___6 = + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term top2 in + FStarC_Compiler_Util.format1 + "Incompatibility between typechecker and normalizer; this monadic application contains impure terms %s\n" + uu___7 in + FStarC_Errors.log_issue + (FStarC_Syntax_Syntax.has_range_syntax ()) + top2 FStarC_Errors_Codes.Warning_Defensive () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___6) + else ()) + else ()); + (let fallback1 uu___4 = + FStarC_TypeChecker_Cfg.log cfg + (fun uu___6 -> + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term top0 in + FStarC_Compiler_Util.print2 + "Reified (2) <%s> to %s\n" uu___7 ""); + (let uu___6 = FStarC_Compiler_List.tl stack1 in + let uu___7 = + FStarC_Syntax_Util.mk_reify top2 + (FStar_Pervasives_Native.Some m) in + norm cfg env1 uu___6 uu___7) in + let fallback2 uu___4 = + FStarC_TypeChecker_Cfg.log cfg + (fun uu___6 -> + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term top0 in + FStarC_Compiler_Util.print2 + "Reified (3) <%s> to %s\n" uu___7 ""); + (let uu___6 = FStarC_Compiler_List.tl stack1 in + let uu___7 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 = top2; + FStarC_Syntax_Syntax.meta = + (FStarC_Syntax_Syntax.Meta_monadic + (m, t)) + }) top0.FStarC_Syntax_Syntax.pos in + norm cfg env1 uu___6 uu___7) in + let uu___4 = + let uu___5 = FStarC_Syntax_Util.un_uinst head in + uu___5.FStarC_Syntax_Syntax.n in + match uu___4 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let lid = FStarC_Syntax_Syntax.lid_of_fv fv in + let qninfo = + FStarC_TypeChecker_Env.lookup_qname + cfg.FStarC_TypeChecker_Cfg.tcenv lid in + let uu___5 = + let uu___6 = + FStarC_TypeChecker_Env.is_action + cfg.FStarC_TypeChecker_Cfg.tcenv lid in + Prims.op_Negation uu___6 in + if uu___5 + then fallback1 () + else + (let uu___7 = + let uu___8 = + FStarC_TypeChecker_Env.lookup_definition_qninfo + cfg.FStarC_TypeChecker_Cfg.delta_level + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + qninfo in + FStarC_Compiler_Option.isNone uu___8 in + if uu___7 + then fallback2 () + else + (let t1 = + let uu___9 = + FStarC_Syntax_Util.mk_reify head + (FStar_Pervasives_Native.Some m) in + FStarC_Syntax_Syntax.mk_Tm_app uu___9 + args t.FStarC_Syntax_Syntax.pos in + let uu___9 = FStarC_Compiler_List.tl stack1 in + norm cfg env1 uu___9 t1)) + | uu___5 -> fallback1 ())) + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = e; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_monadic uu___3;_} + -> do_reify_monadic fallback cfg env1 stack1 e m t + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = e; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_monadic_lift + (msrc, mtgt, t');_} + -> + let lifted = + let uu___3 = closure_as_term cfg env1 t' in + reify_lift cfg e msrc mtgt uu___3 in + (FStarC_TypeChecker_Cfg.log cfg + (fun uu___4 -> + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term lifted in + FStarC_Compiler_Util.print1 + "Reified lift to (2): %s\n" uu___5); + (let uu___4 = FStarC_Compiler_List.tl stack1 in + norm cfg env1 uu___4 lifted)) + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = e; + FStarC_Syntax_Syntax.ret_opt = asc_opt; + FStarC_Syntax_Syntax.brs = branches1; + FStarC_Syntax_Syntax.rc_opt1 = lopt;_} + -> + let branches2 = + FStarC_Compiler_List.map + (fun uu___3 -> + match uu___3 with + | (pat, wopt, tm) -> + let uu___4 = + FStarC_Syntax_Util.mk_reify tm + (FStar_Pervasives_Native.Some m) in + (pat, wopt, uu___4)) branches1 in + let tm = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_match + { + FStarC_Syntax_Syntax.scrutinee = e; + FStarC_Syntax_Syntax.ret_opt = asc_opt; + FStarC_Syntax_Syntax.brs = branches2; + FStarC_Syntax_Syntax.rc_opt1 = lopt + }) top2.FStarC_Syntax_Syntax.pos in + let uu___3 = FStarC_Compiler_List.tl stack1 in + norm cfg env1 uu___3 tm + | uu___3 -> fallback ())) +and (reify_lift : + FStarC_TypeChecker_Cfg.cfg -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.monad_name -> + FStarC_Syntax_Syntax.monad_name -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun cfg -> + fun e -> + fun msrc -> + fun mtgt -> + fun t -> + let env1 = cfg.FStarC_TypeChecker_Cfg.tcenv in + FStarC_TypeChecker_Cfg.log cfg + (fun uu___1 -> + let uu___2 = FStarC_Ident.string_of_lid msrc in + let uu___3 = FStarC_Ident.string_of_lid mtgt in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + FStarC_Compiler_Util.print3 "Reifying lift %s -> %s: %s\n" + uu___2 uu___3 uu___4); + (let uu___1 = + ((FStarC_Syntax_Util.is_pure_effect msrc) || + (FStarC_Syntax_Util.is_div_effect msrc)) + && + (let uu___2 = + FStarC_TypeChecker_Env.is_layered_effect env1 mtgt in + Prims.op_Negation uu___2) in + if uu___1 + then + let ed = + let uu___2 = + FStarC_TypeChecker_Env.norm_eff_name + cfg.FStarC_TypeChecker_Cfg.tcenv mtgt in + FStarC_TypeChecker_Env.get_effect_decl env1 uu___2 in + let uu___2 = + let uu___3 = FStarC_Syntax_Util.get_eff_repr ed in + FStarC_Compiler_Util.must uu___3 in + match uu___2 with + | (uu___3, repr) -> + let uu___4 = + let uu___5 = FStarC_Syntax_Util.get_return_repr ed in + FStarC_Compiler_Util.must uu___5 in + (match uu___4 with + | (uu___5, return_repr) -> + let return_inst = + let uu___6 = + let uu___7 = + FStarC_Syntax_Subst.compress return_repr in + uu___7.FStarC_Syntax_Syntax.n in + match uu___6 with + | FStarC_Syntax_Syntax.Tm_uinst + (return_tm, uu___7::[]) -> + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + env1.FStarC_TypeChecker_Env.universe_of + env1 t in + [uu___11] in + (return_tm, uu___10) in + FStarC_Syntax_Syntax.Tm_uinst uu___9 in + FStarC_Syntax_Syntax.mk uu___8 + e.FStarC_Syntax_Syntax.pos + | uu___7 -> + failwith "NIY : Reification of indexed effects" in + let uu___6 = + let bv = + FStarC_Syntax_Syntax.new_bv + FStar_Pervasives_Native.None t in + let lb = + let uu___7 = + let uu___8 = + let uu___9 = FStarC_Syntax_Syntax.as_arg t in + [uu___9] in + FStarC_Syntax_Util.mk_app repr uu___8 in + { + FStarC_Syntax_Syntax.lbname = + (FStar_Pervasives.Inl bv); + FStarC_Syntax_Syntax.lbunivs = []; + FStarC_Syntax_Syntax.lbtyp = uu___7; + FStarC_Syntax_Syntax.lbeff = msrc; + FStarC_Syntax_Syntax.lbdef = e; + FStarC_Syntax_Syntax.lbattrs = []; + FStarC_Syntax_Syntax.lbpos = + (e.FStarC_Syntax_Syntax.pos) + } in + let uu___7 = FStarC_Syntax_Syntax.bv_to_name bv in + (lb, bv, uu___7) in + (match uu___6 with + | (lb_e, e_bv, e1) -> + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Syntax_Syntax.mk_binder e_bv in + [uu___11] in + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + FStarC_Syntax_Syntax.as_arg t in + let uu___16 = + let uu___17 = + FStarC_Syntax_Syntax.as_arg e1 in + [uu___17] in + uu___15 :: uu___16 in + { + FStarC_Syntax_Syntax.hd = + return_inst; + FStarC_Syntax_Syntax.args = + uu___14 + } in + FStarC_Syntax_Syntax.Tm_app uu___13 in + FStarC_Syntax_Syntax.mk uu___12 + e1.FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Subst.close uu___10 uu___11 in + { + FStarC_Syntax_Syntax.lbs = (false, [lb_e]); + FStarC_Syntax_Syntax.body1 = uu___9 + } in + FStarC_Syntax_Syntax.Tm_let uu___8 in + FStarC_Syntax_Syntax.mk uu___7 + e1.FStarC_Syntax_Syntax.pos)) + else + (let uu___3 = FStarC_TypeChecker_Env.monad_leq env1 msrc mtgt in + match uu___3 with + | FStar_Pervasives_Native.None -> + let uu___4 = + let uu___5 = FStarC_Ident.string_of_lid msrc in + let uu___6 = FStarC_Ident.string_of_lid mtgt in + FStarC_Compiler_Util.format2 + "Impossible : trying to reify a lift between unrelated effects (%s and %s)" + uu___5 uu___6 in + failwith uu___4 + | FStar_Pervasives_Native.Some + { FStarC_TypeChecker_Env.msource = uu___4; + FStarC_TypeChecker_Env.mtarget = uu___5; + FStarC_TypeChecker_Env.mlift = + { FStarC_TypeChecker_Env.mlift_wp = uu___6; + FStarC_TypeChecker_Env.mlift_term = + FStar_Pervasives_Native.None;_}; + FStarC_TypeChecker_Env.mpath = uu___7;_} + -> + let uu___8 = + let uu___9 = FStarC_Ident.string_of_lid msrc in + let uu___10 = FStarC_Ident.string_of_lid mtgt in + FStarC_Compiler_Util.format2 + "Impossible : trying to reify a non-reifiable lift (from %s to %s)" + uu___9 uu___10 in + failwith uu___8 + | FStar_Pervasives_Native.Some + { FStarC_TypeChecker_Env.msource = uu___4; + FStarC_TypeChecker_Env.mtarget = uu___5; + FStarC_TypeChecker_Env.mlift = + { FStarC_TypeChecker_Env.mlift_wp = uu___6; + FStarC_TypeChecker_Env.mlift_term = + FStar_Pervasives_Native.Some lift;_}; + FStarC_TypeChecker_Env.mpath = uu___7;_} + -> + let e1 = + let uu___8 = + FStarC_TypeChecker_Env.is_reifiable_effect env1 msrc in + if uu___8 + then + FStarC_Syntax_Util.mk_reify e + (FStar_Pervasives_Native.Some msrc) + else + (let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Syntax_Syntax.null_binder + FStarC_Syntax_Syntax.t_unit in + [uu___13] in + { + FStarC_Syntax_Syntax.bs = uu___12; + FStarC_Syntax_Syntax.body = e; + FStarC_Syntax_Syntax.rc_opt = + (FStar_Pervasives_Native.Some + { + FStarC_Syntax_Syntax.residual_effect = + msrc; + FStarC_Syntax_Syntax.residual_typ = + (FStar_Pervasives_Native.Some t); + FStarC_Syntax_Syntax.residual_flags = + [] + }) + } in + FStarC_Syntax_Syntax.Tm_abs uu___11 in + FStarC_Syntax_Syntax.mk uu___10 + e.FStarC_Syntax_Syntax.pos) in + let uu___8 = + env1.FStarC_TypeChecker_Env.universe_of env1 t in + lift uu___8 t e1)) +and (norm_pattern_args : + FStarC_TypeChecker_Cfg.cfg -> + env -> + (FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax * + FStarC_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) + Prims.list Prims.list -> + (FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax * + FStarC_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) + Prims.list Prims.list) + = + fun cfg -> + fun env1 -> + fun args -> + FStarC_Compiler_List.map + (FStarC_Compiler_List.map + (fun uu___ -> + match uu___ with + | (a, imp) -> + let uu___1 = norm cfg env1 [] a in (uu___1, imp))) args +and (norm_comp : + FStarC_TypeChecker_Cfg.cfg -> + env -> FStarC_Syntax_Syntax.comp -> FStarC_Syntax_Syntax.comp) + = + fun cfg -> + fun env1 -> + fun comp -> + FStarC_TypeChecker_Cfg.log cfg + (fun uu___1 -> + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_comp comp in + let uu___3 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_nat) + (FStarC_Compiler_List.length env1) in + FStarC_Compiler_Util.print2 + ">>> %s\nNormComp with with %s env elements\n" uu___2 uu___3); + (match comp.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total t -> + let t1 = norm cfg env1 [] t in + let uu___1 = FStarC_Syntax_Syntax.mk_Total t1 in + { + FStarC_Syntax_Syntax.n = (uu___1.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = (comp.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = (uu___1.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (uu___1.FStarC_Syntax_Syntax.hash_code) + } + | FStarC_Syntax_Syntax.GTotal t -> + let t1 = norm cfg env1 [] t in + let uu___1 = FStarC_Syntax_Syntax.mk_GTotal t1 in + { + FStarC_Syntax_Syntax.n = (uu___1.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = (comp.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = (uu___1.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (uu___1.FStarC_Syntax_Syntax.hash_code) + } + | FStarC_Syntax_Syntax.Comp ct -> + let effect_args = + let uu___1 = + let uu___2 = + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.for_extraction + && + (let uu___3 = + let uu___4 = + get_extraction_mode + cfg.FStarC_TypeChecker_Cfg.tcenv + ct.FStarC_Syntax_Syntax.effect_name in + uu___4 = FStarC_Syntax_Syntax.Extract_reify in + Prims.op_Negation uu___3) in + if uu___2 + then + FStarC_Compiler_List.map + (fun uu___3 -> + FStarC_Syntax_Syntax.as_arg + FStarC_Syntax_Syntax.unit_const) + else + FStarC_Compiler_List.mapi + (fun idx -> + fun uu___4 -> + match uu___4 with + | (a, i) -> + let uu___5 = norm cfg env1 [] a in (uu___5, i)) in + uu___1 ct.FStarC_Syntax_Syntax.effect_args in + let flags = + FStarC_Compiler_List.map + (fun uu___1 -> + match uu___1 with + | FStarC_Syntax_Syntax.DECREASES + (FStarC_Syntax_Syntax.Decreases_lex l) -> + let uu___2 = + let uu___3 = + FStarC_Compiler_List.map (norm cfg env1 []) l in + FStarC_Syntax_Syntax.Decreases_lex uu___3 in + FStarC_Syntax_Syntax.DECREASES uu___2 + | FStarC_Syntax_Syntax.DECREASES + (FStarC_Syntax_Syntax.Decreases_wf (rel, e)) -> + let uu___2 = + let uu___3 = + let uu___4 = norm cfg env1 [] rel in + let uu___5 = norm cfg env1 [] e in + (uu___4, uu___5) in + FStarC_Syntax_Syntax.Decreases_wf uu___3 in + FStarC_Syntax_Syntax.DECREASES uu___2 + | f -> f) ct.FStarC_Syntax_Syntax.flags in + let comp_univs = + FStarC_Compiler_List.map (norm_universe cfg env1) + ct.FStarC_Syntax_Syntax.comp_univs in + let result_typ = + norm cfg env1 [] ct.FStarC_Syntax_Syntax.result_typ in + let uu___1 = + FStarC_Syntax_Syntax.mk_Comp + { + FStarC_Syntax_Syntax.comp_univs = comp_univs; + FStarC_Syntax_Syntax.effect_name = + (ct.FStarC_Syntax_Syntax.effect_name); + FStarC_Syntax_Syntax.result_typ = result_typ; + FStarC_Syntax_Syntax.effect_args = effect_args; + FStarC_Syntax_Syntax.flags = flags + } in + { + FStarC_Syntax_Syntax.n = (uu___1.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = (comp.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = (uu___1.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (uu___1.FStarC_Syntax_Syntax.hash_code) + }) +and (norm_binder : + FStarC_TypeChecker_Cfg.cfg -> + env -> FStarC_Syntax_Syntax.binder -> FStarC_Syntax_Syntax.binder) + = + fun cfg -> + fun env1 -> + fun b -> + let x = + let uu___ = b.FStarC_Syntax_Syntax.binder_bv in + let uu___1 = + norm cfg env1 [] + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + { + FStarC_Syntax_Syntax.ppname = (uu___.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = (uu___.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = uu___1 + } in + let imp = + match b.FStarC_Syntax_Syntax.binder_qual with + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Meta t) -> + let uu___ = + let uu___1 = closure_as_term cfg env1 t in + FStarC_Syntax_Syntax.Meta uu___1 in + FStar_Pervasives_Native.Some uu___ + | i -> i in + let attrs = + FStarC_Compiler_List.map (norm cfg env1 []) + b.FStarC_Syntax_Syntax.binder_attrs in + FStarC_Syntax_Syntax.mk_binder_with_attrs x imp + b.FStarC_Syntax_Syntax.binder_positivity attrs +and (norm_binders : + FStarC_TypeChecker_Cfg.cfg -> + env -> FStarC_Syntax_Syntax.binders -> FStarC_Syntax_Syntax.binders) + = + fun cfg -> + fun env1 -> + fun bs -> + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun b -> + match uu___1 with + | (nbs', env2) -> + let b1 = norm_binder cfg env2 b in + let uu___2 = let uu___3 = dummy () in uu___3 :: env2 in + ((b1 :: nbs'), uu___2)) ([], env1) bs in + match uu___ with | (nbs, uu___1) -> FStarC_Compiler_List.rev nbs +and (maybe_simplify : + FStarC_TypeChecker_Cfg.cfg -> + env -> + stack -> + FStarC_Syntax_Syntax.term -> (FStarC_Syntax_Syntax.term * Prims.bool)) + = + fun cfg -> + fun env1 -> + fun stack1 -> + fun tm -> + let uu___ = maybe_simplify_aux cfg env1 stack1 tm in + match uu___ with + | (tm', renorm) -> + (if + (cfg.FStarC_TypeChecker_Cfg.debug).FStarC_TypeChecker_Cfg.b380 + then + (let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + tm in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + tm' in + let uu___4 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) renorm in + FStarC_Compiler_Util.print4 + "%sSimplified\n\t%s to\n\t%s\nrenorm = %s\n" + (if + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.simplify + then "" + else "NOT ") uu___2 uu___3 uu___4) + else (); + (tm', renorm)) +and (norm_cb : + FStarC_TypeChecker_Cfg.cfg -> FStarC_Syntax_Embeddings_Base.norm_cb) = + fun cfg -> + fun uu___ -> + match uu___ with + | FStar_Pervasives.Inr x -> norm cfg [] [] x + | FStar_Pervasives.Inl l -> + let uu___1 = + FStarC_Syntax_DsEnv.try_lookup_lid + (cfg.FStarC_TypeChecker_Cfg.tcenv).FStarC_TypeChecker_Env.dsenv + l in + (match uu___1 with + | FStar_Pervasives_Native.Some t -> t + | FStar_Pervasives_Native.None -> + let uu___2 = + FStarC_Syntax_Syntax.lid_as_fv l + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___2) +and (maybe_simplify_aux : + FStarC_TypeChecker_Cfg.cfg -> + env -> + stack -> + FStarC_Syntax_Syntax.term -> (FStarC_Syntax_Syntax.term * Prims.bool)) + = + fun cfg -> + fun env1 -> + fun stack1 -> + fun tm -> + let uu___ = + let uu___1 = norm_cb cfg in reduce_primops uu___1 cfg env1 tm in + match uu___ with + | (tm1, renorm) -> + if + Prims.op_Negation + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.simplify + then (tm1, renorm) + else + (let w t = + { + FStarC_Syntax_Syntax.n = (t.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = + (tm1.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = + (t.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (t.FStarC_Syntax_Syntax.hash_code) + } in + let simp_t t = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.unmeta t in + uu___3.FStarC_Syntax_Syntax.n in + match uu___2 with + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.true_lid + -> FStar_Pervasives_Native.Some true + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.false_lid + -> FStar_Pervasives_Native.Some false + | uu___3 -> FStar_Pervasives_Native.None in + let is_const_match phi = + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress phi in + uu___3.FStarC_Syntax_Syntax.n in + match uu___2 with + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = uu___3; + FStarC_Syntax_Syntax.ret_opt = uu___4; + FStarC_Syntax_Syntax.brs = br::brs; + FStarC_Syntax_Syntax.rc_opt1 = uu___5;_} + -> + let uu___6 = br in + (match uu___6 with + | (uu___7, uu___8, e) -> + let r = + let uu___9 = simp_t e in + match uu___9 with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some b -> + let uu___10 = + FStarC_Compiler_List.for_all + (fun uu___11 -> + match uu___11 with + | (uu___12, uu___13, e') -> + let uu___14 = simp_t e' in + uu___14 = + (FStar_Pervasives_Native.Some + b)) brs in + if uu___10 + then FStar_Pervasives_Native.Some b + else FStar_Pervasives_Native.None in + r) + | uu___3 -> FStar_Pervasives_Native.None in + let maybe_auto_squash t = + let uu___2 = FStarC_Syntax_Util.is_sub_singleton t in + if uu___2 + then t + else + FStarC_Syntax_Util.mk_auto_squash + FStarC_Syntax_Syntax.U_zero t in + let squashed_head_un_auto_squash_args t = + let maybe_un_auto_squash_arg uu___2 = + match uu___2 with + | (t1, q) -> + let uu___3 = FStarC_Syntax_Util.is_auto_squash t1 in + (match uu___3 with + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.U_zero, t2) -> (t2, q) + | uu___4 -> (t1, q)) in + let uu___2 = FStarC_Syntax_Util.head_and_args t in + match uu___2 with + | (head, args) -> + let args1 = + FStarC_Compiler_List.map maybe_un_auto_squash_arg + args in + let uu___3 = + FStarC_Syntax_Syntax.mk_Tm_app head args1 + t.FStarC_Syntax_Syntax.pos in + (uu___3, false) in + let rec clearly_inhabited ty = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.unmeta ty in + uu___3.FStarC_Syntax_Syntax.n in + match uu___2 with + | FStarC_Syntax_Syntax.Tm_uinst (t, uu___3) -> + clearly_inhabited t + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = uu___3; + FStarC_Syntax_Syntax.comp = c;_} + -> + clearly_inhabited (FStarC_Syntax_Util.comp_result c) + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let l = FStarC_Syntax_Syntax.lid_of_fv fv in + (((FStarC_Ident.lid_equals l + FStarC_Parser_Const.int_lid) + || + (FStarC_Ident.lid_equals l + FStarC_Parser_Const.bool_lid)) + || + (FStarC_Ident.lid_equals l + FStarC_Parser_Const.string_lid)) + || + (FStarC_Ident.lid_equals l + FStarC_Parser_Const.exn_lid) + | uu___3 -> false in + let simplify arg = + let uu___2 = simp_t (FStar_Pervasives_Native.fst arg) in + (uu___2, arg) in + let uu___2 = is_forall_const cfg tm1 in + match uu___2 with + | FStar_Pervasives_Native.Some tm' -> + (if + (cfg.FStarC_TypeChecker_Cfg.debug).FStarC_TypeChecker_Cfg.wpe + then + (let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term tm1 in + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term tm' in + FStarC_Compiler_Util.print2 "WPE> %s ~> %s\n" uu___4 + uu___5) + else (); + (let uu___4 = norm cfg env1 [] tm' in + maybe_simplify_aux cfg env1 stack1 uu___4)) + | FStar_Pervasives_Native.None -> + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.compress tm1 in + uu___4.FStarC_Syntax_Syntax.n in + (match uu___3 with + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Tm_uinst + ({ + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Tm_fvar fv; + FStarC_Syntax_Syntax.pos = uu___4; + FStarC_Syntax_Syntax.vars = uu___5; + FStarC_Syntax_Syntax.hash_code = uu___6;_}, + uu___7); + FStarC_Syntax_Syntax.pos = uu___8; + FStarC_Syntax_Syntax.vars = uu___9; + FStarC_Syntax_Syntax.hash_code = uu___10;_}; + FStarC_Syntax_Syntax.args = args;_} + -> + let uu___11 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.squash_lid in + if uu___11 + then squashed_head_un_auto_squash_args tm1 + else + (let uu___13 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.and_lid in + if uu___13 + then + let uu___14 = + FStarC_Compiler_List.map simplify args in + match uu___14 with + | (FStar_Pervasives_Native.Some (true), + uu___15)::(uu___16, (arg, uu___17))::[] -> + let uu___18 = maybe_auto_squash arg in + (uu___18, false) + | (uu___15, (arg, uu___16))::(FStar_Pervasives_Native.Some + (true), uu___17)::[] + -> + let uu___18 = maybe_auto_squash arg in + (uu___18, false) + | (FStar_Pervasives_Native.Some (false), + uu___15)::uu___16::[] -> + ((w FStarC_Syntax_Util.t_false), false) + | uu___15::(FStar_Pervasives_Native.Some + (false), uu___16)::[] + -> ((w FStarC_Syntax_Util.t_false), false) + | uu___15 -> + squashed_head_un_auto_squash_args tm1 + else + (let uu___15 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.or_lid in + if uu___15 + then + let uu___16 = + FStarC_Compiler_List.map simplify args in + match uu___16 with + | (FStar_Pervasives_Native.Some (true), + uu___17)::uu___18::[] -> + ((w FStarC_Syntax_Util.t_true), false) + | uu___17::(FStar_Pervasives_Native.Some + (true), uu___18)::[] + -> + ((w FStarC_Syntax_Util.t_true), false) + | (FStar_Pervasives_Native.Some (false), + uu___17)::(uu___18, (arg, uu___19))::[] + -> + let uu___20 = maybe_auto_squash arg in + (uu___20, false) + | (uu___17, (arg, uu___18))::(FStar_Pervasives_Native.Some + (false), + uu___19)::[] + -> + let uu___20 = maybe_auto_squash arg in + (uu___20, false) + | uu___17 -> + squashed_head_un_auto_squash_args tm1 + else + (let uu___17 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.imp_lid in + if uu___17 + then + let uu___18 = + FStarC_Compiler_List.map simplify args in + match uu___18 with + | uu___19::(FStar_Pervasives_Native.Some + (true), uu___20)::[] + -> + ((w FStarC_Syntax_Util.t_true), + false) + | (FStar_Pervasives_Native.Some (false), + uu___19)::uu___20::[] -> + ((w FStarC_Syntax_Util.t_true), + false) + | (FStar_Pervasives_Native.Some (true), + uu___19)::(uu___20, (arg, uu___21))::[] + -> + let uu___22 = maybe_auto_squash arg in + (uu___22, false) + | (uu___19, (p, uu___20))::(uu___21, + (q, uu___22))::[] + -> + let uu___23 = + FStarC_Syntax_Util.term_eq p q in + (if uu___23 + then + ((w FStarC_Syntax_Util.t_true), + false) + else + squashed_head_un_auto_squash_args + tm1) + | uu___19 -> + squashed_head_un_auto_squash_args + tm1 + else + (let uu___19 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.iff_lid in + if uu___19 + then + let uu___20 = + FStarC_Compiler_List.map simplify + args in + match uu___20 with + | (FStar_Pervasives_Native.Some + (true), uu___21)::(FStar_Pervasives_Native.Some + (true), + uu___22)::[] + -> + ((w FStarC_Syntax_Util.t_true), + false) + | (FStar_Pervasives_Native.Some + (false), uu___21)::(FStar_Pervasives_Native.Some + (false), + uu___22)::[] + -> + ((w FStarC_Syntax_Util.t_true), + false) + | (FStar_Pervasives_Native.Some + (true), uu___21)::(FStar_Pervasives_Native.Some + (false), + uu___22)::[] + -> + ((w FStarC_Syntax_Util.t_false), + false) + | (FStar_Pervasives_Native.Some + (false), uu___21)::(FStar_Pervasives_Native.Some + (true), + uu___22)::[] + -> + ((w FStarC_Syntax_Util.t_false), + false) + | (uu___21, (arg, uu___22)):: + (FStar_Pervasives_Native.Some + (true), uu___23)::[] + -> + let uu___24 = + maybe_auto_squash arg in + (uu___24, false) + | (FStar_Pervasives_Native.Some + (true), uu___21)::(uu___22, + (arg, uu___23))::[] + -> + let uu___24 = + maybe_auto_squash arg in + (uu___24, false) + | (uu___21, (arg, uu___22)):: + (FStar_Pervasives_Native.Some + (false), uu___23)::[] + -> + let uu___24 = + let uu___25 = + FStarC_Syntax_Util.mk_neg arg in + maybe_auto_squash uu___25 in + (uu___24, false) + | (FStar_Pervasives_Native.Some + (false), uu___21)::(uu___22, + (arg, uu___23))::[] + -> + let uu___24 = + let uu___25 = + FStarC_Syntax_Util.mk_neg arg in + maybe_auto_squash uu___25 in + (uu___24, false) + | (uu___21, (p, uu___22))::(uu___23, + (q, + uu___24))::[] + -> + let uu___25 = + FStarC_Syntax_Util.term_eq p q in + (if uu___25 + then + ((w FStarC_Syntax_Util.t_true), + false) + else + squashed_head_un_auto_squash_args + tm1) + | uu___21 -> + squashed_head_un_auto_squash_args + tm1 + else + (let uu___21 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.not_lid in + if uu___21 + then + let uu___22 = + FStarC_Compiler_List.map + simplify args in + match uu___22 with + | (FStar_Pervasives_Native.Some + (true), uu___23)::[] -> + ((w FStarC_Syntax_Util.t_false), + false) + | (FStar_Pervasives_Native.Some + (false), uu___23)::[] -> + ((w FStarC_Syntax_Util.t_true), + false) + | uu___23 -> + squashed_head_un_auto_squash_args + tm1 + else + (let uu___23 = + FStarC_Syntax_Syntax.fv_eq_lid + fv + FStarC_Parser_Const.forall_lid in + if uu___23 + then + match args with + | (t, uu___24)::[] -> + let uu___25 = + let uu___26 = + FStarC_Syntax_Subst.compress + t in + uu___26.FStarC_Syntax_Syntax.n in + (match uu___25 with + | FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs + = uu___26::[]; + FStarC_Syntax_Syntax.body + = body; + FStarC_Syntax_Syntax.rc_opt + = uu___27;_} + -> + let uu___28 = + simp_t body in + (match uu___28 with + | FStar_Pervasives_Native.Some + (true) -> + ((w + FStarC_Syntax_Util.t_true), + false) + | uu___29 -> + (tm1, false)) + | uu___26 -> (tm1, false)) + | (ty, + FStar_Pervasives_Native.Some + { + FStarC_Syntax_Syntax.aqual_implicit + = true; + FStarC_Syntax_Syntax.aqual_attributes + = uu___24;_})::(t, + uu___25)::[] + -> + let uu___26 = + let uu___27 = + FStarC_Syntax_Subst.compress + t in + uu___27.FStarC_Syntax_Syntax.n in + (match uu___26 with + | FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs + = uu___27::[]; + FStarC_Syntax_Syntax.body + = body; + FStarC_Syntax_Syntax.rc_opt + = uu___28;_} + -> + let uu___29 = + simp_t body in + (match uu___29 with + | FStar_Pervasives_Native.Some + (true) -> + ((w + FStarC_Syntax_Util.t_true), + false) + | FStar_Pervasives_Native.Some + (false) when + clearly_inhabited + ty + -> + ((w + FStarC_Syntax_Util.t_false), + false) + | uu___30 -> + (tm1, false)) + | uu___27 -> (tm1, false)) + | uu___24 -> (tm1, false) + else + (let uu___25 = + FStarC_Syntax_Syntax.fv_eq_lid + fv + FStarC_Parser_Const.exists_lid in + if uu___25 + then + match args with + | (t, uu___26)::[] -> + let uu___27 = + let uu___28 = + FStarC_Syntax_Subst.compress + t in + uu___28.FStarC_Syntax_Syntax.n in + (match uu___27 with + | FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs + = uu___28::[]; + FStarC_Syntax_Syntax.body + = body; + FStarC_Syntax_Syntax.rc_opt + = uu___29;_} + -> + let uu___30 = + simp_t body in + (match uu___30 with + | FStar_Pervasives_Native.Some + (false) -> + ((w + FStarC_Syntax_Util.t_false), + false) + | uu___31 -> + (tm1, false)) + | uu___28 -> + (tm1, false)) + | (ty, + FStar_Pervasives_Native.Some + { + FStarC_Syntax_Syntax.aqual_implicit + = true; + FStarC_Syntax_Syntax.aqual_attributes + = uu___26;_}):: + (t, uu___27)::[] -> + let uu___28 = + let uu___29 = + FStarC_Syntax_Subst.compress + t in + uu___29.FStarC_Syntax_Syntax.n in + (match uu___28 with + | FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs + = uu___29::[]; + FStarC_Syntax_Syntax.body + = body; + FStarC_Syntax_Syntax.rc_opt + = uu___30;_} + -> + let uu___31 = + simp_t body in + (match uu___31 with + | FStar_Pervasives_Native.Some + (false) -> + ((w + FStarC_Syntax_Util.t_false), + false) + | FStar_Pervasives_Native.Some + (true) when + clearly_inhabited + ty + -> + ((w + FStarC_Syntax_Util.t_true), + false) + | uu___32 -> + (tm1, false)) + | uu___29 -> + (tm1, false)) + | uu___26 -> (tm1, false) + else + (let uu___27 = + FStarC_Syntax_Syntax.fv_eq_lid + fv + FStarC_Parser_Const.b2t_lid in + if uu___27 + then + match args with + | ({ + FStarC_Syntax_Syntax.n + = + FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_bool + (true)); + FStarC_Syntax_Syntax.pos + = uu___28; + FStarC_Syntax_Syntax.vars + = uu___29; + FStarC_Syntax_Syntax.hash_code + = uu___30;_}, + uu___31)::[] -> + ((w + FStarC_Syntax_Util.t_true), + false) + | ({ + FStarC_Syntax_Syntax.n + = + FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_bool + (false)); + FStarC_Syntax_Syntax.pos + = uu___28; + FStarC_Syntax_Syntax.vars + = uu___29; + FStarC_Syntax_Syntax.hash_code + = uu___30;_}, + uu___31)::[] -> + ((w + FStarC_Syntax_Util.t_false), + false) + | uu___28 -> (tm1, false) + else + (let uu___29 = + FStarC_Syntax_Syntax.fv_eq_lid + fv + FStarC_Parser_Const.haseq_lid in + if uu___29 + then + let t_has_eq_for_sure + t = + let haseq_lids = + [FStarC_Parser_Const.int_lid; + FStarC_Parser_Const.bool_lid; + FStarC_Parser_Const.unit_lid; + FStarC_Parser_Const.string_lid] in + let uu___30 = + let uu___31 = + FStarC_Syntax_Subst.compress + t in + uu___31.FStarC_Syntax_Syntax.n in + match uu___30 with + | FStarC_Syntax_Syntax.Tm_fvar + fv1 when + FStarC_Compiler_List.existsb + (fun l -> + FStarC_Syntax_Syntax.fv_eq_lid + fv1 l) + haseq_lids + -> true + | uu___31 -> false in + (if + (FStarC_Compiler_List.length + args) + = Prims.int_one + then + let t = + let uu___30 = + FStarC_Compiler_List.hd + args in + FStar_Pervasives_Native.fst + uu___30 in + let uu___30 = + t_has_eq_for_sure + t in + (if uu___30 + then + ((w + FStarC_Syntax_Util.t_true), + false) + else + (let uu___32 = + let uu___33 = + FStarC_Syntax_Subst.compress + t in + uu___33.FStarC_Syntax_Syntax.n in + match uu___32 + with + | FStarC_Syntax_Syntax.Tm_refine + uu___33 -> + let t1 = + FStarC_Syntax_Util.unrefine + t in + let uu___34 + = + t_has_eq_for_sure + t1 in + if uu___34 + then + ((w + FStarC_Syntax_Util.t_true), + false) + else + ( + let haseq_tm + = + let uu___36 + = + let uu___37 + = + FStarC_Syntax_Subst.compress + tm1 in + uu___37.FStarC_Syntax_Syntax.n in + match uu___36 + with + | + FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd + = hd; + FStarC_Syntax_Syntax.args + = uu___37;_} + -> hd + | + uu___37 + -> + failwith + "Impossible! We have already checked that this is a Tm_app" in + let uu___36 + = + let uu___37 + = + let uu___38 + = + FStarC_Syntax_Syntax.as_arg + t1 in + [uu___38] in + FStarC_Syntax_Util.mk_app + haseq_tm + uu___37 in + (uu___36, + false)) + | uu___33 -> + (tm1, + false))) + else (tm1, false)) + else + (let uu___31 = + FStarC_Syntax_Syntax.fv_eq_lid + fv + FStarC_Parser_Const.subtype_of_lid in + if uu___31 + then + let is_unit ty = + let uu___32 = + let uu___33 = + FStarC_Syntax_Subst.compress + ty in + uu___33.FStarC_Syntax_Syntax.n in + match uu___32 + with + | FStarC_Syntax_Syntax.Tm_fvar + fv1 -> + FStarC_Syntax_Syntax.fv_eq_lid + fv1 + FStarC_Parser_Const.unit_lid + | uu___33 -> + false in + match args with + | (t, uu___32):: + (ty, uu___33)::[] + when + (is_unit ty) && + (FStarC_Syntax_Util.is_sub_singleton + t) + -> + ((w + FStarC_Syntax_Util.t_true), + false) + | uu___32 -> + (tm1, false) + else + (let uu___33 = + FStarC_Syntax_Util.is_auto_squash + tm1 in + match uu___33 with + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.U_zero, + t) + when + FStarC_Syntax_Util.is_sub_singleton + t + -> (t, false) + | uu___34 -> + let uu___35 = + let uu___36 + = + norm_cb + cfg in + reduce_equality + uu___36 + cfg env1 in + uu___35 tm1))))))))))) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Tm_fvar fv; + FStarC_Syntax_Syntax.pos = uu___4; + FStarC_Syntax_Syntax.vars = uu___5; + FStarC_Syntax_Syntax.hash_code = uu___6;_}; + FStarC_Syntax_Syntax.args = args;_} + -> + let uu___7 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.squash_lid in + if uu___7 + then squashed_head_un_auto_squash_args tm1 + else + (let uu___9 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.and_lid in + if uu___9 + then + let uu___10 = + FStarC_Compiler_List.map simplify args in + match uu___10 with + | (FStar_Pervasives_Native.Some (true), + uu___11)::(uu___12, (arg, uu___13))::[] -> + let uu___14 = maybe_auto_squash arg in + (uu___14, false) + | (uu___11, (arg, uu___12))::(FStar_Pervasives_Native.Some + (true), uu___13)::[] + -> + let uu___14 = maybe_auto_squash arg in + (uu___14, false) + | (FStar_Pervasives_Native.Some (false), + uu___11)::uu___12::[] -> + ((w FStarC_Syntax_Util.t_false), false) + | uu___11::(FStar_Pervasives_Native.Some + (false), uu___12)::[] + -> ((w FStarC_Syntax_Util.t_false), false) + | uu___11 -> + squashed_head_un_auto_squash_args tm1 + else + (let uu___11 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.or_lid in + if uu___11 + then + let uu___12 = + FStarC_Compiler_List.map simplify args in + match uu___12 with + | (FStar_Pervasives_Native.Some (true), + uu___13)::uu___14::[] -> + ((w FStarC_Syntax_Util.t_true), false) + | uu___13::(FStar_Pervasives_Native.Some + (true), uu___14)::[] + -> + ((w FStarC_Syntax_Util.t_true), false) + | (FStar_Pervasives_Native.Some (false), + uu___13)::(uu___14, (arg, uu___15))::[] + -> + let uu___16 = maybe_auto_squash arg in + (uu___16, false) + | (uu___13, (arg, uu___14))::(FStar_Pervasives_Native.Some + (false), + uu___15)::[] + -> + let uu___16 = maybe_auto_squash arg in + (uu___16, false) + | uu___13 -> + squashed_head_un_auto_squash_args tm1 + else + (let uu___13 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.imp_lid in + if uu___13 + then + let uu___14 = + FStarC_Compiler_List.map simplify args in + match uu___14 with + | uu___15::(FStar_Pervasives_Native.Some + (true), uu___16)::[] + -> + ((w FStarC_Syntax_Util.t_true), + false) + | (FStar_Pervasives_Native.Some (false), + uu___15)::uu___16::[] -> + ((w FStarC_Syntax_Util.t_true), + false) + | (FStar_Pervasives_Native.Some (true), + uu___15)::(uu___16, (arg, uu___17))::[] + -> + let uu___18 = maybe_auto_squash arg in + (uu___18, false) + | (uu___15, (p, uu___16))::(uu___17, + (q, uu___18))::[] + -> + let uu___19 = + FStarC_Syntax_Util.term_eq p q in + (if uu___19 + then + ((w FStarC_Syntax_Util.t_true), + false) + else + squashed_head_un_auto_squash_args + tm1) + | uu___15 -> + squashed_head_un_auto_squash_args + tm1 + else + (let uu___15 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.iff_lid in + if uu___15 + then + let uu___16 = + FStarC_Compiler_List.map simplify + args in + match uu___16 with + | (FStar_Pervasives_Native.Some + (true), uu___17)::(FStar_Pervasives_Native.Some + (true), + uu___18)::[] + -> + ((w FStarC_Syntax_Util.t_true), + false) + | (FStar_Pervasives_Native.Some + (false), uu___17)::(FStar_Pervasives_Native.Some + (false), + uu___18)::[] + -> + ((w FStarC_Syntax_Util.t_true), + false) + | (FStar_Pervasives_Native.Some + (true), uu___17)::(FStar_Pervasives_Native.Some + (false), + uu___18)::[] + -> + ((w FStarC_Syntax_Util.t_false), + false) + | (FStar_Pervasives_Native.Some + (false), uu___17)::(FStar_Pervasives_Native.Some + (true), + uu___18)::[] + -> + ((w FStarC_Syntax_Util.t_false), + false) + | (uu___17, (arg, uu___18)):: + (FStar_Pervasives_Native.Some + (true), uu___19)::[] + -> + let uu___20 = + maybe_auto_squash arg in + (uu___20, false) + | (FStar_Pervasives_Native.Some + (true), uu___17)::(uu___18, + (arg, uu___19))::[] + -> + let uu___20 = + maybe_auto_squash arg in + (uu___20, false) + | (uu___17, (arg, uu___18)):: + (FStar_Pervasives_Native.Some + (false), uu___19)::[] + -> + let uu___20 = + let uu___21 = + FStarC_Syntax_Util.mk_neg arg in + maybe_auto_squash uu___21 in + (uu___20, false) + | (FStar_Pervasives_Native.Some + (false), uu___17)::(uu___18, + (arg, uu___19))::[] + -> + let uu___20 = + let uu___21 = + FStarC_Syntax_Util.mk_neg arg in + maybe_auto_squash uu___21 in + (uu___20, false) + | (uu___17, (p, uu___18))::(uu___19, + (q, + uu___20))::[] + -> + let uu___21 = + FStarC_Syntax_Util.term_eq p q in + (if uu___21 + then + ((w FStarC_Syntax_Util.t_true), + false) + else + squashed_head_un_auto_squash_args + tm1) + | uu___17 -> + squashed_head_un_auto_squash_args + tm1 + else + (let uu___17 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.not_lid in + if uu___17 + then + let uu___18 = + FStarC_Compiler_List.map + simplify args in + match uu___18 with + | (FStar_Pervasives_Native.Some + (true), uu___19)::[] -> + ((w FStarC_Syntax_Util.t_false), + false) + | (FStar_Pervasives_Native.Some + (false), uu___19)::[] -> + ((w FStarC_Syntax_Util.t_true), + false) + | uu___19 -> + squashed_head_un_auto_squash_args + tm1 + else + (let uu___19 = + FStarC_Syntax_Syntax.fv_eq_lid + fv + FStarC_Parser_Const.forall_lid in + if uu___19 + then + match args with + | (t, uu___20)::[] -> + let uu___21 = + let uu___22 = + FStarC_Syntax_Subst.compress + t in + uu___22.FStarC_Syntax_Syntax.n in + (match uu___21 with + | FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs + = uu___22::[]; + FStarC_Syntax_Syntax.body + = body; + FStarC_Syntax_Syntax.rc_opt + = uu___23;_} + -> + let uu___24 = + simp_t body in + (match uu___24 with + | FStar_Pervasives_Native.Some + (true) -> + ((w + FStarC_Syntax_Util.t_true), + false) + | uu___25 -> + (tm1, false)) + | uu___22 -> (tm1, false)) + | (ty, + FStar_Pervasives_Native.Some + { + FStarC_Syntax_Syntax.aqual_implicit + = true; + FStarC_Syntax_Syntax.aqual_attributes + = uu___20;_})::(t, + uu___21)::[] + -> + let uu___22 = + let uu___23 = + FStarC_Syntax_Subst.compress + t in + uu___23.FStarC_Syntax_Syntax.n in + (match uu___22 with + | FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs + = uu___23::[]; + FStarC_Syntax_Syntax.body + = body; + FStarC_Syntax_Syntax.rc_opt + = uu___24;_} + -> + let uu___25 = + simp_t body in + (match uu___25 with + | FStar_Pervasives_Native.Some + (true) -> + ((w + FStarC_Syntax_Util.t_true), + false) + | FStar_Pervasives_Native.Some + (false) when + clearly_inhabited + ty + -> + ((w + FStarC_Syntax_Util.t_false), + false) + | uu___26 -> + (tm1, false)) + | uu___23 -> (tm1, false)) + | uu___20 -> (tm1, false) + else + (let uu___21 = + FStarC_Syntax_Syntax.fv_eq_lid + fv + FStarC_Parser_Const.exists_lid in + if uu___21 + then + match args with + | (t, uu___22)::[] -> + let uu___23 = + let uu___24 = + FStarC_Syntax_Subst.compress + t in + uu___24.FStarC_Syntax_Syntax.n in + (match uu___23 with + | FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs + = uu___24::[]; + FStarC_Syntax_Syntax.body + = body; + FStarC_Syntax_Syntax.rc_opt + = uu___25;_} + -> + let uu___26 = + simp_t body in + (match uu___26 with + | FStar_Pervasives_Native.Some + (false) -> + ((w + FStarC_Syntax_Util.t_false), + false) + | uu___27 -> + (tm1, false)) + | uu___24 -> + (tm1, false)) + | (ty, + FStar_Pervasives_Native.Some + { + FStarC_Syntax_Syntax.aqual_implicit + = true; + FStarC_Syntax_Syntax.aqual_attributes + = uu___22;_}):: + (t, uu___23)::[] -> + let uu___24 = + let uu___25 = + FStarC_Syntax_Subst.compress + t in + uu___25.FStarC_Syntax_Syntax.n in + (match uu___24 with + | FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs + = uu___25::[]; + FStarC_Syntax_Syntax.body + = body; + FStarC_Syntax_Syntax.rc_opt + = uu___26;_} + -> + let uu___27 = + simp_t body in + (match uu___27 with + | FStar_Pervasives_Native.Some + (false) -> + ((w + FStarC_Syntax_Util.t_false), + false) + | FStar_Pervasives_Native.Some + (true) when + clearly_inhabited + ty + -> + ((w + FStarC_Syntax_Util.t_true), + false) + | uu___28 -> + (tm1, false)) + | uu___25 -> + (tm1, false)) + | uu___22 -> (tm1, false) + else + (let uu___23 = + FStarC_Syntax_Syntax.fv_eq_lid + fv + FStarC_Parser_Const.b2t_lid in + if uu___23 + then + match args with + | ({ + FStarC_Syntax_Syntax.n + = + FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_bool + (true)); + FStarC_Syntax_Syntax.pos + = uu___24; + FStarC_Syntax_Syntax.vars + = uu___25; + FStarC_Syntax_Syntax.hash_code + = uu___26;_}, + uu___27)::[] -> + ((w + FStarC_Syntax_Util.t_true), + false) + | ({ + FStarC_Syntax_Syntax.n + = + FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_bool + (false)); + FStarC_Syntax_Syntax.pos + = uu___24; + FStarC_Syntax_Syntax.vars + = uu___25; + FStarC_Syntax_Syntax.hash_code + = uu___26;_}, + uu___27)::[] -> + ((w + FStarC_Syntax_Util.t_false), + false) + | uu___24 -> (tm1, false) + else + (let uu___25 = + FStarC_Syntax_Syntax.fv_eq_lid + fv + FStarC_Parser_Const.haseq_lid in + if uu___25 + then + let t_has_eq_for_sure + t = + let haseq_lids = + [FStarC_Parser_Const.int_lid; + FStarC_Parser_Const.bool_lid; + FStarC_Parser_Const.unit_lid; + FStarC_Parser_Const.string_lid] in + let uu___26 = + let uu___27 = + FStarC_Syntax_Subst.compress + t in + uu___27.FStarC_Syntax_Syntax.n in + match uu___26 with + | FStarC_Syntax_Syntax.Tm_fvar + fv1 when + FStarC_Compiler_List.existsb + (fun l -> + FStarC_Syntax_Syntax.fv_eq_lid + fv1 l) + haseq_lids + -> true + | uu___27 -> false in + (if + (FStarC_Compiler_List.length + args) + = Prims.int_one + then + let t = + let uu___26 = + FStarC_Compiler_List.hd + args in + FStar_Pervasives_Native.fst + uu___26 in + let uu___26 = + t_has_eq_for_sure + t in + (if uu___26 + then + ((w + FStarC_Syntax_Util.t_true), + false) + else + (let uu___28 = + let uu___29 = + FStarC_Syntax_Subst.compress + t in + uu___29.FStarC_Syntax_Syntax.n in + match uu___28 + with + | FStarC_Syntax_Syntax.Tm_refine + uu___29 -> + let t1 = + FStarC_Syntax_Util.unrefine + t in + let uu___30 + = + t_has_eq_for_sure + t1 in + if uu___30 + then + ((w + FStarC_Syntax_Util.t_true), + false) + else + ( + let haseq_tm + = + let uu___32 + = + let uu___33 + = + FStarC_Syntax_Subst.compress + tm1 in + uu___33.FStarC_Syntax_Syntax.n in + match uu___32 + with + | + FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd + = hd; + FStarC_Syntax_Syntax.args + = uu___33;_} + -> hd + | + uu___33 + -> + failwith + "Impossible! We have already checked that this is a Tm_app" in + let uu___32 + = + let uu___33 + = + let uu___34 + = + FStarC_Syntax_Syntax.as_arg + t1 in + [uu___34] in + FStarC_Syntax_Util.mk_app + haseq_tm + uu___33 in + (uu___32, + false)) + | uu___29 -> + (tm1, + false))) + else (tm1, false)) + else + (let uu___27 = + FStarC_Syntax_Syntax.fv_eq_lid + fv + FStarC_Parser_Const.subtype_of_lid in + if uu___27 + then + let is_unit ty = + let uu___28 = + let uu___29 = + FStarC_Syntax_Subst.compress + ty in + uu___29.FStarC_Syntax_Syntax.n in + match uu___28 + with + | FStarC_Syntax_Syntax.Tm_fvar + fv1 -> + FStarC_Syntax_Syntax.fv_eq_lid + fv1 + FStarC_Parser_Const.unit_lid + | uu___29 -> + false in + match args with + | (t, uu___28):: + (ty, uu___29)::[] + when + (is_unit ty) && + (FStarC_Syntax_Util.is_sub_singleton + t) + -> + ((w + FStarC_Syntax_Util.t_true), + false) + | uu___28 -> + (tm1, false) + else + (let uu___29 = + FStarC_Syntax_Util.is_auto_squash + tm1 in + match uu___29 with + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.U_zero, + t) + when + FStarC_Syntax_Util.is_sub_singleton + t + -> (t, false) + | uu___30 -> + let uu___31 = + let uu___32 + = + norm_cb + cfg in + reduce_equality + uu___32 + cfg env1 in + uu___31 tm1))))))))))) + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = bv; + FStarC_Syntax_Syntax.phi = t;_} + -> + let uu___4 = simp_t t in + (match uu___4 with + | FStar_Pervasives_Native.Some (true) -> + ((bv.FStarC_Syntax_Syntax.sort), false) + | FStar_Pervasives_Native.Some (false) -> + (tm1, false) + | FStar_Pervasives_Native.None -> (tm1, false)) + | FStarC_Syntax_Syntax.Tm_match uu___4 -> + let uu___5 = is_const_match tm1 in + (match uu___5 with + | FStar_Pervasives_Native.Some (true) -> + ((w FStarC_Syntax_Util.t_true), false) + | FStar_Pervasives_Native.Some (false) -> + ((w FStarC_Syntax_Util.t_false), false) + | FStar_Pervasives_Native.None -> (tm1, false)) + | uu___4 -> (tm1, false))) +and (rebuild : + FStarC_TypeChecker_Cfg.cfg -> + env -> stack -> FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun cfg -> + fun env1 -> + fun stack1 -> + fun t -> + FStarC_TypeChecker_Cfg.log cfg + (fun uu___1 -> + (let uu___3 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term + t in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + let uu___5 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_nat) + (FStarC_Compiler_List.length env1) in + let uu___6 = + let uu___7 = + let uu___8 = firstn (Prims.of_int (4)) stack1 in + FStar_Pervasives_Native.fst uu___8 in + FStarC_Class_Show.show + (FStarC_Class_Show.show_list showable_stack_elt) uu___7 in + FStarC_Compiler_Util.print4 + ">>> %s\nRebuild %s with %s env elements and top of the stack %s\n" + uu___3 uu___4 uu___5 uu___6); + (let uu___3 = FStarC_Compiler_Effect.op_Bang dbg_NormRebuild in + if uu___3 + then + let uu___4 = FStarC_Syntax_Util.unbound_variables t in + match uu___4 with + | [] -> () + | bvs -> + ((let uu___6 = + FStarC_Class_Tagged.tag_of + FStarC_Syntax_Syntax.tagged_term t in + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + let uu___8 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_bv) bvs in + FStarC_Compiler_Util.print3 + "!!! Rebuild (%s) %s, free vars=%s\n" uu___6 uu___7 + uu___8); + failwith "DIE!") + else ())); + (let f_opt = is_fext_on_domain t in + if + (FStarC_Compiler_Util.is_some f_opt) && + (match stack1 with + | (Arg uu___1)::uu___2 -> true + | uu___1 -> false) + then + let uu___1 = FStarC_Compiler_Util.must f_opt in + norm cfg env1 stack1 uu___1 + else + (let uu___2 = maybe_simplify cfg env1 stack1 t in + match uu___2 with + | (t1, renorm) -> + if renorm + then norm cfg env1 stack1 t1 + else do_rebuild cfg env1 stack1 t1)) +and (do_rebuild : + FStarC_TypeChecker_Cfg.cfg -> + env -> stack -> FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun cfg -> + fun env1 -> + fun stack1 -> + fun t -> + match stack1 with + | [] -> t + | (Meta (uu___, m, r))::stack2 -> + let t1 = + match m with + | FStarC_Syntax_Syntax.Meta_monadic uu___1 -> + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress t in + uu___3.FStarC_Syntax_Syntax.n in + (match uu___2 with + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t'; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_monadic uu___3;_} + -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 = t'; + FStarC_Syntax_Syntax.meta = m + }) r + | uu___3 -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 = t; + FStarC_Syntax_Syntax.meta = m + }) r) + | uu___1 -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 = t; + FStarC_Syntax_Syntax.meta = m + }) r in + rebuild cfg env1 stack2 t1 + | (MemoLazy r)::stack2 -> + (set_memo cfg r (env1, t); + FStarC_TypeChecker_Cfg.log cfg + (fun uu___2 -> + let uu___3 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.print1 "\tSet memo %s\n" uu___3); + rebuild cfg env1 stack2 t) + | (Let (env', bs, lb, r))::stack2 -> + let body = FStarC_Syntax_Subst.close bs t in + let t1 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = (false, [lb]); + FStarC_Syntax_Syntax.body1 = body + }) r in + rebuild cfg env' stack2 t1 + | (Abs (env', bs, env'', lopt, r))::stack2 -> + let bs1 = norm_binders cfg env' bs in + let lopt1 = + FStarC_Compiler_Util.map_option + (norm_residual_comp cfg env'') lopt in + let uu___ = + let uu___1 = FStarC_Syntax_Util.abs bs1 t lopt1 in + { + FStarC_Syntax_Syntax.n = (uu___1.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = r; + FStarC_Syntax_Syntax.vars = + (uu___1.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (uu___1.FStarC_Syntax_Syntax.hash_code) + } in + rebuild cfg env1 stack2 uu___ + | (Arg (Univ uu___, uu___1, uu___2))::uu___3 -> + failwith "Impossible" + | (Arg (Dummy, uu___, uu___1))::uu___2 -> failwith "Impossible" + | (UnivArgs (us, r))::stack2 -> + let t1 = FStarC_Syntax_Syntax.mk_Tm_uinst t us in + rebuild cfg env1 stack2 t1 + | (Arg (Clos (env_arg, tm, uu___, uu___1), aq, r))::stack2 when + let uu___2 = head_of t in + FStarC_Syntax_Util.is_fstar_tactics_by_tactic uu___2 -> + let t1 = + let uu___2 = + let uu___3 = closure_as_term cfg env_arg tm in (uu___3, aq) in + FStarC_Syntax_Syntax.extend_app t uu___2 r in + rebuild cfg env1 stack2 t1 + | (Arg (Clos (env_arg, tm, m, uu___), aq, r))::stack2 -> + (FStarC_TypeChecker_Cfg.log cfg + (fun uu___2 -> + let uu___3 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term tm in + FStarC_Compiler_Util.print1 "Rebuilding with arg %s\n" + uu___3); + (let uu___2 = + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.hnf + && + (let uu___3 = is_partial_primop_app cfg t in + Prims.op_Negation uu___3) in + if uu___2 + then + let arg = closure_as_term cfg env_arg tm in + let t1 = FStarC_Syntax_Syntax.extend_app t (arg, aq) r in + rebuild cfg env_arg stack2 t1 + else + (let uu___4 = read_memo cfg m in + match uu___4 with + | FStar_Pervasives_Native.Some (uu___5, a) -> + let t1 = FStarC_Syntax_Syntax.extend_app t (a, aq) r in + rebuild cfg env_arg stack2 t1 + | FStar_Pervasives_Native.None when + Prims.op_Negation + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.iota + -> + let stack3 = (App (env1, t, aq, r)) :: stack2 in + norm cfg env_arg stack3 tm + | FStar_Pervasives_Native.None -> + let stack3 = (MemoLazy m) :: (App (env1, t, aq, r)) :: + stack2 in + norm cfg env_arg stack3 tm))) + | (App (env2, head, aq, r))::stack' when should_reify cfg stack1 -> + let t0 = t in + let fallback msg uu___ = + FStarC_TypeChecker_Cfg.log cfg + (fun uu___2 -> + let uu___3 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.print2 "Not reifying%s: %s\n" msg + uu___3); + (let t1 = FStarC_Syntax_Syntax.extend_app head (t, aq) r in + rebuild cfg env2 stack' t1) in + let is_non_tac_layered_effect m = + let norm_m = + FStarC_TypeChecker_Env.norm_eff_name + cfg.FStarC_TypeChecker_Cfg.tcenv m in + (let uu___ = + FStarC_Ident.lid_equals norm_m + FStarC_Parser_Const.effect_TAC_lid in + Prims.op_Negation uu___) && + (FStarC_TypeChecker_Env.is_layered_effect + cfg.FStarC_TypeChecker_Cfg.tcenv norm_m) in + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + (match uu___ with + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = uu___1; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_monadic (m, uu___2);_} + when + (is_non_tac_layered_effect m) && + (Prims.op_Negation + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.for_extraction) + -> + let uu___3 = + let uu___4 = FStarC_Ident.string_of_lid m in + FStarC_Compiler_Util.format1 + "Meta_monadic for a non-TAC layered effect %s in non-extraction mode" + uu___4 in + fallback uu___3 () + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = uu___1; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_monadic (m, uu___2);_} + when + ((is_non_tac_layered_effect m) && + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.for_extraction) + && + (let uu___3 = + get_extraction_mode cfg.FStarC_TypeChecker_Cfg.tcenv + m in + FStarC_Syntax_Syntax.uu___is_Extract_none uu___3) + -> + let uu___3 = + get_extraction_mode cfg.FStarC_TypeChecker_Cfg.tcenv m in + (match uu___3 with + | FStarC_Syntax_Syntax.Extract_none msg -> + let uu___4 = + let uu___5 = FStarC_Ident.string_of_lid m in + FStarC_Compiler_Util.format2 + "Normalizer cannot reify effect %s for extraction since %s" + uu___5 msg in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) t + FStarC_Errors_Codes.Fatal_UnexpectedEffect () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4)) + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = uu___1; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_monadic (m, uu___2);_} + when + ((is_non_tac_layered_effect m) && + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.for_extraction) + && + (let uu___3 = + get_extraction_mode cfg.FStarC_TypeChecker_Cfg.tcenv + m in + uu___3 = FStarC_Syntax_Syntax.Extract_primitive) + -> + let uu___3 = + let uu___4 = FStarC_Ident.string_of_lid m in + FStarC_Compiler_Util.format1 + "Meta_monadic for a non-TAC layered effect %s which is Extract_primtiive" + uu___4 in + fallback uu___3 () + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = uu___1; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_monadic_lift + (msrc, mtgt, uu___2);_} + when + ((is_non_tac_layered_effect msrc) || + (is_non_tac_layered_effect mtgt)) + && + (Prims.op_Negation + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.for_extraction) + -> + let uu___3 = + let uu___4 = FStarC_Ident.string_of_lid msrc in + let uu___5 = FStarC_Ident.string_of_lid mtgt in + FStarC_Compiler_Util.format2 + "Meta_monadic_lift for a non-TAC layered effect %s ~> %s in non extraction mode" + uu___4 uu___5 in + fallback uu___3 () + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = uu___1; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_monadic_lift + (msrc, mtgt, uu___2);_} + when + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.for_extraction + && + (((is_non_tac_layered_effect msrc) && + (let uu___3 = + get_extraction_mode + cfg.FStarC_TypeChecker_Cfg.tcenv msrc in + FStarC_Syntax_Syntax.uu___is_Extract_none uu___3)) + || + ((is_non_tac_layered_effect mtgt) && + (let uu___3 = + get_extraction_mode + cfg.FStarC_TypeChecker_Cfg.tcenv mtgt in + FStarC_Syntax_Syntax.uu___is_Extract_none uu___3))) + -> + let uu___3 = + let uu___4 = FStarC_Ident.string_of_lid msrc in + let uu___5 = FStarC_Ident.string_of_lid mtgt in + FStarC_Compiler_Util.format2 + "Normalizer cannot reify %s ~> %s for extraction" + uu___4 uu___5 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) t + FStarC_Errors_Codes.Fatal_UnexpectedEffect () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___3) + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t1; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_monadic (m, ty);_} + -> + do_reify_monadic (fallback " (1)") cfg env2 stack1 t1 m ty + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t1; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_monadic_lift + (msrc, mtgt, ty);_} + -> + let lifted = + let uu___1 = closure_as_term cfg env2 ty in + reify_lift cfg t1 msrc mtgt uu___1 in + (FStarC_TypeChecker_Cfg.log cfg + (fun uu___2 -> + let uu___3 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term lifted in + FStarC_Compiler_Util.print1 + "Reified lift to (1): %s\n" uu___3); + (let uu___2 = FStarC_Compiler_List.tl stack1 in + norm cfg env2 uu___2 lifted)) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_reflect uu___1); + FStarC_Syntax_Syntax.pos = uu___2; + FStarC_Syntax_Syntax.vars = uu___3; + FStarC_Syntax_Syntax.hash_code = uu___4;_}; + FStarC_Syntax_Syntax.args = (e, uu___5)::[];_} + -> norm cfg env2 stack' e + | FStarC_Syntax_Syntax.Tm_app uu___1 when + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.primops + -> + let uu___2 = + FStarC_Syntax_Util.head_and_args_full_unmeta t in + (match uu___2 with + | (hd, args) -> + let uu___3 = + let uu___4 = FStarC_Syntax_Util.un_uinst hd in + uu___4.FStarC_Syntax_Syntax.n in + (match uu___3 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let uu___4 = + FStarC_TypeChecker_Cfg.find_prim_step cfg fv in + (match uu___4 with + | FStar_Pervasives_Native.Some + { + FStarC_TypeChecker_Primops_Base.name = + uu___5; + FStarC_TypeChecker_Primops_Base.arity = + uu___6; + FStarC_TypeChecker_Primops_Base.univ_arity + = uu___7; + FStarC_TypeChecker_Primops_Base.auto_reflect + = FStar_Pervasives_Native.Some n; + FStarC_TypeChecker_Primops_Base.strong_reduction_ok + = uu___8; + FStarC_TypeChecker_Primops_Base.requires_binder_substitution + = uu___9; + FStarC_TypeChecker_Primops_Base.renorm_after + = uu___10; + FStarC_TypeChecker_Primops_Base.interpretation + = uu___11; + FStarC_TypeChecker_Primops_Base.interpretation_nbe + = uu___12;_} + when (FStarC_Compiler_List.length args) = n + -> norm cfg env2 stack' t + | uu___5 -> fallback " (3)" ()) + | uu___4 -> fallback " (4)" ())) + | uu___1 -> fallback " (2)" ()) + | (App (env2, head, aq, r))::stack2 -> + let t1 = FStarC_Syntax_Syntax.extend_app head (t, aq) r in + rebuild cfg env2 stack2 t1 + | (CBVApp (env', head, aq, r))::stack2 -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = fresh_memo () in + (env1, t, uu___5, false) in + Clos uu___4 in + (uu___3, aq, (t.FStarC_Syntax_Syntax.pos)) in + Arg uu___2 in + uu___1 :: stack2 in + norm cfg env' uu___ head + | (Match (env', asc_opt, branches1, lopt, cfg1, r))::stack2 -> + let lopt1 = + FStarC_Compiler_Util.map_option + (norm_residual_comp cfg1 env') lopt in + (FStarC_TypeChecker_Cfg.log cfg1 + (fun uu___1 -> + let uu___2 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.print1 + "Rebuilding with match, scrutinee is %s ...\n" uu___2); + (let scrutinee_env = env1 in + let env2 = env' in + let scrutinee = t in + let norm_and_rebuild_match uu___1 = + FStarC_TypeChecker_Cfg.log cfg1 + (fun uu___3 -> + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term scrutinee in + let uu___5 = + let uu___6 = + FStarC_Compiler_List.map + (fun uu___7 -> + match uu___7 with + | (p, uu___8, uu___9) -> + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_pat p) + branches1 in + FStarC_Compiler_String.concat "\n\t" uu___6 in + FStarC_Compiler_Util.print2 + "match is irreducible: scrutinee=%s\nbranches=%s\n" + uu___4 uu___5); + (let whnf = + (cfg1.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.weak + || + (cfg1.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.hnf in + let cfg_exclude_zeta = + if + (cfg1.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.zeta_full + then cfg1 + else + (let new_delta = + FStarC_Compiler_List.filter + (fun uu___4 -> + match uu___4 with + | FStarC_TypeChecker_Env.InliningDelta -> true + | FStarC_TypeChecker_Env.Eager_unfolding_only + -> true + | uu___5 -> false) + cfg1.FStarC_TypeChecker_Cfg.delta_level in + let steps = + let uu___4 = cfg1.FStarC_TypeChecker_Cfg.steps in + { + FStarC_TypeChecker_Cfg.beta = + (uu___4.FStarC_TypeChecker_Cfg.beta); + FStarC_TypeChecker_Cfg.iota = + (uu___4.FStarC_TypeChecker_Cfg.iota); + FStarC_TypeChecker_Cfg.zeta = false; + FStarC_TypeChecker_Cfg.zeta_full = + (uu___4.FStarC_TypeChecker_Cfg.zeta_full); + FStarC_TypeChecker_Cfg.weak = + (uu___4.FStarC_TypeChecker_Cfg.weak); + FStarC_TypeChecker_Cfg.hnf = + (uu___4.FStarC_TypeChecker_Cfg.hnf); + FStarC_TypeChecker_Cfg.primops = + (uu___4.FStarC_TypeChecker_Cfg.primops); + FStarC_TypeChecker_Cfg.do_not_unfold_pure_lets = + (uu___4.FStarC_TypeChecker_Cfg.do_not_unfold_pure_lets); + FStarC_TypeChecker_Cfg.unfold_until = + FStar_Pervasives_Native.None; + FStarC_TypeChecker_Cfg.unfold_only = + FStar_Pervasives_Native.None; + FStarC_TypeChecker_Cfg.unfold_fully = + (uu___4.FStarC_TypeChecker_Cfg.unfold_fully); + FStarC_TypeChecker_Cfg.unfold_attr = + FStar_Pervasives_Native.None; + FStarC_TypeChecker_Cfg.unfold_qual = + FStar_Pervasives_Native.None; + FStarC_TypeChecker_Cfg.unfold_namespace = + FStar_Pervasives_Native.None; + FStarC_TypeChecker_Cfg.dont_unfold_attr = + FStar_Pervasives_Native.None; + FStarC_TypeChecker_Cfg.pure_subterms_within_computations + = + (uu___4.FStarC_TypeChecker_Cfg.pure_subterms_within_computations); + FStarC_TypeChecker_Cfg.simplify = + (uu___4.FStarC_TypeChecker_Cfg.simplify); + FStarC_TypeChecker_Cfg.erase_universes = + (uu___4.FStarC_TypeChecker_Cfg.erase_universes); + FStarC_TypeChecker_Cfg.allow_unbound_universes = + (uu___4.FStarC_TypeChecker_Cfg.allow_unbound_universes); + FStarC_TypeChecker_Cfg.reify_ = + (uu___4.FStarC_TypeChecker_Cfg.reify_); + FStarC_TypeChecker_Cfg.compress_uvars = + (uu___4.FStarC_TypeChecker_Cfg.compress_uvars); + FStarC_TypeChecker_Cfg.no_full_norm = + (uu___4.FStarC_TypeChecker_Cfg.no_full_norm); + FStarC_TypeChecker_Cfg.check_no_uvars = + (uu___4.FStarC_TypeChecker_Cfg.check_no_uvars); + FStarC_TypeChecker_Cfg.unmeta = + (uu___4.FStarC_TypeChecker_Cfg.unmeta); + FStarC_TypeChecker_Cfg.unascribe = + (uu___4.FStarC_TypeChecker_Cfg.unascribe); + FStarC_TypeChecker_Cfg.in_full_norm_request = + (uu___4.FStarC_TypeChecker_Cfg.in_full_norm_request); + FStarC_TypeChecker_Cfg.weakly_reduce_scrutinee = + (uu___4.FStarC_TypeChecker_Cfg.weakly_reduce_scrutinee); + FStarC_TypeChecker_Cfg.nbe_step = + (uu___4.FStarC_TypeChecker_Cfg.nbe_step); + FStarC_TypeChecker_Cfg.for_extraction = + (uu___4.FStarC_TypeChecker_Cfg.for_extraction); + FStarC_TypeChecker_Cfg.unrefine = + (uu___4.FStarC_TypeChecker_Cfg.unrefine); + FStarC_TypeChecker_Cfg.default_univs_to_zero = + (uu___4.FStarC_TypeChecker_Cfg.default_univs_to_zero); + FStarC_TypeChecker_Cfg.tactics = + (uu___4.FStarC_TypeChecker_Cfg.tactics) + } in + { + FStarC_TypeChecker_Cfg.steps = steps; + FStarC_TypeChecker_Cfg.tcenv = + (cfg1.FStarC_TypeChecker_Cfg.tcenv); + FStarC_TypeChecker_Cfg.debug = + (cfg1.FStarC_TypeChecker_Cfg.debug); + FStarC_TypeChecker_Cfg.delta_level = new_delta; + FStarC_TypeChecker_Cfg.primitive_steps = + (cfg1.FStarC_TypeChecker_Cfg.primitive_steps); + FStarC_TypeChecker_Cfg.strong = true; + FStarC_TypeChecker_Cfg.memoize_lazy = + (cfg1.FStarC_TypeChecker_Cfg.memoize_lazy); + FStarC_TypeChecker_Cfg.normalize_pure_lets = + (cfg1.FStarC_TypeChecker_Cfg.normalize_pure_lets); + FStarC_TypeChecker_Cfg.reifying = + (cfg1.FStarC_TypeChecker_Cfg.reifying); + FStarC_TypeChecker_Cfg.compat_memo_ignore_cfg = + (cfg1.FStarC_TypeChecker_Cfg.compat_memo_ignore_cfg) + }) in + let norm_or_whnf env3 t1 = + if whnf + then closure_as_term cfg_exclude_zeta env3 t1 + else norm cfg_exclude_zeta env3 [] t1 in + let rec norm_pat env3 p = + match p.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_constant uu___3 -> (p, env3) + | FStarC_Syntax_Syntax.Pat_cons (fv, us_opt, pats) -> + let us_opt1 = + if + (cfg1.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.erase_universes + then FStar_Pervasives_Native.None + else + (match us_opt with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some us -> + let uu___4 = + FStarC_Compiler_List.map + (norm_universe cfg1 env3) us in + FStar_Pervasives_Native.Some uu___4) in + let uu___3 = + FStarC_Compiler_List.fold_left + (fun uu___4 -> + fun uu___5 -> + match (uu___4, uu___5) with + | ((pats1, env4), (p1, b)) -> + let uu___6 = norm_pat env4 p1 in + (match uu___6 with + | (p2, env5) -> + (((p2, b) :: pats1), env5))) + ([], env3) pats in + (match uu___3 with + | (pats1, env4) -> + ({ + FStarC_Syntax_Syntax.v = + (FStarC_Syntax_Syntax.Pat_cons + (fv, us_opt1, + (FStarC_Compiler_List.rev pats1))); + FStarC_Syntax_Syntax.p = + (p.FStarC_Syntax_Syntax.p) + }, env4)) + | FStarC_Syntax_Syntax.Pat_var x -> + let x1 = + let uu___3 = + norm_or_whnf env3 x.FStarC_Syntax_Syntax.sort in + { + FStarC_Syntax_Syntax.ppname = + (x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (x.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = uu___3 + } in + let uu___3 = let uu___4 = dummy () in uu___4 :: env3 in + ({ + FStarC_Syntax_Syntax.v = + (FStarC_Syntax_Syntax.Pat_var x1); + FStarC_Syntax_Syntax.p = + (p.FStarC_Syntax_Syntax.p) + }, uu___3) + | FStarC_Syntax_Syntax.Pat_dot_term eopt -> + let eopt1 = + FStarC_Compiler_Util.map_option + (norm_or_whnf env3) eopt in + ({ + FStarC_Syntax_Syntax.v = + (FStarC_Syntax_Syntax.Pat_dot_term eopt1); + FStarC_Syntax_Syntax.p = + (p.FStarC_Syntax_Syntax.p) + }, env3) in + let norm_branches uu___3 = + match env2 with + | [] when whnf -> branches1 + | uu___4 -> + FStarC_Compiler_List.map + (fun branch -> + let uu___5 = + FStarC_Syntax_Subst.open_branch branch in + match uu___5 with + | (p, wopt, e) -> + let uu___6 = norm_pat env2 p in + (match uu___6 with + | (p1, env3) -> + let wopt1 = + match wopt with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some w -> + let uu___7 = norm_or_whnf env3 w in + FStar_Pervasives_Native.Some + uu___7 in + let e1 = norm_or_whnf env3 e in + FStarC_Syntax_Util.branch + (p1, wopt1, e1))) branches1 in + let maybe_commute_matches uu___3 = + let can_commute = + match branches1 with + | ({ + FStarC_Syntax_Syntax.v = + FStarC_Syntax_Syntax.Pat_cons + (fv, uu___4, uu___5); + FStarC_Syntax_Syntax.p = uu___6;_}, + uu___7, uu___8)::uu___9 -> + FStarC_TypeChecker_Env.fv_has_attr + cfg1.FStarC_TypeChecker_Cfg.tcenv fv + FStarC_Parser_Const.commute_nested_matches_lid + | uu___4 -> false in + let uu___4 = + let uu___5 = FStarC_Syntax_Util.unascribe scrutinee in + uu___5.FStarC_Syntax_Syntax.n in + match uu___4 with + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = sc0; + FStarC_Syntax_Syntax.ret_opt = asc_opt0; + FStarC_Syntax_Syntax.brs = branches0; + FStarC_Syntax_Syntax.rc_opt1 = lopt0;_} + when can_commute -> + let reduce_branch b = + let stack3 = + [Match + (env', asc_opt, branches1, lopt1, cfg1, r)] in + let uu___5 = FStarC_Syntax_Subst.open_branch b in + match uu___5 with + | (p, wopt, e) -> + let uu___6 = norm_pat scrutinee_env p in + (match uu___6 with + | (p1, branch_env) -> + let wopt1 = + match wopt with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some w -> + let uu___7 = + norm_or_whnf branch_env w in + FStar_Pervasives_Native.Some uu___7 in + let e1 = norm cfg1 branch_env stack3 e in + FStarC_Syntax_Util.branch (p1, wopt1, e1)) in + let branches01 = + FStarC_Compiler_List.map reduce_branch branches0 in + let uu___5 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_match + { + FStarC_Syntax_Syntax.scrutinee = sc0; + FStarC_Syntax_Syntax.ret_opt = asc_opt0; + FStarC_Syntax_Syntax.brs = branches01; + FStarC_Syntax_Syntax.rc_opt1 = lopt0 + }) r in + rebuild cfg1 env2 stack2 uu___5 + | uu___5 -> + let scrutinee1 = + let uu___6 = + ((((cfg1.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.iota + && + (Prims.op_Negation + (cfg1.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.weak)) + && + (Prims.op_Negation + (cfg1.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.compress_uvars)) + && + (cfg1.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.weakly_reduce_scrutinee) + && (maybe_weakly_reduced scrutinee) in + if uu___6 + then + norm + { + FStarC_TypeChecker_Cfg.steps = + (let uu___7 = + cfg1.FStarC_TypeChecker_Cfg.steps in + { + FStarC_TypeChecker_Cfg.beta = + (uu___7.FStarC_TypeChecker_Cfg.beta); + FStarC_TypeChecker_Cfg.iota = + (uu___7.FStarC_TypeChecker_Cfg.iota); + FStarC_TypeChecker_Cfg.zeta = + (uu___7.FStarC_TypeChecker_Cfg.zeta); + FStarC_TypeChecker_Cfg.zeta_full = + (uu___7.FStarC_TypeChecker_Cfg.zeta_full); + FStarC_TypeChecker_Cfg.weak = + (uu___7.FStarC_TypeChecker_Cfg.weak); + FStarC_TypeChecker_Cfg.hnf = + (uu___7.FStarC_TypeChecker_Cfg.hnf); + FStarC_TypeChecker_Cfg.primops = + (uu___7.FStarC_TypeChecker_Cfg.primops); + FStarC_TypeChecker_Cfg.do_not_unfold_pure_lets + = + (uu___7.FStarC_TypeChecker_Cfg.do_not_unfold_pure_lets); + FStarC_TypeChecker_Cfg.unfold_until = + (uu___7.FStarC_TypeChecker_Cfg.unfold_until); + FStarC_TypeChecker_Cfg.unfold_only = + (uu___7.FStarC_TypeChecker_Cfg.unfold_only); + FStarC_TypeChecker_Cfg.unfold_fully = + (uu___7.FStarC_TypeChecker_Cfg.unfold_fully); + FStarC_TypeChecker_Cfg.unfold_attr = + (uu___7.FStarC_TypeChecker_Cfg.unfold_attr); + FStarC_TypeChecker_Cfg.unfold_qual = + (uu___7.FStarC_TypeChecker_Cfg.unfold_qual); + FStarC_TypeChecker_Cfg.unfold_namespace + = + (uu___7.FStarC_TypeChecker_Cfg.unfold_namespace); + FStarC_TypeChecker_Cfg.dont_unfold_attr + = + (uu___7.FStarC_TypeChecker_Cfg.dont_unfold_attr); + FStarC_TypeChecker_Cfg.pure_subterms_within_computations + = + (uu___7.FStarC_TypeChecker_Cfg.pure_subterms_within_computations); + FStarC_TypeChecker_Cfg.simplify = + (uu___7.FStarC_TypeChecker_Cfg.simplify); + FStarC_TypeChecker_Cfg.erase_universes + = + (uu___7.FStarC_TypeChecker_Cfg.erase_universes); + FStarC_TypeChecker_Cfg.allow_unbound_universes + = + (uu___7.FStarC_TypeChecker_Cfg.allow_unbound_universes); + FStarC_TypeChecker_Cfg.reify_ = + (uu___7.FStarC_TypeChecker_Cfg.reify_); + FStarC_TypeChecker_Cfg.compress_uvars = + (uu___7.FStarC_TypeChecker_Cfg.compress_uvars); + FStarC_TypeChecker_Cfg.no_full_norm = + (uu___7.FStarC_TypeChecker_Cfg.no_full_norm); + FStarC_TypeChecker_Cfg.check_no_uvars = + (uu___7.FStarC_TypeChecker_Cfg.check_no_uvars); + FStarC_TypeChecker_Cfg.unmeta = + (uu___7.FStarC_TypeChecker_Cfg.unmeta); + FStarC_TypeChecker_Cfg.unascribe = + (uu___7.FStarC_TypeChecker_Cfg.unascribe); + FStarC_TypeChecker_Cfg.in_full_norm_request + = + (uu___7.FStarC_TypeChecker_Cfg.in_full_norm_request); + FStarC_TypeChecker_Cfg.weakly_reduce_scrutinee + = false; + FStarC_TypeChecker_Cfg.nbe_step = + (uu___7.FStarC_TypeChecker_Cfg.nbe_step); + FStarC_TypeChecker_Cfg.for_extraction = + (uu___7.FStarC_TypeChecker_Cfg.for_extraction); + FStarC_TypeChecker_Cfg.unrefine = + (uu___7.FStarC_TypeChecker_Cfg.unrefine); + FStarC_TypeChecker_Cfg.default_univs_to_zero + = + (uu___7.FStarC_TypeChecker_Cfg.default_univs_to_zero); + FStarC_TypeChecker_Cfg.tactics = + (uu___7.FStarC_TypeChecker_Cfg.tactics) + }); + FStarC_TypeChecker_Cfg.tcenv = + (cfg1.FStarC_TypeChecker_Cfg.tcenv); + FStarC_TypeChecker_Cfg.debug = + (cfg1.FStarC_TypeChecker_Cfg.debug); + FStarC_TypeChecker_Cfg.delta_level = + (cfg1.FStarC_TypeChecker_Cfg.delta_level); + FStarC_TypeChecker_Cfg.primitive_steps = + (cfg1.FStarC_TypeChecker_Cfg.primitive_steps); + FStarC_TypeChecker_Cfg.strong = + (cfg1.FStarC_TypeChecker_Cfg.strong); + FStarC_TypeChecker_Cfg.memoize_lazy = + (cfg1.FStarC_TypeChecker_Cfg.memoize_lazy); + FStarC_TypeChecker_Cfg.normalize_pure_lets = + (cfg1.FStarC_TypeChecker_Cfg.normalize_pure_lets); + FStarC_TypeChecker_Cfg.reifying = + (cfg1.FStarC_TypeChecker_Cfg.reifying); + FStarC_TypeChecker_Cfg.compat_memo_ignore_cfg + = + (cfg1.FStarC_TypeChecker_Cfg.compat_memo_ignore_cfg) + } scrutinee_env [] scrutinee + else scrutinee in + let asc_opt1 = norm_match_returns cfg1 env2 asc_opt in + let branches2 = norm_branches () in + let uu___6 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_match + { + FStarC_Syntax_Syntax.scrutinee = scrutinee1; + FStarC_Syntax_Syntax.ret_opt = asc_opt1; + FStarC_Syntax_Syntax.brs = branches2; + FStarC_Syntax_Syntax.rc_opt1 = lopt1 + }) r in + rebuild cfg1 env2 stack2 uu___6 in + maybe_commute_matches ()) in + let rec is_cons head = + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress head in + uu___2.FStarC_Syntax_Syntax.n in + match uu___1 with + | FStarC_Syntax_Syntax.Tm_uinst (h, uu___2) -> is_cons h + | FStarC_Syntax_Syntax.Tm_constant uu___2 -> true + | FStarC_Syntax_Syntax.Tm_fvar + { FStarC_Syntax_Syntax.fv_name = uu___2; + FStarC_Syntax_Syntax.fv_qual = + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Data_ctor);_} + -> true + | FStarC_Syntax_Syntax.Tm_fvar + { FStarC_Syntax_Syntax.fv_name = uu___2; + FStarC_Syntax_Syntax.fv_qual = + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Record_ctor uu___3);_} + -> true + | uu___2 -> false in + let guard_when_clause wopt b rest = + match wopt with + | FStar_Pervasives_Native.None -> b + | FStar_Pervasives_Native.Some w -> + let then_branch = b in + let else_branch = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_match + { + FStarC_Syntax_Syntax.scrutinee = scrutinee; + FStarC_Syntax_Syntax.ret_opt = asc_opt; + FStarC_Syntax_Syntax.brs = rest; + FStarC_Syntax_Syntax.rc_opt1 = lopt1 + }) r in + FStarC_Syntax_Util.if_then_else w then_branch + else_branch in + let rec matches_pat scrutinee_orig p = + let scrutinee1 = FStarC_Syntax_Util.unmeta scrutinee_orig in + let scrutinee2 = FStarC_Syntax_Util.unlazy scrutinee1 in + let uu___1 = FStarC_Syntax_Util.head_and_args scrutinee2 in + match uu___1 with + | (head, args) -> + (match p.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_var bv -> + FStar_Pervasives.Inl [(bv, scrutinee_orig)] + | FStarC_Syntax_Syntax.Pat_dot_term uu___2 -> + FStar_Pervasives.Inl [] + | FStarC_Syntax_Syntax.Pat_constant s -> + (match scrutinee2.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_constant s' when + FStarC_Const.eq_const s s' -> + FStar_Pervasives.Inl [] + | uu___2 -> + let uu___3 = + let uu___4 = is_cons head in + Prims.op_Negation uu___4 in + FStar_Pervasives.Inr uu___3) + | FStarC_Syntax_Syntax.Pat_cons (fv, uu___2, arg_pats) + -> + let uu___3 = + let uu___4 = FStarC_Syntax_Util.un_uinst head in + uu___4.FStarC_Syntax_Syntax.n in + (match uu___3 with + | FStarC_Syntax_Syntax.Tm_fvar fv' when + FStarC_Syntax_Syntax.fv_eq fv fv' -> + matches_args [] args arg_pats + | uu___4 -> + let uu___5 = + let uu___6 = is_cons head in + Prims.op_Negation uu___6 in + FStar_Pervasives.Inr uu___5)) + and matches_args out a p = + match (a, p) with + | ([], []) -> FStar_Pervasives.Inl out + | ((t1, uu___1)::rest_a, (p1, uu___2)::rest_p) -> + let uu___3 = matches_pat t1 p1 in + (match uu___3 with + | FStar_Pervasives.Inl s -> + matches_args (FStarC_Compiler_List.op_At out s) + rest_a rest_p + | m -> m) + | uu___1 -> FStar_Pervasives.Inr false in + let rec matches scrutinee1 p = + match p with + | [] -> norm_and_rebuild_match () + | (p1, wopt, b)::rest -> + let uu___1 = matches_pat scrutinee1 p1 in + (match uu___1 with + | FStar_Pervasives.Inr (false) -> + matches scrutinee1 rest + | FStar_Pervasives.Inr (true) -> + norm_and_rebuild_match () + | FStar_Pervasives.Inl s -> + (FStarC_TypeChecker_Cfg.log cfg1 + (fun uu___3 -> + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_pat p1 in + let uu___5 = + let uu___6 = + FStarC_Compiler_List.map + (fun uu___7 -> + match uu___7 with + | (uu___8, t1) -> + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t1) s in + FStarC_Compiler_String.concat "; " uu___6 in + FStarC_Compiler_Util.print2 + "Matches pattern %s with subst = %s\n" + uu___4 uu___5); + (let env0 = env2 in + let env3 = + FStarC_Compiler_List.fold_left + (fun env4 -> + fun uu___3 -> + match uu___3 with + | (bv, t1) -> + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.mk_binder + bv in + FStar_Pervasives_Native.Some + uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Compiler_Util.mk_ref + (if + (cfg1.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.hnf + then + FStar_Pervasives_Native.None + else + FStar_Pervasives_Native.Some + (cfg1, ([], t1))) in + ([], t1, uu___8, false) in + Clos uu___7 in + let uu___7 = fresh_memo () in + (uu___5, uu___6, uu___7) in + uu___4 :: env4) env2 s in + let uu___3 = guard_when_clause wopt b rest in + norm cfg1 env3 stack2 uu___3))) in + if + (cfg1.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.iota + then matches scrutinee branches1 + else norm_and_rebuild_match ())) +and (norm_match_returns : + FStarC_TypeChecker_Cfg.cfg -> + env -> + FStarC_Syntax_Syntax.match_returns_ascription + FStar_Pervasives_Native.option -> + (FStarC_Syntax_Syntax.binder * + ((FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax, + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax) + FStar_Pervasives.either * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax FStar_Pervasives_Native.option * + Prims.bool)) FStar_Pervasives_Native.option) + = + fun cfg -> + fun env1 -> + fun ret_opt -> + match ret_opt with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (b, asc) -> + let b1 = norm_binder cfg env1 b in + let uu___ = FStarC_Syntax_Subst.open_ascription [b1] asc in + (match uu___ with + | (subst, asc1) -> + let asc2 = + let uu___1 = let uu___2 = dummy () in uu___2 :: env1 in + norm_ascription cfg uu___1 asc1 in + let uu___1 = + let uu___2 = + FStarC_Syntax_Subst.close_ascription subst asc2 in + (b1, uu___2) in + FStar_Pervasives_Native.Some uu___1) +and (norm_ascription : + FStarC_TypeChecker_Cfg.cfg -> + env -> + ((FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax, + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax) + FStar_Pervasives.either * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax FStar_Pervasives_Native.option * + Prims.bool) -> + ((FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax, + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax) + FStar_Pervasives.either * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax FStar_Pervasives_Native.option * + Prims.bool)) + = + fun cfg -> + fun env1 -> + fun uu___ -> + match uu___ with + | (tc, tacopt, use_eq) -> + let uu___1 = + match tc with + | FStar_Pervasives.Inl t -> + let uu___2 = norm cfg env1 [] t in + FStar_Pervasives.Inl uu___2 + | FStar_Pervasives.Inr c -> + let uu___2 = norm_comp cfg env1 c in + FStar_Pervasives.Inr uu___2 in + let uu___2 = + FStarC_Compiler_Util.map_opt tacopt (norm cfg env1 []) in + (uu___1, uu___2, use_eq) +and (norm_residual_comp : + FStarC_TypeChecker_Cfg.cfg -> + env -> + FStarC_Syntax_Syntax.residual_comp -> + FStarC_Syntax_Syntax.residual_comp) + = + fun cfg -> + fun env1 -> + fun rc -> + let uu___ = + FStarC_Compiler_Util.map_option (closure_as_term cfg env1) + rc.FStarC_Syntax_Syntax.residual_typ in + { + FStarC_Syntax_Syntax.residual_effect = + (rc.FStarC_Syntax_Syntax.residual_effect); + FStarC_Syntax_Syntax.residual_typ = uu___; + FStarC_Syntax_Syntax.residual_flags = + (rc.FStarC_Syntax_Syntax.residual_flags) + } +let (reflection_env_hook : + FStarC_TypeChecker_Env.env FStar_Pervasives_Native.option + FStarC_Compiler_Effect.ref) + = FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None +let (normalize_with_primitive_steps : + FStarC_TypeChecker_Primops_Base.primitive_step Prims.list -> + FStarC_TypeChecker_Env.steps -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun ps -> + fun s -> + fun e -> + fun t -> + let is_nbe = is_nbe_request s in + let maybe_nbe = if is_nbe then " (NBE)" else "" in + FStarC_Errors.with_ctx + (Prims.strcat "While normalizing a term" maybe_nbe) + (fun uu___ -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_TypeChecker_Env.current_module e in + FStarC_Ident.string_of_lid uu___3 in + FStar_Pervasives_Native.Some uu___2 in + FStarC_Profiling.profile + (fun uu___2 -> + let c = FStarC_TypeChecker_Cfg.config' ps s e in + FStarC_Compiler_Effect.op_Colon_Equals + reflection_env_hook (FStar_Pervasives_Native.Some e); + FStarC_Compiler_Effect.op_Colon_Equals + FStarC_TypeChecker_Normalize_Unfolding.plugin_unfold_warn_ctr + (Prims.of_int (10)); + FStarC_TypeChecker_Cfg.log_top c + (fun uu___6 -> + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.print2 + "\nStarting normalizer%s for (%s) {\n" maybe_nbe + uu___7); + FStarC_TypeChecker_Cfg.log_top c + (fun uu___7 -> + let uu___8 = + FStarC_Class_Show.show + FStarC_TypeChecker_Cfg.showable_cfg c in + FStarC_Compiler_Util.print1 ">>> cfg = %s\n" uu___8); + FStarC_Defensive.def_check_scoped + FStarC_TypeChecker_Env.hasBinders_env + FStarC_Class_Binders.hasNames_term + FStarC_Syntax_Print.pretty_term + t.FStarC_Syntax_Syntax.pos + "normalize_with_primitive_steps call" e t; + (let uu___8 = + FStarC_Compiler_Util.record_time + (fun uu___9 -> + if is_nbe then nbe_eval c s t else norm c [] [] t) in + match uu___8 with + | (r, ms) -> + (FStarC_TypeChecker_Cfg.log_top c + (fun uu___10 -> + let uu___11 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term r in + let uu___12 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) ms in + FStarC_Compiler_Util.print3 + "}\nNormalization%s result = (%s) in %s ms\n" + maybe_nbe uu___11 uu___12); + r))) uu___1 + "FStarC.TypeChecker.Normalize.normalize_with_primitive_steps") +let (normalize : + FStarC_TypeChecker_Env.steps -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun s -> + fun e -> + fun t -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_Env.current_module e in + FStarC_Ident.string_of_lid uu___2 in + FStar_Pervasives_Native.Some uu___1 in + FStarC_Profiling.profile + (fun uu___1 -> normalize_with_primitive_steps [] s e t) uu___ + "FStarC.TypeChecker.Normalize.normalize" +let (normalize_comp : + FStarC_TypeChecker_Env.steps -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.comp -> FStarC_Syntax_Syntax.comp) + = + fun s -> + fun e -> + fun c -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_Env.current_module e in + FStarC_Ident.string_of_lid uu___2 in + FStar_Pervasives_Native.Some uu___1 in + FStarC_Profiling.profile + (fun uu___1 -> + let cfg = FStarC_TypeChecker_Cfg.config s e in + FStarC_Compiler_Effect.op_Colon_Equals reflection_env_hook + (FStar_Pervasives_Native.Some e); + FStarC_Compiler_Effect.op_Colon_Equals + FStarC_TypeChecker_Normalize_Unfolding.plugin_unfold_warn_ctr + (Prims.of_int (10)); + FStarC_TypeChecker_Cfg.log_top cfg + (fun uu___5 -> + let uu___6 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_comp + c in + FStarC_Compiler_Util.print1 + "Starting normalizer for computation (%s) {\n" uu___6); + FStarC_TypeChecker_Cfg.log_top cfg + (fun uu___6 -> + let uu___7 = + FStarC_Class_Show.show + FStarC_TypeChecker_Cfg.showable_cfg cfg in + FStarC_Compiler_Util.print1 ">>> cfg = %s\n" uu___7); + FStarC_Defensive.def_check_scoped + FStarC_TypeChecker_Env.hasBinders_env + FStarC_Class_Binders.hasNames_comp + FStarC_Syntax_Print.pretty_comp c.FStarC_Syntax_Syntax.pos + "normalize_comp call" e c; + (let uu___7 = + FStarC_Errors.with_ctx "While normalizing a computation type" + (fun uu___8 -> + FStarC_Compiler_Util.record_time + (fun uu___9 -> norm_comp cfg [] c)) in + match uu___7 with + | (c1, ms) -> + (FStarC_TypeChecker_Cfg.log_top cfg + (fun uu___9 -> + let uu___10 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_comp c1 in + let uu___11 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) ms in + FStarC_Compiler_Util.print2 + "}\nNormalization result = (%s) in %s ms\n" uu___10 + uu___11); + c1))) uu___ "FStarC.TypeChecker.Normalize.normalize_comp" +let (normalize_universe : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.universe -> FStarC_Syntax_Syntax.universe) + = + fun env1 -> + fun u -> + FStarC_Errors.with_ctx "While normalizing a universe level" + (fun uu___ -> + let uu___1 = FStarC_TypeChecker_Cfg.config [] env1 in + norm_universe uu___1 [] u) +let (non_info_norm : + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.term -> Prims.bool) = + fun env1 -> + fun t -> + let steps = + [FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.AllowUnboundUniverses; + FStarC_TypeChecker_Env.EraseUniverses; + FStarC_TypeChecker_Env.HNF; + FStarC_TypeChecker_Env.Unascribe; + FStarC_TypeChecker_Env.ForExtraction] in + let uu___ = normalize steps env1 t in + FStarC_TypeChecker_Env.non_informative env1 uu___ +let (maybe_promote_t : + FStarC_TypeChecker_Env.env -> + Prims.bool -> FStarC_Syntax_Syntax.term -> Prims.bool) + = + fun env1 -> + fun non_informative_only -> + fun t -> + (Prims.op_Negation non_informative_only) || (non_info_norm env1 t) +let (ghost_to_pure_aux : + FStarC_TypeChecker_Env.env -> + Prims.bool -> + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax) + = + fun env1 -> + fun non_informative_only -> + fun c -> + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total uu___ -> c + | FStarC_Syntax_Syntax.GTotal t -> + let uu___ = maybe_promote_t env1 non_informative_only t in + if uu___ + then + { + FStarC_Syntax_Syntax.n = (FStarC_Syntax_Syntax.Total t); + FStarC_Syntax_Syntax.pos = (c.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = (c.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (c.FStarC_Syntax_Syntax.hash_code) + } + else c + | FStarC_Syntax_Syntax.Comp ct -> + let l = + FStarC_TypeChecker_Env.norm_eff_name env1 + ct.FStarC_Syntax_Syntax.effect_name in + let uu___ = + (FStarC_Syntax_Util.is_ghost_effect l) && + (maybe_promote_t env1 non_informative_only + ct.FStarC_Syntax_Syntax.result_typ) in + if uu___ + then + let ct1 = + let uu___1 = + downgrade_ghost_effect_name + ct.FStarC_Syntax_Syntax.effect_name in + match uu___1 with + | FStar_Pervasives_Native.Some pure_eff -> + let flags = + let uu___2 = + FStarC_Ident.lid_equals pure_eff + FStarC_Parser_Const.effect_Tot_lid in + if uu___2 + then FStarC_Syntax_Syntax.TOTAL :: + (ct.FStarC_Syntax_Syntax.flags) + else ct.FStarC_Syntax_Syntax.flags in + { + FStarC_Syntax_Syntax.comp_univs = + (ct.FStarC_Syntax_Syntax.comp_univs); + FStarC_Syntax_Syntax.effect_name = pure_eff; + FStarC_Syntax_Syntax.result_typ = + (ct.FStarC_Syntax_Syntax.result_typ); + FStarC_Syntax_Syntax.effect_args = + (ct.FStarC_Syntax_Syntax.effect_args); + FStarC_Syntax_Syntax.flags = flags + } + | FStar_Pervasives_Native.None -> + let ct2 = + FStarC_TypeChecker_Env.unfold_effect_abbrev env1 c in + { + FStarC_Syntax_Syntax.comp_univs = + (ct2.FStarC_Syntax_Syntax.comp_univs); + FStarC_Syntax_Syntax.effect_name = + FStarC_Parser_Const.effect_PURE_lid; + FStarC_Syntax_Syntax.result_typ = + (ct2.FStarC_Syntax_Syntax.result_typ); + FStarC_Syntax_Syntax.effect_args = + (ct2.FStarC_Syntax_Syntax.effect_args); + FStarC_Syntax_Syntax.flags = + (ct2.FStarC_Syntax_Syntax.flags) + } in + { + FStarC_Syntax_Syntax.n = (FStarC_Syntax_Syntax.Comp ct1); + FStarC_Syntax_Syntax.pos = (c.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = (c.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (c.FStarC_Syntax_Syntax.hash_code) + } + else c + | uu___ -> c +let (ghost_to_pure_lcomp_aux : + FStarC_TypeChecker_Env.env -> + Prims.bool -> + FStarC_TypeChecker_Common.lcomp -> FStarC_TypeChecker_Common.lcomp) + = + fun env1 -> + fun non_informative_only -> + fun lc -> + let uu___ = + (FStarC_Syntax_Util.is_ghost_effect + lc.FStarC_TypeChecker_Common.eff_name) + && + (maybe_promote_t env1 non_informative_only + lc.FStarC_TypeChecker_Common.res_typ) in + if uu___ + then + let uu___1 = + downgrade_ghost_effect_name lc.FStarC_TypeChecker_Common.eff_name in + match uu___1 with + | FStar_Pervasives_Native.Some pure_eff -> + let uu___2 = + FStarC_TypeChecker_Common.apply_lcomp + (ghost_to_pure_aux env1 non_informative_only) (fun g -> g) + lc in + { + FStarC_TypeChecker_Common.eff_name = pure_eff; + FStarC_TypeChecker_Common.res_typ = + (uu___2.FStarC_TypeChecker_Common.res_typ); + FStarC_TypeChecker_Common.cflags = + (uu___2.FStarC_TypeChecker_Common.cflags); + FStarC_TypeChecker_Common.comp_thunk = + (uu___2.FStarC_TypeChecker_Common.comp_thunk) + } + | FStar_Pervasives_Native.None -> lc + else lc +let (maybe_ghost_to_pure : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.comp -> FStarC_Syntax_Syntax.comp) + = fun env1 -> fun c -> ghost_to_pure_aux env1 true c +let (maybe_ghost_to_pure_lcomp : + FStarC_TypeChecker_Env.env -> + FStarC_TypeChecker_Common.lcomp -> FStarC_TypeChecker_Common.lcomp) + = fun env1 -> fun lc -> ghost_to_pure_lcomp_aux env1 true lc +let (ghost_to_pure : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax) + = fun env1 -> fun c -> ghost_to_pure_aux env1 false c +let (ghost_to_pure_lcomp : + FStarC_TypeChecker_Env.env -> + FStarC_TypeChecker_Common.lcomp -> FStarC_TypeChecker_Common.lcomp) + = fun env1 -> fun lc -> ghost_to_pure_lcomp_aux env1 false lc +let (ghost_to_pure2 : + FStarC_TypeChecker_Env.env -> + (FStarC_Syntax_Syntax.comp * FStarC_Syntax_Syntax.comp) -> + (FStarC_Syntax_Syntax.comp * FStarC_Syntax_Syntax.comp)) + = + fun env1 -> + fun uu___ -> + match uu___ with + | (c1, c2) -> + let uu___1 = + let uu___2 = maybe_ghost_to_pure env1 c1 in + let uu___3 = maybe_ghost_to_pure env1 c2 in (uu___2, uu___3) in + (match uu___1 with + | (c11, c21) -> + let c1_eff = + FStarC_TypeChecker_Env.norm_eff_name env1 + (FStarC_Syntax_Util.comp_effect_name c11) in + let c2_eff = + FStarC_TypeChecker_Env.norm_eff_name env1 + (FStarC_Syntax_Util.comp_effect_name c21) in + let uu___2 = FStarC_Ident.lid_equals c1_eff c2_eff in + if uu___2 + then (c11, c21) + else + (let c1_erasable = + FStarC_TypeChecker_Env.is_erasable_effect env1 c1_eff in + let c2_erasable = + FStarC_TypeChecker_Env.is_erasable_effect env1 c2_eff in + let uu___4 = + c1_erasable && + (FStarC_Ident.lid_equals c2_eff + FStarC_Parser_Const.effect_GHOST_lid) in + if uu___4 + then let uu___5 = ghost_to_pure env1 c21 in (c11, uu___5) + else + (let uu___6 = + c2_erasable && + (FStarC_Ident.lid_equals c1_eff + FStarC_Parser_Const.effect_GHOST_lid) in + if uu___6 + then + let uu___7 = ghost_to_pure env1 c11 in (uu___7, c21) + else (c11, c21)))) +let (ghost_to_pure_lcomp2 : + FStarC_TypeChecker_Env.env -> + (FStarC_TypeChecker_Common.lcomp * FStarC_TypeChecker_Common.lcomp) -> + (FStarC_TypeChecker_Common.lcomp * FStarC_TypeChecker_Common.lcomp)) + = + fun env1 -> + fun uu___ -> + match uu___ with + | (lc1, lc2) -> + let uu___1 = + let uu___2 = maybe_ghost_to_pure_lcomp env1 lc1 in + let uu___3 = maybe_ghost_to_pure_lcomp env1 lc2 in + (uu___2, uu___3) in + (match uu___1 with + | (lc11, lc21) -> + let lc1_eff = + FStarC_TypeChecker_Env.norm_eff_name env1 + lc11.FStarC_TypeChecker_Common.eff_name in + let lc2_eff = + FStarC_TypeChecker_Env.norm_eff_name env1 + lc21.FStarC_TypeChecker_Common.eff_name in + let uu___2 = FStarC_Ident.lid_equals lc1_eff lc2_eff in + if uu___2 + then (lc11, lc21) + else + (let lc1_erasable = + FStarC_TypeChecker_Env.is_erasable_effect env1 lc1_eff in + let lc2_erasable = + FStarC_TypeChecker_Env.is_erasable_effect env1 lc2_eff in + let uu___4 = + lc1_erasable && + (FStarC_Ident.lid_equals lc2_eff + FStarC_Parser_Const.effect_GHOST_lid) in + if uu___4 + then + let uu___5 = ghost_to_pure_lcomp env1 lc21 in + (lc11, uu___5) + else + (let uu___6 = + lc2_erasable && + (FStarC_Ident.lid_equals lc1_eff + FStarC_Parser_Const.effect_GHOST_lid) in + if uu___6 + then + let uu___7 = ghost_to_pure_lcomp env1 lc11 in + (uu___7, lc21) + else (lc11, lc21)))) +let (warn_norm_failure : + FStarC_Compiler_Range_Type.range -> Prims.exn -> unit) = + fun r -> + fun e -> + let uu___ = + let uu___1 = FStarC_Compiler_Util.message_of_exn e in + FStarC_Compiler_Util.format1 "Normalization failed with error %s\n" + uu___1 in + FStarC_Errors.log_issue FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Warning_NormalizationFailure () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___) +let (term_to_doc : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Pprint.document) + = + fun env1 -> + fun t -> + let t1 = + try + (fun uu___ -> + match () with + | () -> + normalize [FStarC_TypeChecker_Env.AllowUnboundUniverses] + env1 t) () + with + | uu___ -> (warn_norm_failure t.FStarC_Syntax_Syntax.pos uu___; t) in + let uu___ = + FStarC_Syntax_DsEnv.set_current_module + env1.FStarC_TypeChecker_Env.dsenv + env1.FStarC_TypeChecker_Env.curmodule in + FStarC_Syntax_Print.term_to_doc' uu___ t1 +let (term_to_string : + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.term -> Prims.string) = + fun env1 -> + fun t -> + FStarC_GenSym.with_frozen_gensym + (fun uu___ -> + let t1 = + try + (fun uu___1 -> + match () with + | () -> + normalize + [FStarC_TypeChecker_Env.AllowUnboundUniverses] env1 t) + () + with + | uu___1 -> + (warn_norm_failure t.FStarC_Syntax_Syntax.pos uu___1; t) in + let uu___1 = + FStarC_Syntax_DsEnv.set_current_module + env1.FStarC_TypeChecker_Env.dsenv + env1.FStarC_TypeChecker_Env.curmodule in + FStarC_Syntax_Print.term_to_string' uu___1 t1) +let (comp_to_string : + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.comp -> Prims.string) = + fun env1 -> + fun c -> + FStarC_GenSym.with_frozen_gensym + (fun uu___ -> + let c1 = + try + (fun uu___1 -> + match () with + | () -> + let uu___2 = + FStarC_TypeChecker_Cfg.config + [FStarC_TypeChecker_Env.AllowUnboundUniverses] env1 in + norm_comp uu___2 [] c) () + with + | uu___1 -> + (warn_norm_failure c.FStarC_Syntax_Syntax.pos uu___1; c) in + let uu___1 = + FStarC_Syntax_DsEnv.set_current_module + env1.FStarC_TypeChecker_Env.dsenv + env1.FStarC_TypeChecker_Env.curmodule in + FStarC_Syntax_Print.comp_to_string' uu___1 c1) +let (comp_to_doc : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.comp -> FStarC_Pprint.document) + = + fun env1 -> + fun c -> + FStarC_GenSym.with_frozen_gensym + (fun uu___ -> + let c1 = + try + (fun uu___1 -> + match () with + | () -> + let uu___2 = + FStarC_TypeChecker_Cfg.config + [FStarC_TypeChecker_Env.AllowUnboundUniverses] env1 in + norm_comp uu___2 [] c) () + with + | uu___1 -> + (warn_norm_failure c.FStarC_Syntax_Syntax.pos uu___1; c) in + let uu___1 = + FStarC_Syntax_DsEnv.set_current_module + env1.FStarC_TypeChecker_Env.dsenv + env1.FStarC_TypeChecker_Env.curmodule in + FStarC_Syntax_Print.comp_to_doc' uu___1 c1) +let (normalize_refinement : + FStarC_TypeChecker_Env.steps -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.typ) + = + fun steps -> + fun env1 -> + fun t0 -> + let t = + normalize + (FStarC_Compiler_List.op_At steps [FStarC_TypeChecker_Env.Beta]) + env1 t0 in + FStarC_Syntax_Util.flatten_refinement t +let (whnf_steps : FStarC_TypeChecker_Env.step Prims.list) = + [FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.Weak; + FStarC_TypeChecker_Env.HNF; + FStarC_TypeChecker_Env.UnfoldUntil FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.Beta] +let (unfold_whnf' : + FStarC_TypeChecker_Env.steps -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun steps -> + fun env1 -> + fun t -> normalize (FStarC_Compiler_List.op_At steps whnf_steps) env1 t +let (unfold_whnf : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = fun env1 -> fun t -> unfold_whnf' [] env1 t +let (reduce_or_remove_uvar_solutions : + Prims.bool -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun remove -> + fun env1 -> + fun t -> + normalize + (FStarC_Compiler_List.op_At + (if remove + then + [FStarC_TypeChecker_Env.DefaultUnivsToZero; + FStarC_TypeChecker_Env.CheckNoUvars] + else []) + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.DoNotUnfoldPureLets; + FStarC_TypeChecker_Env.CompressUvars; + FStarC_TypeChecker_Env.Exclude FStarC_TypeChecker_Env.Zeta; + FStarC_TypeChecker_Env.Exclude FStarC_TypeChecker_Env.Iota; + FStarC_TypeChecker_Env.NoFullNorm]) env1 t +let (reduce_uvar_solutions : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = fun env1 -> fun t -> reduce_or_remove_uvar_solutions false env1 t +let (remove_uvar_solutions : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = fun env1 -> fun t -> reduce_or_remove_uvar_solutions true env1 t +let (eta_expand_with_type : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.term) + = + fun env1 -> + fun e -> + fun t_e -> + let uu___ = FStarC_Syntax_Util.arrow_formals_comp t_e in + match uu___ with + | (formals, c) -> + (match formals with + | [] -> e + | uu___1 -> + let uu___2 = FStarC_Syntax_Util.abs_formals e in + (match uu___2 with + | (actuals, uu___3, uu___4) -> + if + (FStarC_Compiler_List.length actuals) = + (FStarC_Compiler_List.length formals) + then e + else + (let uu___6 = + FStarC_Syntax_Util.args_of_binders formals in + match uu___6 with + | (binders, args) -> + let uu___7 = + FStarC_Syntax_Syntax.mk_Tm_app e args + e.FStarC_Syntax_Syntax.pos in + let uu___8 = + let uu___9 = + FStarC_Syntax_Util.residual_comp_of_comp c in + FStar_Pervasives_Native.Some uu___9 in + FStarC_Syntax_Util.abs binders uu___7 uu___8))) +let (eta_expand : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun env1 -> + fun t -> + match t.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_name x -> + eta_expand_with_type env1 t x.FStarC_Syntax_Syntax.sort + | uu___ -> + let uu___1 = FStarC_Syntax_Util.head_and_args t in + (match uu___1 with + | (head, args) -> + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress head in + uu___3.FStarC_Syntax_Syntax.n in + (match uu___2 with + | FStarC_Syntax_Syntax.Tm_uvar (u, s) -> + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Util.ctx_uvar_typ u in + FStarC_Syntax_Subst.subst' s uu___5 in + FStarC_Syntax_Util.arrow_formals uu___4 in + (match uu___3 with + | (formals, _tres) -> + if + (FStarC_Compiler_List.length formals) = + (FStarC_Compiler_List.length args) + then t + else + (let uu___5 = + env1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + { + FStarC_TypeChecker_Env.solver = + (env1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + FStar_Pervasives_Native.None; + FStarC_TypeChecker_Env.sigtab = + (env1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = true; + FStarC_TypeChecker_Env.lax_universes = + (env1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (env1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (env1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (env1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (env1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (env1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (env1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (env1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (env1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env1.FStarC_TypeChecker_Env.missing_decl) + } t true in + match uu___5 with + | (uu___6, ty, uu___7) -> + eta_expand_with_type env1 t ty)) + | uu___3 -> + let uu___4 = + env1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + { + FStarC_TypeChecker_Env.solver = + (env1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + FStar_Pervasives_Native.None; + FStarC_TypeChecker_Env.sigtab = + (env1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = true; + FStarC_TypeChecker_Env.lax_universes = + (env1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env1.FStarC_TypeChecker_Env.missing_decl) + } t true in + (match uu___4 with + | (uu___5, ty, uu___6) -> eta_expand_with_type env1 t ty))) +let (elim_uvars_aux_tc : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.univ_names -> + FStarC_Syntax_Syntax.binders -> + (FStarC_Syntax_Syntax.typ, FStarC_Syntax_Syntax.comp) + FStar_Pervasives.either -> + (FStarC_Syntax_Syntax.univ_names * FStarC_Syntax_Syntax.binder + Prims.list * + (FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax, + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax) + FStar_Pervasives.either)) + = + fun env1 -> + fun univ_names -> + fun binders -> + fun tc -> + let t = + match (binders, tc) with + | ([], FStar_Pervasives.Inl t1) -> t1 + | ([], FStar_Pervasives.Inr c) -> + failwith "Impossible: empty bindes with a comp" + | (uu___, FStar_Pervasives.Inr c) -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 = binders; + FStarC_Syntax_Syntax.comp = c + }) c.FStarC_Syntax_Syntax.pos + | (uu___, FStar_Pervasives.Inl t1) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.mk_Total t1 in + { + FStarC_Syntax_Syntax.bs1 = binders; + FStarC_Syntax_Syntax.comp = uu___3 + } in + FStarC_Syntax_Syntax.Tm_arrow uu___2 in + FStarC_Syntax_Syntax.mk uu___1 t1.FStarC_Syntax_Syntax.pos in + let uu___ = FStarC_Syntax_Subst.open_univ_vars univ_names t in + match uu___ with + | (univ_names1, t1) -> + let t2 = remove_uvar_solutions env1 t1 in + let t3 = FStarC_Syntax_Subst.close_univ_vars univ_names1 t2 in + let uu___1 = + match binders with + | [] -> ([], (FStar_Pervasives.Inl t3)) + | uu___2 -> + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Subst.compress t3 in + uu___5.FStarC_Syntax_Syntax.n in + (uu___4, tc) in + (match uu___3 with + | (FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = binders1; + FStarC_Syntax_Syntax.comp = c;_}, + FStar_Pervasives.Inr uu___4) -> + (binders1, (FStar_Pervasives.Inr c)) + | (FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = binders1; + FStarC_Syntax_Syntax.comp = c;_}, + FStar_Pervasives.Inl uu___4) -> + (binders1, + (FStar_Pervasives.Inl + (FStarC_Syntax_Util.comp_result c))) + | (uu___4, FStar_Pervasives.Inl uu___5) -> + ([], (FStar_Pervasives.Inl t3)) + | uu___4 -> failwith "Impossible") in + (match uu___1 with + | (binders1, tc1) -> (univ_names1, binders1, tc1)) +let (elim_uvars_aux_t : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.univ_names -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.typ -> + (FStarC_Syntax_Syntax.univ_names * FStarC_Syntax_Syntax.binder + Prims.list * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax)) + = + fun env1 -> + fun univ_names -> + fun binders -> + fun t -> + let uu___ = + elim_uvars_aux_tc env1 univ_names binders + (FStar_Pervasives.Inl t) in + match uu___ with + | (univ_names1, binders1, tc) -> + let uu___1 = FStarC_Compiler_Util.left tc in + (univ_names1, binders1, uu___1) +let (elim_uvars_aux_c : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.univ_names -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.comp -> + (FStarC_Syntax_Syntax.univ_names * FStarC_Syntax_Syntax.binder + Prims.list * FStarC_Syntax_Syntax.comp' + FStarC_Syntax_Syntax.syntax)) + = + fun env1 -> + fun univ_names -> + fun binders -> + fun c -> + let uu___ = + elim_uvars_aux_tc env1 univ_names binders + (FStar_Pervasives.Inr c) in + match uu___ with + | (univ_names1, binders1, tc) -> + let uu___1 = FStarC_Compiler_Util.right tc in + (univ_names1, binders1, uu___1) +let rec (elim_uvars : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.sigelt -> FStarC_Syntax_Syntax.sigelt) + = + fun env1 -> + fun s -> + let sigattrs = + let uu___ = + FStarC_Compiler_List.map (elim_uvars_aux_t env1 [] []) + s.FStarC_Syntax_Syntax.sigattrs in + FStarC_Compiler_List.map + FStar_Pervasives_Native.__proj__Mktuple3__item___3 uu___ in + let s1 = + { + FStarC_Syntax_Syntax.sigel = (s.FStarC_Syntax_Syntax.sigel); + FStarC_Syntax_Syntax.sigrng = (s.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = (s.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = (s.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = sigattrs; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (s.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = (s.FStarC_Syntax_Syntax.sigopts) + } in + match s1.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = lid; + FStarC_Syntax_Syntax.us = univ_names; + FStarC_Syntax_Syntax.params = binders; + FStarC_Syntax_Syntax.num_uniform_params = num_uniform; + FStarC_Syntax_Syntax.t = typ; + FStarC_Syntax_Syntax.mutuals = lids; + FStarC_Syntax_Syntax.ds = lids'; + FStarC_Syntax_Syntax.injective_type_params = + injective_type_params;_} + -> + let uu___ = elim_uvars_aux_t env1 univ_names binders typ in + (match uu___ with + | (univ_names1, binders1, typ1) -> + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_inductive_typ + { + FStarC_Syntax_Syntax.lid = lid; + FStarC_Syntax_Syntax.us = univ_names1; + FStarC_Syntax_Syntax.params = binders1; + FStarC_Syntax_Syntax.num_uniform_params = num_uniform; + FStarC_Syntax_Syntax.t = typ1; + FStarC_Syntax_Syntax.mutuals = lids; + FStarC_Syntax_Syntax.ds = lids'; + FStarC_Syntax_Syntax.injective_type_params = + injective_type_params + }); + FStarC_Syntax_Syntax.sigrng = + (s1.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (s1.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (s1.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (s1.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (s1.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (s1.FStarC_Syntax_Syntax.sigopts) + }) + | FStarC_Syntax_Syntax.Sig_bundle + { FStarC_Syntax_Syntax.ses = sigs; + FStarC_Syntax_Syntax.lids = lids;_} + -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Compiler_List.map (elim_uvars env1) sigs in + { + FStarC_Syntax_Syntax.ses = uu___2; + FStarC_Syntax_Syntax.lids = lids + } in + FStarC_Syntax_Syntax.Sig_bundle uu___1 in + { + FStarC_Syntax_Syntax.sigel = uu___; + FStarC_Syntax_Syntax.sigrng = (s1.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (s1.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = (s1.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (s1.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (s1.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = (s1.FStarC_Syntax_Syntax.sigopts) + } + | FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = lid; + FStarC_Syntax_Syntax.us1 = univ_names; + FStarC_Syntax_Syntax.t1 = typ; + FStarC_Syntax_Syntax.ty_lid = lident; + FStarC_Syntax_Syntax.num_ty_params = i; + FStarC_Syntax_Syntax.mutuals1 = lids; + FStarC_Syntax_Syntax.injective_type_params1 = + injective_type_params;_} + -> + let uu___ = elim_uvars_aux_t env1 univ_names [] typ in + (match uu___ with + | (univ_names1, uu___1, typ1) -> + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_datacon + { + FStarC_Syntax_Syntax.lid1 = lid; + FStarC_Syntax_Syntax.us1 = univ_names1; + FStarC_Syntax_Syntax.t1 = typ1; + FStarC_Syntax_Syntax.ty_lid = lident; + FStarC_Syntax_Syntax.num_ty_params = i; + FStarC_Syntax_Syntax.mutuals1 = lids; + FStarC_Syntax_Syntax.injective_type_params1 = + injective_type_params + }); + FStarC_Syntax_Syntax.sigrng = + (s1.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (s1.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (s1.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (s1.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (s1.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (s1.FStarC_Syntax_Syntax.sigopts) + }) + | FStarC_Syntax_Syntax.Sig_declare_typ + { FStarC_Syntax_Syntax.lid2 = lid; + FStarC_Syntax_Syntax.us2 = univ_names; + FStarC_Syntax_Syntax.t2 = typ;_} + -> + let uu___ = elim_uvars_aux_t env1 univ_names [] typ in + (match uu___ with + | (univ_names1, uu___1, typ1) -> + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_declare_typ + { + FStarC_Syntax_Syntax.lid2 = lid; + FStarC_Syntax_Syntax.us2 = univ_names1; + FStarC_Syntax_Syntax.t2 = typ1 + }); + FStarC_Syntax_Syntax.sigrng = + (s1.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (s1.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (s1.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (s1.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (s1.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (s1.FStarC_Syntax_Syntax.sigopts) + }) + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (b, lbs); + FStarC_Syntax_Syntax.lids1 = lids;_} + -> + let lbs1 = + FStarC_Compiler_List.map + (fun lb -> + let uu___ = + FStarC_Syntax_Subst.univ_var_opening + lb.FStarC_Syntax_Syntax.lbunivs in + match uu___ with + | (opening, lbunivs) -> + let elim t = + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.subst opening t in + remove_uvar_solutions env1 uu___2 in + FStarC_Syntax_Subst.close_univ_vars lbunivs uu___1 in + let lbtyp = elim lb.FStarC_Syntax_Syntax.lbtyp in + let lbdef = elim lb.FStarC_Syntax_Syntax.lbdef in + { + FStarC_Syntax_Syntax.lbname = + (lb.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs = lbunivs; + FStarC_Syntax_Syntax.lbtyp = lbtyp; + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = lbdef; + FStarC_Syntax_Syntax.lbattrs = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + }) lbs in + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_let + { + FStarC_Syntax_Syntax.lbs1 = (b, lbs1); + FStarC_Syntax_Syntax.lids1 = lids + }); + FStarC_Syntax_Syntax.sigrng = (s1.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (s1.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = (s1.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (s1.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (s1.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = (s1.FStarC_Syntax_Syntax.sigopts) + } + | FStarC_Syntax_Syntax.Sig_assume + { FStarC_Syntax_Syntax.lid3 = l; FStarC_Syntax_Syntax.us3 = us; + FStarC_Syntax_Syntax.phi1 = t;_} + -> + let uu___ = elim_uvars_aux_t env1 us [] t in + (match uu___ with + | (us1, uu___1, t1) -> + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_assume + { + FStarC_Syntax_Syntax.lid3 = l; + FStarC_Syntax_Syntax.us3 = us1; + FStarC_Syntax_Syntax.phi1 = t1 + }); + FStarC_Syntax_Syntax.sigrng = + (s1.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (s1.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (s1.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (s1.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (s1.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (s1.FStarC_Syntax_Syntax.sigopts) + }) + | FStarC_Syntax_Syntax.Sig_new_effect ed -> + let uu___ = + elim_uvars_aux_t env1 ed.FStarC_Syntax_Syntax.univs + ed.FStarC_Syntax_Syntax.binders FStarC_Syntax_Syntax.t_unit in + (match uu___ with + | (univs, binders, uu___1) -> + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.univ_var_opening univs in + match uu___3 with + | (univs_opening, univs1) -> + let uu___4 = FStarC_Syntax_Subst.univ_var_closing univs1 in + (univs_opening, uu___4) in + (match uu___2 with + | (univs_opening, univs_closing) -> + let uu___3 = + let binders1 = FStarC_Syntax_Subst.open_binders binders in + let uu___4 = + FStarC_Syntax_Subst.opening_of_binders binders1 in + let uu___5 = + FStarC_Syntax_Subst.closing_of_binders binders1 in + (uu___4, uu___5) in + (match uu___3 with + | (b_opening, b_closing) -> + let n = FStarC_Compiler_List.length univs in + let n_binders = FStarC_Compiler_List.length binders in + let elim_tscheme uu___4 = + match uu___4 with + | (us, t) -> + let n_us = FStarC_Compiler_List.length us in + let uu___5 = + FStarC_Syntax_Subst.open_univ_vars us t in + (match uu___5 with + | (us1, t1) -> + let uu___6 = + let uu___7 = + FStarC_Syntax_Subst.shift_subst n_us + b_opening in + let uu___8 = + FStarC_Syntax_Subst.shift_subst n_us + b_closing in + (uu___7, uu___8) in + (match uu___6 with + | (b_opening1, b_closing1) -> + let uu___7 = + let uu___8 = + FStarC_Syntax_Subst.shift_subst + (n_us + n_binders) + univs_opening in + let uu___9 = + FStarC_Syntax_Subst.shift_subst + (n_us + n_binders) + univs_closing in + (uu___8, uu___9) in + (match uu___7 with + | (univs_opening1, univs_closing1) + -> + let t2 = + let uu___8 = + FStarC_Syntax_Subst.subst + b_opening1 t1 in + FStarC_Syntax_Subst.subst + univs_opening1 uu___8 in + let uu___8 = + elim_uvars_aux_t env1 [] [] + t2 in + (match uu___8 with + | (uu___9, uu___10, t3) -> + let t4 = + let uu___11 = + let uu___12 = + FStarC_Syntax_Subst.close_univ_vars + us1 t3 in + FStarC_Syntax_Subst.subst + b_closing1 uu___12 in + FStarC_Syntax_Subst.subst + univs_closing1 uu___11 in + (us1, t4))))) in + let elim_term t = + let uu___4 = elim_uvars_aux_t env1 univs binders t in + match uu___4 with | (uu___5, uu___6, t1) -> t1 in + let elim_action a = + let action_typ_templ = + let body = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_ascribed + { + FStarC_Syntax_Syntax.tm = + (a.FStarC_Syntax_Syntax.action_defn); + FStarC_Syntax_Syntax.asc = + ((FStar_Pervasives.Inl + (a.FStarC_Syntax_Syntax.action_typ)), + FStar_Pervasives_Native.None, + false); + FStarC_Syntax_Syntax.eff_opt = + FStar_Pervasives_Native.None + }) + (a.FStarC_Syntax_Syntax.action_defn).FStarC_Syntax_Syntax.pos in + match a.FStarC_Syntax_Syntax.action_params with + | [] -> body + | uu___4 -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs = + (a.FStarC_Syntax_Syntax.action_params); + FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = + FStar_Pervasives_Native.None + }) + (a.FStarC_Syntax_Syntax.action_defn).FStarC_Syntax_Syntax.pos in + let destruct_action_body body = + let uu___4 = + let uu___5 = FStarC_Syntax_Subst.compress body in + uu___5.FStarC_Syntax_Syntax.n in + match uu___4 with + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = defn; + FStarC_Syntax_Syntax.asc = + (FStar_Pervasives.Inl typ, + FStar_Pervasives_Native.None, uu___5); + FStarC_Syntax_Syntax.eff_opt = + FStar_Pervasives_Native.None;_} + -> (defn, typ) + | uu___5 -> failwith "Impossible" in + let destruct_action_typ_templ t = + let uu___4 = + let uu___5 = FStarC_Syntax_Subst.compress t in + uu___5.FStarC_Syntax_Syntax.n in + match uu___4 with + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = pars; + FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = uu___5;_} + -> + let uu___6 = destruct_action_body body in + (match uu___6 with + | (defn, typ) -> (pars, defn, typ)) + | uu___5 -> + let uu___6 = destruct_action_body t in + (match uu___6 with + | (defn, typ) -> ([], defn, typ)) in + let uu___4 = + elim_tscheme + ((a.FStarC_Syntax_Syntax.action_univs), + action_typ_templ) in + match uu___4 with + | (action_univs, t) -> + let uu___5 = destruct_action_typ_templ t in + (match uu___5 with + | (action_params, action_defn, action_typ) -> + let a' = + { + FStarC_Syntax_Syntax.action_name = + (a.FStarC_Syntax_Syntax.action_name); + FStarC_Syntax_Syntax.action_unqualified_name + = + (a.FStarC_Syntax_Syntax.action_unqualified_name); + FStarC_Syntax_Syntax.action_univs = + action_univs; + FStarC_Syntax_Syntax.action_params = + action_params; + FStarC_Syntax_Syntax.action_defn = + action_defn; + FStarC_Syntax_Syntax.action_typ = + action_typ + } in + a') in + let ed1 = + let uu___4 = + FStarC_Syntax_Util.apply_eff_sig elim_tscheme + ed.FStarC_Syntax_Syntax.signature in + let uu___5 = + FStarC_Syntax_Util.apply_eff_combinators + elim_tscheme + ed.FStarC_Syntax_Syntax.combinators in + let uu___6 = + FStarC_Compiler_List.map elim_action + ed.FStarC_Syntax_Syntax.actions in + { + FStarC_Syntax_Syntax.mname = + (ed.FStarC_Syntax_Syntax.mname); + FStarC_Syntax_Syntax.cattributes = + (ed.FStarC_Syntax_Syntax.cattributes); + FStarC_Syntax_Syntax.univs = univs; + FStarC_Syntax_Syntax.binders = binders; + FStarC_Syntax_Syntax.signature = uu___4; + FStarC_Syntax_Syntax.combinators = uu___5; + FStarC_Syntax_Syntax.actions = uu___6; + FStarC_Syntax_Syntax.eff_attrs = + (ed.FStarC_Syntax_Syntax.eff_attrs); + FStarC_Syntax_Syntax.extraction_mode = + (ed.FStarC_Syntax_Syntax.extraction_mode) + } in + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_new_effect ed1); + FStarC_Syntax_Syntax.sigrng = + (s1.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (s1.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (s1.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (s1.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (s1.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (s1.FStarC_Syntax_Syntax.sigopts) + }))) + | FStarC_Syntax_Syntax.Sig_sub_effect sub_eff -> + let elim_tscheme_opt uu___ = + match uu___ with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (us, t) -> + let uu___1 = elim_uvars_aux_t env1 us [] t in + (match uu___1 with + | (us1, uu___2, t1) -> + FStar_Pervasives_Native.Some (us1, t1)) in + let sub_eff1 = + let uu___ = elim_tscheme_opt sub_eff.FStarC_Syntax_Syntax.lift_wp in + let uu___1 = elim_tscheme_opt sub_eff.FStarC_Syntax_Syntax.lift in + { + FStarC_Syntax_Syntax.source = + (sub_eff.FStarC_Syntax_Syntax.source); + FStarC_Syntax_Syntax.target = + (sub_eff.FStarC_Syntax_Syntax.target); + FStarC_Syntax_Syntax.lift_wp = uu___; + FStarC_Syntax_Syntax.lift = uu___1; + FStarC_Syntax_Syntax.kind = (sub_eff.FStarC_Syntax_Syntax.kind) + } in + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_sub_effect sub_eff1); + FStarC_Syntax_Syntax.sigrng = (s1.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (s1.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = (s1.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (s1.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (s1.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = (s1.FStarC_Syntax_Syntax.sigopts) + } + | FStarC_Syntax_Syntax.Sig_effect_abbrev + { FStarC_Syntax_Syntax.lid4 = lid; + FStarC_Syntax_Syntax.us4 = univ_names; + FStarC_Syntax_Syntax.bs2 = binders; + FStarC_Syntax_Syntax.comp1 = comp; + FStarC_Syntax_Syntax.cflags = flags;_} + -> + let uu___ = elim_uvars_aux_c env1 univ_names binders comp in + (match uu___ with + | (univ_names1, binders1, comp1) -> + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_effect_abbrev + { + FStarC_Syntax_Syntax.lid4 = lid; + FStarC_Syntax_Syntax.us4 = univ_names1; + FStarC_Syntax_Syntax.bs2 = binders1; + FStarC_Syntax_Syntax.comp1 = comp1; + FStarC_Syntax_Syntax.cflags = flags + }); + FStarC_Syntax_Syntax.sigrng = + (s1.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (s1.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (s1.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (s1.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (s1.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (s1.FStarC_Syntax_Syntax.sigopts) + }) + | FStarC_Syntax_Syntax.Sig_pragma uu___ -> s1 + | FStarC_Syntax_Syntax.Sig_fail uu___ -> s1 + | FStarC_Syntax_Syntax.Sig_splice uu___ -> s1 + | FStarC_Syntax_Syntax.Sig_polymonadic_bind + { FStarC_Syntax_Syntax.m_lid = m; FStarC_Syntax_Syntax.n_lid = n; + FStarC_Syntax_Syntax.p_lid = p; + FStarC_Syntax_Syntax.tm3 = (us_t, t); + FStarC_Syntax_Syntax.typ = (us_ty, ty); + FStarC_Syntax_Syntax.kind1 = k;_} + -> + let uu___ = elim_uvars_aux_t env1 us_t [] t in + (match uu___ with + | (us_t1, uu___1, t1) -> + let uu___2 = elim_uvars_aux_t env1 us_ty [] ty in + (match uu___2 with + | (us_ty1, uu___3, ty1) -> + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_polymonadic_bind + { + FStarC_Syntax_Syntax.m_lid = m; + FStarC_Syntax_Syntax.n_lid = n; + FStarC_Syntax_Syntax.p_lid = p; + FStarC_Syntax_Syntax.tm3 = (us_t1, t1); + FStarC_Syntax_Syntax.typ = (us_ty1, ty1); + FStarC_Syntax_Syntax.kind1 = k + }); + FStarC_Syntax_Syntax.sigrng = + (s1.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (s1.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (s1.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (s1.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (s1.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (s1.FStarC_Syntax_Syntax.sigopts) + })) + | FStarC_Syntax_Syntax.Sig_polymonadic_subcomp + { FStarC_Syntax_Syntax.m_lid1 = m; FStarC_Syntax_Syntax.n_lid1 = n; + FStarC_Syntax_Syntax.tm4 = (us_t, t); + FStarC_Syntax_Syntax.typ1 = (us_ty, ty); + FStarC_Syntax_Syntax.kind2 = k;_} + -> + let uu___ = elim_uvars_aux_t env1 us_t [] t in + (match uu___ with + | (us_t1, uu___1, t1) -> + let uu___2 = elim_uvars_aux_t env1 us_ty [] ty in + (match uu___2 with + | (us_ty1, uu___3, ty1) -> + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_polymonadic_subcomp + { + FStarC_Syntax_Syntax.m_lid1 = m; + FStarC_Syntax_Syntax.n_lid1 = n; + FStarC_Syntax_Syntax.tm4 = (us_t1, t1); + FStarC_Syntax_Syntax.typ1 = (us_ty1, ty1); + FStarC_Syntax_Syntax.kind2 = k + }); + FStarC_Syntax_Syntax.sigrng = + (s1.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (s1.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (s1.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (s1.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (s1.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (s1.FStarC_Syntax_Syntax.sigopts) + })) +let (erase_universes : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun env1 -> + fun t -> + normalize + [FStarC_TypeChecker_Env.EraseUniverses; + FStarC_TypeChecker_Env.AllowUnboundUniverses] env1 t +let (unfold_head_once : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = + fun env1 -> + fun t -> + let aux f us args = + let uu___ = + FStarC_TypeChecker_Env.lookup_nonrec_definition + [FStarC_TypeChecker_Env.Unfold + FStarC_Syntax_Syntax.delta_constant] env1 + (f.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + match uu___ with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some head_def_ts -> + let uu___1 = + FStarC_TypeChecker_Env.inst_tscheme_with head_def_ts us in + (match uu___1 with + | (uu___2, head_def) -> + let t' = + FStarC_Syntax_Syntax.mk_Tm_app head_def args + t.FStarC_Syntax_Syntax.pos in + let t'1 = + normalize + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Iota] env1 t' in + FStar_Pervasives_Native.Some t'1) in + let uu___ = FStarC_Syntax_Util.head_and_args t in + match uu___ with + | (head, args) -> + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress head in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> aux fv [] args + | FStarC_Syntax_Syntax.Tm_uinst + ({ FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar fv; + FStarC_Syntax_Syntax.pos = uu___2; + FStarC_Syntax_Syntax.vars = uu___3; + FStarC_Syntax_Syntax.hash_code = uu___4;_}, + us) + -> aux fv us args + | uu___2 -> FStar_Pervasives_Native.None) +let (get_n_binders' : + FStarC_TypeChecker_Env.env -> + FStarC_TypeChecker_Env.step Prims.list -> + Prims.int -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.binder Prims.list * + FStarC_Syntax_Syntax.comp)) + = + fun env1 -> + fun steps -> + fun n -> + fun t -> + let rec aux retry n1 t1 = + let uu___ = FStarC_Syntax_Util.arrow_formals_comp t1 in + match uu___ with + | (bs, c) -> + let len = FStarC_Compiler_List.length bs in + (match (bs, c) with + | ([], uu___1) when retry -> + let uu___2 = unfold_whnf' steps env1 t1 in + aux false n1 uu___2 + | ([], uu___1) when Prims.op_Negation retry -> (bs, c) + | (bs1, c1) when len = n1 -> (bs1, c1) + | (bs1, c1) when len > n1 -> + let uu___1 = FStarC_Compiler_List.splitAt n1 bs1 in + (match uu___1 with + | (bs_l, bs_r) -> + let uu___2 = + let uu___3 = FStarC_Syntax_Util.arrow bs_r c1 in + FStarC_Syntax_Syntax.mk_Total uu___3 in + (bs_l, uu___2)) + | (bs1, c1) when + ((len < n1) && (FStarC_Syntax_Util.is_total_comp c1)) && + (let uu___1 = FStarC_Syntax_Util.has_decreases c1 in + Prims.op_Negation uu___1) + -> + let uu___1 = + aux true (n1 - len) + (FStarC_Syntax_Util.comp_result c1) in + (match uu___1 with + | (bs', c') -> + ((FStarC_Compiler_List.op_At bs1 bs'), c')) + | (bs1, c1) -> (bs1, c1)) in + aux true n t +let (get_n_binders : + FStarC_TypeChecker_Env.env -> + Prims.int -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.binder Prims.list * FStarC_Syntax_Syntax.comp)) + = fun env1 -> fun n -> fun t -> get_n_binders' env1 [] n t +let (uu___0 : unit) = + FStarC_Compiler_Effect.op_Colon_Equals __get_n_binders get_n_binders' +let (maybe_unfold_head_fv : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = + fun env1 -> + fun head -> + let fv_us_opt = + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress head in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_uinst + ({ FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar fv; + FStarC_Syntax_Syntax.pos = uu___1; + FStarC_Syntax_Syntax.vars = uu___2; + FStarC_Syntax_Syntax.hash_code = uu___3;_}, + us) + -> FStar_Pervasives_Native.Some (fv, us) + | FStarC_Syntax_Syntax.Tm_fvar fv -> + FStar_Pervasives_Native.Some (fv, []) + | uu___1 -> FStar_Pervasives_Native.None in + match fv_us_opt with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (fv, us) -> + let uu___ = + FStarC_TypeChecker_Env.lookup_nonrec_definition + [FStarC_TypeChecker_Env.Unfold + FStarC_Syntax_Syntax.delta_constant] env1 + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + (match uu___ with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (us_formals, defn) -> + let subst = FStarC_TypeChecker_Env.mk_univ_subst us_formals us in + let uu___1 = FStarC_Syntax_Subst.subst subst defn in + FStar_Pervasives_Native.Some uu___1) +let rec (maybe_unfold_aux : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = + fun env1 -> + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = t0; + FStarC_Syntax_Syntax.ret_opt = ret_opt; + FStarC_Syntax_Syntax.brs = brs; + FStarC_Syntax_Syntax.rc_opt1 = rc_opt;_} + -> + let uu___1 = maybe_unfold_aux env1 t0 in + FStarC_Compiler_Util.map_option + (fun t01 -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_match + { + FStarC_Syntax_Syntax.scrutinee = t01; + FStarC_Syntax_Syntax.ret_opt = ret_opt; + FStarC_Syntax_Syntax.brs = brs; + FStarC_Syntax_Syntax.rc_opt1 = rc_opt + }) t.FStarC_Syntax_Syntax.pos) uu___1 + | FStarC_Syntax_Syntax.Tm_fvar uu___1 -> maybe_unfold_head_fv env1 t + | FStarC_Syntax_Syntax.Tm_uinst uu___1 -> maybe_unfold_head_fv env1 t + | uu___1 -> + let uu___2 = FStarC_Syntax_Util.leftmost_head_and_args t in + (match uu___2 with + | (head, args) -> + if args = [] + then maybe_unfold_head_fv env1 head + else + (let uu___4 = maybe_unfold_aux env1 head in + match uu___4 with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some head1 -> + let uu___5 = + FStarC_Syntax_Syntax.mk_Tm_app head1 args + t.FStarC_Syntax_Syntax.pos in + FStar_Pervasives_Native.Some uu___5)) +let (maybe_unfold_head : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = + fun env1 -> + fun t -> + let uu___ = maybe_unfold_aux env1 t in + FStarC_Compiler_Util.map_option + (normalize + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Iota; + FStarC_TypeChecker_Env.Weak; + FStarC_TypeChecker_Env.HNF] env1) uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_Normalize_Unfolding.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Normalize_Unfolding.ml new file mode 100644 index 00000000000..0e8c0511e97 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Normalize_Unfolding.ml @@ -0,0 +1,789 @@ +open Prims +let (plugin_unfold_warn_ctr : Prims.int FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref Prims.int_zero +type should_unfold_res = + | Should_unfold_no + | Should_unfold_yes + | Should_unfold_fully + | Should_unfold_reify +let (uu___is_Should_unfold_no : should_unfold_res -> Prims.bool) = + fun projectee -> + match projectee with | Should_unfold_no -> true | uu___ -> false +let (uu___is_Should_unfold_yes : should_unfold_res -> Prims.bool) = + fun projectee -> + match projectee with | Should_unfold_yes -> true | uu___ -> false +let (uu___is_Should_unfold_fully : should_unfold_res -> Prims.bool) = + fun projectee -> + match projectee with | Should_unfold_fully -> true | uu___ -> false +let (uu___is_Should_unfold_reify : should_unfold_res -> Prims.bool) = + fun projectee -> + match projectee with | Should_unfold_reify -> true | uu___ -> false +let (should_unfold : + FStarC_TypeChecker_Cfg.cfg -> + (FStarC_TypeChecker_Cfg.cfg -> Prims.bool) -> + FStarC_Syntax_Syntax.fv -> + FStarC_TypeChecker_Env.qninfo -> should_unfold_res) + = + fun cfg -> + fun should_reify -> + fun fv -> + fun qninfo -> + let attrs = + let uu___ = FStarC_TypeChecker_Env.attrs_of_qninfo qninfo in + match uu___ with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some ats -> ats in + let quals = + let uu___ = FStarC_TypeChecker_Env.quals_of_qninfo qninfo in + match uu___ with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some quals1 -> quals1 in + let yes = (true, false, false) in + let no = (false, false, false) in + let fully = (true, true, false) in + let reif = (true, false, true) in + let yesno b = if b then yes else no in + let fullyno b = if b then fully else no in + let comb_or l = + FStarC_Compiler_List.fold_right + (fun uu___ -> + fun uu___1 -> + match (uu___, uu___1) with + | ((a, b, c), (x, y, z)) -> ((a || x), (b || y), (c || z))) + l (false, false, false) in + let default_unfolding uu___ = + FStarC_TypeChecker_Cfg.log_unfolding cfg + (fun uu___2 -> + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_fv fv in + let uu___4 = + let uu___5 = + FStarC_TypeChecker_Env.delta_depth_of_fv + cfg.FStarC_TypeChecker_Cfg.tcenv fv in + FStarC_Class_Show.show + FStarC_Syntax_Syntax.showable_delta_depth uu___5 in + let uu___5 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_TypeChecker_Env.showable_delta_level) + cfg.FStarC_TypeChecker_Cfg.delta_level in + FStarC_Compiler_Util.print3 + "should_unfold: Reached a %s with delta_depth = %s\n >> Our delta_level is %s\n" + uu___3 uu___4 uu___5); + (let uu___2 = + FStarC_Compiler_Util.for_some + (fun uu___3 -> + match uu___3 with + | FStarC_TypeChecker_Env.NoDelta -> false + | FStarC_TypeChecker_Env.InliningDelta -> true + | FStarC_TypeChecker_Env.Eager_unfolding_only -> true + | FStarC_TypeChecker_Env.Unfold l -> + let uu___4 = + FStarC_TypeChecker_Env.delta_depth_of_fv + cfg.FStarC_TypeChecker_Cfg.tcenv fv in + FStarC_TypeChecker_Common.delta_depth_greater_than + uu___4 l) cfg.FStarC_TypeChecker_Cfg.delta_level in + yesno uu___2) in + let res = + if FStarC_TypeChecker_Env.qninfo_is_action qninfo + then + let b = should_reify cfg in + (FStarC_TypeChecker_Cfg.log_unfolding cfg + (fun uu___1 -> + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_fv + fv in + let uu___3 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) b in + FStarC_Compiler_Util.print2 + "should_unfold: For DM4F action %s, should_reify = %s\n" + uu___2 uu___3); + if b then reif else no) + else + if + (let uu___ = FStarC_TypeChecker_Cfg.find_prim_step cfg fv in + FStarC_Compiler_Option.isSome uu___) + then + (FStarC_TypeChecker_Cfg.log_unfolding cfg + (fun uu___1 -> + FStarC_Compiler_Util.print_string + " >> It's a primop, not unfolding\n"); + no) + else + (match (qninfo, + ((cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unfold_only), + ((cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unfold_fully), + ((cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unfold_attr), + ((cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unfold_qual), + ((cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unfold_namespace)) + with + | (FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr + ({ + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (is_rec, uu___); + FStarC_Syntax_Syntax.lids1 = uu___1;_}; + FStarC_Syntax_Syntax.sigrng = uu___2; + FStarC_Syntax_Syntax.sigquals = qs; + FStarC_Syntax_Syntax.sigmeta = uu___3; + FStarC_Syntax_Syntax.sigattrs = uu___4; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___5; + FStarC_Syntax_Syntax.sigopts = uu___6;_}, + uu___7), + uu___8), + uu___9, uu___10, uu___11, uu___12, uu___13) when + FStarC_Compiler_List.contains + FStarC_Syntax_Syntax.HasMaskedEffect qs + -> + (FStarC_TypeChecker_Cfg.log_unfolding cfg + (fun uu___15 -> + FStarC_Compiler_Util.print_string + " >> HasMaskedEffect, not unfolding\n"); + no) + | (FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr + ({ + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (is_rec, uu___); + FStarC_Syntax_Syntax.lids1 = uu___1;_}; + FStarC_Syntax_Syntax.sigrng = uu___2; + FStarC_Syntax_Syntax.sigquals = qs; + FStarC_Syntax_Syntax.sigmeta = uu___3; + FStarC_Syntax_Syntax.sigattrs = uu___4; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___5; + FStarC_Syntax_Syntax.sigopts = uu___6;_}, + uu___7), + uu___8), + uu___9, uu___10, uu___11, uu___12, uu___13) when + (is_rec && + (Prims.op_Negation + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.zeta)) + && + (Prims.op_Negation + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.zeta_full) + -> + (FStarC_TypeChecker_Cfg.log_unfolding cfg + (fun uu___15 -> + FStarC_Compiler_Util.print_string + " >> It's a recursive definition but we're not doing Zeta, not unfolding\n"); + no) + | (uu___, FStar_Pervasives_Native.Some uu___1, uu___2, + uu___3, uu___4, uu___5) -> + (FStarC_TypeChecker_Cfg.log_unfolding cfg + (fun uu___7 -> + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_fv fv in + FStarC_Compiler_Util.print1 + "should_unfold: Reached a %s with selective unfolding\n" + uu___8); + (let meets_some_criterion = + let uu___7 = + let uu___8 = + if + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.for_extraction + then + let uu___9 = + let uu___10 = + FStarC_TypeChecker_Env.lookup_definition_qninfo + [FStarC_TypeChecker_Env.Eager_unfolding_only; + FStarC_TypeChecker_Env.InliningDelta] + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + qninfo in + FStarC_Compiler_Option.isSome uu___10 in + yesno uu___9 + else no in + let uu___9 = + let uu___10 = + match (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unfold_only + with + | FStar_Pervasives_Native.None -> no + | FStar_Pervasives_Native.Some lids -> + let uu___11 = + FStarC_Compiler_Util.for_some + (FStarC_Syntax_Syntax.fv_eq_lid fv) + lids in + yesno uu___11 in + let uu___11 = + let uu___12 = + match (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unfold_attr + with + | FStar_Pervasives_Native.None -> no + | FStar_Pervasives_Native.Some lids -> + let uu___13 = + FStarC_Compiler_Util.for_some + (fun at -> + FStarC_Compiler_Util.for_some + (fun lid -> + FStarC_Syntax_Util.is_fvar + lid at) lids) attrs in + yesno uu___13 in + let uu___13 = + let uu___14 = + match (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unfold_fully + with + | FStar_Pervasives_Native.None -> no + | FStar_Pervasives_Native.Some lids -> + let uu___15 = + FStarC_Compiler_Util.for_some + (FStarC_Syntax_Syntax.fv_eq_lid fv) + lids in + fullyno uu___15 in + let uu___15 = + let uu___16 = + match (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unfold_qual + with + | FStar_Pervasives_Native.None -> no + | FStar_Pervasives_Native.Some qs -> + let uu___17 = + FStarC_Compiler_Util.for_some + (fun q -> + FStarC_Compiler_Util.for_some + (fun qual -> + let uu___18 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_qualifier + qual in + uu___18 = q) quals) qs in + yesno uu___17 in + let uu___17 = + let uu___18 = + match (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unfold_namespace + with + | FStar_Pervasives_Native.None -> no + | FStar_Pervasives_Native.Some + namespaces -> + let p = + let uu___19 = + FStarC_Syntax_Syntax.lid_of_fv + fv in + FStarC_Ident.path_of_lid uu___19 in + let r = + FStarC_Compiler_Path.search_forest + (FStarC_Class_Ord.ord_eq + FStarC_Class_Ord.ord_string) + p namespaces in + yesno r in + [uu___18] in + uu___16 :: uu___17 in + uu___14 :: uu___15 in + uu___12 :: uu___13 in + uu___10 :: uu___11 in + uu___8 :: uu___9 in + comb_or uu___7 in + meets_some_criterion)) + | (uu___, uu___1, FStar_Pervasives_Native.Some uu___2, + uu___3, uu___4, uu___5) -> + (FStarC_TypeChecker_Cfg.log_unfolding cfg + (fun uu___7 -> + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_fv fv in + FStarC_Compiler_Util.print1 + "should_unfold: Reached a %s with selective unfolding\n" + uu___8); + (let meets_some_criterion = + let uu___7 = + let uu___8 = + if + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.for_extraction + then + let uu___9 = + let uu___10 = + FStarC_TypeChecker_Env.lookup_definition_qninfo + [FStarC_TypeChecker_Env.Eager_unfolding_only; + FStarC_TypeChecker_Env.InliningDelta] + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + qninfo in + FStarC_Compiler_Option.isSome uu___10 in + yesno uu___9 + else no in + let uu___9 = + let uu___10 = + match (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unfold_only + with + | FStar_Pervasives_Native.None -> no + | FStar_Pervasives_Native.Some lids -> + let uu___11 = + FStarC_Compiler_Util.for_some + (FStarC_Syntax_Syntax.fv_eq_lid fv) + lids in + yesno uu___11 in + let uu___11 = + let uu___12 = + match (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unfold_attr + with + | FStar_Pervasives_Native.None -> no + | FStar_Pervasives_Native.Some lids -> + let uu___13 = + FStarC_Compiler_Util.for_some + (fun at -> + FStarC_Compiler_Util.for_some + (fun lid -> + FStarC_Syntax_Util.is_fvar + lid at) lids) attrs in + yesno uu___13 in + let uu___13 = + let uu___14 = + match (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unfold_fully + with + | FStar_Pervasives_Native.None -> no + | FStar_Pervasives_Native.Some lids -> + let uu___15 = + FStarC_Compiler_Util.for_some + (FStarC_Syntax_Syntax.fv_eq_lid fv) + lids in + fullyno uu___15 in + let uu___15 = + let uu___16 = + match (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unfold_qual + with + | FStar_Pervasives_Native.None -> no + | FStar_Pervasives_Native.Some qs -> + let uu___17 = + FStarC_Compiler_Util.for_some + (fun q -> + FStarC_Compiler_Util.for_some + (fun qual -> + let uu___18 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_qualifier + qual in + uu___18 = q) quals) qs in + yesno uu___17 in + let uu___17 = + let uu___18 = + match (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unfold_namespace + with + | FStar_Pervasives_Native.None -> no + | FStar_Pervasives_Native.Some + namespaces -> + let p = + let uu___19 = + FStarC_Syntax_Syntax.lid_of_fv + fv in + FStarC_Ident.path_of_lid uu___19 in + let r = + FStarC_Compiler_Path.search_forest + (FStarC_Class_Ord.ord_eq + FStarC_Class_Ord.ord_string) + p namespaces in + yesno r in + [uu___18] in + uu___16 :: uu___17 in + uu___14 :: uu___15 in + uu___12 :: uu___13 in + uu___10 :: uu___11 in + uu___8 :: uu___9 in + comb_or uu___7 in + meets_some_criterion)) + | (uu___, uu___1, uu___2, FStar_Pervasives_Native.Some + uu___3, uu___4, uu___5) -> + (FStarC_TypeChecker_Cfg.log_unfolding cfg + (fun uu___7 -> + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_fv fv in + FStarC_Compiler_Util.print1 + "should_unfold: Reached a %s with selective unfolding\n" + uu___8); + (let meets_some_criterion = + let uu___7 = + let uu___8 = + if + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.for_extraction + then + let uu___9 = + let uu___10 = + FStarC_TypeChecker_Env.lookup_definition_qninfo + [FStarC_TypeChecker_Env.Eager_unfolding_only; + FStarC_TypeChecker_Env.InliningDelta] + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + qninfo in + FStarC_Compiler_Option.isSome uu___10 in + yesno uu___9 + else no in + let uu___9 = + let uu___10 = + match (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unfold_only + with + | FStar_Pervasives_Native.None -> no + | FStar_Pervasives_Native.Some lids -> + let uu___11 = + FStarC_Compiler_Util.for_some + (FStarC_Syntax_Syntax.fv_eq_lid fv) + lids in + yesno uu___11 in + let uu___11 = + let uu___12 = + match (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unfold_attr + with + | FStar_Pervasives_Native.None -> no + | FStar_Pervasives_Native.Some lids -> + let uu___13 = + FStarC_Compiler_Util.for_some + (fun at -> + FStarC_Compiler_Util.for_some + (fun lid -> + FStarC_Syntax_Util.is_fvar + lid at) lids) attrs in + yesno uu___13 in + let uu___13 = + let uu___14 = + match (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unfold_fully + with + | FStar_Pervasives_Native.None -> no + | FStar_Pervasives_Native.Some lids -> + let uu___15 = + FStarC_Compiler_Util.for_some + (FStarC_Syntax_Syntax.fv_eq_lid fv) + lids in + fullyno uu___15 in + let uu___15 = + let uu___16 = + match (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unfold_qual + with + | FStar_Pervasives_Native.None -> no + | FStar_Pervasives_Native.Some qs -> + let uu___17 = + FStarC_Compiler_Util.for_some + (fun q -> + FStarC_Compiler_Util.for_some + (fun qual -> + let uu___18 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_qualifier + qual in + uu___18 = q) quals) qs in + yesno uu___17 in + let uu___17 = + let uu___18 = + match (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unfold_namespace + with + | FStar_Pervasives_Native.None -> no + | FStar_Pervasives_Native.Some + namespaces -> + let p = + let uu___19 = + FStarC_Syntax_Syntax.lid_of_fv + fv in + FStarC_Ident.path_of_lid uu___19 in + let r = + FStarC_Compiler_Path.search_forest + (FStarC_Class_Ord.ord_eq + FStarC_Class_Ord.ord_string) + p namespaces in + yesno r in + [uu___18] in + uu___16 :: uu___17 in + uu___14 :: uu___15 in + uu___12 :: uu___13 in + uu___10 :: uu___11 in + uu___8 :: uu___9 in + comb_or uu___7 in + meets_some_criterion)) + | (uu___, uu___1, uu___2, uu___3, + FStar_Pervasives_Native.Some uu___4, uu___5) -> + (FStarC_TypeChecker_Cfg.log_unfolding cfg + (fun uu___7 -> + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_fv fv in + FStarC_Compiler_Util.print1 + "should_unfold: Reached a %s with selective unfolding\n" + uu___8); + (let meets_some_criterion = + let uu___7 = + let uu___8 = + if + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.for_extraction + then + let uu___9 = + let uu___10 = + FStarC_TypeChecker_Env.lookup_definition_qninfo + [FStarC_TypeChecker_Env.Eager_unfolding_only; + FStarC_TypeChecker_Env.InliningDelta] + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + qninfo in + FStarC_Compiler_Option.isSome uu___10 in + yesno uu___9 + else no in + let uu___9 = + let uu___10 = + match (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unfold_only + with + | FStar_Pervasives_Native.None -> no + | FStar_Pervasives_Native.Some lids -> + let uu___11 = + FStarC_Compiler_Util.for_some + (FStarC_Syntax_Syntax.fv_eq_lid fv) + lids in + yesno uu___11 in + let uu___11 = + let uu___12 = + match (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unfold_attr + with + | FStar_Pervasives_Native.None -> no + | FStar_Pervasives_Native.Some lids -> + let uu___13 = + FStarC_Compiler_Util.for_some + (fun at -> + FStarC_Compiler_Util.for_some + (fun lid -> + FStarC_Syntax_Util.is_fvar + lid at) lids) attrs in + yesno uu___13 in + let uu___13 = + let uu___14 = + match (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unfold_fully + with + | FStar_Pervasives_Native.None -> no + | FStar_Pervasives_Native.Some lids -> + let uu___15 = + FStarC_Compiler_Util.for_some + (FStarC_Syntax_Syntax.fv_eq_lid fv) + lids in + fullyno uu___15 in + let uu___15 = + let uu___16 = + match (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unfold_qual + with + | FStar_Pervasives_Native.None -> no + | FStar_Pervasives_Native.Some qs -> + let uu___17 = + FStarC_Compiler_Util.for_some + (fun q -> + FStarC_Compiler_Util.for_some + (fun qual -> + let uu___18 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_qualifier + qual in + uu___18 = q) quals) qs in + yesno uu___17 in + let uu___17 = + let uu___18 = + match (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unfold_namespace + with + | FStar_Pervasives_Native.None -> no + | FStar_Pervasives_Native.Some + namespaces -> + let p = + let uu___19 = + FStarC_Syntax_Syntax.lid_of_fv + fv in + FStarC_Ident.path_of_lid uu___19 in + let r = + FStarC_Compiler_Path.search_forest + (FStarC_Class_Ord.ord_eq + FStarC_Class_Ord.ord_string) + p namespaces in + yesno r in + [uu___18] in + uu___16 :: uu___17 in + uu___14 :: uu___15 in + uu___12 :: uu___13 in + uu___10 :: uu___11 in + uu___8 :: uu___9 in + comb_or uu___7 in + meets_some_criterion)) + | (uu___, uu___1, uu___2, uu___3, uu___4, + FStar_Pervasives_Native.Some uu___5) -> + (FStarC_TypeChecker_Cfg.log_unfolding cfg + (fun uu___7 -> + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_fv fv in + FStarC_Compiler_Util.print1 + "should_unfold: Reached a %s with selective unfolding\n" + uu___8); + (let meets_some_criterion = + let uu___7 = + let uu___8 = + if + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.for_extraction + then + let uu___9 = + let uu___10 = + FStarC_TypeChecker_Env.lookup_definition_qninfo + [FStarC_TypeChecker_Env.Eager_unfolding_only; + FStarC_TypeChecker_Env.InliningDelta] + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + qninfo in + FStarC_Compiler_Option.isSome uu___10 in + yesno uu___9 + else no in + let uu___9 = + let uu___10 = + match (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unfold_only + with + | FStar_Pervasives_Native.None -> no + | FStar_Pervasives_Native.Some lids -> + let uu___11 = + FStarC_Compiler_Util.for_some + (FStarC_Syntax_Syntax.fv_eq_lid fv) + lids in + yesno uu___11 in + let uu___11 = + let uu___12 = + match (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unfold_attr + with + | FStar_Pervasives_Native.None -> no + | FStar_Pervasives_Native.Some lids -> + let uu___13 = + FStarC_Compiler_Util.for_some + (fun at -> + FStarC_Compiler_Util.for_some + (fun lid -> + FStarC_Syntax_Util.is_fvar + lid at) lids) attrs in + yesno uu___13 in + let uu___13 = + let uu___14 = + match (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unfold_fully + with + | FStar_Pervasives_Native.None -> no + | FStar_Pervasives_Native.Some lids -> + let uu___15 = + FStarC_Compiler_Util.for_some + (FStarC_Syntax_Syntax.fv_eq_lid fv) + lids in + fullyno uu___15 in + let uu___15 = + let uu___16 = + match (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unfold_qual + with + | FStar_Pervasives_Native.None -> no + | FStar_Pervasives_Native.Some qs -> + let uu___17 = + FStarC_Compiler_Util.for_some + (fun q -> + FStarC_Compiler_Util.for_some + (fun qual -> + let uu___18 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_qualifier + qual in + uu___18 = q) quals) qs in + yesno uu___17 in + let uu___17 = + let uu___18 = + match (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.unfold_namespace + with + | FStar_Pervasives_Native.None -> no + | FStar_Pervasives_Native.Some + namespaces -> + let p = + let uu___19 = + FStarC_Syntax_Syntax.lid_of_fv + fv in + FStarC_Ident.path_of_lid uu___19 in + let r = + FStarC_Compiler_Path.search_forest + (FStarC_Class_Ord.ord_eq + FStarC_Class_Ord.ord_string) + p namespaces in + yesno r in + [uu___18] in + uu___16 :: uu___17 in + uu___14 :: uu___15 in + uu___12 :: uu___13 in + uu___10 :: uu___11 in + uu___8 :: uu___9 in + comb_or uu___7 in + meets_some_criterion)) + | (uu___, uu___1, uu___2, uu___3, uu___4, uu___5) when + (FStar_Pervasives_Native.uu___is_Some + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.dont_unfold_attr) + && + (FStarC_Compiler_List.existsb + (fun fa -> + FStarC_Syntax_Util.has_attribute attrs fa) + (FStar_Pervasives_Native.__proj__Some__item__v + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.dont_unfold_attr)) + -> + (FStarC_TypeChecker_Cfg.log_unfolding cfg + (fun uu___7 -> + FStarC_Compiler_Util.print_string + " >> forbidden by attribute, not unfolding\n"); + no) + | uu___ -> default_unfolding ()) in + FStarC_TypeChecker_Cfg.log_unfolding cfg + (fun uu___1 -> + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_fv fv in + let uu___3 = + let uu___4 = FStarC_Syntax_Syntax.range_of_fv fv in + FStarC_Class_Show.show + FStarC_Compiler_Range_Ops.showable_range uu___4 in + let uu___4 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_tuple3 + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool)) res in + FStarC_Compiler_Util.print3 + "should_unfold: For %s (%s), unfolding res = %s\n" uu___2 + uu___3 uu___4); + (let r = + match res with + | (false, uu___1, uu___2) -> Should_unfold_no + | (true, false, false) -> Should_unfold_yes + | (true, true, false) -> Should_unfold_fully + | (true, false, true) -> Should_unfold_reify + | uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_tuple3 + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool)) res in + FStarC_Compiler_Util.format1 + "Unexpected unfolding result: %s" uu___3 in + failwith uu___2 in + (let uu___2 = + ((((FStar_Pervasives_Native.uu___is_Some + (cfg.FStarC_TypeChecker_Cfg.steps).FStarC_TypeChecker_Cfg.dont_unfold_attr) + && + (let uu___3 = FStarC_Options.no_plugins () in + Prims.op_Negation uu___3)) + && (r <> Should_unfold_no)) + && + (FStarC_Compiler_Util.for_some + (FStarC_Syntax_Util.is_fvar + FStarC_Parser_Const.plugin_attr) attrs)) + && + (let uu___3 = + FStarC_Compiler_Effect.op_Bang plugin_unfold_warn_ctr in + uu___3 > Prims.int_zero) in + if uu___2 + then + let msg = + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_fv fv in + FStarC_Compiler_Util.format1 + "Unfolding name which is marked as a plugin: %s" uu___3 in + (FStarC_Errors.log_issue FStarC_Class_HasRange.hasRange_range + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.p + FStarC_Errors_Codes.Warning_UnfoldPlugin () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic msg); + (let uu___4 = + let uu___5 = + FStarC_Compiler_Effect.op_Bang plugin_unfold_warn_ctr in + uu___5 - Prims.int_one in + FStarC_Compiler_Effect.op_Colon_Equals plugin_unfold_warn_ctr + uu___4)) + else ()); + r) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_PatternUtils.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_PatternUtils.ml new file mode 100644 index 00000000000..df0c6fa5525 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_PatternUtils.ml @@ -0,0 +1,473 @@ +open Prims +type lcomp_with_binder = + (FStarC_Syntax_Syntax.bv FStar_Pervasives_Native.option * + FStarC_TypeChecker_Common.lcomp) +let (dbg_Patterns : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Patterns" +let rec (elaborate_pat : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.pat -> FStarC_Syntax_Syntax.pat) + = + fun env -> + fun p -> + let maybe_dot inaccessible a r = + if inaccessible + then + FStarC_Syntax_Syntax.withinfo + (FStarC_Syntax_Syntax.Pat_dot_term FStar_Pervasives_Native.None) + r + else FStarC_Syntax_Syntax.withinfo (FStarC_Syntax_Syntax.Pat_var a) r in + match p.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_cons + ({ FStarC_Syntax_Syntax.fv_name = uu___; + FStarC_Syntax_Syntax.fv_qual = FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Unresolved_constructor uu___1);_}, + uu___2, uu___3) + -> p + | FStarC_Syntax_Syntax.Pat_cons (fv, us_opt, pats) -> + let pats1 = + FStarC_Compiler_List.map + (fun uu___ -> + match uu___ with + | (p1, imp) -> + let uu___1 = elaborate_pat env p1 in (uu___1, imp)) pats in + let uu___ = + FStarC_TypeChecker_Env.lookup_datacon env + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + (match uu___ with + | (uu___1, t) -> + let uu___2 = FStarC_Syntax_Util.arrow_formals t in + (match uu___2 with + | (f, uu___3) -> + let rec aux formals pats2 = + match (formals, pats2) with + | ([], []) -> [] + | ([], uu___4::uu___5) -> + FStarC_Errors.raise_error + FStarC_Ident.hasrange_lident + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + FStarC_Errors_Codes.Fatal_TooManyPatternArguments + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "Too many pattern arguments") + | (uu___4::uu___5, []) -> + FStarC_Compiler_List.map + (fun fml -> + let uu___6 = + ((fml.FStarC_Syntax_Syntax.binder_bv), + (fml.FStarC_Syntax_Syntax.binder_qual)) in + match uu___6 with + | (t1, imp) -> + (match imp with + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Implicit + inaccessible) -> + let a = + let uu___7 = + let uu___8 = + FStarC_Syntax_Syntax.range_of_bv + t1 in + FStar_Pervasives_Native.Some + uu___8 in + FStarC_Syntax_Syntax.new_bv uu___7 + FStarC_Syntax_Syntax.tun in + let r = + FStarC_Ident.range_of_lid + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + let uu___7 = + maybe_dot inaccessible a r in + (uu___7, true) + | uu___7 -> + let uu___8 = + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_pat + p in + FStarC_Compiler_Util.format1 + "Insufficient pattern arguments (%s)" + uu___9 in + FStarC_Errors.raise_error + FStarC_Ident.hasrange_lident + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + FStarC_Errors_Codes.Fatal_InsufficientPatternArguments + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___8))) formals + | (f1::formals', (p1, p_imp)::pats') -> + (match ((f1.FStarC_Syntax_Syntax.binder_bv), + (f1.FStarC_Syntax_Syntax.binder_qual)) + with + | (uu___4, FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Implicit inaccessible)) + when inaccessible && p_imp -> + (match p1.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_dot_term uu___5 -> + let uu___6 = aux formals' pats' in + (p1, true) :: uu___6 + | FStarC_Syntax_Syntax.Pat_var v when + let uu___5 = + FStarC_Ident.string_of_id + v.FStarC_Syntax_Syntax.ppname in + uu___5 = FStarC_Ident.reserved_prefix -> + let a = + FStarC_Syntax_Syntax.new_bv + (FStar_Pervasives_Native.Some + (p1.FStarC_Syntax_Syntax.p)) + FStarC_Syntax_Syntax.tun in + let p2 = + let uu___5 = + FStarC_Ident.range_of_lid + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + maybe_dot inaccessible a uu___5 in + let uu___5 = aux formals' pats' in + (p2, true) :: uu___5 + | uu___5 -> + let uu___6 = + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_pat p1 in + FStarC_Compiler_Util.format1 + "This pattern (%s) binds an inaccesible argument; use a wildcard ('_') pattern" + uu___7 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + p1.FStarC_Syntax_Syntax.p + FStarC_Errors_Codes.Fatal_InsufficientPatternArguments + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___6)) + | (uu___4, FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Implicit uu___5)) when + p_imp -> + let uu___6 = aux formals' pats' in (p1, true) + :: uu___6 + | (uu___4, FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Implicit inaccessible)) + -> + let a = + FStarC_Syntax_Syntax.new_bv + (FStar_Pervasives_Native.Some + (p1.FStarC_Syntax_Syntax.p)) + FStarC_Syntax_Syntax.tun in + let p2 = + let uu___5 = + FStarC_Ident.range_of_lid + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + maybe_dot inaccessible a uu___5 in + let uu___5 = aux formals' pats2 in (p2, true) + :: uu___5 + | (uu___4, imp) -> + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.is_bqual_implicit imp in + (p1, uu___6) in + let uu___6 = aux formals' pats' in uu___5 :: + uu___6) in + let uu___4 = + let uu___5 = + let uu___6 = aux f pats1 in (fv, us_opt, uu___6) in + FStarC_Syntax_Syntax.Pat_cons uu___5 in + { + FStarC_Syntax_Syntax.v = uu___4; + FStarC_Syntax_Syntax.p = (p.FStarC_Syntax_Syntax.p) + })) + | uu___ -> p +exception Raw_pat_cannot_be_translated +let (uu___is_Raw_pat_cannot_be_translated : Prims.exn -> Prims.bool) = + fun projectee -> + match projectee with + | Raw_pat_cannot_be_translated -> true + | uu___ -> false +let (raw_pat_as_exp : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.pat -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.bv Prims.list) + FStar_Pervasives_Native.option) + = + fun env -> + fun p -> + let rec aux bs p1 = + match p1.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_constant c -> + let e = + match c with + | FStarC_Const.Const_int + (repr, FStar_Pervasives_Native.Some sw) -> + FStarC_ToSyntax_ToSyntax.desugar_machine_integer + env.FStarC_TypeChecker_Env.dsenv repr sw + p1.FStarC_Syntax_Syntax.p + | uu___ -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_constant c) + p1.FStarC_Syntax_Syntax.p in + (e, bs) + | FStarC_Syntax_Syntax.Pat_dot_term eopt -> + (match eopt with + | FStar_Pervasives_Native.None -> + FStarC_Compiler_Effect.raise Raw_pat_cannot_be_translated + | FStar_Pervasives_Native.Some e -> + let uu___ = FStarC_Syntax_Subst.compress e in (uu___, bs)) + | FStarC_Syntax_Syntax.Pat_var x -> + let uu___ = + FStarC_Syntax_Syntax.mk (FStarC_Syntax_Syntax.Tm_name x) + p1.FStarC_Syntax_Syntax.p in + (uu___, (x :: bs)) + | FStarC_Syntax_Syntax.Pat_cons (fv, us_opt, pats) -> + let uu___ = + FStarC_Compiler_List.fold_right + (fun uu___1 -> + fun uu___2 -> + match (uu___1, uu___2) with + | ((p2, i), (args, bs1)) -> + let uu___3 = aux bs1 p2 in + (match uu___3 with + | (ep, bs2) -> + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.as_aqual_implicit i in + (ep, uu___6) in + uu___5 :: args in + (uu___4, bs2))) pats ([], bs) in + (match uu___ with + | (args, bs1) -> + let hd = FStarC_Syntax_Syntax.fv_to_tm fv in + let hd1 = + match us_opt with + | FStar_Pervasives_Native.None -> hd + | FStar_Pervasives_Native.Some us -> + FStarC_Syntax_Syntax.mk_Tm_uinst hd us in + let e = + FStarC_Syntax_Syntax.mk_Tm_app hd1 args + p1.FStarC_Syntax_Syntax.p in + (e, bs1)) in + try + (fun uu___ -> + match () with + | () -> + let uu___1 = aux [] p in FStar_Pervasives_Native.Some uu___1) + () + with | Raw_pat_cannot_be_translated -> FStar_Pervasives_Native.None +let (pat_as_exp : + Prims.bool -> + Prims.bool -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.pat -> + (FStarC_Syntax_Syntax.bv Prims.list * FStarC_Syntax_Syntax.term * + FStarC_TypeChecker_Common.guard_t * FStarC_Syntax_Syntax.pat)) + = + fun introduce_bv_uvars -> + fun inst_pat_cons_univs -> + fun env -> + fun p -> + let intro_bv env1 x = + if Prims.op_Negation introduce_bv_uvars + then + ({ + FStarC_Syntax_Syntax.ppname = + (x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = (x.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = FStarC_Syntax_Syntax.tun + }, FStarC_TypeChecker_Env.trivial_guard, env1) + else + (let uu___1 = FStarC_Syntax_Util.type_u () in + match uu___1 with + | (t, uu___2) -> + let uu___3 = + let uu___4 = FStarC_Syntax_Syntax.range_of_bv x in + FStarC_TypeChecker_Env.new_implicit_var_aux + "pattern bv type" uu___4 env1 t + (FStarC_Syntax_Syntax.Allow_untyped "pattern bv type") + FStar_Pervasives_Native.None false in + (match uu___3 with + | (t_x, uu___4, guard) -> + let x1 = + { + FStarC_Syntax_Syntax.ppname = + (x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (x.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = t_x + } in + let uu___5 = FStarC_TypeChecker_Env.push_bv env1 x1 in + (x1, guard, uu___5))) in + let rec pat_as_arg_with_env env1 p1 = + match p1.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_constant c -> + let e = + match c with + | FStarC_Const.Const_int + (repr, FStar_Pervasives_Native.Some sw) -> + FStarC_ToSyntax_ToSyntax.desugar_machine_integer + env1.FStarC_TypeChecker_Env.dsenv repr sw + p1.FStarC_Syntax_Syntax.p + | uu___ -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_constant c) + p1.FStarC_Syntax_Syntax.p in + ([], [], [], env1, e, + FStarC_TypeChecker_Common.trivial_guard, p1) + | FStarC_Syntax_Syntax.Pat_dot_term eopt -> + (match eopt with + | FStar_Pervasives_Native.None -> + ((let uu___1 = + FStarC_Compiler_Effect.op_Bang dbg_Patterns in + if uu___1 + then + (if + Prims.op_Negation + env1.FStarC_TypeChecker_Env.phase1 + then + let uu___2 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_pat p1 in + FStarC_Compiler_Util.print1 + "Found a non-instantiated dot pattern in phase2 (%s)\n" + uu___2 + else ()) + else ()); + (let uu___1 = FStarC_Syntax_Util.type_u () in + match uu___1 with + | (k, uu___2) -> + let uu___3 = + FStarC_TypeChecker_Env.new_implicit_var_aux + "pat_dot_term type" p1.FStarC_Syntax_Syntax.p + env1 k + (FStarC_Syntax_Syntax.Allow_ghost + "pat dot term type") + FStar_Pervasives_Native.None false in + (match uu___3 with + | (t, uu___4, g) -> + let uu___5 = + FStarC_TypeChecker_Env.new_implicit_var_aux + "pat_dot_term" p1.FStarC_Syntax_Syntax.p + env1 t + (FStarC_Syntax_Syntax.Allow_ghost + "pat dot term") + FStar_Pervasives_Native.None false in + (match uu___5 with + | (e, uu___6, g') -> + let p2 = + { + FStarC_Syntax_Syntax.v = + (FStarC_Syntax_Syntax.Pat_dot_term + (FStar_Pervasives_Native.Some e)); + FStarC_Syntax_Syntax.p = + (p1.FStarC_Syntax_Syntax.p) + } in + let uu___7 = + FStarC_TypeChecker_Common.conj_guard g + g' in + ([], [], [], env1, e, uu___7, p2))))) + | FStar_Pervasives_Native.Some e -> + ([], [], [], env1, e, + FStarC_TypeChecker_Env.trivial_guard, p1)) + | FStarC_Syntax_Syntax.Pat_var x -> + let uu___ = intro_bv env1 x in + (match uu___ with + | (x1, g, env2) -> + let e = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_name x1) + p1.FStarC_Syntax_Syntax.p in + ([x1], [x1], [], env2, e, g, p1)) + | FStarC_Syntax_Syntax.Pat_cons (fv, us_opt, pats) -> + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun uu___2 -> + match (uu___1, uu___2) with + | ((b, a, w, env2, args, guard, pats1), (p2, imp)) + -> + let uu___3 = pat_as_arg_with_env env2 p2 in + (match uu___3 with + | (b', a', w', env3, te, guard', pat) -> + let arg = + if imp + then FStarC_Syntax_Syntax.iarg te + else FStarC_Syntax_Syntax.as_arg te in + let uu___4 = + FStarC_TypeChecker_Common.conj_guard + guard guard' in + ((b' :: b), (a' :: a), (w' :: w), env3, + (arg :: args), uu___4, ((pat, imp) :: + pats1)))) + ([], [], [], env1, [], + FStarC_TypeChecker_Common.trivial_guard, []) pats in + (match uu___ with + | (b, a, w, env2, args, guard, pats1) -> + let inst_head hd us_opt1 = + match us_opt1 with + | FStar_Pervasives_Native.None -> hd + | FStar_Pervasives_Native.Some us -> + FStarC_Syntax_Syntax.mk_Tm_uinst hd us in + let uu___1 = + let hd = FStarC_Syntax_Syntax.fv_to_tm fv in + if + (Prims.op_Negation inst_pat_cons_univs) || + (FStar_Pervasives_Native.uu___is_Some us_opt) + then + let uu___2 = inst_head hd us_opt in (uu___2, us_opt) + else + (let uu___3 = + let uu___4 = FStarC_Syntax_Syntax.lid_of_fv fv in + FStarC_TypeChecker_Env.lookup_datacon env2 uu___4 in + match uu___3 with + | (us, uu___4) -> + if + (FStarC_Compiler_List.length us) = + Prims.int_zero + then (hd, (FStar_Pervasives_Native.Some [])) + else + (let uu___6 = + FStarC_Syntax_Syntax.mk_Tm_uinst hd us in + (uu___6, (FStar_Pervasives_Native.Some us)))) in + (match uu___1 with + | (hd, us_opt1) -> + let e = + FStarC_Syntax_Syntax.mk_Tm_app hd + (FStarC_Compiler_List.rev args) + p1.FStarC_Syntax_Syntax.p in + ((FStarC_Compiler_List.flatten + (FStarC_Compiler_List.rev b)), + (FStarC_Compiler_List.flatten + (FStarC_Compiler_List.rev a)), + (FStarC_Compiler_List.flatten + (FStarC_Compiler_List.rev w)), env2, e, guard, + { + FStarC_Syntax_Syntax.v = + (FStarC_Syntax_Syntax.Pat_cons + (fv, us_opt1, + (FStarC_Compiler_List.rev pats1))); + FStarC_Syntax_Syntax.p = + (p1.FStarC_Syntax_Syntax.p) + }))) in + let one_pat env1 p1 = + let p2 = elaborate_pat env1 p1 in + let uu___ = pat_as_arg_with_env env1 p2 in + match uu___ with + | (b, a, w, env2, arg, guard, p3) -> + let uu___1 = + FStarC_Compiler_Util.find_dup FStarC_Syntax_Syntax.bv_eq b in + (match uu___1 with + | FStar_Pervasives_Native.Some x -> + let m = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_bv + x in + let uu___2 = + FStarC_Compiler_Util.format1 + "The pattern variable \"%s\" was used more than once" + m in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + p3.FStarC_Syntax_Syntax.p + FStarC_Errors_Codes.Fatal_NonLinearPatternVars () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2) + | uu___2 -> (b, a, w, arg, guard, p3)) in + let uu___ = one_pat env p in + match uu___ with + | (b, uu___1, uu___2, tm, guard, p1) -> (b, tm, guard, p1) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_Positivity.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Positivity.ml new file mode 100644 index 00000000000..138f6961b78 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Positivity.ml @@ -0,0 +1,1743 @@ +open Prims +let (dbg_Positivity : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Positivity" +let (debug_positivity : + FStarC_TypeChecker_Env.env_t -> (unit -> Prims.string) -> unit) = + fun env -> + fun msg -> + let uu___ = FStarC_Compiler_Effect.op_Bang dbg_Positivity in + if uu___ + then + let uu___1 = + let uu___2 = let uu___3 = msg () in Prims.strcat uu___3 "\n" in + Prims.strcat "Positivity::" uu___2 in + FStarC_Compiler_Util.print_string uu___1 + else () +let (string_of_lids : FStarC_Ident.lident Prims.list -> Prims.string) = + fun lids -> + let uu___ = FStarC_Compiler_List.map FStarC_Ident.string_of_lid lids in + FStarC_Compiler_String.concat ", " uu___ +let (normalize : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun env -> + fun t -> + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.HNF; + FStarC_TypeChecker_Env.Weak; + FStarC_TypeChecker_Env.Iota; + FStarC_TypeChecker_Env.Exclude FStarC_TypeChecker_Env.Zeta; + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant] env t +let (apply_constr_arrow : + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.arg Prims.list -> FStarC_Syntax_Syntax.term) + = + fun dlid -> + fun dt -> + fun all_params -> + let rec aux t args = + let uu___ = + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress t in + uu___2.FStarC_Syntax_Syntax.n in + (uu___1, args) in + match uu___ with + | (uu___1, []) -> FStarC_Syntax_Util.canon_arrow t + | (FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = b::bs; + FStarC_Syntax_Syntax.comp = c;_}, + a::args1) -> + let tail = + match bs with + | [] -> FStarC_Syntax_Util.comp_result c + | uu___1 -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = c + }) t.FStarC_Syntax_Syntax.pos in + let uu___1 = FStarC_Syntax_Subst.open_term_1 b tail in + (match uu___1 with + | (b1, tail1) -> + let tail2 = + FStarC_Syntax_Subst.subst + [FStarC_Syntax_Syntax.NT + ((b1.FStarC_Syntax_Syntax.binder_bv), + (FStar_Pervasives_Native.fst a))] tail1 in + aux tail2 args1) + | uu___1 -> + let uu___2 = FStarC_Ident.range_of_lid dlid in + let uu___3 = + let uu___4 = FStarC_Syntax_Print.args_to_string all_params in + let uu___5 = + FStarC_Class_Show.show FStarC_Ident.showable_lident dlid in + let uu___6 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term dt in + FStarC_Compiler_Util.format3 + "Unexpected application of type parameters %s to a data constructor %s : %s" + uu___4 uu___5 uu___6 in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range + uu___2 + FStarC_Errors_Codes.Error_InductiveTypeNotSatisfyPositivityCondition + () (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___3) in + aux dt all_params +let (ty_occurs_in : + FStarC_Ident.lident -> FStarC_Syntax_Syntax.term -> Prims.bool) = + fun ty_lid -> + fun t -> + let uu___ = FStarC_Syntax_Free.fvars t in + FStarC_Class_Setlike.mem () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset FStarC_Syntax_Syntax.ord_fv)) + ty_lid (Obj.magic uu___) +let rec (term_as_fv_or_name : + FStarC_Syntax_Syntax.term -> + ((FStarC_Syntax_Syntax.fv * FStarC_Syntax_Syntax.universes), + FStarC_Syntax_Syntax.bv) FStar_Pervasives.either + FStar_Pervasives_Native.option) + = + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_name x -> + FStar_Pervasives_Native.Some (FStar_Pervasives.Inr x) + | FStarC_Syntax_Syntax.Tm_fvar fv -> + FStar_Pervasives_Native.Some (FStar_Pervasives.Inl (fv, [])) + | FStarC_Syntax_Syntax.Tm_uinst (t1, us) -> + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress t1 in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + FStar_Pervasives_Native.Some (FStar_Pervasives.Inl (fv, us)) + | uu___2 -> + failwith "term_as_fv_or_name: impossible non fvar in uinst") + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t1; FStarC_Syntax_Syntax.asc = uu___1; + FStarC_Syntax_Syntax.eff_opt = uu___2;_} + -> term_as_fv_or_name t1 + | uu___1 -> FStar_Pervasives_Native.None +let (open_sig_inductive_typ : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.sigelt -> + (FStarC_TypeChecker_Env.env * (FStarC_Ident.lident * + FStarC_Syntax_Syntax.univ_name Prims.list * + FStarC_Syntax_Syntax.binders))) + = + fun env -> + fun se -> + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = lid; FStarC_Syntax_Syntax.us = ty_us; + FStarC_Syntax_Syntax.params = ty_params; + FStarC_Syntax_Syntax.num_uniform_params = uu___; + FStarC_Syntax_Syntax.t = uu___1; + FStarC_Syntax_Syntax.mutuals = uu___2; + FStarC_Syntax_Syntax.ds = uu___3; + FStarC_Syntax_Syntax.injective_type_params = uu___4;_} + -> + let uu___5 = FStarC_Syntax_Subst.univ_var_opening ty_us in + (match uu___5 with + | (ty_usubst, ty_us1) -> + let env1 = FStarC_TypeChecker_Env.push_univ_vars env ty_us1 in + let ty_params1 = + FStarC_Syntax_Subst.subst_binders ty_usubst ty_params in + let ty_params2 = FStarC_Syntax_Subst.open_binders ty_params1 in + let env2 = FStarC_TypeChecker_Env.push_binders env1 ty_params2 in + (env2, (lid, ty_us1, ty_params2))) + | uu___ -> failwith "Impossible!" +let (name_as_fv_in_t : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.bv -> + (FStarC_Syntax_Syntax.term * FStarC_Ident.lident)) + = + fun t -> + fun bv -> + let fv_lid = + let uu___ = + let uu___1 = + FStarC_Ident.string_of_id bv.FStarC_Syntax_Syntax.ppname in + FStarC_Ident.lid_of_str uu___1 in + let uu___1 = FStarC_Syntax_Syntax.range_of_bv bv in + FStarC_Ident.set_lid_range uu___ uu___1 in + let fv = FStarC_Syntax_Syntax.tconst fv_lid in + let t1 = FStarC_Syntax_Subst.subst [FStarC_Syntax_Syntax.NT (bv, fv)] t in + (t1, fv_lid) +let rec min_l : + 'a . Prims.int -> 'a Prims.list -> ('a -> Prims.int) -> Prims.int = + fun def -> + fun l -> + fun f -> + match l with + | [] -> def + | hd::tl -> + let uu___ = f hd in + let uu___1 = min_l def tl f in Prims.min uu___ uu___1 +let (max_uniformly_recursive_parameters : + FStarC_TypeChecker_Env.env_t -> + FStarC_Ident.lident Prims.list -> + FStarC_Syntax_Syntax.bv Prims.list -> + FStarC_Syntax_Syntax.term -> Prims.int) + = + fun env -> + fun mutuals -> + fun params -> + fun ty -> + let max_matching_prefix longer shorter f = + let rec aux n ls ms = + match (ls, ms) with + | (uu___, []) -> FStar_Pervasives_Native.Some n + | (l::ls1, m::ms1) -> + let uu___ = f l m in + if uu___ + then aux (n + Prims.int_one) ls1 ms1 + else FStar_Pervasives_Native.Some n + | uu___ -> FStar_Pervasives_Native.None in + aux Prims.int_zero longer shorter in + let ty1 = normalize env ty in + let n_params = FStarC_Compiler_List.length params in + let compare_name_bv x y = + let uu___ = + let uu___1 = + FStarC_Syntax_Subst.compress (FStar_Pervasives_Native.fst x) in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_name x1 -> + FStarC_Syntax_Syntax.bv_eq x1 y + | uu___1 -> false in + let min_l1 f l = min_l n_params f l in + let params_to_string uu___ = + let uu___1 = + FStarC_Compiler_List.map + (FStarC_Class_Show.show FStarC_Syntax_Print.showable_bv) + params in + FStarC_Compiler_String.concat ", " uu___1 in + debug_positivity env + (fun uu___1 -> + let uu___2 = params_to_string () in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term ty1 in + FStarC_Compiler_Util.format2 + "max_uniformly_recursive_parameters? params=%s in %s" uu___2 + uu___3); + (let rec aux ty2 = + debug_positivity env + (fun uu___2 -> + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + ty2 in + FStarC_Compiler_Util.format1 + "max_uniformly_recursive_parameters.aux? %s" uu___3); + (let uu___2 = + FStarC_Compiler_List.for_all + (fun mutual -> + let uu___3 = ty_occurs_in mutual ty2 in + Prims.op_Negation uu___3) mutuals in + if uu___2 + then n_params + else + (let uu___4 = + let uu___5 = FStarC_Syntax_Subst.compress ty2 in + uu___5.FStarC_Syntax_Syntax.n in + match uu___4 with + | FStarC_Syntax_Syntax.Tm_name uu___5 -> n_params + | FStarC_Syntax_Syntax.Tm_fvar uu___5 -> n_params + | FStarC_Syntax_Syntax.Tm_uinst uu___5 -> n_params + | FStarC_Syntax_Syntax.Tm_type uu___5 -> n_params + | FStarC_Syntax_Syntax.Tm_constant uu___5 -> n_params + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x; + FStarC_Syntax_Syntax.phi = f;_} + -> + let uu___5 = aux x.FStarC_Syntax_Syntax.sort in + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = FStarC_Syntax_Syntax.mk_binder x in + [uu___9] in + FStarC_Syntax_Subst.open_term uu___8 f in + match uu___7 with | (uu___8, f1) -> aux f1 in + Prims.min uu___5 uu___6 + | FStarC_Syntax_Syntax.Tm_app uu___5 -> + let uu___6 = FStarC_Syntax_Util.head_and_args ty2 in + (match uu___6 with + | (head, args) -> + let uu___7 = + let uu___8 = FStarC_Syntax_Util.un_uinst head in + uu___8.FStarC_Syntax_Syntax.n in + (match uu___7 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let uu___8 = + FStarC_Compiler_List.existsML + (FStarC_Syntax_Syntax.fv_eq_lid fv) + mutuals in + if uu___8 + then + (debug_positivity env + (fun uu___10 -> + let uu___11 = params_to_string () in + let uu___12 = + FStarC_Syntax_Print.args_to_string + args in + FStarC_Compiler_Util.format2 + "Searching for max matching prefix of params=%s in args=%s" + uu___11 uu___12); + (let uu___10 = + max_matching_prefix args params + compare_name_bv in + match uu___10 with + | FStar_Pervasives_Native.None -> + Prims.int_zero + | FStar_Pervasives_Native.Some n -> n)) + else + min_l1 args + (fun uu___10 -> + match uu___10 with + | (arg, uu___11) -> aux arg) + | uu___8 -> + let uu___9 = aux head in + let uu___10 = + min_l1 args + (fun uu___11 -> + match uu___11 with + | (arg, uu___12) -> aux arg) in + Prims.min uu___9 uu___10)) + | FStarC_Syntax_Syntax.Tm_abs uu___5 -> + let uu___6 = FStarC_Syntax_Util.abs_formals ty2 in + (match uu___6 with + | (bs, body, uu___7) -> + let uu___8 = + min_l1 bs + (fun b -> + aux + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort) in + let uu___9 = aux body in Prims.min uu___8 uu___9) + | FStarC_Syntax_Syntax.Tm_arrow uu___5 -> + let uu___6 = FStarC_Syntax_Util.arrow_formals ty2 in + (match uu___6 with + | (bs, r) -> + let uu___7 = + min_l1 bs + (fun b -> + aux + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort) in + let uu___8 = aux r in Prims.min uu___7 uu___8) + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = scrutinee; + FStarC_Syntax_Syntax.ret_opt = uu___5; + FStarC_Syntax_Syntax.brs = branches; + FStarC_Syntax_Syntax.rc_opt1 = uu___6;_} + -> + let uu___7 = aux scrutinee in + let uu___8 = + min_l1 branches + (fun uu___9 -> + match uu___9 with + | (p, uu___10, t) -> + let bs = + let uu___11 = + FStarC_Syntax_Syntax.pat_bvs p in + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.mk_binder uu___11 in + let uu___11 = + FStarC_Syntax_Subst.open_term bs t in + (match uu___11 with | (bs1, t1) -> aux t1)) in + Prims.min uu___7 uu___8 + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t; + FStarC_Syntax_Syntax.meta = uu___5;_} + -> aux t + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t; + FStarC_Syntax_Syntax.asc = uu___5; + FStarC_Syntax_Syntax.eff_opt = uu___6;_} + -> aux t + | uu___5 -> Prims.int_zero)) in + let res = aux ty1 in + debug_positivity env + (fun uu___2 -> + let uu___3 = params_to_string () in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + ty1 in + FStarC_Compiler_Util.format3 + "result: max_uniformly_recursive_parameters(params=%s in %s) = %s" + uu___3 uu___4 (Prims.string_of_int res)); + res) +let (mark_uniform_type_parameters : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.sigelt -> FStarC_Syntax_Syntax.sigelt) + = + fun env -> + fun sig1 -> + let mark_tycon_parameters tc datas = + let uu___ = tc.FStarC_Syntax_Syntax.sigel in + match uu___ with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = tc_lid; + FStarC_Syntax_Syntax.us = us; + FStarC_Syntax_Syntax.params = ty_param_binders; + FStarC_Syntax_Syntax.num_uniform_params = uu___1; + FStarC_Syntax_Syntax.t = t; + FStarC_Syntax_Syntax.mutuals = mutuals; + FStarC_Syntax_Syntax.ds = data_lids; + FStarC_Syntax_Syntax.injective_type_params = + injective_type_params;_} + -> + let uu___2 = open_sig_inductive_typ env tc in + (match uu___2 with + | (env1, (tc_lid1, us1, ty_params)) -> + let uu___3 = FStarC_Syntax_Util.args_of_binders ty_params in + (match uu___3 with + | (uu___4, ty_param_args) -> + let datacon_fields = + FStarC_Compiler_List.filter_map + (fun data -> + match data.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = d_lid; + FStarC_Syntax_Syntax.us1 = d_us; + FStarC_Syntax_Syntax.t1 = dt; + FStarC_Syntax_Syntax.ty_lid = tc_lid'; + FStarC_Syntax_Syntax.num_ty_params = + uu___5; + FStarC_Syntax_Syntax.mutuals1 = uu___6; + FStarC_Syntax_Syntax.injective_type_params1 + = uu___7;_} + -> + let uu___8 = + FStarC_Ident.lid_equals tc_lid1 tc_lid' in + if uu___8 + then + let dt1 = + let uu___9 = + let uu___10 = + FStarC_Compiler_List.map + (fun uu___11 -> + FStarC_Syntax_Syntax.U_name + uu___11) us1 in + FStarC_TypeChecker_Env.mk_univ_subst + d_us uu___10 in + FStarC_Syntax_Subst.subst uu___9 dt in + let uu___9 = + let uu___10 = + let uu___11 = + apply_constr_arrow d_lid dt1 + ty_param_args in + FStarC_Syntax_Util.arrow_formals + uu___11 in + FStar_Pervasives_Native.fst uu___10 in + FStar_Pervasives_Native.Some uu___9 + else FStar_Pervasives_Native.None + | uu___5 -> FStar_Pervasives_Native.None) datas in + let ty_param_bvs = + FStarC_Compiler_List.map + (fun b -> b.FStarC_Syntax_Syntax.binder_bv) + ty_params in + let n_params = FStarC_Compiler_List.length ty_params in + let min_l1 f l = min_l n_params f l in + let max_uniform_prefix = + min_l1 datacon_fields + (fun fields_of_one_datacon -> + min_l1 fields_of_one_datacon + (fun field -> + max_uniformly_recursive_parameters env1 + mutuals ty_param_bvs + (field.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort)) in + (if max_uniform_prefix < n_params + then + (let uu___6 = + FStarC_Compiler_List.splitAt max_uniform_prefix + ty_param_binders in + match uu___6 with + | (uu___7, non_uniform_params) -> + FStarC_Compiler_List.iter + (fun param -> + if + param.FStarC_Syntax_Syntax.binder_positivity + = + (FStar_Pervasives_Native.Some + FStarC_Syntax_Syntax.BinderStrictlyPositive) + then + let uu___8 = + FStarC_Syntax_Syntax.range_of_bv + param.FStarC_Syntax_Syntax.binder_bv in + let uu___9 = + let uu___10 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_binder + param in + FStarC_Compiler_Util.format1 + "Binder %s is marked strictly positive, but it is not uniformly recursive" + uu___10 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + uu___8 + FStarC_Errors_Codes.Error_InductiveTypeNotSatisfyPositivityCondition + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___9) + else ()) non_uniform_params) + else (); + (let sigel = + FStarC_Syntax_Syntax.Sig_inductive_typ + { + FStarC_Syntax_Syntax.lid = tc_lid1; + FStarC_Syntax_Syntax.us = us1; + FStarC_Syntax_Syntax.params = ty_param_binders; + FStarC_Syntax_Syntax.num_uniform_params = + (FStar_Pervasives_Native.Some + max_uniform_prefix); + FStarC_Syntax_Syntax.t = t; + FStarC_Syntax_Syntax.mutuals = mutuals; + FStarC_Syntax_Syntax.ds = data_lids; + FStarC_Syntax_Syntax.injective_type_params = + injective_type_params + } in + { + FStarC_Syntax_Syntax.sigel = sigel; + FStarC_Syntax_Syntax.sigrng = + (tc.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (tc.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (tc.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (tc.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (tc.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (tc.FStarC_Syntax_Syntax.sigopts) + })))) in + match sig1.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_bundle + { FStarC_Syntax_Syntax.ses = ses; + FStarC_Syntax_Syntax.lids = lids;_} + -> + let uu___ = + FStarC_Compiler_List.partition + (fun se -> + FStarC_Syntax_Syntax.uu___is_Sig_inductive_typ + se.FStarC_Syntax_Syntax.sigel) ses in + (match uu___ with + | (tcs, datas) -> + let tcs1 = + FStarC_Compiler_List.map + (fun tc -> mark_tycon_parameters tc datas) tcs in + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_bundle + { + FStarC_Syntax_Syntax.ses = + (FStar_List_Tot_Base.op_At tcs1 datas); + FStarC_Syntax_Syntax.lids = lids + }); + FStarC_Syntax_Syntax.sigrng = + (sig1.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (sig1.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (sig1.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (sig1.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (sig1.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (sig1.FStarC_Syntax_Syntax.sigopts) + }) + | uu___ -> sig1 +let (may_be_an_arity : + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.term -> Prims.bool) = + fun env -> + fun t -> + let t1 = normalize env t in + let rec aux t2 = + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t2 in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_name uu___1 -> false + | FStarC_Syntax_Syntax.Tm_constant uu___1 -> false + | FStarC_Syntax_Syntax.Tm_abs uu___1 -> false + | FStarC_Syntax_Syntax.Tm_lazy uu___1 -> false + | FStarC_Syntax_Syntax.Tm_quoted uu___1 -> false + | FStarC_Syntax_Syntax.Tm_fvar uu___1 -> + let uu___2 = FStarC_Syntax_Util.head_and_args t2 in + (match uu___2 with + | (head, args) -> + let uu___3 = + let uu___4 = FStarC_Syntax_Util.un_uinst head in + uu___4.FStarC_Syntax_Syntax.n in + (match uu___3 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let uu___4 = + FStarC_TypeChecker_Env.lookup_sigelt env + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + (match uu___4 with + | FStar_Pervasives_Native.None -> true + | FStar_Pervasives_Native.Some se -> + (match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_let uu___5 -> true + | uu___5 -> false)) + | uu___4 -> true)) + | FStarC_Syntax_Syntax.Tm_uinst uu___1 -> + let uu___2 = FStarC_Syntax_Util.head_and_args t2 in + (match uu___2 with + | (head, args) -> + let uu___3 = + let uu___4 = FStarC_Syntax_Util.un_uinst head in + uu___4.FStarC_Syntax_Syntax.n in + (match uu___3 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let uu___4 = + FStarC_TypeChecker_Env.lookup_sigelt env + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + (match uu___4 with + | FStar_Pervasives_Native.None -> true + | FStar_Pervasives_Native.Some se -> + (match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_let uu___5 -> true + | uu___5 -> false)) + | uu___4 -> true)) + | FStarC_Syntax_Syntax.Tm_app uu___1 -> + let uu___2 = FStarC_Syntax_Util.head_and_args t2 in + (match uu___2 with + | (head, args) -> + let uu___3 = + let uu___4 = FStarC_Syntax_Util.un_uinst head in + uu___4.FStarC_Syntax_Syntax.n in + (match uu___3 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let uu___4 = + FStarC_TypeChecker_Env.lookup_sigelt env + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + (match uu___4 with + | FStar_Pervasives_Native.None -> true + | FStar_Pervasives_Native.Some se -> + (match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_let uu___5 -> true + | uu___5 -> false)) + | uu___4 -> true)) + | FStarC_Syntax_Syntax.Tm_type uu___1 -> true + | FStarC_Syntax_Syntax.Tm_arrow uu___1 -> + let uu___2 = FStarC_Syntax_Util.arrow_formals t2 in + (match uu___2 with | (uu___3, t3) -> aux t3) + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x; + FStarC_Syntax_Syntax.phi = uu___1;_} + -> aux x.FStarC_Syntax_Syntax.sort + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = uu___1; + FStarC_Syntax_Syntax.ret_opt = uu___2; + FStarC_Syntax_Syntax.brs = branches; + FStarC_Syntax_Syntax.rc_opt1 = uu___3;_} + -> + FStarC_Compiler_List.existsML + (fun uu___4 -> + match uu___4 with + | (p, uu___5, t3) -> + let bs = + let uu___6 = FStarC_Syntax_Syntax.pat_bvs p in + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.mk_binder uu___6 in + let uu___6 = FStarC_Syntax_Subst.open_term bs t3 in + (match uu___6 with | (bs1, t4) -> aux t4)) branches + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t3; + FStarC_Syntax_Syntax.meta = uu___1;_} + -> aux t3 + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t3; + FStarC_Syntax_Syntax.asc = uu___1; + FStarC_Syntax_Syntax.eff_opt = uu___2;_} + -> aux t3 + | FStarC_Syntax_Syntax.Tm_uvar uu___1 -> true + | FStarC_Syntax_Syntax.Tm_let uu___1 -> true + | FStarC_Syntax_Syntax.Tm_delayed uu___1 -> failwith "Impossible" + | FStarC_Syntax_Syntax.Tm_bvar uu___1 -> failwith "Impossible" + | FStarC_Syntax_Syntax.Tm_unknown -> failwith "Impossible" in + aux t1 +let (check_no_index_occurrences_in_arities : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident Prims.list -> FStarC_Syntax_Syntax.term -> unit) + = + fun env -> + fun mutuals -> + fun t -> + debug_positivity env + (fun uu___1 -> + let uu___2 = string_of_lids mutuals in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.format2 + "check_no_index_occurrences of (mutuals %s) in arities of %s" + uu___2 uu___3); + (let no_occurrence_in_index fv mutuals1 index = + let fext_on_domain_index_sub_term index1 = + let uu___1 = FStarC_Syntax_Util.head_and_args index1 in + match uu___1 with + | (head, args) -> + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Util.un_uinst head in + uu___4.FStarC_Syntax_Syntax.n in + (uu___3, args) in + (match uu___2 with + | (FStarC_Syntax_Syntax.Tm_fvar fv1, + _td::_tr::(f, uu___3)::[]) -> + let uu___4 = + (FStarC_Syntax_Syntax.fv_eq_lid fv1 + FStarC_Parser_Const.fext_on_domain_lid) + || + (FStarC_Syntax_Syntax.fv_eq_lid fv1 + FStarC_Parser_Const.fext_on_domain_g_lid) in + if uu___4 then f else index1 + | uu___3 -> index1) in + let uu___1 = index in + match uu___1 with + | (index1, uu___2) -> + FStarC_Compiler_List.iter + (fun mutual -> + let uu___3 = + let uu___4 = fext_on_domain_index_sub_term index1 in + ty_occurs_in mutual uu___4 in + if uu___3 + then + let uu___4 = + let uu___5 = FStarC_Ident.string_of_lid mutual in + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term index1 in + let uu___7 = FStarC_Ident.string_of_lid fv in + FStarC_Compiler_Util.format3 + "Type %s is not strictly positive since it instantiates a non-uniformly recursive parameter or index %s of %s" + uu___5 uu___6 uu___7 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) index1 + FStarC_Errors_Codes.Error_InductiveTypeNotSatisfyPositivityCondition + () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4) + else ()) mutuals1 in + let no_occurrence_in_indexes fv mutuals1 indexes = + FStarC_Compiler_List.iter (no_occurrence_in_index fv mutuals1) + indexes in + let uu___1 = FStarC_Syntax_Util.head_and_args t in + match uu___1 with + | (head, args) -> + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst head in + uu___3.FStarC_Syntax_Syntax.n in + (match uu___2 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let uu___3 = + FStarC_TypeChecker_Env.num_inductive_uniform_ty_params + env + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + (match uu___3 with + | FStar_Pervasives_Native.None -> () + | FStar_Pervasives_Native.Some n -> + if (FStarC_Compiler_List.length args) <= n + then () + else + (let uu___5 = + FStarC_TypeChecker_Env.try_lookup_lid env + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + match uu___5 with + | FStar_Pervasives_Native.None -> + no_occurrence_in_indexes + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + mutuals args + | FStar_Pervasives_Native.Some + ((_us, i_typ), uu___6) -> + (debug_positivity env + (fun uu___8 -> + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.format2 + "Checking arity indexes of %s (num uniform params = %s)" + uu___9 (Prims.string_of_int n)); + (let uu___8 = + FStarC_Compiler_List.splitAt n args in + match uu___8 with + | (params, indices) -> + let inst_i_typ = + apply_constr_arrow + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + i_typ params in + let uu___9 = + FStarC_Syntax_Util.arrow_formals + inst_i_typ in + (match uu___9 with + | (formals, _sort) -> + let rec aux subst formals1 indices1 + = + match (formals1, indices1) with + | (uu___10, []) -> () + | (f::formals2, i::indices2) -> + let f_t = + FStarC_Syntax_Subst.subst + subst + (f.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + ((let uu___11 = + may_be_an_arity env f_t in + if uu___11 + then + (debug_positivity env + (fun uu___13 -> + let uu___14 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + (FStar_Pervasives_Native.fst + i) in + let uu___15 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + f_t in + FStarC_Compiler_Util.format2 + "Checking %s : %s (arity)" + uu___14 uu___15); + no_occurrence_in_index + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + mutuals i) + else + debug_positivity env + (fun uu___13 -> + let uu___14 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + (FStar_Pervasives_Native.fst + i) in + let uu___15 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + f_t in + FStarC_Compiler_Util.format2 + "Skipping %s : %s (non-arity)" + uu___14 uu___15)); + (let subst1 = + (FStarC_Syntax_Syntax.NT + ((f.FStarC_Syntax_Syntax.binder_bv), + (FStar_Pervasives_Native.fst + i))) + :: subst in + aux subst1 formals2 indices2)) + | ([], uu___10) -> + no_occurrence_in_indexes + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + mutuals indices1 in + aux [] formals indices))))) + | uu___3 -> ())) +let (mutuals_unused_in_type : + FStarC_Ident.lident Prims.list -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> Prims.bool) + = + fun mutuals -> + fun t -> + let mutuals_occur_in t1 = + FStarC_Compiler_Util.for_some (fun lid -> ty_occurs_in lid t1) + mutuals in + let rec ok t1 = + let uu___ = + let uu___1 = mutuals_occur_in t1 in Prims.op_Negation uu___1 in + if uu___ + then true + else + (let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress t1 in + uu___3.FStarC_Syntax_Syntax.n in + match uu___2 with + | FStarC_Syntax_Syntax.Tm_bvar uu___3 -> true + | FStarC_Syntax_Syntax.Tm_name uu___3 -> true + | FStarC_Syntax_Syntax.Tm_constant uu___3 -> true + | FStarC_Syntax_Syntax.Tm_type uu___3 -> true + | FStarC_Syntax_Syntax.Tm_fvar uu___3 -> false + | FStarC_Syntax_Syntax.Tm_uinst uu___3 -> false + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs; + FStarC_Syntax_Syntax.body = t2; + FStarC_Syntax_Syntax.rc_opt = uu___3;_} + -> (binders_ok bs) && (ok t2) + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = c;_} + -> (binders_ok bs) && (ok_comp c) + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = bv; + FStarC_Syntax_Syntax.phi = t2;_} + -> (ok bv.FStarC_Syntax_Syntax.sort) && (ok t2) + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = args;_} + -> + let uu___3 = mutuals_occur_in head in + if uu___3 + then false + else + FStarC_Compiler_List.for_all + (fun uu___5 -> + match uu___5 with + | (a, qual) -> + (match qual with + | FStar_Pervasives_Native.None -> false + | FStar_Pervasives_Native.Some q -> + FStarC_Syntax_Util.contains_unused_attribute + q.FStarC_Syntax_Syntax.aqual_attributes) + || (ok a)) args + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = t2; + FStarC_Syntax_Syntax.ret_opt = uu___3; + FStarC_Syntax_Syntax.brs = branches; + FStarC_Syntax_Syntax.rc_opt1 = uu___4;_} + -> + (ok t2) && + (FStarC_Compiler_List.for_all + (fun uu___5 -> + match uu___5 with | (uu___6, uu___7, br) -> ok br) + branches) + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t2; + FStarC_Syntax_Syntax.asc = asc; + FStarC_Syntax_Syntax.eff_opt = uu___3;_} + -> ok t2 + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (uu___3, lbs); + FStarC_Syntax_Syntax.body1 = t2;_} + -> + (FStarC_Compiler_List.for_all + (fun lb -> + (ok lb.FStarC_Syntax_Syntax.lbtyp) && + (ok lb.FStarC_Syntax_Syntax.lbdef)) lbs) + && (ok t2) + | FStarC_Syntax_Syntax.Tm_uvar uu___3 -> false + | FStarC_Syntax_Syntax.Tm_delayed uu___3 -> false + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t2; + FStarC_Syntax_Syntax.meta = uu___3;_} + -> ok t2 + | uu___3 -> false) + and binders_ok bs = + FStarC_Compiler_List.for_all + (fun b -> + ok (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort) + bs + and ok_comp c = + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total t1 -> ok t1 + | FStarC_Syntax_Syntax.GTotal t1 -> ok t1 + | FStarC_Syntax_Syntax.Comp c1 -> + (ok c1.FStarC_Syntax_Syntax.result_typ) && + (FStarC_Compiler_List.for_all + (fun uu___ -> match uu___ with | (a, uu___1) -> ok a) + c1.FStarC_Syntax_Syntax.effect_args) in + ok t +type unfolded_memo_elt = + (FStarC_Ident.lident * FStarC_Syntax_Syntax.args * Prims.int) Prims.list +type unfolded_memo_t = unfolded_memo_elt FStarC_Compiler_Effect.ref +let (already_unfolded : + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.args -> + unfolded_memo_t -> FStarC_TypeChecker_Env.env_t -> Prims.bool) + = + fun ilid -> + fun args -> + fun unfolded -> + fun env -> + let uu___ = FStarC_Compiler_Effect.op_Bang unfolded in + FStarC_Compiler_List.existsML + (fun uu___1 -> + match uu___1 with + | (lid, l, n) -> + ((FStarC_Ident.lid_equals lid ilid) && + ((FStarC_Compiler_List.length args) >= n)) + && + (let args1 = + let uu___2 = FStarC_Compiler_List.splitAt n args in + FStar_Pervasives_Native.fst uu___2 in + FStarC_Compiler_List.fold_left2 + (fun b -> + fun a -> + fun a' -> + b && + (FStarC_TypeChecker_Rel.teq_nosmt_force env + (FStar_Pervasives_Native.fst a) + (FStar_Pervasives_Native.fst a'))) true + args1 l)) uu___ +let rec (ty_strictly_positive_in_type : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident Prims.list -> + FStarC_Syntax_Syntax.term -> unfolded_memo_t -> Prims.bool) + = + fun env -> + fun mutuals -> + fun in_type -> + fun unfolded -> + let in_type1 = normalize env in_type in + debug_positivity env + (fun uu___1 -> + let uu___2 = string_of_lids mutuals in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + in_type1 in + FStarC_Compiler_Util.format2 + "Checking strict positivity of {%s} in type, after normalization %s " + uu___2 uu___3); + (let uu___1 = + FStarC_Compiler_List.for_all + (fun mutual -> + let uu___2 = ty_occurs_in mutual in_type1 in + Prims.op_Negation uu___2) mutuals in + if uu___1 + then true + else + (debug_positivity env + (fun uu___4 -> "ty does occur in this type"); + (let uu___4 = + let uu___5 = FStarC_Syntax_Subst.compress in_type1 in + uu___5.FStarC_Syntax_Syntax.n in + match uu___4 with + | FStarC_Syntax_Syntax.Tm_fvar uu___5 -> + (debug_positivity env + (fun uu___7 -> + "Checking strict positivity in an fvar/Tm_uinst/Tm_type, return true"); + true) + | FStarC_Syntax_Syntax.Tm_uinst uu___5 -> + (debug_positivity env + (fun uu___7 -> + "Checking strict positivity in an fvar/Tm_uinst/Tm_type, return true"); + true) + | FStarC_Syntax_Syntax.Tm_type uu___5 -> + (debug_positivity env + (fun uu___7 -> + "Checking strict positivity in an fvar/Tm_uinst/Tm_type, return true"); + true) + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t; + FStarC_Syntax_Syntax.asc = uu___5; + FStarC_Syntax_Syntax.eff_opt = uu___6;_} + -> ty_strictly_positive_in_type env mutuals t unfolded + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t; + FStarC_Syntax_Syntax.meta = uu___5;_} + -> ty_strictly_positive_in_type env mutuals t unfolded + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = t; + FStarC_Syntax_Syntax.args = args;_} + -> + let fv_or_name_opt = term_as_fv_or_name t in + (match fv_or_name_opt with + | FStar_Pervasives_Native.None -> + (debug_positivity env + (fun uu___6 -> + let uu___7 = string_of_lids mutuals in + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.format2 + "Failed to check positivity of %s in a term with head %s" + uu___7 uu___8); + false) + | FStar_Pervasives_Native.Some (FStar_Pervasives.Inr x) + -> + let uu___5 = FStarC_TypeChecker_Env.lookup_bv env x in + (match uu___5 with + | (head_ty, _pos) -> + (debug_positivity env + (fun uu___7 -> + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + in_type1 in + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_bv x in + let uu___10 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + head_ty in + FStarC_Compiler_Util.format3 + "Tm_app, head bv, in_type=%s, head_bv=%s, head_ty=%s" + uu___8 uu___9 uu___10); + ty_strictly_positive_in_args env mutuals + head_ty args unfolded)) + | FStar_Pervasives_Native.Some (FStar_Pervasives.Inl + (fv, us)) -> + let uu___5 = + FStarC_Compiler_List.existsML + (FStarC_Ident.lid_equals + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v) + mutuals in + if uu___5 + then + (debug_positivity env + (fun uu___7 -> + let uu___8 = + FStarC_Ident.string_of_lid + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + FStarC_Compiler_Util.format1 + "Checking strict positivity in the Tm_app node where head lid is %s itself, checking that ty does not occur in the arguments" + uu___8); + FStarC_Compiler_List.for_all + (fun uu___7 -> + match uu___7 with + | (t1, uu___8) -> + mutuals_unused_in_type mutuals t1) args) + else + (debug_positivity env + (fun uu___8 -> + let uu___9 = string_of_lids mutuals in + FStarC_Compiler_Util.format1 + "Checking strict positivity in the Tm_app node, head lid is not in %s, so checking nested positivity" + uu___9); + ty_strictly_positive_in_arguments_to_fvar env + mutuals in_type1 + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + us args unfolded)) + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = uu___5; + FStarC_Syntax_Syntax.comp = c;_} + -> + (debug_positivity env + (fun uu___7 -> "Checking strict positivity in Tm_arrow"); + (let check_comp = + (FStarC_Syntax_Util.is_pure_or_ghost_comp c) || + (let uu___7 = + let uu___8 = + FStarC_TypeChecker_Env.norm_eff_name env + (FStarC_Syntax_Util.comp_effect_name c) in + FStarC_TypeChecker_Env.lookup_effect_quals env + uu___8 in + FStarC_Compiler_List.contains + FStarC_Syntax_Syntax.TotalEffect uu___7) in + if Prims.op_Negation check_comp + then + (debug_positivity env + (fun uu___8 -> + "Checking strict positivity , the arrow is impure, so return true"); + true) + else + (debug_positivity env + (fun uu___9 -> + "Checking strict positivity for an arrow, checking that ty does not occur in the binders, and that it is strictly positive in the return type"); + (let uu___9 = + FStarC_Syntax_Util.arrow_formals_comp in_type1 in + match uu___9 with + | (sbs, c1) -> + let return_type = + FStarC_Syntax_Util.comp_result c1 in + let ty_lid_not_to_left_of_arrow = + FStarC_Compiler_List.for_all + (fun uu___10 -> + match uu___10 with + | { FStarC_Syntax_Syntax.binder_bv = b; + FStarC_Syntax_Syntax.binder_qual = + uu___11; + FStarC_Syntax_Syntax.binder_positivity + = uu___12; + FStarC_Syntax_Syntax.binder_attrs = + uu___13;_} + -> + mutuals_unused_in_type mutuals + b.FStarC_Syntax_Syntax.sort) sbs in + if ty_lid_not_to_left_of_arrow + then + let uu___10 = + FStarC_TypeChecker_Env.push_binders env sbs in + ty_strictly_positive_in_type uu___10 mutuals + return_type unfolded + else false)))) + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = bv; + FStarC_Syntax_Syntax.phi = f;_} + -> + (debug_positivity env + (fun uu___6 -> + "Checking strict positivity in an Tm_refine, recur in the bv sort)"); + (let uu___6 = + let uu___7 = + let uu___8 = FStarC_Syntax_Syntax.mk_binder bv in + [uu___8] in + FStarC_Syntax_Subst.open_term uu___7 f in + match uu___6 with + | (b::[], f1) -> + let uu___7 = + ty_strictly_positive_in_type env mutuals + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort + unfolded in + if uu___7 + then + let env1 = + FStarC_TypeChecker_Env.push_binders env [b] in + ty_strictly_positive_in_type env1 mutuals f1 + unfolded + else false)) + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = scrutinee; + FStarC_Syntax_Syntax.ret_opt = uu___5; + FStarC_Syntax_Syntax.brs = branches; + FStarC_Syntax_Syntax.rc_opt1 = uu___6;_} + -> + (debug_positivity env + (fun uu___8 -> + "Checking strict positivity in an Tm_match, recur in the branches)"); + (let uu___8 = + FStarC_Compiler_List.existsML + (fun mutual -> ty_occurs_in mutual scrutinee) + mutuals in + if uu___8 + then + FStarC_Compiler_List.for_all + (fun uu___9 -> + match uu___9 with + | (p, uu___10, t) -> + let bs = + let uu___11 = + FStarC_Syntax_Syntax.pat_bvs p in + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.mk_binder uu___11 in + let uu___11 = + FStarC_Syntax_Subst.open_term bs t in + (match uu___11 with + | (bs1, t1) -> + let uu___12 = + FStarC_Compiler_List.fold_left + (fun uu___13 -> + fun b -> + match uu___13 with + | (t2, lids) -> + let uu___14 = + name_as_fv_in_t t2 + b.FStarC_Syntax_Syntax.binder_bv in + (match uu___14 with + | (t3, lid) -> + (t3, (lid :: lids)))) + (t1, mutuals) bs1 in + (match uu___12 with + | (t2, mutuals1) -> + ty_strictly_positive_in_type env + mutuals1 t2 unfolded))) branches + else + FStarC_Compiler_List.for_all + (fun uu___10 -> + match uu___10 with + | (p, uu___11, t) -> + let bs = + let uu___12 = + FStarC_Syntax_Syntax.pat_bvs p in + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.mk_binder uu___12 in + let uu___12 = + FStarC_Syntax_Subst.open_term bs t in + (match uu___12 with + | (bs1, t1) -> + let uu___13 = + FStarC_TypeChecker_Env.push_binders + env bs1 in + ty_strictly_positive_in_type uu___13 + mutuals t1 unfolded)) branches)) + | FStarC_Syntax_Syntax.Tm_abs uu___5 -> + let uu___6 = FStarC_Syntax_Util.abs_formals in_type1 in + (match uu___6 with + | (bs, body, uu___7) -> + let rec aux env1 bs1 = + match bs1 with + | [] -> + ty_strictly_positive_in_type env1 mutuals body + unfolded + | b::bs2 -> + let uu___8 = + ty_strictly_positive_in_type env1 mutuals + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort + unfolded in + if uu___8 + then + let env2 = + FStarC_TypeChecker_Env.push_binders env1 + [b] in + aux env2 bs2 + else false in + aux env bs) + | uu___5 -> + (debug_positivity env + (fun uu___7 -> + let uu___8 = + FStarC_Class_Tagged.tag_of + FStarC_Syntax_Syntax.tagged_term in_type1 in + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term in_type1 in + FStarC_Compiler_Util.format2 + "Checking strict positivity, unexpected tag: %s and term %s" + uu___8 uu___9); + false)))) +and (ty_strictly_positive_in_args : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident Prims.list -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.args -> unfolded_memo_t -> Prims.bool) + = + fun env -> + fun mutuals -> + fun head_t -> + fun args -> + fun unfolded -> + let uu___ = FStarC_Syntax_Util.arrow_formals head_t in + match uu___ with + | (bs, uu___1) -> + let rec aux bs1 args1 = + match (bs1, args1) with + | (uu___2, []) -> true + | ([], uu___2) -> + FStarC_Compiler_List.for_all + (fun uu___3 -> + match uu___3 with + | (arg, uu___4) -> + mutuals_unused_in_type mutuals arg) args1 + | (b::bs2, (arg, uu___2)::args2) -> + (debug_positivity env + (fun uu___4 -> + let uu___5 = string_of_lids mutuals in + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term arg in + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_binder b in + FStarC_Compiler_Util.format3 + "Checking positivity of %s in argument %s and binder %s" + uu___5 uu___6 uu___7); + (let this_occurrence_ok = + ((mutuals_unused_in_type mutuals arg) || + (FStarC_Syntax_Util.is_binder_unused b)) + || + ((FStarC_Syntax_Util.is_binder_strictly_positive + b) + && + (ty_strictly_positive_in_type env mutuals arg + unfolded)) in + if Prims.op_Negation this_occurrence_ok + then + (debug_positivity env + (fun uu___5 -> + let uu___6 = string_of_lids mutuals in + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term arg in + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_binder b in + FStarC_Compiler_Util.format3 + "Failed checking positivity of %s in argument %s and binder %s" + uu___6 uu___7 uu___8); + false) + else aux bs2 args2)) in + aux bs args +and (ty_strictly_positive_in_arguments_to_fvar : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident Prims.list -> + FStarC_Syntax_Syntax.term -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> unfolded_memo_t -> Prims.bool) + = + fun env -> + fun mutuals -> + fun t -> + fun fv -> + fun us -> + fun args -> + fun unfolded -> + debug_positivity env + (fun uu___1 -> + let uu___2 = string_of_lids mutuals in + let uu___3 = FStarC_Ident.string_of_lid fv in + let uu___4 = FStarC_Syntax_Print.args_to_string args in + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.format4 + "Checking positivity of %s in application of fv %s to %s (t=%s)" + uu___2 uu___3 uu___4 uu___5); + (let uu___1 = FStarC_TypeChecker_Env.is_datacon env fv in + if uu___1 + then + FStarC_Compiler_List.for_all + (fun uu___2 -> + match uu___2 with + | (a, uu___3) -> + ty_strictly_positive_in_type env mutuals a + unfolded) args + else + (let fv_ty = + let uu___3 = + FStarC_TypeChecker_Env.try_lookup_lid env fv in + match uu___3 with + | FStar_Pervasives_Native.Some + ((uu___4, fv_ty1), uu___5) -> fv_ty1 + | uu___4 -> + let uu___5 = + let uu___6 = FStarC_Ident.string_of_lid fv in + FStarC_Compiler_Util.format1 + "Type of %s not found when checking positivity" + uu___6 in + FStarC_Errors.raise_error + FStarC_Ident.hasrange_lident fv + FStarC_Errors_Codes.Error_InductiveTypeNotSatisfyPositivityCondition + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___5) in + let uu___3 = + FStarC_TypeChecker_Env.datacons_of_typ env fv in + match uu___3 with + | (b, idatas) -> + if Prims.op_Negation b + then + ty_strictly_positive_in_args env mutuals fv_ty args + unfolded + else + (check_no_index_occurrences_in_arities env mutuals + t; + (let ilid = fv in + let num_uniform_params = + let uu___6 = + FStarC_TypeChecker_Env.num_inductive_uniform_ty_params + env ilid in + match uu___6 with + | FStar_Pervasives_Native.None -> + failwith "Unexpected type" + | FStar_Pervasives_Native.Some n -> n in + let uu___6 = + FStarC_Compiler_List.splitAt num_uniform_params + args in + match uu___6 with + | (params, _rest) -> + let uu___7 = + already_unfolded ilid args unfolded env in + if uu___7 + then + (debug_positivity env + (fun uu___9 -> + "Checking nested positivity, we have already unfolded this inductive with these args"); + true) + else + (debug_positivity env + (fun uu___10 -> + let uu___11 = + FStarC_Ident.string_of_lid ilid in + let uu___12 = + FStarC_Syntax_Print.args_to_string + params in + FStarC_Compiler_Util.format3 + "Checking positivity in datacon, number of type parameters is %s, adding %s %s to the memo table" + (Prims.string_of_int + num_uniform_params) uu___11 + uu___12); + (let uu___11 = + let uu___12 = + FStarC_Compiler_Effect.op_Bang + unfolded in + FStar_List_Tot_Base.op_At uu___12 + [(ilid, params, num_uniform_params)] in + FStarC_Compiler_Effect.op_Colon_Equals + unfolded uu___11); + FStarC_Compiler_List.for_all + (fun d -> + ty_strictly_positive_in_datacon_of_applied_inductive + env mutuals d ilid us args + num_uniform_params unfolded) idatas))))) +and (ty_strictly_positive_in_datacon_of_applied_inductive : + FStarC_TypeChecker_Env.env_t -> + FStarC_Ident.lident Prims.list -> + FStarC_Ident.lident -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + Prims.int -> unfolded_memo_t -> Prims.bool) + = + fun env -> + fun mutuals -> + fun dlid -> + fun ilid -> + fun us -> + fun args -> + fun num_ibs -> + fun unfolded -> + debug_positivity env + (fun uu___1 -> + let uu___2 = string_of_lids mutuals in + let uu___3 = FStarC_Ident.string_of_lid dlid in + let uu___4 = FStarC_Ident.string_of_lid ilid in + FStarC_Compiler_Util.format3 + "Checking positivity of %s in data constructor %s : %s" + uu___2 uu___3 uu___4); + (let dt = + let uu___1 = + FStarC_TypeChecker_Env.try_lookup_and_inst_lid env us + dlid in + match uu___1 with + | FStar_Pervasives_Native.Some (t, uu___2) -> t + | FStar_Pervasives_Native.None -> + let uu___2 = FStarC_Ident.range_of_lid dlid in + let uu___3 = + let uu___4 = FStarC_Ident.string_of_lid dlid in + FStarC_Compiler_Util.format1 + "Data constructor %s not found when checking positivity" + uu___4 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range uu___2 + FStarC_Errors_Codes.Error_InductiveTypeNotSatisfyPositivityCondition + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___3) in + debug_positivity env + (fun uu___2 -> + let uu___3 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term dt in + let uu___4 = FStarC_Syntax_Print.args_to_string args in + FStarC_Compiler_Util.format3 + "Checking positivity in the data constructor type: %s\n\tnum_ibs=%s, args=%s," + uu___3 (Prims.string_of_int num_ibs) uu___4); + (let uu___2 = FStarC_Compiler_List.splitAt num_ibs args in + match uu___2 with + | (args1, rest) -> + let applied_dt = apply_constr_arrow dlid dt args1 in + (debug_positivity env + (fun uu___4 -> + let uu___5 = FStarC_Ident.string_of_lid dlid in + let uu___6 = + FStarC_Syntax_Print.args_to_string args1 in + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + applied_dt in + FStarC_Compiler_Util.format3 + "Applied data constructor type: %s %s : %s" + uu___5 uu___6 uu___7); + (let uu___4 = + FStarC_Syntax_Util.arrow_formals applied_dt in + match uu___4 with + | (fields, t) -> + (check_no_index_occurrences_in_arities env + mutuals t; + (let rec strictly_positive_in_all_fields env1 + fields1 = + match fields1 with + | [] -> true + | f::fields2 -> + (debug_positivity env1 + (fun uu___7 -> + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_bv + f.FStarC_Syntax_Syntax.binder_bv in + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + (f.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + FStarC_Compiler_Util.format2 + "Checking field %s : %s for indexes and positivity" + uu___8 uu___9); + check_no_index_occurrences_in_arities + env1 mutuals + (f.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort; + (let uu___8 = + ty_strictly_positive_in_type env1 + mutuals + (f.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort + unfolded in + if uu___8 + then + let env2 = + FStarC_TypeChecker_Env.push_binders + env1 [f] in + strictly_positive_in_all_fields + env2 fields2 + else false)) in + strictly_positive_in_all_fields env fields)))))) +let (name_strictly_positive_in_type : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.bv -> FStarC_Syntax_Syntax.term -> Prims.bool) + = + fun env -> + fun bv -> + fun t -> + let uu___ = name_as_fv_in_t t bv in + match uu___ with + | (t1, fv_lid) -> + let uu___1 = FStarC_Compiler_Util.mk_ref [] in + ty_strictly_positive_in_type env [fv_lid] t1 uu___1 +let (name_unused_in_type : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.bv -> FStarC_Syntax_Syntax.term -> Prims.bool) + = + fun env -> + fun bv -> + fun t -> + let uu___ = name_as_fv_in_t t bv in + match uu___ with + | (t1, fv_lid) -> + (let uu___1 = ty_occurs_in fv_lid t1 in Prims.op_Negation uu___1) + || + (let uu___1 = normalize env t1 in + mutuals_unused_in_type [fv_lid] uu___1) +let (ty_strictly_positive_in_datacon_decl : + FStarC_TypeChecker_Env.env_t -> + FStarC_Ident.lident Prims.list -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.universes -> unfolded_memo_t -> Prims.bool) + = + fun env -> + fun mutuals -> + fun dlid -> + fun ty_bs -> + fun us -> + fun unfolded -> + let dt = + let uu___ = + FStarC_TypeChecker_Env.try_lookup_and_inst_lid env us dlid in + match uu___ with + | FStar_Pervasives_Native.Some (t, uu___1) -> t + | FStar_Pervasives_Native.None -> + let uu___1 = + let uu___2 = FStarC_Ident.string_of_lid dlid in + FStarC_Compiler_Util.format1 + "Error looking up data constructor %s when checking positivity" + uu___2 in + FStarC_Errors.raise_error FStarC_Ident.hasrange_lident + dlid + FStarC_Errors_Codes.Error_InductiveTypeNotSatisfyPositivityCondition + () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) in + debug_positivity env + (fun uu___1 -> + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + dt in + Prims.strcat "Checking data constructor type: " uu___2); + (let uu___1 = FStarC_Syntax_Util.args_of_binders ty_bs in + match uu___1 with + | (ty_bs1, args) -> + let dt1 = apply_constr_arrow dlid dt args in + let uu___2 = FStarC_Syntax_Util.arrow_formals dt1 in + (match uu___2 with + | (fields, return_type) -> + (check_no_index_occurrences_in_arities env mutuals + return_type; + (let check_annotated_binders_are_strictly_positive_in_field + f = + let incorrectly_annotated_binder = + FStarC_Compiler_List.tryFind + (fun b -> + ((FStarC_Syntax_Util.is_binder_unused b) + && + (let uu___4 = + name_unused_in_type env + b.FStarC_Syntax_Syntax.binder_bv + (f.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + Prims.op_Negation uu___4)) + || + ((FStarC_Syntax_Util.is_binder_strictly_positive + b) + && + (let uu___4 = + name_strictly_positive_in_type env + b.FStarC_Syntax_Syntax.binder_bv + (f.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + Prims.op_Negation uu___4))) ty_bs1 in + match incorrectly_annotated_binder with + | FStar_Pervasives_Native.None -> () + | FStar_Pervasives_Native.Some b -> + let uu___4 = + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_binder b in + FStarC_Compiler_Util.format2 + "Binder %s is marked %s, but its use in the definition is not" + uu___5 + (if + FStarC_Syntax_Util.is_binder_strictly_positive + b + then "strictly_positive" + else "unused") in + FStarC_Errors.raise_error + FStarC_Syntax_Syntax.hasRange_binder b + FStarC_Errors_Codes.Error_InductiveTypeNotSatisfyPositivityCondition + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4) in + let rec check_all_fields env1 fields1 = + match fields1 with + | [] -> true + | field::fields2 -> + (check_annotated_binders_are_strictly_positive_in_field + field; + (let uu___5 = + let uu___6 = + ty_strictly_positive_in_type env1 + mutuals + (field.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort + unfolded in + Prims.op_Negation uu___6 in + if uu___5 + then false + else + (let env2 = + FStarC_TypeChecker_Env.push_binders + env1 [field] in + check_all_fields env2 fields2))) in + check_all_fields env fields)))) +let (check_strict_positivity : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident Prims.list -> + FStarC_Syntax_Syntax.sigelt -> Prims.bool) + = + fun env -> + fun mutuals -> + fun ty -> + let unfolded_inductives = FStarC_Compiler_Util.mk_ref [] in + let uu___ = open_sig_inductive_typ env ty in + match uu___ with + | (env1, (ty_lid, ty_us, ty_params)) -> + let mutuals1 = + FStarC_Compiler_List.filter + (fun m -> + let uu___1 = FStarC_TypeChecker_Env.is_datacon env1 m in + Prims.op_Negation uu___1) mutuals in + let mutuals2 = + let uu___1 = + FStarC_Compiler_List.existsML + (FStarC_Ident.lid_equals ty_lid) mutuals1 in + if uu___1 then mutuals1 else ty_lid :: mutuals1 in + let datacons = + let uu___1 = FStarC_TypeChecker_Env.datacons_of_typ env1 ty_lid in + FStar_Pervasives_Native.snd uu___1 in + let us = + FStarC_Compiler_List.map + (fun uu___1 -> FStarC_Syntax_Syntax.U_name uu___1) ty_us in + FStarC_Compiler_List.for_all + (fun d -> + ty_strictly_positive_in_datacon_decl env1 mutuals2 d + ty_params us unfolded_inductives) datacons +let (check_exn_strict_positivity : + FStarC_TypeChecker_Env.env -> FStarC_Ident.lident -> Prims.bool) = + fun env -> + fun data_ctor_lid -> + let unfolded_inductives = FStarC_Compiler_Util.mk_ref [] in + ty_strictly_positive_in_datacon_decl env [FStarC_Parser_Const.exn_lid] + data_ctor_lid [] [] unfolded_inductives \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops.ml new file mode 100644 index 00000000000..26c515379aa --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops.ml @@ -0,0 +1,484 @@ +open Prims +let (as_primitive_step : + Prims.bool -> + (FStarC_Ident.lident * Prims.int * Prims.int * + FStarC_TypeChecker_Primops_Base.interp_t * + (FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args -> + FStarC_TypeChecker_NBETerm.t FStar_Pervasives_Native.option)) + -> FStarC_TypeChecker_Primops_Base.primitive_step) + = + fun is_strong -> + fun uu___ -> + match uu___ with + | (l, arity, u_arity, f, f_nbe) -> + FStarC_TypeChecker_Primops_Base.as_primitive_step_nbecbs is_strong + (l, arity, u_arity, f, + (fun cb -> fun univs -> fun args -> f_nbe univs args)) +let (and_op : + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = + fun psc -> + fun _norm_cb -> + fun _us -> + fun args -> + match args with + | (a1, FStar_Pervasives_Native.None)::(a2, + FStar_Pervasives_Native.None)::[] + -> + let uu___ = + FStarC_TypeChecker_Primops_Base.try_unembed_simple + FStarC_Syntax_Embeddings.e_bool a1 in + (match uu___ with + | FStar_Pervasives_Native.Some (false) -> + let uu___1 = + FStarC_TypeChecker_Primops_Base.embed_simple + FStarC_Syntax_Embeddings.e_bool + psc.FStarC_TypeChecker_Primops_Base.psc_range false in + FStar_Pervasives_Native.Some uu___1 + | FStar_Pervasives_Native.Some (true) -> + FStar_Pervasives_Native.Some a2 + | uu___1 -> FStar_Pervasives_Native.None) + | uu___ -> failwith "Unexpected number of arguments" +let (or_op : + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = + fun psc -> + fun _norm_cb -> + fun _us -> + fun args -> + match args with + | (a1, FStar_Pervasives_Native.None)::(a2, + FStar_Pervasives_Native.None)::[] + -> + let uu___ = + FStarC_TypeChecker_Primops_Base.try_unembed_simple + FStarC_Syntax_Embeddings.e_bool a1 in + (match uu___ with + | FStar_Pervasives_Native.Some (true) -> + let uu___1 = + FStarC_TypeChecker_Primops_Base.embed_simple + FStarC_Syntax_Embeddings.e_bool + psc.FStarC_TypeChecker_Primops_Base.psc_range true in + FStar_Pervasives_Native.Some uu___1 + | FStar_Pervasives_Native.Some (false) -> + FStar_Pervasives_Native.Some a2 + | uu___1 -> FStar_Pervasives_Native.None) + | uu___ -> failwith "Unexpected number of arguments" +let (division_modulus_op : + (FStarC_BigInt.t -> FStarC_BigInt.t -> FStarC_BigInt.t) -> + FStarC_BigInt.t -> + FStarC_BigInt.t -> FStarC_BigInt.t FStar_Pervasives_Native.option) + = + fun f -> + fun x -> + fun y -> + let uu___ = + let uu___1 = FStarC_BigInt.to_int_fs y in uu___1 <> Prims.int_zero in + if uu___ + then let uu___1 = f x y in FStar_Pervasives_Native.Some uu___1 + else FStar_Pervasives_Native.None +let (simple_ops : FStarC_TypeChecker_Primops_Base.primitive_step Prims.list) + = + let uu___ = + FStarC_TypeChecker_Primops_Base.mk1 Prims.int_zero + FStarC_Parser_Const.string_of_int_lid FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string + (fun z -> + let uu___1 = FStarC_BigInt.to_int_fs z in Prims.string_of_int uu___1) in + let uu___1 = + let uu___2 = + FStarC_TypeChecker_Primops_Base.mk1 Prims.int_zero + FStarC_Parser_Const.int_of_string_lid + FStarC_Syntax_Embeddings.e_string FStarC_TypeChecker_NBETerm.e_string + (FStarC_Syntax_Embeddings.e_option FStarC_Syntax_Embeddings.e_int) + (FStarC_TypeChecker_NBETerm.e_option FStarC_TypeChecker_NBETerm.e_int) + (fun uu___3 -> + (fun s -> + let uu___3 = FStarC_Compiler_Util.safe_int_of_string s in + Obj.magic + (FStarC_Class_Monad.fmap FStarC_Class_Monad.monad_option () + () + (fun uu___4 -> (Obj.magic FStarC_BigInt.of_int_fs) uu___4) + (Obj.magic uu___3))) uu___3) in + let uu___3 = + let uu___4 = + FStarC_TypeChecker_Primops_Base.mk1 Prims.int_zero + FStarC_Parser_Const.string_of_bool_lid + FStarC_Syntax_Embeddings.e_bool FStarC_TypeChecker_NBETerm.e_bool + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string Prims.string_of_bool in + let uu___5 = + let uu___6 = + FStarC_TypeChecker_Primops_Base.mk1 Prims.int_zero + FStarC_Parser_Const.bool_of_string_lid + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string + (FStarC_Syntax_Embeddings.e_option + FStarC_Syntax_Embeddings.e_bool) + (FStarC_TypeChecker_NBETerm.e_option + FStarC_TypeChecker_NBETerm.e_bool) + (fun uu___7 -> + match uu___7 with + | "true" -> FStar_Pervasives_Native.Some true + | "false" -> FStar_Pervasives_Native.Some false + | uu___8 -> FStar_Pervasives_Native.None) in + let uu___7 = + let uu___8 = + FStarC_TypeChecker_Primops_Base.mk1 Prims.int_zero + FStarC_Parser_Const.op_Minus FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int FStarC_BigInt.minus_big_int in + let uu___9 = + let uu___10 = + FStarC_TypeChecker_Primops_Base.mk2 Prims.int_zero + FStarC_Parser_Const.op_Addition + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int FStarC_BigInt.add_big_int in + let uu___11 = + let uu___12 = + FStarC_TypeChecker_Primops_Base.mk2 Prims.int_zero + FStarC_Parser_Const.op_Subtraction + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int FStarC_BigInt.sub_big_int in + let uu___13 = + let uu___14 = + FStarC_TypeChecker_Primops_Base.mk2 Prims.int_zero + FStarC_Parser_Const.op_Multiply + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int + FStarC_BigInt.mult_big_int in + let uu___15 = + let uu___16 = + FStarC_TypeChecker_Primops_Base.mk2 Prims.int_zero + FStarC_Parser_Const.op_LT + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int + FStarC_Syntax_Embeddings.e_bool + FStarC_TypeChecker_NBETerm.e_bool + FStarC_BigInt.lt_big_int in + let uu___17 = + let uu___18 = + FStarC_TypeChecker_Primops_Base.mk2 Prims.int_zero + FStarC_Parser_Const.op_LTE + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int + FStarC_Syntax_Embeddings.e_bool + FStarC_TypeChecker_NBETerm.e_bool + FStarC_BigInt.le_big_int in + let uu___19 = + let uu___20 = + FStarC_TypeChecker_Primops_Base.mk2 Prims.int_zero + FStarC_Parser_Const.op_GT + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int + FStarC_Syntax_Embeddings.e_bool + FStarC_TypeChecker_NBETerm.e_bool + FStarC_BigInt.gt_big_int in + let uu___21 = + let uu___22 = + FStarC_TypeChecker_Primops_Base.mk2 Prims.int_zero + FStarC_Parser_Const.op_GTE + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int + FStarC_Syntax_Embeddings.e_bool + FStarC_TypeChecker_NBETerm.e_bool + FStarC_BigInt.ge_big_int in + let uu___23 = + let uu___24 = + FStarC_TypeChecker_Primops_Base.mk2' + Prims.int_zero FStarC_Parser_Const.op_Division + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int + (division_modulus_op FStarC_BigInt.div_big_int) + (division_modulus_op FStarC_BigInt.div_big_int) in + let uu___25 = + let uu___26 = + FStarC_TypeChecker_Primops_Base.mk2' + Prims.int_zero FStarC_Parser_Const.op_Modulus + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int + (division_modulus_op + FStarC_BigInt.mod_big_int) + (division_modulus_op + FStarC_BigInt.mod_big_int) in + let uu___27 = + let uu___28 = + FStarC_TypeChecker_Primops_Base.mk1 + Prims.int_zero + FStarC_Parser_Const.op_Negation + FStarC_Syntax_Embeddings.e_bool + FStarC_TypeChecker_NBETerm.e_bool + FStarC_Syntax_Embeddings.e_bool + FStarC_TypeChecker_NBETerm.e_bool + Prims.op_Negation in + let uu___29 = + let uu___30 = + FStarC_TypeChecker_Primops_Base.mk2 + Prims.int_zero + FStarC_Parser_Const.string_concat_lid + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string + FStarC_Syntax_Embeddings.e_string_list + FStarC_TypeChecker_NBETerm.e_string_list + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string + FStarC_Compiler_String.concat in + let uu___31 = + let uu___32 = + FStarC_TypeChecker_Primops_Base.mk2 + Prims.int_zero + FStarC_Parser_Const.string_split_lid + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_char) + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_char) + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string + FStarC_Syntax_Embeddings.e_string_list + FStarC_TypeChecker_NBETerm.e_string_list + FStarC_Compiler_String.split in + let uu___33 = + let uu___34 = + FStarC_TypeChecker_Primops_Base.mk2 + Prims.int_zero + FStarC_Parser_Const.prims_strcat_lid + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string + (fun s1 -> + fun s2 -> Prims.strcat s1 s2) in + let uu___35 = + let uu___36 = + FStarC_TypeChecker_Primops_Base.mk2 + Prims.int_zero + FStarC_Parser_Const.string_compare_lid + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int + (fun s1 -> + fun s2 -> + FStarC_BigInt.of_int_fs + (FStarC_Compiler_String.compare + s1 s2)) in + let uu___37 = + let uu___38 = + FStarC_TypeChecker_Primops_Base.mk1 + Prims.int_zero + FStarC_Parser_Const.string_string_of_list_lid + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_char) + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_char) + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string + FStar_String.string_of_list in + let uu___39 = + let uu___40 = + FStarC_TypeChecker_Primops_Base.mk2 + Prims.int_zero + FStarC_Parser_Const.string_make_lid + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int + FStarC_Syntax_Embeddings.e_char + FStarC_TypeChecker_NBETerm.e_char + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string + (fun x -> + fun y -> + let uu___41 = + FStarC_BigInt.to_int_fs + x in + FStarC_Compiler_String.make + uu___41 y) in + let uu___41 = + let uu___42 = + FStarC_TypeChecker_Primops_Base.mk1 + Prims.int_zero + FStarC_Parser_Const.string_list_of_string_lid + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_char) + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_char) + FStar_String.list_of_string in + let uu___43 = + let uu___44 = + FStarC_TypeChecker_Primops_Base.mk1 + Prims.int_zero + FStarC_Parser_Const.string_lowercase_lid + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string + FStarC_Compiler_String.lowercase in + let uu___45 = + let uu___46 = + FStarC_TypeChecker_Primops_Base.mk1 + Prims.int_zero + FStarC_Parser_Const.string_uppercase_lid + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string + FStarC_Compiler_String.uppercase in + let uu___47 = + let uu___48 = + FStarC_TypeChecker_Primops_Base.mk2 + Prims.int_zero + FStarC_Parser_Const.string_index_lid + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int + FStarC_Syntax_Embeddings.e_char + FStarC_TypeChecker_NBETerm.e_char + FStarC_Compiler_String.index in + let uu___49 = + let uu___50 = + FStarC_TypeChecker_Primops_Base.mk2 + Prims.int_zero + FStarC_Parser_Const.string_index_of_lid + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string + FStarC_Syntax_Embeddings.e_char + FStarC_TypeChecker_NBETerm.e_char + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int + FStarC_Compiler_String.index_of in + let uu___51 = + let uu___52 = + FStarC_TypeChecker_Primops_Base.mk3 + Prims.int_zero + FStarC_Parser_Const.string_sub_lid + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int + FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string + (fun s -> + fun o -> + fun l -> + let uu___53 + = + FStarC_BigInt.to_int_fs + o in + let uu___54 + = + FStarC_BigInt.to_int_fs + l in + FStarC_Compiler_String.substring + s uu___53 + uu___54) in + [uu___52] in + uu___50 :: uu___51 in + uu___48 :: uu___49 in + uu___46 :: uu___47 in + uu___44 :: uu___45 in + uu___42 :: uu___43 in + uu___40 :: uu___41 in + uu___38 :: uu___39 in + uu___36 :: uu___37 in + uu___34 :: uu___35 in + uu___32 :: uu___33 in + uu___30 :: uu___31 in + uu___28 :: uu___29 in + uu___26 :: uu___27 in + uu___24 :: uu___25 in + uu___22 :: uu___23 in + uu___20 :: uu___21 in + uu___18 :: uu___19 in + uu___16 :: uu___17 in + uu___14 :: uu___15 in + uu___12 :: uu___13 in + uu___10 :: uu___11 in + uu___8 :: uu___9 in + uu___6 :: uu___7 in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + uu___ :: uu___1 +let (short_circuit_ops : + FStarC_TypeChecker_Primops_Base.primitive_step Prims.list) = + FStarC_Compiler_List.map (as_primitive_step true) + [(FStarC_Parser_Const.op_And, (Prims.of_int (2)), Prims.int_zero, and_op, + ((fun _us -> FStarC_TypeChecker_NBETerm.and_op))); + (FStarC_Parser_Const.op_Or, (Prims.of_int (2)), Prims.int_zero, or_op, + ((fun _us -> FStarC_TypeChecker_NBETerm.or_op)))] +let (built_in_primitive_steps_list : + FStarC_TypeChecker_Primops_Base.primitive_step Prims.list) = + FStarC_Compiler_List.op_At simple_ops + (FStarC_Compiler_List.op_At short_circuit_ops + (FStarC_Compiler_List.op_At FStarC_TypeChecker_Primops_Issue.ops + (FStarC_Compiler_List.op_At FStarC_TypeChecker_Primops_Array.ops + (FStarC_Compiler_List.op_At + FStarC_TypeChecker_Primops_Sealed.ops + (FStarC_Compiler_List.op_At + FStarC_TypeChecker_Primops_Erased.ops + (FStarC_Compiler_List.op_At + FStarC_TypeChecker_Primops_Docs.ops + (FStarC_Compiler_List.op_At + FStarC_TypeChecker_Primops_MachineInts.ops + (FStarC_Compiler_List.op_At + FStarC_TypeChecker_Primops_Errors_Msg.ops + (FStarC_Compiler_List.op_At + FStarC_TypeChecker_Primops_Range.ops + FStarC_TypeChecker_Primops_Real.ops))))))))) +let (env_dependent_ops : + FStarC_TypeChecker_Env.env_t -> + FStarC_TypeChecker_Primops_Base.primitive_step Prims.list) + = fun env -> FStarC_TypeChecker_Primops_Eq.dec_eq_ops env +let (simplification_ops_list : + FStarC_TypeChecker_Env.env_t -> + FStarC_TypeChecker_Primops_Base.primitive_step Prims.list) + = + fun env -> + let uu___ = FStarC_TypeChecker_Primops_Eq.prop_eq_ops env in + FStarC_Compiler_List.op_At uu___ + FStarC_TypeChecker_Primops_Real.simplify_ops \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_Array.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_Array.ml new file mode 100644 index 00000000000..262d85d9e06 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_Array.ml @@ -0,0 +1,362 @@ +open Prims +let (as_primitive_step : + Prims.bool -> + (FStarC_Ident.lident * Prims.int * Prims.int * + FStarC_TypeChecker_Primops_Base.interp_t * + (FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args -> + FStarC_TypeChecker_NBETerm.t FStar_Pervasives_Native.option)) + -> FStarC_TypeChecker_Primops_Base.primitive_step) + = + fun is_strong -> + fun uu___ -> + match uu___ with + | (l, arity, u_arity, f, f_nbe) -> + FStarC_TypeChecker_Primops_Base.as_primitive_step_nbecbs is_strong + (l, arity, u_arity, f, + (fun cb -> fun univs -> fun args -> f_nbe univs args)) +let (arg_as_int : + FStarC_Syntax_Syntax.arg -> FStarC_BigInt.t FStar_Pervasives_Native.option) + = + fun a -> + FStarC_TypeChecker_Primops_Base.try_unembed_simple + FStarC_Syntax_Embeddings.e_int (FStar_Pervasives_Native.fst a) +let arg_as_list : + 'a . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_Syntax_Syntax.arg -> + 'a Prims.list FStar_Pervasives_Native.option + = + fun e -> + fun a1 -> + FStarC_TypeChecker_Primops_Base.try_unembed_simple + (FStarC_Syntax_Embeddings.e_list e) (FStar_Pervasives_Native.fst a1) +let mixed_binary_op : + 'a 'b 'c . + (FStarC_Syntax_Syntax.arg -> 'a FStar_Pervasives_Native.option) -> + (FStarC_Syntax_Syntax.arg -> 'b FStar_Pervasives_Native.option) -> + (FStarC_Compiler_Range_Type.range -> 'c -> FStarC_Syntax_Syntax.term) + -> + (FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.universes -> + 'a -> 'b -> 'c FStar_Pervasives_Native.option) + -> + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option + = + fun as_a -> + fun as_b -> + fun embed_c -> + fun f -> + fun psc -> + fun norm_cb -> + fun univs -> + fun args -> + match args with + | a1::b1::[] -> + let uu___ = + let uu___1 = as_a a1 in + let uu___2 = as_b b1 in (uu___1, uu___2) in + (match uu___ with + | (FStar_Pervasives_Native.Some a2, + FStar_Pervasives_Native.Some b2) -> + let uu___1 = + f psc.FStarC_TypeChecker_Primops_Base.psc_range + univs a2 b2 in + (match uu___1 with + | FStar_Pervasives_Native.Some c1 -> + let uu___2 = + embed_c + psc.FStarC_TypeChecker_Primops_Base.psc_range + c1 in + FStar_Pervasives_Native.Some uu___2 + | uu___2 -> FStar_Pervasives_Native.None) + | uu___1 -> FStar_Pervasives_Native.None) + | uu___ -> FStar_Pervasives_Native.None +let mixed_ternary_op : + 'a 'b 'c 'd . + (FStarC_Syntax_Syntax.arg -> 'a FStar_Pervasives_Native.option) -> + (FStarC_Syntax_Syntax.arg -> 'b FStar_Pervasives_Native.option) -> + (FStarC_Syntax_Syntax.arg -> 'c FStar_Pervasives_Native.option) -> + (FStarC_Compiler_Range_Type.range -> + 'd -> FStarC_Syntax_Syntax.term) + -> + (FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.universes -> + 'a -> 'b -> 'c -> 'd FStar_Pervasives_Native.option) + -> + FStarC_TypeChecker_Primops_Base.psc -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option + = + fun as_a -> + fun as_b -> + fun as_c -> + fun embed_d -> + fun f -> + fun psc -> + fun norm_cb -> + fun univs -> + fun args -> + match args with + | a1::b1::c1::[] -> + let uu___ = + let uu___1 = as_a a1 in + let uu___2 = as_b b1 in + let uu___3 = as_c c1 in (uu___1, uu___2, uu___3) in + (match uu___ with + | (FStar_Pervasives_Native.Some a2, + FStar_Pervasives_Native.Some b2, + FStar_Pervasives_Native.Some c2) -> + let uu___1 = + f + psc.FStarC_TypeChecker_Primops_Base.psc_range + univs a2 b2 c2 in + (match uu___1 with + | FStar_Pervasives_Native.Some d1 -> + let uu___2 = + embed_d + psc.FStarC_TypeChecker_Primops_Base.psc_range + d1 in + FStar_Pervasives_Native.Some uu___2 + | uu___2 -> FStar_Pervasives_Native.None) + | uu___1 -> FStar_Pervasives_Native.None) + | uu___ -> FStar_Pervasives_Native.None +let (bogus_cbs : FStarC_TypeChecker_NBETerm.nbe_cbs) = + { + FStarC_TypeChecker_NBETerm.iapp = (fun h -> fun _args -> h); + FStarC_TypeChecker_NBETerm.translate = + (fun uu___ -> failwith "bogus_cbs translate") + } +let (ops : FStarC_TypeChecker_Primops_Base.primitive_step Prims.list) = + let of_list_op = + let emb_typ t = + let uu___ = + let uu___1 = + FStarC_Ident.string_of_lid + FStarC_Parser_Const.immutable_array_t_lid in + (uu___1, [t]) in + FStarC_Syntax_Syntax.ET_app uu___ in + let un_lazy universes t l r = + let uu___ = + let uu___1 = + FStarC_Syntax_Util.fvar_const + FStarC_Parser_Const.immutable_array_of_list_lid in + FStarC_Syntax_Syntax.mk_Tm_uinst uu___1 universes in + let uu___1 = + let uu___2 = FStarC_Syntax_Syntax.iarg t in + let uu___3 = let uu___4 = FStarC_Syntax_Syntax.as_arg l in [uu___4] in + uu___2 :: uu___3 in + FStarC_Syntax_Syntax.mk_Tm_app uu___ uu___1 r in + (FStarC_Parser_Const.immutable_array_of_list_lid, (Prims.of_int (2)), + Prims.int_one, + (mixed_binary_op + (fun uu___ -> + match uu___ with + | (elt_t, uu___1) -> FStar_Pervasives_Native.Some elt_t) + (fun uu___ -> + match uu___ with + | (l, q) -> + let uu___1 = + arg_as_list FStarC_Syntax_Embeddings.e_any (l, q) in + (match uu___1 with + | FStar_Pervasives_Native.Some lst -> + FStar_Pervasives_Native.Some (l, lst) + | uu___2 -> FStar_Pervasives_Native.None)) + (fun r -> + fun uu___ -> + match uu___ with + | (universes, elt_t, (l, blob)) -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Embeddings_Base.emb_typ_of + FStarC_Syntax_Embeddings.e_any () in + emb_typ uu___6 in + let uu___6 = + FStarC_Thunk.mk + (fun uu___7 -> un_lazy universes elt_t l r) in + (uu___5, uu___6) in + FStarC_Syntax_Syntax.Lazy_embedding uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Util.fvar_const + FStarC_Parser_Const.immutable_array_t_lid in + FStarC_Syntax_Syntax.mk_Tm_uinst uu___6 universes in + let uu___6 = + let uu___7 = FStarC_Syntax_Syntax.as_arg elt_t in + [uu___7] in + FStarC_Syntax_Syntax.mk_Tm_app uu___5 uu___6 r in + { + FStarC_Syntax_Syntax.blob = blob; + FStarC_Syntax_Syntax.lkind = uu___3; + FStarC_Syntax_Syntax.ltyp = uu___4; + FStarC_Syntax_Syntax.rng = r + } in + FStarC_Syntax_Syntax.Tm_lazy uu___2 in + FStarC_Syntax_Syntax.mk uu___1 r) + (fun r -> + fun universes -> + fun elt_t -> + fun uu___ -> + match uu___ with + | (l, lst) -> + let blob = FStar_ImmutableArray_Base.of_list lst in + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Dyn.mkdyn blob in (l, uu___3) in + (universes, elt_t, uu___2) in + FStar_Pervasives_Native.Some uu___1)), + (FStarC_TypeChecker_NBETerm.mixed_binary_op + (fun uu___ -> + match uu___ with + | (elt_t, uu___1) -> FStar_Pervasives_Native.Some elt_t) + (fun uu___ -> + match uu___ with + | (l, q) -> + let uu___1 = + FStarC_TypeChecker_NBETerm.arg_as_list + FStarC_TypeChecker_NBETerm.e_any (l, q) in + (match uu___1 with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some lst -> + FStar_Pervasives_Native.Some (l, lst))) + (fun uu___ -> + match uu___ with + | (universes, elt_t, (l, blob)) -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Embeddings_Base.emb_typ_of + FStarC_Syntax_Embeddings.e_any () in + emb_typ uu___6 in + (blob, uu___5) in + FStar_Pervasives.Inr uu___4 in + let uu___4 = + FStarC_Thunk.mk + (fun uu___5 -> + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Syntax.lid_as_fv + FStarC_Parser_Const.immutable_array_of_list_lid + FStar_Pervasives_Native.None in + let uu___9 = + let uu___10 = + FStarC_TypeChecker_NBETerm.as_arg l in + [uu___10] in + (uu___8, universes, uu___9) in + FStarC_TypeChecker_NBETerm.FV uu___7 in + FStarC_TypeChecker_NBETerm.mk_t uu___6) in + (uu___3, uu___4) in + FStarC_TypeChecker_NBETerm.Lazy uu___2 in + FStarC_TypeChecker_NBETerm.mk_t uu___1) + (fun universes -> + fun elt_t -> + fun uu___ -> + match uu___ with + | (l, lst) -> + let blob = FStar_ImmutableArray_Base.of_list lst in + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Dyn.mkdyn blob in (l, uu___3) in + (universes, elt_t, uu___2) in + FStar_Pervasives_Native.Some uu___1))) in + let arg1_as_elt_t x = + FStar_Pervasives_Native.Some (FStar_Pervasives_Native.fst x) in + let arg2_as_blob x = + let uu___ = + let uu___1 = + FStarC_Syntax_Subst.compress (FStar_Pervasives_Native.fst x) in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_lazy + { FStarC_Syntax_Syntax.blob = blob; + FStarC_Syntax_Syntax.lkind = FStarC_Syntax_Syntax.Lazy_embedding + (FStarC_Syntax_Syntax.ET_app (head, uu___1), uu___2); + FStarC_Syntax_Syntax.ltyp = uu___3; + FStarC_Syntax_Syntax.rng = uu___4;_} + when + let uu___5 = + FStarC_Ident.string_of_lid + FStarC_Parser_Const.immutable_array_t_lid in + head = uu___5 -> FStar_Pervasives_Native.Some blob + | uu___1 -> FStar_Pervasives_Native.None in + let arg2_as_blob_nbe x = + match (FStar_Pervasives_Native.fst x).FStarC_TypeChecker_NBETerm.nbe_t + with + | FStarC_TypeChecker_NBETerm.Lazy + (FStar_Pervasives.Inr + (blob, FStarC_Syntax_Syntax.ET_app (head, uu___)), uu___1) + when + let uu___2 = + FStarC_Ident.string_of_lid + FStarC_Parser_Const.immutable_array_t_lid in + head = uu___2 -> FStar_Pervasives_Native.Some blob + | uu___ -> FStar_Pervasives_Native.None in + let length_op = + let embed_int r i = + FStarC_TypeChecker_Primops_Base.embed_simple + FStarC_Syntax_Embeddings.e_int r i in + let run_op blob = + let uu___ = + let uu___1 = FStarC_Dyn.undyn blob in + FStarC_Compiler_Util.array_length uu___1 in + FStar_Pervasives_Native.Some uu___ in + (FStarC_Parser_Const.immutable_array_length_lid, (Prims.of_int (2)), + Prims.int_one, + (mixed_binary_op arg1_as_elt_t arg2_as_blob embed_int + (fun _r -> fun _universes -> fun uu___ -> fun blob -> run_op blob)), + (FStarC_TypeChecker_NBETerm.mixed_binary_op + (fun uu___ -> + match uu___ with + | (elt_t, uu___1) -> FStar_Pervasives_Native.Some elt_t) + arg2_as_blob_nbe + (fun i -> + FStarC_TypeChecker_NBETerm.embed FStarC_TypeChecker_NBETerm.e_int + bogus_cbs i) + (fun _universes -> fun uu___ -> fun blob -> run_op blob))) in + let index_op = + (FStarC_Parser_Const.immutable_array_index_lid, (Prims.of_int (3)), + Prims.int_one, + (mixed_ternary_op arg1_as_elt_t arg2_as_blob arg_as_int + (fun r -> fun tm -> tm) + (fun r -> + fun _universes -> + fun _t -> + fun blob -> + fun i -> + let uu___ = + let uu___1 = FStarC_Dyn.undyn blob in + FStarC_Compiler_Util.array_index uu___1 i in + FStar_Pervasives_Native.Some uu___)), + (FStarC_TypeChecker_NBETerm.mixed_ternary_op + (fun uu___ -> + match uu___ with + | (elt_t, uu___1) -> FStar_Pervasives_Native.Some elt_t) + arg2_as_blob_nbe FStarC_TypeChecker_NBETerm.arg_as_int + (fun tm -> tm) + (fun _universes -> + fun _t -> + fun blob -> + fun i -> + let uu___ = + let uu___1 = FStarC_Dyn.undyn blob in + FStarC_Compiler_Util.array_index uu___1 i in + FStar_Pervasives_Native.Some uu___))) in + FStarC_Compiler_List.map (as_primitive_step true) + [of_list_op; length_op; index_op] \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_Base.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_Base.ml new file mode 100644 index 00000000000..5b3d48a13e0 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_Base.ml @@ -0,0 +1,2239 @@ +open Prims +type psc = + { + psc_range: FStarC_Compiler_Range_Type.range ; + psc_subst: unit -> FStarC_Syntax_Syntax.subst_t } +let (__proj__Mkpsc__item__psc_range : + psc -> FStarC_Compiler_Range_Type.range) = + fun projectee -> + match projectee with | { psc_range; psc_subst;_} -> psc_range +let (__proj__Mkpsc__item__psc_subst : + psc -> unit -> FStarC_Syntax_Syntax.subst_t) = + fun projectee -> + match projectee with | { psc_range; psc_subst;_} -> psc_subst +let (null_psc : psc) = + { + psc_range = FStarC_Compiler_Range_Type.dummyRange; + psc_subst = (fun uu___ -> []) + } +let (psc_range : psc -> FStarC_Compiler_Range_Type.range) = + fun psc1 -> psc1.psc_range +let (psc_subst : psc -> FStarC_Syntax_Syntax.subst_t) = + fun psc1 -> psc1.psc_subst () +type interp_t = + psc -> + FStarC_Syntax_Embeddings_Base.norm_cb -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option +type nbe_interp_t = + FStarC_TypeChecker_NBETerm.nbe_cbs -> + FStarC_Syntax_Syntax.universes -> + FStarC_TypeChecker_NBETerm.args -> + FStarC_TypeChecker_NBETerm.t FStar_Pervasives_Native.option +type primitive_step = + { + name: FStarC_Ident.lid ; + arity: Prims.int ; + univ_arity: Prims.int ; + auto_reflect: Prims.int FStar_Pervasives_Native.option ; + strong_reduction_ok: Prims.bool ; + requires_binder_substitution: Prims.bool ; + renorm_after: Prims.bool ; + interpretation: interp_t ; + interpretation_nbe: nbe_interp_t } +let (__proj__Mkprimitive_step__item__name : + primitive_step -> FStarC_Ident.lid) = + fun projectee -> + match projectee with + | { name; arity; univ_arity; auto_reflect; strong_reduction_ok; + requires_binder_substitution; renorm_after; interpretation; + interpretation_nbe;_} -> name +let (__proj__Mkprimitive_step__item__arity : primitive_step -> Prims.int) = + fun projectee -> + match projectee with + | { name; arity; univ_arity; auto_reflect; strong_reduction_ok; + requires_binder_substitution; renorm_after; interpretation; + interpretation_nbe;_} -> arity +let (__proj__Mkprimitive_step__item__univ_arity : + primitive_step -> Prims.int) = + fun projectee -> + match projectee with + | { name; arity; univ_arity; auto_reflect; strong_reduction_ok; + requires_binder_substitution; renorm_after; interpretation; + interpretation_nbe;_} -> univ_arity +let (__proj__Mkprimitive_step__item__auto_reflect : + primitive_step -> Prims.int FStar_Pervasives_Native.option) = + fun projectee -> + match projectee with + | { name; arity; univ_arity; auto_reflect; strong_reduction_ok; + requires_binder_substitution; renorm_after; interpretation; + interpretation_nbe;_} -> auto_reflect +let (__proj__Mkprimitive_step__item__strong_reduction_ok : + primitive_step -> Prims.bool) = + fun projectee -> + match projectee with + | { name; arity; univ_arity; auto_reflect; strong_reduction_ok; + requires_binder_substitution; renorm_after; interpretation; + interpretation_nbe;_} -> strong_reduction_ok +let (__proj__Mkprimitive_step__item__requires_binder_substitution : + primitive_step -> Prims.bool) = + fun projectee -> + match projectee with + | { name; arity; univ_arity; auto_reflect; strong_reduction_ok; + requires_binder_substitution; renorm_after; interpretation; + interpretation_nbe;_} -> requires_binder_substitution +let (__proj__Mkprimitive_step__item__renorm_after : + primitive_step -> Prims.bool) = + fun projectee -> + match projectee with + | { name; arity; univ_arity; auto_reflect; strong_reduction_ok; + requires_binder_substitution; renorm_after; interpretation; + interpretation_nbe;_} -> renorm_after +let (__proj__Mkprimitive_step__item__interpretation : + primitive_step -> interp_t) = + fun projectee -> + match projectee with + | { name; arity; univ_arity; auto_reflect; strong_reduction_ok; + requires_binder_substitution; renorm_after; interpretation; + interpretation_nbe;_} -> interpretation +let (__proj__Mkprimitive_step__item__interpretation_nbe : + primitive_step -> nbe_interp_t) = + fun projectee -> + match projectee with + | { name; arity; univ_arity; auto_reflect; strong_reduction_ok; + requires_binder_substitution; renorm_after; interpretation; + interpretation_nbe;_} -> interpretation_nbe +let embed_simple : + 'a . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_Compiler_Range_Type.range -> 'a -> FStarC_Syntax_Syntax.term + = + fun uu___ -> + fun r -> + fun x -> + let uu___1 = FStarC_Syntax_Embeddings_Base.embed uu___ x in + uu___1 r FStar_Pervasives_Native.None + FStarC_Syntax_Embeddings_Base.id_norm_cb +let try_unembed_simple : + 'a . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + FStarC_Syntax_Syntax.term -> 'a FStar_Pervasives_Native.option + = + fun uu___ -> + fun x -> + FStarC_Syntax_Embeddings_Base.try_unembed uu___ x + FStarC_Syntax_Embeddings_Base.id_norm_cb +let solve : 'a . 'a -> 'a = fun ev -> ev +let (as_primitive_step_nbecbs : + Prims.bool -> + (FStarC_Ident.lident * Prims.int * Prims.int * interp_t * nbe_interp_t) + -> primitive_step) + = + fun is_strong -> + fun uu___ -> + match uu___ with + | (l, arity, u_arity, f, f_nbe) -> + { + name = l; + arity; + univ_arity = u_arity; + auto_reflect = FStar_Pervasives_Native.None; + strong_reduction_ok = is_strong; + requires_binder_substitution = false; + renorm_after = false; + interpretation = f; + interpretation_nbe = f_nbe + } +let mk_interp1 : + 'a 'r . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> ('a -> 'r) -> interp_t + = + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun uu___ -> + fun uu___1 -> + fun f -> + fun psc1 -> + fun cb -> + fun us -> + fun args -> + match args with + | (a1, uu___2)::[] -> + Obj.magic + (Obj.repr + (let uu___3 = try_unembed_simple uu___ a1 in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () + (Obj.magic uu___3) + (fun uu___4 -> + (fun a2 -> + let a2 = Obj.magic a2 in + let uu___4 = + let uu___5 = f a2 in + embed_simple uu___1 psc1.psc_range + uu___5 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Class_Monad.monad_option + () (Obj.magic uu___4))) uu___4))) + | uu___2 -> Obj.magic (Obj.repr (failwith "arity"))) + uu___2 uu___1 uu___ +let mk_nbe_interp1 : + 'a 'r . + 'a FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> ('a -> 'r) -> nbe_interp_t + = + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun uu___ -> + fun uu___1 -> + fun f -> + fun cbs -> + fun us -> + fun args -> + match args with + | (a1, uu___2)::[] -> + Obj.magic + (Obj.repr + (let uu___3 = + let uu___4 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___) cbs a1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Dollar_Greater + FStarC_Class_Monad.monad_option () () + (fun uu___5 -> (Obj.magic f) uu___5) + (Obj.magic uu___4)) in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () + (Obj.magic uu___3) + (fun uu___4 -> + (fun r1 -> + let r1 = Obj.magic r1 in + let uu___4 = + FStarC_TypeChecker_NBETerm.embed + (solve uu___1) cbs r1 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Class_Monad.monad_option + () (Obj.magic uu___4))) uu___4))) + | uu___2 -> + Obj.magic (Obj.repr FStar_Pervasives_Native.None)) + uu___2 uu___1 uu___ +let mk_interp2 : + 'a 'b 'r . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'b FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + ('a -> 'b -> 'r) -> interp_t + = + fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun f -> + fun psc1 -> + fun cb -> + fun us -> + fun args -> + match args with + | (a1, uu___3)::(b1, uu___4)::[] -> + Obj.magic + (Obj.repr + (let uu___5 = + let uu___6 = + let uu___7 = + try_unembed_simple uu___ a1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Dollar_Greater + FStarC_Class_Monad.monad_option + () () + (fun uu___8 -> + (Obj.magic f) uu___8) + (Obj.magic uu___7)) in + let uu___7 = + try_unembed_simple uu___1 b1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___6) + (Obj.magic uu___7)) in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () + (Obj.magic uu___5) + (fun uu___6 -> + (fun r1 -> + let r1 = Obj.magic r1 in + let uu___6 = + embed_simple uu___2 + psc1.psc_range r1 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Class_Monad.monad_option + () (Obj.magic uu___6))) + uu___6))) + | uu___3 -> + Obj.magic (Obj.repr (failwith "arity"))) + uu___3 uu___2 uu___1 uu___ +let mk_nbe_interp2 : + 'a 'b 'r . + 'a FStarC_TypeChecker_NBETerm.embedding -> + 'b FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + ('a -> 'b -> 'r) -> nbe_interp_t + = + fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun f -> + fun cbs -> + fun us -> + fun args -> + match args with + | (a1, uu___3)::(b1, uu___4)::[] -> + Obj.magic + (Obj.repr + (let uu___5 = + let uu___6 = + let uu___7 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___) cbs a1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Dollar_Greater + FStarC_Class_Monad.monad_option + () () + (fun uu___8 -> + (Obj.magic f) uu___8) + (Obj.magic uu___7)) in + let uu___7 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___1) cbs b1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option () + () (Obj.magic uu___6) + (Obj.magic uu___7)) in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () + (Obj.magic uu___5) + (fun uu___6 -> + (fun r1 -> + let r1 = Obj.magic r1 in + let uu___6 = + FStarC_TypeChecker_NBETerm.embed + (solve uu___2) cbs r1 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Class_Monad.monad_option + () (Obj.magic uu___6))) + uu___6))) + | uu___3 -> + Obj.magic + (Obj.repr FStar_Pervasives_Native.None)) + uu___3 uu___2 uu___1 uu___ +let mk_interp3 : + 'a 'b 'c 'r . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'b FStarC_Syntax_Embeddings_Base.embedding -> + 'c FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + ('a -> 'b -> 'c -> 'r) -> interp_t + = + fun uu___4 -> + fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun f -> + fun psc1 -> + fun cb -> + fun us -> + fun args -> + match args with + | (a1, uu___4)::(b1, uu___5)::(c1, uu___6)::[] + -> + Obj.magic + (Obj.repr + (let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + try_unembed_simple uu___ a1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Dollar_Greater + FStarC_Class_Monad.monad_option + () () + (fun uu___11 -> + (Obj.magic f) uu___11) + (Obj.magic uu___10)) in + let uu___10 = + try_unembed_simple uu___1 b1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___9) + (Obj.magic uu___10)) in + let uu___9 = + try_unembed_simple uu___2 c1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___8) + (Obj.magic uu___9)) in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () + () (Obj.magic uu___7) + (fun uu___8 -> + (fun r1 -> + let r1 = Obj.magic r1 in + let uu___8 = + embed_simple uu___3 + psc1.psc_range r1 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Class_Monad.monad_option + () (Obj.magic uu___8))) + uu___8))) + | uu___4 -> + Obj.magic (Obj.repr (failwith "arity"))) + uu___4 uu___3 uu___2 uu___1 uu___ +let mk_nbe_interp3 : + 'a 'b 'c 'r . + 'a FStarC_TypeChecker_NBETerm.embedding -> + 'b FStarC_TypeChecker_NBETerm.embedding -> + 'c FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + ('a -> 'b -> 'c -> 'r) -> nbe_interp_t + = + fun uu___4 -> + fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun f -> + fun cbs -> + fun us -> + fun args -> + match args with + | (a1, uu___4)::(b1, uu___5)::(c1, uu___6)::[] + -> + Obj.magic + (Obj.repr + (let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___) cbs a1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Dollar_Greater + FStarC_Class_Monad.monad_option + () () + (fun uu___11 -> + (Obj.magic f) uu___11) + (Obj.magic uu___10)) in + let uu___10 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___1) cbs b1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___9) + (Obj.magic uu___10)) in + let uu___9 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___2) cbs c1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___8) + (Obj.magic uu___9)) in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () + () (Obj.magic uu___7) + (fun uu___8 -> + (fun r1 -> + let r1 = Obj.magic r1 in + let uu___8 = + FStarC_TypeChecker_NBETerm.embed + (solve uu___3) cbs r1 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Class_Monad.monad_option + () (Obj.magic uu___8))) + uu___8))) + | uu___4 -> + Obj.magic + (Obj.repr FStar_Pervasives_Native.None)) + uu___4 uu___3 uu___2 uu___1 uu___ +let mk_interp4 : + 'a 'b 'c 'd 'r . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'b FStarC_Syntax_Embeddings_Base.embedding -> + 'c FStarC_Syntax_Embeddings_Base.embedding -> + 'd FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + ('a -> 'b -> 'c -> 'd -> 'r) -> interp_t + = + fun uu___5 -> + fun uu___4 -> + fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun uu___4 -> + fun f -> + fun psc1 -> + fun cb -> + fun us -> + fun args -> + match args with + | (a1, uu___5)::(b1, uu___6)::(c1, uu___7):: + (d1, uu___8)::[] -> + Obj.magic + (Obj.repr + (let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + try_unembed_simple + uu___ a1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Dollar_Greater + FStarC_Class_Monad.monad_option + () () + (fun uu___14 -> + (Obj.magic f) + uu___14) + (Obj.magic uu___13)) in + let uu___13 = + try_unembed_simple + uu___1 b1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () + (Obj.magic uu___12) + (Obj.magic uu___13)) in + let uu___12 = + try_unembed_simple uu___2 + c1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () + (Obj.magic uu___11) + (Obj.magic uu___12)) in + let uu___11 = + try_unembed_simple uu___3 d1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___10) + (Obj.magic uu___11)) in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___9) + (fun uu___10 -> + (fun r1 -> + let r1 = Obj.magic r1 in + let uu___10 = + embed_simple uu___4 + psc1.psc_range r1 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Class_Monad.monad_option + () + (Obj.magic uu___10))) + uu___10))) + | uu___5 -> + Obj.magic + (Obj.repr (failwith "arity"))) + uu___5 uu___4 uu___3 uu___2 uu___1 uu___ +let mk_nbe_interp4 : + 'a 'b 'c 'd 'r . + 'a FStarC_TypeChecker_NBETerm.embedding -> + 'b FStarC_TypeChecker_NBETerm.embedding -> + 'c FStarC_TypeChecker_NBETerm.embedding -> + 'd FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + ('a -> 'b -> 'c -> 'd -> 'r) -> nbe_interp_t + = + fun uu___5 -> + fun uu___4 -> + fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun uu___4 -> + fun f -> + fun cbs -> + fun us -> + fun args -> + match args with + | (a1, uu___5)::(b1, uu___6)::(c1, uu___7):: + (d1, uu___8)::[] -> + Obj.magic + (Obj.repr + (let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___) cbs a1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Dollar_Greater + FStarC_Class_Monad.monad_option + () () + (fun uu___14 -> + (Obj.magic f) + uu___14) + (Obj.magic uu___13)) in + let uu___13 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___1) cbs b1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () + (Obj.magic uu___12) + (Obj.magic uu___13)) in + let uu___12 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___2) cbs c1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___11) + (Obj.magic uu___12)) in + let uu___11 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___3) cbs d1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___10) + (Obj.magic uu___11)) in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___9) + (fun uu___10 -> + (fun r1 -> + let r1 = Obj.magic r1 in + let uu___10 = + FStarC_TypeChecker_NBETerm.embed + (solve uu___4) cbs r1 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Class_Monad.monad_option + () + (Obj.magic uu___10))) + uu___10))) + | uu___5 -> + Obj.magic + (Obj.repr FStar_Pervasives_Native.None)) + uu___5 uu___4 uu___3 uu___2 uu___1 uu___ +let mk_interp5 : + 'a 'b 'c 'd 'e 'r . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'b FStarC_Syntax_Embeddings_Base.embedding -> + 'c FStarC_Syntax_Embeddings_Base.embedding -> + 'd FStarC_Syntax_Embeddings_Base.embedding -> + 'e FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + ('a -> 'b -> 'c -> 'd -> 'e -> 'r) -> interp_t + = + fun uu___6 -> + fun uu___5 -> + fun uu___4 -> + fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun uu___4 -> + fun uu___5 -> + fun f -> + fun psc1 -> + fun cb -> + fun us -> + fun args -> + match args with + | (a1, uu___6)::(b1, uu___7):: + (c1, uu___8)::(d1, uu___9):: + (e1, uu___10)::[] -> + Obj.magic + (Obj.repr + (let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = + try_unembed_simple + uu___ a1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Dollar_Greater + FStarC_Class_Monad.monad_option + () () + (fun uu___17 + -> + (Obj.magic + f) + uu___17) + (Obj.magic + uu___16)) in + let uu___16 = + try_unembed_simple + uu___1 b1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () + (Obj.magic + uu___15) + (Obj.magic + uu___16)) in + let uu___15 = + try_unembed_simple + uu___2 c1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () + (Obj.magic + uu___14) + (Obj.magic + uu___15)) in + let uu___14 = + try_unembed_simple + uu___3 d1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () + (Obj.magic uu___13) + (Obj.magic uu___14)) in + let uu___13 = + try_unembed_simple + uu___4 e1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () + (Obj.magic uu___12) + (Obj.magic uu___13)) in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___11) + (fun uu___12 -> + (fun r1 -> + let r1 = + Obj.magic r1 in + let uu___12 = + embed_simple + uu___5 + psc1.psc_range + r1 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Class_Monad.monad_option + () + (Obj.magic + uu___12))) + uu___12))) + | uu___6 -> + Obj.magic + (Obj.repr (failwith "arity"))) + uu___6 uu___5 uu___4 uu___3 uu___2 uu___1 uu___ +let mk_nbe_interp5 : + 'a 'b 'c 'd 'e 'r . + 'a FStarC_TypeChecker_NBETerm.embedding -> + 'b FStarC_TypeChecker_NBETerm.embedding -> + 'c FStarC_TypeChecker_NBETerm.embedding -> + 'd FStarC_TypeChecker_NBETerm.embedding -> + 'e FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + ('a -> 'b -> 'c -> 'd -> 'e -> 'r) -> nbe_interp_t + = + fun uu___6 -> + fun uu___5 -> + fun uu___4 -> + fun uu___3 -> + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun uu___4 -> + fun uu___5 -> + fun f -> + fun cbs -> + fun us -> + fun args -> + match args with + | (a1, uu___6)::(b1, uu___7)::(c1, + uu___8):: + (d1, uu___9)::(e1, uu___10)::[] -> + Obj.magic + (Obj.repr + (let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___) + cbs a1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Dollar_Greater + FStarC_Class_Monad.monad_option + () () + (fun uu___17 -> + (Obj.magic f) + uu___17) + (Obj.magic + uu___16)) in + let uu___16 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___1) cbs + b1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () + (Obj.magic + uu___15) + (Obj.magic + uu___16)) in + let uu___15 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___2) cbs + c1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () + (Obj.magic uu___14) + (Obj.magic uu___15)) in + let uu___14 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___3) cbs d1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () + (Obj.magic uu___13) + (Obj.magic uu___14)) in + let uu___13 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___4) cbs e1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () + (Obj.magic uu___12) + (Obj.magic uu___13)) in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___11) + (fun uu___12 -> + (fun r1 -> + let r1 = Obj.magic r1 in + let uu___12 = + FStarC_TypeChecker_NBETerm.embed + (solve uu___5) cbs + r1 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Class_Monad.monad_option + () + (Obj.magic + uu___12))) + uu___12))) + | uu___6 -> + Obj.magic + (Obj.repr + FStar_Pervasives_Native.None)) + uu___6 uu___5 uu___4 uu___3 uu___2 uu___1 uu___ +let mk1 : + 'a 'r . + Prims.int -> + FStarC_Ident.lid -> + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'a FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + ('a -> 'r) -> primitive_step + = + fun u_arity -> + fun name -> + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun f -> + let interp = mk_interp1 uu___ uu___2 f in + let nbe_interp = mk_nbe_interp1 uu___1 uu___3 f in + as_primitive_step_nbecbs true + (name, Prims.int_one, u_arity, interp, nbe_interp) +let mk2 : + 'a 'b 'r . + Prims.int -> + FStarC_Ident.lid -> + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'a FStarC_TypeChecker_NBETerm.embedding -> + 'b FStarC_Syntax_Embeddings_Base.embedding -> + 'b FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + ('a -> 'b -> 'r) -> primitive_step + = + fun u_arity -> + fun name -> + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun uu___4 -> + fun uu___5 -> + fun f -> + let interp = mk_interp2 uu___ uu___2 uu___4 f in + let nbe_interp = mk_nbe_interp2 uu___1 uu___3 uu___5 f in + as_primitive_step_nbecbs true + (name, (Prims.of_int (2)), u_arity, interp, nbe_interp) +let mk3 : + 'a 'b 'c 'r . + Prims.int -> + FStarC_Ident.lid -> + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'a FStarC_TypeChecker_NBETerm.embedding -> + 'b FStarC_Syntax_Embeddings_Base.embedding -> + 'b FStarC_TypeChecker_NBETerm.embedding -> + 'c FStarC_Syntax_Embeddings_Base.embedding -> + 'c FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + ('a -> 'b -> 'c -> 'r) -> primitive_step + = + fun u_arity -> + fun name -> + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun uu___4 -> + fun uu___5 -> + fun uu___6 -> + fun uu___7 -> + fun f -> + let interp = mk_interp3 uu___ uu___2 uu___4 uu___6 f in + let nbe_interp = + mk_nbe_interp3 uu___1 uu___3 uu___5 uu___7 f in + as_primitive_step_nbecbs true + (name, (Prims.of_int (3)), u_arity, interp, + nbe_interp) +let mk4 : + 'a 'b 'c 'd 'r . + Prims.int -> + FStarC_Ident.lid -> + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'a FStarC_TypeChecker_NBETerm.embedding -> + 'b FStarC_Syntax_Embeddings_Base.embedding -> + 'b FStarC_TypeChecker_NBETerm.embedding -> + 'c FStarC_Syntax_Embeddings_Base.embedding -> + 'c FStarC_TypeChecker_NBETerm.embedding -> + 'd FStarC_Syntax_Embeddings_Base.embedding -> + 'd FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + ('a -> 'b -> 'c -> 'd -> 'r) -> primitive_step + = + fun u_arity -> + fun name -> + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun uu___4 -> + fun uu___5 -> + fun uu___6 -> + fun uu___7 -> + fun uu___8 -> + fun uu___9 -> + fun f -> + let interp = + mk_interp4 uu___ uu___2 uu___4 uu___6 uu___8 f in + let nbe_interp = + mk_nbe_interp4 uu___1 uu___3 uu___5 uu___7 + uu___9 f in + as_primitive_step_nbecbs true + (name, (Prims.of_int (4)), u_arity, interp, + nbe_interp) +let mk5 : + 'a 'b 'c 'd 'e 'r . + Prims.int -> + FStarC_Ident.lid -> + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'a FStarC_TypeChecker_NBETerm.embedding -> + 'b FStarC_Syntax_Embeddings_Base.embedding -> + 'b FStarC_TypeChecker_NBETerm.embedding -> + 'c FStarC_Syntax_Embeddings_Base.embedding -> + 'c FStarC_TypeChecker_NBETerm.embedding -> + 'd FStarC_Syntax_Embeddings_Base.embedding -> + 'd FStarC_TypeChecker_NBETerm.embedding -> + 'e FStarC_Syntax_Embeddings_Base.embedding -> + 'e FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + 'r FStarC_TypeChecker_NBETerm.embedding -> + ('a -> 'b -> 'c -> 'd -> 'e -> 'r) -> + primitive_step + = + fun u_arity -> + fun name -> + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun uu___4 -> + fun uu___5 -> + fun uu___6 -> + fun uu___7 -> + fun uu___8 -> + fun uu___9 -> + fun uu___10 -> + fun uu___11 -> + fun f -> + let interp = + mk_interp5 uu___ uu___2 uu___4 uu___6 + uu___8 uu___10 f in + let nbe_interp = + mk_nbe_interp5 uu___1 uu___3 uu___5 uu___7 + uu___9 uu___11 f in + as_primitive_step_nbecbs true + (name, (Prims.of_int (5)), u_arity, interp, + nbe_interp) +let mk1' : + 'a 'r 'na 'nr . + Prims.int -> + FStarC_Ident.lid -> + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'na FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + 'nr FStarC_TypeChecker_NBETerm.embedding -> + ('a -> 'r FStar_Pervasives_Native.option) -> + ('na -> 'nr FStar_Pervasives_Native.option) -> + primitive_step + = + fun u_arity -> + fun name -> + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun f -> + fun nbe_f -> + let interp psc1 cb us args = + match args with + | (a1, uu___4)::[] -> + Obj.magic + (Obj.repr + (let uu___5 = + let uu___6 = try_unembed_simple uu___ a1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Dollar_Greater + FStarC_Class_Monad.monad_option () () + (fun uu___7 -> (Obj.magic f) uu___7) + (Obj.magic uu___6)) in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () + (Obj.magic uu___5) + (fun uu___6 -> + (fun r1 -> + let r1 = Obj.magic r1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () + () (Obj.magic r1) + (fun uu___6 -> + (fun r2 -> + let r2 = Obj.magic r2 in + let uu___6 = + embed_simple uu___2 + psc1.psc_range r2 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Class_Monad.monad_option + () (Obj.magic uu___6))) + uu___6))) uu___6))) + | uu___4 -> Obj.magic (Obj.repr (failwith "arity")) in + let nbe_interp cbs us args = + match args with + | (a1, uu___4)::[] -> + Obj.magic + (Obj.repr + (let uu___5 = + let uu___6 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___1) cbs a1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Dollar_Greater + FStarC_Class_Monad.monad_option () () + (fun uu___7 -> (Obj.magic nbe_f) uu___7) + (Obj.magic uu___6)) in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () + (Obj.magic uu___5) + (fun uu___6 -> + (fun r1 -> + let r1 = Obj.magic r1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () + () (Obj.magic r1) + (fun uu___6 -> + (fun r2 -> + let r2 = Obj.magic r2 in + let uu___6 = + FStarC_TypeChecker_NBETerm.embed + (solve uu___3) cbs r2 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Class_Monad.monad_option + () (Obj.magic uu___6))) + uu___6))) uu___6))) + | uu___4 -> Obj.magic (Obj.repr (failwith "arity")) in + as_primitive_step_nbecbs true + (name, Prims.int_one, u_arity, interp, nbe_interp) +let mk1_psc' : + 'a 'r 'na 'nr . + Prims.int -> + FStarC_Ident.lid -> + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'na FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + 'nr FStarC_TypeChecker_NBETerm.embedding -> + (psc -> 'a -> 'r FStar_Pervasives_Native.option) -> + (psc -> 'na -> 'nr FStar_Pervasives_Native.option) -> + primitive_step + = + fun u_arity -> + fun name -> + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun f -> + fun nbe_f -> + let interp psc1 cb us args = + match args with + | (a1, uu___4)::[] -> + Obj.magic + (Obj.repr + (let uu___5 = + let uu___6 = try_unembed_simple uu___ a1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Dollar_Greater + FStarC_Class_Monad.monad_option () () + (fun uu___7 -> + (Obj.magic (f psc1)) uu___7) + (Obj.magic uu___6)) in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () + (Obj.magic uu___5) + (fun uu___6 -> + (fun r1 -> + let r1 = Obj.magic r1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () + () (Obj.magic r1) + (fun uu___6 -> + (fun r2 -> + let r2 = Obj.magic r2 in + let uu___6 = + embed_simple uu___2 + psc1.psc_range r2 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Class_Monad.monad_option + () (Obj.magic uu___6))) + uu___6))) uu___6))) + | uu___4 -> Obj.magic (Obj.repr (failwith "arity")) in + let nbe_interp cbs us args = + match args with + | (a1, uu___4)::[] -> + Obj.magic + (Obj.repr + (let uu___5 = + let uu___6 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___1) cbs a1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Dollar_Greater + FStarC_Class_Monad.monad_option () () + (fun uu___7 -> + (Obj.magic (nbe_f null_psc)) uu___7) + (Obj.magic uu___6)) in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () + (Obj.magic uu___5) + (fun uu___6 -> + (fun r1 -> + let r1 = Obj.magic r1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () + () (Obj.magic r1) + (fun uu___6 -> + (fun r2 -> + let r2 = Obj.magic r2 in + let uu___6 = + FStarC_TypeChecker_NBETerm.embed + (solve uu___3) cbs r2 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Class_Monad.monad_option + () (Obj.magic uu___6))) + uu___6))) uu___6))) + | uu___4 -> Obj.magic (Obj.repr (failwith "arity")) in + as_primitive_step_nbecbs true + (name, Prims.int_one, u_arity, interp, nbe_interp) +let mk2' : + 'a 'b 'r 'na 'nb 'nr . + Prims.int -> + FStarC_Ident.lid -> + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'na FStarC_TypeChecker_NBETerm.embedding -> + 'b FStarC_Syntax_Embeddings_Base.embedding -> + 'nb FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + 'nr FStarC_TypeChecker_NBETerm.embedding -> + ('a -> 'b -> 'r FStar_Pervasives_Native.option) -> + ('na -> 'nb -> 'nr FStar_Pervasives_Native.option) -> + primitive_step + = + fun u_arity -> + fun name -> + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun uu___4 -> + fun uu___5 -> + fun f -> + fun nbe_f -> + let interp psc1 cb us args = + match args with + | (a1, uu___6)::(b1, uu___7)::[] -> + Obj.magic + (Obj.repr + (let uu___8 = + let uu___9 = + let uu___10 = + try_unembed_simple uu___ a1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Dollar_Greater + FStarC_Class_Monad.monad_option () + () + (fun uu___11 -> + (Obj.magic f) uu___11) + (Obj.magic uu___10)) in + let uu___10 = + try_unembed_simple uu___2 b1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option () + () (Obj.magic uu___9) + (Obj.magic uu___10)) in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () + (Obj.magic uu___8) + (fun uu___9 -> + (fun r1 -> + let r1 = Obj.magic r1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () (Obj.magic r1) + (fun uu___9 -> + (fun r2 -> + let r2 = Obj.magic r2 in + let uu___9 = + embed_simple uu___4 + psc1.psc_range r2 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Class_Monad.monad_option + () + (Obj.magic uu___9))) + uu___9))) uu___9))) + | uu___6 -> Obj.magic (Obj.repr (failwith "arity")) in + let nbe_interp cbs us args = + match args with + | (a1, uu___6)::(b1, uu___7)::[] -> + Obj.magic + (Obj.repr + (let uu___8 = + let uu___9 = + let uu___10 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___1) cbs a1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Dollar_Greater + FStarC_Class_Monad.monad_option () + () + (fun uu___11 -> + (Obj.magic nbe_f) uu___11) + (Obj.magic uu___10)) in + let uu___10 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___3) cbs b1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option () + () (Obj.magic uu___9) + (Obj.magic uu___10)) in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () + (Obj.magic uu___8) + (fun uu___9 -> + (fun r1 -> + let r1 = Obj.magic r1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () (Obj.magic r1) + (fun uu___9 -> + (fun r2 -> + let r2 = Obj.magic r2 in + let uu___9 = + FStarC_TypeChecker_NBETerm.embed + (solve uu___5) cbs + r2 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Class_Monad.monad_option + () + (Obj.magic uu___9))) + uu___9))) uu___9))) + | uu___6 -> Obj.magic (Obj.repr (failwith "arity")) in + as_primitive_step_nbecbs true + (name, (Prims.of_int (2)), u_arity, interp, + nbe_interp) +let mk3' : + 'a 'b 'c 'r 'na 'nb 'nc 'nr . + Prims.int -> + FStarC_Ident.lid -> + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'na FStarC_TypeChecker_NBETerm.embedding -> + 'b FStarC_Syntax_Embeddings_Base.embedding -> + 'nb FStarC_TypeChecker_NBETerm.embedding -> + 'c FStarC_Syntax_Embeddings_Base.embedding -> + 'nc FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + 'nr FStarC_TypeChecker_NBETerm.embedding -> + ('a -> 'b -> 'c -> 'r FStar_Pervasives_Native.option) + -> + ('na -> + 'nb -> 'nc -> 'nr FStar_Pervasives_Native.option) + -> primitive_step + = + fun u_arity -> + fun name -> + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun uu___4 -> + fun uu___5 -> + fun uu___6 -> + fun uu___7 -> + fun f -> + fun nbe_f -> + let interp psc1 cb us args = + match args with + | (a1, uu___8)::(b1, uu___9)::(c1, uu___10)::[] + -> + Obj.magic + (Obj.repr + (let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + try_unembed_simple uu___ a1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Dollar_Greater + FStarC_Class_Monad.monad_option + () () + (fun uu___15 -> + (Obj.magic f) uu___15) + (Obj.magic uu___14)) in + let uu___14 = + try_unembed_simple uu___2 b1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___13) + (Obj.magic uu___14)) in + let uu___13 = + try_unembed_simple uu___4 c1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___12) + (Obj.magic uu___13)) in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () + (Obj.magic uu___11) + (fun uu___12 -> + (fun r1 -> + let r1 = Obj.magic r1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () (Obj.magic r1) + (fun uu___12 -> + (fun r2 -> + let r2 = + Obj.magic r2 in + let uu___12 = + embed_simple + uu___6 + psc1.psc_range + r2 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Class_Monad.monad_option + () + (Obj.magic + uu___12))) + uu___12))) uu___12))) + | uu___8 -> + Obj.magic (Obj.repr (failwith "arity")) in + let nbe_interp cbs us args = + match args with + | (a1, uu___8)::(b1, uu___9)::(c1, uu___10)::[] + -> + Obj.magic + (Obj.repr + (let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___1) cbs a1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Dollar_Greater + FStarC_Class_Monad.monad_option + () () + (fun uu___15 -> + (Obj.magic nbe_f) uu___15) + (Obj.magic uu___14)) in + let uu___14 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___3) cbs b1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___13) + (Obj.magic uu___14)) in + let uu___13 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___5) cbs c1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___12) + (Obj.magic uu___13)) in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () + (Obj.magic uu___11) + (fun uu___12 -> + (fun r1 -> + let r1 = Obj.magic r1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () (Obj.magic r1) + (fun uu___12 -> + (fun r2 -> + let r2 = + Obj.magic r2 in + let uu___12 = + FStarC_TypeChecker_NBETerm.embed + (solve uu___7) + cbs r2 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Class_Monad.monad_option + () + (Obj.magic + uu___12))) + uu___12))) uu___12))) + | uu___8 -> + Obj.magic (Obj.repr (failwith "arity")) in + as_primitive_step_nbecbs true + (name, (Prims.of_int (3)), u_arity, interp, + nbe_interp) +let mk4' : + 'a 'b 'c 'd 'r 'na 'nb 'nc 'nd 'nr . + Prims.int -> + FStarC_Ident.lid -> + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'na FStarC_TypeChecker_NBETerm.embedding -> + 'b FStarC_Syntax_Embeddings_Base.embedding -> + 'nb FStarC_TypeChecker_NBETerm.embedding -> + 'c FStarC_Syntax_Embeddings_Base.embedding -> + 'nc FStarC_TypeChecker_NBETerm.embedding -> + 'd FStarC_Syntax_Embeddings_Base.embedding -> + 'nd FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + 'nr FStarC_TypeChecker_NBETerm.embedding -> + ('a -> + 'b -> + 'c -> + 'd -> 'r FStar_Pervasives_Native.option) + -> + ('na -> + 'nb -> + 'nc -> + 'nd -> + 'nr FStar_Pervasives_Native.option) + -> primitive_step + = + fun u_arity -> + fun name -> + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun uu___4 -> + fun uu___5 -> + fun uu___6 -> + fun uu___7 -> + fun uu___8 -> + fun uu___9 -> + fun f -> + fun nbe_f -> + let interp psc1 cb us args = + match args with + | (a1, uu___10)::(b1, uu___11)::(c1, uu___12):: + (d1, uu___13)::[] -> + Obj.magic + (Obj.repr + (let uu___14 = + let uu___15 = + let uu___16 = + let uu___17 = + let uu___18 = + try_unembed_simple uu___ + a1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Dollar_Greater + FStarC_Class_Monad.monad_option + () () + (fun uu___19 -> + (Obj.magic f) + uu___19) + (Obj.magic uu___18)) in + let uu___18 = + try_unembed_simple uu___2 + b1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () + (Obj.magic uu___17) + (Obj.magic uu___18)) in + let uu___17 = + try_unembed_simple uu___4 c1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___16) + (Obj.magic uu___17)) in + let uu___16 = + try_unembed_simple uu___6 d1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___15) + (Obj.magic uu___16)) in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___14) + (fun uu___15 -> + (fun r1 -> + let r1 = Obj.magic r1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () (Obj.magic r1) + (fun uu___15 -> + (fun r2 -> + let r2 = + Obj.magic r2 in + let uu___15 = + embed_simple + uu___8 + psc1.psc_range + r2 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Class_Monad.monad_option + () + (Obj.magic + uu___15))) + uu___15))) + uu___15))) + | uu___10 -> + Obj.magic (Obj.repr (failwith "arity")) in + let nbe_interp cbs us args = + match args with + | (a1, uu___10)::(b1, uu___11)::(c1, uu___12):: + (d1, uu___13)::[] -> + Obj.magic + (Obj.repr + (let uu___14 = + let uu___15 = + let uu___16 = + let uu___17 = + let uu___18 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___1) cbs a1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Dollar_Greater + FStarC_Class_Monad.monad_option + () () + (fun uu___19 -> + (Obj.magic nbe_f) + uu___19) + (Obj.magic uu___18)) in + let uu___18 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___3) cbs b1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () + (Obj.magic uu___17) + (Obj.magic uu___18)) in + let uu___17 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___5) cbs c1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___16) + (Obj.magic uu___17)) in + let uu___16 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___7) cbs d1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___15) + (Obj.magic uu___16)) in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___14) + (fun uu___15 -> + (fun r1 -> + let r1 = Obj.magic r1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () (Obj.magic r1) + (fun uu___15 -> + (fun r2 -> + let r2 = + Obj.magic r2 in + let uu___15 = + FStarC_TypeChecker_NBETerm.embed + (solve + uu___9) + cbs r2 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Class_Monad.monad_option + () + (Obj.magic + uu___15))) + uu___15))) + uu___15))) + | uu___10 -> + Obj.magic (Obj.repr (failwith "arity")) in + as_primitive_step_nbecbs true + (name, (Prims.of_int (4)), u_arity, interp, + nbe_interp) +let mk5' : + 'a 'b 'c 'd 'e 'r 'na 'nb 'nc 'nd 'ne 'nr . + Prims.int -> + FStarC_Ident.lid -> + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'na FStarC_TypeChecker_NBETerm.embedding -> + 'b FStarC_Syntax_Embeddings_Base.embedding -> + 'nb FStarC_TypeChecker_NBETerm.embedding -> + 'c FStarC_Syntax_Embeddings_Base.embedding -> + 'nc FStarC_TypeChecker_NBETerm.embedding -> + 'd FStarC_Syntax_Embeddings_Base.embedding -> + 'nd FStarC_TypeChecker_NBETerm.embedding -> + 'e FStarC_Syntax_Embeddings_Base.embedding -> + 'ne FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + 'nr FStarC_TypeChecker_NBETerm.embedding -> + ('a -> + 'b -> + 'c -> + 'd -> + 'e -> + 'r FStar_Pervasives_Native.option) + -> + ('na -> + 'nb -> + 'nc -> + 'nd -> + 'ne -> + 'nr + FStar_Pervasives_Native.option) + -> primitive_step + = + fun u_arity -> + fun name -> + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun uu___4 -> + fun uu___5 -> + fun uu___6 -> + fun uu___7 -> + fun uu___8 -> + fun uu___9 -> + fun uu___10 -> + fun uu___11 -> + fun f -> + fun nbe_f -> + let interp psc1 cb us args = + match args with + | (a1, uu___12)::(b1, uu___13)::(c1, + uu___14):: + (d1, uu___15)::(e1, uu___16)::[] -> + Obj.magic + (Obj.repr + (let uu___17 = + let uu___18 = + let uu___19 = + let uu___20 = + let uu___21 = + let uu___22 = + try_unembed_simple + uu___ a1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Dollar_Greater + FStarC_Class_Monad.monad_option + () () + (fun uu___23 -> + (Obj.magic f) + uu___23) + (Obj.magic + uu___22)) in + let uu___22 = + try_unembed_simple + uu___2 b1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () + (Obj.magic uu___21) + (Obj.magic uu___22)) in + let uu___21 = + try_unembed_simple + uu___4 c1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () + (Obj.magic uu___20) + (Obj.magic uu___21)) in + let uu___20 = + try_unembed_simple uu___6 + d1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () + (Obj.magic uu___19) + (Obj.magic uu___20)) in + let uu___19 = + try_unembed_simple uu___8 + e1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () + (Obj.magic uu___18) + (Obj.magic uu___19)) in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___17) + (fun uu___18 -> + (fun r1 -> + let r1 = Obj.magic r1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () + (Obj.magic r1) + (fun uu___18 -> + (fun r2 -> + let r2 = + Obj.magic + r2 in + let uu___18 + = + embed_simple + uu___10 + psc1.psc_range + r2 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Class_Monad.monad_option + () + (Obj.magic + uu___18))) + uu___18))) + uu___18))) + | uu___12 -> + Obj.magic + (Obj.repr (failwith "arity")) in + let nbe_interp cbs us args = + match args with + | (a1, uu___12)::(b1, uu___13)::(c1, + uu___14):: + (d1, uu___15)::(e1, uu___16)::[] -> + Obj.magic + (Obj.repr + (let uu___17 = + let uu___18 = + let uu___19 = + let uu___20 = + let uu___21 = + let uu___22 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___1) + cbs a1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Dollar_Greater + FStarC_Class_Monad.monad_option + () () + (fun uu___23 -> + (Obj.magic + nbe_f) + uu___23) + (Obj.magic + uu___22)) in + let uu___22 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___3) cbs + b1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () + (Obj.magic uu___21) + (Obj.magic uu___22)) in + let uu___21 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___5) cbs c1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () + (Obj.magic uu___20) + (Obj.magic uu___21)) in + let uu___20 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___7) cbs d1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () + (Obj.magic uu___19) + (Obj.magic uu___20)) in + let uu___19 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___9) cbs e1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () + (Obj.magic uu___18) + (Obj.magic uu___19)) in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___17) + (fun uu___18 -> + (fun r1 -> + let r1 = Obj.magic r1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () + (Obj.magic r1) + (fun uu___18 -> + (fun r2 -> + let r2 = + Obj.magic + r2 in + let uu___18 + = + FStarC_TypeChecker_NBETerm.embed + (solve + uu___11) + cbs r2 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Class_Monad.monad_option + () + (Obj.magic + uu___18))) + uu___18))) + uu___18))) + | uu___12 -> + Obj.magic + (Obj.repr (failwith "arity")) in + as_primitive_step_nbecbs true + (name, (Prims.of_int (5)), u_arity, + interp, nbe_interp) +let mk6' : + 'a 'b 'c 'd 'e 'f 'r 'na 'nb 'nc 'nd 'ne 'nf 'nr . + Prims.int -> + FStarC_Ident.lid -> + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'na FStarC_TypeChecker_NBETerm.embedding -> + 'b FStarC_Syntax_Embeddings_Base.embedding -> + 'nb FStarC_TypeChecker_NBETerm.embedding -> + 'c FStarC_Syntax_Embeddings_Base.embedding -> + 'nc FStarC_TypeChecker_NBETerm.embedding -> + 'd FStarC_Syntax_Embeddings_Base.embedding -> + 'nd FStarC_TypeChecker_NBETerm.embedding -> + 'e FStarC_Syntax_Embeddings_Base.embedding -> + 'ne FStarC_TypeChecker_NBETerm.embedding -> + 'f FStarC_Syntax_Embeddings_Base.embedding -> + 'nf FStarC_TypeChecker_NBETerm.embedding -> + 'r FStarC_Syntax_Embeddings_Base.embedding -> + 'nr FStarC_TypeChecker_NBETerm.embedding -> + ('a -> + 'b -> + 'c -> + 'd -> + 'e -> + 'f -> + 'r + FStar_Pervasives_Native.option) + -> + ('na -> + 'nb -> + 'nc -> + 'nd -> + 'ne -> + 'nf -> + 'nr + FStar_Pervasives_Native.option) + -> primitive_step + = + fun u_arity -> + fun name -> + fun uu___ -> + fun uu___1 -> + fun uu___2 -> + fun uu___3 -> + fun uu___4 -> + fun uu___5 -> + fun uu___6 -> + fun uu___7 -> + fun uu___8 -> + fun uu___9 -> + fun uu___10 -> + fun uu___11 -> + fun uu___12 -> + fun uu___13 -> + fun ff -> + fun nbe_ff -> + let interp psc1 cb us args = + match args with + | (a1, uu___14)::(b1, uu___15):: + (c1, uu___16)::(d1, uu___17):: + (e1, uu___18)::(f1, uu___19)::[] + -> + Obj.magic + (Obj.repr + (let uu___20 = + let uu___21 = + let uu___22 = + let uu___23 = + let uu___24 = + let uu___25 = + let uu___26 = + try_unembed_simple + uu___ a1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Dollar_Greater + FStarC_Class_Monad.monad_option + () () + (fun + uu___27 + -> + (Obj.magic + ff) + uu___27) + (Obj.magic + uu___26)) in + let uu___26 = + try_unembed_simple + uu___2 b1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () + (Obj.magic + uu___25) + (Obj.magic + uu___26)) in + let uu___25 = + try_unembed_simple + uu___4 c1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () + (Obj.magic + uu___24) + (Obj.magic + uu___25)) in + let uu___24 = + try_unembed_simple + uu___6 d1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () + (Obj.magic + uu___23) + (Obj.magic + uu___24)) in + let uu___23 = + try_unembed_simple + uu___8 e1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () + (Obj.magic uu___22) + (Obj.magic uu___23)) in + let uu___22 = + try_unembed_simple + uu___10 f1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () + (Obj.magic uu___21) + (Obj.magic uu___22)) in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___20) + (fun uu___21 -> + (fun r1 -> + let r1 = + Obj.magic r1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () + (Obj.magic r1) + (fun uu___21 + -> + (fun r2 -> + let r2 = + Obj.magic + r2 in + let uu___21 + = + embed_simple + uu___12 + psc1.psc_range + r2 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Class_Monad.monad_option + () + (Obj.magic + uu___21))) + uu___21))) + uu___21))) + | uu___14 -> + Obj.magic + (Obj.repr (failwith "arity")) in + let nbe_interp cbs us args = + match args with + | (a1, uu___14)::(b1, uu___15):: + (c1, uu___16)::(d1, uu___17):: + (e1, uu___18)::(f1, uu___19)::[] + -> + Obj.magic + (Obj.repr + (let uu___20 = + let uu___21 = + let uu___22 = + let uu___23 = + let uu___24 = + let uu___25 = + let uu___26 = + FStarC_TypeChecker_NBETerm.unembed + (solve + uu___1) + cbs a1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Dollar_Greater + FStarC_Class_Monad.monad_option + () () + (fun + uu___27 + -> + (Obj.magic + nbe_ff) + uu___27) + (Obj.magic + uu___26)) in + let uu___26 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___3) + cbs b1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () + (Obj.magic + uu___25) + (Obj.magic + uu___26)) in + let uu___25 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___5) + cbs c1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () + (Obj.magic + uu___24) + (Obj.magic + uu___25)) in + let uu___24 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___7) + cbs d1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () + (Obj.magic + uu___23) + (Obj.magic + uu___24)) in + let uu___23 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___9) cbs + e1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () + (Obj.magic uu___22) + (Obj.magic uu___23)) in + let uu___22 = + FStarC_TypeChecker_NBETerm.unembed + (solve uu___11) cbs + f1 in + Obj.magic + (FStarC_Class_Monad.op_Less_Star_Greater + FStarC_Class_Monad.monad_option + () () + (Obj.magic uu___21) + (Obj.magic uu___22)) in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () (Obj.magic uu___20) + (fun uu___21 -> + (fun r1 -> + let r1 = + Obj.magic r1 in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option + () () + (Obj.magic r1) + (fun uu___21 + -> + (fun r2 -> + let r2 = + Obj.magic + r2 in + let uu___21 + = + FStarC_TypeChecker_NBETerm.embed + (solve + uu___13) + cbs r2 in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Class_Monad.monad_option + () + (Obj.magic + uu___21))) + uu___21))) + uu___21))) + | uu___14 -> + Obj.magic + (Obj.repr (failwith "arity")) in + as_primitive_step_nbecbs true + (name, (Prims.of_int (6)), u_arity, + interp, nbe_interp) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_Docs.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_Docs.ml new file mode 100644 index 00000000000..52aabebe084 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_Docs.ml @@ -0,0 +1,19 @@ +open Prims +let (ops : FStarC_TypeChecker_Primops_Base.primitive_step Prims.list) = + let nm l = FStarC_Parser_Const.p2l ["FStar"; "Stubs"; "Pprint"; l] in + let uu___ = + let uu___1 = nm "arbitrary_string" in + FStarC_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___1 + FStarC_Syntax_Embeddings.e_string FStarC_TypeChecker_NBETerm.e_string + FStarC_Syntax_Embeddings.e_document + FStarC_TypeChecker_NBETerm.e_document FStarC_Pprint.arbitrary_string in + let uu___1 = + let uu___2 = + let uu___3 = nm "render" in + FStarC_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___3 + FStarC_Syntax_Embeddings.e_document + FStarC_TypeChecker_NBETerm.e_document + FStarC_Syntax_Embeddings.e_string FStarC_TypeChecker_NBETerm.e_string + FStarC_Pprint.render in + [uu___2] in + uu___ :: uu___1 \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_Eq.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_Eq.ml new file mode 100644 index 00000000000..be9b5cb50ee --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_Eq.ml @@ -0,0 +1,288 @@ +open Prims +let (s_eq : + FStarC_TypeChecker_Env.env_t -> + FStarC_Syntax_Embeddings.abstract_term -> + FStarC_Syntax_Embeddings.abstract_term -> + FStarC_Syntax_Embeddings.abstract_term -> + Prims.bool FStar_Pervasives_Native.option) + = + fun env -> + fun _typ -> + fun x -> + fun y -> + let uu___ = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm env + (FStarC_Syntax_Embeddings.__proj__Abstract__item__t x) + (FStarC_Syntax_Embeddings.__proj__Abstract__item__t y) in + match uu___ with + | FStarC_TypeChecker_TermEqAndSimplify.Equal -> + FStar_Pervasives_Native.Some true + | FStarC_TypeChecker_TermEqAndSimplify.NotEqual -> + FStar_Pervasives_Native.Some false + | uu___1 -> FStar_Pervasives_Native.None +let (nbe_eq : + FStarC_TypeChecker_Env.env_t -> + FStarC_TypeChecker_NBETerm.abstract_nbe_term -> + FStarC_TypeChecker_NBETerm.abstract_nbe_term -> + FStarC_TypeChecker_NBETerm.abstract_nbe_term -> + Prims.bool FStar_Pervasives_Native.option) + = + fun env -> + fun _typ -> + fun x -> + fun y -> + let uu___ = + FStarC_TypeChecker_NBETerm.eq_t env + (FStarC_TypeChecker_NBETerm.__proj__AbstractNBE__item__t x) + (FStarC_TypeChecker_NBETerm.__proj__AbstractNBE__item__t y) in + match uu___ with + | FStarC_TypeChecker_TermEqAndSimplify.Equal -> + FStar_Pervasives_Native.Some true + | FStarC_TypeChecker_TermEqAndSimplify.NotEqual -> + FStar_Pervasives_Native.Some false + | uu___1 -> FStar_Pervasives_Native.None +let push3 : + 'uuuuu 'uuuuu1 'uuuuu2 'uuuuu3 'uuuuu4 . + ('uuuuu -> 'uuuuu1) -> + ('uuuuu2 -> 'uuuuu3 -> 'uuuuu4 -> 'uuuuu) -> + 'uuuuu2 -> 'uuuuu3 -> 'uuuuu4 -> 'uuuuu1 + = + fun f -> fun g -> fun x -> fun y -> fun z -> let uu___ = g x y z in f uu___ +let negopt3 : + 'uuuuu 'uuuuu1 'uuuuu2 . + unit -> + ('uuuuu -> + 'uuuuu1 -> 'uuuuu2 -> Prims.bool FStar_Pervasives_Native.option) + -> + 'uuuuu -> + 'uuuuu1 -> 'uuuuu2 -> Prims.bool FStar_Pervasives_Native.option + = + fun uu___ -> + push3 + (fun uu___1 -> + (Obj.magic + (FStarC_Class_Monad.fmap FStarC_Class_Monad.monad_option () () + (fun uu___1 -> (Obj.magic Prims.op_Negation) uu___1))) uu___1) +let (dec_eq_ops : + FStarC_TypeChecker_Env.env_t -> + FStarC_TypeChecker_Primops_Base.primitive_step Prims.list) + = + fun env -> + let uu___ = + FStarC_TypeChecker_Primops_Base.mk3' Prims.int_zero + FStarC_Parser_Const.op_Eq FStarC_Syntax_Embeddings.e_abstract_term + FStarC_TypeChecker_NBETerm.e_abstract_nbe_term + FStarC_Syntax_Embeddings.e_abstract_term + FStarC_TypeChecker_NBETerm.e_abstract_nbe_term + FStarC_Syntax_Embeddings.e_abstract_term + FStarC_TypeChecker_NBETerm.e_abstract_nbe_term + FStarC_Syntax_Embeddings.e_bool FStarC_TypeChecker_NBETerm.e_bool + (s_eq env) (nbe_eq env) in + let uu___1 = + let uu___2 = + FStarC_TypeChecker_Primops_Base.mk3' Prims.int_zero + FStarC_Parser_Const.op_notEq + FStarC_Syntax_Embeddings.e_abstract_term + FStarC_TypeChecker_NBETerm.e_abstract_nbe_term + FStarC_Syntax_Embeddings.e_abstract_term + FStarC_TypeChecker_NBETerm.e_abstract_nbe_term + FStarC_Syntax_Embeddings.e_abstract_term + FStarC_TypeChecker_NBETerm.e_abstract_nbe_term + FStarC_Syntax_Embeddings.e_bool FStarC_TypeChecker_NBETerm.e_bool + ((negopt3 ()) (s_eq env)) ((negopt3 ()) (nbe_eq env)) in + [uu___2] in + uu___ :: uu___1 +let (s_eq2 : + FStarC_TypeChecker_Env.env_t -> + FStarC_Syntax_Embeddings.abstract_term -> + FStarC_Syntax_Embeddings.abstract_term -> + FStarC_Syntax_Embeddings.abstract_term -> + FStarC_Syntax_Embeddings.abstract_term + FStar_Pervasives_Native.option) + = + fun env -> + fun _typ -> + fun x -> + fun y -> + let uu___ = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm env + (FStarC_Syntax_Embeddings.__proj__Abstract__item__t x) + (FStarC_Syntax_Embeddings.__proj__Abstract__item__t y) in + match uu___ with + | FStarC_TypeChecker_TermEqAndSimplify.Equal -> + FStar_Pervasives_Native.Some + (FStarC_Syntax_Embeddings.Abstract FStarC_Syntax_Util.t_true) + | FStarC_TypeChecker_TermEqAndSimplify.NotEqual -> + FStar_Pervasives_Native.Some + (FStarC_Syntax_Embeddings.Abstract FStarC_Syntax_Util.t_false) + | uu___1 -> FStar_Pervasives_Native.None +let (nbe_eq2 : + FStarC_TypeChecker_Env.env_t -> + FStarC_TypeChecker_NBETerm.abstract_nbe_term -> + FStarC_TypeChecker_NBETerm.abstract_nbe_term -> + FStarC_TypeChecker_NBETerm.abstract_nbe_term -> + FStarC_TypeChecker_NBETerm.abstract_nbe_term + FStar_Pervasives_Native.option) + = + fun env -> + fun _typ -> + fun x -> + fun y -> + let uu___ = + FStarC_TypeChecker_NBETerm.eq_t env + (FStarC_TypeChecker_NBETerm.__proj__AbstractNBE__item__t x) + (FStarC_TypeChecker_NBETerm.__proj__AbstractNBE__item__t y) in + match uu___ with + | FStarC_TypeChecker_TermEqAndSimplify.Equal -> + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Syntax_Syntax.lid_as_fv + FStarC_Parser_Const.true_lid + FStar_Pervasives_Native.None in + FStarC_TypeChecker_NBETerm.mkFV uu___3 [] [] in + FStarC_TypeChecker_NBETerm.AbstractNBE uu___2 in + FStar_Pervasives_Native.Some uu___1 + | FStarC_TypeChecker_TermEqAndSimplify.NotEqual -> + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Syntax_Syntax.lid_as_fv + FStarC_Parser_Const.false_lid + FStar_Pervasives_Native.None in + FStarC_TypeChecker_NBETerm.mkFV uu___3 [] [] in + FStarC_TypeChecker_NBETerm.AbstractNBE uu___2 in + FStar_Pervasives_Native.Some uu___1 + | FStarC_TypeChecker_TermEqAndSimplify.Unknown -> + FStar_Pervasives_Native.None +let (s_eq3 : + FStarC_TypeChecker_Env.env_t -> + FStarC_Syntax_Embeddings.abstract_term -> + FStarC_Syntax_Embeddings.abstract_term -> + FStarC_Syntax_Embeddings.abstract_term -> + FStarC_Syntax_Embeddings.abstract_term -> + FStarC_Syntax_Embeddings.abstract_term + FStar_Pervasives_Native.option) + = + fun env -> + fun typ1 -> + fun typ2 -> + fun x -> + fun y -> + let uu___ = + let uu___1 = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm env + (FStarC_Syntax_Embeddings.__proj__Abstract__item__t typ1) + (FStarC_Syntax_Embeddings.__proj__Abstract__item__t typ2) in + let uu___2 = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm env + (FStarC_Syntax_Embeddings.__proj__Abstract__item__t x) + (FStarC_Syntax_Embeddings.__proj__Abstract__item__t y) in + (uu___1, uu___2) in + match uu___ with + | (FStarC_TypeChecker_TermEqAndSimplify.Equal, + FStarC_TypeChecker_TermEqAndSimplify.Equal) -> + FStar_Pervasives_Native.Some + (FStarC_Syntax_Embeddings.Abstract + FStarC_Syntax_Util.t_true) + | (FStarC_TypeChecker_TermEqAndSimplify.NotEqual, uu___1) -> + FStar_Pervasives_Native.Some + (FStarC_Syntax_Embeddings.Abstract + FStarC_Syntax_Util.t_false) + | (uu___1, FStarC_TypeChecker_TermEqAndSimplify.NotEqual) -> + FStar_Pervasives_Native.Some + (FStarC_Syntax_Embeddings.Abstract + FStarC_Syntax_Util.t_false) + | uu___1 -> FStar_Pervasives_Native.None +let (nbe_eq3 : + FStarC_TypeChecker_Env.env_t -> + FStarC_TypeChecker_NBETerm.abstract_nbe_term -> + FStarC_TypeChecker_NBETerm.abstract_nbe_term -> + FStarC_TypeChecker_NBETerm.abstract_nbe_term -> + FStarC_TypeChecker_NBETerm.abstract_nbe_term -> + FStarC_TypeChecker_NBETerm.abstract_nbe_term + FStar_Pervasives_Native.option) + = + fun env -> + fun typ1 -> + fun typ2 -> + fun x -> + fun y -> + let uu___ = + let uu___1 = + FStarC_TypeChecker_NBETerm.eq_t env + (FStarC_TypeChecker_NBETerm.__proj__AbstractNBE__item__t + typ1) + (FStarC_TypeChecker_NBETerm.__proj__AbstractNBE__item__t + typ2) in + let uu___2 = + FStarC_TypeChecker_NBETerm.eq_t env + (FStarC_TypeChecker_NBETerm.__proj__AbstractNBE__item__t x) + (FStarC_TypeChecker_NBETerm.__proj__AbstractNBE__item__t y) in + (uu___1, uu___2) in + match uu___ with + | (FStarC_TypeChecker_TermEqAndSimplify.Equal, + FStarC_TypeChecker_TermEqAndSimplify.Equal) -> + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Syntax_Syntax.lid_as_fv + FStarC_Parser_Const.true_lid + FStar_Pervasives_Native.None in + FStarC_TypeChecker_NBETerm.mkFV uu___3 [] [] in + FStarC_TypeChecker_NBETerm.AbstractNBE uu___2 in + FStar_Pervasives_Native.Some uu___1 + | (FStarC_TypeChecker_TermEqAndSimplify.NotEqual, uu___1) -> + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Syntax_Syntax.lid_as_fv + FStarC_Parser_Const.false_lid + FStar_Pervasives_Native.None in + FStarC_TypeChecker_NBETerm.mkFV uu___4 [] [] in + FStarC_TypeChecker_NBETerm.AbstractNBE uu___3 in + FStar_Pervasives_Native.Some uu___2 + | (uu___1, FStarC_TypeChecker_TermEqAndSimplify.NotEqual) -> + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Syntax_Syntax.lid_as_fv + FStarC_Parser_Const.false_lid + FStar_Pervasives_Native.None in + FStarC_TypeChecker_NBETerm.mkFV uu___4 [] [] in + FStarC_TypeChecker_NBETerm.AbstractNBE uu___3 in + FStar_Pervasives_Native.Some uu___2 + | uu___1 -> FStar_Pervasives_Native.None +let (prop_eq_ops : + FStarC_TypeChecker_Env.env_t -> + FStarC_TypeChecker_Primops_Base.primitive_step Prims.list) + = + fun env -> + let uu___ = + FStarC_TypeChecker_Primops_Base.mk3' Prims.int_one + FStarC_Parser_Const.eq2_lid FStarC_Syntax_Embeddings.e_abstract_term + FStarC_TypeChecker_NBETerm.e_abstract_nbe_term + FStarC_Syntax_Embeddings.e_abstract_term + FStarC_TypeChecker_NBETerm.e_abstract_nbe_term + FStarC_Syntax_Embeddings.e_abstract_term + FStarC_TypeChecker_NBETerm.e_abstract_nbe_term + FStarC_Syntax_Embeddings.e_abstract_term + FStarC_TypeChecker_NBETerm.e_abstract_nbe_term (s_eq2 env) + (nbe_eq2 env) in + let uu___1 = + let uu___2 = + FStarC_TypeChecker_Primops_Base.mk4' (Prims.of_int (2)) + FStarC_Parser_Const.eq3_lid + FStarC_Syntax_Embeddings.e_abstract_term + FStarC_TypeChecker_NBETerm.e_abstract_nbe_term + FStarC_Syntax_Embeddings.e_abstract_term + FStarC_TypeChecker_NBETerm.e_abstract_nbe_term + FStarC_Syntax_Embeddings.e_abstract_term + FStarC_TypeChecker_NBETerm.e_abstract_nbe_term + FStarC_Syntax_Embeddings.e_abstract_term + FStarC_TypeChecker_NBETerm.e_abstract_nbe_term + FStarC_Syntax_Embeddings.e_abstract_term + FStarC_TypeChecker_NBETerm.e_abstract_nbe_term (s_eq3 env) + (nbe_eq3 env) in + [uu___2] in + uu___ :: uu___1 \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_Erased.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_Erased.ml new file mode 100644 index 00000000000..371746e4d13 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_Erased.ml @@ -0,0 +1,151 @@ +open Prims +type 'a emb_erased = + | Hide of 'a +let uu___is_Hide : 'a . 'a emb_erased -> Prims.bool = fun projectee -> true +let __proj__Hide__item__x : 'a . 'a emb_erased -> 'a = + fun projectee -> match projectee with | Hide x -> x +let e_erased : + 'a . + 'a FStarC_Syntax_Embeddings_Base.embedding -> + 'a emb_erased FStarC_Syntax_Embeddings_Base.embedding + = + fun d -> + let em x rng shadow cbs = + let uu___ = x in + match uu___ with + | Hide x1 -> + let h = + FStarC_Syntax_Syntax.fvar FStarC_Parser_Const.hide + FStar_Pervasives_Native.None in + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Embeddings_Base.type_of d in + FStarC_Syntax_Syntax.iarg uu___3 in + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Syntax_Embeddings_Base.embed d x1 in + uu___6 rng shadow cbs in + FStarC_Syntax_Syntax.as_arg uu___5 in + [uu___4] in + uu___2 :: uu___3 in + FStarC_Syntax_Util.mk_app h uu___1 in + let un uu___1 uu___ = + (fun t -> + fun cbs -> + let uu___ = FStarC_Syntax_Util.head_and_args t in + match uu___ with + | (head, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst head in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, + _t::(a1, FStar_Pervasives_Native.None)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.hide + -> + Obj.magic + (Obj.repr + (let uu___2 = + FStarC_Syntax_Embeddings_Base.unembed d a1 cbs in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () + (Obj.magic uu___2) + (fun uu___3 -> + (fun v -> + let v = Obj.magic v in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Class_Monad.monad_option () + (Obj.magic (Hide v)))) uu___3))) + | uu___2 -> Obj.magic (Obj.repr FStar_Pervasives_Native.None))) + uu___1 uu___ in + FStarC_Syntax_Embeddings_Base.mk_emb_full em un + (fun uu___ -> + let uu___1 = FStarC_Syntax_Embeddings_Base.type_of d in + FStarC_Syntax_Syntax.t_erased_of uu___1) + (fun uu___ -> + match uu___ with + | Hide x -> + let uu___1 = + let uu___2 = FStarC_Syntax_Embeddings_Base.printer_of d in + uu___2 x in + Prims.strcat "Hide " uu___1) + (fun uu___ -> FStarC_Syntax_Syntax.ET_abstract) +let nbe_e_erased : + 'a . + 'a FStarC_TypeChecker_NBETerm.embedding -> + 'a emb_erased FStarC_TypeChecker_NBETerm.embedding + = + fun d -> + let em cbs x = + let uu___ = x in + match uu___ with + | Hide x1 -> + let fv = + FStarC_Syntax_Syntax.lid_as_fv FStarC_Parser_Const.hide + FStar_Pervasives_Native.None in + let uu___1 = + let uu___2 = + let uu___3 = FStarC_TypeChecker_NBETerm.embed d cbs x1 in + FStarC_TypeChecker_NBETerm.as_arg uu___3 in + [uu___2] in + FStarC_TypeChecker_NBETerm.mkFV fv [] uu___1 in + let un uu___1 uu___ = + (fun cbs -> + fun t -> + let uu___ = FStarC_TypeChecker_NBETerm.nbe_t_of_t t in + match uu___ with + | FStarC_TypeChecker_NBETerm.FV + (fv, uu___1, (_t, uu___2)::(body, uu___3)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.hide -> + Obj.magic + (Obj.repr + (let uu___4 = + FStarC_TypeChecker_NBETerm.unembed d cbs body in + FStarC_Class_Monad.op_let_Bang + FStarC_Class_Monad.monad_option () () + (Obj.magic uu___4) + (fun uu___5 -> + (fun v -> + let v = Obj.magic v in + Obj.magic + (FStarC_Class_Monad.return + FStarC_Class_Monad.monad_option () + (Obj.magic (Hide v)))) uu___5))) + | uu___1 -> Obj.magic (Obj.repr FStar_Pervasives_Native.None)) + uu___1 uu___ in + FStarC_TypeChecker_NBETerm.mk_emb em un (fun uu___ -> Prims.magic ()) + (fun uu___ -> FStarC_Syntax_Syntax.ET_abstract) +let (s_reveal : + FStarC_Syntax_Embeddings.abstract_term -> + FStarC_Syntax_Embeddings.abstract_term emb_erased -> + FStarC_Syntax_Embeddings.abstract_term FStar_Pervasives_Native.option) + = + fun a -> + fun e -> + let uu___ = e in + match uu___ with | Hide x -> FStar_Pervasives_Native.Some x +let (nbe_reveal : + FStarC_TypeChecker_NBETerm.abstract_nbe_term -> + FStarC_TypeChecker_NBETerm.abstract_nbe_term emb_erased -> + FStarC_TypeChecker_NBETerm.abstract_nbe_term + FStar_Pervasives_Native.option) + = + fun a -> + fun e -> + let uu___ = e in + match uu___ with | Hide x -> FStar_Pervasives_Native.Some x +let (ops : FStarC_TypeChecker_Primops_Base.primitive_step Prims.list) = + let uu___ = + FStarC_TypeChecker_Primops_Base.mk2' Prims.int_one + FStarC_Parser_Const.reveal FStarC_Syntax_Embeddings.e_abstract_term + FStarC_TypeChecker_NBETerm.e_abstract_nbe_term + (e_erased FStarC_Syntax_Embeddings.e_abstract_term) + (nbe_e_erased FStarC_TypeChecker_NBETerm.e_abstract_nbe_term) + FStarC_Syntax_Embeddings.e_abstract_term + FStarC_TypeChecker_NBETerm.e_abstract_nbe_term s_reveal nbe_reveal in + [uu___] \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_Errors_Msg.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_Errors_Msg.ml new file mode 100644 index 00000000000..f8fecf822ff --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_Errors_Msg.ml @@ -0,0 +1,85 @@ +open Prims +let (ops : FStarC_TypeChecker_Primops_Base.primitive_step Prims.list) = + let nm l = FStarC_Parser_Const.p2l ["FStar"; "Stubs"; "Errors"; "Msg"; l] in + let uu___ = + let uu___1 = nm "text" in + FStarC_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___1 + FStarC_Syntax_Embeddings.e_string FStarC_TypeChecker_NBETerm.e_string + FStarC_Syntax_Embeddings.e_document + FStarC_TypeChecker_NBETerm.e_document FStarC_Errors_Msg.text in + let uu___1 = + let uu___2 = + let uu___3 = nm "sublist" in + FStarC_TypeChecker_Primops_Base.mk2 Prims.int_zero uu___3 + FStarC_Syntax_Embeddings.e_document + FStarC_TypeChecker_NBETerm.e_document + (FStarC_Syntax_Embeddings.e_list FStarC_Syntax_Embeddings.e_document) + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_document) + FStarC_Syntax_Embeddings.e_document + FStarC_TypeChecker_NBETerm.e_document FStarC_Errors_Msg.sublist in + let uu___3 = + let uu___4 = + let uu___5 = nm "bulleted" in + FStarC_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___5 + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_document) + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_document) + FStarC_Syntax_Embeddings.e_document + FStarC_TypeChecker_NBETerm.e_document FStarC_Errors_Msg.bulleted in + let uu___5 = + let uu___6 = + let uu___7 = nm "mkmsg" in + FStarC_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___7 + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_document) + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_document) FStarC_Errors_Msg.mkmsg in + let uu___7 = + let uu___8 = + let uu___9 = nm "subdoc" in + FStarC_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___9 + FStarC_Syntax_Embeddings.e_document + FStarC_TypeChecker_NBETerm.e_document + FStarC_Syntax_Embeddings.e_document + FStarC_TypeChecker_NBETerm.e_document FStarC_Errors_Msg.subdoc in + let uu___9 = + let uu___10 = + let uu___11 = nm "renderdoc" in + FStarC_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___11 + FStarC_Syntax_Embeddings.e_document + FStarC_TypeChecker_NBETerm.e_document + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string + FStarC_Errors_Msg.renderdoc in + let uu___11 = + let uu___12 = + let uu___13 = nm "backtrace_doc" in + FStarC_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___13 + FStarC_Syntax_Embeddings.e_unit + FStarC_TypeChecker_NBETerm.e_unit + FStarC_Syntax_Embeddings.e_document + FStarC_TypeChecker_NBETerm.e_document + FStarC_Errors_Msg.backtrace_doc in + let uu___13 = + let uu___14 = + let uu___15 = nm "rendermsg" in + FStarC_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___15 + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_document) + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_document) + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string + FStarC_Errors_Msg.rendermsg in + [uu___14] in + uu___12 :: uu___13 in + uu___10 :: uu___11 in + uu___8 :: uu___9 in + uu___6 :: uu___7 in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + uu___ :: uu___1 \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_Issue.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_Issue.ml new file mode 100644 index 00000000000..7e08efe7716 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_Issue.ml @@ -0,0 +1,114 @@ +open Prims +let (ops : FStarC_TypeChecker_Primops_Base.primitive_step Prims.list) = + let mk_lid l = FStarC_Parser_Const.p2l ["FStar"; "Issue"; l] in + let uu___ = + let uu___1 = mk_lid "message_of_issue" in + FStarC_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___1 + FStarC_Syntax_Embeddings.e_issue FStarC_TypeChecker_NBETerm.e_issue + (FStarC_Syntax_Embeddings.e_list FStarC_Syntax_Embeddings.e_document) + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_document) + FStarC_Errors.__proj__Mkissue__item__issue_msg in + let uu___1 = + let uu___2 = + let uu___3 = mk_lid "level_of_issue" in + FStarC_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___3 + FStarC_Syntax_Embeddings.e_issue FStarC_TypeChecker_NBETerm.e_issue + FStarC_Syntax_Embeddings.e_string FStarC_TypeChecker_NBETerm.e_string + (fun i -> + FStarC_Errors.string_of_issue_level i.FStarC_Errors.issue_level) in + let uu___3 = + let uu___4 = + let uu___5 = mk_lid "number_of_issue" in + FStarC_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___5 + FStarC_Syntax_Embeddings.e_issue FStarC_TypeChecker_NBETerm.e_issue + (FStarC_Syntax_Embeddings.e_option FStarC_Syntax_Embeddings.e_int) + (FStarC_TypeChecker_NBETerm.e_option + FStarC_TypeChecker_NBETerm.e_int) + (fun uu___6 -> + (fun i -> + Obj.magic + (FStarC_Class_Monad.fmap FStarC_Class_Monad.monad_option () + () + (fun uu___6 -> + (Obj.magic FStarC_BigInt.of_int_fs) uu___6) + (Obj.magic i.FStarC_Errors.issue_number))) uu___6) in + let uu___5 = + let uu___6 = + let uu___7 = mk_lid "range_of_issue" in + FStarC_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___7 + FStarC_Syntax_Embeddings.e_issue + FStarC_TypeChecker_NBETerm.e_issue + (FStarC_Syntax_Embeddings.e_option + FStarC_Syntax_Embeddings.e_range) + (FStarC_TypeChecker_NBETerm.e_option + FStarC_TypeChecker_NBETerm.e_range) + FStarC_Errors.__proj__Mkissue__item__issue_range in + let uu___7 = + let uu___8 = + let uu___9 = mk_lid "context_of_issue" in + FStarC_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___9 + FStarC_Syntax_Embeddings.e_issue + FStarC_TypeChecker_NBETerm.e_issue + FStarC_Syntax_Embeddings.e_string_list + FStarC_TypeChecker_NBETerm.e_string_list + FStarC_Errors.__proj__Mkissue__item__issue_ctx in + let uu___9 = + let uu___10 = + let uu___11 = mk_lid "render_issue" in + FStarC_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___11 + FStarC_Syntax_Embeddings.e_issue + FStarC_TypeChecker_NBETerm.e_issue + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string + FStarC_Errors.format_issue in + let uu___11 = + let uu___12 = + let uu___13 = mk_lid "mk_issue_doc" in + FStarC_TypeChecker_Primops_Base.mk5 Prims.int_zero uu___13 + FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_document) + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_document) + (FStarC_Syntax_Embeddings.e_option + FStarC_Syntax_Embeddings.e_range) + (FStarC_TypeChecker_NBETerm.e_option + FStarC_TypeChecker_NBETerm.e_range) + (FStarC_Syntax_Embeddings.e_option + FStarC_Syntax_Embeddings.e_int) + (FStarC_TypeChecker_NBETerm.e_option + FStarC_TypeChecker_NBETerm.e_int) + FStarC_Syntax_Embeddings.e_string_list + FStarC_TypeChecker_NBETerm.e_string_list + FStarC_Syntax_Embeddings.e_issue + FStarC_TypeChecker_NBETerm.e_issue + (fun level -> + fun msg -> + fun range -> + fun number -> + fun context -> + let uu___14 = + FStarC_Errors.issue_level_of_string level in + let uu___15 = + Obj.magic + (FStarC_Class_Monad.fmap + FStarC_Class_Monad.monad_option () () + (fun uu___16 -> + (Obj.magic FStarC_BigInt.to_int_fs) + uu___16) (Obj.magic number)) in + { + FStarC_Errors.issue_msg = msg; + FStarC_Errors.issue_level = uu___14; + FStarC_Errors.issue_range = range; + FStarC_Errors.issue_number = uu___15; + FStarC_Errors.issue_ctx = context + }) in + [uu___12] in + uu___10 :: uu___11 in + uu___8 :: uu___9 in + uu___6 :: uu___7 in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + uu___ :: uu___1 \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_MachineInts.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_MachineInts.ml new file mode 100644 index 00000000000..f8f8ad206d3 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_MachineInts.ml @@ -0,0 +1,646 @@ +open Prims +type 'a mymon = + (FStarC_TypeChecker_Primops_Base.primitive_step Prims.list, unit, 'a) + FStarC_Compiler_Writer.writer +let (bounded_arith_ops_for : + FStarC_Compiler_MachineInts.machint_kind -> unit mymon) = + fun k -> + let mod_name = FStarC_Compiler_MachineInts.module_name_for k in + let nm s = + let uu___ = + let uu___1 = + let uu___2 = FStarC_Compiler_MachineInts.module_name_for k in + [uu___2; s] in + "FStar" :: uu___1 in + FStarC_Parser_Const.p2l uu___ in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = nm "v" in + FStarC_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___3 + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + FStarC_Syntax_Embeddings.e_int FStarC_TypeChecker_NBETerm.e_int + (FStarC_Compiler_MachineInts.v k) in + let uu___3 = + let uu___4 = + let uu___5 = nm "add" in + FStarC_TypeChecker_Primops_Base.mk2 Prims.int_zero uu___5 + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (fun x -> + fun y -> + let uu___6 = + let uu___7 = FStarC_Compiler_MachineInts.v k x in + let uu___8 = FStarC_Compiler_MachineInts.v k y in + FStarC_BigInt.add_big_int uu___7 uu___8 in + FStarC_Compiler_MachineInts.make_as k x uu___6) in + let uu___5 = + let uu___6 = + let uu___7 = nm "sub" in + FStarC_TypeChecker_Primops_Base.mk2 Prims.int_zero uu___7 + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (fun x -> + fun y -> + let uu___8 = + let uu___9 = FStarC_Compiler_MachineInts.v k x in + let uu___10 = FStarC_Compiler_MachineInts.v k y in + FStarC_BigInt.sub_big_int uu___9 uu___10 in + FStarC_Compiler_MachineInts.make_as k x uu___8) in + let uu___7 = + let uu___8 = + let uu___9 = nm "mul" in + FStarC_TypeChecker_Primops_Base.mk2 Prims.int_zero uu___9 + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (fun x -> + fun y -> + let uu___10 = + let uu___11 = FStarC_Compiler_MachineInts.v k x in + let uu___12 = FStarC_Compiler_MachineInts.v k y in + FStarC_BigInt.mult_big_int uu___11 uu___12 in + FStarC_Compiler_MachineInts.make_as k x uu___10) in + let uu___9 = + let uu___10 = + let uu___11 = nm "gt" in + FStarC_TypeChecker_Primops_Base.mk2 Prims.int_zero uu___11 + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + FStarC_Syntax_Embeddings.e_bool + FStarC_TypeChecker_NBETerm.e_bool + (fun x -> + fun y -> + let uu___12 = FStarC_Compiler_MachineInts.v k x in + let uu___13 = FStarC_Compiler_MachineInts.v k y in + FStarC_BigInt.gt_big_int uu___12 uu___13) in + let uu___11 = + let uu___12 = + let uu___13 = nm "gte" in + FStarC_TypeChecker_Primops_Base.mk2 Prims.int_zero + uu___13 (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + FStarC_Syntax_Embeddings.e_bool + FStarC_TypeChecker_NBETerm.e_bool + (fun x -> + fun y -> + let uu___14 = FStarC_Compiler_MachineInts.v k x in + let uu___15 = FStarC_Compiler_MachineInts.v k y in + FStarC_BigInt.ge_big_int uu___14 uu___15) in + let uu___13 = + let uu___14 = + let uu___15 = nm "lt" in + FStarC_TypeChecker_Primops_Base.mk2 Prims.int_zero + uu___15 (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + FStarC_Syntax_Embeddings.e_bool + FStarC_TypeChecker_NBETerm.e_bool + (fun x -> + fun y -> + let uu___16 = FStarC_Compiler_MachineInts.v k x in + let uu___17 = FStarC_Compiler_MachineInts.v k y in + FStarC_BigInt.lt_big_int uu___16 uu___17) in + let uu___15 = + let uu___16 = + let uu___17 = nm "lte" in + FStarC_TypeChecker_Primops_Base.mk2 Prims.int_zero + uu___17 (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + FStarC_Syntax_Embeddings.e_bool + FStarC_TypeChecker_NBETerm.e_bool + (fun x -> + fun y -> + let uu___18 = + FStarC_Compiler_MachineInts.v k x in + let uu___19 = + FStarC_Compiler_MachineInts.v k y in + FStarC_BigInt.le_big_int uu___18 uu___19) in + [uu___16] in + uu___14 :: uu___15 in + uu___12 :: uu___13 in + uu___10 :: uu___11 in + uu___8 :: uu___9 in + uu___6 :: uu___7 in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + FStarC_Compiler_Writer.emit (FStarC_Class_Monoid.monoid_list ()) uu___1 in + FStarC_Class_Monad.op_let_Bang + (FStarC_Compiler_Writer.monad_writer + (FStarC_Class_Monoid.monoid_list ())) () () uu___ + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + let sz = FStarC_Compiler_MachineInts.width k in + let modulus = + let uu___2 = FStarC_BigInt.of_int_fs sz in + FStarC_BigInt.shift_left_big_int FStarC_BigInt.one uu___2 in + let mod1 x = FStarC_BigInt.mod_big_int x modulus in + let uu___2 = + let uu___3 = FStarC_Compiler_MachineInts.is_unsigned k in + if uu___3 + then + let uu___4 = + let uu___5 = + let uu___6 = nm "add_mod" in + FStarC_TypeChecker_Primops_Base.mk2 Prims.int_zero uu___6 + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (fun x -> + fun y -> + let uu___7 = + let uu___8 = + let uu___9 = FStarC_Compiler_MachineInts.v k x in + let uu___10 = + FStarC_Compiler_MachineInts.v k y in + FStarC_BigInt.add_big_int uu___9 uu___10 in + mod1 uu___8 in + FStarC_Compiler_MachineInts.make_as k x uu___7) in + let uu___6 = + let uu___7 = + let uu___8 = nm "sub_mod" in + FStarC_TypeChecker_Primops_Base.mk2 Prims.int_zero + uu___8 (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (fun x -> + fun y -> + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Compiler_MachineInts.v k x in + let uu___12 = + FStarC_Compiler_MachineInts.v k y in + FStarC_BigInt.sub_big_int uu___11 uu___12 in + mod1 uu___10 in + FStarC_Compiler_MachineInts.make_as k x uu___9) in + let uu___8 = + let uu___9 = + let uu___10 = nm "div" in + FStarC_TypeChecker_Primops_Base.mk2 Prims.int_zero + uu___10 (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (fun x -> + fun y -> + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Compiler_MachineInts.v k x in + let uu___14 = + FStarC_Compiler_MachineInts.v k y in + FStarC_BigInt.div_big_int uu___13 uu___14 in + mod1 uu___12 in + FStarC_Compiler_MachineInts.make_as k x + uu___11) in + let uu___10 = + let uu___11 = + let uu___12 = nm "rem" in + FStarC_TypeChecker_Primops_Base.mk2 Prims.int_zero + uu___12 (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (fun x -> + fun y -> + let uu___13 = + let uu___14 = + let uu___15 = + FStarC_Compiler_MachineInts.v k x in + let uu___16 = + FStarC_Compiler_MachineInts.v k y in + FStarC_BigInt.mod_big_int uu___15 + uu___16 in + mod1 uu___14 in + FStarC_Compiler_MachineInts.make_as k x + uu___13) in + let uu___12 = + let uu___13 = + let uu___14 = nm "logor" in + FStarC_TypeChecker_Primops_Base.mk2 + Prims.int_zero uu___14 + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (fun x -> + fun y -> + let uu___15 = + let uu___16 = + FStarC_Compiler_MachineInts.v k x in + let uu___17 = + FStarC_Compiler_MachineInts.v k y in + FStarC_BigInt.logor_big_int uu___16 + uu___17 in + FStarC_Compiler_MachineInts.make_as k x + uu___15) in + let uu___14 = + let uu___15 = + let uu___16 = nm "logand" in + FStarC_TypeChecker_Primops_Base.mk2 + Prims.int_zero uu___16 + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (fun x -> + fun y -> + let uu___17 = + let uu___18 = + FStarC_Compiler_MachineInts.v k x in + let uu___19 = + FStarC_Compiler_MachineInts.v k y in + FStarC_BigInt.logand_big_int uu___18 + uu___19 in + FStarC_Compiler_MachineInts.make_as k x + uu___17) in + let uu___16 = + let uu___17 = + let uu___18 = nm "logxor" in + FStarC_TypeChecker_Primops_Base.mk2 + Prims.int_zero uu___18 + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (fun x -> + fun y -> + let uu___19 = + let uu___20 = + FStarC_Compiler_MachineInts.v k x in + let uu___21 = + FStarC_Compiler_MachineInts.v k y in + FStarC_BigInt.logxor_big_int uu___20 + uu___21 in + FStarC_Compiler_MachineInts.make_as k + x uu___19) in + let uu___18 = + let uu___19 = + let uu___20 = nm "lognot" in + FStarC_TypeChecker_Primops_Base.mk1 + Prims.int_zero uu___20 + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint + k) + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint + k) + (fun x -> + let uu___21 = + let uu___22 = + let uu___23 = + FStarC_Compiler_MachineInts.v k + x in + FStarC_BigInt.lognot_big_int + uu___23 in + let uu___23 = + FStarC_Compiler_MachineInts.mask k in + FStarC_BigInt.logand_big_int uu___22 + uu___23 in + FStarC_Compiler_MachineInts.make_as k + x uu___21) in + let uu___20 = + let uu___21 = + let uu___22 = nm "shift_left" in + FStarC_TypeChecker_Primops_Base.mk2 + Prims.int_zero uu___22 + (FStarC_Compiler_MachineInts.e_machint + k) + (FStarC_Compiler_MachineInts.nbe_machint + k) + (FStarC_Compiler_MachineInts.e_machint + FStarC_Compiler_MachineInts.UInt32) + (FStarC_Compiler_MachineInts.nbe_machint + FStarC_Compiler_MachineInts.UInt32) + (FStarC_Compiler_MachineInts.e_machint + k) + (FStarC_Compiler_MachineInts.nbe_machint + k) + (fun x -> + fun y -> + let uu___23 = + let uu___24 = + let uu___25 = + FStarC_Compiler_MachineInts.v + k x in + let uu___26 = + FStarC_Compiler_MachineInts.v + FStarC_Compiler_MachineInts.UInt32 + y in + FStarC_BigInt.shift_left_big_int + uu___25 uu___26 in + let uu___25 = + FStarC_Compiler_MachineInts.mask + k in + FStarC_BigInt.logand_big_int + uu___24 uu___25 in + FStarC_Compiler_MachineInts.make_as + k x uu___23) in + let uu___22 = + let uu___23 = + let uu___24 = nm "shift_right" in + FStarC_TypeChecker_Primops_Base.mk2 + Prims.int_zero uu___24 + (FStarC_Compiler_MachineInts.e_machint + k) + (FStarC_Compiler_MachineInts.nbe_machint + k) + (FStarC_Compiler_MachineInts.e_machint + FStarC_Compiler_MachineInts.UInt32) + (FStarC_Compiler_MachineInts.nbe_machint + FStarC_Compiler_MachineInts.UInt32) + (FStarC_Compiler_MachineInts.e_machint + k) + (FStarC_Compiler_MachineInts.nbe_machint + k) + (fun x -> + fun y -> + let uu___25 = + let uu___26 = + let uu___27 = + FStarC_Compiler_MachineInts.v + k x in + let uu___28 = + FStarC_Compiler_MachineInts.v + FStarC_Compiler_MachineInts.UInt32 + y in + FStarC_BigInt.shift_right_big_int + uu___27 uu___28 in + let uu___27 = + FStarC_Compiler_MachineInts.mask + k in + FStarC_BigInt.logand_big_int + uu___26 uu___27 in + FStarC_Compiler_MachineInts.make_as + k x uu___25) in + [uu___23] in + uu___21 :: uu___22 in + uu___19 :: uu___20 in + uu___17 :: uu___18 in + uu___15 :: uu___16 in + uu___13 :: uu___14 in + uu___11 :: uu___12 in + uu___9 :: uu___10 in + uu___7 :: uu___8 in + uu___5 :: uu___6 in + FStarC_Compiler_Writer.emit + (FStarC_Class_Monoid.monoid_list ()) uu___4 + else + FStarC_Class_Monad.return + (FStarC_Compiler_Writer.monad_writer + (FStarC_Class_Monoid.monoid_list ())) () (Obj.repr ()) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + (FStarC_Compiler_Writer.monad_writer + (FStarC_Class_Monoid.monoid_list ())) () () uu___2 + (fun uu___3 -> + (fun uu___3 -> + let uu___3 = Obj.magic uu___3 in + let uu___4 = + let uu___5 = + (FStarC_Compiler_MachineInts.is_unsigned k) && + (k <> FStarC_Compiler_MachineInts.SizeT) in + if uu___5 + then + let uu___6 = + let uu___7 = + let uu___8 = nm "add_underspec" in + FStarC_TypeChecker_Primops_Base.mk2 + Prims.int_zero uu___8 + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (fun x -> + fun y -> + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Compiler_MachineInts.v k x in + let uu___12 = + FStarC_Compiler_MachineInts.v k y in + FStarC_BigInt.add_big_int uu___11 + uu___12 in + mod1 uu___10 in + FStarC_Compiler_MachineInts.make_as k x + uu___9) in + let uu___8 = + let uu___9 = + let uu___10 = nm "sub_underspec" in + FStarC_TypeChecker_Primops_Base.mk2 + Prims.int_zero uu___10 + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint k) + (fun x -> + fun y -> + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Compiler_MachineInts.v k + x in + let uu___14 = + FStarC_Compiler_MachineInts.v k + y in + FStarC_BigInt.sub_big_int uu___13 + uu___14 in + mod1 uu___12 in + FStarC_Compiler_MachineInts.make_as k + x uu___11) in + let uu___10 = + let uu___11 = + let uu___12 = nm "mul_underspec" in + FStarC_TypeChecker_Primops_Base.mk2 + Prims.int_zero uu___12 + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint + k) + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint + k) + (FStarC_Compiler_MachineInts.e_machint k) + (FStarC_Compiler_MachineInts.nbe_machint + k) + (fun x -> + fun y -> + let uu___13 = + let uu___14 = + let uu___15 = + FStarC_Compiler_MachineInts.v + k x in + let uu___16 = + FStarC_Compiler_MachineInts.v + k y in + FStarC_BigInt.mult_big_int + uu___15 uu___16 in + mod1 uu___14 in + FStarC_Compiler_MachineInts.make_as + k x uu___13) in + [uu___11] in + uu___9 :: uu___10 in + uu___7 :: uu___8 in + FStarC_Compiler_Writer.emit + (FStarC_Class_Monoid.monoid_list ()) uu___6 + else + FStarC_Class_Monad.return + (FStarC_Compiler_Writer.monad_writer + (FStarC_Class_Monoid.monoid_list ())) () + (Obj.repr ()) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + (FStarC_Compiler_Writer.monad_writer + (FStarC_Class_Monoid.monoid_list ())) () () + uu___4 + (fun uu___5 -> + (fun uu___5 -> + let uu___5 = Obj.magic uu___5 in + let uu___6 = + let uu___7 = + (FStarC_Compiler_MachineInts.is_unsigned + k) + && + ((k <> + FStarC_Compiler_MachineInts.SizeT) + && + (k <> + FStarC_Compiler_MachineInts.UInt128)) in + if uu___7 + then + let uu___8 = + let uu___9 = + let uu___10 = nm "mul_mod" in + FStarC_TypeChecker_Primops_Base.mk2 + Prims.int_zero uu___10 + (FStarC_Compiler_MachineInts.e_machint + k) + (FStarC_Compiler_MachineInts.nbe_machint + k) + (FStarC_Compiler_MachineInts.e_machint + k) + (FStarC_Compiler_MachineInts.nbe_machint + k) + (FStarC_Compiler_MachineInts.e_machint + k) + (FStarC_Compiler_MachineInts.nbe_machint + k) + (fun x -> + fun y -> + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Compiler_MachineInts.v + k x in + let uu___14 = + FStarC_Compiler_MachineInts.v + k y in + FStarC_BigInt.mult_big_int + uu___13 uu___14 in + mod1 uu___12 in + FStarC_Compiler_MachineInts.make_as + k x uu___11) in + [uu___9] in + FStarC_Compiler_Writer.emit + (FStarC_Class_Monoid.monoid_list ()) + uu___8 + else + FStarC_Class_Monad.return + (FStarC_Compiler_Writer.monad_writer + (FStarC_Class_Monoid.monoid_list + ())) () (Obj.repr ()) in + Obj.magic + (FStarC_Class_Monad.op_let_Bang + (FStarC_Compiler_Writer.monad_writer + (FStarC_Class_Monoid.monoid_list ())) + () () uu___6 + (fun uu___7 -> + (fun uu___7 -> + let uu___7 = Obj.magic uu___7 in + Obj.magic + (FStarC_Class_Monad.return + (FStarC_Compiler_Writer.monad_writer + (FStarC_Class_Monoid.monoid_list + ())) () (Obj.repr ()))) + uu___7))) uu___5))) uu___3))) + uu___1) +let (ops : FStarC_TypeChecker_Primops_Base.primitive_step Prims.list) = + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Class_Monad.iterM + (FStarC_Compiler_Writer.monad_writer + (FStarC_Class_Monoid.monoid_list ())) () + (fun uu___3 -> (Obj.magic bounded_arith_ops_for) uu___3) + (Obj.magic FStarC_Compiler_MachineInts.all_machint_kinds) in + FStarC_Class_Monad.op_let_Bang + (FStarC_Compiler_Writer.monad_writer + (FStarC_Class_Monoid.monoid_list ())) () () uu___2 + (fun uu___3 -> + (fun uu___3 -> + let uu___3 = Obj.magic uu___3 in + let uu___4 = + let uu___5 = + FStarC_TypeChecker_Primops_Base.mk1 Prims.int_zero + FStarC_Parser_Const.char_u32_of_char + FStarC_Syntax_Embeddings.e_char + FStarC_TypeChecker_NBETerm.e_char + (FStarC_Compiler_MachineInts.e_machint + FStarC_Compiler_MachineInts.UInt32) + (FStarC_Compiler_MachineInts.nbe_machint + FStarC_Compiler_MachineInts.UInt32) + (fun c -> + let n = + FStarC_BigInt.of_int_fs + (FStarC_Compiler_Util.int_of_char c) in + FStarC_Compiler_MachineInts.mk + FStarC_Compiler_MachineInts.UInt32 n + FStar_Pervasives_Native.None) in + [uu___5] in + Obj.magic + (FStarC_Compiler_Writer.emit + (FStarC_Class_Monoid.monoid_list ()) uu___4)) uu___3) in + Obj.magic + (FStarC_Compiler_Writer.run_writer (FStarC_Class_Monoid.monoid_list ()) + () (Obj.magic uu___1)) in + FStar_Pervasives_Native.fst uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_Range.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_Range.ml new file mode 100644 index 00000000000..0384c162a97 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_Range.ml @@ -0,0 +1,128 @@ +open Prims +type unsealedRange = + | U of FStarC_Compiler_Range_Type.range +let (uu___is_U : unsealedRange -> Prims.bool) = fun projectee -> true +let (__proj__U__item___0 : unsealedRange -> FStarC_Compiler_Range_Type.range) + = fun projectee -> match projectee with | U _0 -> _0 +let (mk_range : + Prims.string -> + FStarC_BigInt.t -> + FStarC_BigInt.t -> + FStarC_BigInt.t -> + FStarC_BigInt.t -> FStarC_Compiler_Range_Type.range) + = + fun fn -> + fun from_l -> + fun from_c -> + fun to_l -> + fun to_c -> + let uu___ = + let uu___1 = FStarC_BigInt.to_int_fs from_l in + let uu___2 = FStarC_BigInt.to_int_fs from_c in + FStarC_Compiler_Range_Type.mk_pos uu___1 uu___2 in + let uu___1 = + let uu___2 = FStarC_BigInt.to_int_fs to_l in + let uu___3 = FStarC_BigInt.to_int_fs to_c in + FStarC_Compiler_Range_Type.mk_pos uu___2 uu___3 in + FStarC_Compiler_Range_Type.mk_range fn uu___ uu___1 +let (__mk_range : + Prims.string -> + FStarC_BigInt.t -> + FStarC_BigInt.t -> FStarC_BigInt.t -> FStarC_BigInt.t -> unsealedRange) + = + fun fn -> + fun from_l -> + fun from_c -> + fun to_l -> + fun to_c -> + let uu___ = mk_range fn from_l from_c to_l to_c in U uu___ +let (explode : + unsealedRange -> + (Prims.string * FStarC_BigInt.t * FStarC_BigInt.t * FStarC_BigInt.t * + FStarC_BigInt.t)) + = + fun r -> + match r with + | U r1 -> + let uu___ = FStarC_Compiler_Range_Ops.file_of_range r1 in + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Compiler_Range_Ops.start_of_range r1 in + FStarC_Compiler_Range_Ops.line_of_pos uu___3 in + FStarC_BigInt.of_int_fs uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Compiler_Range_Ops.start_of_range r1 in + FStarC_Compiler_Range_Ops.col_of_pos uu___4 in + FStarC_BigInt.of_int_fs uu___3 in + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Compiler_Range_Ops.end_of_range r1 in + FStarC_Compiler_Range_Ops.line_of_pos uu___5 in + FStarC_BigInt.of_int_fs uu___4 in + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Compiler_Range_Ops.end_of_range r1 in + FStarC_Compiler_Range_Ops.col_of_pos uu___6 in + FStarC_BigInt.of_int_fs uu___5 in + (uu___, uu___1, uu___2, uu___3, uu___4) +let (e_unsealedRange : unsealedRange FStarC_Syntax_Embeddings_Base.embedding) + = + FStarC_Syntax_Embeddings_Base.embed_as FStarC_Syntax_Embeddings.e___range + (fun r -> U r) (fun uu___ -> match uu___ with | U r -> r) + FStar_Pervasives_Native.None +let (nbe_e_unsealedRange : + unsealedRange FStarC_TypeChecker_NBETerm.embedding) = + FStarC_TypeChecker_NBETerm.embed_as FStarC_TypeChecker_NBETerm.e___range + (fun r -> U r) (fun uu___ -> match uu___ with | U r -> r) + FStar_Pervasives_Native.None +let (ops : FStarC_TypeChecker_Primops_Base.primitive_step Prims.list) = + let uu___ = + FStarC_TypeChecker_Primops_Base.mk5 Prims.int_zero + FStarC_Parser_Const.__mk_range_lid FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int e_unsealedRange nbe_e_unsealedRange + __mk_range in + let uu___1 = + let uu___2 = + FStarC_TypeChecker_Primops_Base.mk5 Prims.int_zero + FStarC_Parser_Const.mk_range_lid FStarC_Syntax_Embeddings.e_string + FStarC_TypeChecker_NBETerm.e_string FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int FStarC_Syntax_Embeddings.e_range + FStarC_TypeChecker_NBETerm.e_range mk_range in + let uu___3 = + let uu___4 = + FStarC_TypeChecker_Primops_Base.mk1 Prims.int_zero + FStarC_Parser_Const.__explode_range_lid e_unsealedRange + nbe_e_unsealedRange + (FStarC_Syntax_Embeddings.e_tuple5 + FStarC_Syntax_Embeddings.e_string FStarC_Syntax_Embeddings.e_int + FStarC_Syntax_Embeddings.e_int FStarC_Syntax_Embeddings.e_int + FStarC_Syntax_Embeddings.e_int) + (FStarC_TypeChecker_NBETerm.e_tuple5 + FStarC_TypeChecker_NBETerm.e_string + FStarC_TypeChecker_NBETerm.e_int + FStarC_TypeChecker_NBETerm.e_int + FStarC_TypeChecker_NBETerm.e_int + FStarC_TypeChecker_NBETerm.e_int) explode in + let uu___5 = + let uu___6 = + FStarC_TypeChecker_Primops_Base.mk2 Prims.int_zero + FStarC_Parser_Const.join_range_lid + FStarC_Syntax_Embeddings.e_range + FStarC_TypeChecker_NBETerm.e_range + FStarC_Syntax_Embeddings.e_range + FStarC_TypeChecker_NBETerm.e_range + FStarC_Syntax_Embeddings.e_range + FStarC_TypeChecker_NBETerm.e_range + FStarC_Compiler_Range_Ops.union_ranges in + [uu___6] in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + uu___ :: uu___1 \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_Real.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_Real.ml new file mode 100644 index 00000000000..9be0918a6f9 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_Real.ml @@ -0,0 +1,200 @@ +open Prims +type tf = + | T + | F +let (uu___is_T : tf -> Prims.bool) = + fun projectee -> match projectee with | T -> true | uu___ -> false +let (uu___is_F : tf -> Prims.bool) = + fun projectee -> match projectee with | F -> true | uu___ -> false +let (e_tf : tf FStarC_Syntax_Embeddings_Base.embedding) = + let ty = FStarC_Syntax_Util.fvar_const FStarC_Parser_Const.prop_lid in + let emb_t_prop = + let uu___ = + let uu___1 = FStarC_Ident.string_of_lid FStarC_Parser_Const.prop_lid in + (uu___1, []) in + FStarC_Syntax_Syntax.ET_app uu___ in + let em p rng _shadow _norm = + match p with + | T -> FStarC_Syntax_Util.t_true + | F -> FStarC_Syntax_Util.t_false in + let un t _norm = + let uu___ = + let uu___1 = FStarC_Syntax_Embeddings_Base.unmeta_div_results t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.true_lid -> + FStar_Pervasives_Native.Some T + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.false_lid -> + FStar_Pervasives_Native.Some F + | uu___1 -> FStar_Pervasives_Native.None in + FStarC_Syntax_Embeddings_Base.mk_emb_full em un (fun uu___ -> ty) + (fun uu___ -> match uu___ with | T -> "T" | F -> "F") + (fun uu___ -> emb_t_prop) +let (nbe_e_tf : tf FStarC_TypeChecker_NBETerm.embedding) = + let lid_as_typ l us args = + let uu___ = FStarC_Syntax_Syntax.lid_as_fv l FStar_Pervasives_Native.None in + FStarC_TypeChecker_NBETerm.mkFV uu___ us args in + let em _cb a = + match a with + | T -> lid_as_typ FStarC_Parser_Const.true_lid [] [] + | F -> lid_as_typ FStarC_Parser_Const.false_lid [] [] in + let un _cb t = + match t.FStarC_TypeChecker_NBETerm.nbe_t with + | FStarC_TypeChecker_NBETerm.FV (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.true_lid -> + FStar_Pervasives_Native.Some T + | FStarC_TypeChecker_NBETerm.FV (fv, [], []) when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.false_lid -> + FStar_Pervasives_Native.Some F + | uu___ -> FStar_Pervasives_Native.None in + FStarC_TypeChecker_NBETerm.mk_emb em un + (fun uu___ -> lid_as_typ FStarC_Parser_Const.bool_lid [] []) + (FStarC_Syntax_Embeddings_Base.emb_typ_of e_tf) +let (cmp : + FStarC_Compiler_Real.real -> + FStarC_Compiler_Real.real -> + FStarC_Compiler_Order.order FStar_Pervasives_Native.option) + = + fun r1 -> + fun r2 -> + match ((FStarC_Compiler_Real.__proj__Real__item___0 r1), + (FStarC_Compiler_Real.__proj__Real__item___0 r2)) + with + | ("0.0", "0.0") -> + FStar_Pervasives_Native.Some FStarC_Compiler_Order.Eq + | ("0.0", "0.5") -> + FStar_Pervasives_Native.Some FStarC_Compiler_Order.Lt + | ("0.0", "1.0") -> + FStar_Pervasives_Native.Some FStarC_Compiler_Order.Lt + | ("0.5", "0.0") -> + FStar_Pervasives_Native.Some FStarC_Compiler_Order.Gt + | ("0.5", "0.5") -> + FStar_Pervasives_Native.Some FStarC_Compiler_Order.Eq + | ("0.5", "1.0") -> + FStar_Pervasives_Native.Some FStarC_Compiler_Order.Lt + | ("1.0", "0.0") -> + FStar_Pervasives_Native.Some FStarC_Compiler_Order.Gt + | ("1.0", "0.5") -> + FStar_Pervasives_Native.Some FStarC_Compiler_Order.Gt + | ("1.0", "1.0") -> + FStar_Pervasives_Native.Some FStarC_Compiler_Order.Eq + | uu___ -> FStar_Pervasives_Native.None +let (lt : + FStarC_Compiler_Real.real -> + FStarC_Compiler_Real.real -> tf FStar_Pervasives_Native.option) + = + fun uu___1 -> + fun uu___ -> + (fun r1 -> + fun r2 -> + let uu___ = cmp r1 r2 in + Obj.magic + (FStarC_Class_Monad.fmap FStarC_Class_Monad.monad_option () () + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + match uu___1 with + | FStarC_Compiler_Order.Lt -> Obj.magic T + | uu___2 -> Obj.magic F) uu___1) (Obj.magic uu___))) + uu___1 uu___ +let (le : + FStarC_Compiler_Real.real -> + FStarC_Compiler_Real.real -> tf FStar_Pervasives_Native.option) + = + fun uu___1 -> + fun uu___ -> + (fun r1 -> + fun r2 -> + let uu___ = cmp r1 r2 in + Obj.magic + (FStarC_Class_Monad.fmap FStarC_Class_Monad.monad_option () () + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + match uu___1 with + | FStarC_Compiler_Order.Lt -> Obj.magic T + | FStarC_Compiler_Order.Eq -> Obj.magic T + | uu___2 -> Obj.magic F) uu___1) (Obj.magic uu___))) + uu___1 uu___ +let (gt : + FStarC_Compiler_Real.real -> + FStarC_Compiler_Real.real -> tf FStar_Pervasives_Native.option) + = + fun uu___1 -> + fun uu___ -> + (fun r1 -> + fun r2 -> + let uu___ = cmp r1 r2 in + Obj.magic + (FStarC_Class_Monad.fmap FStarC_Class_Monad.monad_option () () + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + match uu___1 with + | FStarC_Compiler_Order.Gt -> Obj.magic T + | uu___2 -> Obj.magic F) uu___1) (Obj.magic uu___))) + uu___1 uu___ +let (ge : + FStarC_Compiler_Real.real -> + FStarC_Compiler_Real.real -> tf FStar_Pervasives_Native.option) + = + fun uu___1 -> + fun uu___ -> + (fun r1 -> + fun r2 -> + let uu___ = cmp r1 r2 in + Obj.magic + (FStarC_Class_Monad.fmap FStarC_Class_Monad.monad_option () () + (fun uu___1 -> + (fun uu___1 -> + let uu___1 = Obj.magic uu___1 in + match uu___1 with + | FStarC_Compiler_Order.Gt -> Obj.magic T + | FStarC_Compiler_Order.Eq -> Obj.magic T + | uu___2 -> Obj.magic F) uu___1) (Obj.magic uu___))) + uu___1 uu___ +let (of_int : FStarC_BigInt.t -> FStarC_Compiler_Real.real) = + fun i -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_BigInt.to_int_fs i in Prims.string_of_int uu___2 in + Prims.strcat uu___1 ".0" in + FStarC_Compiler_Real.Real uu___ +let (ops : FStarC_TypeChecker_Primops_Base.primitive_step Prims.list) = + let uu___ = + FStarC_TypeChecker_Primops_Base.mk1 Prims.int_zero + FStarC_Parser_Const.real_of_int FStarC_Syntax_Embeddings.e_int + FStarC_TypeChecker_NBETerm.e_int FStarC_Syntax_Embeddings.e_real + FStarC_TypeChecker_NBETerm.e_real of_int in + [uu___] +let (simplify_ops : + FStarC_TypeChecker_Primops_Base.primitive_step Prims.list) = + let uu___ = + FStarC_TypeChecker_Primops_Base.mk2' Prims.int_zero + FStarC_Parser_Const.real_op_LT FStarC_Syntax_Embeddings.e_real + FStarC_TypeChecker_NBETerm.e_real FStarC_Syntax_Embeddings.e_real + FStarC_TypeChecker_NBETerm.e_real e_tf nbe_e_tf lt lt in + let uu___1 = + let uu___2 = + FStarC_TypeChecker_Primops_Base.mk2' Prims.int_zero + FStarC_Parser_Const.real_op_LTE FStarC_Syntax_Embeddings.e_real + FStarC_TypeChecker_NBETerm.e_real FStarC_Syntax_Embeddings.e_real + FStarC_TypeChecker_NBETerm.e_real e_tf nbe_e_tf le le in + let uu___3 = + let uu___4 = + FStarC_TypeChecker_Primops_Base.mk2' Prims.int_zero + FStarC_Parser_Const.real_op_GT FStarC_Syntax_Embeddings.e_real + FStarC_TypeChecker_NBETerm.e_real FStarC_Syntax_Embeddings.e_real + FStarC_TypeChecker_NBETerm.e_real e_tf nbe_e_tf gt gt in + let uu___5 = + let uu___6 = + FStarC_TypeChecker_Primops_Base.mk2' Prims.int_zero + FStarC_Parser_Const.real_op_GTE FStarC_Syntax_Embeddings.e_real + FStarC_TypeChecker_NBETerm.e_real FStarC_Syntax_Embeddings.e_real + FStarC_TypeChecker_NBETerm.e_real e_tf nbe_e_tf ge ge in + [uu___6] in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + uu___ :: uu___1 \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_Sealed.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_Sealed.ml new file mode 100644 index 00000000000..856520e91fd --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Primops_Sealed.ml @@ -0,0 +1,198 @@ +open Prims +let (bogus_cbs : FStarC_TypeChecker_NBETerm.nbe_cbs) = + { + FStarC_TypeChecker_NBETerm.iapp = (fun h -> fun _args -> h); + FStarC_TypeChecker_NBETerm.translate = + (fun uu___ -> failwith "bogus_cbs translate") + } +let (ops : FStarC_TypeChecker_Primops_Base.primitive_step Prims.list) = + FStarC_Compiler_List.map + (fun p -> + let uu___ = + FStarC_TypeChecker_Primops_Base.as_primitive_step_nbecbs true p in + { + FStarC_TypeChecker_Primops_Base.name = + (uu___.FStarC_TypeChecker_Primops_Base.name); + FStarC_TypeChecker_Primops_Base.arity = + (uu___.FStarC_TypeChecker_Primops_Base.arity); + FStarC_TypeChecker_Primops_Base.univ_arity = + (uu___.FStarC_TypeChecker_Primops_Base.univ_arity); + FStarC_TypeChecker_Primops_Base.auto_reflect = + (uu___.FStarC_TypeChecker_Primops_Base.auto_reflect); + FStarC_TypeChecker_Primops_Base.strong_reduction_ok = + (uu___.FStarC_TypeChecker_Primops_Base.strong_reduction_ok); + FStarC_TypeChecker_Primops_Base.requires_binder_substitution = + (uu___.FStarC_TypeChecker_Primops_Base.requires_binder_substitution); + FStarC_TypeChecker_Primops_Base.renorm_after = true; + FStarC_TypeChecker_Primops_Base.interpretation = + (uu___.FStarC_TypeChecker_Primops_Base.interpretation); + FStarC_TypeChecker_Primops_Base.interpretation_nbe = + (uu___.FStarC_TypeChecker_Primops_Base.interpretation_nbe) + }) + [(FStarC_Parser_Const.map_seal_lid, (Prims.of_int (4)), + (Prims.of_int (2)), + ((fun psc -> + fun univs -> + fun cbs -> + fun args -> + match args with + | (ta, uu___)::(tb, uu___1)::(s, uu___2)::(f, uu___3)::[] -> + let try_unembed e x = + FStarC_Syntax_Embeddings_Base.try_unembed e x + FStarC_Syntax_Embeddings_Base.id_norm_cb in + let uu___4 = + let uu___5 = + try_unembed FStarC_Syntax_Embeddings.e_any ta in + let uu___6 = + try_unembed FStarC_Syntax_Embeddings.e_any tb in + let uu___7 = + try_unembed + (FStarC_Syntax_Embeddings.e_sealed + FStarC_Syntax_Embeddings.e_any) s in + let uu___8 = + try_unembed FStarC_Syntax_Embeddings.e_any f in + (uu___5, uu___6, uu___7, uu___8) in + (match uu___4 with + | (FStar_Pervasives_Native.Some ta1, + FStar_Pervasives_Native.Some tb1, + FStar_Pervasives_Native.Some s1, + FStar_Pervasives_Native.Some f1) -> + let r = + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.as_arg + (FStarC_Compiler_Sealed.unseal s1) in + [uu___6] in + FStarC_Syntax_Util.mk_app f1 uu___5 in + let emb = + FStarC_Syntax_Embeddings_Base.set_type ta1 + FStarC_Syntax_Embeddings.e_any in + let uu___5 = + FStarC_TypeChecker_Primops_Base.embed_simple + (FStarC_Syntax_Embeddings.e_sealed emb) + psc.FStarC_TypeChecker_Primops_Base.psc_range + (FStarC_Compiler_Sealed.seal r) in + FStar_Pervasives_Native.Some uu___5 + | uu___5 -> FStar_Pervasives_Native.None) + | uu___ -> FStar_Pervasives_Native.None)), + ((fun cb -> + fun univs -> + fun args -> + match args with + | (ta, uu___)::(tb, uu___1)::(s, uu___2)::(f, uu___3)::[] -> + let try_unembed e x = + FStarC_TypeChecker_NBETerm.unembed e bogus_cbs x in + let uu___4 = + let uu___5 = + try_unembed FStarC_TypeChecker_NBETerm.e_any ta in + let uu___6 = + try_unembed FStarC_TypeChecker_NBETerm.e_any tb in + let uu___7 = + try_unembed + (FStarC_TypeChecker_NBETerm.e_sealed + FStarC_TypeChecker_NBETerm.e_any) s in + let uu___8 = + try_unembed FStarC_TypeChecker_NBETerm.e_any f in + (uu___5, uu___6, uu___7, uu___8) in + (match uu___4 with + | (FStar_Pervasives_Native.Some ta1, + FStar_Pervasives_Native.Some tb1, + FStar_Pervasives_Native.Some s1, + FStar_Pervasives_Native.Some f1) -> + let r = + let uu___5 = + let uu___6 = + FStarC_TypeChecker_NBETerm.as_arg + (FStarC_Compiler_Sealed.unseal s1) in + [uu___6] in + cb.FStarC_TypeChecker_NBETerm.iapp f1 uu___5 in + let emb = + FStarC_TypeChecker_NBETerm.set_type ta1 + FStarC_TypeChecker_NBETerm.e_any in + let uu___5 = + FStarC_TypeChecker_NBETerm.embed + (FStarC_TypeChecker_NBETerm.e_sealed emb) cb + (FStarC_Compiler_Sealed.seal r) in + FStar_Pervasives_Native.Some uu___5 + | uu___5 -> FStar_Pervasives_Native.None) + | uu___ -> FStar_Pervasives_Native.None))); + (FStarC_Parser_Const.bind_seal_lid, (Prims.of_int (4)), + (Prims.of_int (2)), + ((fun psc -> + fun univs -> + fun cbs -> + fun args -> + match args with + | (ta, uu___)::(tb, uu___1)::(s, uu___2)::(f, uu___3)::[] -> + let try_unembed e x = + FStarC_Syntax_Embeddings_Base.try_unembed e x + FStarC_Syntax_Embeddings_Base.id_norm_cb in + let uu___4 = + let uu___5 = + try_unembed FStarC_Syntax_Embeddings.e_any ta in + let uu___6 = + try_unembed FStarC_Syntax_Embeddings.e_any tb in + let uu___7 = + try_unembed + (FStarC_Syntax_Embeddings.e_sealed + FStarC_Syntax_Embeddings.e_any) s in + let uu___8 = + try_unembed FStarC_Syntax_Embeddings.e_any f in + (uu___5, uu___6, uu___7, uu___8) in + (match uu___4 with + | (FStar_Pervasives_Native.Some ta1, + FStar_Pervasives_Native.Some tb1, + FStar_Pervasives_Native.Some s1, + FStar_Pervasives_Native.Some f1) -> + let r = + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.as_arg + (FStarC_Compiler_Sealed.unseal s1) in + [uu___6] in + FStarC_Syntax_Util.mk_app f1 uu___5 in + let uu___5 = + FStarC_TypeChecker_Primops_Base.embed_simple + FStarC_Syntax_Embeddings.e_any + psc.FStarC_TypeChecker_Primops_Base.psc_range r in + FStar_Pervasives_Native.Some uu___5 + | uu___5 -> FStar_Pervasives_Native.None) + | uu___ -> FStar_Pervasives_Native.None)), + ((fun cb -> + fun univs -> + fun args -> + match args with + | (ta, uu___)::(tb, uu___1)::(s, uu___2)::(f, uu___3)::[] -> + let try_unembed e x = + FStarC_TypeChecker_NBETerm.unembed e bogus_cbs x in + let uu___4 = + let uu___5 = + try_unembed FStarC_TypeChecker_NBETerm.e_any ta in + let uu___6 = + try_unembed FStarC_TypeChecker_NBETerm.e_any tb in + let uu___7 = + try_unembed + (FStarC_TypeChecker_NBETerm.e_sealed + FStarC_TypeChecker_NBETerm.e_any) s in + let uu___8 = + try_unembed FStarC_TypeChecker_NBETerm.e_any f in + (uu___5, uu___6, uu___7, uu___8) in + (match uu___4 with + | (FStar_Pervasives_Native.Some ta1, + FStar_Pervasives_Native.Some tb1, + FStar_Pervasives_Native.Some s1, + FStar_Pervasives_Native.Some f1) -> + let r = + let uu___5 = + let uu___6 = + FStarC_TypeChecker_NBETerm.as_arg + (FStarC_Compiler_Sealed.unseal s1) in + [uu___6] in + cb.FStarC_TypeChecker_NBETerm.iapp f1 uu___5 in + let emb = + FStarC_TypeChecker_NBETerm.set_type ta1 + FStarC_TypeChecker_NBETerm.e_any in + let uu___5 = FStarC_TypeChecker_NBETerm.embed emb cb r in + FStar_Pervasives_Native.Some uu___5 + | uu___5 -> FStar_Pervasives_Native.None) + | uu___ -> FStar_Pervasives_Native.None)))] \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_Quals.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Quals.ml new file mode 100644 index 00000000000..cadc420f79e --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Quals.ml @@ -0,0 +1,731 @@ +open Prims +let (check_sigelt_quals_pre : + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.sigelt -> unit) = + fun env -> + fun se -> + let visibility uu___ = + match uu___ with + | FStarC_Syntax_Syntax.Private -> true + | uu___1 -> false in + let reducibility uu___ = + match uu___ with + | FStarC_Syntax_Syntax.Irreducible -> true + | FStarC_Syntax_Syntax.Unfold_for_unification_and_vcgen -> true + | FStarC_Syntax_Syntax.Visible_default -> true + | FStarC_Syntax_Syntax.Inline_for_extraction -> true + | uu___1 -> false in + let assumption uu___ = + match uu___ with + | FStarC_Syntax_Syntax.Assumption -> true + | FStarC_Syntax_Syntax.New -> true + | uu___1 -> false in + let reification uu___ = + match uu___ with + | FStarC_Syntax_Syntax.Reifiable -> true + | FStarC_Syntax_Syntax.Reflectable uu___1 -> true + | uu___1 -> false in + let inferred uu___ = + match uu___ with + | FStarC_Syntax_Syntax.Discriminator uu___1 -> true + | FStarC_Syntax_Syntax.Projector uu___1 -> true + | FStarC_Syntax_Syntax.RecordType uu___1 -> true + | FStarC_Syntax_Syntax.RecordConstructor uu___1 -> true + | FStarC_Syntax_Syntax.ExceptionConstructor -> true + | FStarC_Syntax_Syntax.HasMaskedEffect -> true + | FStarC_Syntax_Syntax.Effect -> true + | uu___1 -> false in + let has_eq uu___ = + match uu___ with + | FStarC_Syntax_Syntax.Noeq -> true + | FStarC_Syntax_Syntax.Unopteq -> true + | uu___1 -> false in + let quals_combo_ok quals q = + match q with + | FStarC_Syntax_Syntax.Assumption -> + FStarC_Compiler_List.for_all + (fun x -> + ((((((x = q) || (x = FStarC_Syntax_Syntax.Logic)) || + (inferred x)) + || (visibility x)) + || (assumption x)) + || + (env.FStarC_TypeChecker_Env.is_iface && + (x = FStarC_Syntax_Syntax.Inline_for_extraction))) + || (x = FStarC_Syntax_Syntax.NoExtract)) quals + | FStarC_Syntax_Syntax.New -> + FStarC_Compiler_List.for_all + (fun x -> + (((x = q) || (inferred x)) || (visibility x)) || + (assumption x)) quals + | FStarC_Syntax_Syntax.Inline_for_extraction -> + FStarC_Compiler_List.for_all + (fun x -> + ((((((((x = q) || (x = FStarC_Syntax_Syntax.Logic)) || + (visibility x)) + || (reducibility x)) + || (reification x)) + || (inferred x)) + || (has_eq x)) + || + (env.FStarC_TypeChecker_Env.is_iface && + (x = FStarC_Syntax_Syntax.Assumption))) + || (x = FStarC_Syntax_Syntax.NoExtract)) quals + | FStarC_Syntax_Syntax.Unfold_for_unification_and_vcgen -> + FStarC_Compiler_List.for_all + (fun x -> + (((((((x = q) || (x = FStarC_Syntax_Syntax.Logic)) || + (x = FStarC_Syntax_Syntax.Inline_for_extraction)) + || (x = FStarC_Syntax_Syntax.NoExtract)) + || (has_eq x)) + || (inferred x)) + || (visibility x)) + || (reification x)) quals + | FStarC_Syntax_Syntax.Visible_default -> + FStarC_Compiler_List.for_all + (fun x -> + (((((((x = q) || (x = FStarC_Syntax_Syntax.Logic)) || + (x = FStarC_Syntax_Syntax.Inline_for_extraction)) + || (x = FStarC_Syntax_Syntax.NoExtract)) + || (has_eq x)) + || (inferred x)) + || (visibility x)) + || (reification x)) quals + | FStarC_Syntax_Syntax.Irreducible -> + FStarC_Compiler_List.for_all + (fun x -> + (((((((x = q) || (x = FStarC_Syntax_Syntax.Logic)) || + (x = FStarC_Syntax_Syntax.Inline_for_extraction)) + || (x = FStarC_Syntax_Syntax.NoExtract)) + || (has_eq x)) + || (inferred x)) + || (visibility x)) + || (reification x)) quals + | FStarC_Syntax_Syntax.Noeq -> + FStarC_Compiler_List.for_all + (fun x -> + (((((((x = q) || (x = FStarC_Syntax_Syntax.Logic)) || + (x = FStarC_Syntax_Syntax.Inline_for_extraction)) + || (x = FStarC_Syntax_Syntax.NoExtract)) + || (has_eq x)) + || (inferred x)) + || (visibility x)) + || (reification x)) quals + | FStarC_Syntax_Syntax.Unopteq -> + FStarC_Compiler_List.for_all + (fun x -> + (((((((x = q) || (x = FStarC_Syntax_Syntax.Logic)) || + (x = FStarC_Syntax_Syntax.Inline_for_extraction)) + || (x = FStarC_Syntax_Syntax.NoExtract)) + || (has_eq x)) + || (inferred x)) + || (visibility x)) + || (reification x)) quals + | FStarC_Syntax_Syntax.TotalEffect -> + FStarC_Compiler_List.for_all + (fun x -> + (((x = q) || (inferred x)) || (visibility x)) || + (reification x)) quals + | FStarC_Syntax_Syntax.Logic -> + FStarC_Compiler_List.for_all + (fun x -> + ((((x = q) || (x = FStarC_Syntax_Syntax.Assumption)) || + (inferred x)) + || (visibility x)) + || (reducibility x)) quals + | FStarC_Syntax_Syntax.Reifiable -> + FStarC_Compiler_List.for_all + (fun x -> + ((((reification x) || (inferred x)) || (visibility x)) || + (x = FStarC_Syntax_Syntax.TotalEffect)) + || (x = FStarC_Syntax_Syntax.Visible_default)) quals + | FStarC_Syntax_Syntax.Reflectable uu___ -> + FStarC_Compiler_List.for_all + (fun x -> + ((((reification x) || (inferred x)) || (visibility x)) || + (x = FStarC_Syntax_Syntax.TotalEffect)) + || (x = FStarC_Syntax_Syntax.Visible_default)) quals + | FStarC_Syntax_Syntax.Private -> true + | uu___ -> true in + let check_no_subtyping_attribute se1 = + let uu___ = + (FStarC_Syntax_Util.has_attribute se1.FStarC_Syntax_Syntax.sigattrs + FStarC_Parser_Const.no_subtping_attr_lid) + && + (match se1.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_let uu___1 -> false + | uu___1 -> true) in + if uu___ + then + let uu___1 = + let uu___2 = + FStarC_Errors_Msg.text + "Illegal attribute: the `no_subtyping` attribute is allowed only on let-bindings." in + [uu___2] in + FStarC_Errors.raise_error FStarC_Syntax_Syntax.has_range_sigelt se1 + FStarC_Errors_Codes.Fatal_InconsistentQualifierAnnotation () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___1) + else () in + check_no_subtyping_attribute se; + (let quals = + FStarC_Compiler_List.filter + (fun x -> Prims.op_Negation (x = FStarC_Syntax_Syntax.Logic)) + (FStarC_Syntax_Util.quals_of_sigelt se) in + let uu___1 = + let uu___2 = + FStarC_Compiler_Util.for_some + (fun uu___3 -> + match uu___3 with + | FStarC_Syntax_Syntax.OnlyName -> true + | uu___4 -> false) quals in + Prims.op_Negation uu___2 in + if uu___1 + then + let r = FStarC_Syntax_Util.range_of_sigelt se in + let no_dup_quals = + FStarC_Compiler_Util.remove_dups (fun x -> fun y -> x = y) quals in + let err msg = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Errors_Msg.text "The qualifier list" in + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_qualifier) quals in + FStarC_Pprint.doc_of_string uu___8 in + let uu___8 = + FStarC_Errors_Msg.text + "is not permissible for this element" in + FStarC_Pprint.op_Hat_Slash_Hat uu___7 uu___8 in + FStarC_Pprint.op_Hat_Slash_Hat uu___5 uu___6 in + [uu___4] in + FStar_List_Tot_Base.append uu___3 msg in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_QulifierListNotPermitted () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___2) in + (if + (FStarC_Compiler_List.length quals) <> + (FStarC_Compiler_List.length no_dup_quals) + then + (let uu___3 = + let uu___4 = FStarC_Errors_Msg.text "Duplicate qualifiers." in + [uu___4] in + err uu___3) + else (); + (let uu___4 = + let uu___5 = + FStarC_Compiler_List.for_all (quals_combo_ok quals) quals in + Prims.op_Negation uu___5 in + if uu___4 + then + let uu___5 = + let uu___6 = FStarC_Errors_Msg.text "Ill-formed combination." in + [uu___6] in + err uu___5 + else ()); + (match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (is_rec, uu___4); + FStarC_Syntax_Syntax.lids1 = uu___5;_} + -> + (if + is_rec && + (FStarC_Compiler_List.contains + FStarC_Syntax_Syntax.Unfold_for_unification_and_vcgen + quals) + then + (let uu___7 = + let uu___8 = + FStarC_Errors_Msg.text + "Recursive definitions cannot be marked inline." in + [uu___8] in + err uu___7) + else (); + (let uu___7 = + FStarC_Compiler_Util.for_some + (fun x -> (assumption x) || (has_eq x)) quals in + if uu___7 + then + let uu___8 = + let uu___9 = + FStarC_Errors_Msg.text + "Definitions cannot be assumed or marked with equality qualifiers." in + [uu___9] in + err uu___8 + else ())) + | FStarC_Syntax_Syntax.Sig_bundle uu___4 -> + ((let uu___6 = + let uu___7 = + FStarC_Compiler_Util.for_all + (fun x -> + ((((x = FStarC_Syntax_Syntax.Inline_for_extraction) + || (x = FStarC_Syntax_Syntax.NoExtract)) + || (inferred x)) + || (visibility x)) + || (has_eq x)) quals in + Prims.op_Negation uu___7 in + if uu___6 then err [] else ()); + (let uu___6 = + (FStarC_Compiler_List.existsb + (fun uu___7 -> + match uu___7 with + | FStarC_Syntax_Syntax.Unopteq -> true + | uu___8 -> false) quals) + && + (FStarC_Syntax_Util.has_attribute + se.FStarC_Syntax_Syntax.sigattrs + FStarC_Parser_Const.erasable_attr) in + if uu___6 + then + let uu___7 = + let uu___8 = + FStarC_Errors_Msg.text + "The `unopteq` qualifier is not allowed on erasable inductives since they don't have decidable equality." in + [uu___8] in + err uu___7 + else ())) + | FStarC_Syntax_Syntax.Sig_declare_typ uu___4 -> + let uu___5 = FStarC_Compiler_Util.for_some has_eq quals in + if uu___5 then err [] else () + | FStarC_Syntax_Syntax.Sig_assume uu___4 -> + let uu___5 = + let uu___6 = + FStarC_Compiler_Util.for_all + (fun x -> + ((visibility x) || + (x = FStarC_Syntax_Syntax.Assumption)) + || (x = FStarC_Syntax_Syntax.InternalAssumption)) + quals in + Prims.op_Negation uu___6 in + if uu___5 then err [] else () + | FStarC_Syntax_Syntax.Sig_new_effect uu___4 -> + let uu___5 = + let uu___6 = + FStarC_Compiler_Util.for_all + (fun x -> + (((x = FStarC_Syntax_Syntax.TotalEffect) || + (inferred x)) + || (visibility x)) + || (reification x)) quals in + Prims.op_Negation uu___6 in + if uu___5 then err [] else () + | FStarC_Syntax_Syntax.Sig_effect_abbrev uu___4 -> + let uu___5 = + let uu___6 = + FStarC_Compiler_Util.for_all + (fun x -> (inferred x) || (visibility x)) quals in + Prims.op_Negation uu___6 in + if uu___5 then err [] else () + | uu___4 -> ())) + else ()) +let (check_erasable : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.qualifier Prims.list -> + FStarC_Compiler_Range_Type.range -> FStarC_Syntax_Syntax.sigelt -> unit) + = + fun env -> + fun quals -> + fun r -> + fun se -> + let lids = FStarC_Syntax_Util.lids_of_sigelt se in + let val_exists = + FStarC_Compiler_Util.for_some + (fun l -> + let uu___ = FStarC_TypeChecker_Env.try_lookup_val_decl env l in + FStarC_Compiler_Option.isSome uu___) lids in + let val_has_erasable_attr = + FStarC_Compiler_Util.for_some + (fun l -> + let attrs_opt = + FStarC_TypeChecker_Env.lookup_attrs_of_lid env l in + (FStarC_Compiler_Option.isSome attrs_opt) && + (let uu___ = FStarC_Compiler_Option.get attrs_opt in + FStarC_Syntax_Util.has_attribute uu___ + FStarC_Parser_Const.erasable_attr)) lids in + let se_has_erasable_attr = + FStarC_Syntax_Util.has_attribute se.FStarC_Syntax_Syntax.sigattrs + FStarC_Parser_Const.erasable_attr in + if + (val_exists && val_has_erasable_attr) && + (Prims.op_Negation se_has_erasable_attr) + then + (let uu___1 = + let uu___2 = + FStarC_Errors_Msg.text + "Mismatch of attributes between declaration and definition." in + let uu___3 = + let uu___4 = + FStarC_Errors_Msg.text + "Declaration is marked `erasable` but the definition is not." in + [uu___4] in + uu___2 :: uu___3 in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_QulifierListNotPermitted () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___1)) + else (); + if + (val_exists && (Prims.op_Negation val_has_erasable_attr)) && + se_has_erasable_attr + then + (let uu___2 = + let uu___3 = + FStarC_Errors_Msg.text + "Mismatch of attributes between declaration and definition." in + let uu___4 = + let uu___5 = + FStarC_Errors_Msg.text + "Definition is marked `erasable` but the declaration is not." in + [uu___5] in + uu___3 :: uu___4 in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_QulifierListNotPermitted () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___2)) + else (); + if se_has_erasable_attr + then + (match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_bundle uu___2 -> + let uu___3 = + let uu___4 = + FStarC_Compiler_Util.for_some + (fun uu___5 -> + match uu___5 with + | FStarC_Syntax_Syntax.Noeq -> true + | uu___6 -> false) quals in + Prims.op_Negation uu___4 in + if uu___3 + then + let uu___4 = + let uu___5 = + FStarC_Errors_Msg.text + "Incompatible attributes and qualifiers: erasable types do not support decidable equality and must be marked `noeq`." in + [uu___5] in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_QulifierListNotPermitted () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___4) + else () + | FStarC_Syntax_Syntax.Sig_declare_typ uu___2 -> () + | FStarC_Syntax_Syntax.Sig_fail uu___2 -> () + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (false, lb::[]); + FStarC_Syntax_Syntax.lids1 = uu___2;_} + -> + let uu___3 = + FStarC_Syntax_Util.abs_formals + lb.FStarC_Syntax_Syntax.lbdef in + (match uu___3 with + | (uu___4, body, uu___5) -> + let uu___6 = + let uu___7 = + FStarC_TypeChecker_Normalize.non_info_norm env body in + Prims.op_Negation uu___7 in + if uu___6 + then + let uu___7 = + let uu___8 = + FStarC_Errors_Msg.text + "Illegal attribute: the `erasable` attribute is only permitted on inductive type definitions and abbreviations for non-informative types." in + let uu___9 = + let uu___10 = + let uu___11 = FStarC_Errors_Msg.text "The term" in + let uu___12 = + let uu___13 = + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_term body in + let uu___14 = + FStarC_Errors_Msg.text + "is considered informative." in + FStarC_Pprint.op_Hat_Slash_Hat uu___13 + uu___14 in + FStarC_Pprint.op_Hat_Slash_Hat uu___11 uu___12 in + [uu___10] in + uu___8 :: uu___9 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) body + FStarC_Errors_Codes.Fatal_QulifierListNotPermitted + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___7) + else ()) + | FStarC_Syntax_Syntax.Sig_new_effect + { FStarC_Syntax_Syntax.mname = eff_name; + FStarC_Syntax_Syntax.cattributes = uu___2; + FStarC_Syntax_Syntax.univs = uu___3; + FStarC_Syntax_Syntax.binders = uu___4; + FStarC_Syntax_Syntax.signature = uu___5; + FStarC_Syntax_Syntax.combinators = uu___6; + FStarC_Syntax_Syntax.actions = uu___7; + FStarC_Syntax_Syntax.eff_attrs = uu___8; + FStarC_Syntax_Syntax.extraction_mode = uu___9;_} + -> + if + Prims.op_Negation + (FStarC_Compiler_List.contains + FStarC_Syntax_Syntax.TotalEffect quals) + then + let uu___10 = + let uu___11 = + let uu___12 = FStarC_Errors_Msg.text "Effect" in + let uu___13 = + let uu___14 = + FStarC_Class_PP.pp FStarC_Ident.pretty_lident + eff_name in + let uu___15 = + FStarC_Errors_Msg.text + "is marked erasable but only total effects are allowed to be erasable." in + FStarC_Pprint.op_Hat_Slash_Hat uu___14 uu___15 in + FStarC_Pprint.op_Hat_Slash_Hat uu___12 uu___13 in + [uu___11] in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_QulifierListNotPermitted () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___10) + else () + | uu___2 -> + let uu___3 = + let uu___4 = + FStarC_Errors_Msg.text + "Illegal attribute: the `erasable` attribute is only permitted on inductive type definitions and abbreviations for non-informative types." in + [uu___4] in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_QulifierListNotPermitted () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___3)) + else () +let (check_must_erase_attribute : + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.sigelt -> unit) = + fun env -> + fun se -> + let uu___ = FStarC_Options.ide () in + if uu___ + then () + else + (match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = lbs; + FStarC_Syntax_Syntax.lids1 = l;_} + -> + let uu___2 = + let uu___3 = FStarC_TypeChecker_Env.dsenv env in + let uu___4 = FStarC_TypeChecker_Env.current_module env in + FStarC_Syntax_DsEnv.iface_decls uu___3 uu___4 in + (match uu___2 with + | FStar_Pervasives_Native.None -> () + | FStar_Pervasives_Native.Some iface_decls -> + FStarC_Compiler_List.iter + (fun lb -> + let lbname = + FStarC_Compiler_Util.right + lb.FStarC_Syntax_Syntax.lbname in + let has_iface_val = + let uu___3 = + let uu___4 = + FStarC_Ident.ident_of_lid + (lbname.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + FStarC_Parser_AST.decl_is_val uu___4 in + FStarC_Compiler_Util.for_some uu___3 iface_decls in + if has_iface_val + then + let must_erase = + FStarC_TypeChecker_Util.must_erase_for_extraction + env lb.FStarC_Syntax_Syntax.lbdef in + let has_attr = + FStarC_TypeChecker_Env.fv_has_attr env lbname + FStarC_Parser_Const.must_erase_for_extraction_attr in + (if must_erase && (Prims.op_Negation has_attr) + then + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_fv lbname in + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_fv lbname in + FStarC_Compiler_Util.format2 + "Values of type `%s` will be erased during extraction, but its interface hides this fact. Add the `must_erase_for_extraction` attribute to the `val %s` declaration for this symbol in the interface" + uu___6 uu___7 in + FStarC_Errors_Msg.text uu___5 in + [uu___4] in + FStarC_Errors.log_issue + FStarC_Syntax_Syntax.hasRange_fv lbname + FStarC_Errors_Codes.Error_MustEraseMissing () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___3) + else + if has_attr && (Prims.op_Negation must_erase) + then + (let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_fv + lbname in + FStarC_Compiler_Util.format1 + "Values of type `%s` cannot be erased during extraction, but the `must_erase_for_extraction` attribute claims that it can. Please remove the attribute." + uu___7 in + FStarC_Errors_Msg.text uu___6 in + [uu___5] in + FStarC_Errors.log_issue + FStarC_Syntax_Syntax.hasRange_fv lbname + FStarC_Errors_Codes.Error_MustEraseMissing + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___4)) + else ()) + else ()) (FStar_Pervasives_Native.snd lbs)) + | uu___2 -> ()) +let (check_typeclass_instance_attribute : + FStarC_TypeChecker_Env.env -> + FStarC_Compiler_Range_Type.range -> FStarC_Syntax_Syntax.sigelt -> unit) + = + fun env -> + fun rng -> + fun se -> + let is_tc_instance = + FStarC_Compiler_Util.for_some + (fun t -> + match t.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.tcinstance_lid + | uu___ -> false) se.FStarC_Syntax_Syntax.sigattrs in + let check_instance_typ ty = + let uu___ = FStarC_Syntax_Util.arrow_formals_comp ty in + match uu___ with + | (uu___1, res) -> + ((let uu___3 = + let uu___4 = FStarC_Syntax_Util.is_total_comp res in + Prims.op_Negation uu___4 in + if uu___3 + then + let uu___4 = + let uu___5 = + FStarC_Errors_Msg.text + "Instances are expected to be total." in + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Errors_Msg.text "This instance has effect" in + let uu___9 = + FStarC_Class_PP.pp FStarC_Ident.pretty_lident + (FStarC_Syntax_Util.comp_effect_name res) in + FStarC_Pprint.op_Hat_Hat uu___8 uu___9 in + [uu___7] in + uu___5 :: uu___6 in + FStarC_Errors.log_issue + FStarC_Class_HasRange.hasRange_range rng + FStarC_Errors_Codes.Error_UnexpectedTypeclassInstance () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___4) + else ()); + (let t = FStarC_Syntax_Util.comp_result res in + let uu___3 = FStarC_Syntax_Util.head_and_args t in + match uu___3 with + | (head, uu___4) -> + let err uu___5 = + let uu___6 = + let uu___7 = + FStarC_Errors_Msg.text + "Instances must define instances of `class` types." in + let uu___8 = + let uu___9 = + let uu___10 = FStarC_Errors_Msg.text "Type" in + let uu___11 = + let uu___12 = + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_term t in + let uu___13 = + FStarC_Errors_Msg.text "is not a class." in + FStarC_Pprint.op_Hat_Slash_Hat uu___12 uu___13 in + FStarC_Pprint.op_Hat_Slash_Hat uu___10 uu___11 in + [uu___9] in + uu___7 :: uu___8 in + FStarC_Errors.log_issue + FStarC_Class_HasRange.hasRange_range rng + FStarC_Errors_Codes.Error_UnexpectedTypeclassInstance + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___6) in + let uu___5 = + let uu___6 = FStarC_Syntax_Util.un_uinst head in + uu___6.FStarC_Syntax_Syntax.n in + (match uu___5 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let uu___6 = + let uu___7 = + FStarC_TypeChecker_Env.fv_has_attr env fv + FStarC_Parser_Const.tcclass_lid in + Prims.op_Negation uu___7 in + if uu___6 then err () else () + | uu___6 -> err ()))) in + if is_tc_instance + then + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (false, lb::[]); + FStarC_Syntax_Syntax.lids1 = uu___;_} + -> check_instance_typ lb.FStarC_Syntax_Syntax.lbtyp + | FStarC_Syntax_Syntax.Sig_let uu___ -> + let uu___1 = + let uu___2 = + FStarC_Errors_Msg.text + "An `instance` definition is expected to be non-recursive and of a type that is a `class`." in + [uu___2] in + FStarC_Errors.log_issue FStarC_Class_HasRange.hasRange_range + rng FStarC_Errors_Codes.Error_UnexpectedTypeclassInstance () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___1) + | FStarC_Syntax_Syntax.Sig_declare_typ + { FStarC_Syntax_Syntax.lid2 = uu___; + FStarC_Syntax_Syntax.us2 = uu___1; + FStarC_Syntax_Syntax.t2 = t;_} + -> check_instance_typ t + | uu___ -> + let uu___1 = + let uu___2 = + FStarC_Errors_Msg.text + "The `instance` attribute is only allowed on `let` and `val` declarations." in + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Errors_Msg.text "It is not allowed for" in + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Print.sigelt_to_string_short se in + FStarC_Pprint.arbitrary_string uu___8 in + FStarC_Pprint.squotes uu___7 in + FStarC_Pprint.op_Hat_Slash_Hat uu___5 uu___6 in + [uu___4] in + uu___2 :: uu___3 in + FStarC_Errors.log_issue FStarC_Class_HasRange.hasRange_range + rng FStarC_Errors_Codes.Error_UnexpectedTypeclassInstance () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___1) + else () +let (check_sigelt_quals_post : + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.sigelt -> unit) = + fun env -> + fun se -> + let quals = se.FStarC_Syntax_Syntax.sigquals in + let r = se.FStarC_Syntax_Syntax.sigrng in + check_erasable env quals r se; + check_must_erase_attribute env se; + check_typeclass_instance_attribute env r se \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_Rel.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Rel.ml new file mode 100644 index 00000000000..ad02ba4cab7 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Rel.ml @@ -0,0 +1,17234 @@ +open Prims +type match_result = + | MisMatch of (FStarC_Syntax_Syntax.delta_depth + FStar_Pervasives_Native.option * FStarC_Syntax_Syntax.delta_depth + FStar_Pervasives_Native.option) + | HeadMatch of Prims.bool + | FullMatch +let (uu___is_MisMatch : match_result -> Prims.bool) = + fun projectee -> + match projectee with | MisMatch _0 -> true | uu___ -> false +let (__proj__MisMatch__item___0 : + match_result -> + (FStarC_Syntax_Syntax.delta_depth FStar_Pervasives_Native.option * + FStarC_Syntax_Syntax.delta_depth FStar_Pervasives_Native.option)) + = fun projectee -> match projectee with | MisMatch _0 -> _0 +let (uu___is_HeadMatch : match_result -> Prims.bool) = + fun projectee -> + match projectee with | HeadMatch _0 -> true | uu___ -> false +let (__proj__HeadMatch__item___0 : match_result -> Prims.bool) = + fun projectee -> match projectee with | HeadMatch _0 -> _0 +let (uu___is_FullMatch : match_result -> Prims.bool) = + fun projectee -> match projectee with | FullMatch -> true | uu___ -> false +type implicit_checking_status = + | Implicit_unresolved + | Implicit_checking_defers_univ_constraint + | Implicit_has_typing_guard of (FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.typ) +let (uu___is_Implicit_unresolved : implicit_checking_status -> Prims.bool) = + fun projectee -> + match projectee with | Implicit_unresolved -> true | uu___ -> false +let (uu___is_Implicit_checking_defers_univ_constraint : + implicit_checking_status -> Prims.bool) = + fun projectee -> + match projectee with + | Implicit_checking_defers_univ_constraint -> true + | uu___ -> false +let (uu___is_Implicit_has_typing_guard : + implicit_checking_status -> Prims.bool) = + fun projectee -> + match projectee with + | Implicit_has_typing_guard _0 -> true + | uu___ -> false +let (__proj__Implicit_has_typing_guard__item___0 : + implicit_checking_status -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.typ)) + = + fun projectee -> match projectee with | Implicit_has_typing_guard _0 -> _0 +let (dbg_Disch : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Disch" +let (dbg_Discharge : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Discharge" +let (dbg_EQ : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "EQ" +let (dbg_ExplainRel : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "ExplainRel" +let (dbg_GenUniverses : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "GenUniverses" +let (dbg_ImplicitTrace : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "ImplicitTrace" +let (dbg_Imps : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Imps" +let (dbg_LayeredEffectsApp : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "LayeredEffectsApp" +let (dbg_LayeredEffectsEqns : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "LayeredEffectsEqns" +let (dbg_Rel : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Rel" +let (dbg_RelBench : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "RelBench" +let (dbg_RelDelta : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "RelDelta" +let (dbg_RelTop : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "RelTop" +let (dbg_ResolveImplicitsHook : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "ResolveImplicitsHook" +let (dbg_Simplification : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Simplification" +let (dbg_SMTQuery : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "SMTQuery" +let (dbg_Tac : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Tac" +let (showable_implicit_checking_status : + implicit_checking_status FStarC_Class_Show.showable) = + { + FStarC_Class_Show.show = + (fun uu___ -> + match uu___ with + | Implicit_unresolved -> "Implicit_unresolved" + | Implicit_checking_defers_univ_constraint -> + "Implicit_checking_defers_univ_constraint" + | Implicit_has_typing_guard (tm, typ) -> "Implicit_has_typing_guard") + } +type tagged_implicits = + (FStarC_TypeChecker_Common.implicit * implicit_checking_status) Prims.list +let (is_base_type : + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.typ -> Prims.bool) = + fun env -> + fun typ -> + let t = FStarC_TypeChecker_Normalize.unfold_whnf env typ in + let uu___ = FStarC_Syntax_Util.head_and_args t in + match uu___ with + | (head, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst head in + FStarC_Syntax_Util.unascribe uu___3 in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_name uu___2 -> true + | FStarC_Syntax_Syntax.Tm_fvar uu___2 -> true + | FStarC_Syntax_Syntax.Tm_type uu___2 -> true + | uu___2 -> false) +let (term_is_uvar : + FStarC_Syntax_Syntax.ctx_uvar -> FStarC_Syntax_Syntax.term -> Prims.bool) = + fun uv -> + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Util.unascribe t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_uvar (uv', uu___1) -> + FStarC_Syntax_Unionfind.equiv uv.FStarC_Syntax_Syntax.ctx_uvar_head + uv'.FStarC_Syntax_Syntax.ctx_uvar_head + | uu___1 -> false +let (binders_as_bv_set : + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.bv FStarC_Compiler_FlatSet.t) + = + fun uu___ -> + (fun bs -> + let uu___ = + FStarC_Compiler_List.map (fun b -> b.FStarC_Syntax_Syntax.binder_bv) + bs in + Obj.magic + (FStarC_Class_Setlike.from_list () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) uu___)) uu___ +type lstring = Prims.string FStarC_Thunk.t +let (mklstr : (unit -> Prims.string) -> Prims.string FStarC_Thunk.thunk) = + fun f -> + let uf = FStarC_Syntax_Unionfind.get () in + FStarC_Thunk.mk + (fun uu___ -> + let tx = FStarC_Syntax_Unionfind.new_transaction () in + FStarC_Syntax_Unionfind.set uf; + (let r = f () in FStarC_Syntax_Unionfind.rollback tx; r)) +type uvi = + | TERM of (FStarC_Syntax_Syntax.ctx_uvar * FStarC_Syntax_Syntax.term) + | UNIV of (FStarC_Syntax_Syntax.universe_uvar * + FStarC_Syntax_Syntax.universe) +let (uu___is_TERM : uvi -> Prims.bool) = + fun projectee -> match projectee with | TERM _0 -> true | uu___ -> false +let (__proj__TERM__item___0 : + uvi -> (FStarC_Syntax_Syntax.ctx_uvar * FStarC_Syntax_Syntax.term)) = + fun projectee -> match projectee with | TERM _0 -> _0 +let (uu___is_UNIV : uvi -> Prims.bool) = + fun projectee -> match projectee with | UNIV _0 -> true | uu___ -> false +let (__proj__UNIV__item___0 : + uvi -> (FStarC_Syntax_Syntax.universe_uvar * FStarC_Syntax_Syntax.universe)) + = fun projectee -> match projectee with | UNIV _0 -> _0 +type defer_ok_t = + | NoDefer + | DeferAny + | DeferFlexFlexOnly +let (uu___is_NoDefer : defer_ok_t -> Prims.bool) = + fun projectee -> match projectee with | NoDefer -> true | uu___ -> false +let (uu___is_DeferAny : defer_ok_t -> Prims.bool) = + fun projectee -> match projectee with | DeferAny -> true | uu___ -> false +let (uu___is_DeferFlexFlexOnly : defer_ok_t -> Prims.bool) = + fun projectee -> + match projectee with | DeferFlexFlexOnly -> true | uu___ -> false +let (uu___0 : defer_ok_t FStarC_Class_Show.showable) = + { + FStarC_Class_Show.show = + (fun uu___ -> + match uu___ with + | NoDefer -> "NoDefer" + | DeferAny -> "DeferAny" + | DeferFlexFlexOnly -> "DeferFlexFlexOnly") + } +type worklist = + { + attempting: FStarC_TypeChecker_Common.probs ; + wl_deferred: + (Prims.int * FStarC_TypeChecker_Common.deferred_reason * lstring * + FStarC_TypeChecker_Common.prob) FStarC_Compiler_CList.clist + ; + wl_deferred_to_tac: + (Prims.int * FStarC_TypeChecker_Common.deferred_reason * lstring * + FStarC_TypeChecker_Common.prob) FStarC_Compiler_CList.clist + ; + ctr: Prims.int ; + defer_ok: defer_ok_t ; + smt_ok: Prims.bool ; + umax_heuristic_ok: Prims.bool ; + tcenv: FStarC_TypeChecker_Env.env ; + wl_implicits: FStarC_TypeChecker_Common.implicits_t ; + repr_subcomp_allowed: Prims.bool ; + typeclass_variables: FStarC_Syntax_Syntax.ctx_uvar FStarC_Compiler_RBSet.t } +let (__proj__Mkworklist__item__attempting : + worklist -> FStarC_TypeChecker_Common.probs) = + fun projectee -> + match projectee with + | { attempting; wl_deferred; wl_deferred_to_tac; ctr; defer_ok; smt_ok; + umax_heuristic_ok; tcenv; wl_implicits; repr_subcomp_allowed; + typeclass_variables;_} -> attempting +let (__proj__Mkworklist__item__wl_deferred : + worklist -> + (Prims.int * FStarC_TypeChecker_Common.deferred_reason * lstring * + FStarC_TypeChecker_Common.prob) FStarC_Compiler_CList.clist) + = + fun projectee -> + match projectee with + | { attempting; wl_deferred; wl_deferred_to_tac; ctr; defer_ok; smt_ok; + umax_heuristic_ok; tcenv; wl_implicits; repr_subcomp_allowed; + typeclass_variables;_} -> wl_deferred +let (__proj__Mkworklist__item__wl_deferred_to_tac : + worklist -> + (Prims.int * FStarC_TypeChecker_Common.deferred_reason * lstring * + FStarC_TypeChecker_Common.prob) FStarC_Compiler_CList.clist) + = + fun projectee -> + match projectee with + | { attempting; wl_deferred; wl_deferred_to_tac; ctr; defer_ok; smt_ok; + umax_heuristic_ok; tcenv; wl_implicits; repr_subcomp_allowed; + typeclass_variables;_} -> wl_deferred_to_tac +let (__proj__Mkworklist__item__ctr : worklist -> Prims.int) = + fun projectee -> + match projectee with + | { attempting; wl_deferred; wl_deferred_to_tac; ctr; defer_ok; smt_ok; + umax_heuristic_ok; tcenv; wl_implicits; repr_subcomp_allowed; + typeclass_variables;_} -> ctr +let (__proj__Mkworklist__item__defer_ok : worklist -> defer_ok_t) = + fun projectee -> + match projectee with + | { attempting; wl_deferred; wl_deferred_to_tac; ctr; defer_ok; smt_ok; + umax_heuristic_ok; tcenv; wl_implicits; repr_subcomp_allowed; + typeclass_variables;_} -> defer_ok +let (__proj__Mkworklist__item__smt_ok : worklist -> Prims.bool) = + fun projectee -> + match projectee with + | { attempting; wl_deferred; wl_deferred_to_tac; ctr; defer_ok; smt_ok; + umax_heuristic_ok; tcenv; wl_implicits; repr_subcomp_allowed; + typeclass_variables;_} -> smt_ok +let (__proj__Mkworklist__item__umax_heuristic_ok : worklist -> Prims.bool) = + fun projectee -> + match projectee with + | { attempting; wl_deferred; wl_deferred_to_tac; ctr; defer_ok; smt_ok; + umax_heuristic_ok; tcenv; wl_implicits; repr_subcomp_allowed; + typeclass_variables;_} -> umax_heuristic_ok +let (__proj__Mkworklist__item__tcenv : + worklist -> FStarC_TypeChecker_Env.env) = + fun projectee -> + match projectee with + | { attempting; wl_deferred; wl_deferred_to_tac; ctr; defer_ok; smt_ok; + umax_heuristic_ok; tcenv; wl_implicits; repr_subcomp_allowed; + typeclass_variables;_} -> tcenv +let (__proj__Mkworklist__item__wl_implicits : + worklist -> FStarC_TypeChecker_Common.implicits_t) = + fun projectee -> + match projectee with + | { attempting; wl_deferred; wl_deferred_to_tac; ctr; defer_ok; smt_ok; + umax_heuristic_ok; tcenv; wl_implicits; repr_subcomp_allowed; + typeclass_variables;_} -> wl_implicits +let (__proj__Mkworklist__item__repr_subcomp_allowed : worklist -> Prims.bool) + = + fun projectee -> + match projectee with + | { attempting; wl_deferred; wl_deferred_to_tac; ctr; defer_ok; smt_ok; + umax_heuristic_ok; tcenv; wl_implicits; repr_subcomp_allowed; + typeclass_variables;_} -> repr_subcomp_allowed +let (__proj__Mkworklist__item__typeclass_variables : + worklist -> FStarC_Syntax_Syntax.ctx_uvar FStarC_Compiler_RBSet.t) = + fun projectee -> + match projectee with + | { attempting; wl_deferred; wl_deferred_to_tac; ctr; defer_ok; smt_ok; + umax_heuristic_ok; tcenv; wl_implicits; repr_subcomp_allowed; + typeclass_variables;_} -> typeclass_variables +let (as_deferred : + (Prims.int * FStarC_TypeChecker_Common.deferred_reason * lstring * + FStarC_TypeChecker_Common.prob) FStarC_Compiler_CList.clist -> + FStarC_TypeChecker_Common.deferred) + = + fun wl_def -> + FStarC_Compiler_CList.map + (fun uu___ -> + match uu___ with + | (uu___1, reason, m, p) -> + let uu___2 = FStarC_Thunk.force m in (reason, uu___2, p)) wl_def +let (as_wl_deferred : + worklist -> + FStarC_TypeChecker_Common.deferred -> + (Prims.int * FStarC_TypeChecker_Common.deferred_reason * lstring * + FStarC_TypeChecker_Common.prob) FStarC_Compiler_CList.clist) + = + fun wl -> + fun d -> + FStarC_Compiler_CList.map + (fun uu___ -> + match uu___ with + | (reason, m, p) -> + let uu___1 = FStarC_Thunk.mkv m in + ((wl.ctr), reason, uu___1, p)) d +let (new_uvar : + Prims.string -> + worklist -> + FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.binding Prims.list -> + FStarC_Syntax_Syntax.binder Prims.list -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.should_check_uvar -> + FStarC_Syntax_Syntax.ctx_uvar_meta_t + FStar_Pervasives_Native.option -> + (FStarC_Syntax_Syntax.ctx_uvar * FStarC_Syntax_Syntax.term + * worklist)) + = + fun reason -> + fun wl -> + fun r -> + fun gamma -> + fun binders -> + fun k -> + fun should_check -> + fun meta -> + let decoration = + { + FStarC_Syntax_Syntax.uvar_decoration_typ = k; + FStarC_Syntax_Syntax.uvar_decoration_typedness_depends_on + = []; + FStarC_Syntax_Syntax.uvar_decoration_should_check = + should_check; + FStarC_Syntax_Syntax.uvar_decoration_should_unrefine = + false + } in + let ctx_uvar = + let uu___ = FStarC_Syntax_Unionfind.fresh decoration r in + { + FStarC_Syntax_Syntax.ctx_uvar_head = uu___; + FStarC_Syntax_Syntax.ctx_uvar_gamma = gamma; + FStarC_Syntax_Syntax.ctx_uvar_binders = binders; + FStarC_Syntax_Syntax.ctx_uvar_reason = reason; + FStarC_Syntax_Syntax.ctx_uvar_range = r; + FStarC_Syntax_Syntax.ctx_uvar_meta = meta + } in + FStarC_TypeChecker_Common.check_uvar_ctx_invariant reason r + true gamma binders; + (let t = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_uvar + (ctx_uvar, ([], FStarC_Syntax_Syntax.NoUseRange))) + r in + let imp = + { + FStarC_TypeChecker_Common.imp_reason = reason; + FStarC_TypeChecker_Common.imp_uvar = ctx_uvar; + FStarC_TypeChecker_Common.imp_tm = t; + FStarC_TypeChecker_Common.imp_range = r + } in + (let uu___2 = + FStarC_Compiler_Effect.op_Bang dbg_ImplicitTrace in + if uu___2 + then + let uu___3 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_uvar + ctx_uvar.FStarC_Syntax_Syntax.ctx_uvar_head in + FStarC_Compiler_Util.print1 + "Just created uvar (Rel) {%s}\n" uu___3 + else ()); + (let uu___2 = + let uu___3 = + Obj.magic + (FStarC_Class_Listlike.cons () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist ())) + imp (Obj.magic wl.wl_implicits)) in + { + attempting = (wl.attempting); + wl_deferred = (wl.wl_deferred); + wl_deferred_to_tac = (wl.wl_deferred_to_tac); + ctr = (wl.ctr); + defer_ok = (wl.defer_ok); + smt_ok = (wl.smt_ok); + umax_heuristic_ok = (wl.umax_heuristic_ok); + tcenv = (wl.tcenv); + wl_implicits = uu___3; + repr_subcomp_allowed = (wl.repr_subcomp_allowed); + typeclass_variables = (wl.typeclass_variables) + } in + (ctx_uvar, t, uu___2))) +let (copy_uvar : + FStarC_Syntax_Syntax.ctx_uvar -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + worklist -> + (FStarC_Syntax_Syntax.ctx_uvar * FStarC_Syntax_Syntax.term * + worklist)) + = + fun u -> + fun bs -> + fun t -> + fun wl -> + let env = + let uu___ = wl.tcenv in + { + FStarC_TypeChecker_Env.solver = + (uu___.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (uu___.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (uu___.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (u.FStarC_Syntax_Syntax.ctx_uvar_gamma); + FStarC_TypeChecker_Env.gamma_sig = + (uu___.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (uu___.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (uu___.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (uu___.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (uu___.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (uu___.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (uu___.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (uu___.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (uu___.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (uu___.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (uu___.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (uu___.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (uu___.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (uu___.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (uu___.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (uu___.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (uu___.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (uu___.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (uu___.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (uu___.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (uu___.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (uu___.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (uu___.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (uu___.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (uu___.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (uu___.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (uu___.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (uu___.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (uu___.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (uu___.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (uu___.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (uu___.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (uu___.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (uu___.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (uu___.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (uu___.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (uu___.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (uu___.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (uu___.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (uu___.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = (uu___.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (uu___.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (uu___.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (uu___.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (uu___.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (uu___.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (uu___.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (uu___.FStarC_TypeChecker_Env.missing_decl) + } in + let env1 = FStarC_TypeChecker_Env.push_binders env bs in + let uu___ = FStarC_TypeChecker_Env.all_binders env1 in + let uu___1 = FStarC_Syntax_Util.ctx_uvar_should_check u in + new_uvar + (Prims.strcat "copy:" u.FStarC_Syntax_Syntax.ctx_uvar_reason) wl + u.FStarC_Syntax_Syntax.ctx_uvar_range + env1.FStarC_TypeChecker_Env.gamma uu___ t uu___1 + u.FStarC_Syntax_Syntax.ctx_uvar_meta +type solution = + | Success of (FStarC_TypeChecker_Common.deferred * + FStarC_TypeChecker_Common.deferred * FStarC_TypeChecker_Common.implicits_t) + + | Failed of (FStarC_TypeChecker_Common.prob * lstring) +let (uu___is_Success : solution -> Prims.bool) = + fun projectee -> match projectee with | Success _0 -> true | uu___ -> false +let (__proj__Success__item___0 : + solution -> + (FStarC_TypeChecker_Common.deferred * FStarC_TypeChecker_Common.deferred + * FStarC_TypeChecker_Common.implicits_t)) + = fun projectee -> match projectee with | Success _0 -> _0 +let (uu___is_Failed : solution -> Prims.bool) = + fun projectee -> match projectee with | Failed _0 -> true | uu___ -> false +let (__proj__Failed__item___0 : + solution -> (FStarC_TypeChecker_Common.prob * lstring)) = + fun projectee -> match projectee with | Failed _0 -> _0 +let (extend_wl : + worklist -> + FStarC_TypeChecker_Common.deferred -> + FStarC_TypeChecker_Common.deferred -> + FStarC_TypeChecker_Common.implicits_t -> worklist) + = + fun wl -> + fun defers -> + fun defer_to_tac -> + fun imps -> + let uu___ = + let uu___1 = as_wl_deferred wl defers in + FStarC_Class_Monoid.op_Plus_Plus + (FStarC_Compiler_CList.monoid_clist ()) wl.wl_deferred uu___1 in + let uu___1 = + let uu___2 = as_wl_deferred wl defer_to_tac in + FStarC_Class_Monoid.op_Plus_Plus + (FStarC_Compiler_CList.monoid_clist ()) wl.wl_deferred_to_tac + uu___2 in + let uu___2 = + FStarC_Class_Monoid.op_Plus_Plus + (FStarC_Compiler_CList.monoid_clist ()) wl.wl_implicits imps in + { + attempting = (wl.attempting); + wl_deferred = uu___; + wl_deferred_to_tac = uu___1; + ctr = (wl.ctr); + defer_ok = (wl.defer_ok); + smt_ok = (wl.smt_ok); + umax_heuristic_ok = (wl.umax_heuristic_ok); + tcenv = (wl.tcenv); + wl_implicits = uu___2; + repr_subcomp_allowed = (wl.repr_subcomp_allowed); + typeclass_variables = (wl.typeclass_variables) + } +type variance = + | COVARIANT + | CONTRAVARIANT + | INVARIANT +let (uu___is_COVARIANT : variance -> Prims.bool) = + fun projectee -> match projectee with | COVARIANT -> true | uu___ -> false +let (uu___is_CONTRAVARIANT : variance -> Prims.bool) = + fun projectee -> + match projectee with | CONTRAVARIANT -> true | uu___ -> false +let (uu___is_INVARIANT : variance -> Prims.bool) = + fun projectee -> match projectee with | INVARIANT -> true | uu___ -> false +type tprob = FStarC_Syntax_Syntax.typ FStarC_TypeChecker_Common.problem +type cprob = FStarC_Syntax_Syntax.comp FStarC_TypeChecker_Common.problem +type 'a problem_t = 'a FStarC_TypeChecker_Common.problem +let (invert_rel : + FStarC_TypeChecker_Common.rel -> FStarC_TypeChecker_Common.rel) = + fun uu___ -> + match uu___ with + | FStarC_TypeChecker_Common.EQ -> FStarC_TypeChecker_Common.EQ + | FStarC_TypeChecker_Common.SUB -> FStarC_TypeChecker_Common.SUBINV + | FStarC_TypeChecker_Common.SUBINV -> FStarC_TypeChecker_Common.SUB +let invert : + 'uuuuu . + 'uuuuu FStarC_TypeChecker_Common.problem -> + 'uuuuu FStarC_TypeChecker_Common.problem + = + fun p -> + { + FStarC_TypeChecker_Common.pid = (p.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = (p.FStarC_TypeChecker_Common.rhs); + FStarC_TypeChecker_Common.relation = + (invert_rel p.FStarC_TypeChecker_Common.relation); + FStarC_TypeChecker_Common.rhs = (p.FStarC_TypeChecker_Common.lhs); + FStarC_TypeChecker_Common.element = + (p.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (p.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar = + (p.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = (p.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = (p.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = (p.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = + (p.FStarC_TypeChecker_Common.logical) + } +let maybe_invert : + 'uuuuu . + 'uuuuu FStarC_TypeChecker_Common.problem -> + 'uuuuu FStarC_TypeChecker_Common.problem + = + fun p -> + if + p.FStarC_TypeChecker_Common.relation = FStarC_TypeChecker_Common.SUBINV + then invert p + else p +let (maybe_invert_p : + FStarC_TypeChecker_Common.prob -> FStarC_TypeChecker_Common.prob) = + fun uu___ -> + match uu___ with + | FStarC_TypeChecker_Common.TProb p -> + FStarC_TypeChecker_Common.TProb (maybe_invert p) + | FStarC_TypeChecker_Common.CProb p -> + FStarC_TypeChecker_Common.CProb (maybe_invert p) +let (make_prob_eq : + FStarC_TypeChecker_Common.prob -> FStarC_TypeChecker_Common.prob) = + fun uu___ -> + match uu___ with + | FStarC_TypeChecker_Common.TProb p -> + FStarC_TypeChecker_Common.TProb + { + FStarC_TypeChecker_Common.pid = (p.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = (p.FStarC_TypeChecker_Common.lhs); + FStarC_TypeChecker_Common.relation = FStarC_TypeChecker_Common.EQ; + FStarC_TypeChecker_Common.rhs = (p.FStarC_TypeChecker_Common.rhs); + FStarC_TypeChecker_Common.element = + (p.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (p.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar = + (p.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (p.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = (p.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (p.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = + (p.FStarC_TypeChecker_Common.logical) + } + | FStarC_TypeChecker_Common.CProb p -> + FStarC_TypeChecker_Common.CProb + { + FStarC_TypeChecker_Common.pid = (p.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = (p.FStarC_TypeChecker_Common.lhs); + FStarC_TypeChecker_Common.relation = FStarC_TypeChecker_Common.EQ; + FStarC_TypeChecker_Common.rhs = (p.FStarC_TypeChecker_Common.rhs); + FStarC_TypeChecker_Common.element = + (p.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (p.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar = + (p.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (p.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = (p.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (p.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = + (p.FStarC_TypeChecker_Common.logical) + } +let (vary_rel : + FStarC_TypeChecker_Common.rel -> variance -> FStarC_TypeChecker_Common.rel) + = + fun rel -> + fun uu___ -> + match uu___ with + | INVARIANT -> FStarC_TypeChecker_Common.EQ + | CONTRAVARIANT -> invert_rel rel + | COVARIANT -> rel +let (p_pid : FStarC_TypeChecker_Common.prob -> Prims.int) = + fun uu___ -> + match uu___ with + | FStarC_TypeChecker_Common.TProb p -> p.FStarC_TypeChecker_Common.pid + | FStarC_TypeChecker_Common.CProb p -> p.FStarC_TypeChecker_Common.pid +let (p_rel : FStarC_TypeChecker_Common.prob -> FStarC_TypeChecker_Common.rel) + = + fun uu___ -> + match uu___ with + | FStarC_TypeChecker_Common.TProb p -> + p.FStarC_TypeChecker_Common.relation + | FStarC_TypeChecker_Common.CProb p -> + p.FStarC_TypeChecker_Common.relation +let (p_reason : FStarC_TypeChecker_Common.prob -> Prims.string Prims.list) = + fun uu___ -> + match uu___ with + | FStarC_TypeChecker_Common.TProb p -> p.FStarC_TypeChecker_Common.reason + | FStarC_TypeChecker_Common.CProb p -> p.FStarC_TypeChecker_Common.reason +let (p_loc : + FStarC_TypeChecker_Common.prob -> FStarC_Compiler_Range_Type.range) = + fun uu___ -> + match uu___ with + | FStarC_TypeChecker_Common.TProb p -> p.FStarC_TypeChecker_Common.loc + | FStarC_TypeChecker_Common.CProb p -> p.FStarC_TypeChecker_Common.loc +let (p_element : + FStarC_TypeChecker_Common.prob -> + FStarC_Syntax_Syntax.bv FStar_Pervasives_Native.option) + = + fun uu___ -> + match uu___ with + | FStarC_TypeChecker_Common.TProb p -> + p.FStarC_TypeChecker_Common.element + | FStarC_TypeChecker_Common.CProb p -> + p.FStarC_TypeChecker_Common.element +let (p_guard : FStarC_TypeChecker_Common.prob -> FStarC_Syntax_Syntax.term) = + fun uu___ -> + match uu___ with + | FStarC_TypeChecker_Common.TProb p -> + p.FStarC_TypeChecker_Common.logical_guard + | FStarC_TypeChecker_Common.CProb p -> + p.FStarC_TypeChecker_Common.logical_guard +let (p_scope : + FStarC_TypeChecker_Common.prob -> FStarC_Syntax_Syntax.binder Prims.list) = + fun prob -> + let r = + match prob with + | FStarC_TypeChecker_Common.TProb p -> + let uu___ = + match p_element prob with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some x -> + let uu___1 = FStarC_Syntax_Syntax.mk_binder x in [uu___1] in + FStarC_Compiler_List.op_At + (p.FStarC_TypeChecker_Common.logical_guard_uvar).FStarC_Syntax_Syntax.ctx_uvar_binders + uu___ + | FStarC_TypeChecker_Common.CProb p -> + let uu___ = + match p_element prob with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some x -> + let uu___1 = FStarC_Syntax_Syntax.mk_binder x in [uu___1] in + FStarC_Compiler_List.op_At + (p.FStarC_TypeChecker_Common.logical_guard_uvar).FStarC_Syntax_Syntax.ctx_uvar_binders + uu___ in + r +let (p_guard_uvar : + FStarC_TypeChecker_Common.prob -> FStarC_Syntax_Syntax.ctx_uvar) = + fun uu___ -> + match uu___ with + | FStarC_TypeChecker_Common.TProb p -> + p.FStarC_TypeChecker_Common.logical_guard_uvar + | FStarC_TypeChecker_Common.CProb p -> + p.FStarC_TypeChecker_Common.logical_guard_uvar +let (p_env : + worklist -> FStarC_TypeChecker_Common.prob -> FStarC_TypeChecker_Env.env) = + fun wl -> + fun prob -> + let uu___ = wl.tcenv in + { + FStarC_TypeChecker_Env.solver = (uu___.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = (uu___.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (uu___.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + ((p_guard_uvar prob).FStarC_Syntax_Syntax.ctx_uvar_gamma); + FStarC_TypeChecker_Env.gamma_sig = + (uu___.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (uu___.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (uu___.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (uu___.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = (uu___.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (uu___.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (uu___.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (uu___.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (uu___.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (uu___.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (uu___.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (uu___.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (uu___.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (uu___.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = (uu___.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (uu___.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = (uu___.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (uu___.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (uu___.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (uu___.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (uu___.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (uu___.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (uu___.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (uu___.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (uu___.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (uu___.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (uu___.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (uu___.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (uu___.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (uu___.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (uu___.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (uu___.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (uu___.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (uu___.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = (uu___.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (uu___.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (uu___.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (uu___.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (uu___.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = (uu___.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = (uu___.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (uu___.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (uu___.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (uu___.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (uu___.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (uu___.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (uu___.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (uu___.FStarC_TypeChecker_Env.missing_decl) + } +let (p_guard_env : + worklist -> FStarC_TypeChecker_Common.prob -> FStarC_TypeChecker_Env.env) = + fun wl -> + fun prob -> + let uu___ = wl.tcenv in + { + FStarC_TypeChecker_Env.solver = (uu___.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = (uu___.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (uu___.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (FStarC_Compiler_List.op_At + (match p_element prob with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some x -> + [FStarC_Syntax_Syntax.Binding_var x]) + (p_guard_uvar prob).FStarC_Syntax_Syntax.ctx_uvar_gamma); + FStarC_TypeChecker_Env.gamma_sig = + (uu___.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (uu___.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (uu___.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (uu___.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = (uu___.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (uu___.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (uu___.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (uu___.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (uu___.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (uu___.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (uu___.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (uu___.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (uu___.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (uu___.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = (uu___.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (uu___.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = (uu___.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (uu___.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (uu___.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (uu___.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (uu___.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (uu___.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (uu___.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (uu___.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (uu___.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (uu___.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (uu___.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (uu___.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (uu___.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (uu___.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (uu___.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (uu___.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (uu___.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (uu___.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = (uu___.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (uu___.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (uu___.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (uu___.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (uu___.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = (uu___.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = (uu___.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (uu___.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (uu___.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (uu___.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (uu___.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (uu___.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (uu___.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (uu___.FStarC_TypeChecker_Env.missing_decl) + } +let (def_scope_wf : + Prims.string -> + FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.binder Prims.list -> unit) + = + fun msg -> + fun rng -> + fun r -> + let uu___ = + let uu___1 = FStarC_Options.defensive () in + Prims.op_Negation uu___1 in + if uu___ + then () + else + (let rec aux prev next = + match next with + | [] -> () + | { FStarC_Syntax_Syntax.binder_bv = bv; + FStarC_Syntax_Syntax.binder_qual = uu___2; + FStarC_Syntax_Syntax.binder_positivity = uu___3; + FStarC_Syntax_Syntax.binder_attrs = uu___4;_}::bs -> + (FStarC_Defensive.def_check_scoped + FStarC_Class_Binders.hasBinders_list_bv + FStarC_Class_Binders.hasNames_term + FStarC_Syntax_Print.pretty_term rng msg prev + bv.FStarC_Syntax_Syntax.sort; + aux (FStarC_Compiler_List.op_At prev [bv]) bs) in + aux [] r) +let (hasBinders_prob : + FStarC_TypeChecker_Common.prob FStarC_Class_Binders.hasBinders) = + { + FStarC_Class_Binders.boundNames = + (fun uu___ -> + (fun prob -> + let uu___ = + let uu___1 = p_scope prob in + FStarC_Compiler_List.map + (fun b -> b.FStarC_Syntax_Syntax.binder_bv) uu___1 in + Obj.magic + (FStarC_Class_Setlike.from_list () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) uu___)) uu___) + } +let (def_check_term_scoped_in_prob : + Prims.string -> + FStarC_TypeChecker_Common.prob -> FStarC_Syntax_Syntax.term -> unit) + = + fun msg -> + fun prob -> + fun phi -> + FStarC_Defensive.def_check_scoped hasBinders_prob + FStarC_Class_Binders.hasNames_term FStarC_Syntax_Print.pretty_term + (p_loc prob) msg prob phi +let (def_check_comp_scoped_in_prob : + Prims.string -> + FStarC_TypeChecker_Common.prob -> FStarC_Syntax_Syntax.comp -> unit) + = + fun msg -> + fun prob -> + fun phi -> + FStarC_Defensive.def_check_scoped hasBinders_prob + FStarC_Class_Binders.hasNames_comp FStarC_Syntax_Print.pretty_comp + (p_loc prob) msg prob phi +let (def_check_prob : Prims.string -> FStarC_TypeChecker_Common.prob -> unit) + = + fun msg -> + fun prob -> + let uu___ = + let uu___1 = FStarC_Options.defensive () in Prims.op_Negation uu___1 in + if uu___ + then () + else + (let msgf m = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Compiler_Util.string_of_int (p_pid prob) in + Prims.strcat uu___4 (Prims.strcat "." m) in + Prims.strcat "." uu___3 in + Prims.strcat msg uu___2 in + (let uu___3 = msgf "scope" in + let uu___4 = p_scope prob in + def_scope_wf uu___3 (p_loc prob) uu___4); + (let uu___4 = msgf "guard" in + def_check_term_scoped_in_prob uu___4 prob (p_guard prob)); + (match prob with + | FStarC_TypeChecker_Common.TProb p -> + ((let uu___5 = msgf "lhs" in + def_check_term_scoped_in_prob uu___5 prob + p.FStarC_TypeChecker_Common.lhs); + (let uu___5 = msgf "rhs" in + def_check_term_scoped_in_prob uu___5 prob + p.FStarC_TypeChecker_Common.rhs)) + | FStarC_TypeChecker_Common.CProb p -> + ((let uu___5 = msgf "lhs" in + def_check_comp_scoped_in_prob uu___5 prob + p.FStarC_TypeChecker_Common.lhs); + (let uu___5 = msgf "rhs" in + def_check_comp_scoped_in_prob uu___5 prob + p.FStarC_TypeChecker_Common.rhs)))) +let (rel_to_string : FStarC_TypeChecker_Common.rel -> Prims.string) = + fun uu___ -> + match uu___ with + | FStarC_TypeChecker_Common.EQ -> "=" + | FStarC_TypeChecker_Common.SUB -> "<:" + | FStarC_TypeChecker_Common.SUBINV -> ":>" +let (term_to_string : FStarC_Syntax_Syntax.term -> Prims.string) = + fun t -> + let uu___ = FStarC_Syntax_Util.head_and_args t in + match uu___ with + | (head, args) -> + (match head.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_uvar (u, s) -> + let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_ctxu u in + let uu___2 = + let uu___3 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_subst_elt)) + (FStar_Pervasives_Native.fst s) in + Prims.strcat "@" uu___3 in + let uu___3 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + (FStarC_Class_Show.show_tuple2 + FStarC_Syntax_Print.showable_term + FStarC_Syntax_Print.showable_aqual)) args in + FStarC_Compiler_Util.format3 "%s%s %s" uu___1 uu___2 uu___3 + | uu___1 -> + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t) +let (prob_to_string : + FStarC_TypeChecker_Env.env -> + FStarC_TypeChecker_Common.prob -> Prims.string) + = + fun env -> + fun prob -> + match prob with + | FStarC_TypeChecker_Common.TProb p -> + let uu___ = + let uu___1 = + FStarC_Compiler_Util.string_of_int + p.FStarC_TypeChecker_Common.pid in + let uu___2 = + let uu___3 = term_to_string p.FStarC_TypeChecker_Common.lhs in + let uu___4 = + let uu___5 = + let uu___6 = term_to_string p.FStarC_TypeChecker_Common.rhs in + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + p.FStarC_TypeChecker_Common.logical in + [uu___9] in + (match p.FStarC_TypeChecker_Common.reason with + | [] -> "" + | r::uu___9 -> r) :: uu___8 in + uu___6 :: uu___7 in + (rel_to_string p.FStarC_TypeChecker_Common.relation) :: + uu___5 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + FStarC_Compiler_Util.format + "\n%s:\t%s \n\t\t%s\n\t%s\n\t(reason:%s) (logical:%s)\n" uu___ + | FStarC_TypeChecker_Common.CProb p -> + let uu___ = + FStarC_Compiler_Util.string_of_int + p.FStarC_TypeChecker_Common.pid in + let uu___1 = + FStarC_TypeChecker_Normalize.comp_to_string env + p.FStarC_TypeChecker_Common.lhs in + let uu___2 = + FStarC_TypeChecker_Normalize.comp_to_string env + p.FStarC_TypeChecker_Common.rhs in + FStarC_Compiler_Util.format4 "\n%s:\t%s \n\t\t%s\n\t%s" uu___ + uu___1 (rel_to_string p.FStarC_TypeChecker_Common.relation) + uu___2 +let (prob_to_string' : + worklist -> FStarC_TypeChecker_Common.prob -> Prims.string) = + fun wl -> fun prob -> let env = p_env wl prob in prob_to_string env prob +let (uvi_to_string : FStarC_TypeChecker_Env.env -> uvi -> Prims.string) = + fun env -> + fun uu___ -> + match uu___ with + | UNIV (u, t) -> + let x = + let uu___1 = FStarC_Options.hide_uvar_nums () in + if uu___1 + then "?" + else + (let uu___3 = FStarC_Syntax_Unionfind.univ_uvar_id u in + FStarC_Compiler_Util.string_of_int uu___3) in + let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_univ t in + FStarC_Compiler_Util.format2 "UNIV %s <- %s" x uu___1 + | TERM (u, t) -> + let x = + let uu___1 = FStarC_Options.hide_uvar_nums () in + if uu___1 + then "?" + else + (let uu___3 = + FStarC_Syntax_Unionfind.uvar_id + u.FStarC_Syntax_Syntax.ctx_uvar_head in + FStarC_Compiler_Util.string_of_int uu___3) in + let uu___1 = FStarC_TypeChecker_Normalize.term_to_string env t in + FStarC_Compiler_Util.format2 "TERM %s <- %s" x uu___1 +let (uvis_to_string : + FStarC_TypeChecker_Env.env -> uvi Prims.list -> Prims.string) = + fun env -> + fun uvis -> (FStarC_Common.string_of_list ()) (uvi_to_string env) uvis +let (empty_worklist : FStarC_TypeChecker_Env.env -> worklist) = + fun env -> + let uu___ = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Free.ord_ctx_uvar)) ()) in + { + attempting = []; + wl_deferred = + (Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic (FStarC_Compiler_CList.listlike_clist ())))); + wl_deferred_to_tac = + (Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic (FStarC_Compiler_CList.listlike_clist ())))); + ctr = Prims.int_zero; + defer_ok = DeferAny; + smt_ok = true; + umax_heuristic_ok = true; + tcenv = env; + wl_implicits = + (Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic (FStarC_Compiler_CList.listlike_clist ())))); + repr_subcomp_allowed = false; + typeclass_variables = uu___ + } +let (giveup : + worklist -> lstring -> FStarC_TypeChecker_Common.prob -> solution) = + fun wl -> + fun reason -> + fun prob -> + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___1 + then + let uu___2 = FStarC_Thunk.force reason in + let uu___3 = prob_to_string' wl prob in + FStarC_Compiler_Util.print2 "Failed %s:\n%s\n" uu___2 uu___3 + else ()); + Failed (prob, reason) +let (giveup_lit : + worklist -> Prims.string -> FStarC_TypeChecker_Common.prob -> solution) = + fun wl -> + fun reason -> + fun prob -> + let uu___ = mklstr (fun uu___1 -> reason) in giveup wl uu___ prob +let (singleton : + worklist -> FStarC_TypeChecker_Common.prob -> Prims.bool -> worklist) = + fun wl -> + fun prob -> + fun smt_ok -> + { + attempting = [prob]; + wl_deferred = (wl.wl_deferred); + wl_deferred_to_tac = (wl.wl_deferred_to_tac); + ctr = (wl.ctr); + defer_ok = (wl.defer_ok); + smt_ok; + umax_heuristic_ok = (wl.umax_heuristic_ok); + tcenv = (wl.tcenv); + wl_implicits = (wl.wl_implicits); + repr_subcomp_allowed = (wl.repr_subcomp_allowed); + typeclass_variables = (wl.typeclass_variables) + } +let wl_of_guard : + 'uuuuu 'uuuuu1 . + FStarC_TypeChecker_Env.env -> + ('uuuuu * 'uuuuu1 * FStarC_TypeChecker_Common.prob) Prims.list -> + worklist + = + fun env -> + fun g -> + let uu___ = empty_worklist env in + let uu___1 = + FStarC_Compiler_List.map + (fun uu___2 -> match uu___2 with | (uu___3, uu___4, p) -> p) g in + { + attempting = uu___1; + wl_deferred = (uu___.wl_deferred); + wl_deferred_to_tac = (uu___.wl_deferred_to_tac); + ctr = (uu___.ctr); + defer_ok = (uu___.defer_ok); + smt_ok = (uu___.smt_ok); + umax_heuristic_ok = (uu___.umax_heuristic_ok); + tcenv = (uu___.tcenv); + wl_implicits = (uu___.wl_implicits); + repr_subcomp_allowed = (uu___.repr_subcomp_allowed); + typeclass_variables = (uu___.typeclass_variables) + } +let (defer : + FStarC_TypeChecker_Common.deferred_reason -> + lstring -> FStarC_TypeChecker_Common.prob -> worklist -> worklist) + = + fun reason -> + fun msg -> + fun prob -> + fun wl -> + let uu___ = + Obj.magic + (FStarC_Class_Listlike.cons () + (Obj.magic (FStarC_Compiler_CList.listlike_clist ())) + ((wl.ctr), reason, msg, prob) (Obj.magic wl.wl_deferred)) in + { + attempting = (wl.attempting); + wl_deferred = uu___; + wl_deferred_to_tac = (wl.wl_deferred_to_tac); + ctr = (wl.ctr); + defer_ok = (wl.defer_ok); + smt_ok = (wl.smt_ok); + umax_heuristic_ok = (wl.umax_heuristic_ok); + tcenv = (wl.tcenv); + wl_implicits = (wl.wl_implicits); + repr_subcomp_allowed = (wl.repr_subcomp_allowed); + typeclass_variables = (wl.typeclass_variables) + } +let (defer_lit : + FStarC_TypeChecker_Common.deferred_reason -> + Prims.string -> FStarC_TypeChecker_Common.prob -> worklist -> worklist) + = + fun reason -> + fun msg -> + fun prob -> + fun wl -> + let uu___ = FStarC_Thunk.mkv msg in defer reason uu___ prob wl +let (attempt : + FStarC_TypeChecker_Common.prob Prims.list -> worklist -> worklist) = + fun probs -> + fun wl -> + FStarC_Compiler_List.iter (def_check_prob "attempt") probs; + { + attempting = (FStarC_Compiler_List.op_At probs wl.attempting); + wl_deferred = (wl.wl_deferred); + wl_deferred_to_tac = (wl.wl_deferred_to_tac); + ctr = (wl.ctr); + defer_ok = (wl.defer_ok); + smt_ok = (wl.smt_ok); + umax_heuristic_ok = (wl.umax_heuristic_ok); + tcenv = (wl.tcenv); + wl_implicits = (wl.wl_implicits); + repr_subcomp_allowed = (wl.repr_subcomp_allowed); + typeclass_variables = (wl.typeclass_variables) + } +let (mk_eq2 : + worklist -> + FStarC_TypeChecker_Common.prob -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + (FStarC_Syntax_Syntax.term * worklist)) + = + fun wl -> + fun prob -> + fun t1 -> + fun t2 -> + let env = p_env wl prob in + FStarC_Defensive.def_check_scoped + FStarC_TypeChecker_Env.hasBinders_env + FStarC_Class_Binders.hasNames_term + FStarC_Syntax_Print.pretty_term t1.FStarC_Syntax_Syntax.pos + "mk_eq2.t1" env t1; + FStarC_Defensive.def_check_scoped + FStarC_TypeChecker_Env.hasBinders_env + FStarC_Class_Binders.hasNames_term + FStarC_Syntax_Print.pretty_term t2.FStarC_Syntax_Syntax.pos + "mk_eq2.t2" env t2; + (let uu___2 = + env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + env t1 false in + match uu___2 with + | (tt, uu___3) -> + let u = env.FStarC_TypeChecker_Env.universe_of env tt in + let uu___4 = FStarC_Syntax_Util.mk_eq2 u tt t1 t2 in + (uu___4, wl)) +let (p_invert : + FStarC_TypeChecker_Common.prob -> FStarC_TypeChecker_Common.prob) = + fun uu___ -> + match uu___ with + | FStarC_TypeChecker_Common.TProb p -> + FStarC_TypeChecker_Common.TProb (invert p) + | FStarC_TypeChecker_Common.CProb p -> + FStarC_TypeChecker_Common.CProb (invert p) +let (p_logical : FStarC_TypeChecker_Common.prob -> Prims.bool) = + fun uu___ -> + match uu___ with + | FStarC_TypeChecker_Common.TProb p -> + p.FStarC_TypeChecker_Common.logical + | FStarC_TypeChecker_Common.CProb p -> + p.FStarC_TypeChecker_Common.logical +let (set_logical : + Prims.bool -> + FStarC_TypeChecker_Common.prob -> FStarC_TypeChecker_Common.prob) + = + fun b -> + fun uu___ -> + match uu___ with + | FStarC_TypeChecker_Common.TProb p -> + FStarC_TypeChecker_Common.TProb + { + FStarC_TypeChecker_Common.pid = + (p.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = + (p.FStarC_TypeChecker_Common.lhs); + FStarC_TypeChecker_Common.relation = + (p.FStarC_TypeChecker_Common.relation); + FStarC_TypeChecker_Common.rhs = + (p.FStarC_TypeChecker_Common.rhs); + FStarC_TypeChecker_Common.element = + (p.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (p.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar = + (p.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (p.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = + (p.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (p.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = b + } + | FStarC_TypeChecker_Common.CProb p -> + FStarC_TypeChecker_Common.CProb + { + FStarC_TypeChecker_Common.pid = + (p.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = + (p.FStarC_TypeChecker_Common.lhs); + FStarC_TypeChecker_Common.relation = + (p.FStarC_TypeChecker_Common.relation); + FStarC_TypeChecker_Common.rhs = + (p.FStarC_TypeChecker_Common.rhs); + FStarC_TypeChecker_Common.element = + (p.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (p.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar = + (p.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (p.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = + (p.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (p.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = b + } +let (is_top_level_prob : FStarC_TypeChecker_Common.prob -> Prims.bool) = + fun p -> (FStarC_Compiler_List.length (p_reason p)) = Prims.int_one +let (next_pid : unit -> Prims.int) = + let ctr = FStarC_Compiler_Util.mk_ref Prims.int_zero in + fun uu___ -> + FStarC_Compiler_Util.incr ctr; FStarC_Compiler_Effect.op_Bang ctr +let mk_problem : + 'uuuuu . + worklist -> + FStarC_Syntax_Syntax.binder Prims.list -> + FStarC_TypeChecker_Common.prob -> + 'uuuuu -> + FStarC_TypeChecker_Common.rel -> + 'uuuuu -> + FStarC_Syntax_Syntax.bv FStar_Pervasives_Native.option -> + Prims.string -> + ('uuuuu FStarC_TypeChecker_Common.problem * worklist) + = + fun wl -> + fun scope -> + fun orig -> + fun lhs -> + fun rel -> + fun rhs -> + fun elt -> + fun reason -> + let scope1 = + match elt with + | FStar_Pervasives_Native.None -> scope + | FStar_Pervasives_Native.Some x -> + let uu___ = + let uu___1 = FStarC_Syntax_Syntax.mk_binder x in + [uu___1] in + FStarC_Compiler_List.op_At scope uu___ in + let bs = + FStarC_Compiler_List.op_At + (p_guard_uvar orig).FStarC_Syntax_Syntax.ctx_uvar_binders + scope1 in + let gamma = + let uu___ = + let uu___1 = + FStarC_Compiler_List.map + (fun b -> + FStarC_Syntax_Syntax.Binding_var + (b.FStarC_Syntax_Syntax.binder_bv)) scope1 in + FStarC_Compiler_List.rev uu___1 in + FStarC_Compiler_List.op_At uu___ + (p_guard_uvar orig).FStarC_Syntax_Syntax.ctx_uvar_gamma in + let uu___ = + new_uvar + (Prims.strcat "mk_problem: logical guard for " reason) + wl FStarC_Compiler_Range_Type.dummyRange gamma bs + FStarC_Syntax_Util.ktype0 + (FStarC_Syntax_Syntax.Allow_untyped "logical guard") + FStar_Pervasives_Native.None in + match uu___ with + | (ctx_uvar, lg, wl1) -> + let prob = + let uu___1 = next_pid () in + { + FStarC_TypeChecker_Common.pid = uu___1; + FStarC_TypeChecker_Common.lhs = lhs; + FStarC_TypeChecker_Common.relation = rel; + FStarC_TypeChecker_Common.rhs = rhs; + FStarC_TypeChecker_Common.element = elt; + FStarC_TypeChecker_Common.logical_guard = lg; + FStarC_TypeChecker_Common.logical_guard_uvar = + ctx_uvar; + FStarC_TypeChecker_Common.reason = (reason :: + (p_reason orig)); + FStarC_TypeChecker_Common.loc = (p_loc orig); + FStarC_TypeChecker_Common.rank = + FStar_Pervasives_Native.None; + FStarC_TypeChecker_Common.logical = + (p_logical orig) + } in + (prob, wl1) +let (mk_t_problem : + worklist -> + FStarC_Syntax_Syntax.binder Prims.list -> + FStarC_TypeChecker_Common.prob -> + FStarC_Syntax_Syntax.typ -> + FStarC_TypeChecker_Common.rel -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.bv FStar_Pervasives_Native.option -> + Prims.string -> (FStarC_TypeChecker_Common.prob * worklist)) + = + fun wl -> + fun scope -> + fun orig -> + fun lhs -> + fun rel -> + fun rhs -> + fun elt -> + fun reason -> + def_check_prob (Prims.strcat reason ".mk_t.arg") orig; + (let uu___1 = + mk_problem wl scope orig lhs rel rhs elt reason in + match uu___1 with + | (p, wl1) -> + (def_check_prob (Prims.strcat reason ".mk_t") + (FStarC_TypeChecker_Common.TProb p); + ((FStarC_TypeChecker_Common.TProb p), wl1))) +let (mk_c_problem : + worklist -> + FStarC_Syntax_Syntax.binder Prims.list -> + FStarC_TypeChecker_Common.prob -> + FStarC_Syntax_Syntax.comp -> + FStarC_TypeChecker_Common.rel -> + FStarC_Syntax_Syntax.comp -> + FStarC_Syntax_Syntax.bv FStar_Pervasives_Native.option -> + Prims.string -> (FStarC_TypeChecker_Common.prob * worklist)) + = + fun wl -> + fun scope -> + fun orig -> + fun lhs -> + fun rel -> + fun rhs -> + fun elt -> + fun reason -> + def_check_prob (Prims.strcat reason ".mk_c.arg") orig; + (let uu___1 = + mk_problem wl scope orig lhs rel rhs elt reason in + match uu___1 with + | (p, wl1) -> + (def_check_prob (Prims.strcat reason ".mk_c") + (FStarC_TypeChecker_Common.CProb p); + ((FStarC_TypeChecker_Common.CProb p), wl1))) +let new_problem : + 'uuuuu . + worklist -> + FStarC_TypeChecker_Env.env -> + 'uuuuu -> + FStarC_TypeChecker_Common.rel -> + 'uuuuu -> + FStarC_Syntax_Syntax.bv FStar_Pervasives_Native.option -> + FStarC_Compiler_Range_Type.range -> + Prims.string -> + ('uuuuu FStarC_TypeChecker_Common.problem * worklist) + = + fun wl -> + fun env -> + fun lhs -> + fun rel -> + fun rhs -> + fun subject -> + fun loc -> + fun reason -> + let lg_ty = + match subject with + | FStar_Pervasives_Native.None -> + FStarC_Syntax_Util.ktype0 + | FStar_Pervasives_Native.Some x -> + let bs = + let uu___ = FStarC_Syntax_Syntax.mk_binder x in + [uu___] in + let uu___ = + FStarC_Syntax_Syntax.mk_Total + FStarC_Syntax_Util.ktype0 in + FStarC_Syntax_Util.arrow bs uu___ in + let uu___ = + let uu___1 = FStarC_TypeChecker_Env.all_binders env in + new_uvar + (Prims.strcat "new_problem: logical guard for " reason) + { + attempting = (wl.attempting); + wl_deferred = (wl.wl_deferred); + wl_deferred_to_tac = (wl.wl_deferred_to_tac); + ctr = (wl.ctr); + defer_ok = (wl.defer_ok); + smt_ok = (wl.smt_ok); + umax_heuristic_ok = (wl.umax_heuristic_ok); + tcenv = env; + wl_implicits = (wl.wl_implicits); + repr_subcomp_allowed = (wl.repr_subcomp_allowed); + typeclass_variables = (wl.typeclass_variables) + } loc env.FStarC_TypeChecker_Env.gamma uu___1 lg_ty + (FStarC_Syntax_Syntax.Allow_untyped "logical guard") + FStar_Pervasives_Native.None in + match uu___ with + | (ctx_uvar, lg, wl1) -> + let lg1 = + match subject with + | FStar_Pervasives_Native.None -> lg + | FStar_Pervasives_Native.Some x -> + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Syntax_Syntax.bv_to_name x in + FStarC_Syntax_Syntax.as_arg uu___3 in + [uu___2] in + FStarC_Syntax_Syntax.mk_Tm_app lg uu___1 loc in + let prob = + let uu___1 = next_pid () in + { + FStarC_TypeChecker_Common.pid = uu___1; + FStarC_TypeChecker_Common.lhs = lhs; + FStarC_TypeChecker_Common.relation = rel; + FStarC_TypeChecker_Common.rhs = rhs; + FStarC_TypeChecker_Common.element = subject; + FStarC_TypeChecker_Common.logical_guard = lg1; + FStarC_TypeChecker_Common.logical_guard_uvar = + ctx_uvar; + FStarC_TypeChecker_Common.reason = [reason]; + FStarC_TypeChecker_Common.loc = loc; + FStarC_TypeChecker_Common.rank = + FStar_Pervasives_Native.None; + FStarC_TypeChecker_Common.logical = false + } in + (prob, wl1) +let (problem_using_guard : + FStarC_TypeChecker_Common.prob -> + FStarC_Syntax_Syntax.typ -> + FStarC_TypeChecker_Common.rel -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.bv FStar_Pervasives_Native.option -> + Prims.string -> + FStarC_Syntax_Syntax.typ FStarC_TypeChecker_Common.problem) + = + fun orig -> + fun lhs -> + fun rel -> + fun rhs -> + fun elt -> + fun reason -> + let p = + let uu___ = next_pid () in + { + FStarC_TypeChecker_Common.pid = uu___; + FStarC_TypeChecker_Common.lhs = lhs; + FStarC_TypeChecker_Common.relation = rel; + FStarC_TypeChecker_Common.rhs = rhs; + FStarC_TypeChecker_Common.element = elt; + FStarC_TypeChecker_Common.logical_guard = (p_guard orig); + FStarC_TypeChecker_Common.logical_guard_uvar = + (p_guard_uvar orig); + FStarC_TypeChecker_Common.reason = (reason :: + (p_reason orig)); + FStarC_TypeChecker_Common.loc = (p_loc orig); + FStarC_TypeChecker_Common.rank = + FStar_Pervasives_Native.None; + FStarC_TypeChecker_Common.logical = (p_logical orig) + } in + def_check_prob reason (FStarC_TypeChecker_Common.TProb p); p +let (guard_on_element : + worklist -> + FStarC_Syntax_Syntax.typ FStarC_TypeChecker_Common.problem -> + FStarC_Syntax_Syntax.bv -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term) + = + fun wl -> + fun problem -> + fun x -> + fun phi -> + match problem.FStarC_TypeChecker_Common.element with + | FStar_Pervasives_Native.None -> + let tcenv = p_env wl (FStarC_TypeChecker_Common.TProb problem) in + let u = + tcenv.FStarC_TypeChecker_Env.universe_of tcenv + x.FStarC_Syntax_Syntax.sort in + FStarC_Syntax_Util.mk_forall u x phi + | FStar_Pervasives_Native.Some e -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.bv_to_name e in + (x, uu___3) in + FStarC_Syntax_Syntax.NT uu___2 in + [uu___1] in + FStarC_Syntax_Subst.subst uu___ phi +let (explain : + worklist -> FStarC_TypeChecker_Common.prob -> lstring -> Prims.string) = + fun wl -> + fun d -> + fun s -> + let uu___ = + (FStarC_Compiler_Effect.op_Bang dbg_ExplainRel) || + (FStarC_Compiler_Effect.op_Bang dbg_Rel) in + if uu___ + then + let uu___1 = FStarC_Compiler_Range_Ops.string_of_range (p_loc d) in + let uu___2 = prob_to_string' wl d in + let uu___3 = FStarC_Thunk.force s in + FStarC_Compiler_Util.format4 + "(%s) Failed to solve the sub-problem\n%s\nWhich arose because:\n\t%s\nFailed because:%s\n" + uu___1 uu___2 + (FStarC_Compiler_String.concat "\n\t>" (p_reason d)) uu___3 + else + (let d1 = maybe_invert_p d in + let rel = + match p_rel d1 with + | FStarC_TypeChecker_Common.EQ -> "equal to" + | FStarC_TypeChecker_Common.SUB -> "a subtype of" + | uu___2 -> failwith "impossible" in + let uu___2 = + match d1 with + | FStarC_TypeChecker_Common.TProb tp -> + FStarC_TypeChecker_Err.print_discrepancy + (FStarC_TypeChecker_Normalize.term_to_string (p_env wl d1)) + tp.FStarC_TypeChecker_Common.lhs + tp.FStarC_TypeChecker_Common.rhs + | FStarC_TypeChecker_Common.CProb cp -> + FStarC_TypeChecker_Err.print_discrepancy + (FStarC_TypeChecker_Normalize.comp_to_string (p_env wl d1)) + cp.FStarC_TypeChecker_Common.lhs + cp.FStarC_TypeChecker_Common.rhs in + match uu___2 with + | (lhs, rhs) -> + FStarC_Compiler_Util.format3 + "%s is not %s the expected type %s" lhs rel rhs) +let (occurs : + FStarC_Syntax_Syntax.ctx_uvar -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.ctx_uvar Prims.list * Prims.bool)) + = + fun uk -> + fun t -> + let uvars = + let uu___ = FStarC_Syntax_Free.uvars t in + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) (Obj.magic uu___) in + let occurs1 = + FStarC_Compiler_Util.for_some + (fun uv -> + FStarC_Syntax_Unionfind.equiv + uv.FStarC_Syntax_Syntax.ctx_uvar_head + uk.FStarC_Syntax_Syntax.ctx_uvar_head) uvars in + (uvars, occurs1) +let (occurs_check : + FStarC_Syntax_Syntax.ctx_uvar -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.ctx_uvar Prims.list * Prims.bool * Prims.string + FStar_Pervasives_Native.option)) + = + fun uk -> + fun t -> + let uu___ = occurs uk t in + match uu___ with + | (uvars, occurs1) -> + let msg = + if Prims.op_Negation occurs1 + then FStar_Pervasives_Native.None + else + (let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_uvar + uk.FStarC_Syntax_Syntax.ctx_uvar_head in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.format2 + "occurs-check failed (%s occurs in %s)" uu___3 uu___4 in + FStar_Pervasives_Native.Some uu___2) in + (uvars, (Prims.op_Negation occurs1), msg) +let (occurs_full : + FStarC_Syntax_Syntax.ctx_uvar -> FStarC_Syntax_Syntax.term -> Prims.bool) = + fun uk -> + fun t -> + let uvars = + let uu___ = FStarC_Syntax_Free.uvars_full t in + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) (Obj.magic uu___) in + let occurs1 = + FStarC_Compiler_Util.for_some + (fun uv -> + FStarC_Syntax_Unionfind.equiv + uv.FStarC_Syntax_Syntax.ctx_uvar_head + uk.FStarC_Syntax_Syntax.ctx_uvar_head) uvars in + occurs1 +let set_uvar : + 'uuuuu . + 'uuuuu -> + FStarC_Syntax_Syntax.ctx_uvar -> + FStarC_Syntax_Syntax.should_check_uvar FStar_Pervasives_Native.option + -> FStarC_Syntax_Syntax.term -> unit + = + fun env -> + fun u -> + fun should_check_opt -> + fun t -> + (match should_check_opt with + | FStar_Pervasives_Native.None -> () + | FStar_Pervasives_Native.Some should_check -> + let uu___1 = + let uu___2 = + FStarC_Syntax_Unionfind.find_decoration + u.FStarC_Syntax_Syntax.ctx_uvar_head in + { + FStarC_Syntax_Syntax.uvar_decoration_typ = + (uu___2.FStarC_Syntax_Syntax.uvar_decoration_typ); + FStarC_Syntax_Syntax.uvar_decoration_typedness_depends_on + = + (uu___2.FStarC_Syntax_Syntax.uvar_decoration_typedness_depends_on); + FStarC_Syntax_Syntax.uvar_decoration_should_check = + should_check; + FStarC_Syntax_Syntax.uvar_decoration_should_unrefine = + (uu___2.FStarC_Syntax_Syntax.uvar_decoration_should_unrefine) + } in + FStarC_Syntax_Unionfind.change_decoration + u.FStarC_Syntax_Syntax.ctx_uvar_head uu___1); + (let uu___2 = FStarC_Options.defensive () in + if uu___2 + then + let uu___3 = + let uu___4 = occurs u t in FStar_Pervasives_Native.snd uu___4 in + (if uu___3 then failwith "OCCURS BUG!" else ()) + else ()); + FStarC_Syntax_Util.set_uvar u.FStarC_Syntax_Syntax.ctx_uvar_head t +let (commit : FStarC_TypeChecker_Env.env_t -> uvi Prims.list -> unit) = + fun env -> + fun uvis -> + FStarC_Compiler_List.iter + (fun uu___ -> + match uu___ with + | UNIV (u, t) -> + (match t with + | FStarC_Syntax_Syntax.U_unif u' -> + FStarC_Syntax_Unionfind.univ_union u u' + | uu___1 -> FStarC_Syntax_Unionfind.univ_change u t) + | TERM (u, t) -> + ((let uu___2 = + FStarC_Compiler_List.map + (fun b -> b.FStarC_Syntax_Syntax.binder_bv) + u.FStarC_Syntax_Syntax.ctx_uvar_binders in + FStarC_Defensive.def_check_scoped + FStarC_Class_Binders.hasBinders_list_bv + FStarC_Class_Binders.hasNames_term + FStarC_Syntax_Print.pretty_term t.FStarC_Syntax_Syntax.pos + "commit" uu___2 t); + set_uvar env u FStar_Pervasives_Native.None t)) uvis +let (find_term_uvar : + FStarC_Syntax_Syntax.uvar -> + uvi Prims.list -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option) + = + fun uv -> + fun s -> + FStarC_Compiler_Util.find_map s + (fun uu___ -> + match uu___ with + | UNIV uu___1 -> FStar_Pervasives_Native.None + | TERM (u, t) -> + let uu___1 = + FStarC_Syntax_Unionfind.equiv uv + u.FStarC_Syntax_Syntax.ctx_uvar_head in + if uu___1 + then FStar_Pervasives_Native.Some t + else FStar_Pervasives_Native.None) +let (find_univ_uvar : + FStarC_Syntax_Syntax.universe_uvar -> + uvi Prims.list -> + FStarC_Syntax_Syntax.universe FStar_Pervasives_Native.option) + = + fun u -> + fun s -> + FStarC_Compiler_Util.find_map s + (fun uu___ -> + match uu___ with + | UNIV (u', t) -> + let uu___1 = FStarC_Syntax_Unionfind.univ_equiv u u' in + if uu___1 + then FStar_Pervasives_Native.Some t + else FStar_Pervasives_Native.None + | uu___1 -> FStar_Pervasives_Native.None) +let (sn' : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun env -> + fun t -> + let uu___ = + let uu___1 = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Beta; FStarC_TypeChecker_Env.Reify] env t in + FStarC_Syntax_Subst.compress uu___1 in + FStarC_Syntax_Util.unlazy_emb uu___ +let (sn : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun env -> + fun t -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_Env.current_module env in + FStarC_Ident.string_of_lid uu___2 in + FStar_Pervasives_Native.Some uu___1 in + FStarC_Profiling.profile (fun uu___1 -> sn' env t) uu___ + "FStarC.TypeChecker.Rel.sn" +let (norm_with_steps : + Prims.string -> + FStarC_TypeChecker_Env.steps -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun profiling_tag -> + fun steps -> + fun env -> + fun t -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_Env.current_module env in + FStarC_Ident.string_of_lid uu___2 in + FStar_Pervasives_Native.Some uu___1 in + FStarC_Profiling.profile + (fun uu___1 -> FStarC_TypeChecker_Normalize.normalize steps env t) + uu___ profiling_tag +let (should_strongly_reduce : FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Util.unascribe t in + FStarC_Syntax_Util.head_and_args uu___1 in + match uu___ with + | (h, uu___1) -> + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress h in + uu___3.FStarC_Syntax_Syntax.n in + (match uu___2 with + | FStarC_Syntax_Syntax.Tm_constant (FStarC_Const.Const_reify uu___3) + -> true + | uu___3 -> false) +let (whnf : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun env -> + fun t -> + let norm steps t1 = + let uu___ = + let uu___1 = + let uu___2 = FStarC_Syntax_Util.unmeta t1 in + FStarC_TypeChecker_Normalize.normalize steps env uu___2 in + FStarC_Syntax_Subst.compress uu___1 in + FStarC_Syntax_Util.unlazy_emb uu___ in + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_Env.current_module env in + FStarC_Ident.string_of_lid uu___2 in + FStar_Pervasives_Native.Some uu___1 in + FStarC_Profiling.profile + (fun uu___1 -> + let steps = + let uu___2 = + let uu___3 = should_strongly_reduce t in + if uu___3 + then + [FStarC_TypeChecker_Env.Exclude FStarC_TypeChecker_Env.Zeta; + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant] + else [FStarC_TypeChecker_Env.Weak; FStarC_TypeChecker_Env.HNF] in + FStarC_Compiler_List.op_At uu___2 + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Reify; + FStarC_TypeChecker_Env.Primops] in + norm steps t) uu___ "FStarC.TypeChecker.Rel.whnf" +let norm_arg : + 'uuuuu . + FStarC_TypeChecker_Env.env -> + (FStarC_Syntax_Syntax.term * 'uuuuu) -> + (FStarC_Syntax_Syntax.term * 'uuuuu) + = + fun env -> + fun t -> + let uu___ = sn env (FStar_Pervasives_Native.fst t) in + (uu___, (FStar_Pervasives_Native.snd t)) +let (sn_binders : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.binders -> FStarC_Syntax_Syntax.binder Prims.list) + = + fun env -> + fun binders -> + FStarC_Compiler_List.map + (fun b -> + let uu___ = + let uu___1 = b.FStarC_Syntax_Syntax.binder_bv in + let uu___2 = + sn env + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + { + FStarC_Syntax_Syntax.ppname = + (uu___1.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (uu___1.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = uu___2 + } in + { + FStarC_Syntax_Syntax.binder_bv = uu___; + FStarC_Syntax_Syntax.binder_qual = + (b.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity = + (b.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs = + (b.FStarC_Syntax_Syntax.binder_attrs) + }) binders +let (norm_univ : + worklist -> FStarC_Syntax_Syntax.universe -> FStarC_Syntax_Syntax.universe) + = + fun wl -> + fun u -> + let rec aux u1 = + let u2 = FStarC_Syntax_Subst.compress_univ u1 in + match u2 with + | FStarC_Syntax_Syntax.U_succ u3 -> + let uu___ = aux u3 in FStarC_Syntax_Syntax.U_succ uu___ + | FStarC_Syntax_Syntax.U_max us -> + let uu___ = FStarC_Compiler_List.map aux us in + FStarC_Syntax_Syntax.U_max uu___ + | uu___ -> u2 in + let uu___ = aux u in + FStarC_TypeChecker_Normalize.normalize_universe wl.tcenv uu___ +let (normalize_refinement : + FStarC_TypeChecker_Env.steps -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.term) + = + fun steps -> + fun env -> + fun t0 -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_Env.current_module env in + FStarC_Ident.string_of_lid uu___2 in + FStar_Pervasives_Native.Some uu___1 in + FStarC_Profiling.profile + (fun uu___1 -> + FStarC_TypeChecker_Normalize.normalize_refinement steps env t0) + uu___ "FStarC.TypeChecker.Rel.normalize_refinement" +let (base_and_refinement_maybe_delta : + Prims.bool -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * (FStarC_Syntax_Syntax.bv * + FStarC_Syntax_Syntax.term) FStar_Pervasives_Native.option)) + = + fun should_delta -> + fun env -> + fun t1 -> + let norm_refinement env1 t = + let steps = + if should_delta + then + [FStarC_TypeChecker_Env.Weak; + FStarC_TypeChecker_Env.HNF; + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant] + else [FStarC_TypeChecker_Env.Weak; FStarC_TypeChecker_Env.HNF] in + normalize_refinement steps env1 t in + let rec aux norm t11 = + let t12 = FStarC_Syntax_Util.unmeta t11 in + match t12.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x; FStarC_Syntax_Syntax.phi = phi;_} + -> + if norm + then + ((x.FStarC_Syntax_Syntax.sort), + (FStar_Pervasives_Native.Some (x, phi))) + else + (let uu___1 = norm_refinement env t12 in + match uu___1 with + | { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x1; + FStarC_Syntax_Syntax.phi = phi1;_}; + FStarC_Syntax_Syntax.pos = uu___2; + FStarC_Syntax_Syntax.vars = uu___3; + FStarC_Syntax_Syntax.hash_code = uu___4;_} -> + ((x1.FStarC_Syntax_Syntax.sort), + (FStar_Pervasives_Native.Some (x1, phi1))) + | tt -> + let uu___2 = + let uu___3 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term tt in + let uu___4 = + FStarC_Class_Tagged.tag_of + FStarC_Syntax_Syntax.tagged_term tt in + FStarC_Compiler_Util.format2 + "impossible: Got %s ... %s\n" uu___3 uu___4 in + failwith uu___2) + | FStarC_Syntax_Syntax.Tm_lazy i -> + let uu___ = FStarC_Syntax_Util.unfold_lazy i in aux norm uu___ + | FStarC_Syntax_Syntax.Tm_uinst uu___ -> + if norm + then (t12, FStar_Pervasives_Native.None) + else + (let t1' = norm_refinement env t12 in + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress t1' in + uu___3.FStarC_Syntax_Syntax.n in + match uu___2 with + | FStarC_Syntax_Syntax.Tm_refine uu___3 -> aux true t1' + | uu___3 -> (t12, FStar_Pervasives_Native.None)) + | FStarC_Syntax_Syntax.Tm_fvar uu___ -> + if norm + then (t12, FStar_Pervasives_Native.None) + else + (let t1' = norm_refinement env t12 in + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress t1' in + uu___3.FStarC_Syntax_Syntax.n in + match uu___2 with + | FStarC_Syntax_Syntax.Tm_refine uu___3 -> aux true t1' + | uu___3 -> (t12, FStar_Pervasives_Native.None)) + | FStarC_Syntax_Syntax.Tm_app uu___ -> + if norm + then (t12, FStar_Pervasives_Native.None) + else + (let t1' = norm_refinement env t12 in + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress t1' in + uu___3.FStarC_Syntax_Syntax.n in + match uu___2 with + | FStarC_Syntax_Syntax.Tm_refine uu___3 -> aux true t1' + | uu___3 -> (t12, FStar_Pervasives_Native.None)) + | FStarC_Syntax_Syntax.Tm_type uu___ -> + (t12, FStar_Pervasives_Native.None) + | FStarC_Syntax_Syntax.Tm_constant uu___ -> + (t12, FStar_Pervasives_Native.None) + | FStarC_Syntax_Syntax.Tm_name uu___ -> + (t12, FStar_Pervasives_Native.None) + | FStarC_Syntax_Syntax.Tm_bvar uu___ -> + (t12, FStar_Pervasives_Native.None) + | FStarC_Syntax_Syntax.Tm_arrow uu___ -> + (t12, FStar_Pervasives_Native.None) + | FStarC_Syntax_Syntax.Tm_abs uu___ -> + (t12, FStar_Pervasives_Native.None) + | FStarC_Syntax_Syntax.Tm_quoted uu___ -> + (t12, FStar_Pervasives_Native.None) + | FStarC_Syntax_Syntax.Tm_uvar uu___ -> + (t12, FStar_Pervasives_Native.None) + | FStarC_Syntax_Syntax.Tm_let uu___ -> + (t12, FStar_Pervasives_Native.None) + | FStarC_Syntax_Syntax.Tm_match uu___ -> + (t12, FStar_Pervasives_Native.None) + | FStarC_Syntax_Syntax.Tm_meta uu___ -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + t12 in + let uu___3 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term + t12 in + FStarC_Compiler_Util.format2 + "impossible (outer): Got %s ... %s\n" uu___2 uu___3 in + failwith uu___1 + | FStarC_Syntax_Syntax.Tm_ascribed uu___ -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + t12 in + let uu___3 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term + t12 in + FStarC_Compiler_Util.format2 + "impossible (outer): Got %s ... %s\n" uu___2 uu___3 in + failwith uu___1 + | FStarC_Syntax_Syntax.Tm_delayed uu___ -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + t12 in + let uu___3 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term + t12 in + FStarC_Compiler_Util.format2 + "impossible (outer): Got %s ... %s\n" uu___2 uu___3 in + failwith uu___1 + | FStarC_Syntax_Syntax.Tm_unknown -> + let uu___ = + let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + t12 in + let uu___2 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term + t12 in + FStarC_Compiler_Util.format2 + "impossible (outer): Got %s ... %s\n" uu___1 uu___2 in + failwith uu___ in + let uu___ = whnf env t1 in aux false uu___ +let (base_and_refinement : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * (FStarC_Syntax_Syntax.bv * + FStarC_Syntax_Syntax.term) FStar_Pervasives_Native.option)) + = fun env -> fun t -> base_and_refinement_maybe_delta false env t +let (unrefine : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.typ) + = + fun env -> + fun t -> + let uu___ = base_and_refinement env t in + FStar_Pervasives_Native.fst uu___ +let (trivial_refinement : + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.bv * FStarC_Syntax_Syntax.term)) + = + fun t -> + let uu___ = FStarC_Syntax_Syntax.null_bv t in + (uu___, FStarC_Syntax_Util.t_true) +let (as_refinement : + Prims.bool -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.bv * FStarC_Syntax_Syntax.term)) + = + fun delta -> + fun env -> + fun t -> + let uu___ = base_and_refinement_maybe_delta delta env t in + match uu___ with + | (t_base, refinement) -> + (match refinement with + | FStar_Pervasives_Native.None -> trivial_refinement t_base + | FStar_Pervasives_Native.Some (x, phi) -> (x, phi)) +let (force_refinement : + (FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax * + (FStarC_Syntax_Syntax.bv * FStarC_Syntax_Syntax.term) + FStar_Pervasives_Native.option) -> FStarC_Syntax_Syntax.term) + = + fun uu___ -> + match uu___ with + | (t_base, refopt) -> + let uu___1 = + match refopt with + | FStar_Pervasives_Native.Some (y, phi) -> (y, phi) + | FStar_Pervasives_Native.None -> trivial_refinement t_base in + (match uu___1 with + | (y, phi) -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_refine + { + FStarC_Syntax_Syntax.b = y; + FStarC_Syntax_Syntax.phi = phi + }) t_base.FStarC_Syntax_Syntax.pos) +let (wl_to_string : worklist -> Prims.string) = + fun wl -> + let probs_to_string ps = + let uu___ = FStarC_Compiler_List.map (prob_to_string' wl) ps in + FStarC_Compiler_String.concat "\n\t" uu___ in + let cprobs_to_string ps = + let uu___ = + let uu___1 = FStarC_Compiler_CList.map (prob_to_string' wl) ps in + FStarC_Class_Listlike.to_list + (FStarC_Compiler_CList.listlike_clist ()) uu___1 in + FStarC_Compiler_String.concat "\n\t" uu___ in + let uu___ = probs_to_string wl.attempting in + let uu___1 = + let uu___2 = + FStarC_Compiler_CList.map + (fun uu___3 -> match uu___3 with | (uu___4, uu___5, uu___6, x) -> x) + wl.wl_deferred in + cprobs_to_string uu___2 in + FStarC_Compiler_Util.format2 + "{ attempting = [ %s ];\ndeferred = [ %s ] }\n" uu___ uu___1 +let (showable_wl : worklist FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = wl_to_string } +type flex_t = + | Flex of (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.ctx_uvar * + FStarC_Syntax_Syntax.args) +let (uu___is_Flex : flex_t -> Prims.bool) = fun projectee -> true +let (__proj__Flex__item___0 : + flex_t -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.ctx_uvar * + FStarC_Syntax_Syntax.args)) + = fun projectee -> match projectee with | Flex _0 -> _0 +let (flex_reason : flex_t -> Prims.string) = + fun uu___ -> + match uu___ with + | Flex (uu___1, u, uu___2) -> u.FStarC_Syntax_Syntax.ctx_uvar_reason +let (flex_uvar : flex_t -> FStarC_Syntax_Syntax.ctx_uvar) = + fun uu___ -> match uu___ with | Flex (uu___1, u, uu___2) -> u +let (flex_uvar_has_meta_tac : FStarC_Syntax_Syntax.ctx_uvar -> Prims.bool) = + fun u -> + match u.FStarC_Syntax_Syntax.ctx_uvar_meta with + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Ctx_uvar_meta_tac + uu___) -> true + | uu___ -> false +let (flex_t_to_string : flex_t -> Prims.string) = + fun uu___ -> + match uu___ with + | Flex (uu___1, c, args) -> + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_ctxu c in + let uu___3 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + (FStarC_Class_Show.show_tuple2 + FStarC_Syntax_Print.showable_term + FStarC_Syntax_Print.showable_aqual)) args in + FStarC_Compiler_Util.format2 "%s [%s]" uu___2 uu___3 +let (is_flex : FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t -> + let uu___ = FStarC_Syntax_Util.head_and_args t in + match uu___ with + | (head, _args) -> + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress head in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_uvar uu___2 -> true + | uu___2 -> false) +let (flex_uvar_head : + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.ctx_uvar) = + fun t -> + let uu___ = FStarC_Syntax_Util.head_and_args t in + match uu___ with + | (head, _args) -> + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress head in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_uvar (u, uu___2) -> u + | uu___2 -> failwith "Not a flex-uvar") +let ensure_no_uvar_subst : + 'uuuuu . + 'uuuuu -> + FStarC_Syntax_Syntax.term -> + worklist -> (FStarC_Syntax_Syntax.term * worklist) + = + fun env -> + fun t0 -> + fun wl -> + let bv_not_affected_by s x = + let t_x = FStarC_Syntax_Syntax.bv_to_name x in + let t_x' = FStarC_Syntax_Subst.subst' s t_x in + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t_x' in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_name y -> FStarC_Syntax_Syntax.bv_eq x y + | uu___1 -> false in + let binding_not_affected_by s b = + match b with + | FStarC_Syntax_Syntax.Binding_var x -> bv_not_affected_by s x + | uu___ -> true in + let uu___ = FStarC_Syntax_Util.head_and_args t0 in + match uu___ with + | (head, args) -> + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress head in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_uvar (uv, ([], uu___2)) -> (t0, wl) + | FStarC_Syntax_Syntax.Tm_uvar (uv, uu___2) when + FStarC_Compiler_List.isEmpty + uv.FStarC_Syntax_Syntax.ctx_uvar_binders + -> (t0, wl) + | FStarC_Syntax_Syntax.Tm_uvar (uv, s) -> + let uu___2 = + FStarC_Common.max_suffix (binding_not_affected_by s) + uv.FStarC_Syntax_Syntax.ctx_uvar_gamma in + (match uu___2 with + | (gamma_aff, new_gamma) -> + (match gamma_aff with + | [] -> (t0, wl) + | uu___3 -> + let dom_binders = + FStarC_TypeChecker_Env.binders_of_bindings + gamma_aff in + let uu___4 = + let uu___5 = + FStarC_TypeChecker_Env.binders_of_bindings + new_gamma in + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Util.ctx_uvar_typ uv in + FStarC_Syntax_Syntax.mk_Total uu___8 in + FStarC_Syntax_Util.arrow dom_binders uu___7 in + let uu___7 = + FStarC_Syntax_Util.ctx_uvar_should_check uv in + new_uvar + (Prims.strcat + uv.FStarC_Syntax_Syntax.ctx_uvar_reason + "; force delayed") wl + t0.FStarC_Syntax_Syntax.pos new_gamma uu___5 + uu___6 uu___7 + uv.FStarC_Syntax_Syntax.ctx_uvar_meta in + (match uu___4 with + | (v, t_v, wl1) -> + let args_sol = + FStarC_Compiler_List.map + FStarC_Syntax_Util.arg_of_non_null_binder + dom_binders in + let sol = + FStarC_Syntax_Syntax.mk_Tm_app t_v args_sol + t0.FStarC_Syntax_Syntax.pos in + ((let uu___6 = + FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___6 + then + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_ctxu uv in + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term sol in + FStarC_Compiler_Util.print2 + "ensure_no_uvar_subst solving %s with %s\n" + uu___7 uu___8 + else ()); + set_uvar env uv + (FStar_Pervasives_Native.Some + FStarC_Syntax_Syntax.Already_checked) + sol; + (let args_sol_s = + FStarC_Compiler_List.map + (fun uu___7 -> + match uu___7 with + | (a, i) -> + let uu___8 = + FStarC_Syntax_Subst.subst' s a in + (uu___8, i)) args_sol in + let t = + FStarC_Syntax_Syntax.mk_Tm_app t_v + (FStarC_Compiler_List.op_At args_sol_s + args) t0.FStarC_Syntax_Syntax.pos in + (t, wl1)))))) + | uu___2 -> + let uu___3 = + let uu___4 = + FStarC_Class_Tagged.tag_of + FStarC_Syntax_Syntax.tagged_term t0 in + let uu___5 = + FStarC_Class_Tagged.tag_of + FStarC_Syntax_Syntax.tagged_term head in + let uu___6 = + let uu___7 = FStarC_Syntax_Subst.compress head in + FStarC_Class_Tagged.tag_of + FStarC_Syntax_Syntax.tagged_term uu___7 in + FStarC_Compiler_Util.format3 + "ensure_no_uvar_subst: expected a uvar at the head (%s-%s-%s)" + uu___4 uu___5 uu___6 in + failwith uu___3) +let (no_free_uvars : FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t -> + (let uu___ = FStarC_Syntax_Free.uvars t in + FStarC_Class_Setlike.is_empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) (Obj.magic uu___)) + && + (let uu___ = FStarC_Syntax_Free.univs t in + FStarC_Class_Setlike.is_empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_univ_uvar)) (Obj.magic uu___)) +let rec (may_relate_with_logical_guard : + FStarC_TypeChecker_Env.env -> + Prims.bool -> FStarC_Syntax_Syntax.typ -> Prims.bool) + = + fun env -> + fun is_eq -> + fun head -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress head in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_name uu___1 -> true + | FStarC_Syntax_Syntax.Tm_match uu___1 -> true + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let uu___1 = FStarC_TypeChecker_Env.delta_depth_of_fv env fv in + (match uu___1 with + | FStarC_Syntax_Syntax.Delta_equational_at_level uu___2 -> true + | FStarC_Syntax_Syntax.Delta_abstract uu___2 -> is_eq + | uu___2 -> false) + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t; FStarC_Syntax_Syntax.asc = uu___1; + FStarC_Syntax_Syntax.eff_opt = uu___2;_} + -> may_relate_with_logical_guard env is_eq t + | FStarC_Syntax_Syntax.Tm_uinst (t, uu___1) -> + may_relate_with_logical_guard env is_eq t + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t; + FStarC_Syntax_Syntax.meta = uu___1;_} + -> may_relate_with_logical_guard env is_eq t + | uu___1 -> false +let (may_relate : + FStarC_TypeChecker_Env.env -> + FStarC_TypeChecker_Common.rel -> FStarC_Syntax_Syntax.typ -> Prims.bool) + = + fun env -> + fun prel -> + fun head -> + may_relate_with_logical_guard env + (FStarC_TypeChecker_Common.uu___is_EQ prel) head +let (destruct_flex_t' : FStarC_Syntax_Syntax.term -> flex_t) = + fun t -> + let uu___ = FStarC_Syntax_Util.head_and_args t in + match uu___ with + | (head, args) -> + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress head in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_uvar (uv, s) -> Flex (t, uv, args) + | uu___2 -> failwith "Not a flex-uvar") +let (destruct_flex_t : + FStarC_Syntax_Syntax.term -> worklist -> (flex_t * worklist)) = + fun t -> + fun wl -> + let uu___ = ensure_no_uvar_subst wl.tcenv t wl in + match uu___ with + | (t1, wl1) -> let uu___1 = destruct_flex_t' t1 in (uu___1, wl1) +let (u_abs : + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun k -> + fun ys -> + fun t -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress k in + uu___2.FStarC_Syntax_Syntax.n in + match uu___1 with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = c;_} + -> + if + (FStarC_Compiler_List.length bs) = + (FStarC_Compiler_List.length ys) + then + let uu___2 = FStarC_Syntax_Subst.open_comp bs c in + ((ys, t), uu___2) + else + (let uu___3 = FStarC_Syntax_Util.abs_formals t in + match uu___3 with + | (ys', t1, uu___4) -> + let uu___5 = FStarC_Syntax_Util.arrow_formals_comp k in + (((FStarC_Compiler_List.op_At ys ys'), t1), uu___5)) + | uu___2 -> + let uu___3 = + let uu___4 = FStarC_Syntax_Syntax.mk_Total k in ([], uu___4) in + ((ys, t), uu___3) in + match uu___ with + | ((ys1, t1), (xs, c)) -> + if + (FStarC_Compiler_List.length xs) <> + (FStarC_Compiler_List.length ys1) + then + FStarC_Syntax_Util.abs ys1 t1 + (FStar_Pervasives_Native.Some + (FStarC_Syntax_Util.mk_residual_comp + FStarC_Parser_Const.effect_Tot_lid + FStar_Pervasives_Native.None [])) + else + (let c1 = + let uu___2 = FStarC_Syntax_Util.rename_binders xs ys1 in + FStarC_Syntax_Subst.subst_comp uu___2 c in + let uu___2 = + let uu___3 = FStarC_Syntax_Util.residual_comp_of_comp c1 in + FStar_Pervasives_Native.Some uu___3 in + FStarC_Syntax_Util.abs ys1 t1 uu___2) +let (solve_prob' : + Prims.bool -> + FStarC_TypeChecker_Common.prob -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax + FStar_Pervasives_Native.option -> + uvi Prims.list -> worklist -> worklist) + = + fun resolve_ok -> + fun prob -> + fun logical_guard -> + fun uvis -> + fun wl -> + def_check_prob "solve_prob'" prob; + (let phi = + match logical_guard with + | FStar_Pervasives_Native.None -> FStarC_Syntax_Util.t_true + | FStar_Pervasives_Native.Some phi1 -> phi1 in + let assign_solution xs uv phi1 = + (let uu___2 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___2 + then + let uu___3 = + FStarC_Compiler_Util.string_of_int (p_pid prob) in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_ctxu + uv in + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + phi1 in + FStarC_Compiler_Util.print3 + "Solving %s (%s) with formula %s\n" uu___3 uu___4 uu___5 + else ()); + (let phi2 = + FStarC_Syntax_Util.abs xs phi1 + (FStar_Pervasives_Native.Some + (FStarC_Syntax_Util.residual_tot + FStarC_Syntax_Util.ktype0)) in + (let uu___3 = + let uu___4 = + FStarC_Compiler_Util.string_of_int (p_pid prob) in + Prims.strcat "solve_prob'.sol." uu___4 in + let uu___4 = + let uu___5 = p_scope prob in + FStarC_Compiler_List.map + (fun b -> b.FStarC_Syntax_Syntax.binder_bv) uu___5 in + FStarC_Defensive.def_check_scoped + FStarC_Class_Binders.hasBinders_list_bv + FStarC_Class_Binders.hasNames_term + FStarC_Syntax_Print.pretty_term (p_loc prob) uu___3 uu___4 + phi2); + set_uvar wl.tcenv uv FStar_Pervasives_Native.None phi2) in + let uv = p_guard_uvar prob in + let fail uu___1 = + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_ctxu + uv in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + (p_guard prob) in + FStarC_Compiler_Util.format2 + "Impossible: this instance %s has already been assigned a solution\n%s\n" + uu___3 uu___4 in + failwith uu___2 in + let args_as_binders args = + FStarC_Compiler_List.collect + (fun uu___1 -> + match uu___1 with + | (a, i) -> + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress a in + uu___3.FStarC_Syntax_Syntax.n in + (match uu___2 with + | FStarC_Syntax_Syntax.Tm_name x -> + let uu___3 = + FStarC_Syntax_Util.bqual_and_attrs_of_aqual i in + (match uu___3 with + | (q, attrs) -> + let uu___4 = + FStarC_Syntax_Util.parse_positivity_attributes + attrs in + (match uu___4 with + | (pq, attrs1) -> + let uu___5 = + FStarC_Syntax_Syntax.mk_binder_with_attrs + x q pq attrs1 in + [uu___5])) + | uu___3 -> (fail (); []))) args in + let wl1 = + let g = whnf (p_guard_env wl prob) (p_guard prob) in + let uu___1 = + let uu___2 = is_flex g in Prims.op_Negation uu___2 in + if uu___1 + then (if resolve_ok then wl else (fail (); wl)) + else + (let uu___3 = destruct_flex_t g wl in + match uu___3 with + | (Flex (uu___4, uv1, args), wl2) -> + ((let uu___6 = args_as_binders args in + assign_solution uu___6 uv1 phi); + wl2)) in + commit wl1.tcenv uvis; + { + attempting = (wl1.attempting); + wl_deferred = (wl1.wl_deferred); + wl_deferred_to_tac = (wl1.wl_deferred_to_tac); + ctr = (wl1.ctr + Prims.int_one); + defer_ok = (wl1.defer_ok); + smt_ok = (wl1.smt_ok); + umax_heuristic_ok = (wl1.umax_heuristic_ok); + tcenv = (wl1.tcenv); + wl_implicits = (wl1.wl_implicits); + repr_subcomp_allowed = (wl1.repr_subcomp_allowed); + typeclass_variables = (wl1.typeclass_variables) + }) +let (extend_universe_solution : + Prims.int -> uvi Prims.list -> worklist -> worklist) = + fun pid -> + fun sol -> + fun wl -> + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___1 + then + let uu___2 = FStarC_Compiler_Util.string_of_int pid in + let uu___3 = uvis_to_string wl.tcenv sol in + FStarC_Compiler_Util.print2 "Solving %s: with [%s]\n" uu___2 + uu___3 + else ()); + commit wl.tcenv sol; + { + attempting = (wl.attempting); + wl_deferred = (wl.wl_deferred); + wl_deferred_to_tac = (wl.wl_deferred_to_tac); + ctr = (wl.ctr + Prims.int_one); + defer_ok = (wl.defer_ok); + smt_ok = (wl.smt_ok); + umax_heuristic_ok = (wl.umax_heuristic_ok); + tcenv = (wl.tcenv); + wl_implicits = (wl.wl_implicits); + repr_subcomp_allowed = (wl.repr_subcomp_allowed); + typeclass_variables = (wl.typeclass_variables) + } +let (solve_prob : + FStarC_TypeChecker_Common.prob -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option -> + uvi Prims.list -> worklist -> worklist) + = + fun prob -> + fun logical_guard -> + fun uvis -> + fun wl -> + def_check_prob "solve_prob.prob" prob; + FStarC_Compiler_Util.iter_opt logical_guard + (def_check_term_scoped_in_prob "solve_prob.guard" prob); + (let uu___3 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___3 + then + let uu___4 = FStarC_Compiler_Util.string_of_int (p_pid prob) in + let uu___5 = uvis_to_string wl.tcenv uvis in + FStarC_Compiler_Util.print2 "Solving %s: with %s\n" uu___4 + uu___5 + else ()); + solve_prob' false prob logical_guard uvis wl +let rec (maximal_prefix : + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.binders -> + (FStarC_Syntax_Syntax.binders * (FStarC_Syntax_Syntax.binders * + FStarC_Syntax_Syntax.binders))) + = + fun bs -> + fun bs' -> + match (bs, bs') with + | (binder1::bs_tail, + { FStarC_Syntax_Syntax.binder_bv = b'; + FStarC_Syntax_Syntax.binder_qual = i'; + FStarC_Syntax_Syntax.binder_positivity = uu___; + FStarC_Syntax_Syntax.binder_attrs = uu___1;_}::bs'_tail) + -> + let uu___2 = + FStarC_Syntax_Syntax.bv_eq binder1.FStarC_Syntax_Syntax.binder_bv + b' in + if uu___2 + then + let uu___3 = maximal_prefix bs_tail bs'_tail in + (match uu___3 with | (pfx, rest) -> ((binder1 :: pfx), rest)) + else ([], (bs, bs')) + | uu___ -> ([], (bs, bs')) +let (extend_gamma : + FStarC_Syntax_Syntax.gamma -> + FStarC_Syntax_Syntax.binders -> FStarC_Syntax_Syntax.binding Prims.list) + = + fun g -> + fun bs -> + FStarC_Compiler_List.fold_left + (fun g1 -> + fun uu___ -> + match uu___ with + | { FStarC_Syntax_Syntax.binder_bv = x; + FStarC_Syntax_Syntax.binder_qual = uu___1; + FStarC_Syntax_Syntax.binder_positivity = uu___2; + FStarC_Syntax_Syntax.binder_attrs = uu___3;_} -> + (FStarC_Syntax_Syntax.Binding_var x) :: g1) g bs +let (gamma_until : + FStarC_Syntax_Syntax.gamma -> + FStarC_Syntax_Syntax.binders -> FStarC_Syntax_Syntax.binding Prims.list) + = + fun g -> + fun bs -> + let uu___ = FStarC_Compiler_List.last_opt bs in + match uu___ with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.binder_bv = x; + FStarC_Syntax_Syntax.binder_qual = uu___1; + FStarC_Syntax_Syntax.binder_positivity = uu___2; + FStarC_Syntax_Syntax.binder_attrs = uu___3;_} + -> + let uu___4 = + FStarC_Compiler_Util.prefix_until + (fun uu___5 -> + match uu___5 with + | FStarC_Syntax_Syntax.Binding_var x' -> + FStarC_Syntax_Syntax.bv_eq x x' + | uu___6 -> false) g in + (match uu___4 with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some (uu___5, bx, rest) -> bx :: rest) +let restrict_ctx : + 'uuuuu . + 'uuuuu -> + FStarC_Syntax_Syntax.ctx_uvar -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.ctx_uvar -> worklist -> worklist + = + fun env -> + fun tgt -> + fun bs -> + fun src -> + fun wl -> + let uu___ = + maximal_prefix tgt.FStarC_Syntax_Syntax.ctx_uvar_binders + src.FStarC_Syntax_Syntax.ctx_uvar_binders in + match uu___ with + | (pfx, uu___1) -> + let g = + gamma_until src.FStarC_Syntax_Syntax.ctx_uvar_gamma pfx in + let aux t f = + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_uvar + src.FStarC_Syntax_Syntax.ctx_uvar_head in + Prims.strcat "restricted " uu___4 in + let uu___4 = FStarC_Syntax_Util.ctx_uvar_should_check src in + new_uvar uu___3 wl + src.FStarC_Syntax_Syntax.ctx_uvar_range g pfx t uu___4 + src.FStarC_Syntax_Syntax.ctx_uvar_meta in + match uu___2 with + | (uu___3, src', wl1) -> + ((let uu___5 = f src' in + set_uvar env src + (FStar_Pervasives_Native.Some + FStarC_Syntax_Syntax.Already_checked) uu___5); + wl1) in + let bs1 = + FStarC_Compiler_List.filter + (fun uu___2 -> + match uu___2 with + | { FStarC_Syntax_Syntax.binder_bv = bv1; + FStarC_Syntax_Syntax.binder_qual = uu___3; + FStarC_Syntax_Syntax.binder_positivity = uu___4; + FStarC_Syntax_Syntax.binder_attrs = uu___5;_} -> + (FStarC_Compiler_List.existsb + (fun uu___6 -> + match uu___6 with + | { FStarC_Syntax_Syntax.binder_bv = bv2; + FStarC_Syntax_Syntax.binder_qual = + uu___7; + FStarC_Syntax_Syntax.binder_positivity = + uu___8; + FStarC_Syntax_Syntax.binder_attrs = + uu___9;_} + -> FStarC_Syntax_Syntax.bv_eq bv1 bv2) + src.FStarC_Syntax_Syntax.ctx_uvar_binders) + && + (let uu___6 = + FStarC_Compiler_List.existsb + (fun uu___7 -> + match uu___7 with + | { + FStarC_Syntax_Syntax.binder_bv = bv2; + FStarC_Syntax_Syntax.binder_qual = + uu___8; + FStarC_Syntax_Syntax.binder_positivity + = uu___9; + FStarC_Syntax_Syntax.binder_attrs = + uu___10;_} + -> + FStarC_Syntax_Syntax.bv_eq bv1 bv2) + pfx in + Prims.op_Negation uu___6)) bs in + if (FStarC_Compiler_List.length bs1) = Prims.int_zero + then + let uu___2 = FStarC_Syntax_Util.ctx_uvar_typ src in + aux uu___2 (fun src' -> src') + else + (let uu___3 = + let t = FStarC_Syntax_Util.ctx_uvar_typ src in + let uu___4 = FStarC_Syntax_Syntax.mk_Total t in + FStarC_Syntax_Util.arrow bs1 uu___4 in + aux uu___3 + (fun src' -> + let uu___4 = + let uu___5 = + FStarC_Syntax_Syntax.binders_to_names bs1 in + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.as_arg uu___5 in + FStarC_Syntax_Syntax.mk_Tm_app src' uu___4 + src.FStarC_Syntax_Syntax.ctx_uvar_range)) +let restrict_all_uvars : + 'uuuuu . + 'uuuuu -> + FStarC_Syntax_Syntax.ctx_uvar -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.ctx_uvar Prims.list -> worklist -> worklist + = + fun env -> + fun tgt -> + fun bs -> + fun sources -> + fun wl -> + match bs with + | [] -> + let ctx_tgt = + binders_as_bv_set tgt.FStarC_Syntax_Syntax.ctx_uvar_binders in + FStarC_Compiler_List.fold_right + (fun src -> + fun wl1 -> + let ctx_src = + binders_as_bv_set + src.FStarC_Syntax_Syntax.ctx_uvar_binders in + let uu___ = + FStarC_Class_Setlike.subset () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) + (Obj.magic ctx_src) (Obj.magic ctx_tgt) in + if uu___ then wl1 else restrict_ctx env tgt [] src wl1) + sources wl + | uu___ -> + FStarC_Compiler_List.fold_right (restrict_ctx env tgt bs) + sources wl +let (intersect_binders : + FStarC_Syntax_Syntax.gamma -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.binders -> FStarC_Syntax_Syntax.binders) + = + fun g -> + fun v1 -> + fun v2 -> + let as_set v = + let uu___ = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Syntax.ord_bv)) ()) in + FStarC_Compiler_List.fold_left + (fun uu___2 -> + fun uu___1 -> + (fun out -> + fun x -> + Obj.magic + (FStarC_Class_Setlike.add () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Syntax.ord_bv)) + x.FStarC_Syntax_Syntax.binder_bv (Obj.magic out))) + uu___2 uu___1) uu___ v in + let v1_set = as_set v1 in + let ctx_binders = + let uu___ = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) ()) in + FStarC_Compiler_List.fold_left + (fun uu___2 -> + fun uu___1 -> + (fun out -> + fun b -> + match b with + | FStarC_Syntax_Syntax.Binding_var x -> + Obj.magic + (Obj.repr + (FStarC_Class_Setlike.add () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) x + (Obj.magic out))) + | uu___1 -> Obj.magic (Obj.repr out)) uu___2 uu___1) + uu___ g in + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun b -> + match uu___1 with + | (isect, isect_set) -> + let uu___2 = + ((b.FStarC_Syntax_Syntax.binder_bv), + (b.FStarC_Syntax_Syntax.binder_qual)) in + (match uu___2 with + | (x, imp) -> + let uu___3 = + let uu___4 = + FStarC_Class_Setlike.mem () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Syntax.ord_bv)) x + (Obj.magic v1_set) in + Prims.op_Negation uu___4 in + if uu___3 + then (isect, isect_set) + else + (let fvs = + FStarC_Syntax_Free.names + x.FStarC_Syntax_Syntax.sort in + let uu___5 = + FStarC_Class_Setlike.subset () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) + (Obj.magic fvs) (Obj.magic isect_set) in + if uu___5 + then + let uu___6 = + Obj.magic + (FStarC_Class_Setlike.add () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) x + (Obj.magic isect_set)) in + ((b :: isect), uu___6) + else (isect, isect_set)))) ([], ctx_binders) v2 in + match uu___ with | (isect, uu___1) -> FStarC_Compiler_List.rev isect +let (binders_eq : + FStarC_Syntax_Syntax.binder Prims.list -> + FStarC_Syntax_Syntax.binder Prims.list -> Prims.bool) + = + fun v1 -> + fun v2 -> + ((FStarC_Compiler_List.length v1) = (FStarC_Compiler_List.length v2)) + && + (FStarC_Compiler_List.forall2 + (fun uu___ -> + fun uu___1 -> + match (uu___, uu___1) with + | ({ FStarC_Syntax_Syntax.binder_bv = a; + FStarC_Syntax_Syntax.binder_qual = uu___2; + FStarC_Syntax_Syntax.binder_positivity = uu___3; + FStarC_Syntax_Syntax.binder_attrs = uu___4;_}, + { FStarC_Syntax_Syntax.binder_bv = b; + FStarC_Syntax_Syntax.binder_qual = uu___5; + FStarC_Syntax_Syntax.binder_positivity = uu___6; + FStarC_Syntax_Syntax.binder_attrs = uu___7;_}) + -> FStarC_Syntax_Syntax.bv_eq a b) v1 v2) +let (name_exists_in_binders : + FStarC_Syntax_Syntax.bv -> + FStarC_Syntax_Syntax.binder Prims.list -> Prims.bool) + = + fun x -> + fun bs -> + FStarC_Compiler_Util.for_some + (fun uu___ -> + match uu___ with + | { FStarC_Syntax_Syntax.binder_bv = y; + FStarC_Syntax_Syntax.binder_qual = uu___1; + FStarC_Syntax_Syntax.binder_positivity = uu___2; + FStarC_Syntax_Syntax.binder_attrs = uu___3;_} -> + FStarC_Syntax_Syntax.bv_eq x y) bs +let (pat_vars : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.binder Prims.list -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.aqual) Prims.list -> + FStarC_Syntax_Syntax.binders FStar_Pervasives_Native.option) + = + fun env -> + fun ctx -> + fun args -> + let rec aux seen args1 = + match args1 with + | [] -> + FStar_Pervasives_Native.Some (FStarC_Compiler_List.rev seen) + | (arg, i)::args2 -> + let hd = sn env arg in + (match hd.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_name a -> + let uu___ = + (name_exists_in_binders a seen) || + (name_exists_in_binders a ctx) in + if uu___ + then FStar_Pervasives_Native.None + else + (let uu___2 = + FStarC_Syntax_Util.bqual_and_attrs_of_aqual i in + match uu___2 with + | (bq, attrs) -> + let uu___3 = + FStarC_Syntax_Util.parse_positivity_attributes + attrs in + (match uu___3 with + | (pq, attrs1) -> + let uu___4 = + let uu___5 = + FStarC_Syntax_Syntax.mk_binder_with_attrs + a bq pq attrs1 in + uu___5 :: seen in + aux uu___4 args2)) + | uu___ -> FStar_Pervasives_Native.None) in + aux [] args +let (string_of_match_result : match_result -> Prims.string) = + fun uu___ -> + match uu___ with + | MisMatch (d1, d2) -> + let uu___1 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_tuple2 + (FStarC_Class_Show.show_option + FStarC_Syntax_Syntax.showable_delta_depth) + (FStarC_Class_Show.show_option + FStarC_Syntax_Syntax.showable_delta_depth)) (d1, d2) in + Prims.strcat "MisMatch " uu___1 + | HeadMatch u -> + let uu___1 = FStarC_Compiler_Util.string_of_bool u in + Prims.strcat "HeadMatch " uu___1 + | FullMatch -> "FullMatch" +let (showable_match_result : match_result FStarC_Class_Show.showable) = + { FStarC_Class_Show.show = string_of_match_result } +let (head_match : match_result -> match_result) = + fun uu___ -> + match uu___ with + | MisMatch (i, j) -> MisMatch (i, j) + | HeadMatch (true) -> HeadMatch true + | uu___1 -> HeadMatch false +let (universe_has_max : + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.universe -> Prims.bool) + = + fun env -> + fun u -> + let u1 = FStarC_TypeChecker_Normalize.normalize_universe env u in + match u1 with + | FStarC_Syntax_Syntax.U_max uu___ -> true + | uu___ -> false +let rec (head_matches : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term -> match_result) + = + fun env -> + fun t1 -> + fun t2 -> + let t11 = FStarC_Syntax_Util.unmeta t1 in + let t21 = FStarC_Syntax_Util.unmeta t2 in + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_RelDelta in + if uu___1 + then + ((let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t11 in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t21 in + FStarC_Compiler_Util.print2 "head_matches %s %s\n" uu___3 uu___4); + (let uu___4 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term + t11 in + let uu___5 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term + t21 in + FStarC_Compiler_Util.print2 " %s -- %s\n" uu___4 + uu___5)) + else ()); + (match ((t11.FStarC_Syntax_Syntax.n), (t21.FStarC_Syntax_Syntax.n)) + with + | (FStarC_Syntax_Syntax.Tm_lazy + { FStarC_Syntax_Syntax.blob = uu___1; + FStarC_Syntax_Syntax.lkind = + FStarC_Syntax_Syntax.Lazy_embedding uu___2; + FStarC_Syntax_Syntax.ltyp = uu___3; + FStarC_Syntax_Syntax.rng = uu___4;_}, + uu___5) -> + let uu___6 = FStarC_Syntax_Util.unlazy t11 in + head_matches env uu___6 t21 + | (uu___1, FStarC_Syntax_Syntax.Tm_lazy + { FStarC_Syntax_Syntax.blob = uu___2; + FStarC_Syntax_Syntax.lkind = + FStarC_Syntax_Syntax.Lazy_embedding uu___3; + FStarC_Syntax_Syntax.ltyp = uu___4; + FStarC_Syntax_Syntax.rng = uu___5;_}) + -> + let uu___6 = FStarC_Syntax_Util.unlazy t21 in + head_matches env t11 uu___6 + | (FStarC_Syntax_Syntax.Tm_lazy li1, FStarC_Syntax_Syntax.Tm_lazy + li2) -> + let uu___1 = + FStarC_Class_Deq.op_Equals_Question + FStarC_Syntax_Syntax.deq_lazy_kind + li1.FStarC_Syntax_Syntax.lkind + li2.FStarC_Syntax_Syntax.lkind in + if uu___1 + then HeadMatch false + else + MisMatch + (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) + | (FStarC_Syntax_Syntax.Tm_name x, FStarC_Syntax_Syntax.Tm_name y) + -> + let uu___1 = FStarC_Syntax_Syntax.bv_eq x y in + if uu___1 + then FullMatch + else + MisMatch + (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) + | (FStarC_Syntax_Syntax.Tm_fvar f, FStarC_Syntax_Syntax.Tm_fvar g) + -> + let uu___1 = FStarC_Syntax_Syntax.fv_eq f g in + if uu___1 + then FullMatch + else + (let uu___3 = + let uu___4 = + let uu___5 = FStarC_TypeChecker_Env.fv_delta_depth env f in + FStar_Pervasives_Native.Some uu___5 in + let uu___5 = + let uu___6 = FStarC_TypeChecker_Env.fv_delta_depth env g in + FStar_Pervasives_Native.Some uu___6 in + (uu___4, uu___5) in + MisMatch uu___3) + | (FStarC_Syntax_Syntax.Tm_uinst (f, uu___1), + FStarC_Syntax_Syntax.Tm_uinst (g, uu___2)) -> + let uu___3 = head_matches env f g in head_match uu___3 + | (FStarC_Syntax_Syntax.Tm_constant (FStarC_Const.Const_reify + uu___1), FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_reify uu___2)) -> FullMatch + | (FStarC_Syntax_Syntax.Tm_constant (FStarC_Const.Const_reify + uu___1), uu___2) -> HeadMatch true + | (uu___1, FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_reify uu___2)) -> HeadMatch true + | (FStarC_Syntax_Syntax.Tm_constant c, + FStarC_Syntax_Syntax.Tm_constant d) -> + let uu___1 = FStarC_Const.eq_const c d in + if uu___1 + then FullMatch + else + MisMatch + (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) + | (FStarC_Syntax_Syntax.Tm_uvar (uv, uu___1), + FStarC_Syntax_Syntax.Tm_uvar (uv', uu___2)) -> + let uu___3 = + FStarC_Syntax_Unionfind.equiv + uv.FStarC_Syntax_Syntax.ctx_uvar_head + uv'.FStarC_Syntax_Syntax.ctx_uvar_head in + if uu___3 + then FullMatch + else + MisMatch + (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) + | (FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x; + FStarC_Syntax_Syntax.phi = uu___1;_}, + FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = y; + FStarC_Syntax_Syntax.phi = uu___2;_}) + -> + let uu___3 = + head_matches env x.FStarC_Syntax_Syntax.sort + y.FStarC_Syntax_Syntax.sort in + head_match uu___3 + | (FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x; + FStarC_Syntax_Syntax.phi = uu___1;_}, + uu___2) -> + let uu___3 = head_matches env x.FStarC_Syntax_Syntax.sort t21 in + head_match uu___3 + | (uu___1, FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x; + FStarC_Syntax_Syntax.phi = uu___2;_}) + -> + let uu___3 = head_matches env t11 x.FStarC_Syntax_Syntax.sort in + head_match uu___3 + | (FStarC_Syntax_Syntax.Tm_type uu___1, FStarC_Syntax_Syntax.Tm_type + uu___2) -> HeadMatch false + | (FStarC_Syntax_Syntax.Tm_arrow uu___1, + FStarC_Syntax_Syntax.Tm_arrow uu___2) -> HeadMatch false + | (FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = uu___1;_}, + FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head'; + FStarC_Syntax_Syntax.args = uu___2;_}) + -> let uu___3 = head_matches env head head' in head_match uu___3 + | (FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = uu___1;_}, + uu___2) -> + let uu___3 = head_matches env head t21 in head_match uu___3 + | (uu___1, FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = uu___2;_}) + -> let uu___3 = head_matches env t11 head in head_match uu___3 + | (FStarC_Syntax_Syntax.Tm_let uu___1, FStarC_Syntax_Syntax.Tm_let + uu___2) -> HeadMatch true + | (FStarC_Syntax_Syntax.Tm_match uu___1, + FStarC_Syntax_Syntax.Tm_match uu___2) -> HeadMatch true + | (FStarC_Syntax_Syntax.Tm_quoted uu___1, + FStarC_Syntax_Syntax.Tm_quoted uu___2) -> HeadMatch true + | (FStarC_Syntax_Syntax.Tm_abs uu___1, FStarC_Syntax_Syntax.Tm_abs + uu___2) -> HeadMatch true + | uu___1 -> + let maybe_dd t = + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress t in + uu___3.FStarC_Syntax_Syntax.n in + match uu___2 with + | FStarC_Syntax_Syntax.Tm_unknown -> + FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Tm_bvar uu___3 -> + FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Tm_name uu___3 -> + FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Tm_uvar uu___3 -> + FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Tm_let uu___3 -> + FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Tm_match uu___3 -> + FStar_Pervasives_Native.None + | uu___3 -> + let uu___4 = + FStarC_TypeChecker_Env.delta_depth_of_term env t in + FStar_Pervasives_Native.Some uu___4 in + let uu___2 = + let uu___3 = maybe_dd t11 in + let uu___4 = maybe_dd t21 in (uu___3, uu___4) in + MisMatch uu___2) +let (head_matches_delta : + FStarC_TypeChecker_Env.env -> + Prims.bool -> + Prims.bool -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.typ -> + (match_result * (FStarC_Syntax_Syntax.typ * + FStarC_Syntax_Syntax.typ) FStar_Pervasives_Native.option)) + = + fun env -> + fun logical -> + fun smt_ok -> + fun t1 -> + fun t2 -> + let base_steps = + FStarC_Compiler_List.op_At + (if logical + then + [FStarC_TypeChecker_Env.DontUnfoldAttr + [FStarC_Parser_Const.tac_opaque_attr]] + else []) + [FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.Weak; + FStarC_TypeChecker_Env.HNF] in + let maybe_inline t = + let head = + let uu___ = unrefine env t in + FStarC_Syntax_Util.head_of uu___ in + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_RelDelta in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + head in + FStarC_Compiler_Util.print2 "Head of %s is %s\n" uu___2 + uu___3 + else ()); + (let uu___1 = + let uu___2 = FStarC_Syntax_Util.un_uinst head in + uu___2.FStarC_Syntax_Syntax.n in + match uu___1 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let uu___2 = + FStarC_TypeChecker_Env.lookup_definition + [FStarC_TypeChecker_Env.Unfold + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.Eager_unfolding_only] env + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + (match uu___2 with + | FStar_Pervasives_Native.None -> + ((let uu___4 = + FStarC_Compiler_Effect.op_Bang dbg_RelDelta in + if uu___4 + then + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head in + FStarC_Compiler_Util.print1 + "No definition found for %s\n" uu___5 + else ()); + FStar_Pervasives_Native.None) + | FStar_Pervasives_Native.Some uu___3 -> + let basic_steps = + FStarC_Compiler_List.op_At + (if logical + then + [FStarC_TypeChecker_Env.DontUnfoldAttr + [FStarC_Parser_Const.tac_opaque_attr]] + else []) + [FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.Weak; + FStarC_TypeChecker_Env.HNF; + FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.Iota] in + let steps = + if smt_ok + then basic_steps + else + (FStarC_TypeChecker_Env.Exclude + FStarC_TypeChecker_Env.Zeta) + :: basic_steps in + let t' = + norm_with_steps + "FStarC.TypeChecker.Rel.norm_with_steps.1" steps + env t in + let uu___4 = + let uu___5 = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm env t + t' in + uu___5 = FStarC_TypeChecker_TermEqAndSimplify.Equal in + if uu___4 + then FStar_Pervasives_Native.None + else + ((let uu___7 = + FStarC_Compiler_Effect.op_Bang dbg_RelDelta in + if uu___7 + then + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t' in + FStarC_Compiler_Util.print2 + "Inlined %s to %s\n" uu___8 uu___9 + else ()); + FStar_Pervasives_Native.Some t')) + | uu___2 -> FStar_Pervasives_Native.None) in + let success d r t11 t21 = + (r, + (if d > Prims.int_zero + then FStar_Pervasives_Native.Some (t11, t21) + else FStar_Pervasives_Native.None)) in + let fail d r t11 t21 = + (r, + (if d > Prims.int_zero + then FStar_Pervasives_Native.Some (t11, t21) + else FStar_Pervasives_Native.None)) in + let made_progress t t' = + let head = + let uu___ = FStarC_Syntax_Util.head_and_args t in + FStar_Pervasives_Native.fst uu___ in + let head' = + let uu___ = FStarC_Syntax_Util.head_and_args t' in + FStar_Pervasives_Native.fst uu___ in + let uu___ = FStarC_Syntax_Util.term_eq head head' in + Prims.op_Negation uu___ in + let rec aux retry n_delta t11 t21 = + let r = head_matches env t11 t21 in + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_RelDelta in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + t11 in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + t21 in + let uu___4 = string_of_match_result r in + FStarC_Compiler_Util.print3 "head_matches (%s, %s) = %s\n" + uu___2 uu___3 uu___4 + else ()); + (let reduce_one_and_try_again d1 d2 = + let d1_greater_than_d2 = + FStarC_TypeChecker_Common.delta_depth_greater_than d1 d2 in + let uu___1 = + if d1_greater_than_d2 + then + let t1' = + normalize_refinement + ((FStarC_TypeChecker_Env.UnfoldUntil d2) :: + base_steps) env t11 in + let uu___2 = made_progress t11 t1' in (t1', t21, uu___2) + else + (let t2' = + normalize_refinement + ((FStarC_TypeChecker_Env.UnfoldUntil d1) :: + base_steps) env t21 in + let uu___3 = made_progress t21 t2' in + (t11, t2', uu___3)) in + match uu___1 with + | (t12, t22, made_progress1) -> + if made_progress1 + then aux retry (n_delta + Prims.int_one) t12 t22 + else fail n_delta r t12 t22 in + let reduce_both_and_try_again d r1 = + let uu___1 = FStarC_TypeChecker_Common.decr_delta_depth d in + match uu___1 with + | FStar_Pervasives_Native.None -> fail n_delta r1 t11 t21 + | FStar_Pervasives_Native.Some d1 -> + let t1' = + normalize_refinement + ((FStarC_TypeChecker_Env.UnfoldUntil d1) :: + base_steps) env t11 in + let t2' = + normalize_refinement + ((FStarC_TypeChecker_Env.UnfoldUntil d1) :: + base_steps) env t21 in + let uu___2 = + (made_progress t11 t1') && (made_progress t21 t2') in + if uu___2 + then aux retry (n_delta + Prims.int_one) t1' t2' + else fail n_delta r1 t11 t21 in + match r with + | MisMatch + (FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Delta_equational_at_level i), + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Delta_equational_at_level j)) + when + ((i > Prims.int_zero) || (j > Prims.int_zero)) && (i <> j) + -> + reduce_one_and_try_again + (FStarC_Syntax_Syntax.Delta_equational_at_level i) + (FStarC_Syntax_Syntax.Delta_equational_at_level j) + | MisMatch + (FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Delta_equational_at_level uu___1), + uu___2) + -> + if Prims.op_Negation retry + then fail n_delta r t11 t21 + else + (let uu___4 = + let uu___5 = maybe_inline t11 in + let uu___6 = maybe_inline t21 in (uu___5, uu___6) in + match uu___4 with + | (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None) -> + fail n_delta r t11 t21 + | (FStar_Pervasives_Native.Some t12, + FStar_Pervasives_Native.None) -> + aux false (n_delta + Prims.int_one) t12 t21 + | (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.Some t22) -> + aux false (n_delta + Prims.int_one) t11 t22 + | (FStar_Pervasives_Native.Some t12, + FStar_Pervasives_Native.Some t22) -> + aux false (n_delta + Prims.int_one) t12 t22) + | MisMatch + (uu___1, FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Delta_equational_at_level uu___2)) + -> + if Prims.op_Negation retry + then fail n_delta r t11 t21 + else + (let uu___4 = + let uu___5 = maybe_inline t11 in + let uu___6 = maybe_inline t21 in (uu___5, uu___6) in + match uu___4 with + | (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None) -> + fail n_delta r t11 t21 + | (FStar_Pervasives_Native.Some t12, + FStar_Pervasives_Native.None) -> + aux false (n_delta + Prims.int_one) t12 t21 + | (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.Some t22) -> + aux false (n_delta + Prims.int_one) t11 t22 + | (FStar_Pervasives_Native.Some t12, + FStar_Pervasives_Native.Some t22) -> + aux false (n_delta + Prims.int_one) t12 t22) + | MisMatch + (FStar_Pervasives_Native.Some d1, + FStar_Pervasives_Native.Some d2) + when d1 = d2 -> reduce_both_and_try_again d1 r + | MisMatch + (FStar_Pervasives_Native.Some d1, + FStar_Pervasives_Native.Some d2) + -> reduce_one_and_try_again d1 d2 + | MisMatch uu___1 -> fail n_delta r t11 t21 + | uu___1 -> success n_delta r t11 t21) in + let r = aux true Prims.int_zero t1 t2 in + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_RelDelta in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t2 in + let uu___4 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_tuple2 showable_match_result + (FStarC_Class_Show.show_option + (FStarC_Class_Show.show_tuple2 + FStarC_Syntax_Print.showable_term + FStarC_Syntax_Print.showable_term))) r in + FStarC_Compiler_Util.print3 + "head_matches_delta (%s, %s) = %s\n" uu___2 uu___3 uu___4 + else ()); + r +let (kind_type : + FStarC_Syntax_Syntax.binders -> + FStarC_Compiler_Range_Type.range -> FStarC_Syntax_Syntax.typ) + = + fun binders -> + fun r -> + let uu___ = FStarC_Syntax_Util.type_u () in + FStar_Pervasives_Native.fst uu___ +let (rank_t_num : FStarC_TypeChecker_Common.rank_t -> Prims.int) = + fun uu___ -> + match uu___ with + | FStarC_TypeChecker_Common.Rigid_rigid -> Prims.int_zero + | FStarC_TypeChecker_Common.Flex_rigid_eq -> Prims.int_one + | FStarC_TypeChecker_Common.Flex_flex_pattern_eq -> (Prims.of_int (2)) + | FStarC_TypeChecker_Common.Flex_rigid -> (Prims.of_int (3)) + | FStarC_TypeChecker_Common.Rigid_flex -> (Prims.of_int (4)) + | FStarC_TypeChecker_Common.Flex_flex -> (Prims.of_int (5)) +let (rank_leq : + FStarC_TypeChecker_Common.rank_t -> + FStarC_TypeChecker_Common.rank_t -> Prims.bool) + = fun r1 -> fun r2 -> (rank_t_num r1) <= (rank_t_num r2) +let (rank_less_than : + FStarC_TypeChecker_Common.rank_t -> + FStarC_TypeChecker_Common.rank_t -> Prims.bool) + = fun r1 -> fun r2 -> (r1 <> r2) && ((rank_t_num r1) <= (rank_t_num r2)) +let (compress_tprob : + worklist -> + FStarC_Syntax_Syntax.typ FStarC_TypeChecker_Common.problem -> + FStarC_Syntax_Syntax.term FStarC_TypeChecker_Common.problem) + = + fun wl -> + fun p -> + let env = p_env wl (FStarC_TypeChecker_Common.TProb p) in + let uu___ = whnf env p.FStarC_TypeChecker_Common.lhs in + let uu___1 = whnf env p.FStarC_TypeChecker_Common.rhs in + { + FStarC_TypeChecker_Common.pid = (p.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = uu___; + FStarC_TypeChecker_Common.relation = + (p.FStarC_TypeChecker_Common.relation); + FStarC_TypeChecker_Common.rhs = uu___1; + FStarC_TypeChecker_Common.element = + (p.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (p.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar = + (p.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (p.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = (p.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = (p.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = + (p.FStarC_TypeChecker_Common.logical) + } +let (compress_cprob : + worklist -> + FStarC_Syntax_Syntax.comp FStarC_TypeChecker_Common.problem -> + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax + FStarC_TypeChecker_Common.problem) + = + fun wl -> + fun p -> + let whnf_c env c = + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total ty -> + let uu___ = whnf env ty in FStarC_Syntax_Syntax.mk_Total uu___ + | uu___ -> c in + let env = p_env wl (FStarC_TypeChecker_Common.CProb p) in + let uu___ = whnf_c env p.FStarC_TypeChecker_Common.lhs in + let uu___1 = whnf_c env p.FStarC_TypeChecker_Common.rhs in + { + FStarC_TypeChecker_Common.pid = (p.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = uu___; + FStarC_TypeChecker_Common.relation = + (p.FStarC_TypeChecker_Common.relation); + FStarC_TypeChecker_Common.rhs = uu___1; + FStarC_TypeChecker_Common.element = + (p.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (p.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar = + (p.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (p.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = (p.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = (p.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = + (p.FStarC_TypeChecker_Common.logical) + } +let (compress_prob : + worklist -> + FStarC_TypeChecker_Common.prob -> FStarC_TypeChecker_Common.prob) + = + fun wl -> + fun p -> + match p with + | FStarC_TypeChecker_Common.TProb p1 -> + let uu___ = compress_tprob wl p1 in + FStarC_TypeChecker_Common.TProb uu___ + | FStarC_TypeChecker_Common.CProb p1 -> + let uu___ = compress_cprob wl p1 in + FStarC_TypeChecker_Common.CProb uu___ +let (rank : + worklist -> + FStarC_TypeChecker_Common.prob -> + (FStarC_TypeChecker_Common.rank_t * FStarC_TypeChecker_Common.prob)) + = + fun wl -> + fun pr -> + let prob = let uu___ = compress_prob wl pr in maybe_invert_p uu___ in + match prob with + | FStarC_TypeChecker_Common.TProb tp -> + let uu___ = + FStarC_Syntax_Util.head_and_args tp.FStarC_TypeChecker_Common.lhs in + (match uu___ with + | (lh, lhs_args) -> + let uu___1 = + FStarC_Syntax_Util.head_and_args + tp.FStarC_TypeChecker_Common.rhs in + (match uu___1 with + | (rh, rhs_args) -> + let uu___2 = + match ((lh.FStarC_Syntax_Syntax.n), + (rh.FStarC_Syntax_Syntax.n)) + with + | (FStarC_Syntax_Syntax.Tm_uvar uu___3, + FStarC_Syntax_Syntax.Tm_uvar uu___4) -> + (match (lhs_args, rhs_args) with + | ([], []) when + tp.FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.EQ + -> + (FStarC_TypeChecker_Common.Flex_flex_pattern_eq, + tp) + | uu___5 -> + (FStarC_TypeChecker_Common.Flex_flex, tp)) + | (FStarC_Syntax_Syntax.Tm_uvar uu___3, uu___4) when + tp.FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.EQ + -> (FStarC_TypeChecker_Common.Flex_rigid_eq, tp) + | (uu___3, FStarC_Syntax_Syntax.Tm_uvar uu___4) when + tp.FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.EQ + -> (FStarC_TypeChecker_Common.Flex_rigid_eq, tp) + | (FStarC_Syntax_Syntax.Tm_uvar uu___3, + FStarC_Syntax_Syntax.Tm_arrow uu___4) -> + (FStarC_TypeChecker_Common.Flex_rigid_eq, + { + FStarC_TypeChecker_Common.pid = + (tp.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = + (tp.FStarC_TypeChecker_Common.lhs); + FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.EQ; + FStarC_TypeChecker_Common.rhs = + (tp.FStarC_TypeChecker_Common.rhs); + FStarC_TypeChecker_Common.element = + (tp.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (tp.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar = + (tp.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (tp.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = + (tp.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (tp.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = + (tp.FStarC_TypeChecker_Common.logical) + }) + | (FStarC_Syntax_Syntax.Tm_uvar uu___3, + FStarC_Syntax_Syntax.Tm_type uu___4) -> + (FStarC_TypeChecker_Common.Flex_rigid_eq, + { + FStarC_TypeChecker_Common.pid = + (tp.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = + (tp.FStarC_TypeChecker_Common.lhs); + FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.EQ; + FStarC_TypeChecker_Common.rhs = + (tp.FStarC_TypeChecker_Common.rhs); + FStarC_TypeChecker_Common.element = + (tp.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (tp.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar = + (tp.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (tp.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = + (tp.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (tp.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = + (tp.FStarC_TypeChecker_Common.logical) + }) + | (FStarC_Syntax_Syntax.Tm_type uu___3, + FStarC_Syntax_Syntax.Tm_uvar uu___4) -> + (FStarC_TypeChecker_Common.Flex_rigid_eq, + { + FStarC_TypeChecker_Common.pid = + (tp.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = + (tp.FStarC_TypeChecker_Common.lhs); + FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.EQ; + FStarC_TypeChecker_Common.rhs = + (tp.FStarC_TypeChecker_Common.rhs); + FStarC_TypeChecker_Common.element = + (tp.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (tp.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar = + (tp.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (tp.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = + (tp.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (tp.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = + (tp.FStarC_TypeChecker_Common.logical) + }) + | (uu___3, FStarC_Syntax_Syntax.Tm_uvar uu___4) -> + (FStarC_TypeChecker_Common.Rigid_flex, tp) + | (FStarC_Syntax_Syntax.Tm_uvar uu___3, uu___4) -> + (FStarC_TypeChecker_Common.Flex_rigid, tp) + | (uu___3, FStarC_Syntax_Syntax.Tm_uvar uu___4) -> + (FStarC_TypeChecker_Common.Rigid_flex, tp) + | (uu___3, uu___4) -> + (FStarC_TypeChecker_Common.Rigid_rigid, tp) in + (match uu___2 with + | (rank1, tp1) -> + (rank1, + (FStarC_TypeChecker_Common.TProb + { + FStarC_TypeChecker_Common.pid = + (tp1.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = + (tp1.FStarC_TypeChecker_Common.lhs); + FStarC_TypeChecker_Common.relation = + (tp1.FStarC_TypeChecker_Common.relation); + FStarC_TypeChecker_Common.rhs = + (tp1.FStarC_TypeChecker_Common.rhs); + FStarC_TypeChecker_Common.element = + (tp1.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (tp1.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar + = + (tp1.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (tp1.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = + (tp1.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (FStar_Pervasives_Native.Some rank1); + FStarC_TypeChecker_Common.logical = + (tp1.FStarC_TypeChecker_Common.logical) + }))))) + | FStarC_TypeChecker_Common.CProb cp -> + (FStarC_TypeChecker_Common.Rigid_rigid, + (FStarC_TypeChecker_Common.CProb + { + FStarC_TypeChecker_Common.pid = + (cp.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = + (cp.FStarC_TypeChecker_Common.lhs); + FStarC_TypeChecker_Common.relation = + (cp.FStarC_TypeChecker_Common.relation); + FStarC_TypeChecker_Common.rhs = + (cp.FStarC_TypeChecker_Common.rhs); + FStarC_TypeChecker_Common.element = + (cp.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (cp.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar = + (cp.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (cp.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = + (cp.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (FStar_Pervasives_Native.Some + FStarC_TypeChecker_Common.Rigid_rigid); + FStarC_TypeChecker_Common.logical = + (cp.FStarC_TypeChecker_Common.logical) + })) +let (next_prob : + worklist -> + (FStarC_TypeChecker_Common.prob * FStarC_TypeChecker_Common.prob + Prims.list * FStarC_TypeChecker_Common.rank_t) + FStar_Pervasives_Native.option) + = + fun wl -> + let rec aux uu___ probs = + match uu___ with + | (min_rank, min, out) -> + (match probs with + | [] -> + (match (min, min_rank) with + | (FStar_Pervasives_Native.Some p, + FStar_Pervasives_Native.Some r) -> + FStar_Pervasives_Native.Some (p, out, r) + | uu___1 -> FStar_Pervasives_Native.None) + | hd::tl -> + let uu___1 = rank wl hd in + (match uu___1 with + | (rank1, hd1) -> + if rank_leq rank1 FStarC_TypeChecker_Common.Flex_rigid_eq + then + (match min with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.Some + (hd1, (FStarC_Compiler_List.op_At out tl), + rank1) + | FStar_Pervasives_Native.Some m -> + FStar_Pervasives_Native.Some + (hd1, + (FStarC_Compiler_List.op_At out (m :: tl)), + rank1)) + else + (let uu___3 = + (min_rank = FStar_Pervasives_Native.None) || + (let uu___4 = FStarC_Compiler_Option.get min_rank in + rank_less_than rank1 uu___4) in + if uu___3 + then + match min with + | FStar_Pervasives_Native.None -> + aux + ((FStar_Pervasives_Native.Some rank1), + (FStar_Pervasives_Native.Some hd1), out) tl + | FStar_Pervasives_Native.Some m -> + aux + ((FStar_Pervasives_Native.Some rank1), + (FStar_Pervasives_Native.Some hd1), (m :: + out)) tl + else aux (min_rank, min, (hd1 :: out)) tl))) in + aux (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None, []) + wl.attempting +let (flex_prob_closing : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.binders -> + FStarC_TypeChecker_Common.prob -> Prims.bool) + = + fun tcenv -> + fun bs -> + fun p -> + let flex_will_be_closed t = + let uu___ = FStarC_Syntax_Util.head_and_args t in + match uu___ with + | (hd, uu___1) -> + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress hd in + uu___3.FStarC_Syntax_Syntax.n in + (match uu___2 with + | FStarC_Syntax_Syntax.Tm_uvar (u, uu___3) -> + FStarC_Compiler_Util.for_some + (fun uu___4 -> + match uu___4 with + | { FStarC_Syntax_Syntax.binder_bv = y; + FStarC_Syntax_Syntax.binder_qual = uu___5; + FStarC_Syntax_Syntax.binder_positivity = uu___6; + FStarC_Syntax_Syntax.binder_attrs = uu___7;_} -> + FStarC_Compiler_Util.for_some + (fun uu___8 -> + match uu___8 with + | { FStarC_Syntax_Syntax.binder_bv = x; + FStarC_Syntax_Syntax.binder_qual = + uu___9; + FStarC_Syntax_Syntax.binder_positivity = + uu___10; + FStarC_Syntax_Syntax.binder_attrs = + uu___11;_} + -> FStarC_Syntax_Syntax.bv_eq x y) bs) + u.FStarC_Syntax_Syntax.ctx_uvar_binders + | uu___3 -> false) in + let wl = empty_worklist tcenv in + let uu___ = rank wl p in + match uu___ with + | (r, p1) -> + (match p1 with + | FStarC_TypeChecker_Common.CProb uu___1 -> true + | FStarC_TypeChecker_Common.TProb p2 -> + (match r with + | FStarC_TypeChecker_Common.Rigid_rigid -> true + | FStarC_TypeChecker_Common.Flex_rigid_eq -> true + | FStarC_TypeChecker_Common.Flex_flex_pattern_eq -> true + | FStarC_TypeChecker_Common.Flex_rigid -> + flex_will_be_closed p2.FStarC_TypeChecker_Common.lhs + | FStarC_TypeChecker_Common.Rigid_flex -> + flex_will_be_closed p2.FStarC_TypeChecker_Common.rhs + | FStarC_TypeChecker_Common.Flex_flex -> + (p2.FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.EQ) + && + ((flex_will_be_closed + p2.FStarC_TypeChecker_Common.lhs) + || + (flex_will_be_closed + p2.FStarC_TypeChecker_Common.rhs)))) +type univ_eq_sol = + | UDeferred of worklist + | USolved of worklist + | UFailed of lstring +let (uu___is_UDeferred : univ_eq_sol -> Prims.bool) = + fun projectee -> + match projectee with | UDeferred _0 -> true | uu___ -> false +let (__proj__UDeferred__item___0 : univ_eq_sol -> worklist) = + fun projectee -> match projectee with | UDeferred _0 -> _0 +let (uu___is_USolved : univ_eq_sol -> Prims.bool) = + fun projectee -> match projectee with | USolved _0 -> true | uu___ -> false +let (__proj__USolved__item___0 : univ_eq_sol -> worklist) = + fun projectee -> match projectee with | USolved _0 -> _0 +let (uu___is_UFailed : univ_eq_sol -> Prims.bool) = + fun projectee -> match projectee with | UFailed _0 -> true | uu___ -> false +let (__proj__UFailed__item___0 : univ_eq_sol -> lstring) = + fun projectee -> match projectee with | UFailed _0 -> _0 +let (ufailed_simple : Prims.string -> univ_eq_sol) = + fun s -> let uu___ = FStarC_Thunk.mkv s in UFailed uu___ +let (ufailed_thunk : (unit -> Prims.string) -> univ_eq_sol) = + fun s -> let uu___ = mklstr s in UFailed uu___ +let rec (really_solve_universe_eq : + Prims.int -> + worklist -> + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.universe -> univ_eq_sol) + = + fun pid_orig -> + fun wl -> + fun u1 -> + fun u2 -> + let u11 = + FStarC_TypeChecker_Normalize.normalize_universe wl.tcenv u1 in + let u21 = + FStarC_TypeChecker_Normalize.normalize_universe wl.tcenv u2 in + let rec occurs_univ v1 u = + match u with + | FStarC_Syntax_Syntax.U_max us -> + FStarC_Compiler_Util.for_some + (fun u3 -> + let uu___ = FStarC_Syntax_Util.univ_kernel u3 in + match uu___ with + | (k, uu___1) -> + (match k with + | FStarC_Syntax_Syntax.U_unif v2 -> + FStarC_Syntax_Unionfind.univ_equiv v1 v2 + | uu___2 -> false)) us + | uu___ -> occurs_univ v1 (FStarC_Syntax_Syntax.U_max [u]) in + let rec filter_out_common_univs u12 u22 = + let common_elts = + FStarC_Compiler_List.fold_left + (fun uvs -> + fun uv1 -> + let uu___ = + FStarC_Compiler_List.existsML + (fun uv2 -> FStarC_Syntax_Util.eq_univs uv1 uv2) u22 in + if uu___ then uv1 :: uvs else uvs) [] u12 in + let filter = + FStarC_Compiler_List.filter + (fun u -> + let uu___ = + FStarC_Compiler_List.existsML + (fun u' -> FStarC_Syntax_Util.eq_univs u u') + common_elts in + Prims.op_Negation uu___) in + let uu___ = filter u12 in + let uu___1 = filter u22 in (uu___, uu___1) in + let try_umax_components u12 u22 msg = + if Prims.op_Negation wl.umax_heuristic_ok + then ufailed_simple "Unable to unify universe terms with umax" + else + (match (u12, u22) with + | (FStarC_Syntax_Syntax.U_max us1, FStarC_Syntax_Syntax.U_max + us2) -> + let uu___1 = filter_out_common_univs us1 us2 in + (match uu___1 with + | (us11, us21) -> + if + (FStarC_Compiler_List.length us11) = + (FStarC_Compiler_List.length us21) + then + let rec aux wl1 us12 us22 = + match (us12, us22) with + | (u13::us13, u23::us23) -> + let uu___2 = + really_solve_universe_eq pid_orig wl1 u13 + u23 in + (match uu___2 with + | USolved wl2 -> aux wl2 us13 us23 + | failed -> failed) + | uu___2 -> USolved wl1 in + aux wl us11 us21 + else + ufailed_thunk + (fun uu___3 -> + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_univ u12 in + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_univ u22 in + FStarC_Compiler_Util.format2 + "Unable to unify universes: %s and %s" + uu___4 uu___5)) + | (FStarC_Syntax_Syntax.U_max us, u') -> + let rec aux wl1 us1 = + match us1 with + | [] -> USolved wl1 + | u::us2 -> + let uu___1 = + really_solve_universe_eq pid_orig wl1 u u' in + (match uu___1 with + | USolved wl2 -> aux wl2 us2 + | failed -> failed) in + aux wl us + | (u', FStarC_Syntax_Syntax.U_max us) -> + let rec aux wl1 us1 = + match us1 with + | [] -> USolved wl1 + | u::us2 -> + let uu___1 = + really_solve_universe_eq pid_orig wl1 u u' in + (match uu___1 with + | USolved wl2 -> aux wl2 us2 + | failed -> failed) in + aux wl us + | uu___1 -> + ufailed_thunk + (fun uu___2 -> + let uu___3 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_univ u12 in + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_univ u22 in + FStarC_Compiler_Util.format3 + "Unable to unify universes: %s and %s (%s)" uu___3 + uu___4 msg)) in + match (u11, u21) with + | (FStarC_Syntax_Syntax.U_bvar uu___, uu___1) -> + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_univ + u11 in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_univ + u21 in + FStarC_Compiler_Util.format2 + "Impossible: found an de Bruijn universe variable or unknown universe: %s, %s" + uu___3 uu___4 in + failwith uu___2 + | (FStarC_Syntax_Syntax.U_unknown, uu___) -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_univ + u11 in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_univ + u21 in + FStarC_Compiler_Util.format2 + "Impossible: found an de Bruijn universe variable or unknown universe: %s, %s" + uu___2 uu___3 in + failwith uu___1 + | (uu___, FStarC_Syntax_Syntax.U_bvar uu___1) -> + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_univ + u11 in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_univ + u21 in + FStarC_Compiler_Util.format2 + "Impossible: found an de Bruijn universe variable or unknown universe: %s, %s" + uu___3 uu___4 in + failwith uu___2 + | (uu___, FStarC_Syntax_Syntax.U_unknown) -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_univ + u11 in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_univ + u21 in + FStarC_Compiler_Util.format2 + "Impossible: found an de Bruijn universe variable or unknown universe: %s, %s" + uu___2 uu___3 in + failwith uu___1 + | (FStarC_Syntax_Syntax.U_name x, FStarC_Syntax_Syntax.U_name y) -> + let uu___ = + let uu___1 = FStarC_Ident.string_of_id x in + let uu___2 = FStarC_Ident.string_of_id y in uu___1 = uu___2 in + if uu___ + then USolved wl + else ufailed_simple "Incompatible universes" + | (FStarC_Syntax_Syntax.U_zero, FStarC_Syntax_Syntax.U_zero) -> + USolved wl + | (FStarC_Syntax_Syntax.U_succ u12, FStarC_Syntax_Syntax.U_succ + u22) -> really_solve_universe_eq pid_orig wl u12 u22 + | (FStarC_Syntax_Syntax.U_unif v1, FStarC_Syntax_Syntax.U_unif v2) + -> + let uu___ = FStarC_Syntax_Unionfind.univ_equiv v1 v2 in + if uu___ + then USolved wl + else + (let wl1 = + extend_universe_solution pid_orig [UNIV (v1, u21)] wl in + USolved wl1) + | (FStarC_Syntax_Syntax.U_unif v1, u) -> + let u3 = norm_univ wl u in + let uu___ = occurs_univ v1 u3 in + if uu___ + then + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_univ + (FStarC_Syntax_Syntax.U_unif v1) in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_univ + u3 in + FStarC_Compiler_Util.format2 + "Failed occurs check: %s occurs in %s" uu___2 uu___3 in + try_umax_components u11 u21 uu___1 + else + (let uu___2 = + extend_universe_solution pid_orig [UNIV (v1, u3)] wl in + USolved uu___2) + | (u, FStarC_Syntax_Syntax.U_unif v1) -> + let u3 = norm_univ wl u in + let uu___ = occurs_univ v1 u3 in + if uu___ + then + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_univ + (FStarC_Syntax_Syntax.U_unif v1) in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_univ + u3 in + FStarC_Compiler_Util.format2 + "Failed occurs check: %s occurs in %s" uu___2 uu___3 in + try_umax_components u11 u21 uu___1 + else + (let uu___2 = + extend_universe_solution pid_orig [UNIV (v1, u3)] wl in + USolved uu___2) + | (FStarC_Syntax_Syntax.U_max uu___, uu___1) -> + if wl.defer_ok = DeferAny + then UDeferred wl + else + (let u12 = norm_univ wl u11 in + let u22 = norm_univ wl u21 in + let uu___3 = FStarC_Syntax_Util.eq_univs u12 u22 in + if uu___3 + then USolved wl + else try_umax_components u12 u22 "") + | (uu___, FStarC_Syntax_Syntax.U_max uu___1) -> + if wl.defer_ok = DeferAny + then UDeferred wl + else + (let u12 = norm_univ wl u11 in + let u22 = norm_univ wl u21 in + let uu___3 = FStarC_Syntax_Util.eq_univs u12 u22 in + if uu___3 + then USolved wl + else try_umax_components u12 u22 "") + | (FStarC_Syntax_Syntax.U_succ uu___, FStarC_Syntax_Syntax.U_zero) + -> ufailed_simple "Incompatible universes" + | (FStarC_Syntax_Syntax.U_succ uu___, FStarC_Syntax_Syntax.U_name + uu___1) -> ufailed_simple "Incompatible universes" + | (FStarC_Syntax_Syntax.U_zero, FStarC_Syntax_Syntax.U_succ uu___) + -> ufailed_simple "Incompatible universes" + | (FStarC_Syntax_Syntax.U_zero, FStarC_Syntax_Syntax.U_name uu___) + -> ufailed_simple "Incompatible universes" + | (FStarC_Syntax_Syntax.U_name uu___, FStarC_Syntax_Syntax.U_succ + uu___1) -> ufailed_simple "Incompatible universes" + | (FStarC_Syntax_Syntax.U_name uu___, FStarC_Syntax_Syntax.U_zero) + -> ufailed_simple "Incompatible universes" +let (solve_universe_eq : + Prims.int -> + worklist -> + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.universe -> univ_eq_sol) + = + fun orig -> + fun wl -> + fun u1 -> + fun u2 -> + if (wl.tcenv).FStarC_TypeChecker_Env.lax_universes + then USolved wl + else really_solve_universe_eq orig wl u1 u2 +let match_num_binders : + 'a 'b . + ('a Prims.list * ('a Prims.list -> 'b)) -> + ('a Prims.list * ('a Prims.list -> 'b)) -> + (('a Prims.list * 'b) * ('a Prims.list * 'b)) + = + fun bc1 -> + fun bc2 -> + let uu___ = bc1 in + match uu___ with + | (bs1, mk_cod1) -> + let uu___1 = bc2 in + (match uu___1 with + | (bs2, mk_cod2) -> + let rec aux bs11 bs21 = + match (bs11, bs21) with + | (x::xs, y::ys) -> + let uu___2 = aux xs ys in + (match uu___2 with + | ((xs1, xr), (ys1, yr)) -> + (((x :: xs1), xr), ((y :: ys1), yr))) + | (xs, ys) -> + let uu___2 = let uu___3 = mk_cod1 xs in ([], uu___3) in + let uu___3 = let uu___4 = mk_cod2 ys in ([], uu___4) in + (uu___2, uu___3) in + aux bs1 bs2) +let (guard_of_prob : + worklist -> + tprob -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> (FStarC_Syntax_Syntax.term * worklist)) + = + fun wl -> + fun problem -> + fun t1 -> + fun t2 -> + def_check_prob "guard_of_prob" + (FStarC_TypeChecker_Common.TProb problem); + (let env = p_env wl (FStarC_TypeChecker_Common.TProb problem) in + let has_type_guard t11 t21 = + match problem.FStarC_TypeChecker_Common.element with + | FStar_Pervasives_Native.Some t -> + let uu___1 = FStarC_Syntax_Syntax.bv_to_name t in + FStarC_Syntax_Util.mk_has_type t11 uu___1 t21 + | FStar_Pervasives_Native.None -> + let x = + FStarC_Syntax_Syntax.new_bv FStar_Pervasives_Native.None + t11 in + (FStarC_Defensive.def_check_scoped + FStarC_TypeChecker_Env.hasBinders_env + FStarC_Class_Binders.hasNames_term + FStarC_Syntax_Print.pretty_term + t11.FStarC_Syntax_Syntax.pos "guard_of_prob.universe_of" + env t11; + (let u_x = env.FStarC_TypeChecker_Env.universe_of env t11 in + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.bv_to_name x in + FStarC_Syntax_Util.mk_has_type t11 uu___3 t21 in + FStarC_Syntax_Util.mk_forall u_x x uu___2)) in + match problem.FStarC_TypeChecker_Common.relation with + | FStarC_TypeChecker_Common.EQ -> + mk_eq2 wl (FStarC_TypeChecker_Common.TProb problem) t1 t2 + | FStarC_TypeChecker_Common.SUB -> + let uu___1 = has_type_guard t1 t2 in (uu___1, wl) + | FStarC_TypeChecker_Common.SUBINV -> + let uu___1 = has_type_guard t2 t1 in (uu___1, wl)) +let (is_flex_pat : flex_t -> Prims.bool) = + fun uu___ -> + match uu___ with | Flex (uu___1, uu___2, []) -> true | uu___1 -> false +let (should_defer_flex_to_user_tac : worklist -> flex_t -> Prims.bool) = + fun wl -> + fun f -> + let uu___ = f in + match uu___ with + | Flex (uu___1, u, uu___2) -> + let b = + FStarC_TypeChecker_DeferredImplicits.should_defer_uvar_to_user_tac + wl.tcenv u in + ((let uu___4 = + FStarC_Compiler_Effect.op_Bang dbg_ResolveImplicitsHook in + if uu___4 + then + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_ctxu u in + let uu___6 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) b in + let uu___7 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + (wl.tcenv).FStarC_TypeChecker_Env.enable_defer_to_tac in + FStarC_Compiler_Util.print3 + "Rel.should_defer_flex_to_user_tac for %s returning %s (env.enable_defer_to_tac: %s)\n" + uu___5 uu___6 uu___7 + else ()); + b) +let (quasi_pattern : + FStarC_TypeChecker_Env.env -> + flex_t -> + (FStarC_Syntax_Syntax.binders * FStarC_Syntax_Syntax.typ) + FStar_Pervasives_Native.option) + = + fun env -> + fun f -> + let uu___ = f in + match uu___ with + | Flex (uu___1, ctx_uvar, args) -> + let t_hd = FStarC_Syntax_Util.ctx_uvar_typ ctx_uvar in + let ctx = ctx_uvar.FStarC_Syntax_Syntax.ctx_uvar_binders in + let name_exists_in x bs = + FStarC_Compiler_Util.for_some + (fun uu___2 -> + match uu___2 with + | { FStarC_Syntax_Syntax.binder_bv = y; + FStarC_Syntax_Syntax.binder_qual = uu___3; + FStarC_Syntax_Syntax.binder_positivity = uu___4; + FStarC_Syntax_Syntax.binder_attrs = uu___5;_} -> + FStarC_Syntax_Syntax.bv_eq x y) bs in + let rec aux pat_binders formals t_res args1 = + match (formals, args1) with + | ([], []) -> + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Syntax.mk_Total t_res in + FStarC_Syntax_Util.arrow formals uu___4 in + ((FStarC_Compiler_List.rev pat_binders), uu___3) in + FStar_Pervasives_Native.Some uu___2 + | (uu___2, []) -> + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.mk_Total t_res in + FStarC_Syntax_Util.arrow formals uu___5 in + ((FStarC_Compiler_List.rev pat_binders), uu___4) in + FStar_Pervasives_Native.Some uu___3 + | (fml::formals1, (a, a_imp)::args2) -> + let uu___2 = + ((fml.FStarC_Syntax_Syntax.binder_bv), + (fml.FStarC_Syntax_Syntax.binder_qual)) in + (match uu___2 with + | (formal, formal_imp) -> + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.compress a in + uu___4.FStarC_Syntax_Syntax.n in + (match uu___3 with + | FStarC_Syntax_Syntax.Tm_name x -> + let uu___4 = + (name_exists_in x ctx) || + (name_exists_in x pat_binders) in + if uu___4 + then aux (fml :: pat_binders) formals1 t_res args2 + else + (let x1 = + { + FStarC_Syntax_Syntax.ppname = + (x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (x.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = + (formal.FStarC_Syntax_Syntax.sort) + } in + let subst = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Syntax.bv_to_name x1 in + (formal, uu___8) in + FStarC_Syntax_Syntax.NT uu___7 in + [uu___6] in + let formals2 = + FStarC_Syntax_Subst.subst_binders subst + formals1 in + let t_res1 = + FStarC_Syntax_Subst.subst subst t_res in + let uu___6 = + FStarC_Syntax_Util.bqual_and_attrs_of_aqual + a_imp in + match uu___6 with + | (q, uu___7) -> + let uu___8 = + let uu___9 = + FStarC_Syntax_Syntax.mk_binder_with_attrs + { + FStarC_Syntax_Syntax.ppname = + (x1.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (x1.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = + (formal.FStarC_Syntax_Syntax.sort) + } q + fml.FStarC_Syntax_Syntax.binder_positivity + fml.FStarC_Syntax_Syntax.binder_attrs in + uu___9 :: pat_binders in + aux uu___8 formals2 t_res1 args2) + | uu___4 -> + aux (fml :: pat_binders) formals1 t_res args2)) + | ([], args2) -> + let uu___2 = + let uu___3 = + FStarC_TypeChecker_Normalize.unfold_whnf env t_res in + FStarC_Syntax_Util.arrow_formals uu___3 in + (match uu___2 with + | (more_formals, t_res1) -> + (match more_formals with + | [] -> FStar_Pervasives_Native.None + | uu___3 -> aux pat_binders more_formals t_res1 args2)) in + (match args with + | [] -> FStar_Pervasives_Native.Some ([], t_hd) + | uu___2 -> + let uu___3 = FStarC_Syntax_Util.arrow_formals t_hd in + (match uu___3 with + | (formals, t_res) -> aux [] formals t_res args)) +let (run_meta_arg_tac : + FStarC_TypeChecker_Env.env_t -> + FStarC_Syntax_Syntax.ctx_uvar -> FStarC_Syntax_Syntax.term) + = + fun env -> + fun ctx_u -> + match ctx_u.FStarC_Syntax_Syntax.ctx_uvar_meta with + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Ctx_uvar_meta_tac + tau) -> + let env1 = + { + FStarC_TypeChecker_Env.solver = + (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (ctx_u.FStarC_Syntax_Syntax.ctx_uvar_gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env.FStarC_TypeChecker_Env.missing_decl) + } in + ((let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_Tac in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_ctxu + ctx_u in + FStarC_Compiler_Util.print1 "Running tactic for meta-arg %s\n" + uu___2 + else ()); + FStarC_Errors.with_ctx "Running tactic for meta-arg" + (fun uu___1 -> + let uu___2 = FStarC_Syntax_Util.ctx_uvar_typ ctx_u in + env1.FStarC_TypeChecker_Env.synth_hook env1 uu___2 tau)) + | uu___ -> + failwith + "run_meta_arg_tac must have been called with a uvar that has a meta tac" +let (simplify_vc : + Prims.bool -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun full_norm_allowed -> + fun env -> + fun t -> + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_Simplification in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.print1 "Simplifying guard %s\n" uu___2 + else ()); + (let steps = + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.Simplify; + FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.Exclude FStarC_TypeChecker_Env.Zeta] in + let steps1 = + if full_norm_allowed + then steps + else FStarC_TypeChecker_Env.NoFullNorm :: steps in + let t' = + norm_with_steps "FStarC.TypeChecker.Rel.simplify_vc" steps1 env t in + (let uu___2 = FStarC_Compiler_Effect.op_Bang dbg_Simplification in + if uu___2 + then + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t' in + FStarC_Compiler_Util.print1 "Simplified guard to %s\n" uu___3 + else ()); + t') +let (__simplify_guard : + Prims.bool -> + FStarC_TypeChecker_Env.env -> + FStarC_TypeChecker_Common.guard_t -> FStarC_TypeChecker_Common.guard_t) + = + fun full_norm_allowed -> + fun env -> + fun g -> + match g.FStarC_TypeChecker_Common.guard_f with + | FStarC_TypeChecker_Common.Trivial -> g + | FStarC_TypeChecker_Common.NonTrivial f -> + let f1 = simplify_vc full_norm_allowed env f in + let f2 = FStarC_TypeChecker_Common.check_trivial f1 in + { + FStarC_TypeChecker_Common.guard_f = f2; + FStarC_TypeChecker_Common.deferred_to_tac = + (g.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (g.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (g.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = + (g.FStarC_TypeChecker_Common.implicits) + } +let (simplify_guard : + FStarC_TypeChecker_Env.env -> + FStarC_TypeChecker_Common.guard_t -> FStarC_TypeChecker_Common.guard_t) + = + fun env -> + fun g -> + match g.FStarC_TypeChecker_Common.guard_f with + | FStarC_TypeChecker_Common.Trivial -> g + | FStarC_TypeChecker_Common.NonTrivial f -> + let f1 = simplify_vc false env f in + let f2 = FStarC_TypeChecker_Common.check_trivial f1 in + { + FStarC_TypeChecker_Common.guard_f = f2; + FStarC_TypeChecker_Common.deferred_to_tac = + (g.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (g.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (g.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = + (g.FStarC_TypeChecker_Common.implicits) + } +let (simplify_guard_full_norm : + FStarC_TypeChecker_Env.env -> + FStarC_TypeChecker_Common.guard_t -> FStarC_TypeChecker_Common.guard_t) + = + fun env -> + fun g -> + match g.FStarC_TypeChecker_Common.guard_f with + | FStarC_TypeChecker_Common.Trivial -> g + | FStarC_TypeChecker_Common.NonTrivial f -> + let f1 = simplify_vc true env f in + let f2 = FStarC_TypeChecker_Common.check_trivial f1 in + { + FStarC_TypeChecker_Common.guard_f = f2; + FStarC_TypeChecker_Common.deferred_to_tac = + (g.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (g.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (g.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = + (g.FStarC_TypeChecker_Common.implicits) + } +let (apply_substitutive_indexed_subcomp : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.indexed_effect_combinator_kind -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.comp -> + FStarC_Syntax_Syntax.comp_typ -> + FStarC_Syntax_Syntax.comp_typ -> + (worklist -> + FStarC_Syntax_Syntax.term -> + FStarC_TypeChecker_Common.rel -> + FStarC_Syntax_Syntax.term -> + Prims.string -> + (FStarC_TypeChecker_Common.prob * worklist)) + -> + Prims.int -> + worklist -> + Prims.string -> + FStarC_Compiler_Range_Type.range -> + (FStarC_Syntax_Syntax.typ * + FStarC_TypeChecker_Common.prob Prims.list * + worklist)) + = + fun env -> + fun k -> + fun bs -> + fun subcomp_c -> + fun ct1 -> + fun ct2 -> + fun sub_prob -> + fun num_effect_params -> + fun wl -> + fun subcomp_name -> + fun r1 -> + let uu___ = + let uu___1 = bs in + match uu___1 with + | a_b::bs1 -> + (bs1, + [FStarC_Syntax_Syntax.NT + ((a_b.FStarC_Syntax_Syntax.binder_bv), + (ct2.FStarC_Syntax_Syntax.result_typ))]) in + match uu___ with + | (bs1, subst) -> + let uu___1 = + if num_effect_params = Prims.int_zero + then + (bs1, subst, + (ct1.FStarC_Syntax_Syntax.effect_args), + (ct2.FStarC_Syntax_Syntax.effect_args), [], + wl) + else + (let split l = + FStarC_Compiler_List.splitAt + num_effect_params l in + let uu___3 = split bs1 in + match uu___3 with + | (eff_params_bs, bs2) -> + let uu___4 = + split + ct1.FStarC_Syntax_Syntax.effect_args in + (match uu___4 with + | (param_args1, args1) -> + let uu___5 = + split + ct2.FStarC_Syntax_Syntax.effect_args in + (match uu___5 with + | (param_args2, args2) -> + let uu___6 = + FStarC_Compiler_List.fold_left2 + (fun uu___7 -> + fun uu___8 -> + fun uu___9 -> + match (uu___7, + uu___8, + uu___9) + with + | ((ps, wl1), + (t1, uu___10), + (t2, uu___11)) + -> + let uu___12 = + sub_prob wl1 + t1 + FStarC_TypeChecker_Common.EQ + t2 + "effect params subcomp" in + (match uu___12 + with + | (p, wl2) -> + ((FStarC_Compiler_List.op_At + ps [p]), + wl2))) + ([], wl) param_args1 + param_args2 in + (match uu___6 with + | (probs, wl1) -> + let param_subst = + FStarC_Compiler_List.map2 + (fun b -> + fun uu___7 -> + match uu___7 + with + | (arg, uu___8) + -> + FStarC_Syntax_Syntax.NT + ((b.FStarC_Syntax_Syntax.binder_bv), + arg)) + eff_params_bs + param_args1 in + (bs2, + (FStarC_Compiler_List.op_At + subst param_subst), + args1, args2, probs, + wl1))))) in + (match uu___1 with + | (bs2, subst1, args1, args2, + eff_params_sub_probs, wl1) -> + let uu___2 = + let uu___3 = + FStarC_Compiler_List.splitAt + (FStarC_Compiler_List.length args1) + bs2 in + match uu___3 with + | (f_bs, bs3) -> + let f_substs = + FStarC_Compiler_List.map2 + (fun f_b -> + fun uu___4 -> + match uu___4 with + | (arg, uu___5) -> + FStarC_Syntax_Syntax.NT + ((f_b.FStarC_Syntax_Syntax.binder_bv), + arg)) f_bs args1 in + (bs3, + (FStarC_Compiler_List.op_At subst1 + f_substs)) in + (match uu___2 with + | (bs3, subst2) -> + let uu___3 = + if + FStarC_Syntax_Syntax.uu___is_Substitutive_combinator + k + then + let uu___4 = + FStarC_Compiler_List.splitAt + (FStarC_Compiler_List.length + args2) bs3 in + match uu___4 with + | (g_bs, bs4) -> + let g_substs = + FStarC_Compiler_List.map2 + (fun g_b -> + fun uu___5 -> + match uu___5 with + | (arg, uu___6) -> + FStarC_Syntax_Syntax.NT + ((g_b.FStarC_Syntax_Syntax.binder_bv), + arg)) g_bs + args2 in + (bs4, + (FStarC_Compiler_List.op_At + subst2 g_substs), [], wl1) + else + if + FStarC_Syntax_Syntax.uu___is_Substitutive_invariant_combinator + k + then + (let uu___5 = + FStarC_Compiler_List.fold_left2 + (fun uu___6 -> + fun uu___7 -> + fun uu___8 -> + match (uu___6, + uu___7, + uu___8) + with + | ((ps, wl2), + (t1, uu___9), + (t2, uu___10)) -> + let uu___11 = + sub_prob wl2 t1 + FStarC_TypeChecker_Common.EQ + t2 + "substitutive inv subcomp args" in + (match uu___11 + with + | (p, wl3) -> + ((FStarC_Compiler_List.op_At + ps + [p]), + wl3))) + ([], wl1) args1 args2 in + match uu___5 with + | (probs, wl2) -> + (bs3, subst2, probs, wl2)) + else + failwith + "Impossible (rel.apply_substitutive_indexed_subcomp unexpected k" in + (match uu___3 with + | (bs4, subst3, f_g_args_eq_sub_probs, + wl2) -> + let bs5 = + let uu___4 = + FStarC_Compiler_List.splitAt + ((FStarC_Compiler_List.length + bs4) + - Prims.int_one) bs4 in + FStar_Pervasives_Native.fst + uu___4 in + let uu___4 = + FStarC_Compiler_List.fold_left + (fun uu___5 -> + fun b -> + match uu___5 with + | (ss, wl3) -> + let uu___6 = + FStarC_TypeChecker_Env.uvars_for_binders + env [b] ss + (fun b1 -> + let uu___7 = + FStarC_Compiler_Effect.op_Bang + dbg_LayeredEffectsApp in + if uu___7 + then + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_binder + b1 in + let uu___9 = + FStarC_Compiler_Range_Ops.string_of_range + r1 in + FStarC_Compiler_Util.format3 + "implicit var for additional binder %s in subcomp %s at %s" + uu___8 + subcomp_name + uu___9 + else + "apply_substitutive_indexed_subcomp") + r1 in + (match uu___6 with + | (uv_t::[], g) -> + let uu___7 = + let uu___8 = + FStarC_Class_Monoid.op_Plus_Plus + (FStarC_Compiler_CList.monoid_clist + ()) + g.FStarC_TypeChecker_Common.implicits + wl3.wl_implicits in + { + attempting = + (wl3.attempting); + wl_deferred + = + (wl3.wl_deferred); + wl_deferred_to_tac + = + (wl3.wl_deferred_to_tac); + ctr = + (wl3.ctr); + defer_ok = + (wl3.defer_ok); + smt_ok = + (wl3.smt_ok); + umax_heuristic_ok + = + (wl3.umax_heuristic_ok); + tcenv = + (wl3.tcenv); + wl_implicits + = uu___8; + repr_subcomp_allowed + = + (wl3.repr_subcomp_allowed); + typeclass_variables + = + (wl3.typeclass_variables) + } in + ((FStarC_Compiler_List.op_At + ss + [FStarC_Syntax_Syntax.NT + ((b.FStarC_Syntax_Syntax.binder_bv), + uv_t)]), + uu___7))) + (subst3, wl2) bs5 in + (match uu___4 with + | (subst4, wl3) -> + let subcomp_ct = + let uu___5 = + FStarC_Syntax_Subst.subst_comp + subst4 subcomp_c in + FStarC_TypeChecker_Env.comp_to_comp_typ + env uu___5 in + let fml = + let uu___5 = + let uu___6 = + FStarC_Compiler_List.hd + subcomp_ct.FStarC_Syntax_Syntax.comp_univs in + let uu___7 = + let uu___8 = + FStarC_Compiler_List.hd + subcomp_ct.FStarC_Syntax_Syntax.effect_args in + FStar_Pervasives_Native.fst + uu___8 in + (uu___6, uu___7) in + match uu___5 with + | (u, wp) -> + FStarC_TypeChecker_Env.pure_precondition_for_trivial_post + env u + subcomp_ct.FStarC_Syntax_Syntax.result_typ + wp + FStarC_Compiler_Range_Type.dummyRange in + (fml, + (FStarC_Compiler_List.op_At + eff_params_sub_probs + f_g_args_eq_sub_probs), + wl3))))) +let (apply_ad_hoc_indexed_subcomp : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.comp -> + FStarC_Syntax_Syntax.comp_typ -> + FStarC_Syntax_Syntax.comp_typ -> + (worklist -> + FStarC_Syntax_Syntax.term -> + FStarC_TypeChecker_Common.rel -> + FStarC_Syntax_Syntax.term -> + Prims.string -> + (FStarC_TypeChecker_Common.prob * worklist)) + -> + worklist -> + Prims.string -> + FStarC_Compiler_Range_Type.range -> + (FStarC_Syntax_Syntax.typ * + FStarC_TypeChecker_Common.prob Prims.list * worklist)) + = + fun env -> + fun bs -> + fun subcomp_c -> + fun ct1 -> + fun ct2 -> + fun sub_prob -> + fun wl -> + fun subcomp_name -> + fun r1 -> + let stronger_t_shape_error s = + let uu___ = + FStarC_Ident.string_of_lid + ct2.FStarC_Syntax_Syntax.effect_name in + FStarC_Compiler_Util.format2 + "Unexpected shape of stronger for %s, reason: %s" + uu___ s in + let uu___ = + if + (FStarC_Compiler_List.length bs) >= + (Prims.of_int (2)) + then + let uu___1 = bs in + match uu___1 with + | a_b::bs1 -> + let uu___2 = + let uu___3 = + FStarC_Compiler_List.splitAt + ((FStarC_Compiler_List.length bs1) - + Prims.int_one) bs1 in + match uu___3 with + | (l1, l2) -> + let uu___4 = FStarC_Compiler_List.hd l2 in + (l1, uu___4) in + (match uu___2 with + | (rest_bs, f_b) -> (a_b, rest_bs, f_b)) + else + (let uu___2 = + stronger_t_shape_error + "not an arrow or not enough binders" in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range r1 + FStarC_Errors_Codes.Fatal_UnexpectedExpressionType + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)) in + match uu___ with + | (a_b, rest_bs, f_b) -> + let uu___1 = + FStarC_TypeChecker_Env.uvars_for_binders env + rest_bs + [FStarC_Syntax_Syntax.NT + ((a_b.FStarC_Syntax_Syntax.binder_bv), + (ct2.FStarC_Syntax_Syntax.result_typ))] + (fun b -> + let uu___2 = + FStarC_Compiler_Effect.op_Bang + dbg_LayeredEffectsApp in + if uu___2 + then + let uu___3 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_binder b in + let uu___4 = + FStarC_Compiler_Range_Ops.string_of_range + r1 in + FStarC_Compiler_Util.format3 + "implicit for binder %s in subcomp %s at %s" + uu___3 subcomp_name uu___4 + else "apply_ad_hoc_indexed_subcomp") r1 in + (match uu___1 with + | (rest_bs_uvars, g_uvars) -> + let wl1 = + let uu___2 = + FStarC_Class_Monoid.op_Plus_Plus + (FStarC_Compiler_CList.monoid_clist ()) + g_uvars.FStarC_TypeChecker_Common.implicits + wl.wl_implicits in + { + attempting = (wl.attempting); + wl_deferred = (wl.wl_deferred); + wl_deferred_to_tac = (wl.wl_deferred_to_tac); + ctr = (wl.ctr); + defer_ok = (wl.defer_ok); + smt_ok = (wl.smt_ok); + umax_heuristic_ok = (wl.umax_heuristic_ok); + tcenv = (wl.tcenv); + wl_implicits = uu___2; + repr_subcomp_allowed = + (wl.repr_subcomp_allowed); + typeclass_variables = + (wl.typeclass_variables) + } in + let substs = + FStarC_Compiler_List.map2 + (fun b -> + fun t -> + FStarC_Syntax_Syntax.NT + ((b.FStarC_Syntax_Syntax.binder_bv), + t)) (a_b :: rest_bs) + ((ct2.FStarC_Syntax_Syntax.result_typ) :: + rest_bs_uvars) in + let uu___2 = + let f_sort_is = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_Env.is_layered_effect + env + ct1.FStarC_Syntax_Syntax.effect_name in + let uu___5 = + stronger_t_shape_error + "type of f is not a repr type" in + FStarC_Syntax_Util.effect_indices_from_repr + (f_b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort + uu___4 r1 uu___5 in + FStarC_Compiler_List.map + (FStarC_Syntax_Subst.subst substs) uu___3 in + let uu___3 = + FStarC_Compiler_List.map + FStar_Pervasives_Native.fst + ct1.FStarC_Syntax_Syntax.effect_args in + FStarC_Compiler_List.fold_left2 + (fun uu___4 -> + fun f_sort_i -> + fun c1_i -> + match uu___4 with + | (ps, wl2) -> + ((let uu___6 = + FStarC_Compiler_Effect.op_Bang + dbg_LayeredEffectsApp in + if uu___6 + then + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + f_sort_i in + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + c1_i in + FStarC_Compiler_Util.print3 + "Layered Effects (%s) %s = %s\n" + subcomp_name uu___7 uu___8 + else ()); + (let uu___6 = + sub_prob wl2 f_sort_i + FStarC_TypeChecker_Common.EQ + c1_i "indices of c1" in + match uu___6 with + | (p, wl3) -> + ((FStarC_Compiler_List.op_At + ps [p]), wl3)))) + ([], wl1) f_sort_is uu___3 in + (match uu___2 with + | (f_sub_probs, wl2) -> + let subcomp_ct = + let uu___3 = + FStarC_Syntax_Subst.subst_comp substs + subcomp_c in + FStarC_TypeChecker_Env.comp_to_comp_typ + env uu___3 in + let uu___3 = + let g_sort_is = + let uu___4 = + FStarC_TypeChecker_Env.is_layered_effect + env + ct2.FStarC_Syntax_Syntax.effect_name in + let uu___5 = + stronger_t_shape_error + "subcomp return type is not a repr" in + FStarC_Syntax_Util.effect_indices_from_repr + subcomp_ct.FStarC_Syntax_Syntax.result_typ + uu___4 r1 uu___5 in + let uu___4 = + FStarC_Compiler_List.map + FStar_Pervasives_Native.fst + ct2.FStarC_Syntax_Syntax.effect_args in + FStarC_Compiler_List.fold_left2 + (fun uu___5 -> + fun g_sort_i -> + fun c2_i -> + match uu___5 with + | (ps, wl3) -> + ((let uu___7 = + FStarC_Compiler_Effect.op_Bang + dbg_LayeredEffectsApp in + if uu___7 + then + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + g_sort_i in + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + c2_i in + FStarC_Compiler_Util.print3 + "Layered Effects (%s) %s = %s\n" + subcomp_name uu___8 + uu___9 + else ()); + (let uu___7 = + sub_prob wl3 g_sort_i + FStarC_TypeChecker_Common.EQ + c2_i "indices of c2" in + match uu___7 with + | (p, wl4) -> + ((FStarC_Compiler_List.op_At + ps [p]), wl4)))) + ([], wl2) g_sort_is uu___4 in + (match uu___3 with + | (g_sub_probs, wl3) -> + let fml = + let uu___4 = + let uu___5 = + FStarC_Compiler_List.hd + subcomp_ct.FStarC_Syntax_Syntax.comp_univs in + let uu___6 = + let uu___7 = + FStarC_Compiler_List.hd + subcomp_ct.FStarC_Syntax_Syntax.effect_args in + FStar_Pervasives_Native.fst + uu___7 in + (uu___5, uu___6) in + match uu___4 with + | (u, wp) -> + FStarC_TypeChecker_Env.pure_precondition_for_trivial_post + env u + subcomp_ct.FStarC_Syntax_Syntax.result_typ + wp + FStarC_Compiler_Range_Type.dummyRange in + (fml, + (FStarC_Compiler_List.op_At + f_sub_probs g_sub_probs), wl3)))) +let (has_typeclass_constraint : + FStarC_Syntax_Syntax.ctx_uvar -> worklist -> Prims.bool) = + fun u -> + fun wl -> + FStarC_Class_Setlike.for_any () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Free.ord_ctx_uvar)) + (fun v -> + FStarC_Syntax_Unionfind.equiv v.FStarC_Syntax_Syntax.ctx_uvar_head + u.FStarC_Syntax_Syntax.ctx_uvar_head) + (Obj.magic wl.typeclass_variables) +let (lazy_complete_repr : FStarC_Syntax_Syntax.lazy_kind -> Prims.bool) = + fun k -> + match k with + | FStarC_Syntax_Syntax.Lazy_bv -> true + | FStarC_Syntax_Syntax.Lazy_namedv -> true + | FStarC_Syntax_Syntax.Lazy_binder -> true + | FStarC_Syntax_Syntax.Lazy_letbinding -> true + | FStarC_Syntax_Syntax.Lazy_fvar -> true + | FStarC_Syntax_Syntax.Lazy_comp -> true + | FStarC_Syntax_Syntax.Lazy_sigelt -> true + | FStarC_Syntax_Syntax.Lazy_universe -> true + | uu___ -> false +let (has_free_uvars : FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Free.uvars_uncached t in + FStarC_Class_Setlike.is_empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) (Obj.magic uu___1) in + Prims.op_Negation uu___ +let (env_has_free_uvars : FStarC_TypeChecker_Env.env_t -> Prims.bool) = + fun e -> + let uu___ = FStarC_TypeChecker_Env.all_binders e in + FStarC_Compiler_List.existsb + (fun b -> + has_free_uvars + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort) + uu___ +let (gamma_has_free_uvars : + FStarC_Syntax_Syntax.binding Prims.list -> Prims.bool) = + fun g -> + FStarC_Compiler_List.existsb + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.Binding_var bv -> + has_free_uvars bv.FStarC_Syntax_Syntax.sort + | uu___1 -> false) g +type reveal_hide_t = + | Hide of (FStarC_Syntax_Syntax.universe * FStarC_Syntax_Syntax.typ * + FStarC_Syntax_Syntax.term) + | Reveal of (FStarC_Syntax_Syntax.universe * FStarC_Syntax_Syntax.typ * + FStarC_Syntax_Syntax.term) +let (uu___is_Hide : reveal_hide_t -> Prims.bool) = + fun projectee -> match projectee with | Hide _0 -> true | uu___ -> false +let (__proj__Hide__item___0 : + reveal_hide_t -> + (FStarC_Syntax_Syntax.universe * FStarC_Syntax_Syntax.typ * + FStarC_Syntax_Syntax.term)) + = fun projectee -> match projectee with | Hide _0 -> _0 +let (uu___is_Reveal : reveal_hide_t -> Prims.bool) = + fun projectee -> match projectee with | Reveal _0 -> true | uu___ -> false +let (__proj__Reveal__item___0 : + reveal_hide_t -> + (FStarC_Syntax_Syntax.universe * FStarC_Syntax_Syntax.typ * + FStarC_Syntax_Syntax.term)) + = fun projectee -> match projectee with | Reveal _0 -> _0 +let rec (solve : worklist -> solution) = + fun probs -> + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___1 + then + let uu___2 = wl_to_string probs in + FStarC_Compiler_Util.print1 "solve:\n\t%s\n" uu___2 + else ()); + (let uu___2 = FStarC_Compiler_Effect.op_Bang dbg_ImplicitTrace in + if uu___2 + then + let uu___3 = + FStarC_Class_Show.show + (FStarC_Compiler_CList.showable_clist + FStarC_TypeChecker_Common.showable_implicit) probs.wl_implicits in + FStarC_Compiler_Util.print1 "solve: wl_implicits = %s\n" uu___3 + else ()); + (let uu___2 = next_prob probs in + match uu___2 with + | FStar_Pervasives_Native.Some (hd, tl, rank1) -> + let probs1 = + { + attempting = tl; + wl_deferred = (probs.wl_deferred); + wl_deferred_to_tac = (probs.wl_deferred_to_tac); + ctr = (probs.ctr); + defer_ok = (probs.defer_ok); + smt_ok = (probs.smt_ok); + umax_heuristic_ok = (probs.umax_heuristic_ok); + tcenv = (probs.tcenv); + wl_implicits = (probs.wl_implicits); + repr_subcomp_allowed = (probs.repr_subcomp_allowed); + typeclass_variables = (probs.typeclass_variables) + } in + (def_check_prob "solve,hd" hd; + (match hd with + | FStarC_TypeChecker_Common.CProb cp -> + solve_c (maybe_invert cp) probs1 + | FStarC_TypeChecker_Common.TProb tp -> + let uu___4 = + FStarC_Compiler_Util.physical_equality + tp.FStarC_TypeChecker_Common.lhs + tp.FStarC_TypeChecker_Common.rhs in + if uu___4 + then + let uu___5 = + solve_prob hd FStar_Pervasives_Native.None [] probs1 in + solve uu___5 + else + (let is_expand_uvar t = + let uu___6 = + let uu___7 = FStarC_Syntax_Subst.compress t in + uu___7.FStarC_Syntax_Syntax.n in + match uu___6 with + | FStarC_Syntax_Syntax.Tm_uvar (ctx_u, uu___7) -> + let uu___8 = + FStarC_Syntax_Unionfind.find_decoration + ctx_u.FStarC_Syntax_Syntax.ctx_uvar_head in + uu___8.FStarC_Syntax_Syntax.uvar_decoration_should_unrefine + | uu___7 -> false in + let maybe_expand tp1 = + let uu___6 = + ((let uu___7 = FStarC_Options_Ext.get "__unrefine" in + uu___7 <> "") && + (tp1.FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.SUB)) + && (is_expand_uvar tp1.FStarC_TypeChecker_Common.rhs) in + if uu___6 + then + let lhs = tp1.FStarC_TypeChecker_Common.lhs in + let lhs_norm = + FStarC_TypeChecker_Normalize.unfold_whnf' + [FStarC_TypeChecker_Env.DontUnfoldAttr + [FStarC_Parser_Const.do_not_unrefine_attr]] + (p_env probs1 hd) lhs in + let uu___7 = + let uu___8 = + let uu___9 = FStarC_Syntax_Subst.compress lhs_norm in + uu___9.FStarC_Syntax_Syntax.n in + FStarC_Syntax_Syntax.uu___is_Tm_refine uu___8 in + (if uu___7 + then + let lhs' = + FStarC_TypeChecker_Normalize.unfold_whnf' + [FStarC_TypeChecker_Env.DontUnfoldAttr + [FStarC_Parser_Const.do_not_unrefine_attr]; + FStarC_TypeChecker_Env.Unrefine] + (p_env probs1 hd) lhs_norm in + ((let uu___9 = + FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___9 + then + let uu___10 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + tp1.FStarC_TypeChecker_Common.rhs in + let uu___11 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term lhs in + let uu___12 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term lhs' in + FStarC_Compiler_Util.print3 + "GGG widening uvar %s! RHS %s ~> %s\n" uu___10 + uu___11 uu___12 + else ()); + { + FStarC_TypeChecker_Common.pid = + (tp1.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = lhs'; + FStarC_TypeChecker_Common.relation = + (tp1.FStarC_TypeChecker_Common.relation); + FStarC_TypeChecker_Common.rhs = + (tp1.FStarC_TypeChecker_Common.rhs); + FStarC_TypeChecker_Common.element = + (tp1.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (tp1.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar = + (tp1.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (tp1.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = + (tp1.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (tp1.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = + (tp1.FStarC_TypeChecker_Common.logical) + }) + else tp1) + else tp1 in + let tp1 = maybe_expand tp in + if + (rank1 = FStarC_TypeChecker_Common.Rigid_rigid) || + ((tp1.FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.EQ) + && (rank1 <> FStarC_TypeChecker_Common.Flex_flex)) + then solve_t' tp1 probs1 + else + if probs1.defer_ok = DeferAny + then + maybe_defer_to_user_tac tp1 + "deferring flex_rigid or flex_flex subtyping" probs1 + else + if rank1 = FStarC_TypeChecker_Common.Flex_flex + then + solve_t' + { + FStarC_TypeChecker_Common.pid = + (tp1.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = + (tp1.FStarC_TypeChecker_Common.lhs); + FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.EQ; + FStarC_TypeChecker_Common.rhs = + (tp1.FStarC_TypeChecker_Common.rhs); + FStarC_TypeChecker_Common.element = + (tp1.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (tp1.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar = + (tp1.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (tp1.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = + (tp1.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (tp1.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = + (tp1.FStarC_TypeChecker_Common.logical) + } probs1 + else + solve_rigid_flex_or_flex_rigid_subtyping rank1 tp1 + probs1))) + | FStar_Pervasives_Native.None -> + let uu___3 = + Obj.magic + (FStarC_Class_Listlike.view () + (Obj.magic (FStarC_Compiler_CList.listlike_clist ())) + (Obj.magic probs.wl_deferred)) in + (match uu___3 with + | FStarC_Class_Listlike.VNil -> + let uu___4 = + let uu___5 = as_deferred probs.wl_deferred_to_tac in + ((Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic (FStarC_Compiler_CList.listlike_clist ())))), + uu___5, (probs.wl_implicits)) in + Success uu___4 + | FStarC_Class_Listlike.VCons (uu___4, uu___5) -> + let uu___6 = + FStarC_Compiler_CList.partition + (fun uu___7 -> + match uu___7 with + | (c, uu___8, uu___9, uu___10) -> c < probs.ctr) + probs.wl_deferred in + (match uu___6 with + | (attempt1, rest) -> + let uu___7 = + Obj.magic + (FStarC_Class_Listlike.view () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist ())) + (Obj.magic attempt1)) in + (match uu___7 with + | FStarC_Class_Listlike.VNil -> + let uu___8 = + let uu___9 = as_deferred probs.wl_deferred in + let uu___10 = as_deferred probs.wl_deferred_to_tac in + (uu___9, uu___10, (probs.wl_implicits)) in + Success uu___8 + | uu___8 -> + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Class_Listlike.to_list + (FStarC_Compiler_CList.listlike_clist ()) + attempt1 in + FStarC_Compiler_List.map + (fun uu___12 -> + match uu___12 with + | (uu___13, uu___14, uu___15, y) -> y) + uu___11 in + { + attempting = uu___10; + wl_deferred = rest; + wl_deferred_to_tac = (probs.wl_deferred_to_tac); + ctr = (probs.ctr); + defer_ok = (probs.defer_ok); + smt_ok = (probs.smt_ok); + umax_heuristic_ok = (probs.umax_heuristic_ok); + tcenv = (probs.tcenv); + wl_implicits = (probs.wl_implicits); + repr_subcomp_allowed = + (probs.repr_subcomp_allowed); + typeclass_variables = (probs.typeclass_variables) + } in + solve uu___9)))) +and (solve_one_universe_eq : + FStarC_TypeChecker_Common.prob -> + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.universe -> worklist -> solution) + = + fun orig -> + fun u1 -> + fun u2 -> + fun wl -> + let uu___ = solve_universe_eq (p_pid orig) wl u1 u2 in + match uu___ with + | USolved wl1 -> + let uu___1 = + solve_prob orig FStar_Pervasives_Native.None [] wl1 in + solve uu___1 + | UFailed msg -> giveup wl msg orig + | UDeferred wl1 -> + let uu___1 = + defer_lit FStarC_TypeChecker_Common.Deferred_univ_constraint + "" orig wl1 in + solve uu___1 +and (solve_maybe_uinsts : + FStarC_TypeChecker_Common.prob -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> worklist -> univ_eq_sol) + = + fun orig -> + fun t1 -> + fun t2 -> + fun wl -> + let rec aux wl1 us1 us2 = + match (us1, us2) with + | ([], []) -> USolved wl1 + | (u1::us11, u2::us21) -> + let uu___ = solve_universe_eq (p_pid orig) wl1 u1 u2 in + (match uu___ with + | USolved wl2 -> aux wl2 us11 us21 + | failed_or_deferred -> failed_or_deferred) + | uu___ -> ufailed_simple "Unequal number of universes" in + let env = p_env wl orig in + FStarC_Defensive.def_check_scoped + FStarC_TypeChecker_Env.hasBinders_env + FStarC_Class_Binders.hasNames_term + FStarC_Syntax_Print.pretty_term t1.FStarC_Syntax_Syntax.pos + "solve_maybe_uinsts.whnf1" env t1; + FStarC_Defensive.def_check_scoped + FStarC_TypeChecker_Env.hasBinders_env + FStarC_Class_Binders.hasNames_term + FStarC_Syntax_Print.pretty_term t2.FStarC_Syntax_Syntax.pos + "solve_maybe_uinsts.whnf2" env t2; + (let t11 = whnf env t1 in + let t21 = whnf env t2 in + match ((t11.FStarC_Syntax_Syntax.n), (t21.FStarC_Syntax_Syntax.n)) + with + | (FStarC_Syntax_Syntax.Tm_uinst + ({ FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar f; + FStarC_Syntax_Syntax.pos = uu___2; + FStarC_Syntax_Syntax.vars = uu___3; + FStarC_Syntax_Syntax.hash_code = uu___4;_}, + us1), + FStarC_Syntax_Syntax.Tm_uinst + ({ FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar g; + FStarC_Syntax_Syntax.pos = uu___5; + FStarC_Syntax_Syntax.vars = uu___6; + FStarC_Syntax_Syntax.hash_code = uu___7;_}, + us2)) -> + let b = FStarC_Syntax_Syntax.fv_eq f g in aux wl us1 us2 + | (FStarC_Syntax_Syntax.Tm_uinst uu___2, uu___3) -> + failwith "Impossible: expect head symbols to match" + | (uu___2, FStarC_Syntax_Syntax.Tm_uinst uu___3) -> + failwith "Impossible: expect head symbols to match" + | uu___2 -> USolved wl) +and (giveup_or_defer : + FStarC_TypeChecker_Common.prob -> + worklist -> + FStarC_TypeChecker_Common.deferred_reason -> lstring -> solution) + = + fun orig -> + fun wl -> + fun reason -> + fun msg -> + if wl.defer_ok = DeferAny + then + ((let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___1 + then + let uu___2 = prob_to_string wl.tcenv orig in + let uu___3 = FStarC_Thunk.force msg in + FStarC_Compiler_Util.print2 + "\n\t\tDeferring %s\n\t\tBecause %s\n" uu___2 uu___3 + else ()); + (let uu___1 = defer reason msg orig wl in solve uu___1)) + else giveup wl msg orig +and (giveup_or_defer_flex_flex : + FStarC_TypeChecker_Common.prob -> + worklist -> + FStarC_TypeChecker_Common.deferred_reason -> lstring -> solution) + = + fun orig -> + fun wl -> + fun reason -> + fun msg -> + if wl.defer_ok <> NoDefer + then + ((let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___1 + then + let uu___2 = prob_to_string wl.tcenv orig in + let uu___3 = FStarC_Thunk.force msg in + FStarC_Compiler_Util.print2 + "\n\t\tDeferring %s\n\t\tBecause %s\n" uu___2 uu___3 + else ()); + (let uu___1 = defer reason msg orig wl in solve uu___1)) + else giveup wl msg orig +and (defer_to_user_tac : + FStarC_TypeChecker_Common.prob -> Prims.string -> worklist -> solution) = + fun orig -> + fun reason -> + fun wl -> + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___1 + then + let uu___2 = prob_to_string wl.tcenv orig in + FStarC_Compiler_Util.print1 "\n\t\tDeferring %s to a tactic\n" + uu___2 + else ()); + (let wl1 = solve_prob orig FStar_Pervasives_Native.None [] wl in + let wl2 = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Thunk.mkv reason in + ((wl1.ctr), FStarC_TypeChecker_Common.Deferred_to_user_tac, + uu___3, orig) in + Obj.magic + (FStarC_Class_Listlike.cons () + (Obj.magic (FStarC_Compiler_CList.listlike_clist ())) + uu___2 (Obj.magic wl1.wl_deferred_to_tac)) in + { + attempting = (wl1.attempting); + wl_deferred = (wl1.wl_deferred); + wl_deferred_to_tac = uu___1; + ctr = (wl1.ctr); + defer_ok = (wl1.defer_ok); + smt_ok = (wl1.smt_ok); + umax_heuristic_ok = (wl1.umax_heuristic_ok); + tcenv = (wl1.tcenv); + wl_implicits = (wl1.wl_implicits); + repr_subcomp_allowed = (wl1.repr_subcomp_allowed); + typeclass_variables = (wl1.typeclass_variables) + } in + solve wl2) +and (maybe_defer_to_user_tac : tprob -> Prims.string -> worklist -> solution) + = + fun prob -> + fun reason -> + fun wl -> + match prob.FStarC_TypeChecker_Common.relation with + | FStarC_TypeChecker_Common.EQ -> + let should_defer_tac t = + let uu___ = FStarC_Syntax_Util.head_and_args t in + match uu___ with + | (head, uu___1) -> + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress head in + uu___3.FStarC_Syntax_Syntax.n in + (match uu___2 with + | FStarC_Syntax_Syntax.Tm_uvar (uv, uu___3) -> + let uu___4 = + FStarC_TypeChecker_DeferredImplicits.should_defer_uvar_to_user_tac + wl.tcenv uv in + (uu___4, (uv.FStarC_Syntax_Syntax.ctx_uvar_reason)) + | uu___3 -> (false, "")) in + let uu___ = should_defer_tac prob.FStarC_TypeChecker_Common.lhs in + (match uu___ with + | (l1, r1) -> + let uu___1 = + should_defer_tac prob.FStarC_TypeChecker_Common.rhs in + (match uu___1 with + | (l2, r2) -> + if l1 || l2 + then + defer_to_user_tac + (FStarC_TypeChecker_Common.TProb prob) + (Prims.strcat r1 (Prims.strcat ", " r2)) wl + else + (let uu___3 = + defer_lit FStarC_TypeChecker_Common.Deferred_flex + reason (FStarC_TypeChecker_Common.TProb prob) wl in + solve uu___3))) + | uu___ -> + let uu___1 = + defer_lit FStarC_TypeChecker_Common.Deferred_flex reason + (FStarC_TypeChecker_Common.TProb prob) wl in + solve uu___1 +and (solve_rigid_flex_or_flex_rigid_subtyping : + FStarC_TypeChecker_Common.rank_t -> tprob -> worklist -> solution) = + fun rank1 -> + fun tp -> + fun wl -> + def_check_prob "solve_rigid_flex_or_flex_rigid_subtyping" + (FStarC_TypeChecker_Common.TProb tp); + (let flip = rank1 = FStarC_TypeChecker_Common.Flex_rigid in + let meet_or_join op ts wl1 = + let eq_prob t1 t2 wl2 = + let uu___1 = + new_problem wl2 + (p_env wl2 (FStarC_TypeChecker_Common.TProb tp)) t1 + FStarC_TypeChecker_Common.EQ t2 FStar_Pervasives_Native.None + t1.FStarC_Syntax_Syntax.pos "join/meet refinements" in + match uu___1 with + | (p, wl3) -> + (def_check_prob "meet_or_join" + (FStarC_TypeChecker_Common.TProb p); + ((FStarC_TypeChecker_Common.TProb p), wl3)) in + let pairwise t1 t2 wl2 = + (let uu___2 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___2 + then + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t2 in + FStarC_Compiler_Util.print2 + "[meet/join]: pairwise: %s and %s\n" uu___3 uu___4 + else ()); + (let uu___2 = + head_matches_delta + (p_env wl2 (FStarC_TypeChecker_Common.TProb tp)) + tp.FStarC_TypeChecker_Common.logical wl2.smt_ok t1 t2 in + match uu___2 with + | (mr, ts1) -> + (match mr with + | HeadMatch (true) -> + let uu___3 = eq_prob t1 t2 wl2 in + (match uu___3 with | (p, wl3) -> (t1, [p], wl3)) + | MisMatch uu___3 -> + let uu___4 = eq_prob t1 t2 wl2 in + (match uu___4 with | (p, wl3) -> (t1, [p], wl3)) + | FullMatch -> + (match ts1 with + | FStar_Pervasives_Native.None -> (t1, [], wl2) + | FStar_Pervasives_Native.Some (t11, t21) -> + (t11, [], wl2)) + | HeadMatch (false) -> + let uu___3 = + match ts1 with + | FStar_Pervasives_Native.Some (t11, t21) -> + let uu___4 = FStarC_Syntax_Subst.compress t11 in + let uu___5 = FStarC_Syntax_Subst.compress t21 in + (uu___4, uu___5) + | FStar_Pervasives_Native.None -> + let uu___4 = FStarC_Syntax_Subst.compress t1 in + let uu___5 = FStarC_Syntax_Subst.compress t2 in + (uu___4, uu___5) in + (match uu___3 with + | (t11, t21) -> + let try_eq t12 t22 wl3 = + let uu___4 = + FStarC_Syntax_Util.head_and_args t12 in + match uu___4 with + | (t1_hd, t1_args) -> + let uu___5 = + FStarC_Syntax_Util.head_and_args t22 in + (match uu___5 with + | (t2_hd, t2_args) -> + if + (FStarC_Compiler_List.length t1_args) + <> + (FStarC_Compiler_List.length + t2_args) + then FStar_Pervasives_Native.None + else + (let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Syntax_Syntax.as_arg + t1_hd in + uu___9 :: t1_args in + let uu___9 = + let uu___10 = + FStarC_Syntax_Syntax.as_arg + t2_hd in + uu___10 :: t2_args in + FStarC_Compiler_List.fold_left2 + (fun uu___10 -> + fun uu___11 -> + fun uu___12 -> + match (uu___10, uu___11, + uu___12) + with + | ((probs, wl4), + (a1, uu___13), + (a2, uu___14)) -> + let uu___15 = + eq_prob a1 a2 wl4 in + (match uu___15 with + | (p, wl5) -> + ((p :: probs), + wl5))) + ([], wl3) uu___8 uu___9 in + match uu___7 with + | (probs, wl4) -> + let wl' = + { + attempting = probs; + wl_deferred = + (Obj.magic + (FStarC_Class_Listlike.empty + () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist + ())))); + wl_deferred_to_tac = + (wl4.wl_deferred_to_tac); + ctr = (wl4.ctr); + defer_ok = NoDefer; + smt_ok = false; + umax_heuristic_ok = + (wl4.umax_heuristic_ok); + tcenv = (wl4.tcenv); + wl_implicits = + (Obj.magic + (FStarC_Class_Listlike.empty + () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist + ())))); + repr_subcomp_allowed = + (wl4.repr_subcomp_allowed); + typeclass_variables = + (wl4.typeclass_variables) + } in + let tx = + FStarC_Syntax_Unionfind.new_transaction + () in + let uu___8 = solve wl' in + (match uu___8 with + | Success + (uu___9, defer_to_tac, + imps) + -> + (FStarC_Syntax_Unionfind.commit + tx; + (let uu___11 = + extend_wl wl4 + (Obj.magic + (FStarC_Class_Listlike.empty + () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist + ())))) + defer_to_tac imps in + FStar_Pervasives_Native.Some + uu___11)) + | Failed uu___9 -> + (FStarC_Syntax_Unionfind.rollback + tx; + FStar_Pervasives_Native.None)))) in + let combine t12 t22 wl3 = + let env = + p_env wl3 + (FStarC_TypeChecker_Common.TProb tp) in + let uu___4 = + base_and_refinement_maybe_delta false env t12 in + match uu___4 with + | (t1_base, p1_opt) -> + let uu___5 = + base_and_refinement_maybe_delta false env + t22 in + (match uu___5 with + | (t2_base, p2_opt) -> + let apply_op env1 op1 phi1 phi2 = + let squash phi = + let uu___6 = + env1.FStarC_TypeChecker_Env.universe_of + env1 phi in + match uu___6 with + | FStarC_Syntax_Syntax.U_zero -> + phi + | u -> + FStarC_Syntax_Util.mk_squash u + phi in + let uu___6 = squash phi1 in + let uu___7 = squash phi2 in + op1 uu___6 uu___7 in + let combine_refinements t_base p1_opt1 + p2_opt1 = + match op with + | FStar_Pervasives_Native.None -> + t_base + | FStar_Pervasives_Native.Some op1 + -> + let refine x t = + let uu___6 = + FStarC_Syntax_Util.is_t_true + t in + if uu___6 + then + x.FStarC_Syntax_Syntax.sort + else + FStarC_Syntax_Util.refine x + t in + (match (p1_opt1, p2_opt1) with + | (FStar_Pervasives_Native.Some + (x, phi1), + FStar_Pervasives_Native.Some + (y, phi2)) -> + let x1 = + FStarC_Syntax_Syntax.freshen_bv + x in + let subst = + [FStarC_Syntax_Syntax.DB + (Prims.int_zero, x1)] in + let phi11 = + FStarC_Syntax_Subst.subst + subst phi1 in + let phi21 = + FStarC_Syntax_Subst.subst + subst phi2 in + let env_x = + FStarC_TypeChecker_Env.push_bv + env x1 in + let uu___6 = + apply_op env_x op1 phi11 + phi21 in + refine x1 uu___6 + | (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.Some + (x, phi)) -> + let x1 = + FStarC_Syntax_Syntax.freshen_bv + x in + let subst = + [FStarC_Syntax_Syntax.DB + (Prims.int_zero, x1)] in + let phi1 = + FStarC_Syntax_Subst.subst + subst phi in + let env_x = + FStarC_TypeChecker_Env.push_bv + env x1 in + let uu___6 = + apply_op env_x op1 + FStarC_Syntax_Util.t_true + phi1 in + refine x1 uu___6 + | (FStar_Pervasives_Native.Some + (x, phi), + FStar_Pervasives_Native.None) + -> + let x1 = + FStarC_Syntax_Syntax.freshen_bv + x in + let subst = + [FStarC_Syntax_Syntax.DB + (Prims.int_zero, x1)] in + let phi1 = + FStarC_Syntax_Subst.subst + subst phi in + let env_x = + FStarC_TypeChecker_Env.push_bv + env x1 in + let uu___6 = + apply_op env_x op1 + FStarC_Syntax_Util.t_true + phi1 in + refine x1 uu___6 + | uu___6 -> t_base) in + let uu___6 = + try_eq t1_base t2_base wl3 in + (match uu___6 with + | FStar_Pervasives_Native.Some wl4 -> + let uu___7 = + combine_refinements t1_base + p1_opt p2_opt in + (uu___7, [], wl4) + | FStar_Pervasives_Native.None -> + let uu___7 = + base_and_refinement_maybe_delta + true env t12 in + (match uu___7 with + | (t1_base1, p1_opt1) -> + let uu___8 = + base_and_refinement_maybe_delta + true env t22 in + (match uu___8 with + | (t2_base1, p2_opt1) -> + let uu___9 = + eq_prob t1_base1 + t2_base1 wl3 in + (match uu___9 with + | (p, wl4) -> + let t = + combine_refinements + t1_base1 + p1_opt1 + p2_opt1 in + (t, [p], wl4)))))) in + let uu___4 = combine t11 t21 wl2 in + (match uu___4 with + | (t12, ps, wl3) -> + ((let uu___6 = + FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___6 + then + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t12 in + FStarC_Compiler_Util.print1 + "pairwise fallback2 succeeded: %s" + uu___7 + else ()); + (t12, ps, wl3)))))) in + let rec aux uu___1 ts1 = + match uu___1 with + | (out, probs, wl2) -> + (match ts1 with + | [] -> (out, probs, wl2) + | t::ts2 -> + let uu___2 = pairwise out t wl2 in + (match uu___2 with + | (out1, probs', wl3) -> + aux + (out1, + (FStarC_Compiler_List.op_At probs probs'), + wl3) ts2)) in + let uu___1 = + let uu___2 = FStarC_Compiler_List.hd ts in (uu___2, [], wl1) in + let uu___2 = FStarC_Compiler_List.tl ts in aux uu___1 uu___2 in + let uu___1 = + if flip + then + ((tp.FStarC_TypeChecker_Common.lhs), + (tp.FStarC_TypeChecker_Common.rhs)) + else + ((tp.FStarC_TypeChecker_Common.rhs), + (tp.FStarC_TypeChecker_Common.lhs)) in + match uu___1 with + | (this_flex, this_rigid) -> + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress this_rigid in + uu___3.FStarC_Syntax_Syntax.n in + (match uu___2 with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = _bs; + FStarC_Syntax_Syntax.comp = comp;_} + -> + let uu___3 = FStarC_Syntax_Util.is_tot_or_gtot_comp comp in + if uu___3 + then + let uu___4 = destruct_flex_t this_flex wl in + (match uu___4 with + | (flex, wl1) -> + let uu___5 = quasi_pattern wl1.tcenv flex in + (match uu___5 with + | FStar_Pervasives_Native.None -> + giveup_lit wl1 + "flex-arrow subtyping, not a quasi pattern" + (FStarC_TypeChecker_Common.TProb tp) + | FStar_Pervasives_Native.Some (flex_bs, flex_t1) + -> + ((let uu___7 = + FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___7 + then + let uu___8 = + FStarC_Compiler_Util.string_of_int + tp.FStarC_TypeChecker_Common.pid in + FStarC_Compiler_Util.print1 + "Trying to solve by imitating arrow:%s\n" + uu___8 + else ()); + imitate_arrow + (FStarC_TypeChecker_Common.TProb tp) wl1 + flex flex_bs flex_t1 + tp.FStarC_TypeChecker_Common.relation + this_rigid))) + else + (let uu___5 = + attempt + [FStarC_TypeChecker_Common.TProb + { + FStarC_TypeChecker_Common.pid = + (tp.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = + (tp.FStarC_TypeChecker_Common.lhs); + FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.EQ; + FStarC_TypeChecker_Common.rhs = + (tp.FStarC_TypeChecker_Common.rhs); + FStarC_TypeChecker_Common.element = + (tp.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (tp.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar = + (tp.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (tp.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = + (tp.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (tp.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = + (tp.FStarC_TypeChecker_Common.logical) + }] wl in + solve uu___5) + | uu___3 -> + ((let uu___5 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___5 + then + let uu___6 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + tp.FStarC_TypeChecker_Common.pid in + FStarC_Compiler_Util.print1 + "Trying to solve by meeting refinements:%s\n" uu___6 + else ()); + (let uu___5 = FStarC_Syntax_Util.head_and_args this_flex in + match uu___5 with + | (u, _args) -> + let env = + p_env wl (FStarC_TypeChecker_Common.TProb tp) in + let uu___6 = + let uu___7 = FStarC_Syntax_Subst.compress u in + uu___7.FStarC_Syntax_Syntax.n in + (match uu___6 with + | FStarC_Syntax_Syntax.Tm_uvar (ctx_uvar, _subst) -> + let equiv t = + let uu___7 = + FStarC_Syntax_Util.head_and_args t in + match uu___7 with + | (u', uu___8) -> + let uu___9 = + let uu___10 = whnf env u' in + uu___10.FStarC_Syntax_Syntax.n in + (match uu___9 with + | FStarC_Syntax_Syntax.Tm_uvar + (ctx_uvar', _subst') -> + FStarC_Syntax_Unionfind.equiv + ctx_uvar.FStarC_Syntax_Syntax.ctx_uvar_head + ctx_uvar'.FStarC_Syntax_Syntax.ctx_uvar_head + | uu___10 -> false) in + let uu___7 = + FStarC_Compiler_List.partition + (fun uu___8 -> + match uu___8 with + | FStarC_TypeChecker_Common.TProb tp1 -> + let tp2 = maybe_invert tp1 in + (match tp2.FStarC_TypeChecker_Common.rank + with + | FStar_Pervasives_Native.Some rank' + when rank1 = rank' -> + if flip + then + equiv + tp2.FStarC_TypeChecker_Common.lhs + else + equiv + tp2.FStarC_TypeChecker_Common.rhs + | uu___9 -> false) + | uu___9 -> false) wl.attempting in + (match uu___7 with + | (bounds_probs, rest) -> + let bounds_typs = + let uu___8 = whnf env this_rigid in + let uu___9 = + FStarC_Compiler_List.collect + (fun uu___10 -> + match uu___10 with + | FStarC_TypeChecker_Common.TProb + p -> + let uu___11 = + if flip + then + whnf env + (maybe_invert p).FStarC_TypeChecker_Common.rhs + else + whnf env + (maybe_invert p).FStarC_TypeChecker_Common.lhs in + [uu___11] + | uu___11 -> []) bounds_probs in + uu___8 :: uu___9 in + let uu___8 = + let uu___9 = + (has_typeclass_constraint ctx_uvar wl) + && (Prims.op_Negation flip) in + if uu___9 + then (true, FStar_Pervasives_Native.None) + else + (false, + (FStar_Pervasives_Native.Some + (if flip + then + FStarC_Syntax_Util.mk_conj_simp + else + FStarC_Syntax_Util.mk_disj_simp))) in + (match uu___8 with + | (widen, meet_or_join_op) -> + let uu___9 = + match bounds_typs with + | t::[] -> + if widen + then + let uu___10 = + let uu___11 = + base_and_refinement_maybe_delta + false env t in + FStar_Pervasives_Native.fst + uu___11 in + (uu___10, [], wl) + else (t, [], wl) + | uu___10 -> + meet_or_join meet_or_join_op + bounds_typs wl in + (match uu___9 with + | (bound, sub_probs, wl1) -> + let uu___10 = + let flex_u = + flex_uvar_head this_flex in + let bound1 = + let uu___11 = + let uu___12 = + FStarC_Syntax_Subst.compress + bound in + uu___12.FStarC_Syntax_Syntax.n in + match uu___11 with + | FStarC_Syntax_Syntax.Tm_refine + { + FStarC_Syntax_Syntax.b + = x; + FStarC_Syntax_Syntax.phi + = phi;_} + when + (tp.FStarC_TypeChecker_Common.relation + = + FStarC_TypeChecker_Common.SUB) + && + (let uu___12 = + occurs flex_u + x.FStarC_Syntax_Syntax.sort in + FStar_Pervasives_Native.snd + uu___12) + -> + x.FStarC_Syntax_Syntax.sort + | uu___12 -> bound in + let uu___11 = + new_problem wl1 + (p_env wl1 + (FStarC_TypeChecker_Common.TProb + tp)) bound1 + FStarC_TypeChecker_Common.EQ + this_flex + FStar_Pervasives_Native.None + tp.FStarC_TypeChecker_Common.loc + (if flip + then "joining refinements" + else "meeting refinements") in + (bound1, uu___11) in + (match uu___10 with + | (bound_typ, (eq_prob, wl')) -> + (def_check_prob + "meet_or_join2" + (FStarC_TypeChecker_Common.TProb + eq_prob); + (let uu___13 = + FStarC_Compiler_Effect.op_Bang + dbg_Rel in + if uu___13 + then + let wl'1 = + { + attempting = + ((FStarC_TypeChecker_Common.TProb + eq_prob) :: + sub_probs); + wl_deferred = + (wl1.wl_deferred); + wl_deferred_to_tac = + (wl1.wl_deferred_to_tac); + ctr = (wl1.ctr); + defer_ok = + (wl1.defer_ok); + smt_ok = + (wl1.smt_ok); + umax_heuristic_ok = + (wl1.umax_heuristic_ok); + tcenv = (wl1.tcenv); + wl_implicits = + (wl1.wl_implicits); + repr_subcomp_allowed + = + (wl1.repr_subcomp_allowed); + typeclass_variables + = + (wl1.typeclass_variables) + } in + let uu___14 = + wl_to_string wl'1 in + FStarC_Compiler_Util.print1 + "After meet/join refinements: %s\n" + uu___14 + else ()); + (let tx = + FStarC_Syntax_Unionfind.new_transaction + () in + FStarC_Compiler_List.iter + (def_check_prob + "meet_or_join3_sub") + sub_probs; + (let uu___14 = + solve_t eq_prob + { + attempting = + sub_probs; + wl_deferred = + (Obj.magic + (FStarC_Class_Listlike.empty + () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist + ())))); + wl_deferred_to_tac + = + (wl'.wl_deferred_to_tac); + ctr = (wl'.ctr); + defer_ok = NoDefer; + smt_ok = + (wl'.smt_ok); + umax_heuristic_ok = + (wl'.umax_heuristic_ok); + tcenv = (wl'.tcenv); + wl_implicits = + (Obj.magic + (FStarC_Class_Listlike.empty + () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist + ())))); + repr_subcomp_allowed + = + (wl'.repr_subcomp_allowed); + typeclass_variables + = + (wl'.typeclass_variables) + } in + match uu___14 with + | Success + (uu___15, + defer_to_tac, imps) + -> + let wl2 = + { + attempting = rest; + wl_deferred = + (wl'.wl_deferred); + wl_deferred_to_tac + = + (wl'.wl_deferred_to_tac); + ctr = (wl'.ctr); + defer_ok = + (wl'.defer_ok); + smt_ok = + (wl'.smt_ok); + umax_heuristic_ok + = + (wl'.umax_heuristic_ok); + tcenv = + (wl'.tcenv); + wl_implicits = + (wl'.wl_implicits); + repr_subcomp_allowed + = + (wl'.repr_subcomp_allowed); + typeclass_variables + = + (wl'.typeclass_variables) + } in + let wl3 = + extend_wl wl2 + (Obj.magic + (FStarC_Class_Listlike.empty + () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist + ())))) + defer_to_tac imps in + let g = + FStarC_Compiler_List.fold_left + (fun g1 -> + fun p -> + FStarC_Syntax_Util.mk_conj + g1 + (p_guard p)) + eq_prob.FStarC_TypeChecker_Common.logical_guard + sub_probs in + let wl4 = + solve_prob' false + (FStarC_TypeChecker_Common.TProb + tp) + (FStar_Pervasives_Native.Some + g) [] wl3 in + let uu___16 = + FStarC_Compiler_List.fold_left + (fun wl5 -> + fun p -> + solve_prob' + true p + FStar_Pervasives_Native.None + [] wl5) + wl4 bounds_probs in + (FStarC_Syntax_Unionfind.commit + tx; + solve wl4) + | Failed (p, msg) -> + ((let uu___16 = + FStarC_Compiler_Effect.op_Bang + dbg_Rel in + if uu___16 + then + let uu___17 = + let uu___18 = + FStarC_Compiler_List.map + (prob_to_string + env) + ((FStarC_TypeChecker_Common.TProb + eq_prob) + :: + sub_probs) in + FStarC_Compiler_String.concat + "\n" uu___18 in + FStarC_Compiler_Util.print1 + "meet/join attempted and failed to solve problems:\n%s\n" + uu___17 + else ()); + (let uu___16 = + let uu___17 = + base_and_refinement + env bound_typ in + (rank1, uu___17) in + match uu___16 with + | (FStarC_TypeChecker_Common.Rigid_flex, + (t_base, + FStar_Pervasives_Native.Some + uu___17)) -> + (FStarC_Syntax_Unionfind.rollback + tx; + (let uu___19 = + new_problem + wl1 + ( + p_env wl1 + (FStarC_TypeChecker_Common.TProb + tp)) + t_base + FStarC_TypeChecker_Common.EQ + this_flex + FStar_Pervasives_Native.None + tp.FStarC_TypeChecker_Common.loc + "widened subtyping" in + match uu___19 + with + | (eq_prob1, + wl2) -> + ( + def_check_prob + "meet_or_join3" + (FStarC_TypeChecker_Common.TProb + eq_prob1); + ( + let wl3 = + solve_prob' + false + (FStarC_TypeChecker_Common.TProb + tp) + (FStar_Pervasives_Native.Some + (p_guard + (FStarC_TypeChecker_Common.TProb + eq_prob1))) + [] wl2 in + let uu___21 + = + attempt + [ + FStarC_TypeChecker_Common.TProb + eq_prob1] + wl3 in + solve + uu___21)))) + | (FStarC_TypeChecker_Common.Flex_rigid, + (t_base, + FStar_Pervasives_Native.Some + (x, phi))) -> + (FStarC_Syntax_Unionfind.rollback + tx; + (let x1 = + FStarC_Syntax_Syntax.freshen_bv + x in + let uu___18 = + let uu___19 + = + let uu___20 + = + FStarC_Syntax_Syntax.mk_binder + x1 in + [uu___20] in + FStarC_Syntax_Subst.open_term + uu___19 + phi in + match uu___18 + with + | (uu___19, + phi1) -> + let uu___20 + = + new_problem + wl1 env + t_base + FStarC_TypeChecker_Common.EQ + this_flex + FStar_Pervasives_Native.None + tp.FStarC_TypeChecker_Common.loc + "widened subtyping" in + (match uu___20 + with + | + (eq_prob1, + wl2) -> + (def_check_prob + "meet_or_join4" + (FStarC_TypeChecker_Common.TProb + eq_prob1); + (let phi2 + = + guard_on_element + wl2 tp x1 + phi1 in + let wl3 = + let uu___22 + = + let uu___23 + = + FStarC_Syntax_Util.mk_conj + phi2 + (p_guard + (FStarC_TypeChecker_Common.TProb + eq_prob1)) in + FStar_Pervasives_Native.Some + uu___23 in + solve_prob' + false + (FStarC_TypeChecker_Common.TProb + tp) + uu___22 + [] wl2 in + let uu___22 + = + attempt + [ + FStarC_TypeChecker_Common.TProb + eq_prob1] + wl3 in + solve + uu___22))))) + | uu___17 -> + let uu___18 = + FStarC_Thunk.map + (fun s -> + Prims.strcat + "failed to solve the sub-problems: " + s) msg in + giveup wl1 + uu___18 p))))))))) + | uu___7 when flip -> + let uu___8 = + let uu___9 = + FStarC_Compiler_Util.string_of_int + (rank_t_num rank1) in + let uu___10 = + prob_to_string env + (FStarC_TypeChecker_Common.TProb tp) in + FStarC_Compiler_Util.format2 + "Impossible: (rank=%s) Not a flex-rigid: %s" + uu___9 uu___10 in + failwith uu___8 + | uu___7 -> + let uu___8 = + let uu___9 = + FStarC_Compiler_Util.string_of_int + (rank_t_num rank1) in + let uu___10 = + prob_to_string env + (FStarC_TypeChecker_Common.TProb tp) in + FStarC_Compiler_Util.format2 + "Impossible: (rank=%s) Not a rigid-flex: %s" + uu___9 uu___10 in + failwith uu___8))))) +and (imitate_arrow : + FStarC_TypeChecker_Common.prob -> + worklist -> + flex_t -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.term -> + FStarC_TypeChecker_Common.rel -> + FStarC_Syntax_Syntax.term -> solution) + = + fun orig -> + fun wl -> + fun lhs -> + fun bs_lhs -> + fun t_res_lhs -> + fun rel -> + fun arrow -> + let bs_lhs_args = + FStarC_Compiler_List.map + (fun uu___ -> + match uu___ with + | { FStarC_Syntax_Syntax.binder_bv = x; + FStarC_Syntax_Syntax.binder_qual = i; + FStarC_Syntax_Syntax.binder_positivity = uu___1; + FStarC_Syntax_Syntax.binder_attrs = uu___2;_} -> + let uu___3 = FStarC_Syntax_Syntax.bv_to_name x in + (uu___3, i)) bs_lhs in + let uu___ = lhs in + match uu___ with + | Flex (uu___1, u_lhs, uu___2) -> + let imitate_comp bs bs_terms c wl1 = + let imitate_tot_or_gtot t f wl2 = + let uu___3 = FStarC_Syntax_Util.type_u () in + match uu___3 with + | (k, uu___4) -> + let uu___5 = + copy_uvar u_lhs + (FStarC_Compiler_List.op_At bs_lhs bs) k wl2 in + (match uu___5 with + | (uu___6, u, wl3) -> + let uu___7 = f u in (uu___7, wl3)) in + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total t -> + imitate_tot_or_gtot t FStarC_Syntax_Syntax.mk_Total + wl1 + | FStarC_Syntax_Syntax.GTotal t -> + imitate_tot_or_gtot t + FStarC_Syntax_Syntax.mk_GTotal wl1 + | FStarC_Syntax_Syntax.Comp ct -> + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Syntax_Syntax.as_arg + ct.FStarC_Syntax_Syntax.result_typ in + uu___5 :: (ct.FStarC_Syntax_Syntax.effect_args) in + FStarC_Compiler_List.fold_right + (fun uu___5 -> + fun uu___6 -> + match (uu___5, uu___6) with + | ((a, i), (out_args, wl2)) -> + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Syntax_Util.type_u () in + FStar_Pervasives_Native.fst uu___9 in + copy_uvar u_lhs [] uu___8 wl2 in + (match uu___7 with + | (uu___8, t_a, wl3) -> + let uu___9 = + copy_uvar u_lhs bs t_a wl3 in + (match uu___9 with + | (uu___10, a', wl4) -> + (((a', i) :: out_args), wl4)))) + uu___4 ([], wl1) in + (match uu___3 with + | (out_args, wl2) -> + let nodec flags = + FStarC_Compiler_List.filter + (fun uu___4 -> + match uu___4 with + | FStarC_Syntax_Syntax.DECREASES uu___5 + -> false + | uu___5 -> true) flags in + let ct' = + let uu___4 = + let uu___5 = + FStarC_Compiler_List.hd out_args in + FStar_Pervasives_Native.fst uu___5 in + let uu___5 = + FStarC_Compiler_List.tl out_args in + let uu___6 = + nodec ct.FStarC_Syntax_Syntax.flags in + { + FStarC_Syntax_Syntax.comp_univs = + (ct.FStarC_Syntax_Syntax.comp_univs); + FStarC_Syntax_Syntax.effect_name = + (ct.FStarC_Syntax_Syntax.effect_name); + FStarC_Syntax_Syntax.result_typ = uu___4; + FStarC_Syntax_Syntax.effect_args = uu___5; + FStarC_Syntax_Syntax.flags = uu___6 + } in + ({ + FStarC_Syntax_Syntax.n = + (FStarC_Syntax_Syntax.Comp ct'); + FStarC_Syntax_Syntax.pos = + (c.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = + (c.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (c.FStarC_Syntax_Syntax.hash_code) + }, wl2)) in + let uu___3 = FStarC_Syntax_Util.arrow_formals_comp arrow in + (match uu___3 with + | (formals, c) -> + let rec aux bs bs_terms formals1 wl1 = + match formals1 with + | [] -> + let uu___4 = imitate_comp bs bs_terms c wl1 in + (match uu___4 with + | (c', wl2) -> + let lhs' = FStarC_Syntax_Util.arrow bs c' in + let sol = + let uu___5 = + let uu___6 = + FStarC_Syntax_Util.abs bs_lhs lhs' + (FStar_Pervasives_Native.Some + (FStarC_Syntax_Util.residual_tot + t_res_lhs)) in + (u_lhs, uu___6) in + TERM uu___5 in + let uu___5 = + mk_t_problem wl2 [] orig lhs' rel arrow + FStar_Pervasives_Native.None + "arrow imitation" in + (match uu___5 with + | (sub_prob, wl3) -> + let uu___6 = + let uu___7 = + solve_prob orig + FStar_Pervasives_Native.None + [sol] wl3 in + attempt [sub_prob] uu___7 in + solve uu___6)) + | { FStarC_Syntax_Syntax.binder_bv = x; + FStarC_Syntax_Syntax.binder_qual = imp; + FStarC_Syntax_Syntax.binder_positivity = pqual; + FStarC_Syntax_Syntax.binder_attrs = attrs;_}::formals2 + -> + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Syntax_Util.type_u () in + FStar_Pervasives_Native.fst uu___6 in + copy_uvar u_lhs + (FStarC_Compiler_List.op_At bs_lhs bs) + uu___5 wl1 in + (match uu___4 with + | (_ctx_u_x, u_x, wl2) -> + let y = + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.range_of_bv x in + FStar_Pervasives_Native.Some uu___6 in + FStarC_Syntax_Syntax.new_bv uu___5 u_x in + let b = + FStarC_Syntax_Syntax.mk_binder_with_attrs + y imp pqual attrs in + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Syntax_Util.arg_of_non_null_binder + b in + [uu___7] in + FStarC_Compiler_List.op_At bs_terms + uu___6 in + aux (FStarC_Compiler_List.op_At bs [b]) + uu___5 formals2 wl2) in + let uu___4 = occurs_check u_lhs arrow in + (match uu___4 with + | (uu___5, occurs_ok, msg) -> + if Prims.op_Negation occurs_ok + then + let uu___6 = + mklstr + (fun uu___7 -> + let uu___8 = + FStarC_Compiler_Option.get msg in + Prims.strcat "occurs-check failed: " + uu___8) in + giveup_or_defer orig wl + FStarC_TypeChecker_Common.Deferred_occur_check_failed + uu___6 + else aux [] [] formals wl)) +and (solve_binders : + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.binders -> + FStarC_TypeChecker_Common.prob -> + worklist -> + (worklist -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.subst_elt Prims.list -> + (FStarC_TypeChecker_Common.prob * worklist)) + -> solution) + = + fun bs1 -> + fun bs2 -> + fun orig -> + fun wl -> + fun rhs -> + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binder) bs1 in + let uu___3 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binder) bs2 in + FStarC_Compiler_Util.print3 "solve_binders\n\t%s\n%s\n\t%s\n" + uu___2 (rel_to_string (p_rel orig)) uu___3 + else ()); + (let eq_bqual a1 a2 = + match (a1, a2) with + | (FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Implicit + b1), FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Implicit b2)) -> true + | uu___1 -> FStarC_Syntax_Util.eq_bqual a1 a2 in + let compat_positivity_qualifiers p1 p2 = + match p_rel orig with + | FStarC_TypeChecker_Common.EQ -> + FStarC_TypeChecker_Common.check_positivity_qual false p1 + p2 + | FStarC_TypeChecker_Common.SUB -> + FStarC_TypeChecker_Common.check_positivity_qual true p1 p2 + | FStarC_TypeChecker_Common.SUBINV -> + FStarC_TypeChecker_Common.check_positivity_qual true p2 p1 in + let rec aux wl1 scope subst xs ys = + match (xs, ys) with + | ([], []) -> + let uu___1 = rhs wl1 scope subst in + (match uu___1 with + | (rhs_prob, wl2) -> + ((let uu___3 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___3 + then + let uu___4 = + prob_to_string (p_env wl2 rhs_prob) rhs_prob in + FStarC_Compiler_Util.print1 "rhs_prob = %s\n" + uu___4 + else ()); + (let formula = p_guard rhs_prob in + ((FStar_Pervasives.Inl ([rhs_prob], formula)), wl2)))) + | (x::xs1, y::ys1) when + (eq_bqual x.FStarC_Syntax_Syntax.binder_qual + y.FStarC_Syntax_Syntax.binder_qual) + && + (compat_positivity_qualifiers + x.FStarC_Syntax_Syntax.binder_positivity + y.FStarC_Syntax_Syntax.binder_positivity) + -> + let uu___1 = + ((x.FStarC_Syntax_Syntax.binder_bv), + (x.FStarC_Syntax_Syntax.binder_qual)) in + (match uu___1 with + | (hd1, imp) -> + let uu___2 = + ((y.FStarC_Syntax_Syntax.binder_bv), + (y.FStarC_Syntax_Syntax.binder_qual)) in + (match uu___2 with + | (hd2, imp') -> + let hd11 = + let uu___3 = + FStarC_Syntax_Subst.subst subst + hd1.FStarC_Syntax_Syntax.sort in + { + FStarC_Syntax_Syntax.ppname = + (hd1.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (hd1.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = uu___3 + } in + let hd21 = + let uu___3 = + FStarC_Syntax_Subst.subst subst + hd2.FStarC_Syntax_Syntax.sort in + { + FStarC_Syntax_Syntax.ppname = + (hd2.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (hd2.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = uu___3 + } in + let uu___3 = + mk_t_problem wl1 scope orig + hd11.FStarC_Syntax_Syntax.sort + (invert_rel (p_rel orig)) + hd21.FStarC_Syntax_Syntax.sort + FStar_Pervasives_Native.None + "Formal parameter" in + (match uu___3 with + | (prob, wl2) -> + let hd12 = + FStarC_Syntax_Syntax.freshen_bv hd11 in + let subst1 = + let uu___4 = + FStarC_Syntax_Subst.shift_subst + Prims.int_one subst in + (FStarC_Syntax_Syntax.DB + (Prims.int_zero, hd12)) + :: uu___4 in + let uu___4 = + aux wl2 + (FStarC_Compiler_List.op_At scope + [{ + FStarC_Syntax_Syntax.binder_bv = + hd12; + FStarC_Syntax_Syntax.binder_qual + = + (x.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity + = + (x.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs + = + (x.FStarC_Syntax_Syntax.binder_attrs) + }]) subst1 xs1 ys1 in + (match uu___4 with + | (FStar_Pervasives.Inl (sub_probs, phi), + wl3) -> + let phi1 = + let uu___5 = + FStarC_TypeChecker_Env.close_forall + (p_env wl3 prob) + [{ + FStarC_Syntax_Syntax.binder_bv + = hd12; + FStarC_Syntax_Syntax.binder_qual + = + (x.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity + = + (x.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs + = + (x.FStarC_Syntax_Syntax.binder_attrs) + }] phi in + FStarC_Syntax_Util.mk_conj + (p_guard prob) uu___5 in + ((let uu___6 = + FStarC_Compiler_Effect.op_Bang + dbg_Rel in + if uu___6 + then + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + phi1 in + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_bv + hd12 in + FStarC_Compiler_Util.print2 + "Formula is %s\n\thd1=%s\n" + uu___7 uu___8 + else ()); + ((FStar_Pervasives.Inl + ((prob :: sub_probs), phi1)), + wl3)) + | fail -> fail)))) + | uu___1 -> + ((FStar_Pervasives.Inr + "arity or argument-qualifier mismatch"), wl1) in + let uu___1 = aux wl [] [] bs1 bs2 in + match uu___1 with + | (FStar_Pervasives.Inr msg, wl1) -> giveup_lit wl1 msg orig + | (FStar_Pervasives.Inl (sub_probs, phi), wl1) -> + let wl2 = + solve_prob orig (FStar_Pervasives_Native.Some phi) [] wl1 in + let uu___2 = attempt sub_probs wl2 in solve uu___2) +and (try_solve_without_smt_or_else : + worklist -> + (worklist -> solution) -> + (worklist -> (FStarC_TypeChecker_Common.prob * lstring) -> solution) -> + solution) + = + fun wl -> + fun try_solve -> + fun else_solve -> + let wl' = + { + attempting = []; + wl_deferred = + (Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic (FStarC_Compiler_CList.listlike_clist ())))); + wl_deferred_to_tac = (wl.wl_deferred_to_tac); + ctr = (wl.ctr); + defer_ok = NoDefer; + smt_ok = false; + umax_heuristic_ok = false; + tcenv = (wl.tcenv); + wl_implicits = + (Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic (FStarC_Compiler_CList.listlike_clist ())))); + repr_subcomp_allowed = (wl.repr_subcomp_allowed); + typeclass_variables = (wl.typeclass_variables) + } in + let tx = FStarC_Syntax_Unionfind.new_transaction () in + let uu___ = try_solve wl' in + match uu___ with + | Success (uu___1, defer_to_tac, imps) -> + (FStarC_Syntax_Unionfind.commit tx; + (let wl1 = + extend_wl wl + (Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic (FStarC_Compiler_CList.listlike_clist ())))) + defer_to_tac imps in + solve wl1)) + | Failed (p, s) -> + (FStarC_Syntax_Unionfind.rollback tx; else_solve wl (p, s)) +and (try_solve_then_or_else : + worklist -> + (worklist -> solution) -> + (worklist -> solution) -> (worklist -> solution) -> solution) + = + fun wl -> + fun try_solve -> + fun then_solve -> + fun else_solve -> + let empty_wl = + { + attempting = []; + wl_deferred = + (Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic (FStarC_Compiler_CList.listlike_clist ())))); + wl_deferred_to_tac = (wl.wl_deferred_to_tac); + ctr = (wl.ctr); + defer_ok = NoDefer; + smt_ok = (wl.smt_ok); + umax_heuristic_ok = (wl.umax_heuristic_ok); + tcenv = (wl.tcenv); + wl_implicits = + (Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic (FStarC_Compiler_CList.listlike_clist ())))); + repr_subcomp_allowed = (wl.repr_subcomp_allowed); + typeclass_variables = (wl.typeclass_variables) + } in + let tx = FStarC_Syntax_Unionfind.new_transaction () in + let uu___ = try_solve empty_wl in + match uu___ with + | Success (uu___1, defer_to_tac, imps) -> + (FStarC_Syntax_Unionfind.commit tx; + (let wl1 = + extend_wl wl + (Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist ())))) + defer_to_tac imps in + then_solve wl1)) + | Failed (p, s) -> + (FStarC_Syntax_Unionfind.rollback tx; else_solve wl) +and (try_solve_probs_without_smt : + worklist -> + (worklist -> (FStarC_TypeChecker_Common.probs * worklist)) -> + (worklist, lstring) FStar_Pervasives.either) + = + fun wl -> + fun probs -> + let uu___ = probs wl in + match uu___ with + | (probs1, wl') -> + let wl'1 = + { + attempting = probs1; + wl_deferred = + (Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic (FStarC_Compiler_CList.listlike_clist ())))); + wl_deferred_to_tac = (wl.wl_deferred_to_tac); + ctr = (wl.ctr); + defer_ok = NoDefer; + smt_ok = false; + umax_heuristic_ok = false; + tcenv = (wl.tcenv); + wl_implicits = + (Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic (FStarC_Compiler_CList.listlike_clist ())))); + repr_subcomp_allowed = (wl.repr_subcomp_allowed); + typeclass_variables = (wl.typeclass_variables) + } in + let uu___1 = solve wl'1 in + (match uu___1 with + | Success (uu___2, defer_to_tac, imps) -> + let wl1 = + extend_wl wl + (Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic (FStarC_Compiler_CList.listlike_clist ())))) + defer_to_tac imps in + FStar_Pervasives.Inl wl1 + | Failed (uu___2, ls) -> FStar_Pervasives.Inr ls) +and (solve_t : tprob -> worklist -> solution) = + fun problem -> + fun wl -> + def_check_prob "solve_t" (FStarC_TypeChecker_Common.TProb problem); + (let uu___1 = compress_tprob wl problem in solve_t' uu___1 wl) +and (solve_t_flex_rigid_eq : + FStarC_TypeChecker_Common.prob -> + worklist -> flex_t -> FStarC_Syntax_Syntax.term -> solution) + = + fun orig -> + fun wl -> + fun lhs -> + fun rhs -> + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term rhs in + FStarC_Compiler_Util.print1 "solve_t_flex_rigid_eq rhs=%s\n" + uu___2 + else ()); + (let uu___1 = should_defer_flex_to_user_tac wl lhs in + if uu___1 + then defer_to_user_tac orig (flex_reason lhs) wl + else + (let mk_solution env lhs1 bs rhs1 = + let bs_orig = bs in + let rhs_orig = rhs1 in + let uu___3 = lhs1 in + match uu___3 with + | Flex (uu___4, ctx_u, args) -> + let uu___5 = + let bv_not_free_in_arg x arg = + let uu___6 = + let uu___7 = + FStarC_Syntax_Free.names + (FStar_Pervasives_Native.fst arg) in + FStarC_Class_Setlike.mem () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) x + (Obj.magic uu___7) in + Prims.op_Negation uu___6 in + let bv_not_free_in_args x args1 = + FStarC_Compiler_Util.for_all (bv_not_free_in_arg x) + args1 in + let binder_matches_aqual b aq = + match ((b.FStarC_Syntax_Syntax.binder_qual), aq) with + | (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None) -> true + | (FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Implicit uu___6), + FStar_Pervasives_Native.Some a) -> + a.FStarC_Syntax_Syntax.aqual_implicit && + (FStarC_Syntax_Util.eqlist + (fun x -> + fun y -> + let uu___7 = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm + env x y in + uu___7 = + FStarC_TypeChecker_TermEqAndSimplify.Equal) + b.FStarC_Syntax_Syntax.binder_attrs + a.FStarC_Syntax_Syntax.aqual_attributes) + | uu___6 -> false in + let rec remove_matching_prefix lhs_binders rhs_args = + match (lhs_binders, rhs_args) with + | ([], uu___6) -> (lhs_binders, rhs_args) + | (uu___6, []) -> (lhs_binders, rhs_args) + | (b::lhs_tl, (t, aq)::rhs_tl) -> + let uu___6 = + let uu___7 = FStarC_Syntax_Subst.compress t in + uu___7.FStarC_Syntax_Syntax.n in + (match uu___6 with + | FStarC_Syntax_Syntax.Tm_name x when + ((FStarC_Syntax_Syntax.bv_eq + b.FStarC_Syntax_Syntax.binder_bv x) + && (binder_matches_aqual b aq)) + && + (bv_not_free_in_args + b.FStarC_Syntax_Syntax.binder_bv rhs_tl) + -> remove_matching_prefix lhs_tl rhs_tl + | uu___7 -> (lhs_binders, rhs_args)) in + let uu___6 = FStarC_Syntax_Util.head_and_args rhs1 in + match uu___6 with + | (rhs_hd, rhs_args) -> + let uu___7 = + let uu___8 = + remove_matching_prefix + (FStarC_Compiler_List.rev bs_orig) + (FStarC_Compiler_List.rev rhs_args) in + match uu___8 with + | (bs_rev, args_rev) -> + ((FStarC_Compiler_List.rev bs_rev), + (FStarC_Compiler_List.rev args_rev)) in + (match uu___7 with + | (bs1, rhs_args1) -> + let uu___8 = + FStarC_Syntax_Syntax.mk_Tm_app rhs_hd + rhs_args1 rhs1.FStarC_Syntax_Syntax.pos in + (bs1, uu___8)) in + (match uu___5 with + | (bs1, rhs2) -> + let sol = + match bs1 with + | [] -> rhs2 + | uu___6 -> + let uu___7 = + FStarC_Syntax_Util.ctx_uvar_typ ctx_u in + let uu___8 = sn_binders env bs1 in + u_abs uu___7 uu___8 rhs2 in + [TERM (ctx_u, sol)]) in + let try_quasi_pattern orig1 env wl1 lhs1 rhs1 = + (let uu___4 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___4 + then FStarC_Compiler_Util.print_string "try_quasi_pattern\n" + else ()); + (let uu___4 = quasi_pattern env lhs1 in + match uu___4 with + | FStar_Pervasives_Native.None -> + ((FStar_Pervasives.Inl "Not a quasi-pattern"), wl1) + | FStar_Pervasives_Native.Some (bs, uu___5) -> + let uu___6 = lhs1 in + (match uu___6 with + | Flex (t_lhs, ctx_u, args) -> + let uu___7 = occurs_check ctx_u rhs1 in + (match uu___7 with + | (uvars, occurs_ok, msg) -> + if Prims.op_Negation occurs_ok + then + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Compiler_Option.get msg in + Prims.strcat + "quasi-pattern, occurs-check failed: " + uu___10 in + FStar_Pervasives.Inl uu___9 in + (uu___8, wl1) + else + (let fvs_lhs = + binders_as_bv_set + (FStarC_Compiler_List.op_At + ctx_u.FStarC_Syntax_Syntax.ctx_uvar_binders + bs) in + let fvs_rhs = FStarC_Syntax_Free.names rhs1 in + let uu___9 = + let uu___10 = + FStarC_Class_Setlike.subset () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) + (Obj.magic fvs_rhs) + (Obj.magic fvs_lhs) in + Prims.op_Negation uu___10 in + if uu___9 + then + ((FStar_Pervasives.Inl + "quasi-pattern, free names on the RHS are not included in the LHS"), + wl1) + else + (let uu___11 = + let uu___12 = + mk_solution env lhs1 bs rhs1 in + FStar_Pervasives.Inr uu___12 in + let uu___12 = + restrict_all_uvars env ctx_u [] uvars + wl1 in + (uu___11, uu___12)))))) in + let imitate_app orig1 env wl1 lhs1 bs_lhs t_res_lhs rhs1 = + let uu___3 = FStarC_Syntax_Util.head_and_args rhs1 in + match uu___3 with + | (rhs_hd, args) -> + let uu___4 = FStarC_Compiler_Util.prefix args in + (match uu___4 with + | (args_rhs, last_arg_rhs) -> + let rhs' = + FStarC_Syntax_Syntax.mk_Tm_app rhs_hd args_rhs + rhs1.FStarC_Syntax_Syntax.pos in + let uu___5 = lhs1 in + (match uu___5 with + | Flex (t_lhs, u_lhs, _lhs_args) -> + let uu___6 = + let uu___7 = + let env1 = p_env wl1 orig1 in + env1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + { + FStarC_TypeChecker_Env.solver = + (env1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + FStar_Pervasives_Native.None; + FStarC_TypeChecker_Env.sigtab = + (env1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp + = + (env1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = true; + FStarC_TypeChecker_Env.lax_universes = + (env1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (env1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force + = + (env1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (env1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (env1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (env1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths + = + (env1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (env1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info + = + (env1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab + = + (env1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (env1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (env1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (env1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (env1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env1.FStarC_TypeChecker_Env.missing_decl) + } + (FStar_Pervasives_Native.fst last_arg_rhs) + false in + match uu___7 with + | (t_last_arg, uu___8) -> + let uu___9 = + let b = + FStarC_Syntax_Syntax.null_binder + t_last_arg in + let uu___10 = + let uu___11 = + FStarC_Syntax_Syntax.mk_Total + t_res_lhs in + FStarC_Syntax_Util.arrow [b] uu___11 in + copy_uvar u_lhs + (FStarC_Compiler_List.op_At bs_lhs + [b]) uu___10 wl1 in + (match uu___9 with + | (uu___10, lhs', wl2) -> + let uu___11 = + copy_uvar u_lhs bs_lhs t_last_arg + wl2 in + (match uu___11 with + | (uu___12, lhs'_last_arg, wl3) -> + (lhs', lhs'_last_arg, wl3))) in + (match uu___6 with + | (lhs', lhs'_last_arg, wl2) -> + let sol = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Syntax_Syntax.mk_Tm_app + lhs' + [(lhs'_last_arg, + (FStar_Pervasives_Native.snd + last_arg_rhs))] + t_lhs.FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Util.abs bs_lhs + uu___10 + (FStar_Pervasives_Native.Some + (FStarC_Syntax_Util.residual_tot + t_res_lhs)) in + (u_lhs, uu___9) in + TERM uu___8 in + [uu___7] in + let uu___7 = + let uu___8 = + mk_t_problem wl2 [] orig1 lhs' + FStarC_TypeChecker_Common.EQ rhs' + FStar_Pervasives_Native.None + "first-order lhs" in + match uu___8 with + | (p1, wl3) -> + let uu___9 = + mk_t_problem wl3 [] orig1 + lhs'_last_arg + FStarC_TypeChecker_Common.EQ + (FStar_Pervasives_Native.fst + last_arg_rhs) + FStar_Pervasives_Native.None + "first-order rhs" in + (match uu___9 with + | (p2, wl4) -> ([p1; p2], wl4)) in + (match uu___7 with + | (sub_probs, wl3) -> + let uu___8 = + let uu___9 = + solve_prob orig1 + FStar_Pervasives_Native.None + sol wl3 in + attempt sub_probs uu___9 in + solve uu___8)))) in + let imitate orig1 env wl1 lhs1 rhs1 = + (let uu___4 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___4 + then FStarC_Compiler_Util.print_string "imitate\n" + else ()); + (let is_app rhs2 = + let uu___4 = FStarC_Syntax_Util.head_and_args rhs2 in + match uu___4 with + | (uu___5, args) -> + (match args with | [] -> false | uu___6 -> true) in + let is_arrow rhs2 = + let uu___4 = + let uu___5 = FStarC_Syntax_Subst.compress rhs2 in + uu___5.FStarC_Syntax_Syntax.n in + match uu___4 with + | FStarC_Syntax_Syntax.Tm_arrow uu___5 -> true + | uu___5 -> false in + let uu___4 = quasi_pattern env lhs1 in + match uu___4 with + | FStar_Pervasives_Native.None -> + let msg = + mklstr + (fun uu___5 -> + let uu___6 = prob_to_string env orig1 in + FStarC_Compiler_Util.format1 + "imitate heuristic cannot solve %s; lhs not a quasi-pattern" + uu___6) in + giveup_or_defer orig1 wl1 + FStarC_TypeChecker_Common.Deferred_first_order_heuristic_failed + msg + | FStar_Pervasives_Native.Some (bs_lhs, t_res_lhs) -> + let uu___5 = is_app rhs1 in + if uu___5 + then + imitate_app orig1 env wl1 lhs1 bs_lhs t_res_lhs rhs1 + else + (let uu___7 = is_arrow rhs1 in + if uu___7 + then + imitate_arrow orig1 wl1 lhs1 bs_lhs t_res_lhs + FStarC_TypeChecker_Common.EQ rhs1 + else + (let msg = + mklstr + (fun uu___9 -> + let uu___10 = prob_to_string env orig1 in + FStarC_Compiler_Util.format1 + "imitate heuristic cannot solve %s; rhs not an app or arrow" + uu___10) in + giveup_or_defer orig1 wl1 + FStarC_TypeChecker_Common.Deferred_first_order_heuristic_failed + msg))) in + let try_first_order orig1 env wl1 lhs1 rhs1 = + let inapplicable msg lstring_opt = + (let uu___4 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___4 + then + let extra_msg = + match lstring_opt with + | FStar_Pervasives_Native.None -> "" + | FStar_Pervasives_Native.Some l -> + FStarC_Thunk.force l in + FStarC_Compiler_Util.print2 + "try_first_order failed because: %s\n%s\n" msg + extra_msg + else ()); + FStar_Pervasives.Inl "first_order doesn't apply" in + (let uu___4 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___4 + then + let uu___5 = flex_t_to_string lhs1 in + let uu___6 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + rhs1 in + FStarC_Compiler_Util.print2 + "try_first_order\n\tlhs=%s\n\trhs=%s\n" uu___5 uu___6 + else ()); + (let uu___4 = lhs1 in + match uu___4 with + | Flex (_t1, ctx_uv, args_lhs) -> + let n_args_lhs = FStarC_Compiler_List.length args_lhs in + let uu___5 = FStarC_Syntax_Util.head_and_args rhs1 in + (match uu___5 with + | (head, args_rhs) -> + let n_args_rhs = + FStarC_Compiler_List.length args_rhs in + if n_args_lhs > n_args_rhs + then + inapplicable "not enough args" + FStar_Pervasives_Native.None + else + (let i = n_args_rhs - n_args_lhs in + let uu___7 = + FStarC_Compiler_List.splitAt i args_rhs in + match uu___7 with + | (prefix, args_rhs1) -> + let head1 = + FStarC_Syntax_Syntax.mk_Tm_app head prefix + head.FStarC_Syntax_Syntax.pos in + let uu___8 = occurs_check ctx_uv head1 in + (match uu___8 with + | (uvars_head, occurs_ok, uu___9) -> + if Prims.op_Negation occurs_ok + then + inapplicable "occurs check failed" + FStar_Pervasives_Native.None + else + (let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Syntax_Free.names head1 in + let uu___14 = + binders_as_bv_set + ctx_uv.FStarC_Syntax_Syntax.ctx_uvar_binders in + FStarC_Class_Setlike.subset () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) + (Obj.magic uu___13) + (Obj.magic uu___14) in + Prims.op_Negation uu___12 in + if uu___11 + then + inapplicable + "free name inclusion failed" + FStar_Pervasives_Native.None + else + (let uu___13 = + env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + { + FStarC_TypeChecker_Env.solver + = + (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range + = + (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule + = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma + = + (env.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig + = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache + = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules + = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ + = + FStar_Pervasives_Native.None; + FStarC_TypeChecker_Env.sigtab + = + (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab + = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp + = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects + = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize + = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs + = + (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level + = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars + = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict + = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface + = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit + = true; + FStarC_TypeChecker_Env.lax_universes + = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 + = + (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard + = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking + = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping + = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics + = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce + = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term + = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of + = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force + = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths + = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns + = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook + = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice + = + (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess + = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess + = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info + = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks + = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv + = + (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe + = + (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab + = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check + = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl + = + (env.FStarC_TypeChecker_Env.missing_decl) + } head1 false in + match uu___13 with + | (t_head, uu___14) -> + let tx = + FStarC_Syntax_Unionfind.new_transaction + () in + let solve_sub_probs_if_head_types_equal + head_uvars_to_restrict wl2 + = + let sol = + [TERM (ctx_uv, head1)] in + let wl3 = + restrict_all_uvars env + ctx_uv [] + head_uvars_to_restrict + wl2 in + let wl4 = + solve_prob orig1 + FStar_Pervasives_Native.None + sol wl3 in + let uu___15 = + FStarC_Compiler_List.fold_left2 + (fun uu___16 -> + fun uu___17 -> + fun uu___18 -> + match (uu___16, + uu___17, + uu___18) + with + | ((probs, wl5), + (arg_lhs, + uu___19), + (arg_rhs, + uu___20)) -> + let uu___21 + = + mk_t_problem + wl5 [] + orig1 + arg_lhs + FStarC_TypeChecker_Common.EQ + arg_rhs + FStar_Pervasives_Native.None + "first-order arg" in + (match uu___21 + with + | (p, wl6) + -> + ((p :: + probs), + wl6))) + ([], wl4) args_lhs + args_rhs1 in + match uu___15 with + | (sub_probs, wl5) -> + let wl' = + { + attempting = + sub_probs; + wl_deferred = + (Obj.magic + (FStarC_Class_Listlike.empty + () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist + ())))); + wl_deferred_to_tac + = + (wl5.wl_deferred_to_tac); + ctr = (wl5.ctr); + defer_ok = NoDefer; + smt_ok = false; + umax_heuristic_ok = + (wl5.umax_heuristic_ok); + tcenv = (wl5.tcenv); + wl_implicits = + (Obj.magic + (FStarC_Class_Listlike.empty + () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist + ())))); + repr_subcomp_allowed + = + (wl5.repr_subcomp_allowed); + typeclass_variables + = + (wl5.typeclass_variables) + } in + let uu___16 = solve wl' in + (match uu___16 with + | Success + (uu___17, + defer_to_tac, + imps) + -> + let wl6 = + extend_wl wl5 + (Obj.magic + (FStarC_Class_Listlike.empty + () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist + ())))) + defer_to_tac + imps in + (FStarC_Syntax_Unionfind.commit + tx; + FStar_Pervasives.Inr + wl6) + | Failed + (uu___17, + lstring1) + -> + (FStarC_Syntax_Unionfind.rollback + tx; + inapplicable + "Subprobs failed: " + (FStar_Pervasives_Native.Some + lstring1))) in + let uu___15 = + let uu___16 = + let uu___17 = + FStarC_Syntax_Util.ctx_uvar_typ + ctx_uv in + FStarC_TypeChecker_TermEqAndSimplify.eq_tm + env t_head uu___17 in + uu___16 = + FStarC_TypeChecker_TermEqAndSimplify.Equal in + if uu___15 + then + solve_sub_probs_if_head_types_equal + uvars_head wl1 + else + ((let uu___18 = + FStarC_Compiler_Effect.op_Bang + dbg_Rel in + if uu___18 + then + let uu___19 = + let uu___20 = + FStarC_Syntax_Util.ctx_uvar_typ + ctx_uv in + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + uu___20 in + let uu___20 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t_head in + FStarC_Compiler_Util.print2 + "first-order: head type mismatch:\n\tlhs=%s\n\trhs=%s\n" + uu___19 uu___20 + else ()); + (let typ_equality_prob wl2 + = + let uu___18 = + let uu___19 = + FStarC_Syntax_Util.ctx_uvar_typ + ctx_uv in + mk_t_problem wl2 [] + orig1 uu___19 + FStarC_TypeChecker_Common.EQ + t_head + FStar_Pervasives_Native.None + "first-order head type" in + match uu___18 with + | (p, wl3) -> + ([p], wl3) in + let uu___18 = + try_solve_probs_without_smt + wl1 typ_equality_prob in + match uu___18 with + | FStar_Pervasives.Inl + wl2 -> + let uu___19 = + let uu___20 = + FStarC_Syntax_Free.uvars + head1 in + FStarC_Class_Setlike.elems + () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) + (Obj.magic + uu___20) in + solve_sub_probs_if_head_types_equal + uu___19 wl2 + | FStar_Pervasives.Inr + msg -> + (FStarC_Syntax_Unionfind.rollback + tx; + inapplicable + "first-order: head type mismatch" + (FStar_Pervasives_Native.Some + msg)))))))))) in + match p_rel orig with + | FStarC_TypeChecker_Common.SUB -> + if wl.defer_ok = DeferAny + then + let uu___3 = FStarC_Thunk.mkv "flex-rigid subtyping" in + giveup_or_defer orig wl + FStarC_TypeChecker_Common.Deferred_flex uu___3 + else solve_t_flex_rigid_eq (make_prob_eq orig) wl lhs rhs + | FStarC_TypeChecker_Common.SUBINV -> + if wl.defer_ok = DeferAny + then + let uu___3 = FStarC_Thunk.mkv "flex-rigid subtyping" in + giveup_or_defer orig wl + FStarC_TypeChecker_Common.Deferred_flex uu___3 + else solve_t_flex_rigid_eq (make_prob_eq orig) wl lhs rhs + | FStarC_TypeChecker_Common.EQ -> + let uu___3 = lhs in + (match uu___3 with + | Flex (_t1, ctx_uv, args_lhs) -> + let env = p_env wl orig in + let uu___4 = + pat_vars env + ctx_uv.FStarC_Syntax_Syntax.ctx_uvar_binders + args_lhs in + (match uu___4 with + | FStar_Pervasives_Native.Some lhs_binders -> + ((let uu___6 = + FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___6 + then + FStarC_Compiler_Util.print_string + "it's a pattern\n" + else ()); + (let rhs1 = sn env rhs in + let fvs1 = + binders_as_bv_set + (FStarC_Compiler_List.op_At + ctx_uv.FStarC_Syntax_Syntax.ctx_uvar_binders + lhs_binders) in + let fvs2 = FStarC_Syntax_Free.names rhs1 in + let uu___6 = occurs_check ctx_uv rhs1 in + match uu___6 with + | (uvars, occurs_ok, msg) -> + let uu___7 = + if occurs_ok + then ((uvars, occurs_ok, msg), rhs1) + else + (let rhs2 = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.Weak; + FStarC_TypeChecker_Env.HNF; + FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.Unascribe] + (p_env wl orig) rhs1 in + let uu___9 = occurs_check ctx_uv rhs2 in + (uu___9, rhs2)) in + (match uu___7 with + | ((uvars1, occurs_ok1, msg1), rhs2) -> + let uu___8 = + (term_is_uvar ctx_uv rhs2) && + (Prims.uu___is_Nil args_lhs) in + if uu___8 + then + let uu___9 = + solve_prob orig + FStar_Pervasives_Native.None [] + wl in + solve uu___9 + else + if Prims.op_Negation occurs_ok1 + then + (let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Compiler_Option.get + msg1 in + Prims.strcat + "occurs-check failed: " + uu___12 in + FStarC_Thunk.mkv uu___11 in + giveup_or_defer orig wl + FStarC_TypeChecker_Common.Deferred_occur_check_failed + uu___10) + else + (let uu___11 = + FStarC_Class_Setlike.subset () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) + (Obj.magic fvs2) + (Obj.magic fvs1) in + if uu___11 + then + let sol = + mk_solution env lhs + lhs_binders rhs2 in + let wl1 = + restrict_all_uvars env ctx_uv + lhs_binders uvars1 wl in + let uu___12 = + solve_prob orig + FStar_Pervasives_Native.None + sol wl1 in + solve uu___12 + else + if wl.defer_ok = DeferAny + then + (let msg2 = + mklstr + (fun uu___13 -> + let uu___14 = + FStarC_Class_Show.show + (FStarC_Compiler_FlatSet.showable_set + FStarC_Syntax_Syntax.ord_bv + FStarC_Syntax_Print.showable_bv) + fvs2 in + let uu___15 = + FStarC_Class_Show.show + (FStarC_Compiler_FlatSet.showable_set + FStarC_Syntax_Syntax.ord_bv + FStarC_Syntax_Print.showable_bv) + fvs1 in + let uu___16 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binder) + (FStarC_Compiler_List.op_At + ctx_uv.FStarC_Syntax_Syntax.ctx_uvar_binders + lhs_binders) in + FStarC_Compiler_Util.format3 + "free names in the RHS {%s} are out of scope for the LHS: {%s}, {%s}" + uu___14 uu___15 + uu___16) in + giveup_or_defer orig wl + FStarC_TypeChecker_Common.Deferred_free_names_check_failed + msg2) + else + imitate orig env wl lhs rhs2)))) + | uu___5 -> + if wl.defer_ok = DeferAny + then + let uu___6 = FStarC_Thunk.mkv "Not a pattern" in + giveup_or_defer orig wl + FStarC_TypeChecker_Common.Deferred_not_a_pattern + uu___6 + else + (let uu___7 = + try_first_order orig env wl lhs rhs in + match uu___7 with + | FStar_Pervasives.Inr wl1 -> solve wl1 + | uu___8 -> + let uu___9 = + try_quasi_pattern orig env wl lhs rhs in + (match uu___9 with + | (FStar_Pervasives.Inr sol, wl1) -> + let uu___10 = + solve_prob orig + FStar_Pervasives_Native.None sol + wl1 in + solve uu___10 + | (FStar_Pervasives.Inl msg, uu___10) -> + imitate orig env wl lhs rhs)))))) +and (solve_t_flex_flex : + FStarC_TypeChecker_Env.env_t -> + FStarC_TypeChecker_Common.prob -> + worklist -> flex_t -> flex_t -> solution) + = + fun env -> + fun orig -> + fun wl -> + fun lhs -> + fun rhs -> + let should_run_meta_arg_tac flex = + let uv = flex_uvar flex in + ((flex_uvar_has_meta_tac uv) && + (let uu___ = + let uu___1 = FStarC_Syntax_Util.ctx_uvar_typ uv in + has_free_uvars uu___1 in + Prims.op_Negation uu___)) + && + (let uu___ = + gamma_has_free_uvars + uv.FStarC_Syntax_Syntax.ctx_uvar_gamma in + Prims.op_Negation uu___) in + let run_meta_arg_tac_and_try_again flex = + let uv = flex_uvar flex in + let t = run_meta_arg_tac env uv in + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_ctxu + uv in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.print2 + "solve_t_flex_flex: solving meta arg uvar %s with %s\n" + uu___2 uu___3 + else ()); + set_uvar env uv FStar_Pervasives_Native.None t; + (let uu___2 = attempt [orig] wl in solve uu___2) in + match p_rel orig with + | FStarC_TypeChecker_Common.SUB -> + if wl.defer_ok = DeferAny + then + let uu___ = FStarC_Thunk.mkv "flex-flex subtyping" in + giveup_or_defer_flex_flex orig wl + FStarC_TypeChecker_Common.Deferred_flex uu___ + else solve_t_flex_flex env (make_prob_eq orig) wl lhs rhs + | FStarC_TypeChecker_Common.SUBINV -> + if wl.defer_ok = DeferAny + then + let uu___ = FStarC_Thunk.mkv "flex-flex subtyping" in + giveup_or_defer_flex_flex orig wl + FStarC_TypeChecker_Common.Deferred_flex uu___ + else solve_t_flex_flex env (make_prob_eq orig) wl lhs rhs + | FStarC_TypeChecker_Common.EQ -> + let uu___ = + (should_defer_flex_to_user_tac wl lhs) || + (should_defer_flex_to_user_tac wl rhs) in + if uu___ + then + defer_to_user_tac orig + (Prims.strcat (flex_reason lhs) + (Prims.strcat ", " (flex_reason rhs))) wl + else + if + ((wl.defer_ok = DeferAny) || + (wl.defer_ok = DeferFlexFlexOnly)) + && + ((Prims.op_Negation (is_flex_pat lhs)) || + (Prims.op_Negation (is_flex_pat rhs))) + then + (let uu___2 = FStarC_Thunk.mkv "flex-flex non-pattern" in + giveup_or_defer_flex_flex orig wl + FStarC_TypeChecker_Common.Deferred_flex_flex_nonpattern + uu___2) + else + (let uu___3 = should_run_meta_arg_tac lhs in + if uu___3 + then run_meta_arg_tac_and_try_again lhs + else + (let uu___5 = should_run_meta_arg_tac rhs in + if uu___5 + then run_meta_arg_tac_and_try_again rhs + else + (let rec occurs_bs u bs = + match bs with + | [] -> false + | b::bs1 -> + (let uu___7 = + occurs u + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + FStar_Pervasives_Native.snd uu___7) || + (occurs_bs u bs1) in + let uu___7 = + let uu___8 = quasi_pattern env lhs in + let uu___9 = quasi_pattern env rhs in + (uu___8, uu___9) in + match uu___7 with + | (FStar_Pervasives_Native.Some + (binders_lhs, t_res_lhs), + FStar_Pervasives_Native.Some + (binders_rhs, t_res_rhs)) -> + let uu___8 = lhs in + (match uu___8 with + | Flex + ({ FStarC_Syntax_Syntax.n = uu___9; + FStarC_Syntax_Syntax.pos = range; + FStarC_Syntax_Syntax.vars = uu___10; + FStarC_Syntax_Syntax.hash_code = + uu___11;_}, + u_lhs, uu___12) + -> + let uu___13 = occurs_bs u_lhs binders_lhs in + if uu___13 + then + let uu___14 = + FStarC_Thunk.mkv + "flex-flex: occurs check failed on the LHS flex quasi-pattern" in + giveup_or_defer orig wl + FStarC_TypeChecker_Common.Deferred_flex_flex_nonpattern + uu___14 + else + (let uu___15 = rhs in + match uu___15 with + | Flex (uu___16, u_rhs, uu___17) -> + let uu___18 = + (FStarC_Syntax_Unionfind.equiv + u_lhs.FStarC_Syntax_Syntax.ctx_uvar_head + u_rhs.FStarC_Syntax_Syntax.ctx_uvar_head) + && + (binders_eq binders_lhs + binders_rhs) in + if uu___18 + then + let uu___19 = + solve_prob orig + FStar_Pervasives_Native.None + [] wl in + solve uu___19 + else + (let uu___20 = + maximal_prefix + u_lhs.FStarC_Syntax_Syntax.ctx_uvar_binders + u_rhs.FStarC_Syntax_Syntax.ctx_uvar_binders in + match uu___20 with + | (ctx_w, (ctx_l, ctx_r)) -> + let gamma_w = + gamma_until + u_lhs.FStarC_Syntax_Syntax.ctx_uvar_gamma + ctx_w in + let zs = + intersect_binders gamma_w + (FStarC_Compiler_List.op_At + ctx_l binders_lhs) + (FStarC_Compiler_List.op_At + ctx_r binders_rhs) in + let new_uvar_typ = + let uu___21 = + FStarC_Syntax_Syntax.mk_Total + t_res_lhs in + FStarC_Syntax_Util.arrow + zs uu___21 in + let uu___21 = + (let uu___22 = + occurs u_lhs + new_uvar_typ in + FStar_Pervasives_Native.snd + uu___22) + || + ((let uu___22 = + FStarC_Syntax_Unionfind.equiv + u_lhs.FStarC_Syntax_Syntax.ctx_uvar_head + u_rhs.FStarC_Syntax_Syntax.ctx_uvar_head in + Prims.op_Negation + uu___22) + && + (let uu___22 = + occurs u_rhs + new_uvar_typ in + FStar_Pervasives_Native.snd + uu___22)) in + if uu___21 + then + let uu___22 = + let uu___23 = + let uu___24 = + FStarC_Class_Show.show + uu___0 + wl.defer_ok in + FStarC_Compiler_Util.format1 + "flex-flex: occurs\n defer_ok=%s\n" + uu___24 in + FStarC_Thunk.mkv + uu___23 in + giveup_or_defer_flex_flex + orig wl + FStarC_TypeChecker_Common.Deferred_flex_flex_nonpattern + uu___22 + else + (let uu___23 = + let uu___24 = + let uu___25 = + FStarC_Syntax_Util.ctx_uvar_should_check + u_lhs in + let uu___26 = + FStarC_Syntax_Util.ctx_uvar_should_check + u_rhs in + (uu___25, uu___26) in + match uu___24 with + | (FStarC_Syntax_Syntax.Allow_untyped + r, + FStarC_Syntax_Syntax.Allow_untyped + uu___25) -> + ((FStarC_Syntax_Syntax.Allow_untyped + r), false) + | (FStarC_Syntax_Syntax.Allow_ghost + r, uu___25) -> + ((FStarC_Syntax_Syntax.Allow_ghost + r), true) + | (uu___25, + FStarC_Syntax_Syntax.Allow_ghost + r) -> + ((FStarC_Syntax_Syntax.Allow_ghost + r), true) + | uu___25 -> + (FStarC_Syntax_Syntax.Strict, + false) in + match uu___23 with + | (new_uvar_should_check, + is_ghost) -> + let uu___24 = + new_uvar + (Prims.strcat + "flex-flex quasi:" + (Prims.strcat + "\tlhs=" + (Prims.strcat + u_lhs.FStarC_Syntax_Syntax.ctx_uvar_reason + (Prims.strcat + "\trhs=" + u_rhs.FStarC_Syntax_Syntax.ctx_uvar_reason)))) + wl range gamma_w + ctx_w + new_uvar_typ + new_uvar_should_check + (if + FStar_Pervasives_Native.uu___is_Some + u_lhs.FStarC_Syntax_Syntax.ctx_uvar_meta + then + u_lhs.FStarC_Syntax_Syntax.ctx_uvar_meta + else + u_rhs.FStarC_Syntax_Syntax.ctx_uvar_meta) in + (match uu___24 with + | (uu___25, w, wl1) + -> + let w_app = + let uu___26 = + FStarC_Compiler_List.map + ( + fun + uu___27 + -> + match uu___27 + with + | + { + FStarC_Syntax_Syntax.binder_bv + = z; + FStarC_Syntax_Syntax.binder_qual + = uu___28; + FStarC_Syntax_Syntax.binder_positivity + = uu___29; + FStarC_Syntax_Syntax.binder_attrs + = uu___30;_} + -> + let uu___31 + = + FStarC_Syntax_Syntax.bv_to_name + z in + FStarC_Syntax_Syntax.as_arg + uu___31) + zs in + FStarC_Syntax_Syntax.mk_Tm_app + w uu___26 + w.FStarC_Syntax_Syntax.pos in + ((let uu___27 = + FStarC_Compiler_Effect.op_Bang + dbg_Rel in + if uu___27 + then + let uu___28 + = + let uu___29 + = + flex_t_to_string + lhs in + let uu___30 + = + let uu___31 + = + flex_t_to_string + rhs in + let uu___32 + = + let uu___33 + = + term_to_string + w in + let uu___34 + = + let uu___35 + = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binder) + (FStarC_Compiler_List.op_At + ctx_l + binders_lhs) in + let uu___36 + = + let uu___37 + = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binder) + (FStarC_Compiler_List.op_At + ctx_r + binders_rhs) in + let uu___38 + = + let uu___39 + = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binder) + zs in + [uu___39] in + uu___37 + :: + uu___38 in + uu___35 + :: + uu___36 in + uu___33 + :: + uu___34 in + uu___31 + :: + uu___32 in + uu___29 + :: + uu___30 in + FStarC_Compiler_Util.print + "flex-flex quasi:\n\tlhs=%s\n\trhs=%s\n\tsol=%s\n\tctx_l@binders_lhs=%s\n\tctx_r@binders_rhs=%s\n\tzs=%s\n" + uu___28 + else ()); + (let rc = + if is_ghost + then + FStarC_Syntax_Util.residual_gtot + t_res_lhs + else + FStarC_Syntax_Util.residual_tot + t_res_lhs in + let s1_sol = + FStarC_Syntax_Util.abs + binders_lhs + w_app + ( + FStar_Pervasives_Native.Some + rc) in + let s1 = + TERM + (u_lhs, + s1_sol) in + let uu___27 = + FStarC_Syntax_Unionfind.equiv + u_lhs.FStarC_Syntax_Syntax.ctx_uvar_head + u_rhs.FStarC_Syntax_Syntax.ctx_uvar_head in + if uu___27 + then + let uu___28 + = + solve_prob + orig + FStar_Pervasives_Native.None + [s1] wl1 in + solve + uu___28 + else + (let s2_sol + = + FStarC_Syntax_Util.abs + binders_rhs + w_app + (FStar_Pervasives_Native.Some + rc) in + let s2 = + TERM + (u_rhs, + s2_sol) in + let uu___29 + = + solve_prob + orig + FStar_Pervasives_Native.None + [s1; s2] + wl1 in + solve + uu___29)))))))) + | uu___8 -> + let uu___9 = + FStarC_Thunk.mkv "flex-flex: non-patterns" in + giveup_or_defer orig wl + FStarC_TypeChecker_Common.Deferred_flex_flex_nonpattern + uu___9))) +and (solve_t' : tprob -> worklist -> solution) = + fun problem -> + fun wl -> + def_check_prob "solve_t'.1" (FStarC_TypeChecker_Common.TProb problem); + (let giveup_or_defer1 orig msg = giveup_or_defer orig wl msg in + let rigid_heads_match need_unif torig wl1 t1 t2 = + let orig = FStarC_TypeChecker_Common.TProb torig in + let env = p_env wl1 orig in + (let uu___2 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___2 + then + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + let uu___4 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t1 in + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t2 in + let uu___6 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t2 in + FStarC_Compiler_Util.print5 "Heads %s: %s (%s) and %s (%s)\n" + (if need_unif then "need unification" else "match") uu___3 + uu___4 uu___5 uu___6 + else ()); + (let uu___2 = FStarC_Syntax_Util.head_and_args t1 in + match uu___2 with + | (head1, args1) -> + let uu___3 = FStarC_Syntax_Util.head_and_args t2 in + (match uu___3 with + | (head2, args2) -> + let need_unif1 = + match (((head1.FStarC_Syntax_Syntax.n), args1), + ((head2.FStarC_Syntax_Syntax.n), args2)) + with + | ((FStarC_Syntax_Syntax.Tm_uinst (uu___4, us1), + uu___5::uu___6), + (FStarC_Syntax_Syntax.Tm_uinst (uu___7, us2), + uu___8::uu___9)) -> + let uu___10 = + (FStarC_Compiler_List.for_all + (fun u -> + let uu___11 = universe_has_max env u in + Prims.op_Negation uu___11) us1) + && + (FStarC_Compiler_List.for_all + (fun u -> + let uu___11 = universe_has_max env u in + Prims.op_Negation uu___11) us2) in + if uu___10 then need_unif else true + | uu___4 -> need_unif in + let solve_head_then wl2 k = + if need_unif1 + then k true wl2 + else + (let uu___5 = solve_maybe_uinsts orig head1 head2 wl2 in + match uu___5 with + | USolved wl3 -> k true wl3 + | UFailed msg -> giveup wl2 msg orig + | UDeferred wl3 -> + let uu___6 = + defer_lit + FStarC_TypeChecker_Common.Deferred_univ_constraint + "universe constraints" orig wl3 in + k false uu___6) in + let nargs = FStarC_Compiler_List.length args1 in + if nargs <> (FStarC_Compiler_List.length args2) + then + let uu___4 = + mklstr + (fun uu___5 -> + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head1 in + let uu___7 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + (FStarC_Class_Show.show_tuple2 + FStarC_Syntax_Print.showable_term + FStarC_Syntax_Print.showable_aqual)) + args1 in + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head2 in + let uu___9 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + (FStarC_Class_Show.show_tuple2 + FStarC_Syntax_Print.showable_term + FStarC_Syntax_Print.showable_aqual)) + args2 in + FStarC_Compiler_Util.format4 + "unequal number of arguments: %s[%s] and %s[%s]" + uu___6 uu___7 uu___8 uu___9) in + giveup wl1 uu___4 orig + else + (let uu___5 = + (nargs = Prims.int_zero) || + (let uu___6 = + FStarC_TypeChecker_TermEqAndSimplify.eq_args env + args1 args2 in + uu___6 = + FStarC_TypeChecker_TermEqAndSimplify.Equal) in + if uu___5 + then + (if need_unif1 + then + solve_t + { + FStarC_TypeChecker_Common.pid = + (problem.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = head1; + FStarC_TypeChecker_Common.relation = + (problem.FStarC_TypeChecker_Common.relation); + FStarC_TypeChecker_Common.rhs = head2; + FStarC_TypeChecker_Common.element = + (problem.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (problem.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar = + (problem.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (problem.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = + (problem.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (problem.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = + (problem.FStarC_TypeChecker_Common.logical) + } wl1 + else + solve_head_then wl1 + (fun ok -> + fun wl2 -> + if ok + then + let uu___7 = + solve_prob orig + FStar_Pervasives_Native.None [] wl2 in + solve uu___7 + else solve wl2)) + else + (let uu___7 = base_and_refinement env t1 in + match uu___7 with + | (base1, refinement1) -> + let uu___8 = base_and_refinement env t2 in + (match uu___8 with + | (base2, refinement2) -> + (match (refinement1, refinement2) with + | (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None) -> + let mk_sub_probs wl2 = + let argp = + if need_unif1 + then + FStarC_Compiler_List.zip + ((head1, + FStar_Pervasives_Native.None) + :: args1) + ((head2, + FStar_Pervasives_Native.None) + :: args2) + else + FStarC_Compiler_List.zip args1 + args2 in + let uu___9 = + FStarC_Compiler_List.fold_right + (fun uu___10 -> + fun uu___11 -> + match (uu___10, uu___11) + with + | (((a1, uu___12), + (a2, uu___13)), + (probs, wl3)) -> + let uu___14 = + mk_problem wl3 [] + orig a1 + FStarC_TypeChecker_Common.EQ + a2 + FStar_Pervasives_Native.None + "index" in + (match uu___14 with + | (prob', wl4) -> + (((FStarC_TypeChecker_Common.TProb + prob') :: + probs), wl4))) + argp ([], wl2) in + match uu___9 with + | (subprobs, wl3) -> + ((let uu___11 = + FStarC_Compiler_Effect.op_Bang + dbg_Rel in + if uu___11 + then + let uu___12 = + FStarC_Compiler_Util.string_of_bool + wl3.smt_ok in + let uu___13 = + (FStarC_Common.string_of_list + ()) + (prob_to_string env) + subprobs in + FStarC_Compiler_Util.print2 + "Adding subproblems for arguments (smtok=%s): %s" + uu___12 uu___13 + else ()); + (let uu___12 = + FStarC_Options.defensive () in + if uu___12 + then + FStarC_Compiler_List.iter + (def_check_prob + "solve_t' subprobs") + subprobs + else ()); + (subprobs, wl3)) in + let solve_sub_probs env1 wl2 = + solve_head_then wl2 + (fun ok -> + fun wl3 -> + if Prims.op_Negation ok + then solve wl3 + else + (let uu___10 = + mk_sub_probs wl3 in + match uu___10 with + | (subprobs, wl4) -> + let formula = + let uu___11 = + FStarC_Compiler_List.map + (fun p -> + p_guard p) + subprobs in + FStarC_Syntax_Util.mk_conj_l + uu___11 in + let wl5 = + solve_prob orig + (FStar_Pervasives_Native.Some + formula) [] wl4 in + let uu___11 = + attempt subprobs wl5 in + solve uu___11)) in + let solve_sub_probs_no_smt wl2 = + solve_head_then wl2 + (fun ok -> + fun wl3 -> + let uu___9 = mk_sub_probs wl3 in + match uu___9 with + | (subprobs, wl4) -> + let formula = + let uu___10 = + FStarC_Compiler_List.map + (fun p -> p_guard p) + subprobs in + FStarC_Syntax_Util.mk_conj_l + uu___10 in + let wl5 = + solve_prob orig + (FStar_Pervasives_Native.Some + formula) [] wl4 in + let uu___10 = + attempt subprobs wl5 in + solve uu___10) in + let unfold_and_retry d wl2 uu___9 = + match uu___9 with + | (prob, reason) -> + ((let uu___11 = + FStarC_Compiler_Effect.op_Bang + dbg_Rel in + if uu___11 + then + let uu___12 = + prob_to_string env orig in + let uu___13 = + FStarC_Thunk.force reason in + FStarC_Compiler_Util.print2 + "Failed to solve %s because a sub-problem is not solvable without SMT because %s" + uu___12 uu___13 + else ()); + (let env1 = p_env wl2 prob in + let uu___11 = + let uu___12 = + FStarC_TypeChecker_Normalize.unfold_head_once + env1 t1 in + let uu___13 = + FStarC_TypeChecker_Normalize.unfold_head_once + env1 t2 in + (uu___12, uu___13) in + match uu___11 with + | (FStar_Pervasives_Native.Some + t1', + FStar_Pervasives_Native.Some + t2') -> + let uu___12 = + FStarC_Syntax_Util.head_and_args + t1' in + (match uu___12 with + | (head1', uu___13) -> + let uu___14 = + FStarC_Syntax_Util.head_and_args + t2' in + (match uu___14 with + | (head2', uu___15) + -> + let uu___16 = + let uu___17 = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm + env1 + head1' + head1 in + let uu___18 = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm + env1 + head2' + head2 in + (uu___17, + uu___18) in + (match uu___16 + with + | (FStarC_TypeChecker_TermEqAndSimplify.Equal, + FStarC_TypeChecker_TermEqAndSimplify.Equal) + -> + ((let uu___18 + = + FStarC_Compiler_Effect.op_Bang + dbg_Rel in + if + uu___18 + then + let uu___19 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t1 in + let uu___20 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t1' in + let uu___21 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t2 in + let uu___22 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t2' in + FStarC_Compiler_Util.print4 + "Unfolding didn't make progress ... got %s ~> %s;\nand %s ~> %s\n" + uu___19 + uu___20 + uu___21 + uu___22 + else ()); + solve_sub_probs + env1 wl2) + | uu___17 -> + let torig' + = + { + FStarC_TypeChecker_Common.pid + = + (torig.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs + = t1'; + FStarC_TypeChecker_Common.relation + = + (torig.FStarC_TypeChecker_Common.relation); + FStarC_TypeChecker_Common.rhs + = t2'; + FStarC_TypeChecker_Common.element + = + (torig.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard + = + (torig.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar + = + (torig.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason + = + (torig.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc + = + (torig.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank + = + (torig.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical + = + (torig.FStarC_TypeChecker_Common.logical) + } in + ((let uu___19 + = + FStarC_Compiler_Effect.op_Bang + dbg_Rel in + if + uu___19 + then + let uu___20 + = + prob_to_string + env1 + (FStarC_TypeChecker_Common.TProb + torig') in + FStarC_Compiler_Util.print1 + "Unfolded and now trying %s\n" + uu___20 + else ()); + solve_t + torig' + wl2)))) + | uu___12 -> + solve_sub_probs env1 wl2)) in + let d = + let uu___9 = + FStarC_TypeChecker_Env.delta_depth_of_term + env head1 in + FStarC_TypeChecker_Common.decr_delta_depth + uu___9 in + let treat_as_injective = + let uu___9 = + let uu___10 = + FStarC_Syntax_Util.un_uinst + head1 in + uu___10.FStarC_Syntax_Syntax.n in + match uu___9 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + FStarC_TypeChecker_Env.fv_has_attr + env fv + FStarC_Parser_Const.unifier_hint_injective_lid + | uu___10 -> false in + (match d with + | FStar_Pervasives_Native.Some d1 + when + wl1.smt_ok && + (Prims.op_Negation + treat_as_injective) + -> + try_solve_without_smt_or_else wl1 + solve_sub_probs_no_smt + (unfold_and_retry d1) + | uu___9 -> solve_sub_probs env wl1) + | uu___9 -> + let lhs = + force_refinement + (base1, refinement1) in + let rhs = + force_refinement + (base2, refinement2) in + solve_t' + { + FStarC_TypeChecker_Common.pid = + (problem.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = + lhs; + FStarC_TypeChecker_Common.relation + = + (problem.FStarC_TypeChecker_Common.relation); + FStarC_TypeChecker_Common.rhs = + rhs; + FStarC_TypeChecker_Common.element + = + (problem.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard + = + (problem.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar + = + (problem.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (problem.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = + (problem.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (problem.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical + = + (problem.FStarC_TypeChecker_Common.logical) + } wl1)))))) in + let try_match_heuristic orig wl1 s1 s2 t1t2_opt = + let env = p_env wl1 orig in + let try_solve_branch scrutinee p = + let uu___1 = destruct_flex_t scrutinee wl1 in + match uu___1 with + | (Flex (_t, uv, _args), wl2) -> + let uu___2 = + FStarC_TypeChecker_PatternUtils.pat_as_exp true true env p in + (match uu___2 with + | (xs, pat_term, g_pat_as_exp, uu___3) -> + let uu___4 = + FStarC_Compiler_List.fold_left + (fun uu___5 -> + fun x -> + match uu___5 with + | (subst, wl3) -> + let t_x = + FStarC_Syntax_Subst.subst subst + x.FStarC_Syntax_Syntax.sort in + let uu___6 = copy_uvar uv [] t_x wl3 in + (match uu___6 with + | (uu___7, u, wl4) -> + let subst1 = + (FStarC_Syntax_Syntax.NT (x, u)) :: + subst in + (subst1, wl4))) ([], wl2) xs in + (match uu___4 with + | (subst, wl3) -> + let pat_term1 = + FStarC_Syntax_Subst.subst subst pat_term in + let uu___5 = + let must_tot = false in + let scrutinee_t = + let uu___6 = + let uu___7 = + let uu___8 = + env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + env scrutinee must_tot in + FStar_Pervasives_Native.fst uu___8 in + FStarC_TypeChecker_Normalize.normalize_refinement + FStarC_TypeChecker_Normalize.whnf_steps env + uu___7 in + FStarC_Syntax_Util.unrefine uu___6 in + (let uu___7 = + FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___7 + then + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term pat_term1 in + FStarC_Compiler_Util.print1 + "Match heuristic, typechecking the pattern term: %s {\n\n" + uu___8 + else ()); + (let uu___7 = + let uu___8 = + FStarC_TypeChecker_Env.set_expected_typ env + scrutinee_t in + env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + uu___8 pat_term1 must_tot in + match uu___7 with + | (pat_term2, pat_term_t, g_pat_term) -> + ((let uu___9 = + FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___9 + then + let uu___10 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + pat_term2 in + let uu___11 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + pat_term_t in + FStarC_Compiler_Util.print2 + "} Match heuristic, typechecked pattern term to %s and type %s\n" + uu___10 uu___11 + else ()); + (pat_term2, g_pat_term))) in + (match uu___5 with + | (pat_term2, g_pat_term) -> + let uu___6 = + let uu___7 = simplify_guard env g_pat_term in + FStarC_TypeChecker_Env.is_trivial_guard_formula + uu___7 in + if uu___6 + then + let uu___7 = + new_problem wl3 env scrutinee + FStarC_TypeChecker_Common.EQ pat_term2 + FStar_Pervasives_Native.None + scrutinee.FStarC_Syntax_Syntax.pos + "match heuristic" in + (match uu___7 with + | (prob, wl4) -> + let wl' = + extend_wl + { + attempting = + [FStarC_TypeChecker_Common.TProb + prob]; + wl_deferred = + (Obj.magic + (FStarC_Class_Listlike.empty + () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist + ())))); + wl_deferred_to_tac = + (wl4.wl_deferred_to_tac); + ctr = (wl4.ctr); + defer_ok = NoDefer; + smt_ok = false; + umax_heuristic_ok = + (wl4.umax_heuristic_ok); + tcenv = (wl4.tcenv); + wl_implicits = + (Obj.magic + (FStarC_Class_Listlike.empty + () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist + ())))); + repr_subcomp_allowed = + (wl4.repr_subcomp_allowed); + typeclass_variables = + (wl4.typeclass_variables) + } + g_pat_term.FStarC_TypeChecker_Common.deferred + g_pat_term.FStarC_TypeChecker_Common.deferred_to_tac + (Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist + ())))) in + let tx = + FStarC_Syntax_Unionfind.new_transaction + () in + let uu___8 = solve wl' in + (match uu___8 with + | Success (uu___9, defer_to_tac, imps) + -> + let wl'1 = + { + attempting = [orig]; + wl_deferred = (wl'.wl_deferred); + wl_deferred_to_tac = + (wl'.wl_deferred_to_tac); + ctr = (wl'.ctr); + defer_ok = (wl'.defer_ok); + smt_ok = (wl'.smt_ok); + umax_heuristic_ok = + (wl'.umax_heuristic_ok); + tcenv = (wl'.tcenv); + wl_implicits = + (wl'.wl_implicits); + repr_subcomp_allowed = + (wl'.repr_subcomp_allowed); + typeclass_variables = + (wl'.typeclass_variables) + } in + let uu___10 = solve wl'1 in + (match uu___10 with + | Success + (uu___11, defer_to_tac', + imps') + -> + (FStarC_Syntax_Unionfind.commit + tx; + (let uu___13 = + let uu___14 = + FStarC_Class_Monoid.op_Plus_Plus + (FStarC_Compiler_CList.monoid_clist + ()) defer_to_tac + defer_to_tac' in + let uu___15 = + let uu___16 = + let uu___17 = + FStarC_Class_Monoid.op_Plus_Plus + (FStarC_Compiler_CList.monoid_clist + ()) imps imps' in + FStarC_Class_Monoid.op_Plus_Plus + (FStarC_Compiler_CList.monoid_clist + ()) uu___17 + g_pat_as_exp.FStarC_TypeChecker_Common.implicits in + FStarC_Class_Monoid.op_Plus_Plus + (FStarC_Compiler_CList.monoid_clist + ()) uu___16 + g_pat_term.FStarC_TypeChecker_Common.implicits in + extend_wl wl4 + (Obj.magic + (FStarC_Class_Listlike.empty + () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist + ())))) + uu___14 uu___15 in + FStar_Pervasives_Native.Some + uu___13)) + | Failed uu___11 -> + (FStarC_Syntax_Unionfind.rollback + tx; + FStar_Pervasives_Native.None)) + | uu___9 -> + (FStarC_Syntax_Unionfind.rollback + tx; + FStar_Pervasives_Native.None))) + else FStar_Pervasives_Native.None))) in + match t1t2_opt with + | FStar_Pervasives_Native.None -> + FStar_Pervasives.Inr FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (t1, t2) -> + ((let uu___2 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___2 + then + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + t1 in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + t2 in + FStarC_Compiler_Util.print2 + "Trying match heuristic for %s vs. %s\n" uu___3 uu___4 + else ()); + (let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Util.unmeta t1 in (s1, uu___4) in + let uu___4 = + let uu___5 = FStarC_Syntax_Util.unmeta t2 in (s2, uu___5) in + (uu___3, uu___4) in + match uu___2 with + | ((uu___3, + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = scrutinee; + FStarC_Syntax_Syntax.ret_opt = uu___4; + FStarC_Syntax_Syntax.brs = branches; + FStarC_Syntax_Syntax.rc_opt1 = uu___5;_}; + FStarC_Syntax_Syntax.pos = uu___6; + FStarC_Syntax_Syntax.vars = uu___7; + FStarC_Syntax_Syntax.hash_code = uu___8;_}), + (s, t)) -> + let uu___9 = + let uu___10 = is_flex scrutinee in + Prims.op_Negation uu___10 in + if uu___9 + then + ((let uu___11 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___11 + then + let uu___12 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term scrutinee in + FStarC_Compiler_Util.print1 + "match head %s is not a flex term\n" uu___12 + else ()); + FStar_Pervasives.Inr FStar_Pervasives_Native.None) + else + if wl1.defer_ok = DeferAny + then + ((let uu___12 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___12 + then + FStarC_Compiler_Util.print_string + "Deferring ... \n" + else ()); + FStar_Pervasives.Inl "defer") + else + ((let uu___13 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___13 + then + let uu___14 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term scrutinee in + let uu___15 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.print2 + "Heuristic applicable with scrutinee %s and other side = %s\n" + uu___14 uu___15 + else ()); + (let pat_discriminates uu___13 = + match uu___13 with + | ({ + FStarC_Syntax_Syntax.v = + FStarC_Syntax_Syntax.Pat_constant uu___14; + FStarC_Syntax_Syntax.p = uu___15;_}, + FStar_Pervasives_Native.None, uu___16) -> true + | ({ + FStarC_Syntax_Syntax.v = + FStarC_Syntax_Syntax.Pat_cons uu___14; + FStarC_Syntax_Syntax.p = uu___15;_}, + FStar_Pervasives_Native.None, uu___16) -> true + | uu___14 -> false in + let head_matching_branch = + FStarC_Compiler_Util.try_find + (fun b -> + if pat_discriminates b + then + let uu___13 = + FStarC_Syntax_Subst.open_branch b in + match uu___13 with + | (uu___14, uu___15, t') -> + let uu___16 = + head_matches_delta (p_env wl1 orig) + (p_logical orig) wl1.smt_ok s t' in + (match uu___16 with + | (FullMatch, uu___17) -> true + | (HeadMatch uu___17, uu___18) -> true + | uu___17 -> false) + else false) branches in + match head_matching_branch with + | FStar_Pervasives_Native.None -> + ((let uu___14 = + FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___14 + then + FStarC_Compiler_Util.print_string + "No head_matching branch\n" + else ()); + (let try_branches = + let uu___14 = + FStarC_Compiler_Util.prefix_until + (fun b -> + Prims.op_Negation + (pat_discriminates b)) branches in + match uu___14 with + | FStar_Pervasives_Native.Some + (branches1, uu___15, uu___16) -> + branches1 + | uu___15 -> branches in + let uu___14 = + FStarC_Compiler_Util.find_map try_branches + (fun b -> + let uu___15 = + FStarC_Syntax_Subst.open_branch b in + match uu___15 with + | (p, uu___16, uu___17) -> + try_solve_branch scrutinee p) in + FStar_Pervasives.Inr uu___14)) + | FStar_Pervasives_Native.Some b -> + let uu___13 = FStarC_Syntax_Subst.open_branch b in + (match uu___13 with + | (p, uu___14, e) -> + ((let uu___16 = + FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___16 + then + let uu___17 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_pat p in + let uu___18 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term e in + FStarC_Compiler_Util.print2 + "Found head matching branch %s -> %s\n" + uu___17 uu___18 + else ()); + (let uu___16 = + try_solve_branch scrutinee p in + FStar_Pervasives.Inr uu___16))))) + | ((s, t), + (uu___3, + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = scrutinee; + FStarC_Syntax_Syntax.ret_opt = uu___4; + FStarC_Syntax_Syntax.brs = branches; + FStarC_Syntax_Syntax.rc_opt1 = uu___5;_}; + FStarC_Syntax_Syntax.pos = uu___6; + FStarC_Syntax_Syntax.vars = uu___7; + FStarC_Syntax_Syntax.hash_code = uu___8;_})) + -> + let uu___9 = + let uu___10 = is_flex scrutinee in + Prims.op_Negation uu___10 in + if uu___9 + then + ((let uu___11 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___11 + then + let uu___12 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term scrutinee in + FStarC_Compiler_Util.print1 + "match head %s is not a flex term\n" uu___12 + else ()); + FStar_Pervasives.Inr FStar_Pervasives_Native.None) + else + if wl1.defer_ok = DeferAny + then + ((let uu___12 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___12 + then + FStarC_Compiler_Util.print_string + "Deferring ... \n" + else ()); + FStar_Pervasives.Inl "defer") + else + ((let uu___13 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___13 + then + let uu___14 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term scrutinee in + let uu___15 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.print2 + "Heuristic applicable with scrutinee %s and other side = %s\n" + uu___14 uu___15 + else ()); + (let pat_discriminates uu___13 = + match uu___13 with + | ({ + FStarC_Syntax_Syntax.v = + FStarC_Syntax_Syntax.Pat_constant uu___14; + FStarC_Syntax_Syntax.p = uu___15;_}, + FStar_Pervasives_Native.None, uu___16) -> true + | ({ + FStarC_Syntax_Syntax.v = + FStarC_Syntax_Syntax.Pat_cons uu___14; + FStarC_Syntax_Syntax.p = uu___15;_}, + FStar_Pervasives_Native.None, uu___16) -> true + | uu___14 -> false in + let head_matching_branch = + FStarC_Compiler_Util.try_find + (fun b -> + if pat_discriminates b + then + let uu___13 = + FStarC_Syntax_Subst.open_branch b in + match uu___13 with + | (uu___14, uu___15, t') -> + let uu___16 = + head_matches_delta (p_env wl1 orig) + (p_logical orig) wl1.smt_ok s t' in + (match uu___16 with + | (FullMatch, uu___17) -> true + | (HeadMatch uu___17, uu___18) -> true + | uu___17 -> false) + else false) branches in + match head_matching_branch with + | FStar_Pervasives_Native.None -> + ((let uu___14 = + FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___14 + then + FStarC_Compiler_Util.print_string + "No head_matching branch\n" + else ()); + (let try_branches = + let uu___14 = + FStarC_Compiler_Util.prefix_until + (fun b -> + Prims.op_Negation + (pat_discriminates b)) branches in + match uu___14 with + | FStar_Pervasives_Native.Some + (branches1, uu___15, uu___16) -> + branches1 + | uu___15 -> branches in + let uu___14 = + FStarC_Compiler_Util.find_map try_branches + (fun b -> + let uu___15 = + FStarC_Syntax_Subst.open_branch b in + match uu___15 with + | (p, uu___16, uu___17) -> + try_solve_branch scrutinee p) in + FStar_Pervasives.Inr uu___14)) + | FStar_Pervasives_Native.Some b -> + let uu___13 = FStarC_Syntax_Subst.open_branch b in + (match uu___13 with + | (p, uu___14, e) -> + ((let uu___16 = + FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___16 + then + let uu___17 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_pat p in + let uu___18 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term e in + FStarC_Compiler_Util.print2 + "Found head matching branch %s -> %s\n" + uu___17 uu___18 + else ()); + (let uu___16 = + try_solve_branch scrutinee p in + FStar_Pervasives.Inr uu___16))))) + | uu___3 -> + ((let uu___5 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___5 + then + let uu___6 = + FStarC_Class_Tagged.tag_of + FStarC_Syntax_Syntax.tagged_term t1 in + let uu___7 = + FStarC_Class_Tagged.tag_of + FStarC_Syntax_Syntax.tagged_term t2 in + FStarC_Compiler_Util.print2 + "Heuristic not applicable: tag lhs=%s, rhs=%s\n" + uu___6 uu___7 + else ()); + FStar_Pervasives.Inr FStar_Pervasives_Native.None))) in + let rigid_rigid_delta torig wl1 head1 head2 t1 t2 = + let orig = FStarC_TypeChecker_Common.TProb torig in + (let uu___2 = FStarC_Compiler_Effect.op_Bang dbg_RelDelta in + if uu___2 + then + let uu___3 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t1 in + let uu___4 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t2 in + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + let uu___6 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t2 in + FStarC_Compiler_Util.print4 + "rigid_rigid_delta of %s-%s (%s, %s)\n" uu___3 uu___4 uu___5 + uu___6 + else ()); + (let uu___2 = + head_matches_delta (p_env wl1 orig) (p_logical orig) wl1.smt_ok + t1 t2 in + match uu___2 with + | (m, o) -> + (match (m, o) with + | (MisMatch uu___3, uu___4) -> + let try_reveal_hide t11 t21 = + let payload_of_hide_reveal h args = + match ((h.FStarC_Syntax_Syntax.n), args) with + | (FStarC_Syntax_Syntax.Tm_uinst (uu___5, u::[]), + (ty, FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = uu___6;_}):: + (t, uu___7)::[]) -> + FStar_Pervasives_Native.Some (u, ty, t) + | uu___5 -> FStar_Pervasives_Native.None in + let is_reveal_or_hide t = + let uu___5 = FStarC_Syntax_Util.head_and_args t in + match uu___5 with + | (h, args) -> + let uu___6 = + FStarC_Syntax_Util.is_fvar + FStarC_Parser_Const.reveal h in + if uu___6 + then + let uu___7 = payload_of_hide_reveal h args in + (match uu___7 with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some t3 -> + FStar_Pervasives_Native.Some (Reveal t3)) + else + (let uu___8 = + FStarC_Syntax_Util.is_fvar + FStarC_Parser_Const.hide h in + if uu___8 + then + let uu___9 = payload_of_hide_reveal h args in + match uu___9 with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some t3 -> + FStar_Pervasives_Native.Some (Hide t3) + else FStar_Pervasives_Native.None) in + let mk_fv_app lid u args r = + let fv = + FStarC_TypeChecker_Env.fvar_of_nonqual_lid wl1.tcenv + lid in + let head = FStarC_Syntax_Syntax.mk_Tm_uinst fv [u] in + FStarC_Syntax_Syntax.mk_Tm_app head args r in + let uu___5 = + let uu___6 = is_reveal_or_hide t11 in + let uu___7 = is_reveal_or_hide t21 in (uu___6, uu___7) in + match uu___5 with + | (FStar_Pervasives_Native.Some (Reveal (u, ty, lhs)), + FStar_Pervasives_Native.None) when is_flex lhs -> + let rhs = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Syntax.as_aqual_implicit true in + (ty, uu___8) in + [uu___7; (t21, FStar_Pervasives_Native.None)] in + mk_fv_app FStarC_Parser_Const.hide u uu___6 + t21.FStarC_Syntax_Syntax.pos in + FStar_Pervasives_Native.Some (lhs, rhs) + | (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.Some (Reveal (u, ty, rhs))) + when is_flex rhs -> + let lhs = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Syntax.as_aqual_implicit true in + (ty, uu___8) in + [uu___7; (t11, FStar_Pervasives_Native.None)] in + mk_fv_app FStarC_Parser_Const.hide u uu___6 + t11.FStarC_Syntax_Syntax.pos in + FStar_Pervasives_Native.Some (lhs, rhs) + | (FStar_Pervasives_Native.Some (Hide (u, ty, lhs)), + FStar_Pervasives_Native.None) -> + let rhs = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Syntax.as_aqual_implicit true in + (ty, uu___8) in + [uu___7; (t21, FStar_Pervasives_Native.None)] in + mk_fv_app FStarC_Parser_Const.reveal u uu___6 + t21.FStarC_Syntax_Syntax.pos in + FStar_Pervasives_Native.Some (lhs, rhs) + | (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.Some (Hide (u, ty, rhs))) -> + let lhs = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Syntax.as_aqual_implicit true in + (ty, uu___8) in + [uu___7; (t11, FStar_Pervasives_Native.None)] in + mk_fv_app FStarC_Parser_Const.reveal u uu___6 + t11.FStarC_Syntax_Syntax.pos in + FStar_Pervasives_Native.Some (lhs, rhs) + | uu___6 -> FStar_Pervasives_Native.None in + let uu___5 = try_match_heuristic orig wl1 t1 t2 o in + (match uu___5 with + | FStar_Pervasives.Inl _defer_ok -> + let uu___6 = + FStarC_Thunk.mkv "delaying match heuristic" in + giveup_or_defer1 orig + FStarC_TypeChecker_Common.Deferred_delay_match_heuristic + uu___6 + | FStar_Pervasives.Inr (FStar_Pervasives_Native.Some wl2) + -> solve wl2 + | FStar_Pervasives.Inr (FStar_Pervasives_Native.None) -> + let uu___6 = try_reveal_hide t1 t2 in + (match uu___6 with + | FStar_Pervasives_Native.Some (t1', t2') -> + solve_t + { + FStarC_TypeChecker_Common.pid = + (problem.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = t1'; + FStarC_TypeChecker_Common.relation = + (problem.FStarC_TypeChecker_Common.relation); + FStarC_TypeChecker_Common.rhs = t2'; + FStarC_TypeChecker_Common.element = + (problem.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (problem.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar + = + (problem.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (problem.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = + (problem.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (problem.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = + (problem.FStarC_TypeChecker_Common.logical) + } wl1 + | FStar_Pervasives_Native.None -> + let uu___7 = + ((may_relate wl1.tcenv + problem.FStarC_TypeChecker_Common.relation + head1) + || + (may_relate wl1.tcenv + problem.FStarC_TypeChecker_Common.relation + head2)) + && wl1.smt_ok in + if uu___7 + then + let uu___8 = guard_of_prob wl1 problem t1 t2 in + (match uu___8 with + | (guard, wl2) -> + let uu___9 = + solve_prob orig + (FStar_Pervasives_Native.Some guard) + [] wl2 in + solve uu___9) + else + (let uu___9 = + mklstr + (fun uu___10 -> + let uu___11 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + head1 in + let uu___12 = + let uu___13 = + FStarC_TypeChecker_Env.delta_depth_of_term + wl1.tcenv head1 in + FStarC_Class_Show.show + FStarC_Syntax_Syntax.showable_delta_depth + uu___13 in + let uu___13 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + head2 in + let uu___14 = + let uu___15 = + FStarC_TypeChecker_Env.delta_depth_of_term + wl1.tcenv head2 in + FStarC_Class_Show.show + FStarC_Syntax_Syntax.showable_delta_depth + uu___15 in + FStarC_Compiler_Util.format4 + "head mismatch (%s (%s) vs %s (%s))" + uu___11 uu___12 uu___13 uu___14) in + giveup wl1 uu___9 orig))) + | (HeadMatch (true), uu___3) when + problem.FStarC_TypeChecker_Common.relation <> + FStarC_TypeChecker_Common.EQ + -> + if wl1.smt_ok + then + let uu___4 = guard_of_prob wl1 problem t1 t2 in + (match uu___4 with + | (guard, wl2) -> + let uu___5 = + solve_prob orig + (FStar_Pervasives_Native.Some guard) [] wl2 in + solve uu___5) + else + (let uu___5 = + mklstr + (fun uu___6 -> + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t1 in + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t2 in + FStarC_Compiler_Util.format2 + "head mismatch for subtyping (%s vs %s)" + uu___7 uu___8) in + giveup wl1 uu___5 orig) + | (uu___3, FStar_Pervasives_Native.Some (t11, t21)) -> + solve_t + { + FStarC_TypeChecker_Common.pid = + (problem.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = t11; + FStarC_TypeChecker_Common.relation = + (problem.FStarC_TypeChecker_Common.relation); + FStarC_TypeChecker_Common.rhs = t21; + FStarC_TypeChecker_Common.element = + (problem.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (problem.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar = + (problem.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (problem.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = + (problem.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (problem.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = + (problem.FStarC_TypeChecker_Common.logical) + } wl1 + | (HeadMatch need_unif, FStar_Pervasives_Native.None) -> + rigid_heads_match need_unif torig wl1 t1 t2 + | (FullMatch, FStar_Pervasives_Native.None) -> + rigid_heads_match false torig wl1 t1 t2)) in + let orig = FStarC_TypeChecker_Common.TProb problem in + def_check_prob "solve_t'.2" orig; + (let uu___2 = + FStarC_Compiler_Util.physical_equality + problem.FStarC_TypeChecker_Common.lhs + problem.FStarC_TypeChecker_Common.rhs in + if uu___2 + then + let uu___3 = solve_prob orig FStar_Pervasives_Native.None [] wl in + solve uu___3 + else + (let t1 = problem.FStarC_TypeChecker_Common.lhs in + let t2 = problem.FStarC_TypeChecker_Common.rhs in + (let uu___5 = + let uu___6 = p_scope orig in + FStarC_Compiler_List.map + (fun b -> b.FStarC_Syntax_Syntax.binder_bv) uu___6 in + FStarC_Defensive.def_check_scoped + FStarC_Class_Binders.hasBinders_list_bv + FStarC_Class_Binders.hasNames_term + FStarC_Syntax_Print.pretty_term (p_loc orig) "ref.t1" uu___5 t1); + (let uu___6 = + let uu___7 = p_scope orig in + FStarC_Compiler_List.map + (fun b -> b.FStarC_Syntax_Syntax.binder_bv) uu___7 in + FStarC_Defensive.def_check_scoped + FStarC_Class_Binders.hasBinders_list_bv + FStarC_Class_Binders.hasNames_term + FStarC_Syntax_Print.pretty_term (p_loc orig) "ref.t2" uu___6 t2); + (let uu___7 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___7 + then + let uu___8 = + FStarC_Compiler_Util.string_of_int + problem.FStarC_TypeChecker_Common.pid in + let uu___9 = + let uu___10 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term + t1 in + let uu___11 = + let uu___12 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + t1 in + Prims.strcat "::" uu___12 in + Prims.strcat uu___10 uu___11 in + let uu___10 = + let uu___11 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term + t2 in + let uu___12 = + let uu___13 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + t2 in + Prims.strcat "::" uu___13 in + Prims.strcat uu___11 uu___12 in + let uu___11 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_nat) + (FStarC_Compiler_List.length wl.attempting) in + FStarC_Compiler_Util.print5 + "Attempting %s (%s vs %s); rel = (%s); number of problems in wl = %s\n" + uu___8 uu___9 uu___10 + (rel_to_string problem.FStarC_TypeChecker_Common.relation) + uu___11 + else ()); + (match ((t1.FStarC_Syntax_Syntax.n), (t2.FStarC_Syntax_Syntax.n)) + with + | (FStarC_Syntax_Syntax.Tm_delayed uu___7, uu___8) -> + failwith "Impossible: terms were not compressed" + | (uu___7, FStarC_Syntax_Syntax.Tm_delayed uu___8) -> + failwith "Impossible: terms were not compressed" + | (FStarC_Syntax_Syntax.Tm_ascribed uu___7, uu___8) -> + let uu___9 = + let uu___10 = FStarC_Syntax_Util.unascribe t1 in + { + FStarC_TypeChecker_Common.pid = + (problem.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = uu___10; + FStarC_TypeChecker_Common.relation = + (problem.FStarC_TypeChecker_Common.relation); + FStarC_TypeChecker_Common.rhs = + (problem.FStarC_TypeChecker_Common.rhs); + FStarC_TypeChecker_Common.element = + (problem.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (problem.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar = + (problem.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (problem.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = + (problem.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (problem.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = + (problem.FStarC_TypeChecker_Common.logical) + } in + solve_t' uu___9 wl + | (FStarC_Syntax_Syntax.Tm_meta uu___7, uu___8) -> + let uu___9 = + let uu___10 = FStarC_Syntax_Util.unmeta t1 in + { + FStarC_TypeChecker_Common.pid = + (problem.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = uu___10; + FStarC_TypeChecker_Common.relation = + (problem.FStarC_TypeChecker_Common.relation); + FStarC_TypeChecker_Common.rhs = + (problem.FStarC_TypeChecker_Common.rhs); + FStarC_TypeChecker_Common.element = + (problem.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (problem.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar = + (problem.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (problem.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = + (problem.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (problem.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = + (problem.FStarC_TypeChecker_Common.logical) + } in + solve_t' uu___9 wl + | (uu___7, FStarC_Syntax_Syntax.Tm_ascribed uu___8) -> + let uu___9 = + let uu___10 = FStarC_Syntax_Util.unascribe t2 in + { + FStarC_TypeChecker_Common.pid = + (problem.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = + (problem.FStarC_TypeChecker_Common.lhs); + FStarC_TypeChecker_Common.relation = + (problem.FStarC_TypeChecker_Common.relation); + FStarC_TypeChecker_Common.rhs = uu___10; + FStarC_TypeChecker_Common.element = + (problem.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (problem.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar = + (problem.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (problem.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = + (problem.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (problem.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = + (problem.FStarC_TypeChecker_Common.logical) + } in + solve_t' uu___9 wl + | (uu___7, FStarC_Syntax_Syntax.Tm_meta uu___8) -> + let uu___9 = + let uu___10 = FStarC_Syntax_Util.unmeta t2 in + { + FStarC_TypeChecker_Common.pid = + (problem.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = + (problem.FStarC_TypeChecker_Common.lhs); + FStarC_TypeChecker_Common.relation = + (problem.FStarC_TypeChecker_Common.relation); + FStarC_TypeChecker_Common.rhs = uu___10; + FStarC_TypeChecker_Common.element = + (problem.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (problem.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar = + (problem.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (problem.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = + (problem.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (problem.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = + (problem.FStarC_TypeChecker_Common.logical) + } in + solve_t' uu___9 wl + | (FStarC_Syntax_Syntax.Tm_quoted (t11, uu___7), + FStarC_Syntax_Syntax.Tm_quoted (t21, uu___8)) -> + let uu___9 = + solve_prob orig FStar_Pervasives_Native.None [] wl in + solve uu___9 + | (FStarC_Syntax_Syntax.Tm_bvar uu___7, uu___8) -> + failwith + "Only locally nameless! We should never see a de Bruijn variable" + | (uu___7, FStarC_Syntax_Syntax.Tm_bvar uu___8) -> + failwith + "Only locally nameless! We should never see a de Bruijn variable" + | (FStarC_Syntax_Syntax.Tm_type u1, FStarC_Syntax_Syntax.Tm_type + u2) -> solve_one_universe_eq orig u1 u2 wl + | (FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs1; + FStarC_Syntax_Syntax.comp = c1;_}, + FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs2; + FStarC_Syntax_Syntax.comp = c2;_}) + -> + let mk_c c uu___7 = + match uu___7 with + | [] -> c + | bs -> + let uu___8 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = c + }) c.FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.mk_Total uu___8 in + let uu___7 = + match_num_binders (bs1, (mk_c c1)) (bs2, (mk_c c2)) in + (match uu___7 with + | ((bs11, c11), (bs21, c21)) -> + solve_binders bs11 bs21 orig wl + (fun wl1 -> + fun scope -> + fun subst -> + let c12 = + FStarC_Syntax_Subst.subst_comp subst c11 in + let c22 = + FStarC_Syntax_Subst.subst_comp subst c21 in + let rel = + let uu___8 = + FStarC_Options.use_eq_at_higher_order () in + if uu___8 + then FStarC_TypeChecker_Common.EQ + else + problem.FStarC_TypeChecker_Common.relation in + mk_c_problem wl1 scope orig c12 rel c22 + FStar_Pervasives_Native.None + "function co-domain")) + | (FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs1; + FStarC_Syntax_Syntax.body = tbody1; + FStarC_Syntax_Syntax.rc_opt = lopt1;_}, + FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs2; + FStarC_Syntax_Syntax.body = tbody2; + FStarC_Syntax_Syntax.rc_opt = lopt2;_}) + -> + let mk_t t l uu___7 = + match uu___7 with + | [] -> t + | bs -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs = bs; + FStarC_Syntax_Syntax.body = t; + FStarC_Syntax_Syntax.rc_opt = l + }) t.FStarC_Syntax_Syntax.pos in + let uu___7 = + match_num_binders (bs1, (mk_t tbody1 lopt1)) + (bs2, (mk_t tbody2 lopt2)) in + (match uu___7 with + | ((bs11, tbody11), (bs21, tbody21)) -> + solve_binders bs11 bs21 orig wl + (fun wl1 -> + fun scope -> + fun subst -> + let uu___8 = + FStarC_Syntax_Subst.subst subst tbody11 in + let uu___9 = + FStarC_Syntax_Subst.subst subst tbody21 in + mk_t_problem wl1 scope orig uu___8 + problem.FStarC_TypeChecker_Common.relation + uu___9 FStar_Pervasives_Native.None + "lambda co-domain")) + | (FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x1; + FStarC_Syntax_Syntax.phi = phi1;_}, + FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x2; + FStarC_Syntax_Syntax.phi = phi2;_}) + -> + let env = p_env wl (FStarC_TypeChecker_Common.TProb problem) in + let uu___7 = + let uu___8 = + head_matches_delta env false wl.smt_ok + x1.FStarC_Syntax_Syntax.sort + x2.FStarC_Syntax_Syntax.sort in + match uu___8 with + | (FullMatch, FStar_Pervasives_Native.Some (t11, t21)) -> + ({ + FStarC_Syntax_Syntax.ppname = + (x1.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (x1.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = t11 + }, + { + FStarC_Syntax_Syntax.ppname = + (x2.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (x2.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = t21 + }) + | (HeadMatch uu___9, FStar_Pervasives_Native.Some + (t11, t21)) -> + ({ + FStarC_Syntax_Syntax.ppname = + (x1.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (x1.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = t11 + }, + { + FStarC_Syntax_Syntax.ppname = + (x2.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (x2.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = t21 + }) + | uu___9 -> (x1, x2) in + (match uu___7 with + | (x11, x21) -> + let t11 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_refine + { + FStarC_Syntax_Syntax.b = x11; + FStarC_Syntax_Syntax.phi = phi1 + }) t1.FStarC_Syntax_Syntax.pos in + let t21 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_refine + { + FStarC_Syntax_Syntax.b = x21; + FStarC_Syntax_Syntax.phi = phi2 + }) t2.FStarC_Syntax_Syntax.pos in + let uu___8 = as_refinement false env t11 in + (match uu___8 with + | (x12, phi11) -> + let uu___9 = as_refinement false env t21 in + (match uu___9 with + | (x22, phi21) -> + ((let uu___11 = + FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___11 + then + ((let uu___13 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_bv x12 in + let uu___14 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + x12.FStarC_Syntax_Syntax.sort in + let uu___15 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + phi11 in + FStarC_Compiler_Util.print3 + "ref1 = (%s):(%s){%s}\n" uu___13 + uu___14 uu___15); + (let uu___13 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_bv x22 in + let uu___14 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + x22.FStarC_Syntax_Syntax.sort in + let uu___15 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + phi21 in + FStarC_Compiler_Util.print3 + "ref2 = (%s):(%s){%s}\n" uu___13 + uu___14 uu___15)) + else ()); + (let uu___11 = + mk_t_problem wl [] orig + x12.FStarC_Syntax_Syntax.sort + problem.FStarC_TypeChecker_Common.relation + x22.FStarC_Syntax_Syntax.sort + problem.FStarC_TypeChecker_Common.element + "refinement base type" in + match uu___11 with + | (base_prob, wl1) -> + let x13 = + FStarC_Syntax_Syntax.freshen_bv x12 in + let subst = + [FStarC_Syntax_Syntax.DB + (Prims.int_zero, x13)] in + let phi12 = + FStarC_Syntax_Subst.subst subst phi11 in + let phi22 = + FStarC_Syntax_Subst.subst subst phi21 in + let mk_imp imp phi13 phi23 = + let uu___12 = imp phi13 phi23 in + guard_on_element wl1 problem x13 + uu___12 in + let fallback uu___12 = + let impl = + if + problem.FStarC_TypeChecker_Common.relation + = FStarC_TypeChecker_Common.EQ + then + mk_imp FStarC_Syntax_Util.mk_iff + phi12 phi22 + else + mk_imp FStarC_Syntax_Util.mk_imp + phi12 phi22 in + let guard = + FStarC_Syntax_Util.mk_conj + (p_guard base_prob) impl in + (let uu___14 = + let uu___15 = p_scope orig in + FStarC_Compiler_List.map + (fun b -> + b.FStarC_Syntax_Syntax.binder_bv) + uu___15 in + FStarC_Defensive.def_check_scoped + FStarC_Class_Binders.hasBinders_list_bv + FStarC_Class_Binders.hasNames_term + FStarC_Syntax_Print.pretty_term + (p_loc orig) "ref.1" uu___14 + (p_guard base_prob)); + (let uu___15 = + let uu___16 = p_scope orig in + FStarC_Compiler_List.map + (fun b -> + b.FStarC_Syntax_Syntax.binder_bv) + uu___16 in + FStarC_Defensive.def_check_scoped + FStarC_Class_Binders.hasBinders_list_bv + FStarC_Class_Binders.hasNames_term + FStarC_Syntax_Print.pretty_term + (p_loc orig) "ref.2" uu___15 impl); + (let wl2 = + solve_prob orig + (FStar_Pervasives_Native.Some + guard) [] wl1 in + let uu___15 = attempt [base_prob] wl2 in + solve uu___15) in + let has_uvars = + (let uu___12 = + let uu___13 = + FStarC_Syntax_Free.uvars phi12 in + FStarC_Class_Setlike.is_empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) + (Obj.magic uu___13) in + Prims.op_Negation uu___12) || + (let uu___12 = + let uu___13 = + FStarC_Syntax_Free.uvars phi22 in + FStarC_Class_Setlike.is_empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) + (Obj.magic uu___13) in + Prims.op_Negation uu___12) in + if + (problem.FStarC_TypeChecker_Common.relation + = FStarC_TypeChecker_Common.EQ) + || + ((Prims.op_Negation + env.FStarC_TypeChecker_Env.uvar_subtyping) + && has_uvars) + then + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_Syntax_Syntax.mk_binder + x13 in + [uu___14] in + mk_t_problem wl1 uu___13 orig phi12 + FStarC_TypeChecker_Common.EQ phi22 + FStar_Pervasives_Native.None + "refinement formula" in + (match uu___12 with + | (ref_prob, wl2) -> + let ref_prob1 = + set_logical true ref_prob in + let tx = + FStarC_Syntax_Unionfind.new_transaction + () in + let uu___13 = + solve + { + attempting = [ref_prob1]; + wl_deferred = + (Obj.magic + (FStarC_Class_Listlike.empty + () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist + ())))); + wl_deferred_to_tac = + (wl2.wl_deferred_to_tac); + ctr = (wl2.ctr); + defer_ok = NoDefer; + smt_ok = (wl2.smt_ok); + umax_heuristic_ok = + (wl2.umax_heuristic_ok); + tcenv = (wl2.tcenv); + wl_implicits = + (Obj.magic + (FStarC_Class_Listlike.empty + () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist + ())))); + repr_subcomp_allowed = + (wl2.repr_subcomp_allowed); + typeclass_variables = + (wl2.typeclass_variables) + } in + (match uu___13 with + | Failed (prob, msg) -> + (FStarC_Syntax_Unionfind.rollback + tx; + if + (((Prims.op_Negation + env.FStarC_TypeChecker_Env.uvar_subtyping) + && has_uvars) + || + (Prims.op_Negation + wl2.smt_ok)) + && + (Prims.op_Negation + env.FStarC_TypeChecker_Env.unif_allow_ref_guards) + then giveup wl2 msg prob + else fallback ()) + | Success + (uu___14, defer_to_tac, + imps) + -> + (FStarC_Syntax_Unionfind.commit + tx; + (let guard = + let uu___16 = + guard_on_element wl2 + problem x13 + (p_guard ref_prob1) in + FStarC_Syntax_Util.mk_conj + (p_guard base_prob) + uu___16 in + let wl3 = + solve_prob orig + (FStar_Pervasives_Native.Some + guard) [] wl2 in + let wl4 = + { + attempting = + (wl3.attempting); + wl_deferred = + (wl3.wl_deferred); + wl_deferred_to_tac = + (wl3.wl_deferred_to_tac); + ctr = + (wl3.ctr + + Prims.int_one); + defer_ok = + (wl3.defer_ok); + smt_ok = (wl3.smt_ok); + umax_heuristic_ok = + (wl3.umax_heuristic_ok); + tcenv = (wl3.tcenv); + wl_implicits = + (wl3.wl_implicits); + repr_subcomp_allowed = + (wl3.repr_subcomp_allowed); + typeclass_variables = + (wl3.typeclass_variables) + } in + let wl5 = + extend_wl wl4 + (Obj.magic + (FStarC_Class_Listlike.empty + () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist + ())))) + defer_to_tac imps in + let uu___16 = + attempt [base_prob] wl5 in + solve uu___16)))) + else fallback ()))))) + | (FStarC_Syntax_Syntax.Tm_uvar uu___7, + FStarC_Syntax_Syntax.Tm_uvar uu___8) -> + let env = p_env wl (FStarC_TypeChecker_Common.TProb problem) in + let uu___9 = ensure_no_uvar_subst env t1 wl in + (match uu___9 with + | (t11, wl1) -> + let t21 = FStarC_Syntax_Util.canon_app t2 in + let uu___10 = ensure_no_uvar_subst env t21 wl1 in + (match uu___10 with + | (t22, wl2) -> + let f1 = destruct_flex_t' t11 in + let f2 = destruct_flex_t' t22 in + solve_t_flex_flex env orig wl2 f1 f2)) + | (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_uvar + uu___7; + FStarC_Syntax_Syntax.pos = uu___8; + FStarC_Syntax_Syntax.vars = uu___9; + FStarC_Syntax_Syntax.hash_code = uu___10;_}; + FStarC_Syntax_Syntax.args = uu___11;_}, + FStarC_Syntax_Syntax.Tm_uvar uu___12) -> + let env = p_env wl (FStarC_TypeChecker_Common.TProb problem) in + let uu___13 = ensure_no_uvar_subst env t1 wl in + (match uu___13 with + | (t11, wl1) -> + let t21 = FStarC_Syntax_Util.canon_app t2 in + let uu___14 = ensure_no_uvar_subst env t21 wl1 in + (match uu___14 with + | (t22, wl2) -> + let f1 = destruct_flex_t' t11 in + let f2 = destruct_flex_t' t22 in + solve_t_flex_flex env orig wl2 f1 f2)) + | (FStarC_Syntax_Syntax.Tm_uvar uu___7, + FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_uvar + uu___8; + FStarC_Syntax_Syntax.pos = uu___9; + FStarC_Syntax_Syntax.vars = uu___10; + FStarC_Syntax_Syntax.hash_code = uu___11;_}; + FStarC_Syntax_Syntax.args = uu___12;_}) + -> + let env = p_env wl (FStarC_TypeChecker_Common.TProb problem) in + let uu___13 = ensure_no_uvar_subst env t1 wl in + (match uu___13 with + | (t11, wl1) -> + let t21 = FStarC_Syntax_Util.canon_app t2 in + let uu___14 = ensure_no_uvar_subst env t21 wl1 in + (match uu___14 with + | (t22, wl2) -> + let f1 = destruct_flex_t' t11 in + let f2 = destruct_flex_t' t22 in + solve_t_flex_flex env orig wl2 f1 f2)) + | (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_uvar + uu___7; + FStarC_Syntax_Syntax.pos = uu___8; + FStarC_Syntax_Syntax.vars = uu___9; + FStarC_Syntax_Syntax.hash_code = uu___10;_}; + FStarC_Syntax_Syntax.args = uu___11;_}, + FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_uvar + uu___12; + FStarC_Syntax_Syntax.pos = uu___13; + FStarC_Syntax_Syntax.vars = uu___14; + FStarC_Syntax_Syntax.hash_code = uu___15;_}; + FStarC_Syntax_Syntax.args = uu___16;_}) + -> + let env = p_env wl (FStarC_TypeChecker_Common.TProb problem) in + let uu___17 = ensure_no_uvar_subst env t1 wl in + (match uu___17 with + | (t11, wl1) -> + let t21 = FStarC_Syntax_Util.canon_app t2 in + let uu___18 = ensure_no_uvar_subst env t21 wl1 in + (match uu___18 with + | (t22, wl2) -> + let f1 = destruct_flex_t' t11 in + let f2 = destruct_flex_t' t22 in + solve_t_flex_flex env orig wl2 f1 f2)) + | (FStarC_Syntax_Syntax.Tm_uvar uu___7, uu___8) when + problem.FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.EQ + -> + let uu___9 = destruct_flex_t t1 wl in + (match uu___9 with + | (f1, wl1) -> solve_t_flex_rigid_eq orig wl1 f1 t2) + | (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_uvar + uu___7; + FStarC_Syntax_Syntax.pos = uu___8; + FStarC_Syntax_Syntax.vars = uu___9; + FStarC_Syntax_Syntax.hash_code = uu___10;_}; + FStarC_Syntax_Syntax.args = uu___11;_}, + uu___12) when + problem.FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.EQ + -> + let uu___13 = destruct_flex_t t1 wl in + (match uu___13 with + | (f1, wl1) -> solve_t_flex_rigid_eq orig wl1 f1 t2) + | (uu___7, FStarC_Syntax_Syntax.Tm_uvar uu___8) when + problem.FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.EQ + -> solve_t' (invert problem) wl + | (uu___7, FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_uvar + uu___8; + FStarC_Syntax_Syntax.pos = uu___9; + FStarC_Syntax_Syntax.vars = uu___10; + FStarC_Syntax_Syntax.hash_code = uu___11;_}; + FStarC_Syntax_Syntax.args = uu___12;_}) + when + problem.FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.EQ + -> solve_t' (invert problem) wl + | (FStarC_Syntax_Syntax.Tm_uvar uu___7, + FStarC_Syntax_Syntax.Tm_arrow uu___8) -> + solve_t' + { + FStarC_TypeChecker_Common.pid = + (problem.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = + (problem.FStarC_TypeChecker_Common.lhs); + FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.EQ; + FStarC_TypeChecker_Common.rhs = + (problem.FStarC_TypeChecker_Common.rhs); + FStarC_TypeChecker_Common.element = + (problem.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (problem.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar = + (problem.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (problem.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = + (problem.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (problem.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = + (problem.FStarC_TypeChecker_Common.logical) + } wl + | (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_uvar + uu___7; + FStarC_Syntax_Syntax.pos = uu___8; + FStarC_Syntax_Syntax.vars = uu___9; + FStarC_Syntax_Syntax.hash_code = uu___10;_}; + FStarC_Syntax_Syntax.args = uu___11;_}, + FStarC_Syntax_Syntax.Tm_arrow uu___12) -> + solve_t' + { + FStarC_TypeChecker_Common.pid = + (problem.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = + (problem.FStarC_TypeChecker_Common.lhs); + FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.EQ; + FStarC_TypeChecker_Common.rhs = + (problem.FStarC_TypeChecker_Common.rhs); + FStarC_TypeChecker_Common.element = + (problem.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (problem.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar = + (problem.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (problem.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = + (problem.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (problem.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = + (problem.FStarC_TypeChecker_Common.logical) + } wl + | (uu___7, FStarC_Syntax_Syntax.Tm_uvar uu___8) -> + let uu___9 = + attempt [FStarC_TypeChecker_Common.TProb problem] wl in + solve uu___9 + | (uu___7, FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_uvar + uu___8; + FStarC_Syntax_Syntax.pos = uu___9; + FStarC_Syntax_Syntax.vars = uu___10; + FStarC_Syntax_Syntax.hash_code = uu___11;_}; + FStarC_Syntax_Syntax.args = uu___12;_}) + -> + let uu___13 = + attempt [FStarC_TypeChecker_Common.TProb problem] wl in + solve uu___13 + | (FStarC_Syntax_Syntax.Tm_uvar uu___7, uu___8) -> + let uu___9 = + attempt [FStarC_TypeChecker_Common.TProb problem] wl in + solve uu___9 + | (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_uvar + uu___7; + FStarC_Syntax_Syntax.pos = uu___8; + FStarC_Syntax_Syntax.vars = uu___9; + FStarC_Syntax_Syntax.hash_code = uu___10;_}; + FStarC_Syntax_Syntax.args = uu___11;_}, + uu___12) -> + let uu___13 = + attempt [FStarC_TypeChecker_Common.TProb problem] wl in + solve uu___13 + | (FStarC_Syntax_Syntax.Tm_abs uu___7, uu___8) -> + let is_abs t = + match t.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_abs uu___9 -> + FStar_Pervasives.Inl t + | uu___9 -> FStar_Pervasives.Inr t in + let env = p_env wl orig in + (match ((is_abs t1), (is_abs t2)) with + | (FStar_Pervasives.Inl t_abs, FStar_Pervasives.Inr not_abs) + -> + let uu___9 = + (is_flex not_abs) && + ((p_rel orig) = FStarC_TypeChecker_Common.EQ) in + if uu___9 + then + let uu___10 = destruct_flex_t not_abs wl in + (match uu___10 with + | (flex, wl1) -> + solve_t_flex_rigid_eq orig wl1 flex t_abs) + else + (let uu___11 = + head_matches_delta env false wl.smt_ok not_abs + t_abs in + match uu___11 with + | (HeadMatch uu___12, FStar_Pervasives_Native.Some + (not_abs', uu___13)) -> + solve_t + { + FStarC_TypeChecker_Common.pid = + (problem.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = not_abs'; + FStarC_TypeChecker_Common.relation = + (problem.FStarC_TypeChecker_Common.relation); + FStarC_TypeChecker_Common.rhs = t_abs; + FStarC_TypeChecker_Common.element = + (problem.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (problem.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar + = + (problem.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (problem.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = + (problem.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (problem.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = + (problem.FStarC_TypeChecker_Common.logical) + } wl + | uu___12 -> + let uu___13 = + FStarC_Syntax_Util.head_and_args not_abs in + (match uu___13 with + | (head, uu___14) -> + let uu___15 = + wl.smt_ok && + (may_relate wl.tcenv (p_rel orig) head) in + if uu___15 + then + let uu___16 = mk_eq2 wl orig t_abs not_abs in + (match uu___16 with + | (g, wl1) -> + let uu___17 = + solve_prob orig + (FStar_Pervasives_Native.Some g) + [] wl1 in + solve uu___17) + else + (let uu___17 = + FStarC_Thunk.mkv + "head tag mismatch: RHS is an abstraction" in + giveup wl uu___17 orig))) + | (FStar_Pervasives.Inr not_abs, FStar_Pervasives.Inl t_abs) + -> + let uu___9 = + (is_flex not_abs) && + ((p_rel orig) = FStarC_TypeChecker_Common.EQ) in + if uu___9 + then + let uu___10 = destruct_flex_t not_abs wl in + (match uu___10 with + | (flex, wl1) -> + solve_t_flex_rigid_eq orig wl1 flex t_abs) + else + (let uu___11 = + head_matches_delta env false wl.smt_ok not_abs + t_abs in + match uu___11 with + | (HeadMatch uu___12, FStar_Pervasives_Native.Some + (not_abs', uu___13)) -> + solve_t + { + FStarC_TypeChecker_Common.pid = + (problem.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = not_abs'; + FStarC_TypeChecker_Common.relation = + (problem.FStarC_TypeChecker_Common.relation); + FStarC_TypeChecker_Common.rhs = t_abs; + FStarC_TypeChecker_Common.element = + (problem.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (problem.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar + = + (problem.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (problem.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = + (problem.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (problem.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = + (problem.FStarC_TypeChecker_Common.logical) + } wl + | uu___12 -> + let uu___13 = + FStarC_Syntax_Util.head_and_args not_abs in + (match uu___13 with + | (head, uu___14) -> + let uu___15 = + wl.smt_ok && + (may_relate wl.tcenv (p_rel orig) head) in + if uu___15 + then + let uu___16 = mk_eq2 wl orig t_abs not_abs in + (match uu___16 with + | (g, wl1) -> + let uu___17 = + solve_prob orig + (FStar_Pervasives_Native.Some g) + [] wl1 in + solve uu___17) + else + (let uu___17 = + FStarC_Thunk.mkv + "head tag mismatch: RHS is an abstraction" in + giveup wl uu___17 orig))) + | uu___9 -> + failwith + "Impossible: at least one side is an abstraction") + | (uu___7, FStarC_Syntax_Syntax.Tm_abs uu___8) -> + let is_abs t = + match t.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_abs uu___9 -> + FStar_Pervasives.Inl t + | uu___9 -> FStar_Pervasives.Inr t in + let env = p_env wl orig in + (match ((is_abs t1), (is_abs t2)) with + | (FStar_Pervasives.Inl t_abs, FStar_Pervasives.Inr not_abs) + -> + let uu___9 = + (is_flex not_abs) && + ((p_rel orig) = FStarC_TypeChecker_Common.EQ) in + if uu___9 + then + let uu___10 = destruct_flex_t not_abs wl in + (match uu___10 with + | (flex, wl1) -> + solve_t_flex_rigid_eq orig wl1 flex t_abs) + else + (let uu___11 = + head_matches_delta env false wl.smt_ok not_abs + t_abs in + match uu___11 with + | (HeadMatch uu___12, FStar_Pervasives_Native.Some + (not_abs', uu___13)) -> + solve_t + { + FStarC_TypeChecker_Common.pid = + (problem.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = not_abs'; + FStarC_TypeChecker_Common.relation = + (problem.FStarC_TypeChecker_Common.relation); + FStarC_TypeChecker_Common.rhs = t_abs; + FStarC_TypeChecker_Common.element = + (problem.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (problem.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar + = + (problem.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (problem.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = + (problem.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (problem.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = + (problem.FStarC_TypeChecker_Common.logical) + } wl + | uu___12 -> + let uu___13 = + FStarC_Syntax_Util.head_and_args not_abs in + (match uu___13 with + | (head, uu___14) -> + let uu___15 = + wl.smt_ok && + (may_relate wl.tcenv (p_rel orig) head) in + if uu___15 + then + let uu___16 = mk_eq2 wl orig t_abs not_abs in + (match uu___16 with + | (g, wl1) -> + let uu___17 = + solve_prob orig + (FStar_Pervasives_Native.Some g) + [] wl1 in + solve uu___17) + else + (let uu___17 = + FStarC_Thunk.mkv + "head tag mismatch: RHS is an abstraction" in + giveup wl uu___17 orig))) + | (FStar_Pervasives.Inr not_abs, FStar_Pervasives.Inl t_abs) + -> + let uu___9 = + (is_flex not_abs) && + ((p_rel orig) = FStarC_TypeChecker_Common.EQ) in + if uu___9 + then + let uu___10 = destruct_flex_t not_abs wl in + (match uu___10 with + | (flex, wl1) -> + solve_t_flex_rigid_eq orig wl1 flex t_abs) + else + (let uu___11 = + head_matches_delta env false wl.smt_ok not_abs + t_abs in + match uu___11 with + | (HeadMatch uu___12, FStar_Pervasives_Native.Some + (not_abs', uu___13)) -> + solve_t + { + FStarC_TypeChecker_Common.pid = + (problem.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = not_abs'; + FStarC_TypeChecker_Common.relation = + (problem.FStarC_TypeChecker_Common.relation); + FStarC_TypeChecker_Common.rhs = t_abs; + FStarC_TypeChecker_Common.element = + (problem.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (problem.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar + = + (problem.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (problem.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = + (problem.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (problem.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = + (problem.FStarC_TypeChecker_Common.logical) + } wl + | uu___12 -> + let uu___13 = + FStarC_Syntax_Util.head_and_args not_abs in + (match uu___13 with + | (head, uu___14) -> + let uu___15 = + wl.smt_ok && + (may_relate wl.tcenv (p_rel orig) head) in + if uu___15 + then + let uu___16 = mk_eq2 wl orig t_abs not_abs in + (match uu___16 with + | (g, wl1) -> + let uu___17 = + solve_prob orig + (FStar_Pervasives_Native.Some g) + [] wl1 in + solve uu___17) + else + (let uu___17 = + FStarC_Thunk.mkv + "head tag mismatch: RHS is an abstraction" in + giveup wl uu___17 orig))) + | uu___9 -> + failwith + "Impossible: at least one side is an abstraction") + | (FStarC_Syntax_Syntax.Tm_refine uu___7, uu___8) -> + let t21 = + let uu___9 = base_and_refinement (p_env wl orig) t2 in + force_refinement uu___9 in + solve_t' + { + FStarC_TypeChecker_Common.pid = + (problem.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = + (problem.FStarC_TypeChecker_Common.lhs); + FStarC_TypeChecker_Common.relation = + (problem.FStarC_TypeChecker_Common.relation); + FStarC_TypeChecker_Common.rhs = t21; + FStarC_TypeChecker_Common.element = + (problem.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (problem.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar = + (problem.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (problem.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = + (problem.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (problem.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = + (problem.FStarC_TypeChecker_Common.logical) + } wl + | (uu___7, FStarC_Syntax_Syntax.Tm_refine uu___8) -> + let t11 = + let uu___9 = base_and_refinement (p_env wl orig) t1 in + force_refinement uu___9 in + solve_t' + { + FStarC_TypeChecker_Common.pid = + (problem.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = t11; + FStarC_TypeChecker_Common.relation = + (problem.FStarC_TypeChecker_Common.relation); + FStarC_TypeChecker_Common.rhs = + (problem.FStarC_TypeChecker_Common.rhs); + FStarC_TypeChecker_Common.element = + (problem.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (problem.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar = + (problem.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (problem.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = + (problem.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (problem.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = + (problem.FStarC_TypeChecker_Common.logical) + } wl + | (FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = s1; + FStarC_Syntax_Syntax.ret_opt = uu___7; + FStarC_Syntax_Syntax.brs = brs1; + FStarC_Syntax_Syntax.rc_opt1 = uu___8;_}, + FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = s2; + FStarC_Syntax_Syntax.ret_opt = uu___9; + FStarC_Syntax_Syntax.brs = brs2; + FStarC_Syntax_Syntax.rc_opt1 = uu___10;_}) + -> + let by_smt uu___11 = + let uu___12 = guard_of_prob wl problem t1 t2 in + match uu___12 with + | (guard, wl1) -> + let uu___13 = + solve_prob orig (FStar_Pervasives_Native.Some guard) + [] wl1 in + solve uu___13 in + let rec solve_branches wl1 brs11 brs21 = + match (brs11, brs21) with + | (br1::rs1, br2::rs2) -> + let uu___11 = br1 in + (match uu___11 with + | (p1, w1, uu___12) -> + let uu___13 = br2 in + (match uu___13 with + | (p2, w2, uu___14) -> + let uu___15 = + let uu___16 = + FStarC_Syntax_Syntax.eq_pat p1 p2 in + Prims.op_Negation uu___16 in + if uu___15 + then FStar_Pervasives_Native.None + else + (let uu___17 = + FStarC_Syntax_Subst.open_branch' br1 in + match uu___17 with + | ((p11, w11, e1), s) -> + let uu___18 = br2 in + (match uu___18 with + | (p21, w21, e2) -> + let w22 = + FStarC_Compiler_Util.map_opt + w21 + (FStarC_Syntax_Subst.subst s) in + let e21 = + FStarC_Syntax_Subst.subst s e2 in + let scope = + let uu___19 = + FStarC_Syntax_Syntax.pat_bvs + p11 in + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.mk_binder + uu___19 in + let uu___19 = + match (w11, w22) with + | (FStar_Pervasives_Native.Some + uu___20, + FStar_Pervasives_Native.None) + -> + FStar_Pervasives_Native.None + | (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.Some + uu___20) -> + FStar_Pervasives_Native.None + | (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None) + -> + FStar_Pervasives_Native.Some + ([], wl1) + | (FStar_Pervasives_Native.Some + w12, + FStar_Pervasives_Native.Some + w23) -> + let uu___20 = + mk_t_problem wl1 scope + orig w12 + FStarC_TypeChecker_Common.EQ + w23 + FStar_Pervasives_Native.None + "when clause" in + (match uu___20 with + | (p, wl2) -> + FStar_Pervasives_Native.Some + ([(scope, p)], wl2)) in + FStarC_Compiler_Util.bind_opt + uu___19 + (fun uu___20 -> + match uu___20 with + | (wprobs, wl2) -> + let uu___21 = + mk_t_problem wl2 scope + orig e1 + FStarC_TypeChecker_Common.EQ + e21 + FStar_Pervasives_Native.None + "branch body" in + (match uu___21 with + | (prob, wl3) -> + ((let uu___23 = + FStarC_Compiler_Effect.op_Bang + dbg_Rel in + if uu___23 + then + let uu___24 = + prob_to_string' + wl3 prob in + let uu___25 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binder) + scope in + FStarC_Compiler_Util.print2 + "Created problem for branches %s with scope %s\n" + uu___24 + uu___25 + else ()); + (let uu___23 = + solve_branches + wl3 rs1 rs2 in + FStarC_Compiler_Util.bind_opt + uu___23 + (fun uu___24 -> + match uu___24 + with + | (r, wl4) + -> + FStar_Pervasives_Native.Some + (((scope, + prob) :: + (FStarC_Compiler_List.op_At + wprobs r)), + wl4)))))))))) + | ([], []) -> FStar_Pervasives_Native.Some ([], wl1) + | uu___11 -> FStar_Pervasives_Native.None in + let uu___11 = solve_branches wl brs1 brs2 in + (match uu___11 with + | FStar_Pervasives_Native.None -> + if wl.smt_ok + then by_smt () + else + (let uu___13 = + FStarC_Thunk.mkv "Tm_match branches don't match" in + giveup wl uu___13 orig) + | FStar_Pervasives_Native.Some (sub_probs, wl1) -> + let uu___12 = + mk_t_problem wl1 [] orig s1 + FStarC_TypeChecker_Common.EQ s2 + FStar_Pervasives_Native.None "match scrutinee" in + (match uu___12 with + | (sc_prob, wl2) -> + let sub_probs1 = ([], sc_prob) :: sub_probs in + let formula = + let uu___13 = + FStarC_Compiler_List.map + (fun uu___14 -> + match uu___14 with + | (scope, p) -> + FStarC_TypeChecker_Env.close_forall + (p_env wl2 orig) scope (p_guard p)) + sub_probs1 in + FStarC_Syntax_Util.mk_conj_l uu___13 in + let tx = FStarC_Syntax_Unionfind.new_transaction () in + let wl3 = + solve_prob orig + (FStar_Pervasives_Native.Some formula) [] wl2 in + let uu___13 = + let uu___14 = + let uu___15 = + FStarC_Compiler_List.map + FStar_Pervasives_Native.snd sub_probs1 in + attempt uu___15 + { + attempting = (wl3.attempting); + wl_deferred = (wl3.wl_deferred); + wl_deferred_to_tac = + (wl3.wl_deferred_to_tac); + ctr = (wl3.ctr); + defer_ok = (wl3.defer_ok); + smt_ok = false; + umax_heuristic_ok = (wl3.umax_heuristic_ok); + tcenv = (wl3.tcenv); + wl_implicits = (wl3.wl_implicits); + repr_subcomp_allowed = + (wl3.repr_subcomp_allowed); + typeclass_variables = + (wl3.typeclass_variables) + } in + solve uu___14 in + (match uu___13 with + | Success (ds, ds', imp) -> + (FStarC_Syntax_Unionfind.commit tx; + Success (ds, ds', imp)) + | Failed uu___14 -> + (FStarC_Syntax_Unionfind.rollback tx; + if wl3.smt_ok + then by_smt () + else + (let uu___17 = + FStarC_Thunk.mkv + "Could not unify matches without SMT" in + giveup wl3 uu___17 orig))))) + | (FStarC_Syntax_Syntax.Tm_match uu___7, uu___8) -> + let head1 = + let uu___9 = FStarC_Syntax_Util.head_and_args t1 in + FStar_Pervasives_Native.fst uu___9 in + let head2 = + let uu___9 = FStarC_Syntax_Util.head_and_args t2 in + FStar_Pervasives_Native.fst uu___9 in + ((let uu___10 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___10 + then + let uu___11 = + let uu___12 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + problem.FStarC_TypeChecker_Common.pid in + let uu___13 = + let uu___14 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + wl.smt_ok in + let uu___15 = + let uu___16 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head1 in + let uu___17 = + let uu___18 = + let uu___19 = + FStarC_TypeChecker_Env.is_interpreted + wl.tcenv head1 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___19 in + let uu___19 = + let uu___20 = + let uu___21 = no_free_uvars t1 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___21 in + let uu___21 = + let uu___22 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head2 in + let uu___23 = + let uu___24 = + let uu___25 = + FStarC_TypeChecker_Env.is_interpreted + wl.tcenv head2 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___25 in + let uu___25 = + let uu___26 = + let uu___27 = no_free_uvars t2 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___27 in + [uu___26] in + uu___24 :: uu___25 in + uu___22 :: uu___23 in + uu___20 :: uu___21 in + uu___18 :: uu___19 in + uu___16 :: uu___17 in + uu___14 :: uu___15 in + uu___12 :: uu___13 in + FStarC_Compiler_Util.print + ">> (%s) (smtok=%s)\n>>> head1 = %s [interpreted=%s; no_free_uvars=%s]\n>>> head2 = %s [interpreted=%s; no_free_uvars=%s]\n" + uu___11 + else ()); + (let equal t11 t21 = + let env = p_env wl orig in + let r = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in + match r with + | FStarC_TypeChecker_TermEqAndSimplify.Equal -> true + | FStarC_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStarC_TypeChecker_TermEqAndSimplify.Unknown -> + let steps = + [FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.Iota] in + let t12 = + norm_with_steps + "FStarC.TypeChecker.Rel.norm_with_steps.2" steps + env t11 in + let t22 = + norm_with_steps + "FStarC.TypeChecker.Rel.norm_with_steps.3" steps + env t21 in + let uu___10 = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStarC_TypeChecker_TermEqAndSimplify.Equal in + let uu___10 = + ((FStarC_TypeChecker_Env.is_interpreted wl.tcenv head1) + || + (FStarC_TypeChecker_Env.is_interpreted wl.tcenv head2)) + && + (problem.FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.EQ) in + if uu___10 + then + let solve_with_smt uu___11 = + let uu___12 = + let uu___13 = equal t1 t2 in + if uu___13 + then (FStar_Pervasives_Native.None, wl) + else + (let uu___15 = mk_eq2 wl orig t1 t2 in + match uu___15 with + | (g, wl1) -> + ((FStar_Pervasives_Native.Some g), wl1)) in + match uu___12 with + | (guard, wl1) -> + let uu___13 = solve_prob orig guard [] wl1 in + solve uu___13 in + let uu___11 = (no_free_uvars t1) && (no_free_uvars t2) in + (if uu___11 + then + let uu___12 = + (Prims.op_Negation wl.smt_ok) || + (FStarC_Options.ml_ish ()) in + (if uu___12 + then + let uu___13 = equal t1 t2 in + (if uu___13 + then + let uu___14 = + solve_prob orig FStar_Pervasives_Native.None + [] wl in + solve uu___14 + else + rigid_rigid_delta problem wl head1 head2 t1 t2) + else solve_with_smt ()) + else + (let uu___13 = + (Prims.op_Negation wl.smt_ok) || + (FStarC_Options.ml_ish ()) in + if uu___13 + then rigid_rigid_delta problem wl head1 head2 t1 t2 + else + try_solve_then_or_else wl + (fun wl_empty -> + rigid_rigid_delta problem wl_empty head1 head2 + t1 t2) (fun wl1 -> solve wl1) + (fun uu___15 -> solve_with_smt ()))) + else rigid_rigid_delta problem wl head1 head2 t1 t2)) + | (FStarC_Syntax_Syntax.Tm_uinst uu___7, uu___8) -> + let head1 = + let uu___9 = FStarC_Syntax_Util.head_and_args t1 in + FStar_Pervasives_Native.fst uu___9 in + let head2 = + let uu___9 = FStarC_Syntax_Util.head_and_args t2 in + FStar_Pervasives_Native.fst uu___9 in + ((let uu___10 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___10 + then + let uu___11 = + let uu___12 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + problem.FStarC_TypeChecker_Common.pid in + let uu___13 = + let uu___14 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + wl.smt_ok in + let uu___15 = + let uu___16 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head1 in + let uu___17 = + let uu___18 = + let uu___19 = + FStarC_TypeChecker_Env.is_interpreted + wl.tcenv head1 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___19 in + let uu___19 = + let uu___20 = + let uu___21 = no_free_uvars t1 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___21 in + let uu___21 = + let uu___22 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head2 in + let uu___23 = + let uu___24 = + let uu___25 = + FStarC_TypeChecker_Env.is_interpreted + wl.tcenv head2 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___25 in + let uu___25 = + let uu___26 = + let uu___27 = no_free_uvars t2 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___27 in + [uu___26] in + uu___24 :: uu___25 in + uu___22 :: uu___23 in + uu___20 :: uu___21 in + uu___18 :: uu___19 in + uu___16 :: uu___17 in + uu___14 :: uu___15 in + uu___12 :: uu___13 in + FStarC_Compiler_Util.print + ">> (%s) (smtok=%s)\n>>> head1 = %s [interpreted=%s; no_free_uvars=%s]\n>>> head2 = %s [interpreted=%s; no_free_uvars=%s]\n" + uu___11 + else ()); + (let equal t11 t21 = + let env = p_env wl orig in + let r = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in + match r with + | FStarC_TypeChecker_TermEqAndSimplify.Equal -> true + | FStarC_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStarC_TypeChecker_TermEqAndSimplify.Unknown -> + let steps = + [FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.Iota] in + let t12 = + norm_with_steps + "FStarC.TypeChecker.Rel.norm_with_steps.2" steps + env t11 in + let t22 = + norm_with_steps + "FStarC.TypeChecker.Rel.norm_with_steps.3" steps + env t21 in + let uu___10 = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStarC_TypeChecker_TermEqAndSimplify.Equal in + let uu___10 = + ((FStarC_TypeChecker_Env.is_interpreted wl.tcenv head1) + || + (FStarC_TypeChecker_Env.is_interpreted wl.tcenv head2)) + && + (problem.FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.EQ) in + if uu___10 + then + let solve_with_smt uu___11 = + let uu___12 = + let uu___13 = equal t1 t2 in + if uu___13 + then (FStar_Pervasives_Native.None, wl) + else + (let uu___15 = mk_eq2 wl orig t1 t2 in + match uu___15 with + | (g, wl1) -> + ((FStar_Pervasives_Native.Some g), wl1)) in + match uu___12 with + | (guard, wl1) -> + let uu___13 = solve_prob orig guard [] wl1 in + solve uu___13 in + let uu___11 = (no_free_uvars t1) && (no_free_uvars t2) in + (if uu___11 + then + let uu___12 = + (Prims.op_Negation wl.smt_ok) || + (FStarC_Options.ml_ish ()) in + (if uu___12 + then + let uu___13 = equal t1 t2 in + (if uu___13 + then + let uu___14 = + solve_prob orig FStar_Pervasives_Native.None + [] wl in + solve uu___14 + else + rigid_rigid_delta problem wl head1 head2 t1 t2) + else solve_with_smt ()) + else + (let uu___13 = + (Prims.op_Negation wl.smt_ok) || + (FStarC_Options.ml_ish ()) in + if uu___13 + then rigid_rigid_delta problem wl head1 head2 t1 t2 + else + try_solve_then_or_else wl + (fun wl_empty -> + rigid_rigid_delta problem wl_empty head1 head2 + t1 t2) (fun wl1 -> solve wl1) + (fun uu___15 -> solve_with_smt ()))) + else rigid_rigid_delta problem wl head1 head2 t1 t2)) + | (FStarC_Syntax_Syntax.Tm_name uu___7, uu___8) -> + let head1 = + let uu___9 = FStarC_Syntax_Util.head_and_args t1 in + FStar_Pervasives_Native.fst uu___9 in + let head2 = + let uu___9 = FStarC_Syntax_Util.head_and_args t2 in + FStar_Pervasives_Native.fst uu___9 in + ((let uu___10 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___10 + then + let uu___11 = + let uu___12 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + problem.FStarC_TypeChecker_Common.pid in + let uu___13 = + let uu___14 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + wl.smt_ok in + let uu___15 = + let uu___16 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head1 in + let uu___17 = + let uu___18 = + let uu___19 = + FStarC_TypeChecker_Env.is_interpreted + wl.tcenv head1 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___19 in + let uu___19 = + let uu___20 = + let uu___21 = no_free_uvars t1 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___21 in + let uu___21 = + let uu___22 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head2 in + let uu___23 = + let uu___24 = + let uu___25 = + FStarC_TypeChecker_Env.is_interpreted + wl.tcenv head2 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___25 in + let uu___25 = + let uu___26 = + let uu___27 = no_free_uvars t2 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___27 in + [uu___26] in + uu___24 :: uu___25 in + uu___22 :: uu___23 in + uu___20 :: uu___21 in + uu___18 :: uu___19 in + uu___16 :: uu___17 in + uu___14 :: uu___15 in + uu___12 :: uu___13 in + FStarC_Compiler_Util.print + ">> (%s) (smtok=%s)\n>>> head1 = %s [interpreted=%s; no_free_uvars=%s]\n>>> head2 = %s [interpreted=%s; no_free_uvars=%s]\n" + uu___11 + else ()); + (let equal t11 t21 = + let env = p_env wl orig in + let r = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in + match r with + | FStarC_TypeChecker_TermEqAndSimplify.Equal -> true + | FStarC_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStarC_TypeChecker_TermEqAndSimplify.Unknown -> + let steps = + [FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.Iota] in + let t12 = + norm_with_steps + "FStarC.TypeChecker.Rel.norm_with_steps.2" steps + env t11 in + let t22 = + norm_with_steps + "FStarC.TypeChecker.Rel.norm_with_steps.3" steps + env t21 in + let uu___10 = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStarC_TypeChecker_TermEqAndSimplify.Equal in + let uu___10 = + ((FStarC_TypeChecker_Env.is_interpreted wl.tcenv head1) + || + (FStarC_TypeChecker_Env.is_interpreted wl.tcenv head2)) + && + (problem.FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.EQ) in + if uu___10 + then + let solve_with_smt uu___11 = + let uu___12 = + let uu___13 = equal t1 t2 in + if uu___13 + then (FStar_Pervasives_Native.None, wl) + else + (let uu___15 = mk_eq2 wl orig t1 t2 in + match uu___15 with + | (g, wl1) -> + ((FStar_Pervasives_Native.Some g), wl1)) in + match uu___12 with + | (guard, wl1) -> + let uu___13 = solve_prob orig guard [] wl1 in + solve uu___13 in + let uu___11 = (no_free_uvars t1) && (no_free_uvars t2) in + (if uu___11 + then + let uu___12 = + (Prims.op_Negation wl.smt_ok) || + (FStarC_Options.ml_ish ()) in + (if uu___12 + then + let uu___13 = equal t1 t2 in + (if uu___13 + then + let uu___14 = + solve_prob orig FStar_Pervasives_Native.None + [] wl in + solve uu___14 + else + rigid_rigid_delta problem wl head1 head2 t1 t2) + else solve_with_smt ()) + else + (let uu___13 = + (Prims.op_Negation wl.smt_ok) || + (FStarC_Options.ml_ish ()) in + if uu___13 + then rigid_rigid_delta problem wl head1 head2 t1 t2 + else + try_solve_then_or_else wl + (fun wl_empty -> + rigid_rigid_delta problem wl_empty head1 head2 + t1 t2) (fun wl1 -> solve wl1) + (fun uu___15 -> solve_with_smt ()))) + else rigid_rigid_delta problem wl head1 head2 t1 t2)) + | (FStarC_Syntax_Syntax.Tm_constant uu___7, uu___8) -> + let head1 = + let uu___9 = FStarC_Syntax_Util.head_and_args t1 in + FStar_Pervasives_Native.fst uu___9 in + let head2 = + let uu___9 = FStarC_Syntax_Util.head_and_args t2 in + FStar_Pervasives_Native.fst uu___9 in + ((let uu___10 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___10 + then + let uu___11 = + let uu___12 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + problem.FStarC_TypeChecker_Common.pid in + let uu___13 = + let uu___14 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + wl.smt_ok in + let uu___15 = + let uu___16 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head1 in + let uu___17 = + let uu___18 = + let uu___19 = + FStarC_TypeChecker_Env.is_interpreted + wl.tcenv head1 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___19 in + let uu___19 = + let uu___20 = + let uu___21 = no_free_uvars t1 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___21 in + let uu___21 = + let uu___22 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head2 in + let uu___23 = + let uu___24 = + let uu___25 = + FStarC_TypeChecker_Env.is_interpreted + wl.tcenv head2 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___25 in + let uu___25 = + let uu___26 = + let uu___27 = no_free_uvars t2 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___27 in + [uu___26] in + uu___24 :: uu___25 in + uu___22 :: uu___23 in + uu___20 :: uu___21 in + uu___18 :: uu___19 in + uu___16 :: uu___17 in + uu___14 :: uu___15 in + uu___12 :: uu___13 in + FStarC_Compiler_Util.print + ">> (%s) (smtok=%s)\n>>> head1 = %s [interpreted=%s; no_free_uvars=%s]\n>>> head2 = %s [interpreted=%s; no_free_uvars=%s]\n" + uu___11 + else ()); + (let equal t11 t21 = + let env = p_env wl orig in + let r = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in + match r with + | FStarC_TypeChecker_TermEqAndSimplify.Equal -> true + | FStarC_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStarC_TypeChecker_TermEqAndSimplify.Unknown -> + let steps = + [FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.Iota] in + let t12 = + norm_with_steps + "FStarC.TypeChecker.Rel.norm_with_steps.2" steps + env t11 in + let t22 = + norm_with_steps + "FStarC.TypeChecker.Rel.norm_with_steps.3" steps + env t21 in + let uu___10 = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStarC_TypeChecker_TermEqAndSimplify.Equal in + let uu___10 = + ((FStarC_TypeChecker_Env.is_interpreted wl.tcenv head1) + || + (FStarC_TypeChecker_Env.is_interpreted wl.tcenv head2)) + && + (problem.FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.EQ) in + if uu___10 + then + let solve_with_smt uu___11 = + let uu___12 = + let uu___13 = equal t1 t2 in + if uu___13 + then (FStar_Pervasives_Native.None, wl) + else + (let uu___15 = mk_eq2 wl orig t1 t2 in + match uu___15 with + | (g, wl1) -> + ((FStar_Pervasives_Native.Some g), wl1)) in + match uu___12 with + | (guard, wl1) -> + let uu___13 = solve_prob orig guard [] wl1 in + solve uu___13 in + let uu___11 = (no_free_uvars t1) && (no_free_uvars t2) in + (if uu___11 + then + let uu___12 = + (Prims.op_Negation wl.smt_ok) || + (FStarC_Options.ml_ish ()) in + (if uu___12 + then + let uu___13 = equal t1 t2 in + (if uu___13 + then + let uu___14 = + solve_prob orig FStar_Pervasives_Native.None + [] wl in + solve uu___14 + else + rigid_rigid_delta problem wl head1 head2 t1 t2) + else solve_with_smt ()) + else + (let uu___13 = + (Prims.op_Negation wl.smt_ok) || + (FStarC_Options.ml_ish ()) in + if uu___13 + then rigid_rigid_delta problem wl head1 head2 t1 t2 + else + try_solve_then_or_else wl + (fun wl_empty -> + rigid_rigid_delta problem wl_empty head1 head2 + t1 t2) (fun wl1 -> solve wl1) + (fun uu___15 -> solve_with_smt ()))) + else rigid_rigid_delta problem wl head1 head2 t1 t2)) + | (FStarC_Syntax_Syntax.Tm_fvar uu___7, uu___8) -> + let head1 = + let uu___9 = FStarC_Syntax_Util.head_and_args t1 in + FStar_Pervasives_Native.fst uu___9 in + let head2 = + let uu___9 = FStarC_Syntax_Util.head_and_args t2 in + FStar_Pervasives_Native.fst uu___9 in + ((let uu___10 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___10 + then + let uu___11 = + let uu___12 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + problem.FStarC_TypeChecker_Common.pid in + let uu___13 = + let uu___14 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + wl.smt_ok in + let uu___15 = + let uu___16 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head1 in + let uu___17 = + let uu___18 = + let uu___19 = + FStarC_TypeChecker_Env.is_interpreted + wl.tcenv head1 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___19 in + let uu___19 = + let uu___20 = + let uu___21 = no_free_uvars t1 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___21 in + let uu___21 = + let uu___22 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head2 in + let uu___23 = + let uu___24 = + let uu___25 = + FStarC_TypeChecker_Env.is_interpreted + wl.tcenv head2 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___25 in + let uu___25 = + let uu___26 = + let uu___27 = no_free_uvars t2 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___27 in + [uu___26] in + uu___24 :: uu___25 in + uu___22 :: uu___23 in + uu___20 :: uu___21 in + uu___18 :: uu___19 in + uu___16 :: uu___17 in + uu___14 :: uu___15 in + uu___12 :: uu___13 in + FStarC_Compiler_Util.print + ">> (%s) (smtok=%s)\n>>> head1 = %s [interpreted=%s; no_free_uvars=%s]\n>>> head2 = %s [interpreted=%s; no_free_uvars=%s]\n" + uu___11 + else ()); + (let equal t11 t21 = + let env = p_env wl orig in + let r = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in + match r with + | FStarC_TypeChecker_TermEqAndSimplify.Equal -> true + | FStarC_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStarC_TypeChecker_TermEqAndSimplify.Unknown -> + let steps = + [FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.Iota] in + let t12 = + norm_with_steps + "FStarC.TypeChecker.Rel.norm_with_steps.2" steps + env t11 in + let t22 = + norm_with_steps + "FStarC.TypeChecker.Rel.norm_with_steps.3" steps + env t21 in + let uu___10 = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStarC_TypeChecker_TermEqAndSimplify.Equal in + let uu___10 = + ((FStarC_TypeChecker_Env.is_interpreted wl.tcenv head1) + || + (FStarC_TypeChecker_Env.is_interpreted wl.tcenv head2)) + && + (problem.FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.EQ) in + if uu___10 + then + let solve_with_smt uu___11 = + let uu___12 = + let uu___13 = equal t1 t2 in + if uu___13 + then (FStar_Pervasives_Native.None, wl) + else + (let uu___15 = mk_eq2 wl orig t1 t2 in + match uu___15 with + | (g, wl1) -> + ((FStar_Pervasives_Native.Some g), wl1)) in + match uu___12 with + | (guard, wl1) -> + let uu___13 = solve_prob orig guard [] wl1 in + solve uu___13 in + let uu___11 = (no_free_uvars t1) && (no_free_uvars t2) in + (if uu___11 + then + let uu___12 = + (Prims.op_Negation wl.smt_ok) || + (FStarC_Options.ml_ish ()) in + (if uu___12 + then + let uu___13 = equal t1 t2 in + (if uu___13 + then + let uu___14 = + solve_prob orig FStar_Pervasives_Native.None + [] wl in + solve uu___14 + else + rigid_rigid_delta problem wl head1 head2 t1 t2) + else solve_with_smt ()) + else + (let uu___13 = + (Prims.op_Negation wl.smt_ok) || + (FStarC_Options.ml_ish ()) in + if uu___13 + then rigid_rigid_delta problem wl head1 head2 t1 t2 + else + try_solve_then_or_else wl + (fun wl_empty -> + rigid_rigid_delta problem wl_empty head1 head2 + t1 t2) (fun wl1 -> solve wl1) + (fun uu___15 -> solve_with_smt ()))) + else rigid_rigid_delta problem wl head1 head2 t1 t2)) + | (FStarC_Syntax_Syntax.Tm_app uu___7, uu___8) -> + let head1 = + let uu___9 = FStarC_Syntax_Util.head_and_args t1 in + FStar_Pervasives_Native.fst uu___9 in + let head2 = + let uu___9 = FStarC_Syntax_Util.head_and_args t2 in + FStar_Pervasives_Native.fst uu___9 in + ((let uu___10 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___10 + then + let uu___11 = + let uu___12 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + problem.FStarC_TypeChecker_Common.pid in + let uu___13 = + let uu___14 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + wl.smt_ok in + let uu___15 = + let uu___16 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head1 in + let uu___17 = + let uu___18 = + let uu___19 = + FStarC_TypeChecker_Env.is_interpreted + wl.tcenv head1 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___19 in + let uu___19 = + let uu___20 = + let uu___21 = no_free_uvars t1 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___21 in + let uu___21 = + let uu___22 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head2 in + let uu___23 = + let uu___24 = + let uu___25 = + FStarC_TypeChecker_Env.is_interpreted + wl.tcenv head2 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___25 in + let uu___25 = + let uu___26 = + let uu___27 = no_free_uvars t2 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___27 in + [uu___26] in + uu___24 :: uu___25 in + uu___22 :: uu___23 in + uu___20 :: uu___21 in + uu___18 :: uu___19 in + uu___16 :: uu___17 in + uu___14 :: uu___15 in + uu___12 :: uu___13 in + FStarC_Compiler_Util.print + ">> (%s) (smtok=%s)\n>>> head1 = %s [interpreted=%s; no_free_uvars=%s]\n>>> head2 = %s [interpreted=%s; no_free_uvars=%s]\n" + uu___11 + else ()); + (let equal t11 t21 = + let env = p_env wl orig in + let r = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in + match r with + | FStarC_TypeChecker_TermEqAndSimplify.Equal -> true + | FStarC_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStarC_TypeChecker_TermEqAndSimplify.Unknown -> + let steps = + [FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.Iota] in + let t12 = + norm_with_steps + "FStarC.TypeChecker.Rel.norm_with_steps.2" steps + env t11 in + let t22 = + norm_with_steps + "FStarC.TypeChecker.Rel.norm_with_steps.3" steps + env t21 in + let uu___10 = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStarC_TypeChecker_TermEqAndSimplify.Equal in + let uu___10 = + ((FStarC_TypeChecker_Env.is_interpreted wl.tcenv head1) + || + (FStarC_TypeChecker_Env.is_interpreted wl.tcenv head2)) + && + (problem.FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.EQ) in + if uu___10 + then + let solve_with_smt uu___11 = + let uu___12 = + let uu___13 = equal t1 t2 in + if uu___13 + then (FStar_Pervasives_Native.None, wl) + else + (let uu___15 = mk_eq2 wl orig t1 t2 in + match uu___15 with + | (g, wl1) -> + ((FStar_Pervasives_Native.Some g), wl1)) in + match uu___12 with + | (guard, wl1) -> + let uu___13 = solve_prob orig guard [] wl1 in + solve uu___13 in + let uu___11 = (no_free_uvars t1) && (no_free_uvars t2) in + (if uu___11 + then + let uu___12 = + (Prims.op_Negation wl.smt_ok) || + (FStarC_Options.ml_ish ()) in + (if uu___12 + then + let uu___13 = equal t1 t2 in + (if uu___13 + then + let uu___14 = + solve_prob orig FStar_Pervasives_Native.None + [] wl in + solve uu___14 + else + rigid_rigid_delta problem wl head1 head2 t1 t2) + else solve_with_smt ()) + else + (let uu___13 = + (Prims.op_Negation wl.smt_ok) || + (FStarC_Options.ml_ish ()) in + if uu___13 + then rigid_rigid_delta problem wl head1 head2 t1 t2 + else + try_solve_then_or_else wl + (fun wl_empty -> + rigid_rigid_delta problem wl_empty head1 head2 + t1 t2) (fun wl1 -> solve wl1) + (fun uu___15 -> solve_with_smt ()))) + else rigid_rigid_delta problem wl head1 head2 t1 t2)) + | (uu___7, FStarC_Syntax_Syntax.Tm_match uu___8) -> + let head1 = + let uu___9 = FStarC_Syntax_Util.head_and_args t1 in + FStar_Pervasives_Native.fst uu___9 in + let head2 = + let uu___9 = FStarC_Syntax_Util.head_and_args t2 in + FStar_Pervasives_Native.fst uu___9 in + ((let uu___10 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___10 + then + let uu___11 = + let uu___12 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + problem.FStarC_TypeChecker_Common.pid in + let uu___13 = + let uu___14 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + wl.smt_ok in + let uu___15 = + let uu___16 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head1 in + let uu___17 = + let uu___18 = + let uu___19 = + FStarC_TypeChecker_Env.is_interpreted + wl.tcenv head1 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___19 in + let uu___19 = + let uu___20 = + let uu___21 = no_free_uvars t1 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___21 in + let uu___21 = + let uu___22 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head2 in + let uu___23 = + let uu___24 = + let uu___25 = + FStarC_TypeChecker_Env.is_interpreted + wl.tcenv head2 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___25 in + let uu___25 = + let uu___26 = + let uu___27 = no_free_uvars t2 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___27 in + [uu___26] in + uu___24 :: uu___25 in + uu___22 :: uu___23 in + uu___20 :: uu___21 in + uu___18 :: uu___19 in + uu___16 :: uu___17 in + uu___14 :: uu___15 in + uu___12 :: uu___13 in + FStarC_Compiler_Util.print + ">> (%s) (smtok=%s)\n>>> head1 = %s [interpreted=%s; no_free_uvars=%s]\n>>> head2 = %s [interpreted=%s; no_free_uvars=%s]\n" + uu___11 + else ()); + (let equal t11 t21 = + let env = p_env wl orig in + let r = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in + match r with + | FStarC_TypeChecker_TermEqAndSimplify.Equal -> true + | FStarC_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStarC_TypeChecker_TermEqAndSimplify.Unknown -> + let steps = + [FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.Iota] in + let t12 = + norm_with_steps + "FStarC.TypeChecker.Rel.norm_with_steps.2" steps + env t11 in + let t22 = + norm_with_steps + "FStarC.TypeChecker.Rel.norm_with_steps.3" steps + env t21 in + let uu___10 = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStarC_TypeChecker_TermEqAndSimplify.Equal in + let uu___10 = + ((FStarC_TypeChecker_Env.is_interpreted wl.tcenv head1) + || + (FStarC_TypeChecker_Env.is_interpreted wl.tcenv head2)) + && + (problem.FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.EQ) in + if uu___10 + then + let solve_with_smt uu___11 = + let uu___12 = + let uu___13 = equal t1 t2 in + if uu___13 + then (FStar_Pervasives_Native.None, wl) + else + (let uu___15 = mk_eq2 wl orig t1 t2 in + match uu___15 with + | (g, wl1) -> + ((FStar_Pervasives_Native.Some g), wl1)) in + match uu___12 with + | (guard, wl1) -> + let uu___13 = solve_prob orig guard [] wl1 in + solve uu___13 in + let uu___11 = (no_free_uvars t1) && (no_free_uvars t2) in + (if uu___11 + then + let uu___12 = + (Prims.op_Negation wl.smt_ok) || + (FStarC_Options.ml_ish ()) in + (if uu___12 + then + let uu___13 = equal t1 t2 in + (if uu___13 + then + let uu___14 = + solve_prob orig FStar_Pervasives_Native.None + [] wl in + solve uu___14 + else + rigid_rigid_delta problem wl head1 head2 t1 t2) + else solve_with_smt ()) + else + (let uu___13 = + (Prims.op_Negation wl.smt_ok) || + (FStarC_Options.ml_ish ()) in + if uu___13 + then rigid_rigid_delta problem wl head1 head2 t1 t2 + else + try_solve_then_or_else wl + (fun wl_empty -> + rigid_rigid_delta problem wl_empty head1 head2 + t1 t2) (fun wl1 -> solve wl1) + (fun uu___15 -> solve_with_smt ()))) + else rigid_rigid_delta problem wl head1 head2 t1 t2)) + | (uu___7, FStarC_Syntax_Syntax.Tm_uinst uu___8) -> + let head1 = + let uu___9 = FStarC_Syntax_Util.head_and_args t1 in + FStar_Pervasives_Native.fst uu___9 in + let head2 = + let uu___9 = FStarC_Syntax_Util.head_and_args t2 in + FStar_Pervasives_Native.fst uu___9 in + ((let uu___10 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___10 + then + let uu___11 = + let uu___12 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + problem.FStarC_TypeChecker_Common.pid in + let uu___13 = + let uu___14 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + wl.smt_ok in + let uu___15 = + let uu___16 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head1 in + let uu___17 = + let uu___18 = + let uu___19 = + FStarC_TypeChecker_Env.is_interpreted + wl.tcenv head1 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___19 in + let uu___19 = + let uu___20 = + let uu___21 = no_free_uvars t1 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___21 in + let uu___21 = + let uu___22 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head2 in + let uu___23 = + let uu___24 = + let uu___25 = + FStarC_TypeChecker_Env.is_interpreted + wl.tcenv head2 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___25 in + let uu___25 = + let uu___26 = + let uu___27 = no_free_uvars t2 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___27 in + [uu___26] in + uu___24 :: uu___25 in + uu___22 :: uu___23 in + uu___20 :: uu___21 in + uu___18 :: uu___19 in + uu___16 :: uu___17 in + uu___14 :: uu___15 in + uu___12 :: uu___13 in + FStarC_Compiler_Util.print + ">> (%s) (smtok=%s)\n>>> head1 = %s [interpreted=%s; no_free_uvars=%s]\n>>> head2 = %s [interpreted=%s; no_free_uvars=%s]\n" + uu___11 + else ()); + (let equal t11 t21 = + let env = p_env wl orig in + let r = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in + match r with + | FStarC_TypeChecker_TermEqAndSimplify.Equal -> true + | FStarC_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStarC_TypeChecker_TermEqAndSimplify.Unknown -> + let steps = + [FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.Iota] in + let t12 = + norm_with_steps + "FStarC.TypeChecker.Rel.norm_with_steps.2" steps + env t11 in + let t22 = + norm_with_steps + "FStarC.TypeChecker.Rel.norm_with_steps.3" steps + env t21 in + let uu___10 = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStarC_TypeChecker_TermEqAndSimplify.Equal in + let uu___10 = + ((FStarC_TypeChecker_Env.is_interpreted wl.tcenv head1) + || + (FStarC_TypeChecker_Env.is_interpreted wl.tcenv head2)) + && + (problem.FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.EQ) in + if uu___10 + then + let solve_with_smt uu___11 = + let uu___12 = + let uu___13 = equal t1 t2 in + if uu___13 + then (FStar_Pervasives_Native.None, wl) + else + (let uu___15 = mk_eq2 wl orig t1 t2 in + match uu___15 with + | (g, wl1) -> + ((FStar_Pervasives_Native.Some g), wl1)) in + match uu___12 with + | (guard, wl1) -> + let uu___13 = solve_prob orig guard [] wl1 in + solve uu___13 in + let uu___11 = (no_free_uvars t1) && (no_free_uvars t2) in + (if uu___11 + then + let uu___12 = + (Prims.op_Negation wl.smt_ok) || + (FStarC_Options.ml_ish ()) in + (if uu___12 + then + let uu___13 = equal t1 t2 in + (if uu___13 + then + let uu___14 = + solve_prob orig FStar_Pervasives_Native.None + [] wl in + solve uu___14 + else + rigid_rigid_delta problem wl head1 head2 t1 t2) + else solve_with_smt ()) + else + (let uu___13 = + (Prims.op_Negation wl.smt_ok) || + (FStarC_Options.ml_ish ()) in + if uu___13 + then rigid_rigid_delta problem wl head1 head2 t1 t2 + else + try_solve_then_or_else wl + (fun wl_empty -> + rigid_rigid_delta problem wl_empty head1 head2 + t1 t2) (fun wl1 -> solve wl1) + (fun uu___15 -> solve_with_smt ()))) + else rigid_rigid_delta problem wl head1 head2 t1 t2)) + | (uu___7, FStarC_Syntax_Syntax.Tm_name uu___8) -> + let head1 = + let uu___9 = FStarC_Syntax_Util.head_and_args t1 in + FStar_Pervasives_Native.fst uu___9 in + let head2 = + let uu___9 = FStarC_Syntax_Util.head_and_args t2 in + FStar_Pervasives_Native.fst uu___9 in + ((let uu___10 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___10 + then + let uu___11 = + let uu___12 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + problem.FStarC_TypeChecker_Common.pid in + let uu___13 = + let uu___14 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + wl.smt_ok in + let uu___15 = + let uu___16 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head1 in + let uu___17 = + let uu___18 = + let uu___19 = + FStarC_TypeChecker_Env.is_interpreted + wl.tcenv head1 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___19 in + let uu___19 = + let uu___20 = + let uu___21 = no_free_uvars t1 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___21 in + let uu___21 = + let uu___22 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head2 in + let uu___23 = + let uu___24 = + let uu___25 = + FStarC_TypeChecker_Env.is_interpreted + wl.tcenv head2 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___25 in + let uu___25 = + let uu___26 = + let uu___27 = no_free_uvars t2 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___27 in + [uu___26] in + uu___24 :: uu___25 in + uu___22 :: uu___23 in + uu___20 :: uu___21 in + uu___18 :: uu___19 in + uu___16 :: uu___17 in + uu___14 :: uu___15 in + uu___12 :: uu___13 in + FStarC_Compiler_Util.print + ">> (%s) (smtok=%s)\n>>> head1 = %s [interpreted=%s; no_free_uvars=%s]\n>>> head2 = %s [interpreted=%s; no_free_uvars=%s]\n" + uu___11 + else ()); + (let equal t11 t21 = + let env = p_env wl orig in + let r = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in + match r with + | FStarC_TypeChecker_TermEqAndSimplify.Equal -> true + | FStarC_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStarC_TypeChecker_TermEqAndSimplify.Unknown -> + let steps = + [FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.Iota] in + let t12 = + norm_with_steps + "FStarC.TypeChecker.Rel.norm_with_steps.2" steps + env t11 in + let t22 = + norm_with_steps + "FStarC.TypeChecker.Rel.norm_with_steps.3" steps + env t21 in + let uu___10 = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStarC_TypeChecker_TermEqAndSimplify.Equal in + let uu___10 = + ((FStarC_TypeChecker_Env.is_interpreted wl.tcenv head1) + || + (FStarC_TypeChecker_Env.is_interpreted wl.tcenv head2)) + && + (problem.FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.EQ) in + if uu___10 + then + let solve_with_smt uu___11 = + let uu___12 = + let uu___13 = equal t1 t2 in + if uu___13 + then (FStar_Pervasives_Native.None, wl) + else + (let uu___15 = mk_eq2 wl orig t1 t2 in + match uu___15 with + | (g, wl1) -> + ((FStar_Pervasives_Native.Some g), wl1)) in + match uu___12 with + | (guard, wl1) -> + let uu___13 = solve_prob orig guard [] wl1 in + solve uu___13 in + let uu___11 = (no_free_uvars t1) && (no_free_uvars t2) in + (if uu___11 + then + let uu___12 = + (Prims.op_Negation wl.smt_ok) || + (FStarC_Options.ml_ish ()) in + (if uu___12 + then + let uu___13 = equal t1 t2 in + (if uu___13 + then + let uu___14 = + solve_prob orig FStar_Pervasives_Native.None + [] wl in + solve uu___14 + else + rigid_rigid_delta problem wl head1 head2 t1 t2) + else solve_with_smt ()) + else + (let uu___13 = + (Prims.op_Negation wl.smt_ok) || + (FStarC_Options.ml_ish ()) in + if uu___13 + then rigid_rigid_delta problem wl head1 head2 t1 t2 + else + try_solve_then_or_else wl + (fun wl_empty -> + rigid_rigid_delta problem wl_empty head1 head2 + t1 t2) (fun wl1 -> solve wl1) + (fun uu___15 -> solve_with_smt ()))) + else rigid_rigid_delta problem wl head1 head2 t1 t2)) + | (uu___7, FStarC_Syntax_Syntax.Tm_constant uu___8) -> + let head1 = + let uu___9 = FStarC_Syntax_Util.head_and_args t1 in + FStar_Pervasives_Native.fst uu___9 in + let head2 = + let uu___9 = FStarC_Syntax_Util.head_and_args t2 in + FStar_Pervasives_Native.fst uu___9 in + ((let uu___10 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___10 + then + let uu___11 = + let uu___12 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + problem.FStarC_TypeChecker_Common.pid in + let uu___13 = + let uu___14 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + wl.smt_ok in + let uu___15 = + let uu___16 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head1 in + let uu___17 = + let uu___18 = + let uu___19 = + FStarC_TypeChecker_Env.is_interpreted + wl.tcenv head1 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___19 in + let uu___19 = + let uu___20 = + let uu___21 = no_free_uvars t1 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___21 in + let uu___21 = + let uu___22 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head2 in + let uu___23 = + let uu___24 = + let uu___25 = + FStarC_TypeChecker_Env.is_interpreted + wl.tcenv head2 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___25 in + let uu___25 = + let uu___26 = + let uu___27 = no_free_uvars t2 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___27 in + [uu___26] in + uu___24 :: uu___25 in + uu___22 :: uu___23 in + uu___20 :: uu___21 in + uu___18 :: uu___19 in + uu___16 :: uu___17 in + uu___14 :: uu___15 in + uu___12 :: uu___13 in + FStarC_Compiler_Util.print + ">> (%s) (smtok=%s)\n>>> head1 = %s [interpreted=%s; no_free_uvars=%s]\n>>> head2 = %s [interpreted=%s; no_free_uvars=%s]\n" + uu___11 + else ()); + (let equal t11 t21 = + let env = p_env wl orig in + let r = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in + match r with + | FStarC_TypeChecker_TermEqAndSimplify.Equal -> true + | FStarC_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStarC_TypeChecker_TermEqAndSimplify.Unknown -> + let steps = + [FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.Iota] in + let t12 = + norm_with_steps + "FStarC.TypeChecker.Rel.norm_with_steps.2" steps + env t11 in + let t22 = + norm_with_steps + "FStarC.TypeChecker.Rel.norm_with_steps.3" steps + env t21 in + let uu___10 = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStarC_TypeChecker_TermEqAndSimplify.Equal in + let uu___10 = + ((FStarC_TypeChecker_Env.is_interpreted wl.tcenv head1) + || + (FStarC_TypeChecker_Env.is_interpreted wl.tcenv head2)) + && + (problem.FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.EQ) in + if uu___10 + then + let solve_with_smt uu___11 = + let uu___12 = + let uu___13 = equal t1 t2 in + if uu___13 + then (FStar_Pervasives_Native.None, wl) + else + (let uu___15 = mk_eq2 wl orig t1 t2 in + match uu___15 with + | (g, wl1) -> + ((FStar_Pervasives_Native.Some g), wl1)) in + match uu___12 with + | (guard, wl1) -> + let uu___13 = solve_prob orig guard [] wl1 in + solve uu___13 in + let uu___11 = (no_free_uvars t1) && (no_free_uvars t2) in + (if uu___11 + then + let uu___12 = + (Prims.op_Negation wl.smt_ok) || + (FStarC_Options.ml_ish ()) in + (if uu___12 + then + let uu___13 = equal t1 t2 in + (if uu___13 + then + let uu___14 = + solve_prob orig FStar_Pervasives_Native.None + [] wl in + solve uu___14 + else + rigid_rigid_delta problem wl head1 head2 t1 t2) + else solve_with_smt ()) + else + (let uu___13 = + (Prims.op_Negation wl.smt_ok) || + (FStarC_Options.ml_ish ()) in + if uu___13 + then rigid_rigid_delta problem wl head1 head2 t1 t2 + else + try_solve_then_or_else wl + (fun wl_empty -> + rigid_rigid_delta problem wl_empty head1 head2 + t1 t2) (fun wl1 -> solve wl1) + (fun uu___15 -> solve_with_smt ()))) + else rigid_rigid_delta problem wl head1 head2 t1 t2)) + | (uu___7, FStarC_Syntax_Syntax.Tm_fvar uu___8) -> + let head1 = + let uu___9 = FStarC_Syntax_Util.head_and_args t1 in + FStar_Pervasives_Native.fst uu___9 in + let head2 = + let uu___9 = FStarC_Syntax_Util.head_and_args t2 in + FStar_Pervasives_Native.fst uu___9 in + ((let uu___10 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___10 + then + let uu___11 = + let uu___12 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + problem.FStarC_TypeChecker_Common.pid in + let uu___13 = + let uu___14 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + wl.smt_ok in + let uu___15 = + let uu___16 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head1 in + let uu___17 = + let uu___18 = + let uu___19 = + FStarC_TypeChecker_Env.is_interpreted + wl.tcenv head1 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___19 in + let uu___19 = + let uu___20 = + let uu___21 = no_free_uvars t1 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___21 in + let uu___21 = + let uu___22 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head2 in + let uu___23 = + let uu___24 = + let uu___25 = + FStarC_TypeChecker_Env.is_interpreted + wl.tcenv head2 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___25 in + let uu___25 = + let uu___26 = + let uu___27 = no_free_uvars t2 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___27 in + [uu___26] in + uu___24 :: uu___25 in + uu___22 :: uu___23 in + uu___20 :: uu___21 in + uu___18 :: uu___19 in + uu___16 :: uu___17 in + uu___14 :: uu___15 in + uu___12 :: uu___13 in + FStarC_Compiler_Util.print + ">> (%s) (smtok=%s)\n>>> head1 = %s [interpreted=%s; no_free_uvars=%s]\n>>> head2 = %s [interpreted=%s; no_free_uvars=%s]\n" + uu___11 + else ()); + (let equal t11 t21 = + let env = p_env wl orig in + let r = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in + match r with + | FStarC_TypeChecker_TermEqAndSimplify.Equal -> true + | FStarC_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStarC_TypeChecker_TermEqAndSimplify.Unknown -> + let steps = + [FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.Iota] in + let t12 = + norm_with_steps + "FStarC.TypeChecker.Rel.norm_with_steps.2" steps + env t11 in + let t22 = + norm_with_steps + "FStarC.TypeChecker.Rel.norm_with_steps.3" steps + env t21 in + let uu___10 = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStarC_TypeChecker_TermEqAndSimplify.Equal in + let uu___10 = + ((FStarC_TypeChecker_Env.is_interpreted wl.tcenv head1) + || + (FStarC_TypeChecker_Env.is_interpreted wl.tcenv head2)) + && + (problem.FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.EQ) in + if uu___10 + then + let solve_with_smt uu___11 = + let uu___12 = + let uu___13 = equal t1 t2 in + if uu___13 + then (FStar_Pervasives_Native.None, wl) + else + (let uu___15 = mk_eq2 wl orig t1 t2 in + match uu___15 with + | (g, wl1) -> + ((FStar_Pervasives_Native.Some g), wl1)) in + match uu___12 with + | (guard, wl1) -> + let uu___13 = solve_prob orig guard [] wl1 in + solve uu___13 in + let uu___11 = (no_free_uvars t1) && (no_free_uvars t2) in + (if uu___11 + then + let uu___12 = + (Prims.op_Negation wl.smt_ok) || + (FStarC_Options.ml_ish ()) in + (if uu___12 + then + let uu___13 = equal t1 t2 in + (if uu___13 + then + let uu___14 = + solve_prob orig FStar_Pervasives_Native.None + [] wl in + solve uu___14 + else + rigid_rigid_delta problem wl head1 head2 t1 t2) + else solve_with_smt ()) + else + (let uu___13 = + (Prims.op_Negation wl.smt_ok) || + (FStarC_Options.ml_ish ()) in + if uu___13 + then rigid_rigid_delta problem wl head1 head2 t1 t2 + else + try_solve_then_or_else wl + (fun wl_empty -> + rigid_rigid_delta problem wl_empty head1 head2 + t1 t2) (fun wl1 -> solve wl1) + (fun uu___15 -> solve_with_smt ()))) + else rigid_rigid_delta problem wl head1 head2 t1 t2)) + | (uu___7, FStarC_Syntax_Syntax.Tm_app uu___8) -> + let head1 = + let uu___9 = FStarC_Syntax_Util.head_and_args t1 in + FStar_Pervasives_Native.fst uu___9 in + let head2 = + let uu___9 = FStarC_Syntax_Util.head_and_args t2 in + FStar_Pervasives_Native.fst uu___9 in + ((let uu___10 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___10 + then + let uu___11 = + let uu___12 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + problem.FStarC_TypeChecker_Common.pid in + let uu___13 = + let uu___14 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + wl.smt_ok in + let uu___15 = + let uu___16 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head1 in + let uu___17 = + let uu___18 = + let uu___19 = + FStarC_TypeChecker_Env.is_interpreted + wl.tcenv head1 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___19 in + let uu___19 = + let uu___20 = + let uu___21 = no_free_uvars t1 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___21 in + let uu___21 = + let uu___22 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head2 in + let uu___23 = + let uu___24 = + let uu___25 = + FStarC_TypeChecker_Env.is_interpreted + wl.tcenv head2 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___25 in + let uu___25 = + let uu___26 = + let uu___27 = no_free_uvars t2 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + uu___27 in + [uu___26] in + uu___24 :: uu___25 in + uu___22 :: uu___23 in + uu___20 :: uu___21 in + uu___18 :: uu___19 in + uu___16 :: uu___17 in + uu___14 :: uu___15 in + uu___12 :: uu___13 in + FStarC_Compiler_Util.print + ">> (%s) (smtok=%s)\n>>> head1 = %s [interpreted=%s; no_free_uvars=%s]\n>>> head2 = %s [interpreted=%s; no_free_uvars=%s]\n" + uu___11 + else ()); + (let equal t11 t21 = + let env = p_env wl orig in + let r = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in + match r with + | FStarC_TypeChecker_TermEqAndSimplify.Equal -> true + | FStarC_TypeChecker_TermEqAndSimplify.NotEqual -> false + | FStarC_TypeChecker_TermEqAndSimplify.Unknown -> + let steps = + [FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.Iota] in + let t12 = + norm_with_steps + "FStarC.TypeChecker.Rel.norm_with_steps.2" steps + env t11 in + let t22 = + norm_with_steps + "FStarC.TypeChecker.Rel.norm_with_steps.3" steps + env t21 in + let uu___10 = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm env t12 + t22 in + uu___10 = FStarC_TypeChecker_TermEqAndSimplify.Equal in + let uu___10 = + ((FStarC_TypeChecker_Env.is_interpreted wl.tcenv head1) + || + (FStarC_TypeChecker_Env.is_interpreted wl.tcenv head2)) + && + (problem.FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.EQ) in + if uu___10 + then + let solve_with_smt uu___11 = + let uu___12 = + let uu___13 = equal t1 t2 in + if uu___13 + then (FStar_Pervasives_Native.None, wl) + else + (let uu___15 = mk_eq2 wl orig t1 t2 in + match uu___15 with + | (g, wl1) -> + ((FStar_Pervasives_Native.Some g), wl1)) in + match uu___12 with + | (guard, wl1) -> + let uu___13 = solve_prob orig guard [] wl1 in + solve uu___13 in + let uu___11 = (no_free_uvars t1) && (no_free_uvars t2) in + (if uu___11 + then + let uu___12 = + (Prims.op_Negation wl.smt_ok) || + (FStarC_Options.ml_ish ()) in + (if uu___12 + then + let uu___13 = equal t1 t2 in + (if uu___13 + then + let uu___14 = + solve_prob orig FStar_Pervasives_Native.None + [] wl in + solve uu___14 + else + rigid_rigid_delta problem wl head1 head2 t1 t2) + else solve_with_smt ()) + else + (let uu___13 = + (Prims.op_Negation wl.smt_ok) || + (FStarC_Options.ml_ish ()) in + if uu___13 + then rigid_rigid_delta problem wl head1 head2 t1 t2 + else + try_solve_then_or_else wl + (fun wl_empty -> + rigid_rigid_delta problem wl_empty head1 head2 + t1 t2) (fun wl1 -> solve wl1) + (fun uu___15 -> solve_with_smt ()))) + else rigid_rigid_delta problem wl head1 head2 t1 t2)) + | (FStarC_Syntax_Syntax.Tm_let uu___7, + FStarC_Syntax_Syntax.Tm_let uu___8) -> + let uu___9 = FStarC_Syntax_Util.term_eq t1 t2 in + if uu___9 + then + let uu___10 = + solve_prob orig FStar_Pervasives_Native.None [] wl in + solve uu___10 + else + (let uu___11 = FStarC_Thunk.mkv "Tm_let mismatch" in + giveup wl uu___11 orig) + | (FStarC_Syntax_Syntax.Tm_let uu___7, uu___8) -> + let uu___9 = + let uu___10 = + FStarC_Class_Tagged.tag_of + FStarC_Syntax_Syntax.tagged_term t1 in + let uu___11 = + FStarC_Class_Tagged.tag_of + FStarC_Syntax_Syntax.tagged_term t2 in + let uu___12 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + t1 in + let uu___13 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + t2 in + FStarC_Compiler_Util.format4 + "Internal error: unexpected flex-flex of %s and %s\n>>> (%s) -- (%s)" + uu___10 uu___11 uu___12 uu___13 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) t1 + FStarC_Errors_Codes.Fatal_UnificationNotWellFormed () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___9) + | (uu___7, FStarC_Syntax_Syntax.Tm_let uu___8) -> + let uu___9 = + let uu___10 = + FStarC_Class_Tagged.tag_of + FStarC_Syntax_Syntax.tagged_term t1 in + let uu___11 = + FStarC_Class_Tagged.tag_of + FStarC_Syntax_Syntax.tagged_term t2 in + let uu___12 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + t1 in + let uu___13 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + t2 in + FStarC_Compiler_Util.format4 + "Internal error: unexpected flex-flex of %s and %s\n>>> (%s) -- (%s)" + uu___10 uu___11 uu___12 uu___13 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) t1 + FStarC_Errors_Codes.Fatal_UnificationNotWellFormed () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___9) + | (FStarC_Syntax_Syntax.Tm_lazy li1, FStarC_Syntax_Syntax.Tm_lazy + li2) when + (FStarC_Class_Deq.op_Equals_Question + FStarC_Syntax_Syntax.deq_lazy_kind + li1.FStarC_Syntax_Syntax.lkind + li2.FStarC_Syntax_Syntax.lkind) + && (lazy_complete_repr li1.FStarC_Syntax_Syntax.lkind) + -> + let uu___7 = + let uu___8 = FStarC_Syntax_Util.unfold_lazy li1 in + let uu___9 = FStarC_Syntax_Util.unfold_lazy li2 in + { + FStarC_TypeChecker_Common.pid = + (problem.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = uu___8; + FStarC_TypeChecker_Common.relation = + (problem.FStarC_TypeChecker_Common.relation); + FStarC_TypeChecker_Common.rhs = uu___9; + FStarC_TypeChecker_Common.element = + (problem.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (problem.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar = + (problem.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (problem.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = + (problem.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (problem.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = + (problem.FStarC_TypeChecker_Common.logical) + } in + solve_t' uu___7 wl + | uu___7 -> + let uu___8 = + FStarC_Thunk.mk + (fun uu___9 -> + let uu___10 = + let uu___11 = + FStarC_Class_Tagged.tag_of + FStarC_Syntax_Syntax.tagged_term t1 in + let uu___12 = + let uu___13 = + FStarC_Class_Tagged.tag_of + FStarC_Syntax_Syntax.tagged_term t2 in + Prims.strcat " vs " uu___13 in + Prims.strcat uu___11 uu___12 in + Prims.strcat "head tag mismatch: " uu___10) in + giveup wl uu___8 orig)))) +and (solve_c : + FStarC_Syntax_Syntax.comp FStarC_TypeChecker_Common.problem -> + worklist -> solution) + = + fun problem -> + fun wl -> + let c1 = problem.FStarC_TypeChecker_Common.lhs in + let c2 = problem.FStarC_TypeChecker_Common.rhs in + let orig = FStarC_TypeChecker_Common.CProb problem in + let env = p_env wl orig in + let sub_prob wl1 t1 rel t2 reason = + mk_t_problem wl1 [] orig t1 rel t2 FStar_Pervasives_Native.None + reason in + let solve_eq c1_comp c2_comp g_lift = + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_EQ in + if uu___1 + then + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.mk_Comp c1_comp in + FStarC_Class_Show.show FStarC_Syntax_Print.showable_comp uu___3 in + let uu___3 = + let uu___4 = FStarC_Syntax_Syntax.mk_Comp c2_comp in + FStarC_Class_Show.show FStarC_Syntax_Print.showable_comp uu___4 in + FStarC_Compiler_Util.print2 + "solve_c is using an equality constraint (%s vs %s)\n" uu___2 + uu___3 + else ()); + (let uu___1 = + let uu___2 = + FStarC_Ident.lid_equals c1_comp.FStarC_Syntax_Syntax.effect_name + c2_comp.FStarC_Syntax_Syntax.effect_name in + Prims.op_Negation uu___2 in + if uu___1 + then + let uu___2 = + mklstr + (fun uu___3 -> + let uu___4 = + FStarC_Class_Show.show FStarC_Ident.showable_lident + c1_comp.FStarC_Syntax_Syntax.effect_name in + let uu___5 = + FStarC_Class_Show.show FStarC_Ident.showable_lident + c2_comp.FStarC_Syntax_Syntax.effect_name in + FStarC_Compiler_Util.format2 + "incompatible effects: %s <> %s" uu___4 uu___5) in + giveup wl uu___2 orig + else + if + (FStarC_Compiler_List.length + c1_comp.FStarC_Syntax_Syntax.effect_args) + <> + (FStarC_Compiler_List.length + c2_comp.FStarC_Syntax_Syntax.effect_args) + then + (let uu___3 = + mklstr + (fun uu___4 -> + let uu___5 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + (FStarC_Class_Show.show_tuple2 + FStarC_Syntax_Print.showable_term + FStarC_Syntax_Print.showable_aqual)) + c1_comp.FStarC_Syntax_Syntax.effect_args in + let uu___6 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + (FStarC_Class_Show.show_tuple2 + FStarC_Syntax_Print.showable_term + FStarC_Syntax_Print.showable_aqual)) + c2_comp.FStarC_Syntax_Syntax.effect_args in + FStarC_Compiler_Util.format2 + "incompatible effect arguments: %s <> %s" uu___5 + uu___6) in + giveup wl uu___3 orig) + else + (let uu___4 = + FStarC_Compiler_List.fold_left2 + (fun uu___5 -> + fun u1 -> + fun u2 -> + match uu___5 with + | (univ_sub_probs, wl1) -> + let uu___6 = + let uu___7 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_type u1) + FStarC_Compiler_Range_Type.dummyRange in + let uu___8 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_type u2) + FStarC_Compiler_Range_Type.dummyRange in + sub_prob wl1 uu___7 + FStarC_TypeChecker_Common.EQ uu___8 + "effect universes" in + (match uu___6 with + | (p, wl2) -> + let uu___7 = + let uu___8 = + Obj.magic + (FStarC_Class_Listlike.cons () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist + ())) p + (FStarC_Class_Listlike.empty () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist + ())))) in + FStarC_Class_Monoid.op_Plus_Plus + (FStarC_Compiler_CList.monoid_clist ()) + univ_sub_probs uu___8 in + (uu___7, wl2))) + ((Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic (FStarC_Compiler_CList.listlike_clist ())))), + wl) c1_comp.FStarC_Syntax_Syntax.comp_univs + c2_comp.FStarC_Syntax_Syntax.comp_univs in + match uu___4 with + | (univ_sub_probs, wl1) -> + let uu___5 = + sub_prob wl1 c1_comp.FStarC_Syntax_Syntax.result_typ + FStarC_TypeChecker_Common.EQ + c2_comp.FStarC_Syntax_Syntax.result_typ + "effect ret type" in + (match uu___5 with + | (ret_sub_prob, wl2) -> + let uu___6 = + FStarC_Compiler_List.fold_right2 + (fun uu___7 -> + fun uu___8 -> + fun uu___9 -> + match (uu___7, uu___8, uu___9) with + | ((a1, uu___10), (a2, uu___11), + (arg_sub_probs, wl3)) -> + let uu___12 = + sub_prob wl3 a1 + FStarC_TypeChecker_Common.EQ a2 + "effect arg" in + (match uu___12 with + | (p, wl4) -> + let uu___13 = + Obj.magic + (FStarC_Class_Listlike.cons () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist + ())) p + (Obj.magic arg_sub_probs)) in + (uu___13, wl4))) + c1_comp.FStarC_Syntax_Syntax.effect_args + c2_comp.FStarC_Syntax_Syntax.effect_args + ((Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist ())))), + wl2) in + (match uu___6 with + | (arg_sub_probs, wl3) -> + let sub_probs = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Compiler_CList.map + (fun uu___10 -> + match uu___10 with + | (uu___11, uu___12, p) -> p) + g_lift.FStarC_TypeChecker_Common.deferred in + FStarC_Class_Monoid.op_Plus_Plus + (FStarC_Compiler_CList.monoid_clist ()) + arg_sub_probs uu___9 in + Obj.magic + (FStarC_Class_Listlike.cons () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist + ())) ret_sub_prob + (Obj.magic uu___8)) in + FStarC_Class_Monoid.op_Plus_Plus + (FStarC_Compiler_CList.monoid_clist ()) + univ_sub_probs uu___7 in + let sub_probs1 = + FStarC_Class_Listlike.to_list + (FStarC_Compiler_CList.listlike_clist ()) + sub_probs in + let guard = + let guard1 = + let uu___7 = + FStarC_Compiler_List.map p_guard sub_probs1 in + FStarC_Syntax_Util.mk_conj_l uu___7 in + match g_lift.FStarC_TypeChecker_Common.guard_f + with + | FStarC_TypeChecker_Common.Trivial -> guard1 + | FStarC_TypeChecker_Common.NonTrivial f -> + FStarC_Syntax_Util.mk_conj guard1 f in + let wl4 = + let uu___7 = + FStarC_Class_Monoid.op_Plus_Plus + (FStarC_Compiler_CList.monoid_clist ()) + g_lift.FStarC_TypeChecker_Common.implicits + wl3.wl_implicits in + { + attempting = (wl3.attempting); + wl_deferred = (wl3.wl_deferred); + wl_deferred_to_tac = (wl3.wl_deferred_to_tac); + ctr = (wl3.ctr); + defer_ok = (wl3.defer_ok); + smt_ok = (wl3.smt_ok); + umax_heuristic_ok = (wl3.umax_heuristic_ok); + tcenv = (wl3.tcenv); + wl_implicits = uu___7; + repr_subcomp_allowed = + (wl3.repr_subcomp_allowed); + typeclass_variables = + (wl3.typeclass_variables) + } in + let wl5 = + solve_prob orig + (FStar_Pervasives_Native.Some guard) [] wl4 in + let uu___7 = attempt sub_probs1 wl5 in + solve uu___7)))) in + let should_fail_since_repr_subcomp_not_allowed repr_subcomp_allowed c11 + c21 = + let uu___ = + let uu___1 = FStarC_TypeChecker_Env.norm_eff_name wl.tcenv c11 in + let uu___2 = FStarC_TypeChecker_Env.norm_eff_name wl.tcenv c21 in + (uu___1, uu___2) in + match uu___ with + | (c12, c22) -> + ((Prims.op_Negation wl.repr_subcomp_allowed) && + (let uu___1 = FStarC_Ident.lid_equals c12 c22 in + Prims.op_Negation uu___1)) + && (FStarC_TypeChecker_Env.is_reifiable_effect wl.tcenv c22) in + let solve_layered_sub c11 c21 = + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_LayeredEffectsApp in + if uu___1 + then + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.mk_Comp c11 in + FStarC_Class_Show.show FStarC_Syntax_Print.showable_comp uu___3 in + let uu___3 = + let uu___4 = FStarC_Syntax_Syntax.mk_Comp c21 in + FStarC_Class_Show.show FStarC_Syntax_Print.showable_comp uu___4 in + FStarC_Compiler_Util.print2 + "solve_layered_sub c1: %s and c2: %s {\n" uu___2 uu___3 + else ()); + if + problem.FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.EQ + then solve_eq c11 c21 FStarC_TypeChecker_Env.trivial_guard + else + (let r = FStarC_TypeChecker_Env.get_range wl.tcenv in + let uu___2 = + should_fail_since_repr_subcomp_not_allowed + wl.repr_subcomp_allowed c11.FStarC_Syntax_Syntax.effect_name + c21.FStarC_Syntax_Syntax.effect_name in + if uu___2 + then + let uu___3 = + mklstr + (fun uu___4 -> + let uu___5 = + FStarC_Ident.string_of_lid + c11.FStarC_Syntax_Syntax.effect_name in + let uu___6 = + FStarC_Ident.string_of_lid + c21.FStarC_Syntax_Syntax.effect_name in + FStarC_Compiler_Util.format2 + "Cannot lift from %s to %s, it needs a lift\n" uu___5 + uu___6) in + giveup wl uu___3 orig + else + (let subcomp_name = + let uu___4 = + let uu___5 = + FStarC_Ident.ident_of_lid + c11.FStarC_Syntax_Syntax.effect_name in + FStarC_Ident.string_of_id uu___5 in + let uu___5 = + let uu___6 = + FStarC_Ident.ident_of_lid + c21.FStarC_Syntax_Syntax.effect_name in + FStarC_Ident.string_of_id uu___6 in + FStarC_Compiler_Util.format2 "%s <: %s" uu___4 uu___5 in + let lift_c1 edge = + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.mk_Comp c11 in + (edge.FStarC_TypeChecker_Env.mlift).FStarC_TypeChecker_Env.mlift_wp + env uu___5 in + match uu___4 with + | (c, g) -> + let uu___5 = + FStarC_TypeChecker_Env.comp_to_comp_typ env c in + (uu___5, g) in + let uu___4 = + let uu___5 = + FStarC_TypeChecker_Env.exists_polymonadic_subcomp env + c11.FStarC_Syntax_Syntax.effect_name + c21.FStarC_Syntax_Syntax.effect_name in + match uu___5 with + | FStar_Pervasives_Native.None -> + let uu___6 = + FStarC_TypeChecker_Env.monad_leq env + c11.FStarC_Syntax_Syntax.effect_name + c21.FStarC_Syntax_Syntax.effect_name in + (match uu___6 with + | FStar_Pervasives_Native.None -> + (c11, FStarC_TypeChecker_Env.trivial_guard, + FStar_Pervasives_Native.None, + FStarC_Syntax_Syntax.Ad_hoc_combinator, + Prims.int_zero, false) + | FStar_Pervasives_Native.Some edge -> + let uu___7 = lift_c1 edge in + (match uu___7 with + | (c12, g_lift) -> + let ed2 = + FStarC_TypeChecker_Env.get_effect_decl env + c21.FStarC_Syntax_Syntax.effect_name in + let uu___8 = + let uu___9 = + FStarC_Syntax_Util.get_stronger_vc_combinator + ed2 in + match uu___9 with + | (ts, kopt) -> + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_TypeChecker_Env.inst_tscheme_with + ts + c21.FStarC_Syntax_Syntax.comp_univs in + FStar_Pervasives_Native.snd uu___12 in + FStar_Pervasives_Native.Some uu___11 in + let uu___11 = + FStarC_Compiler_Util.must kopt in + (uu___10, uu___11) in + (match uu___8 with + | (tsopt, k) -> + let num_eff_params = + match ed2.FStarC_Syntax_Syntax.signature + with + | FStarC_Syntax_Syntax.Layered_eff_sig + (n, uu___9) -> n + | uu___9 -> + failwith + "Impossible (expected indexed effect subcomp)" in + (c12, g_lift, tsopt, k, num_eff_params, + false)))) + | FStar_Pervasives_Native.Some (t, kind) -> + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_TypeChecker_Env.inst_tscheme_with t + c21.FStarC_Syntax_Syntax.comp_univs in + FStar_Pervasives_Native.snd uu___8 in + FStar_Pervasives_Native.Some uu___7 in + (c11, FStarC_TypeChecker_Env.trivial_guard, uu___6, kind, + Prims.int_zero, true) in + match uu___4 with + | (c12, g_lift, stronger_t_opt, kind, num_eff_params, + is_polymonadic) -> + if FStarC_Compiler_Util.is_none stronger_t_opt + then + let uu___5 = + mklstr + (fun uu___6 -> + let uu___7 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + c12.FStarC_Syntax_Syntax.effect_name in + let uu___8 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + c21.FStarC_Syntax_Syntax.effect_name in + FStarC_Compiler_Util.format2 + "incompatible monad ordering: %s %s since its type %s is informative" + uu___9 uu___10 uu___11 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Error_TypeError () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___8) + else ()); + (let uu___7 = + if is_polymonadic + then ([], wl1) + else + (let rec is_uvar t = + let uu___9 = + let uu___10 = FStarC_Syntax_Subst.compress t in + uu___10.FStarC_Syntax_Syntax.n in + match uu___9 with + | FStarC_Syntax_Syntax.Tm_uvar (uv, uu___10) -> + let uu___11 = + FStarC_TypeChecker_DeferredImplicits.should_defer_uvar_to_user_tac + env uv in + Prims.op_Negation uu___11 + | FStarC_Syntax_Syntax.Tm_uinst (t1, uu___10) -> + is_uvar t1 + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = t1; + FStarC_Syntax_Syntax.args = uu___10;_} + -> is_uvar t1 + | uu___10 -> false in + FStarC_Compiler_List.fold_right2 + (fun uu___9 -> + fun uu___10 -> + fun uu___11 -> + match (uu___9, uu___10, uu___11) with + | ((a1, uu___12), (a2, uu___13), + (is_sub_probs, wl2)) -> + let uu___14 = is_uvar a1 in + if uu___14 + then + ((let uu___16 = + FStarC_Compiler_Effect.op_Bang + dbg_LayeredEffectsEqns in + if uu___16 + then + let uu___17 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + a1 in + let uu___18 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + a2 in + FStarC_Compiler_Util.print2 + "Layered Effects teq (rel c1 index uvar) %s = %s\n" + uu___17 uu___18 + else ()); + (let uu___16 = + sub_prob wl2 a1 + FStarC_TypeChecker_Common.EQ + a2 "l.h.s. effect index uvar" in + match uu___16 with + | (p, wl3) -> + ((p :: is_sub_probs), wl3))) + else (is_sub_probs, wl2)) + c12.FStarC_Syntax_Syntax.effect_args + c21.FStarC_Syntax_Syntax.effect_args ([], wl1)) in + match uu___7 with + | (is_sub_probs, wl2) -> + let uu___8 = + sub_prob wl2 c12.FStarC_Syntax_Syntax.result_typ + problem.FStarC_TypeChecker_Common.relation + c21.FStarC_Syntax_Syntax.result_typ + "result type" in + (match uu___8 with + | (ret_sub_prob, wl3) -> + let uu___9 = + FStarC_Syntax_Util.arrow_formals_comp + stronger_t in + (match uu___9 with + | (bs, subcomp_c) -> + let uu___10 = + if + kind = + FStarC_Syntax_Syntax.Ad_hoc_combinator + then + apply_ad_hoc_indexed_subcomp env bs + subcomp_c c12 c21 sub_prob wl3 + subcomp_name r + else + apply_substitutive_indexed_subcomp + env kind bs subcomp_c c12 c21 + sub_prob num_eff_params wl3 + subcomp_name r in + (match uu___10 with + | (fml, sub_probs, wl4) -> + let sub_probs1 = ret_sub_prob :: + (FStarC_Compiler_List.op_At + is_sub_probs sub_probs) in + let guard = + let guard1 = + let uu___11 = + FStarC_Compiler_List.map + p_guard sub_probs1 in + FStarC_Syntax_Util.mk_conj_l + uu___11 in + let guard2 = + match g_lift.FStarC_TypeChecker_Common.guard_f + with + | FStarC_TypeChecker_Common.Trivial + -> guard1 + | FStarC_TypeChecker_Common.NonTrivial + f -> + FStarC_Syntax_Util.mk_conj + guard1 f in + FStarC_Syntax_Util.mk_conj guard2 + fml in + let wl5 = + solve_prob orig + (FStar_Pervasives_Native.Some + guard) [] wl4 in + ((let uu___12 = + FStarC_Compiler_Effect.op_Bang + dbg_LayeredEffectsApp in + if uu___12 + then + FStarC_Compiler_Util.print_string + "}\n" + else ()); + (let uu___12 = + attempt sub_probs1 wl5 in + solve uu___12))))))))) in + let solve_sub c11 edge c21 = + if + problem.FStarC_TypeChecker_Common.relation <> + FStarC_TypeChecker_Common.SUB + then failwith "impossible: solve_sub" + else (); + (let r = FStarC_TypeChecker_Env.get_range env in + let lift_c1 uu___1 = + let univs = + match c11.FStarC_Syntax_Syntax.comp_univs with + | [] -> + let uu___2 = + env.FStarC_TypeChecker_Env.universe_of env + c11.FStarC_Syntax_Syntax.result_typ in + [uu___2] + | x -> x in + let c12 = + { + FStarC_Syntax_Syntax.comp_univs = univs; + FStarC_Syntax_Syntax.effect_name = + (c11.FStarC_Syntax_Syntax.effect_name); + FStarC_Syntax_Syntax.result_typ = + (c11.FStarC_Syntax_Syntax.result_typ); + FStarC_Syntax_Syntax.effect_args = + (c11.FStarC_Syntax_Syntax.effect_args); + FStarC_Syntax_Syntax.flags = (c11.FStarC_Syntax_Syntax.flags) + } in + let uu___2 = + let uu___3 = + FStarC_Syntax_Syntax.mk_Comp + { + FStarC_Syntax_Syntax.comp_univs = univs; + FStarC_Syntax_Syntax.effect_name = + (c12.FStarC_Syntax_Syntax.effect_name); + FStarC_Syntax_Syntax.result_typ = + (c12.FStarC_Syntax_Syntax.result_typ); + FStarC_Syntax_Syntax.effect_args = + (c12.FStarC_Syntax_Syntax.effect_args); + FStarC_Syntax_Syntax.flags = + (c12.FStarC_Syntax_Syntax.flags) + } in + (edge.FStarC_TypeChecker_Env.mlift).FStarC_TypeChecker_Env.mlift_wp + env uu___3 in + match uu___2 with + | (c, g) -> + let uu___3 = + let uu___4 = FStarC_TypeChecker_Env.is_trivial g in + Prims.op_Negation uu___4 in + if uu___3 + then + let uu___4 = + let uu___5 = + FStarC_Class_Show.show FStarC_Ident.showable_lident + c12.FStarC_Syntax_Syntax.effect_name in + let uu___6 = + FStarC_Class_Show.show FStarC_Ident.showable_lident + c21.FStarC_Syntax_Syntax.effect_name in + FStarC_Compiler_Util.format2 + "Lift between wp-effects (%s~>%s) should not have returned a non-trivial guard" + uu___5 uu___6 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_UnexpectedEffect () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4) + else FStarC_TypeChecker_Env.comp_to_comp_typ env c in + let uu___1 = + should_fail_since_repr_subcomp_not_allowed wl.repr_subcomp_allowed + c11.FStarC_Syntax_Syntax.effect_name + c21.FStarC_Syntax_Syntax.effect_name in + if uu___1 + then + let uu___2 = + mklstr + (fun uu___3 -> + let uu___4 = + FStarC_Ident.string_of_lid + c11.FStarC_Syntax_Syntax.effect_name in + let uu___5 = + FStarC_Ident.string_of_lid + c21.FStarC_Syntax_Syntax.effect_name in + FStarC_Compiler_Util.format2 + "Cannot lift from %s to %s, it needs a lift\n" uu___4 + uu___5) in + giveup wl uu___2 orig + else + (let is_null_wp_2 = + FStarC_Compiler_Util.for_some + (fun uu___3 -> + match uu___3 with + | FStarC_Syntax_Syntax.TOTAL -> true + | FStarC_Syntax_Syntax.MLEFFECT -> true + | FStarC_Syntax_Syntax.SOMETRIVIAL -> true + | uu___4 -> false) c21.FStarC_Syntax_Syntax.flags in + let uu___3 = + match ((c11.FStarC_Syntax_Syntax.effect_args), + (c21.FStarC_Syntax_Syntax.effect_args)) + with + | ((wp1, uu___4)::uu___5, (wp2, uu___6)::uu___7) -> (wp1, wp2) + | uu___4 -> + let uu___5 = + let uu___6 = + FStarC_Class_Show.show FStarC_Ident.showable_lident + c11.FStarC_Syntax_Syntax.effect_name in + let uu___7 = + FStarC_Class_Show.show FStarC_Ident.showable_lident + c21.FStarC_Syntax_Syntax.effect_name in + FStarC_Compiler_Util.format2 + "Got effects %s and %s, expected normalized effects" + uu___6 uu___7 in + FStarC_Errors.raise_error + FStarC_TypeChecker_Env.hasRange_env env + FStarC_Errors_Codes.Fatal_ExpectNormalizedEffect () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___5) in + match uu___3 with + | (wpc1, wpc2) -> + let uu___4 = FStarC_Compiler_Util.physical_equality wpc1 wpc2 in + if uu___4 + then + let uu___5 = + problem_using_guard orig + c11.FStarC_Syntax_Syntax.result_typ + problem.FStarC_TypeChecker_Common.relation + c21.FStarC_Syntax_Syntax.result_typ + FStar_Pervasives_Native.None "result type" in + solve_t uu___5 wl + else + (let uu___6 = + let uu___7 = + FStarC_TypeChecker_Env.effect_decl_opt env + c21.FStarC_Syntax_Syntax.effect_name in + FStarC_Compiler_Util.must uu___7 in + match uu___6 with + | (c2_decl, qualifiers) -> + if + FStarC_Compiler_List.contains + FStarC_Syntax_Syntax.Reifiable qualifiers + then + let c1_repr = + let uu___7 = + let uu___8 = + let uu___9 = lift_c1 () in + FStarC_Syntax_Syntax.mk_Comp uu___9 in + let uu___9 = + env.FStarC_TypeChecker_Env.universe_of env + c11.FStarC_Syntax_Syntax.result_typ in + FStarC_TypeChecker_Env.reify_comp env uu___8 + uu___9 in + norm_with_steps + "FStarC.TypeChecker.Rel.norm_with_steps.4" + [FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.Weak; + FStarC_TypeChecker_Env.HNF] env uu___7 in + let c2_repr = + let uu___7 = + let uu___8 = FStarC_Syntax_Syntax.mk_Comp c21 in + let uu___9 = + env.FStarC_TypeChecker_Env.universe_of env + c21.FStarC_Syntax_Syntax.result_typ in + FStarC_TypeChecker_Env.reify_comp env uu___8 + uu___9 in + norm_with_steps + "FStarC.TypeChecker.Rel.norm_with_steps.5" + [FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.Weak; + FStarC_TypeChecker_Env.HNF] env uu___7 in + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term c1_repr in + let uu___10 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term c2_repr in + FStarC_Compiler_Util.format2 + "sub effect repr: %s <: %s" uu___9 uu___10 in + sub_prob wl c1_repr + problem.FStarC_TypeChecker_Common.relation + c2_repr uu___8 in + (match uu___7 with + | (prob, wl1) -> + let wl2 = + solve_prob orig + (FStar_Pervasives_Native.Some + (p_guard prob)) [] wl1 in + let uu___8 = attempt [prob] wl2 in solve uu___8) + else + (let g = + let uu___8 = FStarC_Options.lax () in + if uu___8 + then FStarC_Syntax_Util.t_true + else + (let wpc1_2 = + let uu___10 = lift_c1 () in + FStarC_Compiler_List.hd + uu___10.FStarC_Syntax_Syntax.effect_args in + if is_null_wp_2 + then + ((let uu___11 = + FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___11 + then + FStarC_Compiler_Util.print_string + "Using trivial wp ... \n" + else ()); + (let c1_univ = + env.FStarC_TypeChecker_Env.universe_of + env + c11.FStarC_Syntax_Syntax.result_typ in + let trivial = + let uu___11 = + FStarC_Syntax_Util.get_wp_trivial_combinator + c2_decl in + match uu___11 with + | FStar_Pervasives_Native.None -> + failwith + "Rel doesn't yet handle undefined trivial combinator in an effect" + | FStar_Pervasives_Native.Some t -> t in + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_TypeChecker_Env.inst_effect_fun_with + [c1_univ] env c2_decl trivial in + let uu___14 = + let uu___15 = + FStarC_Syntax_Syntax.as_arg + c11.FStarC_Syntax_Syntax.result_typ in + [uu___15; wpc1_2] in + { + FStarC_Syntax_Syntax.hd = uu___13; + FStarC_Syntax_Syntax.args = uu___14 + } in + FStarC_Syntax_Syntax.Tm_app uu___12 in + FStarC_Syntax_Syntax.mk uu___11 r)) + else + (let c2_univ = + env.FStarC_TypeChecker_Env.universe_of + env c21.FStarC_Syntax_Syntax.result_typ in + let stronger = + let uu___11 = + FStarC_Syntax_Util.get_stronger_vc_combinator + c2_decl in + FStar_Pervasives_Native.fst uu___11 in + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_TypeChecker_Env.inst_effect_fun_with + [c2_univ] env c2_decl stronger in + let uu___14 = + let uu___15 = + FStarC_Syntax_Syntax.as_arg + c21.FStarC_Syntax_Syntax.result_typ in + let uu___16 = + let uu___17 = + FStarC_Syntax_Syntax.as_arg wpc2 in + [uu___17; wpc1_2] in + uu___15 :: uu___16 in + { + FStarC_Syntax_Syntax.hd = uu___13; + FStarC_Syntax_Syntax.args = uu___14 + } in + FStarC_Syntax_Syntax.Tm_app uu___12 in + FStarC_Syntax_Syntax.mk uu___11 r)) in + (let uu___9 = + FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___9 + then + let uu___10 = + let uu___11 = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Iota; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.Simplify] env g in + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term uu___11 in + FStarC_Compiler_Util.print1 + "WP guard (simplifed) is (%s)\n" uu___10 + else ()); + (let uu___9 = + sub_prob wl c11.FStarC_Syntax_Syntax.result_typ + problem.FStarC_TypeChecker_Common.relation + c21.FStarC_Syntax_Syntax.result_typ + "result type" in + match uu___9 with + | (base_prob, wl1) -> + let wl2 = + let uu___10 = + let uu___11 = + FStarC_Syntax_Util.mk_conj + (p_guard base_prob) g in + FStar_Pervasives_Native.Some uu___11 in + solve_prob orig uu___10 [] wl1 in + let uu___10 = attempt [base_prob] wl2 in + solve uu___10))))) in + let uu___ = FStarC_Compiler_Util.physical_equality c1 c2 in + if uu___ + then + let uu___1 = solve_prob orig FStar_Pervasives_Native.None [] wl in + solve uu___1 + else + ((let uu___3 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___3 + then + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_comp c1 in + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_comp c2 in + FStarC_Compiler_Util.print3 "solve_c %s %s %s\n" uu___4 + (rel_to_string problem.FStarC_TypeChecker_Common.relation) + uu___5 + else ()); + (let uu___3 = + let uu___4 = + let uu___5 = + FStarC_TypeChecker_Env.norm_eff_name env + (FStarC_Syntax_Util.comp_effect_name c1) in + let uu___6 = + FStarC_TypeChecker_Env.norm_eff_name env + (FStarC_Syntax_Util.comp_effect_name c2) in + (uu___5, uu___6) in + match uu___4 with + | (eff1, eff2) -> + let uu___5 = FStarC_Ident.lid_equals eff1 eff2 in + if uu___5 + then (c1, c2) + else FStarC_TypeChecker_Normalize.ghost_to_pure2 env (c1, c2) in + match uu___3 with + | (c11, c21) -> + (match ((c11.FStarC_Syntax_Syntax.n), + (c21.FStarC_Syntax_Syntax.n)) + with + | (FStarC_Syntax_Syntax.GTotal t1, FStarC_Syntax_Syntax.Total + t2) when FStarC_TypeChecker_Env.non_informative env t2 -> + let uu___4 = + problem_using_guard orig t1 + problem.FStarC_TypeChecker_Common.relation t2 + FStar_Pervasives_Native.None "result type" in + solve_t uu___4 wl + | (FStarC_Syntax_Syntax.GTotal uu___4, + FStarC_Syntax_Syntax.Total uu___5) -> + let uu___6 = + FStarC_Thunk.mkv + "incompatible monad ordering: GTot + let uu___4 = + problem_using_guard orig t1 + problem.FStarC_TypeChecker_Common.relation t2 + FStar_Pervasives_Native.None "result type" in + solve_t uu___4 wl + | (FStarC_Syntax_Syntax.GTotal t1, FStarC_Syntax_Syntax.GTotal + t2) -> + let uu___4 = + problem_using_guard orig t1 + problem.FStarC_TypeChecker_Common.relation t2 + FStar_Pervasives_Native.None "result type" in + solve_t uu___4 wl + | (FStarC_Syntax_Syntax.Total t1, FStarC_Syntax_Syntax.GTotal + t2) when + problem.FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.SUB + -> + let uu___4 = + problem_using_guard orig t1 + problem.FStarC_TypeChecker_Common.relation t2 + FStar_Pervasives_Native.None "result type" in + solve_t uu___4 wl + | (FStarC_Syntax_Syntax.Total t1, FStarC_Syntax_Syntax.GTotal + t2) -> + let uu___4 = FStarC_Thunk.mkv "GTot =/= Tot" in + giveup wl uu___4 orig + | (FStarC_Syntax_Syntax.GTotal uu___4, + FStarC_Syntax_Syntax.Comp uu___5) -> + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_TypeChecker_Env.comp_to_comp_typ env c11 in + FStarC_Syntax_Syntax.mk_Comp uu___8 in + { + FStarC_TypeChecker_Common.pid = + (problem.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = uu___7; + FStarC_TypeChecker_Common.relation = + (problem.FStarC_TypeChecker_Common.relation); + FStarC_TypeChecker_Common.rhs = + (problem.FStarC_TypeChecker_Common.rhs); + FStarC_TypeChecker_Common.element = + (problem.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (problem.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar = + (problem.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (problem.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = + (problem.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (problem.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = + (problem.FStarC_TypeChecker_Common.logical) + } in + solve_c uu___6 wl + | (FStarC_Syntax_Syntax.Total uu___4, + FStarC_Syntax_Syntax.Comp uu___5) -> + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_TypeChecker_Env.comp_to_comp_typ env c11 in + FStarC_Syntax_Syntax.mk_Comp uu___8 in + { + FStarC_TypeChecker_Common.pid = + (problem.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = uu___7; + FStarC_TypeChecker_Common.relation = + (problem.FStarC_TypeChecker_Common.relation); + FStarC_TypeChecker_Common.rhs = + (problem.FStarC_TypeChecker_Common.rhs); + FStarC_TypeChecker_Common.element = + (problem.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (problem.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar = + (problem.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (problem.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = + (problem.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (problem.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = + (problem.FStarC_TypeChecker_Common.logical) + } in + solve_c uu___6 wl + | (FStarC_Syntax_Syntax.Comp uu___4, + FStarC_Syntax_Syntax.GTotal uu___5) -> + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_TypeChecker_Env.comp_to_comp_typ env c21 in + FStarC_Syntax_Syntax.mk_Comp uu___8 in + { + FStarC_TypeChecker_Common.pid = + (problem.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = + (problem.FStarC_TypeChecker_Common.lhs); + FStarC_TypeChecker_Common.relation = + (problem.FStarC_TypeChecker_Common.relation); + FStarC_TypeChecker_Common.rhs = uu___7; + FStarC_TypeChecker_Common.element = + (problem.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (problem.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar = + (problem.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (problem.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = + (problem.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (problem.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = + (problem.FStarC_TypeChecker_Common.logical) + } in + solve_c uu___6 wl + | (FStarC_Syntax_Syntax.Comp uu___4, + FStarC_Syntax_Syntax.Total uu___5) -> + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_TypeChecker_Env.comp_to_comp_typ env c21 in + FStarC_Syntax_Syntax.mk_Comp uu___8 in + { + FStarC_TypeChecker_Common.pid = + (problem.FStarC_TypeChecker_Common.pid); + FStarC_TypeChecker_Common.lhs = + (problem.FStarC_TypeChecker_Common.lhs); + FStarC_TypeChecker_Common.relation = + (problem.FStarC_TypeChecker_Common.relation); + FStarC_TypeChecker_Common.rhs = uu___7; + FStarC_TypeChecker_Common.element = + (problem.FStarC_TypeChecker_Common.element); + FStarC_TypeChecker_Common.logical_guard = + (problem.FStarC_TypeChecker_Common.logical_guard); + FStarC_TypeChecker_Common.logical_guard_uvar = + (problem.FStarC_TypeChecker_Common.logical_guard_uvar); + FStarC_TypeChecker_Common.reason = + (problem.FStarC_TypeChecker_Common.reason); + FStarC_TypeChecker_Common.loc = + (problem.FStarC_TypeChecker_Common.loc); + FStarC_TypeChecker_Common.rank = + (problem.FStarC_TypeChecker_Common.rank); + FStarC_TypeChecker_Common.logical = + (problem.FStarC_TypeChecker_Common.logical) + } in + solve_c uu___6 wl + | (FStarC_Syntax_Syntax.Comp uu___4, FStarC_Syntax_Syntax.Comp + uu___5) -> + let uu___6 = + (((FStarC_Syntax_Util.is_ml_comp c11) && + (FStarC_Syntax_Util.is_ml_comp c21)) + || + ((FStarC_Syntax_Util.is_total_comp c11) && + (FStarC_Syntax_Util.is_total_comp c21))) + || + (((FStarC_Syntax_Util.is_total_comp c11) && + (FStarC_Syntax_Util.is_ml_comp c21)) + && + (problem.FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.SUB)) in + if uu___6 + then + let uu___7 = + problem_using_guard orig + (FStarC_Syntax_Util.comp_result c11) + problem.FStarC_TypeChecker_Common.relation + (FStarC_Syntax_Util.comp_result c21) + FStar_Pervasives_Native.None "result type" in + solve_t uu___7 wl + else + (let c1_comp = + FStarC_TypeChecker_Env.comp_to_comp_typ env c11 in + let c2_comp = + FStarC_TypeChecker_Env.comp_to_comp_typ env c21 in + if + problem.FStarC_TypeChecker_Common.relation = + FStarC_TypeChecker_Common.EQ + then + let uu___8 = + let uu___9 = + FStarC_Ident.lid_equals + c1_comp.FStarC_Syntax_Syntax.effect_name + c2_comp.FStarC_Syntax_Syntax.effect_name in + if uu___9 + then (c1_comp, c2_comp) + else + (let uu___11 = + FStarC_TypeChecker_Env.unfold_effect_abbrev + env c11 in + let uu___12 = + FStarC_TypeChecker_Env.unfold_effect_abbrev + env c21 in + (uu___11, uu___12)) in + match uu___8 with + | (c1_comp1, c2_comp1) -> + solve_eq c1_comp1 c2_comp1 + FStarC_TypeChecker_Env.trivial_guard + else + (let c12 = + FStarC_TypeChecker_Env.unfold_effect_abbrev env + c11 in + let c22 = + FStarC_TypeChecker_Env.unfold_effect_abbrev env + c21 in + (let uu___10 = + FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___10 + then + let uu___11 = + FStarC_Ident.string_of_lid + c12.FStarC_Syntax_Syntax.effect_name in + let uu___12 = + FStarC_Ident.string_of_lid + c22.FStarC_Syntax_Syntax.effect_name in + FStarC_Compiler_Util.print2 + "solve_c for %s and %s\n" uu___11 uu___12 + else ()); + (let uu___10 = + FStarC_TypeChecker_Env.is_layered_effect env + c22.FStarC_Syntax_Syntax.effect_name in + if uu___10 + then solve_layered_sub c12 c22 + else + (let uu___12 = + FStarC_TypeChecker_Env.monad_leq env + c12.FStarC_Syntax_Syntax.effect_name + c22.FStarC_Syntax_Syntax.effect_name in + match uu___12 with + | FStar_Pervasives_Native.None -> + let uu___13 = + mklstr + (fun uu___14 -> + let uu___15 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + c12.FStarC_Syntax_Syntax.effect_name in + let uu___16 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + c22.FStarC_Syntax_Syntax.effect_name in + FStarC_Compiler_Util.format2 + "incompatible monad ordering: %s + solve_sub c12 edge c22))))))) +let (print_pending_implicits : + FStarC_TypeChecker_Common.guard_t -> Prims.string) = + fun g -> + let uu___ = + FStarC_Compiler_CList.map + (fun i -> + FStarC_Class_Show.show FStarC_Syntax_Print.showable_ctxu + i.FStarC_TypeChecker_Common.imp_uvar) + g.FStarC_TypeChecker_Common.implicits in + FStarC_Class_Show.show + (FStarC_Compiler_CList.showable_clist + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_string)) uu___ +let (ineqs_to_string : + (FStarC_Syntax_Syntax.universe FStarC_Compiler_CList.clist * + (FStarC_Syntax_Syntax.universe * FStarC_Syntax_Syntax.universe) + FStarC_Compiler_CList.clist) -> Prims.string) + = + fun ineqs -> + let uu___ = ineqs in + match uu___ with + | (vars, ineqs1) -> + let ineqs2 = + FStarC_Compiler_CList.map + (fun uu___1 -> + match uu___1 with + | (u1, u2) -> + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_univ + u1 in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_univ + u2 in + FStarC_Compiler_Util.format2 "%s < %s" uu___2 uu___3) + ineqs1 in + let uu___1 = + FStarC_Class_Show.show + (FStarC_Compiler_CList.showable_clist + FStarC_Syntax_Print.showable_univ) vars in + let uu___2 = + FStarC_Class_Show.show + (FStarC_Compiler_CList.showable_clist + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_string)) ineqs2 in + FStarC_Compiler_Util.format2 "Solving for %s; inequalities are %s" + uu___1 uu___2 +let (guard_to_string : + FStarC_TypeChecker_Env.env -> + FStarC_TypeChecker_Common.guard_t -> Prims.string) + = + fun env -> + fun g -> + let uu___ = + let uu___1 = + Obj.magic + (FStarC_Class_Listlike.view () + (Obj.magic (FStarC_Compiler_CList.listlike_clist ())) + (Obj.magic g.FStarC_TypeChecker_Common.deferred)) in + ((g.FStarC_TypeChecker_Common.guard_f), uu___1) in + match uu___ with + | (FStarC_TypeChecker_Common.Trivial, FStarC_Class_Listlike.VNil) when + (let uu___1 = FStarC_Options.print_implicits () in + Prims.op_Negation uu___1) && + (FStarC_Class_Listlike.is_empty + (FStarC_Compiler_CList.listlike_clist ()) + (FStar_Pervasives_Native.snd + g.FStarC_TypeChecker_Common.univ_ineqs)) + -> "{}" + | uu___1 -> + let form = + match g.FStarC_TypeChecker_Common.guard_f with + | FStarC_TypeChecker_Common.Trivial -> "trivial" + | FStarC_TypeChecker_Common.NonTrivial f -> + let uu___2 = + ((FStarC_Compiler_Effect.op_Bang dbg_Rel) || + (FStarC_Compiler_Debug.extreme ())) + || (FStarC_Options.print_implicits ()) in + if uu___2 + then FStarC_TypeChecker_Normalize.term_to_string env f + else "non-trivial" in + let carry defs = + let uu___2 = + let uu___3 = + FStarC_Compiler_CList.map + (fun uu___4 -> + match uu___4 with + | (uu___5, msg, x) -> + let uu___6 = + let uu___7 = prob_to_string env x in + Prims.strcat ": " uu___7 in + Prims.strcat msg uu___6) defs in + FStarC_Class_Listlike.to_list + (FStarC_Compiler_CList.listlike_clist ()) uu___3 in + FStarC_Compiler_String.concat ",\n" uu___2 in + let imps = print_pending_implicits g in + let uu___2 = carry g.FStarC_TypeChecker_Common.deferred in + let uu___3 = carry g.FStarC_TypeChecker_Common.deferred_to_tac in + let uu___4 = ineqs_to_string g.FStarC_TypeChecker_Common.univ_ineqs in + FStarC_Compiler_Util.format5 + "\n\t{guard_f=%s;\n\t deferred={\n%s};\n\t deferred_to_tac={\n%s};\n\t univ_ineqs={%s};\n\t implicits=%s}\n" + form uu___2 uu___3 uu___4 imps +let (new_t_problem : + worklist -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_TypeChecker_Common.rel -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.bv FStar_Pervasives_Native.option -> + FStarC_Compiler_Range_Type.range -> + (FStarC_TypeChecker_Common.prob * worklist)) + = + fun wl -> + fun env -> + fun lhs -> + fun rel -> + fun rhs -> + fun elt -> + fun loc -> + let reason = + let uu___ = + (FStarC_Compiler_Effect.op_Bang dbg_ExplainRel) || + (FStarC_Compiler_Effect.op_Bang dbg_Rel) in + if uu___ + then + let uu___1 = + FStarC_TypeChecker_Normalize.term_to_string env lhs in + let uu___2 = + FStarC_TypeChecker_Normalize.term_to_string env rhs in + FStarC_Compiler_Util.format3 "Top-level:\n%s\n\t%s\n%s" + uu___1 (rel_to_string rel) uu___2 + else "TOP" in + let uu___ = new_problem wl env lhs rel rhs elt loc reason in + match uu___ with + | (p, wl1) -> + (def_check_prob (Prims.strcat "new_t_problem." reason) + (FStarC_TypeChecker_Common.TProb p); + ((FStarC_TypeChecker_Common.TProb p), wl1)) +let (new_t_prob : + worklist -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_TypeChecker_Common.rel -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + (FStarC_TypeChecker_Common.prob * FStarC_Syntax_Syntax.bv * + worklist)) + = + fun wl -> + fun env -> + fun t1 -> + fun rel -> + fun t2 -> + let x = + let uu___ = + let uu___1 = FStarC_TypeChecker_Env.get_range env in + FStar_Pervasives_Native.Some uu___1 in + FStarC_Syntax_Syntax.new_bv uu___ t1 in + let uu___ = + let uu___1 = FStarC_TypeChecker_Env.get_range env in + new_t_problem wl env t1 rel t2 (FStar_Pervasives_Native.Some x) + uu___1 in + match uu___ with | (p, wl1) -> (p, x, wl1) +let (solve_and_commit : + worklist -> + ((FStarC_TypeChecker_Common.prob * lstring) -> + (FStarC_TypeChecker_Common.deferred * + FStarC_TypeChecker_Common.deferred * + FStarC_TypeChecker_Common.implicits_t) + FStar_Pervasives_Native.option) + -> + (FStarC_TypeChecker_Common.deferred * + FStarC_TypeChecker_Common.deferred * + FStarC_TypeChecker_Common.implicits_t) FStar_Pervasives_Native.option) + = + fun wl -> + fun err -> + let tx = FStarC_Syntax_Unionfind.new_transaction () in + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_RelBench in + if uu___1 + then + let uu___2 = + (FStarC_Common.string_of_list ()) + (fun p -> FStarC_Compiler_Util.string_of_int (p_pid p)) + wl.attempting in + FStarC_Compiler_Util.print1 "solving problems %s {\n" uu___2 + else ()); + (let uu___1 = FStarC_Compiler_Util.record_time (fun uu___2 -> solve wl) in + match uu___1 with + | (sol, ms) -> + ((let uu___3 = FStarC_Compiler_Effect.op_Bang dbg_RelBench in + if uu___3 + then + let uu___4 = FStarC_Compiler_Util.string_of_int ms in + FStarC_Compiler_Util.print1 "} solved in %s ms\n" uu___4 + else ()); + (match sol with + | Success (deferred, defer_to_tac, implicits) -> + let uu___3 = + FStarC_Compiler_Util.record_time + (fun uu___4 -> FStarC_Syntax_Unionfind.commit tx) in + (match uu___3 with + | ((), ms1) -> + ((let uu___5 = + FStarC_Compiler_Effect.op_Bang dbg_RelBench in + if uu___5 + then + let uu___6 = FStarC_Compiler_Util.string_of_int ms1 in + FStarC_Compiler_Util.print1 "committed in %s ms\n" + uu___6 + else ()); + FStar_Pervasives_Native.Some + (deferred, defer_to_tac, implicits))) + | Failed (d, s) -> + ((let uu___4 = + (FStarC_Compiler_Effect.op_Bang dbg_ExplainRel) || + (FStarC_Compiler_Effect.op_Bang dbg_Rel) in + if uu___4 + then + let uu___5 = explain wl d s in + FStarC_Compiler_Util.print_string uu___5 + else ()); + (let result = err (d, s) in + FStarC_Syntax_Unionfind.rollback tx; result))))) +let (with_guard : + FStarC_TypeChecker_Env.env -> + FStarC_TypeChecker_Common.prob -> + (FStarC_TypeChecker_Common.deferred * + FStarC_TypeChecker_Common.deferred * + FStarC_TypeChecker_Common.implicits_t) FStar_Pervasives_Native.option + -> FStarC_TypeChecker_Common.guard_t FStar_Pervasives_Native.option) + = + fun env -> + fun prob -> + fun dopt -> + match dopt with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (deferred, defer_to_tac, implicits) -> + (FStarC_Defensive.def_check_scoped + FStarC_TypeChecker_Env.hasBinders_env + FStarC_Class_Binders.hasNames_term + FStarC_Syntax_Print.pretty_term (p_loc prob) "with_guard" env + (p_guard prob); + (let uu___1 = + simplify_guard env + { + FStarC_TypeChecker_Common.guard_f = + (FStarC_TypeChecker_Common.NonTrivial (p_guard prob)); + FStarC_TypeChecker_Common.deferred_to_tac = defer_to_tac; + FStarC_TypeChecker_Common.deferred = deferred; + FStarC_TypeChecker_Common.univ_ineqs = + ((Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist ())))), + (Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist ()))))); + FStarC_TypeChecker_Common.implicits = implicits + } in + FStar_Pervasives_Native.Some uu___1)) +let (try_teq : + Prims.bool -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.typ -> + FStarC_TypeChecker_Common.guard_t FStar_Pervasives_Native.option) + = + fun smt_ok -> + fun env -> + fun t1 -> + fun t2 -> + FStarC_Defensive.def_check_scoped + FStarC_TypeChecker_Env.hasBinders_env + FStarC_Class_Binders.hasNames_term + FStarC_Syntax_Print.pretty_term t1.FStarC_Syntax_Syntax.pos + "try_teq.1" env t1; + FStarC_Defensive.def_check_scoped + FStarC_TypeChecker_Env.hasBinders_env + FStarC_Class_Binders.hasNames_term + FStarC_Syntax_Print.pretty_term t2.FStarC_Syntax_Syntax.pos + "try_teq.2" env t2; + (let smt_ok1 = + smt_ok && + (let uu___2 = FStarC_Options.ml_ish () in + Prims.op_Negation uu___2) in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_TypeChecker_Env.current_module env in + FStarC_Ident.string_of_lid uu___4 in + FStar_Pervasives_Native.Some uu___3 in + FStarC_Profiling.profile + (fun uu___3 -> + (let uu___5 = FStarC_Compiler_Effect.op_Bang dbg_RelTop in + if uu___5 + then + let uu___6 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + t1 in + let uu___7 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + t2 in + let uu___8 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binding) + env.FStarC_TypeChecker_Env.gamma in + FStarC_Compiler_Util.print3 + "try_teq of %s and %s in %s {\n" uu___6 uu___7 uu___8 + else ()); + (let uu___5 = + let uu___6 = empty_worklist env in + let uu___7 = FStarC_TypeChecker_Env.get_range env in + new_t_problem uu___6 env t1 FStarC_TypeChecker_Common.EQ + t2 FStar_Pervasives_Native.None uu___7 in + match uu___5 with + | (prob, wl) -> + let g = + let uu___6 = + solve_and_commit (singleton wl prob smt_ok1) + (fun uu___7 -> FStar_Pervasives_Native.None) in + with_guard env prob uu___6 in + ((let uu___7 = FStarC_Compiler_Effect.op_Bang dbg_RelTop in + if uu___7 + then + let uu___8 = + FStarC_Common.string_of_option + (guard_to_string env) g in + FStarC_Compiler_Util.print1 "} res = %s\n" uu___8 + else ()); + g))) uu___2 "FStarC.TypeChecker.Rel.try_teq") +let (teq : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.typ -> FStarC_TypeChecker_Common.guard_t) + = + fun env -> + fun t1 -> + fun t2 -> + let uu___ = try_teq true env t1 t2 in + match uu___ with + | FStar_Pervasives_Native.None -> + (FStarC_TypeChecker_Err.basic_type_error env + env.FStarC_TypeChecker_Env.range FStar_Pervasives_Native.None + t2 t1; + FStarC_TypeChecker_Common.trivial_guard) + | FStar_Pervasives_Native.Some g -> + ((let uu___2 = + (FStarC_Compiler_Effect.op_Bang dbg_Rel) || + (FStarC_Compiler_Effect.op_Bang dbg_RelTop) in + if uu___2 + then + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t2 in + let uu___5 = guard_to_string env g in + FStarC_Compiler_Util.print3 + "teq of %s and %s succeeded with guard %s\n" uu___3 uu___4 + uu___5 + else ()); + g) +let (get_teq_predicate : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.typ -> + FStarC_TypeChecker_Common.guard_t FStar_Pervasives_Native.option) + = + fun env -> + fun t1 -> + fun t2 -> + (let uu___1 = + (FStarC_Compiler_Effect.op_Bang dbg_Rel) || + (FStarC_Compiler_Effect.op_Bang dbg_RelTop) in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t2 in + FStarC_Compiler_Util.print2 "get_teq_predicate of %s and %s {\n" + uu___2 uu___3 + else ()); + (let uu___1 = + let uu___2 = empty_worklist env in + new_t_prob uu___2 env t1 FStarC_TypeChecker_Common.EQ t2 in + match uu___1 with + | (prob, x, wl) -> + let g = + let uu___2 = + solve_and_commit (singleton wl prob true) + (fun uu___3 -> FStar_Pervasives_Native.None) in + with_guard env prob uu___2 in + ((let uu___3 = + (FStarC_Compiler_Effect.op_Bang dbg_Rel) || + (FStarC_Compiler_Effect.op_Bang dbg_RelTop) in + if uu___3 + then + let uu___4 = + FStarC_Common.string_of_option (guard_to_string env) g in + FStarC_Compiler_Util.print1 "} res teq predicate = %s\n" + uu___4 + else ()); + (match g with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some g1 -> + let uu___3 = + let uu___4 = FStarC_Syntax_Syntax.mk_binder x in + FStarC_TypeChecker_Env.abstract_guard uu___4 g1 in + FStar_Pervasives_Native.Some uu___3))) +let (subtype_fail : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.typ -> unit) + = + fun env -> + fun e -> + fun t1 -> + fun t2 -> + let uu___ = FStarC_TypeChecker_Env.get_range env in + FStarC_TypeChecker_Err.basic_type_error env uu___ + (FStar_Pervasives_Native.Some e) t2 t1 +let (sub_or_eq_comp : + FStarC_TypeChecker_Env.env -> + Prims.bool -> + FStarC_Syntax_Syntax.comp -> + FStarC_Syntax_Syntax.comp -> + FStarC_TypeChecker_Common.guard_t FStar_Pervasives_Native.option) + = + fun env -> + fun use_eq -> + fun c1 -> + fun c2 -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_Env.current_module env in + FStarC_Ident.string_of_lid uu___2 in + FStar_Pervasives_Native.Some uu___1 in + FStarC_Profiling.profile + (fun uu___1 -> + let rel = + if use_eq + then FStarC_TypeChecker_Common.EQ + else FStarC_TypeChecker_Common.SUB in + (let uu___3 = + (FStarC_Compiler_Effect.op_Bang dbg_Rel) || + (FStarC_Compiler_Effect.op_Bang dbg_RelTop) in + if uu___3 + then + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_comp + c1 in + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_comp + c2 in + FStarC_Compiler_Util.print3 + "sub_comp of %s --and-- %s --with-- %s\n" uu___4 uu___5 + (if rel = FStarC_TypeChecker_Common.EQ + then "EQ" + else "SUB") + else ()); + (let uu___3 = + let uu___4 = empty_worklist env in + let uu___5 = FStarC_TypeChecker_Env.get_range env in + new_problem uu___4 env c1 rel c2 + FStar_Pervasives_Native.None uu___5 "sub_comp" in + match uu___3 with + | (prob, wl) -> + let wl1 = + { + attempting = (wl.attempting); + wl_deferred = (wl.wl_deferred); + wl_deferred_to_tac = (wl.wl_deferred_to_tac); + ctr = (wl.ctr); + defer_ok = (wl.defer_ok); + smt_ok = (wl.smt_ok); + umax_heuristic_ok = (wl.umax_heuristic_ok); + tcenv = (wl.tcenv); + wl_implicits = (wl.wl_implicits); + repr_subcomp_allowed = true; + typeclass_variables = (wl.typeclass_variables) + } in + let prob1 = FStarC_TypeChecker_Common.CProb prob in + (def_check_prob "sub_comp" prob1; + (let uu___5 = + FStarC_Compiler_Util.record_time + (fun uu___6 -> + let uu___7 = + solve_and_commit (singleton wl1 prob1 true) + (fun uu___8 -> FStar_Pervasives_Native.None) in + with_guard env prob1 uu___7) in + match uu___5 with + | (r, ms) -> + ((let uu___7 = + ((FStarC_Compiler_Effect.op_Bang dbg_Rel) || + (FStarC_Compiler_Effect.op_Bang dbg_RelTop)) + || + (FStarC_Compiler_Effect.op_Bang dbg_RelBench) in + if uu___7 + then + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_comp c1 in + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_comp c2 in + let uu___10 = + FStarC_Compiler_Util.string_of_int ms in + FStarC_Compiler_Util.print4 + "sub_comp of %s --and-- %s --with-- %s --- solved in %s ms\n" + uu___8 uu___9 + (if rel = FStarC_TypeChecker_Common.EQ + then "EQ" + else "SUB") uu___10 + else ()); + r))))) uu___ "FStarC.TypeChecker.Rel.sub_comp" +let (sub_comp : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.comp -> + FStarC_Syntax_Syntax.comp -> + FStarC_TypeChecker_Common.guard_t FStar_Pervasives_Native.option) + = + fun env -> + fun c1 -> + fun c2 -> + FStarC_Errors.with_ctx "While trying to subtype computation types" + (fun uu___ -> + FStarC_Defensive.def_check_scoped + FStarC_TypeChecker_Env.hasBinders_env + FStarC_Class_Binders.hasNames_comp + FStarC_Syntax_Print.pretty_comp c1.FStarC_Syntax_Syntax.pos + "sub_comp c1" env c1; + FStarC_Defensive.def_check_scoped + FStarC_TypeChecker_Env.hasBinders_env + FStarC_Class_Binders.hasNames_comp + FStarC_Syntax_Print.pretty_comp c2.FStarC_Syntax_Syntax.pos + "sub_comp c2" env c2; + sub_or_eq_comp env false c1 c2) +let (eq_comp : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.comp -> + FStarC_Syntax_Syntax.comp -> + FStarC_TypeChecker_Common.guard_t FStar_Pervasives_Native.option) + = + fun env -> + fun c1 -> + fun c2 -> + FStarC_Errors.with_ctx "While trying to equate computation types" + (fun uu___ -> + FStarC_Defensive.def_check_scoped + FStarC_TypeChecker_Env.hasBinders_env + FStarC_Class_Binders.hasNames_comp + FStarC_Syntax_Print.pretty_comp c1.FStarC_Syntax_Syntax.pos + "eq_comp c1" env c1; + FStarC_Defensive.def_check_scoped + FStarC_TypeChecker_Env.hasBinders_env + FStarC_Class_Binders.hasNames_comp + FStarC_Syntax_Print.pretty_comp c2.FStarC_Syntax_Syntax.pos + "eq_comp c2" env c2; + sub_or_eq_comp env true c1 c2) +let (solve_universe_inequalities' : + FStarC_Syntax_Unionfind.tx -> + FStarC_TypeChecker_Env.env_t -> + (FStarC_Syntax_Syntax.universe FStarC_Compiler_CList.clist * + (FStarC_Syntax_Syntax.universe * FStarC_Syntax_Syntax.universe) + FStarC_Compiler_CList.clist) -> unit) + = + fun tx -> + fun env -> + fun uu___ -> + match uu___ with + | (variables, ineqs) -> + let fail u1 u2 = + FStarC_Syntax_Unionfind.rollback tx; + (let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_univ + u1 in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_univ + u2 in + FStarC_Compiler_Util.format2 + "Universe %s and %s are incompatible" uu___3 uu___4 in + FStarC_Errors.raise_error FStarC_TypeChecker_Env.hasRange_env + env FStarC_Errors_Codes.Fatal_IncompatibleUniverse () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)) in + let equiv v v' = + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress_univ v in + let uu___3 = FStarC_Syntax_Subst.compress_univ v' in + (uu___2, uu___3) in + match uu___1 with + | (FStarC_Syntax_Syntax.U_unif v0, FStarC_Syntax_Syntax.U_unif + v0') -> FStarC_Syntax_Unionfind.univ_equiv v0 v0' + | uu___2 -> false in + let sols = + FStarC_Compiler_CList.collect + (fun uu___1 -> + (fun v -> + let uu___1 = FStarC_Syntax_Subst.compress_univ v in + match uu___1 with + | FStarC_Syntax_Syntax.U_unif uu___2 -> + Obj.magic + (Obj.repr + (let lower_bounds_of_v = + FStarC_Compiler_CList.collect + (fun uu___3 -> + (fun uu___3 -> + match uu___3 with + | (u, v') -> + let uu___4 = equiv v v' in + if uu___4 + then + let uu___5 = + FStarC_Compiler_CList.existsb + (equiv u) variables in + (if uu___5 + then + Obj.magic + (FStarC_Class_Listlike.empty + () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist + ()))) + else + Obj.magic + (FStarC_Class_Listlike.cons + () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist + ())) u + (FStarC_Class_Listlike.empty + () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist + ()))))) + else + Obj.magic + (FStarC_Class_Listlike.empty + () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist + ())))) uu___3) + ineqs in + let lb = + let uu___3 = + let uu___4 = + FStarC_Class_Listlike.to_list + (FStarC_Compiler_CList.listlike_clist + ()) lower_bounds_of_v in + FStarC_Syntax_Syntax.U_max uu___4 in + FStarC_TypeChecker_Normalize.normalize_universe + env uu___3 in + FStarC_Class_Listlike.singleton + (FStarC_Compiler_CList.listlike_clist ()) + (lb, v))) + | uu___2 -> + Obj.magic + (Obj.repr + (FStarC_Class_Listlike.empty () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist ()))))) + uu___1) variables in + let uu___1 = + let wl = + let uu___2 = empty_worklist env in + { + attempting = (uu___2.attempting); + wl_deferred = (uu___2.wl_deferred); + wl_deferred_to_tac = (uu___2.wl_deferred_to_tac); + ctr = (uu___2.ctr); + defer_ok = NoDefer; + smt_ok = (uu___2.smt_ok); + umax_heuristic_ok = (uu___2.umax_heuristic_ok); + tcenv = (uu___2.tcenv); + wl_implicits = (uu___2.wl_implicits); + repr_subcomp_allowed = (uu___2.repr_subcomp_allowed); + typeclass_variables = (uu___2.typeclass_variables) + } in + FStarC_Compiler_CList.map + (fun uu___2 -> + match uu___2 with + | (lb, v) -> + let uu___3 = + solve_universe_eq (Prims.of_int (-1)) wl lb v in + (match uu___3 with + | USolved wl1 -> () + | uu___4 -> fail lb v)) sols in + let rec check_ineq uu___2 = + match uu___2 with + | (u, v) -> + let u1 = + FStarC_TypeChecker_Normalize.normalize_universe env u in + let v1 = + FStarC_TypeChecker_Normalize.normalize_universe env v in + (match (u1, v1) with + | (FStarC_Syntax_Syntax.U_zero, uu___3) -> true + | (FStarC_Syntax_Syntax.U_succ u0, + FStarC_Syntax_Syntax.U_succ v0) -> check_ineq (u0, v0) + | (FStarC_Syntax_Syntax.U_name u0, + FStarC_Syntax_Syntax.U_name v0) -> + FStarC_Ident.ident_equals u0 v0 + | (FStarC_Syntax_Syntax.U_unif u0, + FStarC_Syntax_Syntax.U_unif v0) -> + FStarC_Syntax_Unionfind.univ_equiv u0 v0 + | (FStarC_Syntax_Syntax.U_name uu___3, + FStarC_Syntax_Syntax.U_succ v0) -> check_ineq (u1, v0) + | (FStarC_Syntax_Syntax.U_unif uu___3, + FStarC_Syntax_Syntax.U_succ v0) -> check_ineq (u1, v0) + | (FStarC_Syntax_Syntax.U_max us, uu___3) -> + FStarC_Compiler_Util.for_all + (fun u2 -> check_ineq (u2, v1)) us + | (uu___3, FStarC_Syntax_Syntax.U_max vs) -> + FStarC_Compiler_Util.for_some + (fun v2 -> check_ineq (u1, v2)) vs + | uu___3 -> false) in + let uu___2 = + FStarC_Compiler_CList.for_all + (fun uu___3 -> + match uu___3 with + | (u, v) -> + let uu___4 = check_ineq (u, v) in + if uu___4 + then true + else + ((let uu___7 = + FStarC_Compiler_Effect.op_Bang dbg_GenUniverses in + if uu___7 + then + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_univ u in + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_univ v in + FStarC_Compiler_Util.print2 "%s + (FStarC_Syntax_Syntax.universe FStarC_Compiler_CList.clist * + (FStarC_Syntax_Syntax.universe * FStarC_Syntax_Syntax.universe) + FStarC_Compiler_CList.clist) -> unit) + = + fun env -> + fun ineqs -> + let tx = FStarC_Syntax_Unionfind.new_transaction () in + solve_universe_inequalities' tx env ineqs; + FStarC_Syntax_Unionfind.commit tx +let (try_solve_deferred_constraints : + defer_ok_t -> + Prims.bool -> + Prims.bool -> + FStarC_TypeChecker_Env.env -> + FStarC_TypeChecker_Common.guard_t -> + FStarC_TypeChecker_Common.guard_t) + = + fun defer_ok -> + fun smt_ok -> + fun deferred_to_tac_ok -> + fun env -> + fun g -> + let smt_ok1 = + smt_ok && + (let uu___ = FStarC_Options.ml_ish () in + Prims.op_Negation uu___) in + FStarC_Errors.with_ctx "While solving deferred constraints" + (fun uu___ -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_TypeChecker_Env.current_module env in + FStarC_Ident.string_of_lid uu___3 in + FStar_Pervasives_Native.Some uu___2 in + FStarC_Profiling.profile + (fun uu___2 -> + let imps_l = + FStarC_Class_Listlike.to_list + (FStarC_Compiler_CList.listlike_clist ()) + g.FStarC_TypeChecker_Common.implicits in + let typeclass_variables = + let uu___3 = + FStarC_Compiler_List.collect + (fun i -> + match (i.FStarC_TypeChecker_Common.imp_uvar).FStarC_Syntax_Syntax.ctx_uvar_meta + with + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Ctx_uvar_meta_tac + tac) -> + let uu___4 = + FStarC_Syntax_Util.head_and_args_full + tac in + (match uu___4 with + | (head, uu___5) -> + let uu___6 = + FStarC_Syntax_Util.is_fvar + FStarC_Parser_Const.tcresolve_lid + head in + if uu___6 + then + let goal_type = + FStarC_Syntax_Util.ctx_uvar_typ + i.FStarC_TypeChecker_Common.imp_uvar in + let uvs = + FStarC_Syntax_Free.uvars + goal_type in + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) + (Obj.magic uvs) + else []) + | uu___4 -> []) imps_l in + Obj.magic + (FStarC_Class_Setlike.from_list () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Free.ord_ctx_uvar)) uu___3) in + let wl = + let uu___3 = + let uu___4 = + FStarC_Class_Listlike.to_list + (FStarC_Compiler_CList.listlike_clist ()) + g.FStarC_TypeChecker_Common.deferred in + wl_of_guard env uu___4 in + { + attempting = (uu___3.attempting); + wl_deferred = (uu___3.wl_deferred); + wl_deferred_to_tac = (uu___3.wl_deferred_to_tac); + ctr = (uu___3.ctr); + defer_ok; + smt_ok = smt_ok1; + umax_heuristic_ok = (uu___3.umax_heuristic_ok); + tcenv = (uu___3.tcenv); + wl_implicits = (uu___3.wl_implicits); + repr_subcomp_allowed = + (uu___3.repr_subcomp_allowed); + typeclass_variables + } in + let fail uu___3 = + match uu___3 with + | (d, s) -> + let msg = explain wl d s in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range (p_loc d) + FStarC_Errors_Codes.Fatal_ErrorInSolveDeferredConstraints + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic msg) in + (let uu___4 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___4 + then + let uu___5 = FStarC_Class_Show.show uu___0 defer_ok in + let uu___6 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + deferred_to_tac_ok in + let uu___7 = FStarC_Class_Show.show showable_wl wl in + let uu___8 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_nat) + (FStarC_Compiler_List.length imps_l) in + FStarC_Compiler_Util.print4 + "Trying to solve carried problems (defer_ok=%s) (deferred_to_tac_ok=%s): begin\n\t%s\nend\n and %s implicits\n" + uu___5 uu___6 uu___7 uu___8 + else ()); + (let g1 = + let uu___4 = solve_and_commit wl fail in + match uu___4 with + | FStar_Pervasives_Native.Some + (deferred, uu___5, uu___6) when + (let uu___7 = + Obj.magic + (FStarC_Class_Listlike.view () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist + ())) (Obj.magic deferred)) in + FStarC_Class_Listlike.uu___is_VCons uu___7) && + (defer_ok = NoDefer) + -> + failwith + "Impossible: Unexpected deferred constraints remain" + | FStar_Pervasives_Native.Some + (deferred, defer_to_tac, imps) -> + let uu___5 = + FStarC_Class_Monoid.op_Plus_Plus + (FStarC_Compiler_CList.monoid_clist ()) + g.FStarC_TypeChecker_Common.deferred_to_tac + defer_to_tac in + let uu___6 = + FStarC_Class_Monoid.op_Plus_Plus + (FStarC_Compiler_CList.monoid_clist ()) + g.FStarC_TypeChecker_Common.implicits imps in + { + FStarC_TypeChecker_Common.guard_f = + (g.FStarC_TypeChecker_Common.guard_f); + FStarC_TypeChecker_Common.deferred_to_tac = + uu___5; + FStarC_TypeChecker_Common.deferred = deferred; + FStarC_TypeChecker_Common.univ_ineqs = + (g.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = uu___6 + } + | uu___5 -> + failwith + "Impossible: should have raised a failure already" in + solve_universe_inequalities env + g1.FStarC_TypeChecker_Common.univ_ineqs; + (let g2 = + if deferred_to_tac_ok + then + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_TypeChecker_Env.current_module env in + FStarC_Ident.string_of_lid uu___7 in + FStar_Pervasives_Native.Some uu___6 in + FStarC_Profiling.profile + (fun uu___6 -> + FStarC_TypeChecker_DeferredImplicits.solve_deferred_to_tactic_goals + env g1) uu___5 + "FStarC.TypeChecker.Rel.solve_deferred_to_tactic_goals" + else g1 in + (let uu___6 = + FStarC_Compiler_Effect.op_Bang + dbg_ResolveImplicitsHook in + if uu___6 + then + let uu___7 = guard_to_string env g2 in + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Class_Listlike.to_list + (FStarC_Compiler_CList.listlike_clist ()) + g2.FStarC_TypeChecker_Common.implicits in + FStarC_Compiler_List.length uu___10 in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_nat) uu___9 in + FStarC_Compiler_Util.print2 + "ResolveImplicitsHook: Solved deferred to tactic goals, remaining guard is\n%s (and %s implicits)\n" + uu___7 uu___8 + else ()); + { + FStarC_TypeChecker_Common.guard_f = + (g2.FStarC_TypeChecker_Common.guard_f); + FStarC_TypeChecker_Common.deferred_to_tac = + (g2.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (g2.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + ((Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist + ())))), + (Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic + (FStarC_Compiler_CList.listlike_clist + ()))))); + FStarC_TypeChecker_Common.implicits = + (g2.FStarC_TypeChecker_Common.implicits) + }))) uu___1 + "FStarC.TypeChecker.Rel.try_solve_deferred_constraints") +let (solve_deferred_constraints : + FStarC_TypeChecker_Env.env -> + FStarC_TypeChecker_Common.guard_t -> FStarC_TypeChecker_Common.guard_t) + = + fun env -> + fun g -> + let defer_ok = NoDefer in + let smt_ok = + let uu___ = FStarC_Options.ml_ish () in Prims.op_Negation uu___ in + let deferred_to_tac_ok = true in + try_solve_deferred_constraints defer_ok smt_ok deferred_to_tac_ok env g +let (solve_non_tactic_deferred_constraints : + Prims.bool -> + FStarC_TypeChecker_Env.env -> + FStarC_TypeChecker_Common.guard_t -> FStarC_TypeChecker_Common.guard_t) + = + fun maybe_defer_flex_flex -> + fun env -> + fun g -> + FStarC_Errors.with_ctx "solve_non_tactic_deferred_constraints" + (fun uu___ -> + FStarC_Defensive.def_check_scoped + FStarC_TypeChecker_Env.hasBinders_env + FStarC_TypeChecker_Env.hasNames_guard + FStarC_TypeChecker_Env.pretty_guard + FStarC_Compiler_Range_Type.dummyRange + "solve_non_tactic_deferred_constraints.g" env g; + (let defer_ok = + if maybe_defer_flex_flex then DeferFlexFlexOnly else NoDefer in + let smt_ok = + let uu___2 = FStarC_Options.ml_ish () in + Prims.op_Negation uu___2 in + let deferred_to_tac_ok = false in + try_solve_deferred_constraints defer_ok smt_ok + deferred_to_tac_ok env g)) +let (do_discharge_vc : + (unit -> Prims.string) FStar_Pervasives_Native.option -> + FStarC_TypeChecker_Env.env -> FStarC_TypeChecker_Env.goal -> unit) + = + fun use_env_range_msg -> + fun env -> + fun vc -> + let debug = + ((FStarC_Compiler_Effect.op_Bang dbg_Rel) || + (FStarC_Compiler_Effect.op_Bang dbg_SMTQuery)) + || (FStarC_Compiler_Effect.op_Bang dbg_Discharge) in + let diag uu___1 uu___ = + (let uu___ = FStarC_TypeChecker_Env.get_range env in + Obj.magic + (FStarC_Errors.diag FStarC_Class_HasRange.hasRange_range uu___ + ())) uu___1 uu___ in + if debug + then + (let uu___1 = + let uu___2 = + let uu___3 = FStarC_Errors_Msg.text "Checking VC:" in + let uu___4 = + FStarC_Class_PP.pp FStarC_Syntax_Print.pretty_term vc in + FStarC_Pprint.op_Hat_Slash_Hat uu___3 uu___4 in + [uu___2] in + diag FStarC_Errors_Msg.is_error_message_list_doc uu___1) + else (); + (let vcs = + let uu___1 = FStarC_Options.use_tactics () in + if uu___1 + then + FStarC_Options.with_saved_options + (fun uu___2 -> + (let uu___4 = FStarC_Options.set_options "--no_tactics" in + ()); + (let uu___4 = + (env.FStarC_TypeChecker_Env.solver).FStarC_TypeChecker_Env.preprocess + env vc in + match uu___4 with + | (did_anything, vcs1) -> + (if debug && did_anything + then + (let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Errors_Msg.text + "Tactic preprocessing produced" in + let uu___9 = + let uu___10 = + FStarC_Class_PP.pp FStarC_Class_PP.pp_int + (FStarC_Compiler_List.length vcs1) in + let uu___11 = FStarC_Errors_Msg.text "goals" in + FStarC_Pprint.op_Hat_Slash_Hat uu___10 + uu___11 in + FStarC_Pprint.op_Hat_Slash_Hat uu___8 uu___9 in + [uu___7] in + diag FStarC_Errors_Msg.is_error_message_list_doc + uu___6) + else (); + (let vcs2 = + FStarC_Compiler_List.map + (fun uu___6 -> + match uu___6 with + | (env1, goal, opts) -> + let uu___7 = + norm_with_steps + "FStarC.TypeChecker.Rel.norm_with_steps.7" + [FStarC_TypeChecker_Env.Simplify; + FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.Exclude + FStarC_TypeChecker_Env.Zeta] env1 + goal in + (env1, uu___7, opts)) vcs1 in + let vcs3 = + FStarC_Compiler_List.concatMap + (fun uu___6 -> + match uu___6 with + | (env1, goal, opts) -> + let uu___7 = + (env1.FStarC_TypeChecker_Env.solver).FStarC_TypeChecker_Env.handle_smt_goal + env1 goal in + FStarC_Compiler_List.map + (fun uu___8 -> + match uu___8 with + | (env2, goal1) -> + (env2, goal1, opts)) uu___7) + vcs2 in + let vcs4 = + FStarC_Compiler_List.concatMap + (fun uu___6 -> + match uu___6 with + | (env1, goal, opts) -> + let uu___7 = + FStarC_TypeChecker_Common.check_trivial + goal in + (match uu___7 with + | FStarC_TypeChecker_Common.Trivial -> + (if debug + then + (let uu___9 = + let uu___10 = + FStarC_Errors_Msg.text + "Goal completely solved by tactic\n" in + [uu___10] in + diag + FStarC_Errors_Msg.is_error_message_list_doc + uu___9) + else (); + []) + | FStarC_TypeChecker_Common.NonTrivial + goal1 -> [(env1, goal1, opts)])) + vcs3 in + vcs4)))) + else + (let uu___3 = + let uu___4 = FStarC_Options.peek () in (env, vc, uu___4) in + [uu___3]) in + let vcs1 = + let uu___1 = + let uu___2 = FStarC_Options.split_queries () in + uu___2 = FStarC_Options.Always in + if uu___1 + then + FStarC_Compiler_List.collect + (fun uu___2 -> + match uu___2 with + | (env1, goal, opts) -> + let uu___3 = + FStarC_TypeChecker_Env.split_smt_query env1 goal in + (match uu___3 with + | FStar_Pervasives_Native.None -> [(env1, goal, opts)] + | FStar_Pervasives_Native.Some goals -> + FStarC_Compiler_List.map + (fun uu___4 -> + match uu___4 with + | (env2, goal1) -> (env2, goal1, opts)) goals)) + vcs + else vcs in + FStarC_Compiler_List.iter + (fun uu___1 -> + match uu___1 with + | (env1, goal, opts) -> + FStarC_Options.with_saved_options + (fun uu___2 -> + FStarC_Options.set opts; + if debug + then + (let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Errors_Msg.text + "Before calling solver, VC =" in + let uu___8 = + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_term goal in + FStarC_Pprint.op_Hat_Slash_Hat uu___7 uu___8 in + [uu___6] in + diag FStarC_Errors_Msg.is_error_message_list_doc + uu___5) + else (); + (env1.FStarC_TypeChecker_Env.solver).FStarC_TypeChecker_Env.solve + use_env_range_msg env1 goal)) vcs1) +let (discharge_guard' : + (unit -> Prims.string) FStar_Pervasives_Native.option -> + FStarC_TypeChecker_Env.env -> + FStarC_TypeChecker_Common.guard_t -> + Prims.bool -> + FStarC_TypeChecker_Common.guard_t FStar_Pervasives_Native.option) + = + fun use_env_range_msg -> + fun env -> + fun g -> + fun use_smt -> + (let uu___1 = + FStarC_Compiler_Effect.op_Bang dbg_ResolveImplicitsHook in + if uu___1 + then + let uu___2 = guard_to_string env g in + FStarC_Compiler_Util.print1 + "///////////////////ResolveImplicitsHook: discharge_guard'\nguard = %s\n" + uu___2 + else ()); + (let g1 = + let defer_ok = NoDefer in + let smt_ok = + (let uu___1 = FStarC_Options.ml_ish () in + Prims.op_Negation uu___1) && use_smt in + let deferred_to_tac_ok = true in + try_solve_deferred_constraints defer_ok smt_ok + deferred_to_tac_ok env g in + let debug = + ((FStarC_Compiler_Effect.op_Bang dbg_Rel) || + (FStarC_Compiler_Effect.op_Bang dbg_SMTQuery)) + || (FStarC_Compiler_Effect.op_Bang dbg_Discharge) in + let diag uu___2 uu___1 = + (let uu___1 = FStarC_TypeChecker_Env.get_range env in + Obj.magic + (FStarC_Errors.diag FStarC_Class_HasRange.hasRange_range + uu___1 ())) uu___2 uu___1 in + let ret_g = + { + FStarC_TypeChecker_Common.guard_f = + FStarC_TypeChecker_Common.Trivial; + FStarC_TypeChecker_Common.deferred_to_tac = + (g1.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (g1.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (g1.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = + (g1.FStarC_TypeChecker_Common.implicits) + } in + if env.FStarC_TypeChecker_Env.admit + then + (if + (debug && + (Prims.op_Negation + (FStarC_TypeChecker_Common.uu___is_Trivial + g1.FStarC_TypeChecker_Common.guard_f))) + && (Prims.op_Negation env.FStarC_TypeChecker_Env.phase1) + then + (let uu___2 = + let uu___3 = + FStarC_Errors_Msg.text + "Skipping VC because verification is disabled." in + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Errors_Msg.text "VC =" in + let uu___7 = + FStarC_Class_PP.pp + FStarC_TypeChecker_Env.pretty_guard g1 in + FStarC_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in + [uu___5] in + uu___3 :: uu___4 in + diag FStarC_Errors_Msg.is_error_message_list_doc uu___2) + else (); + FStar_Pervasives_Native.Some ret_g) + else + (let g2 = simplify_guard_full_norm env g1 in + match g2.FStarC_TypeChecker_Common.guard_f with + | FStarC_TypeChecker_Common.Trivial -> + FStar_Pervasives_Native.Some ret_g + | FStarC_TypeChecker_Common.NonTrivial vc when + Prims.op_Negation use_smt -> + (if debug + then + (let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Errors_Msg.text + "Cannot solve without SMT:" in + let uu___6 = + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_term vc in + FStarC_Pprint.op_Hat_Slash_Hat uu___5 uu___6 in + [uu___4] in + diag FStarC_Errors_Msg.is_error_message_list_doc uu___3) + else (); + FStar_Pervasives_Native.None) + | FStarC_TypeChecker_Common.NonTrivial vc -> + (do_discharge_vc use_env_range_msg env vc; + FStar_Pervasives_Native.Some ret_g))) +let (discharge_guard : + FStarC_TypeChecker_Env.env -> + FStarC_TypeChecker_Common.guard_t -> FStarC_TypeChecker_Common.guard_t) + = + fun env -> + fun g -> + let uu___ = discharge_guard' FStar_Pervasives_Native.None env g true in + match uu___ with + | FStar_Pervasives_Native.Some g1 -> g1 + | FStar_Pervasives_Native.None -> + failwith + "Impossible, with use_smt = true, discharge_guard' should never have returned None" +let (discharge_guard_no_smt : + FStarC_TypeChecker_Env.env -> + FStarC_TypeChecker_Common.guard_t -> FStarC_TypeChecker_Common.guard_t) + = + fun env -> + fun g -> + let uu___ = discharge_guard' FStar_Pervasives_Native.None env g false in + match uu___ with + | FStar_Pervasives_Native.Some g1 -> g1 + | FStar_Pervasives_Native.None -> + let uu___1 = + let uu___2 = + FStarC_Errors_Msg.text "Expected a trivial pre-condition" in + [uu___2] in + FStarC_Errors.raise_error FStarC_TypeChecker_Env.hasRange_env env + FStarC_Errors_Codes.Fatal_ExpectTrivialPreCondition () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___1) +let (teq_nosmt : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.typ -> + FStarC_TypeChecker_Common.guard_t FStar_Pervasives_Native.option) + = + fun env -> + fun t1 -> + fun t2 -> + let uu___ = try_teq false env t1 t2 in + match uu___ with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some g -> + discharge_guard' FStar_Pervasives_Native.None env g false +let (subtype_nosmt : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.typ -> + FStarC_TypeChecker_Common.guard_t FStar_Pervasives_Native.option) + = + fun env -> + fun t1 -> + fun t2 -> + (let uu___1 = + (FStarC_Compiler_Effect.op_Bang dbg_Rel) || + (FStarC_Compiler_Effect.op_Bang dbg_RelTop) in + if uu___1 + then + let uu___2 = FStarC_TypeChecker_Normalize.term_to_string env t1 in + let uu___3 = FStarC_TypeChecker_Normalize.term_to_string env t2 in + FStarC_Compiler_Util.print2 "try_subtype_no_smt of %s and %s\n" + uu___2 uu___3 + else ()); + (let uu___1 = + let uu___2 = empty_worklist env in + new_t_prob uu___2 env t1 FStarC_TypeChecker_Common.SUB t2 in + match uu___1 with + | (prob, x, wl) -> + let g = + let uu___2 = + solve_and_commit (singleton wl prob false) + (fun uu___3 -> FStar_Pervasives_Native.None) in + with_guard env prob uu___2 in + (match g with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some g1 -> + let g2 = + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.mk_binder x in + [uu___3] in + FStarC_TypeChecker_Env.close_guard env uu___2 g1 in + discharge_guard' FStar_Pervasives_Native.None env g2 false)) +let (check_subtyping : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + (FStarC_Syntax_Syntax.bv * FStarC_TypeChecker_Common.guard_t) + FStar_Pervasives_Native.option) + = + fun env -> + fun t1 -> + fun t2 -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_Env.current_module env in + FStarC_Ident.string_of_lid uu___2 in + FStar_Pervasives_Native.Some uu___1 in + FStarC_Profiling.profile + (fun uu___1 -> + (let uu___3 = + (FStarC_Compiler_Effect.op_Bang dbg_Rel) || + (FStarC_Compiler_Effect.op_Bang dbg_RelTop) in + if uu___3 + then + let uu___4 = + FStarC_TypeChecker_Normalize.term_to_string env t1 in + let uu___5 = + FStarC_TypeChecker_Normalize.term_to_string env t2 in + FStarC_Compiler_Util.print2 "check_subtyping of %s and %s\n" + uu___4 uu___5 + else ()); + (let uu___3 = + let uu___4 = empty_worklist env in + new_t_prob uu___4 env t1 FStarC_TypeChecker_Common.SUB t2 in + match uu___3 with + | (prob, x, wl) -> + let env_x = FStarC_TypeChecker_Env.push_bv env x in + let smt_ok = + let uu___4 = FStarC_Options.ml_ish () in + Prims.op_Negation uu___4 in + let g = + let uu___4 = + solve_and_commit (singleton wl prob smt_ok) + (fun uu___5 -> FStar_Pervasives_Native.None) in + with_guard env_x prob uu___4 in + (match g with + | FStar_Pervasives_Native.None -> + ((let uu___5 = + (FStarC_Compiler_Effect.op_Bang dbg_Rel) || + (FStarC_Compiler_Effect.op_Bang dbg_RelTop) in + if uu___5 + then + let uu___6 = + FStarC_TypeChecker_Normalize.term_to_string + env_x t1 in + let uu___7 = + FStarC_TypeChecker_Normalize.term_to_string + env_x t2 in + FStarC_Compiler_Util.print2 + "check_subtyping FAILED: %s <: %s\n" uu___6 + uu___7 + else ()); + FStar_Pervasives_Native.None) + | FStar_Pervasives_Native.Some g1 -> + ((let uu___5 = + (FStarC_Compiler_Effect.op_Bang dbg_Rel) || + (FStarC_Compiler_Effect.op_Bang dbg_RelTop) in + if uu___5 + then + let uu___6 = + FStarC_TypeChecker_Normalize.term_to_string + env_x t1 in + let uu___7 = + FStarC_TypeChecker_Normalize.term_to_string + env_x t2 in + let uu___8 = guard_to_string env_x g1 in + FStarC_Compiler_Util.print3 + "check_subtyping succeeded: %s <: %s\n\tguard is %s\n" + uu___6 uu___7 uu___8 + else ()); + FStar_Pervasives_Native.Some (x, g1))))) uu___ + "FStarC.TypeChecker.Rel.check_subtyping" +let (get_subtyping_predicate : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.typ -> + FStarC_TypeChecker_Common.guard_t FStar_Pervasives_Native.option) + = + fun env -> + fun t1 -> + fun t2 -> + FStarC_Errors.with_ctx "While trying to get a subtyping predicate" + (fun uu___ -> + FStarC_Defensive.def_check_scoped + FStarC_TypeChecker_Env.hasBinders_env + FStarC_Class_Binders.hasNames_term + FStarC_Syntax_Print.pretty_term t1.FStarC_Syntax_Syntax.pos + "get_subtyping_predicate.1" env t1; + FStarC_Defensive.def_check_scoped + FStarC_TypeChecker_Env.hasBinders_env + FStarC_Class_Binders.hasNames_term + FStarC_Syntax_Print.pretty_term t2.FStarC_Syntax_Syntax.pos + "get_subtyping_predicate.2" env t2; + (let uu___3 = check_subtyping env t1 t2 in + match uu___3 with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (x, g) -> + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.mk_binder x in + FStarC_TypeChecker_Env.abstract_guard uu___5 g in + FStar_Pervasives_Native.Some uu___4)) +let (get_subtyping_prop : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.typ -> + FStarC_TypeChecker_Common.guard_t FStar_Pervasives_Native.option) + = + fun env -> + fun t1 -> + fun t2 -> + FStarC_Errors.with_ctx "While trying to get a subtyping proposition" + (fun uu___ -> + FStarC_Defensive.def_check_scoped + FStarC_TypeChecker_Env.hasBinders_env + FStarC_Class_Binders.hasNames_term + FStarC_Syntax_Print.pretty_term t1.FStarC_Syntax_Syntax.pos + "get_subtyping_prop.1" env t1; + FStarC_Defensive.def_check_scoped + FStarC_TypeChecker_Env.hasBinders_env + FStarC_Class_Binders.hasNames_term + FStarC_Syntax_Print.pretty_term t2.FStarC_Syntax_Syntax.pos + "get_subtyping_prop.2" env t2; + (let uu___3 = check_subtyping env t1 t2 in + match uu___3 with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (x, g) -> + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Syntax_Syntax.mk_binder x in + [uu___6] in + FStarC_TypeChecker_Env.close_guard env uu___5 g in + FStar_Pervasives_Native.Some uu___4)) +let (try_solve_single_valued_implicits : + FStarC_TypeChecker_Env.env -> + Prims.bool -> + FStarC_TypeChecker_Env.implicits -> + (FStarC_TypeChecker_Env.implicits * Prims.bool)) + = + fun env -> + fun is_tac -> + fun imps -> + if is_tac + then (imps, false) + else + (let imp_value imp = + let uu___1 = + ((imp.FStarC_TypeChecker_Common.imp_uvar), + (imp.FStarC_TypeChecker_Common.imp_range)) in + match uu___1 with + | (ctx_u, r) -> + let t_norm = + let uu___2 = FStarC_Syntax_Util.ctx_uvar_typ ctx_u in + FStarC_TypeChecker_Normalize.normalize + FStarC_TypeChecker_Normalize.whnf_steps env uu___2 in + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress t_norm in + uu___3.FStarC_Syntax_Syntax.n in + (match uu___2 with + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.unit_lid + -> + let uu___3 = + FStarC_Syntax_Syntax.unit_const_with_range r in + FStar_Pervasives_Native.Some uu___3 + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = b; + FStarC_Syntax_Syntax.phi = uu___3;_} + when + FStarC_Syntax_Util.is_unit b.FStarC_Syntax_Syntax.sort + -> + let uu___4 = + FStarC_Syntax_Syntax.unit_const_with_range r in + FStar_Pervasives_Native.Some uu___4 + | uu___3 -> FStar_Pervasives_Native.None) in + let b = + FStarC_Compiler_List.fold_left + (fun b1 -> + fun imp -> + let uu___1 = + (let uu___2 = + FStarC_Syntax_Unionfind.find + (imp.FStarC_TypeChecker_Common.imp_uvar).FStarC_Syntax_Syntax.ctx_uvar_head in + FStarC_Compiler_Util.is_none uu___2) && + (let uu___2 = + FStarC_Syntax_Util.ctx_uvar_should_check + imp.FStarC_TypeChecker_Common.imp_uvar in + uu___2 = FStarC_Syntax_Syntax.Strict) in + if uu___1 + then + let uu___2 = imp_value imp in + match uu___2 with + | FStar_Pervasives_Native.Some tm -> + (commit env + [TERM + ((imp.FStarC_TypeChecker_Common.imp_uvar), + tm)]; + true) + | FStar_Pervasives_Native.None -> b1 + else b1) false imps in + (imps, b)) +let (check_implicit_solution_and_discharge_guard : + FStarC_TypeChecker_Env.env -> + FStarC_TypeChecker_Common.implicit -> + Prims.bool -> + Prims.bool -> + FStarC_TypeChecker_Common.implicits_t + FStar_Pervasives_Native.option) + = + fun env -> + fun imp -> + fun is_tac -> + fun force_univ_constraints -> + let uu___ = imp in + match uu___ with + | { FStarC_TypeChecker_Common.imp_reason = imp_reason; + FStarC_TypeChecker_Common.imp_uvar = imp_uvar; + FStarC_TypeChecker_Common.imp_tm = imp_tm; + FStarC_TypeChecker_Common.imp_range = imp_range;_} -> + let uvar_ty = FStarC_Syntax_Util.ctx_uvar_typ imp_uvar in + let uvar_should_check = + FStarC_Syntax_Util.ctx_uvar_should_check imp_uvar in + ((let uu___2 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___2 + then + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_uvar + imp_uvar.FStarC_Syntax_Syntax.ctx_uvar_head in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + imp_tm in + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + uvar_ty in + let uu___6 = + FStarC_Compiler_Range_Ops.string_of_range imp_range in + FStarC_Compiler_Util.print5 + "Checking uvar %s resolved to %s at type %s, introduce for %s at %s\n" + uu___3 uu___4 uu___5 imp_reason uu___6 + else ()); + (let env1 = + let uu___2 = + FStarC_TypeChecker_Env.clear_expected_typ + { + FStarC_TypeChecker_Env.solver = + (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (imp_uvar.FStarC_Syntax_Syntax.ctx_uvar_gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env.FStarC_TypeChecker_Env.missing_decl) + } in + FStar_Pervasives_Native.fst uu___2 in + let g = + FStarC_Errors.with_ctx "While checking implicit solution" + (fun uu___2 -> + let skip_core = + ((env1.FStarC_TypeChecker_Env.phase1 || + env1.FStarC_TypeChecker_Env.admit) + || + (FStarC_Syntax_Syntax.uu___is_Allow_untyped + uvar_should_check)) + || + (FStarC_Syntax_Syntax.uu___is_Already_checked + uvar_should_check) in + let must_tot = + Prims.op_Negation + ((env1.FStarC_TypeChecker_Env.phase1 || + env1.FStarC_TypeChecker_Env.admit) + || + (FStarC_Syntax_Syntax.uu___is_Allow_ghost + uvar_should_check)) in + if skip_core + then + (if is_tac + then FStarC_TypeChecker_Env.trivial_guard + else + (let imp_tm1 = + let uu___4 = + let uu___5 = + FStarC_Syntax_Subst.compress imp_tm in + uu___5.FStarC_Syntax_Syntax.n in + match uu___4 with + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs; + FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = + FStar_Pervasives_Native.Some rc;_} + -> + { + FStarC_Syntax_Syntax.n = + (FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs = bs; + FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = + (FStar_Pervasives_Native.Some + { + FStarC_Syntax_Syntax.residual_effect + = + (rc.FStarC_Syntax_Syntax.residual_effect); + FStarC_Syntax_Syntax.residual_typ + = + FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.residual_flags + = + (rc.FStarC_Syntax_Syntax.residual_flags) + }) + }); + FStarC_Syntax_Syntax.pos = + (imp_tm.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = + (imp_tm.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (imp_tm.FStarC_Syntax_Syntax.hash_code) + } + | uu___5 -> imp_tm in + let uu___4 = + env1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + env1 imp_tm1 must_tot in + match uu___4 with + | (k', g1) -> + let uu___5 = + get_subtyping_predicate env1 k' uvar_ty in + (match uu___5 with + | FStar_Pervasives_Native.None -> + FStarC_TypeChecker_Err.expected_expression_of_type + env1 imp_tm1.FStarC_Syntax_Syntax.pos + uvar_ty imp_tm1 k' + | FStar_Pervasives_Native.Some f -> + let uu___6 = + let uu___7 = + FStarC_TypeChecker_Env.apply_guard + f imp_tm1 in + FStarC_TypeChecker_Env.conj_guard + uu___7 g1 in + { + FStarC_TypeChecker_Common.guard_f = + FStarC_TypeChecker_Common.Trivial; + FStarC_TypeChecker_Common.deferred_to_tac + = + (uu___6.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (uu___6.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs + = + (uu___6.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = + (uu___6.FStarC_TypeChecker_Common.implicits) + }))) + else + (let uu___4 = + env1.FStarC_TypeChecker_Env.core_check env1 + imp_tm uvar_ty must_tot in + match uu___4 with + | FStar_Pervasives.Inl + (FStar_Pervasives_Native.None) -> + FStarC_TypeChecker_Common.trivial_guard + | FStar_Pervasives.Inl + (FStar_Pervasives_Native.Some g1) -> + { + FStarC_TypeChecker_Common.guard_f = + (FStarC_TypeChecker_Common.NonTrivial g1); + FStarC_TypeChecker_Common.deferred_to_tac = + (FStarC_TypeChecker_Common.trivial_guard.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (FStarC_TypeChecker_Common.trivial_guard.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (FStarC_TypeChecker_Common.trivial_guard.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = + (FStarC_TypeChecker_Common.trivial_guard.FStarC_TypeChecker_Common.implicits) + } + | FStar_Pervasives.Inr print_err -> + let uu___5 = + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_ctxu + imp_uvar in + let uu___7 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + is_tac in + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term imp_tm in + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term uvar_ty in + FStarC_Compiler_Util.format5 + "Core checking failed for implicit %s (is_tac: %s) (reason: %s) (%s <: %s)" + uu___6 uu___7 imp_reason uu___8 uu___9 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + imp_range + FStarC_Errors_Codes.Fatal_FailToResolveImplicitArgument + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___5))) in + let uu___2 = + (Prims.op_Negation force_univ_constraints) && + (FStarC_Compiler_CList.existsb + (fun uu___3 -> + match uu___3 with + | (reason, uu___4, uu___5) -> + reason = + FStarC_TypeChecker_Common.Deferred_univ_constraint) + g.FStarC_TypeChecker_Common.deferred) in + if uu___2 + then FStar_Pervasives_Native.None + else + (let g' = + let uu___4 = + discharge_guard' + (FStar_Pervasives_Native.Some + (fun uu___5 -> + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term imp_tm in + let uu___7 = + FStarC_Class_Show.show + FStarC_Compiler_Range_Ops.showable_range + imp_range in + let uu___8 = + FStarC_Class_Show.show + FStarC_Compiler_Range_Ops.showable_range + imp_tm.FStarC_Syntax_Syntax.pos in + FStarC_Compiler_Util.format4 + "%s (Introduced at %s for %s resolved at %s)" + uu___6 uu___7 imp_reason uu___8)) env1 g + true in + match uu___4 with + | FStar_Pervasives_Native.Some g1 -> g1 + | FStar_Pervasives_Native.None -> + failwith + "Impossible, with use_smt = true, discharge_guard' must return Some" in + FStar_Pervasives_Native.Some + (g'.FStarC_TypeChecker_Common.implicits)))) +let rec (unresolved : FStarC_Syntax_Syntax.ctx_uvar -> Prims.bool) = + fun ctx_u -> + let uu___ = + FStarC_Syntax_Unionfind.find ctx_u.FStarC_Syntax_Syntax.ctx_uvar_head in + match uu___ with + | FStar_Pervasives_Native.Some r -> + (match ctx_u.FStarC_Syntax_Syntax.ctx_uvar_meta with + | FStar_Pervasives_Native.None -> false + | FStar_Pervasives_Native.Some uu___1 -> + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress r in + uu___3.FStarC_Syntax_Syntax.n in + (match uu___2 with + | FStarC_Syntax_Syntax.Tm_uvar (ctx_u', uu___3) -> + unresolved ctx_u' + | uu___3 -> false)) + | FStar_Pervasives_Native.None -> true +let (pick_a_univ_deffered_implicit : + tagged_implicits -> + (FStarC_TypeChecker_Env.implicit FStar_Pervasives_Native.option * + tagged_implicits)) + = + fun out -> + let uu___ = + FStarC_Compiler_List.partition + (fun uu___1 -> + match uu___1 with + | (uu___2, status) -> + status = Implicit_checking_defers_univ_constraint) out in + match uu___ with + | (imps_with_deferred_univs, rest) -> + (match imps_with_deferred_univs with + | [] -> (FStar_Pervasives_Native.None, out) + | hd::tl -> + ((FStar_Pervasives_Native.Some (FStar_Pervasives_Native.fst hd)), + (FStarC_Compiler_List.op_At tl rest))) +let (is_tac_implicit_resolved : + FStarC_TypeChecker_Env.env -> + FStarC_TypeChecker_Common.implicit -> Prims.bool) + = + fun env -> + fun i -> + let uu___ = FStarC_Syntax_Free.uvars i.FStarC_TypeChecker_Common.imp_tm in + FStarC_Class_Setlike.for_all () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) + (fun uv -> + let uu___1 = FStarC_Syntax_Util.ctx_uvar_should_check uv in + FStarC_Syntax_Syntax.uu___is_Allow_unresolved uu___1) + (Obj.magic uu___) +let (resolve_implicits' : + FStarC_TypeChecker_Env.env -> + Prims.bool -> + Prims.bool -> + FStarC_TypeChecker_Env.implicits -> + (FStarC_TypeChecker_Common.implicit * implicit_checking_status) + Prims.list) + = + fun env -> + fun is_tac -> + fun is_gen -> + fun implicits -> + let cacheable tac = + (FStarC_Syntax_Util.is_fvar FStarC_Parser_Const.tcresolve_lid tac) + || + (let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress tac in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = uu___1::[]; + FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = uu___2;_} + -> + let uu___3 = FStarC_Syntax_Util.head_and_args body in + (match uu___3 with + | (hd, args) -> + (FStarC_Syntax_Util.is_fvar + FStarC_Parser_Const.tcresolve_lid hd) + && + ((FStarC_Compiler_List.length args) = Prims.int_one)) + | uu___1 -> false) in + let meta_tac_allowed_for_open_problem tac = cacheable tac in + let __meta_arg_cache = FStarC_Compiler_Util.mk_ref [] in + let meta_arg_cache_result tac e ty res = + let uu___ = + let uu___1 = FStarC_Compiler_Effect.op_Bang __meta_arg_cache in + (tac, e, ty, res) :: uu___1 in + FStarC_Compiler_Effect.op_Colon_Equals __meta_arg_cache uu___ in + let meta_arg_cache_lookup tac e ty = + let rec aux l = + match l with + | [] -> FStar_Pervasives_Native.None + | (tac', e', ty', res')::l' -> + let uu___ = + ((FStarC_Syntax_Util.term_eq tac tac') && + (FStarC_Common.eq_list FStarC_Syntax_Util.eq_binding + e.FStarC_TypeChecker_Env.gamma + e'.FStarC_TypeChecker_Env.gamma)) + && (FStarC_Syntax_Util.term_eq ty ty') in + if uu___ then FStar_Pervasives_Native.Some res' else aux l' in + let uu___ = FStarC_Compiler_Effect.op_Bang __meta_arg_cache in + aux uu___ in + let rec until_fixpoint acc implicits1 = + let uu___ = acc in + match uu___ with + | (out, changed, defer_open_metas) -> + (match implicits1 with + | [] -> + if changed + then + let uu___1 = + FStarC_Compiler_List.map FStar_Pervasives_Native.fst + out in + until_fixpoint ([], false, true) uu___1 + else + if defer_open_metas + then + (let uu___2 = + FStarC_Compiler_List.map + FStar_Pervasives_Native.fst out in + until_fixpoint ([], false, false) uu___2) + else + (let uu___3 = + let uu___4 = + FStarC_Compiler_List.map + FStar_Pervasives_Native.fst out in + try_solve_single_valued_implicits env is_tac + uu___4 in + match uu___3 with + | (imps, changed1) -> + if changed1 + then until_fixpoint ([], false, true) imps + else + (let uu___5 = + pick_a_univ_deffered_implicit out in + match uu___5 with + | (imp_opt, rest) -> + (match imp_opt with + | FStar_Pervasives_Native.None -> rest + | FStar_Pervasives_Native.Some imp -> + let force_univ_constraints = true in + let imps1 = + let uu___6 = + check_implicit_solution_and_discharge_guard + env imp is_tac + force_univ_constraints in + FStarC_Compiler_Util.must uu___6 in + let uu___6 = + let uu___7 = + FStarC_Class_Listlike.to_list + (FStarC_Compiler_CList.listlike_clist + ()) imps1 in + let uu___8 = + FStarC_Compiler_List.map + FStar_Pervasives_Native.fst + rest in + FStarC_Class_Monoid.op_Plus_Plus + (FStarC_Class_Monoid.monoid_list + ()) uu___7 uu___8 in + until_fixpoint ([], false, true) + uu___6))) + | hd::tl -> + let uu___1 = hd in + (match uu___1 with + | { FStarC_TypeChecker_Common.imp_reason = reason; + FStarC_TypeChecker_Common.imp_uvar = ctx_u; + FStarC_TypeChecker_Common.imp_tm = tm; + FStarC_TypeChecker_Common.imp_range = r;_} -> + let uu___2 = + FStarC_Syntax_Unionfind.find_decoration + ctx_u.FStarC_Syntax_Syntax.ctx_uvar_head in + (match uu___2 with + | { + FStarC_Syntax_Syntax.uvar_decoration_typ = + uvar_decoration_typ; + FStarC_Syntax_Syntax.uvar_decoration_typedness_depends_on + = uu___3; + FStarC_Syntax_Syntax.uvar_decoration_should_check + = uvar_decoration_should_check; + FStarC_Syntax_Syntax.uvar_decoration_should_unrefine + = uu___4;_} + -> + ((let uu___6 = + FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___6 + then + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term tm in + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_ctxu + ctx_u in + let uu___9 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + is_tac in + let uu___10 = + FStarC_Class_Show.show + FStarC_Syntax_Syntax.showable_should_check_uvar + uvar_decoration_should_check in + FStarC_Compiler_Util.print4 + "resolve_implicits' loop, imp_tm=%s and ctx_u=%s, is_tac=%s, should_check=%s\n" + uu___7 uu___8 uu___9 uu___10 + else ()); + if + FStarC_Syntax_Syntax.uu___is_Allow_unresolved + uvar_decoration_should_check + then + until_fixpoint + (out, true, defer_open_metas) tl + else + if + (unresolved ctx_u) && + (flex_uvar_has_meta_tac ctx_u) + then + (let uu___6 = + ctx_u.FStarC_Syntax_Syntax.ctx_uvar_meta in + match uu___6 with + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Ctx_uvar_meta_tac + tac) -> + let env1 = + { + FStarC_TypeChecker_Env.solver = + (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule + = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (ctx_u.FStarC_Syntax_Syntax.ctx_uvar_gamma); + FStarC_TypeChecker_Env.gamma_sig + = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache + = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ + = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp + = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize + = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level + = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars + = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict + = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface + = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes + = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard + = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking + = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping + = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics + = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce + = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of + = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force + = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths + = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns + = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook + = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess + = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess + = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info + = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks + = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab + = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check + = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl + = + (env.FStarC_TypeChecker_Env.missing_decl) + } in + let typ = + FStarC_Syntax_Util.ctx_uvar_typ + ctx_u in + let is_open = + (has_free_uvars typ) || + (gamma_has_free_uvars + ctx_u.FStarC_Syntax_Syntax.ctx_uvar_gamma) in + if defer_open_metas && is_open + then + ((let uu___8 = + (FStarC_Compiler_Effect.op_Bang + dbg_Rel) + || + (FStarC_Compiler_Effect.op_Bang + dbg_Imps) in + if uu___8 + then + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_ctxu + ctx_u in + FStarC_Compiler_Util.print1 + "Deferring implicit due to open ctx/typ %s\n" + uu___9 + else ()); + until_fixpoint + (((hd, Implicit_unresolved) :: + out), changed, + defer_open_metas) tl) + else + (let uu___8 = + (is_open && + (let uu___9 = + meta_tac_allowed_for_open_problem + tac in + Prims.op_Negation uu___9)) + && + (let uu___9 = + FStarC_Options_Ext.get + "compat:open_metas" in + uu___9 = "") in + if uu___8 + then + until_fixpoint + (((hd, Implicit_unresolved) + :: out), changed, + defer_open_metas) tl + else + (let solve_with t = + let extra = + let uu___10 = + teq_nosmt env1 t tm in + match uu___10 with + | FStar_Pervasives_Native.None + -> + failwith + "resolve_implicits: unifying with an unresolved uvar failed?" + | FStar_Pervasives_Native.Some + g -> + FStarC_Class_Listlike.to_list + (FStarC_Compiler_CList.listlike_clist + ()) + g.FStarC_TypeChecker_Common.implicits in + until_fixpoint + (out, true, + defer_open_metas) + (FStarC_Compiler_List.op_At + extra tl) in + let uu___10 = cacheable tac in + if uu___10 + then + let uu___11 = + meta_arg_cache_lookup tac + env1 typ in + match uu___11 with + | FStar_Pervasives_Native.Some + res -> solve_with res + | FStar_Pervasives_Native.None + -> + let t = + run_meta_arg_tac env1 + ctx_u in + (meta_arg_cache_result + tac env1 typ t; + solve_with t) + else + (let t = + run_meta_arg_tac env1 + ctx_u in + solve_with t)))) + else + if unresolved ctx_u + then + until_fixpoint + (((hd, Implicit_unresolved) :: out), + changed, defer_open_metas) tl + else + if + ((FStarC_Syntax_Syntax.uu___is_Allow_untyped + uvar_decoration_should_check) + || + (FStarC_Syntax_Syntax.uu___is_Already_checked + uvar_decoration_should_check)) + || is_gen + then + until_fixpoint + (out, true, defer_open_metas) tl + else + (let env1 = + { + FStarC_TypeChecker_Env.solver = + (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule + = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (ctx_u.FStarC_Syntax_Syntax.ctx_uvar_gamma); + FStarC_TypeChecker_Env.gamma_sig + = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache + = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ + = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp + = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize + = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level + = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars + = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict + = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface + = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes + = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard + = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking + = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping + = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics + = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce + = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of + = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force + = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths + = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns + = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook + = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess + = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess + = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info + = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks + = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab + = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check + = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl + = + (env.FStarC_TypeChecker_Env.missing_decl) + } in + let tm1 = + norm_with_steps + "FStarC.TypeChecker.Rel.norm_with_steps.8" + [FStarC_TypeChecker_Env.Beta] + env1 tm in + let hd1 = + { + FStarC_TypeChecker_Common.imp_reason + = + (hd.FStarC_TypeChecker_Common.imp_reason); + FStarC_TypeChecker_Common.imp_uvar + = + (hd.FStarC_TypeChecker_Common.imp_uvar); + FStarC_TypeChecker_Common.imp_tm + = tm1; + FStarC_TypeChecker_Common.imp_range + = + (hd.FStarC_TypeChecker_Common.imp_range) + } in + if is_tac + then + ((let uu___7 = + is_tac_implicit_resolved env1 + hd1 in + if uu___7 + then + let force_univ_constraints = + true in + let res = + check_implicit_solution_and_discharge_guard + env1 hd1 is_tac + force_univ_constraints in + let res1 = + FStarC_Compiler_Util.map_opt + res + (FStarC_Class_Listlike.to_list + (FStarC_Compiler_CList.listlike_clist + ())) in + (if + res1 <> + (FStar_Pervasives_Native.Some + []) + then + failwith + "Impossible: check_implicit_solution_and_discharge_guard for tac must return Some []" + else ()) + else ()); + until_fixpoint + (out, true, defer_open_metas) + tl) + else + (let force_univ_constraints = + false in + let imps_opt = + check_implicit_solution_and_discharge_guard + env1 hd1 is_tac + force_univ_constraints in + match imps_opt with + | FStar_Pervasives_Native.None -> + until_fixpoint + (((hd1, + Implicit_checking_defers_univ_constraint) + :: out), changed, + defer_open_metas) tl + | FStar_Pervasives_Native.Some + imps -> + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Class_Listlike.to_list + (FStarC_Compiler_CList.listlike_clist + ()) imps in + FStarC_Compiler_List.map + (fun i -> + (i, + Implicit_unresolved)) + uu___10 in + FStarC_Compiler_List.op_At + uu___9 out in + (uu___8, true, + defer_open_metas) in + until_fixpoint uu___7 tl)))))) in + until_fixpoint ([], false, true) implicits +let (resolve_implicits : + FStarC_TypeChecker_Env.env -> + FStarC_TypeChecker_Common.guard_t -> FStarC_TypeChecker_Common.guard_t) + = + fun env -> + fun g -> + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_ResolveImplicitsHook in + if uu___1 + then + let uu___2 = guard_to_string env g in + FStarC_Compiler_Util.print1 + "//////////////////////////ResolveImplicitsHook: resolve_implicits begin////////////\nguard = %s {\n" + uu___2 + else ()); + (let tagged_implicits1 = + let uu___1 = + FStarC_Class_Listlike.to_list + (FStarC_Compiler_CList.listlike_clist ()) + g.FStarC_TypeChecker_Common.implicits in + resolve_implicits' env false false uu___1 in + (let uu___2 = FStarC_Compiler_Effect.op_Bang dbg_ResolveImplicitsHook in + if uu___2 + then + FStarC_Compiler_Util.print_string + "//////////////////////////ResolveImplicitsHook: resolve_implicits end////////////\n}\n" + else ()); + (let uu___2 = + let uu___3 = + FStarC_Compiler_List.map FStar_Pervasives_Native.fst + tagged_implicits1 in + FStarC_Class_Listlike.from_list + (FStarC_Compiler_CList.listlike_clist ()) uu___3 in + { + FStarC_TypeChecker_Common.guard_f = + (g.FStarC_TypeChecker_Common.guard_f); + FStarC_TypeChecker_Common.deferred_to_tac = + (g.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (g.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (g.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = uu___2 + })) +let (resolve_generalization_implicits : + FStarC_TypeChecker_Env.env -> + FStarC_TypeChecker_Common.guard_t -> FStarC_TypeChecker_Common.guard_t) + = + fun env -> + fun g -> + let tagged_implicits1 = + let uu___ = + FStarC_Class_Listlike.to_list + (FStarC_Compiler_CList.listlike_clist ()) + g.FStarC_TypeChecker_Common.implicits in + resolve_implicits' env false true uu___ in + let uu___ = + let uu___1 = + FStarC_Compiler_List.map FStar_Pervasives_Native.fst + tagged_implicits1 in + FStarC_Class_Listlike.from_list + (FStarC_Compiler_CList.listlike_clist ()) uu___1 in + { + FStarC_TypeChecker_Common.guard_f = + (g.FStarC_TypeChecker_Common.guard_f); + FStarC_TypeChecker_Common.deferred_to_tac = + (g.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (g.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (g.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = uu___ + } +let (resolve_implicits_tac : + FStarC_TypeChecker_Env.env -> + FStarC_TypeChecker_Common.guard_t -> tagged_implicits) + = + fun env -> + fun g -> + let uu___ = + FStarC_Class_Listlike.to_list + (FStarC_Compiler_CList.listlike_clist ()) + g.FStarC_TypeChecker_Common.implicits in + resolve_implicits' env true false uu___ +let (force_trivial_guard : + FStarC_TypeChecker_Env.env -> FStarC_TypeChecker_Common.guard_t -> unit) = + fun env -> + fun g -> + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_ResolveImplicitsHook in + if uu___1 + then + let uu___2 = guard_to_string env g in + FStarC_Compiler_Util.print1 + "//////////////////////////ResolveImplicitsHook: force_trivial_guard////////////\nguard = %s\n" + uu___2 + else ()); + (let g1 = solve_deferred_constraints env g in + let g2 = resolve_implicits env g1 in + let uu___1 = + FStarC_Class_Listlike.to_list + (FStarC_Compiler_CList.listlike_clist ()) + g2.FStarC_TypeChecker_Common.implicits in + match uu___1 with + | [] -> let uu___2 = discharge_guard env g2 in () + | imp::uu___2 -> + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Errors_Msg.text + "Failed to resolve implicit argument" in + let uu___7 = + let uu___8 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_uvar + (imp.FStarC_TypeChecker_Common.imp_uvar).FStarC_Syntax_Syntax.ctx_uvar_head in + FStarC_Pprint.arbitrary_string uu___8 in + FStarC_Pprint.prefix (Prims.of_int (4)) Prims.int_one uu___6 + uu___7 in + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Errors_Msg.text "of type" in + let uu___9 = + let uu___10 = + FStarC_Syntax_Util.ctx_uvar_typ + imp.FStarC_TypeChecker_Common.imp_uvar in + FStarC_TypeChecker_Normalize.term_to_doc env uu___10 in + FStarC_Pprint.prefix (Prims.of_int (4)) Prims.int_one + uu___8 uu___9 in + let uu___8 = + let uu___9 = FStarC_Errors_Msg.text "introduced for" in + let uu___10 = + FStarC_Errors_Msg.text + imp.FStarC_TypeChecker_Common.imp_reason in + FStarC_Pprint.prefix (Prims.of_int (4)) Prims.int_one + uu___9 uu___10 in + FStarC_Pprint.op_Hat_Slash_Hat uu___7 uu___8 in + FStarC_Pprint.op_Hat_Slash_Hat uu___5 uu___6 in + [uu___4] in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range + imp.FStarC_TypeChecker_Common.imp_range + FStarC_Errors_Codes.Fatal_FailToResolveImplicitArgument () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___3)) +let (subtype_nosmt_force : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.typ -> Prims.bool) + = + fun env -> + fun t1 -> + fun t2 -> + let uu___ = subtype_nosmt env t1 t2 in + match uu___ with + | FStar_Pervasives_Native.None -> false + | FStar_Pervasives_Native.Some g -> (force_trivial_guard env g; true) +let (teq_force : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.typ -> unit) + = + fun env -> + fun t1 -> + fun t2 -> let uu___ = teq env t1 t2 in force_trivial_guard env uu___ +let (teq_nosmt_force : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.typ -> Prims.bool) + = + fun env -> + fun t1 -> + fun t2 -> + let uu___ = teq_nosmt env t1 t2 in + match uu___ with + | FStar_Pervasives_Native.None -> false + | FStar_Pervasives_Native.Some g -> (force_trivial_guard env g; true) +let (layered_effect_teq : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.typ -> + Prims.string FStar_Pervasives_Native.option -> + FStarC_TypeChecker_Common.guard_t) + = + fun env -> + fun t1 -> + fun t2 -> + fun reason -> + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_LayeredEffectsEqns in + if uu___1 + then + let uu___2 = + if FStarC_Compiler_Util.is_none reason + then "_" + else FStarC_Compiler_Util.must reason in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t2 in + FStarC_Compiler_Util.print3 "Layered Effect (%s) %s = %s\n" + uu___2 uu___3 uu___4 + else ()); + teq env t1 t2 +let (universe_inequality : + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.universe -> FStarC_TypeChecker_Common.guard_t) + = + fun u1 -> + fun u2 -> + let uu___ = + let uu___1 = + Obj.magic + (FStarC_Class_Listlike.cons () + (Obj.magic (FStarC_Compiler_CList.listlike_clist ())) + (u1, u2) + (FStarC_Class_Listlike.empty () + (Obj.magic (FStarC_Compiler_CList.listlike_clist ())))) in + ((Obj.magic + (FStarC_Class_Listlike.empty () + (Obj.magic (FStarC_Compiler_CList.listlike_clist ())))), + uu___1) in + { + FStarC_TypeChecker_Common.guard_f = + (FStarC_TypeChecker_Common.trivial_guard.FStarC_TypeChecker_Common.guard_f); + FStarC_TypeChecker_Common.deferred_to_tac = + (FStarC_TypeChecker_Common.trivial_guard.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (FStarC_TypeChecker_Common.trivial_guard.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = uu___; + FStarC_TypeChecker_Common.implicits = + (FStarC_TypeChecker_Common.trivial_guard.FStarC_TypeChecker_Common.implicits) + } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_Tc.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Tc.ml new file mode 100644 index 00000000000..e4620fee333 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Tc.ml @@ -0,0 +1,6079 @@ +open Prims +let (dbg_TwoPhases : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "TwoPhases" +let (dbg_IdInfoOn : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "IdInfoOn" +let (dbg_Normalize : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Normalize" +let (dbg_UF : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "UF" +let (dbg_LogTypes : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "LogTypes" +let (sigelt_typ : + FStarC_Syntax_Syntax.sigelt -> + FStarC_Syntax_Syntax.typ FStar_Pervasives_Native.option) + = + fun se -> + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = uu___; FStarC_Syntax_Syntax.us = uu___1; + FStarC_Syntax_Syntax.params = uu___2; + FStarC_Syntax_Syntax.num_uniform_params = uu___3; + FStarC_Syntax_Syntax.t = t; FStarC_Syntax_Syntax.mutuals = uu___4; + FStarC_Syntax_Syntax.ds = uu___5; + FStarC_Syntax_Syntax.injective_type_params = uu___6;_} + -> FStar_Pervasives_Native.Some t + | FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = uu___; + FStarC_Syntax_Syntax.us1 = uu___1; FStarC_Syntax_Syntax.t1 = t; + FStarC_Syntax_Syntax.ty_lid = uu___2; + FStarC_Syntax_Syntax.num_ty_params = uu___3; + FStarC_Syntax_Syntax.mutuals1 = uu___4; + FStarC_Syntax_Syntax.injective_type_params1 = uu___5;_} + -> FStar_Pervasives_Native.Some t + | FStarC_Syntax_Syntax.Sig_declare_typ + { FStarC_Syntax_Syntax.lid2 = uu___; + FStarC_Syntax_Syntax.us2 = uu___1; FStarC_Syntax_Syntax.t2 = t;_} + -> FStar_Pervasives_Native.Some t + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (uu___, lb::uu___1); + FStarC_Syntax_Syntax.lids1 = uu___2;_} + -> FStar_Pervasives_Native.Some (lb.FStarC_Syntax_Syntax.lbtyp) + | uu___ -> FStar_Pervasives_Native.None +let (set_hint_correlator : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.sigelt -> FStarC_TypeChecker_Env.env) + = + fun env -> + fun se -> + let tbl = + FStar_Pervasives_Native.snd + env.FStarC_TypeChecker_Env.qtbl_name_and_index in + let get_n lid = + let n_opt = + let uu___ = FStarC_Class_Show.show FStarC_Ident.showable_lident lid in + FStarC_Compiler_Util.smap_try_find tbl uu___ in + if FStarC_Compiler_Util.is_some n_opt + then FStarC_Compiler_Util.must n_opt + else Prims.int_zero in + let typ = + let uu___ = sigelt_typ se in + match uu___ with + | FStar_Pervasives_Native.Some t -> t + | uu___1 -> FStarC_Syntax_Syntax.tun in + let uu___ = FStarC_Options.reuse_hint_for () in + match uu___ with + | FStar_Pervasives_Native.Some l -> + let lid = + let uu___1 = FStarC_TypeChecker_Env.current_module env in + FStarC_Ident.lid_add_suffix uu___1 l in + let uu___1 = + let uu___2 = + let uu___3 = let uu___4 = get_n lid in (lid, typ, uu___4) in + FStar_Pervasives_Native.Some uu___3 in + (uu___2, tbl) in + { + FStarC_TypeChecker_Env.solver = + (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = (env.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = (env.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = uu___1; + FStarC_TypeChecker_Env.normalized_eff_names = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env.FStarC_TypeChecker_Env.missing_decl) + } + | FStar_Pervasives_Native.None -> + let lids = FStarC_Syntax_Util.lids_of_sigelt se in + let lid = + match lids with + | [] -> + let uu___1 = FStarC_TypeChecker_Env.current_module env in + let uu___2 = + let uu___3 = FStarC_GenSym.next_id () in + FStarC_Compiler_Util.string_of_int uu___3 in + FStarC_Ident.lid_add_suffix uu___1 uu___2 + | l::uu___1 -> l in + let uu___1 = + let uu___2 = + let uu___3 = let uu___4 = get_n lid in (lid, typ, uu___4) in + FStar_Pervasives_Native.Some uu___3 in + (uu___2, tbl) in + { + FStarC_TypeChecker_Env.solver = + (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = (env.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = (env.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = uu___1; + FStarC_TypeChecker_Env.normalized_eff_names = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env.FStarC_TypeChecker_Env.missing_decl) + } +let (log : FStarC_TypeChecker_Env.env -> Prims.bool) = + fun env -> + (FStarC_Options.log_types ()) && + (let uu___ = + let uu___1 = FStarC_TypeChecker_Env.current_module env in + FStarC_Ident.lid_equals FStarC_Parser_Const.prims_lid uu___1 in + Prims.op_Negation uu___) +let (tc_type_common : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.tscheme -> + FStarC_Syntax_Syntax.typ -> + FStarC_Compiler_Range_Type.range -> FStarC_Syntax_Syntax.tscheme) + = + fun env -> + fun uu___ -> + fun expected_typ -> + fun r -> + match uu___ with + | (uvs, t) -> + let uu___1 = FStarC_Syntax_Subst.open_univ_vars uvs t in + (match uu___1 with + | (uvs1, t1) -> + let env1 = FStarC_TypeChecker_Env.push_univ_vars env uvs1 in + let t2 = + FStarC_TypeChecker_TcTerm.tc_check_trivial_guard env1 t1 + expected_typ in + if uvs1 = [] + then + let uu___2 = + FStarC_TypeChecker_Generalize.generalize_universes + env1 t2 in + (match uu___2 with + | (uvs2, t3) -> + (FStarC_TypeChecker_Util.check_uvars r t3; + (uvs2, t3))) + else + (let uu___3 = + let uu___4 = + FStarC_TypeChecker_Normalize.remove_uvar_solutions + env1 t2 in + FStarC_Syntax_Subst.close_univ_vars uvs1 uu___4 in + (uvs1, uu___3))) +let (tc_declare_typ : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.tscheme -> + FStarC_Compiler_Range_Type.range -> FStarC_Syntax_Syntax.tscheme) + = + fun env -> + fun ts -> + fun r -> + let uu___ = + let uu___1 = FStarC_Syntax_Util.type_u () in + FStar_Pervasives_Native.fst uu___1 in + tc_type_common env ts uu___ r +let (tc_assume : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.tscheme -> + FStarC_Compiler_Range_Type.range -> FStarC_Syntax_Syntax.tscheme) + = + fun env -> + fun ts -> + fun r -> + let uu___ = + let uu___1 = FStarC_Syntax_Util.type_u () in + FStar_Pervasives_Native.fst uu___1 in + tc_type_common env ts uu___ r +let (tc_decl_attributes : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.sigelt -> FStarC_Syntax_Syntax.sigelt) + = + fun env -> + fun se -> + let uu___ = + let uu___1 = + FStarC_TypeChecker_Env.lid_exists env + FStarC_Parser_Const.attr_substitute_lid in + if uu___1 + then ([], (se.FStarC_Syntax_Syntax.sigattrs)) + else + FStarC_Compiler_List.partition + ((=) FStarC_Syntax_Util.attr_substitute) + se.FStarC_Syntax_Syntax.sigattrs in + match uu___ with + | (blacklisted_attrs, other_attrs) -> + let uu___1 = + FStarC_TypeChecker_TcTerm.tc_attributes env other_attrs in + (match uu___1 with + | (g, other_attrs1) -> + (FStarC_TypeChecker_Rel.force_trivial_guard env g; + { + FStarC_Syntax_Syntax.sigel = + (se.FStarC_Syntax_Syntax.sigel); + FStarC_Syntax_Syntax.sigrng = + (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (FStarC_Compiler_List.op_At blacklisted_attrs + other_attrs1); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se.FStarC_Syntax_Syntax.sigopts) + })) +let (tc_inductive' : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.sigelt Prims.list -> + FStarC_Syntax_Syntax.qualifier Prims.list -> + FStarC_Syntax_Syntax.attribute Prims.list -> + FStarC_Ident.lident Prims.list -> + (FStarC_Syntax_Syntax.sigelt * FStarC_Syntax_Syntax.sigelt + Prims.list)) + = + fun env -> + fun ses -> + fun quals -> + fun attrs -> + fun lids -> + (let uu___1 = FStarC_Compiler_Debug.low () in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_sigelt) ses in + FStarC_Compiler_Util.print1 ">>>>>>>>>>>>>>tc_inductive %s\n" + uu___2 + else ()); + (let ses1 = FStarC_Compiler_List.map (tc_decl_attributes env) ses in + let uu___1 = + FStarC_TypeChecker_TcInductive.check_inductive_well_typedness + env ses1 quals lids in + match uu___1 with + | (sig_bndle, tcs, datas) -> + let sig_bndle1 = + FStarC_TypeChecker_Positivity.mark_uniform_type_parameters + env sig_bndle in + let attrs' = + FStarC_Syntax_Util.remove_attr + FStarC_Parser_Const.erasable_attr attrs in + let data_ops_ses = + let uu___2 = + FStarC_Compiler_List.map + (FStarC_TypeChecker_TcInductive.mk_data_operations + quals attrs' env tcs) datas in + FStarC_Compiler_List.flatten uu___2 in + ((let uu___3 = + (FStarC_Options.no_positivity ()) || + (let uu___4 = FStarC_TypeChecker_Env.should_verify env in + Prims.op_Negation uu___4) in + if uu___3 + then () + else + (let env2 = + FStarC_TypeChecker_Env.push_sigelt env sig_bndle1 in + FStarC_Compiler_List.iter + (fun ty -> + let b = + FStarC_TypeChecker_Positivity.check_strict_positivity + env2 lids ty in + if Prims.op_Negation b + then + let uu___6 = + match ty.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = lid; + FStarC_Syntax_Syntax.us = uu___7; + FStarC_Syntax_Syntax.params = uu___8; + FStarC_Syntax_Syntax.num_uniform_params + = uu___9; + FStarC_Syntax_Syntax.t = uu___10; + FStarC_Syntax_Syntax.mutuals = uu___11; + FStarC_Syntax_Syntax.ds = uu___12; + FStarC_Syntax_Syntax.injective_type_params + = uu___13;_} + -> (lid, (ty.FStarC_Syntax_Syntax.sigrng)) + | uu___7 -> failwith "Impossible!" in + match uu___6 with + | (lid, r) -> + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Ident.string_of_lid lid in + Prims.strcat uu___9 + " does not satisfy the strict positivity condition" in + Prims.strcat "Inductive type " uu___8 in + FStarC_Errors.log_issue + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Error_InductiveTypeNotSatisfyPositivityCondition + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___7) + else ()) tcs; + FStarC_Compiler_List.iter + (fun d -> + let uu___6 = + match d.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = data_lid; + FStarC_Syntax_Syntax.us1 = uu___7; + FStarC_Syntax_Syntax.t1 = uu___8; + FStarC_Syntax_Syntax.ty_lid = ty_lid; + FStarC_Syntax_Syntax.num_ty_params = + uu___9; + FStarC_Syntax_Syntax.mutuals1 = uu___10; + FStarC_Syntax_Syntax.injective_type_params1 + = uu___11;_} + -> (data_lid, ty_lid) + | uu___7 -> failwith "Impossible" in + match uu___6 with + | (data_lid, ty_lid) -> + let uu___7 = + (FStarC_Ident.lid_equals ty_lid + FStarC_Parser_Const.exn_lid) + && + (let uu___8 = + FStarC_TypeChecker_Positivity.check_exn_strict_positivity + env2 data_lid in + Prims.op_Negation uu___8) in + if uu___7 + then + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Ident.string_of_lid data_lid in + Prims.strcat uu___10 + " does not satisfy the positivity condition" in + Prims.strcat "Exception " uu___9 in + FStarC_Errors.log_issue + FStarC_Syntax_Syntax.has_range_sigelt d + FStarC_Errors_Codes.Error_InductiveTypeNotSatisfyPositivityCondition + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___8) + else ()) datas)); + (let skip_haseq = + let skip_prims_type uu___3 = + let lid = + let ty = FStarC_Compiler_List.hd tcs in + match ty.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = lid1; + FStarC_Syntax_Syntax.us = uu___4; + FStarC_Syntax_Syntax.params = uu___5; + FStarC_Syntax_Syntax.num_uniform_params = + uu___6; + FStarC_Syntax_Syntax.t = uu___7; + FStarC_Syntax_Syntax.mutuals = uu___8; + FStarC_Syntax_Syntax.ds = uu___9; + FStarC_Syntax_Syntax.injective_type_params = + uu___10;_} + -> lid1 + | uu___4 -> failwith "Impossible" in + FStarC_Compiler_List.existsb + (fun s -> + let uu___4 = + let uu___5 = FStarC_Ident.ident_of_lid lid in + FStarC_Ident.string_of_id uu___5 in + s = uu___4) + FStarC_TypeChecker_TcInductive.early_prims_inductives in + let is_noeq = + FStarC_Compiler_List.existsb + (fun q -> q = FStarC_Syntax_Syntax.Noeq) quals in + let is_erasable uu___3 = + let uu___4 = + let uu___5 = FStarC_Compiler_List.hd tcs in + uu___5.FStarC_Syntax_Syntax.sigattrs in + FStarC_Syntax_Util.has_attribute uu___4 + FStarC_Parser_Const.erasable_attr in + ((((FStarC_Compiler_List.length tcs) = Prims.int_zero) + || + ((FStarC_Ident.lid_equals + env.FStarC_TypeChecker_Env.curmodule + FStarC_Parser_Const.prims_lid) + && (skip_prims_type ()))) + || is_noeq) + || (is_erasable ()) in + let res = + if skip_haseq + then (sig_bndle1, data_ops_ses) + else + (let is_unopteq = + FStarC_Compiler_List.existsb + (fun q -> q = FStarC_Syntax_Syntax.Unopteq) quals in + let ses2 = + if is_unopteq + then + FStarC_TypeChecker_TcInductive.unoptimized_haseq_scheme + sig_bndle1 tcs datas env + else + FStarC_TypeChecker_TcInductive.optimized_haseq_scheme + sig_bndle1 tcs datas env in + (sig_bndle1, + (FStarC_Compiler_List.op_At ses2 data_ops_ses))) in + res))) +let (tc_inductive : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.sigelt Prims.list -> + FStarC_Syntax_Syntax.qualifier Prims.list -> + FStarC_Syntax_Syntax.attribute Prims.list -> + FStarC_Ident.lident Prims.list -> + (FStarC_Syntax_Syntax.sigelt * FStarC_Syntax_Syntax.sigelt + Prims.list)) + = + fun env -> + fun ses -> + fun quals -> + fun attrs -> + fun lids -> + let env1 = FStarC_TypeChecker_Env.push env "tc_inductive" in + let pop uu___ = + let uu___1 = FStarC_TypeChecker_Env.pop env1 "tc_inductive" in + () in + let uu___ = FStarC_Options.trace_error () in + if uu___ + then + let r = tc_inductive' env1 ses quals attrs lids in (pop (); r) + else + (try + (fun uu___2 -> + match () with + | () -> + let uu___3 = tc_inductive' env1 ses quals attrs lids in + (pop (); uu___3)) () + with | uu___2 -> (pop (); FStarC_Compiler_Effect.raise uu___2)) +let proc_check_with : + 'a . FStarC_Syntax_Syntax.attribute Prims.list -> (unit -> 'a) -> 'a = + fun attrs -> + fun kont -> + let uu___ = + FStarC_Syntax_Util.get_attribute FStarC_Parser_Const.check_with_lid + attrs in + match uu___ with + | FStar_Pervasives_Native.None -> kont () + | FStar_Pervasives_Native.Some ((a1, FStar_Pervasives_Native.None)::[]) + -> + let uu___1 = + FStarC_Syntax_Embeddings_Base.unembed + FStarC_Syntax_Embeddings.e_vconfig a1 + FStarC_Syntax_Embeddings_Base.id_norm_cb in + (match uu___1 with + | FStar_Pervasives_Native.None -> failwith "nah" + | FStar_Pervasives_Native.Some vcfg -> + FStarC_Options.with_saved_options + (fun uu___2 -> FStarC_Options.set_vconfig vcfg; kont ()) + | uu___2 -> failwith "ill-formed `check_with`") +let (handle_postprocess_with_attr : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.attribute Prims.list -> + (FStarC_Syntax_Syntax.attribute Prims.list * FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option)) + = + fun env -> + fun ats -> + let uu___ = + FStarC_Syntax_Util.extract_attr' FStarC_Parser_Const.postprocess_with + ats in + match uu___ with + | FStar_Pervasives_Native.None -> (ats, FStar_Pervasives_Native.None) + | FStar_Pervasives_Native.Some + (ats1, (tau, FStar_Pervasives_Native.None)::[]) -> + (ats1, (FStar_Pervasives_Native.Some tau)) + | FStar_Pervasives_Native.Some (ats1, args) -> + ((let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Ident.showable_lident + FStarC_Parser_Const.postprocess_with in + FStarC_Compiler_Util.format1 "Ill-formed application of `%s`" + uu___3 in + FStarC_Errors.log_issue FStarC_TypeChecker_Env.hasRange_env env + FStarC_Errors_Codes.Warning_UnrecognizedAttribute () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + (ats1, FStar_Pervasives_Native.None)) +let (store_sigopts : + FStarC_Syntax_Syntax.sigelt -> FStarC_Syntax_Syntax.sigelt) = + fun se -> + let uu___ = + let uu___1 = FStarC_Options.get_vconfig () in + FStar_Pervasives_Native.Some uu___1 in + { + FStarC_Syntax_Syntax.sigel = (se.FStarC_Syntax_Syntax.sigel); + FStarC_Syntax_Syntax.sigrng = (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = (se.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = (se.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = uu___ + } +let (tc_decls_knot : + (FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.sigelt Prims.list -> + (FStarC_Syntax_Syntax.sigelt Prims.list * FStarC_TypeChecker_Env.env)) + FStar_Pervasives_Native.option FStarC_Compiler_Effect.ref) + = FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None +let do_two_phases : 'uuuuu . 'uuuuu -> Prims.bool = + fun env -> let uu___ = FStarC_Options.lax () in Prims.op_Negation uu___ +let run_phase1 : 'a . (unit -> 'a) -> 'a = + fun f -> + FStarC_TypeChecker_Core.clear_memo_table (); + (let r = f () in FStarC_TypeChecker_Core.clear_memo_table (); r) +let (tc_sig_let : + FStarC_TypeChecker_Env.env -> + FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.sigelt -> + (Prims.bool * FStarC_Syntax_Syntax.letbinding Prims.list) -> + FStarC_Ident.lident Prims.list -> + (FStarC_Syntax_Syntax.sigelt Prims.list * + FStarC_Syntax_Syntax.sigelt Prims.list * + FStarC_TypeChecker_Env.env)) + = + fun env -> + fun r -> + fun se -> + fun lbs -> + fun lids -> + let env0 = env in + let env1 = FStarC_TypeChecker_Env.set_range env r in + let check_quals_eq l qopt val_q = + match qopt with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.Some val_q + | FStar_Pervasives_Native.Some q' -> + let drop_logic_and_irreducible = + FStarC_Compiler_List.filter + (fun x -> + Prims.op_Negation + ((x = FStarC_Syntax_Syntax.Logic) || + (x = FStarC_Syntax_Syntax.Irreducible))) in + let uu___ = + let uu___1 = + let uu___2 = drop_logic_and_irreducible val_q in + let uu___3 = drop_logic_and_irreducible q' in + (uu___2, uu___3) in + match uu___1 with + | (val_q1, q'1) -> + ((FStarC_Compiler_List.length val_q1) = + (FStarC_Compiler_List.length q'1)) + && + (FStarC_Compiler_List.forall2 + FStarC_Syntax_Util.qualifier_equal val_q1 q'1) in + if uu___ + then FStar_Pervasives_Native.Some q' + else + (let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Errors_Msg.text + "Inconsistent qualifier annotations on" in + let uu___5 = + let uu___6 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident l in + FStarC_Pprint.doc_of_string uu___6 in + FStarC_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Errors_Msg.text "Expected" in + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_qualifier) + val_q in + FStarC_Pprint.arbitrary_string uu___10 in + FStarC_Pprint.squotes uu___9 in + FStarC_Pprint.prefix (Prims.of_int (4)) + Prims.int_one uu___7 uu___8 in + let uu___7 = + let uu___8 = FStarC_Errors_Msg.text "got" in + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_qualifier) + q' in + FStarC_Pprint.arbitrary_string uu___11 in + FStarC_Pprint.squotes uu___10 in + FStarC_Pprint.prefix (Prims.of_int (4)) + Prims.int_one uu___8 uu___9 in + FStarC_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in + [uu___5] in + uu___3 :: uu___4 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_InconsistentQualifierAnnotation + () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___2)) in + let rename_parameters lb = + let rename_in_typ def typ = + let typ1 = FStarC_Syntax_Subst.compress typ in + let def_bs = + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress def in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = binders; + FStarC_Syntax_Syntax.body = uu___1; + FStarC_Syntax_Syntax.rc_opt = uu___2;_} + -> binders + | uu___1 -> [] in + match typ1 with + | { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = val_bs; + FStarC_Syntax_Syntax.comp = c;_}; + FStarC_Syntax_Syntax.pos = r1; + FStarC_Syntax_Syntax.vars = uu___; + FStarC_Syntax_Syntax.hash_code = uu___1;_} -> + let has_auto_name bv = + let uu___2 = + FStarC_Ident.string_of_id + bv.FStarC_Syntax_Syntax.ppname in + FStarC_Compiler_Util.starts_with uu___2 + FStarC_Ident.reserved_prefix in + let rec rename_binders def_bs1 val_bs1 = + match (def_bs1, val_bs1) with + | ([], uu___2) -> val_bs1 + | (uu___2, []) -> val_bs1 + | ({ FStarC_Syntax_Syntax.binder_bv = body_bv; + FStarC_Syntax_Syntax.binder_qual = uu___2; + FStarC_Syntax_Syntax.binder_positivity = uu___3; + FStarC_Syntax_Syntax.binder_attrs = uu___4;_}::bt, + val_b::vt) -> + let uu___5 = + let uu___6 = + let uu___7 = has_auto_name body_bv in + let uu___8 = + has_auto_name + val_b.FStarC_Syntax_Syntax.binder_bv in + (uu___7, uu___8) in + match uu___6 with + | (true, uu___7) -> val_b + | (false, true) -> + let uu___7 = + let uu___8 = + val_b.FStarC_Syntax_Syntax.binder_bv in + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Ident.string_of_id + body_bv.FStarC_Syntax_Syntax.ppname in + let uu___12 = + FStarC_Ident.range_of_id + (val_b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.ppname in + (uu___11, uu___12) in + FStarC_Ident.mk_ident uu___10 in + { + FStarC_Syntax_Syntax.ppname = uu___9; + FStarC_Syntax_Syntax.index = + (uu___8.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = + (uu___8.FStarC_Syntax_Syntax.sort) + } in + { + FStarC_Syntax_Syntax.binder_bv = uu___7; + FStarC_Syntax_Syntax.binder_qual = + (val_b.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity = + (val_b.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs = + (val_b.FStarC_Syntax_Syntax.binder_attrs) + } + | (false, false) -> val_b in + let uu___6 = rename_binders bt vt in uu___5 :: + uu___6 in + let uu___2 = + let uu___3 = + let uu___4 = rename_binders def_bs val_bs in + { + FStarC_Syntax_Syntax.bs1 = uu___4; + FStarC_Syntax_Syntax.comp = c + } in + FStarC_Syntax_Syntax.Tm_arrow uu___3 in + FStarC_Syntax_Syntax.mk uu___2 r1 + | uu___ -> typ1 in + let uu___ = + rename_in_typ lb.FStarC_Syntax_Syntax.lbdef + lb.FStarC_Syntax_Syntax.lbtyp in + { + FStarC_Syntax_Syntax.lbname = + (lb.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = uu___; + FStarC_Syntax_Syntax.lbeff = (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = (lb.FStarC_Syntax_Syntax.lbdef); + FStarC_Syntax_Syntax.lbattrs = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = (lb.FStarC_Syntax_Syntax.lbpos) + } in + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun lb -> + match uu___1 with + | (gen, lbs1, quals_opt) -> + let lbname = + FStarC_Compiler_Util.right + lb.FStarC_Syntax_Syntax.lbname in + let uu___2 = + let uu___3 = + FStarC_TypeChecker_Env.try_lookup_val_decl env1 + (lbname.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + match uu___3 with + | FStar_Pervasives_Native.None -> + (gen, lb, quals_opt) + | FStar_Pervasives_Native.Some + ((uvs, tval), quals) -> + let quals_opt1 = + check_quals_eq + (lbname.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + quals_opt quals in + let def = + match (lb.FStarC_Syntax_Syntax.lbtyp).FStarC_Syntax_Syntax.n + with + | FStarC_Syntax_Syntax.Tm_unknown -> + lb.FStarC_Syntax_Syntax.lbdef + | uu___4 -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_ascribed + { + FStarC_Syntax_Syntax.tm = + (lb.FStarC_Syntax_Syntax.lbdef); + FStarC_Syntax_Syntax.asc = + ((FStar_Pervasives.Inl + (lb.FStarC_Syntax_Syntax.lbtyp)), + FStar_Pervasives_Native.None, + false); + FStarC_Syntax_Syntax.eff_opt = + FStar_Pervasives_Native.None + }) + (lb.FStarC_Syntax_Syntax.lbdef).FStarC_Syntax_Syntax.pos in + (if + (lb.FStarC_Syntax_Syntax.lbunivs <> []) && + ((FStarC_Compiler_List.length + lb.FStarC_Syntax_Syntax.lbunivs) + <> (FStarC_Compiler_List.length uvs)) + then + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_IncoherentInlineUniverse + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Inline universes are incoherent with annotation from val declaration") + else (); + (let uu___5 = + FStarC_Syntax_Syntax.mk_lb + ((FStar_Pervasives.Inr lbname), uvs, + FStarC_Parser_Const.effect_Tot_lid, + tval, def, + (lb.FStarC_Syntax_Syntax.lbattrs), + (lb.FStarC_Syntax_Syntax.lbpos)) in + (false, uu___5, quals_opt1))) in + (match uu___2 with + | (gen1, lb1, quals_opt1) -> + (gen1, (lb1 :: lbs1), quals_opt1))) + (true, [], + (if se.FStarC_Syntax_Syntax.sigquals = [] + then FStar_Pervasives_Native.None + else + FStar_Pervasives_Native.Some + (se.FStarC_Syntax_Syntax.sigquals))) + (FStar_Pervasives_Native.snd lbs) in + match uu___ with + | (should_generalize, lbs', quals_opt) -> + (FStarC_Syntax_Util.check_mutual_universes lbs'; + (let quals = + match quals_opt with + | FStar_Pervasives_Native.None -> + [FStarC_Syntax_Syntax.Visible_default] + | FStar_Pervasives_Native.Some q -> + let uu___2 = + FStarC_Compiler_Util.for_some + (fun uu___3 -> + match uu___3 with + | FStarC_Syntax_Syntax.Irreducible -> true + | FStarC_Syntax_Syntax.Visible_default -> true + | FStarC_Syntax_Syntax.Unfold_for_unification_and_vcgen + -> true + | uu___4 -> false) q in + if uu___2 + then q + else FStarC_Syntax_Syntax.Visible_default :: q in + let lbs'1 = FStarC_Compiler_List.rev lbs' in + let uu___2 = + let uu___3 = + FStarC_Syntax_Util.extract_attr' + FStarC_Parser_Const.preprocess_with + se.FStarC_Syntax_Syntax.sigattrs in + match uu___3 with + | FStar_Pervasives_Native.None -> + ((se.FStarC_Syntax_Syntax.sigattrs), + FStar_Pervasives_Native.None) + | FStar_Pervasives_Native.Some + (ats, (tau, FStar_Pervasives_Native.None)::[]) -> + (ats, (FStar_Pervasives_Native.Some tau)) + | FStar_Pervasives_Native.Some (ats, args) -> + (FStarC_Errors.log_issue + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Warning_UnrecognizedAttribute + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Ill-formed application of `preprocess_with`"); + ((se.FStarC_Syntax_Syntax.sigattrs), + FStar_Pervasives_Native.None)) in + match uu___2 with + | (attrs, pre_tau) -> + let se1 = + { + FStarC_Syntax_Syntax.sigel = + (se.FStarC_Syntax_Syntax.sigel); + FStarC_Syntax_Syntax.sigrng = + (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = attrs; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se.FStarC_Syntax_Syntax.sigopts) + } in + let preprocess_lb tau lb = + let lbdef = + FStarC_TypeChecker_Env.preprocess env1 tau + lb.FStarC_Syntax_Syntax.lbdef in + (let uu___4 = + (FStarC_Compiler_Debug.medium ()) || + (FStarC_Compiler_Effect.op_Bang dbg_TwoPhases) in + if uu___4 + then + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term lbdef in + FStarC_Compiler_Util.print1 + "lb preprocessed into: %s\n" uu___5 + else ()); + { + FStarC_Syntax_Syntax.lbname = + (lb.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = + (lb.FStarC_Syntax_Syntax.lbtyp); + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = lbdef; + FStarC_Syntax_Syntax.lbattrs = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + } in + let lbs'2 = + match pre_tau with + | FStar_Pervasives_Native.Some tau -> + FStarC_Compiler_List.map (preprocess_lb tau) + lbs'1 + | FStar_Pervasives_Native.None -> lbs'1 in + let e = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_constant + FStarC_Const.Const_unit) r in + { + FStarC_Syntax_Syntax.lbs = + ((FStar_Pervasives_Native.fst lbs), lbs'2); + FStarC_Syntax_Syntax.body1 = uu___5 + } in + FStarC_Syntax_Syntax.Tm_let uu___4 in + FStarC_Syntax_Syntax.mk uu___3 r in + let env' = + { + FStarC_TypeChecker_Env.solver = + (env1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + should_generalize; + FStarC_TypeChecker_Env.letrecs = + (env1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = true; + FStarC_TypeChecker_Env.check_uvars = + (env1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env1.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env1.FStarC_TypeChecker_Env.missing_decl) + } in + let e1 = + let uu___3 = do_two_phases env' in + if uu___3 + then + run_phase1 + (fun uu___4 -> + let drop_lbtyp e_lax = + let uu___5 = + let uu___6 = + FStarC_Syntax_Subst.compress e_lax in + uu___6.FStarC_Syntax_Syntax.n in + match uu___5 with + | FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = + (false, lb::[]); + FStarC_Syntax_Syntax.body1 = e2;_} + -> + let lb_unannotated = + let uu___6 = + let uu___7 = + FStarC_Syntax_Subst.compress e in + uu___7.FStarC_Syntax_Syntax.n in + match uu___6 with + | FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = + (uu___7, lb1::[]); + FStarC_Syntax_Syntax.body1 = + uu___8;_} + -> + let uu___9 = + let uu___10 = + FStarC_Syntax_Subst.compress + lb1.FStarC_Syntax_Syntax.lbtyp in + uu___10.FStarC_Syntax_Syntax.n in + (match uu___9 with + | FStarC_Syntax_Syntax.Tm_unknown + -> true + | uu___10 -> false) + | uu___7 -> + failwith + "Impossible: first phase lb and second phase lb differ in structure!" in + if lb_unannotated + then + { + FStarC_Syntax_Syntax.n = + (FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = + (false, + [{ + FStarC_Syntax_Syntax.lbname + = + (lb.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs + = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp + = + FStarC_Syntax_Syntax.tun; + FStarC_Syntax_Syntax.lbeff + = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef + = + (lb.FStarC_Syntax_Syntax.lbdef); + FStarC_Syntax_Syntax.lbattrs + = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos + = + (lb.FStarC_Syntax_Syntax.lbpos) + }]); + FStarC_Syntax_Syntax.body1 = + e2 + }); + FStarC_Syntax_Syntax.pos = + (e_lax.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = + (e_lax.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (e_lax.FStarC_Syntax_Syntax.hash_code) + } + else e_lax + | FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = + (true, lbs1); + FStarC_Syntax_Syntax.body1 = uu___6;_} + -> + (FStarC_Syntax_Util.check_mutual_universes + lbs1; + e_lax) in + let e2 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_TypeChecker_Env.current_module + env1 in + FStarC_Ident.string_of_lid uu___7 in + FStar_Pervasives_Native.Some uu___6 in + FStarC_Profiling.profile + (fun uu___6 -> + let uu___7 = + FStarC_TypeChecker_TcTerm.tc_maybe_toplevel_term + { + FStarC_TypeChecker_Env.solver = + (env'.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env'.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule + = + (env'.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env'.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig + = + (env'.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache + = + (env'.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env'.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ + = + (env'.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env'.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env'.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp + = + (env'.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env'.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize + = + (env'.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env'.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level + = + (env'.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars + = + (env'.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict + = + (env'.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env'.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + true; + FStarC_TypeChecker_Env.lax_universes + = + (env'.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + true; + FStarC_TypeChecker_Env.failhard = + (env'.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking + = + (env'.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping + = + (env'.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics + = + (env'.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env'.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env'.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (env'.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of + = + (env'.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env'.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force + = + (env'.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (env'.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (env'.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (env'.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths + = + (env'.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env'.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook + = + (env'.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (env'.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env'.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess + = + (env'.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess + = + (env'.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info + = + (env'.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env'.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env'.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env'.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab + = + (env'.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (env'.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (env'.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (env'.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (env'.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check + = + (env'.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl + = + (env'.FStarC_TypeChecker_Env.missing_decl) + } e in + match uu___7 with + | (e3, uu___8, uu___9) -> e3) uu___5 + "FStarC.TypeChecker.Tc.tc_sig_let-tc-phase1" in + (let uu___6 = + (FStarC_Compiler_Debug.medium ()) || + (FStarC_Compiler_Effect.op_Bang + dbg_TwoPhases) in + if uu___6 + then + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term e2 in + FStarC_Compiler_Util.print1 + "Let binding after phase 1, before removing uvars: %s\n" + uu___7 + else ()); + (let e3 = + let uu___6 = + FStarC_TypeChecker_Normalize.remove_uvar_solutions + env' e2 in + drop_lbtyp uu___6 in + (let uu___7 = + (FStarC_Compiler_Debug.medium ()) || + (FStarC_Compiler_Effect.op_Bang + dbg_TwoPhases) in + if uu___7 + then + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term e3 in + FStarC_Compiler_Util.print1 + "Let binding after phase 1, uvars removed: %s\n" + uu___8 + else ()); + e3)) + else e in + let uu___3 = + handle_postprocess_with_attr env1 + se1.FStarC_Syntax_Syntax.sigattrs in + (match uu___3 with + | (attrs1, post_tau) -> + let se2 = + { + FStarC_Syntax_Syntax.sigel = + (se1.FStarC_Syntax_Syntax.sigel); + FStarC_Syntax_Syntax.sigrng = + (se1.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se1.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se1.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = attrs1; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se1.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se1.FStarC_Syntax_Syntax.sigopts) + } in + let postprocess_lb tau lb = + let uu___4 = + FStarC_Syntax_Subst.univ_var_opening + lb.FStarC_Syntax_Syntax.lbunivs in + match uu___4 with + | (s, univnames) -> + let lbdef = + FStarC_Syntax_Subst.subst s + lb.FStarC_Syntax_Syntax.lbdef in + let lbtyp = + FStarC_Syntax_Subst.subst s + lb.FStarC_Syntax_Syntax.lbtyp in + let env2 = + FStarC_TypeChecker_Env.push_univ_vars env1 + univnames in + let lbdef1 = + FStarC_TypeChecker_Env.postprocess env2 + tau lbtyp lbdef in + let lbdef2 = + FStarC_Syntax_Subst.close_univ_vars + univnames lbdef1 in + { + FStarC_Syntax_Syntax.lbname = + (lb.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = + (lb.FStarC_Syntax_Syntax.lbtyp); + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = lbdef2; + FStarC_Syntax_Syntax.lbattrs = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + } in + let env'1 = + let uu___4 = + let uu___5 = FStarC_Syntax_Subst.compress e1 in + uu___5.FStarC_Syntax_Syntax.n in + match uu___4 with + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = lbs1; + FStarC_Syntax_Syntax.body1 = uu___5;_} + -> + let se3 = + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_let + { + FStarC_Syntax_Syntax.lbs1 = lbs1; + FStarC_Syntax_Syntax.lids1 = lids + }); + FStarC_Syntax_Syntax.sigrng = + (se2.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se2.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se2.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se2.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = + (se2.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se2.FStarC_Syntax_Syntax.sigopts) + } in + set_hint_correlator env' se3 + | uu___5 -> failwith "no way, not a let?" in + (FStarC_Errors.stop_if_err (); + (let r1 = + let should_generalize1 = + let uu___5 = do_two_phases env'1 in + Prims.op_Negation uu___5 in + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_TypeChecker_Env.current_module + env1 in + FStarC_Ident.string_of_lid uu___7 in + FStar_Pervasives_Native.Some uu___6 in + FStarC_Profiling.profile + (fun uu___6 -> + FStarC_TypeChecker_TcTerm.tc_maybe_toplevel_term + { + FStarC_TypeChecker_Env.solver = + (env'1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env'1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env'1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env'1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env'1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env'1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env'1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env'1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env'1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env'1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp + = + (env'1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env'1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + should_generalize1; + FStarC_TypeChecker_Env.letrecs = + (env'1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env'1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env'1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict + = + (env'1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env'1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env'1.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes + = + (env'1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env'1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env'1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env'1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping + = + (env'1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env'1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env'1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env'1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (env'1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env'1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env'1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force + = + (env'1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (env'1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (env'1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (env'1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths + = + (env'1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env'1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env'1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (env'1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env'1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env'1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env'1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info + = + (env'1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env'1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env'1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env'1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab + = + (env'1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (env'1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (env'1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (env'1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (env'1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env'1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env'1.FStarC_TypeChecker_Env.missing_decl) + } e1) uu___5 + "FStarC.TypeChecker.Tc.tc_sig_let-tc-phase2" in + let uu___5 = + match r1 with + | ({ + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = lbs1; + FStarC_Syntax_Syntax.body1 = e2;_}; + FStarC_Syntax_Syntax.pos = uu___6; + FStarC_Syntax_Syntax.vars = uu___7; + FStarC_Syntax_Syntax.hash_code = uu___8;_}, + uu___9, g) when + FStarC_TypeChecker_Env.is_trivial g -> + (FStarC_Syntax_Util.check_mutual_universes + (FStar_Pervasives_Native.snd lbs1); + (let lbs2 = + let uu___11 = + FStarC_Compiler_List.map + rename_parameters + (FStar_Pervasives_Native.snd lbs1) in + ((FStar_Pervasives_Native.fst lbs1), + uu___11) in + let lbs3 = + let uu___11 = + match post_tau with + | FStar_Pervasives_Native.Some tau + -> + FStarC_Compiler_List.map + (postprocess_lb tau) + (FStar_Pervasives_Native.snd + lbs2) + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.snd lbs2 in + ((FStar_Pervasives_Native.fst lbs2), + uu___11) in + let quals1 = + match e2.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 = + uu___11; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_desugared + (FStarC_Syntax_Syntax.Masked_effect);_} + -> + FStarC_Syntax_Syntax.HasMaskedEffect + :: quals + | uu___11 -> quals in + ({ + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_let + { + FStarC_Syntax_Syntax.lbs1 = + lbs3; + FStarC_Syntax_Syntax.lids1 = + lids + }); + FStarC_Syntax_Syntax.sigrng = + (se2.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + quals1; + FStarC_Syntax_Syntax.sigmeta = + (se2.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se2.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = + (se2.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se2.FStarC_Syntax_Syntax.sigopts) + }, lbs3))) + | uu___6 -> + failwith + "impossible (typechecking should preserve Tm_let)" in + match uu___5 with + | (se3, lbs1) -> + ((let uu___7 = + FStarC_Syntax_Util.has_attribute + se3.FStarC_Syntax_Syntax.sigattrs + FStarC_Parser_Const.no_subtping_attr_lid in + if uu___7 + then + let env'2 = + { + FStarC_TypeChecker_Env.solver = + (env'1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env'1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env'1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env'1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env'1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env'1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env'1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ + = + (env'1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env'1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env'1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp + = + (env'1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env'1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env'1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env'1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env'1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env'1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict + = true; + FStarC_TypeChecker_Env.is_iface = + (env'1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env'1.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes + = + (env'1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env'1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env'1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env'1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping + = + (env'1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env'1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env'1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env'1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (env'1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env'1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env'1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force + = + (env'1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (env'1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (env'1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (env'1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths + = + (env'1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env'1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env'1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (env'1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env'1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env'1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env'1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info + = + (env'1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env'1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env'1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env'1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab + = + (env'1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (env'1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (env'1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (env'1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (env'1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env'1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl + = + (env'1.FStarC_TypeChecker_Env.missing_decl) + } in + let err s pos = + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + pos + FStarC_Errors_Codes.Fatal_InconsistentQualifierAnnotation + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic s) in + FStarC_Compiler_List.iter + (fun lb -> + let uu___8 = + let uu___9 = + FStarC_Syntax_Util.is_lemma + lb.FStarC_Syntax_Syntax.lbtyp in + Prims.op_Negation uu___9 in + if uu___8 + then + err + "no_subtype annotation on a non-lemma" + lb.FStarC_Syntax_Syntax.lbpos + else + (let lid_opt = + let uu___10 = + let uu___11 = + FStarC_Syntax_Free.fvars + lb.FStarC_Syntax_Syntax.lbtyp in + FStarC_Class_Setlike.elems + () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Syntax_Syntax.ord_fv)) + (Obj.magic uu___11) in + FStarC_Compiler_List.tryFind + (fun lid -> + let uu___11 = + (let uu___12 = + let uu___13 = + FStarC_Ident.path_of_lid + lid in + FStarC_Compiler_List.hd + uu___13 in + uu___12 = "Prims") || + (FStarC_Ident.lid_equals + lid + FStarC_Parser_Const.pattern_lid) in + Prims.op_Negation uu___11) + uu___10 in + if + FStarC_Compiler_Util.is_some + lid_opt + then + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Compiler_Util.must + lid_opt in + FStarC_Ident.string_of_lid + uu___12 in + FStarC_Compiler_Util.format1 + "%s is not allowed in no_subtyping lemmas (only prims symbols)" + uu___11 in + err uu___10 + lb.FStarC_Syntax_Syntax.lbpos + else + (let uu___11 = + FStarC_Syntax_Util.type_u + () in + match uu___11 with + | (t, uu___12) -> + let uu___13 = + FStarC_Syntax_Subst.open_univ_vars + lb.FStarC_Syntax_Syntax.lbunivs + lb.FStarC_Syntax_Syntax.lbtyp in + (match uu___13 with + | (uvs, lbtyp) -> + let uu___14 = + let uu___15 = + FStarC_TypeChecker_Env.push_univ_vars + env'2 uvs in + FStarC_TypeChecker_TcTerm.tc_check_tot_or_gtot_term + uu___15 lbtyp t + (FStar_Pervasives_Native.Some + "checking no_subtype annotation") in + (match uu___14 with + | (uu___15, + uu___16, g) -> + FStarC_TypeChecker_Rel.force_trivial_guard + env'2 g))))) + (FStar_Pervasives_Native.snd lbs1) + else ()); + FStarC_Compiler_List.iter + (fun lb -> + let fv = + FStarC_Compiler_Util.right + lb.FStarC_Syntax_Syntax.lbname in + FStarC_TypeChecker_Env.insert_fv_info + env1 fv + lb.FStarC_Syntax_Syntax.lbtyp) + (FStar_Pervasives_Native.snd lbs1); + (let uu___9 = log env1 in + if uu___9 + then + let uu___10 = + let uu___11 = + FStarC_Compiler_List.map + (fun lb -> + let should_log = + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + FStarC_Compiler_Util.right + lb.FStarC_Syntax_Syntax.lbname in + uu___15.FStarC_Syntax_Syntax.fv_name in + uu___14.FStarC_Syntax_Syntax.v in + FStarC_TypeChecker_Env.try_lookup_val_decl + env1 uu___13 in + match uu___12 with + | FStar_Pervasives_Native.None + -> true + | uu___13 -> false in + if should_log + then + let uu___12 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_either + FStarC_Syntax_Print.showable_bv + FStarC_Syntax_Print.showable_fv) + lb.FStarC_Syntax_Syntax.lbname in + let uu___13 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + lb.FStarC_Syntax_Syntax.lbtyp in + FStarC_Compiler_Util.format2 + "let %s : %s" uu___12 + uu___13 + else "") + (FStar_Pervasives_Native.snd lbs1) in + FStarC_Compiler_String.concat "\n" + uu___11 in + FStarC_Compiler_Util.print1 "%s\n" + uu___10 + else ()); + ([se3], [], env0))))))) +let (tc_decl' : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.sigelt -> + (FStarC_Syntax_Syntax.sigelt Prims.list * FStarC_Syntax_Syntax.sigelt + Prims.list * FStarC_TypeChecker_Env.env)) + = + fun env0 -> + fun se -> + let env = env0 in + let se1 = + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_fail uu___ -> se + | uu___ -> tc_decl_attributes env se in + FStarC_TypeChecker_Quals.check_sigelt_quals_pre env se1; + proc_check_with se1.FStarC_Syntax_Syntax.sigattrs + (fun uu___1 -> + let r = se1.FStarC_Syntax_Syntax.sigrng in + let se2 = + let uu___2 = FStarC_Options.record_options () in + if uu___2 then store_sigopts se1 else se1 in + match se2.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_inductive_typ uu___2 -> + failwith "Impossible bare data-constructor" + | FStarC_Syntax_Syntax.Sig_datacon uu___2 -> + failwith "Impossible bare data-constructor" + | FStarC_Syntax_Syntax.Sig_fail + { FStarC_Syntax_Syntax.errs = uu___2; + FStarC_Syntax_Syntax.fail_in_lax = false; + FStarC_Syntax_Syntax.ses1 = uu___3;_} + when env.FStarC_TypeChecker_Env.admit -> + ((let uu___5 = FStarC_Compiler_Debug.any () in + if uu___5 + then + let uu___6 = + FStarC_Syntax_Print.sigelt_to_string_short se2 in + FStarC_Compiler_Util.print1 + "Skipping %s since env.admit=true and this is not an expect_lax_failure\n" + uu___6 + else ()); + ([], [], env)) + | FStarC_Syntax_Syntax.Sig_fail + { FStarC_Syntax_Syntax.errs = expected_errors; + FStarC_Syntax_Syntax.fail_in_lax = lax; + FStarC_Syntax_Syntax.ses1 = ses;_} + -> + let env' = + if lax + then + { + FStarC_TypeChecker_Env.solver = + (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = true; + FStarC_TypeChecker_Env.lax_universes = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env.FStarC_TypeChecker_Env.missing_decl) + } + else env in + let env'1 = FStarC_TypeChecker_Env.push env' "expect_failure" in + ((let uu___3 = FStarC_Compiler_Debug.low () in + if uu___3 + then + let uu___4 = + let uu___5 = + FStarC_Compiler_List.map + FStarC_Compiler_Util.string_of_int expected_errors in + FStarC_Compiler_String.concat "; " uu___5 in + FStarC_Compiler_Util.print1 ">> Expecting errors: [%s]\n" + uu___4 + else ()); + (let uu___3 = + FStarC_Errors.catch_errors + (fun uu___4 -> + FStarC_Options.with_saved_options + (fun uu___5 -> + let uu___6 = + let uu___7 = + FStarC_Compiler_Effect.op_Bang tc_decls_knot in + FStarC_Compiler_Util.must uu___7 in + uu___6 env'1 ses)) in + match uu___3 with + | (errs, uu___4) -> + ((let uu___6 = + (FStarC_Options.print_expected_failures ()) || + (FStarC_Compiler_Debug.low ()) in + if uu___6 + then + (FStarC_Compiler_Util.print_string + ">> Got issues: [\n"; + FStarC_Compiler_List.iter FStarC_Errors.print_issue + errs; + FStarC_Compiler_Util.print_string ">>]\n") + else ()); + (let uu___6 = + FStarC_TypeChecker_Env.pop env'1 "expect_failure" in + let actual_errors = + FStarC_Compiler_List.concatMap + (fun i -> + FStarC_Common.list_of_option + i.FStarC_Errors.issue_number) errs in + (match errs with + | [] -> + (FStarC_Compiler_List.iter + FStarC_Errors.print_issue errs; + (let uu___9 = + let uu___10 = + FStarC_Errors_Msg.text + "This top-level definition was expected to fail, but it succeeded" in + [uu___10] in + FStarC_Errors.log_issue + FStarC_Syntax_Syntax.has_range_sigelt se2 + FStarC_Errors_Codes.Error_DidNotFail () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___9))) + | uu___8 -> + if expected_errors <> [] + then + let uu___9 = + FStarC_Errors.find_multiset_discrepancy + expected_errors actual_errors in + (match uu___9 with + | FStar_Pervasives_Native.None -> () + | FStar_Pervasives_Native.Some (e, n1, n2) -> + (FStarC_Compiler_List.iter + FStarC_Errors.print_issue errs; + (let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_Errors_Msg.text + "This top-level definition was expected to raise error codes" in + let uu___15 = + FStarC_Class_PP.pp + (FStarC_Class_PP.pp_list + FStarC_Class_PP.pp_int) + expected_errors in + FStarC_Pprint.prefix + (Prims.of_int (2)) Prims.int_one + uu___14 uu___15 in + let uu___14 = + let uu___15 = + let uu___16 = + FStarC_Errors_Msg.text + "but it raised" in + let uu___17 = + FStarC_Class_PP.pp + (FStarC_Class_PP.pp_list + FStarC_Class_PP.pp_int) + actual_errors in + FStarC_Pprint.prefix + (Prims.of_int (2)) + Prims.int_one uu___16 uu___17 in + FStarC_Pprint.op_Hat_Hat uu___15 + FStarC_Pprint.dot in + FStarC_Pprint.op_Hat_Slash_Hat + uu___13 uu___14 in + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + e in + let uu___17 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + n2 in + let uu___18 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + n1 in + FStarC_Compiler_Util.format3 + "Error #%s was raised %s times, instead of %s." + uu___16 uu___17 uu___18 in + FStarC_Errors_Msg.text uu___15 in + [uu___14] in + uu___12 :: uu___13 in + FStarC_Errors.log_issue + FStarC_Syntax_Syntax.has_range_sigelt + se2 + FStarC_Errors_Codes.Error_DidNotFail + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___11)))) + else ()); + ([], [], env))))) + | FStarC_Syntax_Syntax.Sig_bundle + { FStarC_Syntax_Syntax.ses = ses; + FStarC_Syntax_Syntax.lids = lids;_} + -> + let env1 = FStarC_TypeChecker_Env.set_range env r in + let ses1 = + let uu___2 = do_two_phases env1 in + if uu___2 + then + run_phase1 + (fun uu___3 -> + let ses2 = + let uu___4 = + let uu___5 = + let uu___6 = + tc_inductive + { + FStarC_TypeChecker_Env.solver = + (env1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = true; + FStarC_TypeChecker_Env.lax_universes = + (env1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = true; + FStarC_TypeChecker_Env.failhard = + (env1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (env1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (env1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (env1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (env1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (env1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (env1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (env1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (env1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (env1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env1.FStarC_TypeChecker_Env.missing_decl) + } ses se2.FStarC_Syntax_Syntax.sigquals + se2.FStarC_Syntax_Syntax.sigattrs lids in + FStar_Pervasives_Native.fst uu___6 in + FStarC_TypeChecker_Normalize.elim_uvars env1 + uu___5 in + FStarC_Syntax_Util.ses_of_sigbundle uu___4 in + (let uu___5 = + (FStarC_Compiler_Debug.medium ()) || + (FStarC_Compiler_Effect.op_Bang dbg_TwoPhases) in + if uu___5 + then + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_sigelt + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_bundle + { + FStarC_Syntax_Syntax.ses = ses2; + FStarC_Syntax_Syntax.lids = lids + }); + FStarC_Syntax_Syntax.sigrng = + (se2.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se2.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se2.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se2.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se2.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se2.FStarC_Syntax_Syntax.sigopts) + } in + FStarC_Compiler_Util.print1 + "Inductive after phase 1: %s\n" uu___6 + else ()); + ses2) + else ses in + let uu___2 = + tc_inductive env1 ses1 se2.FStarC_Syntax_Syntax.sigquals + se2.FStarC_Syntax_Syntax.sigattrs lids in + (match uu___2 with + | (sigbndle, projectors_ses) -> + let sigbndle1 = + { + FStarC_Syntax_Syntax.sigel = + (sigbndle.FStarC_Syntax_Syntax.sigel); + FStarC_Syntax_Syntax.sigrng = + (sigbndle.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (sigbndle.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (sigbndle.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se2.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (sigbndle.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (sigbndle.FStarC_Syntax_Syntax.sigopts) + } in + ([sigbndle1], projectors_ses, env0)) + | FStarC_Syntax_Syntax.Sig_pragma p -> + (FStarC_Syntax_Util.process_pragma p r; ([se2], [], env0)) + | FStarC_Syntax_Syntax.Sig_new_effect ne -> + let is_unelaborated_dm4f = + match ne.FStarC_Syntax_Syntax.combinators with + | FStarC_Syntax_Syntax.DM4F_eff combs -> + let uu___2 = + FStarC_Syntax_Subst.compress + (FStar_Pervasives_Native.snd + combs.FStarC_Syntax_Syntax.ret_wp) in + (match uu___2 with + | { + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Tm_unknown; + FStarC_Syntax_Syntax.pos = uu___3; + FStarC_Syntax_Syntax.vars = uu___4; + FStarC_Syntax_Syntax.hash_code = uu___5;_} -> true + | uu___3 -> false) + | uu___2 -> false in + if is_unelaborated_dm4f + then + let env1 = FStarC_TypeChecker_Env.set_range env r in + let uu___2 = + FStarC_TypeChecker_TcEffect.dmff_cps_and_elaborate env1 ne in + (match uu___2 with + | (ses, ne1, lift_from_pure_opt) -> + let effect_and_lift_ses = + match lift_from_pure_opt with + | FStar_Pervasives_Native.Some lift -> + [{ + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_new_effect ne1); + FStarC_Syntax_Syntax.sigrng = + (se2.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se2.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se2.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se2.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se2.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se2.FStarC_Syntax_Syntax.sigopts) + }; + lift] + | FStar_Pervasives_Native.None -> + [{ + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_new_effect ne1); + FStarC_Syntax_Syntax.sigrng = + (se2.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se2.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se2.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se2.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se2.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se2.FStarC_Syntax_Syntax.sigopts) + }] in + let effect_and_lift_ses1 = + FStarC_Compiler_List.map + (fun sigelt -> + { + FStarC_Syntax_Syntax.sigel = + (sigelt.FStarC_Syntax_Syntax.sigel); + FStarC_Syntax_Syntax.sigrng = + (sigelt.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (sigelt.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (let uu___3 = + sigelt.FStarC_Syntax_Syntax.sigmeta in + { + FStarC_Syntax_Syntax.sigmeta_active = + (uu___3.FStarC_Syntax_Syntax.sigmeta_active); + FStarC_Syntax_Syntax.sigmeta_fact_db_ids + = + (uu___3.FStarC_Syntax_Syntax.sigmeta_fact_db_ids); + FStarC_Syntax_Syntax.sigmeta_admit = true; + FStarC_Syntax_Syntax.sigmeta_spliced = + (uu___3.FStarC_Syntax_Syntax.sigmeta_spliced); + FStarC_Syntax_Syntax.sigmeta_already_checked + = + (uu___3.FStarC_Syntax_Syntax.sigmeta_already_checked); + FStarC_Syntax_Syntax.sigmeta_extension_data + = + (uu___3.FStarC_Syntax_Syntax.sigmeta_extension_data) + }); + FStarC_Syntax_Syntax.sigattrs = + (sigelt.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (sigelt.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (sigelt.FStarC_Syntax_Syntax.sigopts) + }) effect_and_lift_ses in + ([], + (FStarC_Compiler_List.op_At ses effect_and_lift_ses1), + env0)) + else + (let ne1 = + let uu___3 = do_two_phases env in + if uu___3 + then + run_phase1 + (fun uu___4 -> + let ne2 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_TypeChecker_TcEffect.tc_eff_decl + { + FStarC_TypeChecker_Env.solver = + (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp + = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = true; + FStarC_TypeChecker_Env.lax_universes = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = true; + FStarC_TypeChecker_Env.failhard = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping + = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force + = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths + = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info + = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab + = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env.FStarC_TypeChecker_Env.missing_decl) + } ne se2.FStarC_Syntax_Syntax.sigquals + se2.FStarC_Syntax_Syntax.sigattrs in + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_new_effect + uu___7); + FStarC_Syntax_Syntax.sigrng = + (se2.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se2.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se2.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se2.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = + (se2.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se2.FStarC_Syntax_Syntax.sigopts) + } in + FStarC_TypeChecker_Normalize.elim_uvars env + uu___6 in + FStarC_Syntax_Util.eff_decl_of_new_effect uu___5 in + (let uu___6 = + (FStarC_Compiler_Debug.medium ()) || + (FStarC_Compiler_Effect.op_Bang dbg_TwoPhases) in + if uu___6 + then + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_sigelt + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_new_effect + ne2); + FStarC_Syntax_Syntax.sigrng = + (se2.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se2.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se2.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se2.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = + (se2.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se2.FStarC_Syntax_Syntax.sigopts) + } in + FStarC_Compiler_Util.print1 + "Effect decl after phase 1: %s\n" uu___7 + else ()); + ne2) + else ne in + let ne2 = + FStarC_TypeChecker_TcEffect.tc_eff_decl env ne1 + se2.FStarC_Syntax_Syntax.sigquals + se2.FStarC_Syntax_Syntax.sigattrs in + let se3 = + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_new_effect ne2); + FStarC_Syntax_Syntax.sigrng = + (se2.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se2.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se2.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se2.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se2.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se2.FStarC_Syntax_Syntax.sigopts) + } in + ([se3], [], env0)) + | FStarC_Syntax_Syntax.Sig_sub_effect sub -> + let sub1 = FStarC_TypeChecker_TcEffect.tc_lift env sub r in + let se3 = + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_sub_effect sub1); + FStarC_Syntax_Syntax.sigrng = + (se2.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se2.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se2.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se2.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se2.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se2.FStarC_Syntax_Syntax.sigopts) + } in + ([se3], [], env) + | FStarC_Syntax_Syntax.Sig_effect_abbrev + { FStarC_Syntax_Syntax.lid4 = lid; + FStarC_Syntax_Syntax.us4 = uvs; + FStarC_Syntax_Syntax.bs2 = tps; + FStarC_Syntax_Syntax.comp1 = c; + FStarC_Syntax_Syntax.cflags = flags;_} + -> + let uu___2 = + let uu___3 = do_two_phases env in + if uu___3 + then + run_phase1 + (fun uu___4 -> + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_TypeChecker_TcEffect.tc_effect_abbrev + { + FStarC_TypeChecker_Env.solver = + (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = true; + FStarC_TypeChecker_Env.lax_universes = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = true; + FStarC_TypeChecker_Env.failhard = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env.FStarC_TypeChecker_Env.missing_decl) + } (lid, uvs, tps, c) r in + match uu___7 with + | (lid1, uvs1, tps1, c1) -> + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_effect_abbrev + { + FStarC_Syntax_Syntax.lid4 = lid1; + FStarC_Syntax_Syntax.us4 = uvs1; + FStarC_Syntax_Syntax.bs2 = tps1; + FStarC_Syntax_Syntax.comp1 = c1; + FStarC_Syntax_Syntax.cflags = flags + }); + FStarC_Syntax_Syntax.sigrng = + (se2.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se2.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se2.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se2.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se2.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se2.FStarC_Syntax_Syntax.sigopts) + } in + FStarC_TypeChecker_Normalize.elim_uvars env uu___6 in + match uu___5.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_effect_abbrev + { FStarC_Syntax_Syntax.lid4 = lid1; + FStarC_Syntax_Syntax.us4 = uvs1; + FStarC_Syntax_Syntax.bs2 = tps1; + FStarC_Syntax_Syntax.comp1 = c1; + FStarC_Syntax_Syntax.cflags = uu___6;_} + -> (lid1, uvs1, tps1, c1) + | uu___6 -> + failwith + "Did not expect Sig_effect_abbrev to not be one after phase 1") + else (lid, uvs, tps, c) in + (match uu___2 with + | (lid1, uvs1, tps1, c1) -> + let uu___3 = + FStarC_TypeChecker_TcEffect.tc_effect_abbrev env + (lid1, uvs1, tps1, c1) r in + (match uu___3 with + | (lid2, uvs2, tps2, c2) -> + let se3 = + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_effect_abbrev + { + FStarC_Syntax_Syntax.lid4 = lid2; + FStarC_Syntax_Syntax.us4 = uvs2; + FStarC_Syntax_Syntax.bs2 = tps2; + FStarC_Syntax_Syntax.comp1 = c2; + FStarC_Syntax_Syntax.cflags = flags + }); + FStarC_Syntax_Syntax.sigrng = + (se2.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se2.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se2.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se2.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se2.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se2.FStarC_Syntax_Syntax.sigopts) + } in + ([se3], [], env0))) + | FStarC_Syntax_Syntax.Sig_declare_typ uu___2 when + FStarC_Compiler_Util.for_some + (fun uu___3 -> + match uu___3 with + | FStarC_Syntax_Syntax.OnlyName -> true + | uu___4 -> false) se2.FStarC_Syntax_Syntax.sigquals + -> ([], [], env0) + | FStarC_Syntax_Syntax.Sig_let uu___2 when + FStarC_Compiler_Util.for_some + (fun uu___3 -> + match uu___3 with + | FStarC_Syntax_Syntax.OnlyName -> true + | uu___4 -> false) se2.FStarC_Syntax_Syntax.sigquals + -> ([], [], env0) + | FStarC_Syntax_Syntax.Sig_declare_typ + { FStarC_Syntax_Syntax.lid2 = lid; + FStarC_Syntax_Syntax.us2 = uvs; + FStarC_Syntax_Syntax.t2 = t;_} + -> + ((let uu___3 = FStarC_TypeChecker_Env.lid_exists env lid in + if uu___3 + then + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident lid in + FStarC_Compiler_Util.format1 + "Top-level declaration %s for a name that is already used in this module." + uu___7 in + FStarC_Errors_Msg.text uu___6 in + let uu___6 = + let uu___7 = + FStarC_Errors_Msg.text + "Top-level declarations must be unique in their module." in + [uu___7] in + uu___5 :: uu___6 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_AlreadyDefinedTopLevelDeclaration + () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___4) + else ()); + (let env1 = FStarC_TypeChecker_Env.set_range env r in + let uu___3 = + let uu___4 = do_two_phases env1 in + if uu___4 + then + run_phase1 + (fun uu___5 -> + let uu___6 = + tc_declare_typ + { + FStarC_TypeChecker_Env.solver = + (env1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = true; + FStarC_TypeChecker_Env.lax_universes = + (env1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = true; + FStarC_TypeChecker_Env.failhard = + (env1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (env1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (env1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (env1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env1.FStarC_TypeChecker_Env.missing_decl) + } (uvs, t) se2.FStarC_Syntax_Syntax.sigrng in + match uu___6 with + | (uvs1, t1) -> + ((let uu___8 = + (FStarC_Compiler_Debug.medium ()) || + (FStarC_Compiler_Effect.op_Bang + dbg_TwoPhases) in + if uu___8 + then + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t1 in + let uu___10 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Ident.showable_ident) uvs1 in + FStarC_Compiler_Util.print2 + "Val declaration after phase 1: %s and uvs: %s\n" + uu___9 uu___10 + else ()); + (uvs1, t1))) + else (uvs, t) in + match uu___3 with + | (uvs1, t1) -> + let uu___4 = + tc_declare_typ env1 (uvs1, t1) + se2.FStarC_Syntax_Syntax.sigrng in + (match uu___4 with + | (uvs2, t2) -> + ([{ + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_declare_typ + { + FStarC_Syntax_Syntax.lid2 = lid; + FStarC_Syntax_Syntax.us2 = uvs2; + FStarC_Syntax_Syntax.t2 = t2 + }); + FStarC_Syntax_Syntax.sigrng = + (se2.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se2.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se2.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se2.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se2.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se2.FStarC_Syntax_Syntax.sigopts) + }], [], env0)))) + | FStarC_Syntax_Syntax.Sig_assume + { FStarC_Syntax_Syntax.lid3 = lid; + FStarC_Syntax_Syntax.us3 = uvs; + FStarC_Syntax_Syntax.phi1 = t;_} + -> + (if + Prims.op_Negation + (FStarC_Compiler_List.contains + FStarC_Syntax_Syntax.InternalAssumption + se2.FStarC_Syntax_Syntax.sigquals) + then + (let uu___3 = + let uu___4 = + FStarC_Class_Show.show FStarC_Ident.showable_lident + lid in + FStarC_Compiler_Util.format1 + "Admitting a top-level assumption %s" uu___4 in + FStarC_Errors.log_issue + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Warning_WarnOnUse () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___3)) + else (); + (let env1 = FStarC_TypeChecker_Env.set_range env r in + let uu___3 = + let uu___4 = do_two_phases env1 in + if uu___4 + then + run_phase1 + (fun uu___5 -> + let uu___6 = + tc_assume + { + FStarC_TypeChecker_Env.solver = + (env1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = true; + FStarC_TypeChecker_Env.lax_universes = + (env1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = true; + FStarC_TypeChecker_Env.failhard = + (env1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (env1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (env1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (env1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env1.FStarC_TypeChecker_Env.missing_decl) + } (uvs, t) se2.FStarC_Syntax_Syntax.sigrng in + match uu___6 with + | (uvs1, t1) -> + ((let uu___8 = + (FStarC_Compiler_Debug.medium ()) || + (FStarC_Compiler_Effect.op_Bang + dbg_TwoPhases) in + if uu___8 + then + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t1 in + let uu___10 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Ident.showable_ident) uvs1 in + FStarC_Compiler_Util.print2 + "Assume after phase 1: %s and uvs: %s\n" + uu___9 uu___10 + else ()); + (uvs1, t1))) + else (uvs, t) in + match uu___3 with + | (uvs1, t1) -> + let uu___4 = + tc_assume env1 (uvs1, t1) + se2.FStarC_Syntax_Syntax.sigrng in + (match uu___4 with + | (uvs2, t2) -> + ([{ + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_assume + { + FStarC_Syntax_Syntax.lid3 = lid; + FStarC_Syntax_Syntax.us3 = uvs2; + FStarC_Syntax_Syntax.phi1 = t2 + }); + FStarC_Syntax_Syntax.sigrng = + (se2.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se2.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se2.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se2.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se2.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se2.FStarC_Syntax_Syntax.sigopts) + }], [], env0)))) + | FStarC_Syntax_Syntax.Sig_splice + { FStarC_Syntax_Syntax.is_typed = is_typed; + FStarC_Syntax_Syntax.lids2 = lids; + FStarC_Syntax_Syntax.tac = t;_} + -> + ((let uu___3 = FStarC_Compiler_Debug.any () in + if uu___3 + then + let uu___4 = + FStarC_Ident.string_of_lid + env.FStarC_TypeChecker_Env.curmodule in + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + t in + let uu___6 = FStarC_Compiler_Util.string_of_bool is_typed in + FStarC_Compiler_Util.print3 + "%s: Found splice of (%s) with is_typed: %s\n" uu___4 + uu___5 uu___6 + else ()); + (let ses = + env.FStarC_TypeChecker_Env.splice env is_typed lids t + se2.FStarC_Syntax_Syntax.sigrng in + let ses1 = + if is_typed + then + let sigquals = + match se2.FStarC_Syntax_Syntax.sigquals with + | [] -> [FStarC_Syntax_Syntax.Visible_default] + | qs -> qs in + FStarC_Compiler_List.map + (fun sp -> + { + FStarC_Syntax_Syntax.sigel = + (sp.FStarC_Syntax_Syntax.sigel); + FStarC_Syntax_Syntax.sigrng = + (sp.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (FStarC_Compiler_List.op_At sigquals + sp.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (sp.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (FStarC_Compiler_List.op_At + se2.FStarC_Syntax_Syntax.sigattrs + sp.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (sp.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (sp.FStarC_Syntax_Syntax.sigopts) + }) ses + else ses in + let ses2 = + FStarC_Compiler_List.map + (fun se3 -> + if + env.FStarC_TypeChecker_Env.is_iface && + (FStarC_Syntax_Syntax.uu___is_Sig_declare_typ + se3.FStarC_Syntax_Syntax.sigel) + then + let uu___3 = + let uu___4 = + FStarC_Compiler_List.filter + (fun q -> + q <> FStarC_Syntax_Syntax.Irreducible) + se3.FStarC_Syntax_Syntax.sigquals in + FStarC_Syntax_Syntax.Assumption :: uu___4 in + { + FStarC_Syntax_Syntax.sigel = + (se3.FStarC_Syntax_Syntax.sigel); + FStarC_Syntax_Syntax.sigrng = + (se3.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = uu___3; + FStarC_Syntax_Syntax.sigmeta = + (se3.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se3.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se3.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se3.FStarC_Syntax_Syntax.sigopts) + } + else se3) ses1 in + let ses3 = + FStarC_Compiler_List.map + (fun se3 -> + { + FStarC_Syntax_Syntax.sigel = + (se3.FStarC_Syntax_Syntax.sigel); + FStarC_Syntax_Syntax.sigrng = + (se3.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se3.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (let uu___3 = se3.FStarC_Syntax_Syntax.sigmeta in + { + FStarC_Syntax_Syntax.sigmeta_active = + (uu___3.FStarC_Syntax_Syntax.sigmeta_active); + FStarC_Syntax_Syntax.sigmeta_fact_db_ids = + (uu___3.FStarC_Syntax_Syntax.sigmeta_fact_db_ids); + FStarC_Syntax_Syntax.sigmeta_admit = + (uu___3.FStarC_Syntax_Syntax.sigmeta_admit); + FStarC_Syntax_Syntax.sigmeta_spliced = true; + FStarC_Syntax_Syntax.sigmeta_already_checked = + (uu___3.FStarC_Syntax_Syntax.sigmeta_already_checked); + FStarC_Syntax_Syntax.sigmeta_extension_data = + (uu___3.FStarC_Syntax_Syntax.sigmeta_extension_data) + }); + FStarC_Syntax_Syntax.sigattrs = + (se3.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se3.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se3.FStarC_Syntax_Syntax.sigopts) + }) ses2 in + let dsenv = + FStarC_Compiler_List.fold_left + FStarC_Syntax_DsEnv.push_sigelt_force + env.FStarC_TypeChecker_Env.dsenv ses3 in + let env1 = + { + FStarC_TypeChecker_Env.solver = + (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = dsenv; + FStarC_TypeChecker_Env.nbe = + (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env.FStarC_TypeChecker_Env.missing_decl) + } in + (let uu___4 = FStarC_Compiler_Debug.low () in + if uu___4 + then + let uu___5 = + let uu___6 = + FStarC_Compiler_List.map + (FStarC_Class_Show.show + FStarC_Syntax_Print.showable_sigelt) ses3 in + FStarC_Compiler_String.concat "\n" uu___6 in + FStarC_Compiler_Util.print1 + "Splice returned sigelts {\n%s\n}\n" uu___5 + else ()); + ([], ses3, env1))) + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = lbs; + FStarC_Syntax_Syntax.lids1 = lids;_} + -> + let uu___2 = + let uu___3 = + let uu___4 = FStarC_TypeChecker_Env.current_module env in + FStarC_Ident.string_of_lid uu___4 in + FStar_Pervasives_Native.Some uu___3 in + FStarC_Profiling.profile + (fun uu___3 -> tc_sig_let env r se2 lbs lids) uu___2 + "FStarC.TypeChecker.Tc.tc_sig_let" + | FStarC_Syntax_Syntax.Sig_polymonadic_bind + { FStarC_Syntax_Syntax.m_lid = m; + FStarC_Syntax_Syntax.n_lid = n; + FStarC_Syntax_Syntax.p_lid = p; + FStarC_Syntax_Syntax.tm3 = t; + FStarC_Syntax_Syntax.typ = uu___2; + FStarC_Syntax_Syntax.kind1 = uu___3;_} + -> + let t1 = + let uu___4 = do_two_phases env in + if uu___4 + then + run_phase1 + (fun uu___5 -> + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_TypeChecker_TcEffect.tc_polymonadic_bind + { + FStarC_TypeChecker_Env.solver = + (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = true; + FStarC_TypeChecker_Env.lax_universes = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = true; + FStarC_TypeChecker_Env.failhard = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env.FStarC_TypeChecker_Env.missing_decl) + } m n p t in + match uu___9 with + | (t2, ty, uu___10) -> + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_polymonadic_bind + { + FStarC_Syntax_Syntax.m_lid = m; + FStarC_Syntax_Syntax.n_lid = n; + FStarC_Syntax_Syntax.p_lid = p; + FStarC_Syntax_Syntax.tm3 = t2; + FStarC_Syntax_Syntax.typ = ty; + FStarC_Syntax_Syntax.kind1 = + FStar_Pervasives_Native.None + }); + FStarC_Syntax_Syntax.sigrng = + (se2.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se2.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se2.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se2.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = + (se2.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se2.FStarC_Syntax_Syntax.sigopts) + } in + FStarC_TypeChecker_Normalize.elim_uvars env + uu___8 in + match uu___7.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_polymonadic_bind + { FStarC_Syntax_Syntax.m_lid = uu___8; + FStarC_Syntax_Syntax.n_lid = uu___9; + FStarC_Syntax_Syntax.p_lid = uu___10; + FStarC_Syntax_Syntax.tm3 = t2; + FStarC_Syntax_Syntax.typ = ty; + FStarC_Syntax_Syntax.kind1 = uu___11;_} + -> (t2, ty) + | uu___8 -> + failwith + "Impossible! tc for Sig_polymonadic_bind must be a Sig_polymonadic_bind" in + match uu___6 with + | (t2, ty) -> + ((let uu___8 = + (FStarC_Compiler_Debug.medium ()) || + (FStarC_Compiler_Effect.op_Bang + dbg_TwoPhases) in + if uu___8 + then + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_sigelt + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_polymonadic_bind + { + FStarC_Syntax_Syntax.m_lid = m; + FStarC_Syntax_Syntax.n_lid = n; + FStarC_Syntax_Syntax.p_lid = p; + FStarC_Syntax_Syntax.tm3 = t2; + FStarC_Syntax_Syntax.typ = ty; + FStarC_Syntax_Syntax.kind1 = + FStar_Pervasives_Native.None + }); + FStarC_Syntax_Syntax.sigrng = + (se2.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se2.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se2.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se2.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = + (se2.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se2.FStarC_Syntax_Syntax.sigopts) + } in + FStarC_Compiler_Util.print1 + "Polymonadic bind after phase 1: %s\n" + uu___9 + else ()); + t2)) + else t in + let uu___4 = + FStarC_TypeChecker_TcEffect.tc_polymonadic_bind env m n p t1 in + (match uu___4 with + | (t2, ty, k) -> + let se3 = + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_polymonadic_bind + { + FStarC_Syntax_Syntax.m_lid = m; + FStarC_Syntax_Syntax.n_lid = n; + FStarC_Syntax_Syntax.p_lid = p; + FStarC_Syntax_Syntax.tm3 = t2; + FStarC_Syntax_Syntax.typ = ty; + FStarC_Syntax_Syntax.kind1 = + (FStar_Pervasives_Native.Some k) + }); + FStarC_Syntax_Syntax.sigrng = + (se2.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se2.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se2.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se2.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se2.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se2.FStarC_Syntax_Syntax.sigopts) + } in + ([se3], [], env0)) + | FStarC_Syntax_Syntax.Sig_polymonadic_subcomp + { FStarC_Syntax_Syntax.m_lid1 = m; + FStarC_Syntax_Syntax.n_lid1 = n; + FStarC_Syntax_Syntax.tm4 = t; + FStarC_Syntax_Syntax.typ1 = uu___2; + FStarC_Syntax_Syntax.kind2 = uu___3;_} + -> + let t1 = + let uu___4 = do_two_phases env in + if uu___4 + then + run_phase1 + (fun uu___5 -> + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_TypeChecker_TcEffect.tc_polymonadic_subcomp + { + FStarC_TypeChecker_Env.solver = + (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = true; + FStarC_TypeChecker_Env.lax_universes = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = true; + FStarC_TypeChecker_Env.failhard = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env.FStarC_TypeChecker_Env.missing_decl) + } m n t in + match uu___9 with + | (t2, ty, uu___10) -> + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_polymonadic_subcomp + { + FStarC_Syntax_Syntax.m_lid1 = m; + FStarC_Syntax_Syntax.n_lid1 = n; + FStarC_Syntax_Syntax.tm4 = t2; + FStarC_Syntax_Syntax.typ1 = ty; + FStarC_Syntax_Syntax.kind2 = + FStar_Pervasives_Native.None + }); + FStarC_Syntax_Syntax.sigrng = + (se2.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se2.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se2.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se2.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = + (se2.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se2.FStarC_Syntax_Syntax.sigopts) + } in + FStarC_TypeChecker_Normalize.elim_uvars env + uu___8 in + match uu___7.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_polymonadic_subcomp + { FStarC_Syntax_Syntax.m_lid1 = uu___8; + FStarC_Syntax_Syntax.n_lid1 = uu___9; + FStarC_Syntax_Syntax.tm4 = t2; + FStarC_Syntax_Syntax.typ1 = ty; + FStarC_Syntax_Syntax.kind2 = uu___10;_} + -> (t2, ty) + | uu___8 -> + failwith + "Impossible! tc for Sig_polymonadic_subcomp must be a Sig_polymonadic_subcomp" in + match uu___6 with + | (t2, ty) -> + ((let uu___8 = + (FStarC_Compiler_Debug.medium ()) || + (FStarC_Compiler_Effect.op_Bang + dbg_TwoPhases) in + if uu___8 + then + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_sigelt + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_polymonadic_subcomp + { + FStarC_Syntax_Syntax.m_lid1 = m; + FStarC_Syntax_Syntax.n_lid1 = n; + FStarC_Syntax_Syntax.tm4 = t2; + FStarC_Syntax_Syntax.typ1 = ty; + FStarC_Syntax_Syntax.kind2 = + FStar_Pervasives_Native.None + }); + FStarC_Syntax_Syntax.sigrng = + (se2.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se2.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se2.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se2.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = + (se2.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se2.FStarC_Syntax_Syntax.sigopts) + } in + FStarC_Compiler_Util.print1 + "Polymonadic subcomp after phase 1: %s\n" + uu___9 + else ()); + t2)) + else t in + let uu___4 = + FStarC_TypeChecker_TcEffect.tc_polymonadic_subcomp env m n + t1 in + (match uu___4 with + | (t2, ty, k) -> + let se3 = + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_polymonadic_subcomp + { + FStarC_Syntax_Syntax.m_lid1 = m; + FStarC_Syntax_Syntax.n_lid1 = n; + FStarC_Syntax_Syntax.tm4 = t2; + FStarC_Syntax_Syntax.typ1 = ty; + FStarC_Syntax_Syntax.kind2 = + (FStar_Pervasives_Native.Some k) + }); + FStarC_Syntax_Syntax.sigrng = + (se2.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se2.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se2.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se2.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se2.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se2.FStarC_Syntax_Syntax.sigopts) + } in + ([se3], [], env0))) +let (tc_decl : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.sigelt -> + (FStarC_Syntax_Syntax.sigelt Prims.list * FStarC_Syntax_Syntax.sigelt + Prims.list * FStarC_TypeChecker_Env.env)) + = + fun env -> + fun se -> + FStarC_GenSym.reset_gensym (); + (let env0 = env in + let env1 = set_hint_correlator env se in + let env2 = + let uu___1 = FStarC_Options.admit_smt_queries () in + if uu___1 + then + { + FStarC_TypeChecker_Env.solver = + (env1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = true; + FStarC_TypeChecker_Env.lax_universes = + (env1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = (env1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env1.FStarC_TypeChecker_Env.missing_decl) + } + else env1 in + (let uu___2 = FStarC_Compiler_Debug.any () in + if uu___2 + then + let uu___3 = FStarC_Syntax_Print.sigelt_to_string_short se in + FStarC_Compiler_Util.print1 "Processing %s\n" uu___3 + else ()); + (let uu___3 = FStarC_Compiler_Debug.medium () in + if uu___3 + then + let uu___4 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + env2.FStarC_TypeChecker_Env.admit in + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_sigelt se in + FStarC_Compiler_Util.print2 ">>>>>>>>>>>>>>tc_decl admit=%s %s\n" + uu___4 uu___5 + else ()); + (let result = + if + (se.FStarC_Syntax_Syntax.sigmeta).FStarC_Syntax_Syntax.sigmeta_already_checked + then ([se], [], env2) + else + if + (se.FStarC_Syntax_Syntax.sigmeta).FStarC_Syntax_Syntax.sigmeta_admit + then + (let result1 = + tc_decl' + { + FStarC_TypeChecker_Env.solver = + (env2.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env2.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env2.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env2.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env2.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env2.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env2.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env2.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env2.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env2.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env2.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env2.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env2.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env2.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env2.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env2.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env2.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env2.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = true; + FStarC_TypeChecker_Env.lax_universes = + (env2.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env2.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env2.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env2.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env2.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env2.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env2.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env2.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env2.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env2.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env2.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env2.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env2.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env2.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env2.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env2.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env2.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env2.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env2.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env2.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env2.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env2.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env2.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env2.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env2.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env2.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env2.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env2.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env2.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env2.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env2.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env2.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env2.FStarC_TypeChecker_Env.missing_decl) + } se in + result1) + else tc_decl' env2 se in + (let uu___4 = result in + match uu___4 with + | (ses, uu___5, uu___6) -> + FStarC_Compiler_List.iter + (FStarC_TypeChecker_Quals.check_sigelt_quals_post env2) ses); + (match () with + | () -> + let result1 = + let uu___4 = result in + match uu___4 with + | (ses, ses_e, env3) -> + (ses, ses_e, + { + FStarC_TypeChecker_Env.solver = + (env3.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env3.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env3.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env3.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env3.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env3.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env3.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env3.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env3.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env3.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env3.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env3.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env3.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env3.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env3.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env3.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env3.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env3.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env0.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env3.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env3.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env3.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env3.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env3.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env3.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env3.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env3.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env3.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env3.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env3.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env3.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env3.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env3.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env3.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env3.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env3.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env3.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env3.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env3.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env3.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env3.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env3.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env3.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env3.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env3.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env3.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env3.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env3.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env3.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env3.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env3.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env3.FStarC_TypeChecker_Env.missing_decl) + }) in + result1))) +let (add_sigelt_to_env : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.sigelt -> Prims.bool -> FStarC_TypeChecker_Env.env) + = + fun env -> + fun se -> + fun from_cache -> + (let uu___1 = FStarC_Compiler_Debug.low () in + if uu___1 + then + let uu___2 = FStarC_Syntax_Print.sigelt_to_string_short se in + let uu___3 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) from_cache in + FStarC_Compiler_Util.print2 + ">>>>>>>>>>>>>>Adding top-level decl to environment: %s (from_cache:%s)\n" + uu___2 uu___3 + else ()); + (match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_inductive_typ uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_sigelt + se in + FStarC_Compiler_Util.format1 + "add_sigelt_to_env: unexpected bare type/data constructor: %s" + uu___3 in + FStarC_Errors.raise_error FStarC_Syntax_Syntax.has_range_sigelt + se FStarC_Errors_Codes.Fatal_UnexpectedInductivetype () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2) + | FStarC_Syntax_Syntax.Sig_datacon uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_sigelt + se in + FStarC_Compiler_Util.format1 + "add_sigelt_to_env: unexpected bare type/data constructor: %s" + uu___3 in + FStarC_Errors.raise_error FStarC_Syntax_Syntax.has_range_sigelt + se FStarC_Errors_Codes.Fatal_UnexpectedInductivetype () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2) + | FStarC_Syntax_Syntax.Sig_declare_typ uu___1 when + FStarC_Compiler_Util.for_some + (fun uu___2 -> + match uu___2 with + | FStarC_Syntax_Syntax.OnlyName -> true + | uu___3 -> false) se.FStarC_Syntax_Syntax.sigquals + -> env + | FStarC_Syntax_Syntax.Sig_let uu___1 when + FStarC_Compiler_Util.for_some + (fun uu___2 -> + match uu___2 with + | FStarC_Syntax_Syntax.OnlyName -> true + | uu___3 -> false) se.FStarC_Syntax_Syntax.sigquals + -> env + | uu___1 -> + let env1 = FStarC_TypeChecker_Env.push_sigelt env se in + (match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_pragma + (FStarC_Syntax_Syntax.ShowOptions) -> + ((let uu___3 = + let uu___4 = FStarC_Errors_Msg.text "Option state:" in + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Options.show_options () in + FStarC_Pprint.arbitrary_string uu___7 in + [uu___6] in + uu___4 :: uu___5 in + FStarC_Errors.info FStarC_Syntax_Syntax.has_range_sigelt + se () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___3)); + env1) + | FStarC_Syntax_Syntax.Sig_pragma + (FStarC_Syntax_Syntax.PushOptions uu___2) -> + if from_cache + then env1 + else + (let uu___4 = FStarC_Options.using_facts_from () in + { + FStarC_TypeChecker_Env.solver = + (env1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env1.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = uu___4; + FStarC_TypeChecker_Env.synth_hook = + (env1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env1.FStarC_TypeChecker_Env.missing_decl) + }) + | FStarC_Syntax_Syntax.Sig_pragma + (FStarC_Syntax_Syntax.PopOptions) -> + if from_cache + then env1 + else + (let uu___3 = FStarC_Options.using_facts_from () in + { + FStarC_TypeChecker_Env.solver = + (env1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env1.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = uu___3; + FStarC_TypeChecker_Env.synth_hook = + (env1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env1.FStarC_TypeChecker_Env.missing_decl) + }) + | FStarC_Syntax_Syntax.Sig_pragma + (FStarC_Syntax_Syntax.SetOptions uu___2) -> + if from_cache + then env1 + else + (let uu___4 = FStarC_Options.using_facts_from () in + { + FStarC_TypeChecker_Env.solver = + (env1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env1.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = uu___4; + FStarC_TypeChecker_Env.synth_hook = + (env1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env1.FStarC_TypeChecker_Env.missing_decl) + }) + | FStarC_Syntax_Syntax.Sig_pragma + (FStarC_Syntax_Syntax.ResetOptions uu___2) -> + if from_cache + then env1 + else + (let uu___4 = FStarC_Options.using_facts_from () in + { + FStarC_TypeChecker_Env.solver = + (env1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env1.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = uu___4; + FStarC_TypeChecker_Env.synth_hook = + (env1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env1.FStarC_TypeChecker_Env.missing_decl) + }) + | FStarC_Syntax_Syntax.Sig_pragma + (FStarC_Syntax_Syntax.RestartSolver) -> + if from_cache || env1.FStarC_TypeChecker_Env.flychecking + then env1 + else + ((env1.FStarC_TypeChecker_Env.solver).FStarC_TypeChecker_Env.refresh + (FStar_Pervasives_Native.Some + (env1.FStarC_TypeChecker_Env.proof_ns)); + env1) + | FStarC_Syntax_Syntax.Sig_pragma + (FStarC_Syntax_Syntax.PrintEffectsGraph) -> + ((let uu___3 = + FStarC_TypeChecker_Env.print_effects_graph env1 in + FStarC_Compiler_Util.write_file "effects.graph" uu___3); + env1) + | FStarC_Syntax_Syntax.Sig_new_effect ne -> + let env2 = + FStarC_TypeChecker_Env.push_new_effect env1 + (ne, (se.FStarC_Syntax_Syntax.sigquals)) in + FStarC_Compiler_List.fold_left + (fun env3 -> + fun a -> + let uu___2 = + FStarC_Syntax_Util.action_as_lb + ne.FStarC_Syntax_Syntax.mname a + (a.FStarC_Syntax_Syntax.action_defn).FStarC_Syntax_Syntax.pos in + FStarC_TypeChecker_Env.push_sigelt env3 uu___2) env2 + ne.FStarC_Syntax_Syntax.actions + | FStarC_Syntax_Syntax.Sig_sub_effect sub -> + FStarC_TypeChecker_Util.update_env_sub_eff env1 sub + se.FStarC_Syntax_Syntax.sigrng + | FStarC_Syntax_Syntax.Sig_polymonadic_bind + { FStarC_Syntax_Syntax.m_lid = m; + FStarC_Syntax_Syntax.n_lid = n; + FStarC_Syntax_Syntax.p_lid = p; + FStarC_Syntax_Syntax.tm3 = uu___2; + FStarC_Syntax_Syntax.typ = ty; + FStarC_Syntax_Syntax.kind1 = k;_} + -> + let uu___3 = FStarC_Compiler_Util.must k in + FStarC_TypeChecker_Util.update_env_polymonadic_bind env1 m + n p ty uu___3 + | FStarC_Syntax_Syntax.Sig_polymonadic_subcomp + { FStarC_Syntax_Syntax.m_lid1 = m; + FStarC_Syntax_Syntax.n_lid1 = n; + FStarC_Syntax_Syntax.tm4 = uu___2; + FStarC_Syntax_Syntax.typ1 = ty; + FStarC_Syntax_Syntax.kind2 = k;_} + -> + let uu___3 = + let uu___4 = FStarC_Compiler_Util.must k in (ty, uu___4) in + FStarC_TypeChecker_Env.add_polymonadic_subcomp env1 m n + uu___3 + | uu___2 -> env1)) +let (compress_and_norm : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.typ FStar_Pervasives_Native.option) + = + fun env -> + fun t -> + let uu___ = FStarC_Syntax_Compress.deep_compress_if_no_uvars t in + match uu___ with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some t1 -> + let uu___1 = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.AllowUnboundUniverses; + FStarC_TypeChecker_Env.CheckNoUvars; + FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.DoNotUnfoldPureLets; + FStarC_TypeChecker_Env.CompressUvars; + FStarC_TypeChecker_Env.Exclude FStarC_TypeChecker_Env.Zeta; + FStarC_TypeChecker_Env.Exclude FStarC_TypeChecker_Env.Iota; + FStarC_TypeChecker_Env.NoFullNorm] env t1 in + FStar_Pervasives_Native.Some uu___1 +let (tc_decls : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.sigelt Prims.list -> + (FStarC_Syntax_Syntax.sigelt Prims.list * FStarC_TypeChecker_Env.env)) + = + fun env -> + fun ses -> + let rec process_one_decl uu___ se = + match uu___ with + | (ses1, env1) -> + (FStarC_Compiler_Effect.op_Colon_Equals + FStarC_Errors.fallback_range + (FStar_Pervasives_Native.Some (se.FStarC_Syntax_Syntax.sigrng)); + (let uu___2 = + env1.FStarC_TypeChecker_Env.flychecking && + (FStarC_Compiler_Debug.any ()) in + if uu___2 + then ((ses1, env1), []) + else + ((let uu___5 = FStarC_Compiler_Debug.low () in + if uu___5 + then + let uu___6 = + FStarC_Class_Tagged.tag_of + FStarC_Syntax_Syntax.tagged_sigelt se in + let uu___7 = + FStarC_Syntax_Print.sigelt_to_string_short se in + FStarC_Compiler_Util.print2 + ">>>>>>>>>>>>>>Checking top-level %s decl %s\n" uu___6 + uu___7 + else ()); + (let uu___6 = FStarC_Options.ide_id_info_off () in + if uu___6 + then FStarC_TypeChecker_Env.toggle_id_info env1 false + else ()); + (let uu___7 = FStarC_Compiler_Effect.op_Bang dbg_IdInfoOn in + if uu___7 + then FStarC_TypeChecker_Env.toggle_id_info env1 true + else ()); + (let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Syntax_Print.sigelt_to_string_short se in + FStarC_Compiler_Util.format2 + "While typechecking the %stop-level declaration `%s`" + (if + (se.FStarC_Syntax_Syntax.sigmeta).FStarC_Syntax_Syntax.sigmeta_spliced + then "(spliced) " + else "") uu___9 in + FStarC_Errors.with_ctx uu___8 + (fun uu___9 -> tc_decl env1 se) in + match uu___7 with + | (ses', ses_elaborated, env2) -> + let ses'1 = + FStarC_Compiler_List.map + (fun se1 -> + (let uu___9 = + FStarC_Compiler_Effect.op_Bang dbg_UF in + if uu___9 + then + let uu___10 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_sigelt se1 in + FStarC_Compiler_Util.print1 + "About to elim vars from %s\n" uu___10 + else ()); + FStarC_TypeChecker_Normalize.elim_uvars env2 se1) + ses' in + let ses_elaborated1 = + FStarC_Compiler_List.map + (fun se1 -> + (let uu___9 = + FStarC_Compiler_Effect.op_Bang dbg_UF in + if uu___9 + then + let uu___10 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_sigelt se1 in + FStarC_Compiler_Util.print1 + "About to elim vars from (elaborated) %s\n" + uu___10 + else ()); + FStarC_TypeChecker_Normalize.elim_uvars env2 se1) + ses_elaborated in + (FStarC_TypeChecker_Env.promote_id_info env2 + (compress_and_norm env2); + (let ses'2 = + FStarC_Compiler_List.map + (FStarC_Syntax_Compress.deep_compress_se false + false) ses'1 in + let env3 = + FStarC_Compiler_List.fold_left + (fun env4 -> + fun se1 -> add_sigelt_to_env env4 se1 false) + env2 ses'2 in + FStarC_Syntax_Unionfind.reset (); + (let uu___11 = + ((FStarC_Options.log_types ()) || + (FStarC_Compiler_Debug.medium ())) + || (FStarC_Compiler_Effect.op_Bang dbg_LogTypes) in + if uu___11 + then + let uu___12 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_sigelt) ses'2 in + FStarC_Compiler_Util.print1 "Checked: %s\n" + uu___12 + else ()); + (let uu___12 = + let uu___13 = + let uu___14 = + FStarC_TypeChecker_Env.current_module env3 in + FStarC_Ident.string_of_lid uu___14 in + FStar_Pervasives_Native.Some uu___13 in + FStarC_Profiling.profile + (fun uu___13 -> + FStarC_Compiler_List.iter + (fun se1 -> + (env3.FStarC_TypeChecker_Env.solver).FStarC_TypeChecker_Env.encode_sig + env3 se1) ses'2) uu___12 + "FStarC.TypeChecker.Tc.encode_sig"); + (((FStarC_Compiler_List.rev_append ses'2 ses1), env3), + ses_elaborated1))))))) in + let process_one_decl_timed acc se = + FStarC_TypeChecker_Core.clear_memo_table (); + (let uu___1 = acc in + match uu___1 with + | (uu___2, env1) -> + let r = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_TypeChecker_Env.current_module env1 in + FStarC_Ident.string_of_lid uu___5 in + FStar_Pervasives_Native.Some uu___4 in + FStarC_Profiling.profile + (fun uu___4 -> process_one_decl acc se) uu___3 + "FStarC.TypeChecker.Tc.process_one_decl" in + ((let uu___4 = + (FStarC_Options.profile_group_by_decl ()) || + (FStarC_Options.timing ()) in + if uu___4 + then + let tag = + match FStarC_Syntax_Util.lids_of_sigelt se with + | hd::uu___5 -> FStarC_Ident.string_of_lid hd + | uu___5 -> + FStarC_Compiler_Range_Ops.string_of_range + (FStarC_Syntax_Util.range_of_sigelt se) in + FStarC_Profiling.report_and_clear tag + else ()); + r)) in + let uu___ = + FStarC_Syntax_Unionfind.with_uf_enabled + (fun uu___1 -> + FStarC_Compiler_Util.fold_flatten process_one_decl_timed + ([], env) ses) in + match uu___ with + | (ses1, env1) -> ((FStarC_Compiler_List.rev_append ses1 []), env1) +let (uu___0 : unit) = + FStarC_Compiler_Effect.op_Colon_Equals tc_decls_knot + (FStar_Pervasives_Native.Some tc_decls) +let (snapshot_context : + FStarC_TypeChecker_Env.env -> + Prims.string -> + ((Prims.int * Prims.int * FStarC_TypeChecker_Env.solver_depth_t * + Prims.int) * FStarC_TypeChecker_Env.env)) + = + fun env -> + fun msg -> + FStarC_Compiler_Util.atomically + (fun uu___ -> FStarC_TypeChecker_Env.snapshot env msg) +let (rollback_context : + FStarC_TypeChecker_Env.solver_t -> + Prims.string -> + (Prims.int * Prims.int * FStarC_TypeChecker_Env.solver_depth_t * + Prims.int) FStar_Pervasives_Native.option -> + FStarC_TypeChecker_Env.env) + = + fun solver -> + fun msg -> + fun depth -> + FStarC_Compiler_Util.atomically + (fun uu___ -> + let env = FStarC_TypeChecker_Env.rollback solver msg depth in + env) +let (push_context : + FStarC_TypeChecker_Env.env -> Prims.string -> FStarC_TypeChecker_Env.env) = + fun env -> + fun msg -> + let uu___ = snapshot_context env msg in + FStar_Pervasives_Native.snd uu___ +let (pop_context : + FStarC_TypeChecker_Env.env -> Prims.string -> FStarC_TypeChecker_Env.env) = + fun env -> + fun msg -> + rollback_context env.FStarC_TypeChecker_Env.solver msg + FStar_Pervasives_Native.None +let (tc_partial_modul : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.modul -> + (FStarC_Syntax_Syntax.modul * FStarC_TypeChecker_Env.env)) + = + fun env -> + fun modul -> + let verify = + let uu___ = + FStarC_Ident.string_of_lid modul.FStarC_Syntax_Syntax.name in + FStarC_Options.should_verify uu___ in + let action = if verify then "verifying" else "lax-checking" in + let label = + if modul.FStarC_Syntax_Syntax.is_interface + then "interface" + else "implementation" in + (let uu___1 = FStarC_Compiler_Debug.any () in + if uu___1 + then + let uu___2 = + FStarC_Ident.string_of_lid modul.FStarC_Syntax_Syntax.name in + FStarC_Compiler_Util.print3 "Now %s %s of %s\n" action label uu___2 + else ()); + FStarC_Compiler_Debug.disable_all (); + (let uu___3 = + let uu___4 = + FStarC_Ident.string_of_lid modul.FStarC_Syntax_Syntax.name in + FStarC_Options.should_check uu___4 in + if uu___3 + then + let uu___4 = FStarC_Options.debug_keys () in + FStarC_Compiler_Debug.enable_toggles uu___4 + else ()); + (let name = + let uu___3 = + FStarC_Ident.string_of_lid modul.FStarC_Syntax_Syntax.name in + FStarC_Compiler_Util.format2 "%s %s" + (if modul.FStarC_Syntax_Syntax.is_interface + then "interface" + else "module") uu___3 in + let env1 = + { + FStarC_TypeChecker_Env.solver = + (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = (env.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (modul.FStarC_Syntax_Syntax.is_interface); + FStarC_TypeChecker_Env.admit = (Prims.op_Negation verify); + FStarC_TypeChecker_Env.lax_universes = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env.FStarC_TypeChecker_Env.missing_decl) + } in + let env2 = + FStarC_TypeChecker_Env.set_current_module env1 + modul.FStarC_Syntax_Syntax.name in + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Ident.string_of_lid modul.FStarC_Syntax_Syntax.name in + FStarC_Options.should_check uu___5 in + Prims.op_Negation uu___4 in + let uu___4 = + let uu___5 = + FStarC_Ident.string_of_lid modul.FStarC_Syntax_Syntax.name in + FStarC_Compiler_Util.format2 "While loading dependency %s%s" uu___5 + (if modul.FStarC_Syntax_Syntax.is_interface + then " (interface)" + else "") in + FStarC_Errors.with_ctx_if uu___3 uu___4 + (fun uu___5 -> + let uu___6 = + tc_decls env2 modul.FStarC_Syntax_Syntax.declarations in + match uu___6 with + | (ses, env3) -> + ({ + FStarC_Syntax_Syntax.name = + (modul.FStarC_Syntax_Syntax.name); + FStarC_Syntax_Syntax.declarations = ses; + FStarC_Syntax_Syntax.is_interface = + (modul.FStarC_Syntax_Syntax.is_interface) + }, env3))) +let (tc_more_partial_modul : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.modul -> + FStarC_Syntax_Syntax.sigelt Prims.list -> + (FStarC_Syntax_Syntax.modul * FStarC_Syntax_Syntax.sigelt Prims.list + * FStarC_TypeChecker_Env.env)) + = + fun env -> + fun modul -> + fun decls -> + let uu___ = tc_decls env decls in + match uu___ with + | (ses, env1) -> + let modul1 = + { + FStarC_Syntax_Syntax.name = (modul.FStarC_Syntax_Syntax.name); + FStarC_Syntax_Syntax.declarations = + (FStarC_Compiler_List.op_At + modul.FStarC_Syntax_Syntax.declarations ses); + FStarC_Syntax_Syntax.is_interface = + (modul.FStarC_Syntax_Syntax.is_interface) + } in + (modul1, ses, env1) +let (finish_partial_modul : + Prims.bool -> + Prims.bool -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.modul -> + (FStarC_Syntax_Syntax.modul * FStarC_TypeChecker_Env.env)) + = + fun loading_from_cache -> + fun iface_exists -> + fun en -> + fun m -> + let env = FStarC_TypeChecker_Env.finish_module en m in + if Prims.op_Negation loading_from_cache + then + (let missing = FStarC_TypeChecker_Env.missing_definition_list env in + if Prims.uu___is_Cons missing + then + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Ident.string_of_lid + m.FStarC_Syntax_Syntax.name in + FStarC_Compiler_Util.format1 + "Missing definitions in module %s:" uu___5 in + FStarC_Errors_Msg.text uu___4 in + let uu___4 = + FStarC_Pprint.separate_map FStarC_Pprint.hardline + (fun l -> + let uu___5 = FStarC_Ident.ident_of_lid l in + FStarC_Class_PP.pp FStarC_Ident.pretty_ident uu___5) + missing in + FStarC_Pprint.prefix (Prims.of_int (2)) Prims.int_one + uu___3 uu___4 in + [uu___2] in + FStarC_Errors.log_issue FStarC_TypeChecker_Env.hasRange_env + env FStarC_Errors_Codes.Error_AdmitWithoutDefinition () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___1) + else ()) + else (); + FStarC_Compiler_Util.smap_clear + (FStar_Pervasives_Native.snd + env.FStarC_TypeChecker_Env.qtbl_name_and_index); + (let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Ident.string_of_lid m.FStarC_Syntax_Syntax.name in + Prims.strcat "Ending modul " uu___5 in + pop_context env uu___4 in + ()); + (let uu___4 = + let uu___5 = FStarC_Options.depth () in uu___5 > Prims.int_zero in + if uu___4 + then + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Options.depth () in + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) uu___8 in + Prims.strcat uu___7 "." in + Prims.strcat + "Some #push-options have not been popped. Current depth is " + uu___6 in + FStarC_Errors.log_issue FStarC_TypeChecker_Env.hasRange_env env + FStarC_Errors_Codes.Error_MissingPopOptions () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___5) + else ()); + (m, env) +let (deep_compress_modul : + FStarC_Syntax_Syntax.modul -> FStarC_Syntax_Syntax.modul) = + fun m -> + let uu___ = + FStarC_Compiler_List.map + (FStarC_Syntax_Compress.deep_compress_se false false) + m.FStarC_Syntax_Syntax.declarations in + { + FStarC_Syntax_Syntax.name = (m.FStarC_Syntax_Syntax.name); + FStarC_Syntax_Syntax.declarations = uu___; + FStarC_Syntax_Syntax.is_interface = + (m.FStarC_Syntax_Syntax.is_interface) + } +let (tc_modul : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.modul -> + Prims.bool -> (FStarC_Syntax_Syntax.modul * FStarC_TypeChecker_Env.env)) + = + fun env0 -> + fun m -> + fun iface_exists -> + let msg = + let uu___ = FStarC_Ident.string_of_lid m.FStarC_Syntax_Syntax.name in + Prims.strcat "Internals for " uu___ in + let env01 = push_context env0 msg in + let uu___ = tc_partial_modul env01 m in + match uu___ with + | (modul, env) -> finish_partial_modul false iface_exists env modul +let (load_checked_module_sigelts : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.modul -> FStarC_TypeChecker_Env.env) + = + fun en -> + fun m -> + let env = + FStarC_TypeChecker_Env.set_current_module en + m.FStarC_Syntax_Syntax.name in + let env1 = + let uu___ = + let uu___1 = FStarC_Ident.string_of_lid m.FStarC_Syntax_Syntax.name in + Prims.strcat "Internals for " uu___1 in + push_context env uu___ in + let env2 = + FStarC_Compiler_List.fold_left + (fun env3 -> + fun se -> + let env4 = add_sigelt_to_env env3 se true in + let lids = FStarC_Syntax_Util.lids_of_sigelt se in + FStarC_Compiler_List.iter + (fun lid -> + let uu___1 = + FStarC_TypeChecker_Env.lookup_sigelt env4 lid in + ()) lids; + env4) env1 m.FStarC_Syntax_Syntax.declarations in + env2 +let (load_checked_module : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.modul -> FStarC_TypeChecker_Env.env) + = + fun en -> + fun m -> + (let uu___1 = + (let uu___2 = FStarC_Ident.string_of_lid m.FStarC_Syntax_Syntax.name in + FStarC_Options.should_check uu___2) || + (FStarC_Options.debug_all_modules ()) in + if uu___1 + then + let uu___2 = FStarC_Options.debug_keys () in + FStarC_Compiler_Debug.enable_toggles uu___2 + else FStarC_Compiler_Debug.disable_all ()); + (let m1 = deep_compress_modul m in + let env = load_checked_module_sigelts en m1 in + let uu___1 = finish_partial_modul true true env m1 in + match uu___1 with | (uu___2, env1) -> env1) +let (load_partial_checked_module : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.modul -> FStarC_TypeChecker_Env.env) + = + fun en -> + fun m -> + let m1 = deep_compress_modul m in load_checked_module_sigelts en m1 +let (check_module : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.modul -> + Prims.bool -> (FStarC_Syntax_Syntax.modul * FStarC_TypeChecker_Env.env)) + = + fun env0 -> + fun m -> + fun b -> + (let uu___1 = FStarC_Compiler_Debug.any () in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show FStarC_Ident.showable_lident + m.FStarC_Syntax_Syntax.name in + FStarC_Compiler_Util.print2 "Checking %s: %s\n" + (if m.FStarC_Syntax_Syntax.is_interface + then "i'face" + else "module") uu___2 + else ()); + (let uu___2 = + let uu___3 = + FStarC_Ident.string_of_lid m.FStarC_Syntax_Syntax.name in + FStarC_Options.dump_module uu___3 in + if uu___2 + then + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_modul m in + FStarC_Compiler_Util.print1 "Module before type checking:\n%s\n" + uu___3 + else ()); + (let env = + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Ident.string_of_lid m.FStarC_Syntax_Syntax.name in + FStarC_Options.should_verify uu___4 in + Prims.op_Negation uu___3 in + { + FStarC_TypeChecker_Env.solver = + (env0.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env0.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env0.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env0.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env0.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env0.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env0.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env0.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env0.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env0.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env0.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env0.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env0.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env0.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env0.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env0.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env0.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env0.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = uu___2; + FStarC_TypeChecker_Env.lax_universes = + (env0.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env0.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env0.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env0.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env0.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env0.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env0.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env0.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env0.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env0.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env0.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env0.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env0.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env0.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env0.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env0.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env0.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env0.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env0.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env0.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env0.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env0.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env0.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env0.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env0.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = (env0.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env0.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env0.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env0.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env0.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env0.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env0.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env0.FStarC_TypeChecker_Env.missing_decl) + } in + let uu___2 = tc_modul env m b in + match uu___2 with + | (m1, env1) -> + let env2 = + { + FStarC_TypeChecker_Env.solver = + (env1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env0.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env1.FStarC_TypeChecker_Env.missing_decl) + } in + ((let uu___4 = + let uu___5 = + FStarC_Ident.string_of_lid m1.FStarC_Syntax_Syntax.name in + FStarC_Options.dump_module uu___5 in + if uu___4 + then + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_modul + m1 in + FStarC_Compiler_Util.print1 + "Module after type checking:\n%s\n" uu___5 + else ()); + (let uu___5 = + (let uu___6 = + FStarC_Ident.string_of_lid m1.FStarC_Syntax_Syntax.name in + FStarC_Options.dump_module uu___6) && + (FStarC_Compiler_Effect.op_Bang dbg_Normalize) in + if uu___5 + then + let normalize_toplevel_lets se = + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_let + { FStarC_Syntax_Syntax.lbs1 = (b1, lbs); + FStarC_Syntax_Syntax.lids1 = ids;_} + -> + let n = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.Reify; + FStarC_TypeChecker_Env.Inlining; + FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.AllowUnboundUniverses] in + let update lb = + let uu___6 = + FStarC_Syntax_Subst.open_univ_vars + lb.FStarC_Syntax_Syntax.lbunivs + lb.FStarC_Syntax_Syntax.lbdef in + match uu___6 with + | (univnames, e) -> + let uu___7 = + let uu___8 = + FStarC_TypeChecker_Env.push_univ_vars env2 + univnames in + n uu___8 e in + { + FStarC_Syntax_Syntax.lbname = + (lb.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = + (lb.FStarC_Syntax_Syntax.lbtyp); + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = uu___7; + FStarC_Syntax_Syntax.lbattrs = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + } in + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = FStarC_Compiler_List.map update lbs in + (b1, uu___9) in + { + FStarC_Syntax_Syntax.lbs1 = uu___8; + FStarC_Syntax_Syntax.lids1 = ids + } in + FStarC_Syntax_Syntax.Sig_let uu___7 in + { + FStarC_Syntax_Syntax.sigel = uu___6; + FStarC_Syntax_Syntax.sigrng = + (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se.FStarC_Syntax_Syntax.sigopts) + } + | uu___6 -> se in + let normalized_module = + let uu___6 = + FStarC_Compiler_List.map normalize_toplevel_lets + m1.FStarC_Syntax_Syntax.declarations in + { + FStarC_Syntax_Syntax.name = + (m1.FStarC_Syntax_Syntax.name); + FStarC_Syntax_Syntax.declarations = uu___6; + FStarC_Syntax_Syntax.is_interface = + (m1.FStarC_Syntax_Syntax.is_interface) + } in + let uu___6 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_modul + normalized_module in + FStarC_Compiler_Util.print1 "%s\n" uu___6 + else ()); + (m1, env2))) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_TcEffect.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_TcEffect.ml new file mode 100644 index 00000000000..f345d5e3e58 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_TcEffect.ml @@ -0,0 +1,10097 @@ +open Prims +let (dbg : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "ED" +let (dbg_LayeredEffectsTc : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "LayeredEffectsTc" +let (dmff_cps_and_elaborate : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.eff_decl -> + (FStarC_Syntax_Syntax.sigelt Prims.list * FStarC_Syntax_Syntax.eff_decl + * FStarC_Syntax_Syntax.sigelt FStar_Pervasives_Native.option)) + = fun env -> fun ed -> FStarC_TypeChecker_DMFF.cps_and_elaborate env ed +let (check_and_gen : + FStarC_TypeChecker_Env.env -> + Prims.string -> + Prims.string -> + Prims.int -> + (FStarC_Syntax_Syntax.univ_names * FStarC_Syntax_Syntax.term) -> + (FStarC_Syntax_Syntax.univ_names * FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.typ)) + = + fun env -> + fun eff_name -> + fun comb -> + fun n -> + fun uu___ -> + match uu___ with + | (us, t) -> + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_tuple2 + (FStarC_Class_Show.show_list + FStarC_Ident.showable_ident) + FStarC_Syntax_Print.showable_term) (us, t) in + Prims.strcat " = " uu___4 in + Prims.strcat comb uu___3 in + Prims.strcat "While checking combinator " uu___2 in + FStarC_Errors.with_ctx uu___1 + (fun uu___2 -> + let uu___3 = FStarC_Syntax_Subst.open_univ_vars us t in + match uu___3 with + | (us1, t1) -> + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_TypeChecker_Env.push_univ_vars env us1 in + FStarC_TypeChecker_TcTerm.tc_tot_or_gtot_term + uu___6 t1 in + match uu___5 with + | (t2, lc, g) -> + (FStarC_TypeChecker_Rel.force_trivial_guard + env g; + (t2, (lc.FStarC_TypeChecker_Common.res_typ))) in + (match uu___4 with + | (t2, ty) -> + let uu___5 = + FStarC_TypeChecker_Generalize.generalize_universes + env t2 in + (match uu___5 with + | (g_us, t3) -> + let ty1 = + FStarC_Syntax_Subst.close_univ_vars g_us + ty in + (if + (FStarC_Compiler_List.length g_us) <> n + then + (let error = + let uu___6 = + FStarC_Compiler_Util.string_of_int + n in + let uu___7 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length + g_us) in + let uu___8 = + FStarC_Syntax_Print.tscheme_to_string + (g_us, t3) in + FStarC_Compiler_Util.format5 + "Expected %s:%s to be universe-polymorphic in %s universes, but found %s (tscheme: %s)" + eff_name comb uu___6 uu___7 uu___8 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax + ()) t3 + FStarC_Errors_Codes.Fatal_MismatchUniversePolymorphic + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic error); + (match us1 with + | [] -> () + | uu___7 -> + let uu___8 = + ((FStarC_Compiler_List.length + us1) + = + (FStarC_Compiler_List.length + g_us)) + && + (FStarC_Compiler_List.forall2 + (fun u1 -> + fun u2 -> + let uu___9 = + FStarC_Syntax_Syntax.order_univ_name + u1 u2 in + uu___9 = + Prims.int_zero) us1 + g_us) in + if uu___8 + then () + else + (let uu___10 = + let uu___11 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Ident.showable_ident) + us1 in + let uu___12 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Ident.showable_ident) + g_us in + FStarC_Compiler_Util.format4 + "Expected and generalized universes in the declaration for %s:%s are different, input: %s, but after gen: %s" + eff_name comb uu___11 + uu___12 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax + ()) t3 + FStarC_Errors_Codes.Fatal_UnexpectedNumberOfUniverse + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___10)))) + else (); + (g_us, t3, ty1))))) +let (pure_wp_uvar : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> + Prims.string -> + FStarC_Compiler_Range_Type.range -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.guard_t)) + = + fun env -> + fun t -> + fun reason -> + fun r -> + let pure_wp_t = + let pure_wp_ts = + let uu___ = + FStarC_TypeChecker_Env.lookup_definition + [FStarC_TypeChecker_Env.NoDelta] env + FStarC_Parser_Const.pure_wp_lid in + FStarC_Compiler_Util.must uu___ in + let uu___ = FStarC_TypeChecker_Env.inst_tscheme pure_wp_ts in + match uu___ with + | (uu___1, pure_wp_t1) -> + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.as_arg t in [uu___3] in + FStarC_Syntax_Syntax.mk_Tm_app pure_wp_t1 uu___2 r in + let uu___ = + FStarC_TypeChecker_Env.new_implicit_var_aux reason r env + pure_wp_t FStarC_Syntax_Syntax.Strict + FStar_Pervasives_Native.None false in + match uu___ with + | (pure_wp_uvar1, uu___1, guard_wp) -> (pure_wp_uvar1, guard_wp) +let op_let_Question : + 'a 'b . + 'a FStar_Pervasives_Native.option -> + ('a -> 'b FStar_Pervasives_Native.option) -> + 'b FStar_Pervasives_Native.option + = + fun f -> + fun g -> + match f with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some x -> g x +let (mteq : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.typ -> Prims.bool) + = + fun env -> + fun t1 -> + fun t2 -> + try + (fun uu___ -> + match () with + | () -> FStarC_TypeChecker_Rel.teq_nosmt_force env t1 t2) () + with | uu___ -> false +let (eq_binders : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.indexed_effect_binder_kind Prims.list + FStar_Pervasives_Native.option) + = + fun env -> + fun bs1 -> + fun bs2 -> + let uu___ = + let uu___1 = + FStarC_Compiler_List.fold_left2 + (fun uu___2 -> + fun b1 -> + fun b2 -> + match uu___2 with + | (b, ss) -> + let uu___3 = + b && + (let uu___4 = + FStarC_Syntax_Subst.subst ss + (b1.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + mteq env uu___4 + (b2.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort) in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Syntax.bv_to_name + b2.FStarC_Syntax_Syntax.binder_bv in + ((b1.FStarC_Syntax_Syntax.binder_bv), + uu___8) in + FStarC_Syntax_Syntax.NT uu___7 in + [uu___6] in + FStarC_Compiler_List.op_At ss uu___5 in + (uu___3, uu___4)) (true, []) bs1 bs2 in + FStar_Pervasives_Native.fst uu___1 in + if uu___ + then + let uu___1 = + FStarC_Compiler_List.map + (fun uu___2 -> FStarC_Syntax_Syntax.Substitutive_binder) bs1 in + FStar_Pervasives_Native.Some uu___1 + else FStar_Pervasives_Native.None +let (log_ad_hoc_combinator_warning : + Prims.string -> FStarC_Compiler_Range_Type.range -> unit) = + fun comb_name -> + fun r -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Compiler_Util.format1 + "Combinator %s is not a substitutive indexed effect combinator, it is better to make it one if possible for better performance and ease of use" + comb_name in + FStarC_Errors_Msg.text uu___2 in + [uu___1] in + FStarC_Errors.log_issue FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Warning_Adhoc_IndexedEffect_Combinator () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___) +let (bind_combinator_kind : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident -> + FStarC_Ident.lident -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.tscheme -> + FStarC_Syntax_Syntax.tscheme -> + FStarC_Syntax_Syntax.tscheme -> + FStarC_Syntax_Syntax.tscheme FStar_Pervasives_Native.option + -> + FStarC_Syntax_Syntax.tscheme FStar_Pervasives_Native.option + -> + FStarC_Syntax_Syntax.tscheme + FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.univ_names -> + FStarC_Syntax_Syntax.typ -> + Prims.int -> + Prims.bool -> + FStarC_Syntax_Syntax.indexed_effect_binder_kind + Prims.list FStar_Pervasives_Native.option) + = + fun env -> + fun m_eff_name -> + fun n_eff_name -> + fun p_eff_name -> + fun m_sig_ts -> + fun n_sig_ts -> + fun p_sig_ts -> + fun m_repr_ts -> + fun n_repr_ts -> + fun p_repr_ts -> + fun bind_us -> + fun k -> + fun num_effect_params -> + fun has_range_binders -> + let debug s = + let uu___ = + (FStarC_Compiler_Debug.medium ()) || + (FStarC_Compiler_Effect.op_Bang + dbg_LayeredEffectsTc) in + if uu___ + then FStarC_Compiler_Util.print1 "%s\n" s + else () in + (let uu___1 = + let uu___2 = + FStarC_Compiler_Util.string_of_int + num_effect_params in + FStarC_Compiler_Util.format1 + "Checking bind combinator kind with %s effect parameters" + uu___2 in + debug uu___1); + (let uu___1 = bind_us in + match uu___1 with + | u_a::u_b::[] -> + let uu___2 = + let uu___3 = + FStarC_Syntax_Util.arrow_formals k in + FStar_Pervasives_Native.fst uu___3 in + (match uu___2 with + | a_b::b_b::rest_bs -> + let uu___3 = + if + num_effect_params = + Prims.int_zero + then + FStar_Pervasives_Native.Some + ([], [], rest_bs) + else + (let uu___5 = + FStarC_TypeChecker_Env.inst_tscheme_with + m_sig_ts + [FStarC_Syntax_Syntax.U_name + u_a] in + match uu___5 with + | (uu___6, sig1) -> + let sig_bs = + let uu___7 = + let uu___8 = + FStarC_Syntax_Util.arrow_formals + sig1 in + FStar_Pervasives_Native.fst + uu___8 in + FStarC_Compiler_List.tl + uu___7 in + let uu___7 = + if + (FStarC_Compiler_List.length + sig_bs) + < num_effect_params + then + FStar_Pervasives_Native.None + else + (let uu___9 = + let uu___10 = + FStarC_Compiler_List.splitAt + num_effect_params + sig_bs in + FStar_Pervasives_Native.fst + uu___10 in + FStar_Pervasives_Native.Some + uu___9) in + op_let_Question uu___7 + (fun sig_eff_params_bs -> + let uu___8 = + if + (FStarC_Compiler_List.length + rest_bs) + < + num_effect_params + then + FStar_Pervasives_Native.None + else + (let uu___10 = + FStarC_Compiler_List.splitAt + num_effect_params + rest_bs in + FStar_Pervasives_Native.Some + uu___10) in + op_let_Question uu___8 + (fun uu___9 -> + match uu___9 with + | (eff_params_bs, + rest_bs1) -> + let uu___10 = + eq_binders + env + sig_eff_params_bs + eff_params_bs in + op_let_Question + uu___10 + (fun + eff_params_bs_kinds + -> + FStar_Pervasives_Native.Some + (eff_params_bs, + eff_params_bs_kinds, + rest_bs1))))) in + op_let_Question uu___3 + (fun uu___4 -> + match uu___4 with + | (eff_params_bs, + eff_params_bs_kinds, + rest_bs1) -> + let uu___5 = + let f_sig_bs = + let uu___6 = + FStarC_TypeChecker_Env.inst_tscheme_with + m_sig_ts + [FStarC_Syntax_Syntax.U_name + u_a] in + match uu___6 with + | (uu___7, sig1) -> + let uu___8 = + let uu___9 = + FStarC_Syntax_Util.arrow_formals + sig1 in + FStar_Pervasives_Native.fst + uu___9 in + (match uu___8 with + | a::bs -> + let uu___9 = + FStarC_Compiler_List.splitAt + num_effect_params + bs in + (match uu___9 + with + | (sig_bs, + bs1) -> + let ss = + let uu___10 + = + let uu___11 + = + let uu___12 + = + let uu___13 + = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + ((a.FStarC_Syntax_Syntax.binder_bv), + uu___13) in + FStarC_Syntax_Syntax.NT + uu___12 in + [uu___11] in + FStarC_Compiler_List.fold_left2 + (fun ss1 + -> + fun sig_b + -> + fun b -> + let uu___11 + = + let uu___12 + = + let uu___13 + = + let uu___14 + = + FStarC_Syntax_Syntax.bv_to_name + b.FStarC_Syntax_Syntax.binder_bv in + ((sig_b.FStarC_Syntax_Syntax.binder_bv), + uu___14) in + FStarC_Syntax_Syntax.NT + uu___13 in + [uu___12] in + FStarC_Compiler_List.op_At + ss1 + uu___11) + uu___10 + sig_bs + eff_params_bs in + FStarC_Syntax_Subst.subst_binders + ss bs1)) in + let uu___6 = + if + (FStarC_Compiler_List.length + rest_bs1) + < + (FStarC_Compiler_List.length + f_sig_bs) + then + FStar_Pervasives_Native.None + else + (let uu___8 = + FStarC_Compiler_List.splitAt + (FStarC_Compiler_List.length + f_sig_bs) + rest_bs1 in + FStar_Pervasives_Native.Some + uu___8) in + op_let_Question uu___6 + (fun uu___7 -> + match uu___7 with + | (f_bs, rest_bs2) -> + let uu___8 = + eq_binders env + f_sig_bs f_bs in + op_let_Question + uu___8 + (fun f_bs_kinds + -> + FStar_Pervasives_Native.Some + (f_bs, + f_bs_kinds, + rest_bs2))) in + op_let_Question uu___5 + (fun uu___6 -> + match uu___6 with + | (f_bs, f_bs_kinds, + rest_bs2) -> + let uu___7 = + let g_sig_bs = + let uu___8 = + FStarC_TypeChecker_Env.inst_tscheme_with + n_sig_ts + [FStarC_Syntax_Syntax.U_name + u_b] in + match uu___8 + with + | (uu___9, + sig1) -> + let uu___10 + = + let uu___11 + = + FStarC_Syntax_Util.arrow_formals + sig1 in + FStar_Pervasives_Native.fst + uu___11 in + (match uu___10 + with + | + b::bs -> + let uu___11 + = + FStarC_Compiler_List.splitAt + num_effect_params + bs in + (match uu___11 + with + | + (sig_bs, + bs1) -> + let ss = + let uu___12 + = + let uu___13 + = + let uu___14 + = + let uu___15 + = + FStarC_Syntax_Syntax.bv_to_name + b_b.FStarC_Syntax_Syntax.binder_bv in + ((b.FStarC_Syntax_Syntax.binder_bv), + uu___15) in + FStarC_Syntax_Syntax.NT + uu___14 in + [uu___13] in + FStarC_Compiler_List.fold_left2 + (fun ss1 + -> + fun sig_b + -> + fun b1 -> + let uu___13 + = + let uu___14 + = + let uu___15 + = + let uu___16 + = + FStarC_Syntax_Syntax.bv_to_name + b1.FStarC_Syntax_Syntax.binder_bv in + ((sig_b.FStarC_Syntax_Syntax.binder_bv), + uu___16) in + FStarC_Syntax_Syntax.NT + uu___15 in + [uu___14] in + FStarC_Compiler_List.op_At + ss1 + uu___13) + uu___12 + sig_bs + eff_params_bs in + FStarC_Syntax_Subst.subst_binders + ss bs1)) in + let uu___8 = + if + (FStarC_Compiler_List.length + rest_bs2) + < + (FStarC_Compiler_List.length + g_sig_bs) + then + FStar_Pervasives_Native.None + else + (let uu___10 + = + FStarC_Compiler_List.splitAt + (FStarC_Compiler_List.length + g_sig_bs) + rest_bs2 in + FStar_Pervasives_Native.Some + uu___10) in + op_let_Question + uu___8 + (fun uu___9 -> + match uu___9 + with + | (g_bs, + rest_bs3) + -> + let uu___10 + = + let uu___11 + = + FStarC_Compiler_List.fold_left2 + (fun + uu___12 + -> + fun + g_sig_b + -> + fun g_b + -> + match uu___12 + with + | + (l, ss) + -> + let g_sig_b_sort + = + FStarC_Syntax_Subst.subst + ss + (g_sig_b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + let g_sig_b_arrow_t + = + let x_bv + = + let uu___13 + = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + FStarC_Syntax_Syntax.gen_bv + "x" + FStar_Pervasives_Native.None + uu___13 in + let ss1 = + let uu___13 + = + FStarC_Compiler_List.map + (fun + uu___14 + -> + match uu___14 + with + | + (bv, k1) + -> + if + k1 = + FStarC_Syntax_Syntax.Substitutive_binder + then + let uu___15 + = + let uu___16 + = + let uu___17 + = + let uu___18 + = + FStarC_Syntax_Syntax.bv_to_name + bv in + let uu___19 + = + let uu___20 + = + let uu___21 + = + FStarC_Syntax_Syntax.bv_to_name + x_bv in + FStarC_Syntax_Syntax.as_arg + uu___21 in + [uu___20] in + FStarC_Syntax_Syntax.mk_Tm_app + uu___18 + uu___19 + FStarC_Compiler_Range_Type.dummyRange in + (bv, + uu___17) in + FStarC_Syntax_Syntax.NT + uu___16 in + [uu___15] + else []) + l in + FStarC_Compiler_List.flatten + uu___13 in + let g_sig_b_sort1 + = + FStarC_Syntax_Subst.subst + ss1 + g_sig_b_sort in + let uu___13 + = + let uu___14 + = + FStarC_Syntax_Syntax.mk_binder + x_bv in + [uu___14] in + let uu___14 + = + FStarC_Syntax_Syntax.mk_Total + g_sig_b_sort1 in + FStarC_Syntax_Util.arrow + uu___13 + uu___14 in + let g_b_kind + = + let uu___13 + = + let uu___14 + = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm + env + g_sig_b_arrow_t + (g_b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + uu___14 = + FStarC_TypeChecker_TermEqAndSimplify.Equal in + if + uu___13 + then + FStarC_Syntax_Syntax.Substitutive_binder + else + (let uu___15 + = + let uu___16 + = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm + env + g_sig_b_sort + (g_b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + uu___16 = + FStarC_TypeChecker_TermEqAndSimplify.Equal in + if + uu___15 + then + FStarC_Syntax_Syntax.BindCont_no_abstraction_binder + else + FStarC_Syntax_Syntax.Ad_hoc_binder) in + let ss1 = + let uu___13 + = + let uu___14 + = + let uu___15 + = + let uu___16 + = + FStarC_Syntax_Syntax.bv_to_name + g_b.FStarC_Syntax_Syntax.binder_bv in + ((g_sig_b.FStarC_Syntax_Syntax.binder_bv), + uu___16) in + FStarC_Syntax_Syntax.NT + uu___15 in + [uu___14] in + FStarC_Compiler_List.op_At + ss + uu___13 in + ((FStarC_Compiler_List.op_At + l + [ + ((g_b.FStarC_Syntax_Syntax.binder_bv), + g_b_kind)]), + ss1)) + ([], []) + g_sig_bs + g_bs in + match uu___11 + with + | + (g_bs_kinds, + uu___12) + -> + let g_bs_kinds1 + = + FStarC_Compiler_List.map + FStar_Pervasives_Native.snd + g_bs_kinds in + if + FStarC_Compiler_List.contains + FStarC_Syntax_Syntax.Ad_hoc_binder + g_bs_kinds1 + then + FStar_Pervasives_Native.None + else + FStar_Pervasives_Native.Some + g_bs_kinds1 in + op_let_Question + uu___10 + (fun + g_bs_kinds + -> + FStar_Pervasives_Native.Some + (g_bs, + g_bs_kinds, + rest_bs3))) in + op_let_Question + uu___7 + (fun uu___8 -> + match uu___8 + with + | (g_bs, + g_bs_kinds, + rest_bs3) + -> + let uu___9 + = + if + has_range_binders + then + FStarC_Compiler_List.splitAt + (Prims.of_int (2)) + rest_bs3 + else + ([], + rest_bs3) in + (match uu___9 + with + | + (range_bs, + rest_bs4) + -> + let uu___10 + = uu___9 in + let uu___11 + = + if + (FStarC_Compiler_List.length + rest_bs4) + >= + (Prims.of_int (2)) + then + let uu___12 + = + FStarC_Compiler_List.splitAt + ((FStarC_Compiler_List.length + rest_bs4) + - + (Prims.of_int (2))) + rest_bs4 in + match uu___12 + with + | + (rest_bs5, + f_b::g_b::[]) + -> + FStar_Pervasives_Native.Some + (rest_bs5, + f_b, g_b) + else + FStar_Pervasives_Native.None in + op_let_Question + uu___11 + (fun + uu___12 + -> + match uu___12 + with + | + (rest_bs5, + f_b, g_b) + -> + let uu___13 + = + let repr_app_bs + = + FStarC_Compiler_List.op_At + eff_params_bs + f_bs in + let expected_f_b_sort + = + match m_repr_ts + with + | + FStar_Pervasives_Native.Some + repr_ts + -> + let uu___14 + = + FStarC_TypeChecker_Env.inst_tscheme_with + repr_ts + [ + FStarC_Syntax_Syntax.U_name + u_a] in + (match uu___14 + with + | + (uu___15, + t) -> + let uu___16 + = + let uu___17 + = + let uu___18 + = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + FStarC_Syntax_Syntax.as_arg + uu___18 in + let uu___18 + = + FStarC_Compiler_List.map + (fun + uu___19 + -> + match uu___19 + with + | + { + FStarC_Syntax_Syntax.binder_bv + = b; + FStarC_Syntax_Syntax.binder_qual + = uu___20; + FStarC_Syntax_Syntax.binder_positivity + = uu___21; + FStarC_Syntax_Syntax.binder_attrs + = uu___22;_} + -> + let uu___23 + = + FStarC_Syntax_Syntax.bv_to_name + b in + FStarC_Syntax_Syntax.as_arg + uu___23) + repr_app_bs in + uu___17 + :: + uu___18 in + FStarC_Syntax_Syntax.mk_Tm_app + t uu___16 + FStarC_Compiler_Range_Type.dummyRange) + | + FStar_Pervasives_Native.None + -> + let uu___14 + = + let uu___15 + = + FStarC_Syntax_Syntax.null_binder + FStarC_Syntax_Syntax.t_unit in + [uu___15] in + let uu___15 + = + let uu___16 + = + let uu___17 + = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + let uu___18 + = + FStarC_Compiler_List.map + (fun b -> + let uu___19 + = + FStarC_Syntax_Syntax.bv_to_name + b.FStarC_Syntax_Syntax.binder_bv in + FStarC_Syntax_Syntax.as_arg + uu___19) + repr_app_bs in + { + FStarC_Syntax_Syntax.comp_univs + = + [ + FStarC_Syntax_Syntax.U_name + u_a]; + FStarC_Syntax_Syntax.effect_name + = + m_eff_name; + FStarC_Syntax_Syntax.result_typ + = uu___17; + FStarC_Syntax_Syntax.effect_args + = uu___18; + FStarC_Syntax_Syntax.flags + = [] + } in + FStarC_Syntax_Syntax.mk_Comp + uu___16 in + FStarC_Syntax_Util.arrow + uu___14 + uu___15 in + let uu___14 + = + let uu___15 + = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm + env + (f_b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort + expected_f_b_sort in + uu___15 = + FStarC_TypeChecker_TermEqAndSimplify.Equal in + if + uu___14 + then + FStar_Pervasives_Native.Some + () + else + FStar_Pervasives_Native.None in + op_let_Question + uu___13 + (fun + _f_b_ok_ + -> + let uu___14 + = + let expected_g_b_sort + = + let x_bv + = + let uu___15 + = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + FStarC_Syntax_Syntax.gen_bv + "x" + FStar_Pervasives_Native.None + uu___15 in + let eff_params_args + = + FStarC_Compiler_List.map + (fun + uu___15 + -> + match uu___15 + with + | + { + FStarC_Syntax_Syntax.binder_bv + = b; + FStarC_Syntax_Syntax.binder_qual + = uu___16; + FStarC_Syntax_Syntax.binder_positivity + = uu___17; + FStarC_Syntax_Syntax.binder_attrs + = uu___18;_} + -> + let uu___19 + = + FStarC_Syntax_Syntax.bv_to_name + b in + FStarC_Syntax_Syntax.as_arg + uu___19) + eff_params_bs in + let g_bs_args + = + let uu___15 + = + FStarC_Compiler_List.map2 + (fun + uu___16 + -> + fun kind + -> + match uu___16 + with + | + { + FStarC_Syntax_Syntax.binder_bv + = b; + FStarC_Syntax_Syntax.binder_qual + = uu___17; + FStarC_Syntax_Syntax.binder_positivity + = uu___18; + FStarC_Syntax_Syntax.binder_attrs + = uu___19;_} + -> + if + kind = + FStarC_Syntax_Syntax.Substitutive_binder + then + let uu___20 + = + FStarC_Syntax_Syntax.bv_to_name + b in + let uu___21 + = + let uu___22 + = + let uu___23 + = + FStarC_Syntax_Syntax.bv_to_name + x_bv in + FStarC_Syntax_Syntax.as_arg + uu___23 in + [uu___22] in + FStarC_Syntax_Syntax.mk_Tm_app + uu___20 + uu___21 + FStarC_Compiler_Range_Type.dummyRange + else + FStarC_Syntax_Syntax.bv_to_name + b) g_bs + g_bs_kinds in + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.as_arg + uu___15 in + let repr_args + = + FStarC_Compiler_List.op_At + eff_params_args + g_bs_args in + match n_repr_ts + with + | + FStar_Pervasives_Native.Some + repr_ts + -> + let uu___15 + = + FStarC_TypeChecker_Env.inst_tscheme_with + repr_ts + [ + FStarC_Syntax_Syntax.U_name + u_b] in + (match uu___15 + with + | + (uu___16, + repr_hd) + -> + let repr_app + = + let uu___17 + = + let uu___18 + = + let uu___19 + = + FStarC_Syntax_Syntax.bv_to_name + b_b.FStarC_Syntax_Syntax.binder_bv in + FStarC_Syntax_Syntax.as_arg + uu___19 in + uu___18 + :: + repr_args in + FStarC_Syntax_Syntax.mk_Tm_app + repr_hd + uu___17 + FStarC_Compiler_Range_Type.dummyRange in + let uu___17 + = + let uu___18 + = + FStarC_Syntax_Syntax.mk_binder + x_bv in + [uu___18] in + let uu___18 + = + FStarC_Syntax_Syntax.mk_Total + repr_app in + FStarC_Syntax_Util.arrow + uu___17 + uu___18) + | + FStar_Pervasives_Native.None + -> + let thunk_t + = + let uu___15 + = + let uu___16 + = + FStarC_Syntax_Syntax.null_binder + FStarC_Syntax_Syntax.t_unit in + [uu___16] in + let uu___16 + = + let uu___17 + = + let uu___18 + = + FStarC_Syntax_Syntax.bv_to_name + b_b.FStarC_Syntax_Syntax.binder_bv in + { + FStarC_Syntax_Syntax.comp_univs + = + [ + FStarC_Syntax_Syntax.U_name + u_b]; + FStarC_Syntax_Syntax.effect_name + = + n_eff_name; + FStarC_Syntax_Syntax.result_typ + = uu___18; + FStarC_Syntax_Syntax.effect_args + = + repr_args; + FStarC_Syntax_Syntax.flags + = [] + } in + FStarC_Syntax_Syntax.mk_Comp + uu___17 in + FStarC_Syntax_Util.arrow + uu___15 + uu___16 in + let uu___15 + = + let uu___16 + = + FStarC_Syntax_Syntax.mk_binder + x_bv in + [uu___16] in + let uu___16 + = + FStarC_Syntax_Syntax.mk_Total + thunk_t in + FStarC_Syntax_Util.arrow + uu___15 + uu___16 in + let uu___15 + = + let uu___16 + = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm + env + (g_b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort + expected_g_b_sort in + uu___16 = + FStarC_TypeChecker_TermEqAndSimplify.Equal in + if + uu___15 + then + FStar_Pervasives_Native.Some + () + else + FStar_Pervasives_Native.None in + op_let_Question + uu___14 + (fun + _g_b_ok + -> + let range_kinds + = + FStarC_Compiler_List.map + (fun + uu___15 + -> + FStarC_Syntax_Syntax.Range_binder) + range_bs in + let rest_kinds + = + FStarC_Compiler_List.map + (fun + uu___15 + -> + FStarC_Syntax_Syntax.Ad_hoc_binder) + rest_bs5 in + FStar_Pervasives_Native.Some + (FStarC_Compiler_List.op_At + [FStarC_Syntax_Syntax.Type_binder; + FStarC_Syntax_Syntax.Type_binder] + (FStarC_Compiler_List.op_At + eff_params_bs_kinds + (FStarC_Compiler_List.op_At + f_bs_kinds + (FStarC_Compiler_List.op_At + g_bs_kinds + (FStarC_Compiler_List.op_At + range_kinds + (FStarC_Compiler_List.op_At + rest_kinds + [FStarC_Syntax_Syntax.Repr_binder; + FStarC_Syntax_Syntax.Repr_binder]))))))))))))))) +let (validate_indexed_effect_bind_shape : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident -> + FStarC_Ident.lident -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.tscheme -> + FStarC_Syntax_Syntax.tscheme -> + FStarC_Syntax_Syntax.tscheme -> + FStarC_Syntax_Syntax.tscheme FStar_Pervasives_Native.option + -> + FStarC_Syntax_Syntax.tscheme FStar_Pervasives_Native.option + -> + FStarC_Syntax_Syntax.tscheme + FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.univ_names -> + FStarC_Syntax_Syntax.typ -> + FStarC_Compiler_Range_Type.range -> + Prims.int -> + Prims.bool -> + (FStarC_Syntax_Syntax.typ * + FStarC_Syntax_Syntax.indexed_effect_combinator_kind)) + = + fun env -> + fun m_eff_name -> + fun n_eff_name -> + fun p_eff_name -> + fun m_sig_ts -> + fun n_sig_ts -> + fun p_sig_ts -> + fun m_repr_ts -> + fun n_repr_ts -> + fun p_repr_ts -> + fun bind_us -> + fun bind_t -> + fun r -> + fun num_effect_params -> + fun has_range_binders -> + let bind_name = + let uu___ = + FStarC_Ident.string_of_lid m_eff_name in + let uu___1 = + FStarC_Ident.string_of_lid n_eff_name in + let uu___2 = + FStarC_Ident.string_of_lid p_eff_name in + FStarC_Compiler_Util.format3 + "(%s , %s) |> %s" uu___ uu___1 uu___2 in + let uu___ = bind_us in + match uu___ with + | u_a::u_b::[] -> + let a_b = + let uu___1 = + let uu___2 = + FStarC_Syntax_Util.type_with_u + (FStarC_Syntax_Syntax.U_name u_a) in + FStarC_Syntax_Syntax.gen_bv "a" + FStar_Pervasives_Native.None uu___2 in + FStarC_Syntax_Syntax.mk_binder uu___1 in + let b_b = + let uu___1 = + let uu___2 = + FStarC_Syntax_Util.type_with_u + (FStarC_Syntax_Syntax.U_name u_b) in + FStarC_Syntax_Syntax.gen_bv "b" + FStar_Pervasives_Native.None uu___2 in + FStarC_Syntax_Syntax.mk_binder uu___1 in + let rest_bs = + let uu___1 = + let uu___2 = + FStarC_Syntax_Subst.compress bind_t in + uu___2.FStarC_Syntax_Syntax.n in + match uu___1 with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = + uu___2;_} + when + (FStarC_Compiler_List.length bs) >= + (Prims.of_int (4)) + -> + let uu___3 = + FStarC_Syntax_Subst.open_binders + bs in + (match uu___3 with + | { + FStarC_Syntax_Syntax.binder_bv + = a; + FStarC_Syntax_Syntax.binder_qual + = uu___4; + FStarC_Syntax_Syntax.binder_positivity + = uu___5; + FStarC_Syntax_Syntax.binder_attrs + = uu___6;_}::{ + FStarC_Syntax_Syntax.binder_bv + = b; + FStarC_Syntax_Syntax.binder_qual + = uu___7; + FStarC_Syntax_Syntax.binder_positivity + = uu___8; + FStarC_Syntax_Syntax.binder_attrs + = uu___9;_}::bs1 + -> + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + (a, uu___13) in + FStarC_Syntax_Syntax.NT + uu___12 in + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + FStarC_Syntax_Syntax.bv_to_name + b_b.FStarC_Syntax_Syntax.binder_bv in + (b, uu___15) in + FStarC_Syntax_Syntax.NT + uu___14 in + [uu___13] in + uu___11 :: uu___12 in + let uu___11 = + let uu___12 = + FStarC_Compiler_List.splitAt + ((FStarC_Compiler_List.length + bs1) + - (Prims.of_int (2))) + bs1 in + FStar_Pervasives_Native.fst + uu___12 in + FStarC_Syntax_Subst.subst_binders + uu___10 uu___11) + | uu___2 -> + let uu___3 = + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + bind_t in + FStarC_Compiler_Util.format2 + "Type of %s is not an arrow with >= 4 binders (%s)" + bind_name uu___4 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + r + FStarC_Errors_Codes.Fatal_UnexpectedEffect + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___3) in + let uu___1 = + if has_range_binders + then + (if + (FStarC_Compiler_List.length + rest_bs) + >= (Prims.of_int (2)) + then + FStarC_Compiler_List.splitAt + ((FStarC_Compiler_List.length + rest_bs) + - (Prims.of_int (2))) rest_bs + else + (let uu___3 = + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + bind_t in + FStarC_Compiler_Util.format2 + "Type of %s is not an arrow with >= 6 binders (%s)" + bind_name uu___4 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + r + FStarC_Errors_Codes.Fatal_UnexpectedEffect + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___3))) + else (rest_bs, []) in + (match uu___1 with + | (rest_bs1, range_bs) -> + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_TypeChecker_Env.push_binders + env (a_b :: b_b :: rest_bs1) in + let uu___5 = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + FStarC_TypeChecker_Util.fresh_effect_repr + uu___4 r m_eff_name m_sig_ts + m_repr_ts + (FStarC_Syntax_Syntax.U_name + u_a) uu___5 in + match uu___3 with + | (repr, g) -> + let uu___4 = + let uu___5 = + FStarC_Syntax_Syntax.gen_bv + "f" + FStar_Pervasives_Native.None + repr in + FStarC_Syntax_Syntax.mk_binder + uu___5 in + (uu___4, g) in + (match uu___2 with + | (f, guard_f) -> + let uu___3 = + let x_a = + let uu___4 = + let uu___5 = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + FStarC_Syntax_Syntax.gen_bv + "x" + FStar_Pervasives_Native.None + uu___5 in + FStarC_Syntax_Syntax.mk_binder + uu___4 in + let uu___4 = + let uu___5 = + FStarC_TypeChecker_Env.push_binders + env + (FStarC_Compiler_List.op_At + (a_b :: b_b :: + rest_bs1) [x_a]) in + let uu___6 = + FStarC_Syntax_Syntax.bv_to_name + b_b.FStarC_Syntax_Syntax.binder_bv in + FStarC_TypeChecker_Util.fresh_effect_repr + uu___5 r n_eff_name + n_sig_ts n_repr_ts + (FStarC_Syntax_Syntax.U_name + u_b) uu___6 in + match uu___4 with + | (repr, g) -> + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Syntax.mk_Total + repr in + FStarC_Syntax_Util.arrow + [x_a] uu___8 in + FStarC_Syntax_Syntax.gen_bv + "g" + FStar_Pervasives_Native.None + uu___7 in + FStarC_Syntax_Syntax.mk_binder + uu___6 in + (uu___5, g) in + (match uu___3 with + | (g, guard_g) -> + let uu___4 = + let uu___5 = + FStarC_TypeChecker_Env.push_binders + env (a_b :: b_b :: + rest_bs1) in + let uu___6 = + FStarC_Syntax_Syntax.bv_to_name + b_b.FStarC_Syntax_Syntax.binder_bv in + FStarC_TypeChecker_Util.fresh_effect_repr + uu___5 r p_eff_name + p_sig_ts p_repr_ts + (FStarC_Syntax_Syntax.U_name + u_b) uu___6 in + (match uu___4 with + | (return_repr, + guard_return_repr) -> + let uu___5 = + let uu___6 = + FStarC_TypeChecker_Env.push_binders + env (a_b :: b_b + :: rest_bs1) in + let uu___7 = + FStarC_Compiler_Util.format1 + "implicit for pure_wp in checking bind %s" + bind_name in + pure_wp_uvar uu___6 + return_repr + uu___7 r in + (match uu___5 with + | (pure_wp_uvar1, + g_pure_wp_uvar) + -> + let k = + let uu___6 = + let uu___7 = + let uu___8 + = + let uu___9 + = + FStarC_TypeChecker_Env.new_u_univ + () in + [uu___9] in + let uu___9 + = + let uu___10 + = + FStarC_Syntax_Syntax.as_arg + pure_wp_uvar1 in + [uu___10] in + { + FStarC_Syntax_Syntax.comp_univs + = uu___8; + FStarC_Syntax_Syntax.effect_name + = + FStarC_Parser_Const.effect_PURE_lid; + FStarC_Syntax_Syntax.result_typ + = + return_repr; + FStarC_Syntax_Syntax.effect_args + = uu___9; + FStarC_Syntax_Syntax.flags + = [] + } in + FStarC_Syntax_Syntax.mk_Comp + uu___7 in + FStarC_Syntax_Util.arrow + (a_b :: b_b + :: + (FStarC_Compiler_List.op_At + rest_bs1 + ( + FStarC_Compiler_List.op_At + range_bs + [f; g]))) + uu___6 in + let guard_eq = + let uu___6 = + FStarC_TypeChecker_Rel.teq_nosmt + env k + bind_t in + match uu___6 + with + | FStar_Pervasives_Native.None + -> + let uu___7 + = + let uu___8 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + bind_t in + FStarC_Compiler_Util.format2 + "Unexpected type of %s (%s)\n" + bind_name + uu___8 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + r + FStarC_Errors_Codes.Fatal_UnexpectedEffect + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + uu___7) + | FStar_Pervasives_Native.Some + g1 -> g1 in + ((let uu___7 = + FStarC_TypeChecker_Env.conj_guards + [guard_f; + guard_g; + guard_return_repr; + g_pure_wp_uvar; + guard_eq] in + FStarC_TypeChecker_Rel.force_trivial_guard + env uu___7); + (let k1 = + let uu___7 = + FStarC_TypeChecker_Normalize.remove_uvar_solutions + env k in + FStarC_Syntax_Subst.compress + uu___7 in + let lopt = + bind_combinator_kind + env + m_eff_name + n_eff_name + p_eff_name + m_sig_ts + n_sig_ts + p_sig_ts + m_repr_ts + n_repr_ts + p_repr_ts + bind_us k1 + num_effect_params + has_range_binders in + let kind = + match lopt + with + | FStar_Pervasives_Native.None + -> + (log_ad_hoc_combinator_warning + bind_name + r; + FStarC_Syntax_Syntax.Ad_hoc_combinator) + | FStar_Pervasives_Native.Some + l -> + FStarC_Syntax_Syntax.Substitutive_combinator + l in + (let uu___8 = + (FStarC_Compiler_Debug.medium + ()) || + ( + FStarC_Compiler_Effect.op_Bang + dbg_LayeredEffectsTc) in + if uu___8 + then + let uu___9 + = + FStarC_Class_Show.show + FStarC_Syntax_Syntax.showable_indexed_effect_combinator_kind + kind in + FStarC_Compiler_Util.print2 + "Bind %s has %s kind\n" + bind_name + uu___9 + else ()); + (k1, kind)))))))) +let (subcomp_combinator_kind : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.tscheme -> + FStarC_Syntax_Syntax.tscheme -> + FStarC_Syntax_Syntax.tscheme FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.tscheme FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.univ_name -> + FStarC_Syntax_Syntax.typ -> + Prims.int -> + FStarC_Syntax_Syntax.indexed_effect_combinator_kind + FStar_Pervasives_Native.option) + = + fun env -> + fun m_eff_name -> + fun n_eff_name -> + fun m_sig_ts -> + fun n_sig_ts -> + fun m_repr_ts -> + fun n_repr_ts -> + fun u -> + fun k -> + fun num_effect_params -> + let uu___ = FStarC_Syntax_Util.arrow_formals_comp k in + match uu___ with + | (a_b::rest_bs, k_c) -> + let uu___1 = + if num_effect_params = Prims.int_zero + then + FStar_Pervasives_Native.Some ([], [], rest_bs) + else + (let uu___3 = + FStarC_TypeChecker_Env.inst_tscheme_with + m_sig_ts [FStarC_Syntax_Syntax.U_name u] in + match uu___3 with + | (uu___4, sig1) -> + let uu___5 = + FStarC_Syntax_Util.arrow_formals sig1 in + (match uu___5 with + | (uu___6::sig_bs, uu___7) -> + let sig_effect_params_bs = + let uu___8 = + FStarC_Compiler_List.splitAt + num_effect_params sig_bs in + FStar_Pervasives_Native.fst uu___8 in + let uu___8 = + FStarC_Compiler_List.splitAt + num_effect_params rest_bs in + (match uu___8 with + | (eff_params_bs, rest_bs1) -> + let uu___9 = + eq_binders env + sig_effect_params_bs + eff_params_bs in + op_let_Question uu___9 + (fun eff_params_bs_kinds -> + FStar_Pervasives_Native.Some + (eff_params_bs, + eff_params_bs_kinds, + rest_bs1))))) in + op_let_Question uu___1 + (fun uu___2 -> + match uu___2 with + | (eff_params_bs, eff_params_bs_kinds, + rest_bs1) -> + let uu___3 = + let f_sig_bs = + let uu___4 = + FStarC_TypeChecker_Env.inst_tscheme_with + m_sig_ts + [FStarC_Syntax_Syntax.U_name u] in + match uu___4 with + | (uu___5, sig1) -> + let uu___6 = + let uu___7 = + FStarC_Syntax_Util.arrow_formals + sig1 in + FStar_Pervasives_Native.fst + uu___7 in + (match uu___6 with + | a::bs -> + let uu___7 = + FStarC_Compiler_List.splitAt + num_effect_params bs in + (match uu___7 with + | (sig_bs, bs1) -> + let ss = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + ((a.FStarC_Syntax_Syntax.binder_bv), + uu___11) in + FStarC_Syntax_Syntax.NT + uu___10 in + [uu___9] in + FStarC_Compiler_List.fold_left2 + (fun ss1 -> + fun sig_b -> + fun b -> + let uu___9 = + let uu___10 + = + let uu___11 + = + let uu___12 + = + FStarC_Syntax_Syntax.bv_to_name + b.FStarC_Syntax_Syntax.binder_bv in + ((sig_b.FStarC_Syntax_Syntax.binder_bv), + uu___12) in + FStarC_Syntax_Syntax.NT + uu___11 in + [uu___10] in + FStarC_Compiler_List.op_At + ss1 uu___9) + uu___8 sig_bs + eff_params_bs in + FStarC_Syntax_Subst.subst_binders + ss bs1)) in + let uu___4 = + if + (FStarC_Compiler_List.length + rest_bs1) + < + (FStarC_Compiler_List.length + f_sig_bs) + then FStar_Pervasives_Native.None + else + (let uu___6 = + FStarC_Compiler_List.splitAt + (FStarC_Compiler_List.length + f_sig_bs) rest_bs1 in + FStar_Pervasives_Native.Some uu___6) in + op_let_Question uu___4 + (fun uu___5 -> + match uu___5 with + | (f_bs, rest_bs2) -> + let uu___6 = + eq_binders env f_sig_bs f_bs in + op_let_Question uu___6 + (fun f_bs_kinds -> + FStar_Pervasives_Native.Some + (f_bs, f_bs_kinds, + rest_bs2))) in + op_let_Question uu___3 + (fun uu___4 -> + match uu___4 with + | (f_bs, f_bs_kinds, rest_bs2) -> + let uu___5 = + if + (FStarC_Compiler_List.length + rest_bs2) + >= Prims.int_one + then + let uu___6 = + FStarC_Compiler_List.splitAt + ((FStarC_Compiler_List.length + rest_bs2) + - Prims.int_one) + rest_bs2 in + match uu___6 with + | (rest_bs3, f_b::[]) -> + FStar_Pervasives_Native.Some + (rest_bs3, f_b) + else + FStar_Pervasives_Native.None in + op_let_Question uu___5 + (fun uu___6 -> + match uu___6 with + | (rest_bs3, f_b) -> + let uu___7 = + let expected_f_b_sort + = + match m_repr_ts with + | FStar_Pervasives_Native.Some + repr_ts -> + let uu___8 = + FStarC_TypeChecker_Env.inst_tscheme_with + repr_ts + [FStarC_Syntax_Syntax.U_name + u] in + (match uu___8 + with + | (uu___9, t) + -> + let uu___10 + = + let uu___11 + = + let uu___12 + = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + FStarC_Syntax_Syntax.as_arg + uu___12 in + let uu___12 + = + FStarC_Compiler_List.map + (fun + uu___13 + -> + match uu___13 + with + | + { + FStarC_Syntax_Syntax.binder_bv + = b; + FStarC_Syntax_Syntax.binder_qual + = uu___14; + FStarC_Syntax_Syntax.binder_positivity + = uu___15; + FStarC_Syntax_Syntax.binder_attrs + = uu___16;_} + -> + let uu___17 + = + FStarC_Syntax_Syntax.bv_to_name + b in + FStarC_Syntax_Syntax.as_arg + uu___17) + (FStarC_Compiler_List.op_At + eff_params_bs + f_bs) in + uu___11 + :: + uu___12 in + FStarC_Syntax_Syntax.mk_Tm_app + t uu___10 + FStarC_Compiler_Range_Type.dummyRange) + | FStar_Pervasives_Native.None + -> + let uu___8 = + let uu___9 = + FStarC_Syntax_Syntax.null_binder + FStarC_Syntax_Syntax.t_unit in + [uu___9] in + let uu___9 = + let uu___10 = + let uu___11 + = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + let uu___12 + = + FStarC_Compiler_List.map + (fun b -> + let uu___13 + = + FStarC_Syntax_Syntax.bv_to_name + b.FStarC_Syntax_Syntax.binder_bv in + FStarC_Syntax_Syntax.as_arg + uu___13) + (FStarC_Compiler_List.op_At + eff_params_bs + f_bs) in + { + FStarC_Syntax_Syntax.comp_univs + = + [ + FStarC_Syntax_Syntax.U_name + u]; + FStarC_Syntax_Syntax.effect_name + = + m_eff_name; + FStarC_Syntax_Syntax.result_typ + = uu___11; + FStarC_Syntax_Syntax.effect_args + = uu___12; + FStarC_Syntax_Syntax.flags + = [] + } in + FStarC_Syntax_Syntax.mk_Comp + uu___10 in + FStarC_Syntax_Util.arrow + uu___8 uu___9 in + let uu___8 = + let uu___9 = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm + env + (f_b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort + expected_f_b_sort in + uu___9 = + FStarC_TypeChecker_TermEqAndSimplify.Equal in + if uu___8 + then + FStar_Pervasives_Native.Some + () + else + FStar_Pervasives_Native.None in + op_let_Question uu___7 + (fun _f_b_ok_ -> + let check_ret_t + f_or_g_bs = + let expected_t = + match n_repr_ts + with + | FStar_Pervasives_Native.Some + repr_ts -> + let uu___8 + = + FStarC_TypeChecker_Env.inst_tscheme_with + repr_ts + [ + FStarC_Syntax_Syntax.U_name + u] in + (match uu___8 + with + | + (uu___9, + t) -> + let uu___10 + = + let uu___11 + = + let uu___12 + = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + FStarC_Syntax_Syntax.as_arg + uu___12 in + let uu___12 + = + FStarC_Compiler_List.map + (fun + uu___13 + -> + match uu___13 + with + | + { + FStarC_Syntax_Syntax.binder_bv + = b; + FStarC_Syntax_Syntax.binder_qual + = uu___14; + FStarC_Syntax_Syntax.binder_positivity + = uu___15; + FStarC_Syntax_Syntax.binder_attrs + = uu___16;_} + -> + let uu___17 + = + FStarC_Syntax_Syntax.bv_to_name + b in + FStarC_Syntax_Syntax.as_arg + uu___17) + (FStarC_Compiler_List.op_At + eff_params_bs + f_or_g_bs) in + uu___11 + :: + uu___12 in + FStarC_Syntax_Syntax.mk_Tm_app + t uu___10 + FStarC_Compiler_Range_Type.dummyRange) + | FStar_Pervasives_Native.None + -> + let uu___8 + = + let uu___9 + = + FStarC_Syntax_Syntax.null_binder + FStarC_Syntax_Syntax.t_unit in + [uu___9] in + let uu___9 + = + let uu___10 + = + let uu___11 + = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + let uu___12 + = + FStarC_Compiler_List.map + (fun b -> + let uu___13 + = + FStarC_Syntax_Syntax.bv_to_name + b.FStarC_Syntax_Syntax.binder_bv in + FStarC_Syntax_Syntax.as_arg + uu___13) + (FStarC_Compiler_List.op_At + eff_params_bs + f_or_g_bs) in + { + FStarC_Syntax_Syntax.comp_univs + = + [ + FStarC_Syntax_Syntax.U_name + u]; + FStarC_Syntax_Syntax.effect_name + = + n_eff_name; + FStarC_Syntax_Syntax.result_typ + = uu___11; + FStarC_Syntax_Syntax.effect_args + = uu___12; + FStarC_Syntax_Syntax.flags + = [] + } in + FStarC_Syntax_Syntax.mk_Comp + uu___10 in + FStarC_Syntax_Util.arrow + uu___8 + uu___9 in + let uu___8 = + let uu___9 = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm + env + (FStarC_Syntax_Util.comp_result + k_c) + expected_t in + uu___9 = + FStarC_TypeChecker_TermEqAndSimplify.Equal in + if uu___8 + then + FStar_Pervasives_Native.Some + () + else + FStar_Pervasives_Native.None in + let uu___8 = + let uu___9 = + check_ret_t + f_bs in + FStar_Pervasives_Native.uu___is_Some + uu___9 in + if uu___8 + then + FStar_Pervasives_Native.Some + FStarC_Syntax_Syntax.Substitutive_invariant_combinator + else + (let uu___10 = + let g_sig_bs = + let uu___11 + = + FStarC_TypeChecker_Env.inst_tscheme_with + n_sig_ts + [ + FStarC_Syntax_Syntax.U_name + u] in + match uu___11 + with + | (uu___12, + sig1) -> + let uu___13 + = + let uu___14 + = + FStarC_Syntax_Util.arrow_formals + sig1 in + FStar_Pervasives_Native.fst + uu___14 in + (match uu___13 + with + | + a::bs -> + let uu___14 + = + FStarC_Compiler_List.splitAt + num_effect_params + bs in + (match uu___14 + with + | + (sig_bs, + bs1) -> + let ss = + let uu___15 + = + let uu___16 + = + let uu___17 + = + let uu___18 + = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + ((a.FStarC_Syntax_Syntax.binder_bv), + uu___18) in + FStarC_Syntax_Syntax.NT + uu___17 in + [uu___16] in + FStarC_Compiler_List.fold_left2 + (fun ss1 + -> + fun sig_b + -> + fun b -> + let uu___16 + = + let uu___17 + = + let uu___18 + = + let uu___19 + = + FStarC_Syntax_Syntax.bv_to_name + b.FStarC_Syntax_Syntax.binder_bv in + ((sig_b.FStarC_Syntax_Syntax.binder_bv), + uu___19) in + FStarC_Syntax_Syntax.NT + uu___18 in + [uu___17] in + FStarC_Compiler_List.op_At + ss1 + uu___16) + uu___15 + sig_bs + eff_params_bs in + FStarC_Syntax_Subst.subst_binders + ss bs1)) in + let uu___11 = + if + (FStarC_Compiler_List.length + rest_bs3) + < + (FStarC_Compiler_List.length + g_sig_bs) + then + FStar_Pervasives_Native.None + else + (let uu___13 + = + FStarC_Compiler_List.splitAt + (FStarC_Compiler_List.length + g_sig_bs) + rest_bs3 in + FStar_Pervasives_Native.Some + uu___13) in + op_let_Question + uu___11 + (fun uu___12 + -> + match uu___12 + with + | + (g_bs, + rest_bs4) + -> + let uu___13 + = + eq_binders + env + g_sig_bs + g_bs in + op_let_Question + uu___13 + (fun + g_bs_kinds + -> + FStar_Pervasives_Native.Some + (g_bs, + g_bs_kinds, + rest_bs4))) in + op_let_Question + uu___10 + (fun uu___11 + -> + match uu___11 + with + | (g_bs, + g_bs_kinds, + rest_bs4) + -> + let uu___12 + = + check_ret_t + g_bs in + op_let_Question + uu___12 + (fun + _ret_t_ok_ + -> + let rest_kinds + = + FStarC_Compiler_List.map + (fun + uu___13 + -> + FStarC_Syntax_Syntax.Ad_hoc_binder) + rest_bs4 in + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Substitutive_combinator + (FStarC_Compiler_List.op_At + [FStarC_Syntax_Syntax.Type_binder] + (FStarC_Compiler_List.op_At + eff_params_bs_kinds + (FStarC_Compiler_List.op_At + f_bs_kinds + (FStarC_Compiler_List.op_At + g_bs_kinds + (FStarC_Compiler_List.op_At + rest_kinds + [FStarC_Syntax_Syntax.Repr_binder]))))))))))))) +let (validate_indexed_effect_subcomp_shape : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.tscheme -> + FStarC_Syntax_Syntax.tscheme -> + FStarC_Syntax_Syntax.tscheme FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.tscheme FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.univ_name -> + FStarC_Syntax_Syntax.typ -> + Prims.int -> + FStarC_Compiler_Range_Type.range -> + (FStarC_Syntax_Syntax.typ * + FStarC_Syntax_Syntax.indexed_effect_combinator_kind)) + = + fun env -> + fun m_eff_name -> + fun n_eff_name -> + fun m_sig_ts -> + fun n_sig_ts -> + fun m_repr_ts -> + fun n_repr_ts -> + fun u -> + fun subcomp_t -> + fun num_effect_params -> + fun r -> + let subcomp_name = + let uu___ = FStarC_Ident.string_of_lid m_eff_name in + let uu___1 = FStarC_Ident.string_of_lid n_eff_name in + FStarC_Compiler_Util.format2 "%s <: %s" uu___ + uu___1 in + let a_b = + let uu___ = + let uu___1 = + FStarC_Syntax_Util.type_with_u + (FStarC_Syntax_Syntax.U_name u) in + FStarC_Syntax_Syntax.gen_bv "a" + FStar_Pervasives_Native.None uu___1 in + FStarC_Syntax_Syntax.mk_binder uu___ in + let rest_bs = + let uu___ = + let uu___1 = + FStarC_Syntax_Subst.compress subcomp_t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = uu___1;_} + when + (FStarC_Compiler_List.length bs) >= + (Prims.of_int (2)) + -> + let uu___2 = + FStarC_Syntax_Subst.open_binders bs in + (match uu___2 with + | { FStarC_Syntax_Syntax.binder_bv = a; + FStarC_Syntax_Syntax.binder_qual = uu___3; + FStarC_Syntax_Syntax.binder_positivity = + uu___4; + FStarC_Syntax_Syntax.binder_attrs = uu___5;_}::bs1 + -> + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + (a, uu___9) in + FStarC_Syntax_Syntax.NT uu___8 in + [uu___7] in + let uu___7 = + let uu___8 = + FStarC_Compiler_List.splitAt + ((FStarC_Compiler_List.length bs1) - + Prims.int_one) bs1 in + FStar_Pervasives_Native.fst uu___8 in + FStarC_Syntax_Subst.subst_binders uu___6 + uu___7) + | uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + subcomp_t in + FStarC_Compiler_Util.format2 + "Type of %s is not an arrow with >= 2 binders (%s)" + subcomp_name uu___3 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_UnexpectedEffect () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2) in + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_Env.push_binders env (a_b :: + rest_bs) in + let uu___3 = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + FStarC_TypeChecker_Util.fresh_effect_repr uu___2 + r m_eff_name m_sig_ts m_repr_ts + (FStarC_Syntax_Syntax.U_name u) uu___3 in + match uu___1 with + | (repr, g) -> + let uu___2 = + let uu___3 = + FStarC_Syntax_Syntax.gen_bv "f" + FStar_Pervasives_Native.None repr in + FStarC_Syntax_Syntax.mk_binder uu___3 in + (uu___2, g) in + match uu___ with + | (f, guard_f) -> + let uu___1 = + let uu___2 = + FStarC_TypeChecker_Env.push_binders env (a_b + :: rest_bs) in + let uu___3 = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + FStarC_TypeChecker_Util.fresh_effect_repr + uu___2 r n_eff_name n_sig_ts n_repr_ts + (FStarC_Syntax_Syntax.U_name u) uu___3 in + (match uu___1 with + | (ret_t, guard_ret_t) -> + let uu___2 = + let uu___3 = + FStarC_TypeChecker_Env.push_binders env + (a_b :: rest_bs) in + let uu___4 = + FStarC_Compiler_Util.format1 + "implicit for pure_wp in checking %s" + subcomp_name in + pure_wp_uvar uu___3 ret_t uu___4 r in + (match uu___2 with + | (pure_wp_uvar1, guard_wp) -> + let c = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_TypeChecker_Env.new_u_univ + () in + [uu___5] in + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.as_arg + pure_wp_uvar1 in + [uu___6] in + { + FStarC_Syntax_Syntax.comp_univs = + uu___4; + FStarC_Syntax_Syntax.effect_name + = + FStarC_Parser_Const.effect_PURE_lid; + FStarC_Syntax_Syntax.result_typ = + ret_t; + FStarC_Syntax_Syntax.effect_args + = uu___5; + FStarC_Syntax_Syntax.flags = [] + } in + FStarC_Syntax_Syntax.mk_Comp uu___3 in + let k = + FStarC_Syntax_Util.arrow + (FStarC_Compiler_List.op_At (a_b :: + rest_bs) [f]) c in + ((let uu___4 = + (FStarC_Compiler_Debug.medium ()) + || + (FStarC_Compiler_Effect.op_Bang + dbg_LayeredEffectsTc) in + if uu___4 + then + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + k in + FStarC_Compiler_Util.print1 + "Expected type of subcomp before unification: %s\n" + uu___5 + else ()); + (let guard_eq = + let uu___4 = + FStarC_TypeChecker_Rel.teq_nosmt + env subcomp_t k in + match uu___4 with + | FStar_Pervasives_Native.None -> + let uu___5 = + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + subcomp_t in + FStarC_Compiler_Util.format2 + "Unexpected type of %s (%s)\n" + subcomp_name uu___6 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + r + FStarC_Errors_Codes.Fatal_UnexpectedEffect + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___5) + | FStar_Pervasives_Native.Some g -> + g in + (let uu___5 = + FStarC_TypeChecker_Env.conj_guards + [guard_f; + guard_ret_t; + guard_wp; + guard_eq] in + FStarC_TypeChecker_Rel.force_trivial_guard + env uu___5); + (let k1 = + let uu___5 = + FStarC_TypeChecker_Normalize.remove_uvar_solutions + env k in + FStarC_Syntax_Subst.compress + uu___5 in + let kopt = + subcomp_combinator_kind env + m_eff_name n_eff_name m_sig_ts + n_sig_ts m_repr_ts n_repr_ts u + k1 num_effect_params in + let kind = + match kopt with + | FStar_Pervasives_Native.None -> + (log_ad_hoc_combinator_warning + subcomp_name r; + FStarC_Syntax_Syntax.Ad_hoc_combinator) + | FStar_Pervasives_Native.Some k2 + -> k2 in + (let uu___6 = + (FStarC_Compiler_Debug.medium ()) + || + (FStarC_Compiler_Effect.op_Bang + dbg_LayeredEffectsTc) in + if uu___6 + then + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Syntax.showable_indexed_effect_combinator_kind + kind in + FStarC_Compiler_Util.print2 + "Subcomp %s has %s kind\n" + subcomp_name uu___7 + else ()); + (k1, kind)))))) +let (ite_combinator_kind : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.tscheme -> + FStarC_Syntax_Syntax.tscheme -> + FStarC_Syntax_Syntax.univ_name -> + FStarC_Syntax_Syntax.term -> + Prims.int -> + FStarC_Syntax_Syntax.indexed_effect_combinator_kind + FStar_Pervasives_Native.option) + = + fun env -> + fun eff_name -> + fun sig_ts -> + fun repr_ts -> + fun u -> + fun tm -> + fun num_effect_params -> + let uu___ = FStarC_Syntax_Util.abs_formals tm in + match uu___ with + | (a_b::rest_bs, uu___1, uu___2) -> + let uu___3 = + if num_effect_params = Prims.int_zero + then FStar_Pervasives_Native.Some ([], [], rest_bs) + else + (let uu___5 = + FStarC_TypeChecker_Env.inst_tscheme_with sig_ts + [FStarC_Syntax_Syntax.U_name u] in + match uu___5 with + | (uu___6, sig1) -> + let uu___7 = + FStarC_Syntax_Util.arrow_formals sig1 in + (match uu___7 with + | (uu___8::sig_bs, uu___9) -> + let sig_effect_params_bs = + let uu___10 = + FStarC_Compiler_List.splitAt + num_effect_params sig_bs in + FStar_Pervasives_Native.fst uu___10 in + let uu___10 = + FStarC_Compiler_List.splitAt + num_effect_params rest_bs in + (match uu___10 with + | (eff_params_bs, rest_bs1) -> + let uu___11 = + eq_binders env sig_effect_params_bs + eff_params_bs in + op_let_Question uu___11 + (fun eff_params_bs_kinds -> + FStar_Pervasives_Native.Some + (eff_params_bs, + eff_params_bs_kinds, + rest_bs1))))) in + op_let_Question uu___3 + (fun uu___4 -> + match uu___4 with + | (eff_params_bs, eff_params_bs_kinds, rest_bs1) -> + let uu___5 = + let f_sig_bs = + let uu___6 = + FStarC_TypeChecker_Env.inst_tscheme_with + sig_ts [FStarC_Syntax_Syntax.U_name u] in + match uu___6 with + | (uu___7, sig1) -> + let uu___8 = + let uu___9 = + FStarC_Syntax_Util.arrow_formals + sig1 in + FStar_Pervasives_Native.fst uu___9 in + (match uu___8 with + | a::bs -> + let uu___9 = + FStarC_Compiler_List.splitAt + num_effect_params bs in + (match uu___9 with + | (sig_bs, bs1) -> + let ss = + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + ((a.FStarC_Syntax_Syntax.binder_bv), + uu___13) in + FStarC_Syntax_Syntax.NT + uu___12 in + [uu___11] in + FStarC_Compiler_List.fold_left2 + (fun ss1 -> + fun sig_b -> + fun b -> + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_Syntax_Syntax.bv_to_name + b.FStarC_Syntax_Syntax.binder_bv in + ((sig_b.FStarC_Syntax_Syntax.binder_bv), + uu___14) in + FStarC_Syntax_Syntax.NT + uu___13 in + [uu___12] in + FStarC_Compiler_List.op_At + ss1 uu___11) + uu___10 sig_bs + eff_params_bs in + FStarC_Syntax_Subst.subst_binders + ss bs1)) in + let uu___6 = + if + (FStarC_Compiler_List.length rest_bs1) < + (FStarC_Compiler_List.length f_sig_bs) + then FStar_Pervasives_Native.None + else + (let uu___8 = + FStarC_Compiler_List.splitAt + (FStarC_Compiler_List.length f_sig_bs) + rest_bs1 in + FStar_Pervasives_Native.Some uu___8) in + op_let_Question uu___6 + (fun uu___7 -> + match uu___7 with + | (f_bs, rest_bs2) -> + let uu___8 = + eq_binders env f_sig_bs f_bs in + op_let_Question uu___8 + (fun f_bs_kinds -> + FStar_Pervasives_Native.Some + (f_bs, f_bs_kinds, rest_bs2))) in + op_let_Question uu___5 + (fun uu___6 -> + match uu___6 with + | (f_bs, f_bs_kinds, rest_bs2) -> + let uu___7 = + if + (FStarC_Compiler_List.length + rest_bs2) + >= (Prims.of_int (3)) + then + let uu___8 = + FStarC_Compiler_List.splitAt + ((FStarC_Compiler_List.length + rest_bs2) + - (Prims.of_int (3))) + rest_bs2 in + FStar_Pervasives_Native.Some uu___8 + else FStar_Pervasives_Native.None in + op_let_Question uu___7 + (fun uu___8 -> + match uu___8 with + | (rest_bs3, f_b::g_b::p_b::[]) -> + let uu___9 = + let expected_f_b_sort = + let uu___10 = + FStarC_TypeChecker_Env.inst_tscheme_with + repr_ts + [FStarC_Syntax_Syntax.U_name + u] in + match uu___10 with + | (uu___11, t) -> + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + FStarC_Syntax_Syntax.as_arg + uu___14 in + let uu___14 = + FStarC_Compiler_List.map + (fun uu___15 -> + match uu___15 + with + | { + FStarC_Syntax_Syntax.binder_bv + = b; + FStarC_Syntax_Syntax.binder_qual + = uu___16; + FStarC_Syntax_Syntax.binder_positivity + = uu___17; + FStarC_Syntax_Syntax.binder_attrs + = uu___18;_} + -> + let uu___19 + = + FStarC_Syntax_Syntax.bv_to_name + b in + FStarC_Syntax_Syntax.as_arg + uu___19) + (FStarC_Compiler_List.op_At + eff_params_bs + f_bs) in + uu___13 :: uu___14 in + FStarC_Syntax_Syntax.mk_Tm_app + t uu___12 + FStarC_Compiler_Range_Type.dummyRange in + let uu___10 = + let uu___11 = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm + env + (f_b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort + expected_f_b_sort in + uu___11 = + FStarC_TypeChecker_TermEqAndSimplify.Equal in + if uu___10 + then + FStar_Pervasives_Native.Some + () + else + FStar_Pervasives_Native.None in + op_let_Question uu___9 + (fun _f_b_ok_ -> + let check_g_b f_or_g_bs = + let expected_g_b_sort = + let uu___10 = + FStarC_TypeChecker_Env.inst_tscheme_with + repr_ts + [FStarC_Syntax_Syntax.U_name + u] in + match uu___10 with + | (uu___11, t) -> + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + FStarC_Syntax_Syntax.as_arg + uu___14 in + let uu___14 = + FStarC_Compiler_List.map + (fun + uu___15 + -> + match uu___15 + with + | + { + FStarC_Syntax_Syntax.binder_bv + = b; + FStarC_Syntax_Syntax.binder_qual + = uu___16; + FStarC_Syntax_Syntax.binder_positivity + = uu___17; + FStarC_Syntax_Syntax.binder_attrs + = uu___18;_} + -> + let uu___19 + = + FStarC_Syntax_Syntax.bv_to_name + b in + FStarC_Syntax_Syntax.as_arg + uu___19) + (FStarC_Compiler_List.op_At + eff_params_bs + f_or_g_bs) in + uu___13 :: + uu___14 in + FStarC_Syntax_Syntax.mk_Tm_app + t uu___12 + FStarC_Compiler_Range_Type.dummyRange in + let uu___10 = + let uu___11 = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm + env + (g_b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort + expected_g_b_sort in + uu___11 = + FStarC_TypeChecker_TermEqAndSimplify.Equal in + if uu___10 + then + FStar_Pervasives_Native.Some + () + else + FStar_Pervasives_Native.None in + let uu___10 = + let uu___11 = + check_g_b f_bs in + FStar_Pervasives_Native.uu___is_Some + uu___11 in + if uu___10 + then + FStar_Pervasives_Native.Some + FStarC_Syntax_Syntax.Substitutive_invariant_combinator + else + (let uu___12 = + let g_sig_bs = + let uu___13 = + FStarC_TypeChecker_Env.inst_tscheme_with + sig_ts + [FStarC_Syntax_Syntax.U_name + u] in + match uu___13 with + | (uu___14, sig1) + -> + let uu___15 = + let uu___16 + = + FStarC_Syntax_Util.arrow_formals + sig1 in + FStar_Pervasives_Native.fst + uu___16 in + (match uu___15 + with + | a::bs -> + let uu___16 + = + FStarC_Compiler_List.splitAt + num_effect_params + bs in + (match uu___16 + with + | + (sig_bs, + bs1) -> + let ss = + let uu___17 + = + let uu___18 + = + let uu___19 + = + let uu___20 + = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + ((a.FStarC_Syntax_Syntax.binder_bv), + uu___20) in + FStarC_Syntax_Syntax.NT + uu___19 in + [uu___18] in + FStarC_Compiler_List.fold_left2 + (fun ss1 + -> + fun sig_b + -> + fun b -> + let uu___18 + = + let uu___19 + = + let uu___20 + = + let uu___21 + = + FStarC_Syntax_Syntax.bv_to_name + b.FStarC_Syntax_Syntax.binder_bv in + ((sig_b.FStarC_Syntax_Syntax.binder_bv), + uu___21) in + FStarC_Syntax_Syntax.NT + uu___20 in + [uu___19] in + FStarC_Compiler_List.op_At + ss1 + uu___18) + uu___17 + sig_bs + eff_params_bs in + FStarC_Syntax_Subst.subst_binders + ss bs1)) in + let uu___13 = + if + (FStarC_Compiler_List.length + rest_bs3) + < + (FStarC_Compiler_List.length + g_sig_bs) + then + FStar_Pervasives_Native.None + else + (let uu___15 = + FStarC_Compiler_List.splitAt + (FStarC_Compiler_List.length + g_sig_bs) + rest_bs3 in + FStar_Pervasives_Native.Some + uu___15) in + op_let_Question + uu___13 + (fun uu___14 -> + match uu___14 + with + | (g_bs, + rest_bs4) -> + let uu___15 + = + eq_binders + env + g_sig_bs + g_bs in + op_let_Question + uu___15 + ( + fun + g_bs_kinds + -> + FStar_Pervasives_Native.Some + (g_bs, + g_bs_kinds, + rest_bs4))) in + op_let_Question + uu___12 + (fun uu___13 -> + match uu___13 + with + | (g_bs, + g_bs_kinds, + rest_bs4) -> + let uu___14 = + check_g_b + g_bs in + op_let_Question + uu___14 + (fun + _g_b_ok_ + -> + let rest_kinds + = + FStarC_Compiler_List.map + (fun + uu___15 + -> + FStarC_Syntax_Syntax.Ad_hoc_binder) + rest_bs4 in + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Substitutive_combinator + (FStarC_Compiler_List.op_At + [FStarC_Syntax_Syntax.Type_binder] + (FStarC_Compiler_List.op_At + eff_params_bs_kinds + (FStarC_Compiler_List.op_At + f_bs_kinds + (FStarC_Compiler_List.op_At + g_bs_kinds + (FStarC_Compiler_List.op_At + rest_kinds + [FStarC_Syntax_Syntax.Repr_binder; + FStarC_Syntax_Syntax.Repr_binder; + FStarC_Syntax_Syntax.Substitutive_binder]))))))))))))) +let (validate_indexed_effect_ite_shape : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.tscheme -> + FStarC_Syntax_Syntax.tscheme -> + FStarC_Syntax_Syntax.univ_name -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.term -> + Prims.int -> + FStarC_Compiler_Range_Type.range -> + (FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.indexed_effect_combinator_kind)) + = + fun env -> + fun eff_name -> + fun sig_ts -> + fun repr_ts -> + fun u -> + fun ite_ty -> + fun ite_tm -> + fun num_effect_params -> + fun r -> + let ite_name = + let uu___ = FStarC_Ident.string_of_lid eff_name in + FStarC_Compiler_Util.format1 "ite_%s" uu___ in + let a_b = + let uu___ = + let uu___1 = + FStarC_Syntax_Util.type_with_u + (FStarC_Syntax_Syntax.U_name u) in + FStarC_Syntax_Syntax.gen_bv "a" + FStar_Pervasives_Native.None uu___1 in + FStarC_Syntax_Syntax.mk_binder uu___ in + let rest_bs = + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress ite_ty in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = uu___1;_} + when + (FStarC_Compiler_List.length bs) >= + (Prims.of_int (4)) + -> + let uu___2 = FStarC_Syntax_Subst.open_binders bs in + (match uu___2 with + | { FStarC_Syntax_Syntax.binder_bv = a; + FStarC_Syntax_Syntax.binder_qual = uu___3; + FStarC_Syntax_Syntax.binder_positivity = + uu___4; + FStarC_Syntax_Syntax.binder_attrs = uu___5;_}::bs1 + -> + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + (a, uu___9) in + FStarC_Syntax_Syntax.NT uu___8 in + [uu___7] in + let uu___7 = + let uu___8 = + FStarC_Compiler_List.splitAt + ((FStarC_Compiler_List.length bs1) - + (Prims.of_int (3))) bs1 in + FStar_Pervasives_Native.fst uu___8 in + FStarC_Syntax_Subst.subst_binders uu___6 + uu___7) + | uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term ite_ty in + FStarC_Compiler_Util.format2 + "Type of %s is not an arrow with >= 4 binders (%s)" + ite_name uu___3 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_UnexpectedEffect () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2) in + let uu___ = + let uu___1 = + let uu___2 = + FStarC_TypeChecker_Env.push_binders env (a_b :: + rest_bs) in + let uu___3 = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + FStarC_TypeChecker_Util.fresh_effect_repr uu___2 r + eff_name sig_ts + (FStar_Pervasives_Native.Some repr_ts) + (FStarC_Syntax_Syntax.U_name u) uu___3 in + match uu___1 with + | (repr, g) -> + let uu___2 = + let uu___3 = + FStarC_Syntax_Syntax.gen_bv "f" + FStar_Pervasives_Native.None repr in + FStarC_Syntax_Syntax.mk_binder uu___3 in + (uu___2, g) in + match uu___ with + | (f, guard_f) -> + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_TypeChecker_Env.push_binders env (a_b :: + rest_bs) in + let uu___4 = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + FStarC_TypeChecker_Util.fresh_effect_repr uu___3 + r eff_name sig_ts + (FStar_Pervasives_Native.Some repr_ts) + (FStarC_Syntax_Syntax.U_name u) uu___4 in + match uu___2 with + | (repr, g) -> + let uu___3 = + let uu___4 = + FStarC_Syntax_Syntax.gen_bv "g" + FStar_Pervasives_Native.None repr in + FStarC_Syntax_Syntax.mk_binder uu___4 in + (uu___3, g) in + (match uu___1 with + | (g, guard_g) -> + let p = + let uu___2 = + FStarC_Syntax_Syntax.gen_bv "p" + FStar_Pervasives_Native.None + FStarC_Syntax_Util.t_bool in + FStarC_Syntax_Syntax.mk_binder uu___2 in + let uu___2 = + let uu___3 = + FStarC_TypeChecker_Env.push_binders env + (FStarC_Compiler_List.op_At (a_b :: + rest_bs) [p]) in + let uu___4 = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + FStarC_TypeChecker_Util.fresh_effect_repr + uu___3 r eff_name sig_ts + (FStar_Pervasives_Native.Some repr_ts) + (FStarC_Syntax_Syntax.U_name u) uu___4 in + (match uu___2 with + | (body_tm, guard_body) -> + let k = + FStarC_Syntax_Util.abs + (FStarC_Compiler_List.op_At (a_b :: + rest_bs) [f; g; p]) body_tm + FStar_Pervasives_Native.None in + let guard_eq = + let uu___3 = + FStarC_TypeChecker_Rel.teq_nosmt env + ite_tm k in + match uu___3 with + | FStar_Pervasives_Native.None -> + let uu___4 = + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + ite_tm in + FStarC_Compiler_Util.format2 + "Unexpected term for %s (%s)\n" + ite_name uu___5 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + r + FStarC_Errors_Codes.Fatal_UnexpectedEffect + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4) + | FStar_Pervasives_Native.Some g1 -> g1 in + ((let uu___4 = + FStarC_TypeChecker_Env.conj_guards + [guard_f; + guard_g; + guard_body; + guard_eq] in + FStarC_TypeChecker_Rel.force_trivial_guard + env uu___4); + (let k1 = + let uu___4 = + FStarC_TypeChecker_Normalize.remove_uvar_solutions + env k in + FStarC_Syntax_Subst.compress uu___4 in + let kopt = + ite_combinator_kind env eff_name sig_ts + repr_ts u k1 num_effect_params in + let kind = + match kopt with + | FStar_Pervasives_Native.None -> + (log_ad_hoc_combinator_warning + ite_name r; + FStarC_Syntax_Syntax.Ad_hoc_combinator) + | FStar_Pervasives_Native.Some k2 -> k2 in + (let uu___5 = + (FStarC_Compiler_Debug.medium ()) || + (FStarC_Compiler_Effect.op_Bang + dbg_LayeredEffectsTc) in + if uu___5 + then + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Syntax.showable_indexed_effect_combinator_kind + kind in + FStarC_Compiler_Util.print2 + "Ite %s has %s kind\n" ite_name + uu___6 + else ()); + (k1, kind))))) +let (validate_indexed_effect_close_shape : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.tscheme -> + FStarC_Syntax_Syntax.tscheme -> + FStarC_Syntax_Syntax.univ_name -> + FStarC_Syntax_Syntax.univ_name -> + FStarC_Syntax_Syntax.term -> + Prims.int -> + FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.term) + = + fun env -> + fun eff_name -> + fun sig_ts -> + fun repr_ts -> + fun u_a -> + fun u_b -> + fun close_tm -> + fun num_effect_params -> + fun r -> + let close_name = + let uu___ = FStarC_Ident.string_of_lid eff_name in + FStarC_Compiler_Util.format1 "close_%s" uu___ in + let b_b = + let uu___ = + let uu___1 = + FStarC_Syntax_Util.type_with_u + (FStarC_Syntax_Syntax.U_name u_b) in + FStarC_Syntax_Syntax.gen_bv "b" + FStar_Pervasives_Native.None uu___1 in + FStarC_Syntax_Syntax.mk_binder uu___ in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_TypeChecker_Env.inst_tscheme_with sig_ts + [FStarC_Syntax_Syntax.U_name u_a] in + FStar_Pervasives_Native.snd uu___3 in + FStarC_Syntax_Util.arrow_formals uu___2 in + FStar_Pervasives_Native.fst uu___1 in + match uu___ with + | a_b::sig_bs -> + let uu___1 = + FStarC_Compiler_List.splitAt num_effect_params + sig_bs in + (match uu___1 with + | (eff_params_bs, sig_bs1) -> + let bs = + FStarC_Compiler_List.map + (fun b -> + let x_b = + let uu___2 = + let uu___3 = + FStarC_Syntax_Syntax.bv_to_name + b_b.FStarC_Syntax_Syntax.binder_bv in + FStarC_Syntax_Syntax.gen_bv "x" + FStar_Pervasives_Native.None uu___3 in + FStarC_Syntax_Syntax.mk_binder uu___2 in + let uu___2 = + let uu___3 = + b.FStarC_Syntax_Syntax.binder_bv in + let uu___4 = + let uu___5 = + FStarC_Syntax_Syntax.mk_Total + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + FStarC_Syntax_Util.arrow [x_b] uu___5 in + { + FStarC_Syntax_Syntax.ppname = + (uu___3.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (uu___3.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = uu___4 + } in + { + FStarC_Syntax_Syntax.binder_bv = uu___2; + FStarC_Syntax_Syntax.binder_qual = + (b.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity + = + (b.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs = + (b.FStarC_Syntax_Syntax.binder_attrs) + }) sig_bs1 in + let f_b = + let uu___2 = + FStarC_TypeChecker_Env.inst_tscheme_with + repr_ts [FStarC_Syntax_Syntax.U_name u_a] in + match uu___2 with + | (uu___3, repr_t) -> + let x_b = + let uu___4 = + let uu___5 = + FStarC_Syntax_Syntax.bv_to_name + b_b.FStarC_Syntax_Syntax.binder_bv in + FStarC_Syntax_Syntax.gen_bv "x" + FStar_Pervasives_Native.None uu___5 in + FStarC_Syntax_Syntax.mk_binder uu___4 in + let is_args = + FStarC_Compiler_List.map + (fun uu___4 -> + match uu___4 with + | { + FStarC_Syntax_Syntax.binder_bv + = binder_bv; + FStarC_Syntax_Syntax.binder_qual + = uu___5; + FStarC_Syntax_Syntax.binder_positivity + = uu___6; + FStarC_Syntax_Syntax.binder_attrs + = uu___7;_} + -> + let uu___8 = + let uu___9 = + FStarC_Syntax_Syntax.bv_to_name + binder_bv in + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Syntax_Syntax.bv_to_name + x_b.FStarC_Syntax_Syntax.binder_bv in + FStarC_Syntax_Syntax.as_arg + uu___12 in + [uu___11] in + FStarC_Syntax_Syntax.mk_Tm_app + uu___9 uu___10 + FStarC_Compiler_Range_Type.dummyRange in + FStarC_Syntax_Syntax.as_arg + uu___8) bs in + let repr_app = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + FStarC_Syntax_Syntax.as_arg uu___6 in + uu___5 :: is_args in + FStarC_Syntax_Syntax.mk_Tm_app repr_t + uu___4 + FStarC_Compiler_Range_Type.dummyRange in + let f_sort = + let uu___4 = + FStarC_Syntax_Syntax.mk_Total repr_app in + FStarC_Syntax_Util.arrow [x_b] uu___4 in + let uu___4 = + FStarC_Syntax_Syntax.gen_bv "f" + FStar_Pervasives_Native.None f_sort in + FStarC_Syntax_Syntax.mk_binder uu___4 in + let env1 = + FStarC_TypeChecker_Env.push_binders env (a_b + :: b_b :: + (FStarC_Compiler_List.op_At eff_params_bs bs)) in + let uu___2 = + let uu___3 = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + FStarC_TypeChecker_Util.fresh_effect_repr env1 + r eff_name sig_ts + (FStar_Pervasives_Native.Some repr_ts) + (FStarC_Syntax_Syntax.U_name u_a) uu___3 in + (match uu___2 with + | (body_tm, g_body) -> + let k = + FStarC_Syntax_Util.abs (a_b :: b_b :: + (FStarC_Compiler_List.op_At + eff_params_bs + (FStarC_Compiler_List.op_At bs [f_b]))) + body_tm FStar_Pervasives_Native.None in + let g_eq = + let uu___3 = + FStarC_TypeChecker_Rel.teq_nosmt env1 + close_tm k in + match uu___3 with + | FStar_Pervasives_Native.None -> + let uu___4 = + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + close_tm in + FStarC_Compiler_Util.format2 + "Unexpected term for %s (%s)\n" + close_name uu___5 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + r + FStarC_Errors_Codes.Fatal_UnexpectedEffect + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4) + | FStar_Pervasives_Native.Some g -> g in + ((let uu___4 = + FStarC_TypeChecker_Env.conj_guard + g_body g_eq in + FStarC_TypeChecker_Rel.force_trivial_guard + env1 uu___4); + (let uu___4 = + FStarC_TypeChecker_Normalize.remove_uvar_solutions + env1 k in + FStarC_Syntax_Subst.compress uu___4)))) +let (lift_combinator_kind : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.tscheme -> + FStarC_Syntax_Syntax.tscheme FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.univ_name -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.indexed_effect_binder_kind Prims.list + FStar_Pervasives_Native.option) + = + fun env -> + fun m_eff_name -> + fun m_sig_ts -> + fun m_repr_ts -> + fun u -> + fun k -> + let uu___ = FStarC_Syntax_Util.arrow_formals k in + match uu___ with + | (a_b::rest_bs, uu___1) -> + let uu___2 = + let f_sig_bs = + let uu___3 = + FStarC_TypeChecker_Env.inst_tscheme_with m_sig_ts + [FStarC_Syntax_Syntax.U_name u] in + match uu___3 with + | (uu___4, sig1) -> + let uu___5 = + let uu___6 = + FStarC_Syntax_Util.arrow_formals sig1 in + FStar_Pervasives_Native.fst uu___6 in + (match uu___5 with + | a::bs -> + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + ((a.FStarC_Syntax_Syntax.binder_bv), + uu___9) in + FStarC_Syntax_Syntax.NT uu___8 in + [uu___7] in + FStarC_Syntax_Subst.subst_binders uu___6 bs) in + let uu___3 = + if + (FStarC_Compiler_List.length rest_bs) < + (FStarC_Compiler_List.length f_sig_bs) + then FStar_Pervasives_Native.None + else + (let uu___5 = + FStarC_Compiler_List.splitAt + (FStarC_Compiler_List.length f_sig_bs) rest_bs in + FStar_Pervasives_Native.Some uu___5) in + op_let_Question uu___3 + (fun uu___4 -> + match uu___4 with + | (f_bs, rest_bs1) -> + let uu___5 = eq_binders env f_sig_bs f_bs in + op_let_Question uu___5 + (fun f_bs_kinds -> + FStar_Pervasives_Native.Some + (f_bs, f_bs_kinds, rest_bs1))) in + op_let_Question uu___2 + (fun uu___3 -> + match uu___3 with + | (f_bs, f_bs_kinds, rest_bs1) -> + let uu___4 = + if + (FStarC_Compiler_List.length rest_bs1) >= + Prims.int_one + then + let uu___5 = + FStarC_Compiler_List.splitAt + ((FStarC_Compiler_List.length rest_bs1) - + Prims.int_one) rest_bs1 in + match uu___5 with + | (rest_bs2, f_b::[]) -> + FStar_Pervasives_Native.Some + (rest_bs2, f_b) + else FStar_Pervasives_Native.None in + op_let_Question uu___4 + (fun uu___5 -> + match uu___5 with + | (rest_bs2, f_b) -> + let uu___6 = + let expected_f_b_sort = + match m_repr_ts with + | FStar_Pervasives_Native.Some + repr_ts -> + let uu___7 = + FStarC_TypeChecker_Env.inst_tscheme_with + repr_ts + [FStarC_Syntax_Syntax.U_name + u] in + (match uu___7 with + | (uu___8, t) -> + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + FStarC_Syntax_Syntax.as_arg + uu___11 in + let uu___11 = + FStarC_Compiler_List.map + (fun uu___12 -> + match uu___12 with + | { + FStarC_Syntax_Syntax.binder_bv + = b; + FStarC_Syntax_Syntax.binder_qual + = uu___13; + FStarC_Syntax_Syntax.binder_positivity + = uu___14; + FStarC_Syntax_Syntax.binder_attrs + = uu___15;_} + -> + let uu___16 = + FStarC_Syntax_Syntax.bv_to_name + b in + FStarC_Syntax_Syntax.as_arg + uu___16) f_bs in + uu___10 :: uu___11 in + FStarC_Syntax_Syntax.mk_Tm_app + t uu___9 + FStarC_Compiler_Range_Type.dummyRange) + | FStar_Pervasives_Native.None -> + let uu___7 = + let uu___8 = + FStarC_Syntax_Syntax.null_binder + FStarC_Syntax_Syntax.t_unit in + [uu___8] in + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + let uu___11 = + FStarC_Compiler_List.map + (fun b -> + let uu___12 = + FStarC_Syntax_Syntax.bv_to_name + b.FStarC_Syntax_Syntax.binder_bv in + FStarC_Syntax_Syntax.as_arg + uu___12) f_bs in + { + FStarC_Syntax_Syntax.comp_univs + = + [FStarC_Syntax_Syntax.U_name + u]; + FStarC_Syntax_Syntax.effect_name + = m_eff_name; + FStarC_Syntax_Syntax.result_typ + = uu___10; + FStarC_Syntax_Syntax.effect_args + = uu___11; + FStarC_Syntax_Syntax.flags + = [] + } in + FStarC_Syntax_Syntax.mk_Comp + uu___9 in + FStarC_Syntax_Util.arrow uu___7 + uu___8 in + let uu___7 = + let uu___8 = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm + env + (f_b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort + expected_f_b_sort in + uu___8 = + FStarC_TypeChecker_TermEqAndSimplify.Equal in + if uu___7 + then FStar_Pervasives_Native.Some () + else FStar_Pervasives_Native.None in + op_let_Question uu___6 + (fun _f_b_ok_ -> + let rest_kinds = + FStarC_Compiler_List.map + (fun uu___7 -> + FStarC_Syntax_Syntax.Ad_hoc_binder) + rest_bs2 in + FStar_Pervasives_Native.Some + (FStarC_Compiler_List.op_At + [FStarC_Syntax_Syntax.Type_binder] + (FStarC_Compiler_List.op_At + f_bs_kinds + (FStarC_Compiler_List.op_At + rest_kinds + [FStarC_Syntax_Syntax.Repr_binder])))))) +let (validate_indexed_effect_lift_shape : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.univ_name -> + FStarC_Syntax_Syntax.typ -> + FStarC_Compiler_Range_Type.range -> + (FStarC_Syntax_Syntax.typ * + FStarC_Syntax_Syntax.indexed_effect_combinator_kind)) + = + fun env -> + fun m_eff_name -> + fun n_eff_name -> + fun u -> + fun lift_t -> + fun r -> + let lift_name = + let uu___ = FStarC_Ident.string_of_lid m_eff_name in + let uu___1 = FStarC_Ident.string_of_lid n_eff_name in + FStarC_Compiler_Util.format2 "%s ~> %s" uu___ uu___1 in + let lift_t_shape_error s = + FStarC_Compiler_Util.format2 + "Unexpected shape of lift %s, reason:%s" lift_name s in + let uu___ = + let uu___1 = + FStarC_TypeChecker_Env.get_effect_decl env m_eff_name in + let uu___2 = + FStarC_TypeChecker_Env.get_effect_decl env n_eff_name in + (uu___1, uu___2) in + match uu___ with + | (m_ed, n_ed) -> + let a_b = + let uu___1 = + let uu___2 = + FStarC_Syntax_Util.type_with_u + (FStarC_Syntax_Syntax.U_name u) in + FStarC_Syntax_Syntax.gen_bv "a" + FStar_Pervasives_Native.None uu___2 in + FStarC_Syntax_Syntax.mk_binder uu___1 in + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress lift_t in + uu___3.FStarC_Syntax_Syntax.n in + match uu___2 with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = c;_} + when + (FStarC_Compiler_List.length bs) >= + (Prims.of_int (2)) + -> + let uu___3 = FStarC_Syntax_Subst.open_binders bs in + (match uu___3 with + | { FStarC_Syntax_Syntax.binder_bv = a; + FStarC_Syntax_Syntax.binder_qual = uu___4; + FStarC_Syntax_Syntax.binder_positivity = uu___5; + FStarC_Syntax_Syntax.binder_attrs = uu___6;_}::bs1 + -> + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + (a, uu___11) in + FStarC_Syntax_Syntax.NT uu___10 in + [uu___9] in + let uu___9 = + let uu___10 = + FStarC_Compiler_List.splitAt + ((FStarC_Compiler_List.length bs1) - + Prims.int_one) bs1 in + FStar_Pervasives_Native.fst uu___10 in + FStarC_Syntax_Subst.subst_binders uu___8 + uu___9 in + let uu___8 = + FStarC_TypeChecker_Env.norm_eff_name env + (FStarC_Syntax_Util.comp_effect_name c) in + (uu___7, uu___8)) + | uu___3 -> + let uu___4 = + lift_t_shape_error + "either not an arrow, or not enough binders" in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_UnexpectedExpressionType + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4) in + (match uu___1 with + | (rest_bs, lift_eff) -> + ((let uu___3 = + let uu___4 = + (FStarC_Ident.lid_equals lift_eff + FStarC_Parser_Const.effect_PURE_lid) + || + ((FStarC_Ident.lid_equals lift_eff + FStarC_Parser_Const.effect_GHOST_lid) + && + (FStarC_TypeChecker_Env.is_erasable_effect + env m_eff_name)) in + Prims.op_Negation uu___4 in + if uu___3 + then + let uu___4 = + lift_t_shape_error + "the lift combinator has an unexpected effect: it must either be PURE or if the source effect is erasable then may be GHOST" in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_UnexpectedExpressionType + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4) + else ()); + (let uu___3 = + let uu___4 = + let uu___5 = + FStarC_TypeChecker_Env.push_binders env (a_b + :: rest_bs) in + let uu___6 = + FStarC_Syntax_Util.effect_sig_ts + m_ed.FStarC_Syntax_Syntax.signature in + let uu___7 = + FStarC_Syntax_Util.get_eff_repr m_ed in + let uu___8 = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + FStarC_TypeChecker_Util.fresh_effect_repr uu___5 + r m_eff_name uu___6 uu___7 + (FStarC_Syntax_Syntax.U_name u) uu___8 in + match uu___4 with + | (repr, g) -> + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.gen_bv "f" + FStar_Pervasives_Native.None repr in + FStarC_Syntax_Syntax.mk_binder uu___6 in + (uu___5, g) in + match uu___3 with + | (f, guard_f) -> + let uu___4 = + let uu___5 = + FStarC_TypeChecker_Env.push_binders env (a_b + :: rest_bs) in + let uu___6 = + FStarC_Syntax_Util.effect_sig_ts + n_ed.FStarC_Syntax_Syntax.signature in + let uu___7 = + FStarC_Syntax_Util.get_eff_repr n_ed in + let uu___8 = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + FStarC_TypeChecker_Util.fresh_effect_repr + uu___5 r n_eff_name uu___6 uu___7 + (FStarC_Syntax_Syntax.U_name u) uu___8 in + (match uu___4 with + | (ret_t, guard_ret_t) -> + let uu___5 = + let uu___6 = + FStarC_TypeChecker_Env.push_binders env + (a_b :: rest_bs) in + let uu___7 = + FStarC_Compiler_Util.format1 + "implicit for pure_wp in typechecking lift %s" + lift_name in + pure_wp_uvar uu___6 ret_t uu___7 r in + (match uu___5 with + | (pure_wp_uvar1, guard_wp) -> + let c = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_TypeChecker_Env.new_u_univ + () in + [uu___8] in + let uu___8 = + let uu___9 = + FStarC_Syntax_Syntax.as_arg + pure_wp_uvar1 in + [uu___9] in + { + FStarC_Syntax_Syntax.comp_univs + = uu___7; + FStarC_Syntax_Syntax.effect_name + = lift_eff; + FStarC_Syntax_Syntax.result_typ + = ret_t; + FStarC_Syntax_Syntax.effect_args + = uu___8; + FStarC_Syntax_Syntax.flags = [] + } in + FStarC_Syntax_Syntax.mk_Comp uu___6 in + let k = + FStarC_Syntax_Util.arrow + (FStarC_Compiler_List.op_At (a_b + :: rest_bs) [f]) c in + let guard_eq = + let uu___6 = + FStarC_TypeChecker_Rel.teq_nosmt + env lift_t k in + match uu___6 with + | FStar_Pervasives_Native.None -> + let uu___7 = + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + lift_t in + FStarC_Compiler_Util.format2 + "Unexpected type of %s (%s)\n" + lift_name uu___8 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + r + FStarC_Errors_Codes.Fatal_UnexpectedEffect + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___7) + | FStar_Pervasives_Native.Some g -> + g in + ((let uu___7 = + FStarC_TypeChecker_Env.conj_guards + [guard_f; + guard_ret_t; + guard_wp; + guard_eq] in + FStarC_TypeChecker_Rel.force_trivial_guard + env uu___7); + (let k1 = + let uu___7 = + FStarC_TypeChecker_Normalize.remove_uvar_solutions + env k in + FStarC_Syntax_Subst.compress + uu___7 in + let lopt = + let uu___7 = + FStarC_Syntax_Util.effect_sig_ts + m_ed.FStarC_Syntax_Syntax.signature in + let uu___8 = + FStarC_Syntax_Util.get_eff_repr + m_ed in + lift_combinator_kind env + m_eff_name uu___7 uu___8 u k1 in + let kind = + match lopt with + | FStar_Pervasives_Native.None -> + (log_ad_hoc_combinator_warning + lift_name r; + FStarC_Syntax_Syntax.Ad_hoc_combinator) + | FStar_Pervasives_Native.Some l + -> + FStarC_Syntax_Syntax.Substitutive_combinator + l in + (let uu___8 = + (FStarC_Compiler_Debug.medium ()) + || + (FStarC_Compiler_Effect.op_Bang + dbg_LayeredEffectsTc) in + if uu___8 + then + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Syntax.showable_indexed_effect_combinator_kind + kind in + FStarC_Compiler_Util.print2 + "Lift %s has %s kind\n" + lift_name uu___9 + else ()); + (k1, kind)))))))) +let (tc_layered_eff_decl : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.eff_decl -> + FStarC_Syntax_Syntax.qualifier Prims.list -> + FStarC_Syntax_Syntax.attribute Prims.list -> + FStarC_Syntax_Syntax.eff_decl) + = + fun env0 -> + fun ed -> + fun quals -> + fun attrs -> + let uu___ = + let uu___1 = + FStarC_Ident.string_of_lid ed.FStarC_Syntax_Syntax.mname in + FStarC_Compiler_Util.format1 + "While checking layered effect definition `%s`" uu___1 in + FStarC_Errors.with_ctx uu___ + (fun uu___1 -> + (let uu___3 = + FStarC_Compiler_Effect.op_Bang dbg_LayeredEffectsTc in + if uu___3 + then + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_eff_decl ed in + FStarC_Compiler_Util.print1 + "Typechecking layered effect: \n\t%s\n" uu___4 + else ()); + if + ((FStarC_Compiler_List.length ed.FStarC_Syntax_Syntax.univs) + <> Prims.int_zero) + || + ((FStarC_Compiler_List.length + ed.FStarC_Syntax_Syntax.binders) + <> Prims.int_zero) + then + (let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Ident.string_of_lid + ed.FStarC_Syntax_Syntax.mname in + Prims.strcat uu___6 ")" in + Prims.strcat + "Binders are not supported for layered effects (" + uu___5 in + FStarC_Errors.raise_error FStarC_Ident.hasrange_lident + ed.FStarC_Syntax_Syntax.mname + FStarC_Errors_Codes.Fatal_UnexpectedEffect () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4)) + else (); + (let log_combinator s uu___4 = + match uu___4 with + | (us, t, ty) -> + let uu___5 = + FStarC_Compiler_Effect.op_Bang dbg_LayeredEffectsTc in + if uu___5 + then + let uu___6 = + FStarC_Ident.string_of_lid + ed.FStarC_Syntax_Syntax.mname in + let uu___7 = + FStarC_Syntax_Print.tscheme_to_string (us, t) in + let uu___8 = + FStarC_Syntax_Print.tscheme_to_string (us, ty) in + FStarC_Compiler_Util.print4 + "Typechecked %s:%s = %s:%s\n" uu___6 s uu___7 + uu___8 + else () in + let fresh_a_and_u_a a = + let uu___4 = FStarC_Syntax_Util.type_u () in + match uu___4 with + | (t, u) -> + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.gen_bv a + FStar_Pervasives_Native.None t in + FStarC_Syntax_Syntax.mk_binder uu___6 in + (uu___5, u) in + let fresh_x_a x a = + let uu___4 = + let uu___5 = + FStarC_Syntax_Syntax.bv_to_name + a.FStarC_Syntax_Syntax.binder_bv in + FStarC_Syntax_Syntax.gen_bv x + FStar_Pervasives_Native.None uu___5 in + FStarC_Syntax_Syntax.mk_binder uu___4 in + let check_and_gen1 = + let uu___4 = + FStarC_Ident.string_of_lid ed.FStarC_Syntax_Syntax.mname in + check_and_gen env0 uu___4 in + let uu___4 = + let uu___5 = + match ed.FStarC_Syntax_Syntax.signature with + | FStarC_Syntax_Syntax.Layered_eff_sig (n, ts) -> (n, ts) + | uu___6 -> + failwith + "Impossible (tc_layered_eff_decl with a wp effect sig" in + match uu___5 with + | (n, sig_ts) -> + FStarC_Errors.with_ctx + "While checking the effect signature" + (fun uu___6 -> + let r = + (FStar_Pervasives_Native.snd sig_ts).FStarC_Syntax_Syntax.pos in + let uu___7 = + check_and_gen1 "signature" Prims.int_one sig_ts in + match uu___7 with + | (sig_us, sig_t, sig_ty) -> + let uu___8 = + FStarC_Syntax_Subst.open_univ_vars sig_us + sig_t in + (match uu___8 with + | (us, t) -> + let env = + FStarC_TypeChecker_Env.push_univ_vars + env0 us in + let uu___9 = fresh_a_and_u_a "a" in + (match uu___9 with + | (a, u) -> + let rest_bs = + let uu___10 = + FStarC_Syntax_Syntax.bv_to_name + a.FStarC_Syntax_Syntax.binder_bv in + FStarC_TypeChecker_Util.layered_effect_indices_as_binders + env r + ed.FStarC_Syntax_Syntax.mname + (sig_us, sig_t) u uu___10 in + let bs = a :: rest_bs in + let k = + let uu___10 = + FStarC_Syntax_Syntax.mk_Total + FStarC_Syntax_Syntax.teff in + FStarC_Syntax_Util.arrow bs + uu___10 in + let g_eq = + FStarC_TypeChecker_Rel.teq env t k in + (FStarC_TypeChecker_Rel.force_trivial_guard + env g_eq; + (let uu___11 = + let uu___12 = + let uu___13 = + FStarC_TypeChecker_Normalize.remove_uvar_solutions + env k in + FStarC_Syntax_Subst.close_univ_vars + us uu___13 in + (sig_us, uu___12, sig_ty) in + (n, uu___11)))))) in + match uu___4 with + | (num_effect_params, signature) -> + (log_combinator "signature" signature; + (let repr = + FStarC_Errors.with_ctx + "While checking the effect repr" + (fun uu___6 -> + let repr_ts = + let uu___7 = + FStarC_Syntax_Util.get_eff_repr ed in + FStarC_Compiler_Util.must uu___7 in + let r = + (FStar_Pervasives_Native.snd repr_ts).FStarC_Syntax_Syntax.pos in + let uu___7 = + check_and_gen1 "repr" Prims.int_one repr_ts in + match uu___7 with + | (repr_us, repr_t, repr_ty) -> + let uu___8 = + FStarC_Syntax_Subst.open_univ_vars repr_us + repr_ty in + (match uu___8 with + | (us, ty) -> + let env = + FStarC_TypeChecker_Env.push_univ_vars + env0 us in + let uu___9 = fresh_a_and_u_a "a" in + (match uu___9 with + | (a, u) -> + let rest_bs = + let signature_ts = + let uu___10 = signature in + match uu___10 with + | (us1, t, uu___11) -> + (us1, t) in + let uu___10 = + FStarC_Syntax_Syntax.bv_to_name + a.FStarC_Syntax_Syntax.binder_bv in + FStarC_TypeChecker_Util.layered_effect_indices_as_binders + env r + ed.FStarC_Syntax_Syntax.mname + signature_ts u uu___10 in + let bs = a :: rest_bs in + let k = + let uu___10 = + let uu___11 = + FStarC_Syntax_Util.type_u () in + match uu___11 with + | (t, u1) -> + FStarC_Syntax_Syntax.mk_Total + t in + FStarC_Syntax_Util.arrow bs + uu___10 in + let g = + FStarC_TypeChecker_Rel.teq env + ty k in + (FStarC_TypeChecker_Rel.force_trivial_guard + env g; + (let uu___11 = + let uu___12 = + FStarC_TypeChecker_Normalize.remove_uvar_solutions + env k in + FStarC_Syntax_Subst.close_univ_vars + us uu___12 in + (repr_us, repr_t, uu___11)))))) in + log_combinator "repr" repr; + (let fresh_repr r env u a_tm = + let signature_ts = + let uu___7 = signature in + match uu___7 with | (us, t, uu___8) -> (us, t) in + let repr_ts = + let uu___7 = repr in + match uu___7 with | (us, t, uu___8) -> (us, t) in + FStarC_TypeChecker_Util.fresh_effect_repr env r + ed.FStarC_Syntax_Syntax.mname signature_ts + (FStar_Pervasives_Native.Some repr_ts) u a_tm in + let not_an_arrow_error comb n t r = + let uu___7 = + let uu___8 = + FStarC_Ident.string_of_lid + ed.FStarC_Syntax_Syntax.mname in + let uu___9 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) n in + let uu___10 = + FStarC_Class_Tagged.tag_of + FStarC_Syntax_Syntax.tagged_term t in + let uu___11 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.format5 + "Type of %s:%s is not an arrow with >= %s binders (%s::%s)" + uu___8 comb uu___9 uu___10 uu___11 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_UnexpectedEffect () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___7) in + let return_repr = + FStarC_Errors.with_ctx + "While checking the return combinator" + (fun uu___7 -> + let return_repr_ts = + let uu___8 = + FStarC_Syntax_Util.get_return_repr ed in + FStarC_Compiler_Util.must uu___8 in + let r = + (FStar_Pervasives_Native.snd return_repr_ts).FStarC_Syntax_Syntax.pos in + let uu___8 = + check_and_gen1 "return_repr" Prims.int_one + return_repr_ts in + match uu___8 with + | (ret_us, ret_t, ret_ty) -> + let uu___9 = + FStarC_Syntax_Subst.open_univ_vars ret_us + ret_ty in + (match uu___9 with + | (us, ty) -> + let env = + FStarC_TypeChecker_Env.push_univ_vars + env0 us in + let uu___10 = fresh_a_and_u_a "a" in + (match uu___10 with + | (a, u_a) -> + let x_a = fresh_x_a "x" a in + let rest_bs = + let uu___11 = + let uu___12 = + FStarC_Syntax_Subst.compress + ty in + uu___12.FStarC_Syntax_Syntax.n in + match uu___11 with + | FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 + = bs; + FStarC_Syntax_Syntax.comp + = uu___12;_} + when + (FStarC_Compiler_List.length + bs) + >= (Prims.of_int (2)) + -> + let uu___13 = + FStarC_Syntax_Subst.open_binders + bs in + (match uu___13 with + | { + FStarC_Syntax_Syntax.binder_bv + = a'; + FStarC_Syntax_Syntax.binder_qual + = uu___14; + FStarC_Syntax_Syntax.binder_positivity + = uu___15; + FStarC_Syntax_Syntax.binder_attrs + = uu___16;_}:: + { + FStarC_Syntax_Syntax.binder_bv + = x'; + FStarC_Syntax_Syntax.binder_qual + = uu___17; + FStarC_Syntax_Syntax.binder_positivity + = uu___18; + FStarC_Syntax_Syntax.binder_attrs + = uu___19;_}::bs1 + -> + let uu___20 = + let uu___21 = + let uu___22 = + let uu___23 = + FStarC_Syntax_Syntax.bv_to_name + x_a.FStarC_Syntax_Syntax.binder_bv in + (x', uu___23) in + FStarC_Syntax_Syntax.NT + uu___22 in + [uu___21] in + let uu___21 = + let uu___22 = + let uu___23 = + let uu___24 = + let uu___25 = + FStarC_Syntax_Syntax.bv_to_name + a.FStarC_Syntax_Syntax.binder_bv in + (a', uu___25) in + FStarC_Syntax_Syntax.NT + uu___24 in + [uu___23] in + FStarC_Syntax_Subst.subst_binders + uu___22 bs1 in + FStarC_Syntax_Subst.subst_binders + uu___20 uu___21) + | uu___12 -> + not_an_arrow_error "return" + (Prims.of_int (2)) ty r in + let bs = a :: x_a :: rest_bs in + let uu___11 = + let uu___12 = + FStarC_TypeChecker_Env.push_binders + env bs in + let uu___13 = + FStarC_Syntax_Syntax.bv_to_name + a.FStarC_Syntax_Syntax.binder_bv in + fresh_repr r uu___12 u_a + uu___13 in + (match uu___11 with + | (repr1, g) -> + let k = + let uu___12 = + FStarC_Syntax_Syntax.mk_Total + repr1 in + FStarC_Syntax_Util.arrow + bs uu___12 in + let g_eq = + FStarC_TypeChecker_Rel.teq + env ty k in + ((let uu___13 = + FStarC_TypeChecker_Env.conj_guard + g g_eq in + FStarC_TypeChecker_Rel.force_trivial_guard + env uu___13); + (let k1 = + FStarC_TypeChecker_Normalize.remove_uvar_solutions + env k in + let uu___13 = + FStarC_Syntax_Subst.close_univ_vars + us k1 in + (ret_us, ret_t, uu___13))))))) in + log_combinator "return_repr" return_repr; + (let uu___8 = + FStarC_Errors.with_ctx + "While checking the bind combinator" + (fun uu___9 -> + let bind_repr_ts = + let uu___10 = + FStarC_Syntax_Util.get_bind_repr ed in + FStarC_Compiler_Util.must uu___10 in + let r = + (FStar_Pervasives_Native.snd bind_repr_ts).FStarC_Syntax_Syntax.pos in + let uu___10 = + check_and_gen1 "bind_repr" + (Prims.of_int (2)) bind_repr_ts in + match uu___10 with + | (bind_us, bind_t, bind_ty) -> + let uu___11 = + FStarC_Syntax_Subst.open_univ_vars + bind_us bind_ty in + (match uu___11 with + | (us, ty) -> + let env = + FStarC_TypeChecker_Env.push_univ_vars + env0 us in + let uu___12 = + let sig_ts = + let uu___13 = signature in + match uu___13 with + | (us1, t, uu___14) -> (us1, t) in + let repr_ts = + let uu___13 = repr in + match uu___13 with + | (us1, t, uu___14) -> (us1, t) in + let uu___13 = + FStarC_Syntax_Util.has_attribute + ed.FStarC_Syntax_Syntax.eff_attrs + FStarC_Parser_Const.bind_has_range_args_attr in + validate_indexed_effect_bind_shape + env ed.FStarC_Syntax_Syntax.mname + ed.FStarC_Syntax_Syntax.mname + ed.FStarC_Syntax_Syntax.mname + sig_ts sig_ts sig_ts + (FStar_Pervasives_Native.Some + repr_ts) + (FStar_Pervasives_Native.Some + repr_ts) + (FStar_Pervasives_Native.Some + repr_ts) us ty r + num_effect_params uu___13 in + (match uu___12 with + | (k, kind) -> + let uu___13 = + let uu___14 = + FStarC_Syntax_Subst.close_univ_vars + bind_us k in + (bind_us, bind_t, uu___14) in + (uu___13, kind)))) in + match uu___8 with + | (bind_repr, bind_kind) -> + (log_combinator "bind_repr" bind_repr; + (let uu___10 = + FStarC_Errors.with_ctx + "While checking the subcomp combinator" + (fun uu___11 -> + let stronger_repr = + let ts = + let uu___12 = + FStarC_Syntax_Util.get_stronger_repr + ed in + FStarC_Compiler_Util.must uu___12 in + let uu___12 = + let uu___13 = + FStarC_Syntax_Subst.compress + (FStar_Pervasives_Native.snd ts) in + uu___13.FStarC_Syntax_Syntax.n in + match uu___12 with + | FStarC_Syntax_Syntax.Tm_unknown -> + let signature_ts = + let uu___13 = signature in + match uu___13 with + | (us, t, uu___14) -> (us, t) in + let uu___13 = + FStarC_TypeChecker_Env.inst_tscheme_with + signature_ts + [FStarC_Syntax_Syntax.U_unknown] in + (match uu___13 with + | (uu___14, signature_t) -> + let uu___15 = + let uu___16 = + FStarC_Syntax_Subst.compress + signature_t in + uu___16.FStarC_Syntax_Syntax.n in + (match uu___15 with + | FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 + = bs; + FStarC_Syntax_Syntax.comp + = uu___16;_} + -> + let bs1 = + FStarC_Syntax_Subst.open_binders + bs in + let repr_t = + let repr_ts = + let uu___17 = repr in + match uu___17 with + | (us, t, uu___18) + -> (us, t) in + let uu___17 = + FStarC_TypeChecker_Env.inst_tscheme_with + repr_ts + [FStarC_Syntax_Syntax.U_unknown] in + FStar_Pervasives_Native.snd + uu___17 in + let repr_t_applied = + let uu___17 = + let uu___18 = + let uu___19 = + let uu___20 = + let uu___21 = + FStarC_Compiler_List.map + (fun b -> + b.FStarC_Syntax_Syntax.binder_bv) + bs1 in + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.bv_to_name + uu___21 in + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.as_arg + uu___20 in + { + FStarC_Syntax_Syntax.hd + = repr_t; + FStarC_Syntax_Syntax.args + = uu___19 + } in + FStarC_Syntax_Syntax.Tm_app + uu___18 in + let uu___18 = + FStarC_Ident.range_of_lid + ed.FStarC_Syntax_Syntax.mname in + FStarC_Syntax_Syntax.mk + uu___17 uu___18 in + let f_b = + FStarC_Syntax_Syntax.null_binder + repr_t_applied in + let uu___17 = + let uu___18 = + let uu___19 = + FStarC_Syntax_Syntax.bv_to_name + f_b.FStarC_Syntax_Syntax.binder_bv in + FStarC_Syntax_Util.abs + (FStarC_Compiler_List.op_At + bs1 [f_b]) + uu___19 + FStar_Pervasives_Native.None in + let uu___19 = + FStarC_Ident.range_of_lid + ed.FStarC_Syntax_Syntax.mname in + { + FStarC_Syntax_Syntax.n + = + (uu___18.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos + = uu___19; + FStarC_Syntax_Syntax.vars + = + (uu___18.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code + = + (uu___18.FStarC_Syntax_Syntax.hash_code) + } in + ([], uu___17) + | uu___16 -> + failwith "Impossible!")) + | uu___13 -> ts in + let r = + (FStar_Pervasives_Native.snd + stronger_repr).FStarC_Syntax_Syntax.pos in + let uu___12 = + check_and_gen1 "stronger_repr" + Prims.int_one stronger_repr in + match uu___12 with + | (stronger_us, stronger_t, stronger_ty) + -> + ((let uu___14 = + FStarC_Compiler_Effect.op_Bang + dbg_LayeredEffectsTc in + if uu___14 + then + let uu___15 = + FStarC_Syntax_Print.tscheme_to_string + (stronger_us, stronger_t) in + let uu___16 = + FStarC_Syntax_Print.tscheme_to_string + (stronger_us, stronger_ty) in + FStarC_Compiler_Util.print2 + "stronger combinator typechecked with term: %s and type: %s\n" + uu___15 uu___16 + else ()); + (let uu___14 = + FStarC_Syntax_Subst.open_univ_vars + stronger_us stronger_ty in + match uu___14 with + | (us, ty) -> + let env = + FStarC_TypeChecker_Env.push_univ_vars + env0 us in + let uu___15 = + let sig_ts = + let uu___16 = signature in + match uu___16 with + | (us1, t, uu___17) -> + (us1, t) in + let repr_ts = + let uu___16 = repr in + match uu___16 with + | (us1, t, uu___17) -> + (us1, t) in + let uu___16 = + FStarC_Compiler_List.hd us in + validate_indexed_effect_subcomp_shape + env + ed.FStarC_Syntax_Syntax.mname + ed.FStarC_Syntax_Syntax.mname + sig_ts sig_ts + (FStar_Pervasives_Native.Some + repr_ts) + (FStar_Pervasives_Native.Some + repr_ts) uu___16 ty + num_effect_params r in + (match uu___15 with + | (k, kind) -> + let uu___16 = + let uu___17 = + FStarC_Syntax_Subst.close_univ_vars + stronger_us k in + (stronger_us, + stronger_t, uu___17) in + (uu___16, kind))))) in + match uu___10 with + | (stronger_repr, subcomp_kind) -> + (log_combinator "stronger_repr" + stronger_repr; + (let uu___12 = + FStarC_Errors.with_ctx + "While checking the if_then_else combinator" + (fun uu___13 -> + let if_then_else_ts = + let ts = + let uu___14 = + let uu___15 = + FStarC_Syntax_Util.get_layered_if_then_else_combinator + ed in + FStarC_Compiler_Util.must + uu___15 in + FStar_Pervasives_Native.fst + uu___14 in + let uu___14 = + let uu___15 = + FStarC_Syntax_Subst.compress + (FStar_Pervasives_Native.snd + ts) in + uu___15.FStarC_Syntax_Syntax.n in + match uu___14 with + | FStarC_Syntax_Syntax.Tm_unknown + -> + let signature_ts = + let uu___15 = signature in + match uu___15 with + | (us, t, uu___16) -> + (us, t) in + let uu___15 = + FStarC_TypeChecker_Env.inst_tscheme_with + signature_ts + [FStarC_Syntax_Syntax.U_unknown] in + (match uu___15 with + | (uu___16, signature_t) -> + let uu___17 = + let uu___18 = + FStarC_Syntax_Subst.compress + signature_t in + uu___18.FStarC_Syntax_Syntax.n in + (match uu___17 with + | FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 + = bs; + FStarC_Syntax_Syntax.comp + = uu___18;_} + -> + let bs1 = + FStarC_Syntax_Subst.open_binders + bs in + let repr_t = + let repr_ts = + let uu___19 = + repr in + match uu___19 + with + | (us, t, + uu___20) -> + (us, t) in + let uu___19 = + FStarC_TypeChecker_Env.inst_tscheme_with + repr_ts + [FStarC_Syntax_Syntax.U_unknown] in + FStar_Pervasives_Native.snd + uu___19 in + let repr_t_applied + = + let uu___19 = + let uu___20 = + let uu___21 + = + let uu___22 + = + let uu___23 + = + FStarC_Compiler_List.map + (fun b -> + b.FStarC_Syntax_Syntax.binder_bv) + bs1 in + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.bv_to_name + uu___23 in + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.as_arg + uu___22 in + { + FStarC_Syntax_Syntax.hd + = repr_t; + FStarC_Syntax_Syntax.args + = uu___21 + } in + FStarC_Syntax_Syntax.Tm_app + uu___20 in + let uu___20 = + FStarC_Ident.range_of_lid + ed.FStarC_Syntax_Syntax.mname in + FStarC_Syntax_Syntax.mk + uu___19 + uu___20 in + let f_b = + FStarC_Syntax_Syntax.null_binder + repr_t_applied in + let g_b = + FStarC_Syntax_Syntax.null_binder + repr_t_applied in + let b_b = + FStarC_Syntax_Syntax.null_binder + FStarC_Syntax_Util.t_bool in + let uu___19 = + let uu___20 = + FStarC_Syntax_Util.abs + (FStarC_Compiler_List.op_At + bs1 + [f_b; + g_b; + b_b]) + repr_t_applied + FStar_Pervasives_Native.None in + let uu___21 = + FStarC_Ident.range_of_lid + ed.FStarC_Syntax_Syntax.mname in + { + FStarC_Syntax_Syntax.n + = + (uu___20.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos + = uu___21; + FStarC_Syntax_Syntax.vars + = + (uu___20.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code + = + (uu___20.FStarC_Syntax_Syntax.hash_code) + } in + ([], uu___19) + | uu___18 -> + failwith + "Impossible!")) + | uu___15 -> ts in + let r = + (FStar_Pervasives_Native.snd + if_then_else_ts).FStarC_Syntax_Syntax.pos in + let uu___14 = + check_and_gen1 "if_then_else" + Prims.int_one if_then_else_ts in + match uu___14 with + | (if_then_else_us, + if_then_else_t, + if_then_else_ty) -> + let uu___15 = + FStarC_Syntax_Subst.open_univ_vars + if_then_else_us + if_then_else_t in + (match uu___15 with + | (us, t) -> + let uu___16 = + FStarC_Syntax_Subst.open_univ_vars + if_then_else_us + if_then_else_ty in + (match uu___16 with + | (uu___17, ty) -> + let env = + FStarC_TypeChecker_Env.push_univ_vars + env0 us in + let uu___18 = + let sig_ts = + let uu___19 = + signature in + match uu___19 + with + | (us1, t1, + uu___20) -> + (us1, t1) in + let repr_ts = + let uu___19 = + repr in + match uu___19 + with + | (us1, t1, + uu___20) -> + (us1, t1) in + let uu___19 = + FStarC_Compiler_List.hd + us in + validate_indexed_effect_ite_shape + env + ed.FStarC_Syntax_Syntax.mname + sig_ts repr_ts + uu___19 ty t + num_effect_params + r in + (match uu___18 with + | (k, kind) -> + let uu___19 = + let uu___20 = + FStarC_Syntax_Subst.close_univ_vars + if_then_else_us + k in + (if_then_else_us, + uu___20, + if_then_else_ty) in + (uu___19, kind))))) in + match uu___12 with + | (if_then_else, ite_kind) -> + (log_combinator "if_then_else" + if_then_else; + FStarC_Errors.with_ctx + "While checking if-then-else soundness" + (fun uu___14 -> + let r = + let uu___15 = + let uu___16 = + let uu___17 = + let uu___18 = + FStarC_Syntax_Util.get_layered_if_then_else_combinator + ed in + FStarC_Compiler_Util.must + uu___18 in + FStar_Pervasives_Native.fst + uu___17 in + FStar_Pervasives_Native.snd + uu___16 in + uu___15.FStarC_Syntax_Syntax.pos in + let uu___15 = if_then_else in + match uu___15 with + | (ite_us, ite_t, uu___16) -> + let uu___17 = + FStarC_Syntax_Subst.open_univ_vars + ite_us ite_t in + (match uu___17 with + | (us, ite_t1) -> + let uu___18 = + let uu___19 = + let uu___20 = + FStarC_Syntax_Subst.compress + ite_t1 in + uu___20.FStarC_Syntax_Syntax.n in + match uu___19 with + | FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs + = bs; + FStarC_Syntax_Syntax.body + = uu___20; + FStarC_Syntax_Syntax.rc_opt + = uu___21;_} + -> + let bs1 = + FStarC_Syntax_Subst.open_binders + bs in + let uu___22 = + let uu___23 = + let uu___24 + = + FStarC_Compiler_List.splitAt + ((FStarC_Compiler_List.length + bs1) - + (Prims.of_int (3))) + bs1 in + FStar_Pervasives_Native.snd + uu___24 in + let uu___24 = + uu___23 in + match uu___24 + with + | f::g::p::[] + -> + (f, g, p) in + (match uu___22 + with + | (f_b, g_b, + p_b) -> + let env = + let uu___23 + = + FStarC_TypeChecker_Env.push_univ_vars + env0 us in + FStarC_TypeChecker_Env.push_binders + uu___23 + bs1 in + let uu___23 + = + let uu___24 + = + let uu___25 + = + FStarC_Compiler_List.map + (fun b -> + let uu___26 + = + FStarC_Syntax_Syntax.bv_to_name + b.FStarC_Syntax_Syntax.binder_bv in + let uu___27 + = + FStarC_Syntax_Util.aqual_of_binder + b in + (uu___26, + uu___27)) + bs1 in + FStarC_Syntax_Syntax.mk_Tm_app + ite_t1 + uu___25 r in + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Beta] + env + uu___24 in + let uu___24 + = + FStarC_Compiler_List.hd + bs1 in + let uu___25 + = + FStarC_Syntax_Syntax.bv_to_name + p_b.FStarC_Syntax_Syntax.binder_bv in + (env, + uu___23, + uu___24, + f_b, g_b, + uu___25)) + | uu___20 -> + failwith + "Impossible! ite_t must have been an abstraction with at least 3 binders" in + (match uu___18 with + | (env, + ite_t_applied, + a_b, f_b, g_b, + p_t) -> + let uu___19 = + let uu___20 = + stronger_repr in + match uu___20 + with + | (uu___21, + uu___22, + subcomp_ty) + -> + let uu___23 + = + FStarC_Syntax_Subst.open_univ_vars + us + subcomp_ty in + (match uu___23 + with + | + (uu___24, + subcomp_ty1) + -> + let uu___25 + = + let uu___26 + = + FStarC_Syntax_Subst.compress + subcomp_ty1 in + uu___26.FStarC_Syntax_Syntax.n in + (match uu___25 + with + | + FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 + = bs; + FStarC_Syntax_Syntax.comp + = c;_} -> + let uu___26 + = + FStarC_Syntax_Subst.open_comp + bs c in + (match uu___26 + with + | + (bs1, c1) + -> + let uu___27 + = + let uu___28 + = + FStarC_Compiler_List.hd + bs1 in + let uu___29 + = + FStarC_Compiler_List.tl + bs1 in + (uu___28, + uu___29) in + (match uu___27 + with + | + (a_b1, + rest_bs) + -> + let uu___28 + = + let uu___29 + = + FStarC_Compiler_List.splitAt + ((FStarC_Compiler_List.length + rest_bs) + - + Prims.int_one) + rest_bs in + match uu___29 + with + | + (l1, l2) + -> + let uu___30 + = + FStarC_Compiler_List.hd + l2 in + (l1, + uu___30) in + (match uu___28 + with + | + (rest_bs1, + f_b1) -> + (a_b1, + rest_bs1, + f_b1, c1)))) + | + uu___26 + -> + failwith + "Impossible! subcomp_ty must have been an arrow with at lease 1 binder")) in + (match uu___19 + with + | (subcomp_a_b, + subcomp_bs, + subcomp_f_b, + subcomp_c) -> + let check_branch + env1 + ite_f_or_g_sort + attr_opt = + let uu___20 + = + let uu___21 + = + let uu___22 + = + let uu___23 + = + let uu___24 + = + let uu___25 + = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + ((subcomp_a_b.FStarC_Syntax_Syntax.binder_bv), + uu___25) in + FStarC_Syntax_Syntax.NT + uu___24 in + [uu___23] in + (uu___22, + [], + FStarC_TypeChecker_Env.trivial_guard) in + FStarC_Compiler_List.fold_left + (fun + uu___22 + -> + fun b -> + match uu___22 + with + | + (subst, + uvars, g) + -> + let sort + = + FStarC_Syntax_Subst.subst + subst + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + let uu___23 + = + let ctx_uvar_meta + = + FStarC_Compiler_Util.map_option + (fun + uu___24 + -> + FStarC_Syntax_Syntax.Ctx_uvar_meta_attr + uu___24) + attr_opt in + let uu___24 + = + let uu___25 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_binder + b in + FStarC_Compiler_Util.format1 + "uvar for subcomp %s binder when checking ite soundness" + uu___25 in + FStarC_TypeChecker_Env.new_implicit_var_aux + uu___24 r + env1 sort + FStarC_Syntax_Syntax.Strict + ctx_uvar_meta + false in + (match uu___23 + with + | + (t, + uu___24, + g_t) -> + let uu___25 + = + FStarC_TypeChecker_Common.conj_guard + g g_t in + ((FStarC_Compiler_List.op_At + subst + [ + FStarC_Syntax_Syntax.NT + ((b.FStarC_Syntax_Syntax.binder_bv), + t)]), + (FStarC_Compiler_List.op_At + uvars + [t]), + uu___25))) + uu___21 + subcomp_bs in + match uu___20 + with + | + (subst, + uvars, + g_uvars) + -> + let subcomp_f_sort + = + FStarC_Syntax_Subst.subst + subst + (subcomp_f_b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + let c = + let uu___21 + = + FStarC_Syntax_Subst.subst_comp + subst + subcomp_c in + FStarC_TypeChecker_Env.unfold_effect_abbrev + env1 + uu___21 in + let g_f_or_g + = + FStarC_TypeChecker_Rel.layered_effect_teq + env1 + subcomp_f_sort + ite_f_or_g_sort + FStar_Pervasives_Native.None in + let g_c = + FStarC_TypeChecker_Rel.layered_effect_teq + env1 + c.FStarC_Syntax_Syntax.result_typ + ite_t_applied + FStar_Pervasives_Native.None in + let fml = + let uu___21 + = + FStarC_Compiler_List.hd + c.FStarC_Syntax_Syntax.comp_univs in + let uu___22 + = + let uu___23 + = + FStarC_Compiler_List.hd + c.FStarC_Syntax_Syntax.effect_args in + FStar_Pervasives_Native.fst + uu___23 in + FStarC_TypeChecker_Env.pure_precondition_for_trivial_post + env1 + uu___21 + c.FStarC_Syntax_Syntax.result_typ + uu___22 r in + let g_precondition + = + match attr_opt + with + | + FStar_Pervasives_Native.None + -> + FStarC_TypeChecker_Env.guard_of_guard_formula + (FStarC_TypeChecker_Common.NonTrivial + fml) + | + FStar_Pervasives_Native.Some + attr -> + let uu___21 + = + let uu___22 + = + FStarC_Syntax_Util.mk_squash + FStarC_Syntax_Syntax.U_zero + fml in + FStarC_TypeChecker_Env.new_implicit_var_aux + "tc_layered_effect_decl.g_precondition" + r env1 + uu___22 + FStarC_Syntax_Syntax.Strict + (FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Ctx_uvar_meta_attr + attr)) + false in + (match uu___21 + with + | + (uu___22, + uu___23, + g) -> g) in + let uu___21 + = + FStarC_TypeChecker_Env.conj_guards + [g_uvars; + g_f_or_g; + g_c; + g_precondition] in + FStarC_TypeChecker_Rel.force_trivial_guard + env1 + uu___21 in + let ite_soundness_tac_attr + = + let uu___20 + = + FStarC_Syntax_Util.get_attribute + FStarC_Parser_Const.ite_soundness_by_attr + attrs in + match uu___20 + with + | + FStar_Pervasives_Native.Some + ((t, + uu___21)::uu___22) + -> + FStar_Pervasives_Native.Some + t + | + uu___21 -> + FStar_Pervasives_Native.None in + ((let env1 = + let uu___20 + = + let uu___21 + = + let uu___22 + = + FStarC_Syntax_Util.b2t + p_t in + FStarC_Syntax_Util.mk_squash + FStarC_Syntax_Syntax.U_zero + uu___22 in + FStarC_Syntax_Syntax.new_bv + FStar_Pervasives_Native.None + uu___21 in + FStarC_TypeChecker_Env.push_bv + env + uu___20 in + check_branch + env1 + (f_b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort + ite_soundness_tac_attr); + (let not_p + = + let uu___20 + = + let uu___21 + = + FStarC_Syntax_Syntax.lid_as_fv + FStarC_Parser_Const.not_lid + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm + uu___21 in + let uu___21 + = + let uu___22 + = + let uu___23 + = + FStarC_Syntax_Util.b2t + p_t in + FStarC_Syntax_Syntax.as_arg + uu___23 in + [uu___22] in + FStarC_Syntax_Syntax.mk_Tm_app + uu___20 + uu___21 r in + let env1 = + let uu___20 + = + FStarC_Syntax_Syntax.new_bv + FStar_Pervasives_Native.None + not_p in + FStarC_TypeChecker_Env.push_bv + env + uu___20 in + check_branch + env1 + (g_b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort + ite_soundness_tac_attr)))))); + (let close_ = + FStarC_Errors.with_ctx + "While checking the close combinator" + (fun uu___14 -> + let ts_opt = + FStarC_Syntax_Util.get_layered_close_combinator + ed in + match ts_opt with + | FStar_Pervasives_Native.None + -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some + close_ts -> + let r = + (FStar_Pervasives_Native.snd + close_ts).FStarC_Syntax_Syntax.pos in + let uu___15 = + check_and_gen1 "close" + (Prims.of_int (2)) + close_ts in + (match uu___15 with + | (close_us, close_t, + close_ty) -> + let uu___16 = + FStarC_Syntax_Subst.open_univ_vars + close_us + close_t in + (match uu___16 with + | (us, t) -> + let env = + FStarC_TypeChecker_Env.push_univ_vars + env0 us in + let k = + let sig_ts = + let uu___17 + = + signature in + match uu___17 + with + | + (us1, t1, + uu___18) + -> + (us1, t1) in + let repr_ts + = + let uu___17 + = repr in + match uu___17 + with + | + (us1, t1, + uu___18) + -> + (us1, t1) in + let uu___17 + = us in + match uu___17 + with + | u_a::u_b::[] + -> + validate_indexed_effect_close_shape + env + ed.FStarC_Syntax_Syntax.mname + sig_ts + repr_ts + u_a u_b t + num_effect_params + r in + let uu___17 = + let uu___18 + = + FStarC_Syntax_Subst.close_univ_vars + close_us + k in + (close_us, + uu___18, + close_ty) in + FStar_Pervasives_Native.Some + uu___17))) in + FStarC_Errors.with_ctx + "While checking the soundness of the close combinator" + (fun uu___14 -> + match close_ with + | FStar_Pervasives_Native.None + -> () + | FStar_Pervasives_Native.Some + close_1 -> + let uu___15 = close_1 in + (match uu___15 with + | (us, close_tm, uu___16) + -> + let r = + close_tm.FStarC_Syntax_Syntax.pos in + ((let supported_subcomp + = + match subcomp_kind + with + | FStarC_Syntax_Syntax.Substitutive_combinator + l -> + Prims.op_Negation + (FStarC_Compiler_List.contains + FStarC_Syntax_Syntax.Ad_hoc_binder + l) + | uu___18 -> + false in + if + Prims.op_Negation + supported_subcomp + then + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + r + FStarC_Errors_Codes.Fatal_UnexpectedEffect + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "close combinator is only allowed for effects with substitutive subcomp") + else ()); + (let uu___18 = + FStarC_Syntax_Subst.open_univ_vars + us close_tm in + match uu___18 with + | (us1, close_tm1) + -> + let uu___19 = + FStarC_Syntax_Util.abs_formals + close_tm1 in + (match uu___19 + with + | (close_bs, + close_body, + uu___20) -> + let uu___21 + = + close_bs in + (match uu___21 + with + | + a_b::b_b::close_bs1 + -> + let uu___22 + = + FStarC_Compiler_List.splitAt + ((FStarC_Compiler_List.length + close_bs1) + - + Prims.int_one) + close_bs1 in + (match uu___22 + with + | + (is_bs, + uu___23) + -> + let x_bv + = + let uu___24 + = + FStarC_Syntax_Syntax.bv_to_name + b_b.FStarC_Syntax_Syntax.binder_bv in + FStarC_Syntax_Syntax.gen_bv + "x" + FStar_Pervasives_Native.None + uu___24 in + let args1 + = + FStarC_Compiler_List.map + (fun i_b + -> + let uu___24 + = + FStarC_Syntax_Syntax.bv_to_name + i_b.FStarC_Syntax_Syntax.binder_bv in + let uu___25 + = + let uu___26 + = + let uu___27 + = + FStarC_Syntax_Syntax.bv_to_name + x_bv in + FStarC_Syntax_Syntax.as_arg + uu___27 in + [uu___26] in + FStarC_Syntax_Syntax.mk_Tm_app + uu___24 + uu___25 r) + is_bs in + let args2 + = + let uu___24 + = + let uu___25 + = + FStarC_Syntax_Subst.compress + close_body in + uu___25.FStarC_Syntax_Syntax.n in + match uu___24 + with + | + FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd + = uu___25; + FStarC_Syntax_Syntax.args + = a::args;_} + -> + FStarC_Compiler_List.map + FStar_Pervasives_Native.fst + args + | + uu___25 + -> + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + r + FStarC_Errors_Codes.Fatal_UnexpectedEffect + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "close combinator body not a repr") in + let env = + let uu___24 + = + let uu___25 + = + let uu___26 + = + FStarC_Syntax_Syntax.mk_binder + x_bv in + [uu___26] in + FStarC_Compiler_List.op_At + (a_b :: + b_b :: + is_bs) + uu___25 in + FStarC_TypeChecker_Env.push_binders + env0 + uu___24 in + let subcomp_ts + = + let uu___24 + = + stronger_repr in + match uu___24 + with + | + (us2, + uu___25, + t) -> + (us2, t) in + let uu___24 + = + let uu___25 + = + let uu___26 + = + let uu___27 + = + FStarC_Compiler_List.hd + us1 in + FStarC_Syntax_Syntax.U_name + uu___27 in + [uu___26] in + FStarC_TypeChecker_Env.inst_tscheme_with + subcomp_ts + uu___25 in + (match uu___24 + with + | + (uu___25, + subcomp_t) + -> + let uu___26 + = + FStarC_Syntax_Util.arrow_formals_comp + subcomp_t in + (match uu___26 + with + | + (a_b_subcomp::subcomp_bs, + subcomp_c) + -> + let subcomp_substs + = + let uu___27 + = + let uu___28 + = + let uu___29 + = + FStarC_Syntax_Syntax.bv_to_name + a_b.FStarC_Syntax_Syntax.binder_bv in + ((a_b_subcomp.FStarC_Syntax_Syntax.binder_bv), + uu___29) in + FStarC_Syntax_Syntax.NT + uu___28 in + [uu___27] in + let uu___27 + = + FStarC_Compiler_List.splitAt + (FStarC_Compiler_List.length + args1) + subcomp_bs in + (match uu___27 + with + | + (subcomp_f_bs, + subcomp_bs1) + -> + let subcomp_substs1 + = + let uu___28 + = + FStarC_Compiler_List.map2 + (fun b -> + fun arg1 + -> + FStarC_Syntax_Syntax.NT + ((b.FStarC_Syntax_Syntax.binder_bv), + arg1)) + subcomp_f_bs + args1 in + FStarC_Compiler_List.op_At + subcomp_substs + uu___28 in + let uu___28 + = + FStarC_Compiler_List.splitAt + (FStarC_Compiler_List.length + args2) + subcomp_bs1 in + (match uu___28 + with + | + (subcomp_g_bs, + uu___29) + -> + let subcomp_substs2 + = + let uu___30 + = + FStarC_Compiler_List.map2 + (fun b -> + fun arg2 + -> + FStarC_Syntax_Syntax.NT + ((b.FStarC_Syntax_Syntax.binder_bv), + arg2)) + subcomp_g_bs + args2 in + FStarC_Compiler_List.op_At + subcomp_substs1 + uu___30 in + let subcomp_c1 + = + let uu___30 + = + FStarC_Syntax_Subst.subst_comp + subcomp_substs2 + subcomp_c in + FStarC_TypeChecker_Env.unfold_effect_abbrev + env + uu___30 in + let fml = + let uu___30 + = + FStarC_Compiler_List.hd + subcomp_c1.FStarC_Syntax_Syntax.comp_univs in + let uu___31 + = + let uu___32 + = + FStarC_Compiler_List.hd + subcomp_c1.FStarC_Syntax_Syntax.effect_args in + FStar_Pervasives_Native.fst + uu___32 in + FStarC_TypeChecker_Env.pure_precondition_for_trivial_post + env + uu___30 + subcomp_c1.FStarC_Syntax_Syntax.result_typ + uu___31 r in + let uu___30 + = + FStarC_TypeChecker_Env.guard_of_guard_formula + (FStarC_TypeChecker_Common.NonTrivial + fml) in + FStarC_TypeChecker_Rel.force_trivial_guard + env + uu___30))))))))))); + (let tc_action env act = + let env01 = env in + let r = + (act.FStarC_Syntax_Syntax.action_defn).FStarC_Syntax_Syntax.pos in + if + (FStarC_Compiler_List.length + act.FStarC_Syntax_Syntax.action_params) + <> Prims.int_zero + then + (let uu___15 = + let uu___16 = + FStarC_Ident.string_of_lid + ed.FStarC_Syntax_Syntax.mname in + let uu___17 = + FStarC_Ident.string_of_lid + act.FStarC_Syntax_Syntax.action_name in + let uu___18 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binder) + act.FStarC_Syntax_Syntax.action_params in + FStarC_Compiler_Util.format3 + "Action %s:%s has non-empty action params (%s)" + uu___16 uu___17 uu___18 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + r + FStarC_Errors_Codes.Fatal_MalformedActionDeclaration + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___15)) + else (); + (let uu___15 = + let uu___16 = + FStarC_Syntax_Subst.univ_var_opening + act.FStarC_Syntax_Syntax.action_univs in + match uu___16 with + | (usubst, us) -> + let uu___17 = + FStarC_TypeChecker_Env.push_univ_vars + env us in + let uu___18 = + let uu___19 = + FStarC_Syntax_Subst.subst + usubst + act.FStarC_Syntax_Syntax.action_defn in + let uu___20 = + FStarC_Syntax_Subst.subst + usubst + act.FStarC_Syntax_Syntax.action_typ in + { + FStarC_Syntax_Syntax.action_name + = + (act.FStarC_Syntax_Syntax.action_name); + FStarC_Syntax_Syntax.action_unqualified_name + = + (act.FStarC_Syntax_Syntax.action_unqualified_name); + FStarC_Syntax_Syntax.action_univs + = us; + FStarC_Syntax_Syntax.action_params + = + (act.FStarC_Syntax_Syntax.action_params); + FStarC_Syntax_Syntax.action_defn + = uu___19; + FStarC_Syntax_Syntax.action_typ + = uu___20 + } in + (uu___17, uu___18) in + match uu___15 with + | (env1, act1) -> + let act_typ = + let uu___16 = + let uu___17 = + FStarC_Syntax_Subst.compress + act1.FStarC_Syntax_Syntax.action_typ in + uu___17.FStarC_Syntax_Syntax.n in + match uu___16 with + | FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 + = bs; + FStarC_Syntax_Syntax.comp + = c;_} + -> + let ct = + FStarC_TypeChecker_Env.comp_to_comp_typ + env1 c in + let uu___17 = + FStarC_Ident.lid_equals + ct.FStarC_Syntax_Syntax.effect_name + ed.FStarC_Syntax_Syntax.mname in + if uu___17 + then + let repr_ts = + let uu___18 = + repr in + match uu___18 + with + | (us, t, + uu___19) -> + (us, t) in + let repr1 = + let uu___18 = + FStarC_TypeChecker_Env.inst_tscheme_with + repr_ts + ct.FStarC_Syntax_Syntax.comp_univs in + FStar_Pervasives_Native.snd + uu___18 in + let repr2 = + let uu___18 = + let uu___19 = + FStarC_Syntax_Syntax.as_arg + ct.FStarC_Syntax_Syntax.result_typ in + uu___19 :: + (ct.FStarC_Syntax_Syntax.effect_args) in + FStarC_Syntax_Syntax.mk_Tm_app + repr1 uu___18 r in + let c1 = + FStarC_Syntax_Syntax.mk_Total + repr2 in + FStarC_Syntax_Util.arrow + bs c1 + else + act1.FStarC_Syntax_Syntax.action_typ + | uu___17 -> + act1.FStarC_Syntax_Syntax.action_typ in + let uu___16 = + FStarC_TypeChecker_TcTerm.tc_tot_or_gtot_term + env1 act_typ in + (match uu___16 with + | (act_typ1, uu___17, g_t) + -> + let uu___18 = + let uu___19 = + let uu___20 = + FStarC_TypeChecker_Env.set_expected_typ + env1 act_typ1 in + { + FStarC_TypeChecker_Env.solver + = + (uu___20.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range + = + (uu___20.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule + = + (uu___20.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma + = + (uu___20.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig + = + (uu___20.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache + = + (uu___20.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules + = + (uu___20.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ + = + (uu___20.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab + = + (uu___20.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab + = + (uu___20.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp + = false; + FStarC_TypeChecker_Env.effects + = + (uu___20.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize + = + (uu___20.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs + = + (uu___20.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level + = + (uu___20.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars + = + (uu___20.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict + = + (uu___20.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface + = + (uu___20.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit + = + (uu___20.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes + = + (uu___20.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 + = + (uu___20.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard + = + (uu___20.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking + = + (uu___20.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping + = + (uu___20.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics + = + (uu___20.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce + = + (uu___20.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term + = + (uu___20.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (uu___20.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of + = + (uu___20.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (uu___20.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force + = + (uu___20.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (uu___20.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (uu___20.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (uu___20.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths + = + (uu___20.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns + = + (uu___20.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook + = + (uu___20.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (uu___20.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice + = + (uu___20.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess + = + (uu___20.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess + = + (uu___20.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info + = + (uu___20.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks + = + (uu___20.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv + = + (uu___20.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe + = + (uu___20.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab + = + (uu___20.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (uu___20.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (uu___20.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (uu___20.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (uu___20.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check + = + (uu___20.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl + = + (uu___20.FStarC_TypeChecker_Env.missing_decl) + } in + FStarC_TypeChecker_TcTerm.tc_tot_or_gtot_term + uu___19 + act1.FStarC_Syntax_Syntax.action_defn in + (match uu___18 with + | (act_defn, uu___19, + g_d) -> + ((let uu___21 = + (FStarC_Compiler_Debug.medium + ()) + || + (FStarC_Compiler_Effect.op_Bang + dbg_LayeredEffectsTc) in + if uu___21 + then + let uu___22 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + act_defn in + let uu___23 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + act_typ1 in + FStarC_Compiler_Util.print2 + "Typechecked action definition: %s and action type: %s\n" + uu___22 + uu___23 + else ()); + (let uu___21 = + let act_typ2 + = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Beta] + env1 + act_typ1 in + let uu___22 = + let uu___23 + = + FStarC_Syntax_Subst.compress + act_typ2 in + uu___23.FStarC_Syntax_Syntax.n in + match uu___22 + with + | FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 + = bs; + FStarC_Syntax_Syntax.comp + = uu___23;_} + -> + let bs1 = + FStarC_Syntax_Subst.open_binders + bs in + let env2 + = + FStarC_TypeChecker_Env.push_binders + env1 bs1 in + let uu___24 + = + FStarC_Syntax_Util.type_u + () in + (match uu___24 + with + | + (t, u) -> + let reason + = + let uu___25 + = + FStarC_Ident.string_of_lid + ed.FStarC_Syntax_Syntax.mname in + let uu___26 + = + FStarC_Ident.string_of_lid + act1.FStarC_Syntax_Syntax.action_name in + FStarC_Compiler_Util.format2 + "implicit for return type of action %s:%s" + uu___25 + uu___26 in + let uu___25 + = + FStarC_TypeChecker_Util.new_implicit_var + reason r + env2 t + false in + (match uu___25 + with + | + (a_tm, + uu___26, + g_tm) -> + let uu___27 + = + fresh_repr + r env2 u + a_tm in + (match uu___27 + with + | + (repr1, + g) -> + let uu___28 + = + let uu___29 + = + FStarC_Syntax_Syntax.mk_Total + repr1 in + FStarC_Syntax_Util.arrow + bs1 + uu___29 in + let uu___29 + = + FStarC_TypeChecker_Env.conj_guard + g g_tm in + (uu___28, + uu___29)))) + | uu___23 -> + let uu___24 + = + let uu___25 + = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + ed.FStarC_Syntax_Syntax.mname in + let uu___26 + = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + act1.FStarC_Syntax_Syntax.action_name in + let uu___27 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + act_typ2 in + FStarC_Compiler_Util.format3 + "Unexpected non-function type for action %s:%s (%s)" + uu___25 + uu___26 + uu___27 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + r + FStarC_Errors_Codes.Fatal_ActionMustHaveFunctionType + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + uu___24) in + match uu___21 + with + | (k, g_k) -> + ((let uu___23 + = + (FStarC_Compiler_Debug.medium + ()) || + (FStarC_Compiler_Effect.op_Bang + dbg_LayeredEffectsTc) in + if + uu___23 + then + let uu___24 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + k in + FStarC_Compiler_Util.print1 + "Expected action type: %s\n" + uu___24 + else ()); + (let g = + FStarC_TypeChecker_Rel.teq + env1 + act_typ1 + k in + FStarC_Compiler_List.iter + (FStarC_TypeChecker_Rel.force_trivial_guard + env1) + [g_t; + g_d; + g_k; + g]; + ( + let uu___25 + = + (FStarC_Compiler_Debug.medium + ()) || + (FStarC_Compiler_Effect.op_Bang + dbg_LayeredEffectsTc) in + if + uu___25 + then + let uu___26 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + k in + FStarC_Compiler_Util.print1 + "Expected action type after unification: %s\n" + uu___26 + else ()); + ( + let act_typ2 + = + let err_msg + t = + let uu___25 + = + FStarC_Ident.string_of_lid + ed.FStarC_Syntax_Syntax.mname in + let uu___26 + = + FStarC_Ident.string_of_lid + act1.FStarC_Syntax_Syntax.action_name in + let uu___27 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t in + FStarC_Compiler_Util.format3 + "Unexpected (k-)type of action %s:%s, expected bs -> repr i_1 ... i_n, found: %s" + uu___25 + uu___26 + uu___27 in + let repr_args + t = + let uu___25 + = + let uu___26 + = + FStarC_Syntax_Subst.compress + t in + uu___26.FStarC_Syntax_Syntax.n in + match uu___25 + with + | + FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd + = head; + FStarC_Syntax_Syntax.args + = a::is;_} + -> + let uu___26 + = + let uu___27 + = + FStarC_Syntax_Subst.compress + head in + uu___27.FStarC_Syntax_Syntax.n in + (match uu___26 + with + | + FStarC_Syntax_Syntax.Tm_uinst + (uu___27, + us) -> + (us, + (FStar_Pervasives_Native.fst + a), is) + | + uu___27 + -> + let uu___28 + = + err_msg t in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + r + FStarC_Errors_Codes.Fatal_ActionMustHaveFunctionType + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + uu___28)) + | + uu___26 + -> + let uu___27 + = + err_msg t in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + r + FStarC_Errors_Codes.Fatal_ActionMustHaveFunctionType + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + uu___27) in + let k1 = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Beta] + env1 k in + let uu___25 + = + let uu___26 + = + FStarC_Syntax_Subst.compress + k1 in + uu___26.FStarC_Syntax_Syntax.n in + match uu___25 + with + | + FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 + = bs; + FStarC_Syntax_Syntax.comp + = c;_} -> + let uu___26 + = + FStarC_Syntax_Subst.open_comp + bs c in + (match uu___26 + with + | + (bs1, c1) + -> + let uu___27 + = + repr_args + (FStarC_Syntax_Util.comp_result + c1) in + (match uu___27 + with + | + (us, a, + is) -> + let ct = + { + FStarC_Syntax_Syntax.comp_univs + = us; + FStarC_Syntax_Syntax.effect_name + = + (ed.FStarC_Syntax_Syntax.mname); + FStarC_Syntax_Syntax.result_typ + = a; + FStarC_Syntax_Syntax.effect_args + = is; + FStarC_Syntax_Syntax.flags + = [] + } in + let uu___28 + = + FStarC_Syntax_Syntax.mk_Comp + ct in + FStarC_Syntax_Util.arrow + bs1 + uu___28)) + | + uu___26 + -> + let uu___27 + = + err_msg + k1 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + r + FStarC_Errors_Codes.Fatal_ActionMustHaveFunctionType + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + uu___27) in + ( + let uu___26 + = + (FStarC_Compiler_Debug.medium + ()) || + (FStarC_Compiler_Effect.op_Bang + dbg_LayeredEffectsTc) in + if + uu___26 + then + let uu___27 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + act_typ2 in + FStarC_Compiler_Util.print1 + "Action type after injecting it into the monad: %s\n" + uu___27 + else ()); + ( + let act2 + = + let uu___26 + = + FStarC_TypeChecker_Generalize.generalize_universes + env1 + act_defn in + match uu___26 + with + | + (us, + act_defn1) + -> + if + act1.FStarC_Syntax_Syntax.action_univs + = [] + then + let uu___27 + = + FStarC_Syntax_Subst.close_univ_vars + us + act_typ2 in + { + FStarC_Syntax_Syntax.action_name + = + (act1.FStarC_Syntax_Syntax.action_name); + FStarC_Syntax_Syntax.action_unqualified_name + = + (act1.FStarC_Syntax_Syntax.action_unqualified_name); + FStarC_Syntax_Syntax.action_univs + = us; + FStarC_Syntax_Syntax.action_params + = + (act1.FStarC_Syntax_Syntax.action_params); + FStarC_Syntax_Syntax.action_defn + = + act_defn1; + FStarC_Syntax_Syntax.action_typ + = uu___27 + } + else + (let uu___28 + = + ((FStarC_Compiler_List.length + us) = + (FStarC_Compiler_List.length + act1.FStarC_Syntax_Syntax.action_univs)) + && + (FStarC_Compiler_List.forall2 + (fun u1 + -> + fun u2 -> + let uu___29 + = + FStarC_Syntax_Syntax.order_univ_name + u1 u2 in + uu___29 = + Prims.int_zero) + us + act1.FStarC_Syntax_Syntax.action_univs) in + if + uu___28 + then + let uu___29 + = + FStarC_Syntax_Subst.close_univ_vars + act1.FStarC_Syntax_Syntax.action_univs + act_typ2 in + { + FStarC_Syntax_Syntax.action_name + = + (act1.FStarC_Syntax_Syntax.action_name); + FStarC_Syntax_Syntax.action_unqualified_name + = + (act1.FStarC_Syntax_Syntax.action_unqualified_name); + FStarC_Syntax_Syntax.action_univs + = + (act1.FStarC_Syntax_Syntax.action_univs); + FStarC_Syntax_Syntax.action_params + = + (act1.FStarC_Syntax_Syntax.action_params); + FStarC_Syntax_Syntax.action_defn + = + act_defn1; + FStarC_Syntax_Syntax.action_typ + = uu___29 + } + else + (let uu___30 + = + let uu___31 + = + FStarC_Ident.string_of_lid + ed.FStarC_Syntax_Syntax.mname in + let uu___32 + = + FStarC_Ident.string_of_lid + act1.FStarC_Syntax_Syntax.action_name in + let uu___33 + = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Ident.showable_ident) + us in + let uu___34 + = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Ident.showable_ident) + act1.FStarC_Syntax_Syntax.action_univs in + FStarC_Compiler_Util.format4 + "Expected and generalized universes in the declaration for %s:%s are different, input: %s, but after gen: %s" + uu___31 + uu___32 + uu___33 + uu___34 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + r + FStarC_Errors_Codes.Fatal_UnexpectedNumberOfUniverse + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + uu___30))) in + act2))))))))) in + let tc_action_with_ctx env act = + let uu___14 = + let uu___15 = + FStarC_Ident.string_of_lid + act.FStarC_Syntax_Syntax.action_name in + FStarC_Compiler_Util.format1 + "While checking the action %s" + uu___15 in + FStarC_Errors.with_ctx uu___14 + (fun uu___15 -> + tc_action env act) in + let extraction_mode = + let has_primitive_extraction = + FStarC_Syntax_Util.has_attribute + ed.FStarC_Syntax_Syntax.eff_attrs + FStarC_Parser_Const.primitive_extraction_attr in + let is_reifiable = + FStarC_Compiler_List.contains + FStarC_Syntax_Syntax.Reifiable + quals in + if + has_primitive_extraction && + is_reifiable + then + let uu___14 = + let uu___15 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + ed.FStarC_Syntax_Syntax.mname in + FStarC_Compiler_Util.format1 + "Effect %s is declared to be both primitive extraction and reifiable" + uu___15 in + FStarC_Errors.raise_error + FStarC_Ident.hasrange_lident + ed.FStarC_Syntax_Syntax.mname + FStarC_Errors_Codes.Fatal_UnexpectedEffect + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___14) + else + if has_primitive_extraction + then + FStarC_Syntax_Syntax.Extract_primitive + else + (let uu___16 = + let uu___17 = + let uu___18 = signature in + match uu___18 with + | (us, t, uu___19) -> + (us, t) in + match uu___17 with + | (us, t) -> + let uu___18 = + let uu___19 = + FStarC_Syntax_Subst.compress + t in + uu___19.FStarC_Syntax_Syntax.n in + (match uu___18 with + | FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 + = bs; + FStarC_Syntax_Syntax.comp + = uu___19;_} + -> + let uu___20 = + FStarC_Syntax_Subst.open_binders + bs in + (match uu___20 + with + | a_b::rest_bs + -> + (us, a_b, + rest_bs)) + | uu___19 -> + failwith + "Impossible!") in + match uu___16 with + | (us, a_b, rest_bs) -> + let env = + FStarC_TypeChecker_Env.push_univ_vars + env0 us in + let env1 = + FStarC_TypeChecker_Env.push_binders + env [a_b] in + let uu___17 = + FStarC_Compiler_List.fold_left + (fun uu___18 -> + fun b -> + match uu___18 + with + | (env2, r) -> + let r1 = + r && + (FStarC_TypeChecker_Normalize.non_info_norm + env2 + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort) in + let uu___19 + = + FStarC_TypeChecker_Env.push_binders + env2 + [b] in + (uu___19, + r1)) + (env1, true) + rest_bs in + (match uu___17 with + | (uu___18, r) -> + let uu___19 = + (r && + (FStarC_Syntax_Syntax.uu___is_Substitutive_combinator + bind_kind)) + && + (is_reifiable + || + (FStarC_Ident.lid_equals + ed.FStarC_Syntax_Syntax.mname + FStarC_Parser_Const.effect_TAC_lid)) in + if uu___19 + then + FStarC_Syntax_Syntax.Extract_reify + else + (let m = + if + Prims.op_Negation + r + then + "one or more effect indices are informative" + else + if + Prims.op_Negation + (FStarC_Syntax_Syntax.uu___is_Substitutive_combinator + bind_kind) + then + "bind is not substitutive" + else + "the effect is not reifiable" in + FStarC_Syntax_Syntax.Extract_none + m))) in + (let uu___15 = + FStarC_Compiler_Effect.op_Bang + dbg_LayeredEffectsTc in + if uu___15 + then + let uu___16 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + ed.FStarC_Syntax_Syntax.mname in + let uu___17 = + FStarC_Class_Show.show + FStarC_Syntax_Syntax.showable_eff_extraction_mode + extraction_mode in + FStarC_Compiler_Util.print2 + "Effect %s has extraction mode %s\n" + uu___16 uu___17 + else ()); + (let tschemes_of uu___15 k = + match uu___15 with + | (us, t, ty) -> + ((us, t), (us, ty), k) in + let tschemes_of2 uu___15 = + match uu___15 with + | (us, t, ty) -> + ((us, t), (us, ty)) in + let combinators = + FStarC_Syntax_Syntax.Layered_eff + { + FStarC_Syntax_Syntax.l_repr + = (tschemes_of2 repr); + FStarC_Syntax_Syntax.l_return + = + (tschemes_of2 return_repr); + FStarC_Syntax_Syntax.l_bind + = + (tschemes_of bind_repr + (FStar_Pervasives_Native.Some + bind_kind)); + FStarC_Syntax_Syntax.l_subcomp + = + (tschemes_of + stronger_repr + (FStar_Pervasives_Native.Some + subcomp_kind)); + FStarC_Syntax_Syntax.l_if_then_else + = + (tschemes_of if_then_else + (FStar_Pervasives_Native.Some + ite_kind)); + FStarC_Syntax_Syntax.l_close + = + (match close_ with + | FStar_Pervasives_Native.None + -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some + (us, t, ty) -> + FStar_Pervasives_Native.Some + ((us, t), + (us, ty))) + } in + let uu___15 = + FStarC_Compiler_List.map + (tc_action_with_ctx env0) + ed.FStarC_Syntax_Syntax.actions in + { + FStarC_Syntax_Syntax.mname = + (ed.FStarC_Syntax_Syntax.mname); + FStarC_Syntax_Syntax.cattributes + = + (ed.FStarC_Syntax_Syntax.cattributes); + FStarC_Syntax_Syntax.univs = + (ed.FStarC_Syntax_Syntax.univs); + FStarC_Syntax_Syntax.binders = + (ed.FStarC_Syntax_Syntax.binders); + FStarC_Syntax_Syntax.signature + = + (FStarC_Syntax_Syntax.Layered_eff_sig + (num_effect_params, + (let uu___16 = signature in + match uu___16 with + | (us, t, uu___17) -> + (us, t)))); + FStarC_Syntax_Syntax.combinators + = combinators; + FStarC_Syntax_Syntax.actions = + uu___15; + FStarC_Syntax_Syntax.eff_attrs + = + (ed.FStarC_Syntax_Syntax.eff_attrs); + FStarC_Syntax_Syntax.extraction_mode + = extraction_mode + })))))))))))))) +let (tc_non_layered_eff_decl : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.eff_decl -> + FStarC_Syntax_Syntax.qualifier Prims.list -> + FStarC_Syntax_Syntax.attribute Prims.list -> + FStarC_Syntax_Syntax.eff_decl) + = + fun env0 -> + fun ed -> + fun _quals -> + fun _attrs -> + let uu___ = + let uu___1 = + FStarC_Ident.string_of_lid ed.FStarC_Syntax_Syntax.mname in + FStarC_Compiler_Util.format1 + "While checking effect definition `%s`" uu___1 in + FStarC_Errors.with_ctx uu___ + (fun uu___1 -> + (let uu___3 = FStarC_Compiler_Effect.op_Bang dbg in + if uu___3 + then + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_eff_decl ed in + FStarC_Compiler_Util.print1 + "Typechecking eff_decl: \n\t%s\n" uu___4 + else ()); + (let uu___3 = + let uu___4 = + FStarC_Syntax_Subst.univ_var_opening + ed.FStarC_Syntax_Syntax.univs in + match uu___4 with + | (ed_univs_subst, ed_univs) -> + let bs = + let uu___5 = + FStarC_Syntax_Subst.subst_binders ed_univs_subst + ed.FStarC_Syntax_Syntax.binders in + FStarC_Syntax_Subst.open_binders uu___5 in + let uu___5 = + let uu___6 = + FStarC_TypeChecker_Env.push_univ_vars env0 ed_univs in + FStarC_TypeChecker_TcTerm.tc_tparams uu___6 bs in + (match uu___5 with + | (bs1, uu___6, uu___7) -> + let uu___8 = + let tmp_t = + let uu___9 = + FStarC_Syntax_Syntax.mk_Total + FStarC_Syntax_Syntax.t_unit in + FStarC_Syntax_Util.arrow bs1 uu___9 in + let uu___9 = + FStarC_TypeChecker_Generalize.generalize_universes + env0 tmp_t in + match uu___9 with + | (us, tmp_t1) -> + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Syntax_Util.arrow_formals + tmp_t1 in + FStar_Pervasives_Native.fst uu___12 in + FStarC_Syntax_Subst.close_binders uu___11 in + (us, uu___10) in + (match uu___8 with + | (us, bs2) -> + (match ed_univs with + | [] -> (us, bs2) + | uu___9 -> + let uu___10 = + ((FStarC_Compiler_List.length ed_univs) + = (FStarC_Compiler_List.length us)) + && + (FStarC_Compiler_List.forall2 + (fun u1 -> + fun u2 -> + let uu___11 = + FStarC_Syntax_Syntax.order_univ_name + u1 u2 in + uu___11 = Prims.int_zero) + ed_univs us) in + if uu___10 + then (us, bs2) + else + (let uu___12 = + let uu___13 = + let uu___14 = + FStarC_Errors_Msg.text + "Expected and generalized universes in effect declaration for" in + let uu___15 = + let uu___16 = + let uu___17 = + FStarC_Ident.string_of_lid + ed.FStarC_Syntax_Syntax.mname in + FStarC_Pprint.doc_of_string + uu___17 in + let uu___17 = + FStarC_Errors_Msg.text + "are different" in + FStarC_Pprint.op_Hat_Slash_Hat + uu___16 uu___17 in + FStarC_Pprint.op_Hat_Slash_Hat + uu___14 uu___15 in + let uu___14 = + let uu___15 = + let uu___16 = + FStarC_Errors_Msg.text + "Expected" in + let uu___17 = + let uu___18 = + FStarC_Class_PP.pp + FStarC_Class_PP.pp_int + (FStarC_Compiler_List.length + ed_univs) in + let uu___19 = + let uu___20 = + FStarC_Errors_Msg.text + "but found" in + let uu___21 = + FStarC_Class_PP.pp + FStarC_Class_PP.pp_int + (FStarC_Compiler_List.length + us) in + FStarC_Pprint.op_Hat_Slash_Hat + uu___20 uu___21 in + FStarC_Pprint.op_Hat_Slash_Hat + uu___18 uu___19 in + FStarC_Pprint.op_Hat_Slash_Hat + uu___16 uu___17 in + [uu___15] in + uu___13 :: uu___14 in + FStarC_Errors.raise_error + FStarC_Ident.hasrange_lident + ed.FStarC_Syntax_Syntax.mname + FStarC_Errors_Codes.Fatal_UnexpectedNumberOfUniverse + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___12))))) in + match uu___3 with + | (us, bs) -> + let ed1 = + { + FStarC_Syntax_Syntax.mname = + (ed.FStarC_Syntax_Syntax.mname); + FStarC_Syntax_Syntax.cattributes = + (ed.FStarC_Syntax_Syntax.cattributes); + FStarC_Syntax_Syntax.univs = us; + FStarC_Syntax_Syntax.binders = bs; + FStarC_Syntax_Syntax.signature = + (ed.FStarC_Syntax_Syntax.signature); + FStarC_Syntax_Syntax.combinators = + (ed.FStarC_Syntax_Syntax.combinators); + FStarC_Syntax_Syntax.actions = + (ed.FStarC_Syntax_Syntax.actions); + FStarC_Syntax_Syntax.eff_attrs = + (ed.FStarC_Syntax_Syntax.eff_attrs); + FStarC_Syntax_Syntax.extraction_mode = + (ed.FStarC_Syntax_Syntax.extraction_mode) + } in + let uu___4 = FStarC_Syntax_Subst.univ_var_opening us in + (match uu___4 with + | (ed_univs_subst, ed_univs) -> + let uu___5 = + let uu___6 = + FStarC_Syntax_Subst.subst_binders ed_univs_subst + bs in + FStarC_Syntax_Subst.open_binders' uu___6 in + (match uu___5 with + | (ed_bs, ed_bs_subst) -> + let ed2 = + let op uu___6 = + match uu___6 with + | (us1, t) -> + let t1 = + let uu___7 = + FStarC_Syntax_Subst.shift_subst + ((FStarC_Compiler_List.length + ed_bs) + + + (FStarC_Compiler_List.length + us1)) ed_univs_subst in + FStarC_Syntax_Subst.subst uu___7 t in + let uu___7 = + let uu___8 = + FStarC_Syntax_Subst.shift_subst + (FStarC_Compiler_List.length us1) + ed_bs_subst in + FStarC_Syntax_Subst.subst uu___8 t1 in + (us1, uu___7) in + let uu___6 = + FStarC_Syntax_Util.apply_eff_sig op + ed1.FStarC_Syntax_Syntax.signature in + let uu___7 = + FStarC_Syntax_Util.apply_eff_combinators op + ed1.FStarC_Syntax_Syntax.combinators in + let uu___8 = + FStarC_Compiler_List.map + (fun a -> + let uu___9 = + let uu___10 = + op + ((a.FStarC_Syntax_Syntax.action_univs), + (a.FStarC_Syntax_Syntax.action_defn)) in + FStar_Pervasives_Native.snd uu___10 in + let uu___10 = + let uu___11 = + op + ((a.FStarC_Syntax_Syntax.action_univs), + (a.FStarC_Syntax_Syntax.action_typ)) in + FStar_Pervasives_Native.snd uu___11 in + { + FStarC_Syntax_Syntax.action_name = + (a.FStarC_Syntax_Syntax.action_name); + FStarC_Syntax_Syntax.action_unqualified_name + = + (a.FStarC_Syntax_Syntax.action_unqualified_name); + FStarC_Syntax_Syntax.action_univs = + (a.FStarC_Syntax_Syntax.action_univs); + FStarC_Syntax_Syntax.action_params = + (a.FStarC_Syntax_Syntax.action_params); + FStarC_Syntax_Syntax.action_defn = + uu___9; + FStarC_Syntax_Syntax.action_typ = + uu___10 + }) ed1.FStarC_Syntax_Syntax.actions in + { + FStarC_Syntax_Syntax.mname = + (ed1.FStarC_Syntax_Syntax.mname); + FStarC_Syntax_Syntax.cattributes = + (ed1.FStarC_Syntax_Syntax.cattributes); + FStarC_Syntax_Syntax.univs = + (ed1.FStarC_Syntax_Syntax.univs); + FStarC_Syntax_Syntax.binders = + (ed1.FStarC_Syntax_Syntax.binders); + FStarC_Syntax_Syntax.signature = uu___6; + FStarC_Syntax_Syntax.combinators = uu___7; + FStarC_Syntax_Syntax.actions = uu___8; + FStarC_Syntax_Syntax.eff_attrs = + (ed1.FStarC_Syntax_Syntax.eff_attrs); + FStarC_Syntax_Syntax.extraction_mode = + (ed1.FStarC_Syntax_Syntax.extraction_mode) + } in + ((let uu___7 = + FStarC_Compiler_Effect.op_Bang dbg in + if uu___7 + then + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_eff_decl + ed2 in + FStarC_Compiler_Util.print1 + "After typechecking binders eff_decl: \n\t%s\n" + uu___8 + else ()); + (let env = + let uu___7 = + FStarC_TypeChecker_Env.push_univ_vars + env0 ed_univs in + FStarC_TypeChecker_Env.push_binders uu___7 + ed_bs in + let check_and_gen' comb n env_opt uu___7 k = + match uu___7 with + | (us1, t) -> + let env1 = + if + FStarC_Compiler_Util.is_some + env_opt + then + FStarC_Compiler_Util.must env_opt + else env in + let uu___8 = + FStarC_Syntax_Subst.open_univ_vars + us1 t in + (match uu___8 with + | (us2, t1) -> + let t2 = + match k with + | FStar_Pervasives_Native.Some + k1 -> + let uu___9 = + FStarC_TypeChecker_Env.push_univ_vars + env1 us2 in + FStarC_TypeChecker_TcTerm.tc_check_trivial_guard + uu___9 t1 k1 + | FStar_Pervasives_Native.None + -> + let uu___9 = + let uu___10 = + FStarC_TypeChecker_Env.push_univ_vars + env1 us2 in + FStarC_TypeChecker_TcTerm.tc_tot_or_gtot_term + uu___10 t1 in + (match uu___9 with + | (t3, uu___10, g) -> + (FStarC_TypeChecker_Rel.force_trivial_guard + env1 g; + t3)) in + let uu___9 = + FStarC_TypeChecker_Generalize.generalize_universes + env1 t2 in + (match uu___9 with + | (g_us, t3) -> + (if + (FStarC_Compiler_List.length + g_us) + <> n + then + (let error = + let uu___11 = + FStarC_Ident.string_of_lid + ed2.FStarC_Syntax_Syntax.mname in + let uu___12 = + FStarC_Compiler_Util.string_of_int + n in + let uu___13 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length + g_us) in + FStarC_Compiler_Util.format4 + "Expected %s:%s to be universe-polymorphic in %s universes, found %s" + uu___11 comb uu___12 + uu___13 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax + ()) t3 + FStarC_Errors_Codes.Fatal_MismatchUniversePolymorphic + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic error)) + else (); + (match us2 with + | [] -> (g_us, t3) + | uu___11 -> + let uu___12 = + ((FStarC_Compiler_List.length + us2) + = + (FStarC_Compiler_List.length + g_us)) + && + (FStarC_Compiler_List.forall2 + (fun u1 -> + fun u2 -> + let uu___13 + = + FStarC_Syntax_Syntax.order_univ_name + u1 u2 in + uu___13 = + Prims.int_zero) + us2 g_us) in + if uu___12 + then (g_us, t3) + else + (let uu___14 = + let uu___15 = + FStarC_Ident.string_of_lid + ed2.FStarC_Syntax_Syntax.mname in + let uu___16 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length + us2) in + let uu___17 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length + g_us) in + FStarC_Compiler_Util.format4 + "Expected and generalized universes in the declaration for %s:%s are different, expected: %s, but found %s" + uu___15 comb + uu___16 uu___17 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax + ()) t3 + FStarC_Errors_Codes.Fatal_UnexpectedNumberOfUniverse + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___14)))))) in + let signature = + let uu___7 = + FStarC_Syntax_Util.effect_sig_ts + ed2.FStarC_Syntax_Syntax.signature in + check_and_gen' "signature" Prims.int_one + FStar_Pervasives_Native.None uu___7 + FStar_Pervasives_Native.None in + (let uu___8 = + FStarC_Compiler_Effect.op_Bang dbg in + if uu___8 + then + let uu___9 = + FStarC_Syntax_Print.tscheme_to_string + signature in + FStarC_Compiler_Util.print1 + "Typechecked signature: %s\n" uu___9 + else ()); + (let fresh_a_and_wp uu___8 = + let fail t = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Syntax_Util.effect_sig_ts + ed2.FStarC_Syntax_Syntax.signature in + FStar_Pervasives_Native.snd uu___11 in + uu___10.FStarC_Syntax_Syntax.pos in + FStarC_TypeChecker_Err.unexpected_signature_for_monad + env uu___9 + ed2.FStarC_Syntax_Syntax.mname t in + let uu___9 = + FStarC_TypeChecker_Env.inst_tscheme + signature in + match uu___9 with + | (uu___10, signature1) -> + let uu___11 = + let uu___12 = + FStarC_Syntax_Subst.compress + signature1 in + uu___12.FStarC_Syntax_Syntax.n in + (match uu___11 with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs1; + FStarC_Syntax_Syntax.comp = + uu___12;_} + -> + let bs2 = + FStarC_Syntax_Subst.open_binders + bs1 in + (match bs2 with + | { + FStarC_Syntax_Syntax.binder_bv + = a; + FStarC_Syntax_Syntax.binder_qual + = uu___13; + FStarC_Syntax_Syntax.binder_positivity + = uu___14; + FStarC_Syntax_Syntax.binder_attrs + = uu___15;_}::{ + FStarC_Syntax_Syntax.binder_bv + = wp; + FStarC_Syntax_Syntax.binder_qual + = uu___16; + FStarC_Syntax_Syntax.binder_positivity + = uu___17; + FStarC_Syntax_Syntax.binder_attrs + = uu___18;_}::[] + -> + (a, + (wp.FStarC_Syntax_Syntax.sort)) + | uu___13 -> fail signature1) + | uu___12 -> fail signature1) in + let log_combinator s ts = + let uu___8 = + FStarC_Compiler_Effect.op_Bang dbg in + if uu___8 + then + let uu___9 = + FStarC_Ident.string_of_lid + ed2.FStarC_Syntax_Syntax.mname in + let uu___10 = + FStarC_Syntax_Print.tscheme_to_string + ts in + FStarC_Compiler_Util.print3 + "Typechecked %s:%s = %s\n" uu___9 s + uu___10 + else () in + let ret_wp = + let uu___8 = fresh_a_and_wp () in + match uu___8 with + | (a, wp_sort) -> + let k = + let uu___9 = + let uu___10 = + FStarC_Syntax_Syntax.mk_binder a in + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Syntax_Syntax.bv_to_name + a in + FStarC_Syntax_Syntax.null_binder + uu___13 in + [uu___12] in + uu___10 :: uu___11 in + let uu___10 = + FStarC_Syntax_Syntax.mk_GTotal + wp_sort in + FStarC_Syntax_Util.arrow uu___9 + uu___10 in + let uu___9 = + FStarC_Syntax_Util.get_return_vc_combinator + ed2 in + check_and_gen' "ret_wp" Prims.int_one + FStar_Pervasives_Native.None uu___9 + (FStar_Pervasives_Native.Some k) in + log_combinator "ret_wp" ret_wp; + (let bind_wp = + let uu___9 = fresh_a_and_wp () in + match uu___9 with + | (a, wp_sort_a) -> + let uu___10 = fresh_a_and_wp () in + (match uu___10 with + | (b, wp_sort_b) -> + let wp_sort_a_b = + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Syntax_Syntax.bv_to_name + a in + FStarC_Syntax_Syntax.null_binder + uu___13 in + [uu___12] in + let uu___12 = + FStarC_Syntax_Syntax.mk_Total + wp_sort_b in + FStarC_Syntax_Util.arrow + uu___11 uu___12 in + let k = + let uu___11 = + let uu___12 = + FStarC_Syntax_Syntax.mk_binder + a in + let uu___13 = + let uu___14 = + FStarC_Syntax_Syntax.mk_binder + b in + let uu___15 = + let uu___16 = + FStarC_Syntax_Syntax.null_binder + wp_sort_a in + let uu___17 = + let uu___18 = + FStarC_Syntax_Syntax.null_binder + wp_sort_a_b in + [uu___18] in + uu___16 :: uu___17 in + uu___14 :: uu___15 in + uu___12 :: uu___13 in + let uu___12 = + FStarC_Syntax_Syntax.mk_Total + wp_sort_b in + FStarC_Syntax_Util.arrow + uu___11 uu___12 in + let uu___11 = + let uu___12 = + FStarC_Syntax_Util.get_bind_vc_combinator + ed2 in + FStar_Pervasives_Native.fst + uu___12 in + check_and_gen' "bind_wp" + (Prims.of_int (2)) + FStar_Pervasives_Native.None + uu___11 + (FStar_Pervasives_Native.Some + k)) in + log_combinator "bind_wp" bind_wp; + (let stronger = + let uu___10 = fresh_a_and_wp () in + match uu___10 with + | (a, wp_sort_a) -> + let uu___11 = + FStarC_Syntax_Util.type_u () in + (match uu___11 with + | (t, uu___12) -> + let k = + let uu___13 = + let uu___14 = + FStarC_Syntax_Syntax.mk_binder + a in + let uu___15 = + let uu___16 = + FStarC_Syntax_Syntax.null_binder + wp_sort_a in + let uu___17 = + let uu___18 = + FStarC_Syntax_Syntax.null_binder + wp_sort_a in + [uu___18] in + uu___16 :: uu___17 in + uu___14 :: uu___15 in + let uu___14 = + FStarC_Syntax_Syntax.mk_Total + t in + FStarC_Syntax_Util.arrow + uu___13 uu___14 in + let uu___13 = + let uu___14 = + FStarC_Syntax_Util.get_stronger_vc_combinator + ed2 in + FStar_Pervasives_Native.fst + uu___14 in + check_and_gen' "stronger" + Prims.int_one + FStar_Pervasives_Native.None + uu___13 + (FStar_Pervasives_Native.Some + k)) in + log_combinator "stronger" stronger; + (let if_then_else = + let uu___11 = fresh_a_and_wp () in + match uu___11 with + | (a, wp_sort_a) -> + let p = + let uu___12 = + let uu___13 = + FStarC_Ident.range_of_lid + ed2.FStarC_Syntax_Syntax.mname in + FStar_Pervasives_Native.Some + uu___13 in + let uu___13 = + let uu___14 = + FStarC_Syntax_Util.type_u () in + FStar_Pervasives_Native.fst + uu___14 in + FStarC_Syntax_Syntax.new_bv + uu___12 uu___13 in + let k = + let uu___12 = + let uu___13 = + FStarC_Syntax_Syntax.mk_binder + a in + let uu___14 = + let uu___15 = + FStarC_Syntax_Syntax.mk_binder + p in + let uu___16 = + let uu___17 = + FStarC_Syntax_Syntax.null_binder + wp_sort_a in + let uu___18 = + let uu___19 = + FStarC_Syntax_Syntax.null_binder + wp_sort_a in + [uu___19] in + uu___17 :: uu___18 in + uu___15 :: uu___16 in + uu___13 :: uu___14 in + let uu___13 = + FStarC_Syntax_Syntax.mk_Total + wp_sort_a in + FStarC_Syntax_Util.arrow uu___12 + uu___13 in + let uu___12 = + let uu___13 = + FStarC_Syntax_Util.get_wp_if_then_else_combinator + ed2 in + FStarC_Compiler_Util.must uu___13 in + check_and_gen' "if_then_else" + Prims.int_one + FStar_Pervasives_Native.None + uu___12 + (FStar_Pervasives_Native.Some k) in + log_combinator "if_then_else" + if_then_else; + (let ite_wp = + let uu___12 = fresh_a_and_wp () in + match uu___12 with + | (a, wp_sort_a) -> + let k = + let uu___13 = + let uu___14 = + FStarC_Syntax_Syntax.mk_binder + a in + let uu___15 = + let uu___16 = + FStarC_Syntax_Syntax.null_binder + wp_sort_a in + [uu___16] in + uu___14 :: uu___15 in + let uu___14 = + FStarC_Syntax_Syntax.mk_Total + wp_sort_a in + FStarC_Syntax_Util.arrow uu___13 + uu___14 in + let uu___13 = + let uu___14 = + FStarC_Syntax_Util.get_wp_ite_combinator + ed2 in + FStarC_Compiler_Util.must + uu___14 in + check_and_gen' "ite_wp" + Prims.int_one + FStar_Pervasives_Native.None + uu___13 + (FStar_Pervasives_Native.Some k) in + log_combinator "ite_wp" ite_wp; + (let close_wp = + let uu___13 = fresh_a_and_wp () in + match uu___13 with + | (a, wp_sort_a) -> + let b = + let uu___14 = + let uu___15 = + FStarC_Ident.range_of_lid + ed2.FStarC_Syntax_Syntax.mname in + FStar_Pervasives_Native.Some + uu___15 in + let uu___15 = + let uu___16 = + FStarC_Syntax_Util.type_u + () in + FStar_Pervasives_Native.fst + uu___16 in + FStarC_Syntax_Syntax.new_bv + uu___14 uu___15 in + let wp_sort_b_a = + let uu___14 = + let uu___15 = + let uu___16 = + FStarC_Syntax_Syntax.bv_to_name + b in + FStarC_Syntax_Syntax.null_binder + uu___16 in + [uu___15] in + let uu___15 = + FStarC_Syntax_Syntax.mk_Total + wp_sort_a in + FStarC_Syntax_Util.arrow + uu___14 uu___15 in + let k = + let uu___14 = + let uu___15 = + FStarC_Syntax_Syntax.mk_binder + a in + let uu___16 = + let uu___17 = + FStarC_Syntax_Syntax.mk_binder + b in + let uu___18 = + let uu___19 = + FStarC_Syntax_Syntax.null_binder + wp_sort_b_a in + [uu___19] in + uu___17 :: uu___18 in + uu___15 :: uu___16 in + let uu___15 = + FStarC_Syntax_Syntax.mk_Total + wp_sort_a in + FStarC_Syntax_Util.arrow + uu___14 uu___15 in + let uu___14 = + let uu___15 = + FStarC_Syntax_Util.get_wp_close_combinator + ed2 in + FStarC_Compiler_Util.must + uu___15 in + check_and_gen' "close_wp" + (Prims.of_int (2)) + FStar_Pervasives_Native.None + uu___14 + (FStar_Pervasives_Native.Some k) in + log_combinator "close_wp" close_wp; + (let trivial = + let uu___14 = fresh_a_and_wp () in + match uu___14 with + | (a, wp_sort_a) -> + let uu___15 = + FStarC_Syntax_Util.type_u () in + (match uu___15 with + | (t, uu___16) -> + let k = + let uu___17 = + let uu___18 = + FStarC_Syntax_Syntax.mk_binder + a in + let uu___19 = + let uu___20 = + FStarC_Syntax_Syntax.null_binder + wp_sort_a in + [uu___20] in + uu___18 :: uu___19 in + let uu___18 = + FStarC_Syntax_Syntax.mk_GTotal + t in + FStarC_Syntax_Util.arrow + uu___17 uu___18 in + let trivial1 = + let uu___17 = + let uu___18 = + FStarC_Syntax_Util.get_wp_trivial_combinator + ed2 in + FStarC_Compiler_Util.must + uu___18 in + check_and_gen' "trivial" + Prims.int_one + FStar_Pervasives_Native.None + uu___17 + (FStar_Pervasives_Native.Some + k) in + (log_combinator "trivial" + trivial1; + trivial1)) in + let uu___14 = + let uu___15 = + FStarC_Syntax_Util.get_eff_repr + ed2 in + match uu___15 with + | FStar_Pervasives_Native.None -> + (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None, + (ed2.FStarC_Syntax_Syntax.actions)) + | uu___16 -> + let repr = + let uu___17 = + fresh_a_and_wp () in + match uu___17 with + | (a, wp_sort_a) -> + let uu___18 = + FStarC_Syntax_Util.type_u + () in + (match uu___18 with + | (t, uu___19) -> + let k = + let uu___20 = + let uu___21 = + FStarC_Syntax_Syntax.mk_binder + a in + let uu___22 = + let uu___23 = + FStarC_Syntax_Syntax.null_binder + wp_sort_a in + [uu___23] in + uu___21 :: + uu___22 in + let uu___21 = + FStarC_Syntax_Syntax.mk_GTotal + t in + FStarC_Syntax_Util.arrow + uu___20 uu___21 in + let uu___20 = + let uu___21 = + FStarC_Syntax_Util.get_eff_repr + ed2 in + FStarC_Compiler_Util.must + uu___21 in + check_and_gen' "repr" + Prims.int_one + FStar_Pervasives_Native.None + uu___20 + (FStar_Pervasives_Native.Some + k)) in + (log_combinator "repr" repr; + (let mk_repr' t wp = + let uu___18 = + FStarC_TypeChecker_Env.inst_tscheme + repr in + match uu___18 with + | (uu___19, repr1) -> + let repr2 = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.EraseUniverses; + FStarC_TypeChecker_Env.AllowUnboundUniverses] + env repr1 in + let uu___20 = + let uu___21 = + let uu___22 = + let uu___23 = + FStarC_Syntax_Syntax.as_arg + t in + let uu___24 = + let uu___25 = + FStarC_Syntax_Syntax.as_arg + wp in + [uu___25] in + uu___23 :: uu___24 in + { + FStarC_Syntax_Syntax.hd + = repr2; + FStarC_Syntax_Syntax.args + = uu___22 + } in + FStarC_Syntax_Syntax.Tm_app + uu___21 in + FStarC_Syntax_Syntax.mk + uu___20 + FStarC_Compiler_Range_Type.dummyRange in + let mk_repr a wp = + let uu___18 = + FStarC_Syntax_Syntax.bv_to_name + a in + mk_repr' uu___18 wp in + let destruct_repr t = + let uu___18 = + let uu___19 = + FStarC_Syntax_Subst.compress + t in + uu___19.FStarC_Syntax_Syntax.n in + match uu___18 with + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd + = uu___19; + FStarC_Syntax_Syntax.args + = + (t1, uu___20):: + (wp, uu___21)::[];_} + -> (t1, wp) + | uu___19 -> + failwith + "Unexpected repr type" in + let return_repr = + let return_repr_ts = + let uu___18 = + FStarC_Syntax_Util.get_return_repr + ed2 in + FStarC_Compiler_Util.must + uu___18 in + let uu___18 = + fresh_a_and_wp () in + match uu___18 with + | (a, uu___19) -> + let x_a = + let uu___20 = + FStarC_Syntax_Syntax.bv_to_name + a in + FStarC_Syntax_Syntax.gen_bv + "x_a" + FStar_Pervasives_Native.None + uu___20 in + let res = + let wp = + let uu___20 = + let uu___21 = + FStarC_TypeChecker_Env.inst_tscheme + ret_wp in + FStar_Pervasives_Native.snd + uu___21 in + let uu___21 = + let uu___22 = + let uu___23 = + FStarC_Syntax_Syntax.bv_to_name + a in + FStarC_Syntax_Syntax.as_arg + uu___23 in + let uu___23 = + let uu___24 = + let uu___25 = + FStarC_Syntax_Syntax.bv_to_name + x_a in + FStarC_Syntax_Syntax.as_arg + uu___25 in + [uu___24] in + uu___22 :: uu___23 in + FStarC_Syntax_Syntax.mk_Tm_app + uu___20 uu___21 + FStarC_Compiler_Range_Type.dummyRange in + mk_repr a wp in + let k = + let uu___20 = + let uu___21 = + FStarC_Syntax_Syntax.mk_binder + a in + let uu___22 = + let uu___23 = + FStarC_Syntax_Syntax.mk_binder + x_a in + [uu___23] in + uu___21 :: uu___22 in + let uu___21 = + FStarC_Syntax_Syntax.mk_Total + res in + FStarC_Syntax_Util.arrow + uu___20 uu___21 in + let uu___20 = + FStarC_TypeChecker_TcTerm.tc_tot_or_gtot_term + env k in + (match uu___20 with + | (k1, uu___21, + uu___22) -> + let env1 = + let uu___23 = + FStarC_TypeChecker_Env.set_range + env + (FStar_Pervasives_Native.snd + return_repr_ts).FStarC_Syntax_Syntax.pos in + FStar_Pervasives_Native.Some + uu___23 in + check_and_gen' + "return_repr" + Prims.int_one + env1 + return_repr_ts + (FStar_Pervasives_Native.Some + k1)) in + log_combinator "return_repr" + return_repr; + (let bind_repr = + let bind_repr_ts = + let uu___19 = + FStarC_Syntax_Util.get_bind_repr + ed2 in + FStarC_Compiler_Util.must + uu___19 in + let uu___19 = + fresh_a_and_wp () in + match uu___19 with + | (a, wp_sort_a) -> + let uu___20 = + fresh_a_and_wp () in + (match uu___20 with + | (b, wp_sort_b) -> + let wp_sort_a_b = + let uu___21 = + let uu___22 = + let uu___23 + = + FStarC_Syntax_Syntax.bv_to_name + a in + FStarC_Syntax_Syntax.null_binder + uu___23 in + [uu___22] in + let uu___22 = + FStarC_Syntax_Syntax.mk_Total + wp_sort_b in + FStarC_Syntax_Util.arrow + uu___21 + uu___22 in + let wp_f = + FStarC_Syntax_Syntax.gen_bv + "wp_f" + FStar_Pervasives_Native.None + wp_sort_a in + let wp_g = + FStarC_Syntax_Syntax.gen_bv + "wp_g" + FStar_Pervasives_Native.None + wp_sort_a_b in + let x_a = + let uu___21 = + FStarC_Syntax_Syntax.bv_to_name + a in + FStarC_Syntax_Syntax.gen_bv + "x_a" + FStar_Pervasives_Native.None + uu___21 in + let wp_g_x = + let uu___21 = + FStarC_Syntax_Syntax.bv_to_name + wp_g in + let uu___22 = + let uu___23 = + let uu___24 + = + FStarC_Syntax_Syntax.bv_to_name + x_a in + FStarC_Syntax_Syntax.as_arg + uu___24 in + [uu___23] in + FStarC_Syntax_Syntax.mk_Tm_app + uu___21 + uu___22 + FStarC_Compiler_Range_Type.dummyRange in + let res = + let wp = + let uu___21 = + let uu___22 + = + FStarC_TypeChecker_Env.inst_tscheme + bind_wp in + FStar_Pervasives_Native.snd + uu___22 in + let uu___22 = + let uu___23 + = + let uu___24 + = + FStarC_Syntax_Syntax.bv_to_name + a in + let uu___25 + = + let uu___26 + = + FStarC_Syntax_Syntax.bv_to_name + b in + let uu___27 + = + let uu___28 + = + FStarC_Syntax_Syntax.bv_to_name + wp_f in + let uu___29 + = + let uu___30 + = + FStarC_Syntax_Syntax.bv_to_name + wp_g in + [uu___30] in + uu___28 + :: + uu___29 in + uu___26 + :: + uu___27 in + uu___24 :: + uu___25 in + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.as_arg + uu___23 in + FStarC_Syntax_Syntax.mk_Tm_app + uu___21 + uu___22 + FStarC_Compiler_Range_Type.dummyRange in + mk_repr b wp in + let maybe_range_arg + = + let uu___21 = + FStarC_Compiler_Util.for_some + (FStarC_TypeChecker_TermEqAndSimplify.eq_tm_bool + env + FStarC_Syntax_Util.dm4f_bind_range_attr) + ed2.FStarC_Syntax_Syntax.eff_attrs in + if uu___21 + then + let uu___22 = + FStarC_Syntax_Syntax.null_binder + FStarC_Syntax_Syntax.t_range in + let uu___23 = + let uu___24 + = + FStarC_Syntax_Syntax.null_binder + FStarC_Syntax_Syntax.t_range in + [uu___24] in + uu___22 :: + uu___23 + else [] in + let k = + let uu___21 = + let uu___22 = + let uu___23 + = + FStarC_Syntax_Syntax.mk_binder + a in + let uu___24 + = + let uu___25 + = + FStarC_Syntax_Syntax.mk_binder + b in + [uu___25] in + uu___23 :: + uu___24 in + let uu___23 = + let uu___24 + = + let uu___25 + = + FStarC_Syntax_Syntax.mk_binder + wp_f in + let uu___26 + = + let uu___27 + = + let uu___28 + = + let uu___29 + = + FStarC_Syntax_Syntax.bv_to_name + wp_f in + mk_repr a + uu___29 in + FStarC_Syntax_Syntax.null_binder + uu___28 in + let uu___28 + = + let uu___29 + = + FStarC_Syntax_Syntax.mk_binder + wp_g in + let uu___30 + = + let uu___31 + = + let uu___32 + = + let uu___33 + = + let uu___34 + = + FStarC_Syntax_Syntax.mk_binder + x_a in + [uu___34] in + let uu___34 + = + let uu___35 + = + mk_repr b + wp_g_x in + FStarC_Syntax_Syntax.mk_Total + uu___35 in + FStarC_Syntax_Util.arrow + uu___33 + uu___34 in + FStarC_Syntax_Syntax.null_binder + uu___32 in + [uu___31] in + uu___29 + :: + uu___30 in + uu___27 + :: + uu___28 in + uu___25 :: + uu___26 in + FStarC_Compiler_List.op_At + maybe_range_arg + uu___24 in + FStarC_Compiler_List.op_At + uu___22 + uu___23 in + let uu___22 = + FStarC_Syntax_Syntax.mk_Total + res in + FStarC_Syntax_Util.arrow + uu___21 + uu___22 in + let uu___21 = + FStarC_TypeChecker_TcTerm.tc_tot_or_gtot_term + env k in + (match uu___21 + with + | (k1, uu___22, + uu___23) -> + let env1 = + FStarC_TypeChecker_Env.set_range + env + (FStar_Pervasives_Native.snd + bind_repr_ts).FStarC_Syntax_Syntax.pos in + let env2 = + FStar_Pervasives_Native.Some + { + FStarC_TypeChecker_Env.solver + = + (env1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range + = + (env1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule + = + (env1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma + = + (env1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig + = + (env1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache + = + (env1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules + = + (env1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ + = + (env1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab + = + (env1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab + = + (env1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp + = + (env1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects + = + (env1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize + = + (env1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs + = + (env1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level + = + (env1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars + = + (env1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict + = + (env1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface + = + (env1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit + = true; + FStarC_TypeChecker_Env.lax_universes + = + (env1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 + = + (env1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard + = + (env1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking + = + (env1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping + = + (env1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics + = + (env1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce + = + (env1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term + = + (env1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (env1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of + = + (env1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force + = + (env1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (env1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (env1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (env1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths + = + (env1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns + = + (env1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook + = + (env1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (env1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice + = + (env1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess + = + (env1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess + = + (env1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info + = + (env1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks + = + (env1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv + = + (env1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe + = + (env1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab + = + (env1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (env1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (env1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (env1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (env1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check + = + (env1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl + = + (env1.FStarC_TypeChecker_Env.missing_decl) + } in + check_and_gen' + "bind_repr" + (Prims.of_int (2)) + env2 + bind_repr_ts + (FStar_Pervasives_Native.Some + k1))) in + log_combinator "bind_repr" + bind_repr; + (let actions = + let check_action act = + if + (FStarC_Compiler_List.length + act.FStarC_Syntax_Syntax.action_params) + <> Prims.int_zero + then + failwith + "tc_eff_decl: expected action_params to be empty" + else (); + (let uu___21 = + if + act.FStarC_Syntax_Syntax.action_univs + = [] + then (env, act) + else + (let uu___23 = + FStarC_Syntax_Subst.univ_var_opening + act.FStarC_Syntax_Syntax.action_univs in + match uu___23 with + | (usubst, uvs) -> + let uu___24 = + FStarC_TypeChecker_Env.push_univ_vars + env uvs in + let uu___25 = + let uu___26 + = + FStarC_Syntax_Subst.subst + usubst + act.FStarC_Syntax_Syntax.action_defn in + let uu___27 + = + FStarC_Syntax_Subst.subst + usubst + act.FStarC_Syntax_Syntax.action_typ in + { + FStarC_Syntax_Syntax.action_name + = + (act.FStarC_Syntax_Syntax.action_name); + FStarC_Syntax_Syntax.action_unqualified_name + = + (act.FStarC_Syntax_Syntax.action_unqualified_name); + FStarC_Syntax_Syntax.action_univs + = uvs; + FStarC_Syntax_Syntax.action_params + = + (act.FStarC_Syntax_Syntax.action_params); + FStarC_Syntax_Syntax.action_defn + = uu___26; + FStarC_Syntax_Syntax.action_typ + = uu___27 + } in + (uu___24, + uu___25)) in + match uu___21 with + | (env1, act1) -> + let act_typ = + let uu___22 = + let uu___23 = + FStarC_Syntax_Subst.compress + act1.FStarC_Syntax_Syntax.action_typ in + uu___23.FStarC_Syntax_Syntax.n in + match uu___22 + with + | FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 + = bs1; + FStarC_Syntax_Syntax.comp + = c;_} + -> + let c1 = + FStarC_TypeChecker_Env.comp_to_comp_typ + env1 c in + let uu___23 = + FStarC_Ident.lid_equals + c1.FStarC_Syntax_Syntax.effect_name + ed2.FStarC_Syntax_Syntax.mname in + if uu___23 + then + let uu___24 + = + let uu___25 + = + let uu___26 + = + let uu___27 + = + FStarC_Compiler_List.hd + c1.FStarC_Syntax_Syntax.effect_args in + FStar_Pervasives_Native.fst + uu___27 in + mk_repr' + c1.FStarC_Syntax_Syntax.result_typ + uu___26 in + FStarC_Syntax_Syntax.mk_Total + uu___25 in + FStarC_Syntax_Util.arrow + bs1 + uu___24 + else + act1.FStarC_Syntax_Syntax.action_typ + | uu___23 -> + act1.FStarC_Syntax_Syntax.action_typ in + let uu___22 = + FStarC_TypeChecker_TcTerm.tc_tot_or_gtot_term + env1 act_typ in + (match uu___22 with + | (act_typ1, + uu___23, g_t) + -> + let env' = + let uu___24 + = + FStarC_TypeChecker_Env.set_expected_typ + env1 + act_typ1 in + { + FStarC_TypeChecker_Env.solver + = + (uu___24.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range + = + (uu___24.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule + = + (uu___24.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma + = + (uu___24.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig + = + (uu___24.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache + = + (uu___24.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules + = + (uu___24.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ + = + (uu___24.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab + = + (uu___24.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab + = + (uu___24.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp + = false; + FStarC_TypeChecker_Env.effects + = + (uu___24.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize + = + (uu___24.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs + = + (uu___24.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level + = + (uu___24.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars + = + (uu___24.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict + = + (uu___24.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface + = + (uu___24.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit + = + (uu___24.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes + = + (uu___24.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 + = + (uu___24.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard + = + (uu___24.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking + = + (uu___24.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping + = + (uu___24.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics + = + (uu___24.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce + = + (uu___24.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term + = + (uu___24.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (uu___24.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of + = + (uu___24.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (uu___24.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force + = + (uu___24.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (uu___24.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (uu___24.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (uu___24.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths + = + (uu___24.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns + = + (uu___24.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook + = + (uu___24.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (uu___24.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice + = + (uu___24.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess + = + (uu___24.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess + = + (uu___24.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info + = + (uu___24.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks + = + (uu___24.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv + = + (uu___24.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe + = + (uu___24.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab + = + (uu___24.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (uu___24.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (uu___24.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (uu___24.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (uu___24.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check + = + (uu___24.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl + = + (uu___24.FStarC_TypeChecker_Env.missing_decl) + } in + ((let uu___25 + = + FStarC_Compiler_Effect.op_Bang + dbg in + if uu___25 + then + let uu___26 + = + FStarC_Ident.string_of_lid + act1.FStarC_Syntax_Syntax.action_name in + let uu___27 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + act1.FStarC_Syntax_Syntax.action_defn in + let uu___28 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + act_typ1 in + FStarC_Compiler_Util.print3 + "Checking action %s:\n[definition]: %s\n[cps'd type]: %s\n" + uu___26 + uu___27 + uu___28 + else ()); + (let uu___25 + = + FStarC_TypeChecker_TcTerm.tc_tot_or_gtot_term + env' + act1.FStarC_Syntax_Syntax.action_defn in + match uu___25 + with + | (act_defn, + uu___26, + g_a) -> + (( + let uu___28 + = + FStarC_TypeChecker_Env.conj_guards + [g_a; + g_t] in + FStarC_TypeChecker_Rel.force_trivial_guard + env1 + uu___28); + (let act_defn1 + = + FStarC_TypeChecker_Normalize.normalize + [ + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant] + env1 + act_defn in + let act_typ2 + = + FStarC_TypeChecker_Normalize.normalize + [ + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.Beta] + env1 + act_typ1 in + let uu___28 + = + let act_typ3 + = + FStarC_Syntax_Subst.compress + act_typ2 in + match + act_typ3.FStarC_Syntax_Syntax.n + with + | + FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 + = bs1; + FStarC_Syntax_Syntax.comp + = c;_} -> + let uu___29 + = + FStarC_Syntax_Subst.open_comp + bs1 c in + (match uu___29 + with + | + (bs2, + uu___30) + -> + let res = + mk_repr' + FStarC_Syntax_Syntax.tun + FStarC_Syntax_Syntax.tun in + let k = + let uu___31 + = + FStarC_Syntax_Syntax.mk_Total + res in + FStarC_Syntax_Util.arrow + bs2 + uu___31 in + let uu___31 + = + FStarC_TypeChecker_TcTerm.tc_tot_or_gtot_term + env1 k in + (match uu___31 + with + | + (k1, + uu___32, + g) -> + (k1, g))) + | + uu___29 + -> + let uu___30 + = + let uu___31 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + act_typ3 in + let uu___32 + = + FStarC_Class_Tagged.tag_of + FStarC_Syntax_Syntax.tagged_term + act_typ3 in + FStarC_Compiler_Util.format2 + "Actions must have function types (not: %s, a.k.a. %s)" + uu___31 + uu___32 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax + ()) + act_defn1 + FStarC_Errors_Codes.Fatal_ActionMustHaveFunctionType + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + uu___30) in + match uu___28 + with + | + (expected_k, + g_k) -> + (( + let g = + FStarC_TypeChecker_Rel.teq + env1 + act_typ2 + expected_k in + let g1 = + FStarC_TypeChecker_Env.conj_guard + g g_k in + match + g1.FStarC_TypeChecker_Common.guard_f + with + | + FStarC_TypeChecker_Common.NonTrivial + uu___30 + -> + let uu___31 + = + let uu___32 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + act_typ2 in + FStarC_Compiler_Util.format1 + "Unexpected non trivial guard formula when checking action type shape (%s)" + uu___32 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax + ()) + act_defn1 + FStarC_Errors_Codes.Fatal_ActionMustHaveFunctionType + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + uu___31) + | + FStarC_TypeChecker_Common.Trivial + -> + let uu___30 + = + FStarC_TypeChecker_Env.conj_guards + [g_k; g1] in + FStarC_TypeChecker_Rel.force_trivial_guard + { + FStarC_TypeChecker_Env.solver + = + (env1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range + = + (env1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule + = + (env1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma + = + (env1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig + = + (env1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache + = + (env1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules + = + (env1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ + = + (env1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab + = + (env1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab + = + (env1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp + = + (env1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects + = + (env1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize + = + (env1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs + = + (env1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level + = + (env1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars + = + (env1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict + = + (env1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface + = + (env1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit + = true; + FStarC_TypeChecker_Env.lax_universes + = + (env1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 + = + (env1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard + = + (env1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking + = + (env1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping + = + (env1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics + = + (env1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce + = + (env1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term + = + (env1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (env1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of + = + (env1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force + = + (env1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (env1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (env1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (env1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths + = + (env1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns + = + (env1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook + = + (env1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (env1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice + = + (env1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess + = + (env1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess + = + (env1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info + = + (env1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks + = + (env1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv + = + (env1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe + = + (env1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab + = + (env1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (env1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (env1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (env1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (env1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check + = + (env1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl + = + (env1.FStarC_TypeChecker_Env.missing_decl) + } uu___30); + (let act_typ3 + = + let uu___30 + = + let uu___31 + = + FStarC_Syntax_Subst.compress + expected_k in + uu___31.FStarC_Syntax_Syntax.n in + match uu___30 + with + | + FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 + = bs1; + FStarC_Syntax_Syntax.comp + = c;_} -> + let uu___31 + = + FStarC_Syntax_Subst.open_comp + bs1 c in + (match uu___31 + with + | + (bs2, c1) + -> + let uu___32 + = + destruct_repr + (FStarC_Syntax_Util.comp_result + c1) in + (match uu___32 + with + | + (a, wp) + -> + let c2 = + let uu___33 + = + let uu___34 + = + let uu___35 + = + FStarC_TypeChecker_Env.push_binders + env1 bs2 in + env1.FStarC_TypeChecker_Env.universe_of + uu___35 a in + [uu___34] in + let uu___34 + = + let uu___35 + = + FStarC_Syntax_Syntax.as_arg + wp in + [uu___35] in + { + FStarC_Syntax_Syntax.comp_univs + = uu___33; + FStarC_Syntax_Syntax.effect_name + = + (ed2.FStarC_Syntax_Syntax.mname); + FStarC_Syntax_Syntax.result_typ + = a; + FStarC_Syntax_Syntax.effect_args + = uu___34; + FStarC_Syntax_Syntax.flags + = [] + } in + let uu___33 + = + FStarC_Syntax_Syntax.mk_Comp + c2 in + FStarC_Syntax_Util.arrow + bs2 + uu___33)) + | + uu___31 + -> + failwith + "Impossible (expected_k is an arrow)" in + let uu___30 + = + if + act1.FStarC_Syntax_Syntax.action_univs + = [] + then + FStarC_TypeChecker_Generalize.generalize_universes + env1 + act_defn1 + else + (let uu___32 + = + FStarC_Syntax_Subst.close_univ_vars + act1.FStarC_Syntax_Syntax.action_univs + act_defn1 in + ((act1.FStarC_Syntax_Syntax.action_univs), + uu___32)) in + match uu___30 + with + | + (univs, + act_defn2) + -> + let act_typ4 + = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Beta] + env1 + act_typ3 in + let act_typ5 + = + FStarC_Syntax_Subst.close_univ_vars + univs + act_typ4 in + { + FStarC_Syntax_Syntax.action_name + = + (act1.FStarC_Syntax_Syntax.action_name); + FStarC_Syntax_Syntax.action_unqualified_name + = + (act1.FStarC_Syntax_Syntax.action_unqualified_name); + FStarC_Syntax_Syntax.action_univs + = univs; + FStarC_Syntax_Syntax.action_params + = + (act1.FStarC_Syntax_Syntax.action_params); + FStarC_Syntax_Syntax.action_defn + = + act_defn2; + FStarC_Syntax_Syntax.action_typ + = + act_typ5 + })))))))) in + FStarC_Compiler_List.map + check_action + ed2.FStarC_Syntax_Syntax.actions in + ((FStar_Pervasives_Native.Some + repr), + (FStar_Pervasives_Native.Some + return_repr), + (FStar_Pervasives_Native.Some + bind_repr), actions))))) in + match uu___14 with + | (repr, return_repr, bind_repr, + actions) -> + let cl ts = + let ts1 = + FStarC_Syntax_Subst.close_tscheme + ed_bs ts in + let ed_univs_closing = + FStarC_Syntax_Subst.univ_var_closing + ed_univs in + let uu___15 = + FStarC_Syntax_Subst.shift_subst + (FStarC_Compiler_List.length + ed_bs) ed_univs_closing in + FStarC_Syntax_Subst.subst_tscheme + uu___15 ts1 in + let combinators = + { + FStarC_Syntax_Syntax.ret_wp = + ret_wp; + FStarC_Syntax_Syntax.bind_wp = + bind_wp; + FStarC_Syntax_Syntax.stronger + = stronger; + FStarC_Syntax_Syntax.if_then_else + = if_then_else; + FStarC_Syntax_Syntax.ite_wp = + ite_wp; + FStarC_Syntax_Syntax.close_wp + = close_wp; + FStarC_Syntax_Syntax.trivial = + trivial; + FStarC_Syntax_Syntax.repr = + repr; + FStarC_Syntax_Syntax.return_repr + = return_repr; + FStarC_Syntax_Syntax.bind_repr + = bind_repr + } in + let combinators1 = + FStarC_Syntax_Util.apply_wp_eff_combinators + cl combinators in + let combinators2 = + match ed2.FStarC_Syntax_Syntax.combinators + with + | FStarC_Syntax_Syntax.Primitive_eff + uu___15 -> + FStarC_Syntax_Syntax.Primitive_eff + combinators1 + | FStarC_Syntax_Syntax.DM4F_eff + uu___15 -> + FStarC_Syntax_Syntax.DM4F_eff + combinators1 + | uu___15 -> + failwith + "Impossible! tc_eff_decl on a layered effect is not expected" in + let ed3 = + let uu___15 = + let uu___16 = cl signature in + FStarC_Syntax_Syntax.WP_eff_sig + uu___16 in + let uu___16 = + FStarC_Compiler_List.map + (fun a -> + let uu___17 = + let uu___18 = + cl + ((a.FStarC_Syntax_Syntax.action_univs), + (a.FStarC_Syntax_Syntax.action_defn)) in + FStar_Pervasives_Native.snd + uu___18 in + let uu___18 = + let uu___19 = + cl + ((a.FStarC_Syntax_Syntax.action_univs), + (a.FStarC_Syntax_Syntax.action_typ)) in + FStar_Pervasives_Native.snd + uu___19 in + { + FStarC_Syntax_Syntax.action_name + = + (a.FStarC_Syntax_Syntax.action_name); + FStarC_Syntax_Syntax.action_unqualified_name + = + (a.FStarC_Syntax_Syntax.action_unqualified_name); + FStarC_Syntax_Syntax.action_univs + = + (a.FStarC_Syntax_Syntax.action_univs); + FStarC_Syntax_Syntax.action_params + = + (a.FStarC_Syntax_Syntax.action_params); + FStarC_Syntax_Syntax.action_defn + = uu___17; + FStarC_Syntax_Syntax.action_typ + = uu___18 + }) actions in + { + FStarC_Syntax_Syntax.mname = + (ed2.FStarC_Syntax_Syntax.mname); + FStarC_Syntax_Syntax.cattributes + = + (ed2.FStarC_Syntax_Syntax.cattributes); + FStarC_Syntax_Syntax.univs = + (ed2.FStarC_Syntax_Syntax.univs); + FStarC_Syntax_Syntax.binders = + (ed2.FStarC_Syntax_Syntax.binders); + FStarC_Syntax_Syntax.signature + = uu___15; + FStarC_Syntax_Syntax.combinators + = combinators2; + FStarC_Syntax_Syntax.actions = + uu___16; + FStarC_Syntax_Syntax.eff_attrs + = + (ed2.FStarC_Syntax_Syntax.eff_attrs); + FStarC_Syntax_Syntax.extraction_mode + = + (ed2.FStarC_Syntax_Syntax.extraction_mode) + } in + ((let uu___16 = + FStarC_Compiler_Effect.op_Bang + dbg in + if uu___16 + then + let uu___17 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_eff_decl + ed3 in + FStarC_Compiler_Util.print1 + "Typechecked effect declaration:\n\t%s\n" + uu___17 + else ()); + ed3)))))))))))))) +let (tc_eff_decl : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.eff_decl -> + FStarC_Syntax_Syntax.qualifier Prims.list -> + FStarC_Syntax_Syntax.attribute Prims.list -> + FStarC_Syntax_Syntax.eff_decl) + = + fun env -> + fun ed -> + fun quals -> + fun attrs -> + let uu___ = FStarC_Syntax_Util.is_layered ed in + if uu___ + then tc_layered_eff_decl env ed quals attrs + else tc_non_layered_eff_decl env ed quals attrs +let (monad_signature : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.bv * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax)) + = + fun env -> + fun m -> + fun s -> + let fail uu___ = + let uu___1 = FStarC_Ident.range_of_lid m in + FStarC_TypeChecker_Err.unexpected_signature_for_monad env uu___1 m + s in + let s1 = FStarC_Syntax_Subst.compress s in + match s1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; FStarC_Syntax_Syntax.comp = c;_} + -> + let bs1 = FStarC_Syntax_Subst.open_binders bs in + (match bs1 with + | { FStarC_Syntax_Syntax.binder_bv = a; + FStarC_Syntax_Syntax.binder_qual = uu___; + FStarC_Syntax_Syntax.binder_positivity = uu___1; + FStarC_Syntax_Syntax.binder_attrs = uu___2;_}::{ + FStarC_Syntax_Syntax.binder_bv + = wp; + FStarC_Syntax_Syntax.binder_qual + = uu___3; + FStarC_Syntax_Syntax.binder_positivity + = uu___4; + FStarC_Syntax_Syntax.binder_attrs + = uu___5;_}::[] + -> (a, (wp.FStarC_Syntax_Syntax.sort)) + | uu___ -> fail ()) + | uu___ -> fail () +let (tc_layered_lift : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.sub_eff -> FStarC_Syntax_Syntax.sub_eff) + = + fun env0 -> + fun sub -> + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_LayeredEffectsTc in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_sub_eff sub in + FStarC_Compiler_Util.print1 "Typechecking sub_effect: %s\n" uu___2 + else ()); + (let lift_ts = FStarC_Compiler_Util.must sub.FStarC_Syntax_Syntax.lift in + let r = (FStar_Pervasives_Native.snd lift_ts).FStarC_Syntax_Syntax.pos in + let uu___1 = check_and_gen env0 "" "lift" Prims.int_one lift_ts in + match uu___1 with + | (us, lift, lift_ty) -> + ((let uu___3 = FStarC_Compiler_Effect.op_Bang dbg_LayeredEffectsTc in + if uu___3 + then + let uu___4 = FStarC_Syntax_Print.tscheme_to_string (us, lift) in + let uu___5 = + FStarC_Syntax_Print.tscheme_to_string (us, lift_ty) in + FStarC_Compiler_Util.print2 + "Typechecked lift: %s and lift_ty: %s\n" uu___4 uu___5 + else ()); + (let uu___3 = FStarC_Syntax_Subst.open_univ_vars us lift_ty in + match uu___3 with + | (us1, lift_ty1) -> + let env = FStarC_TypeChecker_Env.push_univ_vars env0 us1 in + let uu___4 = + let uu___5 = FStarC_Compiler_List.hd us1 in + validate_indexed_effect_lift_shape env + sub.FStarC_Syntax_Syntax.source + sub.FStarC_Syntax_Syntax.target uu___5 lift_ty1 r in + (match uu___4 with + | (k, kind) -> + let sub1 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Syntax_Subst.close_univ_vars us1 k in + (us1, uu___7) in + FStar_Pervasives_Native.Some uu___6 in + { + FStarC_Syntax_Syntax.source = + (sub.FStarC_Syntax_Syntax.source); + FStarC_Syntax_Syntax.target = + (sub.FStarC_Syntax_Syntax.target); + FStarC_Syntax_Syntax.lift_wp = uu___5; + FStarC_Syntax_Syntax.lift = + (FStar_Pervasives_Native.Some (us1, lift)); + FStarC_Syntax_Syntax.kind = + (FStar_Pervasives_Native.Some kind) + } in + ((let uu___6 = + FStarC_Compiler_Effect.op_Bang dbg_LayeredEffectsTc in + if uu___6 + then + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_sub_eff sub1 in + FStarC_Compiler_Util.print1 + "Final sub_effect: %s\n" uu___7 + else ()); + sub1))))) +let (check_lift_for_erasable_effects : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident -> + FStarC_Ident.lident -> FStarC_Compiler_Range_Type.range -> unit) + = + fun env -> + fun m1 -> + fun m2 -> + fun r -> + let err reason = + let uu___ = + let uu___1 = FStarC_Ident.string_of_lid m1 in + let uu___2 = FStarC_Ident.string_of_lid m2 in + FStarC_Compiler_Util.format3 + "Error defining a lift/subcomp %s ~> %s: %s" uu___1 uu___2 + reason in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_UnexpectedEffect () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___) in + let m11 = FStarC_TypeChecker_Env.norm_eff_name env m1 in + let uu___ = + FStarC_Ident.lid_equals m11 FStarC_Parser_Const.effect_GHOST_lid in + if uu___ + then err "user-defined lifts from GHOST effect are not allowed" + else + (let m1_erasable = + FStarC_TypeChecker_Env.is_erasable_effect env m11 in + let m2_erasable = + FStarC_TypeChecker_Env.is_erasable_effect env m2 in + let uu___2 = + (m2_erasable && (Prims.op_Negation m1_erasable)) && + (let uu___3 = + FStarC_Ident.lid_equals m11 + FStarC_Parser_Const.effect_PURE_lid in + Prims.op_Negation uu___3) in + if uu___2 + then + err + "cannot lift a non-erasable effect to an erasable effect unless the non-erasable effect is PURE" + else ()) +let (tc_lift : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.sub_eff -> + FStarC_Compiler_Range_Type.range -> FStarC_Syntax_Syntax.sub_eff) + = + fun env -> + fun sub -> + fun r -> + (let uu___1 = + FStarC_Ident.lid_equals sub.FStarC_Syntax_Syntax.source + sub.FStarC_Syntax_Syntax.target in + if uu___1 + then + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Ident.showable_lident + sub.FStarC_Syntax_Syntax.source in + FStarC_Compiler_Util.format1 + "Cannot define a lift with same source and target (%s)" uu___3 in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_UnexpectedEffect () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2) + else ()); + (let check_and_gen1 env1 t k = + let uu___1 = + FStarC_TypeChecker_TcTerm.tc_check_trivial_guard env1 t k in + FStarC_TypeChecker_Generalize.generalize_universes env1 uu___1 in + check_lift_for_erasable_effects env sub.FStarC_Syntax_Syntax.source + sub.FStarC_Syntax_Syntax.target r; + (let ed_src = + FStarC_TypeChecker_Env.get_effect_decl env + sub.FStarC_Syntax_Syntax.source in + let ed_tgt = + FStarC_TypeChecker_Env.get_effect_decl env + sub.FStarC_Syntax_Syntax.target in + let uu___2 = + (FStarC_Syntax_Util.is_layered ed_src) || + (FStarC_Syntax_Util.is_layered ed_tgt) in + if uu___2 + then + let uu___3 = FStarC_TypeChecker_Env.set_range env r in + tc_layered_lift uu___3 sub + else + (let uu___4 = + let uu___5 = + FStarC_TypeChecker_Env.lookup_effect_lid env + sub.FStarC_Syntax_Syntax.source in + monad_signature env sub.FStarC_Syntax_Syntax.source uu___5 in + match uu___4 with + | (a, wp_a_src) -> + let uu___5 = + let uu___6 = + FStarC_TypeChecker_Env.lookup_effect_lid env + sub.FStarC_Syntax_Syntax.target in + monad_signature env sub.FStarC_Syntax_Syntax.target uu___6 in + (match uu___5 with + | (b, wp_b_tgt) -> + let wp_a_tgt = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = FStarC_Syntax_Syntax.bv_to_name a in + (b, uu___9) in + FStarC_Syntax_Syntax.NT uu___8 in + [uu___7] in + FStarC_Syntax_Subst.subst uu___6 wp_b_tgt in + let expected_k = + let uu___6 = + let uu___7 = FStarC_Syntax_Syntax.mk_binder a in + let uu___8 = + let uu___9 = + FStarC_Syntax_Syntax.null_binder wp_a_src in + [uu___9] in + uu___7 :: uu___8 in + let uu___7 = FStarC_Syntax_Syntax.mk_Total wp_a_tgt in + FStarC_Syntax_Util.arrow uu___6 uu___7 in + let repr_type eff_name a1 wp = + (let uu___7 = + let uu___8 = + FStarC_TypeChecker_Env.is_reifiable_effect env + eff_name in + Prims.op_Negation uu___8 in + if uu___7 + then + let uu___8 = + let uu___9 = FStarC_Ident.string_of_lid eff_name in + FStarC_Compiler_Util.format1 + "Effect %s cannot be reified" uu___9 in + FStarC_Errors.raise_error + FStarC_TypeChecker_Env.hasRange_env env + FStarC_Errors_Codes.Fatal_EffectCannotBeReified + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___8) + else ()); + (let uu___7 = + FStarC_TypeChecker_Env.effect_decl_opt env + eff_name in + match uu___7 with + | FStar_Pervasives_Native.None -> + failwith + "internal error: reifiable effect has no decl?" + | FStar_Pervasives_Native.Some (ed, qualifiers) -> + let repr = + let uu___8 = + let uu___9 = + FStarC_Syntax_Util.get_eff_repr ed in + FStarC_Compiler_Util.must uu___9 in + FStarC_TypeChecker_Env.inst_effect_fun_with + [FStarC_Syntax_Syntax.U_unknown] env ed + uu___8 in + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Syntax_Syntax.as_arg a1 in + let uu___12 = + let uu___13 = + FStarC_Syntax_Syntax.as_arg wp in + [uu___13] in + uu___11 :: uu___12 in + { + FStarC_Syntax_Syntax.hd = repr; + FStarC_Syntax_Syntax.args = uu___10 + } in + FStarC_Syntax_Syntax.Tm_app uu___9 in + let uu___9 = + FStarC_TypeChecker_Env.get_range env in + FStarC_Syntax_Syntax.mk uu___8 uu___9) in + let uu___6 = + match ((sub.FStarC_Syntax_Syntax.lift), + (sub.FStarC_Syntax_Syntax.lift_wp)) + with + | (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None) -> + failwith "Impossible (parser)" + | (lift, FStar_Pervasives_Native.Some (uvs, lift_wp)) + -> + let uu___7 = + if + (FStarC_Compiler_List.length uvs) > + Prims.int_zero + then + let uu___8 = + FStarC_Syntax_Subst.univ_var_opening uvs in + match uu___8 with + | (usubst, uvs1) -> + let uu___9 = + FStarC_TypeChecker_Env.push_univ_vars + env uvs1 in + let uu___10 = + FStarC_Syntax_Subst.subst usubst + lift_wp in + (uu___9, uu___10) + else (env, lift_wp) in + (match uu___7 with + | (env1, lift_wp1) -> + let lift_wp2 = + if + (FStarC_Compiler_List.length uvs) = + Prims.int_zero + then + check_and_gen1 env1 lift_wp1 expected_k + else + (let lift_wp3 = + FStarC_TypeChecker_TcTerm.tc_check_trivial_guard + env1 lift_wp1 expected_k in + let uu___9 = + FStarC_Syntax_Subst.close_univ_vars + uvs lift_wp3 in + (uvs, uu___9)) in + (lift, lift_wp2)) + | (FStar_Pervasives_Native.Some (what, lift), + FStar_Pervasives_Native.None) -> + let uu___7 = + if + (FStarC_Compiler_List.length what) > + Prims.int_zero + then + let uu___8 = + FStarC_Syntax_Subst.univ_var_opening what in + match uu___8 with + | (usubst, uvs) -> + let uu___9 = + FStarC_Syntax_Subst.subst usubst lift in + (uvs, uu___9) + else ([], lift) in + (match uu___7 with + | (uvs, lift1) -> + ((let uu___9 = + FStarC_Compiler_Effect.op_Bang dbg in + if uu___9 + then + let uu___10 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + lift1 in + FStarC_Compiler_Util.print1 + "Lift for free : %s\n" uu___10 + else ()); + (let dmff_env = + FStarC_TypeChecker_DMFF.empty env + (FStarC_TypeChecker_TcTerm.tc_constant + env + FStarC_Compiler_Range_Type.dummyRange) in + let uu___9 = + let uu___10 = + FStarC_TypeChecker_Env.push_univ_vars + env uvs in + FStarC_TypeChecker_TcTerm.tc_term + uu___10 lift1 in + match uu___9 with + | (lift2, comp, uu___10) -> + let uu___11 = + FStarC_TypeChecker_DMFF.star_expr + dmff_env lift2 in + (match uu___11 with + | (uu___12, lift_wp, lift_elab) -> + let lift_wp1 = + FStarC_TypeChecker_DMFF.recheck_debug + "lift-wp" env lift_wp in + let lift_elab1 = + FStarC_TypeChecker_DMFF.recheck_debug + "lift-elab" env lift_elab in + if + (FStarC_Compiler_List.length + uvs) + = Prims.int_zero + then + let uu___13 = + let uu___14 = + FStarC_TypeChecker_Generalize.generalize_universes + env lift_elab1 in + FStar_Pervasives_Native.Some + uu___14 in + let uu___14 = + FStarC_TypeChecker_Generalize.generalize_universes + env lift_wp1 in + (uu___13, uu___14) + else + (let uu___14 = + let uu___15 = + let uu___16 = + FStarC_Syntax_Subst.close_univ_vars + uvs lift_elab1 in + (uvs, uu___16) in + FStar_Pervasives_Native.Some + uu___15 in + let uu___15 = + let uu___16 = + FStarC_Syntax_Subst.close_univ_vars + uvs lift_wp1 in + (uvs, uu___16) in + (uu___14, uu___15)))))) in + (match uu___6 with + | (lift, lift_wp) -> + let env1 = + { + FStarC_TypeChecker_Env.solver = + (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = true; + FStarC_TypeChecker_Env.lax_universes = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env.FStarC_TypeChecker_Env.missing_decl) + } in + let lift1 = + match lift with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (uvs, lift2) -> + let uu___7 = + let uu___8 = + FStarC_Syntax_Subst.univ_var_opening uvs in + match uu___8 with + | (usubst, uvs1) -> + let uu___9 = + FStarC_TypeChecker_Env.push_univ_vars + env1 uvs1 in + let uu___10 = + FStarC_Syntax_Subst.subst usubst + lift2 in + (uu___9, uu___10) in + (match uu___7 with + | (env2, lift3) -> + let uu___8 = + let uu___9 = + FStarC_TypeChecker_Env.lookup_effect_lid + env2 + sub.FStarC_Syntax_Syntax.source in + monad_signature env2 + sub.FStarC_Syntax_Syntax.source + uu___9 in + (match uu___8 with + | (a1, wp_a_src1) -> + let wp_a = + FStarC_Syntax_Syntax.new_bv + FStar_Pervasives_Native.None + wp_a_src1 in + let a_typ = + FStarC_Syntax_Syntax.bv_to_name + a1 in + let wp_a_typ = + FStarC_Syntax_Syntax.bv_to_name + wp_a in + let repr_f = + repr_type + sub.FStarC_Syntax_Syntax.source + a_typ wp_a_typ in + let repr_result = + let lift_wp1 = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.EraseUniverses; + FStarC_TypeChecker_Env.AllowUnboundUniverses] + env2 + (FStar_Pervasives_Native.snd + lift_wp) in + let lift_wp_a = + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Syntax_Syntax.as_arg + a_typ in + let uu___13 = + let uu___14 = + FStarC_Syntax_Syntax.as_arg + wp_a_typ in + [uu___14] in + uu___12 :: uu___13 in + { + FStarC_Syntax_Syntax.hd + = lift_wp1; + FStarC_Syntax_Syntax.args + = uu___11 + } in + FStarC_Syntax_Syntax.Tm_app + uu___10 in + let uu___10 = + FStarC_TypeChecker_Env.get_range + env2 in + FStarC_Syntax_Syntax.mk uu___9 + uu___10 in + repr_type + sub.FStarC_Syntax_Syntax.target + a_typ lift_wp_a in + let expected_k1 = + let uu___9 = + let uu___10 = + FStarC_Syntax_Syntax.mk_binder + a1 in + let uu___11 = + let uu___12 = + FStarC_Syntax_Syntax.mk_binder + wp_a in + let uu___13 = + let uu___14 = + FStarC_Syntax_Syntax.null_binder + repr_f in + [uu___14] in + uu___12 :: uu___13 in + uu___10 :: uu___11 in + let uu___10 = + FStarC_Syntax_Syntax.mk_Total + repr_result in + FStarC_Syntax_Util.arrow uu___9 + uu___10 in + let uu___9 = + FStarC_TypeChecker_TcTerm.tc_tot_or_gtot_term + env2 expected_k1 in + (match uu___9 with + | (expected_k2, uu___10, uu___11) + -> + let lift4 = + if + (FStarC_Compiler_List.length + uvs) + = Prims.int_zero + then + check_and_gen1 env2 lift3 + expected_k2 + else + (let lift5 = + FStarC_TypeChecker_TcTerm.tc_check_trivial_guard + env2 lift3 + expected_k2 in + let uu___13 = + FStarC_Syntax_Subst.close_univ_vars + uvs lift5 in + (uvs, uu___13)) in + FStar_Pervasives_Native.Some + lift4))) in + (if + (FStarC_Compiler_List.length + (FStar_Pervasives_Native.fst lift_wp)) + <> Prims.int_one + then + (let uu___8 = + let uu___9 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + sub.FStarC_Syntax_Syntax.source in + let uu___10 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + sub.FStarC_Syntax_Syntax.target in + let uu___11 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length + (FStar_Pervasives_Native.fst lift_wp)) in + FStarC_Compiler_Util.format3 + "Sub effect wp must be polymorphic in exactly 1 universe; %s ~> %s has %s universes" + uu___9 uu___10 uu___11 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_TooManyUniverse () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___8)) + else (); + (let uu___9 = + (FStarC_Compiler_Util.is_some lift1) && + (let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Compiler_Util.must lift1 in + FStar_Pervasives_Native.fst uu___12 in + FStarC_Compiler_List.length uu___11 in + uu___10 <> Prims.int_one) in + if uu___9 + then + let uu___10 = + let uu___11 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + sub.FStarC_Syntax_Syntax.source in + let uu___12 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + sub.FStarC_Syntax_Syntax.target in + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = + FStarC_Compiler_Util.must lift1 in + FStar_Pervasives_Native.fst uu___16 in + FStarC_Compiler_List.length uu___15 in + FStarC_Compiler_Util.string_of_int uu___14 in + FStarC_Compiler_Util.format3 + "Sub effect lift must be polymorphic in exactly 1 universe; %s ~> %s has %s universes" + uu___11 uu___12 uu___13 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_TooManyUniverse () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___10) + else ()); + { + FStarC_Syntax_Syntax.source = + (sub.FStarC_Syntax_Syntax.source); + FStarC_Syntax_Syntax.target = + (sub.FStarC_Syntax_Syntax.target); + FStarC_Syntax_Syntax.lift_wp = + (FStar_Pervasives_Native.Some lift_wp); + FStarC_Syntax_Syntax.lift = lift1; + FStarC_Syntax_Syntax.kind = + (sub.FStarC_Syntax_Syntax.kind) + })))))) +let (tc_effect_abbrev : + FStarC_TypeChecker_Env.env -> + (FStarC_Ident.lident * FStarC_Syntax_Syntax.univ_names * + FStarC_Syntax_Syntax.binders * FStarC_Syntax_Syntax.comp) -> + FStarC_Compiler_Range_Type.range -> + (FStarC_Ident.lident * FStarC_Syntax_Syntax.univ_names * + FStarC_Syntax_Syntax.binders * FStarC_Syntax_Syntax.comp)) + = + fun env -> + fun uu___ -> + fun r -> + match uu___ with + | (lid, uvs, tps, c) -> + let env0 = env in + let uu___1 = + if (FStarC_Compiler_List.length uvs) = Prims.int_zero + then (env, uvs, tps, c) + else + (let uu___3 = FStarC_Syntax_Subst.univ_var_opening uvs in + match uu___3 with + | (usubst, uvs1) -> + let tps1 = FStarC_Syntax_Subst.subst_binders usubst tps in + let c1 = + let uu___4 = + FStarC_Syntax_Subst.shift_subst + (FStarC_Compiler_List.length tps1) usubst in + FStarC_Syntax_Subst.subst_comp uu___4 c in + let uu___4 = + FStarC_TypeChecker_Env.push_univ_vars env uvs1 in + (uu___4, uvs1, tps1, c1)) in + (match uu___1 with + | (env1, uvs1, tps1, c1) -> + let env2 = FStarC_TypeChecker_Env.set_range env1 r in + let uu___2 = FStarC_Syntax_Subst.open_comp tps1 c1 in + (match uu___2 with + | (tps2, c2) -> + let uu___3 = + FStarC_TypeChecker_TcTerm.tc_tparams env2 tps2 in + (match uu___3 with + | (tps3, env3, us) -> + let uu___4 = + FStarC_TypeChecker_TcTerm.tc_comp env3 c2 in + (match uu___4 with + | (c3, u, g) -> + let is_default_effect = + let uu___5 = + FStarC_TypeChecker_Env.get_default_effect + env3 + (FStarC_Syntax_Util.comp_effect_name c3) in + match uu___5 with + | FStar_Pervasives_Native.None -> false + | FStar_Pervasives_Native.Some l -> + FStarC_Ident.lid_equals l lid in + (FStarC_TypeChecker_Rel.force_trivial_guard + env3 g; + (let expected_result_typ = + match tps3 with + | { FStarC_Syntax_Syntax.binder_bv = x; + FStarC_Syntax_Syntax.binder_qual = + uu___7; + FStarC_Syntax_Syntax.binder_positivity + = uu___8; + FStarC_Syntax_Syntax.binder_attrs = + uu___9;_}::tl + -> + (if + is_default_effect && + (Prims.op_Negation (tl = [])) + then + (let uu___11 = + let uu___12 = + FStarC_Ident.string_of_lid + lid in + let uu___13 = + FStarC_Ident.string_of_lid + (FStarC_Syntax_Util.comp_effect_name + c3) in + FStarC_Compiler_Util.format2 + "Effect %s is marked as a default effect for %s, but it has more than one arguments" + uu___12 uu___13 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + r + FStarC_Errors_Codes.Fatal_UnexpectedEffect + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___11)) + else (); + FStarC_Syntax_Syntax.bv_to_name x) + | uu___7 -> + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + r + FStarC_Errors_Codes.Fatal_NotEnoughArgumentsForEffect + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Effect abbreviations must bind at least the result type") in + let def_result_typ = + FStarC_Syntax_Util.comp_result c3 in + let uu___7 = + let uu___8 = + FStarC_TypeChecker_Rel.teq_nosmt_force + env3 expected_result_typ + def_result_typ in + Prims.op_Negation uu___8 in + if uu___7 + then + let uu___8 = + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + expected_result_typ in + let uu___10 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + def_result_typ in + FStarC_Compiler_Util.format2 + "Result type of effect abbreviation `%s` does not match the result type of its definition `%s`" + uu___9 uu___10 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_EffectAbbreviationResultTypeMismatch + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___8) + else ()); + (let tps4 = + FStarC_Syntax_Subst.close_binders tps3 in + let c4 = + FStarC_Syntax_Subst.close_comp tps4 c3 in + let uu___7 = + let uu___8 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 = tps4; + FStarC_Syntax_Syntax.comp = c4 + }) r in + FStarC_TypeChecker_Generalize.generalize_universes + env0 uu___8 in + match uu___7 with + | (uvs2, t) -> + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Syntax_Subst.compress t in + uu___11.FStarC_Syntax_Syntax.n in + (tps4, uu___10) in + match uu___9 with + | ([], FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 = + uu___10; + FStarC_Syntax_Syntax.comp = c5;_}) + -> ([], c5) + | (uu___10, + FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = tps5; + FStarC_Syntax_Syntax.comp = c5;_}) + -> (tps5, c5) + | uu___10 -> + failwith + "Impossible (t is an arrow)" in + (match uu___8 with + | (tps5, c5) -> + (if + (FStarC_Compiler_List.length + uvs2) + <> Prims.int_one + then + (let uu___10 = + FStarC_Syntax_Subst.open_univ_vars + uvs2 t in + match uu___10 with + | (uu___11, t1) -> + let uu___12 = + let uu___13 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + lid in + let uu___14 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_nat) + (FStarC_Compiler_List.length + uvs2) in + let uu___15 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t1 in + FStarC_Compiler_Util.format3 + "Effect abbreviations must be polymorphic in exactly 1 universe; %s has %s universes (%s)" + uu___13 uu___14 + uu___15 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + r + FStarC_Errors_Codes.Fatal_TooManyUniverse + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___12)) + else (); + (lid, uvs2, tps5, c5))))))))) +let (check_polymonadic_bind_for_erasable_effects : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident -> + FStarC_Ident.lident -> + FStarC_Ident.lident -> FStarC_Compiler_Range_Type.range -> unit) + = + fun env -> + fun m -> + fun n -> + fun p -> + fun r -> + let err reason = + let uu___ = + let uu___1 = + FStarC_Class_Show.show FStarC_Ident.showable_lident m in + let uu___2 = + FStarC_Class_Show.show FStarC_Ident.showable_lident n in + let uu___3 = + FStarC_Class_Show.show FStarC_Ident.showable_lident p in + FStarC_Compiler_Util.format4 + "Error definition polymonadic bind (%s, %s) |> %s: %s" + uu___1 uu___2 uu___3 reason in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range + r FStarC_Errors_Codes.Fatal_UnexpectedEffect () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___) in + let m1 = FStarC_TypeChecker_Env.norm_eff_name env m in + let n1 = FStarC_TypeChecker_Env.norm_eff_name env n in + let uu___ = + (FStarC_Ident.lid_equals m1 + FStarC_Parser_Const.effect_GHOST_lid) + || + (FStarC_Ident.lid_equals n1 + FStarC_Parser_Const.effect_GHOST_lid) in + if uu___ + then + err + "GHOST computations are not allowed to be composed using user-defined polymonadic binds" + else + (let m_erasable = + FStarC_TypeChecker_Env.is_erasable_effect env m1 in + let n_erasable = + FStarC_TypeChecker_Env.is_erasable_effect env n1 in + let p_erasable = + FStarC_TypeChecker_Env.is_erasable_effect env p in + if p_erasable + then + let uu___2 = + (Prims.op_Negation m_erasable) && + (let uu___3 = + FStarC_Ident.lid_equals m1 + FStarC_Parser_Const.effect_PURE_lid in + Prims.op_Negation uu___3) in + (if uu___2 + then + let uu___3 = + let uu___4 = FStarC_Ident.string_of_lid m1 in + FStarC_Compiler_Util.format1 + "target effect is erasable but %s is neither erasable nor PURE" + uu___4 in + err uu___3 + else + (let uu___4 = + (Prims.op_Negation n_erasable) && + (let uu___5 = + FStarC_Ident.lid_equals n1 + FStarC_Parser_Const.effect_PURE_lid in + Prims.op_Negation uu___5) in + if uu___4 + then + let uu___5 = + let uu___6 = FStarC_Ident.string_of_lid n1 in + FStarC_Compiler_Util.format1 + "target effect is erasable but %s is neither erasable nor PURE" + uu___6 in + err uu___5 + else ())) + else ()) +let (tc_polymonadic_bind : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident -> + FStarC_Ident.lident -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.tscheme -> + (FStarC_Syntax_Syntax.tscheme * FStarC_Syntax_Syntax.tscheme * + FStarC_Syntax_Syntax.indexed_effect_combinator_kind)) + = + fun env -> + fun m -> + fun n -> + fun p -> + fun ts -> + let eff_name = + let uu___ = + let uu___1 = FStarC_Ident.ident_of_lid m in + FStarC_Ident.string_of_id uu___1 in + let uu___1 = + let uu___2 = FStarC_Ident.ident_of_lid n in + FStarC_Ident.string_of_id uu___2 in + let uu___2 = + let uu___3 = FStarC_Ident.ident_of_lid p in + FStarC_Ident.string_of_id uu___3 in + FStarC_Compiler_Util.format3 "(%s, %s) |> %s)" uu___ uu___1 + uu___2 in + let r = (FStar_Pervasives_Native.snd ts).FStarC_Syntax_Syntax.pos in + check_polymonadic_bind_for_erasable_effects env m n p r; + (let uu___1 = + check_and_gen env eff_name "polymonadic_bind" + (Prims.of_int (2)) ts in + match uu___1 with + | (us, t, ty) -> + let uu___2 = FStarC_Syntax_Subst.open_univ_vars us ty in + (match uu___2 with + | (us1, ty1) -> + let env1 = + FStarC_TypeChecker_Env.push_univ_vars env us1 in + let uu___3 = + let uu___4 = + FStarC_TypeChecker_Env.get_effect_decl env1 m in + let uu___5 = + FStarC_TypeChecker_Env.get_effect_decl env1 n in + let uu___6 = + FStarC_TypeChecker_Env.get_effect_decl env1 p in + (uu___4, uu___5, uu___6) in + (match uu___3 with + | (m_ed, n_ed, p_ed) -> + let uu___4 = + let uu___5 = + FStarC_Syntax_Util.effect_sig_ts + m_ed.FStarC_Syntax_Syntax.signature in + let uu___6 = + FStarC_Syntax_Util.effect_sig_ts + n_ed.FStarC_Syntax_Syntax.signature in + let uu___7 = + FStarC_Syntax_Util.effect_sig_ts + p_ed.FStarC_Syntax_Syntax.signature in + let uu___8 = + FStarC_Syntax_Util.get_eff_repr m_ed in + let uu___9 = + FStarC_Syntax_Util.get_eff_repr n_ed in + let uu___10 = + FStarC_Syntax_Util.get_eff_repr p_ed in + let uu___11 = + FStarC_TypeChecker_Env.get_range env1 in + validate_indexed_effect_bind_shape env1 m n p + uu___5 uu___6 uu___7 uu___8 uu___9 uu___10 us1 + ty1 uu___11 Prims.int_zero false in + (match uu___4 with + | (k, kind) -> + ((let uu___6 = + FStarC_Compiler_Debug.extreme () in + if uu___6 + then + let uu___7 = + FStarC_Syntax_Print.tscheme_to_string + (us1, t) in + let uu___8 = + FStarC_Syntax_Print.tscheme_to_string + (us1, k) in + FStarC_Compiler_Util.print3 + "Polymonadic bind %s after typechecking (%s::%s)\n" + eff_name uu___7 uu___8 + else ()); + (let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Compiler_Util.format1 + "Polymonadic binds (%s in this case) is an experimental feature;it is subject to some redesign in the future. Please keep us informed (on github etc.) about how you are using it" + eff_name in + FStarC_Errors_Msg.text uu___9 in + [uu___8] in + FStarC_Errors.log_issue + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Warning_BleedingEdge_Feature + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___7)); + (let uu___7 = + let uu___8 = + FStarC_Syntax_Subst.close_univ_vars us1 + k in + (us1, uu___8) in + ((us1, t), uu___7, kind))))))) +let (tc_polymonadic_subcomp : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.tscheme -> + (FStarC_Syntax_Syntax.tscheme * FStarC_Syntax_Syntax.tscheme * + FStarC_Syntax_Syntax.indexed_effect_combinator_kind)) + = + fun env0 -> + fun m -> + fun n -> + fun ts -> + let r = (FStar_Pervasives_Native.snd ts).FStarC_Syntax_Syntax.pos in + check_lift_for_erasable_effects env0 m n r; + (let combinator_name = + let uu___1 = + let uu___2 = FStarC_Ident.ident_of_lid m in + FStarC_Ident.string_of_id uu___2 in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Ident.ident_of_lid n in + FStarC_Ident.string_of_id uu___4 in + Prims.strcat " <: " uu___3 in + Prims.strcat uu___1 uu___2 in + let uu___1 = + check_and_gen env0 combinator_name "polymonadic_subcomp" + Prims.int_one ts in + match uu___1 with + | (us, t, ty) -> + let uu___2 = FStarC_Syntax_Subst.open_univ_vars us ty in + (match uu___2 with + | (us1, ty1) -> + let env = FStarC_TypeChecker_Env.push_univ_vars env0 us1 in + let uu___3 = + let uu___4 = + FStarC_TypeChecker_Env.get_effect_decl env m in + let uu___5 = + FStarC_TypeChecker_Env.get_effect_decl env n in + (uu___4, uu___5) in + (match uu___3 with + | (m_ed, n_ed) -> + let uu___4 = + let uu___5 = + FStarC_Syntax_Util.effect_sig_ts + m_ed.FStarC_Syntax_Syntax.signature in + let uu___6 = + FStarC_Syntax_Util.effect_sig_ts + n_ed.FStarC_Syntax_Syntax.signature in + let uu___7 = FStarC_Syntax_Util.get_eff_repr m_ed in + let uu___8 = FStarC_Syntax_Util.get_eff_repr n_ed in + let uu___9 = FStarC_Compiler_List.hd us1 in + let uu___10 = FStarC_TypeChecker_Env.get_range env in + validate_indexed_effect_subcomp_shape env m n + uu___5 uu___6 uu___7 uu___8 uu___9 ty1 + Prims.int_zero uu___10 in + (match uu___4 with + | (k, kind) -> + ((let uu___6 = FStarC_Compiler_Debug.extreme () in + if uu___6 + then + let uu___7 = + FStarC_Syntax_Print.tscheme_to_string + (us1, t) in + let uu___8 = + FStarC_Syntax_Print.tscheme_to_string + (us1, k) in + FStarC_Compiler_Util.print3 + "Polymonadic subcomp %s after typechecking (%s::%s)\n" + combinator_name uu___7 uu___8 + else ()); + (let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Compiler_Util.format1 + "Polymonadic subcomp (%s in this case) is an experimental feature;it is subject to some redesign in the future. Please keep us informed (on github etc.) about how you are using it" + combinator_name in + FStarC_Errors_Msg.text uu___9 in + [uu___8] in + FStarC_Errors.log_issue + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Warning_BleedingEdge_Feature + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___7)); + (let uu___7 = + let uu___8 = + FStarC_Syntax_Subst.close_univ_vars us1 k in + (us1, uu___8) in + ((us1, t), uu___7, kind))))))) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_TcInductive.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_TcInductive.ml new file mode 100644 index 00000000000..8eb336acdb3 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_TcInductive.ml @@ -0,0 +1,3817 @@ +open Prims +let (dbg_GenUniverses : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "GenUniverses" +let (dbg_LogTypes : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "LogTypes" +let (dbg_Injectivity : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Injectivity" +let (unfold_whnf : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + FStarC_TypeChecker_Normalize.unfold_whnf' + [FStarC_TypeChecker_Env.AllowUnboundUniverses] +let (check_sig_inductive_injectivity_on_params : + FStarC_TypeChecker_Env.env_t -> + FStarC_Syntax_Syntax.sigelt -> FStarC_Syntax_Syntax.sigelt) + = + fun tcenv -> + fun se -> + if tcenv.FStarC_TypeChecker_Env.phase1 + then se + else + (let uu___1 = se.FStarC_Syntax_Syntax.sigel in + match uu___1 with + | FStarC_Syntax_Syntax.Sig_inductive_typ dd -> + let uu___2 = dd in + (match uu___2 with + | { FStarC_Syntax_Syntax.lid = t; + FStarC_Syntax_Syntax.us = universe_names; + FStarC_Syntax_Syntax.params = tps; + FStarC_Syntax_Syntax.num_uniform_params = uu___3; + FStarC_Syntax_Syntax.t = k; + FStarC_Syntax_Syntax.mutuals = uu___4; + FStarC_Syntax_Syntax.ds = uu___5; + FStarC_Syntax_Syntax.injective_type_params = uu___6;_} -> + let t_lid = t in + let uu___7 = + FStarC_Syntax_Subst.univ_var_opening universe_names in + (match uu___7 with + | (usubst, uvs) -> + let uu___8 = + let uu___9 = + FStarC_TypeChecker_Env.push_univ_vars tcenv uvs in + let uu___10 = + FStarC_Syntax_Subst.subst_binders usubst tps in + let uu___11 = + let uu___12 = + FStarC_Syntax_Subst.shift_subst + (FStarC_Compiler_List.length tps) usubst in + FStarC_Syntax_Subst.subst uu___12 k in + (uu___9, uu___10, uu___11) in + (match uu___8 with + | (tcenv1, tps1, k1) -> + let uu___9 = + FStarC_Syntax_Subst.open_term tps1 k1 in + (match uu___9 with + | (tps2, k2) -> + let uu___10 = + FStarC_Syntax_Util.arrow_formals k2 in + (match uu___10 with + | (uu___11, k3) -> + let uu___12 = + FStarC_TypeChecker_TcTerm.tc_binders + tcenv1 tps2 in + (match uu___12 with + | (tps3, env_tps, uu___13, us) -> + let u_k = + let uu___14 = + let uu___15 = + FStarC_Syntax_Syntax.fvar t + FStar_Pervasives_Native.None in + let uu___16 = + let uu___17 = + FStarC_Syntax_Util.args_of_binders + tps3 in + FStar_Pervasives_Native.snd + uu___17 in + let uu___17 = + FStarC_Ident.range_of_lid t in + FStarC_Syntax_Syntax.mk_Tm_app + uu___15 uu___16 uu___17 in + FStarC_TypeChecker_TcTerm.level_of_type + env_tps uu___14 k3 in + let rec universe_leq u v = + match (u, v) with + | (FStarC_Syntax_Syntax.U_zero, + uu___14) -> true + | (FStarC_Syntax_Syntax.U_succ + u0, + FStarC_Syntax_Syntax.U_succ + v0) -> universe_leq u0 v0 + | (FStarC_Syntax_Syntax.U_name + u0, + FStarC_Syntax_Syntax.U_name + v0) -> + FStarC_Ident.ident_equals u0 + v0 + | (FStarC_Syntax_Syntax.U_name + uu___14, + FStarC_Syntax_Syntax.U_succ + v0) -> universe_leq u v0 + | (FStarC_Syntax_Syntax.U_max + us1, uu___14) -> + FStarC_Compiler_Util.for_all + (fun u1 -> + universe_leq u1 v) us1 + | (uu___14, + FStarC_Syntax_Syntax.U_max + vs) -> + FStarC_Compiler_Util.for_some + (universe_leq u) vs + | (FStarC_Syntax_Syntax.U_unknown, + uu___14) -> + let uu___15 = + let uu___16 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + t in + let uu___17 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_univ + u in + let uu___18 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_univ + v in + FStarC_Compiler_Util.format3 + "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" + uu___16 uu___17 uu___18 in + failwith uu___15 + | (uu___14, + FStarC_Syntax_Syntax.U_unknown) + -> + let uu___15 = + let uu___16 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + t in + let uu___17 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_univ + u in + let uu___18 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_univ + v in + FStarC_Compiler_Util.format3 + "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" + uu___16 uu___17 uu___18 in + failwith uu___15 + | (FStarC_Syntax_Syntax.U_unif + uu___14, uu___15) -> + let uu___16 = + let uu___17 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + t in + let uu___18 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_univ + u in + let uu___19 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_univ + v in + FStarC_Compiler_Util.format3 + "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" + uu___17 uu___18 uu___19 in + failwith uu___16 + | (uu___14, + FStarC_Syntax_Syntax.U_unif + uu___15) -> + let uu___16 = + let uu___17 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + t in + let uu___18 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_univ + u in + let uu___19 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_univ + v in + FStarC_Compiler_Util.format3 + "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" + uu___17 uu___18 uu___19 in + failwith uu___16 + | uu___14 -> false in + let u_leq_u_k u = + let u1 = + FStarC_TypeChecker_Normalize.normalize_universe + env_tps u in + universe_leq u1 u_k in + let tp_ok tp u_tp = + let t_tp = + (tp.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + let uu___14 = u_leq_u_k u_tp in + if uu___14 + then true + else + (let t_tp1 = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Unrefine; + FStarC_TypeChecker_Env.Unascribe; + FStarC_TypeChecker_Env.Unmeta; + FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.HNF; + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.Beta] + env_tps t_tp in + let uu___16 = + FStarC_Syntax_Util.arrow_formals + t_tp1 in + match uu___16 with + | (formals, t1) -> + let uu___17 = + FStarC_TypeChecker_TcTerm.tc_binders + env_tps formals in + (match uu___17 with + | (uu___18, uu___19, + uu___20, u_formals) + -> + let inj = + FStarC_Compiler_Util.for_all + (fun u_formal -> + u_leq_u_k + u_formal) + u_formals in + if inj + then + let uu___21 = + let uu___22 = + FStarC_Syntax_Subst.compress + t1 in + uu___22.FStarC_Syntax_Syntax.n in + (match uu___21 + with + | FStarC_Syntax_Syntax.Tm_type + u -> + u_leq_u_k u + | uu___22 -> + false) + else false)) in + let injective_type_params = + FStarC_Compiler_List.forall2 + tp_ok tps3 us in + ((let uu___15 = + FStarC_Compiler_Effect.op_Bang + dbg_Injectivity in + if uu___15 + then + let uu___16 = + FStarC_Ident.string_of_lid t in + FStarC_Compiler_Util.print2 + "%s injectivity for %s\n" + (if injective_type_params + then "YES" + else "NO") uu___16 + else ()); + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_inductive_typ + { + FStarC_Syntax_Syntax.lid + = + (dd.FStarC_Syntax_Syntax.lid); + FStarC_Syntax_Syntax.us + = + (dd.FStarC_Syntax_Syntax.us); + FStarC_Syntax_Syntax.params + = + (dd.FStarC_Syntax_Syntax.params); + FStarC_Syntax_Syntax.num_uniform_params + = + (dd.FStarC_Syntax_Syntax.num_uniform_params); + FStarC_Syntax_Syntax.t = + (dd.FStarC_Syntax_Syntax.t); + FStarC_Syntax_Syntax.mutuals + = + (dd.FStarC_Syntax_Syntax.mutuals); + FStarC_Syntax_Syntax.ds + = + (dd.FStarC_Syntax_Syntax.ds); + FStarC_Syntax_Syntax.injective_type_params + = + injective_type_params + }); + FStarC_Syntax_Syntax.sigrng = + (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se.FStarC_Syntax_Syntax.sigopts) + })))))))) +let (tc_tycon : + FStarC_TypeChecker_Env.env_t -> + FStarC_Syntax_Syntax.sigelt -> + (FStarC_TypeChecker_Env.env_t * FStarC_Syntax_Syntax.sigelt * + FStarC_Syntax_Syntax.universe * FStarC_TypeChecker_Common.guard_t)) + = + fun env -> + fun s -> + match s.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = tc; FStarC_Syntax_Syntax.us = uvs; + FStarC_Syntax_Syntax.params = tps; + FStarC_Syntax_Syntax.num_uniform_params = n_uniform; + FStarC_Syntax_Syntax.t = k; + FStarC_Syntax_Syntax.mutuals = mutuals; + FStarC_Syntax_Syntax.ds = data; + FStarC_Syntax_Syntax.injective_type_params = uu___;_} + -> + let env0 = env in + let uu___1 = FStarC_Syntax_Subst.univ_var_opening uvs in + (match uu___1 with + | (usubst, uvs1) -> + let uu___2 = + let uu___3 = FStarC_TypeChecker_Env.push_univ_vars env uvs1 in + let uu___4 = FStarC_Syntax_Subst.subst_binders usubst tps in + let uu___5 = + let uu___6 = + FStarC_Syntax_Subst.shift_subst + (FStarC_Compiler_List.length tps) usubst in + FStarC_Syntax_Subst.subst uu___6 k in + (uu___3, uu___4, uu___5) in + (match uu___2 with + | (env1, tps1, k1) -> + let uu___3 = FStarC_Syntax_Subst.open_term tps1 k1 in + (match uu___3 with + | (tps2, k2) -> + let uu___4 = + FStarC_TypeChecker_TcTerm.tc_binders env1 tps2 in + (match uu___4 with + | (tps3, env_tps, guard_params, us) -> + let uu___5 = + let uu___6 = + FStarC_TypeChecker_TcTerm.tc_tot_or_gtot_term + env_tps k2 in + match uu___6 with + | (k3, uu___7, g) -> + let k4 = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Exclude + FStarC_TypeChecker_Env.Iota; + FStarC_TypeChecker_Env.Exclude + FStarC_TypeChecker_Env.Zeta; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.NoFullNorm; + FStarC_TypeChecker_Env.Exclude + FStarC_TypeChecker_Env.Beta] + env_tps k3 in + let uu___8 = + FStarC_Syntax_Util.arrow_formals k4 in + let uu___9 = + let uu___10 = + FStarC_TypeChecker_Env.conj_guard + guard_params g in + FStarC_TypeChecker_Rel.discharge_guard + env_tps uu___10 in + (uu___8, uu___9) in + (match uu___5 with + | ((indices, t), guard) -> + let k3 = + let uu___6 = + FStarC_Syntax_Syntax.mk_Total t in + FStarC_Syntax_Util.arrow indices uu___6 in + let uu___6 = FStarC_Syntax_Util.type_u () in + (match uu___6 with + | (t_type, u) -> + let valid_type = + (((FStarC_Syntax_Util.is_eqtype_no_unrefine + t) + && + (Prims.op_Negation + (FStarC_Compiler_List.contains + FStarC_Syntax_Syntax.Noeq + s.FStarC_Syntax_Syntax.sigquals))) + && + (Prims.op_Negation + (FStarC_Compiler_List.contains + FStarC_Syntax_Syntax.Unopteq + s.FStarC_Syntax_Syntax.sigquals))) + || + (FStarC_TypeChecker_Rel.teq_nosmt_force + env1 t t_type) in + (if Prims.op_Negation valid_type + then + (let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t in + let uu___12 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + tc in + FStarC_Compiler_Util.format2 + "Type annotation %s for inductive %s is not Type or eqtype, or it is eqtype but contains noeq/unopteq qualifiers" + uu___11 uu___12 in + FStarC_Errors_Msg.text + uu___10 in + [uu___9] in + FStarC_Errors.raise_error + FStarC_Syntax_Syntax.has_range_sigelt + s + FStarC_Errors_Codes.Error_InductiveAnnotNotAType + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___8)) + else (); + (let usubst1 = + FStarC_Syntax_Subst.univ_var_closing + uvs1 in + let guard1 = + FStarC_TypeChecker_Util.close_guard_implicits + env1 false tps3 guard in + let t_tc = + let uu___8 = + let uu___9 = + FStarC_Syntax_Subst.subst_binders + usubst1 tps3 in + let uu___10 = + let uu___11 = + FStarC_Syntax_Subst.shift_subst + (FStarC_Compiler_List.length + tps3) usubst1 in + FStarC_Syntax_Subst.subst_binders + uu___11 indices in + FStarC_Compiler_List.op_At + uu___9 uu___10 in + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Syntax_Subst.shift_subst + ((FStarC_Compiler_List.length + tps3) + + + (FStarC_Compiler_List.length + indices)) usubst1 in + FStarC_Syntax_Subst.subst + uu___11 t in + FStarC_Syntax_Syntax.mk_Total + uu___10 in + FStarC_Syntax_Util.arrow uu___8 + uu___9 in + let tps4 = + FStarC_Syntax_Subst.close_binders + tps3 in + let k4 = + FStarC_Syntax_Subst.close tps4 k3 in + let uu___8 = + let uu___9 = + FStarC_Syntax_Subst.subst_binders + usubst1 tps4 in + let uu___10 = + let uu___11 = + FStarC_Syntax_Subst.shift_subst + (FStarC_Compiler_List.length + tps4) usubst1 in + FStarC_Syntax_Subst.subst + uu___11 k4 in + (uu___9, uu___10) in + match uu___8 with + | (tps5, k5) -> + let fv_tc = + FStarC_Syntax_Syntax.lid_as_fv + tc + FStar_Pervasives_Native.None in + let uu___9 = + FStarC_Syntax_Subst.open_univ_vars + uvs1 t_tc in + (match uu___9 with + | (uvs2, t_tc1) -> + let uu___10 = + FStarC_TypeChecker_Env.push_let_binding + env0 + (FStar_Pervasives.Inr + fv_tc) + (uvs2, t_tc1) in + (uu___10, + { + FStarC_Syntax_Syntax.sigel + = + (FStarC_Syntax_Syntax.Sig_inductive_typ + { + FStarC_Syntax_Syntax.lid + = tc; + FStarC_Syntax_Syntax.us + = uvs2; + FStarC_Syntax_Syntax.params + = tps5; + FStarC_Syntax_Syntax.num_uniform_params + = n_uniform; + FStarC_Syntax_Syntax.t + = k5; + FStarC_Syntax_Syntax.mutuals + = mutuals; + FStarC_Syntax_Syntax.ds + = data; + FStarC_Syntax_Syntax.injective_type_params + = false + }); + FStarC_Syntax_Syntax.sigrng + = + (s.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals + = + (s.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta + = + (s.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs + = + (s.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = + (s.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts + = + (s.FStarC_Syntax_Syntax.sigopts) + }, u, guard1)))))))))) + | uu___ -> failwith "impossible" +let (mk_implicit : FStarC_Syntax_Syntax.bqual -> FStarC_Syntax_Syntax.bqual) + = + fun uu___ -> + match uu___ with + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Meta q) -> + FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Meta q) + | uu___1 -> + FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Implicit false) +let (tc_data : + FStarC_TypeChecker_Env.env_t -> + (FStarC_Syntax_Syntax.sigelt * FStarC_Syntax_Syntax.universe) Prims.list + -> + FStarC_Syntax_Syntax.sigelt -> + (FStarC_Syntax_Syntax.sigelt * FStarC_TypeChecker_Common.guard_t)) + = + fun env -> + fun tcs -> + fun se -> + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = c; FStarC_Syntax_Syntax.us1 = _uvs; + FStarC_Syntax_Syntax.t1 = t; + FStarC_Syntax_Syntax.ty_lid = tc_lid; + FStarC_Syntax_Syntax.num_ty_params = ntps; + FStarC_Syntax_Syntax.mutuals1 = mutual_tcs; + FStarC_Syntax_Syntax.injective_type_params1 = uu___;_} + -> + let uu___1 = FStarC_Syntax_Subst.univ_var_opening _uvs in + (match uu___1 with + | (usubst, _uvs1) -> + let uu___2 = + let uu___3 = + FStarC_TypeChecker_Env.push_univ_vars env _uvs1 in + let uu___4 = FStarC_Syntax_Subst.subst usubst t in + (uu___3, uu___4) in + (match uu___2 with + | (env1, t1) -> + let uu___3 = + let tps_u_opt = + FStarC_Compiler_Util.find_map tcs + (fun uu___4 -> + match uu___4 with + | (se1, u_tc) -> + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Syntax_Util.lid_of_sigelt se1 in + FStarC_Compiler_Util.must uu___7 in + FStarC_Ident.lid_equals tc_lid uu___6 in + if uu___5 + then + (match se1.FStarC_Syntax_Syntax.sigel + with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { + FStarC_Syntax_Syntax.lid = uu___6; + FStarC_Syntax_Syntax.us = uu___7; + FStarC_Syntax_Syntax.params = tps; + FStarC_Syntax_Syntax.num_uniform_params + = uu___8; + FStarC_Syntax_Syntax.t = uu___9; + FStarC_Syntax_Syntax.mutuals = + uu___10; + FStarC_Syntax_Syntax.ds = uu___11; + FStarC_Syntax_Syntax.injective_type_params + = uu___12;_} + -> + let tps1 = + let uu___13 = + FStarC_Syntax_Subst.subst_binders + usubst tps in + FStarC_Compiler_List.map + (fun x -> + { + FStarC_Syntax_Syntax.binder_bv + = + (x.FStarC_Syntax_Syntax.binder_bv); + FStarC_Syntax_Syntax.binder_qual + = + (FStar_Pervasives_Native.Some + FStarC_Syntax_Syntax.imp_tag); + FStarC_Syntax_Syntax.binder_positivity + = + (x.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs + = + (x.FStarC_Syntax_Syntax.binder_attrs) + }) uu___13 in + let tps2 = + FStarC_Syntax_Subst.open_binders + tps1 in + let uu___13 = + let uu___14 = + FStarC_TypeChecker_Env.push_binders + env1 tps2 in + (uu___14, tps2, u_tc) in + FStar_Pervasives_Native.Some + uu___13 + | uu___6 -> failwith "Impossible") + else FStar_Pervasives_Native.None) in + match tps_u_opt with + | FStar_Pervasives_Native.Some x -> x + | FStar_Pervasives_Native.None -> + let uu___4 = + FStarC_Ident.lid_equals tc_lid + FStarC_Parser_Const.exn_lid in + if uu___4 + then (env1, [], FStarC_Syntax_Syntax.U_zero) + else + FStarC_Errors.raise_error + FStarC_Syntax_Syntax.has_range_sigelt se + FStarC_Errors_Codes.Fatal_UnexpectedDataConstructor + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "Unexpected data constructor") in + (match uu___3 with + | (env2, tps, u_tc) -> + let uu___4 = + let t2 = + FStarC_TypeChecker_Normalize.normalize + (FStarC_Compiler_List.op_At + FStarC_TypeChecker_Normalize.whnf_steps + [FStarC_TypeChecker_Env.AllowUnboundUniverses]) + env2 t1 in + let t3 = FStarC_Syntax_Util.canon_arrow t2 in + let uu___5 = + let uu___6 = FStarC_Syntax_Subst.compress t3 in + uu___6.FStarC_Syntax_Syntax.n in + match uu___5 with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = res;_} + -> + let uu___6 = + FStarC_Compiler_Util.first_N ntps bs in + (match uu___6 with + | (uu___7, bs') -> + let t4 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 = bs'; + FStarC_Syntax_Syntax.comp = + res + }) t3.FStarC_Syntax_Syntax.pos in + let subst = + FStarC_Compiler_List.mapi + (fun i -> + fun uu___8 -> + match uu___8 with + | { + FStarC_Syntax_Syntax.binder_bv + = x; + FStarC_Syntax_Syntax.binder_qual + = uu___9; + FStarC_Syntax_Syntax.binder_positivity + = uu___10; + FStarC_Syntax_Syntax.binder_attrs + = uu___11;_} + -> + FStarC_Syntax_Syntax.DB + ((ntps - + (Prims.int_one + i)), + x)) tps in + let uu___8 = + let uu___9 = + FStarC_Syntax_Subst.subst subst t4 in + FStarC_Syntax_Util.arrow_formals_comp + uu___9 in + (match uu___8 with + | (bs1, c1) -> + let uu___9 = + (FStarC_Options.ml_ish ()) || + (FStarC_Syntax_Util.is_total_comp + c1) in + if uu___9 + then + (bs1, + (FStarC_Syntax_Util.comp_result + c1)) + else + FStarC_Errors.raise_error + FStarC_Ident.hasrange_lident + (FStarC_Syntax_Util.comp_effect_name + c1) + FStarC_Errors_Codes.Fatal_UnexpectedConstructorType + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Constructors cannot have effects"))) + | uu___6 -> ([], t3) in + (match uu___4 with + | (arguments, result) -> + ((let uu___6 = FStarC_Compiler_Debug.low () in + if uu___6 + then + let uu___7 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident c in + let uu___8 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binder) + arguments in + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + result in + FStarC_Compiler_Util.print3 + "Checking datacon %s : %s -> %s \n" + uu___7 uu___8 uu___9 + else ()); + (let uu___6 = + FStarC_TypeChecker_TcTerm.tc_tparams env2 + arguments in + match uu___6 with + | (arguments1, env', us) -> + let type_u_tc = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_type u_tc) + result.FStarC_Syntax_Syntax.pos in + let env'1 = + FStarC_TypeChecker_Env.set_expected_typ + env' type_u_tc in + let uu___7 = + FStarC_TypeChecker_TcTerm.tc_trivial_guard + env'1 result in + (match uu___7 with + | (result1, res_lcomp) -> + let uu___8 = + FStarC_Syntax_Util.head_and_args_full + result1 in + (match uu___8 with + | (head, args) -> + let g_uvs = + let uu___9 = + let uu___10 = + FStarC_Syntax_Subst.compress + head in + uu___10.FStarC_Syntax_Syntax.n in + match uu___9 with + | FStarC_Syntax_Syntax.Tm_uinst + ({ + FStarC_Syntax_Syntax.n + = + FStarC_Syntax_Syntax.Tm_fvar + fv; + FStarC_Syntax_Syntax.pos + = uu___10; + FStarC_Syntax_Syntax.vars + = uu___11; + FStarC_Syntax_Syntax.hash_code + = uu___12;_}, + tuvs) + when + FStarC_Syntax_Syntax.fv_eq_lid + fv tc_lid + -> + if + (FStarC_Compiler_List.length + _uvs1) + = + (FStarC_Compiler_List.length + tuvs) + then + FStarC_Compiler_List.fold_left2 + (fun g -> + fun u1 -> + fun u2 -> + let uu___13 + = + let uu___14 + = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_type + u1) + FStarC_Compiler_Range_Type.dummyRange in + let uu___15 + = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_type + (FStarC_Syntax_Syntax.U_name + u2)) + FStarC_Compiler_Range_Type.dummyRange in + FStarC_TypeChecker_Rel.teq + env'1 + uu___14 + uu___15 in + FStarC_TypeChecker_Env.conj_guard + g uu___13) + FStarC_TypeChecker_Env.trivial_guard + tuvs _uvs1 + else + FStarC_Errors.raise_error + FStarC_Syntax_Syntax.has_range_sigelt + se + FStarC_Errors_Codes.Fatal_UnexpectedConstructorType + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Length of annotated universes does not match inferred universes") + | FStarC_Syntax_Syntax.Tm_fvar + fv when + FStarC_Syntax_Syntax.fv_eq_lid + fv tc_lid + -> + FStarC_TypeChecker_Env.trivial_guard + | uu___10 -> + let uu___11 = + let uu___12 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + tc_lid in + let uu___13 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + head in + FStarC_Compiler_Util.format2 + "Expected a constructor of type %s; got %s" + uu___12 uu___13 in + FStarC_Errors.raise_error + FStarC_Syntax_Syntax.has_range_sigelt + se + FStarC_Errors_Codes.Fatal_UnexpectedConstructorType + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___11) in + let g = + FStarC_Compiler_List.fold_left2 + (fun g1 -> + fun uu___9 -> + fun u_x -> + match uu___9 with + | { + FStarC_Syntax_Syntax.binder_bv + = x; + FStarC_Syntax_Syntax.binder_qual + = uu___10; + FStarC_Syntax_Syntax.binder_positivity + = uu___11; + FStarC_Syntax_Syntax.binder_attrs + = uu___12;_} + -> + let uu___13 = + FStarC_TypeChecker_Rel.universe_inequality + u_x u_tc in + FStarC_TypeChecker_Env.conj_guard + g1 uu___13) + g_uvs arguments1 us in + (FStarC_Errors.stop_if_err (); + (let p_args = + let uu___10 = + FStarC_Compiler_Util.first_N + (FStarC_Compiler_List.length + tps) args in + FStar_Pervasives_Native.fst + uu___10 in + FStarC_Compiler_List.iter2 + (fun uu___11 -> + fun uu___12 -> + match (uu___11, + uu___12) + with + | ({ + FStarC_Syntax_Syntax.binder_bv + = bv; + FStarC_Syntax_Syntax.binder_qual + = uu___13; + FStarC_Syntax_Syntax.binder_positivity + = uu___14; + FStarC_Syntax_Syntax.binder_attrs + = uu___15;_}, + (t2, uu___16)) -> + let uu___17 = + let uu___18 = + FStarC_Syntax_Subst.compress + t2 in + uu___18.FStarC_Syntax_Syntax.n in + (match uu___17 + with + | FStarC_Syntax_Syntax.Tm_name + bv' when + FStarC_Syntax_Syntax.bv_eq + bv bv' + -> () + | uu___18 -> + let uu___19 + = + let uu___20 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_bv + bv in + let uu___21 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t2 in + FStarC_Compiler_Util.format2 + "This parameter is not constant: expected %s, got %s" + uu___20 + uu___21 in + FStarC_Errors.raise_error + ( + FStarC_Syntax_Syntax.has_range_syntax + ()) t2 + FStarC_Errors_Codes.Error_BadInductiveParam + () + ( + Obj.magic + FStarC_Errors_Msg.is_error_message_string) + ( + Obj.magic + uu___19))) + tps p_args; + (let ty = + let uu___11 = + unfold_whnf env2 + res_lcomp.FStarC_TypeChecker_Common.res_typ in + FStarC_Syntax_Util.unrefine + uu___11 in + (let uu___12 = + let uu___13 = + FStarC_Syntax_Subst.compress + ty in + uu___13.FStarC_Syntax_Syntax.n in + match uu___12 with + | FStarC_Syntax_Syntax.Tm_type + uu___13 -> () + | uu___13 -> + let uu___14 = + let uu___15 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + result1 in + let uu___16 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + ty in + FStarC_Compiler_Util.format2 + "The type of %s is %s, but since this is the result type of a constructor its type should be Type" + uu___15 uu___16 in + FStarC_Errors.raise_error + FStarC_Syntax_Syntax.has_range_sigelt + se + FStarC_Errors_Codes.Fatal_WrongResultTypeAfterConstrutor + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___14)); + (let t2 = + let uu___12 = + let uu___13 = + FStarC_Compiler_List.map + (fun b -> + { + FStarC_Syntax_Syntax.binder_bv + = + (b.FStarC_Syntax_Syntax.binder_bv); + FStarC_Syntax_Syntax.binder_qual + = + (FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Implicit + true)); + FStarC_Syntax_Syntax.binder_positivity + = + (b.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs + = + (b.FStarC_Syntax_Syntax.binder_attrs) + }) tps in + FStarC_Compiler_List.op_At + uu___13 arguments1 in + let uu___13 = + FStarC_Syntax_Syntax.mk_Total + result1 in + FStarC_Syntax_Util.arrow + uu___12 uu___13 in + let t3 = + FStarC_Syntax_Subst.close_univ_vars + _uvs1 t2 in + ({ + FStarC_Syntax_Syntax.sigel + = + (FStarC_Syntax_Syntax.Sig_datacon + { + FStarC_Syntax_Syntax.lid1 + = c; + FStarC_Syntax_Syntax.us1 + = _uvs1; + FStarC_Syntax_Syntax.t1 + = t3; + FStarC_Syntax_Syntax.ty_lid + = tc_lid; + FStarC_Syntax_Syntax.num_ty_params + = ntps; + FStarC_Syntax_Syntax.mutuals1 + = mutual_tcs; + FStarC_Syntax_Syntax.injective_type_params1 + = false + }); + FStarC_Syntax_Syntax.sigrng + = + (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals + = + (se.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta + = + (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs + = + (se.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts + = + (se.FStarC_Syntax_Syntax.sigopts) + }, g))))))))))))) + | uu___ -> failwith "impossible" +let (generalize_and_inst_within : + FStarC_TypeChecker_Env.env_t -> + (FStarC_Syntax_Syntax.sigelt * FStarC_Syntax_Syntax.universe) Prims.list + -> + FStarC_Syntax_Syntax.sigelt Prims.list -> + (FStarC_Syntax_Syntax.sigelt Prims.list * FStarC_Syntax_Syntax.sigelt + Prims.list)) + = + fun env -> + fun tcs -> + fun datas -> + let binders = + FStarC_Compiler_List.map + (fun uu___ -> + match uu___ with + | (se, uu___1) -> + (match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = uu___2; + FStarC_Syntax_Syntax.us = uu___3; + FStarC_Syntax_Syntax.params = tps; + FStarC_Syntax_Syntax.num_uniform_params = uu___4; + FStarC_Syntax_Syntax.t = k; + FStarC_Syntax_Syntax.mutuals = uu___5; + FStarC_Syntax_Syntax.ds = uu___6; + FStarC_Syntax_Syntax.injective_type_params = uu___7;_} + -> + let uu___8 = + let uu___9 = FStarC_Syntax_Syntax.mk_Total k in + FStarC_Syntax_Util.arrow tps uu___9 in + FStarC_Syntax_Syntax.null_binder uu___8 + | uu___2 -> failwith "Impossible")) tcs in + let binders' = + FStarC_Compiler_List.map + (fun se -> + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = uu___; + FStarC_Syntax_Syntax.us1 = uu___1; + FStarC_Syntax_Syntax.t1 = t; + FStarC_Syntax_Syntax.ty_lid = uu___2; + FStarC_Syntax_Syntax.num_ty_params = uu___3; + FStarC_Syntax_Syntax.mutuals1 = uu___4; + FStarC_Syntax_Syntax.injective_type_params1 = uu___5;_} + -> FStarC_Syntax_Syntax.null_binder t + | uu___ -> failwith "Impossible") datas in + let t = + let uu___ = + FStarC_Syntax_Syntax.mk_Total FStarC_Syntax_Syntax.t_unit in + FStarC_Syntax_Util.arrow + (FStarC_Compiler_List.op_At binders binders') uu___ in + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_GenUniverses in + if uu___1 + then + let uu___2 = FStarC_TypeChecker_Normalize.term_to_string env t in + FStarC_Compiler_Util.print1 + "@@@@@@Trying to generalize universes in %s\n" uu___2 + else ()); + (let uu___1 = + FStarC_TypeChecker_Generalize.generalize_universes env t in + match uu___1 with + | (uvs, t1) -> + ((let uu___3 = FStarC_Compiler_Effect.op_Bang dbg_GenUniverses in + if uu___3 + then + let uu___4 = + let uu___5 = + FStarC_Compiler_List.map + (fun u -> FStarC_Ident.string_of_id u) uvs in + FStarC_Compiler_String.concat ", " uu___5 in + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + t1 in + FStarC_Compiler_Util.print2 + "@@@@@@Generalized to (%s, %s)\n" uu___4 uu___5 + else ()); + (let uu___3 = FStarC_Syntax_Subst.open_univ_vars uvs t1 in + match uu___3 with + | (uvs1, t2) -> + let uu___4 = FStarC_Syntax_Util.arrow_formals t2 in + (match uu___4 with + | (args, uu___5) -> + let uu___6 = + FStarC_Compiler_Util.first_N + (FStarC_Compiler_List.length binders) args in + (match uu___6 with + | (tc_types, data_types) -> + let tcs1 = + FStarC_Compiler_List.map2 + (fun uu___7 -> + fun uu___8 -> + match (uu___7, uu___8) with + | ({ + FStarC_Syntax_Syntax.binder_bv = x; + FStarC_Syntax_Syntax.binder_qual = + uu___9; + FStarC_Syntax_Syntax.binder_positivity + = uu___10; + FStarC_Syntax_Syntax.binder_attrs + = uu___11;_}, + (se, uu___12)) -> + (match se.FStarC_Syntax_Syntax.sigel + with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { + FStarC_Syntax_Syntax.lid = + tc; + FStarC_Syntax_Syntax.us = + uu___13; + FStarC_Syntax_Syntax.params + = tps; + FStarC_Syntax_Syntax.num_uniform_params + = num_uniform; + FStarC_Syntax_Syntax.t = + uu___14; + FStarC_Syntax_Syntax.mutuals + = mutuals; + FStarC_Syntax_Syntax.ds = + datas1; + FStarC_Syntax_Syntax.injective_type_params + = uu___15;_} + -> + let ty = + FStarC_Syntax_Subst.close_univ_vars + uvs1 + x.FStarC_Syntax_Syntax.sort in + let uu___16 = + let uu___17 = + let uu___18 = + FStarC_Syntax_Subst.compress + ty in + uu___18.FStarC_Syntax_Syntax.n in + match uu___17 with + | FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 + = binders1; + FStarC_Syntax_Syntax.comp + = c;_} + -> + let uu___18 = + FStarC_Compiler_Util.first_N + (FStarC_Compiler_List.length + tps) binders1 in + (match uu___18 with + | (tps1, rest) -> + let t3 = + match rest with + | [] -> + FStarC_Syntax_Util.comp_result + c + | uu___19 -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 + = rest; + FStarC_Syntax_Syntax.comp + = c + }) + (x.FStarC_Syntax_Syntax.sort).FStarC_Syntax_Syntax.pos in + (tps1, t3)) + | uu___18 -> ([], ty) in + (match uu___16 with + | (tps1, t3) -> + { + FStarC_Syntax_Syntax.sigel + = + (FStarC_Syntax_Syntax.Sig_inductive_typ + { + FStarC_Syntax_Syntax.lid + = tc; + FStarC_Syntax_Syntax.us + = uvs1; + FStarC_Syntax_Syntax.params + = tps1; + FStarC_Syntax_Syntax.num_uniform_params + = num_uniform; + FStarC_Syntax_Syntax.t + = t3; + FStarC_Syntax_Syntax.mutuals + = mutuals; + FStarC_Syntax_Syntax.ds + = datas1; + FStarC_Syntax_Syntax.injective_type_params + = false + }); + FStarC_Syntax_Syntax.sigrng + = + (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals + = + (se.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta + = + (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs + = + (se.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts + = + (se.FStarC_Syntax_Syntax.sigopts) + }) + | uu___13 -> failwith "Impossible")) + tc_types tcs in + let datas1 = + match uvs1 with + | [] -> datas + | uu___7 -> + let uvs_universes = + FStarC_Compiler_List.map + (fun uu___8 -> + FStarC_Syntax_Syntax.U_name uu___8) + uvs1 in + let tc_insts = + FStarC_Compiler_List.map + (fun uu___8 -> + match uu___8 with + | { + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_inductive_typ + { + FStarC_Syntax_Syntax.lid = + tc; + FStarC_Syntax_Syntax.us = + uu___9; + FStarC_Syntax_Syntax.params + = uu___10; + FStarC_Syntax_Syntax.num_uniform_params + = uu___11; + FStarC_Syntax_Syntax.t = + uu___12; + FStarC_Syntax_Syntax.mutuals + = uu___13; + FStarC_Syntax_Syntax.ds = + uu___14; + FStarC_Syntax_Syntax.injective_type_params + = uu___15;_}; + FStarC_Syntax_Syntax.sigrng = + uu___16; + FStarC_Syntax_Syntax.sigquals = + uu___17; + FStarC_Syntax_Syntax.sigmeta = + uu___18; + FStarC_Syntax_Syntax.sigattrs = + uu___19; + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = uu___20; + FStarC_Syntax_Syntax.sigopts = + uu___21;_} + -> (tc, uvs_universes) + | uu___9 -> failwith "Impossible") + tcs1 in + FStarC_Compiler_List.map2 + (fun uu___8 -> + fun d -> + match uu___8 with + | { + FStarC_Syntax_Syntax.binder_bv + = t3; + FStarC_Syntax_Syntax.binder_qual + = uu___9; + FStarC_Syntax_Syntax.binder_positivity + = uu___10; + FStarC_Syntax_Syntax.binder_attrs + = uu___11;_} + -> + (match d.FStarC_Syntax_Syntax.sigel + with + | FStarC_Syntax_Syntax.Sig_datacon + { + FStarC_Syntax_Syntax.lid1 + = l; + FStarC_Syntax_Syntax.us1 + = uu___12; + FStarC_Syntax_Syntax.t1 + = uu___13; + FStarC_Syntax_Syntax.ty_lid + = tc; + FStarC_Syntax_Syntax.num_ty_params + = ntps; + FStarC_Syntax_Syntax.mutuals1 + = mutuals; + FStarC_Syntax_Syntax.injective_type_params1 + = uu___14;_} + -> + let ty = + let uu___15 = + FStarC_Syntax_InstFV.instantiate + tc_insts + t3.FStarC_Syntax_Syntax.sort in + FStarC_Syntax_Subst.close_univ_vars + uvs1 uu___15 in + { + FStarC_Syntax_Syntax.sigel + = + (FStarC_Syntax_Syntax.Sig_datacon + { + FStarC_Syntax_Syntax.lid1 + = l; + FStarC_Syntax_Syntax.us1 + = uvs1; + FStarC_Syntax_Syntax.t1 + = ty; + FStarC_Syntax_Syntax.ty_lid + = tc; + FStarC_Syntax_Syntax.num_ty_params + = ntps; + FStarC_Syntax_Syntax.mutuals1 + = mutuals; + FStarC_Syntax_Syntax.injective_type_params1 + = false + }); + FStarC_Syntax_Syntax.sigrng + = + (d.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals + = + (d.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta + = + (d.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs + = + (d.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = + (d.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts + = + (d.FStarC_Syntax_Syntax.sigopts) + } + | uu___12 -> + failwith "Impossible")) + data_types datas in + (tcs1, datas1)))))) +let (datacon_typ : FStarC_Syntax_Syntax.sigelt -> FStarC_Syntax_Syntax.term) + = + fun data -> + match data.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = uu___; + FStarC_Syntax_Syntax.us1 = uu___1; FStarC_Syntax_Syntax.t1 = t; + FStarC_Syntax_Syntax.ty_lid = uu___2; + FStarC_Syntax_Syntax.num_ty_params = uu___3; + FStarC_Syntax_Syntax.mutuals1 = uu___4; + FStarC_Syntax_Syntax.injective_type_params1 = uu___5;_} + -> t + | uu___ -> failwith "Impossible!" +let (haseq_suffix : Prims.string) = "__uu___haseq" +let (is_haseq_lid : FStarC_Ident.lid -> Prims.bool) = + fun lid -> + let str = FStarC_Ident.string_of_lid lid in + let len = FStarC_Compiler_String.length str in + let haseq_suffix_len = FStarC_Compiler_String.length haseq_suffix in + (len > haseq_suffix_len) && + (let uu___ = + let uu___1 = + FStarC_Compiler_String.substring str (len - haseq_suffix_len) + haseq_suffix_len in + FStarC_Compiler_String.compare uu___1 haseq_suffix in + uu___ = Prims.int_zero) +let (get_haseq_axiom_lid : FStarC_Ident.lid -> FStarC_Ident.lid) = + fun lid -> + let uu___ = + let uu___1 = FStarC_Ident.ns_of_lid lid in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Ident.ident_of_lid lid in + FStarC_Ident.string_of_id uu___6 in + Prims.strcat uu___5 haseq_suffix in + FStarC_Ident.id_of_text uu___4 in + [uu___3] in + FStarC_Compiler_List.op_At uu___1 uu___2 in + FStarC_Ident.lid_of_ids uu___ +let (get_optimized_haseq_axiom : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.sigelt -> + FStarC_Syntax_Syntax.subst_elt Prims.list -> + FStarC_Syntax_Syntax.univ_names -> + (FStarC_Ident.lident * FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.binders * FStarC_Syntax_Syntax.binders * + FStarC_Syntax_Syntax.term)) + = + fun en -> + fun ty -> + fun usubst -> + fun us -> + let uu___ = + match ty.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = lid; + FStarC_Syntax_Syntax.us = uu___1; + FStarC_Syntax_Syntax.params = bs; + FStarC_Syntax_Syntax.num_uniform_params = uu___2; + FStarC_Syntax_Syntax.t = t; + FStarC_Syntax_Syntax.mutuals = uu___3; + FStarC_Syntax_Syntax.ds = uu___4; + FStarC_Syntax_Syntax.injective_type_params = uu___5;_} + -> (lid, bs, t) + | uu___1 -> failwith "Impossible!" in + match uu___ with + | (lid, bs, t) -> + let bs1 = FStarC_Syntax_Subst.subst_binders usubst bs in + let t1 = + let uu___1 = + FStarC_Syntax_Subst.shift_subst + (FStarC_Compiler_List.length bs1) usubst in + FStarC_Syntax_Subst.subst uu___1 t in + let uu___1 = FStarC_Syntax_Subst.open_term bs1 t1 in + (match uu___1 with + | (bs2, t2) -> + let ibs = + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress t2 in + uu___3.FStarC_Syntax_Syntax.n in + match uu___2 with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = ibs1; + FStarC_Syntax_Syntax.comp = uu___3;_} + -> ibs1 + | uu___3 -> [] in + let ibs1 = FStarC_Syntax_Subst.open_binders ibs in + let ind = + let uu___2 = + FStarC_Syntax_Syntax.fvar lid + FStar_Pervasives_Native.None in + let uu___3 = + FStarC_Compiler_List.map + (fun u -> FStarC_Syntax_Syntax.U_name u) us in + FStarC_Syntax_Syntax.mk_Tm_uinst uu___2 uu___3 in + let ind1 = + let uu___2 = + FStarC_Compiler_List.map + FStarC_Syntax_Util.arg_of_non_null_binder bs2 in + FStarC_Syntax_Syntax.mk_Tm_app ind uu___2 + FStarC_Compiler_Range_Type.dummyRange in + let ind2 = + let uu___2 = + FStarC_Compiler_List.map + FStarC_Syntax_Util.arg_of_non_null_binder ibs1 in + FStarC_Syntax_Syntax.mk_Tm_app ind1 uu___2 + FStarC_Compiler_Range_Type.dummyRange in + let haseq_ind = + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.as_arg ind2 in + [uu___3] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Syntax_Util.t_haseq uu___2 + FStarC_Compiler_Range_Type.dummyRange in + let bs' = + FStarC_Compiler_List.filter + (fun b -> + let uu___2 = + let uu___3 = FStarC_Syntax_Util.type_u () in + FStar_Pervasives_Native.fst uu___3 in + FStarC_TypeChecker_Rel.subtype_nosmt_force en + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort + uu___2) bs2 in + let haseq_bs = + FStarC_Compiler_List.fold_left + (fun t3 -> + fun b -> + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Syntax_Syntax.bv_to_name + b.FStarC_Syntax_Syntax.binder_bv in + FStarC_Syntax_Syntax.as_arg uu___5 in + [uu___4] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Syntax_Util.t_haseq uu___3 + FStarC_Compiler_Range_Type.dummyRange in + FStarC_Syntax_Util.mk_conj t3 uu___2) + FStarC_Syntax_Util.t_true bs' in + let fml = FStarC_Syntax_Util.mk_imp haseq_bs haseq_ind in + let fml1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.binders_to_names ibs1 in + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Syntax_Syntax.as_arg haseq_ind in + [uu___9] in + [uu___8] in + (uu___6, uu___7) in + FStarC_Syntax_Syntax.Meta_pattern uu___5 in + { + FStarC_Syntax_Syntax.tm2 = fml; + FStarC_Syntax_Syntax.meta = uu___4 + } in + FStarC_Syntax_Syntax.Tm_meta uu___3 in + { + FStarC_Syntax_Syntax.n = uu___2; + FStarC_Syntax_Syntax.pos = + (fml.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = + (fml.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (fml.FStarC_Syntax_Syntax.hash_code) + } in + let fml2 = + FStarC_Compiler_List.fold_right + (fun b -> + fun t3 -> + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.mk_binder + b.FStarC_Syntax_Syntax.binder_bv in + [uu___6] in + let uu___6 = + FStarC_Syntax_Subst.close [b] t3 in + FStarC_Syntax_Util.abs uu___5 uu___6 + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.as_arg uu___4 in + [uu___3] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Syntax_Util.tforall uu___2 + FStarC_Compiler_Range_Type.dummyRange) ibs1 + fml1 in + let fml3 = + FStarC_Compiler_List.fold_right + (fun b -> + fun t3 -> + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.mk_binder + b.FStarC_Syntax_Syntax.binder_bv in + [uu___6] in + let uu___6 = + FStarC_Syntax_Subst.close [b] t3 in + FStarC_Syntax_Util.abs uu___5 uu___6 + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.as_arg uu___4 in + [uu___3] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Syntax_Util.tforall uu___2 + FStarC_Compiler_Range_Type.dummyRange) bs2 fml2 in + let axiom_lid = get_haseq_axiom_lid lid in + (axiom_lid, fml3, bs2, ibs1, haseq_bs)) +let (optimized_haseq_soundness_for_data : + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.sigelt -> + FStarC_Syntax_Syntax.subst_elt Prims.list -> + FStarC_Syntax_Syntax.binders -> FStarC_Syntax_Syntax.term) + = + fun ty_lid -> + fun data -> + fun usubst -> + fun bs -> + let dt = datacon_typ data in + let dt1 = FStarC_Syntax_Subst.subst usubst dt in + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress dt1 in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = dbs; + FStarC_Syntax_Syntax.comp = uu___1;_} + -> + let dbs1 = + let uu___2 = + FStarC_Compiler_List.splitAt + (FStarC_Compiler_List.length bs) dbs in + FStar_Pervasives_Native.snd uu___2 in + let dbs2 = + let uu___2 = FStarC_Syntax_Subst.opening_of_binders bs in + FStarC_Syntax_Subst.subst_binders uu___2 dbs1 in + let dbs3 = FStarC_Syntax_Subst.open_binders dbs2 in + let cond = + FStarC_Compiler_List.fold_left + (fun t -> + fun b -> + let haseq_b = + let uu___2 = + let uu___3 = + FStarC_Syntax_Syntax.as_arg + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + [uu___3] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Syntax_Util.t_haseq uu___2 + FStarC_Compiler_Range_Type.dummyRange in + let sort_range = + ((b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort).FStarC_Syntax_Syntax.pos in + let haseq_b1 = + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Errors_Msg.text + "Failed to prove that the type" in + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Class_PP.pp + FStarC_Ident.pretty_lident ty_lid in + FStarC_Pprint.squotes uu___7 in + let uu___7 = + FStarC_Errors_Msg.text + "supports decidable equality because of this argument." in + FStarC_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in + FStarC_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in + let uu___4 = + let uu___5 = + FStarC_Errors_Msg.text + "Add either the 'noeq' or 'unopteq' qualifier" in + [uu___5] in + uu___3 :: uu___4 in + FStarC_TypeChecker_Util.label uu___2 sort_range + haseq_b in + FStarC_Syntax_Util.mk_conj t haseq_b1) + FStarC_Syntax_Util.t_true dbs3 in + FStarC_Compiler_List.fold_right + (fun b -> + fun t -> + let uu___2 = + let uu___3 = + FStarC_Syntax_Syntax.iarg + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Syntax.mk_binder + b.FStarC_Syntax_Syntax.binder_bv in + [uu___8] in + let uu___8 = FStarC_Syntax_Subst.close [b] t in + FStarC_Syntax_Util.abs uu___7 uu___8 + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.as_arg uu___6 in + [uu___5] in + uu___3 :: uu___4 in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Syntax_Util.tforall uu___2 + FStarC_Compiler_Range_Type.dummyRange) dbs3 cond + | uu___1 -> FStarC_Syntax_Util.t_true +let (optimized_haseq_ty : + FStarC_Syntax_Syntax.sigelts -> + FStarC_Syntax_Syntax.subst_elt Prims.list -> + FStarC_Syntax_Syntax.univ_name Prims.list -> + ((FStarC_Ident.lident * FStarC_Syntax_Syntax.term) Prims.list * + FStarC_TypeChecker_Env.env * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax) -> + FStarC_Syntax_Syntax.sigelt -> + ((FStarC_Ident.lident * FStarC_Syntax_Syntax.term) Prims.list * + FStarC_TypeChecker_Env.env * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax)) + = + fun all_datas_in_the_bundle -> + fun usubst -> + fun us -> + fun acc -> + fun ty -> + let lid = + match ty.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = lid1; + FStarC_Syntax_Syntax.us = uu___; + FStarC_Syntax_Syntax.params = uu___1; + FStarC_Syntax_Syntax.num_uniform_params = uu___2; + FStarC_Syntax_Syntax.t = uu___3; + FStarC_Syntax_Syntax.mutuals = uu___4; + FStarC_Syntax_Syntax.ds = uu___5; + FStarC_Syntax_Syntax.injective_type_params = uu___6;_} + -> lid1 + | uu___ -> failwith "Impossible!" in + let uu___ = acc in + match uu___ with + | (uu___1, en, uu___2, uu___3) -> + let uu___4 = get_optimized_haseq_axiom en ty usubst us in + (match uu___4 with + | (axiom_lid, fml, bs, ibs, haseq_bs) -> + let guard = FStarC_Syntax_Util.mk_conj haseq_bs fml in + let uu___5 = acc in + (match uu___5 with + | (l_axioms, env, guard', cond') -> + let env1 = + FStarC_TypeChecker_Env.push_binders env bs in + let env2 = + FStarC_TypeChecker_Env.push_binders env1 ibs in + let t_datas = + FStarC_Compiler_List.filter + (fun s -> + match s.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = uu___6; + FStarC_Syntax_Syntax.us1 = uu___7; + FStarC_Syntax_Syntax.t1 = uu___8; + FStarC_Syntax_Syntax.ty_lid = t_lid; + FStarC_Syntax_Syntax.num_ty_params = + uu___9; + FStarC_Syntax_Syntax.mutuals1 = + uu___10; + FStarC_Syntax_Syntax.injective_type_params1 + = uu___11;_} + -> t_lid = lid + | uu___6 -> failwith "Impossible") + all_datas_in_the_bundle in + let cond = + FStarC_Compiler_List.fold_left + (fun acc1 -> + fun d -> + let uu___6 = + optimized_haseq_soundness_for_data lid d + usubst bs in + FStarC_Syntax_Util.mk_conj acc1 uu___6) + FStarC_Syntax_Util.t_true t_datas in + let uu___6 = + FStarC_Syntax_Util.mk_conj guard' guard in + let uu___7 = FStarC_Syntax_Util.mk_conj cond' cond in + ((FStarC_Compiler_List.op_At l_axioms + [(axiom_lid, fml)]), env2, uu___6, uu___7))) +let (optimized_haseq_scheme : + FStarC_Syntax_Syntax.sigelt -> + FStarC_Syntax_Syntax.sigelt Prims.list -> + FStarC_Syntax_Syntax.sigelt Prims.list -> + FStarC_TypeChecker_Env.env_t -> + FStarC_Syntax_Syntax.sigelt Prims.list) + = + fun sig_bndle -> + fun tcs -> + fun datas -> + fun env0 -> + let uu___ = + let ty = FStarC_Compiler_List.hd tcs in + match ty.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = uu___1; + FStarC_Syntax_Syntax.us = us; + FStarC_Syntax_Syntax.params = uu___2; + FStarC_Syntax_Syntax.num_uniform_params = uu___3; + FStarC_Syntax_Syntax.t = t; + FStarC_Syntax_Syntax.mutuals = uu___4; + FStarC_Syntax_Syntax.ds = uu___5; + FStarC_Syntax_Syntax.injective_type_params = uu___6;_} + -> (us, t) + | uu___1 -> failwith "Impossible!" in + match uu___ with + | (us, t) -> + let uu___1 = FStarC_Syntax_Subst.univ_var_opening us in + (match uu___1 with + | (usubst, us1) -> + let env = FStarC_TypeChecker_Env.push env0 "haseq" in + let env1 = + FStarC_TypeChecker_Env.push_sigelt_force env sig_bndle in + ((env1.FStarC_TypeChecker_Env.solver).FStarC_TypeChecker_Env.encode_sig + env1 sig_bndle; + (let env2 = + FStarC_TypeChecker_Env.push_univ_vars env1 us1 in + let uu___3 = + FStarC_Compiler_List.fold_left + (optimized_haseq_ty datas usubst us1) + ([], env2, FStarC_Syntax_Util.t_true, + FStarC_Syntax_Util.t_true) tcs in + match uu___3 with + | (axioms, env3, guard, cond) -> + let phi = + let uu___4 = FStarC_Syntax_Util.arrow_formals t in + match uu___4 with + | (uu___5, t1) -> + let uu___6 = + FStarC_Syntax_Util.is_eqtype_no_unrefine t1 in + if uu___6 + then cond + else FStarC_Syntax_Util.mk_imp guard cond in + let uu___4 = + FStarC_TypeChecker_TcTerm.tc_trivial_guard env3 + phi in + (match uu___4 with + | (phi1, uu___5) -> + ((let uu___7 = + FStarC_TypeChecker_Env.should_verify env3 in + if uu___7 + then + let uu___8 = + FStarC_TypeChecker_Env.guard_of_guard_formula + (FStarC_TypeChecker_Common.NonTrivial + phi1) in + FStarC_TypeChecker_Rel.force_trivial_guard + env3 uu___8 + else ()); + (let ses = + FStarC_Compiler_List.fold_left + (fun l -> + fun uu___7 -> + match uu___7 with + | (lid, fml) -> + let fml1 = + FStarC_Syntax_Subst.close_univ_vars + us1 fml in + FStarC_Compiler_List.op_At l + [{ + FStarC_Syntax_Syntax.sigel + = + (FStarC_Syntax_Syntax.Sig_assume + { + FStarC_Syntax_Syntax.lid3 + = lid; + FStarC_Syntax_Syntax.us3 + = us1; + FStarC_Syntax_Syntax.phi1 + = fml1 + }); + FStarC_Syntax_Syntax.sigrng + = + FStarC_Compiler_Range_Type.dummyRange; + FStarC_Syntax_Syntax.sigquals + = + [FStarC_Syntax_Syntax.InternalAssumption]; + FStarC_Syntax_Syntax.sigmeta + = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs + = []; + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = []; + FStarC_Syntax_Syntax.sigopts + = + FStar_Pervasives_Native.None + }]) [] axioms in + (let uu___8 = + FStarC_TypeChecker_Env.pop env3 "haseq" in + ()); + ses)))))) +let (unoptimized_haseq_data : + FStarC_Syntax_Syntax.subst_elt Prims.list -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.term -> + FStarC_Ident.lident Prims.list -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.sigelt -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun usubst -> + fun bs -> + fun haseq_ind -> + fun mutuals -> + fun acc -> + fun data -> + let rec is_mutual t = + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + FStarC_Compiler_List.existsb + (fun lid -> + FStarC_Ident.lid_equals lid + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v) + mutuals + | FStarC_Syntax_Syntax.Tm_uinst (t', uu___1) -> is_mutual t' + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = bv; + FStarC_Syntax_Syntax.phi = uu___1;_} + -> is_mutual bv.FStarC_Syntax_Syntax.sort + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = t'; + FStarC_Syntax_Syntax.args = args;_} + -> + let uu___1 = is_mutual t' in + if uu___1 + then true + else + (let uu___3 = + FStarC_Compiler_List.map FStar_Pervasives_Native.fst + args in + exists_mutual uu___3) + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t'; + FStarC_Syntax_Syntax.meta = uu___1;_} + -> is_mutual t' + | uu___1 -> false + and exists_mutual uu___ = + match uu___ with + | [] -> false + | hd::tl -> (is_mutual hd) || (exists_mutual tl) in + let dt = datacon_typ data in + let dt1 = FStarC_Syntax_Subst.subst usubst dt in + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress dt1 in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = dbs; + FStarC_Syntax_Syntax.comp = uu___1;_} + -> + let dbs1 = + let uu___2 = + FStarC_Compiler_List.splitAt + (FStarC_Compiler_List.length bs) dbs in + FStar_Pervasives_Native.snd uu___2 in + let dbs2 = + let uu___2 = FStarC_Syntax_Subst.opening_of_binders bs in + FStarC_Syntax_Subst.subst_binders uu___2 dbs1 in + let dbs3 = FStarC_Syntax_Subst.open_binders dbs2 in + let cond = + FStarC_Compiler_List.fold_left + (fun t -> + fun b -> + let sort = + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + let haseq_sort = + let uu___2 = + let uu___3 = + FStarC_Syntax_Syntax.as_arg + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + [uu___3] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Syntax_Util.t_haseq uu___2 + FStarC_Compiler_Range_Type.dummyRange in + let haseq_sort1 = + let uu___2 = is_mutual sort in + if uu___2 + then + FStarC_Syntax_Util.mk_imp haseq_ind haseq_sort + else haseq_sort in + FStarC_Syntax_Util.mk_conj t haseq_sort1) + FStarC_Syntax_Util.t_true dbs3 in + let cond1 = + FStarC_Compiler_List.fold_right + (fun b -> + fun t -> + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.mk_binder + b.FStarC_Syntax_Syntax.binder_bv in + [uu___6] in + let uu___6 = FStarC_Syntax_Subst.close [b] t in + FStarC_Syntax_Util.abs uu___5 uu___6 + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.as_arg uu___4 in + [uu___3] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Syntax_Util.tforall uu___2 + FStarC_Compiler_Range_Type.dummyRange) dbs3 cond in + FStarC_Syntax_Util.mk_conj acc cond1 + | uu___1 -> acc +let (unoptimized_haseq_ty : + FStarC_Syntax_Syntax.sigelt Prims.list -> + FStarC_Ident.lident Prims.list -> + FStarC_Syntax_Syntax.subst_elt Prims.list -> + FStarC_Syntax_Syntax.univ_name Prims.list -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.sigelt -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun all_datas_in_the_bundle -> + fun mutuals -> + fun usubst -> + fun us -> + fun acc -> + fun ty -> + let uu___ = + match ty.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = lid; + FStarC_Syntax_Syntax.us = uu___1; + FStarC_Syntax_Syntax.params = bs; + FStarC_Syntax_Syntax.num_uniform_params = uu___2; + FStarC_Syntax_Syntax.t = t; + FStarC_Syntax_Syntax.mutuals = uu___3; + FStarC_Syntax_Syntax.ds = d_lids; + FStarC_Syntax_Syntax.injective_type_params = uu___4;_} + -> (lid, bs, t, d_lids) + | uu___1 -> failwith "Impossible!" in + match uu___ with + | (lid, bs, t, d_lids) -> + let bs1 = FStarC_Syntax_Subst.subst_binders usubst bs in + let t1 = + let uu___1 = + FStarC_Syntax_Subst.shift_subst + (FStarC_Compiler_List.length bs1) usubst in + FStarC_Syntax_Subst.subst uu___1 t in + let uu___1 = FStarC_Syntax_Subst.open_term bs1 t1 in + (match uu___1 with + | (bs2, t2) -> + let ibs = + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress t2 in + uu___3.FStarC_Syntax_Syntax.n in + match uu___2 with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = ibs1; + FStarC_Syntax_Syntax.comp = uu___3;_} + -> ibs1 + | uu___3 -> [] in + let ibs1 = FStarC_Syntax_Subst.open_binders ibs in + let ind = + let uu___2 = + FStarC_Syntax_Syntax.fvar lid + FStar_Pervasives_Native.None in + let uu___3 = + FStarC_Compiler_List.map + (fun u -> FStarC_Syntax_Syntax.U_name u) us in + FStarC_Syntax_Syntax.mk_Tm_uinst uu___2 uu___3 in + let ind1 = + let uu___2 = + FStarC_Compiler_List.map + FStarC_Syntax_Util.arg_of_non_null_binder bs2 in + FStarC_Syntax_Syntax.mk_Tm_app ind uu___2 + FStarC_Compiler_Range_Type.dummyRange in + let ind2 = + let uu___2 = + FStarC_Compiler_List.map + FStarC_Syntax_Util.arg_of_non_null_binder ibs1 in + FStarC_Syntax_Syntax.mk_Tm_app ind1 uu___2 + FStarC_Compiler_Range_Type.dummyRange in + let haseq_ind = + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.as_arg ind2 in + [uu___3] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Syntax_Util.t_haseq uu___2 + FStarC_Compiler_Range_Type.dummyRange in + let t_datas = + FStarC_Compiler_List.filter + (fun s -> + match s.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = uu___2; + FStarC_Syntax_Syntax.us1 = uu___3; + FStarC_Syntax_Syntax.t1 = uu___4; + FStarC_Syntax_Syntax.ty_lid = t_lid; + FStarC_Syntax_Syntax.num_ty_params = + uu___5; + FStarC_Syntax_Syntax.mutuals1 = uu___6; + FStarC_Syntax_Syntax.injective_type_params1 + = uu___7;_} + -> t_lid = lid + | uu___2 -> failwith "Impossible") + all_datas_in_the_bundle in + let data_cond = + FStarC_Compiler_List.fold_left + (unoptimized_haseq_data usubst bs2 haseq_ind + mutuals) FStarC_Syntax_Util.t_true t_datas in + let fml = + FStarC_Syntax_Util.mk_imp data_cond haseq_ind in + let fml1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.binders_to_names ibs1 in + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Syntax_Syntax.as_arg haseq_ind in + [uu___9] in + [uu___8] in + (uu___6, uu___7) in + FStarC_Syntax_Syntax.Meta_pattern uu___5 in + { + FStarC_Syntax_Syntax.tm2 = fml; + FStarC_Syntax_Syntax.meta = uu___4 + } in + FStarC_Syntax_Syntax.Tm_meta uu___3 in + { + FStarC_Syntax_Syntax.n = uu___2; + FStarC_Syntax_Syntax.pos = + (fml.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = + (fml.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (fml.FStarC_Syntax_Syntax.hash_code) + } in + let fml2 = + FStarC_Compiler_List.fold_right + (fun b -> + fun t3 -> + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.mk_binder + b.FStarC_Syntax_Syntax.binder_bv in + [uu___6] in + let uu___6 = + FStarC_Syntax_Subst.close [b] t3 in + FStarC_Syntax_Util.abs uu___5 uu___6 + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.as_arg uu___4 in + [uu___3] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Syntax_Util.tforall uu___2 + FStarC_Compiler_Range_Type.dummyRange) ibs1 + fml1 in + let fml3 = + FStarC_Compiler_List.fold_right + (fun b -> + fun t3 -> + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.mk_binder + b.FStarC_Syntax_Syntax.binder_bv in + [uu___6] in + let uu___6 = + FStarC_Syntax_Subst.close [b] t3 in + FStarC_Syntax_Util.abs uu___5 uu___6 + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.as_arg uu___4 in + [uu___3] in + FStarC_Syntax_Syntax.mk_Tm_app + FStarC_Syntax_Util.tforall uu___2 + FStarC_Compiler_Range_Type.dummyRange) bs2 + fml2 in + FStarC_Syntax_Util.mk_conj acc fml3) +let (unoptimized_haseq_scheme : + FStarC_Syntax_Syntax.sigelt -> + FStarC_Syntax_Syntax.sigelt Prims.list -> + FStarC_Syntax_Syntax.sigelt Prims.list -> + FStarC_TypeChecker_Env.env_t -> + FStarC_Syntax_Syntax.sigelt Prims.list) + = + fun sig_bndle -> + fun tcs -> + fun datas -> + fun env0 -> + let mutuals = + FStarC_Compiler_List.map + (fun ty -> + match ty.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = lid; + FStarC_Syntax_Syntax.us = uu___; + FStarC_Syntax_Syntax.params = uu___1; + FStarC_Syntax_Syntax.num_uniform_params = uu___2; + FStarC_Syntax_Syntax.t = uu___3; + FStarC_Syntax_Syntax.mutuals = uu___4; + FStarC_Syntax_Syntax.ds = uu___5; + FStarC_Syntax_Syntax.injective_type_params = uu___6;_} + -> lid + | uu___ -> failwith "Impossible!") tcs in + let uu___ = + let ty = FStarC_Compiler_List.hd tcs in + match ty.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = lid; + FStarC_Syntax_Syntax.us = us; + FStarC_Syntax_Syntax.params = uu___1; + FStarC_Syntax_Syntax.num_uniform_params = uu___2; + FStarC_Syntax_Syntax.t = uu___3; + FStarC_Syntax_Syntax.mutuals = uu___4; + FStarC_Syntax_Syntax.ds = uu___5; + FStarC_Syntax_Syntax.injective_type_params = uu___6;_} + -> (lid, us) + | uu___1 -> failwith "Impossible!" in + match uu___ with + | (lid, us) -> + let uu___1 = FStarC_Syntax_Subst.univ_var_opening us in + (match uu___1 with + | (usubst, us1) -> + let fml = + FStarC_Compiler_List.fold_left + (unoptimized_haseq_ty datas mutuals usubst us1) + FStarC_Syntax_Util.t_true tcs in + let se = + let uu___2 = + let uu___3 = + let uu___4 = get_haseq_axiom_lid lid in + { + FStarC_Syntax_Syntax.lid3 = uu___4; + FStarC_Syntax_Syntax.us3 = us1; + FStarC_Syntax_Syntax.phi1 = fml + } in + FStarC_Syntax_Syntax.Sig_assume uu___3 in + { + FStarC_Syntax_Syntax.sigel = uu___2; + FStarC_Syntax_Syntax.sigrng = + FStarC_Compiler_Range_Type.dummyRange; + FStarC_Syntax_Syntax.sigquals = + [FStarC_Syntax_Syntax.InternalAssumption]; + FStarC_Syntax_Syntax.sigmeta = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs = []; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = []; + FStarC_Syntax_Syntax.sigopts = + FStar_Pervasives_Native.None + } in + [se]) +let (check_inductive_well_typedness : + FStarC_TypeChecker_Env.env_t -> + FStarC_Syntax_Syntax.sigelt Prims.list -> + FStarC_Syntax_Syntax.qualifier Prims.list -> + FStarC_Ident.lident Prims.list -> + (FStarC_Syntax_Syntax.sigelt * FStarC_Syntax_Syntax.sigelt + Prims.list * FStarC_Syntax_Syntax.sigelt Prims.list)) + = + fun env -> + fun ses -> + fun quals -> + fun lids -> + let uu___ = + FStarC_Compiler_List.partition + (fun uu___1 -> + match uu___1 with + | { + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_inductive_typ uu___2; + FStarC_Syntax_Syntax.sigrng = uu___3; + FStarC_Syntax_Syntax.sigquals = uu___4; + FStarC_Syntax_Syntax.sigmeta = uu___5; + FStarC_Syntax_Syntax.sigattrs = uu___6; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___7; + FStarC_Syntax_Syntax.sigopts = uu___8;_} -> true + | uu___2 -> false) ses in + match uu___ with + | (tys, datas) -> + ((let uu___2 = + FStarC_Compiler_Util.for_some + (fun uu___3 -> + match uu___3 with + | { + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_datacon uu___4; + FStarC_Syntax_Syntax.sigrng = uu___5; + FStarC_Syntax_Syntax.sigquals = uu___6; + FStarC_Syntax_Syntax.sigmeta = uu___7; + FStarC_Syntax_Syntax.sigattrs = uu___8; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = uu___9; + FStarC_Syntax_Syntax.sigopts = uu___10;_} -> false + | uu___4 -> true) datas in + if uu___2 + then + FStarC_Errors.raise_error + FStarC_TypeChecker_Env.hasRange_env env + FStarC_Errors_Codes.Fatal_NonInductiveInMutuallyDefinedType + () (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Mutually defined type contains a non-inductive element") + else ()); + (let univs = + if (FStarC_Compiler_List.length tys) = Prims.int_zero + then [] + else + (let uu___3 = + let uu___4 = FStarC_Compiler_List.hd tys in + uu___4.FStarC_Syntax_Syntax.sigel in + match uu___3 with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = uu___4; + FStarC_Syntax_Syntax.us = uvs; + FStarC_Syntax_Syntax.params = uu___5; + FStarC_Syntax_Syntax.num_uniform_params = uu___6; + FStarC_Syntax_Syntax.t = uu___7; + FStarC_Syntax_Syntax.mutuals = uu___8; + FStarC_Syntax_Syntax.ds = uu___9; + FStarC_Syntax_Syntax.injective_type_params = + uu___10;_} + -> uvs + | uu___4 -> failwith "Impossible, can't happen!") in + let env0 = env in + let uu___2 = + FStarC_Compiler_List.fold_right + (fun tc -> + fun uu___3 -> + match uu___3 with + | (env1, all_tcs, g) -> + let uu___4 = tc_tycon env1 tc in + (match uu___4 with + | (env2, tc1, tc_u, guard) -> + let g' = + FStarC_TypeChecker_Rel.universe_inequality + FStarC_Syntax_Syntax.U_zero tc_u in + ((let uu___6 = FStarC_Compiler_Debug.low () in + if uu___6 + then + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_sigelt + tc1 in + FStarC_Compiler_Util.print1 + "Checked inductive: %s\n" uu___7 + else ()); + (let uu___6 = + let uu___7 = + FStarC_TypeChecker_Env.conj_guard + guard g' in + FStarC_TypeChecker_Env.conj_guard g + uu___7 in + (env2, ((tc1, tc_u) :: all_tcs), uu___6))))) + tys (env, [], FStarC_TypeChecker_Env.trivial_guard) in + match uu___2 with + | (env1, tcs, g) -> + let g1 = FStarC_TypeChecker_Rel.resolve_implicits env1 g in + let uu___3 = + FStarC_Compiler_List.fold_right + (fun se -> + fun uu___4 -> + match uu___4 with + | (datas1, g2) -> + let uu___5 = + let uu___6 = tc_data env1 tcs in uu___6 se in + (match uu___5 with + | (data, g') -> + let uu___6 = + FStarC_TypeChecker_Env.conj_guard g2 + g' in + ((data :: datas1), uu___6))) datas + ([], g1) in + (match uu___3 with + | (datas1, g2) -> + let uu___4 = + let tc_universe_vars = + FStarC_Compiler_List.map + FStar_Pervasives_Native.snd tcs in + let g3 = + let uu___5 = + let uu___6 = + FStarC_Class_Listlike.from_list + (FStarC_Compiler_CList.listlike_clist ()) + tc_universe_vars in + (uu___6, + (FStar_Pervasives_Native.snd + g2.FStarC_TypeChecker_Common.univ_ineqs)) in + { + FStarC_TypeChecker_Common.guard_f = + (g2.FStarC_TypeChecker_Common.guard_f); + FStarC_TypeChecker_Common.deferred_to_tac = + (g2.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (g2.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = uu___5; + FStarC_TypeChecker_Common.implicits = + (g2.FStarC_TypeChecker_Common.implicits) + } in + (let uu___6 = + FStarC_Compiler_Effect.op_Bang dbg_GenUniverses in + if uu___6 + then + let uu___7 = + FStarC_TypeChecker_Rel.guard_to_string env1 + g3 in + FStarC_Compiler_Util.print1 + "@@@@@@Guard before (possible) generalization: %s\n" + uu___7 + else ()); + FStarC_TypeChecker_Rel.force_trivial_guard env0 g3; + if + (FStarC_Compiler_List.length univs) = + Prims.int_zero + then generalize_and_inst_within env0 tcs datas1 + else + (let uu___8 = + FStarC_Compiler_List.map + FStar_Pervasives_Native.fst tcs in + (uu___8, datas1)) in + (match uu___4 with + | (tcs1, datas2) -> + let tcs2 = + FStarC_Compiler_List.map + (fun se -> + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = l; + FStarC_Syntax_Syntax.us = univs1; + FStarC_Syntax_Syntax.params = + binders; + FStarC_Syntax_Syntax.num_uniform_params + = num_uniform; + FStarC_Syntax_Syntax.t = typ; + FStarC_Syntax_Syntax.mutuals = ts; + FStarC_Syntax_Syntax.ds = ds; + FStarC_Syntax_Syntax.injective_type_params + = uu___5;_} + -> + let fail expected inferred = + let uu___6 = + let uu___7 = + FStarC_Syntax_Print.tscheme_to_string + expected in + let uu___8 = + FStarC_Syntax_Print.tscheme_to_string + inferred in + FStarC_Compiler_Util.format2 + "Expected an inductive with type %s; got %s" + uu___7 uu___8 in + FStarC_Errors.raise_error + FStarC_Syntax_Syntax.has_range_sigelt + se + FStarC_Errors_Codes.Fatal_UnexpectedInductivetype + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___6) in + let copy_binder_attrs_from_val + binders1 expected = + let expected_attrs = + let uu___6 = + let uu___7 = + FStarC_TypeChecker_Normalize.get_n_binders + env1 + (FStarC_Compiler_List.length + binders1) expected in + FStar_Pervasives_Native.fst + uu___7 in + FStarC_Compiler_List.map + (fun uu___7 -> + match uu___7 with + | { + FStarC_Syntax_Syntax.binder_bv + = uu___8; + FStarC_Syntax_Syntax.binder_qual + = uu___9; + FStarC_Syntax_Syntax.binder_positivity + = pqual; + FStarC_Syntax_Syntax.binder_attrs + = attrs;_} + -> (attrs, pqual)) + uu___6 in + if + (FStarC_Compiler_List.length + expected_attrs) + <> + (FStarC_Compiler_List.length + binders1) + then + let uu___6 = + let uu___7 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length + binders1) in + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + expected in + FStarC_Compiler_Util.format2 + "Could not get %s type parameters from val type %s" + uu___7 uu___8 in + FStarC_Errors.raise_error + FStarC_Syntax_Syntax.has_range_sigelt + se + FStarC_Errors_Codes.Fatal_UnexpectedInductivetype + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___6) + else + FStarC_Compiler_List.map2 + (fun uu___7 -> + fun b -> + match uu___7 with + | (ex_attrs, pqual) -> + ((let uu___9 = + let uu___10 = + FStarC_TypeChecker_Common.check_positivity_qual + true pqual + b.FStarC_Syntax_Syntax.binder_positivity in + Prims.op_Negation + uu___10 in + if uu___9 + then + FStarC_Errors.raise_error + FStarC_Syntax_Syntax.hasRange_binder + b + FStarC_Errors_Codes.Fatal_UnexpectedInductivetype + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Incompatible positivity annotation") + else ()); + { + FStarC_Syntax_Syntax.binder_bv + = + (b.FStarC_Syntax_Syntax.binder_bv); + FStarC_Syntax_Syntax.binder_qual + = + (b.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity + = pqual; + FStarC_Syntax_Syntax.binder_attrs + = + (FStarC_Compiler_List.op_At + b.FStarC_Syntax_Syntax.binder_attrs + ex_attrs) + })) expected_attrs + binders1 in + let inferred_typ_with_binders + binders1 = + let body = + match binders1 with + | [] -> typ + | uu___6 -> + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Syntax_Syntax.mk_Total + typ in + { + FStarC_Syntax_Syntax.bs1 + = binders1; + FStarC_Syntax_Syntax.comp + = uu___9 + } in + FStarC_Syntax_Syntax.Tm_arrow + uu___8 in + FStarC_Syntax_Syntax.mk + uu___7 + se.FStarC_Syntax_Syntax.sigrng in + (univs1, body) in + let uu___6 = + FStarC_TypeChecker_Env.try_lookup_val_decl + env0 l in + (match uu___6 with + | FStar_Pervasives_Native.None -> + se + | FStar_Pervasives_Native.Some + (expected_typ, uu___7) -> + if + (FStarC_Compiler_List.length + univs1) + = + (FStarC_Compiler_List.length + (FStar_Pervasives_Native.fst + expected_typ)) + then + let uu___8 = + FStarC_Syntax_Subst.open_univ_vars + univs1 + (FStar_Pervasives_Native.snd + expected_typ) in + (match uu___8 with + | (uu___9, expected) -> + let binders1 = + copy_binder_attrs_from_val + binders expected in + let inferred_typ = + inferred_typ_with_binders + binders1 in + let uu___10 = + FStarC_Syntax_Subst.open_univ_vars + univs1 + (FStar_Pervasives_Native.snd + inferred_typ) in + (match uu___10 with + | (uu___11, inferred) + -> + let uu___12 = + FStarC_TypeChecker_Rel.teq_nosmt_force + env0 inferred + expected in + if uu___12 + then + { + FStarC_Syntax_Syntax.sigel + = + (FStarC_Syntax_Syntax.Sig_inductive_typ + { + FStarC_Syntax_Syntax.lid + = l; + FStarC_Syntax_Syntax.us + = univs1; + FStarC_Syntax_Syntax.params + = + binders1; + FStarC_Syntax_Syntax.num_uniform_params + = + num_uniform; + FStarC_Syntax_Syntax.t + = typ; + FStarC_Syntax_Syntax.mutuals + = ts; + FStarC_Syntax_Syntax.ds + = ds; + FStarC_Syntax_Syntax.injective_type_params + = false + }); + FStarC_Syntax_Syntax.sigrng + = + (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals + = + (se.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta + = + (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs + = + (se.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts + = + (se.FStarC_Syntax_Syntax.sigopts) + } + else + fail expected_typ + inferred_typ)) + else + (let uu___9 = + inferred_typ_with_binders + binders in + fail expected_typ uu___9)) + | uu___5 -> se) tcs1 in + let tcs3 = + FStarC_Compiler_List.map + (check_sig_inductive_injectivity_on_params + env0) tcs2 in + let is_injective l = + let uu___5 = + FStarC_Compiler_List.tryPick + (fun se -> + let uu___6 = + se.FStarC_Syntax_Syntax.sigel in + match uu___6 with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = lid; + FStarC_Syntax_Syntax.us = uu___7; + FStarC_Syntax_Syntax.params = + uu___8; + FStarC_Syntax_Syntax.num_uniform_params + = uu___9; + FStarC_Syntax_Syntax.t = uu___10; + FStarC_Syntax_Syntax.mutuals = + uu___11; + FStarC_Syntax_Syntax.ds = + uu___12; + FStarC_Syntax_Syntax.injective_type_params + = injective_type_params;_} + -> + let uu___13 = + FStarC_Ident.lid_equals l lid in + if uu___13 + then + FStar_Pervasives_Native.Some + injective_type_params + else FStar_Pervasives_Native.None) + tcs3 in + match uu___5 with + | FStar_Pervasives_Native.None -> false + | FStar_Pervasives_Native.Some i -> i in + let datas3 = + FStarC_Compiler_List.map + (fun se -> + let uu___5 = + se.FStarC_Syntax_Syntax.sigel in + match uu___5 with + | FStarC_Syntax_Syntax.Sig_datacon dd -> + let uu___6 = + let uu___7 = + let uu___8 = + is_injective + dd.FStarC_Syntax_Syntax.ty_lid in + { + FStarC_Syntax_Syntax.lid1 = + (dd.FStarC_Syntax_Syntax.lid1); + FStarC_Syntax_Syntax.us1 = + (dd.FStarC_Syntax_Syntax.us1); + FStarC_Syntax_Syntax.t1 = + (dd.FStarC_Syntax_Syntax.t1); + FStarC_Syntax_Syntax.ty_lid = + (dd.FStarC_Syntax_Syntax.ty_lid); + FStarC_Syntax_Syntax.num_ty_params + = + (dd.FStarC_Syntax_Syntax.num_ty_params); + FStarC_Syntax_Syntax.mutuals1 + = + (dd.FStarC_Syntax_Syntax.mutuals1); + FStarC_Syntax_Syntax.injective_type_params1 + = uu___8 + } in + FStarC_Syntax_Syntax.Sig_datacon + uu___7 in + { + FStarC_Syntax_Syntax.sigel = + uu___6; + FStarC_Syntax_Syntax.sigrng = + (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = + (se.FStarC_Syntax_Syntax.sigattrs); + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se.FStarC_Syntax_Syntax.sigopts) + }) datas2 in + let sig_bndle = + let uu___5 = + FStarC_TypeChecker_Env.get_range env0 in + let uu___6 = + FStarC_Compiler_List.collect + (fun s -> s.FStarC_Syntax_Syntax.sigattrs) + ses in + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_bundle + { + FStarC_Syntax_Syntax.ses = + (FStarC_Compiler_List.op_At tcs3 + datas3); + FStarC_Syntax_Syntax.lids = lids + }); + FStarC_Syntax_Syntax.sigrng = uu___5; + FStarC_Syntax_Syntax.sigquals = quals; + FStarC_Syntax_Syntax.sigmeta = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs = uu___6; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + []; + FStarC_Syntax_Syntax.sigopts = + FStar_Pervasives_Native.None + } in + (sig_bndle, tcs3, datas3))))) +let (early_prims_inductives : Prims.string Prims.list) = + ["empty"; "trivial"; "equals"; "pair"; "sum"] +let (mk_discriminator_and_indexed_projectors : + FStarC_Syntax_Syntax.qualifier Prims.list -> + FStarC_Syntax_Syntax.attribute Prims.list -> + FStarC_Syntax_Syntax.fv_qual -> + Prims.bool -> + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.univ_names -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.binders -> + Prims.bool -> FStarC_Syntax_Syntax.sigelt Prims.list) + = + fun iquals -> + fun attrs -> + fun fvq -> + fun refine_domain -> + fun env -> + fun tc -> + fun lid -> + fun uvs -> + fun inductive_tps -> + fun indices -> + fun fields -> + fun erasable -> + let p = FStarC_Ident.range_of_lid lid in + let pos q = FStarC_Syntax_Syntax.withinfo q p in + let projectee ptyp = + FStarC_Syntax_Syntax.gen_bv "projectee" + (FStar_Pervasives_Native.Some p) ptyp in + let inst_univs = + FStarC_Compiler_List.map + (fun u -> FStarC_Syntax_Syntax.U_name u) uvs in + let tps = inductive_tps in + let arg_typ = + let inst_tc = + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Syntax_Syntax.lid_as_fv tc + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___3 in + (uu___2, inst_univs) in + FStarC_Syntax_Syntax.Tm_uinst uu___1 in + FStarC_Syntax_Syntax.mk uu___ p in + let args = + FStarC_Compiler_List.map + FStarC_Syntax_Util.arg_of_non_null_binder + (FStarC_Compiler_List.op_At tps indices) in + FStarC_Syntax_Syntax.mk_Tm_app inst_tc args p in + let unrefined_arg_binder = + let uu___ = projectee arg_typ in + FStarC_Syntax_Syntax.mk_binder uu___ in + let arg_binder = + if Prims.op_Negation refine_domain + then unrefined_arg_binder + else + (let disc_name = + FStarC_Syntax_Util.mk_discriminator lid in + let x = + FStarC_Syntax_Syntax.new_bv + (FStar_Pervasives_Native.Some p) arg_typ in + let sort = + let disc_fvar = + let uu___1 = + FStarC_Ident.set_lid_range disc_name p in + FStarC_Syntax_Syntax.fvar_with_dd uu___1 + FStar_Pervasives_Native.None in + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Syntax_Syntax.mk_Tm_uinst + disc_fvar inst_univs in + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.bv_to_name x in + FStarC_Syntax_Syntax.as_arg uu___6 in + [uu___5] in + FStarC_Syntax_Syntax.mk_Tm_app uu___3 + uu___4 p in + FStarC_Syntax_Util.b2t uu___2 in + FStarC_Syntax_Util.refine x uu___1 in + let uu___1 = + let uu___2 = projectee arg_typ in + { + FStarC_Syntax_Syntax.ppname = + (uu___2.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (uu___2.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = sort + } in + FStarC_Syntax_Syntax.mk_binder uu___1) in + let ntps = FStarC_Compiler_List.length tps in + let all_params = + let uu___ = + FStarC_Compiler_List.map + (fun b -> + { + FStarC_Syntax_Syntax.binder_bv = + (b.FStarC_Syntax_Syntax.binder_bv); + FStarC_Syntax_Syntax.binder_qual = + (FStar_Pervasives_Native.Some + FStarC_Syntax_Syntax.imp_tag); + FStarC_Syntax_Syntax.binder_positivity = + (b.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs = + (b.FStarC_Syntax_Syntax.binder_attrs) + }) tps in + FStarC_Compiler_List.op_At uu___ fields in + let imp_binders = + FStarC_Compiler_List.map + (fun b -> + let uu___ = + mk_implicit + b.FStarC_Syntax_Syntax.binder_qual in + { + FStarC_Syntax_Syntax.binder_bv = + (b.FStarC_Syntax_Syntax.binder_bv); + FStarC_Syntax_Syntax.binder_qual = uu___; + FStarC_Syntax_Syntax.binder_positivity = + (b.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs = + (b.FStarC_Syntax_Syntax.binder_attrs) + }) (FStarC_Compiler_List.op_At tps indices) in + let early_prims_inductive = + (let uu___ = + FStarC_TypeChecker_Env.current_module env in + FStarC_Ident.lid_equals + FStarC_Parser_Const.prims_lid uu___) + && + (FStarC_Compiler_List.existsb + (fun s -> + let uu___ = + let uu___1 = + FStarC_Ident.ident_of_lid tc in + FStarC_Ident.string_of_id uu___1 in + s = uu___) early_prims_inductives) in + let discriminator_ses = + if fvq <> FStarC_Syntax_Syntax.Data_ctor + then [] + else + (let discriminator_name = + FStarC_Syntax_Util.mk_discriminator lid in + let no_decl = false in + let only_decl = + early_prims_inductive || + (FStarC_Syntax_Util.has_attribute attrs + FStarC_Parser_Const.no_auto_projectors_attr) in + let quals = + let uu___1 = + FStarC_Compiler_List.filter + (fun uu___2 -> + match uu___2 with + | FStarC_Syntax_Syntax.Inline_for_extraction + -> true + | FStarC_Syntax_Syntax.NoExtract -> + true + | FStarC_Syntax_Syntax.Private -> + true + | uu___3 -> false) iquals in + FStarC_Compiler_List.op_At + ((FStarC_Syntax_Syntax.Discriminator lid) + :: + (if only_decl + then + [FStarC_Syntax_Syntax.Logic; + FStarC_Syntax_Syntax.Assumption] + else [])) uu___1 in + let binders = + FStarC_Compiler_List.op_At imp_binders + [unrefined_arg_binder] in + let t = + let bool_typ = + if erasable + then + FStarC_Syntax_Syntax.mk_GTotal + FStarC_Syntax_Util.t_bool + else + FStarC_Syntax_Syntax.mk_Total + FStarC_Syntax_Util.t_bool in + let uu___1 = + FStarC_Syntax_Util.arrow binders bool_typ in + FStarC_Syntax_Subst.close_univ_vars uvs + uu___1 in + let decl = + let uu___1 = + FStarC_Ident.range_of_lid + discriminator_name in + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_declare_typ + { + FStarC_Syntax_Syntax.lid2 = + discriminator_name; + FStarC_Syntax_Syntax.us2 = uvs; + FStarC_Syntax_Syntax.t2 = t + }); + FStarC_Syntax_Syntax.sigrng = uu___1; + FStarC_Syntax_Syntax.sigquals = quals; + FStarC_Syntax_Syntax.sigmeta = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs = attrs; + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = []; + FStarC_Syntax_Syntax.sigopts = + FStar_Pervasives_Native.None + } in + (let uu___2 = + FStarC_Compiler_Effect.op_Bang dbg_LogTypes in + if uu___2 + then + let uu___3 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_sigelt + decl in + FStarC_Compiler_Util.print1 + "Declaration of a discriminator %s\n" + uu___3 + else ()); + if only_decl + then [decl] + else + (let body = + if Prims.op_Negation refine_domain + then FStarC_Syntax_Util.exp_true_bool + else + (let arg_pats = + FStarC_Compiler_List.mapi + (fun j -> + fun uu___4 -> + match uu___4 with + | { + FStarC_Syntax_Syntax.binder_bv + = x; + FStarC_Syntax_Syntax.binder_qual + = imp; + FStarC_Syntax_Syntax.binder_positivity + = uu___5; + FStarC_Syntax_Syntax.binder_attrs + = uu___6;_} + -> + let b = + FStarC_Syntax_Syntax.is_bqual_implicit + imp in + if b && (j < ntps) + then + let uu___7 = + pos + (FStarC_Syntax_Syntax.Pat_dot_term + FStar_Pervasives_Native.None) in + (uu___7, b) + else + (let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Ident.string_of_id + x.FStarC_Syntax_Syntax.ppname in + FStarC_Syntax_Syntax.gen_bv + uu___11 + FStar_Pervasives_Native.None + FStarC_Syntax_Syntax.tun in + FStarC_Syntax_Syntax.Pat_var + uu___10 in + pos uu___9 in + (uu___8, b))) + all_params in + let pat_true = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Syntax_Syntax.lid_as_fv + lid + (FStar_Pervasives_Native.Some + fvq) in + (uu___7, + FStar_Pervasives_Native.None, + arg_pats) in + FStarC_Syntax_Syntax.Pat_cons + uu___6 in + pos uu___5 in + (uu___4, + FStar_Pervasives_Native.None, + FStarC_Syntax_Util.exp_true_bool) in + let pat_false = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.new_bv + FStar_Pervasives_Native.None + FStarC_Syntax_Syntax.tun in + FStarC_Syntax_Syntax.Pat_var + uu___6 in + pos uu___5 in + (uu___4, + FStar_Pervasives_Native.None, + FStarC_Syntax_Util.exp_false_bool) in + let arg_exp = + FStarC_Syntax_Syntax.bv_to_name + unrefined_arg_binder.FStarC_Syntax_Syntax.binder_bv in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Syntax_Util.branch + pat_true in + let uu___8 = + let uu___9 = + FStarC_Syntax_Util.branch + pat_false in + [uu___9] in + uu___7 :: uu___8 in + { + FStarC_Syntax_Syntax.scrutinee = + arg_exp; + FStarC_Syntax_Syntax.ret_opt = + FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.brs = + uu___6; + FStarC_Syntax_Syntax.rc_opt1 = + FStar_Pervasives_Native.None + } in + FStarC_Syntax_Syntax.Tm_match uu___5 in + FStarC_Syntax_Syntax.mk uu___4 p) in + let imp = + FStarC_Syntax_Util.abs binders body + FStar_Pervasives_Native.None in + let lbtyp = + if no_decl + then t + else FStarC_Syntax_Syntax.tun in + let lb = + let uu___3 = + let uu___4 = + FStarC_Syntax_Syntax.lid_and_dd_as_fv + discriminator_name + FStar_Pervasives_Native.None in + FStar_Pervasives.Inr uu___4 in + let uu___4 = + FStarC_Syntax_Subst.close_univ_vars uvs + imp in + FStarC_Syntax_Util.mk_letbinding uu___3 + uvs lbtyp + FStarC_Parser_Const.effect_Tot_lid + uu___4 [] + FStarC_Compiler_Range_Type.dummyRange in + let impl = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Compiler_Util.right + lb.FStarC_Syntax_Syntax.lbname in + (uu___7.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + [uu___6] in + { + FStarC_Syntax_Syntax.lbs1 = + (false, [lb]); + FStarC_Syntax_Syntax.lids1 = uu___5 + } in + FStarC_Syntax_Syntax.Sig_let uu___4 in + { + FStarC_Syntax_Syntax.sigel = uu___3; + FStarC_Syntax_Syntax.sigrng = p; + FStarC_Syntax_Syntax.sigquals = quals; + FStarC_Syntax_Syntax.sigmeta = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs = attrs; + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = []; + FStarC_Syntax_Syntax.sigopts = + FStar_Pervasives_Native.None + } in + (let uu___4 = + FStarC_Compiler_Effect.op_Bang + dbg_LogTypes in + if uu___4 + then + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_sigelt + impl in + FStarC_Compiler_Util.print1 + "Implementation of a discriminator %s\n" + uu___5 + else ()); + [decl; impl])) in + let arg_exp = + FStarC_Syntax_Syntax.bv_to_name + arg_binder.FStarC_Syntax_Syntax.binder_bv in + let binders = + FStarC_Compiler_List.op_At imp_binders + [arg_binder] in + let arg = + FStarC_Syntax_Util.arg_of_non_null_binder + arg_binder in + let subst = + FStarC_Compiler_List.mapi + (fun i -> + fun uu___ -> + match uu___ with + | { FStarC_Syntax_Syntax.binder_bv = a; + FStarC_Syntax_Syntax.binder_qual = + uu___1; + FStarC_Syntax_Syntax.binder_positivity + = uu___2; + FStarC_Syntax_Syntax.binder_attrs = + uu___3;_} + -> + let field_name = + FStarC_Syntax_Util.mk_field_projector_name + lid a i in + let field_proj_tm = + let uu___4 = + let uu___5 = + FStarC_Syntax_Syntax.lid_as_fv + field_name + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm + uu___5 in + FStarC_Syntax_Syntax.mk_Tm_uinst + uu___4 inst_univs in + let proj = + FStarC_Syntax_Syntax.mk_Tm_app + field_proj_tm [arg] p in + FStarC_Syntax_Syntax.NT (a, proj)) + fields in + let projectors_ses = + let uu___ = + (FStarC_Syntax_Util.has_attribute attrs + FStarC_Parser_Const.no_auto_projectors_decls_attr) + || + (FStarC_Syntax_Util.has_attribute attrs + FStarC_Parser_Const.meta_projectors_attr) in + if uu___ + then [] + else + (let uu___2 = + FStarC_Compiler_List.mapi + (fun i -> + fun uu___3 -> + match uu___3 with + | { + FStarC_Syntax_Syntax.binder_bv = + x; + FStarC_Syntax_Syntax.binder_qual + = uu___4; + FStarC_Syntax_Syntax.binder_positivity + = uu___5; + FStarC_Syntax_Syntax.binder_attrs + = uu___6;_} + -> + let p1 = + FStarC_Syntax_Syntax.range_of_bv + x in + let field_name = + FStarC_Syntax_Util.mk_field_projector_name + lid x i in + let result_comp = + let t = + FStarC_Syntax_Subst.subst + subst + x.FStarC_Syntax_Syntax.sort in + if erasable + then + FStarC_Syntax_Syntax.mk_GTotal + t + else + FStarC_Syntax_Syntax.mk_Total + t in + let t = + let uu___7 = + FStarC_Syntax_Util.arrow + binders result_comp in + FStarC_Syntax_Subst.close_univ_vars + uvs uu___7 in + let only_decl = + early_prims_inductive || + (FStarC_Syntax_Util.has_attribute + attrs + FStarC_Parser_Const.no_auto_projectors_attr) in + let no_decl = false in + let quals q = + if only_decl + then + FStarC_Syntax_Syntax.Assumption + :: q + else q in + let quals1 = + let iquals1 = + FStarC_Compiler_List.filter + (fun uu___7 -> + match uu___7 with + | FStarC_Syntax_Syntax.Inline_for_extraction + -> true + | FStarC_Syntax_Syntax.NoExtract + -> true + | FStarC_Syntax_Syntax.Private + -> true + | uu___8 -> false) + iquals in + quals + ((FStarC_Syntax_Syntax.Projector + (lid, + (x.FStarC_Syntax_Syntax.ppname))) + :: iquals1) in + let attrs1 = + FStarC_Compiler_List.op_At + (if only_decl + then [] + else + [FStarC_Syntax_Util.attr_substitute]) + attrs in + let decl = + let uu___7 = + FStarC_Ident.range_of_lid + field_name in + { + FStarC_Syntax_Syntax.sigel = + (FStarC_Syntax_Syntax.Sig_declare_typ + { + FStarC_Syntax_Syntax.lid2 + = field_name; + FStarC_Syntax_Syntax.us2 + = uvs; + FStarC_Syntax_Syntax.t2 + = t + }); + FStarC_Syntax_Syntax.sigrng = + uu___7; + FStarC_Syntax_Syntax.sigquals + = quals1; + FStarC_Syntax_Syntax.sigmeta + = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs + = attrs1; + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = []; + FStarC_Syntax_Syntax.sigopts + = + FStar_Pervasives_Native.None + } in + ((let uu___8 = + FStarC_Compiler_Effect.op_Bang + dbg_LogTypes in + if uu___8 + then + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_sigelt + decl in + FStarC_Compiler_Util.print1 + "Declaration of a projector %s\n" + uu___9 + else ()); + if only_decl + then [decl] + else + (let projection = + let uu___9 = + FStarC_Ident.string_of_id + x.FStarC_Syntax_Syntax.ppname in + FStarC_Syntax_Syntax.gen_bv + uu___9 + FStar_Pervasives_Native.None + FStarC_Syntax_Syntax.tun in + let arg_pats = + FStarC_Compiler_List.mapi + (fun j -> + fun uu___9 -> + match uu___9 with + | { + FStarC_Syntax_Syntax.binder_bv + = x1; + FStarC_Syntax_Syntax.binder_qual + = imp; + FStarC_Syntax_Syntax.binder_positivity + = uu___10; + FStarC_Syntax_Syntax.binder_attrs + = uu___11;_} + -> + let b = + FStarC_Syntax_Syntax.is_bqual_implicit + imp in + if + (i + ntps) = j + then + let uu___12 = + pos + (FStarC_Syntax_Syntax.Pat_var + projection) in + (uu___12, b) + else + if + b && + (j < ntps) + then + (let uu___13 + = + pos + (FStarC_Syntax_Syntax.Pat_dot_term + FStar_Pervasives_Native.None) in + (uu___13, + b)) + else + (let uu___14 + = + let uu___15 + = + let uu___16 + = + let uu___17 + = + FStarC_Ident.string_of_id + x1.FStarC_Syntax_Syntax.ppname in + FStarC_Syntax_Syntax.gen_bv + uu___17 + FStar_Pervasives_Native.None + FStarC_Syntax_Syntax.tun in + FStarC_Syntax_Syntax.Pat_var + uu___16 in + pos + uu___15 in + (uu___14, + b))) + all_params in + let pat = + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Syntax_Syntax.lid_as_fv + lid + (FStar_Pervasives_Native.Some + fvq) in + (uu___12, + FStar_Pervasives_Native.None, + arg_pats) in + FStarC_Syntax_Syntax.Pat_cons + uu___11 in + pos uu___10 in + let uu___10 = + FStarC_Syntax_Syntax.bv_to_name + projection in + (uu___9, + FStar_Pervasives_Native.None, + uu___10) in + let body = + let return_bv = + FStarC_Syntax_Syntax.gen_bv + "proj_ret" + (FStar_Pervasives_Native.Some + p1) + FStarC_Syntax_Syntax.tun in + let result_typ = + let uu___9 = + let uu___10 = + FStarC_Syntax_Syntax.mk_binder + return_bv in + [uu___10] in + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_Syntax_Syntax.bv_to_name + return_bv in + ((arg_binder.FStarC_Syntax_Syntax.binder_bv), + uu___14) in + FStarC_Syntax_Syntax.NT + uu___13 in + [uu___12] in + FStarC_Syntax_Subst.subst + uu___11 + (FStarC_Syntax_Util.comp_result + result_comp) in + FStarC_Syntax_Subst.close + uu___9 uu___10 in + let return_binder = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Syntax_Syntax.mk_binder + return_bv in + [uu___11] in + FStarC_Syntax_Subst.close_binders + uu___10 in + FStarC_Compiler_List.hd + uu___9 in + let returns_annotation = + let use_eq = true in + FStar_Pervasives_Native.Some + (return_binder, + ((FStar_Pervasives.Inl + result_typ), + FStar_Pervasives_Native.None, + use_eq)) in + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Syntax_Util.branch + pat in + [uu___12] in + { + FStarC_Syntax_Syntax.scrutinee + = arg_exp; + FStarC_Syntax_Syntax.ret_opt + = + returns_annotation; + FStarC_Syntax_Syntax.brs + = uu___11; + FStarC_Syntax_Syntax.rc_opt1 + = + FStar_Pervasives_Native.None + } in + FStarC_Syntax_Syntax.Tm_match + uu___10 in + FStarC_Syntax_Syntax.mk + uu___9 p1 in + let imp = + FStarC_Syntax_Util.abs + binders body + FStar_Pervasives_Native.None in + let dd = + FStarC_Syntax_Syntax.Delta_equational_at_level + Prims.int_one in + let lbtyp = + if no_decl + then t + else + FStarC_Syntax_Syntax.tun in + let lb = + let uu___9 = + let uu___10 = + FStarC_Syntax_Syntax.lid_and_dd_as_fv + field_name + FStar_Pervasives_Native.None in + FStar_Pervasives.Inr + uu___10 in + let uu___10 = + FStarC_Syntax_Subst.close_univ_vars + uvs imp in + { + FStarC_Syntax_Syntax.lbname + = uu___9; + FStarC_Syntax_Syntax.lbunivs + = uvs; + FStarC_Syntax_Syntax.lbtyp + = lbtyp; + FStarC_Syntax_Syntax.lbeff + = + FStarC_Parser_Const.effect_Tot_lid; + FStarC_Syntax_Syntax.lbdef + = uu___10; + FStarC_Syntax_Syntax.lbattrs + = []; + FStarC_Syntax_Syntax.lbpos + = + FStarC_Compiler_Range_Type.dummyRange + } in + let impl = + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Compiler_Util.right + lb.FStarC_Syntax_Syntax.lbname in + (uu___13.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + [uu___12] in + { + FStarC_Syntax_Syntax.lbs1 + = (false, [lb]); + FStarC_Syntax_Syntax.lids1 + = uu___11 + } in + FStarC_Syntax_Syntax.Sig_let + uu___10 in + { + FStarC_Syntax_Syntax.sigel + = uu___9; + FStarC_Syntax_Syntax.sigrng + = p1; + FStarC_Syntax_Syntax.sigquals + = quals1; + FStarC_Syntax_Syntax.sigmeta + = + FStarC_Syntax_Syntax.default_sigmeta; + FStarC_Syntax_Syntax.sigattrs + = attrs1; + FStarC_Syntax_Syntax.sigopens_and_abbrevs + = []; + FStarC_Syntax_Syntax.sigopts + = + FStar_Pervasives_Native.None + } in + (let uu___10 = + FStarC_Compiler_Effect.op_Bang + dbg_LogTypes in + if uu___10 + then + let uu___11 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_sigelt + impl in + FStarC_Compiler_Util.print1 + "Implementation of a projector %s\n" + uu___11 + else ()); + if no_decl + then [impl] + else [decl; impl]))) fields in + FStarC_Compiler_List.flatten uu___2) in + let no_plugin se = + let not_plugin_attr t = + let h = FStarC_Syntax_Util.head_of t in + let uu___ = + FStarC_Syntax_Util.is_fvar + FStarC_Parser_Const.plugin_attr h in + Prims.op_Negation uu___ in + let uu___ = + FStarC_Compiler_List.filter not_plugin_attr + se.FStarC_Syntax_Syntax.sigattrs in + { + FStarC_Syntax_Syntax.sigel = + (se.FStarC_Syntax_Syntax.sigel); + FStarC_Syntax_Syntax.sigrng = + (se.FStarC_Syntax_Syntax.sigrng); + FStarC_Syntax_Syntax.sigquals = + (se.FStarC_Syntax_Syntax.sigquals); + FStarC_Syntax_Syntax.sigmeta = + (se.FStarC_Syntax_Syntax.sigmeta); + FStarC_Syntax_Syntax.sigattrs = uu___; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + (se.FStarC_Syntax_Syntax.sigopens_and_abbrevs); + FStarC_Syntax_Syntax.sigopts = + (se.FStarC_Syntax_Syntax.sigopts) + } in + FStarC_Compiler_List.map no_plugin + (FStarC_Compiler_List.op_At discriminator_ses + projectors_ses) +let (mk_data_operations : + FStarC_Syntax_Syntax.qualifier Prims.list -> + FStarC_Syntax_Syntax.attribute Prims.list -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.sigelt Prims.list -> + FStarC_Syntax_Syntax.sigelt -> + FStarC_Syntax_Syntax.sigelt Prims.list) + = + fun iquals -> + fun attrs -> + fun env -> + fun tcs -> + fun se -> + match se.FStarC_Syntax_Syntax.sigel with + | FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = constr_lid; + FStarC_Syntax_Syntax.us1 = uvs; + FStarC_Syntax_Syntax.t1 = t; + FStarC_Syntax_Syntax.ty_lid = typ_lid; + FStarC_Syntax_Syntax.num_ty_params = n_typars; + FStarC_Syntax_Syntax.mutuals1 = uu___; + FStarC_Syntax_Syntax.injective_type_params1 = uu___1;_} + -> + let uu___2 = FStarC_Syntax_Subst.univ_var_opening uvs in + (match uu___2 with + | (univ_opening, uvs1) -> + let t1 = FStarC_Syntax_Subst.subst univ_opening t in + let uu___3 = FStarC_Syntax_Util.arrow_formals t1 in + (match uu___3 with + | (formals, uu___4) -> + let uu___5 = + let tps_opt = + FStarC_Compiler_Util.find_map tcs + (fun se1 -> + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Util.lid_of_sigelt se1 in + FStarC_Compiler_Util.must uu___8 in + FStarC_Ident.lid_equals typ_lid uu___7 in + if uu___6 + then + match se1.FStarC_Syntax_Syntax.sigel + with + | FStarC_Syntax_Syntax.Sig_inductive_typ + { FStarC_Syntax_Syntax.lid = uu___7; + FStarC_Syntax_Syntax.us = uvs'; + FStarC_Syntax_Syntax.params = tps; + FStarC_Syntax_Syntax.num_uniform_params + = uu___8; + FStarC_Syntax_Syntax.t = typ0; + FStarC_Syntax_Syntax.mutuals = + uu___9; + FStarC_Syntax_Syntax.ds = constrs; + FStarC_Syntax_Syntax.injective_type_params + = uu___10;_} + -> + FStar_Pervasives_Native.Some + (tps, typ0, + ((FStarC_Compiler_List.length + constrs) + > Prims.int_one)) + | uu___7 -> failwith "Impossible" + else FStar_Pervasives_Native.None) in + match tps_opt with + | FStar_Pervasives_Native.Some x -> x + | FStar_Pervasives_Native.None -> + let uu___6 = + FStarC_Ident.lid_equals typ_lid + FStarC_Parser_Const.exn_lid in + if uu___6 + then ([], FStarC_Syntax_Util.ktype0, true) + else + FStarC_Errors.raise_error + FStarC_Syntax_Syntax.has_range_sigelt se + FStarC_Errors_Codes.Fatal_UnexpectedDataConstructor + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "Unexpected data constructor") in + (match uu___5 with + | (inductive_tps, typ0, should_refine) -> + let inductive_tps1 = + FStarC_Syntax_Subst.subst_binders + univ_opening inductive_tps in + let typ01 = + let uu___6 = + FStarC_Syntax_Subst.shift_subst + (FStarC_Compiler_List.length + inductive_tps1) univ_opening in + FStarC_Syntax_Subst.subst uu___6 typ0 in + let uu___6 = + FStarC_Syntax_Util.arrow_formals typ01 in + (match uu___6 with + | (indices, uu___7) -> + let refine_domain = + let uu___8 = + FStarC_Compiler_Util.for_some + (fun uu___9 -> + match uu___9 with + | FStarC_Syntax_Syntax.RecordConstructor + uu___10 -> true + | uu___10 -> false) + se.FStarC_Syntax_Syntax.sigquals in + if uu___8 then false else should_refine in + let fv_qual = + let filter_records uu___8 = + match uu___8 with + | FStarC_Syntax_Syntax.RecordConstructor + (uu___9, fns) -> + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Record_ctor + (typ_lid, fns)) + | uu___9 -> + FStar_Pervasives_Native.None in + let uu___8 = + FStarC_Compiler_Util.find_map + se.FStarC_Syntax_Syntax.sigquals + filter_records in + match uu___8 with + | FStar_Pervasives_Native.None -> + FStarC_Syntax_Syntax.Data_ctor + | FStar_Pervasives_Native.Some q -> q in + let fields = + let uu___8 = + FStarC_Compiler_Util.first_N n_typars + formals in + match uu___8 with + | (imp_tps, fields1) -> + let rename = + FStarC_Compiler_List.map2 + (fun uu___9 -> + fun uu___10 -> + match (uu___9, uu___10) + with + | ({ + FStarC_Syntax_Syntax.binder_bv + = x; + FStarC_Syntax_Syntax.binder_qual + = uu___11; + FStarC_Syntax_Syntax.binder_positivity + = uu___12; + FStarC_Syntax_Syntax.binder_attrs + = uu___13;_}, + { + FStarC_Syntax_Syntax.binder_bv + = x'; + FStarC_Syntax_Syntax.binder_qual + = uu___14; + FStarC_Syntax_Syntax.binder_positivity + = uu___15; + FStarC_Syntax_Syntax.binder_attrs + = uu___16;_}) + -> + let uu___17 = + let uu___18 = + FStarC_Syntax_Syntax.bv_to_name + x' in + (x, uu___18) in + FStarC_Syntax_Syntax.NT + uu___17) imp_tps + inductive_tps1 in + FStarC_Syntax_Subst.subst_binders + rename fields1 in + let erasable = + FStarC_Syntax_Util.has_attribute + se.FStarC_Syntax_Syntax.sigattrs + FStarC_Parser_Const.erasable_attr in + mk_discriminator_and_indexed_projectors + iquals attrs fv_qual refine_domain env + typ_lid constr_lid uvs1 inductive_tps1 + indices fields erasable)))) + | uu___ -> [] \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_TcTerm.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_TcTerm.ml new file mode 100644 index 00000000000..b21de050299 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_TcTerm.ml @@ -0,0 +1,14143 @@ +open Prims +let (dbg_Exports : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Exports" +let (dbg_LayeredEffects : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "LayeredEffects" +let (dbg_NYC : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "NYC" +let (dbg_Patterns : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Patterns" +let (dbg_Range : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Range" +let (dbg_RelCheck : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "RelCheck" +let (dbg_RFD : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "RFD" +let (dbg_Tac : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Tac" +let (dbg_UniverseOf : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "UniverseOf" +let (instantiate_both : + FStarC_TypeChecker_Env.env -> FStarC_TypeChecker_Env.env) = + fun env -> + { + FStarC_TypeChecker_Env.solver = (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = (env.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = true; + FStarC_TypeChecker_Env.effects = (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = (env.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env.FStarC_TypeChecker_Env.missing_decl) + } +let (no_inst : FStarC_TypeChecker_Env.env -> FStarC_TypeChecker_Env.env) = + fun env -> + { + FStarC_TypeChecker_Env.solver = (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = (env.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = false; + FStarC_TypeChecker_Env.effects = (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = (env.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env.FStarC_TypeChecker_Env.missing_decl) + } +let (is_eq : + FStarC_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> + Prims.bool) + = + fun uu___ -> + match uu___ with + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Equality) -> true + | uu___1 -> false +let steps : 'uuuuu . 'uuuuu -> FStarC_TypeChecker_Env.step Prims.list = + fun env -> + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.NoFullNorm; + FStarC_TypeChecker_Env.Exclude FStarC_TypeChecker_Env.Zeta] +let (norm : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun env -> + fun t -> FStarC_TypeChecker_Normalize.normalize (steps env) env t +let (norm_c : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.comp -> FStarC_Syntax_Syntax.comp) + = + fun env -> + fun c -> FStarC_TypeChecker_Normalize.normalize_comp (steps env) env c +let (check_no_escape : + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.bv Prims.list -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Env.guard_t)) + = + fun head_opt -> + fun env -> + fun fvs -> + fun kt -> + FStarC_Errors.with_ctx "While checking for escaped variables" + (fun uu___ -> + let fail x = + let msg = + match head_opt with + | FStar_Pervasives_Native.None -> + let uu___1 = + let uu___2 = FStarC_Errors_Msg.text "Bound variable" in + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_bv x in + FStarC_Pprint.squotes uu___5 in + let uu___5 = + FStarC_Errors_Msg.text + "would escape in the type of this letbinding" in + FStarC_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in + FStarC_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in + let uu___2 = + let uu___3 = + FStarC_Errors_Msg.text + "Add a type annotation that does not mention it" in + [uu___3] in + uu___1 :: uu___2 + | FStar_Pervasives_Native.Some head -> + let uu___1 = + let uu___2 = FStarC_Errors_Msg.text "Bound variable" in + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_bv x in + FStarC_Pprint.squotes uu___5 in + let uu___5 = + let uu___6 = + FStarC_Errors_Msg.text + "escapes because of impure applications in the type of" in + let uu___7 = + let uu___8 = + FStarC_TypeChecker_Normalize.term_to_doc env + head in + FStarC_Pprint.squotes uu___8 in + FStarC_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in + FStarC_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in + FStarC_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in + let uu___2 = + let uu___3 = + FStarC_Errors_Msg.text + "Add explicit let-bindings to avoid this" in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Errors.raise_error + FStarC_TypeChecker_Env.hasRange_env env + FStarC_Errors_Codes.Fatal_EscapedBoundVar () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic msg) in + match fvs with + | [] -> + (kt, + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t)) + | uu___1 -> + let rec aux try_norm t = + let t1 = if try_norm then norm env t else t in + let fvs' = FStarC_Syntax_Free.names t1 in + let uu___2 = + FStarC_Compiler_List.tryFind + (fun x -> + FStarC_Class_Setlike.mem () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) x + (Obj.magic fvs')) fvs in + match uu___2 with + | FStar_Pervasives_Native.None -> + (t1, + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t)) + | FStar_Pervasives_Native.Some x -> + if Prims.op_Negation try_norm + then let uu___3 = norm env t1 in aux true uu___3 + else + (try + (fun uu___4 -> + match () with + | () -> + let env_extended = + FStarC_TypeChecker_Env.push_bvs env + fvs in + let uu___5 = + let uu___6 = + FStarC_TypeChecker_Env.get_range env in + let uu___7 = + let uu___8 = + FStarC_Syntax_Util.type_u () in + FStar_Pervasives_Native.fst uu___8 in + FStarC_TypeChecker_Util.new_implicit_var + "no escape" uu___6 env uu___7 false in + (match uu___5 with + | (s, uu___6, g0) -> + let uu___7 = + FStarC_TypeChecker_Rel.try_teq + false env_extended t1 s in + (match uu___7 with + | FStar_Pervasives_Native.Some g + -> + let g1 = + let uu___8 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g g0 in + FStarC_TypeChecker_Rel.solve_deferred_constraints + env_extended uu___8 in + (s, g1) + | uu___8 -> fail x))) () + with | uu___4 -> fail x) in + aux false kt) +let (check_expected_aqual_for_binder : + FStarC_Syntax_Syntax.aqual -> + FStarC_Syntax_Syntax.binder -> + FStarC_Compiler_Range_Type.range -> FStarC_Syntax_Syntax.aqual) + = + fun aq -> + fun b -> + fun pos -> + let uu___ = + let expected_aq = FStarC_Syntax_Util.aqual_of_binder b in + match (aq, expected_aq) with + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> + FStar_Pervasives.Inr aq + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.Some eaq) + -> + if eaq.FStarC_Syntax_Syntax.aqual_implicit + then + FStar_Pervasives.Inl + "expected implicit annotation on the argument" + else FStar_Pervasives.Inr expected_aq + | (FStar_Pervasives_Native.Some aq1, FStar_Pervasives_Native.None) + -> + FStar_Pervasives.Inl + "expected an explicit argument (without annotation)" + | (FStar_Pervasives_Native.Some aq1, FStar_Pervasives_Native.Some + eaq) -> + if + aq1.FStarC_Syntax_Syntax.aqual_implicit <> + eaq.FStarC_Syntax_Syntax.aqual_implicit + then FStar_Pervasives.Inl "mismatch" + else FStar_Pervasives.Inr expected_aq in + match uu___ with + | FStar_Pervasives.Inl err -> + let msg = + let uu___1 = + FStarC_Errors_Msg.text + (Prims.strcat "Inconsistent argument qualifiers: " + (Prims.strcat err ".")) in + [uu___1] in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range + pos FStarC_Errors_Codes.Fatal_InconsistentImplicitQualifier () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic msg) + | FStar_Pervasives.Inr r -> r +let (check_erasable_binder_attributes : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term Prims.list -> FStarC_Syntax_Syntax.typ -> unit) + = + fun env -> + fun attrs -> + fun binder_ty -> + FStarC_Compiler_List.iter + (fun attr -> + let uu___ = + (FStarC_Syntax_Util.is_fvar FStarC_Parser_Const.erasable_attr + attr) + && + (let uu___1 = + FStarC_TypeChecker_Normalize.non_info_norm env binder_ty in + Prims.op_Negation uu___1) in + if uu___ + then + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) attr + FStarC_Errors_Codes.Fatal_QulifierListNotPermitted () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Incompatible attributes: an erasable attribute on a binder must bind a name at an non-informative type") + else ()) attrs +let (push_binding : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.binder -> FStarC_TypeChecker_Env.env) + = + fun env -> + fun b -> + FStarC_TypeChecker_Env.push_bv env b.FStarC_Syntax_Syntax.binder_bv +let (maybe_extend_subst : + FStarC_Syntax_Syntax.subst_elt Prims.list -> + FStarC_Syntax_Syntax.binder -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.subst_t) + = + fun s -> + fun b -> + fun v -> + let uu___ = FStarC_Syntax_Syntax.is_null_binder b in + if uu___ + then s + else + (FStarC_Syntax_Syntax.NT ((b.FStarC_Syntax_Syntax.binder_bv), v)) + :: s +let (set_lcomp_result : + FStarC_TypeChecker_Common.lcomp -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_TypeChecker_Common.lcomp) + = + fun lc -> + fun t -> + FStarC_TypeChecker_Common.apply_lcomp + (fun c -> FStarC_Syntax_Util.set_result_typ c t) (fun g -> g) + { + FStarC_TypeChecker_Common.eff_name = + (lc.FStarC_TypeChecker_Common.eff_name); + FStarC_TypeChecker_Common.res_typ = t; + FStarC_TypeChecker_Common.cflags = + (lc.FStarC_TypeChecker_Common.cflags); + FStarC_TypeChecker_Common.comp_thunk = + (lc.FStarC_TypeChecker_Common.comp_thunk) + } +let (memo_tk : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.term) + = fun e -> fun t -> e +let (maybe_warn_on_use : + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.fv -> unit) = + fun env -> + fun fv -> + let uu___ = + FStarC_TypeChecker_Env.lookup_attrs_of_lid env + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + match uu___ with + | FStar_Pervasives_Native.None -> () + | FStar_Pervasives_Native.Some attrs -> + FStarC_Compiler_List.iter + (fun a -> + let uu___1 = FStarC_Syntax_Util.head_and_args a in + match uu___1 with + | (head, args) -> + let msg_arg m = + match args with + | ({ + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_string (s, uu___2)); + FStarC_Syntax_Syntax.pos = uu___3; + FStarC_Syntax_Syntax.vars = uu___4; + FStarC_Syntax_Syntax.hash_code = uu___5;_}, + uu___6)::[] -> + let uu___7 = + let uu___8 = FStarC_Errors_Msg.text s in [uu___8] in + FStarC_Compiler_List.op_At m uu___7 + | uu___2 -> m in + (match head.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_fvar attr_fv when + FStarC_Ident.lid_equals + (attr_fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + FStarC_Parser_Const.warn_on_use_attr + -> + let m = + let uu___2 = + let uu___3 = + FStarC_Ident.string_of_lid + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + FStarC_Compiler_Util.format1 + "Every use of %s triggers a warning" uu___3 in + FStarC_Errors_Msg.text uu___2 in + let uu___2 = msg_arg [m] in + FStarC_Errors.log_issue FStarC_Ident.hasrange_lident + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + FStarC_Errors_Codes.Warning_WarnOnUse () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___2) + | FStarC_Syntax_Syntax.Tm_fvar attr_fv when + FStarC_Ident.lid_equals + (attr_fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + FStarC_Parser_Const.deprecated_attr + -> + let m = + let uu___2 = + let uu___3 = + FStarC_Ident.string_of_lid + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + FStarC_Compiler_Util.format1 "%s is deprecated" + uu___3 in + FStarC_Errors_Msg.text uu___2 in + let uu___2 = msg_arg [m] in + FStarC_Errors.log_issue FStarC_Ident.hasrange_lident + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + FStarC_Errors_Codes.Warning_DeprecatedDefinition () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___2) + | uu___2 -> ())) attrs +let (value_check_expected_typ : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.typ, FStarC_TypeChecker_Common.lcomp) + FStar_Pervasives.either -> + FStarC_TypeChecker_Env.guard_t -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.lcomp * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun e -> + fun tlc -> + fun guard -> + FStarC_Defensive.def_check_scoped + FStarC_TypeChecker_Env.hasBinders_env + FStarC_TypeChecker_Env.hasNames_guard + FStarC_TypeChecker_Env.pretty_guard e.FStarC_Syntax_Syntax.pos + "value_check_expected_typ" env guard; + (let lc = + match tlc with + | FStar_Pervasives.Inl t -> + let uu___1 = FStarC_Syntax_Syntax.mk_Total t in + FStarC_TypeChecker_Common.lcomp_of_comp uu___1 + | FStar_Pervasives.Inr lc1 -> lc1 in + let t = lc.FStarC_TypeChecker_Common.res_typ in + let uu___1 = + let uu___2 = FStarC_TypeChecker_Env.expected_typ env in + match uu___2 with + | FStar_Pervasives_Native.None -> ((memo_tk e t), lc, guard) + | FStar_Pervasives_Native.Some (t', use_eq) -> + let uu___3 = + FStarC_TypeChecker_Util.check_has_type_maybe_coerce env e + lc t' use_eq in + (match uu___3 with + | (e1, lc1, g) -> + ((let uu___5 = FStarC_Compiler_Debug.medium () in + if uu___5 + then + let uu___6 = + FStarC_TypeChecker_Common.lcomp_to_string lc1 in + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t' in + let uu___8 = + FStarC_TypeChecker_Rel.guard_to_string env g in + let uu___9 = + FStarC_TypeChecker_Rel.guard_to_string env guard in + FStarC_Compiler_Util.print4 + "value_check_expected_typ: type is %s<:%s \tguard is %s, %s\n" + uu___6 uu___7 uu___8 uu___9 + else ()); + (let t1 = lc1.FStarC_TypeChecker_Common.res_typ in + let g1 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t g guard in + let msg = + let uu___5 = + FStarC_TypeChecker_Env.is_trivial_guard_formula + g1 in + if uu___5 + then FStar_Pervasives_Native.None + else + FStar_Pervasives_Native.Some + (FStarC_TypeChecker_Err.subtyping_failed env t1 + t') in + let uu___5 = + FStarC_TypeChecker_Util.strengthen_precondition msg + env e1 lc1 g1 in + match uu___5 with + | (lc2, g2) -> + let uu___6 = set_lcomp_result lc2 t' in + ((memo_tk e1 t'), uu___6, g2)))) in + match uu___1 with | (e1, lc1, g) -> (e1, lc1, g)) +let (comp_check_expected_typ : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_TypeChecker_Common.lcomp -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.lcomp * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun e -> + fun lc -> + let uu___ = FStarC_TypeChecker_Env.expected_typ env in + match uu___ with + | FStar_Pervasives_Native.None -> + (e, lc, + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t)) + | FStar_Pervasives_Native.Some (t, use_eq) -> + let uu___1 = FStarC_TypeChecker_Util.maybe_coerce_lc env e lc t in + (match uu___1 with + | (e1, lc1, g_c) -> + let uu___2 = + FStarC_TypeChecker_Util.weaken_result_typ env e1 lc1 t + use_eq in + (match uu___2 with + | (e2, lc2, g) -> + let uu___3 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t g g_c in + (e2, lc2, uu___3))) +let (check_expected_effect : + FStarC_TypeChecker_Env.env -> + Prims.bool -> + FStarC_Syntax_Syntax.comp FStar_Pervasives_Native.option -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.comp) -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.comp * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun use_eq -> + fun copt -> + fun ec -> + let uu___ = ec in + match uu___ with + | (e, c) -> + let tot_or_gtot c1 = + let uu___1 = FStarC_Syntax_Util.is_pure_comp c1 in + if uu___1 + then + FStarC_Syntax_Syntax.mk_Total + (FStarC_Syntax_Util.comp_result c1) + else + (let uu___3 = FStarC_Syntax_Util.is_pure_or_ghost_comp c1 in + if uu___3 + then + FStarC_Syntax_Syntax.mk_GTotal + (FStarC_Syntax_Util.comp_result c1) + else failwith "Impossible: Expected pure_or_ghost comp") in + let uu___1 = + let ct = FStarC_Syntax_Util.comp_result c in + match copt with + | FStar_Pervasives_Native.Some uu___2 -> + (copt, c, FStar_Pervasives_Native.None) + | FStar_Pervasives_Native.None -> + let uu___2 = + ((FStarC_Options.ml_ish ()) && + (let uu___3 = FStarC_Parser_Const.effect_ALL_lid () in + FStarC_Ident.lid_equals uu___3 + (FStarC_Syntax_Util.comp_effect_name c))) + || + (((FStarC_Options.ml_ish ()) && + (FStarC_Options.lax ())) + && + (let uu___3 = + FStarC_Syntax_Util.is_pure_or_ghost_comp c in + Prims.op_Negation uu___3)) in + if uu___2 + then + let uu___3 = + let uu___4 = + FStarC_Syntax_Util.ml_comp ct + e.FStarC_Syntax_Syntax.pos in + FStar_Pervasives_Native.Some uu___4 in + (uu___3, c, FStar_Pervasives_Native.None) + else + (let uu___4 = FStarC_Syntax_Util.is_tot_or_gtot_comp c in + if uu___4 + then + let uu___5 = tot_or_gtot c in + (FStar_Pervasives_Native.None, uu___5, + FStar_Pervasives_Native.None) + else + (let uu___6 = + FStarC_Syntax_Util.is_pure_or_ghost_comp c in + if uu___6 + then + let uu___7 = + let uu___8 = tot_or_gtot c in + FStar_Pervasives_Native.Some uu___8 in + (uu___7, c, FStar_Pervasives_Native.None) + else + (let norm_eff_name = + FStarC_TypeChecker_Env.norm_eff_name env + (FStarC_Syntax_Util.comp_effect_name c) in + let uu___8 = + FStarC_TypeChecker_Env.is_layered_effect env + norm_eff_name in + if uu___8 + then + let def_eff_opt = + FStarC_TypeChecker_Env.get_default_effect + env norm_eff_name in + match def_eff_opt with + | FStar_Pervasives_Native.None -> + let uu___9 = + let uu___10 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + (FStarC_Syntax_Util.comp_effect_name + c) in + let uu___11 = + FStarC_Class_Show.show + FStarC_Compiler_Range_Ops.showable_range + e.FStarC_Syntax_Syntax.pos in + FStarC_Compiler_Util.format2 + "Missing annotation for a layered effect (%s) computation at %s" + uu___10 uu___11 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax + ()) e + FStarC_Errors_Codes.Error_LayeredMissingAnnot + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___9) + | FStar_Pervasives_Native.Some def_eff -> + let uu___9 = + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Comp + { + FStarC_Syntax_Syntax.comp_univs = + comp_univs; + FStarC_Syntax_Syntax.effect_name = + uu___10; + FStarC_Syntax_Syntax.result_typ = + result_ty; + FStarC_Syntax_Syntax.effect_args = + uu___11; + FStarC_Syntax_Syntax.flags = + uu___12;_} + -> (comp_univs, result_ty) + | uu___10 -> failwith "Impossible!" in + (match uu___9 with + | (comp_univs, result_ty) -> + let expected_c = + { + FStarC_Syntax_Syntax.comp_univs = + comp_univs; + FStarC_Syntax_Syntax.effect_name + = def_eff; + FStarC_Syntax_Syntax.result_typ = + result_ty; + FStarC_Syntax_Syntax.effect_args + = []; + FStarC_Syntax_Syntax.flags = [] + } in + let uu___10 = + let uu___11 = + FStarC_Syntax_Syntax.mk_Comp + expected_c in + FStar_Pervasives_Native.Some + uu___11 in + (uu___10, c, + FStar_Pervasives_Native.None)) + else + (let uu___10 = + FStarC_Options.trivial_pre_for_unannotated_effectful_fns + () in + if uu___10 + then + let uu___11 = + let uu___12 = + FStarC_TypeChecker_Util.check_trivial_precondition_wp + env c in + match uu___12 with + | (uu___13, uu___14, g) -> + FStar_Pervasives_Native.Some g in + (FStar_Pervasives_Native.None, c, uu___11) + else + (FStar_Pervasives_Native.None, c, + FStar_Pervasives_Native.None))))) in + (match uu___1 with + | (expected_c_opt, c1, gopt) -> + (FStarC_Defensive.def_check_scoped + FStarC_TypeChecker_Env.hasBinders_env + FStarC_Class_Binders.hasNames_comp + FStarC_Syntax_Print.pretty_comp + c1.FStarC_Syntax_Syntax.pos + "check_expected_effect.c.before_norm" env c1; + (let c2 = + FStarC_Errors.with_ctx + "While normalizing actual computation type in check_expected_effect" + (fun uu___3 -> norm_c env c1) in + FStarC_Defensive.def_check_scoped + FStarC_TypeChecker_Env.hasBinders_env + FStarC_Class_Binders.hasNames_comp + FStarC_Syntax_Print.pretty_comp + c2.FStarC_Syntax_Syntax.pos + "check_expected_effect.c.after_norm" env c2; + (match expected_c_opt with + | FStar_Pervasives_Native.None -> + (e, c2, + ((match gopt with + | FStar_Pervasives_Native.None -> + FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t + | FStar_Pervasives_Native.Some g -> g))) + | FStar_Pervasives_Native.Some expected_c -> + ((match gopt with + | FStar_Pervasives_Native.None -> () + | FStar_Pervasives_Native.Some uu___5 -> + failwith + "Impossible! check_expected_effect, gopt should have been None"); + (let c3 = + let uu___5 = + FStarC_TypeChecker_Common.lcomp_of_comp c2 in + FStarC_TypeChecker_Util.maybe_assume_result_eq_pure_term + env e uu___5 in + let uu___5 = + FStarC_TypeChecker_Common.lcomp_comp c3 in + match uu___5 with + | (c4, g_c) -> + (FStarC_Defensive.def_check_scoped + FStarC_TypeChecker_Env.hasBinders_env + FStarC_Class_Binders.hasNames_comp + FStarC_Syntax_Print.pretty_comp + c4.FStarC_Syntax_Syntax.pos + "check_expected_effect.c.after_assume" env + c4; + (let uu___8 = + FStarC_Compiler_Debug.medium () in + if uu___8 + then + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term e in + let uu___10 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_comp c4 in + let uu___11 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_comp + expected_c in + let uu___12 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + use_eq in + FStarC_Compiler_Util.print4 + "In check_expected_effect, asking rel to solve the problem on e=(%s) and c=(%s), expected_c=(%s), and use_eq=%s\n" + uu___9 uu___10 uu___11 uu___12 + else ()); + (let uu___8 = + FStarC_TypeChecker_Util.check_comp env + use_eq e c4 expected_c in + match uu___8 with + | (e1, uu___9, g) -> + let g1 = + let uu___10 = + FStarC_TypeChecker_Env.get_range + env in + let uu___11 = + FStarC_Errors_Msg.mkmsg + "Could not prove post-condition" in + FStarC_TypeChecker_Util.label_guard + uu___10 uu___11 g in + ((let uu___11 = + FStarC_Compiler_Debug.medium () in + if uu___11 + then + let uu___12 = + FStarC_Compiler_Range_Ops.string_of_range + e1.FStarC_Syntax_Syntax.pos in + let uu___13 = + FStarC_TypeChecker_Rel.guard_to_string + env g1 in + FStarC_Compiler_Util.print2 + "(%s) DONE check_expected_effect;\n\tguard is: %s\n" + uu___12 uu___13 + else ()); + (let e2 = + FStarC_TypeChecker_Util.maybe_lift + env e1 + (FStarC_Syntax_Util.comp_effect_name + c4) + (FStarC_Syntax_Util.comp_effect_name + expected_c) + (FStarC_Syntax_Util.comp_result + c4) in + let uu___11 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g1 g_c in + (e2, expected_c, uu___11))))))))))) +let no_logical_guard : + 'uuuuu 'uuuuu1 . + FStarC_TypeChecker_Env.env -> + ('uuuuu * 'uuuuu1 * FStarC_TypeChecker_Env.guard_t) -> + ('uuuuu * 'uuuuu1 * FStarC_TypeChecker_Env.guard_t) + = + fun env -> + fun uu___ -> + match uu___ with + | (te, kt, f) -> + let uu___1 = FStarC_TypeChecker_Env.guard_form f in + (match uu___1 with + | FStarC_TypeChecker_Common.Trivial -> (te, kt, f) + | FStarC_TypeChecker_Common.NonTrivial f1 -> + FStarC_TypeChecker_Err.unexpected_non_trivial_precondition_on_term + env f1) +let (print_expected_ty_str : FStarC_TypeChecker_Env.env -> Prims.string) = + fun env -> + let uu___ = FStarC_TypeChecker_Env.expected_typ env in + match uu___ with + | FStar_Pervasives_Native.None -> "Expected type is None" + | FStar_Pervasives_Native.Some (t, use_eq) -> + let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + let uu___2 = FStarC_Compiler_Util.string_of_bool use_eq in + FStarC_Compiler_Util.format2 "Expected type is (%s, use_eq = %s)" + uu___1 uu___2 +let (print_expected_ty : FStarC_TypeChecker_Env.env -> unit) = + fun env -> + let uu___ = print_expected_ty_str env in + FStarC_Compiler_Util.print1 "%s\n" uu___ +let rec (get_pat_vars' : + FStarC_Syntax_Syntax.bv Prims.list -> + Prims.bool -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.bv FStarC_Compiler_FlatSet.t) + = + fun uu___2 -> + fun uu___1 -> + fun uu___ -> + (fun all -> + fun andlist -> + fun pats -> + let pats1 = FStarC_Syntax_Util.unmeta pats in + let uu___ = FStarC_Syntax_Util.head_and_args pats1 in + match uu___ with + | (head, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst head in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, uu___2) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.nil_lid + -> + Obj.magic + (Obj.repr + (if andlist + then + FStarC_Class_Setlike.from_list () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) all + else + FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) ())) + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (uu___2, FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = uu___3;_}):: + (hd, FStar_Pervasives_Native.None)::(tl, + FStar_Pervasives_Native.None)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.cons_lid + -> + Obj.magic + (Obj.repr + (let hdvs = get_pat_vars' all false hd in + let tlvs = get_pat_vars' all andlist tl in + if andlist + then + FStarC_Class_Setlike.inter () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) + (Obj.magic hdvs) (Obj.magic tlvs) + else + FStarC_Class_Setlike.union () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) + (Obj.magic hdvs) (Obj.magic tlvs))) + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (uu___2, FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = uu___3;_}):: + (pat, FStar_Pervasives_Native.None)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.smtpat_lid + -> + Obj.magic (Obj.repr (FStarC_Syntax_Free.names pat)) + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (subpats, FStar_Pervasives_Native.None)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.smtpatOr_lid + -> + Obj.magic (Obj.repr (get_pat_vars' all true subpats)) + | uu___2 -> + Obj.magic + (Obj.repr + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) ())))) + uu___2 uu___1 uu___ +let (get_pat_vars : + FStarC_Syntax_Syntax.bv Prims.list -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.bv FStarC_Compiler_FlatSet.t) + = fun all -> fun pats -> get_pat_vars' all false pats +let (check_pat_fvs : + FStarC_Compiler_Range_Type.range -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.binder Prims.list -> unit) + = + fun rng -> + fun env -> + fun pats -> + fun bs -> + let pat_vars = + let uu___ = + FStarC_Compiler_List.map + (fun b -> b.FStarC_Syntax_Syntax.binder_bv) bs in + let uu___1 = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Beta] env pats in + get_pat_vars uu___ uu___1 in + let uu___ = + FStarC_Compiler_Util.find_opt + (fun uu___1 -> + match uu___1 with + | { FStarC_Syntax_Syntax.binder_bv = b; + FStarC_Syntax_Syntax.binder_qual = uu___2; + FStarC_Syntax_Syntax.binder_positivity = uu___3; + FStarC_Syntax_Syntax.binder_attrs = uu___4;_} -> + let uu___5 = + FStarC_Class_Setlike.mem () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) b + (Obj.magic pat_vars) in + Prims.op_Negation uu___5) bs in + match uu___ with + | FStar_Pervasives_Native.None -> () + | FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.binder_bv = x; + FStarC_Syntax_Syntax.binder_qual = uu___1; + FStarC_Syntax_Syntax.binder_positivity = uu___2; + FStarC_Syntax_Syntax.binder_attrs = uu___3;_} + -> + let uu___4 = + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_bv x in + FStarC_Compiler_Util.format1 + "Pattern misses at least one bound variable: %s" uu___5 in + FStarC_Errors.log_issue FStarC_Class_HasRange.hasRange_range + rng FStarC_Errors_Codes.Warning_SMTPatternIllFormed () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4) +let (check_no_smt_theory_symbols : + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.term -> unit) = + fun en -> + fun t -> + let rec pat_terms t1 = + let t2 = FStarC_Syntax_Util.unmeta t1 in + let uu___ = FStarC_Syntax_Util.head_and_args t2 in + match uu___ with + | (head, args) -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst head in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + (match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, uu___2) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.nil_lid + -> [] + | (FStarC_Syntax_Syntax.Tm_fvar fv, + uu___2::(hd, uu___3)::(tl, uu___4)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.cons_lid + -> + let uu___5 = pat_terms hd in + let uu___6 = pat_terms tl in + FStarC_Compiler_List.op_At uu___5 uu___6 + | (FStarC_Syntax_Syntax.Tm_fvar fv, uu___2::(pat, uu___3)::[]) + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.smtpat_lid + -> [pat] + | (FStarC_Syntax_Syntax.Tm_fvar fv, + (subpats, FStar_Pervasives_Native.None)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.smtpatOr_lid + -> pat_terms subpats + | uu___2 -> []) in + let rec aux t1 = + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t1 in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_bvar uu___1 -> [] + | FStarC_Syntax_Syntax.Tm_name uu___1 -> [] + | FStarC_Syntax_Syntax.Tm_constant uu___1 -> [] + | FStarC_Syntax_Syntax.Tm_type uu___1 -> [] + | FStarC_Syntax_Syntax.Tm_uvar uu___1 -> [] + | FStarC_Syntax_Syntax.Tm_lazy uu___1 -> [] + | FStarC_Syntax_Syntax.Tm_unknown -> [] + | FStarC_Syntax_Syntax.Tm_abs uu___1 -> [t1] + | FStarC_Syntax_Syntax.Tm_arrow uu___1 -> [t1] + | FStarC_Syntax_Syntax.Tm_refine uu___1 -> [t1] + | FStarC_Syntax_Syntax.Tm_match uu___1 -> [t1] + | FStarC_Syntax_Syntax.Tm_let uu___1 -> [t1] + | FStarC_Syntax_Syntax.Tm_delayed uu___1 -> [t1] + | FStarC_Syntax_Syntax.Tm_quoted uu___1 -> [t1] + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let uu___1 = + FStarC_TypeChecker_Env.fv_has_attr en fv + FStarC_Parser_Const.smt_theory_symbol_attr_lid in + if uu___1 then [t1] else [] + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = t2; + FStarC_Syntax_Syntax.args = args;_} + -> + let uu___1 = aux t2 in + FStarC_Compiler_List.fold_left + (fun acc -> + fun uu___2 -> + match uu___2 with + | (t3, uu___3) -> + let uu___4 = aux t3 in + FStarC_Compiler_List.op_At acc uu___4) uu___1 args + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t2; + FStarC_Syntax_Syntax.asc = uu___1; + FStarC_Syntax_Syntax.eff_opt = uu___2;_} + -> aux t2 + | FStarC_Syntax_Syntax.Tm_uinst (t2, uu___1) -> aux t2 + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t2; + FStarC_Syntax_Syntax.meta = uu___1;_} + -> aux t2 in + let tlist = + let uu___ = pat_terms t in FStarC_Compiler_List.collect aux uu___ in + if (FStarC_Compiler_List.length tlist) = Prims.int_zero + then () + else + (let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Errors_Msg.text + "Pattern uses these theory symbols or terms that should not be in an SMT pattern:" in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Pprint.break_ Prims.int_one in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.comma uu___7 in + FStarC_Pprint.separate_map uu___6 + (FStarC_Class_PP.pp FStarC_Syntax_Print.pretty_term) tlist in + FStarC_Pprint.group uu___5 in + FStarC_Pprint.prefix (Prims.of_int (2)) Prims.int_one uu___3 + uu___4 in + [uu___2] in + FStarC_Errors.log_issue (FStarC_Syntax_Syntax.has_range_syntax ()) t + FStarC_Errors_Codes.Warning_SMTPatternIllFormed () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___1)) +let (check_smt_pat : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.binder Prims.list -> + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> unit) + = + fun env -> + fun t -> + fun bs -> + fun c -> + let uu___ = FStarC_Syntax_Util.is_smt_lemma t in + if uu___ + then + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Comp + { FStarC_Syntax_Syntax.comp_univs = uu___1; + FStarC_Syntax_Syntax.effect_name = uu___2; + FStarC_Syntax_Syntax.result_typ = uu___3; + FStarC_Syntax_Syntax.effect_args = + _pre::_post::(pats, uu___4)::[]; + FStarC_Syntax_Syntax.flags = uu___5;_} + -> + (check_pat_fvs t.FStarC_Syntax_Syntax.pos env pats bs; + check_no_smt_theory_symbols env pats) + | uu___1 -> failwith "Impossible: check_smt_pat: not Comp" + else () +let (guard_letrecs : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> + (FStarC_Syntax_Syntax.lbname * FStarC_Syntax_Syntax.typ * + FStarC_Syntax_Syntax.univ_names) Prims.list) + = + fun env -> + fun actuals -> + fun expected_c -> + match env.FStarC_TypeChecker_Env.letrecs with + | [] -> [] + | letrecs -> + let r = FStarC_TypeChecker_Env.get_range env in + let env1 = + { + FStarC_TypeChecker_Env.solver = + (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = []; + FStarC_TypeChecker_Env.top_level = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env.FStarC_TypeChecker_Env.missing_decl) + } in + let decreases_clause bs c = + (let uu___1 = FStarC_Compiler_Debug.low () in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binder) bs in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_comp c in + FStarC_Compiler_Util.print2 + "Building a decreases clause over (%s) and %s\n" uu___2 + uu___3 + else ()); + (let filter_types_and_functions bs1 = + let uu___1 = + FStarC_Compiler_List.fold_left + (fun uu___2 -> + fun binder -> + match uu___2 with + | (out, env2) -> + let b = binder.FStarC_Syntax_Syntax.binder_bv in + let t = + let uu___3 = + FStarC_Syntax_Util.unrefine + b.FStarC_Syntax_Syntax.sort in + FStarC_TypeChecker_Normalize.unfold_whnf env2 + uu___3 in + let env3 = + FStarC_TypeChecker_Env.push_binders env2 + [binder] in + (match t.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_type uu___3 -> + (out, env3) + | FStarC_Syntax_Syntax.Tm_arrow uu___3 -> + (out, env3) + | uu___3 -> + let arg = + FStarC_Syntax_Syntax.bv_to_name b in + let arg1 = + let uu___4 = + FStarC_Syntax_Util.is_erased_head t in + match uu___4 with + | FStar_Pervasives_Native.Some (u, ty) + -> + FStarC_Syntax_Util.apply_reveal u ty + arg + | uu___5 -> arg in + ((arg1 :: out), env3))) ([], env1) bs1 in + match uu___1 with + | (out_rev, env2) -> FStarC_Compiler_List.rev out_rev in + let cflags = FStarC_Syntax_Util.comp_flags c in + let uu___1 = + FStarC_Compiler_List.tryFind + (fun uu___2 -> + match uu___2 with + | FStarC_Syntax_Syntax.DECREASES uu___3 -> true + | uu___3 -> false) cflags in + match uu___1 with + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.DECREASES + d) -> d + | uu___2 -> + let uu___3 = filter_types_and_functions bs in + FStarC_Syntax_Syntax.Decreases_lex uu___3) in + let precedes_t = + FStarC_TypeChecker_Util.fvar_env env1 + FStarC_Parser_Const.precedes_lid in + let rec mk_precedes_lex env2 l l_prev = + let rec aux l1 l_prev1 = + let type_of should_warn e1 e2 = + let t1 = + let uu___ = + let uu___1 = + env2.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + env2 e1 false in + FStar_Pervasives_Native.fst uu___1 in + FStarC_Syntax_Util.unrefine uu___ in + let t2 = + let uu___ = + let uu___1 = + env2.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + env2 e2 false in + FStar_Pervasives_Native.fst uu___1 in + FStarC_Syntax_Util.unrefine uu___ in + let rec warn t11 t21 = + let uu___ = + let uu___1 = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm env2 t11 + t21 in + uu___1 = FStarC_TypeChecker_TermEqAndSimplify.Equal in + if uu___ + then false + else + (let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.compress t11 in + uu___4.FStarC_Syntax_Syntax.n in + let uu___4 = + let uu___5 = FStarC_Syntax_Subst.compress t21 in + uu___5.FStarC_Syntax_Syntax.n in + (uu___3, uu___4) in + match uu___2 with + | (FStarC_Syntax_Syntax.Tm_uinst (t12, uu___3), + FStarC_Syntax_Syntax.Tm_uinst (t22, uu___4)) -> + warn t12 t22 + | (FStarC_Syntax_Syntax.Tm_name uu___3, + FStarC_Syntax_Syntax.Tm_name uu___4) -> false + | (FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = h1; + FStarC_Syntax_Syntax.args = args1;_}, + FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = h2; + FStarC_Syntax_Syntax.args = args2;_}) + -> + ((warn h1 h2) || + ((FStarC_Compiler_List.length args1) <> + (FStarC_Compiler_List.length args2))) + || + (let uu___3 = + FStarC_Compiler_List.zip args1 args2 in + FStarC_Compiler_List.existsML + (fun uu___4 -> + match uu___4 with + | ((a1, uu___5), (a2, uu___6)) -> + warn a1 a2) uu___3) + | (FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = t12; + FStarC_Syntax_Syntax.phi = phi1;_}, + FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = t22; + FStarC_Syntax_Syntax.phi = phi2;_}) + -> + (warn t12.FStarC_Syntax_Syntax.sort + t22.FStarC_Syntax_Syntax.sort) + || (warn phi1 phi2) + | (FStarC_Syntax_Syntax.Tm_uvar uu___3, uu___4) -> + false + | (uu___3, FStarC_Syntax_Syntax.Tm_uvar uu___4) -> + false + | (uu___3, uu___4) -> true) in + (let uu___1 = + ((Prims.op_Negation env2.FStarC_TypeChecker_Env.phase1) + && should_warn) + && (warn t1 t2) in + if uu___1 + then + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.compress t1 in + uu___4.FStarC_Syntax_Syntax.n in + let uu___4 = + let uu___5 = FStarC_Syntax_Subst.compress t2 in + uu___5.FStarC_Syntax_Syntax.n in + (uu___3, uu___4) in + match uu___2 with + | (FStarC_Syntax_Syntax.Tm_name uu___3, + FStarC_Syntax_Syntax.Tm_name uu___4) -> () + | (uu___3, uu___4) -> + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Errors_Msg.text + "In the decreases clause for this function, the SMT solver may not be able to prove that the types of" in + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_term e1 in + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_Errors_Msg.text "bound in" in + let uu___15 = + FStarC_Class_PP.pp + FStarC_Compiler_Range_Ops.pretty_range + e1.FStarC_Syntax_Syntax.pos in + FStarC_Pprint.op_Hat_Slash_Hat uu___14 + uu___15 in + FStarC_Pprint.parens uu___13 in + FStarC_Pprint.op_Hat_Slash_Hat uu___11 + uu___12 in + FStarC_Pprint.group uu___10 in + FStarC_Pprint.prefix (Prims.of_int (2)) + Prims.int_one uu___8 uu___9 in + let uu___8 = + let uu___9 = + let uu___10 = FStarC_Errors_Msg.text "and" in + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_term e2 in + let uu___14 = + let uu___15 = + let uu___16 = + FStarC_Errors_Msg.text "bound in" in + let uu___17 = + FStarC_Class_PP.pp + FStarC_Compiler_Range_Ops.pretty_range + e2.FStarC_Syntax_Syntax.pos in + FStarC_Pprint.op_Hat_Slash_Hat + uu___16 uu___17 in + FStarC_Pprint.parens uu___15 in + FStarC_Pprint.op_Hat_Slash_Hat uu___13 + uu___14 in + FStarC_Pprint.group uu___12 in + FStarC_Pprint.prefix (Prims.of_int (2)) + Prims.int_one uu___10 uu___11 in + let uu___10 = + FStarC_Errors_Msg.text "are equal." in + FStarC_Pprint.op_Hat_Slash_Hat uu___9 uu___10 in + FStarC_Pprint.op_Hat_Slash_Hat uu___7 uu___8 in + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Errors_Msg.text + "The type of the first term is:" in + let uu___10 = + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_term t1 in + FStarC_Pprint.prefix (Prims.of_int (2)) + Prims.int_one uu___9 uu___10 in + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Errors_Msg.text + "The type of the second term is:" in + let uu___12 = + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_term t2 in + FStarC_Pprint.prefix (Prims.of_int (2)) + Prims.int_one uu___11 uu___12 in + let uu___11 = + let uu___12 = + FStarC_Errors_Msg.text + "If the proof fails, try annotating these with the same type." in + [uu___12] in + uu___10 :: uu___11 in + uu___8 :: uu___9 in + uu___6 :: uu___7 in + FStarC_Errors.log_issue + (FStarC_Syntax_Syntax.has_range_syntax ()) e1 + FStarC_Errors_Codes.Warning_Defensive () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___5) + else ()); + (t1, t2) in + match (l1, l_prev1) with + | ([], []) -> + let uu___ = + let uu___1 = + FStarC_Syntax_Syntax.as_arg + FStarC_Syntax_Syntax.unit_const in + let uu___2 = + let uu___3 = + FStarC_Syntax_Syntax.as_arg + FStarC_Syntax_Syntax.unit_const in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app precedes_t uu___ r + | (x::[], x_prev::[]) -> + let uu___ = type_of false x x_prev in + (match uu___ with + | (t_x, t_x_prev) -> + let uu___1 = + let uu___2 = FStarC_Syntax_Syntax.iarg t_x in + let uu___3 = + let uu___4 = FStarC_Syntax_Syntax.iarg t_x_prev in + let uu___5 = + let uu___6 = FStarC_Syntax_Syntax.as_arg x in + let uu___7 = + let uu___8 = + FStarC_Syntax_Syntax.as_arg x_prev in + [uu___8] in + uu___6 :: uu___7 in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + FStarC_Syntax_Syntax.mk_Tm_app precedes_t uu___1 r) + | (x::tl, x_prev::tl_prev) -> + let uu___ = type_of true x x_prev in + (match uu___ with + | (t_x, t_x_prev) -> + let tm_precedes = + let uu___1 = + let uu___2 = FStarC_Syntax_Syntax.iarg t_x in + let uu___3 = + let uu___4 = + FStarC_Syntax_Syntax.iarg t_x_prev in + let uu___5 = + let uu___6 = FStarC_Syntax_Syntax.as_arg x in + let uu___7 = + let uu___8 = + FStarC_Syntax_Syntax.as_arg x_prev in + [uu___8] in + uu___6 :: uu___7 in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + FStarC_Syntax_Syntax.mk_Tm_app precedes_t uu___1 r in + let eq3_x_x_prev = + FStarC_Syntax_Util.mk_eq3_no_univ t_x t_x_prev x + x_prev in + let uu___1 = + let uu___2 = aux tl tl_prev in + FStarC_Syntax_Util.mk_conj eq3_x_x_prev uu___2 in + FStarC_Syntax_Util.mk_disj tm_precedes uu___1) in + let uu___ = + let uu___1 = + ((FStarC_Compiler_List.length l), + (FStarC_Compiler_List.length l_prev)) in + match uu___1 with + | (n, n_prev) -> + if n = n_prev + then (l, l_prev) + else + if n < n_prev + then + (let uu___3 = + let uu___4 = FStarC_Compiler_List.splitAt n l_prev in + FStar_Pervasives_Native.fst uu___4 in + (l, uu___3)) + else + (let uu___4 = + let uu___5 = FStarC_Compiler_List.splitAt n_prev l in + FStar_Pervasives_Native.fst uu___5 in + (uu___4, l_prev)) in + match uu___ with | (l1, l_prev1) -> aux l1 l_prev1 in + let mk_precedes env2 d d_prev = + match (d, d_prev) with + | (FStarC_Syntax_Syntax.Decreases_lex l, + FStarC_Syntax_Syntax.Decreases_lex l_prev) -> + mk_precedes_lex env2 l l_prev + | (FStarC_Syntax_Syntax.Decreases_wf (rel, e), + FStarC_Syntax_Syntax.Decreases_wf (rel_prev, e_prev)) -> + let rel_guard = + let uu___ = + let uu___1 = FStarC_Syntax_Syntax.as_arg e in + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.as_arg e_prev in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app rel uu___ r in + let uu___ = + let uu___1 = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm env2 rel + rel_prev in + uu___1 = FStarC_TypeChecker_TermEqAndSimplify.Equal in + if uu___ + then rel_guard + else + (let uu___2 = + FStarC_Errors.with_ctx + "Typechecking decreases well-founded relation" + (fun uu___3 -> + env2.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + env2 rel false) in + match uu___2 with + | (t_rel, uu___3) -> + let uu___4 = + FStarC_Errors.with_ctx + "Typechecking previous decreases well-founded relation" + (fun uu___5 -> + env2.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + env2 rel_prev false) in + (match uu___4 with + | (t_rel_prev, uu___5) -> + let eq_guard = + FStarC_Syntax_Util.mk_eq3_no_univ t_rel + t_rel_prev rel rel_prev in + FStarC_Syntax_Util.mk_conj eq_guard rel_guard)) + | (uu___, uu___1) -> + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_UnexpectedTerm () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Cannot build termination VC with a well-founded relation and lex ordering") in + let previous_dec = decreases_clause actuals expected_c in + let guard_one_letrec uu___ = + match uu___ with + | (l, arity, t, u_names) -> + let uu___1 = + FStarC_TypeChecker_Normalize.get_n_binders env1 arity t in + (match uu___1 with + | (formals, c) -> + (if arity > (FStarC_Compiler_List.length formals) + then + failwith + "impossible: bad formals arity, guard_one_letrec" + else (); + (let formals1 = + FStarC_Compiler_List.map + (fun b -> + let uu___3 = + FStarC_Syntax_Syntax.is_null_bv + b.FStarC_Syntax_Syntax.binder_bv in + if uu___3 + then + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.range_of_bv + b.FStarC_Syntax_Syntax.binder_bv in + FStar_Pervasives_Native.Some uu___6 in + FStarC_Syntax_Syntax.new_bv uu___5 + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + { + FStarC_Syntax_Syntax.binder_bv = uu___4; + FStarC_Syntax_Syntax.binder_qual = + (b.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity = + (b.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs = + (b.FStarC_Syntax_Syntax.binder_attrs) + } + else b) formals in + let dec = decreases_clause formals1 c in + let precedes = + let env2 = + FStarC_TypeChecker_Env.push_binders env1 + formals1 in + mk_precedes env2 dec previous_dec in + let precedes1 = + let uu___3 = + FStarC_Errors_Msg.mkmsg + "Could not prove termination of this recursive call" in + FStarC_TypeChecker_Util.label uu___3 r precedes in + let uu___3 = FStarC_Compiler_Util.prefix formals1 in + match uu___3 with + | (bs, + { FStarC_Syntax_Syntax.binder_bv = last; + FStarC_Syntax_Syntax.binder_qual = imp; + FStarC_Syntax_Syntax.binder_positivity = pqual; + FStarC_Syntax_Syntax.binder_attrs = attrs;_}) + -> + let last1 = + let uu___4 = + FStarC_Syntax_Util.refine last precedes1 in + { + FStarC_Syntax_Syntax.ppname = + (last.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (last.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = uu___4 + } in + let refined_formals = + let uu___4 = + let uu___5 = + FStarC_Syntax_Syntax.mk_binder_with_attrs + last1 imp pqual attrs in + [uu___5] in + FStarC_Compiler_List.op_At bs uu___4 in + let t' = + FStarC_Syntax_Util.arrow refined_formals c in + ((let uu___5 = FStarC_Compiler_Debug.medium () in + if uu___5 + then + let uu___6 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_either + FStarC_Syntax_Print.showable_bv + FStarC_Syntax_Print.showable_fv) l in + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t' in + FStarC_Compiler_Util.print3 + "Refined let rec %s\n\tfrom type %s\n\tto type %s\n" + uu___6 uu___7 uu___8 + else ()); + (l, t', u_names))))) in + FStarC_Compiler_List.map guard_one_letrec letrecs +let (wrap_guard_with_tactic_opt : + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option -> + FStarC_TypeChecker_Env.guard_t -> FStarC_TypeChecker_Env.guard_t) + = + fun topt -> + fun g -> + match topt with + | FStar_Pervasives_Native.None -> g + | FStar_Pervasives_Native.Some tactic -> + FStarC_TypeChecker_Env.always_map_guard g + (fun g1 -> + let uu___ = + FStarC_Syntax_Util.mk_squash FStarC_Syntax_Syntax.U_zero g1 in + FStarC_TypeChecker_Common.mk_by_tactic tactic uu___) +let (is_comp_ascribed_reflect : + FStarC_Syntax_Syntax.term -> + (FStarC_Ident.lident * FStarC_Syntax_Syntax.term * + FStarC_Syntax_Syntax.aqual) FStar_Pervasives_Native.option) + = + fun e -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress e in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = e1; + FStarC_Syntax_Syntax.asc = + (FStar_Pervasives.Inr uu___1, uu___2, uu___3); + FStarC_Syntax_Syntax.eff_opt = uu___4;_} + -> + let uu___5 = + let uu___6 = FStarC_Syntax_Subst.compress e1 in + uu___6.FStarC_Syntax_Syntax.n in + (match uu___5 with + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = args;_} + when (FStarC_Compiler_List.length args) = Prims.int_one -> + let uu___6 = + let uu___7 = FStarC_Syntax_Subst.compress head in + uu___7.FStarC_Syntax_Syntax.n in + (match uu___6 with + | FStarC_Syntax_Syntax.Tm_constant (FStarC_Const.Const_reflect + l) -> + let uu___7 = + let uu___8 = FStarC_Compiler_List.hd args in + match uu___8 with | (e2, aqual) -> (l, e2, aqual) in + FStar_Pervasives_Native.Some uu___7 + | uu___7 -> FStar_Pervasives_Native.None) + | uu___6 -> FStar_Pervasives_Native.None) + | uu___1 -> FStar_Pervasives_Native.None +let rec (tc_term : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.lcomp * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun e -> + FStarC_Defensive.def_check_scoped FStarC_TypeChecker_Env.hasBinders_env + FStarC_Class_Binders.hasNames_term FStarC_Syntax_Print.pretty_term + e.FStarC_Syntax_Syntax.pos "tc_term.entry" env e; + (let uu___2 = FStarC_Compiler_Debug.medium () in + if uu___2 + then + let uu___3 = + let uu___4 = FStarC_TypeChecker_Env.get_range env in + FStarC_Compiler_Range_Ops.string_of_range uu___4 in + let uu___4 = + FStarC_Compiler_Util.string_of_bool + env.FStarC_TypeChecker_Env.phase1 in + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + let uu___6 = + let uu___7 = FStarC_Syntax_Subst.compress e in + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term uu___7 in + let uu___7 = print_expected_ty_str env in + FStarC_Compiler_Util.print5 + "(%s) Starting tc_term (phase1=%s) of %s (%s), %s {\n" uu___3 + uu___4 uu___5 uu___6 uu___7 + else ()); + (let uu___2 = + FStarC_Compiler_Util.record_time + (fun uu___3 -> + tc_maybe_toplevel_term + { + FStarC_TypeChecker_Env.solver = + (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = false; + FStarC_TypeChecker_Env.check_uvars = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env.FStarC_TypeChecker_Env.missing_decl) + } e) in + match uu___2 with + | (r, ms) -> + ((let uu___4 = FStarC_Compiler_Debug.medium () in + if uu___4 + then + ((let uu___6 = + let uu___7 = FStarC_TypeChecker_Env.get_range env in + FStarC_Compiler_Range_Ops.string_of_range uu___7 in + let uu___7 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + let uu___8 = + let uu___9 = FStarC_Syntax_Subst.compress e in + FStarC_Class_Tagged.tag_of + FStarC_Syntax_Syntax.tagged_term uu___9 in + let uu___9 = FStarC_Compiler_Util.string_of_int ms in + FStarC_Compiler_Util.print4 + "(%s) } tc_term of %s (%s) took %sms\n" uu___6 uu___7 + uu___8 uu___9); + (let uu___6 = r in + match uu___6 with + | (e1, lc, uu___7) -> + let uu___8 = + let uu___9 = FStarC_TypeChecker_Env.get_range env in + FStarC_Compiler_Range_Ops.string_of_range uu___9 in + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term e1 in + let uu___10 = + FStarC_TypeChecker_Common.lcomp_to_string lc in + let uu___11 = + let uu___12 = FStarC_Syntax_Subst.compress e1 in + FStarC_Class_Tagged.tag_of + FStarC_Syntax_Syntax.tagged_term uu___12 in + FStarC_Compiler_Util.print4 + "(%s) Result is: (%s:%s) (%s)\n" uu___8 uu___9 uu___10 + uu___11)) + else ()); + r)) +and (tc_maybe_toplevel_term : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.lcomp * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun e -> + let env1 = + if e.FStarC_Syntax_Syntax.pos = FStarC_Compiler_Range_Type.dummyRange + then env + else FStarC_TypeChecker_Env.set_range env e.FStarC_Syntax_Syntax.pos in + FStarC_Defensive.def_check_scoped FStarC_TypeChecker_Env.hasBinders_env + FStarC_Class_Binders.hasNames_term FStarC_Syntax_Print.pretty_term + e.FStarC_Syntax_Syntax.pos "tc_maybe_toplevel_term.entry" env1 e; + (let top = FStarC_Syntax_Subst.compress e in + (let uu___2 = FStarC_Compiler_Debug.medium () in + if uu___2 + then + let uu___3 = + let uu___4 = FStarC_TypeChecker_Env.get_range env1 in + FStarC_Class_Show.show FStarC_Compiler_Range_Ops.showable_range + uu___4 in + let uu___4 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term top in + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term top in + FStarC_Compiler_Util.print3 "Typechecking %s (%s): %s\n" uu___3 + uu___4 uu___5 + else ()); + (match top.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_delayed uu___2 -> failwith "Impossible" + | FStarC_Syntax_Syntax.Tm_bvar uu___2 -> + failwith "Impossible: tc_maybe_toplevel_term: not LN" + | FStarC_Syntax_Syntax.Tm_uinst uu___2 -> tc_value env1 e + | FStarC_Syntax_Syntax.Tm_uvar uu___2 -> tc_value env1 e + | FStarC_Syntax_Syntax.Tm_name uu___2 -> tc_value env1 e + | FStarC_Syntax_Syntax.Tm_fvar uu___2 -> tc_value env1 e + | FStarC_Syntax_Syntax.Tm_constant uu___2 -> tc_value env1 e + | FStarC_Syntax_Syntax.Tm_abs uu___2 -> tc_value env1 e + | FStarC_Syntax_Syntax.Tm_arrow uu___2 -> tc_value env1 e + | FStarC_Syntax_Syntax.Tm_refine uu___2 -> tc_value env1 e + | FStarC_Syntax_Syntax.Tm_type uu___2 -> tc_value env1 e + | FStarC_Syntax_Syntax.Tm_unknown -> tc_value env1 e + | FStarC_Syntax_Syntax.Tm_quoted (qt, qi) -> + let projl uu___2 = + match uu___2 with + | FStar_Pervasives.Inl x -> x + | FStar_Pervasives.Inr uu___3 -> failwith "projl fail" in + let non_trivial_antiquotations qi1 = + let is_not_name t = + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress t in + uu___3.FStarC_Syntax_Syntax.n in + match uu___2 with + | FStarC_Syntax_Syntax.Tm_name uu___3 -> false + | uu___3 -> true in + FStarC_Compiler_Util.for_some is_not_name + (FStar_Pervasives_Native.snd + qi1.FStarC_Syntax_Syntax.antiquotations) in + (match qi.FStarC_Syntax_Syntax.qkind with + | FStarC_Syntax_Syntax.Quote_static when + non_trivial_antiquotations qi -> + let e0 = e in + let newbvs = + FStarC_Compiler_List.map + (fun uu___2 -> + FStarC_Syntax_Syntax.new_bv + FStar_Pervasives_Native.None + FStarC_Syntax_Syntax.t_term) + (FStar_Pervasives_Native.snd + qi.FStarC_Syntax_Syntax.antiquotations) in + let z = + FStarC_Compiler_List.zip + (FStar_Pervasives_Native.snd + qi.FStarC_Syntax_Syntax.antiquotations) newbvs in + let lbs = + FStarC_Compiler_List.map + (fun uu___2 -> + match uu___2 with + | (t, bv') -> + FStarC_Syntax_Util.close_univs_and_mk_letbinding + FStar_Pervasives_Native.None + (FStar_Pervasives.Inl bv') [] + FStarC_Syntax_Syntax.t_term + FStarC_Parser_Const.effect_Tot_lid t [] + t.FStarC_Syntax_Syntax.pos) z in + let qi1 = + let uu___2 = + let uu___3 = + FStarC_Compiler_List.map + (fun uu___4 -> + match uu___4 with + | (t, bv') -> FStarC_Syntax_Syntax.bv_to_name bv') + z in + (Prims.int_zero, uu___3) in + { + FStarC_Syntax_Syntax.qkind = + (qi.FStarC_Syntax_Syntax.qkind); + FStarC_Syntax_Syntax.antiquotations = uu___2 + } in + let nq = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_quoted (qt, qi1)) + top.FStarC_Syntax_Syntax.pos in + let e1 = + FStarC_Compiler_List.fold_left + (fun t -> + fun lb -> + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + projl lb.FStarC_Syntax_Syntax.lbname in + FStarC_Syntax_Syntax.mk_binder uu___7 in + [uu___6] in + FStarC_Syntax_Subst.close uu___5 t in + { + FStarC_Syntax_Syntax.lbs = (false, [lb]); + FStarC_Syntax_Syntax.body1 = uu___4 + } in + FStarC_Syntax_Syntax.Tm_let uu___3 in + FStarC_Syntax_Syntax.mk uu___2 + top.FStarC_Syntax_Syntax.pos) nq lbs in + tc_maybe_toplevel_term env1 e1 + | FStarC_Syntax_Syntax.Quote_static -> + let aqs = + FStar_Pervasives_Native.snd + qi.FStarC_Syntax_Syntax.antiquotations in + let env_tm = + FStarC_TypeChecker_Env.set_expected_typ env1 + FStarC_Syntax_Syntax.t_term in + let uu___2 = + FStarC_Compiler_List.fold_left + (fun uu___3 -> + fun aq_tm -> + match uu___3 with + | (aqs_rev, guard, env_tm1) -> + let uu___4 = tc_term env_tm1 aq_tm in + (match uu___4 with + | (aq_tm1, uu___5, g) -> + let env_tm2 = + let uu___6 = + FStarC_Syntax_Syntax.new_bv + FStar_Pervasives_Native.None + FStarC_Syntax_Syntax.t_term in + FStarC_TypeChecker_Env.push_bv env_tm1 + uu___6 in + let uu___6 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g guard in + ((aq_tm1 :: aqs_rev), uu___6, env_tm2))) + ([], + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t), env_tm) + aqs in + (match uu___2 with + | (aqs_rev, guard, _env) -> + let qi1 = + { + FStarC_Syntax_Syntax.qkind = + (qi.FStarC_Syntax_Syntax.qkind); + FStarC_Syntax_Syntax.antiquotations = + (Prims.int_zero, + (FStarC_Compiler_List.rev aqs_rev)) + } in + let tm = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_quoted (qt, qi1)) + top.FStarC_Syntax_Syntax.pos in + value_check_expected_typ env1 tm + (FStar_Pervasives.Inl FStarC_Syntax_Syntax.t_term) + guard) + | FStarC_Syntax_Syntax.Quote_dynamic -> + let c = + FStarC_Syntax_Syntax.mk_Tac FStarC_Syntax_Syntax.t_term in + let uu___2 = FStarC_TypeChecker_Env.clear_expected_typ env1 in + (match uu___2 with + | (env', uu___3) -> + let env'1 = + { + FStarC_TypeChecker_Env.solver = + (env'.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env'.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env'.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env'.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env'.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env'.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env'.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env'.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env'.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env'.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env'.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env'.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env'.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env'.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env'.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env'.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env'.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env'.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = true; + FStarC_TypeChecker_Env.lax_universes = + (env'.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env'.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env'.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env'.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env'.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env'.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env'.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env'.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env'.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env'.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env'.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env'.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env'.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env'.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env'.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env'.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env'.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env'.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env'.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env'.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env'.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env'.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env'.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env'.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env'.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env'.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env'.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env'.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env'.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env'.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env'.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env'.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env'.FStarC_TypeChecker_Env.missing_decl) + } in + let uu___4 = tc_term env'1 qt in + (match uu___4 with + | (qt1, uu___5, g) -> + let g0 = + { + FStarC_TypeChecker_Common.guard_f = + FStarC_TypeChecker_Common.Trivial; + FStarC_TypeChecker_Common.deferred_to_tac = + (g.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (g.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (g.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = + (g.FStarC_TypeChecker_Common.implicits) + } in + let g01 = + FStarC_TypeChecker_Rel.resolve_implicits env'1 + g0 in + let t = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_quoted (qt1, qi)) + top.FStarC_Syntax_Syntax.pos in + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_TypeChecker_Common.lcomp_of_comp c in + FStar_Pervasives.Inr uu___8 in + value_check_expected_typ env1 t uu___7 + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t) in + (match uu___6 with + | (t1, lc, g1) -> + let t2 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 = t1; + FStarC_Syntax_Syntax.meta = + (FStarC_Syntax_Syntax.Meta_monadic_lift + (FStarC_Parser_Const.effect_PURE_lid, + FStarC_Parser_Const.effect_TAC_lid, + FStarC_Syntax_Syntax.t_term)) + }) t1.FStarC_Syntax_Syntax.pos in + let uu___7 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g1 g01 in + (t2, lc, uu___7))))) + | FStarC_Syntax_Syntax.Tm_lazy + { FStarC_Syntax_Syntax.blob = uu___2; + FStarC_Syntax_Syntax.lkind = + FStarC_Syntax_Syntax.Lazy_embedding uu___3; + FStarC_Syntax_Syntax.ltyp = uu___4; + FStarC_Syntax_Syntax.rng = uu___5;_} + -> + let uu___6 = FStarC_Syntax_Util.unlazy top in tc_term env1 uu___6 + | FStarC_Syntax_Syntax.Tm_lazy i -> + value_check_expected_typ env1 top + (FStar_Pervasives.Inl (i.FStarC_Syntax_Syntax.ltyp)) + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t) + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = e1; + FStarC_Syntax_Syntax.meta = FStarC_Syntax_Syntax.Meta_desugared + (FStarC_Syntax_Syntax.Meta_smt_pat);_} + -> + let uu___2 = tc_tot_or_gtot_term env1 e1 in + (match uu___2 with + | (e2, c, g) -> + let g1 = + { + FStarC_TypeChecker_Common.guard_f = + FStarC_TypeChecker_Common.Trivial; + FStarC_TypeChecker_Common.deferred_to_tac = + (g.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (g.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (g.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = + (g.FStarC_TypeChecker_Common.implicits) + } in + let uu___3 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 = e2; + FStarC_Syntax_Syntax.meta = + (FStarC_Syntax_Syntax.Meta_desugared + FStarC_Syntax_Syntax.Meta_smt_pat) + }) top.FStarC_Syntax_Syntax.pos in + (uu___3, c, g1)) + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = e1; + FStarC_Syntax_Syntax.meta = FStarC_Syntax_Syntax.Meta_pattern + (names, pats);_} + -> + let uu___2 = FStarC_Syntax_Util.type_u () in + (match uu___2 with + | (t, u) -> + let uu___3 = + tc_check_tot_or_gtot_term env1 e1 t + FStar_Pervasives_Native.None in + (match uu___3 with + | (e2, c, g) -> + let uu___4 = + let uu___5 = + FStarC_TypeChecker_Env.clear_expected_typ env1 in + match uu___5 with + | (env2, uu___6) -> tc_smt_pats env2 pats in + (match uu___4 with + | (pats1, g') -> + let g'1 = + { + FStarC_TypeChecker_Common.guard_f = + FStarC_TypeChecker_Common.Trivial; + FStarC_TypeChecker_Common.deferred_to_tac = + (g'.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (g'.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (g'.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = + (g'.FStarC_TypeChecker_Common.implicits) + } in + let uu___5 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 = e2; + FStarC_Syntax_Syntax.meta = + (FStarC_Syntax_Syntax.Meta_pattern + (names, pats1)) + }) top.FStarC_Syntax_Syntax.pos in + let uu___6 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t g g'1 in + (uu___5, c, uu___6)))) + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = e1; + FStarC_Syntax_Syntax.meta = FStarC_Syntax_Syntax.Meta_desugared + (FStarC_Syntax_Syntax.Sequence);_} + -> + let uu___2 = tc_term env1 e1 in + (match uu___2 with + | (e2, c, g) -> + let e3 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 = e2; + FStarC_Syntax_Syntax.meta = + (FStarC_Syntax_Syntax.Meta_desugared + FStarC_Syntax_Syntax.Sequence) + }) top.FStarC_Syntax_Syntax.pos in + (e3, c, g)) + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = e1; + FStarC_Syntax_Syntax.meta = FStarC_Syntax_Syntax.Meta_monadic + uu___2;_} + -> tc_term env1 e1 + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = e1; + FStarC_Syntax_Syntax.meta = + FStarC_Syntax_Syntax.Meta_monadic_lift uu___2;_} + -> tc_term env1 e1 + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = e1; FStarC_Syntax_Syntax.meta = m;_} + -> + let uu___2 = tc_term env1 e1 in + (match uu___2 with + | (e2, c, g) -> + let e3 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 = e2; + FStarC_Syntax_Syntax.meta = m + }) top.FStarC_Syntax_Syntax.pos in + (e3, c, g)) + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = e1; + FStarC_Syntax_Syntax.asc = + (asc, FStar_Pervasives_Native.Some tac, use_eq); + FStarC_Syntax_Syntax.eff_opt = labopt;_} + -> + let uu___2 = + tc_tactic FStarC_Syntax_Syntax.t_unit + FStarC_Syntax_Syntax.t_unit env1 tac in + (match uu___2 with + | (tac1, uu___3, g_tac) -> + let t' = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_ascribed + { + FStarC_Syntax_Syntax.tm = e1; + FStarC_Syntax_Syntax.asc = + (asc, FStar_Pervasives_Native.None, use_eq); + FStarC_Syntax_Syntax.eff_opt = labopt + }) top.FStarC_Syntax_Syntax.pos in + let uu___4 = tc_term env1 t' in + (match uu___4 with + | (t'1, c, g) -> + let t'2 = + let uu___5 = + let uu___6 = FStarC_Syntax_Subst.compress t'1 in + uu___6.FStarC_Syntax_Syntax.n in + match uu___5 with + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = e2; + FStarC_Syntax_Syntax.asc = + (asc1, FStar_Pervasives_Native.None, _use_eq); + FStarC_Syntax_Syntax.eff_opt = labopt1;_} + -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_ascribed + { + FStarC_Syntax_Syntax.tm = e2; + FStarC_Syntax_Syntax.asc = + (asc1, + (FStar_Pervasives_Native.Some tac1), + use_eq); + FStarC_Syntax_Syntax.eff_opt = labopt1 + }) t'1.FStarC_Syntax_Syntax.pos + | uu___6 -> failwith "impossible" in + let g1 = + wrap_guard_with_tactic_opt + (FStar_Pervasives_Native.Some tac1) g in + let uu___5 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t g1 g_tac in + (t'2, c, uu___5))) + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = uu___2; + FStarC_Syntax_Syntax.asc = + (FStar_Pervasives.Inr expected_c, + FStar_Pervasives_Native.None, use_eq); + FStarC_Syntax_Syntax.eff_opt = uu___3;_} + when + let uu___4 = is_comp_ascribed_reflect top in + FStarC_Compiler_Util.is_some uu___4 -> + let uu___4 = + let uu___5 = is_comp_ascribed_reflect top in + FStarC_Compiler_Util.must uu___5 in + (match uu___4 with + | (effect_lid, e1, aqual) -> + let uu___5 = FStarC_TypeChecker_Env.clear_expected_typ env1 in + (match uu___5 with + | (env0, uu___6) -> + let uu___7 = tc_comp env0 expected_c in + (match uu___7 with + | (expected_c1, uu___8, g_c) -> + let expected_ct = + FStarC_TypeChecker_Env.unfold_effect_abbrev env0 + expected_c1 in + ((let uu___10 = + let uu___11 = + FStarC_Ident.lid_equals effect_lid + expected_ct.FStarC_Syntax_Syntax.effect_name in + Prims.op_Negation uu___11 in + if uu___10 + then + let uu___11 = + let uu___12 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident effect_lid in + let uu___13 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + expected_ct.FStarC_Syntax_Syntax.effect_name in + FStarC_Compiler_Util.format2 + "The effect on reflect %s does not match with the annotation %s\n" + uu___12 uu___13 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) + top + FStarC_Errors_Codes.Fatal_UnexpectedEffect + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___11) + else ()); + (let uu___11 = + let uu___12 = + FStarC_TypeChecker_Env.is_user_reflectable_effect + env1 effect_lid in + Prims.op_Negation uu___12 in + if uu___11 + then + let uu___12 = + let uu___13 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident effect_lid in + FStarC_Compiler_Util.format1 + "Effect %s cannot be reflected" uu___13 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) + top + FStarC_Errors_Codes.Fatal_EffectCannotBeReified + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___12) + else ()); + (let u_c = + FStarC_Compiler_List.hd + expected_ct.FStarC_Syntax_Syntax.comp_univs in + let repr = + let uu___11 = + let uu___12 = + FStarC_Syntax_Syntax.mk_Comp expected_ct in + FStarC_TypeChecker_Env.effect_repr env0 + uu___12 u_c in + FStarC_Compiler_Util.must uu___11 in + let e2 = + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + let uu___15 = + FStarC_Syntax_Syntax.mk_Total repr in + FStar_Pervasives.Inr uu___15 in + (uu___14, FStar_Pervasives_Native.None, + use_eq) in + { + FStarC_Syntax_Syntax.tm = e1; + FStarC_Syntax_Syntax.asc = uu___13; + FStarC_Syntax_Syntax.eff_opt = + FStar_Pervasives_Native.None + } in + FStarC_Syntax_Syntax.Tm_ascribed uu___12 in + FStarC_Syntax_Syntax.mk uu___11 + e1.FStarC_Syntax_Syntax.pos in + (let uu___12 = FStarC_Compiler_Debug.extreme () in + if uu___12 + then + let uu___13 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term e2 in + FStarC_Compiler_Util.print1 + "Typechecking ascribed reflect, inner ascribed term: %s\n" + uu___13 + else ()); + (let uu___12 = tc_tot_or_gtot_term env0 e2 in + match uu___12 with + | (e3, uu___13, g_e) -> + let e4 = FStarC_Syntax_Util.unascribe e3 in + ((let uu___15 = + FStarC_Compiler_Debug.extreme () in + if uu___15 + then + let uu___16 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + e4 in + let uu___17 = + FStarC_TypeChecker_Rel.guard_to_string + env0 g_e in + FStarC_Compiler_Util.print2 + "Typechecking ascribed reflect, after typechecking inner ascribed term: %s and guard: %s\n" + uu___16 uu___17 + else ()); + (let top1 = + let r = top.FStarC_Syntax_Syntax.pos in + let tm = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_reflect + effect_lid)) r in + let tm1 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = tm; + FStarC_Syntax_Syntax.args = + [(e4, aqual)] + }) r in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_ascribed + { + FStarC_Syntax_Syntax.tm = tm1; + FStarC_Syntax_Syntax.asc = + ((FStar_Pervasives.Inr + expected_c1), + FStar_Pervasives_Native.None, + use_eq); + FStarC_Syntax_Syntax.eff_opt = + (FStar_Pervasives_Native.Some + (FStarC_Syntax_Util.comp_effect_name + expected_c1)) + }) r in + let uu___15 = + let uu___16 = + FStarC_TypeChecker_Common.lcomp_of_comp + expected_c1 in + comp_check_expected_typ env1 top1 + uu___16 in + match uu___15 with + | (top2, c, g_env) -> + let uu___16 = + let uu___17 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g_c g_e in + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + uu___17 g_env in + (top2, c, uu___16))))))))) + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = e1; + FStarC_Syntax_Syntax.asc = + (FStar_Pervasives.Inr expected_c, + FStar_Pervasives_Native.None, use_eq); + FStarC_Syntax_Syntax.eff_opt = uu___2;_} + -> + let uu___3 = FStarC_TypeChecker_Env.clear_expected_typ env1 in + (match uu___3 with + | (env0, uu___4) -> + let uu___5 = tc_comp env0 expected_c in + (match uu___5 with + | (expected_c1, uu___6, g) -> + let uu___7 = + let uu___8 = + FStarC_TypeChecker_Env.set_expected_typ_maybe_eq + env0 (FStarC_Syntax_Util.comp_result expected_c1) + use_eq in + tc_term uu___8 e1 in + (match uu___7 with + | (e2, c', g') -> + let uu___8 = + let uu___9 = + FStarC_TypeChecker_Common.lcomp_comp c' in + match uu___9 with + | (c'1, g_c') -> + let uu___10 = + check_expected_effect env0 use_eq + (FStar_Pervasives_Native.Some + expected_c1) (e2, c'1) in + (match uu___10 with + | (e3, expected_c2, g'') -> + let uu___11 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g_c' g'' in + (e3, expected_c2, uu___11)) in + (match uu___8 with + | (e3, expected_c2, g'') -> + let e4 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_ascribed + { + FStarC_Syntax_Syntax.tm = e3; + FStarC_Syntax_Syntax.asc = + ((FStar_Pervasives.Inr expected_c2), + FStar_Pervasives_Native.None, + use_eq); + FStarC_Syntax_Syntax.eff_opt = + (FStar_Pervasives_Native.Some + (FStarC_Syntax_Util.comp_effect_name + expected_c2)) + }) top.FStarC_Syntax_Syntax.pos in + let lc = + FStarC_TypeChecker_Common.lcomp_of_comp + expected_c2 in + let f = + let uu___9 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g g' in + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + uu___9 g'' in + let uu___9 = + comp_check_expected_typ env1 e4 lc in + (match uu___9 with + | (e5, c, f2) -> + let uu___10 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + f f2 in + (e5, c, uu___10)))))) + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = e1; + FStarC_Syntax_Syntax.asc = + (FStar_Pervasives.Inl t, FStar_Pervasives_Native.None, + use_eq); + FStarC_Syntax_Syntax.eff_opt = uu___2;_} + -> + let uu___3 = FStarC_Syntax_Util.type_u () in + (match uu___3 with + | (k, u) -> + let uu___4 = + tc_check_tot_or_gtot_term env1 t k + FStar_Pervasives_Native.None in + (match uu___4 with + | (t1, uu___5, f) -> + let uu___6 = + let uu___7 = + FStarC_TypeChecker_Env.set_expected_typ_maybe_eq + env1 t1 use_eq in + tc_term uu___7 e1 in + (match uu___6 with + | (e2, c, g) -> + let uu___7 = + let uu___8 = + FStarC_TypeChecker_Env.set_range env1 + t1.FStarC_Syntax_Syntax.pos in + FStarC_TypeChecker_Util.strengthen_precondition + (FStar_Pervasives_Native.Some + (fun uu___9 -> + FStarC_TypeChecker_Err.ill_kinded_type)) + uu___8 e2 c f in + (match uu___7 with + | (c1, f1) -> + let uu___8 = + let uu___9 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_ascribed + { + FStarC_Syntax_Syntax.tm = e2; + FStarC_Syntax_Syntax.asc = + ((FStar_Pervasives.Inl t1), + FStar_Pervasives_Native.None, + use_eq); + FStarC_Syntax_Syntax.eff_opt = + (FStar_Pervasives_Native.Some + (c1.FStarC_TypeChecker_Common.eff_name)) + }) top.FStarC_Syntax_Syntax.pos in + comp_check_expected_typ env1 uu___9 c1 in + (match uu___8 with + | (e3, c2, f2) -> + let uu___9 = + let uu___10 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g f2 in + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + f1 uu___10 in + (e3, c2, uu___9)))))) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_range_of); + FStarC_Syntax_Syntax.pos = uu___2; + FStarC_Syntax_Syntax.vars = uu___3; + FStarC_Syntax_Syntax.hash_code = uu___4;_}; + FStarC_Syntax_Syntax.args = a::hd::rest;_} + -> + let rest1 = hd :: rest in + let uu___5 = FStarC_Syntax_Util.head_and_args top in + (match uu___5 with + | (unary_op, uu___6) -> + let head = + let uu___7 = + FStarC_Compiler_Range_Ops.union_ranges + unary_op.FStarC_Syntax_Syntax.pos + (FStar_Pervasives_Native.fst a).FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = unary_op; + FStarC_Syntax_Syntax.args = [a] + }) uu___7 in + let t = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = rest1 + }) top.FStarC_Syntax_Syntax.pos in + tc_term env1 t) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_reify uu___2); + FStarC_Syntax_Syntax.pos = uu___3; + FStarC_Syntax_Syntax.vars = uu___4; + FStarC_Syntax_Syntax.hash_code = uu___5;_}; + FStarC_Syntax_Syntax.args = a::hd::rest;_} + -> + let rest1 = hd :: rest in + let uu___6 = FStarC_Syntax_Util.head_and_args top in + (match uu___6 with + | (unary_op, uu___7) -> + let head = + let uu___8 = + FStarC_Compiler_Range_Ops.union_ranges + unary_op.FStarC_Syntax_Syntax.pos + (FStar_Pervasives_Native.fst a).FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = unary_op; + FStarC_Syntax_Syntax.args = [a] + }) uu___8 in + let t = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = rest1 + }) top.FStarC_Syntax_Syntax.pos in + tc_term env1 t) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_reflect uu___2); + FStarC_Syntax_Syntax.pos = uu___3; + FStarC_Syntax_Syntax.vars = uu___4; + FStarC_Syntax_Syntax.hash_code = uu___5;_}; + FStarC_Syntax_Syntax.args = a::hd::rest;_} + -> + let rest1 = hd :: rest in + let uu___6 = FStarC_Syntax_Util.head_and_args top in + (match uu___6 with + | (unary_op, uu___7) -> + let head = + let uu___8 = + FStarC_Compiler_Range_Ops.union_ranges + unary_op.FStarC_Syntax_Syntax.pos + (FStar_Pervasives_Native.fst a).FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = unary_op; + FStarC_Syntax_Syntax.args = [a] + }) uu___8 in + let t = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = rest1 + }) top.FStarC_Syntax_Syntax.pos in + tc_term env1 t) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_set_range_of); + FStarC_Syntax_Syntax.pos = uu___2; + FStarC_Syntax_Syntax.vars = uu___3; + FStarC_Syntax_Syntax.hash_code = uu___4;_}; + FStarC_Syntax_Syntax.args = a1::a2::hd::rest;_} + -> + let rest1 = hd :: rest in + let uu___5 = FStarC_Syntax_Util.head_and_args top in + (match uu___5 with + | (unary_op, uu___6) -> + let head = + let uu___7 = + FStarC_Compiler_Range_Ops.union_ranges + unary_op.FStarC_Syntax_Syntax.pos + (FStar_Pervasives_Native.fst a1).FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = unary_op; + FStarC_Syntax_Syntax.args = [a1; a2] + }) uu___7 in + let t = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = rest1 + }) top.FStarC_Syntax_Syntax.pos in + tc_term env1 t) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_range_of); + FStarC_Syntax_Syntax.pos = uu___2; + FStarC_Syntax_Syntax.vars = uu___3; + FStarC_Syntax_Syntax.hash_code = uu___4;_}; + FStarC_Syntax_Syntax.args = + (e1, FStar_Pervasives_Native.None)::[];_} + -> + let uu___5 = + let uu___6 = + let uu___7 = FStarC_TypeChecker_Env.clear_expected_typ env1 in + FStar_Pervasives_Native.fst uu___7 in + tc_term uu___6 e1 in + (match uu___5 with + | (e2, c, g) -> + let uu___6 = FStarC_Syntax_Util.head_and_args top in + (match uu___6 with + | (head, uu___7) -> + let uu___8 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = + [(e2, FStar_Pervasives_Native.None)] + }) top.FStarC_Syntax_Syntax.pos in + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Syntax_Syntax.tabbrev + FStarC_Parser_Const.range_lid in + FStarC_Syntax_Syntax.mk_Total uu___11 in + FStarC_TypeChecker_Common.lcomp_of_comp uu___10 in + (uu___8, uu___9, g))) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_set_range_of); + FStarC_Syntax_Syntax.pos = uu___2; + FStarC_Syntax_Syntax.vars = uu___3; + FStarC_Syntax_Syntax.hash_code = uu___4;_}; + FStarC_Syntax_Syntax.args = + (t, FStar_Pervasives_Native.None)::(r, + FStar_Pervasives_Native.None)::[];_} + -> + let uu___5 = FStarC_Syntax_Util.head_and_args top in + (match uu___5 with + | (head, uu___6) -> + let env' = + let uu___7 = + FStarC_Syntax_Syntax.tabbrev + FStarC_Parser_Const.range_lid in + FStarC_TypeChecker_Env.set_expected_typ env1 uu___7 in + let uu___7 = tc_term env' r in + (match uu___7 with + | (er, uu___8, gr) -> + let uu___9 = tc_term env1 t in + (match uu___9 with + | (t1, tt, gt) -> + let g = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t gr gt in + let uu___10 = + let uu___11 = + let uu___12 = FStarC_Syntax_Syntax.as_arg t1 in + let uu___13 = + let uu___14 = FStarC_Syntax_Syntax.as_arg r in + [uu___14] in + uu___12 :: uu___13 in + FStarC_Syntax_Syntax.mk_Tm_app head uu___11 + top.FStarC_Syntax_Syntax.pos in + (uu___10, tt, g)))) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_range_of); + FStarC_Syntax_Syntax.pos = uu___2; + FStarC_Syntax_Syntax.vars = uu___3; + FStarC_Syntax_Syntax.hash_code = uu___4;_}; + FStarC_Syntax_Syntax.args = uu___5;_} + -> + let uu___6 = + let uu___7 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term top in + FStarC_Compiler_Util.format1 "Ill-applied constant %s" uu___7 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) e + FStarC_Errors_Codes.Fatal_IllAppliedConstant () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___6) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_set_range_of); + FStarC_Syntax_Syntax.pos = uu___2; + FStarC_Syntax_Syntax.vars = uu___3; + FStarC_Syntax_Syntax.hash_code = uu___4;_}; + FStarC_Syntax_Syntax.args = uu___5;_} + -> + let uu___6 = + let uu___7 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term top in + FStarC_Compiler_Util.format1 "Ill-applied constant %s" uu___7 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) e + FStarC_Errors_Codes.Fatal_IllAppliedConstant () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___6) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_reify uu___2); + FStarC_Syntax_Syntax.pos = uu___3; + FStarC_Syntax_Syntax.vars = uu___4; + FStarC_Syntax_Syntax.hash_code = uu___5;_}; + FStarC_Syntax_Syntax.args = (e1, aqual)::[];_} + -> + (if FStarC_Compiler_Option.isSome aqual + then + FStarC_Errors.log_issue + (FStarC_Syntax_Syntax.has_range_syntax ()) e1 + FStarC_Errors_Codes.Warning_IrrelevantQualifierOnArgumentToReify + () (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Qualifier on argument to reify is irrelevant and will be ignored") + else (); + (let uu___7 = FStarC_TypeChecker_Env.clear_expected_typ env1 in + match uu___7 with + | (env0, uu___8) -> + let uu___9 = tc_term env0 e1 in + (match uu___9 with + | (e2, c, g) -> + let uu___10 = + let uu___11 = FStarC_TypeChecker_Common.lcomp_comp c in + match uu___11 with + | (c1, g_c) -> + let uu___12 = + FStarC_TypeChecker_Env.unfold_effect_abbrev + env1 c1 in + (uu___12, g_c) in + (match uu___10 with + | (c1, g_c) -> + ((let uu___12 = + let uu___13 = + FStarC_TypeChecker_Env.is_user_reifiable_effect + env1 c1.FStarC_Syntax_Syntax.effect_name in + Prims.op_Negation uu___13 in + if uu___12 + then + let uu___13 = + let uu___14 = + FStarC_Ident.string_of_lid + c1.FStarC_Syntax_Syntax.effect_name in + FStarC_Compiler_Util.format1 + "Effect %s cannot be reified" uu___14 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) + e2 + FStarC_Errors_Codes.Fatal_EffectCannotBeReified + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___13) + else ()); + (let u_c = + FStarC_Compiler_List.hd + c1.FStarC_Syntax_Syntax.comp_univs in + let e3 = + FStarC_Syntax_Util.mk_reify e2 + (FStar_Pervasives_Native.Some + (c1.FStarC_Syntax_Syntax.effect_name)) in + let repr = + let uu___12 = FStarC_Syntax_Syntax.mk_Comp c1 in + FStarC_TypeChecker_Env.reify_comp env1 + uu___12 u_c in + let c2 = + let uu___12 = + FStarC_TypeChecker_Env.is_total_effect env1 + c1.FStarC_Syntax_Syntax.effect_name in + if uu___12 + then + let uu___13 = + FStarC_Syntax_Syntax.mk_Total repr in + FStarC_TypeChecker_Common.lcomp_of_comp + uu___13 + else + (let ct = + { + FStarC_Syntax_Syntax.comp_univs = + [u_c]; + FStarC_Syntax_Syntax.effect_name = + FStarC_Parser_Const.effect_Dv_lid; + FStarC_Syntax_Syntax.result_typ = repr; + FStarC_Syntax_Syntax.effect_args = []; + FStarC_Syntax_Syntax.flags = [] + } in + let uu___14 = + FStarC_Syntax_Syntax.mk_Comp ct in + FStarC_TypeChecker_Common.lcomp_of_comp + uu___14) in + let uu___12 = + comp_check_expected_typ env1 e3 c2 in + match uu___12 with + | (e4, c3, g') -> + let uu___13 = + let uu___14 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g_c g' in + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g uu___14 in + (e4, c3, uu___13))))))) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_reflect l); + FStarC_Syntax_Syntax.pos = uu___2; + FStarC_Syntax_Syntax.vars = uu___3; + FStarC_Syntax_Syntax.hash_code = uu___4;_}; + FStarC_Syntax_Syntax.args = (e1, aqual)::[];_} + -> + (if FStarC_Compiler_Option.isSome aqual + then + FStarC_Errors.log_issue + (FStarC_Syntax_Syntax.has_range_syntax ()) e1 + FStarC_Errors_Codes.Warning_IrrelevantQualifierOnArgumentToReflect + () (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Qualifier on argument to reflect is irrelevant and will be ignored") + else (); + (let uu___7 = + let uu___8 = + FStarC_TypeChecker_Env.is_user_reflectable_effect env1 l in + Prims.op_Negation uu___8 in + if uu___7 + then + let uu___8 = + let uu___9 = FStarC_Ident.string_of_lid l in + FStarC_Compiler_Util.format1 + "Effect %s cannot be reflected" uu___9 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) e1 + FStarC_Errors_Codes.Fatal_EffectCannotBeReified () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___8) + else ()); + (let uu___7 = FStarC_Syntax_Util.head_and_args top in + match uu___7 with + | (reflect_op, uu___8) -> + let uu___9 = FStarC_TypeChecker_Env.effect_decl_opt env1 l in + (match uu___9 with + | FStar_Pervasives_Native.None -> + let uu___10 = + let uu___11 = FStarC_Ident.string_of_lid l in + FStarC_Compiler_Util.format1 + "Effect %s not found (for reflect)" uu___11 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) e1 + FStarC_Errors_Codes.Fatal_EffectNotFound () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___10) + | FStar_Pervasives_Native.Some (ed, qualifiers) -> + let uu___10 = + FStarC_TypeChecker_Env.clear_expected_typ env1 in + (match uu___10 with + | (env_no_ex, uu___11) -> + let uu___12 = + let uu___13 = tc_tot_or_gtot_term env_no_ex e1 in + match uu___13 with + | (e2, c, g) -> + ((let uu___15 = + let uu___16 = + FStarC_TypeChecker_Common.is_total_lcomp + c in + Prims.op_Negation uu___16 in + if uu___15 + then + FStarC_Errors.log_issue + (FStarC_Syntax_Syntax.has_range_syntax + ()) e2 + FStarC_Errors_Codes.Error_UnexpectedGTotComputation + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Expected Tot, got a GTot computation") + else ()); + (e2, c, g)) in + (match uu___12 with + | (e2, c_e, g_e) -> + let uu___13 = + let uu___14 = FStarC_Syntax_Util.type_u () in + match uu___14 with + | (a, u_a) -> + let uu___15 = + FStarC_TypeChecker_Util.new_implicit_var + "tc_term reflect" + e2.FStarC_Syntax_Syntax.pos + env_no_ex a false in + (match uu___15 with + | (a_uvar, uu___16, g_a) -> + let uu___17 = + FStarC_TypeChecker_Util.fresh_effect_repr_en + env_no_ex + e2.FStarC_Syntax_Syntax.pos l + u_a a_uvar in + (uu___17, u_a, a_uvar, g_a)) in + (match uu___13 with + | ((expected_repr_typ, g_repr), u_a, a, + g_a) -> + let g_eq = + FStarC_TypeChecker_Rel.teq env_no_ex + c_e.FStarC_TypeChecker_Common.res_typ + expected_repr_typ in + let eff_args = + let uu___14 = + let uu___15 = + FStarC_Syntax_Subst.compress + expected_repr_typ in + uu___15.FStarC_Syntax_Syntax.n in + match uu___14 with + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + uu___15; + FStarC_Syntax_Syntax.args = + uu___16::args;_} + -> args + | uu___15 -> + let uu___16 = + let uu___17 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + l in + let uu___18 = + FStarC_Class_Tagged.tag_of + FStarC_Syntax_Syntax.tagged_term + expected_repr_typ in + let uu___19 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + expected_repr_typ in + FStarC_Compiler_Util.format3 + "Expected repr type for %s is not an application node (%s:%s)" + uu___17 uu___18 uu___19 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax + ()) top + FStarC_Errors_Codes.Fatal_UnexpectedEffect + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___16) in + let c = + let uu___14 = + FStarC_Syntax_Syntax.mk_Comp + { + FStarC_Syntax_Syntax.comp_univs + = [u_a]; + FStarC_Syntax_Syntax.effect_name + = + (ed.FStarC_Syntax_Syntax.mname); + FStarC_Syntax_Syntax.result_typ + = a; + FStarC_Syntax_Syntax.effect_args + = eff_args; + FStarC_Syntax_Syntax.flags = [] + } in + FStarC_TypeChecker_Common.lcomp_of_comp + uu___14 in + let e3 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + reflect_op; + FStarC_Syntax_Syntax.args = + [(e2, aqual)] + }) top.FStarC_Syntax_Syntax.pos in + let uu___14 = + comp_check_expected_typ env1 e3 c in + (match uu___14 with + | (e4, c1, g') -> + let e5 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 + = e4; + FStarC_Syntax_Syntax.meta + = + (FStarC_Syntax_Syntax.Meta_monadic + ((c1.FStarC_TypeChecker_Common.eff_name), + (c1.FStarC_TypeChecker_Common.res_typ))) + }) + e4.FStarC_Syntax_Syntax.pos in + let uu___15 = + FStarC_Class_Monoid.msum + FStarC_TypeChecker_Common.monoid_guard_t + [g_e; g_repr; g_a; g_eq; g'] in + (e5, c1, uu___15)))))))) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar + { FStarC_Syntax_Syntax.fv_name = uu___2; + FStarC_Syntax_Syntax.fv_qual = + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Unresolved_constructor uc);_}; + FStarC_Syntax_Syntax.pos = uu___3; + FStarC_Syntax_Syntax.vars = uu___4; + FStarC_Syntax_Syntax.hash_code = uu___5;_}; + FStarC_Syntax_Syntax.args = args;_} + -> + let uu___6 = + let uu___7 = + if uc.FStarC_Syntax_Syntax.uc_base_term + then + match args with + | (b, uu___8)::rest -> + ((FStar_Pervasives_Native.Some b), rest) + | uu___8 -> failwith "Impossible" + else (FStar_Pervasives_Native.None, args) in + match uu___7 with + | (base_term, fields) -> + if + (FStarC_Compiler_List.length + uc.FStarC_Syntax_Syntax.uc_fields) + <> (FStarC_Compiler_List.length fields) + then + let uu___8 = + let uu___9 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_nat) + (FStarC_Compiler_List.length + uc.FStarC_Syntax_Syntax.uc_fields) in + let uu___10 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_nat) + (FStarC_Compiler_List.length fields) in + FStarC_Compiler_Util.format2 + "Could not resolve constructor; expected %s fields but only found %s" + uu___9 uu___10 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) top + FStarC_Errors_Codes.Fatal_IdentifierNotFound () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___8) + else + (let uu___9 = + let uu___10 = + FStarC_Compiler_List.map FStar_Pervasives_Native.fst + fields in + FStarC_Compiler_List.zip + uc.FStarC_Syntax_Syntax.uc_fields uu___10 in + (base_term, uu___9)) in + (match uu___6 with + | (base_term, uc_fields) -> + let uu___7 = + let uu___8 = FStarC_TypeChecker_Env.expected_typ env1 in + match uu___8 with + | FStar_Pervasives_Native.Some (t, uu___9) -> + let uu___10 = + FStarC_TypeChecker_Util.find_record_or_dc_from_typ + env1 (FStar_Pervasives_Native.Some t) uc + top.FStarC_Syntax_Syntax.pos in + (uu___10, + (FStar_Pervasives_Native.Some + (FStar_Pervasives.Inl t))) + | FStar_Pervasives_Native.None -> + (match base_term with + | FStar_Pervasives_Native.Some e1 -> + let uu___9 = tc_term env1 e1 in + (match uu___9 with + | (uu___10, lc, uu___11) -> + let uu___12 = + FStarC_TypeChecker_Util.find_record_or_dc_from_typ + env1 + (FStar_Pervasives_Native.Some + (lc.FStarC_TypeChecker_Common.res_typ)) + uc top.FStarC_Syntax_Syntax.pos in + (uu___12, + (FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr + (lc.FStarC_TypeChecker_Common.res_typ))))) + | FStar_Pervasives_Native.None -> + let uu___9 = + FStarC_TypeChecker_Util.find_record_or_dc_from_typ + env1 FStar_Pervasives_Native.None uc + top.FStarC_Syntax_Syntax.pos in + (uu___9, FStar_Pervasives_Native.None)) in + (match uu___7 with + | ((rdc, constrname, constructor), topt) -> + let rdc1 = rdc in + let constructor1 = + FStarC_Syntax_Syntax.fv_to_tm constructor in + let mk_field_projector i x = + let projname = + FStarC_Syntax_Util.mk_field_projector_name_from_ident + constrname i in + let qual = + if rdc1.FStarC_Syntax_DsEnv.is_record + then + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Record_projector + (constrname, i)) + else FStar_Pervasives_Native.None in + let candidate = + let uu___8 = + FStarC_Ident.set_lid_range projname + x.FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.fvar uu___8 qual in + FStarC_Syntax_Syntax.mk_Tm_app candidate + [(x, FStar_Pervasives_Native.None)] + x.FStarC_Syntax_Syntax.pos in + let fields = + FStarC_TypeChecker_Util.make_record_fields_in_order + env1 uc topt rdc1 uc_fields + (fun field_name -> + match base_term with + | FStar_Pervasives_Native.Some x -> + let uu___8 = mk_field_projector field_name x in + FStar_Pervasives_Native.Some uu___8 + | uu___8 -> FStar_Pervasives_Native.None) + top.FStarC_Syntax_Syntax.pos in + let args1 = + FStarC_Compiler_List.map + (fun x -> (x, FStar_Pervasives_Native.None)) fields in + let term = + FStarC_Syntax_Syntax.mk_Tm_app constructor1 args1 + top.FStarC_Syntax_Syntax.pos in + tc_term env1 term)) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar + { + FStarC_Syntax_Syntax.fv_name = + { FStarC_Syntax_Syntax.v = field_name; + FStarC_Syntax_Syntax.p = uu___2;_}; + FStarC_Syntax_Syntax.fv_qual = + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Unresolved_projector candidate);_}; + FStarC_Syntax_Syntax.pos = uu___3; + FStarC_Syntax_Syntax.vars = uu___4; + FStarC_Syntax_Syntax.hash_code = uu___5;_}; + FStarC_Syntax_Syntax.args = + (e1, FStar_Pervasives_Native.None)::rest;_} + -> + let proceed_with choice = + match choice with + | FStar_Pervasives_Native.None -> + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = FStarC_Ident.string_of_lid field_name in + FStarC_Compiler_Util.format1 + "Field name %s could not be resolved" uu___9 in + FStarC_Errors_Msg.text uu___8 in + [uu___7] in + FStarC_Errors.raise_error FStarC_Ident.hasrange_lident + field_name FStarC_Errors_Codes.Fatal_IdentifierNotFound + () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___6) + | FStar_Pervasives_Native.Some choice1 -> + let f = FStarC_Syntax_Syntax.fv_to_tm choice1 in + let term = + FStarC_Syntax_Syntax.mk_Tm_app f + ((e1, FStar_Pervasives_Native.None) :: rest) + top.FStarC_Syntax_Syntax.pos in + tc_term env1 term in + let uu___6 = + let uu___7 = FStarC_TypeChecker_Env.clear_expected_typ env1 in + match uu___7 with | (env2, uu___8) -> tc_term env2 e1 in + (match uu___6 with + | (uu___7, lc, uu___8) -> + let t0 = + FStarC_TypeChecker_Normalize.unfold_whnf' + [FStarC_TypeChecker_Env.Unascribe; + FStarC_TypeChecker_Env.Unmeta; + FStarC_TypeChecker_Env.Unrefine] env1 + lc.FStarC_TypeChecker_Common.res_typ in + let uu___9 = FStarC_Syntax_Util.head_and_args t0 in + (match uu___9 with + | (thead, uu___10) -> + ((let uu___12 = FStarC_Compiler_Effect.op_Bang dbg_RFD in + if uu___12 + then + let uu___13 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + lc.FStarC_TypeChecker_Common.res_typ in + let uu___14 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t0 in + let uu___15 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term thead in + FStarC_Compiler_Util.print3 + "Got lc.res_typ=%s; t0 = %s; thead = %s\n" + uu___13 uu___14 uu___15 + else ()); + (let uu___12 = + let uu___13 = + let uu___14 = FStarC_Syntax_Util.un_uinst thead in + FStarC_Syntax_Subst.compress uu___14 in + uu___13.FStarC_Syntax_Syntax.n in + match uu___12 with + | FStarC_Syntax_Syntax.Tm_fvar type_name -> + let uu___13 = + FStarC_TypeChecker_Util.try_lookup_record_type + env1 + (type_name.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + (match uu___13 with + | FStar_Pervasives_Native.None -> + proceed_with candidate + | FStar_Pervasives_Native.Some rdc -> + let i = + FStarC_Compiler_List.tryFind + (fun uu___14 -> + match uu___14 with + | (i1, uu___15) -> + FStarC_TypeChecker_Util.field_name_matches + field_name rdc i1) + rdc.FStarC_Syntax_DsEnv.fields in + (match i with + | FStar_Pervasives_Native.None -> + proceed_with candidate + | FStar_Pervasives_Native.Some + (i1, uu___14) -> + let constrname = + let uu___15 = + let uu___16 = + FStarC_Ident.ns_of_lid + rdc.FStarC_Syntax_DsEnv.typename in + FStarC_Compiler_List.op_At uu___16 + [rdc.FStarC_Syntax_DsEnv.constrname] in + FStarC_Ident.lid_of_ids uu___15 in + let projname = + FStarC_Syntax_Util.mk_field_projector_name_from_ident + constrname i1 in + let qual = + if rdc.FStarC_Syntax_DsEnv.is_record + then + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Record_projector + (constrname, i1)) + else FStar_Pervasives_Native.None in + let choice = + let uu___15 = + let uu___16 = + FStarC_Ident.range_of_lid + field_name in + FStarC_Ident.set_lid_range projname + uu___16 in + FStarC_Syntax_Syntax.lid_as_fv + uu___15 qual in + proceed_with + (FStar_Pervasives_Native.Some choice))) + | uu___13 -> proceed_with candidate)))) + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = + (tau, FStar_Pervasives_Native.None)::[];_} + when + (FStarC_Syntax_Util.is_synth_by_tactic head) && + (Prims.op_Negation env1.FStarC_TypeChecker_Env.phase1) + -> + let uu___2 = FStarC_Syntax_Util.head_and_args top in + (match uu___2 with + | (head1, args) -> + tc_synth head1 env1 args top.FStarC_Syntax_Syntax.pos) + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = + (uu___2, FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = uu___3;_}):: + (tau, FStar_Pervasives_Native.None)::[];_} + when + (FStarC_Syntax_Util.is_synth_by_tactic head) && + (Prims.op_Negation env1.FStarC_TypeChecker_Env.phase1) + -> + let uu___4 = FStarC_Syntax_Util.head_and_args top in + (match uu___4 with + | (head1, args) -> + tc_synth head1 env1 args top.FStarC_Syntax_Syntax.pos) + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = args;_} + when + (FStarC_Syntax_Util.is_synth_by_tactic head) && + (Prims.op_Negation env1.FStarC_TypeChecker_Env.phase1) + -> + let uu___2 = + match args with + | (tau, FStar_Pervasives_Native.None)::rest -> + ([(tau, FStar_Pervasives_Native.None)], rest) + | (a, FStar_Pervasives_Native.Some aq)::(tau, + FStar_Pervasives_Native.None)::rest + when aq.FStarC_Syntax_Syntax.aqual_implicit -> + ([(a, (FStar_Pervasives_Native.Some aq)); + (tau, FStar_Pervasives_Native.None)], rest) + | uu___3 -> + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) top + FStarC_Errors_Codes.Fatal_SynthByTacticError () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "synth_by_tactic: bad application") in + (match uu___2 with + | (args1, args2) -> + let t1 = FStarC_Syntax_Util.mk_app head args1 in + let t2 = FStarC_Syntax_Util.mk_app t1 args2 in + tc_term env1 t2) + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = args;_} + -> + let env0 = env1 in + let env2 = + let uu___2 = + let uu___3 = FStarC_TypeChecker_Env.clear_expected_typ env1 in + FStar_Pervasives_Native.fst uu___3 in + instantiate_both uu___2 in + ((let uu___3 = FStarC_Compiler_Debug.high () in + if uu___3 + then + let uu___4 = + FStarC_Compiler_Range_Ops.string_of_range + top.FStarC_Syntax_Syntax.pos in + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + top in + let uu___6 = print_expected_ty_str env0 in + FStarC_Compiler_Util.print3 "(%s) Checking app %s, %s\n" + uu___4 uu___5 uu___6 + else ()); + (let uu___3 = tc_term (no_inst env2) head in + match uu___3 with + | (head1, chead, g_head) -> + let uu___4 = + let uu___5 = FStarC_TypeChecker_Common.lcomp_comp chead in + match uu___5 with + | (c, g) -> + let uu___6 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t g_head g in + (c, uu___6) in + (match uu___4 with + | (chead1, g_head1) -> + let uu___5 = + let uu___6 = + ((FStarC_TypeChecker_Util.short_circuit_head head1) + && + (let uu___7 = FStarC_Options.ml_ish () in + Prims.op_Negation uu___7)) + && + (Prims.op_Negation + env2.FStarC_TypeChecker_Env.phase1) in + if uu___6 + then + let uu___7 = + let uu___8 = + FStarC_TypeChecker_Env.expected_typ env0 in + check_short_circuit_args env2 head1 chead1 + g_head1 args uu___8 in + match uu___7 with | (e1, c, g) -> (e1, c, g) + else + (let uu___8 = + FStarC_TypeChecker_Env.expected_typ env0 in + check_application_args env2 head1 chead1 g_head1 + args uu___8) in + (match uu___5 with + | (e1, c, g) -> + let uu___6 = + let uu___7 = + (FStarC_TypeChecker_Common.is_tot_or_gtot_lcomp + c) + || + (env2.FStarC_TypeChecker_Env.phase1 && + (FStarC_TypeChecker_Common.is_pure_or_ghost_lcomp + c)) in + if uu___7 + then + let uu___8 = + FStarC_TypeChecker_Util.maybe_instantiate + env0 e1 + c.FStarC_TypeChecker_Common.res_typ in + match uu___8 with + | (e2, res_typ, implicits) -> + let uu___9 = + FStarC_TypeChecker_Common.set_result_typ_lc + c res_typ in + (e2, uu___9, implicits) + else + (e1, c, + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t)) in + (match uu___6 with + | (e2, c1, implicits) -> + ((let uu___8 = + FStarC_Compiler_Debug.extreme () in + if uu___8 + then + let uu___9 = + FStarC_TypeChecker_Rel.print_pending_implicits + g in + FStarC_Compiler_Util.print1 + "Introduced {%s} implicits in application\n" + uu___9 + else ()); + (let uu___8 = + comp_check_expected_typ env0 e2 c1 in + match uu___8 with + | (e3, c2, g') -> + let gres = + let uu___9 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g g' in + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + uu___9 implicits in + ((let uu___10 = + FStarC_Compiler_Debug.extreme () in + if uu___10 + then + let uu___11 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + e3 in + let uu___12 = + FStarC_TypeChecker_Rel.guard_to_string + env2 gres in + FStarC_Compiler_Util.print2 + "Guard from application node %s is %s\n" + uu___11 uu___12 + else ()); + (e3, c2, gres))))))))) + | FStarC_Syntax_Syntax.Tm_match uu___2 -> tc_match env1 top + | FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = + (false, + { FStarC_Syntax_Syntax.lbname = FStar_Pervasives.Inr uu___2; + FStarC_Syntax_Syntax.lbunivs = uu___3; + FStarC_Syntax_Syntax.lbtyp = uu___4; + FStarC_Syntax_Syntax.lbeff = uu___5; + FStarC_Syntax_Syntax.lbdef = uu___6; + FStarC_Syntax_Syntax.lbattrs = uu___7; + FStarC_Syntax_Syntax.lbpos = uu___8;_}::[]); + FStarC_Syntax_Syntax.body1 = uu___9;_} + -> check_top_level_let env1 top + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (false, uu___2); + FStarC_Syntax_Syntax.body1 = uu___3;_} + -> check_inner_let env1 top + | FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = + (true, + { FStarC_Syntax_Syntax.lbname = FStar_Pervasives.Inr uu___2; + FStarC_Syntax_Syntax.lbunivs = uu___3; + FStarC_Syntax_Syntax.lbtyp = uu___4; + FStarC_Syntax_Syntax.lbeff = uu___5; + FStarC_Syntax_Syntax.lbdef = uu___6; + FStarC_Syntax_Syntax.lbattrs = uu___7; + FStarC_Syntax_Syntax.lbpos = uu___8;_}::uu___9); + FStarC_Syntax_Syntax.body1 = uu___10;_} + -> check_top_level_let_rec env1 top + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (true, uu___2); + FStarC_Syntax_Syntax.body1 = uu___3;_} + -> check_inner_let_rec env1 top)) +and (tc_match : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.lcomp * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun top -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress top in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = e1; + FStarC_Syntax_Syntax.ret_opt = ret_opt; + FStarC_Syntax_Syntax.brs = eqns; + FStarC_Syntax_Syntax.rc_opt1 = uu___1;_} + -> + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_TypeChecker_Env.clear_expected_typ env in + FStar_Pervasives_Native.fst uu___5 in + instantiate_both uu___4 in + tc_term uu___3 e1 in + (match uu___2 with + | (e11, c1, g1) -> + let uu___3 = + match eqns with + | (p, uu___4, uu___5)::uu___6 -> + (match p.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_cons (fv, uu___7, uu___8) -> + let r = + try + (fun uu___9 -> + match () with + | () -> + let uu___10 = + FStarC_TypeChecker_Env.lookup_datacon + env + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + FStar_Pervasives_Native.Some uu___10) () + with | uu___9 -> FStar_Pervasives_Native.None in + (match r with + | FStar_Pervasives_Native.Some (us, t) -> + let uu___9 = + FStarC_Syntax_Util.arrow_formals_comp t in + (match uu___9 with + | (bs, c) -> + let env' = + FStarC_TypeChecker_Env.push_binders env + bs in + FStarC_TypeChecker_Util.maybe_coerce_lc + env' e11 c1 + (FStarC_Syntax_Util.comp_result c)) + | FStar_Pervasives_Native.None -> + (e11, c1, + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t))) + | uu___7 -> + (e11, c1, + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t))) + | uu___4 -> + (e11, c1, + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t)) in + (match uu___3 with + | (e12, c11, g_c) -> + let uu___4 = + match ret_opt with + | FStar_Pervasives_Native.None -> + let uu___5 = + FStarC_TypeChecker_Env.expected_typ env in + (match uu___5 with + | FStar_Pervasives_Native.Some uu___6 -> + (env, FStar_Pervasives_Native.None, g1) + | FStar_Pervasives_Native.None -> + let uu___6 = FStarC_Syntax_Util.type_u () in + (match uu___6 with + | (k, uu___7) -> + let uu___8 = + FStarC_TypeChecker_Util.new_implicit_var + "match result" + e12.FStarC_Syntax_Syntax.pos env k + false in + (match uu___8 with + | (res_t, uu___9, g) -> + let uu___10 = + FStarC_TypeChecker_Env.set_expected_typ + env res_t in + let uu___11 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g1 g in + (uu___10, + FStar_Pervasives_Native.None, + uu___11)))) + | FStar_Pervasives_Native.Some (b, asc) -> + ((let uu___6 = + let uu___7 = + FStarC_TypeChecker_Util.is_pure_or_ghost_effect + env c11.FStarC_TypeChecker_Common.eff_name in + Prims.op_Negation uu___7 in + if uu___6 + then + let uu___7 = + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term e12 in + let uu___9 = + FStarC_Ident.string_of_lid + c11.FStarC_TypeChecker_Common.eff_name in + FStarC_Compiler_Util.format2 + "For a match with returns annotation, the scrutinee should be pure/ghost, found %s with effect %s" + uu___8 uu___9 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) + e12 + FStarC_Errors_Codes.Fatal_UnexpectedEffect () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___7) + else ()); + (let uu___6 = + FStarC_TypeChecker_Env.clear_expected_typ env in + match uu___6 with + | (env1, uu___7) -> + let uu___8 = + let uu___9 = + FStarC_Syntax_Subst.open_ascription + [b] asc in + match uu___9 with + | (bs, asc1) -> + let b1 = FStarC_Compiler_List.hd bs in + ({ + FStarC_Syntax_Syntax.binder_bv = + (let uu___10 = + b1.FStarC_Syntax_Syntax.binder_bv in + { + FStarC_Syntax_Syntax.ppname = + (uu___10.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (uu___10.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = + (c11.FStarC_TypeChecker_Common.res_typ) + }); + FStarC_Syntax_Syntax.binder_qual = + (b1.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity + = + (b1.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs = + (b1.FStarC_Syntax_Syntax.binder_attrs) + }, asc1) in + (match uu___8 with + | (b1, asc1) -> + let env_asc = + FStarC_TypeChecker_Env.push_binders + env1 [b1] in + let uu___9 = + match asc1 with + | (FStar_Pervasives.Inl t, + FStar_Pervasives_Native.None, + use_eq) -> + let uu___10 = + FStarC_Syntax_Util.type_u () in + (match uu___10 with + | (k, uu___11) -> + let uu___12 = + tc_check_tot_or_gtot_term + env_asc t k + FStar_Pervasives_Native.None in + (match uu___12 with + | (t1, uu___13, g) -> + (((FStar_Pervasives.Inl + t1), + FStar_Pervasives_Native.None, + use_eq), g))) + | (FStar_Pervasives.Inr c, + FStar_Pervasives_Native.None, + use_eq) -> + let uu___10 = tc_comp env_asc c in + (match uu___10 with + | (c2, uu___11, g) -> + (((FStar_Pervasives.Inr c2), + FStar_Pervasives_Native.None, + use_eq), g)) + | uu___10 -> + FStarC_Errors.raise_error + FStarC_TypeChecker_Env.hasRange_env + env1 + FStarC_Errors_Codes.Fatal_UnexpectedTerm + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Tactic is not yet supported with match returns") in + (match uu___9 with + | (asc2, g_asc) -> + let uu___10 = + let uu___11 = + FStarC_TypeChecker_Env.close_guard + env_asc [b1] g_asc in + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g1 uu___11 in + (env1, + (FStar_Pervasives_Native.Some + (b1, asc2)), uu___10))))) in + (match uu___4 with + | (env_branches, ret_opt1, g11) -> + let guard_x = + FStarC_Syntax_Syntax.new_bv + (FStar_Pervasives_Native.Some + (e12.FStarC_Syntax_Syntax.pos)) + c11.FStarC_TypeChecker_Common.res_typ in + let t_eqns = + FStarC_Compiler_List.map + (tc_eqn guard_x env_branches ret_opt1) eqns in + let uu___5 = + match ret_opt1 with + | FStar_Pervasives_Native.Some + (b, (FStar_Pervasives.Inr c, uu___6, uu___7)) + -> + let c2 = + FStarC_Syntax_Subst.subst_comp + [FStarC_Syntax_Syntax.NT + ((b.FStarC_Syntax_Syntax.binder_bv), + e12)] c in + let uu___8 = + let uu___9 = + FStarC_Compiler_List.map + (fun uu___10 -> + match uu___10 with + | (uu___11, f, uu___12, uu___13, + uu___14, g, b1) -> (f, g, b1)) + t_eqns in + FStarC_Compiler_List.unzip3 uu___9 in + (match uu___8 with + | (fmls, gs, erasables) -> + let uu___9 = + FStarC_TypeChecker_Util.get_neg_branch_conds + fmls in + (match uu___9 with + | (neg_conds, exhaustiveness_cond) -> + let g = + let uu___10 = + FStarC_Compiler_List.map2 + FStarC_TypeChecker_Common.weaken_guard_formula + gs neg_conds in + FStarC_Class_Monoid.msum + FStarC_TypeChecker_Common.monoid_guard_t + uu___10 in + let g_exhaustiveness = + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_TypeChecker_Env.get_range + env in + let uu___13 = + FStarC_Syntax_Util.mk_imp + exhaustiveness_cond + FStarC_Syntax_Util.t_false in + FStarC_TypeChecker_Util.label + FStarC_TypeChecker_Err.exhaustiveness_check + uu___12 uu___13 in + FStarC_TypeChecker_Common.NonTrivial + uu___11 in + FStarC_TypeChecker_Env.guard_of_guard_formula + uu___10 in + let g2 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g g_exhaustiveness in + let g3 = + let uu___10 = + let uu___11 = + env.FStarC_TypeChecker_Env.universe_of + env + c11.FStarC_TypeChecker_Common.res_typ in + let uu___12 = + FStarC_Syntax_Syntax.bv_to_name + guard_x in + FStarC_Syntax_Util.mk_eq2 + uu___11 + c11.FStarC_TypeChecker_Common.res_typ + uu___12 e12 in + FStarC_TypeChecker_Common.weaken_guard_formula + g2 uu___10 in + let g4 = + let uu___10 = + let uu___11 = + FStarC_Syntax_Syntax.mk_binder + guard_x in + [uu___11] in + FStarC_TypeChecker_Env.close_guard + env uu___10 g3 in + let uu___10 = + FStarC_TypeChecker_Common.lcomp_of_comp + c2 in + let uu___11 = + FStarC_Compiler_List.fold_left + (fun acc -> fun b1 -> acc || b1) + false erasables in + (uu___10, g4, uu___11))) + | uu___6 -> + let uu___7 = + FStarC_Compiler_List.fold_right + (fun uu___8 -> + fun uu___9 -> + match (uu___8, uu___9) with + | ((branch, f, eff_label, cflags, c, + g, erasable_branch), + (caccum, gaccum, erasable)) -> + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Compiler_Util.must + cflags in + let uu___13 = + FStarC_Compiler_Util.must c in + (f, eff_label, uu___12, + uu___13) in + uu___11 :: caccum in + let uu___11 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g gaccum in + (uu___10, uu___11, + (erasable || erasable_branch))) + t_eqns + ([], + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t), + false) in + (match uu___7 with + | (cases, g, erasable) -> + (match ret_opt1 with + | FStar_Pervasives_Native.None -> + let res_t = + let uu___8 = + let uu___9 = + FStarC_TypeChecker_Env.expected_typ + env_branches in + FStarC_Compiler_Util.must uu___9 in + FStar_Pervasives_Native.fst uu___8 in + let uu___8 = + FStarC_TypeChecker_Util.bind_cases + env res_t cases guard_x in + (uu___8, g, erasable) + | FStar_Pervasives_Native.Some + (b, + (FStar_Pervasives.Inl t, uu___8, + uu___9)) + -> + let t1 = + FStarC_Syntax_Subst.subst + [FStarC_Syntax_Syntax.NT + ((b.FStarC_Syntax_Syntax.binder_bv), + e12)] t in + let cases1 = + FStarC_Compiler_List.map + (fun uu___10 -> + match uu___10 with + | (f, eff_label, cflags, c) + -> + (f, eff_label, cflags, + ((fun b1 -> + let uu___11 = c b1 in + FStarC_TypeChecker_Common.set_result_typ_lc + uu___11 t1)))) + cases in + let uu___10 = + FStarC_TypeChecker_Util.bind_cases + env t1 cases1 guard_x in + (uu___10, g, erasable))) in + (match uu___5 with + | (c_branches, g_branches, erasable) -> + let cres = + FStarC_TypeChecker_Util.bind + e12.FStarC_Syntax_Syntax.pos env + (FStar_Pervasives_Native.Some e12) c11 + ((FStar_Pervasives_Native.Some guard_x), + c_branches) in + let cres1 = + if erasable + then + let e = FStarC_Syntax_Util.exp_true_bool in + let c = + FStarC_Syntax_Syntax.mk_GTotal + FStarC_Syntax_Util.t_bool in + let uu___6 = + FStarC_TypeChecker_Common.lcomp_of_comp c in + FStarC_TypeChecker_Util.bind + e.FStarC_Syntax_Syntax.pos env + (FStar_Pervasives_Native.Some e) uu___6 + (FStar_Pervasives_Native.None, cres) + else cres in + let e = + let ret_opt2 = + match ret_opt1 with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (b, asc) -> + let asc1 = + FStarC_Syntax_Subst.close_ascription + [b] asc in + let b1 = + let uu___6 = + FStarC_Syntax_Subst.close_binders + [b] in + FStarC_Compiler_List.hd uu___6 in + let b2 = + { + FStarC_Syntax_Syntax.binder_bv = + (let uu___6 = + b1.FStarC_Syntax_Syntax.binder_bv in + { + FStarC_Syntax_Syntax.ppname = + (uu___6.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (uu___6.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = + FStarC_Syntax_Syntax.tun + }); + FStarC_Syntax_Syntax.binder_qual = + (b1.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity + = + (b1.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs = + (b1.FStarC_Syntax_Syntax.binder_attrs) + } in + FStar_Pervasives_Native.Some (b2, asc1) in + let mk_match scrutinee = + let branches = + FStarC_Compiler_List.map + (fun uu___6 -> + match uu___6 with + | ((pat, wopt, br), uu___7, + eff_label, uu___8, uu___9, + uu___10, uu___11) -> + let uu___12 = + FStarC_TypeChecker_Util.maybe_lift + env br eff_label + cres1.FStarC_TypeChecker_Common.eff_name + cres1.FStarC_TypeChecker_Common.res_typ in + (pat, wopt, uu___12)) t_eqns in + let e2 = + let rc = + { + FStarC_Syntax_Syntax.residual_effect + = + (cres1.FStarC_TypeChecker_Common.eff_name); + FStarC_Syntax_Syntax.residual_typ = + (FStar_Pervasives_Native.Some + (cres1.FStarC_TypeChecker_Common.res_typ)); + FStarC_Syntax_Syntax.residual_flags = + (cres1.FStarC_TypeChecker_Common.cflags) + } in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_match + { + FStarC_Syntax_Syntax.scrutinee = + scrutinee; + FStarC_Syntax_Syntax.ret_opt = + ret_opt2; + FStarC_Syntax_Syntax.brs = + branches; + FStarC_Syntax_Syntax.rc_opt1 = + (FStar_Pervasives_Native.Some rc) + }) top.FStarC_Syntax_Syntax.pos in + let e3 = + FStarC_TypeChecker_Util.maybe_monadic env + e2 + cres1.FStarC_TypeChecker_Common.eff_name + cres1.FStarC_TypeChecker_Common.res_typ in + match ret_opt2 with + | FStar_Pervasives_Native.None -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_ascribed + { + FStarC_Syntax_Syntax.tm = e3; + FStarC_Syntax_Syntax.asc = + ((FStar_Pervasives.Inl + (cres1.FStarC_TypeChecker_Common.res_typ)), + FStar_Pervasives_Native.None, + false); + FStarC_Syntax_Syntax.eff_opt = + (FStar_Pervasives_Native.Some + (cres1.FStarC_TypeChecker_Common.eff_name)) + }) e3.FStarC_Syntax_Syntax.pos + | uu___6 -> e3 in + let uu___6 = + FStarC_TypeChecker_Util.is_pure_or_ghost_effect + env + c11.FStarC_TypeChecker_Common.eff_name in + if uu___6 + then mk_match e12 + else + (let e_match = + let uu___8 = + FStarC_Syntax_Syntax.bv_to_name + guard_x in + mk_match uu___8 in + let lb = + let uu___8 = + FStarC_TypeChecker_Env.norm_eff_name + env + c11.FStarC_TypeChecker_Common.eff_name in + FStarC_Syntax_Util.mk_letbinding + (FStar_Pervasives.Inl guard_x) [] + c11.FStarC_TypeChecker_Common.res_typ + uu___8 e12 [] + e12.FStarC_Syntax_Syntax.pos in + let e2 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Syntax_Syntax.mk_binder + guard_x in + [uu___12] in + FStarC_Syntax_Subst.close uu___11 + e_match in + { + FStarC_Syntax_Syntax.lbs = + (false, [lb]); + FStarC_Syntax_Syntax.body1 = + uu___10 + } in + FStarC_Syntax_Syntax.Tm_let uu___9 in + FStarC_Syntax_Syntax.mk uu___8 + top.FStarC_Syntax_Syntax.pos in + FStarC_TypeChecker_Util.maybe_monadic env + e2 + cres1.FStarC_TypeChecker_Common.eff_name + cres1.FStarC_TypeChecker_Common.res_typ) in + let uu___6 = + match ret_opt1 with + | FStar_Pervasives_Native.None -> + (e, cres1, + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t)) + | uu___7 -> + comp_check_expected_typ env e cres1 in + (match uu___6 with + | (e2, cres2, g_expected_type) -> + ((let uu___8 = + FStarC_Compiler_Debug.extreme () in + if uu___8 + then + let uu___9 = + FStarC_Compiler_Range_Ops.string_of_range + top.FStarC_Syntax_Syntax.pos in + let uu___10 = + FStarC_TypeChecker_Common.lcomp_to_string + cres2 in + FStarC_Compiler_Util.print2 + "(%s) Typechecked Tm_match, comp type = %s\n" + uu___9 uu___10 + else ()); + (let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g_c g11 in + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + uu___10 g_branches in + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + uu___9 g_expected_type in + (e2, cres2, uu___8)))))))) + | uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term top in + FStarC_Compiler_Util.format1 "tc_match called on %s\n" uu___3 in + failwith uu___2 +and (tc_synth : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_TypeChecker_Env.env -> + (FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax * + FStarC_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) + Prims.list -> + FStarC_Compiler_Range_Type.range -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.lcomp * + FStarC_TypeChecker_Env.guard_t)) + = + fun head -> + fun env -> + fun args -> + fun rng -> + let uu___ = + match args with + | (tau, FStar_Pervasives_Native.None)::[] -> + (tau, FStar_Pervasives_Native.None) + | (a, FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = uu___1;_}):: + (tau, FStar_Pervasives_Native.None)::[] -> + (tau, (FStar_Pervasives_Native.Some a)) + | uu___1 -> + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range rng + FStarC_Errors_Codes.Fatal_SynthByTacticError () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "synth_by_tactic: bad application") in + match uu___ with + | (tau, atyp) -> + ((let uu___2 = FStarC_Compiler_Effect.op_Bang dbg_Tac in + if uu___2 + then + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + tau in + let uu___4 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_option + FStarC_Syntax_Print.showable_term) atyp in + FStarC_Compiler_Util.print2 + "Processing synth of %s at type %s\n" uu___3 uu___4 + else ()); + (let typ = + match atyp with + | FStar_Pervasives_Native.Some t -> t + | FStar_Pervasives_Native.None -> + let uu___2 = FStarC_TypeChecker_Env.expected_typ env in + (match uu___2 with + | FStar_Pervasives_Native.Some (t, use_eq) -> + (if use_eq + then + (let uu___4 = + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.format1 + "Equality ascription in synth (%s) is not yet supported, please use subtyping" + uu___5 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) t + FStarC_Errors_Codes.Fatal_NotSupported () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4)) + else (); + t) + | FStar_Pervasives_Native.None -> + FStarC_Errors.raise_error + FStarC_TypeChecker_Env.hasRange_env env + FStarC_Errors_Codes.Fatal_SynthByTacticError () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "synth_by_tactic: need a type annotation when no expected type is present")) in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Util.type_u () in + FStar_Pervasives_Native.fst uu___5 in + FStarC_TypeChecker_Env.set_expected_typ env uu___4 in + tc_term uu___3 typ in + match uu___2 with + | (typ1, uu___3, g1) -> + (FStarC_TypeChecker_Rel.force_trivial_guard env g1; + (let uu___5 = + tc_tactic FStarC_Syntax_Syntax.t_unit + FStarC_Syntax_Syntax.t_unit env tau in + match uu___5 with + | (tau1, uu___6, g2) -> + (FStarC_TypeChecker_Rel.force_trivial_guard env g2; + (let t = + env.FStarC_TypeChecker_Env.synth_hook env typ1 + { + FStarC_Syntax_Syntax.n = + (tau1.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = rng; + FStarC_Syntax_Syntax.vars = + (tau1.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (tau1.FStarC_Syntax_Syntax.hash_code) + } in + (let uu___9 = + FStarC_Compiler_Effect.op_Bang dbg_Tac in + if uu___9 + then + let uu___10 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.print1 "Got %s\n" uu___10 + else ()); + FStarC_TypeChecker_Util.check_uvars + tau1.FStarC_Syntax_Syntax.pos t; + (let uu___10 = + let uu___11 = + FStarC_Syntax_Syntax.mk_Total typ1 in + FStarC_TypeChecker_Common.lcomp_of_comp + uu___11 in + (t, uu___10, + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t))))))))) +and (tc_tactic : + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.typ -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.lcomp * + FStarC_TypeChecker_Env.guard_t)) + = + fun a -> + fun b -> + fun env -> + fun tau -> + let env1 = + { + FStarC_TypeChecker_Env.solver = + (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = true; + FStarC_TypeChecker_Env.flychecking = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env.FStarC_TypeChecker_Env.missing_decl) + } in + let uu___ = FStarC_Syntax_Syntax.t_tac_of a b in + tc_check_tot_or_gtot_term env1 tau uu___ + FStar_Pervasives_Native.None +and (check_instantiated_fvar : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.var -> + FStarC_Syntax_Syntax.fv_qual FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.typ -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.lcomp * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun v -> + fun q -> + fun e -> + fun t0 -> + let is_data_ctor uu___ = + match uu___ with + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Data_ctor) + -> true + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Record_ctor uu___1) -> true + | uu___1 -> false in + (let uu___1 = + (is_data_ctor q) && + (let uu___2 = + FStarC_TypeChecker_Env.is_datacon env + v.FStarC_Syntax_Syntax.v in + Prims.op_Negation uu___2) in + if uu___1 + then + let uu___2 = + let uu___3 = + FStarC_Ident.string_of_lid v.FStarC_Syntax_Syntax.v in + FStarC_Compiler_Util.format1 + "Expected a data constructor; got %s" uu___3 in + FStarC_Errors.raise_error FStarC_TypeChecker_Env.hasRange_env + env FStarC_Errors_Codes.Fatal_MissingDataConstructor () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2) + else ()); + (let t = FStarC_Syntax_Util.remove_inacc t0 in + let uu___1 = FStarC_TypeChecker_Util.maybe_instantiate env e t in + match uu___1 with + | (e1, t1, implicits) -> + let tc = + let uu___2 = FStarC_TypeChecker_Env.should_verify env in + if uu___2 + then FStar_Pervasives.Inl t1 + else + (let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.mk_Total t1 in + FStarC_TypeChecker_Common.lcomp_of_comp uu___5 in + FStar_Pervasives.Inr uu___4) in + value_check_expected_typ env e1 tc implicits) +and (tc_value : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.lcomp * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun e -> + let env1 = + FStarC_TypeChecker_Env.set_range env e.FStarC_Syntax_Syntax.pos in + let top = FStarC_Syntax_Subst.compress e in + match top.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_bvar x -> + let uu___ = + let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term top in + FStarC_Compiler_Util.format1 + "Violation of locally nameless convention: %s" uu___1 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) top + FStarC_Errors_Codes.Error_IllScopedTerm () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___) + | FStarC_Syntax_Syntax.Tm_uvar (u, s) -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Syntax_Util.ctx_uvar_typ u in + FStarC_Syntax_Subst.subst' s uu___2 in + FStar_Pervasives.Inl uu___1 in + value_check_expected_typ env1 e uu___ + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t) + | FStarC_Syntax_Syntax.Tm_unknown -> + let r = FStarC_TypeChecker_Env.get_range env1 in + let uu___ = + let uu___1 = FStarC_TypeChecker_Env.expected_typ env1 in + match uu___1 with + | FStar_Pervasives_Native.None -> + let uu___2 = FStarC_Syntax_Util.type_u () in + (match uu___2 with + | (k, u) -> + let uu___3 = + FStarC_TypeChecker_Util.new_implicit_var + "type of user-provided implicit term" r env1 k false in + (match uu___3 with | (t, uu___4, g0) -> (t, g0))) + | FStar_Pervasives_Native.Some (t, use_eq) when use_eq -> + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.format1 + "Equality ascription as an expected type for unk (:%s) is not yet supported." + uu___5 in + FStarC_Errors_Msg.text uu___4 in + let uu___4 = + let uu___5 = + FStarC_Errors_Msg.text "Please use subtyping." in + [uu___5] in + uu___3 :: uu___4 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) e + FStarC_Errors_Codes.Fatal_NotSupported () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___2) + | FStar_Pervasives_Native.Some (t, uu___2) -> + (t, + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t)) in + (match uu___ with + | (t, g0) -> + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Class_Show.show + FStarC_Compiler_Range_Ops.showable_range r in + Prims.strcat "user-provided implicit term at " uu___3 in + FStarC_TypeChecker_Util.new_implicit_var uu___2 r env1 t + false in + (match uu___1 with + | (e1, uu___2, g1) -> + let uu___3 = + let uu___4 = FStarC_Syntax_Syntax.mk_Total t in + FStarC_TypeChecker_Common.lcomp_of_comp uu___4 in + let uu___4 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t g0 g1 in + (e1, uu___3, uu___4))) + | FStarC_Syntax_Syntax.Tm_name x -> + let uu___ = FStarC_TypeChecker_Env.lookup_bv env1 x in + (match uu___ with + | (t, rng) -> + let x1 = + FStarC_Syntax_Syntax.set_range_of_bv + { + FStarC_Syntax_Syntax.ppname = + (x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (x.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = t + } rng in + (FStarC_TypeChecker_Env.insert_bv_info env1 x1 t; + (let e1 = FStarC_Syntax_Syntax.bv_to_name x1 in + let uu___2 = + FStarC_TypeChecker_Util.maybe_instantiate env1 e1 t in + match uu___2 with + | (e2, t1, implicits) -> + let tc = + let uu___3 = FStarC_TypeChecker_Env.should_verify env1 in + if uu___3 + then FStar_Pervasives.Inl t1 + else + (let uu___5 = + let uu___6 = FStarC_Syntax_Syntax.mk_Total t1 in + FStarC_TypeChecker_Common.lcomp_of_comp uu___6 in + FStar_Pervasives.Inr uu___5) in + value_check_expected_typ env1 e2 tc implicits))) + | FStarC_Syntax_Syntax.Tm_uinst + ({ FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar fv; + FStarC_Syntax_Syntax.pos = uu___; + FStarC_Syntax_Syntax.vars = uu___1; + FStarC_Syntax_Syntax.hash_code = uu___2;_}, + uu___3) + when + (FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.synth_lid) + && (Prims.op_Negation env1.FStarC_TypeChecker_Env.phase1) + -> + FStarC_Errors.raise_error FStarC_TypeChecker_Env.hasRange_env env1 + FStarC_Errors_Codes.Fatal_BadlyInstantiatedSynthByTactic () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "Badly instantiated synth_by_tactic") + | FStarC_Syntax_Syntax.Tm_fvar fv when + (FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.synth_lid) + && (Prims.op_Negation env1.FStarC_TypeChecker_Env.phase1) + -> + FStarC_Errors.raise_error FStarC_TypeChecker_Env.hasRange_env env1 + FStarC_Errors_Codes.Fatal_BadlyInstantiatedSynthByTactic () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "Badly instantiated synth_by_tactic") + | FStarC_Syntax_Syntax.Tm_uinst + ({ FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar fv; + FStarC_Syntax_Syntax.pos = uu___; + FStarC_Syntax_Syntax.vars = uu___1; + FStarC_Syntax_Syntax.hash_code = uu___2;_}, + us) + -> + let us1 = FStarC_Compiler_List.map (tc_universe env1) us in + let uu___3 = + FStarC_TypeChecker_Env.lookup_lid env1 + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + (match uu___3 with + | ((us', t), range) -> + let fv1 = FStarC_Syntax_Syntax.set_range_of_fv fv range in + (maybe_warn_on_use env1 fv1; + if + (FStarC_Compiler_List.length us1) <> + (FStarC_Compiler_List.length us') + then + (let uu___6 = + let uu___7 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_fv + fv1 in + let uu___8 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_nat) + (FStarC_Compiler_List.length us1) in + let uu___9 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_nat) + (FStarC_Compiler_List.length us') in + FStarC_Compiler_Util.format3 + "Unexpected number of universe instantiations for \"%s\" (%s vs %s)" + uu___7 uu___8 uu___9 in + FStarC_Errors.raise_error + FStarC_TypeChecker_Env.hasRange_env env1 + FStarC_Errors_Codes.Fatal_UnexpectedNumberOfUniverse () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___6)) + else (); + FStarC_Compiler_List.iter2 + (fun ul -> + fun ur -> + match (ul, ur) with + | (FStarC_Syntax_Syntax.U_unif u'', uu___7) -> + FStarC_Syntax_Unionfind.univ_change u'' ur + | (FStarC_Syntax_Syntax.U_name n1, + FStarC_Syntax_Syntax.U_name n2) when + FStarC_Ident.ident_equals n1 n2 -> () + | uu___7 -> + let uu___8 = + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_fv fv1 in + let uu___10 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_univ ul in + let uu___11 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_univ ur in + FStarC_Compiler_Util.format3 + "Incompatible universe application for %s, expected %s got %s\n" + uu___9 uu___10 uu___11 in + FStarC_Errors.raise_error + FStarC_TypeChecker_Env.hasRange_env env1 + FStarC_Errors_Codes.Fatal_IncompatibleUniverse + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___8)) us' us1; + FStarC_TypeChecker_Env.insert_fv_info env1 fv1 t; + (let e1 = + let uu___8 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_fvar fv1) + e.FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.mk_Tm_uinst uu___8 us1 in + check_instantiated_fvar env1 + fv1.FStarC_Syntax_Syntax.fv_name + fv1.FStarC_Syntax_Syntax.fv_qual e1 t))) + | FStarC_Syntax_Syntax.Tm_uinst (uu___, us) -> + FStarC_Errors.raise_error FStarC_TypeChecker_Env.hasRange_env env1 + FStarC_Errors_Codes.Fatal_UnexpectedNumberOfUniverse () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Universe applications are only allowed on top-level identifiers") + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let uu___ = + FStarC_TypeChecker_Env.lookup_lid env1 + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + (match uu___ with + | ((us, t), range) -> + let fv1 = FStarC_Syntax_Syntax.set_range_of_fv fv range in + (maybe_warn_on_use env1 fv1; + (let uu___3 = FStarC_Compiler_Effect.op_Bang dbg_Range in + if uu___3 + then + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.lid_of_fv fv1 in + FStarC_Class_Show.show FStarC_Ident.showable_lident + uu___5 in + let uu___5 = + FStarC_Compiler_Range_Ops.string_of_range + e.FStarC_Syntax_Syntax.pos in + let uu___6 = + FStarC_Compiler_Range_Ops.string_of_range range in + let uu___7 = + FStarC_Compiler_Range_Ops.string_of_use_range range in + let uu___8 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + t in + FStarC_Compiler_Util.print5 + "Lookup up fvar %s at location %s (lid range = defined at %s, used at %s); got universes type %s\n" + uu___4 uu___5 uu___6 uu___7 uu___8 + else ()); + FStarC_TypeChecker_Env.insert_fv_info env1 fv1 t; + (let e1 = + let uu___4 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_fvar fv1) + e.FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.mk_Tm_uinst uu___4 us in + check_instantiated_fvar env1 + fv1.FStarC_Syntax_Syntax.fv_name + fv1.FStarC_Syntax_Syntax.fv_qual e1 t))) + | FStarC_Syntax_Syntax.Tm_constant c -> + let t = tc_constant env1 top.FStarC_Syntax_Syntax.pos c in + let e1 = + FStarC_Syntax_Syntax.mk (FStarC_Syntax_Syntax.Tm_constant c) + e.FStarC_Syntax_Syntax.pos in + value_check_expected_typ env1 e1 (FStar_Pervasives.Inl t) + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t) + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; FStarC_Syntax_Syntax.comp = c;_} + -> + let uu___ = FStarC_Syntax_Subst.open_comp bs c in + (match uu___ with + | (bs1, c1) -> + let env0 = env1 in + let uu___1 = FStarC_TypeChecker_Env.clear_expected_typ env1 in + (match uu___1 with + | (env2, uu___2) -> + let uu___3 = tc_binders env2 bs1 in + (match uu___3 with + | (bs2, env3, g, us) -> + let uu___4 = tc_comp env3 c1 in + (match uu___4 with + | (c2, uc, f) -> + let e1 = + let uu___5 = FStarC_Syntax_Util.arrow bs2 c2 in + { + FStarC_Syntax_Syntax.n = + (uu___5.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = + (top.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = + (uu___5.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (uu___5.FStarC_Syntax_Syntax.hash_code) + } in + (if + Prims.op_Negation + env3.FStarC_TypeChecker_Env.phase1 + then check_smt_pat env3 e1 bs2 c2 + else (); + (let u = FStarC_Syntax_Syntax.U_max (uc :: us) in + let t = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_type u) + top.FStarC_Syntax_Syntax.pos in + let g1 = + let uu___6 = + FStarC_TypeChecker_Env.close_guard_univs + us bs2 f in + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g uu___6 in + let g2 = + FStarC_TypeChecker_Util.close_guard_implicits + env3 false bs2 g1 in + value_check_expected_typ env0 e1 + (FStar_Pervasives.Inl t) g2)))))) + | FStarC_Syntax_Syntax.Tm_type u -> + let u1 = tc_universe env1 u in + let t = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_type (FStarC_Syntax_Syntax.U_succ u1)) + top.FStarC_Syntax_Syntax.pos in + let e1 = + FStarC_Syntax_Syntax.mk (FStarC_Syntax_Syntax.Tm_type u1) + top.FStarC_Syntax_Syntax.pos in + value_check_expected_typ env1 e1 (FStar_Pervasives.Inl t) + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t) + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x; FStarC_Syntax_Syntax.phi = phi;_} -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Syntax_Syntax.mk_binder x in [uu___2] in + FStarC_Syntax_Subst.open_term uu___1 phi in + (match uu___ with + | (x1, phi1) -> + let env0 = env1 in + let uu___1 = FStarC_TypeChecker_Env.clear_expected_typ env1 in + (match uu___1 with + | (env2, uu___2) -> + let uu___3 = + let uu___4 = FStarC_Compiler_List.hd x1 in + tc_binder env2 uu___4 in + (match uu___3 with + | (x2, env3, f1, u) -> + ((let uu___5 = FStarC_Compiler_Debug.high () in + if uu___5 + then + let uu___6 = + FStarC_Compiler_Range_Ops.string_of_range + top.FStarC_Syntax_Syntax.pos in + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term phi1 in + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_bv + x2.FStarC_Syntax_Syntax.binder_bv in + FStarC_Compiler_Util.print3 + "(%s) Checking refinement formula %s; binder is %s\n" + uu___6 uu___7 uu___8 + else ()); + (let uu___5 = FStarC_Syntax_Util.type_u () in + match uu___5 with + | (t_phi, uu___6) -> + let uu___7 = + tc_check_tot_or_gtot_term env3 phi1 t_phi + (FStar_Pervasives_Native.Some + "refinement formula must be pure or ghost") in + (match uu___7 with + | (phi2, uu___8, f2) -> + let e1 = + let uu___9 = + FStarC_Syntax_Util.refine + x2.FStarC_Syntax_Syntax.binder_bv + phi2 in + { + FStarC_Syntax_Syntax.n = + (uu___9.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = + (top.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = + (uu___9.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (uu___9.FStarC_Syntax_Syntax.hash_code) + } in + let t = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_type u) + top.FStarC_Syntax_Syntax.pos in + let g = + let uu___9 = + FStarC_TypeChecker_Env.close_guard_univs + [u] [x2] f2 in + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + f1 uu___9 in + let g1 = + FStarC_TypeChecker_Util.close_guard_implicits + env3 false [x2] g in + value_check_expected_typ env0 e1 + (FStar_Pervasives.Inl t) g1)))))) + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs; FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = uu___;_} + -> + let bs1 = + FStarC_TypeChecker_Util.maybe_add_implicit_binders env1 bs in + ((let uu___2 = FStarC_Compiler_Debug.medium () in + if uu___2 + then + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + { + FStarC_Syntax_Syntax.n = + (FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs = bs1; + FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = + FStar_Pervasives_Native.None + }); + FStarC_Syntax_Syntax.pos = (top.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = + (top.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (top.FStarC_Syntax_Syntax.hash_code) + } in + FStarC_Compiler_Util.print1 "Abstraction is: %s\n" uu___3 + else ()); + (let uu___2 = FStarC_Syntax_Subst.open_term bs1 body in + match uu___2 with | (bs2, body1) -> tc_abs env1 top bs2 body1)) + | uu___ -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term top in + let uu___3 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term top in + FStarC_Compiler_Util.format2 "Unexpected value: %s (%s)" uu___2 + uu___3 in + failwith uu___1 +and (tc_constant : + FStarC_TypeChecker_Env.env -> + FStarC_Compiler_Range_Type.range -> + FStarC_Const.sconst -> FStarC_Syntax_Syntax.typ) + = + fun env -> + fun r -> + fun c -> + let res = + match c with + | FStarC_Const.Const_unit -> FStarC_Syntax_Syntax.t_unit + | FStarC_Const.Const_bool uu___ -> FStarC_Syntax_Util.t_bool + | FStarC_Const.Const_int (uu___, FStar_Pervasives_Native.None) -> + FStarC_Syntax_Syntax.t_int + | FStarC_Const.Const_int + (uu___, FStar_Pervasives_Native.Some msize) -> + FStarC_Syntax_Syntax.tconst + (match msize with + | (FStarC_Const.Signed, FStarC_Const.Int8) -> + FStarC_Parser_Const.int8_lid + | (FStarC_Const.Signed, FStarC_Const.Int16) -> + FStarC_Parser_Const.int16_lid + | (FStarC_Const.Signed, FStarC_Const.Int32) -> + FStarC_Parser_Const.int32_lid + | (FStarC_Const.Signed, FStarC_Const.Int64) -> + FStarC_Parser_Const.int64_lid + | (FStarC_Const.Unsigned, FStarC_Const.Int8) -> + FStarC_Parser_Const.uint8_lid + | (FStarC_Const.Unsigned, FStarC_Const.Int16) -> + FStarC_Parser_Const.uint16_lid + | (FStarC_Const.Unsigned, FStarC_Const.Int32) -> + FStarC_Parser_Const.uint32_lid + | (FStarC_Const.Unsigned, FStarC_Const.Int64) -> + FStarC_Parser_Const.uint64_lid + | (FStarC_Const.Unsigned, FStarC_Const.Sizet) -> + FStarC_Parser_Const.sizet_lid) + | FStarC_Const.Const_string uu___ -> FStarC_Syntax_Syntax.t_string + | FStarC_Const.Const_real uu___ -> FStarC_Syntax_Syntax.t_real + | FStarC_Const.Const_char uu___ -> + let uu___1 = + FStarC_Syntax_DsEnv.try_lookup_lid + env.FStarC_TypeChecker_Env.dsenv + FStarC_Parser_Const.char_lid in + FStarC_Compiler_Util.must uu___1 + | FStarC_Const.Const_effect -> FStarC_Syntax_Util.ktype0 + | FStarC_Const.Const_range uu___ -> FStarC_Syntax_Syntax.t_range + | FStarC_Const.Const_range_of -> + let uu___ = + let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_const c in + FStarC_Compiler_Util.format1 + "Ill-typed %s: this constant must be fully applied" uu___1 in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range + r FStarC_Errors_Codes.Fatal_IllTyped () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___) + | FStarC_Const.Const_set_range_of -> + let uu___ = + let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_const c in + FStarC_Compiler_Util.format1 + "Ill-typed %s: this constant must be fully applied" uu___1 in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range + r FStarC_Errors_Codes.Fatal_IllTyped () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___) + | FStarC_Const.Const_reify uu___ -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_const c in + FStarC_Compiler_Util.format1 + "Ill-typed %s: this constant must be fully applied" uu___2 in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range + r FStarC_Errors_Codes.Fatal_IllTyped () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) + | FStarC_Const.Const_reflect uu___ -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_const c in + FStarC_Compiler_Util.format1 + "Ill-typed %s: this constant must be fully applied" uu___2 in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range + r FStarC_Errors_Codes.Fatal_IllTyped () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) + | uu___ -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_const c in + Prims.strcat "Unsupported constant: " uu___2 in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range + r FStarC_Errors_Codes.Fatal_UnsupportedConstant () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) in + FStarC_Syntax_Subst.set_use_range r res +and (tc_comp : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.comp -> + (FStarC_Syntax_Syntax.comp * FStarC_Syntax_Syntax.universe * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun c -> + let c0 = c in + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total t -> + let uu___ = FStarC_Syntax_Util.type_u () in + (match uu___ with + | (k, u) -> + let uu___1 = + tc_check_tot_or_gtot_term env t k + FStar_Pervasives_Native.None in + (match uu___1 with + | (t1, uu___2, g) -> + let uu___3 = FStarC_Syntax_Syntax.mk_Total t1 in + (uu___3, u, g))) + | FStarC_Syntax_Syntax.GTotal t -> + let uu___ = FStarC_Syntax_Util.type_u () in + (match uu___ with + | (k, u) -> + let uu___1 = + tc_check_tot_or_gtot_term env t k + FStar_Pervasives_Native.None in + (match uu___1 with + | (t1, uu___2, g) -> + let uu___3 = FStarC_Syntax_Syntax.mk_GTotal t1 in + (uu___3, u, g))) + | FStarC_Syntax_Syntax.Comp c1 -> + let head = + FStarC_Syntax_Syntax.fvar c1.FStarC_Syntax_Syntax.effect_name + FStar_Pervasives_Native.None in + let head1 = + match c1.FStarC_Syntax_Syntax.comp_univs with + | [] -> head + | us -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_uinst (head, us)) + c0.FStarC_Syntax_Syntax.pos in + let tc = + let uu___ = + let uu___1 = + FStarC_Syntax_Syntax.as_arg + c1.FStarC_Syntax_Syntax.result_typ in + uu___1 :: (c1.FStarC_Syntax_Syntax.effect_args) in + FStarC_Syntax_Syntax.mk_Tm_app head1 uu___ + (c1.FStarC_Syntax_Syntax.result_typ).FStarC_Syntax_Syntax.pos in + let uu___ = + tc_check_tot_or_gtot_term + { + FStarC_TypeChecker_Env.solver = + (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = true; + FStarC_TypeChecker_Env.flychecking = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env.FStarC_TypeChecker_Env.missing_decl) + } tc FStarC_Syntax_Syntax.teff FStar_Pervasives_Native.None in + (match uu___ with + | (tc1, uu___1, f) -> + let uu___2 = FStarC_Syntax_Util.head_and_args tc1 in + (match uu___2 with + | (head2, args) -> + let comp_univs = + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.compress head2 in + uu___4.FStarC_Syntax_Syntax.n in + match uu___3 with + | FStarC_Syntax_Syntax.Tm_uinst (uu___4, us) -> us + | uu___4 -> [] in + let uu___3 = FStarC_Syntax_Util.head_and_args tc1 in + (match uu___3 with + | (uu___4, args1) -> + let uu___5 = + let uu___6 = FStarC_Compiler_List.hd args1 in + let uu___7 = FStarC_Compiler_List.tl args1 in + (uu___6, uu___7) in + (match uu___5 with + | (res, args2) -> + let uu___6 = + let uu___7 = + FStarC_Compiler_List.map + (fun uu___8 -> + match uu___8 with + | FStarC_Syntax_Syntax.DECREASES + (FStarC_Syntax_Syntax.Decreases_lex + l) -> + let uu___9 = + FStarC_TypeChecker_Env.clear_expected_typ + env in + (match uu___9 with + | (env1, uu___10) -> + let uu___11 = + FStarC_Compiler_List.fold_left + (fun uu___12 -> + fun e -> + match uu___12 with + | (l1, g) -> + let uu___13 = + tc_tot_or_gtot_term + env1 e in + (match uu___13 + with + | (e1, uu___14, + g_e) -> + let uu___15 + = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g g_e in + ((FStarC_Compiler_List.op_At + l1 + [e1]), + uu___15))) + ([], + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t)) + l in + (match uu___11 with + | (l1, g) -> + ((FStarC_Syntax_Syntax.DECREASES + (FStarC_Syntax_Syntax.Decreases_lex + l1)), g))) + | FStarC_Syntax_Syntax.DECREASES + (FStarC_Syntax_Syntax.Decreases_wf + (rel, e)) -> + let uu___9 = + FStarC_TypeChecker_Env.clear_expected_typ + env in + (match uu___9 with + | (env1, uu___10) -> + let uu___11 = + FStarC_Syntax_Util.type_u + () in + (match uu___11 with + | (t, u_t) -> + let u_r = + FStarC_TypeChecker_Env.new_u_univ + () in + let uu___12 = + FStarC_TypeChecker_Util.new_implicit_var + "implicit for type of the well-founded relation in decreases clause" + rel.FStarC_Syntax_Syntax.pos + env1 t false in + (match uu___12 with + | (a, uu___13, g_a) -> + let wf_t = + let uu___14 = + let uu___15 = + FStarC_TypeChecker_Env.fvar_of_nonqual_lid + env1 + FStarC_Parser_Const.well_founded_relation_lid in + FStarC_Syntax_Syntax.mk_Tm_uinst + uu___15 + [u_t; u_r] in + let uu___15 = + let uu___16 = + FStarC_Syntax_Syntax.as_arg + a in + [uu___16] in + FStarC_Syntax_Syntax.mk_Tm_app + uu___14 uu___15 + rel.FStarC_Syntax_Syntax.pos in + let uu___14 = + let uu___15 = + FStarC_TypeChecker_Env.set_expected_typ + env1 wf_t in + tc_tot_or_gtot_term + uu___15 rel in + (match uu___14 with + | (rel1, uu___15, + g_rel) -> + let uu___16 = + let uu___17 + = + FStarC_TypeChecker_Env.set_expected_typ + env1 a in + tc_tot_or_gtot_term + uu___17 e in + (match uu___16 + with + | (e1, + uu___17, + g_e) -> + let uu___18 + = + let uu___19 + = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g_a g_rel in + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + uu___19 + g_e in + ((FStarC_Syntax_Syntax.DECREASES + (FStarC_Syntax_Syntax.Decreases_wf + (rel1, + e1))), + uu___18)))))) + | f1 -> + (f1, + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t))) + c1.FStarC_Syntax_Syntax.flags in + FStarC_Compiler_List.unzip uu___7 in + (match uu___6 with + | (flags, guards) -> + let u = + env.FStarC_TypeChecker_Env.universe_of + env (FStar_Pervasives_Native.fst res) in + let c2 = + FStarC_Syntax_Syntax.mk_Comp + { + FStarC_Syntax_Syntax.comp_univs = + comp_univs; + FStarC_Syntax_Syntax.effect_name = + (c1.FStarC_Syntax_Syntax.effect_name); + FStarC_Syntax_Syntax.result_typ = + (FStar_Pervasives_Native.fst res); + FStarC_Syntax_Syntax.effect_args = + args2; + FStarC_Syntax_Syntax.flags = flags + } in + let u_c = + FStarC_TypeChecker_Util.universe_of_comp + env u c2 in + let uu___7 = + let uu___8 = + FStarC_Class_Monoid.msum + FStarC_TypeChecker_Common.monoid_guard_t + guards in + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + f uu___8 in + (c2, u_c, uu___7)))))) +and (tc_universe : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.universe -> FStarC_Syntax_Syntax.universe) + = + fun env -> + fun u -> + let rec aux u1 = + let u2 = FStarC_Syntax_Subst.compress_univ u1 in + match u2 with + | FStarC_Syntax_Syntax.U_bvar uu___ -> + failwith "Impossible: locally nameless" + | FStarC_Syntax_Syntax.U_unknown -> failwith "Unknown universe" + | FStarC_Syntax_Syntax.U_unif uu___ -> u2 + | FStarC_Syntax_Syntax.U_zero -> u2 + | FStarC_Syntax_Syntax.U_succ u3 -> + let uu___ = aux u3 in FStarC_Syntax_Syntax.U_succ uu___ + | FStarC_Syntax_Syntax.U_max us -> + let uu___ = FStarC_Compiler_List.map aux us in + FStarC_Syntax_Syntax.U_max uu___ + | FStarC_Syntax_Syntax.U_name x -> + let uu___ = FStarC_TypeChecker_Env.lookup_univ env x in + if uu___ + then u2 + else + (let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_univ + u2 in + Prims.strcat uu___4 " not found" in + Prims.strcat "Universe variable " uu___3 in + failwith uu___2) in + if env.FStarC_TypeChecker_Env.lax_universes + then FStarC_Syntax_Syntax.U_zero + else + (match u with + | FStarC_Syntax_Syntax.U_unknown -> + let uu___1 = FStarC_Syntax_Util.type_u () in + FStar_Pervasives_Native.snd uu___1 + | uu___1 -> aux u) +and (tc_abs_expected_function_typ : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.binders -> + (FStarC_Syntax_Syntax.typ * Prims.bool) FStar_Pervasives_Native.option + -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.typ FStar_Pervasives_Native.option * + FStarC_Syntax_Syntax.binders * FStarC_Syntax_Syntax.binders * + FStarC_Syntax_Syntax.comp FStar_Pervasives_Native.option * + FStarC_TypeChecker_Env.env * FStarC_Syntax_Syntax.term * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun bs -> + fun t0 -> + fun body -> + match t0 with + | FStar_Pervasives_Native.None -> + ((match env.FStarC_TypeChecker_Env.letrecs with + | [] -> () + | uu___1 -> + failwith + "Impossible: Can't have a let rec annotation but no expected type"); + (let uu___1 = tc_binders env bs in + match uu___1 with + | (bs1, envbody, g_env, uu___2) -> + (FStar_Pervasives_Native.None, bs1, [], + FStar_Pervasives_Native.None, envbody, body, g_env))) + | FStar_Pervasives_Native.Some (t, use_eq) -> + let t1 = FStarC_Syntax_Subst.compress t in + let rec as_function_typ norm1 t2 = + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t2 in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_uvar uu___1 -> + ((match env.FStarC_TypeChecker_Env.letrecs with + | [] -> () + | uu___3 -> + failwith + "Impossible: uvar abs with non-empty environment"); + (let uu___3 = tc_binders env bs in + match uu___3 with + | (bs1, envbody, g_env, uu___4) -> + let uu___5 = + FStarC_TypeChecker_Env.clear_expected_typ envbody in + (match uu___5 with + | (envbody1, uu___6) -> + ((FStar_Pervasives_Native.Some t2), bs1, [], + FStar_Pervasives_Native.None, envbody1, + body, g_env)))) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Tm_uvar uu___1; + FStarC_Syntax_Syntax.pos = uu___2; + FStarC_Syntax_Syntax.vars = uu___3; + FStarC_Syntax_Syntax.hash_code = uu___4;_}; + FStarC_Syntax_Syntax.args = uu___5;_} + -> + ((match env.FStarC_TypeChecker_Env.letrecs with + | [] -> () + | uu___7 -> + failwith + "Impossible: uvar abs with non-empty environment"); + (let uu___7 = tc_binders env bs in + match uu___7 with + | (bs1, envbody, g_env, uu___8) -> + let uu___9 = + FStarC_TypeChecker_Env.clear_expected_typ envbody in + (match uu___9 with + | (envbody1, uu___10) -> + ((FStar_Pervasives_Native.Some t2), bs1, [], + FStar_Pervasives_Native.None, envbody1, + body, g_env)))) + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = b; + FStarC_Syntax_Syntax.phi = uu___1;_} + -> + let uu___2 = + as_function_typ norm1 b.FStarC_Syntax_Syntax.sort in + (match uu___2 with + | (uu___3, bs1, bs', copt, env_body, body1, g_env) -> + ((FStar_Pervasives_Native.Some t2), bs1, bs', copt, + env_body, body1, g_env)) + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs_expected; + FStarC_Syntax_Syntax.comp = c_expected;_} + -> + let uu___1 = + FStarC_Syntax_Subst.open_comp bs_expected c_expected in + (match uu___1 with + | (bs_expected1, c_expected1) -> + let check_actuals_against_formals env1 bs1 + bs_expected2 body1 = + let rec handle_more uu___2 c_expected2 body2 = + match uu___2 with + | (env_bs, bs2, more, guard_env, subst) -> + (match more with + | FStar_Pervasives_Native.None -> + let uu___3 = + FStarC_Syntax_Subst.subst_comp subst + c_expected2 in + (env_bs, bs2, guard_env, uu___3, body2) + | FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr more_bs_expected) + -> + let c = + let uu___3 = + FStarC_Syntax_Util.arrow + more_bs_expected c_expected2 in + FStarC_Syntax_Syntax.mk_Total uu___3 in + let uu___3 = + FStarC_Syntax_Subst.subst_comp subst + c in + (env_bs, bs2, guard_env, uu___3, body2) + | FStar_Pervasives_Native.Some + (FStar_Pervasives.Inl more_bs) -> + let c = + FStarC_Syntax_Subst.subst_comp subst + c_expected2 in + let uu___3 = + (FStarC_Options.ml_ish ()) || + (FStarC_Syntax_Util.is_named_tot c) in + if uu___3 + then + let t3 = + FStarC_TypeChecker_Normalize.unfold_whnf + env_bs + (FStarC_Syntax_Util.comp_result c) in + (match t3.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 = + bs_expected3; + FStarC_Syntax_Syntax.comp = + c_expected3;_} + -> + let uu___4 = + FStarC_Syntax_Subst.open_comp + bs_expected3 c_expected3 in + (match uu___4 with + | (bs_expected4, c_expected4) + -> + let uu___5 = + tc_abs_check_binders + env_bs more_bs + bs_expected4 use_eq in + (match uu___5 with + | (env_bs_bs', bs', more1, + guard'_env_bs, subst1) + -> + let guard'_env = + FStarC_TypeChecker_Env.close_guard + env_bs bs2 + guard'_env_bs in + let uu___6 = + let uu___7 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + guard_env + guard'_env in + (env_bs_bs', + (FStarC_Compiler_List.op_At + bs2 bs'), + more1, uu___7, + subst1) in + handle_more uu___6 + c_expected4 body2)) + | uu___4 -> + let body3 = + FStarC_Syntax_Util.abs more_bs + body2 + FStar_Pervasives_Native.None in + (env_bs, bs2, guard_env, c, + body3)) + else + (let body3 = + FStarC_Syntax_Util.abs more_bs + body2 + FStar_Pervasives_Native.None in + (env_bs, bs2, guard_env, c, body3))) in + let uu___2 = + tc_abs_check_binders env1 bs1 bs_expected2 + use_eq in + handle_more uu___2 c_expected1 body1 in + let mk_letrec_env envbody bs1 c = + let letrecs = guard_letrecs envbody bs1 c in + let envbody1 = + { + FStarC_TypeChecker_Env.solver = + (envbody.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (envbody.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (envbody.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (envbody.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (envbody.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (envbody.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (envbody.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (envbody.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (envbody.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (envbody.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (envbody.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (envbody.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (envbody.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = []; + FStarC_TypeChecker_Env.top_level = + (envbody.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (envbody.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (envbody.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (envbody.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (envbody.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (envbody.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (envbody.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (envbody.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (envbody.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (envbody.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (envbody.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (envbody.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (envbody.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (envbody.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (envbody.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (envbody.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (envbody.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (envbody.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (envbody.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (envbody.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (envbody.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (envbody.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (envbody.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (envbody.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (envbody.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (envbody.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (envbody.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (envbody.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (envbody.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (envbody.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (envbody.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (envbody.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (envbody.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (envbody.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (envbody.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (envbody.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (envbody.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (envbody.FStarC_TypeChecker_Env.missing_decl) + } in + let uu___2 = + FStarC_Compiler_List.fold_left + (fun uu___3 -> + fun uu___4 -> + match (uu___3, uu___4) with + | ((env1, letrec_binders, g), + (l, t3, u_names)) -> + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_TypeChecker_Env.clear_expected_typ + env1 in + FStar_Pervasives_Native.fst + uu___7 in + tc_term uu___6 t3 in + (match uu___5 with + | (t4, uu___6, g') -> + let env2 = + FStarC_TypeChecker_Env.push_let_binding + env1 l (u_names, t4) in + let lb = + match l with + | FStar_Pervasives.Inl x -> + let uu___7 = + FStarC_Syntax_Syntax.mk_binder + { + FStarC_Syntax_Syntax.ppname + = + (x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index + = + (x.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort + = t4 + } in + uu___7 :: letrec_binders + | uu___7 -> letrec_binders in + let uu___7 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g g' in + (env2, lb, uu___7))) + (envbody1, [], + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t)) + letrecs in + match uu___2 with + | (envbody2, letrec_binders, g) -> + let uu___3 = + FStarC_TypeChecker_Env.close_guard envbody2 + bs1 g in + (envbody2, letrec_binders, uu___3) in + let envbody = + { + FStarC_TypeChecker_Env.solver = + (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = []; + FStarC_TypeChecker_Env.top_level = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env.FStarC_TypeChecker_Env.missing_decl) + } in + let uu___2 = + check_actuals_against_formals envbody bs + bs_expected1 body in + (match uu___2 with + | (envbody1, bs1, g_env, c, body1) -> + let envbody2 = + { + FStarC_TypeChecker_Env.solver = + (envbody1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (envbody1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (envbody1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (envbody1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (envbody1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (envbody1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (envbody1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (envbody1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (envbody1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (envbody1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (envbody1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (envbody1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (envbody1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (envbody1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (envbody1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (envbody1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (envbody1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (envbody1.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (envbody1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (envbody1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (envbody1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (envbody1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (envbody1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (envbody1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (envbody1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (envbody1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (envbody1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (envbody1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (envbody1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (envbody1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (envbody1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (envbody1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (envbody1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (envbody1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (envbody1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (envbody1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (envbody1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (envbody1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (envbody1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (envbody1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (envbody1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (envbody1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (envbody1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (envbody1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (envbody1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (envbody1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (envbody1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (envbody1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (envbody1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (envbody1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (envbody1.FStarC_TypeChecker_Env.missing_decl) + } in + let uu___3 = mk_letrec_env envbody2 bs1 c in + (match uu___3 with + | (envbody3, letrecs, g_annots) -> + let envbody4 = + FStarC_TypeChecker_Env.set_expected_typ_maybe_eq + envbody3 + (FStarC_Syntax_Util.comp_result c) + use_eq in + let uu___4 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g_env g_annots in + ((FStar_Pervasives_Native.Some t2), bs1, + letrecs, + (FStar_Pervasives_Native.Some c), + envbody4, body1, uu___4)))) + | uu___1 -> + if Prims.op_Negation norm1 + then + let uu___2 = + let uu___3 = + FStarC_TypeChecker_Normalize.unfold_whnf env t2 in + FStarC_Syntax_Util.unascribe uu___3 in + as_function_typ true uu___2 + else + (let uu___3 = + tc_abs_expected_function_typ env bs + FStar_Pervasives_Native.None body in + match uu___3 with + | (uu___4, bs1, uu___5, c_opt, envbody, body1, g_env) + -> + ((FStar_Pervasives_Native.Some t2), bs1, [], + c_opt, envbody, body1, g_env)) in + as_function_typ false t1 +and (tc_abs_check_binders : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.binders -> + Prims.bool -> + (FStarC_TypeChecker_Env.env * FStarC_Syntax_Syntax.binders * + (FStarC_Syntax_Syntax.binders, FStarC_Syntax_Syntax.binders) + FStar_Pervasives.either FStar_Pervasives_Native.option * + FStarC_TypeChecker_Env.guard_t * FStarC_Syntax_Syntax.subst_t)) + = + fun env -> + fun bs -> + fun bs_expected -> + fun use_eq -> + let rec aux uu___ bs1 bs_expected1 = + match uu___ with + | (env1, subst) -> + (match (bs1, bs_expected1) with + | ([], []) -> + (env1, [], FStar_Pervasives_Native.None, + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t), subst) + | ({ FStarC_Syntax_Syntax.binder_bv = uu___1; + FStarC_Syntax_Syntax.binder_qual = + FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.binder_positivity = uu___2; + FStarC_Syntax_Syntax.binder_attrs = uu___3;_}::uu___4, + { FStarC_Syntax_Syntax.binder_bv = hd_e; + FStarC_Syntax_Syntax.binder_qual = q; + FStarC_Syntax_Syntax.binder_positivity = pqual; + FStarC_Syntax_Syntax.binder_attrs = attrs;_}::uu___5) + when FStarC_Syntax_Syntax.is_bqual_implicit_or_meta q -> + let bv = + let uu___6 = + let uu___7 = + FStarC_Ident.range_of_id + hd_e.FStarC_Syntax_Syntax.ppname in + FStar_Pervasives_Native.Some uu___7 in + let uu___7 = + FStarC_Syntax_Subst.subst subst + hd_e.FStarC_Syntax_Syntax.sort in + FStarC_Syntax_Syntax.new_bv uu___6 uu___7 in + let uu___6 = + let uu___7 = + FStarC_Syntax_Syntax.mk_binder_with_attrs bv q pqual + attrs in + uu___7 :: bs1 in + aux (env1, subst) uu___6 bs_expected1 + | ({ FStarC_Syntax_Syntax.binder_bv = hd; + FStarC_Syntax_Syntax.binder_qual = imp; + FStarC_Syntax_Syntax.binder_positivity = pqual_actual; + FStarC_Syntax_Syntax.binder_attrs = attrs;_}::bs2, + { FStarC_Syntax_Syntax.binder_bv = hd_expected; + FStarC_Syntax_Syntax.binder_qual = imp'; + FStarC_Syntax_Syntax.binder_positivity = pqual_expected; + FStarC_Syntax_Syntax.binder_attrs = attrs';_}::bs_expected2) + -> + ((let special q1 q2 = + match (q1, q2) with + | (FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Meta uu___2), + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Meta uu___3)) -> true + | (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Equality)) -> true + | (FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Implicit uu___2), + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Meta uu___3)) -> true + | uu___2 -> false in + let uu___2 = + (Prims.op_Negation (special imp imp')) && + (let uu___3 = FStarC_Syntax_Util.eq_bqual imp imp' in + Prims.op_Negation uu___3) in + if uu___2 + then + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_bv hd in + FStarC_Compiler_Util.format1 + "Inconsistent implicit argument annotation on argument %s" + uu___6 in + FStarC_Errors_Msg.text uu___5 in + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Errors_Msg.text "Got:" in + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_Syntax_Print.bqual_to_string imp in + FStarC_Pprint.doc_of_string uu___10 in + FStarC_Pprint.squotes uu___9 in + FStarC_Pprint.prefix (Prims.of_int (2)) + Prims.int_one uu___7 uu___8 in + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Errors_Msg.text "Expected:" in + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Syntax_Print.bqual_to_string + imp' in + FStarC_Pprint.doc_of_string uu___12 in + FStarC_Pprint.squotes uu___11 in + FStarC_Pprint.prefix (Prims.of_int (2)) + Prims.int_one uu___9 uu___10 in + [uu___8] in + uu___6 :: uu___7 in + uu___4 :: uu___5 in + FStarC_Errors.raise_error + FStarC_Syntax_Syntax.hasRange_bv hd + FStarC_Errors_Codes.Fatal_InconsistentImplicitArgumentAnnotation + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___3) + else ()); + (let positivity_qual_to_string uu___2 = + match uu___2 with + | FStar_Pervasives_Native.None -> "None" + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.BinderStrictlyPositive) -> + "StrictlyPositive" + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.BinderUnused) -> "Unused" in + (let uu___3 = + let uu___4 = + FStarC_TypeChecker_Common.check_positivity_qual + true pqual_expected pqual_actual in + Prims.op_Negation uu___4 in + if uu___3 + then + let uu___4 = + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_bv hd in + FStarC_Compiler_Util.format3 + "Inconsistent positivity qualifier on argument %s; Expected qualifier %s, found qualifier %s" + uu___5 + (positivity_qual_to_string pqual_expected) + (positivity_qual_to_string pqual_actual) in + FStarC_Errors.raise_error + FStarC_Syntax_Syntax.hasRange_bv hd + FStarC_Errors_Codes.Fatal_InconsistentQualifierAnnotation + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4) + else ()); + (let expected_t = + FStarC_Syntax_Subst.subst subst + hd_expected.FStarC_Syntax_Syntax.sort in + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Syntax_Util.unmeta + hd.FStarC_Syntax_Syntax.sort in + uu___5.FStarC_Syntax_Syntax.n in + match uu___4 with + | FStarC_Syntax_Syntax.Tm_unknown -> + (expected_t, + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t)) + | uu___5 -> + ((let uu___7 = FStarC_Compiler_Debug.high () in + if uu___7 + then + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_bv hd in + FStarC_Compiler_Util.print1 + "Checking binder %s\n" uu___8 + else ()); + (let uu___7 = + tc_tot_or_gtot_term env1 + hd.FStarC_Syntax_Syntax.sort in + match uu___7 with + | (t, uu___8, g1_env) -> + let g2_env = + let label_guard g = + let uu___9 = + FStarC_Errors_Msg.mkmsg + "Type annotation on parameter incompatible with the expected type" in + FStarC_TypeChecker_Util.label_guard + (hd.FStarC_Syntax_Syntax.sort).FStarC_Syntax_Syntax.pos + uu___9 g in + let uu___9 = + FStarC_TypeChecker_Rel.teq_nosmt env1 + t expected_t in + match uu___9 with + | FStar_Pervasives_Native.Some g -> + FStarC_TypeChecker_Rel.resolve_implicits + env1 g + | FStar_Pervasives_Native.None -> + if use_eq + then + let uu___10 = + FStarC_TypeChecker_Rel.teq env1 + t expected_t in + label_guard uu___10 + else + (let uu___11 = + FStarC_TypeChecker_Rel.get_subtyping_prop + env1 expected_t t in + match uu___11 with + | FStar_Pervasives_Native.None + -> + let uu___12 = + FStarC_TypeChecker_Env.get_range + env1 in + FStarC_TypeChecker_Err.raise_basic_type_error + env1 uu___12 + FStar_Pervasives_Native.None + expected_t t + | FStar_Pervasives_Native.Some + g_env -> label_guard g_env) in + let uu___9 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g1_env g2_env in + (t, uu___9))) in + match uu___3 with + | (t, g_env) -> + let hd1 = + { + FStarC_Syntax_Syntax.ppname = + (hd.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (hd.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = t + } in + let combine_attrs attrs1 attrs'1 = + let diff = + FStarC_Compiler_List.filter + (fun attr' -> + let uu___4 = + FStarC_Compiler_List.existsb + (fun attr -> + let uu___5 = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm + env1 attr attr' in + uu___5 = + FStarC_TypeChecker_TermEqAndSimplify.Equal) + attrs1 in + Prims.op_Negation uu___4) attrs'1 in + FStarC_Compiler_List.op_At attrs1 diff in + let b = + let uu___4 = combine_attrs attrs attrs' in + { + FStarC_Syntax_Syntax.binder_bv = hd1; + FStarC_Syntax_Syntax.binder_qual = imp; + FStarC_Syntax_Syntax.binder_positivity = + pqual_expected; + FStarC_Syntax_Syntax.binder_attrs = uu___4 + } in + (check_erasable_binder_attributes env1 + b.FStarC_Syntax_Syntax.binder_attrs t; + (let b_expected = + { + FStarC_Syntax_Syntax.binder_bv = + hd_expected; + FStarC_Syntax_Syntax.binder_qual = imp'; + FStarC_Syntax_Syntax.binder_positivity = + pqual_expected; + FStarC_Syntax_Syntax.binder_attrs = attrs' + } in + let env_b = push_binding env1 b in + let subst1 = + let uu___5 = + FStarC_Syntax_Syntax.bv_to_name hd1 in + maybe_extend_subst subst b_expected uu___5 in + let uu___5 = + aux (env_b, subst1) bs2 bs_expected2 in + match uu___5 with + | (env_bs, bs3, rest, g'_env_b, subst2) -> + let g'_env = + FStarC_TypeChecker_Env.close_guard env_bs + [b] g'_env_b in + let uu___6 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g_env g'_env in + (env_bs, (b :: bs3), rest, uu___6, subst2)))))) + | (rest, []) -> + (env1, [], + (FStar_Pervasives_Native.Some + (FStar_Pervasives.Inl rest)), + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t), subst) + | ([], rest) -> + (env1, [], + (FStar_Pervasives_Native.Some + (FStar_Pervasives.Inr rest)), + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t), subst)) in + aux (env, []) bs bs_expected +and (tc_abs : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.lcomp * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun top -> + fun bs -> + fun body -> + let fail msg t = + FStarC_TypeChecker_Err.expected_a_term_of_type_t_got_a_function + env top.FStarC_Syntax_Syntax.pos msg t top in + let env0 = env in + let uu___ = FStarC_TypeChecker_Env.clear_expected_typ env in + match uu___ with + | (env1, topt) -> + ((let uu___2 = FStarC_Compiler_Debug.high () in + if uu___2 + then + let uu___3 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_option + (FStarC_Class_Show.show_tuple2 + FStarC_Syntax_Print.showable_term + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool))) topt in + let uu___4 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) + env1.FStarC_TypeChecker_Env.top_level in + FStarC_Compiler_Util.print2 + "!!!!!!!!!!!!!!!Expected type is (%s), top_level=%s\n" + uu___3 uu___4 + else ()); + (let uu___2 = tc_abs_expected_function_typ env1 bs topt body in + match uu___2 with + | (tfun_opt, bs1, letrec_binders, c_opt, envbody, body1, + g_env) -> + ((let uu___4 = FStarC_Compiler_Debug.extreme () in + if uu___4 + then + let uu___5 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_option + FStarC_Syntax_Print.showable_term) tfun_opt in + let uu___6 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_option + FStarC_Syntax_Print.showable_comp) c_opt in + let uu___7 = + let uu___8 = + FStarC_TypeChecker_Env.expected_typ envbody in + FStarC_Class_Show.show + (FStarC_Class_Show.show_option + (FStarC_Class_Show.show_tuple2 + FStarC_Syntax_Print.showable_term + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool))) + uu___8 in + FStarC_Compiler_Util.print3 + "After expected_function_typ, tfun_opt: %s, c_opt: %s, and expected type in envbody: %s\n" + uu___5 uu___6 uu___7 + else ()); + (let uu___5 = FStarC_Compiler_Effect.op_Bang dbg_NYC in + if uu___5 + then + let uu___6 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binder) bs1 in + let uu___7 = + FStarC_TypeChecker_Rel.guard_to_string env1 g_env in + FStarC_Compiler_Util.print2 + "!!!!!!!!!!!!!!!Guard for function with binders %s is %s\n" + uu___6 uu___7 + else ()); + (let envbody1 = + FStarC_TypeChecker_Env.set_range envbody + body1.FStarC_Syntax_Syntax.pos in + let uu___5 = + let uu___6 = + let use_eq_opt = + match topt with + | FStar_Pervasives_Native.Some (uu___7, use_eq) + -> FStar_Pervasives_Native.Some use_eq + | uu___7 -> FStar_Pervasives_Native.None in + let uu___7 = + (FStarC_Compiler_Util.is_some c_opt) && + (let uu___8 = + let uu___9 = + FStarC_Syntax_Subst.compress body1 in + uu___9.FStarC_Syntax_Syntax.n in + match uu___8 with + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = args;_} + when + (FStarC_Compiler_List.length args) = + Prims.int_one + -> + let uu___9 = + let uu___10 = + FStarC_Syntax_Subst.compress head in + uu___10.FStarC_Syntax_Syntax.n in + (match uu___9 with + | FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_reflect uu___10) + -> true + | uu___10 -> false) + | uu___9 -> false) in + if uu___7 + then + let uu___8 = + let uu___9 = + FStarC_TypeChecker_Env.clear_expected_typ + envbody1 in + FStar_Pervasives_Native.fst uu___9 in + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_Compiler_Util.must c_opt in + FStar_Pervasives.Inr uu___14 in + let uu___14 = + FStarC_Compiler_Util.must use_eq_opt in + (uu___13, FStar_Pervasives_Native.None, + uu___14) in + { + FStarC_Syntax_Syntax.tm = body1; + FStarC_Syntax_Syntax.asc = uu___12; + FStarC_Syntax_Syntax.eff_opt = + FStar_Pervasives_Native.None + } in + FStarC_Syntax_Syntax.Tm_ascribed uu___11 in + FStarC_Syntax_Syntax.mk uu___10 + FStarC_Compiler_Range_Type.dummyRange in + (uu___8, uu___9, (FStar_Pervasives.Inr ())) + else + (let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Syntax_Subst.compress body1 in + uu___12.FStarC_Syntax_Syntax.n in + (c_opt, uu___11) in + match uu___10 with + | (FStar_Pervasives_Native.None, + FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = uu___11; + FStarC_Syntax_Syntax.asc = + (FStar_Pervasives.Inr expected_c, + uu___12, uu___13); + FStarC_Syntax_Syntax.eff_opt = uu___14;_}) + -> FStar_Pervasives.Inr () + | uu___11 -> + FStar_Pervasives.Inl + (FStarC_Compiler_Util.dflt false + use_eq_opt) in + (envbody1, body1, uu___9)) in + match uu___6 with + | (envbody2, body2, should_check_expected_effect) -> + let uu___7 = + tc_term + { + FStarC_TypeChecker_Env.solver = + (envbody2.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (envbody2.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (envbody2.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (envbody2.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (envbody2.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (envbody2.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (envbody2.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (envbody2.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (envbody2.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (envbody2.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (envbody2.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (envbody2.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (envbody2.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (envbody2.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = false; + FStarC_TypeChecker_Env.check_uvars = + (envbody2.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (envbody2.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (envbody2.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (envbody2.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (envbody2.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (envbody2.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (envbody2.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (envbody2.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (envbody2.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (envbody2.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (envbody2.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (envbody2.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (envbody2.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (envbody2.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (envbody2.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (envbody2.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (envbody2.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (envbody2.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (envbody2.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (envbody2.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (envbody2.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (envbody2.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (envbody2.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (envbody2.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (envbody2.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (envbody2.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (envbody2.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (envbody2.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (envbody2.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (envbody2.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (envbody2.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (envbody2.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (envbody2.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (envbody2.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (envbody2.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (envbody2.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (envbody2.FStarC_TypeChecker_Env.missing_decl) + } body2 in + (match uu___7 with + | (body3, cbody, guard_body) -> + let guard_body1 = + FStarC_TypeChecker_Rel.solve_non_tactic_deferred_constraints + true envbody2 guard_body in + (match should_check_expected_effect with + | FStar_Pervasives.Inl use_eq -> + let uu___8 = + FStarC_TypeChecker_Common.lcomp_comp + cbody in + (match uu___8 with + | (cbody1, g_lc) -> + let uu___9 = + FStarC_Errors.with_ctx + "While checking that lambda abstraction has expected effect" + (fun uu___10 -> + check_expected_effect + envbody2 use_eq c_opt + (body3, cbody1)) in + (match uu___9 with + | (body4, cbody2, guard) -> + let uu___10 = + let uu___11 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + guard_body1 g_lc in + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + uu___11 guard in + (body4, cbody2, uu___10))) + | FStar_Pervasives.Inr uu___8 -> + let uu___9 = + FStarC_TypeChecker_Common.lcomp_comp + cbody in + (match uu___9 with + | (cbody1, g_lc) -> + let uu___10 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + guard_body1 g_lc in + (body3, cbody1, uu___10)))) in + match uu___5 with + | (body2, cbody, guard_body) -> + ((let uu___7 = FStarC_Compiler_Debug.extreme () in + if uu___7 + then + let uu___8 = + FStarC_TypeChecker_Rel.guard_to_string env1 + guard_body in + FStarC_Compiler_Util.print1 + "tc_abs: guard_body: %s\n" uu___8 + else ()); + (let guard_body1 = + if env1.FStarC_TypeChecker_Env.top_level + then + ((let uu___8 = + FStarC_Compiler_Debug.medium () in + if uu___8 + then + let uu___9 = + FStarC_TypeChecker_Rel.guard_to_string + env1 guard_body in + FStarC_Compiler_Util.print1 + "tc_abs: FORCING guard_body: %s\n" + uu___9 + else ()); + FStarC_TypeChecker_Rel.discharge_guard + envbody1 guard_body) + else guard_body in + let guard = + let guard_body2 = + FStarC_TypeChecker_Env.close_guard envbody1 + (FStarC_Compiler_List.op_At bs1 + letrec_binders) guard_body1 in + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g_env guard_body2 in + let guard1 = + FStarC_TypeChecker_Util.close_guard_implicits + env1 false bs1 guard in + let tfun_computed = + FStarC_Syntax_Util.arrow bs1 cbody in + let e = + let uu___7 = + let uu___8 = + FStarC_Syntax_Util.residual_comp_of_comp + (FStarC_Compiler_Util.dflt cbody c_opt) in + FStar_Pervasives_Native.Some uu___8 in + FStarC_Syntax_Util.abs bs1 body2 uu___7 in + FStarC_Compiler_List.iter + (fun b -> + let uu___8 = FStarC_Options.no_positivity () in + if uu___8 + then () + else + ((let uu___11 = + (FStarC_Syntax_Util.is_binder_unused b) + && + (let uu___12 = + FStarC_TypeChecker_Positivity.name_unused_in_type + envbody1 + b.FStarC_Syntax_Syntax.binder_bv + body2 in + Prims.op_Negation uu___12) in + if uu___11 + then + let uu___12 = + let uu___13 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_binder + b in + FStarC_Compiler_Util.format1 + "Binder %s is marked unused, but its use in the definition is not" + uu___13 in + FStarC_Errors.raise_error + FStarC_Syntax_Syntax.hasRange_binder + b + FStarC_Errors_Codes.Error_InductiveTypeNotSatisfyPositivityCondition + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___12) + else ()); + (let uu___11 = + (FStarC_Syntax_Util.is_binder_strictly_positive + b) + && + (let uu___12 = + FStarC_TypeChecker_Positivity.name_strictly_positive_in_type + envbody1 + b.FStarC_Syntax_Syntax.binder_bv + body2 in + Prims.op_Negation uu___12) in + if uu___11 + then + let uu___12 = + let uu___13 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_binder + b in + FStarC_Compiler_Util.format1 + "Binder %s is marked strictly positive, but its use in the definition is not" + uu___13 in + FStarC_Errors.raise_error + FStarC_Syntax_Syntax.hasRange_binder + b + FStarC_Errors_Codes.Error_InductiveTypeNotSatisfyPositivityCondition + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___12) + else ()))) bs1; + (let uu___8 = + match tfun_opt with + | FStar_Pervasives_Native.Some t -> + let t1 = FStarC_Syntax_Subst.compress t in + let uu___9 = + match topt with + | FStar_Pervasives_Native.Some + (t2, use_eq) -> (t2, use_eq) + | FStar_Pervasives_Native.None -> + failwith + "Impossible! tc_abs: if tfun_computed is Some, expected topt to also be Some" in + (match uu___9 with + | (t_annot, use_eq) -> + (match t1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_arrow + uu___10 -> (e, t_annot, guard1) + | uu___10 -> + let lc = + let uu___11 = + FStarC_Syntax_Syntax.mk_Total + tfun_computed in + FStarC_TypeChecker_Common.lcomp_of_comp + uu___11 in + let uu___11 = + FStarC_TypeChecker_Util.check_has_type_maybe_coerce + env1 e lc t1 use_eq in + (match uu___11 with + | (e1, uu___12, guard') -> + let guard'1 = + let uu___13 = + FStarC_TypeChecker_Err.subtyping_failed + env1 + lc.FStarC_TypeChecker_Common.res_typ + t1 () in + FStarC_TypeChecker_Util.label_guard + e1.FStarC_Syntax_Syntax.pos + uu___13 guard' in + let uu___13 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + guard1 guard'1 in + (e1, t_annot, uu___13)))) + | FStar_Pervasives_Native.None -> + (e, tfun_computed, guard1) in + match uu___8 with + | (e1, tfun, guard2) -> + let c = FStarC_Syntax_Syntax.mk_Total tfun in + let uu___9 = + let uu___10 = + FStarC_TypeChecker_Common.lcomp_of_comp + c in + FStarC_TypeChecker_Util.strengthen_precondition + FStar_Pervasives_Native.None env1 e1 + uu___10 guard2 in + (match uu___9 with | (c1, g) -> (e1, c1, g))))))))) +and (check_application_args : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.comp -> + FStarC_TypeChecker_Env.guard_t -> + (FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax * + FStarC_Syntax_Syntax.arg_qualifier + FStar_Pervasives_Native.option) Prims.list -> + (FStarC_Syntax_Syntax.typ * Prims.bool) + FStar_Pervasives_Native.option -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.lcomp * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun head -> + fun chead -> + fun ghead -> + fun args -> + fun expected_topt -> + let n_args = FStarC_Compiler_List.length args in + let r = FStarC_TypeChecker_Env.get_range env in + let thead = FStarC_Syntax_Util.comp_result chead in + (let uu___1 = FStarC_Compiler_Debug.high () in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show + FStarC_Compiler_Range_Ops.showable_range + head.FStarC_Syntax_Syntax.pos in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + thead in + let uu___4 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + (FStarC_Class_Show.show_tuple2 + FStarC_Syntax_Print.showable_term + FStarC_Syntax_Print.showable_aqual)) args in + FStarC_Compiler_Util.print3 + "(%s) Type of head is %s\nArgs = %s\n" uu___2 uu___3 + uu___4 + else ()); + (let monadic_application uu___1 subst arg_comps_rev + arg_rets_rev guard fvs bs = + match uu___1 with + | (head1, chead1, ghead1, cres) -> + let uu___2 = + match bs with + | [] -> + let uu___3 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + ghead1 guard in + (cres, uu___3) + | uu___3 -> + let g = + let uu___4 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + ghead1 guard in + FStarC_TypeChecker_Rel.solve_deferred_constraints + env uu___4 in + let uu___4 = + let uu___5 = FStarC_Syntax_Util.arrow bs cres in + FStarC_Syntax_Syntax.mk_Total uu___5 in + (uu___4, g) in + (match uu___2 with + | (cres1, guard1) -> + let uu___3 = + check_no_escape + (FStar_Pervasives_Native.Some head1) env fvs + (FStarC_Syntax_Util.comp_result cres1) in + (match uu___3 with + | (rt, g0) -> + let uu___4 = + let uu___5 = + FStarC_Syntax_Util.set_result_typ cres1 rt in + let uu___6 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g0 guard1 in + (uu___5, uu___6) in + (match uu___4 with + | (cres2, guard2) -> + ((let uu___6 = + FStarC_Compiler_Debug.medium () in + if uu___6 + then + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_comp + cres2 in + FStarC_Compiler_Util.print1 + "\t Type of result cres is %s\n" + uu___7 + else ()); + (let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Subst.subst_comp + subst chead1 in + FStarC_TypeChecker_Common.lcomp_of_comp + uu___8 in + let uu___8 = + let uu___9 = + FStarC_Syntax_Subst.subst_comp + subst cres2 in + FStarC_TypeChecker_Common.lcomp_of_comp + uu___9 in + (uu___7, uu___8) in + match uu___6 with + | (chead2, cres3) -> + let uu___7 = + let head_is_pure_and_some_arg_is_effectful + = + (FStarC_TypeChecker_Common.is_pure_or_ghost_lcomp + chead2) + && + (FStarC_Compiler_Util.for_some + (fun uu___8 -> + match uu___8 with + | (uu___9, uu___10, lc) + -> + (let uu___11 = + FStarC_TypeChecker_Common.is_pure_or_ghost_lcomp + lc in + Prims.op_Negation + uu___11) + || + (FStarC_TypeChecker_Util.should_not_inline_lc + lc)) + arg_comps_rev) in + let term = + FStarC_Syntax_Syntax.mk_Tm_app + head1 + (FStarC_Compiler_List.rev + arg_rets_rev) + head1.FStarC_Syntax_Syntax.pos in + let uu___8 = + (FStarC_TypeChecker_Common.is_pure_or_ghost_lcomp + cres3) + && + head_is_pure_and_some_arg_is_effectful in + if uu___8 + then + ((let uu___10 = + FStarC_Compiler_Debug.extreme + () in + if uu___10 + then + let uu___11 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + term in + FStarC_Compiler_Util.print1 + "(a) Monadic app: Return inserted in monadic application: %s\n" + uu___11 + else ()); + (let uu___10 = + FStarC_TypeChecker_Util.maybe_assume_result_eq_pure_term + env term cres3 in + (uu___10, true))) + else + ((let uu___11 = + FStarC_Compiler_Debug.extreme + () in + if uu___11 + then + let uu___12 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + term in + FStarC_Compiler_Util.print1 + "(a) Monadic app: No return inserted in monadic application: %s\n" + uu___12 + else ()); + (cres3, false)) in + (match uu___7 with + | (cres4, inserted_return_in_cres) + -> + let comp = + let arg_rets_names_opt = + FStarC_Compiler_List.map + (fun uu___8 -> + match uu___8 with + | (t, uu___9) -> + let uu___10 = + let uu___11 = + FStarC_Syntax_Subst.compress + t in + uu___11.FStarC_Syntax_Syntax.n in + (match uu___10 + with + | FStarC_Syntax_Syntax.Tm_name + bv -> + FStar_Pervasives_Native.Some + bv + | uu___11 -> + FStar_Pervasives_Native.None)) + (FStarC_Compiler_List.rev + arg_rets_rev) in + let push_option_names_to_env + = + FStarC_Compiler_List.fold_left + (fun env1 -> + fun name_opt -> + let uu___8 = + FStarC_Compiler_Util.map_option + (FStarC_TypeChecker_Env.push_bv + env1) + name_opt in + FStarC_Compiler_Util.dflt + env1 uu___8) in + let uu___8 = + FStarC_Compiler_List.fold_left + (fun uu___9 -> + fun uu___10 -> + match (uu___9, + uu___10) + with + | ((i, out_c), + ((e, q), x, c)) + -> + ((let uu___12 = + FStarC_Compiler_Debug.extreme + () in + if uu___12 + then + let uu___13 + = + match x + with + | + FStar_Pervasives_Native.None + -> "_" + | + FStar_Pervasives_Native.Some + x1 -> + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_bv + x1 in + let uu___14 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + e in + let uu___15 + = + FStarC_TypeChecker_Common.lcomp_to_string + c in + FStarC_Compiler_Util.print3 + "(b) Monadic app: Binding argument %s : %s of type (%s)\n" + uu___13 + uu___14 + uu___15 + else ()); + (let env1 = + if + inserted_return_in_cres + then + let uu___12 + = + let uu___13 + = + FStarC_Compiler_List.splitAt + ((FStarC_Compiler_List.length + arg_rets_names_opt) + - i) + arg_rets_names_opt in + FStar_Pervasives_Native.fst + uu___13 in + push_option_names_to_env + env + uu___12 + else env in + let uu___12 = + FStarC_TypeChecker_Common.is_pure_or_ghost_lcomp + c in + if uu___12 + then + let uu___13 + = + FStarC_TypeChecker_Util.bind + e.FStarC_Syntax_Syntax.pos + env1 + (FStar_Pervasives_Native.Some + e) c + (x, + out_c) in + ((i + + Prims.int_one), + uu___13) + else + (let uu___14 + = + FStarC_TypeChecker_Util.bind + e.FStarC_Syntax_Syntax.pos + env1 + FStar_Pervasives_Native.None + c + (x, + out_c) in + ((i + + Prims.int_one), + uu___14))))) + (Prims.int_one, cres4) + arg_comps_rev in + match uu___8 with + | (uu___9, comp1) -> + let env1 = + push_option_names_to_env + env + arg_rets_names_opt in + ((let uu___11 = + FStarC_Compiler_Debug.extreme + () in + if uu___11 + then + let uu___12 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + head1 in + let uu___13 = + FStarC_TypeChecker_Common.lcomp_to_string + chead2 in + FStarC_Compiler_Util.print2 + "(c) Monadic app: Binding head %s, chead: %s\n" + uu___12 uu___13 + else ()); + (let uu___11 = + FStarC_TypeChecker_Common.is_pure_or_ghost_lcomp + chead2 in + if uu___11 + then + FStarC_TypeChecker_Util.bind + head1.FStarC_Syntax_Syntax.pos + env1 + (FStar_Pervasives_Native.Some + head1) chead2 + (FStar_Pervasives_Native.None, + comp1) + else + FStarC_TypeChecker_Util.bind + head1.FStarC_Syntax_Syntax.pos + env1 + FStar_Pervasives_Native.None + chead2 + (FStar_Pervasives_Native.None, + comp1))) in + let shortcuts_evaluation_order + = + let uu___8 = + let uu___9 = + FStarC_Syntax_Subst.compress + head1 in + uu___9.FStarC_Syntax_Syntax.n in + match uu___8 with + | FStarC_Syntax_Syntax.Tm_fvar + fv -> + (FStarC_Syntax_Syntax.fv_eq_lid + fv + FStarC_Parser_Const.op_And) + || + (FStarC_Syntax_Syntax.fv_eq_lid + fv + FStarC_Parser_Const.op_Or) + | uu___9 -> false in + let app = + if + shortcuts_evaluation_order + then + let args1 = + FStarC_Compiler_List.fold_left + (fun args2 -> + fun uu___8 -> + match uu___8 with + | (arg, uu___9, + uu___10) -> + arg :: args2) + [] arg_comps_rev in + let app1 = + FStarC_Syntax_Syntax.mk_Tm_app + head1 args1 r in + let app2 = + FStarC_TypeChecker_Util.maybe_lift + env app1 + cres4.FStarC_TypeChecker_Common.eff_name + comp.FStarC_TypeChecker_Common.eff_name + comp.FStarC_TypeChecker_Common.res_typ in + FStarC_TypeChecker_Util.maybe_monadic + env app2 + comp.FStarC_TypeChecker_Common.eff_name + comp.FStarC_TypeChecker_Common.res_typ + else + (let uu___9 = + let map_fun uu___10 = + match uu___10 with + | ((e, q), uu___11, + c) -> + ((let uu___13 = + FStarC_Compiler_Debug.extreme + () in + if uu___13 + then + let uu___14 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + e in + let uu___15 = + FStarC_TypeChecker_Common.lcomp_to_string + c in + FStarC_Compiler_Util.print2 + "For arg e=(%s) c=(%s)... " + uu___14 + uu___15 + else ()); + (let uu___13 = + FStarC_TypeChecker_Common.is_pure_or_ghost_lcomp + c in + if uu___13 + then + ((let uu___15 + = + FStarC_Compiler_Debug.extreme + () in + if uu___15 + then + FStarC_Compiler_Util.print_string + "... not lifting\n" + else ()); + (FStar_Pervasives_Native.None, + (e, q))) + else + (let warn_effectful_args + = + (FStarC_TypeChecker_Util.must_erase_for_extraction + env + chead2.FStarC_TypeChecker_Common.res_typ) + && + (let uu___15 + = + let uu___16 + = + let uu___17 + = + FStarC_Syntax_Util.un_uinst + head1 in + uu___17.FStarC_Syntax_Syntax.n in + match uu___16 + with + | + FStarC_Syntax_Syntax.Tm_fvar + fv -> + let uu___17 + = + FStarC_Parser_Const.psconst + "ignore" in + FStarC_Syntax_Syntax.fv_eq_lid + fv + uu___17 + | + uu___17 + -> true in + Prims.op_Negation + uu___15) in + if + warn_effectful_args + then + (let uu___16 + = + let uu___17 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + e in + let uu___18 + = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + c.FStarC_TypeChecker_Common.eff_name in + let uu___19 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + head1 in + FStarC_Compiler_Util.format3 + "Effectful argument %s (%s) to erased function %s, consider let binding it" + uu___17 + uu___18 + uu___19 in + FStarC_Errors.log_issue + (FStarC_Syntax_Syntax.has_range_syntax + ()) e + FStarC_Errors_Codes.Warning_EffectfulArgumentToErasedFunction + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + uu___16)) + else (); + (let uu___17 + = + FStarC_Compiler_Debug.extreme + () in + if uu___17 + then + FStarC_Compiler_Util.print_string + "... lifting!\n" + else ()); + (let x = + FStarC_Syntax_Syntax.new_bv + FStar_Pervasives_Native.None + c.FStarC_TypeChecker_Common.res_typ in + let e1 = + FStarC_TypeChecker_Util.maybe_lift + env e + c.FStarC_TypeChecker_Common.eff_name + comp.FStarC_TypeChecker_Common.eff_name + c.FStarC_TypeChecker_Common.res_typ in + let uu___17 + = + let uu___18 + = + FStarC_Syntax_Syntax.bv_to_name + x in + (uu___18, + q) in + ((FStar_Pervasives_Native.Some + (x, + (c.FStarC_TypeChecker_Common.eff_name), + (c.FStarC_TypeChecker_Common.res_typ), + e1)), + uu___17))))) in + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + let uu___14 = + FStarC_Syntax_Syntax.as_arg + head1 in + (uu___14, + FStar_Pervasives_Native.None, + chead2) in + uu___13 :: + arg_comps_rev in + FStarC_Compiler_List.map + map_fun uu___12 in + FStarC_Compiler_List.split + uu___11 in + match uu___10 with + | (lifted_args, + reverse_args) -> + let uu___11 = + let uu___12 = + FStarC_Compiler_List.hd + reverse_args in + FStar_Pervasives_Native.fst + uu___12 in + let uu___12 = + let uu___13 = + FStarC_Compiler_List.tl + reverse_args in + FStarC_Compiler_List.rev + uu___13 in + (lifted_args, + uu___11, uu___12) in + match uu___9 with + | (lifted_args, head2, + args1) -> + let app1 = + FStarC_Syntax_Syntax.mk_Tm_app + head2 args1 r in + let app2 = + FStarC_TypeChecker_Util.maybe_lift + env app1 + cres4.FStarC_TypeChecker_Common.eff_name + comp.FStarC_TypeChecker_Common.eff_name + comp.FStarC_TypeChecker_Common.res_typ in + let app3 = + FStarC_TypeChecker_Util.maybe_monadic + env app2 + comp.FStarC_TypeChecker_Common.eff_name + comp.FStarC_TypeChecker_Common.res_typ in + let bind_lifted_args + e uu___10 = + match uu___10 with + | FStar_Pervasives_Native.None + -> e + | FStar_Pervasives_Native.Some + (x, m, t, e1) + -> + let lb = + FStarC_Syntax_Util.mk_letbinding + (FStar_Pervasives.Inl + x) [] t m + e1 [] + e1.FStarC_Syntax_Syntax.pos in + let letbinding + = + let uu___11 = + let uu___12 + = + let uu___13 + = + let uu___14 + = + let uu___15 + = + FStarC_Syntax_Syntax.mk_binder + x in + [uu___15] in + FStarC_Syntax_Subst.close + uu___14 e in + { + FStarC_Syntax_Syntax.lbs + = + (false, + [lb]); + FStarC_Syntax_Syntax.body1 + = uu___13 + } in + FStarC_Syntax_Syntax.Tm_let + uu___12 in + FStarC_Syntax_Syntax.mk + uu___11 + e.FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 + = + letbinding; + FStarC_Syntax_Syntax.meta + = + (FStarC_Syntax_Syntax.Meta_monadic + (m, + (comp.FStarC_TypeChecker_Common.res_typ))) + }) + e.FStarC_Syntax_Syntax.pos in + FStarC_Compiler_List.fold_left + bind_lifted_args + app3 lifted_args) in + let uu___8 = + FStarC_TypeChecker_Util.strengthen_precondition + FStar_Pervasives_Native.None + env app comp guard2 in + (match uu___8 with + | (comp1, g) -> + ((let uu___10 = + FStarC_Compiler_Debug.extreme + () in + if uu___10 + then + let uu___11 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + app in + let uu___12 = + FStarC_TypeChecker_Common.lcomp_to_string + comp1 in + FStarC_Compiler_Util.print2 + "(d) Monadic app: type of app\n\t(%s)\n\t: %s\n" + uu___11 uu___12 + else ()); + (app, comp1, g))))))))) in + let rec tc_args head_info uu___1 bs args1 = + match uu___1 with + | (subst, outargs, arg_rets, g, fvs) -> + let instantiate_one_and_go b rest_bs args2 = + let r1 = + match outargs with + | [] -> head.FStarC_Syntax_Syntax.pos + | ((t, uu___2), uu___3, uu___4)::uu___5 -> + let uu___6 = + FStarC_Compiler_Range_Type.def_range + head.FStarC_Syntax_Syntax.pos in + let uu___7 = + let uu___8 = + FStarC_Compiler_Range_Type.use_range + head.FStarC_Syntax_Syntax.pos in + let uu___9 = + FStarC_Compiler_Range_Type.use_range + t.FStarC_Syntax_Syntax.pos in + FStarC_Compiler_Range_Ops.union_rng uu___8 + uu___9 in + FStarC_Compiler_Range_Type.range_of_rng uu___6 + uu___7 in + let b1 = FStarC_Syntax_Subst.subst_binder subst b in + let uu___2 = + FStarC_TypeChecker_Util.instantiate_one_binder env + r1 b1 in + match uu___2 with + | (tm, ty, aq, g') -> + let uu___3 = + check_no_escape + (FStar_Pervasives_Native.Some head) env fvs ty in + (match uu___3 with + | (ty1, g_ex) -> + let guard = + let uu___4 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g g' in + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + uu___4 g_ex in + let arg = (tm, aq) in + let subst1 = + (FStarC_Syntax_Syntax.NT + ((b1.FStarC_Syntax_Syntax.binder_bv), + tm)) + :: subst in + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Syntax.mk_Total ty1 in + FStarC_TypeChecker_Common.lcomp_of_comp + uu___8 in + (arg, FStar_Pervasives_Native.None, + uu___7) in + uu___6 :: outargs in + (subst1, uu___5, (arg :: arg_rets), guard, + fvs) in + tc_args head_info uu___4 rest_bs args2) in + (match (bs, args1) with + | ({ FStarC_Syntax_Syntax.binder_bv = x; + FStarC_Syntax_Syntax.binder_qual = + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Implicit uu___2); + FStarC_Syntax_Syntax.binder_positivity = uu___3; + FStarC_Syntax_Syntax.binder_attrs = uu___4;_}::rest, + (uu___5, FStar_Pervasives_Native.None)::uu___6) -> + let uu___7 = FStarC_Compiler_List.hd bs in + instantiate_one_and_go uu___7 rest args1 + | ({ FStarC_Syntax_Syntax.binder_bv = x; + FStarC_Syntax_Syntax.binder_qual = + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Meta uu___2); + FStarC_Syntax_Syntax.binder_positivity = uu___3; + FStarC_Syntax_Syntax.binder_attrs = uu___4;_}::rest, + (uu___5, FStar_Pervasives_Native.None)::uu___6) -> + let uu___7 = FStarC_Compiler_List.hd bs in + instantiate_one_and_go uu___7 rest args1 + | ({ FStarC_Syntax_Syntax.binder_bv = x; + FStarC_Syntax_Syntax.binder_qual = + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Meta tau); + FStarC_Syntax_Syntax.binder_positivity = uu___2; + FStarC_Syntax_Syntax.binder_attrs = b_attrs;_}::rest, + ({ + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Tm_unknown; + FStarC_Syntax_Syntax.pos = uu___3; + FStarC_Syntax_Syntax.vars = uu___4; + FStarC_Syntax_Syntax.hash_code = uu___5;_}, + FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = uu___6;_})::rest') + -> + let uu___7 = FStarC_Compiler_List.hd bs in + instantiate_one_and_go uu___7 rest rest' + | ({ FStarC_Syntax_Syntax.binder_bv = x; + FStarC_Syntax_Syntax.binder_qual = bqual; + FStarC_Syntax_Syntax.binder_positivity = uu___2; + FStarC_Syntax_Syntax.binder_attrs = b_attrs;_}::rest, + (e, aq)::rest') -> + let aq1 = + let uu___3 = FStarC_Compiler_List.hd bs in + check_expected_aqual_for_binder aq uu___3 + e.FStarC_Syntax_Syntax.pos in + let targ = + FStarC_Syntax_Subst.subst subst + x.FStarC_Syntax_Syntax.sort in + let bqual1 = + FStarC_Syntax_Subst.subst_bqual subst bqual in + let x1 = + { + FStarC_Syntax_Syntax.ppname = + (x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (x.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = targ + } in + ((let uu___4 = FStarC_Compiler_Debug.extreme () in + if uu___4 + then + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_bv x1 in + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + x1.FStarC_Syntax_Syntax.sort in + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term e in + let uu___8 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_subst_elt) + subst in + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term targ in + FStarC_Compiler_Util.print5 + "\tFormal is %s : %s\tType of arg %s (after subst %s) = %s\n" + uu___5 uu___6 uu___7 uu___8 uu___9 + else ()); + (let uu___4 = + check_no_escape + (FStar_Pervasives_Native.Some head) env fvs + targ in + match uu___4 with + | (targ1, g_ex) -> + let env1 = + FStarC_TypeChecker_Env.set_expected_typ_maybe_eq + env targ1 (is_eq bqual1) in + ((let uu___6 = FStarC_Compiler_Debug.high () in + if uu___6 + then + let uu___7 = + FStarC_Class_Tagged.tag_of + FStarC_Syntax_Syntax.tagged_term e in + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term e in + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + targ1 in + let uu___10 = + FStarC_Compiler_Util.string_of_bool + (is_eq bqual1) in + FStarC_Compiler_Util.print4 + "Checking arg (%s) %s at type %s with use_eq:%s\n" + uu___7 uu___8 uu___9 uu___10 + else ()); + (let uu___6 = tc_term env1 e in + match uu___6 with + | (e1, c, g_e) -> + let g1 = + let uu___7 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g_ex g in + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + uu___7 g_e in + let arg = (e1, aq1) in + let xterm = + let uu___7 = + FStarC_Syntax_Syntax.bv_to_name x1 in + (uu___7, aq1) in + let uu___7 = + (FStarC_TypeChecker_Common.is_tot_or_gtot_lcomp + c) + || + (FStarC_TypeChecker_Util.is_pure_or_ghost_effect + env1 + c.FStarC_TypeChecker_Common.eff_name) in + if uu___7 + then + let subst1 = + let uu___8 = + FStarC_Compiler_List.hd bs in + maybe_extend_subst subst uu___8 e1 in + tc_args head_info + (subst1, + ((arg, + (FStar_Pervasives_Native.Some + x1), c) :: outargs), (xterm + :: arg_rets), g1, fvs) rest rest' + else + tc_args head_info + (subst, + ((arg, + (FStar_Pervasives_Native.Some + x1), c) :: outargs), (xterm + :: arg_rets), g1, (x1 :: fvs)) + rest rest')))) + | (uu___2, []) -> + monadic_application head_info subst outargs + arg_rets g fvs bs + | ([], arg::uu___2) -> + let uu___3 = + monadic_application head_info subst outargs + arg_rets g fvs [] in + (match uu___3 with + | (head1, chead1, ghead1) -> + let uu___4 = + let uu___5 = + FStarC_TypeChecker_Common.lcomp_comp + chead1 in + match uu___5 with + | (c, g1) -> + let uu___6 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + ghead1 g1 in + (c, uu___6) in + (match uu___4 with + | (chead2, ghead2) -> + let rec aux norm1 solve ghead3 tres = + let tres1 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Subst.compress tres in + FStarC_Syntax_Util.unrefine uu___6 in + FStarC_Syntax_Util.unmeta_safe uu___5 in + match tres1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs1; + FStarC_Syntax_Syntax.comp = cres';_} + -> + let uu___5 = + FStarC_Syntax_Subst.open_comp bs1 + cres' in + (match uu___5 with + | (bs2, cres'1) -> + let head_info1 = + (head1, chead2, ghead3, + cres'1) in + ((let uu___7 = + FStarC_Compiler_Debug.low + () in + if uu___7 + then + FStarC_Errors.log_issue + (FStarC_Syntax_Syntax.has_range_syntax + ()) tres1 + FStarC_Errors_Codes.Warning_RedundantExplicitCurrying + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Potentially redundant explicit currying of a function type") + else ()); + tc_args head_info1 + ([], [], [], + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t), + []) bs2 args1)) + | uu___5 when Prims.op_Negation norm1 + -> + let rec norm_tres tres2 = + let tres3 = + let uu___6 = + FStarC_TypeChecker_Normalize.unfold_whnf + env tres2 in + FStarC_Syntax_Util.unascribe + uu___6 in + let uu___6 = + let uu___7 = + FStarC_Syntax_Subst.compress + tres3 in + uu___7.FStarC_Syntax_Syntax.n in + match uu___6 with + | FStarC_Syntax_Syntax.Tm_refine + { + FStarC_Syntax_Syntax.b = + { + FStarC_Syntax_Syntax.ppname + = uu___7; + FStarC_Syntax_Syntax.index + = uu___8; + FStarC_Syntax_Syntax.sort + = tres4;_}; + FStarC_Syntax_Syntax.phi = + uu___9;_} + -> norm_tres tres4 + | uu___7 -> tres3 in + let uu___6 = norm_tres tres1 in + aux true solve ghead3 uu___6 + | uu___5 when Prims.op_Negation solve + -> + let ghead4 = + FStarC_TypeChecker_Rel.solve_deferred_constraints + env ghead3 in + aux norm1 true ghead4 tres1 + | uu___5 -> + let uu___6 = + FStarC_Syntax_Syntax.argpos arg in + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Errors_Msg.text + "Too many arguments to function of type" in + let uu___10 = + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_term + thead in + FStarC_Pprint.prefix + (Prims.of_int (4)) + Prims.int_one uu___9 uu___10 in + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Errors_Msg.text + "Got" in + let uu___12 = + let uu___13 = + FStarC_Class_PP.pp + FStarC_Class_PP.pp_int + n_args in + let uu___14 = + FStarC_Errors_Msg.text + "arguments" in + FStarC_Pprint.op_Hat_Slash_Hat + uu___13 uu___14 in + FStarC_Pprint.op_Hat_Slash_Hat + uu___11 uu___12 in + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Errors_Msg.text + "Remaining type is" in + let uu___14 = + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_term + tres1 in + FStarC_Pprint.prefix + (Prims.of_int (4)) + Prims.int_one uu___13 + uu___14 in + [uu___12] in + uu___10 :: uu___11 in + uu___8 :: uu___9 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + uu___6 + FStarC_Errors_Codes.Fatal_ToManyArgumentToFunction + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___7) in + aux false false ghead2 + (FStarC_Syntax_Util.comp_result chead2)))) in + let rec check_function_app tf guard = + let tf1 = FStarC_TypeChecker_Normalize.unfold_whnf env tf in + let uu___1 = + let uu___2 = FStarC_Syntax_Util.unmeta tf1 in + uu___2.FStarC_Syntax_Syntax.n in + match uu___1 with + | FStarC_Syntax_Syntax.Tm_uvar uu___2 -> + let uu___3 = + FStarC_Compiler_List.fold_right + (fun uu___4 -> + fun uu___5 -> + match uu___5 with + | (bs, guard1) -> + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Util.type_u () in + FStar_Pervasives_Native.fst uu___8 in + FStarC_TypeChecker_Util.new_implicit_var + "formal parameter" + tf1.FStarC_Syntax_Syntax.pos env uu___7 + false in + (match uu___6 with + | (t, uu___7, g) -> + let uu___8 = + let uu___9 = + FStarC_Syntax_Syntax.null_binder t in + uu___9 :: bs in + let uu___9 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g guard1 in + (uu___8, uu___9))) args ([], guard) in + (match uu___3 with + | (bs, guard1) -> + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Syntax_Util.type_u () in + FStar_Pervasives_Native.fst uu___7 in + FStarC_TypeChecker_Util.new_implicit_var + "result type" tf1.FStarC_Syntax_Syntax.pos + env uu___6 false in + match uu___5 with + | (t, uu___6, g) -> + let uu___7 = FStarC_Options.ml_ish () in + if uu___7 + then + let uu___8 = FStarC_Syntax_Util.ml_comp t r in + let uu___9 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + guard1 g in + (uu___8, uu___9) + else + (let uu___9 = + FStarC_Syntax_Syntax.mk_Total t in + let uu___10 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + guard1 g in + (uu___9, uu___10)) in + (match uu___4 with + | (cres, guard2) -> + let bs_cres = FStarC_Syntax_Util.arrow bs cres in + ((let uu___6 = + FStarC_Compiler_Debug.extreme () in + if uu___6 + then + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head in + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term tf1 in + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + bs_cres in + FStarC_Compiler_Util.print3 + "Forcing the type of %s from %s to %s\n" + uu___7 uu___8 uu___9 + else ()); + (let g = + let uu___6 = + FStarC_TypeChecker_Rel.teq env tf1 + bs_cres in + FStarC_TypeChecker_Rel.solve_deferred_constraints + env uu___6 in + let uu___6 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g guard2 in + check_function_app bs_cres uu___6)))) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Tm_uvar uu___2; + FStarC_Syntax_Syntax.pos = uu___3; + FStarC_Syntax_Syntax.vars = uu___4; + FStarC_Syntax_Syntax.hash_code = uu___5;_}; + FStarC_Syntax_Syntax.args = uu___6;_} + -> + let uu___7 = + FStarC_Compiler_List.fold_right + (fun uu___8 -> + fun uu___9 -> + match uu___9 with + | (bs, guard1) -> + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Syntax_Util.type_u () in + FStar_Pervasives_Native.fst uu___12 in + FStarC_TypeChecker_Util.new_implicit_var + "formal parameter" + tf1.FStarC_Syntax_Syntax.pos env + uu___11 false in + (match uu___10 with + | (t, uu___11, g) -> + let uu___12 = + let uu___13 = + FStarC_Syntax_Syntax.null_binder t in + uu___13 :: bs in + let uu___13 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g guard1 in + (uu___12, uu___13))) args ([], guard) in + (match uu___7 with + | (bs, guard1) -> + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = FStarC_Syntax_Util.type_u () in + FStar_Pervasives_Native.fst uu___11 in + FStarC_TypeChecker_Util.new_implicit_var + "result type" tf1.FStarC_Syntax_Syntax.pos + env uu___10 false in + match uu___9 with + | (t, uu___10, g) -> + let uu___11 = FStarC_Options.ml_ish () in + if uu___11 + then + let uu___12 = + FStarC_Syntax_Util.ml_comp t r in + let uu___13 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + guard1 g in + (uu___12, uu___13) + else + (let uu___13 = + FStarC_Syntax_Syntax.mk_Total t in + let uu___14 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + guard1 g in + (uu___13, uu___14)) in + (match uu___8 with + | (cres, guard2) -> + let bs_cres = FStarC_Syntax_Util.arrow bs cres in + ((let uu___10 = + FStarC_Compiler_Debug.extreme () in + if uu___10 + then + let uu___11 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head in + let uu___12 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term tf1 in + let uu___13 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + bs_cres in + FStarC_Compiler_Util.print3 + "Forcing the type of %s from %s to %s\n" + uu___11 uu___12 uu___13 + else ()); + (let g = + let uu___10 = + FStarC_TypeChecker_Rel.teq env tf1 + bs_cres in + FStarC_TypeChecker_Rel.solve_deferred_constraints + env uu___10 in + let uu___10 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g guard2 in + check_function_app bs_cres uu___10)))) + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = c;_} + -> + let uu___2 = FStarC_Syntax_Subst.open_comp bs c in + (match uu___2 with + | (bs1, c1) -> + let head_info = (head, chead, ghead, c1) in + ((let uu___4 = FStarC_Compiler_Debug.extreme () in + if uu___4 + then + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head in + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term tf1 in + let uu___7 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_binder) bs1 in + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_comp c1 in + FStarC_Compiler_Util.print4 + "######tc_args of head %s @ %s with formals=%s and result type=%s\n" + uu___5 uu___6 uu___7 uu___8 + else ()); + tc_args head_info ([], [], [], guard, []) bs1 args)) + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = bv; + FStarC_Syntax_Syntax.phi = uu___2;_} + -> check_function_app bv.FStarC_Syntax_Syntax.sort guard + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t; + FStarC_Syntax_Syntax.asc = uu___2; + FStarC_Syntax_Syntax.eff_opt = uu___3;_} + -> check_function_app t guard + | uu___2 -> + FStarC_TypeChecker_Err.expected_function_typ env + head.FStarC_Syntax_Syntax.pos tf1 in + check_function_app thead + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t)) +and (check_short_circuit_args : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.comp -> + FStarC_TypeChecker_Env.guard_t -> + (FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax * + FStarC_Syntax_Syntax.arg_qualifier + FStar_Pervasives_Native.option) Prims.list -> + (FStarC_Syntax_Syntax.typ * Prims.bool) + FStar_Pervasives_Native.option -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.lcomp * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun head -> + fun chead -> + fun g_head -> + fun args -> + fun expected_topt -> + let r = FStarC_TypeChecker_Env.get_range env in + let tf = + FStarC_Syntax_Subst.compress + (FStarC_Syntax_Util.comp_result chead) in + match tf.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = c;_} + when + (FStarC_Syntax_Util.is_total_comp c) && + ((FStarC_Compiler_List.length bs) = + (FStarC_Compiler_List.length args)) + -> + let res_t = FStarC_Syntax_Util.comp_result c in + let uu___ = + FStarC_Compiler_List.fold_left2 + (fun uu___1 -> + fun uu___2 -> + fun b -> + match (uu___1, uu___2) with + | ((seen, guard, ghost), (e, aq)) -> + let aq1 = + check_expected_aqual_for_binder aq b + e.FStarC_Syntax_Syntax.pos in + let uu___3 = + tc_check_tot_or_gtot_term env e + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort + (FStar_Pervasives_Native.Some + "arguments to short circuiting operators must be pure or ghost") in + (match uu___3 with + | (e1, c1, g) -> + let short = + FStarC_TypeChecker_Util.short_circuit + head seen in + let g1 = + let uu___4 = + FStarC_TypeChecker_Env.guard_of_guard_formula + short in + FStarC_TypeChecker_Env.imp_guard + uu___4 g in + let ghost1 = + ghost || + ((let uu___4 = + FStarC_TypeChecker_Common.is_total_lcomp + c1 in + Prims.op_Negation uu___4) && + (let uu___4 = + FStarC_TypeChecker_Util.is_pure_effect + env + c1.FStarC_TypeChecker_Common.eff_name in + Prims.op_Negation uu___4)) in + let uu___4 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + guard g1 in + ((FStarC_Compiler_List.op_At seen + [(e1, aq1)]), uu___4, ghost1))) + ([], g_head, false) args bs in + (match uu___ with + | (args1, guard, ghost) -> + let e = FStarC_Syntax_Syntax.mk_Tm_app head args1 r in + let c1 = + if ghost + then + let uu___1 = FStarC_Syntax_Syntax.mk_GTotal res_t in + FStarC_TypeChecker_Common.lcomp_of_comp uu___1 + else FStarC_TypeChecker_Common.lcomp_of_comp c in + let uu___1 = + FStarC_TypeChecker_Util.strengthen_precondition + FStar_Pervasives_Native.None env e c1 guard in + (match uu___1 with | (c2, g) -> (e, c2, g))) + | uu___ -> + check_application_args env head chead g_head args + expected_topt +and (tc_pat : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.pat -> + (FStarC_Syntax_Syntax.pat * FStarC_Syntax_Syntax.bv Prims.list * + FStarC_Syntax_Syntax.term Prims.list * FStarC_TypeChecker_Env.env * + FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.term * + FStarC_TypeChecker_Env.guard_t * Prims.bool)) + = + fun env -> + fun pat_t -> + fun p0 -> + let fail msg = + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range + p0.FStarC_Syntax_Syntax.p + FStarC_Errors_Codes.Fatal_MismatchedPatternType () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic msg) in + let expected_pat_typ env1 pos scrutinee_t = + let rec aux norm1 t = + let t1 = FStarC_Syntax_Util.unrefine t in + let uu___ = FStarC_Syntax_Util.head_and_args t1 in + match uu___ with + | (head, args) -> + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress head in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_uinst + ({ + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar + f; + FStarC_Syntax_Syntax.pos = uu___2; + FStarC_Syntax_Syntax.vars = uu___3; + FStarC_Syntax_Syntax.hash_code = uu___4;_}, + us) + -> unfold_once t1 f us args + | FStarC_Syntax_Syntax.Tm_fvar f -> unfold_once t1 f [] args + | uu___2 -> + if norm1 + then t1 + else + (let uu___4 = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.HNF; + FStarC_TypeChecker_Env.Unmeta; + FStarC_TypeChecker_Env.Unascribe; + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant] env1 t1 in + aux true uu___4)) + and unfold_once t f us args = + let uu___ = + FStarC_TypeChecker_Env.is_type_constructor env1 + (f.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + if uu___ + then t + else + (let uu___2 = + FStarC_TypeChecker_Env.lookup_definition + [FStarC_TypeChecker_Env.Unfold + FStarC_Syntax_Syntax.delta_constant] env1 + (f.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + match uu___2 with + | FStar_Pervasives_Native.None -> t + | FStar_Pervasives_Native.Some head_def_ts -> + let uu___3 = + FStarC_TypeChecker_Env.inst_tscheme_with head_def_ts us in + (match uu___3 with + | (uu___4, head_def) -> + let t' = + FStarC_Syntax_Syntax.mk_Tm_app head_def args + t.FStarC_Syntax_Syntax.pos in + let t'1 = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Iota] env1 t' in + aux false t'1)) in + let uu___ = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Beta; FStarC_TypeChecker_Env.Iota] env1 + scrutinee_t in + aux false uu___ in + let pat_typ_ok env1 pat_t1 scrutinee_t = + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_Patterns in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + pat_t1 in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + scrutinee_t in + FStarC_Compiler_Util.print2 + "$$$$$$$$$$$$pat_typ_ok? %s vs. %s\n" uu___2 uu___3 + else ()); + FStarC_Defensive.def_check_scoped + FStarC_TypeChecker_Env.hasBinders_env + FStarC_Class_Binders.hasNames_term + FStarC_Syntax_Print.pretty_term pat_t1.FStarC_Syntax_Syntax.pos + "pat_typ_ok.pat_t.entry" env1 pat_t1; + (let fail1 msg_str = + let msg = + if msg_str = "" + then [] + else (let uu___3 = FStarC_Errors_Msg.text msg_str in [uu___3]) in + let msg1 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Errors_Msg.text "Type of pattern" in + let uu___5 = + FStarC_Class_PP.pp FStarC_Syntax_Print.pretty_term + pat_t1 in + FStarC_Pprint.prefix (Prims.of_int (2)) Prims.int_one + uu___4 uu___5 in + let uu___4 = + let uu___5 = + FStarC_Errors_Msg.text + "does not match type of scrutinee" in + let uu___6 = + FStarC_Class_PP.pp FStarC_Syntax_Print.pretty_term + scrutinee_t in + FStarC_Pprint.prefix (Prims.of_int (2)) Prims.int_one + uu___5 uu___6 in + FStarC_Pprint.op_Hat_Slash_Hat uu___3 uu___4 in + uu___2 :: msg in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range + p0.FStarC_Syntax_Syntax.p + FStarC_Errors_Codes.Fatal_MismatchedPatternType () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic msg1) in + let uu___2 = FStarC_Syntax_Util.head_and_args scrutinee_t in + match uu___2 with + | (head_s, args_s) -> + let pat_t2 = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Beta] env1 pat_t1 in + let uu___3 = FStarC_Syntax_Util.un_uinst head_s in + (match uu___3 with + | { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar + uu___4; + FStarC_Syntax_Syntax.pos = uu___5; + FStarC_Syntax_Syntax.vars = uu___6; + FStarC_Syntax_Syntax.hash_code = uu___7;_} -> + let uu___8 = FStarC_Syntax_Util.head_and_args pat_t2 in + (match uu___8 with + | (head_p, args_p) -> + let uu___9 = + FStarC_TypeChecker_Rel.teq_nosmt_force env1 head_p + head_s in + if uu___9 + then + let uu___10 = + let uu___11 = FStarC_Syntax_Util.un_uinst head_p in + uu___11.FStarC_Syntax_Syntax.n in + (match uu___10 with + | FStarC_Syntax_Syntax.Tm_fvar f -> + ((let uu___12 = + let uu___13 = + let uu___14 = + FStarC_Syntax_Syntax.lid_of_fv f in + FStarC_TypeChecker_Env.is_type_constructor + env1 uu___14 in + Prims.op_Negation uu___13 in + if uu___12 + then + fail1 + "Pattern matching a non-inductive type" + else ()); + if + (FStarC_Compiler_List.length args_p) <> + (FStarC_Compiler_List.length args_s) + then fail1 "" + else (); + (let uu___13 = + let uu___14 = + let uu___15 = + FStarC_Syntax_Syntax.lid_of_fv f in + FStarC_TypeChecker_Env.num_inductive_ty_params + env1 uu___15 in + match uu___14 with + | FStar_Pervasives_Native.None -> + (args_p, args_s) + | FStar_Pervasives_Native.Some n -> + let uu___15 = + FStarC_Compiler_Util.first_N n + args_p in + (match uu___15 with + | (params_p, uu___16) -> + let uu___17 = + FStarC_Compiler_Util.first_N n + args_s in + (match uu___17 with + | (params_s, uu___18) -> + (params_p, params_s))) in + match uu___13 with + | (params_p, params_s) -> + FStarC_Compiler_List.fold_left2 + (fun out -> + fun uu___14 -> + fun uu___15 -> + match (uu___14, uu___15) with + | ((p, uu___16), (s, uu___17)) + -> + let uu___18 = + FStarC_TypeChecker_Rel.teq_nosmt + env1 p s in + (match uu___18 with + | FStar_Pervasives_Native.None + -> + let uu___19 = + let uu___20 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + p in + let uu___21 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + s in + FStarC_Compiler_Util.format2 + "Parameter %s <> Parameter %s" + uu___20 uu___21 in + fail1 uu___19 + | FStar_Pervasives_Native.Some + g -> + let g1 = + FStarC_TypeChecker_Rel.discharge_guard_no_smt + env1 g in + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g1 out)) + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t) + params_p params_s)) + | uu___11 -> + fail1 "Pattern matching a non-inductive type") + else + (let uu___11 = + let uu___12 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head_p in + let uu___13 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term head_s in + FStarC_Compiler_Util.format2 + "Head mismatch %s vs %s" uu___12 uu___13 in + fail1 uu___11)) + | uu___4 -> + let uu___5 = + FStarC_TypeChecker_Rel.teq_nosmt env1 pat_t2 + scrutinee_t in + (match uu___5 with + | FStar_Pervasives_Native.None -> fail1 "" + | FStar_Pervasives_Native.Some g -> + let g1 = + FStarC_TypeChecker_Rel.discharge_guard_no_smt env1 + g in + g1))) in + let type_of_simple_pat env1 e = + let uu___ = FStarC_Syntax_Util.head_and_args e in + match uu___ with + | (head, args) -> + (match head.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_uinst + ({ + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar + uu___1; + FStarC_Syntax_Syntax.pos = uu___2; + FStarC_Syntax_Syntax.vars = uu___3; + FStarC_Syntax_Syntax.hash_code = uu___4;_}, + uu___5) + -> + let uu___6 = + match head.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_uinst (head1, us) -> + let uu___7 = head1.FStarC_Syntax_Syntax.n in + (match uu___7 with + | FStarC_Syntax_Syntax.Tm_fvar f -> + let res = + FStarC_TypeChecker_Env.try_lookup_and_inst_lid + env1 us + (f.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + (match res with + | FStar_Pervasives_Native.Some (t, uu___8) + when + FStarC_TypeChecker_Env.is_datacon env1 + (f.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + -> (head1, (us, t)) + | uu___8 -> + let uu___9 = + let uu___10 = + FStarC_Ident.string_of_lid + (f.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + FStarC_Compiler_Util.format1 + "Could not find constructor: %s" + uu___10 in + fail uu___9)) + | FStarC_Syntax_Syntax.Tm_fvar f -> + let uu___7 = + FStarC_TypeChecker_Env.lookup_datacon env1 + (f.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + (head, uu___7) in + (match uu___6 with + | (head1, (us, t_f)) -> + let uu___7 = FStarC_Syntax_Util.arrow_formals t_f in + (match uu___7 with + | (formals, t) -> + let erasable = + FStarC_TypeChecker_Env.non_informative env1 t in + (if + (FStarC_Compiler_List.length formals) <> + (FStarC_Compiler_List.length args) + then + fail + "Pattern is not a fully-applied data constructor" + else (); + (let rec aux uu___9 formals1 args1 = + match uu___9 with + | (subst, args_out, bvs, guard) -> + (match (formals1, args1) with + | ([], []) -> + let head2 = + FStarC_Syntax_Syntax.mk_Tm_uinst + head1 us in + let pat_e = + FStarC_Syntax_Syntax.mk_Tm_app + head2 args_out + e.FStarC_Syntax_Syntax.pos in + let uu___10 = + FStarC_Syntax_Subst.subst subst t in + (pat_e, uu___10, bvs, guard, + erasable) + | ({ + FStarC_Syntax_Syntax.binder_bv = f; + FStarC_Syntax_Syntax.binder_qual = + uu___10; + FStarC_Syntax_Syntax.binder_positivity + = uu___11; + FStarC_Syntax_Syntax.binder_attrs + = uu___12;_}::formals2, + (a, imp_a)::args2) -> + let t_f1 = + FStarC_Syntax_Subst.subst subst + f.FStarC_Syntax_Syntax.sort in + let uu___13 = + let uu___14 = + let uu___15 = + FStarC_Syntax_Subst.compress + a in + uu___15.FStarC_Syntax_Syntax.n in + match uu___14 with + | FStarC_Syntax_Syntax.Tm_name x + -> + let x1 = + { + FStarC_Syntax_Syntax.ppname + = + (x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index + = + (x.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort + = t_f1 + } in + let a1 = + FStarC_Syntax_Syntax.bv_to_name + x1 in + let subst1 = + (FStarC_Syntax_Syntax.NT + (f, a1)) + :: subst in + ((a1, imp_a), subst1, + (FStarC_Compiler_List.op_At + bvs [x1]), + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t)) + | FStarC_Syntax_Syntax.Tm_uvar + uu___15 -> + let use_eq = true in + let env2 = + FStarC_TypeChecker_Env.set_expected_typ_maybe_eq + env1 t_f1 use_eq in + let uu___16 = + tc_tot_or_gtot_term_maybe_solve_deferred + env2 a + FStar_Pervasives_Native.None + false in + (match uu___16 with + | (a1, uu___17, g) -> + let subst1 = + (FStarC_Syntax_Syntax.NT + (f, a1)) + :: subst in + ((a1, imp_a), subst1, + bvs, g)) + | uu___15 -> + let a1 = + FStarC_Syntax_Subst.subst + subst a in + let env2 = + FStarC_TypeChecker_Env.set_expected_typ + env1 t_f1 in + let uu___16 = + tc_tot_or_gtot_term env2 a1 in + (match uu___16 with + | (a2, uu___17, g) -> + let subst1 = + (FStarC_Syntax_Syntax.NT + (f, a2)) + :: subst in + ((a2, imp_a), subst1, + bvs, g)) in + (match uu___13 with + | (a1, subst1, bvs1, g) -> + let uu___14 = + let uu___15 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g guard in + (subst1, + (FStarC_Compiler_List.op_At + args_out [a1]), bvs1, + uu___15) in + aux uu___14 formals2 args2) + | uu___10 -> + fail "Not a fully applied pattern") in + aux + ([], [], [], + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t)) + formals args)))) + | FStarC_Syntax_Syntax.Tm_fvar uu___1 -> + let uu___2 = + match head.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_uinst (head1, us) -> + let uu___3 = head1.FStarC_Syntax_Syntax.n in + (match uu___3 with + | FStarC_Syntax_Syntax.Tm_fvar f -> + let res = + FStarC_TypeChecker_Env.try_lookup_and_inst_lid + env1 us + (f.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + (match res with + | FStar_Pervasives_Native.Some (t, uu___4) + when + FStarC_TypeChecker_Env.is_datacon env1 + (f.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v + -> (head1, (us, t)) + | uu___4 -> + let uu___5 = + let uu___6 = + FStarC_Ident.string_of_lid + (f.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + FStarC_Compiler_Util.format1 + "Could not find constructor: %s" + uu___6 in + fail uu___5)) + | FStarC_Syntax_Syntax.Tm_fvar f -> + let uu___3 = + FStarC_TypeChecker_Env.lookup_datacon env1 + (f.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + (head, uu___3) in + (match uu___2 with + | (head1, (us, t_f)) -> + let uu___3 = FStarC_Syntax_Util.arrow_formals t_f in + (match uu___3 with + | (formals, t) -> + let erasable = + FStarC_TypeChecker_Env.non_informative env1 t in + (if + (FStarC_Compiler_List.length formals) <> + (FStarC_Compiler_List.length args) + then + fail + "Pattern is not a fully-applied data constructor" + else (); + (let rec aux uu___5 formals1 args1 = + match uu___5 with + | (subst, args_out, bvs, guard) -> + (match (formals1, args1) with + | ([], []) -> + let head2 = + FStarC_Syntax_Syntax.mk_Tm_uinst + head1 us in + let pat_e = + FStarC_Syntax_Syntax.mk_Tm_app + head2 args_out + e.FStarC_Syntax_Syntax.pos in + let uu___6 = + FStarC_Syntax_Subst.subst subst t in + (pat_e, uu___6, bvs, guard, + erasable) + | ({ + FStarC_Syntax_Syntax.binder_bv = f; + FStarC_Syntax_Syntax.binder_qual = + uu___6; + FStarC_Syntax_Syntax.binder_positivity + = uu___7; + FStarC_Syntax_Syntax.binder_attrs + = uu___8;_}::formals2, + (a, imp_a)::args2) -> + let t_f1 = + FStarC_Syntax_Subst.subst subst + f.FStarC_Syntax_Syntax.sort in + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Syntax_Subst.compress + a in + uu___11.FStarC_Syntax_Syntax.n in + match uu___10 with + | FStarC_Syntax_Syntax.Tm_name x + -> + let x1 = + { + FStarC_Syntax_Syntax.ppname + = + (x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index + = + (x.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort + = t_f1 + } in + let a1 = + FStarC_Syntax_Syntax.bv_to_name + x1 in + let subst1 = + (FStarC_Syntax_Syntax.NT + (f, a1)) + :: subst in + ((a1, imp_a), subst1, + (FStarC_Compiler_List.op_At + bvs [x1]), + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t)) + | FStarC_Syntax_Syntax.Tm_uvar + uu___11 -> + let use_eq = true in + let env2 = + FStarC_TypeChecker_Env.set_expected_typ_maybe_eq + env1 t_f1 use_eq in + let uu___12 = + tc_tot_or_gtot_term_maybe_solve_deferred + env2 a + FStar_Pervasives_Native.None + false in + (match uu___12 with + | (a1, uu___13, g) -> + let subst1 = + (FStarC_Syntax_Syntax.NT + (f, a1)) + :: subst in + ((a1, imp_a), subst1, + bvs, g)) + | uu___11 -> + let a1 = + FStarC_Syntax_Subst.subst + subst a in + let env2 = + FStarC_TypeChecker_Env.set_expected_typ + env1 t_f1 in + let uu___12 = + tc_tot_or_gtot_term env2 a1 in + (match uu___12 with + | (a2, uu___13, g) -> + let subst1 = + (FStarC_Syntax_Syntax.NT + (f, a2)) + :: subst in + ((a2, imp_a), subst1, + bvs, g)) in + (match uu___9 with + | (a1, subst1, bvs1, g) -> + let uu___10 = + let uu___11 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g guard in + (subst1, + (FStarC_Compiler_List.op_At + args_out [a1]), bvs1, + uu___11) in + aux uu___10 formals2 args2) + | uu___6 -> + fail "Not a fully applied pattern") in + aux + ([], [], [], + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t)) + formals args)))) + | uu___1 -> fail "Not a simple pattern") in + let rec check_nested_pattern env1 p t = + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_Patterns in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_pat p in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.print2 + "Checking nested pattern %s at type %s\n" uu___2 uu___3 + else ()); + (let id t1 = + let uu___1 = + FStarC_Syntax_Syntax.fvar FStarC_Parser_Const.id_lid + FStar_Pervasives_Native.None in + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.iarg t1 in [uu___3] in + FStarC_Syntax_Syntax.mk_Tm_app uu___1 uu___2 + t1.FStarC_Syntax_Syntax.pos in + let mk_disc_t disc inner_t = + let x_b = + let uu___1 = + FStarC_Syntax_Syntax.gen_bv "x" FStar_Pervasives_Native.None + t in + FStarC_Syntax_Syntax.mk_binder uu___1 in + let ty_args = + let uu___1 = FStarC_Syntax_Util.head_and_args t in + match uu___1 with + | (hd, args) -> + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.compress hd in + FStarC_Syntax_Util.un_uinst uu___4 in + uu___3.FStarC_Syntax_Syntax.n in + (match uu___2 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.lid_of_fv fv in + FStarC_TypeChecker_Env.num_inductive_ty_params + env1 uu___5 in + let uu___5 = + FStarC_Compiler_Util.map_option + (fun n -> + if (FStarC_Compiler_List.length args) >= n + then + let uu___6 = + FStarC_Compiler_List.splitAt n args in + FStar_Pervasives_Native.fst uu___6 + else []) uu___4 in + FStarC_Compiler_Util.dflt [] uu___5 in + FStarC_Compiler_List.map + (fun uu___4 -> + match uu___4 with + | (t1, uu___5) -> FStarC_Syntax_Syntax.iarg t1) + uu___3 + | uu___3 -> []) in + let tm = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Syntax_Syntax.bv_to_name + x_b.FStarC_Syntax_Syntax.binder_bv in + FStarC_Syntax_Syntax.as_arg uu___4 in + [uu___3] in + FStarC_Compiler_List.op_At ty_args uu___2 in + FStarC_Syntax_Syntax.mk_Tm_app disc uu___1 + FStarC_Compiler_Range_Type.dummyRange in + let tm1 = + let uu___1 = + let uu___2 = FStarC_Syntax_Syntax.as_arg tm in [uu___2] in + FStarC_Syntax_Syntax.mk_Tm_app inner_t uu___1 + FStarC_Compiler_Range_Type.dummyRange in + FStarC_Syntax_Util.abs [x_b] tm1 FStar_Pervasives_Native.None in + match p.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_dot_term uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_pat p in + FStarC_Compiler_Util.format1 + "Impossible: Expected an undecorated pattern, got %s" + uu___3 in + failwith uu___2 + | FStarC_Syntax_Syntax.Pat_var x -> + let x1 = + { + FStarC_Syntax_Syntax.ppname = + (x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (x.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = t + } in + let uu___1 = let uu___2 = id t in [uu___2] in + let uu___2 = FStarC_Syntax_Syntax.bv_to_name x1 in + ([x1], uu___1, uu___2, + { + FStarC_Syntax_Syntax.v = (FStarC_Syntax_Syntax.Pat_var x1); + FStarC_Syntax_Syntax.p = (p.FStarC_Syntax_Syntax.p) + }, + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t), false) + | FStarC_Syntax_Syntax.Pat_constant c -> + ((match c with + | FStarC_Const.Const_unit -> () + | FStarC_Const.Const_bool uu___2 -> () + | FStarC_Const.Const_int uu___2 -> () + | FStarC_Const.Const_char uu___2 -> () + | FStarC_Const.Const_string uu___2 -> () + | uu___2 -> + let uu___3 = + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_const c in + FStarC_Compiler_Util.format1 + "Pattern matching a constant that does not have decidable equality: %s" + uu___4 in + fail uu___3); + (let uu___2 = + FStarC_TypeChecker_PatternUtils.pat_as_exp false false + env1 p in + match uu___2 with + | (uu___3, e_c, uu___4, uu___5) -> + let uu___6 = tc_tot_or_gtot_term env1 e_c in + (match uu___6 with + | (e_c1, lc, g) -> + (FStarC_TypeChecker_Rel.force_trivial_guard env1 g; + (let expected_t = + expected_pat_typ env1 p0.FStarC_Syntax_Syntax.p + t in + (let uu___9 = + let uu___10 = + FStarC_TypeChecker_Rel.teq_nosmt_force env1 + lc.FStarC_TypeChecker_Common.res_typ + expected_t in + Prims.op_Negation uu___10 in + if uu___9 + then + let uu___10 = + let uu___11 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + lc.FStarC_TypeChecker_Common.res_typ in + let uu___12 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + expected_t in + FStarC_Compiler_Util.format2 + "Type of pattern (%s) does not match type of scrutinee (%s)" + uu___11 uu___12 in + fail uu___10 + else ()); + ([], [], e_c1, p, + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t), + false)))))) + | FStarC_Syntax_Syntax.Pat_cons + ({ FStarC_Syntax_Syntax.fv_name = uu___1; + FStarC_Syntax_Syntax.fv_qual = FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Unresolved_constructor uc);_}, + us_opt, sub_pats) + -> + let uu___2 = + FStarC_TypeChecker_Util.find_record_or_dc_from_typ env1 + (FStar_Pervasives_Native.Some t) uc + p.FStarC_Syntax_Syntax.p in + (match uu___2 with + | (rdc, uu___3, constructor_fv) -> + let f_sub_pats = + FStarC_Compiler_List.zip + uc.FStarC_Syntax_Syntax.uc_fields sub_pats in + let sub_pats1 = + FStarC_TypeChecker_Util.make_record_fields_in_order + env1 uc + (FStar_Pervasives_Native.Some + (FStar_Pervasives.Inl t)) rdc f_sub_pats + (fun uu___4 -> + let x = + FStarC_Syntax_Syntax.new_bv + FStar_Pervasives_Native.None + FStarC_Syntax_Syntax.tun in + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.withinfo + (FStarC_Syntax_Syntax.Pat_var x) + p.FStarC_Syntax_Syntax.p in + (uu___6, false) in + FStar_Pervasives_Native.Some uu___5) + p.FStarC_Syntax_Syntax.p in + let p1 = + { + FStarC_Syntax_Syntax.v = + (FStarC_Syntax_Syntax.Pat_cons + (constructor_fv, us_opt, sub_pats1)); + FStarC_Syntax_Syntax.p = (p.FStarC_Syntax_Syntax.p) + } in + let p2 = + FStarC_TypeChecker_PatternUtils.elaborate_pat env1 p1 in + check_nested_pattern env1 p2 t) + | FStarC_Syntax_Syntax.Pat_cons (fv, us_opt, sub_pats) -> + let simple_pat = + let simple_sub_pats = + FStarC_Compiler_List.map + (fun uu___1 -> + match uu___1 with + | (p1, b) -> + (match p1.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_dot_term uu___2 -> + (p1, b) + | uu___2 -> + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Syntax_Syntax.new_bv + (FStar_Pervasives_Native.Some + (p1.FStarC_Syntax_Syntax.p)) + FStarC_Syntax_Syntax.tun in + FStarC_Syntax_Syntax.Pat_var uu___5 in + FStarC_Syntax_Syntax.withinfo uu___4 + p1.FStarC_Syntax_Syntax.p in + (uu___3, b))) sub_pats in + { + FStarC_Syntax_Syntax.v = + (FStarC_Syntax_Syntax.Pat_cons + (fv, us_opt, simple_sub_pats)); + FStarC_Syntax_Syntax.p = (p.FStarC_Syntax_Syntax.p) + } in + let sub_pats1 = + FStarC_Compiler_List.filter + (fun uu___1 -> + match uu___1 with + | (x, uu___2) -> + (match x.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_dot_term uu___3 -> + false + | uu___3 -> true)) sub_pats in + let uu___1 = + FStarC_TypeChecker_PatternUtils.pat_as_exp false false env1 + simple_pat in + (match uu___1 with + | (simple_bvs_pat, simple_pat_e, g0, simple_pat_elab) -> + (if + (FStarC_Compiler_List.length simple_bvs_pat) <> + (FStarC_Compiler_List.length sub_pats1) + then + (let uu___3 = + let uu___4 = + FStarC_Compiler_Range_Ops.string_of_range + p.FStarC_Syntax_Syntax.p in + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_pat simple_pat in + let uu___6 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length sub_pats1) in + let uu___7 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length simple_bvs_pat) in + FStarC_Compiler_Util.format4 + "(%s) Impossible: pattern bvar mismatch: %s; expected %s sub pats; got %s" + uu___4 uu___5 uu___6 uu___7 in + failwith uu___3) + else (); + (let uu___3 = + let uu___4 = type_of_simple_pat env1 simple_pat_e in + match uu___4 with + | (simple_pat_e1, simple_pat_t, simple_bvs, guard, + erasable) -> + let simple_bvs1 = + let uu___5 = + FStarC_Compiler_Util.first_N + ((FStarC_Compiler_List.length simple_bvs) - + (FStarC_Compiler_List.length + simple_bvs_pat)) simple_bvs in + FStar_Pervasives_Native.snd uu___5 in + let g' = + let uu___5 = + FStarC_TypeChecker_Env.push_bvs env1 + simple_bvs1 in + let uu___6 = + expected_pat_typ env1 + p0.FStarC_Syntax_Syntax.p t in + pat_typ_ok uu___5 simple_pat_t uu___6 in + let guard1 = + let fml = + FStarC_TypeChecker_Env.guard_form guard in + let guard2 = + FStarC_TypeChecker_Rel.discharge_guard_no_smt + env1 + { + FStarC_TypeChecker_Common.guard_f = + FStarC_TypeChecker_Common.Trivial; + FStarC_TypeChecker_Common.deferred_to_tac + = + (guard.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (guard.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (guard.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = + (guard.FStarC_TypeChecker_Common.implicits) + } in + { + FStarC_TypeChecker_Common.guard_f = fml; + FStarC_TypeChecker_Common.deferred_to_tac = + (guard2.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (guard2.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (guard2.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = + (guard2.FStarC_TypeChecker_Common.implicits) + } in + let guard2 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + guard1 g' in + ((let uu___6 = + FStarC_Compiler_Effect.op_Bang dbg_Patterns in + if uu___6 + then + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + simple_pat_e1 in + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + simple_pat_t in + let uu___9 = + let uu___10 = + FStarC_Compiler_List.map + (fun x -> + let uu___11 = + let uu___12 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_bv + x in + let uu___13 = + let uu___14 = + let uu___15 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + x.FStarC_Syntax_Syntax.sort in + Prims.strcat uu___15 ")" in + Prims.strcat " : " uu___14 in + Prims.strcat uu___12 uu___13 in + Prims.strcat "(" uu___11) + simple_bvs1 in + FStarC_Compiler_String.concat " " uu___10 in + FStarC_Compiler_Util.print3 + "$$$$$$$$$$$$Checked simple pattern %s at type %s with bvs=%s\n" + uu___7 uu___8 uu___9 + else ()); + (simple_pat_e1, simple_bvs1, guard2, erasable)) in + match uu___3 with + | (simple_pat_e1, simple_bvs, g1, erasable) -> + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t g0 + g1 in + ([], [], [], [], uu___6, erasable, + Prims.int_zero) in + FStarC_Compiler_List.fold_left2 + (fun uu___6 -> + fun uu___7 -> + fun x -> + match (uu___6, uu___7) with + | ((bvs, tms, pats, subst, g, erasable1, + i), + (p1, b)) -> + let expected_t = + FStarC_Syntax_Subst.subst subst + x.FStarC_Syntax_Syntax.sort in + let env2 = + FStarC_TypeChecker_Env.push_bvs + env1 bvs in + let uu___8 = + check_nested_pattern env2 p1 + expected_t in + (match uu___8 with + | (bvs_p, tms_p, e_p, p2, g', + erasable_p) -> + let g'1 = + let uu___9 = + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.mk_binder + bvs in + FStarC_TypeChecker_Env.close_guard + env2 uu___9 g' in + let tms_p1 = + let disc_tm = + let uu___9 = + FStarC_Syntax_Syntax.lid_of_fv + fv in + FStarC_TypeChecker_Util.get_field_projector_name + env2 uu___9 i in + let uu___9 = + let uu___10 = + FStarC_Syntax_Syntax.fvar + disc_tm + FStar_Pervasives_Native.None in + mk_disc_t uu___10 in + FStarC_Compiler_List.map + uu___9 tms_p in + let uu___9 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g g'1 in + ((FStarC_Compiler_List.op_At + bvs bvs_p), + (FStarC_Compiler_List.op_At + tms tms_p1), + (FStarC_Compiler_List.op_At + pats [(p2, b)]), + ((FStarC_Syntax_Syntax.NT + (x, e_p)) :: subst), + uu___9, + (erasable1 || erasable_p), + (i + Prims.int_one)))) uu___5 + sub_pats1 simple_bvs in + (match uu___4 with + | (bvs, tms, checked_sub_pats, subst, g, + erasable1, uu___5) -> + let pat_e = + FStarC_Syntax_Subst.subst subst + simple_pat_e1 in + let reconstruct_nested_pat pat = + let rec aux simple_pats bvs1 sub_pats2 = + match simple_pats with + | [] -> [] + | (hd, b)::simple_pats1 -> + (match hd.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_dot_term + eopt -> + let eopt1 = + FStarC_Compiler_Util.map_option + (FStarC_Syntax_Subst.subst + subst) eopt in + let hd1 = + { + FStarC_Syntax_Syntax.v = + (FStarC_Syntax_Syntax.Pat_dot_term + eopt1); + FStarC_Syntax_Syntax.p = + (hd.FStarC_Syntax_Syntax.p) + } in + let uu___6 = + aux simple_pats1 bvs1 sub_pats2 in + (hd1, b) :: uu___6 + | FStarC_Syntax_Syntax.Pat_var x -> + (match (bvs1, sub_pats2) with + | (x'::bvs2, + (hd1, uu___6)::sub_pats3) + when + FStarC_Syntax_Syntax.bv_eq x + x' + -> + let uu___7 = + aux simple_pats1 bvs2 + sub_pats3 in + (hd1, b) :: uu___7 + | uu___6 -> + failwith + "Impossible: simple pat variable mismatch") + | uu___6 -> + failwith + "Impossible: expected a simple pattern") in + let us = + let uu___6 = + FStarC_Syntax_Util.head_and_args + simple_pat_e1 in + match uu___6 with + | (hd, uu___7) -> + let uu___8 = + let uu___9 = + FStarC_Syntax_Subst.compress hd in + uu___9.FStarC_Syntax_Syntax.n in + (match uu___8 with + | FStarC_Syntax_Syntax.Tm_fvar uu___9 + -> [] + | FStarC_Syntax_Syntax.Tm_uinst + (uu___9, us1) -> us1 + | uu___9 -> + failwith + "Impossible: tc_pat: pattern head not fvar or uinst") in + match pat.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_cons + (fv1, uu___6, simple_pats) -> + let nested_pats = + aux simple_pats simple_bvs + checked_sub_pats in + { + FStarC_Syntax_Syntax.v = + (FStarC_Syntax_Syntax.Pat_cons + (fv1, + (FStar_Pervasives_Native.Some + us), nested_pats)); + FStarC_Syntax_Syntax.p = + (pat.FStarC_Syntax_Syntax.p) + } + | uu___6 -> + failwith + "Impossible: tc_pat: pat.v expected Pat_cons" in + let uu___6 = + reconstruct_nested_pat simple_pat_elab in + (bvs, tms, pat_e, uu___6, g, erasable1)))))) in + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_Patterns in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_pat p0 in + FStarC_Compiler_Util.print1 "Checking pattern: %s\n" uu___2 + else ()); + (let uu___1 = + let uu___2 = + let uu___3 = FStarC_TypeChecker_Env.clear_expected_typ env in + FStar_Pervasives_Native.fst uu___3 in + let uu___3 = FStarC_TypeChecker_PatternUtils.elaborate_pat env p0 in + let uu___4 = expected_pat_typ env p0.FStarC_Syntax_Syntax.p pat_t in + check_nested_pattern uu___2 uu___3 uu___4 in + match uu___1 with + | (bvs, tms, pat_e, pat, g, erasable) -> + let extended_env = FStarC_TypeChecker_Env.push_bvs env bvs in + let pat_e_norm = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Beta] extended_env pat_e in + ((let uu___3 = FStarC_Compiler_Effect.op_Bang dbg_Patterns in + if uu___3 + then + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_pat + pat in + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + pat_e in + FStarC_Compiler_Util.print2 + "Done checking pattern %s as expression %s\n" uu___4 + uu___5 + else ()); + (pat, bvs, tms, extended_env, pat_e, pat_e_norm, g, erasable))) +and (tc_eqn : + FStarC_Syntax_Syntax.bv -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.match_returns_ascription + FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.branch -> + ((FStarC_Syntax_Syntax.pat * FStarC_Syntax_Syntax.term + FStar_Pervasives_Native.option * FStarC_Syntax_Syntax.term) * + FStarC_Syntax_Syntax.formula * FStarC_Ident.lident * + FStarC_Syntax_Syntax.cflag Prims.list + FStar_Pervasives_Native.option * + (Prims.bool -> FStarC_TypeChecker_Common.lcomp) + FStar_Pervasives_Native.option * FStarC_TypeChecker_Env.guard_t * + Prims.bool)) + = + fun scrutinee -> + fun env -> + fun ret_opt -> + fun branch -> + let uu___ = FStarC_Syntax_Subst.open_branch branch in + match uu___ with + | (pattern, when_clause, branch_exp) -> + let uu___1 = branch in + (match uu___1 with + | (cpat, uu___2, cbr) -> + let pat_t = scrutinee.FStarC_Syntax_Syntax.sort in + let scrutinee_tm = + FStarC_Syntax_Syntax.bv_to_name scrutinee in + let uu___3 = + let uu___4 = + FStarC_TypeChecker_Env.push_bv env scrutinee in + FStarC_TypeChecker_Env.clear_expected_typ uu___4 in + (match uu___3 with + | (scrutinee_env, uu___4) -> + let uu___5 = + let uu___6 = + FStarC_TypeChecker_Env.push_bv env scrutinee in + tc_pat uu___6 pat_t pattern in + (match uu___5 with + | (pattern1, pat_bvs, pat_bv_tms, pat_env, pat_exp, + norm_pat_exp, guard_pat, erasable) -> + ((let uu___7 = FStarC_Compiler_Debug.extreme () in + if uu___7 + then + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_pat + pattern1 in + let uu___9 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_bv) + pat_bvs in + let uu___10 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_term) + pat_bv_tms in + FStarC_Compiler_Util.print3 + "tc_eqn: typechecked pattern %s with bvs %s and pat_bv_tms=%s\n" + uu___8 uu___9 uu___10 + else ()); + (let uu___7 = + match when_clause with + | FStar_Pervasives_Native.None -> + (FStar_Pervasives_Native.None, + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t)) + | FStar_Pervasives_Native.Some e -> + let uu___8 = + FStarC_TypeChecker_Env.should_verify + env in + if uu___8 + then + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax + ()) e + FStarC_Errors_Codes.Fatal_WhenClauseNotSupported + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "When clauses are not yet supported in --verify mode; they will be some day") + else + (let uu___10 = + let uu___11 = + FStarC_TypeChecker_Env.set_expected_typ + pat_env + FStarC_Syntax_Util.t_bool in + tc_term uu___11 e in + match uu___10 with + | (e1, c, g) -> + ((FStar_Pervasives_Native.Some e1), + g)) in + match uu___7 with + | (when_clause1, g_when) -> + let uu___8 = + let branch_exp1 = + match ret_opt with + | FStar_Pervasives_Native.None -> + branch_exp + | FStar_Pervasives_Native.Some + (b, asc) -> + let uu___9 = + FStarC_Syntax_Subst.subst_ascription + [FStarC_Syntax_Syntax.NT + ((b.FStarC_Syntax_Syntax.binder_bv), + norm_pat_exp)] asc in + FStarC_Syntax_Util.ascribe + branch_exp uu___9 in + let uu___9 = tc_term pat_env branch_exp1 in + match uu___9 with + | (branch_exp2, c, g_branch) -> + let branch_exp3 = + match ret_opt with + | FStar_Pervasives_Native.None -> + branch_exp2 + | uu___10 -> + let uu___11 = + let uu___12 = + FStarC_Syntax_Subst.compress + branch_exp2 in + uu___12.FStarC_Syntax_Syntax.n in + (match uu___11 with + | FStarC_Syntax_Syntax.Tm_ascribed + { + FStarC_Syntax_Syntax.tm + = branch_exp4; + FStarC_Syntax_Syntax.asc + = uu___12; + FStarC_Syntax_Syntax.eff_opt + = uu___13;_} + -> branch_exp4 + | uu___12 -> + failwith + "Impossible (expected the match branch with an ascription)") in + (branch_exp3, c, g_branch) in + (match uu___8 with + | (branch_exp1, c, g_branch) -> + (FStarC_Defensive.def_check_scoped + FStarC_TypeChecker_Env.hasBinders_env + FStarC_TypeChecker_Env.hasNames_guard + FStarC_TypeChecker_Env.pretty_guard + cbr.FStarC_Syntax_Syntax.pos + "tc_eqn.1" pat_env g_branch; + (let when_condition = + match when_clause1 with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some w + -> + let uu___10 = + FStarC_Syntax_Util.mk_eq2 + FStarC_Syntax_Syntax.U_zero + FStarC_Syntax_Util.t_bool + w + FStarC_Syntax_Util.exp_true_bool in + FStar_Pervasives_Native.Some + uu___10 in + let branch_guard = + let uu___10 = + let uu___11 = + FStarC_TypeChecker_Env.should_verify + env in + Prims.op_Negation uu___11 in + if uu___10 + then + FStarC_Syntax_Util.exp_true_bool + else + (let rec build_branch_guard + scrutinee_tm1 pattern2 + pat_exp1 = + let discriminate + scrutinee_tm2 f = + let uu___12 = + let uu___13 = + FStarC_TypeChecker_Env.typ_of_datacon + env + f.FStarC_Syntax_Syntax.v in + FStarC_TypeChecker_Env.datacons_of_typ + env uu___13 in + match uu___12 with + | (is_induc, datacons) -> + if + (Prims.op_Negation + is_induc) + || + ((FStarC_Compiler_List.length + datacons) + > Prims.int_one) + then + let discriminator = + FStarC_Syntax_Util.mk_discriminator + f.FStarC_Syntax_Syntax.v in + let uu___13 = + FStarC_TypeChecker_Env.try_lookup_lid + env + discriminator in + (match uu___13 with + | FStar_Pervasives_Native.None + -> [] + | uu___14 -> + let disc = + FStarC_Syntax_Syntax.fvar + discriminator + FStar_Pervasives_Native.None in + let uu___15 = + let uu___16 = + let uu___17 + = + FStarC_Syntax_Syntax.as_arg + scrutinee_tm2 in + [uu___17] in + FStarC_Syntax_Syntax.mk_Tm_app + disc + uu___16 + scrutinee_tm2.FStarC_Syntax_Syntax.pos in + [uu___15]) + else [] in + let fail uu___12 = + let uu___13 = + let uu___14 = + FStarC_Compiler_Range_Ops.string_of_range + pat_exp1.FStarC_Syntax_Syntax.pos in + let uu___15 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + pat_exp1 in + let uu___16 = + FStarC_Class_Tagged.tag_of + FStarC_Syntax_Syntax.tagged_term + pat_exp1 in + FStarC_Compiler_Util.format3 + "tc_eqn: Impossible (%s) %s (%s)" + uu___14 uu___15 + uu___16 in + failwith uu___13 in + let rec head_constructor t = + match t.FStarC_Syntax_Syntax.n + with + | FStarC_Syntax_Syntax.Tm_fvar + fv -> + fv.FStarC_Syntax_Syntax.fv_name + | FStarC_Syntax_Syntax.Tm_uinst + (t1, uu___12) -> + head_constructor t1 + | uu___12 -> fail () in + let force_scrutinee uu___12 + = + match scrutinee_tm1 with + | FStar_Pervasives_Native.None + -> + let uu___13 = + let uu___14 = + FStarC_Compiler_Range_Ops.string_of_range + pattern2.FStarC_Syntax_Syntax.p in + let uu___15 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_pat + pattern2 in + FStarC_Compiler_Util.format2 + "Impossible (%s): scrutinee of match is not defined %s" + uu___14 uu___15 in + failwith uu___13 + | FStar_Pervasives_Native.Some + t -> t in + let pat_exp2 = + let uu___12 = + FStarC_Syntax_Subst.compress + pat_exp1 in + FStarC_Syntax_Util.unmeta + uu___12 in + match ((pattern2.FStarC_Syntax_Syntax.v), + (pat_exp2.FStarC_Syntax_Syntax.n)) + with + | (uu___12, + FStarC_Syntax_Syntax.Tm_name + uu___13) -> [] + | (uu___12, + FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_unit)) + -> [] + | (FStarC_Syntax_Syntax.Pat_constant + _c, + FStarC_Syntax_Syntax.Tm_constant + c1) -> + let uu___12 = + let uu___13 = + tc_constant env + pat_exp2.FStarC_Syntax_Syntax.pos + c1 in + let uu___14 = + force_scrutinee () in + FStarC_Syntax_Util.mk_decidable_eq + uu___13 uu___14 + pat_exp2 in + [uu___12] + | (FStarC_Syntax_Syntax.Pat_constant + (FStarC_Const.Const_int + (uu___12, + FStar_Pervasives_Native.Some + uu___13)), + uu___14) -> + let uu___15 = + let uu___16 = + FStarC_TypeChecker_Env.clear_expected_typ + env in + match uu___16 with + | (env1, uu___17) -> + env1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + env1 pat_exp2 + true in + (match uu___15 with + | (uu___16, t, uu___17) + -> + let uu___18 = + let uu___19 = + force_scrutinee + () in + FStarC_Syntax_Util.mk_decidable_eq + t uu___19 + pat_exp2 in + [uu___18]) + | (FStarC_Syntax_Syntax.Pat_cons + (uu___12, uu___13, []), + FStarC_Syntax_Syntax.Tm_uinst + uu___14) -> + let f = + head_constructor + pat_exp2 in + let uu___15 = + let uu___16 = + FStarC_TypeChecker_Env.is_datacon + env + f.FStarC_Syntax_Syntax.v in + Prims.op_Negation + uu___16 in + if uu___15 + then + failwith + "Impossible: nullary patterns must be data constructors" + else + (let uu___17 = + force_scrutinee () in + let uu___18 = + head_constructor + pat_exp2 in + discriminate uu___17 + uu___18) + | (FStarC_Syntax_Syntax.Pat_cons + (uu___12, uu___13, []), + FStarC_Syntax_Syntax.Tm_fvar + uu___14) -> + let f = + head_constructor + pat_exp2 in + let uu___15 = + let uu___16 = + FStarC_TypeChecker_Env.is_datacon + env + f.FStarC_Syntax_Syntax.v in + Prims.op_Negation + uu___16 in + if uu___15 + then + failwith + "Impossible: nullary patterns must be data constructors" + else + (let uu___17 = + force_scrutinee () in + let uu___18 = + head_constructor + pat_exp2 in + discriminate uu___17 + uu___18) + | (FStarC_Syntax_Syntax.Pat_cons + (uu___12, uu___13, + pat_args), + FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd + = head; + FStarC_Syntax_Syntax.args + = args;_}) + -> + let f = + head_constructor head in + let uu___14 = + (let uu___15 = + FStarC_TypeChecker_Env.is_datacon + env + f.FStarC_Syntax_Syntax.v in + Prims.op_Negation + uu___15) + || + ((FStarC_Compiler_List.length + pat_args) + <> + (FStarC_Compiler_List.length + args)) in + if uu___14 + then + failwith + "Impossible: application patterns must be fully-applied data constructors" + else + (let sub_term_guards = + let uu___16 = + let uu___17 = + FStarC_Compiler_List.zip + pat_args args in + FStarC_Compiler_List.mapi + (fun i -> + fun uu___18 + -> + match uu___18 + with + | + ((pi, + uu___19), + (ei, + uu___20)) + -> + let projector + = + FStarC_TypeChecker_Env.lookup_projector + env + f.FStarC_Syntax_Syntax.v + i in + let scrutinee_tm2 + = + let uu___21 + = + FStarC_TypeChecker_Env.try_lookup_lid + env + projector in + match uu___21 + with + | + FStar_Pervasives_Native.None + -> + FStar_Pervasives_Native.None + | + uu___22 + -> + let proj + = + let uu___23 + = + FStarC_Ident.set_lid_range + projector + f.FStarC_Syntax_Syntax.p in + FStarC_Syntax_Syntax.fvar + uu___23 + FStar_Pervasives_Native.None in + let uu___23 + = + let uu___24 + = + let uu___25 + = + let uu___26 + = + force_scrutinee + () in + FStarC_Syntax_Syntax.as_arg + uu___26 in + [uu___25] in + FStarC_Syntax_Syntax.mk_Tm_app + proj + uu___24 + f.FStarC_Syntax_Syntax.p in + FStar_Pervasives_Native.Some + uu___23 in + build_branch_guard + scrutinee_tm2 + pi ei) + uu___17 in + FStarC_Compiler_List.flatten + uu___16 in + let uu___16 = + let uu___17 = + force_scrutinee + () in + discriminate + uu___17 f in + FStarC_Compiler_List.op_At + uu___16 + sub_term_guards) + | (FStarC_Syntax_Syntax.Pat_dot_term + uu___12, uu___13) -> [] + | uu___12 -> + let uu___13 = + let uu___14 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_pat + pattern2 in + let uu___15 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + pat_exp2 in + FStarC_Compiler_Util.format2 + "Internal error: unexpected elaborated pattern: %s and pattern expression %s" + uu___14 uu___15 in + failwith uu___13 in + let build_and_check_branch_guard + scrutinee_tm1 pattern2 pat = + let uu___12 = + let uu___13 = + FStarC_TypeChecker_Env.should_verify + env in + Prims.op_Negation uu___13 in + if uu___12 + then + FStarC_Syntax_Util.exp_true_bool + else + (let t = + let uu___14 = + build_branch_guard + scrutinee_tm1 + pattern2 pat in + FStarC_Syntax_Util.mk_and_l + uu___14 in + (let uu___15 = + FStarC_Compiler_Debug.high + () in + if uu___15 + then + let uu___16 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t in + FStarC_Compiler_Util.print1 + "tc_eqn: branch guard before typechecking: %s\n" + uu___16 + else ()); + (let uu___15 = + tc_check_tot_or_gtot_term + scrutinee_env t + FStarC_Syntax_Util.t_bool + FStar_Pervasives_Native.None in + match uu___15 with + | (t1, uu___16, uu___17) + -> + ((let uu___19 = + FStarC_Compiler_Debug.high + () in + if uu___19 + then + let uu___20 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t1 in + FStarC_Compiler_Util.print1 + "tc_eqn: branch guard after typechecking: %s\n" + uu___20 + else ()); + t1))) in + let branch_guard1 = + build_and_check_branch_guard + (FStar_Pervasives_Native.Some + scrutinee_tm) pattern1 + norm_pat_exp in + let branch_guard2 = + match when_condition with + | FStar_Pervasives_Native.None + -> branch_guard1 + | FStar_Pervasives_Native.Some + w -> + FStarC_Syntax_Util.mk_and + branch_guard1 w in + branch_guard2) in + (let uu___11 = + FStarC_Compiler_Debug.extreme () in + if uu___11 + then + let uu___12 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + branch_guard in + FStarC_Compiler_Util.print1 + "tc_eqn: branch guard : %s\n" + uu___12 + else ()); + (let uu___11 = + let eqs = + let env1 = pat_env in + let uu___12 = + let uu___13 = + FStarC_TypeChecker_Env.should_verify + env1 in + Prims.op_Negation uu___13 in + if uu___12 + then + FStar_Pervasives_Native.None + else + (let e = + FStarC_Syntax_Subst.compress + pat_exp in + let uu___14 = + let uu___15 = + env1.FStarC_TypeChecker_Env.universe_of + env1 pat_t in + FStarC_Syntax_Util.mk_eq2 + uu___15 pat_t + scrutinee_tm e in + FStar_Pervasives_Native.Some + uu___14) in + match ret_opt with + | FStar_Pervasives_Native.Some + (uu___12, + (FStar_Pervasives.Inr c1, + uu___13, uu___14)) + -> + let pat_bs = + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.mk_binder + pat_bvs in + let g_branch1 = + let uu___15 = + let uu___16 = + if + FStarC_Compiler_Util.is_some + eqs + then + let uu___17 = + FStarC_Compiler_Util.must + eqs in + FStarC_TypeChecker_Common.weaken_guard_formula + g_branch uu___17 + else g_branch in + FStarC_TypeChecker_Env.close_guard + env pat_bs uu___16 in + FStarC_TypeChecker_Util.close_guard_implicits + env true pat_bs uu___15 in + ((FStarC_Syntax_Util.comp_effect_name + c1), + FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None, + g_when, g_branch1) + | uu___12 -> + let uu___13 = + FStarC_TypeChecker_Util.strengthen_precondition + FStar_Pervasives_Native.None + env branch_exp1 c + g_branch in + (match uu___13 with + | (c1, g_branch1) -> + let close_branch_with_substitutions + = + let m = + FStarC_TypeChecker_Env.norm_eff_name + env + c1.FStarC_TypeChecker_Common.eff_name in + (FStarC_TypeChecker_Env.is_layered_effect + env m) + && + (let uu___14 = + let uu___15 = + FStarC_TypeChecker_Env.get_effect_decl + env m in + FStarC_Syntax_Util.get_layered_close_combinator + uu___15 in + FStar_Pervasives_Native.uu___is_None + uu___14) in + let uu___14 = + if + close_branch_with_substitutions + then + let c2 = + let uu___15 = + let uu___16 = + FStarC_Syntax_Util.b2t + branch_guard in + FStarC_TypeChecker_Common.NonTrivial + uu___16 in + FStarC_TypeChecker_Util.weaken_precondition + pat_env c1 + uu___15 in + (c2, + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t)) + else + if + (let uu___16 = + FStarC_TypeChecker_Env.should_verify + pat_env in + Prims.op_Negation + uu___16) + then (c1, g_when) + else + (match (eqs, + when_condition) + with + | (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.None) + -> + (c1, g_when) + | (FStar_Pervasives_Native.Some + f, + FStar_Pervasives_Native.None) + -> + let gf = + FStarC_TypeChecker_Common.NonTrivial + f in + let g = + FStarC_TypeChecker_Env.guard_of_guard_formula + gf in + let uu___16 + = + FStarC_TypeChecker_Util.weaken_precondition + pat_env + c1 gf in + let uu___17 + = + FStarC_TypeChecker_Env.imp_guard + g g_when in + (uu___16, + uu___17) + | (FStar_Pervasives_Native.Some + f, + FStar_Pervasives_Native.Some + w) -> + let g_f = + FStarC_TypeChecker_Common.NonTrivial + f in + let g_fw = + let uu___16 + = + FStarC_Syntax_Util.mk_conj + f w in + FStarC_TypeChecker_Common.NonTrivial + uu___16 in + let uu___16 + = + FStarC_TypeChecker_Util.weaken_precondition + pat_env + c1 g_fw in + let uu___17 + = + let uu___18 + = + FStarC_TypeChecker_Env.guard_of_guard_formula + g_f in + FStarC_TypeChecker_Env.imp_guard + uu___18 + g_when in + (uu___16, + uu___17) + | (FStar_Pervasives_Native.None, + FStar_Pervasives_Native.Some + w) -> + let g_w = + FStarC_TypeChecker_Common.NonTrivial + w in + let g = + FStarC_TypeChecker_Env.guard_of_guard_formula + g_w in + let uu___16 + = + FStarC_TypeChecker_Util.weaken_precondition + pat_env + c1 g_w in + (uu___16, + g_when)) in + (match uu___14 with + | (c_weak, + g_when_weak) -> + let binders = + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.mk_binder + pat_bvs in + let maybe_return_c_weak + should_return = + let c_weak1 = + let uu___15 = + should_return + && + (FStarC_TypeChecker_Common.is_pure_or_ghost_lcomp + c_weak) in + if uu___15 + then + let uu___16 + = + FStarC_TypeChecker_Env.push_bvs + scrutinee_env + pat_bvs in + FStarC_TypeChecker_Util.maybe_assume_result_eq_pure_term + uu___16 + branch_exp1 + c_weak + else c_weak in + if + close_branch_with_substitutions + then + ((let uu___16 + = + FStarC_Compiler_Effect.op_Bang + dbg_LayeredEffects in + if uu___16 + then + FStarC_Compiler_Util.print_string + "Typechecking pat_bv_tms ...\n" + else ()); + (let pat_bv_tms1 + = + FStarC_Compiler_List.map + (fun + pat_bv_tm + -> + let uu___16 + = + let uu___17 + = + FStarC_Syntax_Syntax.as_arg + scrutinee_tm in + [uu___17] in + FStarC_Syntax_Syntax.mk_Tm_app + pat_bv_tm + uu___16 + FStarC_Compiler_Range_Type.dummyRange) + pat_bv_tms in + let pat_bv_tms2 + = + let env1 = + let uu___16 + = + FStarC_TypeChecker_Env.push_bv + env + scrutinee in + { + FStarC_TypeChecker_Env.solver + = + (uu___16.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range + = + (uu___16.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule + = + (uu___16.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma + = + (uu___16.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig + = + (uu___16.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache + = + (uu___16.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules + = + (uu___16.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ + = + (uu___16.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab + = + (uu___16.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab + = + (uu___16.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp + = + (uu___16.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects + = + (uu___16.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize + = + (uu___16.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs + = + (uu___16.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level + = + (uu___16.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars + = + (uu___16.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict + = + (uu___16.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface + = + (uu___16.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit + = true; + FStarC_TypeChecker_Env.lax_universes + = + (uu___16.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 + = + (uu___16.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard + = + (uu___16.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking + = + (uu___16.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping + = + (uu___16.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics + = + (uu___16.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce + = + (uu___16.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term + = + (uu___16.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (uu___16.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of + = + (uu___16.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (uu___16.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force + = + (uu___16.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (uu___16.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (uu___16.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (uu___16.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths + = + (uu___16.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns + = + (uu___16.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook + = + (uu___16.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (uu___16.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice + = + (uu___16.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess + = + (uu___16.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess + = + (uu___16.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info + = + (uu___16.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks + = + (uu___16.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv + = + (uu___16.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe + = + (uu___16.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab + = + (uu___16.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (uu___16.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (uu___16.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (uu___16.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (uu___16.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check + = + (uu___16.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl + = + (uu___16.FStarC_TypeChecker_Env.missing_decl) + } in + let uu___16 + = + let uu___17 + = + FStarC_Compiler_List.fold_left2 + (fun + uu___18 + -> + fun + pat_bv_tm + -> + fun bv -> + match uu___18 + with + | + (substs, + acc) -> + let expected_t + = + FStarC_Syntax_Subst.subst + substs + bv.FStarC_Syntax_Syntax.sort in + let pat_bv_tm1 + = + let uu___19 + = + let uu___20 + = + FStarC_TypeChecker_Env.set_expected_typ + env1 + expected_t in + let uu___21 + = + FStarC_Syntax_Subst.subst + substs + pat_bv_tm in + tc_trivial_guard + uu___20 + uu___21 in + FStar_Pervasives_Native.fst + uu___19 in + ((FStarC_Compiler_List.op_At + substs + [ + FStarC_Syntax_Syntax.NT + (bv, + pat_bv_tm1)]), + (FStarC_Compiler_List.op_At + acc + [pat_bv_tm1]))) + ([], []) + pat_bv_tms1 + pat_bvs in + FStar_Pervasives_Native.snd + uu___17 in + FStarC_Compiler_List.map + (FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Beta] + env1) + uu___16 in + (let uu___17 + = + FStarC_Compiler_Effect.op_Bang + dbg_LayeredEffects in + if uu___17 + then + let uu___18 + = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_term) + pat_bv_tms2 in + let uu___19 + = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Syntax_Print.showable_bv) + pat_bvs in + FStarC_Compiler_Util.print2 + "tc_eqn: typechecked pat_bv_tms=%s (pat_bvs=%s)\n" + uu___18 + uu___19 + else ()); + (let uu___17 + = + FStarC_TypeChecker_Env.push_bv + env + scrutinee in + let uu___18 + = + FStarC_TypeChecker_Common.apply_lcomp + (fun c2 + -> c2) + (fun g -> + match eqs + with + | + FStar_Pervasives_Native.None + -> g + | + FStar_Pervasives_Native.Some + eqs1 -> + FStarC_TypeChecker_Common.weaken_guard_formula + g eqs1) + c_weak1 in + FStarC_TypeChecker_Util.close_layered_lcomp_with_substitutions + uu___17 + pat_bvs + pat_bv_tms2 + uu___18))) + else + (let uu___16 = + let uu___17 + = + FStarC_TypeChecker_Env.norm_eff_name + env + c_weak1.FStarC_TypeChecker_Common.eff_name in + FStarC_TypeChecker_Env.is_layered_effect + env + uu___17 in + if uu___16 + then + let uu___17 + = + FStarC_TypeChecker_Env.push_bv + env + scrutinee in + FStarC_TypeChecker_Util.close_layered_lcomp_with_combinator + uu___17 + pat_bvs + c_weak1 + else + (let uu___18 + = + FStarC_TypeChecker_Env.push_bv + env + scrutinee in + FStarC_TypeChecker_Util.close_wp_lcomp + uu___18 + pat_bvs + c_weak1)) in + let uu___15 = + FStarC_TypeChecker_Env.close_guard + env binders + g_when_weak in + let uu___16 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + guard_pat + g_branch1 in + ((c_weak.FStarC_TypeChecker_Common.eff_name), + (FStar_Pervasives_Native.Some + (c_weak.FStarC_TypeChecker_Common.cflags)), + (FStar_Pervasives_Native.Some + maybe_return_c_weak), + uu___15, + uu___16))) in + match uu___11 with + | (effect_label, cflags, + maybe_return_c, g_when1, + g_branch1) -> + let guard = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g_when1 g_branch1 in + ((let uu___13 = + FStarC_Compiler_Debug.high + () in + if uu___13 + then + let uu___14 = + FStarC_TypeChecker_Rel.guard_to_string + env guard in + FStarC_Compiler_Util.print1 + "Carrying guard from match: %s\n" + uu___14 + else ()); + (let uu___13 = + FStarC_Syntax_Subst.close_branch + (pattern1, when_clause1, + branch_exp1) in + let uu___14 = + let uu___15 = + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.mk_binder + pat_bvs in + FStarC_TypeChecker_Util.close_guard_implicits + env false uu___15 guard in + (uu___13, branch_guard, + effect_label, cflags, + maybe_return_c, uu___14, + erasable)))))))))))) +and (check_top_level_let : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.lcomp * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun e -> + let env1 = instantiate_both env in + match e.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (false, lb::[]); + FStarC_Syntax_Syntax.body1 = e2;_} + -> + let uu___ = check_let_bound_def true env1 lb in + (match uu___ with + | (e1, univ_vars, c1, g1, annotated) -> + let uu___1 = + if + annotated && + (Prims.op_Negation + env1.FStarC_TypeChecker_Env.generalize) + then + let uu___2 = + FStarC_TypeChecker_Normalize.reduce_uvar_solutions env1 + e1 in + (g1, uu___2, univ_vars, c1) + else + (let g11 = + let uu___3 = + FStarC_TypeChecker_Rel.solve_deferred_constraints + env1 g1 in + FStarC_TypeChecker_Rel.resolve_implicits env1 uu___3 in + let uu___3 = FStarC_TypeChecker_Common.lcomp_comp c1 in + match uu___3 with + | (comp1, g_comp1) -> + let g12 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t g11 + g_comp1 in + let uu___4 = + let uu___5 = + FStarC_TypeChecker_Generalize.generalize env1 + false + [((lb.FStarC_Syntax_Syntax.lbname), e1, comp1)] in + FStarC_Compiler_List.hd uu___5 in + (match uu___4 with + | (uu___5, univs, e11, c11, gvs) -> + let g13 = + FStarC_TypeChecker_Rel.resolve_generalization_implicits + env1 g12 in + let g14 = + FStarC_TypeChecker_Env.map_guard g13 + (FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.DoNotUnfoldPureLets; + FStarC_TypeChecker_Env.CompressUvars; + FStarC_TypeChecker_Env.NoFullNorm; + FStarC_TypeChecker_Env.Exclude + FStarC_TypeChecker_Env.Zeta] env1) in + let g15 = + FStarC_TypeChecker_Env.abstract_guard_n gvs + g14 in + let uu___6 = + FStarC_TypeChecker_Common.lcomp_of_comp c11 in + (g15, e11, univs, uu___6))) in + (match uu___1 with + | (g11, e11, univ_vars1, c11) -> + let uu___2 = + let uu___3 = + FStarC_TypeChecker_Util.check_top_level env1 g11 c11 in + match uu___3 with + | (ok, c12) -> + if ok + then (e2, c12) + else + ((let uu___6 = + let uu___7 = FStarC_Options.ml_ish () in + Prims.op_Negation uu___7 in + if uu___6 + then + let uu___7 = + FStarC_TypeChecker_Env.get_range env1 in + FStarC_TypeChecker_Err.warn_top_level_effect + uu___7 + else ()); + (let uu___6 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 = e2; + FStarC_Syntax_Syntax.meta = + (FStarC_Syntax_Syntax.Meta_desugared + FStarC_Syntax_Syntax.Masked_effect) + }) e2.FStarC_Syntax_Syntax.pos in + (uu___6, c12))) in + (match uu___2 with + | (e21, c12) -> + ((let uu___4 = FStarC_Compiler_Debug.medium () in + if uu___4 + then + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term e11 in + FStarC_Compiler_Util.print1 + "Let binding BEFORE tcnorm: %s\n" uu___5 + else ()); + (let e12 = + let uu___4 = FStarC_Options.tcnorm () in + if uu___4 + then + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.UnfoldAttr + [FStarC_Parser_Const.tcnorm_attr]; + FStarC_TypeChecker_Env.Exclude + FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Exclude + FStarC_TypeChecker_Env.Zeta; + FStarC_TypeChecker_Env.NoFullNorm; + FStarC_TypeChecker_Env.DoNotUnfoldPureLets] + env1 e11 + else e11 in + (let uu___5 = FStarC_Compiler_Debug.medium () in + if uu___5 + then + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term e12 in + FStarC_Compiler_Util.print1 + "Let binding AFTER tcnorm: %s\n" uu___6 + else ()); + (let cres = + FStarC_Syntax_Syntax.mk_Total + FStarC_Syntax_Syntax.t_unit in + let lb1 = + FStarC_Syntax_Util.close_univs_and_mk_letbinding + FStar_Pervasives_Native.None + lb.FStarC_Syntax_Syntax.lbname univ_vars1 + (FStarC_Syntax_Util.comp_result c12) + (FStarC_Syntax_Util.comp_effect_name c12) e12 + lb.FStarC_Syntax_Syntax.lbattrs + lb.FStarC_Syntax_Syntax.lbpos in + let uu___5 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = + (false, [lb1]); + FStarC_Syntax_Syntax.body1 = e21 + }) e.FStarC_Syntax_Syntax.pos in + let uu___6 = + FStarC_TypeChecker_Common.lcomp_of_comp cres in + (uu___5, uu___6, + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t)))))))) + | uu___ -> failwith "Impossible: check_top_level_let: not a let" +and (maybe_intro_smt_lemma : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_TypeChecker_Common.lcomp -> FStarC_TypeChecker_Common.lcomp) + = + fun env -> + fun lem_typ -> + fun c2 -> + let uu___ = FStarC_Syntax_Util.is_smt_lemma lem_typ in + if uu___ + then + let universe_of_binders bs = + let uu___1 = + FStarC_Compiler_List.fold_left + (fun uu___2 -> + fun b -> + match uu___2 with + | (env1, us) -> + let u = + env1.FStarC_TypeChecker_Env.universe_of env1 + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + let env2 = + FStarC_TypeChecker_Env.push_binders env1 [b] in + (env2, (u :: us))) (env, []) bs in + match uu___1 with | (uu___2, us) -> FStarC_Compiler_List.rev us in + let quant = + FStarC_Syntax_Util.smt_lemma_as_forall lem_typ + universe_of_binders in + FStarC_TypeChecker_Util.weaken_precondition env c2 + (FStarC_TypeChecker_Common.NonTrivial quant) + else c2 +and (check_inner_let : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.lcomp * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun e -> + let env1 = instantiate_both env in + match e.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (false, lb::[]); + FStarC_Syntax_Syntax.body1 = e2;_} + -> + let env2 = + { + FStarC_TypeChecker_Env.solver = + (env1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = false; + FStarC_TypeChecker_Env.check_uvars = + (env1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env1.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = (env1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env1.FStarC_TypeChecker_Env.missing_decl) + } in + let uu___ = + let uu___1 = + let uu___2 = FStarC_TypeChecker_Env.clear_expected_typ env2 in + FStar_Pervasives_Native.fst uu___2 in + check_let_bound_def false uu___1 lb in + (match uu___ with + | (e1, uu___1, c1, g1, annotated) -> + let pure_or_ghost = + FStarC_TypeChecker_Common.is_pure_or_ghost_lcomp c1 in + let is_inline_let = + FStarC_Compiler_Util.for_some + (FStarC_Syntax_Util.is_fvar + FStarC_Parser_Const.inline_let_attr) + lb.FStarC_Syntax_Syntax.lbattrs in + ((let uu___3 = + is_inline_let && + (let uu___4 = + pure_or_ghost || + (FStarC_TypeChecker_Env.is_erasable_effect env2 + c1.FStarC_TypeChecker_Common.eff_name) in + Prims.op_Negation uu___4) in + if uu___3 + then + let uu___4 = + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term e1 in + let uu___6 = + FStarC_Class_Show.show FStarC_Ident.showable_lident + c1.FStarC_TypeChecker_Common.eff_name in + FStarC_Compiler_Util.format2 + "Definitions marked @inline_let are expected to be pure or ghost; got an expression \"%s\" with effect \"%s\"" + uu___5 uu___6 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) e1 + FStarC_Errors_Codes.Fatal_ExpectedPureExpression () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4) + else ()); + (let x = + let uu___3 = + FStarC_Compiler_Util.left lb.FStarC_Syntax_Syntax.lbname in + { + FStarC_Syntax_Syntax.ppname = + (uu___3.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (uu___3.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = + (c1.FStarC_TypeChecker_Common.res_typ) + } in + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.mk_binder x in + [uu___5] in + FStarC_Syntax_Subst.open_term uu___4 e2 in + match uu___3 with + | (xb, e21) -> + let xbinder = FStarC_Compiler_List.hd xb in + let x1 = xbinder.FStarC_Syntax_Syntax.binder_bv in + let env_x = FStarC_TypeChecker_Env.push_bv env2 x1 in + let uu___4 = + let uu___5 = tc_term env_x e21 in + match uu___5 with + | (e22, c2, g2) -> + let uu___6 = + FStarC_TypeChecker_Util.strengthen_precondition + (FStar_Pervasives_Native.Some + (fun uu___7 -> + FStarC_Errors_Msg.mkmsg + "folding guard g2 of e2 in the lcomp")) + env_x e22 c2 g2 in + (match uu___6 with | (c21, g21) -> (e22, c21, g21)) in + (match uu___4 with + | (e22, c2, g2) -> + let c21 = + maybe_intro_smt_lemma env_x + c1.FStarC_TypeChecker_Common.res_typ c2 in + let cres = + FStarC_TypeChecker_Util.maybe_return_e2_and_bind + e1.FStarC_Syntax_Syntax.pos env2 + (FStar_Pervasives_Native.Some e1) c1 e22 + ((FStar_Pervasives_Native.Some x1), c21) in + let e11 = + FStarC_TypeChecker_Util.maybe_lift env2 e1 + c1.FStarC_TypeChecker_Common.eff_name + cres.FStarC_TypeChecker_Common.eff_name + c1.FStarC_TypeChecker_Common.res_typ in + let e23 = + FStarC_TypeChecker_Util.maybe_lift env2 e22 + c21.FStarC_TypeChecker_Common.eff_name + cres.FStarC_TypeChecker_Common.eff_name + c21.FStarC_TypeChecker_Common.res_typ in + let lb1 = + let attrs = + let add_inline_let = + (Prims.op_Negation is_inline_let) && + ((pure_or_ghost && + (FStarC_Syntax_Util.is_unit + c1.FStarC_TypeChecker_Common.res_typ)) + || + ((FStarC_TypeChecker_Env.is_erasable_effect + env2 + c1.FStarC_TypeChecker_Common.eff_name) + && + (let uu___5 = + FStarC_TypeChecker_Env.is_erasable_effect + env2 + cres.FStarC_TypeChecker_Common.eff_name in + Prims.op_Negation uu___5))) in + if add_inline_let + then FStarC_Syntax_Util.inline_let_attr :: + (lb.FStarC_Syntax_Syntax.lbattrs) + else lb.FStarC_Syntax_Syntax.lbattrs in + FStarC_Syntax_Util.mk_letbinding + (FStar_Pervasives.Inl x1) [] + c1.FStarC_TypeChecker_Common.res_typ + cres.FStarC_TypeChecker_Common.eff_name e11 + attrs lb.FStarC_Syntax_Syntax.lbpos in + let e3 = + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Syntax_Subst.close xb e23 in + { + FStarC_Syntax_Syntax.lbs = (false, [lb1]); + FStarC_Syntax_Syntax.body1 = uu___7 + } in + FStarC_Syntax_Syntax.Tm_let uu___6 in + FStarC_Syntax_Syntax.mk uu___5 + e.FStarC_Syntax_Syntax.pos in + let e4 = + FStarC_TypeChecker_Util.maybe_monadic env2 e3 + cres.FStarC_TypeChecker_Common.eff_name + cres.FStarC_TypeChecker_Common.res_typ in + let g21 = + let uu___5 = + let uu___6 = + FStarC_TypeChecker_Env.norm_eff_name env2 + cres.FStarC_TypeChecker_Common.eff_name in + FStarC_TypeChecker_Env.is_layered_effect env2 + uu___6 in + FStarC_TypeChecker_Util.close_guard_implicits + env2 uu___5 xb g2 in + let guard = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t g1 g21 in + let uu___5 = + let uu___6 = + FStarC_TypeChecker_Env.expected_typ env2 in + FStarC_Compiler_Option.isSome uu___6 in + if uu___5 + then + let tt = + let uu___6 = + let uu___7 = + FStarC_TypeChecker_Env.expected_typ env2 in + FStarC_Compiler_Option.get uu___7 in + FStar_Pervasives_Native.fst uu___6 in + ((let uu___7 = + FStarC_Compiler_Effect.op_Bang dbg_Exports in + if uu___7 + then + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term tt in + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + cres.FStarC_TypeChecker_Common.res_typ in + FStarC_Compiler_Util.print2 + "Got expected type from env %s\ncres.res_typ=%s\n" + uu___8 uu___9 + else ()); + (e4, cres, guard)) + else + (let uu___7 = + check_no_escape FStar_Pervasives_Native.None + env2 [x1] + cres.FStarC_TypeChecker_Common.res_typ in + match uu___7 with + | (t, g_ex) -> + ((let uu___9 = + FStarC_Compiler_Effect.op_Bang + dbg_Exports in + if uu___9 + then + let uu___10 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + cres.FStarC_TypeChecker_Common.res_typ in + let uu___11 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.print2 + "Checked %s has no escaping types; normalized to %s\n" + uu___10 uu___11 + else ()); + (let uu___9 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g_ex guard in + (e4, + { + FStarC_TypeChecker_Common.eff_name = + (cres.FStarC_TypeChecker_Common.eff_name); + FStarC_TypeChecker_Common.res_typ = t; + FStarC_TypeChecker_Common.cflags = + (cres.FStarC_TypeChecker_Common.cflags); + FStarC_TypeChecker_Common.comp_thunk = + (cres.FStarC_TypeChecker_Common.comp_thunk) + }, uu___9)))))))) + | uu___ -> failwith "Impossible (inner let with more than one lb)" +and (check_top_level_let_rec : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.lcomp * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun top -> + let env1 = instantiate_both env in + match top.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (true, lbs); + FStarC_Syntax_Syntax.body1 = e2;_} + -> + let uu___ = FStarC_Syntax_Subst.open_let_rec lbs e2 in + (match uu___ with + | (lbs1, e21) -> + let uu___1 = FStarC_TypeChecker_Env.clear_expected_typ env1 in + (match uu___1 with + | (env0, topt) -> + let uu___2 = build_let_rec_env true env0 lbs1 in + (match uu___2 with + | (lbs2, rec_env, g_t) -> + let uu___3 = check_let_recs rec_env lbs2 in + (match uu___3 with + | (lbs3, g_lbs) -> + let g_lbs1 = + let uu___4 = + let uu___5 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g_t g_lbs in + FStarC_TypeChecker_Rel.solve_deferred_constraints + env1 uu___5 in + FStarC_TypeChecker_Rel.resolve_implicits env1 + uu___4 in + let all_lb_names = + let uu___4 = + FStarC_Compiler_List.map + (fun lb -> + FStarC_Compiler_Util.right + lb.FStarC_Syntax_Syntax.lbname) lbs3 in + FStar_Pervasives_Native.Some uu___4 in + let uu___4 = + if + Prims.op_Negation + env1.FStarC_TypeChecker_Env.generalize + then + let lbs4 = + FStarC_Compiler_List.map + (fun lb -> + let lbdef = + FStarC_TypeChecker_Normalize.reduce_uvar_solutions + env1 + lb.FStarC_Syntax_Syntax.lbdef in + if + lb.FStarC_Syntax_Syntax.lbunivs = + [] + then lb + else + FStarC_Syntax_Util.close_univs_and_mk_letbinding + all_lb_names + lb.FStarC_Syntax_Syntax.lbname + lb.FStarC_Syntax_Syntax.lbunivs + lb.FStarC_Syntax_Syntax.lbtyp + lb.FStarC_Syntax_Syntax.lbeff + lbdef + lb.FStarC_Syntax_Syntax.lbattrs + lb.FStarC_Syntax_Syntax.lbpos) + lbs3 in + (lbs4, g_lbs1) + else + (let ecs = + let uu___6 = + FStarC_Compiler_List.map + (fun lb -> + let uu___7 = + FStarC_Syntax_Syntax.mk_Total + lb.FStarC_Syntax_Syntax.lbtyp in + ((lb.FStarC_Syntax_Syntax.lbname), + (lb.FStarC_Syntax_Syntax.lbdef), + uu___7)) lbs3 in + FStarC_TypeChecker_Generalize.generalize + env1 true uu___6 in + let lbs4 = + FStarC_Compiler_List.map2 + (fun uu___6 -> + fun lb -> + match uu___6 with + | (x, uvs, e, c, gvs) -> + FStarC_Syntax_Util.close_univs_and_mk_letbinding + all_lb_names x uvs + (FStarC_Syntax_Util.comp_result + c) + (FStarC_Syntax_Util.comp_effect_name + c) e + lb.FStarC_Syntax_Syntax.lbattrs + lb.FStarC_Syntax_Syntax.lbpos) + ecs lbs3 in + let g_lbs2 = + FStarC_TypeChecker_Rel.resolve_generalization_implicits + env1 g_lbs1 in + (lbs4, g_lbs2)) in + (match uu___4 with + | (lbs4, g_lbs2) -> + let cres = + let uu___5 = + FStarC_Syntax_Syntax.mk_Total + FStarC_Syntax_Syntax.t_unit in + FStarC_TypeChecker_Common.lcomp_of_comp + uu___5 in + let uu___5 = + FStarC_Syntax_Subst.close_let_rec lbs4 + e21 in + (match uu___5 with + | (lbs5, e22) -> + ((let uu___7 = + FStarC_TypeChecker_Rel.discharge_guard + env1 g_lbs2 in + FStarC_TypeChecker_Rel.force_trivial_guard + env1 uu___7); + (let uu___7 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = + (true, lbs5); + FStarC_Syntax_Syntax.body1 + = e22 + }) + top.FStarC_Syntax_Syntax.pos in + (uu___7, cres, + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t)))))))))) + | uu___ -> + failwith "Impossible: check_top_level_let_rec: not a let rec" +and (check_inner_let_rec : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.lcomp * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun top -> + let env1 = instantiate_both env in + match top.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (true, lbs); + FStarC_Syntax_Syntax.body1 = e2;_} + -> + let uu___ = FStarC_Syntax_Subst.open_let_rec lbs e2 in + (match uu___ with + | (lbs1, e21) -> + let uu___1 = FStarC_TypeChecker_Env.clear_expected_typ env1 in + (match uu___1 with + | (env0, topt) -> + let uu___2 = build_let_rec_env false env0 lbs1 in + (match uu___2 with + | (lbs2, rec_env, g_t) -> + let uu___3 = + let uu___4 = check_let_recs rec_env lbs2 in + match uu___4 with + | (lbs3, g) -> + let uu___5 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g_t g in + (lbs3, uu___5) in + (match uu___3 with + | (lbs3, g_lbs) -> + let uu___4 = + FStarC_Compiler_Util.fold_map + (fun env2 -> + fun lb -> + let x = + let uu___5 = + FStarC_Compiler_Util.left + lb.FStarC_Syntax_Syntax.lbname in + { + FStarC_Syntax_Syntax.ppname = + (uu___5.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (uu___5.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = + (lb.FStarC_Syntax_Syntax.lbtyp) + } in + let lb1 = + { + FStarC_Syntax_Syntax.lbname = + (FStar_Pervasives.Inl x); + FStarC_Syntax_Syntax.lbunivs = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = + (lb.FStarC_Syntax_Syntax.lbtyp); + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = + (lb.FStarC_Syntax_Syntax.lbdef); + FStarC_Syntax_Syntax.lbattrs = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + } in + let env3 = + FStarC_TypeChecker_Env.push_let_binding + env2 + lb1.FStarC_Syntax_Syntax.lbname + ([], + (lb1.FStarC_Syntax_Syntax.lbtyp)) in + (env3, lb1)) env1 lbs3 in + (match uu___4 with + | (env2, lbs4) -> + let bvs = + FStarC_Compiler_List.map + (fun lb -> + FStarC_Compiler_Util.left + lb.FStarC_Syntax_Syntax.lbname) + lbs4 in + let uu___5 = tc_term env2 e21 in + (match uu___5 with + | (e22, cres, g2) -> + let cres1 = + FStarC_Compiler_List.fold_right + (fun lb -> + fun cres2 -> + maybe_intro_smt_lemma env2 + lb.FStarC_Syntax_Syntax.lbtyp + cres2) lbs4 cres in + let cres2 = + FStarC_TypeChecker_Util.maybe_assume_result_eq_pure_term + env2 e22 cres1 in + let cres3 = + FStarC_TypeChecker_Common.lcomp_set_flags + cres2 + [FStarC_Syntax_Syntax.SHOULD_NOT_INLINE] in + let guard = + let uu___6 = + let uu___7 = + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.mk_binder + bvs in + FStarC_TypeChecker_Env.close_guard + env2 uu___7 g2 in + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g_lbs uu___6 in + let cres4 = + let uu___6 = + let uu___7 = + FStarC_TypeChecker_Env.norm_eff_name + env2 + cres3.FStarC_TypeChecker_Common.eff_name in + FStarC_TypeChecker_Env.is_layered_effect + env2 uu___7 in + if uu___6 + then + let bvss = + Obj.magic + (FStarC_Class_Setlike.from_list + () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) + bvs) in + FStarC_TypeChecker_Common.apply_lcomp + (fun c -> + let uu___7 = + let uu___8 = + FStarC_Syntax_Util.comp_effect_args + c in + FStarC_Compiler_List.existsb + (fun uu___9 -> + match uu___9 with + | (t, uu___10) -> + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Syntax_Free.names + t in + Obj.magic + (FStarC_Class_Setlike.inter + () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) + (Obj.magic + bvss) + (Obj.magic + uu___13)) in + FStarC_Class_Setlike.is_empty + () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) + (Obj.magic + uu___12) in + Prims.op_Negation + uu___11) uu___8 in + if uu___7 + then + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax + ()) top + FStarC_Errors_Codes.Fatal_EscapedBoundVar + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "One of the inner let recs escapes in the effect argument(s), try adding a type annotation") + else c) (fun g -> g) cres3 + else + FStarC_TypeChecker_Util.close_wp_lcomp + env2 bvs cres3 in + let tres = + norm env2 + cres4.FStarC_TypeChecker_Common.res_typ in + let cres5 = + { + FStarC_TypeChecker_Common.eff_name + = + (cres4.FStarC_TypeChecker_Common.eff_name); + FStarC_TypeChecker_Common.res_typ + = tres; + FStarC_TypeChecker_Common.cflags + = + (cres4.FStarC_TypeChecker_Common.cflags); + FStarC_TypeChecker_Common.comp_thunk + = + (cres4.FStarC_TypeChecker_Common.comp_thunk) + } in + let guard1 = + let bs = + FStarC_Compiler_List.map + (fun lb -> + let uu___6 = + FStarC_Compiler_Util.left + lb.FStarC_Syntax_Syntax.lbname in + FStarC_Syntax_Syntax.mk_binder + uu___6) lbs4 in + FStarC_TypeChecker_Util.close_guard_implicits + env2 false bs guard in + let uu___6 = + FStarC_Syntax_Subst.close_let_rec + lbs4 e22 in + (match uu___6 with + | (lbs5, e23) -> + let e = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs + = (true, lbs5); + FStarC_Syntax_Syntax.body1 + = e23 + }) + top.FStarC_Syntax_Syntax.pos in + (match topt with + | FStar_Pervasives_Native.Some + uu___7 -> + (e, cres5, guard1) + | FStar_Pervasives_Native.None + -> + let uu___7 = + check_no_escape + FStar_Pervasives_Native.None + env2 bvs tres in + (match uu___7 with + | (tres1, g_ex) -> + let cres6 = + { + FStarC_TypeChecker_Common.eff_name + = + (cres5.FStarC_TypeChecker_Common.eff_name); + FStarC_TypeChecker_Common.res_typ + = tres1; + FStarC_TypeChecker_Common.cflags + = + (cres5.FStarC_TypeChecker_Common.cflags); + FStarC_TypeChecker_Common.comp_thunk + = + (cres5.FStarC_TypeChecker_Common.comp_thunk) + } in + let uu___8 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g_ex guard1 in + (e, cres6, uu___8)))))))))) + | uu___ -> failwith "Impossible: check_inner_let_rec: not a let rec" +and (build_let_rec_env : + Prims.bool -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.letbinding Prims.list -> + (FStarC_Syntax_Syntax.letbinding Prims.list * + FStarC_TypeChecker_Env.env_t * FStarC_TypeChecker_Env.guard_t)) + = + fun _top_level -> + fun env -> + fun lbs -> + let env0 = env in + let termination_check_enabled attrs lbname lbdef lbtyp = + let uu___ = FStarC_Options.ml_ish () in + if uu___ + then FStar_Pervasives_Native.None + else + (let lbtyp0 = lbtyp in + let uu___2 = FStarC_Syntax_Util.abs_formals lbdef in + match uu___2 with + | (actuals, body, body_lc) -> + let actuals1 = + let uu___3 = + FStarC_TypeChecker_Env.set_expected_typ env lbtyp in + FStarC_TypeChecker_Util.maybe_add_implicit_binders uu___3 + actuals in + let nactuals = FStarC_Compiler_List.length actuals1 in + let uu___3 = + FStarC_TypeChecker_Normalize.get_n_binders env nactuals + lbtyp in + (match uu___3 with + | (formals, c) -> + (if + (FStarC_Compiler_List.isEmpty formals) || + (FStarC_Compiler_List.isEmpty actuals1) + then + (let uu___5 = + let uu___6 = + FStarC_Class_Tagged.tag_of + FStarC_Syntax_Syntax.tagged_term lbdef in + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term lbdef in + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term lbtyp in + FStarC_Compiler_Util.format3 + "Only function literals with arrow types can be defined recursively; got (%s) %s : %s" + uu___6 uu___7 uu___8 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) lbtyp + FStarC_Errors_Codes.Fatal_RecursiveFunctionLiteral + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___5)) + else (); + (let nformals = FStarC_Compiler_List.length formals in + let uu___5 = + FStarC_Syntax_Util.has_attribute attrs + FStarC_Parser_Const.admit_termination_lid in + if uu___5 + then + ((let uu___7 = + let uu___8 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_either + FStarC_Syntax_Print.showable_bv + FStarC_Syntax_Print.showable_fv) lbname in + Prims.strcat "Admitting termination of " uu___8 in + FStarC_Errors.log_issue + FStarC_TypeChecker_Env.hasRange_env env + FStarC_Errors_Codes.Warning_WarnOnUse () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___7)); + FStar_Pervasives_Native.None) + else + (let uu___7 = + let uu___8 = + FStarC_TypeChecker_Env.lookup_effect_quals env + (FStarC_Syntax_Util.comp_effect_name c) in + FStarC_Compiler_List.contains + FStarC_Syntax_Syntax.TotalEffect uu___8 in + if uu___7 + then + let uu___8 = + let uu___9 = + FStarC_Syntax_Util.abs actuals1 body body_lc in + (nformals, uu___9) in + FStar_Pervasives_Native.Some uu___8 + else FStar_Pervasives_Native.None))))) in + let check_annot univ_vars t = + let env01 = FStarC_TypeChecker_Env.push_univ_vars env0 univ_vars in + let uu___ = + let uu___1 = + let uu___2 = FStarC_Syntax_Util.type_u () in + FStar_Pervasives_Native.fst uu___2 in + tc_check_tot_or_gtot_term + { + FStarC_TypeChecker_Env.solver = + (env01.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env01.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env01.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env01.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env01.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env01.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env01.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env01.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env01.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env01.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env01.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env01.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env01.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env01.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env01.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = true; + FStarC_TypeChecker_Env.use_eq_strict = + (env01.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env01.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env01.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env01.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env01.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env01.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env01.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env01.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env01.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env01.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env01.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env01.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env01.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env01.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env01.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env01.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env01.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env01.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env01.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env01.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env01.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env01.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env01.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env01.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env01.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env01.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env01.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env01.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env01.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env01.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env01.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env01.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env01.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env01.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env01.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env01.FStarC_TypeChecker_Env.missing_decl) + } t uu___1 FStar_Pervasives_Native.None in + match uu___ with + | (t1, uu___1, g) -> + let uu___2 = + let uu___3 = FStarC_TypeChecker_Rel.resolve_implicits env g in + FStarC_TypeChecker_Rel.discharge_guard env01 uu___3 in + (env01, uu___2, t1) in + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun lb -> + match uu___1 with + | (lbs1, env1, g_acc) -> + let uu___2 = + FStarC_TypeChecker_Util.extract_let_rec_annotation + env1 lb in + (match uu___2 with + | (univ_vars, lbtyp, lbdef, check_t) -> + let env2 = + FStarC_TypeChecker_Env.push_univ_vars env1 + univ_vars in + let uu___3 = + if Prims.op_Negation check_t + then (g_acc, lbtyp) + else + (let uu___5 = check_annot univ_vars lbtyp in + match uu___5 with + | (uu___6, g, t) -> + let uu___7 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g_acc g in + (uu___7, t)) in + (match uu___3 with + | (g, lbtyp1) -> + let uu___4 = + let uu___5 = + termination_check_enabled + lb.FStarC_Syntax_Syntax.lbattrs + lb.FStarC_Syntax_Syntax.lbname lbdef + lbtyp1 in + match uu___5 with + | FStar_Pervasives_Native.Some + (arity, lbdef1) -> + ((let uu___7 = + FStarC_Compiler_Debug.extreme () in + if uu___7 + then + let uu___8 = + FStarC_Compiler_Util.string_of_int + arity in + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + lbdef1 in + FStarC_Compiler_Util.print2 + "termination_check_enabled returned arity: %s and lbdef: %s\n" + uu___8 uu___9 + else ()); + (let lb1 = + { + FStarC_Syntax_Syntax.lbname = + (lb.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs = + univ_vars; + FStarC_Syntax_Syntax.lbtyp = + lbtyp1; + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = + lbdef1; + FStarC_Syntax_Syntax.lbattrs = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + } in + let env3 = + { + FStarC_TypeChecker_Env.solver = + (env2.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env2.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env2.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env2.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env2.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache + = + (env2.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env2.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ + = + (env2.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env2.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env2.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp + = + (env2.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env2.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize + = + (env2.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (((lb1.FStarC_Syntax_Syntax.lbname), + arity, lbtyp1, univ_vars) :: + (env2.FStarC_TypeChecker_Env.letrecs)); + FStarC_TypeChecker_Env.top_level = + (env2.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars + = + (env2.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict + = + (env2.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env2.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env2.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes + = + (env2.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env2.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env2.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking + = + (env2.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping + = + (env2.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env2.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env2.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env2.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (env2.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of + = + (env2.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env2.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force + = + (env2.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (env2.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (env2.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (env2.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths + = + (env2.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env2.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook + = + (env2.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (env2.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env2.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess + = + (env2.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess + = + (env2.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info + = + (env2.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env2.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env2.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env2.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab + = + (env2.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (env2.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (env2.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (env2.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (env2.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check + = + (env2.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl + = + (env2.FStarC_TypeChecker_Env.missing_decl) + } in + (lb1, env3))) + | FStar_Pervasives_Native.None -> + let lb1 = + { + FStarC_Syntax_Syntax.lbname = + (lb.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs = + univ_vars; + FStarC_Syntax_Syntax.lbtyp = lbtyp1; + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = lbdef; + FStarC_Syntax_Syntax.lbattrs = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + } in + let uu___6 = + FStarC_TypeChecker_Env.push_let_binding + env2 lb1.FStarC_Syntax_Syntax.lbname + (univ_vars, lbtyp1) in + (lb1, uu___6) in + (match uu___4 with + | (lb1, env3) -> ((lb1 :: lbs1), env3, g))))) + ([], env, + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t)) lbs in + match uu___ with + | (lbs1, env1, g) -> ((FStarC_Compiler_List.rev lbs1), env1, g) +and (check_let_recs : + FStarC_TypeChecker_Env.env_t -> + FStarC_Syntax_Syntax.letbinding Prims.list -> + (FStarC_Syntax_Syntax.letbinding Prims.list * + FStarC_TypeChecker_Common.guard_t)) + = + fun env -> + fun lbts -> + let uu___ = + let uu___1 = + FStarC_Compiler_List.map + (fun lb -> + let uu___2 = + FStarC_Syntax_Util.abs_formals lb.FStarC_Syntax_Syntax.lbdef in + match uu___2 with + | (bs, t, lcomp) -> + (match bs with + | [] -> + let uu___3 = + FStarC_Syntax_Syntax.range_of_lbname + lb.FStarC_Syntax_Syntax.lbname in + let uu___4 = + let uu___5 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_either + FStarC_Syntax_Print.showable_bv + FStarC_Syntax_Print.showable_fv) + lb.FStarC_Syntax_Syntax.lbname in + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + lb.FStarC_Syntax_Syntax.lbdef in + FStarC_Compiler_Util.format2 + "Only function literals may be defined recursively; %s is defined to be %s" + uu___5 uu___6 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range uu___3 + FStarC_Errors_Codes.Fatal_RecursiveFunctionLiteral + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4) + | uu___3 -> + let arity = + let uu___4 = + FStarC_TypeChecker_Env.get_letrec_arity env + lb.FStarC_Syntax_Syntax.lbname in + match uu___4 with + | FStar_Pervasives_Native.Some n -> n + | FStar_Pervasives_Native.None -> + FStarC_Compiler_List.length bs in + let uu___4 = FStarC_Compiler_List.splitAt arity bs in + (match uu___4 with + | (bs0, bs1) -> + let def = + if FStarC_Compiler_List.isEmpty bs1 + then FStarC_Syntax_Util.abs bs0 t lcomp + else + (let inner = + FStarC_Syntax_Util.abs bs1 t lcomp in + let inner1 = + FStarC_Syntax_Subst.close bs0 inner in + let bs01 = + FStarC_Syntax_Subst.close_binders bs0 in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs = bs01; + FStarC_Syntax_Syntax.body = inner1; + FStarC_Syntax_Syntax.rc_opt = + FStar_Pervasives_Native.None + }) inner1.FStarC_Syntax_Syntax.pos) in + let lb1 = + { + FStarC_Syntax_Syntax.lbname = + (lb.FStarC_Syntax_Syntax.lbname); + FStarC_Syntax_Syntax.lbunivs = + (lb.FStarC_Syntax_Syntax.lbunivs); + FStarC_Syntax_Syntax.lbtyp = + (lb.FStarC_Syntax_Syntax.lbtyp); + FStarC_Syntax_Syntax.lbeff = + (lb.FStarC_Syntax_Syntax.lbeff); + FStarC_Syntax_Syntax.lbdef = def; + FStarC_Syntax_Syntax.lbattrs = + (lb.FStarC_Syntax_Syntax.lbattrs); + FStarC_Syntax_Syntax.lbpos = + (lb.FStarC_Syntax_Syntax.lbpos) + } in + let uu___5 = + let uu___6 = + FStarC_TypeChecker_Env.set_expected_typ env + lb1.FStarC_Syntax_Syntax.lbtyp in + tc_tot_or_gtot_term uu___6 + lb1.FStarC_Syntax_Syntax.lbdef in + (match uu___5 with + | (e, c, g) -> + ((let uu___7 = + let uu___8 = + FStarC_TypeChecker_Common.is_total_lcomp + c in + Prims.op_Negation uu___8 in + if uu___7 + then + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax + ()) e + FStarC_Errors_Codes.Fatal_UnexpectedGTotForLetRec + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Expected let rec to be a Tot term; got effect GTot") + else ()); + (let lb2 = + FStarC_Syntax_Util.mk_letbinding + lb1.FStarC_Syntax_Syntax.lbname + lb1.FStarC_Syntax_Syntax.lbunivs + lb1.FStarC_Syntax_Syntax.lbtyp + FStarC_Parser_Const.effect_Tot_lid e + lb1.FStarC_Syntax_Syntax.lbattrs + lb1.FStarC_Syntax_Syntax.lbpos in + (lb2, g))))))) lbts in + FStarC_Compiler_List.unzip uu___1 in + match uu___ with + | (lbs, gs) -> + let uu___1 = + FStarC_Class_Monoid.msum FStarC_TypeChecker_Common.monoid_guard_t + gs in + (lbs, uu___1) +and (check_let_bound_def : + Prims.bool -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.letbinding -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.univ_names * + FStarC_TypeChecker_Common.lcomp * FStarC_TypeChecker_Env.guard_t * + Prims.bool)) + = + fun top_level -> + fun env -> + fun lb -> + let uu___ = FStarC_TypeChecker_Env.clear_expected_typ env in + match uu___ with + | (env1, uu___1) -> + let e1 = lb.FStarC_Syntax_Syntax.lbdef in + let uu___2 = check_lbtyp top_level env lb in + (match uu___2 with + | (topt, wf_annot, univ_vars, univ_opening, env11) -> + (if (Prims.op_Negation top_level) && (univ_vars <> []) + then + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) e1 + FStarC_Errors_Codes.Fatal_UniversePolymorphicInnerLetBound + () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Inner let-bound definitions cannot be universe polymorphic") + else (); + (let e11 = FStarC_Syntax_Subst.subst univ_opening e1 in + let uu___4 = + tc_maybe_toplevel_term + { + FStarC_TypeChecker_Env.solver = + (env11.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env11.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env11.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env11.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env11.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env11.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env11.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env11.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env11.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env11.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env11.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env11.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env11.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env11.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = top_level; + FStarC_TypeChecker_Env.check_uvars = + (env11.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env11.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env11.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env11.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env11.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env11.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env11.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env11.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env11.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env11.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env11.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env11.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env11.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env11.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env11.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env11.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env11.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env11.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env11.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env11.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env11.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env11.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env11.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env11.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env11.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env11.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env11.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env11.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env11.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env11.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env11.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env11.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env11.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env11.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env11.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env11.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env11.FStarC_TypeChecker_Env.missing_decl) + } e11 in + match uu___4 with + | (e12, c1, g1) -> + let uu___5 = + let uu___6 = + FStarC_TypeChecker_Env.set_range env11 + e12.FStarC_Syntax_Syntax.pos in + FStarC_TypeChecker_Util.strengthen_precondition + (FStar_Pervasives_Native.Some + (fun uu___7 -> + FStarC_Compiler_Util.return_all + FStarC_TypeChecker_Err.ill_kinded_type)) + uu___6 e12 c1 wf_annot in + (match uu___5 with + | (c11, guard_f) -> + let g11 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t g1 + guard_f in + ((let uu___7 = FStarC_Compiler_Debug.extreme () in + if uu___7 + then + let uu___8 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_either + FStarC_Syntax_Print.showable_bv + FStarC_Syntax_Print.showable_fv) + lb.FStarC_Syntax_Syntax.lbname in + let uu___9 = + FStarC_TypeChecker_Common.lcomp_to_string + c11 in + let uu___10 = + FStarC_TypeChecker_Rel.guard_to_string env + g11 in + FStarC_Compiler_Util.print3 + "checked let-bound def %s : %s guard is %s\n" + uu___8 uu___9 uu___10 + else ()); + (e12, univ_vars, c11, g11, + (FStarC_Compiler_Option.isSome topt))))))) +and (check_lbtyp : + Prims.bool -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.letbinding -> + (FStarC_Syntax_Syntax.typ FStar_Pervasives_Native.option * + FStarC_TypeChecker_Env.guard_t * FStarC_Syntax_Syntax.univ_names * + FStarC_Syntax_Syntax.subst_elt Prims.list * + FStarC_TypeChecker_Env.env)) + = + fun top_level -> + fun env -> + fun lb -> + FStarC_Errors.with_ctx + "While checking type annotation of a letbinding" + (fun uu___ -> + let t = + FStarC_Syntax_Subst.compress lb.FStarC_Syntax_Syntax.lbtyp in + match t.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_unknown -> + let uu___1 = + FStarC_Syntax_Subst.univ_var_opening + lb.FStarC_Syntax_Syntax.lbunivs in + (match uu___1 with + | (univ_opening, univ_vars) -> + let uu___2 = + FStarC_TypeChecker_Env.push_univ_vars env univ_vars in + (FStar_Pervasives_Native.None, + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t), + univ_vars, univ_opening, uu___2)) + | uu___1 -> + let uu___2 = + FStarC_Syntax_Subst.univ_var_opening + lb.FStarC_Syntax_Syntax.lbunivs in + (match uu___2 with + | (univ_opening, univ_vars) -> + let t1 = FStarC_Syntax_Subst.subst univ_opening t in + let env1 = + FStarC_TypeChecker_Env.push_univ_vars env univ_vars in + if + top_level && + (Prims.op_Negation + env.FStarC_TypeChecker_Env.generalize) + then + let uu___3 = + FStarC_TypeChecker_Env.set_expected_typ env1 t1 in + ((FStar_Pervasives_Native.Some t1), + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t), + univ_vars, univ_opening, uu___3) + else + (let uu___4 = FStarC_Syntax_Util.type_u () in + match uu___4 with + | (k, uu___5) -> + let uu___6 = + tc_check_tot_or_gtot_term env1 t1 k + FStar_Pervasives_Native.None in + (match uu___6 with + | (t2, uu___7, g) -> + ((let uu___9 = + FStarC_Compiler_Debug.medium () in + if uu___9 + then + let uu___10 = + let uu___11 = + FStarC_Syntax_Syntax.range_of_lbname + lb.FStarC_Syntax_Syntax.lbname in + FStarC_Compiler_Range_Ops.string_of_range + uu___11 in + let uu___11 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t2 in + FStarC_Compiler_Util.print2 + "(%s) Checked type annotation %s\n" + uu___10 uu___11 + else ()); + (let t3 = norm env1 t2 in + let uu___9 = + FStarC_TypeChecker_Env.set_expected_typ + env1 t3 in + ((FStar_Pervasives_Native.Some t3), g, + univ_vars, univ_opening, uu___9))))))) +and (tc_binder : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.binder -> + (FStarC_Syntax_Syntax.binder * FStarC_TypeChecker_Env.env * + FStarC_TypeChecker_Common.guard_t * FStarC_Syntax_Syntax.universe)) + = + fun env -> + fun uu___ -> + match uu___ with + | { FStarC_Syntax_Syntax.binder_bv = x; + FStarC_Syntax_Syntax.binder_qual = imp; + FStarC_Syntax_Syntax.binder_positivity = pqual; + FStarC_Syntax_Syntax.binder_attrs = attrs;_} -> + let uu___1 = FStarC_Syntax_Util.type_u () in + (match uu___1 with + | (tu, u) -> + ((let uu___3 = FStarC_Compiler_Debug.extreme () in + if uu___3 + then + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_bv x in + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + x.FStarC_Syntax_Syntax.sort in + let uu___6 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + tu in + FStarC_Compiler_Util.print3 + "Checking binder %s:%s at type %s\n" uu___4 uu___5 + uu___6 + else ()); + (let uu___3 = + tc_check_tot_or_gtot_term env x.FStarC_Syntax_Syntax.sort + tu FStar_Pervasives_Native.None in + match uu___3 with + | (t, uu___4, g) -> + let uu___5 = + match imp with + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Meta tau) -> + let uu___6 = + tc_tactic FStarC_Syntax_Syntax.t_unit + FStarC_Syntax_Syntax.t_unit env tau in + (match uu___6 with + | (tau1, uu___7, g1) -> + ((FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Meta tau1)), g1)) + | uu___6 -> + (imp, + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t)) in + (match uu___5 with + | (imp1, g') -> + let uu___6 = tc_attributes env attrs in + (match uu___6 with + | (g_attrs, attrs1) -> + let g1 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t g + g_attrs in + (check_erasable_binder_attributes env attrs1 t; + (let x1 = + FStarC_Syntax_Syntax.mk_binder_with_attrs + { + FStarC_Syntax_Syntax.ppname = + (x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (x.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = t + } imp1 pqual attrs1 in + (let uu___9 = FStarC_Compiler_Debug.high () in + if uu___9 + then + let uu___10 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_bv + x1.FStarC_Syntax_Syntax.binder_bv in + let uu___11 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.print2 + "Pushing binder %s at type %s\n" + uu___10 uu___11 + else ()); + (let uu___9 = push_binding env x1 in + (x1, uu___9, g1, u))))))))) +and (tc_binders : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.binders -> + (FStarC_Syntax_Syntax.binders * FStarC_TypeChecker_Env.env * + FStarC_TypeChecker_Env.guard_t * FStarC_Syntax_Syntax.universes)) + = + fun env -> + fun bs -> + (let uu___1 = FStarC_Compiler_Debug.extreme () in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list FStarC_Syntax_Print.showable_binder) + bs in + FStarC_Compiler_Util.print1 "Checking binders %s\n" uu___2 + else ()); + (let rec aux env1 bs1 = + match bs1 with + | [] -> + ([], env1, + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t), []) + | b::bs2 -> + let uu___1 = tc_binder env1 b in + (match uu___1 with + | (b1, env', g, u) -> + let uu___2 = aux env' bs2 in + (match uu___2 with + | (bs3, env'1, g', us) -> + let uu___3 = + let uu___4 = + FStarC_TypeChecker_Env.close_guard_univs [u] + [b1] g' in + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t g uu___4 in + ((b1 :: bs3), env'1, uu___3, (u :: us)))) in + aux env bs) +and (tc_smt_pats : + FStarC_TypeChecker_Env.env -> + (FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax * + FStarC_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) + Prims.list Prims.list -> + ((FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax * + FStarC_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) + Prims.list Prims.list * FStarC_TypeChecker_Common.guard_t)) + = + fun en -> + fun pats -> + let tc_args en1 args = + FStarC_Compiler_List.fold_right + (fun uu___ -> + fun uu___1 -> + match (uu___, uu___1) with + | ((t, imp), (args1, g)) -> + (check_no_smt_theory_symbols en1 t; + (let uu___3 = tc_term en1 t in + match uu___3 with + | (t1, uu___4, g') -> + let uu___5 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t g g' in + (((t1, imp) :: args1), uu___5)))) args + ([], + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t)) in + FStarC_Compiler_List.fold_right + (fun p -> + fun uu___ -> + match uu___ with + | (pats1, g) -> + let uu___1 = tc_args en p in + (match uu___1 with + | (args, g') -> + let uu___2 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t g g' in + ((args :: pats1), uu___2))) pats + ([], + (FStarC_Class_Monoid.mzero FStarC_TypeChecker_Common.monoid_guard_t)) +and (tc_tot_or_gtot_term_maybe_solve_deferred : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + Prims.string FStar_Pervasives_Native.option -> + Prims.bool -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.lcomp * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun e -> + fun msg -> + fun solve_deferred -> + let uu___ = tc_maybe_toplevel_term env e in + match uu___ with + | (e1, c, g) -> + let uu___1 = FStarC_TypeChecker_Common.is_tot_or_gtot_lcomp c in + if uu___1 + then (e1, c, g) + else + (let g1 = + if solve_deferred + then + FStarC_TypeChecker_Rel.solve_deferred_constraints env g + else g in + let uu___3 = FStarC_TypeChecker_Common.lcomp_comp c in + match uu___3 with + | (c1, g_c) -> + let c2 = norm_c env c1 in + let uu___4 = + let uu___5 = + FStarC_TypeChecker_Util.is_pure_effect env + (FStarC_Syntax_Util.comp_effect_name c2) in + if uu___5 + then + let uu___6 = + FStarC_Syntax_Syntax.mk_Total + (FStarC_Syntax_Util.comp_result c2) in + (uu___6, false) + else + (let uu___7 = + FStarC_Syntax_Syntax.mk_GTotal + (FStarC_Syntax_Util.comp_result c2) in + (uu___7, true)) in + (match uu___4 with + | (target_comp, allow_ghost) -> + let uu___5 = + FStarC_TypeChecker_Rel.sub_comp env c2 + target_comp in + (match uu___5 with + | FStar_Pervasives_Native.Some g' -> + let uu___6 = + FStarC_TypeChecker_Common.lcomp_of_comp + target_comp in + let uu___7 = + let uu___8 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g_c g' in + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g1 uu___8 in + (e1, uu___6, uu___7) + | uu___6 -> + if allow_ghost + then + FStarC_TypeChecker_Err.expected_ghost_expression + e1.FStarC_Syntax_Syntax.pos e1 c2 msg + else + FStarC_TypeChecker_Err.expected_pure_expression + e1.FStarC_Syntax_Syntax.pos e1 c2 msg))) +and (tc_tot_or_gtot_term' : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + Prims.string FStar_Pervasives_Native.option -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.lcomp * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun e -> + fun msg -> tc_tot_or_gtot_term_maybe_solve_deferred env e msg true +and (tc_tot_or_gtot_term : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.lcomp * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> fun e -> tc_tot_or_gtot_term' env e FStar_Pervasives_Native.None +and (tc_check_tot_or_gtot_term : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.typ -> + Prims.string FStar_Pervasives_Native.option -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.lcomp * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun e -> + fun t -> + fun msg -> + let env1 = FStarC_TypeChecker_Env.set_expected_typ env t in + tc_tot_or_gtot_term' env1 e msg +and (tc_trivial_guard : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.lcomp)) + = + fun env -> + fun t -> + let uu___ = tc_tot_or_gtot_term env t in + match uu___ with + | (t1, c, g) -> + (FStarC_TypeChecker_Rel.force_trivial_guard env g; (t1, c)) +and (tc_attributes : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term Prims.list -> + (FStarC_TypeChecker_Env.guard_t * FStarC_Syntax_Syntax.term Prims.list)) + = + fun env -> + fun attrs -> + FStarC_Compiler_List.fold_left + (fun uu___ -> + fun attr -> + match uu___ with + | (g, attrs1) -> + let uu___1 = tc_tot_or_gtot_term env attr in + (match uu___1 with + | (attr', uu___2, g') -> + let uu___3 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t g g' in + (uu___3, (attr' :: attrs1)))) + ((FStarC_Class_Monoid.mzero FStarC_TypeChecker_Common.monoid_guard_t), + []) (FStarC_Compiler_List.rev attrs) +let (tc_check_trivial_guard : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun env -> + fun t -> + fun k -> + let uu___ = + tc_check_tot_or_gtot_term env t k FStar_Pervasives_Native.None in + match uu___ with + | (t1, uu___1, g) -> + (FStarC_TypeChecker_Rel.force_trivial_guard env g; t1) +let (typeof_tot_or_gtot_term : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + Prims.bool -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.typ * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun e -> + fun must_tot -> + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_RelCheck in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + FStarC_Compiler_Util.print1 "Checking term %s\n" uu___2 + else ()); + (let env1 = + { + FStarC_TypeChecker_Env.solver = + (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = []; + FStarC_TypeChecker_Env.top_level = false; + FStarC_TypeChecker_Env.check_uvars = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env.FStarC_TypeChecker_Env.missing_decl) + } in + let uu___1 = + try + (fun uu___2 -> match () with | () -> tc_tot_or_gtot_term env1 e) + () + with + | FStarC_Errors.Error (e1, msg, r, ctx) when + r = FStarC_Compiler_Range_Type.dummyRange -> + let uu___3 = + let uu___4 = + let uu___5 = FStarC_TypeChecker_Env.get_range env1 in + (e1, msg, uu___5, ctx) in + FStarC_Errors.Error uu___4 in + FStarC_Compiler_Effect.raise uu___3 in + match uu___1 with + | (t, c, g) -> + if must_tot + then + let c1 = + FStarC_TypeChecker_Normalize.maybe_ghost_to_pure_lcomp env1 + c in + let uu___2 = FStarC_TypeChecker_Common.is_total_lcomp c1 in + (if uu___2 + then (t, (c1.FStarC_TypeChecker_Common.res_typ), g) + else + (let uu___4 = + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term e in + FStarC_Compiler_Util.format1 + "Implicit argument: Expected a total term; got a ghost term: %s" + uu___5 in + FStarC_Errors.raise_error + FStarC_TypeChecker_Env.hasRange_env env1 + FStarC_Errors_Codes.Fatal_UnexpectedImplictArgument () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4))) + else (t, (c.FStarC_TypeChecker_Common.res_typ), g)) +let level_of_type_fail : + 'uuuuu . + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> Prims.string -> 'uuuuu + = + fun env -> + fun e -> + fun t -> + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + FStarC_Compiler_Util.format2 + "Expected a type; got %s of type %s" uu___3 t in + FStarC_Errors_Msg.text uu___2 in + [uu___1] in + FStarC_Errors.raise_error FStarC_TypeChecker_Env.hasRange_env env + FStarC_Errors_Codes.Fatal_UnexpectedTermType () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___) +let (level_of_type : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.universe) + = + fun env -> + fun e -> + fun t -> + let rec aux retry t1 = + let uu___ = + let uu___1 = FStarC_Syntax_Util.unrefine t1 in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_type u -> u + | uu___1 -> + if retry + then + let t2 = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant] env t1 in + aux false t2 + else + (let uu___3 = FStarC_Syntax_Util.type_u () in + match uu___3 with + | (t_u, u) -> + let env1 = + { + FStarC_TypeChecker_Env.solver = + (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = true; + FStarC_TypeChecker_Env.lax_universes = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env.FStarC_TypeChecker_Env.missing_decl) + } in + let g = FStarC_TypeChecker_Rel.teq env1 t1 t_u in + ((match g.FStarC_TypeChecker_Common.guard_f with + | FStarC_TypeChecker_Common.NonTrivial f -> + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t1 in + level_of_type_fail env1 e uu___5 + | uu___5 -> + FStarC_TypeChecker_Rel.force_trivial_guard env1 g); + u)) in + aux true t +let rec (apply_well_typed : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.typ FStar_Pervasives_Native.option) + = + fun env -> + fun t_hd -> + fun args -> + if (FStarC_Compiler_List.length args) = Prims.int_zero + then FStar_Pervasives_Native.Some t_hd + else + (let uu___1 = + let uu___2 = FStarC_TypeChecker_Normalize.unfold_whnf env t_hd in + uu___2.FStarC_Syntax_Syntax.n in + match uu___1 with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = c;_} + -> + let n_args = FStarC_Compiler_List.length args in + let n_bs = FStarC_Compiler_List.length bs in + let uu___2 = + if n_args < n_bs + then + let uu___3 = FStarC_Compiler_Util.first_N n_args bs in + match uu___3 with + | (bs1, rest) -> + let t = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_arrow + { + FStarC_Syntax_Syntax.bs1 = rest; + FStarC_Syntax_Syntax.comp = c + }) t_hd.FStarC_Syntax_Syntax.pos in + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.mk_Total t in + FStarC_Syntax_Subst.open_comp bs1 uu___5 in + (match uu___4 with + | (bs2, c1) -> + (bs2, args, (FStarC_Syntax_Util.comp_result c1), + [])) + else + (let uu___4 = FStarC_Syntax_Subst.open_comp bs c in + match uu___4 with + | (bs1, c1) -> + let uu___5 = FStarC_Compiler_List.splitAt n_bs args in + (match uu___5 with + | (args1, remaining_args) -> + (bs1, args1, + (FStarC_Syntax_Util.comp_result c1), + remaining_args))) in + (match uu___2 with + | (bs1, args1, t, remaining_args) -> + let subst = + FStarC_Compiler_List.map2 + (fun b -> + fun a -> + FStarC_Syntax_Syntax.NT + ((b.FStarC_Syntax_Syntax.binder_bv), + (FStar_Pervasives_Native.fst a))) bs1 args1 in + let t1 = FStarC_Syntax_Subst.subst subst t in + apply_well_typed env t1 remaining_args) + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x; + FStarC_Syntax_Syntax.phi = uu___2;_} + -> apply_well_typed env x.FStarC_Syntax_Syntax.sort args + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t; + FStarC_Syntax_Syntax.asc = uu___2; + FStarC_Syntax_Syntax.eff_opt = uu___3;_} + -> apply_well_typed env t args + | uu___2 -> FStar_Pervasives_Native.None) +let rec (universe_of_aux : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term) + = + fun env -> + fun e -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress e in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_bvar uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + Prims.strcat "TcTerm.universe_of:Impossible (bvar/unknown/lazy) " + uu___3 in + failwith uu___2 + | FStarC_Syntax_Syntax.Tm_unknown -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + Prims.strcat "TcTerm.universe_of:Impossible (bvar/unknown/lazy) " + uu___2 in + failwith uu___1 + | FStarC_Syntax_Syntax.Tm_delayed uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + Prims.strcat "TcTerm.universe_of:Impossible (bvar/unknown/lazy) " + uu___3 in + failwith uu___2 + | FStarC_Syntax_Syntax.Tm_let uu___1 -> + let e1 = FStarC_TypeChecker_Normalize.normalize [] env e in + universe_of_aux env e1 + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs; FStarC_Syntax_Syntax.body = t; + FStarC_Syntax_Syntax.rc_opt = uu___1;_} + -> level_of_type_fail env e "arrow type" + | FStarC_Syntax_Syntax.Tm_uvar (u, s) -> + let uu___1 = FStarC_Syntax_Util.ctx_uvar_typ u in + FStarC_Syntax_Subst.subst' s uu___1 + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t; + FStarC_Syntax_Syntax.meta = uu___1;_} + -> universe_of_aux env t + | FStarC_Syntax_Syntax.Tm_name n -> + let uu___1 = FStarC_TypeChecker_Env.lookup_bv env n in + (match uu___1 with | (t, _rng) -> t) + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let uu___1 = + FStarC_TypeChecker_Env.lookup_lid env + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + (match uu___1 with | ((uu___2, t), uu___3) -> t) + | FStarC_Syntax_Syntax.Tm_lazy i -> + let uu___1 = FStarC_Syntax_Util.unfold_lazy i in + universe_of_aux env uu___1 + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = uu___1; + FStarC_Syntax_Syntax.asc = + (FStar_Pervasives.Inl t, uu___2, uu___3); + FStarC_Syntax_Syntax.eff_opt = uu___4;_} + -> t + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = uu___1; + FStarC_Syntax_Syntax.asc = + (FStar_Pervasives.Inr c, uu___2, uu___3); + FStarC_Syntax_Syntax.eff_opt = uu___4;_} + -> FStarC_Syntax_Util.comp_result c + | FStarC_Syntax_Syntax.Tm_type u -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_type (FStarC_Syntax_Syntax.U_succ u)) + e.FStarC_Syntax_Syntax.pos + | FStarC_Syntax_Syntax.Tm_quoted uu___1 -> FStarC_Syntax_Util.ktype0 + | FStarC_Syntax_Syntax.Tm_constant sc -> + tc_constant env e.FStarC_Syntax_Syntax.pos sc + | FStarC_Syntax_Syntax.Tm_uinst + ({ FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar fv; + FStarC_Syntax_Syntax.pos = uu___1; + FStarC_Syntax_Syntax.vars = uu___2; + FStarC_Syntax_Syntax.hash_code = uu___3;_}, + us) + -> + let uu___4 = + FStarC_TypeChecker_Env.lookup_lid env + (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + (match uu___4 with + | ((us', t), uu___5) -> + (if + (FStarC_Compiler_List.length us) <> + (FStarC_Compiler_List.length us') + then + FStarC_Errors.raise_error + FStarC_TypeChecker_Env.hasRange_env env + FStarC_Errors_Codes.Fatal_UnexpectedNumberOfUniverse () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic "Unexpected number of universe instantiations") + else (); + FStarC_Compiler_List.iter2 + (fun ul -> + fun ur -> + match (ul, ur) with + | (FStarC_Syntax_Syntax.U_unif u'', uu___8) -> + FStarC_Syntax_Unionfind.univ_change u'' ur + | (FStarC_Syntax_Syntax.U_name n1, + FStarC_Syntax_Syntax.U_name n2) when + FStarC_Ident.ident_equals n1 n2 -> () + | uu___8 -> + let uu___9 = + let uu___10 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_fv fv in + let uu___11 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_univ ul in + let uu___12 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_univ ur in + FStarC_Compiler_Util.format3 + "Incompatible universe application for %s, expected %s got %s\n" + uu___10 uu___11 uu___12 in + FStarC_Errors.raise_error + FStarC_TypeChecker_Env.hasRange_env env + FStarC_Errors_Codes.Fatal_IncompatibleUniverse + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___9)) us' us; + t)) + | FStarC_Syntax_Syntax.Tm_uinst uu___1 -> + failwith "Impossible: Tm_uinst's head must be an fvar" + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x; FStarC_Syntax_Syntax.phi = uu___1;_} + -> universe_of_aux env x.FStarC_Syntax_Syntax.sort + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; FStarC_Syntax_Syntax.comp = c;_} + -> + let uu___1 = FStarC_Syntax_Subst.open_comp bs c in + (match uu___1 with + | (bs1, c1) -> + let env1 = FStarC_TypeChecker_Env.push_binders env bs1 in + let us = + FStarC_Compiler_List.map + (fun uu___2 -> + match uu___2 with + | { FStarC_Syntax_Syntax.binder_bv = b; + FStarC_Syntax_Syntax.binder_qual = uu___3; + FStarC_Syntax_Syntax.binder_positivity = uu___4; + FStarC_Syntax_Syntax.binder_attrs = uu___5;_} -> + let uu___6 = + universe_of_aux env1 b.FStarC_Syntax_Syntax.sort in + level_of_type env1 b.FStarC_Syntax_Syntax.sort + uu___6) bs1 in + let u_res = + let res = FStarC_Syntax_Util.comp_result c1 in + let uu___2 = universe_of_aux env1 res in + level_of_type env1 res uu___2 in + let u_c = + FStarC_TypeChecker_Util.universe_of_comp env1 u_res c1 in + let u = + FStarC_TypeChecker_Normalize.normalize_universe env1 + (FStarC_Syntax_Syntax.U_max (u_c :: us)) in + FStarC_Syntax_Syntax.mk (FStarC_Syntax_Syntax.Tm_type u) + e.FStarC_Syntax_Syntax.pos) + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = hd; FStarC_Syntax_Syntax.args = args;_} + -> + let rec type_of_head retry env1 hd1 args1 = + let hd2 = FStarC_Syntax_Subst.compress hd1 in + match hd2.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_unknown -> + failwith + "Impossible: universe_of_aux: Tm_app: unexpected head type" + | FStarC_Syntax_Syntax.Tm_bvar uu___1 -> + failwith + "Impossible: universe_of_aux: Tm_app: unexpected head type" + | FStarC_Syntax_Syntax.Tm_delayed uu___1 -> + failwith + "Impossible: universe_of_aux: Tm_app: unexpected head type" + | FStarC_Syntax_Syntax.Tm_fvar uu___1 -> + let uu___2 = universe_of_aux env1 hd2 in (uu___2, args1) + | FStarC_Syntax_Syntax.Tm_name uu___1 -> + let uu___2 = universe_of_aux env1 hd2 in (uu___2, args1) + | FStarC_Syntax_Syntax.Tm_uvar uu___1 -> + let uu___2 = universe_of_aux env1 hd2 in (uu___2, args1) + | FStarC_Syntax_Syntax.Tm_uinst uu___1 -> + let uu___2 = universe_of_aux env1 hd2 in (uu___2, args1) + | FStarC_Syntax_Syntax.Tm_ascribed uu___1 -> + let uu___2 = universe_of_aux env1 hd2 in (uu___2, args1) + | FStarC_Syntax_Syntax.Tm_refine uu___1 -> + let uu___2 = universe_of_aux env1 hd2 in (uu___2, args1) + | FStarC_Syntax_Syntax.Tm_constant uu___1 -> + let uu___2 = universe_of_aux env1 hd2 in (uu___2, args1) + | FStarC_Syntax_Syntax.Tm_arrow uu___1 -> + let uu___2 = universe_of_aux env1 hd2 in (uu___2, args1) + | FStarC_Syntax_Syntax.Tm_meta uu___1 -> + let uu___2 = universe_of_aux env1 hd2 in (uu___2, args1) + | FStarC_Syntax_Syntax.Tm_type uu___1 -> + let uu___2 = universe_of_aux env1 hd2 in (uu___2, args1) + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = uu___1; + FStarC_Syntax_Syntax.ret_opt = uu___2; + FStarC_Syntax_Syntax.brs = b::uu___3; + FStarC_Syntax_Syntax.rc_opt1 = uu___4;_} + -> + let uu___5 = FStarC_Syntax_Subst.open_branch b in + (match uu___5 with + | (pat, uu___6, tm) -> + let bvs = FStarC_Syntax_Syntax.pat_bvs pat in + let uu___7 = FStarC_Syntax_Util.head_and_args tm in + (match uu___7 with + | (hd3, args') -> + let uu___8 = + FStarC_TypeChecker_Env.push_bvs env1 bvs in + type_of_head retry uu___8 hd3 + (FStarC_Compiler_List.op_At args' args1))) + | uu___1 when retry -> + let e1 = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.DoNotUnfoldPureLets] env1 e in + let uu___2 = FStarC_Syntax_Util.head_and_args e1 in + (match uu___2 with + | (hd3, args2) -> type_of_head false env1 hd3 args2) + | uu___1 -> + let uu___2 = FStarC_TypeChecker_Env.clear_expected_typ env1 in + (match uu___2 with + | (env2, uu___3) -> + let env3 = + { + FStarC_TypeChecker_Env.solver = + (env2.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env2.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env2.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env2.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env2.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env2.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env2.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env2.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env2.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env2.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env2.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env2.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env2.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env2.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = false; + FStarC_TypeChecker_Env.check_uvars = + (env2.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env2.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env2.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = true; + FStarC_TypeChecker_Env.lax_universes = + (env2.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env2.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env2.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env2.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env2.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env2.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env2.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env2.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env2.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env2.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env2.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env2.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env2.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env2.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env2.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env2.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env2.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env2.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env2.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env2.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env2.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env2.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env2.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env2.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env2.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = + (env2.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env2.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env2.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env2.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env2.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env2.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env2.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env2.FStarC_TypeChecker_Env.missing_decl) + } in + ((let uu___5 = + FStarC_Compiler_Effect.op_Bang dbg_UniverseOf in + if uu___5 + then + let uu___6 = + let uu___7 = FStarC_TypeChecker_Env.get_range env3 in + FStarC_Compiler_Range_Ops.string_of_range uu___7 in + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term hd2 in + FStarC_Compiler_Util.print2 + "%s: About to type-check %s\n" uu___6 uu___7 + else ()); + (let uu___5 = tc_term env3 hd2 in + match uu___5 with + | (uu___6, + { FStarC_TypeChecker_Common.eff_name = uu___7; + FStarC_TypeChecker_Common.res_typ = t; + FStarC_TypeChecker_Common.cflags = uu___8; + FStarC_TypeChecker_Common.comp_thunk = uu___9;_}, + g) -> + ((let uu___11 = + FStarC_TypeChecker_Rel.solve_deferred_constraints + env3 g in + ()); + (t, args1))))) in + let uu___1 = type_of_head true env hd args in + (match uu___1 with + | (t, args1) -> + let uu___2 = apply_well_typed env t args1 in + (match uu___2 with + | FStar_Pervasives_Native.Some t1 -> t1 + | FStar_Pervasives_Native.None -> + let uu___3 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + level_of_type_fail env e uu___3)) + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = uu___1; + FStarC_Syntax_Syntax.ret_opt = uu___2; + FStarC_Syntax_Syntax.brs = b::uu___3; + FStarC_Syntax_Syntax.rc_opt1 = uu___4;_} + -> + let uu___5 = FStarC_Syntax_Subst.open_branch b in + (match uu___5 with + | (pat, uu___6, tm) -> + let bvs = FStarC_Syntax_Syntax.pat_bvs pat in + let uu___7 = FStarC_TypeChecker_Env.push_bvs env bvs in + universe_of_aux uu___7 tm) + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = uu___1; + FStarC_Syntax_Syntax.ret_opt = uu___2; + FStarC_Syntax_Syntax.brs = []; + FStarC_Syntax_Syntax.rc_opt1 = uu___3;_} + -> level_of_type_fail env e "empty match cases" +let (universe_of : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.universe) + = + fun env -> + fun e -> + FStarC_Errors.with_ctx "While attempting to compute a universe level" + (fun uu___ -> + (let uu___2 = FStarC_Compiler_Debug.high () in + if uu___2 + then + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + FStarC_Compiler_Util.print1 + "Calling universe_of_aux with %s {\n" uu___3 + else ()); + FStarC_Defensive.def_check_scoped + FStarC_TypeChecker_Env.hasBinders_env + FStarC_Class_Binders.hasNames_term + FStarC_Syntax_Print.pretty_term e.FStarC_Syntax_Syntax.pos + "universe_of entry" env e; + (let r = universe_of_aux env e in + (let uu___4 = FStarC_Compiler_Debug.high () in + if uu___4 + then + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term r in + FStarC_Compiler_Util.print1 + "Got result from universe_of_aux = %s }\n" uu___5 + else ()); + level_of_type env e r)) +let (tc_tparams : + FStarC_TypeChecker_Env.env_t -> + FStarC_Syntax_Syntax.binders -> + (FStarC_Syntax_Syntax.binders * FStarC_TypeChecker_Env.env * + FStarC_Syntax_Syntax.universes)) + = + fun env0 -> + fun tps -> + let uu___ = tc_binders env0 tps in + match uu___ with + | (tps1, env, g, us) -> + (FStarC_TypeChecker_Rel.force_trivial_guard env0 g; (tps1, env, us)) +let rec (__typeof_tot_or_gtot_term_fastpath : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + Prims.bool -> FStarC_Syntax_Syntax.typ FStar_Pervasives_Native.option) + = + fun env -> + fun t -> + fun must_tot -> + let mk_tm_type u = + FStarC_Syntax_Syntax.mk (FStarC_Syntax_Syntax.Tm_type u) + t.FStarC_Syntax_Syntax.pos in + let effect_ok k = + (Prims.op_Negation must_tot) || + (FStarC_TypeChecker_Normalize.non_info_norm env k) in + let t1 = FStarC_Syntax_Subst.compress t in + match t1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_delayed uu___ -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + Prims.strcat "Impossible: " uu___2 in + failwith uu___1 + | FStarC_Syntax_Syntax.Tm_bvar uu___ -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + Prims.strcat "Impossible: " uu___2 in + failwith uu___1 + | FStarC_Syntax_Syntax.Tm_constant (FStarC_Const.Const_reify uu___) + -> FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Tm_constant (FStarC_Const.Const_reflect uu___) + -> FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Tm_name uu___ -> + let uu___1 = universe_of_aux env t1 in + FStar_Pervasives_Native.Some uu___1 + | FStarC_Syntax_Syntax.Tm_fvar uu___ -> + let uu___1 = universe_of_aux env t1 in + FStar_Pervasives_Native.Some uu___1 + | FStarC_Syntax_Syntax.Tm_uinst uu___ -> + let uu___1 = universe_of_aux env t1 in + FStar_Pervasives_Native.Some uu___1 + | FStarC_Syntax_Syntax.Tm_constant uu___ -> + let uu___1 = universe_of_aux env t1 in + FStar_Pervasives_Native.Some uu___1 + | FStarC_Syntax_Syntax.Tm_type uu___ -> + let uu___1 = universe_of_aux env t1 in + FStar_Pervasives_Native.Some uu___1 + | FStarC_Syntax_Syntax.Tm_arrow uu___ -> + let uu___1 = universe_of_aux env t1 in + FStar_Pervasives_Native.Some uu___1 + | FStarC_Syntax_Syntax.Tm_lazy i -> + let uu___ = FStarC_Syntax_Util.unfold_lazy i in + __typeof_tot_or_gtot_term_fastpath env uu___ must_tot + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs; FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.residual_effect = eff; + FStarC_Syntax_Syntax.residual_typ = tbody; + FStarC_Syntax_Syntax.residual_flags = uu___;_};_} + -> + let mk_comp = + let uu___1 = + FStarC_Ident.lid_equals eff + FStarC_Parser_Const.effect_Tot_lid in + if uu___1 + then FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.mk_Total + else + (let uu___3 = + FStarC_Ident.lid_equals eff + FStarC_Parser_Const.effect_GTot_lid in + if uu___3 + then + FStar_Pervasives_Native.Some + FStarC_Syntax_Syntax.mk_GTotal + else FStar_Pervasives_Native.None) in + FStarC_Compiler_Util.bind_opt mk_comp + (fun f -> + let tbody1 = + match tbody with + | FStar_Pervasives_Native.Some uu___1 -> tbody + | FStar_Pervasives_Native.None -> + let uu___1 = FStarC_Syntax_Subst.open_term bs body in + (match uu___1 with + | (bs1, body1) -> + let uu___2 = + let uu___3 = + FStarC_TypeChecker_Env.push_binders env bs1 in + __typeof_tot_or_gtot_term_fastpath uu___3 body1 + false in + FStarC_Compiler_Util.map_opt uu___2 + (FStarC_Syntax_Subst.close bs1)) in + FStarC_Compiler_Util.bind_opt tbody1 + (fun tbody2 -> + let uu___1 = FStarC_Syntax_Subst.open_term bs tbody2 in + match uu___1 with + | (bs1, tbody3) -> + let u = + let uu___2 = + FStarC_TypeChecker_Env.push_binders env bs1 in + universe_of uu___2 tbody3 in + let uu___2 = + let uu___3 = f tbody3 in + FStarC_Syntax_Util.arrow bs1 uu___3 in + FStar_Pervasives_Native.Some uu___2)) + | FStarC_Syntax_Syntax.Tm_abs uu___ -> FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x; FStarC_Syntax_Syntax.phi = uu___;_} + -> + __typeof_tot_or_gtot_term_fastpath env + x.FStarC_Syntax_Syntax.sort must_tot + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_range_of); + FStarC_Syntax_Syntax.pos = uu___; + FStarC_Syntax_Syntax.vars = uu___1; + FStarC_Syntax_Syntax.hash_code = uu___2;_}; + FStarC_Syntax_Syntax.args = a::hd::rest;_} + -> + let rest1 = hd :: rest in + let uu___3 = FStarC_Syntax_Util.head_and_args t1 in + (match uu___3 with + | (unary_op, uu___4) -> + let head = + let uu___5 = + FStarC_Compiler_Range_Ops.union_ranges + unary_op.FStarC_Syntax_Syntax.pos + (FStar_Pervasives_Native.fst a).FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = unary_op; + FStarC_Syntax_Syntax.args = [a] + }) uu___5 in + let t2 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = rest1 + }) t1.FStarC_Syntax_Syntax.pos in + __typeof_tot_or_gtot_term_fastpath env t2 must_tot) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_set_range_of); + FStarC_Syntax_Syntax.pos = uu___; + FStarC_Syntax_Syntax.vars = uu___1; + FStarC_Syntax_Syntax.hash_code = uu___2;_}; + FStarC_Syntax_Syntax.args = a1::a2::hd::rest;_} + -> + let rest1 = hd :: rest in + let uu___3 = FStarC_Syntax_Util.head_and_args t1 in + (match uu___3 with + | (unary_op, uu___4) -> + let head = + let uu___5 = + FStarC_Compiler_Range_Ops.union_ranges + unary_op.FStarC_Syntax_Syntax.pos + (FStar_Pervasives_Native.fst a1).FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = unary_op; + FStarC_Syntax_Syntax.args = [a1; a2] + }) uu___5 in + let t2 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = rest1 + }) t1.FStarC_Syntax_Syntax.pos in + __typeof_tot_or_gtot_term_fastpath env t2 must_tot) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_range_of); + FStarC_Syntax_Syntax.pos = uu___; + FStarC_Syntax_Syntax.vars = uu___1; + FStarC_Syntax_Syntax.hash_code = uu___2;_}; + FStarC_Syntax_Syntax.args = uu___3::[];_} + -> FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.t_range + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_set_range_of); + FStarC_Syntax_Syntax.pos = uu___; + FStarC_Syntax_Syntax.vars = uu___1; + FStarC_Syntax_Syntax.hash_code = uu___2;_}; + FStarC_Syntax_Syntax.args = (t2, uu___3)::uu___4::[];_} + -> __typeof_tot_or_gtot_term_fastpath env t2 must_tot + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = hd; + FStarC_Syntax_Syntax.args = args;_} + -> + let t_hd = __typeof_tot_or_gtot_term_fastpath env hd must_tot in + FStarC_Compiler_Util.bind_opt t_hd + (fun t_hd1 -> + let uu___ = apply_well_typed env t_hd1 args in + FStarC_Compiler_Util.bind_opt uu___ + (fun t2 -> + let uu___1 = + (effect_ok t2) || + (FStarC_Compiler_List.for_all + (fun uu___2 -> + match uu___2 with + | (a, uu___3) -> + let uu___4 = + __typeof_tot_or_gtot_term_fastpath env + a must_tot in + FStarC_Compiler_Util.is_some uu___4) args) in + if uu___1 + then FStar_Pervasives_Native.Some t2 + else FStar_Pervasives_Native.None)) + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t2; + FStarC_Syntax_Syntax.asc = + (FStar_Pervasives.Inl k, uu___, uu___1); + FStarC_Syntax_Syntax.eff_opt = uu___2;_} + -> + let uu___3 = effect_ok k in + if uu___3 + then FStar_Pervasives_Native.Some k + else __typeof_tot_or_gtot_term_fastpath env t2 must_tot + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = uu___; + FStarC_Syntax_Syntax.asc = + (FStar_Pervasives.Inr c, uu___1, uu___2); + FStarC_Syntax_Syntax.eff_opt = uu___3;_} + -> + let k = FStarC_Syntax_Util.comp_result c in + let uu___4 = + ((Prims.op_Negation must_tot) || + (let uu___5 = + FStarC_TypeChecker_Env.norm_eff_name env + (FStarC_Syntax_Util.comp_effect_name c) in + FStarC_Ident.lid_equals FStarC_Parser_Const.effect_PURE_lid + uu___5)) + || (FStarC_TypeChecker_Normalize.non_info_norm env k) in + if uu___4 + then FStar_Pervasives_Native.Some k + else FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Tm_uvar (u, s) -> + if Prims.op_Negation must_tot + then + let uu___ = + let uu___1 = FStarC_Syntax_Util.ctx_uvar_typ u in + FStarC_Syntax_Subst.subst' s uu___1 in + FStar_Pervasives_Native.Some uu___ + else FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Tm_quoted (tm, qi) -> + if Prims.op_Negation must_tot + then FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.t_term + else FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t2; + FStarC_Syntax_Syntax.meta = uu___;_} + -> __typeof_tot_or_gtot_term_fastpath env t2 must_tot + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = uu___; + FStarC_Syntax_Syntax.ret_opt = uu___1; + FStarC_Syntax_Syntax.brs = uu___2; + FStarC_Syntax_Syntax.rc_opt1 = FStar_Pervasives_Native.Some rc;_} + -> rc.FStarC_Syntax_Syntax.residual_typ + | FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (false, lb::[]); + FStarC_Syntax_Syntax.body1 = body;_} + -> + let x = FStarC_Compiler_Util.left lb.FStarC_Syntax_Syntax.lbname in + let uu___ = + let uu___1 = + let uu___2 = FStarC_Syntax_Syntax.mk_binder x in [uu___2] in + FStarC_Syntax_Subst.open_term uu___1 body in + (match uu___ with + | (xb, body1) -> + let xbinder = FStarC_Compiler_List.hd xb in + let x1 = xbinder.FStarC_Syntax_Syntax.binder_bv in + let env_x = FStarC_TypeChecker_Env.push_bv env x1 in + let t2 = + __typeof_tot_or_gtot_term_fastpath env_x body1 must_tot in + FStarC_Compiler_Util.bind_opt t2 + (fun t3 -> + let t4 = FStarC_Syntax_Subst.close xb t3 in + FStar_Pervasives_Native.Some t4)) + | FStarC_Syntax_Syntax.Tm_match uu___ -> FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Tm_let uu___ -> FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Tm_unknown -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term + t1 in + Prims.strcat uu___2 ")" in + Prims.strcat "Impossible! (" uu___1 in + failwith uu___ + | uu___ -> + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term + t1 in + Prims.strcat uu___3 ")" in + Prims.strcat "Impossible! (" uu___2 in + failwith uu___1 +let (typeof_tot_or_gtot_term_fastpath : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_TypeChecker_Env.must_tot -> + FStarC_Syntax_Syntax.typ FStar_Pervasives_Native.option) + = + fun env -> + fun t -> + fun must_tot -> + FStarC_Defensive.def_check_scoped + FStarC_TypeChecker_Env.hasBinders_env + FStarC_Class_Binders.hasNames_term FStarC_Syntax_Print.pretty_term + t.FStarC_Syntax_Syntax.pos "fastpath" env t; + FStarC_Errors.with_ctx + "In a call to typeof_tot_or_gtot_term_fastpath" + (fun uu___1 -> __typeof_tot_or_gtot_term_fastpath env t must_tot) +let rec (effectof_tot_or_gtot_term_fastpath : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Ident.lident FStar_Pervasives_Native.option) + = + fun env -> + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_delayed uu___1 -> failwith "Impossible!" + | FStarC_Syntax_Syntax.Tm_bvar uu___1 -> failwith "Impossible!" + | FStarC_Syntax_Syntax.Tm_name uu___1 -> + FStar_Pervasives_Native.Some FStarC_Parser_Const.effect_PURE_lid + | FStarC_Syntax_Syntax.Tm_lazy uu___1 -> + FStar_Pervasives_Native.Some FStarC_Parser_Const.effect_PURE_lid + | FStarC_Syntax_Syntax.Tm_fvar uu___1 -> + FStar_Pervasives_Native.Some FStarC_Parser_Const.effect_PURE_lid + | FStarC_Syntax_Syntax.Tm_uinst uu___1 -> + FStar_Pervasives_Native.Some FStarC_Parser_Const.effect_PURE_lid + | FStarC_Syntax_Syntax.Tm_constant uu___1 -> + FStar_Pervasives_Native.Some FStarC_Parser_Const.effect_PURE_lid + | FStarC_Syntax_Syntax.Tm_type uu___1 -> + FStar_Pervasives_Native.Some FStarC_Parser_Const.effect_PURE_lid + | FStarC_Syntax_Syntax.Tm_abs uu___1 -> + FStar_Pervasives_Native.Some FStarC_Parser_Const.effect_PURE_lid + | FStarC_Syntax_Syntax.Tm_arrow uu___1 -> + FStar_Pervasives_Native.Some FStarC_Parser_Const.effect_PURE_lid + | FStarC_Syntax_Syntax.Tm_refine uu___1 -> + FStar_Pervasives_Native.Some FStarC_Parser_Const.effect_PURE_lid + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = hd; FStarC_Syntax_Syntax.args = args;_} + -> + let join_effects eff1 eff2 = + let uu___1 = + let uu___2 = FStarC_TypeChecker_Env.norm_eff_name env eff1 in + let uu___3 = FStarC_TypeChecker_Env.norm_eff_name env eff2 in + (uu___2, uu___3) in + match uu___1 with + | (eff11, eff21) -> + let uu___2 = + (FStarC_Parser_Const.effect_PURE_lid, + FStarC_Parser_Const.effect_GHOST_lid) in + (match uu___2 with + | (pure, ghost) -> + let uu___3 = + (FStarC_Ident.lid_equals eff11 pure) && + (FStarC_Ident.lid_equals eff21 pure) in + if uu___3 + then FStar_Pervasives_Native.Some pure + else + (let uu___5 = + ((FStarC_Ident.lid_equals eff11 ghost) || + (FStarC_Ident.lid_equals eff11 pure)) + && + ((FStarC_Ident.lid_equals eff21 ghost) || + (FStarC_Ident.lid_equals eff21 pure)) in + if uu___5 + then FStar_Pervasives_Native.Some ghost + else FStar_Pervasives_Native.None)) in + let uu___1 = effectof_tot_or_gtot_term_fastpath env hd in + FStarC_Compiler_Util.bind_opt uu___1 + (fun eff_hd -> + let uu___2 = + FStarC_Compiler_List.fold_left + (fun eff_opt -> + fun arg -> + FStarC_Compiler_Util.bind_opt eff_opt + (fun eff -> + let uu___3 = + effectof_tot_or_gtot_term_fastpath env + (FStar_Pervasives_Native.fst arg) in + FStarC_Compiler_Util.bind_opt uu___3 + (join_effects eff))) + (FStar_Pervasives_Native.Some eff_hd) args in + FStarC_Compiler_Util.bind_opt uu___2 + (fun eff_hd_and_args -> + let uu___3 = typeof_tot_or_gtot_term_fastpath env hd true in + FStarC_Compiler_Util.bind_opt uu___3 + (fun t_hd -> + let rec maybe_arrow t1 = + let t2 = + FStarC_TypeChecker_Normalize.unfold_whnf env t1 in + match t2.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_arrow uu___4 -> t2 + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x; + FStarC_Syntax_Syntax.phi = uu___4;_} + -> maybe_arrow x.FStarC_Syntax_Syntax.sort + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t3; + FStarC_Syntax_Syntax.asc = uu___4; + FStarC_Syntax_Syntax.eff_opt = uu___5;_} + -> maybe_arrow t3 + | uu___4 -> t2 in + let uu___4 = + let uu___5 = maybe_arrow t_hd in + uu___5.FStarC_Syntax_Syntax.n in + match uu___4 with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = c;_} + -> + let eff_app = + if + (FStarC_Compiler_List.length args) < + (FStarC_Compiler_List.length bs) + then FStarC_Parser_Const.effect_PURE_lid + else FStarC_Syntax_Util.comp_effect_name c in + join_effects eff_hd_and_args eff_app + | uu___5 -> FStar_Pervasives_Native.None))) + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t1; + FStarC_Syntax_Syntax.asc = + (FStar_Pervasives.Inl uu___1, uu___2, uu___3); + FStarC_Syntax_Syntax.eff_opt = uu___4;_} + -> effectof_tot_or_gtot_term_fastpath env t1 + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = uu___1; + FStarC_Syntax_Syntax.asc = + (FStar_Pervasives.Inr c, uu___2, uu___3); + FStarC_Syntax_Syntax.eff_opt = uu___4;_} + -> + let c_eff = + FStarC_TypeChecker_Env.norm_eff_name env + (FStarC_Syntax_Util.comp_effect_name c) in + let uu___5 = + (FStarC_Ident.lid_equals c_eff + FStarC_Parser_Const.effect_PURE_lid) + || + (FStarC_Ident.lid_equals c_eff + FStarC_Parser_Const.effect_GHOST_lid) in + if uu___5 + then FStar_Pervasives_Native.Some c_eff + else FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Tm_uvar uu___1 -> FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Tm_quoted uu___1 -> FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t1; + FStarC_Syntax_Syntax.meta = uu___1;_} + -> effectof_tot_or_gtot_term_fastpath env t1 + | FStarC_Syntax_Syntax.Tm_match uu___1 -> FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Tm_let uu___1 -> FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Tm_unknown -> FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Tm_uinst uu___1 -> FStar_Pervasives_Native.None + | uu___1 -> FStar_Pervasives_Native.None \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_TermEqAndSimplify.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_TermEqAndSimplify.ml new file mode 100644 index 00000000000..4043bea458a --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_TermEqAndSimplify.ml @@ -0,0 +1,1411 @@ +open Prims +type eq_result = + | Equal + | NotEqual + | Unknown +let (uu___is_Equal : eq_result -> Prims.bool) = + fun projectee -> match projectee with | Equal -> true | uu___ -> false +let (uu___is_NotEqual : eq_result -> Prims.bool) = + fun projectee -> match projectee with | NotEqual -> true | uu___ -> false +let (uu___is_Unknown : eq_result -> Prims.bool) = + fun projectee -> match projectee with | Unknown -> true | uu___ -> false +let (injectives : Prims.string Prims.list) = + ["FStar.Int8.int_to_t"; + "FStar.Int16.int_to_t"; + "FStar.Int32.int_to_t"; + "FStar.Int64.int_to_t"; + "FStar.Int128.int_to_t"; + "FStar.UInt8.uint_to_t"; + "FStar.UInt16.uint_to_t"; + "FStar.UInt32.uint_to_t"; + "FStar.UInt64.uint_to_t"; + "FStar.UInt128.uint_to_t"; + "FStar.SizeT.uint_to_t"; + "FStar.Int8.__int_to_t"; + "FStar.Int16.__int_to_t"; + "FStar.Int32.__int_to_t"; + "FStar.Int64.__int_to_t"; + "FStar.Int128.__int_to_t"; + "FStar.UInt8.__uint_to_t"; + "FStar.UInt16.__uint_to_t"; + "FStar.UInt32.__uint_to_t"; + "FStar.UInt64.__uint_to_t"; + "FStar.UInt128.__uint_to_t"; + "FStar.SizeT.__uint_to_t"] +let (eq_inj : eq_result -> eq_result -> eq_result) = + fun r -> + fun s -> + match (r, s) with + | (Equal, Equal) -> Equal + | (NotEqual, uu___) -> NotEqual + | (uu___, NotEqual) -> NotEqual + | (uu___, uu___1) -> Unknown +let (equal_if : Prims.bool -> eq_result) = + fun uu___ -> if uu___ then Equal else Unknown +let (equal_iff : Prims.bool -> eq_result) = + fun uu___ -> if uu___ then Equal else NotEqual +let (eq_and : eq_result -> (unit -> eq_result) -> eq_result) = + fun r -> + fun s -> + let uu___ = (r = Equal) && (let uu___1 = s () in uu___1 = Equal) in + if uu___ then Equal else Unknown +let rec (eq_tm : + FStarC_TypeChecker_Env.env_t -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term -> eq_result) + = + fun env -> + fun t1 -> + fun t2 -> + let t11 = FStarC_Syntax_Util.canon_app t1 in + let t21 = FStarC_Syntax_Util.canon_app t2 in + let equal_data f1 args1 f2 args2 n_parms = + let uu___ = FStarC_Syntax_Syntax.fv_eq f1 f2 in + if uu___ + then + let n1 = FStarC_Compiler_List.length args1 in + let n2 = FStarC_Compiler_List.length args2 in + (if (n1 = n2) && (n_parms <= n1) + then + let uu___1 = FStarC_Compiler_List.splitAt n_parms args1 in + match uu___1 with + | (parms1, args11) -> + let uu___2 = FStarC_Compiler_List.splitAt n_parms args2 in + (match uu___2 with + | (parms2, args21) -> + let eq_arg_list as1 as2 = + FStarC_Compiler_List.fold_left2 + (fun acc -> + fun uu___3 -> + fun uu___4 -> + match (uu___3, uu___4) with + | ((a1, q1), (a2, q2)) -> + let uu___5 = eq_tm env a1 a2 in + eq_inj acc uu___5) Equal as1 as2 in + eq_arg_list args11 args21) + else Unknown) + else NotEqual in + let qual_is_inj uu___ = + match uu___ with + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Data_ctor) -> + true + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Record_ctor + uu___1) -> true + | uu___1 -> false in + let heads_and_args_in_case_both_data = + let uu___ = + let uu___1 = FStarC_Syntax_Util.unmeta t11 in + FStarC_Syntax_Util.head_and_args uu___1 in + match uu___ with + | (head1, args1) -> + let uu___1 = + let uu___2 = FStarC_Syntax_Util.unmeta t21 in + FStarC_Syntax_Util.head_and_args uu___2 in + (match uu___1 with + | (head2, args2) -> + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Util.un_uinst head1 in + uu___4.FStarC_Syntax_Syntax.n in + let uu___4 = + let uu___5 = FStarC_Syntax_Util.un_uinst head2 in + uu___5.FStarC_Syntax_Syntax.n in + (uu___3, uu___4) in + (match uu___2 with + | (FStarC_Syntax_Syntax.Tm_fvar f, + FStarC_Syntax_Syntax.Tm_fvar g) when + (qual_is_inj f.FStarC_Syntax_Syntax.fv_qual) && + (qual_is_inj g.FStarC_Syntax_Syntax.fv_qual) + -> + let uu___3 = + let uu___4 = FStarC_Syntax_Syntax.lid_of_fv f in + FStarC_TypeChecker_Env.num_datacon_non_injective_ty_params + env uu___4 in + (match uu___3 with + | FStar_Pervasives_Native.Some n -> + FStar_Pervasives_Native.Some + (f, args1, g, args2, n) + | uu___4 -> FStar_Pervasives_Native.None) + | uu___3 -> FStar_Pervasives_Native.None)) in + let t12 = FStarC_Syntax_Util.unmeta t11 in + let t22 = FStarC_Syntax_Util.unmeta t21 in + match ((t12.FStarC_Syntax_Syntax.n), (t22.FStarC_Syntax_Syntax.n)) + with + | (FStarC_Syntax_Syntax.Tm_bvar bv1, FStarC_Syntax_Syntax.Tm_bvar + bv2) -> + equal_if + (bv1.FStarC_Syntax_Syntax.index = + bv2.FStarC_Syntax_Syntax.index) + | (FStarC_Syntax_Syntax.Tm_lazy uu___, uu___1) -> + let uu___2 = FStarC_Syntax_Util.unlazy t12 in + eq_tm env uu___2 t22 + | (uu___, FStarC_Syntax_Syntax.Tm_lazy uu___1) -> + let uu___2 = FStarC_Syntax_Util.unlazy t22 in + eq_tm env t12 uu___2 + | (FStarC_Syntax_Syntax.Tm_name a, FStarC_Syntax_Syntax.Tm_name b) -> + let uu___ = FStarC_Syntax_Syntax.bv_eq a b in equal_if uu___ + | uu___ when + FStar_Pervasives_Native.uu___is_Some + heads_and_args_in_case_both_data + -> + let uu___1 = + FStarC_Compiler_Util.must heads_and_args_in_case_both_data in + (match uu___1 with + | (f, args1, g, args2, n) -> equal_data f args1 g args2 n) + | (FStarC_Syntax_Syntax.Tm_fvar f, FStarC_Syntax_Syntax.Tm_fvar g) -> + let uu___ = FStarC_Syntax_Syntax.fv_eq f g in equal_if uu___ + | (FStarC_Syntax_Syntax.Tm_uinst (f, us), + FStarC_Syntax_Syntax.Tm_uinst (g, vs)) -> + let uu___ = eq_tm env f g in + eq_and uu___ + (fun uu___1 -> + let uu___2 = FStarC_Syntax_Util.eq_univs_list us vs in + equal_if uu___2) + | (FStarC_Syntax_Syntax.Tm_constant (FStarC_Const.Const_range uu___), + FStarC_Syntax_Syntax.Tm_constant (FStarC_Const.Const_range + uu___1)) -> Unknown + | (FStarC_Syntax_Syntax.Tm_constant (FStarC_Const.Const_real r1), + FStarC_Syntax_Syntax.Tm_constant (FStarC_Const.Const_real r2)) -> + equal_if (r1 = r2) + | (FStarC_Syntax_Syntax.Tm_constant c, + FStarC_Syntax_Syntax.Tm_constant d) -> + let uu___ = FStarC_Const.eq_const c d in equal_iff uu___ + | (FStarC_Syntax_Syntax.Tm_uvar (u1, ([], uu___)), + FStarC_Syntax_Syntax.Tm_uvar (u2, ([], uu___1))) -> + let uu___2 = + FStarC_Syntax_Unionfind.equiv + u1.FStarC_Syntax_Syntax.ctx_uvar_head + u2.FStarC_Syntax_Syntax.ctx_uvar_head in + equal_if uu___2 + | (FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = h1; + FStarC_Syntax_Syntax.args = args1;_}, + FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = h2; + FStarC_Syntax_Syntax.args = args2;_}) + -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Syntax_Util.un_uinst h1 in + uu___2.FStarC_Syntax_Syntax.n in + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst h2 in + uu___3.FStarC_Syntax_Syntax.n in + (uu___1, uu___2) in + (match uu___ with + | (FStarC_Syntax_Syntax.Tm_fvar f1, FStarC_Syntax_Syntax.Tm_fvar + f2) when + (FStarC_Syntax_Syntax.fv_eq f1 f2) && + (let uu___1 = + let uu___2 = FStarC_Syntax_Syntax.lid_of_fv f1 in + FStarC_Ident.string_of_lid uu___2 in + FStarC_Compiler_List.mem uu___1 injectives) + -> equal_data f1 args1 f2 args2 Prims.int_zero + | uu___1 -> + let uu___2 = eq_tm env h1 h2 in + eq_and uu___2 (fun uu___3 -> eq_args env args1 args2)) + | (FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = t13; + FStarC_Syntax_Syntax.ret_opt = uu___; + FStarC_Syntax_Syntax.brs = bs1; + FStarC_Syntax_Syntax.rc_opt1 = uu___1;_}, + FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = t23; + FStarC_Syntax_Syntax.ret_opt = uu___2; + FStarC_Syntax_Syntax.brs = bs2; + FStarC_Syntax_Syntax.rc_opt1 = uu___3;_}) + -> + if + (FStarC_Compiler_List.length bs1) = + (FStarC_Compiler_List.length bs2) + then + let uu___4 = FStarC_Compiler_List.zip bs1 bs2 in + let uu___5 = eq_tm env t13 t23 in + FStarC_Compiler_List.fold_right + (fun uu___6 -> + fun a -> + match uu___6 with + | (b1, b2) -> + eq_and a (fun uu___7 -> branch_matches env b1 b2)) + uu___4 uu___5 + else Unknown + | (FStarC_Syntax_Syntax.Tm_type u, FStarC_Syntax_Syntax.Tm_type v) -> + let uu___ = FStarC_Syntax_Util.eq_univs u v in equal_if uu___ + | (FStarC_Syntax_Syntax.Tm_quoted (t13, q1), + FStarC_Syntax_Syntax.Tm_quoted (t23, q2)) -> Unknown + | (FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = t13; FStarC_Syntax_Syntax.phi = phi1;_}, + FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = t23; FStarC_Syntax_Syntax.phi = phi2;_}) + -> + let uu___ = + eq_tm env t13.FStarC_Syntax_Syntax.sort + t23.FStarC_Syntax_Syntax.sort in + eq_and uu___ (fun uu___1 -> eq_tm env phi1 phi2) + | (FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs1; + FStarC_Syntax_Syntax.body = body1; + FStarC_Syntax_Syntax.rc_opt = uu___;_}, + FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = bs2; + FStarC_Syntax_Syntax.body = body2; + FStarC_Syntax_Syntax.rc_opt = uu___1;_}) + when + (FStarC_Compiler_List.length bs1) = + (FStarC_Compiler_List.length bs2) + -> + let uu___2 = + FStarC_Compiler_List.fold_left2 + (fun r -> + fun b1 -> + fun b2 -> + eq_and r + (fun uu___3 -> + eq_tm env + (b1.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort + (b2.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort)) + Equal bs1 bs2 in + eq_and uu___2 (fun uu___3 -> eq_tm env body1 body2) + | (FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs1; + FStarC_Syntax_Syntax.comp = c1;_}, + FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs2; + FStarC_Syntax_Syntax.comp = c2;_}) + when + (FStarC_Compiler_List.length bs1) = + (FStarC_Compiler_List.length bs2) + -> + let uu___ = + FStarC_Compiler_List.fold_left2 + (fun r -> + fun b1 -> + fun b2 -> + eq_and r + (fun uu___1 -> + eq_tm env + (b1.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort + (b2.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort)) + Equal bs1 bs2 in + eq_and uu___ (fun uu___1 -> eq_comp env c1 c2) + | uu___ -> Unknown +and (eq_antiquotations : + FStarC_TypeChecker_Env.env_t -> + FStarC_Syntax_Syntax.term Prims.list -> + FStarC_Syntax_Syntax.term Prims.list -> eq_result) + = + fun env -> + fun a1 -> + fun a2 -> + match (a1, a2) with + | ([], []) -> Equal + | ([], uu___) -> NotEqual + | (uu___, []) -> NotEqual + | (t1::a11, t2::a21) -> + let uu___ = eq_tm env t1 t2 in + (match uu___ with + | NotEqual -> NotEqual + | Unknown -> + let uu___1 = eq_antiquotations env a11 a21 in + (match uu___1 with + | NotEqual -> NotEqual + | uu___2 -> Unknown) + | Equal -> eq_antiquotations env a11 a21) +and (branch_matches : + FStarC_TypeChecker_Env.env_t -> + (FStarC_Syntax_Syntax.pat' FStarC_Syntax_Syntax.withinfo_t * + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax + FStar_Pervasives_Native.option * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax) -> + (FStarC_Syntax_Syntax.pat' FStarC_Syntax_Syntax.withinfo_t * + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax + FStar_Pervasives_Native.option * FStarC_Syntax_Syntax.term' + FStarC_Syntax_Syntax.syntax) -> eq_result) + = + fun env -> + fun b1 -> + fun b2 -> + let related_by f o1 o2 = + match (o1, o2) with + | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> + true + | (FStar_Pervasives_Native.Some x, FStar_Pervasives_Native.Some y) + -> f x y + | (uu___, uu___1) -> false in + let uu___ = b1 in + match uu___ with + | (p1, w1, t1) -> + let uu___1 = b2 in + (match uu___1 with + | (p2, w2, t2) -> + let uu___2 = FStarC_Syntax_Syntax.eq_pat p1 p2 in + if uu___2 + then + let uu___3 = + (let uu___4 = eq_tm env t1 t2 in uu___4 = Equal) && + (related_by + (fun t11 -> + fun t21 -> + let uu___4 = eq_tm env t11 t21 in + uu___4 = Equal) w1 w2) in + (if uu___3 then Equal else Unknown) + else Unknown) +and (eq_args : + FStarC_TypeChecker_Env.env_t -> + FStarC_Syntax_Syntax.args -> FStarC_Syntax_Syntax.args -> eq_result) + = + fun env -> + fun a1 -> + fun a2 -> + match (a1, a2) with + | ([], []) -> Equal + | ((a, uu___)::a11, (b, uu___1)::b1) -> + let uu___2 = eq_tm env a b in + (match uu___2 with + | Equal -> eq_args env a11 b1 + | uu___3 -> Unknown) + | uu___ -> Unknown +and (eq_comp : + FStarC_TypeChecker_Env.env_t -> + FStarC_Syntax_Syntax.comp -> FStarC_Syntax_Syntax.comp -> eq_result) + = + fun env -> + fun c1 -> + fun c2 -> + match ((c1.FStarC_Syntax_Syntax.n), (c2.FStarC_Syntax_Syntax.n)) with + | (FStarC_Syntax_Syntax.Total t1, FStarC_Syntax_Syntax.Total t2) -> + eq_tm env t1 t2 + | (FStarC_Syntax_Syntax.GTotal t1, FStarC_Syntax_Syntax.GTotal t2) -> + eq_tm env t1 t2 + | (FStarC_Syntax_Syntax.Comp ct1, FStarC_Syntax_Syntax.Comp ct2) -> + let uu___ = + let uu___1 = + FStarC_Syntax_Util.eq_univs_list + ct1.FStarC_Syntax_Syntax.comp_univs + ct2.FStarC_Syntax_Syntax.comp_univs in + equal_if uu___1 in + eq_and uu___ + (fun uu___1 -> + let uu___2 = + let uu___3 = + FStarC_Ident.lid_equals + ct1.FStarC_Syntax_Syntax.effect_name + ct2.FStarC_Syntax_Syntax.effect_name in + equal_if uu___3 in + eq_and uu___2 + (fun uu___3 -> + let uu___4 = + eq_tm env ct1.FStarC_Syntax_Syntax.result_typ + ct2.FStarC_Syntax_Syntax.result_typ in + eq_and uu___4 + (fun uu___5 -> + eq_args env ct1.FStarC_Syntax_Syntax.effect_args + ct2.FStarC_Syntax_Syntax.effect_args))) + | uu___ -> NotEqual +let (eq_tm_bool : + FStarC_TypeChecker_Env.env_t -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term -> Prims.bool) + = fun e -> fun t1 -> fun t2 -> let uu___ = eq_tm e t1 t2 in uu___ = Equal +let (simplify : + Prims.bool -> + FStarC_TypeChecker_Env.env_t -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun debug -> + fun env -> + fun tm -> + let w t = + { + FStarC_Syntax_Syntax.n = (t.FStarC_Syntax_Syntax.n); + FStarC_Syntax_Syntax.pos = (tm.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = (t.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (t.FStarC_Syntax_Syntax.hash_code) + } in + let simp_t t = + let uu___ = + let uu___1 = FStarC_Syntax_Util.unmeta t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.true_lid + -> FStar_Pervasives_Native.Some true + | FStarC_Syntax_Syntax.Tm_fvar fv when + FStarC_Syntax_Syntax.fv_eq_lid fv FStarC_Parser_Const.false_lid + -> FStar_Pervasives_Native.Some false + | uu___1 -> FStar_Pervasives_Native.None in + let rec args_are_binders args bs = + match (args, bs) with + | ((t, uu___)::args1, b::bs1) -> + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress t in + uu___2.FStarC_Syntax_Syntax.n in + (match uu___1 with + | FStarC_Syntax_Syntax.Tm_name bv' -> + (FStarC_Syntax_Syntax.bv_eq + b.FStarC_Syntax_Syntax.binder_bv bv') + && (args_are_binders args1 bs1) + | uu___2 -> false) + | ([], []) -> true + | (uu___, uu___1) -> false in + let is_applied bs t = + if debug + then + (let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + let uu___2 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t in + FStarC_Compiler_Util.print2 "WPE> is_applied %s -- %s\n" uu___1 + uu___2) + else (); + (let uu___1 = FStarC_Syntax_Util.head_and_args_full t in + match uu___1 with + | (hd, args) -> + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress hd in + uu___3.FStarC_Syntax_Syntax.n in + (match uu___2 with + | FStarC_Syntax_Syntax.Tm_name bv when + args_are_binders args bs -> + (if debug + then + (let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_bv bv in + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term hd in + FStarC_Compiler_Util.print3 + "WPE> got it\n>>>>top = %s\n>>>>b = %s\n>>>>hd = %s\n" + uu___4 uu___5 uu___6) + else (); + FStar_Pervasives_Native.Some bv) + | uu___3 -> FStar_Pervasives_Native.None)) in + let is_applied_maybe_squashed bs t = + if debug + then + (let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + let uu___2 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t in + FStarC_Compiler_Util.print2 + "WPE> is_applied_maybe_squashed %s -- %s\n" uu___1 uu___2) + else (); + (let uu___1 = FStarC_Syntax_Util.is_squash t in + match uu___1 with + | FStar_Pervasives_Native.Some (uu___2, t') -> is_applied bs t' + | uu___2 -> + let uu___3 = FStarC_Syntax_Util.is_auto_squash t in + (match uu___3 with + | FStar_Pervasives_Native.Some (uu___4, t') -> + is_applied bs t' + | uu___4 -> is_applied bs t)) in + let is_const_match phi = + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress phi in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = uu___1; + FStarC_Syntax_Syntax.ret_opt = uu___2; + FStarC_Syntax_Syntax.brs = br::brs; + FStarC_Syntax_Syntax.rc_opt1 = uu___3;_} + -> + let uu___4 = br in + (match uu___4 with + | (uu___5, uu___6, e) -> + let r = + let uu___7 = simp_t e in + match uu___7 with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some b -> + let uu___8 = + FStarC_Compiler_List.for_all + (fun uu___9 -> + match uu___9 with + | (uu___10, uu___11, e') -> + let uu___12 = simp_t e' in + uu___12 = + (FStar_Pervasives_Native.Some b)) brs in + if uu___8 + then FStar_Pervasives_Native.Some b + else FStar_Pervasives_Native.None in + r) + | uu___1 -> FStar_Pervasives_Native.None in + let maybe_auto_squash t = + let uu___ = FStarC_Syntax_Util.is_sub_singleton t in + if uu___ + then t + else + FStarC_Syntax_Util.mk_auto_squash FStarC_Syntax_Syntax.U_zero t in + let squashed_head_un_auto_squash_args t = + let maybe_un_auto_squash_arg uu___ = + match uu___ with + | (t1, q) -> + let uu___1 = FStarC_Syntax_Util.is_auto_squash t1 in + (match uu___1 with + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.U_zero, t2) -> (t2, q) + | uu___2 -> (t1, q)) in + let uu___ = FStarC_Syntax_Util.head_and_args t in + match uu___ with + | (head, args) -> + let args1 = + FStarC_Compiler_List.map maybe_un_auto_squash_arg args in + FStarC_Syntax_Syntax.mk_Tm_app head args1 + t.FStarC_Syntax_Syntax.pos in + let rec clearly_inhabited ty = + let uu___ = + let uu___1 = FStarC_Syntax_Util.unmeta ty in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_uinst (t, uu___1) -> clearly_inhabited t + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = uu___1; + FStarC_Syntax_Syntax.comp = c;_} + -> clearly_inhabited (FStarC_Syntax_Util.comp_result c) + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let l = FStarC_Syntax_Syntax.lid_of_fv fv in + (((FStarC_Ident.lid_equals l FStarC_Parser_Const.int_lid) || + (FStarC_Ident.lid_equals l FStarC_Parser_Const.bool_lid)) + || + (FStarC_Ident.lid_equals l FStarC_Parser_Const.string_lid)) + || (FStarC_Ident.lid_equals l FStarC_Parser_Const.exn_lid) + | uu___1 -> false in + let simplify1 arg = + let uu___ = simp_t (FStar_Pervasives_Native.fst arg) in + (uu___, arg) in + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress tm in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_uinst + ({ + FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar + fv; + FStarC_Syntax_Syntax.pos = uu___1; + FStarC_Syntax_Syntax.vars = uu___2; + FStarC_Syntax_Syntax.hash_code = uu___3;_}, + uu___4); + FStarC_Syntax_Syntax.pos = uu___5; + FStarC_Syntax_Syntax.vars = uu___6; + FStarC_Syntax_Syntax.hash_code = uu___7;_}; + FStarC_Syntax_Syntax.args = args;_} + -> + let uu___8 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.squash_lid in + if uu___8 + then squashed_head_un_auto_squash_args tm + else + (let uu___10 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.and_lid in + if uu___10 + then + let uu___11 = FStarC_Compiler_List.map simplify1 args in + match uu___11 with + | (FStar_Pervasives_Native.Some (true), uu___12)::(uu___13, + (arg, + uu___14))::[] + -> maybe_auto_squash arg + | (uu___12, (arg, uu___13))::(FStar_Pervasives_Native.Some + (true), uu___14)::[] + -> maybe_auto_squash arg + | (FStar_Pervasives_Native.Some (false), uu___12)::uu___13::[] + -> w FStarC_Syntax_Util.t_false + | uu___12::(FStar_Pervasives_Native.Some (false), uu___13)::[] + -> w FStarC_Syntax_Util.t_false + | uu___12 -> squashed_head_un_auto_squash_args tm + else + (let uu___12 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.or_lid in + if uu___12 + then + let uu___13 = FStarC_Compiler_List.map simplify1 args in + match uu___13 with + | (FStar_Pervasives_Native.Some (true), uu___14)::uu___15::[] + -> w FStarC_Syntax_Util.t_true + | uu___14::(FStar_Pervasives_Native.Some (true), uu___15)::[] + -> w FStarC_Syntax_Util.t_true + | (FStar_Pervasives_Native.Some (false), uu___14):: + (uu___15, (arg, uu___16))::[] -> + maybe_auto_squash arg + | (uu___14, (arg, uu___15))::(FStar_Pervasives_Native.Some + (false), uu___16)::[] + -> maybe_auto_squash arg + | uu___14 -> squashed_head_un_auto_squash_args tm + else + (let uu___14 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.imp_lid in + if uu___14 + then + let uu___15 = FStarC_Compiler_List.map simplify1 args in + match uu___15 with + | uu___16::(FStar_Pervasives_Native.Some (true), + uu___17)::[] + -> w FStarC_Syntax_Util.t_true + | (FStar_Pervasives_Native.Some (false), uu___16)::uu___17::[] + -> w FStarC_Syntax_Util.t_true + | (FStar_Pervasives_Native.Some (true), uu___16):: + (uu___17, (arg, uu___18))::[] -> + maybe_auto_squash arg + | (uu___16, (p, uu___17))::(uu___18, (q, uu___19))::[] + -> + let uu___20 = FStarC_Syntax_Util.term_eq p q in + (if uu___20 + then w FStarC_Syntax_Util.t_true + else squashed_head_un_auto_squash_args tm) + | uu___16 -> squashed_head_un_auto_squash_args tm + else + (let uu___16 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.iff_lid in + if uu___16 + then + let uu___17 = + FStarC_Compiler_List.map simplify1 args in + match uu___17 with + | (FStar_Pervasives_Native.Some (true), uu___18):: + (FStar_Pervasives_Native.Some (true), uu___19)::[] + -> w FStarC_Syntax_Util.t_true + | (FStar_Pervasives_Native.Some (false), uu___18):: + (FStar_Pervasives_Native.Some (false), uu___19)::[] + -> w FStarC_Syntax_Util.t_true + | (FStar_Pervasives_Native.Some (true), uu___18):: + (FStar_Pervasives_Native.Some (false), uu___19)::[] + -> w FStarC_Syntax_Util.t_false + | (FStar_Pervasives_Native.Some (false), uu___18):: + (FStar_Pervasives_Native.Some (true), uu___19)::[] + -> w FStarC_Syntax_Util.t_false + | (uu___18, (arg, uu___19))::(FStar_Pervasives_Native.Some + (true), uu___20)::[] + -> maybe_auto_squash arg + | (FStar_Pervasives_Native.Some (true), uu___18):: + (uu___19, (arg, uu___20))::[] -> + maybe_auto_squash arg + | (uu___18, (arg, uu___19))::(FStar_Pervasives_Native.Some + (false), uu___20)::[] + -> + let uu___21 = FStarC_Syntax_Util.mk_neg arg in + maybe_auto_squash uu___21 + | (FStar_Pervasives_Native.Some (false), uu___18):: + (uu___19, (arg, uu___20))::[] -> + let uu___21 = FStarC_Syntax_Util.mk_neg arg in + maybe_auto_squash uu___21 + | (uu___18, (p, uu___19))::(uu___20, (q, uu___21))::[] + -> + let uu___22 = FStarC_Syntax_Util.term_eq p q in + (if uu___22 + then w FStarC_Syntax_Util.t_true + else squashed_head_un_auto_squash_args tm) + | uu___18 -> squashed_head_un_auto_squash_args tm + else + (let uu___18 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.not_lid in + if uu___18 + then + let uu___19 = + FStarC_Compiler_List.map simplify1 args in + match uu___19 with + | (FStar_Pervasives_Native.Some (true), uu___20)::[] + -> w FStarC_Syntax_Util.t_false + | (FStar_Pervasives_Native.Some (false), + uu___20)::[] -> w FStarC_Syntax_Util.t_true + | uu___20 -> + squashed_head_un_auto_squash_args tm + else + (let uu___20 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.forall_lid in + if uu___20 + then + match args with + | (t, uu___21)::[] -> + let uu___22 = + let uu___23 = + FStarC_Syntax_Subst.compress t in + uu___23.FStarC_Syntax_Syntax.n in + (match uu___22 with + | FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs = + uu___23::[]; + FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = + uu___24;_} + -> + let uu___25 = simp_t body in + (match uu___25 with + | FStar_Pervasives_Native.Some + (true) -> + w FStarC_Syntax_Util.t_true + | uu___26 -> tm) + | uu___23 -> tm) + | (ty, FStar_Pervasives_Native.Some + { + FStarC_Syntax_Syntax.aqual_implicit = + true; + FStarC_Syntax_Syntax.aqual_attributes = + uu___21;_})::(t, uu___22)::[] + -> + let uu___23 = + let uu___24 = + FStarC_Syntax_Subst.compress t in + uu___24.FStarC_Syntax_Syntax.n in + (match uu___23 with + | FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs = + uu___24::[]; + FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = + uu___25;_} + -> + let uu___26 = simp_t body in + (match uu___26 with + | FStar_Pervasives_Native.Some + (true) -> + w FStarC_Syntax_Util.t_true + | FStar_Pervasives_Native.Some + (false) when + clearly_inhabited ty -> + w FStarC_Syntax_Util.t_false + | uu___27 -> tm) + | uu___24 -> tm) + | uu___21 -> tm + else + (let uu___22 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.exists_lid in + if uu___22 + then + match args with + | (t, uu___23)::[] -> + let uu___24 = + let uu___25 = + FStarC_Syntax_Subst.compress t in + uu___25.FStarC_Syntax_Syntax.n in + (match uu___24 with + | FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs = + uu___25::[]; + FStarC_Syntax_Syntax.body = + body; + FStarC_Syntax_Syntax.rc_opt = + uu___26;_} + -> + let uu___27 = simp_t body in + (match uu___27 with + | FStar_Pervasives_Native.Some + (false) -> + w FStarC_Syntax_Util.t_false + | uu___28 -> tm) + | uu___25 -> tm) + | (ty, FStar_Pervasives_Native.Some + { + FStarC_Syntax_Syntax.aqual_implicit = + true; + FStarC_Syntax_Syntax.aqual_attributes + = uu___23;_})::(t, uu___24)::[] + -> + let uu___25 = + let uu___26 = + FStarC_Syntax_Subst.compress t in + uu___26.FStarC_Syntax_Syntax.n in + (match uu___25 with + | FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs = + uu___26::[]; + FStarC_Syntax_Syntax.body = + body; + FStarC_Syntax_Syntax.rc_opt = + uu___27;_} + -> + let uu___28 = simp_t body in + (match uu___28 with + | FStar_Pervasives_Native.Some + (false) -> + w FStarC_Syntax_Util.t_false + | FStar_Pervasives_Native.Some + (true) when + clearly_inhabited ty -> + w FStarC_Syntax_Util.t_true + | uu___29 -> tm) + | uu___26 -> tm) + | uu___23 -> tm + else + (let uu___24 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.b2t_lid in + if uu___24 + then + match args with + | ({ + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_bool (true)); + FStarC_Syntax_Syntax.pos = uu___25; + FStarC_Syntax_Syntax.vars = + uu___26; + FStarC_Syntax_Syntax.hash_code = + uu___27;_}, + uu___28)::[] -> + w FStarC_Syntax_Util.t_true + | ({ + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_bool + (false)); + FStarC_Syntax_Syntax.pos = uu___25; + FStarC_Syntax_Syntax.vars = + uu___26; + FStarC_Syntax_Syntax.hash_code = + uu___27;_}, + uu___28)::[] -> + w FStarC_Syntax_Util.t_false + | uu___25 -> tm + else + (let uu___26 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.haseq_lid in + if uu___26 + then + let t_has_eq_for_sure t = + let haseq_lids = + [FStarC_Parser_Const.int_lid; + FStarC_Parser_Const.bool_lid; + FStarC_Parser_Const.unit_lid; + FStarC_Parser_Const.string_lid] in + let uu___27 = + let uu___28 = + FStarC_Syntax_Subst.compress t in + uu___28.FStarC_Syntax_Syntax.n in + match uu___27 with + | FStarC_Syntax_Syntax.Tm_fvar fv1 + when + FStarC_Compiler_List.existsb + (fun l -> + FStarC_Syntax_Syntax.fv_eq_lid + fv1 l) haseq_lids + -> true + | uu___28 -> false in + (if + (FStarC_Compiler_List.length args) + = Prims.int_one + then + let t = + let uu___27 = + FStarC_Compiler_List.hd args in + FStar_Pervasives_Native.fst + uu___27 in + let uu___27 = t_has_eq_for_sure t in + (if uu___27 + then w FStarC_Syntax_Util.t_true + else + (let uu___29 = + let uu___30 = + FStarC_Syntax_Subst.compress + t in + uu___30.FStarC_Syntax_Syntax.n in + match uu___29 with + | FStarC_Syntax_Syntax.Tm_refine + uu___30 -> + let t1 = + FStarC_Syntax_Util.unrefine + t in + let uu___31 = + t_has_eq_for_sure t1 in + if uu___31 + then + w + FStarC_Syntax_Util.t_true + else + (let haseq_tm = + let uu___33 = + let uu___34 = + FStarC_Syntax_Subst.compress + tm in + uu___34.FStarC_Syntax_Syntax.n in + match uu___33 with + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd + = hd; + FStarC_Syntax_Syntax.args + = uu___34;_} + -> hd + | uu___34 -> + failwith + "Impossible! We have already checked that this is a Tm_app" in + let uu___33 = + let uu___34 = + FStarC_Syntax_Syntax.as_arg + t1 in + [uu___34] in + FStarC_Syntax_Util.mk_app + haseq_tm uu___33) + | uu___30 -> tm)) + else tm) + else + (let uu___28 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.eq2_lid in + if uu___28 + then + match args with + | (_typ, uu___29)::(a1, uu___30):: + (a2, uu___31)::[] -> + let uu___32 = eq_tm env a1 a2 in + (match uu___32 with + | Equal -> + w + FStarC_Syntax_Util.t_true + | NotEqual -> + w + FStarC_Syntax_Util.t_false + | uu___33 -> tm) + | uu___29 -> tm + else + (let uu___30 = + FStarC_Syntax_Util.is_auto_squash + tm in + match uu___30 with + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.U_zero, + t) + when + FStarC_Syntax_Util.is_sub_singleton + t + -> t + | uu___31 -> tm))))))))))) + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar fv; + FStarC_Syntax_Syntax.pos = uu___1; + FStarC_Syntax_Syntax.vars = uu___2; + FStarC_Syntax_Syntax.hash_code = uu___3;_}; + FStarC_Syntax_Syntax.args = args;_} + -> + let uu___4 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.squash_lid in + if uu___4 + then squashed_head_un_auto_squash_args tm + else + (let uu___6 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.and_lid in + if uu___6 + then + let uu___7 = FStarC_Compiler_List.map simplify1 args in + match uu___7 with + | (FStar_Pervasives_Native.Some (true), uu___8)::(uu___9, + (arg, + uu___10))::[] + -> maybe_auto_squash arg + | (uu___8, (arg, uu___9))::(FStar_Pervasives_Native.Some + (true), uu___10)::[] + -> maybe_auto_squash arg + | (FStar_Pervasives_Native.Some (false), uu___8)::uu___9::[] + -> w FStarC_Syntax_Util.t_false + | uu___8::(FStar_Pervasives_Native.Some (false), uu___9)::[] + -> w FStarC_Syntax_Util.t_false + | uu___8 -> squashed_head_un_auto_squash_args tm + else + (let uu___8 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.or_lid in + if uu___8 + then + let uu___9 = FStarC_Compiler_List.map simplify1 args in + match uu___9 with + | (FStar_Pervasives_Native.Some (true), uu___10)::uu___11::[] + -> w FStarC_Syntax_Util.t_true + | uu___10::(FStar_Pervasives_Native.Some (true), uu___11)::[] + -> w FStarC_Syntax_Util.t_true + | (FStar_Pervasives_Native.Some (false), uu___10):: + (uu___11, (arg, uu___12))::[] -> + maybe_auto_squash arg + | (uu___10, (arg, uu___11))::(FStar_Pervasives_Native.Some + (false), uu___12)::[] + -> maybe_auto_squash arg + | uu___10 -> squashed_head_un_auto_squash_args tm + else + (let uu___10 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.imp_lid in + if uu___10 + then + let uu___11 = FStarC_Compiler_List.map simplify1 args in + match uu___11 with + | uu___12::(FStar_Pervasives_Native.Some (true), + uu___13)::[] + -> w FStarC_Syntax_Util.t_true + | (FStar_Pervasives_Native.Some (false), uu___12)::uu___13::[] + -> w FStarC_Syntax_Util.t_true + | (FStar_Pervasives_Native.Some (true), uu___12):: + (uu___13, (arg, uu___14))::[] -> + maybe_auto_squash arg + | (uu___12, (p, uu___13))::(uu___14, (q, uu___15))::[] + -> + let uu___16 = FStarC_Syntax_Util.term_eq p q in + (if uu___16 + then w FStarC_Syntax_Util.t_true + else squashed_head_un_auto_squash_args tm) + | uu___12 -> squashed_head_un_auto_squash_args tm + else + (let uu___12 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.iff_lid in + if uu___12 + then + let uu___13 = + FStarC_Compiler_List.map simplify1 args in + match uu___13 with + | (FStar_Pervasives_Native.Some (true), uu___14):: + (FStar_Pervasives_Native.Some (true), uu___15)::[] + -> w FStarC_Syntax_Util.t_true + | (FStar_Pervasives_Native.Some (false), uu___14):: + (FStar_Pervasives_Native.Some (false), uu___15)::[] + -> w FStarC_Syntax_Util.t_true + | (FStar_Pervasives_Native.Some (true), uu___14):: + (FStar_Pervasives_Native.Some (false), uu___15)::[] + -> w FStarC_Syntax_Util.t_false + | (FStar_Pervasives_Native.Some (false), uu___14):: + (FStar_Pervasives_Native.Some (true), uu___15)::[] + -> w FStarC_Syntax_Util.t_false + | (uu___14, (arg, uu___15))::(FStar_Pervasives_Native.Some + (true), uu___16)::[] + -> maybe_auto_squash arg + | (FStar_Pervasives_Native.Some (true), uu___14):: + (uu___15, (arg, uu___16))::[] -> + maybe_auto_squash arg + | (uu___14, (arg, uu___15))::(FStar_Pervasives_Native.Some + (false), uu___16)::[] + -> + let uu___17 = FStarC_Syntax_Util.mk_neg arg in + maybe_auto_squash uu___17 + | (FStar_Pervasives_Native.Some (false), uu___14):: + (uu___15, (arg, uu___16))::[] -> + let uu___17 = FStarC_Syntax_Util.mk_neg arg in + maybe_auto_squash uu___17 + | (uu___14, (p, uu___15))::(uu___16, (q, uu___17))::[] + -> + let uu___18 = FStarC_Syntax_Util.term_eq p q in + (if uu___18 + then w FStarC_Syntax_Util.t_true + else squashed_head_un_auto_squash_args tm) + | uu___14 -> squashed_head_un_auto_squash_args tm + else + (let uu___14 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.not_lid in + if uu___14 + then + let uu___15 = + FStarC_Compiler_List.map simplify1 args in + match uu___15 with + | (FStar_Pervasives_Native.Some (true), uu___16)::[] + -> w FStarC_Syntax_Util.t_false + | (FStar_Pervasives_Native.Some (false), + uu___16)::[] -> w FStarC_Syntax_Util.t_true + | uu___16 -> + squashed_head_un_auto_squash_args tm + else + (let uu___16 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.forall_lid in + if uu___16 + then + match args with + | (t, uu___17)::[] -> + let uu___18 = + let uu___19 = + FStarC_Syntax_Subst.compress t in + uu___19.FStarC_Syntax_Syntax.n in + (match uu___18 with + | FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs = + uu___19::[]; + FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = + uu___20;_} + -> + let uu___21 = simp_t body in + (match uu___21 with + | FStar_Pervasives_Native.Some + (true) -> + w FStarC_Syntax_Util.t_true + | uu___22 -> tm) + | uu___19 -> tm) + | (ty, FStar_Pervasives_Native.Some + { + FStarC_Syntax_Syntax.aqual_implicit = + true; + FStarC_Syntax_Syntax.aqual_attributes = + uu___17;_})::(t, uu___18)::[] + -> + let uu___19 = + let uu___20 = + FStarC_Syntax_Subst.compress t in + uu___20.FStarC_Syntax_Syntax.n in + (match uu___19 with + | FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs = + uu___20::[]; + FStarC_Syntax_Syntax.body = body; + FStarC_Syntax_Syntax.rc_opt = + uu___21;_} + -> + let uu___22 = simp_t body in + (match uu___22 with + | FStar_Pervasives_Native.Some + (true) -> + w FStarC_Syntax_Util.t_true + | FStar_Pervasives_Native.Some + (false) when + clearly_inhabited ty -> + w FStarC_Syntax_Util.t_false + | uu___23 -> tm) + | uu___20 -> tm) + | uu___17 -> tm + else + (let uu___18 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.exists_lid in + if uu___18 + then + match args with + | (t, uu___19)::[] -> + let uu___20 = + let uu___21 = + FStarC_Syntax_Subst.compress t in + uu___21.FStarC_Syntax_Syntax.n in + (match uu___20 with + | FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs = + uu___21::[]; + FStarC_Syntax_Syntax.body = + body; + FStarC_Syntax_Syntax.rc_opt = + uu___22;_} + -> + let uu___23 = simp_t body in + (match uu___23 with + | FStar_Pervasives_Native.Some + (false) -> + w FStarC_Syntax_Util.t_false + | uu___24 -> tm) + | uu___21 -> tm) + | (ty, FStar_Pervasives_Native.Some + { + FStarC_Syntax_Syntax.aqual_implicit = + true; + FStarC_Syntax_Syntax.aqual_attributes + = uu___19;_})::(t, uu___20)::[] + -> + let uu___21 = + let uu___22 = + FStarC_Syntax_Subst.compress t in + uu___22.FStarC_Syntax_Syntax.n in + (match uu___21 with + | FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs = + uu___22::[]; + FStarC_Syntax_Syntax.body = + body; + FStarC_Syntax_Syntax.rc_opt = + uu___23;_} + -> + let uu___24 = simp_t body in + (match uu___24 with + | FStar_Pervasives_Native.Some + (false) -> + w FStarC_Syntax_Util.t_false + | FStar_Pervasives_Native.Some + (true) when + clearly_inhabited ty -> + w FStarC_Syntax_Util.t_true + | uu___25 -> tm) + | uu___22 -> tm) + | uu___19 -> tm + else + (let uu___20 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.b2t_lid in + if uu___20 + then + match args with + | ({ + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_bool (true)); + FStarC_Syntax_Syntax.pos = uu___21; + FStarC_Syntax_Syntax.vars = + uu___22; + FStarC_Syntax_Syntax.hash_code = + uu___23;_}, + uu___24)::[] -> + w FStarC_Syntax_Util.t_true + | ({ + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Tm_constant + (FStarC_Const.Const_bool + (false)); + FStarC_Syntax_Syntax.pos = uu___21; + FStarC_Syntax_Syntax.vars = + uu___22; + FStarC_Syntax_Syntax.hash_code = + uu___23;_}, + uu___24)::[] -> + w FStarC_Syntax_Util.t_false + | uu___21 -> tm + else + (let uu___22 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.haseq_lid in + if uu___22 + then + let t_has_eq_for_sure t = + let haseq_lids = + [FStarC_Parser_Const.int_lid; + FStarC_Parser_Const.bool_lid; + FStarC_Parser_Const.unit_lid; + FStarC_Parser_Const.string_lid] in + let uu___23 = + let uu___24 = + FStarC_Syntax_Subst.compress t in + uu___24.FStarC_Syntax_Syntax.n in + match uu___23 with + | FStarC_Syntax_Syntax.Tm_fvar fv1 + when + FStarC_Compiler_List.existsb + (fun l -> + FStarC_Syntax_Syntax.fv_eq_lid + fv1 l) haseq_lids + -> true + | uu___24 -> false in + (if + (FStarC_Compiler_List.length args) + = Prims.int_one + then + let t = + let uu___23 = + FStarC_Compiler_List.hd args in + FStar_Pervasives_Native.fst + uu___23 in + let uu___23 = t_has_eq_for_sure t in + (if uu___23 + then w FStarC_Syntax_Util.t_true + else + (let uu___25 = + let uu___26 = + FStarC_Syntax_Subst.compress + t in + uu___26.FStarC_Syntax_Syntax.n in + match uu___25 with + | FStarC_Syntax_Syntax.Tm_refine + uu___26 -> + let t1 = + FStarC_Syntax_Util.unrefine + t in + let uu___27 = + t_has_eq_for_sure t1 in + if uu___27 + then + w + FStarC_Syntax_Util.t_true + else + (let haseq_tm = + let uu___29 = + let uu___30 = + FStarC_Syntax_Subst.compress + tm in + uu___30.FStarC_Syntax_Syntax.n in + match uu___29 with + | FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd + = hd; + FStarC_Syntax_Syntax.args + = uu___30;_} + -> hd + | uu___30 -> + failwith + "Impossible! We have already checked that this is a Tm_app" in + let uu___29 = + let uu___30 = + FStarC_Syntax_Syntax.as_arg + t1 in + [uu___30] in + FStarC_Syntax_Util.mk_app + haseq_tm uu___29) + | uu___26 -> tm)) + else tm) + else + (let uu___24 = + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.eq2_lid in + if uu___24 + then + match args with + | (_typ, uu___25)::(a1, uu___26):: + (a2, uu___27)::[] -> + let uu___28 = eq_tm env a1 a2 in + (match uu___28 with + | Equal -> + w + FStarC_Syntax_Util.t_true + | NotEqual -> + w + FStarC_Syntax_Util.t_false + | uu___29 -> tm) + | uu___25 -> tm + else + (let uu___26 = + FStarC_Syntax_Util.is_auto_squash + tm in + match uu___26 with + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.U_zero, + t) + when + FStarC_Syntax_Util.is_sub_singleton + t + -> t + | uu___27 -> tm))))))))))) + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = bv; FStarC_Syntax_Syntax.phi = t;_} -> + let uu___1 = simp_t t in + (match uu___1 with + | FStar_Pervasives_Native.Some (true) -> + bv.FStarC_Syntax_Syntax.sort + | FStar_Pervasives_Native.Some (false) -> tm + | FStar_Pervasives_Native.None -> tm) + | FStarC_Syntax_Syntax.Tm_match uu___1 -> + let uu___2 = is_const_match tm in + (match uu___2 with + | FStar_Pervasives_Native.Some (true) -> + w FStarC_Syntax_Util.t_true + | FStar_Pervasives_Native.Some (false) -> + w FStarC_Syntax_Util.t_false + | FStar_Pervasives_Native.None -> tm) + | uu___1 -> tm \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_TypeChecker_Util.ml b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Util.ml new file mode 100644 index 00000000000..4c20aa84009 --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_TypeChecker_Util.ml @@ -0,0 +1,8861 @@ +open Prims +type lcomp_with_binder = + (FStarC_Syntax_Syntax.bv FStar_Pervasives_Native.option * + FStarC_TypeChecker_Common.lcomp) +let (dbg_bind : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Bind" +let (dbg_Coercions : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Coercions" +let (dbg_Dec : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Dec" +let (dbg_Extraction : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Extraction" +let (dbg_LayeredEffects : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "LayeredEffects" +let (dbg_LayeredEffectsApp : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "LayeredEffectsApp" +let (dbg_Pat : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Pat" +let (dbg_Rel : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Rel" +let (dbg_ResolveImplicitsHook : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "ResolveImplicitsHook" +let (dbg_Return : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Return" +let (dbg_Simplification : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Simplification" +let (dbg_SMTEncodingReify : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "SMTEncodingReify" +let (new_implicit_var : + Prims.string -> + FStarC_Compiler_Range_Type.range -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> + Prims.bool -> + (FStarC_Syntax_Syntax.term * (FStarC_Syntax_Syntax.ctx_uvar * + FStarC_Compiler_Range_Type.range) * + FStarC_TypeChecker_Env.guard_t)) + = + fun reason -> + fun r -> + fun env -> + fun k -> + fun unrefine -> + FStarC_TypeChecker_Env.new_implicit_var_aux reason r env k + FStarC_Syntax_Syntax.Strict FStar_Pervasives_Native.None + unrefine +let (close_guard_implicits : + FStarC_TypeChecker_Env.env -> + Prims.bool -> + FStarC_Syntax_Syntax.binders -> + FStarC_TypeChecker_Env.guard_t -> FStarC_TypeChecker_Env.guard_t) + = + fun env -> + fun solve_deferred -> + fun xs -> + fun g -> + let uu___ = (FStarC_Options.eager_subtyping ()) || solve_deferred in + if uu___ + then + let uu___1 = + let uu___2 = + FStarC_Class_Listlike.to_list + (FStarC_Compiler_CList.listlike_clist ()) + g.FStarC_TypeChecker_Common.deferred in + FStarC_Compiler_List.partition + (fun uu___3 -> + match uu___3 with + | (uu___4, uu___5, p) -> + FStarC_TypeChecker_Rel.flex_prob_closing env xs p) + uu___2 in + match uu___1 with + | (solve_now, defer) -> + ((let uu___3 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___3 + then + (FStarC_Compiler_Util.print_string + "SOLVE BEFORE CLOSING:\n"; + FStarC_Compiler_List.iter + (fun uu___6 -> + match uu___6 with + | (uu___7, s, p) -> + let uu___8 = + FStarC_TypeChecker_Rel.prob_to_string env p in + FStarC_Compiler_Util.print2 "%s: %s\n" s uu___8) + solve_now; + FStarC_Compiler_Util.print_string + " ...DEFERRED THE REST:\n"; + FStarC_Compiler_List.iter + (fun uu___8 -> + match uu___8 with + | (uu___9, s, p) -> + let uu___10 = + FStarC_TypeChecker_Rel.prob_to_string env p in + FStarC_Compiler_Util.print2 "%s: %s\n" s + uu___10) defer; + FStarC_Compiler_Util.print_string "END\n") + else ()); + (let g1 = + let uu___3 = + let uu___4 = + FStarC_Class_Listlike.from_list + (FStarC_Compiler_CList.listlike_clist ()) solve_now in + { + FStarC_TypeChecker_Common.guard_f = + (g.FStarC_TypeChecker_Common.guard_f); + FStarC_TypeChecker_Common.deferred_to_tac = + (g.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = uu___4; + FStarC_TypeChecker_Common.univ_ineqs = + (g.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = + (g.FStarC_TypeChecker_Common.implicits) + } in + FStarC_TypeChecker_Rel.solve_non_tactic_deferred_constraints + false env uu___3 in + let g2 = + let uu___3 = + FStarC_Class_Listlike.from_list + (FStarC_Compiler_CList.listlike_clist ()) defer in + { + FStarC_TypeChecker_Common.guard_f = + (g1.FStarC_TypeChecker_Common.guard_f); + FStarC_TypeChecker_Common.deferred_to_tac = + (g1.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = uu___3; + FStarC_TypeChecker_Common.univ_ineqs = + (g1.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = + (g1.FStarC_TypeChecker_Common.implicits) + } in + g2)) + else g +let (check_uvars : + FStarC_Compiler_Range_Type.range -> FStarC_Syntax_Syntax.typ -> unit) = + fun r -> + fun t -> + let uvs = FStarC_Syntax_Free.uvars t in + let uu___ = + let uu___1 = + FStarC_Class_Setlike.is_empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Free.ord_ctx_uvar)) (Obj.magic uvs) in + Prims.op_Negation uu___1 in + if uu___ + then + (FStarC_Options.push (); + FStarC_Options.set_option "hide_uvar_nums" + (FStarC_Options.Bool false); + FStarC_Options.set_option "print_implicits" + (FStarC_Options.Bool true); + (let uu___5 = + let uu___6 = + FStarC_Class_Show.show + (FStarC_Compiler_FlatSet.showable_set + FStarC_Syntax_Free.ord_ctx_uvar + FStarC_Syntax_Print.showable_ctxu) uvs in + let uu___7 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.format2 + "Unconstrained unification variables %s in type signature %s; please add an annotation" + uu___6 uu___7 in + FStarC_Errors.log_issue FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Error_UncontrainedUnificationVar () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___5)); + FStarC_Options.pop ()) + else () +let (extract_let_rec_annotation : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.letbinding -> + (FStarC_Syntax_Syntax.univ_names * FStarC_Syntax_Syntax.typ * + FStarC_Syntax_Syntax.term * Prims.bool)) + = + fun env -> + fun uu___ -> + match uu___ with + | { FStarC_Syntax_Syntax.lbname = lbname; + FStarC_Syntax_Syntax.lbunivs = univ_vars; + FStarC_Syntax_Syntax.lbtyp = t; + FStarC_Syntax_Syntax.lbeff = uu___1; + FStarC_Syntax_Syntax.lbdef = e; + FStarC_Syntax_Syntax.lbattrs = uu___2; + FStarC_Syntax_Syntax.lbpos = uu___3;_} -> + let rng = FStarC_Syntax_Syntax.range_of_lbname lbname in + let t1 = FStarC_Syntax_Subst.compress t in + let uu___4 = FStarC_Syntax_Subst.univ_var_opening univ_vars in + (match uu___4 with + | (u_subst, univ_vars1) -> + let e1 = FStarC_Syntax_Subst.subst u_subst e in + let t2 = FStarC_Syntax_Subst.subst u_subst t1 in + ((let uu___6 = FStarC_Compiler_Effect.op_Bang dbg_Dec in + if uu___6 + then + let uu___7 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + e1 in + let uu___8 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + t2 in + FStarC_Compiler_Util.print2 + "extract_let_rec_annotation lbdef=%s; lbtyp=%s\n" uu___7 + uu___8 + else ()); + (let env1 = + FStarC_TypeChecker_Env.push_univ_vars env univ_vars1 in + let un_arrow t3 = + let uu___6 = + let uu___7 = FStarC_Syntax_Subst.compress t3 in + uu___7.FStarC_Syntax_Syntax.n in + match uu___6 with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = c;_} + -> FStarC_Syntax_Subst.open_comp bs c + | uu___7 -> + let uu___8 = + let uu___9 = + FStarC_Errors_Msg.text + "Recursive functions must be introduced at arrow types." in + [uu___9] in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range rng + FStarC_Errors_Codes.Fatal_LetRecArgumentMismatch () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___8) in + let reconcile_let_rec_ascription_and_body_type tarr + lbtyp_opt = + let get_decreases c = + FStarC_Compiler_Util.prefix_until + (fun uu___6 -> + match uu___6 with + | FStarC_Syntax_Syntax.DECREASES uu___7 -> true + | uu___7 -> false) + (FStarC_Syntax_Util.comp_flags c) in + let fallback uu___6 = + let uu___7 = FStarC_Syntax_Util.arrow_formals_comp tarr in + match uu___7 with + | (bs, c) -> + let uu___8 = get_decreases c in + (match uu___8 with + | FStar_Pervasives_Native.Some + (pfx, FStarC_Syntax_Syntax.DECREASES d, sfx) -> + let c1 = + FStarC_TypeChecker_Env.comp_set_flags env1 c + (FStarC_Compiler_List.op_At pfx sfx) in + let uu___9 = FStarC_Syntax_Util.arrow bs c1 in + (uu___9, tarr, true) + | uu___9 -> (tarr, tarr, true)) in + match lbtyp_opt with + | FStar_Pervasives_Native.None -> fallback () + | FStar_Pervasives_Native.Some annot -> + let uu___6 = un_arrow tarr in + (match uu___6 with + | (bs, c) -> + let n_bs = FStarC_Compiler_List.length bs in + let uu___7 = + FStarC_TypeChecker_Normalize.get_n_binders env1 + n_bs annot in + (match uu___7 with + | (bs', c') -> + (if + (FStarC_Compiler_List.length bs') <> n_bs + then + (let uu___9 = + let uu___10 = + FStarC_Errors_Msg.text + "Arity mismatch on let rec annotation" in + let uu___11 = + let uu___12 = + FStarC_Errors_Msg.text "(explain)" in + [uu___12] in + uu___10 :: uu___11 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + rng + FStarC_Errors_Codes.Fatal_LetRecArgumentMismatch + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___9)) + else (); + (let move_decreases d flags flags' = + let d' = + let s = + FStarC_Syntax_Util.rename_binders bs + bs' in + FStarC_Syntax_Subst.subst_decreasing_order + s d in + let c1 = + let uu___9 = + FStarC_TypeChecker_Env.push_binders + env1 bs in + FStarC_TypeChecker_Env.comp_set_flags + uu___9 c flags in + let tarr1 = + FStarC_Syntax_Util.arrow bs c1 in + let c'1 = + let uu___9 = + FStarC_TypeChecker_Env.push_binders + env1 bs' in + FStarC_TypeChecker_Env.comp_set_flags + uu___9 c' + ((FStarC_Syntax_Syntax.DECREASES d') + :: flags') in + let tannot = + FStarC_Syntax_Util.arrow bs' c'1 in + (tarr1, tannot, true) in + let uu___9 = + let uu___10 = get_decreases c in + let uu___11 = get_decreases c' in + (uu___10, uu___11) in + match uu___9 with + | (FStar_Pervasives_Native.None, uu___10) + -> (tarr, annot, false) + | (FStar_Pervasives_Native.Some + (pfx, FStarC_Syntax_Syntax.DECREASES d, + sfx), + FStar_Pervasives_Native.Some + (pfx', FStarC_Syntax_Syntax.DECREASES + d', sfx')) -> + ((let uu___11 = + let uu___12 = + FStarC_Errors_Msg.text + "This definitions has multiple decreases clauses." in + let uu___13 = + let uu___14 = + FStarC_Errors_Msg.text + "The decreases clause on the declaration is ignored, please remove it." in + [uu___14] in + uu___12 :: uu___13 in + FStarC_Errors.log_issue + FStarC_Class_HasRange.hasRange_range + rng + FStarC_Errors_Codes.Warning_DeprecatedGeneric + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___11)); + move_decreases d + (FStarC_Compiler_List.op_At pfx sfx) + (FStarC_Compiler_List.op_At pfx' + sfx')) + | (FStar_Pervasives_Native.Some + (pfx, FStarC_Syntax_Syntax.DECREASES d, + sfx), + FStar_Pervasives_Native.None) -> + move_decreases d + (FStarC_Compiler_List.op_At pfx sfx) + (FStarC_Syntax_Util.comp_flags c') + | uu___10 -> failwith "Impossible")))) in + let extract_annot_from_body lbtyp_opt = + let rec aux_lbdef e2 = + let e3 = FStarC_Syntax_Subst.compress e2 in + match e3.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = e'; + FStarC_Syntax_Syntax.meta = m;_} + -> + let uu___6 = aux_lbdef e' in + (match uu___6 with + | (t3, e'1, recheck) -> + (t3, + { + FStarC_Syntax_Syntax.n = + (FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 = e'1; + FStarC_Syntax_Syntax.meta = m + }); + FStarC_Syntax_Syntax.pos = + (e3.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = + (e3.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (e3.FStarC_Syntax_Syntax.hash_code) + }, recheck)) + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = e'; + FStarC_Syntax_Syntax.asc = + (FStar_Pervasives.Inr c, tac_opt, use_eq); + FStarC_Syntax_Syntax.eff_opt = lopt;_} + -> + let uu___6 = FStarC_Syntax_Util.is_total_comp c in + if uu___6 + then + let uu___7 = + reconcile_let_rec_ascription_and_body_type + (FStarC_Syntax_Util.comp_result c) lbtyp_opt in + (match uu___7 with + | (t3, lbtyp, recheck) -> + let e4 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Syntax_Syntax.mk_Total t3 in + FStar_Pervasives.Inr uu___12 in + (uu___11, tac_opt, use_eq) in + { + FStarC_Syntax_Syntax.tm = e'; + FStarC_Syntax_Syntax.asc = uu___10; + FStarC_Syntax_Syntax.eff_opt = lopt + } in + FStarC_Syntax_Syntax.Tm_ascribed uu___9 in + { + FStarC_Syntax_Syntax.n = uu___8; + FStarC_Syntax_Syntax.pos = + (e3.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = + (e3.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (e3.FStarC_Syntax_Syntax.hash_code) + } in + (lbtyp, e4, recheck)) + else + (let uu___8 = + let uu___9 = + FStarC_Errors_Msg.text + "Expected a 'let rec' to be annotated with a value type" in + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Errors_Msg.text + "Got a computation type" in + let uu___13 = + let uu___14 = + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_comp c in + let uu___15 = + FStarC_Errors_Msg.text "instead" in + FStarC_Pprint.op_Hat_Slash_Hat uu___14 + uu___15 in + FStarC_Pprint.op_Hat_Slash_Hat uu___12 + uu___13 in + [uu___11] in + uu___9 :: uu___10 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range rng + FStarC_Errors_Codes.Fatal_UnexpectedComputationTypeForLetRec + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___8)) + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = e'; + FStarC_Syntax_Syntax.asc = + (FStar_Pervasives.Inl t3, tac_opt, use_eq); + FStarC_Syntax_Syntax.eff_opt = lopt;_} + -> + let uu___6 = + reconcile_let_rec_ascription_and_body_type t3 + lbtyp_opt in + (match uu___6 with + | (t4, lbtyp, recheck) -> + let e4 = + { + FStarC_Syntax_Syntax.n = + (FStarC_Syntax_Syntax.Tm_ascribed + { + FStarC_Syntax_Syntax.tm = e'; + FStarC_Syntax_Syntax.asc = + ((FStar_Pervasives.Inl t4), + tac_opt, use_eq); + FStarC_Syntax_Syntax.eff_opt = lopt + }); + FStarC_Syntax_Syntax.pos = + (e3.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = + (e3.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (e3.FStarC_Syntax_Syntax.hash_code) + } in + (lbtyp, e4, recheck)) + | FStarC_Syntax_Syntax.Tm_abs uu___6 -> + let uu___7 = + FStarC_Syntax_Util.abs_formals_maybe_unascribe_body + false e3 in + (match uu___7 with + | (bs, body, rcopt) -> + let mk_comp t3 = + let uu___8 = FStarC_Options.ml_ish () in + if uu___8 + then + FStarC_Syntax_Util.ml_comp t3 + t3.FStarC_Syntax_Syntax.pos + else FStarC_Syntax_Syntax.mk_Total t3 in + let mk_arrow c = FStarC_Syntax_Util.arrow bs c in + let rec aux_abs_body body1 = + let body2 = + FStarC_Syntax_Subst.compress body1 in + match body2.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = body3; + FStarC_Syntax_Syntax.meta = m;_} + -> + let uu___8 = aux_abs_body body3 in + (match uu___8 with + | (t3, body', recheck) -> + let body4 = + { + FStarC_Syntax_Syntax.n = + (FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 + = body'; + FStarC_Syntax_Syntax.meta + = m + }); + FStarC_Syntax_Syntax.pos = + (body3.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars = + (body3.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code = + (body3.FStarC_Syntax_Syntax.hash_code) + } in + (t3, body4, recheck)) + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = uu___8; + FStarC_Syntax_Syntax.asc = + (FStar_Pervasives.Inl t3, uu___9, + use_eq); + FStarC_Syntax_Syntax.eff_opt = uu___10;_} + -> + (if use_eq + then + (let uu___12 = + let uu___13 = + let uu___14 = + FStarC_Errors_Msg.text + "Equality ascription in this case" in + let uu___15 = + let uu___16 = + let uu___17 = + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_term + t3 in + FStarC_Pprint.parens uu___17 in + let uu___17 = + FStarC_Errors_Msg.text + "is not yet supported." in + FStarC_Pprint.op_Hat_Slash_Hat + uu___16 uu___17 in + FStarC_Pprint.op_Hat_Slash_Hat + uu___14 uu___15 in + let uu___14 = + let uu___15 = + FStarC_Errors_Msg.text + "Please use subtyping instead" in + [uu___15] in + uu___13 :: uu___14 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax + ()) t3 + FStarC_Errors_Codes.Fatal_NotSupported + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___12)) + else (); + (match lbtyp_opt with + | FStar_Pervasives_Native.Some lbtyp -> + (lbtyp, body2, false) + | FStar_Pervasives_Native.None -> + let t4 = + let uu___12 = mk_comp t3 in + mk_arrow uu___12 in + (t4, body2, true))) + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = body'; + FStarC_Syntax_Syntax.asc = + (FStar_Pervasives.Inr c, tac_opt, + use_eq); + FStarC_Syntax_Syntax.eff_opt = lopt;_} + -> + let tarr = mk_arrow c in + let uu___8 = + reconcile_let_rec_ascription_and_body_type + tarr lbtyp_opt in + (match uu___8 with + | (tarr1, lbtyp, recheck) -> + let n_bs = + FStarC_Compiler_List.length bs in + let uu___9 = + FStarC_TypeChecker_Normalize.get_n_binders + env1 n_bs tarr1 in + (match uu___9 with + | (bs', c1) -> + if + (FStarC_Compiler_List.length + bs') + <> n_bs + then failwith "Impossible" + else + (let subst = + FStarC_Syntax_Util.rename_binders + bs' bs in + let c2 = + FStarC_Syntax_Subst.subst_comp + subst c1 in + let body3 = + { + FStarC_Syntax_Syntax.n = + (FStarC_Syntax_Syntax.Tm_ascribed + { + FStarC_Syntax_Syntax.tm + = body'; + FStarC_Syntax_Syntax.asc + = + ((FStar_Pervasives.Inr + c2), + tac_opt, + use_eq); + FStarC_Syntax_Syntax.eff_opt + = lopt + }); + FStarC_Syntax_Syntax.pos + = + (body2.FStarC_Syntax_Syntax.pos); + FStarC_Syntax_Syntax.vars + = + (body2.FStarC_Syntax_Syntax.vars); + FStarC_Syntax_Syntax.hash_code + = + (body2.FStarC_Syntax_Syntax.hash_code) + } in + (lbtyp, body3, recheck)))) + | uu___8 -> + (match lbtyp_opt with + | FStar_Pervasives_Native.Some lbtyp -> + (lbtyp, body2, false) + | FStar_Pervasives_Native.None -> + let tarr = + let uu___9 = + mk_comp FStarC_Syntax_Syntax.tun in + mk_arrow uu___9 in + (tarr, body2, true)) in + let uu___8 = aux_abs_body body in + (match uu___8 with + | (lbtyp, body1, recheck) -> + let uu___9 = + FStarC_Syntax_Util.abs bs body1 rcopt in + (lbtyp, uu___9, recheck))) + | uu___6 -> + let uu___7 = + let uu___8 = + FStarC_Errors_Msg.text + "The definition of a 'let rec' must be a function literal" in + let uu___9 = + let uu___10 = + let uu___11 = FStarC_Errors_Msg.text "Got" in + let uu___12 = + let uu___13 = + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_term e3 in + let uu___14 = + FStarC_Errors_Msg.text "instead" in + FStarC_Pprint.op_Hat_Slash_Hat uu___13 + uu___14 in + FStarC_Pprint.op_Hat_Slash_Hat uu___11 uu___12 in + [uu___10] in + uu___8 :: uu___9 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) e3 + FStarC_Errors_Codes.Fatal_UnexpectedComputationTypeForLetRec + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___7) in + aux_lbdef e1 in + match t2.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_unknown -> + let uu___6 = + extract_annot_from_body FStar_Pervasives_Native.None in + (match uu___6 with + | (lbtyp, e2, uu___7) -> (univ_vars1, lbtyp, e2, true)) + | uu___6 -> + let uu___7 = FStarC_Syntax_Util.arrow_formals_comp t2 in + (match uu___7 with + | (uu___8, c) -> + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_TypeChecker_Env.lookup_effect_quals + env1 + (FStarC_Syntax_Util.comp_effect_name c) in + FStarC_Compiler_List.contains + FStarC_Syntax_Syntax.TotalEffect uu___11 in + Prims.op_Negation uu___10 in + if uu___9 + then (univ_vars1, t2, e1, false) + else + (let uu___11 = + extract_annot_from_body + (FStar_Pervasives_Native.Some t2) in + match uu___11 with + | (lbtyp, e2, check_lbtyp) -> + (univ_vars1, lbtyp, e2, check_lbtyp)))))) +let rec (decorated_pattern_as_term : + FStarC_Syntax_Syntax.pat -> + (FStarC_Syntax_Syntax.bv Prims.list * FStarC_Syntax_Syntax.term)) + = + fun pat -> + let mk f = FStarC_Syntax_Syntax.mk f pat.FStarC_Syntax_Syntax.p in + let pat_as_arg uu___ = + match uu___ with + | (p, i) -> + let uu___1 = decorated_pattern_as_term p in + (match uu___1 with + | (vars, te) -> + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.as_aqual_implicit i in + (te, uu___3) in + (vars, uu___2)) in + match pat.FStarC_Syntax_Syntax.v with + | FStarC_Syntax_Syntax.Pat_constant c -> + let uu___ = mk (FStarC_Syntax_Syntax.Tm_constant c) in ([], uu___) + | FStarC_Syntax_Syntax.Pat_var x -> + let uu___ = mk (FStarC_Syntax_Syntax.Tm_name x) in ([x], uu___) + | FStarC_Syntax_Syntax.Pat_cons (fv, us_opt, pats) -> + let uu___ = + let uu___1 = FStarC_Compiler_List.map pat_as_arg pats in + FStarC_Compiler_List.unzip uu___1 in + (match uu___ with + | (vars, args) -> + let vars1 = FStarC_Compiler_List.flatten vars in + let head = FStarC_Syntax_Syntax.fv_to_tm fv in + let head1 = + match us_opt with + | FStar_Pervasives_Native.None -> head + | FStar_Pervasives_Native.Some us -> + FStarC_Syntax_Syntax.mk_Tm_uinst head us in + let uu___1 = + mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = head1; + FStarC_Syntax_Syntax.args = args + }) in + (vars1, uu___1)) + | FStarC_Syntax_Syntax.Pat_dot_term eopt -> + (match eopt with + | FStar_Pervasives_Native.None -> + failwith + "TcUtil::decorated_pattern_as_term: dot pattern not resolved" + | FStar_Pervasives_Native.Some e -> ([], e)) +let (comp_univ_opt : + FStarC_Syntax_Syntax.comp' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.universe FStar_Pervasives_Native.option) + = + fun c -> + match c.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Total uu___ -> FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.GTotal uu___ -> FStar_Pervasives_Native.None + | FStarC_Syntax_Syntax.Comp c1 -> + (match c1.FStarC_Syntax_Syntax.comp_univs with + | [] -> FStar_Pervasives_Native.None + | hd::uu___ -> FStar_Pervasives_Native.Some hd) +let (lcomp_univ_opt : + FStarC_TypeChecker_Common.lcomp -> + (FStarC_Syntax_Syntax.universe FStar_Pervasives_Native.option * + FStarC_TypeChecker_Env.guard_t)) + = + fun lc -> + let uu___ = FStarC_TypeChecker_Common.lcomp_comp lc in + match uu___ with | (c, g) -> ((comp_univ_opt c), g) +let (destruct_wp_comp : + FStarC_Syntax_Syntax.comp_typ -> + (FStarC_Syntax_Syntax.universe * FStarC_Syntax_Syntax.typ * + FStarC_Syntax_Syntax.typ)) + = fun c -> FStarC_Syntax_Util.destruct_comp c +let (mk_comp_l : + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.cflag Prims.list -> FStarC_Syntax_Syntax.comp) + = + fun mname -> + fun u_result -> + fun result -> + fun wp -> + fun flags -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Syntax_Syntax.as_arg wp in [uu___2] in + { + FStarC_Syntax_Syntax.comp_univs = [u_result]; + FStarC_Syntax_Syntax.effect_name = mname; + FStarC_Syntax_Syntax.result_typ = result; + FStarC_Syntax_Syntax.effect_args = uu___1; + FStarC_Syntax_Syntax.flags = flags + } in + FStarC_Syntax_Syntax.mk_Comp uu___ +let (mk_comp : + FStarC_Syntax_Syntax.eff_decl -> + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.cflag Prims.list -> FStarC_Syntax_Syntax.comp) + = fun md -> mk_comp_l md.FStarC_Syntax_Syntax.mname +let (effect_args_from_repr : + FStarC_Syntax_Syntax.term -> + Prims.bool -> + FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.term Prims.list) + = + fun repr -> + fun is_layered -> + fun r -> + let err uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Errors_Msg.text "Could not get effect args from repr" in + let uu___4 = + let uu___5 = + FStarC_Class_PP.pp FStarC_Syntax_Print.pretty_term repr in + let uu___6 = + let uu___7 = FStarC_Errors_Msg.text "with is_layered=" in + let uu___8 = + FStarC_Class_PP.pp FStarC_Class_PP.pp_bool is_layered in + FStarC_Pprint.op_Hat_Hat uu___7 uu___8 in + FStarC_Pprint.op_Hat_Slash_Hat uu___5 uu___6 in + FStarC_Pprint.op_Hat_Slash_Hat uu___3 uu___4 in + [uu___2] in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_UnexpectedEffect () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___1) in + let repr1 = FStarC_Syntax_Subst.compress repr in + if is_layered + then + match repr1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = uu___; + FStarC_Syntax_Syntax.args = uu___1::is;_} + -> FStarC_Compiler_List.map FStar_Pervasives_Native.fst is + | uu___ -> err () + else + (match repr1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = uu___1; + FStarC_Syntax_Syntax.comp = c;_} + -> + let uu___2 = FStarC_Syntax_Util.comp_eff_name_res_and_args c in + (match uu___2 with + | (uu___3, uu___4, args) -> + FStarC_Compiler_List.map FStar_Pervasives_Native.fst args) + | uu___1 -> err ()) +let (mk_wp_return : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.eff_decl -> + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.term -> + FStarC_Compiler_Range_Type.range -> FStarC_Syntax_Syntax.comp) + = + fun env -> + fun ed -> + fun u_a -> + fun a -> + fun e -> + fun r -> + let c = + let uu___ = + let uu___1 = + FStarC_TypeChecker_Env.lid_exists env + FStarC_Parser_Const.effect_GTot_lid in + Prims.op_Negation uu___1 in + if uu___ + then FStarC_Syntax_Syntax.mk_Total a + else + (let uu___2 = FStarC_Syntax_Util.is_unit a in + if uu___2 + then FStarC_Syntax_Syntax.mk_Total a + else + (let wp = + let uu___4 = + (FStarC_Options.lax ()) && + (FStarC_Options.ml_ish ()) in + if uu___4 + then FStarC_Syntax_Syntax.tun + else + (let ret_wp = + FStarC_Syntax_Util.get_return_vc_combinator ed in + let uu___6 = + FStarC_TypeChecker_Env.inst_effect_fun_with + [u_a] env ed ret_wp in + let uu___7 = + let uu___8 = FStarC_Syntax_Syntax.as_arg a in + let uu___9 = + let uu___10 = FStarC_Syntax_Syntax.as_arg e in + [uu___10] in + uu___8 :: uu___9 in + FStarC_Syntax_Syntax.mk_Tm_app uu___6 uu___7 + e.FStarC_Syntax_Syntax.pos) in + mk_comp ed u_a a wp [FStarC_Syntax_Syntax.RETURN])) in + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_Return in + if uu___1 + then + let uu___2 = + FStarC_Compiler_Range_Ops.string_of_range + e.FStarC_Syntax_Syntax.pos in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + let uu___4 = + FStarC_TypeChecker_Normalize.comp_to_string env c in + FStarC_Compiler_Util.print3 + "(%s) returning %s at comp type %s\n" uu___2 uu___3 uu___4 + else ()); + c +let (label : + FStarC_Pprint.document Prims.list -> + FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.typ) + = + fun reason -> + fun r -> + fun f -> + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 = f; + FStarC_Syntax_Syntax.meta = + (FStarC_Syntax_Syntax.Meta_labeled (reason, r, false)) + }) f.FStarC_Syntax_Syntax.pos +let (label_opt : + FStarC_TypeChecker_Env.env -> + (unit -> FStarC_Pprint.document Prims.list) + FStar_Pervasives_Native.option -> + FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.typ) + = + fun env -> + fun reason -> + fun r -> + fun f -> + match reason with + | FStar_Pervasives_Native.None -> f + | FStar_Pervasives_Native.Some reason1 -> + let uu___ = + let uu___1 = FStarC_TypeChecker_Env.should_verify env in + Prims.op_Negation uu___1 in + if uu___ + then f + else (let uu___2 = reason1 () in label uu___2 r f) +let (label_guard : + FStarC_Compiler_Range_Type.range -> + FStarC_Pprint.document Prims.list -> + FStarC_TypeChecker_Env.guard_t -> FStarC_TypeChecker_Env.guard_t) + = + fun r -> + fun reason -> + fun g -> + match g.FStarC_TypeChecker_Common.guard_f with + | FStarC_TypeChecker_Common.Trivial -> g + | FStarC_TypeChecker_Common.NonTrivial f -> + let uu___ = + let uu___1 = label reason r f in + FStarC_TypeChecker_Common.NonTrivial uu___1 in + { + FStarC_TypeChecker_Common.guard_f = uu___; + FStarC_TypeChecker_Common.deferred_to_tac = + (g.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (g.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (g.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = + (g.FStarC_TypeChecker_Common.implicits) + } +let (lift_comp : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.comp_typ -> + FStarC_TypeChecker_Env.mlift -> + (FStarC_Syntax_Syntax.comp * FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun c -> + fun lift -> + let uu___ = + FStarC_Syntax_Syntax.mk_Comp + { + FStarC_Syntax_Syntax.comp_univs = + (c.FStarC_Syntax_Syntax.comp_univs); + FStarC_Syntax_Syntax.effect_name = + (c.FStarC_Syntax_Syntax.effect_name); + FStarC_Syntax_Syntax.result_typ = + (c.FStarC_Syntax_Syntax.result_typ); + FStarC_Syntax_Syntax.effect_args = + (c.FStarC_Syntax_Syntax.effect_args); + FStarC_Syntax_Syntax.flags = [] + } in + lift.FStarC_TypeChecker_Env.mlift_wp env uu___ +let (join_effects : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident -> FStarC_Ident.lident -> FStarC_Ident.lident) + = + fun env -> + fun l1_in -> + fun l2_in -> + let uu___ = + let uu___1 = FStarC_TypeChecker_Env.norm_eff_name env l1_in in + let uu___2 = FStarC_TypeChecker_Env.norm_eff_name env l2_in in + (uu___1, uu___2) in + match uu___ with + | (l1, l2) -> + let uu___1 = FStarC_TypeChecker_Env.join_opt env l1 l2 in + (match uu___1 with + | FStar_Pervasives_Native.Some (m, uu___2, uu___3) -> m + | FStar_Pervasives_Native.None -> + let uu___2 = + FStarC_TypeChecker_Env.exists_polymonadic_bind env l1 l2 in + (match uu___2 with + | FStar_Pervasives_Native.Some (m, uu___3) -> m + | FStar_Pervasives_Native.None -> + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Errors_Msg.text "Effects" in + let uu___6 = + let uu___7 = + FStarC_Class_PP.pp FStarC_Ident.pretty_lident + l1_in in + let uu___8 = + let uu___9 = FStarC_Errors_Msg.text "and" in + let uu___10 = + let uu___11 = + FStarC_Class_PP.pp + FStarC_Ident.pretty_lident l2_in in + let uu___12 = + FStarC_Errors_Msg.text "cannot be composed" in + FStarC_Pprint.op_Hat_Slash_Hat uu___11 + uu___12 in + FStarC_Pprint.op_Hat_Slash_Hat uu___9 uu___10 in + FStarC_Pprint.op_Hat_Slash_Hat uu___7 uu___8 in + FStarC_Pprint.op_Hat_Slash_Hat uu___5 uu___6 in + [uu___4] in + FStarC_Errors.raise_error + FStarC_TypeChecker_Env.hasRange_env env + FStarC_Errors_Codes.Fatal_EffectsCannotBeComposed () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___3))) +let (join_lcomp : + FStarC_TypeChecker_Env.env -> + FStarC_TypeChecker_Common.lcomp -> + FStarC_TypeChecker_Common.lcomp -> FStarC_Ident.lident) + = + fun env -> + fun c1 -> + fun c2 -> + let uu___ = + (FStarC_TypeChecker_Common.is_total_lcomp c1) && + (FStarC_TypeChecker_Common.is_total_lcomp c2) in + if uu___ + then FStarC_Parser_Const.effect_Tot_lid + else + join_effects env c1.FStarC_TypeChecker_Common.eff_name + c2.FStarC_TypeChecker_Common.eff_name +let (maybe_push : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.bv FStar_Pervasives_Native.option -> + FStarC_TypeChecker_Env.env) + = + fun env -> + fun b -> + match b with + | FStar_Pervasives_Native.None -> env + | FStar_Pervasives_Native.Some bv -> + FStarC_TypeChecker_Env.push_bv env bv +let (lift_comps_sep_guards : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.comp -> + FStarC_Syntax_Syntax.comp -> + FStarC_Syntax_Syntax.bv FStar_Pervasives_Native.option -> + Prims.bool -> + (FStarC_Ident.lident * FStarC_Syntax_Syntax.comp * + FStarC_Syntax_Syntax.comp * FStarC_TypeChecker_Env.guard_t * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun c1 -> + fun c2 -> + fun b -> + fun for_bind -> + let c11 = FStarC_TypeChecker_Env.unfold_effect_abbrev env c1 in + let env2 = maybe_push env b in + let c21 = FStarC_TypeChecker_Env.unfold_effect_abbrev env2 c2 in + let uu___ = + FStarC_TypeChecker_Env.join_opt env + c11.FStarC_Syntax_Syntax.effect_name + c21.FStarC_Syntax_Syntax.effect_name in + match uu___ with + | FStar_Pervasives_Native.Some (m, lift1, lift2) -> + let uu___1 = lift_comp env c11 lift1 in + (match uu___1 with + | (c12, g1) -> + let uu___2 = + if Prims.op_Negation for_bind + then lift_comp env2 c21 lift2 + else + (let x_a = + match b with + | FStar_Pervasives_Native.None -> + FStarC_Syntax_Syntax.null_binder + (FStarC_Syntax_Util.comp_result c12) + | FStar_Pervasives_Native.Some x -> + FStarC_Syntax_Syntax.mk_binder x in + let env_x = + FStarC_TypeChecker_Env.push_binders env [x_a] in + let uu___4 = lift_comp env_x c21 lift2 in + match uu___4 with + | (c22, g2) -> + let uu___5 = + FStarC_TypeChecker_Env.close_guard env + [x_a] g2 in + (c22, uu___5)) in + (match uu___2 with | (c22, g2) -> (m, c12, c22, g1, g2))) + | FStar_Pervasives_Native.None -> + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Errors_Msg.text "Effects" in + let uu___4 = + let uu___5 = + FStarC_Class_PP.pp FStarC_Ident.pretty_lident + c11.FStarC_Syntax_Syntax.effect_name in + let uu___6 = + let uu___7 = FStarC_Errors_Msg.text "and" in + let uu___8 = + let uu___9 = + FStarC_Class_PP.pp FStarC_Ident.pretty_lident + c21.FStarC_Syntax_Syntax.effect_name in + let uu___10 = + FStarC_Errors_Msg.text "cannot be composed" in + FStarC_Pprint.op_Hat_Slash_Hat uu___9 uu___10 in + FStarC_Pprint.op_Hat_Slash_Hat uu___7 uu___8 in + FStarC_Pprint.op_Hat_Slash_Hat uu___5 uu___6 in + FStarC_Pprint.op_Hat_Slash_Hat uu___3 uu___4 in + [uu___2] in + FStarC_Errors.raise_error FStarC_TypeChecker_Env.hasRange_env + env FStarC_Errors_Codes.Fatal_EffectsCannotBeComposed () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___1) +let (lift_comps : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.comp -> + FStarC_Syntax_Syntax.comp -> + FStarC_Syntax_Syntax.bv FStar_Pervasives_Native.option -> + Prims.bool -> + (FStarC_Ident.lident * FStarC_Syntax_Syntax.comp * + FStarC_Syntax_Syntax.comp * FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun c1 -> + fun c2 -> + fun b -> + fun for_bind -> + let uu___ = lift_comps_sep_guards env c1 c2 b for_bind in + match uu___ with + | (l, c11, c21, g1, g2) -> + let uu___1 = FStarC_TypeChecker_Env.conj_guard g1 g2 in + (l, c11, c21, uu___1) +let (is_pure_effect : + FStarC_TypeChecker_Env.env -> FStarC_Ident.lident -> Prims.bool) = + fun env -> + fun l -> + let l1 = FStarC_TypeChecker_Env.norm_eff_name env l in + FStarC_Ident.lid_equals l1 FStarC_Parser_Const.effect_PURE_lid +let (is_ghost_effect : + FStarC_TypeChecker_Env.env -> FStarC_Ident.lident -> Prims.bool) = + fun env -> + fun l -> + let l1 = FStarC_TypeChecker_Env.norm_eff_name env l in + FStarC_Ident.lid_equals l1 FStarC_Parser_Const.effect_GHOST_lid +let (is_pure_or_ghost_effect : + FStarC_TypeChecker_Env.env -> FStarC_Ident.lident -> Prims.bool) = + fun env -> + fun l -> + let l1 = FStarC_TypeChecker_Env.norm_eff_name env l in + (FStarC_Ident.lid_equals l1 FStarC_Parser_Const.effect_PURE_lid) || + (FStarC_Ident.lid_equals l1 FStarC_Parser_Const.effect_GHOST_lid) +let (lax_mk_tot_or_comp_l : + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.cflag Prims.list -> FStarC_Syntax_Syntax.comp) + = + fun mname -> + fun u_result -> + fun result -> + fun flags -> + let uu___ = + FStarC_Ident.lid_equals mname FStarC_Parser_Const.effect_Tot_lid in + if uu___ + then FStarC_Syntax_Syntax.mk_Total result + else mk_comp_l mname u_result result FStarC_Syntax_Syntax.tun flags +let (is_function : FStarC_Syntax_Syntax.term -> Prims.bool) = + fun t -> + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_arrow uu___1 -> true + | uu___1 -> false +let (close_wp_comp : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.bv Prims.list -> + FStarC_Syntax_Syntax.comp -> FStarC_Syntax_Syntax.comp) + = + fun env -> + fun bvs -> + fun c -> + (let uu___1 = FStarC_TypeChecker_Env.push_bvs env bvs in + FStarC_Defensive.def_check_scoped + FStarC_TypeChecker_Env.hasBinders_env + FStarC_Class_Binders.hasNames_comp FStarC_Syntax_Print.pretty_comp + c.FStarC_Syntax_Syntax.pos "close_wp_comp" uu___1 c); + (let uu___1 = FStarC_Syntax_Util.is_ml_comp c in + if uu___1 + then c + else + (let uu___3 = + (FStarC_Options.lax ()) && (FStarC_Options.ml_ish ()) in + if uu___3 + then c + else + (let env_bvs = FStarC_TypeChecker_Env.push_bvs env bvs in + let close_wp u_res md res_t bvs1 wp0 = + let close = + let uu___5 = FStarC_Syntax_Util.get_wp_close_combinator md in + FStarC_Compiler_Util.must uu___5 in + FStarC_Compiler_List.fold_right + (fun x -> + fun wp -> + let bs = + let uu___5 = FStarC_Syntax_Syntax.mk_binder x in + [uu___5] in + let us = + let uu___5 = + let uu___6 = + env.FStarC_TypeChecker_Env.universe_of env_bvs + x.FStarC_Syntax_Syntax.sort in + [uu___6] in + u_res :: uu___5 in + let wp1 = + FStarC_Syntax_Util.abs bs wp + (FStar_Pervasives_Native.Some + (FStarC_Syntax_Util.mk_residual_comp + FStarC_Parser_Const.effect_Tot_lid + FStar_Pervasives_Native.None + [FStarC_Syntax_Syntax.TOTAL])) in + let uu___5 = + FStarC_TypeChecker_Env.inst_effect_fun_with us env + md close in + let uu___6 = + let uu___7 = FStarC_Syntax_Syntax.as_arg res_t in + let uu___8 = + let uu___9 = + FStarC_Syntax_Syntax.as_arg + x.FStarC_Syntax_Syntax.sort in + let uu___10 = + let uu___11 = FStarC_Syntax_Syntax.as_arg wp1 in + [uu___11] in + uu___9 :: uu___10 in + uu___7 :: uu___8 in + FStarC_Syntax_Syntax.mk_Tm_app uu___5 uu___6 + wp0.FStarC_Syntax_Syntax.pos) bvs1 wp0 in + let c1 = FStarC_TypeChecker_Env.unfold_effect_abbrev env_bvs c in + let uu___5 = destruct_wp_comp c1 in + match uu___5 with + | (u_res_t, res_t, wp) -> + let md = + FStarC_TypeChecker_Env.get_effect_decl env + c1.FStarC_Syntax_Syntax.effect_name in + let wp1 = close_wp u_res_t md res_t bvs wp in + let uu___6 = + FStarC_Compiler_List.filter + (fun uu___7 -> + match uu___7 with + | FStarC_Syntax_Syntax.MLEFFECT -> true + | FStarC_Syntax_Syntax.SHOULD_NOT_INLINE -> true + | uu___8 -> false) c1.FStarC_Syntax_Syntax.flags in + mk_comp md u_res_t c1.FStarC_Syntax_Syntax.result_typ wp1 + uu___6))) +let (close_wp_lcomp : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.bv Prims.list -> + FStarC_TypeChecker_Common.lcomp -> FStarC_TypeChecker_Common.lcomp) + = + fun env -> + fun bvs -> + fun lc -> + let bs = FStarC_Compiler_List.map FStarC_Syntax_Syntax.mk_binder bvs in + FStarC_TypeChecker_Common.apply_lcomp (close_wp_comp env bvs) + (fun g -> + let uu___ = FStarC_TypeChecker_Env.close_guard env bs g in + close_guard_implicits env false bs uu___) lc +let (substitutive_indexed_close_substs : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.bv -> + FStarC_Syntax_Syntax.args -> + Prims.int -> + FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.subst_elt Prims.list) + = + fun env -> + fun close_bs -> + fun a -> + fun b_bv -> + fun ct_args -> + fun num_effect_params -> + fun r -> + let debug = + FStarC_Compiler_Effect.op_Bang dbg_LayeredEffectsApp in + let uu___ = + let uu___1 = close_bs in + match uu___1 with + | a_b::b_b::close_bs1 -> + (close_bs1, + [FStarC_Syntax_Syntax.NT + ((a_b.FStarC_Syntax_Syntax.binder_bv), a); + FStarC_Syntax_Syntax.NT + ((b_b.FStarC_Syntax_Syntax.binder_bv), + (b_bv.FStarC_Syntax_Syntax.sort))]) in + match uu___ with + | (close_bs1, subst) -> + let uu___1 = + let uu___2 = + FStarC_Compiler_List.splitAt num_effect_params + close_bs1 in + match uu___2 with + | (eff_params_bs, close_bs2) -> + let uu___3 = + FStarC_Compiler_List.splitAt num_effect_params + ct_args in + (match uu___3 with + | (ct_eff_params_args, ct_args1) -> + let uu___4 = + let uu___5 = + FStarC_Compiler_List.map2 + (fun b -> + fun uu___6 -> + match uu___6 with + | (arg, uu___7) -> + FStarC_Syntax_Syntax.NT + ((b.FStarC_Syntax_Syntax.binder_bv), + arg)) eff_params_bs + ct_eff_params_args in + FStarC_Compiler_List.op_At subst uu___5 in + (close_bs2, uu___4, ct_args1)) in + (match uu___1 with + | (close_bs2, subst1, ct_args1) -> + let uu___2 = + FStarC_Compiler_List.splitAt + ((FStarC_Compiler_List.length close_bs2) - + Prims.int_one) close_bs2 in + (match uu___2 with + | (close_bs3, uu___3) -> + FStarC_Compiler_List.fold_left2 + (fun ss -> + fun b -> + fun uu___4 -> + match uu___4 with + | (ct_arg, uu___5) -> + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_Syntax_Syntax.mk_binder + b_bv in + [uu___11] in + FStarC_Syntax_Util.abs + uu___10 ct_arg + FStar_Pervasives_Native.None in + ((b.FStarC_Syntax_Syntax.binder_bv), + uu___9) in + FStarC_Syntax_Syntax.NT uu___8 in + [uu___7] in + FStarC_Compiler_List.op_At ss + uu___6) subst1 close_bs3 + ct_args1)) +let (close_layered_comp_with_combinator : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.bv Prims.list -> + FStarC_Syntax_Syntax.comp -> FStarC_Syntax_Syntax.comp) + = + fun env -> + fun bvs -> + fun c -> + let r = c.FStarC_Syntax_Syntax.pos in + let env_bvs = FStarC_TypeChecker_Env.push_bvs env bvs in + let ct = FStarC_TypeChecker_Env.unfold_effect_abbrev env_bvs c in + let ed = + FStarC_TypeChecker_Env.get_effect_decl env_bvs + ct.FStarC_Syntax_Syntax.effect_name in + let num_effect_params = + match ed.FStarC_Syntax_Syntax.signature with + | FStarC_Syntax_Syntax.Layered_eff_sig (n, uu___) -> n + | uu___ -> + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range + r FStarC_Errors_Codes.Fatal_UnexpectedEffect () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "mk_indexed_close called with a non-indexed effect") in + let close_ts = + let uu___ = FStarC_Syntax_Util.get_layered_close_combinator ed in + FStarC_Compiler_Util.must uu___ in + let effect_args = + FStarC_Compiler_List.fold_right + (fun x -> + fun args -> + let u_a = + FStarC_Compiler_List.hd ct.FStarC_Syntax_Syntax.comp_univs in + let u_b = + env.FStarC_TypeChecker_Env.universe_of env_bvs + x.FStarC_Syntax_Syntax.sort in + let uu___ = + FStarC_TypeChecker_Env.inst_tscheme_with close_ts + [u_a; u_b] in + match uu___ with + | (uu___1, close_t) -> + let uu___2 = FStarC_Syntax_Util.abs_formals close_t in + (match uu___2 with + | (close_bs, close_body, uu___3) -> + let ss = + substitutive_indexed_close_substs env_bvs + close_bs ct.FStarC_Syntax_Syntax.result_typ x + args num_effect_params r in + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Subst.subst ss close_body in + FStarC_Syntax_Subst.compress uu___6 in + uu___5.FStarC_Syntax_Syntax.n in + (match uu___4 with + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = uu___5; + FStarC_Syntax_Syntax.args = uu___6::args1;_} + -> args1 + | uu___5 -> + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_UnexpectedEffect + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Unexpected close combinator shape")))) + bvs ct.FStarC_Syntax_Syntax.effect_args in + FStarC_Syntax_Syntax.mk_Comp + { + FStarC_Syntax_Syntax.comp_univs = + (ct.FStarC_Syntax_Syntax.comp_univs); + FStarC_Syntax_Syntax.effect_name = + (ct.FStarC_Syntax_Syntax.effect_name); + FStarC_Syntax_Syntax.result_typ = + (ct.FStarC_Syntax_Syntax.result_typ); + FStarC_Syntax_Syntax.effect_args = effect_args; + FStarC_Syntax_Syntax.flags = (ct.FStarC_Syntax_Syntax.flags) + } +let (close_layered_lcomp_with_combinator : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.bv Prims.list -> + FStarC_TypeChecker_Common.lcomp -> FStarC_TypeChecker_Common.lcomp) + = + fun env -> + fun bvs -> + fun lc -> + let bs = FStarC_Compiler_List.map FStarC_Syntax_Syntax.mk_binder bvs in + FStarC_TypeChecker_Common.apply_lcomp + (close_layered_comp_with_combinator env bvs) + (fun g -> + let uu___ = FStarC_TypeChecker_Env.close_guard env bs g in + close_guard_implicits env false bs uu___) lc +let (close_layered_lcomp_with_substitutions : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.bv Prims.list -> + FStarC_Syntax_Syntax.term Prims.list -> + FStarC_TypeChecker_Common.lcomp -> FStarC_TypeChecker_Common.lcomp) + = + fun env -> + fun bvs -> + fun tms -> + fun lc -> + let bs = + FStarC_Compiler_List.map FStarC_Syntax_Syntax.mk_binder bvs in + let substs = + FStarC_Compiler_List.map2 + (fun bv -> fun tm -> FStarC_Syntax_Syntax.NT (bv, tm)) bvs tms in + FStarC_TypeChecker_Common.apply_lcomp + (FStarC_Syntax_Subst.subst_comp substs) + (fun g -> + let uu___ = FStarC_TypeChecker_Env.close_guard env bs g in + close_guard_implicits env false bs uu___) lc +let (should_not_inline_lc : FStarC_TypeChecker_Common.lcomp -> Prims.bool) = + fun lc -> + FStarC_Compiler_Util.for_some + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.SHOULD_NOT_INLINE -> true + | uu___1 -> false) lc.FStarC_TypeChecker_Common.cflags +let (should_return : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option -> + FStarC_TypeChecker_Common.lcomp -> Prims.bool) + = + fun env -> + fun eopt -> + fun lc -> + let lc_is_unit_or_effectful = + let c = + let uu___ = + FStarC_Syntax_Util.arrow_formals_comp + lc.FStarC_TypeChecker_Common.res_typ in + FStar_Pervasives_Native.snd uu___ in + let uu___ = FStarC_TypeChecker_Env.is_reifiable_comp env c in + if uu___ + then + let c_eff_name = + FStarC_TypeChecker_Env.norm_eff_name env + (FStarC_Syntax_Util.comp_effect_name c) in + let uu___1 = + (FStarC_TypeChecker_Common.is_pure_or_ghost_lcomp lc) && + (FStarC_Ident.lid_equals c_eff_name + FStarC_Parser_Const.effect_TAC_lid) in + (if uu___1 + then false + else FStarC_TypeChecker_Env.is_layered_effect env c_eff_name) + else + (let uu___2 = FStarC_Syntax_Util.is_pure_or_ghost_comp c in + if uu___2 + then + let uu___3 = + FStarC_TypeChecker_Normalize.unfold_whnf env + (FStarC_Syntax_Util.comp_result c) in + FStarC_Syntax_Util.is_unit uu___3 + else true) in + match eopt with + | FStar_Pervasives_Native.None -> false + | FStar_Pervasives_Native.Some e -> + (((FStarC_TypeChecker_Common.is_pure_or_ghost_lcomp lc) && + (Prims.op_Negation lc_is_unit_or_effectful)) + && + (let uu___ = FStarC_Syntax_Util.head_and_args_full e in + match uu___ with + | (head, uu___1) -> + let uu___2 = + let uu___3 = FStarC_Syntax_Util.un_uinst head in + uu___3.FStarC_Syntax_Syntax.n in + (match uu___2 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let uu___3 = + let uu___4 = FStarC_Syntax_Syntax.lid_of_fv fv in + FStarC_TypeChecker_Env.is_irreducible env uu___4 in + Prims.op_Negation uu___3 + | uu___3 -> true))) + && + (let uu___ = should_not_inline_lc lc in Prims.op_Negation uu___) +let (substitutive_indexed_bind_substs : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.eff_decl -> + FStarC_Syntax_Syntax.eff_decl -> + FStarC_Syntax_Syntax.eff_decl -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.indexed_effect_binder_kind Prims.list -> + FStarC_Syntax_Syntax.comp_typ -> + FStarC_Syntax_Syntax.bv FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.comp_typ -> + FStarC_Compiler_Range_Type.range -> + Prims.int -> + Prims.bool -> + (FStarC_Syntax_Syntax.subst_elt Prims.list * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun m_ed -> + fun n_ed -> + fun p_ed -> + fun bs -> + fun binder_kinds -> + fun ct1 -> + fun b -> + fun ct2 -> + fun r1 -> + fun num_effect_params -> + fun has_range_binders -> + let debug = + FStarC_Compiler_Effect.op_Bang + dbg_LayeredEffectsApp in + let bind_name uu___ = + if debug + then + let uu___1 = + let uu___2 = + FStarC_Ident.ident_of_lid + m_ed.FStarC_Syntax_Syntax.mname in + FStarC_Ident.string_of_id uu___2 in + let uu___2 = + let uu___3 = + FStarC_Ident.ident_of_lid + n_ed.FStarC_Syntax_Syntax.mname in + FStarC_Ident.string_of_id uu___3 in + let uu___3 = + let uu___4 = + FStarC_Ident.ident_of_lid + p_ed.FStarC_Syntax_Syntax.mname in + FStarC_Ident.string_of_id uu___4 in + FStarC_Compiler_Util.format3 "(%s, %s) |> %s" + uu___1 uu___2 uu___3 + else "" in + let uu___ = + let uu___1 = bs in + match uu___1 with + | a_b::b_b::bs1 -> + let uu___2 = + let uu___3 = + FStarC_Compiler_List.splitAt + (Prims.of_int (2)) binder_kinds in + FStar_Pervasives_Native.snd uu___3 in + (bs1, uu___2, + [FStarC_Syntax_Syntax.NT + ((a_b.FStarC_Syntax_Syntax.binder_bv), + (ct1.FStarC_Syntax_Syntax.result_typ)); + FStarC_Syntax_Syntax.NT + ((b_b.FStarC_Syntax_Syntax.binder_bv), + (ct2.FStarC_Syntax_Syntax.result_typ))]) in + match uu___ with + | (bs1, binder_kinds1, subst) -> + let uu___1 = + if num_effect_params = Prims.int_zero + then + (bs1, binder_kinds1, subst, + FStarC_TypeChecker_Env.trivial_guard, + (ct1.FStarC_Syntax_Syntax.effect_args), + (ct2.FStarC_Syntax_Syntax.effect_args)) + else + (let split l = + FStarC_Compiler_List.splitAt + num_effect_params l in + let uu___3 = split bs1 in + match uu___3 with + | (eff_params_bs, bs2) -> + let uu___4 = split binder_kinds1 in + (match uu___4 with + | (uu___5, binder_kinds2) -> + let uu___6 = + split + ct1.FStarC_Syntax_Syntax.effect_args in + (match uu___6 with + | (param_args1, args1) -> + let uu___7 = + split + ct2.FStarC_Syntax_Syntax.effect_args in + (match uu___7 with + | (param_args2, args2) -> + let g = + FStarC_Compiler_List.fold_left2 + (fun g1 -> + fun uu___8 -> + fun uu___9 -> + match + (uu___8, + uu___9) + with + | ((arg1, + uu___10), + (arg2, + uu___11)) + -> + let uu___12 + = + FStarC_TypeChecker_Rel.layered_effect_teq + env arg1 + arg2 + (FStar_Pervasives_Native.Some + "effect param bind") in + FStarC_TypeChecker_Env.conj_guard + g1 + uu___12) + FStarC_TypeChecker_Env.trivial_guard + param_args1 + param_args2 in + let param_subst = + FStarC_Compiler_List.map2 + (fun b1 -> + fun uu___8 -> + match uu___8 + with + | (arg, + uu___9) -> + FStarC_Syntax_Syntax.NT + ((b1.FStarC_Syntax_Syntax.binder_bv), + arg)) + eff_params_bs + param_args1 in + (bs2, binder_kinds2, + (FStarC_Compiler_List.op_At + subst param_subst), + g, args1, args2))))) in + (match uu___1 with + | (bs2, binder_kinds2, subst1, guard, args1, + args2) -> + let uu___2 = + let m_num_effect_args = + FStarC_Compiler_List.length args1 in + let uu___3 = + FStarC_Compiler_List.splitAt + m_num_effect_args bs2 in + match uu___3 with + | (f_bs, bs3) -> + let f_subst = + FStarC_Compiler_List.map2 + (fun f_b -> + fun arg -> + FStarC_Syntax_Syntax.NT + ((f_b.FStarC_Syntax_Syntax.binder_bv), + (FStar_Pervasives_Native.fst + arg))) f_bs args1 in + let uu___4 = + let uu___5 = + FStarC_Compiler_List.splitAt + m_num_effect_args + binder_kinds2 in + FStar_Pervasives_Native.snd uu___5 in + (bs3, uu___4, + (FStarC_Compiler_List.op_At subst1 + f_subst)) in + (match uu___2 with + | (bs3, binder_kinds3, subst2) -> + let uu___3 = + let n_num_effect_args = + FStarC_Compiler_List.length args2 in + let uu___4 = + FStarC_Compiler_List.splitAt + n_num_effect_args bs3 in + match uu___4 with + | (g_bs, bs4) -> + let g_bs_kinds = + let uu___5 = + FStarC_Compiler_List.splitAt + n_num_effect_args + binder_kinds3 in + FStar_Pervasives_Native.fst + uu___5 in + let x_bv = + match b with + | FStar_Pervasives_Native.None + -> + FStarC_Syntax_Syntax.null_bv + ct1.FStarC_Syntax_Syntax.result_typ + | FStar_Pervasives_Native.Some + x -> x in + let uu___5 = + let uu___6 = + FStarC_Compiler_List.zip + g_bs g_bs_kinds in + FStarC_Compiler_List.fold_left2 + (fun uu___7 -> + fun uu___8 -> + fun arg -> + match (uu___7, + uu___8) + with + | ((ss, g), + (g_b, g_b_kind)) + -> + if + g_b_kind = + FStarC_Syntax_Syntax.Substitutive_binder + then + let arg_t = + let uu___9 = + let uu___10 + = + FStarC_Syntax_Syntax.mk_binder + x_bv in + [uu___10] in + FStarC_Syntax_Util.abs + uu___9 + (FStar_Pervasives_Native.fst + arg) + FStar_Pervasives_Native.None in + ((FStarC_Compiler_List.op_At + ss + [FStarC_Syntax_Syntax.NT + ((g_b.FStarC_Syntax_Syntax.binder_bv), + arg_t)]), + g) + else + if + g_b_kind = + FStarC_Syntax_Syntax.BindCont_no_abstraction_binder + then + (let uu___10 + = + FStarC_TypeChecker_Env.uvars_for_binders + env + [g_b] ss + (fun b1 + -> + if debug + then + let uu___11 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_binder + b1 in + let uu___12 + = + bind_name + () in + let uu___13 + = + FStarC_Compiler_Range_Ops.string_of_range + r1 in + FStarC_Compiler_Util.format3 + "implicit var for no abs g binder %s of %s at %s" + uu___11 + uu___12 + uu___13 + else + "substitutive_indexed_bind_substs.1") + r1 in + match uu___10 + with + | (uv_t::[], + g_uv) -> + let g_unif + = + let uu___11 + = + let uu___12 + = + let uu___13 + = + FStarC_Syntax_Syntax.mk_binder + x_bv in + [uu___13] in + FStarC_TypeChecker_Env.push_binders + env + uu___12 in + FStarC_TypeChecker_Rel.layered_effect_teq + uu___11 + uv_t + (FStar_Pervasives_Native.fst + arg) + (FStar_Pervasives_Native.Some + "") in + let uu___11 + = + FStarC_TypeChecker_Env.conj_guards + [g; + g_uv; + g_unif] in + ((FStarC_Compiler_List.op_At + ss + [ + FStarC_Syntax_Syntax.NT + ((g_b.FStarC_Syntax_Syntax.binder_bv), + uv_t)]), + uu___11)) + else + failwith + "Impossible (standard bind with unexpected binder kind)") + (subst2, guard) uu___6 + args2 in + (match uu___5 with + | (subst3, guard1) -> + (bs4, subst3, guard1)) in + (match uu___3 with + | (bs4, subst3, guard1) -> + let bs5 = + if has_range_binders + then + let uu___4 = + FStarC_Compiler_List.splitAt + (Prims.of_int (2)) bs4 in + FStar_Pervasives_Native.snd + uu___4 + else bs4 in + let bs6 = + let uu___4 = + FStarC_Compiler_List.splitAt + ((FStarC_Compiler_List.length + bs5) + - (Prims.of_int (2))) + bs5 in + FStar_Pervasives_Native.fst + uu___4 in + FStarC_Compiler_List.fold_left + (fun uu___4 -> + fun b1 -> + match uu___4 with + | (ss, g) -> + let uu___5 = + FStarC_TypeChecker_Env.uvars_for_binders + env [b1] ss + (fun b2 -> + if debug + then + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_binder + b2 in + let uu___7 = + bind_name + () in + let uu___8 = + FStarC_Compiler_Range_Ops.string_of_range + r1 in + FStarC_Compiler_Util.format3 + "implicit var for additional g binder %s of %s at %s" + uu___6 + uu___7 + uu___8 + else + "substitutive_indexed_bind_substs.2") + r1 in + (match uu___5 with + | (uv_t::[], g_uv) + -> + let uu___6 = + FStarC_TypeChecker_Env.conj_guard + g g_uv in + ((FStarC_Compiler_List.op_At + ss + [FStarC_Syntax_Syntax.NT + ((b1.FStarC_Syntax_Syntax.binder_bv), + uv_t)]), + uu___6))) + (subst3, guard1) bs6))) +let (ad_hoc_indexed_bind_substs : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.eff_decl -> + FStarC_Syntax_Syntax.eff_decl -> + FStarC_Syntax_Syntax.eff_decl -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.comp_typ -> + FStarC_Syntax_Syntax.bv FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.comp_typ -> + FStarC_Compiler_Range_Type.range -> + Prims.bool -> + (FStarC_Syntax_Syntax.subst_elt Prims.list * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun m_ed -> + fun n_ed -> + fun p_ed -> + fun bs -> + fun ct1 -> + fun b -> + fun ct2 -> + fun r1 -> + fun has_range_binders -> + let debug = + FStarC_Compiler_Effect.op_Bang dbg_LayeredEffectsApp in + let bind_name uu___ = + if debug + then + let uu___1 = + let uu___2 = + FStarC_Ident.ident_of_lid + m_ed.FStarC_Syntax_Syntax.mname in + FStarC_Ident.string_of_id uu___2 in + let uu___2 = + let uu___3 = + FStarC_Ident.ident_of_lid + n_ed.FStarC_Syntax_Syntax.mname in + FStarC_Ident.string_of_id uu___3 in + let uu___3 = + let uu___4 = + FStarC_Ident.ident_of_lid + p_ed.FStarC_Syntax_Syntax.mname in + FStarC_Ident.string_of_id uu___4 in + FStarC_Compiler_Util.format3 "(%s, %s) |> %s" + uu___1 uu___2 uu___3 + else "" in + let bind_t_shape_error r s = + let uu___ = + let uu___1 = bind_name () in + FStarC_Compiler_Util.format2 + "bind %s does not have proper shape (reason:%s)" + uu___1 s in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_UnexpectedEffect () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___) in + let num_range_binders = + if has_range_binders + then (Prims.of_int (2)) + else Prims.int_zero in + let uu___ = + if + (FStarC_Compiler_List.length bs) >= + (num_range_binders + (Prims.of_int (4))) + then + let uu___1 = bs in + match uu___1 with + | a_b::b_b::bs1 -> + let uu___2 = + let uu___3 = + FStarC_Compiler_List.splitAt + (((FStarC_Compiler_List.length bs1) - + (Prims.of_int (2))) + - num_range_binders) bs1 in + match uu___3 with + | (l1, l2) -> + let uu___4 = + FStarC_Compiler_List.splitAt + num_range_binders l2 in + (match uu___4 with + | (uu___5, l21) -> + let uu___6 = + FStarC_Compiler_List.hd l21 in + let uu___7 = + let uu___8 = + FStarC_Compiler_List.tl l21 in + FStarC_Compiler_List.hd uu___8 in + (l1, uu___6, uu___7)) in + (match uu___2 with + | (rest_bs, f_b, g_b) -> + (a_b, b_b, rest_bs, f_b, g_b)) + else + bind_t_shape_error r1 + "Either not an arrow or not enough binders" in + match uu___ with + | (a_b, b_b, rest_bs, f_b, g_b) -> + let uu___1 = + FStarC_TypeChecker_Env.uvars_for_binders env + rest_bs + [FStarC_Syntax_Syntax.NT + ((a_b.FStarC_Syntax_Syntax.binder_bv), + (ct1.FStarC_Syntax_Syntax.result_typ)); + FStarC_Syntax_Syntax.NT + ((b_b.FStarC_Syntax_Syntax.binder_bv), + (ct2.FStarC_Syntax_Syntax.result_typ))] + (fun b1 -> + if debug + then + let uu___2 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_binder b1 in + let uu___3 = bind_name () in + let uu___4 = + FStarC_Compiler_Range_Ops.string_of_range + r1 in + FStarC_Compiler_Util.format3 + "implicit var for binder %s of %s at %s" + uu___2 uu___3 uu___4 + else "ad_hoc_indexed_bind_substs") r1 in + (match uu___1 with + | (rest_bs_uvars, g_uvars) -> + ((let uu___3 = + FStarC_Compiler_Effect.op_Bang + dbg_ResolveImplicitsHook in + if uu___3 + then + FStarC_Compiler_List.iter + (fun t -> + let uu___4 = + let uu___5 = + FStarC_Syntax_Subst.compress t in + uu___5.FStarC_Syntax_Syntax.n in + match uu___4 with + | FStarC_Syntax_Syntax.Tm_uvar + (u, uu___5) -> + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t in + let uu___7 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_option + FStarC_Syntax_Print.showable_ctx_uvar_meta) + u.FStarC_Syntax_Syntax.ctx_uvar_meta in + FStarC_Compiler_Util.print2 + "Generated uvar %s with attribute %s\n" + uu___6 uu___7 + | uu___5 -> + let uu___6 = + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t in + Prims.strcat + "Impossible, expected a uvar, got : " + uu___7 in + failwith uu___6) rest_bs_uvars + else ()); + (let subst = + FStarC_Compiler_List.map2 + (fun b1 -> + fun t -> + FStarC_Syntax_Syntax.NT + ((b1.FStarC_Syntax_Syntax.binder_bv), + t)) (a_b :: b_b :: rest_bs) + ((ct1.FStarC_Syntax_Syntax.result_typ) + :: (ct2.FStarC_Syntax_Syntax.result_typ) + :: rest_bs_uvars) in + let f_guard = + let f_sort_is = + let uu___3 = + let uu___4 = + FStarC_Syntax_Subst.compress + (f_b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + let uu___5 = + FStarC_Syntax_Util.is_layered m_ed in + effect_args_from_repr uu___4 uu___5 r1 in + FStarC_Compiler_List.map + (FStarC_Syntax_Subst.subst subst) + uu___3 in + let uu___3 = + FStarC_Compiler_List.map + FStar_Pervasives_Native.fst + ct1.FStarC_Syntax_Syntax.effect_args in + FStarC_Compiler_List.fold_left2 + (fun g -> + fun i1 -> + fun f_i1 -> + (let uu___5 = + FStarC_Compiler_Effect.op_Bang + dbg_ResolveImplicitsHook in + if uu___5 + then + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + i1 in + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + f_i1 in + FStarC_Compiler_Util.print2 + "Generating constraint %s = %s\n" + uu___6 uu___7 + else ()); + (let uu___5 = + let uu___6 = + let uu___7 = bind_name () in + FStar_Pervasives_Native.Some + uu___7 in + FStarC_TypeChecker_Rel.layered_effect_teq + env i1 f_i1 uu___6 in + FStarC_TypeChecker_Env.conj_guard + g uu___5)) + FStarC_TypeChecker_Env.trivial_guard + uu___3 f_sort_is in + let g_guard = + let x_a = + match b with + | FStar_Pervasives_Native.None -> + FStarC_Syntax_Syntax.null_binder + ct1.FStarC_Syntax_Syntax.result_typ + | FStar_Pervasives_Native.Some x -> + FStarC_Syntax_Syntax.mk_binder + { + FStarC_Syntax_Syntax.ppname = + (x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (x.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = + (ct1.FStarC_Syntax_Syntax.result_typ) + } in + let g_sort_is = + let uu___3 = + let uu___4 = + FStarC_Syntax_Subst.compress + (g_b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + uu___4.FStarC_Syntax_Syntax.n in + match uu___3 with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs1; + FStarC_Syntax_Syntax.comp = c;_} + -> + let uu___4 = + FStarC_Syntax_Subst.open_comp bs1 + c in + (match uu___4 with + | (bs2, c1) -> + let bs_subst = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Compiler_List.hd + bs2 in + uu___7.FStarC_Syntax_Syntax.binder_bv in + let uu___7 = + FStarC_Syntax_Syntax.bv_to_name + x_a.FStarC_Syntax_Syntax.binder_bv in + (uu___6, uu___7) in + FStarC_Syntax_Syntax.NT + uu___5 in + let c2 = + FStarC_Syntax_Subst.subst_comp + [bs_subst] c1 in + let uu___5 = + let uu___6 = + FStarC_Syntax_Subst.compress + (FStarC_Syntax_Util.comp_result + c2) in + let uu___7 = + FStarC_Syntax_Util.is_layered + n_ed in + effect_args_from_repr uu___6 + uu___7 r1 in + FStarC_Compiler_List.map + (FStarC_Syntax_Subst.subst + subst) uu___5) + | uu___4 -> + failwith + "impossible: mk_indexed_bind" in + let env_g = + FStarC_TypeChecker_Env.push_binders env + [x_a] in + let uu___3 = + let uu___4 = + FStarC_Compiler_List.map + FStar_Pervasives_Native.fst + ct2.FStarC_Syntax_Syntax.effect_args in + FStarC_Compiler_List.fold_left2 + (fun g -> + fun i1 -> + fun g_i1 -> + (let uu___6 = + FStarC_Compiler_Effect.op_Bang + dbg_ResolveImplicitsHook in + if uu___6 + then + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + i1 in + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + g_i1 in + FStarC_Compiler_Util.print2 + "Generating constraint %s = %s\n" + uu___7 uu___8 + else ()); + (let uu___6 = + let uu___7 = + let uu___8 = bind_name () in + FStar_Pervasives_Native.Some + uu___8 in + FStarC_TypeChecker_Rel.layered_effect_teq + env_g i1 g_i1 uu___7 in + FStarC_TypeChecker_Env.conj_guard + g uu___6)) + FStarC_TypeChecker_Env.trivial_guard + uu___4 g_sort_is in + FStarC_TypeChecker_Env.close_guard env + [x_a] uu___3 in + let uu___3 = + FStarC_TypeChecker_Env.conj_guards + [g_uvars; f_guard; g_guard] in + (subst, uu___3)))) +let (mk_indexed_return : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.eff_decl -> + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.term -> + FStarC_Compiler_Range_Type.range -> + (FStarC_Syntax_Syntax.comp * FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun ed -> + fun u_a -> + fun a -> + fun e -> + fun r -> + let debug = + FStarC_Compiler_Effect.op_Bang dbg_LayeredEffectsApp in + if debug + then + (let uu___1 = + FStarC_Ident.string_of_lid ed.FStarC_Syntax_Syntax.mname in + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_univ + u_a in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term a in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + FStarC_Compiler_Util.print4 + "Computing %s.return for u_a:%s, a:%s, and e:%s{\n" uu___1 + uu___2 uu___3 uu___4) + else (); + (let uu___1 = + let uu___2 = FStarC_Syntax_Util.get_return_vc_combinator ed in + FStarC_TypeChecker_Env.inst_tscheme_with uu___2 [u_a] in + match uu___1 with + | (uu___2, return_t) -> + let return_t_shape_error r1 s = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Class_PP.pp FStarC_Ident.pretty_lident + ed.FStarC_Syntax_Syntax.mname in + let uu___6 = + let uu___7 = FStarC_Errors_Msg.text ".return" in + let uu___8 = + FStarC_Errors_Msg.text + "does not have proper shape" in + FStarC_Pprint.op_Hat_Slash_Hat uu___7 uu___8 in + FStarC_Pprint.op_Hat_Slash_Hat uu___5 uu___6 in + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Errors_Msg.text "Reason: " in + let uu___8 = FStarC_Errors_Msg.text s in + FStarC_Pprint.op_Hat_Hat uu___7 uu___8 in + [uu___6] in + uu___4 :: uu___5 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range r1 + FStarC_Errors_Codes.Fatal_UnexpectedEffect () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___3) in + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Subst.compress return_t in + uu___5.FStarC_Syntax_Syntax.n in + match uu___4 with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = c;_} + when + (FStarC_Compiler_List.length bs) >= + (Prims.of_int (2)) + -> + let uu___5 = FStarC_Syntax_Subst.open_comp bs c in + (match uu___5 with + | (a_b::x_b::bs1, c1) -> + (a_b, x_b, bs1, + (FStarC_Syntax_Util.comp_result c1))) + | uu___5 -> + return_t_shape_error r + "Either not an arrow or not enough binders" in + (match uu___3 with + | (a_b, x_b, rest_bs, return_typ) -> + let uu___4 = + FStarC_TypeChecker_Env.uvars_for_binders env + rest_bs + [FStarC_Syntax_Syntax.NT + ((a_b.FStarC_Syntax_Syntax.binder_bv), a); + FStarC_Syntax_Syntax.NT + ((x_b.FStarC_Syntax_Syntax.binder_bv), e)] + (fun b -> + if debug + then + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_binder b in + let uu___6 = + let uu___7 = + FStarC_Ident.string_of_lid + ed.FStarC_Syntax_Syntax.mname in + FStarC_Compiler_Util.format1 "%s.return" + uu___7 in + let uu___7 = + FStarC_Compiler_Range_Ops.string_of_range + r in + FStarC_Compiler_Util.format3 + "implicit var for binder %s of %s at %s" + uu___5 uu___6 uu___7 + else "mk_indexed_return_env") r in + (match uu___4 with + | (rest_bs_uvars, g_uvars) -> + let subst = + FStarC_Compiler_List.map2 + (fun b -> + fun t -> + FStarC_Syntax_Syntax.NT + ((b.FStarC_Syntax_Syntax.binder_bv), + t)) (a_b :: x_b :: rest_bs) (a :: e + :: rest_bs_uvars) in + let is = + let uu___5 = + let uu___6 = + FStarC_Syntax_Subst.compress return_typ in + let uu___7 = + FStarC_Syntax_Util.is_layered ed in + effect_args_from_repr uu___6 uu___7 r in + FStarC_Compiler_List.map + (FStarC_Syntax_Subst.subst subst) uu___5 in + let c = + let uu___5 = + let uu___6 = + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.as_arg is in + { + FStarC_Syntax_Syntax.comp_univs = [u_a]; + FStarC_Syntax_Syntax.effect_name = + (ed.FStarC_Syntax_Syntax.mname); + FStarC_Syntax_Syntax.result_typ = a; + FStarC_Syntax_Syntax.effect_args = uu___6; + FStarC_Syntax_Syntax.flags = [] + } in + FStarC_Syntax_Syntax.mk_Comp uu___5 in + (if debug + then + (let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_comp c in + FStarC_Compiler_Util.print1 + "} c after return %s\n" uu___6) + else (); + (c, g_uvars))))) +let (mk_indexed_bind : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident -> + FStarC_Ident.lident -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.tscheme -> + FStarC_Syntax_Syntax.indexed_effect_combinator_kind -> + FStarC_Syntax_Syntax.comp_typ -> + FStarC_Syntax_Syntax.bv FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.comp_typ -> + FStarC_Syntax_Syntax.cflag Prims.list -> + FStarC_Compiler_Range_Type.range -> + Prims.int -> + Prims.bool -> + (FStarC_Syntax_Syntax.comp * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun m -> + fun n -> + fun p -> + fun bind_t -> + fun bind_combinator_kind -> + fun ct1 -> + fun b -> + fun ct2 -> + fun flags -> + fun r1 -> + fun num_effect_params -> + fun has_range_binders -> + let debug = + FStarC_Compiler_Effect.op_Bang + dbg_LayeredEffectsApp in + if debug + then + (let uu___1 = + let uu___2 = + FStarC_Syntax_Syntax.mk_Comp ct1 in + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_comp uu___2 in + let uu___2 = + let uu___3 = + FStarC_Syntax_Syntax.mk_Comp ct2 in + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_comp uu___3 in + FStarC_Compiler_Util.print2 + "Binding indexed effects: c1:%s and c2:%s {\n" + uu___1 uu___2) + else (); + (let uu___2 = + FStarC_Compiler_Effect.op_Bang + dbg_ResolveImplicitsHook in + if uu___2 + then + let uu___3 = + let uu___4 = + FStarC_TypeChecker_Env.get_range env in + FStarC_Compiler_Range_Ops.string_of_range + uu___4 in + let uu___4 = + FStarC_Syntax_Print.tscheme_to_string bind_t in + FStarC_Compiler_Util.print2 + "///////////////////////////////Bind at %s/////////////////////\nwith bind_t = %s\n" + uu___3 uu___4 + else ()); + (let uu___2 = + let uu___3 = + FStarC_TypeChecker_Env.get_effect_decl env m in + let uu___4 = + FStarC_TypeChecker_Env.get_effect_decl env n in + let uu___5 = + FStarC_TypeChecker_Env.get_effect_decl env p in + (uu___3, uu___4, uu___5) in + match uu___2 with + | (m_ed, n_ed, p_ed) -> + let bind_name uu___3 = + let uu___4 = + let uu___5 = + FStarC_Ident.ident_of_lid + m_ed.FStarC_Syntax_Syntax.mname in + FStarC_Ident.string_of_id uu___5 in + let uu___5 = + let uu___6 = + FStarC_Ident.ident_of_lid + n_ed.FStarC_Syntax_Syntax.mname in + FStarC_Ident.string_of_id uu___6 in + let uu___6 = + let uu___7 = + FStarC_Ident.ident_of_lid + p_ed.FStarC_Syntax_Syntax.mname in + FStarC_Ident.string_of_id uu___7 in + FStarC_Compiler_Util.format3 + "(%s, %s) |> %s" uu___4 uu___5 uu___6 in + ((let uu___4 = + (((FStarC_TypeChecker_Env.is_erasable_effect + env m) + && + (let uu___5 = + FStarC_TypeChecker_Env.is_erasable_effect + env p in + Prims.op_Negation uu___5)) + && + (let uu___5 = + FStarC_TypeChecker_Normalize.non_info_norm + env + ct1.FStarC_Syntax_Syntax.result_typ in + Prims.op_Negation uu___5)) + || + (((FStarC_TypeChecker_Env.is_erasable_effect + env n) + && + (let uu___5 = + FStarC_TypeChecker_Env.is_erasable_effect + env p in + Prims.op_Negation uu___5)) + && + (let uu___5 = + FStarC_TypeChecker_Normalize.non_info_norm + env + ct2.FStarC_Syntax_Syntax.result_typ in + Prims.op_Negation uu___5)) in + if uu___4 + then + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Errors_Msg.text + "Cannot apply bind" in + let uu___8 = + let uu___9 = + let uu___10 = bind_name () in + FStarC_Pprint.doc_of_string + uu___10 in + let uu___10 = + let uu___11 = + FStarC_Errors_Msg.text "since" in + let uu___12 = + let uu___13 = + FStarC_Class_PP.pp + FStarC_Ident.pretty_lident + p in + let uu___14 = + FStarC_Errors_Msg.text + "is not erasable and one of the computations is informative." in + FStarC_Pprint.op_Hat_Slash_Hat + uu___13 uu___14 in + FStarC_Pprint.op_Hat_Slash_Hat + uu___11 uu___12 in + FStarC_Pprint.op_Hat_Slash_Hat + uu___9 uu___10 in + FStarC_Pprint.op_Hat_Slash_Hat + uu___7 uu___8 in + [uu___6] in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + r1 + FStarC_Errors_Codes.Fatal_UnexpectedEffect + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___5) + else ()); + (let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Compiler_List.hd + ct1.FStarC_Syntax_Syntax.comp_univs in + let uu___7 = + let uu___8 = + FStarC_Compiler_List.hd + ct2.FStarC_Syntax_Syntax.comp_univs in + [uu___8] in + uu___6 :: uu___7 in + FStarC_TypeChecker_Env.inst_tscheme_with + bind_t uu___5 in + match uu___4 with + | (uu___5, bind_t1) -> + let uu___6 = + FStarC_Syntax_Util.arrow_formals_comp + bind_t1 in + (match uu___6 with + | (bind_t_bs, bind_c) -> + let uu___7 = + if + bind_combinator_kind = + FStarC_Syntax_Syntax.Ad_hoc_combinator + then + ad_hoc_indexed_bind_substs + env m_ed n_ed p_ed + bind_t_bs ct1 b ct2 r1 + has_range_binders + else + (let uu___9 = + bind_combinator_kind in + match uu___9 with + | FStarC_Syntax_Syntax.Substitutive_combinator + binder_kinds -> + substitutive_indexed_bind_substs + env m_ed n_ed p_ed + bind_t_bs binder_kinds + ct1 b ct2 r1 + num_effect_params + has_range_binders) in + (match uu___7 with + | (subst, g) -> + let bind_ct = + let uu___8 = + FStarC_Syntax_Subst.subst_comp + subst bind_c in + FStarC_TypeChecker_Env.comp_to_comp_typ + env uu___8 in + let fml = + let uu___8 = + let uu___9 = + FStarC_Compiler_List.hd + bind_ct.FStarC_Syntax_Syntax.comp_univs in + let uu___10 = + let uu___11 = + FStarC_Compiler_List.hd + bind_ct.FStarC_Syntax_Syntax.effect_args in + FStar_Pervasives_Native.fst + uu___11 in + (uu___9, uu___10) in + match uu___8 with + | (u, wp) -> + FStarC_TypeChecker_Env.pure_precondition_for_trivial_post + env u + bind_ct.FStarC_Syntax_Syntax.result_typ + wp + FStarC_Compiler_Range_Type.dummyRange in + let is = + let uu___8 = + FStarC_Syntax_Subst.compress + bind_ct.FStarC_Syntax_Syntax.result_typ in + let uu___9 = + FStarC_Syntax_Util.is_layered + p_ed in + effect_args_from_repr + uu___8 uu___9 r1 in + let c = + let uu___8 = + let uu___9 = + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.as_arg + is in + { + FStarC_Syntax_Syntax.comp_univs + = + (ct2.FStarC_Syntax_Syntax.comp_univs); + FStarC_Syntax_Syntax.effect_name + = + (p_ed.FStarC_Syntax_Syntax.mname); + FStarC_Syntax_Syntax.result_typ + = + (ct2.FStarC_Syntax_Syntax.result_typ); + FStarC_Syntax_Syntax.effect_args + = uu___9; + FStarC_Syntax_Syntax.flags + = flags + } in + FStarC_Syntax_Syntax.mk_Comp + uu___8 in + (if debug + then + (let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_comp + c in + FStarC_Compiler_Util.print1 + "} c after bind: %s\n" + uu___9) + else (); + (let guard = + let uu___9 = + let uu___10 = + let uu___11 = + FStarC_TypeChecker_Env.guard_of_guard_formula + (FStarC_TypeChecker_Common.NonTrivial + fml) in + [uu___11] in + g :: uu___10 in + FStarC_TypeChecker_Env.conj_guards + uu___9 in + (let uu___10 = + FStarC_Compiler_Effect.op_Bang + dbg_ResolveImplicitsHook in + if uu___10 + then + let uu___11 = + let uu___12 = + FStarC_TypeChecker_Env.get_range + env in + FStarC_Compiler_Range_Ops.string_of_range + uu___12 in + let uu___12 = + FStarC_TypeChecker_Rel.guard_to_string + env guard in + FStarC_Compiler_Util.print2 + "///////////////////////////////EndBind at %s/////////////////////\nguard = %s\n" + uu___11 uu___12 + else ()); + (c, guard)))))))) +let (mk_wp_bind : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.comp_typ -> + FStarC_Syntax_Syntax.bv FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.comp_typ -> + FStarC_Syntax_Syntax.cflag Prims.list -> + FStarC_Compiler_Range_Type.range -> FStarC_Syntax_Syntax.comp) + = + fun env -> + fun m -> + fun ct1 -> + fun b -> + fun ct2 -> + fun flags -> + fun r1 -> + let uu___ = + let md = FStarC_TypeChecker_Env.get_effect_decl env m in + let uu___1 = FStarC_TypeChecker_Env.wp_signature env m in + match uu___1 with + | (a, kwp) -> + let uu___2 = destruct_wp_comp ct1 in + let uu___3 = destruct_wp_comp ct2 in + ((md, a, kwp), uu___2, uu___3) in + match uu___ with + | ((md, a, kwp), (u_t1, t1, wp1), (u_t2, t2, wp2)) -> + let bs = + match b with + | FStar_Pervasives_Native.None -> + let uu___1 = FStarC_Syntax_Syntax.null_binder t1 in + [uu___1] + | FStar_Pervasives_Native.Some x -> + let uu___1 = FStarC_Syntax_Syntax.mk_binder x in + [uu___1] in + let mk_lam wp = + FStarC_Syntax_Util.abs bs wp + (FStar_Pervasives_Native.Some + (FStarC_Syntax_Util.mk_residual_comp + FStarC_Parser_Const.effect_Tot_lid + FStar_Pervasives_Native.None + [FStarC_Syntax_Syntax.TOTAL])) in + let wp_args = + let uu___1 = FStarC_Syntax_Syntax.as_arg t1 in + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.as_arg t2 in + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.as_arg wp1 in + let uu___6 = + let uu___7 = + let uu___8 = mk_lam wp2 in + FStarC_Syntax_Syntax.as_arg uu___8 in + [uu___7] in + uu___5 :: uu___6 in + uu___3 :: uu___4 in + uu___1 :: uu___2 in + let uu___1 = FStarC_Syntax_Util.get_bind_vc_combinator md in + (match uu___1 with + | (bind_wp, uu___2) -> + let wp = + let uu___3 = + FStarC_TypeChecker_Env.inst_effect_fun_with + [u_t1; u_t2] env md bind_wp in + FStarC_Syntax_Syntax.mk_Tm_app uu___3 wp_args + t2.FStarC_Syntax_Syntax.pos in + mk_comp md u_t2 t2 wp flags) +let (mk_bind : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.comp -> + FStarC_Syntax_Syntax.bv FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.comp -> + FStarC_Syntax_Syntax.cflag Prims.list -> + FStarC_Compiler_Range_Type.range -> + (FStarC_Syntax_Syntax.comp * FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun c1 -> + fun b -> + fun c2 -> + fun flags -> + fun r1 -> + let env2 = maybe_push env b in + let uu___ = + let uu___1 = + FStarC_TypeChecker_Env.unfold_effect_abbrev env c1 in + let uu___2 = + FStarC_TypeChecker_Env.unfold_effect_abbrev env2 c2 in + (uu___1, uu___2) in + match uu___ with + | (ct1, ct2) -> + let uu___1 = + FStarC_TypeChecker_Env.exists_polymonadic_bind env + ct1.FStarC_Syntax_Syntax.effect_name + ct2.FStarC_Syntax_Syntax.effect_name in + (match uu___1 with + | FStar_Pervasives_Native.Some (p, f_bind) -> + f_bind env ct1 b ct2 flags r1 + | FStar_Pervasives_Native.None -> + let uu___2 = lift_comps env c1 c2 b true in + (match uu___2 with + | (m, c11, c21, g_lift) -> + let uu___3 = + let uu___4 = + FStarC_TypeChecker_Env.comp_to_comp_typ env + c11 in + let uu___5 = + FStarC_TypeChecker_Env.comp_to_comp_typ env2 + c21 in + (uu___4, uu___5) in + (match uu___3 with + | (ct11, ct21) -> + let uu___4 = + let uu___5 = + FStarC_TypeChecker_Env.is_layered_effect + env m in + if uu___5 + then + let m_ed = + FStarC_TypeChecker_Env.get_effect_decl + env m in + let num_effect_params = + match m_ed.FStarC_Syntax_Syntax.signature + with + | FStarC_Syntax_Syntax.Layered_eff_sig + (n, uu___6) -> n + | uu___6 -> + failwith + "Impossible (mk_bind expected an indexed effect)" in + let uu___6 = + FStarC_Syntax_Util.get_bind_vc_combinator + m_ed in + match uu___6 with + | (bind_t, bind_kind) -> + let has_range_args = + FStarC_Syntax_Util.has_attribute + m_ed.FStarC_Syntax_Syntax.eff_attrs + FStarC_Parser_Const.bind_has_range_args_attr in + let uu___7 = + FStarC_Compiler_Util.must + bind_kind in + mk_indexed_bind env m m m bind_t + uu___7 ct11 b ct21 flags r1 + num_effect_params has_range_args + else + (let uu___7 = + mk_wp_bind env m ct11 b ct21 flags r1 in + (uu___7, + FStarC_TypeChecker_Env.trivial_guard)) in + (match uu___4 with + | (c, g_bind) -> + let uu___5 = + FStarC_TypeChecker_Env.conj_guard + g_lift g_bind in + (c, uu___5))))) +let (strengthen_comp : + FStarC_TypeChecker_Env.env -> + (unit -> FStarC_Pprint.document Prims.list) + FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.comp -> + FStarC_Syntax_Syntax.formula -> + FStarC_Syntax_Syntax.cflag Prims.list -> + (FStarC_Syntax_Syntax.comp * FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun reason -> + fun c -> + fun f -> + fun flags -> + let uu___ = + env.FStarC_TypeChecker_Env.phase1 || + (FStarC_TypeChecker_Env.too_early_in_prims env) in + if uu___ + then (c, FStarC_TypeChecker_Env.trivial_guard) + else + (let r = FStarC_TypeChecker_Env.get_range env in + let pure_assert_wp = + let uu___2 = + FStarC_Syntax_Syntax.lid_as_fv + FStarC_Parser_Const.pure_assert_wp_lid + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___2 in + let pure_assert_wp1 = + let uu___2 = + let uu___3 = + let uu___4 = label_opt env reason r f in + FStarC_Syntax_Syntax.as_arg uu___4 in + [uu___3] in + FStarC_Syntax_Syntax.mk_Tm_app pure_assert_wp uu___2 r in + let r1 = FStarC_TypeChecker_Env.get_range env in + let pure_c = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Syntax.as_arg pure_assert_wp1 in + [uu___4] in + { + FStarC_Syntax_Syntax.comp_univs = + [FStarC_Syntax_Syntax.U_zero]; + FStarC_Syntax_Syntax.effect_name = + FStarC_Parser_Const.effect_PURE_lid; + FStarC_Syntax_Syntax.result_typ = + FStarC_Syntax_Syntax.t_unit; + FStarC_Syntax_Syntax.effect_args = uu___3; + FStarC_Syntax_Syntax.flags = [] + } in + FStarC_Syntax_Syntax.mk_Comp uu___2 in + mk_bind env pure_c FStar_Pervasives_Native.None c flags r1) +let (mk_return : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.eff_decl -> + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.term -> + FStarC_Compiler_Range_Type.range -> + (FStarC_Syntax_Syntax.comp * FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun ed -> + fun u_a -> + fun a -> + fun e -> + fun r -> + let uu___ = FStarC_Syntax_Util.is_layered ed in + if uu___ + then mk_indexed_return env ed u_a a e r + else + (let uu___2 = mk_wp_return env ed u_a a e r in + (uu___2, FStarC_TypeChecker_Env.trivial_guard)) +let (return_value : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.universe FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + (FStarC_Syntax_Syntax.comp * FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun eff_lid -> + fun u_t_opt -> + fun t -> + fun v -> + let u = + match u_t_opt with + | FStar_Pervasives_Native.None -> + env.FStarC_TypeChecker_Env.universe_of env t + | FStar_Pervasives_Native.Some u1 -> u1 in + let uu___ = FStarC_TypeChecker_Env.get_effect_decl env eff_lid in + mk_return env uu___ u t v v.FStarC_Syntax_Syntax.pos +let (weaken_flags : + FStarC_Syntax_Syntax.cflag Prims.list -> + FStarC_Syntax_Syntax.cflag Prims.list) + = + fun flags -> + let uu___ = + FStarC_Compiler_Util.for_some + (fun uu___1 -> + match uu___1 with + | FStarC_Syntax_Syntax.SHOULD_NOT_INLINE -> true + | uu___2 -> false) flags in + if uu___ + then [FStarC_Syntax_Syntax.SHOULD_NOT_INLINE] + else + FStarC_Compiler_List.collect + (fun uu___2 -> + match uu___2 with + | FStarC_Syntax_Syntax.TOTAL -> + [FStarC_Syntax_Syntax.TRIVIAL_POSTCONDITION] + | FStarC_Syntax_Syntax.RETURN -> + [FStarC_Syntax_Syntax.PARTIAL_RETURN; + FStarC_Syntax_Syntax.TRIVIAL_POSTCONDITION] + | f -> [f]) flags +let (weaken_comp : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.comp -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.comp * FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun c -> + fun formula -> + let uu___ = FStarC_Syntax_Util.is_ml_comp c in + if uu___ + then (c, FStarC_TypeChecker_Env.trivial_guard) + else + (let ct = FStarC_TypeChecker_Env.unfold_effect_abbrev env c in + let pure_assume_wp = + let uu___2 = + FStarC_Syntax_Syntax.lid_as_fv + FStarC_Parser_Const.pure_assume_wp_lid + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.fv_to_tm uu___2 in + let pure_assume_wp1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.as_arg formula in [uu___3] in + let uu___3 = FStarC_TypeChecker_Env.get_range env in + FStarC_Syntax_Syntax.mk_Tm_app pure_assume_wp uu___2 uu___3 in + let r = FStarC_TypeChecker_Env.get_range env in + let pure_c = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Syntax.as_arg pure_assume_wp1 in + [uu___4] in + { + FStarC_Syntax_Syntax.comp_univs = + [FStarC_Syntax_Syntax.U_zero]; + FStarC_Syntax_Syntax.effect_name = + FStarC_Parser_Const.effect_PURE_lid; + FStarC_Syntax_Syntax.result_typ = + FStarC_Syntax_Syntax.t_unit; + FStarC_Syntax_Syntax.effect_args = uu___3; + FStarC_Syntax_Syntax.flags = [] + } in + FStarC_Syntax_Syntax.mk_Comp uu___2 in + let uu___2 = weaken_flags ct.FStarC_Syntax_Syntax.flags in + mk_bind env pure_c FStar_Pervasives_Native.None c uu___2 r) +let (weaken_precondition : + FStarC_TypeChecker_Env.env -> + FStarC_TypeChecker_Common.lcomp -> + FStarC_TypeChecker_Common.guard_formula -> + FStarC_TypeChecker_Common.lcomp) + = + fun env -> + fun lc -> + fun f -> + let weaken uu___ = + let uu___1 = FStarC_TypeChecker_Common.lcomp_comp lc in + match uu___1 with + | (c, g_c) -> + let uu___2 = + (FStarC_Options.lax ()) && (FStarC_Options.ml_ish ()) in + if uu___2 + then (c, g_c) + else + (match f with + | FStarC_TypeChecker_Common.Trivial -> (c, g_c) + | FStarC_TypeChecker_Common.NonTrivial f1 -> + let uu___4 = weaken_comp env c f1 in + (match uu___4 with + | (c1, g_w) -> + let uu___5 = + FStarC_TypeChecker_Env.conj_guard g_c g_w in + (c1, uu___5))) in + let uu___ = weaken_flags lc.FStarC_TypeChecker_Common.cflags in + FStarC_TypeChecker_Common.mk_lcomp + lc.FStarC_TypeChecker_Common.eff_name + lc.FStarC_TypeChecker_Common.res_typ uu___ weaken +let (strengthen_precondition : + (unit -> FStarC_Pprint.document Prims.list) FStar_Pervasives_Native.option + -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_TypeChecker_Common.lcomp -> + FStarC_TypeChecker_Env.guard_t -> + (FStarC_TypeChecker_Common.lcomp * + FStarC_TypeChecker_Env.guard_t)) + = + fun reason -> + fun env -> + fun e_for_debugging_only -> + fun lc -> + fun g0 -> + let uu___ = FStarC_TypeChecker_Env.is_trivial_guard_formula g0 in + if uu___ + then (lc, g0) + else + (let flags = + let uu___2 = + let uu___3 = + FStarC_TypeChecker_Common.is_tot_or_gtot_lcomp lc in + if uu___3 + then (true, [FStarC_Syntax_Syntax.TRIVIAL_POSTCONDITION]) + else (false, []) in + match uu___2 with + | (maybe_trivial_post, flags1) -> + let uu___3 = + FStarC_Compiler_List.collect + (fun uu___4 -> + match uu___4 with + | FStarC_Syntax_Syntax.RETURN -> + [FStarC_Syntax_Syntax.PARTIAL_RETURN] + | FStarC_Syntax_Syntax.PARTIAL_RETURN -> + [FStarC_Syntax_Syntax.PARTIAL_RETURN] + | FStarC_Syntax_Syntax.SOMETRIVIAL when + Prims.op_Negation maybe_trivial_post -> + [FStarC_Syntax_Syntax.TRIVIAL_POSTCONDITION] + | FStarC_Syntax_Syntax.TRIVIAL_POSTCONDITION when + Prims.op_Negation maybe_trivial_post -> + [FStarC_Syntax_Syntax.TRIVIAL_POSTCONDITION] + | FStarC_Syntax_Syntax.SHOULD_NOT_INLINE -> + [FStarC_Syntax_Syntax.SHOULD_NOT_INLINE] + | uu___5 -> []) + lc.FStarC_TypeChecker_Common.cflags in + FStarC_Compiler_List.op_At flags1 uu___3 in + let strengthen uu___2 = + let uu___3 = FStarC_TypeChecker_Common.lcomp_comp lc in + match uu___3 with + | (c, g_c) -> + let uu___4 = FStarC_Options.lax () in + if uu___4 + then (c, g_c) + else + (let g01 = + FStarC_TypeChecker_Rel.simplify_guard env g0 in + let uu___6 = FStarC_TypeChecker_Env.guard_form g01 in + match uu___6 with + | FStarC_TypeChecker_Common.Trivial -> (c, g_c) + | FStarC_TypeChecker_Common.NonTrivial f -> + ((let uu___8 = FStarC_Compiler_Debug.extreme () in + if uu___8 + then + let uu___9 = + FStarC_TypeChecker_Normalize.term_to_string + env e_for_debugging_only in + let uu___10 = + FStarC_TypeChecker_Normalize.term_to_string + env f in + FStarC_Compiler_Util.print2 + "-------------Strengthening pre-condition of term %s with guard %s\n" + uu___9 uu___10 + else ()); + (let uu___8 = + strengthen_comp env reason c f flags in + match uu___8 with + | (c1, g_s) -> + let uu___9 = + FStarC_TypeChecker_Env.conj_guard g_c g_s in + (c1, uu___9)))) in + let uu___2 = + let uu___3 = + FStarC_TypeChecker_Env.norm_eff_name env + lc.FStarC_TypeChecker_Common.eff_name in + FStarC_TypeChecker_Common.mk_lcomp uu___3 + lc.FStarC_TypeChecker_Common.res_typ flags strengthen in + (uu___2, + { + FStarC_TypeChecker_Common.guard_f = + FStarC_TypeChecker_Common.Trivial; + FStarC_TypeChecker_Common.deferred_to_tac = + (g0.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (g0.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (g0.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = + (g0.FStarC_TypeChecker_Common.implicits) + })) +let (lcomp_has_trivial_postcondition : + FStarC_TypeChecker_Common.lcomp -> Prims.bool) = + fun lc -> + (FStarC_TypeChecker_Common.is_tot_or_gtot_lcomp lc) || + (FStarC_Compiler_Util.for_some + (fun uu___ -> + match uu___ with + | FStarC_Syntax_Syntax.SOMETRIVIAL -> true + | FStarC_Syntax_Syntax.TRIVIAL_POSTCONDITION -> true + | uu___1 -> false) lc.FStarC_TypeChecker_Common.cflags) +let (maybe_capture_unit_refinement : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.bv -> + FStarC_Syntax_Syntax.comp -> + (FStarC_Syntax_Syntax.comp * FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun t -> + fun x -> + fun c -> + let t1 = + FStarC_TypeChecker_Normalize.normalize_refinement + FStarC_TypeChecker_Normalize.whnf_steps env t in + match t1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = b; FStarC_Syntax_Syntax.phi = phi;_} + -> + let is_unit = + match (b.FStarC_Syntax_Syntax.sort).FStarC_Syntax_Syntax.n + with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.unit_lid + | uu___ -> false in + if is_unit + then + let uu___ = + let uu___1 = + FStarC_TypeChecker_Env.norm_eff_name env + (FStarC_Syntax_Util.comp_effect_name c) in + FStarC_TypeChecker_Env.is_layered_effect env uu___1 in + (if uu___ + then + let uu___1 = FStarC_Syntax_Subst.open_term_bv b phi in + match uu___1 with + | (b1, phi1) -> + let phi2 = + FStarC_Syntax_Subst.subst + [FStarC_Syntax_Syntax.NT + (b1, FStarC_Syntax_Syntax.unit_const)] phi1 in + weaken_comp env c phi2 + else + (let uu___2 = close_wp_comp env [x] c in + (uu___2, FStarC_TypeChecker_Env.trivial_guard))) + else (c, FStarC_TypeChecker_Env.trivial_guard) + | uu___ -> (c, FStarC_TypeChecker_Env.trivial_guard) +let (bind : + FStarC_Compiler_Range_Type.range -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option -> + FStarC_TypeChecker_Common.lcomp -> + lcomp_with_binder -> FStarC_TypeChecker_Common.lcomp) + = + fun r1 -> + fun env -> + fun e1opt -> + fun lc1 -> + fun uu___ -> + match uu___ with + | (b, lc2) -> + let debug f = + let uu___1 = + (FStarC_Compiler_Debug.extreme ()) || + (FStarC_Compiler_Effect.op_Bang dbg_bind) in + if uu___1 then f () else () in + let uu___1 = + FStarC_TypeChecker_Normalize.ghost_to_pure_lcomp2 env + (lc1, lc2) in + (match uu___1 with + | (lc11, lc21) -> + let joined_eff = join_lcomp env lc11 lc21 in + let bind_flags = + let uu___2 = + (should_not_inline_lc lc11) || + (should_not_inline_lc lc21) in + if uu___2 + then [FStarC_Syntax_Syntax.SHOULD_NOT_INLINE] + else + (let flags = + let uu___4 = + FStarC_TypeChecker_Common.is_total_lcomp lc11 in + if uu___4 + then + let uu___5 = + FStarC_TypeChecker_Common.is_total_lcomp lc21 in + (if uu___5 + then [FStarC_Syntax_Syntax.TOTAL] + else + (let uu___7 = + FStarC_TypeChecker_Common.is_tot_or_gtot_lcomp + lc21 in + if uu___7 + then [FStarC_Syntax_Syntax.SOMETRIVIAL] + else [])) + else + (let uu___6 = + (FStarC_TypeChecker_Common.is_tot_or_gtot_lcomp + lc11) + && + (FStarC_TypeChecker_Common.is_tot_or_gtot_lcomp + lc21) in + if uu___6 + then [FStarC_Syntax_Syntax.SOMETRIVIAL] + else []) in + let uu___4 = lcomp_has_trivial_postcondition lc21 in + if uu___4 + then FStarC_Syntax_Syntax.TRIVIAL_POSTCONDITION :: + flags + else flags) in + let bind_it uu___2 = + let uu___3 = + (FStarC_Options.lax ()) && + (FStarC_Options.ml_ish ()) in + if uu___3 + then + let u_t = + env.FStarC_TypeChecker_Env.universe_of env + lc21.FStarC_TypeChecker_Common.res_typ in + let uu___4 = + lax_mk_tot_or_comp_l joined_eff u_t + lc21.FStarC_TypeChecker_Common.res_typ [] in + (uu___4, FStarC_TypeChecker_Env.trivial_guard) + else + (let uu___5 = + FStarC_TypeChecker_Common.lcomp_comp lc11 in + match uu___5 with + | (c1, g_c1) -> + let uu___6 = + FStarC_TypeChecker_Common.lcomp_comp lc21 in + (match uu___6 with + | (c2, g_c2) -> + let trivial_guard = + let uu___7 = + match b with + | FStar_Pervasives_Native.Some x -> + let b1 = + FStarC_Syntax_Syntax.mk_binder x in + let uu___8 = + FStarC_Syntax_Syntax.is_null_binder + b1 in + if uu___8 + then g_c2 + else + FStarC_TypeChecker_Env.close_guard + env [b1] g_c2 + | FStar_Pervasives_Native.None -> g_c2 in + FStarC_TypeChecker_Env.conj_guard g_c1 + uu___7 in + (debug + (fun uu___8 -> + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_comp + c1 in + let uu___10 = + match b with + | FStar_Pervasives_Native.None -> + "none" + | FStar_Pervasives_Native.Some x + -> + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_bv + x in + let uu___11 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_comp + c2 in + let uu___12 = + match e1opt with + | FStar_Pervasives_Native.None -> + "none" + | FStar_Pervasives_Native.Some e1 + -> + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + e1 in + FStarC_Compiler_Util.print4 + "(1) bind: \n\tc1=%s\n\tx=%s\n\tc2=%s\n\te1=%s\n(1. end bind)\n" + uu___9 uu___10 uu___11 uu___12); + (let aux uu___8 = + let uu___9 = + FStarC_Syntax_Util.is_trivial_wp c1 in + if uu___9 + then + match b with + | FStar_Pervasives_Native.None -> + FStar_Pervasives.Inl + (c2, "trivial no binder") + | FStar_Pervasives_Native.Some + uu___10 -> + let uu___11 = + FStarC_Syntax_Util.is_ml_comp + c2 in + (if uu___11 + then + FStar_Pervasives.Inl + (c2, "trivial ml") + else + FStar_Pervasives.Inr + "c1 trivial; but c2 is not ML") + else + (let uu___11 = + (FStarC_Syntax_Util.is_ml_comp c1) + && + (FStarC_Syntax_Util.is_ml_comp + c2) in + if uu___11 + then + FStar_Pervasives.Inl + (c2, "both ml") + else + FStar_Pervasives.Inr + "c1 not trivial, and both are not ML") in + let try_simplify uu___8 = + let aux_with_trivial_guard uu___9 = + let uu___10 = aux () in + match uu___10 with + | FStar_Pervasives.Inl (c, reason) + -> + FStar_Pervasives.Inl + (c, trivial_guard, reason) + | FStar_Pervasives.Inr reason -> + FStar_Pervasives.Inr reason in + let uu___9 = + FStarC_TypeChecker_Env.too_early_in_prims + env in + if uu___9 + then + FStar_Pervasives.Inl + (c2, trivial_guard, + "Early in prims; we don't have bind yet") + else + (let uu___11 = + FStarC_Syntax_Util.is_total_comp + c1 in + if uu___11 + then + let close_with_type_of_x x c = + let x1 = + { + FStarC_Syntax_Syntax.ppname + = + (x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index + = + (x.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = + (FStarC_Syntax_Util.comp_result + c1) + } in + maybe_capture_unit_refinement + env + x1.FStarC_Syntax_Syntax.sort + x1 c in + match (e1opt, b) with + | (FStar_Pervasives_Native.Some + e, + FStar_Pervasives_Native.Some + x) -> + let uu___12 = + let uu___13 = + FStarC_Syntax_Subst.subst_comp + [FStarC_Syntax_Syntax.NT + (x, e)] c2 in + close_with_type_of_x x + uu___13 in + (match uu___12 with + | (c21, g_close) -> + let uu___13 = + let uu___14 = + let uu___15 = + let uu___16 = + let uu___17 = + FStarC_TypeChecker_Env.map_guard + g_c2 + (FStarC_Syntax_Subst.subst + [ + FStarC_Syntax_Syntax.NT + (x, e)]) in + [uu___17; + g_close] in + g_c1 :: uu___16 in + FStarC_TypeChecker_Env.conj_guards + uu___15 in + (c21, uu___14, + "c1 Tot") in + FStar_Pervasives.Inl + uu___13) + | (uu___12, + FStar_Pervasives_Native.Some + x) -> + let uu___13 = + close_with_type_of_x x c2 in + (match uu___13 with + | (c21, g_close) -> + let uu___14 = + let uu___15 = + let uu___16 = + let uu___17 = + let uu___18 = + let uu___19 = + let uu___20 + = + FStarC_Syntax_Syntax.mk_binder + x in + [uu___20] in + FStarC_TypeChecker_Env.close_guard + env uu___19 + g_c2 in + [uu___18; + g_close] in + g_c1 :: uu___17 in + FStarC_TypeChecker_Env.conj_guards + uu___16 in + (c21, uu___15, + "c1 Tot only close") in + FStar_Pervasives.Inl + uu___14) + | (uu___12, uu___13) -> + aux_with_trivial_guard () + else + (let uu___13 = + (FStarC_Syntax_Util.is_tot_or_gtot_comp + c1) + && + (FStarC_Syntax_Util.is_tot_or_gtot_comp + c2) in + if uu___13 + then + let uu___14 = + let uu___15 = + FStarC_Syntax_Syntax.mk_GTotal + (FStarC_Syntax_Util.comp_result + c2) in + (uu___15, trivial_guard, + "both GTot") in + FStar_Pervasives.Inl uu___14 + else aux_with_trivial_guard ())) in + let uu___8 = try_simplify () in + match uu___8 with + | FStar_Pervasives.Inl (c, g, reason) -> + (debug + (fun uu___10 -> + let uu___11 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_comp + c in + FStarC_Compiler_Util.print2 + "(2) bind: Simplified (because %s) to\n\t%s\n" + reason uu___11); + (c, g)) + | FStar_Pervasives.Inr reason -> + (debug + (fun uu___10 -> + FStarC_Compiler_Util.print1 + "(2) bind: Not simplified because %s\n" + reason); + (let mk_bind1 c11 b1 c21 g = + let uu___10 = + mk_bind env c11 b1 c21 + bind_flags r1 in + match uu___10 with + | (c, g_bind) -> + let uu___11 = + FStarC_TypeChecker_Env.conj_guard + g g_bind in + (c, uu___11) in + let uu___10 = + let t = + FStarC_Syntax_Util.comp_result + c1 in + match comp_univ_opt c1 with + | FStar_Pervasives_Native.None + -> + let uu___11 = + env.FStarC_TypeChecker_Env.universe_of + env t in + (uu___11, t) + | FStar_Pervasives_Native.Some u + -> (u, t) in + match uu___10 with + | (u_res_t1, res_t1) -> + let uu___11 = + (FStarC_Compiler_Option.isSome + b) + && + (should_return env e1opt + lc11) in + if uu___11 + then + let e1 = + FStarC_Compiler_Option.get + e1opt in + let x = + FStarC_Compiler_Option.get + b in + let uu___12 = + FStarC_Syntax_Util.is_partial_return + c1 in + (if uu___12 + then + (debug + (fun uu___14 -> + let uu___15 = + FStarC_TypeChecker_Normalize.term_to_string + env e1 in + let uu___16 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_bv + x in + FStarC_Compiler_Util.print2 + "(3) bind (case a): Substituting %s for %s\n" + uu___15 uu___16); + (let c21 = + FStarC_Syntax_Subst.subst_comp + [FStarC_Syntax_Syntax.NT + (x, e1)] c2 in + let g = + let uu___14 = + FStarC_TypeChecker_Env.map_guard + g_c2 + (FStarC_Syntax_Subst.subst + [FStarC_Syntax_Syntax.NT + (x, e1)]) in + FStarC_TypeChecker_Env.conj_guard + g_c1 uu___14 in + mk_bind1 c1 b c21 g)) + else + (debug + (fun uu___15 -> + let uu___16 = + FStarC_TypeChecker_Normalize.term_to_string + env e1 in + let uu___17 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_bv + x in + FStarC_Compiler_Util.print2 + "(3) bind (case b): Adding equality %s = %s\n" + uu___16 uu___17); + (let c21 = + FStarC_Syntax_Subst.subst_comp + [FStarC_Syntax_Syntax.NT + (x, e1)] c2 in + let x_eq_e = + let uu___15 = + FStarC_Syntax_Syntax.bv_to_name + x in + FStarC_Syntax_Util.mk_eq2 + u_res_t1 res_t1 e1 + uu___15 in + let uu___15 = + let uu___16 = + let uu___17 = + let uu___18 = + FStarC_Syntax_Syntax.mk_binder + x in + [uu___18] in + FStarC_TypeChecker_Env.push_binders + env uu___17 in + weaken_comp uu___16 + c21 x_eq_e in + match uu___15 with + | (c22, g_w) -> + let g = + let uu___16 = + let uu___17 = + let uu___18 = + let uu___19 + = + let uu___20 + = + FStarC_Syntax_Syntax.mk_binder + x in + [uu___20] in + FStarC_TypeChecker_Env.close_guard + env + uu___19 + g_w in + let uu___19 = + let uu___20 + = + let uu___21 + = + let uu___22 + = + FStarC_Syntax_Syntax.mk_binder + x in + [uu___22] in + let uu___22 + = + FStarC_TypeChecker_Common.weaken_guard_formula + g_c2 + x_eq_e in + FStarC_TypeChecker_Env.close_guard + env + uu___21 + uu___22 in + [uu___20] in + uu___18 :: + uu___19 in + g_c1 :: uu___17 in + FStarC_TypeChecker_Env.conj_guards + uu___16 in + mk_bind1 c1 b c22 g))) + else + mk_bind1 c1 b c2 + trivial_guard)))))) in + FStarC_TypeChecker_Common.mk_lcomp joined_eff + lc21.FStarC_TypeChecker_Common.res_typ bind_flags + bind_it) +let (weaken_guard : + FStarC_TypeChecker_Common.guard_formula -> + FStarC_TypeChecker_Common.guard_formula -> + FStarC_TypeChecker_Common.guard_formula) + = + fun g1 -> + fun g2 -> + match (g1, g2) with + | (FStarC_TypeChecker_Common.NonTrivial f1, + FStarC_TypeChecker_Common.NonTrivial f2) -> + let g = FStarC_Syntax_Util.mk_imp f1 f2 in + FStarC_TypeChecker_Common.NonTrivial g + | uu___ -> g2 +let (assume_result_eq_pure_term_in_m : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.term -> + FStarC_TypeChecker_Common.lcomp -> FStarC_TypeChecker_Common.lcomp) + = + fun env -> + fun m_opt -> + fun e -> + fun lc -> + let m = + let uu___ = + (FStarC_Compiler_Util.is_none m_opt) || + (is_ghost_effect env lc.FStarC_TypeChecker_Common.eff_name) in + if uu___ + then FStarC_Parser_Const.effect_PURE_lid + else FStarC_Compiler_Util.must m_opt in + let flags = + let uu___ = FStarC_TypeChecker_Common.is_total_lcomp lc in + if uu___ + then FStarC_Syntax_Syntax.RETURN :: + (lc.FStarC_TypeChecker_Common.cflags) + else FStarC_Syntax_Syntax.PARTIAL_RETURN :: + (lc.FStarC_TypeChecker_Common.cflags) in + let refine uu___ = + let uu___1 = FStarC_TypeChecker_Common.lcomp_comp lc in + match uu___1 with + | (c, g_c) -> + let u_t = + match comp_univ_opt c with + | FStar_Pervasives_Native.Some u_t1 -> u_t1 + | FStar_Pervasives_Native.None -> + env.FStarC_TypeChecker_Env.universe_of env + (FStarC_Syntax_Util.comp_result c) in + let uu___2 = FStarC_Syntax_Util.is_tot_or_gtot_comp c in + if uu___2 + then + let uu___3 = + return_value env m (FStar_Pervasives_Native.Some u_t) + (FStarC_Syntax_Util.comp_result c) e in + (match uu___3 with + | (retc, g_retc) -> + let g_c1 = + FStarC_TypeChecker_Env.conj_guard g_c g_retc in + let uu___4 = + let uu___5 = FStarC_Syntax_Util.is_pure_comp c in + Prims.op_Negation uu___5 in + if uu___4 + then + let retc1 = + FStarC_TypeChecker_Env.comp_to_comp_typ env retc in + let retc2 = + { + FStarC_Syntax_Syntax.comp_univs = + (retc1.FStarC_Syntax_Syntax.comp_univs); + FStarC_Syntax_Syntax.effect_name = + FStarC_Parser_Const.effect_GHOST_lid; + FStarC_Syntax_Syntax.result_typ = + (retc1.FStarC_Syntax_Syntax.result_typ); + FStarC_Syntax_Syntax.effect_args = + (retc1.FStarC_Syntax_Syntax.effect_args); + FStarC_Syntax_Syntax.flags = flags + } in + let uu___5 = FStarC_Syntax_Syntax.mk_Comp retc2 in + (uu___5, g_c1) + else + (let uu___6 = + FStarC_TypeChecker_Env.comp_set_flags env retc + flags in + (uu___6, g_c1))) + else + (let c1 = FStarC_TypeChecker_Env.unfold_effect_abbrev env c in + let t = c1.FStarC_Syntax_Syntax.result_typ in + let c2 = FStarC_Syntax_Syntax.mk_Comp c1 in + let x = + FStarC_Syntax_Syntax.new_bv + (FStar_Pervasives_Native.Some + (t.FStarC_Syntax_Syntax.pos)) t in + let xexp = FStarC_Syntax_Syntax.bv_to_name x in + let env_x = FStarC_TypeChecker_Env.push_bv env x in + let uu___4 = + return_value env_x m (FStar_Pervasives_Native.Some u_t) + t xexp in + match uu___4 with + | (ret, g_ret) -> + let ret1 = + let uu___5 = + FStarC_TypeChecker_Env.comp_set_flags env_x ret + [FStarC_Syntax_Syntax.PARTIAL_RETURN] in + FStarC_TypeChecker_Common.lcomp_of_comp uu___5 in + let eq = FStarC_Syntax_Util.mk_eq2 u_t t xexp e in + let eq_ret = + weaken_precondition env_x ret1 + (FStarC_TypeChecker_Common.NonTrivial eq) in + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_TypeChecker_Common.lcomp_of_comp c2 in + bind e.FStarC_Syntax_Syntax.pos env + FStar_Pervasives_Native.None uu___7 + ((FStar_Pervasives_Native.Some x), eq_ret) in + FStarC_TypeChecker_Common.lcomp_comp uu___6 in + (match uu___5 with + | (bind_c, g_bind) -> + let uu___6 = + FStarC_TypeChecker_Env.comp_set_flags env + bind_c flags in + let uu___7 = + FStarC_TypeChecker_Env.conj_guards + [g_c; g_ret; g_bind] in + (uu___6, uu___7))) in + let uu___ = should_not_inline_lc lc in + if uu___ + then + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Errors_Msg.text + "assume_result_eq_pure_term cannot inline an non-inlineable lc : " in + let uu___4 = + FStarC_Class_PP.pp FStarC_Syntax_Print.pretty_term e in + FStarC_Pprint.op_Hat_Hat uu___3 uu___4 in + [uu___2] in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) e + FStarC_Errors_Codes.Fatal_UnexpectedTerm () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___1) + else + (let uu___2 = refine () in + match uu___2 with + | (c, g) -> FStarC_TypeChecker_Common.lcomp_of_comp_guard c g) +let (maybe_assume_result_eq_pure_term_in_m : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.term -> + FStarC_TypeChecker_Common.lcomp -> FStarC_TypeChecker_Common.lcomp) + = + fun env -> + fun m_opt -> + fun e -> + fun lc -> + let should_return1 = + (((Prims.op_Negation env.FStarC_TypeChecker_Env.phase1) && + (let uu___ = FStarC_TypeChecker_Env.too_early_in_prims env in + Prims.op_Negation uu___)) + && (should_return env (FStar_Pervasives_Native.Some e) lc)) + && + (let uu___ = + FStarC_TypeChecker_Common.is_lcomp_partial_return lc in + Prims.op_Negation uu___) in + if Prims.op_Negation should_return1 + then lc + else assume_result_eq_pure_term_in_m env m_opt e lc +let (maybe_assume_result_eq_pure_term : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_TypeChecker_Common.lcomp -> FStarC_TypeChecker_Common.lcomp) + = + fun env -> + fun e -> + fun lc -> + maybe_assume_result_eq_pure_term_in_m env + FStar_Pervasives_Native.None e lc +let (maybe_return_e2_and_bind : + FStarC_Compiler_Range_Type.range -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term FStar_Pervasives_Native.option -> + FStarC_TypeChecker_Common.lcomp -> + FStarC_Syntax_Syntax.term -> + lcomp_with_binder -> FStarC_TypeChecker_Common.lcomp) + = + fun r -> + fun env -> + fun e1opt -> + fun lc1 -> + fun e2 -> + fun uu___ -> + match uu___ with + | (x, lc2) -> + let env_x = + match x with + | FStar_Pervasives_Native.None -> env + | FStar_Pervasives_Native.Some x1 -> + FStarC_TypeChecker_Env.push_bv env x1 in + let uu___1 = + FStarC_TypeChecker_Normalize.ghost_to_pure_lcomp2 env + (lc1, lc2) in + (match uu___1 with + | (lc11, lc21) -> + let lc22 = + let eff1 = + FStarC_TypeChecker_Env.norm_eff_name env + lc11.FStarC_TypeChecker_Common.eff_name in + let eff2 = + FStarC_TypeChecker_Env.norm_eff_name env + lc21.FStarC_TypeChecker_Common.eff_name in + let uu___2 = + ((FStarC_Ident.lid_equals eff2 + FStarC_Parser_Const.effect_PURE_lid) + && + (let uu___3 = + FStarC_TypeChecker_Env.join_opt env eff1 + eff2 in + FStarC_Compiler_Util.is_none uu___3)) + && + (let uu___3 = + FStarC_TypeChecker_Env.exists_polymonadic_bind + env eff1 eff2 in + FStarC_Compiler_Util.is_none uu___3) in + if uu___2 + then + assume_result_eq_pure_term_in_m env_x + (FStar_Pervasives_Native.Some eff1) e2 lc21 + else + (let uu___4 = + ((let uu___5 = is_pure_or_ghost_effect env eff1 in + Prims.op_Negation uu___5) || + (should_not_inline_lc lc11)) + && (is_pure_or_ghost_effect env eff2) in + if uu___4 + then + maybe_assume_result_eq_pure_term_in_m env_x + (FStar_Pervasives_Native.Some eff1) e2 lc21 + else lc21) in + bind r env e1opt lc11 (x, lc22)) +let (fvar_env : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident -> FStarC_Syntax_Syntax.term) + = + fun env -> + fun lid -> + let uu___ = + let uu___1 = FStarC_TypeChecker_Env.get_range env in + FStarC_Ident.set_lid_range lid uu___1 in + FStarC_Syntax_Syntax.fvar uu___ FStar_Pervasives_Native.None +let (substitutive_indexed_ite_substs : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.indexed_effect_combinator_kind -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.comp_typ -> + FStarC_Syntax_Syntax.comp_typ -> + Prims.int -> + FStarC_Compiler_Range_Type.range -> + (FStarC_Syntax_Syntax.subst_elt Prims.list * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun k -> + fun bs -> + fun a -> + fun p -> + fun ct_then -> + fun ct_else -> + fun num_effect_params -> + fun r -> + let debug = + FStarC_Compiler_Effect.op_Bang dbg_LayeredEffectsApp in + let uu___ = + let uu___1 = bs in + match uu___1 with + | a_b::bs1 -> + (bs1, + [FStarC_Syntax_Syntax.NT + ((a_b.FStarC_Syntax_Syntax.binder_bv), a)]) in + match uu___ with + | (bs1, subst) -> + let uu___1 = + if num_effect_params = Prims.int_zero + then + (bs1, subst, + FStarC_TypeChecker_Env.trivial_guard, + (ct_then.FStarC_Syntax_Syntax.effect_args), + (ct_else.FStarC_Syntax_Syntax.effect_args)) + else + (let split l = + FStarC_Compiler_List.splitAt num_effect_params + l in + let uu___3 = split bs1 in + match uu___3 with + | (eff_params_bs, bs2) -> + let uu___4 = + split + ct_then.FStarC_Syntax_Syntax.effect_args in + (match uu___4 with + | (param_args1, args1) -> + let uu___5 = + split + ct_else.FStarC_Syntax_Syntax.effect_args in + (match uu___5 with + | (param_args2, args2) -> + let g = + FStarC_Compiler_List.fold_left2 + (fun g1 -> + fun uu___6 -> + fun uu___7 -> + match (uu___6, uu___7) + with + | ((arg1, uu___8), + (arg2, uu___9)) -> + let uu___10 = + FStarC_TypeChecker_Rel.layered_effect_teq + env arg1 arg2 + (FStar_Pervasives_Native.Some + "effect param ite") in + FStarC_TypeChecker_Env.conj_guard + g1 uu___10) + FStarC_TypeChecker_Env.trivial_guard + param_args1 param_args2 in + let param_subst = + FStarC_Compiler_List.map2 + (fun b -> + fun uu___6 -> + match uu___6 with + | (arg, uu___7) -> + FStarC_Syntax_Syntax.NT + ((b.FStarC_Syntax_Syntax.binder_bv), + arg)) + eff_params_bs param_args1 in + (bs2, + (FStarC_Compiler_List.op_At + subst param_subst), g, args1, + args2)))) in + (match uu___1 with + | (bs2, subst1, guard, args1, args2) -> + let uu___2 = + let m_num_effect_args = + FStarC_Compiler_List.length args1 in + let uu___3 = + FStarC_Compiler_List.splitAt + m_num_effect_args bs2 in + match uu___3 with + | (f_bs, bs3) -> + let f_subst = + FStarC_Compiler_List.map2 + (fun f_b -> + fun uu___4 -> + match uu___4 with + | (arg, uu___5) -> + FStarC_Syntax_Syntax.NT + ((f_b.FStarC_Syntax_Syntax.binder_bv), + arg)) f_bs args1 in + (bs3, + (FStarC_Compiler_List.op_At subst1 + f_subst)) in + (match uu___2 with + | (bs3, subst2) -> + let uu___3 = + if + FStarC_Syntax_Syntax.uu___is_Substitutive_combinator + k + then + let n_num_effect_args = + FStarC_Compiler_List.length args2 in + let uu___4 = + FStarC_Compiler_List.splitAt + n_num_effect_args bs3 in + match uu___4 with + | (g_bs, bs4) -> + let g_subst = + FStarC_Compiler_List.map2 + (fun g_b -> + fun uu___5 -> + match uu___5 with + | (arg, uu___6) -> + FStarC_Syntax_Syntax.NT + ((g_b.FStarC_Syntax_Syntax.binder_bv), + arg)) g_bs args2 in + (bs4, + (FStarC_Compiler_List.op_At + subst2 g_subst), guard) + else + if + FStarC_Syntax_Syntax.uu___is_Substitutive_invariant_combinator + k + then + (let uu___5 = + FStarC_Compiler_List.fold_left2 + (fun guard1 -> + fun uu___6 -> + fun uu___7 -> + match (uu___6, uu___7) + with + | ((arg1, uu___8), + (arg2, uu___9)) -> + let uu___10 = + FStarC_TypeChecker_Rel.layered_effect_teq + env arg1 arg2 + (FStar_Pervasives_Native.Some + "substitutive_inv ite args") in + FStarC_TypeChecker_Env.conj_guard + guard1 uu___10) + guard args1 args2 in + (bs3, subst2, uu___5)) + else + failwith + "Impossible (substitutive_indexed_ite: unexpected k)" in + (match uu___3 with + | (bs4, subst3, guard1) -> + let uu___4 = + FStarC_Compiler_List.splitAt + ((FStarC_Compiler_List.length bs4) + - (Prims.of_int (3))) bs4 in + (match uu___4 with + | (bs5, uu___5::uu___6::p_b::[]) -> + let uu___7 = + FStarC_Compiler_List.fold_left + (fun uu___8 -> + fun b -> + match uu___8 with + | (subst4, g) -> + let uu___9 = + FStarC_TypeChecker_Env.uvars_for_binders + env [b] subst4 + (fun b1 -> + if debug + then + let uu___10 + = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_binder + b1 in + let uu___11 + = + FStarC_Ident.string_of_lid + ct_then.FStarC_Syntax_Syntax.effect_name in + let uu___12 + = + FStarC_Compiler_Range_Ops.string_of_range + r in + FStarC_Compiler_Util.format3 + "implicit var for additional ite binder %s of %s at %s)" + uu___10 + uu___11 + uu___12 + else + "substitutive_indexed_ite_substs") + r in + (match uu___9 with + | (uv_t::[], g_uv) + -> + let uu___10 = + FStarC_TypeChecker_Env.conj_guard + g g_uv in + ((FStarC_Compiler_List.op_At + subst4 + [FStarC_Syntax_Syntax.NT + ((b.FStarC_Syntax_Syntax.binder_bv), + uv_t)]), + uu___10))) + (subst3, guard1) bs5 in + (match uu___7 with + | (subst4, g) -> + ((FStarC_Compiler_List.op_At + subst4 + [FStarC_Syntax_Syntax.NT + ((p_b.FStarC_Syntax_Syntax.binder_bv), + p)]), g)))))) +let (ad_hoc_indexed_ite_substs : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.comp_typ -> + FStarC_Syntax_Syntax.comp_typ -> + FStarC_Compiler_Range_Type.range -> + (FStarC_Syntax_Syntax.subst_elt Prims.list * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun bs -> + fun a -> + fun p -> + fun ct_then -> + fun ct_else -> + fun r -> + let debug = + FStarC_Compiler_Effect.op_Bang dbg_LayeredEffectsApp in + let conjunction_name uu___ = + if debug + then + let uu___1 = + FStarC_Ident.string_of_lid + ct_then.FStarC_Syntax_Syntax.effect_name in + FStarC_Compiler_Util.format1 "%s.conjunction" uu___1 + else "" in + let conjunction_t_error r1 s = + let uu___ = + let uu___1 = + let uu___2 = FStarC_Errors_Msg.text "Conjunction" in + let uu___3 = + let uu___4 = + FStarC_Class_PP.pp FStarC_Ident.pretty_lident + ct_then.FStarC_Syntax_Syntax.effect_name in + let uu___5 = + FStarC_Errors_Msg.text + "does not have proper shape." in + FStarC_Pprint.op_Hat_Hat uu___4 uu___5 in + FStarC_Pprint.op_Hat_Hat uu___2 uu___3 in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Errors_Msg.text "Reason: " in + let uu___5 = FStarC_Errors_Msg.text s in + FStarC_Pprint.op_Hat_Hat uu___4 uu___5 in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range r1 + FStarC_Errors_Codes.Fatal_UnexpectedEffect () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___) in + let uu___ = + if (FStarC_Compiler_List.length bs) >= (Prims.of_int (4)) + then + let uu___1 = bs in + match uu___1 with + | a_b::bs1 -> + let uu___2 = + FStarC_Compiler_List.splitAt + ((FStarC_Compiler_List.length bs1) - + (Prims.of_int (3))) bs1 in + (match uu___2 with + | (rest_bs, f_b::g_b::p_b::[]) -> + (a_b, rest_bs, f_b, g_b, p_b)) + else + conjunction_t_error r + "Either not an abstraction or not enough binders" in + match uu___ with + | (a_b, rest_bs, f_b, g_b, p_b) -> + let uu___1 = + FStarC_TypeChecker_Env.uvars_for_binders env rest_bs + [FStarC_Syntax_Syntax.NT + ((a_b.FStarC_Syntax_Syntax.binder_bv), a)] + (fun b -> + if debug + then + let uu___2 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_binder b in + let uu___3 = + FStarC_Ident.string_of_lid + ct_then.FStarC_Syntax_Syntax.effect_name in + let uu___4 = + FStarC_Compiler_Range_Ops.string_of_range r in + FStarC_Compiler_Util.format3 + "implicit var for binder %s of %s:conjunction at %s" + uu___2 uu___3 uu___4 + else "ad_hoc_indexed_ite_substs") r in + (match uu___1 with + | (rest_bs_uvars, g_uvars) -> + let substs = + FStarC_Compiler_List.map2 + (fun b -> + fun t -> + FStarC_Syntax_Syntax.NT + ((b.FStarC_Syntax_Syntax.binder_bv), t)) + (a_b :: + (FStarC_Compiler_List.op_At rest_bs [p_b])) (a + :: + (FStarC_Compiler_List.op_At rest_bs_uvars [p])) in + let f_guard = + let f_sort_is = + let uu___2 = + let uu___3 = + FStarC_Syntax_Subst.compress + (f_b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + uu___3.FStarC_Syntax_Syntax.n in + match uu___2 with + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = uu___3; + FStarC_Syntax_Syntax.args = uu___4::is;_} + -> + let uu___5 = + FStarC_Compiler_List.map + FStar_Pervasives_Native.fst is in + FStarC_Compiler_List.map + (FStarC_Syntax_Subst.subst substs) uu___5 + | uu___3 -> + conjunction_t_error r + "f's type is not a repr type" in + let uu___2 = + FStarC_Compiler_List.map + FStar_Pervasives_Native.fst + ct_then.FStarC_Syntax_Syntax.effect_args in + FStarC_Compiler_List.fold_left2 + (fun g -> + fun i1 -> + fun f_i -> + let uu___3 = + let uu___4 = + let uu___5 = conjunction_name () in + FStar_Pervasives_Native.Some uu___5 in + FStarC_TypeChecker_Rel.layered_effect_teq + env i1 f_i uu___4 in + FStarC_TypeChecker_Env.conj_guard g + uu___3) + FStarC_TypeChecker_Env.trivial_guard uu___2 + f_sort_is in + let g_guard = + let g_sort_is = + let uu___2 = + let uu___3 = + FStarC_Syntax_Subst.compress + (g_b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + uu___3.FStarC_Syntax_Syntax.n in + match uu___2 with + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = uu___3; + FStarC_Syntax_Syntax.args = uu___4::is;_} + -> + let uu___5 = + FStarC_Compiler_List.map + FStar_Pervasives_Native.fst is in + FStarC_Compiler_List.map + (FStarC_Syntax_Subst.subst substs) uu___5 + | uu___3 -> + conjunction_t_error r + "g's type is not a repr type" in + let uu___2 = + FStarC_Compiler_List.map + FStar_Pervasives_Native.fst + ct_else.FStarC_Syntax_Syntax.effect_args in + FStarC_Compiler_List.fold_left2 + (fun g -> + fun i2 -> + fun g_i -> + let uu___3 = + let uu___4 = + let uu___5 = conjunction_name () in + FStar_Pervasives_Native.Some uu___5 in + FStarC_TypeChecker_Rel.layered_effect_teq + env i2 g_i uu___4 in + FStarC_TypeChecker_Env.conj_guard g + uu___3) + FStarC_TypeChecker_Env.trivial_guard uu___2 + g_sort_is in + let uu___2 = + FStarC_TypeChecker_Env.conj_guards + [g_uvars; f_guard; g_guard] in + (substs, uu___2)) +let (mk_layered_conjunction : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.eff_decl -> + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.comp_typ -> + FStarC_Syntax_Syntax.comp_typ -> + FStarC_Compiler_Range_Type.range -> + (FStarC_Syntax_Syntax.comp * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun ed -> + fun u_a -> + fun a -> + fun p -> + fun ct1 -> + fun ct2 -> + fun r -> + let debug = + FStarC_Compiler_Effect.op_Bang dbg_LayeredEffectsApp in + let conjunction_t_error r1 s = + let uu___ = + let uu___1 = + let uu___2 = FStarC_Errors_Msg.text "Conjunction" in + let uu___3 = + let uu___4 = + FStarC_Class_PP.pp FStarC_Ident.pretty_lident + ct1.FStarC_Syntax_Syntax.effect_name in + let uu___5 = + FStarC_Errors_Msg.text + "does not have proper shape." in + FStarC_Pprint.op_Hat_Hat uu___4 uu___5 in + FStarC_Pprint.op_Hat_Hat uu___2 uu___3 in + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Errors_Msg.text "Reason: " in + let uu___5 = FStarC_Errors_Msg.text s in + FStarC_Pprint.op_Hat_Hat uu___4 uu___5 in + [uu___3] in + uu___1 :: uu___2 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range r1 + FStarC_Errors_Codes.Fatal_UnexpectedEffect () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___) in + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Syntax_Util.get_layered_if_then_else_combinator + ed in + FStarC_Compiler_Util.must uu___2 in + match uu___1 with + | (ts, kopt) -> + let uu___2 = + FStarC_TypeChecker_Env.inst_tscheme_with ts [u_a] in + (match uu___2 with + | (uu___3, conjunction) -> + let uu___4 = FStarC_Compiler_Util.must kopt in + (conjunction, uu___4)) in + match uu___ with + | (conjunction, kind) -> + let uu___1 = FStarC_Syntax_Util.abs_formals conjunction in + (match uu___1 with + | (bs, body, uu___2) -> + (if debug + then + (let uu___4 = + let uu___5 = + FStarC_Syntax_Syntax.mk_Comp ct1 in + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_comp uu___5 in + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.mk_Comp ct2 in + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_comp uu___6 in + FStarC_Compiler_Util.print2 + "layered_ite c1: %s and c2: %s {\n" uu___4 + uu___5) + else (); + (let uu___4 = + if + kind = + FStarC_Syntax_Syntax.Ad_hoc_combinator + then + ad_hoc_indexed_ite_substs env bs a p ct1 ct2 + r + else + (let num_effect_params = + match ed.FStarC_Syntax_Syntax.signature + with + | FStarC_Syntax_Syntax.Layered_eff_sig + (n, uu___6) -> n + | uu___6 -> failwith "Impossible!" in + substitutive_indexed_ite_substs env kind bs + a p ct1 ct2 num_effect_params r) in + match uu___4 with + | (substs, g) -> + let body1 = + FStarC_Syntax_Subst.subst substs body in + let is = + let uu___5 = + let uu___6 = + FStarC_Syntax_Subst.compress body1 in + uu___6.FStarC_Syntax_Syntax.n in + match uu___5 with + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = uu___6; + FStarC_Syntax_Syntax.args = a1::args;_} + -> + FStarC_Compiler_List.map + FStar_Pervasives_Native.fst args + | uu___6 -> + conjunction_t_error r + "body is not a repr type" in + let c = + let uu___5 = + let uu___6 = + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.as_arg is in + { + FStarC_Syntax_Syntax.comp_univs = + [u_a]; + FStarC_Syntax_Syntax.effect_name = + (ed.FStarC_Syntax_Syntax.mname); + FStarC_Syntax_Syntax.result_typ = a; + FStarC_Syntax_Syntax.effect_args = + uu___6; + FStarC_Syntax_Syntax.flags = [] + } in + FStarC_Syntax_Syntax.mk_Comp uu___5 in + (if debug + then + FStarC_Compiler_Util.print_string "\n}\n" + else (); + (c, g))))) +let (mk_non_layered_conjunction : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.eff_decl -> + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.comp_typ -> + FStarC_Syntax_Syntax.comp_typ -> + FStarC_Compiler_Range_Type.range -> + (FStarC_Syntax_Syntax.comp * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun ed -> + fun u_a -> + fun a -> + fun p -> + fun ct1 -> + fun ct2 -> + fun uu___ -> + let p1 = FStarC_Syntax_Util.b2t p in + let if_then_else = + let uu___1 = + FStarC_Syntax_Util.get_wp_if_then_else_combinator ed in + FStarC_Compiler_Util.must uu___1 in + let uu___1 = destruct_wp_comp ct1 in + match uu___1 with + | (uu___2, uu___3, wp_t) -> + let uu___4 = destruct_wp_comp ct2 in + (match uu___4 with + | (uu___5, uu___6, wp_e) -> + let wp = + let uu___7 = + FStarC_TypeChecker_Env.inst_effect_fun_with + [u_a] env ed if_then_else in + let uu___8 = + let uu___9 = FStarC_Syntax_Syntax.as_arg a in + let uu___10 = + let uu___11 = FStarC_Syntax_Syntax.as_arg p1 in + let uu___12 = + let uu___13 = + FStarC_Syntax_Syntax.as_arg wp_t in + let uu___14 = + let uu___15 = + FStarC_Syntax_Syntax.as_arg wp_e in + [uu___15] in + uu___13 :: uu___14 in + uu___11 :: uu___12 in + uu___9 :: uu___10 in + let uu___9 = + FStarC_Compiler_Range_Ops.union_ranges + wp_t.FStarC_Syntax_Syntax.pos + wp_e.FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.mk_Tm_app uu___7 uu___8 + uu___9 in + let uu___7 = mk_comp ed u_a a wp [] in + (uu___7, FStarC_TypeChecker_Env.trivial_guard)) +let (comp_pure_wp_false : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.comp) + = + fun env -> + fun u -> + fun t -> + let post_k = + let uu___ = + let uu___1 = FStarC_Syntax_Syntax.null_binder t in [uu___1] in + let uu___1 = + FStarC_Syntax_Syntax.mk_Total FStarC_Syntax_Util.ktype0 in + FStarC_Syntax_Util.arrow uu___ uu___1 in + let kwp = + let uu___ = + let uu___1 = FStarC_Syntax_Syntax.null_binder post_k in [uu___1] in + let uu___1 = + FStarC_Syntax_Syntax.mk_Total FStarC_Syntax_Util.ktype0 in + FStarC_Syntax_Util.arrow uu___ uu___1 in + let post = + FStarC_Syntax_Syntax.new_bv FStar_Pervasives_Native.None post_k in + let wp = + let uu___ = + let uu___1 = FStarC_Syntax_Syntax.mk_binder post in [uu___1] in + let uu___1 = fvar_env env FStarC_Parser_Const.false_lid in + FStarC_Syntax_Util.abs uu___ uu___1 + (FStar_Pervasives_Native.Some + (FStarC_Syntax_Util.mk_residual_comp + FStarC_Parser_Const.effect_Tot_lid + FStar_Pervasives_Native.None [FStarC_Syntax_Syntax.TOTAL])) in + let md = + FStarC_TypeChecker_Env.get_effect_decl env + FStarC_Parser_Const.effect_PURE_lid in + mk_comp md u t wp [] +let (get_neg_branch_conds : + FStarC_Syntax_Syntax.formula Prims.list -> + (FStarC_Syntax_Syntax.formula Prims.list * FStarC_Syntax_Syntax.formula)) + = + fun branch_conds -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Compiler_List.fold_left + (fun uu___3 -> + fun g -> + match uu___3 with + | (conds, acc) -> + let cond = + let uu___4 = + let uu___5 = FStarC_Syntax_Util.b2t g in + FStarC_Syntax_Util.mk_neg uu___5 in + FStarC_Syntax_Util.mk_conj acc uu___4 in + ((FStarC_Compiler_List.op_At conds [cond]), cond)) + ([FStarC_Syntax_Util.t_true], FStarC_Syntax_Util.t_true) + branch_conds in + FStar_Pervasives_Native.fst uu___2 in + FStarC_Compiler_List.splitAt + ((FStarC_Compiler_List.length uu___1) - Prims.int_one) uu___1 in + match uu___ with + | (l1, l2) -> let uu___1 = FStarC_Compiler_List.hd l2 in (l1, uu___1) +let (bind_cases : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ -> + (FStarC_Syntax_Syntax.typ * FStarC_Ident.lident * + FStarC_Syntax_Syntax.cflag Prims.list * + (Prims.bool -> FStarC_TypeChecker_Common.lcomp)) Prims.list -> + FStarC_Syntax_Syntax.bv -> FStarC_TypeChecker_Common.lcomp) + = + fun env0 -> + fun res_t -> + fun lcases -> + fun scrutinee -> + let env = + let uu___ = + let uu___1 = FStarC_Syntax_Syntax.mk_binder scrutinee in + [uu___1] in + FStarC_TypeChecker_Env.push_binders env0 uu___ in + let eff = + FStarC_Compiler_List.fold_left + (fun eff1 -> + fun uu___ -> + match uu___ with + | (uu___1, eff_label, uu___2, uu___3) -> + join_effects env eff1 eff_label) + FStarC_Parser_Const.effect_PURE_lid lcases in + let uu___ = + let uu___1 = + FStarC_Compiler_Util.for_some + (fun uu___2 -> + match uu___2 with + | (uu___3, uu___4, flags, uu___5) -> + FStarC_Compiler_Util.for_some + (fun uu___6 -> + match uu___6 with + | FStarC_Syntax_Syntax.SHOULD_NOT_INLINE -> true + | uu___7 -> false) flags) lcases in + if uu___1 + then (true, [FStarC_Syntax_Syntax.SHOULD_NOT_INLINE]) + else (false, []) in + match uu___ with + | (should_not_inline_whole_match, bind_cases_flags) -> + let bind_cases1 uu___1 = + let u_res_t = + env.FStarC_TypeChecker_Env.universe_of env res_t in + let uu___2 = + (FStarC_Options.lax ()) && (FStarC_Options.ml_ish ()) in + if uu___2 + then + let uu___3 = lax_mk_tot_or_comp_l eff u_res_t res_t [] in + (uu___3, FStarC_TypeChecker_Env.trivial_guard) + else + (let maybe_return eff_label_then cthen = + let uu___4 = + should_not_inline_whole_match || + (let uu___5 = is_pure_or_ghost_effect env eff in + Prims.op_Negation uu___5) in + if uu___4 then cthen true else cthen false in + let uu___4 = + let uu___5 = + FStarC_Compiler_List.map + (fun uu___6 -> + match uu___6 with + | (g, uu___7, uu___8, uu___9) -> g) lcases in + get_neg_branch_conds uu___5 in + match uu___4 with + | (neg_branch_conds, exhaustiveness_branch_cond) -> + let uu___5 = + match lcases with + | [] -> + let uu___6 = + comp_pure_wp_false env u_res_t res_t in + (FStar_Pervasives_Native.None, uu___6, + FStarC_TypeChecker_Env.trivial_guard) + | uu___6 -> + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Compiler_List.splitAt + ((FStarC_Compiler_List.length lcases) - + Prims.int_one) neg_branch_conds in + match uu___9 with + | (l1, l2) -> + let uu___10 = FStarC_Compiler_List.hd l2 in + (l1, uu___10) in + match uu___8 with + | (neg_branch_conds1, neg_last) -> + let uu___9 = + let uu___10 = + FStarC_Compiler_List.splitAt + ((FStarC_Compiler_List.length lcases) + - Prims.int_one) lcases in + match uu___10 with + | (l1, l2) -> + let uu___11 = + FStarC_Compiler_List.hd l2 in + (l1, uu___11) in + (match uu___9 with + | (lcases1, + (g_last, eff_last, uu___10, c_last)) + -> + let uu___11 = + let lc = + maybe_return eff_last c_last in + let uu___12 = + FStarC_TypeChecker_Common.lcomp_comp + lc in + match uu___12 with + | (c, g) -> + let uu___13 = + let uu___14 = + let uu___15 = + FStarC_Syntax_Util.b2t + g_last in + FStarC_Syntax_Util.mk_conj + uu___15 neg_last in + FStarC_TypeChecker_Common.weaken_guard_formula + g uu___14 in + (c, uu___13) in + (match uu___11 with + | (c, g) -> + let uu___12 = + let uu___13 = + FStarC_TypeChecker_Env.norm_eff_name + env eff_last in + FStarC_TypeChecker_Env.get_effect_decl + env uu___13 in + (lcases1, neg_branch_conds1, + uu___12, c, g))) in + (match uu___7 with + | (lcases1, neg_branch_conds1, md, comp, + g_comp) -> + FStarC_Compiler_List.fold_right2 + (fun uu___8 -> + fun neg_cond -> + fun uu___9 -> + match (uu___8, uu___9) with + | ((g, eff_label, uu___10, cthen), + (uu___11, celse, g_comp1)) -> + let uu___12 = + let uu___13 = + maybe_return eff_label + cthen in + FStarC_TypeChecker_Common.lcomp_comp + uu___13 in + (match uu___12 with + | (cthen1, g_then) -> + let uu___13 = + let uu___14 = + lift_comps_sep_guards + env cthen1 celse + FStar_Pervasives_Native.None + false in + match uu___14 with + | (m, cthen2, celse1, + g_lift_then, + g_lift_else) -> + let md1 = + FStarC_TypeChecker_Env.get_effect_decl + env m in + let uu___15 = + FStarC_TypeChecker_Env.comp_to_comp_typ + env cthen2 in + let uu___16 = + FStarC_TypeChecker_Env.comp_to_comp_typ + env celse1 in + (md1, uu___15, + uu___16, + g_lift_then, + g_lift_else) in + (match uu___13 with + | (md1, ct_then, + ct_else, g_lift_then, + g_lift_else) -> + let fn = + let uu___14 = + FStarC_Syntax_Util.is_layered + md1 in + if uu___14 + then + mk_layered_conjunction + else + mk_non_layered_conjunction in + let uu___14 = + let uu___15 = + FStarC_TypeChecker_Env.get_range + env in + fn env md1 u_res_t + res_t g ct_then + ct_else uu___15 in + (match uu___14 with + | (c, + g_conjunction) + -> + let uu___15 = + let g1 = + FStarC_Syntax_Util.b2t + g in + let uu___16 = + let uu___17 + = + FStarC_TypeChecker_Env.conj_guard + g_then + g_lift_then in + let uu___18 + = + FStarC_Syntax_Util.mk_conj + neg_cond + g1 in + FStarC_TypeChecker_Common.weaken_guard_formula + uu___17 + uu___18 in + let uu___17 = + let uu___18 + = + let uu___19 + = + FStarC_Syntax_Util.mk_neg + g1 in + FStarC_Syntax_Util.mk_conj + neg_cond + uu___19 in + FStarC_TypeChecker_Common.weaken_guard_formula + g_lift_else + uu___18 in + (uu___16, + uu___17) in + (match uu___15 + with + | (g_then1, + g_else) -> + let uu___16 + = + FStarC_TypeChecker_Env.conj_guards + [g_comp1; + g_then1; + g_else; + g_conjunction] in + ((FStar_Pervasives_Native.Some + md1), c, + uu___16)))))) + lcases1 neg_branch_conds1 + ((FStar_Pervasives_Native.Some md), comp, + g_comp)) in + (match uu___5 with + | (md, comp, g_comp) -> + let uu___6 = + let uu___7 = + let check = + FStarC_Syntax_Util.mk_imp + exhaustiveness_branch_cond + FStarC_Syntax_Util.t_false in + let check1 = + let uu___8 = + FStarC_TypeChecker_Env.get_range env in + label + FStarC_TypeChecker_Err.exhaustiveness_check + uu___8 check in + strengthen_comp env + FStar_Pervasives_Native.None comp check1 + bind_cases_flags in + match uu___7 with + | (c, g) -> + let uu___8 = + FStarC_TypeChecker_Env.conj_guard g_comp + g in + (c, uu___8) in + (match uu___6 with + | (comp1, g_comp1) -> + (match lcases with + | [] -> (comp1, g_comp1) + | uu___7::[] -> (comp1, g_comp1) + | uu___7 -> + let uu___8 = + let uu___9 = + FStarC_Compiler_Util.must md in + FStarC_Syntax_Util.is_layered uu___9 in + if uu___8 + then (comp1, g_comp1) + else + (let comp2 = + FStarC_TypeChecker_Env.comp_to_comp_typ + env comp1 in + let md1 = + FStarC_TypeChecker_Env.get_effect_decl + env + comp2.FStarC_Syntax_Syntax.effect_name in + let uu___10 = destruct_wp_comp comp2 in + match uu___10 with + | (uu___11, uu___12, wp) -> + let ite_wp = + let uu___13 = + FStarC_Syntax_Util.get_wp_ite_combinator + md1 in + FStarC_Compiler_Util.must + uu___13 in + let wp1 = + let uu___13 = + FStarC_TypeChecker_Env.inst_effect_fun_with + [u_res_t] env md1 ite_wp in + let uu___14 = + let uu___15 = + FStarC_Syntax_Syntax.as_arg + res_t in + let uu___16 = + let uu___17 = + FStarC_Syntax_Syntax.as_arg + wp in + [uu___17] in + uu___15 :: uu___16 in + FStarC_Syntax_Syntax.mk_Tm_app + uu___13 uu___14 + wp.FStarC_Syntax_Syntax.pos in + let uu___13 = + mk_comp md1 u_res_t res_t wp1 + bind_cases_flags in + (uu___13, g_comp1)))))) in + FStarC_TypeChecker_Common.mk_lcomp eff res_t bind_cases_flags + bind_cases1 +let (check_comp : + FStarC_TypeChecker_Env.env -> + Prims.bool -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.comp -> + FStarC_Syntax_Syntax.comp -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.comp * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun use_eq -> + fun e -> + fun c -> + fun c' -> + FStarC_Defensive.def_check_scoped + FStarC_TypeChecker_Env.hasBinders_env + FStarC_Class_Binders.hasNames_comp + FStarC_Syntax_Print.pretty_comp c.FStarC_Syntax_Syntax.pos + "check_comp.c" env c; + FStarC_Defensive.def_check_scoped + FStarC_TypeChecker_Env.hasBinders_env + FStarC_Class_Binders.hasNames_comp + FStarC_Syntax_Print.pretty_comp c'.FStarC_Syntax_Syntax.pos + "check_comp.c'" env c'; + (let uu___3 = FStarC_Compiler_Debug.extreme () in + if uu___3 + then + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_comp c in + let uu___6 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_comp c' in + FStarC_Compiler_Util.print4 + "Checking comp relation:\n%s has type %s\n\t %s \n%s\n" + uu___4 uu___5 (if use_eq then "$:" else "<:") uu___6 + else ()); + (let f = + if use_eq + then FStarC_TypeChecker_Rel.eq_comp + else FStarC_TypeChecker_Rel.sub_comp in + let uu___3 = f env c c' in + match uu___3 with + | FStar_Pervasives_Native.None -> + if use_eq + then + let uu___4 = FStarC_TypeChecker_Env.get_range env in + FStarC_TypeChecker_Err.computed_computation_type_does_not_match_annotation_eq + env uu___4 e c c' + else + (let uu___5 = FStarC_TypeChecker_Env.get_range env in + FStarC_TypeChecker_Err.computed_computation_type_does_not_match_annotation + env uu___5 e c c') + | FStar_Pervasives_Native.Some g -> (e, c', g)) +let (universe_of_comp : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.comp -> FStarC_Syntax_Syntax.universe) + = + fun env -> + fun u_res -> + fun c -> + let c_lid = + FStarC_TypeChecker_Env.norm_eff_name env + (FStarC_Syntax_Util.comp_effect_name c) in + let uu___ = FStarC_Syntax_Util.is_pure_or_ghost_effect c_lid in + if uu___ + then u_res + else + (let is_total = + let uu___2 = + FStarC_TypeChecker_Env.lookup_effect_quals env c_lid in + FStarC_Compiler_List.existsb + (fun q -> q = FStarC_Syntax_Syntax.TotalEffect) uu___2 in + if Prims.op_Negation is_total + then FStarC_Syntax_Syntax.U_zero + else + (let uu___3 = FStarC_TypeChecker_Env.effect_repr env c u_res in + match uu___3 with + | FStar_Pervasives_Native.None -> + let uu___4 = + let uu___5 = + FStarC_Class_Show.show FStarC_Ident.showable_lident + c_lid in + FStarC_Compiler_Util.format1 + "Effect %s is marked total but does not have a repr" + uu___5 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) c + FStarC_Errors_Codes.Fatal_EffectCannotBeReified () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4) + | FStar_Pervasives_Native.Some tm -> + env.FStarC_TypeChecker_Env.universe_of env tm)) +let (check_trivial_precondition_wp : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.comp -> + (FStarC_Syntax_Syntax.comp_typ * FStarC_Syntax_Syntax.formula * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun c -> + let ct = FStarC_TypeChecker_Env.unfold_effect_abbrev env c in + let md = + FStarC_TypeChecker_Env.get_effect_decl env + ct.FStarC_Syntax_Syntax.effect_name in + let uu___ = destruct_wp_comp ct in + match uu___ with + | (u_t, t, wp) -> + let vc = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Util.get_wp_trivial_combinator md in + FStarC_Compiler_Util.must uu___3 in + FStarC_TypeChecker_Env.inst_effect_fun_with [u_t] env md uu___2 in + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.as_arg t in + let uu___4 = + let uu___5 = FStarC_Syntax_Syntax.as_arg wp in [uu___5] in + uu___3 :: uu___4 in + let uu___3 = FStarC_TypeChecker_Env.get_range env in + FStarC_Syntax_Syntax.mk_Tm_app uu___1 uu___2 uu___3 in + let uu___1 = + FStarC_TypeChecker_Env.guard_of_guard_formula + (FStarC_TypeChecker_Common.NonTrivial vc) in + (ct, vc, uu___1) +let (maybe_lift : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Ident.lident -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.term) + = + fun env -> + fun e -> + fun c1 -> + fun c2 -> + fun t -> + let m1 = FStarC_TypeChecker_Env.norm_eff_name env c1 in + let m2 = FStarC_TypeChecker_Env.norm_eff_name env c2 in + let uu___ = + ((FStarC_Ident.lid_equals m1 m2) || + ((FStarC_Syntax_Util.is_pure_effect c1) && + (FStarC_Syntax_Util.is_ghost_effect c2))) + || + ((FStarC_Syntax_Util.is_pure_effect c2) && + (FStarC_Syntax_Util.is_ghost_effect c1)) in + if uu___ + then e + else + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 = e; + FStarC_Syntax_Syntax.meta = + (FStarC_Syntax_Syntax.Meta_monadic_lift (m1, m2, t)) + }) e.FStarC_Syntax_Syntax.pos +let (maybe_monadic : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.term) + = + fun env -> + fun e -> + fun c -> + fun t -> + let m = FStarC_TypeChecker_Env.norm_eff_name env c in + let uu___ = + ((is_pure_or_ghost_effect env m) || + (FStarC_Ident.lid_equals m FStarC_Parser_Const.effect_Tot_lid)) + || + (FStarC_Ident.lid_equals m FStarC_Parser_Const.effect_GTot_lid) in + if uu___ + then e + else + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_meta + { + FStarC_Syntax_Syntax.tm2 = e; + FStarC_Syntax_Syntax.meta = + (FStarC_Syntax_Syntax.Meta_monadic (m, t)) + }) e.FStarC_Syntax_Syntax.pos +let (coerce_with : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_TypeChecker_Common.lcomp -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.universes -> + FStarC_Syntax_Syntax.args -> + FStarC_Syntax_Syntax.comp -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.lcomp)) + = + fun env -> + fun e -> + fun lc -> + fun f -> + fun us -> + fun eargs -> + fun comp2 -> + let uu___ = FStarC_TypeChecker_Env.try_lookup_lid env f in + match uu___ with + | FStar_Pervasives_Native.Some uu___1 -> + ((let uu___3 = + FStarC_Compiler_Effect.op_Bang dbg_Coercions in + if uu___3 + then + let uu___4 = FStarC_Ident.string_of_lid f in + FStarC_Compiler_Util.print1 "Coercing with %s!\n" + uu___4 + else ()); + (let lc2 = FStarC_TypeChecker_Common.lcomp_of_comp comp2 in + let lc_res = + bind e.FStarC_Syntax_Syntax.pos env + (FStar_Pervasives_Native.Some e) lc + (FStar_Pervasives_Native.None, lc2) in + let coercion = + let uu___3 = + FStarC_Ident.set_lid_range f + e.FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.fvar uu___3 + FStar_Pervasives_Native.None in + let coercion1 = + FStarC_Syntax_Syntax.mk_Tm_uinst coercion us in + let e1 = + let uu___3 = + FStarC_TypeChecker_Common.is_pure_or_ghost_lcomp lc in + if uu___3 + then + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Syntax_Syntax.as_arg e in + [uu___6] in + FStarC_Compiler_List.op_At eargs uu___5 in + FStarC_Syntax_Syntax.mk_Tm_app coercion1 uu___4 + e.FStarC_Syntax_Syntax.pos + else + (let x = + FStarC_Syntax_Syntax.new_bv + (FStar_Pervasives_Native.Some + (e.FStarC_Syntax_Syntax.pos)) + lc.FStarC_TypeChecker_Common.res_typ in + let e2 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Syntax_Syntax.bv_to_name x in + FStarC_Syntax_Syntax.as_arg uu___8 in + [uu___7] in + FStarC_Compiler_List.op_At eargs uu___6 in + FStarC_Syntax_Syntax.mk_Tm_app coercion1 uu___5 + e.FStarC_Syntax_Syntax.pos in + let e3 = + maybe_lift env e + lc.FStarC_TypeChecker_Common.eff_name + lc_res.FStarC_TypeChecker_Common.eff_name + lc.FStarC_TypeChecker_Common.res_typ in + let e21 = + let uu___5 = + FStarC_TypeChecker_Env.push_bv env x in + maybe_lift uu___5 e2 + lc2.FStarC_TypeChecker_Common.eff_name + lc_res.FStarC_TypeChecker_Common.eff_name + lc2.FStarC_TypeChecker_Common.res_typ in + let lb = + FStarC_Syntax_Util.mk_letbinding + (FStar_Pervasives.Inl x) [] + lc.FStarC_TypeChecker_Common.res_typ + lc_res.FStarC_TypeChecker_Common.eff_name e3 + [] e3.FStarC_Syntax_Syntax.pos in + let e4 = + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Syntax_Syntax.mk_binder x in + [uu___9] in + FStarC_Syntax_Subst.close uu___8 e21 in + { + FStarC_Syntax_Syntax.lbs = (false, [lb]); + FStarC_Syntax_Syntax.body1 = uu___7 + } in + FStarC_Syntax_Syntax.Tm_let uu___6 in + FStarC_Syntax_Syntax.mk uu___5 + e3.FStarC_Syntax_Syntax.pos in + maybe_monadic env e4 + lc_res.FStarC_TypeChecker_Common.eff_name + lc_res.FStarC_TypeChecker_Common.res_typ) in + (e1, lc_res))) + | FStar_Pervasives_Native.None -> + ((let uu___2 = + let uu___3 = FStarC_Ident.string_of_lid f in + FStarC_Compiler_Util.format1 + "Coercion %s was not found in the environment, not coercing." + uu___3 in + FStarC_Errors.log_issue + (FStarC_Syntax_Syntax.has_range_syntax ()) e + FStarC_Errors_Codes.Warning_CoercionNotFound () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)); + (e, lc)) +type isErased = + | Yes of FStarC_Syntax_Syntax.term + | Maybe + | No +let (uu___is_Yes : isErased -> Prims.bool) = + fun projectee -> match projectee with | Yes _0 -> true | uu___ -> false +let (__proj__Yes__item___0 : isErased -> FStarC_Syntax_Syntax.term) = + fun projectee -> match projectee with | Yes _0 -> _0 +let (uu___is_Maybe : isErased -> Prims.bool) = + fun projectee -> match projectee with | Maybe -> true | uu___ -> false +let (uu___is_No : isErased -> Prims.bool) = + fun projectee -> match projectee with | No -> true | uu___ -> false +let rec (check_erased : + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.term -> isErased) = + fun env -> + fun t -> + let norm' = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.Exclude FStarC_TypeChecker_Env.Zeta; + FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.Unascribe; + FStarC_TypeChecker_Env.Unmeta; + FStarC_TypeChecker_Env.Unrefine; + FStarC_TypeChecker_Env.Weak; + FStarC_TypeChecker_Env.HNF; + FStarC_TypeChecker_Env.Iota] in + let t1 = norm' env t in + let uu___ = FStarC_Syntax_Util.head_and_args t1 in + match uu___ with + | (h, args) -> + let h1 = FStarC_Syntax_Util.un_uinst h in + let r = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress h1 in + uu___3.FStarC_Syntax_Syntax.n in + (uu___2, args) in + match uu___1 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, (a, uu___2)::[]) when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.erased_lid + -> Yes a + | (FStarC_Syntax_Syntax.Tm_uvar uu___2, uu___3) -> Maybe + | (FStarC_Syntax_Syntax.Tm_unknown, uu___2) -> Maybe + | (FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = uu___2; + FStarC_Syntax_Syntax.ret_opt = uu___3; + FStarC_Syntax_Syntax.brs = branches; + FStarC_Syntax_Syntax.rc_opt1 = uu___4;_}, + uu___5) -> + FStarC_Compiler_List.fold_left + (fun acc -> + fun br -> + match acc with + | Yes uu___6 -> Maybe + | Maybe -> Maybe + | No -> + let uu___6 = FStarC_Syntax_Subst.open_branch br in + (match uu___6 with + | (uu___7, uu___8, br_body) -> + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Syntax_Free.names br_body in + FStarC_Class_Setlike.elems () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Syntax_Syntax.ord_bv)) + (Obj.magic uu___12) in + FStarC_TypeChecker_Env.push_bvs env + uu___11 in + check_erased uu___10 br_body in + (match uu___9 with + | No -> No + | uu___10 -> Maybe))) No branches + | uu___2 -> No in + r +let rec first_opt : + 'a 'b . + ('a -> 'b FStar_Pervasives_Native.option) -> + 'a Prims.list -> 'b FStar_Pervasives_Native.option + = + fun f -> + fun xs -> + match xs with + | [] -> FStar_Pervasives_Native.None + | x::xs1 -> + let uu___ = f x in + FStarC_Compiler_Util.catch_opt uu___ + (fun uu___1 -> first_opt f xs1) +let op_let_Question : + 'uuuuu 'uuuuu1 . + unit -> + 'uuuuu FStar_Pervasives_Native.option -> + ('uuuuu -> 'uuuuu1 FStar_Pervasives_Native.option) -> + 'uuuuu1 FStar_Pervasives_Native.option + = fun uu___ -> FStarC_Compiler_Util.bind_opt +let (bool_guard : Prims.bool -> unit FStar_Pervasives_Native.option) = + fun b -> + if b + then FStar_Pervasives_Native.Some () + else FStar_Pervasives_Native.None +let (find_coercion : + FStarC_TypeChecker_Env.env -> + FStarC_TypeChecker_Common.lcomp -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.lcomp * + FStarC_TypeChecker_Env.guard_t) FStar_Pervasives_Native.option) + = + fun env -> + fun checked -> + fun exp_t -> + fun e -> + FStarC_Errors.with_ctx "find_coercion" + (fun uu___ -> + let is_type t = + let t1 = FStarC_TypeChecker_Normalize.unfold_whnf env t in + let t2 = FStarC_Syntax_Util.unrefine t1 in + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress t2 in + uu___2.FStarC_Syntax_Syntax.n in + match uu___1 with + | FStarC_Syntax_Syntax.Tm_type uu___2 -> true + | uu___2 -> false in + let rec head_of t = + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress t in + uu___2.FStarC_Syntax_Syntax.n in + match uu___1 with + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = t1; + FStarC_Syntax_Syntax.args = uu___2;_} + -> head_of t1 + | FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = t1; + FStarC_Syntax_Syntax.ret_opt = uu___2; + FStarC_Syntax_Syntax.brs = uu___3; + FStarC_Syntax_Syntax.rc_opt1 = uu___4;_} + -> head_of t1 + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = uu___2; + FStarC_Syntax_Syntax.body = t1; + FStarC_Syntax_Syntax.rc_opt = uu___3;_} + -> head_of t1 + | FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t1; + FStarC_Syntax_Syntax.asc = uu___2; + FStarC_Syntax_Syntax.eff_opt = uu___3;_} + -> head_of t1 + | FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t1; + FStarC_Syntax_Syntax.meta = uu___2;_} + -> head_of t1 + | FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = b; + FStarC_Syntax_Syntax.phi = uu___2;_} + -> head_of b.FStarC_Syntax_Syntax.sort + | uu___2 -> t in + let is_head_defined t = + let h = head_of t in + let h1 = FStarC_Syntax_Subst.compress h in + ((FStarC_Syntax_Syntax.uu___is_Tm_fvar + h1.FStarC_Syntax_Syntax.n) + || + (FStarC_Syntax_Syntax.uu___is_Tm_uinst + h1.FStarC_Syntax_Syntax.n)) + || + (FStarC_Syntax_Syntax.uu___is_Tm_type + h1.FStarC_Syntax_Syntax.n) in + let head_unfold env1 t = + FStarC_TypeChecker_Normalize.unfold_whnf' + [FStarC_TypeChecker_Env.Unascribe; + FStarC_TypeChecker_Env.Unmeta; + FStarC_TypeChecker_Env.Unrefine] env1 t in + let uu___1 = + let uu___2 = + (is_head_defined exp_t) && + (is_head_defined + checked.FStarC_TypeChecker_Common.res_typ) in + bool_guard uu___2 in + (op_let_Question ()) uu___1 + (fun uu___2 -> + let computed_t = + head_unfold env + checked.FStarC_TypeChecker_Common.res_typ in + let uu___3 = FStarC_Syntax_Util.head_and_args computed_t in + match uu___3 with + | (head, args) -> + let exp_t1 = head_unfold env exp_t in + let uu___4 = + let uu___5 = + let uu___6 = FStarC_Syntax_Util.un_uinst head in + uu___6.FStarC_Syntax_Syntax.n in + (uu___5, args) in + (match uu___4 with + | (FStarC_Syntax_Syntax.Tm_fvar fv, []) when + (FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.bool_lid) + && (is_type exp_t1) + -> + let lc2 = + let uu___5 = + FStarC_Syntax_Syntax.mk_Total + FStarC_Syntax_Util.ktype0 in + FStarC_TypeChecker_Common.lcomp_of_comp uu___5 in + let lc_res = + bind e.FStarC_Syntax_Syntax.pos env + (FStar_Pervasives_Native.Some e) checked + (FStar_Pervasives_Native.None, lc2) in + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Syntax_Syntax.fvar + FStarC_Parser_Const.b2t_lid + FStar_Pervasives_Native.None in + let uu___8 = + let uu___9 = FStarC_Syntax_Syntax.as_arg e in + [uu___9] in + FStarC_Syntax_Util.mk_app uu___7 uu___8 in + (uu___6, lc_res, + FStarC_TypeChecker_Env.trivial_guard) in + FStar_Pervasives_Native.Some uu___5 + | uu___5 -> + let head_lid_of t = + let uu___6 = + let uu___7 = + let uu___8 = head_of t in + FStarC_Syntax_Subst.compress uu___8 in + uu___7.FStarC_Syntax_Syntax.n in + match uu___6 with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let uu___7 = + FStarC_Syntax_Syntax.lid_of_fv fv in + FStar_Pervasives_Native.Some uu___7 + | FStarC_Syntax_Syntax.Tm_uinst + ({ + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Tm_fvar fv; + FStarC_Syntax_Syntax.pos = uu___7; + FStarC_Syntax_Syntax.vars = uu___8; + FStarC_Syntax_Syntax.hash_code = uu___9;_}, + uu___10) + -> + let uu___11 = + FStarC_Syntax_Syntax.lid_of_fv fv in + FStar_Pervasives_Native.Some uu___11 + | uu___7 -> FStar_Pervasives_Native.None in + let uu___6 = head_lid_of exp_t1 in + (op_let_Question ()) uu___6 + (fun exp_head_lid -> + let uu___7 = head_lid_of computed_t in + (op_let_Question ()) uu___7 + (fun computed_head_lid -> + let candidates = + FStarC_TypeChecker_Env.lookup_attr + env "FStar.Pervasives.coercion" in + first_opt + (fun se -> + let uu___8 = + match se.FStarC_Syntax_Syntax.sigel + with + | FStarC_Syntax_Syntax.Sig_let + { + FStarC_Syntax_Syntax.lbs1 + = (uu___9, lb::[]); + FStarC_Syntax_Syntax.lids1 + = uu___10;_} + -> + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Compiler_Util.right + lb.FStarC_Syntax_Syntax.lbname in + FStarC_Syntax_Syntax.lid_of_fv + uu___13 in + (uu___12, + (lb.FStarC_Syntax_Syntax.lbunivs), + (lb.FStarC_Syntax_Syntax.lbtyp)) in + FStar_Pervasives_Native.Some + uu___11 + | FStarC_Syntax_Syntax.Sig_declare_typ + { + FStarC_Syntax_Syntax.lid2 + = lid; + FStarC_Syntax_Syntax.us2 + = us; + FStarC_Syntax_Syntax.t2 = + t;_} + -> + FStar_Pervasives_Native.Some + (lid, us, t) + | uu___9 -> + FStar_Pervasives_Native.None in + (op_let_Question ()) uu___8 + (fun uu___9 -> + match uu___9 with + | (f_name, f_us, f_typ) -> + let uu___10 = + FStarC_Syntax_Subst.open_univ_vars + f_us f_typ in + (match uu___10 with + | (uu___11, f_typ1) -> + let uu___12 = + FStarC_Syntax_Util.arrow_formals_comp + f_typ1 in + (match uu___12 with + | (f_bs, f_c) -> + let uu___13 = + bool_guard + (f_bs <> + []) in + (op_let_Question + ()) uu___13 + (fun uu___14 + -> + let f_res + = + FStarC_Syntax_Util.comp_result + f_c in + let f_res1 + = + let uu___15 + = + FStarC_TypeChecker_Env.push_binders + env f_bs in + head_unfold + uu___15 + f_res in + let uu___15 + = + head_lid_of + f_res1 in + (op_let_Question + ()) + uu___15 + (fun + f_res_head_lid + -> + let uu___16 + = + let uu___17 + = + FStarC_Ident.lid_equals + exp_head_lid + f_res_head_lid in + bool_guard + uu___17 in + (op_let_Question + ()) + uu___16 + (fun + uu___17 + -> + let b = + FStarC_Compiler_List.last + f_bs in + let b_ty + = + (b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + let b_ty1 + = + let uu___18 + = + let uu___19 + = + FStarC_Compiler_List.init + f_bs in + FStarC_TypeChecker_Env.push_binders + env + uu___19 in + head_unfold + uu___18 + b_ty in + let uu___18 + = + head_lid_of + b_ty1 in + (op_let_Question + ()) + uu___18 + (fun + b_head_lid + -> + let uu___19 + = + let uu___20 + = + FStarC_Ident.lid_equals + computed_head_lid + b_head_lid in + bool_guard + uu___20 in + (op_let_Question + ()) + uu___19 + (fun + uu___20 + -> + let f_tm + = + FStarC_Syntax_Syntax.fvar + f_name + FStar_Pervasives_Native.None in + let tt = + let uu___21 + = + let uu___22 + = + FStarC_Syntax_Syntax.as_arg + e in + [uu___22] in + FStarC_Syntax_Util.mk_app + f_tm + uu___21 in + let uu___21 + = + env.FStarC_TypeChecker_Env.tc_term + { + FStarC_TypeChecker_Env.solver + = + (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range + = + (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule + = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma + = + (env.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig + = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache + = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules + = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ + = + (FStar_Pervasives_Native.Some + (exp_t1, + false)); + FStarC_TypeChecker_Env.sigtab + = + (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab + = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp + = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects + = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize + = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs + = + (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level + = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars + = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict + = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface + = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit + = true; + FStarC_TypeChecker_Env.lax_universes + = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 + = + (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard + = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking + = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping + = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics + = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce + = true; + FStarC_TypeChecker_Env.tc_term + = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term + = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of + = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term + = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force + = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force + = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index + = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names + = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths + = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns + = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook + = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook + = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice + = + (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess + = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess + = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info + = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks + = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv + = + (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe + = + (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab + = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab + = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac + = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards + = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args + = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check + = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl + = + (env.FStarC_TypeChecker_Env.missing_decl) + } tt in + FStar_Pervasives_Native.Some + uu___21))))))))) + candidates))))) +let (maybe_coerce_lc : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_TypeChecker_Common.lcomp -> + FStarC_Syntax_Syntax.typ -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.lcomp * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun e -> + fun lc -> + fun exp_t -> + let should_coerce = + (env.FStarC_TypeChecker_Env.phase1 || (FStarC_Options.lax ())) && + (Prims.op_Negation env.FStarC_TypeChecker_Env.nocoerce) in + if Prims.op_Negation should_coerce + then + ((let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_Coercions in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show + FStarC_Compiler_Range_Ops.showable_range + e.FStarC_Syntax_Syntax.pos in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + lc.FStarC_TypeChecker_Common.res_typ in + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + exp_t in + FStarC_Compiler_Util.print4 + "(%s) NOT Trying to coerce %s from type (%s) to type (%s)\n" + uu___2 uu___3 uu___4 uu___5 + else ()); + (e, lc, FStarC_TypeChecker_Env.trivial_guard)) + else + ((let uu___2 = FStarC_Compiler_Effect.op_Bang dbg_Coercions in + if uu___2 + then + let uu___3 = + FStarC_Class_Show.show + FStarC_Compiler_Range_Ops.showable_range + e.FStarC_Syntax_Syntax.pos in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + lc.FStarC_TypeChecker_Common.res_typ in + let uu___6 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term + exp_t in + FStarC_Compiler_Util.print4 + "(%s) Trying to coerce %s from type (%s) to type (%s)\n" + uu___3 uu___4 uu___5 uu___6 + else ()); + (let uu___2 = find_coercion env lc exp_t e in + match uu___2 with + | FStar_Pervasives_Native.Some (coerced, lc1, g) -> + ((let uu___4 = FStarC_Compiler_Effect.op_Bang dbg_Coercions in + if uu___4 + then + let uu___5 = + FStarC_Compiler_Range_Ops.string_of_range + e.FStarC_Syntax_Syntax.pos in + let uu___6 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term e in + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term coerced in + FStarC_Compiler_Util.print3 "(%s) COERCING %s to %s\n" + uu___5 uu___6 uu___7 + else ()); + (coerced, lc1, g)) + | FStar_Pervasives_Native.None -> + ((let uu___4 = FStarC_Compiler_Effect.op_Bang dbg_Coercions in + if uu___4 + then + let uu___5 = + FStarC_Compiler_Range_Ops.string_of_range + e.FStarC_Syntax_Syntax.pos in + FStarC_Compiler_Util.print1 + "(%s) No user coercion found\n" uu___5 + else ()); + (let strip_hide_or_reveal e1 hide_or_reveal = + let uu___4 = + FStarC_Syntax_Util.leftmost_head_and_args e1 in + match uu___4 with + | (hd, args) -> + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Syntax_Subst.compress hd in + uu___7.FStarC_Syntax_Syntax.n in + (uu___6, args) in + (match uu___5 with + | (FStarC_Syntax_Syntax.Tm_uinst (hd1, uu___6), + (uu___7, aq_t)::(e2, aq_e)::[]) when + (((FStarC_Syntax_Util.is_fvar hide_or_reveal + hd1) + && + (FStar_Pervasives_Native.uu___is_Some aq_t)) + && + (FStar_Pervasives_Native.__proj__Some__item__v + aq_t).FStarC_Syntax_Syntax.aqual_implicit) + && + ((aq_e = FStar_Pervasives_Native.None) || + (Prims.op_Negation + (FStar_Pervasives_Native.__proj__Some__item__v + aq_e).FStarC_Syntax_Syntax.aqual_implicit)) + -> FStar_Pervasives_Native.Some e2 + | uu___6 -> FStar_Pervasives_Native.None) in + let uu___4 = + let uu___5 = + check_erased env lc.FStarC_TypeChecker_Common.res_typ in + let uu___6 = check_erased env exp_t in (uu___5, uu___6) in + match uu___4 with + | (No, Yes ty) -> + let u = env.FStarC_TypeChecker_Env.universe_of env ty in + let uu___5 = + FStarC_TypeChecker_Rel.get_subtyping_predicate env + lc.FStarC_TypeChecker_Common.res_typ ty in + (match uu___5 with + | FStar_Pervasives_Native.None -> + (e, lc, FStarC_TypeChecker_Env.trivial_guard) + | FStar_Pervasives_Native.Some g -> + let g1 = FStarC_TypeChecker_Env.apply_guard g e in + let uu___6 = + let uu___7 = + let uu___8 = FStarC_Syntax_Syntax.iarg ty in + [uu___8] in + let uu___8 = + FStarC_Syntax_Syntax.mk_Total exp_t in + coerce_with env e lc FStarC_Parser_Const.hide + [u] uu___7 uu___8 in + (match uu___6 with + | (e_hide, lc1) -> + let e_hide1 = + let uu___7 = + strip_hide_or_reveal e + FStarC_Parser_Const.reveal in + FStarC_Compiler_Util.dflt e_hide uu___7 in + (e_hide1, lc1, g1))) + | (Yes ty, No) -> + let u = env.FStarC_TypeChecker_Env.universe_of env ty in + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Syntax_Syntax.iarg ty in + [uu___7] in + let uu___7 = FStarC_Syntax_Syntax.mk_GTotal ty in + coerce_with env e lc FStarC_Parser_Const.reveal + [u] uu___6 uu___7 in + (match uu___5 with + | (e_reveal, lc1) -> + let e_reveal1 = + let uu___6 = + strip_hide_or_reveal e + FStarC_Parser_Const.hide in + FStarC_Compiler_Util.dflt e_reveal uu___6 in + (e_reveal1, lc1, + FStarC_TypeChecker_Env.trivial_guard)) + | uu___5 -> (e, lc, FStarC_TypeChecker_Env.trivial_guard))))) +let (weaken_result_typ : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_TypeChecker_Common.lcomp -> + FStarC_Syntax_Syntax.typ -> + Prims.bool -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.lcomp * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun e -> + fun lc -> + fun t -> + fun use_eq -> + (let uu___1 = FStarC_Compiler_Debug.high () in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool) use_eq in + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + let uu___4 = FStarC_TypeChecker_Common.lcomp_to_string lc in + let uu___5 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.print4 + "weaken_result_typ use_eq=%s e=(%s) lc=(%s) t=(%s)\n" uu___2 + uu___3 uu___4 uu___5 + else ()); + (let use_eq1 = + (use_eq || env.FStarC_TypeChecker_Env.use_eq_strict) || + (let uu___1 = + FStarC_TypeChecker_Env.effect_decl_opt env + lc.FStarC_TypeChecker_Common.eff_name in + match uu___1 with + | FStar_Pervasives_Native.Some (ed, qualifiers) -> + FStarC_Compiler_List.contains + FStarC_Syntax_Syntax.Reifiable qualifiers + | uu___2 -> false) in + let gopt = + if use_eq1 + then + let uu___1 = + FStarC_TypeChecker_Rel.try_teq true env + lc.FStarC_TypeChecker_Common.res_typ t in + (uu___1, false) + else + (let uu___2 = + FStarC_TypeChecker_Rel.get_subtyping_predicate env + lc.FStarC_TypeChecker_Common.res_typ t in + (uu___2, true)) in + match gopt with + | (FStar_Pervasives_Native.None, uu___1) -> + if env.FStarC_TypeChecker_Env.failhard + then + FStarC_TypeChecker_Err.raise_basic_type_error env + e.FStarC_Syntax_Syntax.pos + (FStar_Pervasives_Native.Some e) t + lc.FStarC_TypeChecker_Common.res_typ + else + (FStarC_TypeChecker_Rel.subtype_fail env e + lc.FStarC_TypeChecker_Common.res_typ t; + (e, + { + FStarC_TypeChecker_Common.eff_name = + (lc.FStarC_TypeChecker_Common.eff_name); + FStarC_TypeChecker_Common.res_typ = t; + FStarC_TypeChecker_Common.cflags = + (lc.FStarC_TypeChecker_Common.cflags); + FStarC_TypeChecker_Common.comp_thunk = + (lc.FStarC_TypeChecker_Common.comp_thunk) + }, FStarC_TypeChecker_Env.trivial_guard)) + | (FStar_Pervasives_Native.Some g, apply_guard) -> + let uu___1 = FStarC_TypeChecker_Env.guard_form g in + (match uu___1 with + | FStarC_TypeChecker_Common.Trivial -> + let strengthen_trivial uu___2 = + let uu___3 = FStarC_TypeChecker_Common.lcomp_comp lc in + match uu___3 with + | (c, g_c) -> + let res_t = FStarC_Syntax_Util.comp_result c in + let set_result_typ c1 = + FStarC_Syntax_Util.set_result_typ c1 t in + let uu___4 = + let uu___5 = + FStarC_TypeChecker_TermEqAndSimplify.eq_tm + env t res_t in + uu___5 = + FStarC_TypeChecker_TermEqAndSimplify.Equal in + if uu___4 + then + ((let uu___6 = FStarC_Compiler_Debug.extreme () in + if uu___6 + then + let uu___7 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term res_t in + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.print2 + "weaken_result_type::strengthen_trivial: res_t:%s is same as t:%s\n" + uu___7 uu___8 + else ()); + (let uu___6 = set_result_typ c in + (uu___6, g_c))) + else + (let is_res_t_refinement = + let res_t1 = + FStarC_TypeChecker_Normalize.normalize_refinement + FStarC_TypeChecker_Normalize.whnf_steps + env res_t in + match res_t1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_refine uu___6 -> + true + | uu___6 -> false in + if is_res_t_refinement + then + let x = + FStarC_Syntax_Syntax.new_bv + (FStar_Pervasives_Native.Some + (res_t.FStarC_Syntax_Syntax.pos)) + res_t in + let uu___6 = + let uu___7 = + FStarC_TypeChecker_Env.norm_eff_name env + (FStarC_Syntax_Util.comp_effect_name c) in + let uu___8 = + FStarC_Syntax_Syntax.bv_to_name x in + return_value env uu___7 (comp_univ_opt c) + res_t uu___8 in + match uu___6 with + | (cret, gret) -> + let lc1 = + let uu___7 = + FStarC_TypeChecker_Common.lcomp_of_comp + c in + let uu___8 = + let uu___9 = + FStarC_TypeChecker_Common.lcomp_of_comp + cret in + ((FStar_Pervasives_Native.Some x), + uu___9) in + bind e.FStarC_Syntax_Syntax.pos env + (FStar_Pervasives_Native.Some e) + uu___7 uu___8 in + ((let uu___8 = + FStarC_Compiler_Debug.extreme () in + if uu___8 + then + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + e in + let uu___10 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_comp + c in + let uu___11 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + t in + let uu___12 = + FStarC_TypeChecker_Common.lcomp_to_string + lc1 in + FStarC_Compiler_Util.print4 + "weaken_result_type::strengthen_trivial: inserting a return for e: %s, c: %s, t: %s, and then post return lc: %s\n" + uu___9 uu___10 uu___11 uu___12 + else ()); + (let uu___8 = + FStarC_TypeChecker_Common.lcomp_comp + lc1 in + match uu___8 with + | (c1, g_lc) -> + let uu___9 = set_result_typ c1 in + let uu___10 = + FStarC_TypeChecker_Env.conj_guards + [g_c; gret; g_lc] in + (uu___9, uu___10))) + else + ((let uu___8 = + FStarC_Compiler_Debug.extreme () in + if uu___8 + then + let uu___9 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term + res_t in + let uu___10 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_comp c in + FStarC_Compiler_Util.print2 + "weaken_result_type::strengthen_trivial: res_t:%s is not a refinement, leaving c:%s as is\n" + uu___9 uu___10 + else ()); + (let uu___8 = set_result_typ c in + (uu___8, g_c)))) in + let lc1 = + FStarC_TypeChecker_Common.mk_lcomp + lc.FStarC_TypeChecker_Common.eff_name t + lc.FStarC_TypeChecker_Common.cflags + strengthen_trivial in + (e, lc1, g) + | FStarC_TypeChecker_Common.NonTrivial f -> + let g1 = + { + FStarC_TypeChecker_Common.guard_f = + FStarC_TypeChecker_Common.Trivial; + FStarC_TypeChecker_Common.deferred_to_tac = + (g.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (g.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (g.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = + (g.FStarC_TypeChecker_Common.implicits) + } in + let strengthen uu___2 = + let uu___3 = + (FStarC_Options.lax ()) && + (FStarC_Options.ml_ish ()) in + if uu___3 + then FStarC_TypeChecker_Common.lcomp_comp lc + else + (let f1 = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.Simplify; + FStarC_TypeChecker_Env.Primops] env f in + let uu___5 = + let uu___6 = FStarC_Syntax_Subst.compress f1 in + uu___6.FStarC_Syntax_Syntax.n in + match uu___5 with + | FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = uu___6; + FStarC_Syntax_Syntax.body = + { + FStarC_Syntax_Syntax.n = + FStarC_Syntax_Syntax.Tm_fvar fv; + FStarC_Syntax_Syntax.pos = uu___7; + FStarC_Syntax_Syntax.vars = uu___8; + FStarC_Syntax_Syntax.hash_code = uu___9;_}; + FStarC_Syntax_Syntax.rc_opt = uu___10;_} + when + FStarC_Syntax_Syntax.fv_eq_lid fv + FStarC_Parser_Const.true_lid + -> + let lc1 = + { + FStarC_TypeChecker_Common.eff_name = + (lc.FStarC_TypeChecker_Common.eff_name); + FStarC_TypeChecker_Common.res_typ = t; + FStarC_TypeChecker_Common.cflags = + (lc.FStarC_TypeChecker_Common.cflags); + FStarC_TypeChecker_Common.comp_thunk = + (lc.FStarC_TypeChecker_Common.comp_thunk) + } in + FStarC_TypeChecker_Common.lcomp_comp lc1 + | uu___6 -> + let uu___7 = + FStarC_TypeChecker_Common.lcomp_comp lc in + (match uu___7 with + | (c, g_c) -> + ((let uu___9 = + FStarC_Compiler_Debug.extreme () in + if uu___9 + then + let uu___10 = + FStarC_TypeChecker_Normalize.term_to_string + env + lc.FStarC_TypeChecker_Common.res_typ in + let uu___11 = + FStarC_TypeChecker_Normalize.term_to_string + env t in + let uu___12 = + FStarC_TypeChecker_Normalize.comp_to_string + env c in + let uu___13 = + FStarC_TypeChecker_Normalize.term_to_string + env f1 in + FStarC_Compiler_Util.print4 + "Weakened from %s to %s\nStrengthening %s with guard %s\n" + uu___10 uu___11 uu___12 uu___13 + else ()); + (let u_t_opt = comp_univ_opt c in + let x = + FStarC_Syntax_Syntax.new_bv + (FStar_Pervasives_Native.Some + (t.FStarC_Syntax_Syntax.pos)) t in + let xexp = + FStarC_Syntax_Syntax.bv_to_name x in + let uu___9 = + let uu___10 = + FStarC_TypeChecker_Env.norm_eff_name + env + (FStarC_Syntax_Util.comp_effect_name + c) in + return_value env uu___10 u_t_opt t + xexp in + match uu___9 with + | (cret, gret) -> + let guard = + if apply_guard + then + let uu___10 = + let uu___11 = + FStarC_Syntax_Syntax.as_arg + xexp in + [uu___11] in + FStarC_Syntax_Syntax.mk_Tm_app + f1 uu___10 + f1.FStarC_Syntax_Syntax.pos + else f1 in + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_TypeChecker_Env.push_bvs + env [x] in + FStarC_TypeChecker_Env.set_range + uu___12 + e.FStarC_Syntax_Syntax.pos in + let uu___12 = + FStarC_TypeChecker_Common.lcomp_of_comp + cret in + let uu___13 = + FStarC_TypeChecker_Env.guard_of_guard_formula + (FStarC_TypeChecker_Common.NonTrivial + guard) in + strengthen_precondition + (FStar_Pervasives_Native.Some + (FStarC_TypeChecker_Err.subtyping_failed + env + lc.FStarC_TypeChecker_Common.res_typ + t)) uu___11 e uu___12 + uu___13 in + (match uu___10 with + | (eq_ret, + _trivial_so_ok_to_discard) -> + let x1 = + { + FStarC_Syntax_Syntax.ppname + = + (x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index + = + (x.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort + = + (lc.FStarC_TypeChecker_Common.res_typ) + } in + let c1 = + let uu___11 = + FStarC_TypeChecker_Common.lcomp_of_comp + c in + bind + e.FStarC_Syntax_Syntax.pos + env + (FStar_Pervasives_Native.Some + e) uu___11 + ((FStar_Pervasives_Native.Some + x1), eq_ret) in + let uu___11 = + FStarC_TypeChecker_Common.lcomp_comp + c1 in + (match uu___11 with + | (c2, g_lc) -> + ((let uu___13 = + FStarC_Compiler_Debug.extreme + () in + if uu___13 + then + let uu___14 = + FStarC_TypeChecker_Normalize.comp_to_string + env c2 in + FStarC_Compiler_Util.print1 + "Strengthened to %s\n" + uu___14 + else ()); + (let uu___13 = + FStarC_TypeChecker_Env.conj_guards + [g_c; gret; g_lc] in + (c2, uu___13))))))))) in + let flags = + FStarC_Compiler_List.collect + (fun uu___2 -> + match uu___2 with + | FStarC_Syntax_Syntax.RETURN -> + [FStarC_Syntax_Syntax.PARTIAL_RETURN] + | FStarC_Syntax_Syntax.PARTIAL_RETURN -> + [FStarC_Syntax_Syntax.PARTIAL_RETURN] + | FStarC_Syntax_Syntax.CPS -> + [FStarC_Syntax_Syntax.CPS] + | uu___3 -> []) + lc.FStarC_TypeChecker_Common.cflags in + let lc1 = + let uu___2 = + FStarC_TypeChecker_Env.norm_eff_name env + lc.FStarC_TypeChecker_Common.eff_name in + FStarC_TypeChecker_Common.mk_lcomp uu___2 t flags + strengthen in + let g2 = + { + FStarC_TypeChecker_Common.guard_f = + FStarC_TypeChecker_Common.Trivial; + FStarC_TypeChecker_Common.deferred_to_tac = + (g1.FStarC_TypeChecker_Common.deferred_to_tac); + FStarC_TypeChecker_Common.deferred = + (g1.FStarC_TypeChecker_Common.deferred); + FStarC_TypeChecker_Common.univ_ineqs = + (g1.FStarC_TypeChecker_Common.univ_ineqs); + FStarC_TypeChecker_Common.implicits = + (g1.FStarC_TypeChecker_Common.implicits) + } in + (e, lc1, g2))) +let (pure_or_ghost_pre_and_post : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.comp -> + (FStarC_Syntax_Syntax.typ FStar_Pervasives_Native.option * + FStarC_Syntax_Syntax.typ)) + = + fun env -> + fun comp -> + let mk_post_type res_t ens = + let x = + FStarC_Syntax_Syntax.new_bv FStar_Pervasives_Native.None res_t in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = FStarC_Syntax_Syntax.bv_to_name x in + FStarC_Syntax_Syntax.as_arg uu___3 in + [uu___2] in + FStarC_Syntax_Syntax.mk_Tm_app ens uu___1 + res_t.FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Util.refine x uu___ in + let norm t = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.EraseUniverses] env t in + let uu___ = FStarC_Syntax_Util.is_tot_or_gtot_comp comp in + if uu___ + then + (FStar_Pervasives_Native.None, (FStarC_Syntax_Util.comp_result comp)) + else + (match comp.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.GTotal uu___2 -> failwith "Impossible" + | FStarC_Syntax_Syntax.Total uu___2 -> failwith "Impossible" + | FStarC_Syntax_Syntax.Comp ct -> + let uu___2 = + (FStarC_Ident.lid_equals ct.FStarC_Syntax_Syntax.effect_name + FStarC_Parser_Const.effect_Pure_lid) + || + (FStarC_Ident.lid_equals ct.FStarC_Syntax_Syntax.effect_name + FStarC_Parser_Const.effect_Ghost_lid) in + if uu___2 + then + (match ct.FStarC_Syntax_Syntax.effect_args with + | (req, uu___3)::(ens, uu___4)::uu___5 -> + let uu___6 = + let uu___7 = norm req in + FStar_Pervasives_Native.Some uu___7 in + let uu___7 = + let uu___8 = + mk_post_type ct.FStarC_Syntax_Syntax.result_typ ens in + norm uu___8 in + (uu___6, uu___7) + | uu___3 -> + let uu___4 = + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_comp comp in + FStarC_Compiler_Util.format1 + "Effect constructor is not fully applied; got %s" + uu___5 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) comp + FStarC_Errors_Codes.Fatal_EffectConstructorNotFullyApplied + () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___4)) + else + (let ct1 = + FStarC_TypeChecker_Env.unfold_effect_abbrev env comp in + match ct1.FStarC_Syntax_Syntax.effect_args with + | (wp, uu___4)::uu___5 -> + let uu___6 = + let uu___7 = + FStarC_TypeChecker_Env.lookup_lid env + FStarC_Parser_Const.as_requires in + FStar_Pervasives_Native.fst uu___7 in + (match uu___6 with + | (us_r, uu___7) -> + let uu___8 = + let uu___9 = + FStarC_TypeChecker_Env.lookup_lid env + FStarC_Parser_Const.as_ensures in + FStar_Pervasives_Native.fst uu___9 in + (match uu___8 with + | (us_e, uu___9) -> + let r = + (ct1.FStarC_Syntax_Syntax.result_typ).FStarC_Syntax_Syntax.pos in + let as_req = + let uu___10 = + let uu___11 = + FStarC_Ident.set_lid_range + FStarC_Parser_Const.as_requires r in + FStarC_Syntax_Syntax.fvar uu___11 + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.mk_Tm_uinst uu___10 us_r in + let as_ens = + let uu___10 = + let uu___11 = + FStarC_Ident.set_lid_range + FStarC_Parser_Const.as_ensures r in + FStarC_Syntax_Syntax.fvar uu___11 + FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.mk_Tm_uinst uu___10 us_e in + let req = + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Syntax_Syntax.as_aqual_implicit + true in + ((ct1.FStarC_Syntax_Syntax.result_typ), + uu___12) in + let uu___12 = + let uu___13 = + FStarC_Syntax_Syntax.as_arg wp in + [uu___13] in + uu___11 :: uu___12 in + FStarC_Syntax_Syntax.mk_Tm_app as_req uu___10 + (ct1.FStarC_Syntax_Syntax.result_typ).FStarC_Syntax_Syntax.pos in + let ens = + let uu___10 = + let uu___11 = + let uu___12 = + FStarC_Syntax_Syntax.as_aqual_implicit + true in + ((ct1.FStarC_Syntax_Syntax.result_typ), + uu___12) in + let uu___12 = + let uu___13 = + FStarC_Syntax_Syntax.as_arg wp in + [uu___13] in + uu___11 :: uu___12 in + FStarC_Syntax_Syntax.mk_Tm_app as_ens uu___10 + (ct1.FStarC_Syntax_Syntax.result_typ).FStarC_Syntax_Syntax.pos in + let uu___10 = + let uu___11 = norm req in + FStar_Pervasives_Native.Some uu___11 in + let uu___11 = + let uu___12 = + mk_post_type + ct1.FStarC_Syntax_Syntax.result_typ ens in + norm uu___12 in + (uu___10, uu___11))) + | uu___4 -> failwith "Impossible")) +let (norm_reify : + FStarC_TypeChecker_Env.env -> + FStarC_TypeChecker_Env.steps -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun env -> + fun steps -> + fun t -> + FStarC_Defensive.def_check_scoped + FStarC_TypeChecker_Env.hasBinders_env + FStarC_Class_Binders.hasNames_term FStarC_Syntax_Print.pretty_term + t.FStarC_Syntax_Syntax.pos "norm_reify" env t; + (let t' = + FStarC_TypeChecker_Normalize.normalize + (FStarC_Compiler_List.op_At + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.Reify; + FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.EraseUniverses; + FStarC_TypeChecker_Env.AllowUnboundUniverses; + FStarC_TypeChecker_Env.Exclude FStarC_TypeChecker_Env.Zeta] + steps) env t in + (let uu___2 = FStarC_Compiler_Effect.op_Bang dbg_SMTEncodingReify in + if uu___2 + then + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t' in + FStarC_Compiler_Util.print2 "Reified body %s \nto %s\n" uu___3 + uu___4 + else ()); + t') +let (remove_reify : FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) = + fun t -> + let uu___ = + let uu___1 = + let uu___2 = FStarC_Syntax_Subst.compress t in + uu___2.FStarC_Syntax_Syntax.n in + match uu___1 with + | FStarC_Syntax_Syntax.Tm_app uu___2 -> false + | uu___2 -> true in + if uu___ + then t + else + (let uu___2 = FStarC_Syntax_Util.head_and_args t in + match uu___2 with + | (head, args) -> + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Syntax_Subst.compress head in + uu___5.FStarC_Syntax_Syntax.n in + match uu___4 with + | FStarC_Syntax_Syntax.Tm_constant (FStarC_Const.Const_reify + uu___5) -> true + | uu___5 -> false in + if uu___3 + then + (match args with + | x::[] -> FStar_Pervasives_Native.fst x + | uu___4 -> + failwith + "Impossible : Reify applied to multiple arguments after normalization.") + else t) +let (maybe_implicit_with_meta_or_attr : + FStarC_Syntax_Syntax.bqual -> + FStarC_Syntax_Syntax.attribute Prims.list -> Prims.bool) + = + fun aq -> + fun attrs -> + match (aq, attrs) with + | (FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Meta uu___), + uu___1) -> true + | (FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Implicit uu___), + uu___1::uu___2) -> true + | uu___ -> false +let (instantiate_one_binder : + FStarC_TypeChecker_Env.env_t -> + FStarC_Compiler_Range_Type.range -> + FStarC_Syntax_Syntax.binder -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.typ * + FStarC_Syntax_Syntax.aqual * FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun r -> + fun b -> + (let uu___1 = FStarC_Compiler_Debug.high () in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_binder b in + FStarC_Compiler_Util.print1 + "instantiate_one_binder: Instantiating implicit binder %s\n" + uu___2 + else ()); + (let op_Plus_Plus = FStarC_TypeChecker_Env.conj_guard in + let uu___1 = b in + match uu___1 with + | { FStarC_Syntax_Syntax.binder_bv = x; + FStarC_Syntax_Syntax.binder_qual = uu___2; + FStarC_Syntax_Syntax.binder_positivity = uu___3; + FStarC_Syntax_Syntax.binder_attrs = uu___4;_} -> + let uu___5 = FStarC_TypeChecker_Env.uvar_meta_for_binder b in + (match uu___5 with + | (ctx_uvar_meta, should_unrefine) -> + let t = x.FStarC_Syntax_Syntax.sort in + let uu___6 = + let msg = + let is_typeclass = + match ctx_uvar_meta with + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Ctx_uvar_meta_tac tau) -> + FStarC_Syntax_Util.is_fvar + FStarC_Parser_Const.tcresolve_lid tau + | uu___7 -> false in + if is_typeclass + then "Typeclass constraint argument" + else + if FStar_Pervasives_Native.uu___is_Some ctx_uvar_meta + then "Instantiating meta argument" + else "Instantiating implicit argument" in + FStarC_TypeChecker_Env.new_implicit_var_aux msg r env t + FStarC_Syntax_Syntax.Strict ctx_uvar_meta + should_unrefine in + (match uu___6 with + | (varg, uu___7, implicits) -> + let aq = FStarC_Syntax_Util.aqual_of_binder b in + let arg = (varg, aq) in + let r1 = (varg, t, aq, implicits) in + ((let uu___9 = FStarC_Compiler_Debug.high () in + if uu___9 + then + let uu___10 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_tuple2 + FStarC_Syntax_Print.showable_term + FStarC_Syntax_Print.showable_term) + ((FStar_Pervasives_Native.__proj__Mktuple4__item___1 + r1), + (FStar_Pervasives_Native.__proj__Mktuple4__item___2 + r1)) in + FStarC_Compiler_Util.print1 + "instantiate_one_binder: result = %s\n" uu___10 + else ()); + r1)))) +let (maybe_instantiate : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.typ -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.typ * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun e -> + fun t -> + let torig = FStarC_Syntax_Subst.compress t in + if Prims.op_Negation env.FStarC_TypeChecker_Env.instantiate_imp + then + (e, torig, + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t)) + else + ((let uu___2 = FStarC_Compiler_Debug.high () in + if uu___2 + then + let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term e in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + let uu___5 = + let uu___6 = FStarC_TypeChecker_Env.expected_typ env in + FStarC_Class_Show.show + (FStarC_Class_Show.show_option + (FStarC_Class_Show.show_tuple2 + FStarC_Syntax_Print.showable_term + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_bool))) uu___6 in + FStarC_Compiler_Util.print3 + "maybe_instantiate: starting check for (%s) of type (%s), expected type is %s\n" + uu___3 uu___4 uu___5 + else ()); + (let unfolded_arrow_formals env1 t1 = + let rec aux env2 bs t2 = + let t3 = FStarC_TypeChecker_Normalize.unfold_whnf env2 t2 in + let uu___2 = FStarC_Syntax_Util.arrow_formals t3 in + match uu___2 with + | (bs', t4) -> + (match bs' with + | [] -> bs + | bs'1 -> + let uu___3 = + FStarC_TypeChecker_Env.push_binders env2 bs'1 in + aux uu___3 (FStarC_Compiler_List.op_At bs bs'1) t4) in + aux env1 [] t1 in + let number_of_implicits t1 = + let formals = unfolded_arrow_formals env t1 in + let n_implicits = + let uu___2 = + FStarC_Compiler_Util.prefix_until + (fun uu___3 -> + match uu___3 with + | { FStarC_Syntax_Syntax.binder_bv = uu___4; + FStarC_Syntax_Syntax.binder_qual = imp; + FStarC_Syntax_Syntax.binder_positivity = uu___5; + FStarC_Syntax_Syntax.binder_attrs = uu___6;_} -> + (FStarC_Compiler_Option.isNone imp) || + (FStarC_Syntax_Util.eq_bqual imp + (FStar_Pervasives_Native.Some + FStarC_Syntax_Syntax.Equality))) formals in + match uu___2 with + | FStar_Pervasives_Native.None -> + FStarC_Compiler_List.length formals + | FStar_Pervasives_Native.Some + (implicits, _first_explicit, _rest) -> + FStarC_Compiler_List.length implicits in + n_implicits in + let inst_n_binders t1 = + let uu___2 = FStarC_TypeChecker_Env.expected_typ env in + match uu___2 with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some (expected_t, uu___3) -> + let n_expected = number_of_implicits expected_t in + let n_available = number_of_implicits t1 in + if n_available < n_expected + then + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Errors_Msg.text "Expected a term with " in + let uu___7 = + let uu___8 = + FStarC_Class_PP.pp FStarC_Class_PP.pp_int + n_expected in + let uu___9 = + let uu___10 = + FStarC_Errors_Msg.text + " implicit arguments, but " in + let uu___11 = + let uu___12 = + FStarC_Class_PP.pp + FStarC_Syntax_Print.pretty_term e in + let uu___13 = + let uu___14 = + FStarC_Errors_Msg.text " has only " in + let uu___15 = + let uu___16 = + FStarC_Class_PP.pp FStarC_Class_PP.pp_int + n_available in + let uu___17 = FStarC_Errors_Msg.text "." in + FStarC_Pprint.op_Hat_Hat uu___16 uu___17 in + FStarC_Pprint.op_Hat_Slash_Hat uu___14 + uu___15 in + FStarC_Pprint.op_Hat_Slash_Hat uu___12 uu___13 in + FStarC_Pprint.op_Hat_Slash_Hat uu___10 uu___11 in + FStarC_Pprint.op_Hat_Slash_Hat uu___8 uu___9 in + FStarC_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in + [uu___5] in + FStarC_Errors.raise_error + FStarC_TypeChecker_Env.hasRange_env env + FStarC_Errors_Codes.Fatal_MissingImplicitArguments () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___4) + else + FStar_Pervasives_Native.Some (n_available - n_expected) in + let decr_inst uu___2 = + match uu___2 with + | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some i -> + FStar_Pervasives_Native.Some (i - Prims.int_one) in + let t1 = FStarC_TypeChecker_Normalize.unfold_whnf env t in + match t1.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = c;_} + -> + let uu___2 = FStarC_Syntax_Subst.open_comp bs c in + (match uu___2 with + | (bs1, c1) -> + let rec aux subst inst_n bs2 = + match (inst_n, bs2) with + | (FStar_Pervasives_Native.Some uu___3, uu___4) when + uu___3 = Prims.int_zero -> + ([], bs2, subst, + FStarC_TypeChecker_Env.trivial_guard) + | (uu___3, + { FStarC_Syntax_Syntax.binder_bv = uu___4; + FStarC_Syntax_Syntax.binder_qual = + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Implicit uu___5); + FStarC_Syntax_Syntax.binder_positivity = uu___6; + FStarC_Syntax_Syntax.binder_attrs = uu___7;_}::rest) + -> + let b = FStarC_Compiler_List.hd bs2 in + let b1 = FStarC_Syntax_Subst.subst_binder subst b in + let uu___8 = + instantiate_one_binder env + e.FStarC_Syntax_Syntax.pos b1 in + (match uu___8 with + | (tm, ty, aq, g) -> + let subst1 = + (FStarC_Syntax_Syntax.NT + ((b1.FStarC_Syntax_Syntax.binder_bv), + tm)) + :: subst in + let uu___9 = + aux subst1 (decr_inst inst_n) rest in + (match uu___9 with + | (args, bs3, subst2, g') -> + let uu___10 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g g' in + (((tm, aq) :: args), bs3, subst2, + uu___10))) + | (uu___3, + { FStarC_Syntax_Syntax.binder_bv = uu___4; + FStarC_Syntax_Syntax.binder_qual = + FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Meta uu___5); + FStarC_Syntax_Syntax.binder_positivity = uu___6; + FStarC_Syntax_Syntax.binder_attrs = uu___7;_}::rest) + -> + let b = FStarC_Compiler_List.hd bs2 in + let b1 = FStarC_Syntax_Subst.subst_binder subst b in + let uu___8 = + instantiate_one_binder env + e.FStarC_Syntax_Syntax.pos b1 in + (match uu___8 with + | (tm, ty, aq, g) -> + let subst1 = + (FStarC_Syntax_Syntax.NT + ((b1.FStarC_Syntax_Syntax.binder_bv), + tm)) + :: subst in + let uu___9 = + aux subst1 (decr_inst inst_n) rest in + (match uu___9 with + | (args, bs3, subst2, g') -> + let uu___10 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g g' in + (((tm, aq) :: args), bs3, subst2, + uu___10))) + | (uu___3, + { FStarC_Syntax_Syntax.binder_bv = uu___4; + FStarC_Syntax_Syntax.binder_qual = uu___5; + FStarC_Syntax_Syntax.binder_positivity = uu___6; + FStarC_Syntax_Syntax.binder_attrs = + uu___7::uu___8;_}::rest) + -> + let b = FStarC_Compiler_List.hd bs2 in + let b1 = FStarC_Syntax_Subst.subst_binder subst b in + let uu___9 = + instantiate_one_binder env + e.FStarC_Syntax_Syntax.pos b1 in + (match uu___9 with + | (tm, ty, aq, g) -> + let subst1 = + (FStarC_Syntax_Syntax.NT + ((b1.FStarC_Syntax_Syntax.binder_bv), + tm)) + :: subst in + let uu___10 = + aux subst1 (decr_inst inst_n) rest in + (match uu___10 with + | (args, bs3, subst2, g') -> + let uu___11 = + FStarC_Class_Monoid.op_Plus_Plus + FStarC_TypeChecker_Common.monoid_guard_t + g g' in + (((tm, aq) :: args), bs3, subst2, + uu___11))) + | (uu___3, bs3) -> + ([], bs3, subst, + (FStarC_Class_Monoid.mzero + FStarC_TypeChecker_Common.monoid_guard_t)) in + let uu___3 = + let uu___4 = inst_n_binders t1 in aux [] uu___4 bs1 in + (match uu___3 with + | (args, bs2, subst, guard) -> + (match (args, bs2) with + | ([], uu___4) -> (e, torig, guard) + | (uu___4, []) when + let uu___5 = + FStarC_Syntax_Util.is_total_comp c1 in + Prims.op_Negation uu___5 -> + (e, torig, + FStarC_TypeChecker_Env.trivial_guard) + | uu___4 -> + let t2 = + match bs2 with + | [] -> FStarC_Syntax_Util.comp_result c1 + | uu___5 -> FStarC_Syntax_Util.arrow bs2 c1 in + let t3 = FStarC_Syntax_Subst.subst subst t2 in + let e1 = + FStarC_Syntax_Syntax.mk_Tm_app e args + e.FStarC_Syntax_Syntax.pos in + (e1, t3, guard)))) + | uu___2 -> (e, torig, FStarC_TypeChecker_Env.trivial_guard))) +let (check_has_type : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.typ -> + Prims.bool -> FStarC_TypeChecker_Env.guard_t) + = + fun env -> + fun e -> + fun t1 -> + fun t2 -> + fun use_eq -> + let env1 = + FStarC_TypeChecker_Env.set_range env e.FStarC_Syntax_Syntax.pos in + let g_opt = + if env1.FStarC_TypeChecker_Env.use_eq_strict + then + let uu___ = FStarC_TypeChecker_Rel.teq_nosmt_force env1 t1 t2 in + (if uu___ + then + FStar_Pervasives_Native.Some + FStarC_TypeChecker_Env.trivial_guard + else FStar_Pervasives_Native.None) + else + if use_eq + then FStarC_TypeChecker_Rel.try_teq true env1 t1 t2 + else + (let uu___2 = + FStarC_TypeChecker_Rel.get_subtyping_predicate env1 t1 + t2 in + match uu___2 with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some f -> + let uu___3 = FStarC_TypeChecker_Env.apply_guard f e in + FStar_Pervasives_Native.Some uu___3) in + match g_opt with + | FStar_Pervasives_Native.None -> + let uu___ = FStarC_TypeChecker_Env.get_range env1 in + FStarC_TypeChecker_Err.expected_expression_of_type env1 uu___ + t2 e t1 + | FStar_Pervasives_Native.Some g -> g +let (check_has_type_maybe_coerce : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.term -> + FStarC_TypeChecker_Common.lcomp -> + FStarC_Syntax_Syntax.typ -> + Prims.bool -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Common.lcomp * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun e -> + fun lc -> + fun t2 -> + fun use_eq -> + let env1 = + FStarC_TypeChecker_Env.set_range env e.FStarC_Syntax_Syntax.pos in + let uu___ = maybe_coerce_lc env1 e lc t2 in + match uu___ with + | (e1, lc1, g_c) -> + let g = + check_has_type env1 e1 + lc1.FStarC_TypeChecker_Common.res_typ t2 use_eq in + ((let uu___2 = FStarC_Compiler_Effect.op_Bang dbg_Rel in + if uu___2 + then + let uu___3 = + FStarC_TypeChecker_Rel.guard_to_string env1 g in + FStarC_Compiler_Util.print1 "Applied guard is %s\n" + uu___3 + else ()); + (let uu___2 = FStarC_TypeChecker_Env.conj_guard g g_c in + (e1, lc1, uu___2))) +let (check_top_level : + FStarC_TypeChecker_Env.env -> + FStarC_TypeChecker_Env.guard_t -> + FStarC_TypeChecker_Common.lcomp -> + (Prims.bool * FStarC_Syntax_Syntax.comp)) + = + fun env -> + fun g -> + fun lc -> + FStarC_Errors.with_ctx "While checking for top-level effects" + (fun uu___ -> + (let uu___2 = FStarC_Compiler_Debug.medium () in + if uu___2 + then + let uu___3 = FStarC_TypeChecker_Common.lcomp_to_string lc in + FStarC_Compiler_Util.print1 "check_top_level, lc = %s\n" + uu___3 + else ()); + (let discharge g1 = + FStarC_TypeChecker_Rel.force_trivial_guard env g1; + FStarC_TypeChecker_Common.is_pure_lcomp lc in + let g1 = + FStarC_TypeChecker_Rel.solve_deferred_constraints env g in + let uu___2 = FStarC_TypeChecker_Common.lcomp_comp lc in + match uu___2 with + | (c, g_c) -> + let uu___3 = FStarC_TypeChecker_Common.is_total_lcomp lc in + if uu___3 + then + let uu___4 = + let uu___5 = FStarC_TypeChecker_Env.conj_guard g1 g_c in + discharge uu___5 in + (uu___4, c) + else + (let c1 = + FStarC_TypeChecker_Env.unfold_effect_abbrev env c in + let us = c1.FStarC_Syntax_Syntax.comp_univs in + let uu___5 = + FStarC_TypeChecker_Env.is_layered_effect env + c1.FStarC_Syntax_Syntax.effect_name in + if uu___5 + then + let c_eff = c1.FStarC_Syntax_Syntax.effect_name in + let ret_comp = FStarC_Syntax_Syntax.mk_Comp c1 in + let steps = + [FStarC_TypeChecker_Env.Eager_unfolding; + FStarC_TypeChecker_Env.Simplify; + FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.NoFullNorm] in + let c2 = + let uu___6 = FStarC_Syntax_Syntax.mk_Comp c1 in + FStarC_TypeChecker_Normalize.normalize_comp steps + env uu___6 in + let top_level_eff_opt = + FStarC_TypeChecker_Env.get_top_level_effect env + c_eff in + match top_level_eff_opt with + | FStar_Pervasives_Native.None -> + let uu___6 = FStarC_TypeChecker_Env.get_range env in + let uu___7 = + let uu___8 = FStarC_Ident.string_of_lid c_eff in + FStarC_Compiler_Util.format1 + "Indexed effect %s cannot be used as a top-level effect" + uu___8 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range uu___6 + FStarC_Errors_Codes.Fatal_UnexpectedEffect () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___7) + | FStar_Pervasives_Native.Some top_level_eff -> + let uu___6 = + FStarC_Ident.lid_equals top_level_eff c_eff in + (if uu___6 + then + let uu___7 = discharge g_c in + (uu___7, ret_comp) + else + (let bc_opt = + FStarC_TypeChecker_Env.lookup_effect_abbrev + env us top_level_eff in + match bc_opt with + | FStar_Pervasives_Native.None -> + let uu___8 = + let uu___9 = + FStarC_Ident.string_of_lid + top_level_eff in + let uu___10 = + FStarC_Ident.string_of_lid c_eff in + FStarC_Compiler_Util.format2 + "Could not find top-level effect abbreviation %s for %s" + uu___9 uu___10 in + FStarC_Errors.raise_error + FStarC_TypeChecker_Env.hasRange_env env + FStarC_Errors_Codes.Fatal_UnexpectedEffect + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___8) + | FStar_Pervasives_Native.Some (bs, uu___8) -> + let debug = + FStarC_Compiler_Effect.op_Bang + dbg_LayeredEffectsApp in + let uu___9 = + FStarC_Syntax_Subst.open_binders bs in + (match uu___9 with + | a::bs1 -> + let uu___10 = + let uu___11 = + FStarC_TypeChecker_Env.get_range + env in + FStarC_TypeChecker_Env.uvars_for_binders + env bs1 + [FStarC_Syntax_Syntax.NT + ((a.FStarC_Syntax_Syntax.binder_bv), + (FStarC_Syntax_Util.comp_result + c2))] + (fun b -> + if debug + then + let uu___12 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_binder + b in + let uu___13 = + FStarC_Ident.string_of_lid + top_level_eff in + FStarC_Compiler_Util.format2 + "implicit for binder %s in effect abbreviation %s while checking top-level effect" + uu___12 uu___13 + else "check_top_level") + uu___11 in + (match uu___10 with + | (uvs, g_uvs) -> + let top_level_comp = + let uu___11 = + let uu___12 = + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.as_arg + uvs in + { + FStarC_Syntax_Syntax.comp_univs + = us; + FStarC_Syntax_Syntax.effect_name + = top_level_eff; + FStarC_Syntax_Syntax.result_typ + = + (FStarC_Syntax_Util.comp_result + c2); + FStarC_Syntax_Syntax.effect_args + = uu___12; + FStarC_Syntax_Syntax.flags + = [] + } in + FStarC_Syntax_Syntax.mk_Comp + uu___11 in + let gopt = + FStarC_TypeChecker_Rel.eq_comp + env top_level_comp c2 in + (match gopt with + | FStar_Pervasives_Native.None + -> + let uu___11 = + let uu___12 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_comp + top_level_comp in + let uu___13 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_comp + c2 in + FStarC_Compiler_Util.format2 + "Could not unify %s and %s when checking top-level effect" + uu___12 uu___13 in + FStarC_Errors.raise_error + FStarC_TypeChecker_Env.hasRange_env + env + FStarC_Errors_Codes.Fatal_UnexpectedEffect + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___11) + | FStar_Pervasives_Native.Some + g2 -> + let uu___11 = + let uu___12 = + FStarC_TypeChecker_Env.conj_guards + [g_c; g_uvs; g2] in + discharge uu___12 in + (uu___11, ret_comp)))))) + else + (let steps = + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.NoFullNorm; + FStarC_TypeChecker_Env.DoNotUnfoldPureLets] in + let c2 = + let uu___7 = FStarC_Syntax_Syntax.mk_Comp c1 in + FStarC_TypeChecker_Normalize.normalize_comp steps + env uu___7 in + let uu___7 = check_trivial_precondition_wp env c2 in + match uu___7 with + | (ct, vc, g_pre) -> + ((let uu___9 = + FStarC_Compiler_Effect.op_Bang + dbg_Simplification in + if uu___9 + then + let uu___10 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term vc in + FStarC_Compiler_Util.print1 + "top-level VC: %s\n" uu___10 + else ()); + (let uu___9 = + let uu___10 = + let uu___11 = + FStarC_TypeChecker_Env.conj_guard g_c + g_pre in + FStarC_TypeChecker_Env.conj_guard g1 + uu___11 in + discharge uu___10 in + let uu___10 = FStarC_Syntax_Syntax.mk_Comp ct in + (uu___9, uu___10))))))) +let (short_circuit : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.args -> FStarC_TypeChecker_Common.guard_formula) + = + fun head -> + fun seen_args -> + let short_bin_op f uu___ = + match uu___ with + | [] -> FStarC_TypeChecker_Common.Trivial + | (fst, uu___1)::[] -> f fst + | uu___1 -> failwith "Unexpected args to binary operator" in + let op_and_e e = + let uu___ = FStarC_Syntax_Util.b2t e in + FStarC_TypeChecker_Common.NonTrivial uu___ in + let op_or_e e = + let uu___ = + let uu___1 = FStarC_Syntax_Util.b2t e in + FStarC_Syntax_Util.mk_neg uu___1 in + FStarC_TypeChecker_Common.NonTrivial uu___ in + let op_and_t t = FStarC_TypeChecker_Common.NonTrivial t in + let op_or_t t = + let uu___ = FStarC_Syntax_Util.mk_neg t in + FStarC_TypeChecker_Common.NonTrivial uu___ in + let op_imp_t t = FStarC_TypeChecker_Common.NonTrivial t in + let short_op_ite uu___ = + match uu___ with + | [] -> FStarC_TypeChecker_Common.Trivial + | (guard, uu___1)::[] -> FStarC_TypeChecker_Common.NonTrivial guard + | _then::(guard, uu___1)::[] -> + let uu___2 = FStarC_Syntax_Util.mk_neg guard in + FStarC_TypeChecker_Common.NonTrivial uu___2 + | uu___1 -> failwith "Unexpected args to ITE" in + let table = + let uu___ = + let uu___1 = short_bin_op op_and_e in + (FStarC_Parser_Const.op_And, uu___1) in + let uu___1 = + let uu___2 = + let uu___3 = short_bin_op op_or_e in + (FStarC_Parser_Const.op_Or, uu___3) in + let uu___3 = + let uu___4 = + let uu___5 = short_bin_op op_and_t in + (FStarC_Parser_Const.and_lid, uu___5) in + let uu___5 = + let uu___6 = + let uu___7 = short_bin_op op_or_t in + (FStarC_Parser_Const.or_lid, uu___7) in + let uu___7 = + let uu___8 = + let uu___9 = short_bin_op op_imp_t in + (FStarC_Parser_Const.imp_lid, uu___9) in + [uu___8; (FStarC_Parser_Const.ite_lid, short_op_ite)] in + uu___6 :: uu___7 in + uu___4 :: uu___5 in + uu___2 :: uu___3 in + uu___ :: uu___1 in + match head.FStarC_Syntax_Syntax.n with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + let lid = (fv.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + let uu___ = + FStarC_Compiler_Util.find_map table + (fun uu___1 -> + match uu___1 with + | (x, mk) -> + let uu___2 = FStarC_Ident.lid_equals x lid in + if uu___2 + then + let uu___3 = mk seen_args in + FStar_Pervasives_Native.Some uu___3 + else FStar_Pervasives_Native.None) in + (match uu___ with + | FStar_Pervasives_Native.None -> + FStarC_TypeChecker_Common.Trivial + | FStar_Pervasives_Native.Some g -> g) + | uu___ -> FStarC_TypeChecker_Common.Trivial +let (short_circuit_head : FStarC_Syntax_Syntax.term -> Prims.bool) = + fun l -> + let uu___ = + let uu___1 = FStarC_Syntax_Util.un_uinst l in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_fvar fv -> + FStarC_Compiler_Util.for_some (FStarC_Syntax_Syntax.fv_eq_lid fv) + [FStarC_Parser_Const.op_And; + FStarC_Parser_Const.op_Or; + FStarC_Parser_Const.and_lid; + FStarC_Parser_Const.or_lid; + FStarC_Parser_Const.imp_lid; + FStarC_Parser_Const.ite_lid] + | uu___1 -> false +let (maybe_add_implicit_binders : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.binders -> FStarC_Syntax_Syntax.binders) + = + fun env -> + fun bs -> + let is_implicit_binder uu___ = + match uu___ with + | { FStarC_Syntax_Syntax.binder_bv = uu___1; + FStarC_Syntax_Syntax.binder_qual = q; + FStarC_Syntax_Syntax.binder_positivity = uu___2; + FStarC_Syntax_Syntax.binder_attrs = uu___3;_} -> + (match q with + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Implicit + uu___4) -> true + | FStar_Pervasives_Native.Some (FStarC_Syntax_Syntax.Meta + uu___4) -> true + | uu___4 -> false) in + let pos bs1 = + match bs1 with + | { FStarC_Syntax_Syntax.binder_bv = hd; + FStarC_Syntax_Syntax.binder_qual = uu___; + FStarC_Syntax_Syntax.binder_positivity = uu___1; + FStarC_Syntax_Syntax.binder_attrs = uu___2;_}::uu___3 -> + FStarC_Syntax_Syntax.range_of_bv hd + | uu___ -> FStarC_TypeChecker_Env.get_range env in + match bs with + | b::uu___ when is_implicit_binder b -> bs + | uu___ -> + let uu___1 = FStarC_TypeChecker_Env.expected_typ env in + (match uu___1 with + | FStar_Pervasives_Native.None -> bs + | FStar_Pervasives_Native.Some (t, uu___2) -> + let uu___3 = + let uu___4 = FStarC_Syntax_Subst.compress t in + uu___4.FStarC_Syntax_Syntax.n in + (match uu___3 with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs'; + FStarC_Syntax_Syntax.comp = uu___4;_} + -> + let uu___5 = + FStarC_Compiler_Util.prefix_until + (fun b -> + let uu___6 = is_implicit_binder b in + Prims.op_Negation uu___6) bs' in + (match uu___5 with + | FStar_Pervasives_Native.None -> bs + | FStar_Pervasives_Native.Some ([], uu___6, uu___7) -> + bs + | FStar_Pervasives_Native.Some (imps, uu___6, uu___7) -> + let r = pos bs in + let imps1 = + FStarC_Compiler_List.map + (fun b -> + let uu___8 = + FStarC_Syntax_Syntax.set_range_of_bv + b.FStarC_Syntax_Syntax.binder_bv r in + { + FStarC_Syntax_Syntax.binder_bv = uu___8; + FStarC_Syntax_Syntax.binder_qual = + (b.FStarC_Syntax_Syntax.binder_qual); + FStarC_Syntax_Syntax.binder_positivity = + (b.FStarC_Syntax_Syntax.binder_positivity); + FStarC_Syntax_Syntax.binder_attrs = + (b.FStarC_Syntax_Syntax.binder_attrs) + }) imps in + FStarC_Compiler_List.op_At imps1 bs) + | uu___4 -> bs)) +let (must_erase_for_extraction : + FStarC_TypeChecker_Env.env -> FStarC_Syntax_Syntax.term -> Prims.bool) = + fun g -> + fun t -> + let rec descend env t1 = + let uu___ = + let uu___1 = FStarC_Syntax_Subst.compress t1 in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_arrow uu___1 -> + let uu___2 = FStarC_Syntax_Util.arrow_formals_comp t1 in + (match uu___2 with + | (bs, c) -> + let env1 = FStarC_TypeChecker_Env.push_binders env bs in + (FStarC_TypeChecker_Env.is_erasable_effect env1 + (FStarC_Syntax_Util.comp_effect_name c)) + || + ((FStarC_Syntax_Util.is_pure_or_ghost_comp c) && + (aux env1 (FStarC_Syntax_Util.comp_result c)))) + | FStarC_Syntax_Syntax.Tm_refine + { + FStarC_Syntax_Syntax.b = + { FStarC_Syntax_Syntax.ppname = uu___1; + FStarC_Syntax_Syntax.index = uu___2; + FStarC_Syntax_Syntax.sort = t2;_}; + FStarC_Syntax_Syntax.phi = uu___3;_} + -> aux env t2 + | FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = head; + FStarC_Syntax_Syntax.args = uu___1;_} + -> descend env head + | FStarC_Syntax_Syntax.Tm_uinst (head, uu___1) -> descend env head + | FStarC_Syntax_Syntax.Tm_fvar fv -> + FStarC_TypeChecker_Env.fv_has_attr env fv + FStarC_Parser_Const.must_erase_for_extraction_attr + | uu___1 -> false + and aux env t1 = + let t2 = + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.Weak; + FStarC_TypeChecker_Env.HNF; + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.AllowUnboundUniverses; + FStarC_TypeChecker_Env.Zeta; + FStarC_TypeChecker_Env.Iota; + FStarC_TypeChecker_Env.Unascribe] env t1 in + let res = + (FStarC_TypeChecker_Env.non_informative env t2) || (descend env t2) in + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_Extraction in + if uu___1 + then + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t2 in + FStarC_Compiler_Util.print2 "must_erase=%s: %s\n" + (if res then "true" else "false") uu___2 + else ()); + res in + aux g t +let (effect_extraction_mode : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident -> FStarC_Syntax_Syntax.eff_extraction_mode) + = + fun env -> + fun l -> + let uu___ = + let uu___1 = FStarC_TypeChecker_Env.norm_eff_name env l in + FStarC_TypeChecker_Env.get_effect_decl env uu___1 in + uu___.FStarC_Syntax_Syntax.extraction_mode +let (fresh_effect_repr : + FStarC_TypeChecker_Env.env -> + FStarC_Compiler_Range_Type.range -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.tscheme -> + FStarC_Syntax_Syntax.tscheme FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun r -> + fun eff_name -> + fun signature_ts -> + fun repr_ts_opt -> + fun u -> + fun a_tm -> + let fail t = + FStarC_TypeChecker_Err.unexpected_signature_for_monad env r + eff_name t in + let uu___ = FStarC_TypeChecker_Env.inst_tscheme signature_ts in + match uu___ with + | (uu___1, signature) -> + let debug = + FStarC_Compiler_Effect.op_Bang dbg_LayeredEffectsApp in + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress signature in + uu___3.FStarC_Syntax_Syntax.n in + (match uu___2 with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = uu___3;_} + -> + let bs1 = FStarC_Syntax_Subst.open_binders bs in + (match bs1 with + | a::bs2 -> + let uu___4 = + FStarC_TypeChecker_Env.uvars_for_binders env + bs2 + [FStarC_Syntax_Syntax.NT + ((a.FStarC_Syntax_Syntax.binder_bv), + a_tm)] + (fun b -> + if debug + then + let uu___5 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_binder + b in + let uu___6 = + FStarC_Ident.string_of_lid eff_name in + let uu___7 = + FStarC_Compiler_Range_Ops.string_of_range + r in + FStarC_Compiler_Util.format3 + "uvar for binder %s when creating a fresh repr for %s at %s" + uu___5 uu___6 uu___7 + else "fresh_effect_repr") r in + (match uu___4 with + | (is, g) -> + let uu___5 = + match repr_ts_opt with + | FStar_Pervasives_Native.None -> + let eff_c = + let uu___6 = + let uu___7 = + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.as_arg + is in + { + FStarC_Syntax_Syntax.comp_univs + = [u]; + FStarC_Syntax_Syntax.effect_name + = eff_name; + FStarC_Syntax_Syntax.result_typ + = a_tm; + FStarC_Syntax_Syntax.effect_args + = uu___7; + FStarC_Syntax_Syntax.flags = + [] + } in + FStarC_Syntax_Syntax.mk_Comp + uu___6 in + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Syntax_Syntax.null_binder + FStarC_Syntax_Syntax.t_unit in + [uu___9] in + { + FStarC_Syntax_Syntax.bs1 = + uu___8; + FStarC_Syntax_Syntax.comp = + eff_c + } in + FStarC_Syntax_Syntax.Tm_arrow + uu___7 in + FStarC_Syntax_Syntax.mk uu___6 r + | FStar_Pervasives_Native.Some repr_ts + -> + let repr = + let uu___6 = + FStarC_TypeChecker_Env.inst_tscheme_with + repr_ts [u] in + FStar_Pervasives_Native.snd uu___6 in + let is_args = + FStarC_Compiler_List.map2 + (fun i -> + fun b -> + let uu___6 = + FStarC_Syntax_Util.aqual_of_binder + b in + (i, uu___6)) is bs2 in + let uu___6 = + let uu___7 = + FStarC_Syntax_Syntax.as_arg a_tm in + uu___7 :: is_args in + FStarC_Syntax_Syntax.mk_Tm_app repr + uu___6 r in + (uu___5, g)) + | uu___4 -> fail signature) + | uu___3 -> fail signature) +let (fresh_effect_repr_en : + FStarC_TypeChecker_Env.env -> + FStarC_Compiler_Range_Type.range -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.term -> + (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun r -> + fun eff_name -> + fun u -> + fun a_tm -> + let uu___ = FStarC_TypeChecker_Env.get_effect_decl env eff_name in + let uu___1 = + FStarC_Syntax_Util.effect_sig_ts + uu___.FStarC_Syntax_Syntax.signature in + let uu___2 = FStarC_Syntax_Util.get_eff_repr uu___ in + fresh_effect_repr env r eff_name uu___1 uu___2 u a_tm +let (layered_effect_indices_as_binders : + FStarC_TypeChecker_Env.env -> + FStarC_Compiler_Range_Type.range -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.tscheme -> + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.binders) + = + fun env -> + fun r -> + fun eff_name -> + fun sig_ts -> + fun u -> + fun a_tm -> + let uu___ = FStarC_TypeChecker_Env.inst_tscheme_with sig_ts [u] in + match uu___ with + | (uu___1, sig_tm) -> + let fail t = + FStarC_TypeChecker_Err.unexpected_signature_for_monad env + r eff_name t in + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress sig_tm in + uu___3.FStarC_Syntax_Syntax.n in + (match uu___2 with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = uu___3;_} + -> + let bs1 = FStarC_Syntax_Subst.open_binders bs in + (match bs1 with + | { FStarC_Syntax_Syntax.binder_bv = a'; + FStarC_Syntax_Syntax.binder_qual = uu___4; + FStarC_Syntax_Syntax.binder_positivity = uu___5; + FStarC_Syntax_Syntax.binder_attrs = uu___6;_}::bs2 + -> + FStarC_Syntax_Subst.subst_binders + [FStarC_Syntax_Syntax.NT (a', a_tm)] bs2 + | uu___4 -> fail sig_tm) + | uu___3 -> fail sig_tm) +let (check_non_informative_type_for_lift : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.term -> FStarC_Compiler_Range_Type.range -> unit) + = + fun env -> + fun m1 -> + fun m2 -> + fun t -> + fun r -> + let uu___ = + ((FStarC_TypeChecker_Env.is_erasable_effect env m1) && + (let uu___1 = + FStarC_TypeChecker_Env.is_erasable_effect env m2 in + Prims.op_Negation uu___1)) + && + (let uu___1 = + FStarC_TypeChecker_Normalize.non_info_norm env t in + Prims.op_Negation uu___1) in + if uu___ + then + let uu___1 = + let uu___2 = FStarC_Ident.string_of_lid m1 in + let uu___3 = FStarC_Ident.string_of_lid m2 in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t in + FStarC_Compiler_Util.format3 + "Cannot lift erasable expression from %s ~> %s since its type %s is informative" + uu___2 uu___3 uu___4 in + FStarC_Errors.raise_error FStarC_Class_HasRange.hasRange_range + r FStarC_Errors_Codes.Error_TypeError () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) + else () +let (substitutive_indexed_lift_substs : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.comp_typ -> + Prims.string -> + FStarC_Compiler_Range_Type.range -> + (FStarC_Syntax_Syntax.subst_elt Prims.list * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun bs -> + fun ct -> + fun lift_name -> + fun r -> + let debug = FStarC_Compiler_Effect.op_Bang dbg_LayeredEffectsApp in + let uu___ = + let uu___1 = bs in + match uu___1 with + | a_b::bs1 -> + (bs1, + [FStarC_Syntax_Syntax.NT + ((a_b.FStarC_Syntax_Syntax.binder_bv), + (ct.FStarC_Syntax_Syntax.result_typ))]) in + match uu___ with + | (bs1, subst) -> + let uu___1 = + let m_num_effect_args = + FStarC_Compiler_List.length + ct.FStarC_Syntax_Syntax.effect_args in + let uu___2 = + FStarC_Compiler_List.splitAt m_num_effect_args bs1 in + match uu___2 with + | (f_bs, bs2) -> + let f_subst = + FStarC_Compiler_List.map2 + (fun f_b -> + fun uu___3 -> + match uu___3 with + | (arg, uu___4) -> + FStarC_Syntax_Syntax.NT + ((f_b.FStarC_Syntax_Syntax.binder_bv), + arg)) f_bs + ct.FStarC_Syntax_Syntax.effect_args in + (bs2, (FStarC_Compiler_List.op_At subst f_subst)) in + (match uu___1 with + | (bs2, subst1) -> + let bs3 = + let uu___2 = + FStarC_Compiler_List.splitAt + ((FStarC_Compiler_List.length bs2) - Prims.int_one) + bs2 in + FStar_Pervasives_Native.fst uu___2 in + FStarC_Compiler_List.fold_left + (fun uu___2 -> + fun b -> + match uu___2 with + | (subst2, g) -> + let uu___3 = + FStarC_TypeChecker_Env.uvars_for_binders + env [b] subst2 + (fun b1 -> + if debug + then + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_binder + b1 in + let uu___5 = + FStarC_Compiler_Range_Ops.string_of_range + r in + FStarC_Compiler_Util.format3 + "implicit var for additional lift binder %s of %s at %s)" + uu___4 lift_name uu___5 + else + "substitutive_indexed_lift_substs") + r in + (match uu___3 with + | (uv_t::[], g_uv) -> + let uu___4 = + FStarC_TypeChecker_Env.conj_guard g + g_uv in + ((FStarC_Compiler_List.op_At subst2 + [FStarC_Syntax_Syntax.NT + ((b.FStarC_Syntax_Syntax.binder_bv), + uv_t)]), uu___4))) + (subst1, FStarC_TypeChecker_Env.trivial_guard) bs3) +let (ad_hoc_indexed_lift_substs : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.binders -> + FStarC_Syntax_Syntax.comp_typ -> + Prims.string -> + FStarC_Compiler_Range_Type.range -> + (FStarC_Syntax_Syntax.subst_elt Prims.list * + FStarC_TypeChecker_Env.guard_t)) + = + fun env -> + fun bs -> + fun ct -> + fun lift_name -> + fun r -> + let debug = FStarC_Compiler_Effect.op_Bang dbg_LayeredEffectsApp in + let lift_t_shape_error s = + FStarC_Compiler_Util.format2 + "Lift %s has unexpected shape, reason: %s" lift_name s in + let uu___ = + if (FStarC_Compiler_List.length bs) >= (Prims.of_int (2)) + then + let uu___1 = bs in + match uu___1 with + | a_b::bs1 -> + let uu___2 = + FStarC_Compiler_List.splitAt + ((FStarC_Compiler_List.length bs1) - Prims.int_one) + bs1 in + (a_b, uu___2) + else + (let uu___2 = + lift_t_shape_error + "either not an arrow or not enough binders" in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range r + FStarC_Errors_Codes.Fatal_UnexpectedEffect () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2)) in + match uu___ with + | (a_b, (rest_bs, f_b::[])) -> + let uu___1 = + FStarC_TypeChecker_Env.uvars_for_binders env rest_bs + [FStarC_Syntax_Syntax.NT + ((a_b.FStarC_Syntax_Syntax.binder_bv), + (ct.FStarC_Syntax_Syntax.result_typ))] + (fun b -> + if debug + then + let uu___2 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_binder b in + let uu___3 = + FStarC_Compiler_Range_Ops.string_of_range r in + FStarC_Compiler_Util.format3 + "implicit var for binder %s of %s at %s" uu___2 + lift_name uu___3 + else "ad_hoc_indexed_lift_substs") r in + (match uu___1 with + | (rest_bs_uvars, g) -> + let substs = + FStarC_Compiler_List.map2 + (fun b -> + fun t -> + FStarC_Syntax_Syntax.NT + ((b.FStarC_Syntax_Syntax.binder_bv), t)) (a_b + :: rest_bs) ((ct.FStarC_Syntax_Syntax.result_typ) :: + rest_bs_uvars) in + let guard_f = + let f_sort = + let uu___2 = + FStarC_Syntax_Subst.subst substs + (f_b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort in + FStarC_Syntax_Subst.compress uu___2 in + let f_sort_is = + let uu___2 = + FStarC_TypeChecker_Env.is_layered_effect env + ct.FStarC_Syntax_Syntax.effect_name in + effect_args_from_repr f_sort uu___2 r in + let uu___2 = + FStarC_Compiler_List.map FStar_Pervasives_Native.fst + ct.FStarC_Syntax_Syntax.effect_args in + FStarC_Compiler_List.fold_left2 + (fun g1 -> + fun i1 -> + fun i2 -> + let uu___3 = + FStarC_TypeChecker_Rel.layered_effect_teq + env i1 i2 + (FStar_Pervasives_Native.Some lift_name) in + FStarC_TypeChecker_Env.conj_guard g1 uu___3) + FStarC_TypeChecker_Env.trivial_guard uu___2 + f_sort_is in + let uu___2 = FStarC_TypeChecker_Env.conj_guard g guard_f in + (substs, uu___2)) +let (lift_tf_layered_effect : + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.tscheme -> + FStarC_Syntax_Syntax.indexed_effect_combinator_kind -> + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.comp -> + (FStarC_Syntax_Syntax.comp * FStarC_TypeChecker_Env.guard_t)) + = + fun tgt -> + fun lift_ts -> + fun kind -> + fun env -> + fun c -> + let debug = FStarC_Compiler_Effect.op_Bang dbg_LayeredEffectsApp in + if debug + then + (let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_comp c in + let uu___2 = + FStarC_Class_Show.show FStarC_Ident.showable_lident tgt in + FStarC_Compiler_Util.print2 + "Lifting indexed comp %s to %s {\n" uu___1 uu___2) + else (); + (let r = FStarC_TypeChecker_Env.get_range env in + let ct = FStarC_TypeChecker_Env.comp_to_comp_typ env c in + check_non_informative_type_for_lift env + ct.FStarC_Syntax_Syntax.effect_name tgt + ct.FStarC_Syntax_Syntax.result_typ r; + (let lift_name uu___2 = + if debug + then + let uu___3 = + FStarC_Ident.string_of_lid + ct.FStarC_Syntax_Syntax.effect_name in + let uu___4 = FStarC_Ident.string_of_lid tgt in + FStarC_Compiler_Util.format2 "%s ~> %s" uu___3 uu___4 + else "" in + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Compiler_List.hd + ct.FStarC_Syntax_Syntax.comp_univs in + [uu___4] in + FStarC_TypeChecker_Env.inst_tscheme_with lift_ts uu___3 in + match uu___2 with + | (uu___3, lift_t) -> + let uu___4 = FStarC_Syntax_Util.arrow_formals_comp lift_t in + (match uu___4 with + | (bs, lift_c) -> + let uu___5 = + if kind = FStarC_Syntax_Syntax.Ad_hoc_combinator + then + let uu___6 = lift_name () in + ad_hoc_indexed_lift_substs env bs ct uu___6 r + else + (let uu___7 = lift_name () in + substitutive_indexed_lift_substs env bs ct uu___7 + r) in + (match uu___5 with + | (substs, g) -> + let lift_ct = + let uu___6 = + FStarC_Syntax_Subst.subst_comp substs lift_c in + FStarC_TypeChecker_Env.comp_to_comp_typ env + uu___6 in + let is = + let uu___6 = + FStarC_TypeChecker_Env.is_layered_effect env + tgt in + effect_args_from_repr + lift_ct.FStarC_Syntax_Syntax.result_typ + uu___6 r in + let fml = + let uu___6 = + let uu___7 = + FStarC_Compiler_List.hd + lift_ct.FStarC_Syntax_Syntax.comp_univs in + let uu___8 = + let uu___9 = + FStarC_Compiler_List.hd + lift_ct.FStarC_Syntax_Syntax.effect_args in + FStar_Pervasives_Native.fst uu___9 in + (uu___7, uu___8) in + match uu___6 with + | (u, wp) -> + FStarC_TypeChecker_Env.pure_precondition_for_trivial_post + env u + lift_ct.FStarC_Syntax_Syntax.result_typ + wp FStarC_Compiler_Range_Type.dummyRange in + ((let uu___7 = + (FStarC_Compiler_Effect.op_Bang + dbg_LayeredEffects) + && (FStarC_Compiler_Debug.extreme ()) in + if uu___7 + then + let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term fml in + FStarC_Compiler_Util.print1 + "Guard for lift is: %s" uu___8 + else ()); + (let c1 = + let uu___7 = + let uu___8 = + FStarC_Compiler_List.map + FStarC_Syntax_Syntax.as_arg is in + { + FStarC_Syntax_Syntax.comp_univs = + (ct.FStarC_Syntax_Syntax.comp_univs); + FStarC_Syntax_Syntax.effect_name = tgt; + FStarC_Syntax_Syntax.result_typ = + (ct.FStarC_Syntax_Syntax.result_typ); + FStarC_Syntax_Syntax.effect_args = uu___8; + FStarC_Syntax_Syntax.flags = [] + } in + FStarC_Syntax_Syntax.mk_Comp uu___7 in + if debug + then + (let uu___8 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_comp c1 in + FStarC_Compiler_Util.print1 + "} Lifted comp: %s\n" uu___8) + else (); + (let g1 = + let uu___8 = + let uu___9 = + let uu___10 = + FStarC_TypeChecker_Env.guard_of_guard_formula + (FStarC_TypeChecker_Common.NonTrivial + fml) in + [uu___10] in + g :: uu___9 in + FStarC_TypeChecker_Env.conj_guards uu___8 in + (c1, g1)))))))) +let lift_tf_layered_effect_term : + 'uuuuu . + 'uuuuu -> + FStarC_Syntax_Syntax.sub_eff -> + FStarC_Syntax_Syntax.universe -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term + = + fun env -> + fun sub -> + fun u -> + fun a -> + fun e -> + let lift = + let uu___ = + let uu___1 = + FStarC_Compiler_Util.must sub.FStarC_Syntax_Syntax.lift in + FStarC_TypeChecker_Env.inst_tscheme_with uu___1 [u] in + FStar_Pervasives_Native.snd uu___ in + let rest_bs = + let lift_t = + FStarC_Compiler_Util.must sub.FStarC_Syntax_Syntax.lift_wp in + let uu___ = + let uu___1 = + FStarC_Syntax_Subst.compress + (FStar_Pervasives_Native.snd lift_t) in + uu___1.FStarC_Syntax_Syntax.n in + match uu___ with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = uu___1::bs; + FStarC_Syntax_Syntax.comp = uu___2;_} + when (FStarC_Compiler_List.length bs) >= Prims.int_one -> + let uu___3 = + FStarC_Compiler_List.splitAt + ((FStarC_Compiler_List.length bs) - Prims.int_one) bs in + FStar_Pervasives_Native.fst uu___3 + | uu___1 -> + let uu___2 = + let uu___3 = FStarC_Syntax_Print.tscheme_to_string lift_t in + FStarC_Compiler_Util.format1 + "lift_t tscheme %s is not an arrow with enough binders" + uu___3 in + FStarC_Errors.raise_error + (FStarC_Syntax_Syntax.has_range_syntax ()) + (FStar_Pervasives_Native.snd lift_t) + FStarC_Errors_Codes.Fatal_UnexpectedEffect () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2) in + let args = + let uu___ = FStarC_Syntax_Syntax.as_arg a in + let uu___1 = + let uu___2 = + FStarC_Compiler_List.map + (fun uu___3 -> + FStarC_Syntax_Syntax.as_arg + FStarC_Syntax_Syntax.unit_const) rest_bs in + let uu___3 = + let uu___4 = FStarC_Syntax_Syntax.as_arg e in [uu___4] in + FStarC_Compiler_List.op_At uu___2 uu___3 in + uu___ :: uu___1 in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = lift; + FStarC_Syntax_Syntax.args = args + }) e.FStarC_Syntax_Syntax.pos +let (get_field_projector_name : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident -> Prims.int -> FStarC_Ident.lident) + = + fun env -> + fun datacon -> + fun index -> + let uu___ = FStarC_TypeChecker_Env.lookup_datacon env datacon in + match uu___ with + | (uu___1, t) -> + let err n = + let uu___2 = + let uu___3 = + FStarC_Class_Show.show FStarC_Ident.showable_lident datacon in + let uu___4 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) n in + let uu___5 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) index in + FStarC_Compiler_Util.format3 + "Data constructor %s does not have enough binders (has %s, tried %s)" + uu___3 uu___4 uu___5 in + FStarC_Errors.raise_error FStarC_TypeChecker_Env.hasRange_env + env FStarC_Errors_Codes.Fatal_UnexpectedDataConstructor () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___2) in + let uu___2 = + let uu___3 = FStarC_Syntax_Subst.compress t in + uu___3.FStarC_Syntax_Syntax.n in + (match uu___2 with + | FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = bs; + FStarC_Syntax_Syntax.comp = uu___3;_} + -> + let bs1 = + FStarC_Compiler_List.filter + (fun uu___4 -> + match uu___4 with + | { FStarC_Syntax_Syntax.binder_bv = uu___5; + FStarC_Syntax_Syntax.binder_qual = q; + FStarC_Syntax_Syntax.binder_positivity = uu___6; + FStarC_Syntax_Syntax.binder_attrs = uu___7;_} -> + (match q with + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Implicit (true)) -> + false + | uu___8 -> true)) bs in + if (FStarC_Compiler_List.length bs1) <= index + then err (FStarC_Compiler_List.length bs1) + else + (let b = FStarC_Compiler_List.nth bs1 index in + FStarC_Syntax_Util.mk_field_projector_name datacon + b.FStarC_Syntax_Syntax.binder_bv index) + | uu___3 -> err Prims.int_zero) +let (get_mlift_for_subeff : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.sub_eff -> FStarC_TypeChecker_Env.mlift) + = + fun env -> + fun sub -> + let uu___ = + (FStarC_TypeChecker_Env.is_layered_effect env + sub.FStarC_Syntax_Syntax.source) + || + (FStarC_TypeChecker_Env.is_layered_effect env + sub.FStarC_Syntax_Syntax.target) in + if uu___ + then + let uu___1 = + let uu___2 = + FStarC_Compiler_Util.must sub.FStarC_Syntax_Syntax.lift_wp in + let uu___3 = + FStarC_Compiler_Util.must sub.FStarC_Syntax_Syntax.kind in + lift_tf_layered_effect sub.FStarC_Syntax_Syntax.target uu___2 + uu___3 in + { + FStarC_TypeChecker_Env.mlift_wp = uu___1; + FStarC_TypeChecker_Env.mlift_term = + (FStar_Pervasives_Native.Some + (lift_tf_layered_effect_term env sub)) + } + else + (let mk_mlift_wp ts env1 c = + let ct = FStarC_TypeChecker_Env.comp_to_comp_typ env1 c in + check_non_informative_type_for_lift env1 + ct.FStarC_Syntax_Syntax.effect_name + sub.FStarC_Syntax_Syntax.target + ct.FStarC_Syntax_Syntax.result_typ + env1.FStarC_TypeChecker_Env.range; + (let uu___3 = + FStarC_TypeChecker_Env.inst_tscheme_with ts + ct.FStarC_Syntax_Syntax.comp_univs in + match uu___3 with + | (uu___4, lift_t) -> + let wp = + FStarC_Compiler_List.hd ct.FStarC_Syntax_Syntax.effect_args in + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + let uu___9 = + let uu___10 = + let uu___11 = + let uu___12 = + let uu___13 = + FStarC_Syntax_Syntax.as_arg + ct.FStarC_Syntax_Syntax.result_typ in + [uu___13; wp] in + { + FStarC_Syntax_Syntax.hd = lift_t; + FStarC_Syntax_Syntax.args = uu___12 + } in + FStarC_Syntax_Syntax.Tm_app uu___11 in + FStarC_Syntax_Syntax.mk uu___10 + (FStar_Pervasives_Native.fst wp).FStarC_Syntax_Syntax.pos in + FStarC_Syntax_Syntax.as_arg uu___9 in + [uu___8] in + { + FStarC_Syntax_Syntax.comp_univs = + (ct.FStarC_Syntax_Syntax.comp_univs); + FStarC_Syntax_Syntax.effect_name = + (sub.FStarC_Syntax_Syntax.target); + FStarC_Syntax_Syntax.result_typ = + (ct.FStarC_Syntax_Syntax.result_typ); + FStarC_Syntax_Syntax.effect_args = uu___7; + FStarC_Syntax_Syntax.flags = + (ct.FStarC_Syntax_Syntax.flags) + } in + FStarC_Syntax_Syntax.mk_Comp uu___6 in + (uu___5, FStarC_TypeChecker_Common.trivial_guard)) in + let mk_mlift_term ts u r e = + let uu___2 = FStarC_TypeChecker_Env.inst_tscheme_with ts [u] in + match uu___2 with + | (uu___3, lift_t) -> + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = FStarC_Syntax_Syntax.as_arg r in + let uu___8 = + let uu___9 = + FStarC_Syntax_Syntax.as_arg FStarC_Syntax_Syntax.tun in + let uu___10 = + let uu___11 = FStarC_Syntax_Syntax.as_arg e in + [uu___11] in + uu___9 :: uu___10 in + uu___7 :: uu___8 in + { + FStarC_Syntax_Syntax.hd = lift_t; + FStarC_Syntax_Syntax.args = uu___6 + } in + FStarC_Syntax_Syntax.Tm_app uu___5 in + FStarC_Syntax_Syntax.mk uu___4 e.FStarC_Syntax_Syntax.pos in + let uu___2 = + let uu___3 = + FStarC_Compiler_Util.must sub.FStarC_Syntax_Syntax.lift_wp in + mk_mlift_wp uu___3 in + { + FStarC_TypeChecker_Env.mlift_wp = uu___2; + FStarC_TypeChecker_Env.mlift_term = + (match sub.FStarC_Syntax_Syntax.lift with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.Some + ((fun uu___3 -> + fun uu___4 -> + fun e -> FStarC_Compiler_Util.return_all e)) + | FStar_Pervasives_Native.Some ts -> + FStar_Pervasives_Native.Some (mk_mlift_term ts)) + }) +let (update_env_sub_eff : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.sub_eff -> + FStarC_Compiler_Range_Type.range -> FStarC_TypeChecker_Env.env) + = + fun env -> + fun sub -> + fun r -> + let r0 = env.FStarC_TypeChecker_Env.range in + let env1 = + let uu___ = get_mlift_for_subeff env sub in + FStarC_TypeChecker_Env.update_effect_lattice + { + FStarC_TypeChecker_Env.solver = + (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = r; + FStarC_TypeChecker_Env.curmodule = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = + (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env.FStarC_TypeChecker_Env.missing_decl) + } sub.FStarC_Syntax_Syntax.source sub.FStarC_Syntax_Syntax.target + uu___ in + { + FStarC_TypeChecker_Env.solver = + (env1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = r0; + FStarC_TypeChecker_Env.curmodule = + (env1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = (env1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = (env1.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env1.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = (env1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = (env1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env1.FStarC_TypeChecker_Env.missing_decl) + } +let (update_env_polymonadic_bind : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident -> + FStarC_Ident.lident -> + FStarC_Ident.lident -> + FStarC_Syntax_Syntax.tscheme -> + FStarC_Syntax_Syntax.indexed_effect_combinator_kind -> + FStarC_TypeChecker_Env.env) + = + fun env -> + fun m -> + fun n -> + fun p -> + fun ty -> + fun k -> + FStarC_TypeChecker_Env.add_polymonadic_bind env m n p + (fun env1 -> + fun c1 -> + fun bv_opt -> + fun c2 -> + fun flags -> + fun r -> + mk_indexed_bind env1 m n p ty k c1 bv_opt c2 + flags r Prims.int_zero false) +let (try_lookup_record_type : + FStarC_TypeChecker_Env.env -> + FStarC_Ident.lident -> + FStarC_Syntax_DsEnv.record_or_dc FStar_Pervasives_Native.option) + = + fun env -> + fun typename -> + try + (fun uu___ -> + match () with + | () -> + let uu___1 = + FStarC_TypeChecker_Env.datacons_of_typ env typename in + (match uu___1 with + | (uu___2, dc::[]) -> + let se = FStarC_TypeChecker_Env.lookup_sigelt env dc in + (match se with + | FStar_Pervasives_Native.Some + { + FStarC_Syntax_Syntax.sigel = + FStarC_Syntax_Syntax.Sig_datacon + { FStarC_Syntax_Syntax.lid1 = uu___3; + FStarC_Syntax_Syntax.us1 = uu___4; + FStarC_Syntax_Syntax.t1 = t; + FStarC_Syntax_Syntax.ty_lid = uu___5; + FStarC_Syntax_Syntax.num_ty_params = nparms; + FStarC_Syntax_Syntax.mutuals1 = uu___6; + FStarC_Syntax_Syntax.injective_type_params1 = + uu___7;_}; + FStarC_Syntax_Syntax.sigrng = uu___8; + FStarC_Syntax_Syntax.sigquals = uu___9; + FStarC_Syntax_Syntax.sigmeta = uu___10; + FStarC_Syntax_Syntax.sigattrs = uu___11; + FStarC_Syntax_Syntax.sigopens_and_abbrevs = + uu___12; + FStarC_Syntax_Syntax.sigopts = uu___13;_} + -> + let uu___14 = FStarC_Syntax_Util.arrow_formals t in + (match uu___14 with + | (formals, c) -> + if + nparms < + (FStarC_Compiler_List.length formals) + then + let uu___15 = + FStarC_Compiler_List.splitAt nparms formals in + (match uu___15 with + | (uu___16, fields) -> + let fields1 = + FStarC_Compiler_List.filter + (fun b -> + match b.FStarC_Syntax_Syntax.binder_qual + with + | FStar_Pervasives_Native.Some + (FStarC_Syntax_Syntax.Implicit + uu___17) -> false + | uu___17 -> true) fields in + let fields2 = + FStarC_Compiler_List.map + (fun b -> + (((b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.ppname), + ((b.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort))) + fields1 in + let is_rec = + FStarC_TypeChecker_Env.is_record env + typename in + let r = + let uu___17 = + FStarC_Ident.ident_of_lid dc in + { + FStarC_Syntax_DsEnv.typename = + typename; + FStarC_Syntax_DsEnv.constrname = + uu___17; + FStarC_Syntax_DsEnv.parms = []; + FStarC_Syntax_DsEnv.fields = fields2; + FStarC_Syntax_DsEnv.is_private = + false; + FStarC_Syntax_DsEnv.is_record = + is_rec + } in + FStar_Pervasives_Native.Some r) + else FStar_Pervasives_Native.None) + | uu___3 -> FStar_Pervasives_Native.None) + | (uu___2, dcs) -> FStar_Pervasives_Native.None)) () + with | uu___ -> FStar_Pervasives_Native.None +let (find_record_or_dc_from_typ : + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.typ FStar_Pervasives_Native.option -> + FStarC_Syntax_Syntax.unresolved_constructor -> + FStarC_Compiler_Range_Type.range -> + (FStarC_Syntax_DsEnv.record_or_dc * FStarC_Ident.lident * + FStarC_Syntax_Syntax.fv)) + = + fun env -> + fun t -> + fun uc -> + fun rng -> + let default_rdc uu___ = + match ((uc.FStarC_Syntax_Syntax.uc_typename), + (uc.FStarC_Syntax_Syntax.uc_fields)) + with + | (FStar_Pervasives_Native.None, []) -> + let uu___1 = + let uu___2 = + FStarC_Errors_Msg.text + "Could not resolve the type for this record." in + [uu___2] in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range rng + FStarC_Errors_Codes.Error_CannotResolveRecord () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___1) + | (FStar_Pervasives_Native.None, f::uu___1) -> + let f1 = + FStarC_Compiler_List.hd uc.FStarC_Syntax_Syntax.uc_fields in + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Ident.string_of_lid f1 in + FStarC_Compiler_Util.format1 + "Field name %s could not be resolved." uu___5 in + FStarC_Errors_Msg.text uu___4 in + [uu___3] in + FStarC_Errors.raise_error FStarC_Ident.hasrange_lident f1 + FStarC_Errors_Codes.Error_CannotResolveRecord () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___2) + | (FStar_Pervasives_Native.Some tn, uu___1) -> + let uu___2 = try_lookup_record_type env tn in + (match uu___2 with + | FStar_Pervasives_Native.Some rdc -> rdc + | FStar_Pervasives_Native.None -> + let uu___3 = + let uu___4 = FStarC_Ident.string_of_lid tn in + FStarC_Compiler_Util.format1 + "Record name %s not found." uu___4 in + FStarC_Errors.raise_error FStarC_Ident.hasrange_lident + tn FStarC_Errors_Codes.Fatal_NameNotFound () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___3)) in + let rdc = + match t with + | FStar_Pervasives_Native.None -> default_rdc () + | FStar_Pervasives_Native.Some t1 -> + let uu___ = + let uu___1 = + FStarC_TypeChecker_Normalize.unfold_whnf' + [FStarC_TypeChecker_Env.Unascribe; + FStarC_TypeChecker_Env.Unmeta; + FStarC_TypeChecker_Env.Unrefine] env t1 in + FStarC_Syntax_Util.head_and_args uu___1 in + (match uu___ with + | (thead, uu___1) -> + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Syntax_Util.un_uinst thead in + FStarC_Syntax_Subst.compress uu___4 in + uu___3.FStarC_Syntax_Syntax.n in + (match uu___2 with + | FStarC_Syntax_Syntax.Tm_fvar type_name -> + let uu___3 = + try_lookup_record_type env + (type_name.FStarC_Syntax_Syntax.fv_name).FStarC_Syntax_Syntax.v in + (match uu___3 with + | FStar_Pervasives_Native.None -> default_rdc () + | FStar_Pervasives_Native.Some r -> r) + | uu___3 -> default_rdc ())) in + let constrname = + let name = + let uu___ = + let uu___1 = + FStarC_Ident.ns_of_lid rdc.FStarC_Syntax_DsEnv.typename in + FStarC_Compiler_List.op_At uu___1 + [rdc.FStarC_Syntax_DsEnv.constrname] in + FStarC_Ident.lid_of_ids uu___ in + FStarC_Ident.set_lid_range name rng in + let constructor = + let qual = + if rdc.FStarC_Syntax_DsEnv.is_record + then + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Compiler_List.map FStar_Pervasives_Native.fst + rdc.FStarC_Syntax_DsEnv.fields in + ((rdc.FStarC_Syntax_DsEnv.typename), uu___2) in + FStarC_Syntax_Syntax.Record_ctor uu___1 in + FStar_Pervasives_Native.Some uu___ + else FStar_Pervasives_Native.None in + FStarC_Syntax_Syntax.lid_as_fv constrname qual in + (rdc, constrname, constructor) +let (field_name_matches : + FStarC_Ident.lident -> + FStarC_Syntax_DsEnv.record_or_dc -> FStarC_Ident.ident -> Prims.bool) + = + fun field_name -> + fun rdc -> + fun field -> + (let uu___ = FStarC_Ident.ident_of_lid field_name in + FStarC_Ident.ident_equals field uu___) && + (let uu___ = + let uu___1 = FStarC_Ident.ns_of_lid field_name in uu___1 <> [] in + if uu___ + then + let uu___1 = FStarC_Ident.nsstr field_name in + let uu___2 = FStarC_Ident.nsstr rdc.FStarC_Syntax_DsEnv.typename in + uu___1 = uu___2 + else true) +let make_record_fields_in_order : + 'a . + FStarC_TypeChecker_Env.env -> + FStarC_Syntax_Syntax.unresolved_constructor -> + (FStarC_Syntax_Syntax.typ, FStarC_Syntax_Syntax.typ) + FStar_Pervasives.either FStar_Pervasives_Native.option -> + FStarC_Syntax_DsEnv.record_or_dc -> + (FStarC_Ident.lident * 'a) Prims.list -> + (FStarC_Ident.ident -> 'a FStar_Pervasives_Native.option) -> + FStarC_Compiler_Range_Type.range -> 'a Prims.list + = + fun env -> + fun uc -> + fun topt -> + fun rdc -> + fun fas -> + fun not_found -> + fun rng -> + let debug uu___ = + let print_rdc rdc1 = + let uu___1 = + FStarC_Ident.string_of_lid + rdc1.FStarC_Syntax_DsEnv.typename in + let uu___2 = + FStarC_Ident.string_of_id + rdc1.FStarC_Syntax_DsEnv.constrname in + let uu___3 = + let uu___4 = + FStarC_Compiler_List.map + (fun uu___5 -> + match uu___5 with + | (i, uu___6) -> FStarC_Ident.string_of_id i) + rdc1.FStarC_Syntax_DsEnv.fields in + FStarC_Compiler_String.concat "; " uu___4 in + FStarC_Compiler_Util.format3 + "{typename=%s; constrname=%s; fields=[%s]}" uu___1 + uu___2 uu___3 in + let print_topt topt1 = + let uu___1 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_option + (FStarC_Class_Show.show_either + FStarC_Syntax_Print.showable_term + FStarC_Syntax_Print.showable_term)) topt1 in + let uu___2 = print_rdc rdc in + FStarC_Compiler_Util.format2 "topt=%s; rdc=%s" uu___1 + uu___2 in + let uu___1 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_option + FStarC_Ident.showable_lident) + uc.FStarC_Syntax_Syntax.uc_typename in + let uu___2 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Ident.showable_lident) + uc.FStarC_Syntax_Syntax.uc_fields in + let uu___3 = print_topt topt in + let uu___4 = print_rdc rdc in + let uu___5 = + let uu___6 = + FStarC_Compiler_List.map FStar_Pervasives_Native.fst + fas in + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Ident.showable_lident) uu___6 in + FStarC_Compiler_Util.print5 + "Resolved uc={typename=%s;fields=%s}\n\ttopt=%s\n\t{rdc = %s\n\tfield assignments=[%s]}\n" + uu___1 uu___2 uu___3 uu___4 uu___5 in + let uu___ = + FStarC_Compiler_List.fold_left + (fun uu___1 -> + fun uu___2 -> + match (uu___1, uu___2) with + | ((fields, as_rev, missing), (field_name, uu___3)) + -> + let uu___4 = + FStarC_Compiler_List.partition + (fun uu___5 -> + match uu___5 with + | (fn, uu___6) -> + field_name_matches fn rdc field_name) + fields in + (match uu___4 with + | (matching, rest) -> + (match matching with + | (uu___5, a1)::[] -> + (rest, (a1 :: as_rev), missing) + | [] -> + let uu___5 = not_found field_name in + (match uu___5 with + | FStar_Pervasives_Native.None -> + (rest, as_rev, (field_name :: + missing)) + | FStar_Pervasives_Native.Some a1 -> + (rest, (a1 :: as_rev), missing)) + | uu___5 -> + let uu___6 = + let uu___7 = + FStarC_Ident.string_of_id + field_name in + let uu___8 = + FStarC_Ident.string_of_lid + rdc.FStarC_Syntax_DsEnv.typename in + FStarC_Compiler_Util.format2 + "Field %s of record type %s is given multiple assignments" + uu___7 uu___8 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + rng + FStarC_Errors_Codes.Fatal_MissingFieldInRecord + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___6)))) (fas, [], []) + rdc.FStarC_Syntax_DsEnv.fields in + match uu___ with + | (rest, as_rev, missing) -> + let pp_missing uu___1 = + let uu___2 = + let uu___3 = FStarC_Pprint.break_ Prims.int_one in + FStarC_Pprint.op_Hat_Hat FStarC_Pprint.comma uu___3 in + FStarC_Pprint.separate_map uu___2 + (fun f -> + let uu___3 = + let uu___4 = + FStarC_Class_Show.show + FStarC_Ident.showable_ident f in + FStarC_Pprint.doc_of_string uu___4 in + FStarC_Pprint.squotes uu___3) missing in + ((match (rest, missing) with + | ([], []) -> () + | ((f, uu___2)::uu___3, uu___4) -> + let uu___5 = + let uu___6 = + let uu___7 = + let uu___8 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident f in + let uu___9 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + rdc.FStarC_Syntax_DsEnv.typename in + FStarC_Compiler_Util.format2 + "Field '%s' is redundant for type %s" + uu___8 uu___9 in + FStarC_Errors_Msg.text uu___7 in + let uu___7 = + let uu___8 = + if Prims.uu___is_Cons missing + then + let uu___9 = + FStarC_Errors_Msg.text "Missing fields:" in + let uu___10 = pp_missing () in + FStarC_Pprint.prefix (Prims.of_int (2)) + Prims.int_one uu___9 uu___10 + else FStarC_Pprint.empty in + [uu___8] in + uu___6 :: uu___7 in + FStarC_Errors.raise_error + FStarC_Ident.hasrange_lident f + FStarC_Errors_Codes.Fatal_MissingFieldInRecord () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___5) + | ([], uu___2) -> + let uu___3 = + let uu___4 = + let uu___5 = + let uu___6 = + let uu___7 = + FStarC_Class_Show.show + FStarC_Ident.showable_lident + rdc.FStarC_Syntax_DsEnv.typename in + FStarC_Compiler_Util.format1 + "Missing fields for record type '%s':" + uu___7 in + FStarC_Errors_Msg.text uu___6 in + let uu___6 = pp_missing () in + FStarC_Pprint.prefix (Prims.of_int (2)) + Prims.int_one uu___5 uu___6 in + [uu___4] in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range rng + FStarC_Errors_Codes.Fatal_MissingFieldInRecord () + (Obj.magic + FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___3)); + FStarC_Compiler_List.rev as_rev) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStarC_Universal.ml b/ocaml/fstar-lib/generated/FStarC_Universal.ml new file mode 100644 index 00000000000..20711b4acee --- /dev/null +++ b/ocaml/fstar-lib/generated/FStarC_Universal.ml @@ -0,0 +1,1574 @@ +open Prims +type uenv = FStarC_Extraction_ML_UEnv.uenv +let (module_or_interface_name : + FStarC_Syntax_Syntax.modul -> (Prims.bool * FStarC_Ident.lid)) = + fun m -> + ((m.FStarC_Syntax_Syntax.is_interface), (m.FStarC_Syntax_Syntax.name)) +let with_dsenv_of_tcenv : + 'a . + FStarC_TypeChecker_Env.env -> + 'a FStarC_Syntax_DsEnv.withenv -> ('a * FStarC_TypeChecker_Env.env) + = + fun tcenv -> + fun f -> + let uu___ = f tcenv.FStarC_TypeChecker_Env.dsenv in + match uu___ with + | (a1, dsenv) -> + (a1, + { + FStarC_TypeChecker_Env.solver = + (tcenv.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (tcenv.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (tcenv.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (tcenv.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (tcenv.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (tcenv.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (tcenv.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (tcenv.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (tcenv.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (tcenv.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (tcenv.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (tcenv.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (tcenv.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (tcenv.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (tcenv.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (tcenv.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (tcenv.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (tcenv.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (tcenv.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (tcenv.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (tcenv.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (tcenv.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (tcenv.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (tcenv.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (tcenv.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (tcenv.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (tcenv.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (tcenv.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (tcenv.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (tcenv.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (tcenv.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (tcenv.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (tcenv.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (tcenv.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (tcenv.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (tcenv.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (tcenv.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (tcenv.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (tcenv.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (tcenv.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (tcenv.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (tcenv.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (tcenv.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = dsenv; + FStarC_TypeChecker_Env.nbe = (tcenv.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (tcenv.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (tcenv.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (tcenv.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (tcenv.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (tcenv.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (tcenv.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (tcenv.FStarC_TypeChecker_Env.missing_decl) + }) +let with_tcenv_of_env : + 'a . + uenv -> + (FStarC_TypeChecker_Env.env -> ('a * FStarC_TypeChecker_Env.env)) -> + ('a * uenv) + = + fun e -> + fun f -> + let uu___ = + let uu___1 = FStarC_Extraction_ML_UEnv.tcenv_of_uenv e in f uu___1 in + match uu___ with + | (a1, t') -> + let uu___1 = FStarC_Extraction_ML_UEnv.set_tcenv e t' in + (a1, uu___1) +let with_dsenv_of_env : + 'a . uenv -> 'a FStarC_Syntax_DsEnv.withenv -> ('a * uenv) = + fun e -> + fun f -> + let uu___ = + let uu___1 = FStarC_Extraction_ML_UEnv.tcenv_of_uenv e in + with_dsenv_of_tcenv uu___1 f in + match uu___ with + | (a1, tcenv) -> + let uu___1 = FStarC_Extraction_ML_UEnv.set_tcenv e tcenv in + (a1, uu___1) +let (push_env : uenv -> uenv) = + fun env -> + let uu___ = + with_tcenv_of_env env + (fun tcenv -> + let uu___1 = + let uu___2 = FStarC_Extraction_ML_UEnv.tcenv_of_uenv env in + FStarC_TypeChecker_Env.push uu___2 "top-level: push_env" in + ((), uu___1)) in + FStar_Pervasives_Native.snd uu___ +let (pop_env : uenv -> uenv) = + fun env -> + let uu___ = + with_tcenv_of_env env + (fun tcenv -> + let uu___1 = FStarC_TypeChecker_Env.pop tcenv "top-level: pop_env" in + ((), uu___1)) in + FStar_Pervasives_Native.snd uu___ +let with_env : 'a . uenv -> (uenv -> 'a) -> 'a = + fun env -> + fun f -> + let env1 = push_env env in + let res = f env1 in let uu___ = pop_env env1 in res +let (env_of_tcenv : + FStarC_TypeChecker_Env.env -> FStarC_Extraction_ML_UEnv.uenv) = + fun env -> FStarC_Extraction_ML_UEnv.new_uenv env +let (parse : + uenv -> + Prims.string FStar_Pervasives_Native.option -> + Prims.string -> (FStarC_Syntax_Syntax.modul * uenv)) + = + fun env -> + fun pre_fn -> + fun fn -> + let uu___ = FStarC_Parser_Driver.parse_file fn in + match uu___ with + | (ast, uu___1) -> + let uu___2 = + match pre_fn with + | FStar_Pervasives_Native.None -> (ast, env) + | FStar_Pervasives_Native.Some pre_fn1 -> + let uu___3 = FStarC_Parser_Driver.parse_file pre_fn1 in + (match uu___3 with + | (pre_ast, uu___4) -> + (match (pre_ast, ast) with + | (FStarC_Parser_AST.Interface + (lid1, decls1, uu___5), FStarC_Parser_AST.Module + (lid2, decls2)) when + FStarC_Ident.lid_equals lid1 lid2 -> + let uu___6 = + let uu___7 = + FStarC_ToSyntax_Interleave.initialize_interface + lid1 decls1 in + with_dsenv_of_env env uu___7 in + (match uu___6 with + | (uu___7, env1) -> + let uu___8 = + FStarC_ToSyntax_Interleave.interleave_module + ast true in + with_dsenv_of_env env1 uu___8) + | (FStarC_Parser_AST.Interface + (lid1, uu___5, uu___6), FStarC_Parser_AST.Module + (lid2, uu___7)) -> + FStarC_Errors.raise_error + FStarC_Ident.hasrange_lident lid1 + FStarC_Errors_Codes.Fatal_PreModuleMismatch () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Module name in implementation does not match that of interface.") + | uu___5 -> + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_PreModuleMismatch () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "Module name in implementation does not match that of interface."))) in + (match uu___2 with + | (ast1, env1) -> + let uu___3 = + FStarC_ToSyntax_ToSyntax.ast_modul_to_modul ast1 in + with_dsenv_of_env env1 uu___3) +let (core_check : FStarC_TypeChecker_Env.core_check_t) = + fun env -> + fun tm -> + fun t -> + fun must_tot -> + let uu___ = + let uu___1 = FStarC_Options.compat_pre_core_should_check () in + Prims.op_Negation uu___1 in + if uu___ + then FStar_Pervasives.Inl FStar_Pervasives_Native.None + else + (let uu___2 = + FStarC_TypeChecker_Core.check_term env tm t must_tot in + match uu___2 with + | FStar_Pervasives.Inl (FStar_Pervasives_Native.None) -> + FStar_Pervasives.Inl FStar_Pervasives_Native.None + | FStar_Pervasives.Inl (FStar_Pervasives_Native.Some g) -> + let uu___3 = FStarC_Options.compat_pre_core_set () in + if uu___3 + then FStar_Pervasives.Inl FStar_Pervasives_Native.None + else FStar_Pervasives.Inl (FStar_Pervasives_Native.Some g) + | FStar_Pervasives.Inr err -> + FStar_Pervasives.Inr + ((fun b -> + if b + then FStarC_TypeChecker_Core.print_error_short err + else FStarC_TypeChecker_Core.print_error err))) +let (init_env : FStarC_Parser_Dep.deps -> FStarC_TypeChecker_Env.env) = + fun deps -> + let solver = + let uu___ = FStarC_Options.lax () in + if uu___ + then FStarC_SMTEncoding_Solver.dummy + else + { + FStarC_TypeChecker_Env.init = + (FStarC_SMTEncoding_Solver.solver.FStarC_TypeChecker_Env.init); + FStarC_TypeChecker_Env.snapshot = + (FStarC_SMTEncoding_Solver.solver.FStarC_TypeChecker_Env.snapshot); + FStarC_TypeChecker_Env.rollback = + (FStarC_SMTEncoding_Solver.solver.FStarC_TypeChecker_Env.rollback); + FStarC_TypeChecker_Env.encode_sig = + (FStarC_SMTEncoding_Solver.solver.FStarC_TypeChecker_Env.encode_sig); + FStarC_TypeChecker_Env.preprocess = FStarC_Tactics_Hooks.preprocess; + FStarC_TypeChecker_Env.spinoff_strictly_positive_goals = + (FStar_Pervasives_Native.Some + FStarC_Tactics_Hooks.spinoff_strictly_positive_goals); + FStarC_TypeChecker_Env.handle_smt_goal = + FStarC_Tactics_Hooks.handle_smt_goal; + FStarC_TypeChecker_Env.solve = + (FStarC_SMTEncoding_Solver.solver.FStarC_TypeChecker_Env.solve); + FStarC_TypeChecker_Env.solve_sync = + (FStarC_SMTEncoding_Solver.solver.FStarC_TypeChecker_Env.solve_sync); + FStarC_TypeChecker_Env.finish = + (FStarC_SMTEncoding_Solver.solver.FStarC_TypeChecker_Env.finish); + FStarC_TypeChecker_Env.refresh = + (FStarC_SMTEncoding_Solver.solver.FStarC_TypeChecker_Env.refresh) + } in + let env = + let uu___ = + let uu___1 = FStarC_Tactics_Interpreter.primitive_steps () in + FStarC_TypeChecker_NBE.normalize uu___1 in + FStarC_TypeChecker_Env.initial_env deps + FStarC_TypeChecker_TcTerm.tc_term + FStarC_TypeChecker_TcTerm.typeof_tot_or_gtot_term + FStarC_TypeChecker_TcTerm.typeof_tot_or_gtot_term_fastpath + FStarC_TypeChecker_TcTerm.universe_of + FStarC_TypeChecker_Rel.teq_nosmt_force + FStarC_TypeChecker_Rel.subtype_nosmt_force solver + FStarC_Parser_Const.prims_lid uu___ core_check in + let env1 = + { + FStarC_TypeChecker_Env.solver = (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = (env.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = (env.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = FStarC_Tactics_Hooks.synthesize; + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = (env.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env.FStarC_TypeChecker_Env.missing_decl) + } in + let env2 = + { + FStarC_TypeChecker_Env.solver = (env1.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = (env1.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env1.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = (env1.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env1.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env1.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env1.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env1.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = (env1.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env1.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env1.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env1.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env1.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env1.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env1.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env1.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env1.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env1.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = (env1.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env1.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = (env1.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env1.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env1.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env1.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env1.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env1.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env1.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env1.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env1.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env1.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env1.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env1.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env1.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env1.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env1.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env1.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env1.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + FStarC_Tactics_Hooks.solve_implicits; + FStarC_TypeChecker_Env.splice = (env1.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env1.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env1.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env1.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env1.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = (env1.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = (env1.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env1.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env1.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env1.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env1.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env1.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env1.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env1.FStarC_TypeChecker_Env.missing_decl) + } in + let env3 = + { + FStarC_TypeChecker_Env.solver = (env2.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = (env2.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env2.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = (env2.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env2.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env2.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env2.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env2.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = (env2.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env2.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env2.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env2.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env2.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env2.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env2.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env2.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env2.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env2.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = (env2.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env2.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = (env2.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env2.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env2.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env2.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env2.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env2.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env2.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env2.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env2.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env2.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env2.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env2.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env2.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env2.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env2.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env2.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env2.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env2.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = FStarC_Tactics_Hooks.splice; + FStarC_TypeChecker_Env.mpreprocess = + (env2.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env2.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env2.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env2.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = (env2.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = (env2.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env2.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env2.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env2.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env2.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env2.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env2.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env2.FStarC_TypeChecker_Env.missing_decl) + } in + let env4 = + { + FStarC_TypeChecker_Env.solver = (env3.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = (env3.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env3.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = (env3.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env3.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env3.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env3.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env3.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = (env3.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env3.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env3.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env3.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env3.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env3.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env3.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env3.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env3.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env3.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = (env3.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env3.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = (env3.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env3.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env3.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env3.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env3.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env3.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env3.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env3.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env3.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env3.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env3.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env3.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env3.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env3.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env3.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env3.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env3.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env3.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = (env3.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = FStarC_Tactics_Hooks.mpreprocess; + FStarC_TypeChecker_Env.postprocess = + (env3.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env3.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env3.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = (env3.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = (env3.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env3.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env3.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env3.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env3.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env3.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env3.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env3.FStarC_TypeChecker_Env.missing_decl) + } in + let env5 = + { + FStarC_TypeChecker_Env.solver = (env4.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = (env4.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env4.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = (env4.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env4.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env4.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env4.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env4.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = (env4.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env4.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env4.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env4.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env4.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env4.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env4.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env4.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env4.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env4.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = (env4.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env4.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = (env4.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env4.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env4.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env4.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env4.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env4.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env4.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env4.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env4.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env4.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env4.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env4.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env4.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env4.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env4.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env4.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env4.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env4.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = (env4.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env4.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = FStarC_Tactics_Hooks.postprocess; + FStarC_TypeChecker_Env.identifier_info = + (env4.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env4.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = (env4.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = (env4.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env4.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env4.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env4.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env4.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env4.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env4.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env4.FStarC_TypeChecker_Env.missing_decl) + } in + (env5.FStarC_TypeChecker_Env.solver).FStarC_TypeChecker_Env.init env5; + env5 +type lang_decls_t = FStarC_Parser_AST.decl Prims.list +let (tc_one_fragment : + FStarC_Syntax_Syntax.modul FStar_Pervasives_Native.option -> + FStarC_TypeChecker_Env.env_t -> + ((FStarC_Parser_ParseIt.input_frag * lang_decls_t), + FStarC_Parser_AST.decl) FStar_Pervasives.either -> + (FStarC_Syntax_Syntax.modul FStar_Pervasives_Native.option * + FStarC_TypeChecker_Env.env * lang_decls_t)) + = + fun curmod -> + fun env -> + fun frag -> + let fname env1 = + let uu___ = FStarC_Options.lsp_server () in + if uu___ + then + let uu___1 = FStarC_TypeChecker_Env.get_range env1 in + FStarC_Compiler_Range_Ops.file_of_range uu___1 + else + (let uu___2 = FStarC_Options.file_list () in + FStarC_Compiler_List.hd uu___2) in + let acceptable_mod_name modul = + let uu___ = + let uu___1 = fname env in + FStarC_Parser_Dep.lowercase_module_name uu___1 in + let uu___1 = + let uu___2 = + FStarC_Ident.string_of_lid modul.FStarC_Syntax_Syntax.name in + FStarC_Compiler_String.lowercase uu___2 in + uu___ = uu___1 in + let range_of_first_mod_decl modul = + match modul with + | FStarC_Parser_AST.Module + (uu___, + { FStarC_Parser_AST.d = uu___1; FStarC_Parser_AST.drange = d; + FStarC_Parser_AST.quals = uu___2; + FStarC_Parser_AST.attrs = uu___3; + FStarC_Parser_AST.interleaved = uu___4;_}::uu___5) + -> d + | FStarC_Parser_AST.Interface + (uu___, + { FStarC_Parser_AST.d = uu___1; FStarC_Parser_AST.drange = d; + FStarC_Parser_AST.quals = uu___2; + FStarC_Parser_AST.attrs = uu___3; + FStarC_Parser_AST.interleaved = uu___4;_}::uu___5, + uu___6) + -> d + | uu___ -> FStarC_Compiler_Range_Type.dummyRange in + let filter_lang_decls d = + match d.FStarC_Parser_AST.d with + | FStarC_Parser_AST.UseLangDecls uu___ -> true + | uu___ -> false in + let use_lang_decl ds = + FStarC_Compiler_List.tryFind + (fun d -> + FStarC_Parser_AST.uu___is_UseLangDecls d.FStarC_Parser_AST.d) + ds in + let check_module_name_declaration ast_modul = + let uu___ = + let uu___1 = + FStarC_ToSyntax_Interleave.interleave_module ast_modul false in + with_dsenv_of_tcenv env uu___1 in + match uu___ with + | (ast_modul1, env1) -> + let uu___1 = + let uu___2 = + FStarC_ToSyntax_ToSyntax.partial_ast_modul_to_modul curmod + ast_modul1 in + with_dsenv_of_tcenv env1 uu___2 in + (match uu___1 with + | (modul, env2) -> + ((let uu___3 = + let uu___4 = acceptable_mod_name modul in + Prims.op_Negation uu___4 in + if uu___3 + then + let msg = + let uu___4 = + let uu___5 = fname env2 in + FStarC_Parser_Dep.module_name_of_file uu___5 in + FStarC_Compiler_Util.format1 + "Interactive mode only supports a single module at the top-level. Expected module %s" + uu___4 in + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range + (range_of_first_mod_decl ast_modul1) + FStarC_Errors_Codes.Fatal_NonSingletonTopLevelModule + () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic msg) + else ()); + (let uu___3 = + let uu___4 = + FStarC_Syntax_DsEnv.syntax_only + env2.FStarC_TypeChecker_Env.dsenv in + if uu___4 + then (modul, env2) + else FStarC_TypeChecker_Tc.tc_partial_modul env2 modul in + match uu___3 with + | (modul1, env3) -> + let lang_decls = + let decls = + match ast_modul1 with + | FStarC_Parser_AST.Module (uu___4, decls1) -> + decls1 + | FStarC_Parser_AST.Interface + (uu___4, decls1, uu___5) -> decls1 in + FStarC_Compiler_List.filter filter_lang_decls + decls in + ((FStar_Pervasives_Native.Some modul1), env3, + lang_decls)))) in + let check_decls ast_decls = + match curmod with + | FStar_Pervasives_Native.None -> + let uu___ = FStarC_Compiler_List.hd ast_decls in + (match uu___ with + | { FStarC_Parser_AST.d = uu___1; + FStarC_Parser_AST.drange = rng; + FStarC_Parser_AST.quals = uu___2; + FStarC_Parser_AST.attrs = uu___3; + FStarC_Parser_AST.interleaved = uu___4;_} -> + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range rng + FStarC_Errors_Codes.Fatal_ModuleFirstStatement () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic + "First statement must be a module declaration")) + | FStar_Pervasives_Native.Some modul -> + let uu___ = + FStarC_Compiler_Util.fold_map + (fun env1 -> + fun a_decl -> + let uu___1 = + let uu___2 = + FStarC_ToSyntax_Interleave.prefix_with_interface_decls + modul.FStarC_Syntax_Syntax.name a_decl in + with_dsenv_of_tcenv env1 uu___2 in + match uu___1 with | (decls, env2) -> (env2, decls)) + env ast_decls in + (match uu___ with + | (env1, ast_decls_l) -> + let uu___1 = + let uu___2 = + FStarC_ToSyntax_ToSyntax.decls_to_sigelts + (FStarC_Compiler_List.flatten ast_decls_l) in + with_dsenv_of_tcenv env1 uu___2 in + (match uu___1 with + | (sigelts, env2) -> + let uu___2 = + let uu___3 = + FStarC_Syntax_DsEnv.syntax_only + env2.FStarC_TypeChecker_Env.dsenv in + if uu___3 + then (modul, [], env2) + else + FStarC_TypeChecker_Tc.tc_more_partial_modul env2 + modul sigelts in + (match uu___2 with + | (modul1, uu___3, env3) -> + let uu___4 = + FStarC_Compiler_List.filter filter_lang_decls + ast_decls in + ((FStar_Pervasives_Native.Some modul1), env3, + uu___4)))) in + match frag with + | FStar_Pervasives.Inr d -> + (match d.FStarC_Parser_AST.d with + | FStarC_Parser_AST.TopLevelModule lid -> + check_module_name_declaration + (FStarC_Parser_AST.Module (lid, [d])) + | uu___ -> check_decls [d]) + | FStar_Pervasives.Inl (frag1, lang_decls) -> + let parse_frag frag2 = + let uu___ = use_lang_decl lang_decls in + match uu___ with + | FStar_Pervasives_Native.None -> + FStarC_Parser_Driver.parse_fragment + FStar_Pervasives_Native.None frag2 + | FStar_Pervasives_Native.Some + { + FStarC_Parser_AST.d = FStarC_Parser_AST.UseLangDecls lang; + FStarC_Parser_AST.drange = uu___1; + FStarC_Parser_AST.quals = uu___2; + FStarC_Parser_AST.attrs = uu___3; + FStarC_Parser_AST.interleaved = uu___4;_} + -> + FStarC_Parser_Driver.parse_fragment + (FStar_Pervasives_Native.Some lang) frag2 in + let uu___ = parse_frag frag1 in + (match uu___ with + | FStarC_Parser_Driver.Empty -> (curmod, env, []) + | FStarC_Parser_Driver.Decls [] -> (curmod, env, []) + | FStarC_Parser_Driver.Modul ast_modul -> + check_module_name_declaration ast_modul + | FStarC_Parser_Driver.Decls ast_decls -> check_decls ast_decls) +let (load_interface_decls : + FStarC_TypeChecker_Env.env -> Prims.string -> FStarC_TypeChecker_Env.env_t) + = + fun env -> + fun interface_file_name -> + let r = + FStarC_Parser_ParseIt.parse FStar_Pervasives_Native.None + (FStarC_Parser_ParseIt.Filename interface_file_name) in + match r with + | FStarC_Parser_ParseIt.ASTFragment + (FStar_Pervasives.Inl (FStarC_Parser_AST.Interface + (l, decls, uu___)), uu___1) + -> + let uu___2 = + let uu___3 = + FStarC_ToSyntax_Interleave.initialize_interface l decls in + with_dsenv_of_tcenv env uu___3 in + FStar_Pervasives_Native.snd uu___2 + | FStarC_Parser_ParseIt.ASTFragment uu___ -> + let uu___1 = + FStarC_Compiler_Util.format1 + "Unexpected result from parsing %s; expected a single interface" + interface_file_name in + FStarC_Errors.raise_error0 FStarC_Errors_Codes.Fatal_ParseErrors () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1) + | FStarC_Parser_ParseIt.ParseError (err, msg, rng) -> + FStarC_Compiler_Effect.raise + (FStarC_Errors.Error (err, msg, rng, [])) + | FStarC_Parser_ParseIt.Term uu___ -> + failwith + "Impossible: parsing a Toplevel always results in an ASTFragment" +let (emit : + FStarC_Parser_Dep.deps -> + (uenv * FStarC_Extraction_ML_Syntax.mllib) Prims.list -> unit) + = + fun dep_graph -> + fun mllibs -> + let opt = FStarC_Options.codegen () in + let fail uu___ = + let uu___1 = + let uu___2 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_option + FStarC_Options.showable_codegen_t) opt in + Prims.strcat "Unrecognized extraction backend: " uu___2 in + failwith uu___1 in + if opt <> FStar_Pervasives_Native.None + then + let ext = + match opt with + | FStar_Pervasives_Native.Some (FStarC_Options.FSharp) -> ".fs" + | FStar_Pervasives_Native.Some (FStarC_Options.OCaml) -> ".ml" + | FStar_Pervasives_Native.Some (FStarC_Options.Plugin) -> ".ml" + | FStar_Pervasives_Native.Some (FStarC_Options.Krml) -> ".krml" + | FStar_Pervasives_Native.Some (FStarC_Options.Extension) -> ".ast" + | uu___ -> fail () in + match opt with + | FStar_Pervasives_Native.Some (FStarC_Options.FSharp) -> + let outdir = FStarC_Options.output_dir () in + let uu___ = + FStarC_Compiler_List.map FStar_Pervasives_Native.snd mllibs in + FStarC_Compiler_List.iter + (FStarC_Extraction_ML_PrintML.print outdir ext) uu___ + | FStar_Pervasives_Native.Some (FStarC_Options.OCaml) -> + let outdir = FStarC_Options.output_dir () in + let uu___ = + FStarC_Compiler_List.map FStar_Pervasives_Native.snd mllibs in + FStarC_Compiler_List.iter + (FStarC_Extraction_ML_PrintML.print outdir ext) uu___ + | FStar_Pervasives_Native.Some (FStarC_Options.Plugin) -> + let outdir = FStarC_Options.output_dir () in + let uu___ = + FStarC_Compiler_List.map FStar_Pervasives_Native.snd mllibs in + FStarC_Compiler_List.iter + (FStarC_Extraction_ML_PrintML.print outdir ext) uu___ + | FStar_Pervasives_Native.Some (FStarC_Options.Extension) -> + FStarC_Compiler_List.iter + (fun uu___ -> + match uu___ with + | (env, m) -> + let uu___1 = m in + (match uu___1 with + | FStarC_Extraction_ML_Syntax.MLLib ms -> + FStarC_Compiler_List.iter + (fun m1 -> + let uu___2 = m1 in + match uu___2 with + | (mname, modul, uu___3) -> + let filename = + FStarC_Compiler_String.concat "_" + (FStarC_Compiler_List.op_At + (FStar_Pervasives_Native.fst mname) + [FStar_Pervasives_Native.snd mname]) in + (match modul with + | FStar_Pervasives_Native.Some + (uu___4, decls) -> + let bindings = + FStarC_Extraction_ML_UEnv.bindings_of_uenv + env in + let deps = + let uu___5 = + FStarC_Extraction_ML_Syntax.string_of_mlpath + mname in + FStarC_Parser_Dep.deps_of_modul + dep_graph uu___5 in + let uu___5 = + FStarC_Options.prepend_output_dir + (Prims.strcat filename ext) in + FStarC_Compiler_Util.save_value_to_file + uu___5 (deps, bindings, decls) + | FStar_Pervasives_Native.None -> + failwith + "Unexpected ml modul in Extension extraction mode")) + ms)) mllibs + | FStar_Pervasives_Native.Some (FStarC_Options.Krml) -> + let programs = + FStarC_Compiler_List.collect + (fun uu___ -> + match uu___ with + | (ue, mllibs1) -> + FStarC_Extraction_Krml.translate ue mllibs1) mllibs in + let bin = (FStarC_Extraction_Krml.current_version, programs) in + let oname = + let uu___ = FStarC_Options.krmloutput () in + match uu___ with + | FStar_Pervasives_Native.Some fname -> fname + | uu___1 -> + (match programs with + | (name, uu___2)::[] -> + FStarC_Options.prepend_output_dir + (Prims.strcat name ext) + | uu___2 -> + FStarC_Options.prepend_output_dir + (Prims.strcat "out" ext)) in + FStarC_Compiler_Util.save_value_to_file oname bin + | uu___ -> fail () + else () +let (tc_one_file : + uenv -> + Prims.string FStar_Pervasives_Native.option -> + Prims.string -> + FStarC_Parser_Dep.parsing_data -> + (FStarC_CheckedFiles.tc_result * FStarC_Extraction_ML_Syntax.mllib + FStar_Pervasives_Native.option * uenv)) + = + fun env -> + fun pre_fn -> + fun fn -> + fun parsing_data -> + FStarC_GenSym.reset_gensym (); + (let maybe_restore_opts uu___1 = + let uu___2 = + let uu___3 = FStarC_Options.interactive () in + Prims.op_Negation uu___3 in + if uu___2 + then + let uu___3 = FStarC_Options.restore_cmd_line_options true in + () + else () in + let maybe_extract_mldefs tcmod env1 = + let uu___1 = FStarC_Options.codegen () in + match uu___1 with + | FStar_Pervasives_Native.None -> + (FStar_Pervasives_Native.None, Prims.int_zero) + | FStar_Pervasives_Native.Some tgt -> + let uu___2 = + let uu___3 = + let uu___4 = + FStarC_Ident.string_of_lid + tcmod.FStarC_Syntax_Syntax.name in + FStarC_Options.should_extract uu___4 tgt in + Prims.op_Negation uu___3 in + if uu___2 + then (FStar_Pervasives_Native.None, Prims.int_zero) + else + FStarC_Compiler_Util.record_time + (fun uu___4 -> + with_env env1 + (fun env2 -> + let uu___5 = + FStarC_Extraction_ML_Modul.extract env2 tcmod in + match uu___5 with | (uu___6, defs) -> defs)) in + let maybe_extract_ml_iface tcmod env1 = + let uu___1 = + let uu___2 = FStarC_Options.codegen () in + uu___2 = FStar_Pervasives_Native.None in + if uu___1 + then (env1, Prims.int_zero) + else + FStarC_Compiler_Util.record_time + (fun uu___3 -> + let uu___4 = + with_env env1 + (fun env2 -> + FStarC_Extraction_ML_Modul.extract_iface env2 + tcmod) in + match uu___4 with | (env2, uu___5) -> env2) in + let tc_source_file uu___1 = + let uu___2 = parse env pre_fn fn in + match uu___2 with + | (fmod, env1) -> + let mii = + let uu___3 = + let uu___4 = + FStarC_Extraction_ML_UEnv.tcenv_of_uenv env1 in + uu___4.FStarC_TypeChecker_Env.dsenv in + FStarC_Syntax_DsEnv.inclusion_info uu___3 + fmod.FStarC_Syntax_Syntax.name in + let check_mod uu___3 = + let check env2 = + (let uu___5 = + let uu___6 = FStarC_Options.lax () in + Prims.op_Negation uu___6 in + if uu___5 + then + FStarC_SMTEncoding_Z3.refresh + FStar_Pervasives_Native.None + else ()); + with_tcenv_of_env env2 + (fun tcenv -> + (match tcenv.FStarC_TypeChecker_Env.gamma with + | [] -> () + | uu___6 -> + failwith + "Impossible: gamma contains leaked names"); + (let uu___6 = + FStarC_TypeChecker_Tc.check_module tcenv fmod + (FStarC_Compiler_Util.is_some pre_fn) in + match uu___6 with + | (modul, env3) -> + (maybe_restore_opts (); + (let smt_decls = + let uu___8 = + let uu___9 = FStarC_Options.lax () in + Prims.op_Negation uu___9 in + if uu___8 + then + FStarC_SMTEncoding_Encode.encode_modul + env3 modul + else ([], []) in + ((modul, smt_decls), env3))))) in + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Ident.string_of_lid + fmod.FStarC_Syntax_Syntax.name in + FStar_Pervasives_Native.Some uu___6 in + FStarC_Profiling.profile (fun uu___6 -> check env1) + uu___5 "FStarC.Universal.tc_source_file" in + match uu___4 with + | ((tcmod, smt_decls), env2) -> + let tc_time = Prims.int_zero in + let uu___5 = maybe_extract_mldefs tcmod env2 in + (match uu___5 with + | (extracted_defs, extract_time) -> + let uu___6 = maybe_extract_ml_iface tcmod env2 in + (match uu___6 with + | (env3, iface_extraction_time) -> + ({ + FStarC_CheckedFiles.checked_module = + tcmod; + FStarC_CheckedFiles.mii = mii; + FStarC_CheckedFiles.smt_decls = smt_decls; + FStarC_CheckedFiles.tc_time = tc_time; + FStarC_CheckedFiles.extraction_time = + (extract_time + iface_extraction_time) + }, extracted_defs, env3))) in + let uu___3 = + (let uu___4 = + FStarC_Ident.string_of_lid + fmod.FStarC_Syntax_Syntax.name in + FStarC_Options.should_verify uu___4) && + ((FStarC_Options.record_hints ()) || + (FStarC_Options.use_hints ())) in + if uu___3 + then + let uu___4 = FStarC_Parser_ParseIt.find_file fn in + FStarC_SMTEncoding_Solver.with_hints_db uu___4 check_mod + else check_mod () in + let uu___1 = + let uu___2 = FStarC_Options.cache_off () in + Prims.op_Negation uu___2 in + if uu___1 + then + let r = + let uu___2 = FStarC_Extraction_ML_UEnv.tcenv_of_uenv env in + FStarC_CheckedFiles.load_module_from_cache uu___2 fn in + let r1 = + let uu___2 = + (FStarC_Options.force ()) && + (FStarC_Options.should_check_file fn) in + if uu___2 then FStar_Pervasives_Native.None else r in + match r1 with + | FStar_Pervasives_Native.None -> + ((let uu___3 = + (let uu___4 = FStarC_Parser_Dep.module_name_of_file fn in + FStarC_Options.should_be_already_cached uu___4) && + (let uu___4 = FStarC_Options.force () in + Prims.op_Negation uu___4) in + if uu___3 + then + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Compiler_Util.format1 + "Expected %s to already be checked." fn in + FStarC_Errors_Msg.text uu___6 in + [uu___5] in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Error_AlreadyCachedAssertionFailure + () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___4) + else ()); + (let uu___4 = + ((let uu___5 = FStarC_Options.codegen () in + FStarC_Compiler_Option.isSome uu___5) && + (FStarC_Options.cmi ())) + && + (let uu___5 = FStarC_Options.force () in + Prims.op_Negation uu___5) in + if uu___4 + then + let uu___5 = + let uu___6 = + FStarC_Errors_Msg.text + "Cross-module inlining expects all modules to be checked first." in + let uu___7 = + let uu___8 = + let uu___9 = + FStarC_Compiler_Util.format1 + "Module %s was not checked." fn in + FStarC_Errors_Msg.text uu___9 in + [uu___8] in + uu___6 :: uu___7 in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Error_AlreadyCachedAssertionFailure + () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic uu___5) + else ()); + (let uu___4 = tc_source_file () in + match uu___4 with + | (tc_result, mllib, env1) -> + ((let uu___6 = + (let uu___7 = FStarC_Errors.get_err_count () in + uu___7 = Prims.int_zero) && + ((FStarC_Options.lax ()) || + (let uu___7 = + FStarC_Ident.string_of_lid + (tc_result.FStarC_CheckedFiles.checked_module).FStarC_Syntax_Syntax.name in + FStarC_Options.should_verify uu___7)) in + if uu___6 + then + let uu___7 = + FStarC_Extraction_ML_UEnv.tcenv_of_uenv env1 in + FStarC_CheckedFiles.store_module_to_cache uu___7 + fn parsing_data tc_result + else ()); + (tc_result, mllib, env1)))) + | FStar_Pervasives_Native.Some tc_result -> + let tcmod = tc_result.FStarC_CheckedFiles.checked_module in + let smt_decls = tc_result.FStarC_CheckedFiles.smt_decls in + ((let uu___3 = + let uu___4 = + FStarC_Ident.string_of_lid + tcmod.FStarC_Syntax_Syntax.name in + FStarC_Options.dump_module uu___4 in + if uu___3 + then + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_modul tcmod in + FStarC_Compiler_Util.print1 + "Module after type checking:\n%s\n" uu___4 + else ()); + (let extend_tcenv tcmod1 tcenv = + (let uu___4 = + let uu___5 = FStarC_Options.lax () in + Prims.op_Negation uu___5 in + if uu___4 + then + FStarC_SMTEncoding_Z3.refresh + FStar_Pervasives_Native.None + else ()); + (let uu___4 = + let uu___5 = + FStarC_ToSyntax_ToSyntax.add_modul_to_env tcmod1 + tc_result.FStarC_CheckedFiles.mii + (FStarC_TypeChecker_Normalize.erase_universes + tcenv) in + with_dsenv_of_tcenv tcenv uu___5 in + match uu___4 with + | (uu___5, tcenv1) -> + let env1 = + FStarC_TypeChecker_Tc.load_checked_module tcenv1 + tcmod1 in + (maybe_restore_opts (); + (let uu___8 = + let uu___9 = FStarC_Options.lax () in + Prims.op_Negation uu___9 in + if uu___8 + then + FStarC_SMTEncoding_Encode.encode_modul_from_cache + env1 tcmod1 smt_decls + else ()); + ((), env1))) in + let env1 = + FStarC_Profiling.profile + (fun uu___3 -> + let uu___4 = + with_tcenv_of_env env (extend_tcenv tcmod) in + FStar_Pervasives_Native.snd uu___4) + FStar_Pervasives_Native.None + "FStarC.Universal.extend_tcenv" in + let mllib = + let uu___3 = FStarC_Options.codegen () in + match uu___3 with + | FStar_Pervasives_Native.None -> + FStar_Pervasives_Native.None + | FStar_Pervasives_Native.Some tgt -> + let uu___4 = + (let uu___5 = + FStarC_Ident.string_of_lid + tcmod.FStarC_Syntax_Syntax.name in + FStarC_Options.should_extract uu___5 tgt) && + ((Prims.op_Negation + tcmod.FStarC_Syntax_Syntax.is_interface) + || (tgt = FStarC_Options.Krml)) in + if uu___4 + then + let uu___5 = maybe_extract_mldefs tcmod env1 in + (match uu___5 with + | (extracted_defs, _extraction_time) -> + extracted_defs) + else FStar_Pervasives_Native.None in + let uu___3 = maybe_extract_ml_iface tcmod env1 in + match uu___3 with + | (env2, _time) -> (tc_result, mllib, env2))) + else + (let uu___3 = tc_source_file () in + match uu___3 with + | (tc_result, mllib, env1) -> (tc_result, mllib, env1))) +let (tc_one_file_for_ide : + FStarC_TypeChecker_Env.env_t -> + Prims.string FStar_Pervasives_Native.option -> + Prims.string -> + FStarC_Parser_Dep.parsing_data -> + (FStarC_CheckedFiles.tc_result * FStarC_TypeChecker_Env.env_t)) + = + fun env -> + fun pre_fn -> + fun fn -> + fun parsing_data -> + let env1 = env_of_tcenv env in + let uu___ = tc_one_file env1 pre_fn fn parsing_data in + match uu___ with + | (tc_result, uu___1, env2) -> + let uu___2 = FStarC_Extraction_ML_UEnv.tcenv_of_uenv env2 in + (tc_result, uu___2) +let (needs_interleaving : Prims.string -> Prims.string -> Prims.bool) = + fun intf -> + fun impl -> + let m1 = FStarC_Parser_Dep.lowercase_module_name intf in + let m2 = FStarC_Parser_Dep.lowercase_module_name impl in + ((m1 = m2) && + (let uu___ = FStarC_Compiler_Util.get_file_extension intf in + FStarC_Compiler_List.mem uu___ ["fsti"; "fsi"])) + && + (let uu___ = FStarC_Compiler_Util.get_file_extension impl in + FStarC_Compiler_List.mem uu___ ["fst"; "fs"]) +let (tc_one_file_from_remaining : + Prims.string Prims.list -> + uenv -> + FStarC_Parser_Dep.deps -> + (Prims.string Prims.list * FStarC_CheckedFiles.tc_result * + FStarC_Extraction_ML_Syntax.mllib FStar_Pervasives_Native.option * + uenv)) + = + fun remaining -> + fun env -> + fun deps -> + let uu___ = + match remaining with + | intf::impl::remaining1 when needs_interleaving intf impl -> + let uu___1 = + let uu___2 = FStarC_Parser_Dep.parsing_data_of deps impl in + tc_one_file env (FStar_Pervasives_Native.Some intf) impl + uu___2 in + (match uu___1 with + | (m, mllib, env1) -> (remaining1, (m, mllib, env1))) + | intf_or_impl::remaining1 -> + let uu___1 = + let uu___2 = + FStarC_Parser_Dep.parsing_data_of deps intf_or_impl in + tc_one_file env FStar_Pervasives_Native.None intf_or_impl + uu___2 in + (match uu___1 with + | (m, mllib, env1) -> (remaining1, (m, mllib, env1))) + | [] -> failwith "Impossible: Empty remaining modules" in + match uu___ with + | (remaining1, (nmods, mllib, env1)) -> + (remaining1, nmods, mllib, env1) +let rec (tc_fold_interleave : + FStarC_Parser_Dep.deps -> + (FStarC_CheckedFiles.tc_result Prims.list * (uenv * + FStarC_Extraction_ML_Syntax.mllib) Prims.list * uenv) -> + Prims.string Prims.list -> + (FStarC_CheckedFiles.tc_result Prims.list * (uenv * + FStarC_Extraction_ML_Syntax.mllib) Prims.list * uenv)) + = + fun deps -> + fun acc -> + fun remaining -> + let as_list env mllib = + match mllib with + | FStar_Pervasives_Native.None -> [] + | FStar_Pervasives_Native.Some mllib1 -> [(env, mllib1)] in + match remaining with + | [] -> acc + | uu___ -> + let uu___1 = acc in + (match uu___1 with + | (mods, mllibs, env_before) -> + let uu___2 = + tc_one_file_from_remaining remaining env_before deps in + (match uu___2 with + | (remaining1, nmod, mllib, env) -> + ((let uu___4 = + let uu___5 = + FStarC_Options.profile_group_by_decl () in + Prims.op_Negation uu___5 in + if uu___4 + then + let uu___5 = + FStarC_Ident.string_of_lid + (nmod.FStarC_CheckedFiles.checked_module).FStarC_Syntax_Syntax.name in + FStarC_Profiling.report_and_clear uu___5 + else ()); + tc_fold_interleave deps + ((FStarC_Compiler_List.op_At mods [nmod]), + (FStarC_Compiler_List.op_At mllibs + (as_list env mllib)), env) remaining1))) +let (dbg_dep : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Debug.get_toggle "Dep" +let (batch_mode_tc : + Prims.string Prims.list -> + FStarC_Parser_Dep.deps -> + (FStarC_CheckedFiles.tc_result Prims.list * uenv * (uenv -> uenv))) + = + fun filenames -> + fun dep_graph -> + (let uu___1 = FStarC_Compiler_Effect.op_Bang dbg_dep in + if uu___1 + then + (FStarC_Compiler_Util.print_endline + "Auto-deps kicked in; here's some info."; + FStarC_Compiler_Util.print1 + "Here's the list of filenames we will process: %s\n" + (FStarC_Compiler_String.concat " " filenames); + (let uu___4 = + let uu___5 = + FStarC_Compiler_List.filter FStarC_Options.should_verify_file + filenames in + FStarC_Compiler_String.concat " " uu___5 in + FStarC_Compiler_Util.print1 + "Here's the list of modules we will verify: %s\n" uu___4)) + else ()); + (let env = + let uu___1 = init_env dep_graph in + FStarC_Extraction_ML_UEnv.new_uenv uu___1 in + let uu___1 = tc_fold_interleave dep_graph ([], [], env) filenames in + match uu___1 with + | (all_mods, mllibs, env1) -> + ((let uu___3 = + let uu___4 = FStarC_Errors.get_err_count () in + uu___4 = Prims.int_zero in + if uu___3 then emit dep_graph mllibs else ()); + (let solver_refresh env2 = + let uu___3 = + with_tcenv_of_env env2 + (fun tcenv -> + (let uu___5 = + (FStarC_Options.interactive ()) && + (let uu___6 = FStarC_Errors.get_err_count () in + uu___6 = Prims.int_zero) in + if uu___5 + then + (tcenv.FStarC_TypeChecker_Env.solver).FStarC_TypeChecker_Env.refresh + FStar_Pervasives_Native.None + else + (tcenv.FStarC_TypeChecker_Env.solver).FStarC_TypeChecker_Env.finish + ()); + ((), tcenv)) in + FStar_Pervasives_Native.snd uu___3 in + (all_mods, env1, solver_refresh)))) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_VConfig.ml b/ocaml/fstar-lib/generated/FStarC_VConfig.ml similarity index 100% rename from ocaml/fstar-lib/generated/FStar_VConfig.ml rename to ocaml/fstar-lib/generated/FStarC_VConfig.ml diff --git a/ocaml/fstar-lib/generated/FStar_Basefiles.ml b/ocaml/fstar-lib/generated/FStar_Basefiles.ml deleted file mode 100644 index 2c72f61d24e..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Basefiles.ml +++ /dev/null @@ -1,35 +0,0 @@ -open Prims -let (must_find : Prims.string -> Prims.string) = - fun fn -> - let uu___ = FStar_Find.find_file fn in - match uu___ with - | FStar_Pervasives_Native.Some f -> f - | FStar_Pervasives_Native.None -> - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Compiler_Util.format1 - "Unable to find required file \"%s\" in the module search path." - fn in - FStar_Errors_Msg.text uu___3 in - [uu___2] in - FStar_Errors.raise_error0 FStar_Errors_Codes.Fatal_ModuleNotFound () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___1) -let (prims : unit -> Prims.string) = - fun uu___ -> - let uu___1 = FStar_Options.custom_prims () in - match uu___1 with - | FStar_Pervasives_Native.Some fn -> fn - | FStar_Pervasives_Native.None -> must_find "Prims.fst" -let (prims_basename : unit -> Prims.string) = - fun uu___ -> let uu___1 = prims () in FStar_Compiler_Util.basename uu___1 -let (pervasives : unit -> Prims.string) = - fun uu___ -> must_find "FStar.Pervasives.fsti" -let (pervasives_basename : unit -> Prims.string) = - fun uu___ -> - let uu___1 = pervasives () in FStar_Compiler_Util.basename uu___1 -let (pervasives_native_basename : unit -> Prims.string) = - fun uu___ -> - let uu___1 = must_find "FStar.Pervasives.Native.fst" in - FStar_Compiler_Util.basename uu___1 \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_CheckedFiles.ml b/ocaml/fstar-lib/generated/FStar_CheckedFiles.ml deleted file mode 100644 index 6a71c1dd021..00000000000 --- a/ocaml/fstar-lib/generated/FStar_CheckedFiles.ml +++ /dev/null @@ -1,611 +0,0 @@ -open Prims -let (dbg : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "CheckedFiles" -let (cache_version_number : Prims.int) = (Prims.of_int (72)) -type tc_result = - { - checked_module: FStar_Syntax_Syntax.modul ; - mii: FStar_Syntax_DsEnv.module_inclusion_info ; - smt_decls: - (FStar_SMTEncoding_Term.decls_t * FStar_SMTEncoding_Env.fvar_binding - Prims.list) - ; - tc_time: Prims.int ; - extraction_time: Prims.int } -let (__proj__Mktc_result__item__checked_module : - tc_result -> FStar_Syntax_Syntax.modul) = - fun projectee -> - match projectee with - | { checked_module; mii; smt_decls; tc_time; extraction_time;_} -> - checked_module -let (__proj__Mktc_result__item__mii : - tc_result -> FStar_Syntax_DsEnv.module_inclusion_info) = - fun projectee -> - match projectee with - | { checked_module; mii; smt_decls; tc_time; extraction_time;_} -> mii -let (__proj__Mktc_result__item__smt_decls : - tc_result -> - (FStar_SMTEncoding_Term.decls_t * FStar_SMTEncoding_Env.fvar_binding - Prims.list)) - = - fun projectee -> - match projectee with - | { checked_module; mii; smt_decls; tc_time; extraction_time;_} -> - smt_decls -let (__proj__Mktc_result__item__tc_time : tc_result -> Prims.int) = - fun projectee -> - match projectee with - | { checked_module; mii; smt_decls; tc_time; extraction_time;_} -> - tc_time -let (__proj__Mktc_result__item__extraction_time : tc_result -> Prims.int) = - fun projectee -> - match projectee with - | { checked_module; mii; smt_decls; tc_time; extraction_time;_} -> - extraction_time -type checked_file_entry_stage1 = - { - version: Prims.int ; - digest: Prims.string ; - parsing_data: FStar_Parser_Dep.parsing_data } -let (__proj__Mkchecked_file_entry_stage1__item__version : - checked_file_entry_stage1 -> Prims.int) = - fun projectee -> - match projectee with | { version; digest; parsing_data;_} -> version -let (__proj__Mkchecked_file_entry_stage1__item__digest : - checked_file_entry_stage1 -> Prims.string) = - fun projectee -> - match projectee with | { version; digest; parsing_data;_} -> digest -let (__proj__Mkchecked_file_entry_stage1__item__parsing_data : - checked_file_entry_stage1 -> FStar_Parser_Dep.parsing_data) = - fun projectee -> - match projectee with | { version; digest; parsing_data;_} -> parsing_data -type checked_file_entry_stage2 = - { - deps_dig: (Prims.string * Prims.string) Prims.list ; - tc_res: tc_result } -let (__proj__Mkchecked_file_entry_stage2__item__deps_dig : - checked_file_entry_stage2 -> (Prims.string * Prims.string) Prims.list) = - fun projectee -> match projectee with | { deps_dig; tc_res;_} -> deps_dig -let (__proj__Mkchecked_file_entry_stage2__item__tc_res : - checked_file_entry_stage2 -> tc_result) = - fun projectee -> match projectee with | { deps_dig; tc_res;_} -> tc_res -type tc_result_t = - | Unknown - | Invalid of Prims.string - | Valid of Prims.string -let (uu___is_Unknown : tc_result_t -> Prims.bool) = - fun projectee -> match projectee with | Unknown -> true | uu___ -> false -let (uu___is_Invalid : tc_result_t -> Prims.bool) = - fun projectee -> match projectee with | Invalid _0 -> true | uu___ -> false -let (__proj__Invalid__item___0 : tc_result_t -> Prims.string) = - fun projectee -> match projectee with | Invalid _0 -> _0 -let (uu___is_Valid : tc_result_t -> Prims.bool) = - fun projectee -> match projectee with | Valid _0 -> true | uu___ -> false -let (__proj__Valid__item___0 : tc_result_t -> Prims.string) = - fun projectee -> match projectee with | Valid _0 -> _0 -let (uu___0 : tc_result_t FStar_Class_Show.showable) = - { - FStar_Class_Show.show = - (fun uu___ -> - match uu___ with - | Unknown -> "Unknown" - | Invalid s -> - let uu___1 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_string) s in - Prims.strcat "Invalid " uu___1 - | Valid s -> - let uu___1 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_string) s in - Prims.strcat "Valid " uu___1) - } -type cache_t = - (tc_result_t * (Prims.string, FStar_Parser_Dep.parsing_data) - FStar_Pervasives.either) -let (mcache : cache_t FStar_Compiler_Util.smap) = - FStar_Compiler_Util.smap_create (Prims.of_int (50)) -let (hash_dependences : - FStar_Parser_Dep.deps -> - Prims.string -> - (Prims.string, (Prims.string * Prims.string) Prims.list) - FStar_Pervasives.either) - = - fun deps -> - fun fn -> - let fn1 = - let uu___ = FStar_Find.find_file fn in - match uu___ with - | FStar_Pervasives_Native.Some fn2 -> fn2 - | uu___1 -> fn in - let module_name = FStar_Parser_Dep.lowercase_module_name fn1 in - let source_hash = FStar_Compiler_Util.digest_of_file fn1 in - let has_interface = - let uu___ = FStar_Parser_Dep.interface_of deps module_name in - FStar_Compiler_Option.isSome uu___ in - let interface_checked_file_name = - let uu___ = (FStar_Parser_Dep.is_implementation fn1) && has_interface in - if uu___ - then - let uu___1 = - let uu___2 = - let uu___3 = FStar_Parser_Dep.interface_of deps module_name in - FStar_Compiler_Util.must uu___3 in - FStar_Parser_Dep.cache_file_name uu___2 in - FStar_Pervasives_Native.Some uu___1 - else FStar_Pervasives_Native.None in - let binary_deps = - let uu___ = FStar_Parser_Dep.deps_of deps fn1 in - FStar_Compiler_List.filter - (fun fn2 -> - let uu___1 = - (FStar_Parser_Dep.is_interface fn2) && - (let uu___2 = FStar_Parser_Dep.lowercase_module_name fn2 in - uu___2 = module_name) in - Prims.op_Negation uu___1) uu___ in - let binary_deps1 = - FStar_Compiler_List.sortWith - (fun fn11 -> - fun fn2 -> - let uu___ = FStar_Parser_Dep.lowercase_module_name fn11 in - let uu___1 = FStar_Parser_Dep.lowercase_module_name fn2 in - FStar_Compiler_String.compare uu___ uu___1) binary_deps in - let maybe_add_iface_hash out = - match interface_checked_file_name with - | FStar_Pervasives_Native.None -> - FStar_Pervasives.Inr (("source", source_hash) :: out) - | FStar_Pervasives_Native.Some iface -> - let uu___ = FStar_Compiler_Util.smap_try_find mcache iface in - (match uu___ with - | FStar_Pervasives_Native.None -> - let msg = - FStar_Compiler_Util.format1 - "hash_dependences::the interface checked file %s does not exist\n" - iface in - ((let uu___2 = FStar_Compiler_Effect.op_Bang dbg in - if uu___2 - then FStar_Compiler_Util.print1 "%s\n" msg - else ()); - FStar_Pervasives.Inl msg) - | FStar_Pervasives_Native.Some (Invalid msg, uu___1) -> - FStar_Pervasives.Inl msg - | FStar_Pervasives_Native.Some (Valid h, uu___1) -> - FStar_Pervasives.Inr (("source", source_hash) :: - ("interface", h) :: out) - | FStar_Pervasives_Native.Some (Unknown, uu___1) -> - let uu___2 = - FStar_Compiler_Util.format1 - "Impossible: unknown entry in the mcache for interface %s\n" - iface in - failwith uu___2) in - let rec hash_deps out uu___ = - match uu___ with - | [] -> maybe_add_iface_hash out - | fn2::deps1 -> - let cache_fn = FStar_Parser_Dep.cache_file_name fn2 in - let digest = - let uu___1 = FStar_Compiler_Util.smap_try_find mcache cache_fn in - match uu___1 with - | FStar_Pervasives_Native.None -> - let msg = - FStar_Compiler_Util.format2 - "For dependency %s, cache file %s is not loaded" fn2 - cache_fn in - ((let uu___3 = FStar_Compiler_Effect.op_Bang dbg in - if uu___3 - then FStar_Compiler_Util.print1 "%s\n" msg - else ()); - FStar_Pervasives.Inl msg) - | FStar_Pervasives_Native.Some (Invalid msg, uu___2) -> - FStar_Pervasives.Inl msg - | FStar_Pervasives_Native.Some (Valid dig, uu___2) -> - FStar_Pervasives.Inr dig - | FStar_Pervasives_Native.Some (Unknown, uu___2) -> - let uu___3 = - FStar_Compiler_Util.format2 - "Impossible: unknown entry in the cache for dependence %s of module %s" - fn2 module_name in - failwith uu___3 in - (match digest with - | FStar_Pervasives.Inl msg -> FStar_Pervasives.Inl msg - | FStar_Pervasives.Inr dig -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Parser_Dep.lowercase_module_name fn2 in - (uu___3, dig) in - uu___2 :: out in - hash_deps uu___1 deps1) in - hash_deps [] binary_deps1 -let (load_checked_file : Prims.string -> Prims.string -> cache_t) = - fun fn -> - fun checked_fn -> - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg in - if uu___1 - then - FStar_Compiler_Util.print1 "Trying to load checked file result %s\n" - checked_fn - else ()); - (let elt = FStar_Compiler_Util.smap_try_find mcache checked_fn in - if FStar_Compiler_Util.is_some elt - then FStar_Compiler_Util.must elt - else - (let add_and_return elt1 = - FStar_Compiler_Util.smap_add mcache checked_fn elt1; elt1 in - if Prims.op_Negation (FStar_Compiler_Util.file_exists checked_fn) - then - let msg = - FStar_Compiler_Util.format1 "checked file %s does not exist" - checked_fn in - add_and_return ((Invalid msg), (FStar_Pervasives.Inl msg)) - else - (let entry = FStar_Compiler_Util.load_value_from_file checked_fn in - match entry with - | FStar_Pervasives_Native.None -> - let msg = - FStar_Compiler_Util.format1 "checked file %s is corrupt" - checked_fn in - add_and_return ((Invalid msg), (FStar_Pervasives.Inl msg)) - | FStar_Pervasives_Native.Some x -> - if x.version <> cache_version_number - then - let msg = - FStar_Compiler_Util.format1 - "checked file %s has incorrect version" checked_fn in - add_and_return ((Invalid msg), (FStar_Pervasives.Inl msg)) - else - (let current_digest = - FStar_Compiler_Util.digest_of_file fn in - if x.digest <> current_digest - then - ((let uu___5 = FStar_Compiler_Effect.op_Bang dbg in - if uu___5 - then - FStar_Compiler_Util.print4 - "Checked file %s is stale since incorrect digest of %s, expected: %s, found: %s\n" - checked_fn fn current_digest x.digest - else ()); - (let msg = - FStar_Compiler_Util.format2 - "checked file %s is stale (digest mismatch for %s)" - checked_fn fn in - add_and_return - ((Invalid msg), (FStar_Pervasives.Inl msg)))) - else - add_and_return - (Unknown, (FStar_Pervasives.Inr (x.parsing_data))))))) -let (load_tc_result : - Prims.string -> - ((Prims.string * Prims.string) Prims.list * tc_result) - FStar_Pervasives_Native.option) - = - fun checked_fn -> - let entry = FStar_Compiler_Util.load_2values_from_file checked_fn in - match entry with - | FStar_Pervasives_Native.Some (uu___, s2) -> - FStar_Pervasives_Native.Some ((s2.deps_dig), (s2.tc_res)) - | uu___ -> FStar_Pervasives_Native.None -let (load_checked_file_with_tc_result : - FStar_Parser_Dep.deps -> - Prims.string -> - Prims.string -> (Prims.string, tc_result) FStar_Pervasives.either) - = - fun deps -> - fun fn -> - fun checked_fn -> - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg in - if uu___1 - then - FStar_Compiler_Util.print1 - "Trying to load checked file with tc result %s\n" checked_fn - else ()); - (let load_tc_result' fn1 = - let uu___1 = load_tc_result fn1 in - match uu___1 with - | FStar_Pervasives_Native.Some x -> x - | FStar_Pervasives_Native.None -> - failwith - "Impossible! if first phase of loading was unknown, it should have succeeded" in - let elt = load_checked_file fn checked_fn in - match elt with - | (Invalid msg, uu___1) -> FStar_Pervasives.Inl msg - | (Valid uu___1, uu___2) -> - let uu___3 = - let uu___4 = load_tc_result' checked_fn in - FStar_Pervasives_Native.snd uu___4 in - FStar_Pervasives.Inr uu___3 - | (Unknown, parsing_data) -> - let uu___1 = hash_dependences deps fn in - (match uu___1 with - | FStar_Pervasives.Inl msg -> - let elt1 = ((Invalid msg), parsing_data) in - (FStar_Compiler_Util.smap_add mcache checked_fn elt1; - FStar_Pervasives.Inl msg) - | FStar_Pervasives.Inr deps_dig' -> - let uu___2 = load_tc_result' checked_fn in - (match uu___2 with - | (deps_dig, tc_result1) -> - if deps_dig = deps_dig' - then - let elt1 = - let uu___3 = - let uu___4 = - FStar_Compiler_Util.digest_of_file checked_fn in - Valid uu___4 in - (uu___3, parsing_data) in - (FStar_Compiler_Util.smap_add mcache checked_fn elt1; - (let validate_iface_cache uu___4 = - let iface = - let uu___5 = - FStar_Parser_Dep.lowercase_module_name fn in - FStar_Parser_Dep.interface_of deps uu___5 in - match iface with - | FStar_Pervasives_Native.None -> () - | FStar_Pervasives_Native.Some iface1 -> - (try - (fun uu___5 -> - match () with - | () -> - let iface_checked_fn = - FStar_Parser_Dep.cache_file_name - iface1 in - let uu___6 = - FStar_Compiler_Util.smap_try_find - mcache iface_checked_fn in - (match uu___6 with - | FStar_Pervasives_Native.Some - (Unknown, parsing_data1) -> - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Compiler_Util.digest_of_file - iface_checked_fn in - Valid uu___9 in - (uu___8, parsing_data1) in - FStar_Compiler_Util.smap_add - mcache iface_checked_fn - uu___7 - | uu___7 -> ())) () - with | uu___5 -> ()) in - validate_iface_cache (); - FStar_Pervasives.Inr tc_result1)) - else - ((let uu___5 = FStar_Compiler_Effect.op_Bang dbg in - if uu___5 - then - ((let uu___7 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length deps_dig') in - let uu___8 = - FStar_Parser_Dep.print_digest deps_dig' in - let uu___9 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length deps_dig) in - let uu___10 = - FStar_Parser_Dep.print_digest deps_dig in - FStar_Compiler_Util.print4 - "FAILING to load.\nExpected (%s) hashes:\n%s\n\nGot (%s) hashes:\n\t%s\n" - uu___7 uu___8 uu___9 uu___10); - if - (FStar_Compiler_List.length deps_dig) = - (FStar_Compiler_List.length deps_dig') - then - FStar_Compiler_List.iter2 - (fun uu___7 -> - fun uu___8 -> - match (uu___7, uu___8) with - | ((x, y), (x', y')) -> - if (x <> x') || (y <> y') - then - let uu___9 = - FStar_Parser_Dep.print_digest - [(x, y)] in - let uu___10 = - FStar_Parser_Dep.print_digest - [(x', y')] in - FStar_Compiler_Util.print2 - "Differ at: Expected %s\n Got %s\n" - uu___9 uu___10 - else ()) deps_dig deps_dig' - else ()) - else ()); - (let msg = - FStar_Compiler_Util.format1 - "checked file %s is stale (dependence hash mismatch, use --debug yes for more details)" - checked_fn in - let elt1 = - ((Invalid msg), (FStar_Pervasives.Inl msg)) in - FStar_Compiler_Util.smap_add mcache checked_fn - elt1; - FStar_Pervasives.Inl msg))))) -let (load_parsing_data_from_cache : - Prims.string -> - FStar_Parser_Dep.parsing_data FStar_Pervasives_Native.option) - = - fun file_name -> - FStar_Errors.with_ctx - (Prims.strcat "While loading parsing data from " file_name) - (fun uu___ -> - let cache_file = - try - (fun uu___1 -> - match () with - | () -> - let uu___2 = FStar_Parser_Dep.cache_file_name file_name in - FStar_Pervasives_Native.Some uu___2) () - with | uu___1 -> FStar_Pervasives_Native.None in - match cache_file with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some cache_file1 -> - let uu___1 = load_checked_file file_name cache_file1 in - (match uu___1 with - | (uu___2, FStar_Pervasives.Inl msg) -> - FStar_Pervasives_Native.None - | (uu___2, FStar_Pervasives.Inr data) -> - FStar_Pervasives_Native.Some data)) -let (load_module_from_cache : - FStar_TypeChecker_Env.env -> - Prims.string -> tc_result FStar_Pervasives_Native.option) - = - let already_failed = FStar_Compiler_Util.mk_ref false in - fun env -> - fun fn -> - FStar_Errors.with_ctx - (Prims.strcat "While loading module from file " fn) - (fun uu___ -> - let load_it fn1 uu___1 = - let cache_file = FStar_Parser_Dep.cache_file_name fn1 in - let fail msg cache_file1 = - let suppress_warning = - (FStar_Options.should_check_file fn1) || - (FStar_Compiler_Effect.op_Bang already_failed) in - if Prims.op_Negation suppress_warning - then - (FStar_Compiler_Effect.op_Colon_Equals already_failed true; - (let uu___3 = - let uu___4 = - FStar_Compiler_Range_Type.mk_pos Prims.int_zero - Prims.int_zero in - let uu___5 = - FStar_Compiler_Range_Type.mk_pos Prims.int_zero - Prims.int_zero in - FStar_Compiler_Range_Type.mk_range fn1 uu___4 uu___5 in - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Compiler_Util.format3 - "Unable to load %s since %s; will recheck %s (suppressing this warning for further modules)" - cache_file1 msg fn1 in - FStar_Errors_Msg.text uu___6 in - [uu___5] in - FStar_Errors.log_issue FStar_Class_HasRange.hasRange_range - uu___3 FStar_Errors_Codes.Warning_CachedFile () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___4))) - else () in - let uu___2 = - let uu___3 = FStar_TypeChecker_Env.dep_graph env in - load_checked_file_with_tc_result uu___3 fn1 cache_file in - match uu___2 with - | FStar_Pervasives.Inl msg -> - (fail msg cache_file; FStar_Pervasives_Native.None) - | FStar_Pervasives.Inr tc_result1 -> - ((let uu___4 = FStar_Compiler_Effect.op_Bang dbg in - if uu___4 - then - FStar_Compiler_Util.print1 - "Successfully loaded module from checked file %s\n" - cache_file - else ()); - FStar_Pervasives_Native.Some tc_result1) in - let load_with_profiling fn1 = - FStar_Profiling.profile (load_it fn1) - FStar_Pervasives_Native.None "FStar.CheckedFiles" in - let i_fn_opt = - let uu___1 = FStar_TypeChecker_Env.dep_graph env in - let uu___2 = FStar_Parser_Dep.lowercase_module_name fn in - FStar_Parser_Dep.interface_of uu___1 uu___2 in - let uu___1 = - (FStar_Parser_Dep.is_implementation fn) && - (FStar_Compiler_Util.is_some i_fn_opt) in - if uu___1 - then - let i_fn = FStar_Compiler_Util.must i_fn_opt in - let i_tc = load_with_profiling i_fn in - match i_tc with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some uu___2 -> load_with_profiling fn - else load_with_profiling fn) -let (store_values_to_cache : - Prims.string -> - checked_file_entry_stage1 -> checked_file_entry_stage2 -> unit) - = - fun cache_file -> - fun stage1 -> - fun stage2 -> - FStar_Errors.with_ctx - (Prims.strcat "While writing checked file " cache_file) - (fun uu___ -> - FStar_Compiler_Util.save_2values_to_file cache_file stage1 - stage2) -let (store_module_to_cache : - FStar_TypeChecker_Env.env -> - Prims.string -> FStar_Parser_Dep.parsing_data -> tc_result -> unit) - = - fun env -> - fun fn -> - fun parsing_data -> - fun tc_result1 -> - let uu___ = - (FStar_Options.cache_checked_modules ()) && - (let uu___1 = FStar_Options.cache_off () in - Prims.op_Negation uu___1) in - if uu___ - then - let cache_file = FStar_Parser_Dep.cache_file_name fn in - let digest = - let uu___1 = FStar_TypeChecker_Env.dep_graph env in - hash_dependences uu___1 fn in - match digest with - | FStar_Pervasives.Inr hashes -> - let tc_result2 = - { - checked_module = (tc_result1.checked_module); - mii = (tc_result1.mii); - smt_decls = (tc_result1.smt_decls); - tc_time = Prims.int_zero; - extraction_time = Prims.int_zero - } in - let stage1 = - let uu___1 = FStar_Compiler_Util.digest_of_file fn in - { - version = cache_version_number; - digest = uu___1; - parsing_data - } in - let stage2 = { deps_dig = hashes; tc_res = tc_result2 } in - store_values_to_cache cache_file stage1 stage2 - | FStar_Pervasives.Inl msg -> - let uu___1 = - let uu___2 = - FStar_Compiler_Range_Type.mk_pos Prims.int_zero - Prims.int_zero in - let uu___3 = - FStar_Compiler_Range_Type.mk_pos Prims.int_zero - Prims.int_zero in - FStar_Compiler_Range_Type.mk_range fn uu___2 uu___3 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Compiler_Util.format1 - "Checked file %s was not written." cache_file in - FStar_Errors_Msg.text uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = FStar_Pprint.doc_of_string "Reason:" in - let uu___7 = FStar_Errors_Msg.text msg in - FStar_Pprint.prefix (Prims.of_int (2)) Prims.int_one - uu___6 uu___7 in - [uu___5] in - uu___3 :: uu___4 in - FStar_Errors.log_issue FStar_Class_HasRange.hasRange_range - uu___1 FStar_Errors_Codes.Warning_FileNotWritten () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___2) - else () -let (unsafe_raw_load_checked_file : - Prims.string -> - (FStar_Parser_Dep.parsing_data * Prims.string Prims.list * tc_result) - FStar_Pervasives_Native.option) - = - fun checked_fn -> - let entry = FStar_Compiler_Util.load_2values_from_file checked_fn in - match entry with - | FStar_Pervasives_Native.Some (s1, s2) -> - let uu___ = - let uu___1 = - FStar_Compiler_List.map FStar_Pervasives_Native.fst s2.deps_dig in - ((s1.parsing_data), uu___1, (s2.tc_res)) in - FStar_Pervasives_Native.Some uu___ - | uu___ -> FStar_Pervasives_Native.None \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Class_Binders.ml b/ocaml/fstar-lib/generated/FStar_Class_Binders.ml deleted file mode 100644 index 4b59d1215d7..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Class_Binders.ml +++ /dev/null @@ -1,80 +0,0 @@ -open Prims -type 'a hasNames = - { - freeNames: 'a -> FStar_Syntax_Syntax.bv FStar_Compiler_FlatSet.flat_set } -let __proj__MkhasNames__item__freeNames : - 'a . - 'a hasNames -> - 'a -> FStar_Syntax_Syntax.bv FStar_Compiler_FlatSet.flat_set - = fun projectee -> match projectee with | { freeNames;_} -> freeNames -let freeNames : - 'a . - 'a hasNames -> - 'a -> FStar_Syntax_Syntax.bv FStar_Compiler_FlatSet.flat_set - = - fun projectee -> - match projectee with | { freeNames = freeNames1;_} -> freeNames1 -type 'a hasBinders = - { - boundNames: 'a -> FStar_Syntax_Syntax.bv FStar_Compiler_FlatSet.flat_set } -let __proj__MkhasBinders__item__boundNames : - 'a . - 'a hasBinders -> - 'a -> FStar_Syntax_Syntax.bv FStar_Compiler_FlatSet.flat_set - = fun projectee -> match projectee with | { boundNames;_} -> boundNames -let boundNames : - 'a . - 'a hasBinders -> - 'a -> FStar_Syntax_Syntax.bv FStar_Compiler_FlatSet.flat_set - = - fun projectee -> - match projectee with | { boundNames = boundNames1;_} -> boundNames1 -let (hasNames_term : FStar_Syntax_Syntax.term hasNames) = - { freeNames = FStar_Syntax_Free.names } -let (hasNames_comp : FStar_Syntax_Syntax.comp hasNames) = - { - freeNames = - (fun c -> - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total t -> FStar_Syntax_Free.names t - | FStar_Syntax_Syntax.GTotal t -> FStar_Syntax_Free.names t - | FStar_Syntax_Syntax.Comp ct -> - let uu___ = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) ()) in - let uu___1 = - let uu___2 = - FStar_Syntax_Free.names ct.FStar_Syntax_Syntax.result_typ in - let uu___3 = - FStar_Compiler_List.map - (fun uu___4 -> - match uu___4 with - | (a, uu___5) -> FStar_Syntax_Free.names a) - ct.FStar_Syntax_Syntax.effect_args in - uu___2 :: uu___3 in - FStar_Compiler_List.fold_left - (fun uu___3 -> - fun uu___2 -> - (Obj.magic - (FStar_Class_Setlike.union () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)))) uu___3 uu___2) - uu___ uu___1) - } -let (hasBinders_list_bv : FStar_Syntax_Syntax.bv Prims.list hasBinders) = - { - boundNames = - (fun uu___ -> - (Obj.magic - (FStar_Class_Setlike.from_list () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)))) uu___) - } -let (hasBinders_set_bv : - FStar_Syntax_Syntax.bv FStar_Compiler_FlatSet.flat_set hasBinders) = - { boundNames = (fun x -> x) } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Class_Embeddable.ml b/ocaml/fstar-lib/generated/FStar_Class_Embeddable.ml index b16b908853a..a9669e2ecb2 100644 --- a/ocaml/fstar-lib/generated/FStar_Class_Embeddable.ml +++ b/ocaml/fstar-lib/generated/FStar_Class_Embeddable.ml @@ -1,97 +1,97 @@ open Prims type 'a embeddable = { - embed: 'a -> FStar_Reflection_Types.term ; - typ: FStar_Reflection_Types.term } + embed: 'a -> FStarC_Reflection_Types.term ; + typ: FStarC_Reflection_Types.term } let __proj__Mkembeddable__item__embed : - 'a . 'a embeddable -> 'a -> FStar_Reflection_Types.term = + 'a . 'a embeddable -> 'a -> FStarC_Reflection_Types.term = fun projectee -> match projectee with | { embed; typ;_} -> embed let __proj__Mkembeddable__item__typ : - 'a . 'a embeddable -> FStar_Reflection_Types.term = + 'a . 'a embeddable -> FStarC_Reflection_Types.term = fun projectee -> match projectee with | { embed; typ;_} -> typ -let embed : 'a . 'a embeddable -> 'a -> FStar_Reflection_Types.term = +let embed : 'a . 'a embeddable -> 'a -> FStarC_Reflection_Types.term = fun projectee -> match projectee with | { embed = embed1; typ;_} -> embed1 -let typ : 'a . 'a embeddable -> FStar_Reflection_Types.term = +let typ : 'a . 'a embeddable -> FStarC_Reflection_Types.term = fun projectee -> match projectee with | { embed = embed1; typ = typ1;_} -> typ1 let (embeddable_string : Prims.string embeddable) = { embed = (fun s -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const - (FStar_Reflection_V2_Data.C_String s))); + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const + (FStarC_Reflection_V2_Data.C_String s))); typ = - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv ["Prims"; "string"]))) + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "string"]))) } let (embeddable_bool : Prims.bool embeddable) = { embed = (fun b -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const (if b - then FStar_Reflection_V2_Data.C_True - else FStar_Reflection_V2_Data.C_False))); + then FStarC_Reflection_V2_Data.C_True + else FStarC_Reflection_V2_Data.C_False))); typ = - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv ["Prims"; "bool"]))) + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "bool"]))) } let (embeddable_int : Prims.int embeddable) = { embed = (fun i -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const - (FStar_Reflection_V2_Data.C_Int i))); + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const + (FStarC_Reflection_V2_Data.C_Int i))); typ = - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv ["Prims"; "int"]))) + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "int"]))) } let rec e_list : - 'a . 'a embeddable -> 'a Prims.list -> FStar_Reflection_Types.term = + 'a . 'a embeddable -> 'a Prims.list -> FStarC_Reflection_Types.term = fun ea -> fun xs -> match xs with | [] -> let uu___ = ea.typ in - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv ["Prims"; "Nil"]))), - (uu___, FStar_Reflection_V2_Data.Q_Implicit))) + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "Nil"]))), + (uu___, FStarC_Reflection_V2_Data.Q_Implicit))) | x::xs1 -> let uu___ = e_list ea xs1 in let uu___1 = embed ea x in let uu___2 = ea.typ in - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "Cons"]))), - (uu___2, FStar_Reflection_V2_Data.Q_Implicit)))), - (uu___1, FStar_Reflection_V2_Data.Q_Explicit)))), - (uu___, FStar_Reflection_V2_Data.Q_Explicit))) + (uu___2, FStarC_Reflection_V2_Data.Q_Implicit)))), + (uu___1, FStarC_Reflection_V2_Data.Q_Explicit)))), + (uu___, FStarC_Reflection_V2_Data.Q_Explicit))) let embeddable_list : 'a . 'a embeddable -> 'a Prims.list embeddable = fun ea -> { embed = (e_list ea); typ = (let uu___ = ea.typ in - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv ["Prims"; "list"]))), - (uu___, FStar_Reflection_V2_Data.Q_Explicit)))) + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "list"]))), + (uu___, FStarC_Reflection_V2_Data.Q_Explicit)))) } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Class_HasRange.ml b/ocaml/fstar-lib/generated/FStar_Class_HasRange.ml deleted file mode 100644 index 774bcf97cdb..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Class_HasRange.ml +++ /dev/null @@ -1,19 +0,0 @@ -open Prims -type 'a hasRange = - { - pos: 'a -> FStar_Compiler_Range_Type.range ; - setPos: FStar_Compiler_Range_Type.range -> 'a -> 'a } -let __proj__MkhasRange__item__pos : - 'a . 'a hasRange -> 'a -> FStar_Compiler_Range_Type.range = - fun projectee -> match projectee with | { pos; setPos;_} -> pos -let __proj__MkhasRange__item__setPos : - 'a . 'a hasRange -> FStar_Compiler_Range_Type.range -> 'a -> 'a = - fun projectee -> match projectee with | { pos; setPos;_} -> setPos -let pos : 'a . 'a hasRange -> 'a -> FStar_Compiler_Range_Type.range = - fun projectee -> match projectee with | { pos = pos1; setPos;_} -> pos1 -let setPos : 'a . 'a hasRange -> FStar_Compiler_Range_Type.range -> 'a -> 'a - = - fun projectee -> - match projectee with | { pos = pos1; setPos = setPos1;_} -> setPos1 -let (hasRange_range : FStar_Compiler_Range_Type.range hasRange) = - { pos = (fun x -> x); setPos = (fun r -> fun uu___ -> r) } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Class_Hashable.ml b/ocaml/fstar-lib/generated/FStar_Class_Hashable.ml deleted file mode 100644 index a8dd25810d3..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Class_Hashable.ml +++ /dev/null @@ -1,194 +0,0 @@ -open Prims -type 'a hashable = { - hash: 'a -> FStar_Hash.hash_code } -let __proj__Mkhashable__item__hash : - 'a . 'a hashable -> 'a -> FStar_Hash.hash_code = - fun projectee -> match projectee with | { hash;_} -> hash -let hash : 'a . 'a hashable -> 'a -> FStar_Hash.hash_code = - fun projectee -> match projectee with | { hash = hash1;_} -> hash1 -let (showable_hash_code : FStar_Hash.hash_code FStar_Class_Show.showable) = - { FStar_Class_Show.show = FStar_Hash.string_of_hash_code } -let (eq_hash_code : FStar_Hash.hash_code FStar_Class_Deq.deq) = - { FStar_Class_Deq.op_Equals_Question = (=) } -let (ord_hash_code : FStar_Hash.hash_code FStar_Class_Ord.ord) = - { - FStar_Class_Ord.super = eq_hash_code; - FStar_Class_Ord.cmp = - (fun x -> - fun y -> - let uu___ = FStar_Hash.cmp_hash x y in - FStar_Compiler_Order.order_from_int uu___) - } -let (hashable_int : Prims.int hashable) = { hash = FStar_Hash.of_int } -let (hashable_string : Prims.string hashable) = - { hash = FStar_Hash.of_string } -let (hashable_bool : Prims.bool hashable) = - { - hash = - (fun b -> - if b - then FStar_Hash.of_int Prims.int_one - else FStar_Hash.of_int (Prims.of_int (2))) - } -let hashable_list : 'a . 'a hashable -> 'a Prims.list hashable = - fun uu___ -> - { - hash = - (fun xs -> - let uu___1 = FStar_Hash.of_int Prims.int_zero in - FStar_Compiler_List.fold_left - (fun h -> - fun x -> let uu___2 = hash uu___ x in FStar_Hash.mix h uu___2) - uu___1 xs) - } -let hashable_option : - 'a . 'a hashable -> 'a FStar_Pervasives_Native.option hashable = - fun uu___ -> - { - hash = - (fun x -> - match x with - | FStar_Pervasives_Native.None -> FStar_Hash.of_int Prims.int_zero - | FStar_Pervasives_Native.Some x1 -> - let uu___1 = FStar_Hash.of_int Prims.int_one in - let uu___2 = hash uu___ x1 in FStar_Hash.mix uu___1 uu___2) - } -let hashable_either : - 'a 'b . - 'a hashable -> 'b hashable -> ('a, 'b) FStar_Pervasives.either hashable - = - fun uu___ -> - fun uu___1 -> - { - hash = - (fun x -> - match x with - | FStar_Pervasives.Inl a1 -> - let uu___2 = FStar_Hash.of_int Prims.int_zero in - let uu___3 = hash uu___ a1 in FStar_Hash.mix uu___2 uu___3 - | FStar_Pervasives.Inr b1 -> - let uu___2 = FStar_Hash.of_int Prims.int_one in - let uu___3 = hash uu___1 b1 in FStar_Hash.mix uu___2 uu___3) - } -let hashable_tuple2 : - 'a 'b . 'a hashable -> 'b hashable -> ('a * 'b) hashable = - fun uu___ -> - fun uu___1 -> - { - hash = - (fun uu___2 -> - match uu___2 with - | (a1, b1) -> - let uu___3 = hash uu___ a1 in - let uu___4 = hash uu___1 b1 in FStar_Hash.mix uu___3 uu___4) - } -let hashable_tuple3 : - 'a 'b 'c . - 'a hashable -> 'b hashable -> 'c hashable -> ('a * 'b * 'c) hashable - = - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - { - hash = - (fun uu___3 -> - match uu___3 with - | (a1, b1, c1) -> - let uu___4 = - let uu___5 = hash uu___ a1 in - let uu___6 = hash uu___1 b1 in - FStar_Hash.mix uu___5 uu___6 in - let uu___5 = hash uu___2 c1 in - FStar_Hash.mix uu___4 uu___5) - } -let hashable_tuple4 : - 'a 'b 'c 'd . - 'a hashable -> - 'b hashable -> - 'c hashable -> 'd hashable -> ('a * 'b * 'c * 'd) hashable - = - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - { - hash = - (fun uu___4 -> - match uu___4 with - | (a1, b1, c1, d1) -> - let uu___5 = - let uu___6 = - let uu___7 = hash uu___ a1 in - let uu___8 = hash uu___1 b1 in - FStar_Hash.mix uu___7 uu___8 in - let uu___7 = hash uu___2 c1 in - FStar_Hash.mix uu___6 uu___7 in - let uu___6 = hash uu___3 d1 in - FStar_Hash.mix uu___5 uu___6) - } -let hashable_tuple5 : - 'a 'b 'c 'd 'e . - 'a hashable -> - 'b hashable -> - 'c hashable -> - 'd hashable -> 'e hashable -> ('a * 'b * 'c * 'd * 'e) hashable - = - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun uu___4 -> - { - hash = - (fun uu___5 -> - match uu___5 with - | (a1, b1, c1, d1, e1) -> - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = hash uu___ a1 in - let uu___10 = hash uu___1 b1 in - FStar_Hash.mix uu___9 uu___10 in - let uu___9 = hash uu___2 c1 in - FStar_Hash.mix uu___8 uu___9 in - let uu___8 = hash uu___3 d1 in - FStar_Hash.mix uu___7 uu___8 in - let uu___7 = hash uu___4 e1 in - FStar_Hash.mix uu___6 uu___7) - } -let hashable_tuple6 : - 'a 'b 'c 'd 'e 'f . - 'a hashable -> - 'b hashable -> - 'c hashable -> - 'd hashable -> - 'e hashable -> - 'f hashable -> ('a * 'b * 'c * 'd * 'e * 'f) hashable - = - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun uu___4 -> - fun uu___5 -> - { - hash = - (fun uu___6 -> - match uu___6 with - | (a1, b1, c1, d1, e1, f1) -> - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = hash uu___ a1 in - let uu___12 = hash uu___1 b1 in - FStar_Hash.mix uu___11 uu___12 in - let uu___11 = hash uu___2 c1 in - FStar_Hash.mix uu___10 uu___11 in - let uu___10 = hash uu___3 d1 in - FStar_Hash.mix uu___9 uu___10 in - let uu___9 = hash uu___4 e1 in - FStar_Hash.mix uu___8 uu___9 in - let uu___8 = hash uu___5 f1 in - FStar_Hash.mix uu___7 uu___8) - } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Class_Monad.ml b/ocaml/fstar-lib/generated/FStar_Class_Monad.ml deleted file mode 100644 index 26aa4f5294b..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Class_Monad.ml +++ /dev/null @@ -1,202 +0,0 @@ -open Prims -type 'm monad = - { - return: unit -> Obj.t -> 'm ; - op_let_Bang: unit -> unit -> 'm -> (Obj.t -> 'm) -> 'm } -let __proj__Mkmonad__item__return : 'm . 'm monad -> unit -> Obj.t -> 'm = - fun projectee -> match projectee with | { return; op_let_Bang;_} -> return -let __proj__Mkmonad__item__op_let_Bang : - 'm . 'm monad -> unit -> unit -> 'm -> (Obj.t -> 'm) -> 'm = - fun projectee -> - match projectee with | { return; op_let_Bang;_} -> op_let_Bang -let return : 'm . 'm monad -> unit -> Obj.t -> 'm = - fun projectee -> - match projectee with | { return = return1; op_let_Bang;_} -> return1 -let op_let_Bang : 'm . 'm monad -> unit -> unit -> 'm -> (Obj.t -> 'm) -> 'm - = - fun projectee -> - match projectee with - | { return = return1; op_let_Bang = op_let_Bang1;_} -> op_let_Bang1 -let (monad_option : unit FStar_Pervasives_Native.option monad) = - { - return = - (fun uu___1 -> - fun uu___ -> - (fun a -> fun x -> Obj.magic (FStar_Pervasives_Native.Some x)) - uu___1 uu___); - op_let_Bang = - (fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun uu___1 -> - fun uu___ -> Obj.magic FStar_Compiler_Util.bind_opt) uu___3 - uu___2 uu___1 uu___) - } -let (monad_list : unit Prims.list monad) = - { - return = - (fun uu___1 -> - fun uu___ -> (fun a -> fun x -> Obj.magic [x]) uu___1 uu___); - op_let_Bang = - (fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun a -> - fun b -> - fun x -> - let x = Obj.magic x in - fun f -> - let f = Obj.magic f in - Obj.magic (FStar_Compiler_List.concatMap f x)) uu___3 - uu___2 uu___1 uu___) - } -let rec mapM : - 'm . 'm monad -> unit -> unit -> (Obj.t -> 'm) -> Obj.t Prims.list -> 'm = - fun uu___ -> - fun a -> - fun b -> - fun f -> - fun l -> - match l with - | [] -> return uu___ () (Obj.magic []) - | x::xs -> - let uu___1 = f x in - op_let_Bang uu___ () () uu___1 - (fun y -> - let uu___2 = mapM uu___ () () f xs in - op_let_Bang uu___ () () uu___2 - (fun uu___3 -> - (fun ys -> - let ys = Obj.magic ys in - Obj.magic - (return uu___ () (Obj.magic (y :: ys)))) - uu___3)) -let mapMi : - 'm . - 'm monad -> - unit -> unit -> (Prims.int -> Obj.t -> 'm) -> Obj.t Prims.list -> 'm - = - fun uu___ -> - fun a -> - fun b -> - fun f -> - fun l -> - let rec mapMi_go i f1 l1 = - match l1 with - | [] -> return uu___ () (Obj.magic []) - | x::xs -> - let uu___1 = f1 i x in - op_let_Bang uu___ () () uu___1 - (fun y -> - let uu___2 = mapMi_go (i + Prims.int_one) f1 xs in - op_let_Bang uu___ () () uu___2 - (fun uu___3 -> - (fun ys -> - let ys = Obj.magic ys in - Obj.magic - (return uu___ () (Obj.magic (y :: ys)))) - uu___3)) in - mapMi_go Prims.int_zero f l -let map_optM : - 'm . - 'm monad -> - unit -> - unit -> (Obj.t -> 'm) -> Obj.t FStar_Pervasives_Native.option -> 'm - = - fun uu___ -> - fun a -> - fun b -> - fun f -> - fun l -> - match l with - | FStar_Pervasives_Native.None -> - return uu___ () (Obj.magic FStar_Pervasives_Native.None) - | FStar_Pervasives_Native.Some x -> - let uu___1 = f x in - op_let_Bang uu___ () () uu___1 - (fun x1 -> - return uu___ () - (Obj.magic (FStar_Pervasives_Native.Some x1))) -let rec iterM : - 'm . 'm monad -> unit -> (Obj.t -> 'm) -> Obj.t Prims.list -> 'm = - fun uu___ -> - fun a -> - fun f -> - fun l -> - match l with - | [] -> return uu___ () (Obj.repr ()) - | x::xs -> - let uu___1 = f x in - op_let_Bang uu___ () () uu___1 - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - Obj.magic (iterM uu___ () f xs)) uu___2) -let rec foldM_left : - 'm . - 'm monad -> - unit -> - unit -> (Obj.t -> Obj.t -> 'm) -> Obj.t -> Obj.t Prims.list -> 'm - = - fun uu___ -> - fun a -> - fun b -> - fun f -> - fun e -> - fun xs -> - match xs with - | [] -> return uu___ () e - | x::xs1 -> - let uu___1 = f e x in - op_let_Bang uu___ () () uu___1 - (fun e' -> foldM_left uu___ () () f e' xs1) -let rec foldM_right : - 'm . - 'm monad -> - unit -> - unit -> (Obj.t -> Obj.t -> 'm) -> Obj.t Prims.list -> Obj.t -> 'm - = - fun uu___ -> - fun a -> - fun b -> - fun f -> - fun xs -> - fun e -> - match xs with - | [] -> return uu___ () e - | x::xs1 -> - let uu___1 = foldM_right uu___ () () f xs1 e in - op_let_Bang uu___ () () uu___1 (fun e' -> f x e') -let op_Less_Dollar_Greater : - 'm . 'm monad -> unit -> unit -> (Obj.t -> Obj.t) -> 'm -> 'm = - fun uu___ -> - fun a -> - fun b -> - fun f -> - fun x -> - op_let_Bang uu___ () () x - (fun v -> let uu___1 = f v in return uu___ () uu___1) -let op_Less_Star_Greater : 'm . 'm monad -> unit -> unit -> 'm -> 'm -> 'm = - fun uu___ -> - fun a -> - fun b -> - fun ff -> - fun x -> - op_let_Bang uu___ () () ff - (fun uu___1 -> - (fun f -> - let f = Obj.magic f in - Obj.magic - (op_let_Bang uu___ () () x - (fun v -> let uu___1 = f v in return uu___ () uu___1))) - uu___1) -let fmap : 'm . 'm monad -> unit -> unit -> (Obj.t -> Obj.t) -> 'm -> 'm = - fun uu___ -> - fun a -> - fun b -> - fun f -> - fun m1 -> - op_let_Bang uu___ () () m1 - (fun v -> let uu___1 = f v in return uu___ () uu___1) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Class_Monoid.ml b/ocaml/fstar-lib/generated/FStar_Class_Monoid.ml deleted file mode 100644 index 4f7e7598988..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Class_Monoid.ml +++ /dev/null @@ -1,26 +0,0 @@ -open Prims -type 'a monoid = { - mzero: 'a ; - mplus: 'a -> 'a -> 'a } -let __proj__Mkmonoid__item__mzero : 'a . 'a monoid -> 'a = - fun projectee -> match projectee with | { mzero; mplus;_} -> mzero -let __proj__Mkmonoid__item__mplus : 'a . 'a monoid -> 'a -> 'a -> 'a = - fun projectee -> match projectee with | { mzero; mplus;_} -> mplus -let mzero : 'a . 'a monoid -> 'a = - fun projectee -> - match projectee with | { mzero = mzero1; mplus;_} -> mzero1 -let mplus : 'a . 'a monoid -> 'a -> 'a -> 'a = - fun projectee -> - match projectee with | { mzero = mzero1; mplus = mplus1;_} -> mplus1 -let op_Plus_Plus : 'a . 'a monoid -> 'a -> 'a -> 'a = - fun uu___ -> mplus uu___ -let msum : 'a . 'a monoid -> 'a Prims.list -> 'a = - fun uu___ -> - fun xs -> FStar_Compiler_List.fold_left (mplus uu___) (mzero uu___) xs -let (monoid_int : Prims.int monoid) = - { mzero = Prims.int_zero; mplus = (fun x -> fun y -> x + y) } -let (monoid_string : Prims.string monoid) = - { mzero = ""; mplus = (fun x -> fun y -> Prims.strcat x y) } -let monoid_list : 'a . unit -> 'a Prims.list monoid = - fun uu___ -> - { mzero = []; mplus = (fun x -> fun y -> FStar_Compiler_List.op_At x y) } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Class_Ord.ml b/ocaml/fstar-lib/generated/FStar_Class_Ord.ml deleted file mode 100644 index ef06b639f59..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Class_Ord.ml +++ /dev/null @@ -1,272 +0,0 @@ -open Prims -type 'a ord = - { - super: 'a FStar_Class_Deq.deq ; - cmp: 'a -> 'a -> FStar_Compiler_Order.order } -let __proj__Mkord__item__super : 'a . 'a ord -> 'a FStar_Class_Deq.deq = - fun projectee -> match projectee with | { super; cmp;_} -> super -let __proj__Mkord__item__cmp : - 'a . 'a ord -> 'a -> 'a -> FStar_Compiler_Order.order = - fun projectee -> match projectee with | { super; cmp;_} -> cmp -let super : 'a . 'a ord -> 'a FStar_Class_Deq.deq = - fun projectee -> match projectee with | { super = super1; cmp;_} -> super1 -let cmp : 'a . 'a ord -> 'a -> 'a -> FStar_Compiler_Order.order = - fun projectee -> - match projectee with | { super = super1; cmp = cmp1;_} -> cmp1 -let op_Less_Question : 'a . 'a ord -> 'a -> 'a -> Prims.bool = - fun uu___ -> - fun x -> - fun y -> let uu___1 = cmp uu___ x y in uu___1 = FStar_Compiler_Order.Lt -let op_Less_Equals_Question : 'a . 'a ord -> 'a -> 'a -> Prims.bool = - fun uu___ -> - fun x -> - fun y -> - let uu___1 = cmp uu___ x y in uu___1 <> FStar_Compiler_Order.Gt -let op_Greater_Question : 'a . 'a ord -> 'a -> 'a -> Prims.bool = - fun uu___ -> - fun x -> - fun y -> let uu___1 = cmp uu___ x y in uu___1 = FStar_Compiler_Order.Gt -let op_Greater_Equals_Question : 'a . 'a ord -> 'a -> 'a -> Prims.bool = - fun uu___ -> - fun x -> - fun y -> - let uu___1 = cmp uu___ x y in uu___1 <> FStar_Compiler_Order.Lt -let min : 'a . 'a ord -> 'a -> 'a -> 'a = - fun uu___ -> - fun x -> - fun y -> - let uu___1 = op_Less_Equals_Question uu___ x y in - if uu___1 then x else y -let max : 'a . 'a ord -> 'a -> 'a -> 'a = - fun uu___ -> - fun x -> - fun y -> - let uu___1 = op_Greater_Equals_Question uu___ x y in - if uu___1 then x else y -let ord_eq : 'a . 'a ord -> 'a FStar_Class_Deq.deq = fun d -> d.super -let rec insert : 'a . 'a ord -> 'a -> 'a Prims.list -> 'a Prims.list = - fun uu___ -> - fun x -> - fun xs -> - match xs with - | [] -> [x] - | y::ys -> - let uu___1 = op_Less_Equals_Question uu___ x y in - if uu___1 - then x :: y :: ys - else (let uu___3 = insert uu___ x ys in y :: uu___3) -let rec sort : 'a . 'a ord -> 'a Prims.list -> 'a Prims.list = - fun uu___ -> - fun xs -> - match xs with - | [] -> [] - | x::xs1 -> let uu___1 = sort uu___ xs1 in insert uu___ x uu___1 -let dedup : 'a . 'a ord -> 'a Prims.list -> 'a Prims.list = - fun uu___ -> - fun xs -> - let out = - FStar_Compiler_List.fold_left - (fun out1 -> - fun x -> - let uu___1 = - FStar_Compiler_List.existsb - (fun y -> - FStar_Class_Deq.op_Equals_Question (ord_eq uu___) x y) - out1 in - if uu___1 then out1 else x :: out1) [] xs in - FStar_Compiler_List.rev out -let (ord_int : Prims.int ord) = - { super = FStar_Class_Deq.deq_int; cmp = FStar_Compiler_Order.compare_int } -let (ord_bool : Prims.bool ord) = - { super = FStar_Class_Deq.deq_bool; cmp = FStar_Compiler_Order.compare_bool - } -let (ord_unit : unit ord) = - { - super = FStar_Class_Deq.deq_unit; - cmp = (fun uu___ -> fun uu___1 -> FStar_Compiler_Order.Eq) - } -let (ord_string : Prims.string ord) = - { - super = FStar_Class_Deq.deq_string; - cmp = - (fun x -> - fun y -> - FStar_Compiler_Order.order_from_int - (FStar_Compiler_String.compare x y)) - } -let ord_option : 'a . 'a ord -> 'a FStar_Pervasives_Native.option ord = - fun d -> - { - super = (FStar_Class_Deq.deq_option (ord_eq d)); - cmp = - (fun x -> - fun y -> - match (x, y) with - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) - -> FStar_Compiler_Order.Eq - | (FStar_Pervasives_Native.Some uu___, - FStar_Pervasives_Native.None) -> FStar_Compiler_Order.Gt - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.Some - uu___) -> FStar_Compiler_Order.Lt - | (FStar_Pervasives_Native.Some x1, FStar_Pervasives_Native.Some - y1) -> cmp d x1 y1) - } -let ord_list : 'a . 'a ord -> 'a Prims.list ord = - fun d -> - { - super = (FStar_Class_Deq.deq_list (ord_eq d)); - cmp = - (fun l1 -> fun l2 -> FStar_Compiler_Order.compare_list l1 l2 (cmp d)) - } -let ord_either : - 'a 'b . 'a ord -> 'b ord -> ('a, 'b) FStar_Pervasives.either ord = - fun d1 -> - fun d2 -> - { - super = (FStar_Class_Deq.deq_either (ord_eq d1) (ord_eq d2)); - cmp = - (fun x -> - fun y -> - match (x, y) with - | (FStar_Pervasives.Inl uu___, FStar_Pervasives.Inr uu___1) -> - FStar_Compiler_Order.Lt - | (FStar_Pervasives.Inr uu___, FStar_Pervasives.Inl uu___1) -> - FStar_Compiler_Order.Gt - | (FStar_Pervasives.Inl x1, FStar_Pervasives.Inl y1) -> - cmp d1 x1 y1 - | (FStar_Pervasives.Inr x1, FStar_Pervasives.Inr y1) -> - cmp d2 x1 y1) - } -let ord_tuple2 : 'a 'b . 'a ord -> 'b ord -> ('a * 'b) ord = - fun d1 -> - fun d2 -> - { - super = (FStar_Class_Deq.deq_tuple2 (ord_eq d1) (ord_eq d2)); - cmp = - (fun uu___ -> - fun uu___1 -> - match (uu___, uu___1) with - | ((x1, x2), (y1, y2)) -> - let uu___2 = cmp d1 x1 y1 in - FStar_Compiler_Order.lex uu___2 - (fun uu___3 -> cmp d2 x2 y2)) - } -let ord_tuple3 : 'a 'b 'c . 'a ord -> 'b ord -> 'c ord -> ('a * 'b * 'c) ord - = - fun d1 -> - fun d2 -> - fun d3 -> - { - super = - (FStar_Class_Deq.deq_tuple3 (ord_eq d1) (ord_eq d2) (ord_eq d3)); - cmp = - (fun uu___ -> - fun uu___1 -> - match (uu___, uu___1) with - | ((x1, x2, x3), (y1, y2, y3)) -> - let uu___2 = cmp d1 x1 y1 in - FStar_Compiler_Order.lex uu___2 - (fun uu___3 -> - let uu___4 = cmp d2 x2 y2 in - FStar_Compiler_Order.lex uu___4 - (fun uu___5 -> cmp d3 x3 y3))) - } -let ord_tuple4 : - 'a 'b 'c 'd . - 'a ord -> 'b ord -> 'c ord -> 'd ord -> ('a * 'b * 'c * 'd) ord - = - fun d1 -> - fun d2 -> - fun d3 -> - fun d4 -> - { - super = - (FStar_Class_Deq.deq_tuple4 (ord_eq d1) (ord_eq d2) (ord_eq d3) - (ord_eq d4)); - cmp = - (fun uu___ -> - fun uu___1 -> - match (uu___, uu___1) with - | ((x1, x2, x3, x4), (y1, y2, y3, y4)) -> - let uu___2 = cmp d1 x1 y1 in - FStar_Compiler_Order.lex uu___2 - (fun uu___3 -> - let uu___4 = cmp d2 x2 y2 in - FStar_Compiler_Order.lex uu___4 - (fun uu___5 -> - let uu___6 = cmp d3 x3 y3 in - FStar_Compiler_Order.lex uu___6 - (fun uu___7 -> cmp d4 x4 y4)))) - } -let ord_tuple5 : - 'a 'b 'c 'd 'e . - 'a ord -> - 'b ord -> 'c ord -> 'd ord -> 'e ord -> ('a * 'b * 'c * 'd * 'e) ord - = - fun d1 -> - fun d2 -> - fun d3 -> - fun d4 -> - fun d5 -> - { - super = - (FStar_Class_Deq.deq_tuple5 (ord_eq d1) (ord_eq d2) - (ord_eq d3) (ord_eq d4) (ord_eq d5)); - cmp = - (fun uu___ -> - fun uu___1 -> - match (uu___, uu___1) with - | ((x1, x2, x3, x4, x5), (y1, y2, y3, y4, y5)) -> - let uu___2 = cmp d1 x1 y1 in - FStar_Compiler_Order.lex uu___2 - (fun uu___3 -> - let uu___4 = cmp d2 x2 y2 in - FStar_Compiler_Order.lex uu___4 - (fun uu___5 -> - let uu___6 = cmp d3 x3 y3 in - FStar_Compiler_Order.lex uu___6 - (fun uu___7 -> - let uu___8 = cmp d4 x4 y4 in - FStar_Compiler_Order.lex uu___8 - (fun uu___9 -> cmp d5 x5 y5))))) - } -let ord_tuple6 : - 'a 'b 'c 'd 'e 'f . - 'a ord -> - 'b ord -> - 'c ord -> - 'd ord -> 'e ord -> 'f ord -> ('a * 'b * 'c * 'd * 'e * 'f) ord - = - fun d1 -> - fun d2 -> - fun d3 -> - fun d4 -> - fun d5 -> - fun d6 -> - { - super = - (FStar_Class_Deq.deq_tuple6 (ord_eq d1) (ord_eq d2) - (ord_eq d3) (ord_eq d4) (ord_eq d5) (ord_eq d6)); - cmp = - (fun uu___ -> - fun uu___1 -> - match (uu___, uu___1) with - | ((x1, x2, x3, x4, x5, x6), (y1, y2, y3, y4, y5, y6)) - -> - let uu___2 = cmp d1 x1 y1 in - FStar_Compiler_Order.lex uu___2 - (fun uu___3 -> - let uu___4 = cmp d2 x2 y2 in - FStar_Compiler_Order.lex uu___4 - (fun uu___5 -> - let uu___6 = cmp d3 x3 y3 in - FStar_Compiler_Order.lex uu___6 - (fun uu___7 -> - let uu___8 = cmp d4 x4 y4 in - FStar_Compiler_Order.lex uu___8 - (fun uu___9 -> - let uu___10 = cmp d5 x5 y5 in - FStar_Compiler_Order.lex - uu___10 - (fun uu___11 -> cmp d6 x6 y6)))))) - } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Class_PP.ml b/ocaml/fstar-lib/generated/FStar_Class_PP.ml deleted file mode 100644 index 8fe5cbdae9f..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Class_PP.ml +++ /dev/null @@ -1,234 +0,0 @@ -open Prims -type 'a pretty = { - pp: 'a -> FStar_Pprint.document } -let __proj__Mkpretty__item__pp : - 'a . 'a pretty -> 'a -> FStar_Pprint.document = - fun projectee -> match projectee with | { pp;_} -> pp -let pp : 'a . 'a pretty -> 'a -> FStar_Pprint.document = - fun projectee -> match projectee with | { pp = pp1;_} -> pp1 -let (gparens : FStar_Pprint.document -> FStar_Pprint.document) = - fun a -> - let uu___ = - let uu___1 = FStar_Pprint.parens a in - FStar_Pprint.nest (Prims.of_int (2)) uu___1 in - FStar_Pprint.group uu___ -let (gbrackets : FStar_Pprint.document -> FStar_Pprint.document) = - fun a -> - let uu___ = - let uu___1 = FStar_Pprint.brackets a in - FStar_Pprint.nest (Prims.of_int (2)) uu___1 in - FStar_Pprint.group uu___ -let (pp_unit : unit pretty) = - { pp = (fun uu___ -> FStar_Pprint.doc_of_string "()") } -let (pp_int : Prims.int pretty) = - { pp = (fun x -> FStar_Pprint.doc_of_string (Prims.string_of_int x)) } -let (pp_bool : Prims.bool pretty) = { pp = FStar_Pprint.doc_of_bool } -let pp_list : 'a . 'a pretty -> 'a Prims.list pretty = - fun uu___ -> - { - pp = - (fun l -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Pprint.break_ Prims.int_one in - FStar_Pprint.op_Hat_Hat FStar_Pprint.semi uu___3 in - FStar_Pprint.flow_map uu___2 (pp uu___) l in - gbrackets uu___1) - } -let pp_option : 'a . 'a pretty -> 'a FStar_Pervasives_Native.option pretty = - fun uu___ -> - { - pp = - (fun o -> - match o with - | FStar_Pervasives_Native.Some v -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Pprint.doc_of_string "Some" in - let uu___4 = pp uu___ v in - FStar_Pprint.op_Hat_Slash_Hat uu___3 uu___4 in - FStar_Pprint.nest (Prims.of_int (2)) uu___2 in - FStar_Pprint.group uu___1 - | FStar_Pervasives_Native.None -> - FStar_Pprint.doc_of_string "None") - } -let pp_either : - 'a 'b . 'a pretty -> 'b pretty -> ('a, 'b) FStar_Pervasives.either pretty = - fun uu___ -> - fun uu___1 -> - { - pp = - (fun e -> - let uu___2 = - let uu___3 = - match e with - | FStar_Pervasives.Inl x -> - let uu___4 = FStar_Pprint.doc_of_string "Inl" in - let uu___5 = pp uu___ x in - FStar_Pprint.op_Hat_Slash_Hat uu___4 uu___5 - | FStar_Pervasives.Inr x -> - let uu___4 = FStar_Pprint.doc_of_string "Inr" in - let uu___5 = pp uu___1 x in - FStar_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in - FStar_Pprint.nest (Prims.of_int (2)) uu___3 in - FStar_Pprint.group uu___2) - } -let (comma_space : FStar_Pprint.document) = - let uu___ = FStar_Pprint.break_ Prims.int_one in - FStar_Pprint.op_Hat_Hat FStar_Pprint.comma uu___ -let pp_tuple2 : 'a 'b . 'a pretty -> 'b pretty -> ('a * 'b) pretty = - fun uu___ -> - fun uu___1 -> - { - pp = - (fun uu___2 -> - match uu___2 with - | (x1, x2) -> - let uu___3 = - let uu___4 = - let uu___5 = pp uu___ x1 in - let uu___6 = let uu___7 = pp uu___1 x2 in [uu___7] in - uu___5 :: uu___6 in - FStar_Pprint.separate comma_space uu___4 in - gparens uu___3) - } -let pp_tuple3 : - 'a 'b 'c . 'a pretty -> 'b pretty -> 'c pretty -> ('a * 'b * 'c) pretty = - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - { - pp = - (fun uu___3 -> - match uu___3 with - | (x1, x2, x3) -> - let uu___4 = - let uu___5 = - let uu___6 = pp uu___ x1 in - let uu___7 = - let uu___8 = pp uu___1 x2 in - let uu___9 = let uu___10 = pp uu___2 x3 in [uu___10] in - uu___8 :: uu___9 in - uu___6 :: uu___7 in - FStar_Pprint.separate comma_space uu___5 in - gparens uu___4) - } -let pp_tuple4 : - 'a 'b 'c 'd . - 'a pretty -> - 'b pretty -> 'c pretty -> 'd pretty -> ('a * 'b * 'c * 'd) pretty - = - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - { - pp = - (fun uu___4 -> - match uu___4 with - | (x1, x2, x3, x4) -> - let uu___5 = - let uu___6 = - let uu___7 = pp uu___ x1 in - let uu___8 = - let uu___9 = pp uu___1 x2 in - let uu___10 = - let uu___11 = pp uu___2 x3 in - let uu___12 = - let uu___13 = pp uu___3 x4 in [uu___13] in - uu___11 :: uu___12 in - uu___9 :: uu___10 in - uu___7 :: uu___8 in - FStar_Pprint.separate comma_space uu___6 in - gparens uu___5) - } -let pp_tuple5 : - 'a 'b 'c 'd 'e . - 'a pretty -> - 'b pretty -> - 'c pretty -> - 'd pretty -> 'e pretty -> ('a * 'b * 'c * 'd * 'e) pretty - = - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun uu___4 -> - { - pp = - (fun uu___5 -> - match uu___5 with - | (x1, x2, x3, x4, x5) -> - let uu___6 = - let uu___7 = - let uu___8 = pp uu___ x1 in - let uu___9 = - let uu___10 = pp uu___1 x2 in - let uu___11 = - let uu___12 = pp uu___2 x3 in - let uu___13 = - let uu___14 = pp uu___3 x4 in - let uu___15 = - let uu___16 = pp uu___4 x5 in [uu___16] in - uu___14 :: uu___15 in - uu___12 :: uu___13 in - uu___10 :: uu___11 in - uu___8 :: uu___9 in - FStar_Pprint.separate comma_space uu___7 in - gparens uu___6) - } -let pp_tuple6 : - 'a 'b 'c 'd 'e 'f . - 'a pretty -> - 'b pretty -> - 'c pretty -> - 'd pretty -> - 'e pretty -> 'f pretty -> ('a * 'b * 'c * 'd * 'e * 'f) pretty - = - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun uu___4 -> - fun uu___5 -> - { - pp = - (fun uu___6 -> - match uu___6 with - | (x1, x2, x3, x4, x5, x6) -> - let uu___7 = - let uu___8 = - let uu___9 = pp uu___ x1 in - let uu___10 = - let uu___11 = pp uu___1 x2 in - let uu___12 = - let uu___13 = pp uu___2 x3 in - let uu___14 = - let uu___15 = pp uu___3 x4 in - let uu___16 = - let uu___17 = pp uu___4 x5 in - let uu___18 = - let uu___19 = pp uu___5 x6 in - [uu___19] in - uu___17 :: uu___18 in - uu___15 :: uu___16 in - uu___13 :: uu___14 in - uu___11 :: uu___12 in - uu___9 :: uu___10 in - FStar_Pprint.separate comma_space uu___8 in - gparens uu___7) - } -let pretty_from_showable : 'a . 'a FStar_Class_Show.showable -> 'a pretty = - fun uu___ -> - { - pp = - (fun x -> - let uu___1 = FStar_Class_Show.show uu___ x in - FStar_Pprint.arbitrary_string uu___1) - } -let showable_from_pretty : 'a . 'a pretty -> 'a FStar_Class_Show.showable = - fun uu___ -> - { - FStar_Class_Show.show = - (fun x -> let uu___1 = pp uu___ x in FStar_Pprint.render uu___1) - } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Class_Show.ml b/ocaml/fstar-lib/generated/FStar_Class_Show.ml deleted file mode 100644 index d79429eca09..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Class_Show.ml +++ /dev/null @@ -1,200 +0,0 @@ -open Prims -type 'a showable = { - show: 'a -> Prims.string } -let __proj__Mkshowable__item__show : 'a . 'a showable -> 'a -> Prims.string = - fun projectee -> match projectee with | { show;_} -> show -let show : 'a . 'a showable -> 'a -> Prims.string = - fun projectee -> match projectee with | { show = show1;_} -> show1 -let printableshow : 'a . 'a FStar_Class_Printable.printable -> 'a showable = - fun uu___ -> { show = (FStar_Class_Printable.to_string uu___) } -let show_list : 'a . 'a showable -> 'a Prims.list showable = - fun uu___ -> { show = ((FStar_Common.string_of_list ()) (show uu___)) } -let show_option : - 'a . 'a showable -> 'a FStar_Pervasives_Native.option showable = - fun uu___ -> { show = (FStar_Common.string_of_option (show uu___)) } -let show_either : - 'a 'b . - 'a showable -> 'b showable -> ('a, 'b) FStar_Pervasives.either showable - = - fun uu___ -> - fun uu___1 -> - { - show = - (fun uu___2 -> - match uu___2 with - | FStar_Pervasives.Inl x -> - let uu___3 = show uu___ x in Prims.strcat "Inl " uu___3 - | FStar_Pervasives.Inr y -> - let uu___3 = show uu___1 y in Prims.strcat "Inr " uu___3) - } -let show_tuple2 : 'a 'b . 'a showable -> 'b showable -> ('a * 'b) showable = - fun uu___ -> - fun uu___1 -> - { - show = - (fun uu___2 -> - match uu___2 with - | (x1, x2) -> - let uu___3 = - let uu___4 = show uu___ x1 in - let uu___5 = - let uu___6 = - let uu___7 = show uu___1 x2 in Prims.strcat uu___7 ")" in - Prims.strcat ", " uu___6 in - Prims.strcat uu___4 uu___5 in - Prims.strcat "(" uu___3) - } -let show_tuple3 : - 'a 'b 'c . - 'a showable -> 'b showable -> 'c showable -> ('a * 'b * 'c) showable - = - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - { - show = - (fun uu___3 -> - match uu___3 with - | (x1, x2, x3) -> - let uu___4 = - let uu___5 = show uu___ x1 in - let uu___6 = - let uu___7 = - let uu___8 = show uu___1 x2 in - let uu___9 = - let uu___10 = - let uu___11 = show uu___2 x3 in - Prims.strcat uu___11 ")" in - Prims.strcat ", " uu___10 in - Prims.strcat uu___8 uu___9 in - Prims.strcat ", " uu___7 in - Prims.strcat uu___5 uu___6 in - Prims.strcat "(" uu___4) - } -let show_tuple4 : - 'a 'b 'c 'd . - 'a showable -> - 'b showable -> - 'c showable -> 'd showable -> ('a * 'b * 'c * 'd) showable - = - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - { - show = - (fun uu___4 -> - match uu___4 with - | (x1, x2, x3, x4) -> - let uu___5 = - let uu___6 = show uu___ x1 in - let uu___7 = - let uu___8 = - let uu___9 = show uu___1 x2 in - let uu___10 = - let uu___11 = - let uu___12 = show uu___2 x3 in - let uu___13 = - let uu___14 = - let uu___15 = show uu___3 x4 in - Prims.strcat uu___15 ")" in - Prims.strcat ", " uu___14 in - Prims.strcat uu___12 uu___13 in - Prims.strcat ", " uu___11 in - Prims.strcat uu___9 uu___10 in - Prims.strcat ", " uu___8 in - Prims.strcat uu___6 uu___7 in - Prims.strcat "(" uu___5) - } -let show_tuple5 : - 'a 'b 'c 'd 'e . - 'a showable -> - 'b showable -> - 'c showable -> - 'd showable -> 'e showable -> ('a * 'b * 'c * 'd * 'e) showable - = - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun uu___4 -> - { - show = - (fun uu___5 -> - match uu___5 with - | (x1, x2, x3, x4, x5) -> - let uu___6 = - let uu___7 = show uu___ x1 in - let uu___8 = - let uu___9 = - let uu___10 = show uu___1 x2 in - let uu___11 = - let uu___12 = - let uu___13 = show uu___2 x3 in - let uu___14 = - let uu___15 = - let uu___16 = show uu___3 x4 in - let uu___17 = - let uu___18 = - let uu___19 = show uu___4 x5 in - Prims.strcat uu___19 ")" in - Prims.strcat ", " uu___18 in - Prims.strcat uu___16 uu___17 in - Prims.strcat ", " uu___15 in - Prims.strcat uu___13 uu___14 in - Prims.strcat ", " uu___12 in - Prims.strcat uu___10 uu___11 in - Prims.strcat ", " uu___9 in - Prims.strcat uu___7 uu___8 in - Prims.strcat "(" uu___6) - } -let show_tuple6 : - 'a 'b 'c 'd 'e 'f . - 'a showable -> - 'b showable -> - 'c showable -> - 'd showable -> - 'e showable -> - 'f showable -> ('a * 'b * 'c * 'd * 'e * 'f) showable - = - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun uu___4 -> - fun uu___5 -> - { - show = - (fun uu___6 -> - match uu___6 with - | (x1, x2, x3, x4, x5, x6) -> - let uu___7 = - let uu___8 = show uu___ x1 in - let uu___9 = - let uu___10 = - let uu___11 = show uu___1 x2 in - let uu___12 = - let uu___13 = - let uu___14 = show uu___2 x3 in - let uu___15 = - let uu___16 = - let uu___17 = show uu___3 x4 in - let uu___18 = - let uu___19 = - let uu___20 = show uu___4 x5 in - let uu___21 = - let uu___22 = - let uu___23 = show uu___5 x6 in - Prims.strcat uu___23 ")" in - Prims.strcat ", " uu___22 in - Prims.strcat uu___20 uu___21 in - Prims.strcat ", " uu___19 in - Prims.strcat uu___17 uu___18 in - Prims.strcat ", " uu___16 in - Prims.strcat uu___14 uu___15 in - Prims.strcat ", " uu___13 in - Prims.strcat uu___11 uu___12 in - Prims.strcat ", " uu___10 in - Prims.strcat uu___8 uu___9 in - Prims.strcat "(" uu___7) - } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Common.ml b/ocaml/fstar-lib/generated/FStar_Common.ml deleted file mode 100644 index 326d31d540c..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Common.ml +++ /dev/null @@ -1,184 +0,0 @@ -open Prims -let (has_cygpath : Prims.bool) = - try - (fun uu___ -> - match () with - | () -> - let t_out = - FStar_Compiler_Util.run_process "has_cygpath" "which" - ["cygpath"] FStar_Pervasives_Native.None in - (FStar_Compiler_Util.trim_string t_out) = "/usr/bin/cygpath") () - with | uu___ -> false -let (try_convert_file_name_to_mixed : Prims.string -> Prims.string) = - let cache = FStar_Compiler_Util.smap_create (Prims.of_int (20)) in - fun s -> - if has_cygpath && (FStar_Compiler_Util.starts_with s "/") - then - let uu___ = FStar_Compiler_Util.smap_try_find cache s in - match uu___ with - | FStar_Pervasives_Native.Some s1 -> s1 - | FStar_Pervasives_Native.None -> - let label = "try_convert_file_name_to_mixed" in - let out = - let uu___1 = - FStar_Compiler_Util.run_process label "cygpath" ["-m"; s] - FStar_Pervasives_Native.None in - FStar_Compiler_Util.trim_string uu___1 in - (FStar_Compiler_Util.smap_add cache s out; out) - else s -let snapshot : - 'a 'b 'c . - ('a -> 'b) -> - 'c Prims.list FStar_Compiler_Effect.ref -> 'a -> (Prims.int * 'b) - = - fun push -> - fun stackref -> - fun arg -> - FStar_Compiler_Util.atomically - (fun uu___ -> - let len = - let uu___1 = FStar_Compiler_Effect.op_Bang stackref in - FStar_Compiler_List.length uu___1 in - let arg' = push arg in (len, arg')) -let rollback : - 'a 'c . - (unit -> 'a) -> - 'c Prims.list FStar_Compiler_Effect.ref -> - Prims.int FStar_Pervasives_Native.option -> 'a - = - fun pop -> - fun stackref -> - fun depth -> - let rec aux n = - if n <= Prims.int_zero - then failwith "Too many pops" - else - if n = Prims.int_one - then pop () - else ((let uu___3 = pop () in ()); aux (n - Prims.int_one)) in - let curdepth = - let uu___ = FStar_Compiler_Effect.op_Bang stackref in - FStar_Compiler_List.length uu___ in - let n = - match depth with - | FStar_Pervasives_Native.Some d -> curdepth - d - | FStar_Pervasives_Native.None -> Prims.int_one in - FStar_Compiler_Util.atomically (fun uu___ -> aux n) -let raise_failed_assertion : 'uuuuu . Prims.string -> 'uuuuu = - fun msg -> - let uu___ = FStar_Compiler_Util.format1 "Assertion failed: %s" msg in - failwith uu___ -let (runtime_assert : Prims.bool -> Prims.string -> unit) = - fun b -> - fun msg -> if Prims.op_Negation b then raise_failed_assertion msg else () -let __string_of_list : - 'a . Prims.string -> ('a -> Prims.string) -> 'a Prims.list -> Prims.string - = - fun delim -> - fun f -> - fun l -> - match l with - | [] -> "[]" - | x::xs -> - let strb = FStar_Compiler_Util.new_string_builder () in - (FStar_Compiler_Util.string_builder_append strb "["; - (let uu___2 = f x in - FStar_Compiler_Util.string_builder_append strb uu___2); - FStar_Compiler_List.iter - (fun x1 -> - FStar_Compiler_Util.string_builder_append strb delim; - (let uu___4 = f x1 in - FStar_Compiler_Util.string_builder_append strb uu___4)) xs; - FStar_Compiler_Util.string_builder_append strb "]"; - FStar_Compiler_Util.string_of_string_builder strb) -let string_of_list : - 'uuuuu . - unit -> ('uuuuu -> Prims.string) -> 'uuuuu Prims.list -> Prims.string - = fun uu___ -> __string_of_list ", " -let string_of_list' : - 'uuuuu . - unit -> ('uuuuu -> Prims.string) -> 'uuuuu Prims.list -> Prims.string - = fun uu___ -> __string_of_list "; " -let list_of_option : 'a . 'a FStar_Pervasives_Native.option -> 'a Prims.list - = - fun o -> - match o with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some x -> [x] -let string_of_option : - 'uuuuu . - ('uuuuu -> Prims.string) -> - 'uuuuu FStar_Pervasives_Native.option -> Prims.string - = - fun f -> - fun uu___ -> - match uu___ with - | FStar_Pervasives_Native.None -> "None" - | FStar_Pervasives_Native.Some x -> - let uu___1 = f x in Prims.strcat "Some " uu___1 -let tabulate : 'a . Prims.int -> (Prims.int -> 'a) -> 'a Prims.list = - fun n -> - fun f -> - let rec aux i = - if i < n - then - let uu___ = f i in - let uu___1 = aux (i + Prims.int_one) in uu___ :: uu___1 - else [] in - aux Prims.int_zero -let rec max_prefix : - 'a . ('a -> Prims.bool) -> 'a Prims.list -> ('a Prims.list * 'a Prims.list) - = - fun f -> - fun xs -> - match xs with - | [] -> ([], []) - | x::xs1 when f x -> - let uu___ = max_prefix f xs1 in - (match uu___ with | (l, r) -> ((x :: l), r)) - | x::xs1 -> ([], (x :: xs1)) -let max_suffix : - 'a . ('a -> Prims.bool) -> 'a Prims.list -> ('a Prims.list * 'a Prims.list) - = - fun f -> - fun xs -> - let rec aux acc xs1 = - match xs1 with - | [] -> (acc, []) - | x::xs2 when f x -> aux (x :: acc) xs2 - | x::xs2 -> (acc, (x :: xs2)) in - let uu___ = aux [] (FStar_Compiler_List.rev xs) in - match uu___ with | (xs1, ys) -> ((FStar_Compiler_List.rev ys), xs1) -let rec eq_list : - 'a . - ('a -> 'a -> Prims.bool) -> 'a Prims.list -> 'a Prims.list -> Prims.bool - = - fun f -> - fun l1 -> - fun l2 -> - match (l1, l2) with - | ([], []) -> true - | ([], uu___) -> false - | (uu___, []) -> false - | (x1::t1, x2::t2) -> (f x1 x2) && (eq_list f t1 t2) -let psmap_to_list : - 'uuuuu . - 'uuuuu FStar_Compiler_Util.psmap -> (Prims.string * 'uuuuu) Prims.list - = - fun m -> - FStar_Compiler_Util.psmap_fold m (fun k -> fun v -> fun a -> (k, v) :: a) - [] -let psmap_keys : - 'uuuuu . 'uuuuu FStar_Compiler_Util.psmap -> Prims.string Prims.list = - fun m -> - FStar_Compiler_Util.psmap_fold m (fun k -> fun v -> fun a -> k :: a) [] -let psmap_values : - 'uuuuu . 'uuuuu FStar_Compiler_Util.psmap -> 'uuuuu Prims.list = - fun m -> - FStar_Compiler_Util.psmap_fold m (fun k -> fun v -> fun a -> v :: a) [] -let option_to_list : - 'uuuuu . 'uuuuu FStar_Pervasives_Native.option -> 'uuuuu Prims.list = - fun uu___ -> - match uu___ with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some x -> [x] \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Compiler_CList.ml b/ocaml/fstar-lib/generated/FStar_Compiler_CList.ml deleted file mode 100644 index 21f436a1c73..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Compiler_CList.ml +++ /dev/null @@ -1,138 +0,0 @@ -open Prims -type 'a clist = - | CNil - | CCons of 'a * 'a clist - | CCat of 'a clist * 'a clist -let uu___is_CNil : 'a . 'a clist -> Prims.bool = - fun projectee -> match projectee with | CNil -> true | uu___ -> false -let uu___is_CCons : 'a . 'a clist -> Prims.bool = - fun projectee -> - match projectee with | CCons (_0, _1) -> true | uu___ -> false -let __proj__CCons__item___0 : 'a . 'a clist -> 'a = - fun projectee -> match projectee with | CCons (_0, _1) -> _0 -let __proj__CCons__item___1 : 'a . 'a clist -> 'a clist = - fun projectee -> match projectee with | CCons (_0, _1) -> _1 -let uu___is_CCat : 'a . 'a clist -> Prims.bool = - fun projectee -> - match projectee with | CCat (_0, _1) -> true | uu___ -> false -let __proj__CCat__item___0 : 'a . 'a clist -> 'a clist = - fun projectee -> match projectee with | CCat (_0, _1) -> _0 -let __proj__CCat__item___1 : 'a . 'a clist -> 'a clist = - fun projectee -> match projectee with | CCat (_0, _1) -> _1 -type 'a t = 'a clist -let ccat : 'a . 'a clist -> 'a clist -> 'a clist = - fun xs -> - fun ys -> - match (xs, ys) with - | (CNil, uu___) -> ys - | (uu___, CNil) -> xs - | uu___ -> CCat (xs, ys) -let rec view : 'a . 'a clist -> ('a, 'a clist) FStar_Class_Listlike.view_t = - fun l -> - match l with - | CNil -> FStar_Class_Listlike.VNil - | CCons (x, xs) -> FStar_Class_Listlike.VCons (x, xs) - | CCat (CCat (xs, ys), zs) -> view (CCat (xs, (CCat (ys, zs)))) - | CCat (xs, ys) -> - (match view xs with - | FStar_Class_Listlike.VNil -> view ys - | FStar_Class_Listlike.VCons (x, xs') -> - FStar_Class_Listlike.VCons (x, (CCat (xs', ys)))) -let listlike_clist : 'a . unit -> ('a, 'a t) FStar_Class_Listlike.listlike = - fun uu___ -> - { - FStar_Class_Listlike.empty = CNil; - FStar_Class_Listlike.cons = - (fun uu___1 -> fun uu___2 -> CCons (uu___1, uu___2)); - FStar_Class_Listlike.view = view - } -let monoid_clist : 'a . unit -> 'a t FStar_Class_Monoid.monoid = - fun uu___ -> - { FStar_Class_Monoid.mzero = CNil; FStar_Class_Monoid.mplus = ccat } -let showable_clist : - 'a . 'a FStar_Class_Show.showable -> 'a t FStar_Class_Show.showable = - fun uu___ -> - { - FStar_Class_Show.show = - (fun l -> - let uu___1 = FStar_Class_Listlike.to_list (listlike_clist ()) l in - FStar_Class_Show.show (FStar_Class_Show.show_list uu___) uu___1) - } -let eq_clist : 'a . 'a FStar_Class_Deq.deq -> 'a t FStar_Class_Deq.deq = - fun d -> - { - FStar_Class_Deq.op_Equals_Question = - (fun l1 -> - fun l2 -> - let uu___ = FStar_Class_Listlike.to_list (listlike_clist ()) l1 in - let uu___1 = FStar_Class_Listlike.to_list (listlike_clist ()) l2 in - FStar_Class_Deq.op_Equals_Question (FStar_Class_Deq.deq_list d) - uu___ uu___1) - } -let ord_clist : 'a . 'a FStar_Class_Ord.ord -> 'a t FStar_Class_Ord.ord = - fun d -> - { - FStar_Class_Ord.super = (eq_clist (FStar_Class_Ord.ord_eq d)); - FStar_Class_Ord.cmp = - (fun l1 -> - fun l2 -> - let uu___ = FStar_Class_Listlike.to_list (listlike_clist ()) l1 in - let uu___1 = FStar_Class_Listlike.to_list (listlike_clist ()) l2 in - FStar_Class_Ord.cmp (FStar_Class_Ord.ord_list d) uu___ uu___1) - } -let rec map : 'a 'b . ('a -> 'b) -> 'a clist -> 'b clist = - fun f -> - fun l -> - match l with - | CNil -> CNil - | CCons (x, xs) -> - let uu___ = f x in let uu___1 = map f xs in CCons (uu___, uu___1) - | CCat (xs, ys) -> - let uu___ = map f xs in let uu___1 = map f ys in ccat uu___ uu___1 -let rec existsb : 'a . ('a -> Prims.bool) -> 'a clist -> Prims.bool = - fun p -> - fun l -> - match l with - | CNil -> false - | CCons (x, xs) -> (p x) || (existsb p xs) - | CCat (xs, ys) -> (existsb p xs) || (existsb p ys) -let rec for_all : 'a . ('a -> Prims.bool) -> 'a clist -> Prims.bool = - fun p -> - fun l -> - match l with - | CNil -> true - | CCons (x, xs) -> (p x) && (for_all p xs) - | CCat (xs, ys) -> (for_all p xs) && (for_all p ys) -let rec partition : - 'a . ('a -> Prims.bool) -> 'a clist -> ('a clist * 'a clist) = - fun p -> - fun l -> - match l with - | CNil -> (CNil, CNil) - | CCons (x, xs) -> - let uu___ = partition p xs in - (match uu___ with - | (ys, zs) -> - let uu___1 = p x in - if uu___1 - then ((CCons (x, ys)), zs) - else (ys, (CCons (x, zs)))) - | CCat (xs, ys) -> - let uu___ = partition p xs in - (match uu___ with - | (ys1, zs) -> - let uu___1 = partition p ys1 in - (match uu___1 with - | (us, vs) -> - let uu___2 = ccat ys1 us in - let uu___3 = ccat zs vs in (uu___2, uu___3))) -let rec collect : 'a 'b . ('a -> 'b clist) -> 'a clist -> 'b clist = - fun f -> - fun l -> - match l with - | CNil -> CNil - | CCons (x, xs) -> - let uu___ = f x in let uu___1 = collect f xs in ccat uu___ uu___1 - | CCat (xs, ys) -> - let uu___ = collect f xs in - let uu___1 = collect f ys in ccat uu___ uu___1 \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Compiler_Debug.ml b/ocaml/fstar-lib/generated/FStar_Compiler_Debug.ml deleted file mode 100644 index eb1f89bfb5c..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Compiler_Debug.ml +++ /dev/null @@ -1,151 +0,0 @@ -open Prims -let (anyref : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref false -let (_debug_all : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref false -let (toggle_list : - (Prims.string * Prims.bool FStar_Compiler_Effect.ref) Prims.list - FStar_Compiler_Effect.ref) - = FStar_Compiler_Util.mk_ref [] -type saved_state = - { - toggles: (Prims.string * Prims.bool) Prims.list ; - any: Prims.bool ; - all: Prims.bool } -let (__proj__Mksaved_state__item__toggles : - saved_state -> (Prims.string * Prims.bool) Prims.list) = - fun projectee -> match projectee with | { toggles; any; all;_} -> toggles -let (__proj__Mksaved_state__item__any : saved_state -> Prims.bool) = - fun projectee -> match projectee with | { toggles; any; all;_} -> any -let (__proj__Mksaved_state__item__all : saved_state -> Prims.bool) = - fun projectee -> match projectee with | { toggles; any; all;_} -> all -let (snapshot : unit -> saved_state) = - fun uu___ -> - let uu___1 = - let uu___2 = FStar_Compiler_Effect.op_Bang toggle_list in - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with - | (k, r) -> - let uu___4 = FStar_Compiler_Effect.op_Bang r in (k, uu___4)) - uu___2 in - let uu___2 = FStar_Compiler_Effect.op_Bang anyref in - let uu___3 = FStar_Compiler_Effect.op_Bang _debug_all in - { toggles = uu___1; any = uu___2; all = uu___3 } -let (register_toggle : Prims.string -> Prims.bool FStar_Compiler_Effect.ref) - = - fun k -> - let r = FStar_Compiler_Util.mk_ref false in - (let uu___1 = FStar_Compiler_Effect.op_Bang _debug_all in - if uu___1 then FStar_Compiler_Effect.op_Colon_Equals r true else ()); - (let uu___2 = - let uu___3 = FStar_Compiler_Effect.op_Bang toggle_list in (k, r) :: - uu___3 in - FStar_Compiler_Effect.op_Colon_Equals toggle_list uu___2); - r -let (get_toggle : Prims.string -> Prims.bool FStar_Compiler_Effect.ref) = - fun k -> - let uu___ = - let uu___1 = FStar_Compiler_Effect.op_Bang toggle_list in - FStar_Compiler_List.tryFind - (fun uu___2 -> match uu___2 with | (k', uu___3) -> k = k') uu___1 in - match uu___ with - | FStar_Pervasives_Native.Some (uu___1, r) -> r - | FStar_Pervasives_Native.None -> register_toggle k -let (restore : saved_state -> unit) = - fun snapshot1 -> - (let uu___1 = FStar_Compiler_Effect.op_Bang toggle_list in - FStar_Compiler_List.iter - (fun uu___2 -> - match uu___2 with - | (uu___3, r) -> FStar_Compiler_Effect.op_Colon_Equals r false) - uu___1); - FStar_Compiler_List.iter - (fun uu___2 -> - match uu___2 with - | (k, b) -> - let r = get_toggle k in - FStar_Compiler_Effect.op_Colon_Equals r b) snapshot1.toggles; - FStar_Compiler_Effect.op_Colon_Equals anyref snapshot1.any; - FStar_Compiler_Effect.op_Colon_Equals _debug_all snapshot1.all -let (list_all_toggles : unit -> Prims.string Prims.list) = - fun uu___ -> - let uu___1 = FStar_Compiler_Effect.op_Bang toggle_list in - FStar_Compiler_List.map FStar_Pervasives_Native.fst uu___1 -let (any : unit -> Prims.bool) = - fun uu___ -> - (FStar_Compiler_Effect.op_Bang anyref) || - (FStar_Compiler_Effect.op_Bang _debug_all) -let (tag : Prims.string -> unit) = - fun s -> - let uu___ = any () in - if uu___ - then - FStar_Compiler_Util.print_string - (Prims.strcat "DEBUG:" (Prims.strcat s "\n")) - else () -let (enable : unit -> unit) = - fun uu___ -> FStar_Compiler_Effect.op_Colon_Equals anyref true -let (dbg_level : Prims.int FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref Prims.int_zero -let (low : unit -> Prims.bool) = - fun uu___ -> - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_level in - uu___1 >= Prims.int_one) || (FStar_Compiler_Effect.op_Bang _debug_all) -let (medium : unit -> Prims.bool) = - fun uu___ -> - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_level in - uu___1 >= (Prims.of_int (2))) || - (FStar_Compiler_Effect.op_Bang _debug_all) -let (high : unit -> Prims.bool) = - fun uu___ -> - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_level in - uu___1 >= (Prims.of_int (3))) || - (FStar_Compiler_Effect.op_Bang _debug_all) -let (extreme : unit -> Prims.bool) = - fun uu___ -> - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_level in - uu___1 >= (Prims.of_int (4))) || - (FStar_Compiler_Effect.op_Bang _debug_all) -let (set_level_low : unit -> unit) = - fun uu___ -> FStar_Compiler_Effect.op_Colon_Equals dbg_level Prims.int_one -let (set_level_medium : unit -> unit) = - fun uu___ -> - FStar_Compiler_Effect.op_Colon_Equals dbg_level (Prims.of_int (2)) -let (set_level_high : unit -> unit) = - fun uu___ -> - FStar_Compiler_Effect.op_Colon_Equals dbg_level (Prims.of_int (3)) -let (set_level_extreme : unit -> unit) = - fun uu___ -> - FStar_Compiler_Effect.op_Colon_Equals dbg_level (Prims.of_int (4)) -let (enable_toggles : Prims.string Prims.list -> unit) = - fun keys -> - if Prims.uu___is_Cons keys then enable () else (); - FStar_Compiler_List.iter - (fun k -> - if k = "Low" - then set_level_low () - else - if k = "Medium" - then set_level_medium () - else - if k = "High" - then set_level_high () - else - if k = "Extreme" - then set_level_extreme () - else - (let t = get_toggle k in - FStar_Compiler_Effect.op_Colon_Equals t true)) keys -let (disable_all : unit -> unit) = - fun uu___ -> - FStar_Compiler_Effect.op_Colon_Equals anyref false; - FStar_Compiler_Effect.op_Colon_Equals dbg_level Prims.int_zero; - (let uu___3 = FStar_Compiler_Effect.op_Bang toggle_list in - FStar_Compiler_List.iter - (fun uu___4 -> - match uu___4 with - | (uu___5, r) -> FStar_Compiler_Effect.op_Colon_Equals r false) - uu___3) -let (set_debug_all : unit -> unit) = - fun uu___ -> FStar_Compiler_Effect.op_Colon_Equals _debug_all true \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Compiler_FlatSet.ml b/ocaml/fstar-lib/generated/FStar_Compiler_FlatSet.ml deleted file mode 100644 index 0a701e59788..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Compiler_FlatSet.ml +++ /dev/null @@ -1,138 +0,0 @@ -open Prims -type 't flat_set = 't Prims.list -type 'a t = 'a flat_set -let rec add : 'a . 'a FStar_Class_Ord.ord -> 'a -> 'a flat_set -> 'a flat_set - = - fun uu___ -> - fun x -> - fun s -> - match s with - | [] -> [x] - | y::yy -> - let uu___1 = - FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq uu___) x y in - if uu___1 - then s - else (let uu___3 = add uu___ x yy in y :: uu___3) -let empty : 'a . unit -> 'a flat_set = fun uu___ -> [] -let from_list : 'a . 'a FStar_Class_Ord.ord -> 'a Prims.list -> 'a flat_set = - fun uu___ -> fun xs -> FStar_Class_Ord.dedup uu___ xs -let mem : 'a . 'a FStar_Class_Ord.ord -> 'a -> 'a flat_set -> Prims.bool = - fun uu___ -> - fun x -> - fun s -> - FStar_Compiler_List.existsb - (fun y -> - FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq uu___) x y) s -let singleton : 'a . 'a FStar_Class_Ord.ord -> 'a -> 'a flat_set = - fun uu___ -> fun x -> [x] -let is_empty : 'a . 'a flat_set -> Prims.bool = fun s -> Prims.uu___is_Nil s -let addn : - 'a . 'a FStar_Class_Ord.ord -> 'a Prims.list -> 'a flat_set -> 'a flat_set - = - fun uu___ -> - fun xs -> fun ys -> FStar_Compiler_List.fold_right (add uu___) xs ys -let rec remove : - 'a . 'a FStar_Class_Ord.ord -> 'a -> 'a flat_set -> 'a flat_set = - fun uu___ -> - fun x -> - fun s -> - match s with - | [] -> [] - | y::yy -> - let uu___1 = - FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq uu___) x y in - if uu___1 - then yy - else (let uu___3 = remove uu___ x yy in y :: uu___3) -let elems : 'a . 'a flat_set -> 'a Prims.list = fun s -> s -let for_all : 'a . ('a -> Prims.bool) -> 'a flat_set -> Prims.bool = - fun p -> - fun s -> let uu___ = elems s in FStar_Compiler_List.for_all p uu___ -let for_any : 'a . ('a -> Prims.bool) -> 'a flat_set -> Prims.bool = - fun p -> - fun s -> let uu___ = elems s in FStar_Compiler_List.existsb p uu___ -let subset : - 'a . 'a FStar_Class_Ord.ord -> 'a flat_set -> 'a flat_set -> Prims.bool = - fun uu___ -> fun s1 -> fun s2 -> for_all (fun y -> mem uu___ y s2) s1 -let equal : - 'a . 'a FStar_Class_Ord.ord -> 'a flat_set -> 'a flat_set -> Prims.bool = - fun uu___ -> - fun s1 -> - fun s2 -> - let uu___1 = FStar_Class_Ord.sort uu___ s1 in - let uu___2 = FStar_Class_Ord.sort uu___ s2 in - FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq (FStar_Class_Ord.ord_list uu___)) uu___1 - uu___2 -let union : - 'a . 'a FStar_Class_Ord.ord -> 'a flat_set -> 'a flat_set -> 'a flat_set = - fun uu___ -> - fun s1 -> - fun s2 -> - FStar_Compiler_List.fold_left (fun s -> fun x -> add uu___ x s) s1 s2 -let inter : - 'a . 'a FStar_Class_Ord.ord -> 'a flat_set -> 'a flat_set -> 'a flat_set = - fun uu___ -> - fun s1 -> - fun s2 -> FStar_Compiler_List.filter (fun y -> mem uu___ y s2) s1 -let diff : - 'a . 'a FStar_Class_Ord.ord -> 'a flat_set -> 'a flat_set -> 'a flat_set = - fun uu___ -> - fun s1 -> - fun s2 -> - FStar_Compiler_List.filter - (fun y -> let uu___1 = mem uu___ y s2 in Prims.op_Negation uu___1) - s1 -let collect : - 'a 'b . - 'b FStar_Class_Ord.ord -> - ('a -> 'b flat_set) -> 'a Prims.list -> 'b flat_set - = - fun uu___ -> - fun f -> - fun l -> - let uu___1 = empty () in - FStar_Compiler_List.fold_right - (fun x -> fun acc -> let uu___2 = f x in union uu___ uu___2 acc) l - uu___1 -let showable_set : - 'a . - 'a FStar_Class_Ord.ord -> - 'a FStar_Class_Show.showable -> 'a flat_set FStar_Class_Show.showable - = - fun uu___ -> - fun uu___1 -> - { - FStar_Class_Show.show = - (fun s -> - let uu___2 = elems s in - FStar_Class_Show.show (FStar_Class_Show.show_list uu___1) uu___2) - } -let setlike_flat_set : - 'a . - 'a FStar_Class_Ord.ord -> ('a, 'a flat_set) FStar_Class_Setlike.setlike - = - fun uu___ -> - { - FStar_Class_Setlike.empty = empty; - FStar_Class_Setlike.singleton = (singleton uu___); - FStar_Class_Setlike.is_empty = is_empty; - FStar_Class_Setlike.add = (add uu___); - FStar_Class_Setlike.remove = (remove uu___); - FStar_Class_Setlike.mem = (mem uu___); - FStar_Class_Setlike.equal = (equal uu___); - FStar_Class_Setlike.subset = (subset uu___); - FStar_Class_Setlike.union = (union uu___); - FStar_Class_Setlike.inter = (inter uu___); - FStar_Class_Setlike.diff = (diff uu___); - FStar_Class_Setlike.for_all = for_all; - FStar_Class_Setlike.for_any = for_any; - FStar_Class_Setlike.elems = elems; - FStar_Class_Setlike.collect = (collect uu___); - FStar_Class_Setlike.from_list = (from_list uu___); - FStar_Class_Setlike.addn = (addn uu___) - } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Compiler_MachineInts.ml b/ocaml/fstar-lib/generated/FStar_Compiler_MachineInts.ml deleted file mode 100644 index 5ce3ce72f38..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Compiler_MachineInts.ml +++ /dev/null @@ -1,344 +0,0 @@ -open Prims -type machint_kind = - | Int8 - | Int16 - | Int32 - | Int64 - | UInt8 - | UInt16 - | UInt32 - | UInt64 - | UInt128 - | SizeT -let (uu___is_Int8 : machint_kind -> Prims.bool) = - fun projectee -> match projectee with | Int8 -> true | uu___ -> false -let (uu___is_Int16 : machint_kind -> Prims.bool) = - fun projectee -> match projectee with | Int16 -> true | uu___ -> false -let (uu___is_Int32 : machint_kind -> Prims.bool) = - fun projectee -> match projectee with | Int32 -> true | uu___ -> false -let (uu___is_Int64 : machint_kind -> Prims.bool) = - fun projectee -> match projectee with | Int64 -> true | uu___ -> false -let (uu___is_UInt8 : machint_kind -> Prims.bool) = - fun projectee -> match projectee with | UInt8 -> true | uu___ -> false -let (uu___is_UInt16 : machint_kind -> Prims.bool) = - fun projectee -> match projectee with | UInt16 -> true | uu___ -> false -let (uu___is_UInt32 : machint_kind -> Prims.bool) = - fun projectee -> match projectee with | UInt32 -> true | uu___ -> false -let (uu___is_UInt64 : machint_kind -> Prims.bool) = - fun projectee -> match projectee with | UInt64 -> true | uu___ -> false -let (uu___is_UInt128 : machint_kind -> Prims.bool) = - fun projectee -> match projectee with | UInt128 -> true | uu___ -> false -let (uu___is_SizeT : machint_kind -> Prims.bool) = - fun projectee -> match projectee with | SizeT -> true | uu___ -> false -let (all_machint_kinds : machint_kind Prims.list) = - [Int8; Int16; Int32; Int64; UInt8; UInt16; UInt32; UInt64; UInt128; SizeT] -let (is_unsigned : machint_kind -> Prims.bool) = - fun k -> - match k with - | Int8 -> false - | Int16 -> false - | Int32 -> false - | Int64 -> false - | UInt8 -> true - | UInt16 -> true - | UInt32 -> true - | UInt64 -> true - | UInt128 -> true - | SizeT -> true -let (is_signed : machint_kind -> Prims.bool) = - fun k -> let uu___ = is_unsigned k in Prims.op_Negation uu___ -let (width : machint_kind -> Prims.int) = - fun k -> - match k with - | Int8 -> (Prims.of_int (8)) - | Int16 -> (Prims.of_int (16)) - | Int32 -> (Prims.of_int (32)) - | Int64 -> (Prims.of_int (64)) - | UInt8 -> (Prims.of_int (8)) - | UInt16 -> (Prims.of_int (16)) - | UInt32 -> (Prims.of_int (32)) - | UInt64 -> (Prims.of_int (64)) - | UInt128 -> (Prims.of_int (128)) - | SizeT -> (Prims.of_int (64)) -let (module_name_for : machint_kind -> Prims.string) = - fun k -> - match k with - | Int8 -> "Int8" - | Int16 -> "Int16" - | Int32 -> "Int32" - | Int64 -> "Int64" - | UInt8 -> "UInt8" - | UInt16 -> "UInt16" - | UInt32 -> "UInt32" - | UInt64 -> "UInt64" - | UInt128 -> "UInt128" - | SizeT -> "SizeT" -let (mask : machint_kind -> FStar_BigInt.t) = - fun k -> - let uu___ = width k in - match uu___ with - | uu___1 when uu___1 = (Prims.of_int (8)) -> FStar_BigInt.of_hex "ff" - | uu___1 when uu___1 = (Prims.of_int (16)) -> FStar_BigInt.of_hex "ffff" - | uu___1 when uu___1 = (Prims.of_int (32)) -> - FStar_BigInt.of_hex "ffffffff" - | uu___1 when uu___1 = (Prims.of_int (64)) -> - FStar_BigInt.of_hex "ffffffffffffffff" - | uu___1 when uu___1 = (Prims.of_int (128)) -> - FStar_BigInt.of_hex "ffffffffffffffffffffffffffffffff" -let (int_to_t_lid_for : machint_kind -> FStar_Ident.lid) = - fun k -> - let path = - let uu___ = - let uu___1 = module_name_for k in - let uu___2 = - let uu___3 = - let uu___4 = is_unsigned k in - if uu___4 then "uint_to_t" else "int_to_t" in - [uu___3] in - uu___1 :: uu___2 in - "FStar" :: uu___ in - FStar_Ident.lid_of_path path FStar_Compiler_Range_Type.dummyRange -let (int_to_t_for : machint_kind -> FStar_Syntax_Syntax.term) = - fun k -> - let lid = int_to_t_lid_for k in - FStar_Syntax_Syntax.fvar lid FStar_Pervasives_Native.None -let (__int_to_t_lid_for : machint_kind -> FStar_Ident.lid) = - fun k -> - let path = - let uu___ = - let uu___1 = module_name_for k in - let uu___2 = - let uu___3 = - let uu___4 = is_unsigned k in - if uu___4 then "__uint_to_t" else "__int_to_t" in - [uu___3] in - uu___1 :: uu___2 in - "FStar" :: uu___ in - FStar_Ident.lid_of_path path FStar_Compiler_Range_Type.dummyRange -let (__int_to_t_for : machint_kind -> FStar_Syntax_Syntax.term) = - fun k -> - let lid = __int_to_t_lid_for k in - FStar_Syntax_Syntax.fvar lid FStar_Pervasives_Native.None -type 'k machint = - | Mk of FStar_BigInt.t * FStar_Syntax_Syntax.meta_source_info - FStar_Pervasives_Native.option -let (uu___is_Mk : machint_kind -> unit machint -> Prims.bool) = - fun k -> fun projectee -> true -let (__proj__Mk__item___0 : machint_kind -> unit machint -> FStar_BigInt.t) = - fun k -> fun projectee -> match projectee with | Mk (_0, _1) -> _0 -let (__proj__Mk__item___1 : - machint_kind -> - unit machint -> - FStar_Syntax_Syntax.meta_source_info FStar_Pervasives_Native.option) - = fun k -> fun projectee -> match projectee with | Mk (_0, _1) -> _1 -let (mk : - machint_kind -> - FStar_BigInt.t -> - FStar_Syntax_Syntax.meta_source_info FStar_Pervasives_Native.option -> - unit machint) - = fun k -> fun x -> fun m -> Mk (x, m) -let (v : machint_kind -> unit machint -> FStar_BigInt.t) = - fun k -> fun x -> let uu___ = x in match uu___ with | Mk (v1, uu___1) -> v1 -let (meta : - machint_kind -> - unit machint -> - FStar_Syntax_Syntax.meta_source_info FStar_Pervasives_Native.option) - = - fun k -> - fun x -> let uu___ = x in match uu___ with | Mk (uu___1, meta1) -> meta1 -let (make_as : - machint_kind -> unit machint -> FStar_BigInt.t -> unit machint) = - fun k -> fun x -> fun z -> let uu___ = meta k x in Mk (z, uu___) -let (showable_bounded_k : - machint_kind -> unit machint FStar_Class_Show.showable) = - fun k -> - { - FStar_Class_Show.show = - (fun uu___ -> - match uu___ with - | Mk (x, m) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_BigInt.to_int_fs x in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) uu___3 in - let uu___3 = - let uu___4 = module_name_for k in Prims.strcat "@@" uu___4 in - Prims.strcat uu___2 uu___3 in - Prims.strcat "machine integer " uu___1) - } -let (e_machint : - machint_kind -> unit machint FStar_Syntax_Embeddings_Base.embedding) = - fun k -> - let with_meta_ds r t m = - match m with - | FStar_Pervasives_Native.None -> t - | FStar_Pervasives_Native.Some m1 -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 = t; - FStar_Syntax_Syntax.meta = - (FStar_Syntax_Syntax.Meta_desugared m1) - }) r in - let em x rng shadow cb = - let uu___ = x in - match uu___ with - | Mk (i, m) -> - let it = - let uu___1 = - FStar_Syntax_Embeddings_Base.embed - FStar_Syntax_Embeddings.e_int i in - uu___1 rng FStar_Pervasives_Native.None cb in - let int_to_t = int_to_t_for k in - let t = - let uu___1 = - let uu___2 = FStar_Syntax_Syntax.as_arg it in [uu___2] in - FStar_Syntax_Syntax.mk_Tm_app int_to_t uu___1 rng in - with_meta_ds rng t m in - let un uu___1 uu___ = - (fun t -> - fun cb -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress t in - uu___2.FStar_Syntax_Syntax.n in - match uu___1 with - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t1; - FStar_Syntax_Syntax.meta = - FStar_Syntax_Syntax.Meta_desugared m;_} - -> (t1, (FStar_Pervasives_Native.Some m)) - | uu___2 -> (t, FStar_Pervasives_Native.None) in - match uu___ with - | (t1, m) -> - let t2 = FStar_Syntax_Util.unmeta_safe t1 in - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress t2 in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = hd; - FStar_Syntax_Syntax.args = (a, uu___2)::[];_} - when - (let uu___3 = int_to_t_lid_for k in - FStar_Syntax_Util.is_fvar uu___3 hd) || - (let uu___3 = __int_to_t_lid_for k in - FStar_Syntax_Util.is_fvar uu___3 hd) - -> - Obj.magic - (Obj.repr - (let a1 = FStar_Syntax_Util.unlazy_emb a in - let uu___3 = - FStar_Syntax_Embeddings_Base.try_unembed - FStar_Syntax_Embeddings.e_int a1 cb in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic uu___3) - (fun uu___4 -> - (fun a2 -> - let a2 = Obj.magic a2 in - Obj.magic - (FStar_Pervasives_Native.Some - (Mk (a2, m)))) uu___4))) - | uu___2 -> Obj.magic (Obj.repr FStar_Pervasives_Native.None))) - uu___1 uu___ in - FStar_Syntax_Embeddings_Base.mk_emb_full em un - (fun uu___ -> - let uu___1 = - let uu___2 = - let uu___3 = let uu___4 = module_name_for k in [uu___4; "t"] in - "FStar" :: uu___3 in - FStar_Ident.lid_of_path uu___2 - FStar_Compiler_Range_Type.dummyRange in - FStar_Syntax_Syntax.fvar uu___1 FStar_Pervasives_Native.None) - (fun uu___ -> "boundedint") - (fun uu___ -> FStar_Syntax_Syntax.ET_abstract) -let (nbe_machint : - machint_kind -> unit machint FStar_TypeChecker_NBETerm.embedding) = - fun k -> - let with_meta_ds t m = - match m with - | FStar_Pervasives_Native.None -> t - | FStar_Pervasives_Native.Some m1 -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Thunk.mk - (fun uu___3 -> FStar_Syntax_Syntax.Meta_desugared m1) in - (t, uu___2) in - FStar_TypeChecker_NBETerm.Meta uu___1 in - FStar_TypeChecker_NBETerm.mk_t uu___ in - let em cbs x = - let uu___ = x in - match uu___ with - | Mk (i, m) -> - let it = - FStar_TypeChecker_NBETerm.embed FStar_TypeChecker_NBETerm.e_int - cbs i in - let int_to_t args = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = __int_to_t_lid_for k in - FStar_Syntax_Syntax.lid_as_fv uu___4 - FStar_Pervasives_Native.None in - (uu___3, [], args) in - FStar_TypeChecker_NBETerm.FV uu___2 in - FStar_TypeChecker_NBETerm.mk_t uu___1 in - let t = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.as_arg it in [uu___2] in - int_to_t uu___1 in - with_meta_ds t m in - let un uu___1 uu___ = - (fun cbs -> - fun a -> - let uu___ = - match a.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Meta (t, tm) -> - let uu___1 = FStar_Thunk.force tm in - (match uu___1 with - | FStar_Syntax_Syntax.Meta_desugared m -> - (t, (FStar_Pervasives_Native.Some m)) - | uu___2 -> (a, FStar_Pervasives_Native.None)) - | uu___1 -> (a, FStar_Pervasives_Native.None) in - match uu___ with - | (a1, m) -> - (match a1.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.FV (fv1, [], (a2, uu___1)::[]) - when - let uu___2 = int_to_t_lid_for k in - FStar_Ident.lid_equals - (fv1.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - uu___2 - -> - Obj.magic - (Obj.repr - (let uu___2 = - FStar_TypeChecker_NBETerm.unembed - FStar_TypeChecker_NBETerm.e_int cbs a2 in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic uu___2) - (fun uu___3 -> - (fun a3 -> - let a3 = Obj.magic a3 in - Obj.magic - (FStar_Pervasives_Native.Some - (Mk (a3, m)))) uu___3))) - | uu___1 -> Obj.magic (Obj.repr FStar_Pervasives_Native.None))) - uu___1 uu___ in - FStar_TypeChecker_NBETerm.mk_emb em un - (fun uu___ -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = let uu___5 = module_name_for k in [uu___5; "t"] in - "FStar" :: uu___4 in - FStar_Ident.lid_of_path uu___3 - FStar_Compiler_Range_Type.dummyRange in - FStar_Syntax_Syntax.lid_as_fv uu___2 FStar_Pervasives_Native.None in - FStar_TypeChecker_NBETerm.mkFV uu___1 [] []) - (fun uu___ -> FStar_Syntax_Syntax.ET_abstract) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Compiler_Misc.ml b/ocaml/fstar-lib/generated/FStar_Compiler_Misc.ml deleted file mode 100644 index d583c344548..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Compiler_Misc.ml +++ /dev/null @@ -1,17 +0,0 @@ -open Prims -let (compare_version : Prims.string -> Prims.string -> FStar_Order.order) = - fun v1 -> - fun v2 -> - let cs1 = - FStar_Compiler_List.map FStar_Compiler_Util.int_of_string - (FStar_Compiler_String.split [46] v1) in - let cs2 = - FStar_Compiler_List.map FStar_Compiler_Util.int_of_string - (FStar_Compiler_String.split [46] v2) in - FStar_Order.compare_list cs1 cs2 FStar_Order.compare_int -let (version_gt : Prims.string -> Prims.string -> Prims.bool) = - fun v1 -> - fun v2 -> let uu___ = compare_version v1 v2 in uu___ = FStar_Order.Gt -let (version_ge : Prims.string -> Prims.string -> Prims.bool) = - fun v1 -> - fun v2 -> let uu___ = compare_version v1 v2 in uu___ <> FStar_Order.Lt \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Compiler_Path.ml b/ocaml/fstar-lib/generated/FStar_Compiler_Path.ml deleted file mode 100644 index 7ab83df5fef..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Compiler_Path.ml +++ /dev/null @@ -1,29 +0,0 @@ -open Prims -type 'a path = 'a Prims.list -type ('a, 'qual) forest = (('a path * 'qual) Prims.list * 'qual) -let rec is_under : - 'a . 'a FStar_Class_Deq.deq -> 'a path -> 'a path -> Prims.bool = - fun uu___ -> - fun p1 -> - fun p2 -> - match (p1, p2) with - | (uu___1, []) -> true - | ([], uu___1) -> false - | (h1::t1, h2::t2) -> - (FStar_Class_Deq.op_Equals_Question uu___ h1 h2) && - (is_under uu___ t1 t2) -let search_forest : - 'a 'q . 'a FStar_Class_Deq.deq -> 'a path -> ('a, 'q) forest -> 'q = - fun uu___ -> - fun p -> - fun f -> - let uu___1 = f in - match uu___1 with - | (roots, def) -> - let rec aux roots1 = - match roots1 with - | [] -> def - | (r, q1)::rs -> - let uu___2 = is_under uu___ p r in - if uu___2 then q1 else aux rs in - aux roots \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Compiler_Plugins.ml b/ocaml/fstar-lib/generated/FStar_Compiler_Plugins.ml deleted file mode 100644 index eb31c480733..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Compiler_Plugins.ml +++ /dev/null @@ -1,194 +0,0 @@ -open Prims -let (loaded : Prims.string Prims.list FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref [] -let (pout : Prims.string -> unit) = - fun s -> - let uu___ = FStar_Compiler_Debug.any () in - if uu___ then FStar_Compiler_Util.print_string s else () -let (pout1 : Prims.string -> Prims.string -> unit) = - fun s -> - fun x -> - let uu___ = FStar_Compiler_Debug.any () in - if uu___ then FStar_Compiler_Util.print1 s x else () -let (perr : Prims.string -> unit) = - fun s -> - let uu___ = FStar_Compiler_Debug.any () in - if uu___ then FStar_Compiler_Util.print_error s else () -let (perr1 : Prims.string -> Prims.string -> unit) = - fun s -> - fun x -> - let uu___ = FStar_Compiler_Debug.any () in - if uu___ then FStar_Compiler_Util.print1_error s x else () -let (dynlink : Prims.string -> unit) = - fun fname -> - let uu___ = - let uu___1 = FStar_Compiler_Effect.op_Bang loaded in - FStar_Compiler_List.mem fname uu___1 in - if uu___ - then pout1 "Plugin %s already loaded, skipping\n" fname - else - (pout (Prims.strcat "Attempting to load " (Prims.strcat fname "\n")); - (try - (fun uu___4 -> - match () with - | () -> FStar_Compiler_Plugins_Base.dynlink_loadfile fname) () - with - | FStar_Compiler_Plugins_Base.DynlinkError e -> - ((let uu___6 = - let uu___7 = - let uu___8 = - FStar_Compiler_Util.format1 - "Failed to load plugin file %s" fname in - FStar_Errors_Msg.text uu___8 in - let uu___8 = - let uu___9 = - let uu___10 = FStar_Errors_Msg.text "Reason:" in - let uu___11 = FStar_Errors_Msg.text e in - FStar_Pprint.prefix (Prims.of_int (2)) Prims.int_one - uu___10 uu___11 in - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - FStar_Errors.errno - FStar_Errors_Codes.Error_PluginDynlink in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) uu___14 in - FStar_Compiler_Util.format1 - "Remove the `--load` option or use `--warn_error -%s` to ignore and continue." - uu___13 in - FStar_Errors_Msg.text uu___12 in - [uu___11] in - uu___9 :: uu___10 in - uu___7 :: uu___8 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Error_PluginDynlink - () (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___6)); - FStar_Errors.stop_if_err ())); - (let uu___5 = - let uu___6 = FStar_Compiler_Effect.op_Bang loaded in fname :: - uu___6 in - FStar_Compiler_Effect.op_Colon_Equals loaded uu___5); - pout1 "Loaded %s\n" fname) -let (load_plugin : Prims.string -> unit) = fun tac -> dynlink tac -let (load_plugins : Prims.string Prims.list -> unit) = - fun tacs -> FStar_Compiler_List.iter load_plugin tacs -let (load_plugins_dir : Prims.string -> unit) = - fun dir -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Compiler_Util.readdir dir in - FStar_Compiler_List.filter - (fun s -> - ((FStar_Compiler_String.length s) >= (Prims.of_int (5))) && - ((FStar_String.sub s - ((FStar_Compiler_String.length s) - (Prims.of_int (5))) - (Prims.of_int (5))) - = ".cmxs")) uu___2 in - FStar_Compiler_List.map - (fun s -> Prims.strcat dir (Prims.strcat "/" s)) uu___1 in - load_plugins uu___ -let (compile_modules : Prims.string -> Prims.string Prims.list -> unit) = - fun dir -> - fun ms -> - let compile m = - let packages = ["fstar.lib"] in - let pkg pname = Prims.strcat "-package " pname in - let args = - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Compiler_List.map pkg packages in - FStar_List_Tot_Base.append uu___3 - ["-o"; Prims.strcat m ".cmxs"; Prims.strcat m ".ml"] in - FStar_List_Tot_Base.append ["-w"; "-8-11-20-21-26-28"] uu___2 in - FStar_List_Tot_Base.append ["-I"; dir] uu___1 in - FStar_List_Tot_Base.append ["ocamlopt"; "-shared"] uu___ in - let ocamlpath_sep = - match FStar_Platform.system with - | FStar_Platform.Windows -> ";" - | FStar_Platform.Posix -> ":" in - let old_ocamlpath = - let uu___ = - FStar_Compiler_Util.expand_environment_variable "OCAMLPATH" in - match uu___ with - | FStar_Pervasives_Native.Some s -> s - | FStar_Pervasives_Native.None -> "" in - let env_setter = - FStar_Compiler_Util.format5 "env OCAMLPATH=\"%s/../lib/%s%s/%s%s\"" - FStar_Options.fstar_bin_directory ocamlpath_sep - FStar_Options.fstar_bin_directory ocamlpath_sep old_ocamlpath in - let cmd = - FStar_Compiler_String.concat " " (env_setter :: "ocamlfind" :: - args) in - let rc = FStar_Compiler_Util.system_run cmd in - if rc <> Prims.int_zero - then - let uu___ = - let uu___1 = - FStar_Errors_Msg.text "Failed to compile native tactic." in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) rc in - FStar_Compiler_Util.format2 - "Command\n`%s`\nreturned with exit code %s" cmd uu___5 in - FStar_Errors_Msg.text uu___4 in - [uu___3] in - uu___1 :: uu___2 in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_FailToCompileNativeTactic () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___) - else () in - try - (fun uu___ -> - match () with - | () -> - let uu___1 = - FStar_Compiler_List.map - (fun m -> Prims.strcat dir (Prims.strcat "/" m)) ms in - FStar_Compiler_List.iter compile uu___1) () - with - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_Compiler_Util.print_exn uu___ in - FStar_Compiler_Util.format1 - "Failed to load native tactic: %s\n" uu___3 in - perr uu___2); - FStar_Compiler_Effect.raise uu___) -let (autoload_plugin : Prims.string -> Prims.bool) = - fun ext -> - let uu___ = - let uu___1 = FStar_Options_Ext.get "noautoload" in uu___1 <> "" in - if uu___ - then false - else - ((let uu___3 = FStar_Compiler_Debug.any () in - if uu___3 - then - FStar_Compiler_Util.print1 - "Trying to find a plugin for extension %s\n" ext - else ()); - (let uu___3 = FStar_Find.find_file (Prims.strcat ext ".cmxs") in - match uu___3 with - | FStar_Pervasives_Native.Some fn -> - let uu___4 = - let uu___5 = FStar_Compiler_Effect.op_Bang loaded in - FStar_Compiler_List.mem fn uu___5 in - if uu___4 - then false - else - ((let uu___7 = FStar_Compiler_Debug.any () in - if uu___7 - then - FStar_Compiler_Util.print1 "Autoloading plugin %s ...\n" fn - else ()); - load_plugin fn; - true) - | FStar_Pervasives_Native.None -> false)) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Compiler_RBSet.ml b/ocaml/fstar-lib/generated/FStar_Compiler_RBSet.ml deleted file mode 100644 index 7d93f137aaf..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Compiler_RBSet.ml +++ /dev/null @@ -1,228 +0,0 @@ -open Prims -type color = - | R - | B -let (uu___is_R : color -> Prims.bool) = - fun projectee -> match projectee with | R -> true | uu___ -> false -let (uu___is_B : color -> Prims.bool) = - fun projectee -> match projectee with | B -> true | uu___ -> false -type 'a rbset = - | L - | N of (color * 'a rbset * 'a * 'a rbset) -let uu___is_L : 'a . 'a rbset -> Prims.bool = - fun projectee -> match projectee with | L -> true | uu___ -> false -let uu___is_N : 'a . 'a rbset -> Prims.bool = - fun projectee -> match projectee with | N _0 -> true | uu___ -> false -let __proj__N__item___0 : 'a . 'a rbset -> (color * 'a rbset * 'a * 'a rbset) - = fun projectee -> match projectee with | N _0 -> _0 -type 'a t = 'a rbset -let empty : 'uuuuu . unit -> 'uuuuu rbset = fun uu___ -> L -let singleton : 'a . 'a -> 'a rbset = fun x -> N (R, L, x, L) -let is_empty : 'uuuuu . unit -> 'uuuuu rbset -> Prims.bool = - fun uu___ -> uu___is_L -let balance : - 'uuuuu . color -> 'uuuuu rbset -> 'uuuuu -> 'uuuuu rbset -> 'uuuuu rbset = - fun c -> - fun l -> - fun x -> - fun r -> - match (c, l, x, r) with - | (B, N (R, N (R, a, x1, b), y, c1), z, d) -> - N (R, (N (B, a, x1, b)), y, (N (B, c1, z, d))) - | (B, a, x1, N (R, N (R, b, y, c1), z, d)) -> - N (R, (N (B, a, x1, b)), y, (N (B, c1, z, d))) - | (B, N (R, a, x1, N (R, b, y, c1)), z, d) -> - N (R, (N (B, a, x1, b)), y, (N (B, c1, z, d))) - | (B, a, x1, N (R, b, y, N (R, c1, z, d))) -> - N (R, (N (B, a, x1, b)), y, (N (B, c1, z, d))) - | (c1, l1, x1, r1) -> N (c1, l1, x1, r1) -let blackroot : 'a . 'a rbset -> 'a rbset = - fun t1 -> match t1 with | N (uu___, l, x, r) -> N (B, l, x, r) -let add : 'a . 'a FStar_Class_Ord.ord -> 'a -> 'a rbset -> 'a rbset = - fun uu___ -> - fun x -> - fun s -> - let rec add' s1 = - match s1 with - | L -> N (R, L, x, L) - | N (c, a1, y, b) -> - let uu___1 = FStar_Class_Ord.op_Less_Question uu___ x y in - if uu___1 - then let uu___2 = add' a1 in balance c uu___2 y b - else - (let uu___3 = FStar_Class_Ord.op_Greater_Question uu___ x y in - if uu___3 - then let uu___4 = add' b in balance c a1 y uu___4 - else s1) in - let uu___1 = add' s in blackroot uu___1 -let rec extract_min : - 'a . 'a FStar_Class_Ord.ord -> 'a rbset -> ('a rbset * 'a) = - fun uu___ -> - fun t1 -> - match t1 with - | N (uu___1, L, x, r) -> (r, x) - | N (c, a1, x, b) -> - let uu___1 = extract_min uu___ a1 in - (match uu___1 with | (a', y) -> ((balance c a' x b), y)) -let rec remove : 'a . 'a FStar_Class_Ord.ord -> 'a -> 'a rbset -> 'a rbset = - fun uu___ -> - fun x -> - fun t1 -> - match t1 with - | L -> L - | N (c, l, y, r) -> - let uu___1 = FStar_Class_Ord.op_Less_Question uu___ x y in - if uu___1 - then let uu___2 = remove uu___ x l in balance c uu___2 y r - else - (let uu___3 = FStar_Class_Ord.op_Greater_Question uu___ x y in - if uu___3 - then let uu___4 = remove uu___ x r in balance c l y uu___4 - else - if uu___is_L r - then l - else - (let uu___6 = extract_min uu___ r in - match uu___6 with | (r', y') -> balance c l y' r')) -let rec mem : 'a . 'a FStar_Class_Ord.ord -> 'a -> 'a rbset -> Prims.bool = - fun uu___ -> - fun x -> - fun s -> - match s with - | L -> false - | N (uu___1, a1, y, b) -> - let uu___2 = FStar_Class_Ord.op_Less_Question uu___ x y in - if uu___2 - then mem uu___ x a1 - else - (let uu___4 = FStar_Class_Ord.op_Greater_Question uu___ x y in - if uu___4 then mem uu___ x b else true) -let rec elems : 'a . 'a rbset -> 'a Prims.list = - fun s -> - match s with - | L -> [] - | N (uu___, a1, x, b) -> - let uu___1 = elems a1 in - let uu___2 = - let uu___3 = elems b in FStar_List_Tot_Base.append [x] uu___3 in - FStar_List_Tot_Base.append uu___1 uu___2 -let equal : 'a . 'a FStar_Class_Ord.ord -> 'a rbset -> 'a rbset -> Prims.bool - = - fun uu___ -> - fun s1 -> - fun s2 -> - let uu___1 = elems s1 in - let uu___2 = elems s2 in - FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq (FStar_Class_Ord.ord_list uu___)) uu___1 - uu___2 -let rec union : - 'a . 'a FStar_Class_Ord.ord -> 'a rbset -> 'a rbset -> 'a rbset = - fun uu___ -> - fun s1 -> - fun s2 -> - match s1 with - | L -> s2 - | N (c, a1, x, b) -> - let uu___1 = let uu___2 = add uu___ x s2 in union uu___ b uu___2 in - union uu___ a1 uu___1 -let inter : 'a . 'a FStar_Class_Ord.ord -> 'a rbset -> 'a rbset -> 'a rbset = - fun uu___ -> - fun s1 -> - fun s2 -> - let rec aux s11 acc = - match s11 with - | L -> acc - | N (uu___1, a1, x, b) -> - let uu___2 = mem uu___ x s2 in - if uu___2 - then - let uu___3 = let uu___4 = aux b acc in aux a1 uu___4 in - add uu___ x uu___3 - else (let uu___4 = aux b acc in aux a1 uu___4) in - aux s1 L -let rec diff : - 'a . 'a FStar_Class_Ord.ord -> 'a rbset -> 'a rbset -> 'a rbset = - fun uu___ -> - fun s1 -> - fun s2 -> - match s2 with - | L -> s1 - | N (uu___1, a1, x, b) -> - let uu___2 = - let uu___3 = remove uu___ x s1 in diff uu___ uu___3 a1 in - diff uu___ uu___2 b -let rec subset : - 'a . 'a FStar_Class_Ord.ord -> 'a rbset -> 'a rbset -> Prims.bool = - fun uu___ -> - fun s1 -> - fun s2 -> - match s1 with - | L -> true - | N (uu___1, a1, x, b) -> - ((mem uu___ x s2) && (subset uu___ a1 s2)) && (subset uu___ b s2) -let rec for_all : 'a . ('a -> Prims.bool) -> 'a rbset -> Prims.bool = - fun p -> - fun s -> - match s with - | L -> true - | N (uu___, a1, x, b) -> ((p x) && (for_all p a1)) && (for_all p b) -let rec for_any : 'a . ('a -> Prims.bool) -> 'a rbset -> Prims.bool = - fun p -> - fun s -> - match s with - | L -> false - | N (uu___, a1, x, b) -> ((p x) || (for_any p a1)) || (for_any p b) -let from_list : 'a . 'a FStar_Class_Ord.ord -> 'a Prims.list -> 'a rbset = - fun uu___ -> - fun xs -> - FStar_Compiler_List.fold_left (fun s -> fun e -> add uu___ e s) L xs -let addn : - 'a . 'a FStar_Class_Ord.ord -> 'a Prims.list -> 'a rbset -> 'a rbset = - fun uu___ -> - fun xs -> - fun s -> - FStar_Compiler_List.fold_left (fun s1 -> fun e -> add uu___ e s1) s - xs -let collect : - 'a . - 'a FStar_Class_Ord.ord -> ('a -> 'a rbset) -> 'a Prims.list -> 'a rbset - = - fun uu___ -> - fun f -> - fun l -> - FStar_Compiler_List.fold_left - (fun s -> fun e -> let uu___1 = f e in union uu___ uu___1 s) L l -let setlike_rbset : - 'a . 'a FStar_Class_Ord.ord -> ('a, 'a t) FStar_Class_Setlike.setlike = - fun uu___ -> - { - FStar_Class_Setlike.empty = empty; - FStar_Class_Setlike.singleton = singleton; - FStar_Class_Setlike.is_empty = (is_empty ()); - FStar_Class_Setlike.add = (add uu___); - FStar_Class_Setlike.remove = (remove uu___); - FStar_Class_Setlike.mem = (mem uu___); - FStar_Class_Setlike.equal = (equal uu___); - FStar_Class_Setlike.subset = (subset uu___); - FStar_Class_Setlike.union = (union uu___); - FStar_Class_Setlike.inter = (inter uu___); - FStar_Class_Setlike.diff = (diff uu___); - FStar_Class_Setlike.for_all = for_all; - FStar_Class_Setlike.for_any = for_any; - FStar_Class_Setlike.elems = elems; - FStar_Class_Setlike.collect = (collect uu___); - FStar_Class_Setlike.from_list = (from_list uu___); - FStar_Class_Setlike.addn = (addn uu___) - } -let showable_rbset : - 'a . 'a FStar_Class_Show.showable -> 'a t FStar_Class_Show.showable = - fun uu___ -> - { - FStar_Class_Show.show = - (fun s -> - let uu___1 = - let uu___2 = elems s in - FStar_Class_Show.show (FStar_Class_Show.show_list uu___) uu___2 in - Prims.strcat "RBSet " uu___1) - } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Compiler_Range_Ops.ml b/ocaml/fstar-lib/generated/FStar_Compiler_Range_Ops.ml deleted file mode 100644 index bfeff096163..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Compiler_Range_Ops.ml +++ /dev/null @@ -1,310 +0,0 @@ -open Prims -let (union_rng : - FStar_Compiler_Range_Type.rng -> - FStar_Compiler_Range_Type.rng -> FStar_Compiler_Range_Type.rng) - = - fun r1 -> - fun r2 -> - if - r1.FStar_Compiler_Range_Type.file_name <> - r2.FStar_Compiler_Range_Type.file_name - then r2 - else - (let start_pos = - FStar_Class_Ord.min FStar_Compiler_Range_Type.ord_pos - r1.FStar_Compiler_Range_Type.start_pos - r2.FStar_Compiler_Range_Type.start_pos in - let end_pos = - FStar_Class_Ord.max FStar_Compiler_Range_Type.ord_pos - r1.FStar_Compiler_Range_Type.end_pos - r2.FStar_Compiler_Range_Type.end_pos in - FStar_Compiler_Range_Type.mk_rng - r1.FStar_Compiler_Range_Type.file_name start_pos end_pos) -let (union_ranges : - FStar_Compiler_Range_Type.range -> - FStar_Compiler_Range_Type.range -> FStar_Compiler_Range_Type.range) - = - fun r1 -> - fun r2 -> - let uu___ = - union_rng r1.FStar_Compiler_Range_Type.def_range - r2.FStar_Compiler_Range_Type.def_range in - let uu___1 = - union_rng r1.FStar_Compiler_Range_Type.use_range - r2.FStar_Compiler_Range_Type.use_range in - { - FStar_Compiler_Range_Type.def_range = uu___; - FStar_Compiler_Range_Type.use_range = uu___1 - } -let (rng_included : - FStar_Compiler_Range_Type.rng -> - FStar_Compiler_Range_Type.rng -> Prims.bool) - = - fun r1 -> - fun r2 -> - if - r1.FStar_Compiler_Range_Type.file_name <> - r2.FStar_Compiler_Range_Type.file_name - then false - else - (FStar_Class_Ord.op_Less_Equals_Question - FStar_Compiler_Range_Type.ord_pos - r2.FStar_Compiler_Range_Type.start_pos - r1.FStar_Compiler_Range_Type.start_pos) - && - (FStar_Class_Ord.op_Greater_Equals_Question - FStar_Compiler_Range_Type.ord_pos - r2.FStar_Compiler_Range_Type.end_pos - r1.FStar_Compiler_Range_Type.end_pos) -let (string_of_pos : FStar_Compiler_Range_Type.pos -> Prims.string) = - fun pos -> - let uu___ = - FStar_Compiler_Util.string_of_int pos.FStar_Compiler_Range_Type.line in - let uu___1 = - FStar_Compiler_Util.string_of_int pos.FStar_Compiler_Range_Type.col in - FStar_Compiler_Util.format2 "%s,%s" uu___ uu___1 -let (string_of_file_name : Prims.string -> Prims.string) = - fun f -> - let uu___ = - let uu___1 = FStar_Options_Ext.get "fstar:no_absolute_paths" in - uu___1 = "1" in - if uu___ - then FStar_Compiler_Util.basename f - else - (let uu___2 = FStar_Options.ide () in - if uu___2 - then - try - (fun uu___3 -> - match () with - | () -> - let uu___4 = - let uu___5 = FStar_Compiler_Util.basename f in - FStar_Find.find_file uu___5 in - (match uu___4 with - | FStar_Pervasives_Native.None -> f - | FStar_Pervasives_Native.Some absolute_path -> - absolute_path)) () - with | uu___3 -> f - else f) -let (file_of_range : FStar_Compiler_Range_Type.range -> Prims.string) = - fun r -> - let f = - (r.FStar_Compiler_Range_Type.def_range).FStar_Compiler_Range_Type.file_name in - string_of_file_name f -let (set_file_of_range : - FStar_Compiler_Range_Type.range -> - Prims.string -> FStar_Compiler_Range_Type.range) - = - fun r -> - fun f -> - { - FStar_Compiler_Range_Type.def_range = - (let uu___ = r.FStar_Compiler_Range_Type.def_range in - { - FStar_Compiler_Range_Type.file_name = f; - FStar_Compiler_Range_Type.start_pos = - (uu___.FStar_Compiler_Range_Type.start_pos); - FStar_Compiler_Range_Type.end_pos = - (uu___.FStar_Compiler_Range_Type.end_pos) - }); - FStar_Compiler_Range_Type.use_range = - (r.FStar_Compiler_Range_Type.use_range) - } -let (string_of_rng : FStar_Compiler_Range_Type.rng -> Prims.string) = - fun r -> - let uu___ = string_of_file_name r.FStar_Compiler_Range_Type.file_name in - let uu___1 = string_of_pos r.FStar_Compiler_Range_Type.start_pos in - let uu___2 = string_of_pos r.FStar_Compiler_Range_Type.end_pos in - FStar_Compiler_Util.format3 "%s(%s-%s)" uu___ uu___1 uu___2 -let (string_of_def_range : FStar_Compiler_Range_Type.range -> Prims.string) = - fun r -> string_of_rng r.FStar_Compiler_Range_Type.def_range -let (string_of_use_range : FStar_Compiler_Range_Type.range -> Prims.string) = - fun r -> string_of_rng r.FStar_Compiler_Range_Type.use_range -let (string_of_range : FStar_Compiler_Range_Type.range -> Prims.string) = - fun r -> string_of_def_range r -let (start_of_range : - FStar_Compiler_Range_Type.range -> FStar_Compiler_Range_Type.pos) = - fun r -> - (r.FStar_Compiler_Range_Type.def_range).FStar_Compiler_Range_Type.start_pos -let (end_of_range : - FStar_Compiler_Range_Type.range -> FStar_Compiler_Range_Type.pos) = - fun r -> - (r.FStar_Compiler_Range_Type.def_range).FStar_Compiler_Range_Type.end_pos -let (file_of_use_range : FStar_Compiler_Range_Type.range -> Prims.string) = - fun r -> - (r.FStar_Compiler_Range_Type.use_range).FStar_Compiler_Range_Type.file_name -let (start_of_use_range : - FStar_Compiler_Range_Type.range -> FStar_Compiler_Range_Type.pos) = - fun r -> - (r.FStar_Compiler_Range_Type.use_range).FStar_Compiler_Range_Type.start_pos -let (end_of_use_range : - FStar_Compiler_Range_Type.range -> FStar_Compiler_Range_Type.pos) = - fun r -> - (r.FStar_Compiler_Range_Type.use_range).FStar_Compiler_Range_Type.end_pos -let (line_of_pos : FStar_Compiler_Range_Type.pos -> Prims.int) = - fun p -> p.FStar_Compiler_Range_Type.line -let (col_of_pos : FStar_Compiler_Range_Type.pos -> Prims.int) = - fun p -> p.FStar_Compiler_Range_Type.col -let (end_range : - FStar_Compiler_Range_Type.range -> FStar_Compiler_Range_Type.range) = - fun r -> - FStar_Compiler_Range_Type.mk_range - (r.FStar_Compiler_Range_Type.def_range).FStar_Compiler_Range_Type.file_name - (r.FStar_Compiler_Range_Type.def_range).FStar_Compiler_Range_Type.end_pos - (r.FStar_Compiler_Range_Type.def_range).FStar_Compiler_Range_Type.end_pos -let (compare_rng : - FStar_Compiler_Range_Type.rng -> FStar_Compiler_Range_Type.rng -> Prims.int) - = - fun r1 -> - fun r2 -> - let fcomp = - FStar_String.compare r1.FStar_Compiler_Range_Type.file_name - r2.FStar_Compiler_Range_Type.file_name in - if fcomp = Prims.int_zero - then - let start1 = r1.FStar_Compiler_Range_Type.start_pos in - let start2 = r2.FStar_Compiler_Range_Type.start_pos in - let lcomp = - start1.FStar_Compiler_Range_Type.line - - start2.FStar_Compiler_Range_Type.line in - (if lcomp = Prims.int_zero - then - start1.FStar_Compiler_Range_Type.col - - start2.FStar_Compiler_Range_Type.col - else lcomp) - else fcomp -let (compare : - FStar_Compiler_Range_Type.range -> - FStar_Compiler_Range_Type.range -> Prims.int) - = - fun r1 -> - fun r2 -> - compare_rng r1.FStar_Compiler_Range_Type.def_range - r2.FStar_Compiler_Range_Type.def_range -let (compare_use_range : - FStar_Compiler_Range_Type.range -> - FStar_Compiler_Range_Type.range -> Prims.int) - = - fun r1 -> - fun r2 -> - compare_rng r1.FStar_Compiler_Range_Type.use_range - r2.FStar_Compiler_Range_Type.use_range -let (range_before_pos : - FStar_Compiler_Range_Type.range -> - FStar_Compiler_Range_Type.pos -> Prims.bool) - = - fun m1 -> - fun p -> - let uu___ = end_of_range m1 in - FStar_Class_Ord.op_Greater_Equals_Question - FStar_Compiler_Range_Type.ord_pos p uu___ -let (end_of_line : - FStar_Compiler_Range_Type.pos -> FStar_Compiler_Range_Type.pos) = - fun p -> - { - FStar_Compiler_Range_Type.line = (p.FStar_Compiler_Range_Type.line); - FStar_Compiler_Range_Type.col = FStar_Compiler_Util.max_int - } -let (extend_to_end_of_line : - FStar_Compiler_Range_Type.range -> FStar_Compiler_Range_Type.range) = - fun r -> - let uu___ = file_of_range r in - let uu___1 = start_of_range r in - let uu___2 = let uu___3 = end_of_range r in end_of_line uu___3 in - FStar_Compiler_Range_Type.mk_range uu___ uu___1 uu___2 -let (json_of_pos : FStar_Compiler_Range_Type.pos -> FStar_Json.json) = - fun pos -> - let uu___ = - let uu___1 = let uu___2 = line_of_pos pos in FStar_Json.JsonInt uu___2 in - let uu___2 = - let uu___3 = let uu___4 = col_of_pos pos in FStar_Json.JsonInt uu___4 in - [uu___3] in - uu___1 :: uu___2 in - FStar_Json.JsonList uu___ -let (json_of_range_fields : - Prims.string -> - FStar_Compiler_Range_Type.pos -> - FStar_Compiler_Range_Type.pos -> FStar_Json.json) - = - fun file -> - fun b -> - fun e -> - let uu___ = - let uu___1 = - let uu___2 = let uu___3 = json_of_pos b in ("beg", uu___3) in - let uu___3 = - let uu___4 = let uu___5 = json_of_pos e in ("end", uu___5) in - [uu___4] in - uu___2 :: uu___3 in - ("fname", (FStar_Json.JsonStr file)) :: uu___1 in - FStar_Json.JsonAssoc uu___ -let (json_of_use_range : FStar_Compiler_Range_Type.range -> FStar_Json.json) - = - fun r -> - let uu___ = file_of_use_range r in - let uu___1 = start_of_use_range r in - let uu___2 = end_of_use_range r in - json_of_range_fields uu___ uu___1 uu___2 -let (json_of_def_range : FStar_Compiler_Range_Type.range -> FStar_Json.json) - = - fun r -> - let uu___ = file_of_range r in - let uu___1 = start_of_range r in - let uu___2 = end_of_range r in json_of_range_fields uu___ uu___1 uu___2 -let (intersect_rng : - FStar_Compiler_Range_Type.rng -> - FStar_Compiler_Range_Type.rng -> FStar_Compiler_Range_Type.rng) - = - fun r1 -> - fun r2 -> - if - r1.FStar_Compiler_Range_Type.file_name <> - r2.FStar_Compiler_Range_Type.file_name - then r2 - else - (let start_pos = - FStar_Class_Ord.max FStar_Compiler_Range_Type.ord_pos - r1.FStar_Compiler_Range_Type.start_pos - r2.FStar_Compiler_Range_Type.start_pos in - let end_pos = - FStar_Class_Ord.min FStar_Compiler_Range_Type.ord_pos - r1.FStar_Compiler_Range_Type.end_pos - r2.FStar_Compiler_Range_Type.end_pos in - let uu___1 = - FStar_Class_Ord.op_Greater_Equals_Question - FStar_Compiler_Range_Type.ord_pos start_pos end_pos in - if uu___1 - then r2 - else - FStar_Compiler_Range_Type.mk_rng - r1.FStar_Compiler_Range_Type.file_name start_pos end_pos) -let (intersect_ranges : - FStar_Compiler_Range_Type.range -> - FStar_Compiler_Range_Type.range -> FStar_Compiler_Range_Type.range) - = - fun r1 -> - fun r2 -> - let uu___ = - intersect_rng r1.FStar_Compiler_Range_Type.def_range - r2.FStar_Compiler_Range_Type.def_range in - let uu___1 = - intersect_rng r1.FStar_Compiler_Range_Type.use_range - r2.FStar_Compiler_Range_Type.use_range in - { - FStar_Compiler_Range_Type.def_range = uu___; - FStar_Compiler_Range_Type.use_range = uu___1 - } -let (bound_range : - FStar_Compiler_Range_Type.range -> - FStar_Compiler_Range_Type.range -> FStar_Compiler_Range_Type.range) - = fun r -> fun bound -> intersect_ranges r bound -let (showable_range : - FStar_Compiler_Range_Type.range FStar_Class_Show.showable) = - { FStar_Class_Show.show = string_of_range } -let (pretty_range : FStar_Compiler_Range_Type.range FStar_Class_PP.pretty) = - { - FStar_Class_PP.pp = - (fun r -> - let uu___ = string_of_range r in FStar_Pprint.doc_of_string uu___) - } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Compiler_Range_Type.ml b/ocaml/fstar-lib/generated/FStar_Compiler_Range_Type.ml deleted file mode 100644 index 21049bd71c4..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Compiler_Range_Type.ml +++ /dev/null @@ -1,103 +0,0 @@ -open Prims -type file_name = Prims.string[@@deriving yojson,show] -type pos = { - line: Prims.int ; - col: Prims.int }[@@deriving yojson,show] -let (__proj__Mkpos__item__line : pos -> Prims.int) = - fun projectee -> match projectee with | { line; col;_} -> line -let (__proj__Mkpos__item__col : pos -> Prims.int) = - fun projectee -> match projectee with | { line; col;_} -> col -let (max : Prims.int -> Prims.int -> Prims.int) = - fun i -> fun j -> if i < j then j else i -let (compare_pos : pos -> pos -> FStar_Compiler_Order.order) = - fun p1 -> - fun p2 -> - let uu___ = FStar_Class_Ord.cmp FStar_Class_Ord.ord_int p1.line p2.line in - FStar_Compiler_Order.lex uu___ - (fun uu___1 -> - FStar_Class_Ord.cmp FStar_Class_Ord.ord_int p1.col p2.col) -let (deq_pos : pos FStar_Class_Deq.deq) = - { FStar_Class_Deq.op_Equals_Question = (=) } -let (ord_pos : pos FStar_Class_Ord.ord) = - { FStar_Class_Ord.super = deq_pos; FStar_Class_Ord.cmp = compare_pos } -type rng = { - file_name: file_name ; - start_pos: pos ; - end_pos: pos }[@@deriving yojson,show] -let (__proj__Mkrng__item__file_name : rng -> file_name) = - fun projectee -> - match projectee with - | { file_name = file_name1; start_pos; end_pos;_} -> file_name1 -let (__proj__Mkrng__item__start_pos : rng -> pos) = - fun projectee -> - match projectee with - | { file_name = file_name1; start_pos; end_pos;_} -> start_pos -let (__proj__Mkrng__item__end_pos : rng -> pos) = - fun projectee -> - match projectee with - | { file_name = file_name1; start_pos; end_pos;_} -> end_pos -type range = { - def_range: rng ; - use_range: rng }[@@deriving yojson,show] -let (__proj__Mkrange__item__def_range : range -> rng) = - fun projectee -> - match projectee with | { def_range; use_range;_} -> def_range -let (__proj__Mkrange__item__use_range : range -> rng) = - fun projectee -> - match projectee with | { def_range; use_range;_} -> use_range -let (dummy_pos : pos) = { line = Prims.int_zero; col = Prims.int_zero } -let (dummy_rng : rng) = - { file_name = "dummy"; start_pos = dummy_pos; end_pos = dummy_pos } -let (dummyRange : range) = { def_range = dummy_rng; use_range = dummy_rng } -let (use_range : range -> rng) = fun r -> r.use_range -let (def_range : range -> rng) = fun r -> r.def_range -let (range_of_rng : rng -> rng -> range) = - fun d -> fun u -> { def_range = d; use_range = u } -let (set_use_range : range -> rng -> range) = - fun r2 -> - fun use_rng -> - if use_rng <> dummy_rng - then { def_range = (r2.def_range); use_range = use_rng } - else r2 -let (set_def_range : range -> rng -> range) = - fun r2 -> - fun def_rng -> - if def_rng <> dummy_rng - then { def_range = def_rng; use_range = (r2.use_range) } - else r2 -let (mk_pos : Prims.int -> Prims.int -> pos) = - fun l -> - fun c -> { line = (max Prims.int_zero l); col = (max Prims.int_zero c) } -let (mk_rng : Prims.string -> pos -> pos -> rng) = - fun file_name1 -> - fun start_pos -> - fun end_pos -> { file_name = file_name1; start_pos; end_pos } -let (mk_range : Prims.string -> pos -> pos -> range) = - fun f -> fun b -> fun e -> let r = mk_rng f b e in range_of_rng r r -let (json_of_pos : pos -> FStar_Json.json) = - fun r -> - FStar_Json.JsonAssoc - [("line", (FStar_Json.JsonInt (r.line))); - ("col", (FStar_Json.JsonInt (r.col)))] -let (json_of_rng : rng -> FStar_Json.json) = - fun r -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = json_of_pos r.start_pos in ("start_pos", uu___3) in - let uu___3 = - let uu___4 = - let uu___5 = json_of_pos r.end_pos in ("end_pos", uu___5) in - [uu___4] in - uu___2 :: uu___3 in - ("file_name", (FStar_Json.JsonStr (r.file_name))) :: uu___1 in - FStar_Json.JsonAssoc uu___ -let (json_of_range : range -> FStar_Json.json) = - fun r -> - let uu___ = - let uu___1 = let uu___2 = json_of_rng r.def_range in ("def", uu___2) in - let uu___2 = - let uu___3 = let uu___4 = json_of_rng r.use_range in ("use", uu___4) in - [uu___3] in - uu___1 :: uu___2 in - FStar_Json.JsonAssoc uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Compiler_Writer.ml b/ocaml/fstar-lib/generated/FStar_Compiler_Writer.ml deleted file mode 100644 index 0cbf4af63c1..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Compiler_Writer.ml +++ /dev/null @@ -1,67 +0,0 @@ -open Prims -type ('m, 'uuuuu, 'a) writer = - | Wr of ('m * 'a) -let uu___is_Wr : - 'm . - 'm FStar_Class_Monoid.monoid -> - unit -> ('m, unit, Obj.t) writer -> Prims.bool - = fun uu___ -> fun a -> fun projectee -> true -let __proj__Wr__item___0 : - 'm . - 'm FStar_Class_Monoid.monoid -> - unit -> ('m, unit, Obj.t) writer -> ('m * Obj.t) - = fun uu___ -> fun a -> fun projectee -> match projectee with | Wr _0 -> _0 -let writer_return : - 'm . - 'm FStar_Class_Monoid.monoid -> unit -> Obj.t -> ('m, unit, Obj.t) writer - = fun uu___ -> fun a -> fun x -> Wr ((FStar_Class_Monoid.mzero uu___), x) -let run_writer : - 'm . - 'm FStar_Class_Monoid.monoid -> - unit -> ('m, unit, Obj.t) writer -> ('m * Obj.t) - = - fun uu___ -> - fun a -> - fun x -> let uu___1 = x in match uu___1 with | Wr (m1, x1) -> (m1, x1) -let writer_bind : - 'm . - 'm FStar_Class_Monoid.monoid -> - unit -> - unit -> - ('m, unit, Obj.t) writer -> - (Obj.t -> ('m, unit, Obj.t) writer) -> ('m, unit, Obj.t) writer - = - fun uu___ -> - fun a -> - fun b -> - fun x -> - fun f -> - let uu___1 = x in - match uu___1 with - | Wr (a1, x1) -> - let uu___2 = f x1 in - (match uu___2 with - | Wr (b1, y) -> - let uu___3 = - let uu___4 = FStar_Class_Monoid.mplus uu___ a1 b1 in - (uu___4, y) in - Wr uu___3) -let monad_writer : - 'm . - 'm FStar_Class_Monoid.monoid -> - ('m, unit, unit) writer FStar_Class_Monad.monad - = - fun d -> - { - FStar_Class_Monad.return = - (fun uu___1 -> - fun uu___ -> (Obj.magic (writer_return d)) uu___1 uu___); - FStar_Class_Monad.op_let_Bang = - (fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (Obj.magic (writer_bind d)) uu___3 uu___2 uu___1 uu___) - } -let emit : 'm . 'm FStar_Class_Monoid.monoid -> 'm -> ('m, unit, unit) writer - = fun uu___ -> fun x -> Wr (x, ()) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Const.ml b/ocaml/fstar-lib/generated/FStar_Const.ml deleted file mode 100644 index cfd47dcfa18..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Const.ml +++ /dev/null @@ -1,149 +0,0 @@ -open Prims -type signedness = - | Unsigned - | Signed [@@deriving yojson,show] -let (uu___is_Unsigned : signedness -> Prims.bool) = - fun projectee -> match projectee with | Unsigned -> true | uu___ -> false -let (uu___is_Signed : signedness -> Prims.bool) = - fun projectee -> match projectee with | Signed -> true | uu___ -> false -type width = - | Int8 - | Int16 - | Int32 - | Int64 - | Sizet [@@deriving yojson,show] -let (uu___is_Int8 : width -> Prims.bool) = - fun projectee -> match projectee with | Int8 -> true | uu___ -> false -let (uu___is_Int16 : width -> Prims.bool) = - fun projectee -> match projectee with | Int16 -> true | uu___ -> false -let (uu___is_Int32 : width -> Prims.bool) = - fun projectee -> match projectee with | Int32 -> true | uu___ -> false -let (uu___is_Int64 : width -> Prims.bool) = - fun projectee -> match projectee with | Int64 -> true | uu___ -> false -let (uu___is_Sizet : width -> Prims.bool) = - fun projectee -> match projectee with | Sizet -> true | uu___ -> false -type sconst = - | Const_effect - | Const_unit - | Const_bool of Prims.bool - | Const_int of (Prims.string * (signedness * width) - FStar_Pervasives_Native.option) - | Const_char of FStar_BaseTypes.char - | Const_real of Prims.string - | Const_string of (Prims.string * FStar_Compiler_Range_Type.range) - | Const_range_of - | Const_set_range_of - | Const_range of FStar_Compiler_Range_Type.range - | Const_reify of FStar_Ident.lid FStar_Pervasives_Native.option - | Const_reflect of FStar_Ident.lid [@@deriving yojson,show] -let (uu___is_Const_effect : sconst -> Prims.bool) = - fun projectee -> - match projectee with | Const_effect -> true | uu___ -> false -let (uu___is_Const_unit : sconst -> Prims.bool) = - fun projectee -> match projectee with | Const_unit -> true | uu___ -> false -let (uu___is_Const_bool : sconst -> Prims.bool) = - fun projectee -> - match projectee with | Const_bool _0 -> true | uu___ -> false -let (__proj__Const_bool__item___0 : sconst -> Prims.bool) = - fun projectee -> match projectee with | Const_bool _0 -> _0 -let (uu___is_Const_int : sconst -> Prims.bool) = - fun projectee -> - match projectee with | Const_int _0 -> true | uu___ -> false -let (__proj__Const_int__item___0 : - sconst -> - (Prims.string * (signedness * width) FStar_Pervasives_Native.option)) - = fun projectee -> match projectee with | Const_int _0 -> _0 -let (uu___is_Const_char : sconst -> Prims.bool) = - fun projectee -> - match projectee with | Const_char _0 -> true | uu___ -> false -let (__proj__Const_char__item___0 : sconst -> FStar_BaseTypes.char) = - fun projectee -> match projectee with | Const_char _0 -> _0 -let (uu___is_Const_real : sconst -> Prims.bool) = - fun projectee -> - match projectee with | Const_real _0 -> true | uu___ -> false -let (__proj__Const_real__item___0 : sconst -> Prims.string) = - fun projectee -> match projectee with | Const_real _0 -> _0 -let (uu___is_Const_string : sconst -> Prims.bool) = - fun projectee -> - match projectee with | Const_string _0 -> true | uu___ -> false -let (__proj__Const_string__item___0 : - sconst -> (Prims.string * FStar_Compiler_Range_Type.range)) = - fun projectee -> match projectee with | Const_string _0 -> _0 -let (uu___is_Const_range_of : sconst -> Prims.bool) = - fun projectee -> - match projectee with | Const_range_of -> true | uu___ -> false -let (uu___is_Const_set_range_of : sconst -> Prims.bool) = - fun projectee -> - match projectee with | Const_set_range_of -> true | uu___ -> false -let (uu___is_Const_range : sconst -> Prims.bool) = - fun projectee -> - match projectee with | Const_range _0 -> true | uu___ -> false -let (__proj__Const_range__item___0 : - sconst -> FStar_Compiler_Range_Type.range) = - fun projectee -> match projectee with | Const_range _0 -> _0 -let (uu___is_Const_reify : sconst -> Prims.bool) = - fun projectee -> - match projectee with | Const_reify _0 -> true | uu___ -> false -let (__proj__Const_reify__item___0 : - sconst -> FStar_Ident.lid FStar_Pervasives_Native.option) = - fun projectee -> match projectee with | Const_reify _0 -> _0 -let (uu___is_Const_reflect : sconst -> Prims.bool) = - fun projectee -> - match projectee with | Const_reflect _0 -> true | uu___ -> false -let (__proj__Const_reflect__item___0 : sconst -> FStar_Ident.lid) = - fun projectee -> match projectee with | Const_reflect _0 -> _0 -let (eq_const : sconst -> sconst -> Prims.bool) = - fun c1 -> - fun c2 -> - match (c1, c2) with - | (Const_int (s1, o1), Const_int (s2, o2)) -> - (let uu___ = FStar_Compiler_Util.ensure_decimal s1 in - let uu___1 = FStar_Compiler_Util.ensure_decimal s2 in - uu___ = uu___1) && (o1 = o2) - | (Const_string (a, uu___), Const_string (b, uu___1)) -> a = b - | (Const_reflect l1, Const_reflect l2) -> FStar_Ident.lid_equals l1 l2 - | (Const_reify uu___, Const_reify uu___1) -> true - | uu___ -> c1 = c2 -let rec (pow2 : FStar_BigInt.bigint -> FStar_BigInt.bigint) = - fun x -> - let uu___ = FStar_BigInt.eq_big_int x FStar_BigInt.zero in - if uu___ - then FStar_BigInt.one - else - (let uu___2 = let uu___3 = FStar_BigInt.pred_big_int x in pow2 uu___3 in - FStar_BigInt.mult_big_int FStar_BigInt.two uu___2) -let (bounds : - signedness -> width -> (FStar_BigInt.bigint * FStar_BigInt.bigint)) = - fun signedness1 -> - fun width1 -> - let n = - match width1 with - | Int8 -> FStar_BigInt.big_int_of_string "8" - | Int16 -> FStar_BigInt.big_int_of_string "16" - | Int32 -> FStar_BigInt.big_int_of_string "32" - | Int64 -> FStar_BigInt.big_int_of_string "64" - | Sizet -> FStar_BigInt.big_int_of_string "16" in - let uu___ = - match signedness1 with - | Unsigned -> - let uu___1 = - let uu___2 = pow2 n in FStar_BigInt.pred_big_int uu___2 in - (FStar_BigInt.zero, uu___1) - | Signed -> - let upper = - let uu___1 = FStar_BigInt.pred_big_int n in pow2 uu___1 in - let uu___1 = FStar_BigInt.minus_big_int upper in - let uu___2 = FStar_BigInt.pred_big_int upper in (uu___1, uu___2) in - match uu___ with | (lower, upper) -> (lower, upper) -let (within_bounds : Prims.string -> signedness -> width -> Prims.bool) = - fun repr -> - fun signedness1 -> - fun width1 -> - let uu___ = bounds signedness1 width1 in - match uu___ with - | (lower, upper) -> - let value = - let uu___1 = FStar_Compiler_Util.ensure_decimal repr in - FStar_BigInt.big_int_of_string uu___1 in - (FStar_BigInt.le_big_int lower value) && - (FStar_BigInt.le_big_int value upper) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Defensive.ml b/ocaml/fstar-lib/generated/FStar_Defensive.ml deleted file mode 100644 index 653cf38f661..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Defensive.ml +++ /dev/null @@ -1,135 +0,0 @@ -open Prims -let (pp_bv : FStar_Syntax_Syntax.bv FStar_Class_PP.pretty) = - { - FStar_Class_PP.pp = - (fun bv -> - let uu___ = FStar_Class_Show.show FStar_Syntax_Print.showable_bv bv in - FStar_Pprint.arbitrary_string uu___) - } -let pp_set : - 'a . - 'a FStar_Class_Ord.ord -> - 'a FStar_Class_PP.pretty -> - 'a FStar_Compiler_FlatSet.t FStar_Class_PP.pretty - = - fun uu___ -> - fun uu___1 -> - { - FStar_Class_PP.pp = - (fun s -> - let doclist ds = - let uu___2 = FStar_Pprint.doc_of_string "[]" in - let uu___3 = - let uu___4 = FStar_Pprint.break_ Prims.int_one in - FStar_Pprint.op_Hat_Hat FStar_Pprint.semi uu___4 in - FStar_Pprint.surround_separate (Prims.of_int (2)) - Prims.int_zero uu___2 FStar_Pprint.lbracket uu___3 - FStar_Pprint.rbracket ds in - let uu___2 = - let uu___3 = - FStar_Class_Setlike.elems () - (Obj.magic (FStar_Compiler_FlatSet.setlike_flat_set uu___)) - (Obj.magic s) in - FStar_Compiler_List.map (FStar_Class_PP.pp uu___1) uu___3 in - doclist uu___2) - } -let __def_check_scoped : - 'envut 'thingut . - 'envut FStar_Class_Binders.hasBinders -> - 'thingut FStar_Class_Binders.hasNames -> - 'thingut FStar_Class_PP.pretty -> - FStar_Compiler_Range_Type.range -> - Prims.string -> 'envut -> 'thingut -> unit - = - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun rng -> - fun msg -> - fun env -> - fun thing -> - let free = FStar_Class_Binders.freeNames uu___1 thing in - let scope = FStar_Class_Binders.boundNames uu___ env in - let uu___3 = - let uu___4 = - FStar_Class_Setlike.subset () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) (Obj.magic free) - (Obj.magic scope) in - Prims.op_Negation uu___4 in - if uu___3 - then - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Errors_Msg.text - "Internal: term is not well-scoped " in - let uu___7 = - let uu___8 = FStar_Pprint.doc_of_string msg in - FStar_Pprint.parens uu___8 in - FStar_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in - let uu___6 = - let uu___7 = - let uu___8 = FStar_Errors_Msg.text "t =" in - let uu___9 = FStar_Class_PP.pp uu___2 thing in - FStar_Pprint.op_Hat_Slash_Hat uu___8 uu___9 in - let uu___8 = - let uu___9 = - let uu___10 = FStar_Errors_Msg.text "FVs =" in - let uu___11 = - FStar_Class_PP.pp - (pp_set FStar_Syntax_Syntax.ord_bv pp_bv) free in - FStar_Pprint.op_Hat_Slash_Hat uu___10 uu___11 in - let uu___10 = - let uu___11 = - let uu___12 = FStar_Errors_Msg.text "Scope =" in - let uu___13 = - FStar_Class_PP.pp - (pp_set FStar_Syntax_Syntax.ord_bv pp_bv) - scope in - FStar_Pprint.op_Hat_Slash_Hat uu___12 uu___13 in - let uu___12 = - let uu___13 = - let uu___14 = FStar_Errors_Msg.text "Diff =" in - let uu___15 = - let uu___16 = - Obj.magic - (FStar_Class_Setlike.diff () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) - (Obj.magic free) (Obj.magic scope)) in - FStar_Class_PP.pp - (pp_set FStar_Syntax_Syntax.ord_bv pp_bv) - uu___16 in - FStar_Pprint.op_Hat_Slash_Hat uu___14 uu___15 in - [uu___13] in - uu___11 :: uu___12 in - uu___9 :: uu___10 in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - FStar_Errors.log_issue FStar_Class_HasRange.hasRange_range - rng FStar_Errors_Codes.Warning_Defensive () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___4) - else () -let def_check_scoped : - 'envut 'thingut . - 'envut FStar_Class_Binders.hasBinders -> - 'thingut FStar_Class_Binders.hasNames -> - 'thingut FStar_Class_PP.pretty -> - FStar_Compiler_Range_Type.range -> - Prims.string -> 'envut -> 'thingut -> unit - = - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun rng -> - fun msg -> - fun env -> - fun thing -> - let uu___3 = FStar_Options.defensive () in - if uu___3 - then __def_check_scoped uu___ uu___1 uu___2 rng msg env thing - else () \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Dependencies.ml b/ocaml/fstar-lib/generated/FStar_Dependencies.ml deleted file mode 100644 index 2da2c39e331..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Dependencies.ml +++ /dev/null @@ -1,21 +0,0 @@ -open Prims -let (find_deps_if_needed : - Prims.string Prims.list -> - (Prims.string -> - FStar_Parser_Dep.parsing_data FStar_Pervasives_Native.option) - -> (Prims.string Prims.list * FStar_Parser_Dep.deps)) - = - fun files -> - fun get_parsing_data_from_cache -> - let uu___ = FStar_Parser_Dep.collect files get_parsing_data_from_cache in - match uu___ with - | (all_files, deps) -> - (match all_files with - | [] -> - (FStar_Errors.log_issue0 - FStar_Errors_Codes.Error_DependencyAnalysisFailed () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Dependency analysis failed; reverting to using only the files provided"); - (files, deps)) - | uu___1 -> ((FStar_Compiler_List.rev all_files), deps)) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Errors.ml b/ocaml/fstar-lib/generated/FStar_Errors.ml deleted file mode 100644 index 4afcfe24ad4..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Errors.ml +++ /dev/null @@ -1,1205 +0,0 @@ -open Prims -let (fallback_range : - FStar_Compiler_Range_Type.range FStar_Pervasives_Native.option - FStar_Compiler_Effect.ref) - = FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None -let (error_range_bound : - FStar_Compiler_Range_Type.range FStar_Pervasives_Native.option - FStar_Compiler_Effect.ref) - = FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None -let with_error_bound : - 'a . FStar_Compiler_Range_Type.range -> (unit -> 'a) -> 'a = - fun r -> - fun f -> - let old = FStar_Compiler_Effect.op_Bang error_range_bound in - FStar_Compiler_Effect.op_Colon_Equals error_range_bound - (FStar_Pervasives_Native.Some r); - (let res = f () in - FStar_Compiler_Effect.op_Colon_Equals error_range_bound old; res) -exception Invalid_warn_error_setting of Prims.string -let (uu___is_Invalid_warn_error_setting : Prims.exn -> Prims.bool) = - fun projectee -> - match projectee with - | Invalid_warn_error_setting uu___ -> true - | uu___ -> false -let (__proj__Invalid_warn_error_setting__item__uu___ : - Prims.exn -> Prims.string) = - fun projectee -> - match projectee with | Invalid_warn_error_setting uu___ -> uu___ -let lookup_error : - 'uuuuu 'uuuuu1 'uuuuu2 . - ('uuuuu * 'uuuuu1 * 'uuuuu2) Prims.list -> - 'uuuuu -> ('uuuuu * 'uuuuu1 * 'uuuuu2) - = - fun settings -> - fun e -> - let uu___ = - FStar_Compiler_Util.try_find - (fun uu___1 -> match uu___1 with | (v, uu___2, i) -> e = v) - settings in - match uu___ with - | FStar_Pervasives_Native.Some i -> i - | FStar_Pervasives_Native.None -> - failwith "Impossible: unrecognized error" -let lookup_error_range : - 'uuuuu 'uuuuu1 . - ('uuuuu * 'uuuuu1 * Prims.int) Prims.list -> - (Prims.int * Prims.int) -> ('uuuuu * 'uuuuu1 * Prims.int) Prims.list - = - fun settings -> - fun uu___ -> - match uu___ with - | (l, h) -> - let uu___1 = - FStar_Compiler_List.partition - (fun uu___2 -> - match uu___2 with - | (uu___3, uu___4, i) -> (l <= i) && (i <= h)) settings in - (match uu___1 with | (matches, uu___2) -> matches) -let (error_number : FStar_Errors_Codes.error_setting -> Prims.int) = - fun uu___ -> match uu___ with | (uu___1, uu___2, i) -> i -let (errno : FStar_Errors_Codes.error_code -> Prims.int) = - fun e -> - let uu___ = lookup_error FStar_Errors_Codes.default_settings e in - error_number uu___ -let (warn_on_use_errno : Prims.int) = - errno FStar_Errors_Codes.Warning_WarnOnUse -let (defensive_errno : Prims.int) = - errno FStar_Errors_Codes.Warning_Defensive -let (call_to_erased_errno : Prims.int) = - errno FStar_Errors_Codes.Error_CallToErased -let (update_flags : - (FStar_Errors_Codes.error_flag * Prims.string) Prims.list -> - FStar_Errors_Codes.error_setting Prims.list) - = - fun l -> - let set_one_flag i flag default_flag = - match (flag, default_flag) with - | (FStar_Errors_Codes.CWarning, FStar_Errors_Codes.CAlwaysError) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Compiler_Util.string_of_int i in - FStar_Compiler_Util.format1 "cannot turn error %s into warning" - uu___2 in - Invalid_warn_error_setting uu___1 in - FStar_Compiler_Effect.raise uu___ - | (FStar_Errors_Codes.CError, FStar_Errors_Codes.CAlwaysError) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Compiler_Util.string_of_int i in - FStar_Compiler_Util.format1 "cannot turn error %s into warning" - uu___2 in - Invalid_warn_error_setting uu___1 in - FStar_Compiler_Effect.raise uu___ - | (FStar_Errors_Codes.CSilent, FStar_Errors_Codes.CAlwaysError) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Compiler_Util.string_of_int i in - FStar_Compiler_Util.format1 "cannot silence error %s" uu___2 in - Invalid_warn_error_setting uu___1 in - FStar_Compiler_Effect.raise uu___ - | (FStar_Errors_Codes.CSilent, FStar_Errors_Codes.CFatal) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Compiler_Util.string_of_int i in - FStar_Compiler_Util.format1 - "cannot change the error level of fatal error %s" uu___2 in - Invalid_warn_error_setting uu___1 in - FStar_Compiler_Effect.raise uu___ - | (FStar_Errors_Codes.CWarning, FStar_Errors_Codes.CFatal) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Compiler_Util.string_of_int i in - FStar_Compiler_Util.format1 - "cannot change the error level of fatal error %s" uu___2 in - Invalid_warn_error_setting uu___1 in - FStar_Compiler_Effect.raise uu___ - | (FStar_Errors_Codes.CError, FStar_Errors_Codes.CFatal) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Compiler_Util.string_of_int i in - FStar_Compiler_Util.format1 - "cannot change the error level of fatal error %s" uu___2 in - Invalid_warn_error_setting uu___1 in - FStar_Compiler_Effect.raise uu___ - | (FStar_Errors_Codes.CAlwaysError, FStar_Errors_Codes.CFatal) -> - FStar_Errors_Codes.CFatal - | uu___ -> flag in - let set_flag_for_range uu___ = - match uu___ with - | (flag, range) -> - let errs = - lookup_error_range FStar_Errors_Codes.default_settings range in - FStar_Compiler_List.map - (fun uu___1 -> - match uu___1 with - | (v, default_flag, i) -> - let uu___2 = set_one_flag i flag default_flag in - (v, uu___2, i)) errs in - let compute_range uu___ = - match uu___ with - | (flag, s) -> - let r = FStar_Compiler_Util.split s ".." in - let uu___1 = - match r with - | r1::r2::[] -> - let uu___2 = FStar_Compiler_Util.int_of_string r1 in - let uu___3 = FStar_Compiler_Util.int_of_string r2 in - (uu___2, uu___3) - | uu___2 -> - let uu___3 = - let uu___4 = - FStar_Compiler_Util.format1 - "Malformed warn-error range %s" s in - Invalid_warn_error_setting uu___4 in - FStar_Compiler_Effect.raise uu___3 in - (match uu___1 with | (l1, h) -> (flag, (l1, h))) in - let error_range_settings = - FStar_Compiler_List.map compute_range (FStar_Compiler_List.rev l) in - let uu___ = - FStar_Compiler_List.collect set_flag_for_range error_range_settings in - FStar_Compiler_List.op_At uu___ FStar_Errors_Codes.default_settings -type error = - (FStar_Errors_Codes.error_code * FStar_Errors_Msg.error_message * - FStar_Compiler_Range_Type.range * Prims.string Prims.list) -type issue_level = - | ENotImplemented - | EInfo - | EWarning - | EError -let (uu___is_ENotImplemented : issue_level -> Prims.bool) = - fun projectee -> - match projectee with | ENotImplemented -> true | uu___ -> false -let (uu___is_EInfo : issue_level -> Prims.bool) = - fun projectee -> match projectee with | EInfo -> true | uu___ -> false -let (uu___is_EWarning : issue_level -> Prims.bool) = - fun projectee -> match projectee with | EWarning -> true | uu___ -> false -let (uu___is_EError : issue_level -> Prims.bool) = - fun projectee -> match projectee with | EError -> true | uu___ -> false -exception Error of error -let (uu___is_Error : Prims.exn -> Prims.bool) = - fun projectee -> - match projectee with | Error uu___ -> true | uu___ -> false -let (__proj__Error__item__uu___ : Prims.exn -> error) = - fun projectee -> match projectee with | Error uu___ -> uu___ -exception Warning of error -let (uu___is_Warning : Prims.exn -> Prims.bool) = - fun projectee -> - match projectee with | Warning uu___ -> true | uu___ -> false -let (__proj__Warning__item__uu___ : Prims.exn -> error) = - fun projectee -> match projectee with | Warning uu___ -> uu___ -exception Stop -let (uu___is_Stop : Prims.exn -> Prims.bool) = - fun projectee -> match projectee with | Stop -> true | uu___ -> false -exception Empty_frag -let (uu___is_Empty_frag : Prims.exn -> Prims.bool) = - fun projectee -> match projectee with | Empty_frag -> true | uu___ -> false -let (json_of_issue_level : issue_level -> FStar_Json.json) = - fun level -> - FStar_Json.JsonStr - (match level with - | ENotImplemented -> "NotImplemented" - | EInfo -> "Info" - | EWarning -> "Warning" - | EError -> "Error") -type issue = - { - issue_msg: FStar_Errors_Msg.error_message ; - issue_level: issue_level ; - issue_range: FStar_Compiler_Range_Type.range FStar_Pervasives_Native.option ; - issue_number: Prims.int FStar_Pervasives_Native.option ; - issue_ctx: Prims.string Prims.list } -let (__proj__Mkissue__item__issue_msg : - issue -> FStar_Errors_Msg.error_message) = - fun projectee -> - match projectee with - | { issue_msg; issue_level = issue_level1; issue_range; issue_number; - issue_ctx;_} -> issue_msg -let (__proj__Mkissue__item__issue_level : issue -> issue_level) = - fun projectee -> - match projectee with - | { issue_msg; issue_level = issue_level1; issue_range; issue_number; - issue_ctx;_} -> issue_level1 -let (__proj__Mkissue__item__issue_range : - issue -> FStar_Compiler_Range_Type.range FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { issue_msg; issue_level = issue_level1; issue_range; issue_number; - issue_ctx;_} -> issue_range -let (__proj__Mkissue__item__issue_number : - issue -> Prims.int FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { issue_msg; issue_level = issue_level1; issue_range; issue_number; - issue_ctx;_} -> issue_number -let (__proj__Mkissue__item__issue_ctx : issue -> Prims.string Prims.list) = - fun projectee -> - match projectee with - | { issue_msg; issue_level = issue_level1; issue_range; issue_number; - issue_ctx;_} -> issue_ctx -let (json_of_issue : issue -> FStar_Json.json) = - fun issue1 -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Errors_Msg.json_of_error_message issue1.issue_msg in - ("msg", uu___2) in - let uu___2 = - let uu___3 = - let uu___4 = json_of_issue_level issue1.issue_level in - ("level", uu___4) in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - Obj.magic - (FStar_Class_Monad.op_Less_Dollar_Greater - FStar_Class_Monad.monad_option () () - (fun uu___8 -> - (Obj.magic FStar_Compiler_Range_Type.json_of_range) - uu___8) (Obj.magic issue1.issue_range)) in - FStar_Compiler_Util.dflt FStar_Json.JsonNull uu___7 in - ("range", uu___6) in - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - Obj.magic - (FStar_Class_Monad.op_Less_Dollar_Greater - FStar_Class_Monad.monad_option () () - (fun uu___10 -> - (fun uu___10 -> - let uu___10 = Obj.magic uu___10 in - Obj.magic (FStar_Json.JsonInt uu___10)) uu___10) - (Obj.magic issue1.issue_number)) in - FStar_Compiler_Util.dflt FStar_Json.JsonNull uu___9 in - ("number", uu___8) in - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - Obj.magic - (FStar_Class_Monad.op_Less_Dollar_Greater - FStar_Class_Monad.monad_list () () - (fun uu___12 -> - (fun uu___12 -> - let uu___12 = Obj.magic uu___12 in - Obj.magic (FStar_Json.JsonStr uu___12)) - uu___12) (Obj.magic issue1.issue_ctx)) in - FStar_Json.JsonList uu___11 in - ("ctx", uu___10) in - [uu___9] in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Json.JsonAssoc uu___ -type error_handler = - { - eh_name: Prims.string ; - eh_add_one: issue -> unit ; - eh_count_errors: unit -> Prims.int ; - eh_report: unit -> issue Prims.list ; - eh_clear: unit -> unit } -let (__proj__Mkerror_handler__item__eh_name : error_handler -> Prims.string) - = - fun projectee -> - match projectee with - | { eh_name; eh_add_one; eh_count_errors; eh_report; eh_clear;_} -> - eh_name -let (__proj__Mkerror_handler__item__eh_add_one : - error_handler -> issue -> unit) = - fun projectee -> - match projectee with - | { eh_name; eh_add_one; eh_count_errors; eh_report; eh_clear;_} -> - eh_add_one -let (__proj__Mkerror_handler__item__eh_count_errors : - error_handler -> unit -> Prims.int) = - fun projectee -> - match projectee with - | { eh_name; eh_add_one; eh_count_errors; eh_report; eh_clear;_} -> - eh_count_errors -let (__proj__Mkerror_handler__item__eh_report : - error_handler -> unit -> issue Prims.list) = - fun projectee -> - match projectee with - | { eh_name; eh_add_one; eh_count_errors; eh_report; eh_clear;_} -> - eh_report -let (__proj__Mkerror_handler__item__eh_clear : error_handler -> unit -> unit) - = - fun projectee -> - match projectee with - | { eh_name; eh_add_one; eh_count_errors; eh_report; eh_clear;_} -> - eh_clear -let (ctx_doc : Prims.string Prims.list -> FStar_Pprint.document) = - fun ctx -> - let uu___ = FStar_Options.error_contexts () in - if uu___ - then - let uu___1 = - FStar_Compiler_List.map - (fun s -> - let uu___2 = - let uu___3 = FStar_Pprint.doc_of_string "> " in - let uu___4 = FStar_Pprint.doc_of_string s in - FStar_Pprint.op_Hat_Hat uu___3 uu___4 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline uu___2) ctx in - FStar_Pprint.concat uu___1 - else FStar_Pprint.empty -let (issue_message : issue -> FStar_Errors_Msg.error_message) = - fun i -> - let uu___ = let uu___1 = ctx_doc i.issue_ctx in [uu___1] in - FStar_Compiler_List.op_At i.issue_msg uu___ -let (string_of_issue_level : issue_level -> Prims.string) = - fun il -> - match il with - | EInfo -> "Info" - | EWarning -> "Warning" - | EError -> "Error" - | ENotImplemented -> "Feature not yet implemented: " -let (issue_level_of_string : Prims.string -> issue_level) = - fun uu___ -> - match uu___ with - | "Info" -> EInfo - | "Warning" -> EWarning - | "Error" -> EError - | uu___1 -> ENotImplemented -let optional_def : - 'a . - ('a -> FStar_Pprint.document) -> - FStar_Pprint.document -> - 'a FStar_Pervasives_Native.option -> FStar_Pprint.document - = - fun f -> - fun def -> - fun o -> - match o with - | FStar_Pervasives_Native.Some x -> f x - | FStar_Pervasives_Native.None -> def -let (format_issue' : Prims.bool -> issue -> Prims.string) = - fun print_hdr -> - fun issue1 -> - let level_header = - let uu___ = string_of_issue_level issue1.issue_level in - FStar_Pprint.doc_of_string uu___ in - let num_opt = - if (issue1.issue_level = EError) || (issue1.issue_level = EWarning) - then - let uu___ = FStar_Pprint.blank Prims.int_one in - let uu___1 = - let uu___2 = FStar_Pprint.doc_of_string "" in - optional_def - (fun n -> - let uu___3 = FStar_Compiler_Util.string_of_int n in - FStar_Pprint.doc_of_string uu___3) uu___2 - issue1.issue_number in - FStar_Pprint.op_Hat_Hat uu___ uu___1 - else FStar_Pprint.empty in - let r = issue1.issue_range in - let atrng = - match r with - | FStar_Pervasives_Native.Some r1 when - r1 <> FStar_Compiler_Range_Type.dummyRange -> - let uu___ = FStar_Pprint.blank Prims.int_one in - let uu___1 = - let uu___2 = FStar_Pprint.doc_of_string "at" in - let uu___3 = - let uu___4 = FStar_Pprint.blank Prims.int_one in - let uu___5 = - let uu___6 = - FStar_Compiler_Range_Ops.string_of_use_range r1 in - FStar_Pprint.doc_of_string uu___6 in - FStar_Pprint.op_Hat_Hat uu___4 uu___5 in - FStar_Pprint.op_Hat_Hat uu___2 uu___3 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 - | uu___ -> FStar_Pprint.empty in - let hdr = - if print_hdr - then - let uu___ = FStar_Pprint.doc_of_string "*" in - let uu___1 = - let uu___2 = FStar_Pprint.blank Prims.int_one in - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = FStar_Pprint.doc_of_string ":" in - FStar_Pprint.op_Hat_Hat uu___7 FStar_Pprint.hardline in - FStar_Pprint.op_Hat_Hat atrng uu___6 in - FStar_Pprint.op_Hat_Hat num_opt uu___5 in - FStar_Pprint.op_Hat_Hat level_header uu___4 in - FStar_Pprint.op_Hat_Hat uu___2 uu___3 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 - else FStar_Pprint.empty in - let seealso = - match r with - | FStar_Pervasives_Native.Some r1 when - (let uu___ = FStar_Compiler_Range_Type.def_range r1 in - let uu___1 = FStar_Compiler_Range_Type.use_range r1 in - uu___ <> uu___1) && - (let uu___ = FStar_Compiler_Range_Type.def_range r1 in - let uu___1 = - FStar_Compiler_Range_Type.def_range - FStar_Compiler_Range_Type.dummyRange in - uu___ <> uu___1) - -> - let uu___ = FStar_Pprint.doc_of_string "See also" in - let uu___1 = - let uu___2 = FStar_Pprint.blank Prims.int_one in - let uu___3 = - let uu___4 = FStar_Compiler_Range_Ops.string_of_range r1 in - FStar_Pprint.doc_of_string uu___4 in - FStar_Pprint.op_Hat_Hat uu___2 uu___3 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 - | uu___ -> FStar_Pprint.empty in - let ctx = - match issue1.issue_ctx with - | h::t when FStar_Options.error_contexts () -> - let d1 s = - let uu___ = FStar_Pprint.doc_of_string "> " in - let uu___1 = FStar_Pprint.doc_of_string s in - FStar_Pprint.op_Hat_Hat uu___ uu___1 in - let uu___ = d1 h in - FStar_Compiler_List.fold_left - (fun l -> - fun r1 -> - let uu___1 = - let uu___2 = d1 r1 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline uu___2 in - FStar_Pprint.op_Hat_Hat l uu___1) uu___ t - | uu___ -> FStar_Pprint.empty in - let subdoc = FStar_Errors_Msg.subdoc' print_hdr in - let mainmsg = - let uu___ = - FStar_Compiler_List.map - (fun d -> let uu___1 = FStar_Pprint.group d in subdoc uu___1) - issue1.issue_msg in - FStar_Pprint.concat uu___ in - let doc = - let uu___ = - let uu___1 = - let uu___2 = subdoc seealso in - let uu___3 = subdoc ctx in FStar_Pprint.op_Hat_Hat uu___2 uu___3 in - FStar_Pprint.op_Hat_Hat mainmsg uu___1 in - FStar_Pprint.op_Hat_Hat hdr uu___ in - FStar_Errors_Msg.renderdoc doc -let (format_issue : issue -> Prims.string) = - fun issue1 -> format_issue' true issue1 -let (print_issue_json : issue -> unit) = - fun issue1 -> - let uu___ = - let uu___1 = json_of_issue issue1 in FStar_Json.string_of_json uu___1 in - FStar_Compiler_Util.print1_error "%s\n" uu___ -let (print_issue_rendered : issue -> unit) = - fun issue1 -> - let printer = - match issue1.issue_level with - | EInfo -> - (fun s -> - let uu___ = FStar_Compiler_Util.colorize_cyan s in - FStar_Compiler_Util.print_string uu___) - | EWarning -> FStar_Compiler_Util.print_warning - | EError -> FStar_Compiler_Util.print_error - | ENotImplemented -> FStar_Compiler_Util.print_error in - let uu___ = let uu___1 = format_issue issue1 in Prims.strcat uu___1 "\n" in - printer uu___ -let (print_issue : issue -> unit) = - fun issue1 -> - let uu___ = FStar_Options.message_format () in - match uu___ with - | FStar_Options.Human -> print_issue_rendered issue1 - | FStar_Options.Json -> print_issue_json issue1 -let (compare_issues : issue -> issue -> Prims.int) = - fun i1 -> - fun i2 -> - match ((i1.issue_range), (i2.issue_range)) with - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> - Prims.int_zero - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.Some uu___) -> - (Prims.of_int (-1)) - | (FStar_Pervasives_Native.Some uu___, FStar_Pervasives_Native.None) -> - Prims.int_one - | (FStar_Pervasives_Native.Some r1, FStar_Pervasives_Native.Some r2) -> - FStar_Compiler_Range_Ops.compare_use_range r1 r2 -let (dummy_ide_rng : FStar_Compiler_Range_Type.rng) = - let uu___ = FStar_Compiler_Range_Type.mk_pos Prims.int_one Prims.int_zero in - let uu___1 = FStar_Compiler_Range_Type.mk_pos Prims.int_one Prims.int_zero in - FStar_Compiler_Range_Type.mk_rng "" uu___ uu___1 -let (maybe_bound_rng : - FStar_Compiler_Range_Type.range -> FStar_Compiler_Range_Type.range) = - fun r -> - let uu___ = FStar_Compiler_Effect.op_Bang error_range_bound in - match uu___ with - | FStar_Pervasives_Native.Some r' -> - FStar_Compiler_Range_Ops.bound_range r r' - | FStar_Pervasives_Native.None -> r -let (fixup_issue_range : issue -> issue) = - fun i -> - let rng = - match i.issue_range with - | FStar_Pervasives_Native.None -> - FStar_Compiler_Effect.op_Bang fallback_range - | FStar_Pervasives_Native.Some range -> - let use_rng = FStar_Compiler_Range_Type.use_range range in - let use_rng' = - if - (use_rng <> FStar_Compiler_Range_Type.dummy_rng) && - (use_rng <> dummy_ide_rng) - then use_rng - else - (let uu___1 = - let uu___2 = FStar_Compiler_Effect.op_Bang fallback_range in - FStar_Pervasives_Native.uu___is_Some uu___2 in - if uu___1 - then - let uu___2 = - let uu___3 = FStar_Compiler_Effect.op_Bang fallback_range in - FStar_Pervasives_Native.__proj__Some__item__v uu___3 in - FStar_Compiler_Range_Type.use_range uu___2 - else use_rng) in - let uu___ = FStar_Compiler_Range_Type.set_use_range range use_rng' in - FStar_Pervasives_Native.Some uu___ in - let uu___ = FStar_Compiler_Util.map_opt rng maybe_bound_rng in - { - issue_msg = (i.issue_msg); - issue_level = (i.issue_level); - issue_range = uu___; - issue_number = (i.issue_number); - issue_ctx = (i.issue_ctx) - } -let (mk_default_handler : Prims.bool -> error_handler) = - fun print -> - let issues = FStar_Compiler_Util.mk_ref [] in - let err_count = FStar_Compiler_Util.mk_ref Prims.int_zero in - let add_one e = - if e.issue_level = EError - then - (let uu___1 = - let uu___2 = FStar_Compiler_Effect.op_Bang err_count in - Prims.int_one + uu___2 in - FStar_Compiler_Effect.op_Colon_Equals err_count uu___1) - else (); - (match e.issue_level with - | EInfo when print -> print_issue e - | uu___2 when print && (FStar_Compiler_Debug.any ()) -> print_issue e - | uu___2 -> - let uu___3 = - let uu___4 = FStar_Compiler_Effect.op_Bang issues in e :: uu___4 in - FStar_Compiler_Effect.op_Colon_Equals issues uu___3); - (let uu___3 = - (FStar_Options.defensive_abort ()) && - (e.issue_number = (FStar_Pervasives_Native.Some defensive_errno)) in - if uu___3 then failwith "Aborting due to --defensive abort" else ()) in - let count_errors uu___ = FStar_Compiler_Effect.op_Bang err_count in - let report uu___ = - let unique_issues = - let uu___1 = FStar_Compiler_Effect.op_Bang issues in - FStar_Compiler_Util.remove_dups (fun i0 -> fun i1 -> i0 = i1) uu___1 in - let sorted_unique_issues = - FStar_Compiler_List.sortWith compare_issues unique_issues in - if print - then FStar_Compiler_List.iter print_issue sorted_unique_issues - else (); - sorted_unique_issues in - let clear uu___ = - FStar_Compiler_Effect.op_Colon_Equals issues []; - FStar_Compiler_Effect.op_Colon_Equals err_count Prims.int_zero in - let uu___ = - let uu___1 = - let uu___2 = FStar_Compiler_Util.string_of_bool print in - Prims.strcat uu___2 ")" in - Prims.strcat "default handler (print=" uu___1 in - { - eh_name = uu___; - eh_add_one = add_one; - eh_count_errors = count_errors; - eh_report = report; - eh_clear = clear - } -let (default_handler : error_handler) = mk_default_handler true -let (current_handler : error_handler FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref default_handler -let (mk_issue : - issue_level -> - FStar_Compiler_Range_Type.range FStar_Pervasives_Native.option -> - FStar_Errors_Msg.error_message -> - Prims.int FStar_Pervasives_Native.option -> - Prims.string Prims.list -> issue) - = - fun level -> - fun range -> - fun msg -> - fun n -> - fun ctx -> - { - issue_msg = msg; - issue_level = level; - issue_range = range; - issue_number = n; - issue_ctx = ctx - } -let (get_err_count : unit -> Prims.int) = - fun uu___ -> - let uu___1 = FStar_Compiler_Effect.op_Bang current_handler in - uu___1.eh_count_errors () -let (wrapped_eh_add_one : error_handler -> issue -> unit) = - fun h -> - fun issue1 -> - let issue2 = fixup_issue_range issue1 in - h.eh_add_one issue2; - if issue2.issue_level <> EInfo - then - ((let uu___2 = - let uu___3 = - FStar_Compiler_Effect.op_Bang FStar_Options.abort_counter in - uu___3 - Prims.int_one in - FStar_Compiler_Effect.op_Colon_Equals FStar_Options.abort_counter - uu___2); - (let uu___2 = - let uu___3 = - FStar_Compiler_Effect.op_Bang FStar_Options.abort_counter in - uu___3 = Prims.int_zero in - if uu___2 then failwith "Aborting due to --abort_on" else ())) - else () -let (add_one : issue -> unit) = - fun issue1 -> - FStar_Compiler_Util.atomically - (fun uu___ -> - let uu___1 = FStar_Compiler_Effect.op_Bang current_handler in - wrapped_eh_add_one uu___1 issue1) -let (add_many : issue Prims.list -> unit) = - fun issues -> - FStar_Compiler_Util.atomically - (fun uu___ -> - let uu___1 = - let uu___2 = FStar_Compiler_Effect.op_Bang current_handler in - wrapped_eh_add_one uu___2 in - FStar_Compiler_List.iter uu___1 issues) -let (add_issues : issue Prims.list -> unit) = fun issues -> add_many issues -let (report_all : unit -> issue Prims.list) = - fun uu___ -> - let uu___1 = FStar_Compiler_Effect.op_Bang current_handler in - uu___1.eh_report () -let (clear : unit -> unit) = - fun uu___ -> - let uu___1 = FStar_Compiler_Effect.op_Bang current_handler in - uu___1.eh_clear () -let (set_handler : error_handler -> unit) = - fun handler -> - let issues = report_all () in - clear (); - FStar_Compiler_Effect.op_Colon_Equals current_handler handler; - add_many issues -type error_context_t = - { - push: Prims.string -> unit ; - pop: unit -> Prims.string ; - clear: unit -> unit ; - get: unit -> Prims.string Prims.list ; - set: Prims.string Prims.list -> unit } -let (__proj__Mkerror_context_t__item__push : - error_context_t -> Prims.string -> unit) = - fun projectee -> - match projectee with | { push; pop; clear = clear1; get; set;_} -> push -let (__proj__Mkerror_context_t__item__pop : - error_context_t -> unit -> Prims.string) = - fun projectee -> - match projectee with | { push; pop; clear = clear1; get; set;_} -> pop -let (__proj__Mkerror_context_t__item__clear : - error_context_t -> unit -> unit) = - fun projectee -> - match projectee with | { push; pop; clear = clear1; get; set;_} -> clear1 -let (__proj__Mkerror_context_t__item__get : - error_context_t -> unit -> Prims.string Prims.list) = - fun projectee -> - match projectee with | { push; pop; clear = clear1; get; set;_} -> get -let (__proj__Mkerror_context_t__item__set : - error_context_t -> Prims.string Prims.list -> unit) = - fun projectee -> - match projectee with | { push; pop; clear = clear1; get; set;_} -> set -let (error_context : error_context_t) = - let ctxs = FStar_Compiler_Util.mk_ref [] in - let push s = - let uu___ = - let uu___1 = FStar_Compiler_Effect.op_Bang ctxs in s :: uu___1 in - FStar_Compiler_Effect.op_Colon_Equals ctxs uu___ in - let pop s = - let uu___ = FStar_Compiler_Effect.op_Bang ctxs in - match uu___ with - | h::t -> (FStar_Compiler_Effect.op_Colon_Equals ctxs t; h) - | uu___1 -> failwith "cannot pop error prefix..." in - let clear1 uu___ = FStar_Compiler_Effect.op_Colon_Equals ctxs [] in - let get uu___ = FStar_Compiler_Effect.op_Bang ctxs in - let set c = FStar_Compiler_Effect.op_Colon_Equals ctxs c in - { push; pop; clear = clear1; get; set } -let (get_ctx : unit -> Prims.string Prims.list) = - fun uu___ -> error_context.get () -let (maybe_add_backtrace : - FStar_Errors_Msg.error_message -> FStar_Errors_Msg.error_message) = - fun msg -> - let uu___ = FStar_Options.trace_error () in - if uu___ - then - let uu___1 = let uu___2 = FStar_Errors_Msg.backtrace_doc () in [uu___2] in - FStar_Compiler_List.op_At msg uu___1 - else msg -let (warn_unsafe_options : - FStar_Compiler_Range_Type.range FStar_Pervasives_Native.option -> - Prims.string -> unit) - = - fun rng_opt -> - fun msg -> - let uu___ = FStar_Options.report_assumes () in - match uu___ with - | FStar_Pervasives_Native.Some "warn" -> - let uu___1 = - let uu___2 = - FStar_Errors_Msg.mkmsg - (Prims.strcat "Every use of this option triggers a warning: " - msg) in - mk_issue EWarning rng_opt uu___2 - (FStar_Pervasives_Native.Some warn_on_use_errno) [] in - add_one uu___1 - | FStar_Pervasives_Native.Some "error" -> - let uu___1 = - let uu___2 = - FStar_Errors_Msg.mkmsg - (Prims.strcat "Every use of this option triggers an error: " - msg) in - mk_issue EError rng_opt uu___2 - (FStar_Pervasives_Native.Some warn_on_use_errno) [] in - add_one uu___1 - | uu___1 -> () -let (set_option_warning_callback_range : - FStar_Compiler_Range_Type.range FStar_Pervasives_Native.option -> unit) = - fun ropt -> - FStar_Options.set_option_warning_callback (warn_unsafe_options ropt) -let (uu___0 : - (((Prims.string -> FStar_Errors_Codes.error_setting Prims.list) -> unit) * - (unit -> FStar_Errors_Codes.error_setting Prims.list))) - = - let parser_callback = - FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None in - let error_flags = FStar_Compiler_Util.smap_create (Prims.of_int (10)) in - let set_error_flags uu___ = - let parse s = - let uu___1 = FStar_Compiler_Effect.op_Bang parser_callback in - match uu___1 with - | FStar_Pervasives_Native.None -> - failwith "Callback for parsing warn_error strings is not set" - | FStar_Pervasives_Native.Some f -> f s in - let we = FStar_Options.warn_error () in - try - (fun uu___1 -> - match () with - | () -> - let r = parse we in - (FStar_Compiler_Util.smap_add error_flags we - (FStar_Pervasives_Native.Some r); - FStar_Getopt.Success)) () - with - | Invalid_warn_error_setting msg -> - (FStar_Compiler_Util.smap_add error_flags we - FStar_Pervasives_Native.None; - FStar_Getopt.Error - (Prims.strcat "Invalid --warn_error setting: " - (Prims.strcat msg "\n"))) in - let get_error_flags uu___ = - let we = FStar_Options.warn_error () in - let uu___1 = FStar_Compiler_Util.smap_try_find error_flags we in - match uu___1 with - | FStar_Pervasives_Native.Some (FStar_Pervasives_Native.Some w) -> w - | uu___2 -> FStar_Errors_Codes.default_settings in - let set_callbacks f = - FStar_Compiler_Effect.op_Colon_Equals parser_callback - (FStar_Pervasives_Native.Some f); - FStar_Options.set_error_flags_callback set_error_flags; - FStar_Options.set_option_warning_callback - (warn_unsafe_options FStar_Pervasives_Native.None) in - (set_callbacks, get_error_flags) -let (t_set_parse_warn_error : - (Prims.string -> FStar_Errors_Codes.error_setting Prims.list) -> unit) = - match uu___0 with - | (t_set_parse_warn_error1, error_flags) -> t_set_parse_warn_error1 -let (error_flags : unit -> FStar_Errors_Codes.error_setting Prims.list) = - match uu___0 with | (t_set_parse_warn_error1, error_flags1) -> error_flags1 -let (set_parse_warn_error : - (Prims.string -> FStar_Errors_Codes.error_setting Prims.list) -> unit) = - t_set_parse_warn_error -let (lookup : - FStar_Errors_Codes.error_code -> FStar_Errors_Codes.error_setting) = - fun err -> - let flags = error_flags () in - let uu___ = lookup_error flags err in - match uu___ with - | (v, level, i) -> - let with_level level1 = (v, level1, i) in - (match v with - | FStar_Errors_Codes.Warning_Defensive when - (FStar_Options.defensive_error ()) || - (FStar_Options.defensive_abort ()) - -> with_level FStar_Errors_Codes.CAlwaysError - | FStar_Errors_Codes.Warning_WarnOnUse -> - let level' = - let uu___1 = FStar_Options.report_assumes () in - match uu___1 with - | FStar_Pervasives_Native.None -> level - | FStar_Pervasives_Native.Some "warn" -> - (match level with - | FStar_Errors_Codes.CSilent -> - FStar_Errors_Codes.CWarning - | uu___2 -> level) - | FStar_Pervasives_Native.Some "error" -> - (match level with - | FStar_Errors_Codes.CWarning -> - FStar_Errors_Codes.CError - | FStar_Errors_Codes.CSilent -> FStar_Errors_Codes.CError - | uu___2 -> level) - | FStar_Pervasives_Native.Some uu___2 -> level in - with_level level' - | uu___1 -> with_level level) -let (log_issue_ctx : - FStar_Compiler_Range_Type.range -> - (FStar_Errors_Codes.error_code * FStar_Errors_Msg.error_message) -> - Prims.string Prims.list -> unit) - = - fun r -> - fun uu___ -> - fun ctx -> - match uu___ with - | (e, msg) -> - let msg1 = maybe_add_backtrace msg in - let uu___1 = lookup e in - (match uu___1 with - | (uu___2, FStar_Errors_Codes.CAlwaysError, errno1) -> - add_one - (mk_issue EError (FStar_Pervasives_Native.Some r) msg1 - (FStar_Pervasives_Native.Some errno1) ctx) - | (uu___2, FStar_Errors_Codes.CError, errno1) -> - add_one - (mk_issue EError (FStar_Pervasives_Native.Some r) msg1 - (FStar_Pervasives_Native.Some errno1) ctx) - | (uu___2, FStar_Errors_Codes.CWarning, errno1) -> - add_one - (mk_issue EWarning (FStar_Pervasives_Native.Some r) msg1 - (FStar_Pervasives_Native.Some errno1) ctx) - | (uu___2, FStar_Errors_Codes.CSilent, uu___3) -> () - | (uu___2, FStar_Errors_Codes.CFatal, errno1) -> - let i = - mk_issue EError (FStar_Pervasives_Native.Some r) msg1 - (FStar_Pervasives_Native.Some errno1) ctx in - let uu___3 = FStar_Options.ide () in - if uu___3 - then add_one i - else - (let uu___5 = - let uu___6 = format_issue i in - Prims.strcat - "don't use log_issue to report fatal error, should use raise_error: " - uu___6 in - failwith uu___5)) -let info : - 'posut . - 'posut FStar_Class_HasRange.hasRange -> - 'posut -> - unit -> Obj.t FStar_Errors_Msg.is_error_message -> Obj.t -> unit - = - fun uu___ -> - fun r -> - fun uu___1 -> - fun uu___2 -> - fun msg -> - let rng = FStar_Class_HasRange.pos uu___ r in - let msg1 = FStar_Errors_Msg.to_doc_list uu___2 msg in - let msg2 = maybe_add_backtrace msg1 in - let ctx = get_ctx () in - add_one - (mk_issue EInfo (FStar_Pervasives_Native.Some rng) msg2 - FStar_Pervasives_Native.None ctx) -let diag : - 'posut . - 'posut FStar_Class_HasRange.hasRange -> - 'posut -> - unit -> Obj.t FStar_Errors_Msg.is_error_message -> Obj.t -> unit - = - fun uu___ -> - fun r -> - fun uu___1 -> - fun uu___2 -> - fun msg -> - let uu___3 = FStar_Compiler_Debug.any () in - if uu___3 then info uu___ r () uu___2 msg else () -let raise_error : - 'a 'posut . - 'posut FStar_Class_HasRange.hasRange -> - 'posut -> - FStar_Errors_Codes.error_code -> - unit -> Obj.t FStar_Errors_Msg.is_error_message -> Obj.t -> 'a - = - fun uu___ -> - fun r -> - fun e -> - fun uu___1 -> - fun uu___2 -> - fun msg -> - let rng = FStar_Class_HasRange.pos uu___ r in - let msg1 = FStar_Errors_Msg.to_doc_list uu___2 msg in - let uu___3 = - let uu___4 = - let uu___5 = maybe_add_backtrace msg1 in - let uu___6 = error_context.get () in - (e, uu___5, rng, uu___6) in - Error uu___4 in - FStar_Compiler_Effect.raise uu___3 -let log_issue : - 'posut . - 'posut FStar_Class_HasRange.hasRange -> - 'posut -> - FStar_Errors_Codes.error_code -> - unit -> Obj.t FStar_Errors_Msg.is_error_message -> Obj.t -> unit - = - fun uu___ -> - fun r -> - fun e -> - fun uu___1 -> - fun uu___2 -> - fun msg -> - let rng = FStar_Class_HasRange.pos uu___ r in - let msg1 = FStar_Errors_Msg.to_doc_list uu___2 msg in - let ctx = error_context.get () in - log_issue_ctx rng (e, msg1) ctx -let raise_error0 : - 'a . - FStar_Errors_Codes.error_code -> - unit -> Obj.t FStar_Errors_Msg.is_error_message -> Obj.t -> 'a - = - fun e -> - fun uu___ -> - fun uu___1 -> - fun msg -> - raise_error FStar_Class_HasRange.hasRange_range - FStar_Compiler_Range_Type.dummyRange e () uu___1 msg -let (log_issue0 : - FStar_Errors_Codes.error_code -> - unit -> Obj.t FStar_Errors_Msg.is_error_message -> Obj.t -> unit) - = - fun e -> - fun uu___ -> - fun uu___1 -> - fun msg -> - log_issue FStar_Class_HasRange.hasRange_range - FStar_Compiler_Range_Type.dummyRange e () uu___1 msg -let diag0 : 't . 't FStar_Errors_Msg.is_error_message -> 't -> unit = - fun uu___ -> - fun msg -> - diag FStar_Class_HasRange.hasRange_range - FStar_Compiler_Range_Type.dummyRange () (Obj.magic uu___) - (Obj.magic msg) -let (add_errors : error Prims.list -> unit) = - fun errs -> - FStar_Compiler_Util.atomically - (fun uu___ -> - FStar_Compiler_List.iter - (fun uu___1 -> - match uu___1 with - | (e, msg, r, ctx) -> log_issue_ctx r (e, msg) ctx) errs) -let (issue_of_exn : Prims.exn -> issue FStar_Pervasives_Native.option) = - fun e -> - match e with - | Error (e1, msg, r, ctx) -> - let errno1 = let uu___ = lookup e1 in error_number uu___ in - FStar_Pervasives_Native.Some - (mk_issue EError (FStar_Pervasives_Native.Some r) msg - (FStar_Pervasives_Native.Some errno1) ctx) - | uu___ -> FStar_Pervasives_Native.None -let (err_exn : Prims.exn -> unit) = - fun exn -> - if exn = Stop - then () - else - (let uu___1 = issue_of_exn exn in - match uu___1 with - | FStar_Pervasives_Native.Some issue1 -> add_one issue1 - | FStar_Pervasives_Native.None -> FStar_Compiler_Effect.raise exn) -let (handleable : Prims.exn -> Prims.bool) = - fun uu___ -> - match uu___ with | Error uu___1 -> true | Stop -> true | uu___1 -> false -let (stop_if_err : unit -> unit) = - fun uu___ -> - let uu___1 = let uu___2 = get_err_count () in uu___2 > Prims.int_zero in - if uu___1 then FStar_Compiler_Effect.raise Stop else () -let with_ctx : 'a . Prims.string -> (unit -> 'a) -> 'a = - fun s -> - fun f -> - error_context.push s; - (let r = - let uu___1 = FStar_Options.trace_error () in - if uu___1 - then let uu___2 = f () in FStar_Pervasives.Inr uu___2 - else - (try - (fun uu___3 -> - match () with - | () -> let uu___4 = f () in FStar_Pervasives.Inr uu___4) () - with - | FStar_Compiler_Effect.Failure msg -> - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = error_context.get () in ctx_doc uu___9 in - [uu___8] in - FStar_Errors_Msg.rendermsg uu___7 in - Prims.strcat msg uu___6 in - FStar_Compiler_Effect.Failure uu___5 in - FStar_Pervasives.Inl uu___4 - | ex -> FStar_Pervasives.Inl ex) in - (let uu___2 = error_context.pop () in ()); - (match r with - | FStar_Pervasives.Inr r1 -> r1 - | FStar_Pervasives.Inl e -> FStar_Compiler_Effect.raise e)) -let with_ctx_if : 'a . Prims.bool -> Prims.string -> (unit -> 'a) -> 'a = - fun b -> fun s -> fun f -> if b then with_ctx s f else f () -let catch_errors_aux : - 'a . - (unit -> 'a) -> - (issue Prims.list * issue Prims.list * 'a - FStar_Pervasives_Native.option) - = - fun f -> - let newh = mk_default_handler false in - let old = FStar_Compiler_Effect.op_Bang current_handler in - FStar_Compiler_Effect.op_Colon_Equals current_handler newh; - (let finally_restore uu___1 = - let all_issues = newh.eh_report () in - FStar_Compiler_Effect.op_Colon_Equals current_handler old; - (let uu___3 = - FStar_Compiler_List.partition (fun i -> i.issue_level = EError) - all_issues in - match uu___3 with | (errs, rest) -> (errs, rest)) in - let r = - try - (fun uu___1 -> - match () with - | () -> let uu___2 = f () in FStar_Pervasives_Native.Some uu___2) - () - with - | uu___1 -> - if handleable uu___1 - then (err_exn uu___1; FStar_Pervasives_Native.None) - else - (let uu___2 = finally_restore () in - FStar_Compiler_Effect.raise uu___1) in - let uu___1 = finally_restore () in - match uu___1 with | (errs, rest) -> (errs, rest, r)) -let no_ctx : 'a . (unit -> 'a) -> 'a = - fun f -> - let save = error_context.get () in - error_context.clear (); (let res = f () in error_context.set save; res) -let catch_errors : - 'a . (unit -> 'a) -> (issue Prims.list * 'a FStar_Pervasives_Native.option) - = - fun f -> - let uu___ = catch_errors_aux f in - match uu___ with - | (errs, rest, r) -> - ((let uu___2 = - let uu___3 = FStar_Compiler_Effect.op_Bang current_handler in - uu___3.eh_add_one in - FStar_Compiler_List.iter uu___2 rest); - (errs, r)) -let catch_errors_and_ignore_rest : - 'a . (unit -> 'a) -> (issue Prims.list * 'a FStar_Pervasives_Native.option) - = - fun f -> - let uu___ = catch_errors_aux f in - match uu___ with - | (errs, rest, r) -> - ((let uu___2 = - let uu___3 = FStar_Compiler_Effect.op_Bang current_handler in - uu___3.eh_add_one in - let uu___3 = - FStar_Compiler_List.filter (fun i -> i.issue_level = EInfo) rest in - FStar_Compiler_List.iter uu___2 uu___3); - (errs, r)) -let (find_multiset_discrepancy : - Prims.int Prims.list -> - Prims.int Prims.list -> - (Prims.int * Prims.int * Prims.int) FStar_Pervasives_Native.option) - = - fun l1 -> - fun l2 -> - let sort = FStar_Compiler_List.sortWith (fun x -> fun y -> x - y) in - let rec collect l = - match l with - | [] -> [] - | hd::tl -> - let uu___ = collect tl in - (match uu___ with - | [] -> [(hd, Prims.int_one)] - | (h, n)::t -> - if h = hd - then (h, (n + Prims.int_one)) :: t - else (hd, Prims.int_one) :: (h, n) :: t) in - let l11 = let uu___ = sort l1 in collect uu___ in - let l21 = let uu___ = sort l2 in collect uu___ in - let rec aux l12 l22 = - match (l12, l22) with - | ([], []) -> FStar_Pervasives_Native.None - | ((e, n)::uu___, []) -> - FStar_Pervasives_Native.Some (e, n, Prims.int_zero) - | ([], (e, n)::uu___) -> - FStar_Pervasives_Native.Some (e, Prims.int_zero, n) - | ((hd1, n1)::tl1, (hd2, n2)::tl2) -> - if hd1 < hd2 - then FStar_Pervasives_Native.Some (hd1, n1, Prims.int_zero) - else - if hd1 > hd2 - then FStar_Pervasives_Native.Some (hd2, Prims.int_zero, n2) - else - if n1 <> n2 - then FStar_Pervasives_Native.Some (hd1, n1, n2) - else aux tl1 tl2 in - aux l11 l21 -let raise_error_doc : - 'a . - FStar_Compiler_Range_Type.range -> - FStar_Errors_Codes.error_code -> FStar_Errors_Msg.error_message -> 'a - = - fun rng -> - fun code -> - fun msg -> - raise_error FStar_Class_HasRange.hasRange_range rng code () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic msg) -let (log_issue_doc : - FStar_Compiler_Range_Type.range -> - FStar_Errors_Codes.error_code -> FStar_Errors_Msg.error_message -> unit) - = - fun rng -> - fun code -> - fun msg -> - log_issue FStar_Class_HasRange.hasRange_range rng code () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic msg) -let raise_error_text : - 'a . - FStar_Compiler_Range_Type.range -> - FStar_Errors_Codes.error_code -> Prims.string -> 'a - = - fun rng -> - fun code -> - fun msg -> - raise_error FStar_Class_HasRange.hasRange_range rng code () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic msg) -let (log_issue_text : - FStar_Compiler_Range_Type.range -> - FStar_Errors_Codes.error_code -> Prims.string -> unit) - = - fun rng -> - fun code -> - fun msg -> - log_issue FStar_Class_HasRange.hasRange_range rng code () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic msg) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Errors_Msg.ml b/ocaml/fstar-lib/generated/FStar_Errors_Msg.ml deleted file mode 100644 index a51739e963c..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Errors_Msg.ml +++ /dev/null @@ -1,102 +0,0 @@ -open Prims -type error_message = FStar_Pprint.document Prims.list -type 't is_error_message = { - to_doc_list: 't -> error_message } -let __proj__Mkis_error_message__item__to_doc_list : - 't . 't is_error_message -> 't -> error_message = - fun projectee -> match projectee with | { to_doc_list;_} -> to_doc_list -let to_doc_list : 't . 't is_error_message -> 't -> error_message = - fun projectee -> - match projectee with | { to_doc_list = to_doc_list1;_} -> to_doc_list1 -let (is_error_message_string : Prims.string is_error_message) = - { - to_doc_list = - (fun s -> let uu___ = FStar_Pprint.arbitrary_string s in [uu___]) - } -let (is_error_message_list_doc : - FStar_Pprint.document Prims.list is_error_message) = - { to_doc_list = (fun x -> x) } -let (vconcat : FStar_Pprint.document Prims.list -> FStar_Pprint.document) = - fun ds -> - match ds with - | h::t -> - FStar_Compiler_List.fold_left - (fun l -> - fun r -> - let uu___ = FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline r in - FStar_Pprint.op_Hat_Hat l uu___) h t - | [] -> FStar_Pprint.empty -let (text : Prims.string -> FStar_Pprint.document) = - fun s -> - let uu___ = FStar_Pprint.break_ Prims.int_one in - let uu___1 = FStar_Pprint.words s in FStar_Pprint.flow uu___ uu___1 -let (sublist : - FStar_Pprint.document -> - FStar_Pprint.document Prims.list -> FStar_Pprint.document) - = - fun h -> - fun ds -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Compiler_List.map (fun d -> FStar_Pprint.op_Hat_Hat h d) - ds in - vconcat uu___3 in - FStar_Pprint.align uu___2 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline uu___1 in - FStar_Pprint.nest (Prims.of_int (2)) uu___ -let (bulleted : FStar_Pprint.document Prims.list -> FStar_Pprint.document) = - fun ds -> let uu___ = FStar_Pprint.doc_of_string "- " in sublist uu___ ds -let (mkmsg : Prims.string -> error_message) = - fun s -> let uu___ = FStar_Pprint.arbitrary_string s in [uu___] -let (renderdoc : FStar_Pprint.document -> Prims.string) = - fun d -> - let one = FStar_Compiler_Util.float_of_string "1.0" in - FStar_Pprint.pretty_string one (Prims.of_int (80)) d -let (backtrace_doc : unit -> FStar_Pprint.document) = - fun uu___ -> - let s = FStar_Compiler_Util.stack_dump () in - let uu___1 = text "Stack trace:" in - let uu___2 = - FStar_Pprint.arbitrary_string (FStar_Compiler_Util.trim_string s) in - FStar_Pprint.op_Hat_Slash_Hat uu___1 uu___2 -let (subdoc' : Prims.bool -> FStar_Pprint.document -> FStar_Pprint.document) - = - fun indent -> - fun d -> - if d = FStar_Pprint.empty - then FStar_Pprint.empty - else - (let uu___1 = - if indent - then FStar_Pprint.blank (Prims.of_int (2)) - else FStar_Pprint.empty in - let uu___2 = - let uu___3 = FStar_Pprint.doc_of_string "-" in - let uu___4 = - let uu___5 = FStar_Pprint.blank Prims.int_one in - let uu___6 = - let uu___7 = FStar_Pprint.align d in - FStar_Pprint.op_Hat_Hat uu___7 FStar_Pprint.hardline in - FStar_Pprint.op_Hat_Hat uu___5 uu___6 in - FStar_Pprint.op_Hat_Hat uu___3 uu___4 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2) -let (subdoc : FStar_Pprint.document -> FStar_Pprint.document) = - fun d -> subdoc' true d -let (rendermsg : error_message -> Prims.string) = - fun ds -> - let uu___ = - let uu___1 = - FStar_Compiler_List.map - (fun d -> let uu___2 = FStar_Pprint.group d in subdoc uu___2) ds in - FStar_Pprint.concat uu___1 in - renderdoc uu___ -let (json_of_error_message : - FStar_Pprint.document Prims.list -> FStar_Json.json) = - fun err_msg -> - let uu___ = - FStar_Compiler_List.map - (fun doc -> let uu___1 = renderdoc doc in FStar_Json.JsonStr uu___1) - err_msg in - FStar_Json.JsonList uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Extraction_Krml.ml b/ocaml/fstar-lib/generated/FStar_Extraction_Krml.ml deleted file mode 100644 index 7a1a2b8a81a..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Extraction_Krml.ml +++ /dev/null @@ -1,4002 +0,0 @@ -open Prims -type version = Prims.int -let (current_version : version) = (Prims.of_int (31)) -type decl = - | DGlobal of (flag Prims.list * (Prims.string Prims.list * Prims.string) * - Prims.int * typ * expr) - | DFunction of (cc FStar_Pervasives_Native.option * flag Prims.list * - Prims.int * typ * (Prims.string Prims.list * Prims.string) * binder - Prims.list * expr) - | DTypeAlias of ((Prims.string Prims.list * Prims.string) * flag Prims.list - * Prims.int * typ) - | DTypeFlat of ((Prims.string Prims.list * Prims.string) * flag Prims.list - * Prims.int * (Prims.string * (typ * Prims.bool)) Prims.list) - | DUnusedRetainedForBackwardsCompat of (cc FStar_Pervasives_Native.option * - flag Prims.list * (Prims.string Prims.list * Prims.string) * typ) - | DTypeVariant of ((Prims.string Prims.list * Prims.string) * flag - Prims.list * Prims.int * (Prims.string * (Prims.string * (typ * - Prims.bool)) Prims.list) Prims.list) - | DTypeAbstractStruct of (Prims.string Prims.list * Prims.string) - | DExternal of (cc FStar_Pervasives_Native.option * flag Prims.list * - (Prims.string Prims.list * Prims.string) * typ * Prims.string Prims.list) - | DUntaggedUnion of ((Prims.string Prims.list * Prims.string) * flag - Prims.list * Prims.int * (Prims.string * typ) Prims.list) -and cc = - | StdCall - | CDecl - | FastCall -and flag = - | Private - | WipeBody - | CInline - | Substitute - | GCType - | Comment of Prims.string - | MustDisappear - | Const of Prims.string - | Prologue of Prims.string - | Epilogue of Prims.string - | Abstract - | IfDef - | Macro - | Deprecated of Prims.string - | CNoInline -and lifetime = - | Eternal - | Stack - | ManuallyManaged -and expr = - | EBound of Prims.int - | EQualified of (Prims.string Prims.list * Prims.string) - | EConstant of (width * Prims.string) - | EUnit - | EApp of (expr * expr Prims.list) - | ETypApp of (expr * typ Prims.list) - | ELet of (binder * expr * expr) - | EIfThenElse of (expr * expr * expr) - | ESequence of expr Prims.list - | EAssign of (expr * expr) - | EBufCreate of (lifetime * expr * expr) - | EBufRead of (expr * expr) - | EBufWrite of (expr * expr * expr) - | EBufSub of (expr * expr) - | EBufBlit of (expr * expr * expr * expr * expr) - | EMatch of (expr * (pattern * expr) Prims.list) - | EOp of (op * width) - | ECast of (expr * typ) - | EPushFrame - | EPopFrame - | EBool of Prims.bool - | EAny - | EAbort - | EReturn of expr - | EFlat of (typ * (Prims.string * expr) Prims.list) - | EField of (typ * expr * Prims.string) - | EWhile of (expr * expr) - | EBufCreateL of (lifetime * expr Prims.list) - | ETuple of expr Prims.list - | ECons of (typ * Prims.string * expr Prims.list) - | EBufFill of (expr * expr * expr) - | EString of Prims.string - | EFun of (binder Prims.list * expr * typ) - | EAbortS of Prims.string - | EBufFree of expr - | EBufCreateNoInit of (lifetime * expr) - | EAbortT of (Prims.string * typ) - | EComment of (Prims.string * expr * Prims.string) - | EStandaloneComment of Prims.string - | EAddrOf of expr - | EBufNull of typ - | EBufDiff of (expr * expr) -and op = - | Add - | AddW - | Sub - | SubW - | Div - | DivW - | Mult - | MultW - | Mod - | BOr - | BAnd - | BXor - | BShiftL - | BShiftR - | BNot - | Eq - | Neq - | Lt - | Lte - | Gt - | Gte - | And - | Or - | Xor - | Not -and pattern = - | PUnit - | PBool of Prims.bool - | PVar of binder - | PCons of (Prims.string * pattern Prims.list) - | PTuple of pattern Prims.list - | PRecord of (Prims.string * pattern) Prims.list - | PConstant of (width * Prims.string) -and width = - | UInt8 - | UInt16 - | UInt32 - | UInt64 - | Int8 - | Int16 - | Int32 - | Int64 - | Bool - | CInt - | SizeT - | PtrdiffT -and binder = - { - name: Prims.string ; - typ: typ ; - mut: Prims.bool ; - meta: flag Prims.list } -and typ = - | TInt of width - | TBuf of typ - | TUnit - | TQualified of (Prims.string Prims.list * Prims.string) - | TBool - | TAny - | TArrow of (typ * typ) - | TBound of Prims.int - | TApp of ((Prims.string Prims.list * Prims.string) * typ Prims.list) - | TTuple of typ Prims.list - | TConstBuf of typ - | TArray of (typ * (width * Prims.string)) -let (uu___is_DGlobal : decl -> Prims.bool) = - fun projectee -> match projectee with | DGlobal _0 -> true | uu___ -> false -let (__proj__DGlobal__item___0 : - decl -> - (flag Prims.list * (Prims.string Prims.list * Prims.string) * Prims.int * - typ * expr)) - = fun projectee -> match projectee with | DGlobal _0 -> _0 -let (uu___is_DFunction : decl -> Prims.bool) = - fun projectee -> - match projectee with | DFunction _0 -> true | uu___ -> false -let (__proj__DFunction__item___0 : - decl -> - (cc FStar_Pervasives_Native.option * flag Prims.list * Prims.int * typ * - (Prims.string Prims.list * Prims.string) * binder Prims.list * expr)) - = fun projectee -> match projectee with | DFunction _0 -> _0 -let (uu___is_DTypeAlias : decl -> Prims.bool) = - fun projectee -> - match projectee with | DTypeAlias _0 -> true | uu___ -> false -let (__proj__DTypeAlias__item___0 : - decl -> - ((Prims.string Prims.list * Prims.string) * flag Prims.list * Prims.int * - typ)) - = fun projectee -> match projectee with | DTypeAlias _0 -> _0 -let (uu___is_DTypeFlat : decl -> Prims.bool) = - fun projectee -> - match projectee with | DTypeFlat _0 -> true | uu___ -> false -let (__proj__DTypeFlat__item___0 : - decl -> - ((Prims.string Prims.list * Prims.string) * flag Prims.list * Prims.int * - (Prims.string * (typ * Prims.bool)) Prims.list)) - = fun projectee -> match projectee with | DTypeFlat _0 -> _0 -let (uu___is_DUnusedRetainedForBackwardsCompat : decl -> Prims.bool) = - fun projectee -> - match projectee with - | DUnusedRetainedForBackwardsCompat _0 -> true - | uu___ -> false -let (__proj__DUnusedRetainedForBackwardsCompat__item___0 : - decl -> - (cc FStar_Pervasives_Native.option * flag Prims.list * (Prims.string - Prims.list * Prims.string) * typ)) - = - fun projectee -> - match projectee with | DUnusedRetainedForBackwardsCompat _0 -> _0 -let (uu___is_DTypeVariant : decl -> Prims.bool) = - fun projectee -> - match projectee with | DTypeVariant _0 -> true | uu___ -> false -let (__proj__DTypeVariant__item___0 : - decl -> - ((Prims.string Prims.list * Prims.string) * flag Prims.list * Prims.int * - (Prims.string * (Prims.string * (typ * Prims.bool)) Prims.list) - Prims.list)) - = fun projectee -> match projectee with | DTypeVariant _0 -> _0 -let (uu___is_DTypeAbstractStruct : decl -> Prims.bool) = - fun projectee -> - match projectee with | DTypeAbstractStruct _0 -> true | uu___ -> false -let (__proj__DTypeAbstractStruct__item___0 : - decl -> (Prims.string Prims.list * Prims.string)) = - fun projectee -> match projectee with | DTypeAbstractStruct _0 -> _0 -let (uu___is_DExternal : decl -> Prims.bool) = - fun projectee -> - match projectee with | DExternal _0 -> true | uu___ -> false -let (__proj__DExternal__item___0 : - decl -> - (cc FStar_Pervasives_Native.option * flag Prims.list * (Prims.string - Prims.list * Prims.string) * typ * Prims.string Prims.list)) - = fun projectee -> match projectee with | DExternal _0 -> _0 -let (uu___is_DUntaggedUnion : decl -> Prims.bool) = - fun projectee -> - match projectee with | DUntaggedUnion _0 -> true | uu___ -> false -let (__proj__DUntaggedUnion__item___0 : - decl -> - ((Prims.string Prims.list * Prims.string) * flag Prims.list * Prims.int * - (Prims.string * typ) Prims.list)) - = fun projectee -> match projectee with | DUntaggedUnion _0 -> _0 -let (uu___is_StdCall : cc -> Prims.bool) = - fun projectee -> match projectee with | StdCall -> true | uu___ -> false -let (uu___is_CDecl : cc -> Prims.bool) = - fun projectee -> match projectee with | CDecl -> true | uu___ -> false -let (uu___is_FastCall : cc -> Prims.bool) = - fun projectee -> match projectee with | FastCall -> true | uu___ -> false -let (uu___is_Private : flag -> Prims.bool) = - fun projectee -> match projectee with | Private -> true | uu___ -> false -let (uu___is_WipeBody : flag -> Prims.bool) = - fun projectee -> match projectee with | WipeBody -> true | uu___ -> false -let (uu___is_CInline : flag -> Prims.bool) = - fun projectee -> match projectee with | CInline -> true | uu___ -> false -let (uu___is_Substitute : flag -> Prims.bool) = - fun projectee -> match projectee with | Substitute -> true | uu___ -> false -let (uu___is_GCType : flag -> Prims.bool) = - fun projectee -> match projectee with | GCType -> true | uu___ -> false -let (uu___is_Comment : flag -> Prims.bool) = - fun projectee -> match projectee with | Comment _0 -> true | uu___ -> false -let (__proj__Comment__item___0 : flag -> Prims.string) = - fun projectee -> match projectee with | Comment _0 -> _0 -let (uu___is_MustDisappear : flag -> Prims.bool) = - fun projectee -> - match projectee with | MustDisappear -> true | uu___ -> false -let (uu___is_Const : flag -> Prims.bool) = - fun projectee -> match projectee with | Const _0 -> true | uu___ -> false -let (__proj__Const__item___0 : flag -> Prims.string) = - fun projectee -> match projectee with | Const _0 -> _0 -let (uu___is_Prologue : flag -> Prims.bool) = - fun projectee -> - match projectee with | Prologue _0 -> true | uu___ -> false -let (__proj__Prologue__item___0 : flag -> Prims.string) = - fun projectee -> match projectee with | Prologue _0 -> _0 -let (uu___is_Epilogue : flag -> Prims.bool) = - fun projectee -> - match projectee with | Epilogue _0 -> true | uu___ -> false -let (__proj__Epilogue__item___0 : flag -> Prims.string) = - fun projectee -> match projectee with | Epilogue _0 -> _0 -let (uu___is_Abstract : flag -> Prims.bool) = - fun projectee -> match projectee with | Abstract -> true | uu___ -> false -let (uu___is_IfDef : flag -> Prims.bool) = - fun projectee -> match projectee with | IfDef -> true | uu___ -> false -let (uu___is_Macro : flag -> Prims.bool) = - fun projectee -> match projectee with | Macro -> true | uu___ -> false -let (uu___is_Deprecated : flag -> Prims.bool) = - fun projectee -> - match projectee with | Deprecated _0 -> true | uu___ -> false -let (__proj__Deprecated__item___0 : flag -> Prims.string) = - fun projectee -> match projectee with | Deprecated _0 -> _0 -let (uu___is_CNoInline : flag -> Prims.bool) = - fun projectee -> match projectee with | CNoInline -> true | uu___ -> false -let (uu___is_Eternal : lifetime -> Prims.bool) = - fun projectee -> match projectee with | Eternal -> true | uu___ -> false -let (uu___is_Stack : lifetime -> Prims.bool) = - fun projectee -> match projectee with | Stack -> true | uu___ -> false -let (uu___is_ManuallyManaged : lifetime -> Prims.bool) = - fun projectee -> - match projectee with | ManuallyManaged -> true | uu___ -> false -let (uu___is_EBound : expr -> Prims.bool) = - fun projectee -> match projectee with | EBound _0 -> true | uu___ -> false -let (__proj__EBound__item___0 : expr -> Prims.int) = - fun projectee -> match projectee with | EBound _0 -> _0 -let (uu___is_EQualified : expr -> Prims.bool) = - fun projectee -> - match projectee with | EQualified _0 -> true | uu___ -> false -let (__proj__EQualified__item___0 : - expr -> (Prims.string Prims.list * Prims.string)) = - fun projectee -> match projectee with | EQualified _0 -> _0 -let (uu___is_EConstant : expr -> Prims.bool) = - fun projectee -> - match projectee with | EConstant _0 -> true | uu___ -> false -let (__proj__EConstant__item___0 : expr -> (width * Prims.string)) = - fun projectee -> match projectee with | EConstant _0 -> _0 -let (uu___is_EUnit : expr -> Prims.bool) = - fun projectee -> match projectee with | EUnit -> true | uu___ -> false -let (uu___is_EApp : expr -> Prims.bool) = - fun projectee -> match projectee with | EApp _0 -> true | uu___ -> false -let (__proj__EApp__item___0 : expr -> (expr * expr Prims.list)) = - fun projectee -> match projectee with | EApp _0 -> _0 -let (uu___is_ETypApp : expr -> Prims.bool) = - fun projectee -> match projectee with | ETypApp _0 -> true | uu___ -> false -let (__proj__ETypApp__item___0 : expr -> (expr * typ Prims.list)) = - fun projectee -> match projectee with | ETypApp _0 -> _0 -let (uu___is_ELet : expr -> Prims.bool) = - fun projectee -> match projectee with | ELet _0 -> true | uu___ -> false -let (__proj__ELet__item___0 : expr -> (binder * expr * expr)) = - fun projectee -> match projectee with | ELet _0 -> _0 -let (uu___is_EIfThenElse : expr -> Prims.bool) = - fun projectee -> - match projectee with | EIfThenElse _0 -> true | uu___ -> false -let (__proj__EIfThenElse__item___0 : expr -> (expr * expr * expr)) = - fun projectee -> match projectee with | EIfThenElse _0 -> _0 -let (uu___is_ESequence : expr -> Prims.bool) = - fun projectee -> - match projectee with | ESequence _0 -> true | uu___ -> false -let (__proj__ESequence__item___0 : expr -> expr Prims.list) = - fun projectee -> match projectee with | ESequence _0 -> _0 -let (uu___is_EAssign : expr -> Prims.bool) = - fun projectee -> match projectee with | EAssign _0 -> true | uu___ -> false -let (__proj__EAssign__item___0 : expr -> (expr * expr)) = - fun projectee -> match projectee with | EAssign _0 -> _0 -let (uu___is_EBufCreate : expr -> Prims.bool) = - fun projectee -> - match projectee with | EBufCreate _0 -> true | uu___ -> false -let (__proj__EBufCreate__item___0 : expr -> (lifetime * expr * expr)) = - fun projectee -> match projectee with | EBufCreate _0 -> _0 -let (uu___is_EBufRead : expr -> Prims.bool) = - fun projectee -> - match projectee with | EBufRead _0 -> true | uu___ -> false -let (__proj__EBufRead__item___0 : expr -> (expr * expr)) = - fun projectee -> match projectee with | EBufRead _0 -> _0 -let (uu___is_EBufWrite : expr -> Prims.bool) = - fun projectee -> - match projectee with | EBufWrite _0 -> true | uu___ -> false -let (__proj__EBufWrite__item___0 : expr -> (expr * expr * expr)) = - fun projectee -> match projectee with | EBufWrite _0 -> _0 -let (uu___is_EBufSub : expr -> Prims.bool) = - fun projectee -> match projectee with | EBufSub _0 -> true | uu___ -> false -let (__proj__EBufSub__item___0 : expr -> (expr * expr)) = - fun projectee -> match projectee with | EBufSub _0 -> _0 -let (uu___is_EBufBlit : expr -> Prims.bool) = - fun projectee -> - match projectee with | EBufBlit _0 -> true | uu___ -> false -let (__proj__EBufBlit__item___0 : expr -> (expr * expr * expr * expr * expr)) - = fun projectee -> match projectee with | EBufBlit _0 -> _0 -let (uu___is_EMatch : expr -> Prims.bool) = - fun projectee -> match projectee with | EMatch _0 -> true | uu___ -> false -let (__proj__EMatch__item___0 : expr -> (expr * (pattern * expr) Prims.list)) - = fun projectee -> match projectee with | EMatch _0 -> _0 -let (uu___is_EOp : expr -> Prims.bool) = - fun projectee -> match projectee with | EOp _0 -> true | uu___ -> false -let (__proj__EOp__item___0 : expr -> (op * width)) = - fun projectee -> match projectee with | EOp _0 -> _0 -let (uu___is_ECast : expr -> Prims.bool) = - fun projectee -> match projectee with | ECast _0 -> true | uu___ -> false -let (__proj__ECast__item___0 : expr -> (expr * typ)) = - fun projectee -> match projectee with | ECast _0 -> _0 -let (uu___is_EPushFrame : expr -> Prims.bool) = - fun projectee -> match projectee with | EPushFrame -> true | uu___ -> false -let (uu___is_EPopFrame : expr -> Prims.bool) = - fun projectee -> match projectee with | EPopFrame -> true | uu___ -> false -let (uu___is_EBool : expr -> Prims.bool) = - fun projectee -> match projectee with | EBool _0 -> true | uu___ -> false -let (__proj__EBool__item___0 : expr -> Prims.bool) = - fun projectee -> match projectee with | EBool _0 -> _0 -let (uu___is_EAny : expr -> Prims.bool) = - fun projectee -> match projectee with | EAny -> true | uu___ -> false -let (uu___is_EAbort : expr -> Prims.bool) = - fun projectee -> match projectee with | EAbort -> true | uu___ -> false -let (uu___is_EReturn : expr -> Prims.bool) = - fun projectee -> match projectee with | EReturn _0 -> true | uu___ -> false -let (__proj__EReturn__item___0 : expr -> expr) = - fun projectee -> match projectee with | EReturn _0 -> _0 -let (uu___is_EFlat : expr -> Prims.bool) = - fun projectee -> match projectee with | EFlat _0 -> true | uu___ -> false -let (__proj__EFlat__item___0 : - expr -> (typ * (Prims.string * expr) Prims.list)) = - fun projectee -> match projectee with | EFlat _0 -> _0 -let (uu___is_EField : expr -> Prims.bool) = - fun projectee -> match projectee with | EField _0 -> true | uu___ -> false -let (__proj__EField__item___0 : expr -> (typ * expr * Prims.string)) = - fun projectee -> match projectee with | EField _0 -> _0 -let (uu___is_EWhile : expr -> Prims.bool) = - fun projectee -> match projectee with | EWhile _0 -> true | uu___ -> false -let (__proj__EWhile__item___0 : expr -> (expr * expr)) = - fun projectee -> match projectee with | EWhile _0 -> _0 -let (uu___is_EBufCreateL : expr -> Prims.bool) = - fun projectee -> - match projectee with | EBufCreateL _0 -> true | uu___ -> false -let (__proj__EBufCreateL__item___0 : expr -> (lifetime * expr Prims.list)) = - fun projectee -> match projectee with | EBufCreateL _0 -> _0 -let (uu___is_ETuple : expr -> Prims.bool) = - fun projectee -> match projectee with | ETuple _0 -> true | uu___ -> false -let (__proj__ETuple__item___0 : expr -> expr Prims.list) = - fun projectee -> match projectee with | ETuple _0 -> _0 -let (uu___is_ECons : expr -> Prims.bool) = - fun projectee -> match projectee with | ECons _0 -> true | uu___ -> false -let (__proj__ECons__item___0 : - expr -> (typ * Prims.string * expr Prims.list)) = - fun projectee -> match projectee with | ECons _0 -> _0 -let (uu___is_EBufFill : expr -> Prims.bool) = - fun projectee -> - match projectee with | EBufFill _0 -> true | uu___ -> false -let (__proj__EBufFill__item___0 : expr -> (expr * expr * expr)) = - fun projectee -> match projectee with | EBufFill _0 -> _0 -let (uu___is_EString : expr -> Prims.bool) = - fun projectee -> match projectee with | EString _0 -> true | uu___ -> false -let (__proj__EString__item___0 : expr -> Prims.string) = - fun projectee -> match projectee with | EString _0 -> _0 -let (uu___is_EFun : expr -> Prims.bool) = - fun projectee -> match projectee with | EFun _0 -> true | uu___ -> false -let (__proj__EFun__item___0 : expr -> (binder Prims.list * expr * typ)) = - fun projectee -> match projectee with | EFun _0 -> _0 -let (uu___is_EAbortS : expr -> Prims.bool) = - fun projectee -> match projectee with | EAbortS _0 -> true | uu___ -> false -let (__proj__EAbortS__item___0 : expr -> Prims.string) = - fun projectee -> match projectee with | EAbortS _0 -> _0 -let (uu___is_EBufFree : expr -> Prims.bool) = - fun projectee -> - match projectee with | EBufFree _0 -> true | uu___ -> false -let (__proj__EBufFree__item___0 : expr -> expr) = - fun projectee -> match projectee with | EBufFree _0 -> _0 -let (uu___is_EBufCreateNoInit : expr -> Prims.bool) = - fun projectee -> - match projectee with | EBufCreateNoInit _0 -> true | uu___ -> false -let (__proj__EBufCreateNoInit__item___0 : expr -> (lifetime * expr)) = - fun projectee -> match projectee with | EBufCreateNoInit _0 -> _0 -let (uu___is_EAbortT : expr -> Prims.bool) = - fun projectee -> match projectee with | EAbortT _0 -> true | uu___ -> false -let (__proj__EAbortT__item___0 : expr -> (Prims.string * typ)) = - fun projectee -> match projectee with | EAbortT _0 -> _0 -let (uu___is_EComment : expr -> Prims.bool) = - fun projectee -> - match projectee with | EComment _0 -> true | uu___ -> false -let (__proj__EComment__item___0 : - expr -> (Prims.string * expr * Prims.string)) = - fun projectee -> match projectee with | EComment _0 -> _0 -let (uu___is_EStandaloneComment : expr -> Prims.bool) = - fun projectee -> - match projectee with | EStandaloneComment _0 -> true | uu___ -> false -let (__proj__EStandaloneComment__item___0 : expr -> Prims.string) = - fun projectee -> match projectee with | EStandaloneComment _0 -> _0 -let (uu___is_EAddrOf : expr -> Prims.bool) = - fun projectee -> match projectee with | EAddrOf _0 -> true | uu___ -> false -let (__proj__EAddrOf__item___0 : expr -> expr) = - fun projectee -> match projectee with | EAddrOf _0 -> _0 -let (uu___is_EBufNull : expr -> Prims.bool) = - fun projectee -> - match projectee with | EBufNull _0 -> true | uu___ -> false -let (__proj__EBufNull__item___0 : expr -> typ) = - fun projectee -> match projectee with | EBufNull _0 -> _0 -let (uu___is_EBufDiff : expr -> Prims.bool) = - fun projectee -> - match projectee with | EBufDiff _0 -> true | uu___ -> false -let (__proj__EBufDiff__item___0 : expr -> (expr * expr)) = - fun projectee -> match projectee with | EBufDiff _0 -> _0 -let (uu___is_Add : op -> Prims.bool) = - fun projectee -> match projectee with | Add -> true | uu___ -> false -let (uu___is_AddW : op -> Prims.bool) = - fun projectee -> match projectee with | AddW -> true | uu___ -> false -let (uu___is_Sub : op -> Prims.bool) = - fun projectee -> match projectee with | Sub -> true | uu___ -> false -let (uu___is_SubW : op -> Prims.bool) = - fun projectee -> match projectee with | SubW -> true | uu___ -> false -let (uu___is_Div : op -> Prims.bool) = - fun projectee -> match projectee with | Div -> true | uu___ -> false -let (uu___is_DivW : op -> Prims.bool) = - fun projectee -> match projectee with | DivW -> true | uu___ -> false -let (uu___is_Mult : op -> Prims.bool) = - fun projectee -> match projectee with | Mult -> true | uu___ -> false -let (uu___is_MultW : op -> Prims.bool) = - fun projectee -> match projectee with | MultW -> true | uu___ -> false -let (uu___is_Mod : op -> Prims.bool) = - fun projectee -> match projectee with | Mod -> true | uu___ -> false -let (uu___is_BOr : op -> Prims.bool) = - fun projectee -> match projectee with | BOr -> true | uu___ -> false -let (uu___is_BAnd : op -> Prims.bool) = - fun projectee -> match projectee with | BAnd -> true | uu___ -> false -let (uu___is_BXor : op -> Prims.bool) = - fun projectee -> match projectee with | BXor -> true | uu___ -> false -let (uu___is_BShiftL : op -> Prims.bool) = - fun projectee -> match projectee with | BShiftL -> true | uu___ -> false -let (uu___is_BShiftR : op -> Prims.bool) = - fun projectee -> match projectee with | BShiftR -> true | uu___ -> false -let (uu___is_BNot : op -> Prims.bool) = - fun projectee -> match projectee with | BNot -> true | uu___ -> false -let (uu___is_Eq : op -> Prims.bool) = - fun projectee -> match projectee with | Eq -> true | uu___ -> false -let (uu___is_Neq : op -> Prims.bool) = - fun projectee -> match projectee with | Neq -> true | uu___ -> false -let (uu___is_Lt : op -> Prims.bool) = - fun projectee -> match projectee with | Lt -> true | uu___ -> false -let (uu___is_Lte : op -> Prims.bool) = - fun projectee -> match projectee with | Lte -> true | uu___ -> false -let (uu___is_Gt : op -> Prims.bool) = - fun projectee -> match projectee with | Gt -> true | uu___ -> false -let (uu___is_Gte : op -> Prims.bool) = - fun projectee -> match projectee with | Gte -> true | uu___ -> false -let (uu___is_And : op -> Prims.bool) = - fun projectee -> match projectee with | And -> true | uu___ -> false -let (uu___is_Or : op -> Prims.bool) = - fun projectee -> match projectee with | Or -> true | uu___ -> false -let (uu___is_Xor : op -> Prims.bool) = - fun projectee -> match projectee with | Xor -> true | uu___ -> false -let (uu___is_Not : op -> Prims.bool) = - fun projectee -> match projectee with | Not -> true | uu___ -> false -let (uu___is_PUnit : pattern -> Prims.bool) = - fun projectee -> match projectee with | PUnit -> true | uu___ -> false -let (uu___is_PBool : pattern -> Prims.bool) = - fun projectee -> match projectee with | PBool _0 -> true | uu___ -> false -let (__proj__PBool__item___0 : pattern -> Prims.bool) = - fun projectee -> match projectee with | PBool _0 -> _0 -let (uu___is_PVar : pattern -> Prims.bool) = - fun projectee -> match projectee with | PVar _0 -> true | uu___ -> false -let (__proj__PVar__item___0 : pattern -> binder) = - fun projectee -> match projectee with | PVar _0 -> _0 -let (uu___is_PCons : pattern -> Prims.bool) = - fun projectee -> match projectee with | PCons _0 -> true | uu___ -> false -let (__proj__PCons__item___0 : - pattern -> (Prims.string * pattern Prims.list)) = - fun projectee -> match projectee with | PCons _0 -> _0 -let (uu___is_PTuple : pattern -> Prims.bool) = - fun projectee -> match projectee with | PTuple _0 -> true | uu___ -> false -let (__proj__PTuple__item___0 : pattern -> pattern Prims.list) = - fun projectee -> match projectee with | PTuple _0 -> _0 -let (uu___is_PRecord : pattern -> Prims.bool) = - fun projectee -> match projectee with | PRecord _0 -> true | uu___ -> false -let (__proj__PRecord__item___0 : - pattern -> (Prims.string * pattern) Prims.list) = - fun projectee -> match projectee with | PRecord _0 -> _0 -let (uu___is_PConstant : pattern -> Prims.bool) = - fun projectee -> - match projectee with | PConstant _0 -> true | uu___ -> false -let (__proj__PConstant__item___0 : pattern -> (width * Prims.string)) = - fun projectee -> match projectee with | PConstant _0 -> _0 -let (uu___is_UInt8 : width -> Prims.bool) = - fun projectee -> match projectee with | UInt8 -> true | uu___ -> false -let (uu___is_UInt16 : width -> Prims.bool) = - fun projectee -> match projectee with | UInt16 -> true | uu___ -> false -let (uu___is_UInt32 : width -> Prims.bool) = - fun projectee -> match projectee with | UInt32 -> true | uu___ -> false -let (uu___is_UInt64 : width -> Prims.bool) = - fun projectee -> match projectee with | UInt64 -> true | uu___ -> false -let (uu___is_Int8 : width -> Prims.bool) = - fun projectee -> match projectee with | Int8 -> true | uu___ -> false -let (uu___is_Int16 : width -> Prims.bool) = - fun projectee -> match projectee with | Int16 -> true | uu___ -> false -let (uu___is_Int32 : width -> Prims.bool) = - fun projectee -> match projectee with | Int32 -> true | uu___ -> false -let (uu___is_Int64 : width -> Prims.bool) = - fun projectee -> match projectee with | Int64 -> true | uu___ -> false -let (uu___is_Bool : width -> Prims.bool) = - fun projectee -> match projectee with | Bool -> true | uu___ -> false -let (uu___is_CInt : width -> Prims.bool) = - fun projectee -> match projectee with | CInt -> true | uu___ -> false -let (uu___is_SizeT : width -> Prims.bool) = - fun projectee -> match projectee with | SizeT -> true | uu___ -> false -let (uu___is_PtrdiffT : width -> Prims.bool) = - fun projectee -> match projectee with | PtrdiffT -> true | uu___ -> false -let (__proj__Mkbinder__item__name : binder -> Prims.string) = - fun projectee -> - match projectee with | { name; typ = typ1; mut; meta;_} -> name -let (__proj__Mkbinder__item__typ : binder -> typ) = - fun projectee -> - match projectee with | { name; typ = typ1; mut; meta;_} -> typ1 -let (__proj__Mkbinder__item__mut : binder -> Prims.bool) = - fun projectee -> - match projectee with | { name; typ = typ1; mut; meta;_} -> mut -let (__proj__Mkbinder__item__meta : binder -> flag Prims.list) = - fun projectee -> - match projectee with | { name; typ = typ1; mut; meta;_} -> meta -let (uu___is_TInt : typ -> Prims.bool) = - fun projectee -> match projectee with | TInt _0 -> true | uu___ -> false -let (__proj__TInt__item___0 : typ -> width) = - fun projectee -> match projectee with | TInt _0 -> _0 -let (uu___is_TBuf : typ -> Prims.bool) = - fun projectee -> match projectee with | TBuf _0 -> true | uu___ -> false -let (__proj__TBuf__item___0 : typ -> typ) = - fun projectee -> match projectee with | TBuf _0 -> _0 -let (uu___is_TUnit : typ -> Prims.bool) = - fun projectee -> match projectee with | TUnit -> true | uu___ -> false -let (uu___is_TQualified : typ -> Prims.bool) = - fun projectee -> - match projectee with | TQualified _0 -> true | uu___ -> false -let (__proj__TQualified__item___0 : - typ -> (Prims.string Prims.list * Prims.string)) = - fun projectee -> match projectee with | TQualified _0 -> _0 -let (uu___is_TBool : typ -> Prims.bool) = - fun projectee -> match projectee with | TBool -> true | uu___ -> false -let (uu___is_TAny : typ -> Prims.bool) = - fun projectee -> match projectee with | TAny -> true | uu___ -> false -let (uu___is_TArrow : typ -> Prims.bool) = - fun projectee -> match projectee with | TArrow _0 -> true | uu___ -> false -let (__proj__TArrow__item___0 : typ -> (typ * typ)) = - fun projectee -> match projectee with | TArrow _0 -> _0 -let (uu___is_TBound : typ -> Prims.bool) = - fun projectee -> match projectee with | TBound _0 -> true | uu___ -> false -let (__proj__TBound__item___0 : typ -> Prims.int) = - fun projectee -> match projectee with | TBound _0 -> _0 -let (uu___is_TApp : typ -> Prims.bool) = - fun projectee -> match projectee with | TApp _0 -> true | uu___ -> false -let (__proj__TApp__item___0 : - typ -> ((Prims.string Prims.list * Prims.string) * typ Prims.list)) = - fun projectee -> match projectee with | TApp _0 -> _0 -let (uu___is_TTuple : typ -> Prims.bool) = - fun projectee -> match projectee with | TTuple _0 -> true | uu___ -> false -let (__proj__TTuple__item___0 : typ -> typ Prims.list) = - fun projectee -> match projectee with | TTuple _0 -> _0 -let (uu___is_TConstBuf : typ -> Prims.bool) = - fun projectee -> - match projectee with | TConstBuf _0 -> true | uu___ -> false -let (__proj__TConstBuf__item___0 : typ -> typ) = - fun projectee -> match projectee with | TConstBuf _0 -> _0 -let (uu___is_TArray : typ -> Prims.bool) = - fun projectee -> match projectee with | TArray _0 -> true | uu___ -> false -let (__proj__TArray__item___0 : typ -> (typ * (width * Prims.string))) = - fun projectee -> match projectee with | TArray _0 -> _0 -type ident = Prims.string -type fields_t = (Prims.string * (typ * Prims.bool)) Prims.list -type branches_t = - (Prims.string * (Prims.string * (typ * Prims.bool)) Prims.list) Prims.list -type fsdoc = Prims.string -type branch = (pattern * expr) -type branches = (pattern * expr) Prims.list -type constant = (width * Prims.string) -type var = Prims.int -type lident = (Prims.string Prims.list * Prims.string) -let (pretty_width : width FStar_Class_PP.pretty) = - { - FStar_Class_PP.pp = - (fun uu___ -> - match uu___ with - | UInt8 -> FStar_Pprint.doc_of_string "UInt8" - | UInt16 -> FStar_Pprint.doc_of_string "UInt16" - | UInt32 -> FStar_Pprint.doc_of_string "UInt32" - | UInt64 -> FStar_Pprint.doc_of_string "UInt64" - | Int8 -> FStar_Pprint.doc_of_string "Int8" - | Int16 -> FStar_Pprint.doc_of_string "Int16" - | Int32 -> FStar_Pprint.doc_of_string "Int32" - | Int64 -> FStar_Pprint.doc_of_string "Int64" - | Bool -> FStar_Pprint.doc_of_string "Bool" - | CInt -> FStar_Pprint.doc_of_string "CInt" - | SizeT -> FStar_Pprint.doc_of_string "SizeT" - | PtrdiffT -> FStar_Pprint.doc_of_string "PtrdiffT") - } -let (record_string : - (Prims.string * Prims.string) Prims.list -> Prims.string) = - fun fs -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with - | (f, s) -> Prims.strcat f (Prims.strcat " = " s)) fs in - FStar_Compiler_String.concat "; " uu___2 in - Prims.strcat uu___1 "}" in - Prims.strcat "{" uu___ -let (ctor : - Prims.string -> FStar_Pprint.document Prims.list -> FStar_Pprint.document) - = - fun n -> - fun args -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Pprint.break_ Prims.int_one in - let uu___4 = - let uu___5 = FStar_Pprint.doc_of_string n in uu___5 :: args in - FStar_Pprint.flow uu___3 uu___4 in - FStar_Pprint.parens uu___2 in - FStar_Pprint.group uu___1 in - FStar_Pprint.nest (Prims.of_int (2)) uu___ -let pp_list' : - 'a . - ('a -> FStar_Pprint.document) -> 'a Prims.list -> FStar_Pprint.document - = - fun f -> - fun xs -> - (FStar_Class_PP.pp_list { FStar_Class_PP.pp = f }).FStar_Class_PP.pp xs -let rec (typ_to_doc : typ -> FStar_Pprint.document) = - fun t -> - match t with - | TInt w -> - let uu___ = let uu___1 = FStar_Class_PP.pp pretty_width w in [uu___1] in - ctor "TInt" uu___ - | TBuf t1 -> - let uu___ = let uu___1 = typ_to_doc t1 in [uu___1] in - ctor "TBuf" uu___ - | TUnit -> FStar_Pprint.doc_of_string "TUnit" - | TQualified x -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Class_Show.show - (FStar_Class_Show.show_tuple2 - (FStar_Class_Show.show_list - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_string)) - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_string)) x in - FStar_Pprint.doc_of_string uu___2 in - [uu___1] in - ctor "TQualified" uu___ - | TBool -> FStar_Pprint.doc_of_string "TBool" - | TAny -> FStar_Pprint.doc_of_string "TAny" - | TArrow (t1, t2) -> - let uu___ = - let uu___1 = typ_to_doc t1 in - let uu___2 = let uu___3 = typ_to_doc t2 in [uu___3] in uu___1 :: - uu___2 in - ctor "TArrow" uu___ - | TBound x -> - let uu___ = - let uu___1 = FStar_Class_PP.pp FStar_Class_PP.pp_int x in [uu___1] in - ctor "TBound" uu___ - | TApp (x, xs) -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Class_Show.show - (FStar_Class_Show.show_tuple2 - (FStar_Class_Show.show_list - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_string)) - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_string)) x in - FStar_Pprint.doc_of_string uu___2 in - let uu___2 = let uu___3 = pp_list' typ_to_doc xs in [uu___3] in - uu___1 :: uu___2 in - ctor "TApp" uu___ - | TTuple ts -> - let uu___ = let uu___1 = pp_list' typ_to_doc ts in [uu___1] in - ctor "TTuple" uu___ - | TConstBuf t1 -> - let uu___ = let uu___1 = typ_to_doc t1 in [uu___1] in - ctor "TConstBuf" uu___ - | TArray (t1, c) -> - let uu___ = - let uu___1 = typ_to_doc t1 in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Class_PP.pp pretty_width - (FStar_Pervasives_Native.fst c) in - let uu___7 = - let uu___8 = - FStar_Pprint.doc_of_string - (FStar_Pervasives_Native.snd c) in - [uu___8] in - uu___6 :: uu___7 in - FStar_Pprint.separate FStar_Pprint.comma uu___5 in - FStar_Pprint.parens uu___4 in - [uu___3] in - uu___1 :: uu___2 in - ctor "TArray" uu___ -let (pretty_typ : typ FStar_Class_PP.pretty) = - { FStar_Class_PP.pp = typ_to_doc } -let (pretty_string : Prims.string FStar_Class_PP.pretty) = - { - FStar_Class_PP.pp = - (fun s -> - let uu___ = FStar_Pprint.doc_of_string s in - FStar_Pprint.dquotes uu___) - } -let (pretty_flag : flag FStar_Class_PP.pretty) = - { - FStar_Class_PP.pp = - (fun uu___ -> - match uu___ with - | Private -> FStar_Pprint.doc_of_string "Private" - | WipeBody -> FStar_Pprint.doc_of_string "WipeBody" - | CInline -> FStar_Pprint.doc_of_string "CInline" - | Substitute -> FStar_Pprint.doc_of_string "Substitute" - | GCType -> FStar_Pprint.doc_of_string "GCType" - | Comment s -> - let uu___1 = - let uu___2 = FStar_Class_PP.pp pretty_string s in [uu___2] in - ctor "Comment" uu___1 - | MustDisappear -> FStar_Pprint.doc_of_string "MustDisappear" - | Const s -> - let uu___1 = - let uu___2 = FStar_Class_PP.pp pretty_string s in [uu___2] in - ctor "Const" uu___1 - | Prologue s -> - let uu___1 = - let uu___2 = FStar_Class_PP.pp pretty_string s in [uu___2] in - ctor "Prologue" uu___1 - | Epilogue s -> - let uu___1 = - let uu___2 = FStar_Class_PP.pp pretty_string s in [uu___2] in - ctor "Epilogue" uu___1 - | Abstract -> FStar_Pprint.doc_of_string "Abstract" - | IfDef -> FStar_Pprint.doc_of_string "IfDef" - | Macro -> FStar_Pprint.doc_of_string "Macro" - | Deprecated s -> - let uu___1 = - let uu___2 = FStar_Class_PP.pp pretty_string s in [uu___2] in - ctor "Deprecated" uu___1 - | CNoInline -> FStar_Pprint.doc_of_string "CNoInline") - } -let (spaced : FStar_Pprint.document -> FStar_Pprint.document) = - fun a -> - let uu___ = FStar_Pprint.break_ Prims.int_one in - let uu___1 = - let uu___2 = FStar_Pprint.break_ Prims.int_one in - FStar_Pprint.op_Hat_Hat a uu___2 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 -let (record : FStar_Pprint.document Prims.list -> FStar_Pprint.document) = - fun fs -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Pprint.break_ Prims.int_one in - FStar_Pprint.op_Hat_Hat FStar_Pprint.semi uu___5 in - FStar_Pprint.separate uu___4 fs in - spaced uu___3 in - FStar_Pprint.braces uu___2 in - FStar_Pprint.nest (Prims.of_int (2)) uu___1 in - FStar_Pprint.group uu___ -let (fld : Prims.string -> FStar_Pprint.document -> FStar_Pprint.document) = - fun n -> - fun v -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Pprint.doc_of_string (Prims.strcat n " =") in - FStar_Pprint.op_Hat_Slash_Hat uu___2 v in - FStar_Pprint.nest (Prims.of_int (2)) uu___1 in - FStar_Pprint.group uu___ -let (pretty_binder : binder FStar_Class_PP.pretty) = - { - FStar_Class_PP.pp = - (fun b -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Class_PP.pp pretty_string b.name in - fld "name" uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = FStar_Class_PP.pp pretty_typ b.typ in - fld "typ" uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = FStar_Class_PP.pp FStar_Class_PP.pp_bool b.mut in - fld "mut" uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Class_PP.pp (FStar_Class_PP.pp_list pretty_flag) - b.meta in - fld "meta" uu___8 in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - record uu___) - } -let (pretty_lifetime : lifetime FStar_Class_PP.pretty) = - { - FStar_Class_PP.pp = - (fun uu___ -> - match uu___ with - | Eternal -> FStar_Pprint.doc_of_string "Eternal" - | Stack -> FStar_Pprint.doc_of_string "Stack" - | ManuallyManaged -> FStar_Pprint.doc_of_string "ManuallyManaged") - } -let (pretty_op : op FStar_Class_PP.pretty) = - { - FStar_Class_PP.pp = - (fun uu___ -> - match uu___ with - | Add -> FStar_Pprint.doc_of_string "Add" - | AddW -> FStar_Pprint.doc_of_string "AddW" - | Sub -> FStar_Pprint.doc_of_string "Sub" - | SubW -> FStar_Pprint.doc_of_string "SubW" - | Div -> FStar_Pprint.doc_of_string "Div" - | DivW -> FStar_Pprint.doc_of_string "DivW" - | Mult -> FStar_Pprint.doc_of_string "Mult" - | MultW -> FStar_Pprint.doc_of_string "MultW" - | Mod -> FStar_Pprint.doc_of_string "Mod" - | BOr -> FStar_Pprint.doc_of_string "BOr" - | BAnd -> FStar_Pprint.doc_of_string "BAnd" - | BXor -> FStar_Pprint.doc_of_string "BXor" - | BShiftL -> FStar_Pprint.doc_of_string "BShiftL" - | BShiftR -> FStar_Pprint.doc_of_string "BShiftR" - | BNot -> FStar_Pprint.doc_of_string "BNot" - | Eq -> FStar_Pprint.doc_of_string "Eq" - | Neq -> FStar_Pprint.doc_of_string "Neq" - | Lt -> FStar_Pprint.doc_of_string "Lt" - | Lte -> FStar_Pprint.doc_of_string "Lte" - | Gt -> FStar_Pprint.doc_of_string "Gt" - | Gte -> FStar_Pprint.doc_of_string "Gte" - | And -> FStar_Pprint.doc_of_string "And" - | Or -> FStar_Pprint.doc_of_string "Or" - | Xor -> FStar_Pprint.doc_of_string "Xor" - | Not -> FStar_Pprint.doc_of_string "Not") - } -let (pretty_cc : cc FStar_Class_PP.pretty) = - { - FStar_Class_PP.pp = - (fun uu___ -> - match uu___ with - | StdCall -> FStar_Pprint.doc_of_string "StdCall" - | CDecl -> FStar_Pprint.doc_of_string "CDecl" - | FastCall -> FStar_Pprint.doc_of_string "FastCall") - } -let rec (pattern_to_doc : pattern -> FStar_Pprint.document) = - fun p -> - match p with - | PUnit -> FStar_Pprint.doc_of_string "PUnit" - | PBool b -> - let uu___ = - let uu___1 = FStar_Class_PP.pp FStar_Class_PP.pp_bool b in [uu___1] in - ctor "PBool" uu___ - | PVar b -> - let uu___ = - let uu___1 = FStar_Class_PP.pp pretty_binder b in [uu___1] in - ctor "PVar" uu___ - | PCons (x, ps) -> - let uu___ = - let uu___1 = FStar_Class_PP.pp pretty_string x in - let uu___2 = let uu___3 = pp_list' pattern_to_doc ps in [uu___3] in - uu___1 :: uu___2 in - ctor "PCons" uu___ - | PTuple ps -> - let uu___ = let uu___1 = pp_list' pattern_to_doc ps in [uu___1] in - ctor "PTuple" uu___ - | PRecord fs -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with - | (s, p1) -> - let uu___4 = pattern_to_doc p1 in fld s uu___4) fs in - record uu___2 in - [uu___1] in - ctor "PRecord" uu___ - | PConstant c -> - let uu___ = - let uu___1 = - FStar_Class_PP.pp - (FStar_Class_PP.pp_tuple2 pretty_width pretty_string) c in - [uu___1] in - ctor "PConstant" uu___ -let (pretty_pattern : pattern FStar_Class_PP.pretty) = - { FStar_Class_PP.pp = pattern_to_doc } -let rec (decl_to_doc : decl -> FStar_Pprint.document) = - fun d -> - match d with - | DGlobal (fs, x, i, t, e) -> - let uu___ = - let uu___1 = - FStar_Class_PP.pp (FStar_Class_PP.pp_list pretty_flag) fs in - let uu___2 = - let uu___3 = - FStar_Class_PP.pp - (FStar_Class_PP.pp_tuple2 - (FStar_Class_PP.pp_list pretty_string) pretty_string) x in - let uu___4 = - let uu___5 = FStar_Class_PP.pp FStar_Class_PP.pp_int i in - let uu___6 = - let uu___7 = FStar_Class_PP.pp pretty_typ t in - let uu___8 = let uu___9 = expr_to_doc e in [uu___9] in uu___7 - :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - ctor "DGlobal" uu___ - | DFunction (cc1, fs, i, t, x, bs, e) -> - let uu___ = - let uu___1 = - FStar_Class_PP.pp (FStar_Class_PP.pp_option pretty_cc) cc1 in - let uu___2 = - let uu___3 = - FStar_Class_PP.pp (FStar_Class_PP.pp_list pretty_flag) fs in - let uu___4 = - let uu___5 = FStar_Class_PP.pp FStar_Class_PP.pp_int i in - let uu___6 = - let uu___7 = FStar_Class_PP.pp pretty_typ t in - let uu___8 = - let uu___9 = - FStar_Class_PP.pp - (FStar_Class_PP.pp_tuple2 - (FStar_Class_PP.pp_list pretty_string) pretty_string) - x in - let uu___10 = - let uu___11 = - FStar_Class_PP.pp - (FStar_Class_PP.pp_list pretty_binder) bs in - let uu___12 = let uu___13 = expr_to_doc e in [uu___13] in - uu___11 :: uu___12 in - uu___9 :: uu___10 in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - ctor "DFunction" uu___ - | DTypeAlias (x, fs, i, t) -> - let uu___ = - let uu___1 = - FStar_Class_PP.pp - (FStar_Class_PP.pp_tuple2 - (FStar_Class_PP.pp_list pretty_string) pretty_string) x in - let uu___2 = - let uu___3 = - FStar_Class_PP.pp (FStar_Class_PP.pp_list pretty_flag) fs in - let uu___4 = - let uu___5 = FStar_Class_PP.pp FStar_Class_PP.pp_int i in - let uu___6 = - let uu___7 = FStar_Class_PP.pp pretty_typ t in [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - ctor "DTypeAlias" uu___ - | DTypeFlat (x, fs, i, f) -> - let uu___ = - let uu___1 = - FStar_Class_PP.pp - (FStar_Class_PP.pp_tuple2 - (FStar_Class_PP.pp_list pretty_string) pretty_string) x in - let uu___2 = - let uu___3 = - FStar_Class_PP.pp (FStar_Class_PP.pp_list pretty_flag) fs in - let uu___4 = - let uu___5 = FStar_Class_PP.pp FStar_Class_PP.pp_int i in - let uu___6 = - let uu___7 = - FStar_Class_PP.pp - (FStar_Class_PP.pp_list - (FStar_Class_PP.pp_tuple2 pretty_string - (FStar_Class_PP.pp_tuple2 pretty_typ - FStar_Class_PP.pp_bool))) f in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - ctor "DTypeFlat" uu___ - | DUnusedRetainedForBackwardsCompat (cc1, fs, x, t) -> - let uu___ = - let uu___1 = - FStar_Class_PP.pp (FStar_Class_PP.pp_option pretty_cc) cc1 in - let uu___2 = - let uu___3 = - FStar_Class_PP.pp (FStar_Class_PP.pp_list pretty_flag) fs in - let uu___4 = - let uu___5 = - FStar_Class_PP.pp - (FStar_Class_PP.pp_tuple2 - (FStar_Class_PP.pp_list pretty_string) pretty_string) x in - let uu___6 = - let uu___7 = FStar_Class_PP.pp pretty_typ t in [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - ctor "DUnusedRetainedForBackwardsCompat" uu___ - | DTypeVariant (x, fs, i, bs) -> - let uu___ = - let uu___1 = - FStar_Class_PP.pp - (FStar_Class_PP.pp_tuple2 - (FStar_Class_PP.pp_list pretty_string) pretty_string) x in - let uu___2 = - let uu___3 = - FStar_Class_PP.pp (FStar_Class_PP.pp_list pretty_flag) fs in - let uu___4 = - let uu___5 = FStar_Class_PP.pp FStar_Class_PP.pp_int i in - let uu___6 = - let uu___7 = - FStar_Class_PP.pp - (FStar_Class_PP.pp_list - (FStar_Class_PP.pp_tuple2 pretty_string - (FStar_Class_PP.pp_list - (FStar_Class_PP.pp_tuple2 pretty_string - (FStar_Class_PP.pp_tuple2 pretty_typ - FStar_Class_PP.pp_bool))))) bs in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - ctor "DTypeVariant" uu___ - | DTypeAbstractStruct x -> - let uu___ = - let uu___1 = - FStar_Class_PP.pp - (FStar_Class_PP.pp_tuple2 - (FStar_Class_PP.pp_list pretty_string) pretty_string) x in - [uu___1] in - ctor "DTypeAbstractStruct" uu___ - | DExternal (cc1, fs, x, t, xs) -> - let uu___ = - let uu___1 = - FStar_Class_PP.pp (FStar_Class_PP.pp_option pretty_cc) cc1 in - let uu___2 = - let uu___3 = - FStar_Class_PP.pp (FStar_Class_PP.pp_list pretty_flag) fs in - let uu___4 = - let uu___5 = - FStar_Class_PP.pp - (FStar_Class_PP.pp_tuple2 - (FStar_Class_PP.pp_list pretty_string) pretty_string) x in - let uu___6 = - let uu___7 = FStar_Class_PP.pp pretty_typ t in - let uu___8 = - let uu___9 = - FStar_Class_PP.pp (FStar_Class_PP.pp_list pretty_string) - xs in - [uu___9] in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - ctor "DExternal" uu___ - | DUntaggedUnion (x, fs, i, xs) -> - let uu___ = - let uu___1 = - FStar_Class_PP.pp - (FStar_Class_PP.pp_tuple2 - (FStar_Class_PP.pp_list pretty_string) pretty_string) x in - let uu___2 = - let uu___3 = - FStar_Class_PP.pp (FStar_Class_PP.pp_list pretty_flag) fs in - let uu___4 = - let uu___5 = FStar_Class_PP.pp FStar_Class_PP.pp_int i in - let uu___6 = - let uu___7 = - FStar_Class_PP.pp - (FStar_Class_PP.pp_list - (FStar_Class_PP.pp_tuple2 pretty_string pretty_typ)) - xs in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - ctor "DUntaggedUnion" uu___ -and (expr_to_doc : expr -> FStar_Pprint.document) = - fun e -> - match e with - | EBound x -> - let uu___ = - let uu___1 = FStar_Class_PP.pp FStar_Class_PP.pp_int x in [uu___1] in - ctor "EBound" uu___ - | EQualified x -> - let uu___ = - let uu___1 = - FStar_Class_PP.pp - (FStar_Class_PP.pp_tuple2 - (FStar_Class_PP.pp_list pretty_string) pretty_string) x in - [uu___1] in - ctor "EQualified" uu___ - | EConstant x -> - let uu___ = - let uu___1 = - FStar_Class_PP.pp - (FStar_Class_PP.pp_tuple2 pretty_width pretty_string) x in - [uu___1] in - ctor "EConstant" uu___ - | EUnit -> FStar_Pprint.doc_of_string "EUnit" - | EApp (x, xs) -> - let uu___ = - let uu___1 = expr_to_doc x in - let uu___2 = let uu___3 = pp_list' expr_to_doc xs in [uu___3] in - uu___1 :: uu___2 in - ctor "EApp" uu___ - | ETypApp (x, xs) -> - let uu___ = - let uu___1 = expr_to_doc x in - let uu___2 = - let uu___3 = - FStar_Class_PP.pp (FStar_Class_PP.pp_list pretty_typ) xs in - [uu___3] in - uu___1 :: uu___2 in - ctor "ETypApp" uu___ - | ELet (x, y, z) -> - let uu___ = - let uu___1 = FStar_Class_PP.pp pretty_binder x in - let uu___2 = - let uu___3 = expr_to_doc y in - let uu___4 = let uu___5 = expr_to_doc z in [uu___5] in uu___3 :: - uu___4 in - uu___1 :: uu___2 in - ctor "ELet" uu___ - | EIfThenElse (x, y, z) -> - let uu___ = - let uu___1 = expr_to_doc x in - let uu___2 = - let uu___3 = expr_to_doc y in - let uu___4 = let uu___5 = expr_to_doc z in [uu___5] in uu___3 :: - uu___4 in - uu___1 :: uu___2 in - ctor "EIfThenElse" uu___ - | ESequence xs -> - let uu___ = let uu___1 = pp_list' expr_to_doc xs in [uu___1] in - ctor "ESequence" uu___ - | EAssign (x, y) -> - let uu___ = - let uu___1 = expr_to_doc x in - let uu___2 = let uu___3 = expr_to_doc y in [uu___3] in uu___1 :: - uu___2 in - ctor "EAssign" uu___ - | EBufCreate (x, y, z) -> - let uu___ = - let uu___1 = FStar_Class_PP.pp pretty_lifetime x in - let uu___2 = - let uu___3 = expr_to_doc y in - let uu___4 = let uu___5 = expr_to_doc z in [uu___5] in uu___3 :: - uu___4 in - uu___1 :: uu___2 in - ctor "EBufCreate" uu___ - | EBufRead (x, y) -> - let uu___ = - let uu___1 = expr_to_doc x in - let uu___2 = let uu___3 = expr_to_doc y in [uu___3] in uu___1 :: - uu___2 in - ctor "EBufRead" uu___ - | EBufWrite (x, y, z) -> - let uu___ = - let uu___1 = expr_to_doc x in - let uu___2 = - let uu___3 = expr_to_doc y in - let uu___4 = let uu___5 = expr_to_doc z in [uu___5] in uu___3 :: - uu___4 in - uu___1 :: uu___2 in - ctor "EBufWrite" uu___ - | EBufSub (x, y) -> - let uu___ = - let uu___1 = expr_to_doc x in - let uu___2 = let uu___3 = expr_to_doc y in [uu___3] in uu___1 :: - uu___2 in - ctor "EBufSub" uu___ - | EBufBlit (x, y, z, a, b) -> - let uu___ = - let uu___1 = expr_to_doc x in - let uu___2 = - let uu___3 = expr_to_doc y in - let uu___4 = - let uu___5 = expr_to_doc z in - let uu___6 = - let uu___7 = expr_to_doc a in - let uu___8 = let uu___9 = expr_to_doc b in [uu___9] in uu___7 - :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - ctor "EBufBlit" uu___ - | EMatch (x, bs) -> - let uu___ = - let uu___1 = expr_to_doc x in - let uu___2 = let uu___3 = pp_list' pp_branch bs in [uu___3] in - uu___1 :: uu___2 in - ctor "EMatch" uu___ - | EOp (x, y) -> - let uu___ = - let uu___1 = FStar_Class_PP.pp pretty_op x in - let uu___2 = - let uu___3 = FStar_Class_PP.pp pretty_width y in [uu___3] in - uu___1 :: uu___2 in - ctor "EOp" uu___ - | ECast (x, y) -> - let uu___ = - let uu___1 = expr_to_doc x in - let uu___2 = - let uu___3 = FStar_Class_PP.pp pretty_typ y in [uu___3] in - uu___1 :: uu___2 in - ctor "ECast" uu___ - | EPushFrame -> FStar_Pprint.doc_of_string "EPushFrame" - | EPopFrame -> FStar_Pprint.doc_of_string "EPopFrame" - | EBool x -> - let uu___ = - let uu___1 = FStar_Class_PP.pp FStar_Class_PP.pp_bool x in [uu___1] in - ctor "EBool" uu___ - | EAny -> FStar_Pprint.doc_of_string "EAny" - | EAbort -> FStar_Pprint.doc_of_string "EAbort" - | EReturn x -> - let uu___ = let uu___1 = expr_to_doc x in [uu___1] in - ctor "EReturn" uu___ - | EFlat (x, xs) -> - let uu___ = - let uu___1 = FStar_Class_PP.pp pretty_typ x in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Compiler_List.map - (fun uu___5 -> - match uu___5 with - | (s, e1) -> let uu___6 = expr_to_doc e1 in fld s uu___6) - xs in - record uu___4 in - [uu___3] in - uu___1 :: uu___2 in - ctor "EFlat" uu___ - | EField (x, y, z) -> - let uu___ = - let uu___1 = FStar_Class_PP.pp pretty_typ x in - let uu___2 = - let uu___3 = expr_to_doc y in - let uu___4 = - let uu___5 = FStar_Class_PP.pp pretty_string z in [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - ctor "EField" uu___ - | EWhile (x, y) -> - let uu___ = - let uu___1 = expr_to_doc x in - let uu___2 = let uu___3 = expr_to_doc y in [uu___3] in uu___1 :: - uu___2 in - ctor "EWhile" uu___ - | EBufCreateL (x, xs) -> - let uu___ = - let uu___1 = FStar_Class_PP.pp pretty_lifetime x in - let uu___2 = let uu___3 = pp_list' expr_to_doc xs in [uu___3] in - uu___1 :: uu___2 in - ctor "EBufCreateL" uu___ - | ETuple xs -> - let uu___ = let uu___1 = pp_list' expr_to_doc xs in [uu___1] in - ctor "ETuple" uu___ - | ECons (x, y, xs) -> - let uu___ = - let uu___1 = FStar_Class_PP.pp pretty_typ x in - let uu___2 = - let uu___3 = FStar_Class_PP.pp pretty_string y in - let uu___4 = let uu___5 = pp_list' expr_to_doc xs in [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - ctor "ECons" uu___ - | EBufFill (x, y, z) -> - let uu___ = - let uu___1 = expr_to_doc x in - let uu___2 = - let uu___3 = expr_to_doc y in - let uu___4 = let uu___5 = expr_to_doc z in [uu___5] in uu___3 :: - uu___4 in - uu___1 :: uu___2 in - ctor "EBufFill" uu___ - | EString x -> - let uu___ = - let uu___1 = FStar_Class_PP.pp pretty_string x in [uu___1] in - ctor "EString" uu___ - | EFun (xs, y, z) -> - let uu___ = - let uu___1 = pp_list' (FStar_Class_PP.pp pretty_binder) xs in - let uu___2 = - let uu___3 = expr_to_doc y in - let uu___4 = - let uu___5 = FStar_Class_PP.pp pretty_typ z in [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - ctor "EFun" uu___ - | EAbortS x -> - let uu___ = - let uu___1 = FStar_Class_PP.pp pretty_string x in [uu___1] in - ctor "EAbortS" uu___ - | EBufFree x -> - let uu___ = let uu___1 = expr_to_doc x in [uu___1] in - ctor "EBufFree" uu___ - | EBufCreateNoInit (x, y) -> - let uu___ = - let uu___1 = FStar_Class_PP.pp pretty_lifetime x in - let uu___2 = let uu___3 = expr_to_doc y in [uu___3] in uu___1 :: - uu___2 in - ctor "EBufCreateNoInit" uu___ - | EAbortT (x, y) -> - let uu___ = - let uu___1 = FStar_Class_PP.pp pretty_string x in - let uu___2 = - let uu___3 = FStar_Class_PP.pp pretty_typ y in [uu___3] in - uu___1 :: uu___2 in - ctor "EAbortT" uu___ - | EComment (x, y, z) -> - let uu___ = - let uu___1 = FStar_Class_PP.pp pretty_string x in - let uu___2 = - let uu___3 = expr_to_doc y in - let uu___4 = - let uu___5 = FStar_Class_PP.pp pretty_string z in [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - ctor "EComment" uu___ - | EStandaloneComment x -> - let uu___ = - let uu___1 = FStar_Class_PP.pp pretty_string x in [uu___1] in - ctor "EStandaloneComment" uu___ - | EAddrOf x -> - let uu___ = let uu___1 = expr_to_doc x in [uu___1] in - ctor "EAddrOf" uu___ - | EBufNull x -> - let uu___ = let uu___1 = FStar_Class_PP.pp pretty_typ x in [uu___1] in - ctor "EBufNull" uu___ - | EBufDiff (x, y) -> - let uu___ = - let uu___1 = expr_to_doc x in - let uu___2 = let uu___3 = expr_to_doc y in [uu___3] in uu___1 :: - uu___2 in - ctor "EBufDiff" uu___ -and (pp_branch : branch -> FStar_Pprint.document) = - fun b -> - let uu___ = b in - match uu___ with - | (p, e) -> - let uu___1 = - let uu___2 = FStar_Class_PP.pp pretty_pattern p in - let uu___3 = - let uu___4 = expr_to_doc e in - FStar_Pprint.op_Hat_Slash_Hat FStar_Pprint.comma uu___4 in - FStar_Pprint.op_Hat_Hat uu___2 uu___3 in - FStar_Pprint.parens uu___1 -let (pretty_decl : decl FStar_Class_PP.pretty) = - { FStar_Class_PP.pp = decl_to_doc } -let (showable_decl : decl FStar_Class_Show.showable) = - FStar_Class_PP.showable_from_pretty pretty_decl -type program = decl Prims.list -type file = (Prims.string * program) -type binary_format = (version * file Prims.list) -let fst3 : 'uuuuu 'uuuuu1 'uuuuu2 . ('uuuuu * 'uuuuu1 * 'uuuuu2) -> 'uuuuu = - fun uu___ -> match uu___ with | (x, uu___1, uu___2) -> x -let snd3 : 'uuuuu 'uuuuu1 'uuuuu2 . ('uuuuu * 'uuuuu1 * 'uuuuu2) -> 'uuuuu1 = - fun uu___ -> match uu___ with | (uu___1, x, uu___2) -> x -let thd3 : 'uuuuu 'uuuuu1 'uuuuu2 . ('uuuuu * 'uuuuu1 * 'uuuuu2) -> 'uuuuu2 = - fun uu___ -> match uu___ with | (uu___1, uu___2, x) -> x -let (mk_width : Prims.string -> width FStar_Pervasives_Native.option) = - fun uu___ -> - match uu___ with - | "UInt8" -> FStar_Pervasives_Native.Some UInt8 - | "UInt16" -> FStar_Pervasives_Native.Some UInt16 - | "UInt32" -> FStar_Pervasives_Native.Some UInt32 - | "UInt64" -> FStar_Pervasives_Native.Some UInt64 - | "Int8" -> FStar_Pervasives_Native.Some Int8 - | "Int16" -> FStar_Pervasives_Native.Some Int16 - | "Int32" -> FStar_Pervasives_Native.Some Int32 - | "Int64" -> FStar_Pervasives_Native.Some Int64 - | "SizeT" -> FStar_Pervasives_Native.Some SizeT - | "PtrdiffT" -> FStar_Pervasives_Native.Some PtrdiffT - | uu___1 -> FStar_Pervasives_Native.None -let (mk_bool_op : Prims.string -> op FStar_Pervasives_Native.option) = - fun uu___ -> - match uu___ with - | "op_Negation" -> FStar_Pervasives_Native.Some Not - | "op_AmpAmp" -> FStar_Pervasives_Native.Some And - | "op_BarBar" -> FStar_Pervasives_Native.Some Or - | "op_Equality" -> FStar_Pervasives_Native.Some Eq - | "op_disEquality" -> FStar_Pervasives_Native.Some Neq - | uu___1 -> FStar_Pervasives_Native.None -let (is_bool_op : Prims.string -> Prims.bool) = - fun op1 -> (mk_bool_op op1) <> FStar_Pervasives_Native.None -let (mk_op : Prims.string -> op FStar_Pervasives_Native.option) = - fun uu___ -> - match uu___ with - | "add" -> FStar_Pervasives_Native.Some Add - | "op_Plus_Hat" -> FStar_Pervasives_Native.Some Add - | "add_underspec" -> FStar_Pervasives_Native.Some Add - | "add_mod" -> FStar_Pervasives_Native.Some AddW - | "op_Plus_Percent_Hat" -> FStar_Pervasives_Native.Some AddW - | "sub" -> FStar_Pervasives_Native.Some Sub - | "op_Subtraction_Hat" -> FStar_Pervasives_Native.Some Sub - | "sub_underspec" -> FStar_Pervasives_Native.Some Sub - | "sub_mod" -> FStar_Pervasives_Native.Some SubW - | "op_Subtraction_Percent_Hat" -> FStar_Pervasives_Native.Some SubW - | "mul" -> FStar_Pervasives_Native.Some Mult - | "op_Star_Hat" -> FStar_Pervasives_Native.Some Mult - | "mul_underspec" -> FStar_Pervasives_Native.Some Mult - | "mul_mod" -> FStar_Pervasives_Native.Some MultW - | "op_Star_Percent_Hat" -> FStar_Pervasives_Native.Some MultW - | "div" -> FStar_Pervasives_Native.Some Div - | "op_Slash_Hat" -> FStar_Pervasives_Native.Some Div - | "div_mod" -> FStar_Pervasives_Native.Some DivW - | "op_Slash_Percent_Hat" -> FStar_Pervasives_Native.Some DivW - | "rem" -> FStar_Pervasives_Native.Some Mod - | "op_Percent_Hat" -> FStar_Pervasives_Native.Some Mod - | "logor" -> FStar_Pervasives_Native.Some BOr - | "op_Bar_Hat" -> FStar_Pervasives_Native.Some BOr - | "logxor" -> FStar_Pervasives_Native.Some BXor - | "op_Hat_Hat" -> FStar_Pervasives_Native.Some BXor - | "logand" -> FStar_Pervasives_Native.Some BAnd - | "op_Amp_Hat" -> FStar_Pervasives_Native.Some BAnd - | "lognot" -> FStar_Pervasives_Native.Some BNot - | "shift_right" -> FStar_Pervasives_Native.Some BShiftR - | "op_Greater_Greater_Hat" -> FStar_Pervasives_Native.Some BShiftR - | "shift_left" -> FStar_Pervasives_Native.Some BShiftL - | "op_Less_Less_Hat" -> FStar_Pervasives_Native.Some BShiftL - | "eq" -> FStar_Pervasives_Native.Some Eq - | "op_Equals_Hat" -> FStar_Pervasives_Native.Some Eq - | "op_Greater_Hat" -> FStar_Pervasives_Native.Some Gt - | "gt" -> FStar_Pervasives_Native.Some Gt - | "op_Greater_Equals_Hat" -> FStar_Pervasives_Native.Some Gte - | "gte" -> FStar_Pervasives_Native.Some Gte - | "op_Less_Hat" -> FStar_Pervasives_Native.Some Lt - | "lt" -> FStar_Pervasives_Native.Some Lt - | "op_Less_Equals_Hat" -> FStar_Pervasives_Native.Some Lte - | "lte" -> FStar_Pervasives_Native.Some Lte - | uu___1 -> FStar_Pervasives_Native.None -let (is_op : Prims.string -> Prims.bool) = - fun op1 -> (mk_op op1) <> FStar_Pervasives_Native.None -let (is_machine_int : Prims.string -> Prims.bool) = - fun m -> (mk_width m) <> FStar_Pervasives_Native.None -type env = - { - uenv: FStar_Extraction_ML_UEnv.uenv ; - names: name Prims.list ; - names_t: Prims.string Prims.list ; - module_name: Prims.string Prims.list } -and name = { - pretty: Prims.string } -let (__proj__Mkenv__item__uenv : env -> FStar_Extraction_ML_UEnv.uenv) = - fun projectee -> - match projectee with | { uenv; names; names_t; module_name;_} -> uenv -let (__proj__Mkenv__item__names : env -> name Prims.list) = - fun projectee -> - match projectee with | { uenv; names; names_t; module_name;_} -> names -let (__proj__Mkenv__item__names_t : env -> Prims.string Prims.list) = - fun projectee -> - match projectee with | { uenv; names; names_t; module_name;_} -> names_t -let (__proj__Mkenv__item__module_name : env -> Prims.string Prims.list) = - fun projectee -> - match projectee with - | { uenv; names; names_t; module_name;_} -> module_name -let (__proj__Mkname__item__pretty : name -> Prims.string) = - fun projectee -> match projectee with | { pretty;_} -> pretty -let (empty : FStar_Extraction_ML_UEnv.uenv -> Prims.string Prims.list -> env) - = - fun uenv -> - fun module_name -> { uenv; names = []; names_t = []; module_name } -let (extend : env -> Prims.string -> env) = - fun env1 -> - fun x -> - { - uenv = (env1.uenv); - names = ({ pretty = x } :: (env1.names)); - names_t = (env1.names_t); - module_name = (env1.module_name) - } -let (extend_t : env -> Prims.string -> env) = - fun env1 -> - fun x -> - { - uenv = (env1.uenv); - names = (env1.names); - names_t = (x :: (env1.names_t)); - module_name = (env1.module_name) - } -let (find_name : env -> Prims.string -> name) = - fun env1 -> - fun x -> - let uu___ = - FStar_Compiler_List.tryFind (fun name1 -> name1.pretty = x) - env1.names in - match uu___ with - | FStar_Pervasives_Native.Some name1 -> name1 - | FStar_Pervasives_Native.None -> - failwith "internal error: name not found" -let (find : env -> Prims.string -> Prims.int) = - fun env1 -> - fun x -> - try - (fun uu___ -> - match () with - | () -> - FStar_Compiler_List.index (fun name1 -> name1.pretty = x) - env1.names) () - with - | uu___ -> - let uu___1 = - FStar_Compiler_Util.format1 "Internal error: name not found %s\n" - x in - failwith uu___1 -let (find_t : env -> Prims.string -> Prims.int) = - fun env1 -> - fun x -> - try - (fun uu___ -> - match () with - | () -> - FStar_Compiler_List.index (fun name1 -> name1 = x) - env1.names_t) () - with - | uu___ -> - let uu___1 = - FStar_Compiler_Util.format1 "Internal error: name not found %s\n" - x in - failwith uu___1 -let (add_binders : - env -> FStar_Extraction_ML_Syntax.mlbinder Prims.list -> env) = - fun env1 -> - fun bs -> - FStar_Compiler_List.fold_left - (fun env2 -> - fun uu___ -> - match uu___ with - | { FStar_Extraction_ML_Syntax.mlbinder_name = mlbinder_name; - FStar_Extraction_ML_Syntax.mlbinder_ty = uu___1; - FStar_Extraction_ML_Syntax.mlbinder_attrs = uu___2;_} -> - extend env2 mlbinder_name) env1 bs -let (list_elements : - FStar_Extraction_ML_Syntax.mlexpr -> - FStar_Extraction_ML_Syntax.mlexpr Prims.list) - = - fun e -> - let lopt = FStar_Extraction_ML_Util.list_elements e in - match lopt with - | FStar_Pervasives_Native.None -> - failwith "Argument of FStar.Buffer.createL is not a list literal!" - | FStar_Pervasives_Native.Some l -> l -let (translate_flags : - FStar_Extraction_ML_Syntax.meta Prims.list -> flag Prims.list) = - fun flags -> - FStar_Compiler_List.choose - (fun uu___ -> - match uu___ with - | FStar_Extraction_ML_Syntax.Private -> - FStar_Pervasives_Native.Some Private - | FStar_Extraction_ML_Syntax.NoExtract -> - FStar_Pervasives_Native.Some WipeBody - | FStar_Extraction_ML_Syntax.CInline -> - FStar_Pervasives_Native.Some CInline - | FStar_Extraction_ML_Syntax.CNoInline -> - FStar_Pervasives_Native.Some CNoInline - | FStar_Extraction_ML_Syntax.Substitute -> - FStar_Pervasives_Native.Some Substitute - | FStar_Extraction_ML_Syntax.GCType -> - FStar_Pervasives_Native.Some GCType - | FStar_Extraction_ML_Syntax.Comment s -> - FStar_Pervasives_Native.Some (Comment s) - | FStar_Extraction_ML_Syntax.StackInline -> - FStar_Pervasives_Native.Some MustDisappear - | FStar_Extraction_ML_Syntax.CConst s -> - FStar_Pervasives_Native.Some (Const s) - | FStar_Extraction_ML_Syntax.CPrologue s -> - FStar_Pervasives_Native.Some (Prologue s) - | FStar_Extraction_ML_Syntax.CEpilogue s -> - FStar_Pervasives_Native.Some (Epilogue s) - | FStar_Extraction_ML_Syntax.CAbstract -> - FStar_Pervasives_Native.Some Abstract - | FStar_Extraction_ML_Syntax.CIfDef -> - FStar_Pervasives_Native.Some IfDef - | FStar_Extraction_ML_Syntax.CMacro -> - FStar_Pervasives_Native.Some Macro - | FStar_Extraction_ML_Syntax.Deprecated s -> - FStar_Pervasives_Native.Some (Deprecated s) - | uu___1 -> FStar_Pervasives_Native.None) flags -let (translate_cc : - FStar_Extraction_ML_Syntax.meta Prims.list -> - cc FStar_Pervasives_Native.option) - = - fun flags -> - let uu___ = - FStar_Compiler_List.choose - (fun uu___1 -> - match uu___1 with - | FStar_Extraction_ML_Syntax.CCConv s -> - FStar_Pervasives_Native.Some s - | uu___2 -> FStar_Pervasives_Native.None) flags in - match uu___ with - | "stdcall"::[] -> FStar_Pervasives_Native.Some StdCall - | "fastcall"::[] -> FStar_Pervasives_Native.Some FastCall - | "cdecl"::[] -> FStar_Pervasives_Native.Some CDecl - | uu___1 -> FStar_Pervasives_Native.None -let (generate_is_null : typ -> expr -> expr) = - fun t -> - fun x -> - let dummy = UInt64 in - EApp ((ETypApp ((EOp (Eq, dummy)), [TBuf t])), [x; EBufNull t]) -exception NotSupportedByKrmlExtension -let (uu___is_NotSupportedByKrmlExtension : Prims.exn -> Prims.bool) = - fun projectee -> - match projectee with - | NotSupportedByKrmlExtension -> true - | uu___ -> false -type translate_type_without_decay_t = - env -> FStar_Extraction_ML_Syntax.mlty -> typ -let (ref_translate_type_without_decay : - translate_type_without_decay_t FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref - (fun uu___ -> - fun uu___1 -> FStar_Compiler_Effect.raise NotSupportedByKrmlExtension) -let (register_pre_translate_type_without_decay : - translate_type_without_decay_t -> unit) = - fun f -> - let before = - FStar_Compiler_Effect.op_Bang ref_translate_type_without_decay in - let after e t = - try (fun uu___ -> match () with | () -> f e t) () - with | NotSupportedByKrmlExtension -> before e t in - FStar_Compiler_Effect.op_Colon_Equals ref_translate_type_without_decay - after -let (register_post_translate_type_without_decay : - translate_type_without_decay_t -> unit) = - fun f -> - let before = - FStar_Compiler_Effect.op_Bang ref_translate_type_without_decay in - let after e t = - try (fun uu___ -> match () with | () -> before e t) () - with | NotSupportedByKrmlExtension -> f e t in - FStar_Compiler_Effect.op_Colon_Equals ref_translate_type_without_decay - after -let (translate_type_without_decay : - env -> FStar_Extraction_ML_Syntax.mlty -> typ) = - fun env1 -> - fun t -> - let uu___ = - FStar_Compiler_Effect.op_Bang ref_translate_type_without_decay in - uu___ env1 t -type translate_type_t = env -> FStar_Extraction_ML_Syntax.mlty -> typ -let (ref_translate_type : translate_type_t FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref - (fun uu___ -> - fun uu___1 -> FStar_Compiler_Effect.raise NotSupportedByKrmlExtension) -let (register_pre_translate_type : translate_type_t -> unit) = - fun f -> - let before = FStar_Compiler_Effect.op_Bang ref_translate_type in - let after e t = - try (fun uu___ -> match () with | () -> f e t) () - with | NotSupportedByKrmlExtension -> before e t in - FStar_Compiler_Effect.op_Colon_Equals ref_translate_type after -let (register_post_translate_type : translate_type_t -> unit) = - fun f -> - let before = FStar_Compiler_Effect.op_Bang ref_translate_type in - let after e t = - try (fun uu___ -> match () with | () -> before e t) () - with | NotSupportedByKrmlExtension -> f e t in - FStar_Compiler_Effect.op_Colon_Equals ref_translate_type after -let (translate_type : env -> FStar_Extraction_ML_Syntax.mlty -> typ) = - fun env1 -> - fun t -> - let uu___ = FStar_Compiler_Effect.op_Bang ref_translate_type in - uu___ env1 t -type translate_expr_t = env -> FStar_Extraction_ML_Syntax.mlexpr -> expr -let (ref_translate_expr : translate_expr_t FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref - (fun uu___ -> - fun uu___1 -> FStar_Compiler_Effect.raise NotSupportedByKrmlExtension) -let (register_pre_translate_expr : translate_expr_t -> unit) = - fun f -> - let before = FStar_Compiler_Effect.op_Bang ref_translate_expr in - let after e t = - try (fun uu___ -> match () with | () -> f e t) () - with | NotSupportedByKrmlExtension -> before e t in - FStar_Compiler_Effect.op_Colon_Equals ref_translate_expr after -let (register_post_translate_expr : translate_expr_t -> unit) = - fun f -> - let before = FStar_Compiler_Effect.op_Bang ref_translate_expr in - let after e t = - try (fun uu___ -> match () with | () -> before e t) () - with | NotSupportedByKrmlExtension -> f e t in - FStar_Compiler_Effect.op_Colon_Equals ref_translate_expr after -let (translate_expr : env -> FStar_Extraction_ML_Syntax.mlexpr -> expr) = - fun env1 -> - fun e -> - let uu___ = FStar_Compiler_Effect.op_Bang ref_translate_expr in - uu___ env1 e -type translate_type_decl_t = - env -> - FStar_Extraction_ML_Syntax.one_mltydecl -> - decl FStar_Pervasives_Native.option -let (ref_translate_type_decl : - translate_type_decl_t FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref - (fun uu___ -> - fun uu___1 -> FStar_Compiler_Effect.raise NotSupportedByKrmlExtension) -let (register_pre_translate_type_decl : translate_type_decl_t -> unit) = - fun f -> - let before = FStar_Compiler_Effect.op_Bang ref_translate_type_decl in - let after e t = - try (fun uu___ -> match () with | () -> f e t) () - with | NotSupportedByKrmlExtension -> before e t in - FStar_Compiler_Effect.op_Colon_Equals ref_translate_type_decl after -let (register_post_translate_type_decl : translate_type_decl_t -> unit) = - fun f -> - let before = FStar_Compiler_Effect.op_Bang ref_translate_type_decl in - let after e t = - try (fun uu___ -> match () with | () -> before e t) () - with | NotSupportedByKrmlExtension -> f e t in - FStar_Compiler_Effect.op_Colon_Equals ref_translate_type_decl after -let (translate_type_decl : - env -> - FStar_Extraction_ML_Syntax.one_mltydecl -> - decl FStar_Pervasives_Native.option) - = - fun env1 -> - fun ty -> - if - FStar_Compiler_List.mem FStar_Extraction_ML_Syntax.NoExtract - ty.FStar_Extraction_ML_Syntax.tydecl_meta - then FStar_Pervasives_Native.None - else - (let uu___1 = FStar_Compiler_Effect.op_Bang ref_translate_type_decl in - uu___1 env1 ty) -let rec (translate_type_without_decay' : - env -> FStar_Extraction_ML_Syntax.mlty -> typ) = - fun env1 -> - fun t -> - match t with - | FStar_Extraction_ML_Syntax.MLTY_Tuple [] -> TAny - | FStar_Extraction_ML_Syntax.MLTY_Top -> TAny - | FStar_Extraction_ML_Syntax.MLTY_Var name1 -> - let uu___ = find_t env1 name1 in TBound uu___ - | FStar_Extraction_ML_Syntax.MLTY_Fun (t1, uu___, t2) -> - let uu___1 = - let uu___2 = translate_type_without_decay env1 t1 in - let uu___3 = translate_type_without_decay env1 t2 in - (uu___2, uu___3) in - TArrow uu___1 - | FStar_Extraction_ML_Syntax.MLTY_Erased -> TUnit - | FStar_Extraction_ML_Syntax.MLTY_Named ([], p) when - let uu___ = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___ = "Prims.unit" -> TUnit - | FStar_Extraction_ML_Syntax.MLTY_Named ([], p) when - let uu___ = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___ = "Prims.bool" -> TBool - | FStar_Extraction_ML_Syntax.MLTY_Named ([], ("FStar"::m::[], "t")) - when is_machine_int m -> - let uu___ = FStar_Compiler_Util.must (mk_width m) in TInt uu___ - | FStar_Extraction_ML_Syntax.MLTY_Named ([], ("FStar"::m::[], "t'")) - when is_machine_int m -> - let uu___ = FStar_Compiler_Util.must (mk_width m) in TInt uu___ - | FStar_Extraction_ML_Syntax.MLTY_Named ([], p) when - let uu___ = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___ = "FStar.Monotonic.HyperStack.mem" -> TUnit - | FStar_Extraction_ML_Syntax.MLTY_Named (uu___::arg::uu___1::[], p) - when - (((let uu___2 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___2 = "FStar.Monotonic.HyperStack.s_mref") || - (let uu___2 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___2 = "FStar.Monotonic.HyperHeap.mrref")) - || - (let uu___2 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___2 = "FStar.HyperStack.ST.m_rref")) - || - (let uu___2 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___2 = "FStar.HyperStack.ST.s_mref") - -> - let uu___2 = translate_type_without_decay env1 arg in TBuf uu___2 - | FStar_Extraction_ML_Syntax.MLTY_Named (arg::uu___::[], p) when - ((((((((((let uu___1 = - FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___1 = "FStar.Monotonic.HyperStack.mreference") || - (let uu___1 = - FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___1 = "FStar.Monotonic.HyperStack.mstackref")) - || - (let uu___1 = - FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___1 = "FStar.Monotonic.HyperStack.mref")) - || - (let uu___1 = - FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___1 = "FStar.Monotonic.HyperStack.mmmstackref")) - || - (let uu___1 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___1 = "FStar.Monotonic.HyperStack.mmmref")) - || - (let uu___1 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___1 = "FStar.Monotonic.Heap.mref")) - || - (let uu___1 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___1 = "FStar.HyperStack.ST.mreference")) - || - (let uu___1 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___1 = "FStar.HyperStack.ST.mstackref")) - || - (let uu___1 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___1 = "FStar.HyperStack.ST.mref")) - || - (let uu___1 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___1 = "FStar.HyperStack.ST.mmmstackref")) - || - (let uu___1 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___1 = "FStar.HyperStack.ST.mmmref") - -> - let uu___1 = translate_type_without_decay env1 arg in TBuf uu___1 - | FStar_Extraction_ML_Syntax.MLTY_Named (arg::uu___::uu___1::[], p) - when - let uu___2 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___2 = "LowStar.Monotonic.Buffer.mbuffer" -> - let uu___2 = translate_type_without_decay env1 arg in TBuf uu___2 - | FStar_Extraction_ML_Syntax.MLTY_Named (arg::[], p) when - (let uu___ = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___ = "LowStar.ConstBuffer.const_buffer") || false - -> - let uu___ = translate_type_without_decay env1 arg in - TConstBuf uu___ - | FStar_Extraction_ML_Syntax.MLTY_Named (arg::[], p) when - ((((((((((((((let uu___ = - FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___ = "FStar.Buffer.buffer") || - (let uu___ = - FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___ = "LowStar.Buffer.buffer")) - || - (let uu___ = - FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___ = "LowStar.ImmutableBuffer.ibuffer")) - || - (let uu___ = - FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___ = "LowStar.UninitializedBuffer.ubuffer")) - || - (let uu___ = - FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___ = "FStar.HyperStack.reference")) - || - (let uu___ = - FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___ = "FStar.HyperStack.stackref")) - || - (let uu___ = - FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___ = "FStar.HyperStack.ref")) - || - (let uu___ = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___ = "FStar.HyperStack.mmstackref")) - || - (let uu___ = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___ = "FStar.HyperStack.mmref")) - || - (let uu___ = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___ = "FStar.HyperStack.ST.reference")) - || - (let uu___ = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___ = "FStar.HyperStack.ST.stackref")) - || - (let uu___ = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___ = "FStar.HyperStack.ST.ref")) - || - (let uu___ = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___ = "FStar.HyperStack.ST.mmstackref")) - || - (let uu___ = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___ = "FStar.HyperStack.ST.mmref")) - || false - -> let uu___ = translate_type_without_decay env1 arg in TBuf uu___ - | FStar_Extraction_ML_Syntax.MLTY_Named (uu___::arg::[], p) when - (let uu___1 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___1 = "FStar.HyperStack.s_ref") || - (let uu___1 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___1 = "FStar.HyperStack.ST.s_ref") - -> - let uu___1 = translate_type_without_decay env1 arg in TBuf uu___1 - | FStar_Extraction_ML_Syntax.MLTY_Named (arg::[], p) when - let uu___ = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___ = "FStar.Universe.raise_t" -> - translate_type_without_decay env1 arg - | FStar_Extraction_ML_Syntax.MLTY_Named (uu___::[], p) when - let uu___1 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___1 = "FStar.Ghost.erased" -> TAny - | FStar_Extraction_ML_Syntax.MLTY_Named ([], (path, type_name)) -> - TQualified (path, type_name) - | FStar_Extraction_ML_Syntax.MLTY_Named (args, (ns, t1)) when - ((ns = ["Prims"]) || (ns = ["FStar"; "Pervasives"; "Native"])) && - (FStar_Compiler_Util.starts_with t1 "tuple") - -> - let uu___ = - FStar_Compiler_List.map (translate_type_without_decay env1) args in - TTuple uu___ - | FStar_Extraction_ML_Syntax.MLTY_Named (args, lid) -> - if (FStar_Compiler_List.length args) > Prims.int_zero - then - let uu___ = - let uu___1 = - FStar_Compiler_List.map (translate_type_without_decay env1) - args in - (lid, uu___1) in - TApp uu___ - else TQualified lid - | FStar_Extraction_ML_Syntax.MLTY_Tuple ts -> - let uu___ = - FStar_Compiler_List.map (translate_type_without_decay env1) ts in - TTuple uu___ -and (translate_type' : env -> FStar_Extraction_ML_Syntax.mlty -> typ) = - fun env1 -> fun t -> translate_type_without_decay env1 t -and (translate_binders : - env -> FStar_Extraction_ML_Syntax.mlbinder Prims.list -> binder Prims.list) - = fun env1 -> fun bs -> FStar_Compiler_List.map (translate_binder env1) bs -and (translate_binder : env -> FStar_Extraction_ML_Syntax.mlbinder -> binder) - = - fun env1 -> - fun uu___ -> - match uu___ with - | { FStar_Extraction_ML_Syntax.mlbinder_name = mlbinder_name; - FStar_Extraction_ML_Syntax.mlbinder_ty = mlbinder_ty; - FStar_Extraction_ML_Syntax.mlbinder_attrs = mlbinder_attrs;_} -> - let uu___1 = translate_type env1 mlbinder_ty in - { name = mlbinder_name; typ = uu___1; mut = false; meta = [] } -and (translate_expr' : env -> FStar_Extraction_ML_Syntax.mlexpr -> expr) = - fun env1 -> - fun e -> - match e.FStar_Extraction_ML_Syntax.expr with - | FStar_Extraction_ML_Syntax.MLE_Tuple [] -> EUnit - | FStar_Extraction_ML_Syntax.MLE_Const c -> translate_constant c - | FStar_Extraction_ML_Syntax.MLE_Var name1 -> - let uu___ = find env1 name1 in EBound uu___ - | FStar_Extraction_ML_Syntax.MLE_Name ("FStar"::m::[], op1) when - (is_machine_int m) && (is_op op1) -> - let uu___ = - let uu___1 = FStar_Compiler_Util.must (mk_op op1) in - let uu___2 = FStar_Compiler_Util.must (mk_width m) in - (uu___1, uu___2) in - EOp uu___ - | FStar_Extraction_ML_Syntax.MLE_Name ("Prims"::[], op1) when - is_bool_op op1 -> - let uu___ = - let uu___1 = FStar_Compiler_Util.must (mk_bool_op op1) in - (uu___1, Bool) in - EOp uu___ - | FStar_Extraction_ML_Syntax.MLE_Name n -> EQualified n - | FStar_Extraction_ML_Syntax.MLE_Let - ((flavor, - { FStar_Extraction_ML_Syntax.mllb_name = name1; - FStar_Extraction_ML_Syntax.mllb_tysc = - FStar_Pervasives_Native.Some ([], typ1); - FStar_Extraction_ML_Syntax.mllb_add_unit = add_unit; - FStar_Extraction_ML_Syntax.mllb_def = body; - FStar_Extraction_ML_Syntax.mllb_attrs = uu___; - FStar_Extraction_ML_Syntax.mllb_meta = flags; - FStar_Extraction_ML_Syntax.print_typ = print;_}::[]), - continuation) - -> - let binder1 = - let uu___1 = translate_type env1 typ1 in - let uu___2 = translate_flags flags in - { name = name1; typ = uu___1; mut = false; meta = uu___2 } in - let body1 = translate_expr env1 body in - let env2 = extend env1 name1 in - let continuation1 = translate_expr env2 continuation in - ELet (binder1, body1, continuation1) - | FStar_Extraction_ML_Syntax.MLE_Match (expr1, branches1) -> - let uu___ = - let uu___1 = translate_expr env1 expr1 in - let uu___2 = translate_branches env1 branches1 in - (uu___1, uu___2) in - EMatch uu___ - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - t::[]); - FStar_Extraction_ML_Syntax.mlty = uu___2; - FStar_Extraction_ML_Syntax.loc = uu___3;_}, - arg::[]) - when - let uu___4 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___4 = "FStar.Dyn.undyn" -> - let uu___4 = - let uu___5 = translate_expr env1 arg in - let uu___6 = translate_type env1 t in (uu___5, uu___6) in - ECast uu___4 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - uu___5) - when - let uu___6 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___6 = "Prims.admit" -> EAbort - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - t::[]); - FStar_Extraction_ML_Syntax.mlty = uu___2; - FStar_Extraction_ML_Syntax.loc = uu___3;_}, - { - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Const - (FStar_Extraction_ML_Syntax.MLC_String s); - FStar_Extraction_ML_Syntax.mlty = uu___4; - FStar_Extraction_ML_Syntax.loc = uu___5;_}::[]) - when - let uu___6 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___6 = "LowStar.Failure.failwith" -> - let uu___6 = let uu___7 = translate_type env1 t in (s, uu___7) in - EAbortT uu___6 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - arg::[]) - when - ((let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "FStar.HyperStack.All.failwith") || - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "FStar.Error.unexpected")) - || - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "FStar.Error.unreachable") - -> - (match arg with - | { - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Const - (FStar_Extraction_ML_Syntax.MLC_String msg); - FStar_Extraction_ML_Syntax.mlty = uu___5; - FStar_Extraction_ML_Syntax.loc = uu___6;_} -> EAbortS msg - | uu___5 -> - let print_nm = (["FStar"; "HyperStack"; "IO"], "print_string") in - let print = - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.MLTY_Top - (FStar_Extraction_ML_Syntax.MLE_Name print_nm) in - let print1 = - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.MLTY_Top - (FStar_Extraction_ML_Syntax.MLE_App (print, [arg])) in - let t = translate_expr env1 print1 in ESequence [t; EAbort]) - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - e1::[]) - when - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.ToFStarBuffer.new_to_old_st") || - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.ToFStarBuffer.old_to_new_st") - -> translate_expr env1 e1 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - e1::e2::[]) - when - ((((let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "FStar.Buffer.index") || - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "FStar.Buffer.op_Array_Access")) - || - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.Monotonic.Buffer.index")) - || - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.UninitializedBuffer.uindex")) - || - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.ConstBuffer.index") - -> - let uu___5 = - let uu___6 = translate_expr env1 e1 in - let uu___7 = translate_expr env1 e2 in (uu___6, uu___7) in - EBufRead uu___5 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - e1::[]) - when - let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "FStar.HyperStack.ST.op_Bang" -> - let uu___5 = - let uu___6 = translate_expr env1 e1 in - (uu___6, (EQualified (["C"], "_zero_for_deref"))) in - EBufRead uu___5 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - arg::[]) - when - let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "FStar.Universe.raise_val" -> translate_expr env1 arg - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - arg::[]) - when - let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "FStar.Universe.downgrade_val" -> translate_expr env1 arg - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - e1::e2::[]) - when - ((let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "FStar.Buffer.create") || - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.Monotonic.Buffer.malloca")) - || - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.ImmutableBuffer.ialloca") - -> - let uu___5 = - let uu___6 = translate_expr env1 e1 in - let uu___7 = translate_expr env1 e2 in (Stack, uu___6, uu___7) in - EBufCreate uu___5 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - elen::[]) - when - let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.UninitializedBuffer.ualloca" -> - let uu___5 = - let uu___6 = translate_expr env1 elen in (Stack, uu___6) in - EBufCreateNoInit uu___5 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - init::[]) - when - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "FStar.HyperStack.ST.salloc") || false - -> - let uu___5 = - let uu___6 = translate_expr env1 init in - (Stack, uu___6, (EConstant (UInt32, "1"))) in - EBufCreate uu___5 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - e2::[]) - when - ((let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "FStar.Buffer.createL") || - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.Monotonic.Buffer.malloca_of_list")) - || - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.ImmutableBuffer.ialloca_of_list") - -> - let uu___5 = - let uu___6 = - let uu___7 = list_elements e2 in - FStar_Compiler_List.map (translate_expr env1) uu___7 in - (Stack, uu___6) in - EBufCreateL uu___5 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - _erid::e2::[]) - when - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.Monotonic.Buffer.mgcmalloc_of_list") || - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.ImmutableBuffer.igcmalloc_of_list") - -> - let uu___5 = - let uu___6 = - let uu___7 = list_elements e2 in - FStar_Compiler_List.map (translate_expr env1) uu___7 in - (Eternal, uu___6) in - EBufCreateL uu___5 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - _rid::init::[]) - when - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "FStar.HyperStack.ST.ralloc") || - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "FStar.HyperStack.ST.ralloc_drgn") - -> - let uu___5 = - let uu___6 = translate_expr env1 init in - (Eternal, uu___6, (EConstant (UInt32, "1"))) in - EBufCreate uu___5 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - _e0::e1::e2::[]) - when - ((let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "FStar.Buffer.rcreate") || - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.Monotonic.Buffer.mgcmalloc")) - || - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.ImmutableBuffer.igcmalloc") - -> - let uu___5 = - let uu___6 = translate_expr env1 e1 in - let uu___7 = translate_expr env1 e2 in (Eternal, uu___6, uu___7) in - EBufCreate uu___5 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - uu___5) - when - (((((let uu___6 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___6 = "LowStar.Monotonic.Buffer.mgcmalloc_and_blit") || - (let uu___6 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___6 = "LowStar.Monotonic.Buffer.mmalloc_and_blit")) - || - (let uu___6 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___6 = "LowStar.Monotonic.Buffer.malloca_and_blit")) - || - (let uu___6 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___6 = "LowStar.ImmutableBuffer.igcmalloc_and_blit")) - || - (let uu___6 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___6 = "LowStar.ImmutableBuffer.imalloc_and_blit")) - || - (let uu___6 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___6 = "LowStar.ImmutableBuffer.ialloca_and_blit") - -> - EAbortS - "alloc_and_blit family of functions are not yet supported downstream" - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - _erid::elen::[]) - when - let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.UninitializedBuffer.ugcmalloc" -> - let uu___5 = - let uu___6 = translate_expr env1 elen in (Eternal, uu___6) in - EBufCreateNoInit uu___5 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - _rid::init::[]) - when - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "FStar.HyperStack.ST.ralloc_mm") || - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "FStar.HyperStack.ST.ralloc_drgn_mm") - -> - let uu___5 = - let uu___6 = translate_expr env1 init in - (ManuallyManaged, uu___6, (EConstant (UInt32, "1"))) in - EBufCreate uu___5 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - _e0::e1::e2::[]) - when - (((let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "FStar.Buffer.rcreate_mm") || - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.Monotonic.Buffer.mmalloc")) - || - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.Monotonic.Buffer.mmalloc")) - || - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.ImmutableBuffer.imalloc") - -> - let uu___5 = - let uu___6 = translate_expr env1 e1 in - let uu___7 = translate_expr env1 e2 in - (ManuallyManaged, uu___6, uu___7) in - EBufCreate uu___5 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - _erid::elen::[]) - when - let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.UninitializedBuffer.umalloc" -> - let uu___5 = - let uu___6 = translate_expr env1 elen in - (ManuallyManaged, uu___6) in - EBufCreateNoInit uu___5 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - e2::[]) - when - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "FStar.HyperStack.ST.rfree") || false - -> let uu___5 = translate_expr env1 e2 in EBufFree uu___5 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - e2::[]) - when - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "FStar.Buffer.rfree") || - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.Monotonic.Buffer.free") - -> let uu___5 = translate_expr env1 e2 in EBufFree uu___5 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - e1::e2::_e3::[]) - when - let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "FStar.Buffer.sub" -> - let uu___5 = - let uu___6 = translate_expr env1 e1 in - let uu___7 = translate_expr env1 e2 in (uu___6, uu___7) in - EBufSub uu___5 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - e1::e2::_e3::[]) - when - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.Monotonic.Buffer.msub") || - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.ConstBuffer.sub") - -> - let uu___5 = - let uu___6 = translate_expr env1 e1 in - let uu___7 = translate_expr env1 e2 in (uu___6, uu___7) in - EBufSub uu___5 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - e1::e2::[]) - when - let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "FStar.Buffer.join" -> translate_expr env1 e1 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - e1::e2::[]) - when - let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "FStar.Buffer.offset" -> - let uu___5 = - let uu___6 = translate_expr env1 e1 in - let uu___7 = translate_expr env1 e2 in (uu___6, uu___7) in - EBufSub uu___5 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - e1::e2::[]) - when - let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.Monotonic.Buffer.moffset" -> - let uu___5 = - let uu___6 = translate_expr env1 e1 in - let uu___7 = translate_expr env1 e2 in (uu___6, uu___7) in - EBufSub uu___5 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - e1::e2::e3::[]) - when - (((let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "FStar.Buffer.upd") || - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "FStar.Buffer.op_Array_Assignment")) - || - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.Monotonic.Buffer.upd'")) - || - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.UninitializedBuffer.uupd") - -> - let uu___5 = - let uu___6 = translate_expr env1 e1 in - let uu___7 = translate_expr env1 e2 in - let uu___8 = translate_expr env1 e3 in (uu___6, uu___7, uu___8) in - EBufWrite uu___5 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - e1::e2::[]) - when - let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "FStar.HyperStack.ST.op_Colon_Equals" -> - let uu___5 = - let uu___6 = translate_expr env1 e1 in - let uu___7 = translate_expr env1 e2 in - (uu___6, (EQualified (["C"], "_zero_for_deref")), uu___7) in - EBufWrite uu___5 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2::[]) - when - (let uu___3 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___3 = "FStar.HyperStack.ST.push_frame") || false - -> EPushFrame - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2::[]) - when - let uu___3 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___3 = "FStar.HyperStack.ST.pop_frame" -> EPopFrame - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - e1::e2::e3::e4::e5::[]) - when - ((let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "FStar.Buffer.blit") || - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.Monotonic.Buffer.blit")) - || - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.UninitializedBuffer.ublit") - -> - let uu___5 = - let uu___6 = translate_expr env1 e1 in - let uu___7 = translate_expr env1 e2 in - let uu___8 = translate_expr env1 e3 in - let uu___9 = translate_expr env1 e4 in - let uu___10 = translate_expr env1 e5 in - (uu___6, uu___7, uu___8, uu___9, uu___10) in - EBufBlit uu___5 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - e1::e2::e3::[]) - when - let s = FStar_Extraction_ML_Syntax.string_of_mlpath p in - (s = "FStar.Buffer.fill") || (s = "LowStar.Monotonic.Buffer.fill") - -> - let uu___5 = - let uu___6 = translate_expr env1 e1 in - let uu___7 = translate_expr env1 e2 in - let uu___8 = translate_expr env1 e3 in (uu___6, uu___7, uu___8) in - EBufFill uu___5 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2::[]) - when - let uu___3 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___3 = "FStar.HyperStack.ST.get" -> EUnit - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - _rid::[]) - when - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "FStar.HyperStack.ST.free_drgn") || - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "FStar.HyperStack.ST.new_drgn") - -> EUnit - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - _ebuf::_eseq::[]) - when - (((let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.Monotonic.Buffer.witness_p") || - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.Monotonic.Buffer.recall_p")) - || - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.ImmutableBuffer.witness_contents")) - || - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.ImmutableBuffer.recall_contents") - -> EUnit - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - e1::[]) - when - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.ConstBuffer.of_buffer") || - (let uu___5 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___5 = "LowStar.ConstBuffer.of_ibuffer") - -> translate_expr env1 e1 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - t::[]); - FStar_Extraction_ML_Syntax.mlty = uu___2; - FStar_Extraction_ML_Syntax.loc = uu___3;_}, - _eqal::e1::[]) - when - let uu___4 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___4 = "LowStar.ConstBuffer.of_qbuf" -> - let uu___4 = - let uu___5 = translate_expr env1 e1 in - let uu___6 = - let uu___7 = translate_type env1 t in TConstBuf uu___7 in - (uu___5, uu___6) in - ECast uu___4 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - t::[]); - FStar_Extraction_ML_Syntax.mlty = uu___2; - FStar_Extraction_ML_Syntax.loc = uu___3;_}, - e1::[]) - when - ((let uu___4 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___4 = "LowStar.ConstBuffer.cast") || - (let uu___4 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___4 = "LowStar.ConstBuffer.to_buffer")) - || - (let uu___4 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___4 = "LowStar.ConstBuffer.to_ibuffer") - -> - let uu___4 = - let uu___5 = translate_expr env1 e1 in - let uu___6 = let uu___7 = translate_type env1 t in TBuf uu___7 in - (uu___5, uu___6) in - ECast uu___4 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - e1::[]) - when - let uu___2 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___2 = "Obj.repr" -> - let uu___2 = let uu___3 = translate_expr env1 e1 in (uu___3, TAny) in - ECast uu___2 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name ("FStar"::m::[], op1); - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - args) - when (is_machine_int m) && (is_op op1) -> - let uu___2 = FStar_Compiler_Util.must (mk_width m) in - let uu___3 = FStar_Compiler_Util.must (mk_op op1) in - mk_op_app env1 uu___2 uu___3 args - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name ("Prims"::[], op1); - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - args) - when is_bool_op op1 -> - let uu___2 = FStar_Compiler_Util.must (mk_bool_op op1) in - mk_op_app env1 Bool uu___2 args - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name - ("FStar"::m::[], "int_to_t"); - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - { - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Const - (FStar_Extraction_ML_Syntax.MLC_Int - (c, FStar_Pervasives_Native.None)); - FStar_Extraction_ML_Syntax.mlty = uu___2; - FStar_Extraction_ML_Syntax.loc = uu___3;_}::[]) - when is_machine_int m -> - let uu___4 = - let uu___5 = FStar_Compiler_Util.must (mk_width m) in (uu___5, c) in - EConstant uu___4 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name - ("FStar"::m::[], "uint_to_t"); - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - { - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Const - (FStar_Extraction_ML_Syntax.MLC_Int - (c, FStar_Pervasives_Native.None)); - FStar_Extraction_ML_Syntax.mlty = uu___2; - FStar_Extraction_ML_Syntax.loc = uu___3;_}::[]) - when is_machine_int m -> - let uu___4 = - let uu___5 = FStar_Compiler_Util.must (mk_width m) in (uu___5, c) in - EConstant uu___4 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name - ("C"::[], "string_of_literal"); - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - { FStar_Extraction_ML_Syntax.expr = e1; - FStar_Extraction_ML_Syntax.mlty = uu___2; - FStar_Extraction_ML_Syntax.loc = uu___3;_}::[]) - -> - (match e1 with - | FStar_Extraction_ML_Syntax.MLE_Const - (FStar_Extraction_ML_Syntax.MLC_String s) -> EString s - | uu___4 -> - failwith - "Cannot extract string_of_literal applied to a non-literal") - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name - ("C"::"Compat"::"String"::[], "of_literal"); - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - { FStar_Extraction_ML_Syntax.expr = e1; - FStar_Extraction_ML_Syntax.mlty = uu___2; - FStar_Extraction_ML_Syntax.loc = uu___3;_}::[]) - -> - (match e1 with - | FStar_Extraction_ML_Syntax.MLE_Const - (FStar_Extraction_ML_Syntax.MLC_String s) -> EString s - | uu___4 -> - failwith - "Cannot extract string_of_literal applied to a non-literal") - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name - ("C"::"String"::[], "of_literal"); - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - { FStar_Extraction_ML_Syntax.expr = e1; - FStar_Extraction_ML_Syntax.mlty = uu___2; - FStar_Extraction_ML_Syntax.loc = uu___3;_}::[]) - -> - (match e1 with - | FStar_Extraction_ML_Syntax.MLE_Const - (FStar_Extraction_ML_Syntax.MLC_String s) -> EString s - | uu___4 -> - failwith - "Cannot extract string_of_literal applied to a non-literal") - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - { FStar_Extraction_ML_Syntax.expr = ebefore; - FStar_Extraction_ML_Syntax.mlty = uu___5; - FStar_Extraction_ML_Syntax.loc = uu___6;_}::e1::{ - FStar_Extraction_ML_Syntax.expr - = eafter; - FStar_Extraction_ML_Syntax.mlty - = uu___7; - FStar_Extraction_ML_Syntax.loc - = uu___8;_}::[]) - when - let uu___9 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___9 = "LowStar.Comment.comment_gen" -> - (match (ebefore, eafter) with - | (FStar_Extraction_ML_Syntax.MLE_Const - (FStar_Extraction_ML_Syntax.MLC_String sbefore), - FStar_Extraction_ML_Syntax.MLE_Const - (FStar_Extraction_ML_Syntax.MLC_String safter)) -> - (if FStar_Compiler_Util.contains sbefore "*/" - then failwith "Before Comment contains end-of-comment marker" - else (); - if FStar_Compiler_Util.contains safter "*/" - then failwith "After Comment contains end-of-comment marker" - else (); - (let uu___11 = - let uu___12 = translate_expr env1 e1 in - (sbefore, uu___12, safter) in - EComment uu___11)) - | uu___9 -> - failwith "Cannot extract comment applied to a non-literal") - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - { FStar_Extraction_ML_Syntax.expr = e1; - FStar_Extraction_ML_Syntax.mlty = uu___2; - FStar_Extraction_ML_Syntax.loc = uu___3;_}::[]) - when - let uu___4 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___4 = "LowStar.Comment.comment" -> - (match e1 with - | FStar_Extraction_ML_Syntax.MLE_Const - (FStar_Extraction_ML_Syntax.MLC_String s) -> - (if FStar_Compiler_Util.contains s "*/" - then - failwith - "Standalone Comment contains end-of-comment marker" - else (); - EStandaloneComment s) - | uu___4 -> - failwith "Cannot extract comment applied to a non-literal") - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name - ("LowStar"::"Literal"::[], "buffer_of_literal"); - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - { FStar_Extraction_ML_Syntax.expr = e1; - FStar_Extraction_ML_Syntax.mlty = uu___2; - FStar_Extraction_ML_Syntax.loc = uu___3;_}::[]) - -> - (match e1 with - | FStar_Extraction_ML_Syntax.MLE_Const - (FStar_Extraction_ML_Syntax.MLC_String s) -> - ECast ((EString s), (TBuf (TInt UInt8))) - | uu___4 -> - failwith - "Cannot extract buffer_of_literal applied to a non-literal") - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name - ("FStar"::"Int"::"Cast"::[], c); - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - arg::[]) - -> - let is_known_type = - (((((((FStar_Compiler_Util.starts_with c "uint8") || - (FStar_Compiler_Util.starts_with c "uint16")) - || (FStar_Compiler_Util.starts_with c "uint32")) - || (FStar_Compiler_Util.starts_with c "uint64")) - || (FStar_Compiler_Util.starts_with c "int8")) - || (FStar_Compiler_Util.starts_with c "int16")) - || (FStar_Compiler_Util.starts_with c "int32")) - || (FStar_Compiler_Util.starts_with c "int64") in - if (FStar_Compiler_Util.ends_with c "uint64") && is_known_type - then - let uu___2 = - let uu___3 = translate_expr env1 arg in (uu___3, (TInt UInt64)) in - ECast uu___2 - else - if (FStar_Compiler_Util.ends_with c "uint32") && is_known_type - then - (let uu___3 = - let uu___4 = translate_expr env1 arg in - (uu___4, (TInt UInt32)) in - ECast uu___3) - else - if (FStar_Compiler_Util.ends_with c "uint16") && is_known_type - then - (let uu___4 = - let uu___5 = translate_expr env1 arg in - (uu___5, (TInt UInt16)) in - ECast uu___4) - else - if (FStar_Compiler_Util.ends_with c "uint8") && is_known_type - then - (let uu___5 = - let uu___6 = translate_expr env1 arg in - (uu___6, (TInt UInt8)) in - ECast uu___5) - else - if - (FStar_Compiler_Util.ends_with c "int64") && - is_known_type - then - (let uu___6 = - let uu___7 = translate_expr env1 arg in - (uu___7, (TInt Int64)) in - ECast uu___6) - else - if - (FStar_Compiler_Util.ends_with c "int32") && - is_known_type - then - (let uu___7 = - let uu___8 = translate_expr env1 arg in - (uu___8, (TInt Int32)) in - ECast uu___7) - else - if - (FStar_Compiler_Util.ends_with c "int16") && - is_known_type - then - (let uu___8 = - let uu___9 = translate_expr env1 arg in - (uu___9, (TInt Int16)) in - ECast uu___8) - else - if - (FStar_Compiler_Util.ends_with c "int8") && - is_known_type - then - (let uu___9 = - let uu___10 = translate_expr env1 arg in - (uu___10, (TInt Int8)) in - ECast uu___9) - else - (let uu___10 = - let uu___11 = - let uu___12 = translate_expr env1 arg in - [uu___12] in - ((EQualified (["FStar"; "Int"; "Cast"], c)), - uu___11) in - EApp uu___10) - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - arg::[]) - when - (((let uu___2 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___2 = "FStar.SizeT.uint16_to_sizet") || - (let uu___2 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___2 = "FStar.SizeT.uint32_to_sizet")) - || - (let uu___2 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___2 = "FStar.SizeT.uint64_to_sizet")) - || - (let uu___2 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___2 = "FStar.PtrdiffT.ptrdifft_to_sizet") - -> - let uu___2 = - let uu___3 = translate_expr env1 arg in (uu___3, (TInt SizeT)) in - ECast uu___2 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - arg::[]) - when - let uu___2 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___2 = "FStar.SizeT.sizet_to_uint32" -> - let uu___2 = - let uu___3 = translate_expr env1 arg in (uu___3, (TInt UInt32)) in - ECast uu___2 - | FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - arg::[]) - when - let uu___2 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___2 = "FStar.SizeT.sizet_to_uint64" -> - let uu___2 = - let uu___3 = translate_expr env1 arg in (uu___3, (TInt UInt64)) in - ECast uu___2 - | FStar_Extraction_ML_Syntax.MLE_App (head, args) -> - let uu___ = - let uu___1 = translate_expr env1 head in - let uu___2 = FStar_Compiler_List.map (translate_expr env1) args in - (uu___1, uu___2) in - EApp uu___ - | FStar_Extraction_ML_Syntax.MLE_TApp (head, ty_args) -> - let uu___ = - let uu___1 = translate_expr env1 head in - let uu___2 = - FStar_Compiler_List.map (translate_type env1) ty_args in - (uu___1, uu___2) in - ETypApp uu___ - | FStar_Extraction_ML_Syntax.MLE_Coerce (e1, t_from, t_to) -> - let uu___ = - let uu___1 = translate_expr env1 e1 in - let uu___2 = translate_type env1 t_to in (uu___1, uu___2) in - ECast uu___ - | FStar_Extraction_ML_Syntax.MLE_Record (uu___, uu___1, fields) -> - let uu___2 = - let uu___3 = assert_lid env1 e.FStar_Extraction_ML_Syntax.mlty in - let uu___4 = - FStar_Compiler_List.map - (fun uu___5 -> - match uu___5 with - | (field, expr1) -> - let uu___6 = translate_expr env1 expr1 in - (field, uu___6)) fields in - (uu___3, uu___4) in - EFlat uu___2 - | FStar_Extraction_ML_Syntax.MLE_Proj (e1, path) -> - let uu___ = - let uu___1 = assert_lid env1 e1.FStar_Extraction_ML_Syntax.mlty in - let uu___2 = translate_expr env1 e1 in - (uu___1, uu___2, (FStar_Pervasives_Native.snd path)) in - EField uu___ - | FStar_Extraction_ML_Syntax.MLE_Let uu___ -> - let uu___1 = - let uu___2 = FStar_Extraction_ML_Code.string_of_mlexpr ([], "") e in - FStar_Compiler_Util.format1 - "todo: translate_expr [MLE_Let] (expr is: %s)" uu___2 in - failwith uu___1 - | FStar_Extraction_ML_Syntax.MLE_App (head, uu___) -> - let uu___1 = - let uu___2 = - FStar_Extraction_ML_Code.string_of_mlexpr ([], "") head in - FStar_Compiler_Util.format1 - "todo: translate_expr [MLE_App] (head is: %s)" uu___2 in - failwith uu___1 - | FStar_Extraction_ML_Syntax.MLE_Seq seqs -> - let uu___ = FStar_Compiler_List.map (translate_expr env1) seqs in - ESequence uu___ - | FStar_Extraction_ML_Syntax.MLE_Tuple es -> - let uu___ = FStar_Compiler_List.map (translate_expr env1) es in - ETuple uu___ - | FStar_Extraction_ML_Syntax.MLE_CTor ((uu___, cons), es) -> - let uu___1 = - let uu___2 = assert_lid env1 e.FStar_Extraction_ML_Syntax.mlty in - let uu___3 = FStar_Compiler_List.map (translate_expr env1) es in - (uu___2, cons, uu___3) in - ECons uu___1 - | FStar_Extraction_ML_Syntax.MLE_Fun (bs, body) -> - let binders = translate_binders env1 bs in - let env2 = add_binders env1 bs in - let uu___ = - let uu___1 = translate_expr env2 body in - let uu___2 = - translate_type env2 body.FStar_Extraction_ML_Syntax.mlty in - (binders, uu___1, uu___2) in - EFun uu___ - | FStar_Extraction_ML_Syntax.MLE_If (e1, e2, e3) -> - let uu___ = - let uu___1 = translate_expr env1 e1 in - let uu___2 = translate_expr env1 e2 in - let uu___3 = - match e3 with - | FStar_Pervasives_Native.None -> EUnit - | FStar_Pervasives_Native.Some e31 -> translate_expr env1 e31 in - (uu___1, uu___2, uu___3) in - EIfThenElse uu___ - | FStar_Extraction_ML_Syntax.MLE_Raise uu___ -> - failwith "todo: translate_expr [MLE_Raise]" - | FStar_Extraction_ML_Syntax.MLE_Try uu___ -> - failwith "todo: translate_expr [MLE_Try]" - | FStar_Extraction_ML_Syntax.MLE_Coerce uu___ -> - failwith "todo: translate_expr [MLE_Coerce]" -and (assert_lid : env -> FStar_Extraction_ML_Syntax.mlty -> typ) = - fun env1 -> - fun t -> - match t with - | FStar_Extraction_ML_Syntax.MLTY_Named (ts, lid) -> - if (FStar_Compiler_List.length ts) > Prims.int_zero - then - let uu___ = - let uu___1 = FStar_Compiler_List.map (translate_type env1) ts in - (lid, uu___1) in - TApp uu___ - else TQualified lid - | uu___ -> - let uu___1 = - let uu___2 = FStar_Extraction_ML_Code.string_of_mlty ([], "") t in - FStar_Compiler_Util.format1 - "invalid argument: expected MLTY_Named, got %s" uu___2 in - failwith uu___1 -and (translate_branches : - env -> - (FStar_Extraction_ML_Syntax.mlpattern * FStar_Extraction_ML_Syntax.mlexpr - FStar_Pervasives_Native.option * FStar_Extraction_ML_Syntax.mlexpr) - Prims.list -> (pattern * expr) Prims.list) - = - fun env1 -> - fun branches1 -> - FStar_Compiler_List.map (translate_branch env1) branches1 -and (translate_branch : - env -> - (FStar_Extraction_ML_Syntax.mlpattern * FStar_Extraction_ML_Syntax.mlexpr - FStar_Pervasives_Native.option * FStar_Extraction_ML_Syntax.mlexpr) -> - (pattern * expr)) - = - fun env1 -> - fun uu___ -> - match uu___ with - | (pat, guard, expr1) -> - if guard = FStar_Pervasives_Native.None - then - let uu___1 = translate_pat env1 pat in - (match uu___1 with - | (env2, pat1) -> - let uu___2 = translate_expr env2 expr1 in (pat1, uu___2)) - else failwith "todo: translate_branch" -and (translate_width : - (FStar_Const.signedness * FStar_Const.width) FStar_Pervasives_Native.option - -> width) - = - fun uu___ -> - match uu___ with - | FStar_Pervasives_Native.None -> CInt - | FStar_Pervasives_Native.Some (FStar_Const.Signed, FStar_Const.Int8) -> - Int8 - | FStar_Pervasives_Native.Some (FStar_Const.Signed, FStar_Const.Int16) -> - Int16 - | FStar_Pervasives_Native.Some (FStar_Const.Signed, FStar_Const.Int32) -> - Int32 - | FStar_Pervasives_Native.Some (FStar_Const.Signed, FStar_Const.Int64) -> - Int64 - | FStar_Pervasives_Native.Some (FStar_Const.Unsigned, FStar_Const.Int8) - -> UInt8 - | FStar_Pervasives_Native.Some (FStar_Const.Unsigned, FStar_Const.Int16) - -> UInt16 - | FStar_Pervasives_Native.Some (FStar_Const.Unsigned, FStar_Const.Int32) - -> UInt32 - | FStar_Pervasives_Native.Some (FStar_Const.Unsigned, FStar_Const.Int64) - -> UInt64 - | FStar_Pervasives_Native.Some (FStar_Const.Unsigned, FStar_Const.Sizet) - -> SizeT -and (translate_pat : - env -> FStar_Extraction_ML_Syntax.mlpattern -> (env * pattern)) = - fun env1 -> - fun p -> - match p with - | FStar_Extraction_ML_Syntax.MLP_Const - (FStar_Extraction_ML_Syntax.MLC_Unit) -> (env1, PUnit) - | FStar_Extraction_ML_Syntax.MLP_Const - (FStar_Extraction_ML_Syntax.MLC_Bool b) -> (env1, (PBool b)) - | FStar_Extraction_ML_Syntax.MLP_Const - (FStar_Extraction_ML_Syntax.MLC_Int (s, sw)) -> - let uu___ = - let uu___1 = let uu___2 = translate_width sw in (uu___2, s) in - PConstant uu___1 in - (env1, uu___) - | FStar_Extraction_ML_Syntax.MLP_Var name1 -> - let env2 = extend env1 name1 in - (env2, (PVar { name = name1; typ = TAny; mut = false; meta = [] })) - | FStar_Extraction_ML_Syntax.MLP_Wild -> - let env2 = extend env1 "_" in - (env2, (PVar { name = "_"; typ = TAny; mut = false; meta = [] })) - | FStar_Extraction_ML_Syntax.MLP_CTor ((uu___, cons), ps) -> - let uu___1 = - FStar_Compiler_List.fold_left - (fun uu___2 -> - fun p1 -> - match uu___2 with - | (env2, acc) -> - let uu___3 = translate_pat env2 p1 in - (match uu___3 with | (env3, p2) -> (env3, (p2 :: acc)))) - (env1, []) ps in - (match uu___1 with - | (env2, ps1) -> - (env2, (PCons (cons, (FStar_Compiler_List.rev ps1))))) - | FStar_Extraction_ML_Syntax.MLP_Record (uu___, ps) -> - let uu___1 = - FStar_Compiler_List.fold_left - (fun uu___2 -> - fun uu___3 -> - match (uu___2, uu___3) with - | ((env2, acc), (field, p1)) -> - let uu___4 = translate_pat env2 p1 in - (match uu___4 with - | (env3, p2) -> (env3, ((field, p2) :: acc)))) - (env1, []) ps in - (match uu___1 with - | (env2, ps1) -> (env2, (PRecord (FStar_Compiler_List.rev ps1)))) - | FStar_Extraction_ML_Syntax.MLP_Tuple ps -> - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun p1 -> - match uu___1 with - | (env2, acc) -> - let uu___2 = translate_pat env2 p1 in - (match uu___2 with | (env3, p2) -> (env3, (p2 :: acc)))) - (env1, []) ps in - (match uu___ with - | (env2, ps1) -> (env2, (PTuple (FStar_Compiler_List.rev ps1)))) - | FStar_Extraction_ML_Syntax.MLP_Const uu___ -> - failwith "todo: translate_pat [MLP_Const]" - | FStar_Extraction_ML_Syntax.MLP_Branch uu___ -> - failwith "todo: translate_pat [MLP_Branch]" -and (translate_constant : FStar_Extraction_ML_Syntax.mlconstant -> expr) = - fun c -> - match c with - | FStar_Extraction_ML_Syntax.MLC_Unit -> EUnit - | FStar_Extraction_ML_Syntax.MLC_Bool b -> EBool b - | FStar_Extraction_ML_Syntax.MLC_String s -> - ((let uu___1 = - FStar_Compiler_Util.for_some - (fun c1 -> c1 = (FStar_Char.char_of_int Prims.int_zero)) - (FStar_String.list_of_string s) in - if uu___1 - then - let uu___2 = - FStar_Compiler_Util.format1 - "Refusing to translate a string literal that contains a null character: %s" - s in - failwith uu___2 - else ()); - EString s) - | FStar_Extraction_ML_Syntax.MLC_Char c1 -> - let i = FStar_Compiler_Util.int_of_char c1 in - let s = FStar_Compiler_Util.string_of_int i in - let c2 = EConstant (CInt, s) in - let char_of_int = EQualified (["FStar"; "Char"], "char_of_int") in - EApp (char_of_int, [c2]) - | FStar_Extraction_ML_Syntax.MLC_Int - (s, FStar_Pervasives_Native.Some (sg, wd)) -> - let uu___ = - let uu___1 = - translate_width (FStar_Pervasives_Native.Some (sg, wd)) in - (uu___1, s) in - EConstant uu___ - | FStar_Extraction_ML_Syntax.MLC_Float uu___ -> - failwith "todo: translate_expr [MLC_Float]" - | FStar_Extraction_ML_Syntax.MLC_Bytes uu___ -> - failwith "todo: translate_expr [MLC_Bytes]" - | FStar_Extraction_ML_Syntax.MLC_Int (s, FStar_Pervasives_Native.None) -> - EConstant (CInt, s) -and (mk_op_app : - env -> width -> op -> FStar_Extraction_ML_Syntax.mlexpr Prims.list -> expr) - = - fun env1 -> - fun w -> - fun op1 -> - fun args -> - let uu___ = - let uu___1 = FStar_Compiler_List.map (translate_expr env1) args in - ((EOp (op1, w)), uu___1) in - EApp uu___ -let (translate_type_decl' : - env -> - FStar_Extraction_ML_Syntax.one_mltydecl -> - decl FStar_Pervasives_Native.option) - = - fun env1 -> - fun ty -> - match ty with - | { FStar_Extraction_ML_Syntax.tydecl_assumed = assumed; - FStar_Extraction_ML_Syntax.tydecl_name = name1; - FStar_Extraction_ML_Syntax.tydecl_ignored = uu___; - FStar_Extraction_ML_Syntax.tydecl_parameters = args; - FStar_Extraction_ML_Syntax.tydecl_meta = flags; - FStar_Extraction_ML_Syntax.tydecl_defn = - FStar_Pervasives_Native.Some - (FStar_Extraction_ML_Syntax.MLTD_Abbrev t);_} - -> - let name2 = ((env1.module_name), name1) in - let env2 = - FStar_Compiler_List.fold_left - (fun env3 -> - fun uu___1 -> - match uu___1 with - | { - FStar_Extraction_ML_Syntax.ty_param_name = - ty_param_name; - FStar_Extraction_ML_Syntax.ty_param_attrs = uu___2;_} - -> extend_t env3 ty_param_name) env1 args in - if - assumed && - (FStar_Compiler_List.mem FStar_Extraction_ML_Syntax.CAbstract - flags) - then FStar_Pervasives_Native.Some (DTypeAbstractStruct name2) - else - if assumed - then - (let name3 = FStar_Extraction_ML_Syntax.string_of_mlpath name2 in - FStar_Compiler_Util.print1_warning - "Not extracting type definition %s to KaRaMeL (assumed type)\n" - name3; - FStar_Pervasives_Native.None) - else - (let uu___3 = - let uu___4 = - let uu___5 = translate_flags flags in - let uu___6 = translate_type env2 t in - (name2, uu___5, (FStar_Compiler_List.length args), uu___6) in - DTypeAlias uu___4 in - FStar_Pervasives_Native.Some uu___3) - | { FStar_Extraction_ML_Syntax.tydecl_assumed = uu___; - FStar_Extraction_ML_Syntax.tydecl_name = name1; - FStar_Extraction_ML_Syntax.tydecl_ignored = uu___1; - FStar_Extraction_ML_Syntax.tydecl_parameters = args; - FStar_Extraction_ML_Syntax.tydecl_meta = flags; - FStar_Extraction_ML_Syntax.tydecl_defn = - FStar_Pervasives_Native.Some - (FStar_Extraction_ML_Syntax.MLTD_Record fields);_} - -> - let name2 = ((env1.module_name), name1) in - let env2 = - FStar_Compiler_List.fold_left - (fun env3 -> - fun uu___2 -> - match uu___2 with - | { - FStar_Extraction_ML_Syntax.ty_param_name = - ty_param_name; - FStar_Extraction_ML_Syntax.ty_param_attrs = uu___3;_} - -> extend_t env3 ty_param_name) env1 args in - let uu___2 = - let uu___3 = - let uu___4 = translate_flags flags in - let uu___5 = - FStar_Compiler_List.map - (fun uu___6 -> - match uu___6 with - | (f, t) -> - let uu___7 = - let uu___8 = translate_type_without_decay env2 t in - (uu___8, false) in - (f, uu___7)) fields in - (name2, uu___4, (FStar_Compiler_List.length args), uu___5) in - DTypeFlat uu___3 in - FStar_Pervasives_Native.Some uu___2 - | { FStar_Extraction_ML_Syntax.tydecl_assumed = uu___; - FStar_Extraction_ML_Syntax.tydecl_name = name1; - FStar_Extraction_ML_Syntax.tydecl_ignored = uu___1; - FStar_Extraction_ML_Syntax.tydecl_parameters = args; - FStar_Extraction_ML_Syntax.tydecl_meta = flags; - FStar_Extraction_ML_Syntax.tydecl_defn = - FStar_Pervasives_Native.Some - (FStar_Extraction_ML_Syntax.MLTD_DType branches1);_} - -> - let name2 = ((env1.module_name), name1) in - let flags1 = translate_flags flags in - let env2 = - let uu___2 = FStar_Extraction_ML_Syntax.ty_param_names args in - FStar_Compiler_List.fold_left extend_t env1 uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Compiler_List.map - (fun uu___5 -> - match uu___5 with - | (cons, ts) -> - let uu___6 = - FStar_Compiler_List.map - (fun uu___7 -> - match uu___7 with - | (name3, t) -> - let uu___8 = - let uu___9 = - translate_type_without_decay env2 t in - (uu___9, false) in - (name3, uu___8)) ts in - (cons, uu___6)) branches1 in - (name2, flags1, (FStar_Compiler_List.length args), uu___4) in - DTypeVariant uu___3 in - FStar_Pervasives_Native.Some uu___2 - | { FStar_Extraction_ML_Syntax.tydecl_assumed = uu___; - FStar_Extraction_ML_Syntax.tydecl_name = name1; - FStar_Extraction_ML_Syntax.tydecl_ignored = uu___1; - FStar_Extraction_ML_Syntax.tydecl_parameters = uu___2; - FStar_Extraction_ML_Syntax.tydecl_meta = uu___3; - FStar_Extraction_ML_Syntax.tydecl_defn = uu___4;_} -> - ((let uu___6 = - let uu___7 = - let uu___8 = - FStar_Compiler_Util.format1 - "Error extracting type definition %s to KaRaMeL." name1 in - FStar_Errors_Msg.text uu___8 in - [uu___7] in - FStar_Errors.log_issue0 - FStar_Errors_Codes.Warning_DefinitionNotTranslated () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___6)); - FStar_Pervasives_Native.None) -let (translate_let' : - env -> - FStar_Extraction_ML_Syntax.mlletflavor -> - FStar_Extraction_ML_Syntax.mllb -> decl FStar_Pervasives_Native.option) - = - fun env1 -> - fun flavor -> - fun lb -> - match lb with - | { FStar_Extraction_ML_Syntax.mllb_name = name1; - FStar_Extraction_ML_Syntax.mllb_tysc = - FStar_Pervasives_Native.Some (tvars, t0); - FStar_Extraction_ML_Syntax.mllb_add_unit = uu___; - FStar_Extraction_ML_Syntax.mllb_def = e; - FStar_Extraction_ML_Syntax.mllb_attrs = uu___1; - FStar_Extraction_ML_Syntax.mllb_meta = meta; - FStar_Extraction_ML_Syntax.print_typ = uu___2;_} when - FStar_Compiler_Util.for_some - (fun uu___3 -> - match uu___3 with - | FStar_Extraction_ML_Syntax.Assumed -> true - | uu___4 -> false) meta - -> - let name2 = ((env1.module_name), name1) in - let arg_names = - match e.FStar_Extraction_ML_Syntax.expr with - | FStar_Extraction_ML_Syntax.MLE_Fun (bs, uu___3) -> - FStar_Compiler_List.map - (fun uu___4 -> - match uu___4 with - | { - FStar_Extraction_ML_Syntax.mlbinder_name = - mlbinder_name; - FStar_Extraction_ML_Syntax.mlbinder_ty = uu___5; - FStar_Extraction_ML_Syntax.mlbinder_attrs = uu___6;_} - -> mlbinder_name) bs - | uu___3 -> [] in - if (FStar_Compiler_List.length tvars) = Prims.int_zero - then - let uu___3 = - let uu___4 = - let uu___5 = translate_cc meta in - let uu___6 = translate_flags meta in - let uu___7 = translate_type env1 t0 in - (uu___5, uu___6, name2, uu___7, arg_names) in - DExternal uu___4 in - FStar_Pervasives_Native.Some uu___3 - else - ((let uu___5 = - FStar_Extraction_ML_Syntax.string_of_mlpath name2 in - FStar_Compiler_Util.print1_warning - "Not extracting %s to KaRaMeL (polymorphic assumes are not supported)\n" - uu___5); - FStar_Pervasives_Native.None) - | { FStar_Extraction_ML_Syntax.mllb_name = name1; - FStar_Extraction_ML_Syntax.mllb_tysc = - FStar_Pervasives_Native.Some (tvars, t0); - FStar_Extraction_ML_Syntax.mllb_add_unit = uu___; - FStar_Extraction_ML_Syntax.mllb_def = - { - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Fun (args, body); - FStar_Extraction_ML_Syntax.mlty = uu___1; - FStar_Extraction_ML_Syntax.loc = uu___2;_}; - FStar_Extraction_ML_Syntax.mllb_attrs = uu___3; - FStar_Extraction_ML_Syntax.mllb_meta = meta; - FStar_Extraction_ML_Syntax.print_typ = uu___4;_} -> - if - FStar_Compiler_List.mem FStar_Extraction_ML_Syntax.NoExtract - meta - then FStar_Pervasives_Native.None - else - (let env2 = - if flavor = FStar_Extraction_ML_Syntax.Rec - then extend env1 name1 - else env1 in - let env3 = - let uu___6 = FStar_Extraction_ML_Syntax.ty_param_names tvars in - FStar_Compiler_List.fold_left - (fun env4 -> fun name2 -> extend_t env4 name2) env2 uu___6 in - let rec find_return_type eff i uu___6 = - match uu___6 with - | FStar_Extraction_ML_Syntax.MLTY_Fun (uu___7, eff1, t) when - i > Prims.int_zero -> - find_return_type eff1 (i - Prims.int_one) t - | t -> (i, eff, t) in - let name2 = ((env3.module_name), name1) in - let uu___6 = - find_return_type FStar_Extraction_ML_Syntax.E_PURE - (FStar_Compiler_List.length args) t0 in - match uu___6 with - | (i, eff, t) -> - (if i > Prims.int_zero - then - (let msg = - "function type annotation has less arrows than the number of arguments; please mark the return type abbreviation as inline_for_extraction" in - let uu___8 = - FStar_Extraction_ML_Syntax.string_of_mlpath name2 in - FStar_Compiler_Util.print2_warning - "Not extracting %s to KaRaMeL (%s)\n" uu___8 msg) - else (); - (let t1 = translate_type env3 t in - let binders = translate_binders env3 args in - let env4 = add_binders env3 args in - let cc1 = translate_cc meta in - let meta1 = - match (eff, t1) with - | (FStar_Extraction_ML_Syntax.E_ERASABLE, uu___8) -> - let uu___9 = translate_flags meta in MustDisappear - :: uu___9 - | (FStar_Extraction_ML_Syntax.E_PURE, TUnit) -> - let uu___8 = translate_flags meta in MustDisappear - :: uu___8 - | uu___8 -> translate_flags meta in - try - (fun uu___8 -> - match () with - | () -> - let body1 = translate_expr env4 body in - FStar_Pervasives_Native.Some - (DFunction - (cc1, meta1, - (FStar_Compiler_List.length tvars), t1, - name2, binders, body1))) () - with - | uu___8 -> - let msg = FStar_Compiler_Util.print_exn uu___8 in - ((let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Extraction_ML_Syntax.string_of_mlpath - name2 in - FStar_Compiler_Util.format1 - "Error while extracting %s to KaRaMeL." - uu___13 in - FStar_Errors_Msg.text uu___12 in - let uu___12 = - let uu___13 = - FStar_Pprint.arbitrary_string msg in - [uu___13] in - uu___11 :: uu___12 in - FStar_Errors.log_issue0 - FStar_Errors_Codes.Warning_FunctionNotExtacted - () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___10)); - (let msg1 = - Prims.strcat - "This function was not extracted:\n" msg in - FStar_Pervasives_Native.Some - (DFunction - (cc1, meta1, - (FStar_Compiler_List.length tvars), t1, - name2, binders, (EAbortS msg1)))))))) - | { FStar_Extraction_ML_Syntax.mllb_name = name1; - FStar_Extraction_ML_Syntax.mllb_tysc = - FStar_Pervasives_Native.Some (tvars, t); - FStar_Extraction_ML_Syntax.mllb_add_unit = uu___; - FStar_Extraction_ML_Syntax.mllb_def = expr1; - FStar_Extraction_ML_Syntax.mllb_attrs = uu___1; - FStar_Extraction_ML_Syntax.mllb_meta = meta; - FStar_Extraction_ML_Syntax.print_typ = uu___2;_} -> - if - FStar_Compiler_List.mem FStar_Extraction_ML_Syntax.NoExtract - meta - then FStar_Pervasives_Native.None - else - (let meta1 = translate_flags meta in - let env2 = - let uu___4 = FStar_Extraction_ML_Syntax.ty_param_names tvars in - FStar_Compiler_List.fold_left - (fun env3 -> fun name2 -> extend_t env3 name2) env1 uu___4 in - let t1 = translate_type env2 t in - let name2 = ((env2.module_name), name1) in - try - (fun uu___4 -> - match () with - | () -> - let expr2 = translate_expr env2 expr1 in - FStar_Pervasives_Native.Some - (DGlobal - (meta1, name2, - (FStar_Compiler_List.length tvars), t1, expr2))) - () - with - | uu___4 -> - ((let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Extraction_ML_Syntax.string_of_mlpath - name2 in - FStar_Compiler_Util.format1 - "Error extracting %s to KaRaMeL." uu___9 in - FStar_Errors_Msg.text uu___8 in - let uu___8 = - let uu___9 = - let uu___10 = FStar_Compiler_Util.print_exn uu___4 in - FStar_Pprint.arbitrary_string uu___10 in - [uu___9] in - uu___7 :: uu___8 in - FStar_Errors.log_issue0 - FStar_Errors_Codes.Warning_DefinitionNotTranslated () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___6)); - FStar_Pervasives_Native.Some - (DGlobal - (meta1, name2, (FStar_Compiler_List.length tvars), - t1, EAny)))) - | { FStar_Extraction_ML_Syntax.mllb_name = name1; - FStar_Extraction_ML_Syntax.mllb_tysc = ts; - FStar_Extraction_ML_Syntax.mllb_add_unit = uu___; - FStar_Extraction_ML_Syntax.mllb_def = uu___1; - FStar_Extraction_ML_Syntax.mllb_attrs = uu___2; - FStar_Extraction_ML_Syntax.mllb_meta = uu___3; - FStar_Extraction_ML_Syntax.print_typ = uu___4;_} -> - ((let uu___6 = - FStar_Compiler_Util.format1 "Not extracting %s to KaRaMeL\n" - name1 in - FStar_Errors.log_issue0 - FStar_Errors_Codes.Warning_DefinitionNotTranslated () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___6)); - (match ts with - | FStar_Pervasives_Native.Some (tps, t) -> - let uu___7 = - let uu___8 = - FStar_Extraction_ML_Syntax.ty_param_names tps in - FStar_Compiler_String.concat ", " uu___8 in - let uu___8 = - FStar_Extraction_ML_Code.string_of_mlty ([], "") t in - FStar_Compiler_Util.print2 - "Type scheme is: forall %s. %s\n" uu___7 uu___8 - | FStar_Pervasives_Native.None -> ()); - FStar_Pervasives_Native.None) -type translate_let_t = - env -> - FStar_Extraction_ML_Syntax.mlletflavor -> - FStar_Extraction_ML_Syntax.mllb -> decl FStar_Pervasives_Native.option -let (ref_translate_let : translate_let_t FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref translate_let' -let (register_pre_translate_let : translate_let_t -> unit) = - fun f -> - let before = FStar_Compiler_Effect.op_Bang ref_translate_let in - let after e fl lb = - try (fun uu___ -> match () with | () -> f e fl lb) () - with | NotSupportedByKrmlExtension -> before e fl lb in - FStar_Compiler_Effect.op_Colon_Equals ref_translate_let after -let (translate_let : - env -> - FStar_Extraction_ML_Syntax.mlletflavor -> - FStar_Extraction_ML_Syntax.mllb -> decl FStar_Pervasives_Native.option) - = - fun env1 -> - fun flavor -> - fun lb -> - let uu___ = FStar_Compiler_Effect.op_Bang ref_translate_let in - uu___ env1 flavor lb -let (translate_decl : - env -> FStar_Extraction_ML_Syntax.mlmodule1 -> decl Prims.list) = - fun env1 -> - fun d -> - match d.FStar_Extraction_ML_Syntax.mlmodule1_m with - | FStar_Extraction_ML_Syntax.MLM_Let (flavor, lbs) -> - FStar_Compiler_List.choose (translate_let env1 flavor) lbs - | FStar_Extraction_ML_Syntax.MLM_Loc uu___ -> [] - | FStar_Extraction_ML_Syntax.MLM_Ty tys -> - FStar_Compiler_List.choose (translate_type_decl env1) tys - | FStar_Extraction_ML_Syntax.MLM_Top uu___ -> - failwith "todo: translate_decl [MLM_Top]" - | FStar_Extraction_ML_Syntax.MLM_Exn (m, uu___) -> - (FStar_Compiler_Util.print1_warning - "Not extracting exception %s to KaRaMeL (exceptions unsupported)\n" - m; - []) -let (translate_module : - FStar_Extraction_ML_UEnv.uenv -> - (FStar_Extraction_ML_Syntax.mlpath * (FStar_Extraction_ML_Syntax.mlsig * - FStar_Extraction_ML_Syntax.mlmodule) FStar_Pervasives_Native.option * - FStar_Extraction_ML_Syntax.mllib) -> file) - = - fun uenv -> - fun m -> - let uu___ = m in - match uu___ with - | (module_name, modul, uu___1) -> - let module_name1 = - FStar_Compiler_List.op_At - (FStar_Pervasives_Native.fst module_name) - [FStar_Pervasives_Native.snd module_name] in - let program1 = - match modul with - | FStar_Pervasives_Native.Some (_signature, decls) -> - FStar_Compiler_List.collect - (translate_decl (empty uenv module_name1)) decls - | uu___2 -> - failwith "Unexpected standalone interface or nested modules" in - ((FStar_Compiler_String.concat "_" module_name1), program1) -let (translate : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Extraction_ML_Syntax.mllib -> file Prims.list) - = - fun ue -> - fun uu___ -> - match uu___ with - | FStar_Extraction_ML_Syntax.MLLib modules -> - FStar_Compiler_List.filter_map - (fun m -> - let m_name = - let uu___1 = m in - match uu___1 with - | (path, uu___2, uu___3) -> - FStar_Extraction_ML_Syntax.string_of_mlpath path in - try - (fun uu___1 -> - match () with - | () -> - ((let uu___3 = - let uu___4 = FStar_Options.silent () in - Prims.op_Negation uu___4 in - if uu___3 - then - FStar_Compiler_Util.print1 - "Attempting to translate module %s\n" m_name - else ()); - (let uu___3 = translate_module ue m in - FStar_Pervasives_Native.Some uu___3))) () - with - | uu___1 -> - ((let uu___3 = FStar_Compiler_Util.print_exn uu___1 in - FStar_Compiler_Util.print2 - "Unable to translate module: %s because:\n %s\n" - m_name uu___3); - FStar_Pervasives_Native.None)) modules -let (uu___0 : unit) = - register_post_translate_type_without_decay translate_type_without_decay'; - register_post_translate_type translate_type'; - register_post_translate_type_decl translate_type_decl'; - register_post_translate_expr translate_expr' \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Extraction_ML_Code.ml b/ocaml/fstar-lib/generated/FStar_Extraction_ML_Code.ml deleted file mode 100644 index 7790ec8110e..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Extraction_ML_Code.ml +++ /dev/null @@ -1,1443 +0,0 @@ -open Prims -type doc = - | Doc of Prims.string -let (uu___is_Doc : doc -> Prims.bool) = fun projectee -> true -let (__proj__Doc__item___0 : doc -> Prims.string) = - fun projectee -> match projectee with | Doc _0 -> _0 -type assoc = - | ILeft - | IRight - | Left - | Right - | NonAssoc -let (uu___is_ILeft : assoc -> Prims.bool) = - fun projectee -> match projectee with | ILeft -> true | uu___ -> false -let (uu___is_IRight : assoc -> Prims.bool) = - fun projectee -> match projectee with | IRight -> true | uu___ -> false -let (uu___is_Left : assoc -> Prims.bool) = - fun projectee -> match projectee with | Left -> true | uu___ -> false -let (uu___is_Right : assoc -> Prims.bool) = - fun projectee -> match projectee with | Right -> true | uu___ -> false -let (uu___is_NonAssoc : assoc -> Prims.bool) = - fun projectee -> match projectee with | NonAssoc -> true | uu___ -> false -type fixity = - | Prefix - | Postfix - | Infix of assoc -let (uu___is_Prefix : fixity -> Prims.bool) = - fun projectee -> match projectee with | Prefix -> true | uu___ -> false -let (uu___is_Postfix : fixity -> Prims.bool) = - fun projectee -> match projectee with | Postfix -> true | uu___ -> false -let (uu___is_Infix : fixity -> Prims.bool) = - fun projectee -> match projectee with | Infix _0 -> true | uu___ -> false -let (__proj__Infix__item___0 : fixity -> assoc) = - fun projectee -> match projectee with | Infix _0 -> _0 -type opprec = (Prims.int * fixity) -type level = (opprec * assoc) -let (t_prio_fun : (Prims.int * fixity)) = - ((Prims.of_int (10)), (Infix Right)) -let (t_prio_tpl : (Prims.int * fixity)) = - ((Prims.of_int (20)), (Infix NonAssoc)) -let (t_prio_name : (Prims.int * fixity)) = ((Prims.of_int (30)), Postfix) -let (e_bin_prio_lambda : (Prims.int * fixity)) = ((Prims.of_int (5)), Prefix) -let (e_bin_prio_if : (Prims.int * fixity)) = ((Prims.of_int (15)), Prefix) -let (e_bin_prio_letin : (Prims.int * fixity)) = ((Prims.of_int (19)), Prefix) -let (e_bin_prio_or : (Prims.int * fixity)) = - ((Prims.of_int (20)), (Infix Left)) -let (e_bin_prio_and : (Prims.int * fixity)) = - ((Prims.of_int (25)), (Infix Left)) -let (e_bin_prio_eq : (Prims.int * fixity)) = - ((Prims.of_int (27)), (Infix NonAssoc)) -let (e_bin_prio_order : (Prims.int * fixity)) = - ((Prims.of_int (29)), (Infix NonAssoc)) -let (e_bin_prio_op1 : (Prims.int * fixity)) = - ((Prims.of_int (30)), (Infix Left)) -let (e_bin_prio_op2 : (Prims.int * fixity)) = - ((Prims.of_int (40)), (Infix Left)) -let (e_bin_prio_op3 : (Prims.int * fixity)) = - ((Prims.of_int (50)), (Infix Left)) -let (e_bin_prio_op4 : (Prims.int * fixity)) = - ((Prims.of_int (60)), (Infix Left)) -let (e_bin_prio_comb : (Prims.int * fixity)) = - ((Prims.of_int (70)), (Infix Left)) -let (e_bin_prio_seq : (Prims.int * fixity)) = - ((Prims.of_int (100)), (Infix Left)) -let (e_app_prio : (Prims.int * fixity)) = - ((Prims.of_int (10000)), (Infix Left)) -let (min_op_prec : (Prims.int * fixity)) = - ((Prims.of_int (-1)), (Infix NonAssoc)) -let (max_op_prec : (Prims.int * fixity)) = - (FStar_Compiler_Util.max_int, (Infix NonAssoc)) -let (empty : doc) = Doc "" -let (hardline : doc) = Doc "\n" -let (text : Prims.string -> doc) = fun s -> Doc s -let (num : Prims.int -> doc) = - fun i -> let uu___ = FStar_Compiler_Util.string_of_int i in Doc uu___ -let (break1 : doc) = text " " -let (enclose : doc -> doc -> doc -> doc) = - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - match (uu___, uu___1, uu___2) with - | (Doc l, Doc r, Doc x) -> Doc (Prims.strcat l (Prims.strcat x r)) -let (cbrackets : doc -> doc) = - fun uu___ -> - match uu___ with | Doc d -> enclose (text "{") (text "}") (Doc d) -let (parens : doc -> doc) = - fun uu___ -> - match uu___ with | Doc d -> enclose (text "(") (text ")") (Doc d) -let (cat : doc -> doc -> doc) = - fun uu___ -> - fun uu___1 -> - match (uu___, uu___1) with - | (Doc d1, Doc d2) -> Doc (Prims.strcat d1 d2) -let (reduce : doc Prims.list -> doc) = - fun docs -> FStar_Compiler_List.fold_left cat empty docs -let (combine : doc -> doc Prims.list -> doc) = - fun uu___ -> - fun docs -> - match uu___ with - | Doc sep -> - let select uu___1 = - match uu___1 with - | Doc d -> - if d = "" - then FStar_Pervasives_Native.None - else FStar_Pervasives_Native.Some d in - let docs1 = FStar_Compiler_List.choose select docs in - Doc (FStar_Compiler_String.concat sep docs1) -let (reduce1 : doc Prims.list -> doc) = fun docs -> combine break1 docs -let (hbox : doc -> doc) = fun d -> d -let rec in_ns : 'a . ('a Prims.list * 'a Prims.list) -> Prims.bool = - fun x -> - match x with - | ([], uu___) -> true - | (x1::t1, x2::t2) when x1 = x2 -> in_ns (t1, t2) - | (uu___, uu___1) -> false -let (path_of_ns : - FStar_Extraction_ML_Syntax.mlsymbol -> - Prims.string Prims.list -> Prims.string Prims.list) - = - fun currentModule -> - fun ns -> - let ns' = FStar_Extraction_ML_Util.flatten_ns ns in - if ns' = currentModule - then [] - else - (let cg_libs = FStar_Options.codegen_libs () in - let ns_len = FStar_Compiler_List.length ns in - let found = - FStar_Compiler_Util.find_map cg_libs - (fun cg_path -> - let cg_len = FStar_Compiler_List.length cg_path in - if (FStar_Compiler_List.length cg_path) < ns_len - then - let uu___1 = FStar_Compiler_Util.first_N cg_len ns in - match uu___1 with - | (pfx, sfx) -> - (if pfx = cg_path - then - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Extraction_ML_Util.flatten_ns sfx in - [uu___4] in - FStar_Compiler_List.op_At pfx uu___3 in - FStar_Pervasives_Native.Some uu___2 - else FStar_Pervasives_Native.None) - else FStar_Pervasives_Native.None) in - match found with - | FStar_Pervasives_Native.None -> [ns'] - | FStar_Pervasives_Native.Some x -> x) -let (mlpath_of_mlpath : - FStar_Extraction_ML_Syntax.mlsymbol -> - FStar_Extraction_ML_Syntax.mlpath -> FStar_Extraction_ML_Syntax.mlpath) - = - fun currentModule -> - fun x -> - let uu___ = FStar_Extraction_ML_Syntax.string_of_mlpath x in - match uu___ with - | "Prims.Some" -> ([], "Some") - | "Prims.None" -> ([], "None") - | uu___1 -> - let uu___2 = x in - (match uu___2 with - | (ns, x1) -> - let uu___3 = path_of_ns currentModule ns in (uu___3, x1)) -let (ptsym_of_symbol : - FStar_Extraction_ML_Syntax.mlsymbol -> FStar_Extraction_ML_Syntax.mlsymbol) - = - fun s -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Compiler_String.get s Prims.int_zero in - FStar_Char.lowercase uu___2 in - let uu___2 = FStar_Compiler_String.get s Prims.int_zero in - uu___1 <> uu___2 in - if uu___ then Prims.strcat "l__" s else s -let (ptsym : - FStar_Extraction_ML_Syntax.mlsymbol -> - FStar_Extraction_ML_Syntax.mlpath -> FStar_Extraction_ML_Syntax.mlsymbol) - = - fun currentModule -> - fun mlp -> - if FStar_Compiler_List.isEmpty (FStar_Pervasives_Native.fst mlp) - then ptsym_of_symbol (FStar_Pervasives_Native.snd mlp) - else - (let uu___1 = mlpath_of_mlpath currentModule mlp in - match uu___1 with - | (p, s) -> - let uu___2 = - let uu___3 = let uu___4 = ptsym_of_symbol s in [uu___4] in - FStar_Compiler_List.op_At p uu___3 in - FStar_Compiler_String.concat "." uu___2) -let (ptctor : - FStar_Extraction_ML_Syntax.mlsymbol -> - FStar_Extraction_ML_Syntax.mlpath -> FStar_Extraction_ML_Syntax.mlsymbol) - = - fun currentModule -> - fun mlp -> - let uu___ = mlpath_of_mlpath currentModule mlp in - match uu___ with - | (p, s) -> - let s1 = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Compiler_String.get s Prims.int_zero in - FStar_Char.uppercase uu___3 in - let uu___3 = FStar_Compiler_String.get s Prims.int_zero in - uu___2 <> uu___3 in - if uu___1 then Prims.strcat "U__" s else s in - FStar_Compiler_String.concat "." (FStar_Compiler_List.op_At p [s1]) -let (infix_prim_ops : - (Prims.string * (Prims.int * fixity) * Prims.string) Prims.list) = - [("op_Addition", e_bin_prio_op1, "+"); - ("op_Subtraction", e_bin_prio_op1, "-"); - ("op_Multiply", e_bin_prio_op1, "*"); - ("op_Division", e_bin_prio_op1, "/"); - ("op_Equality", e_bin_prio_eq, "="); - ("op_Colon_Equals", e_bin_prio_eq, ":="); - ("op_disEquality", e_bin_prio_eq, "<>"); - ("op_AmpAmp", e_bin_prio_and, "&&"); - ("op_BarBar", e_bin_prio_or, "||"); - ("op_LessThanOrEqual", e_bin_prio_order, "<="); - ("op_GreaterThanOrEqual", e_bin_prio_order, ">="); - ("op_LessThan", e_bin_prio_order, "<"); - ("op_GreaterThan", e_bin_prio_order, ">"); - ("op_Modulus", e_bin_prio_order, "mod")] -let (prim_uni_ops : unit -> (Prims.string * Prims.string) Prims.list) = - fun uu___ -> - let op_minus = - let uu___1 = FStar_Extraction_ML_Util.codegen_fsharp () in - if uu___1 then "-" else "~-" in - [("op_Negation", "not"); - ("op_Minus", op_minus); - ("op_Bang", "Support.ST.read")] -let prim_types : 'uuuuu . unit -> 'uuuuu Prims.list = fun uu___ -> [] -let (prim_constructors : (Prims.string * Prims.string) Prims.list) = - [("Some", "Some"); ("None", "None"); ("Nil", "[]"); ("Cons", "::")] -let (is_prims_ns : - FStar_Extraction_ML_Syntax.mlsymbol Prims.list -> Prims.bool) = - fun ns -> ns = ["Prims"] -let (as_bin_op : - FStar_Extraction_ML_Syntax.mlpath -> - (FStar_Extraction_ML_Syntax.mlsymbol * (Prims.int * fixity) * - Prims.string) FStar_Pervasives_Native.option) - = - fun uu___ -> - match uu___ with - | (ns, x) -> - if is_prims_ns ns - then - FStar_Compiler_List.tryFind - (fun uu___1 -> match uu___1 with | (y, uu___2, uu___3) -> x = y) - infix_prim_ops - else FStar_Pervasives_Native.None -let (is_bin_op : FStar_Extraction_ML_Syntax.mlpath -> Prims.bool) = - fun p -> let uu___ = as_bin_op p in uu___ <> FStar_Pervasives_Native.None -let (as_uni_op : - FStar_Extraction_ML_Syntax.mlpath -> - (FStar_Extraction_ML_Syntax.mlsymbol * Prims.string) - FStar_Pervasives_Native.option) - = - fun uu___ -> - match uu___ with - | (ns, x) -> - if is_prims_ns ns - then - let uu___1 = prim_uni_ops () in - FStar_Compiler_List.tryFind - (fun uu___2 -> match uu___2 with | (y, uu___3) -> x = y) uu___1 - else FStar_Pervasives_Native.None -let (is_uni_op : FStar_Extraction_ML_Syntax.mlpath -> Prims.bool) = - fun p -> let uu___ = as_uni_op p in uu___ <> FStar_Pervasives_Native.None -let (is_standard_type : FStar_Extraction_ML_Syntax.mlpath -> Prims.bool) = - fun p -> false -let (as_standard_constructor : - FStar_Extraction_ML_Syntax.mlpath -> - (FStar_Extraction_ML_Syntax.mlsymbol * Prims.string) - FStar_Pervasives_Native.option) - = - fun uu___ -> - match uu___ with - | (ns, x) -> - if is_prims_ns ns - then - FStar_Compiler_List.tryFind - (fun uu___1 -> match uu___1 with | (y, uu___2) -> x = y) - prim_constructors - else FStar_Pervasives_Native.None -let (is_standard_constructor : - FStar_Extraction_ML_Syntax.mlpath -> Prims.bool) = - fun p -> - let uu___ = as_standard_constructor p in - uu___ <> FStar_Pervasives_Native.None -let (maybe_paren : - ((Prims.int * fixity) * assoc) -> (Prims.int * fixity) -> doc -> doc) = - fun uu___ -> - fun inner -> - fun doc1 -> - match uu___ with - | (outer, side) -> - let noparens _inner _outer side1 = - let uu___1 = _inner in - match uu___1 with - | (pi, fi) -> - let uu___2 = _outer in - (match uu___2 with - | (po, fo) -> - (pi > po) || - ((match (fi, side1) with - | (Postfix, Left) -> true - | (Prefix, Right) -> true - | (Infix (Left), Left) -> - (pi = po) && (fo = (Infix Left)) - | (Infix (Right), Right) -> - (pi = po) && (fo = (Infix Right)) - | (Infix (Left), ILeft) -> - (pi = po) && (fo = (Infix Left)) - | (Infix (Right), IRight) -> - (pi = po) && (fo = (Infix Right)) - | (uu___3, NonAssoc) -> (pi = po) && (fi = fo) - | (uu___3, uu___4) -> false))) in - if noparens inner outer side then doc1 else parens doc1 -let (escape_byte_hex : FStar_BaseTypes.byte -> Prims.string) = - fun x -> Prims.strcat "\\x" (FStar_Compiler_Util.hex_string_of_byte x) -let (escape_char_hex : FStar_BaseTypes.char -> Prims.string) = - fun x -> escape_byte_hex (FStar_Compiler_Util.byte_of_char x) -let (escape_or : - (FStar_BaseTypes.char -> Prims.string) -> - FStar_BaseTypes.char -> Prims.string) - = - fun fallback -> - fun uu___ -> - if uu___ = 92 - then "\\\\" - else - if uu___ = 32 - then " " - else - if uu___ = 8 - then "\\b" - else - if uu___ = 9 - then "\\t" - else - if uu___ = 13 - then "\\r" - else - if uu___ = 10 - then "\\n" - else - if uu___ = 39 - then "\\'" - else - if uu___ = 34 - then "\\\"" - else - if FStar_Compiler_Util.is_letter_or_digit uu___ - then FStar_Compiler_Util.string_of_char uu___ - else - if FStar_Compiler_Util.is_punctuation uu___ - then FStar_Compiler_Util.string_of_char uu___ - else - if FStar_Compiler_Util.is_symbol uu___ - then FStar_Compiler_Util.string_of_char uu___ - else fallback uu___ -let (string_of_mlconstant : - FStar_Extraction_ML_Syntax.mlconstant -> Prims.string) = - fun sctt -> - match sctt with - | FStar_Extraction_ML_Syntax.MLC_Unit -> "()" - | FStar_Extraction_ML_Syntax.MLC_Bool (true) -> "true" - | FStar_Extraction_ML_Syntax.MLC_Bool (false) -> "false" - | FStar_Extraction_ML_Syntax.MLC_Char c -> - let uu___ = FStar_Extraction_ML_Util.codegen_fsharp () in - if uu___ - then - Prims.strcat "'" - (Prims.strcat (FStar_Compiler_Util.string_of_char c) "'") - else - (let nc = FStar_Char.int_of_char c in - let uu___2 = FStar_Compiler_Util.string_of_int nc in - Prims.strcat uu___2 - (if - ((nc >= (Prims.of_int (32))) && (nc = (Prims.of_int (127)))) - && (nc < (Prims.of_int (34))) - then - Prims.strcat " (*" - (Prims.strcat (FStar_Compiler_Util.string_of_char c) "*)") - else "")) - | FStar_Extraction_ML_Syntax.MLC_Int - (s, FStar_Pervasives_Native.Some - (FStar_Const.Signed, FStar_Const.Int32)) - -> Prims.strcat s "l" - | FStar_Extraction_ML_Syntax.MLC_Int - (s, FStar_Pervasives_Native.Some - (FStar_Const.Signed, FStar_Const.Int64)) - -> Prims.strcat s "L" - | FStar_Extraction_ML_Syntax.MLC_Int - (s, FStar_Pervasives_Native.Some (uu___, FStar_Const.Int8)) -> s - | FStar_Extraction_ML_Syntax.MLC_Int - (s, FStar_Pervasives_Native.Some (uu___, FStar_Const.Int16)) -> s - | FStar_Extraction_ML_Syntax.MLC_Int - (v, FStar_Pervasives_Native.Some (uu___, FStar_Const.Sizet)) -> - let z = Prims.strcat "(Prims.parse_int \"" (Prims.strcat v "\")") in - Prims.strcat "(FStar_SizeT.uint_to_t (" (Prims.strcat z "))") - | FStar_Extraction_ML_Syntax.MLC_Int - (v, FStar_Pervasives_Native.Some (s, w)) -> - let sign = - match s with - | FStar_Const.Signed -> "Int" - | FStar_Const.Unsigned -> "UInt" in - let ws = - match w with - | FStar_Const.Int8 -> "8" - | FStar_Const.Int16 -> "16" - | FStar_Const.Int32 -> "32" - | FStar_Const.Int64 -> "64" in - let z = Prims.strcat "(Prims.parse_int \"" (Prims.strcat v "\")") in - let u = - match s with - | FStar_Const.Signed -> "" - | FStar_Const.Unsigned -> "u" in - Prims.strcat "(FStar_" - (Prims.strcat sign - (Prims.strcat ws - (Prims.strcat "." - (Prims.strcat u - (Prims.strcat "int_to_t (" (Prims.strcat z "))")))))) - | FStar_Extraction_ML_Syntax.MLC_Int (s, FStar_Pervasives_Native.None) -> - Prims.strcat "(Prims.parse_int \"" (Prims.strcat s "\")") - | FStar_Extraction_ML_Syntax.MLC_Float d -> - FStar_Compiler_Util.string_of_float d - | FStar_Extraction_ML_Syntax.MLC_Bytes bytes -> - let uu___ = - let uu___1 = FStar_Compiler_Bytes.f_encode escape_byte_hex bytes in - Prims.strcat uu___1 "\"" in - Prims.strcat "\"" uu___ - | FStar_Extraction_ML_Syntax.MLC_String chars -> - let uu___ = - let uu___1 = - FStar_Compiler_String.collect - (escape_or FStar_Compiler_Util.string_of_char) chars in - Prims.strcat uu___1 "\"" in - Prims.strcat "\"" uu___ - | uu___ -> failwith "TODO: extract integer constants properly into OCaml" -let (string_of_etag : FStar_Extraction_ML_Syntax.e_tag -> Prims.string) = - fun uu___ -> - match uu___ with - | FStar_Extraction_ML_Syntax.E_PURE -> "" - | FStar_Extraction_ML_Syntax.E_ERASABLE -> "Erased" - | FStar_Extraction_ML_Syntax.E_IMPURE -> "Impure" -let rec (doc_of_mltype' : - FStar_Extraction_ML_Syntax.mlsymbol -> - level -> FStar_Extraction_ML_Syntax.mlty -> doc) - = - fun currentModule -> - fun outer -> - fun ty -> - match ty with - | FStar_Extraction_ML_Syntax.MLTY_Var x -> - let escape_tyvar s = - if FStar_Compiler_Util.starts_with s "'_" - then FStar_Compiler_Util.replace_char s 95 117 - else s in - text (escape_tyvar x) - | FStar_Extraction_ML_Syntax.MLTY_Tuple tys -> - let doc1 = - FStar_Compiler_List.map - (doc_of_mltype currentModule (t_prio_tpl, Left)) tys in - let doc2 = - let uu___ = - let uu___1 = combine (text " * ") doc1 in hbox uu___1 in - parens uu___ in - doc2 - | FStar_Extraction_ML_Syntax.MLTY_Named (args, name) -> - let args1 = - match args with - | [] -> empty - | arg::[] -> - doc_of_mltype currentModule (t_prio_name, Left) arg - | uu___ -> - let args2 = - FStar_Compiler_List.map - (doc_of_mltype currentModule (min_op_prec, NonAssoc)) - args in - let uu___1 = - let uu___2 = combine (text ", ") args2 in hbox uu___2 in - parens uu___1 in - let name1 = ptsym currentModule name in - let uu___ = reduce1 [args1; text name1] in hbox uu___ - | FStar_Extraction_ML_Syntax.MLTY_Fun (t1, et, t2) -> - let d1 = doc_of_mltype currentModule (t_prio_fun, Left) t1 in - let d2 = doc_of_mltype currentModule (t_prio_fun, Right) t2 in - let uu___ = - let uu___1 = reduce1 [d1; text " -> "; d2] in hbox uu___1 in - maybe_paren outer t_prio_fun uu___ - | FStar_Extraction_ML_Syntax.MLTY_Top -> - let uu___ = FStar_Extraction_ML_Util.codegen_fsharp () in - if uu___ then text "obj" else text "Obj.t" - | FStar_Extraction_ML_Syntax.MLTY_Erased -> text "unit" -and (doc_of_mltype : - FStar_Extraction_ML_Syntax.mlsymbol -> - level -> FStar_Extraction_ML_Syntax.mlty -> doc) - = - fun currentModule -> - fun outer -> - fun ty -> - let uu___ = FStar_Extraction_ML_Util.resugar_mlty ty in - doc_of_mltype' currentModule outer uu___ -let rec (doc_of_expr : - FStar_Extraction_ML_Syntax.mlsymbol -> - level -> FStar_Extraction_ML_Syntax.mlexpr -> doc) - = - fun currentModule -> - fun outer -> - fun e -> - match e.FStar_Extraction_ML_Syntax.expr with - | FStar_Extraction_ML_Syntax.MLE_Coerce (e1, t, t') -> - let doc1 = doc_of_expr currentModule (min_op_prec, NonAssoc) e1 in - let uu___ = FStar_Extraction_ML_Util.codegen_fsharp () in - if uu___ - then - let uu___1 = reduce [text "Prims.unsafe_coerce "; doc1] in - parens uu___1 - else - (let uu___2 = reduce [text "Obj.magic "; parens doc1] in - parens uu___2) - | FStar_Extraction_ML_Syntax.MLE_Seq es -> - let docs = - FStar_Compiler_List.map - (doc_of_expr currentModule (min_op_prec, NonAssoc)) es in - let docs1 = - FStar_Compiler_List.map - (fun d -> reduce [d; text ";"; hardline]) docs in - let uu___ = reduce docs1 in parens uu___ - | FStar_Extraction_ML_Syntax.MLE_Const c -> - let uu___ = string_of_mlconstant c in text uu___ - | FStar_Extraction_ML_Syntax.MLE_Var x -> text x - | FStar_Extraction_ML_Syntax.MLE_Name path -> - let uu___ = ptsym currentModule path in text uu___ - | FStar_Extraction_ML_Syntax.MLE_Record (path, uu___, fields) -> - let for1 uu___1 = - match uu___1 with - | (name, e1) -> - let doc1 = - doc_of_expr currentModule (min_op_prec, NonAssoc) e1 in - let uu___2 = - let uu___3 = - let uu___4 = ptsym currentModule (path, name) in - text uu___4 in - [uu___3; text "="; doc1] in - reduce1 uu___2 in - let uu___1 = - let uu___2 = FStar_Compiler_List.map for1 fields in - combine (text "; ") uu___2 in - cbrackets uu___1 - | FStar_Extraction_ML_Syntax.MLE_CTor (ctor, []) -> - let name = - let uu___ = is_standard_constructor ctor in - if uu___ - then - let uu___1 = - let uu___2 = as_standard_constructor ctor in - FStar_Compiler_Option.get uu___2 in - FStar_Pervasives_Native.snd uu___1 - else ptctor currentModule ctor in - text name - | FStar_Extraction_ML_Syntax.MLE_CTor (ctor, args) -> - let name = - let uu___ = is_standard_constructor ctor in - if uu___ - then - let uu___1 = - let uu___2 = as_standard_constructor ctor in - FStar_Compiler_Option.get uu___2 in - FStar_Pervasives_Native.snd uu___1 - else ptctor currentModule ctor in - let args1 = - FStar_Compiler_List.map - (doc_of_expr currentModule (min_op_prec, NonAssoc)) args in - let doc1 = - match (name, args1) with - | ("::", x::xs::[]) -> reduce [parens x; text "::"; xs] - | (uu___, uu___1) -> - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = combine (text ", ") args1 in - parens uu___5 in - [uu___4] in - (text name) :: uu___3 in - reduce1 uu___2 in - maybe_paren outer e_app_prio doc1 - | FStar_Extraction_ML_Syntax.MLE_Tuple es -> - let docs = - FStar_Compiler_List.map - (fun x -> - let uu___ = - doc_of_expr currentModule (min_op_prec, NonAssoc) x in - parens uu___) es in - let docs1 = let uu___ = combine (text ", ") docs in parens uu___ in - docs1 - | FStar_Extraction_ML_Syntax.MLE_Let ((rec_, lets), body) -> - let pre = - if - e.FStar_Extraction_ML_Syntax.loc <> - FStar_Extraction_ML_Syntax.dummy_loc - then - let uu___ = - let uu___1 = - let uu___2 = doc_of_loc e.FStar_Extraction_ML_Syntax.loc in - [uu___2] in - hardline :: uu___1 in - reduce uu___ - else empty in - let doc1 = doc_of_lets currentModule (rec_, false, lets) in - let body1 = - doc_of_expr currentModule (min_op_prec, NonAssoc) body in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = reduce1 [text "in"; body1] in [uu___4] in - doc1 :: uu___3 in - pre :: uu___2 in - combine hardline uu___1 in - parens uu___ - | FStar_Extraction_ML_Syntax.MLE_App (e1, args) -> - (match ((e1.FStar_Extraction_ML_Syntax.expr), args) with - | (FStar_Extraction_ML_Syntax.MLE_Name p, - { - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Fun (uu___::[], scrutinee); - FStar_Extraction_ML_Syntax.mlty = uu___1; - FStar_Extraction_ML_Syntax.loc = uu___2;_}::{ - FStar_Extraction_ML_Syntax.expr - = - FStar_Extraction_ML_Syntax.MLE_Fun - ({ - FStar_Extraction_ML_Syntax.mlbinder_name - = arg; - FStar_Extraction_ML_Syntax.mlbinder_ty - = uu___3; - FStar_Extraction_ML_Syntax.mlbinder_attrs - = uu___4;_}::[], - possible_match); - FStar_Extraction_ML_Syntax.mlty - = uu___5; - FStar_Extraction_ML_Syntax.loc - = uu___6;_}::[]) - when - (let uu___7 = FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___7 = "FStar.Compiler.Effect.try_with") || - (let uu___7 = - FStar_Extraction_ML_Syntax.string_of_mlpath p in - uu___7 = "FStar.All.try_with") - -> - let branches = - match possible_match with - | { - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Match - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Var arg'; - FStar_Extraction_ML_Syntax.mlty = uu___7; - FStar_Extraction_ML_Syntax.loc = uu___8;_}, - branches1); - FStar_Extraction_ML_Syntax.mlty = uu___9; - FStar_Extraction_ML_Syntax.loc = uu___10;_} when - arg = arg' -> branches1 - | e2 -> - [(FStar_Extraction_ML_Syntax.MLP_Wild, - FStar_Pervasives_Native.None, e2)] in - doc_of_expr currentModule outer - { - FStar_Extraction_ML_Syntax.expr = - (FStar_Extraction_ML_Syntax.MLE_Try - (scrutinee, branches)); - FStar_Extraction_ML_Syntax.mlty = - (possible_match.FStar_Extraction_ML_Syntax.mlty); - FStar_Extraction_ML_Syntax.loc = - (possible_match.FStar_Extraction_ML_Syntax.loc) - } - | (FStar_Extraction_ML_Syntax.MLE_Name p, e11::e2::[]) when - is_bin_op p -> doc_of_binop currentModule p e11 e2 - | (FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - unitVal::[]), - e11::e2::[]) when - (is_bin_op p) && - (unitVal = FStar_Extraction_ML_Syntax.ml_unit) - -> doc_of_binop currentModule p e11 e2 - | (FStar_Extraction_ML_Syntax.MLE_Name p, e11::[]) when - is_uni_op p -> doc_of_uniop currentModule p e11 - | (FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name p; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - unitVal::[]), - e11::[]) when - (is_uni_op p) && - (unitVal = FStar_Extraction_ML_Syntax.ml_unit) - -> doc_of_uniop currentModule p e11 - | uu___ -> - let e2 = doc_of_expr currentModule (e_app_prio, ILeft) e1 in - let args1 = - FStar_Compiler_List.map - (doc_of_expr currentModule (e_app_prio, IRight)) args in - let uu___1 = reduce1 (e2 :: args1) in parens uu___1) - | FStar_Extraction_ML_Syntax.MLE_Proj (e1, f) -> - let e2 = doc_of_expr currentModule (min_op_prec, NonAssoc) e1 in - let doc1 = - let uu___ = FStar_Extraction_ML_Util.codegen_fsharp () in - if uu___ - then - reduce [e2; text "."; text (FStar_Pervasives_Native.snd f)] - else - (let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = ptsym currentModule f in text uu___6 in - [uu___5] in - (text ".") :: uu___4 in - e2 :: uu___3 in - reduce uu___2) in - doc1 - | FStar_Extraction_ML_Syntax.MLE_Fun (ids, body) -> - let bvar_annot x xt = - let uu___ = FStar_Extraction_ML_Util.codegen_fsharp () in - if uu___ - then - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - match xt with - | FStar_Pervasives_Native.Some xxt -> - let uu___5 = - let uu___6 = - let uu___7 = - doc_of_mltype currentModule outer xxt in - [uu___7] in - (text " : ") :: uu___6 in - reduce1 uu___5 - | uu___5 -> text "" in - [uu___4; text ")"] in - (text x) :: uu___3 in - (text "(") :: uu___2 in - reduce1 uu___1 - else text x in - let ids1 = - FStar_Compiler_List.map - (fun uu___ -> - match uu___ with - | { FStar_Extraction_ML_Syntax.mlbinder_name = x; - FStar_Extraction_ML_Syntax.mlbinder_ty = xt; - FStar_Extraction_ML_Syntax.mlbinder_attrs = uu___1;_} - -> bvar_annot x (FStar_Pervasives_Native.Some xt)) ids in - let body1 = - doc_of_expr currentModule (min_op_prec, NonAssoc) body in - let doc1 = - let uu___ = - let uu___1 = - let uu___2 = reduce1 ids1 in [uu___2; text "->"; body1] in - (text "fun") :: uu___1 in - reduce1 uu___ in - parens doc1 - | FStar_Extraction_ML_Syntax.MLE_If - (cond, e1, FStar_Pervasives_Native.None) -> - let cond1 = - doc_of_expr currentModule (min_op_prec, NonAssoc) cond in - let doc1 = - let uu___ = - let uu___1 = - reduce1 [text "if"; cond1; text "then"; text "begin"] in - let uu___2 = - let uu___3 = - doc_of_expr currentModule (min_op_prec, NonAssoc) e1 in - [uu___3; text "end"] in - uu___1 :: uu___2 in - combine hardline uu___ in - maybe_paren outer e_bin_prio_if doc1 - | FStar_Extraction_ML_Syntax.MLE_If - (cond, e1, FStar_Pervasives_Native.Some e2) -> - let cond1 = - doc_of_expr currentModule (min_op_prec, NonAssoc) cond in - let doc1 = - let uu___ = - let uu___1 = - reduce1 [text "if"; cond1; text "then"; text "begin"] in - let uu___2 = - let uu___3 = - doc_of_expr currentModule (min_op_prec, NonAssoc) e1 in - let uu___4 = - let uu___5 = - reduce1 [text "end"; text "else"; text "begin"] in - let uu___6 = - let uu___7 = - doc_of_expr currentModule (min_op_prec, NonAssoc) e2 in - [uu___7; text "end"] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - combine hardline uu___ in - maybe_paren outer e_bin_prio_if doc1 - | FStar_Extraction_ML_Syntax.MLE_Match (cond, pats) -> - let cond1 = - doc_of_expr currentModule (min_op_prec, NonAssoc) cond in - let pats1 = - FStar_Compiler_List.map (doc_of_branch currentModule) pats in - let doc1 = - let uu___ = reduce1 [text "match"; parens cond1; text "with"] in - uu___ :: pats1 in - let doc2 = combine hardline doc1 in parens doc2 - | FStar_Extraction_ML_Syntax.MLE_Raise (exn, []) -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = ptctor currentModule exn in text uu___3 in - [uu___2] in - (text "raise") :: uu___1 in - reduce1 uu___ - | FStar_Extraction_ML_Syntax.MLE_Raise (exn, args) -> - let args1 = - FStar_Compiler_List.map - (doc_of_expr currentModule (min_op_prec, NonAssoc)) args in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = ptctor currentModule exn in text uu___3 in - let uu___3 = - let uu___4 = - let uu___5 = combine (text ", ") args1 in parens uu___5 in - [uu___4] in - uu___2 :: uu___3 in - (text "raise") :: uu___1 in - reduce1 uu___ - | FStar_Extraction_ML_Syntax.MLE_Try (e1, pats) -> - let uu___ = - let uu___1 = - let uu___2 = - doc_of_expr currentModule (min_op_prec, NonAssoc) e1 in - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Compiler_List.map (doc_of_branch currentModule) - pats in - combine hardline uu___6 in - [uu___5] in - (text "with") :: uu___4 in - uu___2 :: uu___3 in - (text "try") :: uu___1 in - combine hardline uu___ - | FStar_Extraction_ML_Syntax.MLE_TApp (head, ty_args) -> - doc_of_expr currentModule outer head -and (doc_of_binop : - FStar_Extraction_ML_Syntax.mlsymbol -> - FStar_Extraction_ML_Syntax.mlpath -> - FStar_Extraction_ML_Syntax.mlexpr -> - FStar_Extraction_ML_Syntax.mlexpr -> doc) - = - fun currentModule -> - fun p -> - fun e1 -> - fun e2 -> - let uu___ = - let uu___1 = as_bin_op p in FStar_Compiler_Option.get uu___1 in - match uu___ with - | (uu___1, prio, txt) -> - let e11 = doc_of_expr currentModule (prio, Left) e1 in - let e21 = doc_of_expr currentModule (prio, Right) e2 in - let doc1 = reduce1 [e11; text txt; e21] in parens doc1 -and (doc_of_uniop : - FStar_Extraction_ML_Syntax.mlsymbol -> - FStar_Extraction_ML_Syntax.mlpath -> - FStar_Extraction_ML_Syntax.mlexpr -> doc) - = - fun currentModule -> - fun p -> - fun e1 -> - let uu___ = - let uu___1 = as_uni_op p in FStar_Compiler_Option.get uu___1 in - match uu___ with - | (uu___1, txt) -> - let e11 = doc_of_expr currentModule (min_op_prec, NonAssoc) e1 in - let doc1 = reduce1 [text txt; parens e11] in parens doc1 -and (doc_of_pattern : - FStar_Extraction_ML_Syntax.mlsymbol -> - FStar_Extraction_ML_Syntax.mlpattern -> doc) - = - fun currentModule -> - fun pattern -> - match pattern with - | FStar_Extraction_ML_Syntax.MLP_Wild -> text "_" - | FStar_Extraction_ML_Syntax.MLP_Const c -> - let uu___ = string_of_mlconstant c in text uu___ - | FStar_Extraction_ML_Syntax.MLP_Var x -> text x - | FStar_Extraction_ML_Syntax.MLP_Record (path, fields) -> - let for1 uu___ = - match uu___ with - | (name, p) -> - let uu___1 = - let uu___2 = - let uu___3 = ptsym currentModule (path, name) in - text uu___3 in - let uu___3 = - let uu___4 = - let uu___5 = doc_of_pattern currentModule p in [uu___5] in - (text "=") :: uu___4 in - uu___2 :: uu___3 in - reduce1 uu___1 in - let uu___ = - let uu___1 = FStar_Compiler_List.map for1 fields in - combine (text "; ") uu___1 in - cbrackets uu___ - | FStar_Extraction_ML_Syntax.MLP_CTor (ctor, []) -> - let name = - let uu___ = is_standard_constructor ctor in - if uu___ - then - let uu___1 = - let uu___2 = as_standard_constructor ctor in - FStar_Compiler_Option.get uu___2 in - FStar_Pervasives_Native.snd uu___1 - else ptctor currentModule ctor in - text name - | FStar_Extraction_ML_Syntax.MLP_CTor (ctor, pats) -> - let name = - let uu___ = is_standard_constructor ctor in - if uu___ - then - let uu___1 = - let uu___2 = as_standard_constructor ctor in - FStar_Compiler_Option.get uu___2 in - FStar_Pervasives_Native.snd uu___1 - else ptctor currentModule ctor in - let doc1 = - match (name, pats) with - | ("::", x::xs::[]) -> - let uu___ = - let uu___1 = - let uu___2 = doc_of_pattern currentModule x in - parens uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = doc_of_pattern currentModule xs in - [uu___4] in - (text "::") :: uu___3 in - uu___1 :: uu___2 in - reduce uu___ - | (uu___, (FStar_Extraction_ML_Syntax.MLP_Tuple uu___1)::[]) -> - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Compiler_List.hd pats in - doc_of_pattern currentModule uu___5 in - [uu___4] in - (text name) :: uu___3 in - reduce1 uu___2 - | uu___ -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Compiler_List.map - (doc_of_pattern currentModule) pats in - combine (text ", ") uu___5 in - parens uu___4 in - [uu___3] in - (text name) :: uu___2 in - reduce1 uu___1 in - maybe_paren (min_op_prec, NonAssoc) e_app_prio doc1 - | FStar_Extraction_ML_Syntax.MLP_Tuple ps -> - let ps1 = FStar_Compiler_List.map (doc_of_pattern currentModule) ps in - let uu___ = combine (text ", ") ps1 in parens uu___ - | FStar_Extraction_ML_Syntax.MLP_Branch ps -> - let ps1 = FStar_Compiler_List.map (doc_of_pattern currentModule) ps in - let ps2 = FStar_Compiler_List.map parens ps1 in - combine (text " | ") ps2 -and (doc_of_branch : - FStar_Extraction_ML_Syntax.mlsymbol -> - FStar_Extraction_ML_Syntax.mlbranch -> doc) - = - fun currentModule -> - fun uu___ -> - match uu___ with - | (p, cond, e) -> - let case = - match cond with - | FStar_Pervasives_Native.None -> - let uu___1 = - let uu___2 = - let uu___3 = doc_of_pattern currentModule p in [uu___3] in - (text "|") :: uu___2 in - reduce1 uu___1 - | FStar_Pervasives_Native.Some c -> - let c1 = doc_of_expr currentModule (min_op_prec, NonAssoc) c in - let uu___1 = - let uu___2 = - let uu___3 = doc_of_pattern currentModule p in - [uu___3; text "when"; c1] in - (text "|") :: uu___2 in - reduce1 uu___1 in - let uu___1 = - let uu___2 = reduce1 [case; text "->"; text "begin"] in - let uu___3 = - let uu___4 = - doc_of_expr currentModule (min_op_prec, NonAssoc) e in - [uu___4; text "end"] in - uu___2 :: uu___3 in - combine hardline uu___1 -and (doc_of_lets : - FStar_Extraction_ML_Syntax.mlsymbol -> - (FStar_Extraction_ML_Syntax.mlletflavor * Prims.bool * - FStar_Extraction_ML_Syntax.mllb Prims.list) -> doc) - = - fun currentModule -> - fun uu___ -> - match uu___ with - | (rec_, top_level, lets) -> - let for1 uu___1 = - match uu___1 with - | { FStar_Extraction_ML_Syntax.mllb_name = name; - FStar_Extraction_ML_Syntax.mllb_tysc = tys; - FStar_Extraction_ML_Syntax.mllb_add_unit = uu___2; - FStar_Extraction_ML_Syntax.mllb_def = e; - FStar_Extraction_ML_Syntax.mllb_attrs = uu___3; - FStar_Extraction_ML_Syntax.mllb_meta = uu___4; - FStar_Extraction_ML_Syntax.print_typ = pt;_} -> - let e1 = doc_of_expr currentModule (min_op_prec, NonAssoc) e in - let ids = [] in - let ty_annot = - if Prims.op_Negation pt - then text "" - else - (let uu___6 = - (FStar_Extraction_ML_Util.codegen_fsharp ()) && - ((rec_ = FStar_Extraction_ML_Syntax.Rec) || - top_level) in - if uu___6 - then - match tys with - | FStar_Pervasives_Native.Some - (uu___7::uu___8, uu___9) -> text "" - | FStar_Pervasives_Native.None -> text "" - | FStar_Pervasives_Native.Some ([], ty) -> - let ty1 = - doc_of_mltype currentModule - (min_op_prec, NonAssoc) ty in - reduce1 [text ":"; ty1] - else - if top_level - then - (match tys with - | FStar_Pervasives_Native.None -> text "" - | FStar_Pervasives_Native.Some ([], ty) -> - let ty1 = - doc_of_mltype currentModule - (min_op_prec, NonAssoc) ty in - reduce1 [text ":"; ty1] - | FStar_Pervasives_Native.Some (vs, ty) -> - let ty1 = - doc_of_mltype currentModule - (min_op_prec, NonAssoc) ty in - let vars = - let uu___8 = - let uu___9 = - FStar_Extraction_ML_Syntax.ty_param_names - vs in - FStar_Compiler_List.map - (fun x -> - doc_of_mltype currentModule - (min_op_prec, NonAssoc) - (FStar_Extraction_ML_Syntax.MLTY_Var - x)) uu___9 in - reduce1 uu___8 in - reduce1 [text ":"; vars; text "."; ty1]) - else text "") in - let uu___5 = - let uu___6 = - let uu___7 = reduce1 ids in - [uu___7; ty_annot; text "="; e1] in - (text name) :: uu___6 in - reduce1 uu___5 in - let letdoc = - if rec_ = FStar_Extraction_ML_Syntax.Rec - then reduce1 [text "let"; text "rec"] - else text "let" in - let lets1 = FStar_Compiler_List.map for1 lets in - let lets2 = - FStar_Compiler_List.mapi - (fun i -> - fun doc1 -> - reduce1 - [if i = Prims.int_zero then letdoc else text "and"; - doc1]) lets1 in - combine hardline lets2 -and (doc_of_loc : FStar_Extraction_ML_Syntax.mlloc -> doc) = - fun uu___ -> - match uu___ with - | (lineno, file) -> - let uu___1 = - ((FStar_Options.no_location_info ()) || - (FStar_Extraction_ML_Util.codegen_fsharp ())) - || (file = " dummy") in - if uu___1 - then empty - else - (let file1 = FStar_Compiler_Util.basename file in - let uu___3 = - let uu___4 = - let uu___5 = num lineno in - [uu___5; text (Prims.strcat "\"" (Prims.strcat file1 "\""))] in - (text "#") :: uu___4 in - reduce1 uu___3) -let (doc_of_mltydecl : - FStar_Extraction_ML_Syntax.mlsymbol -> - FStar_Extraction_ML_Syntax.mltydecl -> doc) - = - fun currentModule -> - fun decls -> - let for1 uu___ = - match uu___ with - | { FStar_Extraction_ML_Syntax.tydecl_assumed = uu___1; - FStar_Extraction_ML_Syntax.tydecl_name = x; - FStar_Extraction_ML_Syntax.tydecl_ignored = mangle_opt; - FStar_Extraction_ML_Syntax.tydecl_parameters = tparams; - FStar_Extraction_ML_Syntax.tydecl_meta = uu___2; - FStar_Extraction_ML_Syntax.tydecl_defn = body;_} -> - let x1 = - match mangle_opt with - | FStar_Pervasives_Native.None -> x - | FStar_Pervasives_Native.Some y -> y in - let tparams1 = - let tparams2 = - FStar_Extraction_ML_Syntax.ty_param_names tparams in - match tparams2 with - | [] -> empty - | x2::[] -> text x2 - | uu___3 -> - let doc1 = - FStar_Compiler_List.map (fun x2 -> text x2) tparams2 in - let uu___4 = combine (text ", ") doc1 in parens uu___4 in - let forbody body1 = - match body1 with - | FStar_Extraction_ML_Syntax.MLTD_Abbrev ty -> - doc_of_mltype currentModule (min_op_prec, NonAssoc) ty - | FStar_Extraction_ML_Syntax.MLTD_Record fields -> - let forfield uu___3 = - match uu___3 with - | (name, ty) -> - let name1 = text name in - let ty1 = - doc_of_mltype currentModule (min_op_prec, NonAssoc) - ty in - reduce1 [name1; text ":"; ty1] in - let uu___3 = - let uu___4 = FStar_Compiler_List.map forfield fields in - combine (text "; ") uu___4 in - cbrackets uu___3 - | FStar_Extraction_ML_Syntax.MLTD_DType ctors -> - let forctor uu___3 = - match uu___3 with - | (name, tys) -> - let uu___4 = FStar_Compiler_List.split tys in - (match uu___4 with - | (_names, tys1) -> - (match tys1 with - | [] -> text name - | uu___5 -> - let tys2 = - FStar_Compiler_List.map - (doc_of_mltype currentModule - (t_prio_tpl, Left)) tys1 in - let tys3 = combine (text " * ") tys2 in - reduce1 [text name; text "of"; tys3])) in - let ctors1 = FStar_Compiler_List.map forctor ctors in - let ctors2 = - FStar_Compiler_List.map (fun d -> reduce1 [text "|"; d]) - ctors1 in - combine hardline ctors2 in - let doc1 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = ptsym currentModule ([], x1) in text uu___6 in - [uu___5] in - tparams1 :: uu___4 in - reduce1 uu___3 in - (match body with - | FStar_Pervasives_Native.None -> doc1 - | FStar_Pervasives_Native.Some body1 -> - let body2 = forbody body1 in - let uu___3 = - let uu___4 = reduce1 [doc1; text "="] in [uu___4; body2] in - combine hardline uu___3) in - let doc1 = FStar_Compiler_List.map for1 decls in - let doc2 = - if (FStar_Compiler_List.length doc1) > Prims.int_zero - then - let uu___ = - let uu___1 = - let uu___2 = combine (text " \n and ") doc1 in [uu___2] in - (text "type") :: uu___1 in - reduce1 uu___ - else text "" in - doc2 -let rec (doc_of_sig1 : - FStar_Extraction_ML_Syntax.mlsymbol -> - FStar_Extraction_ML_Syntax.mlsig1 -> doc) - = - fun currentModule -> - fun s -> - match s with - | FStar_Extraction_ML_Syntax.MLS_Mod (x, subsig) -> - let uu___ = - let uu___1 = reduce1 [text "module"; text x; text "="] in - let uu___2 = - let uu___3 = doc_of_sig currentModule subsig in - let uu___4 = let uu___5 = reduce1 [text "end"] in [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - combine hardline uu___ - | FStar_Extraction_ML_Syntax.MLS_Exn (x, []) -> - reduce1 [text "exception"; text x] - | FStar_Extraction_ML_Syntax.MLS_Exn (x, args) -> - let args1 = - FStar_Compiler_List.map - (doc_of_mltype currentModule (min_op_prec, NonAssoc)) args in - let args2 = let uu___ = combine (text " * ") args1 in parens uu___ in - reduce1 [text "exception"; text x; text "of"; args2] - | FStar_Extraction_ML_Syntax.MLS_Val (x, (uu___, ty)) -> - let ty1 = doc_of_mltype currentModule (min_op_prec, NonAssoc) ty in - reduce1 [text "val"; text x; text ": "; ty1] - | FStar_Extraction_ML_Syntax.MLS_Ty decls -> - doc_of_mltydecl currentModule decls -and (doc_of_sig : - FStar_Extraction_ML_Syntax.mlsymbol -> - FStar_Extraction_ML_Syntax.mlsig -> doc) - = - fun currentModule -> - fun s -> - let docs = FStar_Compiler_List.map (doc_of_sig1 currentModule) s in - let docs1 = - FStar_Compiler_List.map (fun x -> reduce [x; hardline; hardline]) - docs in - reduce docs1 -let (doc_of_mod1 : - FStar_Extraction_ML_Syntax.mlsymbol -> - FStar_Extraction_ML_Syntax.mlmodule1 -> doc) - = - fun currentModule -> - fun m -> - match m.FStar_Extraction_ML_Syntax.mlmodule1_m with - | FStar_Extraction_ML_Syntax.MLM_Exn (x, []) -> - reduce1 [text "exception"; text x] - | FStar_Extraction_ML_Syntax.MLM_Exn (x, args) -> - let args1 = - FStar_Compiler_List.map FStar_Pervasives_Native.snd args in - let args2 = - FStar_Compiler_List.map - (doc_of_mltype currentModule (min_op_prec, NonAssoc)) args1 in - let args3 = let uu___ = combine (text " * ") args2 in parens uu___ in - reduce1 [text "exception"; text x; text "of"; args3] - | FStar_Extraction_ML_Syntax.MLM_Ty decls -> - doc_of_mltydecl currentModule decls - | FStar_Extraction_ML_Syntax.MLM_Let (rec_, lets) -> - doc_of_lets currentModule (rec_, true, lets) - | FStar_Extraction_ML_Syntax.MLM_Top e -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - doc_of_expr currentModule (min_op_prec, NonAssoc) e in - [uu___4] in - (text "=") :: uu___3 in - (text "_") :: uu___2 in - (text "let") :: uu___1 in - reduce1 uu___ - | FStar_Extraction_ML_Syntax.MLM_Loc loc -> doc_of_loc loc -let (doc_of_mod : - FStar_Extraction_ML_Syntax.mlsymbol -> - FStar_Extraction_ML_Syntax.mlmodule -> doc) - = - fun currentModule -> - fun m -> - let docs = - FStar_Compiler_List.map - (fun x -> - let doc1 = doc_of_mod1 currentModule x in - [doc1; - (match x.FStar_Extraction_ML_Syntax.mlmodule1_m with - | FStar_Extraction_ML_Syntax.MLM_Loc uu___ -> empty - | uu___ -> hardline); - hardline]) m in - reduce (FStar_Compiler_List.flatten docs) -let (doc_of_mllib_r : - FStar_Extraction_ML_Syntax.mllib -> (Prims.string * doc) Prims.list) = - fun uu___ -> - match uu___ with - | FStar_Extraction_ML_Syntax.MLLib mllib -> - let rec for1_sig uu___1 = - match uu___1 with - | (x, sigmod, FStar_Extraction_ML_Syntax.MLLib sub) -> - let x1 = FStar_Extraction_ML_Util.flatten_mlpath x in - let head = - reduce1 [text "module"; text x1; text ":"; text "sig"] in - let tail = reduce1 [text "end"] in - let doc1 = - FStar_Compiler_Option.map - (fun uu___2 -> - match uu___2 with | (s, uu___3) -> doc_of_sig x1 s) - sigmod in - let sub1 = FStar_Compiler_List.map for1_sig sub in - let sub2 = - FStar_Compiler_List.map - (fun x2 -> reduce [x2; hardline; hardline]) sub1 in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = reduce sub2 in [uu___5; cat tail hardline] in - (match doc1 with - | FStar_Pervasives_Native.None -> empty - | FStar_Pervasives_Native.Some s -> cat s hardline) :: - uu___4 in - (cat head hardline) :: uu___3 in - reduce uu___2 - and for1_mod istop uu___1 = - match uu___1 with - | (mod_name, sigmod, FStar_Extraction_ML_Syntax.MLLib sub) -> - let target_mod_name = - FStar_Extraction_ML_Util.flatten_mlpath mod_name in - let maybe_open_pervasives = - match mod_name with - | ("FStar"::[], "Pervasives") -> [] - | uu___2 -> - let pervasives = - FStar_Extraction_ML_Util.flatten_mlpath - (["FStar"], "Pervasives") in - [hardline; text (Prims.strcat "open " pervasives)] in - let head = - let uu___2 = - let uu___3 = FStar_Extraction_ML_Util.codegen_fsharp () in - if uu___3 - then [text "module"; text target_mod_name] - else - if Prims.op_Negation istop - then - [text "module"; - text target_mod_name; - text "="; - text "struct"] - else [] in - reduce1 uu___2 in - let tail = - if Prims.op_Negation istop - then reduce1 [text "end"] - else reduce1 [] in - let doc1 = - FStar_Compiler_Option.map - (fun uu___2 -> - match uu___2 with - | (uu___3, m) -> doc_of_mod target_mod_name m) sigmod in - let sub1 = FStar_Compiler_List.map (for1_mod false) sub in - let sub2 = - FStar_Compiler_List.map - (fun x -> reduce [x; hardline; hardline]) sub1 in - let prefix = - let uu___2 = FStar_Extraction_ML_Util.codegen_fsharp () in - if uu___2 then [cat (text "#light \"off\"") hardline] else [] in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = reduce sub2 in - [uu___8; cat tail hardline] in - (match doc1 with - | FStar_Pervasives_Native.None -> empty - | FStar_Pervasives_Native.Some s -> cat s hardline) - :: uu___7 in - hardline :: uu___6 in - FStar_Compiler_List.op_At maybe_open_pervasives uu___5 in - FStar_Compiler_List.op_At - [head; hardline; text "open Prims"] uu___4 in - FStar_Compiler_List.op_At prefix uu___3 in - reduce uu___2 in - let docs = - FStar_Compiler_List.map - (fun uu___1 -> - match uu___1 with - | (x, s, m) -> - let uu___2 = FStar_Extraction_ML_Util.flatten_mlpath x in - let uu___3 = for1_mod true (x, s, m) in (uu___2, uu___3)) - mllib in - docs -let (pretty : Prims.int -> doc -> Prims.string) = - fun sz -> fun uu___ -> match uu___ with | Doc doc1 -> doc1 -let (doc_of_mllib : - FStar_Extraction_ML_Syntax.mllib -> (Prims.string * doc) Prims.list) = - fun mllib -> doc_of_mllib_r mllib -let (string_of_mlexpr : - FStar_Extraction_ML_Syntax.mlpath -> - FStar_Extraction_ML_Syntax.mlexpr -> Prims.string) - = - fun cmod -> - fun e -> - let doc1 = - let uu___ = FStar_Extraction_ML_Util.flatten_mlpath cmod in - doc_of_expr uu___ (min_op_prec, NonAssoc) e in - pretty Prims.int_zero doc1 -let (string_of_mlty : - FStar_Extraction_ML_Syntax.mlpath -> - FStar_Extraction_ML_Syntax.mlty -> Prims.string) - = - fun cmod -> - fun e -> - let doc1 = - let uu___ = FStar_Extraction_ML_Util.flatten_mlpath cmod in - doc_of_mltype uu___ (min_op_prec, NonAssoc) e in - pretty Prims.int_zero doc1 -let (showable_mlexpr : - FStar_Extraction_ML_Syntax.mlexpr FStar_Class_Show.showable) = - { FStar_Class_Show.show = (string_of_mlexpr ([], "")) } -let (showable_mlty : - FStar_Extraction_ML_Syntax.mlty FStar_Class_Show.showable) = - { FStar_Class_Show.show = (string_of_mlty ([], "")) } -let (showable_etag : - FStar_Extraction_ML_Syntax.e_tag FStar_Class_Show.showable) = - { FStar_Class_Show.show = string_of_etag } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Extraction_ML_Modul.ml b/ocaml/fstar-lib/generated/FStar_Extraction_ML_Modul.ml deleted file mode 100644 index c1f75899540..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Extraction_ML_Modul.ml +++ /dev/null @@ -1,3174 +0,0 @@ -open Prims -let (dbg_ExtractionReify : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "ExtractionReify" -type tydef_declaration = - (FStar_Extraction_ML_Syntax.mlsymbol * FStar_Extraction_ML_Syntax.metadata - * Prims.int) -type iface = - { - iface_module_name: FStar_Extraction_ML_Syntax.mlpath ; - iface_bindings: - (FStar_Syntax_Syntax.fv * FStar_Extraction_ML_UEnv.exp_binding) - Prims.list - ; - iface_tydefs: - (FStar_Extraction_ML_UEnv.tydef, tydef_declaration) - FStar_Pervasives.either Prims.list - ; - iface_type_names: - (FStar_Syntax_Syntax.fv * FStar_Extraction_ML_Syntax.mlpath) Prims.list } -let (__proj__Mkiface__item__iface_module_name : - iface -> FStar_Extraction_ML_Syntax.mlpath) = - fun projectee -> - match projectee with - | { iface_module_name; iface_bindings; iface_tydefs; iface_type_names;_} - -> iface_module_name -let (__proj__Mkiface__item__iface_bindings : - iface -> - (FStar_Syntax_Syntax.fv * FStar_Extraction_ML_UEnv.exp_binding) - Prims.list) - = - fun projectee -> - match projectee with - | { iface_module_name; iface_bindings; iface_tydefs; iface_type_names;_} - -> iface_bindings -let (__proj__Mkiface__item__iface_tydefs : - iface -> - (FStar_Extraction_ML_UEnv.tydef, tydef_declaration) - FStar_Pervasives.either Prims.list) - = - fun projectee -> - match projectee with - | { iface_module_name; iface_bindings; iface_tydefs; iface_type_names;_} - -> iface_tydefs -let (__proj__Mkiface__item__iface_type_names : - iface -> - (FStar_Syntax_Syntax.fv * FStar_Extraction_ML_Syntax.mlpath) Prims.list) - = - fun projectee -> - match projectee with - | { iface_module_name; iface_bindings; iface_tydefs; iface_type_names;_} - -> iface_type_names -type extension_sigelt_extractor = - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.sigelt -> - FStar_Dyn.dyn -> - (FStar_Extraction_ML_Syntax.mlmodule, Prims.string) - FStar_Pervasives.either -type extension_sigelt_iface_extractor = - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.sigelt -> - FStar_Dyn.dyn -> - ((FStar_Extraction_ML_UEnv.uenv * iface), Prims.string) - FStar_Pervasives.either -type extension_extractor = - { - extract_sigelt: extension_sigelt_extractor ; - extract_sigelt_iface: extension_sigelt_iface_extractor } -let (__proj__Mkextension_extractor__item__extract_sigelt : - extension_extractor -> extension_sigelt_extractor) = - fun projectee -> - match projectee with - | { extract_sigelt; extract_sigelt_iface;_} -> extract_sigelt -let (__proj__Mkextension_extractor__item__extract_sigelt_iface : - extension_extractor -> extension_sigelt_iface_extractor) = - fun projectee -> - match projectee with - | { extract_sigelt; extract_sigelt_iface;_} -> extract_sigelt_iface -let (extension_extractor_table : - extension_extractor FStar_Compiler_Util.smap) = - FStar_Compiler_Util.smap_create (Prims.of_int (20)) -let (register_extension_extractor : - Prims.string -> extension_extractor -> unit) = - fun ext -> - fun callback -> - FStar_Compiler_Util.smap_add extension_extractor_table ext callback -let (lookup_extension_extractor : - Prims.string -> extension_extractor FStar_Pervasives_Native.option) = - fun ext -> - let do1 uu___ = - FStar_Compiler_Util.smap_try_find extension_extractor_table ext in - let uu___ = do1 () in - match uu___ with - | FStar_Pervasives_Native.None -> - let uu___1 = FStar_Compiler_Plugins.autoload_plugin ext in - if uu___1 then do1 () else FStar_Pervasives_Native.None - | r -> r -type env_t = FStar_Extraction_ML_UEnv.uenv -let (fail_exp : - FStar_Ident.lident -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun lid -> - fun t -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Parser_Const.failwith_lid () in - FStar_Syntax_Syntax.fvar uu___3 FStar_Pervasives_Native.None in - let uu___3 = - let uu___4 = FStar_Syntax_Syntax.iarg t in - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Class_Show.show FStar_Ident.showable_lident - lid in - Prims.strcat "Not yet implemented: " uu___12 in - (uu___11, FStar_Compiler_Range_Type.dummyRange) in - FStar_Const.Const_string uu___10 in - FStar_Syntax_Syntax.Tm_constant uu___9 in - FStar_Syntax_Syntax.mk uu___8 - FStar_Compiler_Range_Type.dummyRange in - FStar_Syntax_Syntax.as_arg uu___7 in - [uu___6] in - uu___4 :: uu___5 in - { - FStar_Syntax_Syntax.hd = uu___2; - FStar_Syntax_Syntax.args = uu___3 - } in - FStar_Syntax_Syntax.Tm_app uu___1 in - FStar_Syntax_Syntax.mk uu___ FStar_Compiler_Range_Type.dummyRange -let (always_fail : - FStar_Ident.lident -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.letbinding) - = - fun lid -> - fun t -> - let imp = - let uu___ = FStar_Syntax_Util.arrow_formals t in - match uu___ with - | ([], t1) -> - let b = - let uu___1 = - FStar_Syntax_Syntax.gen_bv "_" FStar_Pervasives_Native.None - t1 in - FStar_Syntax_Syntax.mk_binder uu___1 in - let uu___1 = fail_exp lid t1 in - FStar_Syntax_Util.abs [b] uu___1 FStar_Pervasives_Native.None - | (bs, t1) -> - let uu___1 = fail_exp lid t1 in - FStar_Syntax_Util.abs bs uu___1 FStar_Pervasives_Native.None in - let lb = - let uu___ = - let uu___1 = - FStar_Syntax_Syntax.lid_as_fv lid FStar_Pervasives_Native.None in - FStar_Pervasives.Inr uu___1 in - let uu___1 = FStar_Parser_Const.effect_ML_lid () in - { - FStar_Syntax_Syntax.lbname = uu___; - FStar_Syntax_Syntax.lbunivs = []; - FStar_Syntax_Syntax.lbtyp = t; - FStar_Syntax_Syntax.lbeff = uu___1; - FStar_Syntax_Syntax.lbdef = imp; - FStar_Syntax_Syntax.lbattrs = []; - FStar_Syntax_Syntax.lbpos = (imp.FStar_Syntax_Syntax.pos) - } in - lb -let as_pair : 'uuuuu . 'uuuuu Prims.list -> ('uuuuu * 'uuuuu) = - fun uu___ -> - match uu___ with - | a::b::[] -> (a, b) - | uu___1 -> failwith "Expected a list with 2 elements" -let (flag_of_qual : - FStar_Syntax_Syntax.qualifier -> - FStar_Extraction_ML_Syntax.meta FStar_Pervasives_Native.option) - = - fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.Assumption -> - FStar_Pervasives_Native.Some FStar_Extraction_ML_Syntax.Assumed - | FStar_Syntax_Syntax.Private -> - FStar_Pervasives_Native.Some FStar_Extraction_ML_Syntax.Private - | FStar_Syntax_Syntax.NoExtract -> - FStar_Pervasives_Native.Some FStar_Extraction_ML_Syntax.NoExtract - | uu___1 -> FStar_Pervasives_Native.None -let rec (extract_meta : - FStar_Syntax_Syntax.term -> - FStar_Extraction_ML_Syntax.meta FStar_Pervasives_Native.option) - = - fun x -> - let uu___ = FStar_Syntax_Subst.compress x in - match uu___ with - | { FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___1; FStar_Syntax_Syntax.vars = uu___2; - FStar_Syntax_Syntax.hash_code = uu___3;_} -> - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.lid_of_fv fv in - FStar_Ident.string_of_lid uu___5 in - (match uu___4 with - | "FStar.Pervasives.PpxDerivingShow" -> - FStar_Pervasives_Native.Some - FStar_Extraction_ML_Syntax.PpxDerivingShow - | "FStar.Pervasives.PpxDerivingYoJson" -> - FStar_Pervasives_Native.Some - FStar_Extraction_ML_Syntax.PpxDerivingYoJson - | "FStar.Pervasives.CInline" -> - FStar_Pervasives_Native.Some FStar_Extraction_ML_Syntax.CInline - | "FStar.Pervasives.CNoInline" -> - FStar_Pervasives_Native.Some - FStar_Extraction_ML_Syntax.CNoInline - | "FStar.Pervasives.Substitute" -> - FStar_Pervasives_Native.Some - FStar_Extraction_ML_Syntax.Substitute - | "FStar.Pervasives.Gc" -> - FStar_Pervasives_Native.Some FStar_Extraction_ML_Syntax.GCType - | "FStar.Pervasives.CAbstractStruct" -> - FStar_Pervasives_Native.Some - FStar_Extraction_ML_Syntax.CAbstract - | "FStar.Pervasives.CIfDef" -> - FStar_Pervasives_Native.Some FStar_Extraction_ML_Syntax.CIfDef - | "FStar.Pervasives.CMacro" -> - FStar_Pervasives_Native.Some FStar_Extraction_ML_Syntax.CMacro - | "Prims.deprecated" -> - FStar_Pervasives_Native.Some - (FStar_Extraction_ML_Syntax.Deprecated "") - | uu___5 -> FStar_Pervasives_Native.None) - | { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___1; - FStar_Syntax_Syntax.vars = uu___2; - FStar_Syntax_Syntax.hash_code = uu___3;_}; - FStar_Syntax_Syntax.args = - ({ - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_string (s, uu___4)); - FStar_Syntax_Syntax.pos = uu___5; - FStar_Syntax_Syntax.vars = uu___6; - FStar_Syntax_Syntax.hash_code = uu___7;_}, - uu___8)::[];_}; - FStar_Syntax_Syntax.pos = uu___9; FStar_Syntax_Syntax.vars = uu___10; - FStar_Syntax_Syntax.hash_code = uu___11;_} -> - let uu___12 = - let uu___13 = FStar_Syntax_Syntax.lid_of_fv fv in - FStar_Ident.string_of_lid uu___13 in - (match uu___12 with - | "FStar.Pervasives.PpxDerivingShowConstant" -> - FStar_Pervasives_Native.Some - (FStar_Extraction_ML_Syntax.PpxDerivingShowConstant s) - | "FStar.Pervasives.Comment" -> - FStar_Pervasives_Native.Some - (FStar_Extraction_ML_Syntax.Comment s) - | "FStar.Pervasives.CPrologue" -> - FStar_Pervasives_Native.Some - (FStar_Extraction_ML_Syntax.CPrologue s) - | "FStar.Pervasives.CEpilogue" -> - FStar_Pervasives_Native.Some - (FStar_Extraction_ML_Syntax.CEpilogue s) - | "FStar.Pervasives.CConst" -> - FStar_Pervasives_Native.Some - (FStar_Extraction_ML_Syntax.CConst s) - | "FStar.Pervasives.CCConv" -> - FStar_Pervasives_Native.Some - (FStar_Extraction_ML_Syntax.CCConv s) - | "Prims.deprecated" -> - FStar_Pervasives_Native.Some - (FStar_Extraction_ML_Syntax.Deprecated s) - | uu___13 -> FStar_Pervasives_Native.None) - | { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_string ("KrmlPrivate", uu___1)); - FStar_Syntax_Syntax.pos = uu___2; FStar_Syntax_Syntax.vars = uu___3; - FStar_Syntax_Syntax.hash_code = uu___4;_} -> - FStar_Pervasives_Native.Some FStar_Extraction_ML_Syntax.Private - | { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_string ("c_inline", uu___1)); - FStar_Syntax_Syntax.pos = uu___2; FStar_Syntax_Syntax.vars = uu___3; - FStar_Syntax_Syntax.hash_code = uu___4;_} -> - FStar_Pervasives_Native.Some FStar_Extraction_ML_Syntax.CInline - | { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_string ("substitute", uu___1)); - FStar_Syntax_Syntax.pos = uu___2; FStar_Syntax_Syntax.vars = uu___3; - FStar_Syntax_Syntax.hash_code = uu___4;_} -> - FStar_Pervasives_Native.Some FStar_Extraction_ML_Syntax.Substitute - | { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = x1; - FStar_Syntax_Syntax.meta = uu___1;_}; - FStar_Syntax_Syntax.pos = uu___2; FStar_Syntax_Syntax.vars = uu___3; - FStar_Syntax_Syntax.hash_code = uu___4;_} -> extract_meta x1 - | uu___1 -> - let uu___2 = FStar_Syntax_Util.head_and_args x in - (match uu___2 with - | (head, args) -> - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Subst.compress head in - uu___5.FStar_Syntax_Syntax.n in - (uu___4, args) in - (match uu___3 with - | (FStar_Syntax_Syntax.Tm_fvar fv, uu___4::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.remove_unused_type_parameters_lid - -> - let uu___5 = - let uu___6 = - FStar_ToSyntax_ToSyntax.parse_attr_with_list false x - FStar_Parser_Const.remove_unused_type_parameters_lid in - FStar_Pervasives_Native.fst uu___6 in - (match uu___5 with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some l -> - let uu___6 = - let uu___7 = - let uu___8 = FStar_Syntax_Syntax.range_of_fv fv in - (l, uu___8) in - FStar_Extraction_ML_Syntax.RemoveUnusedTypeParameters - uu___7 in - FStar_Pervasives_Native.Some uu___6) - | uu___4 -> FStar_Pervasives_Native.None)) -let (extract_metadata : - FStar_Syntax_Syntax.term Prims.list -> - FStar_Extraction_ML_Syntax.meta Prims.list) - = fun metas -> FStar_Compiler_List.choose extract_meta metas -let (binders_as_mlty_binders : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.binder Prims.list -> - (FStar_Extraction_ML_UEnv.uenv * FStar_Extraction_ML_Syntax.ty_param - Prims.list)) - = - fun env -> - fun bs -> - FStar_Compiler_Util.fold_map - (fun env1 -> - fun uu___ -> - match uu___ with - | { FStar_Syntax_Syntax.binder_bv = bv; - FStar_Syntax_Syntax.binder_qual = uu___1; - FStar_Syntax_Syntax.binder_positivity = uu___2; - FStar_Syntax_Syntax.binder_attrs = binder_attrs;_} -> - let env2 = FStar_Extraction_ML_UEnv.extend_ty env1 bv false in - let ty_param_name = - let uu___3 = FStar_Extraction_ML_UEnv.lookup_bv env2 bv in - match uu___3 with - | FStar_Pervasives.Inl ty -> - ty.FStar_Extraction_ML_UEnv.ty_b_name - | uu___4 -> failwith "Impossible" in - let ty_param_attrs = - FStar_Compiler_List.map - (fun attr -> - let uu___3 = - FStar_Extraction_ML_Term.term_as_mlexpr env2 attr in - match uu___3 with | (e, uu___4, uu___5) -> e) - binder_attrs in - (env2, - { - FStar_Extraction_ML_Syntax.ty_param_name = ty_param_name; - FStar_Extraction_ML_Syntax.ty_param_attrs = - ty_param_attrs - })) env bs -type data_constructor = - { - dname: FStar_Ident.lident ; - dtyp: FStar_Syntax_Syntax.typ } -let (__proj__Mkdata_constructor__item__dname : - data_constructor -> FStar_Ident.lident) = - fun projectee -> match projectee with | { dname; dtyp;_} -> dname -let (__proj__Mkdata_constructor__item__dtyp : - data_constructor -> FStar_Syntax_Syntax.typ) = - fun projectee -> match projectee with | { dname; dtyp;_} -> dtyp -type inductive_family = - { - ifv: FStar_Syntax_Syntax.fv ; - iname: FStar_Ident.lident ; - iparams: FStar_Syntax_Syntax.binders ; - ityp: FStar_Syntax_Syntax.term ; - idatas: data_constructor Prims.list ; - iquals: FStar_Syntax_Syntax.qualifier Prims.list ; - imetadata: FStar_Extraction_ML_Syntax.metadata } -let (__proj__Mkinductive_family__item__ifv : - inductive_family -> FStar_Syntax_Syntax.fv) = - fun projectee -> - match projectee with - | { ifv; iname; iparams; ityp; idatas; iquals; imetadata;_} -> ifv -let (__proj__Mkinductive_family__item__iname : - inductive_family -> FStar_Ident.lident) = - fun projectee -> - match projectee with - | { ifv; iname; iparams; ityp; idatas; iquals; imetadata;_} -> iname -let (__proj__Mkinductive_family__item__iparams : - inductive_family -> FStar_Syntax_Syntax.binders) = - fun projectee -> - match projectee with - | { ifv; iname; iparams; ityp; idatas; iquals; imetadata;_} -> iparams -let (__proj__Mkinductive_family__item__ityp : - inductive_family -> FStar_Syntax_Syntax.term) = - fun projectee -> - match projectee with - | { ifv; iname; iparams; ityp; idatas; iquals; imetadata;_} -> ityp -let (__proj__Mkinductive_family__item__idatas : - inductive_family -> data_constructor Prims.list) = - fun projectee -> - match projectee with - | { ifv; iname; iparams; ityp; idatas; iquals; imetadata;_} -> idatas -let (__proj__Mkinductive_family__item__iquals : - inductive_family -> FStar_Syntax_Syntax.qualifier Prims.list) = - fun projectee -> - match projectee with - | { ifv; iname; iparams; ityp; idatas; iquals; imetadata;_} -> iquals -let (__proj__Mkinductive_family__item__imetadata : - inductive_family -> FStar_Extraction_ML_Syntax.metadata) = - fun projectee -> - match projectee with - | { ifv; iname; iparams; ityp; idatas; iquals; imetadata;_} -> imetadata -let (print_ifamily : inductive_family -> unit) = - fun i -> - let uu___ = FStar_Class_Show.show FStar_Ident.showable_lident i.iname in - let uu___1 = - FStar_Class_Show.show - (FStar_Class_Show.show_list FStar_Syntax_Print.showable_binder) - i.iparams in - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term i.ityp in - let uu___3 = - let uu___4 = - FStar_Compiler_List.map - (fun d -> - let uu___5 = - FStar_Class_Show.show FStar_Ident.showable_lident d.dname in - let uu___6 = - let uu___7 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - d.dtyp in - Prims.strcat " : " uu___7 in - Prims.strcat uu___5 uu___6) i.idatas in - FStar_Compiler_String.concat "\n\t\t" uu___4 in - FStar_Compiler_Util.print4 "\n\t%s %s : %s { %s }\n" uu___ uu___1 uu___2 - uu___3 -let (bundle_as_inductive_families : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.sigelt Prims.list -> - FStar_Syntax_Syntax.qualifier Prims.list -> - (FStar_Extraction_ML_UEnv.uenv * inductive_family Prims.list)) - = - fun env -> - fun ses -> - fun quals -> - let uu___ = - FStar_Compiler_Util.fold_map - (fun env1 -> - fun se -> - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = l; - FStar_Syntax_Syntax.us = us; - FStar_Syntax_Syntax.params = bs; - FStar_Syntax_Syntax.num_uniform_params = uu___1; - FStar_Syntax_Syntax.t = t; - FStar_Syntax_Syntax.mutuals = uu___2; - FStar_Syntax_Syntax.ds = datas; - FStar_Syntax_Syntax.injective_type_params = uu___3;_} - -> - let uu___4 = FStar_Syntax_Subst.open_univ_vars us t in - (match uu___4 with - | (_us, t1) -> - let uu___5 = FStar_Syntax_Subst.open_term bs t1 in - (match uu___5 with - | (bs1, t2) -> - let datas1 = - FStar_Compiler_List.collect - (fun se1 -> - match se1.FStar_Syntax_Syntax.sigel - with - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = d; - FStar_Syntax_Syntax.us1 = us1; - FStar_Syntax_Syntax.t1 = t3; - FStar_Syntax_Syntax.ty_lid = l'; - FStar_Syntax_Syntax.num_ty_params - = nparams; - FStar_Syntax_Syntax.mutuals1 = - uu___6; - FStar_Syntax_Syntax.injective_type_params1 - = uu___7;_} - when FStar_Ident.lid_equals l l' -> - let uu___8 = - FStar_Syntax_Subst.open_univ_vars - us1 t3 in - (match uu___8 with - | (_us1, t4) -> - let uu___9 = - FStar_Syntax_Util.arrow_formals - t4 in - (match uu___9 with - | (bs', body) -> - let uu___10 = - FStar_Compiler_Util.first_N - (FStar_Compiler_List.length - bs1) bs' in - (match uu___10 with - | (bs_params, rest) -> - let subst = - FStar_Compiler_List.map2 - (fun uu___11 -> - fun uu___12 - -> - match - (uu___11, - uu___12) - with - | ({ - FStar_Syntax_Syntax.binder_bv - = b'; - FStar_Syntax_Syntax.binder_qual - = uu___13; - FStar_Syntax_Syntax.binder_positivity - = uu___14; - FStar_Syntax_Syntax.binder_attrs - = uu___15;_}, - { - FStar_Syntax_Syntax.binder_bv - = b; - FStar_Syntax_Syntax.binder_qual - = uu___16; - FStar_Syntax_Syntax.binder_positivity - = uu___17; - FStar_Syntax_Syntax.binder_attrs - = uu___18;_}) - -> - let uu___19 - = - let uu___20 - = - FStar_Syntax_Syntax.bv_to_name - b in - (b', - uu___20) in - FStar_Syntax_Syntax.NT - uu___19) - bs_params bs1 in - let t5 = - let uu___11 = - let uu___12 = - FStar_Syntax_Syntax.mk_Total - body in - FStar_Syntax_Util.arrow - rest uu___12 in - FStar_Syntax_Subst.subst - subst uu___11 in - [{ - dname = d; - dtyp = t5 - }]))) - | uu___6 -> []) ses in - let metadata = - let uu___6 = - extract_metadata - se.FStar_Syntax_Syntax.sigattrs in - let uu___7 = - FStar_Compiler_List.choose flag_of_qual - quals in - FStar_Compiler_List.op_At uu___6 uu___7 in - let fv = - FStar_Syntax_Syntax.lid_as_fv l - FStar_Pervasives_Native.None in - let uu___6 = - FStar_Extraction_ML_UEnv.extend_type_name - env1 fv in - (match uu___6 with - | (uu___7, env2) -> - (env2, - [{ - ifv = fv; - iname = l; - iparams = bs1; - ityp = t2; - idatas = datas1; - iquals = - (se.FStar_Syntax_Syntax.sigquals); - imetadata = metadata - }])))) - | uu___1 -> (env1, [])) env ses in - match uu___ with - | (env1, ifams) -> (env1, (FStar_Compiler_List.flatten ifams)) -let (empty_iface : iface) = - { - iface_module_name = ([], ""); - iface_bindings = []; - iface_tydefs = []; - iface_type_names = [] - } -let (iface_of_bindings : - (FStar_Syntax_Syntax.fv * FStar_Extraction_ML_UEnv.exp_binding) Prims.list - -> iface) - = - fun fvs -> - { - iface_module_name = (empty_iface.iface_module_name); - iface_bindings = fvs; - iface_tydefs = (empty_iface.iface_tydefs); - iface_type_names = (empty_iface.iface_type_names) - } -let (iface_of_tydefs : FStar_Extraction_ML_UEnv.tydef Prims.list -> iface) = - fun tds -> - let uu___ = - FStar_Compiler_List.map (fun uu___1 -> FStar_Pervasives.Inl uu___1) tds in - let uu___1 = - FStar_Compiler_List.map - (fun td -> - let uu___2 = FStar_Extraction_ML_UEnv.tydef_fv td in - let uu___3 = FStar_Extraction_ML_UEnv.tydef_mlpath td in - (uu___2, uu___3)) tds in - { - iface_module_name = (empty_iface.iface_module_name); - iface_bindings = (empty_iface.iface_bindings); - iface_tydefs = uu___; - iface_type_names = uu___1 - } -let (iface_of_type_names : - (FStar_Syntax_Syntax.fv * FStar_Extraction_ML_Syntax.mlpath) Prims.list -> - iface) - = - fun fvs -> - { - iface_module_name = (empty_iface.iface_module_name); - iface_bindings = (empty_iface.iface_bindings); - iface_tydefs = (empty_iface.iface_tydefs); - iface_type_names = fvs - } -let (iface_union : iface -> iface -> iface) = - fun if1 -> - fun if2 -> - let uu___ = if1.iface_module_name in - { - iface_module_name = uu___; - iface_bindings = - (FStar_Compiler_List.op_At if1.iface_bindings if2.iface_bindings); - iface_tydefs = - (FStar_Compiler_List.op_At if1.iface_tydefs if2.iface_tydefs); - iface_type_names = - (FStar_Compiler_List.op_At if1.iface_type_names - if2.iface_type_names) - } -let (iface_union_l : iface Prims.list -> iface) = - fun ifs -> FStar_Compiler_List.fold_right iface_union ifs empty_iface -let (string_of_mlpath : FStar_Extraction_ML_Syntax.mlpath -> Prims.string) = - fun p -> - FStar_Compiler_String.concat ". " - (FStar_Compiler_List.op_At (FStar_Pervasives_Native.fst p) - [FStar_Pervasives_Native.snd p]) -let tscheme_to_string : - 'uuuuu . - FStar_Extraction_ML_Syntax.mlpath -> - ('uuuuu * FStar_Extraction_ML_Syntax.mlty) -> Prims.string - = - fun cm -> - fun ts -> - FStar_Extraction_ML_Code.string_of_mlty cm - (FStar_Pervasives_Native.snd ts) -let (print_exp_binding : - FStar_Extraction_ML_Syntax.mlpath -> - FStar_Extraction_ML_UEnv.exp_binding -> Prims.string) - = - fun cm -> - fun e -> - let uu___ = - FStar_Extraction_ML_Code.string_of_mlexpr cm - e.FStar_Extraction_ML_UEnv.exp_b_expr in - let uu___1 = - tscheme_to_string cm e.FStar_Extraction_ML_UEnv.exp_b_tscheme in - FStar_Compiler_Util.format3 - "{\n\texp_b_name = %s\n\texp_b_expr = %s\n\texp_b_tscheme = %s }" - e.FStar_Extraction_ML_UEnv.exp_b_name uu___ uu___1 -let (print_binding : - FStar_Extraction_ML_Syntax.mlpath -> - (FStar_Syntax_Syntax.fv * FStar_Extraction_ML_UEnv.exp_binding) -> - Prims.string) - = - fun cm -> - fun uu___ -> - match uu___ with - | (fv, exp_binding) -> - let uu___1 = - FStar_Class_Show.show FStar_Syntax_Print.showable_fv fv in - let uu___2 = print_exp_binding cm exp_binding in - FStar_Compiler_Util.format2 "(%s, %s)" uu___1 uu___2 -let print_tydef : - 'uuuuu 'uuuuu1 . - FStar_Extraction_ML_Syntax.mlpath -> - (FStar_Extraction_ML_UEnv.tydef, (Prims.string * 'uuuuu * 'uuuuu1)) - FStar_Pervasives.either -> Prims.string - = - fun cm -> - fun tydef -> - let uu___ = - match tydef with - | FStar_Pervasives.Inl tydef1 -> - let uu___1 = - let uu___2 = FStar_Extraction_ML_UEnv.tydef_fv tydef1 in - FStar_Class_Show.show FStar_Syntax_Print.showable_fv uu___2 in - let uu___2 = - let uu___3 = FStar_Extraction_ML_UEnv.tydef_def tydef1 in - tscheme_to_string cm uu___3 in - (uu___1, uu___2) - | FStar_Pervasives.Inr (p, uu___1, uu___2) -> (p, "None") in - match uu___ with - | (name, defn) -> FStar_Compiler_Util.format2 "(%s, %s)" name defn -let (iface_to_string : iface -> Prims.string) = - fun iface1 -> - let cm = iface1.iface_module_name in - let print_type_name uu___ = - match uu___ with - | (tn, uu___1) -> - FStar_Class_Show.show FStar_Syntax_Print.showable_fv tn in - let uu___ = - let uu___1 = - FStar_Compiler_List.map (print_binding cm) iface1.iface_bindings in - FStar_Compiler_String.concat "\n" uu___1 in - let uu___1 = - let uu___2 = - FStar_Compiler_List.map (print_tydef cm) iface1.iface_tydefs in - FStar_Compiler_String.concat "\n" uu___2 in - let uu___2 = - let uu___3 = - FStar_Compiler_List.map print_type_name iface1.iface_type_names in - FStar_Compiler_String.concat "\n" uu___3 in - FStar_Compiler_Util.format4 - "Interface %s = {\niface_bindings=\n%s;\n\niface_tydefs=\n%s;\n\niface_type_names=%s;\n}" - (string_of_mlpath iface1.iface_module_name) uu___ uu___1 uu___2 -let (gamma_to_string : FStar_Extraction_ML_UEnv.uenv -> Prims.string) = - fun env -> - let cm = FStar_Extraction_ML_UEnv.current_module_of_uenv env in - let gamma = - let uu___ = FStar_Extraction_ML_UEnv.bindings_of_uenv env in - FStar_Compiler_List.collect - (fun uu___1 -> - match uu___1 with - | FStar_Extraction_ML_UEnv.Fv (b, e) -> [(b, e)] - | uu___2 -> []) uu___ in - let uu___ = - let uu___1 = FStar_Compiler_List.map (print_binding cm) gamma in - FStar_Compiler_String.concat "\n" uu___1 in - FStar_Compiler_Util.format1 "Gamma = {\n %s }" uu___ -let (extract_attrs : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.attribute Prims.list -> - FStar_Extraction_ML_Syntax.mlattribute Prims.list) - = - fun env -> - fun attrs -> - FStar_Compiler_List.map - (fun attr -> - let uu___ = FStar_Extraction_ML_Term.term_as_mlexpr env attr in - match uu___ with | (e, uu___1, uu___2) -> e) attrs -let (extract_typ_abbrev : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.qualifier Prims.list -> - FStar_Syntax_Syntax.attribute Prims.list -> - FStar_Syntax_Syntax.letbinding -> - (env_t * iface * FStar_Extraction_ML_Syntax.mlmodule1 Prims.list)) - = - fun env -> - fun quals -> - fun attrs -> - fun lb -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Extraction_ML_UEnv.tcenv_of_uenv env in - FStar_TypeChecker_Env.open_universes_in uu___2 - lb.FStar_Syntax_Syntax.lbunivs - [lb.FStar_Syntax_Syntax.lbdef; lb.FStar_Syntax_Syntax.lbtyp] in - match uu___1 with - | (tcenv, uu___2, def_typ) -> - let uu___3 = as_pair def_typ in (tcenv, uu___3) in - match uu___ with - | (tcenv, (lbdef, lbtyp)) -> - let lbtyp1 = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.ForExtraction] tcenv lbtyp in - let lbdef1 = - FStar_TypeChecker_Normalize.eta_expand_with_type tcenv lbdef - lbtyp1 in - let fv = - FStar_Compiler_Util.right lb.FStar_Syntax_Syntax.lbname in - let lid = - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - let def = - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress lbdef1 in - FStar_Syntax_Util.unmeta uu___2 in - FStar_Syntax_Util.un_uinst uu___1 in - let def1 = - match def.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_abs uu___1 -> - FStar_Extraction_ML_Term.normalize_abs def - | uu___1 -> def in - let uu___1 = - match def1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = uu___2;_} - -> FStar_Syntax_Subst.open_term bs body - | uu___2 -> ([], def1) in - (match uu___1 with - | (bs, body) -> - let assumed = - FStar_Compiler_Util.for_some - (fun uu___2 -> - match uu___2 with - | FStar_Syntax_Syntax.Assumption -> true - | uu___3 -> false) quals in - let uu___2 = binders_as_mlty_binders env bs in - (match uu___2 with - | (env1, ml_bs) -> - let body1 = - let uu___3 = - FStar_Extraction_ML_Term.term_as_mlty env1 body in - FStar_Extraction_ML_Util.eraseTypeDeep - (FStar_Extraction_ML_Util.udelta_unfold env1) - uu___3 in - let metadata = - let has_val_decl = - FStar_Extraction_ML_UEnv.has_tydef_declaration - env lid in - let meta = - let uu___3 = extract_metadata attrs in - let uu___4 = - FStar_Compiler_List.choose flag_of_qual quals in - FStar_Compiler_List.op_At uu___3 uu___4 in - if has_val_decl - then - let uu___3 = - let uu___4 = FStar_Ident.range_of_lid lid in - FStar_Extraction_ML_Syntax.HasValDecl uu___4 in - uu___3 :: meta - else meta in - let tyscheme = (ml_bs, body1) in - let uu___3 = - let uu___4 = - FStar_Compiler_Util.for_some - (fun uu___5 -> - match uu___5 with - | FStar_Syntax_Syntax.Assumption -> true - | FStar_Syntax_Syntax.New -> true - | uu___6 -> false) quals in - if uu___4 - then - let uu___5 = - FStar_Extraction_ML_UEnv.extend_type_name env - fv in - match uu___5 with - | (mlp, env2) -> - (mlp, (iface_of_type_names [(fv, mlp)]), - env2) - else - (let uu___6 = - FStar_Extraction_ML_UEnv.extend_tydef env fv - tyscheme metadata in - match uu___6 with - | (td, mlp, env2) -> - let uu___7 = iface_of_tydefs [td] in - (mlp, uu___7, env2)) in - (match uu___3 with - | (mlpath, iface1, env2) -> - let td = - { - FStar_Extraction_ML_Syntax.tydecl_assumed = - assumed; - FStar_Extraction_ML_Syntax.tydecl_name = - (FStar_Pervasives_Native.snd mlpath); - FStar_Extraction_ML_Syntax.tydecl_ignored = - FStar_Pervasives_Native.None; - FStar_Extraction_ML_Syntax.tydecl_parameters - = ml_bs; - FStar_Extraction_ML_Syntax.tydecl_meta = - metadata; - FStar_Extraction_ML_Syntax.tydecl_defn = - (FStar_Pervasives_Native.Some - (FStar_Extraction_ML_Syntax.MLTD_Abbrev - body1)) - } in - let loc_mlmodule1 = - let uu___4 = - let uu___5 = FStar_Ident.range_of_lid lid in - FStar_Extraction_ML_Util.mlloc_of_range - uu___5 in - FStar_Extraction_ML_Syntax.MLM_Loc uu___4 in - let ty_mlmodule1 = - FStar_Extraction_ML_Syntax.MLM_Ty [td] in - let def2 = - let uu___4 = - FStar_Extraction_ML_Syntax.mk_mlmodule1 - loc_mlmodule1 in - let uu___5 = - let uu___6 = - let uu___7 = extract_attrs env2 attrs in - FStar_Extraction_ML_Syntax.mk_mlmodule1_with_attrs - ty_mlmodule1 uu___7 in - [uu___6] in - uu___4 :: uu___5 in - (env2, iface1, def2)))) -let (extract_let_rec_type : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.qualifier Prims.list -> - FStar_Syntax_Syntax.attribute Prims.list -> - FStar_Syntax_Syntax.letbinding -> - (env_t * iface * FStar_Extraction_ML_Syntax.mlmodule1 Prims.list)) - = - fun env -> - fun quals -> - fun attrs -> - fun lb -> - let lbtyp = - let uu___ = FStar_Extraction_ML_UEnv.tcenv_of_uenv env in - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.AllowUnboundUniverses; - FStar_TypeChecker_Env.EraseUniverses; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.ForExtraction] uu___ - lb.FStar_Syntax_Syntax.lbtyp in - let uu___ = FStar_Syntax_Util.arrow_formals lbtyp in - match uu___ with - | (bs, uu___1) -> - let uu___2 = binders_as_mlty_binders env bs in - (match uu___2 with - | (env1, ml_bs) -> - let fv = - FStar_Compiler_Util.right lb.FStar_Syntax_Syntax.lbname in - let lid = - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - let body = FStar_Extraction_ML_Syntax.MLTY_Top in - let metadata = - let uu___3 = extract_metadata attrs in - let uu___4 = - FStar_Compiler_List.choose flag_of_qual quals in - FStar_Compiler_List.op_At uu___3 uu___4 in - let assumed = false in - let tscheme = (ml_bs, body) in - let uu___3 = - FStar_Extraction_ML_UEnv.extend_tydef env fv tscheme - metadata in - (match uu___3 with - | (tydef, mlp, env2) -> - let td = - { - FStar_Extraction_ML_Syntax.tydecl_assumed = - assumed; - FStar_Extraction_ML_Syntax.tydecl_name = - (FStar_Pervasives_Native.snd mlp); - FStar_Extraction_ML_Syntax.tydecl_ignored = - FStar_Pervasives_Native.None; - FStar_Extraction_ML_Syntax.tydecl_parameters = - ml_bs; - FStar_Extraction_ML_Syntax.tydecl_meta = metadata; - FStar_Extraction_ML_Syntax.tydecl_defn = - (FStar_Pervasives_Native.Some - (FStar_Extraction_ML_Syntax.MLTD_Abbrev body)) - } in - let loc_mlmodule1 = - let uu___4 = - let uu___5 = FStar_Ident.range_of_lid lid in - FStar_Extraction_ML_Util.mlloc_of_range uu___5 in - FStar_Extraction_ML_Syntax.MLM_Loc uu___4 in - let td_mlmodule1 = - FStar_Extraction_ML_Syntax.MLM_Ty [td] in - let def = - let uu___4 = - FStar_Extraction_ML_Syntax.mk_mlmodule1 - loc_mlmodule1 in - let uu___5 = - let uu___6 = - let uu___7 = extract_attrs env2 attrs in - FStar_Extraction_ML_Syntax.mk_mlmodule1_with_attrs - td_mlmodule1 uu___7 in - [uu___6] in - uu___4 :: uu___5 in - let iface1 = iface_of_tydefs [tydef] in - (env2, iface1, def))) -let (extract_bundle_iface : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.sigelt -> (env_t * iface)) - = - fun env -> - fun se -> - let extract_ctor env_iparams ml_tyvars env1 ctor = - let mlt = - let uu___ = - FStar_Extraction_ML_Term.term_as_mlty env_iparams ctor.dtyp in - FStar_Extraction_ML_Util.eraseTypeDeep - (FStar_Extraction_ML_Util.udelta_unfold env_iparams) uu___ in - let tys = (ml_tyvars, mlt) in - let fvv = - FStar_Syntax_Syntax.lid_as_fv ctor.dname - FStar_Pervasives_Native.None in - let uu___ = FStar_Extraction_ML_UEnv.extend_fv env1 fvv tys false in - match uu___ with | (env2, uu___1, b) -> (env2, (fvv, b)) in - let extract_one_family env1 ind = - let uu___ = binders_as_mlty_binders env1 ind.iparams in - match uu___ with - | (env_iparams, vars) -> - let uu___1 = - FStar_Compiler_Util.fold_map (extract_ctor env_iparams vars) - env1 ind.idatas in - (match uu___1 with - | (env2, ctors) -> - let env3 = - let uu___2 = - FStar_Compiler_Util.find_opt - (fun uu___3 -> - match uu___3 with - | FStar_Syntax_Syntax.RecordType uu___4 -> true - | uu___4 -> false) ind.iquals in - match uu___2 with - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.RecordType (ns, ids)) -> - let g = - FStar_Compiler_List.fold_right - (fun id -> - fun g1 -> - let uu___3 = - FStar_Extraction_ML_UEnv.extend_record_field_name - g1 ((ind.iname), id) in - match uu___3 with | (uu___4, g2) -> g2) ids - env2 in - g - | uu___3 -> env2 in - (env3, ctors)) in - match ((se.FStar_Syntax_Syntax.sigel), - (se.FStar_Syntax_Syntax.sigquals)) - with - | (FStar_Syntax_Syntax.Sig_bundle - { - FStar_Syntax_Syntax.ses = - { - FStar_Syntax_Syntax.sigel = FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = l; - FStar_Syntax_Syntax.us1 = uu___; - FStar_Syntax_Syntax.t1 = t; - FStar_Syntax_Syntax.ty_lid = uu___1; - FStar_Syntax_Syntax.num_ty_params = uu___2; - FStar_Syntax_Syntax.mutuals1 = uu___3; - FStar_Syntax_Syntax.injective_type_params1 = uu___4;_}; - FStar_Syntax_Syntax.sigrng = uu___5; - FStar_Syntax_Syntax.sigquals = uu___6; - FStar_Syntax_Syntax.sigmeta = uu___7; - FStar_Syntax_Syntax.sigattrs = uu___8; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___9; - FStar_Syntax_Syntax.sigopts = uu___10;_}::[]; - FStar_Syntax_Syntax.lids = uu___11;_}, - (FStar_Syntax_Syntax.ExceptionConstructor)::[]) -> - let uu___12 = extract_ctor env [] env { dname = l; dtyp = t } in - (match uu___12 with - | (env1, ctor) -> (env1, (iface_of_bindings [ctor]))) - | (FStar_Syntax_Syntax.Sig_bundle - { FStar_Syntax_Syntax.ses = ses; FStar_Syntax_Syntax.lids = uu___;_}, - quals) -> - let uu___1 = - FStar_Syntax_Util.has_attribute se.FStar_Syntax_Syntax.sigattrs - FStar_Parser_Const.erasable_attr in - if uu___1 - then (env, empty_iface) - else - (let uu___3 = bundle_as_inductive_families env ses quals in - match uu___3 with - | (env1, ifams) -> - let uu___4 = - FStar_Compiler_Util.fold_map extract_one_family env1 ifams in - (match uu___4 with - | (env2, td) -> - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Compiler_List.map - (fun x -> - let uu___8 = - FStar_Extraction_ML_UEnv.mlpath_of_lident - env2 x.iname in - ((x.ifv), uu___8)) ifams in - iface_of_type_names uu___7 in - iface_union uu___6 - (iface_of_bindings (FStar_Compiler_List.flatten td)) in - (env2, uu___5))) - | uu___ -> failwith "Unexpected signature element" -let (extract_type_declaration : - FStar_Extraction_ML_UEnv.uenv -> - Prims.bool -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.qualifier Prims.list -> - FStar_Syntax_Syntax.term Prims.list -> - FStar_Syntax_Syntax.univ_name Prims.list -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - (env_t * iface * FStar_Extraction_ML_Syntax.mlmodule1 - Prims.list)) - = - fun g -> - fun is_interface_val -> - fun lid -> - fun quals -> - fun attrs -> - fun univs -> - fun t -> - let uu___ = - let uu___1 = - FStar_Compiler_Util.for_some - (fun uu___2 -> - match uu___2 with - | FStar_Syntax_Syntax.Assumption -> true - | uu___3 -> false) quals in - Prims.op_Negation uu___1 in - if uu___ - then - let g1 = - FStar_Extraction_ML_UEnv.extend_with_tydef_declaration g - lid in - (g1, empty_iface, []) - else - (let uu___2 = FStar_Syntax_Util.arrow_formals t in - match uu___2 with - | (bs, uu___3) -> - let fv = - FStar_Syntax_Syntax.lid_as_fv lid - FStar_Pervasives_Native.None in - let lb = - let uu___4 = - FStar_Syntax_Util.abs bs - FStar_Syntax_Syntax.t_unit - FStar_Pervasives_Native.None in - { - FStar_Syntax_Syntax.lbname = - (FStar_Pervasives.Inr fv); - FStar_Syntax_Syntax.lbunivs = univs; - FStar_Syntax_Syntax.lbtyp = t; - FStar_Syntax_Syntax.lbeff = - FStar_Parser_Const.effect_Tot_lid; - FStar_Syntax_Syntax.lbdef = uu___4; - FStar_Syntax_Syntax.lbattrs = attrs; - FStar_Syntax_Syntax.lbpos = - (t.FStar_Syntax_Syntax.pos) - } in - let uu___4 = extract_typ_abbrev g quals attrs lb in - (match uu___4 with - | (g1, iface1, mods) -> - let iface2 = - if is_interface_val - then - let mlp = - FStar_Extraction_ML_UEnv.mlpath_of_lident - g1 lid in - let meta = extract_metadata attrs in - { - iface_module_name = - (empty_iface.iface_module_name); - iface_bindings = - (empty_iface.iface_bindings); - iface_tydefs = - [FStar_Pervasives.Inr - ((FStar_Pervasives_Native.snd mlp), - meta, - (FStar_Compiler_List.length bs))]; - iface_type_names = - (empty_iface.iface_type_names) - } - else iface1 in - (g1, iface2, mods))) -let (extract_reifiable_effect : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.eff_decl -> - (FStar_Extraction_ML_UEnv.uenv * iface * - FStar_Extraction_ML_Syntax.mlmodule1 Prims.list)) - = - fun g -> - fun ed -> - let extend_iface lid mlp exp exp_binding = - let fv = - FStar_Syntax_Syntax.lid_as_fv lid FStar_Pervasives_Native.None in - let lb = - { - FStar_Extraction_ML_Syntax.mllb_name = - (FStar_Pervasives_Native.snd mlp); - FStar_Extraction_ML_Syntax.mllb_tysc = - FStar_Pervasives_Native.None; - FStar_Extraction_ML_Syntax.mllb_add_unit = false; - FStar_Extraction_ML_Syntax.mllb_def = exp; - FStar_Extraction_ML_Syntax.mllb_attrs = []; - FStar_Extraction_ML_Syntax.mllb_meta = []; - FStar_Extraction_ML_Syntax.print_typ = false - } in - let uu___ = - FStar_Extraction_ML_Syntax.mk_mlmodule1 - (FStar_Extraction_ML_Syntax.MLM_Let - (FStar_Extraction_ML_Syntax.NonRec, [lb])) in - ((iface_of_bindings [(fv, exp_binding)]), uu___) in - let rec extract_fv tm = - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_ExtractionReify in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term tm in - FStar_Compiler_Util.print1 "extract_fv term: %s\n" uu___2 - else ()); - (let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress tm in - uu___2.FStar_Syntax_Syntax.n in - match uu___1 with - | FStar_Syntax_Syntax.Tm_uinst (tm1, uu___2) -> extract_fv tm1 - | FStar_Syntax_Syntax.Tm_fvar fv -> - let mlp = - FStar_Extraction_ML_UEnv.mlpath_of_lident g - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - let uu___2 = - FStar_Extraction_ML_UEnv.lookup_fv tm.FStar_Syntax_Syntax.pos - g fv in - (match uu___2 with - | { FStar_Extraction_ML_UEnv.exp_b_name = uu___3; - FStar_Extraction_ML_UEnv.exp_b_expr = uu___4; - FStar_Extraction_ML_UEnv.exp_b_tscheme = tysc; - FStar_Extraction_ML_UEnv.exp_b_eff = uu___5;_} -> - let uu___6 = - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.MLTY_Top - (FStar_Extraction_ML_Syntax.MLE_Name mlp) in - (uu___6, tysc)) - | uu___2 -> - let uu___3 = - let uu___4 = - FStar_Compiler_Range_Ops.string_of_range - tm.FStar_Syntax_Syntax.pos in - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term tm in - FStar_Compiler_Util.format2 "(%s) Not an fv: %s" uu___4 uu___5 in - failwith uu___3) in - let extract_action g1 a = - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_ExtractionReify in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - a.FStar_Syntax_Syntax.action_typ in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - a.FStar_Syntax_Syntax.action_defn in - FStar_Compiler_Util.print2 "Action type %s and term %s\n" uu___2 - uu___3 - else ()); - (let lbname = - let uu___1 = - FStar_Syntax_Syntax.new_bv - (FStar_Pervasives_Native.Some - ((a.FStar_Syntax_Syntax.action_defn).FStar_Syntax_Syntax.pos)) - FStar_Syntax_Syntax.tun in - FStar_Pervasives.Inl uu___1 in - let lb = - FStar_Syntax_Syntax.mk_lb - (lbname, (a.FStar_Syntax_Syntax.action_univs), - FStar_Parser_Const.effect_Tot_lid, - (a.FStar_Syntax_Syntax.action_typ), - (a.FStar_Syntax_Syntax.action_defn), [], - ((a.FStar_Syntax_Syntax.action_defn).FStar_Syntax_Syntax.pos)) in - let lbs = (false, [lb]) in - let action_lb = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = lbs; - FStar_Syntax_Syntax.body1 = - FStar_Syntax_Util.exp_false_bool - }) - (a.FStar_Syntax_Syntax.action_defn).FStar_Syntax_Syntax.pos in - let uu___1 = FStar_Extraction_ML_Term.term_as_mlexpr g1 action_lb in - match uu___1 with - | (a_let, uu___2, ty) -> - let uu___3 = - match a_let.FStar_Extraction_ML_Syntax.expr with - | FStar_Extraction_ML_Syntax.MLE_Let - ((uu___4, mllb::[]), uu___5) -> - (match mllb.FStar_Extraction_ML_Syntax.mllb_tysc with - | FStar_Pervasives_Native.Some tysc -> - ((mllb.FStar_Extraction_ML_Syntax.mllb_def), tysc) - | FStar_Pervasives_Native.None -> - failwith "No type scheme") - | uu___4 -> failwith "Impossible" in - (match uu___3 with - | (exp, tysc) -> - let uu___4 = - FStar_Extraction_ML_UEnv.extend_with_action_name g1 ed a - tysc in - (match uu___4 with - | (a_nm, a_lid, exp_b, g2) -> - ((let uu___6 = - FStar_Compiler_Effect.op_Bang dbg_ExtractionReify in - if uu___6 - then - let uu___7 = - FStar_Extraction_ML_Code.string_of_mlexpr a_nm - a_let in - FStar_Compiler_Util.print1 - "Extracted action term: %s\n" uu___7 - else ()); - (let uu___7 = - FStar_Compiler_Effect.op_Bang dbg_ExtractionReify in - if uu___7 - then - ((let uu___9 = - FStar_Extraction_ML_Code.string_of_mlty a_nm - (FStar_Pervasives_Native.snd tysc) in - FStar_Compiler_Util.print1 - "Extracted action type: %s\n" uu___9); - (let uu___9 = - FStar_Extraction_ML_Syntax.ty_param_names - (FStar_Pervasives_Native.fst tysc) in - FStar_Compiler_List.iter - (fun x -> - FStar_Compiler_Util.print1 - "and binders: %s\n" x) uu___9)) - else ()); - (let uu___7 = extend_iface a_lid a_nm exp exp_b in - match uu___7 with - | (iface1, impl) -> (g2, (iface1, impl))))))) in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Util.get_return_repr ed in - FStar_Compiler_Util.must uu___4 in - FStar_Pervasives_Native.snd uu___3 in - extract_fv uu___2 in - match uu___1 with - | (return_tm, ty_sc) -> - let uu___2 = - FStar_Extraction_ML_UEnv.extend_with_monad_op_name g ed - "return" ty_sc in - (match uu___2 with - | (return_nm, return_lid, return_b, g1) -> - let uu___3 = - extend_iface return_lid return_nm return_tm return_b in - (match uu___3 with | (iface1, impl) -> (g1, iface1, impl))) in - match uu___ with - | (g1, return_iface, return_decl) -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Util.get_bind_repr ed in - FStar_Compiler_Util.must uu___5 in - FStar_Pervasives_Native.snd uu___4 in - extract_fv uu___3 in - match uu___2 with - | (bind_tm, ty_sc) -> - let uu___3 = - FStar_Extraction_ML_UEnv.extend_with_monad_op_name g1 ed - "bind" ty_sc in - (match uu___3 with - | (bind_nm, bind_lid, bind_b, g2) -> - let uu___4 = - extend_iface bind_lid bind_nm bind_tm bind_b in - (match uu___4 with - | (iface1, impl) -> (g2, iface1, impl))) in - (match uu___1 with - | (g2, bind_iface, bind_decl) -> - let uu___2 = - FStar_Compiler_Util.fold_map extract_action g2 - ed.FStar_Syntax_Syntax.actions in - (match uu___2 with - | (g3, actions) -> - let uu___3 = FStar_Compiler_List.unzip actions in - (match uu___3 with - | (actions_iface, actions1) -> - let uu___4 = - iface_union_l (return_iface :: bind_iface :: - actions_iface) in - (g3, uu___4, (return_decl :: bind_decl :: actions1))))) -let (should_split_let_rec_types_and_terms : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.letbinding Prims.list -> Prims.bool) - = - fun env -> - fun lbs -> - let rec is_homogeneous out lbs1 = - match lbs1 with - | [] -> true - | lb::lbs_tail -> - let is_type = - FStar_Extraction_ML_Term.is_arity env - lb.FStar_Syntax_Syntax.lbtyp in - (match out with - | FStar_Pervasives_Native.None -> - is_homogeneous (FStar_Pervasives_Native.Some is_type) - lbs_tail - | FStar_Pervasives_Native.Some b when b = is_type -> - is_homogeneous (FStar_Pervasives_Native.Some is_type) - lbs_tail - | uu___ -> false) in - let uu___ = is_homogeneous FStar_Pervasives_Native.None lbs in - Prims.op_Negation uu___ -let (split_let_rec_types_and_terms : - FStar_Syntax_Syntax.sigelt -> - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.letbinding Prims.list -> - FStar_Syntax_Syntax.sigelt Prims.list) - = - fun se -> - fun env -> - fun lbs -> - let rec aux out mutuals lbs1 = - match lbs1 with - | [] -> (out, mutuals) - | lb::lbs_tail -> - let uu___ = aux out mutuals lbs_tail in - (match uu___ with - | (out1, mutuals1) -> - let uu___1 = - let uu___2 = - FStar_Extraction_ML_Term.is_arity env - lb.FStar_Syntax_Syntax.lbtyp in - Prims.op_Negation uu___2 in - if uu___1 - then (out1, (lb :: mutuals1)) - else - (let uu___3 = - FStar_Syntax_Util.abs_formals_maybe_unascribe_body - true lb.FStar_Syntax_Syntax.lbdef in - match uu___3 with - | (formals, body, rc_opt) -> - let body1 = - FStar_Syntax_Syntax.tconst - FStar_Parser_Const.c_true_lid in - let lbdef = - FStar_Syntax_Util.abs formals body1 - FStar_Pervasives_Native.None in - let lb1 = - { - FStar_Syntax_Syntax.lbname = - (lb.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = - (lb.FStar_Syntax_Syntax.lbtyp); - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = lbdef; - FStar_Syntax_Syntax.lbattrs = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - } in - let se1 = - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_let - { - FStar_Syntax_Syntax.lbs1 = - (false, [lb1]); - FStar_Syntax_Syntax.lids1 = [] - }); - FStar_Syntax_Syntax.sigrng = - (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se.FStar_Syntax_Syntax.sigopts) - } in - ((se1 :: out1), mutuals1))) in - let uu___ = aux [] [] lbs in - match uu___ with - | (sigs, lbs1) -> - let lb = - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Compiler_List.map - (fun lb1 -> - let uu___4 = - FStar_Compiler_Util.right - lb1.FStar_Syntax_Syntax.lbname in - FStar_Syntax_Syntax.lid_of_fv uu___4) lbs1 in - { - FStar_Syntax_Syntax.lbs1 = (true, lbs1); - FStar_Syntax_Syntax.lids1 = uu___3 - } in - FStar_Syntax_Syntax.Sig_let uu___2 in - { - FStar_Syntax_Syntax.sigel = uu___1; - FStar_Syntax_Syntax.sigrng = (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se.FStar_Syntax_Syntax.sigopts) - } in - let sigs1 = FStar_Compiler_List.op_At sigs [lb] in sigs1 -let (extract_let_rec_types : - FStar_Syntax_Syntax.sigelt -> - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.letbinding Prims.list -> - (FStar_Extraction_ML_UEnv.uenv * iface * - FStar_Extraction_ML_Syntax.mlmodule1 Prims.list)) - = - fun se -> - fun env -> - fun lbs -> - let uu___ = - FStar_Compiler_Util.for_some - (fun lb -> - let uu___1 = - FStar_Extraction_ML_Term.is_arity env - lb.FStar_Syntax_Syntax.lbtyp in - Prims.op_Negation uu___1) lbs in - if uu___ - then failwith "Impossible: mixed mutual types and terms" - else - (let uu___2 = - FStar_Compiler_List.fold_left - (fun uu___3 -> - fun lb -> - match uu___3 with - | (env1, iface_opt, impls) -> - let uu___4 = - extract_let_rec_type env1 - se.FStar_Syntax_Syntax.sigquals - se.FStar_Syntax_Syntax.sigattrs lb in - (match uu___4 with - | (env2, iface1, impl) -> - let iface_opt1 = - match iface_opt with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.Some iface1 - | FStar_Pervasives_Native.Some iface' -> - let uu___5 = iface_union iface' iface1 in - FStar_Pervasives_Native.Some uu___5 in - (env2, iface_opt1, (impl :: impls)))) - (env, FStar_Pervasives_Native.None, []) lbs in - match uu___2 with - | (env1, iface_opt, impls) -> - let uu___3 = FStar_Compiler_Option.get iface_opt in - (env1, uu___3, - (FStar_Compiler_List.flatten (FStar_Compiler_List.rev impls)))) -let (get_noextract_to : - FStar_Syntax_Syntax.sigelt -> - FStar_Options.codegen_t FStar_Pervasives_Native.option -> Prims.bool) - = - fun se -> - fun backend -> - FStar_Compiler_Util.for_some - (fun uu___ -> - let uu___1 = FStar_Syntax_Util.head_and_args uu___ in - match uu___1 with - | (hd, args) -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Subst.compress hd in - uu___4.FStar_Syntax_Syntax.n in - (uu___3, args) in - (match uu___2 with - | (FStar_Syntax_Syntax.Tm_fvar fv, (a, uu___3)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.noextract_to_attr - -> - let uu___4 = - FStar_Syntax_Embeddings_Base.try_unembed - FStar_Syntax_Embeddings.e_string a - FStar_Syntax_Embeddings_Base.id_norm_cb in - (match uu___4 with - | FStar_Pervasives_Native.Some s -> - (FStar_Compiler_Option.isSome backend) && - (let uu___5 = FStar_Options.parse_codegen s in - uu___5 = backend) - | FStar_Pervasives_Native.None -> false) - | uu___3 -> false)) se.FStar_Syntax_Syntax.sigattrs -let (sigelt_has_noextract : FStar_Syntax_Syntax.sigelt -> Prims.bool) = - fun se -> - let has_noextract_qualifier = - FStar_Compiler_List.contains FStar_Syntax_Syntax.NoExtract - se.FStar_Syntax_Syntax.sigquals in - let has_noextract_attribute = - let uu___ = FStar_Options.codegen () in get_noextract_to se uu___ in - let uu___ = FStar_Options.codegen () in - match uu___ with - | FStar_Pervasives_Native.Some (FStar_Options.Krml) -> - has_noextract_qualifier && has_noextract_attribute - | uu___1 -> has_noextract_qualifier || has_noextract_attribute -let (karamel_fixup_qual : - FStar_Syntax_Syntax.sigelt -> FStar_Syntax_Syntax.sigelt) = - fun se -> - let uu___ = - ((let uu___1 = FStar_Options.codegen () in - uu___1 = (FStar_Pervasives_Native.Some FStar_Options.Krml)) && - (get_noextract_to se - (FStar_Pervasives_Native.Some FStar_Options.Krml))) - && - (Prims.op_Negation - (FStar_Compiler_List.contains FStar_Syntax_Syntax.NoExtract - se.FStar_Syntax_Syntax.sigquals)) in - if uu___ - then - { - FStar_Syntax_Syntax.sigel = (se.FStar_Syntax_Syntax.sigel); - FStar_Syntax_Syntax.sigrng = (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = (FStar_Syntax_Syntax.NoExtract :: - (se.FStar_Syntax_Syntax.sigquals)); - FStar_Syntax_Syntax.sigmeta = (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = (se.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = (se.FStar_Syntax_Syntax.sigopts) - } - else se -let (mark_sigelt_erased : - FStar_Syntax_Syntax.sigelt -> - FStar_Extraction_ML_UEnv.uenv -> FStar_Extraction_ML_UEnv.uenv) - = - fun se -> - fun g -> - FStar_Extraction_ML_UEnv.debug g - (fun u -> - let uu___1 = FStar_Syntax_Print.sigelt_to_string_short se in - FStar_Compiler_Util.print1 ">>>> NOT extracting %s \n" uu___1); - FStar_Compiler_List.fold_right - (fun lid -> - fun g1 -> - let uu___1 = - FStar_Syntax_Syntax.lid_as_fv lid FStar_Pervasives_Native.None in - FStar_Extraction_ML_UEnv.extend_erased_fv g1 uu___1) - (FStar_Syntax_Util.lids_of_sigelt se) g -let (fixup_sigelt_extract_as : - FStar_Syntax_Syntax.sigelt -> FStar_Syntax_Syntax.sigelt) = - fun se -> - let uu___ = - let uu___1 = - FStar_Compiler_Util.find_map se.FStar_Syntax_Syntax.sigattrs - FStar_TypeChecker_Normalize.is_extract_as_attr in - ((se.FStar_Syntax_Syntax.sigel), uu___1) in - match uu___ with - | (FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (uu___1, lb::[]); - FStar_Syntax_Syntax.lids1 = lids;_}, - FStar_Pervasives_Native.Some impl) -> - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_let - { - FStar_Syntax_Syntax.lbs1 = - (true, - [{ - FStar_Syntax_Syntax.lbname = - (lb.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = - (lb.FStar_Syntax_Syntax.lbtyp); - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = impl; - FStar_Syntax_Syntax.lbattrs = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - }]); - FStar_Syntax_Syntax.lids1 = lids - }); - FStar_Syntax_Syntax.sigrng = (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = (se.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = (se.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = (se.FStar_Syntax_Syntax.sigopts) - } - | uu___1 -> se -let rec (extract_sigelt_iface : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.sigelt -> (FStar_Extraction_ML_UEnv.uenv * iface)) - = - fun g -> - fun se -> - let uu___ = sigelt_has_noextract se in - if uu___ - then let g1 = mark_sigelt_erased se g in (g1, empty_iface) - else - (let se1 = karamel_fixup_qual se in - let se2 = fixup_sigelt_extract_as se1 in - match se2.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_bundle uu___2 -> - extract_bundle_iface g se2 - | FStar_Syntax_Syntax.Sig_inductive_typ uu___2 -> - extract_bundle_iface g se2 - | FStar_Syntax_Syntax.Sig_datacon uu___2 -> - extract_bundle_iface g se2 - | FStar_Syntax_Syntax.Sig_declare_typ - { FStar_Syntax_Syntax.lid2 = lid; - FStar_Syntax_Syntax.us2 = univs; FStar_Syntax_Syntax.t2 = t;_} - when FStar_Extraction_ML_Term.is_arity g t -> - let uu___2 = - extract_type_declaration g true lid - se2.FStar_Syntax_Syntax.sigquals - se2.FStar_Syntax_Syntax.sigattrs univs t in - (match uu___2 with | (env, iface1, uu___3) -> (env, iface1)) - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (false, lb::[]); - FStar_Syntax_Syntax.lids1 = uu___2;_} - when - FStar_Extraction_ML_Term.is_arity g lb.FStar_Syntax_Syntax.lbtyp - -> - let uu___3 = - FStar_Compiler_Util.for_some - (fun uu___4 -> - match uu___4 with - | FStar_Syntax_Syntax.Projector uu___5 -> true - | uu___5 -> false) se2.FStar_Syntax_Syntax.sigquals in - if uu___3 - then (g, empty_iface) - else - (let uu___5 = - extract_typ_abbrev g se2.FStar_Syntax_Syntax.sigquals - se2.FStar_Syntax_Syntax.sigattrs lb in - match uu___5 with | (env, iface1, uu___6) -> (env, iface1)) - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (true, lbs); - FStar_Syntax_Syntax.lids1 = uu___2;_} - when should_split_let_rec_types_and_terms g lbs -> - let ses = split_let_rec_types_and_terms se2 g lbs in - let iface1 = - let uu___3 = FStar_Extraction_ML_UEnv.current_module_of_uenv g in - { - iface_module_name = uu___3; - iface_bindings = (empty_iface.iface_bindings); - iface_tydefs = (empty_iface.iface_tydefs); - iface_type_names = (empty_iface.iface_type_names) - } in - FStar_Compiler_List.fold_left - (fun uu___3 -> - fun se3 -> - match uu___3 with - | (g1, out) -> - let uu___4 = extract_sigelt_iface g1 se3 in - (match uu___4 with - | (g2, mls) -> - let uu___5 = iface_union out mls in (g2, uu___5))) - (g, iface1) ses - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (true, lbs); - FStar_Syntax_Syntax.lids1 = uu___2;_} - when - FStar_Compiler_Util.for_some - (fun lb -> - FStar_Extraction_ML_Term.is_arity g - lb.FStar_Syntax_Syntax.lbtyp) lbs - -> - let uu___3 = extract_let_rec_types se2 g lbs in - (match uu___3 with | (env, iface1, uu___4) -> (env, iface1)) - | FStar_Syntax_Syntax.Sig_declare_typ - { FStar_Syntax_Syntax.lid2 = lid; - FStar_Syntax_Syntax.us2 = uu___2; - FStar_Syntax_Syntax.t2 = t;_} - -> - let quals = se2.FStar_Syntax_Syntax.sigquals in - let uu___3 = - (FStar_Compiler_List.contains FStar_Syntax_Syntax.Assumption - quals) - && - (let uu___4 = - let uu___5 = FStar_Extraction_ML_UEnv.tcenv_of_uenv g in - FStar_TypeChecker_Util.must_erase_for_extraction uu___5 t in - Prims.op_Negation uu___4) in - if uu___3 - then - let uu___4 = - let uu___5 = - let uu___6 = let uu___7 = always_fail lid t in [uu___7] in - (false, uu___6) in - FStar_Extraction_ML_Term.extract_lb_iface g uu___5 in - (match uu___4 with - | (g1, bindings) -> (g1, (iface_of_bindings bindings))) - else (g, empty_iface) - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (false, lb::[]); - FStar_Syntax_Syntax.lids1 = uu___2;_} - when - Prims.uu___is_Cons - (se2.FStar_Syntax_Syntax.sigmeta).FStar_Syntax_Syntax.sigmeta_extension_data - -> - let uu___3 = - FStar_Compiler_List.tryPick - (fun uu___4 -> - match uu___4 with - | (ext, blob) -> - let uu___5 = lookup_extension_extractor ext in - (match uu___5 with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some extractor -> - FStar_Pervasives_Native.Some - (ext, blob, extractor))) - (se2.FStar_Syntax_Syntax.sigmeta).FStar_Syntax_Syntax.sigmeta_extension_data in - (match uu___3 with - | FStar_Pervasives_Native.None -> - let uu___4 = - FStar_Extraction_ML_Term.extract_lb_iface g (false, [lb]) in - (match uu___4 with - | (g1, bindings) -> (g1, (iface_of_bindings bindings))) - | FStar_Pervasives_Native.Some (ext, blob, extractor) -> - let res = extractor.extract_sigelt_iface g se2 blob in - (match res with - | FStar_Pervasives.Inl res1 -> res1 - | FStar_Pervasives.Inr err -> - let uu___4 = - FStar_Compiler_Util.format2 - "Extension %s failed to extract iface: %s" ext err in - FStar_Errors.raise_error - FStar_Syntax_Syntax.has_range_sigelt se2 - FStar_Errors_Codes.Fatal_ExtractionUnsupported () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4))) - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = lbs; - FStar_Syntax_Syntax.lids1 = uu___2;_} - -> - let uu___3 = FStar_Extraction_ML_Term.extract_lb_iface g lbs in - (match uu___3 with - | (g1, bindings) -> (g1, (iface_of_bindings bindings))) - | FStar_Syntax_Syntax.Sig_assume uu___2 -> (g, empty_iface) - | FStar_Syntax_Syntax.Sig_sub_effect uu___2 -> (g, empty_iface) - | FStar_Syntax_Syntax.Sig_effect_abbrev uu___2 -> (g, empty_iface) - | FStar_Syntax_Syntax.Sig_polymonadic_bind uu___2 -> - (g, empty_iface) - | FStar_Syntax_Syntax.Sig_polymonadic_subcomp uu___2 -> - (g, empty_iface) - | FStar_Syntax_Syntax.Sig_pragma p -> - (FStar_Syntax_Util.process_pragma p - se2.FStar_Syntax_Syntax.sigrng; - (g, empty_iface)) - | FStar_Syntax_Syntax.Sig_splice uu___2 -> - failwith "impossible: trying to extract splice" - | FStar_Syntax_Syntax.Sig_fail uu___2 -> - failwith "impossible: trying to extract Sig_fail" - | FStar_Syntax_Syntax.Sig_new_effect ed -> - let uu___2 = - (let uu___3 = - let uu___4 = FStar_Extraction_ML_UEnv.tcenv_of_uenv g in - FStar_TypeChecker_Util.effect_extraction_mode uu___4 - ed.FStar_Syntax_Syntax.mname in - uu___3 = FStar_Syntax_Syntax.Extract_reify) && - (FStar_Compiler_List.isEmpty ed.FStar_Syntax_Syntax.binders) in - if uu___2 - then - let uu___3 = extract_reifiable_effect g ed in - (match uu___3 with | (env, iface1, uu___4) -> (env, iface1)) - else (g, empty_iface)) -let (extract_iface' : - env_t -> - FStar_Syntax_Syntax.modul -> (FStar_Extraction_ML_UEnv.uenv * iface)) - = - fun g -> - fun modul -> - let uu___ = FStar_Options.interactive () in - if uu___ - then (g, empty_iface) - else - (let uu___2 = FStar_Options.restore_cmd_line_options true in - let decls = modul.FStar_Syntax_Syntax.declarations in - let iface1 = - let uu___3 = FStar_Extraction_ML_UEnv.current_module_of_uenv g in - { - iface_module_name = uu___3; - iface_bindings = (empty_iface.iface_bindings); - iface_tydefs = (empty_iface.iface_tydefs); - iface_type_names = (empty_iface.iface_type_names) - } in - let res = - FStar_Compiler_List.fold_left - (fun uu___3 -> - fun se -> - match uu___3 with - | (g1, iface2) -> - let uu___4 = extract_sigelt_iface g1 se in - (match uu___4 with - | (g2, iface') -> - let uu___5 = iface_union iface2 iface' in - (g2, uu___5))) (g, iface1) decls in - (let uu___4 = FStar_Options.restore_cmd_line_options true in ()); - res) -let (extract_iface : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.modul -> (FStar_Extraction_ML_UEnv.uenv * iface)) - = - fun g -> - fun modul -> - let uu___ = - FStar_Syntax_Unionfind.with_uf_enabled - (fun uu___1 -> - let uu___2 = FStar_Compiler_Debug.any () in - if uu___2 - then - let uu___3 = - let uu___4 = - FStar_Ident.string_of_lid modul.FStar_Syntax_Syntax.name in - FStar_Compiler_Util.format1 "Extracted interface of %s" - uu___4 in - FStar_Compiler_Util.measure_execution_time uu___3 - (fun uu___4 -> extract_iface' g modul) - else extract_iface' g modul) in - match uu___ with - | (g1, iface1) -> - let uu___1 = - FStar_Extraction_ML_UEnv.with_typars_env g1 - (fun e -> - let iface_tydefs = - FStar_Compiler_List.map - (fun uu___2 -> - match uu___2 with - | FStar_Pervasives.Inl td -> - let uu___3 = - let uu___4 = - FStar_Extraction_ML_UEnv.tydef_mlpath td in - FStar_Pervasives_Native.snd uu___4 in - let uu___4 = - FStar_Extraction_ML_UEnv.tydef_meta td in - let uu___5 = - let uu___6 = - FStar_Extraction_ML_UEnv.tydef_def td in - FStar_Pervasives.Inl uu___6 in - (uu___3, uu___4, uu___5) - | FStar_Pervasives.Inr (p, m, n) -> - (p, m, (FStar_Pervasives.Inr n))) - iface1.iface_tydefs in - let uu___2 = - FStar_Extraction_ML_UEnv.extend_with_module_name g1 - modul.FStar_Syntax_Syntax.name in - match uu___2 with - | (module_name, uu___3) -> - let e1 = - FStar_Extraction_ML_RemoveUnusedParameters.set_current_module - e module_name in - FStar_Extraction_ML_RemoveUnusedParameters.elim_tydefs - e1 iface_tydefs) in - (match uu___1 with - | (g2, uu___2) -> - let uu___3 = FStar_Extraction_ML_UEnv.exit_module g2 in - (uu___3, iface1)) -let (extract_bundle : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.sigelt -> - (FStar_Extraction_ML_UEnv.uenv * FStar_Extraction_ML_Syntax.mlmodule1 - Prims.list)) - = - fun env -> - fun se -> - let extract_ctor env_iparams ml_tyvars env1 ctor = - let mlt = - let uu___ = - FStar_Extraction_ML_Term.term_as_mlty env_iparams ctor.dtyp in - FStar_Extraction_ML_Util.eraseTypeDeep - (FStar_Extraction_ML_Util.udelta_unfold env_iparams) uu___ in - let steps = - [FStar_TypeChecker_Env.Inlining; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.EraseUniverses; - FStar_TypeChecker_Env.AllowUnboundUniverses; - FStar_TypeChecker_Env.ForExtraction] in - let names = - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Extraction_ML_UEnv.tcenv_of_uenv env_iparams in - FStar_TypeChecker_Normalize.normalize steps uu___3 ctor.dtyp in - FStar_Syntax_Subst.compress uu___2 in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; - FStar_Syntax_Syntax.comp = uu___1;_} - -> - FStar_Compiler_List.map - (fun uu___2 -> - match uu___2 with - | { - FStar_Syntax_Syntax.binder_bv = - { FStar_Syntax_Syntax.ppname = ppname; - FStar_Syntax_Syntax.index = uu___3; - FStar_Syntax_Syntax.sort = uu___4;_}; - FStar_Syntax_Syntax.binder_qual = uu___5; - FStar_Syntax_Syntax.binder_positivity = uu___6; - FStar_Syntax_Syntax.binder_attrs = uu___7;_} -> - FStar_Ident.string_of_id ppname) bs - | uu___1 -> [] in - let tys = (ml_tyvars, mlt) in - let fvv = - FStar_Syntax_Syntax.lid_as_fv ctor.dname - FStar_Pervasives_Native.None in - let uu___ = FStar_Extraction_ML_UEnv.extend_fv env1 fvv tys false in - match uu___ with - | (env2, mls, uu___1) -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_Extraction_ML_Util.argTypes mlt in - FStar_Compiler_List.zip names uu___4 in - (mls, uu___3) in - (env2, uu___2) in - let extract_one_family env1 ind = - let uu___ = binders_as_mlty_binders env1 ind.iparams in - match uu___ with - | (env_iparams, vars) -> - let uu___1 = - FStar_Compiler_Util.fold_map (extract_ctor env_iparams vars) - env1 ind.idatas in - (match uu___1 with - | (env2, ctors) -> - let uu___2 = FStar_Syntax_Util.arrow_formals ind.ityp in - (match uu___2 with - | (indices, uu___3) -> - let ml_params = - let uu___4 = - FStar_Compiler_List.mapi - (fun i -> - fun uu___5 -> - let uu___6 = - let uu___7 = - FStar_Compiler_Util.string_of_int i in - Prims.strcat "'dummyV" uu___7 in - { - FStar_Extraction_ML_Syntax.ty_param_name = - uu___6; - FStar_Extraction_ML_Syntax.ty_param_attrs - = [] - }) indices in - FStar_Compiler_List.append vars uu___4 in - let uu___4 = - let uu___5 = - FStar_Compiler_Util.find_opt - (fun uu___6 -> - match uu___6 with - | FStar_Syntax_Syntax.RecordType uu___7 -> - true - | uu___7 -> false) ind.iquals in - match uu___5 with - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.RecordType (ns, ids)) -> - let uu___6 = FStar_Compiler_List.hd ctors in - (match uu___6 with - | (uu___7, c_ty) -> - let uu___8 = - FStar_Compiler_List.fold_right2 - (fun id -> - fun uu___9 -> - fun uu___10 -> - match (uu___9, uu___10) with - | ((uu___11, ty), (fields, g)) -> - let uu___12 = - FStar_Extraction_ML_UEnv.extend_record_field_name - g ((ind.iname), id) in - (match uu___12 with - | (mlid, g1) -> - (((mlid, ty) :: fields), - g1))) ids c_ty - ([], env2) in - (match uu___8 with - | (fields, g) -> - ((FStar_Pervasives_Native.Some - (FStar_Extraction_ML_Syntax.MLTD_Record - fields)), g))) - | uu___6 when - (FStar_Compiler_List.length ctors) = - Prims.int_zero - -> (FStar_Pervasives_Native.None, env2) - | uu___6 -> - ((FStar_Pervasives_Native.Some - (FStar_Extraction_ML_Syntax.MLTD_DType ctors)), - env2) in - (match uu___4 with - | (tbody, env3) -> - let td = - let uu___5 = - let uu___6 = - FStar_Extraction_ML_UEnv.mlpath_of_lident - env3 ind.iname in - FStar_Pervasives_Native.snd uu___6 in - { - FStar_Extraction_ML_Syntax.tydecl_assumed = - false; - FStar_Extraction_ML_Syntax.tydecl_name = - uu___5; - FStar_Extraction_ML_Syntax.tydecl_ignored = - FStar_Pervasives_Native.None; - FStar_Extraction_ML_Syntax.tydecl_parameters = - ml_params; - FStar_Extraction_ML_Syntax.tydecl_meta = - (ind.imetadata); - FStar_Extraction_ML_Syntax.tydecl_defn = tbody - } in - (env3, td)))) in - let mlattrs = extract_attrs env se.FStar_Syntax_Syntax.sigattrs in - match ((se.FStar_Syntax_Syntax.sigel), - (se.FStar_Syntax_Syntax.sigquals)) - with - | (FStar_Syntax_Syntax.Sig_bundle - { - FStar_Syntax_Syntax.ses = - { - FStar_Syntax_Syntax.sigel = FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = l; - FStar_Syntax_Syntax.us1 = uu___; - FStar_Syntax_Syntax.t1 = t; - FStar_Syntax_Syntax.ty_lid = uu___1; - FStar_Syntax_Syntax.num_ty_params = uu___2; - FStar_Syntax_Syntax.mutuals1 = uu___3; - FStar_Syntax_Syntax.injective_type_params1 = uu___4;_}; - FStar_Syntax_Syntax.sigrng = uu___5; - FStar_Syntax_Syntax.sigquals = uu___6; - FStar_Syntax_Syntax.sigmeta = uu___7; - FStar_Syntax_Syntax.sigattrs = uu___8; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___9; - FStar_Syntax_Syntax.sigopts = uu___10;_}::[]; - FStar_Syntax_Syntax.lids = uu___11;_}, - (FStar_Syntax_Syntax.ExceptionConstructor)::[]) -> - let uu___12 = extract_ctor env [] env { dname = l; dtyp = t } in - (match uu___12 with - | (env1, ctor) -> - let uu___13 = - let uu___14 = - FStar_Extraction_ML_Syntax.mk_mlmodule1_with_attrs - (FStar_Extraction_ML_Syntax.MLM_Exn ctor) mlattrs in - [uu___14] in - (env1, uu___13)) - | (FStar_Syntax_Syntax.Sig_bundle - { FStar_Syntax_Syntax.ses = ses; FStar_Syntax_Syntax.lids = uu___;_}, - quals) -> - let uu___1 = - FStar_Syntax_Util.has_attribute se.FStar_Syntax_Syntax.sigattrs - FStar_Parser_Const.erasable_attr in - if uu___1 - then (env, []) - else - (let uu___3 = bundle_as_inductive_families env ses quals in - match uu___3 with - | (env1, ifams) -> - let uu___4 = - FStar_Compiler_Util.fold_map extract_one_family env1 ifams in - (match uu___4 with - | (env2, td) -> - let uu___5 = - let uu___6 = - FStar_Extraction_ML_Syntax.mk_mlmodule1_with_attrs - (FStar_Extraction_ML_Syntax.MLM_Ty td) mlattrs in - [uu___6] in - (env2, uu___5))) - | uu___ -> failwith "Unexpected signature element" -let (lb_is_irrelevant : - env_t -> FStar_Syntax_Syntax.letbinding -> Prims.bool) = - fun g -> - fun lb -> - ((let uu___ = FStar_Extraction_ML_UEnv.tcenv_of_uenv g in - FStar_TypeChecker_Env.non_informative uu___ - lb.FStar_Syntax_Syntax.lbtyp) - && - (let uu___ = - FStar_Extraction_ML_Term.is_arity g lb.FStar_Syntax_Syntax.lbtyp in - Prims.op_Negation uu___)) - && - (FStar_Syntax_Util.is_pure_or_ghost_effect - lb.FStar_Syntax_Syntax.lbeff) -let (lb_is_tactic : env_t -> FStar_Syntax_Syntax.letbinding -> Prims.bool) = - fun g -> - fun lb -> - let uu___ = - FStar_Syntax_Util.is_pure_effect lb.FStar_Syntax_Syntax.lbeff in - if uu___ - then - let uu___1 = - FStar_Syntax_Util.arrow_formals_comp_ln - lb.FStar_Syntax_Syntax.lbtyp in - match uu___1 with - | (bs, c) -> - let c_eff_name = - let uu___2 = FStar_Extraction_ML_UEnv.tcenv_of_uenv g in - FStar_TypeChecker_Env.norm_eff_name uu___2 - (FStar_Syntax_Util.comp_effect_name c) in - FStar_Ident.lid_equals c_eff_name - FStar_Parser_Const.effect_TAC_lid - else false -let rec (extract_sig : - env_t -> - FStar_Syntax_Syntax.sigelt -> - (env_t * FStar_Extraction_ML_Syntax.mlmodule1 Prims.list)) - = - fun g -> - fun se -> - let uu___ = - let uu___1 = FStar_Syntax_Print.sigelt_to_string_short se in - FStar_Compiler_Util.format1 - "While extracting top-level definition `%s`" uu___1 in - FStar_Errors.with_ctx uu___ - (fun uu___1 -> - FStar_Extraction_ML_UEnv.debug g - (fun u -> - let uu___3 = FStar_Syntax_Print.sigelt_to_string_short se in - FStar_Compiler_Util.print1 ">>>> extract_sig %s \n" uu___3); - (let uu___3 = sigelt_has_noextract se in - if uu___3 - then let g1 = mark_sigelt_erased se g in (g1, []) - else - (let se1 = karamel_fixup_qual se in - let se2 = fixup_sigelt_extract_as se1 in - match se2.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_bundle uu___5 -> - let uu___6 = extract_bundle g se2 in - (match uu___6 with - | (g1, ses) -> - let uu___7 = - let uu___8 = - FStar_Extraction_ML_RegEmb.maybe_register_plugin - g1 se2 in - FStar_Compiler_List.op_At ses uu___8 in - (g1, uu___7)) - | FStar_Syntax_Syntax.Sig_inductive_typ uu___5 -> - let uu___6 = extract_bundle g se2 in - (match uu___6 with - | (g1, ses) -> - let uu___7 = - let uu___8 = - FStar_Extraction_ML_RegEmb.maybe_register_plugin - g1 se2 in - FStar_Compiler_List.op_At ses uu___8 in - (g1, uu___7)) - | FStar_Syntax_Syntax.Sig_datacon uu___5 -> - let uu___6 = extract_bundle g se2 in - (match uu___6 with - | (g1, ses) -> - let uu___7 = - let uu___8 = - FStar_Extraction_ML_RegEmb.maybe_register_plugin - g1 se2 in - FStar_Compiler_List.op_At ses uu___8 in - (g1, uu___7)) - | FStar_Syntax_Syntax.Sig_new_effect ed when - let uu___5 = FStar_Extraction_ML_UEnv.tcenv_of_uenv g in - FStar_TypeChecker_Env.is_reifiable_effect uu___5 - ed.FStar_Syntax_Syntax.mname - -> - let uu___5 = extract_reifiable_effect g ed in - (match uu___5 with | (env, _iface, impl) -> (env, impl)) - | FStar_Syntax_Syntax.Sig_splice uu___5 -> - failwith "impossible: trying to extract splice" - | FStar_Syntax_Syntax.Sig_fail uu___5 -> - failwith "impossible: trying to extract Sig_fail" - | FStar_Syntax_Syntax.Sig_new_effect uu___5 -> (g, []) - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (uu___5, lbs); - FStar_Syntax_Syntax.lids1 = uu___6;_} - when FStar_Compiler_List.for_all (lb_is_irrelevant g) lbs - -> (g, []) - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (uu___5, lbs); - FStar_Syntax_Syntax.lids1 = uu___6;_} - when - (let uu___7 = FStar_Options.codegen () in - uu___7 <> - (FStar_Pervasives_Native.Some FStar_Options.Plugin)) - && (FStar_Compiler_List.for_all (lb_is_tactic g) lbs) - -> (g, []) - | FStar_Syntax_Syntax.Sig_declare_typ - { FStar_Syntax_Syntax.lid2 = lid; - FStar_Syntax_Syntax.us2 = univs; - FStar_Syntax_Syntax.t2 = t;_} - when FStar_Extraction_ML_Term.is_arity g t -> - let uu___5 = - extract_type_declaration g false lid - se2.FStar_Syntax_Syntax.sigquals - se2.FStar_Syntax_Syntax.sigattrs univs t in - (match uu___5 with | (env, uu___6, impl) -> (env, impl)) - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (false, lb::[]); - FStar_Syntax_Syntax.lids1 = uu___5;_} - when - FStar_Extraction_ML_Term.is_arity g - lb.FStar_Syntax_Syntax.lbtyp - -> - let uu___6 = - FStar_Compiler_Util.for_some - (fun uu___7 -> - match uu___7 with - | FStar_Syntax_Syntax.Projector uu___8 -> true - | uu___8 -> false) se2.FStar_Syntax_Syntax.sigquals in - if uu___6 - then (g, []) - else - (let uu___8 = - extract_typ_abbrev g se2.FStar_Syntax_Syntax.sigquals - se2.FStar_Syntax_Syntax.sigattrs lb in - match uu___8 with | (env, uu___9, impl) -> (env, impl)) - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (true, lbs); - FStar_Syntax_Syntax.lids1 = uu___5;_} - when should_split_let_rec_types_and_terms g lbs -> - let ses = split_let_rec_types_and_terms se2 g lbs in - FStar_Compiler_List.fold_left - (fun uu___6 -> - fun se3 -> - match uu___6 with - | (g1, out) -> - let uu___7 = extract_sig g1 se3 in - (match uu___7 with - | (g2, mls) -> - (g2, (FStar_Compiler_List.op_At out mls)))) - (g, []) ses - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (true, lbs); - FStar_Syntax_Syntax.lids1 = uu___5;_} - when - FStar_Compiler_Util.for_some - (fun lb -> - FStar_Extraction_ML_Term.is_arity g - lb.FStar_Syntax_Syntax.lbtyp) lbs - -> - let uu___6 = extract_let_rec_types se2 g lbs in - (match uu___6 with | (env, uu___7, impl) -> (env, impl)) - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (false, lb::[]); - FStar_Syntax_Syntax.lids1 = uu___5;_} - when - Prims.uu___is_Cons - (se2.FStar_Syntax_Syntax.sigmeta).FStar_Syntax_Syntax.sigmeta_extension_data - -> - let uu___6 = - FStar_Compiler_List.tryPick - (fun uu___7 -> - match uu___7 with - | (ext, blob) -> - let uu___8 = lookup_extension_extractor ext in - (match uu___8 with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some extractor -> - FStar_Pervasives_Native.Some - (ext, blob, extractor))) - (se2.FStar_Syntax_Syntax.sigmeta).FStar_Syntax_Syntax.sigmeta_extension_data in - (match uu___6 with - | FStar_Pervasives_Native.None -> extract_sig_let g se2 - | FStar_Pervasives_Native.Some (ext, blob, extractor) -> - let uu___7 = extractor.extract_sigelt g se2 blob in - (match uu___7 with - | FStar_Pervasives.Inl decls -> - let meta = - extract_metadata - se2.FStar_Syntax_Syntax.sigattrs in - let mlattrs = - extract_attrs g - se2.FStar_Syntax_Syntax.sigattrs in - FStar_Compiler_List.fold_left - (fun uu___8 -> - fun d -> - match uu___8 with - | (g1, decls1) -> - (match d.FStar_Extraction_ML_Syntax.mlmodule1_m - with - | FStar_Extraction_ML_Syntax.MLM_Let - (maybe_rec, mllb::[]) -> - let uu___9 = - let uu___10 = - FStar_Compiler_Util.must - mllb.FStar_Extraction_ML_Syntax.mllb_tysc in - FStar_Extraction_ML_UEnv.extend_lb - g1 - lb.FStar_Syntax_Syntax.lbname - lb.FStar_Syntax_Syntax.lbtyp - uu___10 - mllb.FStar_Extraction_ML_Syntax.mllb_add_unit in - (match uu___9 with - | (g2, mlid, uu___10) -> - let mllb1 = - { - FStar_Extraction_ML_Syntax.mllb_name - = mlid; - FStar_Extraction_ML_Syntax.mllb_tysc - = - (mllb.FStar_Extraction_ML_Syntax.mllb_tysc); - FStar_Extraction_ML_Syntax.mllb_add_unit - = - (mllb.FStar_Extraction_ML_Syntax.mllb_add_unit); - FStar_Extraction_ML_Syntax.mllb_def - = - (mllb.FStar_Extraction_ML_Syntax.mllb_def); - FStar_Extraction_ML_Syntax.mllb_attrs - = mlattrs; - FStar_Extraction_ML_Syntax.mllb_meta - = meta; - FStar_Extraction_ML_Syntax.print_typ - = - (mllb.FStar_Extraction_ML_Syntax.print_typ) - } in - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Extraction_ML_Syntax.mk_mlmodule1_with_attrs - (FStar_Extraction_ML_Syntax.MLM_Let - (maybe_rec, - [mllb1])) - mlattrs in - [uu___13] in - FStar_Compiler_List.op_At - decls1 uu___12 in - (g2, uu___11)) - | uu___9 -> - let uu___10 = - let uu___11 = - FStar_Class_Show.show - FStar_Extraction_ML_Syntax.showable_mlmodule1 - d in - FStar_Compiler_Util.format1 - "Unexpected ML decl returned by the extension: %s" - uu___11 in - failwith uu___10)) (g, []) decls - | FStar_Pervasives.Inr err -> - let uu___8 = - FStar_Compiler_Util.format2 - "Extension %s failed to extract term: %s" - ext err in - FStar_Errors.raise_error - FStar_Syntax_Syntax.has_range_sigelt se2 - FStar_Errors_Codes.Fatal_ExtractionUnsupported - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___8))) - | FStar_Syntax_Syntax.Sig_let uu___5 -> extract_sig_let g se2 - | FStar_Syntax_Syntax.Sig_declare_typ - { FStar_Syntax_Syntax.lid2 = lid; - FStar_Syntax_Syntax.us2 = uu___5; - FStar_Syntax_Syntax.t2 = t;_} - -> - let quals = se2.FStar_Syntax_Syntax.sigquals in - let uu___6 = - (FStar_Compiler_List.contains - FStar_Syntax_Syntax.Assumption quals) - && - (let uu___7 = - let uu___8 = - FStar_Extraction_ML_UEnv.tcenv_of_uenv g in - FStar_TypeChecker_Util.must_erase_for_extraction - uu___8 t in - Prims.op_Negation uu___7) in - if uu___6 - then - let always_fail1 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = always_fail lid t in [uu___11] in - (false, uu___10) in - { - FStar_Syntax_Syntax.lbs1 = uu___9; - FStar_Syntax_Syntax.lids1 = [] - } in - FStar_Syntax_Syntax.Sig_let uu___8 in - { - FStar_Syntax_Syntax.sigel = uu___7; - FStar_Syntax_Syntax.sigrng = - (se2.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se2.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se2.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se2.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se2.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se2.FStar_Syntax_Syntax.sigopts) - } in - let uu___7 = extract_sig g always_fail1 in - (match uu___7 with - | (g1, mlm) -> - let uu___8 = - FStar_Compiler_Util.find_map quals - (fun uu___9 -> - match uu___9 with - | FStar_Syntax_Syntax.Discriminator l -> - FStar_Pervasives_Native.Some l - | uu___10 -> FStar_Pervasives_Native.None) in - (match uu___8 with - | FStar_Pervasives_Native.Some l -> - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Extraction_ML_Util.mlloc_of_range - se2.FStar_Syntax_Syntax.sigrng in - FStar_Extraction_ML_Syntax.MLM_Loc - uu___12 in - FStar_Extraction_ML_Syntax.mk_mlmodule1 - uu___11 in - let uu___11 = - let uu___12 = - FStar_Extraction_ML_Term.ind_discriminator_body - g1 lid l in - [uu___12] in - uu___10 :: uu___11 in - (g1, uu___9) - | uu___9 -> - let uu___10 = - FStar_Compiler_Util.find_map quals - (fun uu___11 -> - match uu___11 with - | FStar_Syntax_Syntax.Projector - (l, uu___12) -> - FStar_Pervasives_Native.Some l - | uu___12 -> - FStar_Pervasives_Native.None) in - (match uu___10 with - | FStar_Pervasives_Native.Some uu___11 -> - (g1, []) - | uu___11 -> (g1, mlm)))) - else (g, []) - | FStar_Syntax_Syntax.Sig_assume uu___5 -> (g, []) - | FStar_Syntax_Syntax.Sig_sub_effect uu___5 -> (g, []) - | FStar_Syntax_Syntax.Sig_effect_abbrev uu___5 -> (g, []) - | FStar_Syntax_Syntax.Sig_polymonadic_bind uu___5 -> (g, []) - | FStar_Syntax_Syntax.Sig_polymonadic_subcomp uu___5 -> - (g, []) - | FStar_Syntax_Syntax.Sig_pragma p -> - (FStar_Syntax_Util.process_pragma p - se2.FStar_Syntax_Syntax.sigrng; - (g, []))))) -and (extract_sig_let : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.sigelt -> - (FStar_Extraction_ML_UEnv.uenv * FStar_Extraction_ML_Syntax.mlmodule1 - Prims.list)) - = - fun g -> - fun se -> - if - Prims.op_Negation - (FStar_Syntax_Syntax.uu___is_Sig_let se.FStar_Syntax_Syntax.sigel) - then failwith "Impossible: should only be called with Sig_let" - else - (let uu___1 = se.FStar_Syntax_Syntax.sigel in - match uu___1 with - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = lbs; - FStar_Syntax_Syntax.lids1 = uu___2;_} - -> - let attrs = se.FStar_Syntax_Syntax.sigattrs in - let quals = se.FStar_Syntax_Syntax.sigquals in - let maybe_postprocess_lbs lbs1 = - let post_tau = - let uu___3 = - FStar_Syntax_Util.extract_attr' - FStar_Parser_Const.postprocess_extr_with attrs in - match uu___3 with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some - (uu___4, (tau, FStar_Pervasives_Native.None)::uu___5) -> - FStar_Pervasives_Native.Some tau - | FStar_Pervasives_Native.Some uu___4 -> - (FStar_Errors.log_issue - FStar_Syntax_Syntax.has_range_sigelt se - FStar_Errors_Codes.Warning_UnrecognizedAttribute () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Ill-formed application of 'postprocess_for_extraction_with'"); - FStar_Pervasives_Native.None) in - let postprocess_lb tau lb = - let env = FStar_Extraction_ML_UEnv.tcenv_of_uenv g in - let lbdef = - let uu___3 = - let uu___4 = - let uu___5 = FStar_TypeChecker_Env.current_module env in - FStar_Ident.string_of_lid uu___5 in - FStar_Pervasives_Native.Some uu___4 in - FStar_Profiling.profile - (fun uu___4 -> - FStar_TypeChecker_Env.postprocess env tau - lb.FStar_Syntax_Syntax.lbtyp - lb.FStar_Syntax_Syntax.lbdef) uu___3 - "FStar.Extraction.ML.Module.post_process_for_extraction" in - { - FStar_Syntax_Syntax.lbname = - (lb.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = (lb.FStar_Syntax_Syntax.lbtyp); - FStar_Syntax_Syntax.lbeff = (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = lbdef; - FStar_Syntax_Syntax.lbattrs = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = (lb.FStar_Syntax_Syntax.lbpos) - } in - match post_tau with - | FStar_Pervasives_Native.None -> lbs1 - | FStar_Pervasives_Native.Some tau -> - let uu___3 = - FStar_Compiler_List.map (postprocess_lb tau) - (FStar_Pervasives_Native.snd lbs1) in - ((FStar_Pervasives_Native.fst lbs1), uu___3) in - let maybe_normalize_for_extraction lbs1 = - let norm_steps = - let uu___3 = - FStar_Syntax_Util.extract_attr' - FStar_Parser_Const.normalize_for_extraction_lid attrs in - match uu___3 with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some - (uu___4, (steps, FStar_Pervasives_Native.None)::uu___5) - -> - let steps1 = - let uu___6 = FStar_Extraction_ML_UEnv.tcenv_of_uenv g in - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Zeta; - FStar_TypeChecker_Env.Iota; - FStar_TypeChecker_Env.Primops] uu___6 steps in - let uu___6 = - FStar_TypeChecker_Primops_Base.try_unembed_simple - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_norm_step) steps1 in - (match uu___6 with - | FStar_Pervasives_Native.Some steps2 -> - let uu___7 = - FStar_TypeChecker_Cfg.translate_norm_steps steps2 in - FStar_Pervasives_Native.Some uu___7 - | uu___7 -> - ((let uu___9 = - let uu___10 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term steps1 in - FStar_Compiler_Util.format1 - "Ill-formed application of 'normalize_for_extraction': normalization steps '%s' could not be interpreted" - uu___10 in - FStar_Errors.log_issue - FStar_Syntax_Syntax.has_range_sigelt se - FStar_Errors_Codes.Warning_UnrecognizedAttribute - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___9)); - FStar_Pervasives_Native.None)) - | FStar_Pervasives_Native.Some uu___4 -> - (FStar_Errors.log_issue - FStar_Syntax_Syntax.has_range_sigelt se - FStar_Errors_Codes.Warning_UnrecognizedAttribute () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Ill-formed application of 'normalize_for_extraction'"); - FStar_Pervasives_Native.None) in - let norm_one_lb steps lb = - let env = FStar_Extraction_ML_UEnv.tcenv_of_uenv g in - let env1 = - { - FStar_TypeChecker_Env.solver = - (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (env.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = true; - FStar_TypeChecker_Env.core_check = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env.FStar_TypeChecker_Env.missing_decl) - } in - let lbd = - let uu___3 = - let uu___4 = - let uu___5 = FStar_TypeChecker_Env.current_module env1 in - FStar_Ident.string_of_lid uu___5 in - FStar_Pervasives_Native.Some uu___4 in - FStar_Profiling.profile - (fun uu___4 -> - FStar_TypeChecker_Normalize.normalize steps env1 - lb.FStar_Syntax_Syntax.lbdef) uu___3 - "FStar.Extraction.ML.Module.normalize_for_extraction" in - { - FStar_Syntax_Syntax.lbname = - (lb.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = (lb.FStar_Syntax_Syntax.lbtyp); - FStar_Syntax_Syntax.lbeff = (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = lbd; - FStar_Syntax_Syntax.lbattrs = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = (lb.FStar_Syntax_Syntax.lbpos) - } in - match norm_steps with - | FStar_Pervasives_Native.None -> lbs1 - | FStar_Pervasives_Native.Some steps -> - let uu___3 = - FStar_Compiler_List.map (norm_one_lb steps) - (FStar_Pervasives_Native.snd lbs1) in - ((FStar_Pervasives_Native.fst lbs1), uu___3) in - let uu___3 = - let lbs1 = - let uu___4 = maybe_postprocess_lbs lbs in - maybe_normalize_for_extraction uu___4 in - let uu___4 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = lbs1; - FStar_Syntax_Syntax.body1 = - FStar_Syntax_Util.exp_false_bool - }) se.FStar_Syntax_Syntax.sigrng in - FStar_Extraction_ML_Term.term_as_mlexpr g uu___4 in - (match uu___3 with - | (ml_let, uu___4, uu___5) -> - let mlattrs = - extract_attrs g se.FStar_Syntax_Syntax.sigattrs in - (match ml_let.FStar_Extraction_ML_Syntax.expr with - | FStar_Extraction_ML_Syntax.MLE_Let - ((flavor, bindings), uu___6) -> - let flags = - FStar_Compiler_List.choose flag_of_qual quals in - let flags' = extract_metadata attrs in - let uu___7 = - FStar_Compiler_List.fold_left2 - (fun uu___8 -> - fun ml_lb -> - fun uu___9 -> - match (uu___8, uu___9) with - | ((env, ml_lbs), - { FStar_Syntax_Syntax.lbname = lbname; - FStar_Syntax_Syntax.lbunivs = uu___10; - FStar_Syntax_Syntax.lbtyp = t; - FStar_Syntax_Syntax.lbeff = uu___11; - FStar_Syntax_Syntax.lbdef = uu___12; - FStar_Syntax_Syntax.lbattrs = uu___13; - FStar_Syntax_Syntax.lbpos = uu___14;_}) - -> - if - FStar_Compiler_List.contains - FStar_Extraction_ML_Syntax.Erased - ml_lb.FStar_Extraction_ML_Syntax.mllb_meta - then (env, ml_lbs) - else - (let lb_lid = - let uu___16 = - let uu___17 = - FStar_Compiler_Util.right - lbname in - uu___17.FStar_Syntax_Syntax.fv_name in - uu___16.FStar_Syntax_Syntax.v in - let flags'' = - let uu___16 = - let uu___17 = - FStar_Syntax_Subst.compress t in - uu___17.FStar_Syntax_Syntax.n in - match uu___16 with - | FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 = - uu___17; - FStar_Syntax_Syntax.comp = - { - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Comp - { - FStar_Syntax_Syntax.comp_univs - = uu___18; - FStar_Syntax_Syntax.effect_name - = e; - FStar_Syntax_Syntax.result_typ - = uu___19; - FStar_Syntax_Syntax.effect_args - = uu___20; - FStar_Syntax_Syntax.flags - = uu___21;_}; - FStar_Syntax_Syntax.pos - = uu___22; - FStar_Syntax_Syntax.vars - = uu___23; - FStar_Syntax_Syntax.hash_code - = uu___24;_};_} - when - let uu___25 = - FStar_Ident.string_of_lid e in - uu___25 = - "FStar.HyperStack.ST.StackInline" - -> - [FStar_Extraction_ML_Syntax.StackInline] - | uu___17 -> [] in - let meta = - FStar_Compiler_List.op_At flags - (FStar_Compiler_List.op_At - flags' flags'') in - let ml_lb1 = - { - FStar_Extraction_ML_Syntax.mllb_name - = - (ml_lb.FStar_Extraction_ML_Syntax.mllb_name); - FStar_Extraction_ML_Syntax.mllb_tysc - = - (ml_lb.FStar_Extraction_ML_Syntax.mllb_tysc); - FStar_Extraction_ML_Syntax.mllb_add_unit - = - (ml_lb.FStar_Extraction_ML_Syntax.mllb_add_unit); - FStar_Extraction_ML_Syntax.mllb_def - = - (ml_lb.FStar_Extraction_ML_Syntax.mllb_def); - FStar_Extraction_ML_Syntax.mllb_attrs - = mlattrs; - FStar_Extraction_ML_Syntax.mllb_meta - = meta; - FStar_Extraction_ML_Syntax.print_typ - = - (ml_lb.FStar_Extraction_ML_Syntax.print_typ) - } in - let uu___16 = - let uu___17 = - FStar_Compiler_Util.for_some - (fun uu___18 -> - match uu___18 with - | FStar_Syntax_Syntax.Projector - uu___19 -> true - | uu___19 -> false) quals in - if uu___17 - then - let uu___18 = - let uu___19 = - FStar_Compiler_Util.right - lbname in - let uu___20 = - FStar_Compiler_Util.must - ml_lb1.FStar_Extraction_ML_Syntax.mllb_tysc in - FStar_Extraction_ML_UEnv.extend_fv - env uu___19 uu___20 - ml_lb1.FStar_Extraction_ML_Syntax.mllb_add_unit in - match uu___18 with - | (env1, mls, uu___19) -> - (env1, - { - FStar_Extraction_ML_Syntax.mllb_name - = mls; - FStar_Extraction_ML_Syntax.mllb_tysc - = - (ml_lb1.FStar_Extraction_ML_Syntax.mllb_tysc); - FStar_Extraction_ML_Syntax.mllb_add_unit - = - (ml_lb1.FStar_Extraction_ML_Syntax.mllb_add_unit); - FStar_Extraction_ML_Syntax.mllb_def - = - (ml_lb1.FStar_Extraction_ML_Syntax.mllb_def); - FStar_Extraction_ML_Syntax.mllb_attrs - = - (ml_lb1.FStar_Extraction_ML_Syntax.mllb_attrs); - FStar_Extraction_ML_Syntax.mllb_meta - = - (ml_lb1.FStar_Extraction_ML_Syntax.mllb_meta); - FStar_Extraction_ML_Syntax.print_typ - = - (ml_lb1.FStar_Extraction_ML_Syntax.print_typ) - }) - else - (let uu___19 = - let uu___20 = - FStar_Compiler_Util.must - ml_lb1.FStar_Extraction_ML_Syntax.mllb_tysc in - FStar_Extraction_ML_UEnv.extend_lb - env lbname t uu___20 - ml_lb1.FStar_Extraction_ML_Syntax.mllb_add_unit in - match uu___19 with - | (env1, uu___20, uu___21) -> - (env1, ml_lb1)) in - match uu___16 with - | (g1, ml_lb2) -> - (g1, (ml_lb2 :: ml_lbs)))) - (g, []) bindings (FStar_Pervasives_Native.snd lbs) in - (match uu___7 with - | (g1, ml_lbs') -> - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Extraction_ML_Util.mlloc_of_range - se.FStar_Syntax_Syntax.sigrng in - FStar_Extraction_ML_Syntax.MLM_Loc - uu___12 in - FStar_Extraction_ML_Syntax.mk_mlmodule1 - uu___11 in - let uu___11 = - let uu___12 = - FStar_Extraction_ML_Syntax.mk_mlmodule1_with_attrs - (FStar_Extraction_ML_Syntax.MLM_Let - (flavor, - (FStar_Compiler_List.rev ml_lbs'))) - mlattrs in - [uu___12] in - uu___10 :: uu___11 in - let uu___10 = - FStar_Extraction_ML_RegEmb.maybe_register_plugin - g1 se in - FStar_Compiler_List.op_At uu___9 uu___10 in - (g1, uu___8)) - | uu___6 -> - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Extraction_ML_UEnv.current_module_of_uenv - g in - FStar_Extraction_ML_Code.string_of_mlexpr uu___9 - ml_let in - FStar_Compiler_Util.format1 - "Impossible: Translated a let to a non-let: %s" - uu___8 in - failwith uu___7))) -let (extract' : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.modul -> - (FStar_Extraction_ML_UEnv.uenv * FStar_Extraction_ML_Syntax.mllib - FStar_Pervasives_Native.option)) - = - fun g -> - fun m -> - let uu___ = FStar_Options.restore_cmd_line_options true in - let uu___1 = - FStar_Extraction_ML_UEnv.extend_with_module_name g - m.FStar_Syntax_Syntax.name in - match uu___1 with - | (name, g1) -> - let g2 = - let uu___2 = - let uu___3 = FStar_Extraction_ML_UEnv.tcenv_of_uenv g1 in - FStar_TypeChecker_Env.set_current_module uu___3 - m.FStar_Syntax_Syntax.name in - FStar_Extraction_ML_UEnv.set_tcenv g1 uu___2 in - let g3 = FStar_Extraction_ML_UEnv.set_current_module g2 name in - let uu___2 = - FStar_Compiler_Util.fold_map - (fun g4 -> - fun se -> - let uu___3 = FStar_Compiler_Debug.any () in - if uu___3 - then - let nm = - let uu___4 = - FStar_Compiler_List.map FStar_Ident.string_of_lid - (FStar_Syntax_Util.lids_of_sigelt se) in - FStar_Compiler_String.concat ", " uu___4 in - (FStar_Compiler_Util.print1 "+++About to extract {%s}\n" - nm; - (let r = - let uu___5 = - FStar_Compiler_Util.format1 "---Extracted {%s}" nm in - FStar_Compiler_Util.measure_execution_time uu___5 - (fun uu___6 -> extract_sig g4 se) in - (let uu___6 = - FStar_Class_Show.show - FStar_Extraction_ML_Syntax.showable_mlmodule - (FStar_Pervasives_Native.snd r) in - FStar_Compiler_Util.print1 "Extraction result: %s\n" - uu___6); - r)) - else extract_sig g4 se) g3 - m.FStar_Syntax_Syntax.declarations in - (match uu___2 with - | (g4, sigs) -> - let mlm = FStar_Compiler_List.flatten sigs in - let is_karamel = - let uu___3 = FStar_Options.codegen () in - uu___3 = (FStar_Pervasives_Native.Some FStar_Options.Krml) in - let uu___3 = - (let uu___4 = - FStar_Ident.string_of_lid m.FStar_Syntax_Syntax.name in - uu___4 <> "Prims") && - (is_karamel || - (Prims.op_Negation m.FStar_Syntax_Syntax.is_interface)) in - if uu___3 - then - ((let uu___5 = - let uu___6 = FStar_Options.silent () in - Prims.op_Negation uu___6 in - if uu___5 - then - let uu___6 = - FStar_Ident.string_of_lid m.FStar_Syntax_Syntax.name in - FStar_Compiler_Util.print1 "Extracted module %s\n" - uu___6 - else ()); - (g4, - (FStar_Pervasives_Native.Some - (FStar_Extraction_ML_Syntax.MLLib - [(name, (FStar_Pervasives_Native.Some ([], mlm)), - (FStar_Extraction_ML_Syntax.MLLib []))])))) - else (g4, FStar_Pervasives_Native.None)) -let (extract : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.modul -> - (FStar_Extraction_ML_UEnv.uenv * FStar_Extraction_ML_Syntax.mllib - FStar_Pervasives_Native.option)) - = - fun g -> - fun m -> - (let uu___1 = FStar_Options.restore_cmd_line_options true in ()); - (let tgt = - let uu___1 = FStar_Options.codegen () in - match uu___1 with - | FStar_Pervasives_Native.None -> - failwith "Impossible: We're in extract, codegen must be set!" - | FStar_Pervasives_Native.Some t -> t in - (let uu___2 = - let uu___3 = - let uu___4 = FStar_Ident.string_of_lid m.FStar_Syntax_Syntax.name in - FStar_Options.should_extract uu___4 tgt in - Prims.op_Negation uu___3 in - if uu___2 - then - let uu___3 = - let uu___4 = FStar_Ident.string_of_lid m.FStar_Syntax_Syntax.name in - FStar_Compiler_Util.format1 - "Extract called on a module %s that should not be extracted" - uu___4 in - failwith uu___3 - else ()); - (let uu___2 = FStar_Options.interactive () in - if uu___2 - then (g, FStar_Pervasives_Native.None) - else - (let nm = FStar_Ident.string_of_lid m.FStar_Syntax_Syntax.name in - let uu___4 = - FStar_Syntax_Unionfind.with_uf_enabled - (fun uu___5 -> - FStar_Errors.with_ctx - (Prims.strcat "While extracting module " nm) - (fun uu___6 -> - FStar_Profiling.profile (fun uu___7 -> extract' g m) - (FStar_Pervasives_Native.Some nm) - "FStar.Extraction.ML.Modul.extract")) in - match uu___4 with - | (g1, mllib) -> - let uu___5 = - match mllib with - | FStar_Pervasives_Native.None -> (g1, mllib) - | FStar_Pervasives_Native.Some mllib1 -> - let uu___6 = - FStar_Extraction_ML_UEnv.with_typars_env g1 - (fun e -> - FStar_Extraction_ML_RemoveUnusedParameters.elim_mllib - e mllib1) in - (match uu___6 with - | (g2, mllib2) -> - (g2, (FStar_Pervasives_Native.Some mllib2))) in - (match uu___5 with - | (g2, mllib1) -> - ((let uu___7 = - FStar_Options.restore_cmd_line_options true in - ()); - (let uu___7 = FStar_Extraction_ML_UEnv.exit_module g2 in - (uu___7, mllib1))))))) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Extraction_ML_RegEmb.ml b/ocaml/fstar-lib/generated/FStar_Extraction_ML_RegEmb.ml deleted file mode 100644 index 92639a319ea..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Extraction_ML_RegEmb.ml +++ /dev/null @@ -1,2376 +0,0 @@ -open Prims -exception NoEmbedding of Prims.string -let (uu___is_NoEmbedding : Prims.exn -> Prims.bool) = - fun projectee -> - match projectee with | NoEmbedding uu___ -> true | uu___ -> false -let (__proj__NoEmbedding__item__uu___ : Prims.exn -> Prims.string) = - fun projectee -> match projectee with | NoEmbedding uu___ -> uu___ -exception Unsupported of Prims.string -let (uu___is_Unsupported : Prims.exn -> Prims.bool) = - fun projectee -> - match projectee with | Unsupported uu___ -> true | uu___ -> false -let (__proj__Unsupported__item__uu___ : Prims.exn -> Prims.string) = - fun projectee -> match projectee with | Unsupported uu___ -> uu___ -let splitlast : 'uuuuu . 'uuuuu Prims.list -> ('uuuuu Prims.list * 'uuuuu) = - fun s -> - let uu___ = FStar_Compiler_List.rev s in - match uu___ with | x::xs -> ((FStar_Compiler_List.rev xs), x) -let (mk : - FStar_Extraction_ML_Syntax.mlexpr' -> FStar_Extraction_ML_Syntax.mlexpr) = - fun e -> - FStar_Extraction_ML_Syntax.with_ty FStar_Extraction_ML_Syntax.MLTY_Top e -let (ml_name : FStar_Ident.lid -> FStar_Extraction_ML_Syntax.mlexpr) = - fun l -> - let s = FStar_Ident.path_of_lid l in - let uu___ = splitlast s in - match uu___ with - | (ns, id) -> mk (FStar_Extraction_ML_Syntax.MLE_Name (ns, id)) -let (ml_name' : Prims.string -> FStar_Extraction_ML_Syntax.mlexpr) = - fun s -> let uu___ = FStar_Ident.lid_of_str s in ml_name uu___ -let (ml_ctor : - FStar_Ident.lid -> - FStar_Extraction_ML_Syntax.mlexpr Prims.list -> - FStar_Extraction_ML_Syntax.mlexpr) - = - fun l -> - fun args -> - let s = FStar_Ident.path_of_lid l in - let uu___ = splitlast s in - match uu___ with - | (ns, id) -> mk (FStar_Extraction_ML_Syntax.MLE_CTor ((ns, id), args)) -let (ml_record : - FStar_Ident.lid -> - (Prims.string * FStar_Extraction_ML_Syntax.mlexpr) Prims.list -> - FStar_Extraction_ML_Syntax.mlexpr) - = - fun l -> - fun args -> - let s = FStar_Ident.path_of_lid l in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Ident.ident_of_lid l in - FStar_Ident.string_of_id uu___3 in - ([], uu___2, args) in - FStar_Extraction_ML_Syntax.MLE_Record uu___1 in - mk uu___ -let (mk_binder : - FStar_Extraction_ML_Syntax.mlident -> - FStar_Extraction_ML_Syntax.mlty -> FStar_Extraction_ML_Syntax.mlbinder) - = - fun x -> - fun t -> - { - FStar_Extraction_ML_Syntax.mlbinder_name = x; - FStar_Extraction_ML_Syntax.mlbinder_ty = t; - FStar_Extraction_ML_Syntax.mlbinder_attrs = [] - } -let (ml_lam : - FStar_Extraction_ML_Syntax.mlident -> - FStar_Extraction_ML_Syntax.mlexpr -> FStar_Extraction_ML_Syntax.mlexpr) - = - fun nm -> - fun e -> - mk - (FStar_Extraction_ML_Syntax.MLE_Fun - ([mk_binder nm FStar_Extraction_ML_Syntax.MLTY_Top], e)) -let (ml_none : FStar_Extraction_ML_Syntax.mlexpr) = - mk - (FStar_Extraction_ML_Syntax.MLE_Name - (["FStar"; "Pervasives"; "Native"], "None")) -let (ml_some : FStar_Extraction_ML_Syntax.mlexpr) = - mk - (FStar_Extraction_ML_Syntax.MLE_Name - (["FStar"; "Pervasives"; "Native"], "Some")) -let (tm_fvar_lid : FStar_Ident.lident) = - FStar_Ident.lid_of_str "FStar.Syntax.Syntax.Tm_fvar" -let (fv_eq_lid_lid : FStar_Ident.lident) = - FStar_Ident.lid_of_str "FStar.Syntax.Syntax.fv_eq_lid" -let (s_tdataconstr_lid : FStar_Ident.lident) = - FStar_Ident.lid_of_str "FStar.Syntax.Syntax.tdataconstr" -let (lid_of_str_lid : FStar_Ident.lident) = - FStar_Ident.lid_of_str "FStar.Ident.lid_of_str" -let (mk_app_lid : FStar_Ident.lident) = - FStar_Ident.lid_of_str "FStar.Syntax.Util.mk_app" -let (nil_lid : FStar_Ident.lident) = FStar_Ident.lid_of_str "Prims.Nil" -let (cons_lid : FStar_Ident.lident) = FStar_Ident.lid_of_str "Prims.Cons" -let (embed_lid : FStar_Ident.lident) = - FStar_Ident.lid_of_str "FStar.Syntax.Embeddings.Base.extracted_embed" -let (unembed_lid : FStar_Ident.lident) = - FStar_Ident.lid_of_str "FStar.Syntax.Embeddings.Base.extracted_unembed" -let (bind_opt_lid : FStar_Ident.lident) = - FStar_Ident.lid_of_str "FStar.Compiler.Util.bind_opt" -let (ml_nbe_unsupported : FStar_Extraction_ML_Syntax.mlexpr) = - let hd = - mk - (FStar_Extraction_ML_Syntax.MLE_Name - (["FStar"; "TypeChecker"; "NBETerm"], "e_unsupported")) in - mk - (FStar_Extraction_ML_Syntax.MLE_App - (hd, [FStar_Extraction_ML_Syntax.ml_unit])) -let (ml_magic : FStar_Extraction_ML_Syntax.mlexpr) = - mk - (FStar_Extraction_ML_Syntax.MLE_Coerce - (FStar_Extraction_ML_Syntax.ml_unit, - FStar_Extraction_ML_Syntax.MLTY_Top, - FStar_Extraction_ML_Syntax.MLTY_Top)) -let (as_name : - FStar_Extraction_ML_Syntax.mlpath -> FStar_Extraction_ML_Syntax.mlexpr) = - fun mlp -> - FStar_Extraction_ML_Syntax.with_ty FStar_Extraction_ML_Syntax.MLTY_Top - (FStar_Extraction_ML_Syntax.MLE_Name mlp) -let (ml_failwith : Prims.string -> FStar_Extraction_ML_Syntax.mlexpr) = - fun s -> - let uu___ = - let uu___1 = - let uu___2 = as_name ([], "failwith") in - let uu___3 = - let uu___4 = - mk - (FStar_Extraction_ML_Syntax.MLE_Const - (FStar_Extraction_ML_Syntax.MLC_String s)) in - [uu___4] in - (uu___2, uu___3) in - FStar_Extraction_ML_Syntax.MLE_App uu___1 in - mk uu___ -let rec (as_ml_list : - FStar_Extraction_ML_Syntax.mlexpr Prims.list -> - FStar_Extraction_ML_Syntax.mlexpr) - = - fun ts -> - match ts with - | [] -> ml_ctor nil_lid [] - | t::ts1 -> - let uu___ = - let uu___1 = let uu___2 = as_ml_list ts1 in [uu___2] in t :: uu___1 in - ml_ctor cons_lid uu___ -let rec (pats_to_list_pat : - FStar_Extraction_ML_Syntax.mlpattern Prims.list -> - FStar_Extraction_ML_Syntax.mlpattern) - = - fun vs -> - match vs with - | [] -> FStar_Extraction_ML_Syntax.MLP_CTor ((["Prims"], "Nil"), []) - | p::ps -> - let uu___ = - let uu___1 = - let uu___2 = let uu___3 = pats_to_list_pat ps in [uu___3] in p :: - uu___2 in - ((["Prims"], "Cons"), uu___1) in - FStar_Extraction_ML_Syntax.MLP_CTor uu___ -let (fresh : Prims.string -> Prims.string) = - let r = FStar_Compiler_Util.mk_ref Prims.int_zero in - fun s -> - let v = FStar_Compiler_Effect.op_Bang r in - FStar_Compiler_Effect.op_Colon_Equals r (v + Prims.int_one); - Prims.strcat s (Prims.strcat "_" (Prims.string_of_int v)) -let (not_implemented_warning : - FStar_Compiler_Range_Type.range -> Prims.string -> Prims.string -> unit) = - fun r -> - fun t -> - fun msg -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Compiler_Util.format1 - "Plugin `%s' can not run natively because:" t in - FStar_Errors_Msg.text uu___3 in - let uu___3 = FStar_Errors_Msg.text msg in - FStar_Pprint.prefix (Prims.of_int (2)) Prims.int_one uu___2 - uu___3 in - let uu___2 = - let uu___3 = - let uu___4 = FStar_Errors_Msg.text "Use --warn_error -" in - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Errors.lookup - FStar_Errors_Codes.Warning_PluginNotImplemented in - FStar_Errors.error_number uu___8 in - FStar_Class_PP.pp FStar_Class_PP.pp_int uu___7 in - let uu___7 = FStar_Errors_Msg.text "to carry on." in - FStar_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in - FStar_Pprint.op_Hat_Hat uu___4 uu___5 in - [uu___3] in - uu___1 :: uu___2 in - FStar_Errors.log_issue FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Warning_PluginNotImplemented () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___) -type embedding_data = - { - arity: Prims.int ; - syn_emb: FStar_Ident.lid ; - nbe_emb: FStar_Ident.lid FStar_Pervasives_Native.option } -let (__proj__Mkembedding_data__item__arity : embedding_data -> Prims.int) = - fun projectee -> - match projectee with | { arity; syn_emb; nbe_emb;_} -> arity -let (__proj__Mkembedding_data__item__syn_emb : - embedding_data -> FStar_Ident.lid) = - fun projectee -> - match projectee with | { arity; syn_emb; nbe_emb;_} -> syn_emb -let (__proj__Mkembedding_data__item__nbe_emb : - embedding_data -> FStar_Ident.lid FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with | { arity; syn_emb; nbe_emb;_} -> nbe_emb -let (builtin_embeddings : (FStar_Ident.lident * embedding_data) Prims.list) = - let syn_emb_lid s = - FStar_Ident.lid_of_path ["FStar"; "Syntax"; "Embeddings"; s] - FStar_Compiler_Range_Type.dummyRange in - let nbe_emb_lid s = - FStar_Ident.lid_of_path ["FStar"; "TypeChecker"; "NBETerm"; s] - FStar_Compiler_Range_Type.dummyRange in - let refl_emb_lid s = - FStar_Ident.lid_of_path ["FStar"; "Reflection"; "V2"; "Embeddings"; s] - FStar_Compiler_Range_Type.dummyRange in - let nbe_refl_emb_lid s = - FStar_Ident.lid_of_path ["FStar"; "Reflection"; "V2"; "NBEEmbeddings"; s] - FStar_Compiler_Range_Type.dummyRange in - let uu___ = - let uu___1 = - let uu___2 = syn_emb_lid "e_int" in - let uu___3 = - let uu___4 = nbe_emb_lid "e_int" in - FStar_Pervasives_Native.Some uu___4 in - { arity = Prims.int_zero; syn_emb = uu___2; nbe_emb = uu___3 } in - (FStar_Parser_Const.int_lid, uu___1) in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = syn_emb_lid "e_bool" in - let uu___5 = - let uu___6 = nbe_emb_lid "e_bool" in - FStar_Pervasives_Native.Some uu___6 in - { arity = Prims.int_zero; syn_emb = uu___4; nbe_emb = uu___5 } in - (FStar_Parser_Const.bool_lid, uu___3) in - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = syn_emb_lid "e_unit" in - let uu___7 = - let uu___8 = nbe_emb_lid "e_unit" in - FStar_Pervasives_Native.Some uu___8 in - { arity = Prims.int_zero; syn_emb = uu___6; nbe_emb = uu___7 } in - (FStar_Parser_Const.unit_lid, uu___5) in - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = syn_emb_lid "e_string" in - let uu___9 = - let uu___10 = nbe_emb_lid "e_string" in - FStar_Pervasives_Native.Some uu___10 in - { arity = Prims.int_zero; syn_emb = uu___8; nbe_emb = uu___9 } in - (FStar_Parser_Const.string_lid, uu___7) in - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = syn_emb_lid "e_norm_step" in - let uu___11 = - let uu___12 = nbe_emb_lid "e_norm_step" in - FStar_Pervasives_Native.Some uu___12 in - { arity = Prims.int_zero; syn_emb = uu___10; nbe_emb = uu___11 - } in - (FStar_Parser_Const.norm_step_lid, uu___9) in - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = syn_emb_lid "e___range" in - let uu___13 = - let uu___14 = nbe_emb_lid "e___range" in - FStar_Pervasives_Native.Some uu___14 in - { - arity = Prims.int_zero; - syn_emb = uu___12; - nbe_emb = uu___13 - } in - (FStar_Parser_Const.__range_lid, uu___11) in - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = syn_emb_lid "e_vconfig" in - let uu___15 = - let uu___16 = nbe_emb_lid "e_vconfig" in - FStar_Pervasives_Native.Some uu___16 in - { - arity = Prims.int_zero; - syn_emb = uu___14; - nbe_emb = uu___15 - } in - (FStar_Parser_Const.vconfig_lid, uu___13) in - let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = syn_emb_lid "e_list" in - let uu___17 = - let uu___18 = nbe_emb_lid "e_list" in - FStar_Pervasives_Native.Some uu___18 in - { - arity = Prims.int_one; - syn_emb = uu___16; - nbe_emb = uu___17 - } in - (FStar_Parser_Const.list_lid, uu___15) in - let uu___15 = - let uu___16 = - let uu___17 = - let uu___18 = syn_emb_lid "e_option" in - let uu___19 = - let uu___20 = nbe_emb_lid "e_option" in - FStar_Pervasives_Native.Some uu___20 in - { - arity = Prims.int_one; - syn_emb = uu___18; - nbe_emb = uu___19 - } in - (FStar_Parser_Const.option_lid, uu___17) in - let uu___17 = - let uu___18 = - let uu___19 = - let uu___20 = syn_emb_lid "e_sealed" in - let uu___21 = - let uu___22 = nbe_emb_lid "e_sealed" in - FStar_Pervasives_Native.Some uu___22 in - { - arity = Prims.int_one; - syn_emb = uu___20; - nbe_emb = uu___21 - } in - (FStar_Parser_Const.sealed_lid, uu___19) in - let uu___19 = - let uu___20 = - let uu___21 = - FStar_Parser_Const.mk_tuple_lid (Prims.of_int (2)) - FStar_Compiler_Range_Type.dummyRange in - let uu___22 = - let uu___23 = syn_emb_lid "e_tuple2" in - let uu___24 = - let uu___25 = nbe_emb_lid "e_tuple2" in - FStar_Pervasives_Native.Some uu___25 in - { - arity = (Prims.of_int (2)); - syn_emb = uu___23; - nbe_emb = uu___24 - } in - (uu___21, uu___22) in - let uu___21 = - let uu___22 = - let uu___23 = - FStar_Parser_Const.mk_tuple_lid - (Prims.of_int (3)) - FStar_Compiler_Range_Type.dummyRange in - let uu___24 = - let uu___25 = syn_emb_lid "e_tuple3" in - let uu___26 = - let uu___27 = nbe_emb_lid "e_tuple3" in - FStar_Pervasives_Native.Some uu___27 in - { - arity = (Prims.of_int (3)); - syn_emb = uu___25; - nbe_emb = uu___26 - } in - (uu___23, uu___24) in - let uu___23 = - let uu___24 = - let uu___25 = - let uu___26 = syn_emb_lid "e_either" in - let uu___27 = - let uu___28 = nbe_emb_lid "e_either" in - FStar_Pervasives_Native.Some uu___28 in - { - arity = (Prims.of_int (2)); - syn_emb = uu___26; - nbe_emb = uu___27 - } in - (FStar_Parser_Const.either_lid, uu___25) in - let uu___25 = - let uu___26 = - let uu___27 = - FStar_Reflection_V2_Constants.fstar_refl_types_lid - "namedv" in - let uu___28 = - let uu___29 = refl_emb_lid "e_namedv" in - let uu___30 = - let uu___31 = nbe_refl_emb_lid "e_namedv" in - FStar_Pervasives_Native.Some uu___31 in - { - arity = Prims.int_zero; - syn_emb = uu___29; - nbe_emb = uu___30 - } in - (uu___27, uu___28) in - let uu___27 = - let uu___28 = - let uu___29 = - FStar_Reflection_V2_Constants.fstar_refl_types_lid - "bv" in - let uu___30 = - let uu___31 = refl_emb_lid "e_bv" in - let uu___32 = - let uu___33 = nbe_refl_emb_lid "e_bv" in - FStar_Pervasives_Native.Some uu___33 in - { - arity = Prims.int_zero; - syn_emb = uu___31; - nbe_emb = uu___32 - } in - (uu___29, uu___30) in - let uu___29 = - let uu___30 = - let uu___31 = - FStar_Reflection_V2_Constants.fstar_refl_types_lid - "binder" in - let uu___32 = - let uu___33 = refl_emb_lid "e_binder" in - let uu___34 = - let uu___35 = - nbe_refl_emb_lid "e_binder" in - FStar_Pervasives_Native.Some uu___35 in - { - arity = Prims.int_zero; - syn_emb = uu___33; - nbe_emb = uu___34 - } in - (uu___31, uu___32) in - let uu___31 = - let uu___32 = - let uu___33 = - FStar_Reflection_V2_Constants.fstar_refl_types_lid - "term" in - let uu___34 = - let uu___35 = refl_emb_lid "e_term" in - let uu___36 = - let uu___37 = - nbe_refl_emb_lid "e_term" in - FStar_Pervasives_Native.Some uu___37 in - { - arity = Prims.int_zero; - syn_emb = uu___35; - nbe_emb = uu___36 - } in - (uu___33, uu___34) in - let uu___33 = - let uu___34 = - let uu___35 = - FStar_Reflection_V2_Constants.fstar_refl_types_lid - "env" in - let uu___36 = - let uu___37 = refl_emb_lid "e_env" in - let uu___38 = - let uu___39 = - nbe_refl_emb_lid "e_env" in - FStar_Pervasives_Native.Some - uu___39 in - { - arity = Prims.int_zero; - syn_emb = uu___37; - nbe_emb = uu___38 - } in - (uu___35, uu___36) in - let uu___35 = - let uu___36 = - let uu___37 = - FStar_Reflection_V2_Constants.fstar_refl_types_lid - "fv" in - let uu___38 = - let uu___39 = refl_emb_lid "e_fv" in - let uu___40 = - let uu___41 = - nbe_refl_emb_lid "e_fv" in - FStar_Pervasives_Native.Some - uu___41 in - { - arity = Prims.int_zero; - syn_emb = uu___39; - nbe_emb = uu___40 - } in - (uu___37, uu___38) in - let uu___37 = - let uu___38 = - let uu___39 = - FStar_Reflection_V2_Constants.fstar_refl_types_lid - "comp" in - let uu___40 = - let uu___41 = - refl_emb_lid "e_comp" in - let uu___42 = - let uu___43 = - nbe_refl_emb_lid "e_comp" in - FStar_Pervasives_Native.Some - uu___43 in - { - arity = Prims.int_zero; - syn_emb = uu___41; - nbe_emb = uu___42 - } in - (uu___39, uu___40) in - let uu___39 = - let uu___40 = - let uu___41 = - FStar_Reflection_V2_Constants.fstar_refl_types_lid - "sigelt" in - let uu___42 = - let uu___43 = - refl_emb_lid "e_sigelt" in - let uu___44 = - let uu___45 = - nbe_refl_emb_lid "e_sigelt" in - FStar_Pervasives_Native.Some - uu___45 in - { - arity = Prims.int_zero; - syn_emb = uu___43; - nbe_emb = uu___44 - } in - (uu___41, uu___42) in - let uu___41 = - let uu___42 = - let uu___43 = - FStar_Reflection_V2_Constants.fstar_refl_types_lid - "ctx_uvar_and_subst" in - let uu___44 = - let uu___45 = - refl_emb_lid - "e_ctx_uvar_and_subst" in - let uu___46 = - let uu___47 = - nbe_refl_emb_lid - "e_ctx_uvar_and_subst" in - FStar_Pervasives_Native.Some - uu___47 in - { - arity = Prims.int_zero; - syn_emb = uu___45; - nbe_emb = uu___46 - } in - (uu___43, uu___44) in - let uu___43 = - let uu___44 = - let uu___45 = - FStar_Reflection_V2_Constants.fstar_refl_types_lid - "letbinding" in - let uu___46 = - let uu___47 = - refl_emb_lid - "e_letbinding" in - let uu___48 = - let uu___49 = - nbe_refl_emb_lid - "e_letbinding" in - FStar_Pervasives_Native.Some - uu___49 in - { - arity = Prims.int_zero; - syn_emb = uu___47; - nbe_emb = uu___48 - } in - (uu___45, uu___46) in - let uu___45 = - let uu___46 = - let uu___47 = - FStar_Reflection_V2_Constants.fstar_refl_types_lid - "ident" in - let uu___48 = - let uu___49 = - refl_emb_lid "e_ident" in - let uu___50 = - let uu___51 = - nbe_refl_emb_lid - "e_ident" in - FStar_Pervasives_Native.Some - uu___51 in - { - arity = Prims.int_zero; - syn_emb = uu___49; - nbe_emb = uu___50 - } in - (uu___47, uu___48) in - let uu___47 = - let uu___48 = - let uu___49 = - FStar_Reflection_V2_Constants.fstar_refl_types_lid - "universe_uvar" in - let uu___50 = - let uu___51 = - refl_emb_lid - "e_universe_uvar" in - let uu___52 = - let uu___53 = - nbe_refl_emb_lid - "e_universe_uvar" in - FStar_Pervasives_Native.Some - uu___53 in - { - arity = - Prims.int_zero; - syn_emb = uu___51; - nbe_emb = uu___52 - } in - (uu___49, uu___50) in - let uu___49 = - let uu___50 = - let uu___51 = - FStar_Reflection_V2_Constants.fstar_refl_types_lid - "universe" in - let uu___52 = - let uu___53 = - refl_emb_lid - "e_universe" in - let uu___54 = - let uu___55 = - nbe_refl_emb_lid - "e_universe" in - FStar_Pervasives_Native.Some - uu___55 in - { - arity = - Prims.int_zero; - syn_emb = uu___53; - nbe_emb = uu___54 - } in - (uu___51, uu___52) in - let uu___51 = - let uu___52 = - let uu___53 = - FStar_Reflection_V2_Constants.fstar_refl_data_lid - "vconst" in - let uu___54 = - let uu___55 = - refl_emb_lid - "e_vconst" in - let uu___56 = - let uu___57 = - nbe_refl_emb_lid - "e_vconst" in - FStar_Pervasives_Native.Some - uu___57 in - { - arity = - Prims.int_zero; - syn_emb = uu___55; - nbe_emb = uu___56 - } in - (uu___53, uu___54) in - let uu___53 = - let uu___54 = - let uu___55 = - FStar_Reflection_V2_Constants.fstar_refl_data_lid - "aqualv" in - let uu___56 = - let uu___57 = - refl_emb_lid - "e_aqualv" in - let uu___58 = - let uu___59 = - nbe_refl_emb_lid - "e_aqualv" in - FStar_Pervasives_Native.Some - uu___59 in - { - arity = - Prims.int_zero; - syn_emb = - uu___57; - nbe_emb = - uu___58 - } in - (uu___55, uu___56) in - let uu___55 = - let uu___56 = - let uu___57 = - FStar_Reflection_V2_Constants.fstar_refl_data_lid - "pattern" in - let uu___58 = - let uu___59 = - refl_emb_lid - "e_pattern" in - let uu___60 = - let uu___61 = - nbe_refl_emb_lid - "e_pattern" in - FStar_Pervasives_Native.Some - uu___61 in - { - arity = - Prims.int_zero; - syn_emb = - uu___59; - nbe_emb = - uu___60 - } in - (uu___57, - uu___58) in - let uu___57 = - let uu___58 = - let uu___59 = - FStar_Reflection_V2_Constants.fstar_refl_data_lid - "namedv_view" in - let uu___60 = - let uu___61 = - refl_emb_lid - "e_namedv_view" in - let uu___62 = - let uu___63 - = - nbe_refl_emb_lid - "e_namedv_view" in - FStar_Pervasives_Native.Some - uu___63 in - { - arity = - Prims.int_zero; - syn_emb = - uu___61; - nbe_emb = - uu___62 - } in - (uu___59, - uu___60) in - let uu___59 = - let uu___60 = - let uu___61 = - FStar_Reflection_V2_Constants.fstar_refl_data_lid - "bv_view" in - let uu___62 = - let uu___63 - = - refl_emb_lid - "e_bv_view" in - let uu___64 - = - let uu___65 - = - nbe_refl_emb_lid - "e_bv_view" in - FStar_Pervasives_Native.Some - uu___65 in - { - arity = - Prims.int_zero; - syn_emb = - uu___63; - nbe_emb = - uu___64 - } in - (uu___61, - uu___62) in - let uu___61 = - let uu___62 = - let uu___63 - = - FStar_Reflection_V2_Constants.fstar_refl_data_lid - "binder_view" in - let uu___64 - = - let uu___65 - = - refl_emb_lid - "e_binder_view" in - let uu___66 - = - let uu___67 - = - nbe_refl_emb_lid - "e_binder_view" in - FStar_Pervasives_Native.Some - uu___67 in - { - arity = - Prims.int_zero; - syn_emb = - uu___65; - nbe_emb = - uu___66 - } in - (uu___63, - uu___64) in - let uu___63 = - let uu___64 - = - let uu___65 - = - FStar_Reflection_V2_Constants.fstar_refl_data_lid - "binding" in - let uu___66 - = - let uu___67 - = - refl_emb_lid - "e_binding" in - let uu___68 - = - let uu___69 - = - nbe_refl_emb_lid - "e_binding" in - FStar_Pervasives_Native.Some - uu___69 in - { - arity = - Prims.int_zero; - syn_emb = - uu___67; - nbe_emb = - uu___68 - } in - (uu___65, - uu___66) in - let uu___65 - = - let uu___66 - = - let uu___67 - = - FStar_Reflection_V2_Constants.fstar_refl_data_lid - "universe_view" in - let uu___68 - = - let uu___69 - = - refl_emb_lid - "e_universe_view" in - let uu___70 - = - let uu___71 - = - nbe_refl_emb_lid - "e_universe_view" in - FStar_Pervasives_Native.Some - uu___71 in - { - arity = - Prims.int_zero; - syn_emb = - uu___69; - nbe_emb = - uu___70 - } in - (uu___67, - uu___68) in - let uu___67 - = - let uu___68 - = - let uu___69 - = - FStar_Reflection_V2_Constants.fstar_refl_data_lid - "term_view" in - let uu___70 - = - let uu___71 - = - refl_emb_lid - "e_term_view" in - let uu___72 - = - let uu___73 - = - nbe_refl_emb_lid - "e_term_view" in - FStar_Pervasives_Native.Some - uu___73 in - { - arity = - Prims.int_zero; - syn_emb = - uu___71; - nbe_emb = - uu___72 - } in - (uu___69, - uu___70) in - let uu___69 - = - let uu___70 - = - let uu___71 - = - FStar_Reflection_V2_Constants.fstar_refl_data_lid - "comp_view" in - let uu___72 - = - let uu___73 - = - refl_emb_lid - "e_comp_view" in - let uu___74 - = - let uu___75 - = - nbe_refl_emb_lid - "e_comp_view" in - FStar_Pervasives_Native.Some - uu___75 in - { - arity = - Prims.int_zero; - syn_emb = - uu___73; - nbe_emb = - uu___74 - } in - (uu___71, - uu___72) in - let uu___71 - = - let uu___72 - = - let uu___73 - = - FStar_Reflection_V2_Constants.fstar_refl_data_lid - "lb_view" in - let uu___74 - = - let uu___75 - = - refl_emb_lid - "e_lb_view" in - let uu___76 - = - let uu___77 - = - nbe_refl_emb_lid - "e_lb_view" in - FStar_Pervasives_Native.Some - uu___77 in - { - arity = - Prims.int_zero; - syn_emb = - uu___75; - nbe_emb = - uu___76 - } in - (uu___73, - uu___74) in - let uu___73 - = - let uu___74 - = - let uu___75 - = - FStar_Reflection_V2_Constants.fstar_refl_data_lid - "sigelt_view" in - let uu___76 - = - let uu___77 - = - refl_emb_lid - "e_sigelt_view" in - let uu___78 - = - let uu___79 - = - nbe_refl_emb_lid - "e_sigelt_view" in - FStar_Pervasives_Native.Some - uu___79 in - { - arity = - Prims.int_zero; - syn_emb = - uu___77; - nbe_emb = - uu___78 - } in - (uu___75, - uu___76) in - let uu___75 - = - let uu___76 - = - let uu___77 - = - FStar_Reflection_V2_Constants.fstar_refl_data_lid - "qualifier" in - let uu___78 - = - let uu___79 - = - refl_emb_lid - "e_qualifier" in - let uu___80 - = - let uu___81 - = - nbe_refl_emb_lid - "e_qualifier" in - FStar_Pervasives_Native.Some - uu___81 in - { - arity = - Prims.int_zero; - syn_emb = - uu___79; - nbe_emb = - uu___80 - } in - (uu___77, - uu___78) in - [uu___76] in - uu___74 - :: - uu___75 in - uu___72 - :: - uu___73 in - uu___70 - :: - uu___71 in - uu___68 - :: - uu___69 in - uu___66 - :: - uu___67 in - uu___64 :: - uu___65 in - uu___62 :: - uu___63 in - uu___60 :: - uu___61 in - uu___58 :: - uu___59 in - uu___56 :: uu___57 in - uu___54 :: uu___55 in - uu___52 :: uu___53 in - uu___50 :: uu___51 in - uu___48 :: uu___49 in - uu___46 :: uu___47 in - uu___44 :: uu___45 in - uu___42 :: uu___43 in - uu___40 :: uu___41 in - uu___38 :: uu___39 in - uu___36 :: uu___37 in - uu___34 :: uu___35 in - uu___32 :: uu___33 in - uu___30 :: uu___31 in - uu___28 :: uu___29 in - uu___26 :: uu___27 in - uu___24 :: uu___25 in - uu___22 :: uu___23 in - uu___20 :: uu___21 in - uu___18 :: uu___19 in - uu___16 :: uu___17 in - uu___14 :: uu___15 in - uu___12 :: uu___13 in - uu___10 :: uu___11 in - uu___8 :: uu___9 in - uu___6 :: uu___7 in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - uu___ :: uu___1 -let (dbg_plugin : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Plugins" -let (local_fv_embeddings : - (FStar_Ident.lident * embedding_data) Prims.list FStar_Compiler_Effect.ref) - = FStar_Compiler_Util.mk_ref [] -let (register_embedding : FStar_Ident.lident -> embedding_data -> unit) = - fun l -> - fun d -> - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_plugin in - if uu___1 - then - let uu___2 = FStar_Ident.string_of_lid l in - FStar_Compiler_Util.print1 "Registering local embedding for %s\n" - uu___2 - else ()); - (let uu___1 = - let uu___2 = FStar_Compiler_Effect.op_Bang local_fv_embeddings in - (l, d) :: uu___2 in - FStar_Compiler_Effect.op_Colon_Equals local_fv_embeddings uu___1) -let (list_local : unit -> (FStar_Ident.lident * embedding_data) Prims.list) = - fun uu___ -> FStar_Compiler_Effect.op_Bang local_fv_embeddings -let (find_fv_embedding' : - FStar_Ident.lident -> embedding_data FStar_Pervasives_Native.option) = - fun l -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Compiler_Effect.op_Bang local_fv_embeddings in - FStar_Compiler_List.op_At uu___2 builtin_embeddings in - FStar_Compiler_List.find - (fun uu___2 -> - match uu___2 with | (l', uu___3) -> FStar_Ident.lid_equals l l') - uu___1 in - match uu___ with - | FStar_Pervasives_Native.Some (uu___1, data) -> - FStar_Pervasives_Native.Some data - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None -let (find_fv_embedding : FStar_Ident.lident -> embedding_data) = - fun l -> - let uu___ = find_fv_embedding' l in - match uu___ with - | FStar_Pervasives_Native.Some data -> data - | FStar_Pervasives_Native.None -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Ident.string_of_lid l in - Prims.strcat "Embedding not defined for type " uu___3 in - NoEmbedding uu___2 in - FStar_Compiler_Effect.raise uu___1 -type embedding_kind = - | SyntaxTerm - | NBETerm -let (uu___is_SyntaxTerm : embedding_kind -> Prims.bool) = - fun projectee -> match projectee with | SyntaxTerm -> true | uu___ -> false -let (uu___is_NBETerm : embedding_kind -> Prims.bool) = - fun projectee -> match projectee with | NBETerm -> true | uu___ -> false -let rec (embedding_for : - FStar_TypeChecker_Env.env -> - FStar_Ident.lid Prims.list -> - embedding_kind -> - (FStar_Syntax_Syntax.bv * Prims.string) Prims.list -> - FStar_Syntax_Syntax.term -> FStar_Extraction_ML_Syntax.mlexpr) - = - fun tcenv -> - fun mutuals -> - fun k -> - fun env -> - fun t -> - let str_to_name s = as_name ([], s) in - let emb_arrow e1 e2 = - let comb = - match k with - | SyntaxTerm -> ml_name' "FStar.Syntax.Embeddings.e_arrow" - | NBETerm -> ml_name' "FStar.TypeChecker.NBETerm.e_arrow" in - mk (FStar_Extraction_ML_Syntax.MLE_App (comb, [e1; e2])) in - let find_env_entry bv uu___ = - match uu___ with - | (bv', uu___1) -> FStar_Syntax_Syntax.bv_eq bv bv' in - let t1 = FStar_TypeChecker_Normalize.unfold_whnf tcenv t in - let t2 = FStar_Syntax_Util.un_uinst t1 in - let t3 = FStar_Syntax_Subst.compress t2 in - match t3.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_name bv when - FStar_Compiler_Util.for_some (find_env_entry bv) env -> - let comb = - match k with - | SyntaxTerm -> - ml_name' "FStar.Syntax.Embeddings.mk_any_emb" - | NBETerm -> - ml_name' "FStar.TypeChecker.NBETerm.mk_any_emb" in - let s = - let uu___ = - let uu___1 = - FStar_Compiler_Util.find_opt (find_env_entry bv) env in - FStar_Compiler_Util.must uu___1 in - FStar_Pervasives_Native.snd uu___ in - let uu___ = - let uu___1 = - let uu___2 = let uu___3 = str_to_name s in [uu___3] in - (comb, uu___2) in - FStar_Extraction_ML_Syntax.MLE_App uu___1 in - mk uu___ - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x; - FStar_Syntax_Syntax.phi = uu___;_} - -> - embedding_for tcenv mutuals k env x.FStar_Syntax_Syntax.sort - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t4; - FStar_Syntax_Syntax.asc = uu___; - FStar_Syntax_Syntax.eff_opt = uu___1;_} - -> embedding_for tcenv mutuals k env t4 - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = b::[]; - FStar_Syntax_Syntax.comp = c;_} - when FStar_Syntax_Util.is_pure_comp c -> - let uu___ = FStar_Syntax_Subst.open_comp [b] c in - (match uu___ with - | (b1::[], c1) -> - let t0 = - (b1.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - let t11 = FStar_Syntax_Util.comp_result c1 in - let uu___1 = embedding_for tcenv mutuals k env t0 in - let uu___2 = embedding_for tcenv mutuals k env t11 in - emb_arrow uu___1 uu___2) - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = b::more::bs; - FStar_Syntax_Syntax.comp = c;_} - -> - let tail = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 = (more :: bs); - FStar_Syntax_Syntax.comp = c - }) t3.FStar_Syntax_Syntax.pos in - let t4 = - let uu___ = - let uu___1 = - let uu___2 = FStar_Syntax_Syntax.mk_Total tail in - { - FStar_Syntax_Syntax.bs1 = [b]; - FStar_Syntax_Syntax.comp = uu___2 - } in - FStar_Syntax_Syntax.Tm_arrow uu___1 in - FStar_Syntax_Syntax.mk uu___ t3.FStar_Syntax_Syntax.pos in - embedding_for tcenv mutuals k env t4 - | FStar_Syntax_Syntax.Tm_app uu___ -> - let uu___1 = FStar_Syntax_Util.head_and_args t3 in - (match uu___1 with - | (head, args) -> - let e_head = embedding_for tcenv mutuals k env head in - let e_args = - FStar_Compiler_List.map - (fun uu___2 -> - match uu___2 with - | (t4, uu___3) -> - embedding_for tcenv mutuals k env t4) args in - mk (FStar_Extraction_ML_Syntax.MLE_App (e_head, e_args))) - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Compiler_List.existsb - (FStar_Ident.lid_equals - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v) - mutuals - -> - let head = - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Ident.ident_of_lid - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - FStar_Ident.string_of_id uu___3 in - Prims.strcat "__knot_e_" uu___2 in - FStar_Extraction_ML_Syntax.MLE_Var uu___1 in - mk uu___ in - mk - (FStar_Extraction_ML_Syntax.MLE_App - (head, [FStar_Extraction_ML_Syntax.ml_unit])) - | FStar_Syntax_Syntax.Tm_fvar fv when - let uu___ = - find_fv_embedding' - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - FStar_Pervasives_Native.uu___is_Some uu___ -> - let emb_data = - find_fv_embedding - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - (match k with - | SyntaxTerm -> ml_name emb_data.syn_emb - | NBETerm -> - (match emb_data.nbe_emb with - | FStar_Pervasives_Native.Some lid -> ml_name lid - | FStar_Pervasives_Native.None -> ml_nbe_unsupported)) - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_TypeChecker_Env.fv_has_attr tcenv fv - FStar_Parser_Const.plugin_attr - -> - (match k with - | SyntaxTerm -> - let lid = - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - let uu___ = - let uu___1 = - let uu___2 = FStar_Ident.ns_of_lid lid in - FStar_Compiler_List.map FStar_Ident.string_of_id - uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = FStar_Ident.ident_of_lid lid in - FStar_Ident.string_of_id uu___4 in - Prims.strcat "e_" uu___3 in - (uu___1, uu___2) in - as_name uu___ - | NBETerm -> ml_nbe_unsupported) - | FStar_Syntax_Syntax.Tm_fvar fv -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - t3 in - FStar_Compiler_Util.format1 - "Embedding not defined for name `%s'" uu___2 in - NoEmbedding uu___1 in - FStar_Compiler_Effect.raise uu___ - | uu___ -> - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - t3 in - let uu___4 = - FStar_Class_Tagged.tag_of - FStar_Syntax_Syntax.tagged_term t3 in - FStar_Compiler_Util.format2 "Cannot embed type `%s' (%s)" - uu___3 uu___4 in - NoEmbedding uu___2 in - FStar_Compiler_Effect.raise uu___1 -type wrapped_term = - (FStar_Extraction_ML_Syntax.mlexpr * FStar_Extraction_ML_Syntax.mlexpr * - Prims.int * Prims.bool) -let (interpret_plugin_as_term_fun : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.fv -> - FStar_Syntax_Syntax.typ -> - Prims.int FStar_Pervasives_Native.option -> - FStar_Extraction_ML_Syntax.mlexpr' -> - (FStar_Extraction_ML_Syntax.mlexpr * - FStar_Extraction_ML_Syntax.mlexpr * Prims.int * Prims.bool) - FStar_Pervasives_Native.option) - = - fun env -> - fun fv -> - fun t -> - fun arity_opt -> - fun ml_fv -> - let fv_lid = - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - let tcenv = FStar_Extraction_ML_UEnv.tcenv_of_uenv env in - let t1 = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.EraseUniverses; - FStar_TypeChecker_Env.AllowUnboundUniverses; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.ForExtraction] tcenv t in - let as_name1 mlp = - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.MLTY_Top - (FStar_Extraction_ML_Syntax.MLE_Name mlp) in - let lid_to_name l = - let uu___ = - let uu___1 = FStar_Extraction_ML_UEnv.mlpath_of_lident env l in - FStar_Extraction_ML_Syntax.MLE_Name uu___1 in - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.MLTY_Top uu___ in - let str_to_name s = as_name1 ([], s) in - let fv_lid_embedded = - let uu___ = - let uu___1 = - let uu___2 = as_name1 (["FStar_Ident"], "lid_of_str") in - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = FStar_Ident.string_of_lid fv_lid in - FStar_Extraction_ML_Syntax.MLC_String uu___7 in - FStar_Extraction_ML_Syntax.MLE_Const uu___6 in - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.MLTY_Top uu___5 in - [uu___4] in - (uu___2, uu___3) in - FStar_Extraction_ML_Syntax.MLE_App uu___1 in - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.MLTY_Top uu___ in - let mk_tactic_interpretation l arity = - if arity > FStar_Tactics_InterpFuns.max_tac_arity - then - FStar_Compiler_Effect.raise - (NoEmbedding - "tactic plugins can only take up to 20 arguments") - else - (let idroot = - match l with - | SyntaxTerm -> "mk_tactic_interpretation_" - | NBETerm -> "mk_nbe_tactic_interpretation_" in - as_name1 - (["FStar_Tactics_InterpFuns"], - (Prims.strcat idroot (Prims.string_of_int arity)))) in - let mk_from_tactic l arity = - let idroot = - match l with - | SyntaxTerm -> "from_tactic_" - | NBETerm -> "from_nbe_tactic_" in - as_name1 - (["FStar_Tactics_Native"], - (Prims.strcat idroot (Prims.string_of_int arity))) in - let mk_arrow_as_prim_step k arity = - let modul = - match k with - | SyntaxTerm -> ["FStar"; "Syntax"; "Embeddings"] - | NBETerm -> ["FStar"; "TypeChecker"; "NBETerm"] in - as_name1 - (modul, - (Prims.strcat "arrow_as_prim_step_" - (Prims.string_of_int arity))) in - let abstract_tvars tvar_names body = - match tvar_names with - | [] -> - let body1 = - let uu___ = - let uu___1 = - let uu___2 = - as_name1 - (["FStar_Syntax_Embeddings"], "debug_wrap") in - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = FStar_Ident.string_of_lid fv_lid in - FStar_Extraction_ML_Syntax.MLC_String uu___7 in - FStar_Extraction_ML_Syntax.MLE_Const uu___6 in - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.MLTY_Top uu___5 in - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = str_to_name "args" in - [uu___11] in - (body, uu___10) in - FStar_Extraction_ML_Syntax.MLE_App uu___9 in - mk uu___8 in - ml_lam "_" uu___7 in - [uu___6] in - uu___4 :: uu___5 in - (uu___2, uu___3) in - FStar_Extraction_ML_Syntax.MLE_App uu___1 in - mk uu___ in - ml_lam "args" body1 - | uu___ -> - let args_tail = - FStar_Extraction_ML_Syntax.MLP_Var "args_tail" in - let mk_cons hd_pat tail_pat = - FStar_Extraction_ML_Syntax.MLP_CTor - ((["Prims"], "Cons"), [hd_pat; tail_pat]) in - let fst_pat v = - FStar_Extraction_ML_Syntax.MLP_Tuple - [FStar_Extraction_ML_Syntax.MLP_Var v; - FStar_Extraction_ML_Syntax.MLP_Wild] in - let pattern = - FStar_Compiler_List.fold_right - (fun hd_var -> mk_cons (fst_pat hd_var)) tvar_names - args_tail in - let branch = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = as_name1 ([], "args_tail") in - [uu___5] in - (body, uu___4) in - FStar_Extraction_ML_Syntax.MLE_App uu___3 in - mk uu___2 in - (pattern, FStar_Pervasives_Native.None, uu___1) in - let default_branch = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = str_to_name "failwith" in - let uu___5 = - let uu___6 = - mk - (FStar_Extraction_ML_Syntax.MLE_Const - (FStar_Extraction_ML_Syntax.MLC_String - "arity mismatch")) in - [uu___6] in - (uu___4, uu___5) in - FStar_Extraction_ML_Syntax.MLE_App uu___3 in - mk uu___2 in - (FStar_Extraction_ML_Syntax.MLP_Wild, - FStar_Pervasives_Native.None, uu___1) in - let body1 = - let uu___1 = - let uu___2 = - let uu___3 = as_name1 ([], "args") in - (uu___3, [branch; default_branch]) in - FStar_Extraction_ML_Syntax.MLE_Match uu___2 in - mk uu___1 in - let body2 = - let uu___1 = - let uu___2 = - let uu___3 = - as_name1 - (["FStar_Syntax_Embeddings"], "debug_wrap") in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = FStar_Ident.string_of_lid fv_lid in - FStar_Extraction_ML_Syntax.MLC_String uu___8 in - FStar_Extraction_ML_Syntax.MLE_Const uu___7 in - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.MLTY_Top uu___6 in - let uu___6 = - let uu___7 = ml_lam "_" body1 in [uu___7] in - uu___5 :: uu___6 in - (uu___3, uu___4) in - FStar_Extraction_ML_Syntax.MLE_App uu___2 in - mk uu___1 in - ml_lam "args" body2 in - let uu___ = FStar_Syntax_Util.arrow_formals_comp t1 in - match uu___ with - | (bs, c) -> - let uu___1 = - match arity_opt with - | FStar_Pervasives_Native.None -> (bs, c) - | FStar_Pervasives_Native.Some n -> - let n_bs = FStar_Compiler_List.length bs in - if n = n_bs - then (bs, c) - else - if n < n_bs - then - (let uu___3 = FStar_Compiler_Util.first_N n bs in - match uu___3 with - | (bs1, rest) -> - let c1 = - let uu___4 = FStar_Syntax_Util.arrow rest c in - FStar_Syntax_Syntax.mk_Total uu___4 in - (bs1, c1)) - else - (let msg = - let uu___4 = FStar_Ident.string_of_lid fv_lid in - let uu___5 = FStar_Compiler_Util.string_of_int n in - let uu___6 = - FStar_Compiler_Util.string_of_int n_bs in - FStar_Compiler_Util.format3 - "Embedding not defined for %s; expected arity at least %s; got %s" - uu___4 uu___5 uu___6 in - FStar_Compiler_Effect.raise (NoEmbedding msg)) in - (match uu___1 with - | (bs1, c1) -> - let result_typ = FStar_Syntax_Util.comp_result c1 in - let arity = FStar_Compiler_List.length bs1 in - let uu___2 = - let uu___3 = - FStar_Compiler_Util.prefix_until - (fun uu___4 -> - match uu___4 with - | { FStar_Syntax_Syntax.binder_bv = b; - FStar_Syntax_Syntax.binder_qual = uu___5; - FStar_Syntax_Syntax.binder_positivity = - uu___6; - FStar_Syntax_Syntax.binder_attrs = uu___7;_} - -> - let uu___8 = - let uu___9 = - FStar_Syntax_Subst.compress - b.FStar_Syntax_Syntax.sort in - uu___9.FStar_Syntax_Syntax.n in - (match uu___8 with - | FStar_Syntax_Syntax.Tm_type uu___9 -> - false - | uu___9 -> true)) bs1 in - match uu___3 with - | FStar_Pervasives_Native.None -> (bs1, []) - | FStar_Pervasives_Native.Some (tvars, x, rest) -> - (tvars, (x :: rest)) in - (match uu___2 with - | (type_vars, bs2) -> - let tvar_arity = - FStar_Compiler_List.length type_vars in - let non_tvar_arity = FStar_Compiler_List.length bs2 in - let tvar_names = - FStar_Compiler_List.mapi - (fun i -> - fun tv -> - Prims.strcat "tv_" (Prims.string_of_int i)) - type_vars in - let tvar_context = - FStar_Compiler_List.map2 - (fun b -> - fun nm -> - ((b.FStar_Syntax_Syntax.binder_bv), nm)) - type_vars tvar_names in - let rec aux loc accum_embeddings bs3 = - match bs3 with - | [] -> - let arg_unembeddings = - FStar_Compiler_List.rev accum_embeddings in - let res_embedding = - embedding_for tcenv [] loc tvar_context - result_typ in - let fv_lid1 = - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - let uu___3 = - FStar_Syntax_Util.is_pure_comp c1 in - if uu___3 - then - let cb = str_to_name "cb" in - let us = str_to_name "us" in - let embed_fun_N = - mk_arrow_as_prim_step loc non_tvar_arity in - let args = - let uu___4 = - let uu___5 = - let uu___6 = lid_to_name fv_lid1 in - [uu___6; fv_lid_embedded; cb; us] in - res_embedding :: uu___5 in - FStar_Compiler_List.op_At - arg_unembeddings uu___4 in - let fun_embedding = - mk - (FStar_Extraction_ML_Syntax.MLE_App - (embed_fun_N, args)) in - let tabs = - abstract_tvars tvar_names fun_embedding in - let cb_tabs = - let uu___4 = ml_lam "us" tabs in - ml_lam "cb" uu___4 in - let uu___4 = - if loc = NBETerm - then cb_tabs - else ml_lam "_psc" cb_tabs in - (uu___4, arity, true) - else - (let uu___5 = - let uu___6 = - FStar_TypeChecker_Env.norm_eff_name - tcenv - (FStar_Syntax_Util.comp_effect_name - c1) in - FStar_Ident.lid_equals uu___6 - FStar_Parser_Const.effect_TAC_lid in - if uu___5 - then - let h = - mk_tactic_interpretation loc - non_tvar_arity in - let tac_fun = - let uu___6 = - let uu___7 = - let uu___8 = - mk_from_tactic loc - non_tvar_arity in - let uu___9 = - let uu___10 = - lid_to_name fv_lid1 in - [uu___10] in - (uu___8, uu___9) in - FStar_Extraction_ML_Syntax.MLE_App - uu___7 in - mk uu___6 in - let psc = str_to_name "psc" in - let ncb = str_to_name "ncb" in - let us = str_to_name "us" in - let all_args = str_to_name "args" in - let args = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Ident.string_of_lid - fv_lid1 in - Prims.strcat uu___11 - " (plugin)" in - FStar_Extraction_ML_Syntax.MLC_String - uu___10 in - FStar_Extraction_ML_Syntax.MLE_Const - uu___9 in - mk uu___8 in - [uu___7] in - FStar_Compiler_List.op_At uu___6 - (FStar_Compiler_List.op_At [tac_fun] - (FStar_Compiler_List.op_At - arg_unembeddings - [res_embedding; psc; ncb; us])) in - let tabs = - match tvar_names with - | [] -> - let uu___6 = - mk - (FStar_Extraction_ML_Syntax.MLE_App - (h, - (FStar_Compiler_List.op_At - args [all_args]))) in - ml_lam "args" uu___6 - | uu___6 -> - let uu___7 = - mk - (FStar_Extraction_ML_Syntax.MLE_App - (h, args)) in - abstract_tvars tvar_names uu___7 in - let uu___6 = - let uu___7 = - let uu___8 = ml_lam "us" tabs in - ml_lam "ncb" uu___8 in - ml_lam "psc" uu___7 in - (uu___6, (arity + Prims.int_one), false) - else - (let uu___7 = - let uu___8 = - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t1 in - Prims.strcat - "Plugins not defined for type " - uu___9 in - NoEmbedding uu___8 in - FStar_Compiler_Effect.raise uu___7)) - | { FStar_Syntax_Syntax.binder_bv = b; - FStar_Syntax_Syntax.binder_qual = uu___3; - FStar_Syntax_Syntax.binder_positivity = - uu___4; - FStar_Syntax_Syntax.binder_attrs = uu___5;_}::bs4 - -> - let uu___6 = - let uu___7 = - embedding_for tcenv [] loc tvar_context - b.FStar_Syntax_Syntax.sort in - uu___7 :: accum_embeddings in - aux loc uu___6 bs4 in - (try - (fun uu___3 -> - match () with - | () -> - let uu___4 = aux SyntaxTerm [] bs2 in - (match uu___4 with - | (w, a, b) -> - let uu___5 = aux NBETerm [] bs2 in - (match uu___5 with - | (w', uu___6, uu___7) -> - FStar_Pervasives_Native.Some - (w, w', a, b)))) () - with - | NoEmbedding msg -> - ((let uu___5 = - FStar_Ident.range_of_lid - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_fv fv in - not_implemented_warning uu___5 uu___6 msg); - FStar_Pervasives_Native.None)))) -let (mk_unembed : - FStar_TypeChecker_Env.env -> - FStar_Ident.lid Prims.list -> - FStar_Extraction_ML_Syntax.mlpath Prims.list - FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.sigelt Prims.list -> - FStar_Extraction_ML_Syntax.mlexpr) - = - fun tcenv -> - fun mutuals -> - fun record_fields -> - fun ctors -> - let e_branches = FStar_Compiler_Util.mk_ref [] in - let arg_v = fresh "tm" in - FStar_Compiler_List.iter - (fun ctor -> - match ctor.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = lid; - FStar_Syntax_Syntax.us1 = us; - FStar_Syntax_Syntax.t1 = t; - FStar_Syntax_Syntax.ty_lid = ty_lid; - FStar_Syntax_Syntax.num_ty_params = num_ty_params; - FStar_Syntax_Syntax.mutuals1 = uu___1; - FStar_Syntax_Syntax.injective_type_params1 = uu___2;_} - -> - let fv = fresh "fv" in - let uu___3 = FStar_Syntax_Util.arrow_formals t in - (match uu___3 with - | (bs, c) -> - let vs = - FStar_Compiler_List.map - (fun b -> - let uu___4 = - let uu___5 = - FStar_Ident.string_of_id - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.ppname in - fresh uu___5 in - (uu___4, - ((b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort))) - bs in - let pat_s = - let uu___4 = - let uu___5 = FStar_Ident.string_of_lid lid in - FStar_Extraction_ML_Syntax.MLC_String uu___5 in - FStar_Extraction_ML_Syntax.MLP_Const uu___4 in - let pat_args = - let uu___4 = - FStar_Compiler_List.map - (fun uu___5 -> - match uu___5 with - | (v, uu___6) -> - FStar_Extraction_ML_Syntax.MLP_Var v) vs in - pats_to_list_pat uu___4 in - let pat_both = - FStar_Extraction_ML_Syntax.MLP_Tuple - [pat_s; pat_args] in - let ret = - match record_fields with - | FStar_Pervasives_Native.Some fields -> - let uu___4 = - FStar_Compiler_List.map2 - (fun uu___5 -> - fun fld -> - match uu___5 with - | (v, uu___6) -> - let uu___7 = - mk - (FStar_Extraction_ML_Syntax.MLE_Var - v) in - ((FStar_Pervasives_Native.snd fld), - uu___7)) vs fields in - ml_record lid uu___4 - | FStar_Pervasives_Native.None -> - let uu___4 = - FStar_Compiler_List.map - (fun uu___5 -> - match uu___5 with - | (v, uu___6) -> - mk - (FStar_Extraction_ML_Syntax.MLE_Var - v)) vs in - ml_ctor lid uu___4 in - let ret1 = - mk - (FStar_Extraction_ML_Syntax.MLE_App - (ml_some, [ret])) in - let body = - FStar_Compiler_List.fold_right - (fun uu___4 -> - fun body1 -> - match uu___4 with - | (v, ty) -> - let body2 = - mk - (FStar_Extraction_ML_Syntax.MLE_Fun - ([mk_binder v - FStar_Extraction_ML_Syntax.MLTY_Top], - body1)) in - let uu___5 = - let uu___6 = - let uu___7 = ml_name bind_opt_lid in - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - ml_name unembed_lid in - let uu___13 = - let uu___14 = - embedding_for tcenv - mutuals SyntaxTerm [] - ty in - let uu___15 = - let uu___16 = - mk - (FStar_Extraction_ML_Syntax.MLE_Var - v) in - [uu___16] in - uu___14 :: uu___15 in - (uu___12, uu___13) in - FStar_Extraction_ML_Syntax.MLE_App - uu___11 in - mk uu___10 in - [uu___9; body2] in - (uu___7, uu___8) in - FStar_Extraction_ML_Syntax.MLE_App - uu___6 in - mk uu___5) vs ret1 in - let br = - (pat_both, FStar_Pervasives_Native.None, body) in - let uu___4 = - let uu___5 = - FStar_Compiler_Effect.op_Bang e_branches in - br :: uu___5 in - FStar_Compiler_Effect.op_Colon_Equals e_branches - uu___4) - | uu___1 -> failwith "impossible, filter above") ctors; - (let nomatch = - (FStar_Extraction_ML_Syntax.MLP_Wild, - FStar_Pervasives_Native.None, ml_none) in - let branches = - let uu___1 = - let uu___2 = FStar_Compiler_Effect.op_Bang e_branches in - nomatch :: uu___2 in - FStar_Compiler_List.rev uu___1 in - let sc = mk (FStar_Extraction_ML_Syntax.MLE_Var arg_v) in - let def = mk (FStar_Extraction_ML_Syntax.MLE_Match (sc, branches)) in - let lam = - mk - (FStar_Extraction_ML_Syntax.MLE_Fun - ([mk_binder arg_v FStar_Extraction_ML_Syntax.MLTY_Top], - def)) in - lam) -let (mk_embed : - FStar_TypeChecker_Env.env -> - FStar_Ident.lid Prims.list -> - FStar_Extraction_ML_Syntax.mlpath Prims.list - FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.sigelt Prims.list -> - FStar_Extraction_ML_Syntax.mlexpr) - = - fun tcenv -> - fun mutuals -> - fun record_fields -> - fun ctors -> - let e_branches = FStar_Compiler_Util.mk_ref [] in - let arg_v = fresh "tm" in - FStar_Compiler_List.iter - (fun ctor -> - match ctor.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = lid; - FStar_Syntax_Syntax.us1 = us; - FStar_Syntax_Syntax.t1 = t; - FStar_Syntax_Syntax.ty_lid = ty_lid; - FStar_Syntax_Syntax.num_ty_params = num_ty_params; - FStar_Syntax_Syntax.mutuals1 = uu___1; - FStar_Syntax_Syntax.injective_type_params1 = uu___2;_} - -> - let fv = fresh "fv" in - let uu___3 = FStar_Syntax_Util.arrow_formals t in - (match uu___3 with - | (bs, c) -> - let vs = - FStar_Compiler_List.map - (fun b -> - let uu___4 = - let uu___5 = - FStar_Ident.string_of_id - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.ppname in - fresh uu___5 in - (uu___4, - ((b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort))) - bs in - let pat = - match record_fields with - | FStar_Pervasives_Native.Some fields -> - let uu___4 = - let uu___5 = - FStar_Compiler_List.map2 - (fun v -> - fun fld -> - ((FStar_Pervasives_Native.snd fld), - (FStar_Extraction_ML_Syntax.MLP_Var - (FStar_Pervasives_Native.fst v)))) - vs fields in - ([], uu___5) in - FStar_Extraction_ML_Syntax.MLP_Record uu___4 - | FStar_Pervasives_Native.None -> - let uu___4 = - let uu___5 = - let uu___6 = FStar_Ident.path_of_lid lid in - splitlast uu___6 in - let uu___6 = - FStar_Compiler_List.map - (fun v -> - FStar_Extraction_ML_Syntax.MLP_Var - (FStar_Pervasives_Native.fst v)) vs in - (uu___5, uu___6) in - FStar_Extraction_ML_Syntax.MLP_CTor uu___4 in - let fvar = ml_name s_tdataconstr_lid in - let lid_of_str = ml_name lid_of_str_lid in - let head = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - FStar_Ident.string_of_lid lid in - FStar_Extraction_ML_Syntax.MLC_String - uu___14 in - FStar_Extraction_ML_Syntax.MLE_Const - uu___13 in - mk uu___12 in - [uu___11] in - (lid_of_str, uu___10) in - FStar_Extraction_ML_Syntax.MLE_App uu___9 in - mk uu___8 in - [uu___7] in - (fvar, uu___6) in - FStar_Extraction_ML_Syntax.MLE_App uu___5 in - mk uu___4 in - let mk_mk_app t1 ts = - let ts1 = - FStar_Compiler_List.map - (fun t2 -> - mk - (FStar_Extraction_ML_Syntax.MLE_Tuple - [t2; ml_none])) ts in - let uu___4 = - let uu___5 = - let uu___6 = ml_name mk_app_lid in - let uu___7 = - let uu___8 = - let uu___9 = as_ml_list ts1 in [uu___9] in - t1 :: uu___8 in - (uu___6, uu___7) in - FStar_Extraction_ML_Syntax.MLE_App uu___5 in - mk uu___4 in - let args = - FStar_Compiler_List.map - (fun uu___4 -> - match uu___4 with - | (v, ty) -> - let vt = - mk - (FStar_Extraction_ML_Syntax.MLE_Var v) in - let uu___5 = - let uu___6 = - let uu___7 = ml_name embed_lid in - let uu___8 = - let uu___9 = - embedding_for tcenv mutuals - SyntaxTerm [] ty in - [uu___9; vt] in - (uu___7, uu___8) in - FStar_Extraction_ML_Syntax.MLE_App - uu___6 in - mk uu___5) vs in - let ret = mk_mk_app head args in - let br = (pat, FStar_Pervasives_Native.None, ret) in - let uu___4 = - let uu___5 = - FStar_Compiler_Effect.op_Bang e_branches in - br :: uu___5 in - FStar_Compiler_Effect.op_Colon_Equals e_branches - uu___4) - | uu___1 -> failwith "impossible, filter above") ctors; - (let branches = - let uu___1 = FStar_Compiler_Effect.op_Bang e_branches in - FStar_Compiler_List.rev uu___1 in - let sc = mk (FStar_Extraction_ML_Syntax.MLE_Var arg_v) in - let def = mk (FStar_Extraction_ML_Syntax.MLE_Match (sc, branches)) in - let lam = - mk - (FStar_Extraction_ML_Syntax.MLE_Fun - ([mk_binder arg_v FStar_Extraction_ML_Syntax.MLTY_Top], - def)) in - lam) -let (__do_handle_plugin : - FStar_Extraction_ML_UEnv.uenv -> - Prims.int FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.sigelt -> - FStar_Extraction_ML_Syntax.mlmodule1 Prims.list) - = - fun g -> - fun arity_opt -> - fun se -> - let r = se.FStar_Syntax_Syntax.sigrng in - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = lbs; - FStar_Syntax_Syntax.lids1 = uu___;_} - -> - let mk_registration lb = - let fv = - FStar_Compiler_Util.right lb.FStar_Syntax_Syntax.lbname in - let fv_lid = - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - let fv_t = lb.FStar_Syntax_Syntax.lbtyp in - let ml_name_str = - let uu___1 = - let uu___2 = FStar_Ident.string_of_lid fv_lid in - FStar_Extraction_ML_Syntax.MLC_String uu___2 in - FStar_Extraction_ML_Syntax.MLE_Const uu___1 in - let uu___1 = - interpret_plugin_as_term_fun g fv fv_t arity_opt ml_name_str in - match uu___1 with - | FStar_Pervasives_Native.Some - (interp, nbe_interp, arity, plugin) -> - let uu___2 = - if plugin - then - ((["FStar_Tactics_Native"], "register_plugin"), - [interp; nbe_interp]) - else - ((["FStar_Tactics_Native"], "register_tactic"), - [interp]) in - (match uu___2 with - | (register, args) -> - let h = - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.MLTY_Top - (FStar_Extraction_ML_Syntax.MLE_Name register) in - let arity1 = - FStar_Extraction_ML_Syntax.MLE_Const - (FStar_Extraction_ML_Syntax.MLC_Int - ((Prims.string_of_int arity), - FStar_Pervasives_Native.None)) in - let app = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = mk ml_name_str in - let uu___8 = - let uu___9 = mk arity1 in [uu___9] in - uu___7 :: uu___8 in - FStar_Compiler_List.op_At uu___6 args in - (h, uu___5) in - FStar_Extraction_ML_Syntax.MLE_App uu___4 in - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.MLTY_Top uu___3 in - let uu___3 = - FStar_Extraction_ML_Syntax.mk_mlmodule1 - (FStar_Extraction_ML_Syntax.MLM_Top app) in - [uu___3]) - | FStar_Pervasives_Native.None -> [] in - FStar_Compiler_List.collect mk_registration - (FStar_Pervasives_Native.snd lbs) - | FStar_Syntax_Syntax.Sig_bundle - { FStar_Syntax_Syntax.ses = ses; - FStar_Syntax_Syntax.lids = uu___;_} - -> - let mutual_sigelts = - FStar_Compiler_List.filter - (fun se1 -> - match se1.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ uu___1 -> true - | uu___1 -> false) ses in - let mutual_lids = - FStar_Compiler_List.map - (fun se1 -> - match se1.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = lid; - FStar_Syntax_Syntax.us = uu___1; - FStar_Syntax_Syntax.params = uu___2; - FStar_Syntax_Syntax.num_uniform_params = uu___3; - FStar_Syntax_Syntax.t = uu___4; - FStar_Syntax_Syntax.mutuals = uu___5; - FStar_Syntax_Syntax.ds = uu___6; - FStar_Syntax_Syntax.injective_type_params = uu___7;_} - -> lid) mutual_sigelts in - let proc_one typ_sigelt = - let uu___1 = typ_sigelt.FStar_Syntax_Syntax.sigel in - match uu___1 with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = tlid; - FStar_Syntax_Syntax.us = uu___2; - FStar_Syntax_Syntax.params = ps; - FStar_Syntax_Syntax.num_uniform_params = uu___3; - FStar_Syntax_Syntax.t = uu___4; - FStar_Syntax_Syntax.mutuals = uu___5; - FStar_Syntax_Syntax.ds = uu___6; - FStar_Syntax_Syntax.injective_type_params = uu___7;_} - -> - (if (FStar_Compiler_List.length ps) > Prims.int_zero - then - FStar_Compiler_Effect.raise - (Unsupported "parameters on inductive") - else (); - (let ns = FStar_Ident.ns_of_lid tlid in - let name = - let uu___9 = - let uu___10 = FStar_Ident.ids_of_lid tlid in - FStar_Compiler_List.last uu___10 in - FStar_Ident.string_of_id uu___9 in - let ctors = - FStar_Compiler_List.filter - (fun se1 -> - match se1.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = uu___9; - FStar_Syntax_Syntax.us1 = uu___10; - FStar_Syntax_Syntax.t1 = uu___11; - FStar_Syntax_Syntax.ty_lid = ty_lid; - FStar_Syntax_Syntax.num_ty_params = uu___12; - FStar_Syntax_Syntax.mutuals1 = uu___13; - FStar_Syntax_Syntax.injective_type_params1 = - uu___14;_} - -> FStar_Ident.lid_equals ty_lid tlid - | uu___9 -> false) ses in - let ml_name1 = - let uu___9 = - let uu___10 = - let uu___11 = FStar_Ident.string_of_lid tlid in - FStar_Extraction_ML_Syntax.MLC_String uu___11 in - FStar_Extraction_ML_Syntax.MLE_Const uu___10 in - mk uu___9 in - let record_fields = - let uu___9 = - FStar_Compiler_List.find - (fun uu___10 -> - match uu___10 with - | FStar_Syntax_Syntax.RecordType uu___11 -> true - | uu___11 -> false) - typ_sigelt.FStar_Syntax_Syntax.sigquals in - match uu___9 with - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.RecordType (uu___10, b)) -> - let uu___11 = - FStar_Compiler_List.map - (fun f -> - FStar_Extraction_ML_UEnv.lookup_record_field_name - g (tlid, f)) b in - FStar_Pervasives_Native.Some uu___11 - | uu___10 -> FStar_Pervasives_Native.None in - let tcenv = FStar_Extraction_ML_UEnv.tcenv_of_uenv g in - let ml_unembed = - mk_unembed tcenv mutual_lids record_fields ctors in - let ml_embed = - mk_embed tcenv mutual_lids record_fields ctors in - let def = - let uu___9 = - let uu___10 = - let uu___11 = - mk - (FStar_Extraction_ML_Syntax.MLE_Name - (["FStar"; "Syntax"; "Embeddings"; "Base"], - "mk_extracted_embedding")) in - (uu___11, [ml_name1; ml_unembed; ml_embed]) in - FStar_Extraction_ML_Syntax.MLE_App uu___10 in - mk uu___9 in - let def1 = - mk - (FStar_Extraction_ML_Syntax.MLE_Fun - ([mk_binder "_" - FStar_Extraction_ML_Syntax.MLTY_Erased], def)) in - let lb = - { - FStar_Extraction_ML_Syntax.mllb_name = - (Prims.strcat "__knot_e_" name); - FStar_Extraction_ML_Syntax.mllb_tysc = - FStar_Pervasives_Native.None; - FStar_Extraction_ML_Syntax.mllb_add_unit = false; - FStar_Extraction_ML_Syntax.mllb_def = def1; - FStar_Extraction_ML_Syntax.mllb_attrs = []; - FStar_Extraction_ML_Syntax.mllb_meta = []; - FStar_Extraction_ML_Syntax.print_typ = false - } in - (let uu___10 = - let uu___11 = - let uu___12 = - FStar_Ident.mk_ident - ((Prims.strcat "e_" name), - FStar_Compiler_Range_Type.dummyRange) in - FStar_Ident.lid_of_ns_and_id ns uu___12 in - { - arity = Prims.int_zero; - syn_emb = uu___11; - nbe_emb = FStar_Pervasives_Native.None - } in - register_embedding tlid uu___10); - [lb])) in - let lbs = FStar_Compiler_List.concatMap proc_one mutual_sigelts in - let unthunking = - FStar_Compiler_List.concatMap - (fun se1 -> - let tlid = - match se1.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = tlid1; - FStar_Syntax_Syntax.us = uu___1; - FStar_Syntax_Syntax.params = uu___2; - FStar_Syntax_Syntax.num_uniform_params = uu___3; - FStar_Syntax_Syntax.t = uu___4; - FStar_Syntax_Syntax.mutuals = uu___5; - FStar_Syntax_Syntax.ds = uu___6; - FStar_Syntax_Syntax.injective_type_params = uu___7;_} - -> tlid1 in - let name = - let uu___1 = - let uu___2 = FStar_Ident.ids_of_lid tlid in - FStar_Compiler_List.last uu___2 in - FStar_Ident.string_of_id uu___1 in - let app = - let head = - mk - (FStar_Extraction_ML_Syntax.MLE_Var - (Prims.strcat "__knot_e_" name)) in - mk - (FStar_Extraction_ML_Syntax.MLE_App - (head, [FStar_Extraction_ML_Syntax.ml_unit])) in - let lb = - { - FStar_Extraction_ML_Syntax.mllb_name = - (Prims.strcat "e_" name); - FStar_Extraction_ML_Syntax.mllb_tysc = - FStar_Pervasives_Native.None; - FStar_Extraction_ML_Syntax.mllb_add_unit = false; - FStar_Extraction_ML_Syntax.mllb_def = app; - FStar_Extraction_ML_Syntax.mllb_attrs = []; - FStar_Extraction_ML_Syntax.mllb_meta = []; - FStar_Extraction_ML_Syntax.print_typ = false - } in - let uu___1 = - FStar_Extraction_ML_Syntax.mk_mlmodule1 - (FStar_Extraction_ML_Syntax.MLM_Let - (FStar_Extraction_ML_Syntax.NonRec, [lb])) in - [uu___1]) mutual_sigelts in - let uu___1 = - let uu___2 = - FStar_Extraction_ML_Syntax.mk_mlmodule1 - (FStar_Extraction_ML_Syntax.MLM_Let - (FStar_Extraction_ML_Syntax.Rec, lbs)) in - [uu___2] in - FStar_Compiler_List.op_At uu___1 unthunking - | uu___ -> [] -let (do_handle_plugin : - FStar_Extraction_ML_UEnv.uenv -> - Prims.int FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.sigelt -> - FStar_Extraction_ML_Syntax.mlmodule1 Prims.list) - = - fun g -> - fun arity_opt -> - fun se -> - try - (fun uu___ -> - match () with | () -> __do_handle_plugin g arity_opt se) () - with - | Unsupported msg -> - ((let uu___2 = - let uu___3 = FStar_Syntax_Print.sigelt_to_string_short se in - FStar_Compiler_Util.format2 - "Could not generate a plugin for %s, reason = %s" uu___3 - msg in - FStar_Errors.log_issue FStar_Syntax_Syntax.has_range_sigelt se - FStar_Errors_Codes.Warning_PluginNotImplemented () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - []) - | NoEmbedding msg -> - ((let uu___2 = FStar_Syntax_Print.sigelt_to_string_short se in - not_implemented_warning se.FStar_Syntax_Syntax.sigrng uu___2 - msg); - []) -let (maybe_register_plugin : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.sigelt -> - FStar_Extraction_ML_Syntax.mlmodule1 Prims.list) - = - fun g -> - fun se -> - let plugin_with_arity attrs = - FStar_Compiler_Util.find_map attrs - (fun t -> - let uu___ = FStar_Syntax_Util.head_and_args t in - match uu___ with - | (head, args) -> - let uu___1 = - let uu___2 = - FStar_Syntax_Util.is_fvar FStar_Parser_Const.plugin_attr - head in - Prims.op_Negation uu___2 in - if uu___1 - then FStar_Pervasives_Native.None - else - (match args with - | (a, uu___3)::[] -> - let nopt = - FStar_Syntax_Embeddings_Base.unembed - FStar_Syntax_Embeddings.e_fsint a - FStar_Syntax_Embeddings_Base.id_norm_cb in - FStar_Pervasives_Native.Some nopt - | uu___3 -> - FStar_Pervasives_Native.Some - FStar_Pervasives_Native.None)) in - let uu___ = - let uu___1 = FStar_Options.codegen () in - uu___1 <> (FStar_Pervasives_Native.Some FStar_Options.Plugin) in - if uu___ - then [] - else - (let uu___2 = plugin_with_arity se.FStar_Syntax_Syntax.sigattrs in - match uu___2 with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some uu___3 when - FStar_Compiler_List.existsb - (fun uu___4 -> - match uu___4 with - | FStar_Syntax_Syntax.Projector uu___5 -> true - | FStar_Syntax_Syntax.Discriminator uu___5 -> true - | uu___5 -> false) se.FStar_Syntax_Syntax.sigquals - -> [] - | FStar_Pervasives_Native.Some arity_opt -> - do_handle_plugin g arity_opt se) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Extraction_ML_RemoveUnusedParameters.ml b/ocaml/fstar-lib/generated/FStar_Extraction_ML_RemoveUnusedParameters.ml deleted file mode 100644 index 69158370640..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Extraction_ML_RemoveUnusedParameters.ml +++ /dev/null @@ -1,682 +0,0 @@ -open Prims -type argument_tag = - | Retain - | Omit -let (uu___is_Retain : argument_tag -> Prims.bool) = - fun projectee -> match projectee with | Retain -> true | uu___ -> false -let (uu___is_Omit : argument_tag -> Prims.bool) = - fun projectee -> match projectee with | Omit -> true | uu___ -> false -type entry = argument_tag Prims.list -type env_t = - { - current_module: FStar_Extraction_ML_Syntax.mlsymbol Prims.list ; - tydef_map: entry FStar_Compiler_Util.psmap } -let (__proj__Mkenv_t__item__current_module : - env_t -> FStar_Extraction_ML_Syntax.mlsymbol Prims.list) = - fun projectee -> - match projectee with | { current_module; tydef_map;_} -> current_module -let (__proj__Mkenv_t__item__tydef_map : - env_t -> entry FStar_Compiler_Util.psmap) = - fun projectee -> - match projectee with | { current_module; tydef_map;_} -> tydef_map -let (initial_env : env_t) = - let uu___ = FStar_Compiler_Util.psmap_empty () in - { current_module = []; tydef_map = uu___ } -type tydef = - (FStar_Extraction_ML_Syntax.mlsymbol * FStar_Extraction_ML_Syntax.metadata - * (FStar_Extraction_ML_Syntax.mltyscheme, Prims.int) - FStar_Pervasives.either) -let (extend_env : - env_t -> FStar_Extraction_ML_Syntax.mlsymbol -> entry -> env_t) = - fun env -> - fun i -> - fun e -> - let uu___ = - let uu___1 = - FStar_Extraction_ML_Syntax.string_of_mlpath - ((env.current_module), i) in - FStar_Compiler_Util.psmap_add env.tydef_map uu___1 e in - { current_module = (env.current_module); tydef_map = uu___ } -let (lookup_tyname : - env_t -> - FStar_Extraction_ML_Syntax.mlpath -> entry FStar_Pervasives_Native.option) - = - fun env -> - fun name -> - let uu___ = FStar_Extraction_ML_Syntax.string_of_mlpath name in - FStar_Compiler_Util.psmap_try_find env.tydef_map uu___ -type var_set = FStar_Extraction_ML_Syntax.mlident FStar_Compiler_RBSet.t -let (empty_var_set : Prims.string FStar_Compiler_RBSet.t) = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset FStar_Class_Ord.ord_string)) ()) -let rec (freevars_of_mlty' : - var_set -> FStar_Extraction_ML_Syntax.mlty -> var_set) = - fun uu___1 -> - fun uu___ -> - (fun vars -> - fun t -> - match t with - | FStar_Extraction_ML_Syntax.MLTY_Var i -> - Obj.magic - (Obj.repr - (FStar_Class_Setlike.add () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) i (Obj.magic vars))) - | FStar_Extraction_ML_Syntax.MLTY_Fun (t0, uu___, t1) -> - Obj.magic - (Obj.repr - (let uu___1 = freevars_of_mlty' vars t0 in - freevars_of_mlty' uu___1 t1)) - | FStar_Extraction_ML_Syntax.MLTY_Named (tys, uu___) -> - Obj.magic - (Obj.repr - (FStar_Compiler_List.fold_left freevars_of_mlty' vars tys)) - | FStar_Extraction_ML_Syntax.MLTY_Tuple tys -> - Obj.magic - (Obj.repr - (FStar_Compiler_List.fold_left freevars_of_mlty' vars tys)) - | uu___ -> Obj.magic (Obj.repr vars)) uu___1 uu___ -let (freevars_of_mlty : FStar_Extraction_ML_Syntax.mlty -> var_set) = - freevars_of_mlty' empty_var_set -let rec (elim_mlty : - env_t -> FStar_Extraction_ML_Syntax.mlty -> FStar_Extraction_ML_Syntax.mlty) - = - fun env -> - fun mlty -> - match mlty with - | FStar_Extraction_ML_Syntax.MLTY_Var uu___ -> mlty - | FStar_Extraction_ML_Syntax.MLTY_Fun (t0, e, t1) -> - let uu___ = - let uu___1 = elim_mlty env t0 in - let uu___2 = elim_mlty env t1 in (uu___1, e, uu___2) in - FStar_Extraction_ML_Syntax.MLTY_Fun uu___ - | FStar_Extraction_ML_Syntax.MLTY_Named (args, name) -> - let args1 = FStar_Compiler_List.map (elim_mlty env) args in - let uu___ = lookup_tyname env name in - (match uu___ with - | FStar_Pervasives_Native.None -> - FStar_Extraction_ML_Syntax.MLTY_Named (args1, name) - | FStar_Pervasives_Native.Some entry1 -> - (if - (FStar_Compiler_List.length entry1) <> - (FStar_Compiler_List.length args1) - then - failwith - "Impossible: arity mismatch between definition and use" - else (); - (let args2 = - FStar_Compiler_List.fold_right2 - (fun arg -> - fun tag -> - fun out -> - match tag with - | Retain -> arg :: out - | uu___2 -> out) args1 entry1 [] in - FStar_Extraction_ML_Syntax.MLTY_Named (args2, name)))) - | FStar_Extraction_ML_Syntax.MLTY_Tuple tys -> - let uu___ = FStar_Compiler_List.map (elim_mlty env) tys in - FStar_Extraction_ML_Syntax.MLTY_Tuple uu___ - | FStar_Extraction_ML_Syntax.MLTY_Top -> mlty - | FStar_Extraction_ML_Syntax.MLTY_Erased -> mlty -let rec (elim_mlexpr' : - env_t -> - FStar_Extraction_ML_Syntax.mlexpr' -> FStar_Extraction_ML_Syntax.mlexpr') - = - fun env -> - fun e -> - match e with - | FStar_Extraction_ML_Syntax.MLE_Const uu___ -> e - | FStar_Extraction_ML_Syntax.MLE_Var uu___ -> e - | FStar_Extraction_ML_Syntax.MLE_Name uu___ -> e - | FStar_Extraction_ML_Syntax.MLE_Let (lb, e1) -> - let uu___ = - let uu___1 = elim_letbinding env lb in - let uu___2 = elim_mlexpr env e1 in (uu___1, uu___2) in - FStar_Extraction_ML_Syntax.MLE_Let uu___ - | FStar_Extraction_ML_Syntax.MLE_App (e1, es) -> - let uu___ = - let uu___1 = elim_mlexpr env e1 in - let uu___2 = FStar_Compiler_List.map (elim_mlexpr env) es in - (uu___1, uu___2) in - FStar_Extraction_ML_Syntax.MLE_App uu___ - | FStar_Extraction_ML_Syntax.MLE_TApp (e1, tys) -> - let uu___ = - let uu___1 = FStar_Compiler_List.map (elim_mlty env) tys in - (e1, uu___1) in - FStar_Extraction_ML_Syntax.MLE_TApp uu___ - | FStar_Extraction_ML_Syntax.MLE_Fun (bvs, e1) -> - let uu___ = - let uu___1 = - FStar_Compiler_List.map - (fun b -> - let uu___2 = - elim_mlty env b.FStar_Extraction_ML_Syntax.mlbinder_ty in - let uu___3 = - FStar_Compiler_List.map (elim_mlexpr env) - b.FStar_Extraction_ML_Syntax.mlbinder_attrs in - { - FStar_Extraction_ML_Syntax.mlbinder_name = - (b.FStar_Extraction_ML_Syntax.mlbinder_name); - FStar_Extraction_ML_Syntax.mlbinder_ty = uu___2; - FStar_Extraction_ML_Syntax.mlbinder_attrs = uu___3 - }) bvs in - let uu___2 = elim_mlexpr env e1 in (uu___1, uu___2) in - FStar_Extraction_ML_Syntax.MLE_Fun uu___ - | FStar_Extraction_ML_Syntax.MLE_Match (e1, branches) -> - let uu___ = - let uu___1 = elim_mlexpr env e1 in - let uu___2 = FStar_Compiler_List.map (elim_branch env) branches in - (uu___1, uu___2) in - FStar_Extraction_ML_Syntax.MLE_Match uu___ - | FStar_Extraction_ML_Syntax.MLE_Coerce (e1, t0, t1) -> - let uu___ = - let uu___1 = elim_mlexpr env e1 in - let uu___2 = elim_mlty env t0 in - let uu___3 = elim_mlty env t1 in (uu___1, uu___2, uu___3) in - FStar_Extraction_ML_Syntax.MLE_Coerce uu___ - | FStar_Extraction_ML_Syntax.MLE_CTor (l, es) -> - let uu___ = - let uu___1 = FStar_Compiler_List.map (elim_mlexpr env) es in - (l, uu___1) in - FStar_Extraction_ML_Syntax.MLE_CTor uu___ - | FStar_Extraction_ML_Syntax.MLE_Seq es -> - let uu___ = FStar_Compiler_List.map (elim_mlexpr env) es in - FStar_Extraction_ML_Syntax.MLE_Seq uu___ - | FStar_Extraction_ML_Syntax.MLE_Tuple es -> - let uu___ = FStar_Compiler_List.map (elim_mlexpr env) es in - FStar_Extraction_ML_Syntax.MLE_Tuple uu___ - | FStar_Extraction_ML_Syntax.MLE_Record (syms, nm, fields) -> - let uu___ = - let uu___1 = - FStar_Compiler_List.map - (fun uu___2 -> - match uu___2 with - | (s, e1) -> - let uu___3 = elim_mlexpr env e1 in (s, uu___3)) fields in - (syms, nm, uu___1) in - FStar_Extraction_ML_Syntax.MLE_Record uu___ - | FStar_Extraction_ML_Syntax.MLE_Proj (e1, p) -> - let uu___ = let uu___1 = elim_mlexpr env e1 in (uu___1, p) in - FStar_Extraction_ML_Syntax.MLE_Proj uu___ - | FStar_Extraction_ML_Syntax.MLE_If (e1, e11, e2_opt) -> - let uu___ = - let uu___1 = elim_mlexpr env e1 in - let uu___2 = elim_mlexpr env e11 in - let uu___3 = FStar_Compiler_Util.map_opt e2_opt (elim_mlexpr env) in - (uu___1, uu___2, uu___3) in - FStar_Extraction_ML_Syntax.MLE_If uu___ - | FStar_Extraction_ML_Syntax.MLE_Raise (p, es) -> - let uu___ = - let uu___1 = FStar_Compiler_List.map (elim_mlexpr env) es in - (p, uu___1) in - FStar_Extraction_ML_Syntax.MLE_Raise uu___ - | FStar_Extraction_ML_Syntax.MLE_Try (e1, branches) -> - let uu___ = - let uu___1 = elim_mlexpr env e1 in - let uu___2 = FStar_Compiler_List.map (elim_branch env) branches in - (uu___1, uu___2) in - FStar_Extraction_ML_Syntax.MLE_Try uu___ -and (elim_letbinding : - env_t -> - (FStar_Extraction_ML_Syntax.mlletflavor * FStar_Extraction_ML_Syntax.mllb - Prims.list) -> - (FStar_Extraction_ML_Syntax.mlletflavor * - FStar_Extraction_ML_Syntax.mllb Prims.list)) - = - fun env -> - fun uu___ -> - match uu___ with - | (flavor, lbs) -> - let elim_one_lb lb = - let ts = - FStar_Compiler_Util.map_opt - lb.FStar_Extraction_ML_Syntax.mllb_tysc - (fun uu___1 -> - match uu___1 with - | (vars, t) -> - let uu___2 = elim_mlty env t in (vars, uu___2)) in - let expr = elim_mlexpr env lb.FStar_Extraction_ML_Syntax.mllb_def in - { - FStar_Extraction_ML_Syntax.mllb_name = - (lb.FStar_Extraction_ML_Syntax.mllb_name); - FStar_Extraction_ML_Syntax.mllb_tysc = ts; - FStar_Extraction_ML_Syntax.mllb_add_unit = - (lb.FStar_Extraction_ML_Syntax.mllb_add_unit); - FStar_Extraction_ML_Syntax.mllb_def = expr; - FStar_Extraction_ML_Syntax.mllb_attrs = - (lb.FStar_Extraction_ML_Syntax.mllb_attrs); - FStar_Extraction_ML_Syntax.mllb_meta = - (lb.FStar_Extraction_ML_Syntax.mllb_meta); - FStar_Extraction_ML_Syntax.print_typ = - (lb.FStar_Extraction_ML_Syntax.print_typ) - } in - let uu___1 = FStar_Compiler_List.map elim_one_lb lbs in - (flavor, uu___1) -and (elim_branch : - env_t -> - (FStar_Extraction_ML_Syntax.mlpattern * FStar_Extraction_ML_Syntax.mlexpr - FStar_Pervasives_Native.option * FStar_Extraction_ML_Syntax.mlexpr) -> - (FStar_Extraction_ML_Syntax.mlpattern * - FStar_Extraction_ML_Syntax.mlexpr FStar_Pervasives_Native.option * - FStar_Extraction_ML_Syntax.mlexpr)) - = - fun env -> - fun uu___ -> - match uu___ with - | (pat, wopt, e) -> - let uu___1 = FStar_Compiler_Util.map_opt wopt (elim_mlexpr env) in - let uu___2 = elim_mlexpr env e in (pat, uu___1, uu___2) -and (elim_mlexpr : - env_t -> - FStar_Extraction_ML_Syntax.mlexpr -> FStar_Extraction_ML_Syntax.mlexpr) - = - fun env -> - fun e -> - let uu___ = elim_mlexpr' env e.FStar_Extraction_ML_Syntax.expr in - let uu___1 = elim_mlty env e.FStar_Extraction_ML_Syntax.mlty in - { - FStar_Extraction_ML_Syntax.expr = uu___; - FStar_Extraction_ML_Syntax.mlty = uu___1; - FStar_Extraction_ML_Syntax.loc = (e.FStar_Extraction_ML_Syntax.loc) - } -exception Drop_tydef -let (uu___is_Drop_tydef : Prims.exn -> Prims.bool) = - fun projectee -> match projectee with | Drop_tydef -> true | uu___ -> false -let (elim_tydef : - env_t -> - Prims.string -> - FStar_Extraction_ML_Syntax.meta Prims.list -> - FStar_Extraction_ML_Syntax.ty_param Prims.list -> - FStar_Extraction_ML_Syntax.mlty -> - (env_t * (Prims.string * FStar_Extraction_ML_Syntax.meta - Prims.list * FStar_Extraction_ML_Syntax.ty_param Prims.list * - FStar_Extraction_ML_Syntax.mlty))) - = - fun env -> - fun name -> - fun metadata -> - fun parameters -> - fun mlty -> - let val_decl_range = - FStar_Compiler_Util.find_map metadata - (fun uu___ -> - match uu___ with - | FStar_Extraction_ML_Syntax.HasValDecl r -> - FStar_Pervasives_Native.Some r - | uu___1 -> FStar_Pervasives_Native.None) in - let remove_typars_list = - FStar_Compiler_Util.try_find - (fun uu___ -> - match uu___ with - | FStar_Extraction_ML_Syntax.RemoveUnusedTypeParameters - uu___1 -> true - | uu___1 -> false) metadata in - let range_of_tydef = - match remove_typars_list with - | FStar_Pervasives_Native.None -> - FStar_Compiler_Range_Type.dummyRange - | FStar_Pervasives_Native.Some - (FStar_Extraction_ML_Syntax.RemoveUnusedTypeParameters - (uu___, r)) -> r in - let must_eliminate i = - match remove_typars_list with - | FStar_Pervasives_Native.Some - (FStar_Extraction_ML_Syntax.RemoveUnusedTypeParameters - (l, r)) -> FStar_Compiler_List.contains i l - | uu___ -> false in - let can_eliminate i = - match (val_decl_range, remove_typars_list) with - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) - -> true - | uu___ -> false in - let mlty1 = elim_mlty env mlty in - let freevars = freevars_of_mlty mlty1 in - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun param -> - match uu___1 with - | (i, params, entry1) -> - let p = - param.FStar_Extraction_ML_Syntax.ty_param_name in - let uu___2 = - FStar_Class_Setlike.mem () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) p - (Obj.magic freevars) in - if uu___2 - then - (if must_eliminate i - then - (let uu___4 = - FStar_Compiler_Util.format2 - "Expected parameter %s of %s to be unused in its definition and eliminated" - p name in - FStar_Errors.log_issue - FStar_Class_HasRange.hasRange_range - range_of_tydef - FStar_Errors_Codes.Error_RemoveUnusedTypeParameter - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4)) - else (); - ((i + Prims.int_one), (param :: params), (Retain - :: entry1))) - else - if (can_eliminate i) || (must_eliminate i) - then - ((i + Prims.int_one), params, (Omit :: entry1)) - else - (let uu___5 = - let uu___6 = FStar_Options.codegen () in - uu___6 = - (FStar_Pervasives_Native.Some - FStar_Options.FSharp) in - if uu___5 - then - let range = - match val_decl_range with - | FStar_Pervasives_Native.Some r -> r - | uu___6 -> range_of_tydef in - ((let uu___7 = - let uu___8 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - i in - let uu___9 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - i in - FStar_Compiler_Util.format3 - "Parameter %s of %s is unused and must be eliminated for F#; add `[@@ remove_unused_type_parameters [%s; ...]]` to the interface signature; \nThis type definition is being dropped" - uu___8 name uu___9 in - FStar_Errors.log_issue - FStar_Class_HasRange.hasRange_range range - FStar_Errors_Codes.Error_RemoveUnusedTypeParameter - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___7)); - FStar_Compiler_Effect.raise Drop_tydef) - else - ((i + Prims.int_one), (param :: params), - (Retain :: entry1)))) - (Prims.int_zero, [], []) parameters in - match uu___ with - | (uu___1, parameters1, entry1) -> - let uu___2 = - extend_env env name (FStar_Compiler_List.rev entry1) in - (uu___2, - (name, metadata, (FStar_Compiler_List.rev parameters1), - mlty1)) -let (elim_tydef_or_decl : env_t -> tydef -> (env_t * tydef)) = - fun env -> - fun td -> - match td with - | (name, metadata, FStar_Pervasives.Inr arity) -> - let remove_typars_list = - FStar_Compiler_Util.try_find - (fun uu___ -> - match uu___ with - | FStar_Extraction_ML_Syntax.RemoveUnusedTypeParameters - uu___1 -> true - | uu___1 -> false) metadata in - (match remove_typars_list with - | FStar_Pervasives_Native.None -> (env, td) - | FStar_Pervasives_Native.Some - (FStar_Extraction_ML_Syntax.RemoveUnusedTypeParameters - (l, r)) -> - let must_eliminate i = FStar_Compiler_List.contains i l in - let rec aux i = - if i = arity - then [] - else - if must_eliminate i - then - (let uu___1 = aux (i + Prims.int_one) in Omit :: uu___1) - else - (let uu___2 = aux (i + Prims.int_one) in Retain :: - uu___2) in - let entries = aux Prims.int_zero in - let uu___ = extend_env env name entries in (uu___, td)) - | (name, metadata, FStar_Pervasives.Inl (parameters, mlty)) -> - let uu___ = elim_tydef env name metadata parameters mlty in - (match uu___ with - | (env1, (name1, meta, params, mlty1)) -> - (env1, (name1, meta, (FStar_Pervasives.Inl (params, mlty1))))) -let (elim_tydefs : env_t -> tydef Prims.list -> (env_t * tydef Prims.list)) = - fun env -> - fun tds -> - let uu___ = - let uu___1 = FStar_Options.codegen () in - uu___1 <> (FStar_Pervasives_Native.Some FStar_Options.FSharp) in - if uu___ - then (env, tds) - else - (let uu___2 = - FStar_Compiler_List.fold_left - (fun uu___3 -> - fun td -> - match uu___3 with - | (env1, out) -> - (try - (fun uu___4 -> - match () with - | () -> - let uu___5 = elim_tydef_or_decl env1 td in - (match uu___5 with - | (env2, td1) -> (env2, (td1 :: out)))) () - with | Drop_tydef -> (env1, out))) (env, []) tds in - match uu___2 with - | (env1, tds1) -> (env1, (FStar_Compiler_List.rev tds1))) -let (elim_one_mltydecl : - env_t -> - FStar_Extraction_ML_Syntax.one_mltydecl -> - (env_t * FStar_Extraction_ML_Syntax.one_mltydecl)) - = - fun env -> - fun td -> - let uu___ = td in - match uu___ with - | { FStar_Extraction_ML_Syntax.tydecl_assumed = uu___1; - FStar_Extraction_ML_Syntax.tydecl_name = name; - FStar_Extraction_ML_Syntax.tydecl_ignored = uu___2; - FStar_Extraction_ML_Syntax.tydecl_parameters = parameters; - FStar_Extraction_ML_Syntax.tydecl_meta = meta; - FStar_Extraction_ML_Syntax.tydecl_defn = body;_} -> - let elim_td td1 = - match td1 with - | FStar_Extraction_ML_Syntax.MLTD_Abbrev mlty -> - let uu___3 = elim_tydef env name meta parameters mlty in - (match uu___3 with - | (env1, (name1, uu___4, parameters1, mlty1)) -> - (env1, parameters1, - (FStar_Extraction_ML_Syntax.MLTD_Abbrev mlty1))) - | FStar_Extraction_ML_Syntax.MLTD_Record fields -> - let uu___3 = - let uu___4 = - FStar_Compiler_List.map - (fun uu___5 -> - match uu___5 with - | (name1, ty) -> - let uu___6 = elim_mlty env ty in (name1, uu___6)) - fields in - FStar_Extraction_ML_Syntax.MLTD_Record uu___4 in - (env, parameters, uu___3) - | FStar_Extraction_ML_Syntax.MLTD_DType inductive -> - let uu___3 = - let uu___4 = - FStar_Compiler_List.map - (fun uu___5 -> - match uu___5 with - | (i, constrs) -> - let uu___6 = - FStar_Compiler_List.map - (fun uu___7 -> - match uu___7 with - | (constr, ty) -> - let uu___8 = elim_mlty env ty in - (constr, uu___8)) constrs in - (i, uu___6)) inductive in - FStar_Extraction_ML_Syntax.MLTD_DType uu___4 in - (env, parameters, uu___3) in - let uu___3 = - match body with - | FStar_Pervasives_Native.None -> (env, parameters, body) - | FStar_Pervasives_Native.Some td1 -> - let uu___4 = elim_td td1 in - (match uu___4 with - | (env1, parameters1, td2) -> - (env1, parameters1, (FStar_Pervasives_Native.Some td2))) in - (match uu___3 with - | (env1, parameters1, body1) -> - (env1, - { - FStar_Extraction_ML_Syntax.tydecl_assumed = - (td.FStar_Extraction_ML_Syntax.tydecl_assumed); - FStar_Extraction_ML_Syntax.tydecl_name = - (td.FStar_Extraction_ML_Syntax.tydecl_name); - FStar_Extraction_ML_Syntax.tydecl_ignored = - (td.FStar_Extraction_ML_Syntax.tydecl_ignored); - FStar_Extraction_ML_Syntax.tydecl_parameters = parameters1; - FStar_Extraction_ML_Syntax.tydecl_meta = - (td.FStar_Extraction_ML_Syntax.tydecl_meta); - FStar_Extraction_ML_Syntax.tydecl_defn = body1 - })) -let (elim_module : - env_t -> - FStar_Extraction_ML_Syntax.mlmodule1 Prims.list -> - (env_t * FStar_Extraction_ML_Syntax.mlmodule1 Prims.list)) - = - fun env -> - fun m -> - let elim_module1 env1 m1 = - match m1.FStar_Extraction_ML_Syntax.mlmodule1_m with - | FStar_Extraction_ML_Syntax.MLM_Ty td -> - let uu___ = - FStar_Compiler_Util.fold_map elim_one_mltydecl env1 td in - (match uu___ with - | (env2, td1) -> - (env2, - { - FStar_Extraction_ML_Syntax.mlmodule1_m = - (FStar_Extraction_ML_Syntax.MLM_Ty td1); - FStar_Extraction_ML_Syntax.mlmodule1_attrs = - (m1.FStar_Extraction_ML_Syntax.mlmodule1_attrs) - })) - | FStar_Extraction_ML_Syntax.MLM_Let lb -> - let uu___ = - let uu___1 = - let uu___2 = elim_letbinding env1 lb in - FStar_Extraction_ML_Syntax.MLM_Let uu___2 in - { - FStar_Extraction_ML_Syntax.mlmodule1_m = uu___1; - FStar_Extraction_ML_Syntax.mlmodule1_attrs = - (m1.FStar_Extraction_ML_Syntax.mlmodule1_attrs) - } in - (env1, uu___) - | FStar_Extraction_ML_Syntax.MLM_Exn (name, sym_tys) -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Compiler_List.map - (fun uu___4 -> - match uu___4 with - | (s, t) -> - let uu___5 = elim_mlty env1 t in (s, uu___5)) - sym_tys in - (name, uu___3) in - FStar_Extraction_ML_Syntax.MLM_Exn uu___2 in - { - FStar_Extraction_ML_Syntax.mlmodule1_m = uu___1; - FStar_Extraction_ML_Syntax.mlmodule1_attrs = - (m1.FStar_Extraction_ML_Syntax.mlmodule1_attrs) - } in - (env1, uu___) - | FStar_Extraction_ML_Syntax.MLM_Top e -> - let uu___ = - let uu___1 = - let uu___2 = elim_mlexpr env1 e in - FStar_Extraction_ML_Syntax.MLM_Top uu___2 in - { - FStar_Extraction_ML_Syntax.mlmodule1_m = uu___1; - FStar_Extraction_ML_Syntax.mlmodule1_attrs = - (m1.FStar_Extraction_ML_Syntax.mlmodule1_attrs) - } in - (env1, uu___) - | uu___ -> (env1, m1) in - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun m1 -> - match uu___1 with - | (env1, out) -> - (try - (fun uu___2 -> - match () with - | () -> - let uu___3 = elim_module1 env1 m1 in - (match uu___3 with - | (env2, m2) -> (env2, (m2 :: out)))) () - with | Drop_tydef -> (env1, out))) (env, []) m in - match uu___ with | (env1, m1) -> (env1, (FStar_Compiler_List.rev m1)) -let (set_current_module : - env_t -> FStar_Extraction_ML_Syntax.mlpath -> env_t) = - fun e -> - fun n -> - let curmod = - FStar_Compiler_List.op_At (FStar_Pervasives_Native.fst n) - [FStar_Pervasives_Native.snd n] in - { current_module = curmod; tydef_map = (e.tydef_map) } -let (elim_mllib : - env_t -> - FStar_Extraction_ML_Syntax.mllib -> - (env_t * FStar_Extraction_ML_Syntax.mllib)) - = - fun env -> - fun m -> - let uu___ = - let uu___1 = FStar_Options.codegen () in - uu___1 <> (FStar_Pervasives_Native.Some FStar_Options.FSharp) in - if uu___ - then (env, m) - else - (let uu___2 = m in - match uu___2 with - | FStar_Extraction_ML_Syntax.MLLib libs -> - let elim_one_lib env1 lib = - let uu___3 = lib in - match uu___3 with - | (name, sig_mod, _libs) -> - let env2 = set_current_module env1 name in - let uu___4 = - match sig_mod with - | FStar_Pervasives_Native.Some (sig_, mod_) -> - let uu___5 = elim_module env2 mod_ in - (match uu___5 with - | (env3, mod_1) -> - ((FStar_Pervasives_Native.Some (sig_, mod_1)), - env3)) - | FStar_Pervasives_Native.None -> - (FStar_Pervasives_Native.None, env2) in - (match uu___4 with - | (sig_mod1, env3) -> (env3, (name, sig_mod1, _libs))) in - let uu___3 = FStar_Compiler_Util.fold_map elim_one_lib env libs in - (match uu___3 with - | (env1, libs1) -> - (env1, (FStar_Extraction_ML_Syntax.MLLib libs1)))) -let (elim_mllibs : - FStar_Extraction_ML_Syntax.mllib Prims.list -> - FStar_Extraction_ML_Syntax.mllib Prims.list) - = - fun l -> - let uu___ = FStar_Compiler_Util.fold_map elim_mllib initial_env l in - FStar_Pervasives_Native.snd uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Extraction_ML_Syntax.ml b/ocaml/fstar-lib/generated/FStar_Extraction_ML_Syntax.ml deleted file mode 100644 index b5794028ebc..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Extraction_ML_Syntax.ml +++ /dev/null @@ -1,1317 +0,0 @@ -open Prims -type mlsymbol = Prims.string -type mlident = mlsymbol -type mlpath = (mlsymbol Prims.list * mlsymbol) -let (krml_keywords : Prims.string Prims.list) = [] -let (ocamlkeywords : Prims.string Prims.list) = - ["and"; - "as"; - "assert"; - "asr"; - "begin"; - "class"; - "constraint"; - "do"; - "done"; - "downto"; - "else"; - "end"; - "exception"; - "external"; - "false"; - "for"; - "fun"; - "function"; - "functor"; - "if"; - "in"; - "include"; - "inherit"; - "initializer"; - "land"; - "lazy"; - "let"; - "lor"; - "lsl"; - "lsr"; - "lxor"; - "match"; - "method"; - "mod"; - "module"; - "mutable"; - "new"; - "object"; - "of"; - "open"; - "or"; - "private"; - "rec"; - "sig"; - "struct"; - "then"; - "to"; - "true"; - "try"; - "type"; - "val"; - "virtual"; - "when"; - "while"; - "with"; - "nonrec"] -let (fsharpkeywords : Prims.string Prims.list) = - ["abstract"; - "and"; - "as"; - "assert"; - "base"; - "begin"; - "class"; - "default"; - "delegate"; - "do"; - "done"; - "downcast"; - "downto"; - "elif"; - "else"; - "end"; - "exception"; - "extern"; - "false"; - "finally"; - "fixed"; - "for"; - "fun"; - "function"; - "global"; - "if"; - "in"; - "inherit"; - "inline"; - "interface"; - "internal"; - "lazy"; - "let"; - "let!"; - "match"; - "member"; - "module"; - "mutable"; - "namespace"; - "new"; - "not"; - "null"; - "of"; - "open"; - "or"; - "override"; - "private"; - "public"; - "rec"; - "return"; - "return!"; - "select"; - "static"; - "struct"; - "then"; - "to"; - "true"; - "try"; - "type"; - "upcast"; - "use"; - "use!"; - "val"; - "void"; - "when"; - "while"; - "with"; - "yield"; - "yield!"; - "asr"; - "land"; - "lor"; - "lsl"; - "lsr"; - "lxor"; - "mod"; - "sig"; - "atomic"; - "break"; - "checked"; - "component"; - "const"; - "constraint"; - "constructor"; - "continue"; - "eager"; - "event"; - "external"; - "fixed"; - "functor"; - "include"; - "method"; - "mixin"; - "object"; - "parallel"; - "process"; - "protected"; - "pure"; - "sealed"; - "tailcall"; - "trait"; - "virtual"; - "volatile"] -let (string_of_mlpath : mlpath -> Prims.string) = - fun uu___ -> - match uu___ with - | (p, s) -> - FStar_Compiler_String.concat "." (FStar_Compiler_List.op_At p [s]) -type mlidents = mlident Prims.list -type mlsymbols = mlsymbol Prims.list -type e_tag = - | E_PURE - | E_ERASABLE - | E_IMPURE -let (uu___is_E_PURE : e_tag -> Prims.bool) = - fun projectee -> match projectee with | E_PURE -> true | uu___ -> false -let (uu___is_E_ERASABLE : e_tag -> Prims.bool) = - fun projectee -> match projectee with | E_ERASABLE -> true | uu___ -> false -let (uu___is_E_IMPURE : e_tag -> Prims.bool) = - fun projectee -> match projectee with | E_IMPURE -> true | uu___ -> false -type mlloc = (Prims.int * Prims.string) -let (dummy_loc : mlloc) = (Prims.int_zero, "") -type mlty = - | MLTY_Var of mlident - | MLTY_Fun of (mlty * e_tag * mlty) - | MLTY_Named of (mlty Prims.list * mlpath) - | MLTY_Tuple of mlty Prims.list - | MLTY_Top - | MLTY_Erased -let (uu___is_MLTY_Var : mlty -> Prims.bool) = - fun projectee -> - match projectee with | MLTY_Var _0 -> true | uu___ -> false -let (__proj__MLTY_Var__item___0 : mlty -> mlident) = - fun projectee -> match projectee with | MLTY_Var _0 -> _0 -let (uu___is_MLTY_Fun : mlty -> Prims.bool) = - fun projectee -> - match projectee with | MLTY_Fun _0 -> true | uu___ -> false -let (__proj__MLTY_Fun__item___0 : mlty -> (mlty * e_tag * mlty)) = - fun projectee -> match projectee with | MLTY_Fun _0 -> _0 -let (uu___is_MLTY_Named : mlty -> Prims.bool) = - fun projectee -> - match projectee with | MLTY_Named _0 -> true | uu___ -> false -let (__proj__MLTY_Named__item___0 : mlty -> (mlty Prims.list * mlpath)) = - fun projectee -> match projectee with | MLTY_Named _0 -> _0 -let (uu___is_MLTY_Tuple : mlty -> Prims.bool) = - fun projectee -> - match projectee with | MLTY_Tuple _0 -> true | uu___ -> false -let (__proj__MLTY_Tuple__item___0 : mlty -> mlty Prims.list) = - fun projectee -> match projectee with | MLTY_Tuple _0 -> _0 -let (uu___is_MLTY_Top : mlty -> Prims.bool) = - fun projectee -> match projectee with | MLTY_Top -> true | uu___ -> false -let (uu___is_MLTY_Erased : mlty -> Prims.bool) = - fun projectee -> - match projectee with | MLTY_Erased -> true | uu___ -> false -type mlconstant = - | MLC_Unit - | MLC_Bool of Prims.bool - | MLC_Int of (Prims.string * (FStar_Const.signedness * FStar_Const.width) - FStar_Pervasives_Native.option) - | MLC_Float of FStar_BaseTypes.float - | MLC_Char of FStar_BaseTypes.char - | MLC_String of Prims.string - | MLC_Bytes of FStar_BaseTypes.byte Prims.array -let (uu___is_MLC_Unit : mlconstant -> Prims.bool) = - fun projectee -> match projectee with | MLC_Unit -> true | uu___ -> false -let (uu___is_MLC_Bool : mlconstant -> Prims.bool) = - fun projectee -> - match projectee with | MLC_Bool _0 -> true | uu___ -> false -let (__proj__MLC_Bool__item___0 : mlconstant -> Prims.bool) = - fun projectee -> match projectee with | MLC_Bool _0 -> _0 -let (uu___is_MLC_Int : mlconstant -> Prims.bool) = - fun projectee -> match projectee with | MLC_Int _0 -> true | uu___ -> false -let (__proj__MLC_Int__item___0 : - mlconstant -> - (Prims.string * (FStar_Const.signedness * FStar_Const.width) - FStar_Pervasives_Native.option)) - = fun projectee -> match projectee with | MLC_Int _0 -> _0 -let (uu___is_MLC_Float : mlconstant -> Prims.bool) = - fun projectee -> - match projectee with | MLC_Float _0 -> true | uu___ -> false -let (__proj__MLC_Float__item___0 : mlconstant -> FStar_BaseTypes.float) = - fun projectee -> match projectee with | MLC_Float _0 -> _0 -let (uu___is_MLC_Char : mlconstant -> Prims.bool) = - fun projectee -> - match projectee with | MLC_Char _0 -> true | uu___ -> false -let (__proj__MLC_Char__item___0 : mlconstant -> FStar_BaseTypes.char) = - fun projectee -> match projectee with | MLC_Char _0 -> _0 -let (uu___is_MLC_String : mlconstant -> Prims.bool) = - fun projectee -> - match projectee with | MLC_String _0 -> true | uu___ -> false -let (__proj__MLC_String__item___0 : mlconstant -> Prims.string) = - fun projectee -> match projectee with | MLC_String _0 -> _0 -let (uu___is_MLC_Bytes : mlconstant -> Prims.bool) = - fun projectee -> - match projectee with | MLC_Bytes _0 -> true | uu___ -> false -let (__proj__MLC_Bytes__item___0 : - mlconstant -> FStar_BaseTypes.byte Prims.array) = - fun projectee -> match projectee with | MLC_Bytes _0 -> _0 -type mlpattern = - | MLP_Wild - | MLP_Const of mlconstant - | MLP_Var of mlident - | MLP_CTor of (mlpath * mlpattern Prims.list) - | MLP_Branch of mlpattern Prims.list - | MLP_Record of (mlsymbol Prims.list * (mlsymbol * mlpattern) Prims.list) - | MLP_Tuple of mlpattern Prims.list -let (uu___is_MLP_Wild : mlpattern -> Prims.bool) = - fun projectee -> match projectee with | MLP_Wild -> true | uu___ -> false -let (uu___is_MLP_Const : mlpattern -> Prims.bool) = - fun projectee -> - match projectee with | MLP_Const _0 -> true | uu___ -> false -let (__proj__MLP_Const__item___0 : mlpattern -> mlconstant) = - fun projectee -> match projectee with | MLP_Const _0 -> _0 -let (uu___is_MLP_Var : mlpattern -> Prims.bool) = - fun projectee -> match projectee with | MLP_Var _0 -> true | uu___ -> false -let (__proj__MLP_Var__item___0 : mlpattern -> mlident) = - fun projectee -> match projectee with | MLP_Var _0 -> _0 -let (uu___is_MLP_CTor : mlpattern -> Prims.bool) = - fun projectee -> - match projectee with | MLP_CTor _0 -> true | uu___ -> false -let (__proj__MLP_CTor__item___0 : - mlpattern -> (mlpath * mlpattern Prims.list)) = - fun projectee -> match projectee with | MLP_CTor _0 -> _0 -let (uu___is_MLP_Branch : mlpattern -> Prims.bool) = - fun projectee -> - match projectee with | MLP_Branch _0 -> true | uu___ -> false -let (__proj__MLP_Branch__item___0 : mlpattern -> mlpattern Prims.list) = - fun projectee -> match projectee with | MLP_Branch _0 -> _0 -let (uu___is_MLP_Record : mlpattern -> Prims.bool) = - fun projectee -> - match projectee with | MLP_Record _0 -> true | uu___ -> false -let (__proj__MLP_Record__item___0 : - mlpattern -> (mlsymbol Prims.list * (mlsymbol * mlpattern) Prims.list)) = - fun projectee -> match projectee with | MLP_Record _0 -> _0 -let (uu___is_MLP_Tuple : mlpattern -> Prims.bool) = - fun projectee -> - match projectee with | MLP_Tuple _0 -> true | uu___ -> false -let (__proj__MLP_Tuple__item___0 : mlpattern -> mlpattern Prims.list) = - fun projectee -> match projectee with | MLP_Tuple _0 -> _0 -type meta = - | Mutable - | Assumed - | Private - | NoExtract - | CInline - | Substitute - | GCType - | PpxDerivingShow - | PpxDerivingShowConstant of Prims.string - | PpxDerivingYoJson - | Comment of Prims.string - | StackInline - | CPrologue of Prims.string - | CEpilogue of Prims.string - | CConst of Prims.string - | CCConv of Prims.string - | Erased - | CAbstract - | CIfDef - | CMacro - | Deprecated of Prims.string - | RemoveUnusedTypeParameters of (Prims.int Prims.list * - FStar_Compiler_Range_Type.range) - | HasValDecl of FStar_Compiler_Range_Type.range - | CNoInline -let (uu___is_Mutable : meta -> Prims.bool) = - fun projectee -> match projectee with | Mutable -> true | uu___ -> false -let (uu___is_Assumed : meta -> Prims.bool) = - fun projectee -> match projectee with | Assumed -> true | uu___ -> false -let (uu___is_Private : meta -> Prims.bool) = - fun projectee -> match projectee with | Private -> true | uu___ -> false -let (uu___is_NoExtract : meta -> Prims.bool) = - fun projectee -> match projectee with | NoExtract -> true | uu___ -> false -let (uu___is_CInline : meta -> Prims.bool) = - fun projectee -> match projectee with | CInline -> true | uu___ -> false -let (uu___is_Substitute : meta -> Prims.bool) = - fun projectee -> match projectee with | Substitute -> true | uu___ -> false -let (uu___is_GCType : meta -> Prims.bool) = - fun projectee -> match projectee with | GCType -> true | uu___ -> false -let (uu___is_PpxDerivingShow : meta -> Prims.bool) = - fun projectee -> - match projectee with | PpxDerivingShow -> true | uu___ -> false -let (uu___is_PpxDerivingShowConstant : meta -> Prims.bool) = - fun projectee -> - match projectee with - | PpxDerivingShowConstant _0 -> true - | uu___ -> false -let (__proj__PpxDerivingShowConstant__item___0 : meta -> Prims.string) = - fun projectee -> match projectee with | PpxDerivingShowConstant _0 -> _0 -let (uu___is_PpxDerivingYoJson : meta -> Prims.bool) = - fun projectee -> - match projectee with | PpxDerivingYoJson -> true | uu___ -> false -let (uu___is_Comment : meta -> Prims.bool) = - fun projectee -> match projectee with | Comment _0 -> true | uu___ -> false -let (__proj__Comment__item___0 : meta -> Prims.string) = - fun projectee -> match projectee with | Comment _0 -> _0 -let (uu___is_StackInline : meta -> Prims.bool) = - fun projectee -> - match projectee with | StackInline -> true | uu___ -> false -let (uu___is_CPrologue : meta -> Prims.bool) = - fun projectee -> - match projectee with | CPrologue _0 -> true | uu___ -> false -let (__proj__CPrologue__item___0 : meta -> Prims.string) = - fun projectee -> match projectee with | CPrologue _0 -> _0 -let (uu___is_CEpilogue : meta -> Prims.bool) = - fun projectee -> - match projectee with | CEpilogue _0 -> true | uu___ -> false -let (__proj__CEpilogue__item___0 : meta -> Prims.string) = - fun projectee -> match projectee with | CEpilogue _0 -> _0 -let (uu___is_CConst : meta -> Prims.bool) = - fun projectee -> match projectee with | CConst _0 -> true | uu___ -> false -let (__proj__CConst__item___0 : meta -> Prims.string) = - fun projectee -> match projectee with | CConst _0 -> _0 -let (uu___is_CCConv : meta -> Prims.bool) = - fun projectee -> match projectee with | CCConv _0 -> true | uu___ -> false -let (__proj__CCConv__item___0 : meta -> Prims.string) = - fun projectee -> match projectee with | CCConv _0 -> _0 -let (uu___is_Erased : meta -> Prims.bool) = - fun projectee -> match projectee with | Erased -> true | uu___ -> false -let (uu___is_CAbstract : meta -> Prims.bool) = - fun projectee -> match projectee with | CAbstract -> true | uu___ -> false -let (uu___is_CIfDef : meta -> Prims.bool) = - fun projectee -> match projectee with | CIfDef -> true | uu___ -> false -let (uu___is_CMacro : meta -> Prims.bool) = - fun projectee -> match projectee with | CMacro -> true | uu___ -> false -let (uu___is_Deprecated : meta -> Prims.bool) = - fun projectee -> - match projectee with | Deprecated _0 -> true | uu___ -> false -let (__proj__Deprecated__item___0 : meta -> Prims.string) = - fun projectee -> match projectee with | Deprecated _0 -> _0 -let (uu___is_RemoveUnusedTypeParameters : meta -> Prims.bool) = - fun projectee -> - match projectee with - | RemoveUnusedTypeParameters _0 -> true - | uu___ -> false -let (__proj__RemoveUnusedTypeParameters__item___0 : - meta -> (Prims.int Prims.list * FStar_Compiler_Range_Type.range)) = - fun projectee -> match projectee with | RemoveUnusedTypeParameters _0 -> _0 -let (uu___is_HasValDecl : meta -> Prims.bool) = - fun projectee -> - match projectee with | HasValDecl _0 -> true | uu___ -> false -let (__proj__HasValDecl__item___0 : meta -> FStar_Compiler_Range_Type.range) - = fun projectee -> match projectee with | HasValDecl _0 -> _0 -let (uu___is_CNoInline : meta -> Prims.bool) = - fun projectee -> match projectee with | CNoInline -> true | uu___ -> false -type metadata = meta Prims.list -type mlletflavor = - | Rec - | NonRec -let (uu___is_Rec : mlletflavor -> Prims.bool) = - fun projectee -> match projectee with | Rec -> true | uu___ -> false -let (uu___is_NonRec : mlletflavor -> Prims.bool) = - fun projectee -> match projectee with | NonRec -> true | uu___ -> false -type mlbinder = - { - mlbinder_name: mlident ; - mlbinder_ty: mlty ; - mlbinder_attrs: mlexpr Prims.list } -and mlexpr' = - | MLE_Const of mlconstant - | MLE_Var of mlident - | MLE_Name of mlpath - | MLE_Let of ((mlletflavor * mllb Prims.list) * mlexpr) - | MLE_App of (mlexpr * mlexpr Prims.list) - | MLE_TApp of (mlexpr * mlty Prims.list) - | MLE_Fun of (mlbinder Prims.list * mlexpr) - | MLE_Match of (mlexpr * (mlpattern * mlexpr FStar_Pervasives_Native.option - * mlexpr) Prims.list) - | MLE_Coerce of (mlexpr * mlty * mlty) - | MLE_CTor of (mlpath * mlexpr Prims.list) - | MLE_Seq of mlexpr Prims.list - | MLE_Tuple of mlexpr Prims.list - | MLE_Record of (mlsymbol Prims.list * mlsymbol * (mlsymbol * mlexpr) - Prims.list) - | MLE_Proj of (mlexpr * mlpath) - | MLE_If of (mlexpr * mlexpr * mlexpr FStar_Pervasives_Native.option) - | MLE_Raise of (mlpath * mlexpr Prims.list) - | MLE_Try of (mlexpr * (mlpattern * mlexpr FStar_Pervasives_Native.option * - mlexpr) Prims.list) -and mlexpr = { - expr: mlexpr' ; - mlty: mlty ; - loc: mlloc } -and mllb = - { - mllb_name: mlident ; - mllb_tysc: (ty_param Prims.list * mlty) FStar_Pervasives_Native.option ; - mllb_add_unit: Prims.bool ; - mllb_def: mlexpr ; - mllb_attrs: mlexpr Prims.list ; - mllb_meta: metadata ; - print_typ: Prims.bool } -and ty_param = { - ty_param_name: mlident ; - ty_param_attrs: mlexpr Prims.list } -let (__proj__Mkmlbinder__item__mlbinder_name : mlbinder -> mlident) = - fun projectee -> - match projectee with - | { mlbinder_name; mlbinder_ty; mlbinder_attrs;_} -> mlbinder_name -let (__proj__Mkmlbinder__item__mlbinder_ty : mlbinder -> mlty) = - fun projectee -> - match projectee with - | { mlbinder_name; mlbinder_ty; mlbinder_attrs;_} -> mlbinder_ty -let (__proj__Mkmlbinder__item__mlbinder_attrs : - mlbinder -> mlexpr Prims.list) = - fun projectee -> - match projectee with - | { mlbinder_name; mlbinder_ty; mlbinder_attrs;_} -> mlbinder_attrs -let (uu___is_MLE_Const : mlexpr' -> Prims.bool) = - fun projectee -> - match projectee with | MLE_Const _0 -> true | uu___ -> false -let (__proj__MLE_Const__item___0 : mlexpr' -> mlconstant) = - fun projectee -> match projectee with | MLE_Const _0 -> _0 -let (uu___is_MLE_Var : mlexpr' -> Prims.bool) = - fun projectee -> match projectee with | MLE_Var _0 -> true | uu___ -> false -let (__proj__MLE_Var__item___0 : mlexpr' -> mlident) = - fun projectee -> match projectee with | MLE_Var _0 -> _0 -let (uu___is_MLE_Name : mlexpr' -> Prims.bool) = - fun projectee -> - match projectee with | MLE_Name _0 -> true | uu___ -> false -let (__proj__MLE_Name__item___0 : mlexpr' -> mlpath) = - fun projectee -> match projectee with | MLE_Name _0 -> _0 -let (uu___is_MLE_Let : mlexpr' -> Prims.bool) = - fun projectee -> match projectee with | MLE_Let _0 -> true | uu___ -> false -let (__proj__MLE_Let__item___0 : - mlexpr' -> ((mlletflavor * mllb Prims.list) * mlexpr)) = - fun projectee -> match projectee with | MLE_Let _0 -> _0 -let (uu___is_MLE_App : mlexpr' -> Prims.bool) = - fun projectee -> match projectee with | MLE_App _0 -> true | uu___ -> false -let (__proj__MLE_App__item___0 : mlexpr' -> (mlexpr * mlexpr Prims.list)) = - fun projectee -> match projectee with | MLE_App _0 -> _0 -let (uu___is_MLE_TApp : mlexpr' -> Prims.bool) = - fun projectee -> - match projectee with | MLE_TApp _0 -> true | uu___ -> false -let (__proj__MLE_TApp__item___0 : mlexpr' -> (mlexpr * mlty Prims.list)) = - fun projectee -> match projectee with | MLE_TApp _0 -> _0 -let (uu___is_MLE_Fun : mlexpr' -> Prims.bool) = - fun projectee -> match projectee with | MLE_Fun _0 -> true | uu___ -> false -let (__proj__MLE_Fun__item___0 : mlexpr' -> (mlbinder Prims.list * mlexpr)) = - fun projectee -> match projectee with | MLE_Fun _0 -> _0 -let (uu___is_MLE_Match : mlexpr' -> Prims.bool) = - fun projectee -> - match projectee with | MLE_Match _0 -> true | uu___ -> false -let (__proj__MLE_Match__item___0 : - mlexpr' -> - (mlexpr * (mlpattern * mlexpr FStar_Pervasives_Native.option * mlexpr) - Prims.list)) - = fun projectee -> match projectee with | MLE_Match _0 -> _0 -let (uu___is_MLE_Coerce : mlexpr' -> Prims.bool) = - fun projectee -> - match projectee with | MLE_Coerce _0 -> true | uu___ -> false -let (__proj__MLE_Coerce__item___0 : mlexpr' -> (mlexpr * mlty * mlty)) = - fun projectee -> match projectee with | MLE_Coerce _0 -> _0 -let (uu___is_MLE_CTor : mlexpr' -> Prims.bool) = - fun projectee -> - match projectee with | MLE_CTor _0 -> true | uu___ -> false -let (__proj__MLE_CTor__item___0 : mlexpr' -> (mlpath * mlexpr Prims.list)) = - fun projectee -> match projectee with | MLE_CTor _0 -> _0 -let (uu___is_MLE_Seq : mlexpr' -> Prims.bool) = - fun projectee -> match projectee with | MLE_Seq _0 -> true | uu___ -> false -let (__proj__MLE_Seq__item___0 : mlexpr' -> mlexpr Prims.list) = - fun projectee -> match projectee with | MLE_Seq _0 -> _0 -let (uu___is_MLE_Tuple : mlexpr' -> Prims.bool) = - fun projectee -> - match projectee with | MLE_Tuple _0 -> true | uu___ -> false -let (__proj__MLE_Tuple__item___0 : mlexpr' -> mlexpr Prims.list) = - fun projectee -> match projectee with | MLE_Tuple _0 -> _0 -let (uu___is_MLE_Record : mlexpr' -> Prims.bool) = - fun projectee -> - match projectee with | MLE_Record _0 -> true | uu___ -> false -let (__proj__MLE_Record__item___0 : - mlexpr' -> - (mlsymbol Prims.list * mlsymbol * (mlsymbol * mlexpr) Prims.list)) - = fun projectee -> match projectee with | MLE_Record _0 -> _0 -let (uu___is_MLE_Proj : mlexpr' -> Prims.bool) = - fun projectee -> - match projectee with | MLE_Proj _0 -> true | uu___ -> false -let (__proj__MLE_Proj__item___0 : mlexpr' -> (mlexpr * mlpath)) = - fun projectee -> match projectee with | MLE_Proj _0 -> _0 -let (uu___is_MLE_If : mlexpr' -> Prims.bool) = - fun projectee -> match projectee with | MLE_If _0 -> true | uu___ -> false -let (__proj__MLE_If__item___0 : - mlexpr' -> (mlexpr * mlexpr * mlexpr FStar_Pervasives_Native.option)) = - fun projectee -> match projectee with | MLE_If _0 -> _0 -let (uu___is_MLE_Raise : mlexpr' -> Prims.bool) = - fun projectee -> - match projectee with | MLE_Raise _0 -> true | uu___ -> false -let (__proj__MLE_Raise__item___0 : mlexpr' -> (mlpath * mlexpr Prims.list)) = - fun projectee -> match projectee with | MLE_Raise _0 -> _0 -let (uu___is_MLE_Try : mlexpr' -> Prims.bool) = - fun projectee -> match projectee with | MLE_Try _0 -> true | uu___ -> false -let (__proj__MLE_Try__item___0 : - mlexpr' -> - (mlexpr * (mlpattern * mlexpr FStar_Pervasives_Native.option * mlexpr) - Prims.list)) - = fun projectee -> match projectee with | MLE_Try _0 -> _0 -let (__proj__Mkmlexpr__item__expr : mlexpr -> mlexpr') = - fun projectee -> - match projectee with | { expr; mlty = mlty1; loc;_} -> expr -let (__proj__Mkmlexpr__item__mlty : mlexpr -> mlty) = - fun projectee -> - match projectee with | { expr; mlty = mlty1; loc;_} -> mlty1 -let (__proj__Mkmlexpr__item__loc : mlexpr -> mlloc) = - fun projectee -> match projectee with | { expr; mlty = mlty1; loc;_} -> loc -let (__proj__Mkmllb__item__mllb_name : mllb -> mlident) = - fun projectee -> - match projectee with - | { mllb_name; mllb_tysc; mllb_add_unit; mllb_def; mllb_attrs; mllb_meta; - print_typ;_} -> mllb_name -let (__proj__Mkmllb__item__mllb_tysc : - mllb -> (ty_param Prims.list * mlty) FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { mllb_name; mllb_tysc; mllb_add_unit; mllb_def; mllb_attrs; mllb_meta; - print_typ;_} -> mllb_tysc -let (__proj__Mkmllb__item__mllb_add_unit : mllb -> Prims.bool) = - fun projectee -> - match projectee with - | { mllb_name; mllb_tysc; mllb_add_unit; mllb_def; mllb_attrs; mllb_meta; - print_typ;_} -> mllb_add_unit -let (__proj__Mkmllb__item__mllb_def : mllb -> mlexpr) = - fun projectee -> - match projectee with - | { mllb_name; mllb_tysc; mllb_add_unit; mllb_def; mllb_attrs; mllb_meta; - print_typ;_} -> mllb_def -let (__proj__Mkmllb__item__mllb_attrs : mllb -> mlexpr Prims.list) = - fun projectee -> - match projectee with - | { mllb_name; mllb_tysc; mllb_add_unit; mllb_def; mllb_attrs; mllb_meta; - print_typ;_} -> mllb_attrs -let (__proj__Mkmllb__item__mllb_meta : mllb -> metadata) = - fun projectee -> - match projectee with - | { mllb_name; mllb_tysc; mllb_add_unit; mllb_def; mllb_attrs; mllb_meta; - print_typ;_} -> mllb_meta -let (__proj__Mkmllb__item__print_typ : mllb -> Prims.bool) = - fun projectee -> - match projectee with - | { mllb_name; mllb_tysc; mllb_add_unit; mllb_def; mllb_attrs; mllb_meta; - print_typ;_} -> print_typ -let (__proj__Mkty_param__item__ty_param_name : ty_param -> mlident) = - fun projectee -> - match projectee with - | { ty_param_name; ty_param_attrs;_} -> ty_param_name -let (__proj__Mkty_param__item__ty_param_attrs : - ty_param -> mlexpr Prims.list) = - fun projectee -> - match projectee with - | { ty_param_name; ty_param_attrs;_} -> ty_param_attrs -type mlbranch = (mlpattern * mlexpr FStar_Pervasives_Native.option * mlexpr) -type mlletbinding = (mlletflavor * mllb Prims.list) -type mlattribute = mlexpr -type mltyscheme = (ty_param Prims.list * mlty) -type mltybody = - | MLTD_Abbrev of mlty - | MLTD_Record of (mlsymbol * mlty) Prims.list - | MLTD_DType of (mlsymbol * (mlsymbol * mlty) Prims.list) Prims.list -let (uu___is_MLTD_Abbrev : mltybody -> Prims.bool) = - fun projectee -> - match projectee with | MLTD_Abbrev _0 -> true | uu___ -> false -let (__proj__MLTD_Abbrev__item___0 : mltybody -> mlty) = - fun projectee -> match projectee with | MLTD_Abbrev _0 -> _0 -let (uu___is_MLTD_Record : mltybody -> Prims.bool) = - fun projectee -> - match projectee with | MLTD_Record _0 -> true | uu___ -> false -let (__proj__MLTD_Record__item___0 : - mltybody -> (mlsymbol * mlty) Prims.list) = - fun projectee -> match projectee with | MLTD_Record _0 -> _0 -let (uu___is_MLTD_DType : mltybody -> Prims.bool) = - fun projectee -> - match projectee with | MLTD_DType _0 -> true | uu___ -> false -let (__proj__MLTD_DType__item___0 : - mltybody -> (mlsymbol * (mlsymbol * mlty) Prims.list) Prims.list) = - fun projectee -> match projectee with | MLTD_DType _0 -> _0 -type one_mltydecl = - { - tydecl_assumed: Prims.bool ; - tydecl_name: mlsymbol ; - tydecl_ignored: mlsymbol FStar_Pervasives_Native.option ; - tydecl_parameters: ty_param Prims.list ; - tydecl_meta: metadata ; - tydecl_defn: mltybody FStar_Pervasives_Native.option } -let (__proj__Mkone_mltydecl__item__tydecl_assumed : - one_mltydecl -> Prims.bool) = - fun projectee -> - match projectee with - | { tydecl_assumed; tydecl_name; tydecl_ignored; tydecl_parameters; - tydecl_meta; tydecl_defn;_} -> tydecl_assumed -let (__proj__Mkone_mltydecl__item__tydecl_name : one_mltydecl -> mlsymbol) = - fun projectee -> - match projectee with - | { tydecl_assumed; tydecl_name; tydecl_ignored; tydecl_parameters; - tydecl_meta; tydecl_defn;_} -> tydecl_name -let (__proj__Mkone_mltydecl__item__tydecl_ignored : - one_mltydecl -> mlsymbol FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { tydecl_assumed; tydecl_name; tydecl_ignored; tydecl_parameters; - tydecl_meta; tydecl_defn;_} -> tydecl_ignored -let (__proj__Mkone_mltydecl__item__tydecl_parameters : - one_mltydecl -> ty_param Prims.list) = - fun projectee -> - match projectee with - | { tydecl_assumed; tydecl_name; tydecl_ignored; tydecl_parameters; - tydecl_meta; tydecl_defn;_} -> tydecl_parameters -let (__proj__Mkone_mltydecl__item__tydecl_meta : one_mltydecl -> metadata) = - fun projectee -> - match projectee with - | { tydecl_assumed; tydecl_name; tydecl_ignored; tydecl_parameters; - tydecl_meta; tydecl_defn;_} -> tydecl_meta -let (__proj__Mkone_mltydecl__item__tydecl_defn : - one_mltydecl -> mltybody FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { tydecl_assumed; tydecl_name; tydecl_ignored; tydecl_parameters; - tydecl_meta; tydecl_defn;_} -> tydecl_defn -type mltydecl = one_mltydecl Prims.list -type mlmodule1' = - | MLM_Ty of mltydecl - | MLM_Let of mlletbinding - | MLM_Exn of (mlsymbol * (mlsymbol * mlty) Prims.list) - | MLM_Top of mlexpr - | MLM_Loc of mlloc -let (uu___is_MLM_Ty : mlmodule1' -> Prims.bool) = - fun projectee -> match projectee with | MLM_Ty _0 -> true | uu___ -> false -let (__proj__MLM_Ty__item___0 : mlmodule1' -> mltydecl) = - fun projectee -> match projectee with | MLM_Ty _0 -> _0 -let (uu___is_MLM_Let : mlmodule1' -> Prims.bool) = - fun projectee -> match projectee with | MLM_Let _0 -> true | uu___ -> false -let (__proj__MLM_Let__item___0 : mlmodule1' -> mlletbinding) = - fun projectee -> match projectee with | MLM_Let _0 -> _0 -let (uu___is_MLM_Exn : mlmodule1' -> Prims.bool) = - fun projectee -> match projectee with | MLM_Exn _0 -> true | uu___ -> false -let (__proj__MLM_Exn__item___0 : - mlmodule1' -> (mlsymbol * (mlsymbol * mlty) Prims.list)) = - fun projectee -> match projectee with | MLM_Exn _0 -> _0 -let (uu___is_MLM_Top : mlmodule1' -> Prims.bool) = - fun projectee -> match projectee with | MLM_Top _0 -> true | uu___ -> false -let (__proj__MLM_Top__item___0 : mlmodule1' -> mlexpr) = - fun projectee -> match projectee with | MLM_Top _0 -> _0 -let (uu___is_MLM_Loc : mlmodule1' -> Prims.bool) = - fun projectee -> match projectee with | MLM_Loc _0 -> true | uu___ -> false -let (__proj__MLM_Loc__item___0 : mlmodule1' -> mlloc) = - fun projectee -> match projectee with | MLM_Loc _0 -> _0 -type mlmodule1 = - { - mlmodule1_m: mlmodule1' ; - mlmodule1_attrs: mlattribute Prims.list } -let (__proj__Mkmlmodule1__item__mlmodule1_m : mlmodule1 -> mlmodule1') = - fun projectee -> - match projectee with | { mlmodule1_m; mlmodule1_attrs;_} -> mlmodule1_m -let (__proj__Mkmlmodule1__item__mlmodule1_attrs : - mlmodule1 -> mlattribute Prims.list) = - fun projectee -> - match projectee with - | { mlmodule1_m; mlmodule1_attrs;_} -> mlmodule1_attrs -let (mk_mlmodule1 : mlmodule1' -> mlmodule1) = - fun m -> { mlmodule1_m = m; mlmodule1_attrs = [] } -let (mk_mlmodule1_with_attrs : - mlmodule1' -> mlattribute Prims.list -> mlmodule1) = - fun m -> fun attrs -> { mlmodule1_m = m; mlmodule1_attrs = attrs } -type mlmodule = mlmodule1 Prims.list -type mlsig1 = - | MLS_Mod of (mlsymbol * mlsig1 Prims.list) - | MLS_Ty of mltydecl - | MLS_Val of (mlsymbol * mltyscheme) - | MLS_Exn of (mlsymbol * mlty Prims.list) -let (uu___is_MLS_Mod : mlsig1 -> Prims.bool) = - fun projectee -> match projectee with | MLS_Mod _0 -> true | uu___ -> false -let (__proj__MLS_Mod__item___0 : mlsig1 -> (mlsymbol * mlsig1 Prims.list)) = - fun projectee -> match projectee with | MLS_Mod _0 -> _0 -let (uu___is_MLS_Ty : mlsig1 -> Prims.bool) = - fun projectee -> match projectee with | MLS_Ty _0 -> true | uu___ -> false -let (__proj__MLS_Ty__item___0 : mlsig1 -> mltydecl) = - fun projectee -> match projectee with | MLS_Ty _0 -> _0 -let (uu___is_MLS_Val : mlsig1 -> Prims.bool) = - fun projectee -> match projectee with | MLS_Val _0 -> true | uu___ -> false -let (__proj__MLS_Val__item___0 : mlsig1 -> (mlsymbol * mltyscheme)) = - fun projectee -> match projectee with | MLS_Val _0 -> _0 -let (uu___is_MLS_Exn : mlsig1 -> Prims.bool) = - fun projectee -> match projectee with | MLS_Exn _0 -> true | uu___ -> false -let (__proj__MLS_Exn__item___0 : mlsig1 -> (mlsymbol * mlty Prims.list)) = - fun projectee -> match projectee with | MLS_Exn _0 -> _0 -type mlsig = mlsig1 Prims.list -let (with_ty_loc : mlty -> mlexpr' -> mlloc -> mlexpr) = - fun t -> fun e -> fun l -> { expr = e; mlty = t; loc = l } -let (with_ty : mlty -> mlexpr' -> mlexpr) = - fun t -> fun e -> with_ty_loc t e dummy_loc -type mllib = - | MLLib of (mlpath * (mlsig * mlmodule) FStar_Pervasives_Native.option * - mllib) Prims.list -let (uu___is_MLLib : mllib -> Prims.bool) = fun projectee -> true -let (__proj__MLLib__item___0 : - mllib -> - (mlpath * (mlsig * mlmodule) FStar_Pervasives_Native.option * mllib) - Prims.list) - = fun projectee -> match projectee with | MLLib _0 -> _0 -let (ml_unit_ty : mlty) = MLTY_Erased -let (ml_bool_ty : mlty) = MLTY_Named ([], (["Prims"], "bool")) -let (ml_int_ty : mlty) = MLTY_Named ([], (["Prims"], "int")) -let (ml_string_ty : mlty) = MLTY_Named ([], (["Prims"], "string")) -let (ml_unit : mlexpr) = with_ty ml_unit_ty (MLE_Const MLC_Unit) -let (apply_obj_repr : mlexpr -> mlty -> mlexpr) = - fun x -> - fun t -> - let repr_name = - let uu___ = - let uu___1 = FStar_Options.codegen () in - uu___1 = (FStar_Pervasives_Native.Some FStar_Options.FSharp) in - if uu___ then MLE_Name ([], "box") else MLE_Name (["Obj"], "repr") in - let obj_repr = with_ty (MLTY_Fun (t, E_PURE, MLTY_Top)) repr_name in - with_ty_loc MLTY_Top (MLE_App (obj_repr, [x])) x.loc -let (ty_param_names : ty_param Prims.list -> Prims.string Prims.list) = - fun tys -> - FStar_Compiler_List.map - (fun uu___ -> - match uu___ with - | { ty_param_name; ty_param_attrs = uu___1;_} -> ty_param_name) tys -let (push_unit : e_tag -> mltyscheme -> mltyscheme) = - fun eff -> - fun ts -> - let uu___ = ts in - match uu___ with | (vs, ty) -> (vs, (MLTY_Fun (ml_unit_ty, eff, ty))) -let (pop_unit : mltyscheme -> (e_tag * mltyscheme)) = - fun ts -> - let uu___ = ts in - match uu___ with - | (vs, ty) -> - (match ty with - | MLTY_Fun (l, eff, t) -> - if l = ml_unit_ty - then (eff, (vs, t)) - else failwith "unexpected: pop_unit: domain was not unit" - | uu___1 -> failwith "unexpected: pop_unit: not a function type") -let (ctor' : - Prims.string -> FStar_Pprint.document Prims.list -> FStar_Pprint.document) - = - fun n -> - fun args -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Pprint.break_ Prims.int_one in - let uu___4 = - let uu___5 = FStar_Pprint.doc_of_string n in uu___5 :: args in - FStar_Pprint.flow uu___3 uu___4 in - FStar_Pprint.parens uu___2 in - FStar_Pprint.group uu___1 in - FStar_Pprint.nest (Prims.of_int (2)) uu___ -let (ctor : Prims.string -> FStar_Pprint.document -> FStar_Pprint.document) = - fun n -> - fun arg -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Pprint.doc_of_string n in - FStar_Pprint.op_Hat_Slash_Hat uu___3 arg in - FStar_Pprint.parens uu___2 in - FStar_Pprint.group uu___1 in - FStar_Pprint.nest (Prims.of_int (2)) uu___ -let rec (mlty_to_doc : mlty -> FStar_Pprint.document) = - fun t -> - match t with - | MLTY_Var v -> FStar_Pprint.doc_of_string v - | MLTY_Fun (t1, uu___, t2) -> - let uu___1 = - let uu___2 = mlty_to_doc t1 in - let uu___3 = - let uu___4 = FStar_Pprint.doc_of_string "->" in - let uu___5 = let uu___6 = mlty_to_doc t2 in [uu___6] in uu___4 :: - uu___5 in - uu___2 :: uu___3 in - ctor' "" uu___1 - | MLTY_Named (ts, p) -> - let uu___ = - let uu___1 = FStar_Compiler_List.map mlty_to_doc ts in - let uu___2 = - let uu___3 = - let uu___4 = string_of_mlpath p in - FStar_Pprint.doc_of_string uu___4 in - [uu___3] in - FStar_Compiler_List.op_At uu___1 uu___2 in - ctor' "" uu___ - | MLTY_Tuple ts -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Pprint.doc_of_string " *" in - let uu___3 = FStar_Pprint.break_ Prims.int_one in - FStar_Pprint.op_Hat_Hat uu___2 uu___3 in - FStar_Pprint.flow_map uu___1 mlty_to_doc ts in - ctor "" uu___ - | MLTY_Top -> FStar_Pprint.doc_of_string "MLTY_Top" - | MLTY_Erased -> FStar_Pprint.doc_of_string "MLTY_Erased" -let (mlty_to_string : mlty -> Prims.string) = - fun t -> let uu___ = mlty_to_doc t in FStar_Pprint.render uu___ -let (mltyscheme_to_doc : mltyscheme -> FStar_Pprint.document) = - fun tsc -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Pprint.break_ Prims.int_one in - FStar_Pprint.op_Hat_Hat FStar_Pprint.comma uu___4 in - let uu___4 = ty_param_names (FStar_Pervasives_Native.fst tsc) in - FStar_Pprint.flow_map uu___3 FStar_Pprint.doc_of_string uu___4 in - FStar_Pprint.brackets uu___2 in - let uu___2 = - let uu___3 = FStar_Pprint.doc_of_string "," in - let uu___4 = mlty_to_doc (FStar_Pervasives_Native.snd tsc) in - FStar_Pprint.op_Hat_Slash_Hat uu___3 uu___4 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - ctor "" uu___ -let (mltyscheme_to_string : mltyscheme -> Prims.string) = - fun tsc -> let uu___ = mltyscheme_to_doc tsc in FStar_Pprint.render uu___ -let (pair : - FStar_Pprint.document -> FStar_Pprint.document -> FStar_Pprint.document) = - fun a -> - fun b -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Pprint.op_Hat_Slash_Hat FStar_Pprint.comma b in - FStar_Pprint.op_Hat_Hat a uu___2 in - FStar_Pprint.parens uu___1 in - FStar_Pprint.group uu___ -let (triple : - FStar_Pprint.document -> - FStar_Pprint.document -> FStar_Pprint.document -> FStar_Pprint.document) - = - fun a -> - fun b -> - fun c -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Pprint.op_Hat_Slash_Hat FStar_Pprint.comma c in - FStar_Pprint.op_Hat_Hat b uu___4 in - FStar_Pprint.op_Hat_Slash_Hat FStar_Pprint.comma uu___3 in - FStar_Pprint.op_Hat_Hat a uu___2 in - FStar_Pprint.parens uu___1 in - FStar_Pprint.group uu___ -let (ctor2 : - Prims.string -> - FStar_Pprint.document -> FStar_Pprint.document -> FStar_Pprint.document) - = fun n -> fun a -> fun b -> let uu___ = pair a b in ctor n uu___ -let list_to_doc : - 't . - 't Prims.list -> ('t -> FStar_Pprint.document) -> FStar_Pprint.document - = - fun xs -> - fun f -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Pprint.break_ Prims.int_one in - FStar_Pprint.op_Hat_Hat FStar_Pprint.semi uu___4 in - FStar_Pprint.flow_map uu___3 f xs in - FStar_Pprint.brackets uu___2 in - FStar_Pprint.group uu___1 in - FStar_Pprint.nest (Prims.of_int (2)) uu___ -let option_to_doc : - 't . - 't FStar_Pervasives_Native.option -> - ('t -> FStar_Pprint.document) -> FStar_Pprint.document - = - fun x -> - fun f -> - match x with - | FStar_Pervasives_Native.Some x1 -> - let uu___ = - let uu___1 = FStar_Pprint.doc_of_string "Some" in - let uu___2 = f x1 in FStar_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | FStar_Pervasives_Native.None -> FStar_Pprint.doc_of_string "None" -let (spaced : FStar_Pprint.document -> FStar_Pprint.document) = - fun a -> - let uu___ = FStar_Pprint.break_ Prims.int_one in - let uu___1 = - let uu___2 = FStar_Pprint.break_ Prims.int_one in - FStar_Pprint.op_Hat_Hat a uu___2 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 -let (record : FStar_Pprint.document Prims.list -> FStar_Pprint.document) = - fun fs -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Pprint.break_ Prims.int_one in - FStar_Pprint.op_Hat_Hat FStar_Pprint.semi uu___5 in - FStar_Pprint.separate uu___4 fs in - spaced uu___3 in - FStar_Pprint.braces uu___2 in - FStar_Pprint.nest (Prims.of_int (2)) uu___1 in - FStar_Pprint.group uu___ -let (fld : Prims.string -> FStar_Pprint.document -> FStar_Pprint.document) = - fun n -> - fun v -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Pprint.doc_of_string (Prims.strcat n " =") in - FStar_Pprint.op_Hat_Slash_Hat uu___2 v in - FStar_Pprint.nest (Prims.of_int (2)) uu___1 in - FStar_Pprint.group uu___ -let rec (mlexpr_to_doc : mlexpr -> FStar_Pprint.document) = - fun e -> - match e.expr with - | MLE_Const c -> - let uu___ = mlconstant_to_doc c in ctor "MLE_Const" uu___ - | MLE_Var x -> - let uu___ = FStar_Pprint.doc_of_string x in ctor "MLE_Var" uu___ - | MLE_Name (p, x) -> - let uu___ = - FStar_Pprint.doc_of_string (FStar_Compiler_String.concat "." p) in - let uu___1 = FStar_Pprint.doc_of_string x in - ctor2 "MLE_Name" uu___ uu___1 - | MLE_Let (lbs, e1) -> - let uu___ = mlletbinding_to_doc lbs in - let uu___1 = mlexpr_to_doc e1 in ctor2 "MLE_Let" uu___ uu___1 - | MLE_App (e1, es) -> - let uu___ = mlexpr_to_doc e1 in - let uu___1 = list_to_doc es mlexpr_to_doc in - ctor2 "MLE_App" uu___ uu___1 - | MLE_TApp (e1, ts) -> - let uu___ = mlexpr_to_doc e1 in - let uu___1 = list_to_doc ts mlty_to_doc in - ctor2 "MLE_TApp" uu___ uu___1 - | MLE_Fun (bs, e1) -> - let uu___ = - list_to_doc bs - (fun b -> - let uu___1 = FStar_Pprint.doc_of_string b.mlbinder_name in - let uu___2 = mlty_to_doc b.mlbinder_ty in pair uu___1 uu___2) in - let uu___1 = mlexpr_to_doc e1 in ctor2 "MLE_Fun" uu___ uu___1 - | MLE_Match (e1, bs) -> - let uu___ = mlexpr_to_doc e1 in - let uu___1 = list_to_doc bs mlbranch_to_doc in - ctor2 "MLE_Match" uu___ uu___1 - | MLE_Coerce (e1, t1, t2) -> - let uu___ = - let uu___1 = mlexpr_to_doc e1 in - let uu___2 = mlty_to_doc t1 in - let uu___3 = mlty_to_doc t2 in triple uu___1 uu___2 uu___3 in - ctor "MLE_Coerce" uu___ - | MLE_CTor (p, es) -> - let uu___ = - let uu___1 = string_of_mlpath p in - FStar_Pprint.doc_of_string uu___1 in - let uu___1 = list_to_doc es mlexpr_to_doc in - ctor2 "MLE_CTor" uu___ uu___1 - | MLE_Seq es -> - let uu___ = list_to_doc es mlexpr_to_doc in ctor "MLE_Seq" uu___ - | MLE_Tuple es -> - let uu___ = list_to_doc es mlexpr_to_doc in ctor "MLE_Tuple" uu___ - | MLE_Record (p, n, es) -> - let uu___ = - list_to_doc (FStar_Compiler_List.op_At p [n]) - FStar_Pprint.doc_of_string in - let uu___1 = - list_to_doc es - (fun uu___2 -> - match uu___2 with - | (x, e1) -> - let uu___3 = FStar_Pprint.doc_of_string x in - let uu___4 = mlexpr_to_doc e1 in pair uu___3 uu___4) in - ctor2 "MLE_Record" uu___ uu___1 - | MLE_Proj (e1, p) -> - let uu___ = mlexpr_to_doc e1 in - let uu___1 = - let uu___2 = string_of_mlpath p in - FStar_Pprint.doc_of_string uu___2 in - ctor2 "MLE_Proj" uu___ uu___1 - | MLE_If (e1, e2, e3) -> - let uu___ = - let uu___1 = mlexpr_to_doc e1 in - let uu___2 = mlexpr_to_doc e2 in - let uu___3 = option_to_doc e3 mlexpr_to_doc in - triple uu___1 uu___2 uu___3 in - ctor "MLE_If" uu___ - | MLE_Raise (p, es) -> - let uu___ = - let uu___1 = string_of_mlpath p in - FStar_Pprint.doc_of_string uu___1 in - let uu___1 = list_to_doc es mlexpr_to_doc in - ctor2 "MLE_Raise" uu___ uu___1 - | MLE_Try (e1, bs) -> - let uu___ = mlexpr_to_doc e1 in - let uu___1 = list_to_doc bs mlbranch_to_doc in - ctor2 "MLE_Try" uu___ uu___1 -and (mlbranch_to_doc : - (mlpattern * mlexpr FStar_Pervasives_Native.option * mlexpr) -> - FStar_Pprint.document) - = - fun uu___ -> - match uu___ with - | (p, e1, e2) -> - let uu___1 = mlpattern_to_doc p in - let uu___2 = option_to_doc e1 mlexpr_to_doc in - let uu___3 = mlexpr_to_doc e2 in triple uu___1 uu___2 uu___3 -and (mlletbinding_to_doc : - (mlletflavor * mllb Prims.list) -> FStar_Pprint.document) = - fun lbs -> - let uu___ = - let uu___1 = - FStar_Pprint.doc_of_string - (match FStar_Pervasives_Native.__proj__Mktuple2__item___1 lbs with - | Rec -> "Rec" - | NonRec -> "NonRec") in - let uu___2 = - let uu___3 = FStar_Pprint.doc_of_string ", " in - let uu___4 = - list_to_doc - (FStar_Pervasives_Native.__proj__Mktuple2__item___2 lbs) - mllb_to_doc in - FStar_Pprint.op_Hat_Hat uu___3 uu___4 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - FStar_Pprint.parens uu___ -and (mllb_to_doc : mllb -> FStar_Pprint.document) = - fun lb -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Pprint.doc_of_string lb.mllb_name in - fld "mllb_name" uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = list_to_doc lb.mllb_attrs mlexpr_to_doc in - fld "mllb_attrs" uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - option_to_doc lb.mllb_tysc - (fun uu___7 -> - match uu___7 with | (uu___8, t) -> mlty_to_doc t) in - fld "mllb_tysc" uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Compiler_Util.string_of_bool lb.mllb_add_unit in - FStar_Pprint.doc_of_string uu___9 in - fld "mllb_add_unit" uu___8 in - let uu___8 = - let uu___9 = - let uu___10 = mlexpr_to_doc lb.mllb_def in - fld "mllb_def" uu___10 in - [uu___9] in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - record uu___ -and (mlconstant_to_doc : mlconstant -> FStar_Pprint.document) = - fun mlc -> - match mlc with - | MLC_Unit -> FStar_Pprint.doc_of_string "MLC_Unit" - | MLC_Bool b -> - let uu___ = - let uu___1 = FStar_Compiler_Util.string_of_bool b in - FStar_Pprint.doc_of_string uu___1 in - ctor "MLC_Bool" uu___ - | MLC_Int (s, FStar_Pervasives_Native.None) -> - let uu___ = FStar_Pprint.doc_of_string s in ctor "MLC_Int" uu___ - | MLC_Int (s, FStar_Pervasives_Native.Some (s1, s2)) -> - let uu___ = - let uu___1 = FStar_Pprint.doc_of_string s in - triple uu___1 FStar_Pprint.underscore FStar_Pprint.underscore in - ctor "MLC_Int" uu___ - | MLC_Float f -> ctor "MLC_Float" FStar_Pprint.underscore - | MLC_Char c -> ctor "MLC_Char" FStar_Pprint.underscore - | MLC_String s -> - let uu___ = FStar_Pprint.doc_of_string s in ctor "MLC_String" uu___ - | MLC_Bytes b -> ctor "MLC_Bytes" FStar_Pprint.underscore -and (mlpattern_to_doc : mlpattern -> FStar_Pprint.document) = - fun mlp -> - match mlp with - | MLP_Wild -> FStar_Pprint.doc_of_string "MLP_Wild" - | MLP_Const c -> - let uu___ = mlconstant_to_doc c in ctor "MLP_Const" uu___ - | MLP_Var x -> - let uu___ = FStar_Pprint.doc_of_string x in ctor "MLP_Var" uu___ - | MLP_CTor (p, ps) -> - let uu___ = - let uu___1 = string_of_mlpath p in - FStar_Pprint.doc_of_string uu___1 in - let uu___1 = list_to_doc ps mlpattern_to_doc in - ctor2 "MLP_CTor" uu___ uu___1 - | MLP_Branch ps -> - let uu___ = list_to_doc ps mlpattern_to_doc in - ctor "MLP_Branch" uu___ - | MLP_Record (path, fields) -> - let uu___ = - FStar_Pprint.doc_of_string (FStar_Compiler_String.concat "." path) in - let uu___1 = - list_to_doc fields - (fun uu___2 -> - match uu___2 with - | (x, p) -> - let uu___3 = FStar_Pprint.doc_of_string x in - let uu___4 = mlpattern_to_doc p in pair uu___3 uu___4) in - ctor2 "MLP_Record" uu___ uu___1 - | MLP_Tuple ps -> - let uu___ = list_to_doc ps mlpattern_to_doc in ctor "MLP_Tuple" uu___ -let (mlbranch_to_string : mlbranch -> Prims.string) = - fun b -> let uu___ = mlbranch_to_doc b in FStar_Pprint.render uu___ -let (mlletbinding_to_string : mlletbinding -> Prims.string) = - fun lb -> let uu___ = mlletbinding_to_doc lb in FStar_Pprint.render uu___ -let (mllb_to_string : mllb -> Prims.string) = - fun lb -> let uu___ = mllb_to_doc lb in FStar_Pprint.render uu___ -let (mlpattern_to_string : mlpattern -> Prims.string) = - fun p -> let uu___ = mlpattern_to_doc p in FStar_Pprint.render uu___ -let (mlconstant_to_string : mlconstant -> Prims.string) = - fun c -> let uu___ = mlconstant_to_doc c in FStar_Pprint.render uu___ -let (mlexpr_to_string : mlexpr -> Prims.string) = - fun e -> let uu___ = mlexpr_to_doc e in FStar_Pprint.render uu___ -let (mltybody_to_doc : mltybody -> FStar_Pprint.document) = - fun d -> - match d with - | MLTD_Abbrev mlty1 -> - let uu___ = mlty_to_doc mlty1 in ctor "MLTD_Abbrev" uu___ - | MLTD_Record l -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = FStar_Pprint.break_ Prims.int_one in - FStar_Pprint.op_Hat_Hat FStar_Pprint.semi uu___6 in - FStar_Pprint.flow_map uu___5 - (fun uu___6 -> - match uu___6 with - | (x, t) -> - let uu___7 = FStar_Pprint.doc_of_string x in - let uu___8 = mlty_to_doc t in pair uu___7 uu___8) - l in - spaced uu___4 in - FStar_Pprint.braces uu___3 in - FStar_Pprint.nest (Prims.of_int (2)) uu___2 in - FStar_Pprint.group uu___1 in - ctor "MLTD_Record" uu___ - | MLTD_DType l -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = FStar_Pprint.break_ Prims.int_one in - FStar_Pprint.op_Hat_Hat FStar_Pprint.semi uu___6 in - FStar_Pprint.flow_map uu___5 - (fun uu___6 -> - match uu___6 with - | (x, l1) -> - let uu___7 = FStar_Pprint.doc_of_string x in - let uu___8 = - list_to_doc l1 - (fun uu___9 -> - match uu___9 with - | (x1, t) -> - let uu___10 = - FStar_Pprint.doc_of_string x1 in - let uu___11 = mlty_to_doc t in - pair uu___10 uu___11) in - pair uu___7 uu___8) l in - spaced uu___4 in - FStar_Pprint.brackets uu___3 in - FStar_Pprint.nest (Prims.of_int (2)) uu___2 in - FStar_Pprint.group uu___1 in - ctor "MLTD_DType" uu___ -let (mltybody_to_string : mltybody -> Prims.string) = - fun d -> let uu___ = mltybody_to_doc d in FStar_Pprint.render uu___ -let (one_mltydecl_to_doc : one_mltydecl -> FStar_Pprint.document) = - fun d -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Pprint.doc_of_string d.tydecl_name in - fld "tydecl_name" uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = ty_param_names d.tydecl_parameters in - FStar_Compiler_String.concat "," uu___6 in - FStar_Pprint.doc_of_string uu___5 in - fld "tydecl_parameters" uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = option_to_doc d.tydecl_defn mltybody_to_doc in - fld "tydecl_defn" uu___6 in - [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - record uu___ -let (one_mltydecl_to_string : one_mltydecl -> Prims.string) = - fun d -> let uu___ = one_mltydecl_to_doc d in FStar_Pprint.render uu___ -let (mlmodule1_to_doc : mlmodule1 -> FStar_Pprint.document) = - fun m -> - let uu___ = - match m.mlmodule1_m with - | MLM_Ty d -> - let uu___1 = FStar_Pprint.doc_of_string "MLM_Ty " in - let uu___2 = list_to_doc d one_mltydecl_to_doc in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 - | MLM_Let l -> - let uu___1 = FStar_Pprint.doc_of_string "MLM_Let " in - let uu___2 = mlletbinding_to_doc l in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 - | MLM_Exn (s, l) -> - let uu___1 = FStar_Pprint.doc_of_string "MLM_Exn" in - let uu___2 = - let uu___3 = FStar_Pprint.doc_of_string s in - let uu___4 = - list_to_doc l - (fun uu___5 -> - match uu___5 with - | (x, t) -> - let uu___6 = FStar_Pprint.doc_of_string x in - let uu___7 = mlty_to_doc t in pair uu___6 uu___7) in - pair uu___3 uu___4 in - FStar_Pprint.op_Hat_Slash_Hat uu___1 uu___2 - | MLM_Top e -> - let uu___1 = FStar_Pprint.doc_of_string "MLM_Top" in - let uu___2 = mlexpr_to_doc e in - FStar_Pprint.op_Hat_Slash_Hat uu___1 uu___2 - | MLM_Loc _mlloc -> FStar_Pprint.doc_of_string "MLM_Loc" in - FStar_Pprint.group uu___ -let (mlmodule1_to_string : mlmodule1 -> Prims.string) = - fun m -> let uu___ = mlmodule1_to_doc m in FStar_Pprint.render uu___ -let (mlmodule_to_doc : mlmodule -> FStar_Pprint.document) = - fun m -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Pprint.break_ Prims.int_one in - FStar_Pprint.op_Hat_Hat FStar_Pprint.semi uu___4 in - FStar_Pprint.separate_map uu___3 mlmodule1_to_doc m in - spaced uu___2 in - FStar_Pprint.brackets uu___1 in - FStar_Pprint.group uu___ -let (mlmodule_to_string : mlmodule -> Prims.string) = - fun m -> let uu___ = mlmodule_to_doc m in FStar_Pprint.render uu___ -let (showable_mlty : mlty FStar_Class_Show.showable) = - { FStar_Class_Show.show = mlty_to_string } -let (showable_mlconstant : mlconstant FStar_Class_Show.showable) = - { FStar_Class_Show.show = mlconstant_to_string } -let (showable_mlexpr : mlexpr FStar_Class_Show.showable) = - { FStar_Class_Show.show = mlexpr_to_string } -let (showable_mlmodule1 : mlmodule1 FStar_Class_Show.showable) = - { FStar_Class_Show.show = mlmodule1_to_string } -let (showable_mlmodule : mlmodule FStar_Class_Show.showable) = - { FStar_Class_Show.show = mlmodule_to_string } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Extraction_ML_Term.ml b/ocaml/fstar-lib/generated/FStar_Extraction_ML_Term.ml deleted file mode 100644 index 9897db482d2..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Extraction_ML_Term.ml +++ /dev/null @@ -1,4636 +0,0 @@ -open Prims -let (dbg_Extraction : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Extraction" -let (dbg_ExtractionNorm : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "ExtractionNorm" -exception Un_extractable -let (uu___is_Un_extractable : Prims.exn -> Prims.bool) = - fun projectee -> - match projectee with | Un_extractable -> true | uu___ -> false -let (type_leq : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Extraction_ML_Syntax.mlty -> - FStar_Extraction_ML_Syntax.mlty -> Prims.bool) - = - fun g -> - fun t1 -> - fun t2 -> - FStar_Extraction_ML_Util.type_leq - (FStar_Extraction_ML_Util.udelta_unfold g) t1 t2 -let (type_leq_c : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Extraction_ML_Syntax.mlexpr FStar_Pervasives_Native.option -> - FStar_Extraction_ML_Syntax.mlty -> - FStar_Extraction_ML_Syntax.mlty -> - (Prims.bool * FStar_Extraction_ML_Syntax.mlexpr - FStar_Pervasives_Native.option)) - = - fun g -> - fun t1 -> - fun t2 -> - FStar_Extraction_ML_Util.type_leq_c - (FStar_Extraction_ML_Util.udelta_unfold g) t1 t2 -let (eraseTypeDeep : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Extraction_ML_Syntax.mlty -> FStar_Extraction_ML_Syntax.mlty) - = - fun g -> - fun t -> - FStar_Extraction_ML_Util.eraseTypeDeep - (FStar_Extraction_ML_Util.udelta_unfold g) t -let err_ill_typed_application : - 'uuuuu . - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.term -> - FStar_Extraction_ML_Syntax.mlexpr -> - FStar_Syntax_Syntax.args -> - FStar_Extraction_ML_Syntax.mlty -> 'uuuuu - = - fun env -> - fun t -> - fun mlhead -> - fun args -> - fun ty -> - let uu___ = - let uu___1 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - let uu___2 = - let uu___3 = - FStar_Extraction_ML_UEnv.current_module_of_uenv env in - FStar_Extraction_ML_Code.string_of_mlexpr uu___3 mlhead in - let uu___3 = - let uu___4 = - FStar_Extraction_ML_UEnv.current_module_of_uenv env in - FStar_Extraction_ML_Code.string_of_mlty uu___4 ty in - let uu___4 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - (FStar_Class_Show.show_tuple2 - FStar_Syntax_Print.showable_term - FStar_Syntax_Print.showable_aqual)) args in - FStar_Compiler_Util.format4 - "Ill-typed application: source application is %s \n translated prefix to %s at type %s\n remaining args are %s\n" - uu___1 uu___2 uu___3 uu___4 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) t - FStar_Errors_Codes.Fatal_IllTyped () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___) -let err_ill_typed_erasure : - 'uuuuu . - FStar_Extraction_ML_UEnv.uenv -> - FStar_Compiler_Range_Type.range -> - FStar_Extraction_ML_Syntax.mlty -> 'uuuuu - = - fun env -> - fun pos -> - fun ty -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Extraction_ML_UEnv.current_module_of_uenv env in - FStar_Extraction_ML_Code.string_of_mlty uu___2 ty in - FStar_Compiler_Util.format1 - "Erased value found where a value of type %s was expected" uu___1 in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range pos - FStar_Errors_Codes.Fatal_IllTyped () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___) -let err_value_restriction : 'uuuuu . FStar_Syntax_Syntax.term -> 'uuuuu = - fun t -> - let uu___ = - let uu___1 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t in - let uu___2 = FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.format2 - "Refusing to generalize because of the value restriction: (%s) %s" - uu___1 uu___2 in - FStar_Errors.raise_error (FStar_Syntax_Syntax.has_range_syntax ()) t - FStar_Errors_Codes.Fatal_ValueRestriction () - (Obj.magic FStar_Errors_Msg.is_error_message_string) (Obj.magic uu___) -let (err_unexpected_eff : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.term -> - FStar_Extraction_ML_Syntax.mlty -> - FStar_Extraction_ML_Syntax.e_tag -> - FStar_Extraction_ML_Syntax.e_tag -> unit) - = - fun env -> - fun t -> - fun ty -> - fun f0 -> - fun f1 -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Errors_Msg.text "For expression" in - let uu___4 = - FStar_Class_PP.pp FStar_Syntax_Print.pretty_term t in - FStar_Pprint.prefix (Prims.of_int (4)) Prims.int_one uu___3 - uu___4 in - let uu___3 = - let uu___4 = FStar_Errors_Msg.text "of type" in - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Extraction_ML_UEnv.current_module_of_uenv env in - FStar_Extraction_ML_Code.string_of_mlty uu___7 ty in - FStar_Pprint.arbitrary_string uu___6 in - FStar_Pprint.prefix (Prims.of_int (4)) Prims.int_one uu___4 - uu___5 in - FStar_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Errors_Msg.text "Expected effect" in - let uu___6 = - let uu___7 = FStar_Extraction_ML_Util.eff_to_string f0 in - FStar_Pprint.arbitrary_string uu___7 in - FStar_Pprint.prefix (Prims.of_int (4)) Prims.int_one - uu___5 uu___6 in - let uu___5 = - let uu___6 = FStar_Errors_Msg.text "got effect" in - let uu___7 = - let uu___8 = FStar_Extraction_ML_Util.eff_to_string f1 in - FStar_Pprint.arbitrary_string uu___8 in - FStar_Pprint.prefix (Prims.of_int (4)) Prims.int_one - uu___6 uu___7 in - FStar_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in - [uu___3] in - uu___1 :: uu___2 in - FStar_Errors.log_issue (FStar_Syntax_Syntax.has_range_syntax ()) - t FStar_Errors_Codes.Warning_ExtractionUnexpectedEffect () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___) -let err_cannot_extract_effect : - 'uuuuu . - FStar_Ident.lident -> - FStar_Compiler_Range_Type.range -> - Prims.string -> Prims.string -> 'uuuuu - = - fun l -> - fun r -> - fun reason -> - fun ctxt -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Ident.string_of_lid l in - FStar_Compiler_Util.format3 - "Cannot extract effect %s because %s (when extracting %s)" - uu___3 reason ctxt in - FStar_Errors_Msg.text uu___2 in - [uu___1] in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_UnexpectedEffect () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___) -let (effect_as_etag : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Ident.lident -> FStar_Extraction_ML_Syntax.e_tag) - = - let cache = FStar_Compiler_Util.smap_create (Prims.of_int (20)) in - let rec delta_norm_eff g l = - let uu___ = - let uu___1 = FStar_Ident.string_of_lid l in - FStar_Compiler_Util.smap_try_find cache uu___1 in - match uu___ with - | FStar_Pervasives_Native.Some l1 -> l1 - | FStar_Pervasives_Native.None -> - let res = - let uu___1 = - let uu___2 = FStar_Extraction_ML_UEnv.tcenv_of_uenv g in - FStar_TypeChecker_Env.lookup_effect_abbrev uu___2 - [FStar_Syntax_Syntax.U_zero] l in - match uu___1 with - | FStar_Pervasives_Native.None -> l - | FStar_Pervasives_Native.Some (uu___2, c) -> - delta_norm_eff g (FStar_Syntax_Util.comp_effect_name c) in - ((let uu___2 = FStar_Ident.string_of_lid l in - FStar_Compiler_Util.smap_add cache uu___2 res); - res) in - fun g -> - fun l -> - let l1 = delta_norm_eff g l in - let uu___ = - FStar_Ident.lid_equals l1 FStar_Parser_Const.effect_PURE_lid in - if uu___ - then FStar_Extraction_ML_Syntax.E_PURE - else - (let uu___2 = - let uu___3 = FStar_Extraction_ML_UEnv.tcenv_of_uenv g in - FStar_TypeChecker_Env.is_erasable_effect uu___3 l1 in - if uu___2 - then FStar_Extraction_ML_Syntax.E_ERASABLE - else - (let ed_opt = - let uu___4 = FStar_Extraction_ML_UEnv.tcenv_of_uenv g in - FStar_TypeChecker_Env.effect_decl_opt uu___4 l1 in - match ed_opt with - | FStar_Pervasives_Native.Some (ed, qualifiers) -> - let uu___4 = - let uu___5 = FStar_Extraction_ML_UEnv.tcenv_of_uenv g in - FStar_TypeChecker_Env.is_reifiable_effect uu___5 - ed.FStar_Syntax_Syntax.mname in - if uu___4 - then FStar_Extraction_ML_Syntax.E_PURE - else FStar_Extraction_ML_Syntax.E_IMPURE - | FStar_Pervasives_Native.None -> - FStar_Extraction_ML_Syntax.E_IMPURE)) -let rec (is_arity_aux : - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.term -> Prims.bool) = - fun tcenv -> - fun t -> - let t1 = FStar_Syntax_Util.unmeta t in - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t1 in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_unknown -> - let uu___1 = - let uu___2 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t1 in - FStar_Compiler_Util.format1 "Impossible: is_arity (%s)" uu___2 in - failwith uu___1 - | FStar_Syntax_Syntax.Tm_delayed uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t1 in - FStar_Compiler_Util.format1 "Impossible: is_arity (%s)" uu___3 in - failwith uu___2 - | FStar_Syntax_Syntax.Tm_ascribed uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t1 in - FStar_Compiler_Util.format1 "Impossible: is_arity (%s)" uu___3 in - failwith uu___2 - | FStar_Syntax_Syntax.Tm_meta uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t1 in - FStar_Compiler_Util.format1 "Impossible: is_arity (%s)" uu___3 in - failwith uu___2 - | FStar_Syntax_Syntax.Tm_lazy i -> - let uu___1 = FStar_Syntax_Util.unfold_lazy i in - is_arity_aux tcenv uu___1 - | FStar_Syntax_Syntax.Tm_uvar uu___1 -> false - | FStar_Syntax_Syntax.Tm_constant uu___1 -> false - | FStar_Syntax_Syntax.Tm_name uu___1 -> false - | FStar_Syntax_Syntax.Tm_quoted uu___1 -> false - | FStar_Syntax_Syntax.Tm_bvar uu___1 -> false - | FStar_Syntax_Syntax.Tm_type uu___1 -> true - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = uu___1; FStar_Syntax_Syntax.comp = c;_} - -> is_arity_aux tcenv (FStar_Syntax_Util.comp_result c) - | FStar_Syntax_Syntax.Tm_fvar fv -> - let topt = - FStar_TypeChecker_Env.lookup_definition - [FStar_TypeChecker_Env.Unfold - FStar_Syntax_Syntax.delta_constant] tcenv - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - (match topt with - | FStar_Pervasives_Native.None -> false - | FStar_Pervasives_Native.Some (uu___1, t2) -> - is_arity_aux tcenv t2) - | FStar_Syntax_Syntax.Tm_app uu___1 -> - let uu___2 = FStar_Syntax_Util.head_and_args t1 in - (match uu___2 with | (head, uu___3) -> is_arity_aux tcenv head) - | FStar_Syntax_Syntax.Tm_uinst (head, uu___1) -> - is_arity_aux tcenv head - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x; FStar_Syntax_Syntax.phi = uu___1;_} -> - is_arity_aux tcenv x.FStar_Syntax_Syntax.sort - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = uu___1; FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = uu___2;_} - -> is_arity_aux tcenv body - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = uu___1; - FStar_Syntax_Syntax.body1 = body;_} - -> is_arity_aux tcenv body - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = uu___1; - FStar_Syntax_Syntax.ret_opt = uu___2; - FStar_Syntax_Syntax.brs = branches; - FStar_Syntax_Syntax.rc_opt1 = uu___3;_} - -> - (match branches with - | (uu___4, uu___5, e)::uu___6 -> is_arity_aux tcenv e - | uu___4 -> false) -let (is_arity : - FStar_Extraction_ML_UEnv.uenv -> FStar_Syntax_Syntax.term -> Prims.bool) = - fun env -> - fun t -> - let uu___ = FStar_Extraction_ML_UEnv.tcenv_of_uenv env in - is_arity_aux uu___ t -let (push_tcenv_binders : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.binders -> FStar_Extraction_ML_UEnv.uenv) - = - fun u -> - fun bs -> - let tcenv = FStar_Extraction_ML_UEnv.tcenv_of_uenv u in - let tcenv1 = FStar_TypeChecker_Env.push_binders tcenv bs in - FStar_Extraction_ML_UEnv.set_tcenv u tcenv1 -let rec (is_type_aux : - FStar_Extraction_ML_UEnv.uenv -> FStar_Syntax_Syntax.term -> Prims.bool) = - fun env -> - fun t -> - let t1 = FStar_Syntax_Subst.compress t in - match t1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_delayed uu___ -> - let uu___1 = - let uu___2 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t1 in - FStar_Compiler_Util.format1 "Impossible: %s" uu___2 in - failwith uu___1 - | FStar_Syntax_Syntax.Tm_unknown -> - let uu___ = - let uu___1 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t1 in - FStar_Compiler_Util.format1 "Impossible: %s" uu___1 in - failwith uu___ - | FStar_Syntax_Syntax.Tm_lazy i -> - let uu___ = FStar_Syntax_Util.unfold_lazy i in - is_type_aux env uu___ - | FStar_Syntax_Syntax.Tm_constant uu___ -> false - | FStar_Syntax_Syntax.Tm_type uu___ -> true - | FStar_Syntax_Syntax.Tm_refine uu___ -> true - | FStar_Syntax_Syntax.Tm_arrow uu___ -> true - | FStar_Syntax_Syntax.Tm_fvar fv when - let uu___ = FStar_Parser_Const.failwith_lid () in - FStar_Syntax_Syntax.fv_eq_lid fv uu___ -> false - | FStar_Syntax_Syntax.Tm_fvar fv -> - FStar_Extraction_ML_UEnv.is_type_name env fv - | FStar_Syntax_Syntax.Tm_uvar (u, s) -> - let t2 = FStar_Syntax_Util.ctx_uvar_typ u in - let uu___ = FStar_Syntax_Subst.subst' s t2 in is_arity env uu___ - | FStar_Syntax_Syntax.Tm_bvar - { FStar_Syntax_Syntax.ppname = uu___; - FStar_Syntax_Syntax.index = uu___1; - FStar_Syntax_Syntax.sort = t2;_} - -> is_arity env t2 - | FStar_Syntax_Syntax.Tm_name x -> - let g = FStar_Extraction_ML_UEnv.tcenv_of_uenv env in - let uu___ = FStar_TypeChecker_Env.try_lookup_bv g x in - (match uu___ with - | FStar_Pervasives_Native.Some (t2, uu___1) -> is_arity env t2 - | uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term - t1 in - FStar_Compiler_Util.format1 - "Extraction: variable not found: %s" uu___3 in - failwith uu___2) - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t2; FStar_Syntax_Syntax.asc = uu___; - FStar_Syntax_Syntax.eff_opt = uu___1;_} - -> is_type_aux env t2 - | FStar_Syntax_Syntax.Tm_uinst (t2, uu___) -> is_type_aux env t2 - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs; FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = uu___;_} - -> - let uu___1 = FStar_Syntax_Subst.open_term bs body in - (match uu___1 with - | (bs1, body1) -> - let env1 = push_tcenv_binders env bs1 in - is_type_aux env1 body1) - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (false, lb::[]); - FStar_Syntax_Syntax.body1 = body;_} - -> - let x = FStar_Compiler_Util.left lb.FStar_Syntax_Syntax.lbname in - let uu___ = - let uu___1 = - let uu___2 = FStar_Syntax_Syntax.mk_binder x in [uu___2] in - FStar_Syntax_Subst.open_term uu___1 body in - (match uu___ with - | (bs, body1) -> - let env1 = push_tcenv_binders env bs in is_type_aux env1 body1) - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (uu___, lbs); - FStar_Syntax_Syntax.body1 = body;_} - -> - let uu___1 = FStar_Syntax_Subst.open_let_rec lbs body in - (match uu___1 with - | (lbs1, body1) -> - let env1 = - let uu___2 = - FStar_Compiler_List.map - (fun lb -> - let uu___3 = - FStar_Compiler_Util.left - lb.FStar_Syntax_Syntax.lbname in - FStar_Syntax_Syntax.mk_binder uu___3) lbs1 in - push_tcenv_binders env uu___2 in - is_type_aux env1 body1) - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = uu___; - FStar_Syntax_Syntax.ret_opt = uu___1; - FStar_Syntax_Syntax.brs = branches; - FStar_Syntax_Syntax.rc_opt1 = uu___2;_} - -> - (match branches with - | b::uu___3 -> - let uu___4 = FStar_Syntax_Subst.open_branch b in - (match uu___4 with - | (pat, uu___5, e) -> - let uu___6 = - let uu___7 = FStar_Extraction_ML_UEnv.tcenv_of_uenv env in - FStar_TypeChecker_PatternUtils.raw_pat_as_exp uu___7 - pat in - (match uu___6 with - | FStar_Pervasives_Native.None -> false - | FStar_Pervasives_Native.Some (uu___7, bvs) -> - let binders = - FStar_Compiler_List.map - (fun bv -> FStar_Syntax_Syntax.mk_binder bv) bvs in - let env1 = push_tcenv_binders env binders in - is_type_aux env1 e)) - | uu___3 -> false) - | FStar_Syntax_Syntax.Tm_quoted uu___ -> false - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t2; FStar_Syntax_Syntax.meta = uu___;_} - -> is_type_aux env t2 - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = uu___;_} - -> is_type_aux env head -let (is_type : - FStar_Extraction_ML_UEnv.uenv -> FStar_Syntax_Syntax.term -> Prims.bool) = - fun env -> - fun t -> - FStar_Extraction_ML_UEnv.debug env - (fun uu___1 -> - let uu___2 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.print2 "checking is_type (%s) %s\n" uu___2 - uu___3); - (let b = is_type_aux env t in - FStar_Extraction_ML_UEnv.debug env - (fun uu___2 -> - if b - then - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - let uu___4 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t in - FStar_Compiler_Util.print2 "yes, is_type %s (%s)\n" uu___3 - uu___4 - else - (let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - let uu___5 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t in - FStar_Compiler_Util.print2 "not a type %s (%s)\n" uu___4 - uu___5)); - b) -let (is_steel_with_invariant_g : FStar_Syntax_Syntax.term -> Prims.bool) = - fun t -> - let uu___ = FStar_Syntax_Util.head_and_args t in - match uu___ with - | (head, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst head in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, - _a::_fp::_fp'::_o::_p::_i::_body::[]) -> - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.steel_with_invariant_g_lid) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.steel_st_with_invariant_g_lid) - | uu___2 -> false) -let (is_steel_with_invariant : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = - fun t -> - let uu___ = FStar_Syntax_Util.head_and_args t in - match uu___ with - | (head, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst head in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, - _a::_fp::_fp'::_o::_obs::_p::_i::body::[]) when - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.steel_with_invariant_lid) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.steel_st_with_invariant_lid) - -> - FStar_Pervasives_Native.Some (FStar_Pervasives_Native.fst body) - | uu___2 -> FStar_Pervasives_Native.None) -let (is_steel_new_invariant : FStar_Syntax_Syntax.term -> Prims.bool) = - fun t -> - let uu___ = FStar_Syntax_Util.head_and_args t in - match uu___ with - | (head, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst head in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, _o::_p::[]) -> - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.steel_new_invariant_lid) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.steel_st_new_invariant_lid) - | uu___2 -> false) -let (is_type_binder : - FStar_Extraction_ML_UEnv.uenv -> FStar_Syntax_Syntax.binder -> Prims.bool) - = - fun env -> - fun x -> - is_arity env (x.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort -let (is_constructor : FStar_Syntax_Syntax.term -> Prims.bool) = - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_fvar - { FStar_Syntax_Syntax.fv_name = uu___1; - FStar_Syntax_Syntax.fv_qual = FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Data_ctor);_} - -> true - | FStar_Syntax_Syntax.Tm_fvar - { FStar_Syntax_Syntax.fv_name = uu___1; - FStar_Syntax_Syntax.fv_qual = FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Record_ctor uu___2);_} - -> true - | uu___1 -> false -let rec (is_fstar_value : FStar_Syntax_Syntax.term -> Prims.bool) = - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_constant uu___1 -> true - | FStar_Syntax_Syntax.Tm_bvar uu___1 -> true - | FStar_Syntax_Syntax.Tm_fvar uu___1 -> true - | FStar_Syntax_Syntax.Tm_abs uu___1 -> true - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head; FStar_Syntax_Syntax.args = args;_} - -> - let uu___1 = is_constructor head in - if uu___1 - then - FStar_Compiler_List.for_all - (fun uu___2 -> - match uu___2 with | (te, uu___3) -> is_fstar_value te) args - else false - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t1; FStar_Syntax_Syntax.meta = uu___1;_} - -> is_fstar_value t1 - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t1; FStar_Syntax_Syntax.asc = uu___1; - FStar_Syntax_Syntax.eff_opt = uu___2;_} - -> is_fstar_value t1 - | uu___1 -> false -let rec (is_ml_value : FStar_Extraction_ML_Syntax.mlexpr -> Prims.bool) = - fun e -> - match e.FStar_Extraction_ML_Syntax.expr with - | FStar_Extraction_ML_Syntax.MLE_Const uu___ -> true - | FStar_Extraction_ML_Syntax.MLE_Var uu___ -> true - | FStar_Extraction_ML_Syntax.MLE_Name uu___ -> true - | FStar_Extraction_ML_Syntax.MLE_Fun uu___ -> true - | FStar_Extraction_ML_Syntax.MLE_CTor (uu___, exps) -> - FStar_Compiler_Util.for_all is_ml_value exps - | FStar_Extraction_ML_Syntax.MLE_Tuple exps -> - FStar_Compiler_Util.for_all is_ml_value exps - | FStar_Extraction_ML_Syntax.MLE_Record (uu___, uu___1, fields) -> - FStar_Compiler_Util.for_all - (fun uu___2 -> match uu___2 with | (uu___3, e1) -> is_ml_value e1) - fields - | FStar_Extraction_ML_Syntax.MLE_TApp (h, uu___) -> is_ml_value h - | uu___ -> false -let (normalize_abs : FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = - fun t0 -> - let rec aux bs t copt = - let t1 = FStar_Syntax_Subst.compress t in - match t1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs'; FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = copt1;_} - -> aux (FStar_Compiler_List.op_At bs bs') body copt1 - | uu___ -> - let e' = FStar_Syntax_Util.unascribe t1 in - let uu___1 = FStar_Syntax_Util.is_fun e' in - if uu___1 then aux bs e' copt else FStar_Syntax_Util.abs bs e' copt in - aux [] t0 FStar_Pervasives_Native.None -let (unit_binder : unit -> FStar_Syntax_Syntax.binder) = - fun uu___ -> - let uu___1 = - FStar_Syntax_Syntax.new_bv FStar_Pervasives_Native.None - FStar_Syntax_Syntax.t_unit in - FStar_Syntax_Syntax.mk_binder uu___1 -let (check_pats_for_ite : - (FStar_Syntax_Syntax.pat * FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option * FStar_Syntax_Syntax.term) Prims.list -> - (Prims.bool * FStar_Syntax_Syntax.term FStar_Pervasives_Native.option * - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option)) - = - fun l -> - let def = - (false, FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) in - if (FStar_Compiler_List.length l) <> (Prims.of_int (2)) - then def - else - (let uu___1 = FStar_Compiler_List.hd l in - match uu___1 with - | (p1, w1, e1) -> - let uu___2 = - let uu___3 = FStar_Compiler_List.tl l in - FStar_Compiler_List.hd uu___3 in - (match uu___2 with - | (p2, w2, e2) -> - (match (w1, w2, (p1.FStar_Syntax_Syntax.v), - (p2.FStar_Syntax_Syntax.v)) - with - | (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None, - FStar_Syntax_Syntax.Pat_constant (FStar_Const.Const_bool - (true)), FStar_Syntax_Syntax.Pat_constant - (FStar_Const.Const_bool (false))) -> - (true, (FStar_Pervasives_Native.Some e1), - (FStar_Pervasives_Native.Some e2)) - | (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None, - FStar_Syntax_Syntax.Pat_constant (FStar_Const.Const_bool - (false)), FStar_Syntax_Syntax.Pat_constant - (FStar_Const.Const_bool (true))) -> - (true, (FStar_Pervasives_Native.Some e2), - (FStar_Pervasives_Native.Some e1)) - | uu___3 -> def))) -let (instantiate_tyscheme : - FStar_Extraction_ML_Syntax.mltyscheme -> - FStar_Extraction_ML_Syntax.mlty Prims.list -> - FStar_Extraction_ML_Syntax.mlty) - = fun s -> fun args -> FStar_Extraction_ML_Util.subst s args -let (fresh_mlidents : - FStar_Extraction_ML_Syntax.mlty Prims.list -> - FStar_Extraction_ML_UEnv.uenv -> - ((FStar_Extraction_ML_Syntax.mlident * FStar_Extraction_ML_Syntax.mlty) - Prims.list * FStar_Extraction_ML_UEnv.uenv)) - = - fun ts -> - fun g -> - let uu___ = - FStar_Compiler_List.fold_right - (fun t -> - fun uu___1 -> - match uu___1 with - | (uenv, vs) -> - let uu___2 = FStar_Extraction_ML_UEnv.new_mlident uenv in - (match uu___2 with | (uenv1, v) -> (uenv1, ((v, t) :: vs)))) - ts (g, []) in - match uu___ with | (g1, vs_ts) -> (vs_ts, g1) -let (fresh_binders : - FStar_Extraction_ML_Syntax.mlty Prims.list -> - FStar_Extraction_ML_UEnv.uenv -> - (FStar_Extraction_ML_Syntax.mlbinder Prims.list * - FStar_Extraction_ML_UEnv.uenv)) - = - fun ts -> - fun g -> - let uu___ = fresh_mlidents ts g in - match uu___ with - | (vs_ts, g1) -> - let uu___1 = - FStar_Compiler_List.map - (fun uu___2 -> - match uu___2 with - | (v, t) -> - { - FStar_Extraction_ML_Syntax.mlbinder_name = v; - FStar_Extraction_ML_Syntax.mlbinder_ty = t; - FStar_Extraction_ML_Syntax.mlbinder_attrs = [] - }) vs_ts in - (uu___1, g1) -let (instantiate_maybe_partial : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Extraction_ML_Syntax.mlexpr -> - FStar_Extraction_ML_Syntax.e_tag -> - FStar_Extraction_ML_Syntax.mltyscheme -> - FStar_Extraction_ML_Syntax.mlty Prims.list -> - (FStar_Extraction_ML_Syntax.mlexpr * - FStar_Extraction_ML_Syntax.e_tag * - FStar_Extraction_ML_Syntax.mlty)) - = - fun g -> - fun e -> - fun eff -> - fun s -> - fun tyargs -> - let uu___ = s in - match uu___ with - | (vars, t) -> - let n_vars = FStar_Compiler_List.length vars in - let n_args = FStar_Compiler_List.length tyargs in - if n_args = n_vars - then - (if n_args = Prims.int_zero - then (e, eff, t) - else - (let ts = instantiate_tyscheme (vars, t) tyargs in - let tapp = - { - FStar_Extraction_ML_Syntax.expr = - (FStar_Extraction_ML_Syntax.MLE_TApp (e, tyargs)); - FStar_Extraction_ML_Syntax.mlty = ts; - FStar_Extraction_ML_Syntax.loc = - (e.FStar_Extraction_ML_Syntax.loc) - } in - (tapp, eff, ts))) - else - if n_args < n_vars - then - (let extra_tyargs = - let uu___2 = FStar_Compiler_Util.first_N n_args vars in - match uu___2 with - | (uu___3, rest_vars) -> - FStar_Compiler_List.map - (fun uu___4 -> - FStar_Extraction_ML_Syntax.MLTY_Erased) - rest_vars in - let tyargs1 = - FStar_Compiler_List.op_At tyargs extra_tyargs in - let ts = instantiate_tyscheme (vars, t) tyargs1 in - let tapp = - { - FStar_Extraction_ML_Syntax.expr = - (FStar_Extraction_ML_Syntax.MLE_TApp (e, tyargs1)); - FStar_Extraction_ML_Syntax.mlty = ts; - FStar_Extraction_ML_Syntax.loc = - (e.FStar_Extraction_ML_Syntax.loc) - } in - let t1 = - FStar_Compiler_List.fold_left - (fun out -> - fun t2 -> - FStar_Extraction_ML_Syntax.MLTY_Fun - (t2, FStar_Extraction_ML_Syntax.E_PURE, out)) - ts extra_tyargs in - let uu___2 = fresh_binders extra_tyargs g in - match uu___2 with - | (vs_ts, g1) -> - let f = - FStar_Extraction_ML_Syntax.with_ty t1 - (FStar_Extraction_ML_Syntax.MLE_Fun - (vs_ts, tapp)) in - (f, eff, t1)) - else - failwith - "Impossible: instantiate_maybe_partial called with too many arguments" -let (eta_expand : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Extraction_ML_Syntax.mlty -> - FStar_Extraction_ML_Syntax.mlexpr -> FStar_Extraction_ML_Syntax.mlexpr) - = - fun g -> - fun t -> - fun e -> - let uu___ = FStar_Extraction_ML_Util.doms_and_cod t in - match uu___ with - | (ts, r) -> - if ts = [] - then e - else - (let uu___2 = fresh_binders ts g in - match uu___2 with - | (vs_ts, g1) -> - let vs_es = - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with - | { FStar_Extraction_ML_Syntax.mlbinder_name = v; - FStar_Extraction_ML_Syntax.mlbinder_ty = t1; - FStar_Extraction_ML_Syntax.mlbinder_attrs = - uu___4;_} - -> - FStar_Extraction_ML_Syntax.with_ty t1 - (FStar_Extraction_ML_Syntax.MLE_Var v)) vs_ts in - let body = - FStar_Extraction_ML_Syntax.with_ty r - (FStar_Extraction_ML_Syntax.MLE_App (e, vs_es)) in - FStar_Extraction_ML_Syntax.with_ty t - (FStar_Extraction_ML_Syntax.MLE_Fun (vs_ts, body))) -let (default_value_for_ty : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Extraction_ML_Syntax.mlty -> FStar_Extraction_ML_Syntax.mlexpr) - = - fun g -> - fun t -> - let uu___ = FStar_Extraction_ML_Util.doms_and_cod t in - match uu___ with - | (ts, r) -> - let body r1 = - let r2 = - let uu___1 = FStar_Extraction_ML_Util.udelta_unfold g r1 in - match uu___1 with - | FStar_Pervasives_Native.None -> r1 - | FStar_Pervasives_Native.Some r3 -> r3 in - match r2 with - | FStar_Extraction_ML_Syntax.MLTY_Erased -> - FStar_Extraction_ML_Syntax.ml_unit - | FStar_Extraction_ML_Syntax.MLTY_Top -> - FStar_Extraction_ML_Syntax.apply_obj_repr - FStar_Extraction_ML_Syntax.ml_unit - FStar_Extraction_ML_Syntax.MLTY_Erased - | uu___1 -> - FStar_Extraction_ML_Syntax.with_ty r2 - (FStar_Extraction_ML_Syntax.MLE_Coerce - (FStar_Extraction_ML_Syntax.ml_unit, - FStar_Extraction_ML_Syntax.MLTY_Erased, r2)) in - if ts = [] - then body r - else - (let uu___2 = fresh_binders ts g in - match uu___2 with - | (vs_ts, g1) -> - let uu___3 = - let uu___4 = let uu___5 = body r in (vs_ts, uu___5) in - FStar_Extraction_ML_Syntax.MLE_Fun uu___4 in - FStar_Extraction_ML_Syntax.with_ty t uu___3) -let (maybe_eta_expand_coercion : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Extraction_ML_Syntax.mlty -> - FStar_Extraction_ML_Syntax.mlexpr -> FStar_Extraction_ML_Syntax.mlexpr) - = - fun g -> - fun expect -> - fun e -> - let uu___ = - let uu___1 = FStar_Options.codegen () in - uu___1 = (FStar_Pervasives_Native.Some FStar_Options.Krml) in - if uu___ then e else eta_expand g expect e -let (apply_coercion : - FStar_Compiler_Range_Type.range -> - FStar_Extraction_ML_UEnv.uenv -> - FStar_Extraction_ML_Syntax.mlexpr -> - FStar_Extraction_ML_Syntax.mlty -> - FStar_Extraction_ML_Syntax.mlty -> - FStar_Extraction_ML_Syntax.mlexpr) - = - fun pos -> - fun g -> - fun e -> - fun ty -> - fun expect -> - (let uu___1 = FStar_Extraction_ML_Util.codegen_fsharp () in - if uu___1 - then - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Extraction_ML_UEnv.current_module_of_uenv g in - FStar_Extraction_ML_Code.string_of_mlty uu___4 ty in - let uu___4 = - let uu___5 = - FStar_Extraction_ML_UEnv.current_module_of_uenv g in - FStar_Extraction_ML_Code.string_of_mlty uu___5 expect in - FStar_Compiler_Util.format2 - "Inserted an unsafe type coercion in generated code from %s to %s; this may be unsound in F#" - uu___3 uu___4 in - FStar_Errors.log_issue FStar_Class_HasRange.hasRange_range pos - FStar_Errors_Codes.Warning_NoMagicInFSharp () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2) - else ()); - (let mk_fun binder body = - match body.FStar_Extraction_ML_Syntax.expr with - | FStar_Extraction_ML_Syntax.MLE_Fun (binders, body1) -> - FStar_Extraction_ML_Syntax.MLE_Fun - ((binder :: binders), body1) - | uu___1 -> - FStar_Extraction_ML_Syntax.MLE_Fun ([binder], body) in - let rec aux e1 ty1 expect1 = - let coerce_branch uu___1 = - match uu___1 with - | (pat, w, b) -> - let uu___2 = aux b ty1 expect1 in (pat, w, uu___2) in - let rec undelta mlty = - let uu___1 = FStar_Extraction_ML_Util.udelta_unfold g mlty in - match uu___1 with - | FStar_Pervasives_Native.Some t -> undelta t - | FStar_Pervasives_Native.None -> mlty in - let uu___1 = - let uu___2 = undelta expect1 in - ((e1.FStar_Extraction_ML_Syntax.expr), ty1, uu___2) in - match uu___1 with - | (FStar_Extraction_ML_Syntax.MLE_Fun (arg::rest, body), - FStar_Extraction_ML_Syntax.MLTY_Fun (t0, uu___2, t1), - FStar_Extraction_ML_Syntax.MLTY_Fun (s0, uu___3, s1)) -> - let body1 = - match rest with - | [] -> body - | uu___4 -> - FStar_Extraction_ML_Syntax.with_ty t1 - (FStar_Extraction_ML_Syntax.MLE_Fun (rest, body)) in - let body2 = aux body1 t1 s1 in - let uu___4 = type_leq g s0 t0 in - if uu___4 - then - FStar_Extraction_ML_Syntax.with_ty expect1 - (mk_fun arg body2) - else - (let lb = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Extraction_ML_Syntax.with_ty s0 - (FStar_Extraction_ML_Syntax.MLE_Var - (arg.FStar_Extraction_ML_Syntax.mlbinder_name)) in - (uu___9, s0, t0) in - FStar_Extraction_ML_Syntax.MLE_Coerce uu___8 in - FStar_Extraction_ML_Syntax.with_ty t0 uu___7 in - { - FStar_Extraction_ML_Syntax.mllb_name = - (arg.FStar_Extraction_ML_Syntax.mlbinder_name); - FStar_Extraction_ML_Syntax.mllb_tysc = - (FStar_Pervasives_Native.Some ([], t0)); - FStar_Extraction_ML_Syntax.mllb_add_unit = false; - FStar_Extraction_ML_Syntax.mllb_def = uu___6; - FStar_Extraction_ML_Syntax.mllb_attrs = []; - FStar_Extraction_ML_Syntax.mllb_meta = []; - FStar_Extraction_ML_Syntax.print_typ = false - } in - let body3 = - FStar_Extraction_ML_Syntax.with_ty s1 - (FStar_Extraction_ML_Syntax.MLE_Let - ((FStar_Extraction_ML_Syntax.NonRec, [lb]), - body2)) in - FStar_Extraction_ML_Syntax.with_ty expect1 - (mk_fun - { - FStar_Extraction_ML_Syntax.mlbinder_name = - (arg.FStar_Extraction_ML_Syntax.mlbinder_name); - FStar_Extraction_ML_Syntax.mlbinder_ty = s0; - FStar_Extraction_ML_Syntax.mlbinder_attrs = [] - } body3)) - | (FStar_Extraction_ML_Syntax.MLE_Let (lbs, body), uu___2, - uu___3) -> - let uu___4 = - let uu___5 = - let uu___6 = aux body ty1 expect1 in (lbs, uu___6) in - FStar_Extraction_ML_Syntax.MLE_Let uu___5 in - FStar_Extraction_ML_Syntax.with_ty expect1 uu___4 - | (FStar_Extraction_ML_Syntax.MLE_Match (s, branches), uu___2, - uu___3) -> - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Compiler_List.map coerce_branch branches in - (s, uu___6) in - FStar_Extraction_ML_Syntax.MLE_Match uu___5 in - FStar_Extraction_ML_Syntax.with_ty expect1 uu___4 - | (FStar_Extraction_ML_Syntax.MLE_If (s, b1, b2_opt), uu___2, - uu___3) -> - let uu___4 = - let uu___5 = - let uu___6 = aux b1 ty1 expect1 in - let uu___7 = - FStar_Compiler_Util.map_opt b2_opt - (fun b2 -> aux b2 ty1 expect1) in - (s, uu___6, uu___7) in - FStar_Extraction_ML_Syntax.MLE_If uu___5 in - FStar_Extraction_ML_Syntax.with_ty expect1 uu___4 - | (FStar_Extraction_ML_Syntax.MLE_Seq es, uu___2, uu___3) -> - let uu___4 = FStar_Compiler_Util.prefix es in - (match uu___4 with - | (prefix, last) -> - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = aux last ty1 expect1 in [uu___8] in - FStar_Compiler_List.op_At prefix uu___7 in - FStar_Extraction_ML_Syntax.MLE_Seq uu___6 in - FStar_Extraction_ML_Syntax.with_ty expect1 uu___5) - | (FStar_Extraction_ML_Syntax.MLE_Try (s, branches), uu___2, - uu___3) -> - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Compiler_List.map coerce_branch branches in - (s, uu___6) in - FStar_Extraction_ML_Syntax.MLE_Try uu___5 in - FStar_Extraction_ML_Syntax.with_ty expect1 uu___4 - | uu___2 -> - FStar_Extraction_ML_Syntax.with_ty expect1 - (FStar_Extraction_ML_Syntax.MLE_Coerce - (e1, ty1, expect1)) in - aux e ty expect) -let (maybe_coerce : - FStar_Compiler_Range_Type.range -> - FStar_Extraction_ML_UEnv.uenv -> - FStar_Extraction_ML_Syntax.mlexpr -> - FStar_Extraction_ML_Syntax.mlty -> - FStar_Extraction_ML_Syntax.mlty -> - FStar_Extraction_ML_Syntax.mlexpr) - = - fun pos -> - fun g -> - fun e -> - fun ty -> - fun expect -> - let ty1 = eraseTypeDeep g ty in - let uu___ = - type_leq_c g (FStar_Pervasives_Native.Some e) ty1 expect in - match uu___ with - | (true, FStar_Pervasives_Native.Some e') -> e' - | uu___1 -> - (match ty1 with - | FStar_Extraction_ML_Syntax.MLTY_Erased -> - default_value_for_ty g expect - | uu___2 -> - let uu___3 = - let uu___4 = - FStar_Extraction_ML_Util.erase_effect_annotations - ty1 in - let uu___5 = - FStar_Extraction_ML_Util.erase_effect_annotations - expect in - type_leq g uu___4 uu___5 in - if uu___3 - then - (FStar_Extraction_ML_UEnv.debug g - (fun uu___5 -> - let uu___6 = - let uu___7 = - FStar_Extraction_ML_UEnv.current_module_of_uenv - g in - FStar_Extraction_ML_Code.string_of_mlexpr - uu___7 e in - let uu___7 = - let uu___8 = - FStar_Extraction_ML_UEnv.current_module_of_uenv - g in - FStar_Extraction_ML_Code.string_of_mlty uu___8 - ty1 in - FStar_Compiler_Util.print2 - "\n Effect mismatch on type of %s : %s\n" - uu___6 uu___7); - e) - else - (FStar_Extraction_ML_UEnv.debug g - (fun uu___6 -> - let uu___7 = - let uu___8 = - FStar_Extraction_ML_UEnv.current_module_of_uenv - g in - FStar_Extraction_ML_Code.string_of_mlexpr - uu___8 e in - let uu___8 = - let uu___9 = - FStar_Extraction_ML_UEnv.current_module_of_uenv - g in - FStar_Extraction_ML_Code.string_of_mlty uu___9 - ty1 in - let uu___9 = - let uu___10 = - FStar_Extraction_ML_UEnv.current_module_of_uenv - g in - FStar_Extraction_ML_Code.string_of_mlty - uu___10 expect in - FStar_Compiler_Util.print3 - "\n (*needed to coerce expression \n %s \n of type \n %s \n to type \n %s *) \n" - uu___7 uu___8 uu___9); - (let uu___6 = apply_coercion pos g e ty1 expect in - maybe_eta_expand_coercion g expect uu___6))) -let (bv_as_mlty : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.bv -> FStar_Extraction_ML_Syntax.mlty) - = - fun g -> - fun bv -> - let uu___ = FStar_Extraction_ML_UEnv.lookup_bv g bv in - match uu___ with - | FStar_Pervasives.Inl ty_b -> ty_b.FStar_Extraction_ML_UEnv.ty_b_ty - | uu___1 -> FStar_Extraction_ML_Syntax.MLTY_Top -let (extraction_norm_steps : FStar_TypeChecker_Env.step Prims.list) = - let extraction_norm_steps_core = - [FStar_TypeChecker_Env.AllowUnboundUniverses; - FStar_TypeChecker_Env.EraseUniverses; - FStar_TypeChecker_Env.Inlining; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.Exclude FStar_TypeChecker_Env.Zeta; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.Unascribe; - FStar_TypeChecker_Env.ForExtraction] in - let extraction_norm_steps_nbe = FStar_TypeChecker_Env.NBE :: - extraction_norm_steps_core in - let uu___ = FStar_Options.use_nbe_for_extraction () in - if uu___ then extraction_norm_steps_nbe else extraction_norm_steps_core -let (normalize_for_extraction : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun env -> - fun e -> - let uu___ = FStar_Extraction_ML_UEnv.tcenv_of_uenv env in - FStar_TypeChecker_Normalize.normalize extraction_norm_steps uu___ e -let maybe_reify_comp : - 'uuuuu . - 'uuuuu -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.comp -> FStar_Syntax_Syntax.term - = - fun g -> - fun env -> - fun c -> - let uu___ = - FStar_TypeChecker_Util.effect_extraction_mode env - (FStar_Syntax_Util.comp_effect_name c) in - match uu___ with - | FStar_Syntax_Syntax.Extract_reify -> - let uu___1 = - FStar_TypeChecker_Env.reify_comp env c - FStar_Syntax_Syntax.U_unknown in - FStar_TypeChecker_Normalize.normalize extraction_norm_steps env - uu___1 - | FStar_Syntax_Syntax.Extract_primitive -> - FStar_Syntax_Util.comp_result c - | FStar_Syntax_Syntax.Extract_none s -> - let uu___1 = - FStar_Class_Show.show FStar_Syntax_Print.showable_comp c in - err_cannot_extract_effect (FStar_Syntax_Util.comp_effect_name c) - c.FStar_Syntax_Syntax.pos s uu___1 -let (maybe_reify_term : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Ident.lident -> FStar_Syntax_Syntax.term) - = - fun env -> - fun t -> - fun l -> - let uu___ = FStar_TypeChecker_Util.effect_extraction_mode env l in - match uu___ with - | FStar_Syntax_Syntax.Extract_reify -> - let uu___1 = - FStar_Syntax_Util.mk_reify t (FStar_Pervasives_Native.Some l) in - FStar_TypeChecker_Util.norm_reify env - [FStar_TypeChecker_Env.Inlining; - FStar_TypeChecker_Env.ForExtraction; - FStar_TypeChecker_Env.Unascribe] uu___1 - | FStar_Syntax_Syntax.Extract_primitive -> t - | FStar_Syntax_Syntax.Extract_none s -> - let uu___1 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - err_cannot_extract_effect l t.FStar_Syntax_Syntax.pos s uu___1 -let (has_extract_as_impure_effect : - FStar_Extraction_ML_UEnv.uenv -> FStar_Syntax_Syntax.fv -> Prims.bool) = - fun g -> - fun fv -> - let uu___ = FStar_Extraction_ML_UEnv.tcenv_of_uenv g in - FStar_TypeChecker_Env.fv_has_attr uu___ fv - FStar_Parser_Const.extract_as_impure_effect_lid -let (head_of_type_is_extract_as_impure_effect : - FStar_Extraction_ML_UEnv.uenv -> FStar_Syntax_Syntax.term -> Prims.bool) = - fun g -> - fun t -> - let uu___ = FStar_Syntax_Util.head_and_args t in - match uu___ with - | (hd, uu___1) -> - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst hd in - uu___3.FStar_Syntax_Syntax.n in - (match uu___2 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - has_extract_as_impure_effect g fv - | uu___3 -> false) -let rec (translate_term_to_mlty : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.term -> FStar_Extraction_ML_Syntax.mlty) - = - fun g -> - fun t0 -> - let arg_as_mlty g1 uu___ = - match uu___ with - | (a, uu___1) -> - let uu___2 = is_type g1 a in - if uu___2 - then translate_term_to_mlty g1 a - else FStar_Extraction_ML_Syntax.MLTY_Erased in - let fv_app_as_mlty g1 fv args = - let uu___ = - let uu___1 = FStar_Extraction_ML_UEnv.is_fv_type g1 fv in - Prims.op_Negation uu___1 in - if uu___ - then FStar_Extraction_ML_Syntax.MLTY_Top - else - (let uu___2 = has_extract_as_impure_effect g1 fv in - if uu___2 - then - let uu___3 = args in - match uu___3 with - | (a, uu___4)::uu___5 -> translate_term_to_mlty g1 a - else - (let uu___4 = - let uu___5 = - let uu___6 = FStar_Extraction_ML_UEnv.tcenv_of_uenv g1 in - FStar_TypeChecker_Env.lookup_lid uu___6 - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - match uu___5 with - | ((uu___6, fvty), uu___7) -> - let fvty1 = - let uu___8 = FStar_Extraction_ML_UEnv.tcenv_of_uenv g1 in - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.ForExtraction] uu___8 fvty in - FStar_Syntax_Util.arrow_formals fvty1 in - match uu___4 with - | (formals, uu___5) -> - let mlargs = FStar_Compiler_List.map (arg_as_mlty g1) args in - let mlargs1 = - let n_args = FStar_Compiler_List.length args in - if (FStar_Compiler_List.length formals) > n_args - then - let uu___6 = FStar_Compiler_Util.first_N n_args formals in - match uu___6 with - | (uu___7, rest) -> - let uu___8 = - FStar_Compiler_List.map - (fun uu___9 -> - FStar_Extraction_ML_Syntax.MLTY_Erased) rest in - FStar_Compiler_List.op_At mlargs uu___8 - else mlargs in - let nm = - FStar_Extraction_ML_UEnv.mlpath_of_lident g1 - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - FStar_Extraction_ML_Syntax.MLTY_Named (mlargs1, nm))) in - let aux env t = - let t1 = FStar_Syntax_Subst.compress t in - match t1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_type uu___ -> - FStar_Extraction_ML_Syntax.MLTY_Erased - | FStar_Syntax_Syntax.Tm_bvar uu___ -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.format1 "Impossible: Unexpected term %s" - uu___2 in - failwith uu___1 - | FStar_Syntax_Syntax.Tm_delayed uu___ -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.format1 "Impossible: Unexpected term %s" - uu___2 in - failwith uu___1 - | FStar_Syntax_Syntax.Tm_unknown -> - let uu___ = - let uu___1 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.format1 "Impossible: Unexpected term %s" - uu___1 in - failwith uu___ - | FStar_Syntax_Syntax.Tm_lazy i -> - let uu___ = FStar_Syntax_Util.unfold_lazy i in - translate_term_to_mlty env uu___ - | FStar_Syntax_Syntax.Tm_constant uu___ -> - FStar_Extraction_ML_Syntax.MLTY_Top - | FStar_Syntax_Syntax.Tm_quoted uu___ -> - FStar_Extraction_ML_Syntax.MLTY_Top - | FStar_Syntax_Syntax.Tm_uvar uu___ -> - FStar_Extraction_ML_Syntax.MLTY_Top - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t2; - FStar_Syntax_Syntax.meta = uu___;_} - -> translate_term_to_mlty env t2 - | FStar_Syntax_Syntax.Tm_refine - { - FStar_Syntax_Syntax.b = - { FStar_Syntax_Syntax.ppname = uu___; - FStar_Syntax_Syntax.index = uu___1; - FStar_Syntax_Syntax.sort = t2;_}; - FStar_Syntax_Syntax.phi = uu___2;_} - -> translate_term_to_mlty env t2 - | FStar_Syntax_Syntax.Tm_uinst (t2, uu___) -> - translate_term_to_mlty env t2 - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t2; FStar_Syntax_Syntax.asc = uu___; - FStar_Syntax_Syntax.eff_opt = uu___1;_} - -> translate_term_to_mlty env t2 - | FStar_Syntax_Syntax.Tm_name bv -> bv_as_mlty env bv - | FStar_Syntax_Syntax.Tm_fvar fv -> fv_app_as_mlty env fv [] - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; FStar_Syntax_Syntax.comp = c;_} - -> - let uu___ = FStar_Syntax_Subst.open_comp bs c in - (match uu___ with - | (bs1, c1) -> - let uu___1 = binders_as_ml_binders env bs1 in - (match uu___1 with - | (mlbs, env1) -> - let codom = - let uu___2 = - FStar_Extraction_ML_UEnv.tcenv_of_uenv env1 in - maybe_reify_comp env1 uu___2 c1 in - let t_ret = translate_term_to_mlty env1 codom in - let etag = - effect_as_etag env1 - (FStar_Syntax_Util.comp_effect_name c1) in - let etag1 = - if etag = FStar_Extraction_ML_Syntax.E_IMPURE - then etag - else - (let uu___3 = - head_of_type_is_extract_as_impure_effect env1 - codom in - if uu___3 - then FStar_Extraction_ML_Syntax.E_IMPURE - else etag) in - let uu___2 = - FStar_Compiler_List.fold_right - (fun uu___3 -> - fun uu___4 -> - match (uu___3, uu___4) with - | ((uu___5, t2), (tag, t')) -> - (FStar_Extraction_ML_Syntax.E_PURE, - (FStar_Extraction_ML_Syntax.MLTY_Fun - (t2, tag, t')))) mlbs (etag1, t_ret) in - (match uu___2 with | (uu___3, t2) -> t2))) - | FStar_Syntax_Syntax.Tm_app uu___ -> - let uu___1 = FStar_Syntax_Util.head_and_args_full t1 in - (match uu___1 with - | (head, args) -> - let res = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Util.un_uinst head in - uu___4.FStar_Syntax_Syntax.n in - (uu___3, args) in - match uu___2 with - | (FStar_Syntax_Syntax.Tm_name bv, uu___3) -> - bv_as_mlty env bv - | (FStar_Syntax_Syntax.Tm_fvar fv, uu___3::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.steel_memory_inv_lid - -> - translate_term_to_mlty env FStar_Syntax_Syntax.t_unit - | (FStar_Syntax_Syntax.Tm_fvar fv, uu___3) -> - fv_app_as_mlty env fv args - | uu___3 -> FStar_Extraction_ML_Syntax.MLTY_Top in - res) - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs; FStar_Syntax_Syntax.body = ty; - FStar_Syntax_Syntax.rc_opt = uu___;_} - -> - let uu___1 = FStar_Syntax_Subst.open_term bs ty in - (match uu___1 with - | (bs1, ty1) -> - let uu___2 = binders_as_ml_binders env bs1 in - (match uu___2 with - | (bts, env1) -> translate_term_to_mlty env1 ty1)) - | FStar_Syntax_Syntax.Tm_let uu___ -> - FStar_Extraction_ML_Syntax.MLTY_Top - | FStar_Syntax_Syntax.Tm_match uu___ -> - FStar_Extraction_ML_Syntax.MLTY_Top in - let rec is_top_ty t = - match t with - | FStar_Extraction_ML_Syntax.MLTY_Top -> true - | FStar_Extraction_ML_Syntax.MLTY_Named uu___ -> - let uu___1 = FStar_Extraction_ML_Util.udelta_unfold g t in - (match uu___1 with - | FStar_Pervasives_Native.None -> false - | FStar_Pervasives_Native.Some t1 -> is_top_ty t1) - | uu___ -> false in - let uu___ = - let uu___1 = FStar_Extraction_ML_UEnv.tcenv_of_uenv g in - FStar_TypeChecker_Util.must_erase_for_extraction uu___1 t0 in - if uu___ - then FStar_Extraction_ML_Syntax.MLTY_Erased - else - (let mlt = aux g t0 in - let uu___2 = is_top_ty mlt in - if uu___2 then FStar_Extraction_ML_Syntax.MLTY_Top else mlt) -and (binders_as_ml_binders : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.binders -> - ((FStar_Extraction_ML_Syntax.mlident * FStar_Extraction_ML_Syntax.mlty) - Prims.list * FStar_Extraction_ML_UEnv.uenv)) - = - fun g -> - fun bs -> - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun b -> - match uu___1 with - | (ml_bs, env) -> - let uu___2 = is_type_binder g b in - if uu___2 - then - let b1 = b.FStar_Syntax_Syntax.binder_bv in - let env1 = - FStar_Extraction_ML_UEnv.extend_ty env b1 true in - let ml_b = - let uu___3 = - FStar_Extraction_ML_UEnv.lookup_ty env1 b1 in - uu___3.FStar_Extraction_ML_UEnv.ty_b_name in - let ml_b1 = - (ml_b, FStar_Extraction_ML_Syntax.ml_unit_ty) in - ((ml_b1 :: ml_bs), env1) - else - (let b1 = b.FStar_Syntax_Syntax.binder_bv in - let t = - translate_term_to_mlty env - b1.FStar_Syntax_Syntax.sort in - let uu___4 = - FStar_Extraction_ML_UEnv.extend_bv env b1 ([], t) - false false in - match uu___4 with - | (env1, b2, uu___5) -> - let ml_b = (b2, t) in ((ml_b :: ml_bs), env1))) - ([], g) bs in - match uu___ with - | (ml_bs, env) -> ((FStar_Compiler_List.rev ml_bs), env) -let (term_as_mlty : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.term -> FStar_Extraction_ML_Syntax.mlty) - = - fun g -> - fun t0 -> - let t = - let uu___ = FStar_Extraction_ML_UEnv.tcenv_of_uenv g in - FStar_TypeChecker_Normalize.normalize extraction_norm_steps uu___ t0 in - translate_term_to_mlty g t -let (mk_MLE_Seq : - FStar_Extraction_ML_Syntax.mlexpr -> - FStar_Extraction_ML_Syntax.mlexpr -> FStar_Extraction_ML_Syntax.mlexpr') - = - fun e1 -> - fun e2 -> - match ((e1.FStar_Extraction_ML_Syntax.expr), - (e2.FStar_Extraction_ML_Syntax.expr)) - with - | (FStar_Extraction_ML_Syntax.MLE_Seq es1, - FStar_Extraction_ML_Syntax.MLE_Seq es2) -> - FStar_Extraction_ML_Syntax.MLE_Seq - (FStar_Compiler_List.op_At es1 es2) - | (FStar_Extraction_ML_Syntax.MLE_Seq es1, uu___) -> - FStar_Extraction_ML_Syntax.MLE_Seq - (FStar_Compiler_List.op_At es1 [e2]) - | (uu___, FStar_Extraction_ML_Syntax.MLE_Seq es2) -> - FStar_Extraction_ML_Syntax.MLE_Seq (e1 :: es2) - | uu___ -> FStar_Extraction_ML_Syntax.MLE_Seq [e1; e2] -let (mk_MLE_Let : - Prims.bool -> - FStar_Extraction_ML_Syntax.mlletbinding -> - FStar_Extraction_ML_Syntax.mlexpr -> FStar_Extraction_ML_Syntax.mlexpr') - = - fun top_level -> - fun lbs -> - fun body -> - match lbs with - | (FStar_Extraction_ML_Syntax.NonRec, lb::[]) when - Prims.op_Negation top_level -> - (match lb.FStar_Extraction_ML_Syntax.mllb_tysc with - | FStar_Pervasives_Native.Some ([], t) when - t = FStar_Extraction_ML_Syntax.ml_unit_ty -> - if - body.FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.ml_unit.FStar_Extraction_ML_Syntax.expr - then - (lb.FStar_Extraction_ML_Syntax.mllb_def).FStar_Extraction_ML_Syntax.expr - else - (match body.FStar_Extraction_ML_Syntax.expr with - | FStar_Extraction_ML_Syntax.MLE_Var x when - x = lb.FStar_Extraction_ML_Syntax.mllb_name -> - (lb.FStar_Extraction_ML_Syntax.mllb_def).FStar_Extraction_ML_Syntax.expr - | uu___1 when - (lb.FStar_Extraction_ML_Syntax.mllb_def).FStar_Extraction_ML_Syntax.expr - = - FStar_Extraction_ML_Syntax.ml_unit.FStar_Extraction_ML_Syntax.expr - -> body.FStar_Extraction_ML_Syntax.expr - | uu___1 -> - mk_MLE_Seq lb.FStar_Extraction_ML_Syntax.mllb_def - body) - | uu___ -> FStar_Extraction_ML_Syntax.MLE_Let (lbs, body)) - | uu___ -> FStar_Extraction_ML_Syntax.MLE_Let (lbs, body) -let record_fields : - 'a . - FStar_Extraction_ML_UEnv.uenv -> - FStar_Ident.lident -> - FStar_Ident.ident Prims.list -> - 'a Prims.list -> - (FStar_Extraction_ML_Syntax.mlsymbol * 'a) Prims.list - = - fun g -> - fun ty -> - fun fns -> - fun xs -> - let fns1 = - FStar_Compiler_List.map - (fun x -> - FStar_Extraction_ML_UEnv.lookup_record_field_name g (ty, x)) - fns in - FStar_Compiler_List.map2 - (fun uu___ -> fun x -> match uu___ with | (p, s) -> (s, x)) fns1 - xs -let (resugar_pat : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.fv_qual FStar_Pervasives_Native.option -> - FStar_Extraction_ML_Syntax.mlpattern -> - FStar_Extraction_ML_Syntax.mlpattern) - = - fun g -> - fun q -> - fun p -> - match p with - | FStar_Extraction_ML_Syntax.MLP_CTor (d, pats) -> - let uu___ = FStar_Extraction_ML_Util.is_xtuple d in - (match uu___ with - | FStar_Pervasives_Native.Some n -> - FStar_Extraction_ML_Syntax.MLP_Tuple pats - | uu___1 -> - (match q with - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Record_ctor (ty, fns)) -> - let path = - let uu___2 = FStar_Ident.ns_of_lid ty in - FStar_Compiler_List.map FStar_Ident.string_of_id - uu___2 in - let fs = record_fields g ty fns pats in - let path1 = - FStar_Extraction_ML_UEnv.no_fstar_stubs_ns path in - FStar_Extraction_ML_Syntax.MLP_Record (path1, fs) - | uu___2 -> p)) - | uu___ -> p -let rec (extract_one_pat : - Prims.bool -> - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.pat -> - FStar_Extraction_ML_Syntax.mlty -> - (FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.term -> - (FStar_Extraction_ML_Syntax.mlexpr * - FStar_Extraction_ML_Syntax.e_tag * - FStar_Extraction_ML_Syntax.mlty)) - -> - (FStar_Extraction_ML_UEnv.uenv * - (FStar_Extraction_ML_Syntax.mlpattern * - FStar_Extraction_ML_Syntax.mlexpr Prims.list) - FStar_Pervasives_Native.option * Prims.bool)) - = - fun imp -> - fun g -> - fun p -> - fun expected_ty -> - fun term_as_mlexpr -> - let ok t = - match expected_ty with - | FStar_Extraction_ML_Syntax.MLTY_Top -> false - | uu___ -> - let ok1 = type_leq g t expected_ty in - (if Prims.op_Negation ok1 - then - FStar_Extraction_ML_UEnv.debug g - (fun uu___2 -> - let uu___3 = - let uu___4 = - FStar_Extraction_ML_UEnv.current_module_of_uenv - g in - FStar_Extraction_ML_Code.string_of_mlty uu___4 - expected_ty in - let uu___4 = - let uu___5 = - FStar_Extraction_ML_UEnv.current_module_of_uenv - g in - FStar_Extraction_ML_Code.string_of_mlty uu___5 t in - FStar_Compiler_Util.print2 - "Expected pattern type %s; got pattern type %s\n" - uu___3 uu___4) - else (); - ok1) in - match p.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_constant (FStar_Const.Const_int - (c, swopt)) when - let uu___ = FStar_Options.codegen () in - uu___ <> (FStar_Pervasives_Native.Some FStar_Options.Krml) -> - let uu___ = - match swopt with - | FStar_Pervasives_Native.None -> - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Extraction_ML_Util.mlconst_of_const - p.FStar_Syntax_Syntax.p - (FStar_Const.Const_int - (c, FStar_Pervasives_Native.None)) in - FStar_Extraction_ML_Syntax.MLE_Const uu___3 in - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.ml_int_ty uu___2 in - (uu___1, FStar_Extraction_ML_Syntax.ml_int_ty) - | FStar_Pervasives_Native.Some sw -> - let source_term = - let uu___1 = - let uu___2 = - FStar_Extraction_ML_UEnv.tcenv_of_uenv g in - uu___2.FStar_TypeChecker_Env.dsenv in - FStar_ToSyntax_ToSyntax.desugar_machine_integer - uu___1 c sw FStar_Compiler_Range_Type.dummyRange in - let uu___1 = term_as_mlexpr g source_term in - (match uu___1 with - | (mlterm, uu___2, mlty) -> (mlterm, mlty)) in - (match uu___ with - | (mlc, ml_ty) -> - let uu___1 = FStar_Extraction_ML_UEnv.new_mlident g in - (match uu___1 with - | (g1, x) -> - let x_exp = - let x_exp1 = - FStar_Extraction_ML_Syntax.with_ty expected_ty - (FStar_Extraction_ML_Syntax.MLE_Var x) in - let coerce x1 = - FStar_Extraction_ML_Syntax.with_ty ml_ty - (FStar_Extraction_ML_Syntax.MLE_Coerce - (x1, ml_ty, expected_ty)) in - match expected_ty with - | FStar_Extraction_ML_Syntax.MLTY_Top -> - coerce x_exp1 - | uu___2 -> - let uu___3 = ok ml_ty in - if uu___3 then x_exp1 else coerce x_exp1 in - let when_clause = - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.ml_bool_ty - (FStar_Extraction_ML_Syntax.MLE_App - (FStar_Extraction_ML_Util.prims_op_equality, - [x_exp; mlc])) in - let uu___2 = ok ml_ty in - (g1, - (FStar_Pervasives_Native.Some - ((FStar_Extraction_ML_Syntax.MLP_Var x), - [when_clause])), uu___2))) - | FStar_Syntax_Syntax.Pat_constant s -> - let t = - let uu___ = FStar_Extraction_ML_UEnv.tcenv_of_uenv g in - FStar_TypeChecker_TcTerm.tc_constant uu___ - FStar_Compiler_Range_Type.dummyRange s in - let mlty = term_as_mlty g t in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Extraction_ML_Util.mlconst_of_const - p.FStar_Syntax_Syntax.p s in - FStar_Extraction_ML_Syntax.MLP_Const uu___3 in - (uu___2, []) in - FStar_Pervasives_Native.Some uu___1 in - let uu___1 = ok mlty in (g, uu___, uu___1) - | FStar_Syntax_Syntax.Pat_var x -> - let uu___ = - FStar_Extraction_ML_UEnv.extend_bv g x ([], expected_ty) - false imp in - (match uu___ with - | (g1, x1, uu___1) -> - (g1, - (if imp - then FStar_Pervasives_Native.None - else - FStar_Pervasives_Native.Some - ((FStar_Extraction_ML_Syntax.MLP_Var x1), [])), - true)) - | FStar_Syntax_Syntax.Pat_dot_term uu___ -> - (g, FStar_Pervasives_Native.None, true) - | FStar_Syntax_Syntax.Pat_cons (f, uu___, pats) -> - let uu___1 = - let uu___2 = - FStar_Extraction_ML_UEnv.try_lookup_fv - p.FStar_Syntax_Syntax.p g f in - match uu___2 with - | FStar_Pervasives_Native.Some - { FStar_Extraction_ML_UEnv.exp_b_name = uu___3; - FStar_Extraction_ML_UEnv.exp_b_expr = - { - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name n; - FStar_Extraction_ML_Syntax.mlty = uu___4; - FStar_Extraction_ML_Syntax.loc = uu___5;_}; - FStar_Extraction_ML_UEnv.exp_b_tscheme = ttys; - FStar_Extraction_ML_UEnv.exp_b_eff = uu___6;_} - -> (n, ttys) - | FStar_Pervasives_Native.Some uu___3 -> - failwith "Expected a constructor" - | FStar_Pervasives_Native.None -> - let uu___3 = - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_fv f in - FStar_Compiler_Util.format1 - "Cannot extract this pattern, the %s constructor was erased" - uu___4 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - (f.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.p - FStar_Errors_Codes.Error_ErasedCtor () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___3) in - (match uu___1 with - | (d, tys) -> - let nTyVars = - FStar_Compiler_List.length - (FStar_Pervasives_Native.fst tys) in - let uu___2 = FStar_Compiler_Util.first_N nTyVars pats in - (match uu___2 with - | (tysVarPats, restPats) -> - let f_ty = - let mlty_args = - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with - | (p1, uu___4) -> - (match expected_ty with - | FStar_Extraction_ML_Syntax.MLTY_Top - -> - FStar_Extraction_ML_Syntax.MLTY_Top - | uu___5 -> - (match p1.FStar_Syntax_Syntax.v - with - | FStar_Syntax_Syntax.Pat_dot_term - (FStar_Pervasives_Native.Some - t) -> term_as_mlty g t - | uu___6 -> - FStar_Extraction_ML_Syntax.MLTY_Top))) - tysVarPats in - let f_ty1 = - FStar_Extraction_ML_Util.subst tys mlty_args in - FStar_Extraction_ML_Util.uncurry_mlty_fun f_ty1 in - (FStar_Extraction_ML_UEnv.debug g - (fun uu___4 -> - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_fv f in - let uu___6 = - let uu___7 = f_ty in - match uu___7 with - | (args, t) -> - let args1 = - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Extraction_ML_UEnv.current_module_of_uenv - g in - FStar_Extraction_ML_Code.string_of_mlty - uu___10 in - FStar_Compiler_List.map uu___9 args in - FStar_Compiler_String.concat " -> " - uu___8 in - let res = - let uu___8 = - FStar_Extraction_ML_UEnv.current_module_of_uenv - g in - FStar_Extraction_ML_Code.string_of_mlty - uu___8 t in - FStar_Compiler_Util.format2 "%s -> %s" - args1 res in - FStar_Compiler_Util.print2 - "@@@Expected type of pattern with head = %s is %s\n" - uu___5 uu___6); - (let uu___4 = - FStar_Compiler_Util.fold_map - (fun g1 -> - fun uu___5 -> - match uu___5 with - | (p1, imp1) -> - let uu___6 = - extract_one_pat true g1 p1 - FStar_Extraction_ML_Syntax.MLTY_Top - term_as_mlexpr in - (match uu___6 with - | (g2, p2, uu___7) -> (g2, p2))) g - tysVarPats in - match uu___4 with - | (g1, tyMLPats) -> - let uu___5 = - FStar_Compiler_Util.fold_map - (fun uu___6 -> - fun uu___7 -> - match (uu___6, uu___7) with - | ((g2, f_ty1, ok1), (p1, imp1)) -> - let uu___8 = - match f_ty1 with - | (hd::rest, res) -> - ((rest, res), hd) - | uu___9 -> - (([], - FStar_Extraction_ML_Syntax.MLTY_Top), - FStar_Extraction_ML_Syntax.MLTY_Top) in - (match uu___8 with - | (f_ty2, expected_arg_ty) -> - let uu___9 = - extract_one_pat false g2 - p1 expected_arg_ty - term_as_mlexpr in - (match uu___9 with - | (g3, p2, ok') -> - ((g3, f_ty2, - (ok1 && ok')), p2)))) - (g1, f_ty, true) restPats in - (match uu___5 with - | ((g2, f_ty1, sub_pats_ok), restMLPats) -> - let uu___6 = - let uu___7 = - FStar_Compiler_List.collect - (fun uu___8 -> - match uu___8 with - | FStar_Pervasives_Native.Some - x -> [x] - | uu___9 -> []) - (FStar_Compiler_List.append - tyMLPats restMLPats) in - FStar_Compiler_List.split uu___7 in - (match uu___6 with - | (mlPats, when_clauses) -> - let pat_ty_compat = - match f_ty1 with - | ([], t) -> ok t - | uu___7 -> false in - let uu___7 = - let uu___8 = - let uu___9 = - resugar_pat g2 - f.FStar_Syntax_Syntax.fv_qual - (FStar_Extraction_ML_Syntax.MLP_CTor - (d, mlPats)) in - (uu___9, - (FStar_Compiler_List.flatten - when_clauses)) in - FStar_Pervasives_Native.Some - uu___8 in - (g2, uu___7, - (sub_pats_ok && pat_ty_compat)))))))) -let (extract_pat : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.pat -> - FStar_Extraction_ML_Syntax.mlty -> - (FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.term -> - (FStar_Extraction_ML_Syntax.mlexpr * - FStar_Extraction_ML_Syntax.e_tag * - FStar_Extraction_ML_Syntax.mlty)) - -> - (FStar_Extraction_ML_UEnv.uenv * - (FStar_Extraction_ML_Syntax.mlpattern * - FStar_Extraction_ML_Syntax.mlexpr FStar_Pervasives_Native.option) - Prims.list * Prims.bool)) - = - fun g -> - fun p -> - fun expected_t -> - fun term_as_mlexpr -> - let extract_one_pat1 g1 p1 expected_t1 = - let uu___ = - extract_one_pat false g1 p1 expected_t1 term_as_mlexpr in - match uu___ with - | (g2, FStar_Pervasives_Native.Some (x, v), b) -> (g2, (x, v), b) - | uu___1 -> failwith "Impossible: Unable to translate pattern" in - let mk_when_clause whens = - match whens with - | [] -> FStar_Pervasives_Native.None - | hd::tl -> - let uu___ = - FStar_Compiler_List.fold_left - FStar_Extraction_ML_Util.conjoin hd tl in - FStar_Pervasives_Native.Some uu___ in - let uu___ = extract_one_pat1 g p expected_t in - match uu___ with - | (g1, (p1, whens), b) -> - let when_clause = mk_when_clause whens in - (g1, [(p1, when_clause)], b) -let (maybe_eta_data_and_project_record : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.fv_qual FStar_Pervasives_Native.option -> - FStar_Extraction_ML_Syntax.mlty -> - FStar_Extraction_ML_Syntax.mlexpr -> - FStar_Extraction_ML_Syntax.mlexpr) - = - fun g -> - fun qual -> - fun residualType -> - fun mlAppExpr -> - let rec eta_args g1 more_args t = - match t with - | FStar_Extraction_ML_Syntax.MLTY_Fun (t0, uu___, t1) -> - let uu___1 = FStar_Extraction_ML_UEnv.new_mlident g1 in - (match uu___1 with - | (g2, x) -> - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Extraction_ML_Syntax.with_ty t0 - (FStar_Extraction_ML_Syntax.MLE_Var x) in - ((x, t0), uu___4) in - uu___3 :: more_args in - eta_args g2 uu___2 t1) - | FStar_Extraction_ML_Syntax.MLTY_Named (uu___, uu___1) -> - ((FStar_Compiler_List.rev more_args), t) - | uu___ -> - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Extraction_ML_UEnv.current_module_of_uenv g1 in - FStar_Extraction_ML_Code.string_of_mlexpr uu___3 - mlAppExpr in - let uu___3 = - let uu___4 = - FStar_Extraction_ML_UEnv.current_module_of_uenv g1 in - FStar_Extraction_ML_Code.string_of_mlty uu___4 t in - FStar_Compiler_Util.format2 - "Impossible: Head type is not an arrow: (%s : %s)" uu___2 - uu___3 in - failwith uu___1 in - let as_record qual1 e = - match ((e.FStar_Extraction_ML_Syntax.expr), qual1) with - | (FStar_Extraction_ML_Syntax.MLE_CTor (uu___, args), - FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Record_ctor - (tyname, fields))) -> - let path = - let uu___1 = FStar_Ident.ns_of_lid tyname in - FStar_Compiler_List.map FStar_Ident.string_of_id uu___1 in - let fields1 = record_fields g tyname fields args in - let path1 = FStar_Extraction_ML_UEnv.no_fstar_stubs_ns path in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Ident.ident_of_lid tyname in - FStar_Ident.string_of_id uu___4 in - (path1, uu___3, fields1) in - FStar_Extraction_ML_Syntax.MLE_Record uu___2 in - FStar_Extraction_ML_Syntax.with_ty - e.FStar_Extraction_ML_Syntax.mlty uu___1 - | uu___ -> e in - let resugar_and_maybe_eta qual1 e = - let uu___ = eta_args g [] residualType in - match uu___ with - | (eargs, tres) -> - (match eargs with - | [] -> - let uu___1 = as_record qual1 e in - FStar_Extraction_ML_Util.resugar_exp uu___1 - | uu___1 -> - let uu___2 = FStar_Compiler_List.unzip eargs in - (match uu___2 with - | (binders, eargs1) -> - (match e.FStar_Extraction_ML_Syntax.expr with - | FStar_Extraction_ML_Syntax.MLE_CTor (head, args) - -> - let body = - let uu___3 = - let uu___4 = - FStar_Extraction_ML_Syntax.with_ty tres - (FStar_Extraction_ML_Syntax.MLE_CTor - (head, - (FStar_Compiler_List.op_At args - eargs1))) in - as_record qual1 uu___4 in - FStar_Extraction_ML_Util.resugar_exp uu___3 in - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Compiler_List.map - (fun uu___6 -> - match uu___6 with - | (x, t) -> - { - FStar_Extraction_ML_Syntax.mlbinder_name - = x; - FStar_Extraction_ML_Syntax.mlbinder_ty - = t; - FStar_Extraction_ML_Syntax.mlbinder_attrs - = [] - }) binders in - (uu___5, body) in - FStar_Extraction_ML_Syntax.MLE_Fun uu___4 in - FStar_Extraction_ML_Syntax.with_ty - e.FStar_Extraction_ML_Syntax.mlty uu___3 - | uu___3 -> - failwith "Impossible: Not a constructor"))) in - match ((mlAppExpr.FStar_Extraction_ML_Syntax.expr), qual) with - | (uu___, FStar_Pervasives_Native.None) -> mlAppExpr - | (FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name mlp; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - mle::args), - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Record_projector (constrname, f))) -> - let fn = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Extraction_ML_UEnv.tcenv_of_uenv g in - FStar_TypeChecker_Env.typ_of_datacon uu___4 constrname in - (uu___3, f) in - FStar_Extraction_ML_UEnv.lookup_record_field_name g uu___2 in - let proj = FStar_Extraction_ML_Syntax.MLE_Proj (mle, fn) in - let e = - match args with - | [] -> proj - | uu___2 -> - let uu___3 = - let uu___4 = - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.MLTY_Top proj in - (uu___4, args) in - FStar_Extraction_ML_Syntax.MLE_App uu___3 in - FStar_Extraction_ML_Syntax.with_ty - mlAppExpr.FStar_Extraction_ML_Syntax.mlty e - | (FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name mlp; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - mle::args), - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Record_projector (constrname, f))) -> - let fn = - let uu___5 = - let uu___6 = - let uu___7 = FStar_Extraction_ML_UEnv.tcenv_of_uenv g in - FStar_TypeChecker_Env.typ_of_datacon uu___7 constrname in - (uu___6, f) in - FStar_Extraction_ML_UEnv.lookup_record_field_name g uu___5 in - let proj = FStar_Extraction_ML_Syntax.MLE_Proj (mle, fn) in - let e = - match args with - | [] -> proj - | uu___5 -> - let uu___6 = - let uu___7 = - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.MLTY_Top proj in - (uu___7, args) in - FStar_Extraction_ML_Syntax.MLE_App uu___6 in - FStar_Extraction_ML_Syntax.with_ty - mlAppExpr.FStar_Extraction_ML_Syntax.mlty e - | (FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name mlp; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - mlargs), - FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Data_ctor)) -> - let uu___2 = - FStar_Extraction_ML_Syntax.with_ty - mlAppExpr.FStar_Extraction_ML_Syntax.mlty - (FStar_Extraction_ML_Syntax.MLE_CTor (mlp, mlargs)) in - resugar_and_maybe_eta qual uu___2 - | (FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name mlp; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - mlargs), - FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Record_ctor - uu___2)) -> - let uu___3 = - FStar_Extraction_ML_Syntax.with_ty - mlAppExpr.FStar_Extraction_ML_Syntax.mlty - (FStar_Extraction_ML_Syntax.MLE_CTor (mlp, mlargs)) in - resugar_and_maybe_eta qual uu___3 - | (FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name mlp; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - mlargs), - FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Data_ctor)) -> - let uu___5 = - FStar_Extraction_ML_Syntax.with_ty - mlAppExpr.FStar_Extraction_ML_Syntax.mlty - (FStar_Extraction_ML_Syntax.MLE_CTor (mlp, mlargs)) in - resugar_and_maybe_eta qual uu___5 - | (FStar_Extraction_ML_Syntax.MLE_App - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name mlp; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2); - FStar_Extraction_ML_Syntax.mlty = uu___3; - FStar_Extraction_ML_Syntax.loc = uu___4;_}, - mlargs), - FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Record_ctor - uu___5)) -> - let uu___6 = - FStar_Extraction_ML_Syntax.with_ty - mlAppExpr.FStar_Extraction_ML_Syntax.mlty - (FStar_Extraction_ML_Syntax.MLE_CTor (mlp, mlargs)) in - resugar_and_maybe_eta qual uu___6 - | (FStar_Extraction_ML_Syntax.MLE_Name mlp, - FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Data_ctor)) -> - let uu___ = - FStar_Extraction_ML_Syntax.with_ty - mlAppExpr.FStar_Extraction_ML_Syntax.mlty - (FStar_Extraction_ML_Syntax.MLE_CTor (mlp, [])) in - resugar_and_maybe_eta qual uu___ - | (FStar_Extraction_ML_Syntax.MLE_Name mlp, - FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Record_ctor - uu___)) -> - let uu___1 = - FStar_Extraction_ML_Syntax.with_ty - mlAppExpr.FStar_Extraction_ML_Syntax.mlty - (FStar_Extraction_ML_Syntax.MLE_CTor (mlp, [])) in - resugar_and_maybe_eta qual uu___1 - | (FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name mlp; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2), - FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Data_ctor)) -> - let uu___3 = - FStar_Extraction_ML_Syntax.with_ty - mlAppExpr.FStar_Extraction_ML_Syntax.mlty - (FStar_Extraction_ML_Syntax.MLE_CTor (mlp, [])) in - resugar_and_maybe_eta qual uu___3 - | (FStar_Extraction_ML_Syntax.MLE_TApp - ({ - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Name mlp; - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_}, - uu___2), - FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Record_ctor - uu___3)) -> - let uu___4 = - FStar_Extraction_ML_Syntax.with_ty - mlAppExpr.FStar_Extraction_ML_Syntax.mlty - (FStar_Extraction_ML_Syntax.MLE_CTor (mlp, [])) in - resugar_and_maybe_eta qual uu___4 - | uu___ -> mlAppExpr -let (maybe_promote_effect : - FStar_Extraction_ML_Syntax.mlexpr -> - FStar_Extraction_ML_Syntax.e_tag -> - FStar_Extraction_ML_Syntax.mlty -> - (FStar_Extraction_ML_Syntax.mlexpr * - FStar_Extraction_ML_Syntax.e_tag)) - = - fun ml_e -> - fun tag -> - fun t -> - match (tag, t) with - | (FStar_Extraction_ML_Syntax.E_ERASABLE, - FStar_Extraction_ML_Syntax.MLTY_Erased) -> - (FStar_Extraction_ML_Syntax.ml_unit, - FStar_Extraction_ML_Syntax.E_PURE) - | (FStar_Extraction_ML_Syntax.E_PURE, - FStar_Extraction_ML_Syntax.MLTY_Erased) -> - (FStar_Extraction_ML_Syntax.ml_unit, - FStar_Extraction_ML_Syntax.E_PURE) - | uu___ -> (ml_e, tag) -type lb_sig = - (FStar_Syntax_Syntax.lbname * FStar_Extraction_ML_Syntax.e_tag * - (FStar_Syntax_Syntax.typ * (FStar_Syntax_Syntax.binders * - FStar_Extraction_ML_Syntax.mltyscheme)) * Prims.bool * Prims.bool * - FStar_Syntax_Syntax.term) -let rec (extract_lb_sig : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.letbindings -> lb_sig Prims.list) - = - fun g -> - fun lbs -> - let maybe_generalize uu___ = - match uu___ with - | { FStar_Syntax_Syntax.lbname = lbname_; - FStar_Syntax_Syntax.lbunivs = uu___1; - FStar_Syntax_Syntax.lbtyp = lbtyp; - FStar_Syntax_Syntax.lbeff = lbeff; - FStar_Syntax_Syntax.lbdef = lbdef; - FStar_Syntax_Syntax.lbattrs = lbattrs; - FStar_Syntax_Syntax.lbpos = uu___2;_} -> - let has_c_inline = - FStar_Syntax_Util.has_attribute lbattrs - FStar_Parser_Const.c_inline_attr in - let f_e = effect_as_etag g lbeff in - let lbtyp1 = FStar_Syntax_Subst.compress lbtyp in - let no_gen uu___3 = - let expected_t = term_as_mlty g lbtyp1 in - (lbname_, f_e, (lbtyp1, ([], ([], expected_t))), false, - has_c_inline, lbdef) in - let uu___3 = - let uu___4 = FStar_Extraction_ML_UEnv.tcenv_of_uenv g in - FStar_TypeChecker_Util.must_erase_for_extraction uu___4 lbtyp1 in - if uu___3 - then - (lbname_, f_e, - (lbtyp1, ([], ([], FStar_Extraction_ML_Syntax.MLTY_Erased))), - false, has_c_inline, lbdef) - else - (match lbtyp1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; - FStar_Syntax_Syntax.comp = c;_} - when - let uu___5 = FStar_Compiler_List.hd bs in - is_type_binder g uu___5 -> - let uu___5 = FStar_Syntax_Subst.open_comp bs c in - (match uu___5 with - | (bs1, c1) -> - let etag_of_comp c2 = - effect_as_etag g - (FStar_Syntax_Util.comp_effect_name c2) in - let uu___6 = - let uu___7 = - FStar_Compiler_Util.prefix_until - (fun x -> - let uu___8 = is_type_binder g x in - Prims.op_Negation uu___8) bs1 in - match uu___7 with - | FStar_Pervasives_Native.None -> - let uu___8 = etag_of_comp c1 in - (bs1, uu___8, - (FStar_Syntax_Util.comp_result c1)) - | FStar_Pervasives_Native.Some (bs2, b, rest) -> - let uu___8 = - FStar_Syntax_Util.arrow (b :: rest) c1 in - (bs2, FStar_Extraction_ML_Syntax.E_PURE, - uu___8) in - (match uu___6 with - | (tbinders, eff_body, tbody) -> - let n_tbinders = - FStar_Compiler_List.length tbinders in - let lbdef1 = - let uu___7 = normalize_abs lbdef in - FStar_Syntax_Util.unmeta uu___7 in - let tbinders_as_ty_params env = - FStar_Compiler_List.map - (fun uu___7 -> - match uu___7 with - | { FStar_Syntax_Syntax.binder_bv = x; - FStar_Syntax_Syntax.binder_qual = - uu___8; - FStar_Syntax_Syntax.binder_positivity - = uu___9; - FStar_Syntax_Syntax.binder_attrs = - binder_attrs;_} - -> - let uu___10 = - let uu___11 = - FStar_Extraction_ML_UEnv.lookup_ty - env x in - uu___11.FStar_Extraction_ML_UEnv.ty_b_name in - let uu___11 = - FStar_Compiler_List.map - (fun attr -> - let uu___12 = - term_as_mlexpr g attr in - match uu___12 with - | (e, uu___13, uu___14) -> e) - binder_attrs in - { - FStar_Extraction_ML_Syntax.ty_param_name - = uu___10; - FStar_Extraction_ML_Syntax.ty_param_attrs - = uu___11 - }) in - (match lbdef1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs2; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = copt;_} - -> - let uu___7 = - FStar_Syntax_Subst.open_term bs2 body in - (match uu___7 with - | (bs3, body1) -> - if - n_tbinders <= - (FStar_Compiler_List.length bs3) - then - let uu___8 = - FStar_Compiler_Util.first_N - n_tbinders bs3 in - (match uu___8 with - | (targs, rest_args) -> - let expected_source_ty = - let s = - FStar_Compiler_List.map2 - (fun uu___9 -> - fun uu___10 -> - match (uu___9, - uu___10) - with - | ({ - FStar_Syntax_Syntax.binder_bv - = x; - FStar_Syntax_Syntax.binder_qual - = uu___11; - FStar_Syntax_Syntax.binder_positivity - = uu___12; - FStar_Syntax_Syntax.binder_attrs - = uu___13;_}, - { - FStar_Syntax_Syntax.binder_bv - = y; - FStar_Syntax_Syntax.binder_qual - = uu___14; - FStar_Syntax_Syntax.binder_positivity - = uu___15; - FStar_Syntax_Syntax.binder_attrs - = uu___16;_}) - -> - let uu___17 = - let uu___18 = - FStar_Syntax_Syntax.bv_to_name - y in - (x, uu___18) in - FStar_Syntax_Syntax.NT - uu___17) - tbinders targs in - FStar_Syntax_Subst.subst s - tbody in - let env = - FStar_Compiler_List.fold_left - (fun env1 -> - fun uu___9 -> - match uu___9 with - | { - FStar_Syntax_Syntax.binder_bv - = a; - FStar_Syntax_Syntax.binder_qual - = uu___10; - FStar_Syntax_Syntax.binder_positivity - = uu___11; - FStar_Syntax_Syntax.binder_attrs - = uu___12;_} - -> - FStar_Extraction_ML_UEnv.extend_ty - env1 a false) g - targs in - let expected_t = - term_as_mlty env - expected_source_ty in - let polytype = - let uu___9 = - tbinders_as_ty_params env - targs in - (uu___9, expected_t) in - let add_unit = - match rest_args with - | [] -> - (let uu___9 = - is_fstar_value body1 in - Prims.op_Negation uu___9) - || - (let uu___9 = - FStar_Syntax_Util.is_pure_comp - c1 in - Prims.op_Negation - uu___9) - | uu___9 -> false in - let rest_args1 = - if add_unit - then - let uu___9 = unit_binder () in - uu___9 :: rest_args - else rest_args in - let polytype1 = - if add_unit - then - FStar_Extraction_ML_Syntax.push_unit - eff_body polytype - else polytype in - let body2 = - FStar_Syntax_Util.abs - rest_args1 body1 copt in - (lbname_, f_e, - (lbtyp1, (targs, polytype1)), - add_unit, has_c_inline, - body2)) - else - failwith "Not enough type binders") - | FStar_Syntax_Syntax.Tm_uinst uu___7 -> - let env = - FStar_Compiler_List.fold_left - (fun env1 -> - fun uu___8 -> - match uu___8 with - | { - FStar_Syntax_Syntax.binder_bv - = a; - FStar_Syntax_Syntax.binder_qual - = uu___9; - FStar_Syntax_Syntax.binder_positivity - = uu___10; - FStar_Syntax_Syntax.binder_attrs - = uu___11;_} - -> - FStar_Extraction_ML_UEnv.extend_ty - env1 a false) g tbinders in - let expected_t = term_as_mlty env tbody in - let polytype = - let uu___8 = - tbinders_as_ty_params env tbinders in - (uu___8, expected_t) in - let args = - FStar_Compiler_List.map - (fun uu___8 -> - match uu___8 with - | { - FStar_Syntax_Syntax.binder_bv = - bv; - FStar_Syntax_Syntax.binder_qual - = uu___9; - FStar_Syntax_Syntax.binder_positivity - = uu___10; - FStar_Syntax_Syntax.binder_attrs - = uu___11;_} - -> - let uu___12 = - FStar_Syntax_Syntax.bv_to_name - bv in - FStar_Syntax_Syntax.as_arg - uu___12) tbinders in - let e = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = lbdef1; - FStar_Syntax_Syntax.args = args - }) lbdef1.FStar_Syntax_Syntax.pos in - (lbname_, f_e, - (lbtyp1, (tbinders, polytype)), false, - has_c_inline, e) - | FStar_Syntax_Syntax.Tm_fvar uu___7 -> - let env = - FStar_Compiler_List.fold_left - (fun env1 -> - fun uu___8 -> - match uu___8 with - | { - FStar_Syntax_Syntax.binder_bv - = a; - FStar_Syntax_Syntax.binder_qual - = uu___9; - FStar_Syntax_Syntax.binder_positivity - = uu___10; - FStar_Syntax_Syntax.binder_attrs - = uu___11;_} - -> - FStar_Extraction_ML_UEnv.extend_ty - env1 a false) g tbinders in - let expected_t = term_as_mlty env tbody in - let polytype = - let uu___8 = - tbinders_as_ty_params env tbinders in - (uu___8, expected_t) in - let args = - FStar_Compiler_List.map - (fun uu___8 -> - match uu___8 with - | { - FStar_Syntax_Syntax.binder_bv = - bv; - FStar_Syntax_Syntax.binder_qual - = uu___9; - FStar_Syntax_Syntax.binder_positivity - = uu___10; - FStar_Syntax_Syntax.binder_attrs - = uu___11;_} - -> - let uu___12 = - FStar_Syntax_Syntax.bv_to_name - bv in - FStar_Syntax_Syntax.as_arg - uu___12) tbinders in - let e = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = lbdef1; - FStar_Syntax_Syntax.args = args - }) lbdef1.FStar_Syntax_Syntax.pos in - (lbname_, f_e, - (lbtyp1, (tbinders, polytype)), false, - has_c_inline, e) - | FStar_Syntax_Syntax.Tm_name uu___7 -> - let env = - FStar_Compiler_List.fold_left - (fun env1 -> - fun uu___8 -> - match uu___8 with - | { - FStar_Syntax_Syntax.binder_bv - = a; - FStar_Syntax_Syntax.binder_qual - = uu___9; - FStar_Syntax_Syntax.binder_positivity - = uu___10; - FStar_Syntax_Syntax.binder_attrs - = uu___11;_} - -> - FStar_Extraction_ML_UEnv.extend_ty - env1 a false) g tbinders in - let expected_t = term_as_mlty env tbody in - let polytype = - let uu___8 = - tbinders_as_ty_params env tbinders in - (uu___8, expected_t) in - let args = - FStar_Compiler_List.map - (fun uu___8 -> - match uu___8 with - | { - FStar_Syntax_Syntax.binder_bv = - bv; - FStar_Syntax_Syntax.binder_qual - = uu___9; - FStar_Syntax_Syntax.binder_positivity - = uu___10; - FStar_Syntax_Syntax.binder_attrs - = uu___11;_} - -> - let uu___12 = - FStar_Syntax_Syntax.bv_to_name - bv in - FStar_Syntax_Syntax.as_arg - uu___12) tbinders in - let e = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = lbdef1; - FStar_Syntax_Syntax.args = args - }) lbdef1.FStar_Syntax_Syntax.pos in - (lbname_, f_e, - (lbtyp1, (tbinders, polytype)), false, - has_c_inline, e) - | uu___7 -> err_value_restriction lbdef1))) - | uu___5 -> no_gen ()) in - FStar_Compiler_List.map maybe_generalize - (FStar_Pervasives_Native.snd lbs) -and (extract_lb_iface : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.letbindings -> - (FStar_Extraction_ML_UEnv.uenv * (FStar_Syntax_Syntax.fv * - FStar_Extraction_ML_UEnv.exp_binding) Prims.list)) - = - fun g -> - fun lbs -> - let is_top = - FStar_Syntax_Syntax.is_top_level (FStar_Pervasives_Native.snd lbs) in - let is_rec = - (Prims.op_Negation is_top) && (FStar_Pervasives_Native.fst lbs) in - let lbs1 = extract_lb_sig g lbs in - FStar_Compiler_Util.fold_map - (fun env -> - fun uu___ -> - match uu___ with - | (lbname, _e_tag, (typ, (_binders, mltyscheme)), add_unit, - _has_c_inline, _body) -> - let uu___1 = - FStar_Extraction_ML_UEnv.extend_lb env lbname typ - mltyscheme add_unit in - (match uu___1 with - | (env1, uu___2, exp_binding) -> - let uu___3 = - let uu___4 = FStar_Compiler_Util.right lbname in - (uu___4, exp_binding) in - (env1, uu___3))) g lbs1 -and (check_term_as_mlexpr : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.term -> - FStar_Extraction_ML_Syntax.e_tag -> - FStar_Extraction_ML_Syntax.mlty -> - (FStar_Extraction_ML_Syntax.mlexpr * - FStar_Extraction_ML_Syntax.mlty)) - = - fun g -> - fun e -> - fun f -> - fun ty -> - FStar_Extraction_ML_UEnv.debug g - (fun uu___1 -> - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - let uu___3 = - let uu___4 = - FStar_Extraction_ML_UEnv.current_module_of_uenv g in - FStar_Extraction_ML_Code.string_of_mlty uu___4 ty in - let uu___4 = FStar_Extraction_ML_Util.eff_to_string f in - FStar_Compiler_Util.print3 - "Checking %s at type %s and eff %s\n" uu___2 uu___3 uu___4); - (match (f, ty) with - | (FStar_Extraction_ML_Syntax.E_ERASABLE, uu___1) -> - (FStar_Extraction_ML_Syntax.ml_unit, - FStar_Extraction_ML_Syntax.MLTY_Erased) - | (FStar_Extraction_ML_Syntax.E_PURE, - FStar_Extraction_ML_Syntax.MLTY_Erased) -> - (FStar_Extraction_ML_Syntax.ml_unit, - FStar_Extraction_ML_Syntax.MLTY_Erased) - | uu___1 -> - let uu___2 = term_as_mlexpr g e in - (match uu___2 with - | (ml_e, tag, t) -> - (FStar_Extraction_ML_UEnv.debug g - (fun uu___4 -> - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term e in - let uu___6 = - let uu___7 = - FStar_Extraction_ML_UEnv.current_module_of_uenv - g in - FStar_Extraction_ML_Code.string_of_mlexpr uu___7 - ml_e in - let uu___7 = - FStar_Extraction_ML_Util.eff_to_string tag in - let uu___8 = - let uu___9 = - FStar_Extraction_ML_UEnv.current_module_of_uenv - g in - FStar_Extraction_ML_Code.string_of_mlty uu___9 t in - FStar_Compiler_Util.print4 - "Extracted %s to %s at eff %s and type %s\n" - uu___5 uu___6 uu___7 uu___8); - (let uu___4 = FStar_Extraction_ML_Util.eff_leq tag f in - if uu___4 - then - let uu___5 = - maybe_coerce e.FStar_Syntax_Syntax.pos g ml_e t ty in - (uu___5, ty) - else - (match (tag, f, ty) with - | (FStar_Extraction_ML_Syntax.E_ERASABLE, - FStar_Extraction_ML_Syntax.E_PURE, - FStar_Extraction_ML_Syntax.MLTY_Erased) -> - let uu___6 = - maybe_coerce e.FStar_Syntax_Syntax.pos g ml_e - t ty in - (uu___6, ty) - | uu___6 -> - (err_unexpected_eff g e ty f tag; - (let uu___8 = - maybe_coerce e.FStar_Syntax_Syntax.pos g - ml_e t ty in - (uu___8, ty)))))))) -and (term_as_mlexpr : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.term -> - (FStar_Extraction_ML_Syntax.mlexpr * FStar_Extraction_ML_Syntax.e_tag * - FStar_Extraction_ML_Syntax.mlty)) - = - fun g -> - fun e -> - let uu___ = term_as_mlexpr' g e in - match uu___ with - | (e1, f, t) -> - let uu___1 = maybe_promote_effect e1 f t in - (match uu___1 with | (e2, f1) -> (e2, f1, t)) -and (term_as_mlexpr' : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Syntax_Syntax.term -> - (FStar_Extraction_ML_Syntax.mlexpr * FStar_Extraction_ML_Syntax.e_tag * - FStar_Extraction_ML_Syntax.mlty)) - = - fun g -> - fun top -> - let top1 = FStar_Syntax_Subst.compress top in - FStar_Extraction_ML_UEnv.debug g - (fun u -> - let uu___1 = - let uu___2 = - FStar_Compiler_Range_Ops.string_of_range - top1.FStar_Syntax_Syntax.pos in - let uu___3 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term top1 in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term top1 in - FStar_Compiler_Util.format3 "%s: term_as_mlexpr' (%s) : %s \n" - uu___2 uu___3 uu___4 in - FStar_Compiler_Util.print_string uu___1); - (let is_match t = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress t in - FStar_Syntax_Util.unascribe uu___3 in - uu___2.FStar_Syntax_Syntax.n in - match uu___1 with - | FStar_Syntax_Syntax.Tm_match uu___2 -> true - | uu___2 -> false in - let should_apply_to_match_branches = - FStar_Compiler_List.for_all - (fun uu___1 -> - match uu___1 with - | (t, uu___2) -> - let uu___3 = - let uu___4 = FStar_Syntax_Subst.compress t in - uu___4.FStar_Syntax_Syntax.n in - (match uu___3 with - | FStar_Syntax_Syntax.Tm_name uu___4 -> true - | FStar_Syntax_Syntax.Tm_fvar uu___4 -> true - | FStar_Syntax_Syntax.Tm_constant uu___4 -> true - | uu___4 -> false)) in - let apply_to_match_branches head args = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress head in - FStar_Syntax_Util.unascribe uu___3 in - uu___2.FStar_Syntax_Syntax.n in - match uu___1 with - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = scrutinee; - FStar_Syntax_Syntax.ret_opt = uu___2; - FStar_Syntax_Syntax.brs = branches; - FStar_Syntax_Syntax.rc_opt1 = uu___3;_} - -> - let branches1 = - FStar_Compiler_List.map - (fun uu___4 -> - match uu___4 with - | (pat, when_opt, body) -> - (pat, when_opt, - { - FStar_Syntax_Syntax.n = - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = body; - FStar_Syntax_Syntax.args = args - }); - FStar_Syntax_Syntax.pos = - (body.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = - (body.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (body.FStar_Syntax_Syntax.hash_code) - })) branches in - { - FStar_Syntax_Syntax.n = - (FStar_Syntax_Syntax.Tm_match - { - FStar_Syntax_Syntax.scrutinee = scrutinee; - FStar_Syntax_Syntax.ret_opt = - FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.brs = branches1; - FStar_Syntax_Syntax.rc_opt1 = - FStar_Pervasives_Native.None - }); - FStar_Syntax_Syntax.pos = (head.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = (head.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (head.FStar_Syntax_Syntax.hash_code) - } - | uu___2 -> - failwith - "Impossible! cannot apply args to match branches if head is not a match" in - let t = FStar_Syntax_Subst.compress top1 in - match t.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_unknown -> - let uu___1 = - let uu___2 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t in - FStar_Compiler_Util.format1 "Impossible: Unexpected term: %s" - uu___2 in - failwith uu___1 - | FStar_Syntax_Syntax.Tm_delayed uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t in - FStar_Compiler_Util.format1 "Impossible: Unexpected term: %s" - uu___3 in - failwith uu___2 - | FStar_Syntax_Syntax.Tm_uvar uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t in - FStar_Compiler_Util.format1 "Impossible: Unexpected term: %s" - uu___3 in - failwith uu___2 - | FStar_Syntax_Syntax.Tm_bvar uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t in - FStar_Compiler_Util.format1 "Impossible: Unexpected term: %s" - uu___3 in - failwith uu___2 - | FStar_Syntax_Syntax.Tm_lazy i -> - let uu___1 = FStar_Syntax_Util.unfold_lazy i in - term_as_mlexpr g uu___1 - | FStar_Syntax_Syntax.Tm_type uu___1 -> - (FStar_Extraction_ML_Syntax.ml_unit, - FStar_Extraction_ML_Syntax.E_PURE, - FStar_Extraction_ML_Syntax.ml_unit_ty) - | FStar_Syntax_Syntax.Tm_refine uu___1 -> - (FStar_Extraction_ML_Syntax.ml_unit, - FStar_Extraction_ML_Syntax.E_PURE, - FStar_Extraction_ML_Syntax.ml_unit_ty) - | FStar_Syntax_Syntax.Tm_arrow uu___1 -> - (FStar_Extraction_ML_Syntax.ml_unit, - FStar_Extraction_ML_Syntax.E_PURE, - FStar_Extraction_ML_Syntax.ml_unit_ty) - | FStar_Syntax_Syntax.Tm_quoted - (qt, - { FStar_Syntax_Syntax.qkind = FStar_Syntax_Syntax.Quote_dynamic; - FStar_Syntax_Syntax.antiquotations = uu___1;_}) - -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_Parser_Const.failwith_lid () in - FStar_Syntax_Syntax.lid_as_fv uu___4 - FStar_Pervasives_Native.None in - FStar_Extraction_ML_UEnv.lookup_fv t.FStar_Syntax_Syntax.pos g - uu___3 in - (match uu___2 with - | { FStar_Extraction_ML_UEnv.exp_b_name = uu___3; - FStar_Extraction_ML_UEnv.exp_b_expr = fw; - FStar_Extraction_ML_UEnv.exp_b_tscheme = uu___4; - FStar_Extraction_ML_UEnv.exp_b_eff = uu___5;_} -> - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.ml_string_ty - (FStar_Extraction_ML_Syntax.MLE_Const - (FStar_Extraction_ML_Syntax.MLC_String - "Cannot evaluate open quotation at runtime")) in - [uu___10] in - (fw, uu___9) in - FStar_Extraction_ML_Syntax.MLE_App uu___8 in - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.ml_int_ty uu___7 in - (uu___6, FStar_Extraction_ML_Syntax.E_PURE, - FStar_Extraction_ML_Syntax.ml_int_ty)) - | FStar_Syntax_Syntax.Tm_quoted - (qt, - { FStar_Syntax_Syntax.qkind = FStar_Syntax_Syntax.Quote_static; - FStar_Syntax_Syntax.antiquotations = (shift, aqs);_}) - -> - let uu___1 = FStar_Reflection_V2_Builtins.inspect_ln qt in - (match uu___1 with - | FStar_Reflection_V2_Data.Tv_BVar bv -> - if bv.FStar_Syntax_Syntax.index < shift - then - let tv' = FStar_Reflection_V2_Data.Tv_BVar bv in - let tv = - let uu___2 = - FStar_Syntax_Embeddings_Base.embed - FStar_Reflection_V2_Embeddings.e_term_view tv' in - uu___2 t.FStar_Syntax_Syntax.pos - FStar_Pervasives_Native.None - FStar_Syntax_Embeddings_Base.id_norm_cb in - let t1 = - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.as_arg tv in [uu___3] in - FStar_Syntax_Util.mk_app - (FStar_Reflection_V2_Constants.refl_constant_term - FStar_Reflection_V2_Constants.fstar_refl_pack_ln) - uu___2 in - term_as_mlexpr g t1 - else - (let tm = FStar_Syntax_Syntax.lookup_aq bv (shift, aqs) in - term_as_mlexpr g tm) - | tv -> - let tv1 = - let uu___2 = - let uu___3 = - FStar_Reflection_V2_Embeddings.e_term_view_aq - (shift, aqs) in - FStar_Syntax_Embeddings_Base.embed uu___3 tv in - uu___2 t.FStar_Syntax_Syntax.pos - FStar_Pervasives_Native.None - FStar_Syntax_Embeddings_Base.id_norm_cb in - let t1 = - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.as_arg tv1 in [uu___3] in - FStar_Syntax_Util.mk_app - (FStar_Reflection_V2_Constants.refl_constant_term - FStar_Reflection_V2_Constants.fstar_refl_pack_ln) - uu___2 in - term_as_mlexpr g t1) - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t1; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_monadic - (m, uu___1);_} - -> - let t2 = FStar_Syntax_Subst.compress t1 in - (match t2.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (false, lb::[]); - FStar_Syntax_Syntax.body1 = body;_} - when - FStar_Compiler_Util.is_left lb.FStar_Syntax_Syntax.lbname -> - let tcenv = FStar_Extraction_ML_UEnv.tcenv_of_uenv g in - let uu___2 = - let uu___3 = FStar_TypeChecker_Env.effect_decl_opt tcenv m in - FStar_Compiler_Util.must uu___3 in - (match uu___2 with - | (ed, qualifiers) -> - let uu___3 = - let uu___4 = - FStar_TypeChecker_Util.effect_extraction_mode tcenv - ed.FStar_Syntax_Syntax.mname in - uu___4 = FStar_Syntax_Syntax.Extract_primitive in - if uu___3 - then term_as_mlexpr g t2 - else - (let uu___5 = - let uu___6 = - FStar_Ident.string_of_lid - ed.FStar_Syntax_Syntax.mname in - FStar_Compiler_Util.format1 - "This should not happen (should have been handled at Tm_abs level for effect %s)" - uu___6 in - failwith uu___5)) - | uu___2 -> term_as_mlexpr g t2) - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t1; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_monadic_lift - (m1, _m2, _ty);_} - when - let uu___1 = effect_as_etag g m1 in - uu___1 = FStar_Extraction_ML_Syntax.E_ERASABLE -> - (FStar_Extraction_ML_Syntax.ml_unit, - FStar_Extraction_ML_Syntax.E_ERASABLE, - FStar_Extraction_ML_Syntax.MLTY_Erased) - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t1; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_desugared - (FStar_Syntax_Syntax.Machine_integer (signedness, width));_} - -> - let t2 = FStar_Syntax_Subst.compress t1 in - let t3 = FStar_Syntax_Util.unascribe t2 in - (match t3.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = hd; - FStar_Syntax_Syntax.args = (x, uu___1)::[];_} - -> - let x1 = FStar_Syntax_Subst.compress x in - let x2 = FStar_Syntax_Util.unascribe x1 in - (match x2.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_int - (repr, uu___2)) -> - let uu___3 = - let uu___4 = FStar_Extraction_ML_UEnv.tcenv_of_uenv g in - FStar_TypeChecker_TcTerm.typeof_tot_or_gtot_term - uu___4 t3 true in - (match uu___3 with - | (uu___4, ty, uu___5) -> - let ml_ty = term_as_mlty g ty in - let ml_const = - FStar_Const.Const_int - (repr, - (FStar_Pervasives_Native.Some - (signedness, width))) in - let uu___6 = - let uu___7 = - FStar_Extraction_ML_Util.mlexpr_of_const - t3.FStar_Syntax_Syntax.pos ml_const in - FStar_Extraction_ML_Syntax.with_ty ml_ty uu___7 in - (uu___6, FStar_Extraction_ML_Syntax.E_PURE, ml_ty)) - | uu___2 -> term_as_mlexpr g t3) - | uu___1 -> term_as_mlexpr g t3) - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t1; - FStar_Syntax_Syntax.meta = uu___1;_} - -> term_as_mlexpr g t1 - | FStar_Syntax_Syntax.Tm_uinst (t1, uu___1) -> term_as_mlexpr g t1 - | FStar_Syntax_Syntax.Tm_constant c -> - let tcenv = FStar_Extraction_ML_UEnv.tcenv_of_uenv g in - let uu___1 = - FStar_TypeChecker_TcTerm.typeof_tot_or_gtot_term tcenv t true in - (match uu___1 with - | (uu___2, ty, uu___3) -> - let uu___4 = - FStar_TypeChecker_Util.must_erase_for_extraction tcenv ty in - if uu___4 - then - (FStar_Extraction_ML_Syntax.ml_unit, - FStar_Extraction_ML_Syntax.E_PURE, - FStar_Extraction_ML_Syntax.MLTY_Erased) - else - (let ml_ty = term_as_mlty g ty in - let uu___6 = - let uu___7 = - FStar_Extraction_ML_Util.mlexpr_of_const - t.FStar_Syntax_Syntax.pos c in - FStar_Extraction_ML_Syntax.with_ty ml_ty uu___7 in - (uu___6, FStar_Extraction_ML_Syntax.E_PURE, ml_ty))) - | FStar_Syntax_Syntax.Tm_name uu___1 -> - let uu___2 = is_type g t in - if uu___2 - then - (FStar_Extraction_ML_Syntax.ml_unit, - FStar_Extraction_ML_Syntax.E_PURE, - FStar_Extraction_ML_Syntax.ml_unit_ty) - else - (let uu___4 = FStar_Extraction_ML_UEnv.lookup_term g t in - match uu___4 with - | (FStar_Pervasives.Inl uu___5, uu___6) -> - (FStar_Extraction_ML_Syntax.ml_unit, - FStar_Extraction_ML_Syntax.E_PURE, - FStar_Extraction_ML_Syntax.ml_unit_ty) - | (FStar_Pervasives.Inr - { FStar_Extraction_ML_UEnv.exp_b_name = uu___5; - FStar_Extraction_ML_UEnv.exp_b_expr = x; - FStar_Extraction_ML_UEnv.exp_b_tscheme = mltys; - FStar_Extraction_ML_UEnv.exp_b_eff = etag;_}, - qual) -> - (match mltys with - | ([], t1) when t1 = FStar_Extraction_ML_Syntax.ml_unit_ty - -> (FStar_Extraction_ML_Syntax.ml_unit, etag, t1) - | ([], t1) -> - let uu___6 = - maybe_eta_data_and_project_record g qual t1 x in - (uu___6, etag, t1) - | uu___6 -> instantiate_maybe_partial g x etag mltys [])) - | FStar_Syntax_Syntax.Tm_fvar fv -> - let uu___1 = is_type g t in - if uu___1 - then - (FStar_Extraction_ML_Syntax.ml_unit, - FStar_Extraction_ML_Syntax.E_PURE, - FStar_Extraction_ML_Syntax.ml_unit_ty) - else - (let uu___3 = - FStar_Extraction_ML_UEnv.try_lookup_fv - t.FStar_Syntax_Syntax.pos g fv in - match uu___3 with - | FStar_Pervasives_Native.None -> - (FStar_Extraction_ML_Syntax.ml_unit, - FStar_Extraction_ML_Syntax.E_PURE, - FStar_Extraction_ML_Syntax.MLTY_Erased) - | FStar_Pervasives_Native.Some - { FStar_Extraction_ML_UEnv.exp_b_name = uu___4; - FStar_Extraction_ML_UEnv.exp_b_expr = x; - FStar_Extraction_ML_UEnv.exp_b_tscheme = mltys; - FStar_Extraction_ML_UEnv.exp_b_eff = uu___5;_} - -> - (FStar_Extraction_ML_UEnv.debug g - (fun uu___7 -> - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_fv fv in - let uu___9 = - FStar_Class_Show.show - FStar_Extraction_ML_Code.showable_mlexpr x in - let uu___10 = - FStar_Class_Show.show - FStar_Extraction_ML_Code.showable_mlty - (FStar_Pervasives_Native.snd mltys) in - FStar_Compiler_Util.print3 - "looked up %s: got %s at %s \n" uu___8 uu___9 - uu___10); - (match mltys with - | ([], t1) when - t1 = FStar_Extraction_ML_Syntax.ml_unit_ty -> - (FStar_Extraction_ML_Syntax.ml_unit, - FStar_Extraction_ML_Syntax.E_PURE, t1) - | ([], t1) -> - let uu___7 = - maybe_eta_data_and_project_record g - fv.FStar_Syntax_Syntax.fv_qual t1 x in - (uu___7, FStar_Extraction_ML_Syntax.E_PURE, t1) - | uu___7 -> - instantiate_maybe_partial g x - FStar_Extraction_ML_Syntax.E_PURE mltys []))) - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs; FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = rcopt;_} - -> - let uu___1 = FStar_Syntax_Subst.open_term bs body in - (match uu___1 with - | (bs1, body1) -> - let uu___2 = binders_as_ml_binders g bs1 in - (match uu___2 with - | (ml_bs, env) -> - let ml_bs1 = - FStar_Compiler_List.map2 - (fun uu___3 -> - fun b -> - match uu___3 with - | (x, t1) -> - let uu___4 = - FStar_Compiler_List.map - (fun attr -> - let uu___5 = term_as_mlexpr env attr in - match uu___5 with - | (e, uu___6, uu___7) -> e) - b.FStar_Syntax_Syntax.binder_attrs in - { - FStar_Extraction_ML_Syntax.mlbinder_name - = x; - FStar_Extraction_ML_Syntax.mlbinder_ty = - t1; - FStar_Extraction_ML_Syntax.mlbinder_attrs - = uu___4 - }) ml_bs bs1 in - let body2 = - match rcopt with - | FStar_Pervasives_Native.Some rc -> - let uu___3 = - FStar_Extraction_ML_UEnv.tcenv_of_uenv env in - maybe_reify_term uu___3 body1 - rc.FStar_Syntax_Syntax.residual_effect - | FStar_Pervasives_Native.None -> - (FStar_Extraction_ML_UEnv.debug g - (fun uu___4 -> - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term body1 in - FStar_Compiler_Util.print1 - "No computation type for: %s\n" uu___5); - body1) in - let uu___3 = term_as_mlexpr env body2 in - (match uu___3 with - | (ml_body, f, t1) -> - let uu___4 = - FStar_Compiler_List.fold_right - (fun uu___5 -> - fun uu___6 -> - match (uu___5, uu___6) with - | ({ - FStar_Extraction_ML_Syntax.mlbinder_name - = uu___7; - FStar_Extraction_ML_Syntax.mlbinder_ty - = targ; - FStar_Extraction_ML_Syntax.mlbinder_attrs - = uu___8;_}, - (f1, t2)) -> - (FStar_Extraction_ML_Syntax.E_PURE, - (FStar_Extraction_ML_Syntax.MLTY_Fun - (targ, f1, t2)))) ml_bs1 - (f, t1) in - (match uu___4 with - | (f1, tfun) -> - let uu___5 = - FStar_Extraction_ML_Syntax.with_ty tfun - (FStar_Extraction_ML_Syntax.MLE_Fun - (ml_bs1, ml_body)) in - (uu___5, f1, tfun))))) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_range_of); - FStar_Syntax_Syntax.pos = uu___1; - FStar_Syntax_Syntax.vars = uu___2; - FStar_Syntax_Syntax.hash_code = uu___3;_}; - FStar_Syntax_Syntax.args = (a1, uu___4)::[];_} - -> - let ty = - let uu___5 = - FStar_Syntax_Syntax.tabbrev FStar_Parser_Const.range_lid in - term_as_mlty g uu___5 in - let uu___5 = - let uu___6 = - FStar_Extraction_ML_Util.mlexpr_of_range - a1.FStar_Syntax_Syntax.pos in - FStar_Extraction_ML_Syntax.with_ty ty uu___6 in - (uu___5, FStar_Extraction_ML_Syntax.E_PURE, ty) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_set_range_of); - FStar_Syntax_Syntax.pos = uu___1; - FStar_Syntax_Syntax.vars = uu___2; - FStar_Syntax_Syntax.hash_code = uu___3;_}; - FStar_Syntax_Syntax.args = (t1, uu___4)::(r, uu___5)::[];_} - -> term_as_mlexpr g t1 - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_reflect uu___1); - FStar_Syntax_Syntax.pos = uu___2; - FStar_Syntax_Syntax.vars = uu___3; - FStar_Syntax_Syntax.hash_code = uu___4;_}; - FStar_Syntax_Syntax.args = uu___5;_} - -> - let uu___6 = - let uu___7 = - let uu___8 = FStar_Parser_Const.failwith_lid () in - FStar_Syntax_Syntax.lid_as_fv uu___8 - FStar_Pervasives_Native.None in - FStar_Extraction_ML_UEnv.lookup_fv t.FStar_Syntax_Syntax.pos g - uu___7 in - (match uu___6 with - | { FStar_Extraction_ML_UEnv.exp_b_name = uu___7; - FStar_Extraction_ML_UEnv.exp_b_expr = fw; - FStar_Extraction_ML_UEnv.exp_b_tscheme = uu___8; - FStar_Extraction_ML_UEnv.exp_b_eff = uu___9;_} -> - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.ml_string_ty - (FStar_Extraction_ML_Syntax.MLE_Const - (FStar_Extraction_ML_Syntax.MLC_String - "Extraction of reflect is not supported")) in - [uu___14] in - (fw, uu___13) in - FStar_Extraction_ML_Syntax.MLE_App uu___12 in - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.ml_int_ty uu___11 in - (uu___10, FStar_Extraction_ML_Syntax.E_PURE, - FStar_Extraction_ML_Syntax.ml_int_ty)) - | FStar_Syntax_Syntax.Tm_app uu___1 when is_steel_with_invariant_g t - -> - (FStar_Extraction_ML_Syntax.ml_unit, - FStar_Extraction_ML_Syntax.E_PURE, - FStar_Extraction_ML_Syntax.MLTY_Erased) - | FStar_Syntax_Syntax.Tm_app uu___1 when - let uu___2 = is_steel_with_invariant t in - FStar_Pervasives_Native.uu___is_Some uu___2 -> - let body = - let uu___2 = is_steel_with_invariant t in - FStar_Pervasives_Native.__proj__Some__item__v uu___2 in - let tm = - let uu___2 = - let uu___3 = - FStar_Syntax_Syntax.as_arg FStar_Syntax_Syntax.unit_const in - [uu___3] in - FStar_Syntax_Syntax.mk_Tm_app body uu___2 - body.FStar_Syntax_Syntax.pos in - term_as_mlexpr g tm - | FStar_Syntax_Syntax.Tm_app uu___1 when is_steel_new_invariant t -> - (FStar_Extraction_ML_Syntax.ml_unit, - FStar_Extraction_ML_Syntax.E_PURE, - FStar_Extraction_ML_Syntax.ml_unit_ty) - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = args;_} - when (is_match head) && (should_apply_to_match_branches args) -> - let uu___1 = apply_to_match_branches head args in - term_as_mlexpr g uu___1 - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = args;_} - -> - let is_total rc = - (FStar_Ident.lid_equals rc.FStar_Syntax_Syntax.residual_effect - FStar_Parser_Const.effect_Tot_lid) - || - (FStar_Compiler_List.existsb - (fun uu___1 -> - match uu___1 with - | FStar_Syntax_Syntax.TOTAL -> true - | uu___2 -> false) rc.FStar_Syntax_Syntax.residual_flags) in - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress head in - FStar_Syntax_Util.unascribe uu___3 in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs; - FStar_Syntax_Syntax.body = uu___2; - FStar_Syntax_Syntax.rc_opt = rc;_} - -> - let uu___3 = - let uu___4 = FStar_Extraction_ML_UEnv.tcenv_of_uenv g in - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Iota; - FStar_TypeChecker_Env.Zeta; - FStar_TypeChecker_Env.EraseUniverses; - FStar_TypeChecker_Env.AllowUnboundUniverses; - FStar_TypeChecker_Env.ForExtraction] uu___4 t in - term_as_mlexpr g uu___3 - | FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_reify lopt) - -> - (match lopt with - | FStar_Pervasives_Native.Some l -> - let e = - let uu___2 = FStar_Extraction_ML_UEnv.tcenv_of_uenv g in - let uu___3 = - let uu___4 = FStar_Compiler_List.hd args in - FStar_Pervasives_Native.fst uu___4 in - maybe_reify_term uu___2 uu___3 l in - let tm = - let uu___2 = FStar_TypeChecker_Util.remove_reify e in - let uu___3 = FStar_Compiler_List.tl args in - FStar_Syntax_Syntax.mk_Tm_app uu___2 uu___3 - t.FStar_Syntax_Syntax.pos in - term_as_mlexpr g tm - | FStar_Pervasives_Native.None -> - let uu___2 = - let uu___3 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term top1 in - FStar_Compiler_Util.format1 - "Cannot extract %s (reify effect is not set)" uu___3 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) top1 - FStar_Errors_Codes.Fatal_ExtractionUnsupported () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)) - | uu___2 -> - let rec extract_app is_data uu___3 uu___4 restArgs = - match (uu___3, uu___4) with - | ((mlhead, mlargs_f), (f, t1)) -> - let mk_head uu___5 = - let mlargs = - FStar_Compiler_List.map FStar_Pervasives_Native.fst - (FStar_Compiler_List.rev mlargs_f) in - FStar_Extraction_ML_Syntax.with_ty t1 - (FStar_Extraction_ML_Syntax.MLE_App - (mlhead, mlargs)) in - (FStar_Extraction_ML_UEnv.debug g - (fun uu___6 -> - let uu___7 = - let uu___8 = - FStar_Extraction_ML_UEnv.current_module_of_uenv - g in - let uu___9 = mk_head () in - FStar_Extraction_ML_Code.string_of_mlexpr - uu___8 uu___9 in - let uu___8 = - let uu___9 = - FStar_Extraction_ML_UEnv.current_module_of_uenv - g in - FStar_Extraction_ML_Code.string_of_mlty uu___9 - t1 in - let uu___9 = - match restArgs with - | [] -> "none" - | (hd, uu___10)::uu___11 -> - FStar_Class_Show.show - FStar_Syntax_Print.showable_term hd in - FStar_Compiler_Util.print3 - "extract_app ml_head=%s type of head = %s, next arg = %s\n" - uu___7 uu___8 uu___9); - (match (restArgs, t1) with - | ([], uu___6) -> - let app = - let uu___7 = mk_head () in - maybe_eta_data_and_project_record g is_data t1 - uu___7 in - (app, f, t1) - | ((arg, uu___6)::rest, - FStar_Extraction_ML_Syntax.MLTY_Fun - (formal_t, f', t2)) when - (is_type g arg) && - (type_leq g formal_t - FStar_Extraction_ML_Syntax.ml_unit_ty) - -> - let uu___7 = - let uu___8 = - FStar_Extraction_ML_Util.join - arg.FStar_Syntax_Syntax.pos f f' in - (uu___8, t2) in - extract_app is_data - (mlhead, - ((FStar_Extraction_ML_Syntax.ml_unit, - FStar_Extraction_ML_Syntax.E_PURE) :: - mlargs_f)) uu___7 rest - | ((e0, uu___6)::rest, - FStar_Extraction_ML_Syntax.MLTY_Fun - (tExpected, f', t2)) -> - let r = e0.FStar_Syntax_Syntax.pos in - let expected_effect = - let uu___7 = - (FStar_Options.lax ()) && - (FStar_TypeChecker_Util.short_circuit_head - head) in - if uu___7 - then FStar_Extraction_ML_Syntax.E_IMPURE - else FStar_Extraction_ML_Syntax.E_PURE in - let uu___7 = - check_term_as_mlexpr g e0 expected_effect - tExpected in - (match uu___7 with - | (e01, tInferred) -> - let uu___8 = - let uu___9 = - FStar_Extraction_ML_Util.join_l r - [f; f'] in - (uu___9, t2) in - extract_app is_data - (mlhead, ((e01, expected_effect) :: - mlargs_f)) uu___8 rest) - | uu___6 -> - let uu___7 = - FStar_Extraction_ML_Util.udelta_unfold g t1 in - (match uu___7 with - | FStar_Pervasives_Native.Some t2 -> - extract_app is_data (mlhead, mlargs_f) - (f, t2) restArgs - | FStar_Pervasives_Native.None -> - (match t1 with - | FStar_Extraction_ML_Syntax.MLTY_Erased -> - (FStar_Extraction_ML_Syntax.ml_unit, - FStar_Extraction_ML_Syntax.E_PURE, - t1) - | FStar_Extraction_ML_Syntax.MLTY_Top -> - let t2 = - FStar_Compiler_List.fold_right - (fun t3 -> - fun out -> - FStar_Extraction_ML_Syntax.MLTY_Fun - (FStar_Extraction_ML_Syntax.MLTY_Top, - FStar_Extraction_ML_Syntax.E_PURE, - out)) restArgs - FStar_Extraction_ML_Syntax.MLTY_Top in - let mlhead1 = - let mlargs = - FStar_Compiler_List.map - FStar_Pervasives_Native.fst - (FStar_Compiler_List.rev mlargs_f) in - let head1 = - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.MLTY_Top - (FStar_Extraction_ML_Syntax.MLE_App - (mlhead, mlargs)) in - maybe_coerce - top1.FStar_Syntax_Syntax.pos g - head1 - FStar_Extraction_ML_Syntax.MLTY_Top - t2 in - extract_app is_data (mlhead1, []) - (f, t2) restArgs - | uu___8 -> - let mlhead1 = - let mlargs = - FStar_Compiler_List.map - FStar_Pervasives_Native.fst - (FStar_Compiler_List.rev mlargs_f) in - let head1 = - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.MLTY_Top - (FStar_Extraction_ML_Syntax.MLE_App - (mlhead, mlargs)) in - maybe_coerce - top1.FStar_Syntax_Syntax.pos g - head1 - FStar_Extraction_ML_Syntax.MLTY_Top - t1 in - err_ill_typed_application g top1 - mlhead1 restArgs t1)))) in - let extract_app_maybe_projector is_data mlhead uu___3 args1 = - match uu___3 with - | (f, t1) -> - (match is_data with - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Record_projector uu___4) -> - let rec remove_implicits args2 f1 t2 = - match (args2, t2) with - | ((a0, FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = - uu___5;_})::args3, - FStar_Extraction_ML_Syntax.MLTY_Fun - (uu___6, f', t3)) -> - let uu___7 = - FStar_Extraction_ML_Util.join - a0.FStar_Syntax_Syntax.pos f1 f' in - remove_implicits args3 uu___7 t3 - | uu___5 -> (args2, f1, t2) in - let uu___5 = remove_implicits args1 f t1 in - (match uu___5 with - | (args2, f1, t2) -> - extract_app is_data (mlhead, []) (f1, t2) - args2) - | uu___4 -> - extract_app is_data (mlhead, []) (f, t1) args1) in - let extract_app_with_instantiations uu___3 = - let head1 = FStar_Syntax_Util.un_uinst head in - match head1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_name uu___4 -> - let uu___5 = - let uu___6 = - FStar_Extraction_ML_UEnv.lookup_term g head1 in - match uu___6 with - | (FStar_Pervasives.Inr exp_b, q) -> - (FStar_Extraction_ML_UEnv.debug g - (fun uu___8 -> - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head1 in - let uu___10 = - FStar_Class_Show.show - FStar_Extraction_ML_Code.showable_mlexpr - exp_b.FStar_Extraction_ML_UEnv.exp_b_expr in - let uu___11 = - FStar_Class_Show.show - FStar_Extraction_ML_Code.showable_mlty - (FStar_Pervasives_Native.snd - exp_b.FStar_Extraction_ML_UEnv.exp_b_tscheme) in - let uu___12 = - FStar_Class_Show.show - FStar_Extraction_ML_Code.showable_etag - exp_b.FStar_Extraction_ML_UEnv.exp_b_eff in - FStar_Compiler_Util.print4 - "@@@looked up %s: got %s at %s with eff <%s>\n" - uu___9 uu___10 uu___11 uu___12); - (((exp_b.FStar_Extraction_ML_UEnv.exp_b_expr), - (exp_b.FStar_Extraction_ML_UEnv.exp_b_tscheme), - (exp_b.FStar_Extraction_ML_UEnv.exp_b_eff)), - q)) - | uu___7 -> failwith "FIXME Ty" in - (match uu___5 with - | ((head_ml, (vars, t1), head_eff), qual) -> - let has_typ_apps = - match args with - | (a, uu___6)::uu___7 -> is_type g a - | uu___6 -> false in - let uu___6 = - let n = FStar_Compiler_List.length vars in - let uu___7 = - if (FStar_Compiler_List.length args) <= n - then - let uu___8 = - FStar_Compiler_List.map - (fun uu___9 -> - match uu___9 with - | (x, uu___10) -> term_as_mlty g x) - args in - (uu___8, []) - else - (let uu___9 = - FStar_Compiler_Util.first_N n args in - match uu___9 with - | (prefix, rest) -> - let uu___10 = - FStar_Compiler_List.map - (fun uu___11 -> - match uu___11 with - | (x, uu___12) -> - term_as_mlty g x) prefix in - (uu___10, rest)) in - match uu___7 with - | (provided_type_args, rest) -> - let uu___8 = - match head_ml.FStar_Extraction_ML_Syntax.expr - with - | FStar_Extraction_ML_Syntax.MLE_Name - uu___9 -> - let uu___10 = - instantiate_maybe_partial g head_ml - head_eff (vars, t1) - provided_type_args in - (match uu___10 with - | (head2, eff, t2) -> - (head2, eff, t2)) - | FStar_Extraction_ML_Syntax.MLE_Var - uu___9 -> - let uu___10 = - instantiate_maybe_partial g head_ml - head_eff (vars, t1) - provided_type_args in - (match uu___10 with - | (head2, eff, t2) -> - (head2, eff, t2)) - | FStar_Extraction_ML_Syntax.MLE_App - (head2, - { - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Const - (FStar_Extraction_ML_Syntax.MLC_Unit); - FStar_Extraction_ML_Syntax.mlty = - uu___9; - FStar_Extraction_ML_Syntax.loc = - uu___10;_}::[]) - -> - let uu___11 = - instantiate_maybe_partial g head2 - head_eff (vars, t1) - provided_type_args in - (match uu___11 with - | (head3, eff, t2) -> - let uu___12 = - FStar_Extraction_ML_Syntax.with_ty - t2 - (FStar_Extraction_ML_Syntax.MLE_App - (head3, - [FStar_Extraction_ML_Syntax.ml_unit])) in - (uu___12, eff, t2)) - | uu___9 -> - failwith - "Impossible: Unexpected head term" in - (match uu___8 with - | (head2, head_eff1, t2) -> - (head2, head_eff1, t2, rest)) in - (match uu___6 with - | (head_ml1, head_eff1, head_t, args1) -> - (match args1 with - | [] -> - let uu___7 = - maybe_eta_data_and_project_record g - qual head_t head_ml1 in - (uu___7, head_eff1, head_t) - | uu___7 -> - extract_app_maybe_projector qual - head_ml1 (head_eff1, head_t) args1))) - | FStar_Syntax_Syntax.Tm_fvar uu___4 -> - let uu___5 = - let uu___6 = - FStar_Extraction_ML_UEnv.lookup_term g head1 in - match uu___6 with - | (FStar_Pervasives.Inr exp_b, q) -> - (FStar_Extraction_ML_UEnv.debug g - (fun uu___8 -> - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head1 in - let uu___10 = - FStar_Class_Show.show - FStar_Extraction_ML_Code.showable_mlexpr - exp_b.FStar_Extraction_ML_UEnv.exp_b_expr in - let uu___11 = - FStar_Class_Show.show - FStar_Extraction_ML_Code.showable_mlty - (FStar_Pervasives_Native.snd - exp_b.FStar_Extraction_ML_UEnv.exp_b_tscheme) in - let uu___12 = - FStar_Class_Show.show - FStar_Extraction_ML_Code.showable_etag - exp_b.FStar_Extraction_ML_UEnv.exp_b_eff in - FStar_Compiler_Util.print4 - "@@@looked up %s: got %s at %s with eff <%s>\n" - uu___9 uu___10 uu___11 uu___12); - (((exp_b.FStar_Extraction_ML_UEnv.exp_b_expr), - (exp_b.FStar_Extraction_ML_UEnv.exp_b_tscheme), - (exp_b.FStar_Extraction_ML_UEnv.exp_b_eff)), - q)) - | uu___7 -> failwith "FIXME Ty" in - (match uu___5 with - | ((head_ml, (vars, t1), head_eff), qual) -> - let has_typ_apps = - match args with - | (a, uu___6)::uu___7 -> is_type g a - | uu___6 -> false in - let uu___6 = - let n = FStar_Compiler_List.length vars in - let uu___7 = - if (FStar_Compiler_List.length args) <= n - then - let uu___8 = - FStar_Compiler_List.map - (fun uu___9 -> - match uu___9 with - | (x, uu___10) -> term_as_mlty g x) - args in - (uu___8, []) - else - (let uu___9 = - FStar_Compiler_Util.first_N n args in - match uu___9 with - | (prefix, rest) -> - let uu___10 = - FStar_Compiler_List.map - (fun uu___11 -> - match uu___11 with - | (x, uu___12) -> - term_as_mlty g x) prefix in - (uu___10, rest)) in - match uu___7 with - | (provided_type_args, rest) -> - let uu___8 = - match head_ml.FStar_Extraction_ML_Syntax.expr - with - | FStar_Extraction_ML_Syntax.MLE_Name - uu___9 -> - let uu___10 = - instantiate_maybe_partial g head_ml - head_eff (vars, t1) - provided_type_args in - (match uu___10 with - | (head2, eff, t2) -> - (head2, eff, t2)) - | FStar_Extraction_ML_Syntax.MLE_Var - uu___9 -> - let uu___10 = - instantiate_maybe_partial g head_ml - head_eff (vars, t1) - provided_type_args in - (match uu___10 with - | (head2, eff, t2) -> - (head2, eff, t2)) - | FStar_Extraction_ML_Syntax.MLE_App - (head2, - { - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Const - (FStar_Extraction_ML_Syntax.MLC_Unit); - FStar_Extraction_ML_Syntax.mlty = - uu___9; - FStar_Extraction_ML_Syntax.loc = - uu___10;_}::[]) - -> - let uu___11 = - instantiate_maybe_partial g head2 - head_eff (vars, t1) - provided_type_args in - (match uu___11 with - | (head3, eff, t2) -> - let uu___12 = - FStar_Extraction_ML_Syntax.with_ty - t2 - (FStar_Extraction_ML_Syntax.MLE_App - (head3, - [FStar_Extraction_ML_Syntax.ml_unit])) in - (uu___12, eff, t2)) - | uu___9 -> - failwith - "Impossible: Unexpected head term" in - (match uu___8 with - | (head2, head_eff1, t2) -> - (head2, head_eff1, t2, rest)) in - (match uu___6 with - | (head_ml1, head_eff1, head_t, args1) -> - (match args1 with - | [] -> - let uu___7 = - maybe_eta_data_and_project_record g - qual head_t head_ml1 in - (uu___7, head_eff1, head_t) - | uu___7 -> - extract_app_maybe_projector qual - head_ml1 (head_eff1, head_t) args1))) - | uu___4 -> - let uu___5 = term_as_mlexpr g head1 in - (match uu___5 with - | (head2, f, t1) -> - extract_app_maybe_projector - FStar_Pervasives_Native.None head2 (f, t1) args) in - let uu___3 = is_type g t in - if uu___3 - then - (FStar_Extraction_ML_Syntax.ml_unit, - FStar_Extraction_ML_Syntax.E_PURE, - FStar_Extraction_ML_Syntax.ml_unit_ty) - else - (let uu___5 = - let uu___6 = FStar_Syntax_Util.un_uinst head in - uu___6.FStar_Syntax_Syntax.n in - match uu___5 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - let uu___6 = - FStar_Extraction_ML_UEnv.try_lookup_fv - t.FStar_Syntax_Syntax.pos g fv in - (match uu___6 with - | FStar_Pervasives_Native.None -> - (FStar_Extraction_ML_Syntax.ml_unit, - FStar_Extraction_ML_Syntax.E_PURE, - FStar_Extraction_ML_Syntax.MLTY_Erased) - | uu___7 -> extract_app_with_instantiations ()) - | uu___6 -> extract_app_with_instantiations ())) - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = e0; - FStar_Syntax_Syntax.asc = (tc, uu___1, uu___2); - FStar_Syntax_Syntax.eff_opt = f;_} - -> - let t1 = - match tc with - | FStar_Pervasives.Inl t2 -> term_as_mlty g t2 - | FStar_Pervasives.Inr c -> - let uu___3 = - let uu___4 = FStar_Extraction_ML_UEnv.tcenv_of_uenv g in - maybe_reify_comp g uu___4 c in - term_as_mlty g uu___3 in - let f1 = - match f with - | FStar_Pervasives_Native.None -> - failwith "Ascription node with an empty effect label" - | FStar_Pervasives_Native.Some l -> effect_as_etag g l in - let uu___3 = check_term_as_mlexpr g e0 f1 t1 in - (match uu___3 with | (e, t2) -> (e, f1, t2)) - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (false, lb::[]); - FStar_Syntax_Syntax.body1 = e';_} - when - (let uu___1 = FStar_Syntax_Syntax.is_top_level [lb] in - Prims.op_Negation uu___1) && - (let uu___1 = - FStar_Syntax_Util.get_attribute - FStar_Parser_Const.rename_let_attr - lb.FStar_Syntax_Syntax.lbattrs in - FStar_Compiler_Util.is_some uu___1) - -> - let b = - let uu___1 = - FStar_Compiler_Util.left lb.FStar_Syntax_Syntax.lbname in - FStar_Syntax_Syntax.mk_binder uu___1 in - let uu___1 = FStar_Syntax_Subst.open_term_1 b e' in - (match uu___1 with - | ({ FStar_Syntax_Syntax.binder_bv = x; - FStar_Syntax_Syntax.binder_qual = uu___2; - FStar_Syntax_Syntax.binder_positivity = uu___3; - FStar_Syntax_Syntax.binder_attrs = uu___4;_}, - body) -> - let suggested_name = - let attr = - FStar_Syntax_Util.get_attribute - FStar_Parser_Const.rename_let_attr - lb.FStar_Syntax_Syntax.lbattrs in - match attr with - | FStar_Pervasives_Native.Some ((str, uu___5)::[]) -> - let uu___6 = - let uu___7 = FStar_Syntax_Subst.compress str in - uu___7.FStar_Syntax_Syntax.n in - (match uu___6 with - | FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_string (s, uu___7)) when - s <> "" -> - let id = - let uu___8 = - let uu___9 = FStar_Syntax_Syntax.range_of_bv x in - (s, uu___9) in - FStar_Ident.mk_ident uu___8 in - let bv = - { - FStar_Syntax_Syntax.ppname = id; - FStar_Syntax_Syntax.index = Prims.int_zero; - FStar_Syntax_Syntax.sort = - (x.FStar_Syntax_Syntax.sort) - } in - let bv1 = FStar_Syntax_Syntax.freshen_bv bv in - FStar_Pervasives_Native.Some bv1 - | uu___7 -> - (FStar_Errors.log_issue - (FStar_Syntax_Syntax.has_range_syntax ()) top1 - FStar_Errors_Codes.Warning_UnrecognizedAttribute - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Ignoring ill-formed application of `rename_let`"); - FStar_Pervasives_Native.None)) - | FStar_Pervasives_Native.Some uu___5 -> - (FStar_Errors.log_issue - (FStar_Syntax_Syntax.has_range_syntax ()) top1 - FStar_Errors_Codes.Warning_UnrecognizedAttribute () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Ignoring ill-formed application of `rename_let`"); - FStar_Pervasives_Native.None) - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None in - let remove_attr attrs = - let uu___5 = - FStar_Compiler_List.partition - (fun attr -> - let uu___6 = - FStar_Syntax_Util.get_attribute - FStar_Parser_Const.rename_let_attr [attr] in - FStar_Compiler_Util.is_some uu___6) - lb.FStar_Syntax_Syntax.lbattrs in - match uu___5 with | (uu___6, other_attrs) -> other_attrs in - let maybe_rewritten_let = - match suggested_name with - | FStar_Pervasives_Native.None -> - let other_attrs = - remove_attr lb.FStar_Syntax_Syntax.lbattrs in - FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = - (false, - [{ - FStar_Syntax_Syntax.lbname = - (lb.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = - (lb.FStar_Syntax_Syntax.lbtyp); - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = - (lb.FStar_Syntax_Syntax.lbdef); - FStar_Syntax_Syntax.lbattrs = other_attrs; - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - }]); - FStar_Syntax_Syntax.body1 = e' - } - | FStar_Pervasives_Native.Some y -> - let other_attrs = - remove_attr lb.FStar_Syntax_Syntax.lbattrs in - let rename = - let uu___5 = - let uu___6 = - let uu___7 = FStar_Syntax_Syntax.bv_to_name y in - (x, uu___7) in - FStar_Syntax_Syntax.NT uu___6 in - [uu___5] in - let body1 = - let uu___5 = - let uu___6 = FStar_Syntax_Syntax.mk_binder y in - [uu___6] in - let uu___6 = FStar_Syntax_Subst.subst rename body in - FStar_Syntax_Subst.close uu___5 uu___6 in - let lb1 = - { - FStar_Syntax_Syntax.lbname = - (FStar_Pervasives.Inl y); - FStar_Syntax_Syntax.lbunivs = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = - (lb.FStar_Syntax_Syntax.lbtyp); - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = - (lb.FStar_Syntax_Syntax.lbdef); - FStar_Syntax_Syntax.lbattrs = other_attrs; - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - } in - FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = (false, [lb1]); - FStar_Syntax_Syntax.body1 = body1 - } in - let top2 = - { - FStar_Syntax_Syntax.n = maybe_rewritten_let; - FStar_Syntax_Syntax.pos = (top1.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = - (top1.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (top1.FStar_Syntax_Syntax.hash_code) - } in - term_as_mlexpr' g top2) - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (is_rec, lbs); - FStar_Syntax_Syntax.body1 = e';_} - -> - let top_level = FStar_Syntax_Syntax.is_top_level lbs in - let uu___1 = - if is_rec - then FStar_Syntax_Subst.open_let_rec lbs e' - else - (let uu___3 = FStar_Syntax_Syntax.is_top_level lbs in - if uu___3 - then (lbs, e') - else - (let lb = FStar_Compiler_List.hd lbs in - let x = - let uu___5 = - FStar_Compiler_Util.left lb.FStar_Syntax_Syntax.lbname in - FStar_Syntax_Syntax.freshen_bv uu___5 in - let lb1 = - { - FStar_Syntax_Syntax.lbname = (FStar_Pervasives.Inl x); - FStar_Syntax_Syntax.lbunivs = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = - (lb.FStar_Syntax_Syntax.lbtyp); - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = - (lb.FStar_Syntax_Syntax.lbdef); - FStar_Syntax_Syntax.lbattrs = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - } in - let e'1 = - FStar_Syntax_Subst.subst - [FStar_Syntax_Syntax.DB (Prims.int_zero, x)] e' in - ([lb1], e'1))) in - (match uu___1 with - | (lbs1, e'1) -> - let lbs2 = - if top_level - then - let tcenv = - let uu___2 = FStar_Extraction_ML_UEnv.tcenv_of_uenv g in - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Extraction_ML_UEnv.current_module_of_uenv - g in - FStar_Pervasives_Native.fst uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Extraction_ML_UEnv.current_module_of_uenv - g in - FStar_Pervasives_Native.snd uu___8 in - [uu___7] in - FStar_Compiler_List.op_At uu___5 uu___6 in - FStar_Ident.lid_of_path uu___4 - FStar_Compiler_Range_Type.dummyRange in - FStar_TypeChecker_Env.set_current_module uu___2 uu___3 in - FStar_Compiler_List.map - (fun lb -> - let lbdef = - let norm_call uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_TypeChecker_Env.current_module tcenv in - FStar_Ident.string_of_lid uu___5 in - FStar_Pervasives_Native.Some uu___4 in - FStar_Profiling.profile - (fun uu___4 -> - FStar_TypeChecker_Normalize.normalize - (FStar_TypeChecker_Env.PureSubtermsWithinComputations - :: FStar_TypeChecker_Env.Reify :: - extraction_norm_steps) tcenv - lb.FStar_Syntax_Syntax.lbdef) uu___3 - "FStar.Extraction.ML.Term.normalize_lb_def" in - let uu___2 = - (FStar_Compiler_Effect.op_Bang dbg_Extraction) - || - (FStar_Compiler_Effect.op_Bang - dbg_ExtractionNorm) in - if uu___2 - then - ((let uu___4 = - FStar_Class_Show.show - (FStar_Class_Show.show_either - FStar_Syntax_Print.showable_bv - FStar_Syntax_Print.showable_fv) - lb.FStar_Syntax_Syntax.lbname in - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - lb.FStar_Syntax_Syntax.lbdef in - FStar_Compiler_Util.print2 - "Starting to normalize top-level let %s = %s\n" - uu___4 uu___5); - (let a = norm_call () in - (let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term a in - FStar_Compiler_Util.print1 - "Normalized to %s\n" uu___5); - a)) - else norm_call () in - { - FStar_Syntax_Syntax.lbname = - (lb.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = - (lb.FStar_Syntax_Syntax.lbtyp); - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = lbdef; - FStar_Syntax_Syntax.lbattrs = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - }) lbs1 - else lbs1 in - let check_lb env nm_sig = - let uu___2 = nm_sig in - match uu___2 with - | (nm, - (_lbname, f, (_t, (targs, polytype)), add_unit, - has_c_inline, e)) -> - let env1 = - FStar_Compiler_List.fold_left - (fun env2 -> - fun uu___3 -> - match uu___3 with - | { FStar_Syntax_Syntax.binder_bv = a; - FStar_Syntax_Syntax.binder_qual = uu___4; - FStar_Syntax_Syntax.binder_positivity = - uu___5; - FStar_Syntax_Syntax.binder_attrs = uu___6;_} - -> - FStar_Extraction_ML_UEnv.extend_ty env2 a - false) env targs in - let expected_t = FStar_Pervasives_Native.snd polytype in - let uu___3 = check_term_as_mlexpr env1 e f expected_t in - (match uu___3 with - | (e1, ty) -> - let uu___4 = maybe_promote_effect e1 f expected_t in - (match uu___4 with - | (e2, f1) -> - let meta = - match (f1, ty) with - | (FStar_Extraction_ML_Syntax.E_PURE, - FStar_Extraction_ML_Syntax.MLTY_Erased) - -> [FStar_Extraction_ML_Syntax.Erased] - | (FStar_Extraction_ML_Syntax.E_ERASABLE, - FStar_Extraction_ML_Syntax.MLTY_Erased) - -> [FStar_Extraction_ML_Syntax.Erased] - | uu___5 -> [] in - let meta1 = - if has_c_inline - then FStar_Extraction_ML_Syntax.CInline :: - meta - else meta in - (f1, - { - FStar_Extraction_ML_Syntax.mllb_name = nm; - FStar_Extraction_ML_Syntax.mllb_tysc = - (FStar_Pervasives_Native.Some polytype); - FStar_Extraction_ML_Syntax.mllb_add_unit - = add_unit; - FStar_Extraction_ML_Syntax.mllb_def = e2; - FStar_Extraction_ML_Syntax.mllb_attrs = - []; - FStar_Extraction_ML_Syntax.mllb_meta = - meta1; - FStar_Extraction_ML_Syntax.print_typ = - true - }))) in - let lbs3 = extract_lb_sig g (is_rec, lbs2) in - let uu___2 = - FStar_Compiler_List.fold_right - (fun lb -> - fun uu___3 -> - match uu___3 with - | (env, lbs4, env_burn) -> - let uu___4 = lb in - (match uu___4 with - | (lbname, uu___5, (t1, (uu___6, polytype)), - add_unit, _has_c_inline, uu___7) -> - let uu___8 = - FStar_Extraction_ML_UEnv.extend_lb env - lbname t1 polytype add_unit in - (match uu___8 with - | (env1, nm, uu___9) -> - let env_burn1 = - let uu___10 = - let uu___11 = - FStar_Options.codegen () in - uu___11 <> - (FStar_Pervasives_Native.Some - FStar_Options.Krml) in - if uu___10 - then - FStar_Extraction_ML_UEnv.burn_name - env_burn nm - else env_burn in - (env1, ((nm, lb) :: lbs4), env_burn1)))) - lbs3 (g, [], g) in - (match uu___2 with - | (env_body, lbs4, env_burn) -> - let env_def = if is_rec then env_body else env_burn in - let lbs5 = - FStar_Compiler_List.map (check_lb env_def) lbs4 in - let e'_rng = e'1.FStar_Syntax_Syntax.pos in - let uu___3 = term_as_mlexpr env_body e'1 in - (match uu___3 with - | (e'2, f', t') -> - let f = - let uu___4 = - let uu___5 = - FStar_Compiler_List.map - FStar_Pervasives_Native.fst lbs5 in - f' :: uu___5 in - FStar_Extraction_ML_Util.join_l e'_rng uu___4 in - let is_rec1 = - if is_rec = true - then FStar_Extraction_ML_Syntax.Rec - else FStar_Extraction_ML_Syntax.NonRec in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Compiler_List.map - FStar_Pervasives_Native.snd lbs5 in - (is_rec1, uu___7) in - mk_MLE_Let top_level uu___6 e'2 in - let uu___6 = - FStar_Extraction_ML_Util.mlloc_of_range - t.FStar_Syntax_Syntax.pos in - FStar_Extraction_ML_Syntax.with_ty_loc t' uu___5 - uu___6 in - (uu___4, f, t')))) - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = scrutinee; - FStar_Syntax_Syntax.ret_opt = uu___1; - FStar_Syntax_Syntax.brs = pats; - FStar_Syntax_Syntax.rc_opt1 = uu___2;_} - -> - let uu___3 = term_as_mlexpr g scrutinee in - (match uu___3 with - | (e, f_e, t_e) -> - let uu___4 = check_pats_for_ite pats in - (match uu___4 with - | (b, then_e, else_e) -> - let no_lift x t1 = x in - if b - then - (match (then_e, else_e) with - | (FStar_Pervasives_Native.Some then_e1, - FStar_Pervasives_Native.Some else_e1) -> - let uu___5 = term_as_mlexpr g then_e1 in - (match uu___5 with - | (then_mle, f_then, t_then) -> - let uu___6 = term_as_mlexpr g else_e1 in - (match uu___6 with - | (else_mle, f_else, t_else) -> - let uu___7 = - let uu___8 = type_leq g t_then t_else in - if uu___8 - then (t_else, no_lift) - else - (let uu___10 = - type_leq g t_else t_then in - if uu___10 - then (t_then, no_lift) - else - (FStar_Extraction_ML_Syntax.MLTY_Top, - FStar_Extraction_ML_Syntax.apply_obj_repr)) in - (match uu___7 with - | (t_branch, maybe_lift) -> - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - maybe_lift then_mle t_then in - let uu___12 = - let uu___13 = - maybe_lift else_mle - t_else in - FStar_Pervasives_Native.Some - uu___13 in - (e, uu___11, uu___12) in - FStar_Extraction_ML_Syntax.MLE_If - uu___10 in - FStar_Extraction_ML_Syntax.with_ty - t_branch uu___9 in - let uu___9 = - FStar_Extraction_ML_Util.join - then_e1.FStar_Syntax_Syntax.pos - f_then f_else in - (uu___8, uu___9, t_branch)))) - | uu___5 -> - failwith - "ITE pats matched but then and else expressions not found?") - else - (let uu___6 = - FStar_Compiler_Util.fold_map - (fun compat -> - fun br -> - let uu___7 = - FStar_Syntax_Subst.open_branch br in - match uu___7 with - | (pat, when_opt, branch) -> - let uu___8 = - extract_pat g pat t_e term_as_mlexpr in - (match uu___8 with - | (env, p, pat_t_compat) -> - let uu___9 = - match when_opt with - | FStar_Pervasives_Native.None -> - (FStar_Pervasives_Native.None, - FStar_Extraction_ML_Syntax.E_PURE) - | FStar_Pervasives_Native.Some w - -> - let w_pos = - w.FStar_Syntax_Syntax.pos in - let uu___10 = - term_as_mlexpr env w in - (match uu___10 with - | (w1, f_w, t_w) -> - let w2 = - maybe_coerce w_pos env - w1 t_w - FStar_Extraction_ML_Syntax.ml_bool_ty in - ((FStar_Pervasives_Native.Some - w2), f_w)) in - (match uu___9 with - | (when_opt1, f_when) -> - let uu___10 = - term_as_mlexpr env branch in - (match uu___10 with - | (mlbranch, f_branch, - t_branch) -> - let uu___11 = - FStar_Compiler_List.map - (fun uu___12 -> - match uu___12 with - | (p1, wopt) -> - let when_clause - = - FStar_Extraction_ML_Util.conjoin_opt - wopt - when_opt1 in - (p1, - (when_clause, - f_when), - (mlbranch, - f_branch, - t_branch))) - p in - ((compat && pat_t_compat), - uu___11))))) true pats in - match uu___6 with - | (pat_t_compat, mlbranches) -> - let mlbranches1 = - FStar_Compiler_List.flatten mlbranches in - let e1 = - if pat_t_compat - then e - else - (FStar_Extraction_ML_UEnv.debug g - (fun uu___9 -> - let uu___10 = - let uu___11 = - FStar_Extraction_ML_UEnv.current_module_of_uenv - g in - FStar_Extraction_ML_Code.string_of_mlexpr - uu___11 e in - let uu___11 = - let uu___12 = - FStar_Extraction_ML_UEnv.current_module_of_uenv - g in - FStar_Extraction_ML_Code.string_of_mlty - uu___12 t_e in - FStar_Compiler_Util.print2 - "Coercing scrutinee %s from type %s because pattern type is incompatible\n" - uu___10 uu___11); - FStar_Extraction_ML_Syntax.with_ty t_e - (FStar_Extraction_ML_Syntax.MLE_Coerce - (e, t_e, - FStar_Extraction_ML_Syntax.MLTY_Top))) in - (match mlbranches1 with - | [] -> - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Parser_Const.failwith_lid () in - FStar_Syntax_Syntax.lid_as_fv uu___9 - FStar_Pervasives_Native.None in - FStar_Extraction_ML_UEnv.lookup_fv - t.FStar_Syntax_Syntax.pos g uu___8 in - (match uu___7 with - | { - FStar_Extraction_ML_UEnv.exp_b_name = - uu___8; - FStar_Extraction_ML_UEnv.exp_b_expr = - fw; - FStar_Extraction_ML_UEnv.exp_b_tscheme - = uu___9; - FStar_Extraction_ML_UEnv.exp_b_eff = - uu___10;_} - -> - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.ml_string_ty - (FStar_Extraction_ML_Syntax.MLE_Const - (FStar_Extraction_ML_Syntax.MLC_String - "unreachable")) in - [uu___15] in - (fw, uu___14) in - FStar_Extraction_ML_Syntax.MLE_App - uu___13 in - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.ml_int_ty - uu___12 in - (uu___11, - FStar_Extraction_ML_Syntax.E_PURE, - FStar_Extraction_ML_Syntax.ml_int_ty)) - | (uu___7, uu___8, (uu___9, f_first, t_first))::rest - -> - let uu___10 = - FStar_Compiler_List.fold_left - (fun uu___11 -> - fun uu___12 -> - match (uu___11, uu___12) with - | ((topt, f), - (uu___13, uu___14, - (uu___15, f_branch, t_branch))) - -> - let f1 = - FStar_Extraction_ML_Util.join - top1.FStar_Syntax_Syntax.pos - f f_branch in - let topt1 = - match topt with - | FStar_Pervasives_Native.None - -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some - t1 -> - let uu___16 = - type_leq g t1 t_branch in - if uu___16 - then - FStar_Pervasives_Native.Some - t_branch - else - (let uu___18 = - type_leq g t_branch - t1 in - if uu___18 - then - FStar_Pervasives_Native.Some - t1 - else - FStar_Pervasives_Native.None) in - (topt1, f1)) - ((FStar_Pervasives_Native.Some t_first), - f_first) rest in - (match uu___10 with - | (topt, f_match) -> - let mlbranches2 = - FStar_Compiler_List.map - (fun uu___11 -> - match uu___11 with - | (p, (wopt, uu___12), - (b1, uu___13, t1)) -> - let b2 = - match topt with - | FStar_Pervasives_Native.None - -> - FStar_Extraction_ML_Syntax.apply_obj_repr - b1 t1 - | FStar_Pervasives_Native.Some - uu___14 -> b1 in - (p, wopt, b2)) mlbranches1 in - let t_match = - match topt with - | FStar_Pervasives_Native.None -> - FStar_Extraction_ML_Syntax.MLTY_Top - | FStar_Pervasives_Native.Some t1 -> - t1 in - let uu___11 = - FStar_Extraction_ML_Syntax.with_ty - t_match - (FStar_Extraction_ML_Syntax.MLE_Match - (e1, mlbranches2)) in - (uu___11, f_match, t_match))))))) -let (ind_discriminator_body : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Ident.lident -> - FStar_Ident.lident -> FStar_Extraction_ML_Syntax.mlmodule1) - = - fun env -> - fun discName -> - fun constrName -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Extraction_ML_UEnv.tcenv_of_uenv env in - FStar_TypeChecker_Env.lookup_lid uu___2 discName in - FStar_Pervasives_Native.fst uu___1 in - match uu___ with - | (uu___1, fstar_disc_type) -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Subst.compress fstar_disc_type in - uu___4.FStar_Syntax_Syntax.n in - match uu___3 with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = binders; - FStar_Syntax_Syntax.comp = uu___4;_} - -> - let binders1 = - FStar_Compiler_List.filter - (fun uu___5 -> - match uu___5 with - | { FStar_Syntax_Syntax.binder_bv = uu___6; - FStar_Syntax_Syntax.binder_qual = - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Implicit uu___7); - FStar_Syntax_Syntax.binder_positivity = uu___8; - FStar_Syntax_Syntax.binder_attrs = uu___9;_} -> - true - | uu___6 -> false) binders in - FStar_Compiler_List.fold_right - (fun uu___5 -> - fun uu___6 -> - match uu___6 with - | (g, vs) -> - let uu___7 = - FStar_Extraction_ML_UEnv.new_mlident g in - (match uu___7 with - | (g1, v) -> - (g1, - ((v, FStar_Extraction_ML_Syntax.MLTY_Top) - :: vs)))) binders1 (env, []) - | uu___4 -> failwith "Discriminator must be a function" in - (match uu___2 with - | (g, wildcards) -> - let uu___3 = FStar_Extraction_ML_UEnv.new_mlident g in - (match uu___3 with - | (g1, mlid) -> - let targ = FStar_Extraction_ML_Syntax.MLTY_Top in - let disc_ty = FStar_Extraction_ML_Syntax.MLTY_Top in - let discrBody = - let bs = - FStar_Compiler_List.map - (fun uu___4 -> - match uu___4 with - | (x, t) -> - { - FStar_Extraction_ML_Syntax.mlbinder_name - = x; - FStar_Extraction_ML_Syntax.mlbinder_ty = - t; - FStar_Extraction_ML_Syntax.mlbinder_attrs - = [] - }) - (FStar_Compiler_List.op_At wildcards - [(mlid, targ)]) in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Extraction_ML_Syntax.with_ty targ - (FStar_Extraction_ML_Syntax.MLE_Name - ([], mlid)) in - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - FStar_Extraction_ML_UEnv.mlpath_of_lident - g1 constrName in - (uu___14, - [FStar_Extraction_ML_Syntax.MLP_Wild]) in - FStar_Extraction_ML_Syntax.MLP_CTor - uu___13 in - let uu___13 = - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.ml_bool_ty - (FStar_Extraction_ML_Syntax.MLE_Const - (FStar_Extraction_ML_Syntax.MLC_Bool - true)) in - (uu___12, FStar_Pervasives_Native.None, - uu___13) in - let uu___12 = - let uu___13 = - let uu___14 = - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.ml_bool_ty - (FStar_Extraction_ML_Syntax.MLE_Const - (FStar_Extraction_ML_Syntax.MLC_Bool - false)) in - (FStar_Extraction_ML_Syntax.MLP_Wild, - FStar_Pervasives_Native.None, - uu___14) in - [uu___13] in - uu___11 :: uu___12 in - (uu___9, uu___10) in - FStar_Extraction_ML_Syntax.MLE_Match uu___8 in - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.ml_bool_ty uu___7 in - (bs, uu___6) in - FStar_Extraction_ML_Syntax.MLE_Fun uu___5 in - FStar_Extraction_ML_Syntax.with_ty disc_ty uu___4 in - let uu___4 = - FStar_Extraction_ML_UEnv.mlpath_of_lident env - discName in - (match uu___4 with - | (uu___5, name) -> - FStar_Extraction_ML_Syntax.mk_mlmodule1 - (FStar_Extraction_ML_Syntax.MLM_Let - (FStar_Extraction_ML_Syntax.NonRec, - [{ - FStar_Extraction_ML_Syntax.mllb_name = - name; - FStar_Extraction_ML_Syntax.mllb_tysc = - FStar_Pervasives_Native.None; - FStar_Extraction_ML_Syntax.mllb_add_unit - = false; - FStar_Extraction_ML_Syntax.mllb_def = - discrBody; - FStar_Extraction_ML_Syntax.mllb_attrs = - []; - FStar_Extraction_ML_Syntax.mllb_meta = - []; - FStar_Extraction_ML_Syntax.print_typ = - false - }]))))) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Extraction_ML_UEnv.ml b/ocaml/fstar-lib/generated/FStar_Extraction_ML_UEnv.ml deleted file mode 100644 index 370e4958cd5..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Extraction_ML_UEnv.ml +++ /dev/null @@ -1,1197 +0,0 @@ -open Prims -type ty_binding = - { - ty_b_name: FStar_Extraction_ML_Syntax.mlident ; - ty_b_ty: FStar_Extraction_ML_Syntax.mlty } -let (__proj__Mkty_binding__item__ty_b_name : - ty_binding -> FStar_Extraction_ML_Syntax.mlident) = - fun projectee -> - match projectee with | { ty_b_name; ty_b_ty;_} -> ty_b_name -let (__proj__Mkty_binding__item__ty_b_ty : - ty_binding -> FStar_Extraction_ML_Syntax.mlty) = - fun projectee -> match projectee with | { ty_b_name; ty_b_ty;_} -> ty_b_ty -type exp_binding = - { - exp_b_name: FStar_Extraction_ML_Syntax.mlident ; - exp_b_expr: FStar_Extraction_ML_Syntax.mlexpr ; - exp_b_tscheme: FStar_Extraction_ML_Syntax.mltyscheme ; - exp_b_eff: FStar_Extraction_ML_Syntax.e_tag } -let (__proj__Mkexp_binding__item__exp_b_name : - exp_binding -> FStar_Extraction_ML_Syntax.mlident) = - fun projectee -> - match projectee with - | { exp_b_name; exp_b_expr; exp_b_tscheme; exp_b_eff;_} -> exp_b_name -let (__proj__Mkexp_binding__item__exp_b_expr : - exp_binding -> FStar_Extraction_ML_Syntax.mlexpr) = - fun projectee -> - match projectee with - | { exp_b_name; exp_b_expr; exp_b_tscheme; exp_b_eff;_} -> exp_b_expr -let (__proj__Mkexp_binding__item__exp_b_tscheme : - exp_binding -> FStar_Extraction_ML_Syntax.mltyscheme) = - fun projectee -> - match projectee with - | { exp_b_name; exp_b_expr; exp_b_tscheme; exp_b_eff;_} -> exp_b_tscheme -let (__proj__Mkexp_binding__item__exp_b_eff : - exp_binding -> FStar_Extraction_ML_Syntax.e_tag) = - fun projectee -> - match projectee with - | { exp_b_name; exp_b_expr; exp_b_tscheme; exp_b_eff;_} -> exp_b_eff -type ty_or_exp_b = (ty_binding, exp_binding) FStar_Pervasives.either -type binding = - | Bv of (FStar_Syntax_Syntax.bv * ty_or_exp_b) - | Fv of (FStar_Syntax_Syntax.fv * exp_binding) - | ErasedFv of FStar_Syntax_Syntax.fv -let (uu___is_Bv : binding -> Prims.bool) = - fun projectee -> match projectee with | Bv _0 -> true | uu___ -> false -let (__proj__Bv__item___0 : - binding -> (FStar_Syntax_Syntax.bv * ty_or_exp_b)) = - fun projectee -> match projectee with | Bv _0 -> _0 -let (uu___is_Fv : binding -> Prims.bool) = - fun projectee -> match projectee with | Fv _0 -> true | uu___ -> false -let (__proj__Fv__item___0 : - binding -> (FStar_Syntax_Syntax.fv * exp_binding)) = - fun projectee -> match projectee with | Fv _0 -> _0 -let (uu___is_ErasedFv : binding -> Prims.bool) = - fun projectee -> - match projectee with | ErasedFv _0 -> true | uu___ -> false -let (__proj__ErasedFv__item___0 : binding -> FStar_Syntax_Syntax.fv) = - fun projectee -> match projectee with | ErasedFv _0 -> _0 -type tydef = - { - tydef_fv: FStar_Syntax_Syntax.fv ; - tydef_mlmodule_name: FStar_Extraction_ML_Syntax.mlsymbol Prims.list ; - tydef_name: FStar_Extraction_ML_Syntax.mlsymbol ; - tydef_meta: FStar_Extraction_ML_Syntax.metadata ; - tydef_def: FStar_Extraction_ML_Syntax.mltyscheme } -let (__proj__Mktydef__item__tydef_fv : tydef -> FStar_Syntax_Syntax.fv) = - fun projectee -> - match projectee with - | { tydef_fv; tydef_mlmodule_name; tydef_name; tydef_meta; tydef_def;_} - -> tydef_fv -let (__proj__Mktydef__item__tydef_mlmodule_name : - tydef -> FStar_Extraction_ML_Syntax.mlsymbol Prims.list) = - fun projectee -> - match projectee with - | { tydef_fv; tydef_mlmodule_name; tydef_name; tydef_meta; tydef_def;_} - -> tydef_mlmodule_name -let (__proj__Mktydef__item__tydef_name : - tydef -> FStar_Extraction_ML_Syntax.mlsymbol) = - fun projectee -> - match projectee with - | { tydef_fv; tydef_mlmodule_name; tydef_name; tydef_meta; tydef_def;_} - -> tydef_name -let (__proj__Mktydef__item__tydef_meta : - tydef -> FStar_Extraction_ML_Syntax.metadata) = - fun projectee -> - match projectee with - | { tydef_fv; tydef_mlmodule_name; tydef_name; tydef_meta; tydef_def;_} - -> tydef_meta -let (__proj__Mktydef__item__tydef_def : - tydef -> FStar_Extraction_ML_Syntax.mltyscheme) = - fun projectee -> - match projectee with - | { tydef_fv; tydef_mlmodule_name; tydef_name; tydef_meta; tydef_def;_} - -> tydef_def -let (tydef_fv : tydef -> FStar_Syntax_Syntax.fv) = fun td -> td.tydef_fv -let (tydef_meta : tydef -> FStar_Extraction_ML_Syntax.metadata) = - fun td -> td.tydef_meta -let (tydef_def : tydef -> FStar_Extraction_ML_Syntax.mltyscheme) = - fun td -> td.tydef_def -let (tydef_mlpath : tydef -> FStar_Extraction_ML_Syntax.mlpath) = - fun td -> ((td.tydef_mlmodule_name), (td.tydef_name)) -type uenv = - { - env_tcenv: FStar_TypeChecker_Env.env ; - env_bindings: binding Prims.list ; - env_mlident_map: - FStar_Extraction_ML_Syntax.mlident FStar_Compiler_Util.psmap ; - env_remove_typars: FStar_Extraction_ML_RemoveUnusedParameters.env_t ; - mlpath_of_lid: FStar_Extraction_ML_Syntax.mlpath FStar_Compiler_Util.psmap ; - env_fieldname_map: - FStar_Extraction_ML_Syntax.mlident FStar_Compiler_Util.psmap ; - mlpath_of_fieldname: - FStar_Extraction_ML_Syntax.mlpath FStar_Compiler_Util.psmap ; - tydefs: tydef Prims.list ; - type_names: - (FStar_Syntax_Syntax.fv * FStar_Extraction_ML_Syntax.mlpath) Prims.list ; - tydef_declarations: Prims.bool FStar_Compiler_Util.psmap ; - currentModule: FStar_Extraction_ML_Syntax.mlpath } -let (__proj__Mkuenv__item__env_tcenv : uenv -> FStar_TypeChecker_Env.env) = - fun projectee -> - match projectee with - | { env_tcenv; env_bindings; env_mlident_map; env_remove_typars; - mlpath_of_lid; env_fieldname_map; mlpath_of_fieldname; tydefs; - type_names; tydef_declarations; currentModule;_} -> env_tcenv -let (__proj__Mkuenv__item__env_bindings : uenv -> binding Prims.list) = - fun projectee -> - match projectee with - | { env_tcenv; env_bindings; env_mlident_map; env_remove_typars; - mlpath_of_lid; env_fieldname_map; mlpath_of_fieldname; tydefs; - type_names; tydef_declarations; currentModule;_} -> env_bindings -let (__proj__Mkuenv__item__env_mlident_map : - uenv -> FStar_Extraction_ML_Syntax.mlident FStar_Compiler_Util.psmap) = - fun projectee -> - match projectee with - | { env_tcenv; env_bindings; env_mlident_map; env_remove_typars; - mlpath_of_lid; env_fieldname_map; mlpath_of_fieldname; tydefs; - type_names; tydef_declarations; currentModule;_} -> env_mlident_map -let (__proj__Mkuenv__item__env_remove_typars : - uenv -> FStar_Extraction_ML_RemoveUnusedParameters.env_t) = - fun projectee -> - match projectee with - | { env_tcenv; env_bindings; env_mlident_map; env_remove_typars; - mlpath_of_lid; env_fieldname_map; mlpath_of_fieldname; tydefs; - type_names; tydef_declarations; currentModule;_} -> env_remove_typars -let (__proj__Mkuenv__item__mlpath_of_lid : - uenv -> FStar_Extraction_ML_Syntax.mlpath FStar_Compiler_Util.psmap) = - fun projectee -> - match projectee with - | { env_tcenv; env_bindings; env_mlident_map; env_remove_typars; - mlpath_of_lid; env_fieldname_map; mlpath_of_fieldname; tydefs; - type_names; tydef_declarations; currentModule;_} -> mlpath_of_lid -let (__proj__Mkuenv__item__env_fieldname_map : - uenv -> FStar_Extraction_ML_Syntax.mlident FStar_Compiler_Util.psmap) = - fun projectee -> - match projectee with - | { env_tcenv; env_bindings; env_mlident_map; env_remove_typars; - mlpath_of_lid; env_fieldname_map; mlpath_of_fieldname; tydefs; - type_names; tydef_declarations; currentModule;_} -> env_fieldname_map -let (__proj__Mkuenv__item__mlpath_of_fieldname : - uenv -> FStar_Extraction_ML_Syntax.mlpath FStar_Compiler_Util.psmap) = - fun projectee -> - match projectee with - | { env_tcenv; env_bindings; env_mlident_map; env_remove_typars; - mlpath_of_lid; env_fieldname_map; mlpath_of_fieldname; tydefs; - type_names; tydef_declarations; currentModule;_} -> - mlpath_of_fieldname -let (__proj__Mkuenv__item__tydefs : uenv -> tydef Prims.list) = - fun projectee -> - match projectee with - | { env_tcenv; env_bindings; env_mlident_map; env_remove_typars; - mlpath_of_lid; env_fieldname_map; mlpath_of_fieldname; tydefs; - type_names; tydef_declarations; currentModule;_} -> tydefs -let (__proj__Mkuenv__item__type_names : - uenv -> - (FStar_Syntax_Syntax.fv * FStar_Extraction_ML_Syntax.mlpath) Prims.list) - = - fun projectee -> - match projectee with - | { env_tcenv; env_bindings; env_mlident_map; env_remove_typars; - mlpath_of_lid; env_fieldname_map; mlpath_of_fieldname; tydefs; - type_names; tydef_declarations; currentModule;_} -> type_names -let (__proj__Mkuenv__item__tydef_declarations : - uenv -> Prims.bool FStar_Compiler_Util.psmap) = - fun projectee -> - match projectee with - | { env_tcenv; env_bindings; env_mlident_map; env_remove_typars; - mlpath_of_lid; env_fieldname_map; mlpath_of_fieldname; tydefs; - type_names; tydef_declarations; currentModule;_} -> - tydef_declarations -let (__proj__Mkuenv__item__currentModule : - uenv -> FStar_Extraction_ML_Syntax.mlpath) = - fun projectee -> - match projectee with - | { env_tcenv; env_bindings; env_mlident_map; env_remove_typars; - mlpath_of_lid; env_fieldname_map; mlpath_of_fieldname; tydefs; - type_names; tydef_declarations; currentModule;_} -> currentModule -let (tcenv_of_uenv : uenv -> FStar_TypeChecker_Env.env) = - fun u -> u.env_tcenv -let (set_tcenv : uenv -> FStar_TypeChecker_Env.env -> uenv) = - fun u -> - fun t -> - { - env_tcenv = t; - env_bindings = (u.env_bindings); - env_mlident_map = (u.env_mlident_map); - env_remove_typars = (u.env_remove_typars); - mlpath_of_lid = (u.mlpath_of_lid); - env_fieldname_map = (u.env_fieldname_map); - mlpath_of_fieldname = (u.mlpath_of_fieldname); - tydefs = (u.tydefs); - type_names = (u.type_names); - tydef_declarations = (u.tydef_declarations); - currentModule = (u.currentModule) - } -let (current_module_of_uenv : uenv -> FStar_Extraction_ML_Syntax.mlpath) = - fun u -> u.currentModule -let (set_current_module : uenv -> FStar_Extraction_ML_Syntax.mlpath -> uenv) - = - fun u -> - fun m -> - { - env_tcenv = (u.env_tcenv); - env_bindings = (u.env_bindings); - env_mlident_map = (u.env_mlident_map); - env_remove_typars = (u.env_remove_typars); - mlpath_of_lid = (u.mlpath_of_lid); - env_fieldname_map = (u.env_fieldname_map); - mlpath_of_fieldname = (u.mlpath_of_fieldname); - tydefs = (u.tydefs); - type_names = (u.type_names); - tydef_declarations = (u.tydef_declarations); - currentModule = m - } -let with_typars_env : - 'a . - uenv -> - (FStar_Extraction_ML_RemoveUnusedParameters.env_t -> - (FStar_Extraction_ML_RemoveUnusedParameters.env_t * 'a)) - -> (uenv * 'a) - = - fun u -> - fun f -> - let uu___ = f u.env_remove_typars in - match uu___ with - | (e, x) -> - ({ - env_tcenv = (u.env_tcenv); - env_bindings = (u.env_bindings); - env_mlident_map = (u.env_mlident_map); - env_remove_typars = e; - mlpath_of_lid = (u.mlpath_of_lid); - env_fieldname_map = (u.env_fieldname_map); - mlpath_of_fieldname = (u.mlpath_of_fieldname); - tydefs = (u.tydefs); - type_names = (u.type_names); - tydef_declarations = (u.tydef_declarations); - currentModule = (u.currentModule) - }, x) -let (bindings_of_uenv : uenv -> binding Prims.list) = fun u -> u.env_bindings -let (dbg : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Extraction" -let (debug : uenv -> (unit -> unit) -> unit) = - fun g -> - fun f -> - let c = FStar_Extraction_ML_Syntax.string_of_mlpath g.currentModule in - let uu___ = FStar_Compiler_Effect.op_Bang dbg in - if uu___ then f () else () -let (print_mlpath_map : uenv -> Prims.string) = - fun g -> - let string_of_mlpath mlp = - Prims.strcat - (FStar_Compiler_String.concat "." (FStar_Pervasives_Native.fst mlp)) - (Prims.strcat "." (FStar_Pervasives_Native.snd mlp)) in - let entries = - FStar_Compiler_Util.psmap_fold g.mlpath_of_lid - (fun key -> - fun value -> - fun entries1 -> - let uu___ = - FStar_Compiler_Util.format2 "%s -> %s" key - (string_of_mlpath value) in - uu___ :: entries1) [] in - FStar_Compiler_String.concat "\n" entries -let (lookup_fv_generic : - uenv -> - FStar_Syntax_Syntax.fv -> - (Prims.bool, exp_binding) FStar_Pervasives.either) - = - fun g -> - fun fv -> - let v = - FStar_Compiler_Util.find_map g.env_bindings - (fun uu___ -> - match uu___ with - | Fv (fv', t) when FStar_Syntax_Syntax.fv_eq fv fv' -> - FStar_Pervasives_Native.Some (FStar_Pervasives.Inr t) - | ErasedFv fv' when FStar_Syntax_Syntax.fv_eq fv fv' -> - FStar_Pervasives_Native.Some (FStar_Pervasives.Inl true) - | uu___1 -> FStar_Pervasives_Native.None) in - match v with - | FStar_Pervasives_Native.Some r -> r - | FStar_Pervasives_Native.None -> FStar_Pervasives.Inl false -let (try_lookup_fv : - FStar_Compiler_Range_Type.range -> - uenv -> - FStar_Syntax_Syntax.fv -> exp_binding FStar_Pervasives_Native.option) - = - fun r -> - fun g -> - fun fv -> - let uu___ = lookup_fv_generic g fv in - match uu___ with - | FStar_Pervasives.Inr r1 -> FStar_Pervasives_Native.Some r1 - | FStar_Pervasives.Inl (true) -> - ((let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_fv fv in - FStar_Compiler_Util.format1 - "Will not extract reference to variable `%s` since it has the `noextract` qualifier." - uu___5 in - FStar_Errors_Msg.text uu___4 in - let uu___4 = - let uu___5 = - FStar_Errors_Msg.text - "Either remove its qualifier or add it to this definition." in - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Compiler_Util.string_of_int - FStar_Errors.call_to_erased_errno in - FStar_Compiler_Util.format1 - "This error can be ignored with `--warn_error -%s`." - uu___9 in - FStar_Errors_Msg.text uu___8 in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - FStar_Errors.log_issue FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Error_CallToErased () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) - | FStar_Pervasives.Inl (false) -> FStar_Pervasives_Native.None -let (lookup_fv : - FStar_Compiler_Range_Type.range -> - uenv -> FStar_Syntax_Syntax.fv -> exp_binding) - = - fun r -> - fun g -> - fun fv -> - let uu___ = lookup_fv_generic g fv in - match uu___ with - | FStar_Pervasives.Inr t -> t - | FStar_Pervasives.Inl b -> - let uu___1 = - let uu___2 = - FStar_Compiler_Range_Ops.string_of_range - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.p in - let uu___3 = - FStar_Class_Show.show FStar_Ident.showable_lident - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - let uu___4 = FStar_Compiler_Util.string_of_bool b in - FStar_Compiler_Util.format3 - "Internal error: (%s) free variable %s not found during extraction (erased=%s)\n" - uu___2 uu___3 uu___4 in - failwith uu___1 -let (lookup_bv : uenv -> FStar_Syntax_Syntax.bv -> ty_or_exp_b) = - fun g -> - fun bv -> - let x = - FStar_Compiler_Util.find_map g.env_bindings - (fun uu___ -> - match uu___ with - | Bv (bv', r) when FStar_Syntax_Syntax.bv_eq bv bv' -> - FStar_Pervasives_Native.Some r - | uu___1 -> FStar_Pervasives_Native.None) in - match x with - | FStar_Pervasives_Native.None -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Ident.range_of_id bv.FStar_Syntax_Syntax.ppname in - FStar_Compiler_Range_Ops.string_of_range uu___2 in - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_bv bv in - FStar_Compiler_Util.format2 "(%s) bound Variable %s not found\n" - uu___1 uu___2 in - failwith uu___ - | FStar_Pervasives_Native.Some y -> y -let (lookup_term : - uenv -> - FStar_Syntax_Syntax.term -> - (ty_or_exp_b * FStar_Syntax_Syntax.fv_qual - FStar_Pervasives_Native.option)) - = - fun g -> - fun t -> - match t.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_name x -> - let uu___ = lookup_bv g x in (uu___, FStar_Pervasives_Native.None) - | FStar_Syntax_Syntax.Tm_fvar x -> - let uu___ = - let uu___1 = lookup_fv t.FStar_Syntax_Syntax.pos g x in - FStar_Pervasives.Inr uu___1 in - (uu___, (x.FStar_Syntax_Syntax.fv_qual)) - | uu___ -> failwith "Impossible: lookup_term for a non-name" -let (lookup_ty : uenv -> FStar_Syntax_Syntax.bv -> ty_binding) = - fun g -> - fun x -> - let uu___ = lookup_bv g x in - match uu___ with - | FStar_Pervasives.Inl ty -> ty - | uu___1 -> failwith "Expected a type name" -let (lookup_tydef : - uenv -> - FStar_Extraction_ML_Syntax.mlpath -> - FStar_Extraction_ML_Syntax.mltyscheme FStar_Pervasives_Native.option) - = - fun env -> - fun uu___ -> - match uu___ with - | (module_name, ty_name) -> - FStar_Compiler_Util.find_map env.tydefs - (fun tydef1 -> - if - (ty_name = tydef1.tydef_name) && - (module_name = tydef1.tydef_mlmodule_name) - then FStar_Pervasives_Native.Some (tydef1.tydef_def) - else FStar_Pervasives_Native.None) -let (has_tydef_declaration : uenv -> FStar_Ident.lident -> Prims.bool) = - fun u -> - fun l -> - let uu___ = - let uu___1 = FStar_Ident.string_of_lid l in - FStar_Compiler_Util.psmap_try_find u.tydef_declarations uu___1 in - match uu___ with - | FStar_Pervasives_Native.None -> false - | FStar_Pervasives_Native.Some b -> b -let (mlpath_of_lident : - uenv -> FStar_Ident.lident -> FStar_Extraction_ML_Syntax.mlpath) = - fun g -> - fun x -> - let uu___ = - let uu___1 = FStar_Ident.string_of_lid x in - FStar_Compiler_Util.psmap_try_find g.mlpath_of_lid uu___1 in - match uu___ with - | FStar_Pervasives_Native.None -> - (debug g - (fun uu___2 -> - (let uu___4 = FStar_Ident.string_of_lid x in - FStar_Compiler_Util.print1 "Identifier not found: %s" uu___4); - (let uu___4 = print_mlpath_map g in - FStar_Compiler_Util.print1 "Env is \n%s\n" uu___4)); - (let uu___2 = - let uu___3 = FStar_Ident.string_of_lid x in - Prims.strcat "Identifier not found: " uu___3 in - failwith uu___2)) - | FStar_Pervasives_Native.Some mlp -> mlp -let (is_type_name : uenv -> FStar_Syntax_Syntax.fv -> Prims.bool) = - fun g -> - fun fv -> - FStar_Compiler_Util.for_some - (fun uu___ -> - match uu___ with | (x, uu___1) -> FStar_Syntax_Syntax.fv_eq fv x) - g.type_names -let (is_fv_type : uenv -> FStar_Syntax_Syntax.fv -> Prims.bool) = - fun g -> - fun fv -> - (is_type_name g fv) || - (FStar_Compiler_Util.for_some - (fun tydef1 -> FStar_Syntax_Syntax.fv_eq fv tydef1.tydef_fv) - g.tydefs) -let (no_fstar_stubs_ns : - FStar_Extraction_ML_Syntax.mlsymbol Prims.list -> - FStar_Extraction_ML_Syntax.mlsymbol Prims.list) - = - fun ns -> - match ns with | "FStar"::"Stubs"::rest -> "FStar" :: rest | uu___ -> ns -let (no_fstar_stubs : - FStar_Extraction_ML_Syntax.mlpath -> FStar_Extraction_ML_Syntax.mlpath) = - fun p -> - let uu___ = p in - match uu___ with - | (ns, id) -> let ns1 = no_fstar_stubs_ns ns in (ns1, id) -let (lookup_record_field_name : - uenv -> - (FStar_Ident.lident * FStar_Ident.ident) -> - FStar_Extraction_ML_Syntax.mlpath) - = - fun g -> - fun uu___ -> - match uu___ with - | (type_name, fn) -> - let key = - let uu___1 = - let uu___2 = FStar_Ident.ids_of_lid type_name in - FStar_Compiler_List.op_At uu___2 [fn] in - FStar_Ident.lid_of_ids uu___1 in - let uu___1 = - let uu___2 = FStar_Ident.string_of_lid key in - FStar_Compiler_Util.psmap_try_find g.mlpath_of_fieldname uu___2 in - (match uu___1 with - | FStar_Pervasives_Native.None -> - let uu___2 = - let uu___3 = FStar_Ident.string_of_lid key in - Prims.strcat "Field name not found: " uu___3 in - failwith uu___2 - | FStar_Pervasives_Native.Some mlp -> - let uu___2 = mlp in - (match uu___2 with - | (ns, id) -> - let uu___3 = - FStar_Compiler_List.filter (fun s -> s <> "Stubs") ns in - (uu___3, id))) -let (initial_mlident_map : unit -> Prims.string FStar_Compiler_Util.psmap) = - let map = FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None in - fun uu___ -> - let uu___1 = FStar_Compiler_Effect.op_Bang map in - match uu___1 with - | FStar_Pervasives_Native.Some m -> m - | FStar_Pervasives_Native.None -> - let m = - let uu___2 = - let uu___3 = FStar_Options.codegen () in - match uu___3 with - | FStar_Pervasives_Native.Some (FStar_Options.FSharp) -> - FStar_Extraction_ML_Syntax.fsharpkeywords - | FStar_Pervasives_Native.Some (FStar_Options.OCaml) -> - FStar_Extraction_ML_Syntax.ocamlkeywords - | FStar_Pervasives_Native.Some (FStar_Options.Plugin) -> - FStar_Extraction_ML_Syntax.ocamlkeywords - | FStar_Pervasives_Native.Some (FStar_Options.Krml) -> - FStar_Extraction_ML_Syntax.krml_keywords - | FStar_Pervasives_Native.Some (FStar_Options.Extension) -> [] - | FStar_Pervasives_Native.None -> [] in - let uu___3 = FStar_Compiler_Util.psmap_empty () in - FStar_Compiler_List.fold_right - (fun x -> fun m1 -> FStar_Compiler_Util.psmap_add m1 x "") uu___2 - uu___3 in - (FStar_Compiler_Effect.op_Colon_Equals map - (FStar_Pervasives_Native.Some m); - m) -let (rename_conventional : Prims.string -> Prims.bool -> Prims.string) = - fun s -> - fun is_local_type_variable -> - let cs = FStar_String.list_of_string s in - let sanitize_typ uu___ = - let valid_rest c = FStar_Compiler_Util.is_letter_or_digit c in - let aux cs1 = - FStar_Compiler_List.map - (fun x -> let uu___1 = valid_rest x in if uu___1 then x else 117) - cs1 in - let uu___1 = let uu___2 = FStar_Compiler_List.hd cs in uu___2 = 39 in - if uu___1 - then - let uu___2 = FStar_Compiler_List.hd cs in - let uu___3 = let uu___4 = FStar_Compiler_List.tail cs in aux uu___4 in - uu___2 :: uu___3 - else (let uu___3 = aux cs in 39 :: uu___3) in - let sanitize_term uu___ = - let valid c = - ((FStar_Compiler_Util.is_letter_or_digit c) || (c = 95)) || - (c = 39) in - let cs' = - FStar_Compiler_List.fold_right - (fun c -> - fun cs1 -> - let uu___1 = - let uu___2 = valid c in if uu___2 then [c] else [95; 95] in - FStar_Compiler_List.op_At uu___1 cs1) cs [] in - match cs' with - | c::cs1 when (FStar_Compiler_Util.is_digit c) || (c = 39) -> 95 :: c - :: cs1 - | uu___1 -> cs in - let uu___ = - if is_local_type_variable then sanitize_typ () else sanitize_term () in - FStar_String.string_of_list uu___ -let (root_name_of_bv : - FStar_Syntax_Syntax.bv -> FStar_Extraction_ML_Syntax.mlident) = - fun x -> - let uu___ = - (let uu___1 = FStar_Ident.string_of_id x.FStar_Syntax_Syntax.ppname in - FStar_Compiler_Util.starts_with uu___1 FStar_Ident.reserved_prefix) || - (FStar_Syntax_Syntax.is_null_bv x) in - if uu___ - then FStar_Ident.reserved_prefix - else FStar_Ident.string_of_id x.FStar_Syntax_Syntax.ppname -let (find_uniq : - Prims.string FStar_Compiler_Util.psmap -> - Prims.string -> - Prims.bool -> (Prims.string * Prims.string FStar_Compiler_Util.psmap)) - = - fun ml_ident_map -> - fun root_name -> - fun is_local_type_variable -> - let rec aux i root_name1 = - let target_mlident = - if i = Prims.int_zero - then root_name1 - else - (let uu___1 = FStar_Compiler_Util.string_of_int i in - Prims.strcat root_name1 uu___1) in - let uu___ = - FStar_Compiler_Util.psmap_try_find ml_ident_map target_mlident in - match uu___ with - | FStar_Pervasives_Native.Some x -> - aux (i + Prims.int_one) root_name1 - | FStar_Pervasives_Native.None -> - let map = - FStar_Compiler_Util.psmap_add ml_ident_map target_mlident "" in - (target_mlident, map) in - let mlident = rename_conventional root_name is_local_type_variable in - if is_local_type_variable - then - let uu___ = - let uu___1 = - FStar_Compiler_Util.substring_from mlident Prims.int_one in - aux Prims.int_zero uu___1 in - match uu___ with | (nm, map) -> ((Prims.strcat "'" nm), map) - else aux Prims.int_zero mlident -let (mlns_of_lid : - FStar_Ident.lident -> FStar_Extraction_ML_Syntax.mlsymbol Prims.list) = - fun x -> - let uu___ = - let uu___1 = FStar_Ident.ns_of_lid x in - FStar_Compiler_List.map FStar_Ident.string_of_id uu___1 in - no_fstar_stubs_ns uu___ -let (new_mlpath_of_lident : - uenv -> FStar_Ident.lident -> (FStar_Extraction_ML_Syntax.mlpath * uenv)) = - fun g -> - fun x -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Parser_Const.failwith_lid () in - FStar_Ident.lid_equals x uu___2 in - if uu___1 - then - let uu___2 = - let uu___3 = - let uu___4 = FStar_Ident.ident_of_lid x in - FStar_Ident.string_of_id uu___4 in - ([], uu___3) in - (uu___2, g) - else - (let uu___3 = - let uu___4 = - let uu___5 = FStar_Ident.ident_of_lid x in - FStar_Ident.string_of_id uu___5 in - find_uniq g.env_mlident_map uu___4 false in - match uu___3 with - | (name, map) -> - let g1 = - { - env_tcenv = (g.env_tcenv); - env_bindings = (g.env_bindings); - env_mlident_map = map; - env_remove_typars = (g.env_remove_typars); - mlpath_of_lid = (g.mlpath_of_lid); - env_fieldname_map = (g.env_fieldname_map); - mlpath_of_fieldname = (g.mlpath_of_fieldname); - tydefs = (g.tydefs); - type_names = (g.type_names); - tydef_declarations = (g.tydef_declarations); - currentModule = (g.currentModule) - } in - let uu___4 = let uu___5 = mlns_of_lid x in (uu___5, name) in - (uu___4, g1)) in - match uu___ with - | (mlp, g1) -> - let g2 = - let uu___1 = - let uu___2 = FStar_Ident.string_of_lid x in - FStar_Compiler_Util.psmap_add g1.mlpath_of_lid uu___2 mlp in - { - env_tcenv = (g1.env_tcenv); - env_bindings = (g1.env_bindings); - env_mlident_map = (g1.env_mlident_map); - env_remove_typars = (g1.env_remove_typars); - mlpath_of_lid = uu___1; - env_fieldname_map = (g1.env_fieldname_map); - mlpath_of_fieldname = (g1.mlpath_of_fieldname); - tydefs = (g1.tydefs); - type_names = (g1.type_names); - tydef_declarations = (g1.tydef_declarations); - currentModule = (g1.currentModule) - } in - (mlp, g2) -let (extend_ty : uenv -> FStar_Syntax_Syntax.bv -> Prims.bool -> uenv) = - fun g -> - fun a -> - fun map_to_top -> - let is_local_type_variable = Prims.op_Negation map_to_top in - let uu___ = - let uu___1 = root_name_of_bv a in - find_uniq g.env_mlident_map uu___1 is_local_type_variable in - match uu___ with - | (ml_a, mlident_map) -> - let mapped_to = - if map_to_top - then FStar_Extraction_ML_Syntax.MLTY_Top - else FStar_Extraction_ML_Syntax.MLTY_Var ml_a in - let gamma = - (Bv - (a, - (FStar_Pervasives.Inl - { ty_b_name = ml_a; ty_b_ty = mapped_to }))) - :: (g.env_bindings) in - let tcenv = FStar_TypeChecker_Env.push_bv g.env_tcenv a in - { - env_tcenv = tcenv; - env_bindings = gamma; - env_mlident_map = mlident_map; - env_remove_typars = (g.env_remove_typars); - mlpath_of_lid = (g.mlpath_of_lid); - env_fieldname_map = (g.env_fieldname_map); - mlpath_of_fieldname = (g.mlpath_of_fieldname); - tydefs = (g.tydefs); - type_names = (g.type_names); - tydef_declarations = (g.tydef_declarations); - currentModule = (g.currentModule) - } -let (extend_bv : - uenv -> - FStar_Syntax_Syntax.bv -> - FStar_Extraction_ML_Syntax.mltyscheme -> - Prims.bool -> - Prims.bool -> - (uenv * FStar_Extraction_ML_Syntax.mlident * exp_binding)) - = - fun g -> - fun x -> - fun t_x -> - fun add_unit -> - fun mk_unit -> - let ml_ty = - match t_x with - | ([], t) -> t - | uu___ -> FStar_Extraction_ML_Syntax.MLTY_Top in - let uu___ = - let uu___1 = root_name_of_bv x in - find_uniq g.env_mlident_map uu___1 false in - match uu___ with - | (mlident, mlident_map) -> - let mlx = FStar_Extraction_ML_Syntax.MLE_Var mlident in - let mlx1 = - if mk_unit - then FStar_Extraction_ML_Syntax.ml_unit - else - if add_unit - then - (let uu___2 = - let uu___3 = - let uu___4 = - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.MLTY_Top mlx in - (uu___4, [FStar_Extraction_ML_Syntax.ml_unit]) in - FStar_Extraction_ML_Syntax.MLE_App uu___3 in - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.MLTY_Top uu___2) - else FStar_Extraction_ML_Syntax.with_ty ml_ty mlx in - let uu___1 = - if add_unit - then FStar_Extraction_ML_Syntax.pop_unit t_x - else (FStar_Extraction_ML_Syntax.E_PURE, t_x) in - (match uu___1 with - | (eff, t_x1) -> - let exp_binding1 = - { - exp_b_name = mlident; - exp_b_expr = mlx1; - exp_b_tscheme = t_x1; - exp_b_eff = eff - } in - let gamma = - (Bv (x, (FStar_Pervasives.Inr exp_binding1))) :: - (g.env_bindings) in - let tcenv = - let uu___2 = FStar_Syntax_Syntax.binders_of_list [x] in - FStar_TypeChecker_Env.push_binders g.env_tcenv uu___2 in - ({ - env_tcenv = tcenv; - env_bindings = gamma; - env_mlident_map = mlident_map; - env_remove_typars = (g.env_remove_typars); - mlpath_of_lid = (g.mlpath_of_lid); - env_fieldname_map = (g.env_fieldname_map); - mlpath_of_fieldname = (g.mlpath_of_fieldname); - tydefs = (g.tydefs); - type_names = (g.type_names); - tydef_declarations = (g.tydef_declarations); - currentModule = (g.currentModule) - }, mlident, exp_binding1)) -let (burn_name : uenv -> FStar_Extraction_ML_Syntax.mlident -> uenv) = - fun g -> - fun i -> - let uu___ = FStar_Compiler_Util.psmap_add g.env_mlident_map i "" in - { - env_tcenv = (g.env_tcenv); - env_bindings = (g.env_bindings); - env_mlident_map = uu___; - env_remove_typars = (g.env_remove_typars); - mlpath_of_lid = (g.mlpath_of_lid); - env_fieldname_map = (g.env_fieldname_map); - mlpath_of_fieldname = (g.mlpath_of_fieldname); - tydefs = (g.tydefs); - type_names = (g.type_names); - tydef_declarations = (g.tydef_declarations); - currentModule = (g.currentModule) - } -let (new_mlident : uenv -> (uenv * FStar_Extraction_ML_Syntax.mlident)) = - fun g -> - let ml_ty = FStar_Extraction_ML_Syntax.MLTY_Top in - let x = - FStar_Syntax_Syntax.new_bv FStar_Pervasives_Native.None - FStar_Syntax_Syntax.tun in - let uu___ = - extend_bv g x ([], FStar_Extraction_ML_Syntax.MLTY_Top) false false in - match uu___ with | (g1, id, uu___1) -> (g1, id) -let (extend_fv : - uenv -> - FStar_Syntax_Syntax.fv -> - FStar_Extraction_ML_Syntax.mltyscheme -> - Prims.bool -> - (uenv * FStar_Extraction_ML_Syntax.mlident * exp_binding)) - = - fun g -> - fun x -> - fun t_x -> - fun add_unit -> - let rec mltyFvars t = - match t with - | FStar_Extraction_ML_Syntax.MLTY_Var x1 -> [x1] - | FStar_Extraction_ML_Syntax.MLTY_Fun (t1, f, t2) -> - let uu___ = mltyFvars t1 in - let uu___1 = mltyFvars t2 in - FStar_Compiler_List.append uu___ uu___1 - | FStar_Extraction_ML_Syntax.MLTY_Named (args, path) -> - FStar_Compiler_List.collect mltyFvars args - | FStar_Extraction_ML_Syntax.MLTY_Tuple ts -> - FStar_Compiler_List.collect mltyFvars ts - | FStar_Extraction_ML_Syntax.MLTY_Top -> [] - | FStar_Extraction_ML_Syntax.MLTY_Erased -> [] in - let rec subsetMlidents la lb = - match la with - | h::tla -> - (FStar_Compiler_List.contains h lb) && - (subsetMlidents tla lb) - | [] -> true in - let tySchemeIsClosed tys = - let uu___ = mltyFvars (FStar_Pervasives_Native.snd tys) in - let uu___1 = - FStar_Extraction_ML_Syntax.ty_param_names - (FStar_Pervasives_Native.fst tys) in - subsetMlidents uu___ uu___1 in - let uu___ = tySchemeIsClosed t_x in - if uu___ - then - let ml_ty = - match t_x with - | ([], t) -> t - | uu___1 -> FStar_Extraction_ML_Syntax.MLTY_Top in - let uu___1 = - new_mlpath_of_lident g - (x.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - match uu___1 with - | (mlpath, g1) -> - let mlsymbol = FStar_Pervasives_Native.snd mlpath in - let mly = FStar_Extraction_ML_Syntax.MLE_Name mlpath in - let mly1 = - if add_unit - then - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.MLTY_Top mly in - (uu___4, [FStar_Extraction_ML_Syntax.ml_unit]) in - FStar_Extraction_ML_Syntax.MLE_App uu___3 in - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.MLTY_Top uu___2 - else FStar_Extraction_ML_Syntax.with_ty ml_ty mly in - let uu___2 = - if add_unit - then FStar_Extraction_ML_Syntax.pop_unit t_x - else (FStar_Extraction_ML_Syntax.E_PURE, t_x) in - (match uu___2 with - | (eff, t_x1) -> - let exp_binding1 = - { - exp_b_name = mlsymbol; - exp_b_expr = mly1; - exp_b_tscheme = t_x1; - exp_b_eff = eff - } in - let gamma = (Fv (x, exp_binding1)) :: (g1.env_bindings) in - let mlident_map = - FStar_Compiler_Util.psmap_add g1.env_mlident_map - mlsymbol "" in - ({ - env_tcenv = (g1.env_tcenv); - env_bindings = gamma; - env_mlident_map = mlident_map; - env_remove_typars = (g1.env_remove_typars); - mlpath_of_lid = (g1.mlpath_of_lid); - env_fieldname_map = (g1.env_fieldname_map); - mlpath_of_fieldname = (g1.mlpath_of_fieldname); - tydefs = (g1.tydefs); - type_names = (g1.type_names); - tydef_declarations = (g1.tydef_declarations); - currentModule = (g1.currentModule) - }, mlsymbol, exp_binding1)) - else - (let uu___2 = - let uu___3 = - FStar_Extraction_ML_Syntax.mltyscheme_to_string t_x in - FStar_Compiler_Util.format1 "freevars found (%s)" uu___3 in - failwith uu___2) -let (extend_erased_fv : uenv -> FStar_Syntax_Syntax.fv -> uenv) = - fun g -> - fun f -> - { - env_tcenv = (g.env_tcenv); - env_bindings = ((ErasedFv f) :: (g.env_bindings)); - env_mlident_map = (g.env_mlident_map); - env_remove_typars = (g.env_remove_typars); - mlpath_of_lid = (g.mlpath_of_lid); - env_fieldname_map = (g.env_fieldname_map); - mlpath_of_fieldname = (g.mlpath_of_fieldname); - tydefs = (g.tydefs); - type_names = (g.type_names); - tydef_declarations = (g.tydef_declarations); - currentModule = (g.currentModule) - } -let (extend_lb : - uenv -> - FStar_Syntax_Syntax.lbname -> - FStar_Syntax_Syntax.typ -> - FStar_Extraction_ML_Syntax.mltyscheme -> - Prims.bool -> - (uenv * FStar_Extraction_ML_Syntax.mlident * exp_binding)) - = - fun g -> - fun l -> - fun t -> - fun t_x -> - fun add_unit -> - match l with - | FStar_Pervasives.Inl x -> extend_bv g x t_x add_unit false - | FStar_Pervasives.Inr f -> extend_fv g f t_x add_unit -let (extend_tydef : - uenv -> - FStar_Syntax_Syntax.fv -> - FStar_Extraction_ML_Syntax.mltyscheme -> - FStar_Extraction_ML_Syntax.metadata -> - (tydef * FStar_Extraction_ML_Syntax.mlpath * uenv)) - = - fun g -> - fun fv -> - fun ts -> - fun meta -> - let uu___ = - new_mlpath_of_lident g - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - match uu___ with - | (name, g1) -> - let tydef1 = - { - tydef_fv = fv; - tydef_mlmodule_name = (FStar_Pervasives_Native.fst name); - tydef_name = (FStar_Pervasives_Native.snd name); - tydef_meta = meta; - tydef_def = ts - } in - (tydef1, name, - { - env_tcenv = (g1.env_tcenv); - env_bindings = (g1.env_bindings); - env_mlident_map = (g1.env_mlident_map); - env_remove_typars = (g1.env_remove_typars); - mlpath_of_lid = (g1.mlpath_of_lid); - env_fieldname_map = (g1.env_fieldname_map); - mlpath_of_fieldname = (g1.mlpath_of_fieldname); - tydefs = (tydef1 :: (g1.tydefs)); - type_names = ((fv, name) :: (g1.type_names)); - tydef_declarations = (g1.tydef_declarations); - currentModule = (g1.currentModule) - }) -let (extend_with_tydef_declaration : uenv -> FStar_Ident.lident -> uenv) = - fun u -> - fun l -> - let uu___ = - let uu___1 = FStar_Ident.string_of_lid l in - FStar_Compiler_Util.psmap_add u.tydef_declarations uu___1 true in - { - env_tcenv = (u.env_tcenv); - env_bindings = (u.env_bindings); - env_mlident_map = (u.env_mlident_map); - env_remove_typars = (u.env_remove_typars); - mlpath_of_lid = (u.mlpath_of_lid); - env_fieldname_map = (u.env_fieldname_map); - mlpath_of_fieldname = (u.mlpath_of_fieldname); - tydefs = (u.tydefs); - type_names = (u.type_names); - tydef_declarations = uu___; - currentModule = (u.currentModule) - } -let (extend_type_name : - uenv -> - FStar_Syntax_Syntax.fv -> (FStar_Extraction_ML_Syntax.mlpath * uenv)) - = - fun g -> - fun fv -> - let uu___ = - new_mlpath_of_lident g - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - match uu___ with - | (name, g1) -> - (name, - { - env_tcenv = (g1.env_tcenv); - env_bindings = (g1.env_bindings); - env_mlident_map = (g1.env_mlident_map); - env_remove_typars = (g1.env_remove_typars); - mlpath_of_lid = (g1.mlpath_of_lid); - env_fieldname_map = (g1.env_fieldname_map); - mlpath_of_fieldname = (g1.mlpath_of_fieldname); - tydefs = (g1.tydefs); - type_names = ((fv, name) :: (g1.type_names)); - tydef_declarations = (g1.tydef_declarations); - currentModule = (g1.currentModule) - }) -let (extend_with_monad_op_name : - uenv -> - FStar_Syntax_Syntax.eff_decl -> - Prims.string -> - FStar_Extraction_ML_Syntax.mltyscheme -> - (FStar_Extraction_ML_Syntax.mlpath * FStar_Ident.lident * - exp_binding * uenv)) - = - fun g -> - fun ed -> - fun nm -> - fun ts -> - let lid = - let uu___ = FStar_Ident.id_of_text nm in - FStar_Syntax_Util.mk_field_projector_name_from_ident - ed.FStar_Syntax_Syntax.mname uu___ in - let uu___ = - let uu___1 = - FStar_Syntax_Syntax.lid_as_fv lid FStar_Pervasives_Native.None in - extend_fv g uu___1 ts false in - match uu___ with - | (g1, mlid, exp_b) -> - let mlp = let uu___1 = mlns_of_lid lid in (uu___1, mlid) in - (mlp, lid, exp_b, g1) -let (extend_with_action_name : - uenv -> - FStar_Syntax_Syntax.eff_decl -> - FStar_Syntax_Syntax.action -> - FStar_Extraction_ML_Syntax.mltyscheme -> - (FStar_Extraction_ML_Syntax.mlpath * FStar_Ident.lident * - exp_binding * uenv)) - = - fun g -> - fun ed -> - fun a -> - fun ts -> - let nm = - let uu___ = - FStar_Ident.ident_of_lid a.FStar_Syntax_Syntax.action_name in - FStar_Ident.string_of_id uu___ in - let module_name = - FStar_Ident.ns_of_lid ed.FStar_Syntax_Syntax.mname in - let lid = - let uu___ = - let uu___1 = let uu___2 = FStar_Ident.id_of_text nm in [uu___2] in - FStar_Compiler_List.op_At module_name uu___1 in - FStar_Ident.lid_of_ids uu___ in - let uu___ = - let uu___1 = - FStar_Syntax_Syntax.lid_as_fv lid FStar_Pervasives_Native.None in - extend_fv g uu___1 ts false in - match uu___ with - | (g1, mlid, exp_b) -> - let mlp = let uu___1 = mlns_of_lid lid in (uu___1, mlid) in - (mlp, lid, exp_b, g1) -let (extend_record_field_name : - uenv -> - (FStar_Ident.lident * FStar_Ident.ident) -> - (FStar_Extraction_ML_Syntax.mlident * uenv)) - = - fun g -> - fun uu___ -> - match uu___ with - | (type_name, fn) -> - let key = - let uu___1 = - let uu___2 = FStar_Ident.ids_of_lid type_name in - FStar_Compiler_List.op_At uu___2 [fn] in - FStar_Ident.lid_of_ids uu___1 in - let uu___1 = - let uu___2 = FStar_Ident.string_of_id fn in - find_uniq g.env_fieldname_map uu___2 false in - (match uu___1 with - | (name, fieldname_map) -> - let ns = mlns_of_lid type_name in - let mlp = (ns, name) in - let mlp1 = no_fstar_stubs mlp in - let g1 = - let uu___2 = - let uu___3 = FStar_Ident.string_of_lid key in - FStar_Compiler_Util.psmap_add g.mlpath_of_fieldname uu___3 - mlp1 in - { - env_tcenv = (g.env_tcenv); - env_bindings = (g.env_bindings); - env_mlident_map = (g.env_mlident_map); - env_remove_typars = (g.env_remove_typars); - mlpath_of_lid = (g.mlpath_of_lid); - env_fieldname_map = fieldname_map; - mlpath_of_fieldname = uu___2; - tydefs = (g.tydefs); - type_names = (g.type_names); - tydef_declarations = (g.tydef_declarations); - currentModule = (g.currentModule) - } in - (name, g1)) -let (extend_with_module_name : - uenv -> FStar_Ident.lident -> (FStar_Extraction_ML_Syntax.mlpath * uenv)) = - fun g -> - fun m -> - let ns = mlns_of_lid m in - let p = - let uu___ = FStar_Ident.ident_of_lid m in - FStar_Ident.string_of_id uu___ in - ((ns, p), g) -let (exit_module : uenv -> uenv) = - fun g -> - let uu___ = initial_mlident_map () in - let uu___1 = initial_mlident_map () in - { - env_tcenv = (g.env_tcenv); - env_bindings = (g.env_bindings); - env_mlident_map = uu___; - env_remove_typars = (g.env_remove_typars); - mlpath_of_lid = (g.mlpath_of_lid); - env_fieldname_map = uu___1; - mlpath_of_fieldname = (g.mlpath_of_fieldname); - tydefs = (g.tydefs); - type_names = (g.type_names); - tydef_declarations = (g.tydef_declarations); - currentModule = (g.currentModule) - } -let (new_uenv : FStar_TypeChecker_Env.env -> uenv) = - fun e -> - let env = - let uu___ = initial_mlident_map () in - let uu___1 = FStar_Compiler_Util.psmap_empty () in - let uu___2 = initial_mlident_map () in - let uu___3 = FStar_Compiler_Util.psmap_empty () in - let uu___4 = FStar_Compiler_Util.psmap_empty () in - { - env_tcenv = e; - env_bindings = []; - env_mlident_map = uu___; - env_remove_typars = - FStar_Extraction_ML_RemoveUnusedParameters.initial_env; - mlpath_of_lid = uu___1; - env_fieldname_map = uu___2; - mlpath_of_fieldname = uu___3; - tydefs = []; - type_names = []; - tydef_declarations = uu___4; - currentModule = ([], "") - } in - let a = "'a" in - let failwith_ty = - ([{ - FStar_Extraction_ML_Syntax.ty_param_name = a; - FStar_Extraction_ML_Syntax.ty_param_attrs = [] - }], - (FStar_Extraction_ML_Syntax.MLTY_Fun - ((FStar_Extraction_ML_Syntax.MLTY_Named - ([], (["Prims"], "string"))), - FStar_Extraction_ML_Syntax.E_IMPURE, - (FStar_Extraction_ML_Syntax.MLTY_Var a)))) in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Parser_Const.failwith_lid () in - FStar_Syntax_Syntax.lid_as_fv uu___3 FStar_Pervasives_Native.None in - FStar_Pervasives.Inr uu___2 in - extend_lb env uu___1 FStar_Syntax_Syntax.tun failwith_ty false in - match uu___ with | (g, uu___1, uu___2) -> g \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Extraction_ML_Util.ml b/ocaml/fstar-lib/generated/FStar_Extraction_ML_Util.ml deleted file mode 100644 index cda4fdc7e87..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Extraction_ML_Util.ml +++ /dev/null @@ -1,734 +0,0 @@ -open Prims -let (codegen_fsharp : unit -> Prims.bool) = - fun uu___ -> - let uu___1 = FStar_Options.codegen () in - uu___1 = (FStar_Pervasives_Native.Some FStar_Options.FSharp) -let pruneNones : - 'a . 'a FStar_Pervasives_Native.option Prims.list -> 'a Prims.list = - fun l -> - FStar_Compiler_List.fold_right - (fun x -> - fun ll -> - match x with - | FStar_Pervasives_Native.Some xs -> xs :: ll - | FStar_Pervasives_Native.None -> ll) l [] -let (mk_range_mle : FStar_Extraction_ML_Syntax.mlexpr) = - FStar_Extraction_ML_Syntax.with_ty FStar_Extraction_ML_Syntax.MLTY_Top - (FStar_Extraction_ML_Syntax.MLE_Name (["FStar"; "Range"], "mk_range")) -let (dummy_range_mle : FStar_Extraction_ML_Syntax.mlexpr) = - FStar_Extraction_ML_Syntax.with_ty FStar_Extraction_ML_Syntax.MLTY_Top - (FStar_Extraction_ML_Syntax.MLE_Name (["FStar"; "Range"], "dummyRange")) -let (mlconst_of_const' : - FStar_Const.sconst -> FStar_Extraction_ML_Syntax.mlconstant) = - fun sctt -> - match sctt with - | FStar_Const.Const_effect -> failwith "Unsupported constant" - | FStar_Const.Const_range uu___ -> FStar_Extraction_ML_Syntax.MLC_Unit - | FStar_Const.Const_unit -> FStar_Extraction_ML_Syntax.MLC_Unit - | FStar_Const.Const_char c -> FStar_Extraction_ML_Syntax.MLC_Char c - | FStar_Const.Const_int (s, i) -> - FStar_Extraction_ML_Syntax.MLC_Int (s, i) - | FStar_Const.Const_bool b -> FStar_Extraction_ML_Syntax.MLC_Bool b - | FStar_Const.Const_string (s, uu___) -> - FStar_Extraction_ML_Syntax.MLC_String s - | FStar_Const.Const_range_of -> - failwith "Unhandled constant: range_of/set_range_of" - | FStar_Const.Const_set_range_of -> - failwith "Unhandled constant: range_of/set_range_of" - | FStar_Const.Const_real uu___ -> - failwith "Unhandled constant: real/reify/reflect" - | FStar_Const.Const_reify uu___ -> - failwith "Unhandled constant: real/reify/reflect" - | FStar_Const.Const_reflect uu___ -> - failwith "Unhandled constant: real/reify/reflect" -let (mlconst_of_const : - FStar_Compiler_Range_Type.range -> - FStar_Const.sconst -> FStar_Extraction_ML_Syntax.mlconstant) - = - fun p -> - fun c -> - try (fun uu___ -> match () with | () -> mlconst_of_const' c) () - with - | uu___ -> - let uu___1 = - let uu___2 = FStar_Compiler_Range_Ops.string_of_range p in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_const c in - FStar_Compiler_Util.format2 - "(%s) Failed to translate constant %s " uu___2 uu___3 in - failwith uu___1 -let (mlexpr_of_range : - FStar_Compiler_Range_Type.range -> FStar_Extraction_ML_Syntax.mlexpr') = - fun r -> - let cint i = - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Compiler_Util.string_of_int i in - (uu___3, FStar_Pervasives_Native.None) in - FStar_Extraction_ML_Syntax.MLC_Int uu___2 in - FStar_Extraction_ML_Syntax.MLE_Const uu___1 in - FStar_Extraction_ML_Syntax.with_ty FStar_Extraction_ML_Syntax.ml_int_ty - uu___ in - let cstr s = - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.ml_string_ty - (FStar_Extraction_ML_Syntax.MLE_Const - (FStar_Extraction_ML_Syntax.MLC_String s)) in - let drop_path = FStar_Compiler_Util.basename in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Compiler_Range_Ops.file_of_range r in - drop_path uu___4 in - cstr uu___3 in - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = FStar_Compiler_Range_Ops.start_of_range r in - FStar_Compiler_Range_Ops.line_of_pos uu___6 in - cint uu___5 in - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = FStar_Compiler_Range_Ops.start_of_range r in - FStar_Compiler_Range_Ops.col_of_pos uu___8 in - cint uu___7 in - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = FStar_Compiler_Range_Ops.end_of_range r in - FStar_Compiler_Range_Ops.line_of_pos uu___10 in - cint uu___9 in - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = FStar_Compiler_Range_Ops.end_of_range r in - FStar_Compiler_Range_Ops.col_of_pos uu___12 in - cint uu___11 in - [uu___10] in - uu___8 :: uu___9 in - uu___6 :: uu___7 in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - (mk_range_mle, uu___1) in - FStar_Extraction_ML_Syntax.MLE_App uu___ -let (mlexpr_of_const : - FStar_Compiler_Range_Type.range -> - FStar_Const.sconst -> FStar_Extraction_ML_Syntax.mlexpr') - = - fun p -> - fun c -> - match c with - | FStar_Const.Const_range r -> mlexpr_of_range r - | uu___ -> - let uu___1 = mlconst_of_const p c in - FStar_Extraction_ML_Syntax.MLE_Const uu___1 -let rec (subst_aux : - (FStar_Extraction_ML_Syntax.mlident * FStar_Extraction_ML_Syntax.mlty) - Prims.list -> - FStar_Extraction_ML_Syntax.mlty -> FStar_Extraction_ML_Syntax.mlty) - = - fun subst -> - fun t -> - match t with - | FStar_Extraction_ML_Syntax.MLTY_Var x -> - let uu___ = - FStar_Compiler_Util.find_opt - (fun uu___1 -> match uu___1 with | (y, uu___2) -> y = x) subst in - (match uu___ with - | FStar_Pervasives_Native.Some ts -> - FStar_Pervasives_Native.snd ts - | FStar_Pervasives_Native.None -> t) - | FStar_Extraction_ML_Syntax.MLTY_Fun (t1, f, t2) -> - let uu___ = - let uu___1 = subst_aux subst t1 in - let uu___2 = subst_aux subst t2 in (uu___1, f, uu___2) in - FStar_Extraction_ML_Syntax.MLTY_Fun uu___ - | FStar_Extraction_ML_Syntax.MLTY_Named (args, path) -> - let uu___ = - let uu___1 = FStar_Compiler_List.map (subst_aux subst) args in - (uu___1, path) in - FStar_Extraction_ML_Syntax.MLTY_Named uu___ - | FStar_Extraction_ML_Syntax.MLTY_Tuple ts -> - let uu___ = FStar_Compiler_List.map (subst_aux subst) ts in - FStar_Extraction_ML_Syntax.MLTY_Tuple uu___ - | FStar_Extraction_ML_Syntax.MLTY_Top -> t - | FStar_Extraction_ML_Syntax.MLTY_Erased -> t -let (try_subst : - FStar_Extraction_ML_Syntax.mltyscheme -> - FStar_Extraction_ML_Syntax.mlty Prims.list -> - FStar_Extraction_ML_Syntax.mlty FStar_Pervasives_Native.option) - = - fun uu___ -> - fun args -> - match uu___ with - | (formals, t) -> - if - (FStar_Compiler_List.length formals) <> - (FStar_Compiler_List.length args) - then FStar_Pervasives_Native.None - else - (let uu___2 = - let uu___3 = - let uu___4 = - FStar_Extraction_ML_Syntax.ty_param_names formals in - FStar_Compiler_List.zip uu___4 args in - subst_aux uu___3 t in - FStar_Pervasives_Native.Some uu___2) -let (subst : - (FStar_Extraction_ML_Syntax.ty_param Prims.list * - FStar_Extraction_ML_Syntax.mlty) -> - FStar_Extraction_ML_Syntax.mlty Prims.list -> - FStar_Extraction_ML_Syntax.mlty) - = - fun ts -> - fun args -> - let uu___ = try_subst ts args in - match uu___ with - | FStar_Pervasives_Native.None -> - failwith - "Substitution must be fully applied (see GitHub issue #490)" - | FStar_Pervasives_Native.Some t -> t -let (udelta_unfold : - FStar_Extraction_ML_UEnv.uenv -> - FStar_Extraction_ML_Syntax.mlty -> - FStar_Extraction_ML_Syntax.mlty FStar_Pervasives_Native.option) - = - fun g -> - fun uu___ -> - match uu___ with - | FStar_Extraction_ML_Syntax.MLTY_Named (args, n) -> - let uu___1 = FStar_Extraction_ML_UEnv.lookup_tydef g n in - (match uu___1 with - | FStar_Pervasives_Native.Some ts -> - let uu___2 = try_subst ts args in - (match uu___2 with - | FStar_Pervasives_Native.None -> - let uu___3 = - let uu___4 = - FStar_Extraction_ML_Syntax.string_of_mlpath n in - let uu___5 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length args) in - let uu___6 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length - (FStar_Pervasives_Native.fst ts)) in - FStar_Compiler_Util.format3 - "Substitution must be fully applied; got an application of %s with %s args whereas %s were expected (see GitHub issue #490)" - uu___4 uu___5 uu___6 in - failwith uu___3 - | FStar_Pervasives_Native.Some r -> - FStar_Pervasives_Native.Some r) - | uu___2 -> FStar_Pervasives_Native.None) - | uu___1 -> FStar_Pervasives_Native.None -let (eff_leq : - FStar_Extraction_ML_Syntax.e_tag -> - FStar_Extraction_ML_Syntax.e_tag -> Prims.bool) - = - fun f -> - fun f' -> - match (f, f') with - | (FStar_Extraction_ML_Syntax.E_PURE, uu___) -> true - | (FStar_Extraction_ML_Syntax.E_ERASABLE, - FStar_Extraction_ML_Syntax.E_ERASABLE) -> true - | (FStar_Extraction_ML_Syntax.E_IMPURE, - FStar_Extraction_ML_Syntax.E_IMPURE) -> true - | uu___ -> false -let (eff_to_string : FStar_Extraction_ML_Syntax.e_tag -> Prims.string) = - fun uu___ -> - match uu___ with - | FStar_Extraction_ML_Syntax.E_PURE -> "Pure" - | FStar_Extraction_ML_Syntax.E_ERASABLE -> "Erasable" - | FStar_Extraction_ML_Syntax.E_IMPURE -> "Impure" -let (join : - FStar_Compiler_Range_Type.range -> - FStar_Extraction_ML_Syntax.e_tag -> - FStar_Extraction_ML_Syntax.e_tag -> FStar_Extraction_ML_Syntax.e_tag) - = - fun r -> - fun f -> - fun f' -> - match (f, f') with - | (FStar_Extraction_ML_Syntax.E_IMPURE, - FStar_Extraction_ML_Syntax.E_PURE) -> - FStar_Extraction_ML_Syntax.E_IMPURE - | (FStar_Extraction_ML_Syntax.E_PURE, - FStar_Extraction_ML_Syntax.E_IMPURE) -> - FStar_Extraction_ML_Syntax.E_IMPURE - | (FStar_Extraction_ML_Syntax.E_IMPURE, - FStar_Extraction_ML_Syntax.E_IMPURE) -> - FStar_Extraction_ML_Syntax.E_IMPURE - | (FStar_Extraction_ML_Syntax.E_ERASABLE, - FStar_Extraction_ML_Syntax.E_ERASABLE) -> - FStar_Extraction_ML_Syntax.E_ERASABLE - | (FStar_Extraction_ML_Syntax.E_PURE, - FStar_Extraction_ML_Syntax.E_ERASABLE) -> - FStar_Extraction_ML_Syntax.E_ERASABLE - | (FStar_Extraction_ML_Syntax.E_ERASABLE, - FStar_Extraction_ML_Syntax.E_PURE) -> - FStar_Extraction_ML_Syntax.E_ERASABLE - | (FStar_Extraction_ML_Syntax.E_PURE, - FStar_Extraction_ML_Syntax.E_PURE) -> - FStar_Extraction_ML_Syntax.E_PURE - | uu___ -> - let uu___1 = - let uu___2 = FStar_Compiler_Range_Ops.string_of_range r in - let uu___3 = eff_to_string f in - let uu___4 = eff_to_string f' in - FStar_Compiler_Util.format3 - "Impossible (%s): Inconsistent effects %s and %s" uu___2 - uu___3 uu___4 in - failwith uu___1 -let (join_l : - FStar_Compiler_Range_Type.range -> - FStar_Extraction_ML_Syntax.e_tag Prims.list -> - FStar_Extraction_ML_Syntax.e_tag) - = - fun r -> - fun fs -> - FStar_Compiler_List.fold_left (join r) - FStar_Extraction_ML_Syntax.E_PURE fs -let (mk_ty_fun : - FStar_Extraction_ML_Syntax.mlbinder Prims.list -> - FStar_Extraction_ML_Syntax.mlty -> FStar_Extraction_ML_Syntax.mlty) - = - FStar_Compiler_List.fold_right - (fun uu___ -> - fun t -> - match uu___ with - | { FStar_Extraction_ML_Syntax.mlbinder_name = uu___1; - FStar_Extraction_ML_Syntax.mlbinder_ty = mlbinder_ty; - FStar_Extraction_ML_Syntax.mlbinder_attrs = uu___2;_} -> - FStar_Extraction_ML_Syntax.MLTY_Fun - (mlbinder_ty, FStar_Extraction_ML_Syntax.E_PURE, t)) -type unfold_t = - FStar_Extraction_ML_Syntax.mlty -> - FStar_Extraction_ML_Syntax.mlty FStar_Pervasives_Native.option -let rec (type_leq_c : - unfold_t -> - FStar_Extraction_ML_Syntax.mlexpr FStar_Pervasives_Native.option -> - FStar_Extraction_ML_Syntax.mlty -> - FStar_Extraction_ML_Syntax.mlty -> - (Prims.bool * FStar_Extraction_ML_Syntax.mlexpr - FStar_Pervasives_Native.option)) - = - fun unfold_ty -> - fun e -> - fun t -> - fun t' -> - match (t, t') with - | (FStar_Extraction_ML_Syntax.MLTY_Var x, - FStar_Extraction_ML_Syntax.MLTY_Var y) -> - if x = y - then (true, e) - else (false, FStar_Pervasives_Native.None) - | (FStar_Extraction_ML_Syntax.MLTY_Fun (t1, f, t2), - FStar_Extraction_ML_Syntax.MLTY_Fun (t1', f', t2')) -> - let mk_fun xs body = - match xs with - | [] -> body - | uu___ -> - let e1 = - match body.FStar_Extraction_ML_Syntax.expr with - | FStar_Extraction_ML_Syntax.MLE_Fun (ys, body1) -> - FStar_Extraction_ML_Syntax.MLE_Fun - ((FStar_Compiler_List.op_At xs ys), body1) - | uu___1 -> - FStar_Extraction_ML_Syntax.MLE_Fun (xs, body) in - let uu___1 = - mk_ty_fun xs body.FStar_Extraction_ML_Syntax.mlty in - FStar_Extraction_ML_Syntax.with_ty uu___1 e1 in - (match e with - | FStar_Pervasives_Native.Some - { - FStar_Extraction_ML_Syntax.expr = - FStar_Extraction_ML_Syntax.MLE_Fun (x::xs, body); - FStar_Extraction_ML_Syntax.mlty = uu___; - FStar_Extraction_ML_Syntax.loc = uu___1;_} - -> - let uu___2 = (type_leq unfold_ty t1' t1) && (eff_leq f f') in - if uu___2 - then - (if - (f = FStar_Extraction_ML_Syntax.E_PURE) && - (f' = FStar_Extraction_ML_Syntax.E_ERASABLE) - then - let uu___3 = type_leq unfold_ty t2 t2' in - (if uu___3 - then - let body1 = - let uu___4 = - type_leq unfold_ty t2 - FStar_Extraction_ML_Syntax.ml_unit_ty in - if uu___4 - then FStar_Extraction_ML_Syntax.ml_unit - else - FStar_Extraction_ML_Syntax.with_ty t2' - (FStar_Extraction_ML_Syntax.MLE_Coerce - (FStar_Extraction_ML_Syntax.ml_unit, - FStar_Extraction_ML_Syntax.ml_unit_ty, - t2')) in - let uu___4 = - let uu___5 = - let uu___6 = - mk_ty_fun [x] - body1.FStar_Extraction_ML_Syntax.mlty in - FStar_Extraction_ML_Syntax.with_ty uu___6 - (FStar_Extraction_ML_Syntax.MLE_Fun - ([x], body1)) in - FStar_Pervasives_Native.Some uu___5 in - (true, uu___4) - else (false, FStar_Pervasives_Native.None)) - else - (let uu___4 = - let uu___5 = - let uu___6 = mk_fun xs body in - FStar_Pervasives_Native.Some uu___6 in - type_leq_c unfold_ty uu___5 t2 t2' in - match uu___4 with - | (ok, body1) -> - let res = - match body1 with - | FStar_Pervasives_Native.Some body2 -> - let uu___5 = mk_fun [x] body2 in - FStar_Pervasives_Native.Some uu___5 - | uu___5 -> FStar_Pervasives_Native.None in - (ok, res))) - else (false, FStar_Pervasives_Native.None) - | uu___ -> - let uu___1 = - ((type_leq unfold_ty t1' t1) && (eff_leq f f')) && - (type_leq unfold_ty t2 t2') in - if uu___1 - then (true, e) - else (false, FStar_Pervasives_Native.None)) - | (FStar_Extraction_ML_Syntax.MLTY_Named (args, path), - FStar_Extraction_ML_Syntax.MLTY_Named (args', path')) -> - if path = path' - then - let uu___ = - FStar_Compiler_List.forall2 (type_leq unfold_ty) args args' in - (if uu___ - then (true, e) - else (false, FStar_Pervasives_Native.None)) - else - (let uu___1 = unfold_ty t in - match uu___1 with - | FStar_Pervasives_Native.Some t1 -> - type_leq_c unfold_ty e t1 t' - | FStar_Pervasives_Native.None -> - let uu___2 = unfold_ty t' in - (match uu___2 with - | FStar_Pervasives_Native.None -> - (false, FStar_Pervasives_Native.None) - | FStar_Pervasives_Native.Some t'1 -> - type_leq_c unfold_ty e t t'1)) - | (FStar_Extraction_ML_Syntax.MLTY_Tuple ts, - FStar_Extraction_ML_Syntax.MLTY_Tuple ts') -> - let uu___ = - FStar_Compiler_List.forall2 (type_leq unfold_ty) ts ts' in - if uu___ - then (true, e) - else (false, FStar_Pervasives_Native.None) - | (FStar_Extraction_ML_Syntax.MLTY_Top, - FStar_Extraction_ML_Syntax.MLTY_Top) -> (true, e) - | (FStar_Extraction_ML_Syntax.MLTY_Named uu___, uu___1) -> - let uu___2 = unfold_ty t in - (match uu___2 with - | FStar_Pervasives_Native.Some t1 -> - type_leq_c unfold_ty e t1 t' - | uu___3 -> (false, FStar_Pervasives_Native.None)) - | (uu___, FStar_Extraction_ML_Syntax.MLTY_Named uu___1) -> - let uu___2 = unfold_ty t' in - (match uu___2 with - | FStar_Pervasives_Native.Some t'1 -> - type_leq_c unfold_ty e t t'1 - | uu___3 -> (false, FStar_Pervasives_Native.None)) - | (FStar_Extraction_ML_Syntax.MLTY_Erased, - FStar_Extraction_ML_Syntax.MLTY_Erased) -> (true, e) - | uu___ -> (false, FStar_Pervasives_Native.None) -and (type_leq : - unfold_t -> - FStar_Extraction_ML_Syntax.mlty -> - FStar_Extraction_ML_Syntax.mlty -> Prims.bool) - = - fun g -> - fun t1 -> - fun t2 -> - let uu___ = type_leq_c g FStar_Pervasives_Native.None t1 t2 in - FStar_Pervasives_Native.fst uu___ -let rec (erase_effect_annotations : - FStar_Extraction_ML_Syntax.mlty -> FStar_Extraction_ML_Syntax.mlty) = - fun t -> - match t with - | FStar_Extraction_ML_Syntax.MLTY_Fun (t1, f, t2) -> - let uu___ = - let uu___1 = erase_effect_annotations t1 in - let uu___2 = erase_effect_annotations t2 in - (uu___1, FStar_Extraction_ML_Syntax.E_PURE, uu___2) in - FStar_Extraction_ML_Syntax.MLTY_Fun uu___ - | uu___ -> t -let is_type_abstraction : - 'a 'b 'c . (('a, 'b) FStar_Pervasives.either * 'c) Prims.list -> Prims.bool - = - fun uu___ -> - match uu___ with - | (FStar_Pervasives.Inl uu___1, uu___2)::uu___3 -> true - | uu___1 -> false -let (is_xtuple : - (Prims.string Prims.list * Prims.string) -> - Prims.int FStar_Pervasives_Native.option) - = - fun uu___ -> - match uu___ with - | (ns, n) -> - let uu___1 = - let uu___2 = - FStar_Compiler_Util.concat_l "." - (FStar_Compiler_List.op_At ns [n]) in - FStar_Parser_Const.is_tuple_datacon_string uu___2 in - if uu___1 - then - let uu___2 = - let uu___3 = FStar_Compiler_Util.char_at n (Prims.of_int (7)) in - FStar_Compiler_Util.int_of_char uu___3 in - FStar_Pervasives_Native.Some uu___2 - else FStar_Pervasives_Native.None -let (resugar_exp : - FStar_Extraction_ML_Syntax.mlexpr -> FStar_Extraction_ML_Syntax.mlexpr) = - fun e -> - match e.FStar_Extraction_ML_Syntax.expr with - | FStar_Extraction_ML_Syntax.MLE_CTor (mlp, args) -> - let uu___ = is_xtuple mlp in - (match uu___ with - | FStar_Pervasives_Native.Some n -> - FStar_Extraction_ML_Syntax.with_ty - e.FStar_Extraction_ML_Syntax.mlty - (FStar_Extraction_ML_Syntax.MLE_Tuple args) - | uu___1 -> e) - | uu___ -> e -let (record_field_path : - FStar_Ident.lident Prims.list -> Prims.string Prims.list) = - fun uu___ -> - match uu___ with - | f::uu___1 -> - let uu___2 = - let uu___3 = FStar_Ident.ns_of_lid f in - FStar_Compiler_Util.prefix uu___3 in - (match uu___2 with - | (ns, uu___3) -> - FStar_Compiler_List.map (fun id -> FStar_Ident.string_of_id id) - ns) - | uu___1 -> failwith "impos" -let record_fields : - 'a . - FStar_Ident.lident Prims.list -> - 'a Prims.list -> (Prims.string * 'a) Prims.list - = - fun fs -> - fun vs -> - FStar_Compiler_List.map2 - (fun f -> - fun e -> - let uu___ = - let uu___1 = FStar_Ident.ident_of_lid f in - FStar_Ident.string_of_id uu___1 in - (uu___, e)) fs vs -let (is_xtuple_ty : - (Prims.string Prims.list * Prims.string) -> - Prims.int FStar_Pervasives_Native.option) - = - fun uu___ -> - match uu___ with - | (ns, n) -> - let uu___1 = - let uu___2 = - FStar_Compiler_Util.concat_l "." - (FStar_Compiler_List.op_At ns [n]) in - FStar_Parser_Const.is_tuple_constructor_string uu___2 in - if uu___1 - then - let uu___2 = - let uu___3 = FStar_Compiler_Util.char_at n (Prims.of_int (5)) in - FStar_Compiler_Util.int_of_char uu___3 in - FStar_Pervasives_Native.Some uu___2 - else FStar_Pervasives_Native.None -let (resugar_mlty : - FStar_Extraction_ML_Syntax.mlty -> FStar_Extraction_ML_Syntax.mlty) = - fun t -> - match t with - | FStar_Extraction_ML_Syntax.MLTY_Named (args, mlp) -> - let uu___ = is_xtuple_ty mlp in - (match uu___ with - | FStar_Pervasives_Native.Some n -> - FStar_Extraction_ML_Syntax.MLTY_Tuple args - | uu___1 -> t) - | uu___ -> t -let (flatten_ns : Prims.string Prims.list -> Prims.string) = - fun ns -> FStar_Compiler_String.concat "_" ns -let (flatten_mlpath : - (Prims.string Prims.list * Prims.string) -> Prims.string) = - fun uu___ -> - match uu___ with - | (ns, n) -> - FStar_Compiler_String.concat "_" (FStar_Compiler_List.op_At ns [n]) -let (ml_module_name_of_lid : FStar_Ident.lident -> Prims.string) = - fun l -> - let mlp = - let uu___ = - let uu___1 = FStar_Ident.ns_of_lid l in - FStar_Compiler_List.map FStar_Ident.string_of_id uu___1 in - let uu___1 = - let uu___2 = FStar_Ident.ident_of_lid l in - FStar_Ident.string_of_id uu___2 in - (uu___, uu___1) in - flatten_mlpath mlp -let rec (erasableType : - unfold_t -> FStar_Extraction_ML_Syntax.mlty -> Prims.bool) = - fun unfold_ty -> - fun t -> - let erasableTypeNoDelta t1 = - if t1 = FStar_Extraction_ML_Syntax.ml_unit_ty - then true - else - (match t1 with - | FStar_Extraction_ML_Syntax.MLTY_Named - (uu___1, ("FStar"::"Ghost"::[], "erased")) -> true - | FStar_Extraction_ML_Syntax.MLTY_Named - (uu___1, ("FStar"::"Tactics"::"Effect"::[], "tactic")) -> - let uu___2 = FStar_Options.codegen () in - uu___2 <> (FStar_Pervasives_Native.Some FStar_Options.Plugin) - | uu___1 -> false) in - let uu___ = erasableTypeNoDelta t in - if uu___ - then true - else - (let uu___2 = unfold_ty t in - match uu___2 with - | FStar_Pervasives_Native.Some t1 -> erasableType unfold_ty t1 - | FStar_Pervasives_Native.None -> false) -let rec (eraseTypeDeep : - unfold_t -> - FStar_Extraction_ML_Syntax.mlty -> FStar_Extraction_ML_Syntax.mlty) - = - fun unfold_ty -> - fun t -> - match t with - | FStar_Extraction_ML_Syntax.MLTY_Fun (tyd, etag, tycd) -> - if etag = FStar_Extraction_ML_Syntax.E_PURE - then - let uu___ = - let uu___1 = eraseTypeDeep unfold_ty tyd in - let uu___2 = eraseTypeDeep unfold_ty tycd in - (uu___1, etag, uu___2) in - FStar_Extraction_ML_Syntax.MLTY_Fun uu___ - else t - | FStar_Extraction_ML_Syntax.MLTY_Named (lty, mlp) -> - let uu___ = erasableType unfold_ty t in - if uu___ - then FStar_Extraction_ML_Syntax.MLTY_Erased - else - (let uu___2 = - let uu___3 = - FStar_Compiler_List.map (eraseTypeDeep unfold_ty) lty in - (uu___3, mlp) in - FStar_Extraction_ML_Syntax.MLTY_Named uu___2) - | FStar_Extraction_ML_Syntax.MLTY_Tuple lty -> - let uu___ = FStar_Compiler_List.map (eraseTypeDeep unfold_ty) lty in - FStar_Extraction_ML_Syntax.MLTY_Tuple uu___ - | uu___ -> t -let (prims_op_equality : FStar_Extraction_ML_Syntax.mlexpr) = - FStar_Extraction_ML_Syntax.with_ty FStar_Extraction_ML_Syntax.MLTY_Top - (FStar_Extraction_ML_Syntax.MLE_Name (["Prims"], "op_Equality")) -let (prims_op_amp_amp : FStar_Extraction_ML_Syntax.mlexpr) = - let uu___ = - mk_ty_fun - [{ - FStar_Extraction_ML_Syntax.mlbinder_name = "x"; - FStar_Extraction_ML_Syntax.mlbinder_ty = - FStar_Extraction_ML_Syntax.ml_bool_ty; - FStar_Extraction_ML_Syntax.mlbinder_attrs = [] - }; - { - FStar_Extraction_ML_Syntax.mlbinder_name = "y"; - FStar_Extraction_ML_Syntax.mlbinder_ty = - FStar_Extraction_ML_Syntax.ml_bool_ty; - FStar_Extraction_ML_Syntax.mlbinder_attrs = [] - }] FStar_Extraction_ML_Syntax.ml_bool_ty in - FStar_Extraction_ML_Syntax.with_ty uu___ - (FStar_Extraction_ML_Syntax.MLE_Name (["Prims"], "op_AmpAmp")) -let (conjoin : - FStar_Extraction_ML_Syntax.mlexpr -> - FStar_Extraction_ML_Syntax.mlexpr -> FStar_Extraction_ML_Syntax.mlexpr) - = - fun e1 -> - fun e2 -> - FStar_Extraction_ML_Syntax.with_ty - FStar_Extraction_ML_Syntax.ml_bool_ty - (FStar_Extraction_ML_Syntax.MLE_App (prims_op_amp_amp, [e1; e2])) -let (conjoin_opt : - FStar_Extraction_ML_Syntax.mlexpr FStar_Pervasives_Native.option -> - FStar_Extraction_ML_Syntax.mlexpr FStar_Pervasives_Native.option -> - FStar_Extraction_ML_Syntax.mlexpr FStar_Pervasives_Native.option) - = - fun e1 -> - fun e2 -> - match (e1, e2) with - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> - FStar_Pervasives_Native.None - | (FStar_Pervasives_Native.Some x, FStar_Pervasives_Native.None) -> - FStar_Pervasives_Native.Some x - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.Some x) -> - FStar_Pervasives_Native.Some x - | (FStar_Pervasives_Native.Some x, FStar_Pervasives_Native.Some y) -> - let uu___ = conjoin x y in FStar_Pervasives_Native.Some uu___ -let (mlloc_of_range : - FStar_Compiler_Range_Type.range -> (Prims.int * Prims.string)) = - fun r -> - let pos = FStar_Compiler_Range_Ops.start_of_range r in - let line = FStar_Compiler_Range_Ops.line_of_pos pos in - let uu___ = FStar_Compiler_Range_Ops.file_of_range r in (line, uu___) -let rec (doms_and_cod : - FStar_Extraction_ML_Syntax.mlty -> - (FStar_Extraction_ML_Syntax.mlty Prims.list * - FStar_Extraction_ML_Syntax.mlty)) - = - fun t -> - match t with - | FStar_Extraction_ML_Syntax.MLTY_Fun (a, uu___, b) -> - let uu___1 = doms_and_cod b in - (match uu___1 with | (ds, c) -> ((a :: ds), c)) - | uu___ -> ([], t) -let (argTypes : - FStar_Extraction_ML_Syntax.mlty -> - FStar_Extraction_ML_Syntax.mlty Prims.list) - = fun t -> let uu___ = doms_and_cod t in FStar_Pervasives_Native.fst uu___ -let rec (uncurry_mlty_fun : - FStar_Extraction_ML_Syntax.mlty -> - (FStar_Extraction_ML_Syntax.mlty Prims.list * - FStar_Extraction_ML_Syntax.mlty)) - = - fun t -> - match t with - | FStar_Extraction_ML_Syntax.MLTY_Fun (a, uu___, b) -> - let uu___1 = uncurry_mlty_fun b in - (match uu___1 with | (args, res) -> ((a :: args), res)) - | uu___ -> ([], t) -let (list_elements : - FStar_Extraction_ML_Syntax.mlexpr -> - FStar_Extraction_ML_Syntax.mlexpr Prims.list - FStar_Pervasives_Native.option) - = - fun e -> - let rec list_elements1 acc e1 = - match e1.FStar_Extraction_ML_Syntax.expr with - | FStar_Extraction_ML_Syntax.MLE_CTor - (("Prims"::[], "Cons"), hd::tl::[]) -> - list_elements1 (hd :: acc) tl - | FStar_Extraction_ML_Syntax.MLE_CTor (("Prims"::[], "Nil"), []) -> - FStar_Pervasives_Native.Some (FStar_Compiler_List.rev acc) - | uu___ -> FStar_Pervasives_Native.None in - list_elements1 [] e \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Find.ml b/ocaml/fstar-lib/generated/FStar_Find.ml deleted file mode 100644 index 24c7027875c..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Find.ml +++ /dev/null @@ -1,38 +0,0 @@ -open Prims -let (find_file : Prims.string -> Prims.string FStar_Pervasives_Native.option) - = - let file_map = FStar_Compiler_Util.smap_create (Prims.of_int (100)) in - fun filename -> - let uu___ = FStar_Compiler_Util.smap_try_find file_map filename in - match uu___ with - | FStar_Pervasives_Native.Some f -> f - | FStar_Pervasives_Native.None -> - let result = - try - (fun uu___1 -> - match () with - | () -> - let uu___2 = FStar_Compiler_Util.is_path_absolute filename in - if uu___2 - then - (if FStar_Compiler_Util.file_exists filename - then FStar_Pervasives_Native.Some filename - else FStar_Pervasives_Native.None) - else - (let uu___4 = - let uu___5 = FStar_Options.include_path () in - FStar_List_Tot_Base.rev uu___5 in - FStar_Compiler_Util.find_map uu___4 - (fun p -> - let path = - if p = "." - then filename - else FStar_Compiler_Util.join_paths p filename in - if FStar_Compiler_Util.file_exists path - then FStar_Pervasives_Native.Some path - else FStar_Pervasives_Native.None))) () - with | uu___1 -> FStar_Pervasives_Native.None in - (if FStar_Pervasives_Native.uu___is_Some result - then FStar_Compiler_Util.smap_add file_map filename result - else (); - result) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_GenSym.ml b/ocaml/fstar-lib/generated/FStar_GenSym.ml deleted file mode 100644 index fc77fc078bd..00000000000 --- a/ocaml/fstar-lib/generated/FStar_GenSym.ml +++ /dev/null @@ -1,19 +0,0 @@ -open Prims -let (gensym_st : Prims.int FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref Prims.int_zero -let (next_id : unit -> Prims.int) = - fun uu___ -> - let r = FStar_Compiler_Effect.op_Bang gensym_st in - FStar_Compiler_Effect.op_Colon_Equals gensym_st (r + Prims.int_one); r -let (reset_gensym : unit -> unit) = - fun uu___ -> FStar_Compiler_Effect.op_Colon_Equals gensym_st Prims.int_zero -let with_frozen_gensym : 'a . (unit -> 'a) -> 'a = - fun f -> - let v = FStar_Compiler_Effect.op_Bang gensym_st in - let r = - try (fun uu___ -> match () with | () -> f ()) () - with - | uu___ -> - (FStar_Compiler_Effect.op_Colon_Equals gensym_st v; - FStar_Compiler_Effect.raise uu___) in - FStar_Compiler_Effect.op_Colon_Equals gensym_st v; r \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Ident.ml b/ocaml/fstar-lib/generated/FStar_Ident.ml deleted file mode 100644 index dbe65301c2a..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Ident.ml +++ /dev/null @@ -1,160 +0,0 @@ -open Prims -type ident = - { - idText: Prims.string ; - idRange: FStar_Compiler_Range_Type.range }[@@deriving yojson,show] -let (__proj__Mkident__item__idText : ident -> Prims.string) = - fun projectee -> match projectee with | { idText; idRange;_} -> idText -let (__proj__Mkident__item__idRange : - ident -> FStar_Compiler_Range_Type.range) = - fun projectee -> match projectee with | { idText; idRange;_} -> idRange -type path = Prims.string Prims.list[@@deriving yojson,show] -type ipath = ident Prims.list[@@deriving yojson,show] -type lident = - { - ns: ipath ; - ident: ident ; - nsstr: Prims.string ; - str: Prims.string }[@@deriving yojson,show] -let (__proj__Mklident__item__ns : lident -> ipath) = - fun projectee -> - match projectee with | { ns; ident = ident1; nsstr; str;_} -> ns -let (__proj__Mklident__item__ident : lident -> ident) = - fun projectee -> - match projectee with | { ns; ident = ident1; nsstr; str;_} -> ident1 -let (__proj__Mklident__item__nsstr : lident -> Prims.string) = - fun projectee -> - match projectee with | { ns; ident = ident1; nsstr; str;_} -> nsstr -let (__proj__Mklident__item__str : lident -> Prims.string) = - fun projectee -> - match projectee with | { ns; ident = ident1; nsstr; str;_} -> str -let (mk_ident : (Prims.string * FStar_Compiler_Range_Type.range) -> ident) = - fun uu___ -> - match uu___ with | (text, range) -> { idText = text; idRange = range } -let (set_id_range : FStar_Compiler_Range_Type.range -> ident -> ident) = - fun r -> fun i -> { idText = (i.idText); idRange = r } -let (reserved_prefix : Prims.string) = "uu___" -let (gen' : Prims.string -> FStar_Compiler_Range_Type.range -> ident) = - fun s -> - fun r -> - let i = FStar_GenSym.next_id () in - mk_ident ((Prims.strcat s (Prims.string_of_int i)), r) -let (gen : FStar_Compiler_Range_Type.range -> ident) = - fun r -> gen' reserved_prefix r -let (ident_of_lid : lident -> ident) = fun l -> l.ident -let (range_of_id : ident -> FStar_Compiler_Range_Type.range) = - fun id -> id.idRange -let (id_of_text : Prims.string -> ident) = - fun str -> mk_ident (str, FStar_Compiler_Range_Type.dummyRange) -let (string_of_id : ident -> Prims.string) = fun id -> id.idText -let (text_of_path : path -> Prims.string) = - fun path1 -> FStar_Compiler_Util.concat_l "." path1 -let (path_of_text : Prims.string -> path) = - fun text -> FStar_String.split [46] text -let (path_of_ns : ipath -> path) = - fun ns -> FStar_Compiler_List.map string_of_id ns -let (path_of_lid : lident -> path) = - fun lid -> - FStar_Compiler_List.map string_of_id - (FStar_Compiler_List.op_At lid.ns [lid.ident]) -let (ns_of_lid : lident -> ipath) = fun lid -> lid.ns -let (ids_of_lid : lident -> ipath) = - fun lid -> FStar_Compiler_List.op_At lid.ns [lid.ident] -let (lid_of_ns_and_id : ipath -> ident -> lident) = - fun ns -> - fun id -> - let nsstr = - let uu___ = FStar_Compiler_List.map string_of_id ns in - text_of_path uu___ in - { - ns; - ident = id; - nsstr; - str = - (if nsstr = "" - then id.idText - else Prims.strcat nsstr (Prims.strcat "." id.idText)) - } -let (lid_of_ids : ipath -> lident) = - fun ids -> - let uu___ = FStar_Compiler_Util.prefix ids in - match uu___ with | (ns, id) -> lid_of_ns_and_id ns id -let (lid_of_str : Prims.string -> lident) = - fun str -> - let uu___ = - FStar_Compiler_List.map id_of_text (FStar_Compiler_Util.split str ".") in - lid_of_ids uu___ -let (lid_of_path : path -> FStar_Compiler_Range_Type.range -> lident) = - fun path1 -> - fun pos -> - let ids = FStar_Compiler_List.map (fun s -> mk_ident (s, pos)) path1 in - lid_of_ids ids -let (text_of_lid : lident -> Prims.string) = fun lid -> lid.str -let (lid_equals : lident -> lident -> Prims.bool) = - fun l1 -> fun l2 -> l1.str = l2.str -let (ident_equals : ident -> ident -> Prims.bool) = - fun id1 -> fun id2 -> id1.idText = id2.idText -type lid = lident[@@deriving yojson,show] -let (range_of_lid : lident -> FStar_Compiler_Range_Type.range) = - fun lid1 -> range_of_id lid1.ident -let (set_lid_range : lident -> FStar_Compiler_Range_Type.range -> lident) = - fun l -> - fun r -> - { - ns = (l.ns); - ident = - (let uu___ = l.ident in { idText = (uu___.idText); idRange = r }); - nsstr = (l.nsstr); - str = (l.str) - } -let (lid_add_suffix : lident -> Prims.string -> lident) = - fun l -> - fun s -> - let path1 = path_of_lid l in - let uu___ = range_of_lid l in - lid_of_path (FStar_Compiler_List.op_At path1 [s]) uu___ -let (ml_path_of_lid : lident -> Prims.string) = - fun lid1 -> - let uu___ = - let uu___1 = path_of_ns lid1.ns in - let uu___2 = let uu___3 = string_of_id lid1.ident in [uu___3] in - FStar_Compiler_List.op_At uu___1 uu___2 in - FStar_String.concat "_" uu___ -let (string_of_lid : lident -> Prims.string) = fun lid1 -> lid1.str -let (qual_id : lident -> ident -> lident) = - fun lid1 -> - fun id -> - let uu___ = - lid_of_ids (FStar_Compiler_List.op_At lid1.ns [lid1.ident; id]) in - let uu___1 = range_of_id id in set_lid_range uu___ uu___1 -let (nsstr : lident -> Prims.string) = fun l -> l.nsstr -let (showable_ident : ident FStar_Class_Show.showable) = - { FStar_Class_Show.show = string_of_id } -let (showable_lident : lident FStar_Class_Show.showable) = - { FStar_Class_Show.show = string_of_lid } -let (pretty_ident : ident FStar_Class_PP.pretty) = - FStar_Class_PP.pretty_from_showable showable_ident -let (pretty_lident : lident FStar_Class_PP.pretty) = - FStar_Class_PP.pretty_from_showable showable_lident -let (hasrange_ident : ident FStar_Class_HasRange.hasRange) = - { - FStar_Class_HasRange.pos = range_of_id; - FStar_Class_HasRange.setPos = - (fun rng -> fun id -> { idText = (id.idText); idRange = rng }) - } -let (hasrange_lident : lident FStar_Class_HasRange.hasRange) = - { - FStar_Class_HasRange.pos = - (fun lid1 -> FStar_Class_HasRange.pos hasrange_ident lid1.ident); - FStar_Class_HasRange.setPos = - (fun rng -> - fun id -> - let uu___ = - FStar_Class_HasRange.setPos hasrange_ident rng id.ident in - { ns = (id.ns); ident = uu___; nsstr = (id.nsstr); str = (id.str) - }) - } -let (deq_ident : ident FStar_Class_Deq.deq) = - { FStar_Class_Deq.op_Equals_Question = ident_equals } -let (deq_lident : lident FStar_Class_Deq.deq) = - { FStar_Class_Deq.op_Equals_Question = lid_equals } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_Base.ml b/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_Base.ml index a03dea82c49..f95c54133d8 100644 --- a/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_Base.ml +++ b/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_Base.ml @@ -1,22 +1,22 @@ open Prims let (bv_eq : - FStar_Reflection_Types.bv -> FStar_Reflection_Types.bv -> Prims.bool) = + FStarC_Reflection_Types.bv -> FStarC_Reflection_Types.bv -> Prims.bool) = fun bv1 -> fun bv2 -> - let bvv1 = FStar_Reflection_V1_Builtins.inspect_bv bv1 in - let bvv2 = FStar_Reflection_V1_Builtins.inspect_bv bv2 in - bvv1.FStar_Reflection_V1_Data.bv_index = - bvv2.FStar_Reflection_V1_Data.bv_index + let bvv1 = FStarC_Reflection_V1_Builtins.inspect_bv bv1 in + let bvv2 = FStarC_Reflection_V1_Builtins.inspect_bv bv2 in + bvv1.FStarC_Reflection_V1_Data.bv_index = + bvv2.FStarC_Reflection_V1_Data.bv_index let (fv_eq : - FStar_Reflection_Types.fv -> FStar_Reflection_Types.fv -> Prims.bool) = + FStarC_Reflection_Types.fv -> FStarC_Reflection_Types.fv -> Prims.bool) = fun fv1 -> fun fv2 -> - let n1 = FStar_Reflection_V1_Builtins.inspect_fv fv1 in - let n2 = FStar_Reflection_V1_Builtins.inspect_fv fv2 in n1 = n2 + let n1 = FStarC_Reflection_V1_Builtins.inspect_fv fv1 in + let n2 = FStarC_Reflection_V1_Builtins.inspect_fv fv2 in n1 = n2 let (fv_eq_name : - FStar_Reflection_Types.fv -> FStar_Reflection_Types.name -> Prims.bool) = + FStarC_Reflection_Types.fv -> FStarC_Reflection_Types.name -> Prims.bool) = fun fv -> - fun n -> let fvn = FStar_Reflection_V1_Builtins.inspect_fv fv in fvn = n + fun n -> let fvn = FStarC_Reflection_V1_Builtins.inspect_fv fv in fvn = n let opt_apply : 'a 'b . ('a -> 'b) -> @@ -204,10 +204,10 @@ let list_to_string : FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> Prims.strcat uu___1 "]")) let (mk_app_norm : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term Prims.list -> - (FStar_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term Prims.list -> + (FStarC_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) = fun e -> fun t -> @@ -230,7 +230,7 @@ let (mk_app_norm : (Obj.magic uu___) (fun uu___1 -> (fun t1 -> - let uu___1 = FStar_Tactics_V1_Builtins.norm_term_env e [] t1 in + let uu___1 = FStarC_Tactics_V1_Builtins.norm_term_env e [] t1 in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -250,10 +250,10 @@ let (mk_app_norm : FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> t2)))) uu___1) let (opt_mk_app_norm : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.term FStar_Pervasives_Native.option -> - FStar_Reflection_Types.term Prims.list -> - (FStar_Reflection_Types.term FStar_Pervasives_Native.option, + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.term FStar_Pervasives_Native.option -> + FStarC_Reflection_Types.term Prims.list -> + (FStarC_Reflection_Types.term FStar_Pervasives_Native.option, unit) FStar_Tactics_Effect.tac_repr) = fun e -> @@ -268,14 +268,14 @@ let rec unzip : let uu___ = unzip tl in (match uu___ with | (tl1, tl2) -> ((hd1 :: tl1), (hd2 :: tl2))) let (abv_to_string : - FStar_Reflection_Types.bv -> + FStarC_Reflection_Types.bv -> (Prims.string, unit) FStar_Tactics_Effect.tac_repr) = fun bv -> let uu___ = Obj.magic (FStar_Tactics_Effect.lift_div_tac - (fun uu___1 -> FStar_Reflection_V1_Builtins.inspect_bv bv)) in + (fun uu___1 -> FStarC_Reflection_V1_Builtins.inspect_bv bv)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -310,36 +310,37 @@ let (abv_to_string : (Prims.strcat " (%" (Prims.strcat (Prims.string_of_int - bvv.FStar_Reflection_V1_Data.bv_index) + bvv.FStarC_Reflection_V1_Data.bv_index) ")")))))) uu___1) let (print_binder_info : Prims.bool -> - FStar_Reflection_Types.binder -> + FStarC_Reflection_Types.binder -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun full -> fun b -> - match FStar_Reflection_V1_Builtins.inspect_binder b with - | { FStar_Reflection_V1_Data.binder_bv = binder_bv; - FStar_Reflection_V1_Data.binder_qual = binder_qual; - FStar_Reflection_V1_Data.binder_attrs = binder_attrs; - FStar_Reflection_V1_Data.binder_sort = binder_sort;_} -> + match FStarC_Reflection_V1_Builtins.inspect_binder b with + | { FStarC_Reflection_V1_Data.binder_bv = binder_bv; + FStarC_Reflection_V1_Data.binder_qual = binder_qual; + FStarC_Reflection_V1_Data.binder_attrs = binder_attrs; + FStarC_Reflection_V1_Data.binder_sort = binder_sort;_} -> let uu___ = match binder_qual with - | FStar_Reflection_V1_Data.Q_Implicit -> + | FStarC_Reflection_V1_Data.Q_Implicit -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___1 -> "Implicit"))) - | FStar_Reflection_V1_Data.Q_Explicit -> + | FStarC_Reflection_V1_Data.Q_Explicit -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___1 -> "Explicit"))) - | FStar_Reflection_V1_Data.Q_Meta t -> + | FStarC_Reflection_V1_Data.Q_Meta t -> Obj.magic (Obj.repr - (let uu___1 = FStar_Tactics_V1_Builtins.term_to_string t in + (let uu___1 = + FStarC_Tactics_V1_Builtins.term_to_string t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -374,7 +375,8 @@ let (print_binder_info : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> - FStar_Reflection_V1_Builtins.inspect_bv binder_bv)) in + FStarC_Reflection_V1_Builtins.inspect_bv + binder_bv)) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -486,7 +488,7 @@ let (print_binder_info : = let uu___20 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string binder_sort in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -545,7 +547,7 @@ let (print_binder_info : -> Prims.strcat (Prims.string_of_int - bview.FStar_Reflection_V1_Data.bv_index) + bview.FStarC_Reflection_V1_Data.bv_index) uu___20)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -837,7 +839,7 @@ let (print_binder_info : (fun uu___3 -> (fun uu___3 -> Obj.magic - (FStar_Tactics_V1_Builtins.print + (FStarC_Tactics_V1_Builtins.print uu___3)) uu___3)) else (let uu___3 = @@ -864,26 +866,26 @@ let (print_binder_info : (fun uu___4 -> (fun uu___4 -> Obj.magic - (FStar_Tactics_V1_Builtins.print + (FStarC_Tactics_V1_Builtins.print uu___4)) uu___4)))) uu___2))) uu___1) let (print_binders_info : Prims.bool -> - FStar_Reflection_Types.env -> (unit, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.env -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun full -> fun e -> FStar_Tactics_Util.iter (print_binder_info full) - (FStar_Reflection_V1_Builtins.binders_of_env e) + (FStarC_Reflection_V1_Builtins.binders_of_env e) let (acomp_to_string : - FStar_Reflection_Types.comp -> + FStarC_Reflection_Types.comp -> (Prims.string, unit) FStar_Tactics_Effect.tac_repr) = fun c -> - match FStar_Reflection_V1_Builtins.inspect_comp c with - | FStar_Reflection_V1_Data.C_Total ret -> + match FStarC_Reflection_V1_Builtins.inspect_comp c with + | FStarC_Reflection_V1_Data.C_Total ret -> let uu___ = - let uu___1 = FStar_Tactics_V1_Builtins.term_to_string ret in + let uu___1 = FStarC_Tactics_V1_Builtins.term_to_string ret in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -912,9 +914,9 @@ let (acomp_to_string : (fun uu___1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> Prims.strcat "C_Total (" uu___1)) - | FStar_Reflection_V1_Data.C_GTotal ret -> + | FStarC_Reflection_V1_Data.C_GTotal ret -> let uu___ = - let uu___1 = FStar_Tactics_V1_Builtins.term_to_string ret in + let uu___1 = FStarC_Tactics_V1_Builtins.term_to_string ret in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -943,9 +945,9 @@ let (acomp_to_string : (fun uu___1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> Prims.strcat "C_GTotal (" uu___1)) - | FStar_Reflection_V1_Data.C_Lemma (pre, post, patterns) -> + | FStarC_Reflection_V1_Data.C_Lemma (pre, post, patterns) -> let uu___ = - let uu___1 = FStar_Tactics_V1_Builtins.term_to_string pre in + let uu___1 = FStarC_Tactics_V1_Builtins.term_to_string pre in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -963,7 +965,7 @@ let (acomp_to_string : let uu___3 = let uu___4 = let uu___5 = - FStar_Tactics_V1_Builtins.term_to_string post in + FStarC_Tactics_V1_Builtins.term_to_string post in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1028,7 +1030,7 @@ let (acomp_to_string : (fun uu___1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> Prims.strcat "C_Lemma (" uu___1)) - | FStar_Reflection_V1_Data.C_Eff (us, eff_name, result, eff_args, uu___) + | FStarC_Reflection_V1_Data.C_Eff (us, eff_name, result, eff_args, uu___) -> let uu___1 = Obj.magic @@ -1036,7 +1038,8 @@ let (acomp_to_string : (fun uu___2 -> fun a -> let uu___3 = - let uu___4 = FStar_Tactics_V1_Builtins.term_to_string a in + let uu___4 = + FStarC_Tactics_V1_Builtins.term_to_string a in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1137,7 +1140,7 @@ let (acomp_to_string : let uu___5 = let uu___6 = let uu___7 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string result in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1234,16 +1237,16 @@ let (acomp_to_string : Prims.strcat "C_Eff (" uu___5)))) uu___4))) uu___3))) uu___2) -exception MetaAnalysis of FStar_Errors_Msg.error_message +exception MetaAnalysis of FStarC_Errors_Msg.error_message let (uu___is_MetaAnalysis : Prims.exn -> Prims.bool) = fun projectee -> match projectee with | MetaAnalysis uu___ -> true | uu___ -> false let (__proj__MetaAnalysis__item__uu___ : - Prims.exn -> FStar_Errors_Msg.error_message) = + Prims.exn -> FStarC_Errors_Msg.error_message) = fun projectee -> match projectee with | MetaAnalysis uu___ -> uu___ let mfail_doc : 'uuuuu . - FStar_Errors_Msg.error_message -> + FStarC_Errors_Msg.error_message -> ('uuuuu, unit) FStar_Tactics_Effect.tac_repr = fun uu___ -> @@ -1254,7 +1257,7 @@ let mfail : (fun str -> Obj.magic (FStar_Tactics_Effect.raise - (MetaAnalysis (FStar_Errors_Msg.mkmsg str)))) uu___ + (MetaAnalysis (FStarC_Errors_Msg.mkmsg str)))) uu___ let (print_dbg : Prims.bool -> Prims.string -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___1 -> @@ -1262,14 +1265,14 @@ let (print_dbg : (fun debug -> fun s -> if debug - then Obj.magic (Obj.repr (FStar_Tactics_V1_Builtins.print s)) + then Obj.magic (Obj.repr (FStarC_Tactics_V1_Builtins.print s)) else Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___1 -> ())))) uu___1 uu___ let (term_view_construct : - FStar_Reflection_V1_Data.term_view -> + FStarC_Reflection_V1_Data.term_view -> (Prims.string, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> @@ -1278,35 +1281,37 @@ let (term_view_construct : (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> match t with - | FStar_Reflection_V1_Data.Tv_Var uu___1 -> "Tv_Var" - | FStar_Reflection_V1_Data.Tv_BVar uu___1 -> "Tv_BVar" - | FStar_Reflection_V1_Data.Tv_FVar uu___1 -> "Tv_FVar" - | FStar_Reflection_V1_Data.Tv_App (uu___1, uu___2) -> "Tv_App" - | FStar_Reflection_V1_Data.Tv_Abs (uu___1, uu___2) -> "Tv_Abs" - | FStar_Reflection_V1_Data.Tv_Arrow (uu___1, uu___2) -> + | FStarC_Reflection_V1_Data.Tv_Var uu___1 -> "Tv_Var" + | FStarC_Reflection_V1_Data.Tv_BVar uu___1 -> "Tv_BVar" + | FStarC_Reflection_V1_Data.Tv_FVar uu___1 -> "Tv_FVar" + | FStarC_Reflection_V1_Data.Tv_App (uu___1, uu___2) -> + "Tv_App" + | FStarC_Reflection_V1_Data.Tv_Abs (uu___1, uu___2) -> + "Tv_Abs" + | FStarC_Reflection_V1_Data.Tv_Arrow (uu___1, uu___2) -> "Tv_Arrow" - | FStar_Reflection_V1_Data.Tv_Type uu___1 -> "Tv_Type" - | FStar_Reflection_V1_Data.Tv_Refine (uu___1, uu___2, uu___3) + | FStarC_Reflection_V1_Data.Tv_Type uu___1 -> "Tv_Type" + | FStarC_Reflection_V1_Data.Tv_Refine (uu___1, uu___2, uu___3) -> "Tv_Refine" - | FStar_Reflection_V1_Data.Tv_Const uu___1 -> "Tv_Const" - | FStar_Reflection_V1_Data.Tv_Uvar (uu___1, uu___2) -> + | FStarC_Reflection_V1_Data.Tv_Const uu___1 -> "Tv_Const" + | FStarC_Reflection_V1_Data.Tv_Uvar (uu___1, uu___2) -> "Tv_Uvar" - | FStar_Reflection_V1_Data.Tv_Let + | FStarC_Reflection_V1_Data.Tv_Let (uu___1, uu___2, uu___3, uu___4, uu___5, uu___6) -> "Tv_Let" - | FStar_Reflection_V1_Data.Tv_Match (uu___1, uu___2, uu___3) + | FStarC_Reflection_V1_Data.Tv_Match (uu___1, uu___2, uu___3) -> "Tv_Match" - | FStar_Reflection_V1_Data.Tv_AscribedT + | FStarC_Reflection_V1_Data.Tv_AscribedT (uu___1, uu___2, uu___3, uu___4) -> "Tv_AscribedT" - | FStar_Reflection_V1_Data.Tv_AscribedC + | FStarC_Reflection_V1_Data.Tv_AscribedC (uu___1, uu___2, uu___3, uu___4) -> "Tv_AScribedC" | uu___1 -> "Tv_Unknown"))) uu___ let (term_construct : - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.term -> (Prims.string, unit) FStar_Tactics_Effect.tac_repr) = fun t -> - let uu___ = FStar_Tactics_V1_Builtins.inspect t in + let uu___ = FStarC_Tactics_V1_Builtins.inspect t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1322,8 +1327,8 @@ let (term_construct : (fun uu___1 -> Obj.magic (term_view_construct uu___1)) uu___1) let (filter_ascriptions : Prims.bool -> - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) = fun dbg -> fun t -> @@ -1331,7 +1336,7 @@ let (filter_ascriptions : let uu___1 = let uu___2 = let uu___3 = - let uu___4 = FStar_Tactics_V1_Builtins.inspect t in + let uu___4 = FStarC_Tactics_V1_Builtins.inspect t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1364,7 +1369,8 @@ let (filter_ascriptions : (fun uu___4 -> (fun uu___4 -> let uu___5 = - let uu___6 = FStar_Tactics_V1_Builtins.term_to_string t in + let uu___6 = + FStarC_Tactics_V1_Builtins.term_to_string t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1443,7 +1449,7 @@ let (filter_ascriptions : Obj.magic (FStar_Tactics_Visit.visit_tm (fun t1 -> - let uu___2 = FStar_Tactics_V1_Builtins.inspect t1 in + let uu___2 = FStarC_Tactics_V1_Builtins.inspect t1 in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1462,41 +1468,41 @@ let (filter_ascriptions : FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> match uu___3 with - | FStar_Reflection_V1_Data.Tv_AscribedT + | FStarC_Reflection_V1_Data.Tv_AscribedT (e, uu___5, uu___6, uu___7) -> e - | FStar_Reflection_V1_Data.Tv_AscribedC + | FStarC_Reflection_V1_Data.Tv_AscribedC (e, uu___5, uu___6, uu___7) -> e | uu___5 -> t1))) t)) uu___1) let (prettify_term : Prims.bool -> - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) = fun dbg -> fun t -> filter_ascriptions dbg t -type 'a bind_map = (FStar_Reflection_Types.bv * 'a) Prims.list +type 'a bind_map = (FStarC_Reflection_Types.bv * 'a) Prims.list let bind_map_push : 'a . 'a bind_map -> - FStar_Reflection_Types.bv -> - 'a -> (FStar_Reflection_Types.bv * 'a) Prims.list + FStarC_Reflection_Types.bv -> + 'a -> (FStarC_Reflection_Types.bv * 'a) Prims.list = fun m -> fun b -> fun x -> (b, x) :: m let rec bind_map_get : 'a . 'a bind_map -> - FStar_Reflection_Types.bv -> 'a FStar_Pervasives_Native.option + FStarC_Reflection_Types.bv -> 'a FStar_Pervasives_Native.option = fun m -> fun b -> match m with | [] -> FStar_Pervasives_Native.None | (b', x)::m' -> - if (FStar_Reflection_V1_Builtins.compare_bv b b') = FStar_Order.Eq + if (FStarC_Reflection_V1_Builtins.compare_bv b b') = FStar_Order.Eq then FStar_Pervasives_Native.Some x else bind_map_get m' b let rec bind_map_get_from_name : 'a . 'a bind_map -> Prims.string -> - ((FStar_Reflection_Types.bv * 'a) FStar_Pervasives_Native.option, + ((FStarC_Reflection_Types.bv * 'a) FStar_Pervasives_Native.option, unit) FStar_Tactics_Effect.tac_repr = fun uu___1 -> @@ -1516,7 +1522,7 @@ let rec bind_map_get_from_name : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___1 -> - FStar_Reflection_V1_Builtins.inspect_bv b')) in + FStarC_Reflection_V1_Builtins.inspect_bv b')) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1536,7 +1542,7 @@ let rec bind_map_get_from_name : let uu___1 = let uu___2 = FStar_Tactics_Unseal.unseal - b'v.FStar_Reflection_V1_Data.bv_ppname in + b'v.FStarC_Reflection_V1_Data.bv_ppname in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1595,36 +1601,38 @@ let rec bind_map_get_from_name : uu___1 uu___ type genv = { - env: FStar_Reflection_Types.env ; + env: FStarC_Reflection_Types.env ; bmap: - (FStar_Reflection_Types.typ * Prims.bool * FStar_Reflection_Types.term) + (FStarC_Reflection_Types.typ * Prims.bool * FStarC_Reflection_Types.term) bind_map ; - svars: (FStar_Reflection_Types.bv * FStar_Reflection_Types.typ) Prims.list } -let (__proj__Mkgenv__item__env : genv -> FStar_Reflection_Types.env) = + svars: + (FStarC_Reflection_Types.bv * FStarC_Reflection_Types.typ) Prims.list } +let (__proj__Mkgenv__item__env : genv -> FStarC_Reflection_Types.env) = fun projectee -> match projectee with | { env; bmap; svars;_} -> env let (__proj__Mkgenv__item__bmap : genv -> - (FStar_Reflection_Types.typ * Prims.bool * FStar_Reflection_Types.term) + (FStarC_Reflection_Types.typ * Prims.bool * FStarC_Reflection_Types.term) bind_map) = fun projectee -> match projectee with | { env; bmap; svars;_} -> bmap let (__proj__Mkgenv__item__svars : - genv -> (FStar_Reflection_Types.bv * FStar_Reflection_Types.typ) Prims.list) + genv -> + (FStarC_Reflection_Types.bv * FStarC_Reflection_Types.typ) Prims.list) = fun projectee -> match projectee with | { env; bmap; svars;_} -> svars -let (get_env : genv -> FStar_Reflection_Types.env) = fun e -> e.env +let (get_env : genv -> FStarC_Reflection_Types.env) = fun e -> e.env let (get_bind_map : genv -> - (FStar_Reflection_Types.typ * Prims.bool * FStar_Reflection_Types.term) + (FStarC_Reflection_Types.typ * Prims.bool * FStarC_Reflection_Types.term) bind_map) = fun e -> e.bmap let (mk_genv : - FStar_Reflection_Types.env -> - (FStar_Reflection_Types.typ * Prims.bool * FStar_Reflection_Types.term) + FStarC_Reflection_Types.env -> + (FStarC_Reflection_Types.typ * Prims.bool * FStarC_Reflection_Types.term) bind_map -> - (FStar_Reflection_Types.bv * FStar_Reflection_Types.typ) Prims.list -> - genv) + (FStarC_Reflection_Types.bv * FStarC_Reflection_Types.typ) Prims.list + -> genv) = fun env -> fun bmap -> fun svars -> { env; bmap; svars } -let (mk_init_genv : FStar_Reflection_Types.env -> genv) = +let (mk_init_genv : FStarC_Reflection_Types.env -> genv) = fun env -> mk_genv env [] [] let (genv_to_string : genv -> (Prims.string, unit) FStar_Tactics_Effect.tac_repr) = @@ -1667,7 +1675,7 @@ let (genv_to_string : (fun binder_to_string -> let uu___1 = FStar_Tactics_Util.map binder_to_string - (FStar_Reflection_V1_Builtins.binders_of_env ge.env) in + (FStarC_Reflection_V1_Builtins.binders_of_env ge.env) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1745,7 +1753,7 @@ let (genv_to_string : let uu___12 = let uu___13 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -2044,15 +2052,15 @@ let (genv_to_string : uu___1) let (genv_get : genv -> - FStar_Reflection_Types.bv -> - (FStar_Reflection_Types.typ * Prims.bool * FStar_Reflection_Types.term) - FStar_Pervasives_Native.option) + FStarC_Reflection_Types.bv -> + (FStarC_Reflection_Types.typ * Prims.bool * + FStarC_Reflection_Types.term) FStar_Pervasives_Native.option) = fun ge -> fun b -> bind_map_get ge.bmap b let (genv_get_from_name : genv -> Prims.string -> - (((FStar_Reflection_Types.bv * FStar_Reflection_Types.typ) * - (Prims.bool * FStar_Reflection_Types.term)) + (((FStarC_Reflection_Types.bv * FStarC_Reflection_Types.typ) * + (Prims.bool * FStarC_Reflection_Types.term)) FStar_Pervasives_Native.option, unit) FStar_Tactics_Effect.tac_repr) = @@ -2080,10 +2088,10 @@ let (genv_get_from_name : FStar_Pervasives_Native.Some ((bv, sort), (b, x)))) let (genv_push_bv : genv -> - FStar_Reflection_Types.bv -> - FStar_Reflection_Types.typ -> + FStarC_Reflection_Types.bv -> + FStarC_Reflection_Types.typ -> Prims.bool -> - FStar_Reflection_Types.term FStar_Pervasives_Native.option -> + FStarC_Reflection_Types.term FStar_Pervasives_Native.option -> (genv, unit) FStar_Tactics_Effect.tac_repr) = fun ge -> @@ -2185,7 +2193,7 @@ let (genv_push_bv : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> - FStar_Reflection_V1_Builtins.push_binder + FStarC_Reflection_V1_Builtins.push_binder ge.env br)) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -2223,8 +2231,8 @@ let (genv_push_bv : else Obj.magic (Obj.repr - (FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Var + (FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Var b))) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -2259,9 +2267,9 @@ let (genv_push_bv : uu___2))) uu___1) let (genv_push_binder : genv -> - FStar_Reflection_Types.binder -> + FStarC_Reflection_Types.binder -> Prims.bool -> - FStar_Reflection_Types.term FStar_Pervasives_Native.option -> + FStarC_Reflection_Types.term FStar_Pervasives_Native.option -> (genv, unit) FStar_Tactics_Effect.tac_repr) = fun ge -> @@ -2287,43 +2295,44 @@ let (genv_push_binder : (genv_push_bv ge (FStar_Reflection_V1_Derived.bv_of_binder b) uu___1 abs t)) uu___1) -let (bv_is_shadowed : genv -> FStar_Reflection_Types.bv -> Prims.bool) = +let (bv_is_shadowed : genv -> FStarC_Reflection_Types.bv -> Prims.bool) = fun ge -> fun bv -> FStar_List_Tot_Base.existsb (fun uu___ -> match uu___ with | (b, uu___1) -> bv_eq bv b) ge.svars let (binder_is_shadowed : - genv -> FStar_Reflection_Types.binder -> Prims.bool) = + genv -> FStarC_Reflection_Types.binder -> Prims.bool) = fun ge -> fun b -> bv_is_shadowed ge (FStar_Reflection_V1_Derived.bv_of_binder b) let (find_shadowed_bvs : genv -> - FStar_Reflection_Types.bv Prims.list -> - (FStar_Reflection_Types.bv * Prims.bool) Prims.list) + FStarC_Reflection_Types.bv Prims.list -> + (FStarC_Reflection_Types.bv * Prims.bool) Prims.list) = fun ge -> fun bl -> FStar_List_Tot_Base.map (fun b -> (b, (bv_is_shadowed ge b))) bl let (find_shadowed_binders : genv -> - FStar_Reflection_Types.binder Prims.list -> - (FStar_Reflection_Types.binder * Prims.bool) Prims.list) + FStarC_Reflection_Types.binder Prims.list -> + (FStarC_Reflection_Types.binder * Prims.bool) Prims.list) = fun ge -> fun bl -> FStar_List_Tot_Base.map (fun b -> (b, (binder_is_shadowed ge b))) bl -let (bv_is_abstract : genv -> FStar_Reflection_Types.bv -> Prims.bool) = +let (bv_is_abstract : genv -> FStarC_Reflection_Types.bv -> Prims.bool) = fun ge -> fun bv -> match genv_get ge bv with | FStar_Pervasives_Native.None -> false | FStar_Pervasives_Native.Some (uu___, abs, uu___1) -> abs let (binder_is_abstract : - genv -> FStar_Reflection_Types.binder -> Prims.bool) = + genv -> FStarC_Reflection_Types.binder -> Prims.bool) = fun ge -> fun b -> bv_is_abstract ge (FStar_Reflection_V1_Derived.bv_of_binder b) let (genv_abstract_bvs : - genv -> (FStar_Reflection_Types.bv * FStar_Reflection_Types.typ) Prims.list) + genv -> + (FStarC_Reflection_Types.bv * FStarC_Reflection_Types.typ) Prims.list) = fun ge -> FStar_List_Tot_Base.concatMap @@ -2335,7 +2344,7 @@ let rec (_fresh_bv : Prims.string Prims.list -> Prims.string -> Prims.int -> - (FStar_Reflection_Types.bv, unit) FStar_Tactics_Effect.tac_repr) + (FStarC_Reflection_Types.bv, unit) FStar_Tactics_Effect.tac_repr) = fun binder_names -> fun basename -> @@ -2363,19 +2372,19 @@ let rec (_fresh_bv : Obj.magic (_fresh_bv binder_names basename (i + Prims.int_one)) else - Obj.magic (FStar_Tactics_V1_Builtins.fresh_bv_named name)) + Obj.magic (FStarC_Tactics_V1_Builtins.fresh_bv_named name)) uu___1) let (fresh_bv : - FStar_Reflection_Types.env -> + FStarC_Reflection_Types.env -> Prims.string -> - (FStar_Reflection_Types.bv, unit) FStar_Tactics_Effect.tac_repr) + (FStarC_Reflection_Types.bv, unit) FStar_Tactics_Effect.tac_repr) = fun e -> fun basename -> let uu___ = Obj.magic (FStar_Tactics_Effect.lift_div_tac - (fun uu___1 -> FStar_Reflection_V1_Builtins.binders_of_env e)) in + (fun uu___1 -> FStarC_Reflection_V1_Builtins.binders_of_env e)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2414,10 +2423,10 @@ let (fresh_bv : (_fresh_bv binder_names basename Prims.int_zero)) uu___2))) uu___1) let (fresh_binder : - FStar_Reflection_Types.env -> + FStarC_Reflection_Types.env -> Prims.string -> - FStar_Reflection_Types.typ -> - (FStar_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.typ -> + (FStarC_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) = fun e -> fun basename -> @@ -2441,8 +2450,8 @@ let (fresh_binder : let (genv_push_fresh_binder : genv -> Prims.string -> - FStar_Reflection_Types.typ -> - ((genv * FStar_Reflection_Types.binder), unit) + FStarC_Reflection_Types.typ -> + ((genv * FStarC_Reflection_Types.binder), unit) FStar_Tactics_Effect.tac_repr) = fun ge -> @@ -2484,10 +2493,10 @@ let (genv_push_fresh_binder : FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> (ge', b))))) uu___1) let (push_fresh_binder : - FStar_Reflection_Types.env -> + FStarC_Reflection_Types.env -> Prims.string -> - FStar_Reflection_Types.typ -> - ((FStar_Reflection_Types.env * FStar_Reflection_Types.binder), + FStarC_Reflection_Types.typ -> + ((FStarC_Reflection_Types.env * FStarC_Reflection_Types.binder), unit) FStar_Tactics_Effect.tac_repr) = fun e -> @@ -2509,12 +2518,12 @@ let (push_fresh_binder : (fun b -> FStar_Tactics_Effect.lift_div_tac (fun uu___1 -> - ((FStar_Reflection_V1_Builtins.push_binder e b), b))) + ((FStarC_Reflection_V1_Builtins.push_binder e b), b))) let (genv_push_fresh_bv : genv -> Prims.string -> - FStar_Reflection_Types.typ -> - ((genv * FStar_Reflection_Types.bv), unit) + FStarC_Reflection_Types.typ -> + ((genv * FStarC_Reflection_Types.bv), unit) FStar_Tactics_Effect.tac_repr) = fun ge -> @@ -2540,11 +2549,11 @@ let (genv_push_fresh_bv : | (ge', b) -> (ge', (FStar_Reflection_V1_Derived.bv_of_binder b)))) let (push_fresh_var : - FStar_Reflection_Types.env -> + FStarC_Reflection_Types.env -> Prims.string -> - FStar_Reflection_Types.typ -> - ((FStar_Reflection_Types.term * FStar_Reflection_Types.binder * - FStar_Reflection_Types.env), + FStarC_Reflection_Types.typ -> + ((FStarC_Reflection_Types.term * FStarC_Reflection_Types.binder * + FStarC_Reflection_Types.env), unit) FStar_Tactics_Effect.tac_repr) = fun e0 -> @@ -2568,8 +2577,8 @@ let (push_fresh_var : match uu___1 with | (e1, b1) -> let uu___2 = - FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Var + FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Var (FStar_Reflection_V1_Derived.bv_of_binder b1)) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -2592,8 +2601,9 @@ let (push_fresh_var : let (genv_push_fresh_var : genv -> Prims.string -> - FStar_Reflection_Types.typ -> - ((FStar_Reflection_Types.term * FStar_Reflection_Types.binder * genv), + FStarC_Reflection_Types.typ -> + ((FStarC_Reflection_Types.term * FStarC_Reflection_Types.binder * + genv), unit) FStar_Tactics_Effect.tac_repr) = fun ge0 -> @@ -2617,8 +2627,8 @@ let (genv_push_fresh_var : match uu___1 with | (ge1, b1) -> let uu___2 = - FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Var + FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Var (FStar_Reflection_V1_Derived.bv_of_binder b1)) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -2639,12 +2649,12 @@ let (genv_push_fresh_var : FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> (v1, b1, ge1))))) uu___1) let (push_two_fresh_vars : - FStar_Reflection_Types.env -> + FStarC_Reflection_Types.env -> Prims.string -> - FStar_Reflection_Types.typ -> - ((FStar_Reflection_Types.term * FStar_Reflection_Types.binder * - FStar_Reflection_Types.term * FStar_Reflection_Types.binder * - FStar_Reflection_Types.env), + FStarC_Reflection_Types.typ -> + ((FStarC_Reflection_Types.term * FStarC_Reflection_Types.binder * + FStarC_Reflection_Types.term * FStarC_Reflection_Types.binder * + FStarC_Reflection_Types.env), unit) FStar_Tactics_Effect.tac_repr) = fun e0 -> @@ -2688,8 +2698,8 @@ let (push_two_fresh_vars : match uu___3 with | (e2, b2) -> let uu___4 = - FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Var + FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Var (FStar_Reflection_V1_Derived.bv_of_binder b1)) in Obj.magic @@ -2714,8 +2724,8 @@ let (push_two_fresh_vars : (fun uu___5 -> (fun v1 -> let uu___5 = - FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Var + FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Var (FStar_Reflection_V1_Derived.bv_of_binder b2)) in Obj.magic @@ -2746,9 +2756,9 @@ let (push_two_fresh_vars : let (genv_push_two_fresh_vars : genv -> Prims.string -> - FStar_Reflection_Types.typ -> - ((FStar_Reflection_Types.term * FStar_Reflection_Types.binder * - FStar_Reflection_Types.term * FStar_Reflection_Types.binder * + FStarC_Reflection_Types.typ -> + ((FStarC_Reflection_Types.term * FStarC_Reflection_Types.binder * + FStarC_Reflection_Types.term * FStarC_Reflection_Types.binder * genv), unit) FStar_Tactics_Effect.tac_repr) = @@ -2793,8 +2803,8 @@ let (genv_push_two_fresh_vars : match uu___3 with | (ge2, b2) -> let uu___4 = - FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Var + FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Var (FStar_Reflection_V1_Derived.bv_of_binder b1)) in Obj.magic @@ -2819,8 +2829,8 @@ let (genv_push_two_fresh_vars : (fun uu___5 -> (fun v1 -> let uu___5 = - FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Var + FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Var (FStar_Reflection_V1_Derived.bv_of_binder b2)) in Obj.magic @@ -2849,11 +2859,11 @@ let (genv_push_two_fresh_vars : ge2))))) uu___5))) uu___3))) uu___1) let (norm_apply_subst : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.term -> - ((FStar_Reflection_Types.bv * FStar_Reflection_Types.typ) * - FStar_Reflection_Types.term) Prims.list -> - (FStar_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.term -> + ((FStarC_Reflection_Types.bv * FStarC_Reflection_Types.typ) * + FStarC_Reflection_Types.term) Prims.list -> + (FStarC_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) = fun e -> fun t -> @@ -2955,15 +2965,15 @@ let (norm_apply_subst : (fun uu___5 -> (fun t2 -> Obj.magic - (FStar_Tactics_V1_Builtins.norm_term_env + (FStarC_Tactics_V1_Builtins.norm_term_env e [] t2)) uu___5))) uu___4))) uu___3))) uu___1) let (norm_apply_subst_in_comp : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.comp -> - ((FStar_Reflection_Types.bv * FStar_Reflection_Types.typ) * - FStar_Reflection_Types.term) Prims.list -> - (FStar_Reflection_Types.comp, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.comp -> + ((FStarC_Reflection_Types.bv * FStarC_Reflection_Types.typ) * + FStarC_Reflection_Types.term) Prims.list -> + (FStarC_Reflection_Types.comp, unit) FStar_Tactics_Effect.tac_repr) = fun e -> fun c -> @@ -2994,17 +3004,17 @@ let (norm_apply_subst_in_comp : (fun uu___2 -> fun a -> match a with - | FStar_Reflection_V1_Data.Q_Implicit -> + | FStarC_Reflection_V1_Data.Q_Implicit -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> a))) - | FStar_Reflection_V1_Data.Q_Explicit -> + | FStarC_Reflection_V1_Data.Q_Explicit -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> a))) - | FStar_Reflection_V1_Data.Q_Meta t -> + | FStarC_Reflection_V1_Data.Q_Meta t -> Obj.magic (Obj.repr (let uu___3 = subst1 t in @@ -3029,7 +3039,7 @@ let (norm_apply_subst_in_comp : (fun uu___4 -> FStar_Tactics_Effect.lift_div_tac (fun uu___5 -> - FStar_Reflection_V1_Data.Q_Meta + FStarC_Reflection_V1_Data.Q_Meta uu___4))))) uu___3 uu___2)) in Obj.magic @@ -3049,9 +3059,9 @@ let (norm_apply_subst_in_comp : (Obj.magic uu___1) (fun uu___2 -> (fun subst_in_aqualv -> - match FStar_Reflection_V1_Builtins.inspect_comp c + match FStarC_Reflection_V1_Builtins.inspect_comp c with - | FStar_Reflection_V1_Data.C_Total ret -> + | FStarC_Reflection_V1_Data.C_Total ret -> let uu___2 = subst1 ret in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -3075,10 +3085,10 @@ let (norm_apply_subst_in_comp : (fun ret1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> - FStar_Reflection_V1_Builtins.pack_comp - (FStar_Reflection_V1_Data.C_Total + FStarC_Reflection_V1_Builtins.pack_comp + (FStarC_Reflection_V1_Data.C_Total ret1)))) - | FStar_Reflection_V1_Data.C_GTotal ret -> + | FStarC_Reflection_V1_Data.C_GTotal ret -> let uu___2 = subst1 ret in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -3102,10 +3112,10 @@ let (norm_apply_subst_in_comp : (fun ret1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> - FStar_Reflection_V1_Builtins.pack_comp - (FStar_Reflection_V1_Data.C_GTotal + FStarC_Reflection_V1_Builtins.pack_comp + (FStarC_Reflection_V1_Data.C_GTotal ret1)))) - | FStar_Reflection_V1_Data.C_Lemma + | FStarC_Reflection_V1_Data.C_Lemma (pre, post, patterns) -> let uu___2 = subst1 pre in Obj.magic @@ -3175,14 +3185,14 @@ let (norm_apply_subst_in_comp : (fun patterns1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___5 -> - FStar_Reflection_V1_Builtins.pack_comp + FStarC_Reflection_V1_Builtins.pack_comp ( - FStar_Reflection_V1_Data.C_Lemma + FStarC_Reflection_V1_Data.C_Lemma (pre1, post1, patterns1)))))) uu___4))) uu___3)) - | FStar_Reflection_V1_Data.C_Eff + | FStarC_Reflection_V1_Data.C_Eff (us, eff_name, result, eff_args, decrs) -> let uu___2 = subst1 result in Obj.magic @@ -3309,9 +3319,9 @@ let (norm_apply_subst_in_comp : (fun decrs1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___5 -> - FStar_Reflection_V1_Builtins.pack_comp + FStarC_Reflection_V1_Builtins.pack_comp ( - FStar_Reflection_V1_Data.C_Eff + FStarC_Reflection_V1_Data.C_Eff (us, eff_name, result1, @@ -3320,15 +3330,15 @@ let (norm_apply_subst_in_comp : uu___4))) uu___3))) uu___2))) uu___1) let rec (deep_apply_subst : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.bv * FStar_Reflection_Types.term) Prims.list -> - (FStar_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.bv * FStarC_Reflection_Types.term) Prims.list + -> (FStarC_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) = fun e -> fun t -> fun subst -> - let uu___ = FStar_Tactics_V1_Builtins.inspect t in + let uu___ = FStarC_Tactics_V1_Builtins.inspect t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -3344,7 +3354,7 @@ let rec (deep_apply_subst : (fun uu___1 -> (fun uu___1 -> match uu___1 with - | FStar_Reflection_V1_Data.Tv_Var b -> + | FStarC_Reflection_V1_Data.Tv_Var b -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac @@ -3352,7 +3362,7 @@ let rec (deep_apply_subst : match bind_map_get subst b with | FStar_Pervasives_Native.None -> t | FStar_Pervasives_Native.Some t' -> t'))) - | FStar_Reflection_V1_Data.Tv_BVar b -> + | FStarC_Reflection_V1_Data.Tv_BVar b -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac @@ -3360,11 +3370,11 @@ let rec (deep_apply_subst : match bind_map_get subst b with | FStar_Pervasives_Native.None -> t | FStar_Pervasives_Native.Some t' -> t'))) - | FStar_Reflection_V1_Data.Tv_FVar uu___2 -> + | FStarC_Reflection_V1_Data.Tv_FVar uu___2 -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> t))) - | FStar_Reflection_V1_Data.Tv_App (hd, (a, qual)) -> + | FStarC_Reflection_V1_Data.Tv_App (hd, (a, qual)) -> Obj.magic (Obj.repr (let uu___2 = deep_apply_subst e hd subst in @@ -3407,11 +3417,11 @@ let rec (deep_apply_subst : (fun uu___4 -> (fun a1 -> Obj.magic - (FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_App + (FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_App (hd1, (a1, qual))))) uu___4))) uu___3))) - | FStar_Reflection_V1_Data.Tv_Abs (br, body) -> + | FStarC_Reflection_V1_Data.Tv_Abs (br, body) -> Obj.magic (Obj.repr (let uu___2 = deep_apply_subst e body subst in @@ -3432,10 +3442,10 @@ let rec (deep_apply_subst : (fun uu___3 -> (fun body1 -> Obj.magic - (FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Abs + (FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Abs (br, body1)))) uu___3))) - | FStar_Reflection_V1_Data.Tv_Arrow (br, c) -> + | FStarC_Reflection_V1_Data.Tv_Arrow (br, c) -> Obj.magic (Obj.repr (let uu___2 = deep_apply_subst_in_binder e br subst in @@ -3481,15 +3491,15 @@ let rec (deep_apply_subst : (fun uu___5 -> (fun c1 -> Obj.magic - (FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Arrow + (FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Arrow (br1, c1)))) uu___5))) uu___3))) - | FStar_Reflection_V1_Data.Tv_Type uu___2 -> + | FStarC_Reflection_V1_Data.Tv_Type uu___2 -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> t))) - | FStar_Reflection_V1_Data.Tv_Refine (bv, sort, ref) -> + | FStarC_Reflection_V1_Data.Tv_Refine (bv, sort, ref) -> Obj.magic (Obj.repr (let uu___2 = deep_apply_subst e sort subst in @@ -3559,22 +3569,22 @@ let rec (deep_apply_subst : (fun uu___6 -> (fun ref1 -> Obj.magic - (FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Refine + (FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Refine (bv1, sort1, ref1)))) uu___6))) uu___4))) uu___3))) - | FStar_Reflection_V1_Data.Tv_Const uu___2 -> + | FStarC_Reflection_V1_Data.Tv_Const uu___2 -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> t))) - | FStar_Reflection_V1_Data.Tv_Uvar (uu___2, uu___3) -> + | FStarC_Reflection_V1_Data.Tv_Uvar (uu___2, uu___3) -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> t))) - | FStar_Reflection_V1_Data.Tv_Let + | FStarC_Reflection_V1_Data.Tv_Let (recf, attrs, bv, ty, def, body) -> Obj.magic (Obj.repr @@ -3673,8 +3683,8 @@ let rec (deep_apply_subst : (fun body1 -> Obj.magic - (FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Let + (FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Let (recf, [], bv1, ty1, @@ -3683,7 +3693,7 @@ let rec (deep_apply_subst : uu___7))) uu___5))) uu___4))) uu___3))) - | FStar_Reflection_V1_Data.Tv_Match + | FStarC_Reflection_V1_Data.Tv_Match (scrutinee, ret_opt, branches) -> Obj.magic (Obj.repr @@ -4144,15 +4154,15 @@ let rec (deep_apply_subst : branches1 -> Obj.magic - (FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Match + (FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Match (scrutinee1, ret_opt1, branches1)))) uu___6))) uu___5))) uu___4))) uu___3))) - | FStar_Reflection_V1_Data.Tv_AscribedT + | FStarC_Reflection_V1_Data.Tv_AscribedT (exp, ty, tac, use_eq) -> Obj.magic (Obj.repr @@ -4196,14 +4206,14 @@ let rec (deep_apply_subst : (fun uu___4 -> (fun ty1 -> Obj.magic - (FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_AscribedT + (FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_AscribedT (exp1, ty1, FStar_Pervasives_Native.None, use_eq)))) uu___4))) uu___3))) - | FStar_Reflection_V1_Data.Tv_AscribedC (exp, c, tac, use_eq) - -> + | FStarC_Reflection_V1_Data.Tv_AscribedC + (exp, c, tac, use_eq) -> Obj.magic (Obj.repr (let uu___2 = deep_apply_subst e exp subst in @@ -4247,8 +4257,8 @@ let rec (deep_apply_subst : (fun uu___4 -> (fun c1 -> Obj.magic - (FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_AscribedC + (FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_AscribedC (exp1, c1, FStar_Pervasives_Native.None, use_eq)))) uu___4))) @@ -4259,11 +4269,12 @@ let rec (deep_apply_subst : (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> t)))) uu___1) and (deep_apply_subst_in_bv : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.bv -> - (FStar_Reflection_Types.bv * FStar_Reflection_Types.term) Prims.list -> - ((FStar_Reflection_Types.bv * (FStar_Reflection_Types.bv * - FStar_Reflection_Types.term) Prims.list), + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.bv -> + (FStarC_Reflection_Types.bv * FStarC_Reflection_Types.term) Prims.list + -> + ((FStarC_Reflection_Types.bv * (FStarC_Reflection_Types.bv * + FStarC_Reflection_Types.term) Prims.list), unit) FStar_Tactics_Effect.tac_repr) = fun e -> @@ -4272,8 +4283,8 @@ and (deep_apply_subst_in_bv : let uu___ = let uu___1 = let uu___2 = - FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Var bv) in + FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Var bv) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -4319,21 +4330,22 @@ and (deep_apply_subst_in_bv : (fun uu___1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> (bv, uu___1))) and (deep_apply_subst_in_binder : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.binder -> - (FStar_Reflection_Types.bv * FStar_Reflection_Types.term) Prims.list -> - ((FStar_Reflection_Types.binder * (FStar_Reflection_Types.bv * - FStar_Reflection_Types.term) Prims.list), + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.binder -> + (FStarC_Reflection_Types.bv * FStarC_Reflection_Types.term) Prims.list + -> + ((FStarC_Reflection_Types.binder * (FStarC_Reflection_Types.bv * + FStarC_Reflection_Types.term) Prims.list), unit) FStar_Tactics_Effect.tac_repr) = fun e -> fun br -> fun subst -> - match FStar_Reflection_V1_Builtins.inspect_binder br with - | { FStar_Reflection_V1_Data.binder_bv = binder_bv; - FStar_Reflection_V1_Data.binder_qual = binder_qual; - FStar_Reflection_V1_Data.binder_attrs = binder_attrs; - FStar_Reflection_V1_Data.binder_sort = binder_sort;_} -> + match FStarC_Reflection_V1_Builtins.inspect_binder br with + | { FStarC_Reflection_V1_Data.binder_bv = binder_bv; + FStarC_Reflection_V1_Data.binder_qual = binder_qual; + FStarC_Reflection_V1_Data.binder_attrs = binder_attrs; + FStarC_Reflection_V1_Data.binder_sort = binder_sort;_} -> let uu___ = deep_apply_subst e binder_sort subst in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -4370,22 +4382,22 @@ and (deep_apply_subst_in_binder : (fun uu___3 -> match uu___2 with | (binder_bv1, subst1) -> - ((FStar_Reflection_V1_Builtins.pack_binder + ((FStarC_Reflection_V1_Builtins.pack_binder { - FStar_Reflection_V1_Data.binder_bv + FStarC_Reflection_V1_Data.binder_bv = binder_bv1; - FStar_Reflection_V1_Data.binder_qual + FStarC_Reflection_V1_Data.binder_qual = binder_qual; - FStar_Reflection_V1_Data.binder_attrs + FStarC_Reflection_V1_Data.binder_attrs = binder_attrs; - FStar_Reflection_V1_Data.binder_sort + FStarC_Reflection_V1_Data.binder_sort = binder_sort1 }), subst1))))) uu___1) and (deep_apply_subst_in_comp : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.comp -> - (FStar_Reflection_Types.bv * FStar_Reflection_Types.term) Prims.list -> - (FStar_Reflection_Types.comp, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.comp -> + (FStarC_Reflection_Types.bv * FStarC_Reflection_Types.term) Prims.list + -> (FStarC_Reflection_Types.comp, unit) FStar_Tactics_Effect.tac_repr) = fun e -> fun c -> @@ -4416,17 +4428,17 @@ and (deep_apply_subst_in_comp : (fun uu___2 -> fun a -> match a with - | FStar_Reflection_V1_Data.Q_Implicit -> + | FStarC_Reflection_V1_Data.Q_Implicit -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> a))) - | FStar_Reflection_V1_Data.Q_Explicit -> + | FStarC_Reflection_V1_Data.Q_Explicit -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> a))) - | FStar_Reflection_V1_Data.Q_Meta t -> + | FStarC_Reflection_V1_Data.Q_Meta t -> Obj.magic (Obj.repr (let uu___3 = subst1 t in @@ -4451,7 +4463,7 @@ and (deep_apply_subst_in_comp : (fun uu___4 -> FStar_Tactics_Effect.lift_div_tac (fun uu___5 -> - FStar_Reflection_V1_Data.Q_Meta + FStarC_Reflection_V1_Data.Q_Meta uu___4))))) uu___3 uu___2)) in Obj.magic @@ -4471,9 +4483,9 @@ and (deep_apply_subst_in_comp : (Obj.magic uu___1) (fun uu___2 -> (fun subst_in_aqualv -> - match FStar_Reflection_V1_Builtins.inspect_comp c + match FStarC_Reflection_V1_Builtins.inspect_comp c with - | FStar_Reflection_V1_Data.C_Total ret -> + | FStarC_Reflection_V1_Data.C_Total ret -> let uu___2 = subst1 ret in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -4497,10 +4509,10 @@ and (deep_apply_subst_in_comp : (fun ret1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> - FStar_Reflection_V1_Builtins.pack_comp - (FStar_Reflection_V1_Data.C_Total + FStarC_Reflection_V1_Builtins.pack_comp + (FStarC_Reflection_V1_Data.C_Total ret1)))) - | FStar_Reflection_V1_Data.C_GTotal ret -> + | FStarC_Reflection_V1_Data.C_GTotal ret -> let uu___2 = subst1 ret in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -4524,10 +4536,10 @@ and (deep_apply_subst_in_comp : (fun ret1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> - FStar_Reflection_V1_Builtins.pack_comp - (FStar_Reflection_V1_Data.C_GTotal + FStarC_Reflection_V1_Builtins.pack_comp + (FStarC_Reflection_V1_Data.C_GTotal ret1)))) - | FStar_Reflection_V1_Data.C_Lemma + | FStarC_Reflection_V1_Data.C_Lemma (pre, post, patterns) -> let uu___2 = subst1 pre in Obj.magic @@ -4597,14 +4609,14 @@ and (deep_apply_subst_in_comp : (fun patterns1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___5 -> - FStar_Reflection_V1_Builtins.pack_comp + FStarC_Reflection_V1_Builtins.pack_comp ( - FStar_Reflection_V1_Data.C_Lemma + FStarC_Reflection_V1_Data.C_Lemma (pre1, post1, patterns1)))))) uu___4))) uu___3)) - | FStar_Reflection_V1_Data.C_Eff + | FStarC_Reflection_V1_Data.C_Eff (us, eff_name, result, eff_args, decrs) -> let uu___2 = subst1 result in Obj.magic @@ -4731,9 +4743,9 @@ and (deep_apply_subst_in_comp : (fun decrs1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___5 -> - FStar_Reflection_V1_Builtins.pack_comp + FStarC_Reflection_V1_Builtins.pack_comp ( - FStar_Reflection_V1_Data.C_Eff + FStarC_Reflection_V1_Data.C_Eff (us, eff_name, result1, @@ -4742,11 +4754,12 @@ and (deep_apply_subst_in_comp : uu___4))) uu___3))) uu___2))) uu___1) and (deep_apply_subst_in_pattern : - FStar_Reflection_Types.env -> - FStar_Reflection_V1_Data.pattern -> - (FStar_Reflection_Types.bv * FStar_Reflection_Types.term) Prims.list -> - ((FStar_Reflection_V1_Data.pattern * (FStar_Reflection_Types.bv * - FStar_Reflection_Types.term) Prims.list), + FStarC_Reflection_Types.env -> + FStarC_Reflection_V1_Data.pattern -> + (FStarC_Reflection_Types.bv * FStarC_Reflection_Types.term) Prims.list + -> + ((FStarC_Reflection_V1_Data.pattern * (FStarC_Reflection_Types.bv * + FStarC_Reflection_Types.term) Prims.list), unit) FStar_Tactics_Effect.tac_repr) = fun uu___2 -> @@ -4756,12 +4769,12 @@ and (deep_apply_subst_in_pattern : fun pat -> fun subst -> match pat with - | FStar_Reflection_V1_Data.Pat_Constant uu___ -> + | FStarC_Reflection_V1_Data.Pat_Constant uu___ -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___1 -> (pat, subst)))) - | FStar_Reflection_V1_Data.Pat_Cons (fv, us, patterns) -> + | FStarC_Reflection_V1_Data.Pat_Cons (fv, us, patterns) -> Obj.magic (Obj.repr (let uu___ = @@ -4818,9 +4831,9 @@ and (deep_apply_subst_in_pattern : (fun uu___2 -> match uu___1 with | (patterns1, subst1) -> - ((FStar_Reflection_V1_Data.Pat_Cons + ((FStarC_Reflection_V1_Data.Pat_Cons (fv, us, patterns1)), subst1))))) - | FStar_Reflection_V1_Data.Pat_Var (bv, st) -> + | FStarC_Reflection_V1_Data.Pat_Var (bv, st) -> Obj.magic (Obj.repr (let uu___ = @@ -4912,10 +4925,10 @@ and (deep_apply_subst_in_pattern : (fun uu___3 -> match uu___2 with | (bv1, subst1) -> - ((FStar_Reflection_V1_Data.Pat_Var + ((FStarC_Reflection_V1_Data.Pat_Var (bv1, st1)), subst1))))) uu___1))) - | FStar_Reflection_V1_Data.Pat_Dot_Term eopt -> + | FStarC_Reflection_V1_Data.Pat_Dot_Term eopt -> Obj.magic (Obj.repr (let uu___ = @@ -4942,7 +4955,7 @@ and (deep_apply_subst_in_pattern : (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> - FStar_Reflection_V1_Data.Pat_Dot_Term + FStarC_Reflection_V1_Data.Pat_Dot_Term uu___2)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -4963,25 +4976,25 @@ and (deep_apply_subst_in_pattern : (fun uu___2 -> (uu___1, subst)))))) uu___2 uu___1 uu___ let (apply_subst : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.term -> - ((FStar_Reflection_Types.bv * FStar_Reflection_Types.typ) * - FStar_Reflection_Types.term) Prims.list -> - (FStar_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.term -> + ((FStarC_Reflection_Types.bv * FStarC_Reflection_Types.typ) * + FStarC_Reflection_Types.term) Prims.list -> + (FStarC_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) = norm_apply_subst let (apply_subst_in_comp : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.comp -> - ((FStar_Reflection_Types.bv * FStar_Reflection_Types.typ) * - FStar_Reflection_Types.term) Prims.list -> - (FStar_Reflection_Types.comp, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.comp -> + ((FStarC_Reflection_Types.bv * FStarC_Reflection_Types.typ) * + FStarC_Reflection_Types.term) Prims.list -> + (FStarC_Reflection_Types.comp, unit) FStar_Tactics_Effect.tac_repr) = norm_apply_subst_in_comp let (opt_apply_subst : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.term FStar_Pervasives_Native.option -> - ((FStar_Reflection_Types.bv * FStar_Reflection_Types.typ) * - FStar_Reflection_Types.term) Prims.list -> - (FStar_Reflection_Types.term FStar_Pervasives_Native.option, + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.term FStar_Pervasives_Native.option -> + ((FStarC_Reflection_Types.bv * FStarC_Reflection_Types.typ) * + FStarC_Reflection_Types.term) Prims.list -> + (FStarC_Reflection_Types.term FStar_Pervasives_Native.option, unit) FStar_Tactics_Effect.tac_repr) = fun uu___2 -> @@ -5021,10 +5034,11 @@ let (opt_apply_subst : uu___2 uu___1 uu___ let rec (_generate_shadowed_subst : genv -> - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.bv * FStar_Reflection_Types.typ) Prims.list -> - ((genv * (FStar_Reflection_Types.bv * FStar_Reflection_Types.typ * - FStar_Reflection_Types.bv) Prims.list), + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.bv * FStarC_Reflection_Types.typ) Prims.list + -> + ((genv * (FStarC_Reflection_Types.bv * FStarC_Reflection_Types.typ * + FStarC_Reflection_Types.bv) Prims.list), unit) FStar_Tactics_Effect.tac_repr) = fun uu___2 -> @@ -5042,7 +5056,7 @@ let rec (_generate_shadowed_subst : | old_bv::bvl' -> Obj.magic (Obj.repr - (let uu___ = FStar_Tactics_V1_Builtins.inspect t in + (let uu___ = FStarC_Tactics_V1_Builtins.inspect t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -5060,14 +5074,14 @@ let rec (_generate_shadowed_subst : (fun uu___1 -> (fun uu___1 -> match uu___1 with - | FStar_Reflection_V1_Data.Tv_Abs + | FStarC_Reflection_V1_Data.Tv_Abs (b, uu___2) -> let uu___3 = Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> - (FStar_Reflection_V1_Builtins.inspect_binder - b).FStar_Reflection_V1_Data.binder_bv)) in + (FStarC_Reflection_V1_Builtins.inspect_binder + b).FStarC_Reflection_V1_Data.binder_bv)) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -5093,7 +5107,7 @@ let rec (_generate_shadowed_subst : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___5 -> - FStar_Reflection_V1_Builtins.inspect_bv + FStarC_Reflection_V1_Builtins.inspect_bv bv)) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -5145,7 +5159,7 @@ let rec (_generate_shadowed_subst : let uu___6 = FStar_Tactics_Unseal.unseal - bvv.FStar_Reflection_V1_Data.bv_ppname in + bvv.FStarC_Reflection_V1_Data.bv_ppname in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -5212,8 +5226,8 @@ let rec (_generate_shadowed_subst : = let uu___11 = - FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Var + FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Var fresh) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -5297,7 +5311,7 @@ let rec (_generate_shadowed_subst : -> let uu___10 = - FStar_Tactics_V1_Builtins.norm_term_env + FStarC_Tactics_V1_Builtins.norm_term_env ge1.env [] t1 in Obj.magic @@ -5381,8 +5395,8 @@ let rec (_generate_shadowed_subst : uu___1)))) uu___2 uu___1 uu___ let (generate_shadowed_subst : genv -> - ((genv * (FStar_Reflection_Types.bv * FStar_Reflection_Types.typ * - FStar_Reflection_Types.bv) Prims.list), + ((genv * (FStarC_Reflection_Types.bv * FStarC_Reflection_Types.typ * + FStarC_Reflection_Types.bv) Prims.list), unit) FStar_Tactics_Effect.tac_repr) = fun ge -> @@ -5432,9 +5446,9 @@ let (generate_shadowed_subst : (fun bl -> let uu___2 = FStar_Tactics_V1_Derived.mk_abs bl - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const - FStar_Reflection_V2_Data.C_Unit)) in + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const + FStarC_Reflection_V2_Data.C_Unit)) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal diff --git a/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_Effectful.ml b/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_Effectful.ml index 1803794ba77..e9c2d8c4d07 100644 --- a/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_Effectful.ml +++ b/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_Effectful.ml @@ -1,10 +1,10 @@ open Prims let (term_eq : - FStar_Reflection_Types.term -> FStar_Reflection_Types.term -> Prims.bool) = - FStar_Reflection_TermEq_Simple.term_eq + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term -> Prims.bool) + = FStar_Reflection_TermEq_Simple.term_eq type cast_info = { - term: FStar_Reflection_Types.term ; + term: FStarC_Reflection_Types.term ; p_ty: FStar_InteractiveHelpers_ExploreTerm.type_info FStar_Pervasives_Native.option @@ -14,7 +14,7 @@ type cast_info = FStar_Pervasives_Native.option } let (__proj__Mkcast_info__item__term : - cast_info -> FStar_Reflection_Types.term) = + cast_info -> FStarC_Reflection_Types.term) = fun projectee -> match projectee with | { term; p_ty; exp_ty;_} -> term let (__proj__Mkcast_info__item__p_ty : cast_info -> @@ -27,7 +27,7 @@ let (__proj__Mkcast_info__item__exp_ty : FStar_Pervasives_Native.option) = fun projectee -> match projectee with | { term; p_ty; exp_ty;_} -> exp_ty let (mk_cast_info : - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.term -> FStar_InteractiveHelpers_ExploreTerm.type_info FStar_Pervasives_Native.option -> FStar_InteractiveHelpers_ExploreTerm.type_info @@ -37,7 +37,7 @@ let (cast_info_to_string : cast_info -> (Prims.string, unit) FStar_Tactics_Effect.tac_repr) = fun info -> let uu___ = - let uu___1 = FStar_Tactics_V1_Builtins.term_to_string info.term in + let uu___1 = FStarC_Tactics_V1_Builtins.term_to_string info.term in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -191,8 +191,8 @@ type effect_info = { ei_type: FStar_InteractiveHelpers_ExploreTerm.effect_type ; ei_ret_type: FStar_InteractiveHelpers_ExploreTerm.type_info ; - ei_pre: FStar_Reflection_Types.term FStar_Pervasives_Native.option ; - ei_post: FStar_Reflection_Types.term FStar_Pervasives_Native.option } + ei_pre: FStarC_Reflection_Types.term FStar_Pervasives_Native.option ; + ei_post: FStarC_Reflection_Types.term FStar_Pervasives_Native.option } let (__proj__Mkeffect_info__item__ei_type : effect_info -> FStar_InteractiveHelpers_ExploreTerm.effect_type) = fun projectee -> @@ -204,13 +204,13 @@ let (__proj__Mkeffect_info__item__ei_ret_type : match projectee with | { ei_type; ei_ret_type; ei_pre; ei_post;_} -> ei_ret_type let (__proj__Mkeffect_info__item__ei_pre : - effect_info -> FStar_Reflection_Types.term FStar_Pervasives_Native.option) + effect_info -> FStarC_Reflection_Types.term FStar_Pervasives_Native.option) = fun projectee -> match projectee with | { ei_type; ei_ret_type; ei_pre; ei_post;_} -> ei_pre let (__proj__Mkeffect_info__item__ei_post : - effect_info -> FStar_Reflection_Types.term FStar_Pervasives_Native.option) + effect_info -> FStarC_Reflection_Types.term FStar_Pervasives_Native.option) = fun projectee -> match projectee with @@ -218,8 +218,8 @@ let (__proj__Mkeffect_info__item__ei_post : let (mk_effect_info : FStar_InteractiveHelpers_ExploreTerm.effect_type -> FStar_InteractiveHelpers_ExploreTerm.type_info -> - FStar_Reflection_Types.term FStar_Pervasives_Native.option -> - FStar_Reflection_Types.term FStar_Pervasives_Native.option -> + FStarC_Reflection_Types.term FStar_Pervasives_Native.option -> + FStarC_Reflection_Types.term FStar_Pervasives_Native.option -> effect_info) = fun uu___ -> @@ -240,7 +240,7 @@ let (effect_info_to_string : let uu___2 = let uu___3 = FStar_InteractiveHelpers_Base.option_to_string - FStar_Tactics_V1_Builtins.term_to_string c.ei_pre in + FStarC_Tactics_V1_Builtins.term_to_string c.ei_pre in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -282,7 +282,7 @@ let (effect_info_to_string : let uu___10 = let uu___11 = FStar_InteractiveHelpers_Base.option_to_string - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string c.ei_post in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -432,13 +432,13 @@ let (effect_info_to_string : type eterm_info = { einfo: effect_info ; - head: FStar_Reflection_Types.term ; + head: FStarC_Reflection_Types.term ; parameters: cast_info Prims.list } let (__proj__Mketerm_info__item__einfo : eterm_info -> effect_info) = fun projectee -> match projectee with | { einfo; head; parameters;_} -> einfo let (__proj__Mketerm_info__item__head : - eterm_info -> FStar_Reflection_Types.term) = + eterm_info -> FStarC_Reflection_Types.term) = fun projectee -> match projectee with | { einfo; head; parameters;_} -> head let (__proj__Mketerm_info__item__parameters : @@ -540,7 +540,7 @@ let (eterm_info_to_string : let uu___5 = let uu___6 = let uu___7 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string info.head in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -632,20 +632,20 @@ let (eterm_info_to_string : uu___2))) uu___1) let (mk_eterm_info : effect_info -> - FStar_Reflection_Types.term -> cast_info Prims.list -> eterm_info) + FStarC_Reflection_Types.term -> cast_info Prims.list -> eterm_info) = fun uu___ -> fun uu___1 -> fun uu___2 -> { einfo = uu___; head = uu___1; parameters = uu___2 } let rec (decompose_application_aux : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.term -> - ((FStar_Reflection_Types.term * cast_info Prims.list), unit) + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.term -> + ((FStarC_Reflection_Types.term * cast_info Prims.list), unit) FStar_Tactics_Effect.tac_repr) = fun e -> fun t -> - let uu___ = FStar_Tactics_V1_Builtins.inspect t in + let uu___ = FStarC_Tactics_V1_Builtins.inspect t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -660,7 +660,7 @@ let rec (decompose_application_aux : (fun uu___1 -> (fun uu___1 -> match uu___1 with - | FStar_Reflection_V1_Data.Tv_App (hd, (a, qualif)) -> + | FStarC_Reflection_V1_Data.Tv_App (hd, (a, qualif)) -> Obj.magic (Obj.repr (let uu___2 = decompose_application_aux e hd in @@ -746,7 +746,7 @@ let rec (decompose_application_aux : (Obj.repr (let uu___7 = - FStar_Tactics_V1_Builtins.inspect + FStarC_Tactics_V1_Builtins.inspect hd_ty' in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -774,7 +774,7 @@ let rec (decompose_application_aux : match uu___8 with | - FStar_Reflection_V1_Data.Tv_Arrow + FStarC_Reflection_V1_Data.Tv_Arrow (b, c) -> Obj.magic (Obj.repr @@ -892,9 +892,9 @@ let rec (decompose_application_aux : (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> (t, []))))) uu___1) let (decompose_application : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.term -> - ((FStar_Reflection_Types.term * cast_info Prims.list), unit) + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.term -> + ((FStarC_Reflection_Types.term * cast_info Prims.list), unit) FStar_Tactics_Effect.tac_repr) = fun e -> @@ -919,14 +919,14 @@ let (decompose_application : | (hd, params) -> (hd, (FStar_List_Tot_Base.rev params)))) let (comp_view_to_effect_info : Prims.bool -> - FStar_Reflection_V1_Data.comp_view -> + FStarC_Reflection_V1_Data.comp_view -> (effect_info FStar_Pervasives_Native.option, unit) FStar_Tactics_Effect.tac_repr) = fun dbg -> fun cv -> match cv with - | FStar_Reflection_V1_Data.C_Total ret_ty -> + | FStarC_Reflection_V1_Data.C_Total ret_ty -> let uu___ = FStar_InteractiveHelpers_ExploreTerm.get_type_info_from_type ret_ty in @@ -952,7 +952,7 @@ let (comp_view_to_effect_info : FStar_InteractiveHelpers_ExploreTerm.E_Total ret_type_info FStar_Pervasives_Native.None FStar_Pervasives_Native.None))) - | FStar_Reflection_V1_Data.C_GTotal ret_ty -> + | FStarC_Reflection_V1_Data.C_GTotal ret_ty -> let uu___ = FStar_InteractiveHelpers_ExploreTerm.get_type_info_from_type ret_ty in @@ -978,7 +978,7 @@ let (comp_view_to_effect_info : FStar_InteractiveHelpers_ExploreTerm.E_Total ret_type_info FStar_Pervasives_Native.None FStar_Pervasives_Native.None))) - | FStar_Reflection_V1_Data.C_Lemma (pre, post, patterns) -> + | FStarC_Reflection_V1_Data.C_Lemma (pre, post, patterns) -> let uu___ = FStar_InteractiveHelpers_Base.prettify_term dbg pre in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1023,7 +1023,7 @@ let (comp_view_to_effect_info : (FStar_Pervasives_Native.Some pre1) (FStar_Pervasives_Native.Some post1)))))) uu___1) - | FStar_Reflection_V1_Data.C_Eff + | FStarC_Reflection_V1_Data.C_Eff (univs, eff_name, ret_ty, eff_args, uu___) -> let uu___1 = FStar_InteractiveHelpers_Base.print_dbg dbg @@ -1259,7 +1259,7 @@ let (comp_view_to_effect_info : uu___2) let (comp_to_effect_info : Prims.bool -> - FStar_Reflection_Types.comp -> + FStarC_Reflection_Types.comp -> (effect_info FStar_Pervasives_Native.option, unit) FStar_Tactics_Effect.tac_repr) = @@ -1268,7 +1268,7 @@ let (comp_to_effect_info : let uu___ = Obj.magic (FStar_Tactics_Effect.lift_div_tac - (fun uu___1 -> FStar_Reflection_V1_Builtins.inspect_comp c)) in + (fun uu___1 -> FStarC_Reflection_V1_Builtins.inspect_comp c)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1284,8 +1284,8 @@ let (comp_to_effect_info : (fun cv -> Obj.magic (comp_view_to_effect_info dbg cv)) uu___1) let (compute_effect_info : Prims.bool -> - FStar_Reflection_Types.env -> - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.term -> (effect_info FStar_Pervasives_Native.option, unit) FStar_Tactics_Effect.tac_repr) = @@ -1456,13 +1456,13 @@ let (typ_or_comp_to_effect_info : (fun uu___4 -> einfo)))) uu___4))) uu___1) let (tcc_no_lift : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.comp, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.comp, unit) FStar_Tactics_Effect.tac_repr) = fun e -> fun t -> - let uu___ = FStar_Tactics_V1_Builtins.inspect t in + let uu___ = FStarC_Tactics_V1_Builtins.inspect t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1477,7 +1477,7 @@ let (tcc_no_lift : (fun uu___1 -> (fun uu___1 -> match uu___1 with - | FStar_Reflection_V1_Data.Tv_App (uu___2, uu___3) -> + | FStarC_Reflection_V1_Data.Tv_App (uu___2, uu___3) -> let uu___4 = FStar_Tactics_V1_SyntaxHelpers.collect_app t in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1499,7 +1499,7 @@ let (tcc_no_lift : match uu___5 with | (hd, args) -> let uu___6 = - FStar_Tactics_V1_Builtins.tcc e hd in + FStarC_Tactics_V1_Builtins.tcc e hd in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1527,12 +1527,12 @@ let (tcc_no_lift : (FStar_List_Tot_Base.map FStar_Pervasives_Native.fst args))) uu___7))) uu___5)) - | uu___2 -> Obj.magic (FStar_Tactics_V1_Builtins.tcc e t)) + | uu___2 -> Obj.magic (FStarC_Tactics_V1_Builtins.tcc e t)) uu___1) let (compute_eterm_info : Prims.bool -> - FStar_Reflection_Types.env -> - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.term -> (eterm_info, unit) FStar_Tactics_Effect.tac_repr) = fun dbg -> @@ -1613,7 +1613,7 @@ let (compute_eterm_info : (Obj.repr (let uu___5 = let uu___6 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1683,13 +1683,13 @@ let (compute_eterm_info : (fun uu___2 -> (fun uu___2 -> match uu___2 with - | FStar_Tactics_Common.TacticFailure + | FStarC_Tactics_Common.TacticFailure (msg, uu___3) -> Obj.magic (Obj.repr (FStar_InteractiveHelpers_Base.mfail_doc (FStar_List_Tot_Base.op_At - [FStar_Pprint.arbitrary_string + [FStarC_Pprint.arbitrary_string "compute_eterm_info: failure"] msg))) | e1 -> @@ -1704,18 +1704,18 @@ let (has_refinement : ty.FStar_InteractiveHelpers_ExploreTerm.refin let (get_refinement : FStar_InteractiveHelpers_ExploreTerm.type_info -> - FStar_Reflection_Types.term) + FStarC_Reflection_Types.term) = fun ty -> FStar_Pervasives_Native.__proj__Some__item__v ty.FStar_InteractiveHelpers_ExploreTerm.refin let (get_opt_refinment : FStar_InteractiveHelpers_ExploreTerm.type_info -> - FStar_Reflection_Types.term FStar_Pervasives_Native.option) + FStarC_Reflection_Types.term FStar_Pervasives_Native.option) = fun ty -> ty.FStar_InteractiveHelpers_ExploreTerm.refin let (get_rawest_type : FStar_InteractiveHelpers_ExploreTerm.type_info -> - FStar_Reflection_Types.typ) + FStarC_Reflection_Types.typ) = fun ty -> ty.FStar_InteractiveHelpers_ExploreTerm.ty type type_comparison = | Refines @@ -2046,9 +2046,9 @@ let (compare_cast_types : (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> Unknown)))) uu___1) let (mk_has_type : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.typ -> - (FStar_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.typ -> + (FStarC_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) = fun uu___1 -> fun uu___ -> @@ -2058,13 +2058,13 @@ let (mk_has_type : (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> FStar_Reflection_V1_Derived.mk_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "has_type"]))) - [(ty, FStar_Reflection_V1_Data.Q_Implicit); - (t, FStar_Reflection_V1_Data.Q_Explicit); - (ty, FStar_Reflection_V1_Data.Q_Explicit)]))) uu___1 + [(ty, FStarC_Reflection_V1_Data.Q_Implicit); + (t, FStarC_Reflection_V1_Data.Q_Explicit); + (ty, FStarC_Reflection_V1_Data.Q_Explicit)]))) uu___1 uu___ let (cast_info_to_propositions : Prims.bool -> @@ -2349,8 +2349,8 @@ let (cast_info_to_propositions : e_rty -> let uu___8 = - FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_AscribedT + FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_AscribedT ((ci.term), p_rty, FStar_Pervasives_Native.None, @@ -2389,11 +2389,11 @@ let (cast_info_to_propositions : -> [ (p_rty, - FStar_Reflection_V1_Data.Q_Implicit); + FStarC_Reflection_V1_Data.Q_Implicit); (ascr_term, - FStar_Reflection_V1_Data.Q_Explicit); + FStarC_Reflection_V1_Data.Q_Explicit); (e_rty, - FStar_Reflection_V1_Data.Q_Explicit)])) in + FStarC_Reflection_V1_Data.Q_Explicit)])) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -2428,9 +2428,9 @@ let (cast_info_to_propositions : uu___11 -> FStar_Reflection_V1_Derived.mk_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "has_type"]))) has_type_params)) in @@ -2539,7 +2539,7 @@ let (cast_info_list_to_propositions : type pre_post_type = | PP_Unknown | PP_Pure - | PP_State of FStar_Reflection_Types.term + | PP_State of FStarC_Reflection_Types.term let (uu___is_PP_Unknown : pre_post_type -> Prims.bool) = fun projectee -> match projectee with | PP_Unknown -> true | uu___ -> false let (uu___is_PP_Pure : pre_post_type -> Prims.bool) = @@ -2548,12 +2548,12 @@ let (uu___is_PP_State : pre_post_type -> Prims.bool) = fun projectee -> match projectee with | PP_State state_type -> true | uu___ -> false let (__proj__PP_State__item__state_type : - pre_post_type -> FStar_Reflection_Types.term) = + pre_post_type -> FStarC_Reflection_Types.term) = fun projectee -> match projectee with | PP_State state_type -> state_type let (compute_pre_type : Prims.bool -> - FStar_Reflection_Types.env -> - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.term -> (pre_post_type, unit) FStar_Tactics_Effect.tac_repr) = fun dbg -> @@ -2757,7 +2757,7 @@ let (compute_pre_type : = let uu___12 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string (FStar_Reflection_V1_Derived.type_of_binder b) in FStar_Tactics_Effect.tac_bind @@ -2889,11 +2889,11 @@ let (compute_pre_type : uu___7))) uu___5))) uu___3))) uu___1) let (opt_remove_refin : - FStar_Reflection_Types.typ -> - (FStar_Reflection_Types.typ, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.typ -> + (FStarC_Reflection_Types.typ, unit) FStar_Tactics_Effect.tac_repr) = fun ty -> - let uu___ = FStar_Tactics_V1_Builtins.inspect ty in + let uu___ = FStarC_Tactics_V1_Builtins.inspect ty in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2909,14 +2909,14 @@ let (opt_remove_refin : FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> match uu___1 with - | FStar_Reflection_V1_Data.Tv_Refine (uu___3, sort, uu___4) -> + | FStarC_Reflection_V1_Data.Tv_Refine (uu___3, sort, uu___4) -> sort | uu___3 -> ty)) let (compute_post_type : Prims.bool -> - FStar_Reflection_Types.env -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> (pre_post_type, unit) FStar_Tactics_Effect.tac_repr) = fun dbg -> @@ -2956,7 +2956,7 @@ let (compute_post_type : Obj.magic (Obj.repr (let uu___4 = - FStar_Tactics_V1_Builtins.inspect + FStarC_Tactics_V1_Builtins.inspect ret_ty in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -3367,7 +3367,7 @@ let (compute_post_type : = let uu___19 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string ret_type in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -3398,7 +3398,7 @@ let (compute_post_type : = let uu___22 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string r_ty in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -3553,7 +3553,7 @@ let (compute_post_type : = let uu___21 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string s1_ty in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -3584,7 +3584,7 @@ let (compute_post_type : = let uu___24 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string s2_ty in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -3810,7 +3810,7 @@ let (compute_post_type : = let uu___26 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string (FStar_Reflection_V1_Derived.type_of_binder s1) in FStar_Tactics_Effect.tac_bind @@ -3987,10 +3987,10 @@ let (compute_post_type : uu___3))) uu___1) let (check_pre_post_type : Prims.bool -> - FStar_Reflection_Types.env -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> (pre_post_type, unit) FStar_Tactics_Effect.tac_repr) = fun dbg -> @@ -4162,10 +4162,10 @@ let (check_pre_post_type : uu___3))) uu___1) let (check_opt_pre_post_type : Prims.bool -> - FStar_Reflection_Types.env -> - FStar_Reflection_Types.term FStar_Pervasives_Native.option -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term FStar_Pervasives_Native.option -> + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.term FStar_Pervasives_Native.option -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term FStar_Pervasives_Native.option -> (pre_post_type FStar_Pervasives_Native.option, unit) FStar_Tactics_Effect.tac_repr) = @@ -4371,15 +4371,15 @@ let (check_opt_pre_post_type : uu___1) let rec (_introduce_variables_for_abs : FStar_InteractiveHelpers_Base.genv -> - FStar_Reflection_Types.typ -> - ((FStar_Reflection_Types.term Prims.list * - FStar_Reflection_Types.binder Prims.list * + FStarC_Reflection_Types.typ -> + ((FStarC_Reflection_Types.term Prims.list * + FStarC_Reflection_Types.binder Prims.list * FStar_InteractiveHelpers_Base.genv), unit) FStar_Tactics_Effect.tac_repr) = fun ge -> fun ty -> - let uu___ = FStar_Tactics_V1_Builtins.inspect ty in + let uu___ = FStarC_Tactics_V1_Builtins.inspect ty in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -4394,7 +4394,7 @@ let rec (_introduce_variables_for_abs : (fun uu___1 -> (fun uu___1 -> match uu___1 with - | FStar_Reflection_V1_Data.Tv_Arrow (b, c) -> + | FStarC_Reflection_V1_Data.Tv_Arrow (b, c) -> Obj.magic (Obj.repr (let uu___2 = @@ -4488,8 +4488,8 @@ let rec (_introduce_variables_for_abs : (fun uu___5 -> (fun bv1 -> let uu___5 = - FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Var + FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Var bv1) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -4575,9 +4575,9 @@ let rec (_introduce_variables_for_abs : (fun uu___3 -> ([], [], ge))))) uu___1) let (introduce_variables_for_abs : FStar_InteractiveHelpers_Base.genv -> - FStar_Reflection_Types.term -> - ((FStar_Reflection_Types.term Prims.list * - FStar_Reflection_Types.binder Prims.list * + FStarC_Reflection_Types.term -> + ((FStarC_Reflection_Types.term Prims.list * + FStarC_Reflection_Types.binder Prims.list * FStar_InteractiveHelpers_Base.genv), unit) FStar_Tactics_Effect.tac_repr) = @@ -4609,9 +4609,9 @@ let (introduce_variables_for_abs : (fun uu___2 -> ([], [], ge))))) uu___1) let (introduce_variables_for_opt_abs : FStar_InteractiveHelpers_Base.genv -> - FStar_Reflection_Types.term FStar_Pervasives_Native.option -> - ((FStar_Reflection_Types.term Prims.list * - FStar_Reflection_Types.binder Prims.list * + FStarC_Reflection_Types.term FStar_Pervasives_Native.option -> + ((FStarC_Reflection_Types.term Prims.list * + FStarC_Reflection_Types.binder Prims.list * FStar_InteractiveHelpers_Base.genv), unit) FStar_Tactics_Effect.tac_repr) = @@ -4641,14 +4641,14 @@ let (effect_type_is_stateful : | FStar_InteractiveHelpers_ExploreTerm.E_Unknown -> true let (is_st_get : Prims.bool -> - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.term -> (Prims.bool, unit) FStar_Tactics_Effect.tac_repr) = fun dbg -> fun t -> let uu___ = let uu___1 = - let uu___2 = FStar_Tactics_V1_Builtins.term_to_string t in + let uu___2 = FStarC_Tactics_V1_Builtins.term_to_string t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -4696,7 +4696,7 @@ let (is_st_get : (Prims.of_int (9))))) (Obj.magic uu___) (fun uu___1 -> (fun uu___1 -> - let uu___2 = FStar_Tactics_V1_Builtins.inspect t in + let uu___2 = FStarC_Tactics_V1_Builtins.inspect t in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -4715,7 +4715,8 @@ let (is_st_get : (fun uu___3 -> (fun uu___3 -> match uu___3 with - | FStar_Reflection_V1_Data.Tv_App (hd, (a, qual)) -> + | FStarC_Reflection_V1_Data.Tv_App (hd, (a, qual)) + -> let uu___4 = FStar_InteractiveHelpers_Base.print_dbg dbg "-> Is Tv_App" in @@ -4741,7 +4742,7 @@ let (is_st_get : (fun uu___5 -> (fun uu___5 -> let uu___6 = - FStar_Tactics_V1_Builtins.inspect + FStarC_Tactics_V1_Builtins.inspect hd in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -4765,7 +4766,7 @@ let (is_st_get : (fun uu___7 -> (fun uu___7 -> match uu___7 with - | FStar_Reflection_V1_Data.Tv_FVar + | FStarC_Reflection_V1_Data.Tv_FVar fv -> let uu___8 = FStar_InteractiveHelpers_Base.print_dbg @@ -4861,8 +4862,8 @@ let (is_st_get : uu___1) let (is_let_st_get : Prims.bool -> - FStar_Reflection_V1_Data.term_view -> - ((FStar_Reflection_Types.bv * FStar_Reflection_Types.typ) + FStarC_Reflection_V1_Data.term_view -> + ((FStarC_Reflection_Types.bv * FStarC_Reflection_Types.typ) FStar_Pervasives_Native.option, unit) FStar_Tactics_Effect.tac_repr) = @@ -4871,7 +4872,7 @@ let (is_let_st_get : let uu___ = let uu___1 = let uu___2 = - let uu___3 = FStar_Tactics_V1_Builtins.pack t in + let uu___3 = FStarC_Tactics_V1_Builtins.pack t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -4889,7 +4890,7 @@ let (is_let_st_get : (fun uu___4 -> (fun uu___4 -> Obj.magic - (FStar_Tactics_V1_Builtins.term_to_string uu___4)) + (FStarC_Tactics_V1_Builtins.term_to_string uu___4)) uu___4) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -4939,7 +4940,7 @@ let (is_let_st_get : (fun uu___1 -> (fun uu___1 -> match t with - | FStar_Reflection_V1_Data.Tv_Let + | FStarC_Reflection_V1_Data.Tv_Let (recf, attrs, bv, ty, def, body) -> let uu___2 = FStar_InteractiveHelpers_Base.print_dbg dbg @@ -5015,8 +5016,8 @@ let (is_let_st_get : uu___1) let (term_has_effectful_comp : Prims.bool -> - FStar_Reflection_Types.env -> - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.term -> (Prims.bool FStar_Pervasives_Native.option, unit) FStar_Tactics_Effect.tac_repr) = @@ -5124,7 +5125,7 @@ let (term_has_effectful_comp : let (related_term_is_effectul : Prims.bool -> FStar_InteractiveHelpers_Base.genv -> - FStar_Reflection_V1_Data.term_view -> + FStarC_Reflection_V1_Data.term_view -> (Prims.bool, unit) FStar_Tactics_Effect.tac_repr) = fun dbg -> @@ -5173,69 +5174,69 @@ let (related_term_is_effectul : (fun uu___1 -> (fun is_effectful -> match tv with - | FStar_Reflection_V1_Data.Tv_Var uu___1 -> + | FStarC_Reflection_V1_Data.Tv_Var uu___1 -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> false))) - | FStar_Reflection_V1_Data.Tv_BVar uu___1 -> + | FStarC_Reflection_V1_Data.Tv_BVar uu___1 -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> false))) - | FStar_Reflection_V1_Data.Tv_FVar uu___1 -> + | FStarC_Reflection_V1_Data.Tv_FVar uu___1 -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> false))) - | FStar_Reflection_V1_Data.Tv_App (hd, (a, qual)) -> + | FStarC_Reflection_V1_Data.Tv_App (hd, (a, qual)) -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___1 -> false))) - | FStar_Reflection_V1_Data.Tv_Abs (br, body) -> + | FStarC_Reflection_V1_Data.Tv_Abs (br, body) -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___1 -> false))) - | FStar_Reflection_V1_Data.Tv_Arrow (br, c0) -> + | FStarC_Reflection_V1_Data.Tv_Arrow (br, c0) -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___1 -> false))) - | FStar_Reflection_V1_Data.Tv_Type uu___1 -> + | FStarC_Reflection_V1_Data.Tv_Type uu___1 -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> false))) - | FStar_Reflection_V1_Data.Tv_Refine (bv, sort, ref) -> + | FStarC_Reflection_V1_Data.Tv_Refine (bv, sort, ref) -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___1 -> false))) - | FStar_Reflection_V1_Data.Tv_Const uu___1 -> + | FStarC_Reflection_V1_Data.Tv_Const uu___1 -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> false))) - | FStar_Reflection_V1_Data.Tv_Uvar (uu___1, uu___2) -> + | FStarC_Reflection_V1_Data.Tv_Uvar (uu___1, uu___2) -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> false))) - | FStar_Reflection_V1_Data.Tv_Let + | FStarC_Reflection_V1_Data.Tv_Let (recf, attrs, bv, ty, def, body) -> Obj.magic (Obj.repr (is_effectful def)) - | FStar_Reflection_V1_Data.Tv_Match + | FStarC_Reflection_V1_Data.Tv_Match (scrutinee, _ret_opt, branches) -> Obj.magic (Obj.repr (is_effectful scrutinee)) - | FStar_Reflection_V1_Data.Tv_AscribedT (e, ty, tac, uu___1) + | FStarC_Reflection_V1_Data.Tv_AscribedT (e, ty, tac, uu___1) -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> false))) - | FStar_Reflection_V1_Data.Tv_AscribedC (e, c, tac, uu___1) + | FStarC_Reflection_V1_Data.Tv_AscribedC (e, c, tac, uu___1) -> Obj.magic (Obj.repr @@ -5249,8 +5250,8 @@ let (related_term_is_effectul : let rec (find_mem_in_related : Prims.bool -> FStar_InteractiveHelpers_Base.genv -> - FStar_Reflection_V1_Data.term_view Prims.list -> - ((FStar_Reflection_Types.bv * FStar_Reflection_Types.typ) + FStarC_Reflection_V1_Data.term_view Prims.list -> + ((FStarC_Reflection_Types.bv * FStarC_Reflection_Types.typ) FStar_Pervasives_Native.option, unit) FStar_Tactics_Effect.tac_repr) = @@ -5272,7 +5273,8 @@ let rec (find_mem_in_related : (let uu___ = let uu___1 = let uu___2 = - let uu___3 = FStar_Tactics_V1_Builtins.pack tv in + let uu___3 = + FStarC_Tactics_V1_Builtins.pack tv in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -5294,7 +5296,7 @@ let rec (find_mem_in_related : (fun uu___4 -> (fun uu___4 -> Obj.magic - (FStar_Tactics_V1_Builtins.term_to_string + (FStarC_Tactics_V1_Builtins.term_to_string uu___4)) uu___4) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -5539,15 +5541,15 @@ let rec (find_mem_in_related : let rec (find_mem_in_children : Prims.bool -> FStar_InteractiveHelpers_Base.genv -> - FStar_Reflection_Types.term -> - ((FStar_InteractiveHelpers_Base.genv * FStar_Reflection_Types.bv + FStarC_Reflection_Types.term -> + ((FStar_InteractiveHelpers_Base.genv * FStarC_Reflection_Types.bv FStar_Pervasives_Native.option), unit) FStar_Tactics_Effect.tac_repr) = fun dbg -> fun ge -> fun child -> - let uu___ = FStar_Tactics_V1_Builtins.inspect child in + let uu___ = FStarC_Tactics_V1_Builtins.inspect child in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -5565,7 +5567,7 @@ let rec (find_mem_in_children : (fun uu___1 -> (fun uu___1 -> match uu___1 with - | FStar_Reflection_V1_Data.Tv_Let + | FStarC_Reflection_V1_Data.Tv_Let (recf, attrs, bv, ty, def, body) -> Obj.magic (Obj.repr @@ -5699,13 +5701,14 @@ let (pre_post_to_propositions : Prims.bool -> FStar_InteractiveHelpers_Base.genv -> FStar_InteractiveHelpers_ExploreTerm.effect_type -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.binder FStar_Pervasives_Native.option -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.binder FStar_Pervasives_Native.option -> FStar_InteractiveHelpers_ExploreTerm.type_info -> - FStar_Reflection_Types.term FStar_Pervasives_Native.option -> - FStar_Reflection_Types.term FStar_Pervasives_Native.option -> - FStar_Reflection_V1_Data.term_view Prims.list -> - FStar_Reflection_V1_Data.term_view Prims.list -> + FStarC_Reflection_Types.term FStar_Pervasives_Native.option -> + FStarC_Reflection_Types.term FStar_Pervasives_Native.option + -> + FStarC_Reflection_V1_Data.term_view Prims.list -> + FStarC_Reflection_V1_Data.term_view Prims.list -> ((FStar_InteractiveHelpers_Base.genv * FStar_InteractiveHelpers_Propositions.proposition FStar_Pervasives_Native.option * @@ -5746,7 +5749,7 @@ let (pre_post_to_propositions : let uu___3 = let uu___4 = FStar_InteractiveHelpers_Base.option_to_string - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string opt_pre in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -5818,7 +5821,7 @@ let (pre_post_to_propositions : let uu___5 = let uu___6 = FStar_InteractiveHelpers_Base.option_to_string - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string opt_post in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -5958,9 +5961,9 @@ let (pre_post_to_propositions : (ge0, ([], []), ([ - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const - FStar_Reflection_V2_Data.C_Unit)], + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const + FStarC_Reflection_V2_Data.C_Unit)], [])))) | FStar_InteractiveHelpers_ExploreTerm.E_Total -> @@ -6278,8 +6281,8 @@ let (pre_post_to_propositions : -> let uu___18 = - FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Var + FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Var bv) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -6317,9 +6320,9 @@ let (pre_post_to_propositions : FStar_InteractiveHelpers_Base.genv_push_fresh_var ge basename - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Monotonic"; "HyperStack"; @@ -6617,8 +6620,8 @@ let (pre_post_to_propositions : -> let uu___18 = - FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Var + FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Var bv) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -6656,9 +6659,9 @@ let (pre_post_to_propositions : FStar_InteractiveHelpers_Base.genv_push_fresh_var ge basename - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Monotonic"; "HyperStack"; @@ -7288,16 +7291,16 @@ let (eterm_info_to_assertions : Prims.bool -> Prims.bool -> FStar_InteractiveHelpers_Base.genv -> - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.term -> Prims.bool -> Prims.bool -> eterm_info -> - FStar_Reflection_Types.term FStar_Pervasives_Native.option + FStarC_Reflection_Types.term FStar_Pervasives_Native.option -> FStar_InteractiveHelpers_ExploreTerm.typ_or_comp FStar_Pervasives_Native.option -> - FStar_Reflection_V1_Data.term_view Prims.list -> - FStar_Reflection_V1_Data.term_view Prims.list -> + FStarC_Reflection_V1_Data.term_view Prims.list -> + FStarC_Reflection_V1_Data.term_view Prims.list -> ((FStar_InteractiveHelpers_Base.genv * FStar_InteractiveHelpers_Propositions.assertions), unit) FStar_Tactics_Effect.tac_repr) @@ -7411,9 +7414,9 @@ let (eterm_info_to_assertions : (fun uu___6 -> (ge, - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const - FStar_Reflection_V2_Data.C_Unit)), + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const + FStarC_Reflection_V2_Data.C_Unit)), FStar_Pervasives_Native.None)))) else Obj.magic @@ -7480,8 +7483,8 @@ let (eterm_info_to_assertions : -> let uu___9 = - FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Var + FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Var bv) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -7688,7 +7691,7 @@ let (eterm_info_to_assertions : let uu___12 = FStar_InteractiveHelpers_Base.option_to_string - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string pre_prop in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -7782,7 +7785,7 @@ let (eterm_info_to_assertions : let uu___14 = FStar_InteractiveHelpers_Base.option_to_string - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string post_prop in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -8093,7 +8096,7 @@ let (eterm_info_to_assertions : let uu___22 = FStar_InteractiveHelpers_Base.option_to_string - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string ei.ei_pre in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -8187,7 +8190,7 @@ let (eterm_info_to_assertions : let uu___24 = FStar_InteractiveHelpers_Base.option_to_string - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string ei.ei_post in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -8864,8 +8867,8 @@ let (eterm_info_to_assertions : tinfo -> let uu___41 = - FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Var + FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Var bv) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -9793,7 +9796,7 @@ let (eterm_info_to_assertions : let uu___43 = FStar_InteractiveHelpers_Base.list_to_string - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string gcast_props in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -10059,7 +10062,7 @@ let (eterm_info_to_assertions : let uu___35 = FStar_InteractiveHelpers_Base.option_to_string - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string gpre_prop in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -10153,7 +10156,7 @@ let (eterm_info_to_assertions : let uu___37 = FStar_InteractiveHelpers_Base.option_to_string - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string gpost_prop in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -10693,7 +10696,7 @@ let (eterm_info_to_assertions : (fun x -> let uu___29 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string x in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -10721,7 +10724,7 @@ let (eterm_info_to_assertions : uu___30 -> Obj.magic - (FStar_Tactics_V1_Builtins.print + (FStarC_Tactics_V1_Builtins.print uu___30)) uu___30)) pres1)) @@ -10799,7 +10802,7 @@ let (eterm_info_to_assertions : (fun x -> let uu___33 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string x in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -10827,7 +10830,7 @@ let (eterm_info_to_assertions : uu___34 -> Obj.magic - (FStar_Tactics_V1_Builtins.print + (FStarC_Tactics_V1_Builtins.print uu___34)) uu___34)) posts)) diff --git a/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_ExploreTerm.ml b/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_ExploreTerm.ml index 249109268e0..db662d497d9 100644 --- a/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_ExploreTerm.ml +++ b/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_ExploreTerm.ml @@ -4,7 +4,7 @@ let (pure_hoare_effect_qn : Prims.string) = "Prims.Pure" let (stack_effect_qn : Prims.string) = "FStar.HyperStack.ST.Stack" let (st_effect_qn : Prims.string) = "FStar.HyperStack.ST.ST" let (comp_qualifier : - FStar_Reflection_Types.comp -> + FStarC_Reflection_Types.comp -> (Prims.string, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> @@ -12,12 +12,12 @@ let (comp_qualifier : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> - match FStar_Reflection_V1_Builtins.inspect_comp c with - | FStar_Reflection_V1_Data.C_Total uu___1 -> "C_Total" - | FStar_Reflection_V1_Data.C_GTotal uu___1 -> "C_GTotal" - | FStar_Reflection_V1_Data.C_Lemma (uu___1, uu___2, uu___3) -> - "C_Lemma" - | FStar_Reflection_V1_Data.C_Eff + match FStarC_Reflection_V1_Builtins.inspect_comp c with + | FStarC_Reflection_V1_Data.C_Total uu___1 -> "C_Total" + | FStarC_Reflection_V1_Data.C_GTotal uu___1 -> "C_GTotal" + | FStarC_Reflection_V1_Data.C_Lemma (uu___1, uu___2, uu___3) + -> "C_Lemma" + | FStarC_Reflection_V1_Data.C_Eff (uu___1, uu___2, uu___3, uu___4, uu___5) -> "C_Eff"))) uu___ type effect_type = @@ -56,7 +56,7 @@ let (effect_type_to_string : effect_type -> Prims.string) = | E_Stack -> "E_Stack" | E_ST -> "E_ST" | E_Unknown -> "E_Unknown" -let (effect_name_to_type : FStar_Reflection_Types.name -> effect_type) = +let (effect_name_to_type : FStarC_Reflection_Types.name -> effect_type) = fun ename -> let ename1 = FStar_Reflection_V1_Derived.flatten_name ename in if ename1 = pure_effect_qn @@ -81,22 +81,23 @@ let (effect_type_is_pure : effect_type -> Prims.bool) = | E_Unknown -> false type type_info = { - ty: FStar_Reflection_Types.typ ; - refin: FStar_Reflection_Types.term FStar_Pervasives_Native.option } -let (__proj__Mktype_info__item__ty : type_info -> FStar_Reflection_Types.typ) - = fun projectee -> match projectee with | { ty; refin;_} -> ty + ty: FStarC_Reflection_Types.typ ; + refin: FStarC_Reflection_Types.term FStar_Pervasives_Native.option } +let (__proj__Mktype_info__item__ty : + type_info -> FStarC_Reflection_Types.typ) = + fun projectee -> match projectee with | { ty; refin;_} -> ty let (__proj__Mktype_info__item__refin : - type_info -> FStar_Reflection_Types.term FStar_Pervasives_Native.option) = + type_info -> FStarC_Reflection_Types.term FStar_Pervasives_Native.option) = fun projectee -> match projectee with | { ty; refin;_} -> refin let (mk_type_info : - FStar_Reflection_Types.typ -> - FStar_Reflection_Types.term FStar_Pervasives_Native.option -> type_info) + FStarC_Reflection_Types.typ -> + FStarC_Reflection_Types.term FStar_Pervasives_Native.option -> type_info) = fun uu___ -> fun uu___1 -> { ty = uu___; refin = uu___1 } let (type_info_to_string : type_info -> (Prims.string, unit) FStar_Tactics_Effect.tac_repr) = fun info -> let uu___ = - let uu___1 = FStar_Tactics_V1_Builtins.term_to_string info.ty in + let uu___1 = FStarC_Tactics_V1_Builtins.term_to_string info.ty in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -116,7 +117,7 @@ let (type_info_to_string : let uu___4 = let uu___5 = FStar_InteractiveHelpers_Base.option_to_string - FStar_Tactics_V1_Builtins.term_to_string info.refin in + FStarC_Tactics_V1_Builtins.term_to_string info.refin in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -182,14 +183,14 @@ let (type_info_to_string : (fun uu___2 -> Prims.strcat "Mktype_info (" uu___1)) let (unit_type_info : type_info) = mk_type_info - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv ["Prims"; "unit"]))) + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "unit"]))) FStar_Pervasives_Native.None let (safe_tc : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.term FStar_Pervasives_Native.option, unit) + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.term FStar_Pervasives_Native.option, unit) FStar_Tactics_Effect.tac_repr) = fun e -> @@ -198,7 +199,7 @@ let (safe_tc : (fun uu___ -> match () with | () -> - let uu___1 = FStar_Tactics_V1_Builtins.tc e t in + let uu___1 = FStarC_Tactics_V1_Builtins.tc e t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -222,9 +223,9 @@ let (safe_tc : (FStar_Tactics_Effect.lift_div_tac (fun uu___1 -> FStar_Pervasives_Native.None))) uu___) let (safe_tcc : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.comp FStar_Pervasives_Native.option, unit) + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.comp FStar_Pervasives_Native.option, unit) FStar_Tactics_Effect.tac_repr) = fun e -> @@ -233,7 +234,7 @@ let (safe_tcc : (fun uu___ -> match () with | () -> - let uu___1 = FStar_Tactics_V1_Builtins.tcc e t in + let uu___1 = FStarC_Tactics_V1_Builtins.tcc e t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -257,11 +258,11 @@ let (safe_tcc : (FStar_Tactics_Effect.lift_div_tac (fun uu___1 -> FStar_Pervasives_Native.None))) uu___) let (get_type_info_from_type : - FStar_Reflection_Types.typ -> + FStarC_Reflection_Types.typ -> (type_info, unit) FStar_Tactics_Effect.tac_repr) = fun ty -> - let uu___ = FStar_Tactics_V1_Builtins.inspect ty in + let uu___ = FStarC_Tactics_V1_Builtins.inspect ty in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -276,7 +277,7 @@ let (get_type_info_from_type : (fun uu___1 -> (fun uu___1 -> match uu___1 with - | FStar_Reflection_V1_Data.Tv_Refine (bv, sort, refin) -> + | FStarC_Reflection_V1_Data.Tv_Refine (bv, sort, refin) -> let uu___2 = FStar_InteractiveHelpers_Base.prettify_term false sort in Obj.magic @@ -348,8 +349,8 @@ let (get_type_info_from_type : (fun uu___5 -> (fun refin1 -> let uu___5 = - FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Abs + FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Abs (b, refin1)) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -402,8 +403,8 @@ let (get_type_info_from_type : mk_type_info ty1 FStar_Pervasives_Native.None)))) uu___1) let (get_type_info : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.term -> (type_info FStar_Pervasives_Native.option, unit) FStar_Tactics_Effect.tac_repr) = @@ -455,37 +456,37 @@ let (get_type_info : FStar_Pervasives_Native.Some uu___3))))) uu___1) let (get_total_or_gtotal_ret_type : - FStar_Reflection_Types.comp -> - FStar_Reflection_Types.typ FStar_Pervasives_Native.option) + FStarC_Reflection_Types.comp -> + FStarC_Reflection_Types.typ FStar_Pervasives_Native.option) = fun c -> - match FStar_Reflection_V1_Builtins.inspect_comp c with - | FStar_Reflection_V1_Data.C_Total ret_ty -> + match FStarC_Reflection_V1_Builtins.inspect_comp c with + | FStarC_Reflection_V1_Data.C_Total ret_ty -> FStar_Pervasives_Native.Some ret_ty - | FStar_Reflection_V1_Data.C_GTotal ret_ty -> + | FStarC_Reflection_V1_Data.C_GTotal ret_ty -> FStar_Pervasives_Native.Some ret_ty | uu___ -> FStar_Pervasives_Native.None let (get_comp_ret_type : - FStar_Reflection_Types.comp -> FStar_Reflection_Types.typ) = + FStarC_Reflection_Types.comp -> FStarC_Reflection_Types.typ) = fun c -> - match FStar_Reflection_V1_Builtins.inspect_comp c with - | FStar_Reflection_V1_Data.C_Total ret_ty -> ret_ty - | FStar_Reflection_V1_Data.C_GTotal ret_ty -> ret_ty - | FStar_Reflection_V1_Data.C_Eff (uu___, uu___1, ret_ty, uu___2, uu___3) + match FStarC_Reflection_V1_Builtins.inspect_comp c with + | FStarC_Reflection_V1_Data.C_Total ret_ty -> ret_ty + | FStarC_Reflection_V1_Data.C_GTotal ret_ty -> ret_ty + | FStarC_Reflection_V1_Data.C_Eff (uu___, uu___1, ret_ty, uu___2, uu___3) -> ret_ty - | FStar_Reflection_V1_Data.C_Lemma (uu___, uu___1, uu___2) -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv ["Prims"; "unit"])) -let (is_total_or_gtotal : FStar_Reflection_Types.comp -> Prims.bool) = + | FStarC_Reflection_V1_Data.C_Lemma (uu___, uu___1, uu___2) -> + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "unit"])) +let (is_total_or_gtotal : FStarC_Reflection_Types.comp -> Prims.bool) = fun c -> FStar_Pervasives_Native.uu___is_Some (get_total_or_gtotal_ret_type c) let (is_unit_type : - FStar_Reflection_Types.typ -> + FStarC_Reflection_Types.typ -> (Prims.bool, unit) FStar_Tactics_Effect.tac_repr) = fun ty -> - let uu___ = FStar_Tactics_V1_Builtins.inspect ty in + let uu___ = FStarC_Tactics_V1_Builtins.inspect ty in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -501,24 +502,24 @@ let (is_unit_type : FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> match uu___1 with - | FStar_Reflection_V1_Data.Tv_FVar fv -> + | FStarC_Reflection_V1_Data.Tv_FVar fv -> FStar_InteractiveHelpers_Base.fv_eq_name fv FStar_Reflection_Const.unit_lid | uu___3 -> false)) type typ_or_comp = - | TC_Typ of FStar_Reflection_Types.typ * FStar_Reflection_Types.binder + | TC_Typ of FStarC_Reflection_Types.typ * FStarC_Reflection_Types.binder Prims.list * Prims.nat - | TC_Comp of FStar_Reflection_Types.comp * FStar_Reflection_Types.binder + | TC_Comp of FStarC_Reflection_Types.comp * FStarC_Reflection_Types.binder Prims.list * Prims.nat let (uu___is_TC_Typ : typ_or_comp -> Prims.bool) = fun projectee -> match projectee with | TC_Typ (v, pl, num_unflushed) -> true | uu___ -> false -let (__proj__TC_Typ__item__v : typ_or_comp -> FStar_Reflection_Types.typ) = +let (__proj__TC_Typ__item__v : typ_or_comp -> FStarC_Reflection_Types.typ) = fun projectee -> match projectee with | TC_Typ (v, pl, num_unflushed) -> v let (__proj__TC_Typ__item__pl : - typ_or_comp -> FStar_Reflection_Types.binder Prims.list) = + typ_or_comp -> FStarC_Reflection_Types.binder Prims.list) = fun projectee -> match projectee with | TC_Typ (v, pl, num_unflushed) -> pl let (__proj__TC_Typ__item__num_unflushed : typ_or_comp -> Prims.nat) = fun projectee -> @@ -528,10 +529,11 @@ let (uu___is_TC_Comp : typ_or_comp -> Prims.bool) = match projectee with | TC_Comp (v, pl, num_unflushed) -> true | uu___ -> false -let (__proj__TC_Comp__item__v : typ_or_comp -> FStar_Reflection_Types.comp) = +let (__proj__TC_Comp__item__v : typ_or_comp -> FStarC_Reflection_Types.comp) + = fun projectee -> match projectee with | TC_Comp (v, pl, num_unflushed) -> v let (__proj__TC_Comp__item__pl : - typ_or_comp -> FStar_Reflection_Types.binder Prims.list) = + typ_or_comp -> FStarC_Reflection_Types.binder Prims.list) = fun projectee -> match projectee with | TC_Comp (v, pl, num_unflushed) -> pl let (__proj__TC_Comp__item__num_unflushed : typ_or_comp -> Prims.nat) = @@ -543,7 +545,7 @@ let (typ_or_comp_to_string : match tyc with | TC_Typ (v, pl, num_unflushed) -> let uu___ = - let uu___1 = FStar_Tactics_V1_Builtins.term_to_string v in + let uu___1 = FStarC_Tactics_V1_Builtins.term_to_string v in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -728,7 +730,7 @@ let (typ_or_comp_to_string : FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> Prims.strcat "TC_Comp (" uu___1)) let (params_of_typ_or_comp : - typ_or_comp -> FStar_Reflection_Types.binder Prims.list) = + typ_or_comp -> FStarC_Reflection_Types.binder Prims.list) = fun c -> match c with | TC_Typ (uu___, pl, uu___1) -> pl @@ -740,8 +742,8 @@ let (num_unflushed_of_typ_or_comp : typ_or_comp -> Prims.nat) = | TC_Comp (uu___, uu___1, n) -> n let (safe_typ_or_comp : Prims.bool -> - FStar_Reflection_Types.env -> - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.term -> (typ_or_comp FStar_Pervasives_Native.option, unit) FStar_Tactics_Effect.tac_repr) = @@ -772,7 +774,7 @@ let (safe_typ_or_comp : let uu___4 = let uu___5 = let uu___6 = - FStar_Tactics_V1_Builtins.term_to_string t in + FStarC_Tactics_V1_Builtins.term_to_string t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -871,7 +873,7 @@ let (safe_typ_or_comp : let uu___4 = let uu___5 = let uu___6 = - FStar_Tactics_V1_Builtins.term_to_string t in + FStarC_Tactics_V1_Builtins.term_to_string t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1018,12 +1020,13 @@ let (safe_typ_or_comp : (TC_Comp (c, [], Prims.int_zero)))))) uu___1) let (subst_bv_in_comp : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.bv -> - FStar_Reflection_Types.typ -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.comp -> - (FStar_Reflection_Types.comp, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.bv -> + FStarC_Reflection_Types.typ -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.comp -> + (FStarC_Reflection_Types.comp, unit) + FStar_Tactics_Effect.tac_repr) = fun e -> fun b -> @@ -1033,11 +1036,11 @@ let (subst_bv_in_comp : FStar_InteractiveHelpers_Base.apply_subst_in_comp e c [((b, sort), t)] let (subst_binder_in_comp : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.binder -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.comp -> - (FStar_Reflection_Types.comp, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.binder -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.comp -> + (FStarC_Reflection_Types.comp, unit) FStar_Tactics_Effect.tac_repr) = fun e -> fun b -> @@ -1065,14 +1068,14 @@ let (subst_binder_in_comp : (FStar_Reflection_V1_Derived.bv_of_binder b) uu___1 t c)) uu___1) let rec (unfold_until_arrow : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.typ -> - (FStar_Reflection_Types.typ, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.typ -> + (FStarC_Reflection_Types.typ, unit) FStar_Tactics_Effect.tac_repr) = fun e -> fun ty0 -> let uu___ = - let uu___1 = FStar_Tactics_V1_Builtins.inspect ty0 in + let uu___1 = FStarC_Tactics_V1_Builtins.inspect ty0 in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1090,7 +1093,7 @@ let rec (unfold_until_arrow : (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> - FStar_Reflection_V1_Data.uu___is_Tv_Arrow uu___2)) in + FStarC_Reflection_V1_Data.uu___is_Tv_Arrow uu___2)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1115,7 +1118,7 @@ let rec (unfold_until_arrow : Obj.magic (Obj.repr (let uu___3 = - FStar_Tactics_V1_Builtins.norm_term_env e [] ty0 in + FStarC_Tactics_V1_Builtins.norm_term_env e [] ty0 in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1138,8 +1141,8 @@ let rec (unfold_until_arrow : (fun uu___5 -> fun fv -> let uu___6 = - FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_FVar + FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_FVar fv) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1166,7 +1169,7 @@ let rec (unfold_until_arrow : (FStar_Tactics_Effect.lift_div_tac (fun uu___8 -> FStar_Reflection_V1_Derived.flatten_name - (FStar_Reflection_V1_Builtins.inspect_fv + (FStarC_Reflection_V1_Builtins.inspect_fv fv))) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1190,7 +1193,7 @@ let rec (unfold_until_arrow : (fun uu___8 -> (fun fvn -> let uu___8 = - FStar_Tactics_V1_Builtins.norm_term_env + FStarC_Tactics_V1_Builtins.norm_term_env e [FStar_Pervasives.delta_only [fvn]] @@ -1221,7 +1224,7 @@ let rec (unfold_until_arrow : -> let uu___9 = - FStar_Tactics_V1_Builtins.inspect + FStarC_Tactics_V1_Builtins.inspect ty' in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1252,13 +1255,13 @@ let rec (unfold_until_arrow : match uu___10 with | - FStar_Reflection_V1_Data.Tv_FVar + FStarC_Reflection_V1_Data.Tv_FVar fv' -> Obj.magic (Obj.repr (if (FStar_Reflection_V1_Derived.flatten_name - (FStar_Reflection_V1_Builtins.inspect_fv + (FStarC_Reflection_V1_Builtins.inspect_fv fv')) = fvn then @@ -1267,7 +1270,7 @@ let rec (unfold_until_arrow : = let uu___12 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string ty0 in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1367,7 +1370,7 @@ let rec (unfold_until_arrow : (fun uu___5 -> (fun unfold_fv -> let uu___5 = - FStar_Tactics_V1_Builtins.inspect + FStarC_Tactics_V1_Builtins.inspect ty in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1391,14 +1394,14 @@ let rec (unfold_until_arrow : (fun uu___6 -> (fun uu___6 -> match uu___6 with - | FStar_Reflection_V1_Data.Tv_Arrow + | FStarC_Reflection_V1_Data.Tv_Arrow (uu___7, uu___8) -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___9 -> ty))) - | FStar_Reflection_V1_Data.Tv_FVar + | FStarC_Reflection_V1_Data.Tv_FVar fv -> Obj.magic (Obj.repr @@ -1431,7 +1434,7 @@ let rec (unfold_until_arrow : (unfold_until_arrow e ty')) uu___8))) - | FStar_Reflection_V1_Data.Tv_App + | FStarC_Reflection_V1_Data.Tv_App (uu___7, uu___8) -> Obj.magic (Obj.repr @@ -1469,7 +1472,7 @@ let rec (unfold_until_arrow : args) -> let uu___11 = - FStar_Tactics_V1_Builtins.inspect + FStarC_Tactics_V1_Builtins.inspect hd in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1500,7 +1503,7 @@ let rec (unfold_until_arrow : match uu___12 with | - FStar_Reflection_V1_Data.Tv_FVar + FStarC_Reflection_V1_Data.Tv_FVar fv -> let uu___13 = @@ -1577,7 +1580,7 @@ let rec (unfold_until_arrow : = let uu___15 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string ty0 in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1640,13 +1643,13 @@ let rec (unfold_until_arrow : uu___15))) uu___12))) uu___10))) - | FStar_Reflection_V1_Data.Tv_Refine + | FStarC_Reflection_V1_Data.Tv_Refine (bv, sort, ref) -> Obj.magic (Obj.repr (unfold_until_arrow e sort)) - | FStar_Reflection_V1_Data.Tv_AscribedT + | FStarC_Reflection_V1_Data.Tv_AscribedT (body, uu___7, uu___8, uu___9) -> @@ -1654,7 +1657,7 @@ let rec (unfold_until_arrow : (Obj.repr (unfold_until_arrow e body)) - | FStar_Reflection_V1_Data.Tv_AscribedC + | FStarC_Reflection_V1_Data.Tv_AscribedC (body, uu___7, uu___8, uu___9) -> @@ -1667,7 +1670,7 @@ let rec (unfold_until_arrow : (Obj.repr (let uu___8 = let uu___9 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string ty0 in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1728,10 +1731,10 @@ let rec (unfold_until_arrow : uu___6))) uu___5))) uu___4)))) uu___1) let (inst_comp_once : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.comp -> - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.comp, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.comp -> + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.comp, unit) FStar_Tactics_Effect.tac_repr) = fun e -> fun c -> @@ -1774,7 +1777,8 @@ let (inst_comp_once : (Obj.magic uu___1) (fun uu___2 -> (fun ty' -> - let uu___2 = FStar_Tactics_V1_Builtins.inspect ty' in + let uu___2 = + FStarC_Tactics_V1_Builtins.inspect ty' in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1797,7 +1801,7 @@ let (inst_comp_once : (fun uu___3 -> (fun uu___3 -> match uu___3 with - | FStar_Reflection_V1_Data.Tv_Arrow + | FStarC_Reflection_V1_Data.Tv_Arrow (b1, c1) -> Obj.magic (subst_binder_in_comp e b1 t c1) @@ -1807,10 +1811,10 @@ let (inst_comp_once : "inst_comp_once: inconsistent state")) uu___3))) uu___2))) uu___1) let rec (inst_comp : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.comp -> - FStar_Reflection_Types.term Prims.list -> - (FStar_Reflection_Types.comp, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.comp -> + FStarC_Reflection_Types.term Prims.list -> + (FStarC_Reflection_Types.comp, unit) FStar_Tactics_Effect.tac_repr) = fun uu___2 -> fun uu___1 -> @@ -1839,7 +1843,7 @@ let rec (inst_comp : (Obj.repr (FStar_InteractiveHelpers_Base.mfail_doc (FStar_List_Tot_Base.op_At - [FStar_Pprint.arbitrary_string + [FStarC_Pprint.arbitrary_string "inst_comp: error"] msg))) | err -> Obj.magic @@ -1864,10 +1868,10 @@ let rec (inst_comp : (fun c' -> Obj.magic (inst_comp e c' tl')) uu___1)))) uu___2 uu___1 uu___ let (_abs_update_typ : - FStar_Reflection_Types.binder -> - FStar_Reflection_Types.typ -> - FStar_Reflection_Types.binder Prims.list -> - FStar_Reflection_Types.env -> + FStarC_Reflection_Types.binder -> + FStarC_Reflection_Types.typ -> + FStarC_Reflection_Types.binder Prims.list -> + FStarC_Reflection_Types.env -> (typ_or_comp, unit) FStar_Tactics_Effect.tac_repr) = fun b -> @@ -1895,7 +1899,8 @@ let (_abs_update_typ : (Obj.magic uu___1) (fun uu___2 -> (fun ty' -> - let uu___2 = FStar_Tactics_V1_Builtins.inspect ty' in + let uu___2 = + FStarC_Tactics_V1_Builtins.inspect ty' in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1918,12 +1923,12 @@ let (_abs_update_typ : (fun uu___3 -> (fun uu___3 -> match uu___3 with - | FStar_Reflection_V1_Data.Tv_Arrow + | FStarC_Reflection_V1_Data.Tv_Arrow (b1, c1) -> let uu___4 = let uu___5 = - FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Var + FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Var (FStar_Reflection_V1_Derived.bv_of_binder b)) in FStar_Tactics_Effect.tac_bind @@ -1991,7 +1996,7 @@ let (_abs_update_typ : let uu___3 = let uu___4 = let uu___5 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string ty in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -2037,7 +2042,7 @@ let (_abs_update_typ : (fun uu___5 -> FStar_Tactics_Effect.lift_div_tac (fun uu___6 -> - FStar_Errors_Msg.text uu___5)) in + FStarC_Errors_Msg.text uu___5)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2108,9 +2113,9 @@ let (_abs_update_typ : Obj.magic (Obj.repr (FStar_Tactics_Effect.raise err))) uu___) let (abs_update_typ_or_comp : - FStar_Reflection_Types.binder -> + FStarC_Reflection_Types.binder -> typ_or_comp -> - FStar_Reflection_Types.env -> + FStarC_Reflection_Types.env -> (typ_or_comp, unit) FStar_Tactics_Effect.tac_repr) = fun uu___2 -> @@ -2129,9 +2134,9 @@ let (abs_update_typ_or_comp : TC_Comp (v, (b :: pl), (n + Prims.int_one))))) uu___2 uu___1 uu___ let (abs_update_opt_typ_or_comp : - FStar_Reflection_Types.binder -> + FStarC_Reflection_Types.binder -> typ_or_comp FStar_Pervasives_Native.option -> - FStar_Reflection_Types.env -> + FStarC_Reflection_Types.env -> (typ_or_comp FStar_Pervasives_Native.option, unit) FStar_Tactics_Effect.tac_repr) = @@ -2192,12 +2197,13 @@ let (abs_update_opt_typ_or_comp : uu___)))) uu___2 uu___1 uu___ let rec (_flush_typ_or_comp_comp : Prims.bool -> - FStar_Reflection_Types.env -> - FStar_Reflection_Types.binder Prims.list -> - ((FStar_Reflection_Types.bv * FStar_Reflection_Types.typ) * - FStar_Reflection_Types.term) Prims.list -> - FStar_Reflection_Types.comp -> - (FStar_Reflection_Types.comp, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.binder Prims.list -> + ((FStarC_Reflection_Types.bv * FStarC_Reflection_Types.typ) * + FStarC_Reflection_Types.term) Prims.list -> + FStarC_Reflection_Types.comp -> + (FStarC_Reflection_Types.comp, unit) + FStar_Tactics_Effect.tac_repr) = fun dbg -> fun e -> @@ -2280,7 +2286,8 @@ let rec (_flush_typ_or_comp_comp : let uu___2 = let uu___3 = let uu___4 = - FStar_Tactics_V1_Builtins.inspect ty in + FStarC_Tactics_V1_Builtins.inspect + ty in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2302,7 +2309,7 @@ let rec (_flush_typ_or_comp_comp : (fun uu___5 -> FStar_Tactics_Effect.lift_div_tac (fun uu___6 -> - FStar_Reflection_V1_Data.uu___is_Tv_Arrow + FStarC_Reflection_V1_Data.uu___is_Tv_Arrow uu___5)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -2407,7 +2414,7 @@ let rec (_flush_typ_or_comp_comp : match uu___3 with | (ty1, inst') -> let uu___4 = - FStar_Tactics_V1_Builtins.inspect + FStarC_Tactics_V1_Builtins.inspect ty1 in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -2432,7 +2439,7 @@ let rec (_flush_typ_or_comp_comp : (fun uu___5 -> match uu___5 with - | FStar_Reflection_V1_Data.Tv_Arrow + | FStarC_Reflection_V1_Data.Tv_Arrow (b', c') -> let uu___6 = let uu___7 @@ -2497,8 +2504,8 @@ let rec (_flush_typ_or_comp_comp : uu___9 -> let uu___10 = - FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Var + FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Var (FStar_Reflection_V1_Derived.bv_of_binder b)) in Obj.magic @@ -2780,7 +2787,7 @@ let rec (_flush_typ_or_comp_comp : uu___2))) uu___1) let (flush_typ_or_comp : Prims.bool -> - FStar_Reflection_Types.env -> + FStarC_Reflection_Types.env -> typ_or_comp -> (typ_or_comp, unit) FStar_Tactics_Effect.tac_repr) = fun dbg -> @@ -2898,8 +2905,8 @@ let (flush_typ_or_comp : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> - FStar_Reflection_V1_Builtins.pack_comp - (FStar_Reflection_V1_Data.C_Total + FStarC_Reflection_V1_Builtins.pack_comp + (FStarC_Reflection_V1_Data.C_Total ty))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -2981,7 +2988,7 @@ let (flush_typ_or_comp : (fun uu___6 -> FStar_Tactics_Effect.lift_div_tac (fun uu___7 -> - FStar_Errors_Msg.text + FStarC_Errors_Msg.text uu___6)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -3056,8 +3063,8 @@ let (flush_typ_or_comp : uu___1))) uu___1) let (safe_arg_typ_or_comp : Prims.bool -> - FStar_Reflection_Types.env -> - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.term -> (typ_or_comp FStar_Pervasives_Native.option, unit) FStar_Tactics_Effect.tac_repr) = @@ -3066,7 +3073,7 @@ let (safe_arg_typ_or_comp : fun hd -> let uu___ = let uu___1 = - let uu___2 = FStar_Tactics_V1_Builtins.term_to_string hd in + let uu___2 = FStarC_Tactics_V1_Builtins.term_to_string hd in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -3149,7 +3156,7 @@ let (safe_arg_typ_or_comp : (let uu___4 = let uu___5 = let uu___6 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string ty in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -3220,7 +3227,7 @@ let (safe_arg_typ_or_comp : let uu___6 = let uu___7 = let uu___8 = - FStar_Tactics_V1_Builtins.inspect + FStarC_Tactics_V1_Builtins.inspect ty in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -3243,7 +3250,7 @@ let (safe_arg_typ_or_comp : (fun uu___9 -> FStar_Tactics_Effect.lift_div_tac (fun uu___10 -> - FStar_Reflection_V1_Data.uu___is_Tv_Arrow + FStarC_Reflection_V1_Data.uu___is_Tv_Arrow uu___9)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -3363,7 +3370,7 @@ let (safe_arg_typ_or_comp : = let uu___15 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string ty1 in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -3476,7 +3483,7 @@ let (safe_arg_typ_or_comp : (fun uu___7 -> (fun ty1 -> let uu___7 = - FStar_Tactics_V1_Builtins.inspect + FStarC_Tactics_V1_Builtins.inspect ty1 in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -3505,7 +3512,7 @@ let (safe_arg_typ_or_comp : match uu___8 with | - FStar_Reflection_V1_Data.Tv_Arrow + FStarC_Reflection_V1_Data.Tv_Arrow (b, c) -> FStar_Pervasives_Native.Some (TC_Typ @@ -3519,33 +3526,33 @@ let (safe_arg_typ_or_comp : uu___7))) uu___5)))) uu___3))) uu___1) let (convert_ctrl_flag : - FStar_Tactics_Types.ctrl_flag -> FStar_Tactics_Types.ctrl_flag) = + FStarC_Tactics_Types.ctrl_flag -> FStarC_Tactics_Types.ctrl_flag) = fun flag -> match flag with - | FStar_Tactics_Types.Continue -> FStar_Tactics_Types.Continue - | FStar_Tactics_Types.Skip -> FStar_Tactics_Types.Continue - | FStar_Tactics_Types.Abort -> FStar_Tactics_Types.Abort + | FStarC_Tactics_Types.Continue -> FStarC_Tactics_Types.Continue + | FStarC_Tactics_Types.Skip -> FStarC_Tactics_Types.Continue + | FStarC_Tactics_Types.Abort -> FStarC_Tactics_Types.Abort type 'a explorer = 'a -> FStar_InteractiveHelpers_Base.genv -> (FStar_InteractiveHelpers_Base.genv * - FStar_Reflection_V1_Data.term_view) Prims.list -> + FStarC_Reflection_V1_Data.term_view) Prims.list -> typ_or_comp FStar_Pervasives_Native.option -> - FStar_Reflection_V1_Data.term_view -> - (('a * FStar_Tactics_Types.ctrl_flag), unit) + FStarC_Reflection_V1_Data.term_view -> + (('a * FStarC_Tactics_Types.ctrl_flag), unit) FStar_Tactics_Effect.tac_repr let bind_expl : 'a . 'a -> ('a -> - (('a * FStar_Tactics_Types.ctrl_flag), unit) + (('a * FStarC_Tactics_Types.ctrl_flag), unit) FStar_Tactics_Effect.tac_repr) -> ('a -> - (('a * FStar_Tactics_Types.ctrl_flag), unit) + (('a * FStarC_Tactics_Types.ctrl_flag), unit) FStar_Tactics_Effect.tac_repr) -> - (('a * FStar_Tactics_Types.ctrl_flag), unit) + (('a * FStarC_Tactics_Types.ctrl_flag), unit) FStar_Tactics_Effect.tac_repr = fun x -> @@ -3570,7 +3577,7 @@ let bind_expl : (fun uu___1 -> match uu___1 with | (x1, flag1) -> - if flag1 = FStar_Tactics_Types.Continue + if flag1 = FStarC_Tactics_Types.Continue then Obj.magic (Obj.repr (f2 x1)) else Obj.magic @@ -3586,10 +3593,10 @@ let rec (explore_term : Obj.t -> FStar_InteractiveHelpers_Base.genv -> (FStar_InteractiveHelpers_Base.genv * - FStar_Reflection_V1_Data.term_view) Prims.list -> + FStarC_Reflection_V1_Data.term_view) Prims.list -> typ_or_comp FStar_Pervasives_Native.option -> - FStar_Reflection_Types.term -> - ((Obj.t * FStar_Tactics_Types.ctrl_flag), unit) + FStarC_Reflection_Types.term -> + ((Obj.t * FStarC_Tactics_Types.ctrl_flag), unit) FStar_Tactics_Effect.tac_repr) = fun dbg -> @@ -3624,7 +3631,7 @@ let rec (explore_term : (fun uu___4 -> let uu___5 = let uu___6 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string t0 in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -3723,7 +3730,8 @@ let rec (explore_term : (Obj.magic uu___) (fun uu___1 -> (fun uu___1 -> - let uu___2 = FStar_Tactics_V1_Builtins.inspect t0 in + let uu___2 = + FStarC_Tactics_V1_Builtins.inspect t0 in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -3798,41 +3806,41 @@ let rec (explore_term : (fun pl1 -> if flag = - FStar_Tactics_Types.Continue + FStarC_Tactics_Types.Continue then Obj.magic (Obj.repr (match tv0 with | - FStar_Reflection_V1_Data.Tv_Var + FStarC_Reflection_V1_Data.Tv_Var uu___6 -> Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___7 -> (x0, - FStar_Tactics_Types.Continue))) + FStarC_Tactics_Types.Continue))) | - FStar_Reflection_V1_Data.Tv_BVar + FStarC_Reflection_V1_Data.Tv_BVar uu___6 -> Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___7 -> (x0, - FStar_Tactics_Types.Continue))) + FStarC_Tactics_Types.Continue))) | - FStar_Reflection_V1_Data.Tv_FVar + FStarC_Reflection_V1_Data.Tv_FVar uu___6 -> Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___7 -> (x0, - FStar_Tactics_Types.Continue))) + FStarC_Tactics_Types.Continue))) | - FStar_Reflection_V1_Data.Tv_App + FStarC_Reflection_V1_Data.Tv_App (hd, (a1, qual)) -> @@ -3996,7 +4004,7 @@ let rec (explore_term : flag1) -> if flag1 = - FStar_Tactics_Types.Continue + FStarC_Tactics_Types.Continue then Obj.magic (Obj.repr @@ -4020,7 +4028,7 @@ let rec (explore_term : uu___8))) uu___7)) | - FStar_Reflection_V1_Data.Tv_Abs + FStarC_Reflection_V1_Data.Tv_Abs (br, body) -> Obj.repr @@ -4091,7 +4099,7 @@ let rec (explore_term : uu___8))) uu___7)) | - FStar_Reflection_V1_Data.Tv_Arrow + FStarC_Reflection_V1_Data.Tv_Arrow (br, c01) -> Obj.repr @@ -4099,18 +4107,18 @@ let rec (explore_term : (fun uu___6 -> (x0, - FStar_Tactics_Types.Continue))) + FStarC_Tactics_Types.Continue))) | - FStar_Reflection_V1_Data.Tv_Type + FStarC_Reflection_V1_Data.Tv_Type uu___6 -> Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___7 -> (x0, - FStar_Tactics_Types.Continue))) + FStarC_Tactics_Types.Continue))) | - FStar_Reflection_V1_Data.Tv_Refine + FStarC_Reflection_V1_Data.Tv_Refine (bv, sort, ref) -> @@ -4121,7 +4129,7 @@ let rec (explore_term : (FStar_Tactics_Effect.lift_div_tac (fun uu___7 -> - FStar_Reflection_V1_Builtins.inspect_bv + FStarC_Reflection_V1_Builtins.inspect_bv bv)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -4185,7 +4193,7 @@ let rec (explore_term : flag1) -> if flag1 = - FStar_Tactics_Types.Continue + FStarC_Tactics_Types.Continue then Obj.magic (Obj.repr @@ -4241,16 +4249,16 @@ let rec (explore_term : uu___8))) uu___7)) | - FStar_Reflection_V1_Data.Tv_Const + FStarC_Reflection_V1_Data.Tv_Const uu___6 -> Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___7 -> (x0, - FStar_Tactics_Types.Continue))) + FStarC_Tactics_Types.Continue))) | - FStar_Reflection_V1_Data.Tv_Uvar + FStarC_Reflection_V1_Data.Tv_Uvar (uu___6, uu___7) -> @@ -4259,9 +4267,9 @@ let rec (explore_term : (fun uu___8 -> (x0, - FStar_Tactics_Types.Continue))) + FStarC_Tactics_Types.Continue))) | - FStar_Reflection_V1_Data.Tv_Let + FStarC_Reflection_V1_Data.Tv_Let (recf, attrs, bv, ty, @@ -4463,7 +4471,7 @@ let rec (explore_term : uu___8))) uu___7)) | - FStar_Reflection_V1_Data.Tv_Match + FStarC_Reflection_V1_Data.Tv_Match (scrutinee, _ret_opt, branches) @@ -4515,7 +4523,7 @@ let rec (explore_term : flag1) -> if flag1 = - FStar_Tactics_Types.Continue + FStarC_Tactics_Types.Continue then Obj.magic (Obj.repr @@ -4597,7 +4605,7 @@ let rec (explore_term : -> if flag11 = - FStar_Tactics_Types.Continue + FStarC_Tactics_Types.Continue then Obj.magic (Obj.repr @@ -4725,7 +4733,7 @@ let rec (explore_term : uu___8))) uu___7)) | - FStar_Reflection_V1_Data.Tv_AscribedT + FStarC_Reflection_V1_Data.Tv_AscribedT (e, ty, tac, uu___6) @@ -4803,7 +4811,7 @@ let rec (explore_term : flag1) -> if flag1 = - FStar_Tactics_Types.Continue + FStarC_Tactics_Types.Continue then Obj.magic (Obj.repr @@ -4825,7 +4833,7 @@ let rec (explore_term : uu___9))) uu___8)) | - FStar_Reflection_V1_Data.Tv_AscribedC + FStarC_Reflection_V1_Data.Tv_AscribedC (e, c1, tac, uu___6) @@ -4847,7 +4855,7 @@ let rec (explore_term : (fun uu___7 -> (x0, - FStar_Tactics_Types.Continue))))) + FStarC_Tactics_Types.Continue))))) else Obj.magic (Obj.repr @@ -4866,9 +4874,9 @@ and (explore_pattern : Obj.t explorer -> Obj.t -> FStar_InteractiveHelpers_Base.genv -> - FStar_Reflection_V1_Data.pattern -> + FStarC_Reflection_V1_Data.pattern -> ((FStar_InteractiveHelpers_Base.genv * Obj.t * - FStar_Tactics_Types.ctrl_flag), + FStarC_Tactics_Types.ctrl_flag), unit) FStar_Tactics_Effect.tac_repr) = fun dbg -> @@ -4898,13 +4906,14 @@ and (explore_pattern : (fun uu___1 -> (fun uu___1 -> match pat with - | FStar_Reflection_V1_Data.Pat_Constant uu___2 -> + | FStarC_Reflection_V1_Data.Pat_Constant uu___2 -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> - (ge0, x, FStar_Tactics_Types.Continue)))) - | FStar_Reflection_V1_Data.Pat_Cons + (ge0, x, + FStarC_Tactics_Types.Continue)))) + | FStarC_Reflection_V1_Data.Pat_Cons (fv, us, patterns) -> Obj.magic (Obj.repr @@ -4981,7 +4990,7 @@ and (explore_pattern : -> if flag = - FStar_Tactics_Types.Continue + FStarC_Tactics_Types.Continue then Obj.magic (Obj.repr @@ -5025,9 +5034,9 @@ and (explore_pattern : (FStar_Tactics_Util.fold_left explore_pat (ge0, x, - FStar_Tactics_Types.Continue) + FStarC_Tactics_Types.Continue) patterns)) uu___3))) - | FStar_Reflection_V1_Data.Pat_Var (bv, st) -> + | FStarC_Reflection_V1_Data.Pat_Var (bv, st) -> Obj.magic (Obj.repr (let uu___2 = @@ -5080,17 +5089,18 @@ and (explore_pattern : FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> (ge1, x, - FStar_Tactics_Types.Continue))))) - | FStar_Reflection_V1_Data.Pat_Dot_Term uu___2 -> + FStarC_Tactics_Types.Continue))))) + | FStarC_Reflection_V1_Data.Pat_Dot_Term uu___2 -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> - (ge0, x, FStar_Tactics_Types.Continue))))) + (ge0, x, + FStarC_Tactics_Types.Continue))))) uu___1) let (free_in : - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.bv Prims.list, unit) + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.bv Prims.list, unit) FStar_Tactics_Effect.tac_repr) = fun t -> @@ -5170,7 +5180,7 @@ let (free_in : fun c -> fun tv -> match tv with - | FStar_Reflection_V1_Data.Tv_Var + | FStarC_Reflection_V1_Data.Tv_Var bv -> Obj.magic (Obj.repr @@ -5288,7 +5298,7 @@ let (free_in : (fun uu___6 -> (fl', - FStar_Tactics_Types.Continue))))) + FStarC_Tactics_Types.Continue))))) | FStar_Pervasives_Native.Some uu___5 -> Obj.magic @@ -5297,9 +5307,9 @@ let (free_in : (fun uu___6 -> (fl, - FStar_Tactics_Types.Continue))))) + FStarC_Tactics_Types.Continue))))) uu___4))) - | FStar_Reflection_V1_Data.Tv_BVar + | FStarC_Reflection_V1_Data.Tv_BVar bv -> Obj.magic (Obj.repr @@ -5417,7 +5427,7 @@ let (free_in : (fun uu___6 -> (fl', - FStar_Tactics_Types.Continue))))) + FStarC_Tactics_Types.Continue))))) | FStar_Pervasives_Native.Some uu___5 -> Obj.magic @@ -5426,7 +5436,7 @@ let (free_in : (fun uu___6 -> (fl, - FStar_Tactics_Types.Continue))))) + FStarC_Tactics_Types.Continue))))) uu___4))) | uu___3 -> Obj.magic @@ -5434,7 +5444,7 @@ let (free_in : (FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> (fl, - FStar_Tactics_Types.Continue))))) + FStarC_Tactics_Types.Continue))))) uu___7 uu___6 uu___5 uu___4 uu___3 uu___2)) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -5453,7 +5463,7 @@ let (free_in : (Obj.magic uu___1) (fun uu___2 -> (fun update_free -> - let uu___2 = FStar_Tactics_V1_Builtins.top_env () in + let uu___2 = FStarC_Tactics_V1_Builtins.top_env () in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -5557,8 +5567,8 @@ let (free_in : uu___3))) uu___2))) uu___1) let (abs_free_in : FStar_InteractiveHelpers_Base.genv -> - FStar_Reflection_Types.term -> - ((FStar_Reflection_Types.bv * FStar_Reflection_Types.typ) Prims.list, + FStarC_Reflection_Types.term -> + ((FStarC_Reflection_Types.bv * FStarC_Reflection_Types.typ) Prims.list, unit) FStar_Tactics_Effect.tac_repr) = fun ge -> @@ -5594,8 +5604,8 @@ let (abs_free_in : (FStar_InteractiveHelpers_Base.genv_abstract_bvs ge)))) let (shadowed_free_in : FStar_InteractiveHelpers_Base.genv -> - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.bv Prims.list, unit) + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.bv Prims.list, unit) FStar_Tactics_Effect.tac_repr) = fun ge -> @@ -5622,7 +5632,7 @@ let (shadowed_free_in : FStar_InteractiveHelpers_Base.bv_is_shadowed ge bv) fvl)) let (term_has_shadowed_variables : FStar_InteractiveHelpers_Base.genv -> - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.term -> (Prims.bool, unit) FStar_Tactics_Effect.tac_repr) = fun ge -> diff --git a/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_Output.ml b/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_Output.ml index d87c6e1ce98..85c4a1636a7 100644 --- a/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_Output.ml +++ b/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_Output.ml @@ -1,10 +1,10 @@ open Prims let rec _split_subst_at_bv : 'a 'b . - FStar_Reflection_Types.bv -> - ((FStar_Reflection_Types.bv * 'a) * 'b) Prims.list -> - (((FStar_Reflection_Types.bv * 'a) * 'b) Prims.list * - ((FStar_Reflection_Types.bv * 'a) * 'b) Prims.list) + FStarC_Reflection_Types.bv -> + ((FStarC_Reflection_Types.bv * 'a) * 'b) Prims.list -> + (((FStarC_Reflection_Types.bv * 'a) * 'b) Prims.list * + ((FStarC_Reflection_Types.bv * 'a) * 'b) Prims.list) = fun x -> fun subst -> @@ -19,7 +19,7 @@ let rec _split_subst_at_bv : let (subst_shadowed_with_abs_in_assertions : Prims.bool -> FStar_InteractiveHelpers_Base.genv -> - FStar_Reflection_Types.bv FStar_Pervasives_Native.option -> + FStarC_Reflection_Types.bv FStar_Pervasives_Native.option -> FStar_InteractiveHelpers_Propositions.assertions -> ((FStar_InteractiveHelpers_Base.genv * FStar_InteractiveHelpers_Propositions.assertions), @@ -109,8 +109,8 @@ let (subst_shadowed_with_abs_in_assertions : match uu___5 with | (src, ty, tgt) -> let uu___6 = - FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Var + FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Var tgt) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -248,7 +248,7 @@ let (subst_shadowed_with_abs_in_assertions : = let uu___16 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string y in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -764,7 +764,7 @@ let (string_to_printout : Prims.string -> Prims.string -> Prims.string) = let (term_to_printout : FStar_InteractiveHelpers_Base.genv -> Prims.string -> - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.term -> (Prims.string, unit) FStar_Tactics_Effect.tac_repr) = fun ge -> @@ -817,8 +817,8 @@ let (term_to_printout : (fun uu___3 -> match uu___3 with | (bv, uu___4) -> - FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Var bv)) + FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Var bv)) abs in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -893,7 +893,7 @@ let (term_to_printout : (fun uu___5 -> (fun t2 -> let uu___5 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string t2 in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -930,7 +930,7 @@ let (term_to_printout : let (opt_term_to_printout : FStar_InteractiveHelpers_Base.genv -> Prims.string -> - FStar_Reflection_Types.term FStar_Pervasives_Native.option -> + FStarC_Reflection_Types.term FStar_Pervasives_Native.option -> (Prims.string, unit) FStar_Tactics_Effect.tac_repr) = fun uu___2 -> @@ -1234,7 +1234,8 @@ let (result_to_printout : Obj.magic (Obj.repr (let uu___2 = - let uu___3 = FStar_Tactics_V1_Builtins.top_env () in + let uu___3 = + FStarC_Tactics_V1_Builtins.top_env () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1448,7 +1449,7 @@ let (printout_result : (Prims.of_int (146)) (Prims.of_int (2)) (Prims.of_int (146)) (Prims.of_int (39))))) (Obj.magic uu___) (fun uu___1 -> - (fun uu___1 -> Obj.magic (FStar_Tactics_V1_Builtins.print uu___1)) + (fun uu___1 -> Obj.magic (FStarC_Tactics_V1_Builtins.print uu___1)) uu___1) let (printout_success : FStar_InteractiveHelpers_Base.genv -> @@ -1456,14 +1457,15 @@ let (printout_success : (unit, unit) FStar_Tactics_Effect.tac_repr) = fun ge -> fun a -> printout_result "ainfo" (ESuccess (ge, a)) let (printout_failure : - FStar_Errors_Msg.error_message -> + FStarC_Errors_Msg.error_message -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun err -> - printout_result "ainfo" (EFailure (FStar_Errors_Msg.rendermsg err)) + printout_result "ainfo" (EFailure (FStarC_Errors_Msg.rendermsg err)) let (_debug_print_var : Prims.string -> - FStar_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> + (unit, unit) FStar_Tactics_Effect.tac_repr) = fun name -> fun t -> @@ -1471,7 +1473,7 @@ let (_debug_print_var : let uu___1 = let uu___2 = let uu___3 = - let uu___4 = FStar_Tactics_V1_Builtins.term_to_string t in + let uu___4 = FStarC_Tactics_V1_Builtins.term_to_string t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1530,7 +1532,7 @@ let (_debug_print_var : (Obj.magic uu___1) (fun uu___2 -> (fun uu___2 -> - Obj.magic (FStar_Tactics_V1_Builtins.print uu___2)) uu___2) in + Obj.magic (FStarC_Tactics_V1_Builtins.print uu___2)) uu___2) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1546,7 +1548,7 @@ let (_debug_print_var : (fun uu___1 -> let uu___2 = let uu___3 = - let uu___4 = FStar_Tactics_V1_Builtins.top_env () in + let uu___4 = FStarC_Tactics_V1_Builtins.top_env () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1588,7 +1590,7 @@ let (_debug_print_var : (Obj.repr (let uu___5 = let uu___6 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string ty in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1632,7 +1634,7 @@ let (_debug_print_var : (fun uu___6 -> (fun uu___6 -> Obj.magic - (FStar_Tactics_V1_Builtins.print + (FStarC_Tactics_V1_Builtins.print uu___6)) uu___6))) | uu___5 -> Obj.magic @@ -1700,7 +1702,7 @@ let (_debug_print_var : (fun uu___6 -> (fun uu___6 -> Obj.magic - (FStar_Tactics_V1_Builtins.print uu___6)) + (FStarC_Tactics_V1_Builtins.print uu___6)) uu___6) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1725,7 +1727,7 @@ let (_debug_print_var : (fun uu___5 -> let uu___6 = let uu___7 = - FStar_Tactics_V1_Builtins.inspect t in + FStarC_Tactics_V1_Builtins.inspect t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1747,7 +1749,7 @@ let (_debug_print_var : (fun uu___8 -> (fun uu___8 -> match uu___8 with - | FStar_Reflection_V1_Data.Tv_Var + | FStarC_Reflection_V1_Data.Tv_Var bv -> Obj.magic (Obj.repr @@ -1756,7 +1758,7 @@ let (_debug_print_var : (FStar_Tactics_Effect.lift_div_tac (fun uu___10 -> - FStar_Reflection_V1_Builtins.inspect_bv + FStarC_Reflection_V1_Builtins.inspect_bv bv)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1816,7 +1818,7 @@ let (_debug_print_var : (Prims.strcat "; index: " (Prims.string_of_int - b.FStar_Reflection_V1_Data.bv_index)))) in + b.FStarC_Reflection_V1_Data.bv_index)))) in FStar_Tactics_Effect.tac_bind ( FStar_Sealed.seal @@ -1877,7 +1879,7 @@ let (_debug_print_var : uu___11 -> Obj.magic - (FStar_Tactics_V1_Builtins.print + (FStarC_Tactics_V1_Builtins.print uu___11)) uu___11))) uu___10))) @@ -1909,7 +1911,7 @@ let (_debug_print_var : (fun uu___7 -> (fun uu___7 -> Obj.magic - (FStar_Tactics_V1_Builtins.print + (FStarC_Tactics_V1_Builtins.print "end of _debug_print_var")) uu___7))) uu___5))) uu___3))) uu___1) @@ -1921,9 +1923,9 @@ let (tadmit_no_warning : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> FStar_Tactics_V1_Derived.apply - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "InteractiveHelpers"; "Output"; "magic_witness"]))) let (pp_tac : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> @@ -1945,7 +1947,8 @@ let (pp_tac : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (Obj.magic uu___4) (fun uu___5 -> (fun uu___5 -> - Obj.magic (FStar_Tactics_V1_Builtins.term_to_string uu___5)) + Obj.magic + (FStarC_Tactics_V1_Builtins.term_to_string uu___5)) uu___5) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1973,7 +1976,7 @@ let (pp_tac : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (Prims.of_int (184)) (Prims.of_int (2)) (Prims.of_int (184)) (Prims.of_int (62))))) (Obj.magic uu___2) (fun uu___3 -> - (fun uu___3 -> Obj.magic (FStar_Tactics_V1_Builtins.print uu___3)) + (fun uu___3 -> Obj.magic (FStarC_Tactics_V1_Builtins.print uu___3)) uu___3) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1988,7 +1991,7 @@ let (pp_tac : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (Prims.of_int (9))))) (Obj.magic uu___1) (fun uu___2 -> (fun uu___2 -> - let uu___3 = FStar_Tactics_V1_Builtins.dump "" in + let uu___3 = FStarC_Tactics_V1_Builtins.dump "" in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal diff --git a/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_PostProcess.ml b/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_PostProcess.ml index e65d3c26526..fce637176d6 100644 --- a/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_PostProcess.ml +++ b/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_PostProcess.ml @@ -7,12 +7,12 @@ let (focus_on_term : meta_info) = "Not yet implemented: FStar.InteractiveHelpers.PostProcess.focus_on_term") let (end_proof : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> - FStar_Tactics_V1_Builtins.tadmit_t - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const FStar_Reflection_V2_Data.C_Unit)) + FStarC_Tactics_V1_Builtins.tadmit_t + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const FStarC_Reflection_V2_Data.C_Unit)) let (unsquash_equality : - FStar_Reflection_Types.term -> - ((FStar_Reflection_Types.term * FStar_Reflection_Types.term) + FStarC_Reflection_Types.term -> + ((FStarC_Reflection_Types.term * FStarC_Reflection_Types.term) FStar_Pervasives_Native.option, unit) FStar_Tactics_Effect.tac_repr) = @@ -87,7 +87,7 @@ let (pp_explore : let uu___2 = let uu___3 = let uu___4 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string g in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -245,7 +245,7 @@ let (pp_explore : = let uu___11 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string l in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -392,7 +392,7 @@ let (pp_explore_print_goal : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___8 -> - ((), FStar_Tactics_Types.Continue)))) + ((), FStarC_Tactics_Types.Continue)))) uu___2)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -410,7 +410,7 @@ let (pp_explore_print_goal : Obj.magic (pp_explore true false () (Obj.magic f) (Obj.repr ()))) uu___2) let (is_focus_on_term : - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.term -> (Prims.bool, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> @@ -422,12 +422,12 @@ let (is_focus_on_term : "FStar.InteractiveHelpers.PostProcess.focus_on_term"))) uu___ let (term_is_assert_or_assume : - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.term FStar_Pervasives_Native.option, unit) + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.term FStar_Pervasives_Native.option, unit) FStar_Tactics_Effect.tac_repr) = fun t -> - let uu___ = FStar_Tactics_V1_Builtins.inspect t in + let uu___ = FStarC_Tactics_V1_Builtins.inspect t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -443,8 +443,8 @@ let (term_is_assert_or_assume : FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> match uu___1 with - | FStar_Reflection_V1_Data.Tv_App - (hd, (a, FStar_Reflection_V1_Data.Q_Explicit)) -> + | FStarC_Reflection_V1_Data.Tv_App + (hd, (a, FStarC_Reflection_V1_Data.Q_Explicit)) -> if FStar_Reflection_V1_Derived.is_any_fvar a ["Prims._assert"; @@ -454,14 +454,14 @@ let (term_is_assert_or_assume : else FStar_Pervasives_Native.None | uu___3 -> FStar_Pervasives_Native.None)) let (is_focused_term : - FStar_Reflection_V1_Data.term_view -> - (FStar_Reflection_Types.term FStar_Pervasives_Native.option, unit) + FStarC_Reflection_V1_Data.term_view -> + (FStarC_Reflection_Types.term FStar_Pervasives_Native.option, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> (fun tv -> match tv with - | FStar_Reflection_V1_Data.Tv_Let + | FStarC_Reflection_V1_Data.Tv_Let (recf, attrs, uu___, uu___1, def, body) -> Obj.magic (Obj.repr @@ -495,8 +495,8 @@ type 'a exploration_result = { ge: FStar_InteractiveHelpers_Base.genv ; parents: - (FStar_InteractiveHelpers_Base.genv * FStar_Reflection_V1_Data.term_view) - Prims.list + (FStar_InteractiveHelpers_Base.genv * + FStarC_Reflection_V1_Data.term_view) Prims.list ; tgt_comp: FStar_InteractiveHelpers_ExploreTerm.typ_or_comp @@ -511,7 +511,7 @@ let __proj__Mkexploration_result__item__parents : 'a . 'a exploration_result -> (FStar_InteractiveHelpers_Base.genv * - FStar_Reflection_V1_Data.term_view) Prims.list + FStarC_Reflection_V1_Data.term_view) Prims.list = fun projectee -> match projectee with | { ge; parents; tgt_comp; res;_} -> parents @@ -532,7 +532,7 @@ let mk_exploration_result : unit -> FStar_InteractiveHelpers_Base.genv -> (FStar_InteractiveHelpers_Base.genv * - FStar_Reflection_V1_Data.term_view) Prims.list -> + FStarC_Reflection_V1_Data.term_view) Prims.list -> FStar_InteractiveHelpers_ExploreTerm.typ_or_comp FStar_Pervasives_Native.option -> 'uuuuu -> 'uuuuu exploration_result @@ -546,11 +546,11 @@ let mk_exploration_result : } type 'a pred_explorer = FStar_InteractiveHelpers_Base.genv -> - (FStar_InteractiveHelpers_Base.genv * FStar_Reflection_V1_Data.term_view) - Prims.list -> + (FStar_InteractiveHelpers_Base.genv * + FStarC_Reflection_V1_Data.term_view) Prims.list -> FStar_InteractiveHelpers_ExploreTerm.typ_or_comp FStar_Pervasives_Native.option -> - FStar_Reflection_V1_Data.term_view -> + FStarC_Reflection_V1_Data.term_view -> ('a FStar_Pervasives_Native.option, unit) FStar_Tactics_Effect.tac_repr let find_predicated_term_explorer : @@ -628,7 +628,7 @@ let find_predicated_term_explorer : let uu___7 = let uu___8 = let uu___9 = - FStar_Tactics_V1_Builtins.pack + FStarC_Tactics_V1_Builtins.pack t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -651,7 +651,7 @@ let find_predicated_term_explorer : (fun uu___10 -> (fun uu___10 -> Obj.magic - (FStar_Tactics_V1_Builtins.term_to_string + (FStarC_Tactics_V1_Builtins.term_to_string uu___10)) uu___10) in FStar_Tactics_Effect.tac_bind @@ -746,7 +746,7 @@ let find_predicated_term_explorer : (fun uu___4 -> (fun uu___4 -> Obj.magic - (FStar_Tactics_V1_Builtins.print + (FStarC_Tactics_V1_Builtins.print uu___4)) uu___4))) else Obj.magic @@ -801,11 +801,11 @@ let find_predicated_term_explorer : ((mk_exploration_result ()) ge pl opt_c ft)), - FStar_Tactics_Types.Abort) + FStarC_Tactics_Types.Abort) | FStar_Pervasives_Native.None -> (FStar_Pervasives_Native.None, - FStar_Tactics_Types.Continue))))) + FStarC_Tactics_Types.Continue))))) uu___3))) uu___1) let find_predicated_term : 'a . @@ -814,10 +814,10 @@ let find_predicated_term : Prims.bool -> FStar_InteractiveHelpers_Base.genv -> (FStar_InteractiveHelpers_Base.genv * - FStar_Reflection_V1_Data.term_view) Prims.list -> + FStarC_Reflection_V1_Data.term_view) Prims.list -> FStar_InteractiveHelpers_ExploreTerm.typ_or_comp FStar_Pervasives_Native.option -> - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.term -> ('a exploration_result FStar_Pervasives_Native.option, unit) FStar_Tactics_Effect.tac_repr = @@ -851,18 +851,18 @@ let find_predicated_term : (fun uu___1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> FStar_Pervasives_Native.fst uu___1)) -let (_is_focused_term_explorer : FStar_Reflection_Types.term pred_explorer) = - fun ge -> fun pl -> fun opt_c -> fun tv -> is_focused_term tv +let (_is_focused_term_explorer : FStarC_Reflection_Types.term pred_explorer) + = fun ge -> fun pl -> fun opt_c -> fun tv -> is_focused_term tv let (find_focused_term : Prims.bool -> Prims.bool -> FStar_InteractiveHelpers_Base.genv -> (FStar_InteractiveHelpers_Base.genv * - FStar_Reflection_V1_Data.term_view) Prims.list -> + FStarC_Reflection_V1_Data.term_view) Prims.list -> FStar_InteractiveHelpers_ExploreTerm.typ_or_comp FStar_Pervasives_Native.option -> - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.term exploration_result + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.term exploration_result FStar_Pervasives_Native.option, unit) FStar_Tactics_Effect.tac_repr) = @@ -876,7 +876,7 @@ let (find_focused_term : opt_c t let (find_focused_term_in_current_goal : Prims.bool -> - (FStar_Reflection_Types.term exploration_result, unit) + (FStarC_Reflection_Types.term exploration_result, unit) FStar_Tactics_Effect.tac_repr) = fun dbg -> @@ -915,7 +915,7 @@ let (find_focused_term_in_current_goal : let uu___2 = let uu___3 = let uu___4 = - FStar_Tactics_V1_Builtins.term_to_string g in + FStarC_Tactics_V1_Builtins.term_to_string g in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1063,7 +1063,7 @@ let (find_focused_term_in_current_goal : = let uu___11 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string l in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1192,7 +1192,7 @@ let (find_focused_term_in_current_goal : = let uu___15 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string res.res in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1287,7 +1287,7 @@ let (find_focused_term_in_current_goal : = let uu___14 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string g in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1360,7 +1360,7 @@ let (find_focused_term_in_current_goal : uu___1) let (find_focused_assert_in_current_goal : Prims.bool -> - (FStar_Reflection_Types.term exploration_result, unit) + (FStarC_Reflection_Types.term exploration_result, unit) FStar_Tactics_Effect.tac_repr) = fun dbg -> @@ -1401,7 +1401,8 @@ let (find_focused_assert_in_current_goal : let uu___3 = let uu___4 = let uu___5 = - FStar_Tactics_V1_Builtins.term_to_string res.res in + FStarC_Tactics_V1_Builtins.term_to_string + res.res in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1462,7 +1463,7 @@ let (find_focused_assert_in_current_goal : (fun uu___4 -> let uu___5 = let uu___6 = - FStar_Tactics_V1_Builtins.inspect + FStarC_Tactics_V1_Builtins.inspect res.res in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1485,7 +1486,7 @@ let (find_focused_assert_in_current_goal : (fun uu___7 -> (fun uu___7 -> match uu___7 with - | FStar_Reflection_V1_Data.Tv_Let + | FStarC_Reflection_V1_Data.Tv_Let (uu___8, uu___9, bv0, ty, fterm, uu___10) -> @@ -1586,7 +1587,7 @@ let (find_focused_assert_in_current_goal : = let uu___9 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string res.res in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1672,7 +1673,7 @@ let (analyze_effectful_term : Prims.bool -> Prims.bool -> Prims.bool -> - FStar_Reflection_Types.term exploration_result -> + FStarC_Reflection_Types.term exploration_result -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun dbg -> @@ -1721,7 +1722,7 @@ let (analyze_effectful_term : (fun opt_c -> let uu___2 = let uu___3 = - FStar_Tactics_V1_Builtins.inspect res.res in + FStarC_Tactics_V1_Builtins.inspect res.res in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1743,14 +1744,14 @@ let (analyze_effectful_term : (fun uu___4 -> (fun uu___4 -> match uu___4 with - | FStar_Reflection_V1_Data.Tv_Let + | FStarC_Reflection_V1_Data.Tv_Let (uu___5, uu___6, bv0, ty, fterm, uu___7) -> let uu___8 = let uu___9 = let uu___10 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string fterm in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1951,7 +1952,7 @@ let (analyze_effectful_term : (fun uu___14 -> - FStar_Reflection_V1_Builtins.inspect_bv + FStarC_Reflection_V1_Builtins.inspect_bv bv0)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -2075,7 +2076,7 @@ let (analyze_effectful_term : let uu___17 = FStar_Tactics_Unseal.unseal - bvv0.FStar_Reflection_V1_Data.bv_ppname in + bvv0.FStarC_Reflection_V1_Data.bv_ppname in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2530,8 +2531,8 @@ let (analyze_effectful_term : = FStar_InteractiveHelpers_Base.opt_tapply (fun x -> - FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Var + FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Var x)) ret_bv in Obj.magic @@ -2858,25 +2859,27 @@ let (pp_analyze_effectful_term : Obj.magic (Obj.repr (FStar_Tactics_Effect.raise err))) uu___1) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.InteractiveHelpers.PostProcess.pp_analyze_effectful_term" (Prims.of_int (5)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_4 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_4 "FStar.InteractiveHelpers.PostProcess.pp_analyze_effectful_term (plugin)" - (FStar_Tactics_Native.from_tactic_4 pp_analyze_effectful_term) - FStar_Syntax_Embeddings.e_bool FStar_Syntax_Embeddings.e_bool - FStar_Syntax_Embeddings.e_bool FStar_Syntax_Embeddings.e_unit - FStar_Syntax_Embeddings.e_unit psc ncb us args) + (FStarC_Tactics_Native.from_tactic_4 pp_analyze_effectful_term) + FStarC_Syntax_Embeddings.e_bool + FStarC_Syntax_Embeddings.e_bool + FStarC_Syntax_Embeddings.e_bool + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (remove_b2t : - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) = fun t -> - let uu___ = FStar_Tactics_V1_Builtins.inspect t in + let uu___ = FStarC_Tactics_V1_Builtins.inspect t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2891,11 +2894,11 @@ let (remove_b2t : (fun uu___1 -> (fun uu___1 -> match uu___1 with - | FStar_Reflection_V1_Data.Tv_App - (hd, (a, FStar_Reflection_V1_Data.Q_Explicit)) -> + | FStarC_Reflection_V1_Data.Tv_App + (hd, (a, FStarC_Reflection_V1_Data.Q_Explicit)) -> Obj.magic (Obj.repr - (let uu___2 = FStar_Tactics_V1_Builtins.inspect hd in + (let uu___2 = FStarC_Tactics_V1_Builtins.inspect hd in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2914,7 +2917,7 @@ let (remove_b2t : FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> match uu___3 with - | FStar_Reflection_V1_Data.Tv_FVar fv -> + | FStarC_Reflection_V1_Data.Tv_FVar fv -> if FStar_InteractiveHelpers_Base.fv_eq_name fv FStar_Reflection_Const.b2t_qn @@ -2927,8 +2930,8 @@ let (remove_b2t : (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> t)))) uu___1) let (is_conjunction : - FStar_Reflection_Types.term -> - ((FStar_Reflection_Types.term * FStar_Reflection_Types.term) + FStarC_Reflection_Types.term -> + ((FStarC_Reflection_Types.term * FStarC_Reflection_Types.term) FStar_Pervasives_Native.option, unit) FStar_Tactics_Effect.tac_repr) = @@ -2968,13 +2971,13 @@ let (is_conjunction : match uu___2 with | (hd, params) -> (match params with - | (x, FStar_Reflection_V1_Data.Q_Explicit):: - (y, FStar_Reflection_V1_Data.Q_Explicit)::[] + | (x, FStarC_Reflection_V1_Data.Q_Explicit):: + (y, FStarC_Reflection_V1_Data.Q_Explicit)::[] -> Obj.magic (Obj.repr (let uu___3 = - FStar_Tactics_V1_Builtins.inspect hd in + FStarC_Tactics_V1_Builtins.inspect hd in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2997,15 +3000,15 @@ let (is_conjunction : FStar_Tactics_Effect.lift_div_tac (fun uu___5 -> match uu___4 with - | FStar_Reflection_V1_Data.Tv_FVar + | FStarC_Reflection_V1_Data.Tv_FVar fv -> if - ((FStar_Reflection_V1_Builtins.inspect_fv + ((FStarC_Reflection_V1_Builtins.inspect_fv fv) = FStar_Reflection_Const.and_qn) || - ((FStar_Reflection_V1_Builtins.inspect_fv + ((FStarC_Reflection_V1_Builtins.inspect_fv fv) = ["Prims"; @@ -3025,9 +3028,9 @@ let (is_conjunction : FStar_Pervasives_Native.None))))) uu___2))) uu___1) let rec (_split_conjunctions : - FStar_Reflection_Types.term Prims.list -> - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.term Prims.list, unit) + FStarC_Reflection_Types.term Prims.list -> + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.term Prims.list, unit) FStar_Tactics_Effect.tac_repr) = fun ls -> @@ -3099,14 +3102,14 @@ let rec (_split_conjunctions : (fun uu___4 -> ls2)))) uu___3)))) uu___1) let (split_conjunctions : - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.term Prims.list, unit) + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.term Prims.list, unit) FStar_Tactics_Effect.tac_repr) = fun t -> _split_conjunctions [] t let (split_conjunctions_under_match : Prims.bool -> - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.term Prims.list, unit) + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.term Prims.list, unit) FStar_Tactics_Effect.tac_repr) = fun dbg -> @@ -3185,7 +3188,7 @@ let (split_conjunctions_under_match : (Obj.magic uu___1) (fun uu___2 -> (fun uu___2 -> - let uu___3 = FStar_Tactics_V1_Builtins.inspect t1 in + let uu___3 = FStarC_Tactics_V1_Builtins.inspect t1 in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -3208,7 +3211,7 @@ let (split_conjunctions_under_match : (fun uu___4 -> (fun uu___4 -> match uu___4 with - | FStar_Reflection_V1_Data.Tv_Match + | FStarC_Reflection_V1_Data.Tv_Match (scrut, ret_opt, (pat, br)::[]) -> Obj.magic (Obj.repr @@ -3237,8 +3240,8 @@ let (split_conjunctions_under_match : Obj.magic (FStar_Tactics_Util.map (fun x -> - FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Match + FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Match (scrut, ret_opt, [ @@ -3252,7 +3255,7 @@ let (split_conjunctions_under_match : uu___2))) uu___1) let (split_assert_conjs : Prims.bool -> - FStar_Reflection_Types.term exploration_result -> + FStarC_Reflection_Types.term exploration_result -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun dbg -> @@ -3276,7 +3279,7 @@ let (split_assert_conjs : (fun uu___1 -> (fun ge0 -> let uu___1 = - FStar_Tactics_V1_Builtins.norm_term_env + FStarC_Tactics_V1_Builtins.norm_term_env ge0.FStar_InteractiveHelpers_Base.env FStar_InteractiveHelpers_Propositions.simpl_norm_steps res.res in @@ -3458,43 +3461,44 @@ let (pp_split_assert_conjs : | err -> Obj.magic (Obj.repr (FStar_Tactics_Effect.raise err))) uu___1) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.InteractiveHelpers.PostProcess.pp_split_assert_conjs" (Prims.of_int (3)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_2 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_2 "FStar.InteractiveHelpers.PostProcess.pp_split_assert_conjs (plugin)" - (FStar_Tactics_Native.from_tactic_2 pp_split_assert_conjs) - FStar_Syntax_Embeddings.e_bool FStar_Syntax_Embeddings.e_unit - FStar_Syntax_Embeddings.e_unit psc ncb us args) + (FStarC_Tactics_Native.from_tactic_2 pp_split_assert_conjs) + FStarC_Syntax_Embeddings.e_bool + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit psc ncb us args) type eq_kind = - | Eq_Dec of FStar_Reflection_Types.typ - | Eq_Undec of FStar_Reflection_Types.typ - | Eq_Hetero of FStar_Reflection_Types.typ * FStar_Reflection_Types.typ + | Eq_Dec of FStarC_Reflection_Types.typ + | Eq_Undec of FStarC_Reflection_Types.typ + | Eq_Hetero of FStarC_Reflection_Types.typ * FStarC_Reflection_Types.typ let (uu___is_Eq_Dec : eq_kind -> Prims.bool) = fun projectee -> match projectee with | Eq_Dec _0 -> true | uu___ -> false -let (__proj__Eq_Dec__item___0 : eq_kind -> FStar_Reflection_Types.typ) = +let (__proj__Eq_Dec__item___0 : eq_kind -> FStarC_Reflection_Types.typ) = fun projectee -> match projectee with | Eq_Dec _0 -> _0 let (uu___is_Eq_Undec : eq_kind -> Prims.bool) = fun projectee -> match projectee with | Eq_Undec _0 -> true | uu___ -> false -let (__proj__Eq_Undec__item___0 : eq_kind -> FStar_Reflection_Types.typ) = +let (__proj__Eq_Undec__item___0 : eq_kind -> FStarC_Reflection_Types.typ) = fun projectee -> match projectee with | Eq_Undec _0 -> _0 let (uu___is_Eq_Hetero : eq_kind -> Prims.bool) = fun projectee -> match projectee with | Eq_Hetero (_0, _1) -> true | uu___ -> false -let (__proj__Eq_Hetero__item___0 : eq_kind -> FStar_Reflection_Types.typ) = +let (__proj__Eq_Hetero__item___0 : eq_kind -> FStarC_Reflection_Types.typ) = fun projectee -> match projectee with | Eq_Hetero (_0, _1) -> _0 -let (__proj__Eq_Hetero__item___1 : eq_kind -> FStar_Reflection_Types.typ) = +let (__proj__Eq_Hetero__item___1 : eq_kind -> FStarC_Reflection_Types.typ) = fun projectee -> match projectee with | Eq_Hetero (_0, _1) -> _1 let (is_eq : Prims.bool -> - FStar_Reflection_Types.term -> - ((eq_kind * FStar_Reflection_Types.term * FStar_Reflection_Types.term) - FStar_Pervasives_Native.option, + FStarC_Reflection_Types.term -> + ((eq_kind * FStarC_Reflection_Types.term * + FStarC_Reflection_Types.term) FStar_Pervasives_Native.option, unit) FStar_Tactics_Effect.tac_repr) = fun dbg -> @@ -3517,7 +3521,7 @@ let (is_eq : (fun t1 -> let uu___1 = let uu___2 = - let uu___3 = FStar_Tactics_V1_Builtins.term_to_string t1 in + let uu___3 = FStarC_Tactics_V1_Builtins.term_to_string t1 in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -3598,7 +3602,7 @@ let (is_eq : let uu___5 = let uu___6 = let uu___7 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string hd in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -3675,7 +3679,7 @@ let (is_eq : match uu___10 with | (x, y) -> - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string x) params in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -3747,7 +3751,7 @@ let (is_eq : (fun uu___8 -> (fun uu___8 -> let uu___9 = - FStar_Tactics_V1_Builtins.inspect + FStarC_Tactics_V1_Builtins.inspect hd in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -3779,17 +3783,17 @@ let (is_eq : match uu___10 with | - FStar_Reflection_V1_Data.Tv_FVar + FStarC_Reflection_V1_Data.Tv_FVar fv -> (match params with | (a, - FStar_Reflection_V1_Data.Q_Implicit):: + FStarC_Reflection_V1_Data.Q_Implicit):: (x, - FStar_Reflection_V1_Data.Q_Explicit):: + FStarC_Reflection_V1_Data.Q_Explicit):: (y, - FStar_Reflection_V1_Data.Q_Explicit)::[] + FStarC_Reflection_V1_Data.Q_Explicit)::[] -> if FStar_Reflection_V1_Derived.is_any_fvar @@ -3815,13 +3819,13 @@ let (is_eq : FStar_Pervasives_Native.None | (a, - FStar_Reflection_V1_Data.Q_Implicit):: + FStarC_Reflection_V1_Data.Q_Implicit):: (b, - FStar_Reflection_V1_Data.Q_Implicit):: + FStarC_Reflection_V1_Data.Q_Implicit):: (x, - FStar_Reflection_V1_Data.Q_Explicit):: + FStarC_Reflection_V1_Data.Q_Explicit):: (y, - FStar_Reflection_V1_Data.Q_Explicit)::[] + FStarC_Reflection_V1_Data.Q_Explicit)::[] -> if FStar_Reflection_V1_Derived.is_fvar @@ -3846,8 +3850,8 @@ let (is_eq : uu___4))) uu___2))) uu___1) let (mk_eq : eq_kind -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> FStar_Reflection_Types.term) + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term) = fun k -> fun t1 -> @@ -3855,31 +3859,31 @@ let (mk_eq : match k with | Eq_Dec ty -> FStar_Reflection_V1_Derived.mk_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "op_Equality"]))) - [(ty, FStar_Reflection_V1_Data.Q_Implicit); - (t1, FStar_Reflection_V1_Data.Q_Explicit); - (t2, FStar_Reflection_V1_Data.Q_Explicit)] + [(ty, FStarC_Reflection_V1_Data.Q_Implicit); + (t1, FStarC_Reflection_V1_Data.Q_Explicit); + (t2, FStarC_Reflection_V1_Data.Q_Explicit)] | Eq_Undec ty -> FStar_Reflection_V1_Derived.mk_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv ["Prims"; "eq2"]))) - [(ty, FStar_Reflection_V1_Data.Q_Implicit); - (t1, FStar_Reflection_V1_Data.Q_Explicit); - (t2, FStar_Reflection_V1_Data.Q_Explicit)] + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "eq2"]))) + [(ty, FStarC_Reflection_V1_Data.Q_Implicit); + (t1, FStarC_Reflection_V1_Data.Q_Explicit); + (t2, FStarC_Reflection_V1_Data.Q_Explicit)] | Eq_Hetero (ty1, ty2) -> FStar_Reflection_V1_Derived.mk_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "op_Equals_Equals_Equals"]))) - [(ty1, FStar_Reflection_V1_Data.Q_Implicit); - (ty2, FStar_Reflection_V1_Data.Q_Implicit); - (t1, FStar_Reflection_V1_Data.Q_Explicit); - (t2, FStar_Reflection_V1_Data.Q_Explicit)] + [(ty1, FStarC_Reflection_V1_Data.Q_Implicit); + (ty2, FStarC_Reflection_V1_Data.Q_Implicit); + (t1, FStarC_Reflection_V1_Data.Q_Explicit); + (t2, FStarC_Reflection_V1_Data.Q_Explicit)] let (formula_construct : FStar_Reflection_V1_Formula.formula -> (Prims.string, unit) FStar_Tactics_Effect.tac_repr) @@ -3912,9 +3916,9 @@ let (formula_construct : uu___ let (is_equality_for_term : Prims.bool -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.term FStar_Pervasives_Native.option, + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.term FStar_Pervasives_Native.option, unit) FStar_Tactics_Effect.tac_repr) = fun dbg -> @@ -3924,7 +3928,7 @@ let (is_equality_for_term : let uu___1 = let uu___2 = let uu___3 = - let uu___4 = FStar_Tactics_V1_Builtins.term_to_string tm in + let uu___4 = FStarC_Tactics_V1_Builtins.term_to_string tm in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -3943,7 +3947,7 @@ let (is_equality_for_term : (fun uu___5 -> let uu___6 = let uu___7 = - FStar_Tactics_V1_Builtins.term_to_string p in + FStarC_Tactics_V1_Builtins.term_to_string p in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -4050,7 +4054,7 @@ let (is_equality_for_term : (fun uu___1 -> (fun uu___1 -> let uu___2 = - let uu___3 = FStar_Tactics_V1_Builtins.inspect tm in + let uu___3 = FStarC_Tactics_V1_Builtins.inspect tm in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -4071,12 +4075,12 @@ let (is_equality_for_term : fun uu___5 -> (fun uu___5 -> match uu___4 with - | FStar_Reflection_V1_Data.Tv_Var bv -> + | FStarC_Reflection_V1_Data.Tv_Var bv -> Obj.magic (Obj.repr (fun tm' -> let uu___6 = - FStar_Tactics_V1_Builtins.inspect + FStarC_Tactics_V1_Builtins.inspect tm' in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -4100,7 +4104,7 @@ let (is_equality_for_term : FStar_Tactics_Effect.lift_div_tac (fun uu___8 -> match uu___7 with - | FStar_Reflection_V1_Data.Tv_Var + | FStarC_Reflection_V1_Data.Tv_Var bv' -> FStar_InteractiveHelpers_Base.bv_eq bv bv' @@ -4159,7 +4163,7 @@ let (is_equality_for_term : let uu___6 = let uu___7 = let uu___8 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string l in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -4183,7 +4187,7 @@ let (is_equality_for_term : (fun uu___9 -> let uu___10 = let uu___11 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string r in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -4448,9 +4452,9 @@ let (is_equality_for_term : uu___4))) uu___3))) uu___1) let (find_subequality : Prims.bool -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.term FStar_Pervasives_Native.option, + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.term FStar_Pervasives_Native.option, unit) FStar_Tactics_Effect.tac_repr) = fun dbg -> @@ -4460,7 +4464,7 @@ let (find_subequality : let uu___1 = let uu___2 = let uu___3 = - let uu___4 = FStar_Tactics_V1_Builtins.term_to_string tm in + let uu___4 = FStarC_Tactics_V1_Builtins.term_to_string tm in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -4479,7 +4483,7 @@ let (find_subequality : (fun uu___5 -> let uu___6 = let uu___7 = - FStar_Tactics_V1_Builtins.term_to_string p in + FStarC_Tactics_V1_Builtins.term_to_string p in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -4606,7 +4610,7 @@ let (find_subequality : let uu___4 = let uu___5 = FStar_InteractiveHelpers_Base.list_to_string - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string conjuncts in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -4681,15 +4685,15 @@ let (find_subequality : let (find_equality_from_post : Prims.bool -> FStar_InteractiveHelpers_Base.genv -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.bv -> - FStar_Reflection_Types.typ -> - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.bv -> + FStarC_Reflection_Types.typ -> + FStarC_Reflection_Types.term -> FStar_InteractiveHelpers_Effectful.effect_info -> - FStar_Reflection_V1_Data.term_view Prims.list -> - FStar_Reflection_V1_Data.term_view Prims.list -> + FStarC_Reflection_V1_Data.term_view Prims.list -> + FStarC_Reflection_V1_Data.term_view Prims.list -> ((FStar_InteractiveHelpers_Base.genv * - FStar_Reflection_Types.term + FStarC_Reflection_Types.term FStar_Pervasives_Native.option), unit) FStar_Tactics_Effect.tac_repr) = @@ -4784,7 +4788,7 @@ let (find_equality_from_post : let uu___7 = let uu___8 = FStar_InteractiveHelpers_Base.option_to_string - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string post_prop in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -4919,12 +4923,12 @@ let (find_equality_from_post : let rec (find_context_equality_aux : Prims.bool -> FStar_InteractiveHelpers_Base.genv -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.bv FStar_Pervasives_Native.option -> - FStar_Reflection_V1_Data.term_view Prims.list -> - FStar_Reflection_V1_Data.term_view Prims.list -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.bv FStar_Pervasives_Native.option -> + FStarC_Reflection_V1_Data.term_view Prims.list -> + FStarC_Reflection_V1_Data.term_view Prims.list -> ((FStar_InteractiveHelpers_Base.genv * - FStar_Reflection_Types.term FStar_Pervasives_Native.option), + FStarC_Reflection_Types.term FStar_Pervasives_Native.option), unit) FStar_Tactics_Effect.tac_repr) = fun uu___5 -> @@ -4954,7 +4958,7 @@ let rec (find_context_equality_aux : let uu___2 = let uu___3 = let uu___4 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string tm in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -4980,7 +4984,7 @@ let rec (find_context_equality_aux : let uu___7 = let uu___8 = let uu___9 = - FStar_Tactics_V1_Builtins.pack + FStarC_Tactics_V1_Builtins.pack tv in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -5005,7 +5009,7 @@ let rec (find_context_equality_aux : (fun uu___10 -> Obj.magic - (FStar_Tactics_V1_Builtins.term_to_string + (FStarC_Tactics_V1_Builtins.term_to_string uu___10)) uu___10) in FStar_Tactics_Effect.tac_bind @@ -5174,7 +5178,7 @@ let rec (find_context_equality_aux : (fun uu___1 -> (fun uu___1 -> match tv with - | FStar_Reflection_V1_Data.Tv_Let + | FStarC_Reflection_V1_Data.Tv_Let (uu___2, uu___3, bv', ty, def, uu___4) -> @@ -5328,8 +5332,8 @@ let rec (find_context_equality_aux : (Obj.repr (let uu___11 = - FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Var + FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Var bv') in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -5434,11 +5438,11 @@ let rec (find_context_equality_aux : let (find_context_equality : Prims.bool -> FStar_InteractiveHelpers_Base.genv -> - FStar_Reflection_Types.term -> - FStar_Reflection_V1_Data.term_view Prims.list -> - FStar_Reflection_V1_Data.term_view Prims.list -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_V1_Data.term_view Prims.list -> + FStarC_Reflection_V1_Data.term_view Prims.list -> ((FStar_InteractiveHelpers_Base.genv * - FStar_Reflection_Types.term FStar_Pervasives_Native.option), + FStarC_Reflection_Types.term FStar_Pervasives_Native.option), unit) FStar_Tactics_Effect.tac_repr) = fun dbg -> @@ -5447,7 +5451,7 @@ let (find_context_equality : fun parents -> fun children -> let uu___ = - let uu___1 = FStar_Tactics_V1_Builtins.inspect tm in + let uu___1 = FStarC_Tactics_V1_Builtins.inspect tm in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -5466,7 +5470,7 @@ let (find_context_equality : FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> match uu___2 with - | FStar_Reflection_V1_Data.Tv_Var bv -> + | FStarC_Reflection_V1_Data.Tv_Var bv -> FStar_Pervasives_Native.Some bv | uu___4 -> FStar_Pervasives_Native.None)) in FStar_Tactics_Effect.tac_bind @@ -5490,10 +5494,10 @@ let (find_context_equality : children)) uu___1) let rec (replace_term_in : Prims.bool -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) = fun uu___3 -> fun uu___2 -> @@ -5512,7 +5516,7 @@ let rec (replace_term_in : else Obj.magic (Obj.repr - (let uu___1 = FStar_Tactics_V1_Builtins.inspect tm in + (let uu___1 = FStarC_Tactics_V1_Builtins.inspect tm in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -5531,25 +5535,25 @@ let rec (replace_term_in : (fun uu___2 -> (fun uu___2 -> match uu___2 with - | FStar_Reflection_V1_Data.Tv_Var uu___3 + | FStarC_Reflection_V1_Data.Tv_Var uu___3 -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> tm))) - | FStar_Reflection_V1_Data.Tv_BVar uu___3 + | FStarC_Reflection_V1_Data.Tv_BVar uu___3 -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> tm))) - | FStar_Reflection_V1_Data.Tv_FVar uu___3 + | FStarC_Reflection_V1_Data.Tv_FVar uu___3 -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> tm))) - | FStar_Reflection_V1_Data.Tv_App + | FStarC_Reflection_V1_Data.Tv_App (hd, (a, qual)) -> Obj.magic (Obj.repr @@ -5601,14 +5605,14 @@ let rec (replace_term_in : (fun uu___5 -> (fun hd' -> Obj.magic - (FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_App + (FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_App (hd', (a', qual))))) uu___5))) uu___4))) - | FStar_Reflection_V1_Data.Tv_Abs + | FStarC_Reflection_V1_Data.Tv_Abs (br, body) -> Obj.magic (Obj.repr @@ -5636,23 +5640,23 @@ let rec (replace_term_in : (fun uu___4 -> (fun body' -> Obj.magic - (FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Abs + (FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Abs (br, body')))) uu___4))) - | FStar_Reflection_V1_Data.Tv_Arrow + | FStarC_Reflection_V1_Data.Tv_Arrow (br, c0) -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> tm))) - | FStar_Reflection_V1_Data.Tv_Type uu___3 + | FStarC_Reflection_V1_Data.Tv_Type uu___3 -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> tm))) - | FStar_Reflection_V1_Data.Tv_Refine + | FStarC_Reflection_V1_Data.Tv_Refine (bv, sort, ref) -> Obj.magic (Obj.repr @@ -5705,26 +5709,26 @@ let rec (replace_term_in : (fun uu___5 -> (fun ref' -> Obj.magic - (FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Refine + (FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Refine (bv, sort', ref')))) uu___5))) uu___4))) - | FStar_Reflection_V1_Data.Tv_Const uu___3 - -> + | FStarC_Reflection_V1_Data.Tv_Const + uu___3 -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> tm))) - | FStar_Reflection_V1_Data.Tv_Uvar + | FStarC_Reflection_V1_Data.Tv_Uvar (uu___3, uu___4) -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___5 -> tm))) - | FStar_Reflection_V1_Data.Tv_Let + | FStarC_Reflection_V1_Data.Tv_Let (recf, attrs, bv, ty, def, body) -> Obj.magic (Obj.repr @@ -5777,8 +5781,8 @@ let rec (replace_term_in : (fun uu___5 -> (fun body' -> Obj.magic - (FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Let + (FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Let (recf, attrs, bv, ty, @@ -5786,7 +5790,7 @@ let rec (replace_term_in : body')))) uu___5))) uu___4))) - | FStar_Reflection_V1_Data.Tv_Match + | FStarC_Reflection_V1_Data.Tv_Match (scrutinee, ret_opt, branches) -> Obj.magic (Obj.repr @@ -5935,15 +5939,15 @@ let rec (replace_term_in : branches' -> Obj.magic - (FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Match + (FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Match (scrutinee', ret_opt, branches')))) uu___6))) uu___5))) uu___4))) - | FStar_Reflection_V1_Data.Tv_AscribedT + | FStarC_Reflection_V1_Data.Tv_AscribedT (e, ty, tac, use_eq) -> Obj.magic (Obj.repr @@ -5995,14 +5999,14 @@ let rec (replace_term_in : (fun uu___5 -> (fun ty' -> Obj.magic - (FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_AscribedT + (FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_AscribedT (e', ty', tac, use_eq)))) uu___5))) uu___4))) - | FStar_Reflection_V1_Data.Tv_AscribedC + | FStarC_Reflection_V1_Data.Tv_AscribedC (e, c, tac, use_eq) -> Obj.magic (Obj.repr @@ -6030,8 +6034,8 @@ let rec (replace_term_in : (fun uu___4 -> (fun e' -> Obj.magic - (FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_AscribedC + (FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_AscribedC (e', c, tac, use_eq)))) uu___4))) @@ -6042,11 +6046,11 @@ let rec (replace_term_in : (fun uu___4 -> tm)))) uu___2)))) uu___3 uu___2 uu___1 uu___ let rec (strip_implicit_parameters : - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) = fun tm -> - let uu___ = FStar_Tactics_V1_Builtins.inspect tm in + let uu___ = FStarC_Tactics_V1_Builtins.inspect tm in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -6061,10 +6065,10 @@ let rec (strip_implicit_parameters : (fun uu___1 -> (fun uu___1 -> match uu___1 with - | FStar_Reflection_V1_Data.Tv_App (hd, (a, qualif)) -> + | FStarC_Reflection_V1_Data.Tv_App (hd, (a, qualif)) -> Obj.magic (Obj.repr - (if FStar_Reflection_V1_Data.uu___is_Q_Implicit qualif + (if FStarC_Reflection_V1_Data.uu___is_Q_Implicit qualif then Obj.repr (strip_implicit_parameters hd) else Obj.repr @@ -6077,14 +6081,14 @@ let rec (strip_implicit_parameters : uu___1) let (unfold_in_assert_or_assume : Prims.bool -> - FStar_Reflection_Types.term exploration_result -> + FStarC_Reflection_Types.term exploration_result -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun dbg -> fun ares -> let uu___ = let uu___1 = - let uu___2 = FStar_Tactics_V1_Builtins.term_to_string ares.res in + let uu___2 = FStarC_Tactics_V1_Builtins.term_to_string ares.res in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -6236,7 +6240,7 @@ let (unfold_in_assert_or_assume : let uu___5 = let uu___6 = let uu___7 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string ares.res in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -6404,7 +6408,7 @@ let (unfold_in_assert_or_assume : = let uu___17 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string l in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -6437,7 +6441,7 @@ let (unfold_in_assert_or_assume : = let uu___21 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string r in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -6468,7 +6472,7 @@ let (unfold_in_assert_or_assume : = let uu___24 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string res.res in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -6767,7 +6771,7 @@ let (unfold_in_assert_or_assume : = let uu___19 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string l in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -6800,7 +6804,7 @@ let (unfold_in_assert_or_assume : = let uu___23 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string r in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -6831,7 +6835,7 @@ let (unfold_in_assert_or_assume : = let uu___26 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string res.res in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -7186,7 +7190,7 @@ let (unfold_in_assert_or_assume : = let uu___11 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string subterm in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -7219,7 +7223,7 @@ let (unfold_in_assert_or_assume : = let uu___15 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string unf_res.res in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -7426,7 +7430,7 @@ let (unfold_in_assert_or_assume : uu___8 -> let uu___9 = - FStar_Tactics_V1_Builtins.inspect + FStarC_Tactics_V1_Builtins.inspect unf_res.res in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -7459,7 +7463,7 @@ let (unfold_in_assert_or_assume : match res_view with | - FStar_Reflection_V1_Data.Tv_FVar + FStarC_Reflection_V1_Data.Tv_FVar fv -> let uu___11 = @@ -7502,7 +7506,7 @@ let (unfold_in_assert_or_assume : uu___14 -> FStar_Reflection_V1_Derived.flatten_name - (FStar_Reflection_V1_Builtins.inspect_fv + (FStarC_Reflection_V1_Builtins.inspect_fv fv))) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -7531,7 +7535,7 @@ let (unfold_in_assert_or_assume : fname -> let uu___14 = - FStar_Tactics_V1_Builtins.norm_term_env + FStarC_Tactics_V1_Builtins.norm_term_env (ares.ge).FStar_InteractiveHelpers_Base.env [ FStar_Pervasives.delta_only @@ -7570,7 +7574,7 @@ let (unfold_in_assert_or_assume : = let uu___17 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string subterm' in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -7707,7 +7711,7 @@ let (unfold_in_assert_or_assume : match res_view with | - FStar_Reflection_V1_Data.Tv_Var + FStarC_Reflection_V1_Data.Tv_Var bv -> let uu___14 = @@ -7850,8 +7854,8 @@ let (unfold_in_assert_or_assume : -> FStar_Pervasives_Native.Some (bv, - (FStar_Reflection_V2_Builtins.pack_ln - FStar_Reflection_V2_Data.Tv_Unknown)))))) + (FStarC_Reflection_V2_Builtins.pack_ln + FStarC_Reflection_V2_Data.Tv_Unknown)))))) uu___15) | uu___14 @@ -7862,7 +7866,7 @@ let (unfold_in_assert_or_assume : = let uu___17 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string unf_res.res in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -8278,7 +8282,7 @@ let (unfold_in_assert_or_assume : uu___15 -> Obj.magic - (FStar_Tactics_V1_Builtins.inspect + (FStarC_Tactics_V1_Builtins.inspect uu___15)) uu___15) in FStar_Tactics_Effect.tac_bind @@ -8309,7 +8313,7 @@ let (unfold_in_assert_or_assume : match uu___14 with | - FStar_Reflection_V1_Data.Tv_FVar + FStarC_Reflection_V1_Data.Tv_FVar fv -> let uu___15 = @@ -8353,7 +8357,7 @@ let (unfold_in_assert_or_assume : uu___18 -> FStar_Reflection_V1_Derived.flatten_name - (FStar_Reflection_V1_Builtins.inspect_fv + (FStarC_Reflection_V1_Builtins.inspect_fv fv))) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -8382,7 +8386,7 @@ let (unfold_in_assert_or_assume : fname -> let uu___18 = - FStar_Tactics_V1_Builtins.norm_term_env + FStarC_Tactics_V1_Builtins.norm_term_env ge1.FStar_InteractiveHelpers_Base.env [ FStar_Pervasives.delta_only @@ -8421,7 +8425,7 @@ let (unfold_in_assert_or_assume : = let uu___21 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string subterm' in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -8523,7 +8527,7 @@ let (unfold_in_assert_or_assume : = let uu___18 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string unf_res.res in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -8713,7 +8717,7 @@ let (unfold_in_assert_or_assume : = let uu___18 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string final_assert1 in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -8968,16 +8972,17 @@ let (pp_unfold_in_assert_or_assume : | err -> Obj.magic (Obj.repr (FStar_Tactics_Effect.raise err))) uu___1) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.InteractiveHelpers.PostProcess.pp_unfold_in_assert_or_assume" (Prims.of_int (3)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_2 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_2 "FStar.InteractiveHelpers.PostProcess.pp_unfold_in_assert_or_assume (plugin)" - (FStar_Tactics_Native.from_tactic_2 + (FStarC_Tactics_Native.from_tactic_2 pp_unfold_in_assert_or_assume) - FStar_Syntax_Embeddings.e_bool FStar_Syntax_Embeddings.e_unit - FStar_Syntax_Embeddings.e_unit psc ncb us args) \ No newline at end of file + FStarC_Syntax_Embeddings.e_bool + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit psc ncb us args) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_Propositions.ml b/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_Propositions.ml index 922154424c7..eed21506c41 100644 --- a/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_Propositions.ml +++ b/ocaml/fstar-lib/generated/FStar_InteractiveHelpers_Propositions.ml @@ -1,44 +1,44 @@ open Prims -type proposition = FStar_Reflection_Types.term +type proposition = FStarC_Reflection_Types.term let (term_eq : - FStar_Reflection_Types.term -> FStar_Reflection_Types.term -> Prims.bool) = - FStar_Reflection_TermEq_Simple.term_eq + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term -> Prims.bool) + = FStar_Reflection_TermEq_Simple.term_eq let (proposition_to_string : proposition -> (Prims.string, unit) FStar_Tactics_Effect.tac_repr) = - fun p -> FStar_Tactics_V1_Builtins.term_to_string p + fun p -> FStarC_Tactics_V1_Builtins.term_to_string p let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.InteractiveHelpers.Propositions.proposition_to_string" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.InteractiveHelpers.Propositions.proposition_to_string (plugin)" - (FStar_Tactics_Native.from_tactic_1 proposition_to_string) - FStar_Reflection_V2_Embeddings.e_term - FStar_Syntax_Embeddings.e_string psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 proposition_to_string) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Syntax_Embeddings.e_string psc ncb us args) type assertions = { pres: proposition Prims.list ; posts: proposition Prims.list } let rec __knot_e_assertions _ = - FStar_Syntax_Embeddings_Base.mk_extracted_embedding + FStarC_Syntax_Embeddings_Base.mk_extracted_embedding "FStar.InteractiveHelpers.Propositions.assertions" (fun tm_0 -> match tm_0 with | ("FStar.InteractiveHelpers.Propositions.Mkassertions", pres_2::posts_3::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_term) pres_2) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_term) pres_2) (fun pres_2 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_term) posts_3) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_term) posts_3) (fun posts_3 -> FStar_Pervasives_Native.Some { pres = pres_2; posts = posts_3 })) @@ -46,17 +46,17 @@ let rec __knot_e_assertions _ = (fun tm_4 -> match tm_4 with | { pres = pres_6; posts = posts_7;_} -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.InteractiveHelpers.Propositions.Mkassertions")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_term) pres_6), + [((FStarC_Syntax_Embeddings_Base.extracted_embed + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_term) pres_6), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_term) posts_7), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_term) posts_7), FStar_Pervasives_Native.None)]) let e_assertions = __knot_e_assertions () let (__proj__Mkassertions__item__pres : assertions -> proposition Prims.list) @@ -79,25 +79,25 @@ let (is_trivial_proposition : (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> term_eq - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "l_True"]))) p))) uu___ let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.InteractiveHelpers.Propositions.is_trivial_proposition" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.InteractiveHelpers.Propositions.is_trivial_proposition (plugin)" - (FStar_Tactics_Native.from_tactic_1 is_trivial_proposition) - FStar_Reflection_V2_Embeddings.e_term - FStar_Syntax_Embeddings.e_bool psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 is_trivial_proposition) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Syntax_Embeddings.e_bool psc ncb us args) let (simp_filter_proposition : - FStar_Reflection_Types.env -> + FStarC_Reflection_Types.env -> FStar_Pervasives.norm_step Prims.list -> proposition -> (proposition Prims.list, unit) FStar_Tactics_Effect.tac_repr) @@ -105,7 +105,7 @@ let (simp_filter_proposition : fun e -> fun steps -> fun p -> - let uu___ = FStar_Tactics_V1_Builtins.norm_term_env e steps p in + let uu___ = FStarC_Tactics_V1_Builtins.norm_term_env e steps p in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -124,31 +124,31 @@ let (simp_filter_proposition : (fun uu___1 -> if term_eq - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "l_True"]))) prop1 then [] else [prop1])) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.InteractiveHelpers.Propositions.simp_filter_proposition" (Prims.of_int (4)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_3 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_3 "FStar.InteractiveHelpers.Propositions.simp_filter_proposition (plugin)" - (FStar_Tactics_Native.from_tactic_3 simp_filter_proposition) - FStar_Reflection_V2_Embeddings.e_env - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_norm_step) - FStar_Reflection_V2_Embeddings.e_term - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_term) psc ncb us args) + (FStarC_Tactics_Native.from_tactic_3 simp_filter_proposition) + FStarC_Reflection_V2_Embeddings.e_env + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_norm_step) + FStarC_Reflection_V2_Embeddings.e_term + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_term) psc ncb us args) let (simp_filter_propositions : - FStar_Reflection_Types.env -> + FStarC_Reflection_Types.env -> FStar_Pervasives.norm_step Prims.list -> proposition Prims.list -> (proposition Prims.list, unit) FStar_Tactics_Effect.tac_repr) @@ -175,25 +175,25 @@ let (simp_filter_propositions : FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> FStar_List_Tot_Base.flatten uu___1)) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.InteractiveHelpers.Propositions.simp_filter_propositions" (Prims.of_int (4)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_3 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_3 "FStar.InteractiveHelpers.Propositions.simp_filter_propositions (plugin)" - (FStar_Tactics_Native.from_tactic_3 simp_filter_propositions) - FStar_Reflection_V2_Embeddings.e_env - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_norm_step) - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_term) - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_term) psc ncb us args) + (FStarC_Tactics_Native.from_tactic_3 simp_filter_propositions) + FStarC_Reflection_V2_Embeddings.e_env + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_norm_step) + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_term) + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_term) psc ncb us args) let (simp_filter_assertions : - FStar_Reflection_Types.env -> + FStarC_Reflection_Types.env -> FStar_Pervasives.norm_step Prims.list -> assertions -> (assertions, unit) FStar_Tactics_Effect.tac_repr) = @@ -237,17 +237,17 @@ let (simp_filter_assertions : FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> mk_assertions pres posts)))) uu___1) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.InteractiveHelpers.Propositions.simp_filter_assertions" (Prims.of_int (4)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_3 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_3 "FStar.InteractiveHelpers.Propositions.simp_filter_assertions (plugin)" - (FStar_Tactics_Native.from_tactic_3 simp_filter_assertions) - FStar_Reflection_V2_Embeddings.e_env - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_norm_step) e_assertions + (FStarC_Tactics_Native.from_tactic_3 simp_filter_assertions) + FStarC_Reflection_V2_Embeddings.e_env + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_norm_step) e_assertions e_assertions psc ncb us args) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Interactive_CompletionTable.ml b/ocaml/fstar-lib/generated/FStar_Interactive_CompletionTable.ml deleted file mode 100644 index dd8fc860206..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Interactive_CompletionTable.ml +++ /dev/null @@ -1,888 +0,0 @@ -open Prims -let (string_compare : Prims.string -> Prims.string -> Prims.int) = - fun s1 -> fun s2 -> FStar_Compiler_String.compare s1 s2 -type 'a heap = - | EmptyHeap - | Heap of ('a * 'a heap Prims.list) -let uu___is_EmptyHeap : 'a . 'a heap -> Prims.bool = - fun projectee -> match projectee with | EmptyHeap -> true | uu___ -> false -let uu___is_Heap : 'a . 'a heap -> Prims.bool = - fun projectee -> match projectee with | Heap _0 -> true | uu___ -> false -let __proj__Heap__item___0 : 'a . 'a heap -> ('a * 'a heap Prims.list) = - fun projectee -> match projectee with | Heap _0 -> _0 -let heap_merge : - 'uuuuu . - ('uuuuu -> 'uuuuu -> Prims.int) -> - 'uuuuu heap -> 'uuuuu heap -> 'uuuuu heap - = - fun cmp -> - fun h1 -> - fun h2 -> - match (h1, h2) with - | (EmptyHeap, h) -> h - | (h, EmptyHeap) -> h - | (Heap (v1, hh1), Heap (v2, hh2)) -> - let uu___ = let uu___1 = cmp v1 v2 in uu___1 < Prims.int_zero in - if uu___ then Heap (v1, (h2 :: hh1)) else Heap (v2, (h1 :: hh2)) -let heap_insert : - 'uuuuu . - ('uuuuu -> 'uuuuu -> Prims.int) -> 'uuuuu heap -> 'uuuuu -> 'uuuuu heap - = fun cmp -> fun h -> fun v -> heap_merge cmp (Heap (v, [])) h -let rec heap_merge_pairs : - 'uuuuu . - ('uuuuu -> 'uuuuu -> Prims.int) -> 'uuuuu heap Prims.list -> 'uuuuu heap - = - fun cmp -> - fun uu___ -> - match uu___ with - | [] -> EmptyHeap - | h::[] -> h - | h1::h2::hh -> - let uu___1 = heap_merge cmp h1 h2 in - let uu___2 = heap_merge_pairs cmp hh in - heap_merge cmp uu___1 uu___2 -let heap_peek : 'uuuuu . 'uuuuu heap -> 'uuuuu FStar_Pervasives_Native.option - = - fun uu___ -> - match uu___ with - | EmptyHeap -> FStar_Pervasives_Native.None - | Heap (v, uu___1) -> FStar_Pervasives_Native.Some v -let heap_pop : - 'uuuuu . - ('uuuuu -> 'uuuuu -> Prims.int) -> - 'uuuuu heap -> ('uuuuu * 'uuuuu heap) FStar_Pervasives_Native.option - = - fun cmp -> - fun uu___ -> - match uu___ with - | EmptyHeap -> FStar_Pervasives_Native.None - | Heap (v, hh) -> - let uu___1 = let uu___2 = heap_merge_pairs cmp hh in (v, uu___2) in - FStar_Pervasives_Native.Some uu___1 -let heap_from_list : - 'uuuuu . - ('uuuuu -> 'uuuuu -> Prims.int) -> 'uuuuu Prims.list -> 'uuuuu heap - = - fun cmp -> - fun values -> - FStar_Compiler_List.fold_left (heap_insert cmp) EmptyHeap values -let push_nodup : - 'uuuuu . - ('uuuuu -> Prims.string) -> - 'uuuuu -> 'uuuuu Prims.list -> 'uuuuu Prims.list - = - fun key_fn -> - fun x -> - fun uu___ -> - match uu___ with - | [] -> [x] - | h::t -> - let uu___1 = - let uu___2 = - let uu___3 = key_fn x in - let uu___4 = key_fn h in string_compare uu___3 uu___4 in - uu___2 = Prims.int_zero in - if uu___1 then h :: t else x :: h :: t -let rec add_priorities : - 'uuuuu . - Prims.int -> - (Prims.int * 'uuuuu) Prims.list -> - 'uuuuu Prims.list -> (Prims.int * 'uuuuu) Prims.list - = - fun n -> - fun acc -> - fun uu___ -> - match uu___ with - | [] -> acc - | h::t -> add_priorities (n + Prims.int_one) ((n, h) :: acc) t -let merge_increasing_lists_rev : - 'a . ('a -> Prims.string) -> 'a Prims.list Prims.list -> 'a Prims.list = - fun key_fn -> - fun lists -> - let cmp v1 v2 = - match (v1, v2) with - | ((uu___, []), uu___1) -> failwith "impossible" - | (uu___, (uu___1, [])) -> failwith "impossible" - | ((pr1, h1::uu___), (pr2, h2::uu___1)) -> - let cmp_h = - let uu___2 = key_fn h1 in - let uu___3 = key_fn h2 in string_compare uu___2 uu___3 in - if cmp_h <> Prims.int_zero then cmp_h else pr1 - pr2 in - let rec aux lists1 acc = - let uu___ = heap_pop cmp lists1 in - match uu___ with - | FStar_Pervasives_Native.None -> acc - | FStar_Pervasives_Native.Some ((pr, []), uu___1) -> - failwith "impossible" - | FStar_Pervasives_Native.Some ((pr, v::[]), lists2) -> - let uu___1 = push_nodup key_fn v acc in aux lists2 uu___1 - | FStar_Pervasives_Native.Some ((pr, v::tl), lists2) -> - let uu___1 = heap_insert cmp lists2 (pr, tl) in - let uu___2 = push_nodup key_fn v acc in aux uu___1 uu___2 in - let lists1 = FStar_Compiler_List.filter (fun x -> x <> []) lists in - match lists1 with - | [] -> [] - | l::[] -> FStar_Compiler_List.rev l - | uu___ -> - let lists2 = add_priorities Prims.int_zero [] lists1 in - let uu___1 = heap_from_list cmp lists2 in aux uu___1 [] -type 'a btree = - | StrEmpty - | StrBranch of (Prims.string * 'a * 'a btree * 'a btree) -let uu___is_StrEmpty : 'a . 'a btree -> Prims.bool = - fun projectee -> match projectee with | StrEmpty -> true | uu___ -> false -let uu___is_StrBranch : 'a . 'a btree -> Prims.bool = - fun projectee -> - match projectee with | StrBranch _0 -> true | uu___ -> false -let __proj__StrBranch__item___0 : - 'a . 'a btree -> (Prims.string * 'a * 'a btree * 'a btree) = - fun projectee -> match projectee with | StrBranch _0 -> _0 -let rec btree_to_list_rev : - 'a . - 'a btree -> - (Prims.string * 'a) Prims.list -> (Prims.string * 'a) Prims.list - = - fun btree1 -> - fun acc -> - match btree1 with - | StrEmpty -> acc - | StrBranch (key, value, lbt, rbt) -> - let uu___ = - let uu___1 = btree_to_list_rev lbt acc in (key, value) :: uu___1 in - btree_to_list_rev rbt uu___ -let rec btree_from_list : - 'a . - (Prims.string * 'a) Prims.list -> - Prims.int -> ('a btree * (Prims.string * 'a) Prims.list) - = - fun nodes -> - fun size -> - if size = Prims.int_zero - then (StrEmpty, nodes) - else - (let lbt_size = size / (Prims.of_int (2)) in - let rbt_size = (size - lbt_size) - Prims.int_one in - let uu___1 = btree_from_list nodes lbt_size in - match uu___1 with - | (lbt, nodes_left) -> - (match nodes_left with - | [] -> failwith "Invalid size passed to btree_from_list" - | (k, v)::nodes_left1 -> - let uu___2 = btree_from_list nodes_left1 rbt_size in - (match uu___2 with - | (rbt, nodes_left2) -> - ((StrBranch (k, v, lbt, rbt)), nodes_left2)))) -let rec btree_insert_replace : - 'a . 'a btree -> Prims.string -> 'a -> 'a btree = - fun bt -> - fun k -> - fun v -> - match bt with - | StrEmpty -> StrBranch (k, v, StrEmpty, StrEmpty) - | StrBranch (k', v', lbt, rbt) -> - let cmp = string_compare k k' in - if cmp < Prims.int_zero - then - let uu___ = - let uu___1 = btree_insert_replace lbt k v in - (k', v', uu___1, rbt) in - StrBranch uu___ - else - if cmp > Prims.int_zero - then - (let uu___1 = - let uu___2 = btree_insert_replace rbt k v in - (k', v', lbt, uu___2) in - StrBranch uu___1) - else StrBranch (k', v, lbt, rbt) -let rec btree_find_exact : - 'a . 'a btree -> Prims.string -> 'a FStar_Pervasives_Native.option = - fun bt -> - fun k -> - match bt with - | StrEmpty -> FStar_Pervasives_Native.None - | StrBranch (k', v, lbt, rbt) -> - let cmp = string_compare k k' in - if cmp < Prims.int_zero - then btree_find_exact lbt k - else - if cmp > Prims.int_zero - then btree_find_exact rbt k - else FStar_Pervasives_Native.Some v -let rec btree_extract_min : - 'a . - 'a btree -> (Prims.string * 'a * 'a btree) FStar_Pervasives_Native.option - = - fun bt -> - match bt with - | StrEmpty -> FStar_Pervasives_Native.None - | StrBranch (k, v, StrEmpty, rbt) -> - FStar_Pervasives_Native.Some (k, v, rbt) - | StrBranch (uu___, uu___1, lbt, uu___2) -> btree_extract_min lbt -let rec btree_remove : 'a . 'a btree -> Prims.string -> 'a btree = - fun bt -> - fun k -> - match bt with - | StrEmpty -> StrEmpty - | StrBranch (k', v, lbt, rbt) -> - let cmp = string_compare k k' in - if cmp < Prims.int_zero - then - let uu___ = - let uu___1 = btree_remove lbt k in (k', v, uu___1, rbt) in - StrBranch uu___ - else - if cmp > Prims.int_zero - then - (let uu___1 = - let uu___2 = btree_remove rbt k in (k', v, lbt, uu___2) in - StrBranch uu___1) - else - (match lbt with - | StrEmpty -> bt - | uu___2 -> - let uu___3 = btree_extract_min rbt in - (match uu___3 with - | FStar_Pervasives_Native.None -> lbt - | FStar_Pervasives_Native.Some - (rbt_min_k, rbt_min_v, rbt') -> - StrBranch (rbt_min_k, rbt_min_v, lbt, rbt'))) -type prefix_match = - { - prefix: Prims.string FStar_Pervasives_Native.option ; - completion: Prims.string } -let (__proj__Mkprefix_match__item__prefix : - prefix_match -> Prims.string FStar_Pervasives_Native.option) = - fun projectee -> match projectee with | { prefix; completion;_} -> prefix -let (__proj__Mkprefix_match__item__completion : prefix_match -> Prims.string) - = - fun projectee -> - match projectee with | { prefix; completion;_} -> completion -type path_elem = { - imports: Prims.string Prims.list ; - segment: prefix_match } -let (__proj__Mkpath_elem__item__imports : - path_elem -> Prims.string Prims.list) = - fun projectee -> match projectee with | { imports; segment;_} -> imports -let (__proj__Mkpath_elem__item__segment : path_elem -> prefix_match) = - fun projectee -> match projectee with | { imports; segment;_} -> segment -type path = path_elem Prims.list -let (matched_prefix_of_path_elem : - path_elem -> Prims.string FStar_Pervasives_Native.option) = - fun elem -> (elem.segment).prefix -type query = Prims.string Prims.list -type ns_info = { - ns_name: Prims.string ; - ns_loaded: Prims.bool } -let (__proj__Mkns_info__item__ns_name : ns_info -> Prims.string) = - fun projectee -> match projectee with | { ns_name; ns_loaded;_} -> ns_name -let (__proj__Mkns_info__item__ns_loaded : ns_info -> Prims.bool) = - fun projectee -> - match projectee with | { ns_name; ns_loaded;_} -> ns_loaded -type mod_info = - { - mod_name: Prims.string ; - mod_path: Prims.string ; - mod_loaded: Prims.bool } -let (__proj__Mkmod_info__item__mod_name : mod_info -> Prims.string) = - fun projectee -> - match projectee with | { mod_name; mod_path; mod_loaded;_} -> mod_name -let (__proj__Mkmod_info__item__mod_path : mod_info -> Prims.string) = - fun projectee -> - match projectee with | { mod_name; mod_path; mod_loaded;_} -> mod_path -let (__proj__Mkmod_info__item__mod_loaded : mod_info -> Prims.bool) = - fun projectee -> - match projectee with | { mod_name; mod_path; mod_loaded;_} -> mod_loaded -let (mk_path_el : Prims.string Prims.list -> prefix_match -> path_elem) = - fun imports -> fun segment -> { imports; segment } -let btree_find_prefix : - 'a . 'a btree -> Prims.string -> (prefix_match * 'a) Prims.list = - fun bt -> - fun prefix -> - let rec aux bt1 prefix1 acc = - match bt1 with - | StrEmpty -> acc - | StrBranch (k, v, lbt, rbt) -> - let cmp = string_compare k prefix1 in - let include_middle = FStar_Compiler_Util.starts_with k prefix1 in - let explore_right = (cmp <= Prims.int_zero) || include_middle in - let explore_left = cmp > Prims.int_zero in - let matches = if explore_right then aux rbt prefix1 acc else acc in - let matches1 = - if include_middle - then - ({ - prefix = (FStar_Pervasives_Native.Some prefix1); - completion = k - }, v) - :: matches - else matches in - let matches2 = - if explore_left then aux lbt prefix1 matches1 else matches1 in - matches2 in - aux bt prefix [] -let rec btree_fold : - 'a 'b . 'a btree -> (Prims.string -> 'a -> 'b -> 'b) -> 'b -> 'b = - fun bt -> - fun f -> - fun acc -> - match bt with - | StrEmpty -> acc - | StrBranch (k, v, lbt, rbt) -> - let uu___ = let uu___1 = btree_fold rbt f acc in f k v uu___1 in - btree_fold lbt f uu___ -let (query_to_string : Prims.string Prims.list -> Prims.string) = - fun q -> FStar_Compiler_String.concat "." q -type 'a name_collection = - | Names of 'a btree - | ImportedNames of (Prims.string * 'a name_collection Prims.list) -let uu___is_Names : 'a . 'a name_collection -> Prims.bool = - fun projectee -> match projectee with | Names _0 -> true | uu___ -> false -let __proj__Names__item___0 : 'a . 'a name_collection -> 'a btree = - fun projectee -> match projectee with | Names _0 -> _0 -let uu___is_ImportedNames : 'a . 'a name_collection -> Prims.bool = - fun projectee -> - match projectee with | ImportedNames _0 -> true | uu___ -> false -let __proj__ImportedNames__item___0 : - 'a . 'a name_collection -> (Prims.string * 'a name_collection Prims.list) = - fun projectee -> match projectee with | ImportedNames _0 -> _0 -type 'a names = 'a name_collection Prims.list -type 'a trie = { - bindings: 'a names ; - namespaces: 'a trie names } -let __proj__Mktrie__item__bindings : 'a . 'a trie -> 'a names = - fun projectee -> - match projectee with | { bindings; namespaces;_} -> bindings -let __proj__Mktrie__item__namespaces : 'a . 'a trie -> 'a trie names = - fun projectee -> - match projectee with | { bindings; namespaces;_} -> namespaces -let trie_empty : 'uuuuu . unit -> 'uuuuu trie = - fun uu___ -> { bindings = []; namespaces = [] } -let rec names_find_exact : - 'a . 'a names -> Prims.string -> 'a FStar_Pervasives_Native.option = - fun names1 -> - fun ns -> - let uu___ = - match names1 with - | [] -> (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) - | (Names bt)::names2 -> - let uu___1 = btree_find_exact bt ns in - (uu___1, (FStar_Pervasives_Native.Some names2)) - | (ImportedNames (uu___1, names2))::more_names -> - let uu___2 = names_find_exact names2 ns in - (uu___2, (FStar_Pervasives_Native.Some more_names)) in - match uu___ with - | (result, names2) -> - (match (result, names2) with - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.Some - scopes) -> names_find_exact scopes ns - | uu___1 -> result) -let rec trie_descend_exact : - 'a . 'a trie -> query -> 'a trie FStar_Pervasives_Native.option = - fun tr -> - fun query1 -> - match query1 with - | [] -> FStar_Pervasives_Native.Some tr - | ns::query2 -> - let uu___ = names_find_exact tr.namespaces ns in - FStar_Compiler_Util.bind_opt uu___ - (fun scope -> trie_descend_exact scope query2) -let rec trie_find_exact : - 'a . 'a trie -> query -> 'a FStar_Pervasives_Native.option = - fun tr -> - fun query1 -> - match query1 with - | [] -> failwith "Empty query in trie_find_exact" - | name::[] -> names_find_exact tr.bindings name - | ns::query2 -> - let uu___ = names_find_exact tr.namespaces ns in - FStar_Compiler_Util.bind_opt uu___ - (fun scope -> trie_find_exact scope query2) -let names_insert : 'a . 'a names -> Prims.string -> 'a -> 'a names = - fun name_collections -> - fun id -> - fun v -> - let uu___ = - match name_collections with - | (Names bt)::tl -> (bt, tl) - | uu___1 -> (StrEmpty, name_collections) in - match uu___ with - | (bt, name_collections1) -> - let uu___1 = - let uu___2 = btree_insert_replace bt id v in Names uu___2 in - uu___1 :: name_collections1 -let rec namespaces_mutate : - 'a . - 'a trie names -> - Prims.string -> - query -> - query -> - ('a trie -> - Prims.string -> query -> query -> 'a trie names -> 'a trie) - -> ('a trie -> query -> 'a trie) -> 'a trie names - = - fun namespaces -> - fun ns -> - fun q -> - fun rev_acc -> - fun mut_node -> - fun mut_leaf -> - let trie1 = - let uu___ = names_find_exact namespaces ns in - FStar_Compiler_Util.dflt (trie_empty ()) uu___ in - let uu___ = trie_mutate trie1 q rev_acc mut_node mut_leaf in - names_insert namespaces ns uu___ -and trie_mutate : - 'a . - 'a trie -> - query -> - query -> - ('a trie -> - Prims.string -> query -> query -> 'a trie names -> 'a trie) - -> ('a trie -> query -> 'a trie) -> 'a trie - = - fun tr -> - fun q -> - fun rev_acc -> - fun mut_node -> - fun mut_leaf -> - match q with - | [] -> mut_leaf tr rev_acc - | id::q1 -> - let ns' = - namespaces_mutate tr.namespaces id q1 (id :: rev_acc) - mut_node mut_leaf in - mut_node tr id q1 rev_acc ns' -let trie_mutate_leaf : - 'a . 'a trie -> query -> ('a trie -> query -> 'a trie) -> 'a trie = - fun tr -> - fun query1 -> - trie_mutate tr query1 [] - (fun tr1 -> - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun namespaces -> { bindings = (tr1.bindings); namespaces }) -let trie_insert : 'a . 'a trie -> query -> Prims.string -> 'a -> 'a trie = - fun tr -> - fun ns_query -> - fun id -> - fun v -> - trie_mutate_leaf tr ns_query - (fun tr1 -> - fun uu___ -> - let uu___1 = names_insert tr1.bindings id v in - { bindings = uu___1; namespaces = (tr1.namespaces) }) -let trie_import : - 'a . - 'a trie -> - query -> - query -> ('a trie -> 'a trie -> Prims.string -> 'a trie) -> 'a trie - = - fun tr -> - fun host_query -> - fun included_query -> - fun mutator -> - let label = query_to_string included_query in - let included_trie = - let uu___ = trie_descend_exact tr included_query in - FStar_Compiler_Util.dflt (trie_empty ()) uu___ in - trie_mutate_leaf tr host_query - (fun tr1 -> fun uu___ -> mutator tr1 included_trie label) -let trie_include : 'a . 'a trie -> query -> query -> 'a trie = - fun tr -> - fun host_query -> - fun included_query -> - trie_import tr host_query included_query - (fun tr1 -> - fun inc -> - fun label -> - { - bindings = ((ImportedNames (label, (inc.bindings))) :: - (tr1.bindings)); - namespaces = (tr1.namespaces) - }) -let trie_open_namespace : 'a . 'a trie -> query -> query -> 'a trie = - fun tr -> - fun host_query -> - fun included_query -> - trie_import tr host_query included_query - (fun tr1 -> - fun inc -> - fun label -> - { - bindings = (tr1.bindings); - namespaces = ((ImportedNames (label, (inc.namespaces))) :: - (tr1.namespaces)) - }) -let trie_add_alias : - 'a . 'a trie -> Prims.string -> query -> query -> 'a trie = - fun tr -> - fun key -> - fun host_query -> - fun included_query -> - trie_import tr host_query included_query - (fun tr1 -> - fun inc -> - fun label -> - trie_mutate_leaf tr1 [key] - (fun _ignored_overwritten_trie -> - fun uu___ -> - { - bindings = - [ImportedNames (label, (inc.bindings))]; - namespaces = [] - })) -let names_revmap : - 'a 'b . - ('a btree -> 'b) -> 'a names -> (Prims.string Prims.list * 'b) Prims.list - = - fun fn -> - fun name_collections -> - let rec aux acc imports name_collections1 = - FStar_Compiler_List.fold_left - (fun acc1 -> - fun uu___ -> - match uu___ with - | Names bt -> - let uu___1 = let uu___2 = fn bt in (imports, uu___2) in - uu___1 :: acc1 - | ImportedNames (nm, name_collections2) -> - aux acc1 (nm :: imports) name_collections2) acc - name_collections1 in - aux [] [] name_collections -let btree_find_all : - 'a . - Prims.string FStar_Pervasives_Native.option -> - 'a btree -> (prefix_match * 'a) Prims.list - = - fun prefix -> - fun bt -> - btree_fold bt - (fun k -> - fun tr -> fun acc -> ({ prefix; completion = k }, tr) :: acc) [] -type name_search_term = - | NSTAll - | NSTNone - | NSTPrefix of Prims.string -let (uu___is_NSTAll : name_search_term -> Prims.bool) = - fun projectee -> match projectee with | NSTAll -> true | uu___ -> false -let (uu___is_NSTNone : name_search_term -> Prims.bool) = - fun projectee -> match projectee with | NSTNone -> true | uu___ -> false -let (uu___is_NSTPrefix : name_search_term -> Prims.bool) = - fun projectee -> - match projectee with | NSTPrefix _0 -> true | uu___ -> false -let (__proj__NSTPrefix__item___0 : name_search_term -> Prims.string) = - fun projectee -> match projectee with | NSTPrefix _0 -> _0 -let names_find_rev : - 'a . 'a names -> name_search_term -> (path_elem * 'a) Prims.list = - fun names1 -> - fun id -> - let matching_values_per_collection_with_imports = - match id with - | NSTNone -> [] - | NSTAll -> - names_revmap (btree_find_all FStar_Pervasives_Native.None) names1 - | NSTPrefix "" -> - names_revmap (btree_find_all (FStar_Pervasives_Native.Some "")) - names1 - | NSTPrefix id1 -> - names_revmap (fun bt -> btree_find_prefix bt id1) names1 in - let matching_values_per_collection = - FStar_Compiler_List.map - (fun uu___ -> - match uu___ with - | (imports, matches) -> - FStar_Compiler_List.map - (fun uu___1 -> - match uu___1 with - | (segment, v) -> ((mk_path_el imports segment), v)) - matches) matching_values_per_collection_with_imports in - merge_increasing_lists_rev - (fun uu___ -> - match uu___ with - | (path_el, uu___1) -> (path_el.segment).completion) - matching_values_per_collection -let rec trie_find_prefix' : - 'a . - 'a trie -> - path -> query -> (path * 'a) Prims.list -> (path * 'a) Prims.list - = - fun tr -> - fun path_acc -> - fun query1 -> - fun acc -> - let uu___ = - match query1 with - | [] -> (NSTAll, NSTAll, []) - | id::[] -> ((NSTPrefix id), (NSTPrefix id), []) - | ns::query2 -> ((NSTPrefix ns), NSTNone, query2) in - match uu___ with - | (ns_search_term, bindings_search_term, query2) -> - let matching_namespaces_rev = - names_find_rev tr.namespaces ns_search_term in - let acc_with_recursive_bindings = - FStar_Compiler_List.fold_left - (fun acc1 -> - fun uu___1 -> - match uu___1 with - | (path_el, trie1) -> - trie_find_prefix' trie1 (path_el :: path_acc) - query2 acc1) acc matching_namespaces_rev in - let matching_bindings_rev = - names_find_rev tr.bindings bindings_search_term in - FStar_Compiler_List.rev_map_onto - (fun uu___1 -> - match uu___1 with - | (path_el, v) -> - ((FStar_Compiler_List.rev (path_el :: path_acc)), v)) - matching_bindings_rev acc_with_recursive_bindings -let trie_find_prefix : 'a . 'a trie -> query -> (path * 'a) Prims.list = - fun tr -> fun query1 -> trie_find_prefix' tr [] query1 [] -let (mod_name : mod_info -> Prims.string) = fun md -> md.mod_name -type mod_symbol = - | Module of mod_info - | Namespace of ns_info -let (uu___is_Module : mod_symbol -> Prims.bool) = - fun projectee -> match projectee with | Module _0 -> true | uu___ -> false -let (__proj__Module__item___0 : mod_symbol -> mod_info) = - fun projectee -> match projectee with | Module _0 -> _0 -let (uu___is_Namespace : mod_symbol -> Prims.bool) = - fun projectee -> - match projectee with | Namespace _0 -> true | uu___ -> false -let (__proj__Namespace__item___0 : mod_symbol -> ns_info) = - fun projectee -> match projectee with | Namespace _0 -> _0 -type lid_symbol = FStar_Ident.lid -type symbol = - | ModOrNs of mod_symbol - | Lid of lid_symbol -let (uu___is_ModOrNs : symbol -> Prims.bool) = - fun projectee -> match projectee with | ModOrNs _0 -> true | uu___ -> false -let (__proj__ModOrNs__item___0 : symbol -> mod_symbol) = - fun projectee -> match projectee with | ModOrNs _0 -> _0 -let (uu___is_Lid : symbol -> Prims.bool) = - fun projectee -> match projectee with | Lid _0 -> true | uu___ -> false -let (__proj__Lid__item___0 : symbol -> lid_symbol) = - fun projectee -> match projectee with | Lid _0 -> _0 -type table = { - tbl_lids: lid_symbol trie ; - tbl_mods: mod_symbol trie } -let (__proj__Mktable__item__tbl_lids : table -> lid_symbol trie) = - fun projectee -> match projectee with | { tbl_lids; tbl_mods;_} -> tbl_lids -let (__proj__Mktable__item__tbl_mods : table -> mod_symbol trie) = - fun projectee -> match projectee with | { tbl_lids; tbl_mods;_} -> tbl_mods -let (empty : table) = - { tbl_lids = (trie_empty ()); tbl_mods = (trie_empty ()) } -let (insert : table -> query -> Prims.string -> lid_symbol -> table) = - fun tbl -> - fun host_query -> - fun id -> - fun c -> - let uu___ = trie_insert tbl.tbl_lids host_query id c in - { tbl_lids = uu___; tbl_mods = (tbl.tbl_mods) } -let (register_alias : table -> Prims.string -> query -> query -> table) = - fun tbl -> - fun key -> - fun host_query -> - fun included_query -> - let uu___ = - trie_add_alias tbl.tbl_lids key host_query included_query in - { tbl_lids = uu___; tbl_mods = (tbl.tbl_mods) } -let (register_include : table -> query -> query -> table) = - fun tbl -> - fun host_query -> - fun included_query -> - let uu___ = trie_include tbl.tbl_lids host_query included_query in - { tbl_lids = uu___; tbl_mods = (tbl.tbl_mods) } -let (register_open : table -> Prims.bool -> query -> query -> table) = - fun tbl -> - fun is_module -> - fun host_query -> - fun included_query -> - if is_module - then register_include tbl host_query included_query - else - (let uu___1 = - trie_open_namespace tbl.tbl_lids host_query included_query in - { tbl_lids = uu___1; tbl_mods = (tbl.tbl_mods) }) -let (register_module_path : - table -> Prims.bool -> Prims.string -> query -> table) = - fun tbl -> - fun loaded -> - fun path1 -> - fun mod_query -> - let ins_ns id bindings full_name loaded1 = - let uu___ = - let uu___1 = names_find_exact bindings id in (uu___1, loaded1) in - match uu___ with - | (FStar_Pervasives_Native.None, uu___1) -> - names_insert bindings id - (Namespace { ns_name = full_name; ns_loaded = loaded1 }) - | (FStar_Pervasives_Native.Some (Namespace - { ns_name = uu___1; ns_loaded = false;_}), true) -> - names_insert bindings id - (Namespace { ns_name = full_name; ns_loaded = loaded1 }) - | (FStar_Pervasives_Native.Some uu___1, uu___2) -> bindings in - let ins_mod id bindings full_name loaded1 = - names_insert bindings id - (Module - { - mod_name = full_name; - mod_path = path1; - mod_loaded = loaded1 - }) in - let name_of_revq query1 = - FStar_Compiler_String.concat "." (FStar_Compiler_List.rev query1) in - let ins id q revq bindings loaded1 = - let name = name_of_revq (id :: revq) in - match q with - | [] -> ins_mod id bindings name loaded1 - | uu___ -> ins_ns id bindings name loaded1 in - let uu___ = - trie_mutate tbl.tbl_mods mod_query [] - (fun tr -> - fun id -> - fun q -> - fun revq -> - fun namespaces -> - let uu___1 = ins id q revq tr.bindings loaded in - { bindings = uu___1; namespaces }) - (fun tr -> fun uu___1 -> tr) in - { tbl_lids = (tbl.tbl_lids); tbl_mods = uu___ } -let (string_of_path : path -> Prims.string) = - fun path1 -> - let uu___ = - FStar_Compiler_List.map (fun el -> (el.segment).completion) path1 in - FStar_Compiler_String.concat "." uu___ -let (match_length_of_path : path -> Prims.int) = - fun path1 -> - let uu___ = - FStar_Compiler_List.fold_left - (fun acc -> - fun elem -> - let uu___1 = acc in - match uu___1 with - | (acc_len, uu___2) -> - (match (elem.segment).prefix with - | FStar_Pervasives_Native.Some prefix -> - let completion_len = - FStar_Compiler_String.length - (elem.segment).completion in - (((acc_len + Prims.int_one) + completion_len), - (prefix, completion_len)) - | FStar_Pervasives_Native.None -> acc)) - (Prims.int_zero, ("", Prims.int_zero)) path1 in - match uu___ with - | (length, (last_prefix, last_completion_length)) -> - ((length - Prims.int_one) - last_completion_length) + - (FStar_Compiler_String.length last_prefix) -let (first_import_of_path : - path -> Prims.string FStar_Pervasives_Native.option) = - fun path1 -> - match path1 with - | [] -> FStar_Pervasives_Native.None - | { imports; segment = uu___;_}::uu___1 -> - FStar_Compiler_List.last_opt imports -let (alist_of_ns_info : - ns_info -> (Prims.string * FStar_Json.json) Prims.list) = - fun ns_info1 -> - [("name", (FStar_Json.JsonStr (ns_info1.ns_name))); - ("loaded", (FStar_Json.JsonBool (ns_info1.ns_loaded)))] -let (alist_of_mod_info : - mod_info -> (Prims.string * FStar_Json.json) Prims.list) = - fun mod_info1 -> - [("name", (FStar_Json.JsonStr (mod_info1.mod_name))); - ("path", (FStar_Json.JsonStr (mod_info1.mod_path))); - ("loaded", (FStar_Json.JsonBool (mod_info1.mod_loaded)))] -type completion_result = - { - completion_match_length: Prims.int ; - completion_candidate: Prims.string ; - completion_annotation: Prims.string } -let (__proj__Mkcompletion_result__item__completion_match_length : - completion_result -> Prims.int) = - fun projectee -> - match projectee with - | { completion_match_length; completion_candidate; - completion_annotation;_} -> completion_match_length -let (__proj__Mkcompletion_result__item__completion_candidate : - completion_result -> Prims.string) = - fun projectee -> - match projectee with - | { completion_match_length; completion_candidate; - completion_annotation;_} -> completion_candidate -let (__proj__Mkcompletion_result__item__completion_annotation : - completion_result -> Prims.string) = - fun projectee -> - match projectee with - | { completion_match_length; completion_candidate; - completion_annotation;_} -> completion_annotation -let (json_of_completion_result : completion_result -> FStar_Json.json) = - fun result -> - FStar_Json.JsonList - [FStar_Json.JsonInt (result.completion_match_length); - FStar_Json.JsonStr (result.completion_annotation); - FStar_Json.JsonStr (result.completion_candidate)] -let completion_result_of_lid : 'uuuuu . (path * 'uuuuu) -> completion_result - = - fun uu___ -> - match uu___ with - | (path1, _lid) -> - let uu___1 = match_length_of_path path1 in - let uu___2 = string_of_path path1 in - let uu___3 = - let uu___4 = first_import_of_path path1 in - FStar_Compiler_Util.dflt "" uu___4 in - { - completion_match_length = uu___1; - completion_candidate = uu___2; - completion_annotation = uu___3 - } -let (completion_result_of_mod : - Prims.string -> Prims.bool -> path -> completion_result) = - fun annot -> - fun loaded -> - fun path1 -> - let uu___ = match_length_of_path path1 in - let uu___1 = string_of_path path1 in - let uu___2 = - FStar_Compiler_Util.format1 (if loaded then " %s " else "(%s)") - annot in - { - completion_match_length = uu___; - completion_candidate = uu___1; - completion_annotation = uu___2 - } -let (completion_result_of_ns_or_mod : - (path * mod_symbol) -> completion_result) = - fun uu___ -> - match uu___ with - | (path1, symb) -> - (match symb with - | Module - { mod_name = uu___1; mod_path = uu___2; mod_loaded = loaded;_} - -> completion_result_of_mod "mod" loaded path1 - | Namespace { ns_name = uu___1; ns_loaded = loaded;_} -> - completion_result_of_mod "ns" loaded path1) -let (find_module_or_ns : - table -> query -> mod_symbol FStar_Pervasives_Native.option) = - fun tbl -> fun query1 -> trie_find_exact tbl.tbl_mods query1 -let (autocomplete_lid : table -> query -> completion_result Prims.list) = - fun tbl -> - fun query1 -> - let uu___ = trie_find_prefix tbl.tbl_lids query1 in - FStar_Compiler_List.map completion_result_of_lid uu___ -let (autocomplete_mod_or_ns : - table -> - query -> - ((path * mod_symbol) -> - (path * mod_symbol) FStar_Pervasives_Native.option) - -> completion_result Prims.list) - = - fun tbl -> - fun query1 -> - fun filter -> - let uu___ = - let uu___1 = trie_find_prefix tbl.tbl_mods query1 in - FStar_Compiler_List.filter_map filter uu___1 in - FStar_Compiler_List.map completion_result_of_ns_or_mod uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Interactive_Ide.ml b/ocaml/fstar-lib/generated/FStar_Interactive_Ide.ml deleted file mode 100644 index e070afeb214..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Interactive_Ide.ml +++ /dev/null @@ -1,3111 +0,0 @@ -open Prims -let (dbg : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "IDE" -let with_captured_errors' : - 'uuuuu . - FStar_TypeChecker_Env.env -> - FStar_Compiler_Util.sigint_handler -> - (FStar_TypeChecker_Env.env -> 'uuuuu FStar_Pervasives_Native.option) - -> 'uuuuu FStar_Pervasives_Native.option - = - fun env -> - fun sigint_handler -> - fun f -> - try - (fun uu___ -> - match () with - | () -> - FStar_Compiler_Util.with_sigint_handler sigint_handler - (fun uu___1 -> f env)) () - with - | FStar_Compiler_Effect.Failure msg -> - let msg1 = - Prims.strcat "ASSERTION FAILURE: " - (Prims.strcat msg - "\nF* may be in an inconsistent state.\nPlease file a bug report, ideally with a minimized version of the program that triggered the error.") in - (FStar_Errors.log_issue FStar_TypeChecker_Env.hasRange_env env - FStar_Errors_Codes.Error_IDEAssertionFailure () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic msg1); - FStar_Pervasives_Native.None) - | FStar_Compiler_Util.SigInt -> - (FStar_Compiler_Util.print_string "Interrupted"; - FStar_Pervasives_Native.None) - | FStar_Errors.Error (e, msg, r, ctx) -> - (FStar_TypeChecker_Err.add_errors env [(e, msg, r, ctx)]; - FStar_Pervasives_Native.None) - | FStar_Errors.Stop -> FStar_Pervasives_Native.None -let with_captured_errors : - 'uuuuu . - FStar_TypeChecker_Env.env -> - FStar_Compiler_Util.sigint_handler -> - (FStar_TypeChecker_Env.env -> 'uuuuu FStar_Pervasives_Native.option) - -> 'uuuuu FStar_Pervasives_Native.option - = - fun env -> - fun sigint_handler -> - fun f -> - let uu___ = FStar_Options.trace_error () in - if uu___ then f env else with_captured_errors' env sigint_handler f -type env_t = FStar_TypeChecker_Env.env -let (repl_current_qid : - Prims.string FStar_Pervasives_Native.option FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None -let (nothing_left_to_pop : - FStar_Interactive_Ide_Types.repl_state -> Prims.bool) = - fun st -> - let uu___ = - let uu___1 = - FStar_Compiler_Effect.op_Bang FStar_Interactive_PushHelper.repl_stack in - FStar_Compiler_List.length uu___1 in - uu___ = - (FStar_Compiler_List.length - st.FStar_Interactive_Ide_Types.repl_deps_stack) -let (run_repl_transaction : - FStar_Interactive_Ide_Types.repl_state -> - FStar_Interactive_Ide_Types.push_kind FStar_Pervasives_Native.option -> - Prims.bool -> - FStar_Interactive_Ide_Types.repl_task -> - (Prims.bool * FStar_Interactive_Ide_Types.repl_state)) - = - fun st -> - fun push_kind -> - fun must_rollback -> - fun task -> - let st1 = - FStar_Interactive_PushHelper.push_repl "run_repl_transaction" - push_kind task st in - let uu___ = - FStar_Interactive_PushHelper.track_name_changes - st1.FStar_Interactive_Ide_Types.repl_env in - match uu___ with - | (env, finish_name_tracking) -> - let check_success uu___1 = - (let uu___2 = FStar_Errors.get_err_count () in - uu___2 = Prims.int_zero) && - (Prims.op_Negation must_rollback) in - let uu___1 = - let uu___2 = - with_captured_errors env FStar_Compiler_Util.sigint_raise - (fun env1 -> - let uu___3 = - FStar_Interactive_PushHelper.run_repl_task - st1.FStar_Interactive_Ide_Types.repl_curmod env1 - task st1.FStar_Interactive_Ide_Types.repl_lang in - FStar_Pervasives_Native.Some uu___3) in - match uu___2 with - | FStar_Pervasives_Native.Some (curmod, env1, lds) when - check_success () -> (curmod, env1, true, lds) - | uu___3 -> - ((st1.FStar_Interactive_Ide_Types.repl_curmod), env, - false, []) in - (match uu___1 with - | (curmod, env1, success, lds) -> - let uu___2 = finish_name_tracking env1 in - (match uu___2 with - | (env2, name_events) -> - let st2 = - if success - then - let st3 = - { - FStar_Interactive_Ide_Types.repl_line = - (st1.FStar_Interactive_Ide_Types.repl_line); - FStar_Interactive_Ide_Types.repl_column = - (st1.FStar_Interactive_Ide_Types.repl_column); - FStar_Interactive_Ide_Types.repl_fname = - (st1.FStar_Interactive_Ide_Types.repl_fname); - FStar_Interactive_Ide_Types.repl_deps_stack = - (st1.FStar_Interactive_Ide_Types.repl_deps_stack); - FStar_Interactive_Ide_Types.repl_curmod = - curmod; - FStar_Interactive_Ide_Types.repl_env = env2; - FStar_Interactive_Ide_Types.repl_stdin = - (st1.FStar_Interactive_Ide_Types.repl_stdin); - FStar_Interactive_Ide_Types.repl_names = - (st1.FStar_Interactive_Ide_Types.repl_names); - FStar_Interactive_Ide_Types.repl_buffered_input_queries - = - (st1.FStar_Interactive_Ide_Types.repl_buffered_input_queries); - FStar_Interactive_Ide_Types.repl_lang = - (FStar_Compiler_List.op_At - (FStar_Compiler_List.rev lds) - st1.FStar_Interactive_Ide_Types.repl_lang) - } in - FStar_Interactive_PushHelper.commit_name_tracking - st3 name_events - else - FStar_Interactive_PushHelper.pop_repl - "run_repl_transaction" st1 in - (success, st2))) -let (run_repl_ld_transactions : - FStar_Interactive_Ide_Types.repl_state -> - FStar_Interactive_Ide_Types.repl_task Prims.list -> - (FStar_Interactive_Ide_Types.repl_task -> unit) -> - (FStar_Interactive_Ide_Types.repl_state, - FStar_Interactive_Ide_Types.repl_state) FStar_Pervasives.either) - = - fun st -> - fun tasks -> - fun progress_callback -> - let debug verb task = - let uu___ = FStar_Compiler_Effect.op_Bang dbg in - if uu___ - then - let uu___1 = FStar_Interactive_Ide_Types.string_of_repl_task task in - FStar_Compiler_Util.print2 "%s %s" verb uu___1 - else () in - let rec revert_many st1 uu___ = - match uu___ with - | [] -> st1 - | (_id, (task, _st'))::entries -> - (debug "Reverting" task; - (let st' = - FStar_Interactive_PushHelper.pop_repl - "run_repl_ls_transactions" st1 in - let dep_graph = - FStar_TypeChecker_Env.dep_graph - st1.FStar_Interactive_Ide_Types.repl_env in - let st'1 = - let uu___3 = - FStar_TypeChecker_Env.set_dep_graph - st'.FStar_Interactive_Ide_Types.repl_env dep_graph in - { - FStar_Interactive_Ide_Types.repl_line = - (st'.FStar_Interactive_Ide_Types.repl_line); - FStar_Interactive_Ide_Types.repl_column = - (st'.FStar_Interactive_Ide_Types.repl_column); - FStar_Interactive_Ide_Types.repl_fname = - (st'.FStar_Interactive_Ide_Types.repl_fname); - FStar_Interactive_Ide_Types.repl_deps_stack = - (st'.FStar_Interactive_Ide_Types.repl_deps_stack); - FStar_Interactive_Ide_Types.repl_curmod = - (st'.FStar_Interactive_Ide_Types.repl_curmod); - FStar_Interactive_Ide_Types.repl_env = uu___3; - FStar_Interactive_Ide_Types.repl_stdin = - (st'.FStar_Interactive_Ide_Types.repl_stdin); - FStar_Interactive_Ide_Types.repl_names = - (st'.FStar_Interactive_Ide_Types.repl_names); - FStar_Interactive_Ide_Types.repl_buffered_input_queries = - (st'.FStar_Interactive_Ide_Types.repl_buffered_input_queries); - FStar_Interactive_Ide_Types.repl_lang = - (st'.FStar_Interactive_Ide_Types.repl_lang) - } in - revert_many st'1 entries)) in - let rec aux st1 tasks1 previous = - match (tasks1, previous) with - | ([], []) -> FStar_Pervasives.Inl st1 - | (task::tasks2, []) -> - (debug "Loading" task; - progress_callback task; - (let uu___3 = FStar_Options.restore_cmd_line_options false in - ()); - (let timestamped_task = - FStar_Interactive_PushHelper.update_task_timestamps task in - let push_kind = - let uu___3 = FStar_Options.lax () in - if uu___3 - then FStar_Interactive_Ide_Types.LaxCheck - else FStar_Interactive_Ide_Types.FullCheck in - let uu___3 = - run_repl_transaction st1 - (FStar_Pervasives_Native.Some push_kind) false - timestamped_task in - match uu___3 with - | (success, st2) -> - if success - then - let uu___4 = - let uu___5 = - FStar_Compiler_Effect.op_Bang - FStar_Interactive_PushHelper.repl_stack in - { - FStar_Interactive_Ide_Types.repl_line = - (st2.FStar_Interactive_Ide_Types.repl_line); - FStar_Interactive_Ide_Types.repl_column = - (st2.FStar_Interactive_Ide_Types.repl_column); - FStar_Interactive_Ide_Types.repl_fname = - (st2.FStar_Interactive_Ide_Types.repl_fname); - FStar_Interactive_Ide_Types.repl_deps_stack = - uu___5; - FStar_Interactive_Ide_Types.repl_curmod = - (st2.FStar_Interactive_Ide_Types.repl_curmod); - FStar_Interactive_Ide_Types.repl_env = - (st2.FStar_Interactive_Ide_Types.repl_env); - FStar_Interactive_Ide_Types.repl_stdin = - (st2.FStar_Interactive_Ide_Types.repl_stdin); - FStar_Interactive_Ide_Types.repl_names = - (st2.FStar_Interactive_Ide_Types.repl_names); - FStar_Interactive_Ide_Types.repl_buffered_input_queries - = - (st2.FStar_Interactive_Ide_Types.repl_buffered_input_queries); - FStar_Interactive_Ide_Types.repl_lang = - (st2.FStar_Interactive_Ide_Types.repl_lang) - } in - aux uu___4 tasks2 [] - else FStar_Pervasives.Inr st2)) - | (task::tasks2, prev::previous1) when - let uu___ = - FStar_Interactive_PushHelper.update_task_timestamps task in - (FStar_Pervasives_Native.fst (FStar_Pervasives_Native.snd prev)) - = uu___ - -> (debug "Skipping" task; aux st1 tasks2 previous1) - | (tasks2, previous1) -> - let uu___ = revert_many st1 previous1 in aux uu___ tasks2 [] in - aux st tasks - (FStar_Compiler_List.rev - st.FStar_Interactive_Ide_Types.repl_deps_stack) -let (wrap_js_failure : - Prims.string -> - Prims.string -> FStar_Json.json -> FStar_Interactive_Ide_Types.query) - = - fun qid -> - fun expected -> - fun got -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Interactive_JsonHelper.json_debug got in - FStar_Compiler_Util.format2 - "JSON decoding failed: expected %s, got %s" expected uu___2 in - FStar_Interactive_Ide_Types.ProtocolViolation uu___1 in - { - FStar_Interactive_Ide_Types.qq = uu___; - FStar_Interactive_Ide_Types.qid = qid - } -let (unpack_interactive_query : - FStar_Json.json -> FStar_Interactive_Ide_Types.query) = - fun json -> - let assoc errloc key a = - let uu___ = FStar_Interactive_JsonHelper.try_assoc key a in - match uu___ with - | FStar_Pervasives_Native.Some v -> v - | FStar_Pervasives_Native.None -> - let uu___1 = - let uu___2 = - FStar_Compiler_Util.format2 "Missing key [%s] in %s." key - errloc in - FStar_Interactive_JsonHelper.InvalidQuery uu___2 in - FStar_Compiler_Effect.raise uu___1 in - let request = FStar_Interactive_JsonHelper.js_assoc json in - let qid = - let uu___ = assoc "query" "query-id" request in - FStar_Interactive_JsonHelper.js_str uu___ in - try - (fun uu___ -> - match () with - | () -> - let query = - let uu___1 = assoc "query" "query" request in - FStar_Interactive_JsonHelper.js_str uu___1 in - let args = - let uu___1 = assoc "query" "args" request in - FStar_Interactive_JsonHelper.js_assoc uu___1 in - let arg k = assoc "[args]" k args in - let try_arg k = - let uu___1 = FStar_Interactive_JsonHelper.try_assoc k args in - match uu___1 with - | FStar_Pervasives_Native.Some (FStar_Json.JsonNull) -> - FStar_Pervasives_Native.None - | other -> other in - let read_position err loc = - let uu___1 = - let uu___2 = assoc err "filename" loc in - FStar_Interactive_JsonHelper.js_str uu___2 in - let uu___2 = - let uu___3 = assoc err "line" loc in - FStar_Interactive_JsonHelper.js_int uu___3 in - let uu___3 = - let uu___4 = assoc err "column" loc in - FStar_Interactive_JsonHelper.js_int uu___4 in - (uu___1, uu___2, uu___3) in - let read_to_position uu___1 = - let to_pos = - let uu___2 = arg "to-position" in - FStar_Interactive_JsonHelper.js_assoc uu___2 in - let uu___2 = - let uu___3 = assoc "to-position.line" "line" to_pos in - FStar_Interactive_JsonHelper.js_int uu___3 in - let uu___3 = - let uu___4 = assoc "to-position.column" "column" to_pos in - FStar_Interactive_JsonHelper.js_int uu___4 in - ("", uu___2, uu___3) in - let parse_full_buffer_kind kind = - match kind with - | "full" -> FStar_Interactive_Ide_Types.Full - | "lax" -> FStar_Interactive_Ide_Types.Lax - | "cache" -> FStar_Interactive_Ide_Types.Cache - | "reload-deps" -> FStar_Interactive_Ide_Types.ReloadDeps - | "verify-to-position" -> - let uu___1 = read_to_position () in - FStar_Interactive_Ide_Types.VerifyToPosition uu___1 - | "lax-to-position" -> - let uu___1 = read_to_position () in - FStar_Interactive_Ide_Types.LaxToPosition uu___1 - | uu___1 -> - FStar_Compiler_Effect.raise - (FStar_Interactive_JsonHelper.InvalidQuery - "Invalid full-buffer kind") in - let uu___1 = - match query with - | "exit" -> FStar_Interactive_Ide_Types.Exit - | "pop" -> FStar_Interactive_Ide_Types.Pop - | "describe-protocol" -> - FStar_Interactive_Ide_Types.DescribeProtocol - | "describe-repl" -> FStar_Interactive_Ide_Types.DescribeRepl - | "segment" -> - let uu___2 = - let uu___3 = arg "code" in - FStar_Interactive_JsonHelper.js_str uu___3 in - FStar_Interactive_Ide_Types.Segment uu___2 - | "peek" -> - let uu___2 = - let uu___3 = - let uu___4 = arg "kind" in - FStar_Interactive_Ide_Types.js_pushkind uu___4 in - let uu___4 = - let uu___5 = arg "line" in - FStar_Interactive_JsonHelper.js_int uu___5 in - let uu___5 = - let uu___6 = arg "column" in - FStar_Interactive_JsonHelper.js_int uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = arg "code" in - FStar_Interactive_JsonHelper.js_str uu___8 in - FStar_Pervasives.Inl uu___7 in - { - FStar_Interactive_Ide_Types.push_kind = uu___3; - FStar_Interactive_Ide_Types.push_line = uu___4; - FStar_Interactive_Ide_Types.push_column = uu___5; - FStar_Interactive_Ide_Types.push_peek_only = - (query = "peek"); - FStar_Interactive_Ide_Types.push_code_or_decl = uu___6 - } in - FStar_Interactive_Ide_Types.Push uu___2 - | "push" -> - let uu___2 = - let uu___3 = - let uu___4 = arg "kind" in - FStar_Interactive_Ide_Types.js_pushkind uu___4 in - let uu___4 = - let uu___5 = arg "line" in - FStar_Interactive_JsonHelper.js_int uu___5 in - let uu___5 = - let uu___6 = arg "column" in - FStar_Interactive_JsonHelper.js_int uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = arg "code" in - FStar_Interactive_JsonHelper.js_str uu___8 in - FStar_Pervasives.Inl uu___7 in - { - FStar_Interactive_Ide_Types.push_kind = uu___3; - FStar_Interactive_Ide_Types.push_line = uu___4; - FStar_Interactive_Ide_Types.push_column = uu___5; - FStar_Interactive_Ide_Types.push_peek_only = - (query = "peek"); - FStar_Interactive_Ide_Types.push_code_or_decl = uu___6 - } in - FStar_Interactive_Ide_Types.Push uu___2 - | "push-partial-checked-file" -> - let uu___2 = - let uu___3 = arg "until-lid" in - FStar_Interactive_JsonHelper.js_str uu___3 in - FStar_Interactive_Ide_Types.PushPartialCheckedFile uu___2 - | "full-buffer" -> - let uu___2 = - let uu___3 = - let uu___4 = arg "code" in - FStar_Interactive_JsonHelper.js_str uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = arg "kind" in - FStar_Interactive_JsonHelper.js_str uu___6 in - parse_full_buffer_kind uu___5 in - let uu___5 = - let uu___6 = arg "with-symbols" in - FStar_Interactive_JsonHelper.js_bool uu___6 in - (uu___3, uu___4, uu___5) in - FStar_Interactive_Ide_Types.FullBuffer uu___2 - | "autocomplete" -> - let uu___2 = - let uu___3 = - let uu___4 = arg "partial-symbol" in - FStar_Interactive_JsonHelper.js_str uu___4 in - let uu___4 = - let uu___5 = try_arg "context" in - FStar_Interactive_Ide_Types.js_optional_completion_context - uu___5 in - (uu___3, uu___4) in - FStar_Interactive_Ide_Types.AutoComplete uu___2 - | "lookup" -> - let uu___2 = - let uu___3 = - let uu___4 = arg "symbol" in - FStar_Interactive_JsonHelper.js_str uu___4 in - let uu___4 = - let uu___5 = try_arg "context" in - FStar_Interactive_Ide_Types.js_optional_lookup_context - uu___5 in - let uu___5 = - let uu___6 = - let uu___7 = try_arg "location" in - FStar_Compiler_Util.map_option - FStar_Interactive_JsonHelper.js_assoc uu___7 in - FStar_Compiler_Util.map_option - (read_position "[location]") uu___6 in - let uu___6 = - let uu___7 = arg "requested-info" in - FStar_Interactive_JsonHelper.js_list - FStar_Interactive_JsonHelper.js_str uu___7 in - let uu___7 = try_arg "symbol-range" in - (uu___3, uu___4, uu___5, uu___6, uu___7) in - FStar_Interactive_Ide_Types.Lookup uu___2 - | "compute" -> - let uu___2 = - let uu___3 = - let uu___4 = arg "term" in - FStar_Interactive_JsonHelper.js_str uu___4 in - let uu___4 = - let uu___5 = try_arg "rules" in - FStar_Compiler_Util.map_option - (FStar_Interactive_JsonHelper.js_list - FStar_Interactive_Ide_Types.js_reductionrule) - uu___5 in - (uu___3, uu___4) in - FStar_Interactive_Ide_Types.Compute uu___2 - | "search" -> - let uu___2 = - let uu___3 = arg "terms" in - FStar_Interactive_JsonHelper.js_str uu___3 in - FStar_Interactive_Ide_Types.Search uu___2 - | "vfs-add" -> - let uu___2 = - let uu___3 = - let uu___4 = try_arg "filename" in - FStar_Compiler_Util.map_option - FStar_Interactive_JsonHelper.js_str uu___4 in - let uu___4 = - let uu___5 = arg "contents" in - FStar_Interactive_JsonHelper.js_str uu___5 in - (uu___3, uu___4) in - FStar_Interactive_Ide_Types.VfsAdd uu___2 - | "format" -> - let uu___2 = - let uu___3 = arg "code" in - FStar_Interactive_JsonHelper.js_str uu___3 in - FStar_Interactive_Ide_Types.Format uu___2 - | "restart-solver" -> - FStar_Interactive_Ide_Types.RestartSolver - | "cancel" -> - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = arg "cancel-line" in - FStar_Interactive_JsonHelper.js_int uu___5 in - let uu___5 = - let uu___6 = arg "cancel-column" in - FStar_Interactive_JsonHelper.js_int uu___6 in - ("", uu___4, uu___5) in - FStar_Pervasives_Native.Some uu___3 in - FStar_Interactive_Ide_Types.Cancel uu___2 - | uu___2 -> - let uu___3 = - FStar_Compiler_Util.format1 "Unknown query '%s'" query in - FStar_Interactive_Ide_Types.ProtocolViolation uu___3 in - { - FStar_Interactive_Ide_Types.qq = uu___1; - FStar_Interactive_Ide_Types.qid = qid - }) () - with - | FStar_Interactive_JsonHelper.InvalidQuery msg -> - { - FStar_Interactive_Ide_Types.qq = - (FStar_Interactive_Ide_Types.ProtocolViolation msg); - FStar_Interactive_Ide_Types.qid = qid - } - | FStar_Interactive_JsonHelper.UnexpectedJsonType (expected, got) -> - wrap_js_failure qid expected got -let (deserialize_interactive_query : - FStar_Json.json -> FStar_Interactive_Ide_Types.query) = - fun js_query -> - try - (fun uu___ -> match () with | () -> unpack_interactive_query js_query) - () - with - | FStar_Interactive_JsonHelper.InvalidQuery msg -> - { - FStar_Interactive_Ide_Types.qq = - (FStar_Interactive_Ide_Types.ProtocolViolation msg); - FStar_Interactive_Ide_Types.qid = "?" - } - | FStar_Interactive_JsonHelper.UnexpectedJsonType (expected, got) -> - wrap_js_failure "?" expected got -let (parse_interactive_query : - Prims.string -> FStar_Interactive_Ide_Types.query) = - fun query_str -> - let uu___ = FStar_Json.json_of_string query_str in - match uu___ with - | FStar_Pervasives_Native.None -> - { - FStar_Interactive_Ide_Types.qq = - (FStar_Interactive_Ide_Types.ProtocolViolation - "Json parsing failed."); - FStar_Interactive_Ide_Types.qid = "?" - } - | FStar_Pervasives_Native.Some request -> - deserialize_interactive_query request -let (buffer_input_queries : - FStar_Interactive_Ide_Types.repl_state -> - FStar_Interactive_Ide_Types.repl_state) - = - fun st -> - let rec aux qs st1 = - let done1 qs1 st2 = - { - FStar_Interactive_Ide_Types.repl_line = - (st2.FStar_Interactive_Ide_Types.repl_line); - FStar_Interactive_Ide_Types.repl_column = - (st2.FStar_Interactive_Ide_Types.repl_column); - FStar_Interactive_Ide_Types.repl_fname = - (st2.FStar_Interactive_Ide_Types.repl_fname); - FStar_Interactive_Ide_Types.repl_deps_stack = - (st2.FStar_Interactive_Ide_Types.repl_deps_stack); - FStar_Interactive_Ide_Types.repl_curmod = - (st2.FStar_Interactive_Ide_Types.repl_curmod); - FStar_Interactive_Ide_Types.repl_env = - (st2.FStar_Interactive_Ide_Types.repl_env); - FStar_Interactive_Ide_Types.repl_stdin = - (st2.FStar_Interactive_Ide_Types.repl_stdin); - FStar_Interactive_Ide_Types.repl_names = - (st2.FStar_Interactive_Ide_Types.repl_names); - FStar_Interactive_Ide_Types.repl_buffered_input_queries = - (FStar_Compiler_List.op_At - st2.FStar_Interactive_Ide_Types.repl_buffered_input_queries - (FStar_Compiler_List.rev qs1)); - FStar_Interactive_Ide_Types.repl_lang = - (st2.FStar_Interactive_Ide_Types.repl_lang) - } in - let uu___ = - let uu___1 = - FStar_Compiler_Util.poll_stdin - (FStar_Compiler_Util.float_of_string "0.0") in - Prims.op_Negation uu___1 in - if uu___ - then done1 qs st1 - else - (let uu___2 = - FStar_Compiler_Util.read_line - st1.FStar_Interactive_Ide_Types.repl_stdin in - match uu___2 with - | FStar_Pervasives_Native.None -> done1 qs st1 - | FStar_Pervasives_Native.Some line -> - let q = parse_interactive_query line in - (match q.FStar_Interactive_Ide_Types.qq with - | FStar_Interactive_Ide_Types.Cancel uu___3 -> - { - FStar_Interactive_Ide_Types.repl_line = - (st1.FStar_Interactive_Ide_Types.repl_line); - FStar_Interactive_Ide_Types.repl_column = - (st1.FStar_Interactive_Ide_Types.repl_column); - FStar_Interactive_Ide_Types.repl_fname = - (st1.FStar_Interactive_Ide_Types.repl_fname); - FStar_Interactive_Ide_Types.repl_deps_stack = - (st1.FStar_Interactive_Ide_Types.repl_deps_stack); - FStar_Interactive_Ide_Types.repl_curmod = - (st1.FStar_Interactive_Ide_Types.repl_curmod); - FStar_Interactive_Ide_Types.repl_env = - (st1.FStar_Interactive_Ide_Types.repl_env); - FStar_Interactive_Ide_Types.repl_stdin = - (st1.FStar_Interactive_Ide_Types.repl_stdin); - FStar_Interactive_Ide_Types.repl_names = - (st1.FStar_Interactive_Ide_Types.repl_names); - FStar_Interactive_Ide_Types.repl_buffered_input_queries = - [q]; - FStar_Interactive_Ide_Types.repl_lang = - (st1.FStar_Interactive_Ide_Types.repl_lang) - } - | uu___3 -> aux (q :: qs) st1)) in - aux [] st -let (read_interactive_query : - FStar_Interactive_Ide_Types.repl_state -> - (FStar_Interactive_Ide_Types.query * - FStar_Interactive_Ide_Types.repl_state)) - = - fun st -> - match st.FStar_Interactive_Ide_Types.repl_buffered_input_queries with - | [] -> - let uu___ = - FStar_Compiler_Util.read_line - st.FStar_Interactive_Ide_Types.repl_stdin in - (match uu___ with - | FStar_Pervasives_Native.None -> - FStar_Compiler_Effect.exit Prims.int_zero - | FStar_Pervasives_Native.Some line -> - let uu___1 = parse_interactive_query line in (uu___1, st)) - | q::qs -> - (q, - { - FStar_Interactive_Ide_Types.repl_line = - (st.FStar_Interactive_Ide_Types.repl_line); - FStar_Interactive_Ide_Types.repl_column = - (st.FStar_Interactive_Ide_Types.repl_column); - FStar_Interactive_Ide_Types.repl_fname = - (st.FStar_Interactive_Ide_Types.repl_fname); - FStar_Interactive_Ide_Types.repl_deps_stack = - (st.FStar_Interactive_Ide_Types.repl_deps_stack); - FStar_Interactive_Ide_Types.repl_curmod = - (st.FStar_Interactive_Ide_Types.repl_curmod); - FStar_Interactive_Ide_Types.repl_env = - (st.FStar_Interactive_Ide_Types.repl_env); - FStar_Interactive_Ide_Types.repl_stdin = - (st.FStar_Interactive_Ide_Types.repl_stdin); - FStar_Interactive_Ide_Types.repl_names = - (st.FStar_Interactive_Ide_Types.repl_names); - FStar_Interactive_Ide_Types.repl_buffered_input_queries = qs; - FStar_Interactive_Ide_Types.repl_lang = - (st.FStar_Interactive_Ide_Types.repl_lang) - }) -let json_of_opt : - 'uuuuu . - ('uuuuu -> FStar_Json.json) -> - 'uuuuu FStar_Pervasives_Native.option -> FStar_Json.json - = - fun json_of_a -> - fun opt_a -> - let uu___ = FStar_Compiler_Util.map_option json_of_a opt_a in - FStar_Compiler_Util.dflt FStar_Json.JsonNull uu___ -let (alist_of_symbol_lookup_result : - FStar_Interactive_QueryHelper.sl_reponse -> - Prims.string -> - FStar_Json.json FStar_Pervasives_Native.option -> - (Prims.string * FStar_Json.json) Prims.list) - = - fun lr -> - fun symbol -> - fun symrange_opt -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - json_of_opt FStar_Compiler_Range_Ops.json_of_def_range - lr.FStar_Interactive_QueryHelper.slr_def_range in - ("defined-at", uu___3) in - let uu___3 = - let uu___4 = - let uu___5 = - json_of_opt (fun uu___6 -> FStar_Json.JsonStr uu___6) - lr.FStar_Interactive_QueryHelper.slr_typ in - ("type", uu___5) in - let uu___5 = - let uu___6 = - let uu___7 = - json_of_opt (fun uu___8 -> FStar_Json.JsonStr uu___8) - lr.FStar_Interactive_QueryHelper.slr_doc in - ("documentation", uu___7) in - let uu___7 = - let uu___8 = - let uu___9 = - json_of_opt (fun uu___10 -> FStar_Json.JsonStr uu___10) - lr.FStar_Interactive_QueryHelper.slr_def in - ("definition", uu___9) in - [uu___8] in - uu___6 :: uu___7 in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - ("name", - (FStar_Json.JsonStr (lr.FStar_Interactive_QueryHelper.slr_name))) - :: uu___1 in - let uu___1 = - match symrange_opt with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some symrange -> - let uu___2 = - let uu___3 = json_of_opt (fun x -> x) symrange_opt in - ("symbol-range", uu___3) in - [uu___2; ("symbol", (FStar_Json.JsonStr symbol))] in - FStar_Compiler_List.op_At uu___ uu___1 -let (alist_of_protocol_info : (Prims.string * FStar_Json.json) Prims.list) = - let js_version = - FStar_Json.JsonInt - FStar_Interactive_Ide_Types.interactive_protocol_vernum in - let js_features = - let uu___ = - FStar_Compiler_List.map (fun uu___1 -> FStar_Json.JsonStr uu___1) - FStar_Interactive_Ide_Types.interactive_protocol_features in - FStar_Json.JsonList uu___ in - [("version", js_version); ("features", js_features)] -type fstar_option_permission_level = - | OptSet - | OptReadOnly -let (uu___is_OptSet : fstar_option_permission_level -> Prims.bool) = - fun projectee -> match projectee with | OptSet -> true | uu___ -> false -let (uu___is_OptReadOnly : fstar_option_permission_level -> Prims.bool) = - fun projectee -> - match projectee with | OptReadOnly -> true | uu___ -> false -let (string_of_option_permission_level : - fstar_option_permission_level -> Prims.string) = - fun uu___ -> match uu___ with | OptSet -> "" | OptReadOnly -> "read-only" -type fstar_option = - { - opt_name: Prims.string ; - opt_sig: Prims.string ; - opt_value: FStar_Options.option_val ; - opt_default: FStar_Options.option_val ; - opt_type: FStar_Options.opt_type ; - opt_snippets: Prims.string Prims.list ; - opt_documentation: Prims.string FStar_Pervasives_Native.option ; - opt_permission_level: fstar_option_permission_level } -let (__proj__Mkfstar_option__item__opt_name : fstar_option -> Prims.string) = - fun projectee -> - match projectee with - | { opt_name; opt_sig; opt_value; opt_default; opt_type; opt_snippets; - opt_documentation; opt_permission_level;_} -> opt_name -let (__proj__Mkfstar_option__item__opt_sig : fstar_option -> Prims.string) = - fun projectee -> - match projectee with - | { opt_name; opt_sig; opt_value; opt_default; opt_type; opt_snippets; - opt_documentation; opt_permission_level;_} -> opt_sig -let (__proj__Mkfstar_option__item__opt_value : - fstar_option -> FStar_Options.option_val) = - fun projectee -> - match projectee with - | { opt_name; opt_sig; opt_value; opt_default; opt_type; opt_snippets; - opt_documentation; opt_permission_level;_} -> opt_value -let (__proj__Mkfstar_option__item__opt_default : - fstar_option -> FStar_Options.option_val) = - fun projectee -> - match projectee with - | { opt_name; opt_sig; opt_value; opt_default; opt_type; opt_snippets; - opt_documentation; opt_permission_level;_} -> opt_default -let (__proj__Mkfstar_option__item__opt_type : - fstar_option -> FStar_Options.opt_type) = - fun projectee -> - match projectee with - | { opt_name; opt_sig; opt_value; opt_default; opt_type; opt_snippets; - opt_documentation; opt_permission_level;_} -> opt_type -let (__proj__Mkfstar_option__item__opt_snippets : - fstar_option -> Prims.string Prims.list) = - fun projectee -> - match projectee with - | { opt_name; opt_sig; opt_value; opt_default; opt_type; opt_snippets; - opt_documentation; opt_permission_level;_} -> opt_snippets -let (__proj__Mkfstar_option__item__opt_documentation : - fstar_option -> Prims.string FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { opt_name; opt_sig; opt_value; opt_default; opt_type; opt_snippets; - opt_documentation; opt_permission_level;_} -> opt_documentation -let (__proj__Mkfstar_option__item__opt_permission_level : - fstar_option -> fstar_option_permission_level) = - fun projectee -> - match projectee with - | { opt_name; opt_sig; opt_value; opt_default; opt_type; opt_snippets; - opt_documentation; opt_permission_level;_} -> opt_permission_level -let rec (kind_of_fstar_option_type : FStar_Options.opt_type -> Prims.string) - = - fun uu___ -> - match uu___ with - | FStar_Options.Const uu___1 -> "flag" - | FStar_Options.IntStr uu___1 -> "int" - | FStar_Options.BoolStr -> "bool" - | FStar_Options.PathStr uu___1 -> "path" - | FStar_Options.SimpleStr uu___1 -> "string" - | FStar_Options.EnumStr uu___1 -> "enum" - | FStar_Options.OpenEnumStr uu___1 -> "open enum" - | FStar_Options.PostProcessed (uu___1, typ) -> - kind_of_fstar_option_type typ - | FStar_Options.Accumulated typ -> kind_of_fstar_option_type typ - | FStar_Options.ReverseAccumulated typ -> kind_of_fstar_option_type typ - | FStar_Options.WithSideEffect (uu___1, typ) -> - kind_of_fstar_option_type typ -let (snippets_of_fstar_option : - Prims.string -> FStar_Options.opt_type -> Prims.string Prims.list) = - fun name -> - fun typ -> - let mk_field field_name = - Prims.strcat "${" (Prims.strcat field_name "}") in - let mk_snippet name1 argstring = - Prims.strcat "--" - (Prims.strcat name1 - (if argstring <> "" then Prims.strcat " " argstring else "")) in - let rec arg_snippets_of_type typ1 = - match typ1 with - | FStar_Options.Const uu___ -> [""] - | FStar_Options.BoolStr -> ["true"; "false"] - | FStar_Options.IntStr desc -> [mk_field desc] - | FStar_Options.PathStr desc -> [mk_field desc] - | FStar_Options.SimpleStr desc -> [mk_field desc] - | FStar_Options.EnumStr strs -> strs - | FStar_Options.OpenEnumStr (strs, desc) -> - FStar_Compiler_List.op_At strs [mk_field desc] - | FStar_Options.PostProcessed (uu___, elem_spec) -> - arg_snippets_of_type elem_spec - | FStar_Options.Accumulated elem_spec -> - arg_snippets_of_type elem_spec - | FStar_Options.ReverseAccumulated elem_spec -> - arg_snippets_of_type elem_spec - | FStar_Options.WithSideEffect (uu___, elem_spec) -> - arg_snippets_of_type elem_spec in - let uu___ = arg_snippets_of_type typ in - FStar_Compiler_List.map (mk_snippet name) uu___ -let rec (json_of_fstar_option_value : - FStar_Options.option_val -> FStar_Json.json) = - fun uu___ -> - match uu___ with - | FStar_Options.Bool b -> FStar_Json.JsonBool b - | FStar_Options.String s -> FStar_Json.JsonStr s - | FStar_Options.Path s -> FStar_Json.JsonStr s - | FStar_Options.Int n -> FStar_Json.JsonInt n - | FStar_Options.List vs -> - let uu___1 = FStar_Compiler_List.map json_of_fstar_option_value vs in - FStar_Json.JsonList uu___1 - | FStar_Options.Unset -> FStar_Json.JsonNull -let (alist_of_fstar_option : - fstar_option -> (Prims.string * FStar_Json.json) Prims.list) = - fun opt -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = json_of_fstar_option_value opt.opt_value in - ("value", uu___3) in - let uu___3 = - let uu___4 = - let uu___5 = json_of_fstar_option_value opt.opt_default in - ("default", uu___5) in - let uu___5 = - let uu___6 = - let uu___7 = - json_of_opt (fun uu___8 -> FStar_Json.JsonStr uu___8) - opt.opt_documentation in - ("documentation", uu___7) in - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = kind_of_fstar_option_type opt.opt_type in - FStar_Json.JsonStr uu___10 in - ("type", uu___9) in - [uu___8; - ("permission-level", - (FStar_Json.JsonStr - (string_of_option_permission_level - opt.opt_permission_level)))] in - uu___6 :: uu___7 in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - ("signature", (FStar_Json.JsonStr (opt.opt_sig))) :: uu___1 in - ("name", (FStar_Json.JsonStr (opt.opt_name))) :: uu___ -let (json_of_fstar_option : fstar_option -> FStar_Json.json) = - fun opt -> - let uu___ = alist_of_fstar_option opt in FStar_Json.JsonAssoc uu___ -let (json_of_response : - Prims.string -> - FStar_Interactive_Ide_Types.query_status -> - FStar_Json.json -> FStar_Json.json) - = - fun qid -> - fun status -> - fun response -> - let qid1 = FStar_Json.JsonStr qid in - let status1 = - match status with - | FStar_Interactive_Ide_Types.QueryOK -> - FStar_Json.JsonStr "success" - | FStar_Interactive_Ide_Types.QueryNOK -> - FStar_Json.JsonStr "failure" - | FStar_Interactive_Ide_Types.QueryViolatesProtocol -> - FStar_Json.JsonStr "protocol-violation" in - FStar_Json.JsonAssoc - [("kind", (FStar_Json.JsonStr "response")); - ("query-id", qid1); - ("status", status1); - ("response", response)] -let (write_response : - Prims.string -> - FStar_Interactive_Ide_Types.query_status -> FStar_Json.json -> unit) - = - fun qid -> - fun status -> - fun response -> - FStar_Interactive_JsonHelper.write_json - (json_of_response qid status response) -let (json_of_message : Prims.string -> FStar_Json.json -> FStar_Json.json) = - fun level -> - fun js_contents -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Compiler_Effect.op_Bang repl_current_qid in - json_of_opt (fun uu___5 -> FStar_Json.JsonStr uu___5) uu___4 in - ("query-id", uu___3) in - [uu___2; - ("level", (FStar_Json.JsonStr level)); - ("contents", js_contents)] in - ("kind", (FStar_Json.JsonStr "message")) :: uu___1 in - FStar_Json.JsonAssoc uu___ -let forward_message : - 'uuuuu . - (FStar_Json.json -> 'uuuuu) -> Prims.string -> FStar_Json.json -> 'uuuuu - = - fun callback -> - fun level -> - fun contents -> - let uu___ = json_of_message level contents in callback uu___ -let (json_of_hello : FStar_Json.json) = - let js_version = - FStar_Json.JsonInt - FStar_Interactive_Ide_Types.interactive_protocol_vernum in - let js_features = - let uu___ = - FStar_Compiler_List.map (fun uu___1 -> FStar_Json.JsonStr uu___1) - FStar_Interactive_Ide_Types.interactive_protocol_features in - FStar_Json.JsonList uu___ in - FStar_Json.JsonAssoc (("kind", (FStar_Json.JsonStr "protocol-info")) :: - alist_of_protocol_info) -let (write_hello : unit -> unit) = - fun uu___ -> FStar_Interactive_JsonHelper.write_json json_of_hello -let (sig_of_fstar_option : - Prims.string -> FStar_Options.opt_type -> Prims.string) = - fun name -> - fun typ -> - let flag = Prims.strcat "--" name in - let uu___ = FStar_Options.desc_of_opt_type typ in - match uu___ with - | FStar_Pervasives_Native.None -> flag - | FStar_Pervasives_Native.Some arg_sig -> - Prims.strcat flag (Prims.strcat " " arg_sig) -let (fstar_options_list_cache : fstar_option Prims.list) = - let defaults = FStar_Compiler_Util.smap_of_list FStar_Options.defaults in - let uu___ = - FStar_Compiler_List.filter_map - (fun uu___1 -> - match uu___1 with - | (_shortname, name, typ, doc) -> - let uu___2 = FStar_Compiler_Util.smap_try_find defaults name in - FStar_Compiler_Util.map_option - (fun default_value -> - let uu___3 = sig_of_fstar_option name typ in - let uu___4 = snippets_of_fstar_option name typ in - let uu___5 = - if doc = FStar_Pprint.empty - then FStar_Pervasives_Native.None - else - (let uu___7 = FStar_Errors_Msg.renderdoc doc in - FStar_Pervasives_Native.Some uu___7) in - let uu___6 = - let uu___7 = FStar_Options.settable name in - if uu___7 then OptSet else OptReadOnly in - { - opt_name = name; - opt_sig = uu___3; - opt_value = FStar_Options.Unset; - opt_default = default_value; - opt_type = typ; - opt_snippets = uu___4; - opt_documentation = uu___5; - opt_permission_level = uu___6 - }) uu___2) FStar_Options.all_specs_with_types in - FStar_Compiler_List.sortWith - (fun o1 -> - fun o2 -> - FStar_Compiler_String.compare - (FStar_Compiler_String.lowercase o1.opt_name) - (FStar_Compiler_String.lowercase o2.opt_name)) uu___ -let (fstar_options_map_cache : fstar_option FStar_Compiler_Util.smap) = - let cache = FStar_Compiler_Util.smap_create (Prims.of_int (50)) in - FStar_Compiler_List.iter - (fun opt -> FStar_Compiler_Util.smap_add cache opt.opt_name opt) - fstar_options_list_cache; - cache -let (update_option : fstar_option -> fstar_option) = - fun opt -> - let uu___ = FStar_Options.get_option opt.opt_name in - { - opt_name = (opt.opt_name); - opt_sig = (opt.opt_sig); - opt_value = uu___; - opt_default = (opt.opt_default); - opt_type = (opt.opt_type); - opt_snippets = (opt.opt_snippets); - opt_documentation = (opt.opt_documentation); - opt_permission_level = (opt.opt_permission_level) - } -let (current_fstar_options : - (fstar_option -> Prims.bool) -> fstar_option Prims.list) = - fun filter -> - let uu___ = FStar_Compiler_List.filter filter fstar_options_list_cache in - FStar_Compiler_List.map update_option uu___ -let (trim_option_name : Prims.string -> (Prims.string * Prims.string)) = - fun opt_name -> - let opt_prefix = "--" in - if FStar_Compiler_Util.starts_with opt_name opt_prefix - then - let uu___ = - FStar_Compiler_Util.substring_from opt_name - (FStar_Compiler_String.length opt_prefix) in - (opt_prefix, uu___) - else ("", opt_name) -let (json_of_repl_state : - FStar_Interactive_Ide_Types.repl_state -> FStar_Json.json) = - fun st -> - let filenames uu___ = - match uu___ with - | (uu___1, (task, uu___2)) -> - (match task with - | FStar_Interactive_Ide_Types.LDInterleaved (intf, impl) -> - [intf.FStar_Interactive_Ide_Types.tf_fname; - impl.FStar_Interactive_Ide_Types.tf_fname] - | FStar_Interactive_Ide_Types.LDSingle intf_or_impl -> - [intf_or_impl.FStar_Interactive_Ide_Types.tf_fname] - | FStar_Interactive_Ide_Types.LDInterfaceOfCurrentFile intf -> - [intf.FStar_Interactive_Ide_Types.tf_fname] - | uu___3 -> []) in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Compiler_List.concatMap filenames - st.FStar_Interactive_Ide_Types.repl_deps_stack in - FStar_Compiler_List.map (fun uu___5 -> FStar_Json.JsonStr uu___5) - uu___4 in - FStar_Json.JsonList uu___3 in - ("loaded-dependencies", uu___2) in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = current_fstar_options (fun uu___7 -> true) in - FStar_Compiler_List.map json_of_fstar_option uu___6 in - FStar_Json.JsonList uu___5 in - ("options", uu___4) in - [uu___3] in - uu___1 :: uu___2 in - FStar_Json.JsonAssoc uu___ -let run_exit : - 'uuuuu 'uuuuu1 . - 'uuuuu -> - ((FStar_Interactive_Ide_Types.query_status * FStar_Json.json) * - ('uuuuu1, Prims.int) FStar_Pervasives.either) - = - fun st -> - ((FStar_Interactive_Ide_Types.QueryOK, FStar_Json.JsonNull), - (FStar_Pervasives.Inr Prims.int_zero)) -let run_describe_protocol : - 'uuuuu 'uuuuu1 . - 'uuuuu -> - ((FStar_Interactive_Ide_Types.query_status * FStar_Json.json) * - ('uuuuu, 'uuuuu1) FStar_Pervasives.either) - = - fun st -> - ((FStar_Interactive_Ide_Types.QueryOK, - (FStar_Json.JsonAssoc alist_of_protocol_info)), - (FStar_Pervasives.Inl st)) -let run_describe_repl : - 'uuuuu . - FStar_Interactive_Ide_Types.repl_state -> - ((FStar_Interactive_Ide_Types.query_status * FStar_Json.json) * - (FStar_Interactive_Ide_Types.repl_state, 'uuuuu) - FStar_Pervasives.either) - = - fun st -> - let uu___ = - let uu___1 = json_of_repl_state st in - (FStar_Interactive_Ide_Types.QueryOK, uu___1) in - (uu___, (FStar_Pervasives.Inl st)) -let run_protocol_violation : - 'uuuuu 'uuuuu1 . - 'uuuuu -> - Prims.string -> - ((FStar_Interactive_Ide_Types.query_status * FStar_Json.json) * - ('uuuuu, 'uuuuu1) FStar_Pervasives.either) - = - fun st -> - fun message -> - ((FStar_Interactive_Ide_Types.QueryViolatesProtocol, - (FStar_Json.JsonStr message)), (FStar_Pervasives.Inl st)) -let run_generic_error : - 'uuuuu 'uuuuu1 . - 'uuuuu -> - Prims.string -> - ((FStar_Interactive_Ide_Types.query_status * FStar_Json.json) * - ('uuuuu, 'uuuuu1) FStar_Pervasives.either) - = - fun st -> - fun message -> - ((FStar_Interactive_Ide_Types.QueryNOK, (FStar_Json.JsonStr message)), - (FStar_Pervasives.Inl st)) -let (collect_errors : unit -> FStar_Errors.issue Prims.list) = - fun uu___ -> - let errors = FStar_Errors.report_all () in FStar_Errors.clear (); errors -let run_segment : - 'uuuuu . - FStar_Interactive_Ide_Types.repl_state -> - Prims.string -> - ((FStar_Interactive_Ide_Types.query_status * FStar_Json.json) * - (FStar_Interactive_Ide_Types.repl_state, 'uuuuu) - FStar_Pervasives.either) - = - fun st -> - fun code -> - let frag = - { - FStar_Parser_ParseIt.frag_fname = ""; - FStar_Parser_ParseIt.frag_text = code; - FStar_Parser_ParseIt.frag_line = Prims.int_one; - FStar_Parser_ParseIt.frag_col = Prims.int_zero - } in - let collect_decls uu___ = - let uu___1 = - FStar_Parser_Driver.parse_fragment FStar_Pervasives_Native.None - frag in - match uu___1 with - | FStar_Parser_Driver.Empty -> [] - | FStar_Parser_Driver.Decls decls -> decls - | FStar_Parser_Driver.Modul (FStar_Parser_AST.Module (uu___2, decls)) - -> decls - | FStar_Parser_Driver.Modul (FStar_Parser_AST.Interface - (uu___2, decls, uu___3)) -> decls in - let uu___ = - with_captured_errors st.FStar_Interactive_Ide_Types.repl_env - FStar_Compiler_Util.sigint_ignore - (fun uu___1 -> - let uu___2 = collect_decls () in - FStar_Pervasives_Native.Some uu___2) in - match uu___ with - | FStar_Pervasives_Native.None -> - let errors = - let uu___1 = collect_errors () in - FStar_Compiler_List.map FStar_Interactive_Ide_Types.json_of_issue - uu___1 in - ((FStar_Interactive_Ide_Types.QueryNOK, - (FStar_Json.JsonList errors)), (FStar_Pervasives.Inl st)) - | FStar_Pervasives_Native.Some decls -> - let json_of_decl decl = - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Compiler_Range_Ops.json_of_def_range - decl.FStar_Parser_AST.drange in - ("def_range", uu___3) in - [uu___2] in - FStar_Json.JsonAssoc uu___1 in - let js_decls = - let uu___1 = FStar_Compiler_List.map json_of_decl decls in - FStar_Json.JsonList uu___1 in - ((FStar_Interactive_Ide_Types.QueryOK, - (FStar_Json.JsonAssoc [("decls", js_decls)])), - (FStar_Pervasives.Inl st)) -let run_vfs_add : - 'uuuuu . - FStar_Interactive_Ide_Types.repl_state -> - Prims.string FStar_Pervasives_Native.option -> - Prims.string -> - ((FStar_Interactive_Ide_Types.query_status * FStar_Json.json) * - (FStar_Interactive_Ide_Types.repl_state, 'uuuuu) - FStar_Pervasives.either) - = - fun st -> - fun opt_fname -> - fun contents -> - let fname = - FStar_Compiler_Util.dflt st.FStar_Interactive_Ide_Types.repl_fname - opt_fname in - FStar_Parser_ParseIt.add_vfs_entry fname contents; - ((FStar_Interactive_Ide_Types.QueryOK, FStar_Json.JsonNull), - (FStar_Pervasives.Inl st)) -let run_pop : - 'uuuuu . - FStar_Interactive_Ide_Types.repl_state -> - ((FStar_Interactive_Ide_Types.query_status * FStar_Json.json) * - (FStar_Interactive_Ide_Types.repl_state, 'uuuuu) - FStar_Pervasives.either) - = - fun st -> - let uu___ = nothing_left_to_pop st in - if uu___ - then - ((FStar_Interactive_Ide_Types.QueryNOK, - (FStar_Json.JsonStr "Too many pops")), (FStar_Pervasives.Inl st)) - else - (let st' = FStar_Interactive_PushHelper.pop_repl "pop_query" st in - ((FStar_Interactive_Ide_Types.QueryOK, FStar_Json.JsonNull), - (FStar_Pervasives.Inl st'))) -let (write_progress : - Prims.string FStar_Pervasives_Native.option -> - (Prims.string * FStar_Json.json) Prims.list -> unit) - = - fun stage -> - fun contents_alist -> - let stage1 = - match stage with - | FStar_Pervasives_Native.Some s -> FStar_Json.JsonStr s - | FStar_Pervasives_Native.None -> FStar_Json.JsonNull in - let js_contents = ("stage", stage1) :: contents_alist in - let uu___ = - json_of_message "progress" (FStar_Json.JsonAssoc js_contents) in - FStar_Interactive_JsonHelper.write_json uu___ -let (write_error : (Prims.string * FStar_Json.json) Prims.list -> unit) = - fun contents -> - let uu___ = json_of_message "error" (FStar_Json.JsonAssoc contents) in - FStar_Interactive_JsonHelper.write_json uu___ -let (write_repl_ld_task_progress : - FStar_Interactive_Ide_Types.repl_task -> unit) = - fun task -> - match task with - | FStar_Interactive_Ide_Types.LDInterleaved (uu___, tf) -> - let modname = - FStar_Parser_Dep.module_name_of_file - tf.FStar_Interactive_Ide_Types.tf_fname in - write_progress (FStar_Pervasives_Native.Some "loading-dependency") - [("modname", (FStar_Json.JsonStr modname))] - | FStar_Interactive_Ide_Types.LDSingle tf -> - let modname = - FStar_Parser_Dep.module_name_of_file - tf.FStar_Interactive_Ide_Types.tf_fname in - write_progress (FStar_Pervasives_Native.Some "loading-dependency") - [("modname", (FStar_Json.JsonStr modname))] - | FStar_Interactive_Ide_Types.LDInterfaceOfCurrentFile tf -> - let modname = - FStar_Parser_Dep.module_name_of_file - tf.FStar_Interactive_Ide_Types.tf_fname in - write_progress (FStar_Pervasives_Native.Some "loading-dependency") - [("modname", (FStar_Json.JsonStr modname))] - | uu___ -> () -let (load_deps : - FStar_Interactive_Ide_Types.repl_state -> - ((FStar_Interactive_Ide_Types.repl_state * Prims.string Prims.list), - FStar_Interactive_Ide_Types.repl_state) FStar_Pervasives.either) - = - fun st -> - let uu___ = - with_captured_errors st.FStar_Interactive_Ide_Types.repl_env - FStar_Compiler_Util.sigint_ignore - (fun _env -> - let uu___1 = - FStar_Interactive_PushHelper.deps_and_repl_ld_tasks_of_our_file - st.FStar_Interactive_Ide_Types.repl_fname in - FStar_Pervasives_Native.Some uu___1) in - match uu___ with - | FStar_Pervasives_Native.None -> FStar_Pervasives.Inr st - | FStar_Pervasives_Native.Some (deps, tasks, dep_graph) -> - let st1 = - let uu___1 = - FStar_TypeChecker_Env.set_dep_graph - st.FStar_Interactive_Ide_Types.repl_env dep_graph in - { - FStar_Interactive_Ide_Types.repl_line = - (st.FStar_Interactive_Ide_Types.repl_line); - FStar_Interactive_Ide_Types.repl_column = - (st.FStar_Interactive_Ide_Types.repl_column); - FStar_Interactive_Ide_Types.repl_fname = - (st.FStar_Interactive_Ide_Types.repl_fname); - FStar_Interactive_Ide_Types.repl_deps_stack = - (st.FStar_Interactive_Ide_Types.repl_deps_stack); - FStar_Interactive_Ide_Types.repl_curmod = - (st.FStar_Interactive_Ide_Types.repl_curmod); - FStar_Interactive_Ide_Types.repl_env = uu___1; - FStar_Interactive_Ide_Types.repl_stdin = - (st.FStar_Interactive_Ide_Types.repl_stdin); - FStar_Interactive_Ide_Types.repl_names = - (st.FStar_Interactive_Ide_Types.repl_names); - FStar_Interactive_Ide_Types.repl_buffered_input_queries = - (st.FStar_Interactive_Ide_Types.repl_buffered_input_queries); - FStar_Interactive_Ide_Types.repl_lang = - (st.FStar_Interactive_Ide_Types.repl_lang) - } in - let uu___1 = - run_repl_ld_transactions st1 tasks write_repl_ld_task_progress in - (match uu___1 with - | FStar_Pervasives.Inr st2 -> - (write_progress FStar_Pervasives_Native.None []; - FStar_Pervasives.Inr st2) - | FStar_Pervasives.Inl st2 -> - (write_progress FStar_Pervasives_Native.None []; - FStar_Pervasives.Inl (st2, deps))) -let (rephrase_dependency_error : FStar_Errors.issue -> FStar_Errors.issue) = - fun issue -> - let uu___ = - let uu___1 = - FStar_Errors_Msg.text "Error while computing or loading dependencies" in - uu___1 :: (issue.FStar_Errors.issue_msg) in - { - FStar_Errors.issue_msg = uu___; - FStar_Errors.issue_level = (issue.FStar_Errors.issue_level); - FStar_Errors.issue_range = (issue.FStar_Errors.issue_range); - FStar_Errors.issue_number = (issue.FStar_Errors.issue_number); - FStar_Errors.issue_ctx = (issue.FStar_Errors.issue_ctx) - } -let (write_full_buffer_fragment_progress : - FStar_Interactive_Incremental.fragment_progress -> unit) = - fun di -> - let json_of_code_fragment cf = - let uu___ = - let uu___1 = - let uu___2 = - FStar_Compiler_Range_Ops.json_of_def_range - cf.FStar_Parser_ParseIt.range in - ("range", uu___2) in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Compiler_Util.digest_of_string - cf.FStar_Parser_ParseIt.code in - FStar_Json.JsonStr uu___5 in - ("code-digest", uu___4) in - [uu___3] in - uu___1 :: uu___2 in - FStar_Json.JsonAssoc uu___ in - match di with - | FStar_Interactive_Incremental.FullBufferStarted -> - write_progress (FStar_Pervasives_Native.Some "full-buffer-started") - [] - | FStar_Interactive_Incremental.FragmentStarted d -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Compiler_Range_Ops.json_of_def_range - d.FStar_Parser_AST.drange in - ("ranges", uu___2) in - [uu___1] in - write_progress - (FStar_Pervasives_Native.Some "full-buffer-fragment-started") uu___ - | FStar_Interactive_Incremental.FragmentSuccess - (d, cf, FStar_Interactive_Ide_Types.FullCheck) -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Compiler_Range_Ops.json_of_def_range - d.FStar_Parser_AST.drange in - ("ranges", uu___2) in - let uu___2 = - let uu___3 = - let uu___4 = json_of_code_fragment cf in - ("code-fragment", uu___4) in - [uu___3] in - uu___1 :: uu___2 in - write_progress - (FStar_Pervasives_Native.Some "full-buffer-fragment-ok") uu___ - | FStar_Interactive_Incremental.FragmentSuccess - (d, cf, FStar_Interactive_Ide_Types.LaxCheck) -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Compiler_Range_Ops.json_of_def_range - d.FStar_Parser_AST.drange in - ("ranges", uu___2) in - let uu___2 = - let uu___3 = - let uu___4 = json_of_code_fragment cf in - ("code-fragment", uu___4) in - [uu___3] in - uu___1 :: uu___2 in - write_progress - (FStar_Pervasives_Native.Some "full-buffer-fragment-lax-ok") uu___ - | FStar_Interactive_Incremental.FragmentFailed d -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Compiler_Range_Ops.json_of_def_range - d.FStar_Parser_AST.drange in - ("ranges", uu___2) in - [uu___1] in - write_progress - (FStar_Pervasives_Native.Some "full-buffer-fragment-failed") uu___ - | FStar_Interactive_Incremental.FragmentError issues -> - let qid = - let uu___ = FStar_Compiler_Effect.op_Bang repl_current_qid in - match uu___ with - | FStar_Pervasives_Native.None -> "unknown" - | FStar_Pervasives_Native.Some q -> q in - let uu___ = - let uu___1 = - let uu___2 = - FStar_Compiler_List.map - FStar_Interactive_Ide_Types.json_of_issue issues in - FStar_Json.JsonList uu___2 in - json_of_response qid FStar_Interactive_Ide_Types.QueryNOK uu___1 in - FStar_Interactive_JsonHelper.write_json uu___ - | FStar_Interactive_Incremental.FullBufferFinished -> - write_progress (FStar_Pervasives_Native.Some "full-buffer-finished") - [] -let (trunc_modul : - FStar_Syntax_Syntax.modul -> - (FStar_Syntax_Syntax.sigelt -> Prims.bool) -> - (Prims.bool * FStar_Syntax_Syntax.modul)) - = - fun m -> - fun pred -> - let rec filter decls acc = - match decls with - | [] -> (false, (FStar_Compiler_List.rev acc)) - | d::ds -> - let uu___ = pred d in - if uu___ - then (true, (FStar_Compiler_List.rev acc)) - else filter ds (d :: acc) in - let uu___ = filter m.FStar_Syntax_Syntax.declarations [] in - match uu___ with - | (found, decls) -> - (found, - { - FStar_Syntax_Syntax.name = (m.FStar_Syntax_Syntax.name); - FStar_Syntax_Syntax.declarations = decls; - FStar_Syntax_Syntax.is_interface = - (m.FStar_Syntax_Syntax.is_interface) - }) -let (load_partial_checked_file : - FStar_TypeChecker_Env.env -> - Prims.string -> - Prims.string -> (FStar_TypeChecker_Env.env * FStar_Syntax_Syntax.modul)) - = - fun env -> - fun filename -> - fun until_lid -> - let uu___ = FStar_CheckedFiles.load_module_from_cache env filename in - match uu___ with - | FStar_Pervasives_Native.None -> - failwith (Prims.strcat "cannot find checked file for " filename) - | FStar_Pervasives_Native.Some tc_result -> - let uu___1 = - FStar_Universal.with_dsenv_of_tcenv env - (fun ds -> - let uu___2 = - FStar_Syntax_DsEnv.set_current_module ds - (tc_result.FStar_CheckedFiles.checked_module).FStar_Syntax_Syntax.name in - ((), uu___2)) in - (match uu___1 with - | (uu___2, env1) -> - let uu___3 = - FStar_Universal.with_dsenv_of_tcenv env1 - (fun ds -> - let uu___4 = - FStar_Syntax_DsEnv.set_iface_decls ds - (tc_result.FStar_CheckedFiles.checked_module).FStar_Syntax_Syntax.name - [] in - ((), uu___4)) in - (match uu___3 with - | (uu___4, env2) -> - let pred se = - let rec pred1 lids = - match lids with - | [] -> false - | lid::lids1 -> - let uu___5 = - let uu___6 = FStar_Ident.string_of_lid lid in - uu___6 = until_lid in - if uu___5 then true else pred1 lids1 in - pred1 (FStar_Syntax_Util.lids_of_sigelt se) in - let uu___5 = - trunc_modul - tc_result.FStar_CheckedFiles.checked_module pred in - (match uu___5 with - | (found_decl, m) -> - if Prims.op_Negation found_decl - then - failwith - (Prims.strcat - "did not find declaration with lident " - until_lid) - else - (let uu___7 = - let uu___8 = - FStar_ToSyntax_ToSyntax.add_partial_modul_to_env - m tc_result.FStar_CheckedFiles.mii - (FStar_TypeChecker_Normalize.erase_universes - env2) in - FStar_Universal.with_dsenv_of_tcenv env2 - uu___8 in - match uu___7 with - | (uu___8, env3) -> - let env4 = - FStar_TypeChecker_Tc.load_partial_checked_module - env3 m in - let uu___9 = - FStar_Universal.with_dsenv_of_tcenv env4 - (fun ds -> - let uu___10 = - FStar_Syntax_DsEnv.set_current_module - ds m.FStar_Syntax_Syntax.name in - ((), uu___10)) in - (match uu___9 with - | (uu___10, env5) -> - let env6 = - FStar_TypeChecker_Env.set_current_module - env5 m.FStar_Syntax_Syntax.name in - ((let uu___12 = - FStar_SMTEncoding_Encode.encode_modul - env6 m in - ()); - (env6, m))))))) -let (run_load_partial_file : - FStar_Interactive_Ide_Types.repl_state -> - Prims.string -> - ((FStar_Interactive_Ide_Types.query_status * FStar_Json.json) * - (FStar_Interactive_Ide_Types.repl_state, Prims.int) - FStar_Pervasives.either)) - = - fun st -> - fun decl_name -> - let uu___ = load_deps st in - match uu___ with - | FStar_Pervasives.Inr st1 -> - let errors = - let uu___1 = collect_errors () in - FStar_Compiler_List.map rephrase_dependency_error uu___1 in - let js_errors = - FStar_Compiler_List.map FStar_Interactive_Ide_Types.json_of_issue - errors in - ((FStar_Interactive_Ide_Types.QueryNOK, - (FStar_Json.JsonList js_errors)), (FStar_Pervasives.Inl st1)) - | FStar_Pervasives.Inl (st1, deps) -> - let st2 = - FStar_Interactive_PushHelper.push_repl "load partial file" - (FStar_Pervasives_Native.Some - FStar_Interactive_Ide_Types.FullCheck) - FStar_Interactive_Ide_Types.Noop st1 in - let env = st2.FStar_Interactive_Ide_Types.repl_env in - let uu___1 = - with_captured_errors env FStar_Compiler_Util.sigint_raise - (fun env1 -> - let uu___2 = - load_partial_checked_file env1 - st2.FStar_Interactive_Ide_Types.repl_fname decl_name in - FStar_Pervasives_Native.Some uu___2) in - (match uu___1 with - | FStar_Pervasives_Native.Some (env1, curmod) when - let uu___2 = FStar_Errors.get_err_count () in - uu___2 = Prims.int_zero -> - let st3 = - { - FStar_Interactive_Ide_Types.repl_line = - (st2.FStar_Interactive_Ide_Types.repl_line); - FStar_Interactive_Ide_Types.repl_column = - (st2.FStar_Interactive_Ide_Types.repl_column); - FStar_Interactive_Ide_Types.repl_fname = - (st2.FStar_Interactive_Ide_Types.repl_fname); - FStar_Interactive_Ide_Types.repl_deps_stack = - (st2.FStar_Interactive_Ide_Types.repl_deps_stack); - FStar_Interactive_Ide_Types.repl_curmod = - (FStar_Pervasives_Native.Some curmod); - FStar_Interactive_Ide_Types.repl_env = env1; - FStar_Interactive_Ide_Types.repl_stdin = - (st2.FStar_Interactive_Ide_Types.repl_stdin); - FStar_Interactive_Ide_Types.repl_names = - (st2.FStar_Interactive_Ide_Types.repl_names); - FStar_Interactive_Ide_Types.repl_buffered_input_queries = - (st2.FStar_Interactive_Ide_Types.repl_buffered_input_queries); - FStar_Interactive_Ide_Types.repl_lang = - (st2.FStar_Interactive_Ide_Types.repl_lang) - } in - ((FStar_Interactive_Ide_Types.QueryOK, - (FStar_Json.JsonList [])), (FStar_Pervasives.Inl st3)) - | uu___2 -> - let json_error_list = - let uu___3 = collect_errors () in - FStar_Compiler_List.map - FStar_Interactive_Ide_Types.json_of_issue uu___3 in - let json_errors = FStar_Json.JsonList json_error_list in - let st3 = - FStar_Interactive_PushHelper.pop_repl "load partial file" - st2 in - ((FStar_Interactive_Ide_Types.QueryNOK, json_errors), - (FStar_Pervasives.Inl st3))) -let (run_push_without_deps : - FStar_Interactive_Ide_Types.repl_state -> - FStar_Interactive_Ide_Types.push_query -> - ((FStar_Interactive_Ide_Types.query_status * FStar_Json.json) * - (FStar_Interactive_Ide_Types.repl_state, Prims.int) - FStar_Pervasives.either)) - = - fun st -> - fun query -> - let set_flychecking_flag st1 flag = - { - FStar_Interactive_Ide_Types.repl_line = - (st1.FStar_Interactive_Ide_Types.repl_line); - FStar_Interactive_Ide_Types.repl_column = - (st1.FStar_Interactive_Ide_Types.repl_column); - FStar_Interactive_Ide_Types.repl_fname = - (st1.FStar_Interactive_Ide_Types.repl_fname); - FStar_Interactive_Ide_Types.repl_deps_stack = - (st1.FStar_Interactive_Ide_Types.repl_deps_stack); - FStar_Interactive_Ide_Types.repl_curmod = - (st1.FStar_Interactive_Ide_Types.repl_curmod); - FStar_Interactive_Ide_Types.repl_env = - (let uu___ = st1.FStar_Interactive_Ide_Types.repl_env in - { - FStar_TypeChecker_Env.solver = - (uu___.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (uu___.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (uu___.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (uu___.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (uu___.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (uu___.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (uu___.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (uu___.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (uu___.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (uu___.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (uu___.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (uu___.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (uu___.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (uu___.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (uu___.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (uu___.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (uu___.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (uu___.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (uu___.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (uu___.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (uu___.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (uu___.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = flag; - FStar_TypeChecker_Env.uvar_subtyping = - (uu___.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (uu___.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (uu___.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (uu___.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (uu___.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (uu___.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (uu___.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (uu___.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (uu___.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (uu___.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (uu___.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (uu___.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (uu___.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (uu___.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (uu___.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (uu___.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (uu___.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (uu___.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (uu___.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (uu___.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (uu___.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (uu___.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (uu___.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (uu___.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (uu___.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (uu___.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (uu___.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (uu___.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (uu___.FStar_TypeChecker_Env.missing_decl) - }); - FStar_Interactive_Ide_Types.repl_stdin = - (st1.FStar_Interactive_Ide_Types.repl_stdin); - FStar_Interactive_Ide_Types.repl_names = - (st1.FStar_Interactive_Ide_Types.repl_names); - FStar_Interactive_Ide_Types.repl_buffered_input_queries = - (st1.FStar_Interactive_Ide_Types.repl_buffered_input_queries); - FStar_Interactive_Ide_Types.repl_lang = - (st1.FStar_Interactive_Ide_Types.repl_lang) - } in - let uu___ = query in - match uu___ with - | { FStar_Interactive_Ide_Types.push_kind = push_kind; - FStar_Interactive_Ide_Types.push_line = line; - FStar_Interactive_Ide_Types.push_column = column; - FStar_Interactive_Ide_Types.push_peek_only = peek_only; - FStar_Interactive_Ide_Types.push_code_or_decl = code_or_decl;_} -> - ((let uu___2 = FStar_Options.ide_id_info_off () in - if uu___2 - then - FStar_TypeChecker_Env.toggle_id_info - st.FStar_Interactive_Ide_Types.repl_env false - else - FStar_TypeChecker_Env.toggle_id_info - st.FStar_Interactive_Ide_Types.repl_env true); - (let frag = - match code_or_decl with - | FStar_Pervasives.Inl text -> - FStar_Pervasives.Inl - { - FStar_Parser_ParseIt.frag_fname = ""; - FStar_Parser_ParseIt.frag_text = text; - FStar_Parser_ParseIt.frag_line = line; - FStar_Parser_ParseIt.frag_col = column - } - | FStar_Pervasives.Inr (decl, _code) -> - FStar_Pervasives.Inr decl in - let st1 = set_flychecking_flag st peek_only in - let uu___2 = - run_repl_transaction st1 - (FStar_Pervasives_Native.Some push_kind) peek_only - (FStar_Interactive_Ide_Types.PushFragment - (frag, push_kind, [])) in - match uu___2 with - | (success, st2) -> - let st3 = set_flychecking_flag st2 false in - let status = - if success || peek_only - then FStar_Interactive_Ide_Types.QueryOK - else FStar_Interactive_Ide_Types.QueryNOK in - let errs = collect_errors () in - let has_error = - FStar_Compiler_List.existsb - (fun i -> - match i.FStar_Errors.issue_level with - | FStar_Errors.EError -> true - | FStar_Errors.ENotImplemented -> true - | uu___3 -> false) errs in - ((match code_or_decl with - | FStar_Pervasives.Inr (d, s) -> - if Prims.op_Negation has_error - then - write_full_buffer_fragment_progress - (FStar_Interactive_Incremental.FragmentSuccess - (d, s, push_kind)) - else - write_full_buffer_fragment_progress - (FStar_Interactive_Incremental.FragmentFailed d) - | uu___4 -> ()); - (let json_errors = - let uu___4 = - FStar_Compiler_List.map - FStar_Interactive_Ide_Types.json_of_issue errs in - FStar_Json.JsonList uu___4 in - (match (errs, status) with - | (uu___5::uu___6, FStar_Interactive_Ide_Types.QueryOK) -> - FStar_Interactive_PushHelper.add_issues_to_push_fragment - [json_errors] - | uu___5 -> ()); - (let st4 = - if success - then - { - FStar_Interactive_Ide_Types.repl_line = line; - FStar_Interactive_Ide_Types.repl_column = column; - FStar_Interactive_Ide_Types.repl_fname = - (st3.FStar_Interactive_Ide_Types.repl_fname); - FStar_Interactive_Ide_Types.repl_deps_stack = - (st3.FStar_Interactive_Ide_Types.repl_deps_stack); - FStar_Interactive_Ide_Types.repl_curmod = - (st3.FStar_Interactive_Ide_Types.repl_curmod); - FStar_Interactive_Ide_Types.repl_env = - (st3.FStar_Interactive_Ide_Types.repl_env); - FStar_Interactive_Ide_Types.repl_stdin = - (st3.FStar_Interactive_Ide_Types.repl_stdin); - FStar_Interactive_Ide_Types.repl_names = - (st3.FStar_Interactive_Ide_Types.repl_names); - FStar_Interactive_Ide_Types.repl_buffered_input_queries - = - (st3.FStar_Interactive_Ide_Types.repl_buffered_input_queries); - FStar_Interactive_Ide_Types.repl_lang = - (st3.FStar_Interactive_Ide_Types.repl_lang) - } - else st3 in - ((status, json_errors), (FStar_Pervasives.Inl st4))))))) -let (run_push_with_deps : - FStar_Interactive_Ide_Types.repl_state -> - FStar_Interactive_Ide_Types.push_query -> - ((FStar_Interactive_Ide_Types.query_status * FStar_Json.json) * - (FStar_Interactive_Ide_Types.repl_state, Prims.int) - FStar_Pervasives.either)) - = - fun st -> - fun query -> - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg in - if uu___1 - then FStar_Compiler_Util.print_string "Reloading dependencies" - else ()); - FStar_TypeChecker_Env.toggle_id_info - st.FStar_Interactive_Ide_Types.repl_env false; - (let uu___2 = load_deps st in - match uu___2 with - | FStar_Pervasives.Inr st1 -> - let errors = - let uu___3 = collect_errors () in - FStar_Compiler_List.map rephrase_dependency_error uu___3 in - let js_errors = - FStar_Compiler_List.map - FStar_Interactive_Ide_Types.json_of_issue errors in - ((FStar_Interactive_Ide_Types.QueryNOK, - (FStar_Json.JsonList js_errors)), (FStar_Pervasives.Inl st1)) - | FStar_Pervasives.Inl (st1, deps) -> - ((let uu___4 = FStar_Options.restore_cmd_line_options false in ()); - (let names = - FStar_Interactive_PushHelper.add_module_completions - st1.FStar_Interactive_Ide_Types.repl_fname deps - st1.FStar_Interactive_Ide_Types.repl_names in - run_push_without_deps - { - FStar_Interactive_Ide_Types.repl_line = - (st1.FStar_Interactive_Ide_Types.repl_line); - FStar_Interactive_Ide_Types.repl_column = - (st1.FStar_Interactive_Ide_Types.repl_column); - FStar_Interactive_Ide_Types.repl_fname = - (st1.FStar_Interactive_Ide_Types.repl_fname); - FStar_Interactive_Ide_Types.repl_deps_stack = - (st1.FStar_Interactive_Ide_Types.repl_deps_stack); - FStar_Interactive_Ide_Types.repl_curmod = - (st1.FStar_Interactive_Ide_Types.repl_curmod); - FStar_Interactive_Ide_Types.repl_env = - (st1.FStar_Interactive_Ide_Types.repl_env); - FStar_Interactive_Ide_Types.repl_stdin = - (st1.FStar_Interactive_Ide_Types.repl_stdin); - FStar_Interactive_Ide_Types.repl_names = names; - FStar_Interactive_Ide_Types.repl_buffered_input_queries = - (st1.FStar_Interactive_Ide_Types.repl_buffered_input_queries); - FStar_Interactive_Ide_Types.repl_lang = - (st1.FStar_Interactive_Ide_Types.repl_lang) - } query))) -let (run_push : - FStar_Interactive_Ide_Types.repl_state -> - FStar_Interactive_Ide_Types.push_query -> - ((FStar_Interactive_Ide_Types.query_status * FStar_Json.json) * - (FStar_Interactive_Ide_Types.repl_state, Prims.int) - FStar_Pervasives.either)) - = - fun st -> - fun query -> - let uu___ = nothing_left_to_pop st in - if uu___ - then run_push_with_deps st query - else run_push_without_deps st query -let (run_symbol_lookup : - FStar_Interactive_Ide_Types.repl_state -> - Prims.string -> - FStar_Interactive_QueryHelper.position FStar_Pervasives_Native.option - -> - Prims.string Prims.list -> - FStar_Json.json FStar_Pervasives_Native.option -> - (Prims.string, - (Prims.string * (Prims.string * FStar_Json.json) Prims.list)) - FStar_Pervasives.either) - = - fun st -> - fun symbol -> - fun pos_opt -> - fun requested_info -> - fun symbol_range_opt -> - let uu___ = - FStar_Interactive_QueryHelper.symlookup - st.FStar_Interactive_Ide_Types.repl_env symbol pos_opt - requested_info in - match uu___ with - | FStar_Pervasives_Native.None -> - FStar_Pervasives.Inl "Symbol not found" - | FStar_Pervasives_Native.Some result -> - let uu___1 = - let uu___2 = - alist_of_symbol_lookup_result result symbol - symbol_range_opt in - ("symbol", uu___2) in - FStar_Pervasives.Inr uu___1 -let (run_option_lookup : - Prims.string -> - (Prims.string, - (Prims.string * (Prims.string * FStar_Json.json) Prims.list)) - FStar_Pervasives.either) - = - fun opt_name -> - let uu___ = trim_option_name opt_name in - match uu___ with - | (uu___1, trimmed_name) -> - let uu___2 = - FStar_Compiler_Util.smap_try_find fstar_options_map_cache - trimmed_name in - (match uu___2 with - | FStar_Pervasives_Native.None -> - FStar_Pervasives.Inl (Prims.strcat "Unknown option:" opt_name) - | FStar_Pervasives_Native.Some opt -> - let uu___3 = - let uu___4 = - let uu___5 = update_option opt in - alist_of_fstar_option uu___5 in - ("option", uu___4) in - FStar_Pervasives.Inr uu___3) -let (run_module_lookup : - FStar_Interactive_Ide_Types.repl_state -> - Prims.string -> - (Prims.string, - (Prims.string * (Prims.string * FStar_Json.json) Prims.list)) - FStar_Pervasives.either) - = - fun st -> - fun symbol -> - let query = FStar_Compiler_Util.split symbol "." in - let uu___ = - FStar_Interactive_CompletionTable.find_module_or_ns - st.FStar_Interactive_Ide_Types.repl_names query in - match uu___ with - | FStar_Pervasives_Native.None -> - FStar_Pervasives.Inl "No such module or namespace" - | FStar_Pervasives_Native.Some - (FStar_Interactive_CompletionTable.Module mod_info) -> - let uu___1 = - let uu___2 = - FStar_Interactive_CompletionTable.alist_of_mod_info mod_info in - ("module", uu___2) in - FStar_Pervasives.Inr uu___1 - | FStar_Pervasives_Native.Some - (FStar_Interactive_CompletionTable.Namespace ns_info) -> - let uu___1 = - let uu___2 = - FStar_Interactive_CompletionTable.alist_of_ns_info ns_info in - ("namespace", uu___2) in - FStar_Pervasives.Inr uu___1 -let (run_code_lookup : - FStar_Interactive_Ide_Types.repl_state -> - Prims.string -> - FStar_Interactive_QueryHelper.position FStar_Pervasives_Native.option - -> - Prims.string Prims.list -> - FStar_Json.json FStar_Pervasives_Native.option -> - (Prims.string, - (Prims.string * (Prims.string * FStar_Json.json) Prims.list)) - FStar_Pervasives.either) - = - fun st -> - fun symbol -> - fun pos_opt -> - fun requested_info -> - fun symrange_opt -> - let uu___ = - run_symbol_lookup st symbol pos_opt requested_info symrange_opt in - match uu___ with - | FStar_Pervasives.Inr alist -> FStar_Pervasives.Inr alist - | FStar_Pervasives.Inl uu___1 -> - let uu___2 = run_module_lookup st symbol in - (match uu___2 with - | FStar_Pervasives.Inr alist -> FStar_Pervasives.Inr alist - | FStar_Pervasives.Inl err_msg -> - FStar_Pervasives.Inl - "No such symbol, module, or namespace.") -let (run_lookup' : - FStar_Interactive_Ide_Types.repl_state -> - Prims.string -> - FStar_Interactive_Ide_Types.lookup_context -> - FStar_Interactive_QueryHelper.position FStar_Pervasives_Native.option - -> - Prims.string Prims.list -> - FStar_Json.json FStar_Pervasives_Native.option -> - (Prims.string, - (Prims.string * (Prims.string * FStar_Json.json) Prims.list)) - FStar_Pervasives.either) - = - fun st -> - fun symbol -> - fun context -> - fun pos_opt -> - fun requested_info -> - fun symrange -> - match context with - | FStar_Interactive_Ide_Types.LKSymbolOnly -> - run_symbol_lookup st symbol pos_opt requested_info symrange - | FStar_Interactive_Ide_Types.LKModule -> - run_module_lookup st symbol - | FStar_Interactive_Ide_Types.LKOption -> - run_option_lookup symbol - | FStar_Interactive_Ide_Types.LKCode -> - run_code_lookup st symbol pos_opt requested_info symrange -let run_lookup : - 'uuuuu . - FStar_Interactive_Ide_Types.repl_state -> - Prims.string -> - FStar_Interactive_Ide_Types.lookup_context -> - FStar_Interactive_QueryHelper.position - FStar_Pervasives_Native.option -> - Prims.string Prims.list -> - FStar_Json.json FStar_Pervasives_Native.option -> - ((FStar_Interactive_Ide_Types.query_status * FStar_Json.json - Prims.list) * (FStar_Interactive_Ide_Types.repl_state, - 'uuuuu) FStar_Pervasives.either) - = - fun st -> - fun symbol -> - fun context -> - fun pos_opt -> - fun requested_info -> - fun symrange -> - try - (fun uu___ -> - match () with - | () -> - let uu___1 = - run_lookup' st symbol context pos_opt requested_info - symrange in - (match uu___1 with - | FStar_Pervasives.Inl err_msg -> - (match symrange with - | FStar_Pervasives_Native.None -> - ((FStar_Interactive_Ide_Types.QueryNOK, - [FStar_Json.JsonStr err_msg]), - (FStar_Pervasives.Inl st)) - | uu___2 -> - ((FStar_Interactive_Ide_Types.QueryOK, []), - (FStar_Pervasives.Inl st))) - | FStar_Pervasives.Inr (kind, info) -> - ((FStar_Interactive_Ide_Types.QueryOK, - [FStar_Json.JsonAssoc - (("kind", (FStar_Json.JsonStr kind)) :: - info)]), (FStar_Pervasives.Inl st)))) () - with - | uu___ -> - ((FStar_Interactive_Ide_Types.QueryOK, - [FStar_Json.JsonStr - (Prims.strcat "Lookup of " - (Prims.strcat symbol " failed"))]), - (FStar_Pervasives.Inl st)) -let run_code_autocomplete : - 'uuuuu . - FStar_Interactive_Ide_Types.repl_state -> - Prims.string -> - ((FStar_Interactive_Ide_Types.query_status * FStar_Json.json) * - (FStar_Interactive_Ide_Types.repl_state, 'uuuuu) - FStar_Pervasives.either) - = - fun st -> - fun search_term -> - let result = FStar_Interactive_QueryHelper.ck_completion st search_term in - let results = - match result with - | [] -> result - | uu___ -> - let result_correlator = - { - FStar_Interactive_CompletionTable.completion_match_length = - Prims.int_zero; - FStar_Interactive_CompletionTable.completion_candidate = - search_term; - FStar_Interactive_CompletionTable.completion_annotation = - "" - } in - FStar_Compiler_List.op_At result [result_correlator] in - let js = - FStar_Compiler_List.map - FStar_Interactive_CompletionTable.json_of_completion_result results in - ((FStar_Interactive_Ide_Types.QueryOK, (FStar_Json.JsonList js)), - (FStar_Pervasives.Inl st)) -let run_module_autocomplete : - 'uuuuu 'uuuuu1 'uuuuu2 . - FStar_Interactive_Ide_Types.repl_state -> - Prims.string -> - 'uuuuu -> - 'uuuuu1 -> - ((FStar_Interactive_Ide_Types.query_status * FStar_Json.json) * - (FStar_Interactive_Ide_Types.repl_state, 'uuuuu2) - FStar_Pervasives.either) - = - fun st -> - fun search_term -> - fun modules -> - fun namespaces -> - let needle = FStar_Compiler_Util.split search_term "." in - let mods_and_nss = - FStar_Interactive_CompletionTable.autocomplete_mod_or_ns - st.FStar_Interactive_Ide_Types.repl_names needle - (fun uu___ -> FStar_Pervasives_Native.Some uu___) in - let json = - FStar_Compiler_List.map - FStar_Interactive_CompletionTable.json_of_completion_result - mods_and_nss in - ((FStar_Interactive_Ide_Types.QueryOK, (FStar_Json.JsonList json)), - (FStar_Pervasives.Inl st)) -let candidates_of_fstar_option : - 'uuuuu . - Prims.int -> - 'uuuuu -> - fstar_option -> - FStar_Interactive_CompletionTable.completion_result Prims.list - = - fun match_len -> - fun is_reset -> - fun opt -> - let uu___ = - match opt.opt_permission_level with - | OptSet -> (true, "") - | OptReadOnly -> (false, "read-only") in - match uu___ with - | (may_set, explanation) -> - let opt_type = kind_of_fstar_option_type opt.opt_type in - let annot = - if may_set - then opt_type - else - Prims.strcat "(" - (Prims.strcat explanation - (Prims.strcat " " (Prims.strcat opt_type ")"))) in - FStar_Compiler_List.map - (fun snippet -> - { - FStar_Interactive_CompletionTable.completion_match_length - = match_len; - FStar_Interactive_CompletionTable.completion_candidate = - snippet; - FStar_Interactive_CompletionTable.completion_annotation = - annot - }) opt.opt_snippets -let run_option_autocomplete : - 'uuuuu 'uuuuu1 'uuuuu2 . - 'uuuuu -> - Prims.string -> - 'uuuuu1 -> - ((FStar_Interactive_Ide_Types.query_status * FStar_Json.json) * - ('uuuuu, 'uuuuu2) FStar_Pervasives.either) - = - fun st -> - fun search_term -> - fun is_reset -> - let uu___ = trim_option_name search_term in - match uu___ with - | ("--", trimmed_name) -> - let matcher opt = - FStar_Compiler_Util.starts_with opt.opt_name trimmed_name in - let options = current_fstar_options matcher in - let match_len = FStar_Compiler_String.length search_term in - let collect_candidates = - candidates_of_fstar_option match_len is_reset in - let results = - FStar_Compiler_List.concatMap collect_candidates options in - let json = - FStar_Compiler_List.map - FStar_Interactive_CompletionTable.json_of_completion_result - results in - ((FStar_Interactive_Ide_Types.QueryOK, - (FStar_Json.JsonList json)), (FStar_Pervasives.Inl st)) - | (uu___1, uu___2) -> - ((FStar_Interactive_Ide_Types.QueryNOK, - (FStar_Json.JsonStr "Options should start with '--'")), - (FStar_Pervasives.Inl st)) -let run_autocomplete : - 'uuuuu . - FStar_Interactive_Ide_Types.repl_state -> - Prims.string -> - FStar_Interactive_Ide_Types.completion_context -> - ((FStar_Interactive_Ide_Types.query_status * FStar_Json.json) * - (FStar_Interactive_Ide_Types.repl_state, 'uuuuu) - FStar_Pervasives.either) - = - fun st -> - fun search_term -> - fun context -> - match context with - | FStar_Interactive_Ide_Types.CKCode -> - run_code_autocomplete st search_term - | FStar_Interactive_Ide_Types.CKOption is_reset -> - run_option_autocomplete st search_term is_reset - | FStar_Interactive_Ide_Types.CKModuleOrNamespace - (modules, namespaces) -> - run_module_autocomplete st search_term modules namespaces -let run_and_rewind : - 'uuuuu 'uuuuu1 . - FStar_Interactive_Ide_Types.repl_state -> - 'uuuuu -> - (FStar_Interactive_Ide_Types.repl_state -> 'uuuuu) -> - ('uuuuu * (FStar_Interactive_Ide_Types.repl_state, 'uuuuu1) - FStar_Pervasives.either) - = - fun st -> - fun sigint_default -> - fun task -> - let st1 = - FStar_Interactive_PushHelper.push_repl "run_and_rewind" - (FStar_Pervasives_Native.Some - FStar_Interactive_Ide_Types.FullCheck) - FStar_Interactive_Ide_Types.Noop st in - let results = - try - (fun uu___ -> - match () with - | () -> - FStar_Compiler_Util.with_sigint_handler - FStar_Compiler_Util.sigint_raise - (fun uu___1 -> - let uu___2 = task st1 in FStar_Pervasives.Inl uu___2)) - () - with - | FStar_Compiler_Util.SigInt -> FStar_Pervasives.Inl sigint_default - | e -> FStar_Pervasives.Inr e in - let st2 = FStar_Interactive_PushHelper.pop_repl "run_and_rewind" st1 in - match results with - | FStar_Pervasives.Inl results1 -> - (results1, (FStar_Pervasives.Inl st2)) - | FStar_Pervasives.Inr e -> FStar_Compiler_Effect.raise e -let run_with_parsed_and_tc_term : - 'uuuuu 'uuuuu1 'uuuuu2 . - FStar_Interactive_Ide_Types.repl_state -> - Prims.string -> - 'uuuuu -> - 'uuuuu1 -> - (FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - (FStar_Interactive_Ide_Types.query_status * FStar_Json.json)) - -> - ((FStar_Interactive_Ide_Types.query_status * FStar_Json.json) * - (FStar_Interactive_Ide_Types.repl_state, 'uuuuu2) - FStar_Pervasives.either) - = - fun st -> - fun term -> - fun line -> - fun column -> - fun continuation -> - let dummy_let_fragment term1 = - let dummy_decl = - FStar_Compiler_Util.format1 "let __compute_dummy__ = (%s)" - term1 in - { - FStar_Parser_ParseIt.frag_fname = " input"; - FStar_Parser_ParseIt.frag_text = dummy_decl; - FStar_Parser_ParseIt.frag_line = Prims.int_zero; - FStar_Parser_ParseIt.frag_col = Prims.int_zero - } in - let find_let_body ses = - match ses with - | { - FStar_Syntax_Syntax.sigel = FStar_Syntax_Syntax.Sig_let - { - FStar_Syntax_Syntax.lbs1 = - (uu___, - { FStar_Syntax_Syntax.lbname = uu___1; - FStar_Syntax_Syntax.lbunivs = univs; - FStar_Syntax_Syntax.lbtyp = uu___2; - FStar_Syntax_Syntax.lbeff = uu___3; - FStar_Syntax_Syntax.lbdef = def; - FStar_Syntax_Syntax.lbattrs = uu___4; - FStar_Syntax_Syntax.lbpos = uu___5;_}::[]); - FStar_Syntax_Syntax.lids1 = uu___6;_}; - FStar_Syntax_Syntax.sigrng = uu___7; - FStar_Syntax_Syntax.sigquals = uu___8; - FStar_Syntax_Syntax.sigmeta = uu___9; - FStar_Syntax_Syntax.sigattrs = uu___10; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___11; - FStar_Syntax_Syntax.sigopts = uu___12;_}::[] -> - FStar_Pervasives_Native.Some (univs, def) - | uu___ -> FStar_Pervasives_Native.None in - let parse frag = - let uu___ = - FStar_Parser_ParseIt.parse FStar_Pervasives_Native.None - (FStar_Parser_ParseIt.Incremental frag) in - match uu___ with - | FStar_Parser_ParseIt.IncrementalFragment - (decls, uu___1, _err) -> - let uu___2 = - FStar_Compiler_List.map FStar_Pervasives_Native.fst decls in - FStar_Pervasives_Native.Some uu___2 - | uu___1 -> FStar_Pervasives_Native.None in - let desugar env decls = - let uu___ = - let uu___1 = FStar_ToSyntax_ToSyntax.decls_to_sigelts decls in - uu___1 env.FStar_TypeChecker_Env.dsenv in - FStar_Pervasives_Native.fst uu___ in - let typecheck tcenv decls = - let uu___ = FStar_TypeChecker_Tc.tc_decls tcenv decls in - match uu___ with | (ses, uu___1) -> ses in - run_and_rewind st - (FStar_Interactive_Ide_Types.QueryNOK, - (FStar_Json.JsonStr "Computation interrupted")) - (fun st1 -> - let tcenv = st1.FStar_Interactive_Ide_Types.repl_env in - let frag = dummy_let_fragment term in - let uu___ = parse frag in - match uu___ with - | FStar_Pervasives_Native.None -> - (FStar_Interactive_Ide_Types.QueryNOK, - (FStar_Json.JsonStr "Could not parse this term")) - | FStar_Pervasives_Native.Some decls -> - let aux uu___1 = - let decls1 = desugar tcenv decls in - let ses = typecheck tcenv decls1 in - match find_let_body ses with - | FStar_Pervasives_Native.None -> - (FStar_Interactive_Ide_Types.QueryNOK, - (FStar_Json.JsonStr - "Typechecking yielded an unexpected term")) - | FStar_Pervasives_Native.Some (univs, def) -> - let uu___2 = - FStar_Syntax_Subst.open_univ_vars univs def in - (match uu___2 with - | (univs1, def1) -> - let tcenv1 = - FStar_TypeChecker_Env.push_univ_vars tcenv - univs1 in - continuation tcenv1 def1) in - let uu___1 = FStar_Options.trace_error () in - if uu___1 - then aux () - else - (try (fun uu___3 -> match () with | () -> aux ()) () - with - | uu___3 -> - let uu___4 = FStar_Errors.issue_of_exn uu___3 in - (match uu___4 with - | FStar_Pervasives_Native.Some issue -> - let uu___5 = - let uu___6 = - FStar_Errors.format_issue issue in - FStar_Json.JsonStr uu___6 in - (FStar_Interactive_Ide_Types.QueryNOK, - uu___5) - | FStar_Pervasives_Native.None -> - FStar_Compiler_Effect.raise uu___3))) -let run_compute : - 'uuuuu . - FStar_Interactive_Ide_Types.repl_state -> - Prims.string -> - FStar_TypeChecker_Env.step Prims.list FStar_Pervasives_Native.option - -> - ((FStar_Interactive_Ide_Types.query_status * FStar_Json.json) * - (FStar_Interactive_Ide_Types.repl_state, 'uuuuu) - FStar_Pervasives.either) - = - fun st -> - fun term -> - fun rules -> - let rules1 = - FStar_Compiler_List.op_At - (match rules with - | FStar_Pervasives_Native.Some rules2 -> rules2 - | FStar_Pervasives_Native.None -> - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Iota; - FStar_TypeChecker_Env.Zeta; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant]) - [FStar_TypeChecker_Env.Inlining; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.DontUnfoldAttr - [FStar_Parser_Const.tac_opaque_attr]; - FStar_TypeChecker_Env.Primops] in - let normalize_term tcenv rules2 t = - FStar_TypeChecker_Normalize.normalize rules2 tcenv t in - run_with_parsed_and_tc_term st term Prims.int_zero Prims.int_zero - (fun tcenv -> - fun def -> - let normalized = normalize_term tcenv rules1 def in - let uu___ = - let uu___1 = - FStar_Interactive_QueryHelper.term_to_string tcenv - normalized in - FStar_Json.JsonStr uu___1 in - (FStar_Interactive_Ide_Types.QueryOK, uu___)) -type search_term' = - | NameContainsStr of Prims.string - | TypeContainsLid of FStar_Ident.lid -and search_term = { - st_negate: Prims.bool ; - st_term: search_term' } -let (uu___is_NameContainsStr : search_term' -> Prims.bool) = - fun projectee -> - match projectee with | NameContainsStr _0 -> true | uu___ -> false -let (__proj__NameContainsStr__item___0 : search_term' -> Prims.string) = - fun projectee -> match projectee with | NameContainsStr _0 -> _0 -let (uu___is_TypeContainsLid : search_term' -> Prims.bool) = - fun projectee -> - match projectee with | TypeContainsLid _0 -> true | uu___ -> false -let (__proj__TypeContainsLid__item___0 : search_term' -> FStar_Ident.lid) = - fun projectee -> match projectee with | TypeContainsLid _0 -> _0 -let (__proj__Mksearch_term__item__st_negate : search_term -> Prims.bool) = - fun projectee -> - match projectee with | { st_negate; st_term;_} -> st_negate -let (__proj__Mksearch_term__item__st_term : search_term -> search_term') = - fun projectee -> match projectee with | { st_negate; st_term;_} -> st_term -let (st_cost : search_term' -> Prims.int) = - fun uu___ -> - match uu___ with - | NameContainsStr str -> - (FStar_Compiler_String.length str) - | TypeContainsLid lid -> Prims.int_one -type search_candidate = - { - sc_lid: FStar_Ident.lid ; - sc_typ: - FStar_Syntax_Syntax.typ FStar_Pervasives_Native.option - FStar_Compiler_Effect.ref - ; - sc_fvars: - FStar_Ident.lid FStar_Compiler_RBSet.t FStar_Pervasives_Native.option - FStar_Compiler_Effect.ref - } -let (__proj__Mksearch_candidate__item__sc_lid : - search_candidate -> FStar_Ident.lid) = - fun projectee -> - match projectee with | { sc_lid; sc_typ; sc_fvars;_} -> sc_lid -let (__proj__Mksearch_candidate__item__sc_typ : - search_candidate -> - FStar_Syntax_Syntax.typ FStar_Pervasives_Native.option - FStar_Compiler_Effect.ref) - = - fun projectee -> - match projectee with | { sc_lid; sc_typ; sc_fvars;_} -> sc_typ -let (__proj__Mksearch_candidate__item__sc_fvars : - search_candidate -> - FStar_Ident.lid FStar_Compiler_RBSet.t FStar_Pervasives_Native.option - FStar_Compiler_Effect.ref) - = - fun projectee -> - match projectee with | { sc_lid; sc_typ; sc_fvars;_} -> sc_fvars -let (sc_of_lid : FStar_Ident.lid -> search_candidate) = - fun lid -> - let uu___ = FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None in - let uu___1 = FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None in - { sc_lid = lid; sc_typ = uu___; sc_fvars = uu___1 } -let (sc_typ : - FStar_TypeChecker_Env.env -> search_candidate -> FStar_Syntax_Syntax.typ) = - fun tcenv -> - fun sc -> - let uu___ = FStar_Compiler_Effect.op_Bang sc.sc_typ in - match uu___ with - | FStar_Pervasives_Native.Some t -> t - | FStar_Pervasives_Native.None -> - let typ = - let uu___1 = FStar_TypeChecker_Env.try_lookup_lid tcenv sc.sc_lid in - match uu___1 with - | FStar_Pervasives_Native.None -> - FStar_Syntax_Syntax.mk FStar_Syntax_Syntax.Tm_unknown - FStar_Compiler_Range_Type.dummyRange - | FStar_Pervasives_Native.Some ((uu___2, typ1), uu___3) -> typ1 in - (FStar_Compiler_Effect.op_Colon_Equals sc.sc_typ - (FStar_Pervasives_Native.Some typ); - typ) -let (sc_fvars : - FStar_TypeChecker_Env.env -> - search_candidate -> FStar_Ident.lident FStar_Compiler_RBSet.t) - = - fun tcenv -> - fun sc -> - let uu___ = FStar_Compiler_Effect.op_Bang sc.sc_fvars in - match uu___ with - | FStar_Pervasives_Native.Some fv -> fv - | FStar_Pervasives_Native.None -> - let fv = - let uu___1 = sc_typ tcenv sc in FStar_Syntax_Free.fvars uu___1 in - (FStar_Compiler_Effect.op_Colon_Equals sc.sc_fvars - (FStar_Pervasives_Native.Some fv); - fv) -let (json_of_search_result : - FStar_TypeChecker_Env.env -> search_candidate -> FStar_Json.json) = - fun tcenv -> - fun sc -> - let typ_str = - let uu___ = sc_typ tcenv sc in - FStar_Interactive_QueryHelper.term_to_string tcenv uu___ in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Syntax_DsEnv.shorten_lid - tcenv.FStar_TypeChecker_Env.dsenv sc.sc_lid in - FStar_Ident.string_of_lid uu___4 in - FStar_Json.JsonStr uu___3 in - ("lid", uu___2) in - [uu___1; ("type", (FStar_Json.JsonStr typ_str))] in - FStar_Json.JsonAssoc uu___ -exception InvalidSearch of Prims.string -let (uu___is_InvalidSearch : Prims.exn -> Prims.bool) = - fun projectee -> - match projectee with | InvalidSearch uu___ -> true | uu___ -> false -let (__proj__InvalidSearch__item__uu___ : Prims.exn -> Prims.string) = - fun projectee -> match projectee with | InvalidSearch uu___ -> uu___ -let run_search : - 'uuuuu . - FStar_Interactive_Ide_Types.repl_state -> - Prims.string -> - ((FStar_Interactive_Ide_Types.query_status * FStar_Json.json) * - (FStar_Interactive_Ide_Types.repl_state, 'uuuuu) - FStar_Pervasives.either) - = - fun st -> - fun search_str -> - let tcenv = st.FStar_Interactive_Ide_Types.repl_env in - let st_matches candidate term = - let found = - match term.st_term with - | NameContainsStr str -> - let uu___ = FStar_Ident.string_of_lid candidate.sc_lid in - FStar_Compiler_Util.contains uu___ str - | TypeContainsLid lid -> - let uu___ = sc_fvars tcenv candidate in - FStar_Class_Setlike.mem () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Syntax.ord_fv)) lid (Obj.magic uu___) in - found <> term.st_negate in - let parse search_str1 = - let parse_one term = - let negate = FStar_Compiler_Util.starts_with term "-" in - let term1 = - if negate - then FStar_Compiler_Util.substring_from term Prims.int_one - else term in - let beg_quote = FStar_Compiler_Util.starts_with term1 "\"" in - let end_quote = FStar_Compiler_Util.ends_with term1 "\"" in - let strip_quotes str = - if (FStar_Compiler_String.length str) < (Prims.of_int (2)) - then - FStar_Compiler_Effect.raise (InvalidSearch "Empty search term") - else - FStar_Compiler_Util.substring str Prims.int_one - ((FStar_Compiler_String.length term1) - (Prims.of_int (2))) in - let parsed = - if beg_quote <> end_quote - then - let uu___ = - let uu___1 = - FStar_Compiler_Util.format1 - "Improperly quoted search term: %s" term1 in - InvalidSearch uu___1 in - FStar_Compiler_Effect.raise uu___ - else - if beg_quote - then - (let uu___1 = strip_quotes term1 in NameContainsStr uu___1) - else - (let lid = FStar_Ident.lid_of_str term1 in - let uu___2 = - FStar_Syntax_DsEnv.resolve_to_fully_qualified_name - tcenv.FStar_TypeChecker_Env.dsenv lid in - match uu___2 with - | FStar_Pervasives_Native.None -> - let uu___3 = - let uu___4 = - FStar_Compiler_Util.format1 "Unknown identifier: %s" - term1 in - InvalidSearch uu___4 in - FStar_Compiler_Effect.raise uu___3 - | FStar_Pervasives_Native.Some lid1 -> TypeContainsLid lid1) in - { st_negate = negate; st_term = parsed } in - let terms = - FStar_Compiler_List.map parse_one - (FStar_Compiler_Util.split search_str1 " ") in - let cmp x y = (st_cost x.st_term) - (st_cost y.st_term) in - FStar_Compiler_Util.sort_with cmp terms in - let pprint_one term = - let uu___ = - match term.st_term with - | NameContainsStr s -> FStar_Compiler_Util.format1 "\"%s\"" s - | TypeContainsLid l -> - let uu___1 = FStar_Ident.string_of_lid l in - FStar_Compiler_Util.format1 "%s" uu___1 in - Prims.strcat (if term.st_negate then "-" else "") uu___ in - let results = - try - (fun uu___ -> - match () with - | () -> - let terms = parse search_str in - let all_lidents = FStar_TypeChecker_Env.lidents tcenv in - let all_candidates = - FStar_Compiler_List.map sc_of_lid all_lidents in - let matches_all candidate = - FStar_Compiler_List.for_all (st_matches candidate) terms in - let cmp r1 r2 = - let uu___1 = FStar_Ident.string_of_lid r1.sc_lid in - let uu___2 = FStar_Ident.string_of_lid r2.sc_lid in - FStar_Compiler_Util.compare uu___1 uu___2 in - let results1 = - FStar_Compiler_List.filter matches_all all_candidates in - let sorted = FStar_Compiler_Util.sort_with cmp results1 in - let js = - FStar_Compiler_List.map (json_of_search_result tcenv) - sorted in - (match results1 with - | [] -> - let kwds = - let uu___1 = FStar_Compiler_List.map pprint_one terms in - FStar_Compiler_Util.concat_l " " uu___1 in - let uu___1 = - let uu___2 = - FStar_Compiler_Util.format1 - "No results found for query [%s]" kwds in - InvalidSearch uu___2 in - FStar_Compiler_Effect.raise uu___1 - | uu___1 -> - (FStar_Interactive_Ide_Types.QueryOK, - (FStar_Json.JsonList js)))) () - with - | InvalidSearch s -> - (FStar_Interactive_Ide_Types.QueryNOK, (FStar_Json.JsonStr s)) in - (results, (FStar_Pervasives.Inl st)) -let run_format_code : - 'uuuuu . - FStar_Interactive_Ide_Types.repl_state -> - Prims.string -> - ((FStar_Interactive_Ide_Types.query_status * FStar_Json.json) * - (FStar_Interactive_Ide_Types.repl_state, 'uuuuu) - FStar_Pervasives.either) - = - fun st -> - fun code -> - let code_or_err = FStar_Interactive_Incremental.format_code st code in - match code_or_err with - | FStar_Pervasives.Inl code1 -> - let result = - FStar_Json.JsonAssoc - [("formatted-code", (FStar_Json.JsonStr code1))] in - ((FStar_Interactive_Ide_Types.QueryOK, result), - (FStar_Pervasives.Inl st)) - | FStar_Pervasives.Inr issue -> - let result = - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Compiler_List.map - FStar_Interactive_Ide_Types.json_of_issue issue in - FStar_Json.JsonList uu___3 in - ("formatted-code-issue", uu___2) in - [uu___1] in - FStar_Json.JsonAssoc uu___ in - ((FStar_Interactive_Ide_Types.QueryNOK, result), - (FStar_Pervasives.Inl st)) -let (as_json_list : - ((FStar_Interactive_Ide_Types.query_status * FStar_Json.json) * - (FStar_Interactive_Ide_Types.repl_state, Prims.int) - FStar_Pervasives.either) -> - ((FStar_Interactive_Ide_Types.query_status * FStar_Json.json Prims.list) - * (FStar_Interactive_Ide_Types.repl_state, Prims.int) - FStar_Pervasives.either)) - = - fun q -> let uu___ = q in match uu___ with | ((q1, j), s) -> ((q1, [j]), s) -type run_query_result = - ((FStar_Interactive_Ide_Types.query_status * FStar_Json.json Prims.list) * - (FStar_Interactive_Ide_Types.repl_state, Prims.int) - FStar_Pervasives.either) -let (maybe_cancel_queries : - FStar_Interactive_Ide_Types.repl_state -> - FStar_Interactive_Ide_Types.query Prims.list -> - (FStar_Interactive_Ide_Types.query Prims.list * - FStar_Interactive_Ide_Types.repl_state)) - = - fun st -> - fun l -> - let log_cancellation l1 = - let uu___ = FStar_Compiler_Effect.op_Bang dbg in - if uu___ - then - FStar_Compiler_List.iter - (fun q -> - let uu___1 = FStar_Interactive_Ide_Types.query_to_string q in - FStar_Compiler_Util.print1 "Cancelling query: %s\n" uu___1) l1 - else () in - match st.FStar_Interactive_Ide_Types.repl_buffered_input_queries with - | { - FStar_Interactive_Ide_Types.qq = FStar_Interactive_Ide_Types.Cancel - p; - FStar_Interactive_Ide_Types.qid = uu___;_}::rest -> - let st1 = - { - FStar_Interactive_Ide_Types.repl_line = - (st.FStar_Interactive_Ide_Types.repl_line); - FStar_Interactive_Ide_Types.repl_column = - (st.FStar_Interactive_Ide_Types.repl_column); - FStar_Interactive_Ide_Types.repl_fname = - (st.FStar_Interactive_Ide_Types.repl_fname); - FStar_Interactive_Ide_Types.repl_deps_stack = - (st.FStar_Interactive_Ide_Types.repl_deps_stack); - FStar_Interactive_Ide_Types.repl_curmod = - (st.FStar_Interactive_Ide_Types.repl_curmod); - FStar_Interactive_Ide_Types.repl_env = - (st.FStar_Interactive_Ide_Types.repl_env); - FStar_Interactive_Ide_Types.repl_stdin = - (st.FStar_Interactive_Ide_Types.repl_stdin); - FStar_Interactive_Ide_Types.repl_names = - (st.FStar_Interactive_Ide_Types.repl_names); - FStar_Interactive_Ide_Types.repl_buffered_input_queries = rest; - FStar_Interactive_Ide_Types.repl_lang = - (st.FStar_Interactive_Ide_Types.repl_lang) - } in - (match p with - | FStar_Pervasives_Native.None -> (log_cancellation l; ([], st1)) - | FStar_Pervasives_Native.Some p1 -> - let query_ahead_of p2 q = - let uu___1 = p2 in - match uu___1 with - | (uu___2, l1, c) -> - (match q.FStar_Interactive_Ide_Types.qq with - | FStar_Interactive_Ide_Types.Push pq -> - pq.FStar_Interactive_Ide_Types.push_line >= l1 - | uu___3 -> false) in - let l1 = - let uu___1 = - FStar_Compiler_Util.prefix_until (query_ahead_of p1) l in - match uu___1 with - | FStar_Pervasives_Native.None -> l - | FStar_Pervasives_Native.Some (l2, q, qs) -> - (log_cancellation (q :: qs); l2) in - (l1, st1)) - | uu___ -> (l, st) -let rec (fold_query : - (FStar_Interactive_Ide_Types.repl_state -> - FStar_Interactive_Ide_Types.query -> run_query_result) - -> - FStar_Interactive_Ide_Types.query Prims.list -> - FStar_Interactive_Ide_Types.repl_state -> run_query_result) - = - fun f -> - fun l -> - fun st -> - match l with - | [] -> - ((FStar_Interactive_Ide_Types.QueryOK, []), - (FStar_Pervasives.Inl st)) - | q::l1 -> - let uu___ = f st q in - (match uu___ with - | ((status, responses), st') -> - (FStar_Compiler_List.iter - (write_response q.FStar_Interactive_Ide_Types.qid status) - responses; - (match (status, st') with - | (FStar_Interactive_Ide_Types.QueryOK, - FStar_Pervasives.Inl st1) -> - let st2 = buffer_input_queries st1 in - let uu___2 = maybe_cancel_queries st2 l1 in - (match uu___2 with | (l2, st3) -> fold_query f l2 st3) - | uu___2 -> ((status, []), st')))) -let (validate_query : - FStar_Interactive_Ide_Types.repl_state -> - FStar_Interactive_Ide_Types.query -> FStar_Interactive_Ide_Types.query) - = - fun st -> - fun q -> - match q.FStar_Interactive_Ide_Types.qq with - | FStar_Interactive_Ide_Types.Push - { - FStar_Interactive_Ide_Types.push_kind = - FStar_Interactive_Ide_Types.SyntaxCheck; - FStar_Interactive_Ide_Types.push_line = uu___; - FStar_Interactive_Ide_Types.push_column = uu___1; - FStar_Interactive_Ide_Types.push_peek_only = false; - FStar_Interactive_Ide_Types.push_code_or_decl = uu___2;_} - -> - { - FStar_Interactive_Ide_Types.qq = - (FStar_Interactive_Ide_Types.ProtocolViolation - "Cannot use 'kind': 'syntax' with 'query': 'push'"); - FStar_Interactive_Ide_Types.qid = - (q.FStar_Interactive_Ide_Types.qid) - } - | uu___ -> - (match st.FStar_Interactive_Ide_Types.repl_curmod with - | FStar_Pervasives_Native.None when - FStar_Interactive_Ide_Types.query_needs_current_module - q.FStar_Interactive_Ide_Types.qq - -> - { - FStar_Interactive_Ide_Types.qq = - (FStar_Interactive_Ide_Types.GenericError - "Current module unset"); - FStar_Interactive_Ide_Types.qid = - (q.FStar_Interactive_Ide_Types.qid) - } - | uu___1 -> q) -let rec (run_query : - FStar_Interactive_Ide_Types.repl_state -> - FStar_Interactive_Ide_Types.query -> - ((FStar_Interactive_Ide_Types.query_status * FStar_Json.json - Prims.list) * (FStar_Interactive_Ide_Types.repl_state, Prims.int) - FStar_Pervasives.either)) - = - fun st -> - fun q -> - match q.FStar_Interactive_Ide_Types.qq with - | FStar_Interactive_Ide_Types.Exit -> as_json_list (run_exit st) - | FStar_Interactive_Ide_Types.DescribeProtocol -> - as_json_list (run_describe_protocol st) - | FStar_Interactive_Ide_Types.DescribeRepl -> - let uu___ = run_describe_repl st in as_json_list uu___ - | FStar_Interactive_Ide_Types.GenericError message -> - as_json_list (run_generic_error st message) - | FStar_Interactive_Ide_Types.ProtocolViolation query -> - as_json_list (run_protocol_violation st query) - | FStar_Interactive_Ide_Types.Segment c -> - let uu___ = run_segment st c in as_json_list uu___ - | FStar_Interactive_Ide_Types.VfsAdd (fname, contents) -> - let uu___ = run_vfs_add st fname contents in as_json_list uu___ - | FStar_Interactive_Ide_Types.Push pquery -> - let uu___ = run_push st pquery in as_json_list uu___ - | FStar_Interactive_Ide_Types.PushPartialCheckedFile decl_name -> - let uu___ = run_load_partial_file st decl_name in - as_json_list uu___ - | FStar_Interactive_Ide_Types.Pop -> - let uu___ = run_pop st in as_json_list uu___ - | FStar_Interactive_Ide_Types.FullBuffer - (code, full_kind, with_symbols) -> - (write_full_buffer_fragment_progress - FStar_Interactive_Incremental.FullBufferStarted; - (let uu___1 = - FStar_Interactive_Incremental.run_full_buffer st - q.FStar_Interactive_Ide_Types.qid code full_kind with_symbols - write_full_buffer_fragment_progress in - match uu___1 with - | (queries, issues) -> - (FStar_Compiler_List.iter - (write_response q.FStar_Interactive_Ide_Types.qid - FStar_Interactive_Ide_Types.QueryOK) issues; - (let res = fold_query validate_and_run_query queries st in - write_full_buffer_fragment_progress - FStar_Interactive_Incremental.FullBufferFinished; - res)))) - | FStar_Interactive_Ide_Types.AutoComplete (search_term1, context) -> - let uu___ = run_autocomplete st search_term1 context in - as_json_list uu___ - | FStar_Interactive_Ide_Types.Lookup - (symbol, context, pos_opt, rq_info, symrange) -> - run_lookup st symbol context pos_opt rq_info symrange - | FStar_Interactive_Ide_Types.Compute (term, rules) -> - let uu___ = run_compute st term rules in as_json_list uu___ - | FStar_Interactive_Ide_Types.Search term -> - let uu___ = run_search st term in as_json_list uu___ - | FStar_Interactive_Ide_Types.Callback f -> f st - | FStar_Interactive_Ide_Types.Format code -> - let uu___ = run_format_code st code in as_json_list uu___ - | FStar_Interactive_Ide_Types.RestartSolver -> - (((st.FStar_Interactive_Ide_Types.repl_env).FStar_TypeChecker_Env.solver).FStar_TypeChecker_Env.refresh - FStar_Pervasives_Native.None; - ((FStar_Interactive_Ide_Types.QueryOK, []), - (FStar_Pervasives.Inl st))) - | FStar_Interactive_Ide_Types.Cancel uu___ -> - ((FStar_Interactive_Ide_Types.QueryOK, []), - (FStar_Pervasives.Inl st)) -and (validate_and_run_query : - FStar_Interactive_Ide_Types.repl_state -> - FStar_Interactive_Ide_Types.query -> run_query_result) - = - fun st -> - fun query -> - let query1 = validate_query st query in - FStar_Compiler_Effect.op_Colon_Equals repl_current_qid - (FStar_Pervasives_Native.Some - (query1.FStar_Interactive_Ide_Types.qid)); - (let uu___2 = FStar_Compiler_Effect.op_Bang dbg in - if uu___2 - then - let uu___3 = FStar_Interactive_Ide_Types.query_to_string query1 in - FStar_Compiler_Util.print2 "Running query %s: %s\n" - query1.FStar_Interactive_Ide_Types.qid uu___3 - else ()); - run_query st query1 -let (js_repl_eval : - FStar_Interactive_Ide_Types.repl_state -> - FStar_Interactive_Ide_Types.query -> - (FStar_Json.json Prims.list * (FStar_Interactive_Ide_Types.repl_state, - Prims.int) FStar_Pervasives.either)) - = - fun st -> - fun query -> - let uu___ = validate_and_run_query st query in - match uu___ with - | ((status, responses), st_opt) -> - let js_responses = - FStar_Compiler_List.map - (json_of_response query.FStar_Interactive_Ide_Types.qid status) - responses in - (js_responses, st_opt) -let (js_repl_eval_js : - FStar_Interactive_Ide_Types.repl_state -> - FStar_Json.json -> - (FStar_Json.json Prims.list * (FStar_Interactive_Ide_Types.repl_state, - Prims.int) FStar_Pervasives.either)) - = - fun st -> - fun query_js -> - let uu___ = deserialize_interactive_query query_js in - js_repl_eval st uu___ -let (js_repl_eval_str : - FStar_Interactive_Ide_Types.repl_state -> - Prims.string -> - (Prims.string Prims.list * (FStar_Interactive_Ide_Types.repl_state, - Prims.int) FStar_Pervasives.either)) - = - fun st -> - fun query_str -> - let uu___ = - let uu___1 = parse_interactive_query query_str in - js_repl_eval st uu___1 in - match uu___ with - | (js_response, st_opt) -> - let uu___1 = - FStar_Compiler_List.map FStar_Json.string_of_json js_response in - (uu___1, st_opt) -let (js_repl_init_opts : unit -> unit) = - fun uu___ -> - let uu___1 = FStar_Options.parse_cmd_line () in - match uu___1 with - | (res, fnames) -> - (match res with - | FStar_Getopt.Error msg -> - failwith (Prims.strcat "repl_init: " msg) - | FStar_Getopt.Help -> failwith "repl_init: --help unexpected" - | FStar_Getopt.Success -> - (match fnames with - | [] -> - failwith - "repl_init: No file name given in --ide invocation" - | h::uu___2::uu___3 -> - failwith - "repl_init: Too many file names given in --ide invocation" - | uu___2 -> ())) -let rec (go : FStar_Interactive_Ide_Types.repl_state -> Prims.int) = - fun st -> - let uu___ = read_interactive_query st in - match uu___ with - | (query, st1) -> - let uu___1 = validate_and_run_query st1 query in - (match uu___1 with - | ((status, responses), state_opt) -> - (FStar_Compiler_List.iter - (write_response query.FStar_Interactive_Ide_Types.qid status) - responses; - (match state_opt with - | FStar_Pervasives.Inl st' -> go st' - | FStar_Pervasives.Inr exitcode -> exitcode))) -let (interactive_error_handler : FStar_Errors.error_handler) = - let issues = FStar_Compiler_Util.mk_ref [] in - let add_one e = - let uu___ = - let uu___1 = FStar_Compiler_Effect.op_Bang issues in e :: uu___1 in - FStar_Compiler_Effect.op_Colon_Equals issues uu___ in - let count_errors uu___ = - let issues1 = - let uu___1 = FStar_Compiler_Effect.op_Bang issues in - FStar_Compiler_Util.remove_dups (fun i0 -> fun i1 -> i0 = i1) uu___1 in - let uu___1 = - FStar_Compiler_List.filter - (fun e -> e.FStar_Errors.issue_level = FStar_Errors.EError) issues1 in - FStar_Compiler_List.length uu___1 in - let report uu___ = - let uu___1 = - let uu___2 = FStar_Compiler_Effect.op_Bang issues in - FStar_Compiler_Util.remove_dups (fun i0 -> fun i1 -> i0 = i1) uu___2 in - FStar_Compiler_List.sortWith FStar_Errors.compare_issues uu___1 in - let clear uu___ = FStar_Compiler_Effect.op_Colon_Equals issues [] in - { - FStar_Errors.eh_name = "interactive error handler"; - FStar_Errors.eh_add_one = add_one; - FStar_Errors.eh_count_errors = count_errors; - FStar_Errors.eh_report = report; - FStar_Errors.eh_clear = clear - } -let (interactive_printer : - (FStar_Json.json -> unit) -> FStar_Compiler_Util.printer) = - fun printer -> - { - FStar_Compiler_Util.printer_prinfo = - (fun s -> forward_message printer "info" (FStar_Json.JsonStr s)); - FStar_Compiler_Util.printer_prwarning = - (fun s -> forward_message printer "warning" (FStar_Json.JsonStr s)); - FStar_Compiler_Util.printer_prerror = - (fun s -> forward_message printer "error" (FStar_Json.JsonStr s)); - FStar_Compiler_Util.printer_prgeneric = - (fun label -> - fun get_string -> - fun get_json -> - let uu___ = get_json () in forward_message printer label uu___) - } -let (install_ide_mode_hooks : (FStar_Json.json -> unit) -> unit) = - fun printer -> - FStar_Compiler_Util.set_printer (interactive_printer printer); - FStar_Errors.set_handler interactive_error_handler -let (build_initial_repl_state : - Prims.string -> FStar_Interactive_Ide_Types.repl_state) = - fun filename -> - let env = FStar_Universal.init_env FStar_Parser_Dep.empty_deps in - let env1 = - FStar_TypeChecker_Env.set_range env - FStar_Interactive_Ide_Types.initial_range in - FStar_Options.set_ide_filename filename; - (let uu___1 = FStar_Compiler_Util.open_stdin () in - { - FStar_Interactive_Ide_Types.repl_line = Prims.int_one; - FStar_Interactive_Ide_Types.repl_column = Prims.int_zero; - FStar_Interactive_Ide_Types.repl_fname = filename; - FStar_Interactive_Ide_Types.repl_deps_stack = []; - FStar_Interactive_Ide_Types.repl_curmod = FStar_Pervasives_Native.None; - FStar_Interactive_Ide_Types.repl_env = env1; - FStar_Interactive_Ide_Types.repl_stdin = uu___1; - FStar_Interactive_Ide_Types.repl_names = - FStar_Interactive_CompletionTable.empty; - FStar_Interactive_Ide_Types.repl_buffered_input_queries = []; - FStar_Interactive_Ide_Types.repl_lang = [] - }) -let interactive_mode' : - 'uuuuu . FStar_Interactive_Ide_Types.repl_state -> 'uuuuu = - fun init_st -> - write_hello (); - (let exit_code = - let uu___1 = - (FStar_Options.record_hints ()) || (FStar_Options.use_hints ()) in - if uu___1 - then - let uu___2 = - let uu___3 = FStar_Options.file_list () in - FStar_Compiler_List.hd uu___3 in - FStar_SMTEncoding_Solver.with_hints_db uu___2 - (fun uu___3 -> go init_st) - else go init_st in - FStar_Compiler_Effect.exit exit_code) -let (interactive_mode : Prims.string -> unit) = - fun filename -> - install_ide_mode_hooks FStar_Interactive_JsonHelper.write_json; - FStar_Compiler_Util.set_sigint_handler FStar_Compiler_Util.sigint_ignore; - (let uu___3 = - let uu___4 = FStar_Options.codegen () in - FStar_Compiler_Option.isSome uu___4 in - if uu___3 - then - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_IDEIgnoreCodeGen () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic "--ide: ignoring --codegen") - else ()); - (let init = build_initial_repl_state filename in - let uu___3 = FStar_Options.trace_error () in - if uu___3 - then interactive_mode' init - else - (try (fun uu___5 -> match () with | () -> interactive_mode' init) () - with - | uu___5 -> - (FStar_Errors.set_handler FStar_Errors.default_handler; - FStar_Compiler_Effect.raise uu___5))) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Interactive_Ide_Types.ml b/ocaml/fstar-lib/generated/FStar_Interactive_Ide_Types.ml deleted file mode 100644 index 593a4b208a8..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Interactive_Ide_Types.ml +++ /dev/null @@ -1,689 +0,0 @@ -open Prims -let (initial_range : FStar_Compiler_Range_Type.range) = - let uu___ = FStar_Compiler_Range_Type.mk_pos Prims.int_one Prims.int_zero in - let uu___1 = FStar_Compiler_Range_Type.mk_pos Prims.int_one Prims.int_zero in - FStar_Compiler_Range_Type.mk_range "" uu___ uu___1 -type completion_context = - | CKCode - | CKOption of Prims.bool - | CKModuleOrNamespace of (Prims.bool * Prims.bool) -let (uu___is_CKCode : completion_context -> Prims.bool) = - fun projectee -> match projectee with | CKCode -> true | uu___ -> false -let (uu___is_CKOption : completion_context -> Prims.bool) = - fun projectee -> - match projectee with | CKOption _0 -> true | uu___ -> false -let (__proj__CKOption__item___0 : completion_context -> Prims.bool) = - fun projectee -> match projectee with | CKOption _0 -> _0 -let (uu___is_CKModuleOrNamespace : completion_context -> Prims.bool) = - fun projectee -> - match projectee with | CKModuleOrNamespace _0 -> true | uu___ -> false -let (__proj__CKModuleOrNamespace__item___0 : - completion_context -> (Prims.bool * Prims.bool)) = - fun projectee -> match projectee with | CKModuleOrNamespace _0 -> _0 -type lookup_context = - | LKSymbolOnly - | LKModule - | LKOption - | LKCode -let (uu___is_LKSymbolOnly : lookup_context -> Prims.bool) = - fun projectee -> - match projectee with | LKSymbolOnly -> true | uu___ -> false -let (uu___is_LKModule : lookup_context -> Prims.bool) = - fun projectee -> match projectee with | LKModule -> true | uu___ -> false -let (uu___is_LKOption : lookup_context -> Prims.bool) = - fun projectee -> match projectee with | LKOption -> true | uu___ -> false -let (uu___is_LKCode : lookup_context -> Prims.bool) = - fun projectee -> match projectee with | LKCode -> true | uu___ -> false -type position = (Prims.string * Prims.int * Prims.int) -type push_kind = - | SyntaxCheck - | LaxCheck - | FullCheck -let (uu___is_SyntaxCheck : push_kind -> Prims.bool) = - fun projectee -> - match projectee with | SyntaxCheck -> true | uu___ -> false -let (uu___is_LaxCheck : push_kind -> Prims.bool) = - fun projectee -> match projectee with | LaxCheck -> true | uu___ -> false -let (uu___is_FullCheck : push_kind -> Prims.bool) = - fun projectee -> match projectee with | FullCheck -> true | uu___ -> false -type push_query = - { - push_kind: push_kind ; - push_line: Prims.int ; - push_column: Prims.int ; - push_peek_only: Prims.bool ; - push_code_or_decl: - (Prims.string, - (FStar_Parser_AST.decl * FStar_Parser_ParseIt.code_fragment)) - FStar_Pervasives.either - } -let (__proj__Mkpush_query__item__push_kind : push_query -> push_kind) = - fun projectee -> - match projectee with - | { push_kind = push_kind1; push_line; push_column; push_peek_only; - push_code_or_decl;_} -> push_kind1 -let (__proj__Mkpush_query__item__push_line : push_query -> Prims.int) = - fun projectee -> - match projectee with - | { push_kind = push_kind1; push_line; push_column; push_peek_only; - push_code_or_decl;_} -> push_line -let (__proj__Mkpush_query__item__push_column : push_query -> Prims.int) = - fun projectee -> - match projectee with - | { push_kind = push_kind1; push_line; push_column; push_peek_only; - push_code_or_decl;_} -> push_column -let (__proj__Mkpush_query__item__push_peek_only : push_query -> Prims.bool) = - fun projectee -> - match projectee with - | { push_kind = push_kind1; push_line; push_column; push_peek_only; - push_code_or_decl;_} -> push_peek_only -let (__proj__Mkpush_query__item__push_code_or_decl : - push_query -> - (Prims.string, - (FStar_Parser_AST.decl * FStar_Parser_ParseIt.code_fragment)) - FStar_Pervasives.either) - = - fun projectee -> - match projectee with - | { push_kind = push_kind1; push_line; push_column; push_peek_only; - push_code_or_decl;_} -> push_code_or_decl -type lookup_symbol_range = FStar_Json.json -type query_status = - | QueryOK - | QueryNOK - | QueryViolatesProtocol -let (uu___is_QueryOK : query_status -> Prims.bool) = - fun projectee -> match projectee with | QueryOK -> true | uu___ -> false -let (uu___is_QueryNOK : query_status -> Prims.bool) = - fun projectee -> match projectee with | QueryNOK -> true | uu___ -> false -let (uu___is_QueryViolatesProtocol : query_status -> Prims.bool) = - fun projectee -> - match projectee with | QueryViolatesProtocol -> true | uu___ -> false -type repl_depth_t = (FStar_TypeChecker_Env.tcenv_depth_t * Prims.int) -type optmod_t = FStar_Syntax_Syntax.modul FStar_Pervasives_Native.option -type timed_fname = - { - tf_fname: Prims.string ; - tf_modtime: FStar_Compiler_Util.time } -let (__proj__Mktimed_fname__item__tf_fname : timed_fname -> Prims.string) = - fun projectee -> - match projectee with | { tf_fname; tf_modtime;_} -> tf_fname -let (__proj__Mktimed_fname__item__tf_modtime : - timed_fname -> FStar_Compiler_Util.time) = - fun projectee -> - match projectee with | { tf_fname; tf_modtime;_} -> tf_modtime -type repl_task = - | LDInterleaved of (timed_fname * timed_fname) - | LDSingle of timed_fname - | LDInterfaceOfCurrentFile of timed_fname - | PushFragment of ((FStar_Parser_ParseIt.input_frag, FStar_Parser_AST.decl) - FStar_Pervasives.either * push_kind * FStar_Json.json Prims.list) - | Noop -let (uu___is_LDInterleaved : repl_task -> Prims.bool) = - fun projectee -> - match projectee with | LDInterleaved _0 -> true | uu___ -> false -let (__proj__LDInterleaved__item___0 : - repl_task -> (timed_fname * timed_fname)) = - fun projectee -> match projectee with | LDInterleaved _0 -> _0 -let (uu___is_LDSingle : repl_task -> Prims.bool) = - fun projectee -> - match projectee with | LDSingle _0 -> true | uu___ -> false -let (__proj__LDSingle__item___0 : repl_task -> timed_fname) = - fun projectee -> match projectee with | LDSingle _0 -> _0 -let (uu___is_LDInterfaceOfCurrentFile : repl_task -> Prims.bool) = - fun projectee -> - match projectee with - | LDInterfaceOfCurrentFile _0 -> true - | uu___ -> false -let (__proj__LDInterfaceOfCurrentFile__item___0 : repl_task -> timed_fname) = - fun projectee -> match projectee with | LDInterfaceOfCurrentFile _0 -> _0 -let (uu___is_PushFragment : repl_task -> Prims.bool) = - fun projectee -> - match projectee with | PushFragment _0 -> true | uu___ -> false -let (__proj__PushFragment__item___0 : - repl_task -> - ((FStar_Parser_ParseIt.input_frag, FStar_Parser_AST.decl) - FStar_Pervasives.either * push_kind * FStar_Json.json Prims.list)) - = fun projectee -> match projectee with | PushFragment _0 -> _0 -let (uu___is_Noop : repl_task -> Prims.bool) = - fun projectee -> match projectee with | Noop -> true | uu___ -> false -type full_buffer_request_kind = - | Full - | Lax - | Cache - | ReloadDeps - | VerifyToPosition of position - | LaxToPosition of position -let (uu___is_Full : full_buffer_request_kind -> Prims.bool) = - fun projectee -> match projectee with | Full -> true | uu___ -> false -let (uu___is_Lax : full_buffer_request_kind -> Prims.bool) = - fun projectee -> match projectee with | Lax -> true | uu___ -> false -let (uu___is_Cache : full_buffer_request_kind -> Prims.bool) = - fun projectee -> match projectee with | Cache -> true | uu___ -> false -let (uu___is_ReloadDeps : full_buffer_request_kind -> Prims.bool) = - fun projectee -> match projectee with | ReloadDeps -> true | uu___ -> false -let (uu___is_VerifyToPosition : full_buffer_request_kind -> Prims.bool) = - fun projectee -> - match projectee with | VerifyToPosition _0 -> true | uu___ -> false -let (__proj__VerifyToPosition__item___0 : - full_buffer_request_kind -> position) = - fun projectee -> match projectee with | VerifyToPosition _0 -> _0 -let (uu___is_LaxToPosition : full_buffer_request_kind -> Prims.bool) = - fun projectee -> - match projectee with | LaxToPosition _0 -> true | uu___ -> false -let (__proj__LaxToPosition__item___0 : full_buffer_request_kind -> position) - = fun projectee -> match projectee with | LaxToPosition _0 -> _0 -type query' = - | Exit - | DescribeProtocol - | DescribeRepl - | Segment of Prims.string - | Pop - | Push of push_query - | PushPartialCheckedFile of Prims.string - | VfsAdd of (Prims.string FStar_Pervasives_Native.option * Prims.string) - | AutoComplete of (Prims.string * completion_context) - | Lookup of (Prims.string * lookup_context * position - FStar_Pervasives_Native.option * Prims.string Prims.list * - lookup_symbol_range FStar_Pervasives_Native.option) - | Compute of (Prims.string * FStar_TypeChecker_Env.step Prims.list - FStar_Pervasives_Native.option) - | Search of Prims.string - | GenericError of Prims.string - | ProtocolViolation of Prims.string - | FullBuffer of (Prims.string * full_buffer_request_kind * Prims.bool) - | Callback of - (repl_state -> - ((query_status * FStar_Json.json Prims.list) * (repl_state, Prims.int) - FStar_Pervasives.either)) - - | Format of Prims.string - | RestartSolver - | Cancel of position FStar_Pervasives_Native.option -and query = { - qq: query' ; - qid: Prims.string } -and repl_state = - { - repl_line: Prims.int ; - repl_column: Prims.int ; - repl_fname: Prims.string ; - repl_deps_stack: (repl_depth_t * (repl_task * repl_state)) Prims.list ; - repl_curmod: optmod_t ; - repl_env: FStar_TypeChecker_Env.env ; - repl_stdin: FStar_Compiler_Util.stream_reader ; - repl_names: FStar_Interactive_CompletionTable.table ; - repl_buffered_input_queries: query Prims.list ; - repl_lang: FStar_Universal.lang_decls_t } -let (uu___is_Exit : query' -> Prims.bool) = - fun projectee -> match projectee with | Exit -> true | uu___ -> false -let (uu___is_DescribeProtocol : query' -> Prims.bool) = - fun projectee -> - match projectee with | DescribeProtocol -> true | uu___ -> false -let (uu___is_DescribeRepl : query' -> Prims.bool) = - fun projectee -> - match projectee with | DescribeRepl -> true | uu___ -> false -let (uu___is_Segment : query' -> Prims.bool) = - fun projectee -> match projectee with | Segment _0 -> true | uu___ -> false -let (__proj__Segment__item___0 : query' -> Prims.string) = - fun projectee -> match projectee with | Segment _0 -> _0 -let (uu___is_Pop : query' -> Prims.bool) = - fun projectee -> match projectee with | Pop -> true | uu___ -> false -let (uu___is_Push : query' -> Prims.bool) = - fun projectee -> match projectee with | Push _0 -> true | uu___ -> false -let (__proj__Push__item___0 : query' -> push_query) = - fun projectee -> match projectee with | Push _0 -> _0 -let (uu___is_PushPartialCheckedFile : query' -> Prims.bool) = - fun projectee -> - match projectee with | PushPartialCheckedFile _0 -> true | uu___ -> false -let (__proj__PushPartialCheckedFile__item___0 : query' -> Prims.string) = - fun projectee -> match projectee with | PushPartialCheckedFile _0 -> _0 -let (uu___is_VfsAdd : query' -> Prims.bool) = - fun projectee -> match projectee with | VfsAdd _0 -> true | uu___ -> false -let (__proj__VfsAdd__item___0 : - query' -> (Prims.string FStar_Pervasives_Native.option * Prims.string)) = - fun projectee -> match projectee with | VfsAdd _0 -> _0 -let (uu___is_AutoComplete : query' -> Prims.bool) = - fun projectee -> - match projectee with | AutoComplete _0 -> true | uu___ -> false -let (__proj__AutoComplete__item___0 : - query' -> (Prims.string * completion_context)) = - fun projectee -> match projectee with | AutoComplete _0 -> _0 -let (uu___is_Lookup : query' -> Prims.bool) = - fun projectee -> match projectee with | Lookup _0 -> true | uu___ -> false -let (__proj__Lookup__item___0 : - query' -> - (Prims.string * lookup_context * position FStar_Pervasives_Native.option - * Prims.string Prims.list * lookup_symbol_range - FStar_Pervasives_Native.option)) - = fun projectee -> match projectee with | Lookup _0 -> _0 -let (uu___is_Compute : query' -> Prims.bool) = - fun projectee -> match projectee with | Compute _0 -> true | uu___ -> false -let (__proj__Compute__item___0 : - query' -> - (Prims.string * FStar_TypeChecker_Env.step Prims.list - FStar_Pervasives_Native.option)) - = fun projectee -> match projectee with | Compute _0 -> _0 -let (uu___is_Search : query' -> Prims.bool) = - fun projectee -> match projectee with | Search _0 -> true | uu___ -> false -let (__proj__Search__item___0 : query' -> Prims.string) = - fun projectee -> match projectee with | Search _0 -> _0 -let (uu___is_GenericError : query' -> Prims.bool) = - fun projectee -> - match projectee with | GenericError _0 -> true | uu___ -> false -let (__proj__GenericError__item___0 : query' -> Prims.string) = - fun projectee -> match projectee with | GenericError _0 -> _0 -let (uu___is_ProtocolViolation : query' -> Prims.bool) = - fun projectee -> - match projectee with | ProtocolViolation _0 -> true | uu___ -> false -let (__proj__ProtocolViolation__item___0 : query' -> Prims.string) = - fun projectee -> match projectee with | ProtocolViolation _0 -> _0 -let (uu___is_FullBuffer : query' -> Prims.bool) = - fun projectee -> - match projectee with | FullBuffer _0 -> true | uu___ -> false -let (__proj__FullBuffer__item___0 : - query' -> (Prims.string * full_buffer_request_kind * Prims.bool)) = - fun projectee -> match projectee with | FullBuffer _0 -> _0 -let (uu___is_Callback : query' -> Prims.bool) = - fun projectee -> - match projectee with | Callback _0 -> true | uu___ -> false -let (__proj__Callback__item___0 : - query' -> - repl_state -> - ((query_status * FStar_Json.json Prims.list) * (repl_state, Prims.int) - FStar_Pervasives.either)) - = fun projectee -> match projectee with | Callback _0 -> _0 -let (uu___is_Format : query' -> Prims.bool) = - fun projectee -> match projectee with | Format _0 -> true | uu___ -> false -let (__proj__Format__item___0 : query' -> Prims.string) = - fun projectee -> match projectee with | Format _0 -> _0 -let (uu___is_RestartSolver : query' -> Prims.bool) = - fun projectee -> - match projectee with | RestartSolver -> true | uu___ -> false -let (uu___is_Cancel : query' -> Prims.bool) = - fun projectee -> match projectee with | Cancel _0 -> true | uu___ -> false -let (__proj__Cancel__item___0 : - query' -> position FStar_Pervasives_Native.option) = - fun projectee -> match projectee with | Cancel _0 -> _0 -let (__proj__Mkquery__item__qq : query -> query') = - fun projectee -> match projectee with | { qq; qid;_} -> qq -let (__proj__Mkquery__item__qid : query -> Prims.string) = - fun projectee -> match projectee with | { qq; qid;_} -> qid -let (__proj__Mkrepl_state__item__repl_line : repl_state -> Prims.int) = - fun projectee -> - match projectee with - | { repl_line; repl_column; repl_fname; repl_deps_stack; repl_curmod; - repl_env; repl_stdin; repl_names; repl_buffered_input_queries; - repl_lang;_} -> repl_line -let (__proj__Mkrepl_state__item__repl_column : repl_state -> Prims.int) = - fun projectee -> - match projectee with - | { repl_line; repl_column; repl_fname; repl_deps_stack; repl_curmod; - repl_env; repl_stdin; repl_names; repl_buffered_input_queries; - repl_lang;_} -> repl_column -let (__proj__Mkrepl_state__item__repl_fname : repl_state -> Prims.string) = - fun projectee -> - match projectee with - | { repl_line; repl_column; repl_fname; repl_deps_stack; repl_curmod; - repl_env; repl_stdin; repl_names; repl_buffered_input_queries; - repl_lang;_} -> repl_fname -let (__proj__Mkrepl_state__item__repl_deps_stack : - repl_state -> (repl_depth_t * (repl_task * repl_state)) Prims.list) = - fun projectee -> - match projectee with - | { repl_line; repl_column; repl_fname; repl_deps_stack; repl_curmod; - repl_env; repl_stdin; repl_names; repl_buffered_input_queries; - repl_lang;_} -> repl_deps_stack -let (__proj__Mkrepl_state__item__repl_curmod : repl_state -> optmod_t) = - fun projectee -> - match projectee with - | { repl_line; repl_column; repl_fname; repl_deps_stack; repl_curmod; - repl_env; repl_stdin; repl_names; repl_buffered_input_queries; - repl_lang;_} -> repl_curmod -let (__proj__Mkrepl_state__item__repl_env : - repl_state -> FStar_TypeChecker_Env.env) = - fun projectee -> - match projectee with - | { repl_line; repl_column; repl_fname; repl_deps_stack; repl_curmod; - repl_env; repl_stdin; repl_names; repl_buffered_input_queries; - repl_lang;_} -> repl_env -let (__proj__Mkrepl_state__item__repl_stdin : - repl_state -> FStar_Compiler_Util.stream_reader) = - fun projectee -> - match projectee with - | { repl_line; repl_column; repl_fname; repl_deps_stack; repl_curmod; - repl_env; repl_stdin; repl_names; repl_buffered_input_queries; - repl_lang;_} -> repl_stdin -let (__proj__Mkrepl_state__item__repl_names : - repl_state -> FStar_Interactive_CompletionTable.table) = - fun projectee -> - match projectee with - | { repl_line; repl_column; repl_fname; repl_deps_stack; repl_curmod; - repl_env; repl_stdin; repl_names; repl_buffered_input_queries; - repl_lang;_} -> repl_names -let (__proj__Mkrepl_state__item__repl_buffered_input_queries : - repl_state -> query Prims.list) = - fun projectee -> - match projectee with - | { repl_line; repl_column; repl_fname; repl_deps_stack; repl_curmod; - repl_env; repl_stdin; repl_names; repl_buffered_input_queries; - repl_lang;_} -> repl_buffered_input_queries -let (__proj__Mkrepl_state__item__repl_lang : - repl_state -> FStar_Universal.lang_decls_t) = - fun projectee -> - match projectee with - | { repl_line; repl_column; repl_fname; repl_deps_stack; repl_curmod; - repl_env; repl_stdin; repl_names; repl_buffered_input_queries; - repl_lang;_} -> repl_lang -type callback_t = - repl_state -> - ((query_status * FStar_Json.json Prims.list) * (repl_state, Prims.int) - FStar_Pervasives.either) -type repl_stack_entry_t = (repl_depth_t * (repl_task * repl_state)) -type repl_stack_t = (repl_depth_t * (repl_task * repl_state)) Prims.list -type grepl_state = - { - grepl_repls: repl_state FStar_Compiler_Util.psmap ; - grepl_stdin: FStar_Compiler_Util.stream_reader } -let (__proj__Mkgrepl_state__item__grepl_repls : - grepl_state -> repl_state FStar_Compiler_Util.psmap) = - fun projectee -> - match projectee with | { grepl_repls; grepl_stdin;_} -> grepl_repls -let (__proj__Mkgrepl_state__item__grepl_stdin : - grepl_state -> FStar_Compiler_Util.stream_reader) = - fun projectee -> - match projectee with | { grepl_repls; grepl_stdin;_} -> grepl_stdin -let (t0 : FStar_Compiler_Util.time) = FStar_Compiler_Util.now () -let (dummy_tf_of_fname : Prims.string -> timed_fname) = - fun fname -> { tf_fname = fname; tf_modtime = t0 } -let (string_of_timed_fname : timed_fname -> Prims.string) = - fun uu___ -> - match uu___ with - | { tf_fname = fname; tf_modtime = modtime;_} -> - if modtime = t0 - then FStar_Compiler_Util.format1 "{ %s }" fname - else - (let uu___2 = FStar_Compiler_Util.string_of_time modtime in - FStar_Compiler_Util.format2 "{ %s; %s }" fname uu___2) -let (string_of_repl_task : repl_task -> Prims.string) = - fun uu___ -> - match uu___ with - | LDInterleaved (intf, impl) -> - let uu___1 = string_of_timed_fname intf in - let uu___2 = string_of_timed_fname impl in - FStar_Compiler_Util.format2 "LDInterleaved (%s, %s)" uu___1 uu___2 - | LDSingle intf_or_impl -> - let uu___1 = string_of_timed_fname intf_or_impl in - FStar_Compiler_Util.format1 "LDSingle %s" uu___1 - | LDInterfaceOfCurrentFile intf -> - let uu___1 = string_of_timed_fname intf in - FStar_Compiler_Util.format1 "LDInterfaceOfCurrentFile %s" uu___1 - | PushFragment (FStar_Pervasives.Inl frag, uu___1, uu___2) -> - FStar_Compiler_Util.format1 "PushFragment { code = %s }" - frag.FStar_Parser_ParseIt.frag_text - | PushFragment (FStar_Pervasives.Inr d, uu___1, uu___2) -> - let uu___3 = FStar_Class_Show.show FStar_Parser_AST.showable_decl d in - FStar_Compiler_Util.format1 "PushFragment { decl = %s }" uu___3 - | Noop -> "Noop {}" -let (string_of_repl_stack_entry : repl_stack_entry_t -> Prims.string) = - fun uu___ -> - match uu___ with - | ((depth, i), (task, state)) -> - let uu___1 = - let uu___2 = FStar_Compiler_Util.string_of_int i in - let uu___3 = let uu___4 = string_of_repl_task task in [uu___4] in - uu___2 :: uu___3 in - FStar_Compiler_Util.format "{depth=%s; task=%s}" uu___1 -let (string_of_repl_stack : repl_stack_entry_t Prims.list -> Prims.string) = - fun s -> - let uu___ = FStar_Compiler_List.map string_of_repl_stack_entry s in - FStar_Compiler_String.concat ";\n\t\t" uu___ -let (repl_state_to_string : repl_state -> Prims.string) = - fun r -> - let uu___ = - let uu___1 = FStar_Compiler_Util.string_of_int r.repl_line in - let uu___2 = - let uu___3 = FStar_Compiler_Util.string_of_int r.repl_column in - let uu___4 = - let uu___5 = - let uu___6 = - match r.repl_curmod with - | FStar_Pervasives_Native.None -> "None" - | FStar_Pervasives_Native.Some m -> - FStar_Ident.string_of_lid m.FStar_Syntax_Syntax.name in - let uu___7 = - let uu___8 = string_of_repl_stack r.repl_deps_stack in [uu___8] in - uu___6 :: uu___7 in - (r.repl_fname) :: uu___5 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Compiler_Util.format - "{\n\trepl_line=%s;\n\trepl_column=%s;\n\trepl_fname=%s;\n\trepl_cur_mod=%s;\n\t\\ \n repl_deps_stack={%s}\n}" - uu___ -let (push_query_to_string : push_query -> Prims.string) = - fun pq -> - let pk = - match pq.push_kind with - | SyntaxCheck -> "SyntaxCheck" - | LaxCheck -> "LaxCheck" - | FullCheck -> "FullCheck" in - let code_or_decl = - match pq.push_code_or_decl with - | FStar_Pervasives.Inl code -> code - | FStar_Pervasives.Inr (_decl, code) -> code.FStar_Parser_ParseIt.code in - let uu___ = - let uu___1 = - let uu___2 = FStar_Compiler_Util.string_of_int pq.push_line in - let uu___3 = - let uu___4 = FStar_Compiler_Util.string_of_int pq.push_column in - let uu___5 = - let uu___6 = FStar_Compiler_Util.string_of_bool pq.push_peek_only in - [uu___6; code_or_decl] in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - pk :: uu___1 in - FStar_Compiler_Util.format - "{ push_kind = %s; push_line = %s; push_column = %s; push_peek_only = %s; push_code_or_decl = %s }" - uu___ -let (query_to_string : query -> Prims.string) = - fun q -> - match q.qq with - | Exit -> "Exit" - | DescribeProtocol -> "DescribeProtocol" - | DescribeRepl -> "DescribeRepl" - | Segment uu___ -> "Segment" - | Pop -> "Pop" - | Push pq -> - let uu___ = - let uu___1 = push_query_to_string pq in Prims.strcat uu___1 ")" in - Prims.strcat "(Push " uu___ - | PushPartialCheckedFile d -> - Prims.strcat "(PushPartialCheckedFile " (Prims.strcat d ")") - | VfsAdd uu___ -> "VfsAdd" - | AutoComplete uu___ -> "AutoComplete" - | Lookup (s, _lc, pos, features, _sr) -> - let uu___ = - match pos with - | FStar_Pervasives_Native.None -> "None" - | FStar_Pervasives_Native.Some (f, i, j) -> - let uu___1 = FStar_Compiler_Util.string_of_int i in - let uu___2 = FStar_Compiler_Util.string_of_int j in - FStar_Compiler_Util.format3 "(%s, %s, %s)" f uu___1 uu___2 in - FStar_Compiler_Util.format3 "(Lookup %s %s [%s])" s uu___ - (FStar_Compiler_String.concat "; " features) - | Compute uu___ -> "Compute" - | Search uu___ -> "Search" - | GenericError uu___ -> "GenericError" - | ProtocolViolation uu___ -> "ProtocolViolation" - | FullBuffer uu___ -> "FullBuffer" - | Callback uu___ -> "Callback" - | Format uu___ -> "Format" - | RestartSolver -> "RestartSolver" - | Cancel uu___ -> "Cancel" -let (query_needs_current_module : query' -> Prims.bool) = - fun uu___ -> - match uu___ with - | Exit -> false - | DescribeProtocol -> false - | DescribeRepl -> false - | Segment uu___1 -> false - | Pop -> false - | Push - { push_kind = uu___1; push_line = uu___2; push_column = uu___3; - push_peek_only = false; push_code_or_decl = uu___4;_} - -> false - | VfsAdd uu___1 -> false - | GenericError uu___1 -> false - | ProtocolViolation uu___1 -> false - | PushPartialCheckedFile uu___1 -> false - | FullBuffer uu___1 -> false - | Callback uu___1 -> false - | Format uu___1 -> false - | RestartSolver -> false - | Cancel uu___1 -> false - | Push uu___1 -> true - | AutoComplete uu___1 -> true - | Lookup uu___1 -> true - | Compute uu___1 -> true - | Search uu___1 -> true -let (interactive_protocol_vernum : Prims.int) = (Prims.of_int (2)) -let (interactive_protocol_features : Prims.string Prims.list) = - ["autocomplete"; - "autocomplete/context"; - "compute"; - "compute/reify"; - "compute/pure-subterms"; - "describe-protocol"; - "describe-repl"; - "exit"; - "lookup"; - "lookup/context"; - "lookup/documentation"; - "lookup/definition"; - "peek"; - "pop"; - "push"; - "push-partial-checked-file"; - "search"; - "segment"; - "vfs-add"; - "tactic-ranges"; - "interrupt"; - "progress"; - "full-buffer"; - "format"; - "restart-solver"; - "cancel"] -let (json_of_issue_level : FStar_Errors.issue_level -> FStar_Json.json) = - fun i -> - FStar_Json.JsonStr - (match i with - | FStar_Errors.ENotImplemented -> "not-implemented" - | FStar_Errors.EInfo -> "info" - | FStar_Errors.EWarning -> "warning" - | FStar_Errors.EError -> "error") -let (json_of_issue : FStar_Errors.issue -> FStar_Json.json) = - fun issue -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Errors.format_issue' false issue in - FStar_Json.JsonStr uu___5 in - ("message", uu___4) in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - match issue.FStar_Errors.issue_range with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some r -> - let uu___9 = - FStar_Compiler_Range_Ops.json_of_use_range r in - [uu___9] in - let uu___9 = - match issue.FStar_Errors.issue_range with - | FStar_Pervasives_Native.Some r when - let uu___10 = FStar_Compiler_Range_Type.def_range r in - let uu___11 = FStar_Compiler_Range_Type.use_range r in - uu___10 <> uu___11 -> - let uu___10 = - FStar_Compiler_Range_Ops.json_of_def_range r in - [uu___10] - | uu___10 -> [] in - FStar_Compiler_List.op_At uu___8 uu___9 in - FStar_Json.JsonList uu___7 in - ("ranges", uu___6) in - [uu___5] in - uu___3 :: uu___4 in - FStar_Compiler_List.op_At - (match issue.FStar_Errors.issue_number with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some n -> - [("number", (FStar_Json.JsonInt n))]) uu___2 in - FStar_Compiler_List.op_At - [("level", (json_of_issue_level issue.FStar_Errors.issue_level))] - uu___1 in - FStar_Json.JsonAssoc uu___ -let (js_pushkind : FStar_Json.json -> push_kind) = - fun s -> - let uu___ = FStar_Interactive_JsonHelper.js_str s in - match uu___ with - | "syntax" -> SyntaxCheck - | "lax" -> LaxCheck - | "full" -> FullCheck - | uu___1 -> FStar_Interactive_JsonHelper.js_fail "push_kind" s -let (js_reductionrule : FStar_Json.json -> FStar_TypeChecker_Env.step) = - fun s -> - let uu___ = FStar_Interactive_JsonHelper.js_str s in - match uu___ with - | "beta" -> FStar_TypeChecker_Env.Beta - | "delta" -> - FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant - | "iota" -> FStar_TypeChecker_Env.Iota - | "zeta" -> FStar_TypeChecker_Env.Zeta - | "reify" -> FStar_TypeChecker_Env.Reify - | "pure-subterms" -> FStar_TypeChecker_Env.PureSubtermsWithinComputations - | uu___1 -> FStar_Interactive_JsonHelper.js_fail "reduction rule" s -let (js_optional_completion_context : - FStar_Json.json FStar_Pervasives_Native.option -> completion_context) = - fun k -> - match k with - | FStar_Pervasives_Native.None -> CKCode - | FStar_Pervasives_Native.Some k1 -> - let uu___ = FStar_Interactive_JsonHelper.js_str k1 in - (match uu___ with - | "symbol" -> CKCode - | "code" -> CKCode - | "set-options" -> CKOption false - | "reset-options" -> CKOption true - | "open" -> CKModuleOrNamespace (true, true) - | "let-open" -> CKModuleOrNamespace (true, true) - | "include" -> CKModuleOrNamespace (true, false) - | "module-alias" -> CKModuleOrNamespace (true, false) - | uu___1 -> - FStar_Interactive_JsonHelper.js_fail - "completion context (code, set-options, reset-options, open, let-open, include, module-alias)" - k1) -let (js_optional_lookup_context : - FStar_Json.json FStar_Pervasives_Native.option -> lookup_context) = - fun k -> - match k with - | FStar_Pervasives_Native.None -> LKSymbolOnly - | FStar_Pervasives_Native.Some k1 -> - let uu___ = FStar_Interactive_JsonHelper.js_str k1 in - (match uu___ with - | "symbol-only" -> LKSymbolOnly - | "code" -> LKCode - | "set-options" -> LKOption - | "reset-options" -> LKOption - | "open" -> LKModule - | "let-open" -> LKModule - | "include" -> LKModule - | "module-alias" -> LKModule - | uu___1 -> - FStar_Interactive_JsonHelper.js_fail - "lookup context (symbol-only, code, set-options, reset-options, open, let-open, include, module-alias)" - k1) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Interactive_Incremental.ml b/ocaml/fstar-lib/generated/FStar_Interactive_Incremental.ml deleted file mode 100644 index 55ecf5bc188..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Interactive_Incremental.ml +++ /dev/null @@ -1,584 +0,0 @@ -open Prims -type fragment_progress = - | FullBufferStarted - | FragmentStarted of FStar_Parser_AST.decl - | FragmentSuccess of (FStar_Parser_AST.decl * - FStar_Parser_ParseIt.code_fragment * FStar_Interactive_Ide_Types.push_kind) - - | FragmentFailed of FStar_Parser_AST.decl - | FragmentError of FStar_Errors.issue Prims.list - | FullBufferFinished -let (uu___is_FullBufferStarted : fragment_progress -> Prims.bool) = - fun projectee -> - match projectee with | FullBufferStarted -> true | uu___ -> false -let (uu___is_FragmentStarted : fragment_progress -> Prims.bool) = - fun projectee -> - match projectee with | FragmentStarted _0 -> true | uu___ -> false -let (__proj__FragmentStarted__item___0 : - fragment_progress -> FStar_Parser_AST.decl) = - fun projectee -> match projectee with | FragmentStarted _0 -> _0 -let (uu___is_FragmentSuccess : fragment_progress -> Prims.bool) = - fun projectee -> - match projectee with | FragmentSuccess _0 -> true | uu___ -> false -let (__proj__FragmentSuccess__item___0 : - fragment_progress -> - (FStar_Parser_AST.decl * FStar_Parser_ParseIt.code_fragment * - FStar_Interactive_Ide_Types.push_kind)) - = fun projectee -> match projectee with | FragmentSuccess _0 -> _0 -let (uu___is_FragmentFailed : fragment_progress -> Prims.bool) = - fun projectee -> - match projectee with | FragmentFailed _0 -> true | uu___ -> false -let (__proj__FragmentFailed__item___0 : - fragment_progress -> FStar_Parser_AST.decl) = - fun projectee -> match projectee with | FragmentFailed _0 -> _0 -let (uu___is_FragmentError : fragment_progress -> Prims.bool) = - fun projectee -> - match projectee with | FragmentError _0 -> true | uu___ -> false -let (__proj__FragmentError__item___0 : - fragment_progress -> FStar_Errors.issue Prims.list) = - fun projectee -> match projectee with | FragmentError _0 -> _0 -let (uu___is_FullBufferFinished : fragment_progress -> Prims.bool) = - fun projectee -> - match projectee with | FullBufferFinished -> true | uu___ -> false -type qid = (Prims.string * Prims.int) -type 'a qst = qid -> ('a * qid) -let return : 'a . 'a -> 'a qst = fun x -> fun q -> (x, q) -let op_let_Bang : 'a 'b . 'a qst -> ('a -> 'b qst) -> 'b qst = - fun f -> - fun g -> - fun q -> - let uu___ = f q in - match uu___ with | (x, q') -> let uu___1 = g x in uu___1 q' -let run_qst : 'a . 'a qst -> Prims.string -> 'a = - fun f -> - fun q -> - let uu___ = f (q, Prims.int_zero) in FStar_Pervasives_Native.fst uu___ -let rec map : 'a 'b . ('a -> 'b qst) -> 'a Prims.list -> 'b Prims.list qst = - fun f -> - fun l -> - match l with - | [] -> return [] - | hd::tl -> - let uu___ = f hd in - op_let_Bang uu___ - (fun hd1 -> - let uu___1 = map f tl in - op_let_Bang uu___1 (fun tl1 -> return (hd1 :: tl1))) -let (shift_qid : qid -> Prims.int -> (Prims.string * Prims.int)) = - fun q -> - fun i -> - ((FStar_Pervasives_Native.fst q), - ((FStar_Pervasives_Native.snd q) + i)) -let (next_qid : qid qst) = - fun q -> let q1 = shift_qid q Prims.int_one in (q1, q1) -let (get_qid : qid qst) = fun q -> (q, q) -let (as_query : - FStar_Interactive_Ide_Types.query' -> FStar_Interactive_Ide_Types.query qst) - = - fun q -> - op_let_Bang next_qid - (fun uu___ -> - match uu___ with - | (qid_prefix, i) -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Compiler_Util.string_of_int i in - Prims.strcat "." uu___4 in - Prims.strcat qid_prefix uu___3 in - { - FStar_Interactive_Ide_Types.qq = q; - FStar_Interactive_Ide_Types.qid = uu___2 - } in - return uu___1) -let (dump_symbols_for_lid : - FStar_Ident.lident -> FStar_Interactive_Ide_Types.query qst) = - fun l -> - let r = FStar_Ident.range_of_lid l in - let start_pos = FStar_Compiler_Range_Ops.start_of_range r in - let end_pos = FStar_Compiler_Range_Ops.end_of_range r in - let start_line = FStar_Compiler_Range_Ops.line_of_pos start_pos in - let start_col = FStar_Compiler_Range_Ops.col_of_pos start_pos in - let end_line = FStar_Compiler_Range_Ops.line_of_pos end_pos in - let end_col = FStar_Compiler_Range_Ops.col_of_pos end_pos in - let position = ("", start_line, start_col) in - let uu___ = - let uu___1 = - let uu___2 = FStar_Ident.string_of_lid l in - (uu___2, FStar_Interactive_Ide_Types.LKCode, - (FStar_Pervasives_Native.Some position), - ["type"; "documentation"; "defined-at"], - (FStar_Pervasives_Native.Some - (FStar_Json.JsonAssoc - [("fname", (FStar_Json.JsonStr "")); - ("beg", - (FStar_Json.JsonList - [FStar_Json.JsonInt start_line; - FStar_Json.JsonInt start_col])); - ("end", - (FStar_Json.JsonList - [FStar_Json.JsonInt end_line; - FStar_Json.JsonInt end_col]))]))) in - FStar_Interactive_Ide_Types.Lookup uu___1 in - as_query uu___ -let (dump_symbols : - FStar_Parser_AST.decl -> FStar_Interactive_Ide_Types.query Prims.list qst) - = - fun d -> - let ls = FStar_Parser_AST_Util.lidents_of_decl d in - map dump_symbols_for_lid ls -let (push_decl : - FStar_Interactive_Ide_Types.push_kind -> - Prims.bool -> - (fragment_progress -> unit) -> - (FStar_Parser_AST.decl * FStar_Parser_ParseIt.code_fragment) -> - FStar_Interactive_Ide_Types.query Prims.list qst) - = - fun push_kind -> - fun with_symbols -> - fun write_full_buffer_fragment_progress -> - fun ds -> - let uu___ = ds in - match uu___ with - | (d, s) -> - let pq = - let uu___1 = - let uu___2 = - FStar_Compiler_Range_Ops.start_of_range - d.FStar_Parser_AST.drange in - FStar_Compiler_Range_Ops.line_of_pos uu___2 in - let uu___2 = - let uu___3 = - FStar_Compiler_Range_Ops.start_of_range - d.FStar_Parser_AST.drange in - FStar_Compiler_Range_Ops.col_of_pos uu___3 in - { - FStar_Interactive_Ide_Types.push_kind = push_kind; - FStar_Interactive_Ide_Types.push_line = uu___1; - FStar_Interactive_Ide_Types.push_column = uu___2; - FStar_Interactive_Ide_Types.push_peek_only = false; - FStar_Interactive_Ide_Types.push_code_or_decl = - (FStar_Pervasives.Inr ds) - } in - let progress st = - write_full_buffer_fragment_progress (FragmentStarted d); - ((FStar_Interactive_Ide_Types.QueryOK, []), - (FStar_Pervasives.Inl st)) in - let uu___1 = - as_query (FStar_Interactive_Ide_Types.Callback progress) in - op_let_Bang uu___1 - (fun cb -> - let uu___2 = - as_query (FStar_Interactive_Ide_Types.Push pq) in - op_let_Bang uu___2 - (fun push -> - if with_symbols - then - let uu___3 = dump_symbols d in - op_let_Bang uu___3 - (fun lookups -> - return - (FStar_Compiler_List.op_At [cb; push] - lookups)) - else return [cb; push])) -let (push_decls : - FStar_Interactive_Ide_Types.push_kind -> - Prims.bool -> - (fragment_progress -> unit) -> - (FStar_Parser_AST.decl * FStar_Parser_ParseIt.code_fragment) - Prims.list -> FStar_Interactive_Ide_Types.query Prims.list qst) - = - fun push_kind -> - fun with_symbols -> - fun write_full_buffer_fragment_progress -> - fun ds -> - let uu___ = - map - (push_decl push_kind with_symbols - write_full_buffer_fragment_progress) ds in - op_let_Bang uu___ - (fun qs -> return (FStar_Compiler_List.flatten qs)) -let (pop_entries : - FStar_Interactive_Ide_Types.repl_stack_entry_t Prims.list -> - FStar_Interactive_Ide_Types.query Prims.list qst) - = fun e -> map (fun uu___ -> as_query FStar_Interactive_Ide_Types.Pop) e -let repl_task : - 'uuuuu 'uuuuu1 'uuuuu2 . ('uuuuu * ('uuuuu1 * 'uuuuu2)) -> 'uuuuu1 = - fun uu___ -> match uu___ with | (uu___1, (p, uu___2)) -> p -let (inspect_repl_stack : - FStar_Interactive_Ide_Types.repl_stack_t -> - (FStar_Parser_AST.decl * FStar_Parser_ParseIt.code_fragment) Prims.list - -> - FStar_Interactive_Ide_Types.push_kind -> - Prims.bool -> - (fragment_progress -> unit) -> - (FStar_Interactive_Ide_Types.query Prims.list * FStar_Json.json - Prims.list) qst) - = - fun s -> - fun ds -> - fun push_kind -> - fun with_symbols -> - fun write_full_buffer_fragment_progress -> - let entries = FStar_Compiler_List.rev s in - let push_decls1 = - push_decls push_kind with_symbols - write_full_buffer_fragment_progress in - let uu___ = - FStar_Compiler_Util.prefix_until - (fun uu___1 -> - match uu___1 with - | (uu___2, - (FStar_Interactive_Ide_Types.PushFragment uu___3, - uu___4)) -> true - | uu___2 -> false) entries in - match uu___ with - | FStar_Pervasives_Native.None -> - let uu___1 = push_decls1 ds in - op_let_Bang uu___1 (fun ds1 -> return (ds1, [])) - | FStar_Pervasives_Native.Some (prefix, first_push, rest) -> - let entries1 = first_push :: rest in - let repl_task1 uu___1 = - match uu___1 with | (uu___2, (p, uu___3)) -> p in - let rec matching_prefix accum lookups entries2 ds1 = - match (entries2, ds1) with - | ([], []) -> return (lookups, accum) - | (e::entries3, d::ds2) -> - (match repl_task1 e with - | FStar_Interactive_Ide_Types.Noop -> - matching_prefix accum lookups entries3 (d :: ds2) - | FStar_Interactive_Ide_Types.PushFragment - (FStar_Pervasives.Inl frag, uu___1, uu___2) -> - let uu___3 = pop_entries (e :: entries3) in - op_let_Bang uu___3 - (fun pops -> - let uu___4 = push_decls1 (d :: ds2) in - op_let_Bang uu___4 - (fun pushes -> - return - ((FStar_Compiler_List.op_At lookups - (FStar_Compiler_List.op_At pops - pushes)), accum))) - | FStar_Interactive_Ide_Types.PushFragment - (FStar_Pervasives.Inr d', pk, issues) -> - let uu___1 = - FStar_Parser_AST_Util.eq_decl - (FStar_Pervasives_Native.fst d) d' in - if uu___1 - then - let uu___2 = d in - (match uu___2 with - | (d1, s1) -> - (write_full_buffer_fragment_progress - (FragmentSuccess (d1, s1, pk)); - if with_symbols - then - (let uu___4 = dump_symbols d1 in - op_let_Bang uu___4 - (fun lookups' -> - matching_prefix - (FStar_Compiler_List.op_At - issues accum) - (FStar_Compiler_List.op_At - lookups' lookups) entries3 - ds2)) - else - matching_prefix - (FStar_Compiler_List.op_At issues - accum) lookups entries3 ds2)) - else - (let uu___3 = pop_entries (e :: entries3) in - op_let_Bang uu___3 - (fun pops -> - let uu___4 = push_decls1 (d :: ds2) in - op_let_Bang uu___4 - (fun pushes -> - return - ((FStar_Compiler_List.op_At pops - (FStar_Compiler_List.op_At - lookups pushes)), accum))))) - | ([], ds2) -> - let uu___1 = push_decls1 ds2 in - op_let_Bang uu___1 - (fun pushes -> - return - ((FStar_Compiler_List.op_At lookups pushes), - accum)) - | (es, []) -> - let uu___1 = pop_entries es in - op_let_Bang uu___1 - (fun pops -> - return - ((FStar_Compiler_List.op_At lookups pops), - accum)) in - matching_prefix [] [] entries1 ds -let reload_deps : - 'uuuuu 'uuuuu1 . - ('uuuuu * (FStar_Interactive_Ide_Types.repl_task * 'uuuuu1)) Prims.list - -> FStar_Interactive_Ide_Types.query Prims.list qst - = - fun repl_stack -> - let pop_until_deps entries = - let uu___ = - FStar_Compiler_Util.prefix_until - (fun e -> - match repl_task e with - | FStar_Interactive_Ide_Types.PushFragment uu___1 -> false - | FStar_Interactive_Ide_Types.Noop -> false - | uu___1 -> true) entries in - match uu___ with - | FStar_Pervasives_Native.None -> return [] - | FStar_Pervasives_Native.Some (prefix, uu___1, uu___2) -> - let uu___3 = as_query FStar_Interactive_Ide_Types.Pop in - op_let_Bang uu___3 - (fun pop -> - let uu___4 = - FStar_Compiler_List.map (fun uu___5 -> pop) prefix in - return uu___4) in - pop_until_deps repl_stack -let (parse_code : - FStar_Parser_ParseIt.lang_opts -> - Prims.string -> FStar_Parser_ParseIt.parse_result) - = - fun lang -> - fun code -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Compiler_Range_Ops.file_of_range - FStar_Interactive_Ide_Types.initial_range in - let uu___3 = - let uu___4 = - FStar_Compiler_Range_Ops.start_of_range - FStar_Interactive_Ide_Types.initial_range in - FStar_Compiler_Range_Ops.line_of_pos uu___4 in - let uu___4 = - let uu___5 = - FStar_Compiler_Range_Ops.start_of_range - FStar_Interactive_Ide_Types.initial_range in - FStar_Compiler_Range_Ops.col_of_pos uu___5 in - { - FStar_Parser_ParseIt.frag_fname = uu___2; - FStar_Parser_ParseIt.frag_text = code; - FStar_Parser_ParseIt.frag_line = uu___3; - FStar_Parser_ParseIt.frag_col = uu___4 - } in - FStar_Parser_ParseIt.Incremental uu___1 in - FStar_Parser_ParseIt.parse lang uu___ -let (syntax_issue : - (FStar_Errors_Codes.error_code * FStar_Errors_Msg.error_message * - FStar_Compiler_Range_Type.range) -> FStar_Errors.issue) - = - fun uu___ -> - match uu___ with - | (raw_error, msg, range) -> - let uu___1 = FStar_Errors.lookup raw_error in - (match uu___1 with - | (uu___2, uu___3, num) -> - let issue = - { - FStar_Errors.issue_msg = msg; - FStar_Errors.issue_level = FStar_Errors.EError; - FStar_Errors.issue_range = - (FStar_Pervasives_Native.Some range); - FStar_Errors.issue_number = - (FStar_Pervasives_Native.Some num); - FStar_Errors.issue_ctx = [] - } in - issue) -let (run_full_buffer : - FStar_Interactive_Ide_Types.repl_state -> - Prims.string -> - Prims.string -> - FStar_Interactive_Ide_Types.full_buffer_request_kind -> - Prims.bool -> - (fragment_progress -> unit) -> - (FStar_Interactive_Ide_Types.query Prims.list * FStar_Json.json - Prims.list)) - = - fun st -> - fun qid1 -> - fun code -> - fun request_type -> - fun with_symbols -> - fun write_full_buffer_fragment_progress -> - let parse_result = parse_code FStar_Pervasives_Native.None code in - let log_syntax_issues err = - match err with - | FStar_Pervasives_Native.None -> () - | FStar_Pervasives_Native.Some err1 -> - let issue = syntax_issue err1 in - write_full_buffer_fragment_progress - (FragmentError [issue]) in - let filter_decls decls = - match request_type with - | FStar_Interactive_Ide_Types.VerifyToPosition - (uu___, line, _col) -> - FStar_Compiler_List.filter - (fun uu___1 -> - match uu___1 with - | (d, uu___2) -> - let start = - FStar_Compiler_Range_Ops.start_of_range - d.FStar_Parser_AST.drange in - let start_line = - FStar_Compiler_Range_Ops.line_of_pos start in - start_line <= line) decls - | FStar_Interactive_Ide_Types.LaxToPosition - (uu___, line, _col) -> - FStar_Compiler_List.filter - (fun uu___1 -> - match uu___1 with - | (d, uu___2) -> - let start = - FStar_Compiler_Range_Ops.start_of_range - d.FStar_Parser_AST.drange in - let start_line = - FStar_Compiler_Range_Ops.line_of_pos start in - start_line <= line) decls - | uu___ -> decls in - let qs = - match parse_result with - | FStar_Parser_ParseIt.IncrementalFragment - (decls, uu___, err_opt) -> - ((let uu___2 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length decls) in - FStar_Compiler_Util.print1 "Parsed %s declarations\n" - uu___2); - (match (request_type, decls) with - | (FStar_Interactive_Ide_Types.ReloadDeps, d::uu___2) - -> - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Compiler_Effect.op_Bang - FStar_Interactive_PushHelper.repl_stack in - reload_deps uu___5 in - op_let_Bang uu___4 - (fun queries -> - let uu___5 = - push_decl - FStar_Interactive_Ide_Types.FullCheck - with_symbols - write_full_buffer_fragment_progress d in - op_let_Bang uu___5 - (fun push_mod -> - return - ((FStar_Compiler_List.op_At queries - push_mod), []))) in - run_qst uu___3 qid1 - | uu___2 -> - let decls1 = filter_decls decls in - let push_kind = - match request_type with - | FStar_Interactive_Ide_Types.LaxToPosition - uu___3 -> - FStar_Interactive_Ide_Types.LaxCheck - | FStar_Interactive_Ide_Types.Lax -> - FStar_Interactive_Ide_Types.LaxCheck - | uu___3 -> FStar_Interactive_Ide_Types.FullCheck in - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Compiler_Effect.op_Bang - FStar_Interactive_PushHelper.repl_stack in - inspect_repl_stack uu___5 decls1 push_kind - with_symbols - write_full_buffer_fragment_progress in - run_qst uu___4 qid1 in - (match uu___3 with - | (queries, issues) -> - (if - request_type <> - FStar_Interactive_Ide_Types.Cache - then log_syntax_issues err_opt - else (); - (let uu___6 = FStar_Compiler_Debug.any () in - if uu___6 - then - let uu___7 = - let uu___8 = - FStar_Compiler_List.map - FStar_Interactive_Ide_Types.query_to_string - queries in - FStar_Compiler_String.concat "\n" uu___8 in - FStar_Compiler_Util.print1 - "Generating queries\n%s\n" uu___7 - else ()); - if - request_type <> - FStar_Interactive_Ide_Types.Cache - then (queries, issues) - else ([], issues))))) - | FStar_Parser_ParseIt.ParseError err -> - (if request_type = FStar_Interactive_Ide_Types.Full - then - log_syntax_issues (FStar_Pervasives_Native.Some err) - else (); - ([], [])) - | uu___ -> failwith "Unexpected parse result" in - qs -let (format_code : - FStar_Interactive_Ide_Types.repl_state -> - Prims.string -> - (Prims.string, FStar_Errors.issue Prims.list) FStar_Pervasives.either) - = - fun st -> - fun code -> - let maybe_lang = - match st.FStar_Interactive_Ide_Types.repl_lang with - | [] -> FStar_Pervasives_Native.None - | { FStar_Parser_AST.d = FStar_Parser_AST.UseLangDecls l; - FStar_Parser_AST.drange = uu___; FStar_Parser_AST.quals = uu___1; - FStar_Parser_AST.attrs = uu___2; - FStar_Parser_AST.interleaved = uu___3;_}::uu___4 -> - FStar_Pervasives_Native.Some l in - let parse_result = parse_code maybe_lang code in - match parse_result with - | FStar_Parser_ParseIt.IncrementalFragment - (decls, comments, FStar_Pervasives_Native.None) -> - let doc_to_string doc = - FStar_Pprint.pretty_string - (FStar_Compiler_Util.float_of_string "1.0") - (Prims.of_int (100)) doc in - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun uu___2 -> - match (uu___1, uu___2) with - | ((out, comments1), (d, uu___3)) -> - let uu___4 = - FStar_Parser_ToDocument.decl_with_comments_to_document - d comments1 in - (match uu___4 with - | (doc, comments2) -> - let uu___5 = - let uu___6 = doc_to_string doc in uu___6 :: out in - (uu___5, comments2))) - ([], (FStar_Compiler_List.rev comments)) decls in - (match uu___ with - | (formatted_code_rev, leftover_comments) -> - let code1 = - FStar_Compiler_String.concat "\n\n" - (FStar_Compiler_List.rev formatted_code_rev) in - let formatted_code = - match leftover_comments with - | [] -> code1 - | uu___1 -> - let doc = - FStar_Parser_ToDocument.comments_to_document - leftover_comments in - let uu___2 = - let uu___3 = doc_to_string doc in - Prims.strcat "\n\n" uu___3 in - Prims.strcat code1 uu___2 in - FStar_Pervasives.Inl formatted_code) - | FStar_Parser_ParseIt.IncrementalFragment - (uu___, uu___1, FStar_Pervasives_Native.Some err) -> - let uu___2 = let uu___3 = syntax_issue err in [uu___3] in - FStar_Pervasives.Inr uu___2 - | FStar_Parser_ParseIt.ParseError err -> - let uu___ = let uu___1 = syntax_issue err in [uu___1] in - FStar_Pervasives.Inr uu___ - | uu___ -> failwith "Unexpected parse result" \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Interactive_JsonHelper.ml b/ocaml/fstar-lib/generated/FStar_Interactive_JsonHelper.ml deleted file mode 100644 index 48dfb98cfb7..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Interactive_JsonHelper.ml +++ /dev/null @@ -1,747 +0,0 @@ -open Prims -type assoct = (Prims.string * FStar_Json.json) Prims.list -let (try_assoc : - Prims.string -> assoct -> FStar_Json.json FStar_Pervasives_Native.option) = - fun key -> - fun d -> - let uu___ = - FStar_Compiler_Util.try_find - (fun uu___1 -> match uu___1 with | (k, uu___2) -> k = key) d in - FStar_Compiler_Util.map_option FStar_Pervasives_Native.snd uu___ -exception MissingKey of Prims.string -let (uu___is_MissingKey : Prims.exn -> Prims.bool) = - fun projectee -> - match projectee with | MissingKey uu___ -> true | uu___ -> false -let (__proj__MissingKey__item__uu___ : Prims.exn -> Prims.string) = - fun projectee -> match projectee with | MissingKey uu___ -> uu___ -exception InvalidQuery of Prims.string -let (uu___is_InvalidQuery : Prims.exn -> Prims.bool) = - fun projectee -> - match projectee with | InvalidQuery uu___ -> true | uu___ -> false -let (__proj__InvalidQuery__item__uu___ : Prims.exn -> Prims.string) = - fun projectee -> match projectee with | InvalidQuery uu___ -> uu___ -exception UnexpectedJsonType of (Prims.string * FStar_Json.json) -let (uu___is_UnexpectedJsonType : Prims.exn -> Prims.bool) = - fun projectee -> - match projectee with | UnexpectedJsonType uu___ -> true | uu___ -> false -let (__proj__UnexpectedJsonType__item__uu___ : - Prims.exn -> (Prims.string * FStar_Json.json)) = - fun projectee -> match projectee with | UnexpectedJsonType uu___ -> uu___ -exception MalformedHeader -let (uu___is_MalformedHeader : Prims.exn -> Prims.bool) = - fun projectee -> - match projectee with | MalformedHeader -> true | uu___ -> false -exception InputExhausted -let (uu___is_InputExhausted : Prims.exn -> Prims.bool) = - fun projectee -> - match projectee with | InputExhausted -> true | uu___ -> false -let (assoc : Prims.string -> assoct -> FStar_Json.json) = - fun key -> - fun a -> - let uu___ = try_assoc key a in - match uu___ with - | FStar_Pervasives_Native.Some v -> v - | FStar_Pervasives_Native.None -> - let uu___1 = - let uu___2 = FStar_Compiler_Util.format1 "Missing key [%s]" key in - MissingKey uu___2 in - FStar_Compiler_Effect.raise uu___1 -let (write_json : FStar_Json.json -> unit) = - fun js -> - (let uu___1 = FStar_Json.string_of_json js in - FStar_Compiler_Util.print_raw uu___1); - FStar_Compiler_Util.print_raw "\n" -let (write_jsonrpc : FStar_Json.json -> unit) = - fun js -> - let js_str = FStar_Json.string_of_json js in - let len = - FStar_Compiler_Util.string_of_int (FStar_Compiler_String.length js_str) in - let uu___ = - FStar_Compiler_Util.format2 "Content-Length: %s\r\n\r\n%s" len js_str in - FStar_Compiler_Util.print_raw uu___ -let js_fail : 'a . Prims.string -> FStar_Json.json -> 'a = - fun expected -> - fun got -> - FStar_Compiler_Effect.raise (UnexpectedJsonType (expected, got)) -let (js_int : FStar_Json.json -> Prims.int) = - fun uu___ -> - match uu___ with - | FStar_Json.JsonInt i -> i - | other -> js_fail "int" other -let (js_bool : FStar_Json.json -> Prims.bool) = - fun uu___ -> - match uu___ with - | FStar_Json.JsonBool b -> b - | other -> js_fail "int" other -let (js_str : FStar_Json.json -> Prims.string) = - fun uu___ -> - match uu___ with - | FStar_Json.JsonStr s -> s - | other -> js_fail "string" other -let js_list : - 'a . (FStar_Json.json -> 'a) -> FStar_Json.json -> 'a Prims.list = - fun k -> - fun uu___ -> - match uu___ with - | FStar_Json.JsonList l -> FStar_Compiler_List.map k l - | other -> js_fail "list" other -let (js_assoc : FStar_Json.json -> assoct) = - fun uu___ -> - match uu___ with - | FStar_Json.JsonAssoc a -> a - | other -> js_fail "dictionary" other -let (js_str_int : FStar_Json.json -> Prims.int) = - fun uu___ -> - match uu___ with - | FStar_Json.JsonInt i -> i - | FStar_Json.JsonStr s -> FStar_Compiler_Util.int_of_string s - | other -> js_fail "string or int" other -let (arg : Prims.string -> assoct -> FStar_Json.json) = - fun k -> - fun r -> - let uu___ = let uu___1 = assoc "params" r in js_assoc uu___1 in - assoc k uu___ -let (uri_to_path : Prims.string -> Prims.string) = - fun u -> - let uu___ = - let uu___1 = - FStar_Compiler_Util.substring u (Prims.of_int (9)) (Prims.of_int (3)) in - uu___1 = "%3A" in - if uu___ - then - let uu___1 = - FStar_Compiler_Util.substring u (Prims.of_int (8)) Prims.int_one in - let uu___2 = FStar_Compiler_Util.substring_from u (Prims.of_int (12)) in - FStar_Compiler_Util.format2 "%s:%s" uu___1 uu___2 - else FStar_Compiler_Util.substring_from u (Prims.of_int (7)) -type completion_context = - { - trigger_kind: Prims.int ; - trigger_char: Prims.string FStar_Pervasives_Native.option } -let (__proj__Mkcompletion_context__item__trigger_kind : - completion_context -> Prims.int) = - fun projectee -> - match projectee with | { trigger_kind; trigger_char;_} -> trigger_kind -let (__proj__Mkcompletion_context__item__trigger_char : - completion_context -> Prims.string FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with | { trigger_kind; trigger_char;_} -> trigger_char -let (path_to_uri : Prims.string -> Prims.string) = - fun u -> - let uu___ = - let uu___1 = FStar_Compiler_Util.char_at u Prims.int_one in uu___1 = 58 in - if uu___ - then - let rest = - let uu___1 = FStar_Compiler_Util.substring_from u (Prims.of_int (2)) in - FStar_Compiler_Util.replace_char uu___1 92 47 in - let uu___1 = - FStar_Compiler_Util.substring u Prims.int_zero Prims.int_one in - FStar_Compiler_Util.format2 "file:///%s%3A%s" uu___1 rest - else FStar_Compiler_Util.format1 "file://%s" u -let (js_compl_context : FStar_Json.json -> completion_context) = - fun uu___ -> - match uu___ with - | FStar_Json.JsonAssoc a -> - let uu___1 = let uu___2 = assoc "triggerKind" a in js_int uu___2 in - let uu___2 = - let uu___3 = try_assoc "triggerChar" a in - FStar_Compiler_Util.map_option js_str uu___3 in - { trigger_kind = uu___1; trigger_char = uu___2 } - | other -> js_fail "dictionary" other -type txdoc_item = - { - fname: Prims.string ; - langId: Prims.string ; - version: Prims.int ; - text: Prims.string } -let (__proj__Mktxdoc_item__item__fname : txdoc_item -> Prims.string) = - fun projectee -> - match projectee with | { fname; langId; version; text;_} -> fname -let (__proj__Mktxdoc_item__item__langId : txdoc_item -> Prims.string) = - fun projectee -> - match projectee with | { fname; langId; version; text;_} -> langId -let (__proj__Mktxdoc_item__item__version : txdoc_item -> Prims.int) = - fun projectee -> - match projectee with | { fname; langId; version; text;_} -> version -let (__proj__Mktxdoc_item__item__text : txdoc_item -> Prims.string) = - fun projectee -> - match projectee with | { fname; langId; version; text;_} -> text -let (js_txdoc_item : FStar_Json.json -> txdoc_item) = - fun uu___ -> - match uu___ with - | FStar_Json.JsonAssoc a -> - let arg1 k = assoc k a in - let uu___1 = - let uu___2 = let uu___3 = arg1 "uri" in js_str uu___3 in - uri_to_path uu___2 in - let uu___2 = let uu___3 = arg1 "languageId" in js_str uu___3 in - let uu___3 = let uu___4 = arg1 "version" in js_int uu___4 in - let uu___4 = let uu___5 = arg1 "text" in js_str uu___5 in - { fname = uu___1; langId = uu___2; version = uu___3; text = uu___4 } - | other -> js_fail "dictionary" other -type txdoc_pos = { - path: Prims.string ; - line: Prims.int ; - col: Prims.int } -let (__proj__Mktxdoc_pos__item__path : txdoc_pos -> Prims.string) = - fun projectee -> match projectee with | { path; line; col;_} -> path -let (__proj__Mktxdoc_pos__item__line : txdoc_pos -> Prims.int) = - fun projectee -> match projectee with | { path; line; col;_} -> line -let (__proj__Mktxdoc_pos__item__col : txdoc_pos -> Prims.int) = - fun projectee -> match projectee with | { path; line; col;_} -> col -let (js_txdoc_id : assoct -> Prims.string) = - fun r -> - let uu___ = - let uu___1 = - let uu___2 = let uu___3 = arg "textDocument" r in js_assoc uu___3 in - assoc "uri" uu___2 in - js_str uu___1 in - uri_to_path uu___ -let (js_txdoc_pos : assoct -> txdoc_pos) = - fun r -> - let pos = let uu___ = arg "position" r in js_assoc uu___ in - let uu___ = js_txdoc_id r in - let uu___1 = let uu___2 = assoc "line" pos in js_int uu___2 in - let uu___2 = let uu___3 = assoc "character" pos in js_int uu___3 in - { path = uu___; line = uu___1; col = uu___2 } -type workspace_folder = { - wk_uri: Prims.string ; - wk_name: Prims.string } -let (__proj__Mkworkspace_folder__item__wk_uri : - workspace_folder -> Prims.string) = - fun projectee -> match projectee with | { wk_uri; wk_name;_} -> wk_uri -let (__proj__Mkworkspace_folder__item__wk_name : - workspace_folder -> Prims.string) = - fun projectee -> match projectee with | { wk_uri; wk_name;_} -> wk_name -type wsch_event = { - added: workspace_folder ; - removed: workspace_folder } -let (__proj__Mkwsch_event__item__added : wsch_event -> workspace_folder) = - fun projectee -> match projectee with | { added; removed;_} -> added -let (__proj__Mkwsch_event__item__removed : wsch_event -> workspace_folder) = - fun projectee -> match projectee with | { added; removed;_} -> removed -let (js_wsch_event : FStar_Json.json -> wsch_event) = - fun uu___ -> - match uu___ with - | FStar_Json.JsonAssoc a -> - let added' = let uu___1 = assoc "added" a in js_assoc uu___1 in - let removed' = let uu___1 = assoc "removed" a in js_assoc uu___1 in - let uu___1 = - let uu___2 = let uu___3 = assoc "uri" added' in js_str uu___3 in - let uu___3 = let uu___4 = assoc "name" added' in js_str uu___4 in - { wk_uri = uu___2; wk_name = uu___3 } in - let uu___2 = - let uu___3 = let uu___4 = assoc "uri" removed' in js_str uu___4 in - let uu___4 = let uu___5 = assoc "name" removed' in js_str uu___5 in - { wk_uri = uu___3; wk_name = uu___4 } in - { added = uu___1; removed = uu___2 } - | other -> js_fail "dictionary" other -let (js_contentch : FStar_Json.json -> Prims.string) = - fun uu___ -> - match uu___ with - | FStar_Json.JsonList l -> - let uu___1 = - FStar_Compiler_List.map - (fun uu___2 -> - match uu___2 with - | FStar_Json.JsonAssoc a -> - let uu___3 = assoc "text" a in js_str uu___3) l in - FStar_Compiler_List.hd uu___1 - | other -> js_fail "dictionary" other -type lquery = - | Initialize of (Prims.int * Prims.string) - | Initialized - | Shutdown - | Exit - | Cancel of Prims.int - | FolderChange of wsch_event - | ChangeConfig - | ChangeWatch - | Symbol of Prims.string - | ExecCommand of Prims.string - | DidOpen of txdoc_item - | DidChange of (Prims.string * Prims.string) - | WillSave of Prims.string - | WillSaveWait of Prims.string - | DidSave of (Prims.string * Prims.string) - | DidClose of Prims.string - | Completion of (txdoc_pos * completion_context) - | Resolve - | Hover of txdoc_pos - | SignatureHelp of txdoc_pos - | Declaration of txdoc_pos - | Definition of txdoc_pos - | TypeDefinition of txdoc_pos - | Implementation of txdoc_pos - | References - | DocumentHighlight of txdoc_pos - | DocumentSymbol - | CodeAction - | CodeLens - | CodeLensResolve - | DocumentLink - | DocumentLinkResolve - | DocumentColor - | ColorPresentation - | Formatting - | RangeFormatting - | TypeFormatting - | Rename - | PrepareRename of txdoc_pos - | FoldingRange - | BadProtocolMsg of Prims.string -let (uu___is_Initialize : lquery -> Prims.bool) = - fun projectee -> - match projectee with | Initialize _0 -> true | uu___ -> false -let (__proj__Initialize__item___0 : lquery -> (Prims.int * Prims.string)) = - fun projectee -> match projectee with | Initialize _0 -> _0 -let (uu___is_Initialized : lquery -> Prims.bool) = - fun projectee -> - match projectee with | Initialized -> true | uu___ -> false -let (uu___is_Shutdown : lquery -> Prims.bool) = - fun projectee -> match projectee with | Shutdown -> true | uu___ -> false -let (uu___is_Exit : lquery -> Prims.bool) = - fun projectee -> match projectee with | Exit -> true | uu___ -> false -let (uu___is_Cancel : lquery -> Prims.bool) = - fun projectee -> match projectee with | Cancel _0 -> true | uu___ -> false -let (__proj__Cancel__item___0 : lquery -> Prims.int) = - fun projectee -> match projectee with | Cancel _0 -> _0 -let (uu___is_FolderChange : lquery -> Prims.bool) = - fun projectee -> - match projectee with | FolderChange _0 -> true | uu___ -> false -let (__proj__FolderChange__item___0 : lquery -> wsch_event) = - fun projectee -> match projectee with | FolderChange _0 -> _0 -let (uu___is_ChangeConfig : lquery -> Prims.bool) = - fun projectee -> - match projectee with | ChangeConfig -> true | uu___ -> false -let (uu___is_ChangeWatch : lquery -> Prims.bool) = - fun projectee -> - match projectee with | ChangeWatch -> true | uu___ -> false -let (uu___is_Symbol : lquery -> Prims.bool) = - fun projectee -> match projectee with | Symbol _0 -> true | uu___ -> false -let (__proj__Symbol__item___0 : lquery -> Prims.string) = - fun projectee -> match projectee with | Symbol _0 -> _0 -let (uu___is_ExecCommand : lquery -> Prims.bool) = - fun projectee -> - match projectee with | ExecCommand _0 -> true | uu___ -> false -let (__proj__ExecCommand__item___0 : lquery -> Prims.string) = - fun projectee -> match projectee with | ExecCommand _0 -> _0 -let (uu___is_DidOpen : lquery -> Prims.bool) = - fun projectee -> match projectee with | DidOpen _0 -> true | uu___ -> false -let (__proj__DidOpen__item___0 : lquery -> txdoc_item) = - fun projectee -> match projectee with | DidOpen _0 -> _0 -let (uu___is_DidChange : lquery -> Prims.bool) = - fun projectee -> - match projectee with | DidChange _0 -> true | uu___ -> false -let (__proj__DidChange__item___0 : lquery -> (Prims.string * Prims.string)) = - fun projectee -> match projectee with | DidChange _0 -> _0 -let (uu___is_WillSave : lquery -> Prims.bool) = - fun projectee -> - match projectee with | WillSave _0 -> true | uu___ -> false -let (__proj__WillSave__item___0 : lquery -> Prims.string) = - fun projectee -> match projectee with | WillSave _0 -> _0 -let (uu___is_WillSaveWait : lquery -> Prims.bool) = - fun projectee -> - match projectee with | WillSaveWait _0 -> true | uu___ -> false -let (__proj__WillSaveWait__item___0 : lquery -> Prims.string) = - fun projectee -> match projectee with | WillSaveWait _0 -> _0 -let (uu___is_DidSave : lquery -> Prims.bool) = - fun projectee -> match projectee with | DidSave _0 -> true | uu___ -> false -let (__proj__DidSave__item___0 : lquery -> (Prims.string * Prims.string)) = - fun projectee -> match projectee with | DidSave _0 -> _0 -let (uu___is_DidClose : lquery -> Prims.bool) = - fun projectee -> - match projectee with | DidClose _0 -> true | uu___ -> false -let (__proj__DidClose__item___0 : lquery -> Prims.string) = - fun projectee -> match projectee with | DidClose _0 -> _0 -let (uu___is_Completion : lquery -> Prims.bool) = - fun projectee -> - match projectee with | Completion _0 -> true | uu___ -> false -let (__proj__Completion__item___0 : - lquery -> (txdoc_pos * completion_context)) = - fun projectee -> match projectee with | Completion _0 -> _0 -let (uu___is_Resolve : lquery -> Prims.bool) = - fun projectee -> match projectee with | Resolve -> true | uu___ -> false -let (uu___is_Hover : lquery -> Prims.bool) = - fun projectee -> match projectee with | Hover _0 -> true | uu___ -> false -let (__proj__Hover__item___0 : lquery -> txdoc_pos) = - fun projectee -> match projectee with | Hover _0 -> _0 -let (uu___is_SignatureHelp : lquery -> Prims.bool) = - fun projectee -> - match projectee with | SignatureHelp _0 -> true | uu___ -> false -let (__proj__SignatureHelp__item___0 : lquery -> txdoc_pos) = - fun projectee -> match projectee with | SignatureHelp _0 -> _0 -let (uu___is_Declaration : lquery -> Prims.bool) = - fun projectee -> - match projectee with | Declaration _0 -> true | uu___ -> false -let (__proj__Declaration__item___0 : lquery -> txdoc_pos) = - fun projectee -> match projectee with | Declaration _0 -> _0 -let (uu___is_Definition : lquery -> Prims.bool) = - fun projectee -> - match projectee with | Definition _0 -> true | uu___ -> false -let (__proj__Definition__item___0 : lquery -> txdoc_pos) = - fun projectee -> match projectee with | Definition _0 -> _0 -let (uu___is_TypeDefinition : lquery -> Prims.bool) = - fun projectee -> - match projectee with | TypeDefinition _0 -> true | uu___ -> false -let (__proj__TypeDefinition__item___0 : lquery -> txdoc_pos) = - fun projectee -> match projectee with | TypeDefinition _0 -> _0 -let (uu___is_Implementation : lquery -> Prims.bool) = - fun projectee -> - match projectee with | Implementation _0 -> true | uu___ -> false -let (__proj__Implementation__item___0 : lquery -> txdoc_pos) = - fun projectee -> match projectee with | Implementation _0 -> _0 -let (uu___is_References : lquery -> Prims.bool) = - fun projectee -> match projectee with | References -> true | uu___ -> false -let (uu___is_DocumentHighlight : lquery -> Prims.bool) = - fun projectee -> - match projectee with | DocumentHighlight _0 -> true | uu___ -> false -let (__proj__DocumentHighlight__item___0 : lquery -> txdoc_pos) = - fun projectee -> match projectee with | DocumentHighlight _0 -> _0 -let (uu___is_DocumentSymbol : lquery -> Prims.bool) = - fun projectee -> - match projectee with | DocumentSymbol -> true | uu___ -> false -let (uu___is_CodeAction : lquery -> Prims.bool) = - fun projectee -> match projectee with | CodeAction -> true | uu___ -> false -let (uu___is_CodeLens : lquery -> Prims.bool) = - fun projectee -> match projectee with | CodeLens -> true | uu___ -> false -let (uu___is_CodeLensResolve : lquery -> Prims.bool) = - fun projectee -> - match projectee with | CodeLensResolve -> true | uu___ -> false -let (uu___is_DocumentLink : lquery -> Prims.bool) = - fun projectee -> - match projectee with | DocumentLink -> true | uu___ -> false -let (uu___is_DocumentLinkResolve : lquery -> Prims.bool) = - fun projectee -> - match projectee with | DocumentLinkResolve -> true | uu___ -> false -let (uu___is_DocumentColor : lquery -> Prims.bool) = - fun projectee -> - match projectee with | DocumentColor -> true | uu___ -> false -let (uu___is_ColorPresentation : lquery -> Prims.bool) = - fun projectee -> - match projectee with | ColorPresentation -> true | uu___ -> false -let (uu___is_Formatting : lquery -> Prims.bool) = - fun projectee -> match projectee with | Formatting -> true | uu___ -> false -let (uu___is_RangeFormatting : lquery -> Prims.bool) = - fun projectee -> - match projectee with | RangeFormatting -> true | uu___ -> false -let (uu___is_TypeFormatting : lquery -> Prims.bool) = - fun projectee -> - match projectee with | TypeFormatting -> true | uu___ -> false -let (uu___is_Rename : lquery -> Prims.bool) = - fun projectee -> match projectee with | Rename -> true | uu___ -> false -let (uu___is_PrepareRename : lquery -> Prims.bool) = - fun projectee -> - match projectee with | PrepareRename _0 -> true | uu___ -> false -let (__proj__PrepareRename__item___0 : lquery -> txdoc_pos) = - fun projectee -> match projectee with | PrepareRename _0 -> _0 -let (uu___is_FoldingRange : lquery -> Prims.bool) = - fun projectee -> - match projectee with | FoldingRange -> true | uu___ -> false -let (uu___is_BadProtocolMsg : lquery -> Prims.bool) = - fun projectee -> - match projectee with | BadProtocolMsg _0 -> true | uu___ -> false -let (__proj__BadProtocolMsg__item___0 : lquery -> Prims.string) = - fun projectee -> match projectee with | BadProtocolMsg _0 -> _0 -type lsp_query = - { - query_id: Prims.int FStar_Pervasives_Native.option ; - q: lquery } -let (__proj__Mklsp_query__item__query_id : - lsp_query -> Prims.int FStar_Pervasives_Native.option) = - fun projectee -> match projectee with | { query_id; q;_} -> query_id -let (__proj__Mklsp_query__item__q : lsp_query -> lquery) = - fun projectee -> match projectee with | { query_id; q;_} -> q -type error_code = - | ParseError - | InvalidRequest - | MethodNotFound - | InvalidParams - | InternalError - | ServerErrorStart - | ServerErrorEnd - | ServerNotInitialized - | UnknownErrorCode - | RequestCancelled - | ContentModified -let (uu___is_ParseError : error_code -> Prims.bool) = - fun projectee -> match projectee with | ParseError -> true | uu___ -> false -let (uu___is_InvalidRequest : error_code -> Prims.bool) = - fun projectee -> - match projectee with | InvalidRequest -> true | uu___ -> false -let (uu___is_MethodNotFound : error_code -> Prims.bool) = - fun projectee -> - match projectee with | MethodNotFound -> true | uu___ -> false -let (uu___is_InvalidParams : error_code -> Prims.bool) = - fun projectee -> - match projectee with | InvalidParams -> true | uu___ -> false -let (uu___is_InternalError : error_code -> Prims.bool) = - fun projectee -> - match projectee with | InternalError -> true | uu___ -> false -let (uu___is_ServerErrorStart : error_code -> Prims.bool) = - fun projectee -> - match projectee with | ServerErrorStart -> true | uu___ -> false -let (uu___is_ServerErrorEnd : error_code -> Prims.bool) = - fun projectee -> - match projectee with | ServerErrorEnd -> true | uu___ -> false -let (uu___is_ServerNotInitialized : error_code -> Prims.bool) = - fun projectee -> - match projectee with | ServerNotInitialized -> true | uu___ -> false -let (uu___is_UnknownErrorCode : error_code -> Prims.bool) = - fun projectee -> - match projectee with | UnknownErrorCode -> true | uu___ -> false -let (uu___is_RequestCancelled : error_code -> Prims.bool) = - fun projectee -> - match projectee with | RequestCancelled -> true | uu___ -> false -let (uu___is_ContentModified : error_code -> Prims.bool) = - fun projectee -> - match projectee with | ContentModified -> true | uu___ -> false -type rng = - { - rng_start: (Prims.int * Prims.int) ; - rng_end: (Prims.int * Prims.int) } -let (__proj__Mkrng__item__rng_start : rng -> (Prims.int * Prims.int)) = - fun projectee -> - match projectee with | { rng_start; rng_end;_} -> rng_start -let (__proj__Mkrng__item__rng_end : rng -> (Prims.int * Prims.int)) = - fun projectee -> match projectee with | { rng_start; rng_end;_} -> rng_end -let (js_rng : FStar_Json.json -> rng) = - fun uu___ -> - match uu___ with - | FStar_Json.JsonAssoc a -> - let st = assoc "start" a in - let fin = assoc "end" a in - let l = assoc "line" in - let c = assoc "character" in - let uu___1 = - let uu___2 = - let uu___3 = let uu___4 = js_assoc st in l uu___4 in - js_int uu___3 in - let uu___3 = - let uu___4 = let uu___5 = js_assoc st in c uu___5 in - js_int uu___4 in - (uu___2, uu___3) in - let uu___2 = - let uu___3 = - let uu___4 = let uu___5 = js_assoc fin in l uu___5 in - js_int uu___4 in - let uu___4 = - let uu___5 = let uu___6 = js_assoc st in c uu___6 in - js_int uu___5 in - (uu___3, uu___4) in - { rng_start = uu___1; rng_end = uu___2 } - | other -> js_fail "dictionary" other -let (errorcode_to_int : error_code -> Prims.int) = - fun uu___ -> - match uu___ with - | ParseError -> (Prims.of_int (-32700)) - | InvalidRequest -> (Prims.of_int (-32600)) - | MethodNotFound -> (Prims.of_int (-32601)) - | InvalidParams -> (Prims.of_int (-32602)) - | InternalError -> (Prims.of_int (-32603)) - | ServerErrorStart -> (Prims.of_int (-32099)) - | ServerErrorEnd -> (Prims.of_int (-32000)) - | ServerNotInitialized -> (Prims.of_int (-32002)) - | UnknownErrorCode -> (Prims.of_int (-32001)) - | RequestCancelled -> (Prims.of_int (-32800)) - | ContentModified -> (Prims.of_int (-32801)) -let (json_debug : FStar_Json.json -> Prims.string) = - fun uu___ -> - match uu___ with - | FStar_Json.JsonNull -> "null" - | FStar_Json.JsonBool b -> - FStar_Compiler_Util.format1 "bool (%s)" - (if b then "true" else "false") - | FStar_Json.JsonInt i -> - let uu___1 = FStar_Compiler_Util.string_of_int i in - FStar_Compiler_Util.format1 "int (%s)" uu___1 - | FStar_Json.JsonStr s -> FStar_Compiler_Util.format1 "string (%s)" s - | FStar_Json.JsonList uu___1 -> "list (...)" - | FStar_Json.JsonAssoc uu___1 -> "dictionary (...)" -let (wrap_jsfail : - Prims.int FStar_Pervasives_Native.option -> - Prims.string -> FStar_Json.json -> lsp_query) - = - fun qid -> - fun expected -> - fun got -> - let uu___ = - let uu___1 = - let uu___2 = json_debug got in - FStar_Compiler_Util.format2 - "JSON decoding failed: expected %s, got %s" expected uu___2 in - BadProtocolMsg uu___1 in - { query_id = qid; q = uu___ } -let (resultResponse : - FStar_Json.json -> assoct FStar_Pervasives_Native.option) = - fun r -> FStar_Pervasives_Native.Some [("result", r)] -let (errorResponse : - FStar_Json.json -> assoct FStar_Pervasives_Native.option) = - fun r -> FStar_Pervasives_Native.Some [("error", r)] -let (nullResponse : assoct FStar_Pervasives_Native.option) = - resultResponse FStar_Json.JsonNull -let (json_of_response : - Prims.int FStar_Pervasives_Native.option -> assoct -> FStar_Json.json) = - fun qid -> - fun response -> - match qid with - | FStar_Pervasives_Native.Some i -> - FStar_Json.JsonAssoc - (FStar_Compiler_List.op_At - [("jsonrpc", (FStar_Json.JsonStr "2.0")); - ("id", (FStar_Json.JsonInt i))] response) - | FStar_Pervasives_Native.None -> - FStar_Json.JsonAssoc - (FStar_Compiler_List.op_At - [("jsonrpc", (FStar_Json.JsonStr "2.0"))] response) -let (js_resperr : error_code -> Prims.string -> FStar_Json.json) = - fun err -> - fun msg -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = errorcode_to_int err in FStar_Json.JsonInt uu___3 in - ("code", uu___2) in - [uu___1; ("message", (FStar_Json.JsonStr msg))] in - FStar_Json.JsonAssoc uu___ -let (wrap_content_szerr : Prims.string -> lsp_query) = - fun m -> - { query_id = FStar_Pervasives_Native.None; q = (BadProtocolMsg m) } -let (js_servcap : FStar_Json.json) = - FStar_Json.JsonAssoc - [("capabilities", - (FStar_Json.JsonAssoc - [("textDocumentSync", - (FStar_Json.JsonAssoc - [("openClose", (FStar_Json.JsonBool true)); - ("change", (FStar_Json.JsonInt Prims.int_one)); - ("willSave", (FStar_Json.JsonBool false)); - ("willSaveWaitUntil", (FStar_Json.JsonBool false)); - ("save", - (FStar_Json.JsonAssoc - [("includeText", (FStar_Json.JsonBool true))]))])); - ("hoverProvider", (FStar_Json.JsonBool true)); - ("completionProvider", (FStar_Json.JsonAssoc [])); - ("signatureHelpProvider", (FStar_Json.JsonAssoc [])); - ("definitionProvider", (FStar_Json.JsonBool true)); - ("typeDefinitionProvider", (FStar_Json.JsonBool false)); - ("implementationProvider", (FStar_Json.JsonBool false)); - ("referencesProvider", (FStar_Json.JsonBool false)); - ("documentSymbolProvider", (FStar_Json.JsonBool false)); - ("workspaceSymbolProvider", (FStar_Json.JsonBool false)); - ("codeActionProvider", (FStar_Json.JsonBool false))]))] -let (js_pos : FStar_Compiler_Range_Type.pos -> FStar_Json.json) = - fun p -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Compiler_Range_Ops.line_of_pos p in - uu___4 - Prims.int_one in - FStar_Json.JsonInt uu___3 in - ("line", uu___2) in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Compiler_Range_Ops.col_of_pos p in - FStar_Json.JsonInt uu___5 in - ("character", uu___4) in - [uu___3] in - uu___1 :: uu___2 in - FStar_Json.JsonAssoc uu___ -let (js_range : FStar_Compiler_Range_Type.range -> FStar_Json.json) = - fun r -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Compiler_Range_Ops.start_of_range r in - js_pos uu___3 in - ("start", uu___2) in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Compiler_Range_Ops.end_of_range r in - js_pos uu___5 in - ("end", uu___4) in - [uu___3] in - uu___1 :: uu___2 in - FStar_Json.JsonAssoc uu___ -let (js_dummyrange : FStar_Json.json) = - FStar_Json.JsonAssoc - [("start", - (FStar_Json.JsonAssoc - [("line", (FStar_Json.JsonInt Prims.int_zero)); - ("character", (FStar_Json.JsonInt Prims.int_zero)); - ("end", - (FStar_Json.JsonAssoc - [("line", (FStar_Json.JsonInt Prims.int_zero)); - ("character", (FStar_Json.JsonInt Prims.int_zero))]))]))] -let (js_loclink : FStar_Compiler_Range_Type.range -> FStar_Json.json) = - fun r -> - let s = js_range r in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = FStar_Compiler_Range_Ops.file_of_range r in - path_to_uri uu___6 in - FStar_Json.JsonStr uu___5 in - ("targetUri", uu___4) in - [uu___3; ("targetRange", s); ("targetSelectionRange", s)] in - FStar_Json.JsonAssoc uu___2 in - [uu___1] in - FStar_Json.JsonList uu___ -let (pos_munge : txdoc_pos -> (Prims.string * Prims.int * Prims.int)) = - fun pos -> ((pos.path), (pos.line + Prims.int_one), (pos.col)) -let (js_diag : - Prims.string -> - Prims.string -> - FStar_Compiler_Range_Type.range FStar_Pervasives_Native.option -> - assoct) - = - fun fname -> - fun msg -> - fun r -> - let r' = - match r with - | FStar_Pervasives_Native.Some r1 -> js_range r1 - | FStar_Pervasives_Native.None -> js_dummyrange in - let ds = - ("diagnostics", - (FStar_Json.JsonList - [FStar_Json.JsonAssoc - [("range", r'); ("message", (FStar_Json.JsonStr msg))]])) in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = path_to_uri fname in - FStar_Json.JsonStr uu___6 in - ("uri", uu___5) in - [uu___4; ds] in - FStar_Json.JsonAssoc uu___3 in - ("params", uu___2) in - [uu___1] in - ("method", (FStar_Json.JsonStr "textDocument/publishDiagnostics")) :: - uu___ -let (js_diag_clear : Prims.string -> assoct) = - fun fname -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = path_to_uri fname in FStar_Json.JsonStr uu___6 in - ("uri", uu___5) in - [uu___4; ("diagnostics", (FStar_Json.JsonList []))] in - FStar_Json.JsonAssoc uu___3 in - ("params", uu___2) in - [uu___1] in - ("method", (FStar_Json.JsonStr "textDocument/publishDiagnostics")) :: - uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Interactive_Legacy.ml b/ocaml/fstar-lib/generated/FStar_Interactive_Legacy.ml deleted file mode 100644 index 3f84f912394..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Interactive_Legacy.ml +++ /dev/null @@ -1,964 +0,0 @@ -open Prims -let (tc_one_file : - Prims.string Prims.list -> - FStar_TypeChecker_Env.env -> - ((Prims.string FStar_Pervasives_Native.option * Prims.string) * - FStar_TypeChecker_Env.env_t * Prims.string Prims.list)) - = - fun remaining -> - fun env -> - let uu___ = - match remaining with - | intf::impl::remaining1 when - FStar_Universal.needs_interleaving intf impl -> - let uu___1 = - FStar_Universal.tc_one_file_for_ide env - (FStar_Pervasives_Native.Some intf) impl - FStar_Parser_Dep.empty_parsing_data in - (match uu___1 with - | (uu___2, env1) -> - (((FStar_Pervasives_Native.Some intf), impl), env1, - remaining1)) - | intf_or_impl::remaining1 -> - let uu___1 = - FStar_Universal.tc_one_file_for_ide env - FStar_Pervasives_Native.None intf_or_impl - FStar_Parser_Dep.empty_parsing_data in - (match uu___1 with - | (uu___2, env1) -> - ((FStar_Pervasives_Native.None, intf_or_impl), env1, - remaining1)) - | [] -> failwith "Impossible" in - match uu___ with - | ((intf, impl), env1, remaining1) -> ((intf, impl), env1, remaining1) -type env_t = FStar_TypeChecker_Env.env -type modul_t = FStar_Syntax_Syntax.modul FStar_Pervasives_Native.option -type stack_t = (env_t * modul_t) Prims.list -let (pop : FStar_TypeChecker_Env.env -> Prims.string -> unit) = - fun env -> - fun msg -> - (let uu___1 = FStar_TypeChecker_Tc.pop_context env msg in ()); - FStar_Options.pop () -let (push_with_kind : - FStar_TypeChecker_Env.env -> - Prims.bool -> Prims.bool -> Prims.string -> FStar_TypeChecker_Env.env) - = - fun env -> - fun lax -> - fun restore_cmd_line_options -> - fun msg -> - let env1 = - { - FStar_TypeChecker_Env.solver = - (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = (env.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = lax; - FStar_TypeChecker_Env.lax_universes = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env.FStar_TypeChecker_Env.missing_decl) - } in - let res = FStar_TypeChecker_Tc.push_context env1 msg in - FStar_Options.push (); - if restore_cmd_line_options - then - (let uu___2 = FStar_Options.restore_cmd_line_options false in ()) - else (); - res -let (check_frag : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.modul FStar_Pervasives_Native.option -> - (FStar_Parser_ParseIt.input_frag * FStar_Universal.lang_decls_t) -> - (FStar_Syntax_Syntax.modul FStar_Pervasives_Native.option * - FStar_TypeChecker_Env.env * Prims.int) - FStar_Pervasives_Native.option) - = - fun env -> - fun curmod -> - fun frag -> - try - (fun uu___ -> - match () with - | () -> - let uu___1 = - FStar_Universal.tc_one_fragment curmod env - (FStar_Pervasives.Inl frag) in - (match uu___1 with - | (m, env1, uu___2) -> - let uu___3 = - let uu___4 = FStar_Errors.get_err_count () in - (m, env1, uu___4) in - FStar_Pervasives_Native.Some uu___3)) () - with - | FStar_Errors.Error (e, msg, r, ctx) when - let uu___1 = FStar_Options.trace_error () in - Prims.op_Negation uu___1 -> - (FStar_TypeChecker_Err.add_errors env [(e, msg, r, ctx)]; - FStar_Pervasives_Native.None) -let (report_fail : unit -> unit) = - fun uu___ -> - (let uu___2 = FStar_Errors.report_all () in ()); FStar_Errors.clear () -type input_chunks = - | Push of (Prims.bool * Prims.int * Prims.int) - | Pop of Prims.string - | Code of (Prims.string * (Prims.string * Prims.string)) - | Info of (Prims.string * Prims.bool * (Prims.string * Prims.int * - Prims.int) FStar_Pervasives_Native.option) - | Completions of Prims.string -let (uu___is_Push : input_chunks -> Prims.bool) = - fun projectee -> match projectee with | Push _0 -> true | uu___ -> false -let (__proj__Push__item___0 : - input_chunks -> (Prims.bool * Prims.int * Prims.int)) = - fun projectee -> match projectee with | Push _0 -> _0 -let (uu___is_Pop : input_chunks -> Prims.bool) = - fun projectee -> match projectee with | Pop _0 -> true | uu___ -> false -let (__proj__Pop__item___0 : input_chunks -> Prims.string) = - fun projectee -> match projectee with | Pop _0 -> _0 -let (uu___is_Code : input_chunks -> Prims.bool) = - fun projectee -> match projectee with | Code _0 -> true | uu___ -> false -let (__proj__Code__item___0 : - input_chunks -> (Prims.string * (Prims.string * Prims.string))) = - fun projectee -> match projectee with | Code _0 -> _0 -let (uu___is_Info : input_chunks -> Prims.bool) = - fun projectee -> match projectee with | Info _0 -> true | uu___ -> false -let (__proj__Info__item___0 : - input_chunks -> - (Prims.string * Prims.bool * (Prims.string * Prims.int * Prims.int) - FStar_Pervasives_Native.option)) - = fun projectee -> match projectee with | Info _0 -> _0 -let (uu___is_Completions : input_chunks -> Prims.bool) = - fun projectee -> - match projectee with | Completions _0 -> true | uu___ -> false -let (__proj__Completions__item___0 : input_chunks -> Prims.string) = - fun projectee -> match projectee with | Completions _0 -> _0 -type interactive_state = - { - chunk: FStar_Compiler_Util.string_builder ; - stdin: - FStar_Compiler_Util.stream_reader FStar_Pervasives_Native.option - FStar_Compiler_Effect.ref - ; - buffer: input_chunks Prims.list FStar_Compiler_Effect.ref ; - log: - FStar_Compiler_Util.out_channel FStar_Pervasives_Native.option - FStar_Compiler_Effect.ref - } -let (__proj__Mkinteractive_state__item__chunk : - interactive_state -> FStar_Compiler_Util.string_builder) = - fun projectee -> - match projectee with | { chunk; stdin; buffer; log;_} -> chunk -let (__proj__Mkinteractive_state__item__stdin : - interactive_state -> - FStar_Compiler_Util.stream_reader FStar_Pervasives_Native.option - FStar_Compiler_Effect.ref) - = - fun projectee -> - match projectee with | { chunk; stdin; buffer; log;_} -> stdin -let (__proj__Mkinteractive_state__item__buffer : - interactive_state -> input_chunks Prims.list FStar_Compiler_Effect.ref) = - fun projectee -> - match projectee with | { chunk; stdin; buffer; log;_} -> buffer -let (__proj__Mkinteractive_state__item__log : - interactive_state -> - FStar_Compiler_Util.out_channel FStar_Pervasives_Native.option - FStar_Compiler_Effect.ref) - = - fun projectee -> - match projectee with | { chunk; stdin; buffer; log;_} -> log -let (the_interactive_state : interactive_state) = - let uu___ = FStar_Compiler_Util.new_string_builder () in - let uu___1 = FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None in - let uu___2 = FStar_Compiler_Util.mk_ref [] in - let uu___3 = FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None in - { chunk = uu___; stdin = uu___1; buffer = uu___2; log = uu___3 } -let rec (read_chunk : unit -> input_chunks) = - fun uu___ -> - let s = the_interactive_state in - let log = - let uu___1 = FStar_Compiler_Debug.any () in - if uu___1 - then - let transcript = - let uu___2 = FStar_Compiler_Effect.op_Bang s.log in - match uu___2 with - | FStar_Pervasives_Native.Some transcript1 -> transcript1 - | FStar_Pervasives_Native.None -> - let transcript1 = - FStar_Compiler_Util.open_file_for_writing "transcript" in - (FStar_Compiler_Effect.op_Colon_Equals s.log - (FStar_Pervasives_Native.Some transcript1); - transcript1) in - fun line -> - (FStar_Compiler_Util.append_to_file transcript line; - FStar_Compiler_Util.flush transcript) - else (fun uu___3 -> ()) in - let stdin = - let uu___1 = FStar_Compiler_Effect.op_Bang s.stdin in - match uu___1 with - | FStar_Pervasives_Native.Some i -> i - | FStar_Pervasives_Native.None -> - let i = FStar_Compiler_Util.open_stdin () in - (FStar_Compiler_Effect.op_Colon_Equals s.stdin - (FStar_Pervasives_Native.Some i); - i) in - let line = - let uu___1 = FStar_Compiler_Util.read_line stdin in - match uu___1 with - | FStar_Pervasives_Native.None -> - FStar_Compiler_Effect.exit Prims.int_zero - | FStar_Pervasives_Native.Some l -> l in - log line; - (let l = FStar_Compiler_Util.trim_string line in - if FStar_Compiler_Util.starts_with l "#end" - then - let responses = - match FStar_Compiler_Util.split l " " with - | uu___2::ok::fail::[] -> (ok, fail) - | uu___2 -> ("ok", "fail") in - let str = FStar_Compiler_Util.string_of_string_builder s.chunk in - (FStar_Compiler_Util.clear_string_builder s.chunk; - Code (str, responses)) - else - if FStar_Compiler_Util.starts_with l "#pop" - then (FStar_Compiler_Util.clear_string_builder s.chunk; Pop l) - else - if FStar_Compiler_Util.starts_with l "#push" - then - (FStar_Compiler_Util.clear_string_builder s.chunk; - (let lc_lax = - let uu___5 = - FStar_Compiler_Util.substring_from l - (FStar_Compiler_String.length "#push") in - FStar_Compiler_Util.trim_string uu___5 in - let lc = - match FStar_Compiler_Util.split lc_lax " " with - | l1::c::"#lax"::[] -> - let uu___5 = FStar_Compiler_Util.int_of_string l1 in - let uu___6 = FStar_Compiler_Util.int_of_string c in - (true, uu___5, uu___6) - | l1::c::[] -> - let uu___5 = FStar_Compiler_Util.int_of_string l1 in - let uu___6 = FStar_Compiler_Util.int_of_string c in - (false, uu___5, uu___6) - | uu___5 -> - (FStar_Errors.log_issue0 - FStar_Errors_Codes.Warning_WrongErrorLocation () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - (Prims.strcat - "Error locations may be wrong, unrecognized string after #push: " - lc_lax)); - (false, Prims.int_one, Prims.int_zero)) in - Push lc)) - else - if FStar_Compiler_Util.starts_with l "#info " - then - (match FStar_Compiler_Util.split l " " with - | uu___5::symbol::[] -> - (FStar_Compiler_Util.clear_string_builder s.chunk; - Info (symbol, true, FStar_Pervasives_Native.None)) - | uu___5::symbol::file::row::col::[] -> - (FStar_Compiler_Util.clear_string_builder s.chunk; - (let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = FStar_Compiler_Util.int_of_string row in - let uu___11 = FStar_Compiler_Util.int_of_string col in - (file, uu___10, uu___11) in - FStar_Pervasives_Native.Some uu___9 in - (symbol, false, uu___8) in - Info uu___7)) - | uu___5 -> - (FStar_Errors.log_issue0 - FStar_Errors_Codes.Error_IDEUnrecognized () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - (Prims.strcat "Unrecognized \"#info\" request: " l)); - FStar_Compiler_Effect.exit Prims.int_one)) - else - if FStar_Compiler_Util.starts_with l "#completions " - then - (match FStar_Compiler_Util.split l " " with - | uu___6::prefix::"#"::[] -> - (FStar_Compiler_Util.clear_string_builder s.chunk; - Completions prefix) - | uu___6 -> - (FStar_Errors.log_issue0 - FStar_Errors_Codes.Error_IDEUnrecognized () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - (Prims.strcat - "Unrecognized \"#completions\" request: " l)); - FStar_Compiler_Effect.exit Prims.int_one)) - else - if l = "#finish" - then FStar_Compiler_Effect.exit Prims.int_zero - else - (FStar_Compiler_Util.string_builder_append s.chunk line; - FStar_Compiler_Util.string_builder_append s.chunk "\n"; - read_chunk ())) -let (shift_chunk : unit -> input_chunks) = - fun uu___ -> - let s = the_interactive_state in - let uu___1 = FStar_Compiler_Effect.op_Bang s.buffer in - match uu___1 with - | [] -> read_chunk () - | chunk::chunks -> - (FStar_Compiler_Effect.op_Colon_Equals s.buffer chunks; chunk) -let (fill_buffer : unit -> unit) = - fun uu___ -> - let s = the_interactive_state in - let uu___1 = - let uu___2 = FStar_Compiler_Effect.op_Bang s.buffer in - let uu___3 = let uu___4 = read_chunk () in [uu___4] in - FStar_Compiler_List.op_At uu___2 uu___3 in - FStar_Compiler_Effect.op_Colon_Equals s.buffer uu___1 -let (deps_of_our_file : - Prims.string -> - (Prims.string Prims.list * Prims.string FStar_Pervasives_Native.option * - FStar_Parser_Dep.deps)) - = - fun filename -> - let uu___ = - FStar_Dependencies.find_deps_if_needed [filename] - FStar_CheckedFiles.load_parsing_data_from_cache in - match uu___ with - | (deps, dep_graph) -> - let uu___1 = - FStar_Compiler_List.partition - (fun x -> - let uu___2 = FStar_Parser_Dep.lowercase_module_name x in - let uu___3 = FStar_Parser_Dep.lowercase_module_name filename in - uu___2 <> uu___3) deps in - (match uu___1 with - | (deps1, same_name) -> - let maybe_intf = - match same_name with - | intf::impl::[] -> - ((let uu___3 = - (let uu___4 = FStar_Parser_Dep.is_interface intf in - Prims.op_Negation uu___4) || - (let uu___4 = - FStar_Parser_Dep.is_implementation impl in - Prims.op_Negation uu___4) in - if uu___3 - then - let uu___4 = - FStar_Compiler_Util.format2 - "Found %s and %s but not an interface + implementation" - intf impl in - FStar_Errors.log_issue0 - FStar_Errors_Codes.Warning_MissingInterfaceOrImplementation - () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4) - else ()); - FStar_Pervasives_Native.Some intf) - | impl::[] -> FStar_Pervasives_Native.None - | uu___2 -> - ((let uu___4 = - FStar_Compiler_Util.format1 - "Unexpected: ended up with %s" - (FStar_Compiler_String.concat " " same_name) in - FStar_Errors.log_issue0 - FStar_Errors_Codes.Warning_UnexpectedFile () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4)); - FStar_Pervasives_Native.None) in - (deps1, maybe_intf, dep_graph)) -type m_timestamps = - (Prims.string FStar_Pervasives_Native.option * Prims.string * - FStar_Compiler_Util.time FStar_Pervasives_Native.option * - FStar_Compiler_Util.time) Prims.list -let rec (tc_deps : - modul_t -> - stack_t -> - FStar_TypeChecker_Env.env -> - Prims.string Prims.list -> - m_timestamps -> - (stack_t * FStar_TypeChecker_Env.env * m_timestamps)) - = - fun m -> - fun stack -> - fun env -> - fun remaining -> - fun ts -> - match remaining with - | [] -> (stack, env, ts) - | uu___ -> - let stack1 = (env, m) :: stack in - let env1 = - let uu___1 = FStar_Options.lax () in - push_with_kind env uu___1 true "typecheck_modul" in - let uu___1 = tc_one_file remaining env1 in - (match uu___1 with - | ((intf, impl), env2, remaining1) -> - let uu___2 = - let intf_t = - match intf with - | FStar_Pervasives_Native.Some intf1 -> - let uu___3 = - FStar_Parser_ParseIt.get_file_last_modification_time - intf1 in - FStar_Pervasives_Native.Some uu___3 - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None in - let impl_t = - FStar_Parser_ParseIt.get_file_last_modification_time - impl in - (intf_t, impl_t) in - (match uu___2 with - | (intf_t, impl_t) -> - tc_deps m stack1 env2 remaining1 - ((intf, impl, intf_t, impl_t) :: ts))) -let (update_deps : - Prims.string -> - modul_t -> - stack_t -> env_t -> m_timestamps -> (stack_t * env_t * m_timestamps)) - = - fun filename -> - fun m -> - fun stk -> - fun env -> - fun ts -> - let is_stale intf impl intf_t impl_t = - let impl_mt = - FStar_Parser_ParseIt.get_file_last_modification_time impl in - (FStar_Compiler_Util.is_before impl_t impl_mt) || - (match (intf, intf_t) with - | (FStar_Pervasives_Native.Some intf1, - FStar_Pervasives_Native.Some intf_t1) -> - let intf_mt = - FStar_Parser_ParseIt.get_file_last_modification_time - intf1 in - FStar_Compiler_Util.is_before intf_t1 intf_mt - | (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None) -> false - | (uu___, uu___1) -> - failwith - "Impossible, if the interface is None, the timestamp entry should also be None") in - let rec iterate depnames st env' ts1 good_stack good_ts = - let match_dep depnames1 intf impl = - match intf with - | FStar_Pervasives_Native.None -> - (match depnames1 with - | dep::depnames' -> - if dep = impl - then (true, depnames') - else (false, depnames1) - | uu___ -> (false, depnames1)) - | FStar_Pervasives_Native.Some intf1 -> - (match depnames1 with - | depintf::dep::depnames' -> - if (depintf = intf1) && (dep = impl) - then (true, depnames') - else (false, depnames1) - | uu___ -> (false, depnames1)) in - let rec pop_tc_and_stack env1 stack ts2 = - match ts2 with - | [] -> env1 - | uu___::ts3 -> - (pop env1 ""; - (let uu___2 = - let uu___3 = FStar_Compiler_List.hd stack in - let uu___4 = FStar_Compiler_List.tl stack in - (uu___3, uu___4) in - match uu___2 with - | ((env2, uu___3), stack1) -> - pop_tc_and_stack env2 stack1 ts3)) in - match ts1 with - | ts_elt::ts' -> - let uu___ = ts_elt in - (match uu___ with - | (intf, impl, intf_t, impl_t) -> - let uu___1 = match_dep depnames intf impl in - (match uu___1 with - | (b, depnames') -> - let uu___2 = - (Prims.op_Negation b) || - (is_stale intf impl intf_t impl_t) in - if uu___2 - then - let env1 = - pop_tc_and_stack env' - (FStar_Compiler_List.rev_append st []) ts1 in - tc_deps m good_stack env1 depnames good_ts - else - (let uu___4 = - let uu___5 = FStar_Compiler_List.hd st in - let uu___6 = FStar_Compiler_List.tl st in - (uu___5, uu___6) in - match uu___4 with - | (stack_elt, st') -> - iterate depnames' st' env' ts' (stack_elt - :: good_stack) (ts_elt :: good_ts)))) - | [] -> tc_deps m good_stack env' depnames good_ts in - let uu___ = deps_of_our_file filename in - match uu___ with - | (filenames, uu___1, dep_graph) -> - iterate filenames (FStar_Compiler_List.rev_append stk []) env - (FStar_Compiler_List.rev_append ts []) [] [] -let (format_info : - FStar_TypeChecker_Env.env -> - Prims.string -> - FStar_Syntax_Syntax.term -> - FStar_Compiler_Range_Type.range -> - Prims.string FStar_Pervasives_Native.option -> Prims.string) - = - fun env -> - fun name -> - fun typ -> - fun range -> - fun doc -> - let uu___ = FStar_Compiler_Range_Ops.string_of_range range in - let uu___1 = FStar_TypeChecker_Normalize.term_to_string env typ in - let uu___2 = - match doc with - | FStar_Pervasives_Native.Some docstring -> - FStar_Compiler_Util.format1 "#doc %s" docstring - | FStar_Pervasives_Native.None -> "" in - FStar_Compiler_Util.format4 "(defined at %s) %s: %s%s" uu___ name - uu___1 uu___2 -let rec (go : - (Prims.int * Prims.int) -> - Prims.string -> stack_t -> modul_t -> env_t -> m_timestamps -> unit) - = - fun line_col -> - fun filename -> - fun stack -> - fun curmod -> - fun env -> - fun ts -> - let uu___ = shift_chunk () in - match uu___ with - | Info (symbol, fqn_only, pos_opt) -> - let info_at_pos_opt = - match pos_opt with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (file, row, col) -> - FStar_TypeChecker_Err.info_at_pos env file row col in - let info_opt = - match info_at_pos_opt with - | FStar_Pervasives_Native.Some uu___1 -> info_at_pos_opt - | FStar_Pervasives_Native.None -> - if symbol = "" - then FStar_Pervasives_Native.None - else - (let lid = - let uu___2 = - FStar_Compiler_List.map FStar_Ident.id_of_text - (FStar_Compiler_Util.split symbol ".") in - FStar_Ident.lid_of_ids uu___2 in - let lid1 = - if fqn_only - then lid - else - (let uu___3 = - FStar_Syntax_DsEnv.resolve_to_fully_qualified_name - env.FStar_TypeChecker_Env.dsenv lid in - match uu___3 with - | FStar_Pervasives_Native.None -> lid - | FStar_Pervasives_Native.Some lid2 -> lid2) in - let uu___2 = - FStar_TypeChecker_Env.try_lookup_lid env lid1 in - FStar_Compiler_Util.map_option - (fun uu___3 -> - match uu___3 with - | ((uu___4, typ), r) -> - ((FStar_Pervasives.Inr lid1), typ, r)) - uu___2) in - ((match info_opt with - | FStar_Pervasives_Native.None -> - FStar_Compiler_Util.print_string "\n#done-nok\n" - | FStar_Pervasives_Native.Some (name_or_lid, typ, rng) -> - let uu___2 = - match name_or_lid with - | FStar_Pervasives.Inl name -> - (name, FStar_Pervasives_Native.None) - | FStar_Pervasives.Inr lid -> - let uu___3 = FStar_Ident.string_of_lid lid in - (uu___3, FStar_Pervasives_Native.None) in - (match uu___2 with - | (name, doc) -> - let uu___3 = format_info env name typ rng doc in - FStar_Compiler_Util.print1 "%s\n#done-ok\n" - uu___3)); - go line_col filename stack curmod env ts) - | Completions search_term -> - let rec measure_anchored_match search_term1 candidate = - match (search_term1, candidate) with - | ([], uu___1) -> - FStar_Pervasives_Native.Some ([], Prims.int_zero) - | (uu___1, []) -> FStar_Pervasives_Native.None - | (hs::ts1, hc::tc) -> - let hc_text = FStar_Ident.string_of_id hc in - if FStar_Compiler_Util.starts_with hc_text hs - then - (match ts1 with - | [] -> - FStar_Pervasives_Native.Some - (candidate, - (FStar_Compiler_String.length hs)) - | uu___1 -> - let uu___2 = measure_anchored_match ts1 tc in - FStar_Compiler_Util.map_option - (fun uu___3 -> - match uu___3 with - | (matched, len) -> - ((hc :: matched), - (((FStar_Compiler_String.length - hc_text) - + Prims.int_one) - + len))) uu___2) - else FStar_Pervasives_Native.None in - let rec locate_match needle candidate = - let uu___1 = measure_anchored_match needle candidate in - match uu___1 with - | FStar_Pervasives_Native.Some (matched, n) -> - FStar_Pervasives_Native.Some ([], matched, n) - | FStar_Pervasives_Native.None -> - (match candidate with - | [] -> FStar_Pervasives_Native.None - | hc::tc -> - let uu___2 = locate_match needle tc in - FStar_Compiler_Util.map_option - (fun uu___3 -> - match uu___3 with - | (prefix, matched, len) -> - ((hc :: prefix), matched, len)) uu___2) in - let str_of_ids ids = - let uu___1 = - FStar_Compiler_List.map FStar_Ident.string_of_id ids in - FStar_Compiler_Util.concat_l "." uu___1 in - let match_lident_against needle lident = - let uu___1 = - let uu___2 = FStar_Ident.ns_of_lid lident in - let uu___3 = - let uu___4 = FStar_Ident.ident_of_lid lident in - [uu___4] in - FStar_Compiler_List.op_At uu___2 uu___3 in - locate_match needle uu___1 in - let shorten_namespace uu___1 = - match uu___1 with - | (prefix, matched, match_len) -> - let naked_match = - match matched with - | uu___2::[] -> true - | uu___2 -> false in - let uu___2 = - FStar_Syntax_DsEnv.shorten_module_path - env.FStar_TypeChecker_Env.dsenv prefix - naked_match in - (match uu___2 with - | (stripped_ns, shortened) -> - let uu___3 = str_of_ids shortened in - let uu___4 = str_of_ids matched in - let uu___5 = str_of_ids stripped_ns in - (uu___3, uu___4, uu___5, match_len)) in - let prepare_candidate uu___1 = - match uu___1 with - | (prefix, matched, stripped_ns, match_len) -> - if prefix = "" - then (matched, stripped_ns, match_len) - else - ((Prims.strcat prefix (Prims.strcat "." matched)), - stripped_ns, - (((FStar_Compiler_String.length prefix) + - match_len) - + Prims.int_one)) in - let needle = FStar_Compiler_Util.split search_term "." in - let all_lidents_in_env = FStar_TypeChecker_Env.lidents env in - let matches = - let case_a_find_transitive_includes orig_ns m id = - let exported_names = - FStar_Syntax_DsEnv.transitive_exported_ids - env.FStar_TypeChecker_Env.dsenv m in - let matched_length = - FStar_Compiler_List.fold_left - (fun out -> - fun s -> - ((FStar_Compiler_String.length s) + out) + - Prims.int_one) - (FStar_Compiler_String.length id) orig_ns in - FStar_Compiler_List.filter_map - (fun n -> - if FStar_Compiler_Util.starts_with n id - then - let lid = - let uu___1 = FStar_Ident.ids_of_lid m in - let uu___2 = FStar_Ident.id_of_text n in - FStar_Ident.lid_of_ns_and_id uu___1 uu___2 in - let uu___1 = - FStar_Syntax_DsEnv.resolve_to_fully_qualified_name - env.FStar_TypeChecker_Env.dsenv lid in - FStar_Compiler_Option.map - (fun fqn -> - let uu___2 = - let uu___3 = - FStar_Compiler_List.map - FStar_Ident.id_of_text orig_ns in - let uu___4 = - let uu___5 = - FStar_Ident.ident_of_lid fqn in - [uu___5] in - FStar_Compiler_List.op_At uu___3 uu___4 in - ([], uu___2, matched_length)) uu___1 - else FStar_Pervasives_Native.None) exported_names in - let case_b_find_matches_in_env uu___1 = - let matches1 = - FStar_Compiler_List.filter_map - (match_lident_against needle) all_lidents_in_env in - FStar_Compiler_List.filter - (fun uu___2 -> - match uu___2 with - | (ns, id, uu___3) -> - let uu___4 = - let uu___5 = FStar_Ident.lid_of_ids id in - FStar_Syntax_DsEnv.resolve_to_fully_qualified_name - env.FStar_TypeChecker_Env.dsenv uu___5 in - (match uu___4 with - | FStar_Pervasives_Native.None -> false - | FStar_Pervasives_Native.Some l -> - let uu___5 = - FStar_Ident.lid_of_ids - (FStar_Compiler_List.op_At ns id) in - FStar_Ident.lid_equals l uu___5)) - matches1 in - let uu___1 = FStar_Compiler_Util.prefix needle in - match uu___1 with - | (ns, id) -> - let matched_ids = - match ns with - | [] -> case_b_find_matches_in_env () - | uu___2 -> - let l = - FStar_Ident.lid_of_path ns - FStar_Compiler_Range_Type.dummyRange in - let uu___3 = - FStar_Syntax_DsEnv.resolve_module_name - env.FStar_TypeChecker_Env.dsenv l true in - (match uu___3 with - | FStar_Pervasives_Native.None -> - case_b_find_matches_in_env () - | FStar_Pervasives_Native.Some m -> - case_a_find_transitive_includes ns m id) in - FStar_Compiler_List.map - (fun x -> - let uu___2 = shorten_namespace x in - prepare_candidate uu___2) matched_ids in - ((let uu___2 = - FStar_Compiler_Util.sort_with - (fun uu___3 -> - fun uu___4 -> - match (uu___3, uu___4) with - | ((cd1, ns1, uu___5), (cd2, ns2, uu___6)) -> - (match FStar_Compiler_String.compare cd1 cd2 - with - | uu___7 when uu___7 = Prims.int_zero -> - FStar_Compiler_String.compare ns1 ns2 - | n -> n)) matches in - FStar_Compiler_List.iter - (fun uu___3 -> - match uu___3 with - | (candidate, ns, match_len) -> - let uu___4 = - FStar_Compiler_Util.string_of_int match_len in - FStar_Compiler_Util.print3 "%s %s %s \n" uu___4 - ns candidate) uu___2); - FStar_Compiler_Util.print_string "#done-ok\n"; - go line_col filename stack curmod env ts) - | Pop msg -> - (pop env msg; - (let uu___2 = - match stack with - | [] -> - (FStar_Errors.log_issue0 - FStar_Errors_Codes.Error_IDETooManyPops () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic "Too many pops"); - FStar_Compiler_Effect.exit Prims.int_one) - | hd::tl -> (hd, tl) in - match uu___2 with - | ((env1, curmod1), stack1) -> - go line_col filename stack1 curmod1 env1 ts)) - | Push (lax, l, c) -> - let uu___1 = - if - (FStar_Compiler_List.length stack) = - (FStar_Compiler_List.length ts) - then - let uu___2 = update_deps filename curmod stack env ts in - (true, uu___2) - else (false, (stack, env, ts)) in - (match uu___1 with - | (restore_cmd_line_options, (stack1, env1, ts1)) -> - let stack2 = (env1, curmod) :: stack1 in - let env2 = - push_with_kind env1 lax restore_cmd_line_options - "#push" in - go (l, c) filename stack2 curmod env2 ts1) - | Code (text, (ok, fail)) -> - let fail1 curmod1 tcenv = - report_fail (); - FStar_Compiler_Util.print1 "%s\n" fail; - go line_col filename stack curmod1 tcenv ts in - let frag = - { - FStar_Parser_ParseIt.frag_fname = " input"; - FStar_Parser_ParseIt.frag_text = text; - FStar_Parser_ParseIt.frag_line = - (FStar_Pervasives_Native.fst line_col); - FStar_Parser_ParseIt.frag_col = - (FStar_Pervasives_Native.snd line_col) - } in - let res = check_frag env curmod (frag, []) in - (match res with - | FStar_Pervasives_Native.Some (curmod1, env1, n_errs) -> - if n_errs = Prims.int_zero - then - (FStar_Compiler_Util.print1 "\n%s\n" ok; - go line_col filename stack curmod1 env1 ts) - else fail1 curmod1 env1 - | uu___1 -> fail1 curmod env) -let (interactive_mode : Prims.string -> unit) = - fun filename -> - (let uu___1 = - let uu___2 = FStar_Options.codegen () in - FStar_Compiler_Option.isSome uu___2 in - if uu___1 - then - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_IDEIgnoreCodeGen () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Code-generation is not supported in interactive mode, ignoring the codegen flag") - else ()); - (let uu___1 = deps_of_our_file filename in - match uu___1 with - | (filenames, maybe_intf, dep_graph) -> - let env = FStar_Universal.init_env dep_graph in - let uu___2 = - tc_deps FStar_Pervasives_Native.None [] env filenames [] in - (match uu___2 with - | (stack, env1, ts) -> - let initial_range = - let uu___3 = - FStar_Compiler_Range_Type.mk_pos Prims.int_one - Prims.int_zero in - let uu___4 = - FStar_Compiler_Range_Type.mk_pos Prims.int_one - Prims.int_zero in - FStar_Compiler_Range_Type.mk_range filename uu___3 uu___4 in - let env2 = FStar_TypeChecker_Env.set_range env1 initial_range in - let env3 = - match maybe_intf with - | FStar_Pervasives_Native.Some intf -> - FStar_Universal.load_interface_decls env2 intf - | FStar_Pervasives_Native.None -> env2 in - let uu___3 = - (FStar_Options.record_hints ()) || - (FStar_Options.use_hints ()) in - if uu___3 - then - let uu___4 = - let uu___5 = FStar_Options.file_list () in - FStar_Compiler_List.hd uu___5 in - FStar_SMTEncoding_Solver.with_hints_db uu___4 - (fun uu___5 -> - go (Prims.int_one, Prims.int_zero) filename stack - FStar_Pervasives_Native.None env3 ts) - else - go (Prims.int_one, Prims.int_zero) filename stack - FStar_Pervasives_Native.None env3 ts)) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Interactive_Lsp.ml b/ocaml/fstar-lib/generated/FStar_Interactive_Lsp.ml deleted file mode 100644 index 781fb8c26c8..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Interactive_Lsp.ml +++ /dev/null @@ -1,515 +0,0 @@ -open Prims -let (unpack_lsp_query : - (Prims.string * FStar_Json.json) Prims.list -> - FStar_Interactive_JsonHelper.lsp_query) - = - fun r -> - let qid = - let uu___ = FStar_Interactive_JsonHelper.try_assoc "id" r in - FStar_Compiler_Util.map_option FStar_Interactive_JsonHelper.js_str_int - uu___ in - try - (fun uu___ -> - match () with - | () -> - let method1 = - let uu___1 = FStar_Interactive_JsonHelper.assoc "method" r in - FStar_Interactive_JsonHelper.js_str uu___1 in - let uu___1 = - match method1 with - | "initialize" -> - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Interactive_JsonHelper.arg "processId" r in - FStar_Interactive_JsonHelper.js_int uu___4 in - let uu___4 = - let uu___5 = - FStar_Interactive_JsonHelper.arg "rootUri" r in - FStar_Interactive_JsonHelper.js_str uu___5 in - (uu___3, uu___4) in - FStar_Interactive_JsonHelper.Initialize uu___2 - | "initialized" -> FStar_Interactive_JsonHelper.Initialized - | "shutdown" -> FStar_Interactive_JsonHelper.Shutdown - | "exit" -> FStar_Interactive_JsonHelper.Exit - | "$/cancelRequest" -> - let uu___2 = - let uu___3 = FStar_Interactive_JsonHelper.arg "id" r in - FStar_Interactive_JsonHelper.js_str_int uu___3 in - FStar_Interactive_JsonHelper.Cancel uu___2 - | "workspace/didChangeWorkspaceFolders" -> - let uu___2 = - let uu___3 = FStar_Interactive_JsonHelper.arg "event" r in - FStar_Interactive_JsonHelper.js_wsch_event uu___3 in - FStar_Interactive_JsonHelper.FolderChange uu___2 - | "workspace/didChangeConfiguration" -> - FStar_Interactive_JsonHelper.ChangeConfig - | "workspace/didChangeWatchedFiles" -> - FStar_Interactive_JsonHelper.ChangeWatch - | "workspace/symbol" -> - let uu___2 = - let uu___3 = FStar_Interactive_JsonHelper.arg "query" r in - FStar_Interactive_JsonHelper.js_str uu___3 in - FStar_Interactive_JsonHelper.Symbol uu___2 - | "workspace/executeCommand" -> - let uu___2 = - let uu___3 = - FStar_Interactive_JsonHelper.arg "command" r in - FStar_Interactive_JsonHelper.js_str uu___3 in - FStar_Interactive_JsonHelper.ExecCommand uu___2 - | "textDocument/didOpen" -> - let uu___2 = - let uu___3 = - FStar_Interactive_JsonHelper.arg "textDocument" r in - FStar_Interactive_JsonHelper.js_txdoc_item uu___3 in - FStar_Interactive_JsonHelper.DidOpen uu___2 - | "textDocument/didChange" -> - let uu___2 = - let uu___3 = FStar_Interactive_JsonHelper.js_txdoc_id r in - let uu___4 = - let uu___5 = - FStar_Interactive_JsonHelper.arg "contentChanges" r in - FStar_Interactive_JsonHelper.js_contentch uu___5 in - (uu___3, uu___4) in - FStar_Interactive_JsonHelper.DidChange uu___2 - | "textDocument/willSave" -> - let uu___2 = FStar_Interactive_JsonHelper.js_txdoc_id r in - FStar_Interactive_JsonHelper.WillSave uu___2 - | "textDocument/willSaveWaitUntil" -> - let uu___2 = FStar_Interactive_JsonHelper.js_txdoc_id r in - FStar_Interactive_JsonHelper.WillSaveWait uu___2 - | "textDocument/didSave" -> - let uu___2 = - let uu___3 = FStar_Interactive_JsonHelper.js_txdoc_id r in - let uu___4 = - let uu___5 = FStar_Interactive_JsonHelper.arg "text" r in - FStar_Interactive_JsonHelper.js_str uu___5 in - (uu___3, uu___4) in - FStar_Interactive_JsonHelper.DidSave uu___2 - | "textDocument/didClose" -> - let uu___2 = FStar_Interactive_JsonHelper.js_txdoc_id r in - FStar_Interactive_JsonHelper.DidClose uu___2 - | "textDocument/completion" -> - let uu___2 = - let uu___3 = FStar_Interactive_JsonHelper.js_txdoc_pos r in - let uu___4 = - let uu___5 = - FStar_Interactive_JsonHelper.arg "context" r in - FStar_Interactive_JsonHelper.js_compl_context uu___5 in - (uu___3, uu___4) in - FStar_Interactive_JsonHelper.Completion uu___2 - | "completionItem/resolve" -> - FStar_Interactive_JsonHelper.Resolve - | "textDocument/hover" -> - let uu___2 = FStar_Interactive_JsonHelper.js_txdoc_pos r in - FStar_Interactive_JsonHelper.Hover uu___2 - | "textDocument/signatureHelp" -> - let uu___2 = FStar_Interactive_JsonHelper.js_txdoc_pos r in - FStar_Interactive_JsonHelper.SignatureHelp uu___2 - | "textDocument/declaration" -> - let uu___2 = FStar_Interactive_JsonHelper.js_txdoc_pos r in - FStar_Interactive_JsonHelper.Declaration uu___2 - | "textDocument/definition" -> - let uu___2 = FStar_Interactive_JsonHelper.js_txdoc_pos r in - FStar_Interactive_JsonHelper.Definition uu___2 - | "textDocument/typeDefinition" -> - let uu___2 = FStar_Interactive_JsonHelper.js_txdoc_pos r in - FStar_Interactive_JsonHelper.TypeDefinition uu___2 - | "textDocument/implementation" -> - let uu___2 = FStar_Interactive_JsonHelper.js_txdoc_pos r in - FStar_Interactive_JsonHelper.Implementation uu___2 - | "textDocument/references" -> - FStar_Interactive_JsonHelper.References - | "textDocument/documentHighlight" -> - let uu___2 = FStar_Interactive_JsonHelper.js_txdoc_pos r in - FStar_Interactive_JsonHelper.DocumentHighlight uu___2 - | "textDocument/documentSymbol" -> - FStar_Interactive_JsonHelper.DocumentSymbol - | "textDocument/codeAction" -> - FStar_Interactive_JsonHelper.CodeAction - | "textDocument/codeLens" -> - FStar_Interactive_JsonHelper.CodeLens - | "codeLens/resolve" -> - FStar_Interactive_JsonHelper.CodeLensResolve - | "textDocument/documentLink" -> - FStar_Interactive_JsonHelper.DocumentLink - | "documentLink/resolve" -> - FStar_Interactive_JsonHelper.DocumentLinkResolve - | "textDocument/documentColor" -> - FStar_Interactive_JsonHelper.DocumentColor - | "textDocument/colorPresentation" -> - FStar_Interactive_JsonHelper.ColorPresentation - | "textDocument/formatting" -> - FStar_Interactive_JsonHelper.Formatting - | "textDocument/rangeFormatting" -> - FStar_Interactive_JsonHelper.RangeFormatting - | "textDocument/onTypeFormatting" -> - FStar_Interactive_JsonHelper.TypeFormatting - | "textDocument/rename" -> FStar_Interactive_JsonHelper.Rename - | "textDocument/prepareRename" -> - let uu___2 = FStar_Interactive_JsonHelper.js_txdoc_pos r in - FStar_Interactive_JsonHelper.PrepareRename uu___2 - | "textDocument/foldingRange" -> - FStar_Interactive_JsonHelper.FoldingRange - | m -> - let uu___2 = - FStar_Compiler_Util.format1 "Unknown method '%s'" m in - FStar_Interactive_JsonHelper.BadProtocolMsg uu___2 in - { - FStar_Interactive_JsonHelper.query_id = qid; - FStar_Interactive_JsonHelper.q = uu___1 - }) () - with - | FStar_Interactive_JsonHelper.MissingKey msg -> - { - FStar_Interactive_JsonHelper.query_id = qid; - FStar_Interactive_JsonHelper.q = - (FStar_Interactive_JsonHelper.BadProtocolMsg msg) - } - | FStar_Interactive_JsonHelper.UnexpectedJsonType (expected, got) -> - FStar_Interactive_JsonHelper.wrap_jsfail qid expected got -let (deserialize_lsp_query : - FStar_Json.json -> FStar_Interactive_JsonHelper.lsp_query) = - fun js_query -> - try - (fun uu___ -> - match () with - | () -> - let uu___1 = FStar_Interactive_JsonHelper.js_assoc js_query in - unpack_lsp_query uu___1) () - with - | FStar_Interactive_JsonHelper.UnexpectedJsonType (expected, got) -> - FStar_Interactive_JsonHelper.wrap_jsfail FStar_Pervasives_Native.None - expected got -let (parse_lsp_query : - Prims.string -> FStar_Interactive_JsonHelper.lsp_query) = - fun query_str -> - let uu___1 = FStar_Json.json_of_string query_str in - match uu___1 with - | FStar_Pervasives_Native.None -> - { - FStar_Interactive_JsonHelper.query_id = - FStar_Pervasives_Native.None; - FStar_Interactive_JsonHelper.q = - (FStar_Interactive_JsonHelper.BadProtocolMsg - "Json parsing failed") - } - | FStar_Pervasives_Native.Some request -> deserialize_lsp_query request -let (repl_state_init : - Prims.string -> FStar_Interactive_Ide_Types.repl_state) = - fun fname -> - let intial_range = - let uu___ = - FStar_Compiler_Range_Type.mk_pos Prims.int_one Prims.int_zero in - let uu___1 = - FStar_Compiler_Range_Type.mk_pos Prims.int_one Prims.int_zero in - FStar_Compiler_Range_Type.mk_range fname uu___ uu___1 in - let env = FStar_Universal.init_env FStar_Parser_Dep.empty_deps in - let env1 = FStar_TypeChecker_Env.set_range env intial_range in - let uu___ = FStar_Compiler_Util.open_stdin () in - { - FStar_Interactive_Ide_Types.repl_line = Prims.int_one; - FStar_Interactive_Ide_Types.repl_column = Prims.int_zero; - FStar_Interactive_Ide_Types.repl_fname = fname; - FStar_Interactive_Ide_Types.repl_deps_stack = []; - FStar_Interactive_Ide_Types.repl_curmod = FStar_Pervasives_Native.None; - FStar_Interactive_Ide_Types.repl_env = env1; - FStar_Interactive_Ide_Types.repl_stdin = uu___; - FStar_Interactive_Ide_Types.repl_names = - FStar_Interactive_CompletionTable.empty; - FStar_Interactive_Ide_Types.repl_buffered_input_queries = []; - FStar_Interactive_Ide_Types.repl_lang = [] - } -type optresponse = - FStar_Interactive_JsonHelper.assoct FStar_Pervasives_Native.option -type either_gst_exit = - (FStar_Interactive_Ide_Types.grepl_state, Prims.int) - FStar_Pervasives.either -let (invoke_full_lax : - FStar_Interactive_Ide_Types.grepl_state -> - Prims.string -> - Prims.string -> Prims.bool -> (optresponse * either_gst_exit)) - = - fun gst -> - fun fname -> - fun text -> - fun force -> - let aux uu___ = - FStar_Parser_ParseIt.add_vfs_entry fname text; - (let uu___2 = - let uu___3 = repl_state_init fname in - FStar_Interactive_PushHelper.full_lax text uu___3 in - match uu___2 with - | (diag, st') -> - let repls = - FStar_Compiler_Util.psmap_add - gst.FStar_Interactive_Ide_Types.grepl_repls fname st' in - let diag1 = - if FStar_Compiler_Util.is_some diag - then diag - else - (let uu___4 = - FStar_Interactive_JsonHelper.js_diag_clear fname in - FStar_Pervasives_Native.Some uu___4) in - (diag1, - (FStar_Pervasives.Inl - { - FStar_Interactive_Ide_Types.grepl_repls = repls; - FStar_Interactive_Ide_Types.grepl_stdin = - (gst.FStar_Interactive_Ide_Types.grepl_stdin) - }))) in - let uu___ = - FStar_Compiler_Util.psmap_try_find - gst.FStar_Interactive_Ide_Types.grepl_repls fname in - match uu___ with - | FStar_Pervasives_Native.Some uu___1 -> - if force - then aux () - else (FStar_Pervasives_Native.None, (FStar_Pervasives.Inl gst)) - | FStar_Pervasives_Native.None -> aux () -let (run_query : - FStar_Interactive_Ide_Types.grepl_state -> - FStar_Interactive_JsonHelper.lquery -> (optresponse * either_gst_exit)) - = - fun gst -> - fun q -> - match q with - | FStar_Interactive_JsonHelper.Initialize (uu___, uu___1) -> - let uu___2 = - FStar_Interactive_JsonHelper.resultResponse - FStar_Interactive_JsonHelper.js_servcap in - (uu___2, (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.Initialized -> - (FStar_Pervasives_Native.None, (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.Shutdown -> - (FStar_Interactive_JsonHelper.nullResponse, - (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.Exit -> - (FStar_Pervasives_Native.None, - (FStar_Pervasives.Inr Prims.int_zero)) - | FStar_Interactive_JsonHelper.Cancel id -> - (FStar_Pervasives_Native.None, (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.FolderChange evt -> - (FStar_Interactive_JsonHelper.nullResponse, - (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.ChangeConfig -> - (FStar_Interactive_JsonHelper.nullResponse, - (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.ChangeWatch -> - (FStar_Pervasives_Native.None, (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.Symbol sym -> - (FStar_Interactive_JsonHelper.nullResponse, - (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.ExecCommand cmd -> - (FStar_Interactive_JsonHelper.nullResponse, - (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.DidOpen - { FStar_Interactive_JsonHelper.fname = f; - FStar_Interactive_JsonHelper.langId = uu___; - FStar_Interactive_JsonHelper.version = uu___1; - FStar_Interactive_JsonHelper.text = t;_} - -> invoke_full_lax gst f t false - | FStar_Interactive_JsonHelper.DidChange (txid, content) -> - (FStar_Parser_ParseIt.add_vfs_entry txid content; - (FStar_Pervasives_Native.None, (FStar_Pervasives.Inl gst))) - | FStar_Interactive_JsonHelper.WillSave txid -> - (FStar_Pervasives_Native.None, (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.WillSaveWait txid -> - (FStar_Interactive_JsonHelper.nullResponse, - (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.DidSave (f, t) -> - invoke_full_lax gst f t true - | FStar_Interactive_JsonHelper.DidClose txid -> - (FStar_Pervasives_Native.None, (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.Completion (txpos, ctx) -> - let uu___ = - FStar_Compiler_Util.psmap_try_find - gst.FStar_Interactive_Ide_Types.grepl_repls - txpos.FStar_Interactive_JsonHelper.path in - (match uu___ with - | FStar_Pervasives_Native.Some st -> - let uu___1 = FStar_Interactive_QueryHelper.complookup st txpos in - (uu___1, (FStar_Pervasives.Inl gst)) - | FStar_Pervasives_Native.None -> - (FStar_Interactive_JsonHelper.nullResponse, - (FStar_Pervasives.Inl gst))) - | FStar_Interactive_JsonHelper.Resolve -> - (FStar_Interactive_JsonHelper.nullResponse, - (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.Hover txpos -> - let uu___ = - FStar_Compiler_Util.psmap_try_find - gst.FStar_Interactive_Ide_Types.grepl_repls - txpos.FStar_Interactive_JsonHelper.path in - (match uu___ with - | FStar_Pervasives_Native.Some st -> - let uu___1 = - FStar_Interactive_QueryHelper.hoverlookup - st.FStar_Interactive_Ide_Types.repl_env txpos in - (uu___1, (FStar_Pervasives.Inl gst)) - | FStar_Pervasives_Native.None -> - (FStar_Interactive_JsonHelper.nullResponse, - (FStar_Pervasives.Inl gst))) - | FStar_Interactive_JsonHelper.SignatureHelp txpos -> - (FStar_Interactive_JsonHelper.nullResponse, - (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.Declaration txpos -> - (FStar_Interactive_JsonHelper.nullResponse, - (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.Definition txpos -> - let uu___ = - FStar_Compiler_Util.psmap_try_find - gst.FStar_Interactive_Ide_Types.grepl_repls - txpos.FStar_Interactive_JsonHelper.path in - (match uu___ with - | FStar_Pervasives_Native.Some st -> - let uu___1 = - FStar_Interactive_QueryHelper.deflookup - st.FStar_Interactive_Ide_Types.repl_env txpos in - (uu___1, (FStar_Pervasives.Inl gst)) - | FStar_Pervasives_Native.None -> - (FStar_Interactive_JsonHelper.nullResponse, - (FStar_Pervasives.Inl gst))) - | FStar_Interactive_JsonHelper.TypeDefinition txpos -> - (FStar_Interactive_JsonHelper.nullResponse, - (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.Implementation txpos -> - (FStar_Interactive_JsonHelper.nullResponse, - (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.References -> - (FStar_Interactive_JsonHelper.nullResponse, - (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.DocumentHighlight txpos -> - (FStar_Interactive_JsonHelper.nullResponse, - (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.DocumentSymbol -> - (FStar_Interactive_JsonHelper.nullResponse, - (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.CodeAction -> - (FStar_Interactive_JsonHelper.nullResponse, - (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.CodeLens -> - (FStar_Interactive_JsonHelper.nullResponse, - (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.CodeLensResolve -> - (FStar_Interactive_JsonHelper.nullResponse, - (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.DocumentLink -> - (FStar_Interactive_JsonHelper.nullResponse, - (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.DocumentLinkResolve -> - (FStar_Interactive_JsonHelper.nullResponse, - (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.DocumentColor -> - (FStar_Interactive_JsonHelper.nullResponse, - (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.ColorPresentation -> - (FStar_Interactive_JsonHelper.nullResponse, - (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.Formatting -> - (FStar_Interactive_JsonHelper.nullResponse, - (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.RangeFormatting -> - (FStar_Interactive_JsonHelper.nullResponse, - (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.TypeFormatting -> - (FStar_Interactive_JsonHelper.nullResponse, - (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.Rename -> - (FStar_Interactive_JsonHelper.nullResponse, - (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.PrepareRename txpos -> - (FStar_Interactive_JsonHelper.nullResponse, - (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.FoldingRange -> - (FStar_Interactive_JsonHelper.nullResponse, - (FStar_Pervasives.Inl gst)) - | FStar_Interactive_JsonHelper.BadProtocolMsg msg -> - let uu___ = - let uu___1 = - FStar_Interactive_JsonHelper.js_resperr - FStar_Interactive_JsonHelper.MethodNotFound msg in - FStar_Interactive_JsonHelper.errorResponse uu___1 in - (uu___, (FStar_Pervasives.Inl gst)) -let rec (parse_header_len : - FStar_Compiler_Util.stream_reader -> Prims.int -> Prims.int) = - fun stream -> - fun len -> - let uu___ = FStar_Compiler_Util.read_line stream in - match uu___ with - | FStar_Pervasives_Native.Some s -> - if FStar_Compiler_Util.starts_with s "Content-Length: " - then - let uu___1 = - let uu___2 = - FStar_Compiler_Util.substring_from s (Prims.of_int (16)) in - FStar_Compiler_Util.safe_int_of_string uu___2 in - (match uu___1 with - | FStar_Pervasives_Native.Some new_len -> - parse_header_len stream new_len - | FStar_Pervasives_Native.None -> - FStar_Compiler_Effect.raise - FStar_Interactive_JsonHelper.MalformedHeader) - else - if FStar_Compiler_Util.starts_with s "Content-Type: " - then parse_header_len stream len - else - if s = "" - then len - else - FStar_Compiler_Effect.raise - FStar_Interactive_JsonHelper.MalformedHeader - | FStar_Pervasives_Native.None -> - FStar_Compiler_Effect.raise - FStar_Interactive_JsonHelper.InputExhausted -let rec (read_lsp_query : - FStar_Compiler_Util.stream_reader -> FStar_Interactive_JsonHelper.lsp_query) - = - fun stream -> - try - (fun uu___ -> - match () with - | () -> - let n = parse_header_len stream Prims.int_zero in - let uu___1 = FStar_Compiler_Util.nread stream n in - (match uu___1 with - | FStar_Pervasives_Native.Some s -> parse_lsp_query s - | FStar_Pervasives_Native.None -> - let uu___2 = - let uu___3 = FStar_Compiler_Util.string_of_int n in - FStar_Compiler_Util.format1 "Could not read %s bytes" - uu___3 in - FStar_Interactive_JsonHelper.wrap_content_szerr uu___2)) () - with - | FStar_Interactive_JsonHelper.MalformedHeader -> - (FStar_Compiler_Util.print_error "[E] Malformed Content Header\n"; - read_lsp_query stream) - | FStar_Interactive_JsonHelper.InputExhausted -> read_lsp_query stream -let rec (go : FStar_Interactive_Ide_Types.grepl_state -> Prims.int) = - fun gst -> - let query = read_lsp_query gst.FStar_Interactive_Ide_Types.grepl_stdin in - let uu___ = run_query gst query.FStar_Interactive_JsonHelper.q in - match uu___ with - | (r, state_opt) -> - ((match r with - | FStar_Pervasives_Native.Some response -> - let response' = - FStar_Interactive_JsonHelper.json_of_response - query.FStar_Interactive_JsonHelper.query_id response in - FStar_Interactive_JsonHelper.write_jsonrpc response' - | FStar_Pervasives_Native.None -> ()); - (match state_opt with - | FStar_Pervasives.Inl gst' -> go gst' - | FStar_Pervasives.Inr exitcode -> exitcode)) -let (start_server : unit -> unit) = - fun uu___ -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Compiler_Util.psmap_empty () in - let uu___4 = FStar_Compiler_Util.open_stdin () in - { - FStar_Interactive_Ide_Types.grepl_repls = uu___3; - FStar_Interactive_Ide_Types.grepl_stdin = uu___4 - } in - go uu___2 in - FStar_Compiler_Effect.exit uu___1 \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Interactive_PushHelper.ml b/ocaml/fstar-lib/generated/FStar_Interactive_PushHelper.ml deleted file mode 100644 index f159fd62edc..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Interactive_PushHelper.ml +++ /dev/null @@ -1,953 +0,0 @@ -open Prims -type ctx_depth_t = - (Prims.int * Prims.int * FStar_TypeChecker_Env.solver_depth_t * Prims.int) -type deps_t = FStar_Parser_Dep.deps -type either_replst = - (FStar_Interactive_Ide_Types.repl_state, - FStar_Interactive_Ide_Types.repl_state) FStar_Pervasives.either -type name_tracking_event = - | NTAlias of (FStar_Ident.lid * FStar_Ident.ident * FStar_Ident.lid) - | NTOpen of (FStar_Ident.lid * - FStar_Syntax_Syntax.open_module_or_namespace) - | NTInclude of (FStar_Ident.lid * FStar_Ident.lid) - | NTBinding of (FStar_Syntax_Syntax.binding, - FStar_TypeChecker_Env.sig_binding) FStar_Pervasives.either -let (uu___is_NTAlias : name_tracking_event -> Prims.bool) = - fun projectee -> match projectee with | NTAlias _0 -> true | uu___ -> false -let (__proj__NTAlias__item___0 : - name_tracking_event -> - (FStar_Ident.lid * FStar_Ident.ident * FStar_Ident.lid)) - = fun projectee -> match projectee with | NTAlias _0 -> _0 -let (uu___is_NTOpen : name_tracking_event -> Prims.bool) = - fun projectee -> match projectee with | NTOpen _0 -> true | uu___ -> false -let (__proj__NTOpen__item___0 : - name_tracking_event -> - (FStar_Ident.lid * FStar_Syntax_Syntax.open_module_or_namespace)) - = fun projectee -> match projectee with | NTOpen _0 -> _0 -let (uu___is_NTInclude : name_tracking_event -> Prims.bool) = - fun projectee -> - match projectee with | NTInclude _0 -> true | uu___ -> false -let (__proj__NTInclude__item___0 : - name_tracking_event -> (FStar_Ident.lid * FStar_Ident.lid)) = - fun projectee -> match projectee with | NTInclude _0 -> _0 -let (uu___is_NTBinding : name_tracking_event -> Prims.bool) = - fun projectee -> - match projectee with | NTBinding _0 -> true | uu___ -> false -let (__proj__NTBinding__item___0 : - name_tracking_event -> - (FStar_Syntax_Syntax.binding, FStar_TypeChecker_Env.sig_binding) - FStar_Pervasives.either) - = fun projectee -> match projectee with | NTBinding _0 -> _0 -let (repl_stack : - FStar_Interactive_Ide_Types.repl_stack_t FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref [] -let (set_check_kind : - FStar_TypeChecker_Env.env_t -> - FStar_Interactive_Ide_Types.push_kind -> FStar_TypeChecker_Env.env_t) - = - fun env -> - fun check_kind -> - let uu___ = - (check_kind = FStar_Interactive_Ide_Types.LaxCheck) || - (FStar_Options.lax ()) in - let uu___1 = - FStar_Syntax_DsEnv.set_syntax_only env.FStar_TypeChecker_Env.dsenv - (check_kind = FStar_Interactive_Ide_Types.SyntaxCheck) in - { - FStar_TypeChecker_Env.solver = (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = (env.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = uu___; - FStar_TypeChecker_Env.lax_universes = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = uu___1; - FStar_TypeChecker_Env.nbe = (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env.FStar_TypeChecker_Env.missing_decl) - } -let (repl_ld_tasks_of_deps : - Prims.string Prims.list -> - FStar_Interactive_Ide_Types.repl_task Prims.list -> - FStar_Interactive_Ide_Types.repl_task Prims.list) - = - fun deps -> - fun final_tasks -> - let wrap fname = - let uu___ = FStar_Compiler_Util.now () in - { - FStar_Interactive_Ide_Types.tf_fname = fname; - FStar_Interactive_Ide_Types.tf_modtime = uu___ - } in - let rec aux deps1 final_tasks1 = - match deps1 with - | intf::impl::deps' when FStar_Universal.needs_interleaving intf impl - -> - let uu___ = - let uu___1 = - let uu___2 = wrap intf in - let uu___3 = wrap impl in (uu___2, uu___3) in - FStar_Interactive_Ide_Types.LDInterleaved uu___1 in - let uu___1 = aux deps' final_tasks1 in uu___ :: uu___1 - | intf_or_impl::deps' -> - let uu___ = - let uu___1 = wrap intf_or_impl in - FStar_Interactive_Ide_Types.LDSingle uu___1 in - let uu___1 = aux deps' final_tasks1 in uu___ :: uu___1 - | [] -> final_tasks1 in - aux deps final_tasks -let (deps_and_repl_ld_tasks_of_our_file : - Prims.string -> - (Prims.string Prims.list * FStar_Interactive_Ide_Types.repl_task - Prims.list * deps_t)) - = - fun filename -> - let get_mod_name fname = FStar_Parser_Dep.lowercase_module_name fname in - let our_mod_name = get_mod_name filename in - let has_our_mod_name f = - let uu___ = get_mod_name f in uu___ = our_mod_name in - let parse_data_cache = FStar_CheckedFiles.load_parsing_data_from_cache in - let uu___ = - FStar_Dependencies.find_deps_if_needed [filename] parse_data_cache in - match uu___ with - | (deps, dep_graph) -> - let uu___1 = FStar_Compiler_List.partition has_our_mod_name deps in - (match uu___1 with - | (same_name, real_deps) -> - let intf_tasks = - match same_name with - | intf::impl::[] -> - ((let uu___3 = - let uu___4 = FStar_Parser_Dep.is_interface intf in - Prims.op_Negation uu___4 in - if uu___3 - then - let uu___4 = - FStar_Compiler_Util.format1 - "Expecting an interface, got %s" intf in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_MissingInterface () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4) - else ()); - (let uu___4 = - let uu___5 = FStar_Parser_Dep.is_implementation impl in - Prims.op_Negation uu___5 in - if uu___4 - then - let uu___5 = - FStar_Compiler_Util.format1 - "Expecting an implementation, got %s" impl in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_MissingImplementation () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___5) - else ()); - (let uu___4 = - let uu___5 = - let uu___6 = FStar_Compiler_Util.now () in - { - FStar_Interactive_Ide_Types.tf_fname = intf; - FStar_Interactive_Ide_Types.tf_modtime = uu___6 - } in - FStar_Interactive_Ide_Types.LDInterfaceOfCurrentFile - uu___5 in - [uu___4])) - | impl::[] -> [] - | uu___2 -> - let mods_str = FStar_Compiler_String.concat " " same_name in - let message = "Too many or too few files matching %s: %s" in - ((let uu___4 = - FStar_Compiler_Util.format message - [our_mod_name; mods_str] in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_TooManyOrTooFewFileMatch () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4)); - []) in - let tasks = repl_ld_tasks_of_deps real_deps intf_tasks in - (real_deps, tasks, dep_graph)) -let (snapshot_env : - FStar_TypeChecker_Env.env -> - Prims.string -> - (FStar_Interactive_Ide_Types.repl_depth_t * - FStar_TypeChecker_Env.env_t)) - = - fun env -> - fun msg -> - let uu___ = FStar_TypeChecker_Tc.snapshot_context env msg in - match uu___ with - | (ctx_depth, env1) -> - let uu___1 = FStar_Options.snapshot () in - (match uu___1 with - | (opt_depth, ()) -> ((ctx_depth, opt_depth), env1)) -let (push_repl : - Prims.string -> - FStar_Interactive_Ide_Types.push_kind FStar_Pervasives_Native.option -> - FStar_Interactive_Ide_Types.repl_task -> - FStar_Interactive_Ide_Types.repl_state -> - FStar_Interactive_Ide_Types.repl_state) - = - fun msg -> - fun push_kind_opt -> - fun task -> - fun st -> - let uu___ = - snapshot_env st.FStar_Interactive_Ide_Types.repl_env msg in - match uu___ with - | (depth, env) -> - ((let uu___2 = - let uu___3 = FStar_Compiler_Effect.op_Bang repl_stack in - (depth, (task, st)) :: uu___3 in - FStar_Compiler_Effect.op_Colon_Equals repl_stack uu___2); - (match push_kind_opt with - | FStar_Pervasives_Native.None -> st - | FStar_Pervasives_Native.Some push_kind -> - let uu___2 = set_check_kind env push_kind in - { - FStar_Interactive_Ide_Types.repl_line = - (st.FStar_Interactive_Ide_Types.repl_line); - FStar_Interactive_Ide_Types.repl_column = - (st.FStar_Interactive_Ide_Types.repl_column); - FStar_Interactive_Ide_Types.repl_fname = - (st.FStar_Interactive_Ide_Types.repl_fname); - FStar_Interactive_Ide_Types.repl_deps_stack = - (st.FStar_Interactive_Ide_Types.repl_deps_stack); - FStar_Interactive_Ide_Types.repl_curmod = - (st.FStar_Interactive_Ide_Types.repl_curmod); - FStar_Interactive_Ide_Types.repl_env = uu___2; - FStar_Interactive_Ide_Types.repl_stdin = - (st.FStar_Interactive_Ide_Types.repl_stdin); - FStar_Interactive_Ide_Types.repl_names = - (st.FStar_Interactive_Ide_Types.repl_names); - FStar_Interactive_Ide_Types.repl_buffered_input_queries - = - (st.FStar_Interactive_Ide_Types.repl_buffered_input_queries); - FStar_Interactive_Ide_Types.repl_lang = - (st.FStar_Interactive_Ide_Types.repl_lang) - })) -let (add_issues_to_push_fragment : FStar_Json.json Prims.list -> unit) = - fun issues -> - let uu___ = FStar_Compiler_Effect.op_Bang repl_stack in - match uu___ with - | (depth, - (FStar_Interactive_Ide_Types.PushFragment (frag, push_kind, i), st))::rest - -> - let pf = - FStar_Interactive_Ide_Types.PushFragment - (frag, push_kind, (FStar_Compiler_List.op_At issues i)) in - FStar_Compiler_Effect.op_Colon_Equals repl_stack ((depth, (pf, st)) - :: rest) - | uu___1 -> () -let (rollback_env : - FStar_TypeChecker_Env.solver_t -> - Prims.string -> - ((Prims.int * Prims.int * FStar_TypeChecker_Env.solver_depth_t * - Prims.int) * Prims.int) -> FStar_TypeChecker_Env.env) - = - fun solver -> - fun msg -> - fun uu___ -> - match uu___ with - | (ctx_depth, opt_depth) -> - let env = - FStar_TypeChecker_Tc.rollback_context solver msg - (FStar_Pervasives_Native.Some ctx_depth) in - (FStar_Options.rollback (FStar_Pervasives_Native.Some opt_depth); - env) -let (pop_repl : - Prims.string -> - FStar_Interactive_Ide_Types.repl_state -> - FStar_Interactive_Ide_Types.repl_state) - = - fun msg -> - fun st -> - let uu___ = FStar_Compiler_Effect.op_Bang repl_stack in - match uu___ with - | [] -> failwith "Too many pops" - | (depth, (uu___1, st'))::stack_tl -> - let env = - rollback_env - (st.FStar_Interactive_Ide_Types.repl_env).FStar_TypeChecker_Env.solver - msg depth in - (FStar_Compiler_Effect.op_Colon_Equals repl_stack stack_tl; - (let uu___4 = - FStar_Compiler_Util.physical_equality env - st'.FStar_Interactive_Ide_Types.repl_env in - FStar_Common.runtime_assert uu___4 "Inconsistent stack state"); - st') -let (tc_one : - FStar_TypeChecker_Env.env_t -> - Prims.string FStar_Pervasives_Native.option -> - Prims.string -> FStar_TypeChecker_Env.env_t) - = - fun env -> - fun intf_opt -> - fun modf -> - let parse_data = - let uu___ = FStar_TypeChecker_Env.dep_graph env in - FStar_Parser_Dep.parsing_data_of uu___ modf in - let uu___ = - FStar_Universal.tc_one_file_for_ide env intf_opt modf parse_data in - match uu___ with | (uu___1, env1) -> env1 -let (run_repl_task : - FStar_Interactive_Ide_Types.optmod_t -> - FStar_TypeChecker_Env.env_t -> - FStar_Interactive_Ide_Types.repl_task -> - FStar_Universal.lang_decls_t -> - (FStar_Interactive_Ide_Types.optmod_t * FStar_TypeChecker_Env.env_t - * FStar_Universal.lang_decls_t)) - = - fun curmod -> - fun env -> - fun task -> - fun lds -> - match task with - | FStar_Interactive_Ide_Types.LDInterleaved (intf, impl) -> - let uu___ = - tc_one env - (FStar_Pervasives_Native.Some - (intf.FStar_Interactive_Ide_Types.tf_fname)) - impl.FStar_Interactive_Ide_Types.tf_fname in - (curmod, uu___, []) - | FStar_Interactive_Ide_Types.LDSingle intf_or_impl -> - let uu___ = - tc_one env FStar_Pervasives_Native.None - intf_or_impl.FStar_Interactive_Ide_Types.tf_fname in - (curmod, uu___, []) - | FStar_Interactive_Ide_Types.LDInterfaceOfCurrentFile intf -> - let uu___ = - FStar_Universal.load_interface_decls env - intf.FStar_Interactive_Ide_Types.tf_fname in - (curmod, uu___, []) - | FStar_Interactive_Ide_Types.PushFragment (frag, uu___, uu___1) -> - let frag1 = - match frag with - | FStar_Pervasives.Inl frag2 -> - FStar_Pervasives.Inl (frag2, lds) - | FStar_Pervasives.Inr decl -> FStar_Pervasives.Inr decl in - let uu___2 = FStar_Universal.tc_one_fragment curmod env frag1 in - (match uu___2 with | (o, e, langs) -> (o, e, langs)) - | FStar_Interactive_Ide_Types.Noop -> (curmod, env, []) -let (query_of_ids : - FStar_Ident.ident Prims.list -> FStar_Interactive_CompletionTable.query) = - fun ids -> FStar_Compiler_List.map FStar_Ident.string_of_id ids -let (query_of_lid : - FStar_Ident.lident -> FStar_Interactive_CompletionTable.query) = - fun lid -> - let uu___ = - let uu___1 = FStar_Ident.ns_of_lid lid in - let uu___2 = let uu___3 = FStar_Ident.ident_of_lid lid in [uu___3] in - FStar_Compiler_List.op_At uu___1 uu___2 in - query_of_ids uu___ -let (update_names_from_event : - Prims.string -> - FStar_Interactive_CompletionTable.table -> - name_tracking_event -> FStar_Interactive_CompletionTable.table) - = - fun cur_mod_str -> - fun table -> - fun evt -> - let is_cur_mod lid = - let uu___ = FStar_Ident.string_of_lid lid in uu___ = cur_mod_str in - match evt with - | NTAlias (host, id, included) -> - let uu___ = is_cur_mod host in - if uu___ - then - let uu___1 = FStar_Ident.string_of_id id in - let uu___2 = query_of_lid included in - FStar_Interactive_CompletionTable.register_alias table uu___1 - [] uu___2 - else table - | NTOpen (host, (included, kind, uu___)) -> - let uu___1 = is_cur_mod host in - if uu___1 - then - let uu___2 = query_of_lid included in - FStar_Interactive_CompletionTable.register_open table - (kind = FStar_Syntax_Syntax.Open_module) [] uu___2 - else table - | NTInclude (host, included) -> - let uu___ = - let uu___1 = is_cur_mod host in - if uu___1 then [] else query_of_lid host in - let uu___1 = query_of_lid included in - FStar_Interactive_CompletionTable.register_include table uu___ - uu___1 - | NTBinding binding -> - let lids = - match binding with - | FStar_Pervasives.Inl (FStar_Syntax_Syntax.Binding_lid - (lid, uu___)) -> [lid] - | FStar_Pervasives.Inr (lids1, uu___) -> lids1 - | uu___ -> [] in - FStar_Compiler_List.fold_left - (fun tbl -> - fun lid -> - let ns_query = - let uu___ = - let uu___1 = FStar_Ident.nsstr lid in - uu___1 = cur_mod_str in - if uu___ - then [] - else - (let uu___2 = FStar_Ident.ns_of_lid lid in - query_of_ids uu___2) in - let uu___ = - let uu___1 = FStar_Ident.ident_of_lid lid in - FStar_Ident.string_of_id uu___1 in - FStar_Interactive_CompletionTable.insert tbl ns_query - uu___ lid) table lids -let (commit_name_tracking' : - FStar_Syntax_Syntax.modul FStar_Pervasives_Native.option -> - FStar_Interactive_CompletionTable.table -> - name_tracking_event Prims.list -> - FStar_Interactive_CompletionTable.table) - = - fun cur_mod -> - fun names -> - fun name_events -> - let cur_mod_str = - match cur_mod with - | FStar_Pervasives_Native.None -> "" - | FStar_Pervasives_Native.Some md -> - let uu___ = FStar_Syntax_Syntax.mod_name md in - FStar_Ident.string_of_lid uu___ in - let updater = update_names_from_event cur_mod_str in - FStar_Compiler_List.fold_left updater names name_events -let (commit_name_tracking : - FStar_Interactive_Ide_Types.repl_state -> - name_tracking_event Prims.list -> FStar_Interactive_Ide_Types.repl_state) - = - fun st -> - fun name_events -> - let names = - commit_name_tracking' st.FStar_Interactive_Ide_Types.repl_curmod - st.FStar_Interactive_Ide_Types.repl_names name_events in - { - FStar_Interactive_Ide_Types.repl_line = - (st.FStar_Interactive_Ide_Types.repl_line); - FStar_Interactive_Ide_Types.repl_column = - (st.FStar_Interactive_Ide_Types.repl_column); - FStar_Interactive_Ide_Types.repl_fname = - (st.FStar_Interactive_Ide_Types.repl_fname); - FStar_Interactive_Ide_Types.repl_deps_stack = - (st.FStar_Interactive_Ide_Types.repl_deps_stack); - FStar_Interactive_Ide_Types.repl_curmod = - (st.FStar_Interactive_Ide_Types.repl_curmod); - FStar_Interactive_Ide_Types.repl_env = - (st.FStar_Interactive_Ide_Types.repl_env); - FStar_Interactive_Ide_Types.repl_stdin = - (st.FStar_Interactive_Ide_Types.repl_stdin); - FStar_Interactive_Ide_Types.repl_names = names; - FStar_Interactive_Ide_Types.repl_buffered_input_queries = - (st.FStar_Interactive_Ide_Types.repl_buffered_input_queries); - FStar_Interactive_Ide_Types.repl_lang = - (st.FStar_Interactive_Ide_Types.repl_lang) - } -let (fresh_name_tracking_hooks : - unit -> - (name_tracking_event Prims.list FStar_Compiler_Effect.ref * - FStar_Syntax_DsEnv.dsenv_hooks * FStar_TypeChecker_Env.tcenv_hooks)) - = - fun uu___ -> - let events = FStar_Compiler_Util.mk_ref [] in - let push_event evt = - let uu___1 = - let uu___2 = FStar_Compiler_Effect.op_Bang events in evt :: uu___2 in - FStar_Compiler_Effect.op_Colon_Equals events uu___1 in - let uu___1 = - FStar_Syntax_DsEnv.mk_dsenv_hooks - (fun dsenv -> - fun op -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_DsEnv.current_module dsenv in - (uu___4, op) in - NTOpen uu___3 in - push_event uu___2) - (fun dsenv -> - fun ns -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_DsEnv.current_module dsenv in - (uu___4, ns) in - NTInclude uu___3 in - push_event uu___2) - (fun dsenv -> - fun x -> - fun l -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_DsEnv.current_module dsenv in - (uu___4, x, l) in - NTAlias uu___3 in - push_event uu___2) in - (events, uu___1, - { - FStar_TypeChecker_Env.tc_push_in_gamma_hook = - (fun uu___2 -> fun s -> push_event (NTBinding s)) - }) -let (track_name_changes : - FStar_TypeChecker_Env.env_t -> - (FStar_TypeChecker_Env.env_t * - (FStar_TypeChecker_Env.env_t -> - (FStar_TypeChecker_Env.env_t * name_tracking_event Prims.list)))) - = - fun env -> - let set_hooks dshooks tchooks env1 = - let uu___ = - FStar_Universal.with_dsenv_of_tcenv env1 - (fun dsenv -> - let uu___1 = FStar_Syntax_DsEnv.set_ds_hooks dsenv dshooks in - ((), uu___1)) in - match uu___ with - | ((), tcenv') -> FStar_TypeChecker_Env.set_tc_hooks tcenv' tchooks in - let uu___ = - let uu___1 = - FStar_Syntax_DsEnv.ds_hooks env.FStar_TypeChecker_Env.dsenv in - let uu___2 = FStar_TypeChecker_Env.tc_hooks env in (uu___1, uu___2) in - match uu___ with - | (old_dshooks, old_tchooks) -> - let uu___1 = fresh_name_tracking_hooks () in - (match uu___1 with - | (events, new_dshooks, new_tchooks) -> - let uu___2 = set_hooks new_dshooks new_tchooks env in - (uu___2, - ((fun env1 -> - let uu___3 = set_hooks old_dshooks old_tchooks env1 in - let uu___4 = - let uu___5 = FStar_Compiler_Effect.op_Bang events in - FStar_Compiler_List.rev uu___5 in - (uu___3, uu___4))))) -let (repl_tx : - FStar_Interactive_Ide_Types.repl_state -> - FStar_Interactive_Ide_Types.push_kind -> - FStar_Interactive_Ide_Types.repl_task -> - (FStar_Interactive_JsonHelper.assoct FStar_Pervasives_Native.option * - FStar_Interactive_Ide_Types.repl_state)) - = - fun st -> - fun push_kind -> - fun task -> - try - (fun uu___ -> - match () with - | () -> - let st1 = - push_repl "repl_tx" - (FStar_Pervasives_Native.Some push_kind) task st in - let uu___1 = - track_name_changes - st1.FStar_Interactive_Ide_Types.repl_env in - (match uu___1 with - | (env, finish_name_tracking) -> - let uu___2 = - run_repl_task - st1.FStar_Interactive_Ide_Types.repl_curmod env - task st1.FStar_Interactive_Ide_Types.repl_lang in - (match uu___2 with - | (curmod, env1, lds) -> - let st2 = - { - FStar_Interactive_Ide_Types.repl_line = - (st1.FStar_Interactive_Ide_Types.repl_line); - FStar_Interactive_Ide_Types.repl_column = - (st1.FStar_Interactive_Ide_Types.repl_column); - FStar_Interactive_Ide_Types.repl_fname = - (st1.FStar_Interactive_Ide_Types.repl_fname); - FStar_Interactive_Ide_Types.repl_deps_stack = - (st1.FStar_Interactive_Ide_Types.repl_deps_stack); - FStar_Interactive_Ide_Types.repl_curmod = - curmod; - FStar_Interactive_Ide_Types.repl_env = env1; - FStar_Interactive_Ide_Types.repl_stdin = - (st1.FStar_Interactive_Ide_Types.repl_stdin); - FStar_Interactive_Ide_Types.repl_names = - (st1.FStar_Interactive_Ide_Types.repl_names); - FStar_Interactive_Ide_Types.repl_buffered_input_queries - = - (st1.FStar_Interactive_Ide_Types.repl_buffered_input_queries); - FStar_Interactive_Ide_Types.repl_lang = - (FStar_Compiler_List.op_At - (FStar_Compiler_List.rev lds) - st1.FStar_Interactive_Ide_Types.repl_lang) - } in - let uu___3 = finish_name_tracking env1 in - (match uu___3 with - | (env2, name_events) -> - let uu___4 = - commit_name_tracking st2 name_events in - (FStar_Pervasives_Native.None, uu___4))))) () - with - | FStar_Compiler_Effect.Failure msg -> - let uu___1 = - let uu___2 = - FStar_Interactive_JsonHelper.js_diag - st.FStar_Interactive_Ide_Types.repl_fname msg - FStar_Pervasives_Native.None in - FStar_Pervasives_Native.Some uu___2 in - (uu___1, st) - | FStar_Compiler_Util.SigInt -> - (FStar_Compiler_Util.print_error "[E] Interrupt"; - (FStar_Pervasives_Native.None, st)) - | FStar_Errors.Error (e, msg, r, _ctx) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Errors_Msg.rendermsg msg in - FStar_Interactive_JsonHelper.js_diag - st.FStar_Interactive_Ide_Types.repl_fname uu___3 - (FStar_Pervasives_Native.Some r) in - FStar_Pervasives_Native.Some uu___2 in - (uu___1, st) - | FStar_Errors.Stop -> - (FStar_Compiler_Util.print_error "[E] Stop"; - (FStar_Pervasives_Native.None, st)) -let (tf_of_fname : Prims.string -> FStar_Interactive_Ide_Types.timed_fname) = - fun fname -> - let uu___ = FStar_Parser_ParseIt.get_file_last_modification_time fname in - { - FStar_Interactive_Ide_Types.tf_fname = fname; - FStar_Interactive_Ide_Types.tf_modtime = uu___ - } -let (update_task_timestamps : - FStar_Interactive_Ide_Types.repl_task -> - FStar_Interactive_Ide_Types.repl_task) - = - fun uu___ -> - match uu___ with - | FStar_Interactive_Ide_Types.LDInterleaved (intf, impl) -> - let uu___1 = - let uu___2 = tf_of_fname intf.FStar_Interactive_Ide_Types.tf_fname in - let uu___3 = tf_of_fname impl.FStar_Interactive_Ide_Types.tf_fname in - (uu___2, uu___3) in - FStar_Interactive_Ide_Types.LDInterleaved uu___1 - | FStar_Interactive_Ide_Types.LDSingle intf_or_impl -> - let uu___1 = - tf_of_fname intf_or_impl.FStar_Interactive_Ide_Types.tf_fname in - FStar_Interactive_Ide_Types.LDSingle uu___1 - | FStar_Interactive_Ide_Types.LDInterfaceOfCurrentFile intf -> - let uu___1 = tf_of_fname intf.FStar_Interactive_Ide_Types.tf_fname in - FStar_Interactive_Ide_Types.LDInterfaceOfCurrentFile uu___1 - | other -> other -let (repl_ldtx : - FStar_Interactive_Ide_Types.repl_state -> - FStar_Interactive_Ide_Types.repl_task Prims.list -> either_replst) - = - fun st -> - fun tasks -> - let rec revert_many st1 uu___ = - match uu___ with - | [] -> st1 - | (_id, (task, _st'))::entries -> - let st' = pop_repl "repl_ldtx" st1 in - let dep_graph = - FStar_TypeChecker_Env.dep_graph - st1.FStar_Interactive_Ide_Types.repl_env in - let st'1 = - let uu___1 = - FStar_TypeChecker_Env.set_dep_graph - st'.FStar_Interactive_Ide_Types.repl_env dep_graph in - { - FStar_Interactive_Ide_Types.repl_line = - (st'.FStar_Interactive_Ide_Types.repl_line); - FStar_Interactive_Ide_Types.repl_column = - (st'.FStar_Interactive_Ide_Types.repl_column); - FStar_Interactive_Ide_Types.repl_fname = - (st'.FStar_Interactive_Ide_Types.repl_fname); - FStar_Interactive_Ide_Types.repl_deps_stack = - (st'.FStar_Interactive_Ide_Types.repl_deps_stack); - FStar_Interactive_Ide_Types.repl_curmod = - (st'.FStar_Interactive_Ide_Types.repl_curmod); - FStar_Interactive_Ide_Types.repl_env = uu___1; - FStar_Interactive_Ide_Types.repl_stdin = - (st'.FStar_Interactive_Ide_Types.repl_stdin); - FStar_Interactive_Ide_Types.repl_names = - (st'.FStar_Interactive_Ide_Types.repl_names); - FStar_Interactive_Ide_Types.repl_buffered_input_queries = - (st'.FStar_Interactive_Ide_Types.repl_buffered_input_queries); - FStar_Interactive_Ide_Types.repl_lang = - (st'.FStar_Interactive_Ide_Types.repl_lang) - } in - revert_many st'1 entries in - let rec aux st1 tasks1 previous = - match (tasks1, previous) with - | ([], []) -> FStar_Pervasives.Inl st1 - | (task::tasks2, []) -> - let timestamped_task = update_task_timestamps task in - let uu___ = - repl_tx st1 FStar_Interactive_Ide_Types.LaxCheck - timestamped_task in - (match uu___ with - | (diag, st2) -> - if Prims.op_Negation (FStar_Compiler_Util.is_some diag) - then - let uu___1 = - let uu___2 = FStar_Compiler_Effect.op_Bang repl_stack in - { - FStar_Interactive_Ide_Types.repl_line = - (st2.FStar_Interactive_Ide_Types.repl_line); - FStar_Interactive_Ide_Types.repl_column = - (st2.FStar_Interactive_Ide_Types.repl_column); - FStar_Interactive_Ide_Types.repl_fname = - (st2.FStar_Interactive_Ide_Types.repl_fname); - FStar_Interactive_Ide_Types.repl_deps_stack = uu___2; - FStar_Interactive_Ide_Types.repl_curmod = - (st2.FStar_Interactive_Ide_Types.repl_curmod); - FStar_Interactive_Ide_Types.repl_env = - (st2.FStar_Interactive_Ide_Types.repl_env); - FStar_Interactive_Ide_Types.repl_stdin = - (st2.FStar_Interactive_Ide_Types.repl_stdin); - FStar_Interactive_Ide_Types.repl_names = - (st2.FStar_Interactive_Ide_Types.repl_names); - FStar_Interactive_Ide_Types.repl_buffered_input_queries - = - (st2.FStar_Interactive_Ide_Types.repl_buffered_input_queries); - FStar_Interactive_Ide_Types.repl_lang = - (st2.FStar_Interactive_Ide_Types.repl_lang) - } in - aux uu___1 tasks2 [] - else FStar_Pervasives.Inr st2) - | (task::tasks2, prev::previous1) when - let uu___ = update_task_timestamps task in - (FStar_Pervasives_Native.fst (FStar_Pervasives_Native.snd prev)) - = uu___ - -> aux st1 tasks2 previous1 - | (tasks2, previous1) -> - let uu___ = revert_many st1 previous1 in aux uu___ tasks2 [] in - aux st tasks - (FStar_Compiler_List.rev - st.FStar_Interactive_Ide_Types.repl_deps_stack) -let (ld_deps : - FStar_Interactive_Ide_Types.repl_state -> - ((FStar_Interactive_Ide_Types.repl_state * Prims.string Prims.list), - FStar_Interactive_Ide_Types.repl_state) FStar_Pervasives.either) - = - fun st -> - try - (fun uu___ -> - match () with - | () -> - let uu___1 = - deps_and_repl_ld_tasks_of_our_file - st.FStar_Interactive_Ide_Types.repl_fname in - (match uu___1 with - | (deps, tasks, dep_graph) -> - let st1 = - let uu___2 = - FStar_TypeChecker_Env.set_dep_graph - st.FStar_Interactive_Ide_Types.repl_env dep_graph in - { - FStar_Interactive_Ide_Types.repl_line = - (st.FStar_Interactive_Ide_Types.repl_line); - FStar_Interactive_Ide_Types.repl_column = - (st.FStar_Interactive_Ide_Types.repl_column); - FStar_Interactive_Ide_Types.repl_fname = - (st.FStar_Interactive_Ide_Types.repl_fname); - FStar_Interactive_Ide_Types.repl_deps_stack = - (st.FStar_Interactive_Ide_Types.repl_deps_stack); - FStar_Interactive_Ide_Types.repl_curmod = - (st.FStar_Interactive_Ide_Types.repl_curmod); - FStar_Interactive_Ide_Types.repl_env = uu___2; - FStar_Interactive_Ide_Types.repl_stdin = - (st.FStar_Interactive_Ide_Types.repl_stdin); - FStar_Interactive_Ide_Types.repl_names = - (st.FStar_Interactive_Ide_Types.repl_names); - FStar_Interactive_Ide_Types.repl_buffered_input_queries - = - (st.FStar_Interactive_Ide_Types.repl_buffered_input_queries); - FStar_Interactive_Ide_Types.repl_lang = - (st.FStar_Interactive_Ide_Types.repl_lang) - } in - let uu___2 = repl_ldtx st1 tasks in - (match uu___2 with - | FStar_Pervasives.Inr st2 -> FStar_Pervasives.Inr st2 - | FStar_Pervasives.Inl st2 -> - FStar_Pervasives.Inl (st2, deps)))) () - with - | FStar_Errors.Error (e, msg, _rng, ctx) -> - ((let uu___2 = FStar_Errors_Msg.rendermsg msg in - FStar_Compiler_Util.print1_error "[E] Failed to load deps. %s" - uu___2); - FStar_Pervasives.Inr st) - | exn -> - ((let uu___2 = FStar_Compiler_Util.message_of_exn exn in - FStar_Compiler_Util.print1_error - "[E] Failed to load deps. Message: %s" uu___2); - FStar_Pervasives.Inr st) -let (add_module_completions : - Prims.string -> - Prims.string Prims.list -> - FStar_Interactive_CompletionTable.table -> - FStar_Interactive_CompletionTable.table) - = - fun this_fname -> - fun deps -> - fun table -> - let capitalize str = - if str = "" - then str - else - (let first = - FStar_Compiler_String.substring str Prims.int_zero - Prims.int_one in - let uu___1 = - FStar_Compiler_String.substring str Prims.int_one - ((FStar_Compiler_String.length str) - Prims.int_one) in - Prims.strcat (FStar_Compiler_String.uppercase first) uu___1) in - let mods = FStar_Parser_Dep.build_inclusion_candidates_list () in - let loaded_mods_set = - let uu___ = FStar_Compiler_Util.psmap_empty () in - let uu___1 = - let uu___2 = FStar_Basefiles.prims () in uu___2 :: deps in - FStar_Compiler_List.fold_left - (fun acc -> - fun dep -> - let uu___2 = FStar_Parser_Dep.lowercase_module_name dep in - FStar_Compiler_Util.psmap_add acc uu___2 true) uu___ uu___1 in - let loaded modname = - FStar_Compiler_Util.psmap_find_default loaded_mods_set modname - false in - let this_mod_key = FStar_Parser_Dep.lowercase_module_name this_fname in - FStar_Compiler_List.fold_left - (fun table1 -> - fun uu___ -> - match uu___ with - | (modname, mod_path) -> - let mod_key = FStar_Compiler_String.lowercase modname in - if this_mod_key = mod_key - then table1 - else - (let ns_query = - let uu___2 = capitalize modname in - FStar_Compiler_Util.split uu___2 "." in - let uu___2 = loaded mod_key in - FStar_Interactive_CompletionTable.register_module_path - table1 uu___2 mod_path ns_query)) table - (FStar_Compiler_List.rev mods) -let (full_lax : - Prims.string -> - FStar_Interactive_Ide_Types.repl_state -> - (FStar_Interactive_JsonHelper.assoct FStar_Pervasives_Native.option * - FStar_Interactive_Ide_Types.repl_state)) - = - fun text -> - fun st -> - FStar_TypeChecker_Env.toggle_id_info - st.FStar_Interactive_Ide_Types.repl_env true; - (let frag = - { - FStar_Parser_ParseIt.frag_fname = - (st.FStar_Interactive_Ide_Types.repl_fname); - FStar_Parser_ParseIt.frag_text = text; - FStar_Parser_ParseIt.frag_line = Prims.int_one; - FStar_Parser_ParseIt.frag_col = Prims.int_zero - } in - let uu___1 = ld_deps st in - match uu___1 with - | FStar_Pervasives.Inl (st1, deps) -> - let names = - add_module_completions - st1.FStar_Interactive_Ide_Types.repl_fname deps - st1.FStar_Interactive_Ide_Types.repl_names in - repl_tx - { - FStar_Interactive_Ide_Types.repl_line = - (st1.FStar_Interactive_Ide_Types.repl_line); - FStar_Interactive_Ide_Types.repl_column = - (st1.FStar_Interactive_Ide_Types.repl_column); - FStar_Interactive_Ide_Types.repl_fname = - (st1.FStar_Interactive_Ide_Types.repl_fname); - FStar_Interactive_Ide_Types.repl_deps_stack = - (st1.FStar_Interactive_Ide_Types.repl_deps_stack); - FStar_Interactive_Ide_Types.repl_curmod = - (st1.FStar_Interactive_Ide_Types.repl_curmod); - FStar_Interactive_Ide_Types.repl_env = - (st1.FStar_Interactive_Ide_Types.repl_env); - FStar_Interactive_Ide_Types.repl_stdin = - (st1.FStar_Interactive_Ide_Types.repl_stdin); - FStar_Interactive_Ide_Types.repl_names = names; - FStar_Interactive_Ide_Types.repl_buffered_input_queries = - (st1.FStar_Interactive_Ide_Types.repl_buffered_input_queries); - FStar_Interactive_Ide_Types.repl_lang = - (st1.FStar_Interactive_Ide_Types.repl_lang) - } FStar_Interactive_Ide_Types.LaxCheck - (FStar_Interactive_Ide_Types.PushFragment - ((FStar_Pervasives.Inl frag), - FStar_Interactive_Ide_Types.LaxCheck, [])) - | FStar_Pervasives.Inr st1 -> (FStar_Pervasives_Native.None, st1)) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Interactive_QueryHelper.ml b/ocaml/fstar-lib/generated/FStar_Interactive_QueryHelper.ml deleted file mode 100644 index c36b397fb74..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Interactive_QueryHelper.ml +++ /dev/null @@ -1,302 +0,0 @@ -open Prims -type position = (Prims.string * Prims.int * Prims.int) -type sl_reponse = - { - slr_name: Prims.string ; - slr_def_range: - FStar_Compiler_Range_Type.range FStar_Pervasives_Native.option ; - slr_typ: Prims.string FStar_Pervasives_Native.option ; - slr_doc: Prims.string FStar_Pervasives_Native.option ; - slr_def: Prims.string FStar_Pervasives_Native.option } -let (__proj__Mksl_reponse__item__slr_name : sl_reponse -> Prims.string) = - fun projectee -> - match projectee with - | { slr_name; slr_def_range; slr_typ; slr_doc; slr_def;_} -> slr_name -let (__proj__Mksl_reponse__item__slr_def_range : - sl_reponse -> - FStar_Compiler_Range_Type.range FStar_Pervasives_Native.option) - = - fun projectee -> - match projectee with - | { slr_name; slr_def_range; slr_typ; slr_doc; slr_def;_} -> - slr_def_range -let (__proj__Mksl_reponse__item__slr_typ : - sl_reponse -> Prims.string FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { slr_name; slr_def_range; slr_typ; slr_doc; slr_def;_} -> slr_typ -let (__proj__Mksl_reponse__item__slr_doc : - sl_reponse -> Prims.string FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { slr_name; slr_def_range; slr_typ; slr_doc; slr_def;_} -> slr_doc -let (__proj__Mksl_reponse__item__slr_def : - sl_reponse -> Prims.string FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { slr_name; slr_def_range; slr_typ; slr_doc; slr_def;_} -> slr_def -let with_printed_effect_args : 'uuuuu . (unit -> 'uuuuu) -> 'uuuuu = - fun k -> - FStar_Options.with_saved_options - (fun uu___ -> - FStar_Options.set_option "print_effect_args" - (FStar_Options.Bool true); - k ()) -let (term_to_string : - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.term -> Prims.string) = - fun tcenv -> - fun t -> - with_printed_effect_args - (fun uu___ -> FStar_TypeChecker_Normalize.term_to_string tcenv t) -let (sigelt_to_string : - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.sigelt -> Prims.string) = - fun tcenv -> - fun se -> - with_printed_effect_args - (fun uu___ -> - let uu___1 = - FStar_Syntax_DsEnv.set_current_module - tcenv.FStar_TypeChecker_Env.dsenv - tcenv.FStar_TypeChecker_Env.curmodule in - FStar_Syntax_Print.sigelt_to_string' uu___1 se) -let (symlookup : - FStar_TypeChecker_Env.env -> - Prims.string -> - position FStar_Pervasives_Native.option -> - Prims.string Prims.list -> sl_reponse FStar_Pervasives_Native.option) - = - fun tcenv -> - fun symbol -> - fun pos_opt -> - fun requested_info -> - let info_of_lid_str lid_str = - let lid = - let uu___ = - FStar_Compiler_List.map FStar_Ident.id_of_text - (FStar_Compiler_Util.split lid_str ".") in - FStar_Ident.lid_of_ids uu___ in - let lid1 = - let uu___ = - FStar_Syntax_DsEnv.resolve_to_fully_qualified_name - tcenv.FStar_TypeChecker_Env.dsenv lid in - FStar_Compiler_Util.dflt lid uu___ in - let uu___ = FStar_TypeChecker_Env.try_lookup_lid tcenv lid1 in - FStar_Compiler_Util.map_option - (fun uu___1 -> - match uu___1 with - | ((uu___2, typ), r) -> - ((FStar_Pervasives.Inr lid1), typ, r)) uu___ in - let docs_of_lid lid = FStar_Pervasives_Native.None in - let def_of_lid lid = - let uu___ = FStar_TypeChecker_Env.lookup_qname tcenv lid in - FStar_Compiler_Util.bind_opt uu___ - (fun uu___1 -> - match uu___1 with - | (FStar_Pervasives.Inr (se, uu___2), uu___3) -> - let uu___4 = sigelt_to_string tcenv se in - FStar_Pervasives_Native.Some uu___4 - | uu___2 -> FStar_Pervasives_Native.None) in - let info_at_pos_opt = - FStar_Compiler_Util.bind_opt pos_opt - (fun uu___ -> - match uu___ with - | (file, row, col) -> - FStar_TypeChecker_Err.info_at_pos tcenv file row col) in - let info_opt = - match info_at_pos_opt with - | FStar_Pervasives_Native.Some uu___ -> info_at_pos_opt - | FStar_Pervasives_Native.None -> - if symbol = "" - then FStar_Pervasives_Native.None - else info_of_lid_str symbol in - match info_opt with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (name_or_lid, typ, rng) -> - let name = - match name_or_lid with - | FStar_Pervasives.Inl name1 -> name1 - | FStar_Pervasives.Inr lid -> FStar_Ident.string_of_lid lid in - let str_of_opt uu___ = - match uu___ with - | FStar_Pervasives_Native.None -> "" - | FStar_Pervasives_Native.Some s -> s in - let typ_str = - if FStar_Compiler_List.mem "type" requested_info - then - let uu___ = term_to_string tcenv typ in - FStar_Pervasives_Native.Some uu___ - else FStar_Pervasives_Native.None in - let doc_str = - match name_or_lid with - | FStar_Pervasives.Inr lid when - FStar_Compiler_List.mem "documentation" requested_info -> - docs_of_lid lid - | uu___ -> FStar_Pervasives_Native.None in - let def_str = - match name_or_lid with - | FStar_Pervasives.Inr lid when - FStar_Compiler_List.mem "definition" requested_info -> - def_of_lid lid - | uu___ -> FStar_Pervasives_Native.None in - let def_range = - if FStar_Compiler_List.mem "defined-at" requested_info - then FStar_Pervasives_Native.Some rng - else FStar_Pervasives_Native.None in - FStar_Pervasives_Native.Some - { - slr_name = name; - slr_def_range = def_range; - slr_typ = typ_str; - slr_doc = doc_str; - slr_def = def_str - } -let mod_filter : - 'uuuuu . - ('uuuuu * FStar_Interactive_CompletionTable.mod_symbol) -> - ('uuuuu * FStar_Interactive_CompletionTable.mod_symbol) - FStar_Pervasives_Native.option - = - fun uu___ -> - match uu___ with - | (uu___1, FStar_Interactive_CompletionTable.Namespace uu___2) -> - FStar_Pervasives_Native.None - | (uu___1, FStar_Interactive_CompletionTable.Module - { FStar_Interactive_CompletionTable.mod_name = uu___2; - FStar_Interactive_CompletionTable.mod_path = uu___3; - FStar_Interactive_CompletionTable.mod_loaded = true;_}) - -> FStar_Pervasives_Native.None - | (pth, FStar_Interactive_CompletionTable.Module md) -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Interactive_CompletionTable.mod_name md in - Prims.strcat uu___5 "." in - { - FStar_Interactive_CompletionTable.mod_name = uu___4; - FStar_Interactive_CompletionTable.mod_path = - (md.FStar_Interactive_CompletionTable.mod_path); - FStar_Interactive_CompletionTable.mod_loaded = - (md.FStar_Interactive_CompletionTable.mod_loaded) - } in - FStar_Interactive_CompletionTable.Module uu___3 in - (pth, uu___2) in - FStar_Pervasives_Native.Some uu___1 -let (ck_completion : - FStar_Interactive_Ide_Types.repl_state -> - Prims.string -> - FStar_Interactive_CompletionTable.completion_result Prims.list) - = - fun st -> - fun search_term -> - let needle = FStar_Compiler_Util.split search_term "." in - let mods_and_nss = - FStar_Interactive_CompletionTable.autocomplete_mod_or_ns - st.FStar_Interactive_Ide_Types.repl_names needle mod_filter in - let lids = - FStar_Interactive_CompletionTable.autocomplete_lid - st.FStar_Interactive_Ide_Types.repl_names needle in - FStar_Compiler_List.op_At lids mods_and_nss -let (deflookup : - FStar_TypeChecker_Env.env -> - FStar_Interactive_JsonHelper.txdoc_pos -> - FStar_Interactive_JsonHelper.assoct FStar_Pervasives_Native.option) - = - fun env -> - fun pos -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Interactive_JsonHelper.pos_munge pos in - FStar_Pervasives_Native.Some uu___2 in - symlookup env "" uu___1 ["defined-at"] in - match uu___ with - | FStar_Pervasives_Native.Some - { slr_name = uu___1; - slr_def_range = FStar_Pervasives_Native.Some r; slr_typ = uu___2; - slr_doc = uu___3; slr_def = uu___4;_} - -> - let uu___5 = FStar_Interactive_JsonHelper.js_loclink r in - FStar_Interactive_JsonHelper.resultResponse uu___5 - | uu___1 -> FStar_Interactive_JsonHelper.nullResponse -let (hoverlookup : - FStar_TypeChecker_Env.env -> - FStar_Interactive_JsonHelper.txdoc_pos -> - FStar_Interactive_JsonHelper.assoct FStar_Pervasives_Native.option) - = - fun env -> - fun pos -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Interactive_JsonHelper.pos_munge pos in - FStar_Pervasives_Native.Some uu___2 in - symlookup env "" uu___1 ["type"; "definition"] in - match uu___ with - | FStar_Pervasives_Native.Some - { slr_name = n; slr_def_range = uu___1; - slr_typ = FStar_Pervasives_Native.Some t; slr_doc = uu___2; - slr_def = FStar_Pervasives_Native.Some d;_} - -> - let hovertxt = - FStar_Compiler_Util.format2 - "```fstar\n%s\n````\n---\n```fstar\n%s\n```" t d in - FStar_Interactive_JsonHelper.resultResponse - (FStar_Json.JsonAssoc - [("contents", - (FStar_Json.JsonAssoc - [("kind", (FStar_Json.JsonStr "markdown")); - ("value", (FStar_Json.JsonStr hovertxt))]))]) - | uu___1 -> FStar_Interactive_JsonHelper.nullResponse -let (complookup : - FStar_Interactive_Ide_Types.repl_state -> - FStar_Interactive_JsonHelper.txdoc_pos -> - FStar_Interactive_JsonHelper.assoct FStar_Pervasives_Native.option) - = - fun st -> - fun pos -> - let uu___ = FStar_Interactive_JsonHelper.pos_munge pos in - match uu___ with - | (file, row, current_col) -> - let uu___1 = FStar_Parser_ParseIt.read_vfs_entry file in - (match uu___1 with - | FStar_Pervasives_Native.Some (uu___2, text) -> - let rec find_col l = - match l with - | [] -> Prims.int_zero - | h::t -> - if - (h = 32) && - ((FStar_Compiler_List.length t) < current_col) - then (FStar_Compiler_List.length t) + Prims.int_one - else find_col t in - let str = - FStar_Compiler_List.nth - (FStar_Compiler_Util.splitlines text) - (row - Prims.int_one) in - let explode s = - let rec exp i l = - if i < Prims.int_zero - then l - else - (let uu___4 = - let uu___5 = FStar_Compiler_String.get s i in uu___5 - :: l in - exp (i - Prims.int_one) uu___4) in - exp ((FStar_Compiler_String.length s) - Prims.int_one) [] in - let begin_col = - let uu___3 = - let uu___4 = explode str in FStar_Compiler_List.rev uu___4 in - find_col uu___3 in - let term = - FStar_Compiler_Util.substring str begin_col - (current_col - begin_col) in - let items = ck_completion st term in - let l = - FStar_Compiler_List.map - (fun r -> - FStar_Json.JsonAssoc - [("label", - (FStar_Json.JsonStr - (r.FStar_Interactive_CompletionTable.completion_candidate)))]) - items in - FStar_Interactive_JsonHelper.resultResponse - (FStar_Json.JsonList l)) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Main.ml b/ocaml/fstar-lib/generated/FStar_Main.ml deleted file mode 100644 index 2ec06058c05..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Main.ml +++ /dev/null @@ -1,608 +0,0 @@ -open Prims -let (uu___0 : unit) = FStar_Version.dummy () -let (process_args : - unit -> (FStar_Getopt.parse_cmdline_res * Prims.string Prims.list)) = - fun uu___ -> FStar_Options.parse_cmd_line () -let (cleanup : unit -> unit) = fun uu___ -> FStar_Compiler_Util.kill_all () -let (finished_message : - (Prims.bool * FStar_Ident.lident) Prims.list -> Prims.int -> unit) = - fun fmods -> - fun errs -> - let print_to = - if errs > Prims.int_zero - then FStar_Compiler_Util.print_error - else FStar_Compiler_Util.print_string in - let uu___ = - let uu___1 = FStar_Options.silent () in Prims.op_Negation uu___1 in - if uu___ - then - (FStar_Compiler_List.iter - (fun uu___2 -> - match uu___2 with - | (iface, name) -> - let tag = - if iface then "i'face (or impl+i'face)" else "module" in - let uu___3 = - let uu___4 = FStar_Ident.string_of_lid name in - FStar_Options.should_print_message uu___4 in - if uu___3 - then - let uu___4 = - let uu___5 = FStar_Ident.string_of_lid name in - FStar_Compiler_Util.format2 "Verified %s: %s\n" tag - uu___5 in - print_to uu___4 - else ()) fmods; - if errs > Prims.int_zero - then - (if errs = Prims.int_one - then - FStar_Compiler_Util.print_error - "1 error was reported (see above)\n" - else - (let uu___3 = FStar_Compiler_Util.string_of_int errs in - FStar_Compiler_Util.print1_error - "%s errors were reported (see above)\n" uu___3)) - else - (let uu___3 = - FStar_Compiler_Util.colorize_bold - "All verification conditions discharged successfully" in - FStar_Compiler_Util.print1 "%s\n" uu___3)) - else () -let (report_errors : (Prims.bool * FStar_Ident.lident) Prims.list -> unit) = - fun fmods -> - (let uu___1 = FStar_Errors.report_all () in ()); - (let nerrs = FStar_Errors.get_err_count () in - if nerrs > Prims.int_zero - then - (finished_message fmods nerrs; - FStar_Compiler_Effect.exit Prims.int_one) - else ()) -let (load_native_tactics : unit -> unit) = - fun uu___ -> - let modules_to_load = - let uu___1 = FStar_Options.load () in - FStar_Compiler_List.map FStar_Ident.lid_of_str uu___1 in - let cmxs_to_load = - let uu___1 = FStar_Options.load_cmxs () in - FStar_Compiler_List.map FStar_Ident.lid_of_str uu___1 in - let ml_module_name m = FStar_Extraction_ML_Util.ml_module_name_of_lid m in - let ml_file m = - let uu___1 = ml_module_name m in Prims.strcat uu___1 ".ml" in - let cmxs_file m = - let cmxs = let uu___1 = ml_module_name m in Prims.strcat uu___1 ".cmxs" in - let uu___1 = FStar_Find.find_file cmxs in - match uu___1 with - | FStar_Pervasives_Native.Some f -> f - | FStar_Pervasives_Native.None -> - if FStar_Compiler_List.contains m cmxs_to_load - then - let uu___2 = - FStar_Compiler_Util.format1 "Could not find %s to load" cmxs in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_FailToCompileNativeTactic () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2) - else - (let uu___3 = - let uu___4 = ml_file m in FStar_Find.find_file uu___4 in - match uu___3 with - | FStar_Pervasives_Native.None -> - let uu___4 = - let uu___5 = ml_file m in - FStar_Compiler_Util.format1 - "Failed to compile native tactic; extracted module %s not found" - uu___5 in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_FailToCompileNativeTactic () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4) - | FStar_Pervasives_Native.Some ml -> - let dir = FStar_Compiler_Util.dirname ml in - ((let uu___5 = let uu___6 = ml_module_name m in [uu___6] in - FStar_Compiler_Plugins.compile_modules dir uu___5); - (let uu___5 = FStar_Find.find_file cmxs in - match uu___5 with - | FStar_Pervasives_Native.None -> - let uu___6 = - FStar_Compiler_Util.format1 - "Failed to compile native tactic; compiled object %s not found" - cmxs in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_FailToCompileNativeTactic - () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___6) - | FStar_Pervasives_Native.Some f -> f))) in - let cmxs_files = - FStar_Compiler_List.map cmxs_file - (FStar_Compiler_List.op_At modules_to_load cmxs_to_load) in - (let uu___2 = FStar_Compiler_Debug.any () in - if uu___2 - then - FStar_Compiler_Util.print1 "Will try to load cmxs files: [%s]\n" - (FStar_Compiler_String.concat ", " cmxs_files) - else ()); - FStar_Compiler_Plugins.load_plugins cmxs_files; - (let uu___4 = FStar_Options.use_native_tactics () in - FStar_Compiler_Util.iter_opt uu___4 - FStar_Compiler_Plugins.load_plugins_dir) -let (fstar_files : - Prims.string Prims.list FStar_Pervasives_Native.option - FStar_Compiler_Effect.ref) - = FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None -let go : 'uuuuu . 'uuuuu -> unit = - fun uu___ -> - let uu___1 = process_args () in - match uu___1 with - | (res, filenames) -> - ((let uu___3 = FStar_Options.trace_error () in - if uu___3 - then - let h = FStar_Compiler_Util.get_sigint_handler () in - let h' s = - FStar_Compiler_Debug.enable (); - FStar_Options.set_option "error_contexts" - (FStar_Options.Bool true); - (let uu___7 = - let uu___8 = FStar_Errors_Msg.text "GOT SIGINT! Exiting" in - [uu___8] in - FStar_Errors.diag FStar_Class_HasRange.hasRange_range - FStar_Compiler_Range_Type.dummyRange () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___7)); - FStar_Compiler_Effect.exit Prims.int_one in - let uu___4 = FStar_Compiler_Util.sigint_handler_f h' in - FStar_Compiler_Util.set_sigint_handler uu___4 - else ()); - (match res with - | FStar_Getopt.Empty -> - (FStar_Options.display_usage (); - FStar_Compiler_Effect.exit Prims.int_one) - | FStar_Getopt.Help -> - (FStar_Options.display_usage (); - FStar_Compiler_Effect.exit Prims.int_zero) - | FStar_Getopt.Error msg -> - (FStar_Compiler_Util.print_error msg; - FStar_Compiler_Effect.exit Prims.int_one) - | uu___3 when FStar_Options.print_cache_version () -> - ((let uu___5 = - FStar_Compiler_Util.string_of_int - FStar_CheckedFiles.cache_version_number in - FStar_Compiler_Util.print1 "F* cache version number: %s\n" - uu___5); - FStar_Compiler_Effect.exit Prims.int_zero) - | FStar_Getopt.Success -> - (FStar_Compiler_Effect.op_Colon_Equals fstar_files - (FStar_Pervasives_Native.Some filenames); - (let uu___5 = FStar_Compiler_Debug.any () in - if uu___5 - then - (FStar_Compiler_Util.print1 "- F* executable: %s\n" - FStar_Compiler_Util.exec_name; - FStar_Compiler_Util.print1 "- F* exec dir: %s\n" - FStar_Options.fstar_bin_directory; - (let uu___9 = - let uu___10 = FStar_Options.lib_root () in - FStar_Compiler_Util.dflt "" uu___10 in - FStar_Compiler_Util.print1 "- Library root: %s\n" uu___9); - (let uu___10 = - let uu___11 = FStar_Options.include_path () in - FStar_Class_Show.show - (FStar_Class_Show.show_list - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_string)) - uu___11 in - FStar_Compiler_Util.print1 "- Full include path: %s\n" - uu___10); - FStar_Compiler_Util.print_string "\n") - else ()); - load_native_tactics (); - FStar_Syntax_Unionfind.set_ro (); - (let uu___7 = - let uu___8 = FStar_Options.dep () in - uu___8 <> FStar_Pervasives_Native.None in - if uu___7 - then - let uu___8 = - FStar_Parser_Dep.collect filenames - FStar_CheckedFiles.load_parsing_data_from_cache in - match uu___8 with - | (uu___9, deps) -> - (FStar_Parser_Dep.print deps; report_errors []) - else - (let uu___9 = - (FStar_Options.print ()) || - (FStar_Options.print_in_place ()) in - if uu___9 - then - (if FStar_Platform.is_fstar_compiler_using_ocaml - then - let printing_mode = - let uu___10 = FStar_Options.print () in - if uu___10 - then FStar_Prettyprint.FromTempToStdout - else FStar_Prettyprint.FromTempToFile in - FStar_Prettyprint.generate printing_mode filenames - else - failwith - "You seem to be using the F#-generated version ofthe compiler ; \\o\n reindenting is not known to work yet with this version") - else - (let uu___11 = - let uu___12 = FStar_Options.read_checked_file () in - FStar_Pervasives_Native.uu___is_Some uu___12 in - if uu___11 - then - let path = - let uu___12 = FStar_Options.read_checked_file () in - FStar_Pervasives_Native.__proj__Some__item__v - uu___12 in - let env = - FStar_Universal.init_env - FStar_Parser_Dep.empty_deps in - let res1 = FStar_CheckedFiles.load_tc_result path in - match res1 with - | FStar_Pervasives_Native.None -> - let uu___12 = - let uu___13 = - let uu___14 = - FStar_Errors_Msg.text - "Could not read checked file:" in - let uu___15 = FStar_Pprint.doc_of_string path in - FStar_Pprint.op_Hat_Slash_Hat uu___14 uu___15 in - [uu___13] in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_ModuleOrFileNotFound - () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___12) - | FStar_Pervasives_Native.Some (uu___12, tcr) -> - let uu___13 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_modul - tcr.FStar_CheckedFiles.checked_module in - FStar_Compiler_Util.print1 "%s\n" uu___13 - else - (let uu___13 = FStar_Options.list_plugins () in - if uu___13 - then - let ps = FStar_TypeChecker_Cfg.list_plugins () in - let ts = - FStar_Tactics_Interpreter.native_tactics_steps - () in - ((let uu___15 = - let uu___16 = - FStar_Compiler_List.map - (fun p -> - let uu___17 = - FStar_Class_Show.show - FStar_Ident.showable_lident - p.FStar_TypeChecker_Primops_Base.name in - Prims.strcat " " uu___17) ps in - FStar_Compiler_String.concat "\n" uu___16 in - FStar_Compiler_Util.print1 - "Registered plugins:\n%s\n" uu___15); - (let uu___16 = - let uu___17 = - FStar_Compiler_List.map - (fun p -> - let uu___18 = - FStar_Class_Show.show - FStar_Ident.showable_lident - p.FStar_TypeChecker_Primops_Base.name in - Prims.strcat " " uu___18) ts in - FStar_Compiler_String.concat "\n" uu___17 in - FStar_Compiler_Util.print1 - "Registered tactic plugins:\n%s\n" uu___16)) - else - (let uu___15 = FStar_Options.locate () in - if uu___15 - then - ((let uu___17 = - let uu___18 = - FStar_Compiler_Util.get_exec_dir () in - FStar_Compiler_Util.normalize_file_path - uu___18 in - FStar_Compiler_Util.print1 "%s\n" uu___17); - FStar_Compiler_Effect.exit Prims.int_zero) - else - (let uu___17 = FStar_Options.locate_lib () in - if uu___17 - then - let uu___18 = FStar_Options.lib_root () in - match uu___18 with - | FStar_Pervasives_Native.None -> - (FStar_Compiler_Util.print_error - "No library found (is --no_default_includes set?)\n"; - FStar_Compiler_Effect.exit - Prims.int_one) - | FStar_Pervasives_Native.Some s -> - ((let uu___20 = - FStar_Compiler_Util.normalize_file_path - s in - FStar_Compiler_Util.print1 "%s\n" - uu___20); - FStar_Compiler_Effect.exit - Prims.int_zero) - else - (let uu___19 = FStar_Options.locate_ocaml () in - if uu___19 - then - ((let uu___21 = - let uu___22 = - let uu___23 = - FStar_Compiler_Util.get_exec_dir - () in - Prims.strcat uu___23 "/../lib" in - FStar_Compiler_Util.normalize_file_path - uu___22 in - FStar_Compiler_Util.print1 "%s\n" - uu___21); - FStar_Compiler_Effect.exit - Prims.int_zero) - else - (let uu___21 = - let uu___22 = - FStar_Options.read_krml_file () in - FStar_Pervasives_Native.uu___is_Some - uu___22 in - if uu___21 - then - let path = - let uu___22 = - FStar_Options.read_krml_file () in - FStar_Pervasives_Native.__proj__Some__item__v - uu___22 in - let uu___22 = - FStar_Compiler_Util.load_value_from_file - path in - match uu___22 with - | FStar_Pervasives_Native.None -> - let uu___23 = - let uu___24 = - let uu___25 = - FStar_Errors_Msg.text - "Could not read krml file:" in - let uu___26 = - FStar_Pprint.doc_of_string - path in - FStar_Pprint.op_Hat_Slash_Hat - uu___25 uu___26 in - [uu___24] in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_ModuleOrFileNotFound - () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___23) - | FStar_Pervasives_Native.Some - (version, files) -> - ((let uu___24 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - version in - FStar_Compiler_Util.print1 - "Karamel format version: %s\n" - uu___24); - FStar_Compiler_List.iter - (fun uu___24 -> - match uu___24 with - | (name, decls) -> - (FStar_Compiler_Util.print1 - "%s:\n" name; - FStar_Compiler_List.iter - (fun d -> - let uu___26 = - FStar_Class_Show.show - FStar_Extraction_Krml.showable_decl - d in - FStar_Compiler_Util.print1 - " %s\n" uu___26) - decls)) files) - else - (let uu___23 = - FStar_Options.lsp_server () in - if uu___23 - then - FStar_Interactive_Lsp.start_server - () - else - (let uu___25 = - FStar_Options.interactive () in - if uu___25 - then - (FStar_Syntax_Unionfind.set_rw - (); - (match filenames with - | [] -> - (FStar_Errors.log_issue0 - FStar_Errors_Codes.Error_MissingFileName - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "--ide: Name of current file missing in command line invocation\n"); - FStar_Compiler_Effect.exit - Prims.int_one) - | uu___27::uu___28::uu___29 -> - (FStar_Errors.log_issue0 - FStar_Errors_Codes.Error_TooManyFiles - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "--ide: Too many files in command line invocation\n"); - FStar_Compiler_Effect.exit - Prims.int_one) - | filename::[] -> - let uu___27 = - FStar_Options.legacy_interactive - () in - if uu___27 - then - FStar_Interactive_Legacy.interactive_mode - filename - else - FStar_Interactive_Ide.interactive_mode - filename)) - else - if - (FStar_Compiler_List.length - filenames) - >= Prims.int_one - then - (let uu___27 = - FStar_Dependencies.find_deps_if_needed - filenames - FStar_CheckedFiles.load_parsing_data_from_cache in - match uu___27 with - | (filenames1, dep_graph) -> - let uu___28 = - FStar_Universal.batch_mode_tc - filenames1 dep_graph in - (match uu___28 with - | (tcrs, env, cleanup1) - -> - ((let uu___30 = - cleanup1 env in - ()); - (let module_names = - FStar_Compiler_List.map - (fun tcr -> - FStar_Universal.module_or_interface_name - tcr.FStar_CheckedFiles.checked_module) - tcrs in - report_errors - module_names; - finished_message - module_names - Prims.int_zero)))) - else - FStar_Errors.raise_error0 - FStar_Errors_Codes.Error_MissingFileName - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "No file provided")))))))))))))) -let (lazy_chooser : - FStar_Syntax_Syntax.lazy_kind -> - FStar_Syntax_Syntax.lazyinfo -> FStar_Syntax_Syntax.term) - = - fun k -> - fun i -> - match k with - | FStar_Syntax_Syntax.BadLazy -> failwith "lazy chooser: got a BadLazy" - | FStar_Syntax_Syntax.Lazy_bv -> - FStar_Reflection_V2_Embeddings.unfold_lazy_bv i - | FStar_Syntax_Syntax.Lazy_namedv -> - FStar_Reflection_V2_Embeddings.unfold_lazy_namedv i - | FStar_Syntax_Syntax.Lazy_binder -> - FStar_Reflection_V2_Embeddings.unfold_lazy_binder i - | FStar_Syntax_Syntax.Lazy_letbinding -> - FStar_Reflection_V2_Embeddings.unfold_lazy_letbinding i - | FStar_Syntax_Syntax.Lazy_optionstate -> - FStar_Reflection_V2_Embeddings.unfold_lazy_optionstate i - | FStar_Syntax_Syntax.Lazy_fvar -> - FStar_Reflection_V2_Embeddings.unfold_lazy_fvar i - | FStar_Syntax_Syntax.Lazy_comp -> - FStar_Reflection_V2_Embeddings.unfold_lazy_comp i - | FStar_Syntax_Syntax.Lazy_env -> - FStar_Reflection_V2_Embeddings.unfold_lazy_env i - | FStar_Syntax_Syntax.Lazy_sigelt -> - FStar_Reflection_V2_Embeddings.unfold_lazy_sigelt i - | FStar_Syntax_Syntax.Lazy_universe -> - FStar_Reflection_V2_Embeddings.unfold_lazy_universe i - | FStar_Syntax_Syntax.Lazy_proofstate -> - FStar_Tactics_Embedding.unfold_lazy_proofstate i - | FStar_Syntax_Syntax.Lazy_goal -> - FStar_Tactics_Embedding.unfold_lazy_goal i - | FStar_Syntax_Syntax.Lazy_doc -> - FStar_Reflection_V2_Embeddings.unfold_lazy_doc i - | FStar_Syntax_Syntax.Lazy_uvar -> - FStar_Syntax_Util.exp_string "((uvar))" - | FStar_Syntax_Syntax.Lazy_universe_uvar -> - FStar_Syntax_Util.exp_string "((universe_uvar))" - | FStar_Syntax_Syntax.Lazy_issue -> - FStar_Syntax_Util.exp_string "((issue))" - | FStar_Syntax_Syntax.Lazy_ident -> - FStar_Syntax_Util.exp_string "((ident))" - | FStar_Syntax_Syntax.Lazy_tref -> - FStar_Syntax_Util.exp_string "((tref))" - | FStar_Syntax_Syntax.Lazy_embedding (uu___, t) -> FStar_Thunk.force t - | FStar_Syntax_Syntax.Lazy_extension s -> - let uu___ = FStar_Compiler_Util.format1 "((extension %s))" s in - FStar_Syntax_Util.exp_string uu___ -let (setup_hooks : unit -> unit) = - fun uu___ -> - FStar_Compiler_Effect.op_Colon_Equals - FStar_Syntax_DsEnv.ugly_sigelt_to_string_hook - (FStar_Class_Show.show FStar_Syntax_Print.showable_sigelt); - FStar_Errors.set_parse_warn_error FStar_Parser_ParseIt.parse_warn_error; - FStar_Compiler_Effect.op_Colon_Equals FStar_Syntax_Syntax.lazy_chooser - (FStar_Pervasives_Native.Some lazy_chooser); - FStar_Compiler_Effect.op_Colon_Equals FStar_Syntax_Util.tts_f - (FStar_Pervasives_Native.Some - (FStar_Class_Show.show FStar_Syntax_Print.showable_term)); - FStar_Compiler_Effect.op_Colon_Equals FStar_Syntax_Util.ttd_f - (FStar_Pervasives_Native.Some - (FStar_Class_PP.pp FStar_Syntax_Print.pretty_term)); - FStar_Compiler_Effect.op_Colon_Equals - FStar_TypeChecker_Normalize.unembed_binder_knot - (FStar_Pervasives_Native.Some FStar_Reflection_V2_Embeddings.e_binder); - FStar_Compiler_List.iter - FStar_Tactics_Interpreter.register_tactic_primitive_step - FStar_Tactics_V1_Primops.ops; - FStar_Compiler_List.iter - FStar_Tactics_Interpreter.register_tactic_primitive_step - FStar_Tactics_V2_Primops.ops -let (handle_error : Prims.exn -> unit) = - fun e -> - (let uu___1 = FStar_Errors.handleable e in - if uu___1 then FStar_Errors.err_exn e else ()); - (let uu___2 = FStar_Options.trace_error () in - if uu___2 - then - let uu___3 = FStar_Compiler_Util.message_of_exn e in - let uu___4 = FStar_Compiler_Util.trace_of_exn e in - FStar_Compiler_Util.print2_error "Unexpected error\n%s\n%s\n" uu___3 - uu___4 - else - (let uu___4 = - let uu___5 = FStar_Errors.handleable e in Prims.op_Negation uu___5 in - if uu___4 - then - let uu___5 = FStar_Compiler_Util.message_of_exn e in - FStar_Compiler_Util.print1_error - "Unexpected error; please file a bug report, ideally with a minimized version of the source program that triggered the error.\n%s\n" - uu___5 - else ())); - cleanup (); - report_errors [] -let main : 'uuuuu . unit -> 'uuuuu = - fun uu___ -> - try - (fun uu___1 -> - match () with - | () -> - (setup_hooks (); - (let uu___3 = FStar_Compiler_Util.record_time go in - match uu___3 with - | (uu___4, time) -> - ((let uu___6 = FStar_Options.query_stats () in - if uu___6 - then - let uu___7 = FStar_Compiler_Util.string_of_int time in - let uu___8 = - let uu___9 = FStar_Getopt.cmdline () in - FStar_Compiler_String.concat " " uu___9 in - FStar_Compiler_Util.print2_error - "TOTAL TIME %s ms: %s\n" uu___7 uu___8 - else ()); - cleanup (); - FStar_Compiler_Effect.exit Prims.int_zero)))) () - with - | uu___1 -> - (handle_error uu___1; FStar_Compiler_Effect.exit Prims.int_one) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Options.ml b/ocaml/fstar-lib/generated/FStar_Options.ml deleted file mode 100644 index 219c6ed28e2..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Options.ml +++ /dev/null @@ -1,5076 +0,0 @@ -open Prims -type codegen_t = - | OCaml - | FSharp - | Krml - | Plugin - | Extension -let (uu___is_OCaml : codegen_t -> Prims.bool) = - fun projectee -> match projectee with | OCaml -> true | uu___ -> false -let (uu___is_FSharp : codegen_t -> Prims.bool) = - fun projectee -> match projectee with | FSharp -> true | uu___ -> false -let (uu___is_Krml : codegen_t -> Prims.bool) = - fun projectee -> match projectee with | Krml -> true | uu___ -> false -let (uu___is_Plugin : codegen_t -> Prims.bool) = - fun projectee -> match projectee with | Plugin -> true | uu___ -> false -let (uu___is_Extension : codegen_t -> Prims.bool) = - fun projectee -> match projectee with | Extension -> true | uu___ -> false -type split_queries_t = - | No - | OnFailure - | Always -let (uu___is_No : split_queries_t -> Prims.bool) = - fun projectee -> match projectee with | No -> true | uu___ -> false -let (uu___is_OnFailure : split_queries_t -> Prims.bool) = - fun projectee -> match projectee with | OnFailure -> true | uu___ -> false -let (uu___is_Always : split_queries_t -> Prims.bool) = - fun projectee -> match projectee with | Always -> true | uu___ -> false -type message_format_t = - | Json - | Human -let (uu___is_Json : message_format_t -> Prims.bool) = - fun projectee -> match projectee with | Json -> true | uu___ -> false -let (uu___is_Human : message_format_t -> Prims.bool) = - fun projectee -> match projectee with | Human -> true | uu___ -> false -type option_val = - | Bool of Prims.bool - | String of Prims.string - | Path of Prims.string - | Int of Prims.int - | List of option_val Prims.list - | Unset -let (uu___is_Bool : option_val -> Prims.bool) = - fun projectee -> match projectee with | Bool _0 -> true | uu___ -> false -let (__proj__Bool__item___0 : option_val -> Prims.bool) = - fun projectee -> match projectee with | Bool _0 -> _0 -let (uu___is_String : option_val -> Prims.bool) = - fun projectee -> match projectee with | String _0 -> true | uu___ -> false -let (__proj__String__item___0 : option_val -> Prims.string) = - fun projectee -> match projectee with | String _0 -> _0 -let (uu___is_Path : option_val -> Prims.bool) = - fun projectee -> match projectee with | Path _0 -> true | uu___ -> false -let (__proj__Path__item___0 : option_val -> Prims.string) = - fun projectee -> match projectee with | Path _0 -> _0 -let (uu___is_Int : option_val -> Prims.bool) = - fun projectee -> match projectee with | Int _0 -> true | uu___ -> false -let (__proj__Int__item___0 : option_val -> Prims.int) = - fun projectee -> match projectee with | Int _0 -> _0 -let (uu___is_List : option_val -> Prims.bool) = - fun projectee -> match projectee with | List _0 -> true | uu___ -> false -let (__proj__List__item___0 : option_val -> option_val Prims.list) = - fun projectee -> match projectee with | List _0 -> _0 -let (uu___is_Unset : option_val -> Prims.bool) = - fun projectee -> match projectee with | Unset -> true | uu___ -> false -type optionstate = option_val FStar_Compiler_Util.psmap -type opt_type = - | Const of option_val - | IntStr of Prims.string - | BoolStr - | PathStr of Prims.string - | SimpleStr of Prims.string - | EnumStr of Prims.string Prims.list - | OpenEnumStr of (Prims.string Prims.list * Prims.string) - | PostProcessed of ((option_val -> option_val) * opt_type) - | Accumulated of opt_type - | ReverseAccumulated of opt_type - | WithSideEffect of ((unit -> unit) * opt_type) -let (uu___is_Const : opt_type -> Prims.bool) = - fun projectee -> match projectee with | Const _0 -> true | uu___ -> false -let (__proj__Const__item___0 : opt_type -> option_val) = - fun projectee -> match projectee with | Const _0 -> _0 -let (uu___is_IntStr : opt_type -> Prims.bool) = - fun projectee -> match projectee with | IntStr _0 -> true | uu___ -> false -let (__proj__IntStr__item___0 : opt_type -> Prims.string) = - fun projectee -> match projectee with | IntStr _0 -> _0 -let (uu___is_BoolStr : opt_type -> Prims.bool) = - fun projectee -> match projectee with | BoolStr -> true | uu___ -> false -let (uu___is_PathStr : opt_type -> Prims.bool) = - fun projectee -> match projectee with | PathStr _0 -> true | uu___ -> false -let (__proj__PathStr__item___0 : opt_type -> Prims.string) = - fun projectee -> match projectee with | PathStr _0 -> _0 -let (uu___is_SimpleStr : opt_type -> Prims.bool) = - fun projectee -> - match projectee with | SimpleStr _0 -> true | uu___ -> false -let (__proj__SimpleStr__item___0 : opt_type -> Prims.string) = - fun projectee -> match projectee with | SimpleStr _0 -> _0 -let (uu___is_EnumStr : opt_type -> Prims.bool) = - fun projectee -> match projectee with | EnumStr _0 -> true | uu___ -> false -let (__proj__EnumStr__item___0 : opt_type -> Prims.string Prims.list) = - fun projectee -> match projectee with | EnumStr _0 -> _0 -let (uu___is_OpenEnumStr : opt_type -> Prims.bool) = - fun projectee -> - match projectee with | OpenEnumStr _0 -> true | uu___ -> false -let (__proj__OpenEnumStr__item___0 : - opt_type -> (Prims.string Prims.list * Prims.string)) = - fun projectee -> match projectee with | OpenEnumStr _0 -> _0 -let (uu___is_PostProcessed : opt_type -> Prims.bool) = - fun projectee -> - match projectee with | PostProcessed _0 -> true | uu___ -> false -let (__proj__PostProcessed__item___0 : - opt_type -> ((option_val -> option_val) * opt_type)) = - fun projectee -> match projectee with | PostProcessed _0 -> _0 -let (uu___is_Accumulated : opt_type -> Prims.bool) = - fun projectee -> - match projectee with | Accumulated _0 -> true | uu___ -> false -let (__proj__Accumulated__item___0 : opt_type -> opt_type) = - fun projectee -> match projectee with | Accumulated _0 -> _0 -let (uu___is_ReverseAccumulated : opt_type -> Prims.bool) = - fun projectee -> - match projectee with | ReverseAccumulated _0 -> true | uu___ -> false -let (__proj__ReverseAccumulated__item___0 : opt_type -> opt_type) = - fun projectee -> match projectee with | ReverseAccumulated _0 -> _0 -let (uu___is_WithSideEffect : opt_type -> Prims.bool) = - fun projectee -> - match projectee with | WithSideEffect _0 -> true | uu___ -> false -let (__proj__WithSideEffect__item___0 : - opt_type -> ((unit -> unit) * opt_type)) = - fun projectee -> match projectee with | WithSideEffect _0 -> _0 -let (debug_embedding : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref false -let (eager_embedding : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref false -let (__unit_tests__ : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref false -let (__unit_tests : unit -> Prims.bool) = - fun uu___ -> FStar_Compiler_Effect.op_Bang __unit_tests__ -let (__set_unit_tests : unit -> unit) = - fun uu___ -> FStar_Compiler_Effect.op_Colon_Equals __unit_tests__ true -let (__clear_unit_tests : unit -> unit) = - fun uu___ -> FStar_Compiler_Effect.op_Colon_Equals __unit_tests__ false -let (as_bool : option_val -> Prims.bool) = - fun uu___ -> - match uu___ with - | Bool b -> b - | uu___1 -> failwith "Impos: expected Bool" -let (as_int : option_val -> Prims.int) = - fun uu___ -> - match uu___ with | Int b -> b | uu___1 -> failwith "Impos: expected Int" -let (as_string : option_val -> Prims.string) = - fun uu___ -> - match uu___ with - | String b -> b - | Path b -> FStar_Common.try_convert_file_name_to_mixed b - | uu___1 -> failwith "Impos: expected String" -let (as_list' : option_val -> option_val Prims.list) = - fun uu___ -> - match uu___ with - | List ts -> ts - | uu___1 -> failwith "Impos: expected List" -let as_list : - 'uuuuu . (option_val -> 'uuuuu) -> option_val -> 'uuuuu Prims.list = - fun as_t -> - fun x -> let uu___ = as_list' x in FStar_Compiler_List.map as_t uu___ -let as_option : - 'uuuuu . - (option_val -> 'uuuuu) -> - option_val -> 'uuuuu FStar_Pervasives_Native.option - = - fun as_t -> - fun uu___ -> - match uu___ with - | Unset -> FStar_Pervasives_Native.None - | v -> let uu___1 = as_t v in FStar_Pervasives_Native.Some uu___1 -let (as_comma_string_list : option_val -> Prims.string Prims.list) = - fun uu___ -> - match uu___ with - | List ls -> - let uu___1 = - FStar_Compiler_List.map - (fun l -> - let uu___2 = as_string l in - FStar_Compiler_Util.split uu___2 ",") ls in - FStar_Compiler_List.flatten uu___1 - | uu___1 -> failwith "Impos: expected String (comma list)" -let copy_optionstate : - 'uuuuu . 'uuuuu FStar_Compiler_Util.smap -> 'uuuuu FStar_Compiler_Util.smap - = fun m -> FStar_Compiler_Util.smap_copy m -type history1 = - (FStar_Compiler_Debug.saved_state * FStar_Options_Ext.ext_state * - optionstate) -let (fstar_options : optionstate FStar_Compiler_Effect.ref) = - let uu___ = FStar_Compiler_Util.psmap_empty () in - FStar_Compiler_Util.mk_ref uu___ -let (history : history1 Prims.list Prims.list FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref [] -let (peek : unit -> optionstate) = - fun uu___ -> FStar_Compiler_Effect.op_Bang fstar_options -let (internal_push : unit -> unit) = - fun uu___ -> - let uu___1 = FStar_Compiler_Effect.op_Bang history in - match uu___1 with - | lev1::rest -> - let newhd = - let uu___2 = FStar_Compiler_Debug.snapshot () in - let uu___3 = FStar_Options_Ext.save () in - let uu___4 = FStar_Compiler_Effect.op_Bang fstar_options in - (uu___2, uu___3, uu___4) in - FStar_Compiler_Effect.op_Colon_Equals history ((newhd :: lev1) :: - rest) -let (internal_pop : unit -> Prims.bool) = - fun uu___ -> - let uu___1 = FStar_Compiler_Effect.op_Bang history in - match uu___1 with - | lev1::rest -> - (match lev1 with - | [] -> false - | (dbg, ext, opts)::lev1' -> - (FStar_Compiler_Debug.restore dbg; - FStar_Options_Ext.restore ext; - FStar_Compiler_Effect.op_Colon_Equals fstar_options opts; - FStar_Compiler_Effect.op_Colon_Equals history (lev1' :: rest); - true)) -let (push : unit -> unit) = - fun uu___ -> - internal_push (); - (let uu___2 = FStar_Compiler_Effect.op_Bang history in - match uu___2 with - | lev1::uu___3 -> - ((let uu___5 = - let uu___6 = FStar_Compiler_Effect.op_Bang history in lev1 :: - uu___6 in - FStar_Compiler_Effect.op_Colon_Equals history uu___5); - (let uu___6 = internal_pop () in ()))) -let (pop : unit -> unit) = - fun uu___ -> - let uu___1 = FStar_Compiler_Effect.op_Bang history in - match uu___1 with - | [] -> failwith "TOO MANY POPS!" - | uu___2::levs -> - (FStar_Compiler_Effect.op_Colon_Equals history levs; - (let uu___4 = - let uu___5 = internal_pop () in Prims.op_Negation uu___5 in - if uu___4 then failwith "aaa!!!" else ())) -let (set : optionstate -> unit) = - fun o -> FStar_Compiler_Effect.op_Colon_Equals fstar_options o -let (depth : unit -> Prims.int) = - fun uu___ -> - let uu___1 = FStar_Compiler_Effect.op_Bang history in - match uu___1 with | lev::uu___2 -> FStar_Compiler_List.length lev -let (snapshot : unit -> (Prims.int * unit)) = - fun uu___ -> FStar_Common.snapshot push history () -let (rollback : Prims.int FStar_Pervasives_Native.option -> unit) = - fun depth1 -> FStar_Common.rollback pop history depth1 -let (set_option : Prims.string -> option_val -> unit) = - fun k -> - fun v -> - let map = peek () in - if k = "report_assumes" - then - let uu___ = FStar_Compiler_Util.psmap_try_find map k in - match uu___ with - | FStar_Pervasives_Native.Some (String "error") -> () - | uu___1 -> - let uu___2 = FStar_Compiler_Util.psmap_add map k v in - FStar_Compiler_Effect.op_Colon_Equals fstar_options uu___2 - else - (let uu___1 = FStar_Compiler_Util.psmap_add map k v in - FStar_Compiler_Effect.op_Colon_Equals fstar_options uu___1) -let (set_option' : (Prims.string * option_val) -> unit) = - fun uu___ -> match uu___ with | (k, v) -> set_option k v -let (set_admit_smt_queries : Prims.bool -> unit) = - fun b -> set_option "admit_smt_queries" (Bool b) -let (defaults : (Prims.string * option_val) Prims.list) = - [("abort_on", (Int Prims.int_zero)); - ("admit_smt_queries", (Bool false)); - ("admit_except", Unset); - ("disallow_unification_guards", (Bool false)); - ("already_cached", Unset); - ("cache_checked_modules", (Bool false)); - ("cache_dir", Unset); - ("cache_off", (Bool false)); - ("compat_pre_core", Unset); - ("compat_pre_typed_indexed_effects", (Bool false)); - ("print_cache_version", (Bool false)); - ("cmi", (Bool false)); - ("codegen", Unset); - ("codegen-lib", (List [])); - ("defensive", (String "no")); - ("debug", (List [])); - ("debug_all", (Bool false)); - ("debug_all_modules", (Bool false)); - ("dep", Unset); - ("detail_errors", (Bool false)); - ("detail_hint_replay", (Bool false)); - ("dump_module", (List [])); - ("eager_subtyping", (Bool false)); - ("error_contexts", (Bool false)); - ("expose_interfaces", (Bool false)); - ("message_format", (String "human")); - ("ext", Unset); - ("extract", Unset); - ("extract_all", (Bool false)); - ("extract_module", (List [])); - ("extract_namespace", (List [])); - ("full_context_dependency", (Bool true)); - ("hide_uvar_nums", (Bool false)); - ("hint_hook", Unset); - ("hint_info", (Bool false)); - ("hint_dir", Unset); - ("hint_file", Unset); - ("in", (Bool false)); - ("ide", (Bool false)); - ("ide_id_info_off", (Bool false)); - ("lsp", (Bool false)); - ("include", (List [])); - ("print", (Bool false)); - ("print_in_place", (Bool false)); - ("force", (Bool false)); - ("fuel", Unset); - ("ifuel", Unset); - ("initial_fuel", (Int (Prims.of_int (2)))); - ("initial_ifuel", (Int Prims.int_one)); - ("keep_query_captions", (Bool true)); - ("lax", (Bool false)); - ("load", (List [])); - ("load_cmxs", (List [])); - ("log_queries", (Bool false)); - ("log_failing_queries", (Bool false)); - ("log_types", (Bool false)); - ("max_fuel", (Int (Prims.of_int (8)))); - ("max_ifuel", (Int (Prims.of_int (2)))); - ("MLish", (Bool false)); - ("MLish_effect", (String "FStar.Compiler.Effect")); - ("no_default_includes", (Bool false)); - ("no_extract", (List [])); - ("no_location_info", (Bool false)); - ("no_smt", (Bool false)); - ("no_plugins", (Bool false)); - ("no_tactics", (Bool false)); - ("normalize_pure_terms_for_extraction", (Bool false)); - ("krmloutput", Unset); - ("odir", Unset); - ("output_deps_to", Unset); - ("prims", Unset); - ("pretype", (Bool true)); - ("prims_ref", Unset); - ("print_bound_var_types", (Bool false)); - ("print_effect_args", (Bool false)); - ("print_expected_failures", (Bool false)); - ("print_full_names", (Bool false)); - ("print_implicits", (Bool false)); - ("print_universes", (Bool false)); - ("print_z3_statistics", (Bool false)); - ("prn", (Bool false)); - ("proof_recovery", (Bool false)); - ("quake", (Int Prims.int_zero)); - ("quake_lo", (Int Prims.int_one)); - ("quake_hi", (Int Prims.int_one)); - ("quake_keep", (Bool false)); - ("query_cache", (Bool false)); - ("query_stats", (Bool false)); - ("read_checked_file", Unset); - ("list_plugins", (Bool false)); - ("locate", (Bool false)); - ("locate_lib", (Bool false)); - ("locate_ocaml", (Bool false)); - ("read_krml_file", Unset); - ("record_hints", (Bool false)); - ("record_options", (Bool false)); - ("report_assumes", Unset); - ("retry", (Bool false)); - ("reuse_hint_for", Unset); - ("silent", (Bool false)); - ("smt", Unset); - ("smtencoding.elim_box", (Bool false)); - ("smtencoding.nl_arith_repr", (String "boxwrap")); - ("smtencoding.l_arith_repr", (String "boxwrap")); - ("smtencoding.valid_intro", (Bool true)); - ("smtencoding.valid_elim", (Bool false)); - ("split_queries", (String "on_failure")); - ("tactics_failhard", (Bool false)); - ("tactics_info", (Bool false)); - ("tactic_raw_binders", (Bool false)); - ("tactic_trace", (Bool false)); - ("tactic_trace_d", (Int Prims.int_zero)); - ("tcnorm", (Bool true)); - ("timing", (Bool false)); - ("trace_error", (Bool false)); - ("ugly", (Bool false)); - ("unthrottle_inductives", (Bool false)); - ("unsafe_tactic_exec", (Bool false)); - ("use_native_tactics", Unset); - ("use_eq_at_higher_order", (Bool false)); - ("use_hints", (Bool false)); - ("use_hint_hashes", (Bool false)); - ("using_facts_from", Unset); - ("verify_module", (List [])); - ("warn_default_effects", (Bool false)); - ("z3refresh", (Bool false)); - ("z3rlimit", (Int (Prims.of_int (5)))); - ("z3rlimit_factor", (Int Prims.int_one)); - ("z3seed", (Int Prims.int_zero)); - ("z3cliopt", (List [])); - ("z3smtopt", (List [])); - ("z3version", (String "4.8.5")); - ("__no_positivity", (Bool false)); - ("__tactics_nbe", (Bool false)); - ("warn_error", (List [])); - ("use_nbe", (Bool false)); - ("use_nbe_for_extraction", (Bool false)); - ("trivial_pre_for_unannotated_effectful_fns", (Bool true)); - ("profile_group_by_decl", (Bool false)); - ("profile_component", Unset); - ("profile", Unset)] -let (init : unit -> unit) = - fun uu___ -> - FStar_Compiler_Debug.disable_all (); - FStar_Options_Ext.reset (); - (let uu___4 = FStar_Compiler_Util.psmap_empty () in - FStar_Compiler_Effect.op_Colon_Equals fstar_options uu___4); - FStar_Compiler_List.iter set_option' defaults -let (clear : unit -> unit) = - fun uu___ -> FStar_Compiler_Effect.op_Colon_Equals history [[]]; init () -let (uu___0 : unit) = clear () -let (get_option : Prims.string -> option_val) = - fun s -> - let uu___ = - let uu___1 = peek () in FStar_Compiler_Util.psmap_try_find uu___1 s in - match uu___ with - | FStar_Pervasives_Native.None -> - let uu___1 = - let uu___2 = FStar_Compiler_String.op_Hat s " not found" in - FStar_Compiler_String.op_Hat "Impossible: option " uu___2 in - failwith uu___1 - | FStar_Pervasives_Native.Some s1 -> s1 -let rec (option_val_to_string : option_val -> Prims.string) = - fun v -> - match v with - | Bool b -> - let uu___ = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) b in - FStar_Compiler_String.op_Hat "Bool " uu___ - | String s -> - let uu___ = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_string) s in - FStar_Compiler_String.op_Hat "String " uu___ - | Path s -> - let uu___ = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_string) s in - FStar_Compiler_String.op_Hat "Path " uu___ - | Int i -> - let uu___ = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) i in - FStar_Compiler_String.op_Hat "Int " uu___ - | List vs -> - let uu___ = (FStar_Common.string_of_list ()) option_val_to_string vs in - FStar_Compiler_String.op_Hat "List " uu___ - | Unset -> "Unset" -let (showable_option_val : option_val FStar_Class_Show.showable) = - { FStar_Class_Show.show = option_val_to_string } -let rec (eq_option_val : option_val -> option_val -> Prims.bool) = - fun v1 -> - fun v2 -> - match (v1, v2) with - | (Bool x1, Bool x2) -> - FStar_Class_Deq.op_Equals_Question FStar_Class_Deq.deq_bool x1 x2 - | (String x1, String x2) -> - FStar_Class_Deq.op_Equals_Question FStar_Class_Deq.deq_string x1 x2 - | (Path x1, Path x2) -> - FStar_Class_Deq.op_Equals_Question FStar_Class_Deq.deq_string x1 x2 - | (Int x1, Int x2) -> - FStar_Class_Deq.op_Equals_Question FStar_Class_Deq.deq_int x1 x2 - | (Unset, Unset) -> true - | (List x1, List x2) -> FStar_Common.eq_list eq_option_val x1 x2 - | (uu___, uu___1) -> false -let (deq_option_val : option_val FStar_Class_Deq.deq) = - { FStar_Class_Deq.op_Equals_Question = eq_option_val } -let rec list_try_find : - 'a 'b . - 'a FStar_Class_Deq.deq -> - 'a -> ('a * 'b) Prims.list -> 'b FStar_Pervasives_Native.option - = - fun uu___ -> - fun k -> - fun l -> - match l with - | [] -> FStar_Pervasives_Native.None - | (k', v')::l' -> - let uu___1 = FStar_Class_Deq.op_Equals_Question uu___ k k' in - if uu___1 - then FStar_Pervasives_Native.Some v' - else list_try_find uu___ k l' -let (show_options : unit -> Prims.string) = - fun uu___ -> - let s = peek () in - let kvs = - let uu___1 = FStar_Common.psmap_keys s in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Class_Monad.monad_list () () - (Obj.magic uu___1) - (fun uu___2 -> - (fun k -> - let k = Obj.magic k in - if k = "verify_module" - then Obj.magic (Obj.repr []) - else - Obj.magic - (Obj.repr - (let v = - let uu___3 = - FStar_Compiler_Util.psmap_try_find s k in - FStar_Compiler_Util.must uu___3 in - let v0 = - list_try_find FStar_Class_Deq.deq_string k - defaults in - let uu___3 = - FStar_Class_Deq.op_Equals_Question - (FStar_Class_Deq.deq_option deq_option_val) v0 - (FStar_Pervasives_Native.Some v) in - if uu___3 - then Obj.repr [] - else - Obj.repr - (FStar_Class_Monad.return - FStar_Class_Monad.monad_list () - (Obj.magic (k, v)))))) uu___2)) in - let rec show_optionval v = - match v with - | String s1 -> - let uu___1 = FStar_Compiler_String.op_Hat s1 "\"" in - FStar_Compiler_String.op_Hat "\"" uu___1 - | Bool b -> - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) b - | Int i -> - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) i - | Path s1 -> s1 - | List s1 -> - let uu___1 = FStar_Compiler_List.map show_optionval s1 in - FStar_Compiler_String.concat "," uu___1 - | Unset -> "" in - let show1 uu___1 = - match uu___1 with - | (k, v) -> - let uu___2 = show_optionval v in - FStar_Compiler_Util.format2 "--%s %s" k uu___2 in - let uu___1 = FStar_Compiler_List.map show1 kvs in - FStar_Compiler_String.concat "\n" uu___1 -let (set_verification_options : optionstate -> unit) = - fun o -> - let verifopts = - ["initial_fuel"; - "max_fuel"; - "initial_ifuel"; - "max_ifuel"; - "detail_errors"; - "detail_hint_replay"; - "no_smt"; - "quake"; - "retry"; - "smtencoding.elim_box"; - "smtencoding.nl_arith_repr"; - "smtencoding.l_arith_repr"; - "smtencoding.valid_intro"; - "smtencoding.valid_elim"; - "tcnorm"; - "no_plugins"; - "no_tactics"; - "z3cliopt"; - "z3smtopt"; - "z3refresh"; - "z3rlimit"; - "z3rlimit_factor"; - "z3seed"; - "z3version"; - "trivial_pre_for_unannotated_effectful_fns"] in - FStar_Compiler_List.iter - (fun k -> - let uu___ = - let uu___1 = FStar_Compiler_Util.psmap_try_find o k in - FStar_Compiler_Util.must uu___1 in - set_option k uu___) verifopts -let lookup_opt : 'uuuuu . Prims.string -> (option_val -> 'uuuuu) -> 'uuuuu = - fun s -> fun c -> let uu___ = get_option s in c uu___ -let (get_abort_on : unit -> Prims.int) = - fun uu___ -> lookup_opt "abort_on" as_int -let (get_admit_smt_queries : unit -> Prims.bool) = - fun uu___ -> lookup_opt "admit_smt_queries" as_bool -let (get_admit_except : unit -> Prims.string FStar_Pervasives_Native.option) - = fun uu___ -> lookup_opt "admit_except" (as_option as_string) -let (get_compat_pre_core : unit -> Prims.int FStar_Pervasives_Native.option) - = fun uu___ -> lookup_opt "compat_pre_core" (as_option as_int) -let (get_compat_pre_typed_indexed_effects : unit -> Prims.bool) = - fun uu___ -> lookup_opt "compat_pre_typed_indexed_effects" as_bool -let (get_disallow_unification_guards : unit -> Prims.bool) = - fun uu___ -> lookup_opt "disallow_unification_guards" as_bool -let (get_already_cached : - unit -> Prims.string Prims.list FStar_Pervasives_Native.option) = - fun uu___ -> lookup_opt "already_cached" (as_option (as_list as_string)) -let (get_cache_checked_modules : unit -> Prims.bool) = - fun uu___ -> lookup_opt "cache_checked_modules" as_bool -let (get_cache_dir : unit -> Prims.string FStar_Pervasives_Native.option) = - fun uu___ -> lookup_opt "cache_dir" (as_option as_string) -let (get_cache_off : unit -> Prims.bool) = - fun uu___ -> lookup_opt "cache_off" as_bool -let (get_print_cache_version : unit -> Prims.bool) = - fun uu___ -> lookup_opt "print_cache_version" as_bool -let (get_cmi : unit -> Prims.bool) = fun uu___ -> lookup_opt "cmi" as_bool -let (get_codegen : unit -> Prims.string FStar_Pervasives_Native.option) = - fun uu___ -> lookup_opt "codegen" (as_option as_string) -let (get_codegen_lib : unit -> Prims.string Prims.list) = - fun uu___ -> lookup_opt "codegen-lib" (as_list as_string) -let (get_defensive : unit -> Prims.string) = - fun uu___ -> lookup_opt "defensive" as_string -let (get_dep : unit -> Prims.string FStar_Pervasives_Native.option) = - fun uu___ -> lookup_opt "dep" (as_option as_string) -let (get_detail_errors : unit -> Prims.bool) = - fun uu___ -> lookup_opt "detail_errors" as_bool -let (get_detail_hint_replay : unit -> Prims.bool) = - fun uu___ -> lookup_opt "detail_hint_replay" as_bool -let (get_dump_module : unit -> Prims.string Prims.list) = - fun uu___ -> lookup_opt "dump_module" (as_list as_string) -let (get_eager_subtyping : unit -> Prims.bool) = - fun uu___ -> lookup_opt "eager_subtyping" as_bool -let (get_error_contexts : unit -> Prims.bool) = - fun uu___ -> lookup_opt "error_contexts" as_bool -let (get_expose_interfaces : unit -> Prims.bool) = - fun uu___ -> lookup_opt "expose_interfaces" as_bool -let (get_message_format : unit -> Prims.string) = - fun uu___ -> lookup_opt "message_format" as_string -let (get_extract : - unit -> Prims.string Prims.list FStar_Pervasives_Native.option) = - fun uu___ -> lookup_opt "extract" (as_option (as_list as_string)) -let (get_extract_module : unit -> Prims.string Prims.list) = - fun uu___ -> lookup_opt "extract_module" (as_list as_string) -let (get_extract_namespace : unit -> Prims.string Prims.list) = - fun uu___ -> lookup_opt "extract_namespace" (as_list as_string) -let (get_force : unit -> Prims.bool) = - fun uu___ -> lookup_opt "force" as_bool -let (get_hide_uvar_nums : unit -> Prims.bool) = - fun uu___ -> lookup_opt "hide_uvar_nums" as_bool -let (get_hint_info : unit -> Prims.bool) = - fun uu___ -> lookup_opt "hint_info" as_bool -let (get_hint_dir : unit -> Prims.string FStar_Pervasives_Native.option) = - fun uu___ -> lookup_opt "hint_dir" (as_option as_string) -let (get_hint_file : unit -> Prims.string FStar_Pervasives_Native.option) = - fun uu___ -> lookup_opt "hint_file" (as_option as_string) -let (get_in : unit -> Prims.bool) = fun uu___ -> lookup_opt "in" as_bool -let (get_ide : unit -> Prims.bool) = fun uu___ -> lookup_opt "ide" as_bool -let (get_ide_id_info_off : unit -> Prims.bool) = - fun uu___ -> lookup_opt "ide_id_info_off" as_bool -let (get_lsp : unit -> Prims.bool) = fun uu___ -> lookup_opt "lsp" as_bool -let (get_include : unit -> Prims.string Prims.list) = - fun uu___ -> lookup_opt "include" (as_list as_string) -let (get_print : unit -> Prims.bool) = - fun uu___ -> lookup_opt "print" as_bool -let (get_print_in_place : unit -> Prims.bool) = - fun uu___ -> lookup_opt "print_in_place" as_bool -let (get_initial_fuel : unit -> Prims.int) = - fun uu___ -> lookup_opt "initial_fuel" as_int -let (get_initial_ifuel : unit -> Prims.int) = - fun uu___ -> lookup_opt "initial_ifuel" as_int -let (get_keep_query_captions : unit -> Prims.bool) = - fun uu___ -> lookup_opt "keep_query_captions" as_bool -let (get_lax : unit -> Prims.bool) = fun uu___ -> lookup_opt "lax" as_bool -let (get_load : unit -> Prims.string Prims.list) = - fun uu___ -> lookup_opt "load" (as_list as_string) -let (get_load_cmxs : unit -> Prims.string Prims.list) = - fun uu___ -> lookup_opt "load_cmxs" (as_list as_string) -let (get_log_queries : unit -> Prims.bool) = - fun uu___ -> lookup_opt "log_queries" as_bool -let (get_log_failing_queries : unit -> Prims.bool) = - fun uu___ -> lookup_opt "log_failing_queries" as_bool -let (get_log_types : unit -> Prims.bool) = - fun uu___ -> lookup_opt "log_types" as_bool -let (get_max_fuel : unit -> Prims.int) = - fun uu___ -> lookup_opt "max_fuel" as_int -let (get_max_ifuel : unit -> Prims.int) = - fun uu___ -> lookup_opt "max_ifuel" as_int -let (get_MLish : unit -> Prims.bool) = - fun uu___ -> lookup_opt "MLish" as_bool -let (get_MLish_effect : unit -> Prims.string) = - fun uu___ -> lookup_opt "MLish_effect" as_string -let (get_no_default_includes : unit -> Prims.bool) = - fun uu___ -> lookup_opt "no_default_includes" as_bool -let (get_no_extract : unit -> Prims.string Prims.list) = - fun uu___ -> lookup_opt "no_extract" (as_list as_string) -let (get_no_location_info : unit -> Prims.bool) = - fun uu___ -> lookup_opt "no_location_info" as_bool -let (get_no_plugins : unit -> Prims.bool) = - fun uu___ -> lookup_opt "no_plugins" as_bool -let (get_no_smt : unit -> Prims.bool) = - fun uu___ -> lookup_opt "no_smt" as_bool -let (get_normalize_pure_terms_for_extraction : unit -> Prims.bool) = - fun uu___ -> lookup_opt "normalize_pure_terms_for_extraction" as_bool -let (get_krmloutput : unit -> Prims.string FStar_Pervasives_Native.option) = - fun uu___ -> lookup_opt "krmloutput" (as_option as_string) -let (get_odir : unit -> Prims.string FStar_Pervasives_Native.option) = - fun uu___ -> lookup_opt "odir" (as_option as_string) -let (get_output_deps_to : - unit -> Prims.string FStar_Pervasives_Native.option) = - fun uu___ -> lookup_opt "output_deps_to" (as_option as_string) -let (get_ugly : unit -> Prims.bool) = fun uu___ -> lookup_opt "ugly" as_bool -let (get_prims : unit -> Prims.string FStar_Pervasives_Native.option) = - fun uu___ -> lookup_opt "prims" (as_option as_string) -let (get_print_bound_var_types : unit -> Prims.bool) = - fun uu___ -> lookup_opt "print_bound_var_types" as_bool -let (get_print_effect_args : unit -> Prims.bool) = - fun uu___ -> lookup_opt "print_effect_args" as_bool -let (get_print_expected_failures : unit -> Prims.bool) = - fun uu___ -> lookup_opt "print_expected_failures" as_bool -let (get_print_full_names : unit -> Prims.bool) = - fun uu___ -> lookup_opt "print_full_names" as_bool -let (get_print_implicits : unit -> Prims.bool) = - fun uu___ -> lookup_opt "print_implicits" as_bool -let (get_print_universes : unit -> Prims.bool) = - fun uu___ -> lookup_opt "print_universes" as_bool -let (get_print_z3_statistics : unit -> Prims.bool) = - fun uu___ -> lookup_opt "print_z3_statistics" as_bool -let (get_prn : unit -> Prims.bool) = fun uu___ -> lookup_opt "prn" as_bool -let (get_proof_recovery : unit -> Prims.bool) = - fun uu___ -> lookup_opt "proof_recovery" as_bool -let (get_quake_lo : unit -> Prims.int) = - fun uu___ -> lookup_opt "quake_lo" as_int -let (get_quake_hi : unit -> Prims.int) = - fun uu___ -> lookup_opt "quake_hi" as_int -let (get_quake_keep : unit -> Prims.bool) = - fun uu___ -> lookup_opt "quake_keep" as_bool -let (get_query_cache : unit -> Prims.bool) = - fun uu___ -> lookup_opt "query_cache" as_bool -let (get_query_stats : unit -> Prims.bool) = - fun uu___ -> lookup_opt "query_stats" as_bool -let (get_read_checked_file : - unit -> Prims.string FStar_Pervasives_Native.option) = - fun uu___ -> lookup_opt "read_checked_file" (as_option as_string) -let (get_read_krml_file : - unit -> Prims.string FStar_Pervasives_Native.option) = - fun uu___ -> lookup_opt "read_krml_file" (as_option as_string) -let (get_list_plugins : unit -> Prims.bool) = - fun uu___ -> lookup_opt "list_plugins" as_bool -let (get_locate : unit -> Prims.bool) = - fun uu___ -> lookup_opt "locate" as_bool -let (get_locate_lib : unit -> Prims.bool) = - fun uu___ -> lookup_opt "locate_lib" as_bool -let (get_locate_ocaml : unit -> Prims.bool) = - fun uu___ -> lookup_opt "locate_ocaml" as_bool -let (get_record_hints : unit -> Prims.bool) = - fun uu___ -> lookup_opt "record_hints" as_bool -let (get_record_options : unit -> Prims.bool) = - fun uu___ -> lookup_opt "record_options" as_bool -let (get_retry : unit -> Prims.bool) = - fun uu___ -> lookup_opt "retry" as_bool -let (get_reuse_hint_for : - unit -> Prims.string FStar_Pervasives_Native.option) = - fun uu___ -> lookup_opt "reuse_hint_for" (as_option as_string) -let (get_report_assumes : - unit -> Prims.string FStar_Pervasives_Native.option) = - fun uu___ -> lookup_opt "report_assumes" (as_option as_string) -let (get_silent : unit -> Prims.bool) = - fun uu___ -> lookup_opt "silent" as_bool -let (get_smt : unit -> Prims.string FStar_Pervasives_Native.option) = - fun uu___ -> lookup_opt "smt" (as_option as_string) -let (get_smtencoding_elim_box : unit -> Prims.bool) = - fun uu___ -> lookup_opt "smtencoding.elim_box" as_bool -let (get_smtencoding_nl_arith_repr : unit -> Prims.string) = - fun uu___ -> lookup_opt "smtencoding.nl_arith_repr" as_string -let (get_smtencoding_l_arith_repr : unit -> Prims.string) = - fun uu___ -> lookup_opt "smtencoding.l_arith_repr" as_string -let (get_smtencoding_valid_intro : unit -> Prims.bool) = - fun uu___ -> lookup_opt "smtencoding.valid_intro" as_bool -let (get_smtencoding_valid_elim : unit -> Prims.bool) = - fun uu___ -> lookup_opt "smtencoding.valid_elim" as_bool -let (get_split_queries : unit -> Prims.string) = - fun uu___ -> lookup_opt "split_queries" as_string -let (get_tactic_raw_binders : unit -> Prims.bool) = - fun uu___ -> lookup_opt "tactic_raw_binders" as_bool -let (get_tactics_failhard : unit -> Prims.bool) = - fun uu___ -> lookup_opt "tactics_failhard" as_bool -let (get_tactics_info : unit -> Prims.bool) = - fun uu___ -> lookup_opt "tactics_info" as_bool -let (get_tactic_trace : unit -> Prims.bool) = - fun uu___ -> lookup_opt "tactic_trace" as_bool -let (get_tactic_trace_d : unit -> Prims.int) = - fun uu___ -> lookup_opt "tactic_trace_d" as_int -let (get_tactics_nbe : unit -> Prims.bool) = - fun uu___ -> lookup_opt "__tactics_nbe" as_bool -let (get_tcnorm : unit -> Prims.bool) = - fun uu___ -> lookup_opt "tcnorm" as_bool -let (get_timing : unit -> Prims.bool) = - fun uu___ -> lookup_opt "timing" as_bool -let (get_trace_error : unit -> Prims.bool) = - fun uu___ -> lookup_opt "trace_error" as_bool -let (get_unthrottle_inductives : unit -> Prims.bool) = - fun uu___ -> lookup_opt "unthrottle_inductives" as_bool -let (get_unsafe_tactic_exec : unit -> Prims.bool) = - fun uu___ -> lookup_opt "unsafe_tactic_exec" as_bool -let (get_use_eq_at_higher_order : unit -> Prims.bool) = - fun uu___ -> lookup_opt "use_eq_at_higher_order" as_bool -let (get_use_hints : unit -> Prims.bool) = - fun uu___ -> lookup_opt "use_hints" as_bool -let (get_use_hint_hashes : unit -> Prims.bool) = - fun uu___ -> lookup_opt "use_hint_hashes" as_bool -let (get_use_native_tactics : - unit -> Prims.string FStar_Pervasives_Native.option) = - fun uu___ -> lookup_opt "use_native_tactics" (as_option as_string) -let (get_no_tactics : unit -> Prims.bool) = - fun uu___ -> lookup_opt "no_tactics" as_bool -let (get_using_facts_from : - unit -> Prims.string Prims.list FStar_Pervasives_Native.option) = - fun uu___ -> lookup_opt "using_facts_from" (as_option (as_list as_string)) -let (get_verify_module : unit -> Prims.string Prims.list) = - fun uu___ -> lookup_opt "verify_module" (as_list as_string) -let (get_version : unit -> Prims.bool) = - fun uu___ -> lookup_opt "version" as_bool -let (get_warn_default_effects : unit -> Prims.bool) = - fun uu___ -> lookup_opt "warn_default_effects" as_bool -let (get_z3cliopt : unit -> Prims.string Prims.list) = - fun uu___ -> lookup_opt "z3cliopt" (as_list as_string) -let (get_z3smtopt : unit -> Prims.string Prims.list) = - fun uu___ -> lookup_opt "z3smtopt" (as_list as_string) -let (get_z3refresh : unit -> Prims.bool) = - fun uu___ -> lookup_opt "z3refresh" as_bool -let (get_z3rlimit : unit -> Prims.int) = - fun uu___ -> lookup_opt "z3rlimit" as_int -let (get_z3rlimit_factor : unit -> Prims.int) = - fun uu___ -> lookup_opt "z3rlimit_factor" as_int -let (get_z3seed : unit -> Prims.int) = - fun uu___ -> lookup_opt "z3seed" as_int -let (get_z3version : unit -> Prims.string) = - fun uu___ -> lookup_opt "z3version" as_string -let (get_no_positivity : unit -> Prims.bool) = - fun uu___ -> lookup_opt "__no_positivity" as_bool -let (get_warn_error : unit -> Prims.string Prims.list) = - fun uu___ -> lookup_opt "warn_error" (as_list as_string) -let (get_use_nbe : unit -> Prims.bool) = - fun uu___ -> lookup_opt "use_nbe" as_bool -let (get_use_nbe_for_extraction : unit -> Prims.bool) = - fun uu___ -> lookup_opt "use_nbe_for_extraction" as_bool -let (get_trivial_pre_for_unannotated_effectful_fns : unit -> Prims.bool) = - fun uu___ -> lookup_opt "trivial_pre_for_unannotated_effectful_fns" as_bool -let (get_profile : - unit -> Prims.string Prims.list FStar_Pervasives_Native.option) = - fun uu___ -> lookup_opt "profile" (as_option (as_list as_string)) -let (get_profile_group_by_decl : unit -> Prims.bool) = - fun uu___ -> lookup_opt "profile_group_by_decl" as_bool -let (get_profile_component : - unit -> Prims.string Prims.list FStar_Pervasives_Native.option) = - fun uu___ -> lookup_opt "profile_component" (as_option (as_list as_string)) -let (_version : Prims.string FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref "" -let (_platform : Prims.string FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref "" -let (_compiler : Prims.string FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref "" -let (_date : Prims.string FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref " not set" -let (_commit : Prims.string FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref "" -let (display_version : unit -> unit) = - fun uu___ -> - let uu___1 = - let uu___2 = FStar_Compiler_Effect.op_Bang _version in - let uu___3 = FStar_Compiler_Effect.op_Bang _platform in - let uu___4 = FStar_Compiler_Effect.op_Bang _compiler in - let uu___5 = FStar_Compiler_Effect.op_Bang _date in - let uu___6 = FStar_Compiler_Effect.op_Bang _commit in - FStar_Compiler_Util.format5 - "F* %s\nplatform=%s\ncompiler=%s\ndate=%s\ncommit=%s\n" uu___2 uu___3 - uu___4 uu___5 uu___6 in - FStar_Compiler_Util.print_string uu___1 -let (display_debug_keys : unit -> unit) = - fun uu___ -> - let keys = FStar_Compiler_Debug.list_all_toggles () in - let uu___1 = - FStar_Compiler_List.sortWith FStar_Compiler_String.compare keys in - FStar_Compiler_List.iter - (fun s -> - let uu___2 = FStar_Compiler_String.op_Hat s "\n" in - FStar_Compiler_Util.print_string uu___2) uu___1 -let (display_usage_aux : - (FStar_Getopt.opt * FStar_Pprint.document) Prims.list -> unit) = - fun specs -> - let text s = - let uu___ = FStar_Pprint.break_ Prims.int_one in - let uu___1 = FStar_Pprint.words s in FStar_Pprint.flow uu___ uu___1 in - let bold_doc d = - let uu___ = - let uu___1 = FStar_Compiler_Util.stdout_isatty () in - uu___1 = (FStar_Pervasives_Native.Some true) in - if uu___ - then - let uu___1 = FStar_Pprint.fancystring "\027[39;1m" Prims.int_zero in - let uu___2 = - let uu___3 = FStar_Pprint.fancystring "\027[0m" Prims.int_zero in - FStar_Pprint.op_Hat_Hat d uu___3 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 - else d in - let d = - let uu___ = - FStar_Pprint.doc_of_string - "fstar.exe [options] file[s] [@respfile...]" in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Compiler_Util.colorize_bold "@" in - FStar_Compiler_Util.format1 - " %srespfile: read command-line options from respfile\n" - uu___4 in - FStar_Pprint.doc_of_string uu___3 in - let uu___3 = - FStar_Compiler_List.fold_right - (fun uu___4 -> - fun rest -> - match uu___4 with - | ((short, flag, p), explain) -> - let arg = - match p with - | FStar_Getopt.ZeroArgs uu___5 -> FStar_Pprint.empty - | FStar_Getopt.OneArg (uu___5, argname) -> - let uu___6 = FStar_Pprint.blank Prims.int_one in - let uu___7 = FStar_Pprint.doc_of_string argname in - FStar_Pprint.op_Hat_Hat uu___6 uu___7 in - let short_opt = - if short <> FStar_Getopt.noshort - then - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Compiler_String.make Prims.int_one - short in - FStar_Compiler_String.op_Hat "-" uu___8 in - FStar_Pprint.doc_of_string uu___7 in - FStar_Pprint.op_Hat_Hat uu___6 arg in - [uu___5] - else [] in - let long_opt = - if flag <> "" - then - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Compiler_String.op_Hat "--" flag in - FStar_Pprint.doc_of_string uu___7 in - FStar_Pprint.op_Hat_Hat uu___6 arg in - [uu___5] - else [] in - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = FStar_Pprint.blank Prims.int_one in - FStar_Pprint.op_Hat_Hat FStar_Pprint.comma - uu___9 in - FStar_Pprint.separate uu___8 - (FStar_Compiler_List.op_At short_opt long_opt) in - bold_doc uu___7 in - FStar_Pprint.group uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Pprint.blank (Prims.of_int (4)) in - let uu___11 = FStar_Pprint.align explain in - FStar_Pprint.op_Hat_Hat uu___10 uu___11 in - FStar_Pprint.group uu___9 in - let uu___9 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline rest in - FStar_Pprint.op_Hat_Hat uu___8 uu___9 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline uu___7 in - FStar_Pprint.op_Hat_Hat uu___5 uu___6) specs - FStar_Pprint.empty in - FStar_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in - FStar_Pprint.op_Hat_Slash_Hat uu___ uu___1 in - let uu___ = - FStar_Pprint.pretty_string (FStar_Compiler_Util.float_of_string "1.0") - (Prims.of_int (80)) d in - FStar_Compiler_Util.print_string uu___ -let (mk_spec : - (FStar_BaseTypes.char * Prims.string * option_val FStar_Getopt.opt_variant) - -> FStar_Getopt.opt) - = - fun o -> - let uu___ = o in - match uu___ with - | (ns, name, arg) -> - let arg1 = - match arg with - | FStar_Getopt.ZeroArgs f -> - let g uu___1 = let uu___2 = f () in set_option name uu___2 in - FStar_Getopt.ZeroArgs g - | FStar_Getopt.OneArg (f, d) -> - let g x = let uu___1 = f x in set_option name uu___1 in - FStar_Getopt.OneArg (g, d) in - (ns, name, arg1) -let (accumulated_option : Prims.string -> option_val -> option_val) = - fun name -> - fun value -> - let prev_values = - let uu___ = lookup_opt name (as_option as_list') in - FStar_Compiler_Util.dflt [] uu___ in - List (value :: prev_values) -let (reverse_accumulated_option : Prims.string -> option_val -> option_val) = - fun name -> - fun value -> - let prev_values = - let uu___ = lookup_opt name (as_option as_list') in - FStar_Compiler_Util.dflt [] uu___ in - List (FStar_Compiler_List.op_At prev_values [value]) -let accumulate_string : - 'uuuuu . Prims.string -> ('uuuuu -> Prims.string) -> 'uuuuu -> unit = - fun name -> - fun post_processor -> - fun value -> - let uu___ = - let uu___1 = let uu___2 = post_processor value in String uu___2 in - accumulated_option name uu___1 in - set_option name uu___ -let (add_extract_module : Prims.string -> unit) = - fun s -> - accumulate_string "extract_module" FStar_Compiler_String.lowercase s -let (add_extract_namespace : Prims.string -> unit) = - fun s -> - accumulate_string "extract_namespace" FStar_Compiler_String.lowercase s -let (add_verify_module : Prims.string -> unit) = - fun s -> - accumulate_string "verify_module" FStar_Compiler_String.lowercase s -exception InvalidArgument of Prims.string -let (uu___is_InvalidArgument : Prims.exn -> Prims.bool) = - fun projectee -> - match projectee with | InvalidArgument uu___ -> true | uu___ -> false -let (__proj__InvalidArgument__item__uu___ : Prims.exn -> Prims.string) = - fun projectee -> match projectee with | InvalidArgument uu___ -> uu___ -let rec (parse_opt_val : - Prims.string -> opt_type -> Prims.string -> option_val) = - fun opt_name -> - fun typ -> - fun str_val -> - try - (fun uu___ -> - match () with - | () -> - (match typ with - | Const c -> c - | IntStr uu___1 -> - let uu___2 = - FStar_Compiler_Util.safe_int_of_string str_val in - (match uu___2 with - | FStar_Pervasives_Native.Some v -> Int v - | FStar_Pervasives_Native.None -> - FStar_Compiler_Effect.raise - (InvalidArgument opt_name)) - | BoolStr -> - let uu___1 = - if str_val = "true" - then true - else - if str_val = "false" - then false - else - FStar_Compiler_Effect.raise - (InvalidArgument opt_name) in - Bool uu___1 - | PathStr uu___1 -> Path str_val - | SimpleStr uu___1 -> String str_val - | EnumStr strs -> - if FStar_Compiler_List.mem str_val strs - then String str_val - else - FStar_Compiler_Effect.raise - (InvalidArgument opt_name) - | OpenEnumStr uu___1 -> String str_val - | PostProcessed (pp, elem_spec) -> - let uu___1 = parse_opt_val opt_name elem_spec str_val in - pp uu___1 - | Accumulated elem_spec -> - let v = parse_opt_val opt_name elem_spec str_val in - accumulated_option opt_name v - | ReverseAccumulated elem_spec -> - let v = parse_opt_val opt_name elem_spec str_val in - reverse_accumulated_option opt_name v - | WithSideEffect (side_effect, elem_spec) -> - (side_effect (); - parse_opt_val opt_name elem_spec str_val))) () - with - | InvalidArgument opt_name1 -> - let uu___1 = - FStar_Compiler_Util.format1 "Invalid argument to --%s" - opt_name1 in - failwith uu___1 -let rec (desc_of_opt_type : - opt_type -> Prims.string FStar_Pervasives_Native.option) = - fun typ -> - let desc_of_enum cases = - FStar_Pervasives_Native.Some (FStar_Compiler_String.concat "|" cases) in - match typ with - | Const c -> FStar_Pervasives_Native.None - | IntStr desc -> FStar_Pervasives_Native.Some desc - | BoolStr -> desc_of_enum ["true"; "false"] - | PathStr desc -> FStar_Pervasives_Native.Some desc - | SimpleStr desc -> FStar_Pervasives_Native.Some desc - | EnumStr strs -> desc_of_enum strs - | OpenEnumStr (strs, desc) -> - desc_of_enum (FStar_Compiler_List.op_At strs [desc]) - | PostProcessed (uu___, elem_spec) -> desc_of_opt_type elem_spec - | Accumulated elem_spec -> desc_of_opt_type elem_spec - | ReverseAccumulated elem_spec -> desc_of_opt_type elem_spec - | WithSideEffect (uu___, elem_spec) -> desc_of_opt_type elem_spec -let (arg_spec_of_opt_type : - Prims.string -> opt_type -> option_val FStar_Getopt.opt_variant) = - fun opt_name -> - fun typ -> - let wrap s = - let uu___ = FStar_Compiler_String.op_Hat s ">" in - FStar_Compiler_String.op_Hat "<" uu___ in - let parser = parse_opt_val opt_name typ in - let uu___ = desc_of_opt_type typ in - match uu___ with - | FStar_Pervasives_Native.None -> - FStar_Getopt.ZeroArgs ((fun uu___1 -> parser "")) - | FStar_Pervasives_Native.Some desc -> - let desc1 = wrap desc in FStar_Getopt.OneArg (parser, desc1) -let (pp_validate_dir : option_val -> option_val) = - fun p -> let pp = as_string p in FStar_Compiler_Util.mkdir false true pp; p -let (pp_lowercase : option_val -> option_val) = - fun s -> - let uu___ = - let uu___1 = as_string s in FStar_Compiler_String.lowercase uu___1 in - String uu___ -let (abort_counter : Prims.int FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref Prims.int_zero -let (interp_quake_arg : Prims.string -> (Prims.int * Prims.int * Prims.bool)) - = - fun s -> - let ios = FStar_Compiler_Util.int_of_string in - match FStar_Compiler_Util.split s "/" with - | f::[] -> - let uu___ = ios f in let uu___1 = ios f in (uu___, uu___1, false) - | f1::f2::[] -> - if f2 = "k" - then - let uu___ = ios f1 in let uu___1 = ios f1 in (uu___, uu___1, true) - else - (let uu___1 = ios f1 in - let uu___2 = ios f2 in (uu___1, uu___2, false)) - | f1::f2::k::[] -> - if k = "k" - then - let uu___ = ios f1 in let uu___1 = ios f2 in (uu___, uu___1, true) - else failwith "unexpected value for --quake" - | uu___ -> failwith "unexpected value for --quake" -let (uu___1 : (((Prims.string -> unit) -> unit) * (Prims.string -> unit))) = - let cb = FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None in - let set1 f = - FStar_Compiler_Effect.op_Colon_Equals cb (FStar_Pervasives_Native.Some f) in - let call msg = - let uu___ = FStar_Compiler_Effect.op_Bang cb in - match uu___ with - | FStar_Pervasives_Native.None -> () - | FStar_Pervasives_Native.Some f -> f msg in - (set1, call) -let (set_option_warning_callback_aux : (Prims.string -> unit) -> unit) = - match uu___1 with - | (set_option_warning_callback_aux1, option_warning_callback) -> - set_option_warning_callback_aux1 -let (option_warning_callback : Prims.string -> unit) = - match uu___1 with - | (set_option_warning_callback_aux1, option_warning_callback1) -> - option_warning_callback1 -let (set_option_warning_callback : (Prims.string -> unit) -> unit) = - fun f -> set_option_warning_callback_aux f -let rec (specs_with_types : - Prims.bool -> - (FStar_BaseTypes.char * Prims.string * opt_type * FStar_Pprint.document) - Prims.list) - = - fun warn_unsafe -> - let text s = - let uu___ = FStar_Pprint.break_ Prims.int_one in - let uu___2 = FStar_Pprint.words s in FStar_Pprint.flow uu___ uu___2 in - let uu___ = - let uu___2 = - text - "Abort on the n-th error or warning raised. Useful in combination with --trace_error. Count starts at 1, use 0 to disable. (default 0)" in - (FStar_Getopt.noshort, "abort_on", - (PostProcessed - ((fun uu___3 -> - match uu___3 with - | Int x -> - (FStar_Compiler_Effect.op_Colon_Equals abort_counter x; - Int x) - | x -> failwith "?"), (IntStr "non-negative integer"))), - uu___2) in - let uu___2 = - let uu___3 = - let uu___4 = text "Admit SMT queries, unsafe! (default 'false')" in - (FStar_Getopt.noshort, "admit_smt_queries", - (WithSideEffect - ((fun uu___5 -> - if warn_unsafe - then option_warning_callback "admit_smt_queries" - else ()), BoolStr)), uu___4) in - let uu___4 = - let uu___5 = - let uu___6 = - text - "Admit all queries, except those with label ( symbol, id))(e.g. --admit_except '(FStar.Fin.pigeonhole, 1)' or --admit_except FStar.Fin.pigeonhole)" in - (FStar_Getopt.noshort, "admit_except", - (WithSideEffect - ((fun uu___7 -> - if warn_unsafe - then option_warning_callback "admit_except" - else ()), (SimpleStr "[symbol|(symbol, id)]"))), uu___6) in - let uu___6 = - let uu___7 = - let uu___8 = - text - "Retain behavior of the tactic engine prior to the introduction of FStar.TypeChecker.Core (0 is most permissive, 2 is least permissive)" in - (FStar_Getopt.noshort, "compat_pre_core", (IntStr "0, 1, 2"), - uu___8) in - let uu___8 = - let uu___9 = - let uu___10 = text "Retain untyped indexed effects implicits" in - (FStar_Getopt.noshort, "compat_pre_typed_indexed_effects", - (Const (Bool true)), uu___10) in - let uu___10 = - let uu___11 = - let uu___12 = - text - "Fail if the SMT guard are produced when the tactic engine re-checks solutions produced by the unifier (default 'false')" in - (FStar_Getopt.noshort, "disallow_unification_guards", - BoolStr, uu___12) in - let uu___12 = - let uu___13 = - let uu___14 = - text - "Expects all modules whose names or namespaces match the provided options to already have valid .checked files in the include path" in - (FStar_Getopt.noshort, "already_cached", - (Accumulated - (SimpleStr - "One or more space-separated occurrences of '[+|-]( * | namespace | module)'")), - uu___14) in - let uu___14 = - let uu___15 = - let uu___16 = - text - "Write a '.checked' file for each module after verification and read from it if present, instead of re-verifying" in - (FStar_Getopt.noshort, "cache_checked_modules", - (Const (Bool true)), uu___16) in - let uu___16 = - let uu___17 = - let uu___18 = - text - "Read and write .checked and .checked.lax in directory dir" in - (FStar_Getopt.noshort, "cache_dir", - (PostProcessed (pp_validate_dir, (PathStr "dir"))), - uu___18) in - let uu___18 = - let uu___19 = - let uu___20 = - text "Do not read or write any .checked files" in - (FStar_Getopt.noshort, "cache_off", - (Const (Bool true)), uu___20) in - let uu___20 = - let uu___21 = - let uu___22 = - text - "Print the version for .checked files and exit." in - (FStar_Getopt.noshort, "print_cache_version", - (Const (Bool true)), uu___22) in - let uu___22 = - let uu___23 = - let uu___24 = - text - "Inline across module interfaces during extraction (aka. cross-module inlining)" in - (FStar_Getopt.noshort, "cmi", - (Const (Bool true)), uu___24) in - let uu___24 = - let uu___25 = - let uu___26 = - text - "Generate code for further compilation to executable code, or build a compiler plugin" in - (FStar_Getopt.noshort, "codegen", - (EnumStr - ["OCaml"; - "FSharp"; - "krml"; - "Plugin"; - "Extension"]), uu___26) in - let uu___26 = - let uu___27 = - let uu___28 = - text - "External runtime library (i.e. M.N.x extracts to M.N.X instead of M_N.x)" in - (FStar_Getopt.noshort, "codegen-lib", - (Accumulated (SimpleStr "namespace")), - uu___28) in - let uu___28 = - let uu___29 = - let uu___30 = - text - "Enable general debugging, i.e. increase verbosity." in - (100, "", - (PostProcessed - ((fun o -> - FStar_Compiler_Debug.enable (); o), - (Const (Bool true)))), uu___30) in - let uu___30 = - let uu___31 = - let uu___32 = - text - "Enable specific debug toggles (comma-separated list of debug keys)" in - (FStar_Getopt.noshort, "debug", - (PostProcessed - ((fun o -> - let keys = - as_comma_string_list o in - FStar_Compiler_Debug.enable_toggles - keys; - o), - (ReverseAccumulated - (SimpleStr "debug toggles")))), - uu___32) in - let uu___32 = - let uu___33 = - let uu___34 = - text - "Enable all debug toggles. WARNING: this will cause a lot of output!" in - (FStar_Getopt.noshort, "debug_all", - (PostProcessed - ((fun o -> - match o with - | Bool (true) -> - (FStar_Compiler_Debug.set_debug_all - (); - o) - | uu___35 -> failwith "?"), - (Const (Bool true)))), uu___34) in - let uu___34 = - let uu___35 = - let uu___36 = - text - "Enable to make the effect of --debug apply to every module processed by the compiler, including dependencies." in - (FStar_Getopt.noshort, - "debug_all_modules", - (Const (Bool true)), uu___36) in - let uu___36 = - let uu___37 = - let uu___38 = - let uu___39 = - text - "Enable several internal sanity checks, useful to track bugs and report issues." in - let uu___40 = - let uu___41 = - let uu___42 = - let uu___43 = - text - "if 'no', no checks are performed" in - let uu___44 = - let uu___45 = - text - "if 'warn', checks are performed and raise a warning when they fail" in - let uu___46 = - let uu___47 = - text - "if 'error, like 'warn', but the compiler raises a hard error instead" in - let uu___48 = - let uu___49 = - text - "if 'abort, like 'warn', but the compiler immediately aborts on an error" in - [uu___49] in - uu___47 :: uu___48 in - uu___45 :: uu___46 in - uu___43 :: uu___44 in - FStar_Errors_Msg.bulleted - uu___42 in - let uu___42 = - text "(default 'no')" in - FStar_Pprint.op_Hat_Slash_Hat - uu___41 uu___42 in - FStar_Pprint.op_Hat_Hat uu___39 - uu___40 in - (FStar_Getopt.noshort, "defensive", - (EnumStr - ["no"; - "warn"; - "error"; - "abort"]), uu___38) in - let uu___38 = - let uu___39 = - let uu___40 = - let uu___41 = - text - "Output the transitive closure of the full dependency graph in three formats:" in - let uu___42 = - let uu___43 = - let uu___44 = - text - "'graph': a format suitable the 'dot' tool from 'GraphViz'" in - let uu___45 = - let uu___46 = - text - "'full': a format suitable for 'make', including dependences for producing .ml and .krml files" in - let uu___47 = - let uu___48 = - text - "'make': (deprecated) a format suitable for 'make', including only dependences among source files" in - [uu___48] in - uu___46 :: uu___47 in - uu___44 :: uu___45 in - FStar_Errors_Msg.bulleted - uu___43 in - FStar_Pprint.op_Hat_Hat uu___41 - uu___42 in - (FStar_Getopt.noshort, "dep", - (EnumStr - ["make"; - "graph"; - "full"; - "raw"]), uu___40) in - let uu___40 = - let uu___41 = - let uu___42 = - text - "Emit a detailed error report by asking the SMT solver many queries; will take longer" in - (FStar_Getopt.noshort, - "detail_errors", - (Const (Bool true)), uu___42) in - let uu___42 = - let uu___43 = - let uu___44 = - text - "Emit a detailed report for proof whose unsat core fails to replay" in - (FStar_Getopt.noshort, - "detail_hint_replay", - (Const (Bool true)), - uu___44) in - let uu___44 = - let uu___45 = - let uu___46 = - text - "Print out this module as it passes through the compiler pipeline" in - (FStar_Getopt.noshort, - "dump_module", - (Accumulated - (SimpleStr - "module_name")), - uu___46) in - let uu___46 = - let uu___47 = - let uu___48 = - text - "Try to solve subtyping constraints at each binder (loses precision but may be slightly more efficient)" in - (FStar_Getopt.noshort, - "eager_subtyping", - (Const (Bool true)), - uu___48) in - let uu___48 = - let uu___49 = - let uu___50 = - text - "Print context information for each error or warning raised (default false)" in - (FStar_Getopt.noshort, - "error_contexts", - BoolStr, uu___50) in - let uu___50 = - let uu___51 = - let uu___52 = - text - "These options are set in extensions option map. Keys are usually namespaces separated by \":\". E.g., 'pulse:verbose=1;my:extension:option=xyz;foo:bar=baz'. These options are typically interpreted by extensions. Any later use of --ext over the same key overrides the old value. An entry 'e' that is not of the form 'a=b' is treated as 'e=1', i.e., 'e' associated with string \"1\"." in - (FStar_Getopt.noshort, - "ext", - (PostProcessed - ((fun o -> - let parse_ext - s = - let exts = - FStar_Compiler_Util.split - s ";" in - FStar_Compiler_List.collect - (fun s1 - -> - match - FStar_Compiler_Util.split - s1 "=" - with - | - k::v::[] - -> - [(k, v)] - | - uu___53 - -> - [ - (s1, "1")]) - exts in - (let uu___54 - = - let uu___55 - = - as_comma_string_list - o in - FStar_Compiler_List.collect - parse_ext - uu___55 in - FStar_Compiler_List.iter - ( - fun - uu___55 - -> - match uu___55 - with - | - (k, v) -> - FStar_Options_Ext.set - k v) - uu___54); - o), - (ReverseAccumulated - (SimpleStr - "extension knobs")))), - uu___52) in - let uu___52 = - let uu___53 = - let uu___54 = - text - "Extract only those modules whose names or namespaces match the provided options. 'TargetName' ranges over {OCaml, krml, FSharp, Plugin, Extension}. A 'ModuleSelector' is a space or comma-separated list of '[+|-]( * | namespace | module)'. For example --extract 'OCaml:A -A.B' --extract 'krml:A -A.C' --extract '*' means for OCaml, extract everything in the A namespace only except A.B; for krml, extract everything in the A namespace only except A.C; for everything else, extract everything. Note, the '+' is optional: --extract '+A' and --extract 'A' mean the same thing. Note also that '--extract A' applies both to a module named 'A' and to any module in the 'A' namespace Multiple uses of this option accumulate, e.g., --extract A --extract B is interpreted as --extract 'A B'." in - (FStar_Getopt.noshort, - "extract", - (Accumulated - (SimpleStr - "One or more semicolon separated occurrences of '[TargetName:]ModuleSelector'")), - uu___54) in - let uu___54 = - let uu___55 = - let uu___56 = - text - "Deprecated: use --extract instead; Only extract the specified modules (instead of the possibly-partial dependency graph)" in - (FStar_Getopt.noshort, - "extract_module", - (Accumulated - (PostProcessed - (pp_lowercase, - (SimpleStr - "module_name")))), - uu___56) in - let uu___56 = - let uu___57 = - let uu___58 = - text - "Deprecated: use --extract instead; Only extract modules in the specified namespace" in - (FStar_Getopt.noshort, - "extract_namespace", - (Accumulated - (PostProcessed - (pp_lowercase, - (SimpleStr - "namespace name")))), - uu___58) in - let uu___58 = - let uu___59 = - let uu___60 = - text - "Explicitly break the abstraction imposed by the interface of any implementation file that appears on the command line (use with care!)" in - (FStar_Getopt.noshort, - "expose_interfaces", - (Const - (Bool - true)), - uu___60) in - let uu___60 = - let uu___61 = - let uu___62 - = - text - "Format of the messages emitted by F* (default `human`)" in - (FStar_Getopt.noshort, - "message_format", - ( - EnumStr - ["human"; - "json"]), - uu___62) in - let uu___62 = - let uu___63 - = - let uu___64 - = - text - "Don't print unification variable numbers" in - (FStar_Getopt.noshort, - "hide_uvar_nums", - (Const - (Bool - true)), - uu___64) in - let uu___64 - = - let uu___65 - = - let uu___66 - = - text - "Read/write hints to dir/module_name.hints (instead of placing hint-file alongside source file)" in - (FStar_Getopt.noshort, - "hint_dir", - (PostProcessed - (pp_validate_dir, - (PathStr - "dir"))), - uu___66) in - let uu___66 - = - let uu___67 - = - let uu___68 - = - text - "Read/write hints to path (instead of module-specific hints files; overrides hint_dir)" in - (FStar_Getopt.noshort, - "hint_file", - (PathStr - "path"), - uu___68) in - let uu___68 - = - let uu___69 - = - let uu___70 - = - text - "Print information regarding hints (deprecated; use --query_stats instead)" in - (FStar_Getopt.noshort, - "hint_info", - (Const - (Bool - true)), - uu___70) in - let uu___70 - = - let uu___71 - = - let uu___72 - = - text - "Legacy interactive mode; reads input from stdin" in - (FStar_Getopt.noshort, - "in", - (Const - (Bool - true)), - uu___72) in - let uu___72 - = - let uu___73 - = - let uu___74 - = - text - "JSON-based interactive mode for IDEs" in - (FStar_Getopt.noshort, - "ide", - (Const - (Bool - true)), - uu___74) in - let uu___74 - = - let uu___75 - = - let uu___76 - = - text - "Disable identifier tables in IDE mode (temporary workaround useful in Steel)" in - (FStar_Getopt.noshort, - "ide_id_info_off", - (Const - (Bool - true)), - uu___76) in - let uu___76 - = - let uu___77 - = - let uu___78 - = - text - "Language Server Protocol-based interactive mode for IDEs" in - (FStar_Getopt.noshort, - "lsp", - (Const - (Bool - true)), - uu___78) in - let uu___78 - = - let uu___79 - = - let uu___80 - = - text - "A directory in which to search for files included on the command line" in - (FStar_Getopt.noshort, - "include", - (ReverseAccumulated - (PathStr - "path")), - uu___80) in - let uu___80 - = - let uu___81 - = - let uu___82 - = - text - "Parses and prettyprints the files included on the command line" in - (FStar_Getopt.noshort, - "print", - (Const - (Bool - true)), - uu___82) in - let uu___82 - = - let uu___83 - = - let uu___84 - = - text - "Parses and prettyprints in place the files included on the command line" in - (FStar_Getopt.noshort, - "print_in_place", - (Const - (Bool - true)), - uu___84) in - let uu___84 - = - let uu___85 - = - let uu___86 - = - text - "Force checking the files given as arguments even if they have valid checked files" in - (102, - "force", - (Const - (Bool - true)), - uu___86) in - let uu___86 - = - let uu___87 - = - let uu___88 - = - text - "Set initial_fuel and max_fuel at once" in - (FStar_Getopt.noshort, - "fuel", - (PostProcessed - ((fun - uu___89 - -> - match uu___89 - with - | - String s - -> - let p f = - let uu___90 - = - FStar_Compiler_Util.int_of_string - f in - Int - uu___90 in - let uu___90 - = - match - FStar_Compiler_Util.split - s "," - with - | - f::[] -> - (f, f) - | - f1::f2::[] - -> - (f1, f2) - | - uu___91 - -> - failwith - "unexpected value for --fuel" in - (match uu___90 - with - | - (min, - max) -> - (( - let uu___92 - = p min in - set_option - "initial_fuel" - uu___92); - (let uu___93 - = p max in - set_option - "max_fuel" - uu___93); - String s)) - | - uu___90 - -> - failwith - "impos"), - (SimpleStr - "non-negative integer or pair of non-negative integers"))), - uu___88) in - let uu___88 - = - let uu___89 - = - let uu___90 - = - text - "Set initial_ifuel and max_ifuel at once" in - (FStar_Getopt.noshort, - "ifuel", - (PostProcessed - ((fun - uu___91 - -> - match uu___91 - with - | - String s - -> - let p f = - let uu___92 - = - FStar_Compiler_Util.int_of_string - f in - Int - uu___92 in - let uu___92 - = - match - FStar_Compiler_Util.split - s "," - with - | - f::[] -> - (f, f) - | - f1::f2::[] - -> - (f1, f2) - | - uu___93 - -> - failwith - "unexpected value for --ifuel" in - (match uu___92 - with - | - (min, - max) -> - (( - let uu___94 - = p min in - set_option - "initial_ifuel" - uu___94); - (let uu___95 - = p max in - set_option - "max_ifuel" - uu___95); - String s)) - | - uu___92 - -> - failwith - "impos"), - (SimpleStr - "non-negative integer or pair of non-negative integers"))), - uu___90) in - let uu___90 - = - let uu___91 - = - let uu___92 - = - text - "Number of unrolling of recursive functions to try initially (default 2)" in - (FStar_Getopt.noshort, - "initial_fuel", - (IntStr - "non-negative integer"), - uu___92) in - let uu___92 - = - let uu___93 - = - let uu___94 - = - text - "Number of unrolling of inductive datatypes to try at first (default 1)" in - (FStar_Getopt.noshort, - "initial_ifuel", - (IntStr - "non-negative integer"), - uu___94) in - let uu___94 - = - let uu___95 - = - let uu___96 - = - text - "Retain comments in the logged SMT queries (requires --log_queries or --log_failing_queries; default true)" in - (FStar_Getopt.noshort, - "keep_query_captions", - BoolStr, - uu___96) in - let uu___96 - = - let uu___97 - = - let uu___98 - = - text - "Run the lax-type checker only (admit all verification conditions)" in - (FStar_Getopt.noshort, - "lax", - (WithSideEffect - ((fun - uu___99 - -> - if - warn_unsafe - then - option_warning_callback - "lax" - else ()), - (Const - (Bool - true)))), - uu___98) in - let uu___98 - = - let uu___99 - = - let uu___100 - = - text - "Load OCaml module, compiling it if necessary" in - (FStar_Getopt.noshort, - "load", - (ReverseAccumulated - (PathStr - "module")), - uu___100) in - let uu___100 - = - let uu___101 - = - let uu___102 - = - text - "Load compiled module, fails hard if the module is not already compiled" in - (FStar_Getopt.noshort, - "load_cmxs", - (ReverseAccumulated - (PathStr - "module")), - uu___102) in - let uu___102 - = - let uu___103 - = - let uu___104 - = - text - "Print types computed for data/val/let-bindings" in - (FStar_Getopt.noshort, - "log_types", - (Const - (Bool - true)), - uu___104) in - let uu___104 - = - let uu___105 - = - let uu___106 - = - text - "Log the Z3 queries in several queries-*.smt2 files, as we go" in - (FStar_Getopt.noshort, - "log_queries", - (Const - (Bool - true)), - uu___106) in - let uu___106 - = - let uu___107 - = - let uu___108 - = - text - "As --log_queries, but only save the failing queries. Each query is\n saved in its own file regardless of whether they were checked during the\n same invocation. The SMT2 file names begin with \"failedQueries\"" in - (FStar_Getopt.noshort, - "log_failing_queries", - (Const - (Bool - true)), - uu___108) in - let uu___108 - = - let uu___109 - = - let uu___110 - = - text - "Number of unrolling of recursive functions to try at most (default 8)" in - (FStar_Getopt.noshort, - "max_fuel", - (IntStr - "non-negative integer"), - uu___110) in - let uu___110 - = - let uu___111 - = - let uu___112 - = - text - "Number of unrolling of inductive datatypes to try at most (default 2)" in - (FStar_Getopt.noshort, - "max_ifuel", - (IntStr - "non-negative integer"), - uu___112) in - let uu___112 - = - let uu___113 - = - let uu___114 - = - text - "Trigger various specializations for compiling the F* compiler itself (not meant for user code)" in - (FStar_Getopt.noshort, - "MLish", - (Const - (Bool - true)), - uu___114) in - let uu___114 - = - let uu___115 - = - let uu___116 - = - text - "Set the default effect *module* for --MLish (default: FStar.Compiler.Effect)" in - (FStar_Getopt.noshort, - "MLish_effect", - (SimpleStr - "module_name"), - uu___116) in - let uu___116 - = - let uu___117 - = - let uu___118 - = - text - "Ignore the default module search paths" in - (FStar_Getopt.noshort, - "no_default_includes", - (Const - (Bool - true)), - uu___118) in - let uu___118 - = - let uu___119 - = - let uu___120 - = - text - "Deprecated: use --extract instead; Do not extract code from this module" in - (FStar_Getopt.noshort, - "no_extract", - (Accumulated - (PathStr - "module name")), - uu___120) in - let uu___120 - = - let uu___121 - = - let uu___122 - = - text - "Suppress location information in the generated OCaml output (only relevant with --codegen OCaml)" in - (FStar_Getopt.noshort, - "no_location_info", - (Const - (Bool - true)), - uu___122) in - let uu___122 - = - let uu___123 - = - let uu___124 - = - text - "Do not send any queries to the SMT solver, and fail on them instead" in - (FStar_Getopt.noshort, - "no_smt", - (Const - (Bool - true)), - uu___124) in - let uu___124 - = - let uu___125 - = - let uu___126 - = - text - "Extract top-level pure terms after normalizing them. This can lead to very large code, but can result in more partial evaluation and compile-time specialization." in - (FStar_Getopt.noshort, - "normalize_pure_terms_for_extraction", - (Const - (Bool - true)), - uu___126) in - let uu___126 - = - let uu___127 - = - let uu___128 - = - text - "Place KaRaMeL extraction output in file . The path can be relative or absolute and does not dependon the --odir option." in - (FStar_Getopt.noshort, - "krmloutput", - (PathStr - "filename"), - uu___128) in - let uu___128 - = - let uu___129 - = - let uu___130 - = - text - "Place output in directory dir" in - (FStar_Getopt.noshort, - "odir", - (PostProcessed - (pp_validate_dir, - (PathStr - "dir"))), - uu___130) in - let uu___130 - = - let uu___131 - = - let uu___132 - = - text - "Output the result of --dep into this file instead of to standard output." in - (FStar_Getopt.noshort, - "output_deps_to", - (PathStr - "file"), - uu___132) in - let uu___132 - = - let uu___133 - = - let uu___134 - = - text - "Use a custom Prims.fst file. Do not use if you do not know exactly what you're doing." in - (FStar_Getopt.noshort, - "prims", - (PathStr - "file"), - uu___134) in - let uu___134 - = - let uu___135 - = - let uu___136 - = - text - "Print the types of bound variables" in - (FStar_Getopt.noshort, - "print_bound_var_types", - (Const - (Bool - true)), - uu___136) in - let uu___136 - = - let uu___137 - = - let uu___138 - = - text - "Print inferred predicate transformers for all computation types" in - (FStar_Getopt.noshort, - "print_effect_args", - (Const - (Bool - true)), - uu___138) in - let uu___138 - = - let uu___139 - = - let uu___140 - = - text - "Print the errors generated by declarations marked with expect_failure, useful for debugging error locations" in - (FStar_Getopt.noshort, - "print_expected_failures", - (Const - (Bool - true)), - uu___140) in - let uu___140 - = - let uu___141 - = - let uu___142 - = - text - "Print full names of variables" in - (FStar_Getopt.noshort, - "print_full_names", - (Const - (Bool - true)), - uu___142) in - let uu___142 - = - let uu___143 - = - let uu___144 - = - text - "Print implicit arguments" in - (FStar_Getopt.noshort, - "print_implicits", - (Const - (Bool - true)), - uu___144) in - let uu___144 - = - let uu___145 - = - let uu___146 - = - text - "Print universes" in - (FStar_Getopt.noshort, - "print_universes", - (Const - (Bool - true)), - uu___146) in - let uu___146 - = - let uu___147 - = - let uu___148 - = - text - "Print Z3 statistics for each SMT query (details such as relevant modules, facts, etc. for each proof)" in - (FStar_Getopt.noshort, - "print_z3_statistics", - (Const - (Bool - true)), - uu___148) in - let uu___148 - = - let uu___149 - = - let uu___150 - = - text - "Print full names (deprecated; use --print_full_names instead)" in - (FStar_Getopt.noshort, - "prn", - (Const - (Bool - true)), - uu___150) in - let uu___150 - = - let uu___151 - = - let uu___152 - = - text - "Proof recovery mode: before failing an SMT query, retry 3 times, increasing rlimits. If the query goes through after retrying, verification will succeed, but a warning will be emitted. This feature is useful to restore a project after some change to its libraries or F* upgrade. Importantly, then, this option cannot be used in a pragma (#set-options, etc)." in - (FStar_Getopt.noshort, - "proof_recovery", - (Const - (Bool - true)), - uu___152) in - let uu___152 - = - let uu___153 - = - let uu___154 - = - let uu___155 - = - text - "Repeats SMT queries to check for robustness" in - let uu___156 - = - let uu___157 - = - let uu___158 - = - let uu___159 - = - text - "--quake N/M repeats each query checks that it succeeds at least N out of M times, aborting early if possible" in - let uu___160 - = - let uu___161 - = - text - "--quake N/M/k works as above, except it will unconditionally run M times" in - let uu___162 - = - let uu___163 - = - text - "--quake N is an alias for --quake N/N" in - let uu___164 - = - let uu___165 - = - text - "--quake N/k is an alias for --quake N/N/k" in - [uu___165] in - uu___163 - :: - uu___164 in - uu___161 - :: - uu___162 in - uu___159 - :: - uu___160 in - FStar_Errors_Msg.bulleted - uu___158 in - let uu___158 - = - text - "Using --quake disables --retry. When quake testing, queries are not splitted for error reporting unless '--split_queries always' is given. Queries from the smt_sync tactic are not quake-tested." in - FStar_Pprint.op_Hat_Hat - uu___157 - uu___158 in - FStar_Pprint.op_Hat_Hat - uu___155 - uu___156 in - (FStar_Getopt.noshort, - "quake", - (PostProcessed - ((fun - uu___155 - -> - match uu___155 - with - | - String s - -> - let uu___156 - = - interp_quake_arg - s in - (match uu___156 - with - | - (min, - max, k) - -> - (set_option - "quake_lo" - (Int min); - set_option - "quake_hi" - (Int max); - set_option - "quake_keep" - (Bool k); - set_option - "retry" - (Bool - false); - String s)) - | - uu___156 - -> - failwith - "impos"), - (SimpleStr - "positive integer or pair of positive integers"))), - uu___154) in - let uu___154 - = - let uu___155 - = - let uu___156 - = - text - "Keep a running cache of SMT queries to make verification faster. Only available in the interactive mode. NOTE: This feature is experimental and potentially unsound! Hence why\n it is not allowed in batch mode (where it is also less useful). If you\n find a query that is mistakenly accepted with the cache, please\n report a bug to the F* issue tracker on GitHub." in - (FStar_Getopt.noshort, - "query_cache", - (Const - (Bool - true)), - uu___156) in - let uu___156 - = - let uu___157 - = - let uu___158 - = - text - "Print SMT query statistics" in - (FStar_Getopt.noshort, - "query_stats", - (Const - (Bool - true)), - uu___158) in - let uu___158 - = - let uu___159 - = - let uu___160 - = - text - "Read a checked file and dump it to standard output." in - (FStar_Getopt.noshort, - "read_checked_file", - (PathStr - "path"), - uu___160) in - let uu___160 - = - let uu___161 - = - let uu___162 - = - text - "Read a Karamel binary file and dump it to standard output." in - (FStar_Getopt.noshort, - "read_krml_file", - (PathStr - "path"), - uu___162) in - let uu___162 - = - let uu___163 - = - let uu___164 - = - text - "Record a database of hints for efficient proof replay" in - (FStar_Getopt.noshort, - "record_hints", - (Const - (Bool - true)), - uu___164) in - let uu___164 - = - let uu___165 - = - let uu___166 - = - text - "Record the state of options used to check each sigelt, useful for the `check_with` attribute and metaprogramming. Note that this implies a performance hit and increases the size of checked files." in - (FStar_Getopt.noshort, - "record_options", - (Const - (Bool - true)), - uu___166) in - let uu___166 - = - let uu___167 - = - let uu___168 - = - text - "Retry each SMT query N times and succeed on the first try. Using --retry disables --quake." in - (FStar_Getopt.noshort, - "retry", - (PostProcessed - ((fun - uu___169 - -> - match uu___169 - with - | - Int i -> - (set_option - "quake_lo" - (Int - Prims.int_one); - set_option - "quake_hi" - (Int i); - set_option - "quake_keep" - (Bool - false); - set_option - "retry" - (Bool - true); - Bool true) - | - uu___170 - -> - failwith - "impos"), - (IntStr - "positive integer"))), - uu___168) in - let uu___168 - = - let uu___169 - = - let uu___170 - = - text - "Optimistically, attempt using the recorded hint for toplevel_name (a top-level name in the current module) when trying to verify some other term 'g'" in - (FStar_Getopt.noshort, - "reuse_hint_for", - (SimpleStr - "toplevel_name"), - uu___170) in - let uu___170 - = - let uu___171 - = - let uu___172 - = - text - "Report every use of an escape hatch, include assume, admit, etc." in - (FStar_Getopt.noshort, - "report_assumes", - (EnumStr - ["warn"; - "error"]), - uu___172) in - let uu___172 - = - let uu___173 - = - let uu___174 - = - text - "Disable all non-critical output" in - (FStar_Getopt.noshort, - "silent", - (Const - (Bool - true)), - uu___174) in - let uu___174 - = - let uu___175 - = - let uu___176 - = - text - "Path to the Z3 SMT solver (we could eventually support other solvers)" in - (FStar_Getopt.noshort, - "smt", - (PathStr - "path"), - uu___176) in - let uu___176 - = - let uu___177 - = - let uu___178 - = - text - "Toggle a peephole optimization that eliminates redundant uses of boxing/unboxing in the SMT encoding (default 'false')" in - (FStar_Getopt.noshort, - "smtencoding.elim_box", - BoolStr, - uu___178) in - let uu___178 - = - let uu___179 - = - let uu___180 - = - let uu___181 - = - text - "Control the representation of non-linear arithmetic functions in the SMT encoding:" in - let uu___182 - = - let uu___183 - = - let uu___184 - = - let uu___185 - = - text - "if 'boxwrap' use 'Prims.op_Multiply, Prims.op_Division, Prims.op_Modulus'" in - let uu___186 - = - let uu___187 - = - text - "if 'native' use '*, div, mod'" in - let uu___188 - = - let uu___189 - = - text - "if 'wrapped' use '_mul, _div, _mod : Int*Int -> Int'" in - [uu___189] in - uu___187 - :: - uu___188 in - uu___185 - :: - uu___186 in - FStar_Errors_Msg.bulleted - uu___184 in - let uu___184 - = - text - "(default 'boxwrap')" in - FStar_Pprint.op_Hat_Hat - uu___183 - uu___184 in - FStar_Pprint.op_Hat_Hat - uu___181 - uu___182 in - (FStar_Getopt.noshort, - "smtencoding.nl_arith_repr", - (EnumStr - ["native"; - "wrapped"; - "boxwrap"]), - uu___180) in - let uu___180 - = - let uu___181 - = - let uu___182 - = - let uu___183 - = - text - "Toggle the representation of linear arithmetic functions in the SMT encoding:" in - let uu___184 - = - let uu___185 - = - let uu___186 - = - let uu___187 - = - text - "if 'boxwrap', use 'Prims.op_Addition, Prims.op_Subtraction, Prims.op_Minus'" in - let uu___188 - = - let uu___189 - = - text - "if 'native', use '+, -, -'" in - [uu___189] in - uu___187 - :: - uu___188 in - FStar_Errors_Msg.bulleted - uu___186 in - let uu___186 - = - text - "(default 'boxwrap')" in - FStar_Pprint.op_Hat_Hat - uu___185 - uu___186 in - FStar_Pprint.op_Hat_Hat - uu___183 - uu___184 in - (FStar_Getopt.noshort, - "smtencoding.l_arith_repr", - (EnumStr - ["native"; - "boxwrap"]), - uu___182) in - let uu___182 - = - let uu___183 - = - let uu___184 - = - text - "Include an axiom in the SMT encoding to introduce proof-irrelevance from a constructive proof" in - (FStar_Getopt.noshort, - "smtencoding.valid_intro", - BoolStr, - uu___184) in - let uu___184 - = - let uu___185 - = - let uu___186 - = - text - "Include an axiom in the SMT encoding to eliminate proof-irrelevance into the existence of a proof witness" in - (FStar_Getopt.noshort, - "smtencoding.valid_elim", - BoolStr, - uu___186) in - let uu___186 - = - let uu___187 - = - let uu___188 - = - let uu___189 - = - text - "Split SMT verification conditions into several separate queries, one per goal. Helps with localizing errors." in - let uu___190 - = - let uu___191 - = - let uu___192 - = - text - "Use 'no' to disable (this may reduce the quality of error messages)." in - let uu___193 - = - let uu___194 - = - text - "Use 'on_failure' to split queries and retry when discharging fails (the default)" in - let uu___195 - = - let uu___196 - = - text - "Use 'yes' to always split." in - [uu___196] in - uu___194 - :: - uu___195 in - uu___192 - :: - uu___193 in - FStar_Errors_Msg.bulleted - uu___191 in - FStar_Pprint.op_Hat_Hat - uu___189 - uu___190 in - (FStar_Getopt.noshort, - "split_queries", - (EnumStr - ["no"; - "on_failure"; - "always"]), - uu___188) in - let uu___188 - = - let uu___189 - = - let uu___190 - = - text - "Do not use the lexical scope of tactics to improve binder names" in - (FStar_Getopt.noshort, - "tactic_raw_binders", - (Const - (Bool - true)), - uu___190) in - let uu___190 - = - let uu___191 - = - let uu___192 - = - text - "Do not recover from metaprogramming errors, and abort if one occurs" in - (FStar_Getopt.noshort, - "tactics_failhard", - (Const - (Bool - true)), - uu___192) in - let uu___192 - = - let uu___193 - = - let uu___194 - = - text - "Print some rough information on tactics, such as the time they take to run" in - (FStar_Getopt.noshort, - "tactics_info", - (Const - (Bool - true)), - uu___194) in - let uu___194 - = - let uu___195 - = - let uu___196 - = - text - "Print a depth-indexed trace of tactic execution (Warning: very verbose)" in - (FStar_Getopt.noshort, - "tactic_trace", - (Const - (Bool - true)), - uu___196) in - let uu___196 - = - let uu___197 - = - let uu___198 - = - text - "Trace tactics up to a certain binding depth" in - (FStar_Getopt.noshort, - "tactic_trace_d", - (IntStr - "positive_integer"), - uu___198) in - let uu___198 - = - let uu___199 - = - let uu___200 - = - text - "Use NBE to evaluate metaprograms (experimental)" in - (FStar_Getopt.noshort, - "__tactics_nbe", - (Const - (Bool - true)), - uu___200) in - let uu___200 - = - let uu___201 - = - let uu___202 - = - text - "Attempt to normalize definitions marked as tcnorm (default 'true')" in - (FStar_Getopt.noshort, - "tcnorm", - BoolStr, - uu___202) in - let uu___202 - = - let uu___203 - = - let uu___204 - = - text - "Print the time it takes to verify each top-level definition. This is just an alias for an invocation of the profiler, so it may not work well if combined with --profile. In particular, it implies --profile_group_by_decl." in - (FStar_Getopt.noshort, - "timing", - (Const - (Bool - true)), - uu___204) in - let uu___204 - = - let uu___205 - = - let uu___206 - = - text - "Attach stack traces on errors" in - (FStar_Getopt.noshort, - "trace_error", - (Const - (Bool - true)), - uu___206) in - let uu___206 - = - let uu___207 - = - let uu___208 - = - text - "Emit output formatted for debugging" in - (FStar_Getopt.noshort, - "ugly", - (Const - (Bool - true)), - uu___208) in - let uu___208 - = - let uu___209 - = - let uu___210 - = - text - "Let the SMT solver unfold inductive types to arbitrary depths (may affect verifier performance)" in - (FStar_Getopt.noshort, - "unthrottle_inductives", - (Const - (Bool - true)), - uu___210) in - let uu___210 - = - let uu___211 - = - let uu___212 - = - text - "Allow tactics to run external processes. WARNING: checking an untrusted F* file while using this option can have disastrous effects." in - (FStar_Getopt.noshort, - "unsafe_tactic_exec", - (Const - (Bool - true)), - uu___212) in - let uu___212 - = - let uu___213 - = - let uu___214 - = - text - "Use equality constraints when comparing higher-order types (Temporary)" in - (FStar_Getopt.noshort, - "use_eq_at_higher_order", - (Const - (Bool - true)), - uu___214) in - let uu___214 - = - let uu___215 - = - let uu___216 - = - text - "Use a previously recorded hints database for proof replay" in - (FStar_Getopt.noshort, - "use_hints", - (Const - (Bool - true)), - uu___216) in - let uu___216 - = - let uu___217 - = - let uu___218 - = - text - "Admit queries if their hash matches the hash recorded in the hints database" in - (FStar_Getopt.noshort, - "use_hint_hashes", - (Const - (Bool - true)), - uu___218) in - let uu___218 - = - let uu___219 - = - let uu___220 - = - text - "Use compiled tactics from path" in - (FStar_Getopt.noshort, - "use_native_tactics", - (PathStr - "path"), - uu___220) in - let uu___220 - = - let uu___221 - = - let uu___222 - = - text - "Do not run plugins natively and interpret them as usual instead" in - (FStar_Getopt.noshort, - "no_plugins", - (Const - (Bool - true)), - uu___222) in - let uu___222 - = - let uu___223 - = - let uu___224 - = - text - "Do not run the tactic engine before discharging a VC" in - (FStar_Getopt.noshort, - "no_tactics", - (Const - (Bool - true)), - uu___224) in - let uu___224 - = - let uu___225 - = - let uu___226 - = - text - "Prunes the context to include only the facts from the given namespace or fact id. Facts can be include or excluded using the [+|-] qualifier. For example --using_facts_from '* -FStar.Reflection +FStar.Compiler.List -FStar.Compiler.List.Tot' will remove all facts from FStar.Compiler.List.Tot.*, retain all remaining facts from FStar.Compiler.List.*, remove all facts from FStar.Reflection.*, and retain all the rest. Note, the '+' is optional: --using_facts_from 'FStar.Compiler.List' is equivalent to --using_facts_from '+FStar.Compiler.List'. Multiple uses of this option accumulate, e.g., --using_facts_from A --using_facts_from B is interpreted as --using_facts_from A^B." in - (FStar_Getopt.noshort, - "using_facts_from", - (ReverseAccumulated - (SimpleStr - "One or more space-separated occurrences of '[+|-]( * | namespace | fact id)'")), - uu___226) in - let uu___226 - = - let uu___227 - = - let uu___228 - = - text - "This does nothing and will be removed" in - (FStar_Getopt.noshort, - "__temp_fast_implicits", - (Const - (Bool - true)), - uu___228) in - let uu___228 - = - let uu___229 - = - let uu___230 - = - text - "Display version number" in - (118, - "version", - (WithSideEffect - ((fun - uu___231 - -> - display_version - (); - FStar_Compiler_Effect.exit - Prims.int_zero), - (Const - (Bool - true)))), - uu___230) in - let uu___230 - = - let uu___231 - = - let uu___232 - = - text - "Warn when (a -> b) is desugared to (a -> Tot b)" in - (FStar_Getopt.noshort, - "warn_default_effects", - (Const - (Bool - true)), - uu___232) in - let uu___232 - = - let uu___233 - = - let uu___234 - = - text - "Z3 command line options" in - (FStar_Getopt.noshort, - "z3cliopt", - (ReverseAccumulated - (SimpleStr - "option")), - uu___234) in - let uu___234 - = - let uu___235 - = - let uu___236 - = - text - "Z3 options in smt2 format" in - (FStar_Getopt.noshort, - "z3smtopt", - (ReverseAccumulated - (SimpleStr - "option")), - uu___236) in - let uu___236 - = - let uu___237 - = - let uu___238 - = - text - "Restart Z3 after each query; useful for ensuring proof robustness" in - (FStar_Getopt.noshort, - "z3refresh", - (Const - (Bool - true)), - uu___238) in - let uu___238 - = - let uu___239 - = - let uu___240 - = - text - "Set the Z3 per-query resource limit (default 5 units, taking roughtly 5s)" in - (FStar_Getopt.noshort, - "z3rlimit", - (IntStr - "positive_integer"), - uu___240) in - let uu___240 - = - let uu___241 - = - let uu___242 - = - text - "Set the Z3 per-query resource limit multiplier. This is useful when, say, regenerating hints and you want to be more lax. (default 1)" in - (FStar_Getopt.noshort, - "z3rlimit_factor", - (IntStr - "positive_integer"), - uu___242) in - let uu___242 - = - let uu___243 - = - let uu___244 - = - text - "Set the Z3 random seed (default 0)" in - (FStar_Getopt.noshort, - "z3seed", - (IntStr - "positive_integer"), - uu___244) in - let uu___244 - = - let uu___245 - = - let uu___246 - = - text - "Set the version of Z3 that is to be used. Default: 4.8.5" in - (FStar_Getopt.noshort, - "z3version", - (SimpleStr - "version"), - uu___246) in - let uu___246 - = - let uu___247 - = - let uu___248 - = - text - "Don't check positivity of inductive types" in - (FStar_Getopt.noshort, - "__no_positivity", - (WithSideEffect - ((fun - uu___249 - -> - if - warn_unsafe - then - option_warning_callback - "__no_positivity" - else ()), - (Const - (Bool - true)))), - uu___248) in - let uu___248 - = - let uu___249 - = - let uu___250 - = - let uu___251 - = - text - "The [-warn_error] option follows the OCaml syntax, namely:" in - let uu___252 - = - let uu___253 - = - let uu___254 - = - text - "[r] is a range of warnings (either a number [n], or a range [n..n])" in - let uu___255 - = - let uu___256 - = - text - "[-r] silences range [r]" in - let uu___257 - = - let uu___258 - = - text - "[+r] enables range [r] as warnings (NOTE: \"enabling\" an error will downgrade it to a warning)" in - let uu___259 - = - let uu___260 - = - text - "[@r] makes range [r] fatal." in - [uu___260] in - uu___258 - :: - uu___259 in - uu___256 - :: - uu___257 in - uu___254 - :: - uu___255 in - FStar_Errors_Msg.bulleted - uu___253 in - FStar_Pprint.op_Hat_Hat - uu___251 - uu___252 in - (FStar_Getopt.noshort, - "warn_error", - (ReverseAccumulated - (SimpleStr - "")), - uu___250) in - let uu___250 - = - let uu___251 - = - let uu___252 - = - text - "Use normalization by evaluation as the default normalization strategy (default 'false')" in - (FStar_Getopt.noshort, - "use_nbe", - BoolStr, - uu___252) in - let uu___252 - = - let uu___253 - = - let uu___254 - = - text - "Use normalization by evaluation for normalizing terms before extraction (default 'false')" in - (FStar_Getopt.noshort, - "use_nbe_for_extraction", - BoolStr, - uu___254) in - let uu___254 - = - let uu___255 - = - let uu___256 - = - text - "Enforce trivial preconditions for unannotated effectful functions (default 'true')" in - (FStar_Getopt.noshort, - "trivial_pre_for_unannotated_effectful_fns", - BoolStr, - uu___256) in - let uu___256 - = - let uu___257 - = - let uu___258 - = - text - "Debug messages for embeddings/unembeddings of natively compiled terms" in - (FStar_Getopt.noshort, - "__debug_embedding", - (WithSideEffect - ((fun - uu___259 - -> - FStar_Compiler_Effect.op_Colon_Equals - debug_embedding - true), - (Const - (Bool - true)))), - uu___258) in - let uu___258 - = - let uu___259 - = - let uu___260 - = - text - "Eagerly embed and unembed terms to primitive operations and plugins: not recommended except for benchmarking" in - (FStar_Getopt.noshort, - "eager_embedding", - (WithSideEffect - ((fun - uu___261 - -> - FStar_Compiler_Effect.op_Colon_Equals - eager_embedding - true), - (Const - (Bool - true)))), - uu___260) in - let uu___260 - = - let uu___261 - = - let uu___262 - = - text - "Emit profiles grouped by declaration rather than by module" in - (FStar_Getopt.noshort, - "profile_group_by_decl", - (Const - (Bool - true)), - uu___262) in - let uu___262 - = - let uu___263 - = - let uu___264 - = - text - "Specific source locations in the compiler are instrumented with profiling counters. Pass `--profile_component FStar.TypeChecker` to enable all counters in the FStar.TypeChecker namespace. This option is a module or namespace selector, like many other options (e.g., `--extract`)" in - (FStar_Getopt.noshort, - "profile_component", - (Accumulated - (SimpleStr - "One or more space-separated occurrences of '[+|-]( * | namespace | module | identifier)'")), - uu___264) in - let uu___264 - = - let uu___265 - = - let uu___266 - = - text - "Profiling can be enabled when the compiler is processing a given set of source modules. Pass `--profile FStar.Pervasives` to enable profiling when the compiler is processing any module in FStar.Pervasives. This option is a module or namespace selector, like many other options (e.g., `--extract`)" in - (FStar_Getopt.noshort, - "profile", - (Accumulated - (SimpleStr - "One or more space-separated occurrences of '[+|-]( * | namespace | module)'")), - uu___266) in - let uu___266 - = - let uu___267 - = - let uu___268 - = - text - "Display this information" in - (104, - "help", - (WithSideEffect - ((fun - uu___269 - -> - ( - let uu___271 - = - specs - warn_unsafe in - display_usage_aux - uu___271); - FStar_Compiler_Effect.exit - Prims.int_zero), - (Const - (Bool - true)))), - uu___268) in - let uu___268 - = - let uu___269 - = - let uu___270 - = - text - "List all debug keys and exit" in - (FStar_Getopt.noshort, - "list_debug_keys", - (WithSideEffect - ((fun - uu___271 - -> - display_debug_keys - (); - FStar_Compiler_Effect.exit - Prims.int_zero), - (Const - (Bool - true)))), - uu___270) in - let uu___270 - = - let uu___271 - = - let uu___272 - = - text - "List all registered plugins and exit" in - (FStar_Getopt.noshort, - "list_plugins", - (Const - (Bool - true)), - uu___272) in - let uu___272 - = - let uu___273 - = - let uu___274 - = - text - "Print the root of the F* installation and exit" in - (FStar_Getopt.noshort, - "locate", - (Const - (Bool - true)), - uu___274) in - let uu___274 - = - let uu___275 - = - let uu___276 - = - text - "Print the root of the F* library and exit" in - (FStar_Getopt.noshort, - "locate_lib", - (Const - (Bool - true)), - uu___276) in - let uu___276 - = - let uu___277 - = - let uu___278 - = - text - "Print the root of the built OCaml F* library and exit" in - (FStar_Getopt.noshort, - "locate_ocaml", - (Const - (Bool - true)), - uu___278) in - [uu___277] in - uu___275 - :: - uu___276 in - uu___273 - :: - uu___274 in - uu___271 - :: - uu___272 in - uu___269 - :: - uu___270 in - uu___267 - :: - uu___268 in - uu___265 - :: - uu___266 in - uu___263 - :: - uu___264 in - uu___261 - :: - uu___262 in - uu___259 - :: - uu___260 in - uu___257 - :: - uu___258 in - uu___255 - :: - uu___256 in - uu___253 - :: - uu___254 in - uu___251 - :: - uu___252 in - uu___249 - :: - uu___250 in - uu___247 - :: - uu___248 in - uu___245 - :: - uu___246 in - uu___243 - :: - uu___244 in - uu___241 - :: - uu___242 in - uu___239 - :: - uu___240 in - uu___237 - :: - uu___238 in - uu___235 - :: - uu___236 in - uu___233 - :: - uu___234 in - uu___231 - :: - uu___232 in - uu___229 - :: - uu___230 in - uu___227 - :: - uu___228 in - uu___225 - :: - uu___226 in - uu___223 - :: - uu___224 in - uu___221 - :: - uu___222 in - uu___219 - :: - uu___220 in - uu___217 - :: - uu___218 in - uu___215 - :: - uu___216 in - uu___213 - :: - uu___214 in - uu___211 - :: - uu___212 in - uu___209 - :: - uu___210 in - uu___207 - :: - uu___208 in - uu___205 - :: - uu___206 in - uu___203 - :: - uu___204 in - uu___201 - :: - uu___202 in - uu___199 - :: - uu___200 in - uu___197 - :: - uu___198 in - uu___195 - :: - uu___196 in - uu___193 - :: - uu___194 in - uu___191 - :: - uu___192 in - uu___189 - :: - uu___190 in - uu___187 - :: - uu___188 in - uu___185 - :: - uu___186 in - uu___183 - :: - uu___184 in - uu___181 - :: - uu___182 in - uu___179 - :: - uu___180 in - uu___177 - :: - uu___178 in - uu___175 - :: - uu___176 in - uu___173 - :: - uu___174 in - uu___171 - :: - uu___172 in - uu___169 - :: - uu___170 in - uu___167 - :: - uu___168 in - uu___165 - :: - uu___166 in - uu___163 - :: - uu___164 in - uu___161 - :: - uu___162 in - uu___159 - :: - uu___160 in - uu___157 - :: - uu___158 in - uu___155 - :: - uu___156 in - uu___153 - :: - uu___154 in - uu___151 - :: - uu___152 in - uu___149 - :: - uu___150 in - uu___147 - :: - uu___148 in - uu___145 - :: - uu___146 in - uu___143 - :: - uu___144 in - uu___141 - :: - uu___142 in - uu___139 - :: - uu___140 in - uu___137 - :: - uu___138 in - uu___135 - :: - uu___136 in - uu___133 - :: - uu___134 in - uu___131 - :: - uu___132 in - uu___129 - :: - uu___130 in - uu___127 - :: - uu___128 in - uu___125 - :: - uu___126 in - uu___123 - :: - uu___124 in - uu___121 - :: - uu___122 in - uu___119 - :: - uu___120 in - uu___117 - :: - uu___118 in - uu___115 - :: - uu___116 in - uu___113 - :: - uu___114 in - uu___111 - :: - uu___112 in - uu___109 - :: - uu___110 in - uu___107 - :: - uu___108 in - uu___105 - :: - uu___106 in - uu___103 - :: - uu___104 in - uu___101 - :: - uu___102 in - uu___99 - :: - uu___100 in - uu___97 - :: - uu___98 in - uu___95 - :: - uu___96 in - uu___93 - :: - uu___94 in - uu___91 - :: - uu___92 in - uu___89 - :: - uu___90 in - uu___87 - :: - uu___88 in - uu___85 - :: - uu___86 in - uu___83 - :: - uu___84 in - uu___81 - :: - uu___82 in - uu___79 - :: - uu___80 in - uu___77 - :: - uu___78 in - uu___75 - :: - uu___76 in - uu___73 - :: - uu___74 in - uu___71 - :: - uu___72 in - uu___69 - :: - uu___70 in - uu___67 - :: - uu___68 in - uu___65 - :: - uu___66 in - uu___63 :: - uu___64 in - uu___61 :: - uu___62 in - uu___59 :: - uu___60 in - uu___57 :: - uu___58 in - uu___55 :: uu___56 in - uu___53 :: uu___54 in - uu___51 :: uu___52 in - uu___49 :: uu___50 in - uu___47 :: uu___48 in - uu___45 :: uu___46 in - uu___43 :: uu___44 in - uu___41 :: uu___42 in - uu___39 :: uu___40 in - uu___37 :: uu___38 in - uu___35 :: uu___36 in - uu___33 :: uu___34 in - uu___31 :: uu___32 in - uu___29 :: uu___30 in - uu___27 :: uu___28 in - uu___25 :: uu___26 in - uu___23 :: uu___24 in - uu___21 :: uu___22 in - uu___19 :: uu___20 in - uu___17 :: uu___18 in - uu___15 :: uu___16 in - uu___13 :: uu___14 in - uu___11 :: uu___12 in - uu___9 :: uu___10 in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___ :: uu___2 -and (specs : - Prims.bool -> (FStar_Getopt.opt * FStar_Pprint.document) Prims.list) = - fun warn_unsafe -> - let uu___ = specs_with_types warn_unsafe in - FStar_Compiler_List.map - (fun uu___2 -> - match uu___2 with - | (short, long, typ, doc) -> - let uu___3 = - let uu___4 = - let uu___5 = arg_spec_of_opt_type long typ in - (short, long, uu___5) in - mk_spec uu___4 in - (uu___3, doc)) uu___ -let (settable : Prims.string -> Prims.bool) = - fun uu___ -> - match uu___ with - | "__temp_fast_implicits" -> true - | "abort_on" -> true - | "admit_except" -> true - | "admit_smt_queries" -> true - | "compat_pre_core" -> true - | "compat_pre_typed_indexed_effects" -> true - | "disallow_unification_guards" -> true - | "debug" -> true - | "debug_all" -> true - | "debug_all_modules" -> true - | "defensive" -> true - | "detail_errors" -> true - | "detail_hint_replay" -> true - | "eager_subtyping" -> true - | "error_contexts" -> true - | "hide_uvar_nums" -> true - | "hint_dir" -> true - | "hint_file" -> true - | "hint_info" -> true - | "fuel" -> true - | "ext" -> true - | "ifuel" -> true - | "initial_fuel" -> true - | "initial_ifuel" -> true - | "ide_id_info_off" -> true - | "keep_query_captions" -> true - | "load" -> true - | "load_cmxs" -> true - | "log_queries" -> true - | "log_failing_queries" -> true - | "log_types" -> true - | "max_fuel" -> true - | "max_ifuel" -> true - | "no_plugins" -> true - | "__no_positivity" -> true - | "normalize_pure_terms_for_extraction" -> true - | "no_smt" -> true - | "no_tactics" -> true - | "print_bound_var_types" -> true - | "print_effect_args" -> true - | "print_expected_failures" -> true - | "print_full_names" -> true - | "print_implicits" -> true - | "print_universes" -> true - | "print_z3_statistics" -> true - | "prn" -> true - | "quake_lo" -> true - | "quake_hi" -> true - | "quake_keep" -> true - | "quake" -> true - | "query_cache" -> true - | "query_stats" -> true - | "record_options" -> true - | "retry" -> true - | "reuse_hint_for" -> true - | "report_assumes" -> true - | "silent" -> true - | "smtencoding.elim_box" -> true - | "smtencoding.l_arith_repr" -> true - | "smtencoding.nl_arith_repr" -> true - | "smtencoding.valid_intro" -> true - | "smtencoding.valid_elim" -> true - | "split_queries" -> true - | "tactic_raw_binders" -> true - | "tactics_failhard" -> true - | "tactics_info" -> true - | "__tactics_nbe" -> true - | "tactic_trace" -> true - | "tactic_trace_d" -> true - | "tcnorm" -> true - | "timing" -> true - | "trace_error" -> true - | "ugly" -> true - | "unthrottle_inductives" -> true - | "use_eq_at_higher_order" -> true - | "using_facts_from" -> true - | "warn_error" -> true - | "z3cliopt" -> true - | "z3smtopt" -> true - | "z3refresh" -> true - | "z3rlimit" -> true - | "z3rlimit_factor" -> true - | "z3seed" -> true - | "z3version" -> true - | "trivial_pre_for_unannotated_effectful_fns" -> true - | "profile_group_by_decl" -> true - | "profile_component" -> true - | "profile" -> true - | uu___2 -> false -let (all_specs : (FStar_Getopt.opt * FStar_Pprint.document) Prims.list) = - specs true -let (all_specs_getopt : FStar_Getopt.opt Prims.list) = - FStar_Compiler_List.map FStar_Pervasives_Native.fst all_specs -let (all_specs_with_types : - (FStar_BaseTypes.char * Prims.string * opt_type * FStar_Pprint.document) - Prims.list) - = specs_with_types true -let (settable_specs : - ((FStar_BaseTypes.char * Prims.string * unit FStar_Getopt.opt_variant) * - FStar_Pprint.document) Prims.list) - = - FStar_Compiler_List.filter - (fun uu___ -> - match uu___ with | ((uu___2, x, uu___3), uu___4) -> settable x) - all_specs -let (uu___2 : - (((unit -> FStar_Getopt.parse_cmdline_res) -> unit) * - (unit -> FStar_Getopt.parse_cmdline_res))) - = - let callback = FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None in - let set1 f = - FStar_Compiler_Effect.op_Colon_Equals callback - (FStar_Pervasives_Native.Some f) in - let call uu___ = - let uu___3 = FStar_Compiler_Effect.op_Bang callback in - match uu___3 with - | FStar_Pervasives_Native.None -> - failwith "Error flags callback not yet set" - | FStar_Pervasives_Native.Some f -> f () in - (set1, call) -let (set_error_flags_callback_aux : - (unit -> FStar_Getopt.parse_cmdline_res) -> unit) = - match uu___2 with - | (set_error_flags_callback_aux1, set_error_flags) -> - set_error_flags_callback_aux1 -let (set_error_flags : unit -> FStar_Getopt.parse_cmdline_res) = - match uu___2 with - | (set_error_flags_callback_aux1, set_error_flags1) -> set_error_flags1 -let (set_error_flags_callback : - (unit -> FStar_Getopt.parse_cmdline_res) -> unit) = - set_error_flags_callback_aux -let (display_usage : unit -> unit) = fun uu___ -> display_usage_aux all_specs -let (fstar_bin_directory : Prims.string) = - FStar_Compiler_Util.get_exec_dir () -let (file_list_ : Prims.string Prims.list FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref [] -let rec (parse_filename_arg : - FStar_Getopt.opt Prims.list -> - Prims.bool -> Prims.string -> FStar_Getopt.parse_cmdline_res) - = - fun specs1 -> - fun enable_filenames -> - fun arg -> - if FStar_Compiler_Util.starts_with arg "@" - then - let filename = FStar_Compiler_Util.substring_from arg Prims.int_one in - let lines = FStar_Compiler_Util.file_get_lines filename in - FStar_Getopt.parse_list specs1 - (parse_filename_arg specs1 enable_filenames) lines - else - (if enable_filenames - then - (let uu___4 = - let uu___5 = FStar_Compiler_Effect.op_Bang file_list_ in - FStar_Compiler_List.op_At uu___5 [arg] in - FStar_Compiler_Effect.op_Colon_Equals file_list_ uu___4) - else (); - FStar_Getopt.Success) -let (parse_cmd_line : - unit -> (FStar_Getopt.parse_cmdline_res * Prims.string Prims.list)) = - fun uu___ -> - let res = - FStar_Getopt.parse_cmdline all_specs_getopt - (parse_filename_arg all_specs_getopt true) in - let res1 = if res = FStar_Getopt.Success then set_error_flags () else res in - let uu___3 = - let uu___4 = FStar_Compiler_Effect.op_Bang file_list_ in - FStar_Compiler_List.map FStar_Common.try_convert_file_name_to_mixed - uu___4 in - (res1, uu___3) -let (file_list : unit -> Prims.string Prims.list) = - fun uu___ -> FStar_Compiler_Effect.op_Bang file_list_ -let (restore_cmd_line_options : Prims.bool -> FStar_Getopt.parse_cmdline_res) - = - fun should_clear -> - let old_verify_module = get_verify_module () in - if should_clear then clear () else init (); - (let specs1 = - let uu___3 = specs false in - FStar_Compiler_List.map FStar_Pervasives_Native.fst uu___3 in - let r = - FStar_Getopt.parse_cmdline specs1 (parse_filename_arg specs1 false) in - (let uu___4 = - let uu___5 = - let uu___6 = - FStar_Compiler_List.map (fun uu___7 -> String uu___7) - old_verify_module in - List uu___6 in - ("verify_module", uu___5) in - set_option' uu___4); - r) -let (module_name_of_file_name : Prims.string -> Prims.string) = - fun f -> - let f1 = FStar_Compiler_Util.basename f in - let f2 = - let uu___ = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Compiler_Util.get_file_extension f1 in - FStar_Compiler_String.length uu___5 in - (FStar_Compiler_String.length f1) - uu___4 in - uu___3 - Prims.int_one in - FStar_Compiler_String.substring f1 Prims.int_zero uu___ in - FStar_Compiler_String.lowercase f2 -let (should_check : Prims.string -> Prims.bool) = - fun m -> - let l = get_verify_module () in - FStar_Compiler_List.contains (FStar_Compiler_String.lowercase m) l -let (should_verify : Prims.string -> Prims.bool) = - fun m -> - (let uu___ = get_lax () in Prims.op_Negation uu___) && (should_check m) -let (should_check_file : Prims.string -> Prims.bool) = - fun fn -> let uu___ = module_name_of_file_name fn in should_check uu___ -let (should_verify_file : Prims.string -> Prims.bool) = - fun fn -> let uu___ = module_name_of_file_name fn in should_verify uu___ -let (module_name_eq : Prims.string -> Prims.string -> Prims.bool) = - fun m1 -> - fun m2 -> - (FStar_Compiler_String.lowercase m1) = - (FStar_Compiler_String.lowercase m2) -let (should_print_message : Prims.string -> Prims.bool) = - fun m -> - let uu___ = should_verify m in if uu___ then m <> "Prims" else false -let (read_fstar_include : - Prims.string -> Prims.string Prims.list FStar_Pervasives_Native.option) = - fun fn -> - try - (fun uu___ -> - match () with - | () -> - let s = FStar_Compiler_Util.file_get_contents fn in - let subdirs = - FStar_Compiler_List.filter - (fun s1 -> - (s1 <> "") && - (let uu___3 = - let uu___4 = - FStar_Compiler_String.get s1 Prims.int_zero in - uu___4 = 35 in - Prims.op_Negation uu___3)) - (FStar_Compiler_String.split [10] s) in - FStar_Pervasives_Native.Some subdirs) () - with - | uu___ -> - ((let uu___4 = FStar_Compiler_String.op_Hat "Could not read " fn in - failwith uu___4); - FStar_Pervasives_Native.None) -let rec (expand_include_d : Prims.string -> Prims.string Prims.list) = - fun dirname -> - let dot_inc_path = FStar_Compiler_String.op_Hat dirname "/fstar.include" in - if FStar_Compiler_Util.file_exists dot_inc_path - then - let subdirs = - let uu___ = read_fstar_include dot_inc_path in - FStar_Pervasives_Native.__proj__Some__item__v uu___ in - let uu___ = - FStar_Compiler_List.collect - (fun subd -> - let uu___3 = - let uu___4 = FStar_Compiler_String.op_Hat "/" subd in - FStar_Compiler_String.op_Hat dirname uu___4 in - expand_include_d uu___3) subdirs in - dirname :: uu___ - else [dirname] -let (expand_include_ds : Prims.string Prims.list -> Prims.string Prims.list) - = fun dirnames -> FStar_Compiler_List.collect expand_include_d dirnames -let (lib_root : unit -> Prims.string FStar_Pervasives_Native.option) = - fun uu___ -> - let uu___3 = get_no_default_includes () in - if uu___3 - then FStar_Pervasives_Native.None - else - (let uu___5 = - FStar_Compiler_Util.expand_environment_variable "FSTAR_LIB" in - match uu___5 with - | FStar_Pervasives_Native.Some s -> FStar_Pervasives_Native.Some s - | FStar_Pervasives_Native.None -> - let uu___6 = - let uu___7 = - FStar_Compiler_String.op_Hat fstar_bin_directory "/../ulib" in - FStar_Compiler_Util.file_exists uu___7 in - if uu___6 - then - let uu___7 = - FStar_Compiler_String.op_Hat fstar_bin_directory "/../ulib" in - FStar_Pervasives_Native.Some uu___7 - else - (let uu___8 = - let uu___9 = - FStar_Compiler_String.op_Hat fstar_bin_directory - "/../lib/fstar" in - FStar_Compiler_Util.file_exists uu___9 in - if uu___8 - then - let uu___9 = - FStar_Compiler_String.op_Hat fstar_bin_directory - "/../lib/fstar" in - FStar_Pervasives_Native.Some uu___9 - else FStar_Pervasives_Native.None)) -let (lib_paths : unit -> Prims.string Prims.list) = - fun uu___ -> - let uu___3 = - let uu___4 = lib_root () in FStar_Common.option_to_list uu___4 in - expand_include_ds uu___3 -let (include_path : unit -> Prims.string Prims.list) = - fun uu___ -> - let cache_dir = - let uu___3 = get_cache_dir () in - match uu___3 with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some c -> [c] in - let include_paths = - let uu___3 = get_include () in expand_include_ds uu___3 in - let uu___3 = - let uu___4 = lib_paths () in - let uu___5 = - let uu___6 = expand_include_d "." in - FStar_Compiler_List.op_At include_paths uu___6 in - FStar_Compiler_List.op_At uu___4 uu___5 in - FStar_Compiler_List.op_At cache_dir uu___3 -let (custom_prims : unit -> Prims.string FStar_Pervasives_Native.option) = - fun uu___ -> get_prims () -let (prepend_output_dir : Prims.string -> Prims.string) = - fun fname -> - let uu___ = get_odir () in - match uu___ with - | FStar_Pervasives_Native.None -> fname - | FStar_Pervasives_Native.Some x -> - FStar_Compiler_Util.join_paths x fname -let (prepend_cache_dir : Prims.string -> Prims.string) = - fun fpath -> - let uu___ = get_cache_dir () in - match uu___ with - | FStar_Pervasives_Native.None -> fpath - | FStar_Pervasives_Native.Some x -> - let uu___3 = FStar_Compiler_Util.basename fpath in - FStar_Compiler_Util.join_paths x uu___3 -let (path_of_text : Prims.string -> Prims.string Prims.list) = - fun text -> FStar_Compiler_String.split [46] text -let (parse_settings : - Prims.string Prims.list -> - (Prims.string Prims.list * Prims.bool) Prims.list) - = - fun ns -> - let cache = FStar_Compiler_Util.smap_create (Prims.of_int (31)) in - let with_cache f s = - let uu___ = FStar_Compiler_Util.smap_try_find cache s in - match uu___ with - | FStar_Pervasives_Native.Some s1 -> s1 - | FStar_Pervasives_Native.None -> - let res = f s in (FStar_Compiler_Util.smap_add cache s res; res) in - let parse_one_setting s = - if s = "*" - then ([], true) - else - if s = "-*" - then ([], false) - else - if FStar_Compiler_Util.starts_with s "-" - then - (let path = - let uu___4 = - FStar_Compiler_Util.substring_from s Prims.int_one in - path_of_text uu___4 in - (path, false)) - else - (let s1 = - if FStar_Compiler_Util.starts_with s "+" - then FStar_Compiler_Util.substring_from s Prims.int_one - else s in - ((path_of_text s1), true)) in - let uu___ = - FStar_Compiler_List.collect - (fun s -> - let s1 = FStar_Compiler_Util.trim_string s in - if s1 = "" - then [] - else - with_cache - (fun s2 -> - let s3 = FStar_Compiler_Util.replace_char s2 32 44 in - let uu___4 = - let uu___5 = - FStar_Compiler_List.concatMap - (fun s4 -> FStar_Compiler_Util.split s4 ",") - (FStar_Compiler_Util.splitlines s3) in - FStar_Compiler_List.filter (fun s4 -> s4 <> "") uu___5 in - FStar_Compiler_List.map parse_one_setting uu___4) s1) ns in - FStar_Compiler_List.rev uu___ -let (admit_smt_queries : unit -> Prims.bool) = - fun uu___ -> get_admit_smt_queries () -let (admit_except : unit -> Prims.string FStar_Pervasives_Native.option) = - fun uu___ -> get_admit_except () -let (compat_pre_core_should_register : unit -> Prims.bool) = - fun uu___ -> - let uu___3 = get_compat_pre_core () in - match uu___3 with - | FStar_Pervasives_Native.Some uu___4 when uu___4 = Prims.int_zero -> - false - | uu___4 -> true -let (compat_pre_core_should_check : unit -> Prims.bool) = - fun uu___ -> - let uu___3 = get_compat_pre_core () in - match uu___3 with - | FStar_Pervasives_Native.Some uu___4 when uu___4 = Prims.int_zero -> - false - | FStar_Pervasives_Native.Some uu___4 when uu___4 = Prims.int_one -> - false - | uu___4 -> true -let (compat_pre_core_set : unit -> Prims.bool) = - fun uu___ -> - let uu___3 = get_compat_pre_core () in - match uu___3 with - | FStar_Pervasives_Native.None -> false - | uu___4 -> true -let (compat_pre_typed_indexed_effects : unit -> Prims.bool) = - fun uu___ -> get_compat_pre_typed_indexed_effects () -let (disallow_unification_guards : unit -> Prims.bool) = - fun uu___ -> get_disallow_unification_guards () -let (cache_checked_modules : unit -> Prims.bool) = - fun uu___ -> get_cache_checked_modules () -let (cache_off : unit -> Prims.bool) = fun uu___ -> get_cache_off () -let (print_cache_version : unit -> Prims.bool) = - fun uu___ -> get_print_cache_version () -let (cmi : unit -> Prims.bool) = fun uu___ -> get_cmi () -let (parse_codegen : - Prims.string -> codegen_t FStar_Pervasives_Native.option) = - fun uu___ -> - match uu___ with - | "OCaml" -> FStar_Pervasives_Native.Some OCaml - | "FSharp" -> FStar_Pervasives_Native.Some FSharp - | "krml" -> FStar_Pervasives_Native.Some Krml - | "Plugin" -> FStar_Pervasives_Native.Some Plugin - | "Extension" -> FStar_Pervasives_Native.Some Extension - | uu___3 -> FStar_Pervasives_Native.None -let (print_codegen : codegen_t -> Prims.string) = - fun uu___ -> - match uu___ with - | OCaml -> "OCaml" - | FSharp -> "FSharp" - | Krml -> "krml" - | Plugin -> "Plugin" - | Extension -> "Extension" -let (codegen : unit -> codegen_t FStar_Pervasives_Native.option) = - fun uu___ -> - let uu___3 = get_codegen () in - FStar_Compiler_Util.map_opt uu___3 - (fun s -> - let uu___4 = parse_codegen s in FStar_Compiler_Util.must uu___4) -let (codegen_libs : unit -> Prims.string Prims.list Prims.list) = - fun uu___ -> - let uu___3 = get_codegen_lib () in - FStar_Compiler_List.map (fun x -> FStar_Compiler_Util.split x ".") uu___3 -let (profile_group_by_decl : unit -> Prims.bool) = - fun uu___ -> get_profile_group_by_decl () -let (defensive : unit -> Prims.bool) = - fun uu___ -> let uu___3 = get_defensive () in uu___3 <> "no" -let (defensive_error : unit -> Prims.bool) = - fun uu___ -> let uu___3 = get_defensive () in uu___3 = "error" -let (defensive_abort : unit -> Prims.bool) = - fun uu___ -> let uu___3 = get_defensive () in uu___3 = "abort" -let (dep : unit -> Prims.string FStar_Pervasives_Native.option) = - fun uu___ -> get_dep () -let (detail_errors : unit -> Prims.bool) = fun uu___ -> get_detail_errors () -let (detail_hint_replay : unit -> Prims.bool) = - fun uu___ -> get_detail_hint_replay () -let (any_dump_module : unit -> Prims.bool) = - fun uu___ -> let uu___3 = get_dump_module () in Prims.uu___is_Cons uu___3 -let (dump_module : Prims.string -> Prims.bool) = - fun s -> - let uu___ = get_dump_module () in - FStar_Compiler_List.existsb (module_name_eq s) uu___ -let (eager_subtyping : unit -> Prims.bool) = - fun uu___ -> get_eager_subtyping () -let (error_contexts : unit -> Prims.bool) = - fun uu___ -> get_error_contexts () -let (expose_interfaces : unit -> Prims.bool) = - fun uu___ -> get_expose_interfaces () -let (message_format : unit -> message_format_t) = - fun uu___ -> - let uu___3 = get_message_format () in - match uu___3 with - | "human" -> Human - | "json" -> Json - | illegal -> - let uu___4 = - let uu___5 = - FStar_Compiler_String.op_Hat illegal - "`. This should be impossible: `message_format` was supposed to be validated." in - FStar_Compiler_String.op_Hat - "print_issue: option `message_format` was expected to be `human` or `json`, not `" - uu___5 in - failwith uu___4 -let (force : unit -> Prims.bool) = fun uu___ -> get_force () -let (full_context_dependency : unit -> Prims.bool) = fun uu___ -> true -let (hide_uvar_nums : unit -> Prims.bool) = - fun uu___ -> get_hide_uvar_nums () -let (hint_info : unit -> Prims.bool) = - fun uu___ -> (get_hint_info ()) || (get_query_stats ()) -let (hint_dir : unit -> Prims.string FStar_Pervasives_Native.option) = - fun uu___ -> get_hint_dir () -let (hint_file : unit -> Prims.string FStar_Pervasives_Native.option) = - fun uu___ -> get_hint_file () -let (hint_file_for_src : Prims.string -> Prims.string) = - fun src_filename -> - let uu___ = hint_file () in - match uu___ with - | FStar_Pervasives_Native.Some fn -> fn - | FStar_Pervasives_Native.None -> - let file_name = - let uu___3 = hint_dir () in - match uu___3 with - | FStar_Pervasives_Native.Some dir -> - let uu___4 = FStar_Compiler_Util.basename src_filename in - FStar_Compiler_Util.concat_dir_filename dir uu___4 - | uu___4 -> src_filename in - FStar_Compiler_Util.format1 "%s.hints" file_name -let (ide : unit -> Prims.bool) = fun uu___ -> get_ide () -let (ide_id_info_off : unit -> Prims.bool) = - fun uu___ -> get_ide_id_info_off () -let (ide_file_name_st : - ((Prims.string -> unit) * - (unit -> Prims.string FStar_Pervasives_Native.option))) - = - let v = FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None in - let set1 f = - let uu___ = FStar_Compiler_Effect.op_Bang v in - match uu___ with - | FStar_Pervasives_Native.None -> - FStar_Compiler_Effect.op_Colon_Equals v - (FStar_Pervasives_Native.Some f) - | FStar_Pervasives_Native.Some uu___3 -> - failwith "ide_file_name_st already set" in - let get uu___ = FStar_Compiler_Effect.op_Bang v in (set1, get) -let (set_ide_filename : Prims.string -> unit) = - FStar_Pervasives_Native.fst ide_file_name_st -let (ide_filename : unit -> Prims.string FStar_Pervasives_Native.option) = - FStar_Pervasives_Native.snd ide_file_name_st -let (print : unit -> Prims.bool) = fun uu___ -> get_print () -let (print_in_place : unit -> Prims.bool) = - fun uu___ -> get_print_in_place () -let (initial_fuel : unit -> Prims.int) = - fun uu___ -> - let uu___3 = get_initial_fuel () in - let uu___4 = get_max_fuel () in Prims.min uu___3 uu___4 -let (initial_ifuel : unit -> Prims.int) = - fun uu___ -> - let uu___3 = get_initial_ifuel () in - let uu___4 = get_max_ifuel () in Prims.min uu___3 uu___4 -let (interactive : unit -> Prims.bool) = - fun uu___ -> ((get_in ()) || (get_ide ())) || (get_lsp ()) -let (lax : unit -> Prims.bool) = fun uu___ -> get_lax () -let (load : unit -> Prims.string Prims.list) = fun uu___ -> get_load () -let (load_cmxs : unit -> Prims.string Prims.list) = - fun uu___ -> get_load_cmxs () -let (legacy_interactive : unit -> Prims.bool) = fun uu___ -> get_in () -let (lsp_server : unit -> Prims.bool) = fun uu___ -> get_lsp () -let (log_queries : unit -> Prims.bool) = fun uu___ -> get_log_queries () -let (log_failing_queries : unit -> Prims.bool) = - fun uu___ -> get_log_failing_queries () -let (keep_query_captions : unit -> Prims.bool) = - fun uu___ -> - (get_keep_query_captions ()) && - ((log_queries ()) || (log_failing_queries ())) -let (log_types : unit -> Prims.bool) = fun uu___ -> get_log_types () -let (max_fuel : unit -> Prims.int) = fun uu___ -> get_max_fuel () -let (max_ifuel : unit -> Prims.int) = fun uu___ -> get_max_ifuel () -let (ml_ish : unit -> Prims.bool) = fun uu___ -> get_MLish () -let (ml_ish_effect : unit -> Prims.string) = fun uu___ -> get_MLish_effect () -let (set_ml_ish : unit -> unit) = fun uu___ -> set_option "MLish" (Bool true) -let (no_default_includes : unit -> Prims.bool) = - fun uu___ -> get_no_default_includes () -let (no_extract : Prims.string -> Prims.bool) = - fun s -> - let uu___ = get_no_extract () in - FStar_Compiler_List.existsb (module_name_eq s) uu___ -let (normalize_pure_terms_for_extraction : unit -> Prims.bool) = - fun uu___ -> get_normalize_pure_terms_for_extraction () -let (no_location_info : unit -> Prims.bool) = - fun uu___ -> get_no_location_info () -let (no_plugins : unit -> Prims.bool) = fun uu___ -> get_no_plugins () -let (no_smt : unit -> Prims.bool) = fun uu___ -> get_no_smt () -let (krmloutput : unit -> Prims.string FStar_Pervasives_Native.option) = - fun uu___ -> get_krmloutput () -let (output_dir : unit -> Prims.string FStar_Pervasives_Native.option) = - fun uu___ -> get_odir () -let (output_deps_to : unit -> Prims.string FStar_Pervasives_Native.option) = - fun uu___ -> get_output_deps_to () -let (ugly : unit -> Prims.bool) = fun uu___ -> get_ugly () -let (print_bound_var_types : unit -> Prims.bool) = - fun uu___ -> get_print_bound_var_types () -let (print_effect_args : unit -> Prims.bool) = - fun uu___ -> get_print_effect_args () -let (print_expected_failures : unit -> Prims.bool) = - fun uu___ -> get_print_expected_failures () -let (print_implicits : unit -> Prims.bool) = - fun uu___ -> get_print_implicits () -let (print_real_names : unit -> Prims.bool) = - fun uu___ -> (get_prn ()) || (get_print_full_names ()) -let (print_universes : unit -> Prims.bool) = - fun uu___ -> get_print_universes () -let (print_z3_statistics : unit -> Prims.bool) = - fun uu___ -> get_print_z3_statistics () -let (proof_recovery : unit -> Prims.bool) = - fun uu___ -> get_proof_recovery () -let (quake_lo : unit -> Prims.int) = fun uu___ -> get_quake_lo () -let (quake_hi : unit -> Prims.int) = fun uu___ -> get_quake_hi () -let (quake_keep : unit -> Prims.bool) = fun uu___ -> get_quake_keep () -let (query_cache : unit -> Prims.bool) = fun uu___ -> get_query_cache () -let (query_stats : unit -> Prims.bool) = fun uu___ -> get_query_stats () -let (read_checked_file : unit -> Prims.string FStar_Pervasives_Native.option) - = fun uu___ -> get_read_checked_file () -let (list_plugins : unit -> Prims.bool) = fun uu___ -> get_list_plugins () -let (locate : unit -> Prims.bool) = fun uu___ -> get_locate () -let (locate_lib : unit -> Prims.bool) = fun uu___ -> get_locate_lib () -let (locate_ocaml : unit -> Prims.bool) = fun uu___ -> get_locate_ocaml () -let (read_krml_file : unit -> Prims.string FStar_Pervasives_Native.option) = - fun uu___ -> get_read_krml_file () -let (record_hints : unit -> Prims.bool) = fun uu___ -> get_record_hints () -let (record_options : unit -> Prims.bool) = - fun uu___ -> get_record_options () -let (retry : unit -> Prims.bool) = fun uu___ -> get_retry () -let (reuse_hint_for : unit -> Prims.string FStar_Pervasives_Native.option) = - fun uu___ -> get_reuse_hint_for () -let (report_assumes : unit -> Prims.string FStar_Pervasives_Native.option) = - fun uu___ -> get_report_assumes () -let (silent : unit -> Prims.bool) = fun uu___ -> get_silent () -let (smt : unit -> Prims.string FStar_Pervasives_Native.option) = - fun uu___ -> get_smt () -let (smtencoding_elim_box : unit -> Prims.bool) = - fun uu___ -> get_smtencoding_elim_box () -let (smtencoding_nl_arith_native : unit -> Prims.bool) = - fun uu___ -> - let uu___3 = get_smtencoding_nl_arith_repr () in uu___3 = "native" -let (smtencoding_nl_arith_wrapped : unit -> Prims.bool) = - fun uu___ -> - let uu___3 = get_smtencoding_nl_arith_repr () in uu___3 = "wrapped" -let (smtencoding_nl_arith_default : unit -> Prims.bool) = - fun uu___ -> - let uu___3 = get_smtencoding_nl_arith_repr () in uu___3 = "boxwrap" -let (smtencoding_l_arith_native : unit -> Prims.bool) = - fun uu___ -> - let uu___3 = get_smtencoding_l_arith_repr () in uu___3 = "native" -let (smtencoding_l_arith_default : unit -> Prims.bool) = - fun uu___ -> - let uu___3 = get_smtencoding_l_arith_repr () in uu___3 = "boxwrap" -let (smtencoding_valid_intro : unit -> Prims.bool) = - fun uu___ -> get_smtencoding_valid_intro () -let (smtencoding_valid_elim : unit -> Prims.bool) = - fun uu___ -> get_smtencoding_valid_elim () -let (parse_split_queries : - Prims.string -> split_queries_t FStar_Pervasives_Native.option) = - fun s -> - match s with - | "no" -> FStar_Pervasives_Native.Some No - | "on_failure" -> FStar_Pervasives_Native.Some OnFailure - | "always" -> FStar_Pervasives_Native.Some Always - | uu___ -> FStar_Pervasives_Native.None -let (split_queries : unit -> split_queries_t) = - fun uu___ -> - let uu___3 = - let uu___4 = get_split_queries () in parse_split_queries uu___4 in - FStar_Compiler_Util.must uu___3 -let (tactic_raw_binders : unit -> Prims.bool) = - fun uu___ -> get_tactic_raw_binders () -let (tactics_failhard : unit -> Prims.bool) = - fun uu___ -> get_tactics_failhard () -let (tactics_info : unit -> Prims.bool) = fun uu___ -> get_tactics_info () -let (tactic_trace : unit -> Prims.bool) = fun uu___ -> get_tactic_trace () -let (tactic_trace_d : unit -> Prims.int) = fun uu___ -> get_tactic_trace_d () -let (tactics_nbe : unit -> Prims.bool) = fun uu___ -> get_tactics_nbe () -let (tcnorm : unit -> Prims.bool) = fun uu___ -> get_tcnorm () -let (timing : unit -> Prims.bool) = fun uu___ -> get_timing () -let (trace_error : unit -> Prims.bool) = fun uu___ -> get_trace_error () -let (unthrottle_inductives : unit -> Prims.bool) = - fun uu___ -> get_unthrottle_inductives () -let (unsafe_tactic_exec : unit -> Prims.bool) = - fun uu___ -> get_unsafe_tactic_exec () -let (use_eq_at_higher_order : unit -> Prims.bool) = - fun uu___ -> get_use_eq_at_higher_order () -let (use_hints : unit -> Prims.bool) = fun uu___ -> get_use_hints () -let (use_hint_hashes : unit -> Prims.bool) = - fun uu___ -> get_use_hint_hashes () -let (use_native_tactics : - unit -> Prims.string FStar_Pervasives_Native.option) = - fun uu___ -> get_use_native_tactics () -let (use_tactics : unit -> Prims.bool) = - fun uu___ -> let uu___3 = get_no_tactics () in Prims.op_Negation uu___3 -let (using_facts_from : - unit -> (Prims.string Prims.list * Prims.bool) Prims.list) = - fun uu___ -> - let uu___3 = get_using_facts_from () in - match uu___3 with - | FStar_Pervasives_Native.None -> [([], true)] - | FStar_Pervasives_Native.Some ns -> parse_settings ns -let (warn_default_effects : unit -> Prims.bool) = - fun uu___ -> get_warn_default_effects () -let (warn_error : unit -> Prims.string) = - fun uu___ -> - let uu___3 = get_warn_error () in FStar_Compiler_String.concat " " uu___3 -let (z3_cliopt : unit -> Prims.string Prims.list) = - fun uu___ -> get_z3cliopt () -let (z3_smtopt : unit -> Prims.string Prims.list) = - fun uu___ -> get_z3smtopt () -let (z3_refresh : unit -> Prims.bool) = fun uu___ -> get_z3refresh () -let (z3_rlimit : unit -> Prims.int) = fun uu___ -> get_z3rlimit () -let (z3_rlimit_factor : unit -> Prims.int) = - fun uu___ -> get_z3rlimit_factor () -let (z3_seed : unit -> Prims.int) = fun uu___ -> get_z3seed () -let (z3_version : unit -> Prims.string) = fun uu___ -> get_z3version () -let (no_positivity : unit -> Prims.bool) = fun uu___ -> get_no_positivity () -let (use_nbe : unit -> Prims.bool) = fun uu___ -> get_use_nbe () -let (use_nbe_for_extraction : unit -> Prims.bool) = - fun uu___ -> get_use_nbe_for_extraction () -let (trivial_pre_for_unannotated_effectful_fns : unit -> Prims.bool) = - fun uu___ -> get_trivial_pre_for_unannotated_effectful_fns () -let (debug_keys : unit -> Prims.string Prims.list) = - fun uu___ -> lookup_opt "debug" as_comma_string_list -let (debug_all : unit -> Prims.bool) = - fun uu___ -> lookup_opt "debug_all" as_bool -let (debug_all_modules : unit -> Prims.bool) = - fun uu___ -> lookup_opt "debug_all_modules" as_bool -let with_saved_options : 'a . (unit -> 'a) -> 'a = - fun f -> - let uu___ = let uu___3 = trace_error () in Prims.op_Negation uu___3 in - if uu___ - then - (push (); - (let r = - try - (fun uu___4 -> - match () with - | () -> let uu___5 = f () in FStar_Pervasives.Inr uu___5) () - with | uu___4 -> FStar_Pervasives.Inl uu___4 in - pop (); - (match r with - | FStar_Pervasives.Inr v -> v - | FStar_Pervasives.Inl ex -> FStar_Compiler_Effect.raise ex))) - else (push (); (let retv = f () in pop (); retv)) -let (module_matches_namespace_filter : - Prims.string -> Prims.string Prims.list -> Prims.bool) = - fun m -> - fun filter -> - let m1 = FStar_Compiler_String.lowercase m in - let setting = parse_settings filter in - let m_components = path_of_text m1 in - let rec matches_path m_components1 path = - match (m_components1, path) with - | (uu___, []) -> true - | (m2::ms, p::ps) -> - (m2 = (FStar_Compiler_String.lowercase p)) && - (matches_path ms ps) - | uu___ -> false in - let uu___ = - FStar_Compiler_Util.try_find - (fun uu___3 -> - match uu___3 with - | (path, uu___4) -> matches_path m_components path) setting in - match uu___ with - | FStar_Pervasives_Native.None -> false - | FStar_Pervasives_Native.Some (uu___3, flag) -> flag -let (matches_namespace_filter_opt : - Prims.string -> - Prims.string Prims.list FStar_Pervasives_Native.option -> Prims.bool) - = - fun m -> - fun uu___ -> - match uu___ with - | FStar_Pervasives_Native.None -> false - | FStar_Pervasives_Native.Some filter -> - module_matches_namespace_filter m filter -type parsed_extract_setting = - { - target_specific_settings: (codegen_t * Prims.string) Prims.list ; - default_settings: Prims.string FStar_Pervasives_Native.option } -let (__proj__Mkparsed_extract_setting__item__target_specific_settings : - parsed_extract_setting -> (codegen_t * Prims.string) Prims.list) = - fun projectee -> - match projectee with - | { target_specific_settings; default_settings;_} -> - target_specific_settings -let (__proj__Mkparsed_extract_setting__item__default_settings : - parsed_extract_setting -> Prims.string FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { target_specific_settings; default_settings;_} -> default_settings -let (print_pes : parsed_extract_setting -> Prims.string) = - fun pes -> - let uu___ = - let uu___3 = - FStar_Compiler_List.map - (fun uu___4 -> - match uu___4 with - | (tgt, s) -> - FStar_Compiler_Util.format2 "(%s, %s)" (print_codegen tgt) s) - pes.target_specific_settings in - FStar_Compiler_String.concat "; " uu___3 in - FStar_Compiler_Util.format2 - "{ target_specific_settings = %s;\n\t\n default_settings = %s }" - uu___ - (match pes.default_settings with - | FStar_Pervasives_Native.None -> "None" - | FStar_Pervasives_Native.Some s -> s) -let (find_setting_for_target : - codegen_t -> - (codegen_t * Prims.string) Prims.list -> - Prims.string FStar_Pervasives_Native.option) - = - fun tgt -> - fun s -> - let uu___ = - FStar_Compiler_Util.try_find - (fun uu___3 -> match uu___3 with | (x, uu___4) -> x = tgt) s in - match uu___ with - | FStar_Pervasives_Native.Some (uu___3, s1) -> - FStar_Pervasives_Native.Some s1 - | uu___3 -> FStar_Pervasives_Native.None -let (extract_settings : - unit -> parsed_extract_setting FStar_Pervasives_Native.option) = - let memo = FStar_Compiler_Util.mk_ref (FStar_Pervasives_Native.None, false) in - let merge_parsed_extract_settings p0 p1 = - let merge_setting s0 s1 = - match (s0, s1) with - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> - FStar_Pervasives_Native.None - | (FStar_Pervasives_Native.Some p, FStar_Pervasives_Native.None) -> - FStar_Pervasives_Native.Some p - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.Some p) -> - FStar_Pervasives_Native.Some p - | (FStar_Pervasives_Native.Some p01, FStar_Pervasives_Native.Some p11) - -> - let uu___ = - let uu___3 = FStar_Compiler_String.op_Hat "," p11 in - FStar_Compiler_String.op_Hat p01 uu___3 in - FStar_Pervasives_Native.Some uu___ in - let merge_target tgt = - let uu___ = - let uu___3 = find_setting_for_target tgt p0.target_specific_settings in - let uu___4 = find_setting_for_target tgt p1.target_specific_settings in - merge_setting uu___3 uu___4 in - match uu___ with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some x -> [(tgt, x)] in - let uu___ = - FStar_Compiler_List.collect merge_target - [OCaml; FSharp; Krml; Plugin; Extension] in - let uu___3 = merge_setting p0.default_settings p1.default_settings in - { target_specific_settings = uu___; default_settings = uu___3 } in - fun uu___ -> - let uu___3 = FStar_Compiler_Effect.op_Bang memo in - match uu___3 with - | (result, set1) -> - let fail msg = - display_usage (); - (let uu___5 = - FStar_Compiler_Util.format1 - "Could not parse '%s' passed to the --extract option" msg in - failwith uu___5) in - if set1 - then result - else - (let uu___5 = get_extract () in - match uu___5 with - | FStar_Pervasives_Native.None -> - (FStar_Compiler_Effect.op_Colon_Equals memo - (FStar_Pervasives_Native.None, true); - FStar_Pervasives_Native.None) - | FStar_Pervasives_Native.Some extract_settings1 -> - let parse_one_setting extract_setting = - let tgt_specific_settings = - FStar_Compiler_Util.split extract_setting ";" in - let split_one t_setting = - match FStar_Compiler_Util.split t_setting ":" with - | default_setting::[] -> - FStar_Pervasives.Inr - (FStar_Compiler_Util.trim_string default_setting) - | target::setting::[] -> - let target1 = FStar_Compiler_Util.trim_string target in - let uu___6 = parse_codegen target1 in - (match uu___6 with - | FStar_Pervasives_Native.None -> fail target1 - | FStar_Pervasives_Native.Some tgt -> - FStar_Pervasives.Inl - (tgt, - (FStar_Compiler_Util.trim_string setting)) - | uu___7 -> fail t_setting) in - let settings = - FStar_Compiler_List.map split_one tgt_specific_settings in - let fail_duplicate msg tgt = - display_usage (); - (let uu___7 = - FStar_Compiler_Util.format2 - "Could not parse '%s'; multiple setting for %s target" - msg tgt in - failwith uu___7) in - let pes = - FStar_Compiler_List.fold_right - (fun setting -> - fun out -> - match setting with - | FStar_Pervasives.Inr def -> - (match out.default_settings with - | FStar_Pervasives_Native.None -> - { - target_specific_settings = - (out.target_specific_settings); - default_settings = - (FStar_Pervasives_Native.Some def) - } - | FStar_Pervasives_Native.Some uu___6 -> - fail_duplicate def "default") - | FStar_Pervasives.Inl (target, setting1) -> - let uu___6 = - FStar_Compiler_Util.try_find - (fun uu___7 -> - match uu___7 with - | (x, uu___8) -> x = target) - out.target_specific_settings in - (match uu___6 with - | FStar_Pervasives_Native.None -> - { - target_specific_settings = - ((target, setting1) :: - (out.target_specific_settings)); - default_settings = - (out.default_settings) - } - | FStar_Pervasives_Native.Some uu___7 -> - fail_duplicate setting1 - (print_codegen target))) settings - { - target_specific_settings = []; - default_settings = FStar_Pervasives_Native.None - } in - pes in - let empty_pes = - { - target_specific_settings = []; - default_settings = FStar_Pervasives_Native.None - } in - let pes = - FStar_Compiler_List.fold_right - (fun setting -> - fun pes1 -> - let uu___6 = parse_one_setting setting in - merge_parsed_extract_settings pes1 uu___6) - extract_settings1 empty_pes in - (FStar_Compiler_Effect.op_Colon_Equals memo - ((FStar_Pervasives_Native.Some pes), true); - FStar_Pervasives_Native.Some pes)) -let (should_extract : Prims.string -> codegen_t -> Prims.bool) = - fun m -> - fun tgt -> - let m1 = FStar_Compiler_String.lowercase m in - if m1 = "prims" - then false - else - (let uu___3 = extract_settings () in - match uu___3 with - | FStar_Pervasives_Native.Some pes -> - ((let uu___5 = - let uu___6 = get_no_extract () in - let uu___7 = get_extract_namespace () in - let uu___8 = get_extract_module () in - (uu___6, uu___7, uu___8) in - match uu___5 with - | ([], [], []) -> () - | uu___6 -> - failwith - "Incompatible options: --extract cannot be used with --no_extract, --extract_namespace or --extract_module"); - (let tsetting = - let uu___5 = - find_setting_for_target tgt pes.target_specific_settings in - match uu___5 with - | FStar_Pervasives_Native.Some s -> s - | FStar_Pervasives_Native.None -> - (match pes.default_settings with - | FStar_Pervasives_Native.Some s -> s - | FStar_Pervasives_Native.None -> "*") in - module_matches_namespace_filter m1 [tsetting])) - | FStar_Pervasives_Native.None -> - let should_extract_namespace m2 = - let uu___4 = get_extract_namespace () in - match uu___4 with - | [] -> false - | ns -> - FStar_Compiler_Util.for_some - (fun n -> - FStar_Compiler_Util.starts_with m2 - (FStar_Compiler_String.lowercase n)) ns in - let should_extract_module m2 = - let uu___4 = get_extract_module () in - match uu___4 with - | [] -> false - | l -> - FStar_Compiler_Util.for_some - (fun n -> (FStar_Compiler_String.lowercase n) = m2) l in - (let uu___4 = no_extract m1 in Prims.op_Negation uu___4) && - (let uu___4 = - let uu___5 = get_extract_namespace () in - let uu___6 = get_extract_module () in (uu___5, uu___6) in - (match uu___4 with - | ([], []) -> true - | uu___5 -> - (should_extract_namespace m1) || - (should_extract_module m1)))) -let (should_be_already_cached : Prims.string -> Prims.bool) = - fun m -> - (let uu___ = should_check m in Prims.op_Negation uu___) && - (let uu___ = get_already_cached () in - match uu___ with - | FStar_Pervasives_Native.None -> false - | FStar_Pervasives_Native.Some already_cached_setting -> - module_matches_namespace_filter m already_cached_setting) -let (profile_enabled : - Prims.string FStar_Pervasives_Native.option -> Prims.string -> Prims.bool) - = - fun modul_opt -> - fun phase -> - match modul_opt with - | FStar_Pervasives_Native.None -> - let uu___ = get_profile_component () in - matches_namespace_filter_opt phase uu___ - | FStar_Pervasives_Native.Some modul -> - ((let uu___ = get_profile () in - matches_namespace_filter_opt modul uu___) && - (let uu___ = get_profile_component () in - matches_namespace_filter_opt phase uu___)) - || - (((timing ()) && - (phase = "FStar.TypeChecker.Tc.process_one_decl")) - && (should_check modul)) -exception File_argument of Prims.string -let (uu___is_File_argument : Prims.exn -> Prims.bool) = - fun projectee -> - match projectee with | File_argument uu___ -> true | uu___ -> false -let (__proj__File_argument__item__uu___ : Prims.exn -> Prims.string) = - fun projectee -> match projectee with | File_argument uu___ -> uu___ -let (set_options : Prims.string -> FStar_Getopt.parse_cmdline_res) = - fun s -> - try - (fun uu___ -> - match () with - | () -> - if s = "" - then FStar_Getopt.Success - else - (let settable_specs1 = - FStar_Compiler_List.map FStar_Pervasives_Native.fst - settable_specs in - let res = - FStar_Getopt.parse_string settable_specs1 - (fun s1 -> - FStar_Compiler_Effect.raise (File_argument s1); - FStar_Getopt.Error "set_options with file argument") s in - if res = FStar_Getopt.Success - then set_error_flags () - else res)) () - with - | File_argument s1 -> - let uu___3 = - FStar_Compiler_Util.format1 "File %s is not a valid option" s1 in - FStar_Getopt.Error uu___3 -let with_options : 'a . Prims.string -> (unit -> 'a) -> 'a = - fun s -> - fun f -> - with_saved_options - (fun uu___ -> (let uu___4 = set_options s in ()); f ()) -let (get_vconfig : unit -> FStar_VConfig.vconfig) = - fun uu___ -> - let vcfg = - let uu___3 = get_initial_fuel () in - let uu___4 = get_max_fuel () in - let uu___5 = get_initial_ifuel () in - let uu___6 = get_max_ifuel () in - let uu___7 = get_detail_errors () in - let uu___8 = get_detail_hint_replay () in - let uu___9 = get_no_smt () in - let uu___10 = get_quake_lo () in - let uu___11 = get_quake_hi () in - let uu___12 = get_quake_keep () in - let uu___13 = get_retry () in - let uu___14 = get_smtencoding_elim_box () in - let uu___15 = get_smtencoding_nl_arith_repr () in - let uu___16 = get_smtencoding_l_arith_repr () in - let uu___17 = get_smtencoding_valid_intro () in - let uu___18 = get_smtencoding_valid_elim () in - let uu___19 = get_tcnorm () in - let uu___20 = get_no_plugins () in - let uu___21 = get_no_tactics () in - let uu___22 = get_z3cliopt () in - let uu___23 = get_z3smtopt () in - let uu___24 = get_z3refresh () in - let uu___25 = get_z3rlimit () in - let uu___26 = get_z3rlimit_factor () in - let uu___27 = get_z3seed () in - let uu___28 = get_z3version () in - let uu___29 = get_trivial_pre_for_unannotated_effectful_fns () in - let uu___30 = get_reuse_hint_for () in - { - FStar_VConfig.initial_fuel = uu___3; - FStar_VConfig.max_fuel = uu___4; - FStar_VConfig.initial_ifuel = uu___5; - FStar_VConfig.max_ifuel = uu___6; - FStar_VConfig.detail_errors = uu___7; - FStar_VConfig.detail_hint_replay = uu___8; - FStar_VConfig.no_smt = uu___9; - FStar_VConfig.quake_lo = uu___10; - FStar_VConfig.quake_hi = uu___11; - FStar_VConfig.quake_keep = uu___12; - FStar_VConfig.retry = uu___13; - FStar_VConfig.smtencoding_elim_box = uu___14; - FStar_VConfig.smtencoding_nl_arith_repr = uu___15; - FStar_VConfig.smtencoding_l_arith_repr = uu___16; - FStar_VConfig.smtencoding_valid_intro = uu___17; - FStar_VConfig.smtencoding_valid_elim = uu___18; - FStar_VConfig.tcnorm = uu___19; - FStar_VConfig.no_plugins = uu___20; - FStar_VConfig.no_tactics = uu___21; - FStar_VConfig.z3cliopt = uu___22; - FStar_VConfig.z3smtopt = uu___23; - FStar_VConfig.z3refresh = uu___24; - FStar_VConfig.z3rlimit = uu___25; - FStar_VConfig.z3rlimit_factor = uu___26; - FStar_VConfig.z3seed = uu___27; - FStar_VConfig.z3version = uu___28; - FStar_VConfig.trivial_pre_for_unannotated_effectful_fns = uu___29; - FStar_VConfig.reuse_hint_for = uu___30 - } in - vcfg -let (set_vconfig : FStar_VConfig.vconfig -> unit) = - fun vcfg -> - let option_as tag o = - match o with - | FStar_Pervasives_Native.None -> Unset - | FStar_Pervasives_Native.Some s -> tag s in - set_option "initial_fuel" (Int (vcfg.FStar_VConfig.initial_fuel)); - set_option "max_fuel" (Int (vcfg.FStar_VConfig.max_fuel)); - set_option "initial_ifuel" (Int (vcfg.FStar_VConfig.initial_ifuel)); - set_option "max_ifuel" (Int (vcfg.FStar_VConfig.max_ifuel)); - set_option "detail_errors" (Bool (vcfg.FStar_VConfig.detail_errors)); - set_option "detail_hint_replay" - (Bool (vcfg.FStar_VConfig.detail_hint_replay)); - set_option "no_smt" (Bool (vcfg.FStar_VConfig.no_smt)); - set_option "quake_lo" (Int (vcfg.FStar_VConfig.quake_lo)); - set_option "quake_hi" (Int (vcfg.FStar_VConfig.quake_hi)); - set_option "quake_keep" (Bool (vcfg.FStar_VConfig.quake_keep)); - set_option "retry" (Bool (vcfg.FStar_VConfig.retry)); - set_option "smtencoding.elim_box" - (Bool (vcfg.FStar_VConfig.smtencoding_elim_box)); - set_option "smtencoding.nl_arith_repr" - (String (vcfg.FStar_VConfig.smtencoding_nl_arith_repr)); - set_option "smtencoding.l_arith_repr" - (String (vcfg.FStar_VConfig.smtencoding_l_arith_repr)); - set_option "smtencoding.valid_intro" - (Bool (vcfg.FStar_VConfig.smtencoding_valid_intro)); - set_option "smtencoding.valid_elim" - (Bool (vcfg.FStar_VConfig.smtencoding_valid_elim)); - set_option "tcnorm" (Bool (vcfg.FStar_VConfig.tcnorm)); - set_option "no_plugins" (Bool (vcfg.FStar_VConfig.no_plugins)); - set_option "no_tactics" (Bool (vcfg.FStar_VConfig.no_tactics)); - (let uu___22 = - let uu___23 = - FStar_Compiler_List.map (fun uu___24 -> String uu___24) - vcfg.FStar_VConfig.z3cliopt in - List uu___23 in - set_option "z3cliopt" uu___22); - (let uu___23 = - let uu___24 = - FStar_Compiler_List.map (fun uu___25 -> String uu___25) - vcfg.FStar_VConfig.z3smtopt in - List uu___24 in - set_option "z3smtopt" uu___23); - set_option "z3refresh" (Bool (vcfg.FStar_VConfig.z3refresh)); - set_option "z3rlimit" (Int (vcfg.FStar_VConfig.z3rlimit)); - set_option "z3rlimit_factor" (Int (vcfg.FStar_VConfig.z3rlimit_factor)); - set_option "z3seed" (Int (vcfg.FStar_VConfig.z3seed)); - set_option "z3version" (String (vcfg.FStar_VConfig.z3version)); - set_option "trivial_pre_for_unannotated_effectful_fns" - (Bool (vcfg.FStar_VConfig.trivial_pre_for_unannotated_effectful_fns)); - (let uu___30 = - option_as (fun uu___31 -> String uu___31) - vcfg.FStar_VConfig.reuse_hint_for in - set_option "reuse_hint_for" uu___30) -let (showable_codegen_t : codegen_t FStar_Class_Show.showable) = - { FStar_Class_Show.show = print_codegen } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Options_Ext.ml b/ocaml/fstar-lib/generated/FStar_Options_Ext.ml deleted file mode 100644 index c16437ff48b..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Options_Ext.ml +++ /dev/null @@ -1,67 +0,0 @@ -open Prims -type key = Prims.string -type value = Prims.string -type ext_state = - | E of Prims.string FStar_Compiler_Util.psmap -let (uu___is_E : ext_state -> Prims.bool) = fun projectee -> true -let (__proj__E__item__map : - ext_state -> Prims.string FStar_Compiler_Util.psmap) = - fun projectee -> match projectee with | E map -> map -let (cur_state : ext_state FStar_Compiler_Effect.ref) = - let uu___ = let uu___1 = FStar_Compiler_Util.psmap_empty () in E uu___1 in - FStar_Compiler_Util.mk_ref uu___ -let (set : key -> value -> unit) = - fun k -> - fun v -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Compiler_Effect.op_Bang cur_state in - __proj__E__item__map uu___3 in - FStar_Compiler_Util.psmap_add uu___2 k v in - E uu___1 in - FStar_Compiler_Effect.op_Colon_Equals cur_state uu___ -let (get : key -> value) = - fun k -> - let r = - let uu___ = - let uu___1 = - let uu___2 = FStar_Compiler_Effect.op_Bang cur_state in - __proj__E__item__map uu___2 in - FStar_Compiler_Util.psmap_try_find uu___1 k in - match uu___ with - | FStar_Pervasives_Native.None -> "" - | FStar_Pervasives_Native.Some v -> v in - r -let (is_prefix : Prims.string -> Prims.string -> Prims.bool) = - fun s1 -> - fun s2 -> - let l1 = FStar_Compiler_String.length s1 in - let l2 = FStar_Compiler_String.length s2 in - (l2 >= l1) && - (let uu___ = FStar_Compiler_String.substring s2 Prims.int_zero l1 in - uu___ = s1) -let (getns : Prims.string -> (key * value) Prims.list) = - fun ns -> - let f k v acc = - let uu___ = is_prefix (Prims.strcat ns ":") k in - if uu___ then (k, v) :: acc else acc in - let uu___ = - let uu___1 = FStar_Compiler_Effect.op_Bang cur_state in - __proj__E__item__map uu___1 in - FStar_Compiler_Util.psmap_fold uu___ f [] -let (all : unit -> (key * value) Prims.list) = - fun uu___ -> - let f k v acc = (k, v) :: acc in - let uu___1 = - let uu___2 = FStar_Compiler_Effect.op_Bang cur_state in - __proj__E__item__map uu___2 in - FStar_Compiler_Util.psmap_fold uu___1 f [] -let (save : unit -> ext_state) = - fun uu___ -> FStar_Compiler_Effect.op_Bang cur_state -let (restore : ext_state -> unit) = - fun s -> FStar_Compiler_Effect.op_Colon_Equals cur_state s -let (reset : unit -> unit) = - fun uu___ -> - let uu___1 = let uu___2 = FStar_Compiler_Util.psmap_empty () in E uu___2 in - FStar_Compiler_Effect.op_Colon_Equals cur_state uu___1 \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Order.ml b/ocaml/fstar-lib/generated/FStar_Order.ml index 14625f8a6ea..f9bf2ea67c8 100644 --- a/ocaml/fstar-lib/generated/FStar_Order.ml +++ b/ocaml/fstar-lib/generated/FStar_Order.ml @@ -4,7 +4,7 @@ type order = | Eq | Gt let rec __knot_e_order _ = - FStar_Syntax_Embeddings_Base.mk_extracted_embedding "FStar.Order.order" + FStarC_Syntax_Embeddings_Base.mk_extracted_embedding "FStar.Order.order" (fun tm_0 -> match tm_0 with | ("FStar.Order.Lt", []) -> FStar_Pervasives_Native.Some Lt @@ -14,17 +14,17 @@ let rec __knot_e_order _ = (fun tm_4 -> match tm_4 with | Lt -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Order.Lt")) [] + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Order.Lt")) [] | Eq -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Order.Eq")) [] + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Order.Eq")) [] | Gt -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Order.Gt")) []) + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Order.Gt")) []) let e_order = __knot_e_order () let (uu___is_Lt : order -> Prims.bool) = fun projectee -> match projectee with | Lt -> true | uu___ -> false diff --git a/ocaml/fstar-lib/generated/FStar_Parser_AST.ml b/ocaml/fstar-lib/generated/FStar_Parser_AST.ml deleted file mode 100644 index dd282e3e22f..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Parser_AST.ml +++ /dev/null @@ -1,2769 +0,0 @@ -open Prims -type level = - | Un - | Expr - | Type_level - | Kind - | Formula -let (uu___is_Un : level -> Prims.bool) = - fun projectee -> match projectee with | Un -> true | uu___ -> false -let (uu___is_Expr : level -> Prims.bool) = - fun projectee -> match projectee with | Expr -> true | uu___ -> false -let (uu___is_Type_level : level -> Prims.bool) = - fun projectee -> match projectee with | Type_level -> true | uu___ -> false -let (uu___is_Kind : level -> Prims.bool) = - fun projectee -> match projectee with | Kind -> true | uu___ -> false -let (uu___is_Formula : level -> Prims.bool) = - fun projectee -> match projectee with | Formula -> true | uu___ -> false -type let_qualifier = - | NoLetQualifier - | Rec -let (uu___is_NoLetQualifier : let_qualifier -> Prims.bool) = - fun projectee -> - match projectee with | NoLetQualifier -> true | uu___ -> false -let (uu___is_Rec : let_qualifier -> Prims.bool) = - fun projectee -> match projectee with | Rec -> true | uu___ -> false -type quote_kind = - | Static - | Dynamic -let (uu___is_Static : quote_kind -> Prims.bool) = - fun projectee -> match projectee with | Static -> true | uu___ -> false -let (uu___is_Dynamic : quote_kind -> Prims.bool) = - fun projectee -> match projectee with | Dynamic -> true | uu___ -> false -type term' = - | Wild - | Const of FStar_Const.sconst - | Op of (FStar_Ident.ident * term Prims.list) - | Tvar of FStar_Ident.ident - | Uvar of FStar_Ident.ident - | Var of FStar_Ident.lid - | Name of FStar_Ident.lid - | Projector of (FStar_Ident.lid * FStar_Ident.ident) - | Construct of (FStar_Ident.lid * (term * imp) Prims.list) - | Abs of (pattern Prims.list * term) - | Function of ((pattern * term FStar_Pervasives_Native.option * term) - Prims.list * FStar_Compiler_Range_Type.range) - | App of (term * term * imp) - | Let of (let_qualifier * (term Prims.list FStar_Pervasives_Native.option * - (pattern * term)) Prims.list * term) - | LetOperator of ((FStar_Ident.ident * pattern * term) Prims.list * term) - | LetOpen of (FStar_Ident.lid * term) - | LetOpenRecord of (term * term * term) - | Seq of (term * term) - | Bind of (FStar_Ident.ident * term * term) - | If of (term * FStar_Ident.ident FStar_Pervasives_Native.option * - (FStar_Ident.ident FStar_Pervasives_Native.option * term * Prims.bool) - FStar_Pervasives_Native.option * term * term) - | Match of (term * FStar_Ident.ident FStar_Pervasives_Native.option * - (FStar_Ident.ident FStar_Pervasives_Native.option * term * Prims.bool) - FStar_Pervasives_Native.option * (pattern * term - FStar_Pervasives_Native.option * term) Prims.list) - | TryWith of (term * (pattern * term FStar_Pervasives_Native.option * term) - Prims.list) - | Ascribed of (term * term * term FStar_Pervasives_Native.option * - Prims.bool) - | Record of (term FStar_Pervasives_Native.option * (FStar_Ident.lid * term) - Prims.list) - | Project of (term * FStar_Ident.lid) - | Product of (binder Prims.list * term) - | Sum of ((binder, term) FStar_Pervasives.either Prims.list * term) - | QForall of (binder Prims.list * (FStar_Ident.ident Prims.list * term - Prims.list Prims.list) * term) - | QExists of (binder Prims.list * (FStar_Ident.ident Prims.list * term - Prims.list Prims.list) * term) - | QuantOp of (FStar_Ident.ident * binder Prims.list * (FStar_Ident.ident - Prims.list * term Prims.list Prims.list) * term) - | Refine of (binder * term) - | NamedTyp of (FStar_Ident.ident * term) - | Paren of term - | Requires of (term * Prims.string FStar_Pervasives_Native.option) - | Ensures of (term * Prims.string FStar_Pervasives_Native.option) - | LexList of term Prims.list - | WFOrder of (term * term) - | Decreases of (term * Prims.string FStar_Pervasives_Native.option) - | Labeled of (term * Prims.string * Prims.bool) - | Discrim of FStar_Ident.lid - | Attributes of term Prims.list - | Antiquote of term - | Quote of (term * quote_kind) - | VQuote of term - | CalcProof of (term * term * calc_step Prims.list) - | IntroForall of (binder Prims.list * term * term) - | IntroExists of (binder Prims.list * term * term Prims.list * term) - | IntroImplies of (term * term * binder * term) - | IntroOr of (Prims.bool * term * term * term) - | IntroAnd of (term * term * term * term) - | ElimForall of (binder Prims.list * term * term Prims.list) - | ElimExists of (binder Prims.list * term * term * binder * term) - | ElimImplies of (term * term * term) - | ElimOr of (term * term * term * binder * term * binder * term) - | ElimAnd of (term * term * term * binder * binder * term) - | ListLiteral of term Prims.list - | SeqLiteral of term Prims.list -and term = { - tm: term' ; - range: FStar_Compiler_Range_Type.range ; - level: level } -and calc_step = - | CalcStep of (term * term * term) -and binder' = - | Variable of FStar_Ident.ident - | TVariable of FStar_Ident.ident - | Annotated of (FStar_Ident.ident * term) - | TAnnotated of (FStar_Ident.ident * term) - | NoName of term -and binder = - { - b: binder' ; - brange: FStar_Compiler_Range_Type.range ; - blevel: level ; - aqual: arg_qualifier FStar_Pervasives_Native.option ; - battributes: term Prims.list } -and pattern' = - | PatWild of (arg_qualifier FStar_Pervasives_Native.option * term - Prims.list) - | PatConst of FStar_Const.sconst - | PatApp of (pattern * pattern Prims.list) - | PatVar of (FStar_Ident.ident * arg_qualifier - FStar_Pervasives_Native.option * term Prims.list) - | PatName of FStar_Ident.lid - | PatTvar of (FStar_Ident.ident * arg_qualifier - FStar_Pervasives_Native.option * term Prims.list) - | PatList of pattern Prims.list - | PatTuple of (pattern Prims.list * Prims.bool) - | PatRecord of (FStar_Ident.lid * pattern) Prims.list - | PatAscribed of (pattern * (term * term FStar_Pervasives_Native.option)) - | PatOr of pattern Prims.list - | PatOp of FStar_Ident.ident - | PatVQuote of term -and pattern = { - pat: pattern' ; - prange: FStar_Compiler_Range_Type.range } -and arg_qualifier = - | Implicit - | Equality - | Meta of term - | TypeClassArg -and imp = - | FsTypApp - | Hash - | UnivApp - | HashBrace of term - | Infix - | Nothing -let (uu___is_Wild : term' -> Prims.bool) = - fun projectee -> match projectee with | Wild -> true | uu___ -> false -let (uu___is_Const : term' -> Prims.bool) = - fun projectee -> match projectee with | Const _0 -> true | uu___ -> false -let (__proj__Const__item___0 : term' -> FStar_Const.sconst) = - fun projectee -> match projectee with | Const _0 -> _0 -let (uu___is_Op : term' -> Prims.bool) = - fun projectee -> match projectee with | Op _0 -> true | uu___ -> false -let (__proj__Op__item___0 : term' -> (FStar_Ident.ident * term Prims.list)) = - fun projectee -> match projectee with | Op _0 -> _0 -let (uu___is_Tvar : term' -> Prims.bool) = - fun projectee -> match projectee with | Tvar _0 -> true | uu___ -> false -let (__proj__Tvar__item___0 : term' -> FStar_Ident.ident) = - fun projectee -> match projectee with | Tvar _0 -> _0 -let (uu___is_Uvar : term' -> Prims.bool) = - fun projectee -> match projectee with | Uvar _0 -> true | uu___ -> false -let (__proj__Uvar__item___0 : term' -> FStar_Ident.ident) = - fun projectee -> match projectee with | Uvar _0 -> _0 -let (uu___is_Var : term' -> Prims.bool) = - fun projectee -> match projectee with | Var _0 -> true | uu___ -> false -let (__proj__Var__item___0 : term' -> FStar_Ident.lid) = - fun projectee -> match projectee with | Var _0 -> _0 -let (uu___is_Name : term' -> Prims.bool) = - fun projectee -> match projectee with | Name _0 -> true | uu___ -> false -let (__proj__Name__item___0 : term' -> FStar_Ident.lid) = - fun projectee -> match projectee with | Name _0 -> _0 -let (uu___is_Projector : term' -> Prims.bool) = - fun projectee -> - match projectee with | Projector _0 -> true | uu___ -> false -let (__proj__Projector__item___0 : - term' -> (FStar_Ident.lid * FStar_Ident.ident)) = - fun projectee -> match projectee with | Projector _0 -> _0 -let (uu___is_Construct : term' -> Prims.bool) = - fun projectee -> - match projectee with | Construct _0 -> true | uu___ -> false -let (__proj__Construct__item___0 : - term' -> (FStar_Ident.lid * (term * imp) Prims.list)) = - fun projectee -> match projectee with | Construct _0 -> _0 -let (uu___is_Abs : term' -> Prims.bool) = - fun projectee -> match projectee with | Abs _0 -> true | uu___ -> false -let (__proj__Abs__item___0 : term' -> (pattern Prims.list * term)) = - fun projectee -> match projectee with | Abs _0 -> _0 -let (uu___is_Function : term' -> Prims.bool) = - fun projectee -> - match projectee with | Function _0 -> true | uu___ -> false -let (__proj__Function__item___0 : - term' -> - ((pattern * term FStar_Pervasives_Native.option * term) Prims.list * - FStar_Compiler_Range_Type.range)) - = fun projectee -> match projectee with | Function _0 -> _0 -let (uu___is_App : term' -> Prims.bool) = - fun projectee -> match projectee with | App _0 -> true | uu___ -> false -let (__proj__App__item___0 : term' -> (term * term * imp)) = - fun projectee -> match projectee with | App _0 -> _0 -let (uu___is_Let : term' -> Prims.bool) = - fun projectee -> match projectee with | Let _0 -> true | uu___ -> false -let (__proj__Let__item___0 : - term' -> - (let_qualifier * (term Prims.list FStar_Pervasives_Native.option * - (pattern * term)) Prims.list * term)) - = fun projectee -> match projectee with | Let _0 -> _0 -let (uu___is_LetOperator : term' -> Prims.bool) = - fun projectee -> - match projectee with | LetOperator _0 -> true | uu___ -> false -let (__proj__LetOperator__item___0 : - term' -> ((FStar_Ident.ident * pattern * term) Prims.list * term)) = - fun projectee -> match projectee with | LetOperator _0 -> _0 -let (uu___is_LetOpen : term' -> Prims.bool) = - fun projectee -> match projectee with | LetOpen _0 -> true | uu___ -> false -let (__proj__LetOpen__item___0 : term' -> (FStar_Ident.lid * term)) = - fun projectee -> match projectee with | LetOpen _0 -> _0 -let (uu___is_LetOpenRecord : term' -> Prims.bool) = - fun projectee -> - match projectee with | LetOpenRecord _0 -> true | uu___ -> false -let (__proj__LetOpenRecord__item___0 : term' -> (term * term * term)) = - fun projectee -> match projectee with | LetOpenRecord _0 -> _0 -let (uu___is_Seq : term' -> Prims.bool) = - fun projectee -> match projectee with | Seq _0 -> true | uu___ -> false -let (__proj__Seq__item___0 : term' -> (term * term)) = - fun projectee -> match projectee with | Seq _0 -> _0 -let (uu___is_Bind : term' -> Prims.bool) = - fun projectee -> match projectee with | Bind _0 -> true | uu___ -> false -let (__proj__Bind__item___0 : term' -> (FStar_Ident.ident * term * term)) = - fun projectee -> match projectee with | Bind _0 -> _0 -let (uu___is_If : term' -> Prims.bool) = - fun projectee -> match projectee with | If _0 -> true | uu___ -> false -let (__proj__If__item___0 : - term' -> - (term * FStar_Ident.ident FStar_Pervasives_Native.option * - (FStar_Ident.ident FStar_Pervasives_Native.option * term * Prims.bool) - FStar_Pervasives_Native.option * term * term)) - = fun projectee -> match projectee with | If _0 -> _0 -let (uu___is_Match : term' -> Prims.bool) = - fun projectee -> match projectee with | Match _0 -> true | uu___ -> false -let (__proj__Match__item___0 : - term' -> - (term * FStar_Ident.ident FStar_Pervasives_Native.option * - (FStar_Ident.ident FStar_Pervasives_Native.option * term * Prims.bool) - FStar_Pervasives_Native.option * (pattern * term - FStar_Pervasives_Native.option * term) Prims.list)) - = fun projectee -> match projectee with | Match _0 -> _0 -let (uu___is_TryWith : term' -> Prims.bool) = - fun projectee -> match projectee with | TryWith _0 -> true | uu___ -> false -let (__proj__TryWith__item___0 : - term' -> - (term * (pattern * term FStar_Pervasives_Native.option * term) - Prims.list)) - = fun projectee -> match projectee with | TryWith _0 -> _0 -let (uu___is_Ascribed : term' -> Prims.bool) = - fun projectee -> - match projectee with | Ascribed _0 -> true | uu___ -> false -let (__proj__Ascribed__item___0 : - term' -> (term * term * term FStar_Pervasives_Native.option * Prims.bool)) - = fun projectee -> match projectee with | Ascribed _0 -> _0 -let (uu___is_Record : term' -> Prims.bool) = - fun projectee -> match projectee with | Record _0 -> true | uu___ -> false -let (__proj__Record__item___0 : - term' -> - (term FStar_Pervasives_Native.option * (FStar_Ident.lid * term) - Prims.list)) - = fun projectee -> match projectee with | Record _0 -> _0 -let (uu___is_Project : term' -> Prims.bool) = - fun projectee -> match projectee with | Project _0 -> true | uu___ -> false -let (__proj__Project__item___0 : term' -> (term * FStar_Ident.lid)) = - fun projectee -> match projectee with | Project _0 -> _0 -let (uu___is_Product : term' -> Prims.bool) = - fun projectee -> match projectee with | Product _0 -> true | uu___ -> false -let (__proj__Product__item___0 : term' -> (binder Prims.list * term)) = - fun projectee -> match projectee with | Product _0 -> _0 -let (uu___is_Sum : term' -> Prims.bool) = - fun projectee -> match projectee with | Sum _0 -> true | uu___ -> false -let (__proj__Sum__item___0 : - term' -> ((binder, term) FStar_Pervasives.either Prims.list * term)) = - fun projectee -> match projectee with | Sum _0 -> _0 -let (uu___is_QForall : term' -> Prims.bool) = - fun projectee -> match projectee with | QForall _0 -> true | uu___ -> false -let (__proj__QForall__item___0 : - term' -> - (binder Prims.list * (FStar_Ident.ident Prims.list * term Prims.list - Prims.list) * term)) - = fun projectee -> match projectee with | QForall _0 -> _0 -let (uu___is_QExists : term' -> Prims.bool) = - fun projectee -> match projectee with | QExists _0 -> true | uu___ -> false -let (__proj__QExists__item___0 : - term' -> - (binder Prims.list * (FStar_Ident.ident Prims.list * term Prims.list - Prims.list) * term)) - = fun projectee -> match projectee with | QExists _0 -> _0 -let (uu___is_QuantOp : term' -> Prims.bool) = - fun projectee -> match projectee with | QuantOp _0 -> true | uu___ -> false -let (__proj__QuantOp__item___0 : - term' -> - (FStar_Ident.ident * binder Prims.list * (FStar_Ident.ident Prims.list * - term Prims.list Prims.list) * term)) - = fun projectee -> match projectee with | QuantOp _0 -> _0 -let (uu___is_Refine : term' -> Prims.bool) = - fun projectee -> match projectee with | Refine _0 -> true | uu___ -> false -let (__proj__Refine__item___0 : term' -> (binder * term)) = - fun projectee -> match projectee with | Refine _0 -> _0 -let (uu___is_NamedTyp : term' -> Prims.bool) = - fun projectee -> - match projectee with | NamedTyp _0 -> true | uu___ -> false -let (__proj__NamedTyp__item___0 : term' -> (FStar_Ident.ident * term)) = - fun projectee -> match projectee with | NamedTyp _0 -> _0 -let (uu___is_Paren : term' -> Prims.bool) = - fun projectee -> match projectee with | Paren _0 -> true | uu___ -> false -let (__proj__Paren__item___0 : term' -> term) = - fun projectee -> match projectee with | Paren _0 -> _0 -let (uu___is_Requires : term' -> Prims.bool) = - fun projectee -> - match projectee with | Requires _0 -> true | uu___ -> false -let (__proj__Requires__item___0 : - term' -> (term * Prims.string FStar_Pervasives_Native.option)) = - fun projectee -> match projectee with | Requires _0 -> _0 -let (uu___is_Ensures : term' -> Prims.bool) = - fun projectee -> match projectee with | Ensures _0 -> true | uu___ -> false -let (__proj__Ensures__item___0 : - term' -> (term * Prims.string FStar_Pervasives_Native.option)) = - fun projectee -> match projectee with | Ensures _0 -> _0 -let (uu___is_LexList : term' -> Prims.bool) = - fun projectee -> match projectee with | LexList _0 -> true | uu___ -> false -let (__proj__LexList__item___0 : term' -> term Prims.list) = - fun projectee -> match projectee with | LexList _0 -> _0 -let (uu___is_WFOrder : term' -> Prims.bool) = - fun projectee -> match projectee with | WFOrder _0 -> true | uu___ -> false -let (__proj__WFOrder__item___0 : term' -> (term * term)) = - fun projectee -> match projectee with | WFOrder _0 -> _0 -let (uu___is_Decreases : term' -> Prims.bool) = - fun projectee -> - match projectee with | Decreases _0 -> true | uu___ -> false -let (__proj__Decreases__item___0 : - term' -> (term * Prims.string FStar_Pervasives_Native.option)) = - fun projectee -> match projectee with | Decreases _0 -> _0 -let (uu___is_Labeled : term' -> Prims.bool) = - fun projectee -> match projectee with | Labeled _0 -> true | uu___ -> false -let (__proj__Labeled__item___0 : term' -> (term * Prims.string * Prims.bool)) - = fun projectee -> match projectee with | Labeled _0 -> _0 -let (uu___is_Discrim : term' -> Prims.bool) = - fun projectee -> match projectee with | Discrim _0 -> true | uu___ -> false -let (__proj__Discrim__item___0 : term' -> FStar_Ident.lid) = - fun projectee -> match projectee with | Discrim _0 -> _0 -let (uu___is_Attributes : term' -> Prims.bool) = - fun projectee -> - match projectee with | Attributes _0 -> true | uu___ -> false -let (__proj__Attributes__item___0 : term' -> term Prims.list) = - fun projectee -> match projectee with | Attributes _0 -> _0 -let (uu___is_Antiquote : term' -> Prims.bool) = - fun projectee -> - match projectee with | Antiquote _0 -> true | uu___ -> false -let (__proj__Antiquote__item___0 : term' -> term) = - fun projectee -> match projectee with | Antiquote _0 -> _0 -let (uu___is_Quote : term' -> Prims.bool) = - fun projectee -> match projectee with | Quote _0 -> true | uu___ -> false -let (__proj__Quote__item___0 : term' -> (term * quote_kind)) = - fun projectee -> match projectee with | Quote _0 -> _0 -let (uu___is_VQuote : term' -> Prims.bool) = - fun projectee -> match projectee with | VQuote _0 -> true | uu___ -> false -let (__proj__VQuote__item___0 : term' -> term) = - fun projectee -> match projectee with | VQuote _0 -> _0 -let (uu___is_CalcProof : term' -> Prims.bool) = - fun projectee -> - match projectee with | CalcProof _0 -> true | uu___ -> false -let (__proj__CalcProof__item___0 : - term' -> (term * term * calc_step Prims.list)) = - fun projectee -> match projectee with | CalcProof _0 -> _0 -let (uu___is_IntroForall : term' -> Prims.bool) = - fun projectee -> - match projectee with | IntroForall _0 -> true | uu___ -> false -let (__proj__IntroForall__item___0 : - term' -> (binder Prims.list * term * term)) = - fun projectee -> match projectee with | IntroForall _0 -> _0 -let (uu___is_IntroExists : term' -> Prims.bool) = - fun projectee -> - match projectee with | IntroExists _0 -> true | uu___ -> false -let (__proj__IntroExists__item___0 : - term' -> (binder Prims.list * term * term Prims.list * term)) = - fun projectee -> match projectee with | IntroExists _0 -> _0 -let (uu___is_IntroImplies : term' -> Prims.bool) = - fun projectee -> - match projectee with | IntroImplies _0 -> true | uu___ -> false -let (__proj__IntroImplies__item___0 : term' -> (term * term * binder * term)) - = fun projectee -> match projectee with | IntroImplies _0 -> _0 -let (uu___is_IntroOr : term' -> Prims.bool) = - fun projectee -> match projectee with | IntroOr _0 -> true | uu___ -> false -let (__proj__IntroOr__item___0 : term' -> (Prims.bool * term * term * term)) - = fun projectee -> match projectee with | IntroOr _0 -> _0 -let (uu___is_IntroAnd : term' -> Prims.bool) = - fun projectee -> - match projectee with | IntroAnd _0 -> true | uu___ -> false -let (__proj__IntroAnd__item___0 : term' -> (term * term * term * term)) = - fun projectee -> match projectee with | IntroAnd _0 -> _0 -let (uu___is_ElimForall : term' -> Prims.bool) = - fun projectee -> - match projectee with | ElimForall _0 -> true | uu___ -> false -let (__proj__ElimForall__item___0 : - term' -> (binder Prims.list * term * term Prims.list)) = - fun projectee -> match projectee with | ElimForall _0 -> _0 -let (uu___is_ElimExists : term' -> Prims.bool) = - fun projectee -> - match projectee with | ElimExists _0 -> true | uu___ -> false -let (__proj__ElimExists__item___0 : - term' -> (binder Prims.list * term * term * binder * term)) = - fun projectee -> match projectee with | ElimExists _0 -> _0 -let (uu___is_ElimImplies : term' -> Prims.bool) = - fun projectee -> - match projectee with | ElimImplies _0 -> true | uu___ -> false -let (__proj__ElimImplies__item___0 : term' -> (term * term * term)) = - fun projectee -> match projectee with | ElimImplies _0 -> _0 -let (uu___is_ElimOr : term' -> Prims.bool) = - fun projectee -> match projectee with | ElimOr _0 -> true | uu___ -> false -let (__proj__ElimOr__item___0 : - term' -> (term * term * term * binder * term * binder * term)) = - fun projectee -> match projectee with | ElimOr _0 -> _0 -let (uu___is_ElimAnd : term' -> Prims.bool) = - fun projectee -> match projectee with | ElimAnd _0 -> true | uu___ -> false -let (__proj__ElimAnd__item___0 : - term' -> (term * term * term * binder * binder * term)) = - fun projectee -> match projectee with | ElimAnd _0 -> _0 -let (uu___is_ListLiteral : term' -> Prims.bool) = - fun projectee -> - match projectee with | ListLiteral _0 -> true | uu___ -> false -let (__proj__ListLiteral__item___0 : term' -> term Prims.list) = - fun projectee -> match projectee with | ListLiteral _0 -> _0 -let (uu___is_SeqLiteral : term' -> Prims.bool) = - fun projectee -> - match projectee with | SeqLiteral _0 -> true | uu___ -> false -let (__proj__SeqLiteral__item___0 : term' -> term Prims.list) = - fun projectee -> match projectee with | SeqLiteral _0 -> _0 -let (__proj__Mkterm__item__tm : term -> term') = - fun projectee -> - match projectee with | { tm; range; level = level1;_} -> tm -let (__proj__Mkterm__item__range : term -> FStar_Compiler_Range_Type.range) = - fun projectee -> - match projectee with | { tm; range; level = level1;_} -> range -let (__proj__Mkterm__item__level : term -> level) = - fun projectee -> - match projectee with | { tm; range; level = level1;_} -> level1 -let (uu___is_CalcStep : calc_step -> Prims.bool) = fun projectee -> true -let (__proj__CalcStep__item___0 : calc_step -> (term * term * term)) = - fun projectee -> match projectee with | CalcStep _0 -> _0 -let (uu___is_Variable : binder' -> Prims.bool) = - fun projectee -> - match projectee with | Variable _0 -> true | uu___ -> false -let (__proj__Variable__item___0 : binder' -> FStar_Ident.ident) = - fun projectee -> match projectee with | Variable _0 -> _0 -let (uu___is_TVariable : binder' -> Prims.bool) = - fun projectee -> - match projectee with | TVariable _0 -> true | uu___ -> false -let (__proj__TVariable__item___0 : binder' -> FStar_Ident.ident) = - fun projectee -> match projectee with | TVariable _0 -> _0 -let (uu___is_Annotated : binder' -> Prims.bool) = - fun projectee -> - match projectee with | Annotated _0 -> true | uu___ -> false -let (__proj__Annotated__item___0 : binder' -> (FStar_Ident.ident * term)) = - fun projectee -> match projectee with | Annotated _0 -> _0 -let (uu___is_TAnnotated : binder' -> Prims.bool) = - fun projectee -> - match projectee with | TAnnotated _0 -> true | uu___ -> false -let (__proj__TAnnotated__item___0 : binder' -> (FStar_Ident.ident * term)) = - fun projectee -> match projectee with | TAnnotated _0 -> _0 -let (uu___is_NoName : binder' -> Prims.bool) = - fun projectee -> match projectee with | NoName _0 -> true | uu___ -> false -let (__proj__NoName__item___0 : binder' -> term) = - fun projectee -> match projectee with | NoName _0 -> _0 -let (__proj__Mkbinder__item__b : binder -> binder') = - fun projectee -> - match projectee with | { b; brange; blevel; aqual; battributes;_} -> b -let (__proj__Mkbinder__item__brange : - binder -> FStar_Compiler_Range_Type.range) = - fun projectee -> - match projectee with - | { b; brange; blevel; aqual; battributes;_} -> brange -let (__proj__Mkbinder__item__blevel : binder -> level) = - fun projectee -> - match projectee with - | { b; brange; blevel; aqual; battributes;_} -> blevel -let (__proj__Mkbinder__item__aqual : - binder -> arg_qualifier FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { b; brange; blevel; aqual; battributes;_} -> aqual -let (__proj__Mkbinder__item__battributes : binder -> term Prims.list) = - fun projectee -> - match projectee with - | { b; brange; blevel; aqual; battributes;_} -> battributes -let (uu___is_PatWild : pattern' -> Prims.bool) = - fun projectee -> match projectee with | PatWild _0 -> true | uu___ -> false -let (__proj__PatWild__item___0 : - pattern' -> - (arg_qualifier FStar_Pervasives_Native.option * term Prims.list)) - = fun projectee -> match projectee with | PatWild _0 -> _0 -let (uu___is_PatConst : pattern' -> Prims.bool) = - fun projectee -> - match projectee with | PatConst _0 -> true | uu___ -> false -let (__proj__PatConst__item___0 : pattern' -> FStar_Const.sconst) = - fun projectee -> match projectee with | PatConst _0 -> _0 -let (uu___is_PatApp : pattern' -> Prims.bool) = - fun projectee -> match projectee with | PatApp _0 -> true | uu___ -> false -let (__proj__PatApp__item___0 : pattern' -> (pattern * pattern Prims.list)) = - fun projectee -> match projectee with | PatApp _0 -> _0 -let (uu___is_PatVar : pattern' -> Prims.bool) = - fun projectee -> match projectee with | PatVar _0 -> true | uu___ -> false -let (__proj__PatVar__item___0 : - pattern' -> - (FStar_Ident.ident * arg_qualifier FStar_Pervasives_Native.option * term - Prims.list)) - = fun projectee -> match projectee with | PatVar _0 -> _0 -let (uu___is_PatName : pattern' -> Prims.bool) = - fun projectee -> match projectee with | PatName _0 -> true | uu___ -> false -let (__proj__PatName__item___0 : pattern' -> FStar_Ident.lid) = - fun projectee -> match projectee with | PatName _0 -> _0 -let (uu___is_PatTvar : pattern' -> Prims.bool) = - fun projectee -> match projectee with | PatTvar _0 -> true | uu___ -> false -let (__proj__PatTvar__item___0 : - pattern' -> - (FStar_Ident.ident * arg_qualifier FStar_Pervasives_Native.option * term - Prims.list)) - = fun projectee -> match projectee with | PatTvar _0 -> _0 -let (uu___is_PatList : pattern' -> Prims.bool) = - fun projectee -> match projectee with | PatList _0 -> true | uu___ -> false -let (__proj__PatList__item___0 : pattern' -> pattern Prims.list) = - fun projectee -> match projectee with | PatList _0 -> _0 -let (uu___is_PatTuple : pattern' -> Prims.bool) = - fun projectee -> - match projectee with | PatTuple _0 -> true | uu___ -> false -let (__proj__PatTuple__item___0 : - pattern' -> (pattern Prims.list * Prims.bool)) = - fun projectee -> match projectee with | PatTuple _0 -> _0 -let (uu___is_PatRecord : pattern' -> Prims.bool) = - fun projectee -> - match projectee with | PatRecord _0 -> true | uu___ -> false -let (__proj__PatRecord__item___0 : - pattern' -> (FStar_Ident.lid * pattern) Prims.list) = - fun projectee -> match projectee with | PatRecord _0 -> _0 -let (uu___is_PatAscribed : pattern' -> Prims.bool) = - fun projectee -> - match projectee with | PatAscribed _0 -> true | uu___ -> false -let (__proj__PatAscribed__item___0 : - pattern' -> (pattern * (term * term FStar_Pervasives_Native.option))) = - fun projectee -> match projectee with | PatAscribed _0 -> _0 -let (uu___is_PatOr : pattern' -> Prims.bool) = - fun projectee -> match projectee with | PatOr _0 -> true | uu___ -> false -let (__proj__PatOr__item___0 : pattern' -> pattern Prims.list) = - fun projectee -> match projectee with | PatOr _0 -> _0 -let (uu___is_PatOp : pattern' -> Prims.bool) = - fun projectee -> match projectee with | PatOp _0 -> true | uu___ -> false -let (__proj__PatOp__item___0 : pattern' -> FStar_Ident.ident) = - fun projectee -> match projectee with | PatOp _0 -> _0 -let (uu___is_PatVQuote : pattern' -> Prims.bool) = - fun projectee -> - match projectee with | PatVQuote _0 -> true | uu___ -> false -let (__proj__PatVQuote__item___0 : pattern' -> term) = - fun projectee -> match projectee with | PatVQuote _0 -> _0 -let (__proj__Mkpattern__item__pat : pattern -> pattern') = - fun projectee -> match projectee with | { pat; prange;_} -> pat -let (__proj__Mkpattern__item__prange : - pattern -> FStar_Compiler_Range_Type.range) = - fun projectee -> match projectee with | { pat; prange;_} -> prange -let (uu___is_Implicit : arg_qualifier -> Prims.bool) = - fun projectee -> match projectee with | Implicit -> true | uu___ -> false -let (uu___is_Equality : arg_qualifier -> Prims.bool) = - fun projectee -> match projectee with | Equality -> true | uu___ -> false -let (uu___is_Meta : arg_qualifier -> Prims.bool) = - fun projectee -> match projectee with | Meta _0 -> true | uu___ -> false -let (__proj__Meta__item___0 : arg_qualifier -> term) = - fun projectee -> match projectee with | Meta _0 -> _0 -let (uu___is_TypeClassArg : arg_qualifier -> Prims.bool) = - fun projectee -> - match projectee with | TypeClassArg -> true | uu___ -> false -let (uu___is_FsTypApp : imp -> Prims.bool) = - fun projectee -> match projectee with | FsTypApp -> true | uu___ -> false -let (uu___is_Hash : imp -> Prims.bool) = - fun projectee -> match projectee with | Hash -> true | uu___ -> false -let (uu___is_UnivApp : imp -> Prims.bool) = - fun projectee -> match projectee with | UnivApp -> true | uu___ -> false -let (uu___is_HashBrace : imp -> Prims.bool) = - fun projectee -> - match projectee with | HashBrace _0 -> true | uu___ -> false -let (__proj__HashBrace__item___0 : imp -> term) = - fun projectee -> match projectee with | HashBrace _0 -> _0 -let (uu___is_Infix : imp -> Prims.bool) = - fun projectee -> match projectee with | Infix -> true | uu___ -> false -let (uu___is_Nothing : imp -> Prims.bool) = - fun projectee -> match projectee with | Nothing -> true | uu___ -> false -type match_returns_annotation = - (FStar_Ident.ident FStar_Pervasives_Native.option * term * Prims.bool) -type patterns = (FStar_Ident.ident Prims.list * term Prims.list Prims.list) -type attributes_ = term Prims.list -type branch = (pattern * term FStar_Pervasives_Native.option * term) -type aqual = arg_qualifier FStar_Pervasives_Native.option -let (hasRange_term : term FStar_Class_HasRange.hasRange) = - { - FStar_Class_HasRange.pos = (fun t -> t.range); - FStar_Class_HasRange.setPos = - (fun r -> fun t -> { tm = (t.tm); range = r; level = (t.level) }) - } -let (hasRange_pattern : pattern FStar_Class_HasRange.hasRange) = - { - FStar_Class_HasRange.pos = (fun p -> p.prange); - FStar_Class_HasRange.setPos = - (fun r -> fun p -> { pat = (p.pat); prange = r }) - } -let (hasRange_binder : binder FStar_Class_HasRange.hasRange) = - { - FStar_Class_HasRange.pos = (fun b -> b.brange); - FStar_Class_HasRange.setPos = - (fun r -> - fun b -> - { - b = (b.b); - brange = r; - blevel = (b.blevel); - aqual = (b.aqual); - battributes = (b.battributes) - }) - } -type knd = term -type typ = term -type expr = term -type tycon_record = - (FStar_Ident.ident * aqual * attributes_ * term) Prims.list -type constructor_payload = - | VpOfNotation of typ - | VpArbitrary of typ - | VpRecord of (tycon_record * typ FStar_Pervasives_Native.option) -let (uu___is_VpOfNotation : constructor_payload -> Prims.bool) = - fun projectee -> - match projectee with | VpOfNotation _0 -> true | uu___ -> false -let (__proj__VpOfNotation__item___0 : constructor_payload -> typ) = - fun projectee -> match projectee with | VpOfNotation _0 -> _0 -let (uu___is_VpArbitrary : constructor_payload -> Prims.bool) = - fun projectee -> - match projectee with | VpArbitrary _0 -> true | uu___ -> false -let (__proj__VpArbitrary__item___0 : constructor_payload -> typ) = - fun projectee -> match projectee with | VpArbitrary _0 -> _0 -let (uu___is_VpRecord : constructor_payload -> Prims.bool) = - fun projectee -> - match projectee with | VpRecord _0 -> true | uu___ -> false -let (__proj__VpRecord__item___0 : - constructor_payload -> (tycon_record * typ FStar_Pervasives_Native.option)) - = fun projectee -> match projectee with | VpRecord _0 -> _0 -type tycon = - | TyconAbstract of (FStar_Ident.ident * binder Prims.list * knd - FStar_Pervasives_Native.option) - | TyconAbbrev of (FStar_Ident.ident * binder Prims.list * knd - FStar_Pervasives_Native.option * term) - | TyconRecord of (FStar_Ident.ident * binder Prims.list * knd - FStar_Pervasives_Native.option * attributes_ * tycon_record) - | TyconVariant of (FStar_Ident.ident * binder Prims.list * knd - FStar_Pervasives_Native.option * (FStar_Ident.ident * constructor_payload - FStar_Pervasives_Native.option * attributes_) Prims.list) -let (uu___is_TyconAbstract : tycon -> Prims.bool) = - fun projectee -> - match projectee with | TyconAbstract _0 -> true | uu___ -> false -let (__proj__TyconAbstract__item___0 : - tycon -> - (FStar_Ident.ident * binder Prims.list * knd - FStar_Pervasives_Native.option)) - = fun projectee -> match projectee with | TyconAbstract _0 -> _0 -let (uu___is_TyconAbbrev : tycon -> Prims.bool) = - fun projectee -> - match projectee with | TyconAbbrev _0 -> true | uu___ -> false -let (__proj__TyconAbbrev__item___0 : - tycon -> - (FStar_Ident.ident * binder Prims.list * knd - FStar_Pervasives_Native.option * term)) - = fun projectee -> match projectee with | TyconAbbrev _0 -> _0 -let (uu___is_TyconRecord : tycon -> Prims.bool) = - fun projectee -> - match projectee with | TyconRecord _0 -> true | uu___ -> false -let (__proj__TyconRecord__item___0 : - tycon -> - (FStar_Ident.ident * binder Prims.list * knd - FStar_Pervasives_Native.option * attributes_ * tycon_record)) - = fun projectee -> match projectee with | TyconRecord _0 -> _0 -let (uu___is_TyconVariant : tycon -> Prims.bool) = - fun projectee -> - match projectee with | TyconVariant _0 -> true | uu___ -> false -let (__proj__TyconVariant__item___0 : - tycon -> - (FStar_Ident.ident * binder Prims.list * knd - FStar_Pervasives_Native.option * (FStar_Ident.ident * - constructor_payload FStar_Pervasives_Native.option * attributes_) - Prims.list)) - = fun projectee -> match projectee with | TyconVariant _0 -> _0 -type qualifier = - | Private - | Noeq - | Unopteq - | Assumption - | DefaultEffect - | TotalEffect - | Effect_qual - | New - | Inline - | Visible - | Unfold_for_unification_and_vcgen - | Inline_for_extraction - | Irreducible - | NoExtract - | Reifiable - | Reflectable - | Opaque - | Logic -let (uu___is_Private : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Private -> true | uu___ -> false -let (uu___is_Noeq : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Noeq -> true | uu___ -> false -let (uu___is_Unopteq : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Unopteq -> true | uu___ -> false -let (uu___is_Assumption : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Assumption -> true | uu___ -> false -let (uu___is_DefaultEffect : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | DefaultEffect -> true | uu___ -> false -let (uu___is_TotalEffect : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | TotalEffect -> true | uu___ -> false -let (uu___is_Effect_qual : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | Effect_qual -> true | uu___ -> false -let (uu___is_New : qualifier -> Prims.bool) = - fun projectee -> match projectee with | New -> true | uu___ -> false -let (uu___is_Inline : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Inline -> true | uu___ -> false -let (uu___is_Visible : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Visible -> true | uu___ -> false -let (uu___is_Unfold_for_unification_and_vcgen : qualifier -> Prims.bool) = - fun projectee -> - match projectee with - | Unfold_for_unification_and_vcgen -> true - | uu___ -> false -let (uu___is_Inline_for_extraction : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | Inline_for_extraction -> true | uu___ -> false -let (uu___is_Irreducible : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | Irreducible -> true | uu___ -> false -let (uu___is_NoExtract : qualifier -> Prims.bool) = - fun projectee -> match projectee with | NoExtract -> true | uu___ -> false -let (uu___is_Reifiable : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Reifiable -> true | uu___ -> false -let (uu___is_Reflectable : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | Reflectable -> true | uu___ -> false -let (uu___is_Opaque : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Opaque -> true | uu___ -> false -let (uu___is_Logic : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Logic -> true | uu___ -> false -type qualifiers = qualifier Prims.list -type decoration = - | Qualifier of qualifier - | DeclAttributes of term Prims.list -let (uu___is_Qualifier : decoration -> Prims.bool) = - fun projectee -> - match projectee with | Qualifier _0 -> true | uu___ -> false -let (__proj__Qualifier__item___0 : decoration -> qualifier) = - fun projectee -> match projectee with | Qualifier _0 -> _0 -let (uu___is_DeclAttributes : decoration -> Prims.bool) = - fun projectee -> - match projectee with | DeclAttributes _0 -> true | uu___ -> false -let (__proj__DeclAttributes__item___0 : decoration -> term Prims.list) = - fun projectee -> match projectee with | DeclAttributes _0 -> _0 -type lift_op = - | NonReifiableLift of term - | ReifiableLift of (term * term) - | LiftForFree of term -let (uu___is_NonReifiableLift : lift_op -> Prims.bool) = - fun projectee -> - match projectee with | NonReifiableLift _0 -> true | uu___ -> false -let (__proj__NonReifiableLift__item___0 : lift_op -> term) = - fun projectee -> match projectee with | NonReifiableLift _0 -> _0 -let (uu___is_ReifiableLift : lift_op -> Prims.bool) = - fun projectee -> - match projectee with | ReifiableLift _0 -> true | uu___ -> false -let (__proj__ReifiableLift__item___0 : lift_op -> (term * term)) = - fun projectee -> match projectee with | ReifiableLift _0 -> _0 -let (uu___is_LiftForFree : lift_op -> Prims.bool) = - fun projectee -> - match projectee with | LiftForFree _0 -> true | uu___ -> false -let (__proj__LiftForFree__item___0 : lift_op -> term) = - fun projectee -> match projectee with | LiftForFree _0 -> _0 -type lift = - { - msource: FStar_Ident.lid ; - mdest: FStar_Ident.lid ; - lift_op: lift_op ; - braced: Prims.bool } -let (__proj__Mklift__item__msource : lift -> FStar_Ident.lid) = - fun projectee -> - match projectee with - | { msource; mdest; lift_op = lift_op1; braced;_} -> msource -let (__proj__Mklift__item__mdest : lift -> FStar_Ident.lid) = - fun projectee -> - match projectee with - | { msource; mdest; lift_op = lift_op1; braced;_} -> mdest -let (__proj__Mklift__item__lift_op : lift -> lift_op) = - fun projectee -> - match projectee with - | { msource; mdest; lift_op = lift_op1; braced;_} -> lift_op1 -let (__proj__Mklift__item__braced : lift -> Prims.bool) = - fun projectee -> - match projectee with - | { msource; mdest; lift_op = lift_op1; braced;_} -> braced -type pragma = - | ShowOptions - | SetOptions of Prims.string - | ResetOptions of Prims.string FStar_Pervasives_Native.option - | PushOptions of Prims.string FStar_Pervasives_Native.option - | PopOptions - | RestartSolver - | PrintEffectsGraph -let (uu___is_ShowOptions : pragma -> Prims.bool) = - fun projectee -> - match projectee with | ShowOptions -> true | uu___ -> false -let (uu___is_SetOptions : pragma -> Prims.bool) = - fun projectee -> - match projectee with | SetOptions _0 -> true | uu___ -> false -let (__proj__SetOptions__item___0 : pragma -> Prims.string) = - fun projectee -> match projectee with | SetOptions _0 -> _0 -let (uu___is_ResetOptions : pragma -> Prims.bool) = - fun projectee -> - match projectee with | ResetOptions _0 -> true | uu___ -> false -let (__proj__ResetOptions__item___0 : - pragma -> Prims.string FStar_Pervasives_Native.option) = - fun projectee -> match projectee with | ResetOptions _0 -> _0 -let (uu___is_PushOptions : pragma -> Prims.bool) = - fun projectee -> - match projectee with | PushOptions _0 -> true | uu___ -> false -let (__proj__PushOptions__item___0 : - pragma -> Prims.string FStar_Pervasives_Native.option) = - fun projectee -> match projectee with | PushOptions _0 -> _0 -let (uu___is_PopOptions : pragma -> Prims.bool) = - fun projectee -> match projectee with | PopOptions -> true | uu___ -> false -let (uu___is_RestartSolver : pragma -> Prims.bool) = - fun projectee -> - match projectee with | RestartSolver -> true | uu___ -> false -let (uu___is_PrintEffectsGraph : pragma -> Prims.bool) = - fun projectee -> - match projectee with | PrintEffectsGraph -> true | uu___ -> false -type dep_scan_callbacks = - { - scan_term: term -> unit ; - scan_binder: binder -> unit ; - scan_pattern: pattern -> unit ; - add_lident: FStar_Ident.lident -> unit ; - add_open: FStar_Ident.lident -> unit } -let (__proj__Mkdep_scan_callbacks__item__scan_term : - dep_scan_callbacks -> term -> unit) = - fun projectee -> - match projectee with - | { scan_term; scan_binder; scan_pattern; add_lident; add_open;_} -> - scan_term -let (__proj__Mkdep_scan_callbacks__item__scan_binder : - dep_scan_callbacks -> binder -> unit) = - fun projectee -> - match projectee with - | { scan_term; scan_binder; scan_pattern; add_lident; add_open;_} -> - scan_binder -let (__proj__Mkdep_scan_callbacks__item__scan_pattern : - dep_scan_callbacks -> pattern -> unit) = - fun projectee -> - match projectee with - | { scan_term; scan_binder; scan_pattern; add_lident; add_open;_} -> - scan_pattern -let (__proj__Mkdep_scan_callbacks__item__add_lident : - dep_scan_callbacks -> FStar_Ident.lident -> unit) = - fun projectee -> - match projectee with - | { scan_term; scan_binder; scan_pattern; add_lident; add_open;_} -> - add_lident -let (__proj__Mkdep_scan_callbacks__item__add_open : - dep_scan_callbacks -> FStar_Ident.lident -> unit) = - fun projectee -> - match projectee with - | { scan_term; scan_binder; scan_pattern; add_lident; add_open;_} -> - add_open -type to_be_desugared = - { - lang_name: Prims.string ; - blob: FStar_Dyn.dyn ; - idents: FStar_Ident.ident Prims.list ; - to_string: FStar_Dyn.dyn -> Prims.string ; - eq: FStar_Dyn.dyn -> FStar_Dyn.dyn -> Prims.bool ; - dep_scan: dep_scan_callbacks -> FStar_Dyn.dyn -> unit } -let (__proj__Mkto_be_desugared__item__lang_name : - to_be_desugared -> Prims.string) = - fun projectee -> - match projectee with - | { lang_name; blob; idents; to_string; eq; dep_scan;_} -> lang_name -let (__proj__Mkto_be_desugared__item__blob : - to_be_desugared -> FStar_Dyn.dyn) = - fun projectee -> - match projectee with - | { lang_name; blob; idents; to_string; eq; dep_scan;_} -> blob -let (__proj__Mkto_be_desugared__item__idents : - to_be_desugared -> FStar_Ident.ident Prims.list) = - fun projectee -> - match projectee with - | { lang_name; blob; idents; to_string; eq; dep_scan;_} -> idents -let (__proj__Mkto_be_desugared__item__to_string : - to_be_desugared -> FStar_Dyn.dyn -> Prims.string) = - fun projectee -> - match projectee with - | { lang_name; blob; idents; to_string; eq; dep_scan;_} -> to_string -let (__proj__Mkto_be_desugared__item__eq : - to_be_desugared -> FStar_Dyn.dyn -> FStar_Dyn.dyn -> Prims.bool) = - fun projectee -> - match projectee with - | { lang_name; blob; idents; to_string; eq; dep_scan;_} -> eq -let (__proj__Mkto_be_desugared__item__dep_scan : - to_be_desugared -> dep_scan_callbacks -> FStar_Dyn.dyn -> unit) = - fun projectee -> - match projectee with - | { lang_name; blob; idents; to_string; eq; dep_scan;_} -> dep_scan -type decl' = - | TopLevelModule of FStar_Ident.lid - | Open of (FStar_Ident.lid * FStar_Syntax_Syntax.restriction) - | Friend of FStar_Ident.lid - | Include of (FStar_Ident.lid * FStar_Syntax_Syntax.restriction) - | ModuleAbbrev of (FStar_Ident.ident * FStar_Ident.lid) - | TopLevelLet of (let_qualifier * (pattern * term) Prims.list) - | Tycon of (Prims.bool * Prims.bool * tycon Prims.list) - | Val of (FStar_Ident.ident * term) - | Exception of (FStar_Ident.ident * term FStar_Pervasives_Native.option) - | NewEffect of effect_decl - | LayeredEffect of effect_decl - | SubEffect of lift - | Polymonadic_bind of (FStar_Ident.lid * FStar_Ident.lid * FStar_Ident.lid - * term) - | Polymonadic_subcomp of (FStar_Ident.lid * FStar_Ident.lid * term) - | Pragma of pragma - | Assume of (FStar_Ident.ident * term) - | Splice of (Prims.bool * FStar_Ident.ident Prims.list * term) - | DeclSyntaxExtension of (Prims.string * Prims.string * - FStar_Compiler_Range_Type.range * FStar_Compiler_Range_Type.range) - | UseLangDecls of Prims.string - | DeclToBeDesugared of to_be_desugared - | Unparseable -and decl = - { - d: decl' ; - drange: FStar_Compiler_Range_Type.range ; - quals: qualifiers ; - attrs: attributes_ ; - interleaved: Prims.bool } -and effect_decl = - | DefineEffect of (FStar_Ident.ident * binder Prims.list * term * decl - Prims.list) - | RedefineEffect of (FStar_Ident.ident * binder Prims.list * term) -let (uu___is_TopLevelModule : decl' -> Prims.bool) = - fun projectee -> - match projectee with | TopLevelModule _0 -> true | uu___ -> false -let (__proj__TopLevelModule__item___0 : decl' -> FStar_Ident.lid) = - fun projectee -> match projectee with | TopLevelModule _0 -> _0 -let (uu___is_Open : decl' -> Prims.bool) = - fun projectee -> match projectee with | Open _0 -> true | uu___ -> false -let (__proj__Open__item___0 : - decl' -> (FStar_Ident.lid * FStar_Syntax_Syntax.restriction)) = - fun projectee -> match projectee with | Open _0 -> _0 -let (uu___is_Friend : decl' -> Prims.bool) = - fun projectee -> match projectee with | Friend _0 -> true | uu___ -> false -let (__proj__Friend__item___0 : decl' -> FStar_Ident.lid) = - fun projectee -> match projectee with | Friend _0 -> _0 -let (uu___is_Include : decl' -> Prims.bool) = - fun projectee -> match projectee with | Include _0 -> true | uu___ -> false -let (__proj__Include__item___0 : - decl' -> (FStar_Ident.lid * FStar_Syntax_Syntax.restriction)) = - fun projectee -> match projectee with | Include _0 -> _0 -let (uu___is_ModuleAbbrev : decl' -> Prims.bool) = - fun projectee -> - match projectee with | ModuleAbbrev _0 -> true | uu___ -> false -let (__proj__ModuleAbbrev__item___0 : - decl' -> (FStar_Ident.ident * FStar_Ident.lid)) = - fun projectee -> match projectee with | ModuleAbbrev _0 -> _0 -let (uu___is_TopLevelLet : decl' -> Prims.bool) = - fun projectee -> - match projectee with | TopLevelLet _0 -> true | uu___ -> false -let (__proj__TopLevelLet__item___0 : - decl' -> (let_qualifier * (pattern * term) Prims.list)) = - fun projectee -> match projectee with | TopLevelLet _0 -> _0 -let (uu___is_Tycon : decl' -> Prims.bool) = - fun projectee -> match projectee with | Tycon _0 -> true | uu___ -> false -let (__proj__Tycon__item___0 : - decl' -> (Prims.bool * Prims.bool * tycon Prims.list)) = - fun projectee -> match projectee with | Tycon _0 -> _0 -let (uu___is_Val : decl' -> Prims.bool) = - fun projectee -> match projectee with | Val _0 -> true | uu___ -> false -let (__proj__Val__item___0 : decl' -> (FStar_Ident.ident * term)) = - fun projectee -> match projectee with | Val _0 -> _0 -let (uu___is_Exception : decl' -> Prims.bool) = - fun projectee -> - match projectee with | Exception _0 -> true | uu___ -> false -let (__proj__Exception__item___0 : - decl' -> (FStar_Ident.ident * term FStar_Pervasives_Native.option)) = - fun projectee -> match projectee with | Exception _0 -> _0 -let (uu___is_NewEffect : decl' -> Prims.bool) = - fun projectee -> - match projectee with | NewEffect _0 -> true | uu___ -> false -let (__proj__NewEffect__item___0 : decl' -> effect_decl) = - fun projectee -> match projectee with | NewEffect _0 -> _0 -let (uu___is_LayeredEffect : decl' -> Prims.bool) = - fun projectee -> - match projectee with | LayeredEffect _0 -> true | uu___ -> false -let (__proj__LayeredEffect__item___0 : decl' -> effect_decl) = - fun projectee -> match projectee with | LayeredEffect _0 -> _0 -let (uu___is_SubEffect : decl' -> Prims.bool) = - fun projectee -> - match projectee with | SubEffect _0 -> true | uu___ -> false -let (__proj__SubEffect__item___0 : decl' -> lift) = - fun projectee -> match projectee with | SubEffect _0 -> _0 -let (uu___is_Polymonadic_bind : decl' -> Prims.bool) = - fun projectee -> - match projectee with | Polymonadic_bind _0 -> true | uu___ -> false -let (__proj__Polymonadic_bind__item___0 : - decl' -> (FStar_Ident.lid * FStar_Ident.lid * FStar_Ident.lid * term)) = - fun projectee -> match projectee with | Polymonadic_bind _0 -> _0 -let (uu___is_Polymonadic_subcomp : decl' -> Prims.bool) = - fun projectee -> - match projectee with | Polymonadic_subcomp _0 -> true | uu___ -> false -let (__proj__Polymonadic_subcomp__item___0 : - decl' -> (FStar_Ident.lid * FStar_Ident.lid * term)) = - fun projectee -> match projectee with | Polymonadic_subcomp _0 -> _0 -let (uu___is_Pragma : decl' -> Prims.bool) = - fun projectee -> match projectee with | Pragma _0 -> true | uu___ -> false -let (__proj__Pragma__item___0 : decl' -> pragma) = - fun projectee -> match projectee with | Pragma _0 -> _0 -let (uu___is_Assume : decl' -> Prims.bool) = - fun projectee -> match projectee with | Assume _0 -> true | uu___ -> false -let (__proj__Assume__item___0 : decl' -> (FStar_Ident.ident * term)) = - fun projectee -> match projectee with | Assume _0 -> _0 -let (uu___is_Splice : decl' -> Prims.bool) = - fun projectee -> match projectee with | Splice _0 -> true | uu___ -> false -let (__proj__Splice__item___0 : - decl' -> (Prims.bool * FStar_Ident.ident Prims.list * term)) = - fun projectee -> match projectee with | Splice _0 -> _0 -let (uu___is_DeclSyntaxExtension : decl' -> Prims.bool) = - fun projectee -> - match projectee with | DeclSyntaxExtension _0 -> true | uu___ -> false -let (__proj__DeclSyntaxExtension__item___0 : - decl' -> - (Prims.string * Prims.string * FStar_Compiler_Range_Type.range * - FStar_Compiler_Range_Type.range)) - = fun projectee -> match projectee with | DeclSyntaxExtension _0 -> _0 -let (uu___is_UseLangDecls : decl' -> Prims.bool) = - fun projectee -> - match projectee with | UseLangDecls _0 -> true | uu___ -> false -let (__proj__UseLangDecls__item___0 : decl' -> Prims.string) = - fun projectee -> match projectee with | UseLangDecls _0 -> _0 -let (uu___is_DeclToBeDesugared : decl' -> Prims.bool) = - fun projectee -> - match projectee with | DeclToBeDesugared _0 -> true | uu___ -> false -let (__proj__DeclToBeDesugared__item___0 : decl' -> to_be_desugared) = - fun projectee -> match projectee with | DeclToBeDesugared _0 -> _0 -let (uu___is_Unparseable : decl' -> Prims.bool) = - fun projectee -> - match projectee with | Unparseable -> true | uu___ -> false -let (__proj__Mkdecl__item__d : decl -> decl') = - fun projectee -> - match projectee with | { d; drange; quals; attrs; interleaved;_} -> d -let (__proj__Mkdecl__item__drange : decl -> FStar_Compiler_Range_Type.range) - = - fun projectee -> - match projectee with - | { d; drange; quals; attrs; interleaved;_} -> drange -let (__proj__Mkdecl__item__quals : decl -> qualifiers) = - fun projectee -> - match projectee with | { d; drange; quals; attrs; interleaved;_} -> quals -let (__proj__Mkdecl__item__attrs : decl -> attributes_) = - fun projectee -> - match projectee with | { d; drange; quals; attrs; interleaved;_} -> attrs -let (__proj__Mkdecl__item__interleaved : decl -> Prims.bool) = - fun projectee -> - match projectee with - | { d; drange; quals; attrs; interleaved;_} -> interleaved -let (uu___is_DefineEffect : effect_decl -> Prims.bool) = - fun projectee -> - match projectee with | DefineEffect _0 -> true | uu___ -> false -let (__proj__DefineEffect__item___0 : - effect_decl -> - (FStar_Ident.ident * binder Prims.list * term * decl Prims.list)) - = fun projectee -> match projectee with | DefineEffect _0 -> _0 -let (uu___is_RedefineEffect : effect_decl -> Prims.bool) = - fun projectee -> - match projectee with | RedefineEffect _0 -> true | uu___ -> false -let (__proj__RedefineEffect__item___0 : - effect_decl -> (FStar_Ident.ident * binder Prims.list * term)) = - fun projectee -> match projectee with | RedefineEffect _0 -> _0 -let (hasRange_decl : decl FStar_Class_HasRange.hasRange) = - { - FStar_Class_HasRange.pos = (fun d -> d.drange); - FStar_Class_HasRange.setPos = - (fun r -> - fun d -> - { - d = (d.d); - drange = r; - quals = (d.quals); - attrs = (d.attrs); - interleaved = (d.interleaved) - }) - } -type modul = - | Module of (FStar_Ident.lid * decl Prims.list) - | Interface of (FStar_Ident.lid * decl Prims.list * Prims.bool) -let (uu___is_Module : modul -> Prims.bool) = - fun projectee -> match projectee with | Module _0 -> true | uu___ -> false -let (__proj__Module__item___0 : modul -> (FStar_Ident.lid * decl Prims.list)) - = fun projectee -> match projectee with | Module _0 -> _0 -let (uu___is_Interface : modul -> Prims.bool) = - fun projectee -> - match projectee with | Interface _0 -> true | uu___ -> false -let (__proj__Interface__item___0 : - modul -> (FStar_Ident.lid * decl Prims.list * Prims.bool)) = - fun projectee -> match projectee with | Interface _0 -> _0 -type file = modul -type inputFragment = (file, decl Prims.list) FStar_Pervasives.either -let (lid_of_modul : modul -> FStar_Ident.lid) = - fun m -> - match m with - | Module (lid, uu___) -> lid - | Interface (lid, uu___, uu___1) -> lid -let (check_id : FStar_Ident.ident -> unit) = - fun id -> - let first_char = - let uu___ = FStar_Ident.string_of_id id in - FStar_Compiler_String.substring uu___ Prims.int_zero Prims.int_one in - if - Prims.op_Negation - ((FStar_Compiler_String.lowercase first_char) = first_char) - then - let uu___ = - let uu___1 = FStar_Class_Show.show FStar_Ident.showable_ident id in - FStar_Compiler_Util.format1 - "Invalid identifer '%s'; expected a symbol that begins with a lower-case character" - uu___1 in - FStar_Errors.raise_error FStar_Ident.hasrange_ident id - FStar_Errors_Codes.Fatal_InvalidIdentifier () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___) - else () -let at_most_one : - 'uuuuu . - Prims.string -> - FStar_Compiler_Range_Type.range -> - 'uuuuu Prims.list -> 'uuuuu FStar_Pervasives_Native.option - = - fun s -> - fun r -> - fun l -> - match l with - | x::[] -> FStar_Pervasives_Native.Some x - | [] -> FStar_Pervasives_Native.None - | uu___ -> - let uu___1 = - FStar_Compiler_Util.format1 - "At most one %s is allowed on declarations" s in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_MoreThanOneDeclaration () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) -let (mk_binder_with_attrs : - binder' -> - FStar_Compiler_Range_Type.range -> - level -> aqual -> term Prims.list -> binder) - = - fun b -> - fun r -> - fun l -> - fun i -> - fun attrs -> - { b; brange = r; blevel = l; aqual = i; battributes = attrs } -let (mk_binder : - binder' -> FStar_Compiler_Range_Type.range -> level -> aqual -> binder) = - fun b -> fun r -> fun l -> fun i -> mk_binder_with_attrs b r l i [] -let (mk_term : term' -> FStar_Compiler_Range_Type.range -> level -> term) = - fun t -> fun r -> fun l -> { tm = t; range = r; level = l } -let (mk_uminus : - term -> - FStar_Compiler_Range_Type.range -> - FStar_Compiler_Range_Type.range -> level -> term) - = - fun t -> - fun rminus -> - fun r -> - fun l -> - let t1 = - match t.tm with - | Const (FStar_Const.Const_int - (s, FStar_Pervasives_Native.Some (FStar_Const.Signed, width))) - -> - Const - (FStar_Const.Const_int - ((Prims.strcat "-" s), - (FStar_Pervasives_Native.Some - (FStar_Const.Signed, width)))) - | uu___ -> - let uu___1 = - let uu___2 = FStar_Ident.mk_ident ("-", rminus) in - (uu___2, [t]) in - Op uu___1 in - mk_term t1 r l -let (mk_pattern : pattern' -> FStar_Compiler_Range_Type.range -> pattern) = - fun p -> fun r -> { pat = p; prange = r } -let (un_curry_abs : pattern Prims.list -> term -> term') = - fun ps -> - fun body -> - match body.tm with - | Abs (p', body') -> Abs ((FStar_Compiler_List.op_At ps p'), body') - | uu___ -> Abs (ps, body) -let (mk_function : - branch Prims.list -> - FStar_Compiler_Range_Type.range -> - FStar_Compiler_Range_Type.range -> term) - = - fun branches -> - fun r1 -> fun r2 -> mk_term (Function (branches, r1)) r2 Expr -let (un_function : - pattern -> term -> (pattern * term) FStar_Pervasives_Native.option) = - fun p -> - fun tm -> - match ((p.pat), (tm.tm)) with - | (PatVar uu___, Abs (pats, body)) -> - let uu___1 = - let uu___2 = mk_pattern (PatApp (p, pats)) p.prange in - (uu___2, body) in - FStar_Pervasives_Native.Some uu___1 - | uu___ -> FStar_Pervasives_Native.None -let (mkApp : - term -> (term * imp) Prims.list -> FStar_Compiler_Range_Type.range -> term) - = - fun t -> - fun args -> - fun r -> - match args with - | [] -> t - | uu___ -> - (match t.tm with - | Name s -> mk_term (Construct (s, args)) r Un - | uu___1 -> - FStar_Compiler_List.fold_left - (fun t1 -> - fun uu___2 -> - match uu___2 with - | (a, imp1) -> mk_term (App (t1, a, imp1)) r Un) t - args) -let (consPat : - FStar_Compiler_Range_Type.range -> pattern -> pattern -> pattern') = - fun r -> - fun hd -> - fun tl -> - let uu___ = - let uu___1 = mk_pattern (PatName FStar_Parser_Const.cons_lid) r in - (uu___1, [hd; tl]) in - PatApp uu___ -let (consTerm : FStar_Compiler_Range_Type.range -> term -> term -> term) = - fun r -> - fun hd -> - fun tl -> - mk_term - (Construct - (FStar_Parser_Const.cons_lid, [(hd, Nothing); (tl, Nothing)])) r - Expr -let (mkListLit : FStar_Compiler_Range_Type.range -> term Prims.list -> term) - = fun r -> fun elts -> mk_term (ListLiteral elts) r Expr -let (mkSeqLit : FStar_Compiler_Range_Type.range -> term Prims.list -> term) = - fun r -> fun elts -> mk_term (SeqLiteral elts) r Expr -let (unit_const : FStar_Compiler_Range_Type.range -> term) = - fun r -> mk_term (Const FStar_Const.Const_unit) r Expr -let (ml_comp : term -> term) = - fun t -> - let lid = FStar_Parser_Const.effect_ML_lid () in - let ml = mk_term (Name lid) t.range Expr in - let t1 = mk_term (App (ml, t, Nothing)) t.range Expr in t1 -let (tot_comp : term -> term) = - fun t -> - let ml = mk_term (Name FStar_Parser_Const.effect_Tot_lid) t.range Expr in - let t1 = mk_term (App (ml, t, Nothing)) t.range Expr in t1 -let (mkRefSet : FStar_Compiler_Range_Type.range -> term Prims.list -> term) = - fun r -> - fun elts -> - let uu___ = - (FStar_Parser_Const.set_empty, FStar_Parser_Const.set_singleton, - FStar_Parser_Const.set_union, FStar_Parser_Const.heap_addr_of_lid) in - match uu___ with - | (empty_lid, singleton_lid, union_lid, addr_of_lid) -> - let empty = - let uu___1 = - let uu___2 = FStar_Ident.set_lid_range empty_lid r in - Var uu___2 in - mk_term uu___1 r Expr in - let addr_of = - let uu___1 = - let uu___2 = FStar_Ident.set_lid_range addr_of_lid r in - Var uu___2 in - mk_term uu___1 r Expr in - let singleton = - let uu___1 = - let uu___2 = FStar_Ident.set_lid_range singleton_lid r in - Var uu___2 in - mk_term uu___1 r Expr in - let union = - let uu___1 = - let uu___2 = FStar_Ident.set_lid_range union_lid r in - Var uu___2 in - mk_term uu___1 r Expr in - FStar_Compiler_List.fold_right - (fun e -> - fun tl -> - let e1 = mkApp addr_of [(e, Nothing)] r in - let single_e = mkApp singleton [(e1, Nothing)] r in - mkApp union [(single_e, Nothing); (tl, Nothing)] r) elts - empty -let (mkExplicitApp : - term -> term Prims.list -> FStar_Compiler_Range_Type.range -> term) = - fun t -> - fun args -> - fun r -> - match args with - | [] -> t - | uu___ -> - (match t.tm with - | Name s -> - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Compiler_List.map (fun a -> (a, Nothing)) args in - (s, uu___3) in - Construct uu___2 in - mk_term uu___1 r Un - | uu___1 -> - FStar_Compiler_List.fold_left - (fun t1 -> fun a -> mk_term (App (t1, a, Nothing)) r Un) t - args) -let (mkAdmitMagic : FStar_Compiler_Range_Type.range -> term) = - fun r -> - let admit = - let admit_name = - let uu___ = - let uu___1 = - FStar_Ident.set_lid_range FStar_Parser_Const.admit_lid r in - Var uu___1 in - mk_term uu___ r Expr in - let uu___ = let uu___1 = unit_const r in [uu___1] in - mkExplicitApp admit_name uu___ r in - let magic = - let magic_name = - let uu___ = - let uu___1 = - FStar_Ident.set_lid_range FStar_Parser_Const.magic_lid r in - Var uu___1 in - mk_term uu___ r Expr in - let uu___ = let uu___1 = unit_const r in [uu___1] in - mkExplicitApp magic_name uu___ r in - let admit_magic = mk_term (Seq (admit, magic)) r Expr in admit_magic -let mkWildAdmitMagic : - 'uuuuu . - FStar_Compiler_Range_Type.range -> - (pattern * 'uuuuu FStar_Pervasives_Native.option * term) - = - fun r -> - let uu___ = mk_pattern (PatWild (FStar_Pervasives_Native.None, [])) r in - let uu___1 = mkAdmitMagic r in - (uu___, FStar_Pervasives_Native.None, uu___1) -let focusBranches : - 'uuuuu . - (Prims.bool * (pattern * 'uuuuu FStar_Pervasives_Native.option * term)) - Prims.list -> - FStar_Compiler_Range_Type.range -> - (pattern * 'uuuuu FStar_Pervasives_Native.option * term) Prims.list - = - fun branches -> - fun r -> - let should_filter = - FStar_Compiler_Util.for_some FStar_Pervasives_Native.fst branches in - if should_filter - then - (FStar_Errors.log_issue FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Warning_Filtered () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic "Focusing on only some cases"); - (let focussed = - let uu___1 = - FStar_Compiler_List.filter FStar_Pervasives_Native.fst branches in - FStar_Compiler_List.map FStar_Pervasives_Native.snd uu___1 in - let uu___1 = let uu___2 = mkWildAdmitMagic r in [uu___2] in - FStar_Compiler_List.op_At focussed uu___1)) - else FStar_Compiler_List.map FStar_Pervasives_Native.snd branches -let (focusLetBindings : - (Prims.bool * (pattern * term)) Prims.list -> - FStar_Compiler_Range_Type.range -> (pattern * term) Prims.list) - = - fun lbs -> - fun r -> - let should_filter = - FStar_Compiler_Util.for_some FStar_Pervasives_Native.fst lbs in - if should_filter - then - (FStar_Errors.log_issue FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Warning_Filtered () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Focusing on only some cases in this (mutually) recursive definition"); - FStar_Compiler_List.map - (fun uu___1 -> - match uu___1 with - | (f, lb) -> - if f - then lb - else - (let uu___3 = mkAdmitMagic r in - ((FStar_Pervasives_Native.fst lb), uu___3))) lbs) - else FStar_Compiler_List.map FStar_Pervasives_Native.snd lbs -let (focusAttrLetBindings : - (attributes_ FStar_Pervasives_Native.option * (Prims.bool * (pattern * - term))) Prims.list -> - FStar_Compiler_Range_Type.range -> - (attributes_ FStar_Pervasives_Native.option * (pattern * term)) - Prims.list) - = - fun lbs -> - fun r -> - let should_filter = - FStar_Compiler_Util.for_some - (fun uu___ -> match uu___ with | (attr, (focus, uu___1)) -> focus) - lbs in - if should_filter - then - (FStar_Errors.log_issue FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Warning_Filtered () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Focusing on only some cases in this (mutually) recursive definition"); - FStar_Compiler_List.map - (fun uu___1 -> - match uu___1 with - | (attr, (f, lb)) -> - if f - then (attr, lb) - else - (let uu___3 = - let uu___4 = mkAdmitMagic r in - ((FStar_Pervasives_Native.fst lb), uu___4) in - (attr, uu___3))) lbs) - else - FStar_Compiler_List.map - (fun uu___1 -> - match uu___1 with | (attr, (uu___2, lb)) -> (attr, lb)) lbs -let (mkFsTypApp : - term -> term Prims.list -> FStar_Compiler_Range_Type.range -> term) = - fun t -> - fun args -> - fun r -> - let uu___ = FStar_Compiler_List.map (fun a -> (a, FsTypApp)) args in - mkApp t uu___ r -let (mkTuple : term Prims.list -> FStar_Compiler_Range_Type.range -> term) = - fun args -> - fun r -> - let cons = - FStar_Parser_Const.mk_tuple_data_lid - (FStar_Compiler_List.length args) r in - let uu___ = mk_term (Name cons) r Expr in - let uu___1 = FStar_Compiler_List.map (fun x -> (x, Nothing)) args in - mkApp uu___ uu___1 r -let (mkDTuple : term Prims.list -> FStar_Compiler_Range_Type.range -> term) = - fun args -> - fun r -> - let cons = - FStar_Parser_Const.mk_dtuple_data_lid - (FStar_Compiler_List.length args) r in - let uu___ = mk_term (Name cons) r Expr in - let uu___1 = FStar_Compiler_List.map (fun x -> (x, Nothing)) args in - mkApp uu___ uu___1 r -let (mkRefinedBinder : - FStar_Ident.ident -> - term -> - Prims.bool -> - term FStar_Pervasives_Native.option -> - FStar_Compiler_Range_Type.range -> - aqual -> term Prims.list -> binder) - = - fun id -> - fun t -> - fun should_bind_var -> - fun refopt -> - fun m -> - fun implicit -> - fun attrs -> - let b = - mk_binder_with_attrs (Annotated (id, t)) m Type_level - implicit attrs in - match refopt with - | FStar_Pervasives_Native.None -> b - | FStar_Pervasives_Native.Some phi -> - if should_bind_var - then - let uu___ = - let uu___1 = - let uu___2 = mk_term (Refine (b, phi)) m Type_level in - (id, uu___2) in - Annotated uu___1 in - mk_binder_with_attrs uu___ m Type_level implicit attrs - else - (let x = FStar_Ident.gen t.range in - let b1 = - mk_binder_with_attrs (Annotated (x, t)) m Type_level - implicit attrs in - let uu___1 = - let uu___2 = - let uu___3 = - mk_term (Refine (b1, phi)) m Type_level in - (id, uu___3) in - Annotated uu___2 in - mk_binder_with_attrs uu___1 m Type_level implicit - attrs) -let (mkRefinedPattern : - pattern -> - term -> - Prims.bool -> - term FStar_Pervasives_Native.option -> - FStar_Compiler_Range_Type.range -> - FStar_Compiler_Range_Type.range -> pattern) - = - fun pat -> - fun t -> - fun should_bind_pat -> - fun phi_opt -> - fun t_range -> - fun range -> - let t1 = - match phi_opt with - | FStar_Pervasives_Native.None -> t - | FStar_Pervasives_Native.Some phi -> - if should_bind_pat - then - (match pat.pat with - | PatVar (x, uu___, attrs) -> - let uu___1 = - let uu___2 = - let uu___3 = - mk_binder_with_attrs (Annotated (x, t)) - t_range Type_level - FStar_Pervasives_Native.None attrs in - (uu___3, phi) in - Refine uu___2 in - mk_term uu___1 range Type_level - | uu___ -> - let x = FStar_Ident.gen t_range in - let phi1 = - let x_var = - let uu___1 = - let uu___2 = FStar_Ident.lid_of_ids [x] in - Var uu___2 in - mk_term uu___1 phi.range Formula in - let pat_branch = - (pat, FStar_Pervasives_Native.None, phi) in - let otherwise_branch = - let uu___1 = - mk_pattern - (PatWild - (FStar_Pervasives_Native.None, [])) - phi.range in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Ident.lid_of_path ["False"] - phi.range in - Name uu___4 in - mk_term uu___3 phi.range Formula in - (uu___1, FStar_Pervasives_Native.None, uu___2) in - mk_term - (Match - (x_var, FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None, - [pat_branch; otherwise_branch])) - phi.range Formula in - let uu___1 = - let uu___2 = - let uu___3 = - mk_binder (Annotated (x, t)) t_range - Type_level FStar_Pervasives_Native.None in - (uu___3, phi1) in - Refine uu___2 in - mk_term uu___1 range Type_level) - else - (let x = FStar_Ident.gen t.range in - let uu___1 = - let uu___2 = - let uu___3 = - mk_binder (Annotated (x, t)) t_range Type_level - FStar_Pervasives_Native.None in - (uu___3, phi) in - Refine uu___2 in - mk_term uu___1 range Type_level) in - mk_pattern - (PatAscribed (pat, (t1, FStar_Pervasives_Native.None))) range -let rec (extract_named_refinement : - Prims.bool -> - term -> - (FStar_Ident.ident * term * term FStar_Pervasives_Native.option) - FStar_Pervasives_Native.option) - = - fun remove_parens -> - fun t1 -> - match t1.tm with - | NamedTyp (x, t) -> - FStar_Pervasives_Native.Some (x, t, FStar_Pervasives_Native.None) - | Refine - ({ b = Annotated (x, t); brange = uu___; blevel = uu___1; - aqual = uu___2; battributes = uu___3;_}, - t') - -> - FStar_Pervasives_Native.Some - (x, t, (FStar_Pervasives_Native.Some t')) - | Paren t when remove_parens -> - extract_named_refinement remove_parens t - | uu___ -> FStar_Pervasives_Native.None -let rec (as_mlist : - ((FStar_Ident.lid * decl) * decl Prims.list) -> decl Prims.list -> modul) = - fun cur -> - fun ds -> - let uu___ = cur in - match uu___ with - | ((m_name, m_decl), cur1) -> - (match ds with - | [] -> - Module (m_name, (m_decl :: (FStar_Compiler_List.rev cur1))) - | d::ds1 -> - (match d.d with - | TopLevelModule m' -> - FStar_Errors.raise_error hasRange_decl d - FStar_Errors_Codes.Fatal_UnexpectedModuleDeclaration () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic "Unexpected module declaration") - | uu___1 -> as_mlist ((m_name, m_decl), (d :: cur1)) ds1)) -let (as_frag : decl Prims.list -> inputFragment) = - fun ds -> - let uu___ = - match ds with - | d::ds1 -> (d, ds1) - | [] -> FStar_Compiler_Effect.raise FStar_Errors.Empty_frag in - match uu___ with - | (d, ds1) -> - (match d.d with - | TopLevelModule m -> - let m1 = as_mlist ((m, d), []) ds1 in FStar_Pervasives.Inl m1 - | uu___1 -> - let ds2 = d :: ds1 in - (FStar_Compiler_List.iter - (fun uu___3 -> - match uu___3 with - | { d = TopLevelModule uu___4; drange = r; quals = uu___5; - attrs = uu___6; interleaved = uu___7;_} -> - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_UnexpectedModuleDeclaration - () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic "Unexpected module declaration") - | uu___4 -> ()) ds2; - FStar_Pervasives.Inr ds2)) -let (strip_prefix : - Prims.string -> Prims.string -> Prims.string FStar_Pervasives_Native.option) - = - fun prefix -> - fun s -> - if FStar_Compiler_Util.starts_with s prefix - then - let uu___ = - FStar_Compiler_Util.substring_from s - (FStar_Compiler_String.length prefix) in - FStar_Pervasives_Native.Some uu___ - else FStar_Pervasives_Native.None -let (compile_op : - Prims.int -> - Prims.string -> FStar_Compiler_Range_Type.range -> Prims.string) - = - fun arity -> - fun s -> - fun r -> - let name_of_char uu___ = - match uu___ with - | 38 -> "Amp" - | 64 -> "At" - | 43 -> "Plus" - | 45 when arity = Prims.int_one -> "Minus" - | 45 -> "Subtraction" - | 126 -> "Tilde" - | 47 -> "Slash" - | 92 -> "Backslash" - | 60 -> "Less" - | 61 -> "Equals" - | 62 -> "Greater" - | 95 -> "Underscore" - | 124 -> "Bar" - | 33 -> "Bang" - | 94 -> "Hat" - | 37 -> "Percent" - | 42 -> "Star" - | 63 -> "Question" - | 58 -> "Colon" - | 36 -> "Dollar" - | 46 -> "Dot" - | c -> - let uu___1 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_Util.int_of_char c) in - Prims.strcat "u" uu___1 in - match s with - | ".[]<-" -> "op_String_Assignment" - | ".()<-" -> "op_Array_Assignment" - | ".[||]<-" -> "op_Brack_Lens_Assignment" - | ".(||)<-" -> "op_Lens_Assignment" - | ".[]" -> "op_String_Access" - | ".()" -> "op_Array_Access" - | ".[||]" -> "op_Brack_Lens_Access" - | ".(||)" -> "op_Lens_Access" - | uu___ -> - let uu___1 = - if - (FStar_Compiler_Util.starts_with s "let") || - (FStar_Compiler_Util.starts_with s "and") - then - let uu___2 = - let uu___3 = - FStar_Compiler_Util.substring s Prims.int_zero - (Prims.of_int (3)) in - Prims.strcat uu___3 "_" in - let uu___3 = - FStar_Compiler_Util.substring_from s (Prims.of_int (3)) in - (uu___2, uu___3) - else - if - (FStar_Compiler_Util.starts_with s "exists") || - (FStar_Compiler_Util.starts_with s "forall") - then - (let uu___3 = - let uu___4 = - FStar_Compiler_Util.substring s Prims.int_zero - (Prims.of_int (6)) in - Prims.strcat uu___4 "_" in - let uu___4 = - FStar_Compiler_Util.substring_from s (Prims.of_int (6)) in - (uu___3, uu___4)) - else ("", s) in - (match uu___1 with - | (prefix, s1) -> - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Compiler_String.list_of_string s1 in - FStar_Compiler_List.map name_of_char uu___5 in - FStar_Compiler_String.concat "_" uu___4 in - Prims.strcat prefix uu___3 in - Prims.strcat "op_" uu___2) -let (compile_op' : - Prims.string -> FStar_Compiler_Range_Type.range -> Prims.string) = - fun s -> fun r -> compile_op (Prims.of_int (-1)) s r -let (string_to_op : - Prims.string -> - (Prims.string * Prims.int FStar_Pervasives_Native.option) - FStar_Pervasives_Native.option) - = - fun s -> - let name_of_op s1 = - match s1 with - | "Amp" -> - FStar_Pervasives_Native.Some ("&", FStar_Pervasives_Native.None) - | "At" -> - FStar_Pervasives_Native.Some ("@", FStar_Pervasives_Native.None) - | "Plus" -> - FStar_Pervasives_Native.Some - ("+", (FStar_Pervasives_Native.Some (Prims.of_int (2)))) - | "Minus" -> - FStar_Pervasives_Native.Some ("-", FStar_Pervasives_Native.None) - | "Subtraction" -> - FStar_Pervasives_Native.Some - ("-", (FStar_Pervasives_Native.Some (Prims.of_int (2)))) - | "Tilde" -> - FStar_Pervasives_Native.Some ("~", FStar_Pervasives_Native.None) - | "Slash" -> - FStar_Pervasives_Native.Some - ("/", (FStar_Pervasives_Native.Some (Prims.of_int (2)))) - | "Backslash" -> - FStar_Pervasives_Native.Some ("\\", FStar_Pervasives_Native.None) - | "Less" -> - FStar_Pervasives_Native.Some - ("<", (FStar_Pervasives_Native.Some (Prims.of_int (2)))) - | "Equals" -> - FStar_Pervasives_Native.Some ("=", FStar_Pervasives_Native.None) - | "Greater" -> - FStar_Pervasives_Native.Some - (">", (FStar_Pervasives_Native.Some (Prims.of_int (2)))) - | "Underscore" -> - FStar_Pervasives_Native.Some ("_", FStar_Pervasives_Native.None) - | "Bar" -> - FStar_Pervasives_Native.Some ("|", FStar_Pervasives_Native.None) - | "Bang" -> - FStar_Pervasives_Native.Some ("!", FStar_Pervasives_Native.None) - | "Hat" -> - FStar_Pervasives_Native.Some ("^", FStar_Pervasives_Native.None) - | "Percent" -> - FStar_Pervasives_Native.Some ("%", FStar_Pervasives_Native.None) - | "Star" -> - FStar_Pervasives_Native.Some ("*", FStar_Pervasives_Native.None) - | "Question" -> - FStar_Pervasives_Native.Some ("?", FStar_Pervasives_Native.None) - | "Colon" -> - FStar_Pervasives_Native.Some (":", FStar_Pervasives_Native.None) - | "Dollar" -> - FStar_Pervasives_Native.Some ("$", FStar_Pervasives_Native.None) - | "Dot" -> - FStar_Pervasives_Native.Some (".", FStar_Pervasives_Native.None) - | "let" -> - FStar_Pervasives_Native.Some (s1, FStar_Pervasives_Native.None) - | "and" -> - FStar_Pervasives_Native.Some (s1, FStar_Pervasives_Native.None) - | "forall" -> - FStar_Pervasives_Native.Some (s1, FStar_Pervasives_Native.None) - | "exists" -> - FStar_Pervasives_Native.Some (s1, FStar_Pervasives_Native.None) - | uu___ -> FStar_Pervasives_Native.None in - match s with - | "op_String_Assignment" -> - FStar_Pervasives_Native.Some (".[]<-", FStar_Pervasives_Native.None) - | "op_Array_Assignment" -> - FStar_Pervasives_Native.Some (".()<-", FStar_Pervasives_Native.None) - | "op_Brack_Lens_Assignment" -> - FStar_Pervasives_Native.Some - (".[||]<-", FStar_Pervasives_Native.None) - | "op_Lens_Assignment" -> - FStar_Pervasives_Native.Some - (".(||)<-", FStar_Pervasives_Native.None) - | "op_String_Access" -> - FStar_Pervasives_Native.Some (".[]", FStar_Pervasives_Native.None) - | "op_Array_Access" -> - FStar_Pervasives_Native.Some (".()", FStar_Pervasives_Native.None) - | "op_Brack_Lens_Access" -> - FStar_Pervasives_Native.Some (".[||]", FStar_Pervasives_Native.None) - | "op_Lens_Access" -> - FStar_Pervasives_Native.Some (".(||)", FStar_Pervasives_Native.None) - | uu___ -> - if FStar_Compiler_Util.starts_with s "op_" - then - let frags = - let uu___1 = - FStar_Compiler_Util.substring_from s - (FStar_Compiler_String.length "op_") in - FStar_Compiler_Util.split uu___1 "_" in - (match frags with - | op::[] -> - if FStar_Compiler_Util.starts_with op "u" - then - let uu___1 = - let uu___2 = - FStar_Compiler_Util.substring_from op Prims.int_one in - FStar_Compiler_Util.safe_int_of_string uu___2 in - FStar_Compiler_Util.map_opt uu___1 - (fun op1 -> - ((FStar_Compiler_Util.string_of_char - (FStar_Compiler_Util.char_of_int op1)), - FStar_Pervasives_Native.None)) - else name_of_op op - | uu___1 -> - let maybeop = - let uu___2 = FStar_Compiler_List.map name_of_op frags in - FStar_Compiler_List.fold_left - (fun acc -> - fun x -> - match acc with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some acc1 -> - (match x with - | FStar_Pervasives_Native.Some (op, uu___3) -> - FStar_Pervasives_Native.Some - (Prims.strcat acc1 op) - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None)) - (FStar_Pervasives_Native.Some "") uu___2 in - FStar_Compiler_Util.map_opt maybeop - (fun o -> (o, FStar_Pervasives_Native.None))) - else FStar_Pervasives_Native.None -let (string_of_fsdoc : - (Prims.string * (Prims.string * Prims.string) Prims.list) -> Prims.string) - = - fun uu___ -> - match uu___ with - | (comment, keywords) -> - let uu___1 = - let uu___2 = - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with - | (k, v) -> Prims.strcat k (Prims.strcat "->" v)) keywords in - FStar_Compiler_String.concat "," uu___2 in - Prims.strcat comment uu___1 -let (string_of_let_qualifier : let_qualifier -> Prims.string) = - fun uu___ -> match uu___ with | NoLetQualifier -> "" | Rec -> "rec" -let to_string_l : - 'uuuuu . - Prims.string -> - ('uuuuu -> Prims.string) -> 'uuuuu Prims.list -> Prims.string - = - fun sep -> - fun f -> - fun l -> - let uu___ = FStar_Compiler_List.map f l in - FStar_Compiler_String.concat sep uu___ -let (imp_to_string : imp -> Prims.string) = - fun uu___ -> match uu___ with | Hash -> "#" | uu___1 -> "" -let rec (term_to_string : term -> Prims.string) = - fun x -> - match x.tm with - | Wild -> "_" - | LexList l -> - let uu___ = - match l with - | [] -> " " - | hd::tl -> - let uu___1 = term_to_string hd in - FStar_Compiler_List.fold_left - (fun s -> - fun t -> - let uu___2 = - let uu___3 = term_to_string t in - Prims.strcat "; " uu___3 in - Prims.strcat s uu___2) uu___1 tl in - FStar_Compiler_Util.format1 "%[%s]" uu___ - | Decreases (t, uu___) -> - let uu___1 = term_to_string t in - FStar_Compiler_Util.format1 "(decreases %s)" uu___1 - | Requires (t, uu___) -> - let uu___1 = term_to_string t in - FStar_Compiler_Util.format1 "(requires %s)" uu___1 - | Ensures (t, uu___) -> - let uu___1 = term_to_string t in - FStar_Compiler_Util.format1 "(ensures %s)" uu___1 - | Labeled (t, l, uu___) -> - let uu___1 = term_to_string t in - FStar_Compiler_Util.format2 "(labeled %s %s)" l uu___1 - | Const c -> FStar_Parser_Const.const_to_string c - | Op (s, xs) -> - let uu___ = FStar_Ident.string_of_id s in - let uu___1 = - let uu___2 = - FStar_Compiler_List.map (fun x1 -> term_to_string x1) xs in - FStar_Compiler_String.concat ", " uu___2 in - FStar_Compiler_Util.format2 "%s(%s)" uu___ uu___1 - | Tvar id -> FStar_Ident.string_of_id id - | Uvar id -> FStar_Ident.string_of_id id - | Var l -> FStar_Ident.string_of_lid l - | Name l -> FStar_Ident.string_of_lid l - | Projector (rec_lid, field_id) -> - let uu___ = FStar_Ident.string_of_lid rec_lid in - let uu___1 = FStar_Ident.string_of_id field_id in - FStar_Compiler_Util.format2 "%s?.%s" uu___ uu___1 - | Construct (l, args) -> - let uu___ = FStar_Ident.string_of_lid l in - let uu___1 = - to_string_l " " - (fun uu___2 -> - match uu___2 with - | (a, imp1) -> - let uu___3 = term_to_string a in - FStar_Compiler_Util.format2 "%s%s" (imp_to_string imp1) - uu___3) args in - FStar_Compiler_Util.format2 "(%s %s)" uu___ uu___1 - | Function (branches, r) -> - let uu___ = - to_string_l " | " - (fun uu___1 -> - match uu___1 with - | (p, w, e) -> - let uu___2 = pat_to_string p in - let uu___3 = term_to_string e in - FStar_Compiler_Util.format2 "%s -> %s" uu___2 uu___3) - branches in - FStar_Compiler_Util.format1 "(function %s)" uu___ - | Abs (pats, t) -> - let uu___ = to_string_l " " pat_to_string pats in - let uu___1 = term_to_string t in - FStar_Compiler_Util.format2 "(fun %s -> %s)" uu___ uu___1 - | App (t1, t2, imp1) -> - let uu___ = term_to_string t1 in - let uu___1 = term_to_string t2 in - FStar_Compiler_Util.format3 "%s %s%s" uu___ (imp_to_string imp1) - uu___1 - | Let (Rec, (a, (p, b))::lbs, body) -> - let uu___ = attrs_opt_to_string a in - let uu___1 = - let uu___2 = pat_to_string p in - let uu___3 = term_to_string b in - FStar_Compiler_Util.format2 "%s=%s" uu___2 uu___3 in - let uu___2 = - to_string_l " " - (fun uu___3 -> - match uu___3 with - | (a1, (p1, b1)) -> - let uu___4 = attrs_opt_to_string a1 in - let uu___5 = pat_to_string p1 in - let uu___6 = term_to_string b1 in - FStar_Compiler_Util.format3 "%sand %s=%s" uu___4 uu___5 - uu___6) lbs in - let uu___3 = term_to_string body in - FStar_Compiler_Util.format4 "%slet rec %s%s in %s" uu___ uu___1 - uu___2 uu___3 - | Let (q, (attrs, (pat, tm))::[], body) -> - let uu___ = attrs_opt_to_string attrs in - let uu___1 = string_of_let_qualifier q in - let uu___2 = pat_to_string pat in - let uu___3 = term_to_string tm in - let uu___4 = term_to_string body in - FStar_Compiler_Util.format5 "%slet %s %s = %s in %s" uu___ uu___1 - uu___2 uu___3 uu___4 - | Let (uu___, uu___1, uu___2) -> - FStar_Errors.raise_error hasRange_term x - FStar_Errors_Codes.Fatal_EmptySurfaceLet () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic "Internal error: found an invalid surface Let") - | LetOpen (lid, t) -> - let uu___ = FStar_Ident.string_of_lid lid in - let uu___1 = term_to_string t in - FStar_Compiler_Util.format2 "let open %s in %s" uu___ uu___1 - | Seq (t1, t2) -> - let uu___ = term_to_string t1 in - let uu___1 = term_to_string t2 in - FStar_Compiler_Util.format2 "%s; %s" uu___ uu___1 - | Bind (id, t1, t2) -> - let uu___ = FStar_Ident.string_of_id id in - let uu___1 = term_to_string t1 in - let uu___2 = term_to_string t2 in - FStar_Compiler_Util.format3 "%s <- %s; %s" uu___ uu___1 uu___2 - | If (t1, op_opt, ret_opt, t2, t3) -> - let uu___ = - match op_opt with - | FStar_Pervasives_Native.Some op -> FStar_Ident.string_of_id op - | FStar_Pervasives_Native.None -> "" in - let uu___1 = term_to_string t1 in - let uu___2 = - match ret_opt with - | FStar_Pervasives_Native.None -> "" - | FStar_Pervasives_Native.Some (as_opt, ret, use_eq) -> - let s = if use_eq then "returns$" else "returns" in - let uu___3 = - match as_opt with - | FStar_Pervasives_Native.None -> "" - | FStar_Pervasives_Native.Some as_ident -> - let uu___4 = FStar_Ident.string_of_id as_ident in - FStar_Compiler_Util.format1 " as %s " uu___4 in - let uu___4 = term_to_string ret in - FStar_Compiler_Util.format3 "%s%s %s " uu___3 s uu___4 in - let uu___3 = term_to_string t2 in - let uu___4 = term_to_string t3 in - FStar_Compiler_Util.format5 "if%s %s %sthen %s else %s" uu___ uu___1 - uu___2 uu___3 uu___4 - | Match (t, op_opt, ret_opt, branches) -> - try_or_match_to_string x t branches op_opt ret_opt - | TryWith (t, branches) -> - try_or_match_to_string x t branches FStar_Pervasives_Native.None - FStar_Pervasives_Native.None - | Ascribed (t1, t2, FStar_Pervasives_Native.None, flag) -> - let s = if flag then "$:" else "<:" in - let uu___ = term_to_string t1 in - let uu___1 = term_to_string t2 in - FStar_Compiler_Util.format3 "(%s %s %s)" uu___ s uu___1 - | Ascribed (t1, t2, FStar_Pervasives_Native.Some tac, flag) -> - let s = if flag then "$:" else "<:" in - let uu___ = term_to_string t1 in - let uu___1 = term_to_string t2 in - let uu___2 = term_to_string tac in - FStar_Compiler_Util.format4 "(%s %s %s by %s)" uu___ s uu___1 uu___2 - | Record (FStar_Pervasives_Native.Some e, fields) -> - let uu___ = term_to_string e in - let uu___1 = - to_string_l " " - (fun uu___2 -> - match uu___2 with - | (l, e1) -> - let uu___3 = FStar_Ident.string_of_lid l in - let uu___4 = term_to_string e1 in - FStar_Compiler_Util.format2 "%s=%s" uu___3 uu___4) fields in - FStar_Compiler_Util.format2 "{%s with %s}" uu___ uu___1 - | Record (FStar_Pervasives_Native.None, fields) -> - let uu___ = - to_string_l " " - (fun uu___1 -> - match uu___1 with - | (l, e) -> - let uu___2 = FStar_Ident.string_of_lid l in - let uu___3 = term_to_string e in - FStar_Compiler_Util.format2 "%s=%s" uu___2 uu___3) fields in - FStar_Compiler_Util.format1 "{%s}" uu___ - | Project (e, l) -> - let uu___ = term_to_string e in - let uu___1 = FStar_Ident.string_of_lid l in - FStar_Compiler_Util.format2 "%s.%s" uu___ uu___1 - | Product ([], t) -> term_to_string t - | Product (b::hd::tl, t) -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = mk_term (Product ((hd :: tl), t)) x.range x.level in - ([b], uu___3) in - Product uu___2 in - mk_term uu___1 x.range x.level in - term_to_string uu___ - | Product (b::[], t) when x.level = Type_level -> - let uu___ = binder_to_string b in - let uu___1 = term_to_string t in - FStar_Compiler_Util.format2 "%s -> %s" uu___ uu___1 - | Product (b::[], t) when x.level = Kind -> - let uu___ = binder_to_string b in - let uu___1 = term_to_string t in - FStar_Compiler_Util.format2 "%s => %s" uu___ uu___1 - | Sum (binders, t) -> - let uu___ = - FStar_Compiler_List.map - (fun uu___1 -> - match uu___1 with - | FStar_Pervasives.Inl b -> binder_to_string b - | FStar_Pervasives.Inr t1 -> term_to_string t1) - (FStar_Compiler_List.op_At binders [FStar_Pervasives.Inr t]) in - FStar_Compiler_String.concat " & " uu___ - | QForall (bs, (uu___, pats), t) -> - let uu___1 = to_string_l " " binder_to_string bs in - let uu___2 = - to_string_l " \\/ " (to_string_l "; " term_to_string) pats in - let uu___3 = term_to_string t in - FStar_Compiler_Util.format3 "forall %s.{:pattern %s} %s" uu___1 - uu___2 uu___3 - | QExists (bs, (uu___, pats), t) -> - let uu___1 = to_string_l " " binder_to_string bs in - let uu___2 = - to_string_l " \\/ " (to_string_l "; " term_to_string) pats in - let uu___3 = term_to_string t in - FStar_Compiler_Util.format3 "exists %s.{:pattern %s} %s" uu___1 - uu___2 uu___3 - | QuantOp (i, bs, (uu___, []), t) -> - let uu___1 = FStar_Ident.string_of_id i in - let uu___2 = to_string_l " " binder_to_string bs in - let uu___3 = term_to_string t in - FStar_Compiler_Util.format3 "%s %s. %s" uu___1 uu___2 uu___3 - | QuantOp (i, bs, (uu___, pats), t) -> - let uu___1 = FStar_Ident.string_of_id i in - let uu___2 = to_string_l " " binder_to_string bs in - let uu___3 = - to_string_l " \\/ " (to_string_l "; " term_to_string) pats in - let uu___4 = term_to_string t in - FStar_Compiler_Util.format4 "%s %s.{:pattern %s} %s" uu___1 uu___2 - uu___3 uu___4 - | Refine (b, t) -> - let uu___ = binder_to_string b in - let uu___1 = term_to_string t in - FStar_Compiler_Util.format2 "%s:{%s}" uu___ uu___1 - | NamedTyp (x1, t) -> - let uu___ = FStar_Ident.string_of_id x1 in - let uu___1 = term_to_string t in - FStar_Compiler_Util.format2 "%s:%s" uu___ uu___1 - | Paren t -> - let uu___ = term_to_string t in - FStar_Compiler_Util.format1 "(%s)" uu___ - | Product (bs, t) -> - let uu___ = - let uu___1 = FStar_Compiler_List.map binder_to_string bs in - FStar_Compiler_String.concat "," uu___1 in - let uu___1 = term_to_string t in - FStar_Compiler_Util.format2 "Unidentified product: [%s] %s" uu___ - uu___1 - | Discrim lid -> - let uu___ = FStar_Ident.string_of_lid lid in - FStar_Compiler_Util.format1 "%s?" uu___ - | Attributes ts -> - let uu___ = - let uu___1 = FStar_Compiler_List.map term_to_string ts in - FStar_Compiler_String.concat " " uu___1 in - FStar_Compiler_Util.format1 "(attributes %s)" uu___ - | Antiquote t -> - let uu___ = term_to_string t in - FStar_Compiler_Util.format1 "(`#%s)" uu___ - | Quote (t, Static) -> - let uu___ = term_to_string t in - FStar_Compiler_Util.format1 "(`(%s))" uu___ - | Quote (t, Dynamic) -> - let uu___ = term_to_string t in - FStar_Compiler_Util.format1 "quote (%s)" uu___ - | VQuote t -> - let uu___ = term_to_string t in - FStar_Compiler_Util.format1 "`%%%s" uu___ - | CalcProof (rel, init, steps) -> - let uu___ = term_to_string rel in - let uu___1 = term_to_string init in - let uu___2 = - let uu___3 = FStar_Compiler_List.map calc_step_to_string steps in - FStar_Compiler_String.concat " " uu___3 in - FStar_Compiler_Util.format3 "calc (%s) { %s %s }" uu___ uu___1 uu___2 - | ElimForall (bs, t, vs) -> - let uu___ = binders_to_string " " bs in - let uu___1 = term_to_string t in - let uu___2 = - let uu___3 = FStar_Compiler_List.map term_to_string vs in - FStar_Compiler_String.concat " " uu___3 in - FStar_Compiler_Util.format3 "_elim_ forall %s. %s using %s" uu___ - uu___1 uu___2 - | ElimExists (bs, p, q, b, e) -> - let uu___ = binders_to_string " " bs in - let uu___1 = term_to_string p in - let uu___2 = term_to_string q in - let uu___3 = binder_to_string b in - let uu___4 = term_to_string e in - FStar_Compiler_Util.format5 - "_elim_ exists %s. %s _to_ %s\n\\with %s. %s" uu___ uu___1 uu___2 - uu___3 uu___4 - | ElimImplies (p, q, e) -> - let uu___ = term_to_string p in - let uu___1 = term_to_string q in - let uu___2 = term_to_string e in - FStar_Compiler_Util.format3 "_elim_ %s ==> %s with %s" uu___ uu___1 - uu___2 - | ElimOr (p, q, r, x1, e, y, e') -> - let uu___ = - let uu___1 = term_to_string p in - let uu___2 = - let uu___3 = term_to_string q in - let uu___4 = - let uu___5 = term_to_string r in - let uu___6 = - let uu___7 = binder_to_string x1 in - let uu___8 = - let uu___9 = term_to_string e in - let uu___10 = - let uu___11 = binder_to_string y in - let uu___12 = - let uu___13 = term_to_string e' in [uu___13] in - uu___11 :: uu___12 in - uu___9 :: uu___10 in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Compiler_Util.format - "_elim_ %s \\/ %s _to_ %s\n\\with %s. %s\n\\and %s.%s" uu___ - | ElimAnd (p, q, r, x1, y, e) -> - let uu___ = - let uu___1 = term_to_string p in - let uu___2 = - let uu___3 = term_to_string q in - let uu___4 = - let uu___5 = term_to_string r in - let uu___6 = - let uu___7 = binder_to_string x1 in - let uu___8 = - let uu___9 = binder_to_string y in - let uu___10 = let uu___11 = term_to_string e in [uu___11] in - uu___9 :: uu___10 in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Compiler_Util.format - "_elim_ %s /\\ %s _to_ %s\n\\with %s %s. %s" uu___ - | IntroForall (xs, p, e) -> - let uu___ = binders_to_string " " xs in - let uu___1 = term_to_string p in - let uu___2 = term_to_string e in - FStar_Compiler_Util.format3 "_intro_ forall %s. %s with %s" uu___ - uu___1 uu___2 - | IntroExists (xs, t, vs, e) -> - let uu___ = binders_to_string " " xs in - let uu___1 = term_to_string t in - let uu___2 = - let uu___3 = FStar_Compiler_List.map term_to_string vs in - FStar_Compiler_String.concat " " uu___3 in - let uu___3 = term_to_string e in - FStar_Compiler_Util.format4 "_intro_ exists %s. %s using %s with %s" - uu___ uu___1 uu___2 uu___3 - | IntroImplies (p, q, x1, e) -> - let uu___ = term_to_string p in - let uu___1 = term_to_string q in - let uu___2 = binder_to_string x1 in - let uu___3 = term_to_string p in - FStar_Compiler_Util.format4 "_intro_ %s ==> %s with %s. %s" uu___ - uu___1 uu___2 uu___3 - | IntroOr (b, p, q, r) -> - let uu___ = term_to_string p in - let uu___1 = term_to_string q in - let uu___2 = term_to_string r in - FStar_Compiler_Util.format4 "_intro_ %s \\/ %s using %s with %s" - uu___ uu___1 (if b then "Left" else "Right") uu___2 - | IntroAnd (p, q, e1, e2) -> - let uu___ = term_to_string p in - let uu___1 = term_to_string q in - let uu___2 = term_to_string e1 in - let uu___3 = term_to_string e2 in - FStar_Compiler_Util.format4 "_intro_ %s /\\ %s with %s and %s" uu___ - uu___1 uu___2 uu___3 - | ListLiteral ts -> - let uu___ = to_string_l "; " term_to_string ts in - FStar_Compiler_Util.format1 "[%s]" uu___ - | SeqLiteral ts -> - let uu___ = to_string_l "; " term_to_string ts in - FStar_Compiler_Util.format1 "seq![%s]" uu___ -and (binders_to_string : Prims.string -> binder Prims.list -> Prims.string) = - fun sep -> - fun bs -> - let uu___ = FStar_Compiler_List.map binder_to_string bs in - FStar_Compiler_String.concat sep uu___ -and (try_or_match_to_string : - term -> - term -> - (pattern * term FStar_Pervasives_Native.option * term) Prims.list -> - FStar_Ident.ident FStar_Pervasives_Native.option -> - (FStar_Ident.ident FStar_Pervasives_Native.option * term * - Prims.bool) FStar_Pervasives_Native.option -> Prims.string) - = - fun x -> - fun scrutinee -> - fun branches -> - fun op_opt -> - fun ret_opt -> - let s = - match x.tm with - | Match uu___ -> "match" - | TryWith uu___ -> "try" - | uu___ -> failwith "impossible" in - let uu___ = - match op_opt with - | FStar_Pervasives_Native.Some op -> - FStar_Ident.string_of_id op - | FStar_Pervasives_Native.None -> "" in - let uu___1 = term_to_string scrutinee in - let uu___2 = - match ret_opt with - | FStar_Pervasives_Native.None -> "" - | FStar_Pervasives_Native.Some (as_opt, ret, use_eq) -> - let s1 = if use_eq then "returns$" else "returns" in - let uu___3 = - match as_opt with - | FStar_Pervasives_Native.None -> "" - | FStar_Pervasives_Native.Some as_ident -> - let uu___4 = FStar_Ident.string_of_id as_ident in - FStar_Compiler_Util.format1 "as %s " uu___4 in - let uu___4 = term_to_string ret in - FStar_Compiler_Util.format3 "%s%s %s " s1 uu___3 uu___4 in - let uu___3 = - to_string_l " | " - (fun uu___4 -> - match uu___4 with - | (p, w, e) -> - let uu___5 = pat_to_string p in - let uu___6 = - match w with - | FStar_Pervasives_Native.None -> "" - | FStar_Pervasives_Native.Some e1 -> - let uu___7 = term_to_string e1 in - FStar_Compiler_Util.format1 "when %s" uu___7 in - let uu___7 = term_to_string e in - FStar_Compiler_Util.format3 "%s %s -> %s" uu___5 - uu___6 uu___7) branches in - FStar_Compiler_Util.format5 "%s%s %s %swith %s" s uu___ uu___1 - uu___2 uu___3 -and (calc_step_to_string : calc_step -> Prims.string) = - fun uu___ -> - match uu___ with - | CalcStep (rel, just, next) -> - let uu___1 = term_to_string rel in - let uu___2 = term_to_string just in - let uu___3 = term_to_string next in - FStar_Compiler_Util.format3 "%s{ %s } %s" uu___1 uu___2 uu___3 -and (binder_to_string : binder -> Prims.string) = - fun x -> - let pr x1 = - let s = - match x1.b with - | Variable i -> FStar_Ident.string_of_id i - | TVariable i -> - let uu___ = FStar_Ident.string_of_id i in - FStar_Compiler_Util.format1 "%s:_" uu___ - | TAnnotated (i, t) -> - let uu___ = FStar_Ident.string_of_id i in - let uu___1 = term_to_string t in - FStar_Compiler_Util.format2 "%s:%s" uu___ uu___1 - | Annotated (i, t) -> - let uu___ = FStar_Ident.string_of_id i in - let uu___1 = term_to_string t in - FStar_Compiler_Util.format2 "%s:%s" uu___ uu___1 - | NoName t -> term_to_string t in - let uu___ = aqual_to_string x1.aqual in - let uu___1 = attr_list_to_string x1.battributes in - FStar_Compiler_Util.format3 "%s%s%s" uu___ uu___1 s in - match x.aqual with - | FStar_Pervasives_Native.Some (TypeClassArg) -> - let uu___ = let uu___1 = pr x in Prims.strcat uu___1 " |}" in - Prims.strcat "{| " uu___ - | uu___ -> pr x -and (aqual_to_string : - arg_qualifier FStar_Pervasives_Native.option -> Prims.string) = - fun uu___ -> - match uu___ with - | FStar_Pervasives_Native.Some (Equality) -> "$" - | FStar_Pervasives_Native.Some (Implicit) -> "#" - | FStar_Pervasives_Native.None -> "" - | FStar_Pervasives_Native.Some (Meta uu___1) -> - failwith "aqual_to_strings: meta arg qualifier?" - | FStar_Pervasives_Native.Some (TypeClassArg) -> - failwith "aqual_to_strings: meta arg qualifier?" -and (attr_list_to_string : term Prims.list -> Prims.string) = - fun uu___ -> - match uu___ with - | [] -> "" - | l -> attrs_opt_to_string (FStar_Pervasives_Native.Some l) -and (pat_to_string : pattern -> Prims.string) = - fun x -> - match x.pat with - | PatWild (FStar_Pervasives_Native.None, attrs) -> - let uu___ = attr_list_to_string attrs in Prims.strcat uu___ "_" - | PatWild (uu___, attrs) -> - let uu___1 = - let uu___2 = attr_list_to_string attrs in Prims.strcat uu___2 "_" in - Prims.strcat "#" uu___1 - | PatConst c -> FStar_Parser_Const.const_to_string c - | PatVQuote t -> - let uu___ = term_to_string t in - FStar_Compiler_Util.format1 "`%%%s" uu___ - | PatApp (p, ps) -> - let uu___ = pat_to_string p in - let uu___1 = to_string_l " " pat_to_string ps in - FStar_Compiler_Util.format2 "(%s %s)" uu___ uu___1 - | PatTvar (i, aq, attrs) -> - let uu___ = aqual_to_string aq in - let uu___1 = attr_list_to_string attrs in - let uu___2 = FStar_Ident.string_of_id i in - FStar_Compiler_Util.format3 "%s%s%s" uu___ uu___1 uu___2 - | PatVar (i, aq, attrs) -> - let uu___ = aqual_to_string aq in - let uu___1 = attr_list_to_string attrs in - let uu___2 = FStar_Ident.string_of_id i in - FStar_Compiler_Util.format3 "%s%s%s" uu___ uu___1 uu___2 - | PatName l -> FStar_Ident.string_of_lid l - | PatList l -> - let uu___ = to_string_l "; " pat_to_string l in - FStar_Compiler_Util.format1 "[%s]" uu___ - | PatTuple (l, false) -> - let uu___ = to_string_l ", " pat_to_string l in - FStar_Compiler_Util.format1 "(%s)" uu___ - | PatTuple (l, true) -> - let uu___ = to_string_l ", " pat_to_string l in - FStar_Compiler_Util.format1 "(|%s|)" uu___ - | PatRecord l -> - let uu___ = - to_string_l "; " - (fun uu___1 -> - match uu___1 with - | (f, e) -> - let uu___2 = FStar_Ident.string_of_lid f in - let uu___3 = pat_to_string e in - FStar_Compiler_Util.format2 "%s=%s" uu___2 uu___3) l in - FStar_Compiler_Util.format1 "{%s}" uu___ - | PatOr l -> to_string_l "|\n " pat_to_string l - | PatOp op -> - let uu___ = FStar_Ident.string_of_id op in - FStar_Compiler_Util.format1 "(%s)" uu___ - | PatAscribed (p, (t, FStar_Pervasives_Native.None)) -> - let uu___ = pat_to_string p in - let uu___1 = term_to_string t in - FStar_Compiler_Util.format2 "(%s:%s)" uu___ uu___1 - | PatAscribed (p, (t, FStar_Pervasives_Native.Some tac)) -> - let uu___ = pat_to_string p in - let uu___1 = term_to_string t in - let uu___2 = term_to_string tac in - FStar_Compiler_Util.format3 "(%s:%s by %s)" uu___ uu___1 uu___2 -and (attrs_opt_to_string : - term Prims.list FStar_Pervasives_Native.option -> Prims.string) = - fun uu___ -> - match uu___ with - | FStar_Pervasives_Native.None -> "" - | FStar_Pervasives_Native.Some attrs -> - let uu___1 = - let uu___2 = FStar_Compiler_List.map term_to_string attrs in - FStar_Compiler_String.concat "; " uu___2 in - FStar_Compiler_Util.format1 "[@ %s]" uu___1 -let rec (head_id_of_pat : pattern -> FStar_Ident.lident Prims.list) = - fun p -> - match p.pat with - | PatName l -> [l] - | PatVar (i, uu___, uu___1) -> - let uu___2 = FStar_Ident.lid_of_ids [i] in [uu___2] - | PatApp (p1, uu___) -> head_id_of_pat p1 - | PatAscribed (p1, uu___) -> head_id_of_pat p1 - | uu___ -> [] -let (lids_of_let : - (pattern * term) Prims.list -> FStar_Ident.lident Prims.list) = - fun defs -> - FStar_Compiler_List.collect - (fun uu___ -> match uu___ with | (p, uu___1) -> head_id_of_pat p) defs -let (id_of_tycon : tycon -> Prims.string) = - fun uu___ -> - match uu___ with - | TyconAbstract (i, uu___1, uu___2) -> FStar_Ident.string_of_id i - | TyconAbbrev (i, uu___1, uu___2, uu___3) -> FStar_Ident.string_of_id i - | TyconRecord (i, uu___1, uu___2, uu___3, uu___4) -> - FStar_Ident.string_of_id i - | TyconVariant (i, uu___1, uu___2, uu___3) -> FStar_Ident.string_of_id i -let (string_of_pragma : pragma -> Prims.string) = - fun uu___ -> - match uu___ with - | ShowOptions -> "show-options" - | SetOptions s -> FStar_Compiler_Util.format1 "set-options \"%s\"" s - | ResetOptions s -> - FStar_Compiler_Util.format1 "reset-options \"%s\"" - (FStar_Compiler_Util.dflt "" s) - | PushOptions s -> - FStar_Compiler_Util.format1 "push-options \"%s\"" - (FStar_Compiler_Util.dflt "" s) - | PopOptions -> "pop-options" - | RestartSolver -> "restart-solver" - | PrintEffectsGraph -> "print-effects-graph" -let (restriction_to_string : FStar_Syntax_Syntax.restriction -> Prims.string) - = - fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.Unrestricted -> "" - | FStar_Syntax_Syntax.AllowList allow_list -> - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Compiler_List.map - (fun uu___4 -> - match uu___4 with - | (id, renamed) -> - let uu___5 = FStar_Ident.string_of_id id in - let uu___6 = - let uu___7 = - FStar_Compiler_Util.map_opt renamed - (fun renamed1 -> - let uu___8 = - FStar_Ident.string_of_id renamed1 in - Prims.strcat " as " uu___8) in - FStar_Compiler_Util.dflt "" uu___7 in - Prims.strcat uu___5 uu___6) allow_list in - FStar_Compiler_String.concat ", " uu___3 in - Prims.strcat uu___2 "}" in - Prims.strcat " {" uu___1 -let rec (decl_to_string : decl -> Prims.string) = - fun d -> - match d.d with - | TopLevelModule l -> - let uu___ = FStar_Ident.string_of_lid l in - Prims.strcat "module " uu___ - | Open (l, r) -> - let uu___ = - let uu___1 = FStar_Ident.string_of_lid l in - let uu___2 = restriction_to_string r in Prims.strcat uu___1 uu___2 in - Prims.strcat "open " uu___ - | Friend l -> - let uu___ = FStar_Ident.string_of_lid l in - Prims.strcat "friend " uu___ - | Include (l, r) -> - let uu___ = - let uu___1 = FStar_Ident.string_of_lid l in - let uu___2 = restriction_to_string r in Prims.strcat uu___1 uu___2 in - Prims.strcat "include " uu___ - | ModuleAbbrev (i, l) -> - let uu___ = FStar_Ident.string_of_id i in - let uu___1 = FStar_Ident.string_of_lid l in - FStar_Compiler_Util.format2 "module %s = %s" uu___ uu___1 - | TopLevelLet (uu___, pats) -> - let uu___1 = - let uu___2 = - let uu___3 = lids_of_let pats in - FStar_Compiler_List.map (fun l -> FStar_Ident.string_of_lid l) - uu___3 in - FStar_Compiler_String.concat ", " uu___2 in - Prims.strcat "let " uu___1 - | Assume (i, uu___) -> - let uu___1 = FStar_Ident.string_of_id i in - Prims.strcat "assume " uu___1 - | Tycon (uu___, uu___1, tys) -> - let uu___2 = - let uu___3 = FStar_Compiler_List.map id_of_tycon tys in - FStar_Compiler_String.concat ", " uu___3 in - Prims.strcat "type " uu___2 - | Val (i, uu___) -> - let uu___1 = FStar_Ident.string_of_id i in Prims.strcat "val " uu___1 - | Exception (i, uu___) -> - let uu___1 = FStar_Ident.string_of_id i in - Prims.strcat "exception " uu___1 - | NewEffect (DefineEffect (i, uu___, uu___1, uu___2)) -> - let uu___3 = FStar_Ident.string_of_id i in - Prims.strcat "new_effect " uu___3 - | NewEffect (RedefineEffect (i, uu___, uu___1)) -> - let uu___2 = FStar_Ident.string_of_id i in - Prims.strcat "new_effect " uu___2 - | LayeredEffect (DefineEffect (i, uu___, uu___1, uu___2)) -> - let uu___3 = FStar_Ident.string_of_id i in - Prims.strcat "layered_effect " uu___3 - | LayeredEffect (RedefineEffect (i, uu___, uu___1)) -> - let uu___2 = FStar_Ident.string_of_id i in - Prims.strcat "layered_effect " uu___2 - | Polymonadic_bind (l1, l2, l3, uu___) -> - let uu___1 = FStar_Ident.string_of_lid l1 in - let uu___2 = FStar_Ident.string_of_lid l2 in - let uu___3 = FStar_Ident.string_of_lid l3 in - FStar_Compiler_Util.format3 "polymonadic_bind (%s, %s) |> %s" uu___1 - uu___2 uu___3 - | Polymonadic_subcomp (l1, l2, uu___) -> - let uu___1 = FStar_Ident.string_of_lid l1 in - let uu___2 = FStar_Ident.string_of_lid l2 in - FStar_Compiler_Util.format2 "polymonadic_subcomp %s <: %s" uu___1 - uu___2 - | Splice (is_typed, ids, t) -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Compiler_List.map - (fun i -> FStar_Ident.string_of_id i) ids in - FStar_Compiler_String.concat ";" uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = term_to_string t in Prims.strcat uu___6 ")" in - Prims.strcat "] (" uu___5 in - Prims.strcat uu___3 uu___4 in - Prims.strcat "[" uu___2 in - Prims.strcat (if is_typed then "_t" else "") uu___1 in - Prims.strcat "splice" uu___ - | SubEffect uu___ -> "sub_effect" - | Pragma p -> - let uu___ = string_of_pragma p in Prims.strcat "pragma #" uu___ - | DeclSyntaxExtension (id, content, uu___, uu___1) -> - Prims.strcat "```" - (Prims.strcat id (Prims.strcat "\n" (Prims.strcat content "\n```"))) - | DeclToBeDesugared tbs -> - let uu___ = - let uu___1 = tbs.to_string tbs.blob in Prims.strcat uu___1 ")" in - Prims.strcat "(to_be_desugared: " uu___ - | UseLangDecls str -> FStar_Compiler_Util.format1 "#lang-%s" str - | Unparseable -> "unparseable" -let (modul_to_string : modul -> Prims.string) = - fun m -> - match m with - | Module (uu___, decls) -> - let uu___1 = FStar_Compiler_List.map decl_to_string decls in - FStar_Compiler_String.concat "\n" uu___1 - | Interface (uu___, decls, uu___1) -> - let uu___2 = FStar_Compiler_List.map decl_to_string decls in - FStar_Compiler_String.concat "\n" uu___2 -let (decl_is_val : FStar_Ident.ident -> decl -> Prims.bool) = - fun id -> - fun decl1 -> - match decl1.d with - | Val (id', uu___) -> FStar_Ident.ident_equals id id' - | uu___ -> false -let (thunk : term -> term) = - fun ens -> - let wildpat = - mk_pattern (PatWild (FStar_Pervasives_Native.None, [])) ens.range in - mk_term (Abs ([wildpat], ens)) ens.range Expr -let (ident_of_binder : - FStar_Compiler_Range_Type.range -> binder -> FStar_Ident.ident) = - fun r -> - fun b -> - match b.b with - | Variable i -> i - | TVariable i -> i - | Annotated (i, uu___) -> i - | TAnnotated (i, uu___) -> i - | NoName uu___ -> - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_MissingQuantifierBinder () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic "Wildcard binders in quantifiers are not allowed") -let (idents_of_binders : - binder Prims.list -> - FStar_Compiler_Range_Type.range -> FStar_Ident.ident Prims.list) - = fun bs -> fun r -> FStar_Compiler_List.map (ident_of_binder r) bs -let (showable_decl : decl FStar_Class_Show.showable) = - { FStar_Class_Show.show = decl_to_string } -let (showable_term : term FStar_Class_Show.showable) = - { FStar_Class_Show.show = term_to_string } -let (add_decorations : decl -> decoration Prims.list -> decl) = - fun d -> - fun decorations -> - let decorations1 = - let uu___ = - FStar_Compiler_List.partition uu___is_DeclAttributes decorations in - match uu___ with - | (attrs, quals) -> - let attrs1 = - match (attrs, (d.attrs)) with - | (attrs2, []) -> attrs2 - | ((DeclAttributes a)::[], attrs2) -> - [DeclAttributes (FStar_Compiler_List.op_At a attrs2)] - | ([], attrs2) -> [DeclAttributes attrs2] - | uu___1 -> - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Compiler_List.map - (fun uu___5 -> - match uu___5 with - | DeclAttributes a -> - FStar_Class_Show.show - (FStar_Class_Show.show_list showable_term) - a - | uu___6 -> "") attrs in - FStar_Compiler_String.concat ", " uu___4 in - let uu___4 = - let uu___5 = - FStar_Compiler_List.map - (FStar_Class_Show.show showable_term) d.attrs in - FStar_Compiler_String.concat ", " uu___5 in - FStar_Compiler_Util.format2 - "At most one attribute set is allowed on declarations\n got %s;\n and %s" - uu___3 uu___4 in - FStar_Errors.raise_error hasRange_decl d - FStar_Errors_Codes.Fatal_MoreThanOneDeclaration () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2) in - let uu___1 = - FStar_Compiler_List.map (fun uu___2 -> Qualifier uu___2) - d.quals in - FStar_Compiler_List.op_At uu___1 - (FStar_Compiler_List.op_At quals attrs1) in - let attributes_1 = - let uu___ = - FStar_Compiler_List.choose - (fun uu___1 -> - match uu___1 with - | DeclAttributes a -> FStar_Pervasives_Native.Some a - | uu___2 -> FStar_Pervasives_Native.None) decorations1 in - at_most_one "attribute set" d.drange uu___ in - let attributes_2 = FStar_Compiler_Util.dflt [] attributes_1 in - let qualifiers1 = - FStar_Compiler_List.choose - (fun uu___ -> - match uu___ with - | Qualifier q -> FStar_Pervasives_Native.Some q - | uu___1 -> FStar_Pervasives_Native.None) decorations1 in - { - d = (d.d); - drange = (d.drange); - quals = qualifiers1; - attrs = attributes_2; - interleaved = (d.interleaved) - } -let (mk_decl : - decl' -> FStar_Compiler_Range_Type.range -> decoration Prims.list -> decl) - = - fun d -> - fun r -> - fun decorations -> - let d1 = - { d; drange = r; quals = []; attrs = []; interleaved = false } in - add_decorations d1 decorations \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Parser_AST_Util.ml b/ocaml/fstar-lib/generated/FStar_Parser_AST_Util.ml deleted file mode 100644 index e1c2dabe240..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Parser_AST_Util.ml +++ /dev/null @@ -1,1238 +0,0 @@ -open Prims -let (eq_ident : FStar_Ident.ident -> FStar_Ident.ident -> Prims.bool) = - fun i1 -> fun i2 -> FStar_Ident.ident_equals i1 i2 -let eq_list : - 'a . - ('a -> 'a -> Prims.bool) -> 'a Prims.list -> 'a Prims.list -> Prims.bool - = - fun f -> - fun t1 -> - fun t2 -> - ((FStar_Compiler_List.length t1) = (FStar_Compiler_List.length t2)) - && (FStar_Compiler_List.forall2 f t1 t2) -let eq_option : - 'a . - ('a -> 'a -> Prims.bool) -> - 'a FStar_Pervasives_Native.option -> - 'a FStar_Pervasives_Native.option -> Prims.bool - = - fun f -> - fun t1 -> - fun t2 -> - match (t1, t2) with - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> - true - | (FStar_Pervasives_Native.Some t11, FStar_Pervasives_Native.Some - t21) -> f t11 t21 - | uu___ -> false -let (eq_sconst : FStar_Const.sconst -> FStar_Const.sconst -> Prims.bool) = - fun c1 -> - fun c2 -> - match (c1, c2) with - | (FStar_Const.Const_effect, FStar_Const.Const_effect) -> true - | (FStar_Const.Const_unit, FStar_Const.Const_unit) -> true - | (FStar_Const.Const_bool b1, FStar_Const.Const_bool b2) -> b1 = b2 - | (FStar_Const.Const_int (s1, sw1), FStar_Const.Const_int (s2, sw2)) -> - (s1 = s2) && (sw1 = sw2) - | (FStar_Const.Const_char c11, FStar_Const.Const_char c21) -> c11 = c21 - | (FStar_Const.Const_string (s1, uu___), FStar_Const.Const_string - (s2, uu___1)) -> s1 = s2 - | (FStar_Const.Const_real s1, FStar_Const.Const_real s2) -> s1 = s2 - | (FStar_Const.Const_range r1, FStar_Const.Const_range r2) -> r1 = r2 - | (FStar_Const.Const_reify uu___, FStar_Const.Const_reify uu___1) -> - true - | (FStar_Const.Const_reflect l1, FStar_Const.Const_reflect l2) -> - FStar_Ident.lid_equals l1 l2 - | uu___ -> false -let rec (eq_term : - FStar_Parser_AST.term -> FStar_Parser_AST.term -> Prims.bool) = - fun t1 -> fun t2 -> eq_term' t1.FStar_Parser_AST.tm t2.FStar_Parser_AST.tm -and (eq_terms : - FStar_Parser_AST.term Prims.list -> - FStar_Parser_AST.term Prims.list -> Prims.bool) - = fun t1 -> fun t2 -> eq_list eq_term t1 t2 -and (eq_arg : - (FStar_Parser_AST.term * FStar_Parser_AST.imp) -> - (FStar_Parser_AST.term * FStar_Parser_AST.imp) -> Prims.bool) - = - fun t1 -> - fun t2 -> - let uu___ = t1 in - match uu___ with - | (t11, a1) -> - let uu___1 = t2 in - (match uu___1 with - | (t21, a2) -> (eq_term t11 t21) && (eq_imp a1 a2)) -and (eq_imp : FStar_Parser_AST.imp -> FStar_Parser_AST.imp -> Prims.bool) = - fun i1 -> - fun i2 -> - match (i1, i2) with - | (FStar_Parser_AST.FsTypApp, FStar_Parser_AST.FsTypApp) -> true - | (FStar_Parser_AST.Hash, FStar_Parser_AST.Hash) -> true - | (FStar_Parser_AST.UnivApp, FStar_Parser_AST.UnivApp) -> true - | (FStar_Parser_AST.Infix, FStar_Parser_AST.Infix) -> true - | (FStar_Parser_AST.Nothing, FStar_Parser_AST.Nothing) -> true - | (FStar_Parser_AST.HashBrace t1, FStar_Parser_AST.HashBrace t2) -> - eq_term t1 t2 - | uu___ -> false -and (eq_args : - (FStar_Parser_AST.term * FStar_Parser_AST.imp) Prims.list -> - (FStar_Parser_AST.term * FStar_Parser_AST.imp) Prims.list -> Prims.bool) - = fun t1 -> fun t2 -> eq_list eq_arg t1 t2 -and (eq_arg_qualifier : - FStar_Parser_AST.arg_qualifier -> - FStar_Parser_AST.arg_qualifier -> Prims.bool) - = - fun arg_qualifier1 -> - fun arg_qualifier2 -> - match (arg_qualifier1, arg_qualifier2) with - | (FStar_Parser_AST.Implicit, FStar_Parser_AST.Implicit) -> true - | (FStar_Parser_AST.Equality, FStar_Parser_AST.Equality) -> true - | (FStar_Parser_AST.Meta t1, FStar_Parser_AST.Meta t2) -> eq_term t1 t2 - | (FStar_Parser_AST.TypeClassArg, FStar_Parser_AST.TypeClassArg) -> - true - | uu___ -> false -and (eq_pattern : - FStar_Parser_AST.pattern -> FStar_Parser_AST.pattern -> Prims.bool) = - fun p1 -> - fun p2 -> eq_pattern' p1.FStar_Parser_AST.pat p2.FStar_Parser_AST.pat -and (eq_aqual : - FStar_Parser_AST.arg_qualifier FStar_Pervasives_Native.option -> - FStar_Parser_AST.arg_qualifier FStar_Pervasives_Native.option -> - Prims.bool) - = fun a1 -> fun a2 -> eq_option eq_arg_qualifier a1 a2 -and (eq_pattern' : - FStar_Parser_AST.pattern' -> FStar_Parser_AST.pattern' -> Prims.bool) = - fun p1 -> - fun p2 -> - match (p1, p2) with - | (FStar_Parser_AST.PatWild (q1, a1), FStar_Parser_AST.PatWild - (q2, a2)) -> (eq_aqual q1 q2) && (eq_terms a1 a2) - | (FStar_Parser_AST.PatConst s1, FStar_Parser_AST.PatConst s2) -> - eq_sconst s1 s2 - | (FStar_Parser_AST.PatApp (p11, ps1), FStar_Parser_AST.PatApp - (p21, ps2)) -> (eq_pattern p11 p21) && (eq_list eq_pattern ps1 ps2) - | (FStar_Parser_AST.PatTvar (i1, aq1, as1), FStar_Parser_AST.PatTvar - (i2, aq2, as2)) -> - ((FStar_Ident.ident_equals i1 i2) && (eq_aqual aq1 aq2)) && - (eq_terms as1 as2) - | (FStar_Parser_AST.PatVar (i1, aq1, as1), FStar_Parser_AST.PatVar - (i2, aq2, as2)) -> - ((FStar_Ident.ident_equals i1 i2) && (eq_aqual aq1 aq2)) && - (eq_terms as1 as2) - | (FStar_Parser_AST.PatName l1, FStar_Parser_AST.PatName l2) -> - FStar_Ident.lid_equals l1 l2 - | (FStar_Parser_AST.PatOr ps1, FStar_Parser_AST.PatOr ps2) -> - eq_list eq_pattern ps1 ps2 - | (FStar_Parser_AST.PatList ps1, FStar_Parser_AST.PatList ps2) -> - eq_list eq_pattern ps1 ps2 - | (FStar_Parser_AST.PatTuple (ps1, b1), FStar_Parser_AST.PatTuple - (ps2, b2)) -> (eq_list eq_pattern ps1 ps2) && (b1 = b2) - | (FStar_Parser_AST.PatRecord ps1, FStar_Parser_AST.PatRecord ps2) -> - eq_list - (fun uu___ -> - fun uu___1 -> - match (uu___, uu___1) with - | ((l1, p11), (l2, p21)) -> - (FStar_Ident.lid_equals l1 l2) && (eq_pattern p11 p21)) - ps1 ps2 - | (FStar_Parser_AST.PatAscribed (p11, (t1, topt1)), - FStar_Parser_AST.PatAscribed (p21, (t2, topt2))) -> - ((eq_pattern p11 p21) && (eq_term t1 t2)) && - (eq_option eq_term topt1 topt2) - | (FStar_Parser_AST.PatOp i1, FStar_Parser_AST.PatOp i2) -> - eq_ident i1 i2 - | (FStar_Parser_AST.PatVQuote t1, FStar_Parser_AST.PatVQuote t2) -> - eq_term t1 t2 - | uu___ -> false -and (eq_term' : - FStar_Parser_AST.term' -> FStar_Parser_AST.term' -> Prims.bool) = - fun t1 -> - fun t2 -> - match (t1, t2) with - | (FStar_Parser_AST.Wild, FStar_Parser_AST.Wild) -> true - | (FStar_Parser_AST.Const s1, FStar_Parser_AST.Const s2) -> - FStar_Const.eq_const s1 s2 - | (FStar_Parser_AST.Op (i1, ts1), FStar_Parser_AST.Op (i2, ts2)) -> - (eq_ident i1 i2) && (eq_terms ts1 ts2) - | (FStar_Parser_AST.Tvar i1, FStar_Parser_AST.Tvar i2) -> - eq_ident i1 i2 - | (FStar_Parser_AST.Uvar i1, FStar_Parser_AST.Uvar i2) -> - eq_ident i1 i2 - | (FStar_Parser_AST.Var l1, FStar_Parser_AST.Var l2) -> - FStar_Ident.lid_equals l1 l2 - | (FStar_Parser_AST.Name l1, FStar_Parser_AST.Name l2) -> - FStar_Ident.lid_equals l1 l2 - | (FStar_Parser_AST.Projector (l1, i1), FStar_Parser_AST.Projector - (l2, i2)) -> - (FStar_Ident.lid_equals l1 l2) && (FStar_Ident.ident_equals i1 i2) - | (FStar_Parser_AST.Construct (l1, args1), FStar_Parser_AST.Construct - (l2, args2)) -> - (FStar_Ident.lid_equals l1 l2) && (eq_args args1 args2) - | (FStar_Parser_AST.Function (brs1, _r1), FStar_Parser_AST.Function - (brs2, _r2)) -> eq_list eq_branch brs1 brs2 - | (FStar_Parser_AST.Abs (ps1, t11), FStar_Parser_AST.Abs (ps2, t21)) -> - (eq_list eq_pattern ps1 ps2) && (eq_term t11 t21) - | (FStar_Parser_AST.App (h1, t11, i1), FStar_Parser_AST.App - (h2, t21, i2)) -> - ((eq_term h1 h2) && (eq_term t11 t21)) && (eq_imp i1 i2) - | (FStar_Parser_AST.Let (lq1, defs1, t11), FStar_Parser_AST.Let - (lq2, defs2, t21)) -> - ((lq1 = lq2) && - (eq_list - (fun uu___ -> - fun uu___1 -> - match (uu___, uu___1) with - | ((o1, (p1, t12)), (o2, (p2, t22))) -> - ((eq_option eq_terms o1 o2) && (eq_pattern p1 p2)) - && (eq_term t12 t22)) defs1 defs2)) - && (eq_term t11 t21) - | (FStar_Parser_AST.LetOperator (defs1, t11), - FStar_Parser_AST.LetOperator (defs2, t21)) -> - (eq_list - (fun uu___ -> - fun uu___1 -> - match (uu___, uu___1) with - | ((i1, ps1, t12), (i2, ps2, t22)) -> - ((eq_ident i1 i2) && (eq_pattern ps1 ps2)) && - (eq_term t12 t22)) defs1 defs2) - && (eq_term t11 t21) - | (FStar_Parser_AST.LetOpen (l1, t11), FStar_Parser_AST.LetOpen - (l2, t21)) -> (FStar_Ident.lid_equals l1 l2) && (eq_term t11 t21) - | (FStar_Parser_AST.LetOpenRecord (t11, t21, t3), - FStar_Parser_AST.LetOpenRecord (t4, t5, t6)) -> - ((eq_term t11 t4) && (eq_term t21 t5)) && (eq_term t3 t6) - | (FStar_Parser_AST.Seq (t11, t21), FStar_Parser_AST.Seq (t3, t4)) -> - (eq_term t11 t3) && (eq_term t21 t4) - | (FStar_Parser_AST.Bind (i1, t11, t21), FStar_Parser_AST.Bind - (i2, t3, t4)) -> - ((FStar_Ident.ident_equals i1 i2) && (eq_term t11 t3)) && - (eq_term t21 t4) - | (FStar_Parser_AST.If (t11, i1, mra1, t21, t3), FStar_Parser_AST.If - (t4, i2, mra2, t5, t6)) -> - ((((eq_term t11 t4) && (eq_option eq_ident i1 i2)) && - (eq_option eq_match_returns_annotation mra1 mra2)) - && (eq_term t21 t5)) - && (eq_term t3 t6) - | (FStar_Parser_AST.Match (t11, i1, mra1, bs1), FStar_Parser_AST.Match - (t21, i2, mra2, bs2)) -> - (((eq_term t11 t21) && (eq_option eq_ident i1 i2)) && - (eq_option eq_match_returns_annotation mra1 mra2)) - && (eq_list eq_branch bs1 bs2) - | (FStar_Parser_AST.TryWith (t11, bs1), FStar_Parser_AST.TryWith - (t21, bs2)) -> (eq_term t11 t21) && (eq_list eq_branch bs1 bs2) - | (FStar_Parser_AST.Ascribed (t11, t21, topt1, b1), - FStar_Parser_AST.Ascribed (t3, t4, topt2, b2)) -> - (((eq_term t11 t3) && (eq_term t21 t4)) && - (eq_option eq_term topt1 topt2)) - && (b1 = b2) - | (FStar_Parser_AST.Record (topt1, fs1), FStar_Parser_AST.Record - (topt2, fs2)) -> - (eq_option eq_term topt1 topt2) && - (eq_list - (fun uu___ -> - fun uu___1 -> - match (uu___, uu___1) with - | ((l1, t11), (l2, t21)) -> - (FStar_Ident.lid_equals l1 l2) && (eq_term t11 t21)) - fs1 fs2) - | (FStar_Parser_AST.Project (t11, l1), FStar_Parser_AST.Project - (t21, l2)) -> (eq_term t11 t21) && (FStar_Ident.lid_equals l1 l2) - | (FStar_Parser_AST.Product (bs1, t11), FStar_Parser_AST.Product - (bs2, t21)) -> (eq_list eq_binder bs1 bs2) && (eq_term t11 t21) - | (FStar_Parser_AST.Sum (bs1, t11), FStar_Parser_AST.Sum (bs2, t21)) -> - (eq_list - (fun b1 -> - fun b2 -> - match (b1, b2) with - | (FStar_Pervasives.Inl b11, FStar_Pervasives.Inl b21) -> - eq_binder b11 b21 - | (FStar_Pervasives.Inr t12, FStar_Pervasives.Inr t22) -> - eq_term t12 t22 - | (FStar_Pervasives.Inl uu___, FStar_Pervasives.Inr uu___1) - -> false - | (FStar_Pervasives.Inr uu___, FStar_Pervasives.Inl uu___1) - -> false) bs1 bs2) - && (eq_term t11 t21) - | (FStar_Parser_AST.QForall (bs1, ps1, t11), FStar_Parser_AST.QForall - (bs2, ps2, t21)) -> - let eq_ps uu___ uu___1 = - match (uu___, uu___1) with - | ((is1, ts1), (is2, ts2)) -> - (eq_list eq_ident is1 is2) && - (eq_list (eq_list eq_term) ts1 ts2) in - ((eq_list eq_binder bs1 bs2) && (eq_ps ps1 ps2)) && - (eq_term t11 t21) - | (FStar_Parser_AST.QExists (bs1, ps1, t11), FStar_Parser_AST.QExists - (bs2, ps2, t21)) -> - let eq_ps uu___ uu___1 = - match (uu___, uu___1) with - | ((is1, ts1), (is2, ts2)) -> - (eq_list eq_ident is1 is2) && - (eq_list (eq_list eq_term) ts1 ts2) in - ((eq_list eq_binder bs1 bs2) && (eq_ps ps1 ps2)) && - (eq_term t11 t21) - | (FStar_Parser_AST.QuantOp (i1, bs1, ps1, t11), - FStar_Parser_AST.QuantOp (i2, bs2, ps2, t21)) -> - let eq_ps uu___ uu___1 = - match (uu___, uu___1) with - | ((is1, ts1), (is2, ts2)) -> - (eq_list eq_ident is1 is2) && - (eq_list (eq_list eq_term) ts1 ts2) in - (((FStar_Ident.ident_equals i1 i2) && (eq_list eq_binder bs1 bs2)) - && (eq_ps ps1 ps2)) - && (eq_term t11 t21) - | (FStar_Parser_AST.Refine (t11, t21), FStar_Parser_AST.Refine - (t3, t4)) -> (eq_binder t11 t3) && (eq_term t21 t4) - | (FStar_Parser_AST.NamedTyp (i1, t11), FStar_Parser_AST.NamedTyp - (i2, t21)) -> (eq_ident i1 i2) && (eq_term t11 t21) - | (FStar_Parser_AST.Paren t11, FStar_Parser_AST.Paren t21) -> - eq_term t11 t21 - | (FStar_Parser_AST.Requires (t11, s1), FStar_Parser_AST.Requires - (t21, s2)) -> (eq_term t11 t21) && (eq_option (=) s1 s2) - | (FStar_Parser_AST.Ensures (t11, s1), FStar_Parser_AST.Ensures - (t21, s2)) -> (eq_term t11 t21) && (eq_option (=) s1 s2) - | (FStar_Parser_AST.LexList ts1, FStar_Parser_AST.LexList ts2) -> - eq_list eq_term ts1 ts2 - | (FStar_Parser_AST.WFOrder (t11, t21), FStar_Parser_AST.WFOrder - (t3, t4)) -> (eq_term t11 t3) && (eq_term t21 t4) - | (FStar_Parser_AST.Decreases (t11, s1), FStar_Parser_AST.Decreases - (t21, s2)) -> (eq_term t11 t21) && (eq_option (=) s1 s2) - | (FStar_Parser_AST.Labeled (t11, s1, b1), FStar_Parser_AST.Labeled - (t21, s2, b2)) -> ((eq_term t11 t21) && (s1 = s2)) && (b1 = b2) - | (FStar_Parser_AST.Discrim l1, FStar_Parser_AST.Discrim l2) -> - FStar_Ident.lid_equals l1 l2 - | (FStar_Parser_AST.Attributes ts1, FStar_Parser_AST.Attributes ts2) -> - eq_list eq_term ts1 ts2 - | (FStar_Parser_AST.Antiquote t11, FStar_Parser_AST.Antiquote t21) -> - eq_term t11 t21 - | (FStar_Parser_AST.Quote (t11, k1), FStar_Parser_AST.Quote (t21, k2)) - -> (eq_term t11 t21) && (k1 = k2) - | (FStar_Parser_AST.VQuote t11, FStar_Parser_AST.VQuote t21) -> - eq_term t11 t21 - | (FStar_Parser_AST.CalcProof (t11, t21, cs1), - FStar_Parser_AST.CalcProof (t3, t4, cs2)) -> - ((eq_term t11 t3) && (eq_term t21 t4)) && - (eq_list eq_calc_step cs1 cs2) - | (FStar_Parser_AST.IntroForall (bs1, t11, t21), - FStar_Parser_AST.IntroForall (bs2, t3, t4)) -> - ((eq_list eq_binder bs1 bs2) && (eq_term t11 t3)) && - (eq_term t21 t4) - | (FStar_Parser_AST.IntroExists (bs1, t11, ts1, t21), - FStar_Parser_AST.IntroExists (bs2, t3, ts2, t4)) -> - (((eq_list eq_binder bs1 bs2) && (eq_term t11 t3)) && - (eq_list eq_term ts1 ts2)) - && (eq_term t21 t4) - | (FStar_Parser_AST.IntroImplies (t11, t21, b1, t3), - FStar_Parser_AST.IntroImplies (t4, t5, b2, t6)) -> - (((eq_term t11 t4) && (eq_term t21 t5)) && (eq_binder b1 b2)) && - (eq_term t3 t6) - | (FStar_Parser_AST.IntroOr (b1, t11, t21, t3), - FStar_Parser_AST.IntroOr (b2, t4, t5, t6)) -> - (((b1 = b2) && (eq_term t11 t4)) && (eq_term t21 t5)) && - (eq_term t3 t6) - | (FStar_Parser_AST.IntroAnd (t11, t21, t3, t4), - FStar_Parser_AST.IntroAnd (t5, t6, t7, t8)) -> - (((eq_term t11 t5) && (eq_term t21 t6)) && (eq_term t3 t7)) && - (eq_term t4 t8) - | (FStar_Parser_AST.ElimForall (bs1, t11, ts1), - FStar_Parser_AST.ElimForall (bs2, t21, ts2)) -> - ((eq_list eq_binder bs1 bs2) && (eq_term t11 t21)) && - (eq_list eq_term ts1 ts2) - | (FStar_Parser_AST.ElimExists (bs1, t11, t21, b1, t3), - FStar_Parser_AST.ElimExists (bs2, t4, t5, b2, t6)) -> - ((((eq_list eq_binder bs1 bs2) && (eq_term t11 t4)) && - (eq_term t21 t5)) - && (eq_binder b1 b2)) - && (eq_term t3 t6) - | (FStar_Parser_AST.ElimImplies (t11, t21, t3), - FStar_Parser_AST.ElimImplies (t4, t5, t6)) -> - ((eq_term t11 t4) && (eq_term t21 t5)) && (eq_term t3 t6) - | (FStar_Parser_AST.ElimOr (t11, t21, t3, b1, t4, b2, t5), - FStar_Parser_AST.ElimOr (t6, t7, t8, b3, t9, b4, t10)) -> - ((((((eq_term t11 t6) && (eq_term t21 t7)) && (eq_term t3 t8)) && - (eq_binder b1 b3)) - && (eq_term t4 t9)) - && (eq_binder b2 b4)) - && (eq_term t5 t10) - | (FStar_Parser_AST.ElimAnd (t11, t21, t3, b1, b2, t4), - FStar_Parser_AST.ElimAnd (t5, t6, t7, b3, b4, t8)) -> - (((((eq_term t11 t5) && (eq_term t21 t6)) && (eq_term t3 t7)) && - (eq_binder b1 b3)) - && (eq_binder b2 b4)) - && (eq_term t4 t8) - | (FStar_Parser_AST.ListLiteral ts1, FStar_Parser_AST.ListLiteral ts2) - -> eq_list eq_term ts1 ts2 - | (FStar_Parser_AST.SeqLiteral ts1, FStar_Parser_AST.SeqLiteral ts2) -> - eq_list eq_term ts1 ts2 - | uu___ -> false -and (eq_calc_step : - FStar_Parser_AST.calc_step -> FStar_Parser_AST.calc_step -> Prims.bool) = - fun uu___ -> - fun uu___1 -> - match (uu___, uu___1) with - | (FStar_Parser_AST.CalcStep (t1, t2, t3), FStar_Parser_AST.CalcStep - (t4, t5, t6)) -> - ((eq_term t1 t4) && (eq_term t2 t5)) && (eq_term t3 t6) -and (eq_binder : - FStar_Parser_AST.binder -> FStar_Parser_AST.binder -> Prims.bool) = - fun b1 -> - fun b2 -> - ((eq_binder' b1.FStar_Parser_AST.b b2.FStar_Parser_AST.b) && - (eq_aqual b1.FStar_Parser_AST.aqual b2.FStar_Parser_AST.aqual)) - && - (eq_list eq_term b1.FStar_Parser_AST.battributes - b2.FStar_Parser_AST.battributes) -and (eq_binder' : - FStar_Parser_AST.binder' -> FStar_Parser_AST.binder' -> Prims.bool) = - fun b1 -> - fun b2 -> - match (b1, b2) with - | (FStar_Parser_AST.Variable i1, FStar_Parser_AST.Variable i2) -> - eq_ident i1 i2 - | (FStar_Parser_AST.TVariable i1, FStar_Parser_AST.TVariable i2) -> - eq_ident i1 i2 - | (FStar_Parser_AST.Annotated (i1, t1), FStar_Parser_AST.Annotated - (i2, t2)) -> (eq_ident i1 i2) && (eq_term t1 t2) - | (FStar_Parser_AST.TAnnotated (i1, t1), FStar_Parser_AST.TAnnotated - (i2, t2)) -> (eq_ident i1 i2) && (eq_term t1 t2) - | (FStar_Parser_AST.NoName t1, FStar_Parser_AST.NoName t2) -> - eq_term t1 t2 - | uu___ -> false -and (eq_match_returns_annotation : - (FStar_Ident.ident FStar_Pervasives_Native.option * FStar_Parser_AST.term * - Prims.bool) -> - (FStar_Ident.ident FStar_Pervasives_Native.option * FStar_Parser_AST.term - * Prims.bool) -> Prims.bool) - = - fun uu___ -> - fun uu___1 -> - match (uu___, uu___1) with - | ((i1, t1, b1), (i2, t2, b2)) -> - ((eq_option eq_ident i1 i2) && (eq_term t1 t2)) && (b1 = b2) -and (eq_branch : - (FStar_Parser_AST.pattern * FStar_Parser_AST.term - FStar_Pervasives_Native.option * FStar_Parser_AST.term) -> - (FStar_Parser_AST.pattern * FStar_Parser_AST.term - FStar_Pervasives_Native.option * FStar_Parser_AST.term) -> Prims.bool) - = - fun uu___ -> - fun uu___1 -> - match (uu___, uu___1) with - | ((p1, o1, t1), (p2, o2, t2)) -> - ((eq_pattern p1 p2) && (eq_option eq_term o1 o2)) && - (eq_term t1 t2) -let (eq_tycon_record : - FStar_Parser_AST.tycon_record -> - FStar_Parser_AST.tycon_record -> Prims.bool) - = - fun t1 -> - fun t2 -> - eq_list - (fun uu___ -> - fun uu___1 -> - match (uu___, uu___1) with - | ((i1, a1, a2, t11), (i2, a3, a4, t21)) -> - (((eq_ident i1 i2) && (eq_aqual a1 a3)) && - (eq_list eq_term a2 a4)) - && (eq_term t11 t21)) t1 t2 -let (eq_constructor_payload : - FStar_Parser_AST.constructor_payload -> - FStar_Parser_AST.constructor_payload -> Prims.bool) - = - fun t1 -> - fun t2 -> - match (t1, t2) with - | (FStar_Parser_AST.VpOfNotation t11, FStar_Parser_AST.VpOfNotation - t21) -> eq_term t11 t21 - | (FStar_Parser_AST.VpArbitrary t11, FStar_Parser_AST.VpArbitrary t21) - -> eq_term t11 t21 - | (FStar_Parser_AST.VpRecord (r1, k1), FStar_Parser_AST.VpRecord - (r2, k2)) -> (eq_tycon_record r1 r2) && (eq_option eq_term k1 k2) - | uu___ -> false -let (eq_tycon : - FStar_Parser_AST.tycon -> FStar_Parser_AST.tycon -> Prims.bool) = - fun t1 -> - fun t2 -> - match (t1, t2) with - | (FStar_Parser_AST.TyconAbstract (i1, bs1, k1), - FStar_Parser_AST.TyconAbstract (i2, bs2, k2)) -> - ((eq_ident i1 i2) && (eq_list eq_binder bs1 bs2)) && - (eq_option eq_term k1 k2) - | (FStar_Parser_AST.TyconAbbrev (i1, bs1, k1, t11), - FStar_Parser_AST.TyconAbbrev (i2, bs2, k2, t21)) -> - (((eq_ident i1 i2) && (eq_list eq_binder bs1 bs2)) && - (eq_option eq_term k1 k2)) - && (eq_term t11 t21) - | (FStar_Parser_AST.TyconRecord (i1, bs1, k1, a1, r1), - FStar_Parser_AST.TyconRecord (i2, bs2, k2, a2, r2)) -> - ((((eq_ident i1 i2) && (eq_list eq_binder bs1 bs2)) && - (eq_option eq_term k1 k2)) - && (eq_list eq_term a1 a2)) - && (eq_tycon_record r1 r2) - | (FStar_Parser_AST.TyconVariant (i1, bs1, k1, cs1), - FStar_Parser_AST.TyconVariant (i2, bs2, k2, cs2)) -> - (((eq_ident i1 i2) && (eq_list eq_binder bs1 bs2)) && - (eq_option eq_term k1 k2)) - && - (eq_list - (fun uu___ -> - fun uu___1 -> - match (uu___, uu___1) with - | ((i11, o1, a1), (i21, o2, a2)) -> - ((eq_ident i11 i21) && - (eq_option eq_constructor_payload o1 o2)) - && (eq_list eq_term a1 a2)) cs1 cs2) - | uu___ -> false -let (eq_lid : FStar_Ident.lident -> FStar_Ident.lident -> Prims.bool) = - FStar_Ident.lid_equals -let (eq_lift : FStar_Parser_AST.lift -> FStar_Parser_AST.lift -> Prims.bool) - = - fun t1 -> - fun t2 -> - ((eq_lid t1.FStar_Parser_AST.msource t2.FStar_Parser_AST.msource) && - (eq_lid t1.FStar_Parser_AST.mdest t2.FStar_Parser_AST.mdest)) - && - (match ((t1.FStar_Parser_AST.lift_op), (t2.FStar_Parser_AST.lift_op)) - with - | (FStar_Parser_AST.NonReifiableLift t11, - FStar_Parser_AST.NonReifiableLift t21) -> eq_term t11 t21 - | (FStar_Parser_AST.ReifiableLift (t11, t21), - FStar_Parser_AST.ReifiableLift (t3, t4)) -> - (eq_term t11 t3) && (eq_term t21 t4) - | (FStar_Parser_AST.LiftForFree t11, FStar_Parser_AST.LiftForFree - t21) -> eq_term t11 t21 - | uu___ -> false) -let (eq_pragma : - FStar_Parser_AST.pragma -> FStar_Parser_AST.pragma -> Prims.bool) = - fun t1 -> - fun t2 -> - match (t1, t2) with - | (FStar_Parser_AST.SetOptions s1, FStar_Parser_AST.SetOptions s2) -> - s1 = s2 - | (FStar_Parser_AST.ResetOptions s1, FStar_Parser_AST.ResetOptions s2) - -> eq_option (fun s11 -> fun s21 -> s11 = s21) s1 s2 - | (FStar_Parser_AST.PushOptions s1, FStar_Parser_AST.PushOptions s2) -> - eq_option (fun s11 -> fun s21 -> s11 = s21) s1 s2 - | (FStar_Parser_AST.PopOptions, FStar_Parser_AST.PopOptions) -> true - | (FStar_Parser_AST.RestartSolver, FStar_Parser_AST.RestartSolver) -> - true - | (FStar_Parser_AST.PrintEffectsGraph, - FStar_Parser_AST.PrintEffectsGraph) -> true - | uu___ -> false -let (eq_qualifier : - FStar_Parser_AST.qualifier -> FStar_Parser_AST.qualifier -> Prims.bool) = - fun t1 -> - fun t2 -> - match (t1, t2) with - | (FStar_Parser_AST.Private, FStar_Parser_AST.Private) -> true - | (FStar_Parser_AST.Noeq, FStar_Parser_AST.Noeq) -> true - | (FStar_Parser_AST.Unopteq, FStar_Parser_AST.Unopteq) -> true - | (FStar_Parser_AST.Assumption, FStar_Parser_AST.Assumption) -> true - | (FStar_Parser_AST.DefaultEffect, FStar_Parser_AST.DefaultEffect) -> - true - | (FStar_Parser_AST.TotalEffect, FStar_Parser_AST.TotalEffect) -> true - | (FStar_Parser_AST.Effect_qual, FStar_Parser_AST.Effect_qual) -> true - | (FStar_Parser_AST.New, FStar_Parser_AST.New) -> true - | (FStar_Parser_AST.Inline, FStar_Parser_AST.Inline) -> true - | (FStar_Parser_AST.Visible, FStar_Parser_AST.Visible) -> true - | (FStar_Parser_AST.Unfold_for_unification_and_vcgen, - FStar_Parser_AST.Unfold_for_unification_and_vcgen) -> true - | (FStar_Parser_AST.Inline_for_extraction, - FStar_Parser_AST.Inline_for_extraction) -> true - | (FStar_Parser_AST.Irreducible, FStar_Parser_AST.Irreducible) -> true - | (FStar_Parser_AST.NoExtract, FStar_Parser_AST.NoExtract) -> true - | (FStar_Parser_AST.Reifiable, FStar_Parser_AST.Reifiable) -> true - | (FStar_Parser_AST.Reflectable, FStar_Parser_AST.Reflectable) -> true - | (FStar_Parser_AST.Opaque, FStar_Parser_AST.Opaque) -> true - | (FStar_Parser_AST.Logic, FStar_Parser_AST.Logic) -> true - | uu___ -> false -let (eq_qualifiers : - FStar_Parser_AST.qualifiers -> FStar_Parser_AST.qualifiers -> Prims.bool) = - fun t1 -> fun t2 -> eq_list eq_qualifier t1 t2 -let (eq_restriction : - FStar_Syntax_Syntax.restriction -> - FStar_Syntax_Syntax.restriction -> Prims.bool) - = - fun restriction1 -> - fun restriction2 -> - match (restriction1, restriction2) with - | (FStar_Syntax_Syntax.Unrestricted, FStar_Syntax_Syntax.Unrestricted) - -> true - | (FStar_Syntax_Syntax.AllowList l1, FStar_Syntax_Syntax.AllowList l2) - -> - let eq_tuple eq_fst eq_snd uu___ uu___1 = - match (uu___, uu___1) with - | ((a, b), (c, d)) -> (eq_fst a c) && (eq_snd b d) in - eq_list (eq_tuple eq_ident (eq_option eq_ident)) l1 l2 -let rec (eq_decl' : - FStar_Parser_AST.decl' -> FStar_Parser_AST.decl' -> Prims.bool) = - fun d1 -> - fun d2 -> - match (d1, d2) with - | (FStar_Parser_AST.TopLevelModule lid1, - FStar_Parser_AST.TopLevelModule lid2) -> eq_lid lid1 lid2 - | (FStar_Parser_AST.Open (lid1, restriction1), FStar_Parser_AST.Open - (lid2, restriction2)) -> - (eq_lid lid1 lid2) && (eq_restriction restriction1 restriction2) - | (FStar_Parser_AST.Friend lid1, FStar_Parser_AST.Friend lid2) -> - eq_lid lid1 lid2 - | (FStar_Parser_AST.Include (lid1, restriction1), - FStar_Parser_AST.Include (lid2, restriction2)) -> - (eq_lid lid1 lid2) && (eq_restriction restriction1 restriction2) - | (FStar_Parser_AST.ModuleAbbrev (i1, lid1), - FStar_Parser_AST.ModuleAbbrev (i2, lid2)) -> - (eq_ident i1 i2) && (eq_lid lid1 lid2) - | (FStar_Parser_AST.TopLevelLet (lq1, pats1), - FStar_Parser_AST.TopLevelLet (lq2, pats2)) -> - (lq1 = lq2) && - (eq_list - (fun uu___ -> - fun uu___1 -> - match (uu___, uu___1) with - | ((p1, t1), (p2, t2)) -> - (eq_pattern p1 p2) && (eq_term t1 t2)) pats1 pats2) - | (FStar_Parser_AST.Tycon (b1, b2, tcs1), FStar_Parser_AST.Tycon - (b3, b4, tcs2)) -> - ((b1 = b3) && (b2 = b4)) && (eq_list eq_tycon tcs1 tcs2) - | (FStar_Parser_AST.Val (i1, t1), FStar_Parser_AST.Val (i2, t2)) -> - (eq_ident i1 i2) && (eq_term t1 t2) - | (FStar_Parser_AST.Exception (i1, t1), FStar_Parser_AST.Exception - (i2, t2)) -> (eq_ident i1 i2) && (eq_option eq_term t1 t2) - | (FStar_Parser_AST.NewEffect ed1, FStar_Parser_AST.NewEffect ed2) -> - eq_effect_decl ed1 ed2 - | (FStar_Parser_AST.LayeredEffect ed1, FStar_Parser_AST.LayeredEffect - ed2) -> eq_effect_decl ed1 ed2 - | (FStar_Parser_AST.SubEffect l1, FStar_Parser_AST.SubEffect l2) -> - eq_lift l1 l2 - | (FStar_Parser_AST.Polymonadic_bind (lid1, lid2, lid3, t1), - FStar_Parser_AST.Polymonadic_bind (lid4, lid5, lid6, t2)) -> - (((eq_lid lid1 lid4) && (eq_lid lid2 lid5)) && (eq_lid lid3 lid6)) - && (eq_term t1 t2) - | (FStar_Parser_AST.Polymonadic_subcomp (lid1, lid2, t1), - FStar_Parser_AST.Polymonadic_subcomp (lid3, lid4, t2)) -> - ((eq_lid lid1 lid3) && (eq_lid lid2 lid4)) && (eq_term t1 t2) - | (FStar_Parser_AST.Pragma p1, FStar_Parser_AST.Pragma p2) -> - eq_pragma p1 p2 - | (FStar_Parser_AST.Assume (i1, t1), FStar_Parser_AST.Assume (i2, t2)) - -> (eq_ident i1 i2) && (eq_term t1 t2) - | (FStar_Parser_AST.Splice (is_typed1, is1, t1), - FStar_Parser_AST.Splice (is_typed2, is2, t2)) -> - ((is_typed1 = is_typed2) && (eq_list eq_ident is1 is2)) && - (eq_term t1 t2) - | (FStar_Parser_AST.DeclSyntaxExtension (s1, t1, uu___, uu___1), - FStar_Parser_AST.DeclSyntaxExtension (s2, t2, uu___2, uu___3)) -> - (s1 = s2) && (t1 = t2) - | (FStar_Parser_AST.UseLangDecls p1, FStar_Parser_AST.UseLangDecls p2) - -> p1 = p2 - | (FStar_Parser_AST.DeclToBeDesugared tbs1, - FStar_Parser_AST.DeclToBeDesugared tbs2) -> - (tbs1.FStar_Parser_AST.lang_name = tbs2.FStar_Parser_AST.lang_name) - && - (tbs1.FStar_Parser_AST.eq tbs1.FStar_Parser_AST.blob - tbs2.FStar_Parser_AST.blob) - | uu___ -> false -and (eq_effect_decl : - FStar_Parser_AST.effect_decl -> FStar_Parser_AST.effect_decl -> Prims.bool) - = - fun t1 -> - fun t2 -> - match (t1, t2) with - | (FStar_Parser_AST.DefineEffect (i1, bs1, t11, ds1), - FStar_Parser_AST.DefineEffect (i2, bs2, t21, ds2)) -> - (((eq_ident i1 i2) && (eq_list eq_binder bs1 bs2)) && - (eq_term t11 t21)) - && (eq_list eq_decl ds1 ds2) - | (FStar_Parser_AST.RedefineEffect (i1, bs1, t11), - FStar_Parser_AST.RedefineEffect (i2, bs2, t21)) -> - ((eq_ident i1 i2) && (eq_list eq_binder bs1 bs2)) && - (eq_term t11 t21) - | uu___ -> false -and (eq_decl : FStar_Parser_AST.decl -> FStar_Parser_AST.decl -> Prims.bool) - = - fun d1 -> - fun d2 -> - ((eq_decl' d1.FStar_Parser_AST.d d2.FStar_Parser_AST.d) && - (eq_list eq_qualifier d1.FStar_Parser_AST.quals - d2.FStar_Parser_AST.quals)) - && - (eq_list eq_term d1.FStar_Parser_AST.attrs d2.FStar_Parser_AST.attrs) -let concat_map : - 'uuuuu 'uuuuu1 . - unit -> - ('uuuuu -> 'uuuuu1 Prims.list) -> - 'uuuuu Prims.list -> 'uuuuu1 Prims.list - = fun uu___ -> FStar_Compiler_List.collect -let opt_map : - 'uuuuu 'a . - ('a -> 'uuuuu Prims.list) -> - 'a FStar_Pervasives_Native.option -> 'uuuuu Prims.list - = - fun f -> - fun x -> - match x with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some x1 -> f x1 -let rec (lidents_of_term : - FStar_Parser_AST.term -> FStar_Ident.lident Prims.list) = - fun t -> lidents_of_term' t.FStar_Parser_AST.tm -and (lidents_of_term' : - FStar_Parser_AST.term' -> FStar_Ident.lident Prims.list) = - fun t -> - match t with - | FStar_Parser_AST.Wild -> [] - | FStar_Parser_AST.Const uu___ -> [] - | FStar_Parser_AST.Op (s, ts) -> (concat_map ()) lidents_of_term ts - | FStar_Parser_AST.Tvar uu___ -> [] - | FStar_Parser_AST.Uvar uu___ -> [] - | FStar_Parser_AST.Var lid -> [lid] - | FStar_Parser_AST.Name lid -> [lid] - | FStar_Parser_AST.Projector (lid, uu___) -> [lid] - | FStar_Parser_AST.Construct (lid, ts) -> - let uu___ = - (concat_map ()) - (fun uu___1 -> - match uu___1 with | (t1, uu___2) -> lidents_of_term t1) ts in - lid :: uu___ - | FStar_Parser_AST.Function (brs, uu___) -> - (concat_map ()) lidents_of_branch brs - | FStar_Parser_AST.Abs (ps, t1) -> - let uu___ = (concat_map ()) lidents_of_pattern ps in - let uu___1 = lidents_of_term t1 in - FStar_Compiler_List.op_At uu___ uu___1 - | FStar_Parser_AST.App (t1, t2, uu___) -> - let uu___1 = lidents_of_term t1 in - let uu___2 = lidents_of_term t2 in - FStar_Compiler_List.op_At uu___1 uu___2 - | FStar_Parser_AST.Let (uu___, lbs, t1) -> - let uu___1 = - (concat_map ()) - (fun uu___2 -> - match uu___2 with - | (uu___3, (p, t2)) -> - let uu___4 = lidents_of_pattern p in - let uu___5 = lidents_of_term t2 in - FStar_Compiler_List.op_At uu___4 uu___5) lbs in - let uu___2 = lidents_of_term t1 in - FStar_Compiler_List.op_At uu___1 uu___2 - | FStar_Parser_AST.LetOperator (lbs, t1) -> - let uu___ = - (concat_map ()) - (fun uu___1 -> - match uu___1 with - | (uu___2, p, t2) -> - let uu___3 = lidents_of_pattern p in - let uu___4 = lidents_of_term t2 in - FStar_Compiler_List.op_At uu___3 uu___4) lbs in - let uu___1 = lidents_of_term t1 in - FStar_Compiler_List.op_At uu___ uu___1 - | FStar_Parser_AST.LetOpen (lid, t1) -> - let uu___ = lidents_of_term t1 in lid :: uu___ - | FStar_Parser_AST.LetOpenRecord (t1, t2, t3) -> - let uu___ = lidents_of_term t1 in - let uu___1 = - let uu___2 = lidents_of_term t2 in - let uu___3 = lidents_of_term t3 in - FStar_Compiler_List.op_At uu___2 uu___3 in - FStar_Compiler_List.op_At uu___ uu___1 - | FStar_Parser_AST.Seq (t1, t2) -> - let uu___ = lidents_of_term t1 in - let uu___1 = lidents_of_term t2 in - FStar_Compiler_List.op_At uu___ uu___1 - | FStar_Parser_AST.Bind (uu___, t1, t2) -> - let uu___1 = lidents_of_term t1 in - let uu___2 = lidents_of_term t2 in - FStar_Compiler_List.op_At uu___1 uu___2 - | FStar_Parser_AST.If (t1, uu___, uu___1, t2, t3) -> - let uu___2 = lidents_of_term t1 in - let uu___3 = - let uu___4 = lidents_of_term t2 in - let uu___5 = lidents_of_term t3 in - FStar_Compiler_List.op_At uu___4 uu___5 in - FStar_Compiler_List.op_At uu___2 uu___3 - | FStar_Parser_AST.Match (t1, uu___, uu___1, bs) -> - let uu___2 = lidents_of_term t1 in - let uu___3 = (concat_map ()) lidents_of_branch bs in - FStar_Compiler_List.op_At uu___2 uu___3 - | FStar_Parser_AST.TryWith (t1, bs) -> - let uu___ = lidents_of_term t1 in - let uu___1 = (concat_map ()) lidents_of_branch bs in - FStar_Compiler_List.op_At uu___ uu___1 - | FStar_Parser_AST.Ascribed (t1, t2, uu___, uu___1) -> - let uu___2 = lidents_of_term t1 in - let uu___3 = lidents_of_term t2 in - FStar_Compiler_List.op_At uu___2 uu___3 - | FStar_Parser_AST.Record (t1, ts) -> - let uu___ = - (concat_map ()) - (fun uu___1 -> - match uu___1 with | (uu___2, t2) -> lidents_of_term t2) ts in - let uu___1 = opt_map lidents_of_term t1 in - FStar_Compiler_List.op_At uu___ uu___1 - | FStar_Parser_AST.Project (t1, uu___) -> lidents_of_term t1 - | FStar_Parser_AST.Product (ts, t1) -> - let uu___ = (concat_map ()) lidents_of_binder ts in - let uu___1 = lidents_of_term t1 in - FStar_Compiler_List.op_At uu___ uu___1 - | FStar_Parser_AST.Sum (ts, t1) -> - let uu___ = - (concat_map ()) - (fun uu___1 -> - match uu___1 with - | FStar_Pervasives.Inl b -> lidents_of_binder b - | FStar_Pervasives.Inr t2 -> lidents_of_term t2) ts in - let uu___1 = lidents_of_term t1 in - FStar_Compiler_List.op_At uu___ uu___1 - | FStar_Parser_AST.QForall (bs, _pats, t1) -> lidents_of_term t1 - | FStar_Parser_AST.QExists (bs, _pats, t1) -> lidents_of_term t1 - | FStar_Parser_AST.QuantOp (i, bs, pats, t1) -> lidents_of_term t1 - | FStar_Parser_AST.Refine (b, t1) -> lidents_of_term t1 - | FStar_Parser_AST.NamedTyp (i, t1) -> lidents_of_term t1 - | FStar_Parser_AST.Paren t1 -> lidents_of_term t1 - | FStar_Parser_AST.Requires (t1, uu___) -> lidents_of_term t1 - | FStar_Parser_AST.Ensures (t1, uu___) -> lidents_of_term t1 - | FStar_Parser_AST.LexList ts -> (concat_map ()) lidents_of_term ts - | FStar_Parser_AST.WFOrder (t1, t2) -> - let uu___ = lidents_of_term t1 in - let uu___1 = lidents_of_term t2 in - FStar_Compiler_List.op_At uu___ uu___1 - | FStar_Parser_AST.Decreases (t1, uu___) -> lidents_of_term t1 - | FStar_Parser_AST.Labeled (t1, uu___, uu___1) -> lidents_of_term t1 - | FStar_Parser_AST.Discrim lid -> [lid] - | FStar_Parser_AST.Attributes ts -> (concat_map ()) lidents_of_term ts - | FStar_Parser_AST.Antiquote t1 -> lidents_of_term t1 - | FStar_Parser_AST.Quote (t1, uu___) -> lidents_of_term t1 - | FStar_Parser_AST.VQuote t1 -> lidents_of_term t1 - | FStar_Parser_AST.CalcProof (t1, t2, ts) -> - let uu___ = lidents_of_term t1 in - let uu___1 = - let uu___2 = lidents_of_term t2 in - let uu___3 = (concat_map ()) lidents_of_calc_step ts in - FStar_Compiler_List.op_At uu___2 uu___3 in - FStar_Compiler_List.op_At uu___ uu___1 - | FStar_Parser_AST.IntroForall (bs, t1, t2) -> - let uu___ = lidents_of_term t1 in - let uu___1 = lidents_of_term t2 in - FStar_Compiler_List.op_At uu___ uu___1 - | FStar_Parser_AST.IntroExists (bs, t1, ts, t2) -> - let uu___ = lidents_of_term t1 in - let uu___1 = - let uu___2 = (concat_map ()) lidents_of_term ts in - let uu___3 = lidents_of_term t2 in - FStar_Compiler_List.op_At uu___2 uu___3 in - FStar_Compiler_List.op_At uu___ uu___1 - | FStar_Parser_AST.IntroImplies (t1, t2, b, t3) -> - let uu___ = lidents_of_term t1 in - let uu___1 = - let uu___2 = lidents_of_term t2 in - let uu___3 = lidents_of_term t3 in - FStar_Compiler_List.op_At uu___2 uu___3 in - FStar_Compiler_List.op_At uu___ uu___1 - | FStar_Parser_AST.IntroOr (b, t1, t2, t3) -> - let uu___ = lidents_of_term t1 in - let uu___1 = - let uu___2 = lidents_of_term t2 in - let uu___3 = lidents_of_term t3 in - FStar_Compiler_List.op_At uu___2 uu___3 in - FStar_Compiler_List.op_At uu___ uu___1 - | FStar_Parser_AST.IntroAnd (t1, t2, t3, t4) -> - let uu___ = lidents_of_term t1 in - let uu___1 = - let uu___2 = lidents_of_term t2 in - let uu___3 = - let uu___4 = lidents_of_term t3 in - let uu___5 = lidents_of_term t4 in - FStar_Compiler_List.op_At uu___4 uu___5 in - FStar_Compiler_List.op_At uu___2 uu___3 in - FStar_Compiler_List.op_At uu___ uu___1 - | FStar_Parser_AST.ElimForall (bs, t1, ts) -> - let uu___ = (concat_map ()) lidents_of_binder bs in - let uu___1 = - let uu___2 = lidents_of_term t1 in - let uu___3 = (concat_map ()) lidents_of_term ts in - FStar_Compiler_List.op_At uu___2 uu___3 in - FStar_Compiler_List.op_At uu___ uu___1 - | FStar_Parser_AST.ElimExists (bs, t1, t2, b, t3) -> - let uu___ = (concat_map ()) lidents_of_binder bs in - let uu___1 = - let uu___2 = lidents_of_term t1 in - let uu___3 = - let uu___4 = lidents_of_term t2 in - let uu___5 = lidents_of_term t3 in - FStar_Compiler_List.op_At uu___4 uu___5 in - FStar_Compiler_List.op_At uu___2 uu___3 in - FStar_Compiler_List.op_At uu___ uu___1 - | FStar_Parser_AST.ElimImplies (t1, t2, t3) -> - let uu___ = lidents_of_term t1 in - let uu___1 = - let uu___2 = lidents_of_term t2 in - let uu___3 = lidents_of_term t3 in - FStar_Compiler_List.op_At uu___2 uu___3 in - FStar_Compiler_List.op_At uu___ uu___1 - | FStar_Parser_AST.ElimOr (t1, t2, t3, b1, t4, b2, t5) -> - let uu___ = lidents_of_term t1 in - let uu___1 = - let uu___2 = lidents_of_term t2 in - let uu___3 = - let uu___4 = lidents_of_term t3 in - let uu___5 = - let uu___6 = lidents_of_term t4 in - let uu___7 = lidents_of_term t5 in - FStar_Compiler_List.op_At uu___6 uu___7 in - FStar_Compiler_List.op_At uu___4 uu___5 in - FStar_Compiler_List.op_At uu___2 uu___3 in - FStar_Compiler_List.op_At uu___ uu___1 - | FStar_Parser_AST.ElimAnd (t1, t2, t3, b1, b2, t4) -> - let uu___ = lidents_of_term t1 in - let uu___1 = - let uu___2 = lidents_of_term t2 in - let uu___3 = - let uu___4 = lidents_of_term t3 in - let uu___5 = lidents_of_term t4 in - FStar_Compiler_List.op_At uu___4 uu___5 in - FStar_Compiler_List.op_At uu___2 uu___3 in - FStar_Compiler_List.op_At uu___ uu___1 - | FStar_Parser_AST.ListLiteral ts -> (concat_map ()) lidents_of_term ts - | FStar_Parser_AST.SeqLiteral ts -> (concat_map ()) lidents_of_term ts -and (lidents_of_branch : - (FStar_Parser_AST.pattern * FStar_Parser_AST.term - FStar_Pervasives_Native.option * FStar_Parser_AST.term) -> - FStar_Ident.lident Prims.list) - = - fun uu___ -> - match uu___ with - | (p, uu___1, t) -> - let uu___2 = lidents_of_pattern p in - let uu___3 = lidents_of_term t in - FStar_Compiler_List.op_At uu___2 uu___3 -and (lidents_of_calc_step : - FStar_Parser_AST.calc_step -> FStar_Ident.lident Prims.list) = - fun uu___ -> - match uu___ with - | FStar_Parser_AST.CalcStep (t1, t2, t3) -> - let uu___1 = lidents_of_term t1 in - let uu___2 = - let uu___3 = lidents_of_term t2 in - let uu___4 = lidents_of_term t3 in - FStar_Compiler_List.op_At uu___3 uu___4 in - FStar_Compiler_List.op_At uu___1 uu___2 -and (lidents_of_pattern : - FStar_Parser_AST.pattern -> FStar_Ident.lident Prims.list) = - fun p -> - match p.FStar_Parser_AST.pat with - | FStar_Parser_AST.PatWild uu___ -> [] - | FStar_Parser_AST.PatConst uu___ -> [] - | FStar_Parser_AST.PatApp (p1, ps) -> - let uu___ = lidents_of_pattern p1 in - let uu___1 = (concat_map ()) lidents_of_pattern ps in - FStar_Compiler_List.op_At uu___ uu___1 - | FStar_Parser_AST.PatVar (i, uu___, uu___1) -> - let uu___2 = FStar_Ident.lid_of_ids [i] in [uu___2] - | FStar_Parser_AST.PatName lid -> [lid] - | FStar_Parser_AST.PatTvar (i, uu___, uu___1) -> [] - | FStar_Parser_AST.PatList ps -> (concat_map ()) lidents_of_pattern ps - | FStar_Parser_AST.PatTuple (ps, uu___) -> - (concat_map ()) lidents_of_pattern ps - | FStar_Parser_AST.PatRecord ps -> - (concat_map ()) - (fun uu___ -> - match uu___ with | (uu___1, p1) -> lidents_of_pattern p1) ps - | FStar_Parser_AST.PatAscribed (p1, (t1, t2)) -> - let uu___ = lidents_of_pattern p1 in - let uu___1 = - let uu___2 = lidents_of_term t1 in - let uu___3 = opt_map lidents_of_term t2 in - FStar_Compiler_List.op_At uu___2 uu___3 in - FStar_Compiler_List.op_At uu___ uu___1 - | FStar_Parser_AST.PatOr ps -> (concat_map ()) lidents_of_pattern ps - | FStar_Parser_AST.PatOp uu___ -> [] - | FStar_Parser_AST.PatVQuote t -> lidents_of_term t -and (lidents_of_binder : - FStar_Parser_AST.binder -> FStar_Ident.lident Prims.list) = - fun b -> - match b.FStar_Parser_AST.b with - | FStar_Parser_AST.Annotated (uu___, t) -> lidents_of_term t - | FStar_Parser_AST.TAnnotated (uu___, t) -> lidents_of_term t - | FStar_Parser_AST.NoName t -> lidents_of_term t - | uu___ -> [] -let lidents_of_tycon_record : - 'uuuuu 'uuuuu1 'uuuuu2 . - ('uuuuu * 'uuuuu1 * 'uuuuu2 * FStar_Parser_AST.term) -> - FStar_Ident.lident Prims.list - = - fun uu___ -> - match uu___ with | (uu___1, uu___2, uu___3, t) -> lidents_of_term t -let (lidents_of_constructor_payload : - FStar_Parser_AST.constructor_payload -> FStar_Ident.lident Prims.list) = - fun t -> - match t with - | FStar_Parser_AST.VpOfNotation t1 -> lidents_of_term t1 - | FStar_Parser_AST.VpArbitrary t1 -> lidents_of_term t1 - | FStar_Parser_AST.VpRecord (tc, FStar_Pervasives_Native.None) -> - (concat_map ()) lidents_of_tycon_record tc - | FStar_Parser_AST.VpRecord (tc, FStar_Pervasives_Native.Some t1) -> - let uu___ = (concat_map ()) lidents_of_tycon_record tc in - let uu___1 = lidents_of_term t1 in - FStar_Compiler_List.op_At uu___ uu___1 -let (lidents_of_tycon_variant : - (FStar_Ident.ident * FStar_Parser_AST.constructor_payload - FStar_Pervasives_Native.option * FStar_Parser_AST.attributes_) -> - FStar_Ident.lident Prims.list) - = - fun tc -> - match tc with - | (uu___, FStar_Pervasives_Native.None, uu___1) -> [] - | (uu___, FStar_Pervasives_Native.Some t, uu___1) -> - lidents_of_constructor_payload t -let (lidents_of_tycon : - FStar_Parser_AST.tycon -> FStar_Ident.lident Prims.list) = - fun tc -> - match tc with - | FStar_Parser_AST.TyconAbstract (uu___, bs, k) -> - let uu___1 = (concat_map ()) lidents_of_binder bs in - let uu___2 = opt_map lidents_of_term k in - FStar_Compiler_List.op_At uu___1 uu___2 - | FStar_Parser_AST.TyconAbbrev (uu___, bs, k, t) -> - let uu___1 = (concat_map ()) lidents_of_binder bs in - let uu___2 = - let uu___3 = opt_map lidents_of_term k in - let uu___4 = lidents_of_term t in - FStar_Compiler_List.op_At uu___3 uu___4 in - FStar_Compiler_List.op_At uu___1 uu___2 - | FStar_Parser_AST.TyconRecord (uu___, bs, k, uu___1, tcs) -> - let uu___2 = (concat_map ()) lidents_of_binder bs in - let uu___3 = - let uu___4 = opt_map lidents_of_term k in - let uu___5 = (concat_map ()) lidents_of_tycon_record tcs in - FStar_Compiler_List.op_At uu___4 uu___5 in - FStar_Compiler_List.op_At uu___2 uu___3 - | FStar_Parser_AST.TyconVariant (uu___, bs, k, tcs) -> - let uu___1 = (concat_map ()) lidents_of_binder bs in - let uu___2 = - let uu___3 = opt_map lidents_of_term k in - let uu___4 = (concat_map ()) lidents_of_tycon_variant tcs in - FStar_Compiler_List.op_At uu___3 uu___4 in - FStar_Compiler_List.op_At uu___1 uu___2 -let (lidents_of_lift : - FStar_Parser_AST.lift -> FStar_Ident.lident Prims.list) = - fun l -> - let uu___ = - match l.FStar_Parser_AST.lift_op with - | FStar_Parser_AST.NonReifiableLift t -> lidents_of_term t - | FStar_Parser_AST.ReifiableLift (t1, t2) -> - let uu___1 = lidents_of_term t1 in - let uu___2 = lidents_of_term t2 in - FStar_Compiler_List.op_At uu___1 uu___2 - | FStar_Parser_AST.LiftForFree t -> lidents_of_term t in - FStar_Compiler_List.op_At - [l.FStar_Parser_AST.msource; l.FStar_Parser_AST.mdest] uu___ -let rec (lidents_of_decl : - FStar_Parser_AST.decl -> FStar_Ident.lident Prims.list) = - fun d -> - match d.FStar_Parser_AST.d with - | FStar_Parser_AST.TopLevelModule uu___ -> [] - | FStar_Parser_AST.Open (l, uu___) -> [l] - | FStar_Parser_AST.Friend l -> [l] - | FStar_Parser_AST.Include (l, uu___) -> [l] - | FStar_Parser_AST.ModuleAbbrev (uu___, l) -> [l] - | FStar_Parser_AST.TopLevelLet (_q, lbs) -> - (concat_map ()) - (fun uu___ -> - match uu___ with - | (p, t) -> - let uu___1 = lidents_of_pattern p in - let uu___2 = lidents_of_term t in - FStar_Compiler_List.op_At uu___1 uu___2) lbs - | FStar_Parser_AST.Tycon (uu___, uu___1, tcs) -> - (concat_map ()) lidents_of_tycon tcs - | FStar_Parser_AST.Val (uu___, t) -> lidents_of_term t - | FStar_Parser_AST.Exception (uu___, FStar_Pervasives_Native.None) -> [] - | FStar_Parser_AST.Exception (uu___, FStar_Pervasives_Native.Some t) -> - lidents_of_term t - | FStar_Parser_AST.NewEffect ed -> lidents_of_effect_decl ed - | FStar_Parser_AST.LayeredEffect ed -> lidents_of_effect_decl ed - | FStar_Parser_AST.SubEffect lift -> lidents_of_lift lift - | FStar_Parser_AST.Polymonadic_bind (l0, l1, l2, t) -> - let uu___ = - let uu___1 = let uu___2 = lidents_of_term t in l2 :: uu___2 in l1 - :: uu___1 in - l0 :: uu___ - | FStar_Parser_AST.Polymonadic_subcomp (l0, l1, t) -> - let uu___ = let uu___1 = lidents_of_term t in l1 :: uu___1 in l0 :: - uu___ - | FStar_Parser_AST.Pragma uu___ -> [] - | FStar_Parser_AST.Assume (uu___, t) -> lidents_of_term t - | FStar_Parser_AST.Splice (uu___, uu___1, t) -> lidents_of_term t - | FStar_Parser_AST.DeclSyntaxExtension uu___ -> [] - | FStar_Parser_AST.DeclToBeDesugared uu___ -> [] -and (lidents_of_effect_decl : - FStar_Parser_AST.effect_decl -> FStar_Ident.lident Prims.list) = - fun ed -> - match ed with - | FStar_Parser_AST.DefineEffect (uu___, bs, t, ds) -> - let uu___1 = (concat_map ()) lidents_of_binder bs in - let uu___2 = - let uu___3 = lidents_of_term t in - let uu___4 = (concat_map ()) lidents_of_decl ds in - FStar_Compiler_List.op_At uu___3 uu___4 in - FStar_Compiler_List.op_At uu___1 uu___2 - | FStar_Parser_AST.RedefineEffect (uu___, bs, t) -> - let uu___1 = (concat_map ()) lidents_of_binder bs in - let uu___2 = lidents_of_term t in - FStar_Compiler_List.op_At uu___1 uu___2 -type open_namespaces_and_abbreviations = - { - open_namespaces: FStar_Ident.lident Prims.list ; - module_abbreviations: (FStar_Ident.ident * FStar_Ident.lident) Prims.list } -let (__proj__Mkopen_namespaces_and_abbreviations__item__open_namespaces : - open_namespaces_and_abbreviations -> FStar_Ident.lident Prims.list) = - fun projectee -> - match projectee with - | { open_namespaces; module_abbreviations;_} -> open_namespaces -let (__proj__Mkopen_namespaces_and_abbreviations__item__module_abbreviations - : - open_namespaces_and_abbreviations -> - (FStar_Ident.ident * FStar_Ident.lident) Prims.list) - = - fun projectee -> - match projectee with - | { open_namespaces; module_abbreviations;_} -> module_abbreviations -type error_message = - { - message: Prims.string ; - range: FStar_Compiler_Range_Type.range } -let (__proj__Mkerror_message__item__message : error_message -> Prims.string) - = fun projectee -> match projectee with | { message; range;_} -> message -let (__proj__Mkerror_message__item__range : - error_message -> FStar_Compiler_Range_Type.range) = - fun projectee -> match projectee with | { message; range;_} -> range -type extension_parser = - { - parse_decl_name: - Prims.string -> - FStar_Compiler_Range_Type.range -> - (error_message, FStar_Ident.ident) FStar_Pervasives.either - ; - parse_decl: - open_namespaces_and_abbreviations -> - Prims.string -> - FStar_Compiler_Range_Type.range -> - (error_message, FStar_Parser_AST.decl) FStar_Pervasives.either - } -let (__proj__Mkextension_parser__item__parse_decl_name : - extension_parser -> - Prims.string -> - FStar_Compiler_Range_Type.range -> - (error_message, FStar_Ident.ident) FStar_Pervasives.either) - = - fun projectee -> - match projectee with - | { parse_decl_name; parse_decl;_} -> parse_decl_name -let (__proj__Mkextension_parser__item__parse_decl : - extension_parser -> - open_namespaces_and_abbreviations -> - Prims.string -> - FStar_Compiler_Range_Type.range -> - (error_message, FStar_Parser_AST.decl) FStar_Pervasives.either) - = - fun projectee -> - match projectee with | { parse_decl_name; parse_decl;_} -> parse_decl -let (extension_parser_table : extension_parser FStar_Compiler_Util.smap) = - FStar_Compiler_Util.smap_create (Prims.of_int (20)) -let (register_extension_parser : Prims.string -> extension_parser -> unit) = - fun ext -> - fun parser -> - FStar_Compiler_Util.smap_add extension_parser_table ext parser -let (lookup_extension_parser : - Prims.string -> extension_parser FStar_Pervasives_Native.option) = - fun ext -> - let do1 uu___ = - FStar_Compiler_Util.smap_try_find extension_parser_table ext in - let uu___ = do1 () in - match uu___ with - | FStar_Pervasives_Native.None -> - let uu___1 = FStar_Compiler_Plugins.autoload_plugin ext in - if uu___1 then do1 () else FStar_Pervasives_Native.None - | r -> r -type extension_lang_parser = - { - parse_decls: - Prims.string -> - FStar_Compiler_Range_Type.range -> - (error_message, FStar_Parser_AST.decl Prims.list) - FStar_Pervasives.either - } -let (__proj__Mkextension_lang_parser__item__parse_decls : - extension_lang_parser -> - Prims.string -> - FStar_Compiler_Range_Type.range -> - (error_message, FStar_Parser_AST.decl Prims.list) - FStar_Pervasives.either) - = fun projectee -> match projectee with | { parse_decls;_} -> parse_decls -let (as_open_namespaces_and_abbrevs : - FStar_Parser_AST.decl Prims.list -> open_namespaces_and_abbreviations) = - fun ls -> - FStar_Compiler_List.fold_right - (fun d -> - fun out -> - match d.FStar_Parser_AST.d with - | FStar_Parser_AST.Open (lid, uu___) -> - { - open_namespaces = (lid :: (out.open_namespaces)); - module_abbreviations = (out.module_abbreviations) - } - | FStar_Parser_AST.ModuleAbbrev (i, lid) -> - { - open_namespaces = (out.open_namespaces); - module_abbreviations = ((i, lid) :: - (out.module_abbreviations)) - } - | uu___ -> out) ls - { open_namespaces = []; module_abbreviations = [] } -let (extension_lang_parser_table : - extension_lang_parser FStar_Compiler_Util.smap) = - FStar_Compiler_Util.smap_create (Prims.of_int (20)) -let (register_extension_lang_parser : - Prims.string -> extension_lang_parser -> unit) = - fun ext -> - fun parser -> - FStar_Compiler_Util.smap_add extension_lang_parser_table ext parser -let (lookup_extension_lang_parser : - Prims.string -> extension_lang_parser FStar_Pervasives_Native.option) = - fun ext -> - let r = FStar_Compiler_Util.smap_try_find extension_lang_parser_table ext in - match r with - | FStar_Pervasives_Native.None -> - let uu___ = FStar_Compiler_Plugins.autoload_plugin ext in - if uu___ - then - FStar_Compiler_Util.smap_try_find extension_lang_parser_table ext - else FStar_Pervasives_Native.None - | uu___ -> r -let (parse_extension_lang : - Prims.string -> - Prims.string -> - FStar_Compiler_Range_Type.range -> FStar_Parser_AST.decl Prims.list) - = - fun lang_name -> - fun raw_text -> - fun raw_text_pos -> - let extension_parser1 = lookup_extension_lang_parser lang_name in - match extension_parser1 with - | FStar_Pervasives_Native.None -> - let uu___ = - FStar_Compiler_Util.format1 "Unknown language extension %s" - lang_name in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range - raw_text_pos FStar_Errors_Codes.Fatal_SyntaxError () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___) - | FStar_Pervasives_Native.Some parser -> - let uu___ = parser.parse_decls raw_text raw_text_pos in - (match uu___ with - | FStar_Pervasives.Inl error -> - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range - error.range FStar_Errors_Codes.Fatal_SyntaxError () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic error.message) - | FStar_Pervasives.Inr ds -> ds) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Parser_Const.ml b/ocaml/fstar-lib/generated/FStar_Parser_Const.ml deleted file mode 100644 index 0f0f1132217..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Parser_Const.ml +++ /dev/null @@ -1,665 +0,0 @@ -open Prims -let (p2l : FStar_Ident.path -> FStar_Ident.lident) = - fun l -> FStar_Ident.lid_of_path l FStar_Compiler_Range_Type.dummyRange -let (pconst : Prims.string -> FStar_Ident.lident) = fun s -> p2l ["Prims"; s] -let (psconst : Prims.string -> FStar_Ident.lident) = - fun s -> p2l ["FStar"; "Pervasives"; s] -let (psnconst : Prims.string -> FStar_Ident.lident) = - fun s -> p2l ["FStar"; "Pervasives"; "Native"; s] -let (prims_lid : FStar_Ident.lident) = p2l ["Prims"] -let (pervasives_native_lid : FStar_Ident.lident) = - p2l ["FStar"; "Pervasives"; "Native"] -let (pervasives_lid : FStar_Ident.lident) = p2l ["FStar"; "Pervasives"] -let (fstar_ns_lid : FStar_Ident.lident) = p2l ["FStar"] -let (bool_lid : FStar_Ident.lident) = pconst "bool" -let (unit_lid : FStar_Ident.lident) = pconst "unit" -let (squash_lid : FStar_Ident.lident) = pconst "squash" -let (auto_squash_lid : FStar_Ident.lident) = pconst "auto_squash" -let (string_lid : FStar_Ident.lident) = pconst "string" -let (bytes_lid : FStar_Ident.lident) = pconst "bytes" -let (int_lid : FStar_Ident.lident) = pconst "int" -let (exn_lid : FStar_Ident.lident) = pconst "exn" -let (list_lid : FStar_Ident.lident) = pconst "list" -let (immutable_array_t_lid : FStar_Ident.lident) = - p2l ["FStar"; "ImmutableArray"; "Base"; "t"] -let (immutable_array_of_list_lid : FStar_Ident.lident) = - p2l ["FStar"; "ImmutableArray"; "Base"; "of_list"] -let (immutable_array_length_lid : FStar_Ident.lident) = - p2l ["FStar"; "ImmutableArray"; "Base"; "length"] -let (immutable_array_index_lid : FStar_Ident.lident) = - p2l ["FStar"; "ImmutableArray"; "Base"; "index"] -let (eqtype_lid : FStar_Ident.lident) = pconst "eqtype" -let (option_lid : FStar_Ident.lident) = psnconst "option" -let (either_lid : FStar_Ident.lident) = psconst "either" -let (pattern_lid : FStar_Ident.lident) = psconst "pattern" -let (lex_t_lid : FStar_Ident.lident) = pconst "lex_t" -let (precedes_lid : FStar_Ident.lident) = pconst "precedes" -let (smtpat_lid : FStar_Ident.lident) = psconst "smt_pat" -let (smtpatOr_lid : FStar_Ident.lident) = psconst "smt_pat_or" -let (monadic_lid : FStar_Ident.lident) = pconst "M" -let (spinoff_lid : FStar_Ident.lident) = psconst "spinoff" -let (inl_lid : FStar_Ident.lident) = psconst "Inl" -let (inr_lid : FStar_Ident.lident) = psconst "Inr" -let (int8_lid : FStar_Ident.lident) = p2l ["FStar"; "Int8"; "t"] -let (uint8_lid : FStar_Ident.lident) = p2l ["FStar"; "UInt8"; "t"] -let (int16_lid : FStar_Ident.lident) = p2l ["FStar"; "Int16"; "t"] -let (uint16_lid : FStar_Ident.lident) = p2l ["FStar"; "UInt16"; "t"] -let (int32_lid : FStar_Ident.lident) = p2l ["FStar"; "Int32"; "t"] -let (uint32_lid : FStar_Ident.lident) = p2l ["FStar"; "UInt32"; "t"] -let (int64_lid : FStar_Ident.lident) = p2l ["FStar"; "Int64"; "t"] -let (uint64_lid : FStar_Ident.lident) = p2l ["FStar"; "UInt64"; "t"] -let (sizet_lid : FStar_Ident.lident) = p2l ["FStar"; "SizeT"; "t"] -let (salloc_lid : FStar_Ident.lident) = p2l ["FStar"; "ST"; "salloc"] -let (swrite_lid : FStar_Ident.lident) = - p2l ["FStar"; "ST"; "op_Colon_Equals"] -let (sread_lid : FStar_Ident.lident) = p2l ["FStar"; "ST"; "op_Bang"] -let (max_lid : FStar_Ident.lident) = p2l ["max"] -let (real_lid : FStar_Ident.lident) = p2l ["FStar"; "Real"; "real"] -let (float_lid : FStar_Ident.lident) = p2l ["FStar"; "Float"; "float"] -let (char_lid : FStar_Ident.lident) = p2l ["FStar"; "Char"; "char"] -let (heap_lid : FStar_Ident.lident) = p2l ["FStar"; "Heap"; "heap"] -let (logical_lid : FStar_Ident.lident) = pconst "logical" -let (prop_lid : FStar_Ident.lident) = pconst "prop" -let (smt_theory_symbol_attr_lid : FStar_Ident.lident) = - pconst "smt_theory_symbol" -let (true_lid : FStar_Ident.lident) = pconst "l_True" -let (false_lid : FStar_Ident.lident) = pconst "l_False" -let (and_lid : FStar_Ident.lident) = pconst "l_and" -let (or_lid : FStar_Ident.lident) = pconst "l_or" -let (not_lid : FStar_Ident.lident) = pconst "l_not" -let (imp_lid : FStar_Ident.lident) = pconst "l_imp" -let (iff_lid : FStar_Ident.lident) = pconst "l_iff" -let (ite_lid : FStar_Ident.lident) = pconst "l_ITE" -let (exists_lid : FStar_Ident.lident) = pconst "l_Exists" -let (forall_lid : FStar_Ident.lident) = pconst "l_Forall" -let (haseq_lid : FStar_Ident.lident) = pconst "hasEq" -let (b2t_lid : FStar_Ident.lident) = pconst "b2t" -let (admit_lid : FStar_Ident.lident) = pconst "admit" -let (magic_lid : FStar_Ident.lident) = pconst "magic" -let (has_type_lid : FStar_Ident.lident) = pconst "has_type" -let (c_true_lid : FStar_Ident.lident) = pconst "trivial" -let (empty_type_lid : FStar_Ident.lident) = pconst "empty" -let (c_and_lid : FStar_Ident.lident) = pconst "pair" -let (c_or_lid : FStar_Ident.lident) = pconst "sum" -let (dtuple2_lid : FStar_Ident.lident) = pconst "dtuple2" -let (eq2_lid : FStar_Ident.lident) = pconst "eq2" -let (eq3_lid : FStar_Ident.lident) = pconst "op_Equals_Equals_Equals" -let (c_eq2_lid : FStar_Ident.lident) = pconst "equals" -let (cons_lid : FStar_Ident.lident) = pconst "Cons" -let (nil_lid : FStar_Ident.lident) = pconst "Nil" -let (some_lid : FStar_Ident.lident) = psnconst "Some" -let (none_lid : FStar_Ident.lident) = psnconst "None" -let (assume_lid : FStar_Ident.lident) = pconst "_assume" -let (assert_lid : FStar_Ident.lident) = pconst "_assert" -let (pure_wp_lid : FStar_Ident.lident) = pconst "pure_wp" -let (pure_wp_monotonic_lid : FStar_Ident.lident) = pconst "pure_wp_monotonic" -let (pure_wp_monotonic0_lid : FStar_Ident.lident) = - pconst "pure_wp_monotonic0" -let (trivial_pure_post_lid : FStar_Ident.lident) = - psconst "trivial_pure_post" -let (pure_assert_wp_lid : FStar_Ident.lident) = pconst "pure_assert_wp0" -let (pure_assume_wp_lid : FStar_Ident.lident) = pconst "pure_assume_wp0" -let (assert_norm_lid : FStar_Ident.lident) = - p2l ["FStar"; "Pervasives"; "assert_norm"] -let (list_append_lid : FStar_Ident.lident) = p2l ["FStar"; "List"; "append"] -let (list_tot_append_lid : FStar_Ident.lident) = - p2l ["FStar"; "List"; "Tot"; "Base"; "append"] -let (id_lid : FStar_Ident.lident) = psconst "id" -let (seq_cons_lid : FStar_Ident.lident) = - p2l ["FStar"; "Seq"; "Base"; "cons"] -let (seq_empty_lid : FStar_Ident.lident) = - p2l ["FStar"; "Seq"; "Base"; "empty"] -let (c2l : Prims.string -> FStar_Ident.lident) = - fun s -> p2l ["FStar"; "Char"; s] -let (char_u32_of_char : FStar_Ident.lident) = c2l "u32_of_char" -let (s2l : Prims.string -> FStar_Ident.lident) = - fun n -> p2l ["FStar"; "String"; n] -let (string_list_of_string_lid : FStar_Ident.lident) = s2l "list_of_string" -let (string_string_of_list_lid : FStar_Ident.lident) = s2l "string_of_list" -let (string_make_lid : FStar_Ident.lident) = s2l "make" -let (string_split_lid : FStar_Ident.lident) = s2l "split" -let (string_concat_lid : FStar_Ident.lident) = s2l "concat" -let (string_compare_lid : FStar_Ident.lident) = s2l "compare" -let (string_lowercase_lid : FStar_Ident.lident) = s2l "lowercase" -let (string_uppercase_lid : FStar_Ident.lident) = s2l "uppercase" -let (string_index_lid : FStar_Ident.lident) = s2l "index" -let (string_index_of_lid : FStar_Ident.lident) = s2l "index_of" -let (string_sub_lid : FStar_Ident.lident) = s2l "sub" -let (prims_strcat_lid : FStar_Ident.lident) = pconst "strcat" -let (prims_op_Hat_lid : FStar_Ident.lident) = pconst "op_Hat" -let (let_in_typ : FStar_Ident.lident) = p2l ["Prims"; "Let"] -let (string_of_int_lid : FStar_Ident.lident) = p2l ["Prims"; "string_of_int"] -let (string_of_bool_lid : FStar_Ident.lident) = - p2l ["Prims"; "string_of_bool"] -let (int_of_string_lid : FStar_Ident.lident) = - p2l ["FStar"; "Parse"; "int_of_string"] -let (bool_of_string_lid : FStar_Ident.lident) = - p2l ["FStar"; "Parse"; "bool_of_string"] -let (string_compare : FStar_Ident.lident) = - p2l ["FStar"; "String"; "compare"] -let (order_lid : FStar_Ident.lident) = p2l ["FStar"; "Order"; "order"] -let (vconfig_lid : FStar_Ident.lident) = - p2l ["FStar"; "Stubs"; "VConfig"; "vconfig"] -let (mkvconfig_lid : FStar_Ident.lident) = - p2l ["FStar"; "Stubs"; "VConfig"; "Mkvconfig"] -let (op_Eq : FStar_Ident.lident) = pconst "op_Equality" -let (op_notEq : FStar_Ident.lident) = pconst "op_disEquality" -let (op_LT : FStar_Ident.lident) = pconst "op_LessThan" -let (op_LTE : FStar_Ident.lident) = pconst "op_LessThanOrEqual" -let (op_GT : FStar_Ident.lident) = pconst "op_GreaterThan" -let (op_GTE : FStar_Ident.lident) = pconst "op_GreaterThanOrEqual" -let (op_Subtraction : FStar_Ident.lident) = pconst "op_Subtraction" -let (op_Minus : FStar_Ident.lident) = pconst "op_Minus" -let (op_Addition : FStar_Ident.lident) = pconst "op_Addition" -let (op_Multiply : FStar_Ident.lident) = pconst "op_Multiply" -let (op_Division : FStar_Ident.lident) = pconst "op_Division" -let (op_Modulus : FStar_Ident.lident) = pconst "op_Modulus" -let (op_And : FStar_Ident.lident) = pconst "op_AmpAmp" -let (op_Or : FStar_Ident.lident) = pconst "op_BarBar" -let (op_Negation : FStar_Ident.lident) = pconst "op_Negation" -let (subtype_of_lid : FStar_Ident.lident) = pconst "subtype_of" -let (real_const : Prims.string -> FStar_Ident.lident) = - fun s -> p2l ["FStar"; "Real"; s] -let (real_op_LT : FStar_Ident.lident) = real_const "op_Less_Dot" -let (real_op_LTE : FStar_Ident.lident) = real_const "op_Less_Equals_Dot" -let (real_op_GT : FStar_Ident.lident) = real_const "op_Greater_Dot" -let (real_op_GTE : FStar_Ident.lident) = real_const "op_Greater_Equals_Dot" -let (real_op_Subtraction : FStar_Ident.lident) = - real_const "op_Subtraction_Dot" -let (real_op_Addition : FStar_Ident.lident) = real_const "op_Plus_Dot" -let (real_op_Multiply : FStar_Ident.lident) = real_const "op_Star_Dot" -let (real_op_Division : FStar_Ident.lident) = real_const "op_Slash_Dot" -let (real_of_int : FStar_Ident.lident) = real_const "of_int" -let (bvconst : Prims.string -> FStar_Ident.lident) = - fun s -> p2l ["FStar"; "BV"; s] -let (bv_t_lid : FStar_Ident.lident) = bvconst "bv_t" -let (nat_to_bv_lid : FStar_Ident.lident) = bvconst "int2bv" -let (bv_to_nat_lid : FStar_Ident.lident) = bvconst "bv2int" -let (bv_and_lid : FStar_Ident.lident) = bvconst "bvand" -let (bv_xor_lid : FStar_Ident.lident) = bvconst "bvxor" -let (bv_or_lid : FStar_Ident.lident) = bvconst "bvor" -let (bv_add_lid : FStar_Ident.lident) = bvconst "bvadd" -let (bv_sub_lid : FStar_Ident.lident) = bvconst "bvsub" -let (bv_shift_left_lid : FStar_Ident.lident) = bvconst "bvshl" -let (bv_shift_right_lid : FStar_Ident.lident) = bvconst "bvshr" -let (bv_udiv_lid : FStar_Ident.lident) = bvconst "bvdiv" -let (bv_mod_lid : FStar_Ident.lident) = bvconst "bvmod" -let (bv_mul_lid : FStar_Ident.lident) = bvconst "bvmul" -let (bv_shift_left'_lid : FStar_Ident.lident) = bvconst "bvshl'" -let (bv_shift_right'_lid : FStar_Ident.lident) = bvconst "bvshr'" -let (bv_udiv_unsafe_lid : FStar_Ident.lident) = bvconst "bvdiv_unsafe" -let (bv_mod_unsafe_lid : FStar_Ident.lident) = bvconst "bvmod_unsafe" -let (bv_mul'_lid : FStar_Ident.lident) = bvconst "bvmul'" -let (bv_ult_lid : FStar_Ident.lident) = bvconst "bvult" -let (bv_uext_lid : FStar_Ident.lident) = bvconst "bv_uext" -let (array_lid : FStar_Ident.lident) = p2l ["FStar"; "Array"; "array"] -let (array_of_list_lid : FStar_Ident.lident) = - p2l ["FStar"; "Array"; "of_list"] -let (st_lid : FStar_Ident.lident) = p2l ["FStar"; "ST"] -let (write_lid : FStar_Ident.lident) = p2l ["FStar"; "ST"; "write"] -let (read_lid : FStar_Ident.lident) = p2l ["FStar"; "ST"; "read"] -let (alloc_lid : FStar_Ident.lident) = p2l ["FStar"; "ST"; "alloc"] -let (op_ColonEq : FStar_Ident.lident) = - p2l ["FStar"; "ST"; "op_Colon_Equals"] -let (ref_lid : FStar_Ident.lident) = p2l ["FStar"; "Heap"; "ref"] -let (heap_addr_of_lid : FStar_Ident.lident) = - p2l ["FStar"; "Heap"; "addr_of"] -let (set_empty : FStar_Ident.lident) = p2l ["FStar"; "Set"; "empty"] -let (set_singleton : FStar_Ident.lident) = p2l ["FStar"; "Set"; "singleton"] -let (set_union : FStar_Ident.lident) = p2l ["FStar"; "Set"; "union"] -let (fstar_hyperheap_lid : FStar_Ident.lident) = p2l ["FStar"; "HyperHeap"] -let (rref_lid : FStar_Ident.lident) = p2l ["FStar"; "HyperHeap"; "rref"] -let (erased_lid : FStar_Ident.lident) = p2l ["FStar"; "Ghost"; "erased"] -let (effect_PURE_lid : FStar_Ident.lident) = pconst "PURE" -let (effect_Pure_lid : FStar_Ident.lident) = pconst "Pure" -let (effect_Tot_lid : FStar_Ident.lident) = pconst "Tot" -let (effect_Lemma_lid : FStar_Ident.lident) = psconst "Lemma" -let (effect_GTot_lid : FStar_Ident.lident) = pconst "GTot" -let (effect_GHOST_lid : FStar_Ident.lident) = pconst "GHOST" -let (effect_Ghost_lid : FStar_Ident.lident) = pconst "Ghost" -let (effect_DIV_lid : FStar_Ident.lident) = psconst "DIV" -let (effect_Div_lid : FStar_Ident.lident) = psconst "Div" -let (effect_Dv_lid : FStar_Ident.lident) = psconst "Dv" -let (ef_base : unit -> Prims.string Prims.list) = - fun uu___ -> - let uu___1 = FStar_Options.ml_ish () in - if uu___1 - then - let uu___2 = FStar_Options.ml_ish_effect () in - FStar_String.split [46] uu___2 - else ["FStar"; "All"] -let (effect_ALL_lid : unit -> FStar_Ident.lident) = - fun uu___ -> - let uu___1 = - let uu___2 = ef_base () in FStar_Compiler_List.op_At uu___2 ["ALL"] in - p2l uu___1 -let (effect_ML_lid : unit -> FStar_Ident.lident) = - fun uu___ -> - let uu___1 = - let uu___2 = ef_base () in FStar_Compiler_List.op_At uu___2 ["ML"] in - p2l uu___1 -let (failwith_lid : unit -> FStar_Ident.lident) = - fun uu___ -> - let uu___1 = - let uu___2 = ef_base () in - FStar_Compiler_List.op_At uu___2 ["failwith"] in - p2l uu___1 -let (try_with_lid : unit -> FStar_Ident.lident) = - fun uu___ -> - let uu___1 = - let uu___2 = ef_base () in - FStar_Compiler_List.op_At uu___2 ["try_with"] in - p2l uu___1 -let (as_requires : FStar_Ident.lident) = pconst "as_requires" -let (as_ensures : FStar_Ident.lident) = pconst "as_ensures" -let (decreases_lid : FStar_Ident.lident) = pconst "decreases" -let (reveal : FStar_Ident.lident) = p2l ["FStar"; "Ghost"; "reveal"] -let (hide : FStar_Ident.lident) = p2l ["FStar"; "Ghost"; "hide"] -let (labeled_lid : FStar_Ident.lident) = p2l ["FStar"; "Range"; "labeled"] -let (__range_lid : FStar_Ident.lident) = p2l ["FStar"; "Range"; "__range"] -let (range_lid : FStar_Ident.lident) = p2l ["FStar"; "Range"; "range"] -let (range_0 : FStar_Ident.lident) = p2l ["FStar"; "Range"; "range_0"] -let (mk_range_lid : FStar_Ident.lident) = p2l ["FStar"; "Range"; "mk_range"] -let (__mk_range_lid : FStar_Ident.lident) = - p2l ["FStar"; "Range"; "__mk_range"] -let (__explode_range_lid : FStar_Ident.lident) = - p2l ["FStar"; "Range"; "explode"] -let (join_range_lid : FStar_Ident.lident) = - p2l ["FStar"; "Range"; "join_range"] -let (guard_free : FStar_Ident.lident) = pconst "guard_free" -let (inversion_lid : FStar_Ident.lident) = - p2l ["FStar"; "Pervasives"; "inversion"] -let (normalize : FStar_Ident.lident) = psconst "normalize" -let (normalize_term : FStar_Ident.lident) = psconst "normalize_term" -let (norm : FStar_Ident.lident) = psconst "norm" -let (steps_simpl : FStar_Ident.lident) = psconst "simplify" -let (steps_weak : FStar_Ident.lident) = psconst "weak" -let (steps_hnf : FStar_Ident.lident) = psconst "hnf" -let (steps_primops : FStar_Ident.lident) = psconst "primops" -let (steps_zeta : FStar_Ident.lident) = psconst "zeta" -let (steps_zeta_full : FStar_Ident.lident) = psconst "zeta_full" -let (steps_iota : FStar_Ident.lident) = psconst "iota" -let (steps_delta : FStar_Ident.lident) = psconst "delta" -let (steps_reify : FStar_Ident.lident) = psconst "reify_" -let (steps_norm_debug : FStar_Ident.lident) = psconst "norm_debug" -let (steps_unfoldonly : FStar_Ident.lident) = psconst "delta_only" -let (steps_unfoldfully : FStar_Ident.lident) = psconst "delta_fully" -let (steps_unfoldattr : FStar_Ident.lident) = psconst "delta_attr" -let (steps_unfoldqual : FStar_Ident.lident) = psconst "delta_qualifier" -let (steps_unfoldnamespace : FStar_Ident.lident) = psconst "delta_namespace" -let (steps_unascribe : FStar_Ident.lident) = psconst "unascribe" -let (steps_nbe : FStar_Ident.lident) = psconst "nbe" -let (steps_unmeta : FStar_Ident.lident) = psconst "unmeta" -let (deprecated_attr : FStar_Ident.lident) = pconst "deprecated" -let (warn_on_use_attr : FStar_Ident.lident) = pconst "warn_on_use" -let (inline_let_attr : FStar_Ident.lident) = - p2l ["FStar"; "Pervasives"; "inline_let"] -let (rename_let_attr : FStar_Ident.lident) = - p2l ["FStar"; "Pervasives"; "rename_let"] -let (plugin_attr : FStar_Ident.lident) = - p2l ["FStar"; "Pervasives"; "plugin"] -let (tcnorm_attr : FStar_Ident.lident) = - p2l ["FStar"; "Pervasives"; "tcnorm"] -let (dm4f_bind_range_attr : FStar_Ident.lident) = - p2l ["FStar"; "Pervasives"; "dm4f_bind_range"] -let (must_erase_for_extraction_attr : FStar_Ident.lident) = - psconst "must_erase_for_extraction" -let (strict_on_arguments_attr : FStar_Ident.lident) = - p2l ["FStar"; "Pervasives"; "strict_on_arguments"] -let (resolve_implicits_attr_string : Prims.string) = - "FStar.Pervasives.resolve_implicits" -let (unification_tag_lid : FStar_Ident.lident) = psconst "defer_to" -let (override_resolve_implicits_handler_lid : FStar_Ident.lident) = - p2l ["FStar"; "Pervasives"; "override_resolve_implicits_handler"] -let (handle_smt_goals_attr : FStar_Ident.lident) = psconst "handle_smt_goals" -let (handle_smt_goals_attr_string : Prims.string) = - "FStar.Pervasives.handle_smt_goals" -let (erasable_attr : FStar_Ident.lident) = - p2l ["FStar"; "Pervasives"; "erasable"] -let (comment_attr : FStar_Ident.lident) = - p2l ["FStar"; "Pervasives"; "Comment"] -let (c_inline_attr : FStar_Ident.lident) = - p2l ["FStar"; "Pervasives"; "CInline"] -let (fail_attr : FStar_Ident.lident) = psconst "expect_failure" -let (fail_lax_attr : FStar_Ident.lident) = psconst "expect_lax_failure" -let (tcdecltime_attr : FStar_Ident.lident) = psconst "tcdecltime" -let (noextract_to_attr : FStar_Ident.lident) = psconst "noextract_to" -let (unifier_hint_injective_lid : FStar_Ident.lident) = - psconst "unifier_hint_injective" -let (normalize_for_extraction_lid : FStar_Ident.lident) = - psconst "normalize_for_extraction" -let (commute_nested_matches_lid : FStar_Ident.lident) = - psconst "commute_nested_matches" -let (remove_unused_type_parameters_lid : FStar_Ident.lident) = - psconst "remove_unused_type_parameters" -let (ite_soundness_by_attr : FStar_Ident.lident) = psconst "ite_soundness_by" -let (default_effect_attr : FStar_Ident.lident) = psconst "default_effect" -let (top_level_effect_attr : FStar_Ident.lident) = psconst "top_level_effect" -let (effect_parameter_attr : FStar_Ident.lident) = psconst "effect_param" -let (bind_has_range_args_attr : FStar_Ident.lident) = - psconst "bind_has_range_args" -let (primitive_extraction_attr : FStar_Ident.lident) = - psconst "primitive_extraction" -let (binder_strictly_positive_attr : FStar_Ident.lident) = - psconst "strictly_positive" -let (binder_unused_attr : FStar_Ident.lident) = psconst "unused" -let (no_auto_projectors_decls_attr : FStar_Ident.lident) = - psconst "no_auto_projectors_decls" -let (no_auto_projectors_attr : FStar_Ident.lident) = - psconst "no_auto_projectors" -let (no_subtping_attr_lid : FStar_Ident.lident) = psconst "no_subtyping" -let (admit_termination_lid : FStar_Ident.lident) = - psconst "admit_termination" -let (unrefine_binder_attr : FStar_Ident.lident) = pconst "unrefine" -let (do_not_unrefine_attr : FStar_Ident.lident) = pconst "do_not_unrefine" -let (attr_substitute_lid : FStar_Ident.lident) = - p2l ["FStar"; "Pervasives"; "Substitute"] -let (desugar_of_variant_record_lid : FStar_Ident.lident) = - psconst "desugar_of_variant_record" -let (well_founded_relation_lid : FStar_Ident.lident) = - p2l ["FStar"; "WellFounded"; "well_founded_relation"] -let (gen_reset : ((unit -> Prims.int) * (unit -> unit))) = - let x = FStar_Compiler_Util.mk_ref Prims.int_zero in - let gen uu___ = FStar_Compiler_Util.incr x; FStar_Compiler_Util.read x in - let reset uu___ = FStar_Compiler_Util.write x Prims.int_zero in - (gen, reset) -let (next_id : unit -> Prims.int) = FStar_Pervasives_Native.fst gen_reset -let (sli : FStar_Ident.lident -> Prims.string) = - fun l -> - let uu___ = FStar_Options.print_real_names () in - if uu___ - then FStar_Ident.string_of_lid l - else - (let uu___2 = FStar_Ident.ident_of_lid l in - FStar_Ident.string_of_id uu___2) -let (const_to_string : FStar_Const.sconst -> Prims.string) = - fun x -> - match x with - | FStar_Const.Const_effect -> "Effect" - | FStar_Const.Const_unit -> "()" - | FStar_Const.Const_bool b -> if b then "true" else "false" - | FStar_Const.Const_real r -> Prims.strcat r "R" - | FStar_Const.Const_string (s, uu___) -> - FStar_Compiler_Util.format1 "\"%s\"" s - | FStar_Const.Const_int (x1, uu___) -> x1 - | FStar_Const.Const_char c -> - Prims.strcat "'" - (Prims.strcat (FStar_Compiler_Util.string_of_char c) "'") - | FStar_Const.Const_range r -> FStar_Compiler_Range_Ops.string_of_range r - | FStar_Const.Const_range_of -> "range_of" - | FStar_Const.Const_set_range_of -> "set_range_of" - | FStar_Const.Const_reify lopt -> - let uu___ = - match lopt with - | FStar_Pervasives_Native.None -> "" - | FStar_Pervasives_Native.Some l -> - let uu___1 = FStar_Ident.string_of_lid l in - FStar_Compiler_Util.format1 "<%s>" uu___1 in - FStar_Compiler_Util.format1 "reify%s" uu___ - | FStar_Const.Const_reflect l -> - let uu___ = sli l in - FStar_Compiler_Util.format1 "[[%s.reflect]]" uu___ -let (mk_tuple_lid : - Prims.int -> FStar_Compiler_Range_Type.range -> FStar_Ident.lident) = - fun n -> - fun r -> - let t = - let uu___ = FStar_Compiler_Util.string_of_int n in - FStar_Compiler_Util.format1 "tuple%s" uu___ in - let uu___ = psnconst t in FStar_Ident.set_lid_range uu___ r -let (lid_tuple2 : FStar_Ident.lident) = - mk_tuple_lid (Prims.of_int (2)) FStar_Compiler_Range_Type.dummyRange -let (lid_tuple3 : FStar_Ident.lident) = - mk_tuple_lid (Prims.of_int (3)) FStar_Compiler_Range_Type.dummyRange -let (lid_tuple4 : FStar_Ident.lident) = - mk_tuple_lid (Prims.of_int (4)) FStar_Compiler_Range_Type.dummyRange -let (lid_tuple5 : FStar_Ident.lident) = - mk_tuple_lid (Prims.of_int (5)) FStar_Compiler_Range_Type.dummyRange -let (is_tuple_constructor_string : Prims.string -> Prims.bool) = - fun s -> FStar_Compiler_Util.starts_with s "FStar.Pervasives.Native.tuple" -let (is_tuple_constructor_id : FStar_Ident.ident -> Prims.bool) = - fun id -> - let uu___ = FStar_Ident.string_of_id id in - is_tuple_constructor_string uu___ -let (is_tuple_constructor_lid : FStar_Ident.lident -> Prims.bool) = - fun lid -> - let uu___ = FStar_Ident.string_of_lid lid in - is_tuple_constructor_string uu___ -let (mk_tuple_data_lid : - Prims.int -> FStar_Compiler_Range_Type.range -> FStar_Ident.lident) = - fun n -> - fun r -> - let t = - let uu___ = FStar_Compiler_Util.string_of_int n in - FStar_Compiler_Util.format1 "Mktuple%s" uu___ in - let uu___ = psnconst t in FStar_Ident.set_lid_range uu___ r -let (lid_Mktuple2 : FStar_Ident.lident) = - mk_tuple_data_lid (Prims.of_int (2)) FStar_Compiler_Range_Type.dummyRange -let (lid_Mktuple3 : FStar_Ident.lident) = - mk_tuple_data_lid (Prims.of_int (3)) FStar_Compiler_Range_Type.dummyRange -let (lid_Mktuple4 : FStar_Ident.lident) = - mk_tuple_data_lid (Prims.of_int (4)) FStar_Compiler_Range_Type.dummyRange -let (lid_Mktuple5 : FStar_Ident.lident) = - mk_tuple_data_lid (Prims.of_int (5)) FStar_Compiler_Range_Type.dummyRange -let (is_tuple_datacon_string : Prims.string -> Prims.bool) = - fun s -> - FStar_Compiler_Util.starts_with s "FStar.Pervasives.Native.Mktuple" -let (is_tuple_datacon_id : FStar_Ident.ident -> Prims.bool) = - fun id -> - let uu___ = FStar_Ident.string_of_id id in is_tuple_datacon_string uu___ -let (is_tuple_datacon_lid : FStar_Ident.lident -> Prims.bool) = - fun lid -> - let uu___ = FStar_Ident.string_of_lid lid in - is_tuple_datacon_string uu___ -let (is_tuple_data_lid : FStar_Ident.lident -> Prims.int -> Prims.bool) = - fun f -> - fun n -> - let uu___ = mk_tuple_data_lid n FStar_Compiler_Range_Type.dummyRange in - FStar_Ident.lid_equals f uu___ -let (is_tuple_data_lid' : FStar_Ident.lident -> Prims.bool) = - fun f -> - let uu___ = FStar_Ident.string_of_lid f in is_tuple_datacon_string uu___ -let (mod_prefix_dtuple : Prims.int -> Prims.string -> FStar_Ident.lident) = - fun n -> if n = (Prims.of_int (2)) then pconst else psconst -let (mk_dtuple_lid : - Prims.int -> FStar_Compiler_Range_Type.range -> FStar_Ident.lident) = - fun n -> - fun r -> - let t = - let uu___ = FStar_Compiler_Util.string_of_int n in - FStar_Compiler_Util.format1 "dtuple%s" uu___ in - let uu___ = let uu___1 = mod_prefix_dtuple n in uu___1 t in - FStar_Ident.set_lid_range uu___ r -let (is_dtuple_constructor_string : Prims.string -> Prims.bool) = - fun s -> - (s = "Prims.dtuple2") || - (FStar_Compiler_Util.starts_with s "FStar.Pervasives.dtuple") -let (is_dtuple_constructor_lid : FStar_Ident.lident -> Prims.bool) = - fun lid -> - let uu___ = FStar_Ident.string_of_lid lid in - is_dtuple_constructor_string uu___ -let (mk_dtuple_data_lid : - Prims.int -> FStar_Compiler_Range_Type.range -> FStar_Ident.lident) = - fun n -> - fun r -> - let t = - let uu___ = FStar_Compiler_Util.string_of_int n in - FStar_Compiler_Util.format1 "Mkdtuple%s" uu___ in - let uu___ = let uu___1 = mod_prefix_dtuple n in uu___1 t in - FStar_Ident.set_lid_range uu___ r -let (is_dtuple_datacon_string : Prims.string -> Prims.bool) = - fun s -> - (s = "Prims.Mkdtuple2") || - (FStar_Compiler_Util.starts_with s "FStar.Pervasives.Mkdtuple") -let (is_dtuple_data_lid : FStar_Ident.lident -> Prims.int -> Prims.bool) = - fun f -> - fun n -> - let uu___ = mk_dtuple_data_lid n FStar_Compiler_Range_Type.dummyRange in - FStar_Ident.lid_equals f uu___ -let (is_dtuple_data_lid' : FStar_Ident.lident -> Prims.bool) = - fun f -> - let uu___ = FStar_Ident.string_of_lid f in is_dtuple_datacon_string uu___ -let (is_name : FStar_Ident.lident -> Prims.bool) = - fun lid -> - let c = - let uu___ = - let uu___1 = FStar_Ident.ident_of_lid lid in - FStar_Ident.string_of_id uu___1 in - FStar_Compiler_Util.char_at uu___ Prims.int_zero in - FStar_Compiler_Util.is_upper c -let (term_view_lid : FStar_Ident.lident) = - p2l ["FStar"; "Reflection"; "V1"; "Data"; "term_view"] -let (fstar_tactics_lid' : Prims.string Prims.list -> FStar_Ident.lid) = - fun s -> - FStar_Ident.lid_of_path - (FStar_Compiler_List.op_At ["FStar"; "Tactics"] s) - FStar_Compiler_Range_Type.dummyRange -let (fstar_stubs_tactics_lid' : Prims.string Prims.list -> FStar_Ident.lid) = - fun s -> - FStar_Ident.lid_of_path - (FStar_Compiler_List.op_At ["FStar"; "Stubs"; "Tactics"] s) - FStar_Compiler_Range_Type.dummyRange -let (fstar_tactics_lid : Prims.string -> FStar_Ident.lid) = - fun s -> fstar_tactics_lid' [s] -let (tac_lid : FStar_Ident.lid) = fstar_tactics_lid' ["Effect"; "tac"] -let (tactic_lid : FStar_Ident.lid) = fstar_tactics_lid' ["Effect"; "tactic"] -let (tac_opaque_attr : FStar_Ident.lident) = pconst "tac_opaque" -let (meta_projectors_attr : FStar_Ident.lid) = - fstar_tactics_lid' ["MkProjectors"; "meta_projectors"] -let (mk_projs_lid : FStar_Ident.lid) = - fstar_tactics_lid' ["MkProjectors"; "mk_projs"] -let (mk_class_lid : FStar_Ident.lid) = - fstar_tactics_lid' ["Typeclasses"; "mk_class"] -let (tcresolve_lid : FStar_Ident.lid) = - fstar_tactics_lid' ["Typeclasses"; "tcresolve"] -let (tcclass_lid : FStar_Ident.lid) = - fstar_tactics_lid' ["Typeclasses"; "tcclass"] -let (tcinstance_lid : FStar_Ident.lid) = - fstar_tactics_lid' ["Typeclasses"; "tcinstance"] -let (no_method_lid : FStar_Ident.lid) = - fstar_tactics_lid' ["Typeclasses"; "no_method"] -let (effect_TAC_lid : FStar_Ident.lid) = fstar_tactics_lid' ["Effect"; "TAC"] -let (effect_Tac_lid : FStar_Ident.lid) = fstar_tactics_lid' ["Effect"; "Tac"] -let (by_tactic_lid : FStar_Ident.lid) = - fstar_tactics_lid' ["Effect"; "with_tactic"] -let (rewrite_by_tactic_lid : FStar_Ident.lid) = - fstar_tactics_lid' ["Effect"; "rewrite_with_tactic"] -let (synth_lid : FStar_Ident.lid) = - fstar_tactics_lid' ["Effect"; "synth_by_tactic"] -let (assert_by_tactic_lid : FStar_Ident.lid) = - fstar_tactics_lid' ["Effect"; "assert_by_tactic"] -let (fstar_syntax_syntax_term : FStar_Ident.lident) = - FStar_Ident.lid_of_str "FStar.Syntax.Syntax.term" -let (binder_lid : FStar_Ident.lident) = - FStar_Ident.lid_of_path ["FStar"; "Stubs"; "Reflection"; "Types"; "binder"] - FStar_Compiler_Range_Type.dummyRange -let (binders_lid : FStar_Ident.lident) = - FStar_Ident.lid_of_path - ["FStar"; "Stubs"; "Reflection"; "Types"; "binders"] - FStar_Compiler_Range_Type.dummyRange -let (bv_lid : FStar_Ident.lident) = - FStar_Ident.lid_of_path ["FStar"; "Stubs"; "Reflection"; "Types"; "bv"] - FStar_Compiler_Range_Type.dummyRange -let (fv_lid : FStar_Ident.lident) = - FStar_Ident.lid_of_path ["FStar"; "Stubs"; "Reflection"; "Types"; "fv"] - FStar_Compiler_Range_Type.dummyRange -let (norm_step_lid : FStar_Ident.lident) = psconst "norm_step" -let (postprocess_with : FStar_Ident.lident) = - p2l ["FStar"; "Tactics"; "Effect"; "postprocess_with"] -let (preprocess_with : FStar_Ident.lident) = - p2l ["FStar"; "Tactics"; "Effect"; "preprocess_with"] -let (postprocess_extr_with : FStar_Ident.lident) = - p2l ["FStar"; "Tactics"; "Effect"; "postprocess_for_extraction_with"] -let (term_lid : FStar_Ident.lident) = - p2l ["FStar"; "Stubs"; "Reflection"; "Types"; "term"] -let (ctx_uvar_and_subst_lid : FStar_Ident.lident) = - p2l ["FStar"; "Stubs"; "Reflection"; "Types"; "ctx_uvar_and_subst"] -let (universe_uvar_lid : FStar_Ident.lident) = - p2l ["FStar"; "Stubs"; "Reflection"; "Types"; "universe_uvar"] -let (check_with_lid : FStar_Ident.lident) = - FStar_Ident.lid_of_path ["FStar"; "Stubs"; "VConfig"; "check_with"] - FStar_Compiler_Range_Type.dummyRange -let (decls_lid : FStar_Ident.lident) = - p2l ["FStar"; "Stubs"; "Reflection"; "Types"; "decls"] -let (dsl_typing_builtin : Prims.string -> FStar_Ident.lident) = - fun s -> - FStar_Ident.lid_of_path - (FStar_Compiler_List.op_At - ["FStar"; "Reflection"; "Typing"; "Builtins"] [s]) - FStar_Compiler_Range_Type.dummyRange -let (dsl_tac_typ_lid : FStar_Ident.lident) = - FStar_Ident.lid_of_path ["FStar"; "Reflection"; "Typing"; "dsl_tac_t"] - FStar_Compiler_Range_Type.dummyRange -let (calc_lid : Prims.string -> FStar_Ident.lid) = - fun i -> - FStar_Ident.lid_of_path ["FStar"; "Calc"; i] - FStar_Compiler_Range_Type.dummyRange -let (calc_init_lid : FStar_Ident.lid) = calc_lid "calc_init" -let (calc_step_lid : FStar_Ident.lid) = calc_lid "calc_step" -let (calc_finish_lid : FStar_Ident.lid) = calc_lid "calc_finish" -let (calc_push_impl_lid : FStar_Ident.lid) = calc_lid "calc_push_impl" -let (classical_sugar_lid : Prims.string -> FStar_Ident.lid) = - fun i -> - FStar_Ident.lid_of_path ["FStar"; "Classical"; "Sugar"; i] - FStar_Compiler_Range_Type.dummyRange -let (forall_intro_lid : FStar_Ident.lid) = classical_sugar_lid "forall_intro" -let (exists_intro_lid : FStar_Ident.lid) = classical_sugar_lid "exists_intro" -let (implies_intro_lid : FStar_Ident.lid) = - classical_sugar_lid "implies_intro" -let (or_intro_left_lid : FStar_Ident.lid) = - classical_sugar_lid "or_intro_left" -let (or_intro_right_lid : FStar_Ident.lid) = - classical_sugar_lid "or_intro_right" -let (and_intro_lid : FStar_Ident.lid) = classical_sugar_lid "and_intro" -let (forall_elim_lid : FStar_Ident.lid) = classical_sugar_lid "forall_elim" -let (exists_elim_lid : FStar_Ident.lid) = classical_sugar_lid "exists_elim" -let (implies_elim_lid : FStar_Ident.lid) = classical_sugar_lid "implies_elim" -let (or_elim_lid : FStar_Ident.lid) = classical_sugar_lid "or_elim" -let (and_elim_lid : FStar_Ident.lid) = classical_sugar_lid "and_elim" -let (match_returns_def_name : Prims.string) = - Prims.strcat FStar_Ident.reserved_prefix "_ret_" -let (steel_memory_inv_lid : FStar_Ident.lident) = - FStar_Ident.lid_of_path ["Steel"; "Memory"; "inv"] - FStar_Compiler_Range_Type.dummyRange -let (steel_new_invariant_lid : FStar_Ident.lident) = - FStar_Ident.lid_of_path ["Steel"; "Effect"; "Atomic"; "new_invariant"] - FStar_Compiler_Range_Type.dummyRange -let (steel_st_new_invariant_lid : FStar_Ident.lident) = - FStar_Ident.lid_of_path ["Steel"; "ST"; "Util"; "new_invariant"] - FStar_Compiler_Range_Type.dummyRange -let (steel_with_invariant_g_lid : FStar_Ident.lident) = - FStar_Ident.lid_of_path ["Steel"; "Effect"; "Atomic"; "with_invariant_g"] - FStar_Compiler_Range_Type.dummyRange -let (steel_st_with_invariant_g_lid : FStar_Ident.lident) = - FStar_Ident.lid_of_path ["Steel"; "ST"; "Util"; "with_invariant_g"] - FStar_Compiler_Range_Type.dummyRange -let (steel_with_invariant_lid : FStar_Ident.lident) = - FStar_Ident.lid_of_path ["Steel"; "Effect"; "Atomic"; "with_invariant"] - FStar_Compiler_Range_Type.dummyRange -let (steel_st_with_invariant_lid : FStar_Ident.lident) = - FStar_Ident.lid_of_path ["Steel"; "ST"; "Util"; "with_invariant"] - FStar_Compiler_Range_Type.dummyRange -let (fext_lid : Prims.string -> FStar_Ident.lident) = - fun s -> - FStar_Ident.lid_of_path ["FStar"; "FunctionalExtensionality"; s] - FStar_Compiler_Range_Type.dummyRange -let (fext_on_domain_lid : FStar_Ident.lident) = fext_lid "on_domain" -let (fext_on_dom_lid : FStar_Ident.lident) = fext_lid "on_dom" -let (fext_on_domain_g_lid : FStar_Ident.lident) = fext_lid "on_domain_g" -let (fext_on_dom_g_lid : FStar_Ident.lident) = fext_lid "on_dom_g" -let (sealed_lid : FStar_Ident.lident) = p2l ["FStar"; "Sealed"; "sealed"] -let (seal_lid : FStar_Ident.lident) = p2l ["FStar"; "Sealed"; "seal"] -let (unseal_lid : FStar_Ident.lident) = - p2l ["FStar"; "Tactics"; "Unseal"; "unseal"] -let (map_seal_lid : FStar_Ident.lident) = p2l ["FStar"; "Sealed"; "map_seal"] -let (bind_seal_lid : FStar_Ident.lident) = - p2l ["FStar"; "Sealed"; "bind_seal"] -let (tref_lid : FStar_Ident.lident) = - p2l ["FStar"; "Stubs"; "Tactics"; "Types"; "tref"] -let (document_lid : FStar_Ident.lident) = - p2l ["FStar"; "Stubs"; "Pprint"; "document"] -let (issue_lid : FStar_Ident.lident) = p2l ["FStar"; "Issue"; "issue"] -let (extract_as_lid : FStar_Ident.lident) = - p2l ["FStar"; "ExtractAs"; "extract_as"] -let (extract_as_impure_effect_lid : FStar_Ident.lident) = - p2l ["FStar"; "Pervasives"; "extract_as_impure_effect"] \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Parser_Dep.ml b/ocaml/fstar-lib/generated/FStar_Parser_Dep.ml deleted file mode 100644 index 7ced193f075..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Parser_Dep.ml +++ /dev/null @@ -1,2993 +0,0 @@ -open Prims -type open_kind = - | Open_module - | Open_namespace -let (uu___is_Open_module : open_kind -> Prims.bool) = - fun projectee -> - match projectee with | Open_module -> true | uu___ -> false -let (uu___is_Open_namespace : open_kind -> Prims.bool) = - fun projectee -> - match projectee with | Open_namespace -> true | uu___ -> false -type module_name = Prims.string -let (dbg : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Dep" -let (dbg_CheckedFiles : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "CheckedFiles" -let profile : 'uuuuu . (unit -> 'uuuuu) -> Prims.string -> 'uuuuu = - fun f -> fun c -> FStar_Profiling.profile f FStar_Pervasives_Native.None c -let with_file_outchannel : - 'a . Prims.string -> (FStar_Compiler_Util.out_channel -> 'a) -> 'a = - fun fn -> - fun k -> - let outc = FStar_Compiler_Util.open_file_for_writing fn in - let r = - try (fun uu___ -> match () with | () -> k outc) () - with - | uu___ -> - (FStar_Compiler_Util.close_out_channel outc; - FStar_Compiler_Util.delete_file fn; - FStar_Compiler_Effect.raise uu___) in - FStar_Compiler_Util.close_out_channel outc; r -type verify_mode = - | VerifyAll - | VerifyUserList - | VerifyFigureItOut -let (uu___is_VerifyAll : verify_mode -> Prims.bool) = - fun projectee -> match projectee with | VerifyAll -> true | uu___ -> false -let (uu___is_VerifyUserList : verify_mode -> Prims.bool) = - fun projectee -> - match projectee with | VerifyUserList -> true | uu___ -> false -let (uu___is_VerifyFigureItOut : verify_mode -> Prims.bool) = - fun projectee -> - match projectee with | VerifyFigureItOut -> true | uu___ -> false -type intf_and_impl = - (Prims.string FStar_Pervasives_Native.option * Prims.string - FStar_Pervasives_Native.option) -type files_for_module_name = intf_and_impl FStar_Compiler_Util.smap -let (intf_and_impl_to_string : - (Prims.string FStar_Pervasives_Native.option * Prims.string - FStar_Pervasives_Native.option) -> Prims.string) - = - fun ii -> - match ii with - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> - ", " - | (FStar_Pervasives_Native.Some intf, FStar_Pervasives_Native.None) -> - intf - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.Some impl) -> - impl - | (FStar_Pervasives_Native.Some intf, FStar_Pervasives_Native.Some impl) - -> Prims.strcat intf (Prims.strcat ", " impl) -let (files_for_module_name_to_string : files_for_module_name -> unit) = - fun m -> - FStar_Compiler_Util.print_string "Printing the file system map {\n"; - (let str_opt_to_string sopt = - match sopt with - | FStar_Pervasives_Native.None -> "" - | FStar_Pervasives_Native.Some s -> s in - FStar_Compiler_Util.smap_iter m - (fun k -> - fun v -> - FStar_Compiler_Util.print2 "%s:%s\n" k - (intf_and_impl_to_string v)); - FStar_Compiler_Util.print_string "}\n") -type color = - | White - | Gray - | Black -let (uu___is_White : color -> Prims.bool) = - fun projectee -> match projectee with | White -> true | uu___ -> false -let (uu___is_Gray : color -> Prims.bool) = - fun projectee -> match projectee with | Gray -> true | uu___ -> false -let (uu___is_Black : color -> Prims.bool) = - fun projectee -> match projectee with | Black -> true | uu___ -> false -let (check_and_strip_suffix : - Prims.string -> Prims.string FStar_Pervasives_Native.option) = - fun f -> - let suffixes = [".fsti"; ".fst"; ".fsi"; ".fs"] in - let matches = - FStar_Compiler_List.map - (fun ext -> - let lext = FStar_Compiler_String.length ext in - let l = FStar_Compiler_String.length f in - let uu___ = - (l > lext) && - (let uu___1 = - FStar_Compiler_String.substring f (l - lext) lext in - uu___1 = ext) in - if uu___ - then - let uu___1 = - FStar_Compiler_String.substring f Prims.int_zero (l - lext) in - FStar_Pervasives_Native.Some uu___1 - else FStar_Pervasives_Native.None) suffixes in - let uu___ = - FStar_Compiler_List.filter FStar_Compiler_Util.is_some matches in - match uu___ with - | (FStar_Pervasives_Native.Some m)::uu___1 -> - FStar_Pervasives_Native.Some m - | uu___1 -> FStar_Pervasives_Native.None -let (is_interface : Prims.string -> Prims.bool) = - fun f -> - let uu___ = - FStar_Compiler_String.get f - ((FStar_Compiler_String.length f) - Prims.int_one) in - uu___ = 105 -let (is_implementation : Prims.string -> Prims.bool) = - fun f -> let uu___ = is_interface f in Prims.op_Negation uu___ -let list_of_option : - 'uuuuu . 'uuuuu FStar_Pervasives_Native.option -> 'uuuuu Prims.list = - fun uu___ -> - match uu___ with - | FStar_Pervasives_Native.Some x -> [x] - | FStar_Pervasives_Native.None -> [] -let list_of_pair : - 'uuuuu . - ('uuuuu FStar_Pervasives_Native.option * 'uuuuu - FStar_Pervasives_Native.option) -> 'uuuuu Prims.list - = - fun uu___ -> - match uu___ with - | (intf, impl) -> - FStar_Compiler_List.op_At (list_of_option intf) (list_of_option impl) -let (maybe_module_name_of_file : - Prims.string -> Prims.string FStar_Pervasives_Native.option) = - fun f -> - let uu___ = FStar_Compiler_Util.basename f in - check_and_strip_suffix uu___ -let (module_name_of_file : Prims.string -> Prims.string) = - fun f -> - let uu___ = maybe_module_name_of_file f in - match uu___ with - | FStar_Pervasives_Native.Some longname -> longname - | FStar_Pervasives_Native.None -> - let uu___1 = - FStar_Compiler_Util.format1 "Not a valid FStar file: '%s'" f in - FStar_Errors.raise_error0 FStar_Errors_Codes.Fatal_NotValidFStarFile - () (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) -let (lowercase_module_name : Prims.string -> Prims.string) = - fun f -> - let uu___ = module_name_of_file f in - FStar_Compiler_String.lowercase uu___ -let (namespace_of_module : - Prims.string -> FStar_Ident.lident FStar_Pervasives_Native.option) = - fun f -> - let lid = - let uu___ = FStar_Ident.path_of_text f in - FStar_Ident.lid_of_path uu___ FStar_Compiler_Range_Type.dummyRange in - let uu___ = FStar_Ident.ns_of_lid lid in - match uu___ with - | [] -> FStar_Pervasives_Native.None - | ns -> - let uu___1 = FStar_Ident.lid_of_ids ns in - FStar_Pervasives_Native.Some uu___1 -type file_name = Prims.string -type dependence = - | UseInterface of module_name - | PreferInterface of module_name - | UseImplementation of module_name - | FriendImplementation of module_name -let (uu___is_UseInterface : dependence -> Prims.bool) = - fun projectee -> - match projectee with | UseInterface _0 -> true | uu___ -> false -let (__proj__UseInterface__item___0 : dependence -> module_name) = - fun projectee -> match projectee with | UseInterface _0 -> _0 -let (uu___is_PreferInterface : dependence -> Prims.bool) = - fun projectee -> - match projectee with | PreferInterface _0 -> true | uu___ -> false -let (__proj__PreferInterface__item___0 : dependence -> module_name) = - fun projectee -> match projectee with | PreferInterface _0 -> _0 -let (uu___is_UseImplementation : dependence -> Prims.bool) = - fun projectee -> - match projectee with | UseImplementation _0 -> true | uu___ -> false -let (__proj__UseImplementation__item___0 : dependence -> module_name) = - fun projectee -> match projectee with | UseImplementation _0 -> _0 -let (uu___is_FriendImplementation : dependence -> Prims.bool) = - fun projectee -> - match projectee with | FriendImplementation _0 -> true | uu___ -> false -let (__proj__FriendImplementation__item___0 : dependence -> module_name) = - fun projectee -> match projectee with | FriendImplementation _0 -> _0 -let (dep_to_string : dependence -> Prims.string) = - fun uu___ -> - match uu___ with - | UseInterface f -> Prims.strcat "UseInterface " f - | PreferInterface f -> Prims.strcat "PreferInterface " f - | UseImplementation f -> Prims.strcat "UseImplementation " f - | FriendImplementation f -> Prims.strcat "FriendImplementation " f -let (showable_dependence : dependence FStar_Class_Show.showable) = - { FStar_Class_Show.show = dep_to_string } -type dependences = dependence Prims.list -let empty_dependences : 'uuuuu . unit -> 'uuuuu Prims.list = fun uu___ -> [] -type dep_node = { - edges: dependences ; - color: color } -let (__proj__Mkdep_node__item__edges : dep_node -> dependences) = - fun projectee -> match projectee with | { edges; color = color1;_} -> edges -let (__proj__Mkdep_node__item__color : dep_node -> color) = - fun projectee -> - match projectee with | { edges; color = color1;_} -> color1 -type dependence_graph = - | Deps of dep_node FStar_Compiler_Util.smap -let (uu___is_Deps : dependence_graph -> Prims.bool) = fun projectee -> true -let (__proj__Deps__item___0 : - dependence_graph -> dep_node FStar_Compiler_Util.smap) = - fun projectee -> match projectee with | Deps _0 -> _0 -type parsing_data_elt = - | P_begin_module of FStar_Ident.lident - | P_open of (Prims.bool * FStar_Ident.lident) - | P_implicit_open_module_or_namespace of (open_kind * FStar_Ident.lid) - | P_dep of (Prims.bool * FStar_Ident.lident) - | P_alias of (FStar_Ident.ident * FStar_Ident.lident) - | P_lid of FStar_Ident.lident - | P_inline_for_extraction -let (uu___is_P_begin_module : parsing_data_elt -> Prims.bool) = - fun projectee -> - match projectee with | P_begin_module _0 -> true | uu___ -> false -let (__proj__P_begin_module__item___0 : - parsing_data_elt -> FStar_Ident.lident) = - fun projectee -> match projectee with | P_begin_module _0 -> _0 -let (uu___is_P_open : parsing_data_elt -> Prims.bool) = - fun projectee -> match projectee with | P_open _0 -> true | uu___ -> false -let (__proj__P_open__item___0 : - parsing_data_elt -> (Prims.bool * FStar_Ident.lident)) = - fun projectee -> match projectee with | P_open _0 -> _0 -let (uu___is_P_implicit_open_module_or_namespace : - parsing_data_elt -> Prims.bool) = - fun projectee -> - match projectee with - | P_implicit_open_module_or_namespace _0 -> true - | uu___ -> false -let (__proj__P_implicit_open_module_or_namespace__item___0 : - parsing_data_elt -> (open_kind * FStar_Ident.lid)) = - fun projectee -> - match projectee with | P_implicit_open_module_or_namespace _0 -> _0 -let (uu___is_P_dep : parsing_data_elt -> Prims.bool) = - fun projectee -> match projectee with | P_dep _0 -> true | uu___ -> false -let (__proj__P_dep__item___0 : - parsing_data_elt -> (Prims.bool * FStar_Ident.lident)) = - fun projectee -> match projectee with | P_dep _0 -> _0 -let (uu___is_P_alias : parsing_data_elt -> Prims.bool) = - fun projectee -> match projectee with | P_alias _0 -> true | uu___ -> false -let (__proj__P_alias__item___0 : - parsing_data_elt -> (FStar_Ident.ident * FStar_Ident.lident)) = - fun projectee -> match projectee with | P_alias _0 -> _0 -let (uu___is_P_lid : parsing_data_elt -> Prims.bool) = - fun projectee -> match projectee with | P_lid _0 -> true | uu___ -> false -let (__proj__P_lid__item___0 : parsing_data_elt -> FStar_Ident.lident) = - fun projectee -> match projectee with | P_lid _0 -> _0 -let (uu___is_P_inline_for_extraction : parsing_data_elt -> Prims.bool) = - fun projectee -> - match projectee with | P_inline_for_extraction -> true | uu___ -> false -type parsing_data = - | Mk_pd of parsing_data_elt Prims.list -let (uu___is_Mk_pd : parsing_data -> Prims.bool) = fun projectee -> true -let (__proj__Mk_pd__item___0 : parsing_data -> parsing_data_elt Prims.list) = - fun projectee -> match projectee with | Mk_pd _0 -> _0 -let (str_of_parsing_data_elt : parsing_data_elt -> Prims.string) = - fun elt -> - let str_of_open_kind uu___ = - match uu___ with - | Open_module -> "P_open_module" - | Open_namespace -> "P_open_namespace" in - match elt with - | P_begin_module lid -> - let uu___ = - let uu___1 = FStar_Ident.string_of_lid lid in - Prims.strcat uu___1 ")" in - Prims.strcat "P_begin_module (" uu___ - | P_open (b, lid) -> - let uu___ = - let uu___1 = FStar_Compiler_Util.string_of_bool b in - let uu___2 = - let uu___3 = - let uu___4 = FStar_Ident.string_of_lid lid in - Prims.strcat uu___4 ")" in - Prims.strcat ", " uu___3 in - Prims.strcat uu___1 uu___2 in - Prims.strcat "P_open (" uu___ - | P_implicit_open_module_or_namespace (k, lid) -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Ident.string_of_lid lid in - Prims.strcat uu___3 ")" in - Prims.strcat ", " uu___2 in - Prims.strcat (str_of_open_kind k) uu___1 in - Prims.strcat "P_implicit_open_module_or_namespace (" uu___ - | P_dep (b, lid) -> - let uu___ = - let uu___1 = FStar_Ident.string_of_lid lid in - let uu___2 = - let uu___3 = - let uu___4 = FStar_Compiler_Util.string_of_bool b in - Prims.strcat uu___4 ")" in - Prims.strcat ", " uu___3 in - Prims.strcat uu___1 uu___2 in - Prims.strcat "P_dep (" uu___ - | P_alias (id, lid) -> - let uu___ = - let uu___1 = FStar_Ident.string_of_id id in - let uu___2 = - let uu___3 = - let uu___4 = FStar_Ident.string_of_lid lid in - Prims.strcat uu___4 ")" in - Prims.strcat ", " uu___3 in - Prims.strcat uu___1 uu___2 in - Prims.strcat "P_alias (" uu___ - | P_lid lid -> - let uu___ = - let uu___1 = FStar_Ident.string_of_lid lid in - Prims.strcat uu___1 ")" in - Prims.strcat "P_lid (" uu___ - | P_inline_for_extraction -> "P_inline_for_extraction" -let (str_of_parsing_data : parsing_data -> Prims.string) = - fun uu___ -> - match uu___ with - | Mk_pd l -> - FStar_Compiler_List.fold_left - (fun s -> - fun elt -> - let uu___1 = - let uu___2 = str_of_parsing_data_elt elt in - Prims.strcat "; " uu___2 in - Prims.strcat s uu___1) "" l -let (friends : parsing_data -> FStar_Ident.lident Prims.list) = - fun p -> - let uu___ = p in - match uu___ with - | Mk_pd p1 -> - FStar_Compiler_List.collect - (fun uu___1 -> - match uu___1 with | P_dep (true, l) -> [l] | uu___2 -> []) p1 -let (parsing_data_elt_eq : - parsing_data_elt -> parsing_data_elt -> Prims.bool) = - fun e1 -> - fun e2 -> - match (e1, e2) with - | (P_begin_module l1, P_begin_module l2) -> - FStar_Ident.lid_equals l1 l2 - | (P_open (b1, l1), P_open (b2, l2)) -> - (b1 = b2) && (FStar_Ident.lid_equals l1 l2) - | (P_implicit_open_module_or_namespace (k1, l1), - P_implicit_open_module_or_namespace (k2, l2)) -> - (k1 = k2) && (FStar_Ident.lid_equals l1 l2) - | (P_dep (b1, l1), P_dep (b2, l2)) -> - (b1 = b2) && (FStar_Ident.lid_equals l1 l2) - | (P_alias (i1, l1), P_alias (i2, l2)) -> - (let uu___ = FStar_Ident.string_of_id i1 in - let uu___1 = FStar_Ident.string_of_id i2 in uu___ = uu___1) && - (FStar_Ident.lid_equals l1 l2) - | (P_lid l1, P_lid l2) -> FStar_Ident.lid_equals l1 l2 - | (P_inline_for_extraction, P_inline_for_extraction) -> true - | (uu___, uu___1) -> false -let (empty_parsing_data : parsing_data) = Mk_pd [] -type deps = - { - dep_graph: dependence_graph ; - file_system_map: files_for_module_name ; - cmd_line_files: file_name Prims.list ; - all_files: file_name Prims.list ; - interfaces_with_inlining: module_name Prims.list ; - parse_results: parsing_data FStar_Compiler_Util.smap } -let (__proj__Mkdeps__item__dep_graph : deps -> dependence_graph) = - fun projectee -> - match projectee with - | { dep_graph; file_system_map; cmd_line_files; all_files; - interfaces_with_inlining; parse_results;_} -> dep_graph -let (__proj__Mkdeps__item__file_system_map : deps -> files_for_module_name) = - fun projectee -> - match projectee with - | { dep_graph; file_system_map; cmd_line_files; all_files; - interfaces_with_inlining; parse_results;_} -> file_system_map -let (__proj__Mkdeps__item__cmd_line_files : deps -> file_name Prims.list) = - fun projectee -> - match projectee with - | { dep_graph; file_system_map; cmd_line_files; all_files; - interfaces_with_inlining; parse_results;_} -> cmd_line_files -let (__proj__Mkdeps__item__all_files : deps -> file_name Prims.list) = - fun projectee -> - match projectee with - | { dep_graph; file_system_map; cmd_line_files; all_files; - interfaces_with_inlining; parse_results;_} -> all_files -let (__proj__Mkdeps__item__interfaces_with_inlining : - deps -> module_name Prims.list) = - fun projectee -> - match projectee with - | { dep_graph; file_system_map; cmd_line_files; all_files; - interfaces_with_inlining; parse_results;_} -> - interfaces_with_inlining -let (__proj__Mkdeps__item__parse_results : - deps -> parsing_data FStar_Compiler_Util.smap) = - fun projectee -> - match projectee with - | { dep_graph; file_system_map; cmd_line_files; all_files; - interfaces_with_inlining; parse_results;_} -> parse_results -let (deps_try_find : - dependence_graph -> Prims.string -> dep_node FStar_Pervasives_Native.option) - = - fun uu___ -> - fun k -> - match uu___ with | Deps m -> FStar_Compiler_Util.smap_try_find m k -let (deps_add_dep : dependence_graph -> Prims.string -> dep_node -> unit) = - fun uu___ -> - fun k -> - fun v -> - match uu___ with | Deps m -> FStar_Compiler_Util.smap_add m k v -let (deps_keys : dependence_graph -> Prims.string Prims.list) = - fun uu___ -> match uu___ with | Deps m -> FStar_Compiler_Util.smap_keys m -let (deps_empty : unit -> dependence_graph) = - fun uu___ -> - let uu___1 = FStar_Compiler_Util.smap_create (Prims.of_int (41)) in - Deps uu___1 -let (mk_deps : - dependence_graph -> - files_for_module_name -> - file_name Prims.list -> - file_name Prims.list -> - module_name Prims.list -> - parsing_data FStar_Compiler_Util.smap -> deps) - = - fun dg -> - fun fs -> - fun c -> - fun a -> - fun i -> - fun pr -> - { - dep_graph = dg; - file_system_map = fs; - cmd_line_files = c; - all_files = a; - interfaces_with_inlining = i; - parse_results = pr - } -let (empty_deps : deps) = - let uu___ = deps_empty () in - let uu___1 = FStar_Compiler_Util.smap_create Prims.int_zero in - let uu___2 = FStar_Compiler_Util.smap_create Prims.int_zero in - mk_deps uu___ uu___1 [] [] [] uu___2 -let (module_name_of_dep : dependence -> module_name) = - fun uu___ -> - match uu___ with - | UseInterface m -> m - | PreferInterface m -> m - | UseImplementation m -> m - | FriendImplementation m -> m -let (resolve_module_name : - files_for_module_name -> - module_name -> module_name FStar_Pervasives_Native.option) - = - fun file_system_map -> - fun key -> - let uu___ = FStar_Compiler_Util.smap_try_find file_system_map key in - match uu___ with - | FStar_Pervasives_Native.Some - (FStar_Pervasives_Native.Some fn, uu___1) -> - let uu___2 = lowercase_module_name fn in - FStar_Pervasives_Native.Some uu___2 - | FStar_Pervasives_Native.Some - (uu___1, FStar_Pervasives_Native.Some fn) -> - let uu___2 = lowercase_module_name fn in - FStar_Pervasives_Native.Some uu___2 - | uu___1 -> FStar_Pervasives_Native.None -let (interface_of_internal : - files_for_module_name -> - module_name -> file_name FStar_Pervasives_Native.option) - = - fun file_system_map -> - fun key -> - let uu___ = FStar_Compiler_Util.smap_try_find file_system_map key in - match uu___ with - | FStar_Pervasives_Native.Some - (FStar_Pervasives_Native.Some iface, uu___1) -> - FStar_Pervasives_Native.Some iface - | uu___1 -> FStar_Pervasives_Native.None -let (implementation_of_internal : - files_for_module_name -> - module_name -> file_name FStar_Pervasives_Native.option) - = - fun file_system_map -> - fun key -> - let uu___ = FStar_Compiler_Util.smap_try_find file_system_map key in - match uu___ with - | FStar_Pervasives_Native.Some - (uu___1, FStar_Pervasives_Native.Some impl) -> - FStar_Pervasives_Native.Some impl - | uu___1 -> FStar_Pervasives_Native.None -let (interface_of : - deps -> Prims.string -> Prims.string FStar_Pervasives_Native.option) = - fun deps1 -> fun key -> interface_of_internal deps1.file_system_map key -let (implementation_of : - deps -> Prims.string -> Prims.string FStar_Pervasives_Native.option) = - fun deps1 -> - fun key -> implementation_of_internal deps1.file_system_map key -let (has_interface : files_for_module_name -> module_name -> Prims.bool) = - fun file_system_map -> - fun key -> - let uu___ = interface_of_internal file_system_map key in - FStar_Compiler_Option.isSome uu___ -let (has_implementation : files_for_module_name -> module_name -> Prims.bool) - = - fun file_system_map -> - fun key -> - let uu___ = implementation_of_internal file_system_map key in - FStar_Compiler_Option.isSome uu___ -let (cache_file_name : Prims.string -> Prims.string) = - let checked_file_and_exists_flag fn = - let cache_fn = - let lax = FStar_Options.lax () in - if lax - then Prims.strcat fn ".checked.lax" - else Prims.strcat fn ".checked" in - let mname = module_name_of_file fn in - let uu___ = - let uu___1 = FStar_Compiler_Util.basename cache_fn in - FStar_Find.find_file uu___1 in - match uu___ with - | FStar_Pervasives_Native.Some path -> - let expected_cache_file = FStar_Options.prepend_cache_dir cache_fn in - ((let uu___2 = - ((let uu___3 = FStar_Options.dep () in - FStar_Compiler_Option.isSome uu___3) && - (let uu___3 = FStar_Options.should_be_already_cached mname in - Prims.op_Negation uu___3)) - && - ((Prims.op_Negation - (FStar_Compiler_Util.file_exists expected_cache_file)) - || - (let uu___3 = - FStar_Compiler_Util.paths_to_same_file path - expected_cache_file in - Prims.op_Negation uu___3)) in - if uu___2 - then - let uu___3 = - let uu___4 = - let uu___5 = FStar_Errors_Msg.text "Did not expect module" in - let uu___6 = - let uu___7 = FStar_Pprint.doc_of_string mname in - let uu___8 = FStar_Errors_Msg.text "to be already checked." in - FStar_Pprint.op_Hat_Slash_Hat uu___7 uu___8 in - FStar_Pprint.op_Hat_Slash_Hat uu___5 uu___6 in - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Errors_Msg.text - "Found it in an unexpected location:" in - let uu___9 = FStar_Pprint.doc_of_string path in - FStar_Pprint.prefix (Prims.of_int (2)) Prims.int_one - uu___8 uu___9 in - let uu___8 = - let uu___9 = FStar_Errors_Msg.text "instead of" in - let uu___10 = - FStar_Pprint.doc_of_string expected_cache_file in - FStar_Pprint.prefix (Prims.of_int (2)) Prims.int_one - uu___9 uu___10 in - FStar_Pprint.op_Hat_Slash_Hat uu___7 uu___8 in - [uu___6] in - uu___4 :: uu___5 in - FStar_Errors.log_issue0 - FStar_Errors_Codes.Warning_UnexpectedCheckedFile () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___3) - else ()); - (let uu___2 = - (FStar_Compiler_Util.file_exists expected_cache_file) && - (FStar_Compiler_Util.paths_to_same_file path - expected_cache_file) in - if uu___2 then expected_cache_file else path)) - | FStar_Pervasives_Native.None -> - ((let uu___2 = FStar_Compiler_Effect.op_Bang dbg_CheckedFiles in - if uu___2 - then - let uu___3 = FStar_Compiler_Util.basename cache_fn in - FStar_Compiler_Util.print1 "find_file(%s) returned None\n" uu___3 - else ()); - (let uu___3 = FStar_Options.should_be_already_cached mname in - if uu___3 - then - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Compiler_Util.format1 - "Expected %s to be already checked but could not find it." - mname in - FStar_Errors_Msg.text uu___6 in - [uu___5] in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Error_AlreadyCachedAssertionFailure () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___4) - else ()); - FStar_Options.prepend_cache_dir cache_fn) in - let memo = FStar_Compiler_Util.smap_create (Prims.of_int (100)) in - let memo1 f x = - let uu___ = FStar_Compiler_Util.smap_try_find memo x in - match uu___ with - | FStar_Pervasives_Native.Some res -> res - | FStar_Pervasives_Native.None -> - let res = f x in (FStar_Compiler_Util.smap_add memo x res; res) in - memo1 checked_file_and_exists_flag -let (parsing_data_of : deps -> Prims.string -> parsing_data) = - fun deps1 -> - fun fn -> - let uu___ = FStar_Compiler_Util.smap_try_find deps1.parse_results fn in - FStar_Compiler_Util.must uu___ -let (file_of_dep_aux : - Prims.bool -> - files_for_module_name -> file_name Prims.list -> dependence -> file_name) - = - fun use_checked_file -> - fun file_system_map -> - fun all_cmd_line_files -> - fun d -> - let cmd_line_has_impl key = - FStar_Compiler_Util.for_some - (fun fn -> - (is_implementation fn) && - (let uu___ = lowercase_module_name fn in key = uu___)) - all_cmd_line_files in - let maybe_use_cache_of f = - if use_checked_file then cache_file_name f else f in - match d with - | UseInterface key -> - let uu___ = interface_of_internal file_system_map key in - (match uu___ with - | FStar_Pervasives_Native.None -> - let uu___1 = - FStar_Compiler_Util.format1 - "Expected an interface for module %s, but couldn't find one" - key in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_MissingInterface () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) - | FStar_Pervasives_Native.Some f -> f) - | PreferInterface key when has_interface file_system_map key -> - let uu___ = - (cmd_line_has_impl key) && - (let uu___1 = FStar_Options.dep () in - FStar_Compiler_Option.isNone uu___1) in - if uu___ - then - let uu___1 = FStar_Options.expose_interfaces () in - (if uu___1 - then - let uu___2 = - let uu___3 = - implementation_of_internal file_system_map key in - FStar_Compiler_Option.get uu___3 in - maybe_use_cache_of uu___2 - else - (let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - implementation_of_internal file_system_map key in - FStar_Compiler_Option.get uu___7 in - let uu___7 = - let uu___8 = - interface_of_internal file_system_map key in - FStar_Compiler_Option.get uu___8 in - FStar_Compiler_Util.format3 - "You may have a cyclic dependence on module %s: use --dep full to confirm. Alternatively, invoking fstar with %s on the command line breaks the abstraction imposed by its interface %s." - key uu___6 uu___7 in - FStar_Errors_Msg.text uu___5 in - let uu___5 = - let uu___6 = - FStar_Errors_Msg.text - "If you really want this behavior add the option '--expose_interfaces'." in - [uu___6] in - uu___4 :: uu___5 in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_MissingExposeInterfacesOption - () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___3))) - else - (let uu___2 = - let uu___3 = interface_of_internal file_system_map key in - FStar_Compiler_Option.get uu___3 in - maybe_use_cache_of uu___2) - | PreferInterface key -> - let uu___ = implementation_of_internal file_system_map key in - (match uu___ with - | FStar_Pervasives_Native.None -> - let uu___1 = - FStar_Compiler_Util.format1 - "Expected an implementation of module %s, but couldn't find one" - key in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_MissingImplementation () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) - | FStar_Pervasives_Native.Some f -> maybe_use_cache_of f) - | UseImplementation key -> - let uu___ = implementation_of_internal file_system_map key in - (match uu___ with - | FStar_Pervasives_Native.None -> - let uu___1 = - FStar_Compiler_Util.format1 - "Expected an implementation of module %s, but couldn't find one" - key in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_MissingImplementation () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) - | FStar_Pervasives_Native.Some f -> maybe_use_cache_of f) - | FriendImplementation key -> - let uu___ = implementation_of_internal file_system_map key in - (match uu___ with - | FStar_Pervasives_Native.None -> - let uu___1 = - FStar_Compiler_Util.format1 - "Expected an implementation of module %s, but couldn't find one" - key in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_MissingImplementation () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) - | FStar_Pervasives_Native.Some f -> maybe_use_cache_of f) -let (file_of_dep : - files_for_module_name -> file_name Prims.list -> dependence -> file_name) = - file_of_dep_aux false -let (dependences_of : - files_for_module_name -> - dependence_graph -> - file_name Prims.list -> file_name -> file_name Prims.list) - = - fun file_system_map -> - fun deps1 -> - fun all_cmd_line_files -> - fun fn -> - let uu___ = deps_try_find deps1 fn in - match uu___ with - | FStar_Pervasives_Native.None -> empty_dependences () - | FStar_Pervasives_Native.Some { edges = deps2; color = uu___1;_} - -> - let uu___2 = - FStar_Compiler_List.map - (file_of_dep file_system_map all_cmd_line_files) deps2 in - FStar_Compiler_List.filter (fun k -> k <> fn) uu___2 -let (print_graph : - FStar_Compiler_Util.out_channel -> Prims.string -> dependence_graph -> unit) - = - fun outc -> - fun fn -> - fun graph -> - (let uu___1 = - let uu___2 = FStar_Options.silent () in Prims.op_Negation uu___2 in - if uu___1 - then - (FStar_Compiler_Util.print1 - "A DOT-format graph has been dumped in the current directory as `%s`\n" - fn; - FStar_Compiler_Util.print1 - "With GraphViz installed, try: fdp -Tpng -odep.png %s\n" fn; - FStar_Compiler_Util.print1 - "Hint: cat %s | grep -v _ | grep -v prims\n" fn) - else ()); - (let s = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = deps_keys graph in - FStar_Compiler_List.unique uu___5 in - FStar_Compiler_List.collect - (fun k -> - let deps1 = - let uu___5 = - let uu___6 = deps_try_find graph k in - FStar_Compiler_Util.must uu___6 in - uu___5.edges in - let r s1 = FStar_Compiler_Util.replace_char s1 46 95 in - let print dep = - let uu___5 = - let uu___6 = lowercase_module_name k in r uu___6 in - FStar_Compiler_Util.format2 " \"%s\" -> \"%s\"" - uu___5 (r (module_name_of_dep dep)) in - FStar_Compiler_List.map print deps1) uu___4 in - FStar_Compiler_String.concat "\n" uu___3 in - Prims.strcat uu___2 "\n}\n" in - Prims.strcat "digraph {\n" uu___1 in - FStar_Compiler_Util.fprint outc "%s" [s]) -let (safe_readdir_for_include : Prims.string -> Prims.string Prims.list) = - fun d -> - try (fun uu___ -> match () with | () -> FStar_Compiler_Util.readdir d) () - with - | uu___ -> - ((let uu___2 = - let uu___3 = - let uu___4 = - FStar_Errors_Msg.text "Not a valid include directory:" in - let uu___5 = FStar_Pprint.doc_of_string d in - FStar_Pprint.prefix (Prims.of_int (2)) Prims.int_one uu___4 - uu___5 in - [uu___3] in - FStar_Errors.log_issue0 - FStar_Errors_Codes.Fatal_NotValidIncludeDirectory () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___2)); - []) -let (build_inclusion_candidates_list : - unit -> (Prims.string * Prims.string) Prims.list) = - fun uu___ -> - let include_directories = FStar_Options.include_path () in - let include_directories1 = - FStar_Compiler_List.map FStar_Compiler_Util.normalize_file_path - include_directories in - let include_directories2 = - FStar_Compiler_List.unique include_directories1 in - let cwd = - let uu___1 = FStar_Compiler_Util.getcwd () in - FStar_Compiler_Util.normalize_file_path uu___1 in - FStar_Compiler_List.concatMap - (fun d -> - let files = safe_readdir_for_include d in - FStar_Compiler_List.filter_map - (fun f -> - let f1 = FStar_Compiler_Util.basename f in - let uu___1 = check_and_strip_suffix f1 in - FStar_Compiler_Util.map_option - (fun longname -> - let full_path = - if d = cwd - then f1 - else FStar_Compiler_Util.join_paths d f1 in - (longname, full_path)) uu___1) files) include_directories2 -let (build_map : Prims.string Prims.list -> files_for_module_name) = - fun filenames -> - let map = FStar_Compiler_Util.smap_create (Prims.of_int (41)) in - let add_entry key full_path = - let uu___ = FStar_Compiler_Util.smap_try_find map key in - match uu___ with - | FStar_Pervasives_Native.Some (intf, impl) -> - let uu___1 = is_interface full_path in - if uu___1 - then - FStar_Compiler_Util.smap_add map key - ((FStar_Pervasives_Native.Some full_path), impl) - else - FStar_Compiler_Util.smap_add map key - (intf, (FStar_Pervasives_Native.Some full_path)) - | FStar_Pervasives_Native.None -> - let uu___1 = is_interface full_path in - if uu___1 - then - FStar_Compiler_Util.smap_add map key - ((FStar_Pervasives_Native.Some full_path), - FStar_Pervasives_Native.None) - else - FStar_Compiler_Util.smap_add map key - (FStar_Pervasives_Native.None, - (FStar_Pervasives_Native.Some full_path)) in - (let uu___1 = build_inclusion_candidates_list () in - FStar_Compiler_List.iter - (fun uu___2 -> - match uu___2 with - | (longname, full_path) -> - add_entry (FStar_Compiler_String.lowercase longname) full_path) - uu___1); - FStar_Compiler_List.iter - (fun f -> let uu___2 = lowercase_module_name f in add_entry uu___2 f) - filenames; - map -let (string_of_lid : FStar_Ident.lident -> Prims.bool -> Prims.string) = - fun l -> - fun last -> - let suffix = - if last - then - let uu___ = - let uu___1 = FStar_Ident.ident_of_lid l in - FStar_Ident.string_of_id uu___1 in - [uu___] - else [] in - let names = - let uu___ = - let uu___1 = FStar_Ident.ns_of_lid l in - FStar_Compiler_List.map (fun x -> FStar_Ident.string_of_id x) - uu___1 in - FStar_Compiler_List.op_At uu___ suffix in - FStar_Compiler_String.concat "." names -let (lowercase_join_longident : - FStar_Ident.lident -> Prims.bool -> Prims.string) = - fun l -> - fun last -> - let uu___ = string_of_lid l last in - FStar_Compiler_String.lowercase uu___ -let (namespace_of_lid : FStar_Ident.lident -> Prims.string) = - fun l -> - let uu___ = - let uu___1 = FStar_Ident.ns_of_lid l in - FStar_Compiler_List.map FStar_Ident.string_of_id uu___1 in - FStar_Compiler_String.concat "_" uu___ -let (check_module_declaration_against_filename : - FStar_Ident.lident -> Prims.string -> unit) = - fun lid -> - fun filename -> - let k' = string_of_lid lid true in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Compiler_Util.basename filename in - check_and_strip_suffix uu___3 in - FStar_Compiler_Util.must uu___2 in - uu___1 <> k' in - if uu___ - then - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = string_of_lid lid true in - FStar_Compiler_Util.format2 - "The module declaration \"module %s\" found in file %s does not match its filename." - uu___4 filename in - FStar_Errors_Msg.text uu___3 in - let uu___3 = - let uu___4 = - FStar_Errors_Msg.text - "Dependencies will be incorrect and the module will not be verified." in - [uu___4] in - uu___2 :: uu___3 in - FStar_Errors.log_issue FStar_Ident.hasrange_lident lid - FStar_Errors_Codes.Error_ModuleFileNameMismatch () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___1) - else () -exception Exit -let (uu___is_Exit : Prims.exn -> Prims.bool) = - fun projectee -> match projectee with | Exit -> true | uu___ -> false -let (core_modules : unit -> Prims.string Prims.list) = - fun uu___ -> - let uu___1 = - let uu___2 = FStar_Basefiles.prims_basename () in - let uu___3 = - let uu___4 = FStar_Basefiles.pervasives_basename () in - let uu___5 = - let uu___6 = FStar_Basefiles.pervasives_native_basename () in - [uu___6] in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - FStar_Compiler_List.map module_name_of_file uu___1 -let (implicit_ns_deps : FStar_Ident.lident Prims.list) = - [FStar_Parser_Const.fstar_ns_lid] -let (implicit_module_deps : FStar_Ident.lident Prims.list) = - [FStar_Parser_Const.prims_lid; FStar_Parser_Const.pervasives_lid] -let (hard_coded_dependencies : - Prims.string -> (FStar_Ident.lident * open_kind) Prims.list) = - fun full_filename -> - let filename = FStar_Compiler_Util.basename full_filename in - let implicit_module_deps1 = - FStar_Compiler_List.map (fun l -> (l, Open_module)) - implicit_module_deps in - let implicit_ns_deps1 = - FStar_Compiler_List.map (fun l -> (l, Open_namespace)) implicit_ns_deps in - let uu___ = - let uu___1 = module_name_of_file filename in - let uu___2 = core_modules () in FStar_Compiler_List.mem uu___1 uu___2 in - if uu___ - then [] - else - (let uu___2 = - let uu___3 = module_name_of_file full_filename in - namespace_of_module uu___3 in - match uu___2 with - | FStar_Pervasives_Native.None -> - FStar_Compiler_List.op_At implicit_ns_deps1 implicit_module_deps1 - | FStar_Pervasives_Native.Some ns -> - FStar_Compiler_List.op_At implicit_ns_deps1 - (FStar_Compiler_List.op_At implicit_module_deps1 - [(ns, Open_namespace)])) -let (dep_subsumed_by : dependence -> dependence -> Prims.bool) = - fun d -> - fun d' -> - match (d, d') with - | (PreferInterface l', FriendImplementation l) -> l = l' - | uu___ -> d = d' -let (enter_namespace : - files_for_module_name -> - files_for_module_name -> Prims.string -> Prims.bool -> Prims.bool) - = - fun original_map -> - fun working_map -> - fun sprefix -> - fun implicit_open -> - let found = FStar_Compiler_Util.mk_ref false in - let sprefix1 = Prims.strcat sprefix "." in - let suffix_exists mopt = - match mopt with - | FStar_Pervasives_Native.None -> false - | FStar_Pervasives_Native.Some (intf, impl) -> - (FStar_Compiler_Util.is_some intf) || - (FStar_Compiler_Util.is_some impl) in - FStar_Compiler_Util.smap_iter original_map - (fun k -> - fun uu___1 -> - if FStar_Compiler_Util.starts_with k sprefix1 - then - let suffix = - FStar_Compiler_String.substring k - (FStar_Compiler_String.length sprefix1) - ((FStar_Compiler_String.length k) - - (FStar_Compiler_String.length sprefix1)) in - ((let suffix_filename = - FStar_Compiler_Util.smap_try_find original_map suffix in - if implicit_open && (suffix_exists suffix_filename) - then - let str = - let uu___3 = - FStar_Compiler_Util.must suffix_filename in - intf_and_impl_to_string uu___3 in - let uu___3 = - let uu___4 = - let uu___5 = FStar_Pprint.break_ Prims.int_one in - let uu___6 = - let uu___7 = - FStar_Errors_Msg.text - "Implicitly opening namespace" in - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Pprint.doc_of_string sprefix1 in - FStar_Pprint.squotes uu___10 in - let uu___10 = - let uu___11 = - FStar_Errors_Msg.text "shadows module" in - let uu___12 = - let uu___13 = - let uu___14 = - FStar_Pprint.doc_of_string suffix in - FStar_Pprint.squotes uu___14 in - let uu___14 = - let uu___15 = - FStar_Errors_Msg.text "in file" in - let uu___16 = - let uu___17 = - let uu___18 = - let uu___19 = - FStar_Pprint.doc_of_string str in - FStar_Pprint.dquotes uu___19 in - FStar_Pprint.op_Hat_Hat uu___18 - FStar_Pprint.dot in - [uu___17] in - uu___15 :: uu___16 in - uu___13 :: uu___14 in - uu___11 :: uu___12 in - uu___9 :: uu___10 in - uu___7 :: uu___8 in - FStar_Pprint.flow uu___5 uu___6 in - let uu___5 = - let uu___6 = - let uu___7 = FStar_Errors_Msg.text "Rename" in - let uu___8 = - let uu___9 = - let uu___10 = FStar_Pprint.doc_of_string str in - FStar_Pprint.dquotes uu___10 in - let uu___10 = - FStar_Errors_Msg.text "to avoid conflicts." in - FStar_Pprint.op_Hat_Slash_Hat uu___9 uu___10 in - FStar_Pprint.op_Hat_Slash_Hat uu___7 uu___8 in - [uu___6] in - uu___4 :: uu___5 in - FStar_Errors.log_issue0 - FStar_Errors_Codes.Warning_UnexpectedFile () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___3) - else ()); - (let filename = - let uu___3 = - FStar_Compiler_Util.smap_try_find original_map k in - FStar_Compiler_Util.must uu___3 in - FStar_Compiler_Util.smap_add working_map suffix filename; - FStar_Compiler_Effect.op_Colon_Equals found true)) - else ()); - FStar_Compiler_Effect.op_Bang found -let (collect_one : - files_for_module_name -> - Prims.string -> - (Prims.string -> parsing_data FStar_Pervasives_Native.option) -> - (parsing_data * dependence Prims.list * Prims.bool * dependence - Prims.list)) - = - fun original_map -> - fun filename -> - fun get_parsing_data_from_cache -> - let from_parsing_data pd original_map1 filename1 = - let deps1 = FStar_Compiler_Util.mk_ref [] in - let has_inline_for_extraction = FStar_Compiler_Util.mk_ref false in - let mo_roots = - let mname = lowercase_module_name filename1 in - let uu___ = - (is_interface filename1) && - (has_implementation original_map1 mname) in - if uu___ then [UseImplementation mname] else [] in - let auto_open = - let uu___ = hard_coded_dependencies filename1 in - FStar_Compiler_List.map - (fun uu___1 -> - match uu___1 with - | (lid, k) -> P_implicit_open_module_or_namespace (k, lid)) - uu___ in - let working_map = FStar_Compiler_Util.smap_copy original_map1 in - let set_interface_inlining uu___ = - let uu___1 = is_interface filename1 in - if uu___1 - then - FStar_Compiler_Effect.op_Colon_Equals has_inline_for_extraction - true - else () in - let add_dep deps2 d = - let uu___ = - let uu___1 = - let uu___2 = FStar_Compiler_Effect.op_Bang deps2 in - FStar_Compiler_List.existsML (dep_subsumed_by d) uu___2 in - Prims.op_Negation uu___1 in - if uu___ - then - let uu___1 = - let uu___2 = FStar_Compiler_Effect.op_Bang deps2 in d :: - uu___2 in - FStar_Compiler_Effect.op_Colon_Equals deps2 uu___1 - else () in - let dep_edge module_name1 is_friend = - if is_friend - then FriendImplementation module_name1 - else PreferInterface module_name1 in - let add_dependence_edge original_or_working_map lid is_friend = - let key = lowercase_join_longident lid true in - let uu___ = resolve_module_name original_or_working_map key in - match uu___ with - | FStar_Pervasives_Native.Some module_name1 -> - (add_dep deps1 (dep_edge module_name1 is_friend); true) - | uu___1 -> false in - let record_open_module let_open lid = - let uu___ = - (let_open && (add_dependence_edge working_map lid false)) || - ((Prims.op_Negation let_open) && - (add_dependence_edge original_map1 lid false)) in - if uu___ - then true - else - (if let_open - then - (let uu___3 = - let uu___4 = string_of_lid lid true in - FStar_Compiler_Util.format1 "Module not found: %s" uu___4 in - FStar_Errors.log_issue FStar_Ident.hasrange_lident lid - FStar_Errors_Codes.Warning_ModuleOrFileNotFoundWarning () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___3)) - else (); - false) in - let record_open_namespace lid implicit_open = - let key = lowercase_join_longident lid true in - let r = - enter_namespace original_map1 working_map key implicit_open in - if (Prims.op_Negation r) && (Prims.op_Negation implicit_open) - then - let uu___ = - let uu___1 = string_of_lid lid true in - FStar_Compiler_Util.format1 - "No modules in namespace %s and no file with that name either" - uu___1 in - FStar_Errors.log_issue FStar_Ident.hasrange_lident lid - FStar_Errors_Codes.Warning_ModuleOrFileNotFoundWarning () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___) - else () in - let record_open let_open lid = - let uu___ = record_open_module let_open lid in - if uu___ - then () - else - if Prims.op_Negation let_open - then record_open_namespace lid false - else () in - let record_implicit_open_module_or_namespace uu___ = - match uu___ with - | (lid, kind) -> - (match kind with - | Open_namespace -> record_open_namespace lid true - | Open_module -> - let uu___1 = record_open_module false lid in ()) in - let record_module_alias ident lid = - let key = - let uu___ = FStar_Ident.string_of_id ident in - FStar_Compiler_String.lowercase uu___ in - let alias = lowercase_join_longident lid true in - let uu___ = FStar_Compiler_Util.smap_try_find original_map1 alias in - match uu___ with - | FStar_Pervasives_Native.Some deps_of_aliased_module -> - (FStar_Compiler_Util.smap_add working_map key - deps_of_aliased_module; - (let uu___3 = - let uu___4 = lowercase_join_longident lid true in - dep_edge uu___4 false in - add_dep deps1 uu___3); - true) - | FStar_Pervasives_Native.None -> - ((let uu___2 = - FStar_Compiler_Util.format1 - "module not found in search path: %s" alias in - FStar_Errors.log_issue FStar_Ident.hasrange_lident lid - FStar_Errors_Codes.Warning_ModuleOrFileNotFoundWarning () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - false) in - let add_dep_on_module module_name1 is_friend = - let uu___ = - add_dependence_edge working_map module_name1 is_friend in - if uu___ - then () - else - (let uu___2 = FStar_Compiler_Effect.op_Bang dbg in - if uu___2 - then - let uu___3 = - let uu___4 = - FStar_Class_Show.show FStar_Ident.showable_lident - module_name1 in - FStar_Compiler_Util.format1 "Unbound module reference %s" - uu___4 in - FStar_Errors.log_issue FStar_Ident.hasrange_lident - module_name1 - FStar_Errors_Codes.Warning_UnboundModuleReference () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___3) - else ()) in - let record_lid lid = - let uu___ = FStar_Ident.ns_of_lid lid in - match uu___ with - | [] -> () - | ns -> - let module_name1 = FStar_Ident.lid_of_ids ns in - add_dep_on_module module_name1 false in - let begin_module lid = - let uu___ = - let uu___1 = - let uu___2 = FStar_Ident.ns_of_lid lid in - FStar_Compiler_List.length uu___2 in - uu___1 > Prims.int_zero in - if uu___ - then - let uu___1 = - let uu___2 = namespace_of_lid lid in - enter_namespace original_map1 working_map uu___2 in - () - else () in - (match pd with - | Mk_pd l -> - FStar_Compiler_List.iter - (fun elt -> - match elt with - | P_begin_module lid -> begin_module lid - | P_open (b, lid) -> record_open b lid - | P_implicit_open_module_or_namespace (k, lid) -> - record_implicit_open_module_or_namespace (lid, k) - | P_dep (b, lid) -> add_dep_on_module lid b - | P_alias (id, lid) -> - let uu___1 = record_module_alias id lid in () - | P_lid lid -> record_lid lid - | P_inline_for_extraction -> set_interface_inlining ()) - (FStar_Compiler_List.op_At auto_open l)); - (let uu___1 = FStar_Compiler_Effect.op_Bang deps1 in - let uu___2 = - FStar_Compiler_Effect.op_Bang has_inline_for_extraction in - (uu___1, uu___2, mo_roots)) in - let data_from_cache = get_parsing_data_from_cache filename in - if FStar_Compiler_Util.is_some data_from_cache - then - let uu___ = - let uu___1 = FStar_Compiler_Util.must data_from_cache in - from_parsing_data uu___1 original_map filename in - match uu___ with - | (deps1, has_inline_for_extraction, mo_roots) -> - ((let uu___2 = FStar_Compiler_Effect.op_Bang dbg in - if uu___2 - then - let uu___3 = - FStar_Class_Show.show - (FStar_Class_Show.show_list showable_dependence) deps1 in - FStar_Compiler_Util.print2 - "Reading the parsing data for %s from its checked file .. found [%s]\n" - filename uu___3 - else ()); - (let uu___2 = FStar_Compiler_Util.must data_from_cache in - (uu___2, deps1, has_inline_for_extraction, mo_roots))) - else - (let num_of_toplevelmods = - FStar_Compiler_Util.mk_ref Prims.int_zero in - let pd = FStar_Compiler_Util.mk_ref [] in - let add_to_parsing_data elt = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Compiler_Effect.op_Bang pd in - FStar_Compiler_List.existsML - (fun e -> parsing_data_elt_eq e elt) uu___3 in - Prims.op_Negation uu___2 in - if uu___1 - then - let uu___2 = - let uu___3 = FStar_Compiler_Effect.op_Bang pd in elt :: - uu___3 in - FStar_Compiler_Effect.op_Colon_Equals pd uu___2 - else () in - let rec collect_module uu___1 = - match uu___1 with - | FStar_Parser_AST.Module (lid, decls) -> - (check_module_declaration_against_filename lid filename; - add_to_parsing_data (P_begin_module lid); - collect_decls decls) - | FStar_Parser_AST.Interface (lid, decls, uu___2) -> - (check_module_declaration_against_filename lid filename; - add_to_parsing_data (P_begin_module lid); - collect_decls decls) - and collect_decls decls = - FStar_Compiler_List.iter - (fun x -> - collect_decl x.FStar_Parser_AST.d; - FStar_Compiler_List.iter collect_term - x.FStar_Parser_AST.attrs; - if - FStar_Compiler_List.contains - FStar_Parser_AST.Inline_for_extraction - x.FStar_Parser_AST.quals - then add_to_parsing_data P_inline_for_extraction - else ()) decls - and collect_decl d = - match d with - | FStar_Parser_AST.Include (lid, uu___1) -> - add_to_parsing_data (P_open (false, lid)) - | FStar_Parser_AST.Open (lid, uu___1) -> - add_to_parsing_data (P_open (false, lid)) - | FStar_Parser_AST.Friend lid -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = lowercase_join_longident lid true in - FStar_Ident.lid_of_str uu___4 in - (true, uu___3) in - P_dep uu___2 in - add_to_parsing_data uu___1 - | FStar_Parser_AST.ModuleAbbrev (ident, lid) -> - add_to_parsing_data (P_alias (ident, lid)) - | FStar_Parser_AST.TopLevelLet (uu___1, patterms) -> - FStar_Compiler_List.iter - (fun uu___2 -> - match uu___2 with - | (pat, t) -> (collect_pattern pat; collect_term t)) - patterms - | FStar_Parser_AST.Splice (uu___1, uu___2, t) -> collect_term t - | FStar_Parser_AST.Assume (uu___1, t) -> collect_term t - | FStar_Parser_AST.SubEffect - { FStar_Parser_AST.msource = uu___1; - FStar_Parser_AST.mdest = uu___2; - FStar_Parser_AST.lift_op = - FStar_Parser_AST.NonReifiableLift t; - FStar_Parser_AST.braced = uu___3;_} - -> collect_term t - | FStar_Parser_AST.SubEffect - { FStar_Parser_AST.msource = uu___1; - FStar_Parser_AST.mdest = uu___2; - FStar_Parser_AST.lift_op = FStar_Parser_AST.LiftForFree t; - FStar_Parser_AST.braced = uu___3;_} - -> collect_term t - | FStar_Parser_AST.Val (uu___1, t) -> collect_term t - | FStar_Parser_AST.SubEffect - { FStar_Parser_AST.msource = uu___1; - FStar_Parser_AST.mdest = uu___2; - FStar_Parser_AST.lift_op = FStar_Parser_AST.ReifiableLift - (t0, t1); - FStar_Parser_AST.braced = uu___3;_} - -> (collect_term t0; collect_term t1) - | FStar_Parser_AST.Tycon (uu___1, tc, ts) -> - (if tc - then - add_to_parsing_data - (P_lid FStar_Parser_Const.tcclass_lid) - else (); - FStar_Compiler_List.iter collect_tycon ts) - | FStar_Parser_AST.Exception (uu___1, t) -> - FStar_Compiler_Util.iter_opt t collect_term - | FStar_Parser_AST.NewEffect ed -> collect_effect_decl ed - | FStar_Parser_AST.LayeredEffect ed -> collect_effect_decl ed - | FStar_Parser_AST.Polymonadic_bind (uu___1, uu___2, uu___3, t) - -> collect_term t - | FStar_Parser_AST.Polymonadic_subcomp (uu___1, uu___2, t) -> - collect_term t - | FStar_Parser_AST.DeclToBeDesugared tbs -> - tbs.FStar_Parser_AST.dep_scan - { - FStar_Parser_AST.scan_term = collect_term; - FStar_Parser_AST.scan_binder = collect_binder; - FStar_Parser_AST.scan_pattern = collect_pattern; - FStar_Parser_AST.add_lident = - (fun lid -> add_to_parsing_data (P_lid lid)); - FStar_Parser_AST.add_open = - (fun lid -> add_to_parsing_data (P_open (true, lid))) - } tbs.FStar_Parser_AST.blob - | FStar_Parser_AST.UseLangDecls uu___1 -> () - | FStar_Parser_AST.Pragma uu___1 -> () - | FStar_Parser_AST.DeclSyntaxExtension uu___1 -> () - | FStar_Parser_AST.Unparseable -> () - | FStar_Parser_AST.TopLevelModule lid -> - (FStar_Compiler_Util.incr num_of_toplevelmods; - (let uu___2 = - let uu___3 = - FStar_Compiler_Effect.op_Bang num_of_toplevelmods in - uu___3 > Prims.int_one in - if uu___2 - then - let uu___3 = - let uu___4 = string_of_lid lid true in - FStar_Compiler_Util.format1 - "Automatic dependency analysis demands one module per file (module %s not supported)" - uu___4 in - FStar_Errors.raise_error FStar_Ident.hasrange_lident lid - FStar_Errors_Codes.Fatal_OneModulePerFile () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___3) - else ())) - and collect_tycon uu___1 = - match uu___1 with - | FStar_Parser_AST.TyconAbstract (uu___2, binders, k) -> - (collect_binders binders; - FStar_Compiler_Util.iter_opt k collect_term) - | FStar_Parser_AST.TyconAbbrev (uu___2, binders, k, t) -> - (collect_binders binders; - FStar_Compiler_Util.iter_opt k collect_term; - collect_term t) - | FStar_Parser_AST.TyconRecord - (uu___2, binders, k, uu___3, identterms) -> - (collect_binders binders; - FStar_Compiler_Util.iter_opt k collect_term; - collect_tycon_record identterms) - | FStar_Parser_AST.TyconVariant (uu___2, binders, k, identterms) - -> - (collect_binders binders; - FStar_Compiler_Util.iter_opt k collect_term; - (let uu___5 = - FStar_Compiler_List.filter_map - FStar_Pervasives_Native.__proj__Mktuple3__item___2 - identterms in - FStar_Compiler_List.iter - (fun uu___6 -> - match uu___6 with - | FStar_Parser_AST.VpOfNotation t -> collect_term t - | FStar_Parser_AST.VpArbitrary t -> collect_term t - | FStar_Parser_AST.VpRecord (record, t) -> - (collect_tycon_record record; - FStar_Compiler_Util.iter_opt t collect_term)) - uu___5)) - and collect_tycon_record r = - FStar_Compiler_List.iter - (fun uu___1 -> - match uu___1 with - | (uu___2, aq, attrs, t) -> - (collect_aqual aq; - FStar_Compiler_List.iter collect_term attrs; - collect_term t)) r - and collect_effect_decl uu___1 = - match uu___1 with - | FStar_Parser_AST.DefineEffect (uu___2, binders, t, decls) -> - (collect_binders binders; - collect_term t; - collect_decls decls) - | FStar_Parser_AST.RedefineEffect (uu___2, binders, t) -> - (collect_binders binders; collect_term t) - and collect_binders binders = - FStar_Compiler_List.iter collect_binder binders - and collect_binder b = - collect_aqual b.FStar_Parser_AST.aqual; - FStar_Compiler_List.iter collect_term - b.FStar_Parser_AST.battributes; - (match b with - | { - FStar_Parser_AST.b = FStar_Parser_AST.Annotated (uu___3, t); - FStar_Parser_AST.brange = uu___4; - FStar_Parser_AST.blevel = uu___5; - FStar_Parser_AST.aqual = uu___6; - FStar_Parser_AST.battributes = uu___7;_} -> collect_term t - | { - FStar_Parser_AST.b = FStar_Parser_AST.TAnnotated - (uu___3, t); - FStar_Parser_AST.brange = uu___4; - FStar_Parser_AST.blevel = uu___5; - FStar_Parser_AST.aqual = uu___6; - FStar_Parser_AST.battributes = uu___7;_} -> collect_term t - | { FStar_Parser_AST.b = FStar_Parser_AST.NoName t; - FStar_Parser_AST.brange = uu___3; - FStar_Parser_AST.blevel = uu___4; - FStar_Parser_AST.aqual = uu___5; - FStar_Parser_AST.battributes = uu___6;_} -> collect_term t - | uu___3 -> ()) - and collect_aqual uu___1 = - match uu___1 with - | FStar_Pervasives_Native.Some (FStar_Parser_AST.Meta t) -> - collect_term t - | FStar_Pervasives_Native.Some (FStar_Parser_AST.TypeClassArg) - -> - add_to_parsing_data (P_lid FStar_Parser_Const.tcresolve_lid) - | uu___2 -> () - and collect_term t = collect_term' t.FStar_Parser_AST.tm - and collect_constant uu___1 = - match uu___1 with - | FStar_Const.Const_int - (uu___2, FStar_Pervasives_Native.Some - (FStar_Const.Unsigned, FStar_Const.Sizet)) - -> - let uu___3 = - let uu___4 = - let uu___5 = FStar_Ident.lid_of_str "fstar.sizeT" in - (false, uu___5) in - P_dep uu___4 in - add_to_parsing_data uu___3 - | FStar_Const.Const_int - (uu___2, FStar_Pervasives_Native.Some (signedness, width)) - -> - let u = - match signedness with - | FStar_Const.Unsigned -> "u" - | FStar_Const.Signed -> "" in - let w = - match width with - | FStar_Const.Int8 -> "8" - | FStar_Const.Int16 -> "16" - | FStar_Const.Int32 -> "32" - | FStar_Const.Int64 -> "64" in - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Compiler_Util.format2 "fstar.%sint%s" u w in - FStar_Ident.lid_of_str uu___6 in - (false, uu___5) in - P_dep uu___4 in - add_to_parsing_data uu___3 - | FStar_Const.Const_char uu___2 -> - let uu___3 = - let uu___4 = - let uu___5 = FStar_Ident.lid_of_str "fstar.char" in - (false, uu___5) in - P_dep uu___4 in - add_to_parsing_data uu___3 - | FStar_Const.Const_range_of -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_Ident.lid_of_str "fstar.range" in - (false, uu___4) in - P_dep uu___3 in - add_to_parsing_data uu___2 - | FStar_Const.Const_set_range_of -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_Ident.lid_of_str "fstar.range" in - (false, uu___4) in - P_dep uu___3 in - add_to_parsing_data uu___2 - | FStar_Const.Const_real uu___2 -> - let uu___3 = - let uu___4 = - let uu___5 = FStar_Ident.lid_of_str "fstar.real" in - (false, uu___5) in - P_dep uu___4 in - add_to_parsing_data uu___3 - | uu___2 -> () - and collect_term' uu___1 = - match uu___1 with - | FStar_Parser_AST.Wild -> () - | FStar_Parser_AST.Const c -> collect_constant c - | FStar_Parser_AST.Op (uu___2, ts) -> - FStar_Compiler_List.iter collect_term ts - | FStar_Parser_AST.Tvar uu___2 -> () - | FStar_Parser_AST.Uvar uu___2 -> () - | FStar_Parser_AST.Var lid -> add_to_parsing_data (P_lid lid) - | FStar_Parser_AST.Projector (lid, uu___2) -> - add_to_parsing_data (P_lid lid) - | FStar_Parser_AST.Discrim lid -> - add_to_parsing_data (P_lid lid) - | FStar_Parser_AST.Name lid -> add_to_parsing_data (P_lid lid) - | FStar_Parser_AST.Construct (lid, termimps) -> - (add_to_parsing_data (P_lid lid); - FStar_Compiler_List.iter - (fun uu___3 -> - match uu___3 with | (t, uu___4) -> collect_term t) - termimps) - | FStar_Parser_AST.Function (branches, uu___2) -> - collect_branches branches - | FStar_Parser_AST.Abs (pats, t) -> - (collect_patterns pats; collect_term t) - | FStar_Parser_AST.App (t1, t2, uu___2) -> - (collect_term t1; collect_term t2) - | FStar_Parser_AST.Let (uu___2, patterms, t) -> - (FStar_Compiler_List.iter - (fun uu___4 -> - match uu___4 with - | (attrs_opt, (pat, t1)) -> - ((let uu___6 = - FStar_Compiler_Util.map_opt attrs_opt - (FStar_Compiler_List.iter collect_term) in - ()); - collect_pattern pat; - collect_term t1)) patterms; - collect_term t) - | FStar_Parser_AST.LetOperator (lets, body) -> - (FStar_Compiler_List.iter - (fun uu___3 -> - match uu___3 with - | (ident, pat, def) -> - (collect_pattern pat; collect_term def)) lets; - collect_term body) - | FStar_Parser_AST.LetOpen (lid, t) -> - (add_to_parsing_data (P_open (true, lid)); collect_term t) - | FStar_Parser_AST.LetOpenRecord (r, rty, e) -> - (collect_term r; collect_term rty; collect_term e) - | FStar_Parser_AST.Bind (uu___2, t1, t2) -> - (collect_term t1; collect_term t2) - | FStar_Parser_AST.Seq (t1, t2) -> - (collect_term t1; collect_term t2) - | FStar_Parser_AST.If (t1, uu___2, ret_opt, t2, t3) -> - (collect_term t1; - (match ret_opt with - | FStar_Pervasives_Native.None -> () - | FStar_Pervasives_Native.Some (uu___5, ret, uu___6) -> - collect_term ret); - collect_term t2; - collect_term t3) - | FStar_Parser_AST.Match (t, uu___2, ret_opt, bs) -> - (collect_term t; - (match ret_opt with - | FStar_Pervasives_Native.None -> () - | FStar_Pervasives_Native.Some (uu___5, ret, uu___6) -> - collect_term ret); - collect_branches bs) - | FStar_Parser_AST.TryWith (t, bs) -> - (collect_term t; collect_branches bs) - | FStar_Parser_AST.Ascribed - (t1, t2, FStar_Pervasives_Native.None, uu___2) -> - (collect_term t1; collect_term t2) - | FStar_Parser_AST.Ascribed - (t1, t2, FStar_Pervasives_Native.Some tac, uu___2) -> - (collect_term t1; collect_term t2; collect_term tac) - | FStar_Parser_AST.Record (t, idterms) -> - (FStar_Compiler_Util.iter_opt t collect_term; - FStar_Compiler_List.iter - (fun uu___3 -> - match uu___3 with - | (fn, t1) -> (collect_fieldname fn; collect_term t1)) - idterms) - | FStar_Parser_AST.Project (t, f) -> - (collect_term t; collect_fieldname f) - | FStar_Parser_AST.Product (binders, t) -> - (collect_binders binders; collect_term t) - | FStar_Parser_AST.Sum (binders, t) -> - (FStar_Compiler_List.iter - (fun uu___3 -> - match uu___3 with - | FStar_Pervasives.Inl b -> collect_binder b - | FStar_Pervasives.Inr t1 -> collect_term t1) binders; - collect_term t) - | FStar_Parser_AST.QForall (binders, (uu___2, ts), t) -> - (collect_binders binders; - FStar_Compiler_List.iter - (FStar_Compiler_List.iter collect_term) ts; - collect_term t) - | FStar_Parser_AST.QExists (binders, (uu___2, ts), t) -> - (collect_binders binders; - FStar_Compiler_List.iter - (FStar_Compiler_List.iter collect_term) ts; - collect_term t) - | FStar_Parser_AST.QuantOp (uu___2, binders, (uu___3, ts), t) -> - (collect_binders binders; - FStar_Compiler_List.iter - (FStar_Compiler_List.iter collect_term) ts; - collect_term t) - | FStar_Parser_AST.Refine (binder, t) -> - (collect_binder binder; collect_term t) - | FStar_Parser_AST.NamedTyp (uu___2, t) -> collect_term t - | FStar_Parser_AST.Paren t -> collect_term t - | FStar_Parser_AST.Requires (t, uu___2) -> collect_term t - | FStar_Parser_AST.Ensures (t, uu___2) -> collect_term t - | FStar_Parser_AST.Labeled (t, uu___2, uu___3) -> collect_term t - | FStar_Parser_AST.LexList l -> - FStar_Compiler_List.iter collect_term l - | FStar_Parser_AST.WFOrder (t1, t2) -> - ((let uu___3 = - let uu___4 = - let uu___5 = - FStar_Ident.lid_of_str "FStar.WellFounded" in - (false, uu___5) in - P_dep uu___4 in - add_to_parsing_data uu___3); - collect_term t1; - collect_term t2) - | FStar_Parser_AST.Decreases (t, uu___2) -> collect_term t - | FStar_Parser_AST.Quote (t, uu___2) -> collect_term t - | FStar_Parser_AST.Antiquote t -> collect_term t - | FStar_Parser_AST.VQuote t -> collect_term t - | FStar_Parser_AST.Attributes cattributes -> - FStar_Compiler_List.iter collect_term cattributes - | FStar_Parser_AST.CalcProof (rel, init, steps) -> - ((let uu___3 = - let uu___4 = - let uu___5 = FStar_Ident.lid_of_str "FStar.Calc" in - (false, uu___5) in - P_dep uu___4 in - add_to_parsing_data uu___3); - collect_term rel; - collect_term init; - FStar_Compiler_List.iter - (fun uu___5 -> - match uu___5 with - | FStar_Parser_AST.CalcStep (rel1, just, next) -> - (collect_term rel1; - collect_term just; - collect_term next)) steps) - | FStar_Parser_AST.IntroForall (bs, p, e) -> - ((let uu___3 = - let uu___4 = - let uu___5 = - FStar_Ident.lid_of_str "FStar.Classical.Sugar" in - (false, uu___5) in - P_dep uu___4 in - add_to_parsing_data uu___3); - collect_binders bs; - collect_term p; - collect_term e) - | FStar_Parser_AST.IntroExists (bs, t, vs, e) -> - ((let uu___3 = - let uu___4 = - let uu___5 = - FStar_Ident.lid_of_str "FStar.Classical.Sugar" in - (false, uu___5) in - P_dep uu___4 in - add_to_parsing_data uu___3); - collect_binders bs; - collect_term t; - FStar_Compiler_List.iter collect_term vs; - collect_term e) - | FStar_Parser_AST.IntroImplies (p, q, x, e) -> - ((let uu___3 = - let uu___4 = - let uu___5 = - FStar_Ident.lid_of_str "FStar.Classical.Sugar" in - (false, uu___5) in - P_dep uu___4 in - add_to_parsing_data uu___3); - collect_term p; - collect_term q; - collect_binder x; - collect_term e) - | FStar_Parser_AST.IntroOr (b, p, q, r) -> - ((let uu___3 = - let uu___4 = - let uu___5 = - FStar_Ident.lid_of_str "FStar.Classical.Sugar" in - (false, uu___5) in - P_dep uu___4 in - add_to_parsing_data uu___3); - collect_term p; - collect_term q; - collect_term r) - | FStar_Parser_AST.IntroAnd (p, q, r, e) -> - ((let uu___3 = - let uu___4 = - let uu___5 = - FStar_Ident.lid_of_str "FStar.Classical.Sugar" in - (false, uu___5) in - P_dep uu___4 in - add_to_parsing_data uu___3); - collect_term p; - collect_term q; - collect_term r; - collect_term e) - | FStar_Parser_AST.ElimForall (bs, p, vs) -> - ((let uu___3 = - let uu___4 = - let uu___5 = - FStar_Ident.lid_of_str "FStar.Classical.Sugar" in - (false, uu___5) in - P_dep uu___4 in - add_to_parsing_data uu___3); - collect_binders bs; - collect_term p; - FStar_Compiler_List.iter collect_term vs) - | FStar_Parser_AST.ElimExists (bs, p, q, b, e) -> - ((let uu___3 = - let uu___4 = - let uu___5 = - FStar_Ident.lid_of_str "FStar.Classical.Sugar" in - (false, uu___5) in - P_dep uu___4 in - add_to_parsing_data uu___3); - collect_binders bs; - collect_term p; - collect_term q; - collect_binder b; - collect_term e) - | FStar_Parser_AST.ElimImplies (p, q, e) -> - ((let uu___3 = - let uu___4 = - let uu___5 = - FStar_Ident.lid_of_str "FStar.Classical.Sugar" in - (false, uu___5) in - P_dep uu___4 in - add_to_parsing_data uu___3); - collect_term p; - collect_term q; - collect_term e) - | FStar_Parser_AST.ElimAnd (p, q, r, x, y, e) -> - ((let uu___3 = - let uu___4 = - let uu___5 = - FStar_Ident.lid_of_str "FStar.Classical.Sugar" in - (false, uu___5) in - P_dep uu___4 in - add_to_parsing_data uu___3); - collect_term p; - collect_term q; - collect_term r; - collect_binder x; - collect_binder y; - collect_term e) - | FStar_Parser_AST.ElimOr (p, q, r, x, e, y, e') -> - ((let uu___3 = - let uu___4 = - let uu___5 = - FStar_Ident.lid_of_str "FStar.Classical.Sugar" in - (false, uu___5) in - P_dep uu___4 in - add_to_parsing_data uu___3); - collect_term p; - collect_term q; - collect_term r; - collect_binder x; - collect_binder y; - collect_term e; - collect_term e') - | FStar_Parser_AST.ListLiteral ts -> - FStar_Compiler_List.iter collect_term ts - | FStar_Parser_AST.SeqLiteral ts -> - ((let uu___3 = - let uu___4 = - let uu___5 = FStar_Ident.lid_of_str "FStar.Seq.Base" in - (false, uu___5) in - P_dep uu___4 in - add_to_parsing_data uu___3); - FStar_Compiler_List.iter collect_term ts) - and collect_patterns ps = - FStar_Compiler_List.iter collect_pattern ps - and collect_pattern p = collect_pattern' p.FStar_Parser_AST.pat - and collect_pattern' uu___1 = - match uu___1 with - | FStar_Parser_AST.PatVar (uu___2, aqual, attrs) -> - (collect_aqual aqual; - FStar_Compiler_List.iter collect_term attrs) - | FStar_Parser_AST.PatTvar (uu___2, aqual, attrs) -> - (collect_aqual aqual; - FStar_Compiler_List.iter collect_term attrs) - | FStar_Parser_AST.PatWild (aqual, attrs) -> - (collect_aqual aqual; - FStar_Compiler_List.iter collect_term attrs) - | FStar_Parser_AST.PatOp uu___2 -> () - | FStar_Parser_AST.PatConst uu___2 -> () - | FStar_Parser_AST.PatVQuote t -> collect_term t - | FStar_Parser_AST.PatApp (p, ps) -> - (collect_pattern p; collect_patterns ps) - | FStar_Parser_AST.PatName uu___2 -> () - | FStar_Parser_AST.PatList ps -> collect_patterns ps - | FStar_Parser_AST.PatOr ps -> collect_patterns ps - | FStar_Parser_AST.PatTuple (ps, uu___2) -> collect_patterns ps - | FStar_Parser_AST.PatRecord lidpats -> - FStar_Compiler_List.iter - (fun uu___2 -> - match uu___2 with | (uu___3, p) -> collect_pattern p) - lidpats - | FStar_Parser_AST.PatAscribed - (p, (t, FStar_Pervasives_Native.None)) -> - (collect_pattern p; collect_term t) - | FStar_Parser_AST.PatAscribed - (p, (t, FStar_Pervasives_Native.Some tac)) -> - (collect_pattern p; collect_term t; collect_term tac) - and collect_branches bs = - FStar_Compiler_List.iter collect_branch bs - and collect_branch uu___1 = - match uu___1 with - | (pat, t1, t2) -> - (collect_pattern pat; - FStar_Compiler_Util.iter_opt t1 collect_term; - collect_term t2) - and collect_fieldname fn = - let uu___1 = let uu___2 = FStar_Ident.nsstr fn in uu___2 <> "" in - if uu___1 - then - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Ident.ns_of_lid fn in - FStar_Ident.lid_of_ids uu___5 in - (false, uu___4) in - P_dep uu___3 in - add_to_parsing_data uu___2 - else () in - let uu___1 = FStar_Parser_Driver.parse_file filename in - match uu___1 with - | (ast, uu___2) -> - (collect_module ast; - (let pd1 = - let uu___4 = - let uu___5 = FStar_Compiler_Effect.op_Bang pd in - FStar_Compiler_List.rev uu___5 in - Mk_pd uu___4 in - let uu___4 = from_parsing_data pd1 original_map filename in - match uu___4 with - | (deps1, has_inline_for_extraction, mo_roots) -> - (pd1, deps1, has_inline_for_extraction, mo_roots)))) -let (collect_one_cache : - (dependence Prims.list * dependence Prims.list * Prims.bool) - FStar_Compiler_Util.smap FStar_Compiler_Effect.ref) - = - let uu___ = FStar_Compiler_Util.smap_create Prims.int_zero in - FStar_Compiler_Util.mk_ref uu___ -let (set_collect_one_cache : - (dependence Prims.list * dependence Prims.list * Prims.bool) - FStar_Compiler_Util.smap -> unit) - = - fun cache -> FStar_Compiler_Effect.op_Colon_Equals collect_one_cache cache -let (dep_graph_copy : dependence_graph -> dependence_graph) = - fun dep_graph -> - let uu___ = dep_graph in - match uu___ with - | Deps g -> let uu___1 = FStar_Compiler_Util.smap_copy g in Deps uu___1 -let (widen_deps : - module_name Prims.list -> - dependence_graph -> - files_for_module_name -> Prims.bool -> (Prims.bool * dependence_graph)) - = - fun friends1 -> - fun dep_graph -> - fun file_system_map -> - fun widened -> - let widened1 = FStar_Compiler_Util.mk_ref widened in - let uu___ = dep_graph in - match uu___ with - | Deps dg -> - let uu___1 = deps_empty () in - (match uu___1 with - | Deps dg' -> - let widen_one deps1 = - FStar_Compiler_List.map - (fun d -> - match d with - | PreferInterface m when - (FStar_Compiler_List.contains m friends1) && - (has_implementation file_system_map m) - -> - (FStar_Compiler_Effect.op_Colon_Equals widened1 - true; - FriendImplementation m) - | uu___2 -> d) deps1 in - (FStar_Compiler_Util.smap_fold dg - (fun filename -> - fun dep_node1 -> - fun uu___3 -> - let uu___4 = - let uu___5 = widen_one dep_node1.edges in - { edges = uu___5; color = White } in - FStar_Compiler_Util.smap_add dg' filename uu___4) - (); - (let uu___3 = FStar_Compiler_Effect.op_Bang widened1 in - (uu___3, (Deps dg'))))) -let (topological_dependences_of' : - files_for_module_name -> - dependence_graph -> - Prims.string Prims.list -> - file_name Prims.list -> - Prims.bool -> (file_name Prims.list * Prims.bool)) - = - fun file_system_map -> - fun dep_graph -> - fun interfaces_needing_inlining -> - fun root_files -> - fun widened -> - let rec all_friend_deps_1 dep_graph1 cycle uu___ filename = - match uu___ with - | (all_friends, all_files) -> - let dep_node1 = - let uu___1 = deps_try_find dep_graph1 filename in - FStar_Compiler_Util.must uu___1 in - (match dep_node1.color with - | Gray -> - failwith - "Impossible: cycle detected after cycle detection has passed" - | Black -> (all_friends, all_files) - | White -> - ((let uu___2 = FStar_Compiler_Effect.op_Bang dbg in - if uu___2 - then - let uu___3 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - showable_dependence) dep_node1.edges in - FStar_Compiler_Util.print2 - "Visiting %s: direct deps are %s\n" filename - uu___3 - else ()); - deps_add_dep dep_graph1 filename - { edges = (dep_node1.edges); color = Gray }; - (let uu___3 = - let uu___4 = - dependences_of file_system_map dep_graph1 - root_files filename in - all_friend_deps dep_graph1 cycle - (all_friends, all_files) uu___4 in - match uu___3 with - | (all_friends1, all_files1) -> - (deps_add_dep dep_graph1 filename - { edges = (dep_node1.edges); color = Black }; - (let uu___6 = FStar_Compiler_Effect.op_Bang dbg in - if uu___6 - then - FStar_Compiler_Util.print1 "Adding %s\n" - filename - else ()); - (let uu___6 = - let uu___7 = - FStar_Compiler_List.collect - (fun uu___8 -> - match uu___8 with - | FriendImplementation m -> [m] - | d -> []) dep_node1.edges in - FStar_Compiler_List.op_At uu___7 - all_friends1 in - (uu___6, (filename :: all_files1))))))) - and all_friend_deps dep_graph1 cycle all_friends filenames = - FStar_Compiler_List.fold_left - (fun all_friends1 -> - fun k -> - all_friend_deps_1 dep_graph1 (k :: cycle) all_friends1 k) - all_friends filenames in - let uu___ = all_friend_deps dep_graph [] ([], []) root_files in - match uu___ with - | (friends1, all_files_0) -> - ((let uu___2 = FStar_Compiler_Effect.op_Bang dbg in - if uu___2 - then - let uu___3 = - let uu___4 = - FStar_Compiler_Util.remove_dups - (fun x -> fun y -> x = y) friends1 in - FStar_Compiler_String.concat ", " uu___4 in - FStar_Compiler_Util.print3 - "Phase1 complete:\n\tall_files = %s\n\tall_friends=%s\n\tinterfaces_with_inlining=%s\n" - (FStar_Compiler_String.concat ", " all_files_0) uu___3 - (FStar_Compiler_String.concat ", " - interfaces_needing_inlining) - else ()); - (let uu___2 = - widen_deps friends1 dep_graph file_system_map widened in - match uu___2 with - | (widened1, dep_graph1) -> - let uu___3 = - (let uu___5 = FStar_Compiler_Effect.op_Bang dbg in - if uu___5 - then - FStar_Compiler_Util.print_string - "==============Phase2==================\n" - else ()); - all_friend_deps dep_graph1 [] ([], []) root_files in - (match uu___3 with - | (uu___4, all_files) -> - ((let uu___6 = FStar_Compiler_Effect.op_Bang dbg in - if uu___6 - then - FStar_Compiler_Util.print1 - "Phase2 complete: all_files = %s\n" - (FStar_Compiler_String.concat ", " all_files) - else ()); - (all_files, widened1))))) -let (phase1 : - files_for_module_name -> - dependence_graph -> - module_name Prims.list -> Prims.bool -> (Prims.bool * dependence_graph)) - = - fun file_system_map -> - fun dep_graph -> - fun interfaces_needing_inlining -> - fun for_extraction -> - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg in - if uu___1 - then - FStar_Compiler_Util.print_string - "==============Phase1==================\n" - else ()); - (let widened = false in - let uu___1 = (FStar_Options.cmi ()) && for_extraction in - if uu___1 - then - widen_deps interfaces_needing_inlining dep_graph file_system_map - widened - else (widened, dep_graph)) -let (topological_dependences_of : - files_for_module_name -> - dependence_graph -> - Prims.string Prims.list -> - file_name Prims.list -> - Prims.bool -> (file_name Prims.list * Prims.bool)) - = - fun file_system_map -> - fun dep_graph -> - fun interfaces_needing_inlining -> - fun root_files -> - fun for_extraction -> - let uu___ = - phase1 file_system_map dep_graph interfaces_needing_inlining - for_extraction in - match uu___ with - | (widened, dep_graph1) -> - topological_dependences_of' file_system_map dep_graph1 - interfaces_needing_inlining root_files widened -let (all_files_in_include_paths : unit -> Prims.string Prims.list) = - fun uu___ -> - let paths = FStar_Options.include_path () in - FStar_Compiler_List.collect - (fun path -> - let files = safe_readdir_for_include path in - let files1 = - FStar_Compiler_List.filter - (fun f -> - (FStar_Compiler_Util.ends_with f ".fst") || - (FStar_Compiler_Util.ends_with f ".fsti")) files in - FStar_Compiler_List.map - (fun file -> FStar_Compiler_Util.join_paths path file) files1) - paths -let (collect : - Prims.string Prims.list -> - (Prims.string -> parsing_data FStar_Pervasives_Native.option) -> - (Prims.string Prims.list * deps)) - = - fun all_cmd_line_files -> - fun get_parsing_data_from_cache -> - let all_cmd_line_files1 = - match all_cmd_line_files with - | [] -> all_files_in_include_paths () - | uu___ -> all_cmd_line_files in - let all_cmd_line_files2 = - FStar_Compiler_List.map - (fun fn -> - let uu___ = FStar_Find.find_file fn in - match uu___ with - | FStar_Pervasives_Native.None -> - let uu___1 = - FStar_Compiler_Util.format1 "File %s could not be found" - fn in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_ModuleOrFileNotFound () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) - | FStar_Pervasives_Native.Some fn1 -> fn1) all_cmd_line_files1 in - let dep_graph = deps_empty () in - let file_system_map = build_map all_cmd_line_files2 in - let interfaces_needing_inlining = FStar_Compiler_Util.mk_ref [] in - let add_interface_for_inlining l = - let l1 = lowercase_module_name l in - let uu___ = - let uu___1 = - FStar_Compiler_Effect.op_Bang interfaces_needing_inlining in - l1 :: uu___1 in - FStar_Compiler_Effect.op_Colon_Equals interfaces_needing_inlining - uu___ in - let parse_results = FStar_Compiler_Util.smap_create (Prims.of_int (40)) in - let rec discover_one file_name1 = - let uu___ = - let uu___1 = deps_try_find dep_graph file_name1 in - uu___1 = FStar_Pervasives_Native.None in - if uu___ - then - let uu___1 = - let uu___2 = - let uu___3 = FStar_Compiler_Effect.op_Bang collect_one_cache in - FStar_Compiler_Util.smap_try_find uu___3 file_name1 in - match uu___2 with - | FStar_Pervasives_Native.Some cached -> ((Mk_pd []), cached) - | FStar_Pervasives_Native.None -> - let uu___3 = - collect_one file_system_map file_name1 - get_parsing_data_from_cache in - (match uu___3 with - | (parsing_data1, deps1, needs_interface_inlining, - additional_roots) -> - (parsing_data1, - (deps1, additional_roots, needs_interface_inlining))) in - match uu___1 with - | (parsing_data1, (deps1, mo_roots, needs_interface_inlining)) -> - (if needs_interface_inlining - then add_interface_for_inlining file_name1 - else (); - FStar_Compiler_Util.smap_add parse_results file_name1 - parsing_data1; - (let deps2 = - let module_name1 = lowercase_module_name file_name1 in - let uu___4 = - (is_implementation file_name1) && - (has_interface file_system_map module_name1) in - if uu___4 - then - FStar_Compiler_List.op_At deps1 - [UseInterface module_name1] - else deps1 in - let dep_node1 = - let uu___4 = FStar_Compiler_List.unique deps2 in - { edges = uu___4; color = White } in - deps_add_dep dep_graph file_name1 dep_node1; - (let uu___5 = - FStar_Compiler_List.map - (file_of_dep file_system_map all_cmd_line_files2) - (FStar_Compiler_List.op_At deps2 mo_roots) in - FStar_Compiler_List.iter discover_one uu___5))) - else () in - profile - (fun uu___1 -> - FStar_Compiler_List.iter discover_one all_cmd_line_files2) - "FStar.Parser.Dep.discover"; - (let cycle_detected dep_graph1 cycle filename = - FStar_Compiler_Util.print1 - "The cycle contains a subset of the modules in:\n%s \n" - (FStar_Compiler_String.concat "\n`used by` " cycle); - (let fn = "dep.graph" in - with_file_outchannel fn - (fun outc -> print_graph outc fn dep_graph1); - FStar_Compiler_Util.print_string "\n"; - (let uu___4 = - let uu___5 = - let uu___6 = - FStar_Compiler_Util.format1 - "Recursive dependency on module %s." filename in - FStar_Errors_Msg.text uu___6 in - let uu___6 = - let uu___7 = - FStar_Errors_Msg.text - "A full dependency graph was written to dep.graph." in - [uu___7] in - uu___5 :: uu___6 in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_CyclicDependence () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___4))) in - let full_cycle_detection all_command_line_files file_system_map1 = - let dep_graph1 = dep_graph_copy dep_graph in - let mo_files = FStar_Compiler_Util.mk_ref [] in - let rec aux cycle filename = - let node = - let uu___1 = deps_try_find dep_graph1 filename in - match uu___1 with - | FStar_Pervasives_Native.Some node1 -> node1 - | FStar_Pervasives_Native.None -> - let uu___2 = - FStar_Compiler_Util.format1 - "Impossible: Failed to find dependencies of %s" filename in - failwith uu___2 in - let direct_deps = - FStar_Compiler_List.collect - (fun x -> - match x with - | UseInterface f -> - let uu___1 = - implementation_of_internal file_system_map1 f in - (match uu___1 with - | FStar_Pervasives_Native.None -> [x] - | FStar_Pervasives_Native.Some fn when fn = filename - -> [x] - | uu___2 -> [x; UseImplementation f]) - | PreferInterface f -> - let uu___1 = - implementation_of_internal file_system_map1 f in - (match uu___1 with - | FStar_Pervasives_Native.None -> [x] - | FStar_Pervasives_Native.Some fn when fn = filename - -> [x] - | uu___2 -> [x; UseImplementation f]) - | uu___1 -> [x]) node.edges in - match node.color with - | Gray -> cycle_detected dep_graph1 cycle filename - | Black -> () - | White -> - (deps_add_dep dep_graph1 filename - { edges = direct_deps; color = Gray }; - (let uu___3 = - dependences_of file_system_map1 dep_graph1 - all_command_line_files filename in - FStar_Compiler_List.iter (fun k -> aux (k :: cycle) k) - uu___3); - deps_add_dep dep_graph1 filename - { edges = direct_deps; color = Black }; - (let uu___4 = is_interface filename in - if uu___4 - then - let uu___5 = - let uu___6 = lowercase_module_name filename in - implementation_of_internal file_system_map1 uu___6 in - FStar_Compiler_Util.iter_opt uu___5 - (fun impl -> - if - Prims.op_Negation - (FStar_Compiler_List.contains impl - all_command_line_files) - then - let uu___6 = - let uu___7 = - FStar_Compiler_Effect.op_Bang mo_files in - impl :: uu___7 in - FStar_Compiler_Effect.op_Colon_Equals mo_files - uu___6 - else ()) - else ())) in - FStar_Compiler_List.iter (aux []) all_command_line_files; - (let uu___2 = FStar_Compiler_Effect.op_Bang mo_files in - FStar_Compiler_List.iter (aux []) uu___2) in - full_cycle_detection all_cmd_line_files2 file_system_map; - FStar_Compiler_List.iter - (fun f -> - let m = lowercase_module_name f in - FStar_Options.add_verify_module m) all_cmd_line_files2; - (let inlining_ifaces = - FStar_Compiler_Effect.op_Bang interfaces_needing_inlining in - let uu___3 = - profile - (fun uu___4 -> - let uu___5 = - let uu___6 = FStar_Options.codegen () in - uu___6 <> FStar_Pervasives_Native.None in - topological_dependences_of file_system_map dep_graph - inlining_ifaces all_cmd_line_files2 uu___5) - "FStar.Parser.Dep.topological_dependences_of" in - match uu___3 with - | (all_files, uu___4) -> - ((let uu___6 = FStar_Compiler_Effect.op_Bang dbg in - if uu___6 - then - FStar_Compiler_Util.print1 - "Interfaces needing inlining: %s\n" - (FStar_Compiler_String.concat ", " inlining_ifaces) - else ()); - (all_files, - (mk_deps dep_graph file_system_map all_cmd_line_files2 - all_files inlining_ifaces parse_results))))) -let (deps_of : deps -> Prims.string -> Prims.string Prims.list) = - fun deps1 -> - fun f -> - dependences_of deps1.file_system_map deps1.dep_graph - deps1.cmd_line_files f -let (deps_of_modul : deps -> module_name -> module_name Prims.list) = - fun deps1 -> - fun m -> - let aux fopt = - let uu___ = - FStar_Compiler_Util.map_option - (fun f -> - let uu___1 = deps_of deps1 f in - FStar_Compiler_List.map module_name_of_file uu___1) fopt in - FStar_Compiler_Util.dflt [] uu___ in - let uu___ = - let uu___1 = - FStar_Compiler_Util.smap_try_find deps1.file_system_map - (FStar_Compiler_String.lowercase m) in - FStar_Compiler_Util.map_option - (fun uu___2 -> - match uu___2 with - | (intf_opt, impl_opt) -> - let uu___3 = - let uu___4 = aux intf_opt in - let uu___5 = aux impl_opt in - FStar_Compiler_List.op_At uu___4 uu___5 in - FStar_Compiler_Util.remove_dups (fun x -> fun y -> x = y) - uu___3) uu___1 in - FStar_Compiler_Util.dflt [] uu___ -let (print_digest : (Prims.string * Prims.string) Prims.list -> Prims.string) - = - fun dig -> - let uu___ = - FStar_Compiler_List.map - (fun uu___1 -> - match uu___1 with - | (m, d) -> - let uu___2 = FStar_Compiler_Util.base64_encode d in - FStar_Compiler_Util.format2 "%s:%s" m uu___2) dig in - FStar_Compiler_String.concat "\n" uu___ -let (print_make : FStar_Compiler_Util.out_channel -> deps -> unit) = - fun outc -> - fun deps1 -> - let file_system_map = deps1.file_system_map in - let all_cmd_line_files = deps1.cmd_line_files in - let deps2 = deps1.dep_graph in - let keys = deps_keys deps2 in - FStar_Compiler_List.iter - (fun f -> - let dep_node1 = - let uu___ = deps_try_find deps2 f in - FStar_Compiler_Option.get uu___ in - let files = - FStar_Compiler_List.map - (file_of_dep file_system_map all_cmd_line_files) - dep_node1.edges in - let files1 = - FStar_Compiler_List.map - (fun s -> FStar_Compiler_Util.replace_chars s 32 "\\ ") files in - FStar_Compiler_Util.print2 "%s: %s\n\n" f - (FStar_Compiler_String.concat " " files1)) keys -let (print_raw : FStar_Compiler_Util.out_channel -> deps -> unit) = - fun outc -> - fun deps1 -> - let uu___ = deps1.dep_graph in - match uu___ with - | Deps deps2 -> - let uu___1 = - let uu___2 = - FStar_Compiler_Util.smap_fold deps2 - (fun k -> - fun dep_node1 -> - fun out -> - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Compiler_List.map dep_to_string - dep_node1.edges in - FStar_Compiler_String.concat ";\n\t" uu___5 in - FStar_Compiler_Util.format2 "%s -> [\n\t%s\n] " k - uu___4 in - uu___3 :: out) [] in - FStar_Compiler_String.concat ";;\n" uu___2 in - FStar_Compiler_Util.fprint outc "%s\n" [uu___1] -let (print_full : FStar_Compiler_Util.out_channel -> deps -> unit) = - fun outc -> - fun deps1 -> - let sort_output_files orig_output_file_map = - let order = FStar_Compiler_Util.mk_ref [] in - let remaining_output_files = - FStar_Compiler_Util.smap_copy orig_output_file_map in - let visited_other_modules = - FStar_Compiler_Util.smap_create (Prims.of_int (41)) in - let should_visit lc_module_name = - (let uu___ = - FStar_Compiler_Util.smap_try_find remaining_output_files - lc_module_name in - FStar_Compiler_Option.isSome uu___) || - (let uu___ = - FStar_Compiler_Util.smap_try_find visited_other_modules - lc_module_name in - FStar_Compiler_Option.isNone uu___) in - let mark_visiting lc_module_name = - let ml_file_opt = - FStar_Compiler_Util.smap_try_find remaining_output_files - lc_module_name in - FStar_Compiler_Util.smap_remove remaining_output_files - lc_module_name; - FStar_Compiler_Util.smap_add visited_other_modules lc_module_name - true; - ml_file_opt in - let emit_output_file_opt ml_file_opt = - match ml_file_opt with - | FStar_Pervasives_Native.None -> () - | FStar_Pervasives_Native.Some ml_file -> - let uu___ = - let uu___1 = FStar_Compiler_Effect.op_Bang order in ml_file - :: uu___1 in - FStar_Compiler_Effect.op_Colon_Equals order uu___ in - let rec aux uu___ = - match uu___ with - | [] -> () - | lc_module_name::modules_to_extract -> - let visit_file file_opt = - match file_opt with - | FStar_Pervasives_Native.None -> () - | FStar_Pervasives_Native.Some file_name1 -> - let uu___1 = deps_try_find deps1.dep_graph file_name1 in - (match uu___1 with - | FStar_Pervasives_Native.None -> - let uu___2 = - FStar_Compiler_Util.format2 - "Impossible: module %s: %s not found" - lc_module_name file_name1 in - failwith uu___2 - | FStar_Pervasives_Native.Some - { edges = immediate_deps; color = uu___2;_} -> - let immediate_deps1 = - FStar_Compiler_List.map - (fun x -> - FStar_Compiler_String.lowercase - (module_name_of_dep x)) immediate_deps in - aux immediate_deps1) in - ((let uu___2 = should_visit lc_module_name in - if uu___2 - then - let ml_file_opt = mark_visiting lc_module_name in - ((let uu___4 = implementation_of deps1 lc_module_name in - visit_file uu___4); - (let uu___5 = interface_of deps1 lc_module_name in - visit_file uu___5); - emit_output_file_opt ml_file_opt) - else ()); - aux modules_to_extract) in - let all_extracted_modules = - FStar_Compiler_Util.smap_keys orig_output_file_map in - aux all_extracted_modules; - (let uu___1 = FStar_Compiler_Effect.op_Bang order in - FStar_Compiler_List.rev uu___1) in - let sb = - let uu___ = FStar_BigInt.of_int_fs (Prims.of_int (10000)) in - FStar_StringBuffer.create uu___ in - let pr str = let uu___ = FStar_StringBuffer.add str sb in () in - let print_entry target first_dep all_deps = - pr target; pr ": "; pr first_dep; pr "\\\n\t"; pr all_deps; pr "\n\n" in - let keys = deps_keys deps1.dep_graph in - let no_fstar_stubs_file s = - let s1 = "FStar.Stubs." in - let s2 = "FStar." in - let l1 = FStar_Compiler_String.length s1 in - let uu___ = - ((FStar_Compiler_String.length s) >= l1) && - (let uu___1 = FStar_Compiler_String.substring s Prims.int_zero l1 in - uu___1 = s1) in - if uu___ - then - let uu___1 = - FStar_Compiler_String.substring s l1 - ((FStar_Compiler_String.length s) - l1) in - Prims.strcat s2 uu___1 - else s in - let output_file ext fst_file = - let basename = - let uu___ = - let uu___1 = FStar_Compiler_Util.basename fst_file in - check_and_strip_suffix uu___1 in - FStar_Compiler_Option.get uu___ in - let basename1 = no_fstar_stubs_file basename in - let ml_base_name = FStar_Compiler_Util.replace_chars basename1 46 "_" in - FStar_Options.prepend_output_dir (Prims.strcat ml_base_name ext) in - let norm_path s = - FStar_Compiler_Util.replace_chars - (FStar_Compiler_Util.replace_chars s 92 "/") 32 "\\ " in - let output_fs_file f = - let uu___ = output_file ".fs" f in norm_path uu___ in - let output_ml_file f = - let uu___ = output_file ".ml" f in norm_path uu___ in - let output_krml_file f = - let uu___ = output_file ".krml" f in norm_path uu___ in - let output_cmx_file f = - let uu___ = output_file ".cmx" f in norm_path uu___ in - let cache_file f = let uu___ = cache_file_name f in norm_path uu___ in - let uu___ = - phase1 deps1.file_system_map deps1.dep_graph - deps1.interfaces_with_inlining true in - match uu___ with - | (widened, dep_graph) -> - let all_checked_files = - FStar_Compiler_List.fold_left - (fun all_checked_files1 -> - fun file_name1 -> - let process_one_key uu___1 = - let dep_node1 = - let uu___2 = deps_try_find deps1.dep_graph file_name1 in - FStar_Compiler_Option.get uu___2 in - let uu___2 = - let uu___3 = is_interface file_name1 in - if uu___3 - then - (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None) - else - (let uu___5 = - let uu___6 = lowercase_module_name file_name1 in - interface_of deps1 uu___6 in - match uu___5 with - | FStar_Pervasives_Native.None -> - (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None) - | FStar_Pervasives_Native.Some iface -> - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - deps_try_find deps1.dep_graph iface in - FStar_Compiler_Option.get uu___9 in - uu___8.edges in - FStar_Pervasives_Native.Some uu___7 in - ((FStar_Pervasives_Native.Some iface), uu___6)) in - match uu___2 with - | (iface_fn, iface_deps) -> - let iface_deps1 = - FStar_Compiler_Util.map_opt iface_deps - (FStar_Compiler_List.filter - (fun iface_dep -> - let uu___3 = - FStar_Compiler_Util.for_some - (dep_subsumed_by iface_dep) - dep_node1.edges in - Prims.op_Negation uu___3)) in - let norm_f = norm_path file_name1 in - let files = - FStar_Compiler_List.map - (file_of_dep_aux true deps1.file_system_map - deps1.cmd_line_files) dep_node1.edges in - let files1 = - match iface_deps1 with - | FStar_Pervasives_Native.None -> files - | FStar_Pervasives_Native.Some iface_deps2 -> - let iface_files = - FStar_Compiler_List.map - (file_of_dep_aux true - deps1.file_system_map - deps1.cmd_line_files) iface_deps2 in - FStar_Compiler_Util.remove_dups - (fun x -> fun y -> x = y) - (FStar_Compiler_List.op_At files iface_files) in - let files2 = - if FStar_Compiler_Util.is_some iface_fn - then - let iface_fn1 = - FStar_Compiler_Util.must iface_fn in - let uu___3 = - FStar_Compiler_List.filter - (fun f -> f <> iface_fn1) files1 in - let uu___4 = cache_file_name iface_fn1 in uu___4 - :: uu___3 - else files1 in - let files3 = - FStar_Compiler_List.map norm_path files2 in - let files4 = - FStar_Compiler_String.concat "\\\n\t" files3 in - let cache_file_name1 = cache_file file_name1 in - let all_checked_files2 = - let uu___3 = - let uu___4 = - let uu___5 = module_name_of_file file_name1 in - FStar_Options.should_be_already_cached uu___5 in - Prims.op_Negation uu___4 in - if uu___3 - then - (print_entry cache_file_name1 norm_f files4; - cache_file_name1 - :: - all_checked_files1) - else all_checked_files1 in - let uu___3 = - let uu___4 = FStar_Options.cmi () in - if uu___4 - then - profile - (fun uu___5 -> - let uu___6 = dep_graph_copy dep_graph in - topological_dependences_of' - deps1.file_system_map uu___6 - deps1.interfaces_with_inlining - [file_name1] widened) - "FStar.Parser.Dep.topological_dependences_of_2" - else - (let maybe_widen_deps f_deps = - FStar_Compiler_List.map - (fun dep -> - file_of_dep_aux false - deps1.file_system_map - deps1.cmd_line_files dep) f_deps in - let fst_files = - maybe_widen_deps dep_node1.edges in - let fst_files_from_iface = - match iface_deps1 with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some iface_deps2 -> - maybe_widen_deps iface_deps2 in - let uu___6 = - FStar_Compiler_Util.remove_dups - (fun x -> fun y -> x = y) - (FStar_Compiler_List.op_At fst_files - fst_files_from_iface) in - (uu___6, false)) in - (match uu___3 with - | (all_fst_files_dep, widened1) -> - let all_checked_fst_dep_files = - FStar_Compiler_List.map cache_file - all_fst_files_dep in - let all_checked_fst_dep_files_string = - FStar_Compiler_String.concat " \\\n\t" - all_checked_fst_dep_files in - ((let uu___5 = is_implementation file_name1 in - if uu___5 - then - ((let uu___7 = - (FStar_Options.cmi ()) && widened1 in - if uu___7 - then - let mname = - lowercase_module_name file_name1 in - ((let uu___9 = - output_ml_file file_name1 in - print_entry uu___9 cache_file_name1 - all_checked_fst_dep_files_string); - (let uu___10 = - FStar_Options.should_extract mname - FStar_Options.FSharp in - if uu___10 - then - let uu___11 = - output_fs_file file_name1 in - print_entry uu___11 - cache_file_name1 - all_checked_fst_dep_files_string - else ()); - (let uu___10 = - output_krml_file file_name1 in - print_entry uu___10 cache_file_name1 - all_checked_fst_dep_files_string)) - else - (let mname = - lowercase_module_name file_name1 in - (let uu___10 = - output_ml_file file_name1 in - print_entry uu___10 cache_file_name1 - ""); - (let uu___11 = - FStar_Options.should_extract mname - FStar_Options.FSharp in - if uu___11 - then - let uu___12 = - output_fs_file file_name1 in - print_entry uu___12 - cache_file_name1 "" - else ()); - (let uu___11 = - output_krml_file file_name1 in - print_entry uu___11 cache_file_name1 - ""))); - (let cmx_files = - let extracted_fst_files = - FStar_Compiler_List.filter - (fun df -> - (let uu___7 = - lowercase_module_name df in - let uu___8 = - lowercase_module_name - file_name1 in - uu___7 <> uu___8) && - (let uu___7 = - lowercase_module_name df in - FStar_Options.should_extract - uu___7 FStar_Options.OCaml)) - all_fst_files_dep in - FStar_Compiler_List.map output_cmx_file - extracted_fst_files in - let uu___7 = - let uu___8 = - lowercase_module_name file_name1 in - FStar_Options.should_extract uu___8 - FStar_Options.OCaml in - if uu___7 - then - let cmx_files1 = - FStar_Compiler_String.concat "\\\n\t" - cmx_files in - let uu___8 = output_cmx_file file_name1 in - let uu___9 = output_ml_file file_name1 in - print_entry uu___8 uu___9 cmx_files1 - else ())) - else - (let uu___7 = - (let uu___8 = - let uu___9 = - lowercase_module_name file_name1 in - has_implementation - deps1.file_system_map uu___9 in - Prims.op_Negation uu___8) && - (is_interface file_name1) in - if uu___7 - then - let uu___8 = - (FStar_Options.cmi ()) && - (widened1 || true) in - (if uu___8 - then - let uu___9 = - output_krml_file file_name1 in - print_entry uu___9 cache_file_name1 - all_checked_fst_dep_files_string - else - (let uu___10 = - output_krml_file file_name1 in - print_entry uu___10 cache_file_name1 - "")) - else ())); - all_checked_files2)) in - profile process_one_key "FStar.Parser.Dep.process_one_key") - [] keys in - let all_fst_files = - let uu___1 = FStar_Compiler_List.filter is_implementation keys in - FStar_Compiler_Util.sort_with FStar_Compiler_String.compare - uu___1 in - let all_fsti_files = - let uu___1 = FStar_Compiler_List.filter is_interface keys in - FStar_Compiler_Util.sort_with FStar_Compiler_String.compare - uu___1 in - let all_ml_files = - let ml_file_map = - FStar_Compiler_Util.smap_create (Prims.of_int (41)) in - FStar_Compiler_List.iter - (fun fst_file -> - let mname = lowercase_module_name fst_file in - let uu___2 = - FStar_Options.should_extract mname FStar_Options.OCaml in - if uu___2 - then - let uu___3 = output_ml_file fst_file in - FStar_Compiler_Util.smap_add ml_file_map mname uu___3 - else ()) all_fst_files; - sort_output_files ml_file_map in - let all_fs_files = - let fs_file_map = - FStar_Compiler_Util.smap_create (Prims.of_int (41)) in - FStar_Compiler_List.iter - (fun fst_file -> - let mname = lowercase_module_name fst_file in - let uu___2 = - FStar_Options.should_extract mname FStar_Options.FSharp in - if uu___2 - then - let uu___3 = output_fs_file fst_file in - FStar_Compiler_Util.smap_add fs_file_map mname uu___3 - else ()) all_fst_files; - sort_output_files fs_file_map in - let all_krml_files = - let krml_file_map = - FStar_Compiler_Util.smap_create (Prims.of_int (41)) in - FStar_Compiler_List.iter - (fun fst_file -> - let mname = lowercase_module_name fst_file in - let uu___2 = - FStar_Options.should_extract mname FStar_Options.Krml in - if uu___2 - then - let uu___3 = output_krml_file fst_file in - FStar_Compiler_Util.smap_add krml_file_map mname uu___3 - else ()) keys; - sort_output_files krml_file_map in - let print_all tag files = - pr tag; - pr "=\\\n\t"; - FStar_Compiler_List.iter - (fun f -> pr (norm_path f); pr " \\\n\t") files; - pr "\n" in - (FStar_Compiler_List.iter - (fun fsti -> - let mn = lowercase_module_name fsti in - let range_of_file fsti1 = - let r = - FStar_Compiler_Range_Ops.set_file_of_range - FStar_Compiler_Range_Type.dummyRange fsti1 in - let uu___2 = FStar_Compiler_Range_Type.def_range r in - FStar_Compiler_Range_Type.set_use_range r uu___2 in - let uu___2 = - let uu___3 = has_implementation deps1.file_system_map mn in - Prims.op_Negation uu___3 in - if uu___2 - then - let uu___3 = range_of_file fsti in - let uu___4 = - let uu___5 = module_name_of_file fsti in - FStar_Compiler_Util.format1 - "Interface %s is admitted without an implementation" - uu___5 in - FStar_Errors.log_issue FStar_Class_HasRange.hasRange_range - uu___3 FStar_Errors_Codes.Warning_WarnOnUse () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4) - else ()) all_fsti_files; - print_all "ALL_FST_FILES" all_fst_files; - print_all "ALL_FSTI_FILES" all_fsti_files; - print_all "ALL_CHECKED_FILES" all_checked_files; - print_all "ALL_FS_FILES" all_fs_files; - print_all "ALL_ML_FILES" all_ml_files; - print_all "ALL_KRML_FILES" all_krml_files; - FStar_StringBuffer.output_channel outc sb) -let (do_print : - FStar_Compiler_Util.out_channel -> Prims.string -> deps -> unit) = - fun outc -> - fun fn -> - fun deps1 -> - let pref uu___ = - (let uu___2 = - let uu___3 = - FStar_Compiler_Effect.op_Bang FStar_Options._version in - [uu___3] in - FStar_Compiler_Util.fprint outc - "# This .depend was generated by F* %s\n" uu___2); - (let uu___3 = - let uu___4 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_string) - FStar_Compiler_Util.exec_name in - [uu___4] in - FStar_Compiler_Util.fprint outc "# Executable: %s\n" uu___3); - (let uu___4 = - let uu___5 = FStar_Compiler_Effect.op_Bang FStar_Options._commit in - [uu___5] in - FStar_Compiler_Util.fprint outc "# Hash: %s\n" uu___4); - (let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = FStar_Compiler_Util.getcwd () in - FStar_Compiler_Util.normalize_file_path uu___8 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_string) uu___7 in - [uu___6] in - FStar_Compiler_Util.fprint outc "# Running in directory %s\n" - uu___5); - (let uu___6 = - let uu___7 = - let uu___8 = FStar_Compiler_Util.get_cmd_args () in - FStar_Class_Show.show - (FStar_Class_Show.show_list - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_string)) uu___8 in - [uu___7] in - FStar_Compiler_Util.fprint outc - "# Command line arguments: \"%s\"\n" uu___6); - FStar_Compiler_Util.fprint outc "\n" [] in - let uu___ = FStar_Options.dep () in - match uu___ with - | FStar_Pervasives_Native.Some "make" -> - (pref (); print_make outc deps1) - | FStar_Pervasives_Native.Some "full" -> - (pref (); - profile (fun uu___2 -> print_full outc deps1) - "FStarC.Parser.Deps.print_full_deps") - | FStar_Pervasives_Native.Some "graph" -> - print_graph outc fn deps1.dep_graph - | FStar_Pervasives_Native.Some "raw" -> print_raw outc deps1 - | FStar_Pervasives_Native.Some uu___1 -> - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_UnknownToolForDep () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic "unknown tool for --dep\n") - | FStar_Pervasives_Native.None -> () -let (do_print_stdout : deps -> unit) = - fun deps1 -> do_print FStar_Compiler_Util.stdout "" deps1 -let (do_print_file : deps -> Prims.string -> unit) = - fun deps1 -> - fun fn -> with_file_outchannel fn (fun outc -> do_print outc fn deps1) -let (print : deps -> unit) = - fun deps1 -> - let uu___ = FStar_Options.output_deps_to () in - match uu___ with - | FStar_Pervasives_Native.Some s -> do_print_file deps1 s - | FStar_Pervasives_Native.None when - let uu___1 = FStar_Options.dep () in - uu___1 = (FStar_Pervasives_Native.Some "graph") -> - do_print_file deps1 "dep.graph" - | FStar_Pervasives_Native.None -> do_print_stdout deps1 -let (module_has_interface : deps -> FStar_Ident.lident -> Prims.bool) = - fun deps1 -> - fun module_name1 -> - let uu___ = - let uu___1 = FStar_Ident.string_of_lid module_name1 in - FStar_Compiler_String.lowercase uu___1 in - has_interface deps1.file_system_map uu___ -let (deps_has_implementation : deps -> FStar_Ident.lident -> Prims.bool) = - fun deps1 -> - fun module_name1 -> - let m = - let uu___ = FStar_Ident.string_of_lid module_name1 in - FStar_Compiler_String.lowercase uu___ in - FStar_Compiler_Util.for_some - (fun f -> - (is_implementation f) && - (let uu___ = - let uu___1 = module_name_of_file f in - FStar_Compiler_String.lowercase uu___1 in - uu___ = m)) deps1.all_files \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Parser_Driver.ml b/ocaml/fstar-lib/generated/FStar_Parser_Driver.ml deleted file mode 100644 index a47c92571a5..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Parser_Driver.ml +++ /dev/null @@ -1,110 +0,0 @@ -open Prims -let (is_cache_file : Prims.string -> Prims.bool) = - fun fn -> - let uu___ = FStar_Compiler_Util.get_file_extension fn in uu___ = ".cache" -type fragment = - | Empty - | Modul of FStar_Parser_AST.modul - | Decls of FStar_Parser_AST.decl Prims.list - | DeclsWithContent of (FStar_Parser_AST.decl * - FStar_Parser_ParseIt.code_fragment) Prims.list -let (uu___is_Empty : fragment -> Prims.bool) = - fun projectee -> match projectee with | Empty -> true | uu___ -> false -let (uu___is_Modul : fragment -> Prims.bool) = - fun projectee -> match projectee with | Modul _0 -> true | uu___ -> false -let (__proj__Modul__item___0 : fragment -> FStar_Parser_AST.modul) = - fun projectee -> match projectee with | Modul _0 -> _0 -let (uu___is_Decls : fragment -> Prims.bool) = - fun projectee -> match projectee with | Decls _0 -> true | uu___ -> false -let (__proj__Decls__item___0 : fragment -> FStar_Parser_AST.decl Prims.list) - = fun projectee -> match projectee with | Decls _0 -> _0 -let (uu___is_DeclsWithContent : fragment -> Prims.bool) = - fun projectee -> - match projectee with | DeclsWithContent _0 -> true | uu___ -> false -let (__proj__DeclsWithContent__item___0 : - fragment -> - (FStar_Parser_AST.decl * FStar_Parser_ParseIt.code_fragment) Prims.list) - = fun projectee -> match projectee with | DeclsWithContent _0 -> _0 -let (parse_fragment : - FStar_Parser_ParseIt.lang_opts -> - FStar_Parser_ParseIt.input_frag -> fragment) - = - fun lang_opt -> - fun frag -> - let uu___ = - FStar_Parser_ParseIt.parse lang_opt - (FStar_Parser_ParseIt.Toplevel frag) in - match uu___ with - | FStar_Parser_ParseIt.ASTFragment (FStar_Pervasives.Inl modul, uu___1) - -> Modul modul - | FStar_Parser_ParseIt.ASTFragment (FStar_Pervasives.Inr [], uu___1) -> - Empty - | FStar_Parser_ParseIt.ASTFragment (FStar_Pervasives.Inr decls, uu___1) - -> Decls decls - | FStar_Parser_ParseIt.IncrementalFragment (decls, uu___1, uu___2) -> - DeclsWithContent decls - | FStar_Parser_ParseIt.ParseError (e, msg, r) -> - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r e () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic msg) - | FStar_Parser_ParseIt.Term uu___1 -> - failwith - "Impossible: parsing a Toplevel always results in an ASTFragment" -let (maybe_dump_module : FStar_Parser_AST.modul -> unit) = - fun m -> - match m with - | FStar_Parser_AST.Module (l, ds) -> - let uu___ = - let uu___1 = FStar_Ident.string_of_lid l in - FStar_Options.dump_module uu___1 in - if uu___ - then - let uu___1 = FStar_Ident.string_of_lid l in - let uu___2 = - let uu___3 = - FStar_Compiler_List.map - (FStar_Class_Show.show FStar_Parser_AST.showable_decl) ds in - FStar_Compiler_String.concat "\n" uu___3 in - FStar_Compiler_Util.print2 "Parsed module %s\n%s\n" uu___1 uu___2 - else () - | FStar_Parser_AST.Interface (l, ds, uu___) -> - let uu___1 = - let uu___2 = FStar_Ident.string_of_lid l in - FStar_Options.dump_module uu___2 in - if uu___1 - then - let uu___2 = FStar_Ident.string_of_lid l in - let uu___3 = - let uu___4 = - FStar_Compiler_List.map - (FStar_Class_Show.show FStar_Parser_AST.showable_decl) ds in - FStar_Compiler_String.concat "\n" uu___4 in - FStar_Compiler_Util.print2 "Parsed module %s\n%s\n" uu___2 uu___3 - else () -let (parse_file : - Prims.string -> - (FStar_Parser_AST.file * (Prims.string * FStar_Compiler_Range_Type.range) - Prims.list)) - = - fun fn -> - let uu___ = - FStar_Parser_ParseIt.parse FStar_Pervasives_Native.None - (FStar_Parser_ParseIt.Filename fn) in - match uu___ with - | FStar_Parser_ParseIt.ASTFragment (FStar_Pervasives.Inl ast, comments) - -> (ast, comments) - | FStar_Parser_ParseIt.ASTFragment (FStar_Pervasives.Inr uu___1, uu___2) - -> - let msg = FStar_Compiler_Util.format1 "%s: expected a module\n" fn in - let r = FStar_Compiler_Range_Type.dummyRange in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_ModuleExpected () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic msg) - | FStar_Parser_ParseIt.ParseError (e, msg, r) -> - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r e () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic msg) - | FStar_Parser_ParseIt.Term uu___1 -> - failwith - "Impossible: parsing a Filename always results in an ASTFragment" \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Parser_ToDocument.ml b/ocaml/fstar-lib/generated/FStar_Parser_ToDocument.ml deleted file mode 100644 index 3fb0f40256b..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Parser_ToDocument.ml +++ /dev/null @@ -1,5075 +0,0 @@ -open Prims -let (maybe_unthunk : FStar_Parser_AST.term -> FStar_Parser_AST.term) = - fun t -> - match t.FStar_Parser_AST.tm with - | FStar_Parser_AST.Abs (uu___::[], body) -> body - | uu___ -> t -let (min : Prims.int -> Prims.int -> Prims.int) = - fun x -> fun y -> if x > y then y else x -let (max : Prims.int -> Prims.int -> Prims.int) = - fun x -> fun y -> if x > y then x else y -let map_rev : 'a 'b . ('a -> 'b) -> 'a Prims.list -> 'b Prims.list = - fun f -> - fun l -> - let rec aux l1 acc = - match l1 with - | [] -> acc - | x::xs -> - let uu___ = let uu___1 = f x in uu___1 :: acc in aux xs uu___ in - aux l [] -let map_if_all : - 'a 'b . - ('a -> 'b FStar_Pervasives_Native.option) -> - 'a Prims.list -> 'b Prims.list FStar_Pervasives_Native.option - = - fun f -> - fun l -> - let rec aux l1 acc = - match l1 with - | [] -> acc - | x::xs -> - let uu___ = f x in - (match uu___ with - | FStar_Pervasives_Native.Some r -> aux xs (r :: acc) - | FStar_Pervasives_Native.None -> []) in - let r = aux l [] in - if (FStar_Compiler_List.length l) = (FStar_Compiler_List.length r) - then FStar_Pervasives_Native.Some r - else FStar_Pervasives_Native.None -let rec all : 'a . ('a -> Prims.bool) -> 'a Prims.list -> Prims.bool = - fun f -> - fun l -> - match l with - | [] -> true - | x::xs -> let uu___ = f x in if uu___ then all f xs else false -let (all1_explicit : - (FStar_Parser_AST.term * FStar_Parser_AST.imp) Prims.list -> Prims.bool) = - fun args -> - (Prims.op_Negation (FStar_Compiler_List.isEmpty args)) && - (FStar_Compiler_Util.for_all - (fun uu___ -> - match uu___ with - | (uu___1, FStar_Parser_AST.Nothing) -> true - | uu___1 -> false) args) -let (str : Prims.string -> FStar_Pprint.document) = - fun s -> FStar_Pprint.doc_of_string s -let default_or_map : - 'uuuuu 'uuuuu1 . - 'uuuuu -> - ('uuuuu1 -> 'uuuuu) -> 'uuuuu1 FStar_Pervasives_Native.option -> 'uuuuu - = - fun n -> - fun f -> - fun x -> - match x with - | FStar_Pervasives_Native.None -> n - | FStar_Pervasives_Native.Some x' -> f x' -let (prefix2 : - FStar_Pprint.document -> FStar_Pprint.document -> FStar_Pprint.document) = - fun prefix_ -> - fun body -> - FStar_Pprint.prefix (Prims.of_int (2)) Prims.int_one prefix_ body -let (prefix2_nonempty : - FStar_Pprint.document -> FStar_Pprint.document -> FStar_Pprint.document) = - fun prefix_ -> - fun body -> - if body = FStar_Pprint.empty then prefix_ else prefix2 prefix_ body -let (op_Hat_Slash_Plus_Hat : - FStar_Pprint.document -> FStar_Pprint.document -> FStar_Pprint.document) = - fun prefix_ -> fun body -> prefix2 prefix_ body -let (jump2 : FStar_Pprint.document -> FStar_Pprint.document) = - fun body -> FStar_Pprint.jump (Prims.of_int (2)) Prims.int_one body -let (infix2 : - FStar_Pprint.document -> - FStar_Pprint.document -> FStar_Pprint.document -> FStar_Pprint.document) - = FStar_Pprint.infix (Prims.of_int (2)) Prims.int_one -let (infix0 : - FStar_Pprint.document -> - FStar_Pprint.document -> FStar_Pprint.document -> FStar_Pprint.document) - = FStar_Pprint.infix Prims.int_zero Prims.int_one -let (break1 : FStar_Pprint.document) = FStar_Pprint.break_ Prims.int_one -let separate_break_map : - 'uuuuu . - FStar_Pprint.document -> - ('uuuuu -> FStar_Pprint.document) -> - 'uuuuu Prims.list -> FStar_Pprint.document - = - fun sep -> - fun f -> - fun l -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Pprint.op_Hat_Hat sep break1 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___2 in - FStar_Pprint.separate_map uu___1 f l in - FStar_Pprint.group uu___ -let precede_break_separate_map : - 'uuuuu . - FStar_Pprint.document -> - FStar_Pprint.document -> - ('uuuuu -> FStar_Pprint.document) -> - 'uuuuu Prims.list -> FStar_Pprint.document - = - fun prec -> - fun sep -> - fun f -> - fun l -> - let uu___ = - let uu___1 = FStar_Pprint.op_Hat_Hat prec FStar_Pprint.space in - let uu___2 = let uu___3 = FStar_Compiler_List.hd l in f uu___3 in - FStar_Pprint.precede uu___1 uu___2 in - let uu___1 = - let uu___2 = FStar_Compiler_List.tl l in - FStar_Pprint.concat_map - (fun x -> - let uu___3 = - let uu___4 = - let uu___5 = f x in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___5 in - FStar_Pprint.op_Hat_Hat sep uu___4 in - FStar_Pprint.op_Hat_Hat break1 uu___3) uu___2 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 -let concat_break_map : - 'uuuuu . - ('uuuuu -> FStar_Pprint.document) -> - 'uuuuu Prims.list -> FStar_Pprint.document - = - fun f -> - fun l -> - let uu___ = - FStar_Pprint.concat_map - (fun x -> let uu___1 = f x in FStar_Pprint.op_Hat_Hat uu___1 break1) - l in - FStar_Pprint.group uu___ -let (parens_with_nesting : FStar_Pprint.document -> FStar_Pprint.document) = - fun contents -> - FStar_Pprint.surround (Prims.of_int (2)) Prims.int_zero - FStar_Pprint.lparen contents FStar_Pprint.rparen -let (soft_parens_with_nesting : - FStar_Pprint.document -> FStar_Pprint.document) = - fun contents -> - FStar_Pprint.soft_surround (Prims.of_int (2)) Prims.int_zero - FStar_Pprint.lparen contents FStar_Pprint.rparen -let (braces_with_nesting : FStar_Pprint.document -> FStar_Pprint.document) = - fun contents -> - FStar_Pprint.surround (Prims.of_int (2)) Prims.int_one - FStar_Pprint.lbrace contents FStar_Pprint.rbrace -let (soft_braces_with_nesting : - FStar_Pprint.document -> FStar_Pprint.document) = - fun contents -> - FStar_Pprint.soft_surround (Prims.of_int (2)) Prims.int_one - FStar_Pprint.lbrace contents FStar_Pprint.rbrace -let (soft_braces_with_nesting_tight : - FStar_Pprint.document -> FStar_Pprint.document) = - fun contents -> - FStar_Pprint.soft_surround (Prims.of_int (2)) Prims.int_zero - FStar_Pprint.lbrace contents FStar_Pprint.rbrace -let (brackets_with_nesting : FStar_Pprint.document -> FStar_Pprint.document) - = - fun contents -> - FStar_Pprint.surround (Prims.of_int (2)) Prims.int_one - FStar_Pprint.lbracket contents FStar_Pprint.rbracket -let (soft_brackets_with_nesting : - FStar_Pprint.document -> FStar_Pprint.document) = - fun contents -> - FStar_Pprint.soft_surround (Prims.of_int (2)) Prims.int_one - FStar_Pprint.lbracket contents FStar_Pprint.rbracket -let (soft_lens_access_with_nesting : - FStar_Pprint.document -> FStar_Pprint.document) = - fun contents -> - let uu___ = str "(|" in - let uu___1 = str "|)" in - FStar_Pprint.soft_surround (Prims.of_int (2)) Prims.int_one uu___ - contents uu___1 -let (soft_brackets_lens_access_with_nesting : - FStar_Pprint.document -> FStar_Pprint.document) = - fun contents -> - let uu___ = str "[|" in - let uu___1 = str "|]" in - FStar_Pprint.soft_surround (Prims.of_int (2)) Prims.int_one uu___ - contents uu___1 -let (soft_begin_end_with_nesting : - FStar_Pprint.document -> FStar_Pprint.document) = - fun contents -> - let uu___ = str "begin" in - let uu___1 = str "end" in - FStar_Pprint.soft_surround (Prims.of_int (2)) Prims.int_one uu___ - contents uu___1 -let (tc_arg : FStar_Pprint.document -> FStar_Pprint.document) = - fun contents -> - let uu___ = str "{|" in - let uu___1 = str "|}" in - FStar_Pprint.soft_surround (Prims.of_int (2)) Prims.int_one uu___ - contents uu___1 -let (is_tc_binder : FStar_Parser_AST.binder -> Prims.bool) = - fun b -> - match b.FStar_Parser_AST.aqual with - | FStar_Pervasives_Native.Some (FStar_Parser_AST.TypeClassArg) -> true - | uu___ -> false -let (is_meta_qualifier : - FStar_Parser_AST.arg_qualifier FStar_Pervasives_Native.option -> Prims.bool) - = - fun aq -> - match aq with - | FStar_Pervasives_Native.Some (FStar_Parser_AST.Meta uu___) -> true - | uu___ -> false -let (is_joinable_binder : FStar_Parser_AST.binder -> Prims.bool) = - fun b -> - (let uu___ = is_tc_binder b in Prims.op_Negation uu___) && - (Prims.op_Negation (is_meta_qualifier b.FStar_Parser_AST.aqual)) -let separate_map_last : - 'uuuuu . - FStar_Pprint.document -> - (Prims.bool -> 'uuuuu -> FStar_Pprint.document) -> - 'uuuuu Prims.list -> FStar_Pprint.document - = - fun sep -> - fun f -> - fun es -> - let l = FStar_Compiler_List.length es in - let es1 = - FStar_Compiler_List.mapi - (fun i -> fun e -> f (i <> (l - Prims.int_one)) e) es in - FStar_Pprint.separate sep es1 -let separate_break_map_last : - 'uuuuu . - FStar_Pprint.document -> - (Prims.bool -> 'uuuuu -> FStar_Pprint.document) -> - 'uuuuu Prims.list -> FStar_Pprint.document - = - fun sep -> - fun f -> - fun l -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Pprint.op_Hat_Hat sep break1 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___2 in - separate_map_last uu___1 f l in - FStar_Pprint.group uu___ -let separate_map_or_flow : - 'uuuuu . - FStar_Pprint.document -> - ('uuuuu -> FStar_Pprint.document) -> - 'uuuuu Prims.list -> FStar_Pprint.document - = - fun sep -> - fun f -> - fun l -> - if (FStar_Compiler_List.length l) < (Prims.of_int (10)) - then FStar_Pprint.separate_map sep f l - else FStar_Pprint.flow_map sep f l -let flow_map_last : - 'uuuuu . - FStar_Pprint.document -> - (Prims.bool -> 'uuuuu -> FStar_Pprint.document) -> - 'uuuuu Prims.list -> FStar_Pprint.document - = - fun sep -> - fun f -> - fun es -> - let l = FStar_Compiler_List.length es in - let es1 = - FStar_Compiler_List.mapi - (fun i -> fun e -> f (i <> (l - Prims.int_one)) e) es in - FStar_Pprint.flow sep es1 -let separate_map_or_flow_last : - 'uuuuu . - FStar_Pprint.document -> - (Prims.bool -> 'uuuuu -> FStar_Pprint.document) -> - 'uuuuu Prims.list -> FStar_Pprint.document - = - fun sep -> - fun f -> - fun l -> - if (FStar_Compiler_List.length l) < (Prims.of_int (10)) - then separate_map_last sep f l - else flow_map_last sep f l -let (separate_or_flow : - FStar_Pprint.document -> - FStar_Pprint.document Prims.list -> FStar_Pprint.document) - = fun sep -> fun l -> separate_map_or_flow sep (fun x -> x) l -let (surround_maybe_empty : - Prims.int -> - Prims.int -> - FStar_Pprint.document -> - FStar_Pprint.document -> - FStar_Pprint.document -> FStar_Pprint.document) - = - fun n -> - fun b -> - fun doc1 -> - fun doc2 -> - fun doc3 -> - if doc2 = FStar_Pprint.empty - then - let uu___ = FStar_Pprint.op_Hat_Slash_Hat doc1 doc3 in - FStar_Pprint.group uu___ - else FStar_Pprint.surround n b doc1 doc2 doc3 -let soft_surround_separate_map : - 'uuuuu . - Prims.int -> - Prims.int -> - FStar_Pprint.document -> - FStar_Pprint.document -> - FStar_Pprint.document -> - FStar_Pprint.document -> - ('uuuuu -> FStar_Pprint.document) -> - 'uuuuu Prims.list -> FStar_Pprint.document - = - fun n -> - fun b -> - fun void_ -> - fun opening -> - fun sep -> - fun closing -> - fun f -> - fun xs -> - if xs = [] - then void_ - else - (let uu___1 = FStar_Pprint.separate_map sep f xs in - FStar_Pprint.soft_surround n b opening uu___1 closing) -let soft_surround_map_or_flow : - 'uuuuu . - Prims.int -> - Prims.int -> - FStar_Pprint.document -> - FStar_Pprint.document -> - FStar_Pprint.document -> - FStar_Pprint.document -> - ('uuuuu -> FStar_Pprint.document) -> - 'uuuuu Prims.list -> FStar_Pprint.document - = - fun n -> - fun b -> - fun void_ -> - fun opening -> - fun sep -> - fun closing -> - fun f -> - fun xs -> - if xs = [] - then void_ - else - (let uu___1 = separate_map_or_flow sep f xs in - FStar_Pprint.soft_surround n b opening uu___1 closing) -let (is_unit : FStar_Parser_AST.term -> Prims.bool) = - fun e -> - match e.FStar_Parser_AST.tm with - | FStar_Parser_AST.Const (FStar_Const.Const_unit) -> true - | uu___ -> false -let (matches_var : FStar_Parser_AST.term -> FStar_Ident.ident -> Prims.bool) - = - fun t -> - fun x -> - match t.FStar_Parser_AST.tm with - | FStar_Parser_AST.Var y -> - let uu___ = FStar_Ident.string_of_id x in - let uu___1 = FStar_Ident.string_of_lid y in uu___ = uu___1 - | uu___ -> false -let (is_tuple_constructor : FStar_Ident.lident -> Prims.bool) = - FStar_Parser_Const.is_tuple_data_lid' -let (is_dtuple_constructor : FStar_Ident.lident -> Prims.bool) = - FStar_Parser_Const.is_dtuple_data_lid' -let (is_array : FStar_Parser_AST.term -> Prims.bool) = - fun e -> - match e.FStar_Parser_AST.tm with - | FStar_Parser_AST.App - ({ FStar_Parser_AST.tm = FStar_Parser_AST.Var lid; - FStar_Parser_AST.range = uu___; FStar_Parser_AST.level = uu___1;_}, - l, FStar_Parser_AST.Nothing) - -> - (FStar_Ident.lid_equals lid FStar_Parser_Const.array_of_list_lid) && - (FStar_Parser_AST.uu___is_ListLiteral l.FStar_Parser_AST.tm) - | uu___ -> false -let rec (is_ref_set : FStar_Parser_AST.term -> Prims.bool) = - fun e -> - match e.FStar_Parser_AST.tm with - | FStar_Parser_AST.Var maybe_empty_lid -> - FStar_Ident.lid_equals maybe_empty_lid FStar_Parser_Const.set_empty - | FStar_Parser_AST.App - ({ FStar_Parser_AST.tm = FStar_Parser_AST.Var maybe_singleton_lid; - FStar_Parser_AST.range = uu___; FStar_Parser_AST.level = uu___1;_}, - { - FStar_Parser_AST.tm = FStar_Parser_AST.App - ({ FStar_Parser_AST.tm = FStar_Parser_AST.Var maybe_addr_of_lid; - FStar_Parser_AST.range = uu___2; - FStar_Parser_AST.level = uu___3;_}, - e1, FStar_Parser_AST.Nothing); - FStar_Parser_AST.range = uu___4; - FStar_Parser_AST.level = uu___5;_}, - FStar_Parser_AST.Nothing) - -> - (FStar_Ident.lid_equals maybe_singleton_lid - FStar_Parser_Const.set_singleton) - && - (FStar_Ident.lid_equals maybe_addr_of_lid - FStar_Parser_Const.heap_addr_of_lid) - | FStar_Parser_AST.App - ({ - FStar_Parser_AST.tm = FStar_Parser_AST.App - ({ FStar_Parser_AST.tm = FStar_Parser_AST.Var maybe_union_lid; - FStar_Parser_AST.range = uu___; - FStar_Parser_AST.level = uu___1;_}, - e1, FStar_Parser_AST.Nothing); - FStar_Parser_AST.range = uu___2; - FStar_Parser_AST.level = uu___3;_}, - e2, FStar_Parser_AST.Nothing) - -> - ((FStar_Ident.lid_equals maybe_union_lid FStar_Parser_Const.set_union) - && (is_ref_set e1)) - && (is_ref_set e2) - | uu___ -> false -let rec (extract_from_ref_set : - FStar_Parser_AST.term -> FStar_Parser_AST.term Prims.list) = - fun e -> - match e.FStar_Parser_AST.tm with - | FStar_Parser_AST.Var uu___ -> [] - | FStar_Parser_AST.App - ({ FStar_Parser_AST.tm = FStar_Parser_AST.Var uu___; - FStar_Parser_AST.range = uu___1; - FStar_Parser_AST.level = uu___2;_}, - { - FStar_Parser_AST.tm = FStar_Parser_AST.App - ({ FStar_Parser_AST.tm = FStar_Parser_AST.Var uu___3; - FStar_Parser_AST.range = uu___4; - FStar_Parser_AST.level = uu___5;_}, - e1, FStar_Parser_AST.Nothing); - FStar_Parser_AST.range = uu___6; - FStar_Parser_AST.level = uu___7;_}, - FStar_Parser_AST.Nothing) - -> [e1] - | FStar_Parser_AST.App - ({ - FStar_Parser_AST.tm = FStar_Parser_AST.App - ({ FStar_Parser_AST.tm = FStar_Parser_AST.Var uu___; - FStar_Parser_AST.range = uu___1; - FStar_Parser_AST.level = uu___2;_}, - e1, FStar_Parser_AST.Nothing); - FStar_Parser_AST.range = uu___3; - FStar_Parser_AST.level = uu___4;_}, - e2, FStar_Parser_AST.Nothing) - -> - let uu___5 = extract_from_ref_set e1 in - let uu___6 = extract_from_ref_set e2 in - FStar_Compiler_List.op_At uu___5 uu___6 - | uu___ -> - let uu___1 = - let uu___2 = FStar_Parser_AST.term_to_string e in - FStar_Compiler_Util.format1 "Not a ref set %s" uu___2 in - failwith uu___1 -let (is_general_application : FStar_Parser_AST.term -> Prims.bool) = - fun e -> - let uu___ = (is_array e) || (is_ref_set e) in Prims.op_Negation uu___ -let (is_general_construction : FStar_Parser_AST.term -> Prims.bool) = - fun e -> - Prims.op_Negation - (FStar_Parser_AST.uu___is_ListLiteral e.FStar_Parser_AST.tm) -let (is_general_prefix_op : FStar_Ident.ident -> Prims.bool) = - fun op -> - let op_starting_char = - let uu___ = FStar_Ident.string_of_id op in - FStar_Compiler_Util.char_at uu___ Prims.int_zero in - ((op_starting_char = 33) || (op_starting_char = 63)) || - ((op_starting_char = 126) && - (let uu___ = FStar_Ident.string_of_id op in uu___ <> "~")) -let (head_and_args : - FStar_Parser_AST.term -> - (FStar_Parser_AST.term * (FStar_Parser_AST.term * FStar_Parser_AST.imp) - Prims.list)) - = - fun e -> - let rec aux e1 acc = - match e1.FStar_Parser_AST.tm with - | FStar_Parser_AST.App (head, arg, imp) -> aux head ((arg, imp) :: acc) - | uu___ -> (e1, acc) in - aux e [] -type associativity = - | Left - | Right - | NonAssoc -let (uu___is_Left : associativity -> Prims.bool) = - fun projectee -> match projectee with | Left -> true | uu___ -> false -let (uu___is_Right : associativity -> Prims.bool) = - fun projectee -> match projectee with | Right -> true | uu___ -> false -let (uu___is_NonAssoc : associativity -> Prims.bool) = - fun projectee -> match projectee with | NonAssoc -> true | uu___ -> false -type token = - | StartsWith of FStar_Char.char - | Exact of Prims.string - | UnicodeOperator -let (uu___is_StartsWith : token -> Prims.bool) = - fun projectee -> - match projectee with | StartsWith _0 -> true | uu___ -> false -let (__proj__StartsWith__item___0 : token -> FStar_Char.char) = - fun projectee -> match projectee with | StartsWith _0 -> _0 -let (uu___is_Exact : token -> Prims.bool) = - fun projectee -> match projectee with | Exact _0 -> true | uu___ -> false -let (__proj__Exact__item___0 : token -> Prims.string) = - fun projectee -> match projectee with | Exact _0 -> _0 -let (uu___is_UnicodeOperator : token -> Prims.bool) = - fun projectee -> - match projectee with | UnicodeOperator -> true | uu___ -> false -type associativity_level = (associativity * token Prims.list) -let (token_to_string : token -> Prims.string) = - fun uu___ -> - match uu___ with - | StartsWith c -> - Prims.strcat (FStar_Compiler_Util.string_of_char c) ".*" - | Exact s -> s - | UnicodeOperator -> "" -let (is_non_latin_char : FStar_Char.char -> Prims.bool) = - fun s -> (FStar_Compiler_Util.int_of_char s) > (Prims.of_int (0x024f)) -let (matches_token : Prims.string -> token -> Prims.bool) = - fun s -> - fun uu___ -> - match uu___ with - | StartsWith c -> - let uu___1 = FStar_Compiler_String.get s Prims.int_zero in - uu___1 = c - | Exact s' -> s = s' - | UnicodeOperator -> - let uu___1 = FStar_Compiler_String.get s Prims.int_zero in - is_non_latin_char uu___1 -let matches_level : - 'uuuuu . Prims.string -> ('uuuuu * token Prims.list) -> Prims.bool = - fun s -> - fun uu___ -> - match uu___ with - | (assoc_levels, tokens) -> - let uu___1 = FStar_Compiler_List.tryFind (matches_token s) tokens in - uu___1 <> FStar_Pervasives_Native.None -let (opinfix4 : associativity_level) = (Right, [Exact "**"; UnicodeOperator]) -let (opinfix3 : associativity_level) = - (Left, [StartsWith 42; StartsWith 47; StartsWith 37]) -let (opinfix2 : associativity_level) = (Left, [StartsWith 43; StartsWith 45]) -let (minus_lvl : associativity_level) = (Left, [Exact "-"]) -let (opinfix1 : associativity_level) = - (Right, [StartsWith 64; StartsWith 94]) -let (pipe_right : associativity_level) = (Left, [Exact "|>"]) -let (opinfix0d : associativity_level) = (Left, [StartsWith 36]) -let (opinfix0c : associativity_level) = - (Left, [StartsWith 61; StartsWith 60; StartsWith 62]) -let (equal : associativity_level) = (Left, [Exact "="]) -let (opinfix0b : associativity_level) = (Left, [StartsWith 38]) -let (opinfix0a : associativity_level) = (Left, [StartsWith 124]) -let (colon_equals : associativity_level) = (NonAssoc, [Exact ":="]) -let (amp : associativity_level) = (Right, [Exact "&"]) -let (colon_colon : associativity_level) = (Right, [Exact "::"]) -let (level_associativity_spec : associativity_level Prims.list) = - [opinfix4; - opinfix3; - opinfix2; - opinfix1; - pipe_right; - opinfix0d; - opinfix0c; - opinfix0b; - opinfix0a; - colon_equals; - amp; - colon_colon] -let (level_table : - ((Prims.int * Prims.int * Prims.int) * token Prims.list) Prims.list) = - let levels_from_associativity l uu___ = - match uu___ with - | Left -> (l, l, (l - Prims.int_one)) - | Right -> ((l - Prims.int_one), l, l) - | NonAssoc -> ((l - Prims.int_one), l, (l - Prims.int_one)) in - FStar_Compiler_List.mapi - (fun i -> - fun uu___ -> - match uu___ with - | (assoc, tokens) -> ((levels_from_associativity i assoc), tokens)) - level_associativity_spec -let (assign_levels : - associativity_level Prims.list -> - Prims.string -> (Prims.int * Prims.int * Prims.int)) - = - fun token_associativity_spec -> - fun s -> - let uu___ = FStar_Compiler_List.tryFind (matches_level s) level_table in - match uu___ with - | FStar_Pervasives_Native.Some (assoc_levels, uu___1) -> assoc_levels - | uu___1 -> failwith (Prims.strcat "Unrecognized operator " s) -let max_level : 'uuuuu . ('uuuuu * token Prims.list) Prims.list -> Prims.int - = - fun l -> - let find_level_and_max n level = - let uu___ = - FStar_Compiler_List.tryFind - (fun uu___1 -> - match uu___1 with - | (uu___2, tokens) -> - tokens = (FStar_Pervasives_Native.snd level)) level_table in - match uu___ with - | FStar_Pervasives_Native.Some ((uu___1, l1, uu___2), uu___3) -> - max n l1 - | FStar_Pervasives_Native.None -> - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Compiler_List.map token_to_string - (FStar_Pervasives_Native.snd level) in - FStar_Compiler_String.concat "," uu___3 in - FStar_Compiler_Util.format1 "Undefined associativity level %s" - uu___2 in - failwith uu___1 in - FStar_Compiler_List.fold_left find_level_and_max Prims.int_zero l -let (levels : Prims.string -> (Prims.int * Prims.int * Prims.int)) = - fun op -> - let uu___ = assign_levels level_associativity_spec op in - match uu___ with - | (left, mine, right) -> - if op = "&" - then ((left - Prims.int_one), mine, right) - else (left, mine, right) -let (operatorInfix0ad12 : associativity_level Prims.list) = - [opinfix0a; opinfix0b; opinfix0c; opinfix0d; opinfix1; opinfix2] -let (is_operatorInfix0ad12 : FStar_Ident.ident -> Prims.bool) = - fun op -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Ident.string_of_id op in matches_level uu___2 in - FStar_Compiler_List.tryFind uu___1 operatorInfix0ad12 in - uu___ <> FStar_Pervasives_Native.None -let (is_operatorInfix34 : FStar_Ident.ident -> Prims.bool) = - let opinfix34 = [opinfix3; opinfix4] in - fun op -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Ident.string_of_id op in matches_level uu___2 in - FStar_Compiler_List.tryFind uu___1 opinfix34 in - uu___ <> FStar_Pervasives_Native.None -let (handleable_args_length : FStar_Ident.ident -> Prims.int) = - fun op -> - let op_s = FStar_Ident.string_of_id op in - let uu___ = - (is_general_prefix_op op) || (FStar_Compiler_List.mem op_s ["-"; "~"]) in - if uu___ - then Prims.int_one - else - (let uu___2 = - ((is_operatorInfix0ad12 op) || (is_operatorInfix34 op)) || - (FStar_Compiler_List.mem op_s - ["<==>"; - "==>"; - "\\/"; - "/\\"; - "="; - "|>"; - ":="; - ".()"; - ".[]"; - ".(||)"; - ".[||]"]) in - if uu___2 - then (Prims.of_int (2)) - else - if - FStar_Compiler_List.mem op_s - [".()<-"; ".[]<-"; ".(||)<-"; ".[||]<-"] - then (Prims.of_int (3)) - else Prims.int_zero) -let handleable_op : - 'uuuuu . FStar_Ident.ident -> 'uuuuu Prims.list -> Prims.bool = - fun op -> - fun args -> - match FStar_Compiler_List.length args with - | uu___ when uu___ = Prims.int_zero -> true - | uu___ when uu___ = Prims.int_one -> - (is_general_prefix_op op) || - (let uu___1 = FStar_Ident.string_of_id op in - FStar_Compiler_List.mem uu___1 ["-"; "~"]) - | uu___ when uu___ = (Prims.of_int (2)) -> - ((is_operatorInfix0ad12 op) || (is_operatorInfix34 op)) || - (let uu___1 = FStar_Ident.string_of_id op in - FStar_Compiler_List.mem uu___1 - ["<==>"; - "==>"; - "\\/"; - "/\\"; - "="; - "|>"; - ":="; - ".()"; - ".[]"; - ".(||)"; - ".[||]"]) - | uu___ when uu___ = (Prims.of_int (3)) -> - let uu___1 = FStar_Ident.string_of_id op in - FStar_Compiler_List.mem uu___1 - [".()<-"; ".[]<-"; ".(||)<-"; ".[||]<-"] - | uu___ -> false -type annotation_style = - | Binders of (Prims.int * Prims.int * Prims.bool) - | Arrows of (Prims.int * Prims.int) -let (uu___is_Binders : annotation_style -> Prims.bool) = - fun projectee -> match projectee with | Binders _0 -> true | uu___ -> false -let (__proj__Binders__item___0 : - annotation_style -> (Prims.int * Prims.int * Prims.bool)) = - fun projectee -> match projectee with | Binders _0 -> _0 -let (uu___is_Arrows : annotation_style -> Prims.bool) = - fun projectee -> match projectee with | Arrows _0 -> true | uu___ -> false -let (__proj__Arrows__item___0 : annotation_style -> (Prims.int * Prims.int)) - = fun projectee -> match projectee with | Arrows _0 -> _0 -let (all_binders_annot : FStar_Parser_AST.term -> Prims.bool) = - fun e -> - let is_binder_annot b = - match b.FStar_Parser_AST.b with - | FStar_Parser_AST.Annotated uu___ -> true - | uu___ -> false in - let rec all_binders e1 l = - match e1.FStar_Parser_AST.tm with - | FStar_Parser_AST.Product (bs, tgt) -> - let uu___ = FStar_Compiler_List.for_all is_binder_annot bs in - if uu___ - then all_binders tgt (l + (FStar_Compiler_List.length bs)) - else (false, Prims.int_zero) - | uu___ -> (true, (l + Prims.int_one)) in - let uu___ = all_binders e Prims.int_zero in - match uu___ with - | (b, l) -> if b && (l > Prims.int_one) then true else false -type catf = - FStar_Pprint.document -> FStar_Pprint.document -> FStar_Pprint.document -let (cat_with_colon : - FStar_Pprint.document -> FStar_Pprint.document -> FStar_Pprint.document) = - fun x -> - fun y -> - let uu___ = FStar_Pprint.op_Hat_Slash_Hat FStar_Pprint.colon y in - FStar_Pprint.op_Hat_Hat x uu___ -let (comment_stack : - (Prims.string * FStar_Compiler_Range_Type.range) Prims.list - FStar_Compiler_Effect.ref) - = FStar_Compiler_Util.mk_ref [] -type decl_meta = - { - r: FStar_Compiler_Range_Type.range ; - has_qs: Prims.bool ; - has_attrs: Prims.bool } -let (__proj__Mkdecl_meta__item__r : - decl_meta -> FStar_Compiler_Range_Type.range) = - fun projectee -> match projectee with | { r; has_qs; has_attrs;_} -> r -let (__proj__Mkdecl_meta__item__has_qs : decl_meta -> Prims.bool) = - fun projectee -> match projectee with | { r; has_qs; has_attrs;_} -> has_qs -let (__proj__Mkdecl_meta__item__has_attrs : decl_meta -> Prims.bool) = - fun projectee -> - match projectee with | { r; has_qs; has_attrs;_} -> has_attrs -let (dummy_meta : decl_meta) = - { - r = FStar_Compiler_Range_Type.dummyRange; - has_qs = false; - has_attrs = false - } -let with_comment : - 'uuuuu . - ('uuuuu -> FStar_Pprint.document) -> - 'uuuuu -> FStar_Compiler_Range_Type.range -> FStar_Pprint.document - = - fun printer -> - fun tm -> - fun tmrange -> - let rec comments_before_pos acc print_pos lookahead_pos = - let uu___ = FStar_Compiler_Effect.op_Bang comment_stack in - match uu___ with - | [] -> (acc, false) - | (c, crange)::cs -> - let comment = - let uu___1 = str c in - FStar_Pprint.op_Hat_Hat uu___1 FStar_Pprint.hardline in - let uu___1 = - FStar_Compiler_Range_Ops.range_before_pos crange print_pos in - if uu___1 - then - (FStar_Compiler_Effect.op_Colon_Equals comment_stack cs; - (let uu___3 = FStar_Pprint.op_Hat_Hat acc comment in - comments_before_pos uu___3 print_pos lookahead_pos)) - else - (let uu___3 = - FStar_Compiler_Range_Ops.range_before_pos crange - lookahead_pos in - (acc, uu___3)) in - let uu___ = - let uu___1 = - let uu___2 = FStar_Compiler_Range_Ops.start_of_range tmrange in - FStar_Compiler_Range_Ops.end_of_line uu___2 in - let uu___2 = FStar_Compiler_Range_Ops.end_of_range tmrange in - comments_before_pos FStar_Pprint.empty uu___1 uu___2 in - match uu___ with - | (comments, has_lookahead) -> - let printed_e = printer tm in - let comments1 = - if has_lookahead - then - let pos = FStar_Compiler_Range_Ops.end_of_range tmrange in - let uu___1 = comments_before_pos comments pos pos in - FStar_Pervasives_Native.fst uu___1 - else comments in - if comments1 = FStar_Pprint.empty - then printed_e - else - (let uu___2 = FStar_Pprint.op_Hat_Hat comments1 printed_e in - FStar_Pprint.group uu___2) -let with_comment_sep : - 'uuuuu 'uuuuu1 . - ('uuuuu -> 'uuuuu1) -> - 'uuuuu -> - FStar_Compiler_Range_Type.range -> (FStar_Pprint.document * 'uuuuu1) - = - fun printer -> - fun tm -> - fun tmrange -> - let rec comments_before_pos acc print_pos lookahead_pos = - let uu___ = FStar_Compiler_Effect.op_Bang comment_stack in - match uu___ with - | [] -> (acc, false) - | (c, crange)::cs -> - let comment = str c in - let uu___1 = - FStar_Compiler_Range_Ops.range_before_pos crange print_pos in - if uu___1 - then - (FStar_Compiler_Effect.op_Colon_Equals comment_stack cs; - (let uu___3 = - if acc = FStar_Pprint.empty - then comment - else - (let uu___5 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline - comment in - FStar_Pprint.op_Hat_Hat acc uu___5) in - comments_before_pos uu___3 print_pos lookahead_pos)) - else - (let uu___3 = - FStar_Compiler_Range_Ops.range_before_pos crange - lookahead_pos in - (acc, uu___3)) in - let uu___ = - let uu___1 = - let uu___2 = FStar_Compiler_Range_Ops.start_of_range tmrange in - FStar_Compiler_Range_Ops.end_of_line uu___2 in - let uu___2 = FStar_Compiler_Range_Ops.end_of_range tmrange in - comments_before_pos FStar_Pprint.empty uu___1 uu___2 in - match uu___ with - | (comments, has_lookahead) -> - let printed_e = printer tm in - let comments1 = - if has_lookahead - then - let pos = FStar_Compiler_Range_Ops.end_of_range tmrange in - let uu___1 = comments_before_pos comments pos pos in - FStar_Pervasives_Native.fst uu___1 - else comments in - (comments1, printed_e) -let rec (place_comments_until_pos : - Prims.int -> - Prims.int -> - FStar_Compiler_Range_Type.pos -> - decl_meta -> - FStar_Pprint.document -> - Prims.bool -> Prims.bool -> FStar_Pprint.document) - = - fun k -> - fun lbegin -> - fun pos -> - fun meta_decl -> - fun doc -> - fun r -> - fun init -> - let uu___ = FStar_Compiler_Effect.op_Bang comment_stack in - match uu___ with - | (comment, crange)::cs when - FStar_Compiler_Range_Ops.range_before_pos crange pos -> - (FStar_Compiler_Effect.op_Colon_Equals comment_stack cs; - (let lnum = - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Compiler_Range_Ops.start_of_range crange in - FStar_Compiler_Range_Ops.line_of_pos uu___4 in - uu___3 - lbegin in - max k uu___2 in - let lnum1 = min (Prims.of_int (2)) lnum in - let doc1 = - let uu___2 = - let uu___3 = - FStar_Pprint.repeat lnum1 FStar_Pprint.hardline in - let uu___4 = str comment in - FStar_Pprint.op_Hat_Hat uu___3 uu___4 in - FStar_Pprint.op_Hat_Hat doc uu___2 in - let uu___2 = - let uu___3 = - FStar_Compiler_Range_Ops.end_of_range crange in - FStar_Compiler_Range_Ops.line_of_pos uu___3 in - place_comments_until_pos Prims.int_one uu___2 pos - meta_decl doc1 true init)) - | uu___1 -> - if doc = FStar_Pprint.empty - then FStar_Pprint.empty - else - (let lnum = - let uu___3 = - FStar_Compiler_Range_Ops.line_of_pos pos in - uu___3 - lbegin in - let lnum1 = min (Prims.of_int (3)) lnum in - let lnum2 = - if meta_decl.has_qs || meta_decl.has_attrs - then lnum1 - Prims.int_one - else lnum1 in - let lnum3 = max k lnum2 in - let lnum4 = - if meta_decl.has_qs && meta_decl.has_attrs - then (Prims.of_int (2)) - else lnum3 in - let lnum5 = if init then (Prims.of_int (2)) else lnum4 in - let uu___3 = - FStar_Pprint.repeat lnum5 FStar_Pprint.hardline in - FStar_Pprint.op_Hat_Hat doc uu___3) -let separate_map_with_comments : - 'uuuuu . - FStar_Pprint.document -> - FStar_Pprint.document -> - ('uuuuu -> FStar_Pprint.document) -> - 'uuuuu Prims.list -> ('uuuuu -> decl_meta) -> FStar_Pprint.document - = - fun prefix -> - fun sep -> - fun f -> - fun xs -> - fun extract_meta -> - let fold_fun uu___ x = - match uu___ with - | (last_line, doc) -> - let meta_decl = extract_meta x in - let r = meta_decl.r in - let doc1 = - let uu___1 = FStar_Compiler_Range_Ops.start_of_range r in - place_comments_until_pos Prims.int_one last_line uu___1 - meta_decl doc false false in - let uu___1 = - let uu___2 = FStar_Compiler_Range_Ops.end_of_range r in - FStar_Compiler_Range_Ops.line_of_pos uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = f x in FStar_Pprint.op_Hat_Hat sep uu___4 in - FStar_Pprint.op_Hat_Hat doc1 uu___3 in - (uu___1, uu___2) in - let uu___ = - let uu___1 = FStar_Compiler_List.hd xs in - let uu___2 = FStar_Compiler_List.tl xs in (uu___1, uu___2) in - match uu___ with - | (x, xs1) -> - let init = - let meta_decl = extract_meta x in - let uu___1 = - let uu___2 = - FStar_Compiler_Range_Ops.end_of_range meta_decl.r in - FStar_Compiler_Range_Ops.line_of_pos uu___2 in - let uu___2 = - let uu___3 = f x in FStar_Pprint.op_Hat_Hat prefix uu___3 in - (uu___1, uu___2) in - let uu___1 = FStar_Compiler_List.fold_left fold_fun init xs1 in - FStar_Pervasives_Native.snd uu___1 -let separate_map_with_comments_kw : - 'uuuuu 'uuuuu1 . - 'uuuuu -> - 'uuuuu -> - ('uuuuu -> 'uuuuu1 -> FStar_Pprint.document) -> - 'uuuuu1 Prims.list -> - ('uuuuu1 -> decl_meta) -> FStar_Pprint.document - = - fun prefix -> - fun sep -> - fun f -> - fun xs -> - fun extract_meta -> - let fold_fun uu___ x = - match uu___ with - | (last_line, doc) -> - let meta_decl = extract_meta x in - let r = meta_decl.r in - let doc1 = - let uu___1 = FStar_Compiler_Range_Ops.start_of_range r in - place_comments_until_pos Prims.int_one last_line uu___1 - meta_decl doc false false in - let uu___1 = - let uu___2 = FStar_Compiler_Range_Ops.end_of_range r in - FStar_Compiler_Range_Ops.line_of_pos uu___2 in - let uu___2 = - let uu___3 = f sep x in - FStar_Pprint.op_Hat_Hat doc1 uu___3 in - (uu___1, uu___2) in - let uu___ = - let uu___1 = FStar_Compiler_List.hd xs in - let uu___2 = FStar_Compiler_List.tl xs in (uu___1, uu___2) in - match uu___ with - | (x, xs1) -> - let init = - let meta_decl = extract_meta x in - let uu___1 = - let uu___2 = - FStar_Compiler_Range_Ops.end_of_range meta_decl.r in - FStar_Compiler_Range_Ops.line_of_pos uu___2 in - let uu___2 = f prefix x in (uu___1, uu___2) in - let uu___1 = FStar_Compiler_List.fold_left fold_fun init xs1 in - FStar_Pervasives_Native.snd uu___1 -let p_lidentOrOperator' : - 'uuuuu . - 'uuuuu -> - ('uuuuu -> Prims.string) -> - ('uuuuu -> FStar_Pprint.document) -> FStar_Pprint.document - = - fun l -> - fun s_l -> - fun p_l -> - let lstr = s_l l in - if FStar_Compiler_Util.starts_with lstr "op_" - then - let uu___ = FStar_Parser_AST.string_to_op lstr in - match uu___ with - | FStar_Pervasives_Native.None -> - let uu___1 = str "( " in - let uu___2 = - let uu___3 = p_l l in - let uu___4 = str " )" in - FStar_Pprint.op_Hat_Hat uu___3 uu___4 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 - | FStar_Pervasives_Native.Some (s, uu___1) -> - let uu___2 = str "( " in - let uu___3 = - let uu___4 = str s in - let uu___5 = str " )" in - FStar_Pprint.op_Hat_Hat uu___4 uu___5 in - FStar_Pprint.op_Hat_Hat uu___2 uu___3 - else p_l l -let (string_of_id_or_underscore : FStar_Ident.ident -> FStar_Pprint.document) - = - fun lid -> - let uu___ = - (let uu___1 = FStar_Ident.string_of_id lid in - FStar_Compiler_Util.starts_with uu___1 FStar_Ident.reserved_prefix) && - (let uu___1 = FStar_Options.print_real_names () in - Prims.op_Negation uu___1) in - if uu___ - then FStar_Pprint.underscore - else (let uu___2 = FStar_Ident.string_of_id lid in str uu___2) -let (text_of_lid_or_underscore : FStar_Ident.lident -> FStar_Pprint.document) - = - fun lid -> - let uu___ = - (let uu___1 = - let uu___2 = FStar_Ident.ident_of_lid lid in - FStar_Ident.string_of_id uu___2 in - FStar_Compiler_Util.starts_with uu___1 FStar_Ident.reserved_prefix) && - (let uu___1 = FStar_Options.print_real_names () in - Prims.op_Negation uu___1) in - if uu___ - then FStar_Pprint.underscore - else (let uu___2 = FStar_Ident.string_of_lid lid in str uu___2) -let (p_qlident : FStar_Ident.lident -> FStar_Pprint.document) = - fun lid -> text_of_lid_or_underscore lid -let (p_quident : FStar_Ident.lident -> FStar_Pprint.document) = - fun lid -> text_of_lid_or_underscore lid -let (p_ident : FStar_Ident.ident -> FStar_Pprint.document) = - fun lid -> string_of_id_or_underscore lid -let (p_lident : FStar_Ident.ident -> FStar_Pprint.document) = - fun lid -> string_of_id_or_underscore lid -let (p_uident : FStar_Ident.ident -> FStar_Pprint.document) = - fun lid -> string_of_id_or_underscore lid -let (p_tvar : FStar_Ident.ident -> FStar_Pprint.document) = - fun lid -> string_of_id_or_underscore lid -let (p_qlidentOrOperator : FStar_Ident.lident -> FStar_Pprint.document) = - fun lid -> p_lidentOrOperator' lid FStar_Ident.string_of_lid p_qlident -let (p_lidentOrOperator : FStar_Ident.ident -> FStar_Pprint.document) = - fun lid -> p_lidentOrOperator' lid FStar_Ident.string_of_id p_lident -let rec (p_decl : FStar_Parser_AST.decl -> FStar_Pprint.document) = - fun d -> - let qualifiers = - match ((d.FStar_Parser_AST.quals), (d.FStar_Parser_AST.d)) with - | ((FStar_Parser_AST.Assumption)::[], FStar_Parser_AST.Assume - (id, uu___)) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Ident.string_of_id id in - FStar_Compiler_Util.char_at uu___3 Prims.int_zero in - FStar_Compiler_Util.is_upper uu___2 in - if uu___1 - then - let uu___2 = p_qualifier FStar_Parser_AST.Assumption in - FStar_Pprint.op_Hat_Hat uu___2 FStar_Pprint.space - else p_qualifiers d.FStar_Parser_AST.quals - | uu___ -> p_qualifiers d.FStar_Parser_AST.quals in - let uu___ = p_attributes true d.FStar_Parser_AST.attrs in - let uu___1 = - let uu___2 = p_rawDecl d in FStar_Pprint.op_Hat_Hat qualifiers uu___2 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 -and (p_attributes : - Prims.bool -> FStar_Parser_AST.attributes_ -> FStar_Pprint.document) = - fun isTopLevel -> - fun attrs -> - match attrs with - | [] -> FStar_Pprint.empty - | uu___ -> - let uu___1 = - let uu___2 = str (if isTopLevel then "@@ " else "@@@ ") in - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = str "; " in - let uu___8 = - FStar_Compiler_List.map - (p_noSeqTermAndComment false false) attrs in - FStar_Pprint.flow uu___7 uu___8 in - FStar_Pprint.op_Hat_Hat uu___6 FStar_Pprint.rbracket in - FStar_Pprint.align uu___5 in - FStar_Pprint.op_Hat_Hat uu___4 - (if isTopLevel - then FStar_Pprint.hardline - else FStar_Pprint.empty) in - FStar_Pprint.op_Hat_Hat uu___2 uu___3 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.lbracket uu___1 -and (p_justSig : FStar_Parser_AST.decl -> FStar_Pprint.document) = - fun d -> - match d.FStar_Parser_AST.d with - | FStar_Parser_AST.Val (lid, t) -> - let uu___ = - let uu___1 = str "val" in - let uu___2 = - let uu___3 = - let uu___4 = p_lidentOrOperator lid in - let uu___5 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.space FStar_Pprint.colon in - FStar_Pprint.op_Hat_Hat uu___4 uu___5 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___3 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - let uu___1 = p_typ false false t in - FStar_Pprint.op_Hat_Hat uu___ uu___1 - | FStar_Parser_AST.TopLevelLet (uu___, lbs) -> - FStar_Pprint.separate_map FStar_Pprint.hardline - (fun lb -> - let uu___1 = let uu___2 = str "let" in p_letlhs uu___2 lb false in - FStar_Pprint.group uu___1) lbs - | uu___ -> FStar_Pprint.empty -and p_list : - 't . - ('t -> FStar_Pprint.document) -> - FStar_Pprint.document -> 't Prims.list -> FStar_Pprint.document - = - fun f -> - fun sep -> - fun l -> - let rec p_list' uu___ = - match uu___ with - | [] -> FStar_Pprint.empty - | x::[] -> f x - | x::xs -> - let uu___1 = f x in - let uu___2 = - let uu___3 = p_list' xs in FStar_Pprint.op_Hat_Hat sep uu___3 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - let uu___ = str "[" in - let uu___1 = - let uu___2 = p_list' l in - let uu___3 = str "]" in FStar_Pprint.op_Hat_Hat uu___2 uu___3 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 -and (p_restriction : - FStar_Syntax_Syntax.restriction -> FStar_Pprint.document) = - fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.Unrestricted -> FStar_Pprint.empty - | FStar_Syntax_Syntax.AllowList ids -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = str ", " in - p_list - (fun uu___5 -> - match uu___5 with - | (id, renamed) -> - let uu___6 = p_ident id in - let uu___7 = FStar_Pprint.optional p_ident renamed in - FStar_Pprint.op_Hat_Slash_Hat uu___6 uu___7) uu___4 - ids in - FStar_Pprint.op_Hat_Hat uu___3 FStar_Pprint.rbrace in - FStar_Pprint.op_Hat_Hat FStar_Pprint.lbrace uu___2 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___1 -and (p_rawDecl : FStar_Parser_AST.decl -> FStar_Pprint.document) = - fun d -> - match d.FStar_Parser_AST.d with - | FStar_Parser_AST.Open (uid, r) -> - let uu___ = - let uu___1 = str "open" in - let uu___2 = - let uu___3 = p_quident uid in - let uu___4 = p_restriction r in - FStar_Pprint.op_Hat_Slash_Hat uu___3 uu___4 in - FStar_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | FStar_Parser_AST.Include (uid, r) -> - let uu___ = - let uu___1 = str "include" in - let uu___2 = - let uu___3 = p_quident uid in - let uu___4 = p_restriction r in - FStar_Pprint.op_Hat_Slash_Hat uu___3 uu___4 in - FStar_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | FStar_Parser_AST.Friend uid -> - let uu___ = - let uu___1 = str "friend" in - let uu___2 = p_quident uid in - FStar_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | FStar_Parser_AST.ModuleAbbrev (uid1, uid2) -> - let uu___ = - let uu___1 = str "module" in - let uu___2 = - let uu___3 = - let uu___4 = p_uident uid1 in - let uu___5 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.space - FStar_Pprint.equals in - FStar_Pprint.op_Hat_Hat uu___4 uu___5 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___3 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - let uu___1 = p_quident uid2 in op_Hat_Slash_Plus_Hat uu___ uu___1 - | FStar_Parser_AST.TopLevelModule uid -> - let uu___ = - let uu___1 = str "module" in - let uu___2 = - let uu___3 = p_quident uid in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___3 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | FStar_Parser_AST.Tycon - (true, uu___, (FStar_Parser_AST.TyconAbbrev - (uid, tpars, FStar_Pervasives_Native.None, t))::[]) - -> - let effect_prefix_doc = - let uu___1 = str "effect" in - let uu___2 = - let uu___3 = p_uident uid in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___3 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - let uu___1 = - let uu___2 = p_typars tpars in - FStar_Pprint.surround (Prims.of_int (2)) Prims.int_one - effect_prefix_doc uu___2 FStar_Pprint.equals in - let uu___2 = p_typ false false t in - op_Hat_Slash_Plus_Hat uu___1 uu___2 - | FStar_Parser_AST.Tycon (false, tc, tcdefs) -> - let s = if tc then str "class" else str "type" in - let uu___ = - let uu___1 = FStar_Compiler_List.hd tcdefs in - p_typeDeclWithKw s uu___1 in - let uu___1 = - let uu___2 = FStar_Compiler_List.tl tcdefs in - FStar_Pprint.concat_map - (fun x -> - let uu___3 = - let uu___4 = str "and" in p_typeDeclWithKw uu___4 x in - FStar_Pprint.op_Hat_Hat break1 uu___3) uu___2 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 - | FStar_Parser_AST.TopLevelLet (q, lbs) -> - let let_doc = - let uu___ = str "let" in - let uu___1 = p_letqualifier q in - FStar_Pprint.op_Hat_Hat uu___ uu___1 in - let uu___ = str "and" in - separate_map_with_comments_kw let_doc uu___ p_letbinding lbs - (fun uu___1 -> - match uu___1 with - | (p, t) -> - let uu___2 = - FStar_Compiler_Range_Ops.union_ranges - p.FStar_Parser_AST.prange t.FStar_Parser_AST.range in - { r = uu___2; has_qs = false; has_attrs = false }) - | FStar_Parser_AST.Val (lid, t) -> - let uu___ = - let uu___1 = str "val" in - let uu___2 = - let uu___3 = - let uu___4 = p_lidentOrOperator lid in - let uu___5 = sig_as_binders_if_possible t false in - FStar_Pprint.op_Hat_Hat uu___4 uu___5 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___3 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | FStar_Parser_AST.Assume (id, t) -> - let decl_keyword = - let uu___ = - let uu___1 = - let uu___2 = FStar_Ident.string_of_id id in - FStar_Compiler_Util.char_at uu___2 Prims.int_zero in - FStar_Compiler_Util.is_upper uu___1 in - if uu___ - then FStar_Pprint.empty - else - (let uu___2 = str "val" in - FStar_Pprint.op_Hat_Hat uu___2 FStar_Pprint.space) in - let uu___ = - let uu___1 = p_ident id in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = p_typ false false t in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___5 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.colon uu___4 in - FStar_Pprint.group uu___3 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - FStar_Pprint.op_Hat_Hat decl_keyword uu___ - | FStar_Parser_AST.Exception (uid, t_opt) -> - let uu___ = str "exception" in - let uu___1 = - let uu___2 = - let uu___3 = p_uident uid in - let uu___4 = - FStar_Pprint.optional - (fun t -> - let uu___5 = - let uu___6 = str "of" in - let uu___7 = p_typ false false t in - op_Hat_Slash_Plus_Hat uu___6 uu___7 in - FStar_Pprint.op_Hat_Hat break1 uu___5) t_opt in - FStar_Pprint.op_Hat_Hat uu___3 uu___4 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___2 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 - | FStar_Parser_AST.NewEffect ne -> - let uu___ = str "new_effect" in - let uu___1 = - let uu___2 = p_newEffect ne in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___2 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 - | FStar_Parser_AST.SubEffect se -> - let uu___ = str "sub_effect" in - let uu___1 = - let uu___2 = p_subEffect se in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___2 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 - | FStar_Parser_AST.LayeredEffect ne -> - let uu___ = str "layered_effect" in - let uu___1 = - let uu___2 = p_newEffect ne in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___2 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 - | FStar_Parser_AST.Polymonadic_bind (l1, l2, l3, t) -> - let uu___ = str "polymonadic_bind" in - let uu___1 = - let uu___2 = - let uu___3 = p_quident l1 in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = p_quident l2 in - let uu___8 = - let uu___9 = - let uu___10 = str "|>" in - let uu___11 = - let uu___12 = p_quident l3 in - let uu___13 = - let uu___14 = p_simpleTerm false false t in - FStar_Pprint.op_Hat_Hat FStar_Pprint.equals uu___14 in - FStar_Pprint.op_Hat_Hat uu___12 uu___13 in - FStar_Pprint.op_Hat_Hat uu___10 uu___11 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.rparen uu___9 in - FStar_Pprint.op_Hat_Hat uu___7 uu___8 in - FStar_Pprint.op_Hat_Hat break1 uu___6 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.comma uu___5 in - FStar_Pprint.op_Hat_Hat uu___3 uu___4 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.lparen uu___2 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 - | FStar_Parser_AST.Pragma p -> p_pragma p - | FStar_Parser_AST.Tycon (true, uu___, uu___1) -> - failwith - "Effect abbreviation is expected to be defined by an abbreviation" - | FStar_Parser_AST.Splice (is_typed, ids, t) -> - let uu___ = str "%splice" in - let uu___1 = - let uu___2 = if is_typed then str "_t" else FStar_Pprint.empty in - let uu___3 = - let uu___4 = let uu___5 = str ";" in p_list p_uident uu___5 ids in - let uu___5 = - let uu___6 = p_term false false t in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___6 in - FStar_Pprint.op_Hat_Hat uu___4 uu___5 in - FStar_Pprint.op_Hat_Hat uu___2 uu___3 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 - | FStar_Parser_AST.DeclSyntaxExtension (tag, blob, blob_rng, start_rng) - -> - let uu___ = FStar_Pprint.doc_of_string (Prims.strcat "```" tag) in - let uu___1 = - let uu___2 = FStar_Pprint.arbitrary_string blob in - let uu___3 = FStar_Pprint.doc_of_string "```" in - FStar_Pprint.op_Hat_Hat uu___2 uu___3 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 - | FStar_Parser_AST.DeclToBeDesugared tbs -> - let uu___ = tbs.FStar_Parser_AST.to_string tbs.FStar_Parser_AST.blob in - FStar_Pprint.arbitrary_string uu___ -and (p_pragma : FStar_Parser_AST.pragma -> FStar_Pprint.document) = - fun uu___ -> - match uu___ with - | FStar_Parser_AST.ShowOptions -> str "#show-options" - | FStar_Parser_AST.SetOptions s -> - let uu___1 = str "#set-options" in - let uu___2 = - let uu___3 = let uu___4 = str s in FStar_Pprint.dquotes uu___4 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___3 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 - | FStar_Parser_AST.ResetOptions s_opt -> - let uu___1 = str "#reset-options" in - let uu___2 = - FStar_Pprint.optional - (fun s -> - let uu___3 = let uu___4 = str s in FStar_Pprint.dquotes uu___4 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___3) s_opt in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 - | FStar_Parser_AST.PushOptions s_opt -> - let uu___1 = str "#push-options" in - let uu___2 = - FStar_Pprint.optional - (fun s -> - let uu___3 = let uu___4 = str s in FStar_Pprint.dquotes uu___4 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___3) s_opt in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 - | FStar_Parser_AST.PopOptions -> str "#pop-options" - | FStar_Parser_AST.RestartSolver -> str "#restart-solver" - | FStar_Parser_AST.PrintEffectsGraph -> str "#print-effects-graph" -and (p_typars : FStar_Parser_AST.binder Prims.list -> FStar_Pprint.document) - = fun bs -> p_binders true bs -and (p_typeDeclWithKw : - FStar_Pprint.document -> FStar_Parser_AST.tycon -> FStar_Pprint.document) = - fun kw -> - fun typedecl -> - let uu___ = p_typeDecl kw typedecl in - match uu___ with - | (comm, decl, body, pre) -> - if comm = FStar_Pprint.empty - then let uu___1 = pre body in FStar_Pprint.op_Hat_Hat decl uu___1 - else - (let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = pre body in - FStar_Pprint.op_Hat_Slash_Hat uu___5 comm in - FStar_Pprint.op_Hat_Hat decl uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline body in - FStar_Pprint.op_Hat_Hat comm uu___8 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline uu___7 in - FStar_Pprint.nest (Prims.of_int (2)) uu___6 in - FStar_Pprint.op_Hat_Hat decl uu___5 in - FStar_Pprint.ifflat uu___3 uu___4 in - FStar_Pprint.group uu___2) -and (p_typeDecl : - FStar_Pprint.document -> - FStar_Parser_AST.tycon -> - (FStar_Pprint.document * FStar_Pprint.document * FStar_Pprint.document - * (FStar_Pprint.document -> FStar_Pprint.document))) - = - fun pre -> - fun uu___ -> - match uu___ with - | FStar_Parser_AST.TyconAbstract (lid, bs, typ_opt) -> - let uu___1 = p_typeDeclPrefix pre false lid bs typ_opt in - (FStar_Pprint.empty, uu___1, FStar_Pprint.empty, ((fun x -> x))) - | FStar_Parser_AST.TyconAbbrev (lid, bs, typ_opt, t) -> - let uu___1 = p_typ_sep false false t in - (match uu___1 with - | (comm, doc) -> - let uu___2 = p_typeDeclPrefix pre true lid bs typ_opt in - (comm, uu___2, doc, jump2)) - | FStar_Parser_AST.TyconRecord - (lid, bs, typ_opt, attrs, record_field_decls) -> - let uu___1 = p_typeDeclPrefix pre true lid bs typ_opt in - let uu___2 = - let uu___3 = p_attributes false attrs in - let uu___4 = p_typeDeclRecord record_field_decls in - FStar_Pprint.op_Hat_Hat uu___3 uu___4 in - (FStar_Pprint.empty, uu___1, uu___2, - ((fun d -> FStar_Pprint.op_Hat_Hat FStar_Pprint.space d))) - | FStar_Parser_AST.TyconVariant (lid, bs, typ_opt, ct_decls) -> - let p_constructorBranchAndComments uu___1 = - match uu___1 with - | (uid, payload, attrs) -> - let range = - let uu___2 = - let uu___3 = FStar_Ident.range_of_id uid in - let uu___4 = - FStar_Compiler_Util.bind_opt payload - (fun uu___5 -> - match uu___5 with - | FStar_Parser_AST.VpOfNotation t -> - FStar_Pervasives_Native.Some - (t.FStar_Parser_AST.range) - | FStar_Parser_AST.VpArbitrary t -> - FStar_Pervasives_Native.Some - (t.FStar_Parser_AST.range) - | FStar_Parser_AST.VpRecord (record, uu___6) -> - FStar_Pervasives_Native.None) in - FStar_Compiler_Util.dflt uu___3 uu___4 in - FStar_Compiler_Range_Ops.extend_to_end_of_line uu___2 in - let uu___2 = - with_comment_sep p_constructorBranch (uid, payload, attrs) - range in - (match uu___2 with - | (comm, ctor) -> - inline_comment_or_above comm ctor FStar_Pprint.empty) in - let datacon_doc = - FStar_Pprint.separate_map FStar_Pprint.hardline - p_constructorBranchAndComments ct_decls in - let uu___1 = p_typeDeclPrefix pre true lid bs typ_opt in - (FStar_Pprint.empty, uu___1, datacon_doc, jump2) -and (p_typeDeclRecord : - FStar_Parser_AST.tycon_record -> FStar_Pprint.document) = - fun fields -> - let p_recordField ps uu___ = - match uu___ with - | (lid, aq, attrs, t) -> - let uu___1 = - let uu___2 = - FStar_Compiler_Range_Ops.extend_to_end_of_line - t.FStar_Parser_AST.range in - with_comment_sep (p_recordFieldDecl ps) (lid, aq, attrs, t) - uu___2 in - (match uu___1 with - | (comm, field) -> - let sep = if ps then FStar_Pprint.semi else FStar_Pprint.empty in - inline_comment_or_above comm field sep) in - let uu___ = separate_map_last FStar_Pprint.hardline p_recordField fields in - braces_with_nesting uu___ -and (p_typeDeclPrefix : - FStar_Pprint.document -> - Prims.bool -> - FStar_Ident.ident -> - FStar_Parser_AST.binder Prims.list -> - FStar_Parser_AST.knd FStar_Pervasives_Native.option -> - FStar_Pprint.document) - = - fun kw -> - fun eq -> - fun lid -> - fun bs -> - fun typ_opt -> - let with_kw cont = - let lid_doc = p_ident lid in - let kw_lid = - let uu___ = FStar_Pprint.op_Hat_Slash_Hat kw lid_doc in - FStar_Pprint.group uu___ in - cont kw_lid in - let typ = - let maybe_eq = - if eq then FStar_Pprint.equals else FStar_Pprint.empty in - match typ_opt with - | FStar_Pervasives_Native.None -> maybe_eq - | FStar_Pervasives_Native.Some t -> - let uu___ = - let uu___1 = - let uu___2 = p_typ false false t in - FStar_Pprint.op_Hat_Slash_Hat uu___2 maybe_eq in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___1 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.colon uu___ in - if bs = [] - then with_kw (fun n -> prefix2 n typ) - else - (let binders = p_binders_list true bs in - with_kw - (fun n -> - let uu___1 = - let uu___2 = FStar_Pprint.flow break1 binders in - prefix2 n uu___2 in - prefix2 uu___1 typ)) -and (p_recordFieldDecl : - Prims.bool -> - (FStar_Ident.ident * FStar_Parser_AST.aqual * - FStar_Parser_AST.attributes_ * FStar_Parser_AST.term) -> - FStar_Pprint.document) - = - fun ps -> - fun uu___ -> - match uu___ with - | (lid, aq, attrs, t) -> - let uu___1 = - let uu___2 = FStar_Pprint.optional p_aqual aq in - let uu___3 = - let uu___4 = p_attributes false attrs in - let uu___5 = - let uu___6 = p_lidentOrOperator lid in - let uu___7 = - let uu___8 = p_typ ps false t in - FStar_Pprint.op_Hat_Hat FStar_Pprint.colon uu___8 in - FStar_Pprint.op_Hat_Hat uu___6 uu___7 in - FStar_Pprint.op_Hat_Hat uu___4 uu___5 in - FStar_Pprint.op_Hat_Hat uu___2 uu___3 in - FStar_Pprint.group uu___1 -and (p_constructorBranch : - (FStar_Ident.ident * FStar_Parser_AST.constructor_payload - FStar_Pervasives_Native.option * FStar_Parser_AST.attributes_) -> - FStar_Pprint.document) - = - fun uu___ -> - match uu___ with - | (uid, variant, attrs) -> - let h isOf t = - let uu___1 = if isOf then str "of" else FStar_Pprint.colon in - let uu___2 = - let uu___3 = p_typ false false t in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___3 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = p_attributes false attrs in - let uu___6 = p_uident uid in - FStar_Pprint.op_Hat_Hat uu___5 uu___6 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___4 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.bar uu___3 in - FStar_Pprint.group uu___2 in - let uu___2 = - default_or_map FStar_Pprint.empty - (fun payload -> - let uu___3 = - let uu___4 = - match payload with - | FStar_Parser_AST.VpOfNotation t -> h true t - | FStar_Parser_AST.VpArbitrary t -> h false t - | FStar_Parser_AST.VpRecord (r, t) -> - let uu___5 = p_typeDeclRecord r in - let uu___6 = - default_or_map FStar_Pprint.empty (h false) t in - FStar_Pprint.op_Hat_Hat uu___5 uu___6 in - FStar_Pprint.group uu___4 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___3) variant in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 -and (p_letlhs : - FStar_Pprint.document -> - (FStar_Parser_AST.pattern * FStar_Parser_AST.term) -> - Prims.bool -> FStar_Pprint.document) - = - fun kw -> - fun uu___ -> - fun inner_let -> - match uu___ with - | (pat, uu___1) -> - let uu___2 = - match pat.FStar_Parser_AST.pat with - | FStar_Parser_AST.PatAscribed - (pat1, (t, FStar_Pervasives_Native.None)) -> - (pat1, - (FStar_Pervasives_Native.Some (t, FStar_Pprint.empty))) - | FStar_Parser_AST.PatAscribed - (pat1, (t, FStar_Pervasives_Native.Some tac)) -> - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = str "by" in - let uu___9 = - let uu___10 = p_atomicTerm (maybe_unthunk tac) in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space - uu___10 in - FStar_Pprint.op_Hat_Hat uu___8 uu___9 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___7 in - FStar_Pprint.group uu___6 in - (t, uu___5) in - FStar_Pervasives_Native.Some uu___4 in - (pat1, uu___3) - | uu___3 -> (pat, FStar_Pervasives_Native.None) in - (match uu___2 with - | (pat1, ascr) -> - (match pat1.FStar_Parser_AST.pat with - | FStar_Parser_AST.PatApp - ({ - FStar_Parser_AST.pat = FStar_Parser_AST.PatVar - (lid, uu___3, uu___4); - FStar_Parser_AST.prange = uu___5;_}, - pats) - -> - let ascr_doc = - match ascr with - | FStar_Pervasives_Native.Some (t, tac) -> - let uu___6 = sig_as_binders_if_possible t true in - FStar_Pprint.op_Hat_Hat uu___6 tac - | FStar_Pervasives_Native.None -> FStar_Pprint.empty in - let uu___6 = - if inner_let - then - let uu___7 = pats_as_binders_if_possible pats in - match uu___7 with | (bs, style) -> (bs, style) - else - (let uu___8 = pats_as_binders_if_possible pats in - match uu___8 with | (bs, style) -> (bs, style)) in - (match uu___6 with - | (terms, style) -> - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = p_lidentOrOperator lid in - let uu___11 = - format_sig style terms ascr_doc true true in - FStar_Pprint.op_Hat_Hat uu___10 uu___11 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space - uu___9 in - FStar_Pprint.op_Hat_Hat kw uu___8 in - FStar_Pprint.group uu___7) - | uu___3 -> - let ascr_doc = - match ascr with - | FStar_Pervasives_Native.Some (t, tac) -> - let uu___4 = - let uu___5 = - let uu___6 = - p_typ_top - (Arrows - ((Prims.of_int (2)), - (Prims.of_int (2)))) false false t in - FStar_Pprint.op_Hat_Hat FStar_Pprint.colon - uu___6 in - FStar_Pprint.group uu___5 in - FStar_Pprint.op_Hat_Hat uu___4 tac - | FStar_Pervasives_Native.None -> FStar_Pprint.empty in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = p_tuplePattern pat1 in - FStar_Pprint.op_Hat_Slash_Hat kw uu___7 in - FStar_Pprint.group uu___6 in - FStar_Pprint.op_Hat_Hat uu___5 ascr_doc in - FStar_Pprint.group uu___4)) -and (p_letbinding : - FStar_Pprint.document -> - (FStar_Parser_AST.pattern * FStar_Parser_AST.term) -> - FStar_Pprint.document) - = - fun kw -> - fun uu___ -> - match uu___ with - | (pat, e) -> - let doc_pat = p_letlhs kw (pat, e) false in - let uu___1 = p_term_sep false false e in - (match uu___1 with - | (comm, doc_expr) -> - let doc_expr1 = - inline_comment_or_above comm doc_expr FStar_Pprint.empty in - let uu___2 = - let uu___3 = - FStar_Pprint.op_Hat_Slash_Hat FStar_Pprint.equals - doc_expr1 in - FStar_Pprint.op_Hat_Slash_Hat doc_pat uu___3 in - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = jump2 doc_expr1 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.equals uu___7 in - FStar_Pprint.group uu___6 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___5 in - FStar_Pprint.op_Hat_Hat doc_pat uu___4 in - FStar_Pprint.ifflat uu___2 uu___3) -and (p_term_list : - Prims.bool -> - Prims.bool -> FStar_Parser_AST.term Prims.list -> FStar_Pprint.document) - = - fun ps -> - fun pb -> - fun l -> - let rec aux uu___ = - match uu___ with - | [] -> FStar_Pprint.empty - | x::[] -> p_term ps pb x - | x::xs -> - let uu___1 = p_term ps pb x in - let uu___2 = - let uu___3 = str ";" in - let uu___4 = aux xs in FStar_Pprint.op_Hat_Hat uu___3 uu___4 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - let uu___ = str "[" in - let uu___1 = - let uu___2 = aux l in - let uu___3 = str "]" in FStar_Pprint.op_Hat_Hat uu___2 uu___3 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 -and (p_newEffect : FStar_Parser_AST.effect_decl -> FStar_Pprint.document) = - fun uu___ -> - match uu___ with - | FStar_Parser_AST.RedefineEffect (lid, bs, t) -> - p_effectRedefinition lid bs t - | FStar_Parser_AST.DefineEffect (lid, bs, t, eff_decls) -> - p_effectDefinition lid bs t eff_decls -and (p_effectRedefinition : - FStar_Ident.ident -> - FStar_Parser_AST.binder Prims.list -> - FStar_Parser_AST.term -> FStar_Pprint.document) - = - fun uid -> - fun bs -> - fun t -> - let uu___ = p_uident uid in - let uu___1 = p_binders true bs in - let uu___2 = - let uu___3 = p_simpleTerm false false t in - prefix2 FStar_Pprint.equals uu___3 in - surround_maybe_empty (Prims.of_int (2)) Prims.int_one uu___ uu___1 - uu___2 -and (p_effectDefinition : - FStar_Ident.ident -> - FStar_Parser_AST.binder Prims.list -> - FStar_Parser_AST.term -> - FStar_Parser_AST.decl Prims.list -> FStar_Pprint.document) - = - fun uid -> - fun bs -> - fun t -> - fun eff_decls -> - let binders = p_binders true bs in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = p_uident uid in - let uu___4 = p_binders true bs in - let uu___5 = - let uu___6 = p_typ false false t in - prefix2 FStar_Pprint.colon uu___6 in - surround_maybe_empty (Prims.of_int (2)) Prims.int_one uu___3 - uu___4 uu___5 in - FStar_Pprint.group uu___2 in - let uu___2 = - let uu___3 = str "with" in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.semi - FStar_Pprint.space in - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline uu___9 in - separate_map_last uu___8 p_effectDecl eff_decls in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___7 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___6 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline uu___5 in - FStar_Pprint.op_Hat_Hat uu___3 uu___4 in - FStar_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in - braces_with_nesting uu___ -and (p_effectDecl : - Prims.bool -> FStar_Parser_AST.decl -> FStar_Pprint.document) = - fun ps -> - fun d -> - match d.FStar_Parser_AST.d with - | FStar_Parser_AST.Tycon - (false, uu___, (FStar_Parser_AST.TyconAbbrev - (lid, [], FStar_Pervasives_Native.None, e))::[]) - -> - let uu___1 = - let uu___2 = p_lident lid in - let uu___3 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.space FStar_Pprint.equals in - FStar_Pprint.op_Hat_Hat uu___2 uu___3 in - let uu___2 = p_simpleTerm ps false e in prefix2 uu___1 uu___2 - | uu___ -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Parser_AST.showable_decl d in - FStar_Compiler_Util.format1 - "Not a declaration of an effect member... or at least I hope so : %s" - uu___2 in - failwith uu___1 -and (p_subEffect : FStar_Parser_AST.lift -> FStar_Pprint.document) = - fun lift -> - let lift_op_doc = - let lifts = - match lift.FStar_Parser_AST.lift_op with - | FStar_Parser_AST.NonReifiableLift t -> [("lift_wp", t)] - | FStar_Parser_AST.ReifiableLift (t1, t2) -> - [("lift_wp", t1); ("lift", t2)] - | FStar_Parser_AST.LiftForFree t -> [("lift", t)] in - let p_lift ps uu___ = - match uu___ with - | (kwd, t) -> - let uu___1 = - let uu___2 = str kwd in - let uu___3 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.space - FStar_Pprint.equals in - FStar_Pprint.op_Hat_Hat uu___2 uu___3 in - let uu___2 = p_simpleTerm ps false t in prefix2 uu___1 uu___2 in - separate_break_map_last FStar_Pprint.semi p_lift lifts in - let uu___ = - let uu___1 = - let uu___2 = p_quident lift.FStar_Parser_AST.msource in - let uu___3 = - let uu___4 = str "~>" in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___4 in - FStar_Pprint.op_Hat_Hat uu___2 uu___3 in - let uu___2 = p_quident lift.FStar_Parser_AST.mdest in - prefix2 uu___1 uu___2 in - let uu___1 = - let uu___2 = braces_with_nesting lift_op_doc in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___2 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 -and (p_qualifier : FStar_Parser_AST.qualifier -> FStar_Pprint.document) = - fun uu___ -> - match uu___ with - | FStar_Parser_AST.Private -> str "private" - | FStar_Parser_AST.Noeq -> str "noeq" - | FStar_Parser_AST.Unopteq -> str "unopteq" - | FStar_Parser_AST.Assumption -> str "assume" - | FStar_Parser_AST.DefaultEffect -> str "default" - | FStar_Parser_AST.TotalEffect -> str "total" - | FStar_Parser_AST.Effect_qual -> FStar_Pprint.empty - | FStar_Parser_AST.New -> str "new" - | FStar_Parser_AST.Inline -> str "inline" - | FStar_Parser_AST.Visible -> FStar_Pprint.empty - | FStar_Parser_AST.Unfold_for_unification_and_vcgen -> str "unfold" - | FStar_Parser_AST.Inline_for_extraction -> str "inline_for_extraction" - | FStar_Parser_AST.Irreducible -> str "irreducible" - | FStar_Parser_AST.NoExtract -> str "noextract" - | FStar_Parser_AST.Reifiable -> str "reifiable" - | FStar_Parser_AST.Reflectable -> str "reflectable" - | FStar_Parser_AST.Opaque -> str "opaque" - | FStar_Parser_AST.Logic -> str "logic" -and (p_qualifiers : FStar_Parser_AST.qualifiers -> FStar_Pprint.document) = - fun qs -> - match qs with - | [] -> FStar_Pprint.empty - | q::[] -> - let uu___ = p_qualifier q in - FStar_Pprint.op_Hat_Hat uu___ FStar_Pprint.hardline - | uu___ -> - let uu___1 = - let uu___2 = FStar_Compiler_List.map p_qualifier qs in - FStar_Pprint.flow break1 uu___2 in - FStar_Pprint.op_Hat_Hat uu___1 FStar_Pprint.hardline -and (p_letqualifier : - FStar_Parser_AST.let_qualifier -> FStar_Pprint.document) = - fun uu___ -> - match uu___ with - | FStar_Parser_AST.Rec -> - let uu___1 = str "rec" in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___1 - | FStar_Parser_AST.NoLetQualifier -> FStar_Pprint.empty -and (p_aqual : FStar_Parser_AST.arg_qualifier -> FStar_Pprint.document) = - fun uu___ -> - match uu___ with - | FStar_Parser_AST.Implicit -> str "#" - | FStar_Parser_AST.Equality -> str "$" - | FStar_Parser_AST.Meta t -> - let t1 = - match t.FStar_Parser_AST.tm with - | FStar_Parser_AST.Abs (uu___1, e) -> e - | uu___1 -> - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Parser_AST.unit_const t.FStar_Parser_AST.range in - (t, uu___4, FStar_Parser_AST.Nothing) in - FStar_Parser_AST.App uu___3 in - FStar_Parser_AST.mk_term uu___2 t.FStar_Parser_AST.range - FStar_Parser_AST.Expr in - let uu___1 = str "#[" in - let uu___2 = - let uu___3 = p_term false false t1 in - let uu___4 = - let uu___5 = str "]" in FStar_Pprint.op_Hat_Hat uu___5 break1 in - FStar_Pprint.op_Hat_Hat uu___3 uu___4 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 - | FStar_Parser_AST.TypeClassArg -> FStar_Pprint.empty -and (p_disjunctivePattern : - FStar_Parser_AST.pattern -> FStar_Pprint.document) = - fun p -> - match p.FStar_Parser_AST.pat with - | FStar_Parser_AST.PatOr pats -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.bar FStar_Pprint.space in - FStar_Pprint.op_Hat_Hat break1 uu___2 in - FStar_Pprint.separate_map uu___1 p_tuplePattern pats in - FStar_Pprint.group uu___ - | uu___ -> p_tuplePattern p -and (p_tuplePattern : FStar_Parser_AST.pattern -> FStar_Pprint.document) = - fun p -> - match p.FStar_Parser_AST.pat with - | FStar_Parser_AST.PatTuple (pats, false) -> - let uu___ = - let uu___1 = FStar_Pprint.op_Hat_Hat FStar_Pprint.comma break1 in - FStar_Pprint.separate_map uu___1 p_constructorPattern pats in - FStar_Pprint.group uu___ - | uu___ -> p_constructorPattern p -and (p_constructorPattern : - FStar_Parser_AST.pattern -> FStar_Pprint.document) = - fun p -> - match p.FStar_Parser_AST.pat with - | FStar_Parser_AST.PatApp - ({ FStar_Parser_AST.pat = FStar_Parser_AST.PatName maybe_cons_lid; - FStar_Parser_AST.prange = uu___;_}, - hd::tl::[]) - when - FStar_Ident.lid_equals maybe_cons_lid FStar_Parser_Const.cons_lid -> - let uu___1 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.colon FStar_Pprint.colon in - let uu___2 = p_constructorPattern hd in - let uu___3 = p_constructorPattern tl in infix0 uu___1 uu___2 uu___3 - | FStar_Parser_AST.PatApp - ({ FStar_Parser_AST.pat = FStar_Parser_AST.PatName uid; - FStar_Parser_AST.prange = uu___;_}, - pats) - -> - let uu___1 = p_quident uid in - let uu___2 = FStar_Pprint.separate_map break1 p_atomicPattern pats in - prefix2 uu___1 uu___2 - | uu___ -> p_atomicPattern p -and (p_atomicPattern : FStar_Parser_AST.pattern -> FStar_Pprint.document) = - fun p -> - match p.FStar_Parser_AST.pat with - | FStar_Parser_AST.PatAscribed (pat, (t, FStar_Pervasives_Native.None)) - -> - (match ((pat.FStar_Parser_AST.pat), (t.FStar_Parser_AST.tm)) with - | (FStar_Parser_AST.PatVar (lid, aqual, attrs), - FStar_Parser_AST.Refine - ({ FStar_Parser_AST.b = FStar_Parser_AST.Annotated (lid', t1); - FStar_Parser_AST.brange = uu___; - FStar_Parser_AST.blevel = uu___1; - FStar_Parser_AST.aqual = uu___2; - FStar_Parser_AST.battributes = uu___3;_}, - phi)) when - let uu___4 = FStar_Ident.string_of_id lid in - let uu___5 = FStar_Ident.string_of_id lid' in uu___4 = uu___5 -> - let uu___4 = - let uu___5 = p_ident lid in - p_refinement aqual attrs uu___5 t1 phi in - soft_parens_with_nesting uu___4 - | (FStar_Parser_AST.PatWild (aqual, attrs), FStar_Parser_AST.Refine - ({ FStar_Parser_AST.b = FStar_Parser_AST.NoName t1; - FStar_Parser_AST.brange = uu___; - FStar_Parser_AST.blevel = uu___1; - FStar_Parser_AST.aqual = uu___2; - FStar_Parser_AST.battributes = uu___3;_}, - phi)) -> - let uu___4 = - p_refinement aqual attrs FStar_Pprint.underscore t1 phi in - soft_parens_with_nesting uu___4 - | (FStar_Parser_AST.PatVar (uu___, aqual, uu___1), uu___2) -> - let wrap = - if - aqual = - (FStar_Pervasives_Native.Some - FStar_Parser_AST.TypeClassArg) - then tc_arg - else soft_parens_with_nesting in - let uu___3 = - let uu___4 = p_tuplePattern pat in - let uu___5 = - let uu___6 = p_tmEqNoRefinement t in - FStar_Pprint.op_Hat_Slash_Hat FStar_Pprint.colon uu___6 in - FStar_Pprint.op_Hat_Hat uu___4 uu___5 in - wrap uu___3 - | (FStar_Parser_AST.PatWild (aqual, uu___), uu___1) -> - let wrap = - if - aqual = - (FStar_Pervasives_Native.Some - FStar_Parser_AST.TypeClassArg) - then tc_arg - else soft_parens_with_nesting in - let uu___2 = - let uu___3 = p_tuplePattern pat in - let uu___4 = - let uu___5 = p_tmEqNoRefinement t in - FStar_Pprint.op_Hat_Slash_Hat FStar_Pprint.colon uu___5 in - FStar_Pprint.op_Hat_Hat uu___3 uu___4 in - wrap uu___2 - | uu___ -> - let uu___1 = - let uu___2 = p_tuplePattern pat in - let uu___3 = - let uu___4 = p_tmEqNoRefinement t in - FStar_Pprint.op_Hat_Slash_Hat FStar_Pprint.colon uu___4 in - FStar_Pprint.op_Hat_Hat uu___2 uu___3 in - soft_parens_with_nesting uu___1) - | FStar_Parser_AST.PatList pats -> - let uu___ = separate_break_map FStar_Pprint.semi p_tuplePattern pats in - FStar_Pprint.surround (Prims.of_int (2)) Prims.int_zero - FStar_Pprint.lbracket uu___ FStar_Pprint.rbracket - | FStar_Parser_AST.PatRecord pats -> - let p_recordFieldPat uu___ = - match uu___ with - | (lid, pat) -> - let uu___1 = p_qlident lid in - let uu___2 = p_tuplePattern pat in - infix2 FStar_Pprint.equals uu___1 uu___2 in - let uu___ = - separate_break_map FStar_Pprint.semi p_recordFieldPat pats in - soft_braces_with_nesting uu___ - | FStar_Parser_AST.PatTuple (pats, true) -> - let uu___ = - FStar_Pprint.op_Hat_Hat FStar_Pprint.lparen FStar_Pprint.bar in - let uu___1 = - separate_break_map FStar_Pprint.comma p_constructorPattern pats in - let uu___2 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.bar FStar_Pprint.rparen in - FStar_Pprint.surround (Prims.of_int (2)) Prims.int_one uu___ uu___1 - uu___2 - | FStar_Parser_AST.PatTvar (tv, arg_qualifier_opt, attrs) -> p_tvar tv - | FStar_Parser_AST.PatOp op -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Ident.string_of_id op in str uu___3 in - let uu___3 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.space FStar_Pprint.rparen in - FStar_Pprint.op_Hat_Hat uu___2 uu___3 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___1 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.lparen uu___ - | FStar_Parser_AST.PatWild (aqual, attrs) -> - let uu___ = FStar_Pprint.optional p_aqual aqual in - let uu___1 = - let uu___2 = p_attributes false attrs in - FStar_Pprint.op_Hat_Hat uu___2 FStar_Pprint.underscore in - FStar_Pprint.op_Hat_Hat uu___ uu___1 - | FStar_Parser_AST.PatConst c -> p_constant c - | FStar_Parser_AST.PatVQuote e -> - let uu___ = - let uu___1 = str "`%" in - let uu___2 = p_noSeqTermAndComment false false e in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | FStar_Parser_AST.PatVar (lid, aqual, attrs) -> - let uu___ = FStar_Pprint.optional p_aqual aqual in - let uu___1 = - let uu___2 = p_attributes false attrs in - let uu___3 = p_lident lid in FStar_Pprint.op_Hat_Hat uu___2 uu___3 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 - | FStar_Parser_AST.PatName uid -> p_quident uid - | FStar_Parser_AST.PatOr uu___ -> failwith "Inner or pattern !" - | FStar_Parser_AST.PatApp - ({ FStar_Parser_AST.pat = FStar_Parser_AST.PatName uu___; - FStar_Parser_AST.prange = uu___1;_}, - uu___2) - -> let uu___3 = p_tuplePattern p in soft_parens_with_nesting uu___3 - | FStar_Parser_AST.PatTuple (uu___, false) -> - let uu___1 = p_tuplePattern p in soft_parens_with_nesting uu___1 - | uu___ -> - let uu___1 = - let uu___2 = FStar_Parser_AST.pat_to_string p in - FStar_Compiler_Util.format1 "Invalid pattern %s" uu___2 in - failwith uu___1 -and (is_typ_tuple : FStar_Parser_AST.term -> Prims.bool) = - fun e -> - match e.FStar_Parser_AST.tm with - | FStar_Parser_AST.Op (id, uu___) when - let uu___1 = FStar_Ident.string_of_id id in uu___1 = "*" -> true - | uu___ -> false -and (p_binder : - Prims.bool -> FStar_Parser_AST.binder -> FStar_Pprint.document) = - fun is_atomic -> - fun b -> - let is_tc = is_tc_binder b in - let uu___ = p_binder' false (is_atomic && (Prims.op_Negation is_tc)) b in - match uu___ with - | (b', t') -> - let d = - match t' with - | FStar_Pervasives_Native.Some (typ, catf1) -> catf1 b' typ - | FStar_Pervasives_Native.None -> b' in - if is_tc then tc_arg d else d -and (p_binder' : - Prims.bool -> - Prims.bool -> - FStar_Parser_AST.binder -> - (FStar_Pprint.document * (FStar_Pprint.document * catf) - FStar_Pervasives_Native.option)) - = - fun no_pars -> - fun is_atomic -> - fun b -> - match b.FStar_Parser_AST.b with - | FStar_Parser_AST.Variable lid -> - let uu___ = - let uu___1 = - FStar_Pprint.optional p_aqual b.FStar_Parser_AST.aqual in - let uu___2 = - let uu___3 = - p_attributes false b.FStar_Parser_AST.battributes in - let uu___4 = p_lident lid in - FStar_Pprint.op_Hat_Hat uu___3 uu___4 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - (uu___, FStar_Pervasives_Native.None) - | FStar_Parser_AST.TVariable lid -> - let uu___ = - let uu___1 = p_attributes false b.FStar_Parser_AST.battributes in - let uu___2 = p_lident lid in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - (uu___, FStar_Pervasives_Native.None) - | FStar_Parser_AST.Annotated (lid, t) -> - let uu___ = - match t.FStar_Parser_AST.tm with - | FStar_Parser_AST.Refine - ({ - FStar_Parser_AST.b = FStar_Parser_AST.Annotated - (lid', t1); - FStar_Parser_AST.brange = uu___1; - FStar_Parser_AST.blevel = uu___2; - FStar_Parser_AST.aqual = uu___3; - FStar_Parser_AST.battributes = uu___4;_}, - phi) - when - let uu___5 = FStar_Ident.string_of_id lid in - let uu___6 = FStar_Ident.string_of_id lid' in - uu___5 = uu___6 -> - let uu___5 = p_lident lid in - p_refinement' b.FStar_Parser_AST.aqual - b.FStar_Parser_AST.battributes uu___5 t1 phi - | uu___1 -> - let t' = - let uu___2 = is_typ_tuple t in - if uu___2 - then - let uu___3 = p_tmFormula t in - soft_parens_with_nesting uu___3 - else p_tmFormula t in - let uu___2 = - let uu___3 = - FStar_Pprint.optional p_aqual b.FStar_Parser_AST.aqual in - let uu___4 = - let uu___5 = - p_attributes false b.FStar_Parser_AST.battributes in - let uu___6 = p_lident lid in - FStar_Pprint.op_Hat_Hat uu___5 uu___6 in - FStar_Pprint.op_Hat_Hat uu___3 uu___4 in - (uu___2, t') in - (match uu___ with - | (b', t') -> - let catf1 = - if - is_atomic || - ((is_meta_qualifier b.FStar_Parser_AST.aqual) && - (Prims.op_Negation no_pars)) - then - fun x -> - fun y -> - let uu___1 = - let uu___2 = - let uu___3 = cat_with_colon x y in - FStar_Pprint.op_Hat_Hat uu___3 - FStar_Pprint.rparen in - FStar_Pprint.op_Hat_Hat FStar_Pprint.lparen uu___2 in - FStar_Pprint.group uu___1 - else - (fun x -> - fun y -> - let uu___2 = cat_with_colon x y in - FStar_Pprint.group uu___2) in - (b', (FStar_Pervasives_Native.Some (t', catf1)))) - | FStar_Parser_AST.TAnnotated uu___ -> - failwith "Is this still used ?" - | FStar_Parser_AST.NoName t -> - (match t.FStar_Parser_AST.tm with - | FStar_Parser_AST.Refine - ({ FStar_Parser_AST.b = FStar_Parser_AST.NoName t1; - FStar_Parser_AST.brange = uu___; - FStar_Parser_AST.blevel = uu___1; - FStar_Parser_AST.aqual = uu___2; - FStar_Parser_AST.battributes = uu___3;_}, - phi) - -> - let uu___4 = - p_refinement' b.FStar_Parser_AST.aqual - b.FStar_Parser_AST.battributes FStar_Pprint.underscore - t1 phi in - (match uu___4 with - | (b', t') -> - (b', - (FStar_Pervasives_Native.Some (t', cat_with_colon)))) - | uu___ -> - let pref = - let uu___1 = - FStar_Pprint.optional p_aqual b.FStar_Parser_AST.aqual in - let uu___2 = - p_attributes false b.FStar_Parser_AST.battributes in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - let p_Tm = if is_atomic then p_atomicTerm else p_appTerm in - let uu___1 = - let uu___2 = p_Tm t in FStar_Pprint.op_Hat_Hat pref uu___2 in - (uu___1, FStar_Pervasives_Native.None)) -and (p_refinement : - FStar_Parser_AST.arg_qualifier FStar_Pervasives_Native.option -> - FStar_Parser_AST.term Prims.list -> - FStar_Pprint.document -> - FStar_Parser_AST.term -> - FStar_Parser_AST.term -> FStar_Pprint.document) - = - fun aqual_opt -> - fun attrs -> - fun binder -> - fun t -> - fun phi -> - let uu___ = p_refinement' aqual_opt attrs binder t phi in - match uu___ with | (b, typ) -> cat_with_colon b typ -and (p_refinement' : - FStar_Parser_AST.arg_qualifier FStar_Pervasives_Native.option -> - FStar_Parser_AST.term Prims.list -> - FStar_Pprint.document -> - FStar_Parser_AST.term -> - FStar_Parser_AST.term -> - (FStar_Pprint.document * FStar_Pprint.document)) - = - fun aqual_opt -> - fun attrs -> - fun binder -> - fun t -> - fun phi -> - let is_t_atomic = - match t.FStar_Parser_AST.tm with - | FStar_Parser_AST.Construct uu___ -> false - | FStar_Parser_AST.App uu___ -> false - | FStar_Parser_AST.Op uu___ -> false - | uu___ -> true in - let uu___ = p_noSeqTerm false false phi in - match uu___ with - | (comm, phi1) -> - let phi2 = - if comm = FStar_Pprint.empty - then phi1 - else - (let uu___2 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline phi1 in - FStar_Pprint.op_Hat_Hat comm uu___2) in - let jump_break = - if is_t_atomic then Prims.int_zero else Prims.int_one in - let uu___1 = - let uu___2 = FStar_Pprint.optional p_aqual aqual_opt in - let uu___3 = - let uu___4 = p_attributes false attrs in - FStar_Pprint.op_Hat_Hat uu___4 binder in - FStar_Pprint.op_Hat_Hat uu___2 uu___3 in - let uu___2 = - let uu___3 = p_appTerm t in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = soft_braces_with_nesting_tight phi2 in - let uu___8 = soft_braces_with_nesting phi2 in - FStar_Pprint.ifflat uu___7 uu___8 in - FStar_Pprint.group uu___6 in - FStar_Pprint.jump (Prims.of_int (2)) jump_break uu___5 in - FStar_Pprint.op_Hat_Hat uu___3 uu___4 in - (uu___1, uu___2) -and (p_binders_list : - Prims.bool -> - FStar_Parser_AST.binder Prims.list -> FStar_Pprint.document Prims.list) - = - fun is_atomic -> fun bs -> FStar_Compiler_List.map (p_binder is_atomic) bs -and (p_binders : - Prims.bool -> FStar_Parser_AST.binder Prims.list -> FStar_Pprint.document) - = - fun is_atomic -> - fun bs -> - let uu___ = p_binders_list is_atomic bs in - separate_or_flow break1 uu___ -and (p_binders_sep : - FStar_Parser_AST.binder Prims.list -> FStar_Pprint.document) = - fun bs -> - let uu___ = p_binders_list true bs in - FStar_Pprint.separate_map FStar_Pprint.space (fun x -> x) uu___ -and (paren_if : Prims.bool -> FStar_Pprint.document -> FStar_Pprint.document) - = fun b -> if b then soft_parens_with_nesting else (fun x -> x) -and (inline_comment_or_above : - FStar_Pprint.document -> - FStar_Pprint.document -> FStar_Pprint.document -> FStar_Pprint.document) - = - fun comm -> - fun doc -> - fun sep -> - if comm = FStar_Pprint.empty - then - let uu___ = FStar_Pprint.op_Hat_Hat doc sep in - FStar_Pprint.group uu___ - else - (let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Pprint.op_Hat_Hat break1 comm in - FStar_Pprint.op_Hat_Hat sep uu___5 in - FStar_Pprint.op_Hat_Hat doc uu___4 in - FStar_Pprint.group uu___3 in - let uu___3 = - let uu___4 = - let uu___5 = FStar_Pprint.op_Hat_Hat doc sep in - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline uu___5 in - FStar_Pprint.op_Hat_Hat comm uu___4 in - FStar_Pprint.ifflat uu___2 uu___3 in - FStar_Pprint.group uu___1) -and (p_term : - Prims.bool -> Prims.bool -> FStar_Parser_AST.term -> FStar_Pprint.document) - = - fun ps -> - fun pb -> - fun e -> - match e.FStar_Parser_AST.tm with - | FStar_Parser_AST.Seq (e1, e2) -> - let uu___ = p_noSeqTerm true false e1 in - (match uu___ with - | (comm, t1) -> - let uu___1 = - inline_comment_or_above comm t1 FStar_Pprint.semi in - let uu___2 = - let uu___3 = p_term ps pb e2 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline uu___3 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2) - | FStar_Parser_AST.Bind (x, e1, e2) -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = p_lident x in - let uu___4 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.space - FStar_Pprint.long_left_arrow in - FStar_Pprint.op_Hat_Hat uu___3 uu___4 in - let uu___3 = - let uu___4 = p_noSeqTermAndComment true false e1 in - let uu___5 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.space - FStar_Pprint.semi in - FStar_Pprint.op_Hat_Hat uu___4 uu___5 in - op_Hat_Slash_Plus_Hat uu___2 uu___3 in - FStar_Pprint.group uu___1 in - let uu___1 = p_term ps pb e2 in - FStar_Pprint.op_Hat_Slash_Hat uu___ uu___1 - | uu___ -> - let uu___1 = p_noSeqTermAndComment ps pb e in - FStar_Pprint.group uu___1 -and (p_term_sep : - Prims.bool -> - Prims.bool -> - FStar_Parser_AST.term -> - (FStar_Pprint.document * FStar_Pprint.document)) - = - fun ps -> - fun pb -> - fun e -> - match e.FStar_Parser_AST.tm with - | FStar_Parser_AST.Seq (e1, e2) -> - let uu___ = p_noSeqTerm true false e1 in - (match uu___ with - | (comm, t1) -> - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Pprint.op_Hat_Hat t1 FStar_Pprint.semi in - FStar_Pprint.group uu___3 in - let uu___3 = - let uu___4 = p_term ps pb e2 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline uu___4 in - FStar_Pprint.op_Hat_Hat uu___2 uu___3 in - (comm, uu___1)) - | FStar_Parser_AST.Bind (x, e1, e2) -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = p_lident x in - let uu___5 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.space - FStar_Pprint.long_left_arrow in - FStar_Pprint.op_Hat_Hat uu___4 uu___5 in - let uu___4 = - let uu___5 = p_noSeqTermAndComment true false e1 in - let uu___6 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.space - FStar_Pprint.semi in - FStar_Pprint.op_Hat_Hat uu___5 uu___6 in - op_Hat_Slash_Plus_Hat uu___3 uu___4 in - FStar_Pprint.group uu___2 in - let uu___2 = p_term ps pb e2 in - FStar_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in - (FStar_Pprint.empty, uu___) - | uu___ -> p_noSeqTerm ps pb e -and (p_noSeqTerm : - Prims.bool -> - Prims.bool -> - FStar_Parser_AST.term -> - (FStar_Pprint.document * FStar_Pprint.document)) - = - fun ps -> - fun pb -> - fun e -> - with_comment_sep (p_noSeqTerm' ps pb) e e.FStar_Parser_AST.range -and (p_noSeqTermAndComment : - Prims.bool -> Prims.bool -> FStar_Parser_AST.term -> FStar_Pprint.document) - = - fun ps -> - fun pb -> - fun e -> with_comment (p_noSeqTerm' ps pb) e e.FStar_Parser_AST.range -and (p_noSeqTerm' : - Prims.bool -> Prims.bool -> FStar_Parser_AST.term -> FStar_Pprint.document) - = - fun ps -> - fun pb -> - fun e -> - match e.FStar_Parser_AST.tm with - | FStar_Parser_AST.Ascribed - (e1, t, FStar_Pervasives_Native.None, use_eq) -> - let uu___ = - let uu___1 = p_tmIff e1 in - let uu___2 = - let uu___3 = - let uu___4 = p_typ ps pb t in - FStar_Pprint.op_Hat_Slash_Hat FStar_Pprint.colon uu___4 in - FStar_Pprint.op_Hat_Hat - (if use_eq - then FStar_Pprint.dollar - else FStar_Pprint.langle) uu___3 in - FStar_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | FStar_Parser_AST.Ascribed - (e1, t, FStar_Pervasives_Native.Some tac, use_eq) -> - let uu___ = - let uu___1 = p_tmIff e1 in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = p_typ false false t in - let uu___6 = - let uu___7 = str "by" in - let uu___8 = p_typ ps pb (maybe_unthunk tac) in - FStar_Pprint.op_Hat_Slash_Hat uu___7 uu___8 in - FStar_Pprint.op_Hat_Slash_Hat uu___5 uu___6 in - FStar_Pprint.op_Hat_Slash_Hat FStar_Pprint.colon uu___4 in - FStar_Pprint.op_Hat_Hat - (if use_eq - then FStar_Pprint.dollar - else FStar_Pprint.langle) uu___3 in - FStar_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | FStar_Parser_AST.Op (id, e1::e2::e3::[]) when - let uu___ = FStar_Ident.string_of_id id in uu___ = ".()<-" -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = p_atomicTermNotQUident e1 in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = p_term false false e2 in - soft_parens_with_nesting uu___7 in - let uu___7 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.space - FStar_Pprint.larrow in - FStar_Pprint.op_Hat_Hat uu___6 uu___7 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.dot uu___5 in - FStar_Pprint.op_Hat_Hat uu___3 uu___4 in - FStar_Pprint.group uu___2 in - let uu___2 = - let uu___3 = p_noSeqTermAndComment ps pb e3 in jump2 uu___3 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | FStar_Parser_AST.Op (id, e1::e2::e3::[]) when - let uu___ = FStar_Ident.string_of_id id in uu___ = ".[]<-" -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = p_atomicTermNotQUident e1 in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = p_term false false e2 in - soft_brackets_with_nesting uu___7 in - let uu___7 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.space - FStar_Pprint.larrow in - FStar_Pprint.op_Hat_Hat uu___6 uu___7 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.dot uu___5 in - FStar_Pprint.op_Hat_Hat uu___3 uu___4 in - FStar_Pprint.group uu___2 in - let uu___2 = - let uu___3 = p_noSeqTermAndComment ps pb e3 in jump2 uu___3 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | FStar_Parser_AST.Op (id, e1::e2::e3::[]) when - let uu___ = FStar_Ident.string_of_id id in uu___ = ".(||)<-" -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = p_atomicTermNotQUident e1 in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = p_term false false e2 in - soft_lens_access_with_nesting uu___7 in - let uu___7 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.space - FStar_Pprint.larrow in - FStar_Pprint.op_Hat_Hat uu___6 uu___7 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.dot uu___5 in - FStar_Pprint.op_Hat_Hat uu___3 uu___4 in - FStar_Pprint.group uu___2 in - let uu___2 = - let uu___3 = p_noSeqTermAndComment ps pb e3 in jump2 uu___3 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | FStar_Parser_AST.Op (id, e1::e2::e3::[]) when - let uu___ = FStar_Ident.string_of_id id in uu___ = ".[||]<-" -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = p_atomicTermNotQUident e1 in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = p_term false false e2 in - soft_brackets_lens_access_with_nesting uu___7 in - let uu___7 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.space - FStar_Pprint.larrow in - FStar_Pprint.op_Hat_Hat uu___6 uu___7 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.dot uu___5 in - FStar_Pprint.op_Hat_Hat uu___3 uu___4 in - FStar_Pprint.group uu___2 in - let uu___2 = - let uu___3 = p_noSeqTermAndComment ps pb e3 in jump2 uu___3 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | FStar_Parser_AST.Requires (e1, wtf) -> - let uu___ = - let uu___1 = str "requires" in - let uu___2 = p_typ ps pb e1 in - FStar_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | FStar_Parser_AST.Ensures (e1, wtf) -> - let uu___ = - let uu___1 = str "ensures" in - let uu___2 = p_typ ps pb e1 in - FStar_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | FStar_Parser_AST.WFOrder (rel, e1) -> p_dec_wf ps pb rel e1 - | FStar_Parser_AST.LexList l -> - let uu___ = - let uu___1 = str "%" in - let uu___2 = p_term_list ps pb l in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | FStar_Parser_AST.Decreases (e1, wtf) -> - let uu___ = - let uu___1 = str "decreases" in - let uu___2 = p_typ ps pb e1 in - FStar_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | FStar_Parser_AST.Attributes es -> - let uu___ = - let uu___1 = str "attributes" in - let uu___2 = FStar_Pprint.separate_map break1 p_atomicTerm es in - FStar_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | FStar_Parser_AST.If (e1, op_opt, ret_opt, e2, e3) -> - if is_unit e3 - then - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Compiler_Util.map_opt op_opt - FStar_Ident.string_of_id in - FStar_Compiler_Util.bind_opt uu___6 - (FStar_Parser_AST.strip_prefix "let") in - FStar_Compiler_Util.dflt "" uu___5 in - Prims.strcat "if" uu___4 in - str uu___3 in - let uu___3 = p_noSeqTermAndComment false false e1 in - op_Hat_Slash_Plus_Hat uu___2 uu___3 in - let uu___2 = - let uu___3 = str "then" in - let uu___4 = p_noSeqTermAndComment ps pb e2 in - op_Hat_Slash_Plus_Hat uu___3 uu___4 in - FStar_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - else - (let e2_doc = - match e2.FStar_Parser_AST.tm with - | FStar_Parser_AST.If (uu___1, uu___2, uu___3, uu___4, e31) - when is_unit e31 -> - let uu___5 = p_noSeqTermAndComment false false e2 in - soft_parens_with_nesting uu___5 - | uu___1 -> p_noSeqTermAndComment false false e2 in - match ret_opt with - | FStar_Pervasives_Native.None -> - let uu___1 = - let uu___2 = - let uu___3 = str "if" in - let uu___4 = p_noSeqTermAndComment false false e1 in - op_Hat_Slash_Plus_Hat uu___3 uu___4 in - let uu___3 = - let uu___4 = - let uu___5 = str "then" in - op_Hat_Slash_Plus_Hat uu___5 e2_doc in - let uu___5 = - let uu___6 = str "else" in - let uu___7 = p_noSeqTermAndComment ps pb e3 in - op_Hat_Slash_Plus_Hat uu___6 uu___7 in - FStar_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in - FStar_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in - FStar_Pprint.group uu___1 - | FStar_Pervasives_Native.Some (as_opt, ret, use_eq) -> - let uu___1 = - let uu___2 = - let uu___3 = str "if" in - let uu___4 = p_noSeqTermAndComment false false e1 in - op_Hat_Slash_Plus_Hat uu___3 uu___4 in - let uu___3 = - let uu___4 = - let uu___5 = - match as_opt with - | FStar_Pervasives_Native.None -> - FStar_Pprint.empty - | FStar_Pervasives_Native.Some as_ident -> - let uu___6 = str "as" in - let uu___7 = p_ident as_ident in - FStar_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in - let uu___6 = - let uu___7 = - str (if use_eq then "returns$" else "returns") in - let uu___8 = p_tmIff ret in - op_Hat_Slash_Plus_Hat uu___7 uu___8 in - FStar_Pprint.op_Hat_Slash_Hat uu___5 uu___6 in - let uu___5 = - let uu___6 = - let uu___7 = str "then" in - op_Hat_Slash_Plus_Hat uu___7 e2_doc in - let uu___7 = - let uu___8 = str "else" in - let uu___9 = p_noSeqTermAndComment ps pb e3 in - op_Hat_Slash_Plus_Hat uu___8 uu___9 in - FStar_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in - FStar_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in - FStar_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in - FStar_Pprint.group uu___1) - | FStar_Parser_AST.TryWith (e1, branches) -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = str "try" in - let uu___4 = p_noSeqTermAndComment false false e1 in - prefix2 uu___3 uu___4 in - let uu___3 = - let uu___4 = str "with" in - let uu___5 = - separate_map_last FStar_Pprint.hardline p_patternBranch - branches in - FStar_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in - FStar_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in - FStar_Pprint.group uu___1 in - let uu___1 = paren_if (ps || pb) in uu___1 uu___ - | FStar_Parser_AST.Match (e1, op_opt, ret_opt, branches) -> - let match_doc = - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Compiler_Util.map_opt op_opt - FStar_Ident.string_of_id in - FStar_Compiler_Util.bind_opt uu___3 - (FStar_Parser_AST.strip_prefix "let") in - FStar_Compiler_Util.dflt "" uu___2 in - Prims.strcat "match" uu___1 in - str uu___ in - let uu___ = - let uu___1 = - match ret_opt with - | FStar_Pervasives_Native.None -> - let uu___2 = - let uu___3 = p_noSeqTermAndComment false false e1 in - let uu___4 = str "with" in - FStar_Pprint.surround (Prims.of_int (2)) Prims.int_one - match_doc uu___3 uu___4 in - FStar_Pprint.group uu___2 - | FStar_Pervasives_Native.Some (as_opt, ret, use_eq) -> - let uu___2 = - let uu___3 = - let uu___4 = p_noSeqTermAndComment false false e1 in - let uu___5 = - let uu___6 = - match as_opt with - | FStar_Pervasives_Native.None -> - FStar_Pprint.empty - | FStar_Pervasives_Native.Some as_ident -> - let uu___7 = str "as" in - let uu___8 = p_ident as_ident in - op_Hat_Slash_Plus_Hat uu___7 uu___8 in - let uu___7 = - let uu___8 = - str (if use_eq then "returns$" else "returns") in - let uu___9 = p_tmIff ret in - op_Hat_Slash_Plus_Hat uu___8 uu___9 in - op_Hat_Slash_Plus_Hat uu___6 uu___7 in - op_Hat_Slash_Plus_Hat uu___4 uu___5 in - let uu___4 = str "with" in - FStar_Pprint.surround (Prims.of_int (2)) Prims.int_one - match_doc uu___3 uu___4 in - FStar_Pprint.group uu___2 in - let uu___2 = - separate_map_last FStar_Pprint.hardline p_patternBranch - branches in - FStar_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in - let uu___1 = paren_if (ps || pb) in uu___1 uu___ - | FStar_Parser_AST.LetOpen (uid, e1) -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = str "let open" in - let uu___4 = p_quident uid in - let uu___5 = str "in" in - FStar_Pprint.surround (Prims.of_int (2)) Prims.int_one - uu___3 uu___4 uu___5 in - let uu___3 = p_term false pb e1 in - FStar_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in - FStar_Pprint.group uu___1 in - let uu___1 = paren_if ps in uu___1 uu___ - | FStar_Parser_AST.LetOpenRecord (r, rty, e1) -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = str "let open" in - let uu___4 = p_term false pb r in - let uu___5 = str "as" in - FStar_Pprint.surround (Prims.of_int (2)) Prims.int_one - uu___3 uu___4 uu___5 in - let uu___3 = - let uu___4 = p_term false pb rty in - let uu___5 = - let uu___6 = str "in" in - let uu___7 = p_term false pb e1 in - FStar_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in - FStar_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in - FStar_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in - FStar_Pprint.group uu___1 in - let uu___1 = paren_if ps in uu___1 uu___ - | FStar_Parser_AST.LetOperator (lets, body) -> - let p_let uu___ is_last = - match uu___ with - | (id, pat, e1) -> - let doc_let_or_and = - let uu___1 = FStar_Ident.string_of_id id in str uu___1 in - let doc_pat = p_letlhs doc_let_or_and (pat, e1) true in - (match ((pat.FStar_Parser_AST.pat), - (e1.FStar_Parser_AST.tm)) - with - | (FStar_Parser_AST.PatVar (pid, uu___1, uu___2), - FStar_Parser_AST.Name tid) when - let uu___3 = FStar_Ident.string_of_id pid in - let uu___4 = - let uu___5 = FStar_Ident.path_of_lid tid in - FStar_Compiler_List.last uu___5 in - uu___3 = uu___4 -> - let uu___3 = - if is_last then str "in" else FStar_Pprint.empty in - FStar_Pprint.op_Hat_Slash_Hat doc_pat uu___3 - | (FStar_Parser_AST.PatVar (pid, uu___1, uu___2), - FStar_Parser_AST.Var tid) when - let uu___3 = FStar_Ident.string_of_id pid in - let uu___4 = - let uu___5 = FStar_Ident.path_of_lid tid in - FStar_Compiler_List.last uu___5 in - uu___3 = uu___4 -> - let uu___3 = - if is_last then str "in" else FStar_Pprint.empty in - FStar_Pprint.op_Hat_Slash_Hat doc_pat uu___3 - | uu___1 -> - let uu___2 = p_term_sep false false e1 in - (match uu___2 with - | (comm, doc_expr) -> - let doc_expr1 = - inline_comment_or_above comm doc_expr - FStar_Pprint.empty in - if is_last - then - let uu___3 = - FStar_Pprint.flow break1 - [doc_pat; FStar_Pprint.equals] in - let uu___4 = str "in" in - FStar_Pprint.surround (Prims.of_int (2)) - Prims.int_one uu___3 doc_expr1 uu___4 - else - (let uu___4 = - FStar_Pprint.flow break1 - [doc_pat; FStar_Pprint.equals; doc_expr1] in - FStar_Pprint.hang (Prims.of_int (2)) uu___4))) in - let l = FStar_Compiler_List.length lets in - let lets_docs = - FStar_Compiler_List.mapi - (fun i -> - fun lb -> - let uu___ = p_let lb (i = (l - Prims.int_one)) in - FStar_Pprint.group uu___) lets in - let lets_doc = - let uu___ = FStar_Pprint.separate break1 lets_docs in - FStar_Pprint.group uu___ in - let r = - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = p_term false pb body in - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline uu___3 in - FStar_Pprint.op_Hat_Hat lets_doc uu___2 in - FStar_Pprint.group uu___1 in - let uu___1 = paren_if ps in uu___1 uu___ in - r - | FStar_Parser_AST.Let (q, lbs, e1) -> - let p_lb q1 uu___ is_last = - match uu___ with - | (a, (pat, e2)) -> - let attrs = p_attrs_opt true a in - let doc_let_or_and = - match q1 with - | FStar_Pervasives_Native.Some (FStar_Parser_AST.Rec) -> - let uu___1 = - let uu___2 = str "let" in - let uu___3 = str "rec" in - FStar_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in - FStar_Pprint.group uu___1 - | FStar_Pervasives_Native.Some - (FStar_Parser_AST.NoLetQualifier) -> str "let" - | uu___1 -> str "and" in - let doc_pat = p_letlhs doc_let_or_and (pat, e2) true in - let uu___1 = p_term_sep false false e2 in - (match uu___1 with - | (comm, doc_expr) -> - let doc_expr1 = - inline_comment_or_above comm doc_expr - FStar_Pprint.empty in - let uu___2 = - if is_last - then - let uu___3 = - FStar_Pprint.flow break1 - [doc_pat; FStar_Pprint.equals] in - let uu___4 = str "in" in - FStar_Pprint.surround (Prims.of_int (2)) - Prims.int_one uu___3 doc_expr1 uu___4 - else - (let uu___4 = - FStar_Pprint.flow break1 - [doc_pat; FStar_Pprint.equals; doc_expr1] in - FStar_Pprint.hang (Prims.of_int (2)) uu___4) in - FStar_Pprint.op_Hat_Hat attrs uu___2) in - let l = FStar_Compiler_List.length lbs in - let lbs_docs = - FStar_Compiler_List.mapi - (fun i -> - fun lb -> - if i = Prims.int_zero - then - let uu___ = - p_lb (FStar_Pervasives_Native.Some q) lb - (i = (l - Prims.int_one)) in - FStar_Pprint.group uu___ - else - (let uu___1 = - p_lb FStar_Pervasives_Native.None lb - (i = (l - Prims.int_one)) in - FStar_Pprint.group uu___1)) lbs in - let lbs_doc = - let uu___ = FStar_Pprint.separate break1 lbs_docs in - FStar_Pprint.group uu___ in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = p_term false pb e1 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline uu___3 in - FStar_Pprint.op_Hat_Hat lbs_doc uu___2 in - FStar_Pprint.group uu___1 in - let uu___1 = paren_if ps in uu___1 uu___ - | FStar_Parser_AST.Quote (e1, FStar_Parser_AST.Dynamic) -> - let uu___ = - let uu___1 = str "quote" in - let uu___2 = p_noSeqTermAndComment ps pb e1 in - FStar_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | FStar_Parser_AST.Quote (e1, FStar_Parser_AST.Static) -> - let uu___ = - let uu___1 = str "`" in - let uu___2 = p_noSeqTermAndComment ps pb e1 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | FStar_Parser_AST.VQuote e1 -> - let uu___ = - let uu___1 = str "`%" in - let uu___2 = p_noSeqTermAndComment ps pb e1 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | FStar_Parser_AST.Antiquote - { - FStar_Parser_AST.tm = FStar_Parser_AST.Quote - (e1, FStar_Parser_AST.Dynamic); - FStar_Parser_AST.range = uu___; - FStar_Parser_AST.level = uu___1;_} - -> - let uu___2 = - let uu___3 = str "`@" in - let uu___4 = p_noSeqTermAndComment ps pb e1 in - FStar_Pprint.op_Hat_Hat uu___3 uu___4 in - FStar_Pprint.group uu___2 - | FStar_Parser_AST.Antiquote e1 -> - let uu___ = - let uu___1 = str "`#" in - let uu___2 = p_noSeqTermAndComment ps pb e1 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | FStar_Parser_AST.CalcProof (rel, init, steps) -> - let head = - let uu___ = str "calc" in - let uu___1 = - let uu___2 = - let uu___3 = p_noSeqTermAndComment false false rel in - let uu___4 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.space - FStar_Pprint.lbrace in - FStar_Pprint.op_Hat_Hat uu___3 uu___4 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___2 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 in - let bot = FStar_Pprint.rbrace in - let uu___ = FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline bot in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = p_noSeqTermAndComment false false init in - let uu___5 = - let uu___6 = str ";" in - let uu___7 = - let uu___8 = - separate_map_last FStar_Pprint.hardline p_calcStep - steps in - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline uu___8 in - FStar_Pprint.op_Hat_Hat uu___6 uu___7 in - FStar_Pprint.op_Hat_Hat uu___4 uu___5 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline uu___3 in - FStar_Pprint.nest (Prims.of_int (2)) uu___2 in - FStar_Pprint.enclose head uu___ uu___1 - | FStar_Parser_AST.IntroForall (xs, p, e1) -> - let p1 = p_noSeqTermAndComment false false p in - let e2 = p_noSeqTermAndComment false false e1 in - let xs1 = p_binders_sep xs in - let uu___ = str "introduce forall" in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = str "." in - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = str "with" in - let uu___11 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.space e2 in - FStar_Pprint.op_Hat_Hat uu___10 uu___11 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline - uu___9 in - FStar_Pprint.op_Hat_Hat p1 uu___8 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___7 in - FStar_Pprint.op_Hat_Hat uu___5 uu___6 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___4 in - FStar_Pprint.op_Hat_Hat xs1 uu___3 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___2 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 - | FStar_Parser_AST.IntroExists (xs, p, vs, e1) -> - let p1 = p_noSeqTermAndComment false false p in - let e2 = p_noSeqTermAndComment false false e1 in - let xs1 = p_binders_sep xs in - let uu___ = str "introduce" in - let uu___1 = - let uu___2 = - let uu___3 = str "exists" in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = str "." in - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = str "with" in - let uu___12 = - let uu___13 = - let uu___14 = - FStar_Pprint.separate_map - FStar_Pprint.space p_atomicTerm vs in - let uu___15 = - let uu___16 = - let uu___17 = str "and" in - let uu___18 = - FStar_Pprint.op_Hat_Hat - FStar_Pprint.space e2 in - FStar_Pprint.op_Hat_Hat uu___17 uu___18 in - FStar_Pprint.op_Hat_Hat - FStar_Pprint.hardline uu___16 in - FStar_Pprint.op_Hat_Hat uu___14 uu___15 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space - uu___13 in - FStar_Pprint.op_Hat_Hat uu___11 uu___12 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline - uu___10 in - FStar_Pprint.op_Hat_Hat p1 uu___9 in - FStar_Pprint.op_Hat_Hat uu___7 uu___8 in - FStar_Pprint.op_Hat_Hat xs1 uu___6 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___5 in - FStar_Pprint.op_Hat_Hat uu___3 uu___4 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___2 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 - | FStar_Parser_AST.IntroImplies (p, q, x, e1) -> - let p1 = p_tmFormula p in - let q1 = p_tmFormula q in - let e2 = p_noSeqTermAndComment false false e1 in - let x1 = p_binders_sep [x] in - let uu___ = str "introduce" in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = str "==>" in - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = str "with" in - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = str "." in - let uu___15 = - FStar_Pprint.op_Hat_Hat - FStar_Pprint.space e2 in - FStar_Pprint.op_Hat_Hat uu___14 uu___15 in - FStar_Pprint.op_Hat_Hat x1 uu___13 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space - uu___12 in - FStar_Pprint.op_Hat_Hat uu___10 uu___11 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline - uu___9 in - FStar_Pprint.op_Hat_Hat q1 uu___8 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___7 in - FStar_Pprint.op_Hat_Hat uu___5 uu___6 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___4 in - FStar_Pprint.op_Hat_Hat p1 uu___3 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___2 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 - | FStar_Parser_AST.IntroOr (b, p, q, e1) -> - let p1 = p_tmFormula p in - let q1 = p_tmFormula q in - let e2 = p_noSeqTermAndComment false false e1 in - let uu___ = str "introduce" in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = str "\\/" in - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = str "with" in - let uu___11 = - let uu___12 = - let uu___13 = - if b then str "Left" else str "Right" in - let uu___14 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.space - e2 in - FStar_Pprint.op_Hat_Hat uu___13 uu___14 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space - uu___12 in - FStar_Pprint.op_Hat_Hat uu___10 uu___11 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline - uu___9 in - FStar_Pprint.op_Hat_Hat q1 uu___8 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___7 in - FStar_Pprint.op_Hat_Hat uu___5 uu___6 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___4 in - FStar_Pprint.op_Hat_Hat p1 uu___3 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___2 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 - | FStar_Parser_AST.IntroAnd (p, q, e1, e2) -> - let p1 = p_tmFormula p in - let q1 = p_tmTuple q in - let e11 = p_noSeqTermAndComment false false e1 in - let e21 = p_noSeqTermAndComment false false e2 in - let uu___ = str "introduce" in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = str "/\\" in - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = str "with" in - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = str "and" in - let uu___16 = - FStar_Pprint.op_Hat_Hat - FStar_Pprint.space e21 in - FStar_Pprint.op_Hat_Hat uu___15 uu___16 in - FStar_Pprint.op_Hat_Hat - FStar_Pprint.hardline uu___14 in - FStar_Pprint.op_Hat_Hat e11 uu___13 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space - uu___12 in - FStar_Pprint.op_Hat_Hat uu___10 uu___11 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline - uu___9 in - FStar_Pprint.op_Hat_Hat q1 uu___8 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___7 in - FStar_Pprint.op_Hat_Hat uu___5 uu___6 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___4 in - FStar_Pprint.op_Hat_Hat p1 uu___3 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___2 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 - | FStar_Parser_AST.ElimForall (xs, p, vs) -> - let xs1 = p_binders_sep xs in - let p1 = p_noSeqTermAndComment false false p in - let vs1 = - FStar_Pprint.separate_map FStar_Pprint.space p_atomicTerm vs in - let uu___ = str "eliminate" in - let uu___1 = - let uu___2 = - let uu___3 = str "forall" in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = str "." in - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = str "with" in - let uu___13 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.space - vs1 in - FStar_Pprint.op_Hat_Hat uu___12 uu___13 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline - uu___11 in - FStar_Pprint.op_Hat_Hat p1 uu___10 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___9 in - FStar_Pprint.op_Hat_Hat uu___7 uu___8 in - FStar_Pprint.op_Hat_Hat xs1 uu___6 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___5 in - FStar_Pprint.op_Hat_Hat uu___3 uu___4 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___2 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 - | FStar_Parser_AST.ElimExists (bs, p, q, b, e1) -> - let head = - let uu___ = str "eliminate exists" in - let uu___1 = - let uu___2 = - let uu___3 = p_binders_sep bs in - let uu___4 = str "." in - FStar_Pprint.op_Hat_Hat uu___3 uu___4 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___2 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 in - let p1 = p_noSeqTermAndComment false false p in - let q1 = p_noSeqTermAndComment false false q in - let e2 = p_noSeqTermAndComment false false e1 in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = str "returns" in - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = str "with" in - let uu___10 = - let uu___11 = - let uu___12 = p_binders_sep [b] in - let uu___13 = - let uu___14 = str "." in - let uu___15 = - FStar_Pprint.op_Hat_Hat - FStar_Pprint.hardline e2 in - FStar_Pprint.op_Hat_Hat uu___14 uu___15 in - FStar_Pprint.op_Hat_Hat uu___12 uu___13 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space - uu___11 in - FStar_Pprint.op_Hat_Hat uu___9 uu___10 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline - uu___8 in - FStar_Pprint.op_Hat_Hat q1 uu___7 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___6 in - FStar_Pprint.op_Hat_Hat uu___4 uu___5 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline uu___3 in - FStar_Pprint.op_Hat_Hat p1 uu___2 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline uu___1 in - FStar_Pprint.op_Hat_Hat head uu___ - | FStar_Parser_AST.ElimImplies (p, q, e1) -> - let p1 = p_tmFormula p in - let q1 = p_tmFormula q in - let e2 = p_noSeqTermAndComment false false e1 in - let uu___ = str "eliminate" in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = str "==>" in - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = str "with" in - let uu___11 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.space e2 in - FStar_Pprint.op_Hat_Hat uu___10 uu___11 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline - uu___9 in - FStar_Pprint.op_Hat_Hat q1 uu___8 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___7 in - FStar_Pprint.op_Hat_Hat uu___5 uu___6 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___4 in - FStar_Pprint.op_Hat_Hat p1 uu___3 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___2 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 - | FStar_Parser_AST.ElimOr (p, q, r, x, e1, y, e2) -> - let p1 = p_tmFormula p in - let q1 = p_tmFormula q in - let r1 = p_noSeqTermAndComment false false r in - let x1 = p_binders_sep [x] in - let e11 = p_noSeqTermAndComment false false e1 in - let y1 = p_binders_sep [y] in - let e21 = p_noSeqTermAndComment false false e2 in - let uu___ = str "eliminate" in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = str "\\/" in - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = str "returns" in - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = str "with" in - let uu___16 = - let uu___17 = - let uu___18 = - let uu___19 = - let uu___20 = str "." in - let uu___21 = - let uu___22 = - let uu___23 = - let uu___24 = - let uu___25 = str "and" in - let uu___26 = - let uu___27 = - let uu___28 = - let uu___29 = - let uu___30 = - str "." in - let uu___31 = - FStar_Pprint.op_Hat_Hat - FStar_Pprint.space - e21 in - FStar_Pprint.op_Hat_Hat - uu___30 uu___31 in - FStar_Pprint.op_Hat_Hat - FStar_Pprint.space - uu___29 in - FStar_Pprint.op_Hat_Hat - y1 uu___28 in - FStar_Pprint.op_Hat_Hat - FStar_Pprint.space - uu___27 in - FStar_Pprint.op_Hat_Hat - uu___25 uu___26 in - FStar_Pprint.op_Hat_Hat - FStar_Pprint.hardline - uu___24 in - FStar_Pprint.op_Hat_Hat e11 - uu___23 in - FStar_Pprint.op_Hat_Hat - FStar_Pprint.space uu___22 in - FStar_Pprint.op_Hat_Hat uu___20 - uu___21 in - FStar_Pprint.op_Hat_Hat - FStar_Pprint.space uu___19 in - FStar_Pprint.op_Hat_Hat x1 uu___18 in - FStar_Pprint.op_Hat_Hat - FStar_Pprint.space uu___17 in - FStar_Pprint.op_Hat_Hat uu___15 uu___16 in - FStar_Pprint.op_Hat_Hat - FStar_Pprint.hardline uu___14 in - FStar_Pprint.op_Hat_Hat r1 uu___13 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space - uu___12 in - FStar_Pprint.op_Hat_Hat uu___10 uu___11 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline - uu___9 in - FStar_Pprint.op_Hat_Hat q1 uu___8 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___7 in - FStar_Pprint.op_Hat_Hat uu___5 uu___6 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___4 in - FStar_Pprint.op_Hat_Hat p1 uu___3 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___2 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 - | FStar_Parser_AST.ElimAnd (p, q, r, x, y, e1) -> - let p1 = p_tmFormula p in - let q1 = p_tmTuple q in - let r1 = p_noSeqTermAndComment false false r in - let xy = p_binders_sep [x; y] in - let e2 = p_noSeqTermAndComment false false e1 in - let uu___ = str "eliminate" in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = str "/\\" in - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = str "returns" in - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = str "with" in - let uu___16 = - let uu___17 = - let uu___18 = - let uu___19 = - let uu___20 = str "." in - let uu___21 = - FStar_Pprint.op_Hat_Hat - FStar_Pprint.space e2 in - FStar_Pprint.op_Hat_Hat uu___20 - uu___21 in - FStar_Pprint.op_Hat_Hat - FStar_Pprint.space uu___19 in - FStar_Pprint.op_Hat_Hat xy uu___18 in - FStar_Pprint.op_Hat_Hat - FStar_Pprint.space uu___17 in - FStar_Pprint.op_Hat_Hat uu___15 uu___16 in - FStar_Pprint.op_Hat_Hat - FStar_Pprint.hardline uu___14 in - FStar_Pprint.op_Hat_Hat r1 uu___13 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space - uu___12 in - FStar_Pprint.op_Hat_Hat uu___10 uu___11 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline - uu___9 in - FStar_Pprint.op_Hat_Hat q1 uu___8 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___7 in - FStar_Pprint.op_Hat_Hat uu___5 uu___6 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___4 in - FStar_Pprint.op_Hat_Hat p1 uu___3 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___2 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 - | uu___ -> p_typ ps pb e -and (p_dec_wf : - Prims.bool -> - Prims.bool -> - FStar_Parser_AST.term -> FStar_Parser_AST.term -> FStar_Pprint.document) - = - fun ps -> - fun pb -> - fun rel -> - fun e -> - let uu___ = - let uu___1 = str "{:well-founded " in - let uu___2 = - let uu___3 = p_typ ps pb rel in - let uu___4 = - let uu___5 = p_typ ps pb e in - let uu___6 = str " }" in - FStar_Pprint.op_Hat_Hat uu___5 uu___6 in - FStar_Pprint.op_Hat_Slash_Hat uu___3 uu___4 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ -and (p_calcStep : - Prims.bool -> FStar_Parser_AST.calc_step -> FStar_Pprint.document) = - fun uu___ -> - fun uu___1 -> - match uu___1 with - | FStar_Parser_AST.CalcStep (rel, just, next) -> - let uu___2 = - let uu___3 = p_noSeqTermAndComment false false rel in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = p_noSeqTermAndComment false false just in - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - p_noSeqTermAndComment false false next in - let uu___14 = str ";" in - FStar_Pprint.op_Hat_Hat uu___13 uu___14 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline - uu___12 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.rbrace uu___11 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___10 in - FStar_Pprint.op_Hat_Hat uu___8 uu___9 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___7 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.lbrace uu___6 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___5 in - FStar_Pprint.op_Hat_Hat uu___3 uu___4 in - FStar_Pprint.group uu___2 -and (p_attrs_opt : - Prims.bool -> - FStar_Parser_AST.term Prims.list FStar_Pervasives_Native.option -> - FStar_Pprint.document) - = - fun isTopLevel -> - fun uu___ -> - match uu___ with - | FStar_Pervasives_Native.None -> FStar_Pprint.empty - | FStar_Pervasives_Native.Some terms -> - let uu___1 = - let uu___2 = str (if isTopLevel then "[@@" else "[@@@") in - let uu___3 = - let uu___4 = - let uu___5 = str "; " in - FStar_Pprint.separate_map uu___5 - (p_noSeqTermAndComment false false) terms in - let uu___5 = str "]" in - FStar_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in - FStar_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in - FStar_Pprint.group uu___1 -and (p_typ : - Prims.bool -> Prims.bool -> FStar_Parser_AST.term -> FStar_Pprint.document) - = - fun ps -> - fun pb -> fun e -> with_comment (p_typ' ps pb) e e.FStar_Parser_AST.range -and (p_typ_sep : - Prims.bool -> - Prims.bool -> - FStar_Parser_AST.term -> - (FStar_Pprint.document * FStar_Pprint.document)) - = - fun ps -> - fun pb -> - fun e -> with_comment_sep (p_typ' ps pb) e e.FStar_Parser_AST.range -and (p_typ' : - Prims.bool -> Prims.bool -> FStar_Parser_AST.term -> FStar_Pprint.document) - = - fun ps -> - fun pb -> - fun e -> - match e.FStar_Parser_AST.tm with - | FStar_Parser_AST.QForall (bs, (uu___, trigger), e1) -> - let binders_doc = p_binders true bs in - let term_doc = p_noSeqTermAndComment ps pb e1 in - (match trigger with - | [] -> - let uu___1 = - let uu___2 = - let uu___3 = p_quantifier e in - FStar_Pprint.op_Hat_Hat uu___3 FStar_Pprint.space in - FStar_Pprint.soft_surround (Prims.of_int (2)) - Prims.int_zero uu___2 binders_doc FStar_Pprint.dot in - prefix2 uu___1 term_doc - | pats -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = p_quantifier e in - FStar_Pprint.op_Hat_Hat uu___5 FStar_Pprint.space in - FStar_Pprint.soft_surround (Prims.of_int (2)) - Prims.int_zero uu___4 binders_doc FStar_Pprint.dot in - let uu___4 = p_trigger trigger in prefix2 uu___3 uu___4 in - FStar_Pprint.group uu___2 in - prefix2 uu___1 term_doc) - | FStar_Parser_AST.QExists (bs, (uu___, trigger), e1) -> - let binders_doc = p_binders true bs in - let term_doc = p_noSeqTermAndComment ps pb e1 in - (match trigger with - | [] -> - let uu___1 = - let uu___2 = - let uu___3 = p_quantifier e in - FStar_Pprint.op_Hat_Hat uu___3 FStar_Pprint.space in - FStar_Pprint.soft_surround (Prims.of_int (2)) - Prims.int_zero uu___2 binders_doc FStar_Pprint.dot in - prefix2 uu___1 term_doc - | pats -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = p_quantifier e in - FStar_Pprint.op_Hat_Hat uu___5 FStar_Pprint.space in - FStar_Pprint.soft_surround (Prims.of_int (2)) - Prims.int_zero uu___4 binders_doc FStar_Pprint.dot in - let uu___4 = p_trigger trigger in prefix2 uu___3 uu___4 in - FStar_Pprint.group uu___2 in - prefix2 uu___1 term_doc) - | FStar_Parser_AST.QuantOp (uu___, bs, (uu___1, trigger), e1) -> - let binders_doc = p_binders true bs in - let term_doc = p_noSeqTermAndComment ps pb e1 in - (match trigger with - | [] -> - let uu___2 = - let uu___3 = - let uu___4 = p_quantifier e in - FStar_Pprint.op_Hat_Hat uu___4 FStar_Pprint.space in - FStar_Pprint.soft_surround (Prims.of_int (2)) - Prims.int_zero uu___3 binders_doc FStar_Pprint.dot in - prefix2 uu___2 term_doc - | pats -> - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = p_quantifier e in - FStar_Pprint.op_Hat_Hat uu___6 FStar_Pprint.space in - FStar_Pprint.soft_surround (Prims.of_int (2)) - Prims.int_zero uu___5 binders_doc FStar_Pprint.dot in - let uu___5 = p_trigger trigger in prefix2 uu___4 uu___5 in - FStar_Pprint.group uu___3 in - prefix2 uu___2 term_doc) - | uu___ -> p_simpleTerm ps pb e -and (p_typ_top : - annotation_style -> - Prims.bool -> - Prims.bool -> FStar_Parser_AST.term -> FStar_Pprint.document) - = - fun style -> - fun ps -> - fun pb -> - fun e -> - with_comment (p_typ_top' style ps pb) e e.FStar_Parser_AST.range -and (p_typ_top' : - annotation_style -> - Prims.bool -> - Prims.bool -> FStar_Parser_AST.term -> FStar_Pprint.document) - = - fun style -> - fun ps -> fun pb -> fun e -> p_tmArrow style true p_tmFormula e -and (sig_as_binders_if_possible : - FStar_Parser_AST.term -> Prims.bool -> FStar_Pprint.document) = - fun t -> - fun extra_space -> - let s = if extra_space then FStar_Pprint.space else FStar_Pprint.empty in - let uu___ = all_binders_annot t in - if uu___ - then - let uu___1 = - p_typ_top (Binders ((Prims.of_int (4)), Prims.int_zero, true)) - false false t in - FStar_Pprint.op_Hat_Hat s uu___1 - else - (let uu___2 = - let uu___3 = - let uu___4 = - p_typ_top (Arrows ((Prims.of_int (2)), (Prims.of_int (2)))) - false false t in - FStar_Pprint.op_Hat_Hat s uu___4 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.colon uu___3 in - FStar_Pprint.group uu___2) -and (collapse_pats : - (FStar_Pprint.document * FStar_Pprint.document * Prims.bool * Prims.bool) - Prims.list -> FStar_Pprint.document Prims.list) - = - fun pats -> - let fold_fun bs x = - let uu___ = x in - match uu___ with - | (b1, t1, tc1, j1) -> - (match bs with - | [] -> [([b1], t1, tc1, j1)] - | hd::tl -> - let uu___1 = hd in - (match uu___1 with - | (b2s, t2, tc2, j2) -> - if ((t1 = t2) && j1) && j2 - then - ((FStar_Compiler_List.op_At b2s [b1]), t1, false, true) - :: tl - else ([b1], t1, tc1, j1) :: hd :: tl)) in - let p_collapsed_binder cb = - let uu___ = cb in - match uu___ with - | (bs, typ, istcarg, uu___1) -> - let body = - match bs with - | [] -> failwith "Impossible" - | hd::tl -> - let uu___2 = - FStar_Compiler_List.fold_left - (fun x -> - fun y -> - let uu___3 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.space y in - FStar_Pprint.op_Hat_Hat x uu___3) hd tl in - cat_with_colon uu___2 typ in - if istcarg then tc_arg body else soft_parens_with_nesting body in - let binders = - FStar_Compiler_List.fold_left fold_fun [] - (FStar_Compiler_List.rev pats) in - map_rev p_collapsed_binder binders -and (pats_as_binders_if_possible : - FStar_Parser_AST.pattern Prims.list -> - (FStar_Pprint.document Prims.list * annotation_style)) - = - fun pats -> - let all_binders p = - match p.FStar_Parser_AST.pat with - | FStar_Parser_AST.PatAscribed (pat, (t, FStar_Pervasives_Native.None)) - -> - (match ((pat.FStar_Parser_AST.pat), (t.FStar_Parser_AST.tm)) with - | (FStar_Parser_AST.PatVar (lid, aqual, attrs), - FStar_Parser_AST.Refine - ({ FStar_Parser_AST.b = FStar_Parser_AST.Annotated (lid', t1); - FStar_Parser_AST.brange = uu___; - FStar_Parser_AST.blevel = uu___1; - FStar_Parser_AST.aqual = uu___2; - FStar_Parser_AST.battributes = uu___3;_}, - phi)) when - let uu___4 = FStar_Ident.string_of_id lid in - let uu___5 = FStar_Ident.string_of_id lid' in uu___4 = uu___5 - -> - let uu___4 = - let uu___5 = p_ident lid in - p_refinement' aqual attrs uu___5 t1 phi in - (match uu___4 with - | (x, y) -> FStar_Pervasives_Native.Some (x, y, false, false)) - | (FStar_Parser_AST.PatVar (lid, aqual, attrs), uu___) -> - let is_tc = - aqual = - (FStar_Pervasives_Native.Some - FStar_Parser_AST.TypeClassArg) in - let is_meta = - match aqual with - | FStar_Pervasives_Native.Some (FStar_Parser_AST.Meta - uu___1) -> true - | uu___1 -> false in - let uu___1 = - let uu___2 = - let uu___3 = FStar_Pprint.optional p_aqual aqual in - let uu___4 = - let uu___5 = p_attributes false attrs in - let uu___6 = p_ident lid in - FStar_Pprint.op_Hat_Hat uu___5 uu___6 in - FStar_Pprint.op_Hat_Hat uu___3 uu___4 in - let uu___3 = p_tmEqNoRefinement t in - (uu___2, uu___3, is_tc, - ((Prims.op_Negation is_tc) && (Prims.op_Negation is_meta))) in - FStar_Pervasives_Native.Some uu___1 - | uu___ -> FStar_Pervasives_Native.None) - | uu___ -> FStar_Pervasives_Native.None in - let uu___ = map_if_all all_binders pats in - match uu___ with - | FStar_Pervasives_Native.Some bs -> - let uu___1 = collapse_pats bs in - (uu___1, (Binders ((Prims.of_int (4)), Prims.int_zero, true))) - | FStar_Pervasives_Native.None -> - let uu___1 = FStar_Compiler_List.map p_atomicPattern pats in - (uu___1, (Binders ((Prims.of_int (4)), Prims.int_zero, false))) -and (p_quantifier : FStar_Parser_AST.term -> FStar_Pprint.document) = - fun e -> - match e.FStar_Parser_AST.tm with - | FStar_Parser_AST.QForall uu___ -> str "forall" - | FStar_Parser_AST.QExists uu___ -> str "exists" - | FStar_Parser_AST.QuantOp (i, uu___, uu___1, uu___2) -> p_ident i - | uu___ -> - failwith "Imposible : p_quantifier called on a non-quantifier term" -and (p_trigger : - FStar_Parser_AST.term Prims.list Prims.list -> FStar_Pprint.document) = - fun uu___ -> - match uu___ with - | [] -> FStar_Pprint.empty - | pats -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = str "pattern" in - let uu___5 = - let uu___6 = - let uu___7 = p_disjunctivePats pats in - FStar_Pprint.jump (Prims.of_int (2)) Prims.int_zero uu___7 in - FStar_Pprint.op_Hat_Hat uu___6 FStar_Pprint.rbrace in - FStar_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.colon uu___3 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.lbrace uu___2 in - FStar_Pprint.group uu___1 -and (p_disjunctivePats : - FStar_Parser_AST.term Prims.list Prims.list -> FStar_Pprint.document) = - fun pats -> - let uu___ = str "\\/" in - FStar_Pprint.separate_map uu___ p_conjunctivePats pats -and (p_conjunctivePats : - FStar_Parser_AST.term Prims.list -> FStar_Pprint.document) = - fun pats -> - let uu___ = - let uu___1 = FStar_Pprint.op_Hat_Hat FStar_Pprint.semi break1 in - FStar_Pprint.separate_map uu___1 p_appTerm pats in - FStar_Pprint.group uu___ -and (p_simpleTerm : - Prims.bool -> Prims.bool -> FStar_Parser_AST.term -> FStar_Pprint.document) - = - fun ps -> - fun pb -> - fun e -> - match e.FStar_Parser_AST.tm with - | FStar_Parser_AST.Function (branches, uu___) -> - let uu___1 = - let uu___2 = - let uu___3 = str "function" in - let uu___4 = - separate_map_last FStar_Pprint.hardline p_patternBranch - branches in - FStar_Pprint.op_Hat_Slash_Hat uu___3 uu___4 in - FStar_Pprint.group uu___2 in - let uu___2 = paren_if (ps || pb) in uu___2 uu___1 - | FStar_Parser_AST.Abs (pats, e1) -> - let uu___ = p_term_sep false pb e1 in - (match uu___ with - | (comm, doc) -> - let prefix = - let uu___1 = str "fun" in - let uu___2 = - let uu___3 = - FStar_Pprint.separate_map break1 p_atomicPattern pats in - FStar_Pprint.op_Hat_Slash_Hat uu___3 FStar_Pprint.rarrow in - op_Hat_Slash_Plus_Hat uu___1 uu___2 in - let uu___1 = - if comm <> FStar_Pprint.empty - then - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline doc in - FStar_Pprint.op_Hat_Hat comm uu___4 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline uu___3 in - FStar_Pprint.op_Hat_Hat prefix uu___2 - else - (let uu___3 = op_Hat_Slash_Plus_Hat prefix doc in - FStar_Pprint.group uu___3) in - let uu___2 = paren_if ps in uu___2 uu___1) - | uu___ -> p_tmIff e -and (p_maybeFocusArrow : Prims.bool -> FStar_Pprint.document) = - fun b -> if b then str "~>" else FStar_Pprint.rarrow -and (p_patternBranch : - Prims.bool -> - (FStar_Parser_AST.pattern * FStar_Parser_AST.term - FStar_Pervasives_Native.option * FStar_Parser_AST.term) -> - FStar_Pprint.document) - = - fun pb -> - fun uu___ -> - match uu___ with - | (pat, when_opt, e) -> - let one_pattern_branch p = - let branch = - match when_opt with - | FStar_Pervasives_Native.None -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = p_tuplePattern p in - let uu___5 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.space - FStar_Pprint.rarrow in - FStar_Pprint.op_Hat_Hat uu___4 uu___5 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___3 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.bar uu___2 in - FStar_Pprint.group uu___1 - | FStar_Pervasives_Native.Some f -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = p_tuplePattern p in - let uu___7 = str "when" in - FStar_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in - FStar_Pprint.group uu___5 in - let uu___5 = - let uu___6 = - let uu___7 = p_tmFormula f in - [uu___7; FStar_Pprint.rarrow] in - FStar_Pprint.flow break1 uu___6 in - FStar_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___3 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.bar uu___2 in - FStar_Pprint.hang (Prims.of_int (2)) uu___1 in - let uu___1 = p_term_sep false pb e in - match uu___1 with - | (comm, doc) -> - if pb - then - (if comm = FStar_Pprint.empty - then - let uu___2 = op_Hat_Slash_Plus_Hat branch doc in - FStar_Pprint.group uu___2 - else - (let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Pprint.op_Hat_Hat break1 comm in - FStar_Pprint.op_Hat_Hat doc uu___7 in - op_Hat_Slash_Plus_Hat branch uu___6 in - FStar_Pprint.group uu___5 in - let uu___5 = - let uu___6 = - let uu___7 = - inline_comment_or_above comm doc - FStar_Pprint.empty in - jump2 uu___7 in - FStar_Pprint.op_Hat_Hat branch uu___6 in - FStar_Pprint.ifflat uu___4 uu___5 in - FStar_Pprint.group uu___3)) - else - if comm <> FStar_Pprint.empty - then - (let uu___3 = - let uu___4 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline doc in - FStar_Pprint.op_Hat_Hat comm uu___4 in - op_Hat_Slash_Plus_Hat branch uu___3) - else op_Hat_Slash_Plus_Hat branch doc in - (match pat.FStar_Parser_AST.pat with - | FStar_Parser_AST.PatOr pats -> - (match FStar_Compiler_List.rev pats with - | hd::tl -> - let last_pat_branch = one_pattern_branch hd in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.bar - FStar_Pprint.space in - FStar_Pprint.op_Hat_Hat break1 uu___6 in - FStar_Pprint.separate_map uu___5 p_tuplePattern - (FStar_Compiler_List.rev tl) in - FStar_Pprint.op_Hat_Slash_Hat uu___4 - last_pat_branch in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___3 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.bar uu___2 in - FStar_Pprint.group uu___1 - | [] -> - failwith "Impossible: disjunctive pattern can't be empty") - | uu___1 -> one_pattern_branch pat) -and (p_tmIff : FStar_Parser_AST.term -> FStar_Pprint.document) = - fun e -> - match e.FStar_Parser_AST.tm with - | FStar_Parser_AST.Op (id, e1::e2::[]) when - let uu___ = FStar_Ident.string_of_id id in uu___ = "<==>" -> - let uu___ = str "<==>" in - let uu___1 = p_tmImplies e1 in - let uu___2 = p_tmIff e2 in infix0 uu___ uu___1 uu___2 - | uu___ -> p_tmImplies e -and (p_tmImplies : FStar_Parser_AST.term -> FStar_Pprint.document) = - fun e -> - match e.FStar_Parser_AST.tm with - | FStar_Parser_AST.Op (id, e1::e2::[]) when - let uu___ = FStar_Ident.string_of_id id in uu___ = "==>" -> - let uu___ = str "==>" in - let uu___1 = - p_tmArrow (Arrows ((Prims.of_int (2)), (Prims.of_int (2)))) false - p_tmFormula e1 in - let uu___2 = p_tmImplies e2 in infix0 uu___ uu___1 uu___2 - | uu___ -> - p_tmArrow (Arrows ((Prims.of_int (2)), (Prims.of_int (2)))) false - p_tmFormula e -and (format_sig : - annotation_style -> - FStar_Pprint.document Prims.list -> - FStar_Pprint.document -> - Prims.bool -> Prims.bool -> FStar_Pprint.document) - = - fun style -> - fun terms -> - fun ret_d -> - fun no_last_op -> - fun flat_space -> - let uu___ = - match style with - | Arrows (n, ln) -> - let uu___1 = - let uu___2 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.rarrow break1 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___2 in - let uu___2 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.rarrow - FStar_Pprint.space in - (n, ln, uu___1, uu___2) - | Binders (n, ln, parens) -> - let uu___1 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.colon - FStar_Pprint.space in - (n, ln, break1, uu___1) in - match uu___ with - | (n, last_n, sep, last_op) -> - let last_op1 = - if - ((FStar_Compiler_List.length terms) > Prims.int_zero) && - (Prims.op_Negation no_last_op) - then last_op - else FStar_Pprint.empty in - let one_line_space = - if - (Prims.op_Negation (ret_d = FStar_Pprint.empty)) || - (Prims.op_Negation no_last_op) - then FStar_Pprint.space - else FStar_Pprint.empty in - let single_line_arg_indent = - FStar_Pprint.repeat n FStar_Pprint.space in - let fs = - if flat_space - then FStar_Pprint.space - else FStar_Pprint.empty in - (match FStar_Compiler_List.length terms with - | uu___1 when uu___1 = Prims.int_zero -> ret_d - | uu___1 -> - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Pprint.separate sep terms in - let uu___6 = - let uu___7 = - FStar_Pprint.op_Hat_Hat last_op1 ret_d in - FStar_Pprint.op_Hat_Hat one_line_space uu___7 in - FStar_Pprint.op_Hat_Hat uu___5 uu___6 in - FStar_Pprint.op_Hat_Hat fs uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = FStar_Pprint.separate sep terms in - FStar_Pprint.op_Hat_Hat fs uu___8 in - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Pprint.op_Hat_Hat sep - single_line_arg_indent in - let uu___12 = - FStar_Compiler_List.map - (fun x -> - let uu___13 = - FStar_Pprint.hang - (Prims.of_int (2)) x in - FStar_Pprint.align uu___13) terms in - FStar_Pprint.separate uu___11 uu___12 in - FStar_Pprint.op_Hat_Hat - single_line_arg_indent uu___10 in - jump2 uu___9 in - FStar_Pprint.ifflat uu___7 uu___8 in - FStar_Pprint.group uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Pprint.op_Hat_Hat last_op1 ret_d in - FStar_Pprint.hang last_n uu___8 in - FStar_Pprint.align uu___7 in - FStar_Pprint.prefix n Prims.int_one uu___5 uu___6 in - FStar_Pprint.ifflat uu___3 uu___4 in - FStar_Pprint.group uu___2) -and (p_tmArrow : - annotation_style -> - Prims.bool -> - (FStar_Parser_AST.term -> FStar_Pprint.document) -> - FStar_Parser_AST.term -> FStar_Pprint.document) - = - fun style -> - fun flat_space -> - fun p_Tm -> - fun e -> - let uu___ = - match style with - | Arrows uu___1 -> p_tmArrow' p_Tm e - | Binders uu___1 -> collapse_binders style p_Tm e in - match uu___ with - | (terms, ret_d) -> format_sig style terms ret_d false flat_space -and (p_tmArrow' : - (FStar_Parser_AST.term -> FStar_Pprint.document) -> - FStar_Parser_AST.term -> - (FStar_Pprint.document Prims.list * FStar_Pprint.document)) - = - fun p_Tm -> - fun e -> - match e.FStar_Parser_AST.tm with - | FStar_Parser_AST.Product (bs, tgt) -> - let bs_ds = FStar_Compiler_List.map (fun b -> p_binder false b) bs in - let uu___ = p_tmArrow' p_Tm tgt in - (match uu___ with - | (bs_ds', ret) -> ((FStar_Compiler_List.op_At bs_ds bs_ds'), ret)) - | uu___ -> let uu___1 = p_Tm e in ([], uu___1) -and (collapse_binders : - annotation_style -> - (FStar_Parser_AST.term -> FStar_Pprint.document) -> - FStar_Parser_AST.term -> - (FStar_Pprint.document Prims.list * FStar_Pprint.document)) - = - fun style -> - fun p_Tm -> - fun e -> - let atomize = - match style with | Binders (uu___, uu___1, a) -> a | uu___ -> false in - let wrap is_tc doc = - if is_tc - then tc_arg doc - else if atomize then soft_parens_with_nesting doc else doc in - let rec accumulate_binders p_Tm1 e1 = - match e1.FStar_Parser_AST.tm with - | FStar_Parser_AST.Product (bs, tgt) -> - let bs_ds = - FStar_Compiler_List.map - (fun b -> - let uu___ = p_binder' true false b in - let uu___1 = is_tc_binder b in - let uu___2 = is_joinable_binder b in - (uu___, uu___1, uu___2)) bs in - let uu___ = accumulate_binders p_Tm1 tgt in - (match uu___ with - | (bs_ds', ret) -> - ((FStar_Compiler_List.op_At bs_ds bs_ds'), ret)) - | uu___ -> let uu___1 = p_Tm1 e1 in ([], uu___1) in - let fold_fun bs x = - let uu___ = x in - match uu___ with - | ((b1, t1), tc1, j1) -> - (match bs with - | [] -> [([b1], t1, tc1, j1)] - | hd::tl -> - let uu___1 = hd in - (match uu___1 with - | (b2s, t2, tc2, j2) -> - (match (t1, t2) with - | (FStar_Pervasives_Native.Some (typ1, catf1), - FStar_Pervasives_Native.Some (typ2, uu___2)) when - ((typ1 = typ2) && j1) && j2 -> - ((FStar_Compiler_List.op_At b2s [b1]), t1, - false, true) - :: tl - | uu___2 -> ([b1], t1, tc1, j1) :: bs))) in - let p_collapsed_binder cb = - let uu___ = cb in - match uu___ with - | (bs, t, is_tc, uu___1) -> - (match t with - | FStar_Pervasives_Native.None -> - (match bs with - | b::[] -> wrap is_tc b - | uu___2 -> failwith "Impossible") - | FStar_Pervasives_Native.Some (typ, f) -> - (match bs with - | [] -> failwith "Impossible" - | hd::tl -> - let uu___2 = - let uu___3 = - FStar_Compiler_List.fold_left - (fun x -> - fun y -> - let uu___4 = - FStar_Pprint.op_Hat_Hat - FStar_Pprint.space y in - FStar_Pprint.op_Hat_Hat x uu___4) hd tl in - f uu___3 typ in - wrap is_tc uu___2)) in - let uu___ = accumulate_binders p_Tm e in - match uu___ with - | (bs_ds, ret_d) -> - let binders = FStar_Compiler_List.fold_left fold_fun [] bs_ds in - let uu___1 = map_rev p_collapsed_binder binders in - (uu___1, ret_d) -and (p_tmFormula : FStar_Parser_AST.term -> FStar_Pprint.document) = - fun e -> - let conj = - let uu___ = - let uu___1 = str "/\\" in FStar_Pprint.op_Hat_Hat uu___1 break1 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___ in - let disj = - let uu___ = - let uu___1 = str "\\/" in FStar_Pprint.op_Hat_Hat uu___1 break1 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___ in - let formula = p_tmDisjunction e in - FStar_Pprint.flow_map disj - (fun d -> FStar_Pprint.flow_map conj (fun x -> FStar_Pprint.group x) d) - formula -and (p_tmDisjunction : - FStar_Parser_AST.term -> FStar_Pprint.document Prims.list Prims.list) = - fun e -> - match e.FStar_Parser_AST.tm with - | FStar_Parser_AST.Op (id, e1::e2::[]) when - let uu___ = FStar_Ident.string_of_id id in uu___ = "\\/" -> - let uu___ = p_tmDisjunction e1 in - let uu___1 = let uu___2 = p_tmConjunction e2 in [uu___2] in - FStar_Compiler_List.op_At uu___ uu___1 - | uu___ -> let uu___1 = p_tmConjunction e in [uu___1] -and (p_tmConjunction : - FStar_Parser_AST.term -> FStar_Pprint.document Prims.list) = - fun e -> - match e.FStar_Parser_AST.tm with - | FStar_Parser_AST.Op (id, e1::e2::[]) when - let uu___ = FStar_Ident.string_of_id id in uu___ = "/\\" -> - let uu___ = p_tmConjunction e1 in - let uu___1 = let uu___2 = p_tmTuple e2 in [uu___2] in - FStar_Compiler_List.op_At uu___ uu___1 - | uu___ -> let uu___1 = p_tmTuple e in [uu___1] -and (p_tmTuple : FStar_Parser_AST.term -> FStar_Pprint.document) = - fun e -> with_comment p_tmTuple' e e.FStar_Parser_AST.range -and (p_tmTuple' : FStar_Parser_AST.term -> FStar_Pprint.document) = - fun e -> - match e.FStar_Parser_AST.tm with - | FStar_Parser_AST.Construct (lid, args) when - (is_tuple_constructor lid) && (all1_explicit args) -> - let uu___ = FStar_Pprint.op_Hat_Hat FStar_Pprint.comma break1 in - FStar_Pprint.separate_map uu___ - (fun uu___1 -> match uu___1 with | (e1, uu___2) -> p_tmEq e1) args - | uu___ -> p_tmEq e -and (paren_if_gt : - Prims.int -> Prims.int -> FStar_Pprint.document -> FStar_Pprint.document) = - fun curr -> - fun mine -> - fun doc -> - if mine > curr - then - let uu___ = - let uu___1 = FStar_Pprint.op_Hat_Hat doc FStar_Pprint.rparen in - FStar_Pprint.op_Hat_Hat FStar_Pprint.lparen uu___1 in - FStar_Pprint.group uu___ - else doc -and (p_tmEqWith : - (FStar_Parser_AST.term -> FStar_Pprint.document) -> - FStar_Parser_AST.term -> FStar_Pprint.document) - = - fun p_X -> - fun e -> - let n = - max_level - (FStar_Compiler_List.op_At [colon_equals; pipe_right] - operatorInfix0ad12) in - p_tmEqWith' p_X n e -and (p_tmEqWith' : - (FStar_Parser_AST.term -> FStar_Pprint.document) -> - Prims.int -> FStar_Parser_AST.term -> FStar_Pprint.document) - = - fun p_X -> - fun curr -> - fun e -> - match e.FStar_Parser_AST.tm with - | FStar_Parser_AST.Op (op, e1::e2::[]) when - (let uu___ = - (let uu___1 = FStar_Ident.string_of_id op in uu___1 = "==>") - || - (let uu___1 = FStar_Ident.string_of_id op in uu___1 = "<==>") in - Prims.op_Negation uu___) && - (((is_operatorInfix0ad12 op) || - (let uu___ = FStar_Ident.string_of_id op in uu___ = "=")) - || (let uu___ = FStar_Ident.string_of_id op in uu___ = "|>")) - -> - let op1 = FStar_Ident.string_of_id op in - let uu___ = levels op1 in - (match uu___ with - | (left, mine, right) -> - let uu___1 = - let uu___2 = str op1 in - let uu___3 = p_tmEqWith' p_X left e1 in - let uu___4 = p_tmEqWith' p_X right e2 in - infix0 uu___2 uu___3 uu___4 in - paren_if_gt curr mine uu___1) - | FStar_Parser_AST.Op (id, e1::e2::[]) when - let uu___ = FStar_Ident.string_of_id id in uu___ = ":=" -> - let uu___ = - let uu___1 = p_tmEqWith p_X e1 in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = p_tmEqWith p_X e2 in - op_Hat_Slash_Plus_Hat FStar_Pprint.equals uu___5 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.colon uu___4 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___3 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | FStar_Parser_AST.Op (id, e1::[]) when - let uu___ = FStar_Ident.string_of_id id in uu___ = "-" -> - let uu___ = levels "-" in - (match uu___ with - | (left, mine, right) -> - let uu___1 = p_tmEqWith' p_X mine e1 in - FStar_Pprint.op_Hat_Slash_Hat FStar_Pprint.minus uu___1) - | uu___ -> p_tmNoEqWith p_X e -and (p_tmNoEqWith : - (FStar_Parser_AST.term -> FStar_Pprint.document) -> - FStar_Parser_AST.term -> FStar_Pprint.document) - = - fun p_X -> - fun e -> - let n = max_level [colon_colon; amp; opinfix3; opinfix4] in - p_tmNoEqWith' false p_X n e -and (p_tmNoEqWith' : - Prims.bool -> - (FStar_Parser_AST.term -> FStar_Pprint.document) -> - Prims.int -> FStar_Parser_AST.term -> FStar_Pprint.document) - = - fun inside_tuple -> - fun p_X -> - fun curr -> - fun e -> - match e.FStar_Parser_AST.tm with - | FStar_Parser_AST.Construct (lid, (e1, uu___)::(e2, uu___1)::[]) - when FStar_Ident.lid_equals lid FStar_Parser_Const.cons_lid -> - let op = "::" in - let uu___2 = levels op in - (match uu___2 with - | (left, mine, right) -> - let uu___3 = - let uu___4 = str op in - let uu___5 = p_tmNoEqWith' false p_X left e1 in - let uu___6 = p_tmNoEqWith' false p_X right e2 in - infix0 uu___4 uu___5 uu___6 in - paren_if_gt curr mine uu___3) - | FStar_Parser_AST.Sum (binders, res) -> - let op = "&" in - let uu___ = levels op in - (match uu___ with - | (left, mine, right) -> - let p_dsumfst bt = - match bt with - | FStar_Pervasives.Inl b -> - let uu___1 = p_binder false b in - let uu___2 = - let uu___3 = - let uu___4 = str op in - FStar_Pprint.op_Hat_Hat uu___4 break1 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___3 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 - | FStar_Pervasives.Inr t -> - let uu___1 = p_tmNoEqWith' false p_X left t in - let uu___2 = - let uu___3 = - let uu___4 = str op in - FStar_Pprint.op_Hat_Hat uu___4 break1 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___3 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - let uu___1 = - let uu___2 = FStar_Pprint.concat_map p_dsumfst binders in - let uu___3 = p_tmNoEqWith' false p_X right res in - FStar_Pprint.op_Hat_Hat uu___2 uu___3 in - paren_if_gt curr mine uu___1) - | FStar_Parser_AST.Op (op, e1::e2::[]) when is_operatorInfix34 op - -> - let op1 = FStar_Ident.string_of_id op in - let uu___ = levels op1 in - (match uu___ with - | (left, mine, right) -> - let uu___1 = - let uu___2 = str op1 in - let uu___3 = p_tmNoEqWith' false p_X left e1 in - let uu___4 = p_tmNoEqWith' false p_X right e2 in - infix0 uu___2 uu___3 uu___4 in - paren_if_gt curr mine uu___1) - | FStar_Parser_AST.Record (with_opt, record_fields) -> - let uu___ = - let uu___1 = - default_or_map FStar_Pprint.empty p_with_clause with_opt in - let uu___2 = - let uu___3 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.semi break1 in - separate_map_last uu___3 p_simpleDef record_fields in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - braces_with_nesting uu___ - | FStar_Parser_AST.Op (id, e1::[]) when - let uu___ = FStar_Ident.string_of_id id in uu___ = "~" -> - let uu___ = - let uu___1 = str "~" in - let uu___2 = p_atomicTerm e1 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | FStar_Parser_AST.Paren p when inside_tuple -> - (match p.FStar_Parser_AST.tm with - | FStar_Parser_AST.Op (id, e1::e2::[]) when - let uu___ = FStar_Ident.string_of_id id in uu___ = "*" -> - let op = "*" in - let uu___ = levels op in - (match uu___ with - | (left, mine, right) -> - let uu___1 = - let uu___2 = str op in - let uu___3 = p_tmNoEqWith' true p_X left e1 in - let uu___4 = p_tmNoEqWith' true p_X right e2 in - infix0 uu___2 uu___3 uu___4 in - paren_if_gt curr mine uu___1) - | uu___ -> p_X e) - | uu___ -> p_X e -and (p_tmEqNoRefinement : FStar_Parser_AST.term -> FStar_Pprint.document) = - fun e -> p_tmEqWith p_appTerm e -and (p_tmEq : FStar_Parser_AST.term -> FStar_Pprint.document) = - fun e -> p_tmEqWith p_tmRefinement e -and (p_tmNoEq : FStar_Parser_AST.term -> FStar_Pprint.document) = - fun e -> p_tmNoEqWith p_tmRefinement e -and (p_tmRefinement : FStar_Parser_AST.term -> FStar_Pprint.document) = - fun e -> - match e.FStar_Parser_AST.tm with - | FStar_Parser_AST.NamedTyp (lid, e1) -> - let uu___ = - let uu___1 = p_lident lid in - let uu___2 = - let uu___3 = p_appTerm e1 in - FStar_Pprint.op_Hat_Slash_Hat FStar_Pprint.colon uu___3 in - FStar_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | FStar_Parser_AST.Refine (b, phi) -> p_refinedBinder b phi - | uu___ -> p_appTerm e -and (p_with_clause : FStar_Parser_AST.term -> FStar_Pprint.document) = - fun e -> - let uu___ = p_appTerm e in - let uu___1 = - let uu___2 = - let uu___3 = str "with" in FStar_Pprint.op_Hat_Hat uu___3 break1 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___2 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 -and (p_refinedBinder : - FStar_Parser_AST.binder -> FStar_Parser_AST.term -> FStar_Pprint.document) - = - fun b -> - fun phi -> - match b.FStar_Parser_AST.b with - | FStar_Parser_AST.Annotated (lid, t) -> - let uu___ = p_lident lid in - p_refinement b.FStar_Parser_AST.aqual - b.FStar_Parser_AST.battributes uu___ t phi - | FStar_Parser_AST.Variable lid -> - let uu___ = p_lident lid in - let uu___1 = - let uu___2 = FStar_Ident.range_of_id lid in - FStar_Parser_AST.mk_term FStar_Parser_AST.Wild uu___2 - FStar_Parser_AST.Type_level in - p_refinement b.FStar_Parser_AST.aqual - b.FStar_Parser_AST.battributes uu___ uu___1 phi - | FStar_Parser_AST.TAnnotated uu___ -> failwith "Is this still used ?" - | FStar_Parser_AST.TVariable uu___ -> - let uu___1 = - let uu___2 = FStar_Parser_AST.binder_to_string b in - FStar_Compiler_Util.format1 - "Impossible: a refined binder ought to be annotated (%s)" - uu___2 in - failwith uu___1 - | FStar_Parser_AST.NoName uu___ -> - let uu___1 = - let uu___2 = FStar_Parser_AST.binder_to_string b in - FStar_Compiler_Util.format1 - "Impossible: a refined binder ought to be annotated (%s)" - uu___2 in - failwith uu___1 -and (p_simpleDef : - Prims.bool -> - (FStar_Ident.lid * FStar_Parser_AST.term) -> FStar_Pprint.document) - = - fun ps -> - fun uu___ -> - match uu___ with - | (lid, e) -> - let uu___1 = - let uu___2 = p_qlidentOrOperator lid in - let uu___3 = - let uu___4 = p_noSeqTermAndComment ps false e in - FStar_Pprint.op_Hat_Slash_Hat FStar_Pprint.equals uu___4 in - FStar_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in - FStar_Pprint.group uu___1 -and (p_appTerm : FStar_Parser_AST.term -> FStar_Pprint.document) = - fun e -> - match e.FStar_Parser_AST.tm with - | FStar_Parser_AST.App uu___ when is_general_application e -> - let uu___1 = head_and_args e in - (match uu___1 with - | (head, args) -> - (match args with - | e1::e2::[] when - (FStar_Pervasives_Native.snd e1) = FStar_Parser_AST.Infix - -> - let uu___2 = p_argTerm e1 in - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = str "`" in - let uu___7 = - let uu___8 = p_indexingTerm head in - let uu___9 = str "`" in - FStar_Pprint.op_Hat_Hat uu___8 uu___9 in - FStar_Pprint.op_Hat_Hat uu___6 uu___7 in - FStar_Pprint.group uu___5 in - let uu___5 = p_argTerm e2 in - FStar_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in - FStar_Pprint.op_Hat_Slash_Hat uu___2 uu___3 - | uu___2 -> - let uu___3 = - let uu___4 = p_indexingTerm head in (uu___4, args) in - (match uu___3 with - | (head_doc, args1) -> - let uu___4 = - let uu___5 = - FStar_Pprint.op_Hat_Hat head_doc - FStar_Pprint.space in - soft_surround_map_or_flow (Prims.of_int (2)) - Prims.int_zero head_doc uu___5 break1 - FStar_Pprint.empty p_argTerm args1 in - FStar_Pprint.group uu___4))) - | FStar_Parser_AST.Construct (lid, args) when - ((is_general_construction e) && - (let uu___ = (is_dtuple_constructor lid) && (all1_explicit args) in - Prims.op_Negation uu___)) - && - (let uu___ = (is_tuple_constructor lid) && (all1_explicit args) in - Prims.op_Negation uu___) - -> - (match args with - | [] -> p_quident lid - | arg::[] -> - let uu___ = - let uu___1 = p_quident lid in - let uu___2 = p_argTerm arg in - FStar_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | hd::tl -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = p_quident lid in - let uu___4 = p_argTerm hd in prefix2 uu___3 uu___4 in - FStar_Pprint.group uu___2 in - let uu___2 = - let uu___3 = FStar_Pprint.separate_map break1 p_argTerm tl in - jump2 uu___3 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - FStar_Pprint.group uu___) - | uu___ -> p_indexingTerm e -and (p_argTerm : - (FStar_Parser_AST.term * FStar_Parser_AST.imp) -> FStar_Pprint.document) = - fun arg_imp -> - match arg_imp with - | (u, FStar_Parser_AST.UnivApp) -> p_universe u - | (e, FStar_Parser_AST.FsTypApp) -> - (FStar_Errors.log_issue FStar_Parser_AST.hasRange_term e - FStar_Errors_Codes.Warning_UnexpectedFsTypApp () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Unexpected FsTypApp, output might not be formatted correctly."); - (let uu___1 = p_indexingTerm e in - FStar_Pprint.surround (Prims.of_int (2)) Prims.int_one - FStar_Pprint.langle uu___1 FStar_Pprint.rangle)) - | (e, FStar_Parser_AST.Hash) -> - let uu___ = str "#" in - let uu___1 = p_indexingTerm e in FStar_Pprint.op_Hat_Hat uu___ uu___1 - | (e, FStar_Parser_AST.HashBrace t) -> - let uu___ = str "#[" in - let uu___1 = - let uu___2 = p_indexingTerm t in - let uu___3 = - let uu___4 = str "]" in - let uu___5 = p_indexingTerm e in - FStar_Pprint.op_Hat_Hat uu___4 uu___5 in - FStar_Pprint.op_Hat_Hat uu___2 uu___3 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 - | (e, FStar_Parser_AST.Infix) -> p_indexingTerm e - | (e, FStar_Parser_AST.Nothing) -> p_indexingTerm e -and (p_indexingTerm_aux : - (FStar_Parser_AST.term -> FStar_Pprint.document) -> - FStar_Parser_AST.term -> FStar_Pprint.document) - = - fun exit -> - fun e -> - match e.FStar_Parser_AST.tm with - | FStar_Parser_AST.Op (id, e1::e2::[]) when - let uu___ = FStar_Ident.string_of_id id in uu___ = ".()" -> - let uu___ = - let uu___1 = p_indexingTerm_aux p_atomicTermNotQUident e1 in - let uu___2 = - let uu___3 = - let uu___4 = p_term false false e2 in - soft_parens_with_nesting uu___4 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.dot uu___3 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | FStar_Parser_AST.Op (id, e1::e2::[]) when - let uu___ = FStar_Ident.string_of_id id in uu___ = ".[]" -> - let uu___ = - let uu___1 = p_indexingTerm_aux p_atomicTermNotQUident e1 in - let uu___2 = - let uu___3 = - let uu___4 = p_term false false e2 in - soft_brackets_with_nesting uu___4 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.dot uu___3 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | FStar_Parser_AST.Op (id, e1::e2::[]) when - let uu___ = FStar_Ident.string_of_id id in uu___ = ".(||)" -> - let uu___ = - let uu___1 = p_indexingTerm_aux p_atomicTermNotQUident e1 in - let uu___2 = - let uu___3 = - let uu___4 = p_term false false e2 in - soft_lens_access_with_nesting uu___4 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.dot uu___3 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | FStar_Parser_AST.Op (id, e1::e2::[]) when - let uu___ = FStar_Ident.string_of_id id in uu___ = ".[||]" -> - let uu___ = - let uu___1 = p_indexingTerm_aux p_atomicTermNotQUident e1 in - let uu___2 = - let uu___3 = - let uu___4 = p_term false false e2 in - soft_brackets_lens_access_with_nesting uu___4 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.dot uu___3 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | uu___ -> exit e -and (p_indexingTerm : FStar_Parser_AST.term -> FStar_Pprint.document) = - fun e -> p_indexingTerm_aux p_atomicTerm e -and (p_atomicTerm : FStar_Parser_AST.term -> FStar_Pprint.document) = - fun e -> - match e.FStar_Parser_AST.tm with - | FStar_Parser_AST.LetOpen (lid, e1) -> - let uu___ = p_quident lid in - let uu___1 = - let uu___2 = - let uu___3 = p_term false false e1 in - soft_parens_with_nesting uu___3 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.dot uu___2 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 - | FStar_Parser_AST.Name lid -> p_quident lid - | FStar_Parser_AST.Construct (lid, []) when is_general_construction e -> - p_quident lid - | FStar_Parser_AST.Op (op, e1::[]) when is_general_prefix_op op -> - let uu___ = let uu___1 = FStar_Ident.string_of_id op in str uu___1 in - let uu___1 = p_atomicTerm e1 in FStar_Pprint.op_Hat_Hat uu___ uu___1 - | FStar_Parser_AST.ListLiteral ts -> - let uu___ = - let uu___1 = FStar_Pprint.op_Hat_Hat FStar_Pprint.semi break1 in - separate_map_or_flow_last uu___1 - (fun ps -> p_noSeqTermAndComment ps false) ts in - FStar_Pprint.surround (Prims.of_int (2)) Prims.int_zero - FStar_Pprint.lbracket uu___ FStar_Pprint.rbracket - | FStar_Parser_AST.SeqLiteral ts -> - let uu___ = - let uu___1 = FStar_Pprint.doc_of_string "seq!" in - FStar_Pprint.op_Hat_Hat uu___1 FStar_Pprint.lbracket in - let uu___1 = - let uu___2 = FStar_Pprint.op_Hat_Hat FStar_Pprint.semi break1 in - separate_map_or_flow_last uu___2 - (fun ps -> p_noSeqTermAndComment ps false) ts in - FStar_Pprint.surround (Prims.of_int (2)) Prims.int_zero uu___ uu___1 - FStar_Pprint.rbracket - | uu___ -> p_atomicTermNotQUident e -and (p_atomicTermNotQUident : FStar_Parser_AST.term -> FStar_Pprint.document) - = - fun e -> - match e.FStar_Parser_AST.tm with - | FStar_Parser_AST.Wild -> FStar_Pprint.underscore - | FStar_Parser_AST.Var lid when - FStar_Ident.lid_equals lid FStar_Parser_Const.assert_lid -> - str "assert" - | FStar_Parser_AST.Var lid when - FStar_Ident.lid_equals lid FStar_Parser_Const.assume_lid -> - str "assume" - | FStar_Parser_AST.Tvar tv -> p_tvar tv - | FStar_Parser_AST.Const c -> - (match c with - | FStar_Const.Const_char x when x = 10 -> str "0x0Az" - | uu___ -> p_constant c) - | FStar_Parser_AST.Name lid when - FStar_Ident.lid_equals lid FStar_Parser_Const.true_lid -> str "True" - | FStar_Parser_AST.Name lid when - FStar_Ident.lid_equals lid FStar_Parser_Const.false_lid -> - str "False" - | FStar_Parser_AST.Op (op, e1::[]) when is_general_prefix_op op -> - let uu___ = let uu___1 = FStar_Ident.string_of_id op in str uu___1 in - let uu___1 = p_atomicTermNotQUident e1 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 - | FStar_Parser_AST.Op (op, []) -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Ident.string_of_id op in str uu___3 in - let uu___3 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.space FStar_Pprint.rparen in - FStar_Pprint.op_Hat_Hat uu___2 uu___3 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.space uu___1 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.lparen uu___ - | FStar_Parser_AST.Construct (lid, args) when - (is_dtuple_constructor lid) && (all1_explicit args) -> - let uu___ = - FStar_Pprint.op_Hat_Hat FStar_Pprint.lparen FStar_Pprint.bar in - let uu___1 = - let uu___2 = FStar_Pprint.op_Hat_Hat FStar_Pprint.comma break1 in - FStar_Pprint.separate_map uu___2 - (fun uu___3 -> match uu___3 with | (e1, uu___4) -> p_tmEq e1) - args in - let uu___2 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.bar FStar_Pprint.rparen in - FStar_Pprint.surround (Prims.of_int (2)) Prims.int_one uu___ uu___1 - uu___2 - | FStar_Parser_AST.Construct (lid, args) when - (is_tuple_constructor lid) && (all1_explicit args) -> - let uu___ = p_tmTuple e in FStar_Pprint.parens uu___ - | FStar_Parser_AST.Project (e1, lid) -> - let uu___ = - let uu___1 = p_atomicTermNotQUident e1 in - let uu___2 = - let uu___3 = p_qlident lid in - FStar_Pprint.op_Hat_Hat FStar_Pprint.dot uu___3 in - FStar_Pprint.prefix (Prims.of_int (2)) Prims.int_zero uu___1 uu___2 in - FStar_Pprint.group uu___ - | uu___ -> p_projectionLHS e -and (p_projectionLHS : FStar_Parser_AST.term -> FStar_Pprint.document) = - fun e -> - match e.FStar_Parser_AST.tm with - | FStar_Parser_AST.Var lid -> p_qlident lid - | FStar_Parser_AST.Projector (constr_lid, field_lid) -> - let uu___ = p_quident constr_lid in - let uu___1 = - let uu___2 = - let uu___3 = p_lident field_lid in - FStar_Pprint.op_Hat_Hat FStar_Pprint.dot uu___3 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.qmark uu___2 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 - | FStar_Parser_AST.Discrim constr_lid -> - let uu___ = p_quident constr_lid in - FStar_Pprint.op_Hat_Hat uu___ FStar_Pprint.qmark - | FStar_Parser_AST.Paren e1 -> - let uu___ = p_term_sep false false e1 in - (match uu___ with - | (comm, t) -> - let doc = soft_parens_with_nesting t in - if comm = FStar_Pprint.empty - then doc - else - (let uu___2 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline doc in - FStar_Pprint.op_Hat_Hat comm uu___2)) - | uu___ when is_ref_set e -> - let es = extract_from_ref_set e in - let uu___1 = - FStar_Pprint.op_Hat_Hat FStar_Pprint.bang FStar_Pprint.lbrace in - let uu___2 = - let uu___3 = FStar_Pprint.op_Hat_Hat FStar_Pprint.comma break1 in - separate_map_or_flow uu___3 p_appTerm es in - FStar_Pprint.surround (Prims.of_int (2)) Prims.int_zero uu___1 uu___2 - FStar_Pprint.rbrace - | FStar_Parser_AST.Labeled (e1, s, b) -> - let uu___ = str (Prims.strcat "(*" (Prims.strcat s "*)")) in - let uu___1 = p_term false false e1 in - FStar_Pprint.op_Hat_Slash_Hat uu___ uu___1 - | FStar_Parser_AST.Op (op, args) when - let uu___ = handleable_op op args in Prims.op_Negation uu___ -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Ident.string_of_id op in - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length args) in - Prims.strcat uu___5 - " arguments couldn't be handled by the pretty printer" in - Prims.strcat " with " uu___4 in - Prims.strcat uu___2 uu___3 in - Prims.strcat "Operation " uu___1 in - failwith uu___ - | FStar_Parser_AST.Uvar id -> - failwith "Unexpected universe variable out of universe context" - | FStar_Parser_AST.Wild -> - let uu___ = p_term false false e in soft_parens_with_nesting uu___ - | FStar_Parser_AST.Const uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.Op uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.Tvar uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.Var uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.Name uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.Construct uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.Abs uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.App uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.Let uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.LetOperator uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.LetOpen uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.LetOpenRecord uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.Seq uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.Bind uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.If uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.Match uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.TryWith uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.Ascribed uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.Record uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.Project uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.Product uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.Sum uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.QForall uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.QExists uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.QuantOp uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.Refine uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.NamedTyp uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.Requires uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.Ensures uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.Decreases uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.Attributes uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.Quote uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.VQuote uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.Antiquote uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.CalcProof uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.ListLiteral uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.SeqLiteral uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.ElimExists uu___ -> - let uu___1 = p_term false false e in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.LexList l -> - let uu___ = - let uu___1 = str "%" in - let uu___2 = p_term_list false false l in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | FStar_Parser_AST.WFOrder (rel, e1) -> p_dec_wf false false rel e1 -and (p_constant : FStar_Const.sconst -> FStar_Pprint.document) = - fun uu___ -> - match uu___ with - | FStar_Const.Const_effect -> str "Effect" - | FStar_Const.Const_unit -> str "()" - | FStar_Const.Const_bool b -> FStar_Pprint.doc_of_bool b - | FStar_Const.Const_real r -> str (Prims.strcat r "R") - | FStar_Const.Const_char x -> FStar_Pprint.doc_of_char x - | FStar_Const.Const_string (s, uu___1) -> - let uu___2 = str (FStar_Compiler_String.escaped s) in - FStar_Pprint.dquotes uu___2 - | FStar_Const.Const_int (repr, sign_width_opt) -> - let signedness uu___1 = - match uu___1 with - | FStar_Const.Unsigned -> str "u" - | FStar_Const.Signed -> FStar_Pprint.empty in - let width uu___1 = - match uu___1 with - | FStar_Const.Int8 -> str "y" - | FStar_Const.Int16 -> str "s" - | FStar_Const.Int32 -> str "l" - | FStar_Const.Int64 -> str "L" in - let suffix uu___1 = - match uu___1 with - | (s, w) -> - (match (s, w) with - | (uu___2, FStar_Const.Sizet) -> str "sz" - | uu___2 -> - let uu___3 = signedness s in - let uu___4 = width w in - FStar_Pprint.op_Hat_Hat uu___3 uu___4) in - let ending = default_or_map FStar_Pprint.empty suffix sign_width_opt in - let uu___1 = str repr in FStar_Pprint.op_Hat_Hat uu___1 ending - | FStar_Const.Const_range_of -> str "range_of" - | FStar_Const.Const_set_range_of -> str "set_range_of" - | FStar_Const.Const_range r -> - let uu___1 = FStar_Compiler_Range_Ops.string_of_range r in str uu___1 - | FStar_Const.Const_reify uu___1 -> str "reify" - | FStar_Const.Const_reflect lid -> - let uu___1 = p_quident lid in - let uu___2 = - let uu___3 = - let uu___4 = str "reflect" in - FStar_Pprint.op_Hat_Hat FStar_Pprint.dot uu___4 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.qmark uu___3 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 -and (p_universe : FStar_Parser_AST.term -> FStar_Pprint.document) = - fun u -> - let uu___ = str "u#" in - let uu___1 = p_atomicUniverse u in FStar_Pprint.op_Hat_Hat uu___ uu___1 -and (p_universeFrom : FStar_Parser_AST.term -> FStar_Pprint.document) = - fun u -> - match u.FStar_Parser_AST.tm with - | FStar_Parser_AST.Op (id, u1::u2::[]) when - let uu___ = FStar_Ident.string_of_id id in uu___ = "+" -> - let uu___ = - let uu___1 = p_universeFrom u1 in - let uu___2 = - let uu___3 = p_universeFrom u2 in - FStar_Pprint.op_Hat_Slash_Hat FStar_Pprint.plus uu___3 in - FStar_Pprint.op_Hat_Slash_Hat uu___1 uu___2 in - FStar_Pprint.group uu___ - | FStar_Parser_AST.App uu___ -> - let uu___1 = head_and_args u in - (match uu___1 with - | (head, args) -> - (match head.FStar_Parser_AST.tm with - | FStar_Parser_AST.Var maybe_max_lid when - FStar_Ident.lid_equals maybe_max_lid - FStar_Parser_Const.max_lid - -> - let uu___2 = - let uu___3 = p_qlident FStar_Parser_Const.max_lid in - let uu___4 = - FStar_Pprint.separate_map FStar_Pprint.space - (fun uu___5 -> - match uu___5 with - | (u1, uu___6) -> p_atomicUniverse u1) args in - op_Hat_Slash_Plus_Hat uu___3 uu___4 in - FStar_Pprint.group uu___2 - | uu___2 -> - let uu___3 = - let uu___4 = FStar_Parser_AST.term_to_string u in - FStar_Compiler_Util.format1 - "Invalid term in universe context %s" uu___4 in - failwith uu___3)) - | uu___ -> p_atomicUniverse u -and (p_atomicUniverse : FStar_Parser_AST.term -> FStar_Pprint.document) = - fun u -> - match u.FStar_Parser_AST.tm with - | FStar_Parser_AST.Wild -> FStar_Pprint.underscore - | FStar_Parser_AST.Const (FStar_Const.Const_int (r, sw)) -> - p_constant (FStar_Const.Const_int (r, sw)) - | FStar_Parser_AST.Uvar id -> - let uu___ = FStar_Ident.string_of_id id in str uu___ - | FStar_Parser_AST.Paren u1 -> - let uu___ = p_universeFrom u1 in soft_parens_with_nesting uu___ - | FStar_Parser_AST.App uu___ -> - let uu___1 = p_universeFrom u in soft_parens_with_nesting uu___1 - | FStar_Parser_AST.Op (id, uu___::uu___1::[]) when - let uu___2 = FStar_Ident.string_of_id id in uu___2 = "+" -> - let uu___2 = p_universeFrom u in soft_parens_with_nesting uu___2 - | uu___ -> - let uu___1 = - let uu___2 = FStar_Parser_AST.term_to_string u in - FStar_Compiler_Util.format1 "Invalid term in universe context %s" - uu___2 in - failwith uu___1 -let (term_to_document : FStar_Parser_AST.term -> FStar_Pprint.document) = - fun e -> p_term false false e -let (signature_to_document : FStar_Parser_AST.decl -> FStar_Pprint.document) - = fun e -> p_justSig e -let (decl_to_document : FStar_Parser_AST.decl -> FStar_Pprint.document) = - fun e -> p_decl e -let (pat_to_document : FStar_Parser_AST.pattern -> FStar_Pprint.document) = - fun p -> p_disjunctivePattern p -let (binder_to_document : FStar_Parser_AST.binder -> FStar_Pprint.document) = - fun b -> p_binder true b -let (modul_to_document : FStar_Parser_AST.modul -> FStar_Pprint.document) = - fun m -> - match m with - | FStar_Parser_AST.Module (uu___, decls) -> - let uu___1 = FStar_Compiler_List.map decl_to_document decls in - FStar_Pprint.separate FStar_Pprint.hardline uu___1 - | FStar_Parser_AST.Interface (uu___, decls, uu___1) -> - let uu___2 = FStar_Compiler_List.map decl_to_document decls in - FStar_Pprint.separate FStar_Pprint.hardline uu___2 -let (comments_to_document : - (Prims.string * FStar_Compiler_Range_Type.range) Prims.list -> - FStar_Pprint.document) - = - fun comments -> - FStar_Pprint.separate_map FStar_Pprint.hardline - (fun uu___ -> match uu___ with | (comment, range) -> str comment) - comments -let (extract_decl_range : FStar_Parser_AST.decl -> decl_meta) = - fun d -> - let has_qs = - match ((d.FStar_Parser_AST.quals), (d.FStar_Parser_AST.d)) with - | ((FStar_Parser_AST.Assumption)::[], FStar_Parser_AST.Assume - (id, uu___)) -> false - | ([], uu___) -> false - | uu___ -> true in - { - r = (d.FStar_Parser_AST.drange); - has_qs; - has_attrs = - (Prims.op_Negation - (FStar_Compiler_List.isEmpty d.FStar_Parser_AST.attrs)) - } -let (decls_with_comments_to_document : - FStar_Parser_AST.decl Prims.list -> - (Prims.string * FStar_Compiler_Range_Type.range) Prims.list -> - (FStar_Pprint.document * (Prims.string * - FStar_Compiler_Range_Type.range) Prims.list)) - = - fun decls -> - fun comments -> - match decls with - | [] -> (FStar_Pprint.empty, comments) - | d::ds -> - let uu___ = ((d :: ds), (d.FStar_Parser_AST.drange)) in - (match uu___ with - | (decls1, first_range) -> - (FStar_Compiler_Effect.op_Colon_Equals comment_stack comments; - (let initial_comment = - let uu___2 = - FStar_Compiler_Range_Ops.start_of_range first_range in - place_comments_until_pos Prims.int_zero Prims.int_one - uu___2 dummy_meta FStar_Pprint.empty false true in - let doc = - separate_map_with_comments FStar_Pprint.empty - FStar_Pprint.empty p_decl decls1 extract_decl_range in - let comments1 = FStar_Compiler_Effect.op_Bang comment_stack in - FStar_Compiler_Effect.op_Colon_Equals comment_stack []; - (let uu___3 = FStar_Pprint.op_Hat_Hat initial_comment doc in - (uu___3, comments1))))) -let (modul_with_comments_to_document : - FStar_Parser_AST.modul -> - (Prims.string * FStar_Compiler_Range_Type.range) Prims.list -> - (FStar_Pprint.document * (Prims.string * - FStar_Compiler_Range_Type.range) Prims.list)) - = - fun m -> - fun comments -> - let decls = - match m with - | FStar_Parser_AST.Module (uu___, decls1) -> decls1 - | FStar_Parser_AST.Interface (uu___, decls1, uu___1) -> decls1 in - decls_with_comments_to_document decls comments -let (decl_with_comments_to_document : - FStar_Parser_AST.decl -> - (Prims.string * FStar_Compiler_Range_Type.range) Prims.list -> - (FStar_Pprint.document * (Prims.string * - FStar_Compiler_Range_Type.range) Prims.list)) - = fun d -> fun comments -> decls_with_comments_to_document [d] comments \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Prettyprint.ml b/ocaml/fstar-lib/generated/FStar_Prettyprint.ml deleted file mode 100644 index 375cdbf123b..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Prettyprint.ml +++ /dev/null @@ -1,88 +0,0 @@ -open Prims -type printing_mode = - | ToTempFile - | FromTempToStdout - | FromTempToFile -let (uu___is_ToTempFile : printing_mode -> Prims.bool) = - fun projectee -> match projectee with | ToTempFile -> true | uu___ -> false -let (uu___is_FromTempToStdout : printing_mode -> Prims.bool) = - fun projectee -> - match projectee with | FromTempToStdout -> true | uu___ -> false -let (uu___is_FromTempToFile : printing_mode -> Prims.bool) = - fun projectee -> - match projectee with | FromTempToFile -> true | uu___ -> false -let (temp_file_name : Prims.string -> Prims.string) = - fun f -> FStar_Compiler_Util.format1 "%s.print_.fst" f -let (generate : printing_mode -> Prims.string Prims.list -> unit) = - fun m -> - fun filenames -> - let parse_and_prettyprint m1 filename = - let uu___ = FStar_Parser_Driver.parse_file filename in - match uu___ with - | (modul, comments) -> - let outf = - match m1 with - | FromTempToStdout -> FStar_Pervasives_Native.None - | FromTempToFile -> - let outf1 = - FStar_Compiler_Util.open_file_for_writing filename in - FStar_Pervasives_Native.Some outf1 - | ToTempFile -> - let outf1 = - let uu___1 = temp_file_name filename in - FStar_Compiler_Util.open_file_for_writing uu___1 in - FStar_Pervasives_Native.Some outf1 in - let leftover_comments = - let comments1 = FStar_Compiler_List.rev comments in - let uu___1 = - FStar_Parser_ToDocument.modul_with_comments_to_document modul - comments1 in - match uu___1 with - | (doc, comments2) -> - ((match outf with - | FStar_Pervasives_Native.Some f -> - let uu___3 = - FStar_Pprint.pretty_string - (FStar_Compiler_Util.float_of_string "1.0") - (Prims.of_int (100)) doc in - FStar_Compiler_Util.append_to_file f uu___3 - | FStar_Pervasives_Native.None -> - FStar_Pprint.pretty_out_channel - (FStar_Compiler_Util.float_of_string "1.0") - (Prims.of_int (100)) doc FStar_Compiler_Util.stdout); - comments2) in - let left_over_doc = - if - Prims.op_Negation - (FStar_Compiler_List.isEmpty leftover_comments) - then - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Parser_ToDocument.comments_to_document - leftover_comments in - [uu___4] in - FStar_Pprint.hardline :: uu___3 in - FStar_Pprint.hardline :: uu___2 in - FStar_Pprint.concat uu___1 - else - if m1 = FromTempToStdout - then - FStar_Pprint.concat - [FStar_Pprint.hardline; FStar_Pprint.hardline] - else FStar_Pprint.empty in - (match outf with - | FStar_Pervasives_Native.None -> - FStar_Pprint.pretty_out_channel - (FStar_Compiler_Util.float_of_string "1.0") - (Prims.of_int (100)) left_over_doc - FStar_Compiler_Util.stdout - | FStar_Pervasives_Native.Some outf1 -> - ((let uu___2 = - FStar_Pprint.pretty_string - (FStar_Compiler_Util.float_of_string "1.0") - (Prims.of_int (100)) left_over_doc in - FStar_Compiler_Util.append_to_file outf1 uu___2); - FStar_Compiler_Util.close_out_channel outf1)) in - FStar_Compiler_List.iter (parse_and_prettyprint m) filenames \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Profiling.ml b/ocaml/fstar-lib/generated/FStar_Profiling.ml deleted file mode 100644 index 102afbffe44..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Profiling.ml +++ /dev/null @@ -1,154 +0,0 @@ -open Prims -type counter = - { - cid: Prims.string ; - total_time: Prims.int FStar_Compiler_Effect.ref ; - running: Prims.bool FStar_Compiler_Effect.ref ; - undercount: Prims.bool FStar_Compiler_Effect.ref } -let (__proj__Mkcounter__item__cid : counter -> Prims.string) = - fun projectee -> - match projectee with | { cid; total_time; running; undercount;_} -> cid -let (__proj__Mkcounter__item__total_time : - counter -> Prims.int FStar_Compiler_Effect.ref) = - fun projectee -> - match projectee with - | { cid; total_time; running; undercount;_} -> total_time -let (__proj__Mkcounter__item__running : - counter -> Prims.bool FStar_Compiler_Effect.ref) = - fun projectee -> - match projectee with - | { cid; total_time; running; undercount;_} -> running -let (__proj__Mkcounter__item__undercount : - counter -> Prims.bool FStar_Compiler_Effect.ref) = - fun projectee -> - match projectee with - | { cid; total_time; running; undercount;_} -> undercount -let (json_of_counter : counter -> FStar_Json.json) = - fun c -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Compiler_Effect.op_Bang c.total_time in - FStar_Json.JsonInt uu___4 in - ("total_time", uu___3) in - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = FStar_Compiler_Effect.op_Bang c.running in - FStar_Json.JsonBool uu___6 in - ("running", uu___5) in - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = FStar_Compiler_Effect.op_Bang c.undercount in - FStar_Json.JsonBool uu___8 in - ("undercount", uu___7) in - [uu___6] in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - ("id", (FStar_Json.JsonStr (c.cid))) :: uu___1 in - FStar_Json.JsonAssoc uu___ -let (new_counter : Prims.string -> counter) = - fun cid -> - let uu___ = FStar_Compiler_Util.mk_ref Prims.int_zero in - let uu___1 = FStar_Compiler_Util.mk_ref false in - let uu___2 = FStar_Compiler_Util.mk_ref false in - { cid; total_time = uu___; running = uu___1; undercount = uu___2 } -let (all_counters : counter FStar_Compiler_Util.smap) = - FStar_Compiler_Util.smap_create (Prims.of_int (20)) -let (create_or_lookup_counter : Prims.string -> counter) = - fun cid -> - let uu___ = FStar_Compiler_Util.smap_try_find all_counters cid in - match uu___ with - | FStar_Pervasives_Native.Some c -> c - | FStar_Pervasives_Native.None -> - let c = new_counter cid in - (FStar_Compiler_Util.smap_add all_counters cid c; c) -let profile : - 'a . - (unit -> 'a) -> - Prims.string FStar_Pervasives_Native.option -> Prims.string -> 'a - = - fun f -> - fun module_name -> - fun cid -> - let uu___ = FStar_Options.profile_enabled module_name cid in - if uu___ - then - let c = create_or_lookup_counter cid in - let uu___1 = FStar_Compiler_Effect.op_Bang c.running in - (if uu___1 - then f () - else - (try - (fun uu___3 -> - match () with - | () -> - (FStar_Compiler_Effect.op_Colon_Equals c.running true; - (let uu___5 = FStar_Compiler_Util.record_time f in - match uu___5 with - | (res, elapsed) -> - ((let uu___7 = - let uu___8 = - FStar_Compiler_Effect.op_Bang c.total_time in - uu___8 + elapsed in - FStar_Compiler_Effect.op_Colon_Equals - c.total_time uu___7); - FStar_Compiler_Effect.op_Colon_Equals c.running - false; - res)))) () - with - | uu___3 -> - (FStar_Compiler_Effect.op_Colon_Equals c.running false; - FStar_Compiler_Effect.op_Colon_Equals c.undercount true; - FStar_Compiler_Effect.raise uu___3))) - else f () -let (report_json : Prims.string -> counter -> unit) = - fun tag -> - fun c -> - let counter1 = json_of_counter c in - let uu___ = - FStar_Json.string_of_json - (FStar_Json.JsonAssoc - [("tag", (FStar_Json.JsonStr tag)); ("counter", counter1)]) in - FStar_Compiler_Util.print1_error "%s\n" uu___ -let (report_human : Prims.string -> counter -> unit) = - fun tag -> - fun c -> - let warn = - let uu___ = FStar_Compiler_Effect.op_Bang c.running in - if uu___ - then " (Warning, this counter is still running)" - else - (let uu___2 = FStar_Compiler_Effect.op_Bang c.undercount in - if uu___2 - then - " (Warning, some operations raised exceptions and we not accounted for)" - else "") in - let uu___ = - let uu___1 = FStar_Compiler_Effect.op_Bang c.total_time in - FStar_Compiler_Util.string_of_int uu___1 in - FStar_Compiler_Util.print4 "%s, profiled %s:\t %s ms%s\n" tag c.cid - uu___ warn -let (report : Prims.string -> counter -> unit) = - fun tag -> - fun c -> - let uu___ = FStar_Options.message_format () in - match uu___ with - | FStar_Options.Human -> report_human tag c - | FStar_Options.Json -> report_json tag c -let (report_and_clear : Prims.string -> unit) = - fun tag -> - let ctrs = - FStar_Compiler_Util.smap_fold all_counters - (fun uu___ -> fun v -> fun l -> v :: l) [] in - FStar_Compiler_Util.smap_clear all_counters; - (let ctrs1 = - FStar_Compiler_Util.sort_with - (fun c1 -> - fun c2 -> - let uu___1 = FStar_Compiler_Effect.op_Bang c2.total_time in - let uu___2 = FStar_Compiler_Effect.op_Bang c1.total_time in - uu___1 - uu___2) ctrs in - FStar_Compiler_List.iter (report tag) ctrs1) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Pure_BreakVC.ml b/ocaml/fstar-lib/generated/FStar_Pure_BreakVC.ml index 44611d6c70a..f87b83d85f5 100644 --- a/ocaml/fstar-lib/generated/FStar_Pure_BreakVC.ml +++ b/ocaml/fstar-lib/generated/FStar_Pure_BreakVC.ml @@ -3,7 +3,7 @@ type 'p break_wp' = unit FStar_Pervasives.spinoff let (post : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> let uu___1 = - FStar_Tactics_V2_Builtins.norm + FStarC_Tactics_V2_Builtins.norm [FStar_Pervasives.delta_fully ["FStar.Pure.BreakVC.mono_lem"; "FStar.Pure.BreakVC.break_wp'"]] in FStar_Tactics_Effect.tac_bind diff --git a/ocaml/fstar-lib/generated/FStar_Reflection_TermEq.ml b/ocaml/fstar-lib/generated/FStar_Reflection_TermEq.ml index 103b0ec326b..8e797d1b111 100644 --- a/ocaml/fstar-lib/generated/FStar_Reflection_TermEq.ml +++ b/ocaml/fstar-lib/generated/FStar_Reflection_TermEq.ml @@ -14,8 +14,8 @@ type 'p faithful_pattern = Obj.t type 'pb faithful_pattern_arg = Obj.t type 'ats faithful_attrs = Obj.t type 'c faithful_comp = Obj.t -type faithful_term = FStar_Reflection_Types.term -type faithful_universe = FStar_Reflection_Types.universe +type faithful_term = FStarC_Reflection_Types.term +type faithful_universe = FStarC_Reflection_Types.universe type _cmpres = | Eq | Neq @@ -49,28 +49,30 @@ let op_Amp_Amp_Amp : | (Neq, uu___) -> Neq | (uu___, Neq) -> Neq | uu___ -> Unknown -let (bv_cmp : FStar_Reflection_Types.bv comparator_for) = +let (bv_cmp : FStarC_Reflection_Types.bv comparator_for) = fun x1 -> fun x2 -> - let v1 = FStar_Reflection_V2_Builtins.inspect_bv x1 in - let v2 = FStar_Reflection_V2_Builtins.inspect_bv x2 in + let v1 = FStarC_Reflection_V2_Builtins.inspect_bv x1 in + let v2 = FStarC_Reflection_V2_Builtins.inspect_bv x2 in if - v1.FStar_Reflection_V2_Data.index = v2.FStar_Reflection_V2_Data.index + v1.FStarC_Reflection_V2_Data.index = + v2.FStarC_Reflection_V2_Data.index then Eq else Neq -let (namedv_cmp : FStar_Reflection_Types.namedv comparator_for) = +let (namedv_cmp : FStarC_Reflection_Types.namedv comparator_for) = fun x1 -> fun x2 -> - let v1 = FStar_Reflection_V2_Builtins.inspect_namedv x1 in - let v2 = FStar_Reflection_V2_Builtins.inspect_namedv x2 in - if v1.FStar_Reflection_V2_Data.uniq = v2.FStar_Reflection_V2_Data.uniq + let v1 = FStarC_Reflection_V2_Builtins.inspect_namedv x1 in + let v2 = FStarC_Reflection_V2_Builtins.inspect_namedv x2 in + if + v1.FStarC_Reflection_V2_Data.uniq = v2.FStarC_Reflection_V2_Data.uniq then Eq else Neq -let (fv_cmp : FStar_Reflection_Types.fv comparator_for) = +let (fv_cmp : FStarC_Reflection_Types.fv comparator_for) = fun f1 -> fun f2 -> - let n1 = FStar_Reflection_V2_Builtins.inspect_fv f1 in - let n2 = FStar_Reflection_V2_Builtins.inspect_fv f2 in + let n1 = FStarC_Reflection_V2_Builtins.inspect_fv f1 in + let n2 = FStarC_Reflection_V2_Builtins.inspect_fv f2 in if n1 = n2 then Eq else Neq let opt_cmp : 'a . 'a comparator_for -> 'a FStar_Pervasives_Native.option comparator_for @@ -190,127 +192,130 @@ let either_dec_cmp : let eq_cmp : 'uuuuu . 'uuuuu comparator_for = fun x -> fun y -> if x = y then Eq else Neq let (range_cmp : FStar_Range.range comparator_for) = fun r1 -> fun r2 -> Eq -let (ident_cmp : FStar_Reflection_Types.ident comparator_for) = +let (ident_cmp : FStarC_Reflection_Types.ident comparator_for) = fun i1 -> fun i2 -> - let iv1 = FStar_Reflection_V2_Builtins.inspect_ident i1 in - let iv2 = FStar_Reflection_V2_Builtins.inspect_ident i2 in + let iv1 = FStarC_Reflection_V2_Builtins.inspect_ident i1 in + let iv2 = FStarC_Reflection_V2_Builtins.inspect_ident i2 in Obj.magic (eq_cmp (FStar_Pervasives_Native.fst iv1) (FStar_Pervasives_Native.fst iv2)) -let rec (univ_cmp : FStar_Reflection_Types.universe comparator_for) = +let rec (univ_cmp : FStarC_Reflection_Types.universe comparator_for) = fun u1 -> fun u2 -> - let uv1 = FStar_Reflection_V2_Builtins.inspect_universe u1 in - let uv2 = FStar_Reflection_V2_Builtins.inspect_universe u2 in + let uv1 = FStarC_Reflection_V2_Builtins.inspect_universe u1 in + let uv2 = FStarC_Reflection_V2_Builtins.inspect_universe u2 in match (uv1, uv2) with - | (FStar_Reflection_V2_Data.Uv_Zero, FStar_Reflection_V2_Data.Uv_Zero) - -> Obj.magic (Obj.repr Eq) - | (FStar_Reflection_V2_Data.Uv_Succ u11, - FStar_Reflection_V2_Data.Uv_Succ u21) -> + | (FStarC_Reflection_V2_Data.Uv_Zero, + FStarC_Reflection_V2_Data.Uv_Zero) -> Obj.magic (Obj.repr Eq) + | (FStarC_Reflection_V2_Data.Uv_Succ u11, + FStarC_Reflection_V2_Data.Uv_Succ u21) -> Obj.magic (Obj.repr (univ_cmp u11 u21)) - | (FStar_Reflection_V2_Data.Uv_Max us1, FStar_Reflection_V2_Data.Uv_Max - us2) -> Obj.magic (Obj.repr (list_dec_cmp u1 u2 univ_cmp us1 us2)) - | (FStar_Reflection_V2_Data.Uv_BVar v1, - FStar_Reflection_V2_Data.Uv_BVar v2) -> + | (FStarC_Reflection_V2_Data.Uv_Max us1, + FStarC_Reflection_V2_Data.Uv_Max us2) -> + Obj.magic (Obj.repr (list_dec_cmp u1 u2 univ_cmp us1 us2)) + | (FStarC_Reflection_V2_Data.Uv_BVar v1, + FStarC_Reflection_V2_Data.Uv_BVar v2) -> Obj.magic (Obj.repr (eq_cmp v1 v2)) - | (FStar_Reflection_V2_Data.Uv_Name n1, - FStar_Reflection_V2_Data.Uv_Name n2) -> + | (FStarC_Reflection_V2_Data.Uv_Name n1, + FStarC_Reflection_V2_Data.Uv_Name n2) -> Obj.magic (Obj.repr (ident_cmp n1 n2)) - | (FStar_Reflection_V2_Data.Uv_Unif u11, - FStar_Reflection_V2_Data.Uv_Unif u21) -> + | (FStarC_Reflection_V2_Data.Uv_Unif u11, + FStarC_Reflection_V2_Data.Uv_Unif u21) -> Obj.magic (Obj.repr Unknown) - | (FStar_Reflection_V2_Data.Uv_Unk, FStar_Reflection_V2_Data.Uv_Unk) -> - Obj.magic (Obj.repr Eq) + | (FStarC_Reflection_V2_Data.Uv_Unk, FStarC_Reflection_V2_Data.Uv_Unk) + -> Obj.magic (Obj.repr Eq) | uu___ -> Obj.magic (Obj.repr Neq) -let (const_cmp : FStar_Reflection_V2_Data.vconst comparator_for) = +let (const_cmp : FStarC_Reflection_V2_Data.vconst comparator_for) = fun c1 -> fun c2 -> match (c1, c2) with - | (FStar_Reflection_V2_Data.C_Unit, FStar_Reflection_V2_Data.C_Unit) -> - Obj.magic (Obj.repr Eq) - | (FStar_Reflection_V2_Data.C_Int i1, FStar_Reflection_V2_Data.C_Int + | (FStarC_Reflection_V2_Data.C_Unit, FStarC_Reflection_V2_Data.C_Unit) + -> Obj.magic (Obj.repr Eq) + | (FStarC_Reflection_V2_Data.C_Int i1, FStarC_Reflection_V2_Data.C_Int i2) -> Obj.magic (Obj.repr (eq_cmp i1 i2)) - | (FStar_Reflection_V2_Data.C_True, FStar_Reflection_V2_Data.C_True) -> - Obj.magic (Obj.repr Eq) - | (FStar_Reflection_V2_Data.C_False, FStar_Reflection_V2_Data.C_False) + | (FStarC_Reflection_V2_Data.C_True, FStarC_Reflection_V2_Data.C_True) -> Obj.magic (Obj.repr Eq) - | (FStar_Reflection_V2_Data.C_String s1, - FStar_Reflection_V2_Data.C_String s2) -> + | (FStarC_Reflection_V2_Data.C_False, + FStarC_Reflection_V2_Data.C_False) -> Obj.magic (Obj.repr Eq) + | (FStarC_Reflection_V2_Data.C_String s1, + FStarC_Reflection_V2_Data.C_String s2) -> Obj.magic (Obj.repr (eq_cmp s1 s2)) - | (FStar_Reflection_V2_Data.C_Range r1, - FStar_Reflection_V2_Data.C_Range r2) -> + | (FStarC_Reflection_V2_Data.C_Range r1, + FStarC_Reflection_V2_Data.C_Range r2) -> Obj.magic (Obj.repr (range_cmp r1 r2)) - | (FStar_Reflection_V2_Data.C_Reify, FStar_Reflection_V2_Data.C_Reify) - -> Obj.magic (Obj.repr Eq) - | (FStar_Reflection_V2_Data.C_Reflect n1, - FStar_Reflection_V2_Data.C_Reflect n2) -> + | (FStarC_Reflection_V2_Data.C_Reify, + FStarC_Reflection_V2_Data.C_Reify) -> Obj.magic (Obj.repr Eq) + | (FStarC_Reflection_V2_Data.C_Reflect n1, + FStarC_Reflection_V2_Data.C_Reflect n2) -> Obj.magic (Obj.repr (eq_cmp n1 n2)) - | (FStar_Reflection_V2_Data.C_Real s1, FStar_Reflection_V2_Data.C_Real - s2) -> Obj.magic (Obj.repr (eq_cmp s1 s2)) + | (FStarC_Reflection_V2_Data.C_Real s1, + FStarC_Reflection_V2_Data.C_Real s2) -> + Obj.magic (Obj.repr (eq_cmp s1 s2)) | uu___ -> Obj.magic (Obj.repr Neq) -let (ctxu_cmp : FStar_Reflection_Types.ctx_uvar_and_subst comparator_for) = +let (ctxu_cmp : FStarC_Reflection_Types.ctx_uvar_and_subst comparator_for) = fun uu___ -> fun uu___1 -> Unknown -let rec (term_cmp : FStar_Reflection_Types.term comparator_for) = +let rec (term_cmp : FStarC_Reflection_Types.term comparator_for) = fun t1 -> fun t2 -> - let tv1 = FStar_Reflection_V2_Builtins.inspect_ln t1 in - let tv2 = FStar_Reflection_V2_Builtins.inspect_ln t2 in + let tv1 = FStarC_Reflection_V2_Builtins.inspect_ln t1 in + let tv2 = FStarC_Reflection_V2_Builtins.inspect_ln t2 in match (tv1, tv2) with - | (FStar_Reflection_V2_Data.Tv_Unsupp, uu___) -> + | (FStarC_Reflection_V2_Data.Tv_Unsupp, uu___) -> Obj.magic (Obj.repr Unknown) - | (uu___, FStar_Reflection_V2_Data.Tv_Unsupp) -> + | (uu___, FStarC_Reflection_V2_Data.Tv_Unsupp) -> Obj.magic (Obj.repr Unknown) - | (FStar_Reflection_V2_Data.Tv_Var v1, FStar_Reflection_V2_Data.Tv_Var - v2) -> Obj.magic (Obj.repr (namedv_cmp v1 v2)) - | (FStar_Reflection_V2_Data.Tv_BVar v1, - FStar_Reflection_V2_Data.Tv_BVar v2) -> + | (FStarC_Reflection_V2_Data.Tv_Var v1, + FStarC_Reflection_V2_Data.Tv_Var v2) -> + Obj.magic (Obj.repr (namedv_cmp v1 v2)) + | (FStarC_Reflection_V2_Data.Tv_BVar v1, + FStarC_Reflection_V2_Data.Tv_BVar v2) -> Obj.magic (Obj.repr (bv_cmp v1 v2)) - | (FStar_Reflection_V2_Data.Tv_FVar f1, - FStar_Reflection_V2_Data.Tv_FVar f2) -> + | (FStarC_Reflection_V2_Data.Tv_FVar f1, + FStarC_Reflection_V2_Data.Tv_FVar f2) -> Obj.magic (Obj.repr (fv_cmp f1 f2)) - | (FStar_Reflection_V2_Data.Tv_UInst (f1, u1), - FStar_Reflection_V2_Data.Tv_UInst (f2, u2)) -> + | (FStarC_Reflection_V2_Data.Tv_UInst (f1, u1), + FStarC_Reflection_V2_Data.Tv_UInst (f2, u2)) -> Obj.magic (Obj.repr (op_Amp_Amp_Amp f1 f2 u1 u2 (fv_cmp f1 f2) (list_dec_cmp t1 t2 univ_cmp u1 u2))) - | (FStar_Reflection_V2_Data.Tv_App (h1, a1), - FStar_Reflection_V2_Data.Tv_App (h2, a2)) -> + | (FStarC_Reflection_V2_Data.Tv_App (h1, a1), + FStarC_Reflection_V2_Data.Tv_App (h2, a2)) -> Obj.magic (Obj.repr (op_Amp_Amp_Amp h1 h2 a1 a2 (term_cmp h1 h2) (arg_cmp a1 a2))) - | (FStar_Reflection_V2_Data.Tv_Abs (b1, e1), - FStar_Reflection_V2_Data.Tv_Abs (b2, e2)) -> + | (FStarC_Reflection_V2_Data.Tv_Abs (b1, e1), + FStarC_Reflection_V2_Data.Tv_Abs (b2, e2)) -> Obj.magic (Obj.repr (op_Amp_Amp_Amp b1 b2 e1 e2 (binder_cmp b1 b2) (term_cmp e1 e2))) - | (FStar_Reflection_V2_Data.Tv_Arrow (b1, c1), - FStar_Reflection_V2_Data.Tv_Arrow (b2, c2)) -> + | (FStarC_Reflection_V2_Data.Tv_Arrow (b1, c1), + FStarC_Reflection_V2_Data.Tv_Arrow (b2, c2)) -> Obj.magic (Obj.repr (op_Amp_Amp_Amp b1 b2 c1 c2 (binder_cmp b1 b2) (comp_cmp c1 c2))) - | (FStar_Reflection_V2_Data.Tv_Type u1, - FStar_Reflection_V2_Data.Tv_Type u2) -> + | (FStarC_Reflection_V2_Data.Tv_Type u1, + FStarC_Reflection_V2_Data.Tv_Type u2) -> Obj.magic (Obj.repr (univ_cmp u1 u2)) - | (FStar_Reflection_V2_Data.Tv_Refine (sb1, r1), - FStar_Reflection_V2_Data.Tv_Refine (sb2, r2)) -> + | (FStarC_Reflection_V2_Data.Tv_Refine (sb1, r1), + FStarC_Reflection_V2_Data.Tv_Refine (sb2, r2)) -> Obj.magic (Obj.repr (op_Amp_Amp_Amp sb1 sb2 r1 r2 (binder_cmp sb1 sb2) (term_cmp r1 r2))) - | (FStar_Reflection_V2_Data.Tv_Const c1, - FStar_Reflection_V2_Data.Tv_Const c2) -> + | (FStarC_Reflection_V2_Data.Tv_Const c1, + FStarC_Reflection_V2_Data.Tv_Const c2) -> Obj.magic (Obj.repr (const_cmp c1 c2)) - | (FStar_Reflection_V2_Data.Tv_Uvar (n1, u1), - FStar_Reflection_V2_Data.Tv_Uvar (n2, u2)) -> + | (FStarC_Reflection_V2_Data.Tv_Uvar (n1, u1), + FStarC_Reflection_V2_Data.Tv_Uvar (n2, u2)) -> Obj.magic (Obj.repr (op_Amp_Amp_Amp n1 n2 u1 u2 (eq_cmp n1 n2) (ctxu_cmp u1 u2))) - | (FStar_Reflection_V2_Data.Tv_Let (r1, attrs1, sb1, e1, b1), - FStar_Reflection_V2_Data.Tv_Let (r2, attrs2, sb2, e2, b2)) -> + | (FStarC_Reflection_V2_Data.Tv_Let (r1, attrs1, sb1, e1, b1), + FStarC_Reflection_V2_Data.Tv_Let (r2, attrs2, sb2, e2, b2)) -> Obj.magic (Obj.repr (op_Amp_Amp_Amp (((r1, attrs1), sb1), e1) @@ -322,16 +327,16 @@ let rec (term_cmp : FStar_Reflection_Types.term comparator_for) = (list_dec_cmp t1 t2 term_cmp attrs1 attrs2)) (binder_cmp sb1 sb2)) (term_cmp e1 e2)) (term_cmp b1 b2))) - | (FStar_Reflection_V2_Data.Tv_Match (sc1, o1, brs1), - FStar_Reflection_V2_Data.Tv_Match (sc2, o2, brs2)) -> + | (FStarC_Reflection_V2_Data.Tv_Match (sc1, o1, brs1), + FStarC_Reflection_V2_Data.Tv_Match (sc2, o2, brs2)) -> Obj.magic (Obj.repr (op_Amp_Amp_Amp (sc1, o1) (sc2, o2) brs1 brs2 (op_Amp_Amp_Amp sc1 sc2 o1 o2 (term_cmp sc1 sc2) (opt_dec_cmp t1 t2 match_returns_ascription_cmp o1 o2)) (list_dec_cmp t1 t2 br_cmp brs1 brs2))) - | (FStar_Reflection_V2_Data.Tv_AscribedT (e1, ta1, tacopt1, eq1), - FStar_Reflection_V2_Data.Tv_AscribedT (e2, ta2, tacopt2, eq2)) -> + | (FStarC_Reflection_V2_Data.Tv_AscribedT (e1, ta1, tacopt1, eq1), + FStarC_Reflection_V2_Data.Tv_AscribedT (e2, ta2, tacopt2, eq2)) -> Obj.magic (Obj.repr (op_Amp_Amp_Amp ((e1, ta1), tacopt1) ((e2, ta2), tacopt2) eq1 @@ -341,8 +346,8 @@ let rec (term_cmp : FStar_Reflection_Types.term comparator_for) = (term_cmp ta1 ta2)) (opt_dec_cmp t1 t2 term_cmp tacopt1 tacopt2)) (eq_cmp eq1 eq2))) - | (FStar_Reflection_V2_Data.Tv_AscribedC (e1, c1, tacopt1, eq1), - FStar_Reflection_V2_Data.Tv_AscribedC (e2, c2, tacopt2, eq2)) -> + | (FStarC_Reflection_V2_Data.Tv_AscribedC (e1, c1, tacopt1, eq1), + FStarC_Reflection_V2_Data.Tv_AscribedC (e2, c2, tacopt2, eq2)) -> Obj.magic (Obj.repr (op_Amp_Amp_Amp ((e1, c1), tacopt1) ((e2, c2), tacopt2) eq1 @@ -352,30 +357,30 @@ let rec (term_cmp : FStar_Reflection_Types.term comparator_for) = (comp_cmp c1 c2)) (opt_dec_cmp t1 t2 term_cmp tacopt1 tacopt2)) (eq_cmp eq1 eq2))) - | (FStar_Reflection_V2_Data.Tv_Unknown, - FStar_Reflection_V2_Data.Tv_Unknown) -> Obj.magic (Obj.repr Eq) + | (FStarC_Reflection_V2_Data.Tv_Unknown, + FStarC_Reflection_V2_Data.Tv_Unknown) -> Obj.magic (Obj.repr Eq) | uu___ -> Obj.magic (Obj.repr Neq) -and (arg_cmp : FStar_Reflection_V2_Data.argv comparator_for) = +and (arg_cmp : FStarC_Reflection_V2_Data.argv comparator_for) = fun uu___ -> fun uu___1 -> match (uu___, uu___1) with | ((a1, q1), (a2, q2)) -> op_Amp_Amp_Amp a1 a2 q1 q2 (term_cmp a1 a2) (aqual_cmp q1 q2) -and (aqual_cmp : FStar_Reflection_V2_Data.aqualv comparator_for) = +and (aqual_cmp : FStarC_Reflection_V2_Data.aqualv comparator_for) = fun a1 -> fun a2 -> match (a1, a2) with - | (FStar_Reflection_V2_Data.Q_Implicit, - FStar_Reflection_V2_Data.Q_Implicit) -> Eq - | (FStar_Reflection_V2_Data.Q_Explicit, - FStar_Reflection_V2_Data.Q_Explicit) -> Eq - | (FStar_Reflection_V2_Data.Q_Equality, - FStar_Reflection_V2_Data.Q_Equality) -> Eq - | (FStar_Reflection_V2_Data.Q_Meta m1, FStar_Reflection_V2_Data.Q_Meta - m2) -> term_cmp m1 m2 + | (FStarC_Reflection_V2_Data.Q_Implicit, + FStarC_Reflection_V2_Data.Q_Implicit) -> Eq + | (FStarC_Reflection_V2_Data.Q_Explicit, + FStarC_Reflection_V2_Data.Q_Explicit) -> Eq + | (FStarC_Reflection_V2_Data.Q_Equality, + FStarC_Reflection_V2_Data.Q_Equality) -> Eq + | (FStarC_Reflection_V2_Data.Q_Meta m1, + FStarC_Reflection_V2_Data.Q_Meta m2) -> term_cmp m1 m2 | uu___ -> Neq and (match_returns_ascription_cmp : - FStar_Syntax_Syntax.match_returns_ascription comparator_for) = + FStarC_Syntax_Syntax.match_returns_ascription comparator_for) = fun asc1 -> fun asc2 -> let uu___ = asc1 in @@ -392,50 +397,50 @@ and (match_returns_ascription_cmp : (either_dec_cmp asc1 asc2 term_cmp comp_cmp tc1 tc2)) (opt_dec_cmp asc1 asc2 term_cmp tacopt1 tacopt2)) (eq_cmp eq1 eq2))) -and (binder_cmp : FStar_Reflection_Types.binder comparator_for) = +and (binder_cmp : FStarC_Reflection_Types.binder comparator_for) = fun b1 -> fun b2 -> - let bv1 = FStar_Reflection_V2_Builtins.inspect_binder b1 in - let bv2 = FStar_Reflection_V2_Builtins.inspect_binder b2 in + let bv1 = FStarC_Reflection_V2_Builtins.inspect_binder b1 in + let bv2 = FStarC_Reflection_V2_Builtins.inspect_binder b2 in Obj.magic (op_Amp_Amp_Amp - ((bv1.FStar_Reflection_V2_Data.sort2), - (bv1.FStar_Reflection_V2_Data.qual)) - ((bv2.FStar_Reflection_V2_Data.sort2), - (bv2.FStar_Reflection_V2_Data.qual)) - bv1.FStar_Reflection_V2_Data.attrs - bv2.FStar_Reflection_V2_Data.attrs - (op_Amp_Amp_Amp bv1.FStar_Reflection_V2_Data.sort2 - bv2.FStar_Reflection_V2_Data.sort2 - bv1.FStar_Reflection_V2_Data.qual - bv2.FStar_Reflection_V2_Data.qual - (term_cmp bv1.FStar_Reflection_V2_Data.sort2 - bv2.FStar_Reflection_V2_Data.sort2) - (aqual_cmp bv1.FStar_Reflection_V2_Data.qual - bv2.FStar_Reflection_V2_Data.qual)) - (list_dec_cmp b1 b2 term_cmp bv1.FStar_Reflection_V2_Data.attrs - bv2.FStar_Reflection_V2_Data.attrs)) -and (comp_cmp : FStar_Reflection_Types.comp comparator_for) = + ((bv1.FStarC_Reflection_V2_Data.sort2), + (bv1.FStarC_Reflection_V2_Data.qual)) + ((bv2.FStarC_Reflection_V2_Data.sort2), + (bv2.FStarC_Reflection_V2_Data.qual)) + bv1.FStarC_Reflection_V2_Data.attrs + bv2.FStarC_Reflection_V2_Data.attrs + (op_Amp_Amp_Amp bv1.FStarC_Reflection_V2_Data.sort2 + bv2.FStarC_Reflection_V2_Data.sort2 + bv1.FStarC_Reflection_V2_Data.qual + bv2.FStarC_Reflection_V2_Data.qual + (term_cmp bv1.FStarC_Reflection_V2_Data.sort2 + bv2.FStarC_Reflection_V2_Data.sort2) + (aqual_cmp bv1.FStarC_Reflection_V2_Data.qual + bv2.FStarC_Reflection_V2_Data.qual)) + (list_dec_cmp b1 b2 term_cmp bv1.FStarC_Reflection_V2_Data.attrs + bv2.FStarC_Reflection_V2_Data.attrs)) +and (comp_cmp : FStarC_Reflection_Types.comp comparator_for) = fun c1 -> fun c2 -> - let cv1 = FStar_Reflection_V2_Builtins.inspect_comp c1 in - let cv2 = FStar_Reflection_V2_Builtins.inspect_comp c2 in + let cv1 = FStarC_Reflection_V2_Builtins.inspect_comp c1 in + let cv2 = FStarC_Reflection_V2_Builtins.inspect_comp c2 in match (cv1, cv2) with - | (FStar_Reflection_V2_Data.C_Total t1, - FStar_Reflection_V2_Data.C_Total t2) -> + | (FStarC_Reflection_V2_Data.C_Total t1, + FStarC_Reflection_V2_Data.C_Total t2) -> Obj.magic (Obj.repr (term_cmp t1 t2)) - | (FStar_Reflection_V2_Data.C_GTotal t1, - FStar_Reflection_V2_Data.C_GTotal t2) -> + | (FStarC_Reflection_V2_Data.C_GTotal t1, + FStarC_Reflection_V2_Data.C_GTotal t2) -> Obj.magic (Obj.repr (term_cmp t1 t2)) - | (FStar_Reflection_V2_Data.C_Lemma (pre1, post1, pat1), - FStar_Reflection_V2_Data.C_Lemma (pre2, post2, pat2)) -> + | (FStarC_Reflection_V2_Data.C_Lemma (pre1, post1, pat1), + FStarC_Reflection_V2_Data.C_Lemma (pre2, post2, pat2)) -> Obj.magic (Obj.repr (op_Amp_Amp_Amp (pre1, post1) (pre2, post2) pat1 pat2 (op_Amp_Amp_Amp pre1 pre2 post1 post2 (term_cmp pre1 pre2) (term_cmp post1 post2)) (term_cmp pat1 pat2))) - | (FStar_Reflection_V2_Data.C_Eff (us1, ef1, t1, args1, dec1), - FStar_Reflection_V2_Data.C_Eff (us2, ef2, t2, args2, dec2)) -> + | (FStarC_Reflection_V2_Data.C_Eff (us1, ef1, t1, args1, dec1), + FStarC_Reflection_V2_Data.C_Eff (us2, ef2, t2, args2, dec2)) -> Obj.magic (Obj.repr (op_Amp_Amp_Amp (((us1, ef1), t1), args1) @@ -449,7 +454,7 @@ and (comp_cmp : FStar_Reflection_Types.comp comparator_for) = (list_dec_cmp c1 c2 arg_cmp args1 args2)) (list_dec_cmp c1 c2 term_cmp dec1 dec2))) | uu___ -> Obj.magic (Obj.repr Neq) -and (br_cmp : FStar_Reflection_V2_Data.branch comparator_for) = +and (br_cmp : FStarC_Reflection_V2_Data.branch comparator_for) = fun br1 -> fun br2 -> op_Amp_Amp_Amp (FStar_Pervasives_Native.fst br1) @@ -459,21 +464,21 @@ and (br_cmp : FStar_Reflection_V2_Data.branch comparator_for) = (FStar_Pervasives_Native.fst br2)) (term_cmp (FStar_Pervasives_Native.snd br1) (FStar_Pervasives_Native.snd br2)) -and (pat_cmp : FStar_Reflection_V2_Data.pattern comparator_for) = +and (pat_cmp : FStarC_Reflection_V2_Data.pattern comparator_for) = fun p1 -> fun p2 -> match (p1, p2) with - | (FStar_Reflection_V2_Data.Pat_Var (x1, s1), - FStar_Reflection_V2_Data.Pat_Var (x2, s2)) -> + | (FStarC_Reflection_V2_Data.Pat_Var (x1, s1), + FStarC_Reflection_V2_Data.Pat_Var (x2, s2)) -> Obj.magic (Obj.repr Eq) - | (FStar_Reflection_V2_Data.Pat_Constant x1, - FStar_Reflection_V2_Data.Pat_Constant x2) -> + | (FStarC_Reflection_V2_Data.Pat_Constant x1, + FStarC_Reflection_V2_Data.Pat_Constant x2) -> Obj.magic (Obj.repr (const_cmp x1 x2)) - | (FStar_Reflection_V2_Data.Pat_Dot_Term x1, - FStar_Reflection_V2_Data.Pat_Dot_Term x2) -> + | (FStarC_Reflection_V2_Data.Pat_Dot_Term x1, + FStarC_Reflection_V2_Data.Pat_Dot_Term x2) -> Obj.magic (Obj.repr (opt_dec_cmp p1 p2 term_cmp x1 x2)) - | (FStar_Reflection_V2_Data.Pat_Cons (head1, us1, subpats1), - FStar_Reflection_V2_Data.Pat_Cons (head2, us2, subpats2)) -> + | (FStarC_Reflection_V2_Data.Pat_Cons (head1, us1, subpats1), + FStarC_Reflection_V2_Data.Pat_Cons (head2, us2, subpats2)) -> Obj.magic (Obj.repr (op_Amp_Amp_Amp (head1, us1) (head2, us2) subpats1 subpats2 @@ -482,7 +487,7 @@ and (pat_cmp : FStar_Reflection_V2_Data.pattern comparator_for) = (list_dec_cmp p1 p2 pat_arg_cmp subpats1 subpats2))) | uu___ -> Obj.magic (Obj.repr Neq) and (pat_arg_cmp : - (FStar_Reflection_V2_Data.pattern * Prims.bool) comparator_for) = + (FStarC_Reflection_V2_Data.pattern * Prims.bool) comparator_for) = fun uu___ -> fun uu___1 -> match (uu___, uu___1) with @@ -491,125 +496,125 @@ and (pat_arg_cmp : type 'r defined = unit type ('uuuuu, 'uuuuu1, 'f, 'l1, 'l2) def2 = unit let (term_eq : - FStar_Reflection_Types.term -> FStar_Reflection_Types.term -> Prims.bool) = - fun t1 -> fun t2 -> uu___is_Eq (term_cmp t1 t2) + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term -> Prims.bool) + = fun t1 -> fun t2 -> uu___is_Eq (term_cmp t1 t2) let _ = - FStar_Tactics_Native.register_plugin "FStar.Reflection.TermEq.term_eq" + FStarC_Tactics_Native.register_plugin "FStar.Reflection.TermEq.term_eq" (Prims.of_int (2)) (fun _psc -> fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Reflection.TermEq.term_eq" (fun _ -> - (FStar_Syntax_Embeddings.arrow_as_prim_step_2 - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_term - FStar_Syntax_Embeddings.e_bool term_eq - (FStar_Ident.lid_of_str + (FStarC_Syntax_Embeddings.arrow_as_prim_step_2 + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Syntax_Embeddings.e_bool term_eq + (FStarC_Ident.lid_of_str "FStar.Reflection.TermEq.term_eq") cb us) args)) (fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Reflection.TermEq.term_eq" (fun _ -> - (FStar_TypeChecker_NBETerm.arrow_as_prim_step_2 - FStar_Reflection_V2_NBEEmbeddings.e_term - FStar_Reflection_V2_NBEEmbeddings.e_term - FStar_TypeChecker_NBETerm.e_bool term_eq - (FStar_Ident.lid_of_str "FStar.Reflection.TermEq.term_eq") + (FStarC_TypeChecker_NBETerm.arrow_as_prim_step_2 + FStarC_Reflection_V2_NBEEmbeddings.e_term + FStarC_Reflection_V2_NBEEmbeddings.e_term + FStarC_TypeChecker_NBETerm.e_bool term_eq + (FStarC_Ident.lid_of_str "FStar.Reflection.TermEq.term_eq") cb us) args)) let (term_eq_dec : faithful_term -> faithful_term -> Prims.bool) = fun t1 -> fun t2 -> uu___is_Eq (term_cmp t1 t2) let _ = - FStar_Tactics_Native.register_plugin "FStar.Reflection.TermEq.term_eq_dec" + FStarC_Tactics_Native.register_plugin "FStar.Reflection.TermEq.term_eq_dec" (Prims.of_int (2)) (fun _psc -> fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Reflection.TermEq.term_eq_dec" (fun _ -> - (FStar_Syntax_Embeddings.arrow_as_prim_step_2 - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_term - FStar_Syntax_Embeddings.e_bool term_eq_dec - (FStar_Ident.lid_of_str + (FStarC_Syntax_Embeddings.arrow_as_prim_step_2 + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Syntax_Embeddings.e_bool term_eq_dec + (FStarC_Ident.lid_of_str "FStar.Reflection.TermEq.term_eq_dec") cb us) args)) (fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Reflection.TermEq.term_eq_dec" (fun _ -> - (FStar_TypeChecker_NBETerm.arrow_as_prim_step_2 - FStar_Reflection_V2_NBEEmbeddings.e_term - FStar_Reflection_V2_NBEEmbeddings.e_term - FStar_TypeChecker_NBETerm.e_bool term_eq_dec - (FStar_Ident.lid_of_str + (FStarC_TypeChecker_NBETerm.arrow_as_prim_step_2 + FStarC_Reflection_V2_NBEEmbeddings.e_term + FStarC_Reflection_V2_NBEEmbeddings.e_term + FStarC_TypeChecker_NBETerm.e_bool term_eq_dec + (FStarC_Ident.lid_of_str "FStar.Reflection.TermEq.term_eq_dec") cb us) args)) let (univ_eq : - FStar_Reflection_Types.universe -> - FStar_Reflection_Types.universe -> Prims.bool) + FStarC_Reflection_Types.universe -> + FStarC_Reflection_Types.universe -> Prims.bool) = fun u1 -> fun u2 -> uu___is_Eq (univ_cmp u1 u2) let _ = - FStar_Tactics_Native.register_plugin "FStar.Reflection.TermEq.univ_eq" + FStarC_Tactics_Native.register_plugin "FStar.Reflection.TermEq.univ_eq" (Prims.of_int (2)) (fun _psc -> fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Reflection.TermEq.univ_eq" (fun _ -> - (FStar_Syntax_Embeddings.arrow_as_prim_step_2 - FStar_Reflection_V2_Embeddings.e_universe - FStar_Reflection_V2_Embeddings.e_universe - FStar_Syntax_Embeddings.e_bool univ_eq - (FStar_Ident.lid_of_str + (FStarC_Syntax_Embeddings.arrow_as_prim_step_2 + FStarC_Reflection_V2_Embeddings.e_universe + FStarC_Reflection_V2_Embeddings.e_universe + FStarC_Syntax_Embeddings.e_bool univ_eq + (FStarC_Ident.lid_of_str "FStar.Reflection.TermEq.univ_eq") cb us) args)) (fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Reflection.TermEq.univ_eq" (fun _ -> - (FStar_TypeChecker_NBETerm.arrow_as_prim_step_2 - FStar_Reflection_V2_NBEEmbeddings.e_universe - FStar_Reflection_V2_NBEEmbeddings.e_universe - FStar_TypeChecker_NBETerm.e_bool univ_eq - (FStar_Ident.lid_of_str "FStar.Reflection.TermEq.univ_eq") + (FStarC_TypeChecker_NBETerm.arrow_as_prim_step_2 + FStarC_Reflection_V2_NBEEmbeddings.e_universe + FStarC_Reflection_V2_NBEEmbeddings.e_universe + FStarC_TypeChecker_NBETerm.e_bool univ_eq + (FStarC_Ident.lid_of_str "FStar.Reflection.TermEq.univ_eq") cb us) args)) let (univ_eq_dec : faithful_universe -> faithful_universe -> Prims.bool) = fun u1 -> fun u2 -> uu___is_Eq (univ_cmp u1 u2) let _ = - FStar_Tactics_Native.register_plugin "FStar.Reflection.TermEq.univ_eq_dec" + FStarC_Tactics_Native.register_plugin "FStar.Reflection.TermEq.univ_eq_dec" (Prims.of_int (2)) (fun _psc -> fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Reflection.TermEq.univ_eq_dec" (fun _ -> - (FStar_Syntax_Embeddings.arrow_as_prim_step_2 - FStar_Reflection_V2_Embeddings.e_universe - FStar_Reflection_V2_Embeddings.e_universe - FStar_Syntax_Embeddings.e_bool univ_eq_dec - (FStar_Ident.lid_of_str + (FStarC_Syntax_Embeddings.arrow_as_prim_step_2 + FStarC_Reflection_V2_Embeddings.e_universe + FStarC_Reflection_V2_Embeddings.e_universe + FStarC_Syntax_Embeddings.e_bool univ_eq_dec + (FStarC_Ident.lid_of_str "FStar.Reflection.TermEq.univ_eq_dec") cb us) args)) (fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Reflection.TermEq.univ_eq_dec" (fun _ -> - (FStar_TypeChecker_NBETerm.arrow_as_prim_step_2 - FStar_Reflection_V2_NBEEmbeddings.e_universe - FStar_Reflection_V2_NBEEmbeddings.e_universe - FStar_TypeChecker_NBETerm.e_bool univ_eq_dec - (FStar_Ident.lid_of_str + (FStarC_TypeChecker_NBETerm.arrow_as_prim_step_2 + FStarC_Reflection_V2_NBEEmbeddings.e_universe + FStarC_Reflection_V2_NBEEmbeddings.e_universe + FStarC_TypeChecker_NBETerm.e_bool univ_eq_dec + (FStarC_Ident.lid_of_str "FStar.Reflection.TermEq.univ_eq_dec") cb us) args)) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Reflection_TermEq_Simple.ml b/ocaml/fstar-lib/generated/FStar_Reflection_TermEq_Simple.ml index 25b265fbe43..5336054f1dd 100644 --- a/ocaml/fstar-lib/generated/FStar_Reflection_TermEq_Simple.ml +++ b/ocaml/fstar-lib/generated/FStar_Reflection_TermEq_Simple.ml @@ -1,64 +1,64 @@ open Prims let (term_eq : - FStar_Reflection_Types.term -> FStar_Reflection_Types.term -> Prims.bool) = - FStar_Reflection_TermEq.term_eq + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term -> Prims.bool) + = FStar_Reflection_TermEq.term_eq let _ = - FStar_Tactics_Native.register_plugin + FStarC_Tactics_Native.register_plugin "FStar.Reflection.TermEq.Simple.term_eq" (Prims.of_int (2)) (fun _psc -> fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Reflection.TermEq.Simple.term_eq" (fun _ -> - (FStar_Syntax_Embeddings.arrow_as_prim_step_2 - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_term - FStar_Syntax_Embeddings.e_bool term_eq - (FStar_Ident.lid_of_str + (FStarC_Syntax_Embeddings.arrow_as_prim_step_2 + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Syntax_Embeddings.e_bool term_eq + (FStarC_Ident.lid_of_str "FStar.Reflection.TermEq.Simple.term_eq") cb us) args)) (fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Reflection.TermEq.Simple.term_eq" (fun _ -> - (FStar_TypeChecker_NBETerm.arrow_as_prim_step_2 - FStar_Reflection_V2_NBEEmbeddings.e_term - FStar_Reflection_V2_NBEEmbeddings.e_term - FStar_TypeChecker_NBETerm.e_bool term_eq - (FStar_Ident.lid_of_str + (FStarC_TypeChecker_NBETerm.arrow_as_prim_step_2 + FStarC_Reflection_V2_NBEEmbeddings.e_term + FStarC_Reflection_V2_NBEEmbeddings.e_term + FStarC_TypeChecker_NBETerm.e_bool term_eq + (FStarC_Ident.lid_of_str "FStar.Reflection.TermEq.Simple.term_eq") cb us) args)) let (univ_eq : - FStar_Reflection_Types.universe -> - FStar_Reflection_Types.universe -> Prims.bool) + FStarC_Reflection_Types.universe -> + FStarC_Reflection_Types.universe -> Prims.bool) = FStar_Reflection_TermEq.univ_eq let _ = - FStar_Tactics_Native.register_plugin + FStarC_Tactics_Native.register_plugin "FStar.Reflection.TermEq.Simple.univ_eq" (Prims.of_int (2)) (fun _psc -> fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Reflection.TermEq.Simple.univ_eq" (fun _ -> - (FStar_Syntax_Embeddings.arrow_as_prim_step_2 - FStar_Reflection_V2_Embeddings.e_universe - FStar_Reflection_V2_Embeddings.e_universe - FStar_Syntax_Embeddings.e_bool univ_eq - (FStar_Ident.lid_of_str + (FStarC_Syntax_Embeddings.arrow_as_prim_step_2 + FStarC_Reflection_V2_Embeddings.e_universe + FStarC_Reflection_V2_Embeddings.e_universe + FStarC_Syntax_Embeddings.e_bool univ_eq + (FStarC_Ident.lid_of_str "FStar.Reflection.TermEq.Simple.univ_eq") cb us) args)) (fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Reflection.TermEq.Simple.univ_eq" (fun _ -> - (FStar_TypeChecker_NBETerm.arrow_as_prim_step_2 - FStar_Reflection_V2_NBEEmbeddings.e_universe - FStar_Reflection_V2_NBEEmbeddings.e_universe - FStar_TypeChecker_NBETerm.e_bool univ_eq - (FStar_Ident.lid_of_str + (FStarC_TypeChecker_NBETerm.arrow_as_prim_step_2 + FStarC_Reflection_V2_NBEEmbeddings.e_universe + FStarC_Reflection_V2_NBEEmbeddings.e_universe + FStarC_TypeChecker_NBETerm.e_bool univ_eq + (FStarC_Ident.lid_of_str "FStar.Reflection.TermEq.Simple.univ_eq") cb us) args)) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Reflection_Typing.ml b/ocaml/fstar-lib/generated/FStar_Reflection_Typing.ml index a04cc89a0ab..ebc953b6738 100644 --- a/ocaml/fstar-lib/generated/FStar_Reflection_Typing.ml +++ b/ocaml/fstar-lib/generated/FStar_Reflection_Typing.ml @@ -10,115 +10,117 @@ let rec map_dec : 'a 'b . 'a Prims.list -> ('a -> 'b) -> 'b Prims.list = fun f -> match l with | [] -> [] | x::xs -> (f x) :: (map_dec xs f) type ('a, 'b, 'f, 'xs, 'ys) zip2prop = Obj.t let (lookup_bvar : - FStar_Reflection_Types.env -> - Prims.int -> FStar_Reflection_Types.term FStar_Pervasives_Native.option) + FStarC_Reflection_Types.env -> + Prims.int -> FStarC_Reflection_Types.term FStar_Pervasives_Native.option) = fun e -> fun x -> Prims.magic () let (lookup_fvar_uinst : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.fv -> - FStar_Reflection_Types.universe Prims.list -> - FStar_Reflection_Types.term FStar_Pervasives_Native.option) + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.fv -> + FStarC_Reflection_Types.universe Prims.list -> + FStarC_Reflection_Types.term FStar_Pervasives_Native.option) = fun e -> fun x -> fun us -> Prims.magic () let (lookup_fvar : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.fv -> - FStar_Reflection_Types.term FStar_Pervasives_Native.option) + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.fv -> + FStarC_Reflection_Types.term FStar_Pervasives_Native.option) = fun e -> fun x -> lookup_fvar_uinst e x [] type pp_name_t = (Prims.string, unit) FStar_Sealed_Inhabited.sealed let (pp_name_default : pp_name_t) = FStar_Sealed_Inhabited.seal "x" "x" let (seal_pp_name : Prims.string -> pp_name_t) = fun x -> FStar_Sealed_Inhabited.seal "x" x -let (tun : FStar_Reflection_Types.term) = - FStar_Reflection_V2_Builtins.pack_ln FStar_Reflection_V2_Data.Tv_Unknown +let (tun : FStarC_Reflection_Types.term) = + FStarC_Reflection_V2_Builtins.pack_ln FStarC_Reflection_V2_Data.Tv_Unknown type sort_t = - (FStar_Reflection_Types.term, unit) FStar_Sealed_Inhabited.sealed + (FStarC_Reflection_Types.term, unit) FStar_Sealed_Inhabited.sealed let (sort_default : sort_t) = FStar_Sealed_Inhabited.seal tun tun -let (seal_sort : FStar_Reflection_Types.term -> sort_t) = +let (seal_sort : FStarC_Reflection_Types.term -> sort_t) = fun x -> FStar_Sealed_Inhabited.seal tun x let (mk_binder : pp_name_t -> - FStar_Reflection_Types.term -> - FStar_Reflection_V2_Data.aqualv -> FStar_Reflection_Types.binder) + FStarC_Reflection_Types.term -> + FStarC_Reflection_V2_Data.aqualv -> FStarC_Reflection_Types.binder) = fun pp_name -> fun ty -> fun q -> - FStar_Reflection_V2_Builtins.pack_binder + FStarC_Reflection_V2_Builtins.pack_binder { - FStar_Reflection_V2_Data.sort2 = ty; - FStar_Reflection_V2_Data.qual = q; - FStar_Reflection_V2_Data.attrs = []; - FStar_Reflection_V2_Data.ppname2 = pp_name + FStarC_Reflection_V2_Data.sort2 = ty; + FStarC_Reflection_V2_Data.qual = q; + FStarC_Reflection_V2_Data.attrs = []; + FStarC_Reflection_V2_Data.ppname2 = pp_name } let (mk_simple_binder : pp_name_t -> - FStar_Reflection_Types.term -> FStar_Reflection_V2_Data.simple_binder) + FStarC_Reflection_Types.term -> FStarC_Reflection_V2_Data.simple_binder) = fun pp_name -> fun ty -> - FStar_Reflection_V2_Builtins.pack_binder + FStarC_Reflection_V2_Builtins.pack_binder { - FStar_Reflection_V2_Data.sort2 = ty; - FStar_Reflection_V2_Data.qual = FStar_Reflection_V2_Data.Q_Explicit; - FStar_Reflection_V2_Data.attrs = []; - FStar_Reflection_V2_Data.ppname2 = pp_name + FStarC_Reflection_V2_Data.sort2 = ty; + FStarC_Reflection_V2_Data.qual = + FStarC_Reflection_V2_Data.Q_Explicit; + FStarC_Reflection_V2_Data.attrs = []; + FStarC_Reflection_V2_Data.ppname2 = pp_name } let (extend_env : - FStar_Reflection_Types.env -> - FStar_Reflection_V2_Data.var -> - FStar_Reflection_Types.term -> FStar_Reflection_Types.env) + FStarC_Reflection_Types.env -> + FStarC_Reflection_V2_Data.var -> + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.env) = fun e -> fun x -> fun ty -> FStar_Reflection_V2_Derived.push_binding e { - FStar_Reflection_V2_Data.uniq1 = x; - FStar_Reflection_V2_Data.sort3 = ty; - FStar_Reflection_V2_Data.ppname3 = (seal_pp_name "x") + FStarC_Reflection_V2_Data.uniq1 = x; + FStarC_Reflection_V2_Data.sort3 = ty; + FStarC_Reflection_V2_Data.ppname3 = (seal_pp_name "x") } -let (bv_index : FStar_Reflection_Types.bv -> FStar_Reflection_V2_Data.var) = +let (bv_index : FStarC_Reflection_Types.bv -> FStarC_Reflection_V2_Data.var) + = fun x -> - (FStar_Reflection_V2_Builtins.inspect_bv x).FStar_Reflection_V2_Data.index + (FStarC_Reflection_V2_Builtins.inspect_bv x).FStarC_Reflection_V2_Data.index let (namedv_uniq : - FStar_Reflection_Types.namedv -> FStar_Reflection_V2_Data.var) = + FStarC_Reflection_Types.namedv -> FStarC_Reflection_V2_Data.var) = fun x -> - (FStar_Reflection_V2_Builtins.inspect_namedv x).FStar_Reflection_V2_Data.uniq + (FStarC_Reflection_V2_Builtins.inspect_namedv x).FStarC_Reflection_V2_Data.uniq let (binder_sort : - FStar_Reflection_Types.binder -> FStar_Reflection_Types.typ) = + FStarC_Reflection_Types.binder -> FStarC_Reflection_Types.typ) = fun b -> - (FStar_Reflection_V2_Builtins.inspect_binder b).FStar_Reflection_V2_Data.sort2 + (FStarC_Reflection_V2_Builtins.inspect_binder b).FStarC_Reflection_V2_Data.sort2 let (binder_qual : - FStar_Reflection_Types.binder -> FStar_Reflection_V2_Data.aqualv) = + FStarC_Reflection_Types.binder -> FStarC_Reflection_V2_Data.aqualv) = fun b -> - let uu___ = FStar_Reflection_V2_Builtins.inspect_binder b in + let uu___ = FStarC_Reflection_V2_Builtins.inspect_binder b in match uu___ with - | { FStar_Reflection_V2_Data.sort2 = uu___1; - FStar_Reflection_V2_Data.qual = q; - FStar_Reflection_V2_Data.attrs = uu___2; - FStar_Reflection_V2_Data.ppname2 = uu___3;_} -> q + | { FStarC_Reflection_V2_Data.sort2 = uu___1; + FStarC_Reflection_V2_Data.qual = q; + FStarC_Reflection_V2_Data.attrs = uu___2; + FStarC_Reflection_V2_Data.ppname2 = uu___3;_} -> q type subst_elt = - | DT of Prims.nat * FStar_Reflection_Types.term - | NT of FStar_Reflection_V2_Data.var * FStar_Reflection_Types.term - | ND of FStar_Reflection_V2_Data.var * Prims.nat + | DT of Prims.nat * FStarC_Reflection_Types.term + | NT of FStarC_Reflection_V2_Data.var * FStarC_Reflection_Types.term + | ND of FStarC_Reflection_V2_Data.var * Prims.nat let (uu___is_DT : subst_elt -> Prims.bool) = fun projectee -> match projectee with | DT (_0, _1) -> true | uu___ -> false let (__proj__DT__item___0 : subst_elt -> Prims.nat) = fun projectee -> match projectee with | DT (_0, _1) -> _0 -let (__proj__DT__item___1 : subst_elt -> FStar_Reflection_Types.term) = +let (__proj__DT__item___1 : subst_elt -> FStarC_Reflection_Types.term) = fun projectee -> match projectee with | DT (_0, _1) -> _1 let (uu___is_NT : subst_elt -> Prims.bool) = fun projectee -> match projectee with | NT (_0, _1) -> true | uu___ -> false -let (__proj__NT__item___0 : subst_elt -> FStar_Reflection_V2_Data.var) = +let (__proj__NT__item___0 : subst_elt -> FStarC_Reflection_V2_Data.var) = fun projectee -> match projectee with | NT (_0, _1) -> _0 -let (__proj__NT__item___1 : subst_elt -> FStar_Reflection_Types.term) = +let (__proj__NT__item___1 : subst_elt -> FStarC_Reflection_Types.term) = fun projectee -> match projectee with | NT (_0, _1) -> _1 let (uu___is_ND : subst_elt -> Prims.bool) = fun projectee -> match projectee with | ND (_0, _1) -> true | uu___ -> false -let (__proj__ND__item___0 : subst_elt -> FStar_Reflection_V2_Data.var) = +let (__proj__ND__item___0 : subst_elt -> FStarC_Reflection_V2_Data.var) = fun projectee -> match projectee with | ND (_0, _1) -> _0 let (__proj__ND__item___1 : subst_elt -> Prims.nat) = fun projectee -> match projectee with | ND (_0, _1) -> _1 @@ -136,17 +138,17 @@ let (shift_subst_n : let (shift_subst : subst_elt Prims.list -> subst_elt Prims.list) = shift_subst_n Prims.int_one let (maybe_uniq_of_term : - FStar_Reflection_Types.term -> - FStar_Reflection_V2_Data.var FStar_Pervasives_Native.option) + FStarC_Reflection_Types.term -> + FStarC_Reflection_V2_Data.var FStar_Pervasives_Native.option) = fun x -> - match FStar_Reflection_V2_Builtins.inspect_ln x with - | FStar_Reflection_V2_Data.Tv_Var namedv -> + match FStarC_Reflection_V2_Builtins.inspect_ln x with + | FStarC_Reflection_V2_Data.Tv_Var namedv -> FStar_Pervasives_Native.Some (namedv_uniq namedv) | uu___ -> FStar_Pervasives_Native.None let rec (find_matching_subst_elt_bv : subst -> - FStar_Reflection_Types.bv -> subst_elt FStar_Pervasives_Native.option) + FStarC_Reflection_Types.bv -> subst_elt FStar_Pervasives_Native.option) = fun s -> fun bv -> @@ -158,7 +160,7 @@ let rec (find_matching_subst_elt_bv : else find_matching_subst_elt_bv ss bv | uu___::ss -> find_matching_subst_elt_bv ss bv let (subst_db : - FStar_Reflection_Types.bv -> subst -> FStar_Reflection_Types.term) = + FStarC_Reflection_Types.bv -> subst -> FStarC_Reflection_Types.term) = fun bv -> fun s -> match find_matching_subst_elt_bv s bv with @@ -167,22 +169,23 @@ let (subst_db : | FStar_Pervasives_Native.None -> t | FStar_Pervasives_Native.Some k -> let v = - FStar_Reflection_V2_Builtins.pack_namedv + FStarC_Reflection_V2_Builtins.pack_namedv { - FStar_Reflection_V2_Data.uniq = k; - FStar_Reflection_V2_Data.sort = - ((FStar_Reflection_V2_Builtins.inspect_bv bv).FStar_Reflection_V2_Data.sort1); - FStar_Reflection_V2_Data.ppname = - ((FStar_Reflection_V2_Builtins.inspect_bv bv).FStar_Reflection_V2_Data.ppname1) + FStarC_Reflection_V2_Data.uniq = k; + FStarC_Reflection_V2_Data.sort = + ((FStarC_Reflection_V2_Builtins.inspect_bv bv).FStarC_Reflection_V2_Data.sort1); + FStarC_Reflection_V2_Data.ppname = + ((FStarC_Reflection_V2_Builtins.inspect_bv bv).FStarC_Reflection_V2_Data.ppname1) } in - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Var v)) + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Var v)) | uu___ -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_BVar bv) + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_BVar bv) let rec (find_matching_subst_elt_var : subst -> - FStar_Reflection_Types.namedv -> subst_elt FStar_Pervasives_Native.option) + FStarC_Reflection_Types.namedv -> + subst_elt FStar_Pervasives_Native.option) = fun s -> fun v -> @@ -198,7 +201,7 @@ let rec (find_matching_subst_elt_var : else find_matching_subst_elt_var rest v | uu___::rest -> find_matching_subst_elt_var rest v let (subst_var : - FStar_Reflection_Types.namedv -> subst -> FStar_Reflection_Types.term) = + FStarC_Reflection_Types.namedv -> subst -> FStarC_Reflection_Types.term) = fun v -> fun s -> match find_matching_subst_elt_var s v with @@ -206,222 +209,225 @@ let (subst_var : (match maybe_uniq_of_term t with | FStar_Pervasives_Native.None -> t | FStar_Pervasives_Native.Some k -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Var - (FStar_Reflection_V2_Builtins.pack_namedv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Var + (FStarC_Reflection_V2_Builtins.pack_namedv (let uu___1 = - FStar_Reflection_V2_Builtins.inspect_namedv v in + FStarC_Reflection_V2_Builtins.inspect_namedv v in { - FStar_Reflection_V2_Data.uniq = k; - FStar_Reflection_V2_Data.sort = - (uu___1.FStar_Reflection_V2_Data.sort); - FStar_Reflection_V2_Data.ppname = - (uu___1.FStar_Reflection_V2_Data.ppname) + FStarC_Reflection_V2_Data.uniq = k; + FStarC_Reflection_V2_Data.sort = + (uu___1.FStarC_Reflection_V2_Data.sort); + FStarC_Reflection_V2_Data.ppname = + (uu___1.FStarC_Reflection_V2_Data.ppname) })))) | FStar_Pervasives_Native.Some (ND (uu___, i)) -> let bv = - FStar_Reflection_V2_Builtins.pack_bv + FStarC_Reflection_V2_Builtins.pack_bv { - FStar_Reflection_V2_Data.index = i; - FStar_Reflection_V2_Data.sort1 = - ((FStar_Reflection_V2_Builtins.inspect_namedv v).FStar_Reflection_V2_Data.sort); - FStar_Reflection_V2_Data.ppname1 = - ((FStar_Reflection_V2_Builtins.inspect_namedv v).FStar_Reflection_V2_Data.ppname) + FStarC_Reflection_V2_Data.index = i; + FStarC_Reflection_V2_Data.sort1 = + ((FStarC_Reflection_V2_Builtins.inspect_namedv v).FStarC_Reflection_V2_Data.sort); + FStarC_Reflection_V2_Data.ppname1 = + ((FStarC_Reflection_V2_Builtins.inspect_namedv v).FStarC_Reflection_V2_Data.ppname) } in - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_BVar bv) + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_BVar bv) | uu___ -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Var v) -let (make_bv : Prims.nat -> FStar_Reflection_V2_Data.bv_view) = + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Var v) +let (make_bv : Prims.nat -> FStarC_Reflection_V2_Data.bv_view) = fun n -> { - FStar_Reflection_V2_Data.index = n; - FStar_Reflection_V2_Data.sort1 = sort_default; - FStar_Reflection_V2_Data.ppname1 = pp_name_default + FStarC_Reflection_V2_Data.index = n; + FStarC_Reflection_V2_Data.sort1 = sort_default; + FStarC_Reflection_V2_Data.ppname1 = pp_name_default } let (make_bv_with_name : - pp_name_t -> Prims.nat -> FStar_Reflection_V2_Data.bv_view) = + pp_name_t -> Prims.nat -> FStarC_Reflection_V2_Data.bv_view) = fun s -> fun n -> { - FStar_Reflection_V2_Data.index = n; - FStar_Reflection_V2_Data.sort1 = sort_default; - FStar_Reflection_V2_Data.ppname1 = s + FStarC_Reflection_V2_Data.index = n; + FStarC_Reflection_V2_Data.sort1 = sort_default; + FStarC_Reflection_V2_Data.ppname1 = s } -let (var_as_bv : Prims.nat -> FStar_Reflection_Types.bv) = - fun v -> FStar_Reflection_V2_Builtins.pack_bv (make_bv v) -let (make_namedv : Prims.nat -> FStar_Reflection_V2_Data.namedv_view) = +let (var_as_bv : Prims.nat -> FStarC_Reflection_Types.bv) = + fun v -> FStarC_Reflection_V2_Builtins.pack_bv (make_bv v) +let (make_namedv : Prims.nat -> FStarC_Reflection_V2_Data.namedv_view) = fun n -> { - FStar_Reflection_V2_Data.uniq = n; - FStar_Reflection_V2_Data.sort = sort_default; - FStar_Reflection_V2_Data.ppname = pp_name_default + FStarC_Reflection_V2_Data.uniq = n; + FStarC_Reflection_V2_Data.sort = sort_default; + FStarC_Reflection_V2_Data.ppname = pp_name_default } let (make_namedv_with_name : - pp_name_t -> Prims.nat -> FStar_Reflection_V2_Data.namedv_view) = + pp_name_t -> Prims.nat -> FStarC_Reflection_V2_Data.namedv_view) = fun s -> fun n -> { - FStar_Reflection_V2_Data.uniq = n; - FStar_Reflection_V2_Data.sort = sort_default; - FStar_Reflection_V2_Data.ppname = s + FStarC_Reflection_V2_Data.uniq = n; + FStarC_Reflection_V2_Data.sort = sort_default; + FStarC_Reflection_V2_Data.ppname = s } -let (var_as_namedv : Prims.nat -> FStar_Reflection_Types.namedv) = +let (var_as_namedv : Prims.nat -> FStarC_Reflection_Types.namedv) = fun v -> - FStar_Reflection_V2_Builtins.pack_namedv + FStarC_Reflection_V2_Builtins.pack_namedv { - FStar_Reflection_V2_Data.uniq = v; - FStar_Reflection_V2_Data.sort = sort_default; - FStar_Reflection_V2_Data.ppname = pp_name_default + FStarC_Reflection_V2_Data.uniq = v; + FStarC_Reflection_V2_Data.sort = sort_default; + FStarC_Reflection_V2_Data.ppname = pp_name_default } let (var_as_term : - FStar_Reflection_V2_Data.var -> FStar_Reflection_Types.term) = + FStarC_Reflection_V2_Data.var -> FStarC_Reflection_Types.term) = fun v -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Var (var_as_namedv v)) + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Var (var_as_namedv v)) let (binder_of_t_q : - FStar_Reflection_Types.term -> - FStar_Reflection_V2_Data.aqualv -> FStar_Reflection_Types.binder) + FStarC_Reflection_Types.term -> + FStarC_Reflection_V2_Data.aqualv -> FStarC_Reflection_Types.binder) = fun t -> fun q -> mk_binder pp_name_default t q let (mk_abs : - FStar_Reflection_Types.term -> - FStar_Reflection_V2_Data.aqualv -> - FStar_Reflection_Types.term -> FStar_Reflection_Types.term) + FStarC_Reflection_Types.term -> + FStarC_Reflection_V2_Data.aqualv -> + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term) = fun ty -> fun qual -> fun t -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Abs ((binder_of_t_q ty qual), t)) -let (mk_total : FStar_Reflection_Types.typ -> FStar_Reflection_Types.comp) = + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Abs ((binder_of_t_q ty qual), t)) +let (mk_total : FStarC_Reflection_Types.typ -> FStarC_Reflection_Types.comp) + = fun t -> - FStar_Reflection_V2_Builtins.pack_comp - (FStar_Reflection_V2_Data.C_Total t) -let (mk_ghost : FStar_Reflection_Types.typ -> FStar_Reflection_Types.comp) = + FStarC_Reflection_V2_Builtins.pack_comp + (FStarC_Reflection_V2_Data.C_Total t) +let (mk_ghost : FStarC_Reflection_Types.typ -> FStarC_Reflection_Types.comp) + = fun t -> - FStar_Reflection_V2_Builtins.pack_comp - (FStar_Reflection_V2_Data.C_GTotal t) + FStarC_Reflection_V2_Builtins.pack_comp + (FStarC_Reflection_V2_Data.C_GTotal t) let (mk_arrow : - FStar_Reflection_Types.term -> - FStar_Reflection_V2_Data.aqualv -> - FStar_Reflection_Types.typ -> FStar_Reflection_Types.term) + FStarC_Reflection_Types.term -> + FStarC_Reflection_V2_Data.aqualv -> + FStarC_Reflection_Types.typ -> FStarC_Reflection_Types.term) = fun ty -> fun qual -> fun t -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Arrow + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Arrow ((binder_of_t_q ty qual), (mk_total t))) let (mk_ghost_arrow : - FStar_Reflection_Types.term -> - FStar_Reflection_V2_Data.aqualv -> - FStar_Reflection_Types.typ -> FStar_Reflection_Types.term) + FStarC_Reflection_Types.term -> + FStarC_Reflection_V2_Data.aqualv -> + FStarC_Reflection_Types.typ -> FStarC_Reflection_Types.term) = fun ty -> fun qual -> fun t -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Arrow + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Arrow ((binder_of_t_q ty qual), (mk_ghost t))) -let (bound_var : Prims.nat -> FStar_Reflection_Types.term) = +let (bound_var : Prims.nat -> FStarC_Reflection_Types.term) = fun i -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_BVar - (FStar_Reflection_V2_Builtins.pack_bv (make_bv i))) + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_BVar + (FStarC_Reflection_V2_Builtins.pack_bv (make_bv i))) let (mk_let : pp_name_t -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> FStar_Reflection_Types.term) + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term) = fun ppname -> fun e1 -> fun t1 -> fun e2 -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Let + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Let (false, [], (mk_simple_binder ppname t1), e1, e2)) let (open_with_var_elt : - FStar_Reflection_V2_Data.var -> Prims.nat -> subst_elt) = + FStarC_Reflection_V2_Data.var -> Prims.nat -> subst_elt) = fun x -> fun i -> DT (i, - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Var (var_as_namedv x)))) -let (open_with_var : FStar_Reflection_V2_Data.var -> Prims.nat -> subst) = + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Var (var_as_namedv x)))) +let (open_with_var : FStarC_Reflection_V2_Data.var -> Prims.nat -> subst) = fun x -> fun i -> [open_with_var_elt x i] let (subst_ctx_uvar_and_subst : - FStar_Reflection_Types.ctx_uvar_and_subst -> - subst -> FStar_Reflection_Types.ctx_uvar_and_subst) + FStarC_Reflection_Types.ctx_uvar_and_subst -> + subst -> FStarC_Reflection_Types.ctx_uvar_and_subst) = fun uu___ -> fun uu___1 -> Prims.magic () let rec (binder_offset_patterns : - (FStar_Reflection_V2_Data.pattern * Prims.bool) Prims.list -> Prims.nat) = + (FStarC_Reflection_V2_Data.pattern * Prims.bool) Prims.list -> Prims.nat) = fun ps -> match ps with | [] -> Prims.int_zero | (p, b)::ps1 -> let n = binder_offset_pattern p in let m = binder_offset_patterns ps1 in n + m -and (binder_offset_pattern : FStar_Reflection_V2_Data.pattern -> Prims.nat) = +and (binder_offset_pattern : FStarC_Reflection_V2_Data.pattern -> Prims.nat) + = fun p -> match p with - | FStar_Reflection_V2_Data.Pat_Constant uu___ -> Prims.int_zero - | FStar_Reflection_V2_Data.Pat_Dot_Term uu___ -> Prims.int_zero - | FStar_Reflection_V2_Data.Pat_Var (uu___, uu___1) -> Prims.int_one - | FStar_Reflection_V2_Data.Pat_Cons (head, univs, subpats) -> + | FStarC_Reflection_V2_Data.Pat_Constant uu___ -> Prims.int_zero + | FStarC_Reflection_V2_Data.Pat_Dot_Term uu___ -> Prims.int_zero + | FStarC_Reflection_V2_Data.Pat_Var (uu___, uu___1) -> Prims.int_one + | FStarC_Reflection_V2_Data.Pat_Cons (head, univs, subpats) -> binder_offset_patterns subpats let rec (subst_term : - FStar_Reflection_Types.term -> subst -> FStar_Reflection_Types.term) = + FStarC_Reflection_Types.term -> subst -> FStarC_Reflection_Types.term) = fun t -> fun ss -> - match FStar_Reflection_V2_Builtins.inspect_ln t with - | FStar_Reflection_V2_Data.Tv_UInst (uu___, uu___1) -> t - | FStar_Reflection_V2_Data.Tv_FVar uu___ -> t - | FStar_Reflection_V2_Data.Tv_Type uu___ -> t - | FStar_Reflection_V2_Data.Tv_Const uu___ -> t - | FStar_Reflection_V2_Data.Tv_Unsupp -> t - | FStar_Reflection_V2_Data.Tv_Unknown -> t - | FStar_Reflection_V2_Data.Tv_Var x -> subst_var x ss - | FStar_Reflection_V2_Data.Tv_BVar j -> subst_db j ss - | FStar_Reflection_V2_Data.Tv_App (hd, argv) -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App + match FStarC_Reflection_V2_Builtins.inspect_ln t with + | FStarC_Reflection_V2_Data.Tv_UInst (uu___, uu___1) -> t + | FStarC_Reflection_V2_Data.Tv_FVar uu___ -> t + | FStarC_Reflection_V2_Data.Tv_Type uu___ -> t + | FStarC_Reflection_V2_Data.Tv_Const uu___ -> t + | FStarC_Reflection_V2_Data.Tv_Unsupp -> t + | FStarC_Reflection_V2_Data.Tv_Unknown -> t + | FStarC_Reflection_V2_Data.Tv_Var x -> subst_var x ss + | FStarC_Reflection_V2_Data.Tv_BVar j -> subst_db j ss + | FStarC_Reflection_V2_Data.Tv_App (hd, argv) -> + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App ((subst_term hd ss), ((subst_term (FStar_Pervasives_Native.fst argv) ss), (FStar_Pervasives_Native.snd argv)))) - | FStar_Reflection_V2_Data.Tv_Abs (b, body) -> + | FStarC_Reflection_V2_Data.Tv_Abs (b, body) -> let b' = subst_binder b ss in - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Abs + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Abs (b', (subst_term body (shift_subst ss)))) - | FStar_Reflection_V2_Data.Tv_Arrow (b, c) -> + | FStarC_Reflection_V2_Data.Tv_Arrow (b, c) -> let b' = subst_binder b ss in - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Arrow + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Arrow (b', (subst_comp c (shift_subst ss)))) - | FStar_Reflection_V2_Data.Tv_Refine (b, f) -> + | FStarC_Reflection_V2_Data.Tv_Refine (b, f) -> let b1 = subst_binder b ss in - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Refine + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Refine (b1, (subst_term f (shift_subst ss)))) - | FStar_Reflection_V2_Data.Tv_Uvar (j, c) -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Uvar + | FStarC_Reflection_V2_Data.Tv_Uvar (j, c) -> + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Uvar (j, (subst_ctx_uvar_and_subst c ss))) - | FStar_Reflection_V2_Data.Tv_Let (recf, attrs, b, def, body) -> + | FStarC_Reflection_V2_Data.Tv_Let (recf, attrs, b, def, body) -> let b1 = subst_binder b ss in - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Let + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Let (recf, (subst_terms attrs ss), b1, (if recf then subst_term def (shift_subst ss) else subst_term def ss), (subst_term body (shift_subst ss)))) - | FStar_Reflection_V2_Data.Tv_Match (scr, ret, brs) -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Match + | FStarC_Reflection_V2_Data.Tv_Match (scr, ret, brs) -> + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Match ((subst_term scr ss), (match ret with | FStar_Pervasives_Native.None -> @@ -429,18 +435,18 @@ let rec (subst_term : | FStar_Pervasives_Native.Some m -> FStar_Pervasives_Native.Some (subst_match_returns m ss)), (subst_branches brs ss))) - | FStar_Reflection_V2_Data.Tv_AscribedT (e, t1, tac, b) -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_AscribedT + | FStarC_Reflection_V2_Data.Tv_AscribedT (e, t1, tac, b) -> + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_AscribedT ((subst_term e ss), (subst_term t1 ss), (match tac with | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None | FStar_Pervasives_Native.Some tac1 -> FStar_Pervasives_Native.Some (subst_term tac1 ss)), b)) - | FStar_Reflection_V2_Data.Tv_AscribedC (e, c, tac, b) -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_AscribedC + | FStarC_Reflection_V2_Data.Tv_AscribedC (e, c, tac, b) -> + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_AscribedC ((subst_term e ss), (subst_comp c ss), (match tac with | FStar_Pervasives_Native.None -> @@ -448,45 +454,46 @@ let rec (subst_term : | FStar_Pervasives_Native.Some tac1 -> FStar_Pervasives_Native.Some (subst_term tac1 ss)), b)) and (subst_binder : - FStar_Reflection_Types.binder -> subst -> FStar_Reflection_Types.binder) = + FStarC_Reflection_Types.binder -> subst -> FStarC_Reflection_Types.binder) + = fun b -> fun ss -> - let bndr = FStar_Reflection_V2_Builtins.inspect_binder b in - FStar_Reflection_V2_Builtins.pack_binder + let bndr = FStarC_Reflection_V2_Builtins.inspect_binder b in + FStarC_Reflection_V2_Builtins.pack_binder { - FStar_Reflection_V2_Data.sort2 = - (subst_term bndr.FStar_Reflection_V2_Data.sort2 ss); - FStar_Reflection_V2_Data.qual = - (bndr.FStar_Reflection_V2_Data.qual); - FStar_Reflection_V2_Data.attrs = - (subst_terms bndr.FStar_Reflection_V2_Data.attrs ss); - FStar_Reflection_V2_Data.ppname2 = - (bndr.FStar_Reflection_V2_Data.ppname2) + FStarC_Reflection_V2_Data.sort2 = + (subst_term bndr.FStarC_Reflection_V2_Data.sort2 ss); + FStarC_Reflection_V2_Data.qual = + (bndr.FStarC_Reflection_V2_Data.qual); + FStarC_Reflection_V2_Data.attrs = + (subst_terms bndr.FStarC_Reflection_V2_Data.attrs ss); + FStarC_Reflection_V2_Data.ppname2 = + (bndr.FStarC_Reflection_V2_Data.ppname2) } and (subst_comp : - FStar_Reflection_Types.comp -> subst -> FStar_Reflection_Types.comp) = + FStarC_Reflection_Types.comp -> subst -> FStarC_Reflection_Types.comp) = fun c -> fun ss -> - match FStar_Reflection_V2_Builtins.inspect_comp c with - | FStar_Reflection_V2_Data.C_Total t -> - FStar_Reflection_V2_Builtins.pack_comp - (FStar_Reflection_V2_Data.C_Total (subst_term t ss)) - | FStar_Reflection_V2_Data.C_GTotal t -> - FStar_Reflection_V2_Builtins.pack_comp - (FStar_Reflection_V2_Data.C_GTotal (subst_term t ss)) - | FStar_Reflection_V2_Data.C_Lemma (pre, post, pats) -> - FStar_Reflection_V2_Builtins.pack_comp - (FStar_Reflection_V2_Data.C_Lemma + match FStarC_Reflection_V2_Builtins.inspect_comp c with + | FStarC_Reflection_V2_Data.C_Total t -> + FStarC_Reflection_V2_Builtins.pack_comp + (FStarC_Reflection_V2_Data.C_Total (subst_term t ss)) + | FStarC_Reflection_V2_Data.C_GTotal t -> + FStarC_Reflection_V2_Builtins.pack_comp + (FStarC_Reflection_V2_Data.C_GTotal (subst_term t ss)) + | FStarC_Reflection_V2_Data.C_Lemma (pre, post, pats) -> + FStarC_Reflection_V2_Builtins.pack_comp + (FStarC_Reflection_V2_Data.C_Lemma ((subst_term pre ss), (subst_term post ss), (subst_term pats ss))) - | FStar_Reflection_V2_Data.C_Eff (us, eff_name, res, args, decrs) -> - FStar_Reflection_V2_Builtins.pack_comp - (FStar_Reflection_V2_Data.C_Eff + | FStarC_Reflection_V2_Data.C_Eff (us, eff_name, res, args, decrs) -> + FStarC_Reflection_V2_Builtins.pack_comp + (FStarC_Reflection_V2_Data.C_Eff (us, eff_name, (subst_term res ss), (subst_args args ss), (subst_terms decrs ss))) and (subst_terms : - FStar_Reflection_Types.term Prims.list -> - subst -> FStar_Reflection_Types.term Prims.list) + FStarC_Reflection_Types.term Prims.list -> + subst -> FStarC_Reflection_Types.term Prims.list) = fun ts -> fun ss -> @@ -494,8 +501,8 @@ and (subst_terms : | [] -> [] | t::ts1 -> (subst_term t ss) :: (subst_terms ts1 ss) and (subst_args : - FStar_Reflection_V2_Data.argv Prims.list -> - subst -> FStar_Reflection_V2_Data.argv Prims.list) + FStarC_Reflection_V2_Data.argv Prims.list -> + subst -> FStarC_Reflection_V2_Data.argv Prims.list) = fun ts -> fun ss -> @@ -503,8 +510,8 @@ and (subst_args : | [] -> [] | (t, q)::ts1 -> ((subst_term t ss), q) :: (subst_args ts1 ss) and (subst_patterns : - (FStar_Reflection_V2_Data.pattern * Prims.bool) Prims.list -> - subst -> (FStar_Reflection_V2_Data.pattern * Prims.bool) Prims.list) + (FStarC_Reflection_V2_Data.pattern * Prims.bool) Prims.list -> + subst -> (FStarC_Reflection_V2_Data.pattern * Prims.bool) Prims.list) = fun ps -> fun ss -> @@ -515,26 +522,27 @@ and (subst_patterns : let p1 = subst_pattern p ss in let ps2 = subst_patterns ps1 (shift_subst_n n ss) in (p1, b) :: ps2 and (subst_pattern : - FStar_Reflection_V2_Data.pattern -> - subst -> FStar_Reflection_V2_Data.pattern) + FStarC_Reflection_V2_Data.pattern -> + subst -> FStarC_Reflection_V2_Data.pattern) = fun p -> fun ss -> match p with - | FStar_Reflection_V2_Data.Pat_Constant uu___ -> p - | FStar_Reflection_V2_Data.Pat_Cons (fv, us, pats) -> + | FStarC_Reflection_V2_Data.Pat_Constant uu___ -> p + | FStarC_Reflection_V2_Data.Pat_Cons (fv, us, pats) -> let pats1 = subst_patterns pats ss in - FStar_Reflection_V2_Data.Pat_Cons (fv, us, pats1) - | FStar_Reflection_V2_Data.Pat_Var (bv, s) -> - FStar_Reflection_V2_Data.Pat_Var (bv, s) - | FStar_Reflection_V2_Data.Pat_Dot_Term topt -> - FStar_Reflection_V2_Data.Pat_Dot_Term + FStarC_Reflection_V2_Data.Pat_Cons (fv, us, pats1) + | FStarC_Reflection_V2_Data.Pat_Var (bv, s) -> + FStarC_Reflection_V2_Data.Pat_Var (bv, s) + | FStarC_Reflection_V2_Data.Pat_Dot_Term topt -> + FStarC_Reflection_V2_Data.Pat_Dot_Term ((match topt with | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None | FStar_Pervasives_Native.Some t -> FStar_Pervasives_Native.Some (subst_term t ss))) and (subst_branch : - FStar_Reflection_V2_Data.branch -> subst -> FStar_Reflection_V2_Data.branch) + FStarC_Reflection_V2_Data.branch -> + subst -> FStarC_Reflection_V2_Data.branch) = fun br -> fun ss -> @@ -545,8 +553,8 @@ and (subst_branch : let j = binder_offset_pattern p1 in let t1 = subst_term t (shift_subst_n j ss) in (p1, t1) and (subst_branches : - FStar_Reflection_V2_Data.branch Prims.list -> - subst -> FStar_Reflection_V2_Data.branch Prims.list) + FStarC_Reflection_V2_Data.branch Prims.list -> + subst -> FStarC_Reflection_V2_Data.branch Prims.list) = fun brs -> fun ss -> @@ -554,8 +562,8 @@ and (subst_branches : | [] -> [] | br::brs1 -> (subst_branch br ss) :: (subst_branches brs1 ss) and (subst_match_returns : - FStar_Syntax_Syntax.match_returns_ascription -> - subst -> FStar_Syntax_Syntax.match_returns_ascription) + FStarC_Syntax_Syntax.match_returns_ascription -> + subst -> FStarC_Syntax_Syntax.match_returns_ascription) = fun m -> fun ss -> @@ -576,152 +584,156 @@ and (subst_match_returns : FStar_Pervasives_Native.Some (subst_term t (shift_subst ss)) in (b1, (ret1, as_1, eq)) let (open_with : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> FStar_Reflection_Types.term) + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term) = fun t -> fun v -> FStar_Reflection_Typing_Builtins.open_with t v let (open_term : - FStar_Reflection_Types.term -> - FStar_Reflection_V2_Data.var -> FStar_Reflection_Types.term) + FStarC_Reflection_Types.term -> + FStarC_Reflection_V2_Data.var -> FStarC_Reflection_Types.term) = fun t -> fun v -> FStar_Reflection_Typing_Builtins.open_term t v let (close_term : - FStar_Reflection_Types.term -> - FStar_Reflection_V2_Data.var -> FStar_Reflection_Types.term) + FStarC_Reflection_Types.term -> + FStarC_Reflection_V2_Data.var -> FStarC_Reflection_Types.term) = fun t -> fun v -> FStar_Reflection_Typing_Builtins.close_term t v let (rename : - FStar_Reflection_Types.term -> - FStar_Reflection_V2_Data.var -> - FStar_Reflection_V2_Data.var -> FStar_Reflection_Types.term) + FStarC_Reflection_Types.term -> + FStarC_Reflection_V2_Data.var -> + FStarC_Reflection_V2_Data.var -> FStarC_Reflection_Types.term) = fun t -> fun x -> fun y -> FStar_Reflection_Typing_Builtins.rename t x y let (constant_as_term : - FStar_Reflection_V2_Data.vconst -> FStar_Reflection_Types.term) = + FStarC_Reflection_V2_Data.vconst -> FStarC_Reflection_Types.term) = fun v -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const v) -let (unit_exp : FStar_Reflection_Types.term) = - constant_as_term FStar_Reflection_V2_Data.C_Unit -let (unit_fv : FStar_Reflection_Types.fv) = - FStar_Reflection_V2_Builtins.pack_fv FStar_Reflection_Const.unit_lid -let (unit_ty : FStar_Reflection_Types.term) = - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar unit_fv) -let (bool_fv : FStar_Reflection_Types.fv) = - FStar_Reflection_V2_Builtins.pack_fv FStar_Reflection_Const.bool_lid -let (bool_ty : FStar_Reflection_Types.term) = - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar bool_fv) -let (u_zero : FStar_Reflection_Types.universe) = - FStar_Reflection_V2_Builtins.pack_universe FStar_Reflection_V2_Data.Uv_Zero + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const v) +let (unit_exp : FStarC_Reflection_Types.term) = + constant_as_term FStarC_Reflection_V2_Data.C_Unit +let (unit_fv : FStarC_Reflection_Types.fv) = + FStarC_Reflection_V2_Builtins.pack_fv FStar_Reflection_Const.unit_lid +let (unit_ty : FStarC_Reflection_Types.term) = + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar unit_fv) +let (bool_fv : FStarC_Reflection_Types.fv) = + FStarC_Reflection_V2_Builtins.pack_fv FStar_Reflection_Const.bool_lid +let (bool_ty : FStarC_Reflection_Types.term) = + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar bool_fv) +let (u_zero : FStarC_Reflection_Types.universe) = + FStarC_Reflection_V2_Builtins.pack_universe + FStarC_Reflection_V2_Data.Uv_Zero let (u_max : - FStar_Reflection_Types.universe -> - FStar_Reflection_Types.universe -> FStar_Reflection_Types.universe) + FStarC_Reflection_Types.universe -> + FStarC_Reflection_Types.universe -> FStarC_Reflection_Types.universe) = fun u1 -> fun u2 -> - FStar_Reflection_V2_Builtins.pack_universe - (FStar_Reflection_V2_Data.Uv_Max [u1; u2]) + FStarC_Reflection_V2_Builtins.pack_universe + (FStarC_Reflection_V2_Data.Uv_Max [u1; u2]) let (u_succ : - FStar_Reflection_Types.universe -> FStar_Reflection_Types.universe) = + FStarC_Reflection_Types.universe -> FStarC_Reflection_Types.universe) = fun u -> - FStar_Reflection_V2_Builtins.pack_universe - (FStar_Reflection_V2_Data.Uv_Succ u) + FStarC_Reflection_V2_Builtins.pack_universe + (FStarC_Reflection_V2_Data.Uv_Succ u) let (tm_type : - FStar_Reflection_Types.universe -> FStar_Reflection_Types.term) = + FStarC_Reflection_Types.universe -> FStarC_Reflection_Types.term) = fun u -> - FStar_Reflection_V2_Builtins.pack_ln (FStar_Reflection_V2_Data.Tv_Type u) -let (tm_prop : FStar_Reflection_Types.term) = + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Type u) +let (tm_prop : FStarC_Reflection_Types.term) = let prop_fv = - FStar_Reflection_V2_Builtins.pack_fv FStar_Reflection_Const.prop_qn in - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar prop_fv) -let (eqtype_lid : FStar_Reflection_Types.name) = ["Prims"; "eqtype"] -let (true_bool : FStar_Reflection_Types.term) = - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const FStar_Reflection_V2_Data.C_True) -let (false_bool : FStar_Reflection_Types.term) = - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const FStar_Reflection_V2_Data.C_False) + FStarC_Reflection_V2_Builtins.pack_fv FStar_Reflection_Const.prop_qn in + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar prop_fv) +let (eqtype_lid : FStarC_Reflection_Types.name) = ["Prims"; "eqtype"] +let (true_bool : FStarC_Reflection_Types.term) = + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const FStarC_Reflection_V2_Data.C_True) +let (false_bool : FStarC_Reflection_Types.term) = + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const FStarC_Reflection_V2_Data.C_False) let (eq2 : - FStar_Reflection_Types.universe -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> FStar_Reflection_Types.term) + FStarC_Reflection_Types.universe -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term) = fun u -> fun t -> fun v0 -> fun v1 -> let eq21 = - FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_fv FStar_Reflection_Const.eq2_qn in let eq22 = - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_UInst (eq21, [u])) in + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_UInst (eq21, [u])) in let h = - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - (eq22, (t, FStar_Reflection_V2_Data.Q_Implicit))) in + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + (eq22, (t, FStarC_Reflection_V2_Data.Q_Implicit))) in let h1 = - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - (h, (v0, FStar_Reflection_V2_Data.Q_Explicit))) in + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + (h, (v0, FStarC_Reflection_V2_Data.Q_Explicit))) in let h2 = - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - (h1, (v1, FStar_Reflection_V2_Data.Q_Explicit))) in + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + (h1, (v1, FStarC_Reflection_V2_Data.Q_Explicit))) in h2 -let (b2t_lid : FStar_Reflection_Types.name) = ["Prims"; "b2t"] -let (b2t_fv : FStar_Reflection_Types.fv) = - FStar_Reflection_V2_Builtins.pack_fv b2t_lid -let (b2t_ty : FStar_Reflection_Types.term) = - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Arrow +let (b2t_lid : FStarC_Reflection_Types.name) = ["Prims"; "b2t"] +let (b2t_fv : FStarC_Reflection_Types.fv) = + FStarC_Reflection_V2_Builtins.pack_fv b2t_lid +let (b2t_ty : FStarC_Reflection_Types.term) = + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Arrow ((mk_binder (FStar_Sealed.seal "x") bool_ty - FStar_Reflection_V2_Data.Q_Explicit), (mk_total (tm_type u_zero)))) + FStarC_Reflection_V2_Data.Q_Explicit), + (mk_total (tm_type u_zero)))) let rec (freevars : - FStar_Reflection_Types.term -> FStar_Reflection_V2_Data.var FStar_Set.set) + FStarC_Reflection_Types.term -> FStarC_Reflection_V2_Data.var FStar_Set.set) = fun e -> - match FStar_Reflection_V2_Builtins.inspect_ln e with - | FStar_Reflection_V2_Data.Tv_Uvar (uu___, uu___1) -> + match FStarC_Reflection_V2_Builtins.inspect_ln e with + | FStarC_Reflection_V2_Data.Tv_Uvar (uu___, uu___1) -> FStar_Set.complement (FStar_Set.empty ()) - | FStar_Reflection_V2_Data.Tv_UInst (uu___, uu___1) -> FStar_Set.empty () - | FStar_Reflection_V2_Data.Tv_FVar uu___ -> FStar_Set.empty () - | FStar_Reflection_V2_Data.Tv_Type uu___ -> FStar_Set.empty () - | FStar_Reflection_V2_Data.Tv_Const uu___ -> FStar_Set.empty () - | FStar_Reflection_V2_Data.Tv_Unknown -> FStar_Set.empty () - | FStar_Reflection_V2_Data.Tv_Unsupp -> FStar_Set.empty () - | FStar_Reflection_V2_Data.Tv_BVar uu___ -> FStar_Set.empty () - | FStar_Reflection_V2_Data.Tv_Var x -> + | FStarC_Reflection_V2_Data.Tv_UInst (uu___, uu___1) -> + FStar_Set.empty () + | FStarC_Reflection_V2_Data.Tv_FVar uu___ -> FStar_Set.empty () + | FStarC_Reflection_V2_Data.Tv_Type uu___ -> FStar_Set.empty () + | FStarC_Reflection_V2_Data.Tv_Const uu___ -> FStar_Set.empty () + | FStarC_Reflection_V2_Data.Tv_Unknown -> FStar_Set.empty () + | FStarC_Reflection_V2_Data.Tv_Unsupp -> FStar_Set.empty () + | FStarC_Reflection_V2_Data.Tv_BVar uu___ -> FStar_Set.empty () + | FStarC_Reflection_V2_Data.Tv_Var x -> FStar_Set.singleton (namedv_uniq x) - | FStar_Reflection_V2_Data.Tv_App (e1, (e2, uu___)) -> + | FStarC_Reflection_V2_Data.Tv_App (e1, (e2, uu___)) -> FStar_Set.union (freevars e1) (freevars e2) - | FStar_Reflection_V2_Data.Tv_Abs (b, body) -> + | FStarC_Reflection_V2_Data.Tv_Abs (b, body) -> FStar_Set.union (freevars_binder b) (freevars body) - | FStar_Reflection_V2_Data.Tv_Arrow (b, c) -> + | FStarC_Reflection_V2_Data.Tv_Arrow (b, c) -> FStar_Set.union (freevars_binder b) (freevars_comp c) - | FStar_Reflection_V2_Data.Tv_Refine (b, f) -> + | FStarC_Reflection_V2_Data.Tv_Refine (b, f) -> FStar_Set.union (freevars (binder_sort b)) (freevars f) - | FStar_Reflection_V2_Data.Tv_Let (recf, attrs, b, def, body) -> + | FStarC_Reflection_V2_Data.Tv_Let (recf, attrs, b, def, body) -> FStar_Set.union (FStar_Set.union (FStar_Set.union (freevars_terms attrs) (freevars (binder_sort b))) (freevars def)) (freevars body) - | FStar_Reflection_V2_Data.Tv_Match (scr, ret, brs) -> + | FStarC_Reflection_V2_Data.Tv_Match (scr, ret, brs) -> FStar_Set.union (FStar_Set.union (freevars scr) (freevars_opt ret freevars_match_returns)) (freevars_branches brs) - | FStar_Reflection_V2_Data.Tv_AscribedT (e1, t, tac, b) -> + | FStarC_Reflection_V2_Data.Tv_AscribedT (e1, t, tac, b) -> FStar_Set.union (FStar_Set.union (freevars e1) (freevars t)) (freevars_opt tac freevars) - | FStar_Reflection_V2_Data.Tv_AscribedC (e1, c, tac, b) -> + | FStarC_Reflection_V2_Data.Tv_AscribedC (e1, c, tac, b) -> FStar_Set.union (FStar_Set.union (freevars e1) (freevars_comp c)) (freevars_opt tac freevars) and freevars_opt : 'a . 'a FStar_Pervasives_Native.option -> - ('a -> FStar_Reflection_V2_Data.var FStar_Set.set) -> - FStar_Reflection_V2_Data.var FStar_Set.set + ('a -> FStarC_Reflection_V2_Data.var FStar_Set.set) -> + FStarC_Reflection_V2_Data.var FStar_Set.set = fun o -> fun f -> @@ -729,56 +741,57 @@ and freevars_opt : | FStar_Pervasives_Native.None -> FStar_Set.empty () | FStar_Pervasives_Native.Some x -> f x and (freevars_comp : - FStar_Reflection_Types.comp -> FStar_Reflection_V2_Data.var FStar_Set.set) + FStarC_Reflection_Types.comp -> FStarC_Reflection_V2_Data.var FStar_Set.set) = fun c -> - match FStar_Reflection_V2_Builtins.inspect_comp c with - | FStar_Reflection_V2_Data.C_Total t -> freevars t - | FStar_Reflection_V2_Data.C_GTotal t -> freevars t - | FStar_Reflection_V2_Data.C_Lemma (pre, post, pats) -> + match FStarC_Reflection_V2_Builtins.inspect_comp c with + | FStarC_Reflection_V2_Data.C_Total t -> freevars t + | FStarC_Reflection_V2_Data.C_GTotal t -> freevars t + | FStarC_Reflection_V2_Data.C_Lemma (pre, post, pats) -> FStar_Set.union (FStar_Set.union (freevars pre) (freevars post)) (freevars pats) - | FStar_Reflection_V2_Data.C_Eff (us, eff_name, res, args, decrs) -> + | FStarC_Reflection_V2_Data.C_Eff (us, eff_name, res, args, decrs) -> FStar_Set.union (FStar_Set.union (freevars res) (freevars_args args)) (freevars_terms decrs) and (freevars_args : - FStar_Reflection_V2_Data.argv Prims.list -> - FStar_Reflection_V2_Data.var FStar_Set.set) + FStarC_Reflection_V2_Data.argv Prims.list -> + FStarC_Reflection_V2_Data.var FStar_Set.set) = fun ts -> match ts with | [] -> FStar_Set.empty () | (t, q)::ts1 -> FStar_Set.union (freevars t) (freevars_args ts1) and (freevars_terms : - FStar_Reflection_Types.term Prims.list -> - FStar_Reflection_V2_Data.var FStar_Set.set) + FStarC_Reflection_Types.term Prims.list -> + FStarC_Reflection_V2_Data.var FStar_Set.set) = fun ts -> match ts with | [] -> FStar_Set.empty () | t::ts1 -> FStar_Set.union (freevars t) (freevars_terms ts1) and (freevars_binder : - FStar_Reflection_Types.binder -> FStar_Reflection_V2_Data.var FStar_Set.set) + FStarC_Reflection_Types.binder -> + FStarC_Reflection_V2_Data.var FStar_Set.set) = fun b -> - let bndr = FStar_Reflection_V2_Builtins.inspect_binder b in - FStar_Set.union (freevars bndr.FStar_Reflection_V2_Data.sort2) - (freevars_terms bndr.FStar_Reflection_V2_Data.attrs) + let bndr = FStarC_Reflection_V2_Builtins.inspect_binder b in + FStar_Set.union (freevars bndr.FStarC_Reflection_V2_Data.sort2) + (freevars_terms bndr.FStarC_Reflection_V2_Data.attrs) and (freevars_pattern : - FStar_Reflection_V2_Data.pattern -> - FStar_Reflection_V2_Data.var FStar_Set.set) + FStarC_Reflection_V2_Data.pattern -> + FStarC_Reflection_V2_Data.var FStar_Set.set) = fun p -> match p with - | FStar_Reflection_V2_Data.Pat_Constant uu___ -> FStar_Set.empty () - | FStar_Reflection_V2_Data.Pat_Cons (head, univs, subpats) -> + | FStarC_Reflection_V2_Data.Pat_Constant uu___ -> FStar_Set.empty () + | FStarC_Reflection_V2_Data.Pat_Cons (head, univs, subpats) -> freevars_patterns subpats - | FStar_Reflection_V2_Data.Pat_Var (bv, s) -> FStar_Set.empty () - | FStar_Reflection_V2_Data.Pat_Dot_Term topt -> + | FStarC_Reflection_V2_Data.Pat_Var (bv, s) -> FStar_Set.empty () + | FStarC_Reflection_V2_Data.Pat_Dot_Term topt -> freevars_opt topt freevars and (freevars_patterns : - (FStar_Reflection_V2_Data.pattern * Prims.bool) Prims.list -> - FStar_Reflection_V2_Data.var FStar_Set.set) + (FStarC_Reflection_V2_Data.pattern * Prims.bool) Prims.list -> + FStarC_Reflection_V2_Data.var FStar_Set.set) = fun ps -> match ps with @@ -786,24 +799,24 @@ and (freevars_patterns : | (p, b)::ps1 -> FStar_Set.union (freevars_pattern p) (freevars_patterns ps1) and (freevars_branch : - FStar_Reflection_V2_Data.branch -> - FStar_Reflection_V2_Data.var FStar_Set.set) + FStarC_Reflection_V2_Data.branch -> + FStarC_Reflection_V2_Data.var FStar_Set.set) = fun br -> let uu___ = br in match uu___ with | (p, t) -> FStar_Set.union (freevars_pattern p) (freevars t) and (freevars_branches : - FStar_Reflection_V2_Data.branch Prims.list -> - FStar_Reflection_V2_Data.var FStar_Set.set) + FStarC_Reflection_V2_Data.branch Prims.list -> + FStarC_Reflection_V2_Data.var FStar_Set.set) = fun brs -> match brs with | [] -> FStar_Set.empty () | hd::tl -> FStar_Set.union (freevars_branch hd) (freevars_branches tl) and (freevars_match_returns : - FStar_Syntax_Syntax.match_returns_ascription -> - FStar_Reflection_V2_Data.var FStar_Set.set) + FStarC_Syntax_Syntax.match_returns_ascription -> + FStarC_Reflection_V2_Data.var FStar_Set.set) = fun m -> let uu___ = m in @@ -816,77 +829,78 @@ and (freevars_match_returns : | FStar_Pervasives.Inr c -> freevars_comp c in let as_1 = freevars_opt as_ freevars in FStar_Set.union (FStar_Set.union b1 ret1) as_1 -let rec (ln' : FStar_Reflection_Types.term -> Prims.int -> Prims.bool) = +let rec (ln' : FStarC_Reflection_Types.term -> Prims.int -> Prims.bool) = fun e -> fun n -> - match FStar_Reflection_V2_Builtins.inspect_ln e with - | FStar_Reflection_V2_Data.Tv_UInst (uu___, uu___1) -> true - | FStar_Reflection_V2_Data.Tv_FVar uu___ -> true - | FStar_Reflection_V2_Data.Tv_Type uu___ -> true - | FStar_Reflection_V2_Data.Tv_Const uu___ -> true - | FStar_Reflection_V2_Data.Tv_Unknown -> true - | FStar_Reflection_V2_Data.Tv_Unsupp -> true - | FStar_Reflection_V2_Data.Tv_Var uu___ -> true - | FStar_Reflection_V2_Data.Tv_BVar m -> (bv_index m) <= n - | FStar_Reflection_V2_Data.Tv_App (e1, (e2, uu___)) -> + match FStarC_Reflection_V2_Builtins.inspect_ln e with + | FStarC_Reflection_V2_Data.Tv_UInst (uu___, uu___1) -> true + | FStarC_Reflection_V2_Data.Tv_FVar uu___ -> true + | FStarC_Reflection_V2_Data.Tv_Type uu___ -> true + | FStarC_Reflection_V2_Data.Tv_Const uu___ -> true + | FStarC_Reflection_V2_Data.Tv_Unknown -> true + | FStarC_Reflection_V2_Data.Tv_Unsupp -> true + | FStarC_Reflection_V2_Data.Tv_Var uu___ -> true + | FStarC_Reflection_V2_Data.Tv_BVar m -> (bv_index m) <= n + | FStarC_Reflection_V2_Data.Tv_App (e1, (e2, uu___)) -> (ln' e1 n) && (ln' e2 n) - | FStar_Reflection_V2_Data.Tv_Abs (b, body) -> + | FStarC_Reflection_V2_Data.Tv_Abs (b, body) -> (ln'_binder b n) && (ln' body (n + Prims.int_one)) - | FStar_Reflection_V2_Data.Tv_Arrow (b, c) -> + | FStarC_Reflection_V2_Data.Tv_Arrow (b, c) -> (ln'_binder b n) && (ln'_comp c (n + Prims.int_one)) - | FStar_Reflection_V2_Data.Tv_Refine (b, f) -> + | FStarC_Reflection_V2_Data.Tv_Refine (b, f) -> (ln'_binder b n) && (ln' f (n + Prims.int_one)) - | FStar_Reflection_V2_Data.Tv_Uvar (uu___, uu___1) -> false - | FStar_Reflection_V2_Data.Tv_Let (recf, attrs, b, def, body) -> + | FStarC_Reflection_V2_Data.Tv_Uvar (uu___, uu___1) -> false + | FStarC_Reflection_V2_Data.Tv_Let (recf, attrs, b, def, body) -> (((ln'_terms attrs n) && (ln'_binder b n)) && (if recf then ln' def (n + Prims.int_one) else ln' def n)) && (ln' body (n + Prims.int_one)) - | FStar_Reflection_V2_Data.Tv_Match (scr, ret, brs) -> + | FStarC_Reflection_V2_Data.Tv_Match (scr, ret, brs) -> ((ln' scr n) && (match ret with | FStar_Pervasives_Native.None -> true | FStar_Pervasives_Native.Some m -> ln'_match_returns m n)) && (ln'_branches brs n) - | FStar_Reflection_V2_Data.Tv_AscribedT (e1, t, tac, b) -> + | FStarC_Reflection_V2_Data.Tv_AscribedT (e1, t, tac, b) -> ((ln' e1 n) && (ln' t n)) && ((match tac with | FStar_Pervasives_Native.None -> true | FStar_Pervasives_Native.Some tac1 -> ln' tac1 n)) - | FStar_Reflection_V2_Data.Tv_AscribedC (e1, c, tac, b) -> + | FStarC_Reflection_V2_Data.Tv_AscribedC (e1, c, tac, b) -> ((ln' e1 n) && (ln'_comp c n)) && ((match tac with | FStar_Pervasives_Native.None -> true | FStar_Pervasives_Native.Some tac1 -> ln' tac1 n)) -and (ln'_comp : FStar_Reflection_Types.comp -> Prims.int -> Prims.bool) = +and (ln'_comp : FStarC_Reflection_Types.comp -> Prims.int -> Prims.bool) = fun c -> fun i -> - match FStar_Reflection_V2_Builtins.inspect_comp c with - | FStar_Reflection_V2_Data.C_Total t -> ln' t i - | FStar_Reflection_V2_Data.C_GTotal t -> ln' t i - | FStar_Reflection_V2_Data.C_Lemma (pre, post, pats) -> + match FStarC_Reflection_V2_Builtins.inspect_comp c with + | FStarC_Reflection_V2_Data.C_Total t -> ln' t i + | FStarC_Reflection_V2_Data.C_GTotal t -> ln' t i + | FStarC_Reflection_V2_Data.C_Lemma (pre, post, pats) -> ((ln' pre i) && (ln' post i)) && (ln' pats i) - | FStar_Reflection_V2_Data.C_Eff (us, eff_name, res, args, decrs) -> + | FStarC_Reflection_V2_Data.C_Eff (us, eff_name, res, args, decrs) -> ((ln' res i) && (ln'_args args i)) && (ln'_terms decrs i) and (ln'_args : - FStar_Reflection_V2_Data.argv Prims.list -> Prims.int -> Prims.bool) = + FStarC_Reflection_V2_Data.argv Prims.list -> Prims.int -> Prims.bool) = fun ts -> fun i -> match ts with | [] -> true | (t, q)::ts1 -> (ln' t i) && (ln'_args ts1 i) -and (ln'_binder : FStar_Reflection_Types.binder -> Prims.int -> Prims.bool) = +and (ln'_binder : FStarC_Reflection_Types.binder -> Prims.int -> Prims.bool) + = fun b -> fun n -> - let bndr = FStar_Reflection_V2_Builtins.inspect_binder b in - (ln' bndr.FStar_Reflection_V2_Data.sort2 n) && - (ln'_terms bndr.FStar_Reflection_V2_Data.attrs n) + let bndr = FStarC_Reflection_V2_Builtins.inspect_binder b in + (ln' bndr.FStarC_Reflection_V2_Data.sort2 n) && + (ln'_terms bndr.FStarC_Reflection_V2_Data.attrs n) and (ln'_terms : - FStar_Reflection_Types.term Prims.list -> Prims.int -> Prims.bool) = + FStarC_Reflection_Types.term Prims.list -> Prims.int -> Prims.bool) = fun ts -> fun n -> match ts with | [] -> true | t::ts1 -> (ln' t n) && (ln'_terms ts1 n) and (ln'_patterns : - (FStar_Reflection_V2_Data.pattern * Prims.bool) Prims.list -> + (FStarC_Reflection_V2_Data.pattern * Prims.bool) Prims.list -> Prims.int -> Prims.bool) = fun ps -> @@ -898,20 +912,20 @@ and (ln'_patterns : let n = binder_offset_pattern p in let b1 = ln'_patterns ps1 (i + n) in b0 && b1 and (ln'_pattern : - FStar_Reflection_V2_Data.pattern -> Prims.int -> Prims.bool) = + FStarC_Reflection_V2_Data.pattern -> Prims.int -> Prims.bool) = fun p -> fun i -> match p with - | FStar_Reflection_V2_Data.Pat_Constant uu___ -> true - | FStar_Reflection_V2_Data.Pat_Cons (head, univs, subpats) -> + | FStarC_Reflection_V2_Data.Pat_Constant uu___ -> true + | FStarC_Reflection_V2_Data.Pat_Cons (head, univs, subpats) -> ln'_patterns subpats i - | FStar_Reflection_V2_Data.Pat_Var (bv, s) -> true - | FStar_Reflection_V2_Data.Pat_Dot_Term topt -> + | FStarC_Reflection_V2_Data.Pat_Var (bv, s) -> true + | FStarC_Reflection_V2_Data.Pat_Dot_Term topt -> (match topt with | FStar_Pervasives_Native.None -> true | FStar_Pervasives_Native.Some t -> ln' t i) -and (ln'_branch : FStar_Reflection_V2_Data.branch -> Prims.int -> Prims.bool) - = +and (ln'_branch : + FStarC_Reflection_V2_Data.branch -> Prims.int -> Prims.bool) = fun br -> fun i -> let uu___ = br in @@ -921,14 +935,14 @@ and (ln'_branch : FStar_Reflection_V2_Data.branch -> Prims.int -> Prims.bool) let j = binder_offset_pattern p in let b' = ln' t (i + j) in b && b' and (ln'_branches : - FStar_Reflection_V2_Data.branch Prims.list -> Prims.int -> Prims.bool) = + FStarC_Reflection_V2_Data.branch Prims.list -> Prims.int -> Prims.bool) = fun brs -> fun i -> match brs with | [] -> true | br::brs1 -> (ln'_branch br i) && (ln'_branches brs1 i) and (ln'_match_returns : - FStar_Syntax_Syntax.match_returns_ascription -> Prims.int -> Prims.bool) = + FStarC_Syntax_Syntax.match_returns_ascription -> Prims.int -> Prims.bool) = fun m -> fun i -> let uu___ = m in @@ -944,15 +958,15 @@ and (ln'_match_returns : | FStar_Pervasives_Native.None -> true | FStar_Pervasives_Native.Some t -> ln' t (i + Prims.int_one) in (b1 && ret1) && as_1 -let (ln : FStar_Reflection_Types.term -> Prims.bool) = +let (ln : FStarC_Reflection_Types.term -> Prims.bool) = fun t -> ln' t (Prims.of_int (-1)) -let (ln_comp : FStar_Reflection_Types.comp -> Prims.bool) = +let (ln_comp : FStarC_Reflection_Types.comp -> Prims.bool) = fun c -> ln'_comp c (Prims.of_int (-1)) type term_ctxt = | Ctxt_hole - | Ctxt_app_head of term_ctxt * FStar_Reflection_V2_Data.argv - | Ctxt_app_arg of FStar_Reflection_Types.term * - FStar_Reflection_V2_Data.aqualv * term_ctxt + | Ctxt_app_head of term_ctxt * FStarC_Reflection_V2_Data.argv + | Ctxt_app_arg of FStarC_Reflection_Types.term * + FStarC_Reflection_V2_Data.aqualv * term_ctxt let uu___is_Ctxt_hole uu___ = match uu___ with | Ctxt_hole _ -> true | _ -> false let uu___is_Ctxt_app_head uu___ = @@ -960,64 +974,68 @@ let uu___is_Ctxt_app_head uu___ = let uu___is_Ctxt_app_arg uu___ = match uu___ with | Ctxt_app_arg _ -> true | _ -> false let rec (apply_term_ctxt : - term_ctxt -> FStar_Reflection_Types.term -> FStar_Reflection_Types.term) = + term_ctxt -> FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term) + = fun e -> fun t -> match e with | Ctxt_hole -> t | Ctxt_app_head (e1, arg) -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App ((apply_term_ctxt e1 t), arg)) + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App ((apply_term_ctxt e1 t), arg)) | Ctxt_app_arg (hd, q, e1) -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App (hd, ((apply_term_ctxt e1 t), q))) type ('dummyV0, 'dummyV1) constant_typing = | CT_Unit | CT_True | CT_False let (uu___is_CT_Unit : - FStar_Reflection_V2_Data.vconst -> - FStar_Reflection_Types.term -> (unit, unit) constant_typing -> Prims.bool) + FStarC_Reflection_V2_Data.vconst -> + FStarC_Reflection_Types.term -> + (unit, unit) constant_typing -> Prims.bool) = fun uu___ -> fun uu___1 -> fun projectee -> match projectee with | CT_Unit -> true | uu___2 -> false let (uu___is_CT_True : - FStar_Reflection_V2_Data.vconst -> - FStar_Reflection_Types.term -> (unit, unit) constant_typing -> Prims.bool) + FStarC_Reflection_V2_Data.vconst -> + FStarC_Reflection_Types.term -> + (unit, unit) constant_typing -> Prims.bool) = fun uu___ -> fun uu___1 -> fun projectee -> match projectee with | CT_True -> true | uu___2 -> false let (uu___is_CT_False : - FStar_Reflection_V2_Data.vconst -> - FStar_Reflection_Types.term -> (unit, unit) constant_typing -> Prims.bool) + FStarC_Reflection_V2_Data.vconst -> + FStarC_Reflection_Types.term -> + (unit, unit) constant_typing -> Prims.bool) = fun uu___ -> fun uu___1 -> fun projectee -> match projectee with | CT_False -> true | uu___2 -> false type ('dummyV0, 'dummyV1) univ_eq = - | UN_Refl of FStar_Reflection_Types.universe - | UN_MaxCongL of FStar_Reflection_Types.universe * - FStar_Reflection_Types.universe * FStar_Reflection_Types.universe * ( - unit, unit) univ_eq - | UN_MaxCongR of FStar_Reflection_Types.universe * - FStar_Reflection_Types.universe * FStar_Reflection_Types.universe * ( - unit, unit) univ_eq - | UN_MaxComm of FStar_Reflection_Types.universe * - FStar_Reflection_Types.universe - | UN_MaxLeq of FStar_Reflection_Types.universe * - FStar_Reflection_Types.universe * (unit, unit) univ_leq + | UN_Refl of FStarC_Reflection_Types.universe + | UN_MaxCongL of FStarC_Reflection_Types.universe * + FStarC_Reflection_Types.universe * FStarC_Reflection_Types.universe * + (unit, unit) univ_eq + | UN_MaxCongR of FStarC_Reflection_Types.universe * + FStarC_Reflection_Types.universe * FStarC_Reflection_Types.universe * + (unit, unit) univ_eq + | UN_MaxComm of FStarC_Reflection_Types.universe * + FStarC_Reflection_Types.universe + | UN_MaxLeq of FStarC_Reflection_Types.universe * + FStarC_Reflection_Types.universe * (unit, unit) univ_leq and ('dummyV0, 'dummyV1) univ_leq = - | UNLEQ_Refl of FStar_Reflection_Types.universe - | UNLEQ_Succ of FStar_Reflection_Types.universe * - FStar_Reflection_Types.universe * (unit, unit) univ_leq - | UNLEQ_Max of FStar_Reflection_Types.universe * - FStar_Reflection_Types.universe + | UNLEQ_Refl of FStarC_Reflection_Types.universe + | UNLEQ_Succ of FStarC_Reflection_Types.universe * + FStarC_Reflection_Types.universe * (unit, unit) univ_leq + | UNLEQ_Max of FStarC_Reflection_Types.universe * + FStarC_Reflection_Types.universe let uu___is_UN_Refl uu___1 uu___ uu___2 = match uu___2 with | UN_Refl _ -> true | _ -> false let uu___is_UN_MaxCongL uu___1 uu___ uu___2 = @@ -1035,27 +1053,27 @@ let uu___is_UNLEQ_Succ uu___1 uu___ uu___2 = let uu___is_UNLEQ_Max uu___1 uu___ uu___2 = match uu___2 with | UNLEQ_Max _ -> true | _ -> false let (mk_if : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> FStar_Reflection_Types.term) + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term) = fun scrutinee -> fun then_ -> fun else_ -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Match + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Match (scrutinee, FStar_Pervasives_Native.None, - [((FStar_Reflection_V2_Data.Pat_Constant - FStar_Reflection_V2_Data.C_True), then_); - ((FStar_Reflection_V2_Data.Pat_Constant - FStar_Reflection_V2_Data.C_False), else_)])) + [((FStarC_Reflection_V2_Data.Pat_Constant + FStarC_Reflection_V2_Data.C_True), then_); + ((FStarC_Reflection_V2_Data.Pat_Constant + FStarC_Reflection_V2_Data.C_False), else_)])) type comp_typ = - (FStar_TypeChecker_Core.tot_or_ghost * FStar_Reflection_Types.typ) + (FStarC_TypeChecker_Core.tot_or_ghost * FStarC_Reflection_Types.typ) let (close_comp_typ' : comp_typ -> - FStar_Reflection_V2_Data.var -> + FStarC_Reflection_V2_Data.var -> Prims.nat -> - (FStar_TypeChecker_Core.tot_or_ghost * FStar_Reflection_Types.term)) + (FStarC_TypeChecker_Core.tot_or_ghost * FStarC_Reflection_Types.term)) = fun c -> fun x -> @@ -1064,14 +1082,14 @@ let (close_comp_typ' : (subst_term (FStar_Pervasives_Native.snd c) [ND (x, i)])) let (close_comp_typ : comp_typ -> - FStar_Reflection_V2_Data.var -> - (FStar_TypeChecker_Core.tot_or_ghost * FStar_Reflection_Types.term)) + FStarC_Reflection_V2_Data.var -> + (FStarC_TypeChecker_Core.tot_or_ghost * FStarC_Reflection_Types.term)) = fun c -> fun x -> close_comp_typ' c x Prims.int_zero let (open_comp_typ' : comp_typ -> - FStar_Reflection_V2_Data.var -> + FStarC_Reflection_V2_Data.var -> Prims.nat -> - (FStar_TypeChecker_Core.tot_or_ghost * FStar_Reflection_Types.term)) + (FStarC_TypeChecker_Core.tot_or_ghost * FStarC_Reflection_Types.term)) = fun c -> fun x -> @@ -1080,29 +1098,29 @@ let (open_comp_typ' : (subst_term (FStar_Pervasives_Native.snd c) (open_with_var x i))) let (open_comp_typ : comp_typ -> - FStar_Reflection_V2_Data.var -> - (FStar_TypeChecker_Core.tot_or_ghost * FStar_Reflection_Types.term)) + FStarC_Reflection_V2_Data.var -> + (FStarC_TypeChecker_Core.tot_or_ghost * FStarC_Reflection_Types.term)) = fun c -> fun x -> open_comp_typ' c x Prims.int_zero let (freevars_comp_typ : - comp_typ -> FStar_Reflection_V2_Data.var FStar_Set.set) = + comp_typ -> FStarC_Reflection_V2_Data.var FStar_Set.set) = fun c -> freevars (FStar_Pervasives_Native.snd c) -let (mk_comp : comp_typ -> FStar_Reflection_Types.comp) = +let (mk_comp : comp_typ -> FStarC_Reflection_Types.comp) = fun c -> match FStar_Pervasives_Native.fst c with - | FStar_TypeChecker_Core.E_Total -> + | FStarC_TypeChecker_Core.E_Total -> mk_total (FStar_Pervasives_Native.snd c) - | FStar_TypeChecker_Core.E_Ghost -> + | FStarC_TypeChecker_Core.E_Ghost -> mk_ghost (FStar_Pervasives_Native.snd c) let (mk_arrow_ct : - FStar_Reflection_Types.term -> - FStar_Reflection_V2_Data.aqualv -> - comp_typ -> FStar_Reflection_Types.term) + FStarC_Reflection_Types.term -> + FStarC_Reflection_V2_Data.aqualv -> + comp_typ -> FStarC_Reflection_Types.term) = fun ty -> fun qual -> fun c -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Arrow + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Arrow ((binder_of_t_q ty qual), (mk_comp c))) type relation = | R_Eq @@ -1111,14 +1129,14 @@ let (uu___is_R_Eq : relation -> Prims.bool) = fun projectee -> match projectee with | R_Eq -> true | uu___ -> false let (uu___is_R_Sub : relation -> Prims.bool) = fun projectee -> match projectee with | R_Sub -> true | uu___ -> false -type binding = (FStar_Reflection_V2_Data.var * FStar_Reflection_Types.term) +type binding = (FStarC_Reflection_V2_Data.var * FStarC_Reflection_Types.term) type bindings = binding Prims.list let rename_bindings : 'uuuuu . - ('uuuuu * FStar_Reflection_Types.term) Prims.list -> - FStar_Reflection_V2_Data.var -> - FStar_Reflection_V2_Data.var -> - ('uuuuu * FStar_Reflection_Types.term) Prims.list + ('uuuuu * FStarC_Reflection_Types.term) Prims.list -> + FStarC_Reflection_V2_Data.var -> + FStarC_Reflection_V2_Data.var -> + ('uuuuu * FStarC_Reflection_Types.term) Prims.list = fun bs -> fun x -> @@ -1126,24 +1144,24 @@ let rename_bindings : FStar_List_Tot_Base.map (fun uu___ -> match uu___ with | (v, t) -> (v, (rename t x y))) bs let rec (extend_env_l : - FStar_Reflection_Types.env -> bindings -> FStar_Reflection_Types.env) = + FStarC_Reflection_Types.env -> bindings -> FStarC_Reflection_Types.env) = fun g -> fun bs -> match bs with | [] -> g | (x, t)::bs1 -> extend_env (extend_env_l g bs1) x t -let (is_non_informative_name : FStar_Reflection_Types.name -> Prims.bool) = +let (is_non_informative_name : FStarC_Reflection_Types.name -> Prims.bool) = fun l -> ((l = FStar_Reflection_Const.unit_lid) || (l = FStar_Reflection_Const.squash_qn)) || (l = ["FStar"; "Ghost"; "erased"]) -let (is_non_informative_fv : FStar_Reflection_Types.fv -> Prims.bool) = +let (is_non_informative_fv : FStarC_Reflection_Types.fv -> Prims.bool) = fun f -> - is_non_informative_name (FStar_Reflection_V2_Builtins.inspect_fv f) + is_non_informative_name (FStarC_Reflection_V2_Builtins.inspect_fv f) let rec (__close_term_vs : Prims.nat -> - FStar_Reflection_V2_Data.var Prims.list -> - FStar_Reflection_Types.term -> FStar_Reflection_Types.term) + FStarC_Reflection_V2_Data.var Prims.list -> + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term) = fun i -> fun vs -> @@ -1154,54 +1172,54 @@ let rec (__close_term_vs : subst_term (__close_term_vs (i + Prims.int_one) vs1 t) [ND (v, i)] let (close_term_vs : - FStar_Reflection_V2_Data.var Prims.list -> - FStar_Reflection_Types.term -> FStar_Reflection_Types.term) + FStarC_Reflection_V2_Data.var Prims.list -> + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term) = fun vs -> fun t -> __close_term_vs Prims.int_zero vs t let (close_term_bs : binding Prims.list -> - FStar_Reflection_Types.term -> FStar_Reflection_Types.term) + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term) = fun bs -> fun t -> close_term_vs (FStar_List_Tot_Base.map FStar_Pervasives_Native.fst bs) t let (bindings_to_refl_bindings : - binding Prims.list -> FStar_Reflection_V2_Data.binding Prims.list) = + binding Prims.list -> FStarC_Reflection_V2_Data.binding Prims.list) = fun bs -> FStar_List_Tot_Base.map (fun uu___ -> match uu___ with | (v, ty) -> { - FStar_Reflection_V2_Data.uniq1 = v; - FStar_Reflection_V2_Data.sort3 = ty; - FStar_Reflection_V2_Data.ppname3 = pp_name_default + FStarC_Reflection_V2_Data.uniq1 = v; + FStarC_Reflection_V2_Data.sort3 = ty; + FStarC_Reflection_V2_Data.ppname3 = pp_name_default }) bs let (refl_bindings_to_bindings : - FStar_Reflection_V2_Data.binding Prims.list -> binding Prims.list) = + FStarC_Reflection_V2_Data.binding Prims.list -> binding Prims.list) = fun bs -> FStar_List_Tot_Base.map (fun b -> - ((b.FStar_Reflection_V2_Data.uniq1), - (b.FStar_Reflection_V2_Data.sort3))) bs + ((b.FStarC_Reflection_V2_Data.uniq1), + (b.FStarC_Reflection_V2_Data.sort3))) bs type ('dummyV0, 'dummyV1) non_informative = - | Non_informative_type of FStar_Reflection_Types.env * - FStar_Reflection_Types.universe - | Non_informative_fv of FStar_Reflection_Types.env * - FStar_Reflection_Types.fv - | Non_informative_uinst of FStar_Reflection_Types.env * - FStar_Reflection_Types.fv * FStar_Reflection_Types.universe Prims.list - | Non_informative_app of FStar_Reflection_Types.env * - FStar_Reflection_Types.term * FStar_Reflection_V2_Data.argv * (unit, + | Non_informative_type of FStarC_Reflection_Types.env * + FStarC_Reflection_Types.universe + | Non_informative_fv of FStarC_Reflection_Types.env * + FStarC_Reflection_Types.fv + | Non_informative_uinst of FStarC_Reflection_Types.env * + FStarC_Reflection_Types.fv * FStarC_Reflection_Types.universe Prims.list + | Non_informative_app of FStarC_Reflection_Types.env * + FStarC_Reflection_Types.term * FStarC_Reflection_V2_Data.argv * (unit, unit) non_informative - | Non_informative_total_arrow of FStar_Reflection_Types.env * - FStar_Reflection_Types.term * FStar_Reflection_V2_Data.aqualv * - FStar_Reflection_Types.term * (unit, unit) non_informative - | Non_informative_ghost_arrow of FStar_Reflection_Types.env * - FStar_Reflection_Types.term * FStar_Reflection_V2_Data.aqualv * - FStar_Reflection_Types.term - | Non_informative_token of FStar_Reflection_Types.env * - FStar_Reflection_Types.typ * unit + | Non_informative_total_arrow of FStarC_Reflection_Types.env * + FStarC_Reflection_Types.term * FStarC_Reflection_V2_Data.aqualv * + FStarC_Reflection_Types.term * (unit, unit) non_informative + | Non_informative_ghost_arrow of FStarC_Reflection_Types.env * + FStarC_Reflection_Types.term * FStarC_Reflection_V2_Data.aqualv * + FStarC_Reflection_Types.term + | Non_informative_token of FStarC_Reflection_Types.env * + FStarC_Reflection_Types.typ * unit let uu___is_Non_informative_type uu___1 uu___ uu___2 = match uu___2 with | Non_informative_type _ -> true | _ -> false let uu___is_Non_informative_fv uu___1 uu___ uu___2 = @@ -1220,38 +1238,38 @@ type ('bnds, 'pat, 'uuuuu) bindings_ok_for_pat = Obj.t type ('g, 'bs, 'br) bindings_ok_for_branch = Obj.t type ('g, 'bss, 'brs) bindings_ok_for_branch_N = Obj.t let (binding_to_namedv : - FStar_Reflection_V2_Data.binding -> FStar_Reflection_Types.namedv) = + FStarC_Reflection_V2_Data.binding -> FStarC_Reflection_Types.namedv) = fun b -> - FStar_Reflection_V2_Builtins.pack_namedv + FStarC_Reflection_V2_Builtins.pack_namedv { - FStar_Reflection_V2_Data.uniq = (b.FStar_Reflection_V2_Data.uniq1); - FStar_Reflection_V2_Data.sort = - (FStar_Sealed.seal b.FStar_Reflection_V2_Data.sort3); - FStar_Reflection_V2_Data.ppname = - (b.FStar_Reflection_V2_Data.ppname3) + FStarC_Reflection_V2_Data.uniq = (b.FStarC_Reflection_V2_Data.uniq1); + FStarC_Reflection_V2_Data.sort = + (FStar_Sealed.seal b.FStarC_Reflection_V2_Data.sort3); + FStarC_Reflection_V2_Data.ppname = + (b.FStarC_Reflection_V2_Data.ppname3) } let rec (elaborate_pat : - FStar_Reflection_V2_Data.pattern -> - FStar_Reflection_V2_Data.binding Prims.list -> - (FStar_Reflection_Types.term * FStar_Reflection_V2_Data.binding + FStarC_Reflection_V2_Data.pattern -> + FStarC_Reflection_V2_Data.binding Prims.list -> + (FStarC_Reflection_Types.term * FStarC_Reflection_V2_Data.binding Prims.list) FStar_Pervasives_Native.option) = fun p -> fun bs -> match (p, bs) with - | (FStar_Reflection_V2_Data.Pat_Constant c, uu___) -> + | (FStarC_Reflection_V2_Data.Pat_Constant c, uu___) -> FStar_Pervasives_Native.Some - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const c)), bs) - | (FStar_Reflection_V2_Data.Pat_Cons (fv, univs, subpats), bs1) -> + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const c)), bs) + | (FStarC_Reflection_V2_Data.Pat_Cons (fv, univs, subpats), bs1) -> let head = match univs with | FStar_Pervasives_Native.Some univs1 -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_UInst (fv, univs1)) + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_UInst (fv, univs1)) | FStar_Pervasives_Native.None -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar fv) in + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar fv) in fold_left_dec (FStar_Pervasives_Native.Some (head, bs1)) subpats (fun st -> fun pi -> @@ -1267,137 +1285,140 @@ let rec (elaborate_pat : FStar_Pervasives_Native.None | FStar_Pervasives_Native.Some (t, bs') -> FStar_Pervasives_Native.Some - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App (head1, (t, (if i then - FStar_Reflection_V2_Data.Q_Implicit + FStarC_Reflection_V2_Data.Q_Implicit else - FStar_Reflection_V2_Data.Q_Explicit))))), + FStarC_Reflection_V2_Data.Q_Explicit))))), bs')))) - | (FStar_Reflection_V2_Data.Pat_Var (uu___, uu___1), b::bs1) -> + | (FStarC_Reflection_V2_Data.Pat_Var (uu___, uu___1), b::bs1) -> FStar_Pervasives_Native.Some - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Var (binding_to_namedv b))), + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Var (binding_to_namedv b))), bs1) - | (FStar_Reflection_V2_Data.Pat_Dot_Term (FStar_Pervasives_Native.Some + | (FStarC_Reflection_V2_Data.Pat_Dot_Term (FStar_Pervasives_Native.Some t), uu___) -> FStar_Pervasives_Native.Some (t, bs) - | (FStar_Reflection_V2_Data.Pat_Dot_Term + | (FStarC_Reflection_V2_Data.Pat_Dot_Term (FStar_Pervasives_Native.None), uu___) -> FStar_Pervasives_Native.None | uu___ -> FStar_Pervasives_Native.None type ('dummyV0, 'dummyV1, 'dummyV2) typing = - | T_Token of FStar_Reflection_Types.env * FStar_Reflection_Types.term * + | T_Token of FStarC_Reflection_Types.env * FStarC_Reflection_Types.term * comp_typ * unit - | T_Var of FStar_Reflection_Types.env * FStar_Reflection_Types.namedv - | T_FVar of FStar_Reflection_Types.env * FStar_Reflection_Types.fv - | T_UInst of FStar_Reflection_Types.env * FStar_Reflection_Types.fv * - FStar_Reflection_Types.universe Prims.list - | T_Const of FStar_Reflection_Types.env * FStar_Reflection_V2_Data.vconst * - FStar_Reflection_Types.term * (unit, unit) constant_typing - | T_Abs of FStar_Reflection_Types.env * FStar_Reflection_V2_Data.var * - FStar_Reflection_Types.term * FStar_Reflection_Types.term * comp_typ * - FStar_Reflection_Types.universe * pp_name_t * - FStar_Reflection_V2_Data.aqualv * FStar_TypeChecker_Core.tot_or_ghost * + | T_Var of FStarC_Reflection_Types.env * FStarC_Reflection_Types.namedv + | T_FVar of FStarC_Reflection_Types.env * FStarC_Reflection_Types.fv + | T_UInst of FStarC_Reflection_Types.env * FStarC_Reflection_Types.fv * + FStarC_Reflection_Types.universe Prims.list + | T_Const of FStarC_Reflection_Types.env * FStarC_Reflection_V2_Data.vconst + * FStarC_Reflection_Types.term * (unit, unit) constant_typing + | T_Abs of FStarC_Reflection_Types.env * FStarC_Reflection_V2_Data.var * + FStarC_Reflection_Types.term * FStarC_Reflection_Types.term * comp_typ * + FStarC_Reflection_Types.universe * pp_name_t * + FStarC_Reflection_V2_Data.aqualv * FStarC_TypeChecker_Core.tot_or_ghost * (unit, unit, unit) typing * (unit, unit, unit) typing - | T_App of FStar_Reflection_Types.env * FStar_Reflection_Types.term * - FStar_Reflection_Types.term * FStar_Reflection_Types.binder * - FStar_Reflection_Types.term * FStar_TypeChecker_Core.tot_or_ghost * ( - unit, unit, unit) typing * (unit, unit, unit) typing - | T_Let of FStar_Reflection_Types.env * FStar_Reflection_V2_Data.var * - FStar_Reflection_Types.term * FStar_Reflection_Types.typ * - FStar_Reflection_Types.term * FStar_Reflection_Types.typ * - FStar_TypeChecker_Core.tot_or_ghost * pp_name_t * (unit, unit, unit) typing - * (unit, unit, unit) typing - | T_Arrow of FStar_Reflection_Types.env * FStar_Reflection_V2_Data.var * - FStar_Reflection_Types.term * FStar_Reflection_Types.term * - FStar_Reflection_Types.universe * FStar_Reflection_Types.universe * - pp_name_t * FStar_Reflection_V2_Data.aqualv * - FStar_TypeChecker_Core.tot_or_ghost * FStar_TypeChecker_Core.tot_or_ghost * - FStar_TypeChecker_Core.tot_or_ghost * (unit, unit, unit) typing * ( - unit, unit, unit) typing - | T_Refine of FStar_Reflection_Types.env * FStar_Reflection_V2_Data.var * - FStar_Reflection_Types.term * FStar_Reflection_Types.term * - FStar_Reflection_Types.universe * FStar_Reflection_Types.universe * - FStar_TypeChecker_Core.tot_or_ghost * FStar_TypeChecker_Core.tot_or_ghost * + | T_App of FStarC_Reflection_Types.env * FStarC_Reflection_Types.term * + FStarC_Reflection_Types.term * FStarC_Reflection_Types.binder * + FStarC_Reflection_Types.term * FStarC_TypeChecker_Core.tot_or_ghost * (unit, unit, unit) typing * (unit, unit, unit) typing - | T_PropIrrelevance of FStar_Reflection_Types.env * - FStar_Reflection_Types.term * FStar_Reflection_Types.term * - FStar_TypeChecker_Core.tot_or_ghost * FStar_TypeChecker_Core.tot_or_ghost * - (unit, unit, unit) typing * (unit, unit, unit) typing - | T_Sub of FStar_Reflection_Types.env * FStar_Reflection_Types.term * + | T_Let of FStarC_Reflection_Types.env * FStarC_Reflection_V2_Data.var * + FStarC_Reflection_Types.term * FStarC_Reflection_Types.typ * + FStarC_Reflection_Types.term * FStarC_Reflection_Types.typ * + FStarC_TypeChecker_Core.tot_or_ghost * pp_name_t * (unit, unit, unit) + typing * (unit, unit, unit) typing + | T_Arrow of FStarC_Reflection_Types.env * FStarC_Reflection_V2_Data.var * + FStarC_Reflection_Types.term * FStarC_Reflection_Types.term * + FStarC_Reflection_Types.universe * FStarC_Reflection_Types.universe * + pp_name_t * FStarC_Reflection_V2_Data.aqualv * + FStarC_TypeChecker_Core.tot_or_ghost * FStarC_TypeChecker_Core.tot_or_ghost + * FStarC_TypeChecker_Core.tot_or_ghost * (unit, unit, unit) typing * ( + unit, unit, unit) typing + | T_Refine of FStarC_Reflection_Types.env * FStarC_Reflection_V2_Data.var * + FStarC_Reflection_Types.term * FStarC_Reflection_Types.term * + FStarC_Reflection_Types.universe * FStarC_Reflection_Types.universe * + FStarC_TypeChecker_Core.tot_or_ghost * FStarC_TypeChecker_Core.tot_or_ghost + * (unit, unit, unit) typing * (unit, unit, unit) typing + | T_PropIrrelevance of FStarC_Reflection_Types.env * + FStarC_Reflection_Types.term * FStarC_Reflection_Types.term * + FStarC_TypeChecker_Core.tot_or_ghost * FStarC_TypeChecker_Core.tot_or_ghost + * (unit, unit, unit) typing * (unit, unit, unit) typing + | T_Sub of FStarC_Reflection_Types.env * FStarC_Reflection_Types.term * comp_typ * comp_typ * (unit, unit, unit) typing * (unit, unit, unit, unit) related_comp - | T_If of FStar_Reflection_Types.env * FStar_Reflection_Types.term * - FStar_Reflection_Types.term * FStar_Reflection_Types.term * - FStar_Reflection_Types.term * FStar_Reflection_Types.universe * - FStar_Reflection_V2_Data.var * FStar_TypeChecker_Core.tot_or_ghost * - FStar_TypeChecker_Core.tot_or_ghost * (unit, unit, unit) typing * ( + | T_If of FStarC_Reflection_Types.env * FStarC_Reflection_Types.term * + FStarC_Reflection_Types.term * FStarC_Reflection_Types.term * + FStarC_Reflection_Types.term * FStarC_Reflection_Types.universe * + FStarC_Reflection_V2_Data.var * FStarC_TypeChecker_Core.tot_or_ghost * + FStarC_TypeChecker_Core.tot_or_ghost * (unit, unit, unit) typing * ( unit, unit, unit) typing * (unit, unit, unit) typing * (unit, unit, unit) typing - | T_Match of FStar_Reflection_Types.env * FStar_Reflection_Types.universe * - FStar_Reflection_Types.typ * FStar_Reflection_Types.term * - FStar_TypeChecker_Core.tot_or_ghost * (unit, unit, unit) typing * - FStar_TypeChecker_Core.tot_or_ghost * (unit, unit, unit) typing * - FStar_Reflection_V2_Data.branch Prims.list * comp_typ * - FStar_Reflection_V2_Data.binding Prims.list Prims.list * (unit, unit, + | T_Match of FStarC_Reflection_Types.env * FStarC_Reflection_Types.universe + * FStarC_Reflection_Types.typ * FStarC_Reflection_Types.term * + FStarC_TypeChecker_Core.tot_or_ghost * (unit, unit, unit) typing * + FStarC_TypeChecker_Core.tot_or_ghost * (unit, unit, unit) typing * + FStarC_Reflection_V2_Data.branch Prims.list * comp_typ * + FStarC_Reflection_V2_Data.binding Prims.list Prims.list * (unit, unit, unit, unit, unit) match_is_complete * (unit, unit, unit, unit, unit, unit, unit) branches_typing and ('dummyV0, 'dummyV1, 'dummyV2, 'dummyV3) related = - | Rel_refl of FStar_Reflection_Types.env * FStar_Reflection_Types.term * + | Rel_refl of FStarC_Reflection_Types.env * FStarC_Reflection_Types.term * relation - | Rel_sym of FStar_Reflection_Types.env * FStar_Reflection_Types.term * - FStar_Reflection_Types.term * (unit, unit, unit, unit) related - | Rel_trans of FStar_Reflection_Types.env * FStar_Reflection_Types.term * - FStar_Reflection_Types.term * FStar_Reflection_Types.term * relation * + | Rel_sym of FStarC_Reflection_Types.env * FStarC_Reflection_Types.term * + FStarC_Reflection_Types.term * (unit, unit, unit, unit) related + | Rel_trans of FStarC_Reflection_Types.env * FStarC_Reflection_Types.term * + FStarC_Reflection_Types.term * FStarC_Reflection_Types.term * relation * (unit, unit, unit, unit) related * (unit, unit, unit, unit) related - | Rel_univ of FStar_Reflection_Types.env * FStar_Reflection_Types.universe - * FStar_Reflection_Types.universe * (unit, unit) univ_eq - | Rel_beta of FStar_Reflection_Types.env * FStar_Reflection_Types.typ * - FStar_Reflection_V2_Data.aqualv * FStar_Reflection_Types.term * - FStar_Reflection_Types.term - | Rel_eq_token of FStar_Reflection_Types.env * FStar_Reflection_Types.term - * FStar_Reflection_Types.term * unit - | Rel_subtyping_token of FStar_Reflection_Types.env * - FStar_Reflection_Types.term * FStar_Reflection_Types.term * unit - | Rel_equiv of FStar_Reflection_Types.env * FStar_Reflection_Types.term * - FStar_Reflection_Types.term * relation * (unit, unit, unit, unit) related - | Rel_arrow of FStar_Reflection_Types.env * FStar_Reflection_Types.term * - FStar_Reflection_Types.term * FStar_Reflection_V2_Data.aqualv * comp_typ * - comp_typ * relation * FStar_Reflection_V2_Data.var * (unit, unit, unit, - unit) related * (unit, unit, unit, unit) related_comp - | Rel_abs of FStar_Reflection_Types.env * FStar_Reflection_Types.term * - FStar_Reflection_Types.term * FStar_Reflection_V2_Data.aqualv * - FStar_Reflection_Types.term * FStar_Reflection_Types.term * - FStar_Reflection_V2_Data.var * (unit, unit, unit, unit) related * ( + | Rel_univ of FStarC_Reflection_Types.env * + FStarC_Reflection_Types.universe * FStarC_Reflection_Types.universe * + (unit, unit) univ_eq + | Rel_beta of FStarC_Reflection_Types.env * FStarC_Reflection_Types.typ * + FStarC_Reflection_V2_Data.aqualv * FStarC_Reflection_Types.term * + FStarC_Reflection_Types.term + | Rel_eq_token of FStarC_Reflection_Types.env * + FStarC_Reflection_Types.term * FStarC_Reflection_Types.term * unit + | Rel_subtyping_token of FStarC_Reflection_Types.env * + FStarC_Reflection_Types.term * FStarC_Reflection_Types.term * unit + | Rel_equiv of FStarC_Reflection_Types.env * FStarC_Reflection_Types.term * + FStarC_Reflection_Types.term * relation * (unit, unit, unit, unit) related + + | Rel_arrow of FStarC_Reflection_Types.env * FStarC_Reflection_Types.term * + FStarC_Reflection_Types.term * FStarC_Reflection_V2_Data.aqualv * comp_typ + * comp_typ * relation * FStarC_Reflection_V2_Data.var * (unit, unit, + unit, unit) related * (unit, unit, unit, unit) related_comp + | Rel_abs of FStarC_Reflection_Types.env * FStarC_Reflection_Types.term * + FStarC_Reflection_Types.term * FStarC_Reflection_V2_Data.aqualv * + FStarC_Reflection_Types.term * FStarC_Reflection_Types.term * + FStarC_Reflection_V2_Data.var * (unit, unit, unit, unit) related * ( unit, unit, unit, unit) related - | Rel_ctxt of FStar_Reflection_Types.env * FStar_Reflection_Types.term * - FStar_Reflection_Types.term * term_ctxt * (unit, unit, unit, unit) related + | Rel_ctxt of FStarC_Reflection_Types.env * FStarC_Reflection_Types.term * + FStarC_Reflection_Types.term * term_ctxt * (unit, unit, unit, unit) related and ('dummyV0, 'dummyV1, 'dummyV2, 'dummyV3) related_comp = - | Relc_typ of FStar_Reflection_Types.env * FStar_Reflection_Types.term * - FStar_Reflection_Types.term * FStar_TypeChecker_Core.tot_or_ghost * + | Relc_typ of FStarC_Reflection_Types.env * FStarC_Reflection_Types.term * + FStarC_Reflection_Types.term * FStarC_TypeChecker_Core.tot_or_ghost * relation * (unit, unit, unit, unit) related - | Relc_total_ghost of FStar_Reflection_Types.env * - FStar_Reflection_Types.term - | Relc_ghost_total of FStar_Reflection_Types.env * - FStar_Reflection_Types.term * (unit, unit) non_informative + | Relc_total_ghost of FStarC_Reflection_Types.env * + FStarC_Reflection_Types.term + | Relc_ghost_total of FStarC_Reflection_Types.env * + FStarC_Reflection_Types.term * (unit, unit) non_informative and ('g, 'scuu, 'scuty, 'sc, 'rty, 'dummyV0, 'dummyV1) branches_typing = | BT_Nil - | BT_S of FStar_Reflection_V2_Data.branch * - FStar_Reflection_V2_Data.binding Prims.list * (unit, unit, unit, unit, - unit, unit, unit) branch_typing * FStar_Reflection_V2_Data.branch - Prims.list * FStar_Reflection_V2_Data.binding Prims.list Prims.list * + | BT_S of FStarC_Reflection_V2_Data.branch * + FStarC_Reflection_V2_Data.binding Prims.list * (unit, unit, unit, unit, + unit, unit, unit) branch_typing * FStarC_Reflection_V2_Data.branch + Prims.list * FStarC_Reflection_V2_Data.binding Prims.list Prims.list * (unit, unit, unit, unit, unit, unit, unit) branches_typing and ('g, 'scuu, 'scuty, 'sc, 'rty, 'dummyV0, 'dummyV1) branch_typing = - | BO of FStar_Reflection_V2_Data.pattern * FStar_Reflection_V2_Data.binding - Prims.list * FStar_Reflection_V2_Data.var * FStar_Reflection_Types.term * - unit * (unit, unit, unit) typing + | BO of FStarC_Reflection_V2_Data.pattern * + FStarC_Reflection_V2_Data.binding Prims.list * + FStarC_Reflection_V2_Data.var * FStarC_Reflection_Types.term * unit * + (unit, unit, unit) typing and ('dummyV0, 'dummyV1, 'dummyV2, 'dummyV3, 'dummyV4) match_is_complete = - | MC_Tok of FStar_Reflection_Types.env * FStar_Reflection_Types.term * - FStar_Reflection_Types.typ * FStar_Reflection_V2_Data.pattern Prims.list * - FStar_Reflection_V2_Data.binding Prims.list Prims.list * unit + | MC_Tok of FStarC_Reflection_Types.env * FStarC_Reflection_Types.term * + FStarC_Reflection_Types.typ * FStarC_Reflection_V2_Data.pattern Prims.list + * FStarC_Reflection_V2_Data.binding Prims.list Prims.list * unit let uu___is_T_Token uu___2 uu___1 uu___ uu___3 = match uu___3 with | T_Token _ -> true | _ -> false let uu___is_T_Var uu___2 uu___1 uu___ uu___3 = @@ -1468,16 +1489,16 @@ type ('g, 't1, 't2) equiv = (unit, unit, unit, unit) related type ('g, 'e, 't) tot_typing = (unit, unit, unit) typing type ('g, 'e, 't) ghost_typing = (unit, unit, unit) typing let (subtyping_token_renaming : - FStar_Reflection_Types.env -> + FStarC_Reflection_Types.env -> bindings -> bindings -> - FStar_Reflection_V2_Data.var -> - FStar_Reflection_V2_Data.var -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> - (unit, unit, unit) FStar_Tactics_Types.subtyping_token -> - (unit, unit, unit) FStar_Tactics_Types.subtyping_token) + FStarC_Reflection_V2_Data.var -> + FStarC_Reflection_V2_Data.var -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> + (unit, unit, unit) FStarC_Tactics_Types.subtyping_token -> + (unit, unit, unit) FStarC_Tactics_Types.subtyping_token) = fun g -> fun bs0 -> @@ -1485,24 +1506,24 @@ let (subtyping_token_renaming : fun x -> fun y -> fun t -> fun t0 -> fun t1 -> fun d -> Prims.magic () let (subtyping_token_weakening : - FStar_Reflection_Types.env -> + FStarC_Reflection_Types.env -> bindings -> bindings -> - FStar_Reflection_V2_Data.var -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> - (unit, unit, unit) FStar_Tactics_Types.subtyping_token -> - (unit, unit, unit) FStar_Tactics_Types.subtyping_token) + FStarC_Reflection_V2_Data.var -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> + (unit, unit, unit) FStarC_Tactics_Types.subtyping_token -> + (unit, unit, unit) FStarC_Tactics_Types.subtyping_token) = fun g -> fun bs0 -> fun bs1 -> fun x -> fun t -> fun t0 -> fun t1 -> fun d -> Prims.magic () let (simplify_umax : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.universe -> + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.universe -> (unit, unit, unit) typing -> (unit, unit, unit) typing) = fun g -> @@ -1514,18 +1535,18 @@ let (simplify_umax : let du1 = Rel_equiv (g, (tm_type (u_max u u)), (tm_type u), R_Sub, du) in T_Sub - (g, t, (FStar_TypeChecker_Core.E_Total, (tm_type (u_max u u))), - (FStar_TypeChecker_Core.E_Total, (tm_type u)), d, + (g, t, (FStarC_TypeChecker_Core.E_Total, (tm_type (u_max u u))), + (FStarC_TypeChecker_Core.E_Total, (tm_type u)), d, (Relc_typ (g, (tm_type (u_max u u)), (tm_type u), - FStar_TypeChecker_Core.E_Total, R_Sub, du1))) + FStarC_TypeChecker_Core.E_Total, R_Sub, du1))) let (equiv_arrow : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.typ -> - FStar_Reflection_V2_Data.aqualv -> - FStar_Reflection_V2_Data.var -> + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.typ -> + FStarC_Reflection_V2_Data.aqualv -> + FStarC_Reflection_V2_Data.var -> (unit, unit, unit) equiv -> (unit, unit, unit) equiv) = fun g -> @@ -1535,8 +1556,8 @@ let (equiv_arrow : fun q -> fun x -> fun eq -> - let c1 = (FStar_TypeChecker_Core.E_Total, e1) in - let c2 = (FStar_TypeChecker_Core.E_Total, e2) in + let c1 = (FStarC_TypeChecker_Core.E_Total, e1) in + let c2 = (FStarC_TypeChecker_Core.E_Total, e2) in Rel_arrow (g, ty, ty, q, c1, c2, R_Eq, x, (Rel_refl (g, ty, R_Eq)), (Relc_typ @@ -1545,12 +1566,12 @@ let (equiv_arrow : (subst_term e2 (open_with_var x Prims.int_zero)), (FStar_Pervasives_Native.fst c1), R_Eq, eq))) let (equiv_abs_close : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.typ -> - FStar_Reflection_V2_Data.aqualv -> - FStar_Reflection_V2_Data.var -> + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.typ -> + FStarC_Reflection_V2_Data.aqualv -> + FStarC_Reflection_V2_Data.var -> (unit, unit, unit) equiv -> (unit, unit, unit) equiv) = fun g -> @@ -1566,16 +1587,17 @@ let (equiv_abs_close : (subst_term e2 [ND (x, Prims.int_zero)]), x, (Rel_refl (g, ty, R_Eq)), eq1) type 'g fstar_env_fvs = unit -type fstar_env = FStar_Reflection_Types.env +type fstar_env = FStarC_Reflection_Types.env type fstar_top_env = fstar_env type ('dummyV0, 'dummyV1) sigelt_typing = - | ST_Let of FStar_Reflection_Types.env * FStar_Reflection_Types.fv * - FStar_Reflection_Types.typ * FStar_Reflection_Types.term * unit - | ST_Let_Opaque of FStar_Reflection_Types.env * FStar_Reflection_Types.fv * - FStar_Reflection_Types.typ * unit + | ST_Let of FStarC_Reflection_Types.env * FStarC_Reflection_Types.fv * + FStarC_Reflection_Types.typ * FStarC_Reflection_Types.term * unit + | ST_Let_Opaque of FStarC_Reflection_Types.env * FStarC_Reflection_Types.fv + * FStarC_Reflection_Types.typ * unit let (uu___is_ST_Let : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.sigelt -> (unit, unit) sigelt_typing -> Prims.bool) + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.sigelt -> + (unit, unit) sigelt_typing -> Prims.bool) = fun uu___ -> fun uu___1 -> @@ -1584,43 +1606,44 @@ let (uu___is_ST_Let : | ST_Let (g, fv, ty, tm, _4) -> true | uu___2 -> false let (__proj__ST_Let__item__g : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.sigelt -> - (unit, unit) sigelt_typing -> FStar_Reflection_Types.env) + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.sigelt -> + (unit, unit) sigelt_typing -> FStarC_Reflection_Types.env) = fun uu___ -> fun uu___1 -> fun projectee -> match projectee with | ST_Let (g, fv, ty, tm, _4) -> g let (__proj__ST_Let__item__fv : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.sigelt -> - (unit, unit) sigelt_typing -> FStar_Reflection_Types.fv) + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.sigelt -> + (unit, unit) sigelt_typing -> FStarC_Reflection_Types.fv) = fun uu___ -> fun uu___1 -> fun projectee -> match projectee with | ST_Let (g, fv, ty, tm, _4) -> fv let (__proj__ST_Let__item__ty : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.sigelt -> - (unit, unit) sigelt_typing -> FStar_Reflection_Types.typ) + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.sigelt -> + (unit, unit) sigelt_typing -> FStarC_Reflection_Types.typ) = fun uu___ -> fun uu___1 -> fun projectee -> match projectee with | ST_Let (g, fv, ty, tm, _4) -> ty let (__proj__ST_Let__item__tm : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.sigelt -> - (unit, unit) sigelt_typing -> FStar_Reflection_Types.term) + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.sigelt -> + (unit, unit) sigelt_typing -> FStarC_Reflection_Types.term) = fun uu___ -> fun uu___1 -> fun projectee -> match projectee with | ST_Let (g, fv, ty, tm, _4) -> tm let (uu___is_ST_Let_Opaque : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.sigelt -> (unit, unit) sigelt_typing -> Prims.bool) + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.sigelt -> + (unit, unit) sigelt_typing -> Prims.bool) = fun uu___ -> fun uu___1 -> @@ -1629,59 +1652,60 @@ let (uu___is_ST_Let_Opaque : | ST_Let_Opaque (g, fv, ty, _3) -> true | uu___2 -> false let (__proj__ST_Let_Opaque__item__g : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.sigelt -> - (unit, unit) sigelt_typing -> FStar_Reflection_Types.env) + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.sigelt -> + (unit, unit) sigelt_typing -> FStarC_Reflection_Types.env) = fun uu___ -> fun uu___1 -> fun projectee -> match projectee with | ST_Let_Opaque (g, fv, ty, _3) -> g let (__proj__ST_Let_Opaque__item__fv : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.sigelt -> - (unit, unit) sigelt_typing -> FStar_Reflection_Types.fv) + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.sigelt -> + (unit, unit) sigelt_typing -> FStarC_Reflection_Types.fv) = fun uu___ -> fun uu___1 -> fun projectee -> match projectee with | ST_Let_Opaque (g, fv, ty, _3) -> fv let (__proj__ST_Let_Opaque__item__ty : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.sigelt -> - (unit, unit) sigelt_typing -> FStar_Reflection_Types.typ) + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.sigelt -> + (unit, unit) sigelt_typing -> FStarC_Reflection_Types.typ) = fun uu___ -> fun uu___1 -> fun projectee -> match projectee with | ST_Let_Opaque (g, fv, ty, _3) -> ty -type blob = (Prims.string * FStar_Reflection_Types.term) +type blob = (Prims.string * FStarC_Reflection_Types.term) type ('s, 't) sigelt_has_type = Obj.t type ('g, 't) sigelt_for = - (Prims.bool * FStar_Reflection_Types.sigelt * blob + (Prims.bool * FStarC_Reflection_Types.sigelt * blob FStar_Pervasives_Native.option) type ('g, 't) dsl_tac_result_t = ((unit, unit) sigelt_for Prims.list * (unit, unit) sigelt_for * (unit, unit) sigelt_for Prims.list) type dsl_tac_t = - (fstar_top_env * FStar_Reflection_Types.typ FStar_Pervasives_Native.option) - -> ((unit, unit) dsl_tac_result_t, unit) FStar_Tactics_Effect.tac_repr + (fstar_top_env * FStarC_Reflection_Types.typ + FStar_Pervasives_Native.option) -> + ((unit, unit) dsl_tac_result_t, unit) FStar_Tactics_Effect.tac_repr let (if_complete_match : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.term -> (unit, unit, unit, unit, unit) - FStar_Tactics_V2_Builtins.match_complete_token) + FStarC_Tactics_V2_Builtins.match_complete_token) = fun g -> fun t -> Prims.magic () let (mkif : fstar_env -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.universe -> - FStar_Reflection_V2_Data.var -> - FStar_TypeChecker_Core.tot_or_ghost -> - FStar_TypeChecker_Core.tot_or_ghost -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.universe -> + FStarC_Reflection_V2_Data.var -> + FStarC_TypeChecker_Core.tot_or_ghost -> + FStarC_TypeChecker_Core.tot_or_ghost -> (unit, unit, unit) typing -> (unit, unit, unit) typing -> (unit, unit, unit) typing -> @@ -1702,35 +1726,35 @@ let (mkif : fun te -> fun tr -> let brt = - ((FStar_Reflection_V2_Data.Pat_Constant - FStar_Reflection_V2_Data.C_True), then_) in + ((FStarC_Reflection_V2_Data.Pat_Constant + FStarC_Reflection_V2_Data.C_True), then_) in let bre = - ((FStar_Reflection_V2_Data.Pat_Constant - FStar_Reflection_V2_Data.C_False), else_) in + ((FStarC_Reflection_V2_Data.Pat_Constant + FStarC_Reflection_V2_Data.C_False), else_) in let brty uu___ = BT_S - (((FStar_Reflection_V2_Data.Pat_Constant - FStar_Reflection_V2_Data.C_True), then_), - [], + (((FStarC_Reflection_V2_Data.Pat_Constant + FStarC_Reflection_V2_Data.C_True), + then_), [], (BO - ((FStar_Reflection_V2_Data.Pat_Constant - FStar_Reflection_V2_Data.C_True), + ((FStarC_Reflection_V2_Data.Pat_Constant + FStarC_Reflection_V2_Data.C_True), [], hyp, then_, (), tt)), - [((FStar_Reflection_V2_Data.Pat_Constant - FStar_Reflection_V2_Data.C_False), + [((FStarC_Reflection_V2_Data.Pat_Constant + FStarC_Reflection_V2_Data.C_False), else_)], [[]], (BT_S - (((FStar_Reflection_V2_Data.Pat_Constant - FStar_Reflection_V2_Data.C_False), + (((FStarC_Reflection_V2_Data.Pat_Constant + FStarC_Reflection_V2_Data.C_False), else_), [], (BO - ((FStar_Reflection_V2_Data.Pat_Constant - FStar_Reflection_V2_Data.C_False), + ((FStarC_Reflection_V2_Data.Pat_Constant + FStarC_Reflection_V2_Data.C_False), [], hyp, else_, (), te)), [], [], BT_Nil))) in T_Match (g, u_zero, bool_ty, scrutinee, - FStar_TypeChecker_Core.E_Total, + FStarC_TypeChecker_Core.E_Total, (T_FVar (g, bool_fv)), eff, ts, [brt; bre], (eff, ty), [[]; []], (MC_Tok @@ -1740,11 +1764,11 @@ let (mkif : [brt; bre]), [[]; []], ())), (brty ())) let (mk_checked_let : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.name -> + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.name -> Prims.string -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.typ -> (unit, unit) sigelt_for) + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.typ -> (unit, unit) sigelt_for) = fun g -> fun cur_module -> @@ -1752,28 +1776,28 @@ let (mk_checked_let : fun tm -> fun ty -> let fv = - FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_fv (FStar_List_Tot_Base.op_At cur_module [nm]) in let lb = - FStar_Reflection_V2_Builtins.pack_lb + FStarC_Reflection_V2_Builtins.pack_lb { - FStar_Reflection_V2_Data.lb_fv = fv; - FStar_Reflection_V2_Data.lb_us = []; - FStar_Reflection_V2_Data.lb_typ = ty; - FStar_Reflection_V2_Data.lb_def = tm + FStarC_Reflection_V2_Data.lb_fv = fv; + FStarC_Reflection_V2_Data.lb_us = []; + FStarC_Reflection_V2_Data.lb_typ = ty; + FStarC_Reflection_V2_Data.lb_def = tm } in let se = - FStar_Reflection_V2_Builtins.pack_sigelt - (FStar_Reflection_V2_Data.Sg_Let (false, [lb])) in + FStarC_Reflection_V2_Builtins.pack_sigelt + (FStarC_Reflection_V2_Data.Sg_Let (false, [lb])) in let pf = ST_Let (g, fv, ty, tm, ()) in (true, se, FStar_Pervasives_Native.None) let (mk_unchecked_let : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.name -> + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.name -> Prims.string -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.typ -> - (Prims.bool * FStar_Reflection_Types.sigelt * blob + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.typ -> + (Prims.bool * FStarC_Reflection_Types.sigelt * blob FStar_Pervasives_Native.option)) = fun g -> @@ -1782,24 +1806,24 @@ let (mk_unchecked_let : fun tm -> fun ty -> let fv = - FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_fv (FStar_List_Tot_Base.op_At cur_module [nm]) in let lb = - FStar_Reflection_V2_Builtins.pack_lb + FStarC_Reflection_V2_Builtins.pack_lb { - FStar_Reflection_V2_Data.lb_fv = fv; - FStar_Reflection_V2_Data.lb_us = []; - FStar_Reflection_V2_Data.lb_typ = ty; - FStar_Reflection_V2_Data.lb_def = tm + FStarC_Reflection_V2_Data.lb_fv = fv; + FStarC_Reflection_V2_Data.lb_us = []; + FStarC_Reflection_V2_Data.lb_typ = ty; + FStarC_Reflection_V2_Data.lb_def = tm } in let se = - FStar_Reflection_V2_Builtins.pack_sigelt - (FStar_Reflection_V2_Data.Sg_Let (false, [lb])) in + FStarC_Reflection_V2_Builtins.pack_sigelt + (FStarC_Reflection_V2_Data.Sg_Let (false, [lb])) in (false, se, FStar_Pervasives_Native.None) let (typing_to_token : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.term -> comp_typ -> (unit, unit, unit) typing -> - (unit, unit, unit) FStar_Tactics_Types.typing_token) + (unit, unit, unit) FStarC_Tactics_Types.typing_token) = fun g -> fun e -> fun c -> fun uu___ -> Prims.magic () \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Reflection_V1_Builtins.ml b/ocaml/fstar-lib/generated/FStar_Reflection_V1_Builtins.ml deleted file mode 100644 index 7c09ce98992..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Reflection_V1_Builtins.ml +++ /dev/null @@ -1,1519 +0,0 @@ -open Prims -let (get_env : unit -> FStar_TypeChecker_Env.env) = - fun uu___ -> - let uu___1 = - FStar_Compiler_Effect.op_Bang - FStar_TypeChecker_Normalize.reflection_env_hook in - match uu___1 with - | FStar_Pervasives_Native.None -> - failwith "impossible: env_hook unset in reflection" - | FStar_Pervasives_Native.Some e -> e -let (inspect_bqual : - FStar_Syntax_Syntax.bqual -> FStar_Reflection_V1_Data.aqualv) = - fun bq -> - match bq with - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit uu___) -> - FStar_Reflection_V1_Data.Q_Implicit - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta t) -> - FStar_Reflection_V1_Data.Q_Meta t - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Equality) -> - FStar_Reflection_V1_Data.Q_Explicit - | FStar_Pervasives_Native.None -> FStar_Reflection_V1_Data.Q_Explicit -let (inspect_aqual : - FStar_Syntax_Syntax.aqual -> FStar_Reflection_V1_Data.aqualv) = - fun aq -> - match aq with - | FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = uu___;_} - -> FStar_Reflection_V1_Data.Q_Implicit - | uu___ -> FStar_Reflection_V1_Data.Q_Explicit -let (pack_bqual : - FStar_Reflection_V1_Data.aqualv -> FStar_Syntax_Syntax.bqual) = - fun aqv -> - match aqv with - | FStar_Reflection_V1_Data.Q_Explicit -> FStar_Pervasives_Native.None - | FStar_Reflection_V1_Data.Q_Implicit -> - FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit false) - | FStar_Reflection_V1_Data.Q_Meta t -> - FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta t) -let (pack_aqual : - FStar_Reflection_V1_Data.aqualv -> FStar_Syntax_Syntax.aqual) = - fun aqv -> - match aqv with - | FStar_Reflection_V1_Data.Q_Implicit -> - FStar_Syntax_Syntax.as_aqual_implicit true - | uu___ -> FStar_Pervasives_Native.None -let (inspect_fv : FStar_Syntax_Syntax.fv -> Prims.string Prims.list) = - fun fv -> - let uu___ = FStar_Syntax_Syntax.lid_of_fv fv in - FStar_Ident.path_of_lid uu___ -let (pack_fv : Prims.string Prims.list -> FStar_Syntax_Syntax.fv) = - fun ns -> - let lid = FStar_Parser_Const.p2l ns in - let fallback uu___ = - let quals = - let uu___1 = FStar_Ident.lid_equals lid FStar_Parser_Const.cons_lid in - if uu___1 - then FStar_Pervasives_Native.Some FStar_Syntax_Syntax.Data_ctor - else - (let uu___3 = FStar_Ident.lid_equals lid FStar_Parser_Const.nil_lid in - if uu___3 - then FStar_Pervasives_Native.Some FStar_Syntax_Syntax.Data_ctor - else - (let uu___5 = - FStar_Ident.lid_equals lid FStar_Parser_Const.some_lid in - if uu___5 - then FStar_Pervasives_Native.Some FStar_Syntax_Syntax.Data_ctor - else - (let uu___7 = - FStar_Ident.lid_equals lid FStar_Parser_Const.none_lid in - if uu___7 - then - FStar_Pervasives_Native.Some FStar_Syntax_Syntax.Data_ctor - else FStar_Pervasives_Native.None))) in - let uu___1 = FStar_Parser_Const.p2l ns in - FStar_Syntax_Syntax.lid_as_fv uu___1 quals in - let uu___ = - FStar_Compiler_Effect.op_Bang - FStar_TypeChecker_Normalize.reflection_env_hook in - match uu___ with - | FStar_Pervasives_Native.None -> fallback () - | FStar_Pervasives_Native.Some env -> - let qninfo = FStar_TypeChecker_Env.lookup_qname env lid in - (match qninfo with - | FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr (se, _us), _rng) -> - let quals = FStar_Syntax_DsEnv.fv_qual_of_se se in - let uu___1 = FStar_Parser_Const.p2l ns in - FStar_Syntax_Syntax.lid_as_fv uu___1 quals - | uu___1 -> fallback ()) -let rec last : 'a . 'a Prims.list -> 'a = - fun l -> - match l with - | [] -> failwith "last: empty list" - | x::[] -> x - | uu___::xs -> last xs -let rec init : 'a . 'a Prims.list -> 'a Prims.list = - fun l -> - match l with - | [] -> failwith "init: empty list" - | x::[] -> [] - | x::xs -> let uu___ = init xs in x :: uu___ -let (inspect_const : - FStar_Syntax_Syntax.sconst -> FStar_Reflection_V1_Data.vconst) = - fun c -> - match c with - | FStar_Const.Const_unit -> FStar_Reflection_V1_Data.C_Unit - | FStar_Const.Const_int (s, uu___) -> - let uu___1 = FStar_BigInt.big_int_of_string s in - FStar_Reflection_V1_Data.C_Int uu___1 - | FStar_Const.Const_bool (true) -> FStar_Reflection_V1_Data.C_True - | FStar_Const.Const_bool (false) -> FStar_Reflection_V1_Data.C_False - | FStar_Const.Const_string (s, uu___) -> - FStar_Reflection_V1_Data.C_String s - | FStar_Const.Const_range r -> FStar_Reflection_V1_Data.C_Range r - | FStar_Const.Const_reify uu___ -> FStar_Reflection_V1_Data.C_Reify - | FStar_Const.Const_reflect l -> - let uu___ = FStar_Ident.path_of_lid l in - FStar_Reflection_V1_Data.C_Reflect uu___ - | uu___ -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_const c in - FStar_Compiler_Util.format1 "unknown constant: %s" uu___2 in - failwith uu___1 -let (inspect_universe : - FStar_Syntax_Syntax.universe -> FStar_Reflection_V1_Data.universe_view) = - fun u -> - match u with - | FStar_Syntax_Syntax.U_zero -> FStar_Reflection_V1_Data.Uv_Zero - | FStar_Syntax_Syntax.U_succ u1 -> FStar_Reflection_V1_Data.Uv_Succ u1 - | FStar_Syntax_Syntax.U_max us -> FStar_Reflection_V1_Data.Uv_Max us - | FStar_Syntax_Syntax.U_bvar n -> - let uu___ = FStar_BigInt.of_int_fs n in - FStar_Reflection_V1_Data.Uv_BVar uu___ - | FStar_Syntax_Syntax.U_name i -> - let uu___ = - let uu___1 = FStar_Ident.string_of_id i in - let uu___2 = FStar_Ident.range_of_id i in (uu___1, uu___2) in - FStar_Reflection_V1_Data.Uv_Name uu___ - | FStar_Syntax_Syntax.U_unif u1 -> FStar_Reflection_V1_Data.Uv_Unif u1 - | FStar_Syntax_Syntax.U_unknown -> FStar_Reflection_V1_Data.Uv_Unk -let (pack_universe : - FStar_Reflection_V1_Data.universe_view -> FStar_Syntax_Syntax.universe) = - fun uv -> - match uv with - | FStar_Reflection_V1_Data.Uv_Zero -> FStar_Syntax_Syntax.U_zero - | FStar_Reflection_V1_Data.Uv_Succ u -> FStar_Syntax_Syntax.U_succ u - | FStar_Reflection_V1_Data.Uv_Max us -> FStar_Syntax_Syntax.U_max us - | FStar_Reflection_V1_Data.Uv_BVar n -> - let uu___ = FStar_BigInt.to_int_fs n in - FStar_Syntax_Syntax.U_bvar uu___ - | FStar_Reflection_V1_Data.Uv_Name i -> - let uu___ = FStar_Ident.mk_ident i in - FStar_Syntax_Syntax.U_name uu___ - | FStar_Reflection_V1_Data.Uv_Unif u -> FStar_Syntax_Syntax.U_unif u - | FStar_Reflection_V1_Data.Uv_Unk -> FStar_Syntax_Syntax.U_unknown -let rec (inspect_ln : - FStar_Syntax_Syntax.term -> FStar_Reflection_V1_Data.term_view) = - fun t -> - let t1 = FStar_Syntax_Subst.compress_subst t in - match t1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t2; FStar_Syntax_Syntax.meta = uu___;_} - -> inspect_ln t2 - | FStar_Syntax_Syntax.Tm_name bv -> FStar_Reflection_V1_Data.Tv_Var bv - | FStar_Syntax_Syntax.Tm_bvar bv -> FStar_Reflection_V1_Data.Tv_BVar bv - | FStar_Syntax_Syntax.Tm_fvar fv -> FStar_Reflection_V1_Data.Tv_FVar fv - | FStar_Syntax_Syntax.Tm_uinst (t2, us) -> - (match t2.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_fvar fv -> - FStar_Reflection_V1_Data.Tv_UInst (fv, us) - | uu___ -> - failwith "Reflection::inspect_ln: uinst for a non-fvar node") - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t2; - FStar_Syntax_Syntax.asc = (FStar_Pervasives.Inl ty, tacopt, eq); - FStar_Syntax_Syntax.eff_opt = uu___;_} - -> FStar_Reflection_V1_Data.Tv_AscribedT (t2, ty, tacopt, eq) - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t2; - FStar_Syntax_Syntax.asc = (FStar_Pervasives.Inr cty, tacopt, eq); - FStar_Syntax_Syntax.eff_opt = uu___;_} - -> FStar_Reflection_V1_Data.Tv_AscribedC (t2, cty, tacopt, eq) - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = uu___; FStar_Syntax_Syntax.args = [];_} -> - failwith "inspect_ln: empty arguments on Tm_app" - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = hd; FStar_Syntax_Syntax.args = args;_} -> - let uu___ = last args in - (match uu___ with - | (a, q) -> - let q' = inspect_aqual q in - let uu___1 = - let uu___2 = - let uu___3 = init args in FStar_Syntax_Util.mk_app hd uu___3 in - (uu___2, (a, q')) in - FStar_Reflection_V1_Data.Tv_App uu___1) - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = []; FStar_Syntax_Syntax.body = uu___; - FStar_Syntax_Syntax.rc_opt = uu___1;_} - -> failwith "inspect_ln: empty arguments on Tm_abs" - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = b::bs; FStar_Syntax_Syntax.body = t2; - FStar_Syntax_Syntax.rc_opt = k;_} - -> - let body = - match bs with - | [] -> t2 - | bs1 -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = bs1; - FStar_Syntax_Syntax.body = t2; - FStar_Syntax_Syntax.rc_opt = k - }) t2.FStar_Syntax_Syntax.pos in - FStar_Reflection_V1_Data.Tv_Abs (b, body) - | FStar_Syntax_Syntax.Tm_type u -> FStar_Reflection_V1_Data.Tv_Type u - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = []; FStar_Syntax_Syntax.comp = uu___;_} - -> failwith "inspect_ln: empty binders on arrow" - | FStar_Syntax_Syntax.Tm_arrow uu___ -> - let uu___1 = FStar_Syntax_Util.arrow_one_ln t1 in - (match uu___1 with - | FStar_Pervasives_Native.Some (b, c) -> - FStar_Reflection_V1_Data.Tv_Arrow (b, c) - | FStar_Pervasives_Native.None -> failwith "impossible") - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = bv; FStar_Syntax_Syntax.phi = t2;_} -> - FStar_Reflection_V1_Data.Tv_Refine - (bv, (bv.FStar_Syntax_Syntax.sort), t2) - | FStar_Syntax_Syntax.Tm_constant c -> - let uu___ = inspect_const c in - FStar_Reflection_V1_Data.Tv_Const uu___ - | FStar_Syntax_Syntax.Tm_uvar (ctx_u, s) -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Syntax_Unionfind.uvar_unique_id - ctx_u.FStar_Syntax_Syntax.ctx_uvar_head in - FStar_BigInt.of_int_fs uu___2 in - (uu___1, (ctx_u, s)) in - FStar_Reflection_V1_Data.Tv_Uvar uu___ - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (false, lb::[]); - FStar_Syntax_Syntax.body1 = t2;_} - -> - if lb.FStar_Syntax_Syntax.lbunivs <> [] - then FStar_Reflection_V1_Data.Tv_Unsupp - else - (match lb.FStar_Syntax_Syntax.lbname with - | FStar_Pervasives.Inr uu___1 -> - FStar_Reflection_V1_Data.Tv_Unsupp - | FStar_Pervasives.Inl bv -> - FStar_Reflection_V1_Data.Tv_Let - (false, (lb.FStar_Syntax_Syntax.lbattrs), bv, - (bv.FStar_Syntax_Syntax.sort), - (lb.FStar_Syntax_Syntax.lbdef), t2)) - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (true, lb::[]); - FStar_Syntax_Syntax.body1 = t2;_} - -> - if lb.FStar_Syntax_Syntax.lbunivs <> [] - then FStar_Reflection_V1_Data.Tv_Unsupp - else - (match lb.FStar_Syntax_Syntax.lbname with - | FStar_Pervasives.Inr uu___1 -> - FStar_Reflection_V1_Data.Tv_Unsupp - | FStar_Pervasives.Inl bv -> - FStar_Reflection_V1_Data.Tv_Let - (true, (lb.FStar_Syntax_Syntax.lbattrs), bv, - (bv.FStar_Syntax_Syntax.sort), - (lb.FStar_Syntax_Syntax.lbdef), t2)) - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = t2; - FStar_Syntax_Syntax.ret_opt = ret_opt; - FStar_Syntax_Syntax.brs = brs; - FStar_Syntax_Syntax.rc_opt1 = uu___;_} - -> - let rec inspect_pat p = - match p.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_constant c -> - let uu___1 = inspect_const c in - FStar_Reflection_V1_Data.Pat_Constant uu___1 - | FStar_Syntax_Syntax.Pat_cons (fv, us_opt, ps) -> - let uu___1 = - let uu___2 = - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with - | (p1, b) -> - let uu___4 = inspect_pat p1 in (uu___4, b)) ps in - (fv, us_opt, uu___2) in - FStar_Reflection_V1_Data.Pat_Cons uu___1 - | FStar_Syntax_Syntax.Pat_var bv -> - FStar_Reflection_V1_Data.Pat_Var - (bv, - (FStar_Compiler_Sealed.seal bv.FStar_Syntax_Syntax.sort)) - | FStar_Syntax_Syntax.Pat_dot_term eopt -> - FStar_Reflection_V1_Data.Pat_Dot_Term eopt in - let brs1 = - FStar_Compiler_List.map - (fun uu___1 -> - match uu___1 with - | (pat, uu___2, t3) -> - let uu___3 = inspect_pat pat in (uu___3, t3)) brs in - FStar_Reflection_V1_Data.Tv_Match (t2, ret_opt, brs1) - | FStar_Syntax_Syntax.Tm_unknown -> FStar_Reflection_V1_Data.Tv_Unknown - | FStar_Syntax_Syntax.Tm_lazy i -> - let uu___ = FStar_Syntax_Util.unfold_lazy i in inspect_ln uu___ - | uu___ -> - ((let uu___2 = - let uu___3 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t1 in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.format2 - "inspect_ln: outside of expected syntax (%s, %s)" uu___3 uu___4 in - FStar_Errors.log_issue (FStar_Syntax_Syntax.has_range_syntax ()) t1 - FStar_Errors_Codes.Warning_CantInspect () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Reflection_V1_Data.Tv_Unsupp) -let (inspect_comp : - FStar_Syntax_Syntax.comp -> FStar_Reflection_V1_Data.comp_view) = - fun c -> - let get_dec flags = - let uu___ = - FStar_Compiler_List.tryFind - (fun uu___1 -> - match uu___1 with - | FStar_Syntax_Syntax.DECREASES uu___2 -> true - | uu___2 -> false) flags in - match uu___ with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.DECREASES - (FStar_Syntax_Syntax.Decreases_lex ts)) -> ts - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.DECREASES - (FStar_Syntax_Syntax.Decreases_wf uu___1)) -> - ((let uu___3 = - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_comp c in - FStar_Compiler_Util.format1 - "inspect_comp: inspecting comp with wf decreases clause is not yet supported: %s skipping the decreases clause" - uu___4 in - FStar_Errors.log_issue (FStar_Syntax_Syntax.has_range_syntax ()) - c FStar_Errors_Codes.Warning_CantInspect () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___3)); - []) - | uu___1 -> failwith "Impossible!" in - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total t -> FStar_Reflection_V1_Data.C_Total t - | FStar_Syntax_Syntax.GTotal t -> FStar_Reflection_V1_Data.C_GTotal t - | FStar_Syntax_Syntax.Comp ct -> - let uopt = - if - (FStar_Compiler_List.length ct.FStar_Syntax_Syntax.comp_univs) = - Prims.int_zero - then FStar_Syntax_Syntax.U_unknown - else FStar_Compiler_List.hd ct.FStar_Syntax_Syntax.comp_univs in - let uu___ = - FStar_Ident.lid_equals ct.FStar_Syntax_Syntax.effect_name - FStar_Parser_Const.effect_Lemma_lid in - if uu___ - then - (match ct.FStar_Syntax_Syntax.effect_args with - | (pre, uu___1)::(post, uu___2)::(pats, uu___3)::uu___4 -> - FStar_Reflection_V1_Data.C_Lemma (pre, post, pats) - | uu___1 -> - failwith "inspect_comp: Lemma does not have enough arguments?") - else - (let inspect_arg uu___2 = - match uu___2 with - | (a, q) -> let uu___3 = inspect_aqual q in (a, uu___3) in - let uu___2 = - let uu___3 = - FStar_Ident.path_of_lid ct.FStar_Syntax_Syntax.effect_name in - let uu___4 = - FStar_Compiler_List.map inspect_arg - ct.FStar_Syntax_Syntax.effect_args in - let uu___5 = get_dec ct.FStar_Syntax_Syntax.flags in - ((ct.FStar_Syntax_Syntax.comp_univs), uu___3, - (ct.FStar_Syntax_Syntax.result_typ), uu___4, uu___5) in - FStar_Reflection_V1_Data.C_Eff uu___2) -let (pack_comp : - FStar_Reflection_V1_Data.comp_view -> FStar_Syntax_Syntax.comp) = - fun cv -> - let urefl_to_univs u = - if u = FStar_Syntax_Syntax.U_unknown then [] else [u] in - let urefl_to_univ_opt u = - if u = FStar_Syntax_Syntax.U_unknown - then FStar_Pervasives_Native.None - else FStar_Pervasives_Native.Some u in - match cv with - | FStar_Reflection_V1_Data.C_Total t -> FStar_Syntax_Syntax.mk_Total t - | FStar_Reflection_V1_Data.C_GTotal t -> FStar_Syntax_Syntax.mk_GTotal t - | FStar_Reflection_V1_Data.C_Lemma (pre, post, pats) -> - let ct = - let uu___ = - let uu___1 = FStar_Syntax_Syntax.as_arg pre in - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.as_arg post in - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.as_arg pats in [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - { - FStar_Syntax_Syntax.comp_univs = []; - FStar_Syntax_Syntax.effect_name = - FStar_Parser_Const.effect_Lemma_lid; - FStar_Syntax_Syntax.result_typ = FStar_Syntax_Syntax.t_unit; - FStar_Syntax_Syntax.effect_args = uu___; - FStar_Syntax_Syntax.flags = [] - } in - FStar_Syntax_Syntax.mk_Comp ct - | FStar_Reflection_V1_Data.C_Eff (us, ef, res, args, decrs) -> - let pack_arg uu___ = - match uu___ with - | (a, q) -> let uu___1 = pack_aqual q in (a, uu___1) in - let flags = - if (FStar_Compiler_List.length decrs) = Prims.int_zero - then [] - else - [FStar_Syntax_Syntax.DECREASES - (FStar_Syntax_Syntax.Decreases_lex decrs)] in - let ct = - let uu___ = - FStar_Ident.lid_of_path ef FStar_Compiler_Range_Type.dummyRange in - let uu___1 = FStar_Compiler_List.map pack_arg args in - { - FStar_Syntax_Syntax.comp_univs = us; - FStar_Syntax_Syntax.effect_name = uu___; - FStar_Syntax_Syntax.result_typ = res; - FStar_Syntax_Syntax.effect_args = uu___1; - FStar_Syntax_Syntax.flags = flags - } in - FStar_Syntax_Syntax.mk_Comp ct -let (pack_const : - FStar_Reflection_V1_Data.vconst -> FStar_Syntax_Syntax.sconst) = - fun c -> - match c with - | FStar_Reflection_V1_Data.C_Unit -> FStar_Const.Const_unit - | FStar_Reflection_V1_Data.C_Int i -> - let uu___ = - let uu___1 = FStar_BigInt.string_of_big_int i in - (uu___1, FStar_Pervasives_Native.None) in - FStar_Const.Const_int uu___ - | FStar_Reflection_V1_Data.C_True -> FStar_Const.Const_bool true - | FStar_Reflection_V1_Data.C_False -> FStar_Const.Const_bool false - | FStar_Reflection_V1_Data.C_String s -> - FStar_Const.Const_string (s, FStar_Compiler_Range_Type.dummyRange) - | FStar_Reflection_V1_Data.C_Range r -> FStar_Const.Const_range r - | FStar_Reflection_V1_Data.C_Reify -> - FStar_Const.Const_reify FStar_Pervasives_Native.None - | FStar_Reflection_V1_Data.C_Reflect ns -> - let uu___ = - FStar_Ident.lid_of_path ns FStar_Compiler_Range_Type.dummyRange in - FStar_Const.Const_reflect uu___ -let (pack_ln : - FStar_Reflection_V1_Data.term_view -> FStar_Syntax_Syntax.term) = - fun tv -> - match tv with - | FStar_Reflection_V1_Data.Tv_Var bv -> FStar_Syntax_Syntax.bv_to_name bv - | FStar_Reflection_V1_Data.Tv_BVar bv -> FStar_Syntax_Syntax.bv_to_tm bv - | FStar_Reflection_V1_Data.Tv_FVar fv -> FStar_Syntax_Syntax.fv_to_tm fv - | FStar_Reflection_V1_Data.Tv_UInst (fv, us) -> - let uu___ = FStar_Syntax_Syntax.fv_to_tm fv in - FStar_Syntax_Syntax.mk_Tm_uinst uu___ us - | FStar_Reflection_V1_Data.Tv_App (l, (r, q)) -> - let q' = pack_aqual q in FStar_Syntax_Util.mk_app l [(r, q')] - | FStar_Reflection_V1_Data.Tv_Abs (b, t) -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = [b]; - FStar_Syntax_Syntax.body = t; - FStar_Syntax_Syntax.rc_opt = FStar_Pervasives_Native.None - }) t.FStar_Syntax_Syntax.pos - | FStar_Reflection_V1_Data.Tv_Arrow (b, c) -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = [b]; FStar_Syntax_Syntax.comp = c }) - c.FStar_Syntax_Syntax.pos - | FStar_Reflection_V1_Data.Tv_Type u -> - FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_type u) - FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V1_Data.Tv_Refine (bv, sort, t) -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_refine - { - FStar_Syntax_Syntax.b = - { - FStar_Syntax_Syntax.ppname = - (bv.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = (bv.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = sort - }; - FStar_Syntax_Syntax.phi = t - }) t.FStar_Syntax_Syntax.pos - | FStar_Reflection_V1_Data.Tv_Const c -> - let uu___ = - let uu___1 = pack_const c in FStar_Syntax_Syntax.Tm_constant uu___1 in - FStar_Syntax_Syntax.mk uu___ FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V1_Data.Tv_Uvar (u, ctx_u_s) -> - FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_uvar ctx_u_s) - FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V1_Data.Tv_Let (false, attrs, bv, ty, t1, t2) -> - let bv1 = - { - FStar_Syntax_Syntax.ppname = (bv.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = (bv.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = ty - } in - let lb = - FStar_Syntax_Util.mk_letbinding (FStar_Pervasives.Inl bv1) [] - bv1.FStar_Syntax_Syntax.sort FStar_Parser_Const.effect_Tot_lid t1 - attrs FStar_Compiler_Range_Type.dummyRange in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = (false, [lb]); - FStar_Syntax_Syntax.body1 = t2 - }) FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V1_Data.Tv_Let (true, attrs, bv, ty, t1, t2) -> - let bv1 = - { - FStar_Syntax_Syntax.ppname = (bv.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = (bv.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = ty - } in - let lb = - FStar_Syntax_Util.mk_letbinding (FStar_Pervasives.Inl bv1) [] - bv1.FStar_Syntax_Syntax.sort FStar_Parser_Const.effect_Tot_lid t1 - attrs FStar_Compiler_Range_Type.dummyRange in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = (true, [lb]); - FStar_Syntax_Syntax.body1 = t2 - }) FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V1_Data.Tv_Match (t, ret_opt, brs) -> - let wrap v = - { - FStar_Syntax_Syntax.v = v; - FStar_Syntax_Syntax.p = FStar_Compiler_Range_Type.dummyRange - } in - let rec pack_pat p = - match p with - | FStar_Reflection_V1_Data.Pat_Constant c -> - let uu___ = - let uu___1 = pack_const c in - FStar_Syntax_Syntax.Pat_constant uu___1 in - wrap uu___ - | FStar_Reflection_V1_Data.Pat_Cons (fv, us_opt, ps) -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with - | (p1, b) -> let uu___4 = pack_pat p1 in (uu___4, b)) - ps in - (fv, us_opt, uu___2) in - FStar_Syntax_Syntax.Pat_cons uu___1 in - wrap uu___ - | FStar_Reflection_V1_Data.Pat_Var (bv, _sort) -> - wrap (FStar_Syntax_Syntax.Pat_var bv) - | FStar_Reflection_V1_Data.Pat_Dot_Term eopt -> - wrap (FStar_Syntax_Syntax.Pat_dot_term eopt) in - let brs1 = - FStar_Compiler_List.map - (fun uu___ -> - match uu___ with - | (pat, t1) -> - let uu___1 = pack_pat pat in - (uu___1, FStar_Pervasives_Native.None, t1)) brs in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_match - { - FStar_Syntax_Syntax.scrutinee = t; - FStar_Syntax_Syntax.ret_opt = ret_opt; - FStar_Syntax_Syntax.brs = brs1; - FStar_Syntax_Syntax.rc_opt1 = FStar_Pervasives_Native.None - }) FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V1_Data.Tv_AscribedT (e, t, tacopt, use_eq) -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_ascribed - { - FStar_Syntax_Syntax.tm = e; - FStar_Syntax_Syntax.asc = - ((FStar_Pervasives.Inl t), tacopt, use_eq); - FStar_Syntax_Syntax.eff_opt = FStar_Pervasives_Native.None - }) FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V1_Data.Tv_AscribedC (e, c, tacopt, use_eq) -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_ascribed - { - FStar_Syntax_Syntax.tm = e; - FStar_Syntax_Syntax.asc = - ((FStar_Pervasives.Inr c), tacopt, use_eq); - FStar_Syntax_Syntax.eff_opt = FStar_Pervasives_Native.None - }) FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V1_Data.Tv_Unknown -> - FStar_Syntax_Syntax.mk FStar_Syntax_Syntax.Tm_unknown - FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V1_Data.Tv_Unsupp -> - (FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_CantInspect () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic "packing a Tv_Unsupp into Tm_unknown"); - FStar_Syntax_Syntax.mk FStar_Syntax_Syntax.Tm_unknown - FStar_Compiler_Range_Type.dummyRange) -let (compare_bv : - FStar_Syntax_Syntax.bv -> FStar_Syntax_Syntax.bv -> FStar_Order.order) = - fun x -> - fun y -> - let n = FStar_Syntax_Syntax.order_bv x y in - if n < Prims.int_zero - then FStar_Order.Lt - else if n = Prims.int_zero then FStar_Order.Eq else FStar_Order.Gt -let (lookup_attr : - FStar_Syntax_Syntax.term -> - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.fv Prims.list) - = - fun attr -> - fun env -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress_subst attr in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_fvar fv -> - let ses = - let uu___1 = - let uu___2 = FStar_Syntax_Syntax.lid_of_fv fv in - FStar_Ident.string_of_lid uu___2 in - FStar_TypeChecker_Env.lookup_attr env uu___1 in - FStar_Compiler_List.concatMap - (fun se -> - let uu___1 = FStar_Syntax_Util.lid_of_sigelt se in - match uu___1 with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some l -> - let uu___2 = - FStar_Syntax_Syntax.lid_as_fv l - FStar_Pervasives_Native.None in - [uu___2]) ses - | uu___1 -> [] -let (all_defs_in_env : - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.fv Prims.list) = - fun env -> - let uu___ = FStar_TypeChecker_Env.lidents env in - FStar_Compiler_List.map - (fun l -> FStar_Syntax_Syntax.lid_as_fv l FStar_Pervasives_Native.None) - uu___ -let (defs_in_module : - FStar_TypeChecker_Env.env -> - FStar_Reflection_V1_Data.name -> FStar_Syntax_Syntax.fv Prims.list) - = - fun env -> - fun modul -> - let uu___ = FStar_TypeChecker_Env.lidents env in - FStar_Compiler_List.concatMap - (fun l -> - let ns = - let uu___1 = - let uu___2 = FStar_Ident.ids_of_lid l in init uu___2 in - FStar_Compiler_List.map FStar_Ident.string_of_id uu___1 in - if ns = modul - then - let uu___1 = - FStar_Syntax_Syntax.lid_as_fv l FStar_Pervasives_Native.None in - [uu___1] - else []) uu___ -let (lookup_typ : - FStar_TypeChecker_Env.env -> - Prims.string Prims.list -> - FStar_Syntax_Syntax.sigelt FStar_Pervasives_Native.option) - = - fun env -> - fun ns -> - let lid = FStar_Parser_Const.p2l ns in - FStar_TypeChecker_Env.lookup_sigelt env lid -let (sigelt_attrs : - FStar_Syntax_Syntax.sigelt -> FStar_Syntax_Syntax.attribute Prims.list) = - fun se -> se.FStar_Syntax_Syntax.sigattrs -let (set_sigelt_attrs : - FStar_Syntax_Syntax.attribute Prims.list -> - FStar_Syntax_Syntax.sigelt -> FStar_Syntax_Syntax.sigelt) - = - fun attrs -> - fun se -> - { - FStar_Syntax_Syntax.sigel = (se.FStar_Syntax_Syntax.sigel); - FStar_Syntax_Syntax.sigrng = (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = (se.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = attrs; - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = (se.FStar_Syntax_Syntax.sigopts) - } -let (inspect_ident : FStar_Ident.ident -> FStar_Reflection_V1_Data.ident) = - fun i -> FStar_Reflection_V2_Builtins.inspect_ident i -let (pack_ident : FStar_Reflection_V1_Data.ident -> FStar_Ident.ident) = - fun i -> FStar_Reflection_V2_Builtins.pack_ident i -let (rd_to_syntax_qual : - FStar_Reflection_V1_Data.qualifier -> FStar_Syntax_Syntax.qualifier) = - fun uu___ -> - match uu___ with - | FStar_Reflection_V1_Data.Assumption -> FStar_Syntax_Syntax.Assumption - | FStar_Reflection_V1_Data.New -> FStar_Syntax_Syntax.New - | FStar_Reflection_V1_Data.Private -> FStar_Syntax_Syntax.Private - | FStar_Reflection_V1_Data.Unfold_for_unification_and_vcgen -> - FStar_Syntax_Syntax.Unfold_for_unification_and_vcgen - | FStar_Reflection_V1_Data.Visible_default -> - FStar_Syntax_Syntax.Visible_default - | FStar_Reflection_V1_Data.Irreducible -> FStar_Syntax_Syntax.Irreducible - | FStar_Reflection_V1_Data.Inline_for_extraction -> - FStar_Syntax_Syntax.Inline_for_extraction - | FStar_Reflection_V1_Data.NoExtract -> FStar_Syntax_Syntax.NoExtract - | FStar_Reflection_V1_Data.Noeq -> FStar_Syntax_Syntax.Noeq - | FStar_Reflection_V1_Data.Unopteq -> FStar_Syntax_Syntax.Unopteq - | FStar_Reflection_V1_Data.TotalEffect -> FStar_Syntax_Syntax.TotalEffect - | FStar_Reflection_V1_Data.Logic -> FStar_Syntax_Syntax.Logic - | FStar_Reflection_V1_Data.Reifiable -> FStar_Syntax_Syntax.Reifiable - | FStar_Reflection_V1_Data.Reflectable l -> - let uu___1 = - FStar_Ident.lid_of_path l FStar_Compiler_Range_Type.dummyRange in - FStar_Syntax_Syntax.Reflectable uu___1 - | FStar_Reflection_V1_Data.Discriminator l -> - let uu___1 = - FStar_Ident.lid_of_path l FStar_Compiler_Range_Type.dummyRange in - FStar_Syntax_Syntax.Discriminator uu___1 - | FStar_Reflection_V1_Data.Projector (l, i) -> - let uu___1 = - let uu___2 = - FStar_Ident.lid_of_path l FStar_Compiler_Range_Type.dummyRange in - let uu___3 = pack_ident i in (uu___2, uu___3) in - FStar_Syntax_Syntax.Projector uu___1 - | FStar_Reflection_V1_Data.RecordType (l1, l2) -> - let uu___1 = - let uu___2 = FStar_Compiler_List.map pack_ident l1 in - let uu___3 = FStar_Compiler_List.map pack_ident l2 in - (uu___2, uu___3) in - FStar_Syntax_Syntax.RecordType uu___1 - | FStar_Reflection_V1_Data.RecordConstructor (l1, l2) -> - let uu___1 = - let uu___2 = FStar_Compiler_List.map pack_ident l1 in - let uu___3 = FStar_Compiler_List.map pack_ident l2 in - (uu___2, uu___3) in - FStar_Syntax_Syntax.RecordConstructor uu___1 - | FStar_Reflection_V1_Data.Action l -> - let uu___1 = - FStar_Ident.lid_of_path l FStar_Compiler_Range_Type.dummyRange in - FStar_Syntax_Syntax.Action uu___1 - | FStar_Reflection_V1_Data.ExceptionConstructor -> - FStar_Syntax_Syntax.ExceptionConstructor - | FStar_Reflection_V1_Data.HasMaskedEffect -> - FStar_Syntax_Syntax.HasMaskedEffect - | FStar_Reflection_V1_Data.Effect -> FStar_Syntax_Syntax.Effect - | FStar_Reflection_V1_Data.OnlyName -> FStar_Syntax_Syntax.OnlyName -let (syntax_to_rd_qual : - FStar_Syntax_Syntax.qualifier -> FStar_Reflection_V1_Data.qualifier) = - fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.Assumption -> FStar_Reflection_V1_Data.Assumption - | FStar_Syntax_Syntax.New -> FStar_Reflection_V1_Data.New - | FStar_Syntax_Syntax.Private -> FStar_Reflection_V1_Data.Private - | FStar_Syntax_Syntax.Unfold_for_unification_and_vcgen -> - FStar_Reflection_V1_Data.Unfold_for_unification_and_vcgen - | FStar_Syntax_Syntax.Visible_default -> - FStar_Reflection_V1_Data.Visible_default - | FStar_Syntax_Syntax.Irreducible -> FStar_Reflection_V1_Data.Irreducible - | FStar_Syntax_Syntax.Inline_for_extraction -> - FStar_Reflection_V1_Data.Inline_for_extraction - | FStar_Syntax_Syntax.NoExtract -> FStar_Reflection_V1_Data.NoExtract - | FStar_Syntax_Syntax.Noeq -> FStar_Reflection_V1_Data.Noeq - | FStar_Syntax_Syntax.Unopteq -> FStar_Reflection_V1_Data.Unopteq - | FStar_Syntax_Syntax.TotalEffect -> FStar_Reflection_V1_Data.TotalEffect - | FStar_Syntax_Syntax.Logic -> FStar_Reflection_V1_Data.Logic - | FStar_Syntax_Syntax.Reifiable -> FStar_Reflection_V1_Data.Reifiable - | FStar_Syntax_Syntax.Reflectable l -> - let uu___1 = FStar_Ident.path_of_lid l in - FStar_Reflection_V1_Data.Reflectable uu___1 - | FStar_Syntax_Syntax.Discriminator l -> - let uu___1 = FStar_Ident.path_of_lid l in - FStar_Reflection_V1_Data.Discriminator uu___1 - | FStar_Syntax_Syntax.Projector (l, i) -> - let uu___1 = - let uu___2 = FStar_Ident.path_of_lid l in - let uu___3 = inspect_ident i in (uu___2, uu___3) in - FStar_Reflection_V1_Data.Projector uu___1 - | FStar_Syntax_Syntax.RecordType (l1, l2) -> - let uu___1 = - let uu___2 = FStar_Compiler_List.map inspect_ident l1 in - let uu___3 = FStar_Compiler_List.map inspect_ident l2 in - (uu___2, uu___3) in - FStar_Reflection_V1_Data.RecordType uu___1 - | FStar_Syntax_Syntax.RecordConstructor (l1, l2) -> - let uu___1 = - let uu___2 = FStar_Compiler_List.map inspect_ident l1 in - let uu___3 = FStar_Compiler_List.map inspect_ident l2 in - (uu___2, uu___3) in - FStar_Reflection_V1_Data.RecordConstructor uu___1 - | FStar_Syntax_Syntax.Action l -> - let uu___1 = FStar_Ident.path_of_lid l in - FStar_Reflection_V1_Data.Action uu___1 - | FStar_Syntax_Syntax.ExceptionConstructor -> - FStar_Reflection_V1_Data.ExceptionConstructor - | FStar_Syntax_Syntax.HasMaskedEffect -> - FStar_Reflection_V1_Data.HasMaskedEffect - | FStar_Syntax_Syntax.Effect -> FStar_Reflection_V1_Data.Effect - | FStar_Syntax_Syntax.OnlyName -> FStar_Reflection_V1_Data.OnlyName -let (sigelt_quals : - FStar_Syntax_Syntax.sigelt -> FStar_Reflection_V1_Data.qualifier Prims.list) - = - fun se -> - FStar_Compiler_List.map syntax_to_rd_qual se.FStar_Syntax_Syntax.sigquals -let (set_sigelt_quals : - FStar_Reflection_V1_Data.qualifier Prims.list -> - FStar_Syntax_Syntax.sigelt -> FStar_Syntax_Syntax.sigelt) - = - fun quals -> - fun se -> - let uu___ = FStar_Compiler_List.map rd_to_syntax_qual quals in - { - FStar_Syntax_Syntax.sigel = (se.FStar_Syntax_Syntax.sigel); - FStar_Syntax_Syntax.sigrng = (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = uu___; - FStar_Syntax_Syntax.sigmeta = (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = (se.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = (se.FStar_Syntax_Syntax.sigopts) - } -let (sigelt_opts : - FStar_Syntax_Syntax.sigelt -> - FStar_VConfig.vconfig FStar_Pervasives_Native.option) - = fun se -> se.FStar_Syntax_Syntax.sigopts -let (embed_vconfig : FStar_VConfig.vconfig -> FStar_Syntax_Syntax.term) = - fun vcfg -> - let uu___ = - FStar_Syntax_Embeddings_Base.embed FStar_Syntax_Embeddings.e_vconfig - vcfg in - uu___ FStar_Compiler_Range_Type.dummyRange FStar_Pervasives_Native.None - FStar_Syntax_Embeddings_Base.id_norm_cb -let (inspect_sigelt : - FStar_Syntax_Syntax.sigelt -> FStar_Reflection_V1_Data.sigelt_view) = - fun se -> - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (r, lbs); - FStar_Syntax_Syntax.lids1 = uu___;_} - -> - let inspect_letbinding lb = - let uu___1 = lb in - match uu___1 with - | { FStar_Syntax_Syntax.lbname = nm; - FStar_Syntax_Syntax.lbunivs = us; - FStar_Syntax_Syntax.lbtyp = typ; - FStar_Syntax_Syntax.lbeff = eff; - FStar_Syntax_Syntax.lbdef = def; - FStar_Syntax_Syntax.lbattrs = attrs; - FStar_Syntax_Syntax.lbpos = pos;_} -> - let uu___2 = FStar_Syntax_Subst.univ_var_opening us in - (match uu___2 with - | (s, us1) -> - let typ1 = FStar_Syntax_Subst.subst s typ in - let def1 = FStar_Syntax_Subst.subst s def in - FStar_Syntax_Util.mk_letbinding nm us1 typ1 eff def1 attrs - pos) in - let uu___1 = - let uu___2 = FStar_Compiler_List.map inspect_letbinding lbs in - (r, uu___2) in - FStar_Reflection_V1_Data.Sg_Let uu___1 - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = lid; FStar_Syntax_Syntax.us = us; - FStar_Syntax_Syntax.params = param_bs; - FStar_Syntax_Syntax.num_uniform_params = uu___; - FStar_Syntax_Syntax.t = ty; FStar_Syntax_Syntax.mutuals = uu___1; - FStar_Syntax_Syntax.ds = c_lids; - FStar_Syntax_Syntax.injective_type_params = uu___2;_} - -> - let nm = FStar_Ident.path_of_lid lid in - let uu___3 = FStar_Syntax_Subst.univ_var_opening us in - (match uu___3 with - | (s, us1) -> - let param_bs1 = FStar_Syntax_Subst.subst_binders s param_bs in - let ty1 = FStar_Syntax_Subst.subst s ty in - let uu___4 = FStar_Syntax_Subst.open_term param_bs1 ty1 in - (match uu___4 with - | (param_bs2, ty2) -> - let inspect_ctor c_lid = - let uu___5 = - let uu___6 = get_env () in - FStar_TypeChecker_Env.lookup_sigelt uu___6 c_lid in - match uu___5 with - | FStar_Pervasives_Native.Some - { - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = lid1; - FStar_Syntax_Syntax.us1 = us2; - FStar_Syntax_Syntax.t1 = cty; - FStar_Syntax_Syntax.ty_lid = uu___6; - FStar_Syntax_Syntax.num_ty_params = nparam; - FStar_Syntax_Syntax.mutuals1 = uu___7; - FStar_Syntax_Syntax.injective_type_params1 = - uu___8;_}; - FStar_Syntax_Syntax.sigrng = uu___9; - FStar_Syntax_Syntax.sigquals = uu___10; - FStar_Syntax_Syntax.sigmeta = uu___11; - FStar_Syntax_Syntax.sigattrs = uu___12; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___13; - FStar_Syntax_Syntax.sigopts = uu___14;_} - -> - let cty1 = FStar_Syntax_Subst.subst s cty in - let uu___15 = - let uu___16 = get_env () in - FStar_TypeChecker_Normalize.get_n_binders uu___16 - nparam cty1 in - (match uu___15 with - | (param_ctor_bs, c) -> - (if - (FStar_Compiler_List.length param_ctor_bs) <> - nparam - then - failwith - "impossible: inspect_sigelt: could not obtain sufficient ctor param binders" - else (); - (let uu___18 = - let uu___19 = - FStar_Syntax_Util.is_total_comp c in - Prims.op_Negation uu___19 in - if uu___18 - then - failwith - "impossible: inspect_sigelt: removed parameters and got an effectful comp" - else ()); - (let cty2 = FStar_Syntax_Util.comp_result c in - let s' = - FStar_Compiler_List.map2 - (fun b1 -> - fun b2 -> - let uu___18 = - let uu___19 = - FStar_Syntax_Syntax.bv_to_name - b2.FStar_Syntax_Syntax.binder_bv in - ((b1.FStar_Syntax_Syntax.binder_bv), - uu___19) in - FStar_Syntax_Syntax.NT uu___18) - param_ctor_bs param_bs2 in - let cty3 = FStar_Syntax_Subst.subst s' cty2 in - let cty4 = FStar_Syntax_Util.remove_inacc cty3 in - let uu___18 = FStar_Ident.path_of_lid lid1 in - (uu___18, cty4)))) - | uu___6 -> - failwith - "impossible: inspect_sigelt: did not find ctor" in - let uu___5 = - let uu___6 = FStar_Compiler_List.map inspect_ident us1 in - let uu___7 = FStar_Compiler_List.map inspect_ctor c_lids in - (nm, uu___6, param_bs2, ty2, uu___7) in - FStar_Reflection_V1_Data.Sg_Inductive uu___5)) - | FStar_Syntax_Syntax.Sig_declare_typ - { FStar_Syntax_Syntax.lid2 = lid; FStar_Syntax_Syntax.us2 = us; - FStar_Syntax_Syntax.t2 = ty;_} - -> - let nm = FStar_Ident.path_of_lid lid in - let uu___ = FStar_Syntax_Subst.open_univ_vars us ty in - (match uu___ with - | (us1, ty1) -> - let uu___1 = - let uu___2 = FStar_Compiler_List.map inspect_ident us1 in - (nm, uu___2, ty1) in - FStar_Reflection_V1_Data.Sg_Val uu___1) - | uu___ -> FStar_Reflection_V1_Data.Unk -let (pack_sigelt : - FStar_Reflection_V1_Data.sigelt_view -> FStar_Syntax_Syntax.sigelt) = - fun sv -> - let check_lid lid = - let uu___ = - let uu___1 = - let uu___2 = FStar_Ident.path_of_lid lid in - FStar_Compiler_List.length uu___2 in - uu___1 <= Prims.int_one in - if uu___ - then - let uu___1 = - let uu___2 = - let uu___3 = FStar_Ident.string_of_lid lid in - Prims.strcat uu___3 "\" (did you forget a module path?)" in - Prims.strcat "pack_sigelt: invalid long identifier \"" uu___2 in - failwith uu___1 - else () in - match sv with - | FStar_Reflection_V1_Data.Sg_Let (r, lbs) -> - let pack_letbinding lb = - let uu___ = lb in - match uu___ with - | { FStar_Syntax_Syntax.lbname = nm; - FStar_Syntax_Syntax.lbunivs = us; - FStar_Syntax_Syntax.lbtyp = typ; - FStar_Syntax_Syntax.lbeff = eff; - FStar_Syntax_Syntax.lbdef = def; - FStar_Syntax_Syntax.lbattrs = attrs; - FStar_Syntax_Syntax.lbpos = pos;_} -> - let lid = - match nm with - | FStar_Pervasives.Inr fv -> FStar_Syntax_Syntax.lid_of_fv fv - | uu___1 -> - failwith - "impossible: pack_sigelt: bv in toplevel let binding" in - (check_lid lid; - (let s = FStar_Syntax_Subst.univ_var_closing us in - let typ1 = FStar_Syntax_Subst.subst s typ in - let def1 = FStar_Syntax_Subst.subst s def in - let lb1 = - FStar_Syntax_Util.mk_letbinding nm us typ1 eff def1 attrs - pos in - (lid, lb1))) in - let packed = FStar_Compiler_List.map pack_letbinding lbs in - let lbs1 = FStar_Compiler_List.map FStar_Pervasives_Native.snd packed in - let lids = FStar_Compiler_List.map FStar_Pervasives_Native.fst packed in - FStar_Syntax_Syntax.mk_sigelt - (FStar_Syntax_Syntax.Sig_let - { - FStar_Syntax_Syntax.lbs1 = (r, lbs1); - FStar_Syntax_Syntax.lids1 = lids - }) - | FStar_Reflection_V1_Data.Sg_Inductive - (nm, us_names, param_bs, ty, ctors) -> - let us_names1 = FStar_Compiler_List.map pack_ident us_names in - let ind_lid = - FStar_Ident.lid_of_path nm FStar_Compiler_Range_Type.dummyRange in - (check_lid ind_lid; - (let s = FStar_Syntax_Subst.univ_var_closing us_names1 in - let nparam = FStar_Compiler_List.length param_bs in - let injective_type_params = false in - let pack_ctor c = - let uu___1 = c in - match uu___1 with - | (nm1, ty1) -> - let lid = - FStar_Ident.lid_of_path nm1 - FStar_Compiler_Range_Type.dummyRange in - let ty2 = - let uu___2 = FStar_Syntax_Syntax.mk_Total ty1 in - FStar_Syntax_Util.arrow param_bs uu___2 in - let ty3 = FStar_Syntax_Subst.subst s ty2 in - FStar_Syntax_Syntax.mk_sigelt - (FStar_Syntax_Syntax.Sig_datacon - { - FStar_Syntax_Syntax.lid1 = lid; - FStar_Syntax_Syntax.us1 = us_names1; - FStar_Syntax_Syntax.t1 = ty3; - FStar_Syntax_Syntax.ty_lid = ind_lid; - FStar_Syntax_Syntax.num_ty_params = nparam; - FStar_Syntax_Syntax.mutuals1 = []; - FStar_Syntax_Syntax.injective_type_params1 = - injective_type_params - }) in - let ctor_ses = FStar_Compiler_List.map pack_ctor ctors in - let c_lids = - FStar_Compiler_List.map - (fun se -> - let uu___1 = FStar_Syntax_Util.lid_of_sigelt se in - FStar_Compiler_Util.must uu___1) ctor_ses in - let ind_se = - let param_bs1 = FStar_Syntax_Subst.close_binders param_bs in - let ty1 = FStar_Syntax_Subst.close param_bs1 ty in - let param_bs2 = FStar_Syntax_Subst.subst_binders s param_bs1 in - let ty2 = FStar_Syntax_Subst.subst s ty1 in - FStar_Syntax_Syntax.mk_sigelt - (FStar_Syntax_Syntax.Sig_inductive_typ - { - FStar_Syntax_Syntax.lid = ind_lid; - FStar_Syntax_Syntax.us = us_names1; - FStar_Syntax_Syntax.params = param_bs2; - FStar_Syntax_Syntax.num_uniform_params = - FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.t = ty2; - FStar_Syntax_Syntax.mutuals = []; - FStar_Syntax_Syntax.ds = c_lids; - FStar_Syntax_Syntax.injective_type_params = - injective_type_params - }) in - let se = - FStar_Syntax_Syntax.mk_sigelt - (FStar_Syntax_Syntax.Sig_bundle - { - FStar_Syntax_Syntax.ses = (ind_se :: ctor_ses); - FStar_Syntax_Syntax.lids = (ind_lid :: c_lids) - }) in - { - FStar_Syntax_Syntax.sigel = (se.FStar_Syntax_Syntax.sigel); - FStar_Syntax_Syntax.sigrng = (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = (FStar_Syntax_Syntax.Noeq :: - (se.FStar_Syntax_Syntax.sigquals)); - FStar_Syntax_Syntax.sigmeta = (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = (se.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = (se.FStar_Syntax_Syntax.sigopts) - })) - | FStar_Reflection_V1_Data.Sg_Val (nm, us_names, ty) -> - let us_names1 = FStar_Compiler_List.map pack_ident us_names in - let val_lid = - FStar_Ident.lid_of_path nm FStar_Compiler_Range_Type.dummyRange in - (check_lid val_lid; - (let typ = FStar_Syntax_Subst.close_univ_vars us_names1 ty in - FStar_Syntax_Syntax.mk_sigelt - (FStar_Syntax_Syntax.Sig_declare_typ - { - FStar_Syntax_Syntax.lid2 = val_lid; - FStar_Syntax_Syntax.us2 = us_names1; - FStar_Syntax_Syntax.t2 = typ - }))) - | FStar_Reflection_V1_Data.Unk -> failwith "packing Unk, sorry" -let (inspect_lb : - FStar_Syntax_Syntax.letbinding -> FStar_Reflection_V1_Data.lb_view) = - fun lb -> - let uu___ = lb in - match uu___ with - | { FStar_Syntax_Syntax.lbname = nm; FStar_Syntax_Syntax.lbunivs = us; - FStar_Syntax_Syntax.lbtyp = typ; FStar_Syntax_Syntax.lbeff = eff; - FStar_Syntax_Syntax.lbdef = def; FStar_Syntax_Syntax.lbattrs = attrs; - FStar_Syntax_Syntax.lbpos = pos;_} -> - let uu___1 = FStar_Syntax_Subst.univ_var_opening us in - (match uu___1 with - | (s, us1) -> - let typ1 = FStar_Syntax_Subst.subst s typ in - let def1 = FStar_Syntax_Subst.subst s def in - let us2 = FStar_Compiler_List.map inspect_ident us1 in - (match nm with - | FStar_Pervasives.Inr fv -> - { - FStar_Reflection_V1_Data.lb_fv = fv; - FStar_Reflection_V1_Data.lb_us = us2; - FStar_Reflection_V1_Data.lb_typ = typ1; - FStar_Reflection_V1_Data.lb_def = def1 - } - | uu___2 -> failwith "Impossible: bv in top-level let binding")) -let (pack_lb : - FStar_Reflection_V1_Data.lb_view -> FStar_Syntax_Syntax.letbinding) = - fun lbv -> - let uu___ = lbv in - match uu___ with - | { FStar_Reflection_V1_Data.lb_fv = fv; - FStar_Reflection_V1_Data.lb_us = us; - FStar_Reflection_V1_Data.lb_typ = typ; - FStar_Reflection_V1_Data.lb_def = def;_} -> - let us1 = FStar_Compiler_List.map pack_ident us in - let s = FStar_Syntax_Subst.univ_var_closing us1 in - let typ1 = FStar_Syntax_Subst.subst s typ in - let def1 = FStar_Syntax_Subst.subst s def in - FStar_Syntax_Util.mk_letbinding (FStar_Pervasives.Inr fv) us1 typ1 - FStar_Parser_Const.effect_Tot_lid def1 [] - FStar_Compiler_Range_Type.dummyRange -let (inspect_bv : FStar_Syntax_Syntax.bv -> FStar_Reflection_V1_Data.bv_view) - = - fun bv -> - if bv.FStar_Syntax_Syntax.index < Prims.int_zero - then - (let uu___1 = - let uu___2 = FStar_Ident.string_of_id bv.FStar_Syntax_Syntax.ppname in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - bv.FStar_Syntax_Syntax.sort in - let uu___4 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - bv.FStar_Syntax_Syntax.index in - FStar_Compiler_Util.format3 - "inspect_bv: index is negative (%s : %s), index = %s" uu___2 - uu___3 uu___4 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_CantInspect () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1)) - else (); - (let uu___1 = - let uu___2 = FStar_Ident.string_of_id bv.FStar_Syntax_Syntax.ppname in - FStar_Compiler_Sealed.seal uu___2 in - let uu___2 = FStar_BigInt.of_int_fs bv.FStar_Syntax_Syntax.index in - { - FStar_Reflection_V1_Data.bv_ppname = uu___1; - FStar_Reflection_V1_Data.bv_index = uu___2 - }) -let (pack_bv : FStar_Reflection_V1_Data.bv_view -> FStar_Syntax_Syntax.bv) = - fun bvv -> - (let uu___1 = - let uu___2 = - FStar_BigInt.to_int_fs bvv.FStar_Reflection_V1_Data.bv_index in - uu___2 < Prims.int_zero in - if uu___1 - then - let uu___2 = - let uu___3 = - let uu___4 = - FStar_BigInt.to_int_fs bvv.FStar_Reflection_V1_Data.bv_index in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) uu___4 in - FStar_Compiler_Util.format2 - "pack_bv: index is negative (%s), index = %s" - (FStar_Compiler_Sealed.unseal - bvv.FStar_Reflection_V1_Data.bv_ppname) uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_CantInspect () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2) - else ()); - (let uu___1 = - FStar_Ident.mk_ident - ((FStar_Compiler_Sealed.unseal - bvv.FStar_Reflection_V1_Data.bv_ppname), - FStar_Compiler_Range_Type.dummyRange) in - let uu___2 = - FStar_BigInt.to_int_fs bvv.FStar_Reflection_V1_Data.bv_index in - { - FStar_Syntax_Syntax.ppname = uu___1; - FStar_Syntax_Syntax.index = uu___2; - FStar_Syntax_Syntax.sort = FStar_Syntax_Syntax.tun - }) -let (inspect_binder : - FStar_Syntax_Syntax.binder -> FStar_Reflection_V1_Data.binder_view) = - fun b -> - let attrs = - FStar_Syntax_Util.encode_positivity_attributes - b.FStar_Syntax_Syntax.binder_positivity - b.FStar_Syntax_Syntax.binder_attrs in - let uu___ = inspect_bqual b.FStar_Syntax_Syntax.binder_qual in - { - FStar_Reflection_V1_Data.binder_bv = (b.FStar_Syntax_Syntax.binder_bv); - FStar_Reflection_V1_Data.binder_qual = uu___; - FStar_Reflection_V1_Data.binder_attrs = attrs; - FStar_Reflection_V1_Data.binder_sort = - ((b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort) - } -let (pack_binder : - FStar_Reflection_V1_Data.binder_view -> FStar_Syntax_Syntax.binder) = - fun bview -> - let uu___ = - FStar_Syntax_Util.parse_positivity_attributes - bview.FStar_Reflection_V1_Data.binder_attrs in - match uu___ with - | (pqual, attrs) -> - let uu___1 = pack_bqual bview.FStar_Reflection_V1_Data.binder_qual in - { - FStar_Syntax_Syntax.binder_bv = - (let uu___2 = bview.FStar_Reflection_V1_Data.binder_bv in - { - FStar_Syntax_Syntax.ppname = - (uu___2.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = (uu___2.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = - (bview.FStar_Reflection_V1_Data.binder_sort) - }); - FStar_Syntax_Syntax.binder_qual = uu___1; - FStar_Syntax_Syntax.binder_positivity = pqual; - FStar_Syntax_Syntax.binder_attrs = attrs - } -let (moduleof : FStar_TypeChecker_Env.env -> Prims.string Prims.list) = - fun e -> FStar_Ident.path_of_lid e.FStar_TypeChecker_Env.curmodule -let (env_open_modules : - FStar_TypeChecker_Env.env -> FStar_Reflection_V1_Data.name Prims.list) = - fun e -> - let uu___ = FStar_Syntax_DsEnv.open_modules e.FStar_TypeChecker_Env.dsenv in - FStar_Compiler_List.map - (fun uu___1 -> - match uu___1 with - | (l, m) -> - let uu___2 = FStar_Ident.ids_of_lid l in - FStar_Compiler_List.map FStar_Ident.string_of_id uu___2) uu___ -let (binders_of_env : - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.binders) = - fun e -> FStar_TypeChecker_Env.all_binders e -let eqopt : - 'uuuuu . - unit -> - ('uuuuu -> 'uuuuu -> Prims.bool) -> - 'uuuuu FStar_Pervasives_Native.option -> - 'uuuuu FStar_Pervasives_Native.option -> Prims.bool - = fun uu___ -> FStar_Syntax_Util.eqopt -let eqlist : - 'uuuuu . - unit -> - ('uuuuu -> 'uuuuu -> Prims.bool) -> - 'uuuuu Prims.list -> 'uuuuu Prims.list -> Prims.bool - = fun uu___ -> FStar_Syntax_Util.eqlist -let eqprod : - 'uuuuu 'uuuuu1 . - unit -> - ('uuuuu -> 'uuuuu -> Prims.bool) -> - ('uuuuu1 -> 'uuuuu1 -> Prims.bool) -> - ('uuuuu * 'uuuuu1) -> ('uuuuu * 'uuuuu1) -> Prims.bool - = fun uu___ -> FStar_Syntax_Util.eqprod -let rec (term_eq : - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term -> Prims.bool) = - fun t1 -> - fun t2 -> - let uu___ = - let uu___1 = inspect_ln t1 in - let uu___2 = inspect_ln t2 in (uu___1, uu___2) in - match uu___ with - | (FStar_Reflection_V1_Data.Tv_Var bv1, FStar_Reflection_V1_Data.Tv_Var - bv2) -> bv_eq bv1 bv2 - | (FStar_Reflection_V1_Data.Tv_BVar bv1, - FStar_Reflection_V1_Data.Tv_BVar bv2) -> bv_eq bv1 bv2 - | (FStar_Reflection_V1_Data.Tv_FVar fv1, - FStar_Reflection_V1_Data.Tv_FVar fv2) -> - FStar_Syntax_Syntax.fv_eq fv1 fv2 - | (FStar_Reflection_V1_Data.Tv_UInst (fv1, us1), - FStar_Reflection_V1_Data.Tv_UInst (fv2, us2)) -> - (FStar_Syntax_Syntax.fv_eq fv1 fv2) && (univs_eq us1 us2) - | (FStar_Reflection_V1_Data.Tv_App (h1, arg1), - FStar_Reflection_V1_Data.Tv_App (h2, arg2)) -> - (term_eq h1 h2) && (arg_eq arg1 arg2) - | (FStar_Reflection_V1_Data.Tv_Abs (b1, t11), - FStar_Reflection_V1_Data.Tv_Abs (b2, t21)) -> - (binder_eq b1 b2) && (term_eq t11 t21) - | (FStar_Reflection_V1_Data.Tv_Arrow (b1, c1), - FStar_Reflection_V1_Data.Tv_Arrow (b2, c2)) -> - (binder_eq b1 b2) && (comp_eq c1 c2) - | (FStar_Reflection_V1_Data.Tv_Type u1, - FStar_Reflection_V1_Data.Tv_Type u2) -> univ_eq u1 u2 - | (FStar_Reflection_V1_Data.Tv_Refine (b1, sort1, t11), - FStar_Reflection_V1_Data.Tv_Refine (b2, sort2, t21)) -> - (term_eq sort1 sort2) && (term_eq t11 t21) - | (FStar_Reflection_V1_Data.Tv_Const c1, - FStar_Reflection_V1_Data.Tv_Const c2) -> const_eq c1 c2 - | (FStar_Reflection_V1_Data.Tv_Uvar (n1, uv1), - FStar_Reflection_V1_Data.Tv_Uvar (n2, uv2)) -> n1 = n2 - | (FStar_Reflection_V1_Data.Tv_Let (r1, ats1, bv1, ty1, m1, n1), - FStar_Reflection_V1_Data.Tv_Let (r2, ats2, bv2, ty2, m2, n2)) -> - ((((r1 = r2) && ((eqlist ()) term_eq ats1 ats2)) && - (term_eq ty1 ty2)) - && (term_eq m1 m2)) - && (term_eq n1 n2) - | (FStar_Reflection_V1_Data.Tv_Match (h1, an1, brs1), - FStar_Reflection_V1_Data.Tv_Match (h2, an2, brs2)) -> - ((term_eq h1 h2) && ((eqopt ()) match_ret_asc_eq an1 an2)) && - ((eqlist ()) branch_eq brs1 brs2) - | (FStar_Reflection_V1_Data.Tv_AscribedT (e1, t11, topt1, eq1), - FStar_Reflection_V1_Data.Tv_AscribedT (e2, t21, topt2, eq2)) -> - (((term_eq e1 e2) && (term_eq t11 t21)) && - ((eqopt ()) term_eq topt1 topt2)) - && (eq1 = eq2) - | (FStar_Reflection_V1_Data.Tv_AscribedC (e1, c1, topt1, eq1), - FStar_Reflection_V1_Data.Tv_AscribedC (e2, c2, topt2, eq2)) -> - (((term_eq e1 e2) && (comp_eq c1 c2)) && - ((eqopt ()) term_eq topt1 topt2)) - && (eq1 = eq2) - | (FStar_Reflection_V1_Data.Tv_Unknown, - FStar_Reflection_V1_Data.Tv_Unknown) -> true - | uu___1 -> false -and (arg_eq : - FStar_Reflection_V1_Data.argv -> - FStar_Reflection_V1_Data.argv -> Prims.bool) - = - fun arg1 -> - fun arg2 -> - let uu___ = arg1 in - match uu___ with - | (a1, aq1) -> - let uu___1 = arg2 in - (match uu___1 with - | (a2, aq2) -> (term_eq a1 a2) && (aqual_eq aq1 aq2)) -and (aqual_eq : - FStar_Reflection_V1_Data.aqualv -> - FStar_Reflection_V1_Data.aqualv -> Prims.bool) - = - fun aq1 -> - fun aq2 -> - match (aq1, aq2) with - | (FStar_Reflection_V1_Data.Q_Implicit, - FStar_Reflection_V1_Data.Q_Implicit) -> true - | (FStar_Reflection_V1_Data.Q_Explicit, - FStar_Reflection_V1_Data.Q_Explicit) -> true - | (FStar_Reflection_V1_Data.Q_Meta t1, FStar_Reflection_V1_Data.Q_Meta - t2) -> term_eq t1 t2 - | uu___ -> false -and (binder_eq : - FStar_Syntax_Syntax.binder -> FStar_Syntax_Syntax.binder -> Prims.bool) = - fun b1 -> - fun b2 -> - let bview1 = inspect_binder b1 in - let bview2 = inspect_binder b2 in - ((binding_bv_eq bview1.FStar_Reflection_V1_Data.binder_bv - bview2.FStar_Reflection_V1_Data.binder_bv) - && - (aqual_eq bview1.FStar_Reflection_V1_Data.binder_qual - bview2.FStar_Reflection_V1_Data.binder_qual)) - && - ((eqlist ()) term_eq bview1.FStar_Reflection_V1_Data.binder_attrs - bview2.FStar_Reflection_V1_Data.binder_attrs) -and (binding_bv_eq : - FStar_Syntax_Syntax.bv -> FStar_Syntax_Syntax.bv -> Prims.bool) = - fun bv1 -> - fun bv2 -> - term_eq bv1.FStar_Syntax_Syntax.sort bv2.FStar_Syntax_Syntax.sort -and (bv_eq : FStar_Syntax_Syntax.bv -> FStar_Syntax_Syntax.bv -> Prims.bool) - = - fun bv1 -> - fun bv2 -> bv1.FStar_Syntax_Syntax.index = bv2.FStar_Syntax_Syntax.index -and (comp_eq : - FStar_Syntax_Syntax.comp -> FStar_Syntax_Syntax.comp -> Prims.bool) = - fun c1 -> - fun c2 -> - let uu___ = - let uu___1 = inspect_comp c1 in - let uu___2 = inspect_comp c2 in (uu___1, uu___2) in - match uu___ with - | (FStar_Reflection_V1_Data.C_Total t1, - FStar_Reflection_V1_Data.C_Total t2) -> term_eq t1 t2 - | (FStar_Reflection_V1_Data.C_GTotal t1, - FStar_Reflection_V1_Data.C_GTotal t2) -> term_eq t1 t2 - | (FStar_Reflection_V1_Data.C_Lemma (pre1, post1, pats1), - FStar_Reflection_V1_Data.C_Lemma (pre2, post2, pats2)) -> - ((term_eq pre1 pre2) && (term_eq post1 post2)) && - (term_eq pats1 pats2) - | (FStar_Reflection_V1_Data.C_Eff (us1, name1, t1, args1, decrs1), - FStar_Reflection_V1_Data.C_Eff (us2, name2, t2, args2, decrs2)) -> - ((((univs_eq us1 us2) && (name1 = name2)) && (term_eq t1 t2)) && - ((eqlist ()) arg_eq args1 args2)) - && ((eqlist ()) term_eq decrs1 decrs2) - | uu___1 -> false -and (match_ret_asc_eq : - FStar_Syntax_Syntax.match_returns_ascription -> - FStar_Syntax_Syntax.match_returns_ascription -> Prims.bool) - = fun a1 -> fun a2 -> (eqprod ()) binder_eq ascription_eq a1 a2 -and (ascription_eq : - FStar_Syntax_Syntax.ascription -> - FStar_Syntax_Syntax.ascription -> Prims.bool) - = - fun asc1 -> - fun asc2 -> - let uu___ = asc1 in - match uu___ with - | (a1, topt1, eq1) -> - let uu___1 = asc2 in - (match uu___1 with - | (a2, topt2, eq2) -> - ((match (a1, a2) with - | (FStar_Pervasives.Inl t1, FStar_Pervasives.Inl t2) -> - term_eq t1 t2 - | (FStar_Pervasives.Inr c1, FStar_Pervasives.Inr c2) -> - comp_eq c1 c2) - && ((eqopt ()) term_eq topt1 topt2)) - && (eq1 = eq2)) -and (branch_eq : - FStar_Reflection_V1_Data.branch -> - FStar_Reflection_V1_Data.branch -> Prims.bool) - = fun c1 -> fun c2 -> (eqprod ()) pattern_eq term_eq c1 c2 -and (pattern_eq : - FStar_Reflection_V1_Data.pattern -> - FStar_Reflection_V1_Data.pattern -> Prims.bool) - = - fun p1 -> - fun p2 -> - match (p1, p2) with - | (FStar_Reflection_V1_Data.Pat_Constant c1, - FStar_Reflection_V1_Data.Pat_Constant c2) -> const_eq c1 c2 - | (FStar_Reflection_V1_Data.Pat_Cons (fv1, us1, subpats1), - FStar_Reflection_V1_Data.Pat_Cons (fv2, us2, subpats2)) -> - ((FStar_Syntax_Syntax.fv_eq fv1 fv2) && - ((eqopt ()) ((eqlist ()) univ_eq) us1 us2)) - && - ((eqlist ()) - ((eqprod ()) pattern_eq (fun b1 -> fun b2 -> b1 = b2)) - subpats1 subpats2) - | (FStar_Reflection_V1_Data.Pat_Var (bv1, uu___), - FStar_Reflection_V1_Data.Pat_Var (bv2, uu___1)) -> - binding_bv_eq bv1 bv2 - | (FStar_Reflection_V1_Data.Pat_Dot_Term topt1, - FStar_Reflection_V1_Data.Pat_Dot_Term topt2) -> - (eqopt ()) term_eq topt1 topt2 - | uu___ -> false -and (const_eq : - FStar_Reflection_V1_Data.vconst -> - FStar_Reflection_V1_Data.vconst -> Prims.bool) - = fun c1 -> fun c2 -> c1 = c2 -and (univ_eq : - FStar_Syntax_Syntax.universe -> FStar_Syntax_Syntax.universe -> Prims.bool) - = fun u1 -> fun u2 -> FStar_Syntax_Util.eq_univs u1 u2 -and (univs_eq : - FStar_Syntax_Syntax.universe Prims.list -> - FStar_Syntax_Syntax.universe Prims.list -> Prims.bool) - = fun us1 -> fun us2 -> (eqlist ()) univ_eq us1 us2 -let (implode_qn : Prims.string Prims.list -> Prims.string) = - fun ns -> FStar_Compiler_String.concat "." ns -let (explode_qn : Prims.string -> Prims.string Prims.list) = - fun s -> FStar_Compiler_String.split [46] s -let (compare_string : Prims.string -> Prims.string -> FStar_BigInt.t) = - fun s1 -> - fun s2 -> FStar_BigInt.of_int_fs (FStar_Compiler_String.compare s1 s2) -let (push_binder : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.binder -> FStar_TypeChecker_Env.env) - = fun e -> fun b -> FStar_TypeChecker_Env.push_binders e [b] -let (subst : - FStar_Syntax_Syntax.bv -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun x -> - fun n -> - fun m -> FStar_Syntax_Subst.subst [FStar_Syntax_Syntax.NT (x, n)] m -let (close_term : - FStar_Syntax_Syntax.binder -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = fun b -> fun t -> FStar_Syntax_Subst.close [b] t -let (range_of_term : - FStar_Syntax_Syntax.term -> FStar_Compiler_Range_Type.range) = - fun t -> t.FStar_Syntax_Syntax.pos -let (range_of_sigelt : - FStar_Syntax_Syntax.sigelt -> FStar_Compiler_Range_Type.range) = - fun s -> s.FStar_Syntax_Syntax.sigrng \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Reflection_V1_Constants.ml b/ocaml/fstar-lib/generated/FStar_Reflection_V1_Constants.ml deleted file mode 100644 index 63932510c1c..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Reflection_V1_Constants.ml +++ /dev/null @@ -1,391 +0,0 @@ -open Prims -type refl_constant = - { - lid: FStar_Ident.lid ; - fv: FStar_Syntax_Syntax.fv ; - t: FStar_Syntax_Syntax.term } -let (__proj__Mkrefl_constant__item__lid : refl_constant -> FStar_Ident.lid) = - fun projectee -> match projectee with | { lid; fv; t;_} -> lid -let (__proj__Mkrefl_constant__item__fv : - refl_constant -> FStar_Syntax_Syntax.fv) = - fun projectee -> match projectee with | { lid; fv; t;_} -> fv -let (__proj__Mkrefl_constant__item__t : - refl_constant -> FStar_Syntax_Syntax.term) = - fun projectee -> match projectee with | { lid; fv; t;_} -> t -let (refl_constant_lid : refl_constant -> FStar_Ident.lid) = fun rc -> rc.lid -let (refl_constant_term : refl_constant -> FStar_Syntax_Syntax.term) = - fun rc -> rc.t -let (fstar_refl_lid : Prims.string Prims.list -> FStar_Ident.lident) = - fun s -> - FStar_Ident.lid_of_path - (FStar_Compiler_List.op_At ["FStar"; "Stubs"; "Reflection"] s) - FStar_Compiler_Range_Type.dummyRange -let (fstar_refl_types_lid : Prims.string -> FStar_Ident.lident) = - fun s -> fstar_refl_lid ["Types"; s] -let (fstar_refl_builtins_lid : Prims.string -> FStar_Ident.lident) = - fun s -> fstar_refl_lid ["V1"; "Builtins"; s] -let (fstar_refl_data_lid : Prims.string -> FStar_Ident.lident) = - fun s -> fstar_refl_lid ["V1"; "Data"; s] -let (fstar_refl_data_const : Prims.string -> refl_constant) = - fun s -> - let lid = fstar_refl_data_lid s in - let uu___ = - FStar_Syntax_Syntax.lid_as_fv lid - (FStar_Pervasives_Native.Some FStar_Syntax_Syntax.Data_ctor) in - let uu___1 = FStar_Syntax_Syntax.tdataconstr lid in - { lid; fv = uu___; t = uu___1 } -let (mk_refl_types_lid_as_term : Prims.string -> FStar_Syntax_Syntax.term) = - fun s -> - let uu___ = fstar_refl_types_lid s in FStar_Syntax_Syntax.tconst uu___ -let (mk_refl_types_lid_as_fv : Prims.string -> FStar_Syntax_Syntax.fv) = - fun s -> - let uu___ = fstar_refl_types_lid s in FStar_Syntax_Syntax.fvconst uu___ -let (mk_refl_data_lid_as_term : Prims.string -> FStar_Syntax_Syntax.term) = - fun s -> - let uu___ = fstar_refl_data_lid s in FStar_Syntax_Syntax.tconst uu___ -let (mk_refl_data_lid_as_fv : Prims.string -> FStar_Syntax_Syntax.fv) = - fun s -> - let uu___ = fstar_refl_data_lid s in FStar_Syntax_Syntax.fvconst uu___ -let (mk_inspect_pack_pair : Prims.string -> (refl_constant * refl_constant)) - = - fun s -> - let inspect_lid = fstar_refl_builtins_lid (Prims.strcat "inspect" s) in - let pack_lid = fstar_refl_builtins_lid (Prims.strcat "pack" s) in - let inspect_fv = - FStar_Syntax_Syntax.lid_as_fv inspect_lid FStar_Pervasives_Native.None in - let pack_fv = - FStar_Syntax_Syntax.lid_as_fv pack_lid FStar_Pervasives_Native.None in - let inspect = - let uu___ = FStar_Syntax_Syntax.fv_to_tm inspect_fv in - { lid = inspect_lid; fv = inspect_fv; t = uu___ } in - let pack = - let uu___ = FStar_Syntax_Syntax.fv_to_tm pack_fv in - { lid = pack_lid; fv = pack_fv; t = uu___ } in - (inspect, pack) -let (uu___0 : (refl_constant * refl_constant)) = mk_inspect_pack_pair "_ln" -let (fstar_refl_inspect_ln : refl_constant) = - match uu___0 with - | (fstar_refl_inspect_ln1, fstar_refl_pack_ln) -> fstar_refl_inspect_ln1 -let (fstar_refl_pack_ln : refl_constant) = - match uu___0 with - | (fstar_refl_inspect_ln1, fstar_refl_pack_ln1) -> fstar_refl_pack_ln1 -let (uu___1 : (refl_constant * refl_constant)) = mk_inspect_pack_pair "_fv" -let (fstar_refl_inspect_fv : refl_constant) = - match uu___1 with - | (fstar_refl_inspect_fv1, fstar_refl_pack_fv) -> fstar_refl_inspect_fv1 -let (fstar_refl_pack_fv : refl_constant) = - match uu___1 with - | (fstar_refl_inspect_fv1, fstar_refl_pack_fv1) -> fstar_refl_pack_fv1 -let (uu___2 : (refl_constant * refl_constant)) = mk_inspect_pack_pair "_bv" -let (fstar_refl_inspect_bv : refl_constant) = - match uu___2 with - | (fstar_refl_inspect_bv1, fstar_refl_pack_bv) -> fstar_refl_inspect_bv1 -let (fstar_refl_pack_bv : refl_constant) = - match uu___2 with - | (fstar_refl_inspect_bv1, fstar_refl_pack_bv1) -> fstar_refl_pack_bv1 -let (uu___3 : (refl_constant * refl_constant)) = - mk_inspect_pack_pair "_binder" -let (fstar_refl_inspect_binder : refl_constant) = - match uu___3 with - | (fstar_refl_inspect_binder1, fstar_refl_pack_binder) -> - fstar_refl_inspect_binder1 -let (fstar_refl_pack_binder : refl_constant) = - match uu___3 with - | (fstar_refl_inspect_binder1, fstar_refl_pack_binder1) -> - fstar_refl_pack_binder1 -let (uu___4 : (refl_constant * refl_constant)) = mk_inspect_pack_pair "_comp" -let (fstar_refl_inspect_comp : refl_constant) = - match uu___4 with - | (fstar_refl_inspect_comp1, fstar_refl_pack_comp) -> - fstar_refl_inspect_comp1 -let (fstar_refl_pack_comp : refl_constant) = - match uu___4 with - | (fstar_refl_inspect_comp1, fstar_refl_pack_comp1) -> - fstar_refl_pack_comp1 -let (uu___5 : (refl_constant * refl_constant)) = - mk_inspect_pack_pair "_sigelt" -let (fstar_refl_inspect_sigelt : refl_constant) = - match uu___5 with - | (fstar_refl_inspect_sigelt1, fstar_refl_pack_sigelt) -> - fstar_refl_inspect_sigelt1 -let (fstar_refl_pack_sigelt : refl_constant) = - match uu___5 with - | (fstar_refl_inspect_sigelt1, fstar_refl_pack_sigelt1) -> - fstar_refl_pack_sigelt1 -let (uu___6 : (refl_constant * refl_constant)) = mk_inspect_pack_pair "_lb" -let (fstar_refl_inspect_lb : refl_constant) = - match uu___6 with - | (fstar_refl_inspect_lb1, fstar_refl_pack_lb) -> fstar_refl_inspect_lb1 -let (fstar_refl_pack_lb : refl_constant) = - match uu___6 with - | (fstar_refl_inspect_lb1, fstar_refl_pack_lb1) -> fstar_refl_pack_lb1 -let (uu___7 : (refl_constant * refl_constant)) = - mk_inspect_pack_pair "_universe" -let (fstar_refl_inspect_universe : refl_constant) = - match uu___7 with - | (fstar_refl_inspect_universe1, fstar_refl_pack_universe) -> - fstar_refl_inspect_universe1 -let (fstar_refl_pack_universe : refl_constant) = - match uu___7 with - | (fstar_refl_inspect_universe1, fstar_refl_pack_universe1) -> - fstar_refl_pack_universe1 -let (fstar_refl_env : FStar_Syntax_Syntax.term) = - mk_refl_types_lid_as_term "env" -let (fstar_refl_env_fv : FStar_Syntax_Syntax.fv) = - mk_refl_types_lid_as_fv "env" -let (fstar_refl_bv : FStar_Syntax_Syntax.term) = - mk_refl_types_lid_as_term "bv" -let (fstar_refl_bv_fv : FStar_Syntax_Syntax.fv) = - mk_refl_types_lid_as_fv "bv" -let (fstar_refl_fv : FStar_Syntax_Syntax.term) = - mk_refl_types_lid_as_term "fv" -let (fstar_refl_fv_fv : FStar_Syntax_Syntax.fv) = - mk_refl_types_lid_as_fv "fv" -let (fstar_refl_comp : FStar_Syntax_Syntax.term) = - mk_refl_types_lid_as_term "comp" -let (fstar_refl_comp_fv : FStar_Syntax_Syntax.fv) = - mk_refl_types_lid_as_fv "comp" -let (fstar_refl_binder : FStar_Syntax_Syntax.term) = - mk_refl_types_lid_as_term "binder" -let (fstar_refl_binder_fv : FStar_Syntax_Syntax.fv) = - mk_refl_types_lid_as_fv "binder" -let (fstar_refl_sigelt : FStar_Syntax_Syntax.term) = - mk_refl_types_lid_as_term "sigelt" -let (fstar_refl_sigelt_fv : FStar_Syntax_Syntax.fv) = - mk_refl_types_lid_as_fv "sigelt" -let (fstar_refl_term : FStar_Syntax_Syntax.term) = - mk_refl_types_lid_as_term "term" -let (fstar_refl_term_fv : FStar_Syntax_Syntax.fv) = - mk_refl_types_lid_as_fv "term" -let (fstar_refl_letbinding : FStar_Syntax_Syntax.term) = - mk_refl_types_lid_as_term "letbinding" -let (fstar_refl_letbinding_fv : FStar_Syntax_Syntax.fv) = - mk_refl_types_lid_as_fv "letbinding" -let (fstar_refl_ident : FStar_Syntax_Syntax.term) = - mk_refl_types_lid_as_term "ident" -let (fstar_refl_ident_fv : FStar_Syntax_Syntax.fv) = - mk_refl_types_lid_as_fv "ident" -let (fstar_refl_univ_name : FStar_Syntax_Syntax.term) = - mk_refl_types_lid_as_term "univ_name" -let (fstar_refl_univ_name_fv : FStar_Syntax_Syntax.fv) = - mk_refl_types_lid_as_fv "univ_name" -let (fstar_refl_optionstate : FStar_Syntax_Syntax.term) = - mk_refl_types_lid_as_term "optionstate" -let (fstar_refl_optionstate_fv : FStar_Syntax_Syntax.fv) = - mk_refl_types_lid_as_fv "optionstate" -let (fstar_refl_universe : FStar_Syntax_Syntax.term) = - mk_refl_types_lid_as_term "universe" -let (fstar_refl_universe_fv : FStar_Syntax_Syntax.fv) = - mk_refl_types_lid_as_fv "universe" -let (fstar_refl_aqualv : FStar_Syntax_Syntax.term) = - mk_refl_data_lid_as_term "aqualv" -let (fstar_refl_aqualv_fv : FStar_Syntax_Syntax.fv) = - mk_refl_data_lid_as_fv "aqualv" -let (fstar_refl_comp_view : FStar_Syntax_Syntax.term) = - mk_refl_data_lid_as_term "comp_view" -let (fstar_refl_comp_view_fv : FStar_Syntax_Syntax.fv) = - mk_refl_data_lid_as_fv "comp_view" -let (fstar_refl_term_view : FStar_Syntax_Syntax.term) = - mk_refl_data_lid_as_term "term_view" -let (fstar_refl_term_view_fv : FStar_Syntax_Syntax.fv) = - mk_refl_data_lid_as_fv "term_view" -let (fstar_refl_pattern : FStar_Syntax_Syntax.term) = - mk_refl_data_lid_as_term "pattern" -let (fstar_refl_pattern_fv : FStar_Syntax_Syntax.fv) = - mk_refl_data_lid_as_fv "pattern" -let (fstar_refl_branch : FStar_Syntax_Syntax.term) = - mk_refl_data_lid_as_term "branch" -let (fstar_refl_branch_fv : FStar_Syntax_Syntax.fv) = - mk_refl_data_lid_as_fv "branch" -let (fstar_refl_bv_view : FStar_Syntax_Syntax.term) = - mk_refl_data_lid_as_term "bv_view" -let (fstar_refl_bv_view_fv : FStar_Syntax_Syntax.fv) = - mk_refl_data_lid_as_fv "bv_view" -let (fstar_refl_binder_view : FStar_Syntax_Syntax.term) = - mk_refl_data_lid_as_term "binder_view" -let (fstar_refl_binder_view_fv : FStar_Syntax_Syntax.fv) = - mk_refl_data_lid_as_fv "binder_view" -let (fstar_refl_vconst : FStar_Syntax_Syntax.term) = - mk_refl_data_lid_as_term "vconst" -let (fstar_refl_vconst_fv : FStar_Syntax_Syntax.fv) = - mk_refl_data_lid_as_fv "vconst" -let (fstar_refl_lb_view : FStar_Syntax_Syntax.term) = - mk_refl_data_lid_as_term "lb_view" -let (fstar_refl_lb_view_fv : FStar_Syntax_Syntax.fv) = - mk_refl_data_lid_as_fv "lb_view" -let (fstar_refl_sigelt_view : FStar_Syntax_Syntax.term) = - mk_refl_data_lid_as_term "sigelt_view" -let (fstar_refl_sigelt_view_fv : FStar_Syntax_Syntax.fv) = - mk_refl_data_lid_as_fv "sigelt_view" -let (fstar_refl_qualifier : FStar_Syntax_Syntax.term) = - mk_refl_data_lid_as_term "qualifier" -let (fstar_refl_qualifier_fv : FStar_Syntax_Syntax.fv) = - mk_refl_data_lid_as_fv "qualifier" -let (fstar_refl_universe_view : FStar_Syntax_Syntax.term) = - mk_refl_data_lid_as_term "universe_view" -let (fstar_refl_universe_view_fv : FStar_Syntax_Syntax.fv) = - mk_refl_data_lid_as_fv "universe_view" -let (ref_Mk_bv : refl_constant) = - let lid = fstar_refl_data_lid "Mkbv_view" in - let attr = - let uu___ = - let uu___8 = fstar_refl_data_lid "bv_view" in - let uu___9 = - let uu___10 = - FStar_Ident.mk_ident - ("bv_ppname", FStar_Compiler_Range_Type.dummyRange) in - let uu___11 = - let uu___12 = - FStar_Ident.mk_ident - ("bv_index", FStar_Compiler_Range_Type.dummyRange) in - [uu___12] in - uu___10 :: uu___11 in - (uu___8, uu___9) in - FStar_Syntax_Syntax.Record_ctor uu___ in - let fv = - FStar_Syntax_Syntax.lid_as_fv lid (FStar_Pervasives_Native.Some attr) in - let uu___ = FStar_Syntax_Syntax.fv_to_tm fv in { lid; fv; t = uu___ } -let (ref_Mk_binder : refl_constant) = - let lid = fstar_refl_data_lid "Mkbinder_view" in - let attr = - let uu___ = - let uu___8 = fstar_refl_data_lid "binder_view" in - let uu___9 = - let uu___10 = - FStar_Ident.mk_ident - ("binder_bv", FStar_Compiler_Range_Type.dummyRange) in - let uu___11 = - let uu___12 = - FStar_Ident.mk_ident - ("binder_qual", FStar_Compiler_Range_Type.dummyRange) in - let uu___13 = - let uu___14 = - FStar_Ident.mk_ident - ("binder_attrs", FStar_Compiler_Range_Type.dummyRange) in - let uu___15 = - let uu___16 = - FStar_Ident.mk_ident - ("binder_sort", FStar_Compiler_Range_Type.dummyRange) in - [uu___16] in - uu___14 :: uu___15 in - uu___12 :: uu___13 in - uu___10 :: uu___11 in - (uu___8, uu___9) in - FStar_Syntax_Syntax.Record_ctor uu___ in - let fv = - FStar_Syntax_Syntax.lid_as_fv lid (FStar_Pervasives_Native.Some attr) in - let uu___ = FStar_Syntax_Syntax.fv_to_tm fv in { lid; fv; t = uu___ } -let (ref_Mk_lb : refl_constant) = - let lid = fstar_refl_data_lid "Mklb_view" in - let attr = - let uu___ = - let uu___8 = fstar_refl_data_lid "lb_view" in - let uu___9 = - let uu___10 = - FStar_Ident.mk_ident - ("lb_fv", FStar_Compiler_Range_Type.dummyRange) in - let uu___11 = - let uu___12 = - FStar_Ident.mk_ident - ("lb_us", FStar_Compiler_Range_Type.dummyRange) in - let uu___13 = - let uu___14 = - FStar_Ident.mk_ident - ("lb_typ", FStar_Compiler_Range_Type.dummyRange) in - let uu___15 = - let uu___16 = - FStar_Ident.mk_ident - ("lb_def", FStar_Compiler_Range_Type.dummyRange) in - [uu___16] in - uu___14 :: uu___15 in - uu___12 :: uu___13 in - uu___10 :: uu___11 in - (uu___8, uu___9) in - FStar_Syntax_Syntax.Record_ctor uu___ in - let fv = - FStar_Syntax_Syntax.lid_as_fv lid (FStar_Pervasives_Native.Some attr) in - let uu___ = FStar_Syntax_Syntax.fv_to_tm fv in { lid; fv; t = uu___ } -let (ref_Q_Explicit : refl_constant) = fstar_refl_data_const "Q_Explicit" -let (ref_Q_Implicit : refl_constant) = fstar_refl_data_const "Q_Implicit" -let (ref_Q_Meta : refl_constant) = fstar_refl_data_const "Q_Meta" -let (ref_C_Unit : refl_constant) = fstar_refl_data_const "C_Unit" -let (ref_C_True : refl_constant) = fstar_refl_data_const "C_True" -let (ref_C_False : refl_constant) = fstar_refl_data_const "C_False" -let (ref_C_Int : refl_constant) = fstar_refl_data_const "C_Int" -let (ref_C_String : refl_constant) = fstar_refl_data_const "C_String" -let (ref_C_Range : refl_constant) = fstar_refl_data_const "C_Range" -let (ref_C_Reify : refl_constant) = fstar_refl_data_const "C_Reify" -let (ref_C_Reflect : refl_constant) = fstar_refl_data_const "C_Reflect" -let (ref_Pat_Constant : refl_constant) = fstar_refl_data_const "Pat_Constant" -let (ref_Pat_Cons : refl_constant) = fstar_refl_data_const "Pat_Cons" -let (ref_Pat_Var : refl_constant) = fstar_refl_data_const "Pat_Var" -let (ref_Pat_Dot_Term : refl_constant) = fstar_refl_data_const "Pat_Dot_Term" -let (ref_Uv_Zero : refl_constant) = fstar_refl_data_const "Uv_Zero" -let (ref_Uv_Succ : refl_constant) = fstar_refl_data_const "Uv_Succ" -let (ref_Uv_Max : refl_constant) = fstar_refl_data_const "Uv_Max" -let (ref_Uv_BVar : refl_constant) = fstar_refl_data_const "Uv_BVar" -let (ref_Uv_Name : refl_constant) = fstar_refl_data_const "Uv_Name" -let (ref_Uv_Unif : refl_constant) = fstar_refl_data_const "Uv_Unif" -let (ref_Uv_Unk : refl_constant) = fstar_refl_data_const "Uv_Unk" -let (ref_Tv_Var : refl_constant) = fstar_refl_data_const "Tv_Var" -let (ref_Tv_BVar : refl_constant) = fstar_refl_data_const "Tv_BVar" -let (ref_Tv_FVar : refl_constant) = fstar_refl_data_const "Tv_FVar" -let (ref_Tv_UInst : refl_constant) = fstar_refl_data_const "Tv_UInst" -let (ref_Tv_App : refl_constant) = fstar_refl_data_const "Tv_App" -let (ref_Tv_Abs : refl_constant) = fstar_refl_data_const "Tv_Abs" -let (ref_Tv_Arrow : refl_constant) = fstar_refl_data_const "Tv_Arrow" -let (ref_Tv_Type : refl_constant) = fstar_refl_data_const "Tv_Type" -let (ref_Tv_Refine : refl_constant) = fstar_refl_data_const "Tv_Refine" -let (ref_Tv_Const : refl_constant) = fstar_refl_data_const "Tv_Const" -let (ref_Tv_Uvar : refl_constant) = fstar_refl_data_const "Tv_Uvar" -let (ref_Tv_Let : refl_constant) = fstar_refl_data_const "Tv_Let" -let (ref_Tv_Match : refl_constant) = fstar_refl_data_const "Tv_Match" -let (ref_Tv_AscT : refl_constant) = fstar_refl_data_const "Tv_AscribedT" -let (ref_Tv_AscC : refl_constant) = fstar_refl_data_const "Tv_AscribedC" -let (ref_Tv_Unknown : refl_constant) = fstar_refl_data_const "Tv_Unknown" -let (ref_Tv_Unsupp : refl_constant) = fstar_refl_data_const "Tv_Unsupp" -let (ref_C_Total : refl_constant) = fstar_refl_data_const "C_Total" -let (ref_C_GTotal : refl_constant) = fstar_refl_data_const "C_GTotal" -let (ref_C_Lemma : refl_constant) = fstar_refl_data_const "C_Lemma" -let (ref_C_Eff : refl_constant) = fstar_refl_data_const "C_Eff" -let (ref_Sg_Let : refl_constant) = fstar_refl_data_const "Sg_Let" -let (ref_Sg_Inductive : refl_constant) = fstar_refl_data_const "Sg_Inductive" -let (ref_Sg_Val : refl_constant) = fstar_refl_data_const "Sg_Val" -let (ref_Unk : refl_constant) = fstar_refl_data_const "Unk" -let (ref_qual_Assumption : refl_constant) = - fstar_refl_data_const "Assumption" -let (ref_qual_InternalAssumption : refl_constant) = - fstar_refl_data_const "InternalAssumption" -let (ref_qual_New : refl_constant) = fstar_refl_data_const "New" -let (ref_qual_Private : refl_constant) = fstar_refl_data_const "Private" -let (ref_qual_Unfold_for_unification_and_vcgen : refl_constant) = - fstar_refl_data_const "Unfold_for_unification_and_vcgen" -let (ref_qual_Visible_default : refl_constant) = - fstar_refl_data_const "Visible_default" -let (ref_qual_Irreducible : refl_constant) = - fstar_refl_data_const "Irreducible" -let (ref_qual_Inline_for_extraction : refl_constant) = - fstar_refl_data_const "Inline_for_extraction" -let (ref_qual_NoExtract : refl_constant) = fstar_refl_data_const "NoExtract" -let (ref_qual_Noeq : refl_constant) = fstar_refl_data_const "Noeq" -let (ref_qual_Unopteq : refl_constant) = fstar_refl_data_const "Unopteq" -let (ref_qual_TotalEffect : refl_constant) = - fstar_refl_data_const "TotalEffect" -let (ref_qual_Logic : refl_constant) = fstar_refl_data_const "Logic" -let (ref_qual_Reifiable : refl_constant) = fstar_refl_data_const "Reifiable" -let (ref_qual_Reflectable : refl_constant) = - fstar_refl_data_const "Reflectable" -let (ref_qual_Discriminator : refl_constant) = - fstar_refl_data_const "Discriminator" -let (ref_qual_Projector : refl_constant) = fstar_refl_data_const "Projector" -let (ref_qual_RecordType : refl_constant) = - fstar_refl_data_const "RecordType" -let (ref_qual_RecordConstructor : refl_constant) = - fstar_refl_data_const "RecordConstructor" -let (ref_qual_Action : refl_constant) = fstar_refl_data_const "Action" -let (ref_qual_ExceptionConstructor : refl_constant) = - fstar_refl_data_const "ExceptionConstructor" -let (ref_qual_HasMaskedEffect : refl_constant) = - fstar_refl_data_const "HasMaskedEffect" -let (ref_qual_Effect : refl_constant) = fstar_refl_data_const "Effect" -let (ref_qual_OnlyName : refl_constant) = fstar_refl_data_const "OnlyName" \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Reflection_V1_Data.ml b/ocaml/fstar-lib/generated/FStar_Reflection_V1_Data.ml deleted file mode 100644 index c6967b9c243..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Reflection_V1_Data.ml +++ /dev/null @@ -1,470 +0,0 @@ -open Prims -type name = Prims.string Prims.list -type typ = FStar_Syntax_Syntax.term -type binders = FStar_Syntax_Syntax.binder Prims.list -type ident = (Prims.string * FStar_Compiler_Range_Type.range) -type univ_name = ident -type vconst = - | C_Unit - | C_Int of FStar_BigInt.t - | C_True - | C_False - | C_String of Prims.string - | C_Range of FStar_Compiler_Range_Type.range - | C_Reify - | C_Reflect of name -let (uu___is_C_Unit : vconst -> Prims.bool) = - fun projectee -> match projectee with | C_Unit -> true | uu___ -> false -let (uu___is_C_Int : vconst -> Prims.bool) = - fun projectee -> match projectee with | C_Int _0 -> true | uu___ -> false -let (__proj__C_Int__item___0 : vconst -> FStar_BigInt.t) = - fun projectee -> match projectee with | C_Int _0 -> _0 -let (uu___is_C_True : vconst -> Prims.bool) = - fun projectee -> match projectee with | C_True -> true | uu___ -> false -let (uu___is_C_False : vconst -> Prims.bool) = - fun projectee -> match projectee with | C_False -> true | uu___ -> false -let (uu___is_C_String : vconst -> Prims.bool) = - fun projectee -> - match projectee with | C_String _0 -> true | uu___ -> false -let (__proj__C_String__item___0 : vconst -> Prims.string) = - fun projectee -> match projectee with | C_String _0 -> _0 -let (uu___is_C_Range : vconst -> Prims.bool) = - fun projectee -> match projectee with | C_Range _0 -> true | uu___ -> false -let (__proj__C_Range__item___0 : vconst -> FStar_Compiler_Range_Type.range) = - fun projectee -> match projectee with | C_Range _0 -> _0 -let (uu___is_C_Reify : vconst -> Prims.bool) = - fun projectee -> match projectee with | C_Reify -> true | uu___ -> false -let (uu___is_C_Reflect : vconst -> Prims.bool) = - fun projectee -> - match projectee with | C_Reflect _0 -> true | uu___ -> false -let (__proj__C_Reflect__item___0 : vconst -> name) = - fun projectee -> match projectee with | C_Reflect _0 -> _0 -type universes = FStar_Syntax_Syntax.universe Prims.list -type pattern = - | Pat_Constant of vconst - | Pat_Cons of (FStar_Syntax_Syntax.fv * FStar_Syntax_Syntax.universe - Prims.list FStar_Pervasives_Native.option * (pattern * Prims.bool) - Prims.list) - | Pat_Var of (FStar_Syntax_Syntax.bv * typ FStar_Compiler_Sealed.sealed) - | Pat_Dot_Term of FStar_Syntax_Syntax.term FStar_Pervasives_Native.option -let (uu___is_Pat_Constant : pattern -> Prims.bool) = - fun projectee -> - match projectee with | Pat_Constant _0 -> true | uu___ -> false -let (__proj__Pat_Constant__item___0 : pattern -> vconst) = - fun projectee -> match projectee with | Pat_Constant _0 -> _0 -let (uu___is_Pat_Cons : pattern -> Prims.bool) = - fun projectee -> - match projectee with | Pat_Cons _0 -> true | uu___ -> false -let (__proj__Pat_Cons__item___0 : - pattern -> - (FStar_Syntax_Syntax.fv * FStar_Syntax_Syntax.universe Prims.list - FStar_Pervasives_Native.option * (pattern * Prims.bool) Prims.list)) - = fun projectee -> match projectee with | Pat_Cons _0 -> _0 -let (uu___is_Pat_Var : pattern -> Prims.bool) = - fun projectee -> match projectee with | Pat_Var _0 -> true | uu___ -> false -let (__proj__Pat_Var__item___0 : - pattern -> (FStar_Syntax_Syntax.bv * typ FStar_Compiler_Sealed.sealed)) = - fun projectee -> match projectee with | Pat_Var _0 -> _0 -let (uu___is_Pat_Dot_Term : pattern -> Prims.bool) = - fun projectee -> - match projectee with | Pat_Dot_Term _0 -> true | uu___ -> false -let (__proj__Pat_Dot_Term__item___0 : - pattern -> FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) = - fun projectee -> match projectee with | Pat_Dot_Term _0 -> _0 -type branch = (pattern * FStar_Syntax_Syntax.term) -type aqualv = - | Q_Implicit - | Q_Explicit - | Q_Meta of FStar_Syntax_Syntax.term -let (uu___is_Q_Implicit : aqualv -> Prims.bool) = - fun projectee -> match projectee with | Q_Implicit -> true | uu___ -> false -let (uu___is_Q_Explicit : aqualv -> Prims.bool) = - fun projectee -> match projectee with | Q_Explicit -> true | uu___ -> false -let (uu___is_Q_Meta : aqualv -> Prims.bool) = - fun projectee -> match projectee with | Q_Meta _0 -> true | uu___ -> false -let (__proj__Q_Meta__item___0 : aqualv -> FStar_Syntax_Syntax.term) = - fun projectee -> match projectee with | Q_Meta _0 -> _0 -type argv = (FStar_Syntax_Syntax.term * aqualv) -type ppname_t = Prims.string FStar_Compiler_Sealed.sealed -let (as_ppname : Prims.string -> ppname_t) = - fun x -> FStar_Compiler_Sealed.seal x -type bv_view = { - bv_ppname: ppname_t ; - bv_index: FStar_BigInt.t } -let (__proj__Mkbv_view__item__bv_ppname : bv_view -> ppname_t) = - fun projectee -> - match projectee with | { bv_ppname; bv_index;_} -> bv_ppname -let (__proj__Mkbv_view__item__bv_index : bv_view -> FStar_BigInt.t) = - fun projectee -> - match projectee with | { bv_ppname; bv_index;_} -> bv_index -type binder_view = - { - binder_bv: FStar_Syntax_Syntax.bv ; - binder_qual: aqualv ; - binder_attrs: FStar_Syntax_Syntax.term Prims.list ; - binder_sort: typ } -let (__proj__Mkbinder_view__item__binder_bv : - binder_view -> FStar_Syntax_Syntax.bv) = - fun projectee -> - match projectee with - | { binder_bv; binder_qual; binder_attrs; binder_sort;_} -> binder_bv -let (__proj__Mkbinder_view__item__binder_qual : binder_view -> aqualv) = - fun projectee -> - match projectee with - | { binder_bv; binder_qual; binder_attrs; binder_sort;_} -> binder_qual -let (__proj__Mkbinder_view__item__binder_attrs : - binder_view -> FStar_Syntax_Syntax.term Prims.list) = - fun projectee -> - match projectee with - | { binder_bv; binder_qual; binder_attrs; binder_sort;_} -> binder_attrs -let (__proj__Mkbinder_view__item__binder_sort : binder_view -> typ) = - fun projectee -> - match projectee with - | { binder_bv; binder_qual; binder_attrs; binder_sort;_} -> binder_sort -type universe_view = - | Uv_Zero - | Uv_Succ of FStar_Syntax_Syntax.universe - | Uv_Max of universes - | Uv_BVar of FStar_BigInt.t - | Uv_Name of (Prims.string * FStar_Compiler_Range_Type.range) - | Uv_Unif of FStar_Syntax_Syntax.universe_uvar - | Uv_Unk -let (uu___is_Uv_Zero : universe_view -> Prims.bool) = - fun projectee -> match projectee with | Uv_Zero -> true | uu___ -> false -let (uu___is_Uv_Succ : universe_view -> Prims.bool) = - fun projectee -> match projectee with | Uv_Succ _0 -> true | uu___ -> false -let (__proj__Uv_Succ__item___0 : - universe_view -> FStar_Syntax_Syntax.universe) = - fun projectee -> match projectee with | Uv_Succ _0 -> _0 -let (uu___is_Uv_Max : universe_view -> Prims.bool) = - fun projectee -> match projectee with | Uv_Max _0 -> true | uu___ -> false -let (__proj__Uv_Max__item___0 : universe_view -> universes) = - fun projectee -> match projectee with | Uv_Max _0 -> _0 -let (uu___is_Uv_BVar : universe_view -> Prims.bool) = - fun projectee -> match projectee with | Uv_BVar _0 -> true | uu___ -> false -let (__proj__Uv_BVar__item___0 : universe_view -> FStar_BigInt.t) = - fun projectee -> match projectee with | Uv_BVar _0 -> _0 -let (uu___is_Uv_Name : universe_view -> Prims.bool) = - fun projectee -> match projectee with | Uv_Name _0 -> true | uu___ -> false -let (__proj__Uv_Name__item___0 : - universe_view -> (Prims.string * FStar_Compiler_Range_Type.range)) = - fun projectee -> match projectee with | Uv_Name _0 -> _0 -let (uu___is_Uv_Unif : universe_view -> Prims.bool) = - fun projectee -> match projectee with | Uv_Unif _0 -> true | uu___ -> false -let (__proj__Uv_Unif__item___0 : - universe_view -> FStar_Syntax_Syntax.universe_uvar) = - fun projectee -> match projectee with | Uv_Unif _0 -> _0 -let (uu___is_Uv_Unk : universe_view -> Prims.bool) = - fun projectee -> match projectee with | Uv_Unk -> true | uu___ -> false -type term_view = - | Tv_Var of FStar_Syntax_Syntax.bv - | Tv_BVar of FStar_Syntax_Syntax.bv - | Tv_FVar of FStar_Syntax_Syntax.fv - | Tv_UInst of (FStar_Syntax_Syntax.fv * universes) - | Tv_App of (FStar_Syntax_Syntax.term * argv) - | Tv_Abs of (FStar_Syntax_Syntax.binder * FStar_Syntax_Syntax.term) - | Tv_Arrow of (FStar_Syntax_Syntax.binder * FStar_Syntax_Syntax.comp) - | Tv_Type of FStar_Syntax_Syntax.universe - | Tv_Refine of (FStar_Syntax_Syntax.bv * typ * FStar_Syntax_Syntax.term) - | Tv_Const of vconst - | Tv_Uvar of (FStar_BigInt.t * FStar_Syntax_Syntax.ctx_uvar_and_subst) - | Tv_Let of (Prims.bool * FStar_Syntax_Syntax.term Prims.list * - FStar_Syntax_Syntax.bv * typ * FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.term) - | Tv_Match of (FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.match_returns_ascription FStar_Pervasives_Native.option - * branch Prims.list) - | Tv_AscribedT of (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option * Prims.bool) - | Tv_AscribedC of (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.comp * - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option * Prims.bool) - | Tv_Unknown - | Tv_Unsupp -let (uu___is_Tv_Var : term_view -> Prims.bool) = - fun projectee -> match projectee with | Tv_Var _0 -> true | uu___ -> false -let (__proj__Tv_Var__item___0 : term_view -> FStar_Syntax_Syntax.bv) = - fun projectee -> match projectee with | Tv_Var _0 -> _0 -let (uu___is_Tv_BVar : term_view -> Prims.bool) = - fun projectee -> match projectee with | Tv_BVar _0 -> true | uu___ -> false -let (__proj__Tv_BVar__item___0 : term_view -> FStar_Syntax_Syntax.bv) = - fun projectee -> match projectee with | Tv_BVar _0 -> _0 -let (uu___is_Tv_FVar : term_view -> Prims.bool) = - fun projectee -> match projectee with | Tv_FVar _0 -> true | uu___ -> false -let (__proj__Tv_FVar__item___0 : term_view -> FStar_Syntax_Syntax.fv) = - fun projectee -> match projectee with | Tv_FVar _0 -> _0 -let (uu___is_Tv_UInst : term_view -> Prims.bool) = - fun projectee -> - match projectee with | Tv_UInst _0 -> true | uu___ -> false -let (__proj__Tv_UInst__item___0 : - term_view -> (FStar_Syntax_Syntax.fv * universes)) = - fun projectee -> match projectee with | Tv_UInst _0 -> _0 -let (uu___is_Tv_App : term_view -> Prims.bool) = - fun projectee -> match projectee with | Tv_App _0 -> true | uu___ -> false -let (__proj__Tv_App__item___0 : - term_view -> (FStar_Syntax_Syntax.term * argv)) = - fun projectee -> match projectee with | Tv_App _0 -> _0 -let (uu___is_Tv_Abs : term_view -> Prims.bool) = - fun projectee -> match projectee with | Tv_Abs _0 -> true | uu___ -> false -let (__proj__Tv_Abs__item___0 : - term_view -> (FStar_Syntax_Syntax.binder * FStar_Syntax_Syntax.term)) = - fun projectee -> match projectee with | Tv_Abs _0 -> _0 -let (uu___is_Tv_Arrow : term_view -> Prims.bool) = - fun projectee -> - match projectee with | Tv_Arrow _0 -> true | uu___ -> false -let (__proj__Tv_Arrow__item___0 : - term_view -> (FStar_Syntax_Syntax.binder * FStar_Syntax_Syntax.comp)) = - fun projectee -> match projectee with | Tv_Arrow _0 -> _0 -let (uu___is_Tv_Type : term_view -> Prims.bool) = - fun projectee -> match projectee with | Tv_Type _0 -> true | uu___ -> false -let (__proj__Tv_Type__item___0 : term_view -> FStar_Syntax_Syntax.universe) = - fun projectee -> match projectee with | Tv_Type _0 -> _0 -let (uu___is_Tv_Refine : term_view -> Prims.bool) = - fun projectee -> - match projectee with | Tv_Refine _0 -> true | uu___ -> false -let (__proj__Tv_Refine__item___0 : - term_view -> (FStar_Syntax_Syntax.bv * typ * FStar_Syntax_Syntax.term)) = - fun projectee -> match projectee with | Tv_Refine _0 -> _0 -let (uu___is_Tv_Const : term_view -> Prims.bool) = - fun projectee -> - match projectee with | Tv_Const _0 -> true | uu___ -> false -let (__proj__Tv_Const__item___0 : term_view -> vconst) = - fun projectee -> match projectee with | Tv_Const _0 -> _0 -let (uu___is_Tv_Uvar : term_view -> Prims.bool) = - fun projectee -> match projectee with | Tv_Uvar _0 -> true | uu___ -> false -let (__proj__Tv_Uvar__item___0 : - term_view -> (FStar_BigInt.t * FStar_Syntax_Syntax.ctx_uvar_and_subst)) = - fun projectee -> match projectee with | Tv_Uvar _0 -> _0 -let (uu___is_Tv_Let : term_view -> Prims.bool) = - fun projectee -> match projectee with | Tv_Let _0 -> true | uu___ -> false -let (__proj__Tv_Let__item___0 : - term_view -> - (Prims.bool * FStar_Syntax_Syntax.term Prims.list * - FStar_Syntax_Syntax.bv * typ * FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.term)) - = fun projectee -> match projectee with | Tv_Let _0 -> _0 -let (uu___is_Tv_Match : term_view -> Prims.bool) = - fun projectee -> - match projectee with | Tv_Match _0 -> true | uu___ -> false -let (__proj__Tv_Match__item___0 : - term_view -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.match_returns_ascription - FStar_Pervasives_Native.option * branch Prims.list)) - = fun projectee -> match projectee with | Tv_Match _0 -> _0 -let (uu___is_Tv_AscribedT : term_view -> Prims.bool) = - fun projectee -> - match projectee with | Tv_AscribedT _0 -> true | uu___ -> false -let (__proj__Tv_AscribedT__item___0 : - term_view -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option * Prims.bool)) - = fun projectee -> match projectee with | Tv_AscribedT _0 -> _0 -let (uu___is_Tv_AscribedC : term_view -> Prims.bool) = - fun projectee -> - match projectee with | Tv_AscribedC _0 -> true | uu___ -> false -let (__proj__Tv_AscribedC__item___0 : - term_view -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.comp * - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option * Prims.bool)) - = fun projectee -> match projectee with | Tv_AscribedC _0 -> _0 -let (uu___is_Tv_Unknown : term_view -> Prims.bool) = - fun projectee -> match projectee with | Tv_Unknown -> true | uu___ -> false -let (uu___is_Tv_Unsupp : term_view -> Prims.bool) = - fun projectee -> match projectee with | Tv_Unsupp -> true | uu___ -> false -let (notAscription : term_view -> Prims.bool) = - fun tv -> - (Prims.op_Negation (uu___is_Tv_AscribedT tv)) && - (Prims.op_Negation (uu___is_Tv_AscribedC tv)) -type comp_view = - | C_Total of typ - | C_GTotal of typ - | C_Lemma of (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.term) - | C_Eff of (universes * name * FStar_Syntax_Syntax.term * argv Prims.list * - FStar_Syntax_Syntax.term Prims.list) -let (uu___is_C_Total : comp_view -> Prims.bool) = - fun projectee -> match projectee with | C_Total _0 -> true | uu___ -> false -let (__proj__C_Total__item___0 : comp_view -> typ) = - fun projectee -> match projectee with | C_Total _0 -> _0 -let (uu___is_C_GTotal : comp_view -> Prims.bool) = - fun projectee -> - match projectee with | C_GTotal _0 -> true | uu___ -> false -let (__proj__C_GTotal__item___0 : comp_view -> typ) = - fun projectee -> match projectee with | C_GTotal _0 -> _0 -let (uu___is_C_Lemma : comp_view -> Prims.bool) = - fun projectee -> match projectee with | C_Lemma _0 -> true | uu___ -> false -let (__proj__C_Lemma__item___0 : - comp_view -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.term)) - = fun projectee -> match projectee with | C_Lemma _0 -> _0 -let (uu___is_C_Eff : comp_view -> Prims.bool) = - fun projectee -> match projectee with | C_Eff _0 -> true | uu___ -> false -let (__proj__C_Eff__item___0 : - comp_view -> - (universes * name * FStar_Syntax_Syntax.term * argv Prims.list * - FStar_Syntax_Syntax.term Prims.list)) - = fun projectee -> match projectee with | C_Eff _0 -> _0 -type ctor = (name * typ) -type lb_view = - { - lb_fv: FStar_Syntax_Syntax.fv ; - lb_us: univ_name Prims.list ; - lb_typ: typ ; - lb_def: FStar_Syntax_Syntax.term } -let (__proj__Mklb_view__item__lb_fv : lb_view -> FStar_Syntax_Syntax.fv) = - fun projectee -> - match projectee with | { lb_fv; lb_us; lb_typ; lb_def;_} -> lb_fv -let (__proj__Mklb_view__item__lb_us : lb_view -> univ_name Prims.list) = - fun projectee -> - match projectee with | { lb_fv; lb_us; lb_typ; lb_def;_} -> lb_us -let (__proj__Mklb_view__item__lb_typ : lb_view -> typ) = - fun projectee -> - match projectee with | { lb_fv; lb_us; lb_typ; lb_def;_} -> lb_typ -let (__proj__Mklb_view__item__lb_def : lb_view -> FStar_Syntax_Syntax.term) = - fun projectee -> - match projectee with | { lb_fv; lb_us; lb_typ; lb_def;_} -> lb_def -type sigelt_view = - | Sg_Let of (Prims.bool * FStar_Syntax_Syntax.letbinding Prims.list) - | Sg_Inductive of (name * univ_name Prims.list * FStar_Syntax_Syntax.binder - Prims.list * typ * ctor Prims.list) - | Sg_Val of (name * univ_name Prims.list * typ) - | Unk -let (uu___is_Sg_Let : sigelt_view -> Prims.bool) = - fun projectee -> match projectee with | Sg_Let _0 -> true | uu___ -> false -let (__proj__Sg_Let__item___0 : - sigelt_view -> (Prims.bool * FStar_Syntax_Syntax.letbinding Prims.list)) = - fun projectee -> match projectee with | Sg_Let _0 -> _0 -let (uu___is_Sg_Inductive : sigelt_view -> Prims.bool) = - fun projectee -> - match projectee with | Sg_Inductive _0 -> true | uu___ -> false -let (__proj__Sg_Inductive__item___0 : - sigelt_view -> - (name * univ_name Prims.list * FStar_Syntax_Syntax.binder Prims.list * - typ * ctor Prims.list)) - = fun projectee -> match projectee with | Sg_Inductive _0 -> _0 -let (uu___is_Sg_Val : sigelt_view -> Prims.bool) = - fun projectee -> match projectee with | Sg_Val _0 -> true | uu___ -> false -let (__proj__Sg_Val__item___0 : - sigelt_view -> (name * univ_name Prims.list * typ)) = - fun projectee -> match projectee with | Sg_Val _0 -> _0 -let (uu___is_Unk : sigelt_view -> Prims.bool) = - fun projectee -> match projectee with | Unk -> true | uu___ -> false -type qualifier = - | Assumption - | InternalAssumption - | New - | Private - | Unfold_for_unification_and_vcgen - | Visible_default - | Irreducible - | Inline_for_extraction - | NoExtract - | Noeq - | Unopteq - | TotalEffect - | Logic - | Reifiable - | Reflectable of name - | Discriminator of name - | Projector of (name * ident) - | RecordType of (ident Prims.list * ident Prims.list) - | RecordConstructor of (ident Prims.list * ident Prims.list) - | Action of name - | ExceptionConstructor - | HasMaskedEffect - | Effect - | OnlyName -let (uu___is_Assumption : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Assumption -> true | uu___ -> false -let (uu___is_InternalAssumption : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | InternalAssumption -> true | uu___ -> false -let (uu___is_New : qualifier -> Prims.bool) = - fun projectee -> match projectee with | New -> true | uu___ -> false -let (uu___is_Private : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Private -> true | uu___ -> false -let (uu___is_Unfold_for_unification_and_vcgen : qualifier -> Prims.bool) = - fun projectee -> - match projectee with - | Unfold_for_unification_and_vcgen -> true - | uu___ -> false -let (uu___is_Visible_default : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | Visible_default -> true | uu___ -> false -let (uu___is_Irreducible : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | Irreducible -> true | uu___ -> false -let (uu___is_Inline_for_extraction : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | Inline_for_extraction -> true | uu___ -> false -let (uu___is_NoExtract : qualifier -> Prims.bool) = - fun projectee -> match projectee with | NoExtract -> true | uu___ -> false -let (uu___is_Noeq : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Noeq -> true | uu___ -> false -let (uu___is_Unopteq : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Unopteq -> true | uu___ -> false -let (uu___is_TotalEffect : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | TotalEffect -> true | uu___ -> false -let (uu___is_Logic : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Logic -> true | uu___ -> false -let (uu___is_Reifiable : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Reifiable -> true | uu___ -> false -let (uu___is_Reflectable : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | Reflectable _0 -> true | uu___ -> false -let (__proj__Reflectable__item___0 : qualifier -> name) = - fun projectee -> match projectee with | Reflectable _0 -> _0 -let (uu___is_Discriminator : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | Discriminator _0 -> true | uu___ -> false -let (__proj__Discriminator__item___0 : qualifier -> name) = - fun projectee -> match projectee with | Discriminator _0 -> _0 -let (uu___is_Projector : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | Projector _0 -> true | uu___ -> false -let (__proj__Projector__item___0 : qualifier -> (name * ident)) = - fun projectee -> match projectee with | Projector _0 -> _0 -let (uu___is_RecordType : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | RecordType _0 -> true | uu___ -> false -let (__proj__RecordType__item___0 : - qualifier -> (ident Prims.list * ident Prims.list)) = - fun projectee -> match projectee with | RecordType _0 -> _0 -let (uu___is_RecordConstructor : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | RecordConstructor _0 -> true | uu___ -> false -let (__proj__RecordConstructor__item___0 : - qualifier -> (ident Prims.list * ident Prims.list)) = - fun projectee -> match projectee with | RecordConstructor _0 -> _0 -let (uu___is_Action : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Action _0 -> true | uu___ -> false -let (__proj__Action__item___0 : qualifier -> name) = - fun projectee -> match projectee with | Action _0 -> _0 -let (uu___is_ExceptionConstructor : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | ExceptionConstructor -> true | uu___ -> false -let (uu___is_HasMaskedEffect : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | HasMaskedEffect -> true | uu___ -> false -let (uu___is_Effect : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Effect -> true | uu___ -> false -let (uu___is_OnlyName : qualifier -> Prims.bool) = - fun projectee -> match projectee with | OnlyName -> true | uu___ -> false -type qualifiers = qualifier Prims.list -type var = FStar_BigInt.t -type exp = - | Unit - | Var of var - | Mult of (exp * exp) -let (uu___is_Unit : exp -> Prims.bool) = - fun projectee -> match projectee with | Unit -> true | uu___ -> false -let (uu___is_Var : exp -> Prims.bool) = - fun projectee -> match projectee with | Var _0 -> true | uu___ -> false -let (__proj__Var__item___0 : exp -> var) = - fun projectee -> match projectee with | Var _0 -> _0 -let (uu___is_Mult : exp -> Prims.bool) = - fun projectee -> match projectee with | Mult _0 -> true | uu___ -> false -let (__proj__Mult__item___0 : exp -> (exp * exp)) = - fun projectee -> match projectee with | Mult _0 -> _0 -type decls = FStar_Syntax_Syntax.sigelt Prims.list \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Reflection_V1_Derived.ml b/ocaml/fstar-lib/generated/FStar_Reflection_V1_Derived.ml index e13dacf3ef7..6fa30d46414 100644 --- a/ocaml/fstar-lib/generated/FStar_Reflection_V1_Derived.ml +++ b/ocaml/fstar-lib/generated/FStar_Reflection_V1_Derived.ml @@ -1,74 +1,75 @@ open Prims let (bv_of_binder : - FStar_Reflection_Types.binder -> FStar_Reflection_Types.bv) = + FStarC_Reflection_Types.binder -> FStarC_Reflection_Types.bv) = fun b -> - (FStar_Reflection_V1_Builtins.inspect_binder b).FStar_Reflection_V1_Data.binder_bv + (FStarC_Reflection_V1_Builtins.inspect_binder b).FStarC_Reflection_V1_Data.binder_bv let rec (inspect_ln_unascribe : - FStar_Reflection_Types.term -> FStar_Reflection_V1_Data.term_view) = + FStarC_Reflection_Types.term -> FStarC_Reflection_V1_Data.term_view) = fun t -> - match FStar_Reflection_V1_Builtins.inspect_ln t with - | FStar_Reflection_V1_Data.Tv_AscribedT (t', uu___, uu___1, uu___2) -> + match FStarC_Reflection_V1_Builtins.inspect_ln t with + | FStarC_Reflection_V1_Data.Tv_AscribedT (t', uu___, uu___1, uu___2) -> inspect_ln_unascribe t' - | FStar_Reflection_V1_Data.Tv_AscribedC (t', uu___, uu___1, uu___2) -> + | FStarC_Reflection_V1_Data.Tv_AscribedC (t', uu___, uu___1, uu___2) -> inspect_ln_unascribe t' | tv -> tv let (mk_binder : - FStar_Reflection_Types.bv -> - FStar_Reflection_Types.typ -> FStar_Reflection_Types.binder) + FStarC_Reflection_Types.bv -> + FStarC_Reflection_Types.typ -> FStarC_Reflection_Types.binder) = fun bv -> fun sort -> - FStar_Reflection_V1_Builtins.pack_binder + FStarC_Reflection_V1_Builtins.pack_binder { - FStar_Reflection_V1_Data.binder_bv = bv; - FStar_Reflection_V1_Data.binder_qual = - FStar_Reflection_V1_Data.Q_Explicit; - FStar_Reflection_V1_Data.binder_attrs = []; - FStar_Reflection_V1_Data.binder_sort = sort + FStarC_Reflection_V1_Data.binder_bv = bv; + FStarC_Reflection_V1_Data.binder_qual = + FStarC_Reflection_V1_Data.Q_Explicit; + FStarC_Reflection_V1_Data.binder_attrs = []; + FStarC_Reflection_V1_Data.binder_sort = sort } let (mk_implicit_binder : - FStar_Reflection_Types.bv -> - FStar_Reflection_Types.typ -> FStar_Reflection_Types.binder) + FStarC_Reflection_Types.bv -> + FStarC_Reflection_Types.typ -> FStarC_Reflection_Types.binder) = fun bv -> fun sort -> - FStar_Reflection_V1_Builtins.pack_binder + FStarC_Reflection_V1_Builtins.pack_binder { - FStar_Reflection_V1_Data.binder_bv = bv; - FStar_Reflection_V1_Data.binder_qual = - FStar_Reflection_V1_Data.Q_Implicit; - FStar_Reflection_V1_Data.binder_attrs = []; - FStar_Reflection_V1_Data.binder_sort = sort + FStarC_Reflection_V1_Data.binder_bv = bv; + FStarC_Reflection_V1_Data.binder_qual = + FStarC_Reflection_V1_Data.Q_Implicit; + FStarC_Reflection_V1_Data.binder_attrs = []; + FStarC_Reflection_V1_Data.binder_sort = sort } let (type_of_binder : - FStar_Reflection_Types.binder -> FStar_Reflection_Types.typ) = + FStarC_Reflection_Types.binder -> FStarC_Reflection_Types.typ) = fun b -> - (FStar_Reflection_V1_Builtins.inspect_binder b).FStar_Reflection_V1_Data.binder_sort -let rec (flatten_name : FStar_Reflection_Types.name -> Prims.string) = + (FStarC_Reflection_V1_Builtins.inspect_binder b).FStarC_Reflection_V1_Data.binder_sort +let rec (flatten_name : FStarC_Reflection_Types.name -> Prims.string) = fun ns -> match ns with | [] -> "" | n::[] -> n | n::ns1 -> Prims.strcat n (Prims.strcat "." (flatten_name ns1)) let rec (collect_app_ln' : - FStar_Reflection_V1_Data.argv Prims.list -> - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.term * FStar_Reflection_V1_Data.argv + FStarC_Reflection_V1_Data.argv Prims.list -> + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.term * FStarC_Reflection_V1_Data.argv Prims.list)) = fun args -> fun t -> match inspect_ln_unascribe t with - | FStar_Reflection_V1_Data.Tv_App (l, r) -> + | FStarC_Reflection_V1_Data.Tv_App (l, r) -> collect_app_ln' (r :: args) l | uu___ -> (t, args) let (collect_app_ln : - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.term * FStar_Reflection_V1_Data.argv Prims.list)) + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.term * FStarC_Reflection_V1_Data.argv + Prims.list)) = collect_app_ln' [] let rec (mk_app : - FStar_Reflection_Types.term -> - FStar_Reflection_V1_Data.argv Prims.list -> FStar_Reflection_Types.term) + FStarC_Reflection_Types.term -> + FStarC_Reflection_V1_Data.argv Prims.list -> FStarC_Reflection_Types.term) = fun t -> fun args -> @@ -76,147 +77,152 @@ let rec (mk_app : | [] -> t | x::xs -> mk_app - (FStar_Reflection_V1_Builtins.pack_ln - (FStar_Reflection_V1_Data.Tv_App (t, x))) xs + (FStarC_Reflection_V1_Builtins.pack_ln + (FStarC_Reflection_V1_Data.Tv_App (t, x))) xs let (mk_e_app : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term Prims.list -> FStar_Reflection_Types.term) + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term Prims.list -> FStarC_Reflection_Types.term) = fun t -> fun args -> - let e t1 = (t1, FStar_Reflection_V1_Data.Q_Explicit) in + let e t1 = (t1, FStarC_Reflection_V1_Data.Q_Explicit) in mk_app t (FStar_List_Tot_Base.map e args) -let (u_unk : FStar_Reflection_Types.universe) = - FStar_Reflection_V2_Builtins.pack_universe FStar_Reflection_V2_Data.Uv_Unk +let (u_unk : FStarC_Reflection_Types.universe) = + FStarC_Reflection_V2_Builtins.pack_universe + FStarC_Reflection_V2_Data.Uv_Unk let rec (mk_tot_arr_ln : - FStar_Reflection_Types.binder Prims.list -> - FStar_Reflection_Types.term -> FStar_Reflection_Types.term) + FStarC_Reflection_Types.binder Prims.list -> + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term) = fun bs -> fun cod -> match bs with | [] -> cod | b::bs1 -> - FStar_Reflection_V1_Builtins.pack_ln - (FStar_Reflection_V1_Data.Tv_Arrow + FStarC_Reflection_V1_Builtins.pack_ln + (FStarC_Reflection_V1_Data.Tv_Arrow (b, - (FStar_Reflection_V1_Builtins.pack_comp - (FStar_Reflection_V1_Data.C_Total (mk_tot_arr_ln bs1 cod))))) + (FStarC_Reflection_V1_Builtins.pack_comp + (FStarC_Reflection_V1_Data.C_Total + (mk_tot_arr_ln bs1 cod))))) let rec (collect_arr' : - FStar_Reflection_Types.binder Prims.list -> - FStar_Reflection_Types.comp -> - (FStar_Reflection_Types.binder Prims.list * - FStar_Reflection_Types.comp)) + FStarC_Reflection_Types.binder Prims.list -> + FStarC_Reflection_Types.comp -> + (FStarC_Reflection_Types.binder Prims.list * + FStarC_Reflection_Types.comp)) = fun bs -> fun c -> - match FStar_Reflection_V1_Builtins.inspect_comp c with - | FStar_Reflection_V1_Data.C_Total t -> + match FStarC_Reflection_V1_Builtins.inspect_comp c with + | FStarC_Reflection_V1_Data.C_Total t -> (match inspect_ln_unascribe t with - | FStar_Reflection_V1_Data.Tv_Arrow (b, c1) -> + | FStarC_Reflection_V1_Data.Tv_Arrow (b, c1) -> collect_arr' (b :: bs) c1 | uu___ -> (bs, c)) | uu___ -> (bs, c) let (collect_arr_ln_bs : - FStar_Reflection_Types.typ -> - (FStar_Reflection_Types.binder Prims.list * FStar_Reflection_Types.comp)) + FStarC_Reflection_Types.typ -> + (FStarC_Reflection_Types.binder Prims.list * + FStarC_Reflection_Types.comp)) = fun t -> let uu___ = collect_arr' [] - (FStar_Reflection_V1_Builtins.pack_comp - (FStar_Reflection_V1_Data.C_Total t)) in + (FStarC_Reflection_V1_Builtins.pack_comp + (FStarC_Reflection_V1_Data.C_Total t)) in match uu___ with | (bs, c) -> ((FStar_List_Tot_Base.rev bs), c) let (collect_arr_ln : - FStar_Reflection_Types.typ -> - (FStar_Reflection_Types.typ Prims.list * FStar_Reflection_Types.comp)) + FStarC_Reflection_Types.typ -> + (FStarC_Reflection_Types.typ Prims.list * FStarC_Reflection_Types.comp)) = fun t -> let uu___ = collect_arr_ln_bs t in match uu___ with | (bs, c) -> ((FStar_List_Tot_Base.map type_of_binder bs), c) let rec (collect_abs' : - FStar_Reflection_Types.binder Prims.list -> - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.binder Prims.list * - FStar_Reflection_Types.term)) + FStarC_Reflection_Types.binder Prims.list -> + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.binder Prims.list * + FStarC_Reflection_Types.term)) = fun bs -> fun t -> match inspect_ln_unascribe t with - | FStar_Reflection_V1_Data.Tv_Abs (b, t') -> collect_abs' (b :: bs) t' + | FStarC_Reflection_V1_Data.Tv_Abs (b, t') -> collect_abs' (b :: bs) t' | uu___ -> (bs, t) let (collect_abs_ln : - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.binder Prims.list * FStar_Reflection_Types.term)) + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.binder Prims.list * + FStarC_Reflection_Types.term)) = fun t -> let uu___ = collect_abs' [] t in match uu___ with | (bs, t') -> ((FStar_List_Tot_Base.rev bs), t') -let (fv_to_string : FStar_Reflection_Types.fv -> Prims.string) = +let (fv_to_string : FStarC_Reflection_Types.fv -> Prims.string) = fun fv -> - FStar_Reflection_V1_Builtins.implode_qn - (FStar_Reflection_V1_Builtins.inspect_fv fv) -let (mk_stringlit : Prims.string -> FStar_Reflection_Types.term) = + FStarC_Reflection_V1_Builtins.implode_qn + (FStarC_Reflection_V1_Builtins.inspect_fv fv) +let (mk_stringlit : Prims.string -> FStarC_Reflection_Types.term) = fun s -> - FStar_Reflection_V1_Builtins.pack_ln - (FStar_Reflection_V1_Data.Tv_Const - (FStar_Reflection_V1_Data.C_String s)) + FStarC_Reflection_V1_Builtins.pack_ln + (FStarC_Reflection_V1_Data.Tv_Const + (FStarC_Reflection_V1_Data.C_String s)) let (mk_strcat : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> FStar_Reflection_Types.term) + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term) = fun t1 -> fun t2 -> mk_e_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv ["Prims"; "strcat"]))) + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "strcat"]))) [t1; t2] let (mk_cons : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> FStar_Reflection_Types.term) + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term) = fun h -> fun t -> mk_e_app - (FStar_Reflection_V1_Builtins.pack_ln - (FStar_Reflection_V1_Data.Tv_FVar - (FStar_Reflection_V1_Builtins.pack_fv + (FStarC_Reflection_V1_Builtins.pack_ln + (FStarC_Reflection_V1_Data.Tv_FVar + (FStarC_Reflection_V1_Builtins.pack_fv FStar_Reflection_Const.cons_qn))) [h; t] let (mk_cons_t : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> FStar_Reflection_Types.term) + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term) = fun ty -> fun h -> fun t -> mk_app - (FStar_Reflection_V1_Builtins.pack_ln - (FStar_Reflection_V1_Data.Tv_FVar - (FStar_Reflection_V1_Builtins.pack_fv + (FStarC_Reflection_V1_Builtins.pack_ln + (FStarC_Reflection_V1_Data.Tv_FVar + (FStarC_Reflection_V1_Builtins.pack_fv FStar_Reflection_Const.cons_qn))) - [(ty, FStar_Reflection_V1_Data.Q_Implicit); - (h, FStar_Reflection_V1_Data.Q_Explicit); - (t, FStar_Reflection_V1_Data.Q_Explicit)] + [(ty, FStarC_Reflection_V1_Data.Q_Implicit); + (h, FStarC_Reflection_V1_Data.Q_Explicit); + (t, FStarC_Reflection_V1_Data.Q_Explicit)] let rec (mk_list : - FStar_Reflection_Types.term Prims.list -> FStar_Reflection_Types.term) = + FStarC_Reflection_Types.term Prims.list -> FStarC_Reflection_Types.term) = fun ts -> match ts with | [] -> - FStar_Reflection_V1_Builtins.pack_ln - (FStar_Reflection_V1_Data.Tv_FVar - (FStar_Reflection_V1_Builtins.pack_fv + FStarC_Reflection_V1_Builtins.pack_ln + (FStarC_Reflection_V1_Data.Tv_FVar + (FStarC_Reflection_V1_Builtins.pack_fv FStar_Reflection_Const.nil_qn)) | t::ts1 -> mk_cons t (mk_list ts1) let (mktuple_n : - FStar_Reflection_Types.term Prims.list -> FStar_Reflection_Types.term) = + FStarC_Reflection_Types.term Prims.list -> FStarC_Reflection_Types.term) = fun ts -> match FStar_List_Tot_Base.length ts with | uu___ when uu___ = Prims.int_zero -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const FStar_Reflection_V2_Data.C_Unit) + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const + FStarC_Reflection_V2_Data.C_Unit) | uu___ when uu___ = Prims.int_one -> let uu___1 = ts in (match uu___1 with | x::[] -> x) | n -> @@ -237,22 +243,22 @@ let (mktuple_n : | uu___ when uu___ = (Prims.of_int (8)) -> FStar_Reflection_Const.mktuple8_qn in mk_e_app - (FStar_Reflection_V1_Builtins.pack_ln - (FStar_Reflection_V1_Data.Tv_FVar - (FStar_Reflection_V1_Builtins.pack_fv qn))) ts + (FStarC_Reflection_V1_Builtins.pack_ln + (FStarC_Reflection_V1_Data.Tv_FVar + (FStarC_Reflection_V1_Builtins.pack_fv qn))) ts let (destruct_tuple : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term Prims.list FStar_Pervasives_Native.option) + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term Prims.list FStar_Pervasives_Native.option) = fun t -> let uu___ = collect_app_ln t in match uu___ with | (head, args) -> - (match FStar_Reflection_V1_Builtins.inspect_ln head with - | FStar_Reflection_V1_Data.Tv_FVar fv -> + (match FStarC_Reflection_V1_Builtins.inspect_ln head with + | FStarC_Reflection_V1_Data.Tv_FVar fv -> if FStar_List_Tot_Base.mem - (FStar_Reflection_V1_Builtins.inspect_fv fv) + (FStarC_Reflection_V1_Builtins.inspect_fv fv) [FStar_Reflection_Const.mktuple2_qn; FStar_Reflection_Const.mktuple3_qn; FStar_Reflection_Const.mktuple4_qn; @@ -267,134 +273,137 @@ let (destruct_tuple : match uu___1 with | (t1, q) -> (match q with - | FStar_Reflection_V1_Data.Q_Explicit -> [t1] + | FStarC_Reflection_V1_Data.Q_Explicit -> [t1] | uu___2 -> [])) args) else FStar_Pervasives_Native.None | uu___1 -> FStar_Pervasives_Native.None) let (mkpair : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> FStar_Reflection_Types.term) + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term) = fun t1 -> fun t2 -> mktuple_n [t1; t2] -let rec (head : FStar_Reflection_Types.term -> FStar_Reflection_Types.term) = +let rec (head : FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term) + = fun t -> - match FStar_Reflection_V1_Builtins.inspect_ln t with - | FStar_Reflection_V1_Data.Tv_Match (t1, uu___, uu___1) -> head t1 - | FStar_Reflection_V1_Data.Tv_Let + match FStarC_Reflection_V1_Builtins.inspect_ln t with + | FStarC_Reflection_V1_Data.Tv_Match (t1, uu___, uu___1) -> head t1 + | FStarC_Reflection_V1_Data.Tv_Let (uu___, uu___1, uu___2, uu___3, t1, uu___4) -> head t1 - | FStar_Reflection_V1_Data.Tv_Abs (uu___, t1) -> head t1 - | FStar_Reflection_V1_Data.Tv_Refine (uu___, uu___1, t1) -> head t1 - | FStar_Reflection_V1_Data.Tv_App (t1, uu___) -> head t1 - | FStar_Reflection_V1_Data.Tv_AscribedT (t1, uu___, uu___1, uu___2) -> + | FStarC_Reflection_V1_Data.Tv_Abs (uu___, t1) -> head t1 + | FStarC_Reflection_V1_Data.Tv_Refine (uu___, uu___1, t1) -> head t1 + | FStarC_Reflection_V1_Data.Tv_App (t1, uu___) -> head t1 + | FStarC_Reflection_V1_Data.Tv_AscribedT (t1, uu___, uu___1, uu___2) -> head t1 - | FStar_Reflection_V1_Data.Tv_AscribedC (t1, uu___, uu___1, uu___2) -> + | FStarC_Reflection_V1_Data.Tv_AscribedC (t1, uu___, uu___1, uu___2) -> head t1 - | FStar_Reflection_V1_Data.Tv_Unknown -> t - | FStar_Reflection_V1_Data.Tv_Uvar (uu___, uu___1) -> t - | FStar_Reflection_V1_Data.Tv_Const uu___ -> t - | FStar_Reflection_V1_Data.Tv_Type uu___ -> t - | FStar_Reflection_V1_Data.Tv_Var uu___ -> t - | FStar_Reflection_V1_Data.Tv_BVar uu___ -> t - | FStar_Reflection_V1_Data.Tv_FVar uu___ -> t - | FStar_Reflection_V1_Data.Tv_UInst (uu___, uu___1) -> t - | FStar_Reflection_V1_Data.Tv_Arrow (uu___, uu___1) -> t - | FStar_Reflection_V1_Data.Tv_Unsupp -> t -let (is_fvar : FStar_Reflection_Types.term -> Prims.string -> Prims.bool) = + | FStarC_Reflection_V1_Data.Tv_Unknown -> t + | FStarC_Reflection_V1_Data.Tv_Uvar (uu___, uu___1) -> t + | FStarC_Reflection_V1_Data.Tv_Const uu___ -> t + | FStarC_Reflection_V1_Data.Tv_Type uu___ -> t + | FStarC_Reflection_V1_Data.Tv_Var uu___ -> t + | FStarC_Reflection_V1_Data.Tv_BVar uu___ -> t + | FStarC_Reflection_V1_Data.Tv_FVar uu___ -> t + | FStarC_Reflection_V1_Data.Tv_UInst (uu___, uu___1) -> t + | FStarC_Reflection_V1_Data.Tv_Arrow (uu___, uu___1) -> t + | FStarC_Reflection_V1_Data.Tv_Unsupp -> t +let (is_fvar : FStarC_Reflection_Types.term -> Prims.string -> Prims.bool) = fun t -> fun nm -> match inspect_ln_unascribe t with - | FStar_Reflection_V1_Data.Tv_FVar fv -> - (FStar_Reflection_V1_Builtins.implode_qn - (FStar_Reflection_V1_Builtins.inspect_fv fv)) + | FStarC_Reflection_V1_Data.Tv_FVar fv -> + (FStarC_Reflection_V1_Builtins.implode_qn + (FStarC_Reflection_V1_Builtins.inspect_fv fv)) = nm - | FStar_Reflection_V1_Data.Tv_UInst (fv, uu___) -> - (FStar_Reflection_V1_Builtins.implode_qn - (FStar_Reflection_V1_Builtins.inspect_fv fv)) + | FStarC_Reflection_V1_Data.Tv_UInst (fv, uu___) -> + (FStarC_Reflection_V1_Builtins.implode_qn + (FStarC_Reflection_V1_Builtins.inspect_fv fv)) = nm | uu___ -> false let rec (is_any_fvar : - FStar_Reflection_Types.term -> Prims.string Prims.list -> Prims.bool) = + FStarC_Reflection_Types.term -> Prims.string Prims.list -> Prims.bool) = fun t -> fun nms -> match nms with | [] -> false | v::vs -> (is_fvar t v) || (is_any_fvar t vs) -let (is_uvar : FStar_Reflection_Types.term -> Prims.bool) = +let (is_uvar : FStarC_Reflection_Types.term -> Prims.bool) = fun t -> - match FStar_Reflection_V1_Builtins.inspect_ln (head t) with - | FStar_Reflection_V1_Data.Tv_Uvar (uu___, uu___1) -> true + match FStarC_Reflection_V1_Builtins.inspect_ln (head t) with + | FStarC_Reflection_V1_Data.Tv_Uvar (uu___, uu___1) -> true | uu___ -> false let (binder_set_qual : - FStar_Reflection_V1_Data.aqualv -> - FStar_Reflection_Types.binder -> FStar_Reflection_Types.binder) + FStarC_Reflection_V1_Data.aqualv -> + FStarC_Reflection_Types.binder -> FStarC_Reflection_Types.binder) = fun q -> fun b -> - let bview = FStar_Reflection_V1_Builtins.inspect_binder b in - FStar_Reflection_V1_Builtins.pack_binder + let bview = FStarC_Reflection_V1_Builtins.inspect_binder b in + FStarC_Reflection_V1_Builtins.pack_binder { - FStar_Reflection_V1_Data.binder_bv = - (bview.FStar_Reflection_V1_Data.binder_bv); - FStar_Reflection_V1_Data.binder_qual = q; - FStar_Reflection_V1_Data.binder_attrs = - (bview.FStar_Reflection_V1_Data.binder_attrs); - FStar_Reflection_V1_Data.binder_sort = - (bview.FStar_Reflection_V1_Data.binder_sort) + FStarC_Reflection_V1_Data.binder_bv = + (bview.FStarC_Reflection_V1_Data.binder_bv); + FStarC_Reflection_V1_Data.binder_qual = q; + FStarC_Reflection_V1_Data.binder_attrs = + (bview.FStarC_Reflection_V1_Data.binder_attrs); + FStarC_Reflection_V1_Data.binder_sort = + (bview.FStarC_Reflection_V1_Data.binder_sort) } let (add_check_with : - FStar_VConfig.vconfig -> - FStar_Reflection_Types.sigelt -> FStar_Reflection_Types.sigelt) + FStarC_VConfig.vconfig -> + FStarC_Reflection_Types.sigelt -> FStarC_Reflection_Types.sigelt) = fun vcfg -> fun se -> - let attrs = FStar_Reflection_V1_Builtins.sigelt_attrs se in - let vcfg_t = FStar_Reflection_V1_Builtins.embed_vconfig vcfg in + let attrs = FStarC_Reflection_V1_Builtins.sigelt_attrs se in + let vcfg_t = FStarC_Reflection_V1_Builtins.embed_vconfig vcfg in let t = - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Stubs"; "VConfig"; "check_with"]))), - (vcfg_t, FStar_Reflection_V2_Data.Q_Explicit))) in - FStar_Reflection_V1_Builtins.set_sigelt_attrs (t :: attrs) se -let (un_uinst : FStar_Reflection_Types.term -> FStar_Reflection_Types.term) = + (vcfg_t, FStarC_Reflection_V2_Data.Q_Explicit))) in + FStarC_Reflection_V1_Builtins.set_sigelt_attrs (t :: attrs) se +let (un_uinst : FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term) + = fun t -> - match FStar_Reflection_V1_Builtins.inspect_ln t with - | FStar_Reflection_V1_Data.Tv_UInst (fv, uu___) -> - FStar_Reflection_V1_Builtins.pack_ln - (FStar_Reflection_V1_Data.Tv_FVar fv) + match FStarC_Reflection_V1_Builtins.inspect_ln t with + | FStarC_Reflection_V1_Data.Tv_UInst (fv, uu___) -> + FStarC_Reflection_V1_Builtins.pack_ln + (FStarC_Reflection_V1_Data.Tv_FVar fv) | uu___ -> t let rec (is_name_imp : - FStar_Reflection_Types.name -> FStar_Reflection_Types.term -> Prims.bool) = + FStarC_Reflection_Types.name -> FStarC_Reflection_Types.term -> Prims.bool) + = fun nm -> fun t -> match inspect_ln_unascribe t with - | FStar_Reflection_V1_Data.Tv_FVar fv -> - if (FStar_Reflection_V1_Builtins.inspect_fv fv) = nm + | FStarC_Reflection_V1_Data.Tv_FVar fv -> + if (FStarC_Reflection_V1_Builtins.inspect_fv fv) = nm then true else false - | FStar_Reflection_V1_Data.Tv_UInst (fv, uu___) -> - if (FStar_Reflection_V1_Builtins.inspect_fv fv) = nm + | FStarC_Reflection_V1_Data.Tv_UInst (fv, uu___) -> + if (FStarC_Reflection_V1_Builtins.inspect_fv fv) = nm then true else false - | FStar_Reflection_V1_Data.Tv_App - (l, (uu___, FStar_Reflection_V1_Data.Q_Implicit)) -> + | FStarC_Reflection_V1_Data.Tv_App + (l, (uu___, FStarC_Reflection_V1_Data.Q_Implicit)) -> is_name_imp nm l | uu___ -> false let (unsquash_term : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term FStar_Pervasives_Native.option) + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term FStar_Pervasives_Native.option) = fun t -> match inspect_ln_unascribe t with - | FStar_Reflection_V1_Data.Tv_App - (l, (r, FStar_Reflection_V1_Data.Q_Explicit)) -> + | FStarC_Reflection_V1_Data.Tv_App + (l, (r, FStarC_Reflection_V1_Data.Q_Explicit)) -> if is_name_imp FStar_Reflection_Const.squash_qn l then FStar_Pervasives_Native.Some r else FStar_Pervasives_Native.None | uu___ -> FStar_Pervasives_Native.None let (maybe_unsquash_term : - FStar_Reflection_Types.term -> FStar_Reflection_Types.term) = + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term) = fun t -> match unsquash_term t with | FStar_Pervasives_Native.Some t' -> t' diff --git a/ocaml/fstar-lib/generated/FStar_Reflection_V1_Derived_Lemmas.ml b/ocaml/fstar-lib/generated/FStar_Reflection_V1_Derived_Lemmas.ml index 832fa7e38d2..17ac43edc7b 100644 --- a/ocaml/fstar-lib/generated/FStar_Reflection_V1_Derived_Lemmas.ml +++ b/ocaml/fstar-lib/generated/FStar_Reflection_V1_Derived_Lemmas.ml @@ -5,22 +5,25 @@ type ('a, 'r, 'l, 'r1) op_Less_Less_Colon = unit let rec list_ref : 'a 'p . 'a Prims.list -> 'a Prims.list = fun l -> match l with | [] -> [] | x::xs -> x :: (list_ref xs) let (collect_app_ref : - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.term * FStar_Reflection_V1_Data.argv Prims.list)) + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.term * FStarC_Reflection_V1_Data.argv + Prims.list)) = fun t -> let uu___ = FStar_Reflection_V1_Derived.collect_app_ln t in match uu___ with | (h, a) -> (h, (list_ref a)) let (collect_abs_ln_ref : - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.binder Prims.list * FStar_Reflection_Types.term)) + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.binder Prims.list * + FStarC_Reflection_Types.term)) = fun t -> let uu___ = FStar_Reflection_V1_Derived.collect_abs_ln t in match uu___ with | (bds, body) -> ((list_ref bds), body) let (collect_arr_ln_bs_ref : - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.binder Prims.list * FStar_Reflection_Types.comp)) + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.binder Prims.list * + FStarC_Reflection_Types.comp)) = fun t -> let uu___ = FStar_Reflection_V1_Derived.collect_arr_ln_bs t in diff --git a/ocaml/fstar-lib/generated/FStar_Reflection_V1_Embeddings.ml b/ocaml/fstar-lib/generated/FStar_Reflection_V1_Embeddings.ml deleted file mode 100644 index c313ac467e3..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Reflection_V1_Embeddings.ml +++ /dev/null @@ -1,2147 +0,0 @@ -open Prims -let (noaqs : FStar_Syntax_Syntax.antiquotations) = (Prims.int_zero, []) -let mk_emb : - 'uuuuu . - (FStar_Compiler_Range_Type.range -> 'uuuuu -> FStar_Syntax_Syntax.term) - -> - (FStar_Syntax_Syntax.term -> 'uuuuu FStar_Pervasives_Native.option) -> - FStar_Syntax_Syntax.term -> - 'uuuuu FStar_Syntax_Embeddings_Base.embedding - = - fun f -> - fun g -> - fun t -> - let uu___ = FStar_Syntax_Embeddings_Base.term_as_fv t in - FStar_Syntax_Embeddings_Base.mk_emb - (fun x -> fun r -> fun _topt -> fun _norm -> f r x) - (fun x -> fun _norm -> g x) uu___ -let embed : - 'a . - 'a FStar_Syntax_Embeddings_Base.embedding -> - FStar_Compiler_Range_Type.range -> 'a -> FStar_Syntax_Syntax.term - = - fun uu___ -> - fun r -> - fun x -> - let uu___1 = FStar_Syntax_Embeddings_Base.embed uu___ x in - uu___1 r FStar_Pervasives_Native.None - FStar_Syntax_Embeddings_Base.id_norm_cb -let unembed : - 'a . - 'a FStar_Syntax_Embeddings_Base.embedding -> - FStar_Syntax_Syntax.term -> 'a FStar_Pervasives_Native.option - = - fun uu___ -> - fun x -> - FStar_Syntax_Embeddings_Base.try_unembed uu___ x - FStar_Syntax_Embeddings_Base.id_norm_cb -let (e_bv : FStar_Syntax_Syntax.bv FStar_Syntax_Embeddings_Base.embedding) = - FStar_Reflection_V2_Embeddings.e_bv -let (e_binder : - FStar_Syntax_Syntax.binder FStar_Syntax_Embeddings_Base.embedding) = - FStar_Reflection_V2_Embeddings.e_binder -let (e_term_aq : - FStar_Syntax_Syntax.antiquotations -> - FStar_Syntax_Syntax.term FStar_Syntax_Embeddings_Base.embedding) - = FStar_Reflection_V2_Embeddings.e_term_aq -let (e_term : - FStar_Syntax_Syntax.term FStar_Syntax_Embeddings_Base.embedding) = - FStar_Reflection_V2_Embeddings.e_term -let (e_binders : - FStar_Syntax_Syntax.binders FStar_Syntax_Embeddings_Base.embedding) = - FStar_Reflection_V2_Embeddings.e_binders -let (e_fv : FStar_Syntax_Syntax.fv FStar_Syntax_Embeddings_Base.embedding) = - FStar_Reflection_V2_Embeddings.e_fv -let (e_comp : - FStar_Syntax_Syntax.comp FStar_Syntax_Embeddings_Base.embedding) = - FStar_Reflection_V2_Embeddings.e_comp -let (e_universe : - FStar_Syntax_Syntax.universe FStar_Syntax_Embeddings_Base.embedding) = - FStar_Reflection_V2_Embeddings.e_universe -let (e_aqualv : - FStar_Reflection_V1_Data.aqualv FStar_Syntax_Embeddings_Base.embedding) = - let embed_aqualv rng q = - let r = - match q with - | FStar_Reflection_V1_Data.Q_Explicit -> - FStar_Reflection_V1_Constants.ref_Q_Explicit.FStar_Reflection_V1_Constants.t - | FStar_Reflection_V1_Data.Q_Implicit -> - FStar_Reflection_V1_Constants.ref_Q_Implicit.FStar_Reflection_V1_Constants.t - | FStar_Reflection_V1_Data.Q_Meta t -> - let uu___ = - let uu___1 = - let uu___2 = embed e_term rng t in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_Q_Meta.FStar_Reflection_V1_Constants.t - uu___ FStar_Compiler_Range_Type.dummyRange in - { - FStar_Syntax_Syntax.n = (r.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = rng; - FStar_Syntax_Syntax.vars = (r.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = (r.FStar_Syntax_Syntax.hash_code) - } in - let unembed_aqualv t = - let t1 = FStar_Syntax_Util.unascribe t in - let uu___ = FStar_Syntax_Util.head_and_args t1 in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst hd in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Q_Explicit.FStar_Reflection_V1_Constants.lid - -> - FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.Q_Explicit - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Q_Implicit.FStar_Reflection_V1_Constants.lid - -> - FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.Q_Implicit - | (FStar_Syntax_Syntax.Tm_fvar fv, (t2, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Q_Meta.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = unembed e_term t2 in - FStar_Compiler_Util.bind_opt uu___3 - (fun t3 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Q_Meta t3)) - | uu___2 -> FStar_Pervasives_Native.None) in - mk_emb embed_aqualv unembed_aqualv - FStar_Reflection_V1_Constants.fstar_refl_aqualv -let (e_ident : - FStar_Reflection_V1_Data.ident FStar_Syntax_Embeddings_Base.embedding) = - FStar_Syntax_Embeddings.e_tuple2 FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_range -let (e_universe_view : - FStar_Reflection_V1_Data.universe_view - FStar_Syntax_Embeddings_Base.embedding) - = - let embed_universe_view rng uv = - match uv with - | FStar_Reflection_V1_Data.Uv_Zero -> - FStar_Reflection_V1_Constants.ref_Uv_Zero.FStar_Reflection_V1_Constants.t - | FStar_Reflection_V1_Data.Uv_Succ u -> - let uu___ = - let uu___1 = - let uu___2 = - embed FStar_Reflection_V2_Embeddings.e_universe rng u in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_Uv_Succ.FStar_Reflection_V1_Constants.t - uu___ rng - | FStar_Reflection_V1_Data.Uv_Max us -> - let uu___ = - let uu___1 = - let uu___2 = - embed - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_universe) rng us in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_Uv_Max.FStar_Reflection_V1_Constants.t - uu___ rng - | FStar_Reflection_V1_Data.Uv_BVar n -> - let uu___ = - let uu___1 = - let uu___2 = embed FStar_Syntax_Embeddings.e_int rng n in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_Uv_BVar.FStar_Reflection_V1_Constants.t - uu___ rng - | FStar_Reflection_V1_Data.Uv_Name i -> - let uu___ = - let uu___1 = - let uu___2 = embed e_ident rng i in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_Uv_Name.FStar_Reflection_V1_Constants.t - uu___ rng - | FStar_Reflection_V1_Data.Uv_Unif u -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Syntax_Util.mk_lazy u FStar_Syntax_Util.t_universe_uvar - FStar_Syntax_Syntax.Lazy_universe_uvar - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_Uv_Unif.FStar_Reflection_V1_Constants.t - uu___ rng - | FStar_Reflection_V1_Data.Uv_Unk -> - FStar_Reflection_V1_Constants.ref_Uv_Unk.FStar_Reflection_V1_Constants.t in - let unembed_universe_view t = - let t1 = FStar_Syntax_Util.unascribe t in - let uu___ = FStar_Syntax_Util.head_and_args t1 in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst hd in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Uv_Zero.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.Uv_Zero - | (FStar_Syntax_Syntax.Tm_fvar fv, (u, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Uv_Succ.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = unembed FStar_Reflection_V2_Embeddings.e_universe u in - FStar_Compiler_Util.bind_opt uu___3 - (fun u1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Uv_Succ u1)) - | (FStar_Syntax_Syntax.Tm_fvar fv, (us, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Uv_Max.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = - unembed - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_universe) us in - FStar_Compiler_Util.bind_opt uu___3 - (fun us1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Uv_Max us1)) - | (FStar_Syntax_Syntax.Tm_fvar fv, (n, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Uv_BVar.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = unembed FStar_Syntax_Embeddings.e_int n in - FStar_Compiler_Util.bind_opt uu___3 - (fun n1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Uv_BVar n1)) - | (FStar_Syntax_Syntax.Tm_fvar fv, (i, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Uv_Name.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = unembed e_ident i in - FStar_Compiler_Util.bind_opt uu___3 - (fun i1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Uv_Name i1)) - | (FStar_Syntax_Syntax.Tm_fvar fv, (u, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Uv_Unif.FStar_Reflection_V1_Constants.lid - -> - let u1 = - FStar_Syntax_Util.unlazy_as_t - FStar_Syntax_Syntax.Lazy_universe_uvar u in - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Uv_Unif u1) - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Uv_Unk.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.Uv_Unk - | uu___2 -> FStar_Pervasives_Native.None) in - mk_emb embed_universe_view unembed_universe_view - FStar_Reflection_V1_Constants.fstar_refl_universe_view -let (e_env : - FStar_TypeChecker_Env.env FStar_Syntax_Embeddings_Base.embedding) = - let embed_env rng e = - FStar_Syntax_Util.mk_lazy e FStar_Reflection_V1_Constants.fstar_refl_env - FStar_Syntax_Syntax.Lazy_env (FStar_Pervasives_Native.Some rng) in - let unembed_env t = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_lazy - { FStar_Syntax_Syntax.blob = b; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_env; - FStar_Syntax_Syntax.ltyp = uu___1; - FStar_Syntax_Syntax.rng = uu___2;_} - -> - let uu___3 = FStar_Dyn.undyn b in FStar_Pervasives_Native.Some uu___3 - | uu___1 -> FStar_Pervasives_Native.None in - mk_emb embed_env unembed_env FStar_Reflection_V1_Constants.fstar_refl_env -let (e_const : - FStar_Reflection_V1_Data.vconst FStar_Syntax_Embeddings_Base.embedding) = - let embed_const rng c = - let r = - match c with - | FStar_Reflection_V1_Data.C_Unit -> - FStar_Reflection_V1_Constants.ref_C_Unit.FStar_Reflection_V1_Constants.t - | FStar_Reflection_V1_Data.C_True -> - FStar_Reflection_V1_Constants.ref_C_True.FStar_Reflection_V1_Constants.t - | FStar_Reflection_V1_Data.C_False -> - FStar_Reflection_V1_Constants.ref_C_False.FStar_Reflection_V1_Constants.t - | FStar_Reflection_V1_Data.C_Int i -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_BigInt.string_of_big_int i in - FStar_Syntax_Util.exp_int uu___3 in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_C_Int.FStar_Reflection_V1_Constants.t - uu___ FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V1_Data.C_String s -> - let uu___ = - let uu___1 = - let uu___2 = embed FStar_Syntax_Embeddings.e_string rng s in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_C_String.FStar_Reflection_V1_Constants.t - uu___ FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V1_Data.C_Range r1 -> - let uu___ = - let uu___1 = - let uu___2 = embed FStar_Syntax_Embeddings.e_range rng r1 in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_C_Range.FStar_Reflection_V1_Constants.t - uu___ FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V1_Data.C_Reify -> - FStar_Reflection_V1_Constants.ref_C_Reify.FStar_Reflection_V1_Constants.t - | FStar_Reflection_V1_Data.C_Reflect ns -> - let uu___ = - let uu___1 = - let uu___2 = embed FStar_Syntax_Embeddings.e_string_list rng ns in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_C_Reflect.FStar_Reflection_V1_Constants.t - uu___ FStar_Compiler_Range_Type.dummyRange in - { - FStar_Syntax_Syntax.n = (r.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = rng; - FStar_Syntax_Syntax.vars = (r.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = (r.FStar_Syntax_Syntax.hash_code) - } in - let unembed_const t = - let t1 = FStar_Syntax_Util.unascribe t in - let uu___ = FStar_Syntax_Util.head_and_args t1 in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst hd in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_C_Unit.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.C_Unit - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_C_True.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.C_True - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_C_False.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.C_False - | (FStar_Syntax_Syntax.Tm_fvar fv, (i, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_C_Int.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = unembed FStar_Syntax_Embeddings.e_int i in - FStar_Compiler_Util.bind_opt uu___3 - (fun i1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.C_Int i1)) - | (FStar_Syntax_Syntax.Tm_fvar fv, (s, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_C_String.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = unembed FStar_Syntax_Embeddings.e_string s in - FStar_Compiler_Util.bind_opt uu___3 - (fun s1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.C_String s1)) - | (FStar_Syntax_Syntax.Tm_fvar fv, (r, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_C_Range.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = unembed FStar_Syntax_Embeddings.e_range r in - FStar_Compiler_Util.bind_opt uu___3 - (fun r1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.C_Range r1)) - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_C_Reify.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.C_Reify - | (FStar_Syntax_Syntax.Tm_fvar fv, (ns, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_C_Reflect.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = unembed FStar_Syntax_Embeddings.e_string_list ns in - FStar_Compiler_Util.bind_opt uu___3 - (fun ns1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.C_Reflect ns1)) - | uu___2 -> FStar_Pervasives_Native.None) in - mk_emb embed_const unembed_const - FStar_Reflection_V1_Constants.fstar_refl_vconst -let rec e_pattern_aq : - 'uuuuu . - 'uuuuu -> - FStar_Reflection_V1_Data.pattern FStar_Syntax_Embeddings_Base.embedding - = - fun aq -> - let rec embed_pattern rng p = - match p with - | FStar_Reflection_V1_Data.Pat_Constant c -> - let uu___ = - let uu___1 = - let uu___2 = embed e_const rng c in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_Pat_Constant.FStar_Reflection_V1_Constants.t - uu___ rng - | FStar_Reflection_V1_Data.Pat_Cons (fv, us_opt, ps) -> - let uu___ = - let uu___1 = - let uu___2 = embed FStar_Reflection_V2_Embeddings.e_fv rng fv in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - embed - (FStar_Syntax_Embeddings.e_option - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_universe)) rng - us_opt in - FStar_Syntax_Syntax.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = e_pattern_aq aq in - FStar_Syntax_Embeddings.e_tuple2 uu___9 - FStar_Syntax_Embeddings.e_bool in - FStar_Syntax_Embeddings.e_list uu___8 in - embed uu___7 rng ps in - FStar_Syntax_Syntax.as_arg uu___6 in - [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_Pat_Cons.FStar_Reflection_V1_Constants.t - uu___ rng - | FStar_Reflection_V1_Data.Pat_Var (bv, sort) -> - let uu___ = - let uu___1 = - let uu___2 = embed e_bv rng bv in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - embed (FStar_Syntax_Embeddings.e_sealed e_term) rng sort in - FStar_Syntax_Syntax.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_Pat_Var.FStar_Reflection_V1_Constants.t - uu___ rng - | FStar_Reflection_V1_Data.Pat_Dot_Term eopt -> - let uu___ = - let uu___1 = - let uu___2 = - embed (FStar_Syntax_Embeddings.e_option e_term) rng eopt in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_Pat_Dot_Term.FStar_Reflection_V1_Constants.t - uu___ rng in - let rec unembed_pattern t = - let t1 = FStar_Syntax_Util.unascribe t in - let uu___ = FStar_Syntax_Util.head_and_args t1 in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst hd in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, (c, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Pat_Constant.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = unembed e_const c in - FStar_Compiler_Util.bind_opt uu___3 - (fun c1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Pat_Constant c1)) - | (FStar_Syntax_Syntax.Tm_fvar fv, - (f, uu___2)::(us_opt, uu___3)::(ps, uu___4)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Pat_Cons.FStar_Reflection_V1_Constants.lid - -> - let uu___5 = unembed FStar_Reflection_V2_Embeddings.e_fv f in - FStar_Compiler_Util.bind_opt uu___5 - (fun f1 -> - let uu___6 = - unembed - (FStar_Syntax_Embeddings.e_option - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_universe)) - us_opt in - FStar_Compiler_Util.bind_opt uu___6 - (fun us_opt1 -> - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = e_pattern_aq aq in - FStar_Syntax_Embeddings.e_tuple2 uu___10 - FStar_Syntax_Embeddings.e_bool in - FStar_Syntax_Embeddings.e_list uu___9 in - unembed uu___8 ps in - FStar_Compiler_Util.bind_opt uu___7 - (fun ps1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Pat_Cons - (f1, us_opt1, ps1))))) - | (FStar_Syntax_Syntax.Tm_fvar fv, - (bv, uu___2)::(sort, uu___3)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Pat_Var.FStar_Reflection_V1_Constants.lid - -> - let uu___4 = unembed e_bv bv in - FStar_Compiler_Util.bind_opt uu___4 - (fun bv1 -> - let uu___5 = - unembed (FStar_Syntax_Embeddings.e_sealed e_term) sort in - FStar_Compiler_Util.bind_opt uu___5 - (fun sort1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Pat_Var (bv1, sort1)))) - | (FStar_Syntax_Syntax.Tm_fvar fv, (eopt, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Pat_Dot_Term.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = - unembed (FStar_Syntax_Embeddings.e_option e_term) eopt in - FStar_Compiler_Util.bind_opt uu___3 - (fun eopt1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Pat_Dot_Term eopt1)) - | uu___2 -> FStar_Pervasives_Native.None) in - mk_emb embed_pattern unembed_pattern - FStar_Reflection_V1_Constants.fstar_refl_pattern -let (e_pattern : - FStar_Reflection_V1_Data.pattern FStar_Syntax_Embeddings_Base.embedding) = - e_pattern_aq noaqs -let (e_branch : - FStar_Reflection_V1_Data.branch FStar_Syntax_Embeddings_Base.embedding) = - FStar_Syntax_Embeddings.e_tuple2 e_pattern e_term -let (e_argv : - FStar_Reflection_V1_Data.argv FStar_Syntax_Embeddings_Base.embedding) = - FStar_Syntax_Embeddings.e_tuple2 e_term e_aqualv -let (e_args : - FStar_Reflection_V1_Data.argv Prims.list - FStar_Syntax_Embeddings_Base.embedding) - = FStar_Syntax_Embeddings.e_list e_argv -let (e_branch_aq : - FStar_Syntax_Syntax.antiquotations -> - (FStar_Reflection_V1_Data.pattern * FStar_Syntax_Syntax.term) - FStar_Syntax_Embeddings_Base.embedding) - = - fun aq -> - let uu___ = e_pattern_aq aq in - let uu___1 = e_term_aq aq in - FStar_Syntax_Embeddings.e_tuple2 uu___ uu___1 -let (e_argv_aq : - FStar_Syntax_Syntax.antiquotations -> - (FStar_Syntax_Syntax.term * FStar_Reflection_V1_Data.aqualv) - FStar_Syntax_Embeddings_Base.embedding) - = - fun aq -> - let uu___ = e_term_aq aq in - FStar_Syntax_Embeddings.e_tuple2 uu___ e_aqualv -let (e_match_returns_annotation : - (FStar_Syntax_Syntax.binder * ((FStar_Syntax_Syntax.term, - FStar_Syntax_Syntax.comp) FStar_Pervasives.either * - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option * Prims.bool)) - FStar_Pervasives_Native.option FStar_Syntax_Embeddings_Base.embedding) - = - FStar_Syntax_Embeddings.e_option - (FStar_Syntax_Embeddings.e_tuple2 e_binder - (FStar_Syntax_Embeddings.e_tuple3 - (FStar_Syntax_Embeddings.e_either e_term e_comp) - (FStar_Syntax_Embeddings.e_option e_term) - FStar_Syntax_Embeddings.e_bool)) -let (e_term_view_aq : - FStar_Syntax_Syntax.antiquotations -> - FStar_Reflection_V1_Data.term_view FStar_Syntax_Embeddings_Base.embedding) - = - fun aq -> - let push uu___ = - match uu___ with | (s, aq1) -> ((s + Prims.int_one), aq1) in - let embed_term_view rng t = - match t with - | FStar_Reflection_V1_Data.Tv_FVar fv -> - let uu___ = - let uu___1 = - let uu___2 = embed FStar_Reflection_V2_Embeddings.e_fv rng fv in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_Tv_FVar.FStar_Reflection_V1_Constants.t - uu___ rng - | FStar_Reflection_V1_Data.Tv_BVar fv -> - let uu___ = - let uu___1 = - let uu___2 = embed e_bv rng fv in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_Tv_BVar.FStar_Reflection_V1_Constants.t - uu___ rng - | FStar_Reflection_V1_Data.Tv_Var bv -> - let uu___ = - let uu___1 = - let uu___2 = embed e_bv rng bv in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_Tv_Var.FStar_Reflection_V1_Constants.t - uu___ rng - | FStar_Reflection_V1_Data.Tv_UInst (fv, us) -> - let uu___ = - let uu___1 = - let uu___2 = embed FStar_Reflection_V2_Embeddings.e_fv rng fv in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - embed - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_universe) rng us in - FStar_Syntax_Syntax.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_Tv_UInst.FStar_Reflection_V1_Constants.t - uu___ rng - | FStar_Reflection_V1_Data.Tv_App (hd, a) -> - let uu___ = - let uu___1 = - let uu___2 = let uu___3 = e_term_aq aq in embed uu___3 rng hd in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = let uu___5 = e_argv_aq aq in embed uu___5 rng a in - FStar_Syntax_Syntax.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_Tv_App.FStar_Reflection_V1_Constants.t - uu___ rng - | FStar_Reflection_V1_Data.Tv_Abs (b, t1) -> - let uu___ = - let uu___1 = - let uu___2 = - embed FStar_Reflection_V2_Embeddings.e_binder rng b in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = e_term_aq (push aq) in embed uu___5 rng t1 in - FStar_Syntax_Syntax.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_Tv_Abs.FStar_Reflection_V1_Constants.t - uu___ rng - | FStar_Reflection_V1_Data.Tv_Arrow (b, c) -> - let uu___ = - let uu___1 = - let uu___2 = - embed FStar_Reflection_V2_Embeddings.e_binder rng b in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - embed FStar_Reflection_V2_Embeddings.e_comp rng c in - FStar_Syntax_Syntax.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_Tv_Arrow.FStar_Reflection_V1_Constants.t - uu___ rng - | FStar_Reflection_V1_Data.Tv_Type u -> - let uu___ = - let uu___1 = - let uu___2 = - embed FStar_Reflection_V2_Embeddings.e_universe rng u in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_Tv_Type.FStar_Reflection_V1_Constants.t - uu___ rng - | FStar_Reflection_V1_Data.Tv_Refine (bv, s, t1) -> - let uu___ = - let uu___1 = - let uu___2 = embed e_bv rng bv in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = let uu___5 = e_term_aq aq in embed uu___5 rng s in - FStar_Syntax_Syntax.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = e_term_aq (push aq) in embed uu___7 rng t1 in - FStar_Syntax_Syntax.as_arg uu___6 in - [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_Tv_Refine.FStar_Reflection_V1_Constants.t - uu___ rng - | FStar_Reflection_V1_Data.Tv_Const c -> - let uu___ = - let uu___1 = - let uu___2 = embed e_const rng c in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_Tv_Const.FStar_Reflection_V1_Constants.t - uu___ rng - | FStar_Reflection_V1_Data.Tv_Uvar (u, d) -> - let uu___ = - let uu___1 = - let uu___2 = embed FStar_Syntax_Embeddings.e_int rng u in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Syntax_Util.mk_lazy (u, d) - FStar_Syntax_Util.t_ctx_uvar_and_sust - FStar_Syntax_Syntax.Lazy_uvar - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_Tv_Uvar.FStar_Reflection_V1_Constants.t - uu___ rng - | FStar_Reflection_V1_Data.Tv_Let (r, attrs, b, ty, t1, t2) -> - let uu___ = - let uu___1 = - let uu___2 = embed FStar_Syntax_Embeddings.e_bool rng r in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - embed (FStar_Syntax_Embeddings.e_list e_term) rng attrs in - FStar_Syntax_Syntax.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = embed e_bv rng b in - FStar_Syntax_Syntax.as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = e_term_aq aq in embed uu___9 rng ty in - FStar_Syntax_Syntax.as_arg uu___8 in - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = e_term_aq aq in embed uu___11 rng t1 in - FStar_Syntax_Syntax.as_arg uu___10 in - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = e_term_aq (push aq) in - embed uu___13 rng t2 in - FStar_Syntax_Syntax.as_arg uu___12 in - [uu___11] in - uu___9 :: uu___10 in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_Tv_Let.FStar_Reflection_V1_Constants.t - uu___ rng - | FStar_Reflection_V1_Data.Tv_Match (t1, ret_opt, brs) -> - let uu___ = - let uu___1 = - let uu___2 = let uu___3 = e_term_aq aq in embed uu___3 rng t1 in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = embed e_match_returns_annotation rng ret_opt in - FStar_Syntax_Syntax.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = e_branch_aq aq in - FStar_Syntax_Embeddings.e_list uu___8 in - embed uu___7 rng brs in - FStar_Syntax_Syntax.as_arg uu___6 in - [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_Tv_Match.FStar_Reflection_V1_Constants.t - uu___ rng - | FStar_Reflection_V1_Data.Tv_AscribedT (e, t1, tacopt, use_eq) -> - let uu___ = - let uu___1 = - let uu___2 = let uu___3 = e_term_aq aq in embed uu___3 rng e in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = let uu___5 = e_term_aq aq in embed uu___5 rng t1 in - FStar_Syntax_Syntax.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = e_term_aq aq in - FStar_Syntax_Embeddings.e_option uu___8 in - embed uu___7 rng tacopt in - FStar_Syntax_Syntax.as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - embed FStar_Syntax_Embeddings.e_bool rng use_eq in - FStar_Syntax_Syntax.as_arg uu___8 in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_Tv_AscT.FStar_Reflection_V1_Constants.t - uu___ rng - | FStar_Reflection_V1_Data.Tv_AscribedC (e, c, tacopt, use_eq) -> - let uu___ = - let uu___1 = - let uu___2 = let uu___3 = e_term_aq aq in embed uu___3 rng e in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - embed FStar_Reflection_V2_Embeddings.e_comp rng c in - FStar_Syntax_Syntax.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = e_term_aq aq in - FStar_Syntax_Embeddings.e_option uu___8 in - embed uu___7 rng tacopt in - FStar_Syntax_Syntax.as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - embed FStar_Syntax_Embeddings.e_bool rng use_eq in - FStar_Syntax_Syntax.as_arg uu___8 in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_Tv_AscC.FStar_Reflection_V1_Constants.t - uu___ rng - | FStar_Reflection_V1_Data.Tv_Unknown -> - let uu___ = - FStar_Reflection_V1_Constants.ref_Tv_Unknown.FStar_Reflection_V1_Constants.t in - { - FStar_Syntax_Syntax.n = (uu___.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = rng; - FStar_Syntax_Syntax.vars = (uu___.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (uu___.FStar_Syntax_Syntax.hash_code) - } - | FStar_Reflection_V1_Data.Tv_Unsupp -> - let uu___ = - FStar_Reflection_V1_Constants.ref_Tv_Unsupp.FStar_Reflection_V1_Constants.t in - { - FStar_Syntax_Syntax.n = (uu___.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = rng; - FStar_Syntax_Syntax.vars = (uu___.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (uu___.FStar_Syntax_Syntax.hash_code) - } in - let unembed_term_view t = - let uu___ = FStar_Syntax_Util.head_and_args t in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst hd in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, (b, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_Var.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = unembed e_bv b in - FStar_Compiler_Util.bind_opt uu___3 - (fun b1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Tv_Var b1)) - | (FStar_Syntax_Syntax.Tm_fvar fv, (b, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_BVar.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = unembed e_bv b in - FStar_Compiler_Util.bind_opt uu___3 - (fun b1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Tv_BVar b1)) - | (FStar_Syntax_Syntax.Tm_fvar fv, (f, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_FVar.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = unembed FStar_Reflection_V2_Embeddings.e_fv f in - FStar_Compiler_Util.bind_opt uu___3 - (fun f1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Tv_FVar f1)) - | (FStar_Syntax_Syntax.Tm_fvar fv, (f, uu___2)::(us, uu___3)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_UInst.FStar_Reflection_V1_Constants.lid - -> - let uu___4 = unembed FStar_Reflection_V2_Embeddings.e_fv f in - FStar_Compiler_Util.bind_opt uu___4 - (fun f1 -> - let uu___5 = - unembed - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_universe) us in - FStar_Compiler_Util.bind_opt uu___5 - (fun us1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Tv_UInst (f1, us1)))) - | (FStar_Syntax_Syntax.Tm_fvar fv, (l, uu___2)::(r, uu___3)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_App.FStar_Reflection_V1_Constants.lid - -> - let uu___4 = unembed e_term l in - FStar_Compiler_Util.bind_opt uu___4 - (fun l1 -> - let uu___5 = unembed e_argv r in - FStar_Compiler_Util.bind_opt uu___5 - (fun r1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Tv_App (l1, r1)))) - | (FStar_Syntax_Syntax.Tm_fvar fv, (b, uu___2)::(t1, uu___3)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_Abs.FStar_Reflection_V1_Constants.lid - -> - let uu___4 = unembed FStar_Reflection_V2_Embeddings.e_binder b in - FStar_Compiler_Util.bind_opt uu___4 - (fun b1 -> - let uu___5 = unembed e_term t1 in - FStar_Compiler_Util.bind_opt uu___5 - (fun t2 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Tv_Abs (b1, t2)))) - | (FStar_Syntax_Syntax.Tm_fvar fv, (b, uu___2)::(t1, uu___3)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_Arrow.FStar_Reflection_V1_Constants.lid - -> - let uu___4 = unembed FStar_Reflection_V2_Embeddings.e_binder b in - FStar_Compiler_Util.bind_opt uu___4 - (fun b1 -> - let uu___5 = - unembed FStar_Reflection_V2_Embeddings.e_comp t1 in - FStar_Compiler_Util.bind_opt uu___5 - (fun c -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Tv_Arrow (b1, c)))) - | (FStar_Syntax_Syntax.Tm_fvar fv, (u, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_Type.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = - unembed FStar_Reflection_V2_Embeddings.e_universe u in - FStar_Compiler_Util.bind_opt uu___3 - (fun u1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Tv_Type u1)) - | (FStar_Syntax_Syntax.Tm_fvar fv, - (b, uu___2)::(sort, uu___3)::(t1, uu___4)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_Refine.FStar_Reflection_V1_Constants.lid - -> - let uu___5 = unembed e_bv b in - FStar_Compiler_Util.bind_opt uu___5 - (fun b1 -> - let uu___6 = unembed e_term sort in - FStar_Compiler_Util.bind_opt uu___6 - (fun sort1 -> - let uu___7 = unembed e_term t1 in - FStar_Compiler_Util.bind_opt uu___7 - (fun t2 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Tv_Refine - (b1, sort1, t2))))) - | (FStar_Syntax_Syntax.Tm_fvar fv, (c, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_Const.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = unembed e_const c in - FStar_Compiler_Util.bind_opt uu___3 - (fun c1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Tv_Const c1)) - | (FStar_Syntax_Syntax.Tm_fvar fv, (u, uu___2)::(l, uu___3)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_Uvar.FStar_Reflection_V1_Constants.lid - -> - let uu___4 = unembed FStar_Syntax_Embeddings.e_int u in - FStar_Compiler_Util.bind_opt uu___4 - (fun u1 -> - let ctx_u_s = - FStar_Syntax_Util.unlazy_as_t - FStar_Syntax_Syntax.Lazy_uvar l in - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Tv_Uvar (u1, ctx_u_s))) - | (FStar_Syntax_Syntax.Tm_fvar fv, - (r, uu___2)::(attrs, uu___3)::(b, uu___4)::(ty, uu___5):: - (t1, uu___6)::(t2, uu___7)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_Let.FStar_Reflection_V1_Constants.lid - -> - let uu___8 = unembed FStar_Syntax_Embeddings.e_bool r in - FStar_Compiler_Util.bind_opt uu___8 - (fun r1 -> - let uu___9 = - unembed (FStar_Syntax_Embeddings.e_list e_term) attrs in - FStar_Compiler_Util.bind_opt uu___9 - (fun attrs1 -> - let uu___10 = unembed e_bv b in - FStar_Compiler_Util.bind_opt uu___10 - (fun b1 -> - let uu___11 = unembed e_term ty in - FStar_Compiler_Util.bind_opt uu___11 - (fun ty1 -> - let uu___12 = unembed e_term t1 in - FStar_Compiler_Util.bind_opt uu___12 - (fun t11 -> - let uu___13 = unembed e_term t2 in - FStar_Compiler_Util.bind_opt uu___13 - (fun t21 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Tv_Let - (r1, attrs1, b1, ty1, t11, - t21)))))))) - | (FStar_Syntax_Syntax.Tm_fvar fv, - (t1, uu___2)::(ret_opt, uu___3)::(brs, uu___4)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_Match.FStar_Reflection_V1_Constants.lid - -> - let uu___5 = unembed e_term t1 in - FStar_Compiler_Util.bind_opt uu___5 - (fun t2 -> - let uu___6 = unembed e_match_returns_annotation ret_opt in - FStar_Compiler_Util.bind_opt uu___6 - (fun ret_opt1 -> - let uu___7 = - unembed (FStar_Syntax_Embeddings.e_list e_branch) - brs in - FStar_Compiler_Util.bind_opt uu___7 - (fun brs1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Tv_Match - (t2, ret_opt1, brs1))))) - | (FStar_Syntax_Syntax.Tm_fvar fv, - (e, uu___2)::(t1, uu___3)::(tacopt, uu___4)::(use_eq, uu___5)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_AscT.FStar_Reflection_V1_Constants.lid - -> - let uu___6 = unembed e_term e in - FStar_Compiler_Util.bind_opt uu___6 - (fun e1 -> - let uu___7 = unembed e_term t1 in - FStar_Compiler_Util.bind_opt uu___7 - (fun t2 -> - let uu___8 = - unembed (FStar_Syntax_Embeddings.e_option e_term) - tacopt in - FStar_Compiler_Util.bind_opt uu___8 - (fun tacopt1 -> - let uu___9 = - unembed FStar_Syntax_Embeddings.e_bool use_eq in - FStar_Compiler_Util.bind_opt uu___9 - (fun use_eq1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Tv_AscribedT - (e1, t2, tacopt1, use_eq1)))))) - | (FStar_Syntax_Syntax.Tm_fvar fv, - (e, uu___2)::(c, uu___3)::(tacopt, uu___4)::(use_eq, uu___5)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_AscC.FStar_Reflection_V1_Constants.lid - -> - let uu___6 = unembed e_term e in - FStar_Compiler_Util.bind_opt uu___6 - (fun e1 -> - let uu___7 = unembed e_comp c in - FStar_Compiler_Util.bind_opt uu___7 - (fun c1 -> - let uu___8 = - unembed (FStar_Syntax_Embeddings.e_option e_term) - tacopt in - FStar_Compiler_Util.bind_opt uu___8 - (fun tacopt1 -> - let uu___9 = - unembed FStar_Syntax_Embeddings.e_bool use_eq in - FStar_Compiler_Util.bind_opt uu___9 - (fun use_eq1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Tv_AscribedC - (e1, c1, tacopt1, use_eq1)))))) - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_Unknown.FStar_Reflection_V1_Constants.lid - -> - FStar_Pervasives_Native.Some - FStar_Reflection_V1_Data.Tv_Unknown - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_Unsupp.FStar_Reflection_V1_Constants.lid - -> - FStar_Pervasives_Native.Some - FStar_Reflection_V1_Data.Tv_Unsupp - | uu___2 -> FStar_Pervasives_Native.None) in - mk_emb embed_term_view unembed_term_view - FStar_Reflection_V1_Constants.fstar_refl_term_view -let (e_term_view : - FStar_Reflection_V1_Data.term_view FStar_Syntax_Embeddings_Base.embedding) - = e_term_view_aq noaqs -let (e_name : Prims.string Prims.list FStar_Syntax_Embeddings_Base.embedding) - = FStar_Syntax_Embeddings.e_list FStar_Syntax_Embeddings.e_string -let (e_bv_view : - FStar_Reflection_V1_Data.bv_view FStar_Syntax_Embeddings_Base.embedding) = - let embed_bv_view rng bvv = - let uu___ = - let uu___1 = - let uu___2 = - embed - (FStar_Syntax_Embeddings.e_sealed - FStar_Syntax_Embeddings.e_string) rng - bvv.FStar_Reflection_V1_Data.bv_ppname in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - embed FStar_Syntax_Embeddings.e_int rng - bvv.FStar_Reflection_V1_Data.bv_index in - FStar_Syntax_Syntax.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_Mk_bv.FStar_Reflection_V1_Constants.t - uu___ rng in - let unembed_bv_view t = - let t1 = FStar_Syntax_Util.unascribe t in - let uu___ = FStar_Syntax_Util.head_and_args t1 in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst hd in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, (nm, uu___2)::(idx, uu___3)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Mk_bv.FStar_Reflection_V1_Constants.lid - -> - let uu___4 = - unembed - (FStar_Syntax_Embeddings.e_sealed - FStar_Syntax_Embeddings.e_string) nm in - FStar_Compiler_Util.bind_opt uu___4 - (fun nm1 -> - let uu___5 = unembed FStar_Syntax_Embeddings.e_int idx in - FStar_Compiler_Util.bind_opt uu___5 - (fun idx1 -> - FStar_Pervasives_Native.Some - { - FStar_Reflection_V1_Data.bv_ppname = nm1; - FStar_Reflection_V1_Data.bv_index = idx1 - })) - | uu___2 -> FStar_Pervasives_Native.None) in - mk_emb embed_bv_view unembed_bv_view - FStar_Reflection_V1_Constants.fstar_refl_bv_view -let (e_attribute : - FStar_Syntax_Syntax.attribute FStar_Syntax_Embeddings_Base.embedding) = - e_term -let (e_attributes : - FStar_Syntax_Syntax.attribute Prims.list - FStar_Syntax_Embeddings_Base.embedding) - = FStar_Syntax_Embeddings.e_list e_attribute -let (e_binder_view : - FStar_Reflection_V1_Data.binder_view FStar_Syntax_Embeddings_Base.embedding) - = - let embed_binder_view rng bview = - let uu___ = - let uu___1 = - let uu___2 = embed e_bv rng bview.FStar_Reflection_V1_Data.binder_bv in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - embed e_aqualv rng bview.FStar_Reflection_V1_Data.binder_qual in - FStar_Syntax_Syntax.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - embed e_attributes rng - bview.FStar_Reflection_V1_Data.binder_attrs in - FStar_Syntax_Syntax.as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - embed e_term rng bview.FStar_Reflection_V1_Data.binder_sort in - FStar_Syntax_Syntax.as_arg uu___8 in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_Mk_binder.FStar_Reflection_V1_Constants.t - uu___ rng in - let unembed_binder_view t = - let t1 = FStar_Syntax_Util.unascribe t in - let uu___ = FStar_Syntax_Util.head_and_args t1 in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst hd in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, - (bv, uu___2)::(q, uu___3)::(attrs, uu___4)::(sort, uu___5)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Mk_binder.FStar_Reflection_V1_Constants.lid - -> - let uu___6 = unembed e_bv bv in - FStar_Compiler_Util.bind_opt uu___6 - (fun bv1 -> - let uu___7 = unembed e_aqualv q in - FStar_Compiler_Util.bind_opt uu___7 - (fun q1 -> - let uu___8 = unembed e_attributes attrs in - FStar_Compiler_Util.bind_opt uu___8 - (fun attrs1 -> - let uu___9 = unembed e_term sort in - FStar_Compiler_Util.bind_opt uu___9 - (fun sort1 -> - FStar_Pervasives_Native.Some - { - FStar_Reflection_V1_Data.binder_bv = bv1; - FStar_Reflection_V1_Data.binder_qual = - q1; - FStar_Reflection_V1_Data.binder_attrs = - attrs1; - FStar_Reflection_V1_Data.binder_sort = - sort1 - })))) - | uu___2 -> FStar_Pervasives_Native.None) in - mk_emb embed_binder_view unembed_binder_view - FStar_Reflection_V1_Constants.fstar_refl_binder_view -let (e_comp_view : - FStar_Reflection_V1_Data.comp_view FStar_Syntax_Embeddings_Base.embedding) - = - let embed_comp_view rng cv = - match cv with - | FStar_Reflection_V1_Data.C_Total t -> - let uu___ = - let uu___1 = - let uu___2 = embed e_term rng t in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_C_Total.FStar_Reflection_V1_Constants.t - uu___ rng - | FStar_Reflection_V1_Data.C_GTotal t -> - let uu___ = - let uu___1 = - let uu___2 = embed e_term rng t in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_C_GTotal.FStar_Reflection_V1_Constants.t - uu___ rng - | FStar_Reflection_V1_Data.C_Lemma (pre, post, pats) -> - let uu___ = - let uu___1 = - let uu___2 = embed e_term rng pre in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = embed e_term rng post in - FStar_Syntax_Syntax.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = embed e_term rng pats in - FStar_Syntax_Syntax.as_arg uu___6 in - [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_C_Lemma.FStar_Reflection_V1_Constants.t - uu___ rng - | FStar_Reflection_V1_Data.C_Eff (us, eff, res, args, decrs) -> - let uu___ = - let uu___1 = - let uu___2 = - embed - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_universe) rng us in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - embed FStar_Syntax_Embeddings.e_string_list rng eff in - FStar_Syntax_Syntax.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = embed e_term rng res in - FStar_Syntax_Syntax.as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - embed (FStar_Syntax_Embeddings.e_list e_argv) rng args in - FStar_Syntax_Syntax.as_arg uu___8 in - let uu___8 = - let uu___9 = - let uu___10 = - embed (FStar_Syntax_Embeddings.e_list e_term) rng decrs in - FStar_Syntax_Syntax.as_arg uu___10 in - [uu___9] in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_C_Eff.FStar_Reflection_V1_Constants.t - uu___ rng in - let unembed_comp_view t = - let t1 = FStar_Syntax_Util.unascribe t in - let uu___ = FStar_Syntax_Util.head_and_args t1 in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst hd in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, (t2, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_C_Total.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = unembed e_term t2 in - FStar_Compiler_Util.bind_opt uu___3 - (fun t3 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.C_Total t3)) - | (FStar_Syntax_Syntax.Tm_fvar fv, (t2, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_C_GTotal.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = unembed e_term t2 in - FStar_Compiler_Util.bind_opt uu___3 - (fun t3 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.C_GTotal t3)) - | (FStar_Syntax_Syntax.Tm_fvar fv, - (pre, uu___2)::(post, uu___3)::(pats, uu___4)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_C_Lemma.FStar_Reflection_V1_Constants.lid - -> - let uu___5 = unembed e_term pre in - FStar_Compiler_Util.bind_opt uu___5 - (fun pre1 -> - let uu___6 = unembed e_term post in - FStar_Compiler_Util.bind_opt uu___6 - (fun post1 -> - let uu___7 = unembed e_term pats in - FStar_Compiler_Util.bind_opt uu___7 - (fun pats1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.C_Lemma - (pre1, post1, pats1))))) - | (FStar_Syntax_Syntax.Tm_fvar fv, - (us, uu___2)::(eff, uu___3)::(res, uu___4)::(args1, uu___5):: - (decrs, uu___6)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_C_Eff.FStar_Reflection_V1_Constants.lid - -> - let uu___7 = - unembed - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_universe) us in - FStar_Compiler_Util.bind_opt uu___7 - (fun us1 -> - let uu___8 = - unembed FStar_Syntax_Embeddings.e_string_list eff in - FStar_Compiler_Util.bind_opt uu___8 - (fun eff1 -> - let uu___9 = unembed e_term res in - FStar_Compiler_Util.bind_opt uu___9 - (fun res1 -> - let uu___10 = - unembed (FStar_Syntax_Embeddings.e_list e_argv) - args1 in - FStar_Compiler_Util.bind_opt uu___10 - (fun args2 -> - let uu___11 = - unembed - (FStar_Syntax_Embeddings.e_list e_term) - decrs in - FStar_Compiler_Util.bind_opt uu___11 - (fun decrs1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.C_Eff - (us1, eff1, res1, args2, decrs1))))))) - | uu___2 -> FStar_Pervasives_Native.None) in - mk_emb embed_comp_view unembed_comp_view - FStar_Reflection_V1_Constants.fstar_refl_comp_view -let (e_sigelt : - FStar_Syntax_Syntax.sigelt FStar_Syntax_Embeddings_Base.embedding) = - let embed_sigelt rng se = - FStar_Syntax_Util.mk_lazy se - FStar_Reflection_V1_Constants.fstar_refl_sigelt - FStar_Syntax_Syntax.Lazy_sigelt (FStar_Pervasives_Native.Some rng) in - let unembed_sigelt t = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_lazy - { FStar_Syntax_Syntax.blob = b; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_sigelt; - FStar_Syntax_Syntax.ltyp = uu___1; - FStar_Syntax_Syntax.rng = uu___2;_} - -> - let uu___3 = FStar_Dyn.undyn b in FStar_Pervasives_Native.Some uu___3 - | uu___1 -> FStar_Pervasives_Native.None in - mk_emb embed_sigelt unembed_sigelt - FStar_Reflection_V1_Constants.fstar_refl_sigelt -let (e_univ_name : - FStar_Reflection_V1_Data.univ_name FStar_Syntax_Embeddings_Base.embedding) - = - FStar_Syntax_Embeddings_Base.set_type - FStar_Reflection_V1_Constants.fstar_refl_univ_name e_ident -let (e_lb_view : - FStar_Reflection_V1_Data.lb_view FStar_Syntax_Embeddings_Base.embedding) = - let embed_lb_view rng lbv = - let uu___ = - let uu___1 = - let uu___2 = - embed FStar_Reflection_V2_Embeddings.e_fv rng - lbv.FStar_Reflection_V1_Data.lb_fv in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - embed (FStar_Syntax_Embeddings.e_list e_ident) rng - lbv.FStar_Reflection_V1_Data.lb_us in - FStar_Syntax_Syntax.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = embed e_term rng lbv.FStar_Reflection_V1_Data.lb_typ in - FStar_Syntax_Syntax.as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - embed e_term rng lbv.FStar_Reflection_V1_Data.lb_def in - FStar_Syntax_Syntax.as_arg uu___8 in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_Mk_lb.FStar_Reflection_V1_Constants.t - uu___ rng in - let unembed_lb_view t = - let t1 = FStar_Syntax_Util.unascribe t in - let uu___ = FStar_Syntax_Util.head_and_args t1 in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst hd in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, - (fv', uu___2)::(us, uu___3)::(typ, uu___4)::(def, uu___5)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Mk_lb.FStar_Reflection_V1_Constants.lid - -> - let uu___6 = unembed FStar_Reflection_V2_Embeddings.e_fv fv' in - FStar_Compiler_Util.bind_opt uu___6 - (fun fv'1 -> - let uu___7 = - unembed (FStar_Syntax_Embeddings.e_list e_ident) us in - FStar_Compiler_Util.bind_opt uu___7 - (fun us1 -> - let uu___8 = unembed e_term typ in - FStar_Compiler_Util.bind_opt uu___8 - (fun typ1 -> - let uu___9 = unembed e_term def in - FStar_Compiler_Util.bind_opt uu___9 - (fun def1 -> - FStar_Pervasives_Native.Some - { - FStar_Reflection_V1_Data.lb_fv = fv'1; - FStar_Reflection_V1_Data.lb_us = us1; - FStar_Reflection_V1_Data.lb_typ = typ1; - FStar_Reflection_V1_Data.lb_def = def1 - })))) - | uu___2 -> FStar_Pervasives_Native.None) in - mk_emb embed_lb_view unembed_lb_view - FStar_Reflection_V1_Constants.fstar_refl_lb_view -let (e_letbinding : - FStar_Syntax_Syntax.letbinding FStar_Syntax_Embeddings_Base.embedding) = - let embed_letbinding rng lb = - FStar_Syntax_Util.mk_lazy lb - FStar_Reflection_V1_Constants.fstar_refl_letbinding - FStar_Syntax_Syntax.Lazy_letbinding (FStar_Pervasives_Native.Some rng) in - let unembed_letbinding t = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_lazy - { FStar_Syntax_Syntax.blob = lb; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_letbinding; - FStar_Syntax_Syntax.ltyp = uu___1; - FStar_Syntax_Syntax.rng = uu___2;_} - -> - let uu___3 = FStar_Dyn.undyn lb in - FStar_Pervasives_Native.Some uu___3 - | uu___1 -> FStar_Pervasives_Native.None in - mk_emb embed_letbinding unembed_letbinding - FStar_Reflection_V1_Constants.fstar_refl_letbinding -let (e_ctor : - FStar_Reflection_V1_Data.ctor FStar_Syntax_Embeddings_Base.embedding) = - FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_list FStar_Syntax_Embeddings.e_string) e_term -let (e_sigelt_view : - FStar_Reflection_V1_Data.sigelt_view FStar_Syntax_Embeddings_Base.embedding) - = - let embed_sigelt_view rng sev = - match sev with - | FStar_Reflection_V1_Data.Sg_Let (r, lbs) -> - let uu___ = - let uu___1 = - let uu___2 = embed FStar_Syntax_Embeddings.e_bool rng r in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - embed - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_letbinding) rng lbs in - FStar_Syntax_Syntax.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_Sg_Let.FStar_Reflection_V1_Constants.t - uu___ rng - | FStar_Reflection_V1_Data.Sg_Inductive (nm, univs, bs, t, dcs) -> - let uu___ = - let uu___1 = - let uu___2 = embed FStar_Syntax_Embeddings.e_string_list rng nm in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - embed (FStar_Syntax_Embeddings.e_list e_ident) rng univs in - FStar_Syntax_Syntax.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - embed FStar_Reflection_V2_Embeddings.e_binders rng bs in - FStar_Syntax_Syntax.as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = embed e_term rng t in - FStar_Syntax_Syntax.as_arg uu___8 in - let uu___8 = - let uu___9 = - let uu___10 = - embed (FStar_Syntax_Embeddings.e_list e_ctor) rng dcs in - FStar_Syntax_Syntax.as_arg uu___10 in - [uu___9] in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_Sg_Inductive.FStar_Reflection_V1_Constants.t - uu___ rng - | FStar_Reflection_V1_Data.Sg_Val (nm, univs, t) -> - let uu___ = - let uu___1 = - let uu___2 = embed FStar_Syntax_Embeddings.e_string_list rng nm in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - embed (FStar_Syntax_Embeddings.e_list e_ident) rng univs in - FStar_Syntax_Syntax.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = embed e_term rng t in - FStar_Syntax_Syntax.as_arg uu___6 in - [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_Sg_Val.FStar_Reflection_V1_Constants.t - uu___ rng - | FStar_Reflection_V1_Data.Unk -> - let uu___ = - FStar_Reflection_V1_Constants.ref_Unk.FStar_Reflection_V1_Constants.t in - { - FStar_Syntax_Syntax.n = (uu___.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = rng; - FStar_Syntax_Syntax.vars = (uu___.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (uu___.FStar_Syntax_Syntax.hash_code) - } in - let unembed_sigelt_view t = - let t1 = FStar_Syntax_Util.unascribe t in - let uu___ = FStar_Syntax_Util.head_and_args t1 in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst hd in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, - (nm, uu___2)::(us, uu___3)::(bs, uu___4)::(t2, uu___5)::(dcs, - uu___6)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Sg_Inductive.FStar_Reflection_V1_Constants.lid - -> - let uu___7 = unembed FStar_Syntax_Embeddings.e_string_list nm in - FStar_Compiler_Util.bind_opt uu___7 - (fun nm1 -> - let uu___8 = - unembed (FStar_Syntax_Embeddings.e_list e_ident) us in - FStar_Compiler_Util.bind_opt uu___8 - (fun us1 -> - let uu___9 = - unembed FStar_Reflection_V2_Embeddings.e_binders bs in - FStar_Compiler_Util.bind_opt uu___9 - (fun bs1 -> - let uu___10 = unembed e_term t2 in - FStar_Compiler_Util.bind_opt uu___10 - (fun t3 -> - let uu___11 = - unembed - (FStar_Syntax_Embeddings.e_list e_ctor) - dcs in - FStar_Compiler_Util.bind_opt uu___11 - (fun dcs1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Sg_Inductive - (nm1, us1, bs1, t3, dcs1))))))) - | (FStar_Syntax_Syntax.Tm_fvar fv, (r, uu___2)::(lbs, uu___3)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Sg_Let.FStar_Reflection_V1_Constants.lid - -> - let uu___4 = unembed FStar_Syntax_Embeddings.e_bool r in - FStar_Compiler_Util.bind_opt uu___4 - (fun r1 -> - let uu___5 = - unembed - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_letbinding) lbs in - FStar_Compiler_Util.bind_opt uu___5 - (fun lbs1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Sg_Let (r1, lbs1)))) - | (FStar_Syntax_Syntax.Tm_fvar fv, - (nm, uu___2)::(us, uu___3)::(t2, uu___4)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Sg_Val.FStar_Reflection_V1_Constants.lid - -> - let uu___5 = unembed FStar_Syntax_Embeddings.e_string_list nm in - FStar_Compiler_Util.bind_opt uu___5 - (fun nm1 -> - let uu___6 = - unembed (FStar_Syntax_Embeddings.e_list e_ident) us in - FStar_Compiler_Util.bind_opt uu___6 - (fun us1 -> - let uu___7 = unembed e_term t2 in - FStar_Compiler_Util.bind_opt uu___7 - (fun t3 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Sg_Val (nm1, us1, t3))))) - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Unk.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.Unk - | uu___2 -> FStar_Pervasives_Native.None) in - mk_emb embed_sigelt_view unembed_sigelt_view - FStar_Reflection_V1_Constants.fstar_refl_sigelt_view -let (e_qualifier : - FStar_Reflection_V1_Data.qualifier FStar_Syntax_Embeddings_Base.embedding) - = - let embed1 rng q = - let r = - match q with - | FStar_Reflection_V1_Data.Assumption -> - FStar_Reflection_V1_Constants.ref_qual_Assumption.FStar_Reflection_V1_Constants.t - | FStar_Reflection_V1_Data.InternalAssumption -> - FStar_Reflection_V1_Constants.ref_qual_InternalAssumption.FStar_Reflection_V1_Constants.t - | FStar_Reflection_V1_Data.New -> - FStar_Reflection_V1_Constants.ref_qual_New.FStar_Reflection_V1_Constants.t - | FStar_Reflection_V1_Data.Private -> - FStar_Reflection_V1_Constants.ref_qual_Private.FStar_Reflection_V1_Constants.t - | FStar_Reflection_V1_Data.Unfold_for_unification_and_vcgen -> - FStar_Reflection_V1_Constants.ref_qual_Unfold_for_unification_and_vcgen.FStar_Reflection_V1_Constants.t - | FStar_Reflection_V1_Data.Visible_default -> - FStar_Reflection_V1_Constants.ref_qual_Visible_default.FStar_Reflection_V1_Constants.t - | FStar_Reflection_V1_Data.Irreducible -> - FStar_Reflection_V1_Constants.ref_qual_Irreducible.FStar_Reflection_V1_Constants.t - | FStar_Reflection_V1_Data.Inline_for_extraction -> - FStar_Reflection_V1_Constants.ref_qual_Inline_for_extraction.FStar_Reflection_V1_Constants.t - | FStar_Reflection_V1_Data.NoExtract -> - FStar_Reflection_V1_Constants.ref_qual_NoExtract.FStar_Reflection_V1_Constants.t - | FStar_Reflection_V1_Data.Noeq -> - FStar_Reflection_V1_Constants.ref_qual_Noeq.FStar_Reflection_V1_Constants.t - | FStar_Reflection_V1_Data.Unopteq -> - FStar_Reflection_V1_Constants.ref_qual_Unopteq.FStar_Reflection_V1_Constants.t - | FStar_Reflection_V1_Data.TotalEffect -> - FStar_Reflection_V1_Constants.ref_qual_TotalEffect.FStar_Reflection_V1_Constants.t - | FStar_Reflection_V1_Data.Logic -> - FStar_Reflection_V1_Constants.ref_qual_Logic.FStar_Reflection_V1_Constants.t - | FStar_Reflection_V1_Data.Reifiable -> - FStar_Reflection_V1_Constants.ref_qual_Reifiable.FStar_Reflection_V1_Constants.t - | FStar_Reflection_V1_Data.ExceptionConstructor -> - FStar_Reflection_V1_Constants.ref_qual_ExceptionConstructor.FStar_Reflection_V1_Constants.t - | FStar_Reflection_V1_Data.HasMaskedEffect -> - FStar_Reflection_V1_Constants.ref_qual_HasMaskedEffect.FStar_Reflection_V1_Constants.t - | FStar_Reflection_V1_Data.Effect -> - FStar_Reflection_V1_Constants.ref_qual_Effect.FStar_Reflection_V1_Constants.t - | FStar_Reflection_V1_Data.OnlyName -> - FStar_Reflection_V1_Constants.ref_qual_OnlyName.FStar_Reflection_V1_Constants.t - | FStar_Reflection_V1_Data.Reflectable l -> - let uu___ = - let uu___1 = - let uu___2 = embed FStar_Syntax_Embeddings.e_string_list rng l in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_qual_Reflectable.FStar_Reflection_V1_Constants.t - uu___ FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V1_Data.Discriminator l -> - let uu___ = - let uu___1 = - let uu___2 = embed FStar_Syntax_Embeddings.e_string_list rng l in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_qual_Discriminator.FStar_Reflection_V1_Constants.t - uu___ FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V1_Data.Action l -> - let uu___ = - let uu___1 = - let uu___2 = embed FStar_Syntax_Embeddings.e_string_list rng l in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_qual_Action.FStar_Reflection_V1_Constants.t - uu___ FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V1_Data.Projector (l, i) -> - let uu___ = - let uu___1 = - let uu___2 = - embed - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Syntax_Embeddings.e_string_list e_ident) rng - (l, i) in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_qual_Projector.FStar_Reflection_V1_Constants.t - uu___ FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V1_Data.RecordType (ids1, ids2) -> - let uu___ = - let uu___1 = - let uu___2 = - embed - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_list e_ident) - (FStar_Syntax_Embeddings.e_list e_ident)) rng - (ids1, ids2) in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_qual_RecordType.FStar_Reflection_V1_Constants.t - uu___ FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V1_Data.RecordConstructor (ids1, ids2) -> - let uu___ = - let uu___1 = - let uu___2 = - embed - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_list e_ident) - (FStar_Syntax_Embeddings.e_list e_ident)) rng - (ids1, ids2) in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.ref_qual_RecordConstructor.FStar_Reflection_V1_Constants.t - uu___ FStar_Compiler_Range_Type.dummyRange in - { - FStar_Syntax_Syntax.n = (r.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = rng; - FStar_Syntax_Syntax.vars = (r.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = (r.FStar_Syntax_Syntax.hash_code) - } in - let unembed1 t = - let t1 = FStar_Syntax_Util.unascribe t in - let uu___ = FStar_Syntax_Util.head_and_args t1 in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst hd in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_Assumption.FStar_Reflection_V1_Constants.lid - -> - FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.Assumption - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_InternalAssumption.FStar_Reflection_V1_Constants.lid - -> - FStar_Pervasives_Native.Some - FStar_Reflection_V1_Data.InternalAssumption - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_New.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.New - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_Private.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.Private - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_Unfold_for_unification_and_vcgen.FStar_Reflection_V1_Constants.lid - -> - FStar_Pervasives_Native.Some - FStar_Reflection_V1_Data.Unfold_for_unification_and_vcgen - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_Visible_default.FStar_Reflection_V1_Constants.lid - -> - FStar_Pervasives_Native.Some - FStar_Reflection_V1_Data.Visible_default - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_Irreducible.FStar_Reflection_V1_Constants.lid - -> - FStar_Pervasives_Native.Some - FStar_Reflection_V1_Data.Irreducible - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_Inline_for_extraction.FStar_Reflection_V1_Constants.lid - -> - FStar_Pervasives_Native.Some - FStar_Reflection_V1_Data.Inline_for_extraction - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_NoExtract.FStar_Reflection_V1_Constants.lid - -> - FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.NoExtract - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_Noeq.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.Noeq - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_Unopteq.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.Unopteq - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_TotalEffect.FStar_Reflection_V1_Constants.lid - -> - FStar_Pervasives_Native.Some - FStar_Reflection_V1_Data.TotalEffect - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_Logic.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.Logic - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_Reifiable.FStar_Reflection_V1_Constants.lid - -> - FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.Reifiable - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_ExceptionConstructor.FStar_Reflection_V1_Constants.lid - -> - FStar_Pervasives_Native.Some - FStar_Reflection_V1_Data.ExceptionConstructor - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_HasMaskedEffect.FStar_Reflection_V1_Constants.lid - -> - FStar_Pervasives_Native.Some - FStar_Reflection_V1_Data.HasMaskedEffect - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_Effect.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.Effect - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_OnlyName.FStar_Reflection_V1_Constants.lid - -> - FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.OnlyName - | (FStar_Syntax_Syntax.Tm_fvar fv, (l, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_Reflectable.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = unembed FStar_Syntax_Embeddings.e_string_list l in - FStar_Compiler_Util.bind_opt uu___3 - (fun l1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Reflectable l1)) - | (FStar_Syntax_Syntax.Tm_fvar fv, (l, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_Discriminator.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = unembed FStar_Syntax_Embeddings.e_string_list l in - FStar_Compiler_Util.bind_opt uu___3 - (fun l1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Discriminator l1)) - | (FStar_Syntax_Syntax.Tm_fvar fv, (l, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_Action.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = unembed FStar_Syntax_Embeddings.e_string_list l in - FStar_Compiler_Util.bind_opt uu___3 - (fun l1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Action l1)) - | (FStar_Syntax_Syntax.Tm_fvar fv, (payload, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_Projector.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = - unembed - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Syntax_Embeddings.e_string_list e_ident) payload in - FStar_Compiler_Util.bind_opt uu___3 - (fun uu___4 -> - match uu___4 with - | (l, i) -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Projector (l, i))) - | (FStar_Syntax_Syntax.Tm_fvar fv, (payload, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_RecordType.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = - unembed - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_list e_ident) - (FStar_Syntax_Embeddings.e_list e_ident)) payload in - FStar_Compiler_Util.bind_opt uu___3 - (fun uu___4 -> - match uu___4 with - | (ids1, ids2) -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.RecordType (ids1, ids2))) - | (FStar_Syntax_Syntax.Tm_fvar fv, (payload, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_RecordConstructor.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = - unembed - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_list e_ident) - (FStar_Syntax_Embeddings.e_list e_ident)) payload in - FStar_Compiler_Util.bind_opt uu___3 - (fun uu___4 -> - match uu___4 with - | (ids1, ids2) -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.RecordConstructor - (ids1, ids2))) - | uu___2 -> FStar_Pervasives_Native.None) in - mk_emb embed1 unembed1 FStar_Reflection_V1_Constants.fstar_refl_qualifier -let (e_qualifiers : - FStar_Reflection_V1_Data.qualifier Prims.list - FStar_Syntax_Embeddings_Base.embedding) - = FStar_Syntax_Embeddings.e_list e_qualifier -let (unfold_lazy_bv : - FStar_Syntax_Syntax.lazyinfo -> FStar_Syntax_Syntax.term) = - fun i -> - let bv = FStar_Dyn.undyn i.FStar_Syntax_Syntax.blob in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Reflection_V1_Builtins.inspect_bv bv in - embed e_bv_view i.FStar_Syntax_Syntax.rng uu___3 in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.fstar_refl_pack_bv.FStar_Reflection_V1_Constants.t - uu___ i.FStar_Syntax_Syntax.rng -let (unfold_lazy_binder : - FStar_Syntax_Syntax.lazyinfo -> FStar_Syntax_Syntax.term) = - fun i -> - let binder = FStar_Dyn.undyn i.FStar_Syntax_Syntax.blob in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Reflection_V1_Builtins.inspect_binder binder in - embed e_binder_view i.FStar_Syntax_Syntax.rng uu___3 in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.fstar_refl_pack_binder.FStar_Reflection_V1_Constants.t - uu___ i.FStar_Syntax_Syntax.rng -let (unfold_lazy_letbinding : - FStar_Syntax_Syntax.lazyinfo -> FStar_Syntax_Syntax.term) = - fun i -> - let lb = FStar_Dyn.undyn i.FStar_Syntax_Syntax.blob in - let lbv = FStar_Reflection_V1_Builtins.inspect_lb lb in - let uu___ = - let uu___1 = - let uu___2 = - embed FStar_Reflection_V2_Embeddings.e_fv i.FStar_Syntax_Syntax.rng - lbv.FStar_Reflection_V1_Data.lb_fv in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - embed (FStar_Syntax_Embeddings.e_list e_ident) - i.FStar_Syntax_Syntax.rng lbv.FStar_Reflection_V1_Data.lb_us in - FStar_Syntax_Syntax.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - embed e_term i.FStar_Syntax_Syntax.rng - lbv.FStar_Reflection_V1_Data.lb_typ in - FStar_Syntax_Syntax.as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - embed e_term i.FStar_Syntax_Syntax.rng - lbv.FStar_Reflection_V1_Data.lb_def in - FStar_Syntax_Syntax.as_arg uu___8 in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.fstar_refl_pack_lb.FStar_Reflection_V1_Constants.t - uu___ i.FStar_Syntax_Syntax.rng -let (unfold_lazy_fvar : - FStar_Syntax_Syntax.lazyinfo -> FStar_Syntax_Syntax.term) = - fun i -> - let fv = FStar_Dyn.undyn i.FStar_Syntax_Syntax.blob in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Reflection_V1_Builtins.inspect_fv fv in - embed FStar_Syntax_Embeddings.e_string_list - i.FStar_Syntax_Syntax.rng uu___3 in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.fstar_refl_pack_fv.FStar_Reflection_V1_Constants.t - uu___ i.FStar_Syntax_Syntax.rng -let (unfold_lazy_comp : - FStar_Syntax_Syntax.lazyinfo -> FStar_Syntax_Syntax.term) = - fun i -> - let comp = FStar_Dyn.undyn i.FStar_Syntax_Syntax.blob in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Reflection_V1_Builtins.inspect_comp comp in - embed e_comp_view i.FStar_Syntax_Syntax.rng uu___3 in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.fstar_refl_pack_comp.FStar_Reflection_V1_Constants.t - uu___ i.FStar_Syntax_Syntax.rng -let (unfold_lazy_env : - FStar_Syntax_Syntax.lazyinfo -> FStar_Syntax_Syntax.term) = - fun i -> FStar_Syntax_Util.exp_unit -let (unfold_lazy_optionstate : - FStar_Syntax_Syntax.lazyinfo -> FStar_Syntax_Syntax.term) = - fun i -> FStar_Syntax_Util.exp_unit -let (unfold_lazy_sigelt : - FStar_Syntax_Syntax.lazyinfo -> FStar_Syntax_Syntax.term) = - fun i -> - let sigelt = FStar_Dyn.undyn i.FStar_Syntax_Syntax.blob in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Reflection_V1_Builtins.inspect_sigelt sigelt in - embed e_sigelt_view i.FStar_Syntax_Syntax.rng uu___3 in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.fstar_refl_pack_sigelt.FStar_Reflection_V1_Constants.t - uu___ i.FStar_Syntax_Syntax.rng -let (unfold_lazy_universe : - FStar_Syntax_Syntax.lazyinfo -> FStar_Syntax_Syntax.term) = - fun i -> - let u = FStar_Dyn.undyn i.FStar_Syntax_Syntax.blob in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Reflection_V1_Builtins.inspect_universe u in - embed e_universe_view i.FStar_Syntax_Syntax.rng uu___3 in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V1_Constants.fstar_refl_pack_universe.FStar_Reflection_V1_Constants.t - uu___ i.FStar_Syntax_Syntax.rng \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Reflection_V1_Formula.ml b/ocaml/fstar-lib/generated/FStar_Reflection_V1_Formula.ml index 041297ebca6..026daa98ed4 100644 --- a/ocaml/fstar-lib/generated/FStar_Reflection_V1_Formula.ml +++ b/ocaml/fstar-lib/generated/FStar_Reflection_V1_Formula.ml @@ -1,13 +1,13 @@ open Prims let (bv_to_string : - FStar_Reflection_Types.bv -> + FStarC_Reflection_Types.bv -> (Prims.string, unit) FStar_Tactics_Effect.tac_repr) = fun bv -> let uu___ = Obj.magic (FStar_Tactics_Effect.lift_div_tac - (fun uu___1 -> FStar_Reflection_V1_Builtins.inspect_bv bv)) in + (fun uu___1 -> FStarC_Reflection_V1_Builtins.inspect_bv bv)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -23,13 +23,13 @@ let (bv_to_string : (fun bvv -> Obj.magic (FStar_Tactics_Unseal.unseal - bvv.FStar_Reflection_V1_Data.bv_ppname)) uu___1) + bvv.FStarC_Reflection_V1_Data.bv_ppname)) uu___1) let rec (inspect_unascribe : - FStar_Reflection_Types.term -> - (FStar_Reflection_V1_Data.term_view, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> + (FStarC_Reflection_V1_Data.term_view, unit) FStar_Tactics_Effect.tac_repr) = fun t -> - let uu___ = FStar_Tactics_V1_Builtins.inspect t in + let uu___ = FStarC_Tactics_V1_Builtins.inspect t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -44,10 +44,10 @@ let rec (inspect_unascribe : (fun uu___1 -> (fun uu___1 -> match uu___1 with - | FStar_Reflection_V1_Data.Tv_AscribedT + | FStarC_Reflection_V1_Data.Tv_AscribedT (t1, uu___2, uu___3, uu___4) -> Obj.magic (Obj.repr (inspect_unascribe t1)) - | FStar_Reflection_V1_Data.Tv_AscribedC + | FStarC_Reflection_V1_Data.Tv_AscribedC (t1, uu___2, uu___3, uu___4) -> Obj.magic (Obj.repr (inspect_unascribe t1)) | tv -> @@ -56,9 +56,9 @@ let rec (inspect_unascribe : (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> tv)))) uu___1) let rec (collect_app' : - FStar_Reflection_V1_Data.argv Prims.list -> - FStar_Reflection_Types.term -> - ((FStar_Reflection_Types.term * FStar_Reflection_V1_Data.argv + FStarC_Reflection_V1_Data.argv Prims.list -> + FStarC_Reflection_Types.term -> + ((FStarC_Reflection_Types.term * FStarC_Reflection_V1_Data.argv Prims.list), unit) FStar_Tactics_Effect.tac_repr) = @@ -79,7 +79,7 @@ let rec (collect_app' : (fun uu___1 -> (fun uu___1 -> match uu___1 with - | FStar_Reflection_V1_Data.Tv_App (l, r) -> + | FStarC_Reflection_V1_Data.Tv_App (l, r) -> Obj.magic (Obj.repr (collect_app' (r :: args) l)) | uu___2 -> Obj.magic @@ -87,13 +87,14 @@ let rec (collect_app' : (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> (t, args))))) uu___1) let (collect_app : - FStar_Reflection_Types.term -> - ((FStar_Reflection_Types.term * FStar_Reflection_V1_Data.argv Prims.list), + FStarC_Reflection_Types.term -> + ((FStarC_Reflection_Types.term * FStarC_Reflection_V1_Data.argv + Prims.list), unit) FStar_Tactics_Effect.tac_repr) = collect_app' [] type comparison = - | Eq of FStar_Reflection_Types.typ FStar_Pervasives_Native.option - | BoolEq of FStar_Reflection_Types.typ FStar_Pervasives_Native.option + | Eq of FStarC_Reflection_Types.typ FStar_Pervasives_Native.option + | BoolEq of FStarC_Reflection_Types.typ FStar_Pervasives_Native.option | Lt | Le | Gt @@ -101,12 +102,12 @@ type comparison = let (uu___is_Eq : comparison -> Prims.bool) = fun projectee -> match projectee with | Eq _0 -> true | uu___ -> false let (__proj__Eq__item___0 : - comparison -> FStar_Reflection_Types.typ FStar_Pervasives_Native.option) = + comparison -> FStarC_Reflection_Types.typ FStar_Pervasives_Native.option) = fun projectee -> match projectee with | Eq _0 -> _0 let (uu___is_BoolEq : comparison -> Prims.bool) = fun projectee -> match projectee with | BoolEq _0 -> true | uu___ -> false let (__proj__BoolEq__item___0 : - comparison -> FStar_Reflection_Types.typ FStar_Pervasives_Native.option) = + comparison -> FStarC_Reflection_Types.typ FStar_Pervasives_Native.option) = fun projectee -> match projectee with | BoolEq _0 -> _0 let (uu___is_Lt : comparison -> Prims.bool) = fun projectee -> match projectee with | Lt -> true | uu___ -> false @@ -119,20 +120,20 @@ let (uu___is_Ge : comparison -> Prims.bool) = type formula = | True_ | False_ - | Comp of comparison * FStar_Reflection_Types.term * - FStar_Reflection_Types.term - | And of FStar_Reflection_Types.term * FStar_Reflection_Types.term - | Or of FStar_Reflection_Types.term * FStar_Reflection_Types.term - | Not of FStar_Reflection_Types.term - | Implies of FStar_Reflection_Types.term * FStar_Reflection_Types.term - | Iff of FStar_Reflection_Types.term * FStar_Reflection_Types.term - | Forall of FStar_Reflection_Types.bv * FStar_Reflection_Types.typ * - FStar_Reflection_Types.term - | Exists of FStar_Reflection_Types.bv * FStar_Reflection_Types.typ * - FStar_Reflection_Types.term - | App of FStar_Reflection_Types.term * FStar_Reflection_Types.term - | Name of FStar_Reflection_Types.bv - | FV of FStar_Reflection_Types.fv + | Comp of comparison * FStarC_Reflection_Types.term * + FStarC_Reflection_Types.term + | And of FStarC_Reflection_Types.term * FStarC_Reflection_Types.term + | Or of FStarC_Reflection_Types.term * FStarC_Reflection_Types.term + | Not of FStarC_Reflection_Types.term + | Implies of FStarC_Reflection_Types.term * FStarC_Reflection_Types.term + | Iff of FStarC_Reflection_Types.term * FStarC_Reflection_Types.term + | Forall of FStarC_Reflection_Types.bv * FStarC_Reflection_Types.typ * + FStarC_Reflection_Types.term + | Exists of FStarC_Reflection_Types.bv * FStarC_Reflection_Types.typ * + FStarC_Reflection_Types.term + | App of FStarC_Reflection_Types.term * FStarC_Reflection_Types.term + | Name of FStarC_Reflection_Types.bv + | FV of FStarC_Reflection_Types.fv | IntLit of Prims.int | F_Unknown let (uu___is_True_ : formula -> Prims.bool) = @@ -144,74 +145,74 @@ let (uu___is_Comp : formula -> Prims.bool) = match projectee with | Comp (_0, _1, _2) -> true | uu___ -> false let (__proj__Comp__item___0 : formula -> comparison) = fun projectee -> match projectee with | Comp (_0, _1, _2) -> _0 -let (__proj__Comp__item___1 : formula -> FStar_Reflection_Types.term) = +let (__proj__Comp__item___1 : formula -> FStarC_Reflection_Types.term) = fun projectee -> match projectee with | Comp (_0, _1, _2) -> _1 -let (__proj__Comp__item___2 : formula -> FStar_Reflection_Types.term) = +let (__proj__Comp__item___2 : formula -> FStarC_Reflection_Types.term) = fun projectee -> match projectee with | Comp (_0, _1, _2) -> _2 let (uu___is_And : formula -> Prims.bool) = fun projectee -> match projectee with | And (_0, _1) -> true | uu___ -> false -let (__proj__And__item___0 : formula -> FStar_Reflection_Types.term) = +let (__proj__And__item___0 : formula -> FStarC_Reflection_Types.term) = fun projectee -> match projectee with | And (_0, _1) -> _0 -let (__proj__And__item___1 : formula -> FStar_Reflection_Types.term) = +let (__proj__And__item___1 : formula -> FStarC_Reflection_Types.term) = fun projectee -> match projectee with | And (_0, _1) -> _1 let (uu___is_Or : formula -> Prims.bool) = fun projectee -> match projectee with | Or (_0, _1) -> true | uu___ -> false -let (__proj__Or__item___0 : formula -> FStar_Reflection_Types.term) = +let (__proj__Or__item___0 : formula -> FStarC_Reflection_Types.term) = fun projectee -> match projectee with | Or (_0, _1) -> _0 -let (__proj__Or__item___1 : formula -> FStar_Reflection_Types.term) = +let (__proj__Or__item___1 : formula -> FStarC_Reflection_Types.term) = fun projectee -> match projectee with | Or (_0, _1) -> _1 let (uu___is_Not : formula -> Prims.bool) = fun projectee -> match projectee with | Not _0 -> true | uu___ -> false -let (__proj__Not__item___0 : formula -> FStar_Reflection_Types.term) = +let (__proj__Not__item___0 : formula -> FStarC_Reflection_Types.term) = fun projectee -> match projectee with | Not _0 -> _0 let (uu___is_Implies : formula -> Prims.bool) = fun projectee -> match projectee with | Implies (_0, _1) -> true | uu___ -> false -let (__proj__Implies__item___0 : formula -> FStar_Reflection_Types.term) = +let (__proj__Implies__item___0 : formula -> FStarC_Reflection_Types.term) = fun projectee -> match projectee with | Implies (_0, _1) -> _0 -let (__proj__Implies__item___1 : formula -> FStar_Reflection_Types.term) = +let (__proj__Implies__item___1 : formula -> FStarC_Reflection_Types.term) = fun projectee -> match projectee with | Implies (_0, _1) -> _1 let (uu___is_Iff : formula -> Prims.bool) = fun projectee -> match projectee with | Iff (_0, _1) -> true | uu___ -> false -let (__proj__Iff__item___0 : formula -> FStar_Reflection_Types.term) = +let (__proj__Iff__item___0 : formula -> FStarC_Reflection_Types.term) = fun projectee -> match projectee with | Iff (_0, _1) -> _0 -let (__proj__Iff__item___1 : formula -> FStar_Reflection_Types.term) = +let (__proj__Iff__item___1 : formula -> FStarC_Reflection_Types.term) = fun projectee -> match projectee with | Iff (_0, _1) -> _1 let (uu___is_Forall : formula -> Prims.bool) = fun projectee -> match projectee with | Forall (_0, _1, _2) -> true | uu___ -> false -let (__proj__Forall__item___0 : formula -> FStar_Reflection_Types.bv) = +let (__proj__Forall__item___0 : formula -> FStarC_Reflection_Types.bv) = fun projectee -> match projectee with | Forall (_0, _1, _2) -> _0 -let (__proj__Forall__item___1 : formula -> FStar_Reflection_Types.typ) = +let (__proj__Forall__item___1 : formula -> FStarC_Reflection_Types.typ) = fun projectee -> match projectee with | Forall (_0, _1, _2) -> _1 -let (__proj__Forall__item___2 : formula -> FStar_Reflection_Types.term) = +let (__proj__Forall__item___2 : formula -> FStarC_Reflection_Types.term) = fun projectee -> match projectee with | Forall (_0, _1, _2) -> _2 let (uu___is_Exists : formula -> Prims.bool) = fun projectee -> match projectee with | Exists (_0, _1, _2) -> true | uu___ -> false -let (__proj__Exists__item___0 : formula -> FStar_Reflection_Types.bv) = +let (__proj__Exists__item___0 : formula -> FStarC_Reflection_Types.bv) = fun projectee -> match projectee with | Exists (_0, _1, _2) -> _0 -let (__proj__Exists__item___1 : formula -> FStar_Reflection_Types.typ) = +let (__proj__Exists__item___1 : formula -> FStarC_Reflection_Types.typ) = fun projectee -> match projectee with | Exists (_0, _1, _2) -> _1 -let (__proj__Exists__item___2 : formula -> FStar_Reflection_Types.term) = +let (__proj__Exists__item___2 : formula -> FStarC_Reflection_Types.term) = fun projectee -> match projectee with | Exists (_0, _1, _2) -> _2 let (uu___is_App : formula -> Prims.bool) = fun projectee -> match projectee with | App (_0, _1) -> true | uu___ -> false -let (__proj__App__item___0 : formula -> FStar_Reflection_Types.term) = +let (__proj__App__item___0 : formula -> FStarC_Reflection_Types.term) = fun projectee -> match projectee with | App (_0, _1) -> _0 -let (__proj__App__item___1 : formula -> FStar_Reflection_Types.term) = +let (__proj__App__item___1 : formula -> FStarC_Reflection_Types.term) = fun projectee -> match projectee with | App (_0, _1) -> _1 let (uu___is_Name : formula -> Prims.bool) = fun projectee -> match projectee with | Name _0 -> true | uu___ -> false -let (__proj__Name__item___0 : formula -> FStar_Reflection_Types.bv) = +let (__proj__Name__item___0 : formula -> FStarC_Reflection_Types.bv) = fun projectee -> match projectee with | Name _0 -> _0 let (uu___is_FV : formula -> Prims.bool) = fun projectee -> match projectee with | FV _0 -> true | uu___ -> false -let (__proj__FV__item___0 : formula -> FStar_Reflection_Types.fv) = +let (__proj__FV__item___0 : formula -> FStarC_Reflection_Types.fv) = fun projectee -> match projectee with | FV _0 -> _0 let (uu___is_IntLit : formula -> Prims.bool) = fun projectee -> match projectee with | IntLit _0 -> true | uu___ -> false @@ -220,8 +221,8 @@ let (__proj__IntLit__item___0 : formula -> Prims.int) = let (uu___is_F_Unknown : formula -> Prims.bool) = fun projectee -> match projectee with | F_Unknown -> true | uu___ -> false let (mk_Forall : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> (formula, unit) FStar_Tactics_Effect.tac_repr) = fun uu___1 -> @@ -232,31 +233,32 @@ let (mk_Forall : (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> Forall - ((FStar_Reflection_V1_Builtins.pack_bv + ((FStarC_Reflection_V1_Builtins.pack_bv { - FStar_Reflection_V1_Data.bv_ppname = - (FStar_Reflection_V1_Data.as_ppname "x"); - FStar_Reflection_V1_Data.bv_index = Prims.int_zero + FStarC_Reflection_V1_Data.bv_ppname = + (FStarC_Reflection_V1_Data.as_ppname "x"); + FStarC_Reflection_V1_Data.bv_index = + Prims.int_zero }), typ, - (FStar_Reflection_V1_Builtins.pack_ln - (FStar_Reflection_V1_Data.Tv_App + (FStarC_Reflection_V1_Builtins.pack_ln + (FStarC_Reflection_V1_Data.Tv_App (pred, - ((FStar_Reflection_V1_Builtins.pack_ln - (FStar_Reflection_V1_Data.Tv_BVar - (FStar_Reflection_V1_Builtins.pack_bv + ((FStarC_Reflection_V1_Builtins.pack_ln + (FStarC_Reflection_V1_Data.Tv_BVar + (FStarC_Reflection_V1_Builtins.pack_bv { - FStar_Reflection_V1_Data.bv_ppname + FStarC_Reflection_V1_Data.bv_ppname = - (FStar_Reflection_V1_Data.as_ppname + (FStarC_Reflection_V1_Data.as_ppname "x"); - FStar_Reflection_V1_Data.bv_index + FStarC_Reflection_V1_Data.bv_index = Prims.int_zero }))), - FStar_Reflection_V1_Data.Q_Explicit)))))))) + FStarC_Reflection_V1_Data.Q_Explicit)))))))) uu___1 uu___ let (mk_Exists : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> (formula, unit) FStar_Tactics_Effect.tac_repr) = fun uu___1 -> @@ -267,30 +269,31 @@ let (mk_Exists : (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> Exists - ((FStar_Reflection_V1_Builtins.pack_bv + ((FStarC_Reflection_V1_Builtins.pack_bv { - FStar_Reflection_V1_Data.bv_ppname = - (FStar_Reflection_V1_Data.as_ppname "x"); - FStar_Reflection_V1_Data.bv_index = Prims.int_zero + FStarC_Reflection_V1_Data.bv_ppname = + (FStarC_Reflection_V1_Data.as_ppname "x"); + FStarC_Reflection_V1_Data.bv_index = + Prims.int_zero }), typ, - (FStar_Reflection_V1_Builtins.pack_ln - (FStar_Reflection_V1_Data.Tv_App + (FStarC_Reflection_V1_Builtins.pack_ln + (FStarC_Reflection_V1_Data.Tv_App (pred, - ((FStar_Reflection_V1_Builtins.pack_ln - (FStar_Reflection_V1_Data.Tv_BVar - (FStar_Reflection_V1_Builtins.pack_bv + ((FStarC_Reflection_V1_Builtins.pack_ln + (FStarC_Reflection_V1_Data.Tv_BVar + (FStarC_Reflection_V1_Builtins.pack_bv { - FStar_Reflection_V1_Data.bv_ppname + FStarC_Reflection_V1_Data.bv_ppname = - (FStar_Reflection_V1_Data.as_ppname + (FStarC_Reflection_V1_Data.as_ppname "x"); - FStar_Reflection_V1_Data.bv_index + FStarC_Reflection_V1_Data.bv_index = Prims.int_zero }))), - FStar_Reflection_V1_Data.Q_Explicit)))))))) + FStarC_Reflection_V1_Data.Q_Explicit)))))))) uu___1 uu___ let (term_as_formula' : - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.term -> (formula, unit) FStar_Tactics_Effect.tac_repr) = fun t -> @@ -309,42 +312,42 @@ let (term_as_formula' : (fun uu___1 -> (fun uu___1 -> match uu___1 with - | FStar_Reflection_V1_Data.Tv_Var n -> + | FStarC_Reflection_V1_Data.Tv_Var n -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> Name n))) - | FStar_Reflection_V1_Data.Tv_FVar fv -> + | FStarC_Reflection_V1_Data.Tv_FVar fv -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> if - (FStar_Reflection_V1_Builtins.inspect_fv fv) = + (FStarC_Reflection_V1_Builtins.inspect_fv fv) = FStar_Reflection_Const.true_qn then True_ else if - (FStar_Reflection_V1_Builtins.inspect_fv fv) = - FStar_Reflection_Const.false_qn + (FStarC_Reflection_V1_Builtins.inspect_fv fv) + = FStar_Reflection_Const.false_qn then False_ else FV fv))) - | FStar_Reflection_V1_Data.Tv_UInst (fv, uu___2) -> + | FStarC_Reflection_V1_Data.Tv_UInst (fv, uu___2) -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> if - (FStar_Reflection_V1_Builtins.inspect_fv fv) = + (FStarC_Reflection_V1_Builtins.inspect_fv fv) = FStar_Reflection_Const.true_qn then True_ else if - (FStar_Reflection_V1_Builtins.inspect_fv fv) = - FStar_Reflection_Const.false_qn + (FStarC_Reflection_V1_Builtins.inspect_fv fv) + = FStar_Reflection_Const.false_qn then False_ else FV fv))) - | FStar_Reflection_V1_Data.Tv_App (h0, t1) -> + | FStarC_Reflection_V1_Data.Tv_App (h0, t1) -> Obj.magic (Obj.repr (let uu___2 = collect_app h0 in @@ -393,26 +396,26 @@ let (term_as_formula' : (Obj.magic uu___4) (fun uu___5 -> (fun h1 -> - match ((FStar_Reflection_V1_Builtins.inspect_ln + match ((FStarC_Reflection_V1_Builtins.inspect_ln h1), (FStar_List_Tot_Base.op_At ts [t1])) with - | (FStar_Reflection_V1_Data.Tv_FVar + | (FStarC_Reflection_V1_Data.Tv_FVar fv, (a1, - FStar_Reflection_V1_Data.Q_Implicit):: + FStarC_Reflection_V1_Data.Q_Implicit):: (a2, - FStar_Reflection_V1_Data.Q_Explicit):: + FStarC_Reflection_V1_Data.Q_Explicit):: (a3, - FStar_Reflection_V1_Data.Q_Explicit)::[]) + FStarC_Reflection_V1_Data.Q_Explicit)::[]) -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___5 -> if - (FStar_Reflection_V1_Builtins.inspect_fv + (FStarC_Reflection_V1_Builtins.inspect_fv fv) = FStar_Reflection_Const.eq2_qn @@ -425,7 +428,7 @@ let (term_as_formula' : a3) else if - (FStar_Reflection_V1_Builtins.inspect_fv + (FStarC_Reflection_V1_Builtins.inspect_fv fv) = FStar_Reflection_Const.eq1_qn @@ -437,7 +440,7 @@ let (term_as_formula' : a3) else if - (FStar_Reflection_V1_Builtins.inspect_fv + (FStarC_Reflection_V1_Builtins.inspect_fv fv) = FStar_Reflection_Const.lt_qn then @@ -446,7 +449,7 @@ let (term_as_formula' : a3) else if - (FStar_Reflection_V1_Builtins.inspect_fv + (FStarC_Reflection_V1_Builtins.inspect_fv fv) = FStar_Reflection_Const.lte_qn then @@ -455,7 +458,7 @@ let (term_as_formula' : a3) else if - (FStar_Reflection_V1_Builtins.inspect_fv + (FStarC_Reflection_V1_Builtins.inspect_fv fv) = FStar_Reflection_Const.gt_qn then @@ -464,7 +467,7 @@ let (term_as_formula' : a3) else if - (FStar_Reflection_V1_Builtins.inspect_fv + (FStarC_Reflection_V1_Builtins.inspect_fv fv) = FStar_Reflection_Const.gte_qn then @@ -476,19 +479,19 @@ let (term_as_formula' : (h0, (FStar_Pervasives_Native.fst t1))))) - | (FStar_Reflection_V1_Data.Tv_FVar + | (FStarC_Reflection_V1_Data.Tv_FVar fv, (a1, - FStar_Reflection_V1_Data.Q_Explicit):: + FStarC_Reflection_V1_Data.Q_Explicit):: (a2, - FStar_Reflection_V1_Data.Q_Explicit)::[]) + FStarC_Reflection_V1_Data.Q_Explicit)::[]) -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___5 -> if - (FStar_Reflection_V1_Builtins.inspect_fv + (FStarC_Reflection_V1_Builtins.inspect_fv fv) = FStar_Reflection_Const.imp_qn @@ -497,7 +500,7 @@ let (term_as_formula' : (a1, a2) else if - (FStar_Reflection_V1_Builtins.inspect_fv + (FStarC_Reflection_V1_Builtins.inspect_fv fv) = FStar_Reflection_Const.and_qn @@ -505,7 +508,7 @@ let (term_as_formula' : And (a1, a2) else if - (FStar_Reflection_V1_Builtins.inspect_fv + (FStarC_Reflection_V1_Builtins.inspect_fv fv) = FStar_Reflection_Const.iff_qn then @@ -513,7 +516,7 @@ let (term_as_formula' : (a1, a2) else if - (FStar_Reflection_V1_Builtins.inspect_fv + (FStarC_Reflection_V1_Builtins.inspect_fv fv) = FStar_Reflection_Const.or_qn then @@ -521,7 +524,7 @@ let (term_as_formula' : (a1, a2) else if - (FStar_Reflection_V1_Builtins.inspect_fv + (FStarC_Reflection_V1_Builtins.inspect_fv fv) = FStar_Reflection_Const.eq2_qn then @@ -531,7 +534,7 @@ let (term_as_formula' : a1, a2) else if - (FStar_Reflection_V1_Builtins.inspect_fv + (FStarC_Reflection_V1_Builtins.inspect_fv fv) = FStar_Reflection_Const.eq1_qn then @@ -544,12 +547,12 @@ let (term_as_formula' : (h0, (FStar_Pervasives_Native.fst t1))))) - | (FStar_Reflection_V1_Data.Tv_FVar + | (FStarC_Reflection_V1_Data.Tv_FVar fv, (a1, - FStar_Reflection_V1_Data.Q_Implicit):: + FStarC_Reflection_V1_Data.Q_Implicit):: (a2, - FStar_Reflection_V1_Data.Q_Explicit)::[]) + FStarC_Reflection_V1_Data.Q_Explicit)::[]) -> Obj.magic (Obj.repr @@ -557,7 +560,7 @@ let (term_as_formula' : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___6 -> - FStar_Reflection_V1_Builtins.inspect_fv + FStarC_Reflection_V1_Builtins.inspect_fv fv)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -607,42 +610,42 @@ let (term_as_formula' : (FStar_Pervasives_Native.fst t1))))))) uu___6))) - | (FStar_Reflection_V1_Data.Tv_FVar + | (FStarC_Reflection_V1_Data.Tv_FVar fv, (a, - FStar_Reflection_V1_Data.Q_Explicit)::[]) + FStarC_Reflection_V1_Data.Q_Explicit)::[]) -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___5 -> if - (FStar_Reflection_V1_Builtins.inspect_fv + (FStarC_Reflection_V1_Builtins.inspect_fv fv) = FStar_Reflection_Const.not_qn then Not a else if - (FStar_Reflection_V1_Builtins.inspect_fv + (FStarC_Reflection_V1_Builtins.inspect_fv fv) = FStar_Reflection_Const.b2t_qn then (if - FStar_Reflection_V1_Builtins.term_eq + FStarC_Reflection_V1_Builtins.term_eq a - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const - FStar_Reflection_V2_Data.C_False)) + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const + FStarC_Reflection_V2_Data.C_False)) then False_ else if - FStar_Reflection_V1_Builtins.term_eq + FStarC_Reflection_V1_Builtins.term_eq a - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const - FStar_Reflection_V2_Data.C_True)) + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const + FStarC_Reflection_V2_Data.C_True)) then True_ else App @@ -665,70 +668,70 @@ let (term_as_formula' : (FStar_Pervasives_Native.fst t1)))))) uu___5))) uu___3))) - | FStar_Reflection_V1_Data.Tv_Const - (FStar_Reflection_V1_Data.C_Int i) -> + | FStarC_Reflection_V1_Data.Tv_Const + (FStarC_Reflection_V1_Data.C_Int i) -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> IntLit i))) - | FStar_Reflection_V1_Data.Tv_Let + | FStarC_Reflection_V1_Data.Tv_Let (uu___2, uu___3, uu___4, uu___5, uu___6, uu___7) -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___8 -> F_Unknown))) - | FStar_Reflection_V1_Data.Tv_Match (uu___2, uu___3, uu___4) -> + | FStarC_Reflection_V1_Data.Tv_Match (uu___2, uu___3, uu___4) -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___5 -> F_Unknown))) - | FStar_Reflection_V1_Data.Tv_Type uu___2 -> + | FStarC_Reflection_V1_Data.Tv_Type uu___2 -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> F_Unknown))) - | FStar_Reflection_V1_Data.Tv_Abs (uu___2, uu___3) -> + | FStarC_Reflection_V1_Data.Tv_Abs (uu___2, uu___3) -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> F_Unknown))) - | FStar_Reflection_V1_Data.Tv_Arrow (uu___2, uu___3) -> + | FStarC_Reflection_V1_Data.Tv_Arrow (uu___2, uu___3) -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> F_Unknown))) - | FStar_Reflection_V1_Data.Tv_Uvar (uu___2, uu___3) -> + | FStarC_Reflection_V1_Data.Tv_Uvar (uu___2, uu___3) -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> F_Unknown))) - | FStar_Reflection_V1_Data.Tv_Unknown -> + | FStarC_Reflection_V1_Data.Tv_Unknown -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> F_Unknown))) - | FStar_Reflection_V1_Data.Tv_Unsupp -> + | FStarC_Reflection_V1_Data.Tv_Unsupp -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> F_Unknown))) - | FStar_Reflection_V1_Data.Tv_Refine (uu___2, uu___3, uu___4) -> + | FStarC_Reflection_V1_Data.Tv_Refine (uu___2, uu___3, uu___4) -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___5 -> F_Unknown))) - | FStar_Reflection_V1_Data.Tv_Const uu___2 -> + | FStarC_Reflection_V1_Data.Tv_Const uu___2 -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> F_Unknown))) - | FStar_Reflection_V1_Data.Tv_BVar uu___2 -> + | FStarC_Reflection_V1_Data.Tv_BVar uu___2 -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> F_Unknown)))) uu___1) let (term_as_formula : - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.term -> (formula, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> @@ -741,107 +744,108 @@ let (term_as_formula : | FStar_Pervasives_Native.Some t1 -> Obj.magic (Obj.repr (term_as_formula' t1))) uu___ let (term_as_formula_total : - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.term -> (formula, unit) FStar_Tactics_Effect.tac_repr) = fun t -> term_as_formula' (FStar_Reflection_V1_Derived.maybe_unsquash_term t) -let (formula_as_term_view : formula -> FStar_Reflection_V1_Data.term_view) = +let (formula_as_term_view : formula -> FStarC_Reflection_V1_Data.term_view) = fun f -> let mk_app' tv args = FStar_List_Tot_Base.fold_left (fun tv1 -> fun a -> - FStar_Reflection_V1_Data.Tv_App - ((FStar_Reflection_V1_Builtins.pack_ln tv1), a)) tv args in - let e = FStar_Reflection_V1_Data.Q_Explicit in - let i = FStar_Reflection_V1_Data.Q_Implicit in + FStarC_Reflection_V1_Data.Tv_App + ((FStarC_Reflection_V1_Builtins.pack_ln tv1), a)) tv args in + let e = FStarC_Reflection_V1_Data.Q_Explicit in + let i = FStarC_Reflection_V1_Data.Q_Implicit in match f with | True_ -> - FStar_Reflection_V1_Data.Tv_FVar - (FStar_Reflection_V1_Builtins.pack_fv + FStarC_Reflection_V1_Data.Tv_FVar + (FStarC_Reflection_V1_Builtins.pack_fv FStar_Reflection_Const.true_qn) | False_ -> - FStar_Reflection_V1_Data.Tv_FVar - (FStar_Reflection_V1_Builtins.pack_fv + FStarC_Reflection_V1_Data.Tv_FVar + (FStarC_Reflection_V1_Builtins.pack_fv FStar_Reflection_Const.false_qn) | Comp (Eq (FStar_Pervasives_Native.None), l, r) -> mk_app' - (FStar_Reflection_V1_Data.Tv_FVar - (FStar_Reflection_V1_Builtins.pack_fv + (FStarC_Reflection_V1_Data.Tv_FVar + (FStarC_Reflection_V1_Builtins.pack_fv FStar_Reflection_Const.eq2_qn)) [(l, e); (r, e)] | Comp (Eq (FStar_Pervasives_Native.Some t), l, r) -> mk_app' - (FStar_Reflection_V1_Data.Tv_FVar - (FStar_Reflection_V1_Builtins.pack_fv + (FStarC_Reflection_V1_Data.Tv_FVar + (FStarC_Reflection_V1_Builtins.pack_fv FStar_Reflection_Const.eq2_qn)) [(t, i); (l, e); (r, e)] | Comp (BoolEq (FStar_Pervasives_Native.None), l, r) -> mk_app' - (FStar_Reflection_V1_Data.Tv_FVar - (FStar_Reflection_V1_Builtins.pack_fv + (FStarC_Reflection_V1_Data.Tv_FVar + (FStarC_Reflection_V1_Builtins.pack_fv FStar_Reflection_Const.eq1_qn)) [(l, e); (r, e)] | Comp (BoolEq (FStar_Pervasives_Native.Some t), l, r) -> mk_app' - (FStar_Reflection_V1_Data.Tv_FVar - (FStar_Reflection_V1_Builtins.pack_fv + (FStarC_Reflection_V1_Data.Tv_FVar + (FStarC_Reflection_V1_Builtins.pack_fv FStar_Reflection_Const.eq1_qn)) [(t, i); (l, e); (r, e)] | Comp (Lt, l, r) -> mk_app' - (FStar_Reflection_V1_Data.Tv_FVar - (FStar_Reflection_V1_Builtins.pack_fv + (FStarC_Reflection_V1_Data.Tv_FVar + (FStarC_Reflection_V1_Builtins.pack_fv FStar_Reflection_Const.lt_qn)) [(l, e); (r, e)] | Comp (Le, l, r) -> mk_app' - (FStar_Reflection_V1_Data.Tv_FVar - (FStar_Reflection_V1_Builtins.pack_fv + (FStarC_Reflection_V1_Data.Tv_FVar + (FStarC_Reflection_V1_Builtins.pack_fv FStar_Reflection_Const.lte_qn)) [(l, e); (r, e)] | Comp (Gt, l, r) -> mk_app' - (FStar_Reflection_V1_Data.Tv_FVar - (FStar_Reflection_V1_Builtins.pack_fv + (FStarC_Reflection_V1_Data.Tv_FVar + (FStarC_Reflection_V1_Builtins.pack_fv FStar_Reflection_Const.gt_qn)) [(l, e); (r, e)] | Comp (Ge, l, r) -> mk_app' - (FStar_Reflection_V1_Data.Tv_FVar - (FStar_Reflection_V1_Builtins.pack_fv + (FStarC_Reflection_V1_Data.Tv_FVar + (FStarC_Reflection_V1_Builtins.pack_fv FStar_Reflection_Const.gte_qn)) [(l, e); (r, e)] | And (p, q) -> mk_app' - (FStar_Reflection_V1_Data.Tv_FVar - (FStar_Reflection_V1_Builtins.pack_fv + (FStarC_Reflection_V1_Data.Tv_FVar + (FStarC_Reflection_V1_Builtins.pack_fv FStar_Reflection_Const.and_qn)) [(p, e); (q, e)] | Or (p, q) -> mk_app' - (FStar_Reflection_V1_Data.Tv_FVar - (FStar_Reflection_V1_Builtins.pack_fv + (FStarC_Reflection_V1_Data.Tv_FVar + (FStarC_Reflection_V1_Builtins.pack_fv FStar_Reflection_Const.or_qn)) [(p, e); (q, e)] | Implies (p, q) -> mk_app' - (FStar_Reflection_V1_Data.Tv_FVar - (FStar_Reflection_V1_Builtins.pack_fv + (FStarC_Reflection_V1_Data.Tv_FVar + (FStarC_Reflection_V1_Builtins.pack_fv FStar_Reflection_Const.imp_qn)) [(p, e); (q, e)] | Not p -> mk_app' - (FStar_Reflection_V1_Data.Tv_FVar - (FStar_Reflection_V1_Builtins.pack_fv + (FStarC_Reflection_V1_Data.Tv_FVar + (FStarC_Reflection_V1_Builtins.pack_fv FStar_Reflection_Const.not_qn)) [(p, e)] | Iff (p, q) -> mk_app' - (FStar_Reflection_V1_Data.Tv_FVar - (FStar_Reflection_V1_Builtins.pack_fv + (FStarC_Reflection_V1_Data.Tv_FVar + (FStarC_Reflection_V1_Builtins.pack_fv FStar_Reflection_Const.iff_qn)) [(p, e); (q, e)] - | Forall (b, sort, t) -> FStar_Reflection_V1_Data.Tv_Unknown - | Exists (b, sort, t) -> FStar_Reflection_V1_Data.Tv_Unknown + | Forall (b, sort, t) -> FStarC_Reflection_V1_Data.Tv_Unknown + | Exists (b, sort, t) -> FStarC_Reflection_V1_Data.Tv_Unknown | App (p, q) -> - FStar_Reflection_V1_Data.Tv_App - (p, (q, FStar_Reflection_V1_Data.Q_Explicit)) - | Name b -> FStar_Reflection_V1_Data.Tv_Var b - | FV fv -> FStar_Reflection_V1_Data.Tv_FVar fv + FStarC_Reflection_V1_Data.Tv_App + (p, (q, FStarC_Reflection_V1_Data.Q_Explicit)) + | Name b -> FStarC_Reflection_V1_Data.Tv_Var b + | FV fv -> FStarC_Reflection_V1_Data.Tv_FVar fv | IntLit i1 -> - FStar_Reflection_V1_Data.Tv_Const (FStar_Reflection_V1_Data.C_Int i1) - | F_Unknown -> FStar_Reflection_V1_Data.Tv_Unknown -let (formula_as_term : formula -> FStar_Reflection_Types.term) = - fun f -> FStar_Reflection_V1_Builtins.pack_ln (formula_as_term_view f) + FStarC_Reflection_V1_Data.Tv_Const + (FStarC_Reflection_V1_Data.C_Int i1) + | F_Unknown -> FStarC_Reflection_V1_Data.Tv_Unknown +let (formula_as_term : formula -> FStarC_Reflection_Types.term) = + fun f -> FStarC_Reflection_V1_Builtins.pack_ln (formula_as_term_view f) let (formula_to_string : formula -> (Prims.string, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> @@ -871,7 +875,8 @@ let (formula_to_string : (Obj.repr (let uu___2 = let uu___3 = - FStar_Tactics_V1_Builtins.term_to_string t in + FStarC_Tactics_V1_Builtins.term_to_string + t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -932,7 +937,7 @@ let (formula_to_string : let uu___3 = let uu___4 = let uu___5 = - FStar_Tactics_V1_Builtins.term_to_string l in + FStarC_Tactics_V1_Builtins.term_to_string l in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -956,7 +961,7 @@ let (formula_to_string : let uu___7 = let uu___8 = let uu___9 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string r in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1100,7 +1105,8 @@ let (formula_to_string : (Obj.repr (let uu___2 = let uu___3 = - FStar_Tactics_V1_Builtins.term_to_string t in + FStarC_Tactics_V1_Builtins.term_to_string + t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1161,7 +1167,7 @@ let (formula_to_string : let uu___3 = let uu___4 = let uu___5 = - FStar_Tactics_V1_Builtins.term_to_string l in + FStarC_Tactics_V1_Builtins.term_to_string l in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1185,7 +1191,7 @@ let (formula_to_string : let uu___7 = let uu___8 = let uu___9 = - FStar_Tactics_V1_Builtins.term_to_string + FStarC_Tactics_V1_Builtins.term_to_string r in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1317,7 +1323,7 @@ let (formula_to_string : Obj.magic (Obj.repr (let uu___ = - let uu___1 = FStar_Tactics_V1_Builtins.term_to_string l in + let uu___1 = FStarC_Tactics_V1_Builtins.term_to_string l in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1337,7 +1343,7 @@ let (formula_to_string : let uu___3 = let uu___4 = let uu___5 = - FStar_Tactics_V1_Builtins.term_to_string r in + FStarC_Tactics_V1_Builtins.term_to_string r in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1420,7 +1426,7 @@ let (formula_to_string : Obj.magic (Obj.repr (let uu___ = - let uu___1 = FStar_Tactics_V1_Builtins.term_to_string l in + let uu___1 = FStarC_Tactics_V1_Builtins.term_to_string l in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1440,7 +1446,7 @@ let (formula_to_string : let uu___3 = let uu___4 = let uu___5 = - FStar_Tactics_V1_Builtins.term_to_string r in + FStarC_Tactics_V1_Builtins.term_to_string r in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1523,7 +1529,7 @@ let (formula_to_string : Obj.magic (Obj.repr (let uu___ = - let uu___1 = FStar_Tactics_V1_Builtins.term_to_string l in + let uu___1 = FStarC_Tactics_V1_Builtins.term_to_string l in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1543,7 +1549,7 @@ let (formula_to_string : let uu___3 = let uu___4 = let uu___5 = - FStar_Tactics_V1_Builtins.term_to_string r in + FStarC_Tactics_V1_Builtins.term_to_string r in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1626,7 +1632,7 @@ let (formula_to_string : Obj.magic (Obj.repr (let uu___ = - let uu___1 = FStar_Tactics_V1_Builtins.term_to_string l in + let uu___1 = FStarC_Tactics_V1_Builtins.term_to_string l in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1646,7 +1652,7 @@ let (formula_to_string : let uu___3 = let uu___4 = let uu___5 = - FStar_Tactics_V1_Builtins.term_to_string r in + FStarC_Tactics_V1_Builtins.term_to_string r in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1729,7 +1735,7 @@ let (formula_to_string : Obj.magic (Obj.repr (let uu___ = - let uu___1 = FStar_Tactics_V1_Builtins.term_to_string p in + let uu___1 = FStarC_Tactics_V1_Builtins.term_to_string p in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1749,7 +1755,7 @@ let (formula_to_string : let uu___3 = let uu___4 = let uu___5 = - FStar_Tactics_V1_Builtins.term_to_string q in + FStarC_Tactics_V1_Builtins.term_to_string q in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1832,7 +1838,7 @@ let (formula_to_string : Obj.magic (Obj.repr (let uu___ = - let uu___1 = FStar_Tactics_V1_Builtins.term_to_string p in + let uu___1 = FStarC_Tactics_V1_Builtins.term_to_string p in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1852,7 +1858,7 @@ let (formula_to_string : let uu___3 = let uu___4 = let uu___5 = - FStar_Tactics_V1_Builtins.term_to_string q in + FStarC_Tactics_V1_Builtins.term_to_string q in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1935,7 +1941,7 @@ let (formula_to_string : Obj.magic (Obj.repr (let uu___ = - let uu___1 = FStar_Tactics_V1_Builtins.term_to_string p in + let uu___1 = FStarC_Tactics_V1_Builtins.term_to_string p in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1955,7 +1961,7 @@ let (formula_to_string : let uu___3 = let uu___4 = let uu___5 = - FStar_Tactics_V1_Builtins.term_to_string q in + FStarC_Tactics_V1_Builtins.term_to_string q in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2038,7 +2044,7 @@ let (formula_to_string : Obj.magic (Obj.repr (let uu___ = - let uu___1 = FStar_Tactics_V1_Builtins.term_to_string p in + let uu___1 = FStarC_Tactics_V1_Builtins.term_to_string p in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2075,7 +2081,7 @@ let (formula_to_string : Obj.magic (Obj.repr (let uu___ = - let uu___1 = FStar_Tactics_V1_Builtins.term_to_string p in + let uu___1 = FStarC_Tactics_V1_Builtins.term_to_string p in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2095,7 +2101,7 @@ let (formula_to_string : let uu___3 = let uu___4 = let uu___5 = - FStar_Tactics_V1_Builtins.term_to_string q in + FStarC_Tactics_V1_Builtins.term_to_string q in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2178,7 +2184,7 @@ let (formula_to_string : Obj.magic (Obj.repr (let uu___ = - let uu___1 = FStar_Tactics_V1_Builtins.term_to_string t in + let uu___1 = FStarC_Tactics_V1_Builtins.term_to_string t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2215,7 +2221,7 @@ let (formula_to_string : Obj.magic (Obj.repr (let uu___ = - let uu___1 = FStar_Tactics_V1_Builtins.term_to_string t in + let uu___1 = FStarC_Tactics_V1_Builtins.term_to_string t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2252,7 +2258,7 @@ let (formula_to_string : Obj.magic (Obj.repr (let uu___ = - let uu___1 = FStar_Tactics_V1_Builtins.term_to_string p in + let uu___1 = FStarC_Tactics_V1_Builtins.term_to_string p in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2272,7 +2278,7 @@ let (formula_to_string : let uu___3 = let uu___4 = let uu___5 = - FStar_Tactics_V1_Builtins.term_to_string q in + FStarC_Tactics_V1_Builtins.term_to_string q in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2396,7 +2402,7 @@ let (formula_to_string : Prims.strcat "FV (" (Prims.strcat (FStar_Reflection_V1_Derived.flatten_name - (FStar_Reflection_V1_Builtins.inspect_fv fv)) + (FStarC_Reflection_V1_Builtins.inspect_fv fv)) ")")))) | IntLit i -> Obj.magic diff --git a/ocaml/fstar-lib/generated/FStar_Reflection_V1_Interpreter.ml b/ocaml/fstar-lib/generated/FStar_Reflection_V1_Interpreter.ml deleted file mode 100644 index e316e4ad795..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Reflection_V1_Interpreter.ml +++ /dev/null @@ -1,554 +0,0 @@ -open Prims -let mk1 : - 'res 't1 . - Prims.string -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 'res FStar_Syntax_Embeddings_Base.embedding -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 'res FStar_TypeChecker_NBETerm.embedding -> - ('t1 -> 'res) -> FStar_TypeChecker_Primops_Base.primitive_step - = - fun nm -> - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun f -> - let lid = - FStar_Reflection_V1_Constants.fstar_refl_builtins_lid nm in - FStar_TypeChecker_Primops_Base.mk1' Prims.int_zero lid uu___ - uu___2 uu___1 uu___3 - (fun x -> - let uu___4 = f x in FStar_Pervasives_Native.Some uu___4) - (fun x -> - let uu___4 = f x in FStar_Pervasives_Native.Some uu___4) -let mk2 : - 'res 't1 't2 . - Prims.string -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 'res FStar_Syntax_Embeddings_Base.embedding -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 'res FStar_TypeChecker_NBETerm.embedding -> - ('t1 -> 't2 -> 'res) -> - FStar_TypeChecker_Primops_Base.primitive_step - = - fun nm -> - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun uu___4 -> - fun uu___5 -> - fun f -> - let lid = - FStar_Reflection_V1_Constants.fstar_refl_builtins_lid nm in - FStar_TypeChecker_Primops_Base.mk2' Prims.int_zero lid - uu___ uu___3 uu___1 uu___4 uu___2 uu___5 - (fun x -> - fun y -> - let uu___6 = f x y in - FStar_Pervasives_Native.Some uu___6) - (fun x -> - fun y -> - let uu___6 = f x y in - FStar_Pervasives_Native.Some uu___6) -let mk3 : - 'res 't1 't2 't3 . - Prims.string -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 'res FStar_Syntax_Embeddings_Base.embedding -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 'res FStar_TypeChecker_NBETerm.embedding -> - ('t1 -> 't2 -> 't3 -> 'res) -> - FStar_TypeChecker_Primops_Base.primitive_step - = - fun nm -> - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun uu___4 -> - fun uu___5 -> - fun uu___6 -> - fun uu___7 -> - fun f -> - let lid = - FStar_Reflection_V1_Constants.fstar_refl_builtins_lid - nm in - FStar_TypeChecker_Primops_Base.mk3' Prims.int_zero lid - uu___ uu___4 uu___1 uu___5 uu___2 uu___6 uu___3 - uu___7 - (fun x -> - fun y -> - fun z -> - let uu___8 = f x y z in - FStar_Pervasives_Native.Some uu___8) - (fun x -> - fun y -> - fun z -> - let uu___8 = f x y z in - FStar_Pervasives_Native.Some uu___8) -let (uu___0 : - FStar_Syntax_Syntax.term FStar_Syntax_Embeddings_Base.embedding) = - FStar_Reflection_V1_Embeddings.e_term -let (uu___1 : - FStar_Reflection_V1_Data.term_view FStar_Syntax_Embeddings_Base.embedding) - = FStar_Reflection_V1_Embeddings.e_term_view -let (uu___2 : FStar_Syntax_Syntax.fv FStar_Syntax_Embeddings_Base.embedding) - = FStar_Reflection_V1_Embeddings.e_fv -let (uu___3 : FStar_Syntax_Syntax.bv FStar_Syntax_Embeddings_Base.embedding) - = FStar_Reflection_V1_Embeddings.e_bv -let (uu___4 : - FStar_Reflection_V1_Data.bv_view FStar_Syntax_Embeddings_Base.embedding) = - FStar_Reflection_V1_Embeddings.e_bv_view -let (uu___5 : - FStar_Syntax_Syntax.comp FStar_Syntax_Embeddings_Base.embedding) = - FStar_Reflection_V1_Embeddings.e_comp -let (uu___6 : - FStar_Reflection_V1_Data.comp_view FStar_Syntax_Embeddings_Base.embedding) - = FStar_Reflection_V1_Embeddings.e_comp_view -let (uu___7 : - FStar_Syntax_Syntax.universe FStar_Syntax_Embeddings_Base.embedding) = - FStar_Reflection_V1_Embeddings.e_universe -let (uu___8 : - FStar_Reflection_V1_Data.universe_view - FStar_Syntax_Embeddings_Base.embedding) - = FStar_Reflection_V1_Embeddings.e_universe_view -let (uu___9 : - FStar_Syntax_Syntax.sigelt FStar_Syntax_Embeddings_Base.embedding) = - FStar_Reflection_V1_Embeddings.e_sigelt -let (uu___10 : - FStar_Reflection_V1_Data.sigelt_view FStar_Syntax_Embeddings_Base.embedding) - = FStar_Reflection_V1_Embeddings.e_sigelt_view -let (uu___11 : - FStar_Syntax_Syntax.binder FStar_Syntax_Embeddings_Base.embedding) = - FStar_Reflection_V1_Embeddings.e_binder -let (uu___12 : - FStar_Reflection_V1_Data.binder_view FStar_Syntax_Embeddings_Base.embedding) - = FStar_Reflection_V1_Embeddings.e_binder_view -let (uu___13 : - FStar_Reflection_V1_Data.binders FStar_Syntax_Embeddings_Base.embedding) = - FStar_Reflection_V1_Embeddings.e_binders -let (uu___14 : - FStar_Syntax_Syntax.letbinding FStar_Syntax_Embeddings_Base.embedding) = - FStar_Reflection_V1_Embeddings.e_letbinding -let (uu___15 : - FStar_Reflection_V1_Data.lb_view FStar_Syntax_Embeddings_Base.embedding) = - FStar_Reflection_V1_Embeddings.e_lb_view -let (uu___16 : - FStar_TypeChecker_Env.env FStar_Syntax_Embeddings_Base.embedding) = - FStar_Reflection_V1_Embeddings.e_env -let (uu___17 : - FStar_Reflection_V1_Data.aqualv FStar_Syntax_Embeddings_Base.embedding) = - FStar_Reflection_V1_Embeddings.e_aqualv -let (uu___18 : - FStar_Syntax_Syntax.attribute Prims.list - FStar_Syntax_Embeddings_Base.embedding) - = FStar_Reflection_V1_Embeddings.e_attributes -let (uu___19 : - FStar_Reflection_V1_Data.qualifier Prims.list - FStar_Syntax_Embeddings_Base.embedding) - = FStar_Reflection_V1_Embeddings.e_qualifiers -let (uu___20 : FStar_Syntax_Syntax.term FStar_TypeChecker_NBETerm.embedding) - = FStar_Reflection_V1_NBEEmbeddings.e_term -let (uu___21 : - FStar_Reflection_V1_Data.term_view FStar_TypeChecker_NBETerm.embedding) = - FStar_Reflection_V1_NBEEmbeddings.e_term_view -let (uu___22 : FStar_Syntax_Syntax.fv FStar_TypeChecker_NBETerm.embedding) = - FStar_Reflection_V1_NBEEmbeddings.e_fv -let (uu___23 : FStar_Syntax_Syntax.bv FStar_TypeChecker_NBETerm.embedding) = - FStar_Reflection_V1_NBEEmbeddings.e_bv -let (uu___24 : - FStar_Reflection_V1_Data.bv_view FStar_TypeChecker_NBETerm.embedding) = - FStar_Reflection_V1_NBEEmbeddings.e_bv_view -let (uu___25 : FStar_Syntax_Syntax.comp FStar_TypeChecker_NBETerm.embedding) - = FStar_Reflection_V1_NBEEmbeddings.e_comp -let (uu___26 : - FStar_Reflection_V1_Data.comp_view FStar_TypeChecker_NBETerm.embedding) = - FStar_Reflection_V1_NBEEmbeddings.e_comp_view -let (uu___27 : - FStar_Syntax_Syntax.universe FStar_TypeChecker_NBETerm.embedding) = - FStar_Reflection_V1_NBEEmbeddings.e_universe -let (uu___28 : - FStar_Reflection_V1_Data.universe_view FStar_TypeChecker_NBETerm.embedding) - = FStar_Reflection_V1_NBEEmbeddings.e_universe_view -let (uu___29 : - FStar_Syntax_Syntax.sigelt FStar_TypeChecker_NBETerm.embedding) = - FStar_Reflection_V1_NBEEmbeddings.e_sigelt -let (uu___30 : - FStar_Reflection_V1_Data.sigelt_view FStar_TypeChecker_NBETerm.embedding) = - FStar_Reflection_V1_NBEEmbeddings.e_sigelt_view -let (uu___31 : - FStar_Syntax_Syntax.binder FStar_TypeChecker_NBETerm.embedding) = - FStar_Reflection_V1_NBEEmbeddings.e_binder -let (uu___32 : - FStar_Reflection_V1_Data.binder_view FStar_TypeChecker_NBETerm.embedding) = - FStar_Reflection_V1_NBEEmbeddings.e_binder_view -let (uu___33 : - FStar_Reflection_V1_Data.binders FStar_TypeChecker_NBETerm.embedding) = - FStar_Reflection_V1_NBEEmbeddings.e_binders -let (uu___34 : - FStar_Syntax_Syntax.letbinding FStar_TypeChecker_NBETerm.embedding) = - FStar_Reflection_V1_NBEEmbeddings.e_letbinding -let (uu___35 : - FStar_Reflection_V1_Data.lb_view FStar_TypeChecker_NBETerm.embedding) = - FStar_Reflection_V1_NBEEmbeddings.e_lb_view -let (uu___36 : FStar_TypeChecker_Env.env FStar_TypeChecker_NBETerm.embedding) - = FStar_Reflection_V1_NBEEmbeddings.e_env -let (uu___37 : - FStar_Reflection_V1_Data.aqualv FStar_TypeChecker_NBETerm.embedding) = - FStar_Reflection_V1_NBEEmbeddings.e_aqualv -let (uu___38 : - FStar_Syntax_Syntax.attribute Prims.list - FStar_TypeChecker_NBETerm.embedding) - = FStar_Reflection_V1_NBEEmbeddings.e_attributes -let (uu___39 : - FStar_Reflection_V1_Data.qualifier Prims.list - FStar_TypeChecker_NBETerm.embedding) - = FStar_Reflection_V1_NBEEmbeddings.e_qualifiers -let (reflection_primops : - FStar_TypeChecker_Primops_Base.primitive_step Prims.list) = - let uu___ = - mk1 "inspect_ln" uu___0 uu___1 uu___20 uu___21 - FStar_Reflection_V1_Builtins.inspect_ln in - let uu___40 = - let uu___41 = - mk1 "pack_ln" uu___1 uu___0 uu___21 uu___20 - FStar_Reflection_V1_Builtins.pack_ln in - let uu___42 = - let uu___43 = - mk1 "inspect_fv" uu___2 FStar_Syntax_Embeddings.e_string_list uu___22 - FStar_TypeChecker_NBETerm.e_string_list - FStar_Reflection_V1_Builtins.inspect_fv in - let uu___44 = - let uu___45 = - mk1 "pack_fv" FStar_Syntax_Embeddings.e_string_list uu___2 - FStar_TypeChecker_NBETerm.e_string_list uu___22 - FStar_Reflection_V1_Builtins.pack_fv in - let uu___46 = - let uu___47 = - mk1 "inspect_comp" uu___5 uu___6 uu___25 uu___26 - FStar_Reflection_V1_Builtins.inspect_comp in - let uu___48 = - let uu___49 = - mk1 "pack_comp" uu___6 uu___5 uu___26 uu___25 - FStar_Reflection_V1_Builtins.pack_comp in - let uu___50 = - let uu___51 = - mk1 "inspect_universe" uu___7 uu___8 uu___27 uu___28 - FStar_Reflection_V1_Builtins.inspect_universe in - let uu___52 = - let uu___53 = - mk1 "pack_universe" uu___8 uu___7 uu___28 uu___27 - FStar_Reflection_V1_Builtins.pack_universe in - let uu___54 = - let uu___55 = - mk1 "inspect_sigelt" uu___9 uu___10 uu___29 uu___30 - FStar_Reflection_V1_Builtins.inspect_sigelt in - let uu___56 = - let uu___57 = - mk1 "pack_sigelt" uu___10 uu___9 uu___30 uu___29 - FStar_Reflection_V1_Builtins.pack_sigelt in - let uu___58 = - let uu___59 = - mk1 "inspect_lb" uu___14 uu___15 uu___34 uu___35 - FStar_Reflection_V1_Builtins.inspect_lb in - let uu___60 = - let uu___61 = - mk1 "pack_lb" uu___15 uu___14 uu___35 uu___34 - FStar_Reflection_V1_Builtins.pack_lb in - let uu___62 = - let uu___63 = - mk1 "inspect_bv" uu___3 uu___4 uu___23 uu___24 - FStar_Reflection_V1_Builtins.inspect_bv in - let uu___64 = - let uu___65 = - mk1 "pack_bv" uu___4 uu___3 uu___24 uu___23 - FStar_Reflection_V1_Builtins.pack_bv in - let uu___66 = - let uu___67 = - mk1 "inspect_binder" uu___11 uu___12 uu___31 - uu___32 - FStar_Reflection_V1_Builtins.inspect_binder in - let uu___68 = - let uu___69 = - mk1 "pack_binder" uu___12 uu___11 uu___32 - uu___31 - FStar_Reflection_V1_Builtins.pack_binder in - let uu___70 = - let uu___71 = - mk1 "sigelt_opts" uu___9 - (FStar_Syntax_Embeddings.e_option - FStar_Syntax_Embeddings.e_vconfig) - uu___29 - (FStar_TypeChecker_NBETerm.e_option - FStar_TypeChecker_NBETerm.e_vconfig) - FStar_Reflection_V1_Builtins.sigelt_opts in - let uu___72 = - let uu___73 = - mk1 "embed_vconfig" - FStar_Syntax_Embeddings.e_vconfig - uu___0 - FStar_TypeChecker_NBETerm.e_vconfig - uu___20 - FStar_Reflection_V1_Builtins.embed_vconfig in - let uu___74 = - let uu___75 = - mk1 "sigelt_attrs" uu___9 uu___18 - uu___29 uu___38 - FStar_Reflection_V1_Builtins.sigelt_attrs in - let uu___76 = - let uu___77 = - mk2 "set_sigelt_attrs" uu___18 - uu___9 uu___9 uu___38 uu___29 - uu___29 - FStar_Reflection_V1_Builtins.set_sigelt_attrs in - let uu___78 = - let uu___79 = - mk1 "sigelt_quals" uu___9 uu___19 - uu___29 uu___39 - FStar_Reflection_V1_Builtins.sigelt_quals in - let uu___80 = - let uu___81 = - mk2 "set_sigelt_quals" uu___19 - uu___9 uu___9 uu___39 uu___29 - uu___29 - FStar_Reflection_V1_Builtins.set_sigelt_quals in - let uu___82 = - let uu___83 = - mk3 "subst" uu___3 uu___0 - uu___0 uu___0 uu___23 - uu___20 uu___20 uu___20 - FStar_Reflection_V1_Builtins.subst in - let uu___84 = - let uu___85 = - mk2 "close_term" uu___11 - uu___0 uu___0 uu___31 - uu___20 uu___20 - FStar_Reflection_V1_Builtins.close_term in - let uu___86 = - let uu___87 = - mk2 "compare_bv" uu___3 - uu___3 - FStar_Syntax_Embeddings.e_order - uu___23 uu___23 - FStar_TypeChecker_NBETerm.e_order - FStar_Reflection_V1_Builtins.compare_bv in - let uu___88 = - let uu___89 = - mk2 "lookup_attr" - uu___0 uu___16 - (FStar_Syntax_Embeddings.e_list - uu___2) uu___20 - uu___36 - (FStar_TypeChecker_NBETerm.e_list - uu___22) - FStar_Reflection_V1_Builtins.lookup_attr in - let uu___90 = - let uu___91 = - mk1 "all_defs_in_env" - uu___16 - (FStar_Syntax_Embeddings.e_list - uu___2) uu___36 - (FStar_TypeChecker_NBETerm.e_list - uu___22) - FStar_Reflection_V1_Builtins.all_defs_in_env in - let uu___92 = - let uu___93 = - mk2 - "defs_in_module" - uu___16 - FStar_Syntax_Embeddings.e_string_list - (FStar_Syntax_Embeddings.e_list - uu___2) - uu___36 - FStar_TypeChecker_NBETerm.e_string_list - (FStar_TypeChecker_NBETerm.e_list - uu___22) - FStar_Reflection_V1_Builtins.defs_in_module in - let uu___94 = - let uu___95 = - mk2 "term_eq" - uu___0 uu___0 - FStar_Syntax_Embeddings.e_bool - uu___20 uu___20 - FStar_TypeChecker_NBETerm.e_bool - FStar_Reflection_V1_Builtins.term_eq in - let uu___96 = - let uu___97 = - mk1 "moduleof" - uu___16 - FStar_Syntax_Embeddings.e_string_list - uu___36 - FStar_TypeChecker_NBETerm.e_string_list - FStar_Reflection_V1_Builtins.moduleof in - let uu___98 = - let uu___99 = - mk1 - "binders_of_env" - uu___16 - uu___13 - uu___36 - uu___33 - FStar_Reflection_V1_Builtins.binders_of_env in - let uu___100 = - let uu___101 - = - mk2 - "lookup_typ" - uu___16 - FStar_Syntax_Embeddings.e_string_list - ( - FStar_Syntax_Embeddings.e_option - uu___9) - uu___36 - FStar_TypeChecker_NBETerm.e_string_list - ( - FStar_TypeChecker_NBETerm.e_option - uu___29) - FStar_Reflection_V1_Builtins.lookup_typ in - let uu___102 - = - let uu___103 - = - mk1 - "env_open_modules" - uu___16 - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_string_list) - uu___36 - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_string_list) - FStar_Reflection_V1_Builtins.env_open_modules in - let uu___104 - = - let uu___105 - = - mk1 - "implode_qn" - FStar_Syntax_Embeddings.e_string_list - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string_list - FStar_TypeChecker_NBETerm.e_string - FStar_Reflection_V1_Builtins.implode_qn in - let uu___106 - = - let uu___107 - = - mk1 - "explode_qn" - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_string_list - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_string_list - FStar_Reflection_V1_Builtins.explode_qn in - let uu___108 - = - let uu___109 - = - mk2 - "compare_string" - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_int - FStar_Reflection_V1_Builtins.compare_string in - let uu___110 - = - let uu___111 - = - mk2 - "push_binder" - uu___16 - uu___11 - uu___16 - uu___36 - uu___31 - uu___36 - FStar_Reflection_V1_Builtins.push_binder in - let uu___112 - = - let uu___113 - = - mk1 - "range_of_term" - uu___0 - FStar_Syntax_Embeddings.e_range - uu___20 - FStar_TypeChecker_NBETerm.e_range - FStar_Reflection_V1_Builtins.range_of_term in - let uu___114 - = - let uu___115 - = - mk1 - "range_of_sigelt" - uu___9 - FStar_Syntax_Embeddings.e_range - uu___29 - FStar_TypeChecker_NBETerm.e_range - FStar_Reflection_V1_Builtins.range_of_sigelt in - [uu___115] in - uu___113 - :: - uu___114 in - uu___111 - :: - uu___112 in - uu___109 - :: - uu___110 in - uu___107 - :: - uu___108 in - uu___105 - :: - uu___106 in - uu___103 :: - uu___104 in - uu___101 :: - uu___102 in - uu___99 :: - uu___100 in - uu___97 :: - uu___98 in - uu___95 :: uu___96 in - uu___93 :: uu___94 in - uu___91 :: uu___92 in - uu___89 :: uu___90 in - uu___87 :: uu___88 in - uu___85 :: uu___86 in - uu___83 :: uu___84 in - uu___81 :: uu___82 in - uu___79 :: uu___80 in - uu___77 :: uu___78 in - uu___75 :: uu___76 in - uu___73 :: uu___74 in - uu___71 :: uu___72 in - uu___69 :: uu___70 in - uu___67 :: uu___68 in - uu___65 :: uu___66 in - uu___63 :: uu___64 in - uu___61 :: uu___62 in - uu___59 :: uu___60 in - uu___57 :: uu___58 in - uu___55 :: uu___56 in - uu___53 :: uu___54 in - uu___51 :: uu___52 in - uu___49 :: uu___50 in - uu___47 :: uu___48 in - uu___45 :: uu___46 in - uu___43 :: uu___44 in - uu___41 :: uu___42 in - uu___ :: uu___40 -let (uu___40 : unit) = - FStar_Compiler_List.iter FStar_TypeChecker_Cfg.register_extra_step - reflection_primops \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Reflection_V1_NBEEmbeddings.ml b/ocaml/fstar-lib/generated/FStar_Reflection_V1_NBEEmbeddings.ml deleted file mode 100644 index 21fdf08eee7..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Reflection_V1_NBEEmbeddings.ml +++ /dev/null @@ -1,2326 +0,0 @@ -open Prims -let (noaqs : FStar_Syntax_Syntax.antiquotations) = (Prims.int_zero, []) -let (mkFV : - FStar_Syntax_Syntax.fv -> - FStar_Syntax_Syntax.universe Prims.list -> - (FStar_TypeChecker_NBETerm.t * FStar_Syntax_Syntax.aqual) Prims.list -> - FStar_TypeChecker_NBETerm.t) - = - fun fv -> - fun us -> - fun ts -> - FStar_TypeChecker_NBETerm.mkFV fv (FStar_Compiler_List.rev us) - (FStar_Compiler_List.rev ts) -let (mkConstruct : - FStar_Syntax_Syntax.fv -> - FStar_Syntax_Syntax.universe Prims.list -> - (FStar_TypeChecker_NBETerm.t * FStar_Syntax_Syntax.aqual) Prims.list -> - FStar_TypeChecker_NBETerm.t) - = - fun fv -> - fun us -> - fun ts -> - FStar_TypeChecker_NBETerm.mkConstruct fv (FStar_Compiler_List.rev us) - (FStar_Compiler_List.rev ts) -let (fv_as_emb_typ : FStar_Syntax_Syntax.fv -> FStar_Syntax_Syntax.emb_typ) = - fun fv -> - let uu___ = - let uu___1 = - FStar_Ident.string_of_lid - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - (uu___1, []) in - FStar_Syntax_Syntax.ET_app uu___ -let mk_emb' : - 'uuuuu . - (FStar_TypeChecker_NBETerm.nbe_cbs -> - 'uuuuu -> FStar_TypeChecker_NBETerm.t) - -> - (FStar_TypeChecker_NBETerm.nbe_cbs -> - FStar_TypeChecker_NBETerm.t -> 'uuuuu FStar_Pervasives_Native.option) - -> - FStar_Syntax_Syntax.fv -> 'uuuuu FStar_TypeChecker_NBETerm.embedding - = - fun x -> - fun y -> - fun fv -> - FStar_TypeChecker_NBETerm.mk_emb x y (fun uu___ -> mkFV fv [] []) - (fun uu___ -> fv_as_emb_typ fv) -let mk_lazy : - 'uuuuu . - FStar_TypeChecker_NBETerm.nbe_cbs -> - 'uuuuu -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.lazy_kind -> FStar_TypeChecker_NBETerm.t - = - fun cb -> - fun obj -> - fun ty -> - fun kind -> - let li = - { - FStar_Syntax_Syntax.blob = (FStar_Dyn.mkdyn obj); - FStar_Syntax_Syntax.lkind = kind; - FStar_Syntax_Syntax.ltyp = ty; - FStar_Syntax_Syntax.rng = FStar_Compiler_Range_Type.dummyRange - } in - let thunk = - FStar_Thunk.mk - (fun uu___ -> - let uu___1 = FStar_Syntax_Util.unfold_lazy li in - FStar_TypeChecker_NBETerm.translate_cb cb uu___1) in - FStar_TypeChecker_NBETerm.mk_t - (FStar_TypeChecker_NBETerm.Lazy - ((FStar_Pervasives.Inl li), thunk)) -let (e_bv : FStar_Syntax_Syntax.bv FStar_TypeChecker_NBETerm.embedding) = - let embed_bv cb bv = - mk_lazy cb bv FStar_Reflection_V1_Constants.fstar_refl_bv - FStar_Syntax_Syntax.Lazy_bv in - let unembed_bv cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Lazy - (FStar_Pervasives.Inl - { FStar_Syntax_Syntax.blob = b; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_bv; - FStar_Syntax_Syntax.ltyp = uu___; - FStar_Syntax_Syntax.rng = uu___1;_}, - uu___2) - -> - let uu___3 = FStar_Dyn.undyn b in FStar_Pervasives_Native.Some uu___3 - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded bv: %s" uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_bv unembed_bv FStar_Reflection_V1_Constants.fstar_refl_bv_fv -let (e_binder : - FStar_Syntax_Syntax.binder FStar_TypeChecker_NBETerm.embedding) = - let embed_binder cb b = - mk_lazy cb b FStar_Reflection_V1_Constants.fstar_refl_binder - FStar_Syntax_Syntax.Lazy_binder in - let unembed_binder cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Lazy - (FStar_Pervasives.Inl - { FStar_Syntax_Syntax.blob = b; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_binder; - FStar_Syntax_Syntax.ltyp = uu___; - FStar_Syntax_Syntax.rng = uu___1;_}, - uu___2) - -> - let uu___3 = FStar_Dyn.undyn b in FStar_Pervasives_Native.Some uu___3 - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded binder: %s" uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_binder unembed_binder - FStar_Reflection_V1_Constants.fstar_refl_binder_fv -let rec mapM_opt : - 'a 'b . - ('a -> 'b FStar_Pervasives_Native.option) -> - 'a Prims.list -> 'b Prims.list FStar_Pervasives_Native.option - = - fun f -> - fun l -> - match l with - | [] -> FStar_Pervasives_Native.Some [] - | x::xs -> - let uu___ = f x in - FStar_Compiler_Util.bind_opt uu___ - (fun x1 -> - let uu___1 = mapM_opt f xs in - FStar_Compiler_Util.bind_opt uu___1 - (fun xs1 -> FStar_Pervasives_Native.Some (x1 :: xs1))) -let (e_term_aq : - (Prims.int * FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - Prims.list) -> - FStar_Syntax_Syntax.term FStar_TypeChecker_NBETerm.embedding) - = - fun aq -> - let embed_term cb t = - let qi = - { - FStar_Syntax_Syntax.qkind = FStar_Syntax_Syntax.Quote_static; - FStar_Syntax_Syntax.antiquotations = aq - } in - FStar_TypeChecker_NBETerm.mk_t - (FStar_TypeChecker_NBETerm.Quote (t, qi)) in - let unembed_term cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Quote (tm, qi) -> - let uu___ = - FStar_Reflection_V1_Embeddings.e_term_aq (Prims.int_zero, []) in - let uu___1 = - FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_quoted (tm, qi)) - FStar_Compiler_Range_Type.dummyRange in - FStar_Syntax_Embeddings_Base.unembed uu___ uu___1 - FStar_Syntax_Embeddings_Base.id_norm_cb - | uu___ -> FStar_Pervasives_Native.None in - { - FStar_TypeChecker_NBETerm.em = embed_term; - FStar_TypeChecker_NBETerm.un = unembed_term; - FStar_TypeChecker_NBETerm.typ = - (fun uu___ -> - mkFV FStar_Reflection_V1_Constants.fstar_refl_term_fv [] []); - FStar_TypeChecker_NBETerm.e_typ = - (fun uu___ -> - fv_as_emb_typ FStar_Reflection_V1_Constants.fstar_refl_term_fv) - } -let (e_term : FStar_Syntax_Syntax.term FStar_TypeChecker_NBETerm.embedding) = - e_term_aq (Prims.int_zero, []) -let (e_sort : - FStar_Syntax_Syntax.term FStar_Compiler_Sealed.sealed - FStar_TypeChecker_NBETerm.embedding) - = FStar_TypeChecker_NBETerm.e_sealed e_term -let (e_ppname : - Prims.string FStar_Compiler_Sealed.sealed - FStar_TypeChecker_NBETerm.embedding) - = FStar_TypeChecker_NBETerm.e_sealed FStar_TypeChecker_NBETerm.e_string -let (e_aqualv : - FStar_Reflection_V1_Data.aqualv FStar_TypeChecker_NBETerm.embedding) = - let embed_aqualv cb q = - match q with - | FStar_Reflection_V1_Data.Q_Explicit -> - mkConstruct - FStar_Reflection_V1_Constants.ref_Q_Explicit.FStar_Reflection_V1_Constants.fv - [] [] - | FStar_Reflection_V1_Data.Q_Implicit -> - mkConstruct - FStar_Reflection_V1_Constants.ref_Q_Implicit.FStar_Reflection_V1_Constants.fv - [] [] - | FStar_Reflection_V1_Data.Q_Meta t -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_term cb t in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V1_Constants.ref_Q_Meta.FStar_Reflection_V1_Constants.fv - [] uu___ in - let unembed_aqualv cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Q_Explicit.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.Q_Explicit - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Q_Implicit.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.Q_Implicit - | FStar_TypeChecker_NBETerm.Construct (fv, [], (t1, uu___)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Q_Meta.FStar_Reflection_V1_Constants.lid - -> - let uu___1 = FStar_TypeChecker_NBETerm.unembed e_term cb t1 in - FStar_Compiler_Util.bind_opt uu___1 - (fun t2 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Q_Meta t2)) - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded aqualv: %s" uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - FStar_TypeChecker_NBETerm.mk_emb embed_aqualv unembed_aqualv - (fun uu___ -> - mkConstruct FStar_Reflection_V1_Constants.fstar_refl_aqualv_fv [] []) - (fun uu___ -> - fv_as_emb_typ FStar_Reflection_V1_Constants.fstar_refl_aqualv_fv) -let (e_binders : - FStar_Syntax_Syntax.binders FStar_TypeChecker_NBETerm.embedding) = - FStar_TypeChecker_NBETerm.e_list e_binder -let (e_fv : FStar_Syntax_Syntax.fv FStar_TypeChecker_NBETerm.embedding) = - let embed_fv cb fv = - mk_lazy cb fv FStar_Reflection_V1_Constants.fstar_refl_fv - FStar_Syntax_Syntax.Lazy_fvar in - let unembed_fv cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Lazy - (FStar_Pervasives.Inl - { FStar_Syntax_Syntax.blob = b; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_fvar; - FStar_Syntax_Syntax.ltyp = uu___; - FStar_Syntax_Syntax.rng = uu___1;_}, - uu___2) - -> - let uu___3 = FStar_Dyn.undyn b in FStar_Pervasives_Native.Some uu___3 - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded fvar: %s" uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_fv unembed_fv FStar_Reflection_V1_Constants.fstar_refl_fv_fv -let (e_comp : FStar_Syntax_Syntax.comp FStar_TypeChecker_NBETerm.embedding) = - let embed_comp cb c = - mk_lazy cb c FStar_Reflection_V1_Constants.fstar_refl_comp - FStar_Syntax_Syntax.Lazy_comp in - let unembed_comp cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Lazy - (FStar_Pervasives.Inl - { FStar_Syntax_Syntax.blob = b; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_comp; - FStar_Syntax_Syntax.ltyp = uu___; - FStar_Syntax_Syntax.rng = uu___1;_}, - uu___2) - -> - let uu___3 = FStar_Dyn.undyn b in FStar_Pervasives_Native.Some uu___3 - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded comp: %s" uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_comp unembed_comp - FStar_Reflection_V1_Constants.fstar_refl_comp_fv -let (e_env : FStar_TypeChecker_Env.env FStar_TypeChecker_NBETerm.embedding) = - let embed_env cb e = - mk_lazy cb e FStar_Reflection_V1_Constants.fstar_refl_env - FStar_Syntax_Syntax.Lazy_env in - let unembed_env cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Lazy - (FStar_Pervasives.Inl - { FStar_Syntax_Syntax.blob = b; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_env; - FStar_Syntax_Syntax.ltyp = uu___; - FStar_Syntax_Syntax.rng = uu___1;_}, - uu___2) - -> - let uu___3 = FStar_Dyn.undyn b in FStar_Pervasives_Native.Some uu___3 - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded env: %s" uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_env unembed_env - FStar_Reflection_V1_Constants.fstar_refl_env_fv -let (e_const : - FStar_Reflection_V1_Data.vconst FStar_TypeChecker_NBETerm.embedding) = - let embed_const cb c = - match c with - | FStar_Reflection_V1_Data.C_Unit -> - mkConstruct - FStar_Reflection_V1_Constants.ref_C_Unit.FStar_Reflection_V1_Constants.fv - [] [] - | FStar_Reflection_V1_Data.C_True -> - mkConstruct - FStar_Reflection_V1_Constants.ref_C_True.FStar_Reflection_V1_Constants.fv - [] [] - | FStar_Reflection_V1_Data.C_False -> - mkConstruct - FStar_Reflection_V1_Constants.ref_C_False.FStar_Reflection_V1_Constants.fv - [] [] - | FStar_Reflection_V1_Data.C_Int i -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.mk_t - (FStar_TypeChecker_NBETerm.Constant - (FStar_TypeChecker_NBETerm.Int i)) in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V1_Constants.ref_C_Int.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.C_String s -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed - FStar_TypeChecker_NBETerm.e_string cb s in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V1_Constants.ref_C_String.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.C_Range r -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed - FStar_TypeChecker_NBETerm.e_range cb r in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V1_Constants.ref_C_Range.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.C_Reify -> - mkConstruct - FStar_Reflection_V1_Constants.ref_C_Reify.FStar_Reflection_V1_Constants.fv - [] [] - | FStar_Reflection_V1_Data.C_Reflect ns -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed - FStar_TypeChecker_NBETerm.e_string_list cb ns in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V1_Constants.ref_C_Reflect.FStar_Reflection_V1_Constants.fv - [] uu___ in - let unembed_const cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_C_Unit.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.C_Unit - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_C_True.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.C_True - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_C_False.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.C_False - | FStar_TypeChecker_NBETerm.Construct (fv, [], (i, uu___)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_C_Int.FStar_Reflection_V1_Constants.lid - -> - let uu___1 = - FStar_TypeChecker_NBETerm.unembed FStar_TypeChecker_NBETerm.e_int - cb i in - FStar_Compiler_Util.bind_opt uu___1 - (fun i1 -> - FStar_Pervasives_Native.Some (FStar_Reflection_V1_Data.C_Int i1)) - | FStar_TypeChecker_NBETerm.Construct (fv, [], (s, uu___)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_C_String.FStar_Reflection_V1_Constants.lid - -> - let uu___1 = - FStar_TypeChecker_NBETerm.unembed - FStar_TypeChecker_NBETerm.e_string cb s in - FStar_Compiler_Util.bind_opt uu___1 - (fun s1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.C_String s1)) - | FStar_TypeChecker_NBETerm.Construct (fv, [], (r, uu___)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_C_Range.FStar_Reflection_V1_Constants.lid - -> - let uu___1 = - FStar_TypeChecker_NBETerm.unembed FStar_TypeChecker_NBETerm.e_range - cb r in - FStar_Compiler_Util.bind_opt uu___1 - (fun r1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.C_Range r1)) - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_C_Reify.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.C_Reify - | FStar_TypeChecker_NBETerm.Construct (fv, [], (ns, uu___)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_C_Reflect.FStar_Reflection_V1_Constants.lid - -> - let uu___1 = - FStar_TypeChecker_NBETerm.unembed - FStar_TypeChecker_NBETerm.e_string_list cb ns in - FStar_Compiler_Util.bind_opt uu___1 - (fun ns1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.C_Reflect ns1)) - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded vconst: %s" uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_const unembed_const - FStar_Reflection_V1_Constants.fstar_refl_vconst_fv -let (e_universe : - FStar_Syntax_Syntax.universe FStar_TypeChecker_NBETerm.embedding) = - let embed_universe cb u = - mk_lazy cb u FStar_Reflection_V1_Constants.fstar_refl_universe - FStar_Syntax_Syntax.Lazy_universe in - let unembed_universe cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Lazy - (FStar_Pervasives.Inl - { FStar_Syntax_Syntax.blob = b; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_universe; - FStar_Syntax_Syntax.ltyp = uu___; - FStar_Syntax_Syntax.rng = uu___1;_}, - uu___2) - -> - let uu___3 = FStar_Dyn.undyn b in FStar_Pervasives_Native.Some uu___3 - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded universe: %s" uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_universe unembed_universe - FStar_Reflection_V1_Constants.fstar_refl_universe_fv -let rec e_pattern_aq : - 'uuuuu . - 'uuuuu -> - FStar_Reflection_V1_Data.pattern FStar_TypeChecker_NBETerm.embedding - = - fun aq -> - let embed_pattern cb p = - match p with - | FStar_Reflection_V1_Data.Pat_Constant c -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_const cb c in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V1_Constants.ref_Pat_Constant.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.Pat_Cons (fv, us_opt, ps) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_fv cb fv in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_option - (FStar_TypeChecker_NBETerm.e_list e_universe)) cb - us_opt in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = e_pattern_aq aq in - FStar_TypeChecker_NBETerm.e_tuple2 uu___9 - FStar_TypeChecker_NBETerm.e_bool in - FStar_TypeChecker_NBETerm.e_list uu___8 in - FStar_TypeChecker_NBETerm.embed uu___7 cb ps in - FStar_TypeChecker_NBETerm.as_arg uu___6 in - [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V1_Constants.ref_Pat_Cons.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.Pat_Var (bv, sort) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_bv cb bv in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = FStar_TypeChecker_NBETerm.embed e_sort cb sort in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V1_Constants.ref_Pat_Var.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.Pat_Dot_Term eopt -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_option e_term) cb eopt in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V1_Constants.ref_Pat_Dot_Term.FStar_Reflection_V1_Constants.fv - [] uu___ in - let unembed_pattern cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Construct (fv, [], (c, uu___)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Pat_Constant.FStar_Reflection_V1_Constants.lid - -> - let uu___1 = FStar_TypeChecker_NBETerm.unembed e_const cb c in - FStar_Compiler_Util.bind_opt uu___1 - (fun c1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Pat_Constant c1)) - | FStar_TypeChecker_NBETerm.Construct - (fv, [], (ps, uu___)::(us_opt, uu___1)::(f, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Pat_Cons.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = FStar_TypeChecker_NBETerm.unembed e_fv cb f in - FStar_Compiler_Util.bind_opt uu___3 - (fun f1 -> - let uu___4 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_option - (FStar_TypeChecker_NBETerm.e_list e_universe)) cb - us_opt in - FStar_Compiler_Util.bind_opt uu___4 - (fun us -> - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = e_pattern_aq aq in - FStar_TypeChecker_NBETerm.e_tuple2 uu___8 - FStar_TypeChecker_NBETerm.e_bool in - FStar_TypeChecker_NBETerm.e_list uu___7 in - FStar_TypeChecker_NBETerm.unembed uu___6 cb ps in - FStar_Compiler_Util.bind_opt uu___5 - (fun ps1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Pat_Cons (f1, us, ps1))))) - | FStar_TypeChecker_NBETerm.Construct - (fv, [], (sort, uu___)::(bv, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Pat_Var.FStar_Reflection_V1_Constants.lid - -> - let uu___2 = FStar_TypeChecker_NBETerm.unembed e_bv cb bv in - FStar_Compiler_Util.bind_opt uu___2 - (fun bv1 -> - let uu___3 = FStar_TypeChecker_NBETerm.unembed e_sort cb sort in - FStar_Compiler_Util.bind_opt uu___3 - (fun sort1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Pat_Var (bv1, sort1)))) - | FStar_TypeChecker_NBETerm.Construct (fv, [], (eopt, uu___)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Pat_Dot_Term.FStar_Reflection_V1_Constants.lid - -> - let uu___1 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_option e_term) cb eopt in - FStar_Compiler_Util.bind_opt uu___1 - (fun eopt1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Pat_Dot_Term eopt1)) - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded pattern: %s" - uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_pattern unembed_pattern - FStar_Reflection_V1_Constants.fstar_refl_pattern_fv -let (e_pattern : - FStar_Reflection_V1_Data.pattern FStar_TypeChecker_NBETerm.embedding) = - e_pattern_aq noaqs -let (e_branch : - FStar_Reflection_V1_Data.branch FStar_TypeChecker_NBETerm.embedding) = - FStar_TypeChecker_NBETerm.e_tuple2 e_pattern e_term -let (e_argv : - FStar_Reflection_V1_Data.argv FStar_TypeChecker_NBETerm.embedding) = - FStar_TypeChecker_NBETerm.e_tuple2 e_term e_aqualv -let (e_branch_aq : - (Prims.int * FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - Prims.list) -> - (FStar_Reflection_V1_Data.pattern * FStar_Syntax_Syntax.term) - FStar_TypeChecker_NBETerm.embedding) - = - fun aq -> - let uu___ = e_pattern_aq aq in - FStar_TypeChecker_NBETerm.e_tuple2 uu___ (e_term_aq aq) -let (e_argv_aq : - (Prims.int * FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - Prims.list) -> - (FStar_Syntax_Syntax.term * FStar_Reflection_V1_Data.aqualv) - FStar_TypeChecker_NBETerm.embedding) - = fun aq -> FStar_TypeChecker_NBETerm.e_tuple2 (e_term_aq aq) e_aqualv -let (e_match_returns_annotation : - (FStar_Syntax_Syntax.binder * ((FStar_Syntax_Syntax.term, - FStar_Syntax_Syntax.comp) FStar_Pervasives.either * - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option * Prims.bool)) - FStar_Pervasives_Native.option FStar_TypeChecker_NBETerm.embedding) - = - FStar_TypeChecker_NBETerm.e_option - (FStar_TypeChecker_NBETerm.e_tuple2 e_binder - (FStar_TypeChecker_NBETerm.e_tuple3 - (FStar_TypeChecker_NBETerm.e_either e_term e_comp) - (FStar_TypeChecker_NBETerm.e_option e_term) - FStar_TypeChecker_NBETerm.e_bool)) -let unlazy_as_t : - 'uuuuu . - FStar_Syntax_Syntax.lazy_kind -> FStar_TypeChecker_NBETerm.t -> 'uuuuu - = - fun k -> - fun t -> - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Lazy - (FStar_Pervasives.Inl - { FStar_Syntax_Syntax.blob = v; FStar_Syntax_Syntax.lkind = k'; - FStar_Syntax_Syntax.ltyp = uu___; - FStar_Syntax_Syntax.rng = uu___1;_}, - uu___2) - when - FStar_Class_Deq.op_Equals_Question - FStar_Syntax_Syntax.deq_lazy_kind k k' - -> FStar_Dyn.undyn v - | uu___ -> failwith "Not a Lazy of the expected kind (NBE)" -let (e_ident : - FStar_Reflection_V1_Data.ident FStar_TypeChecker_NBETerm.embedding) = - FStar_TypeChecker_NBETerm.e_tuple2 FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_range -let (e_universe_view : - FStar_Reflection_V1_Data.universe_view FStar_TypeChecker_NBETerm.embedding) - = - let embed_universe_view cb uv = - match uv with - | FStar_Reflection_V1_Data.Uv_Zero -> - mkConstruct - FStar_Reflection_V1_Constants.ref_Uv_Zero.FStar_Reflection_V1_Constants.fv - [] [] - | FStar_Reflection_V1_Data.Uv_Succ u -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_universe cb u in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V1_Constants.ref_Uv_Succ.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.Uv_Max us -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_list e_universe) cb us in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V1_Constants.ref_Uv_Max.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.Uv_BVar n -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed FStar_TypeChecker_NBETerm.e_int - cb n in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V1_Constants.ref_Uv_BVar.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.Uv_Name i -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_tuple2 - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_range) cb i in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V1_Constants.ref_Uv_Name.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.Uv_Unif u -> - let uu___ = - let uu___1 = - let uu___2 = - mk_lazy cb u FStar_Syntax_Util.t_universe_uvar - FStar_Syntax_Syntax.Lazy_universe_uvar in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V1_Constants.ref_Uv_Unif.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.Uv_Unk -> - mkConstruct - FStar_Reflection_V1_Constants.ref_Uv_Unk.FStar_Reflection_V1_Constants.fv - [] [] in - let unembed_universe_view cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Uv_Zero.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.Uv_Zero - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, (u, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Uv_Succ.FStar_Reflection_V1_Constants.lid - -> - let uu___2 = FStar_TypeChecker_NBETerm.unembed e_universe cb u in - FStar_Compiler_Util.bind_opt uu___2 - (fun u1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Uv_Succ u1)) - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, (us, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Uv_Max.FStar_Reflection_V1_Constants.lid - -> - let uu___2 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_list e_universe) cb us in - FStar_Compiler_Util.bind_opt uu___2 - (fun us1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Uv_Max us1)) - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, (n, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Uv_BVar.FStar_Reflection_V1_Constants.lid - -> - let uu___2 = - FStar_TypeChecker_NBETerm.unembed FStar_TypeChecker_NBETerm.e_int - cb n in - FStar_Compiler_Util.bind_opt uu___2 - (fun n1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Uv_BVar n1)) - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, (i, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Uv_Name.FStar_Reflection_V1_Constants.lid - -> - let uu___2 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_tuple2 - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_range) cb i in - FStar_Compiler_Util.bind_opt uu___2 - (fun i1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Uv_Name i1)) - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, (u, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Uv_Unif.FStar_Reflection_V1_Constants.lid - -> - let u1 = unlazy_as_t FStar_Syntax_Syntax.Lazy_universe_uvar u in - FStar_Pervasives_Native.Some (FStar_Reflection_V1_Data.Uv_Unif u1) - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Uv_Unk.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.Uv_Unk - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded universe view: %s" - uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_universe_view unembed_universe_view - FStar_Reflection_V1_Constants.fstar_refl_universe_view_fv -let (e_term_view_aq : - (Prims.int * FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - Prims.list) -> - FStar_Reflection_V1_Data.term_view FStar_TypeChecker_NBETerm.embedding) - = - fun aq -> - let shift uu___ = - match uu___ with | (s, aqs) -> ((s + Prims.int_one), aqs) in - let embed_term_view cb tv = - match tv with - | FStar_Reflection_V1_Data.Tv_FVar fv -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_fv cb fv in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V1_Constants.ref_Tv_FVar.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.Tv_BVar bv -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_bv cb bv in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V1_Constants.ref_Tv_BVar.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.Tv_Var bv -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_bv cb bv in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V1_Constants.ref_Tv_Var.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.Tv_UInst (fv, us) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_fv cb fv in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_list e_universe) cb us in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V1_Constants.ref_Tv_UInst.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.Tv_App (hd, a) -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed (e_term_aq aq) cb hd in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed (e_argv_aq aq) cb a in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V1_Constants.ref_Tv_App.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.Tv_Abs (b, t) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_binder cb b in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed (e_term_aq (shift aq)) cb t in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V1_Constants.ref_Tv_Abs.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.Tv_Arrow (b, c) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_binder cb b in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = FStar_TypeChecker_NBETerm.embed e_comp cb c in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V1_Constants.ref_Tv_Arrow.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.Tv_Type u -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_universe cb u in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V1_Constants.ref_Tv_Type.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.Tv_Refine (bv, sort, t) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_bv cb bv in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed (e_term_aq aq) cb sort in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - FStar_TypeChecker_NBETerm.embed (e_term_aq (shift aq)) cb - t in - FStar_TypeChecker_NBETerm.as_arg uu___6 in - [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V1_Constants.ref_Tv_Refine.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.Tv_Const c -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_const cb c in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V1_Constants.ref_Tv_Const.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.Tv_Uvar (u, d) -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed - FStar_TypeChecker_NBETerm.e_int cb u in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - mk_lazy cb (u, d) FStar_Syntax_Util.t_ctx_uvar_and_sust - FStar_Syntax_Syntax.Lazy_uvar in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V1_Constants.ref_Tv_Uvar.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.Tv_Let (r, attrs, b, ty, t1, t2) -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed - FStar_TypeChecker_NBETerm.e_bool cb r in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_list e_term) cb attrs in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = FStar_TypeChecker_NBETerm.embed e_bv cb b in - FStar_TypeChecker_NBETerm.as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - FStar_TypeChecker_NBETerm.embed (e_term_aq aq) cb ty in - FStar_TypeChecker_NBETerm.as_arg uu___8 in - let uu___8 = - let uu___9 = - let uu___10 = - FStar_TypeChecker_NBETerm.embed (e_term_aq aq) cb t1 in - FStar_TypeChecker_NBETerm.as_arg uu___10 in - let uu___10 = - let uu___11 = - let uu___12 = - FStar_TypeChecker_NBETerm.embed - (e_term_aq (shift aq)) cb t2 in - FStar_TypeChecker_NBETerm.as_arg uu___12 in - [uu___11] in - uu___9 :: uu___10 in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V1_Constants.ref_Tv_Let.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.Tv_Match (t, ret_opt, brs) -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed (e_term_aq aq) cb t in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed e_match_returns_annotation - cb ret_opt in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = e_branch_aq aq in - FStar_TypeChecker_NBETerm.e_list uu___8 in - FStar_TypeChecker_NBETerm.embed uu___7 cb brs in - FStar_TypeChecker_NBETerm.as_arg uu___6 in - [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V1_Constants.ref_Tv_Match.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.Tv_AscribedT (e, t, tacopt, use_eq) -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed (e_term_aq aq) cb e in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed (e_term_aq aq) cb t in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_option (e_term_aq aq)) cb - tacopt in - FStar_TypeChecker_NBETerm.as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - FStar_TypeChecker_NBETerm.embed - FStar_TypeChecker_NBETerm.e_bool cb use_eq in - FStar_TypeChecker_NBETerm.as_arg uu___8 in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V1_Constants.ref_Tv_AscT.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.Tv_AscribedC (e, c, tacopt, use_eq) -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed (e_term_aq aq) cb e in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = FStar_TypeChecker_NBETerm.embed e_comp cb c in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_option (e_term_aq aq)) cb - tacopt in - FStar_TypeChecker_NBETerm.as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - FStar_TypeChecker_NBETerm.embed - FStar_TypeChecker_NBETerm.e_bool cb use_eq in - FStar_TypeChecker_NBETerm.as_arg uu___8 in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V1_Constants.ref_Tv_AscT.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.Tv_Unknown -> - mkConstruct - FStar_Reflection_V1_Constants.ref_Tv_Unknown.FStar_Reflection_V1_Constants.fv - [] [] - | FStar_Reflection_V1_Data.Tv_Unsupp -> - mkConstruct - FStar_Reflection_V1_Constants.ref_Tv_Unsupp.FStar_Reflection_V1_Constants.fv - [] [] in - let unembed_term_view cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, (b, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_Var.FStar_Reflection_V1_Constants.lid - -> - let uu___2 = FStar_TypeChecker_NBETerm.unembed e_bv cb b in - FStar_Compiler_Util.bind_opt uu___2 - (fun b1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Tv_Var b1)) - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, (b, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_BVar.FStar_Reflection_V1_Constants.lid - -> - let uu___2 = FStar_TypeChecker_NBETerm.unembed e_bv cb b in - FStar_Compiler_Util.bind_opt uu___2 - (fun b1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Tv_BVar b1)) - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, (f, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_FVar.FStar_Reflection_V1_Constants.lid - -> - let uu___2 = FStar_TypeChecker_NBETerm.unembed e_fv cb f in - FStar_Compiler_Util.bind_opt uu___2 - (fun f1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Tv_FVar f1)) - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, (f, uu___1)::(us, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_UInst.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = FStar_TypeChecker_NBETerm.unembed e_fv cb f in - FStar_Compiler_Util.bind_opt uu___3 - (fun f1 -> - let uu___4 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_list e_universe) cb us in - FStar_Compiler_Util.bind_opt uu___4 - (fun us1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Tv_UInst (f1, us1)))) - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, (r, uu___1)::(l, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_App.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = FStar_TypeChecker_NBETerm.unembed e_term cb l in - FStar_Compiler_Util.bind_opt uu___3 - (fun l1 -> - let uu___4 = FStar_TypeChecker_NBETerm.unembed e_argv cb r in - FStar_Compiler_Util.bind_opt uu___4 - (fun r1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Tv_App (l1, r1)))) - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, (t1, uu___1)::(b, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_Abs.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = FStar_TypeChecker_NBETerm.unembed e_binder cb b in - FStar_Compiler_Util.bind_opt uu___3 - (fun b1 -> - let uu___4 = FStar_TypeChecker_NBETerm.unembed e_term cb t1 in - FStar_Compiler_Util.bind_opt uu___4 - (fun t2 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Tv_Abs (b1, t2)))) - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, (t1, uu___1)::(b, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_Arrow.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = FStar_TypeChecker_NBETerm.unembed e_binder cb b in - FStar_Compiler_Util.bind_opt uu___3 - (fun b1 -> - let uu___4 = FStar_TypeChecker_NBETerm.unembed e_comp cb t1 in - FStar_Compiler_Util.bind_opt uu___4 - (fun c -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Tv_Arrow (b1, c)))) - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, (u, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_Type.FStar_Reflection_V1_Constants.lid - -> - let uu___2 = FStar_TypeChecker_NBETerm.unembed e_universe cb u in - FStar_Compiler_Util.bind_opt uu___2 - (fun u1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Tv_Type u1)) - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, (t1, uu___1)::(sort, uu___2)::(b, uu___3)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_Refine.FStar_Reflection_V1_Constants.lid - -> - let uu___4 = FStar_TypeChecker_NBETerm.unembed e_bv cb b in - FStar_Compiler_Util.bind_opt uu___4 - (fun b1 -> - let uu___5 = FStar_TypeChecker_NBETerm.unembed e_term cb sort in - FStar_Compiler_Util.bind_opt uu___5 - (fun sort1 -> - let uu___6 = - FStar_TypeChecker_NBETerm.unembed e_term cb t1 in - FStar_Compiler_Util.bind_opt uu___6 - (fun t2 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Tv_Refine - (b1, sort1, t2))))) - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, (c, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_Const.FStar_Reflection_V1_Constants.lid - -> - let uu___2 = FStar_TypeChecker_NBETerm.unembed e_const cb c in - FStar_Compiler_Util.bind_opt uu___2 - (fun c1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Tv_Const c1)) - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, (l, uu___1)::(u, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_Uvar.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = - FStar_TypeChecker_NBETerm.unembed FStar_TypeChecker_NBETerm.e_int - cb u in - FStar_Compiler_Util.bind_opt uu___3 - (fun u1 -> - let ctx_u_s = unlazy_as_t FStar_Syntax_Syntax.Lazy_uvar l in - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Tv_Uvar (u1, ctx_u_s))) - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, - (t2, uu___1)::(t1, uu___2)::(ty, uu___3)::(b, uu___4)::(attrs, - uu___5):: - (r, uu___6)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_Let.FStar_Reflection_V1_Constants.lid - -> - let uu___7 = - FStar_TypeChecker_NBETerm.unembed - FStar_TypeChecker_NBETerm.e_bool cb r in - FStar_Compiler_Util.bind_opt uu___7 - (fun r1 -> - let uu___8 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_list e_term) cb attrs in - FStar_Compiler_Util.bind_opt uu___8 - (fun attrs1 -> - let uu___9 = FStar_TypeChecker_NBETerm.unembed e_bv cb b in - FStar_Compiler_Util.bind_opt uu___9 - (fun b1 -> - let uu___10 = - FStar_TypeChecker_NBETerm.unembed e_term cb ty in - FStar_Compiler_Util.bind_opt uu___10 - (fun ty1 -> - let uu___11 = - FStar_TypeChecker_NBETerm.unembed e_term cb - t1 in - FStar_Compiler_Util.bind_opt uu___11 - (fun t11 -> - let uu___12 = - FStar_TypeChecker_NBETerm.unembed e_term - cb t2 in - FStar_Compiler_Util.bind_opt uu___12 - (fun t21 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Tv_Let - (r1, attrs1, b1, ty1, t11, t21)))))))) - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, (brs, uu___1)::(ret_opt, uu___2)::(t1, uu___3)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_Match.FStar_Reflection_V1_Constants.lid - -> - let uu___4 = FStar_TypeChecker_NBETerm.unembed e_term cb t1 in - FStar_Compiler_Util.bind_opt uu___4 - (fun t2 -> - let uu___5 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_list e_branch) cb brs in - FStar_Compiler_Util.bind_opt uu___5 - (fun brs1 -> - let uu___6 = - FStar_TypeChecker_NBETerm.unembed - e_match_returns_annotation cb ret_opt in - FStar_Compiler_Util.bind_opt uu___6 - (fun ret_opt1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Tv_Match - (t2, ret_opt1, brs1))))) - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, - (tacopt, uu___1)::(t1, uu___2)::(e, uu___3)::(use_eq, uu___4)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_AscT.FStar_Reflection_V1_Constants.lid - -> - let uu___5 = FStar_TypeChecker_NBETerm.unembed e_term cb e in - FStar_Compiler_Util.bind_opt uu___5 - (fun e1 -> - let uu___6 = FStar_TypeChecker_NBETerm.unembed e_term cb t1 in - FStar_Compiler_Util.bind_opt uu___6 - (fun t2 -> - let uu___7 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_option e_term) cb tacopt in - FStar_Compiler_Util.bind_opt uu___7 - (fun tacopt1 -> - let uu___8 = - FStar_TypeChecker_NBETerm.unembed - FStar_TypeChecker_NBETerm.e_bool cb use_eq in - FStar_Compiler_Util.bind_opt uu___8 - (fun use_eq1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Tv_AscribedT - (e1, t2, tacopt1, use_eq1)))))) - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, - (tacopt, uu___1)::(c, uu___2)::(e, uu___3)::(use_eq, uu___4)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_AscC.FStar_Reflection_V1_Constants.lid - -> - let uu___5 = FStar_TypeChecker_NBETerm.unembed e_term cb e in - FStar_Compiler_Util.bind_opt uu___5 - (fun e1 -> - let uu___6 = FStar_TypeChecker_NBETerm.unembed e_comp cb c in - FStar_Compiler_Util.bind_opt uu___6 - (fun c1 -> - let uu___7 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_option e_term) cb tacopt in - FStar_Compiler_Util.bind_opt uu___7 - (fun tacopt1 -> - let uu___8 = - FStar_TypeChecker_NBETerm.unembed - FStar_TypeChecker_NBETerm.e_bool cb use_eq in - FStar_Compiler_Util.bind_opt uu___8 - (fun use_eq1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Tv_AscribedC - (e1, c1, tacopt1, use_eq1)))))) - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_Unknown.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.Tv_Unknown - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Tv_Unsupp.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.Tv_Unsupp - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded term_view: %s" - uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_term_view unembed_term_view - FStar_Reflection_V1_Constants.fstar_refl_term_view_fv -let (e_term_view : - FStar_Reflection_V1_Data.term_view FStar_TypeChecker_NBETerm.embedding) = - e_term_view_aq (Prims.int_zero, []) -let (e_bv_view : - FStar_Reflection_V1_Data.bv_view FStar_TypeChecker_NBETerm.embedding) = - let embed_bv_view cb bvv = - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_sealed - FStar_TypeChecker_NBETerm.e_string) cb - bvv.FStar_Reflection_V1_Data.bv_ppname in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed FStar_TypeChecker_NBETerm.e_int - cb bvv.FStar_Reflection_V1_Data.bv_index in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V1_Constants.ref_Mk_bv.FStar_Reflection_V1_Constants.fv - [] uu___ in - let unembed_bv_view cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, (idx, uu___1)::(nm, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Mk_bv.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_sealed - FStar_TypeChecker_NBETerm.e_string) cb nm in - FStar_Compiler_Util.bind_opt uu___3 - (fun nm1 -> - let uu___4 = - FStar_TypeChecker_NBETerm.unembed - FStar_TypeChecker_NBETerm.e_int cb idx in - FStar_Compiler_Util.bind_opt uu___4 - (fun idx1 -> - FStar_Pervasives_Native.Some - { - FStar_Reflection_V1_Data.bv_ppname = nm1; - FStar_Reflection_V1_Data.bv_index = idx1 - })) - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded bv_view: %s" uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_bv_view unembed_bv_view - FStar_Reflection_V1_Constants.fstar_refl_bv_view_fv -let (e_attribute : - FStar_Syntax_Syntax.attribute FStar_TypeChecker_NBETerm.embedding) = e_term -let (e_attributes : - FStar_Syntax_Syntax.attribute Prims.list - FStar_TypeChecker_NBETerm.embedding) - = FStar_TypeChecker_NBETerm.e_list e_attribute -let (e_binder_view : - FStar_Reflection_V1_Data.binder_view FStar_TypeChecker_NBETerm.embedding) = - let embed_binder_view cb bview = - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed e_bv cb - bview.FStar_Reflection_V1_Data.binder_bv in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed e_aqualv cb - bview.FStar_Reflection_V1_Data.binder_qual in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - FStar_TypeChecker_NBETerm.embed e_attributes cb - bview.FStar_Reflection_V1_Data.binder_attrs in - FStar_TypeChecker_NBETerm.as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - FStar_TypeChecker_NBETerm.embed e_term cb - bview.FStar_Reflection_V1_Data.binder_sort in - FStar_TypeChecker_NBETerm.as_arg uu___8 in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V1_Constants.ref_Mk_binder.FStar_Reflection_V1_Constants.fv - [] uu___ in - let unembed_binder_view cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, - (sort, uu___1)::(attrs, uu___2)::(q, uu___3)::(bv, uu___4)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Mk_binder.FStar_Reflection_V1_Constants.lid - -> - let uu___5 = FStar_TypeChecker_NBETerm.unembed e_bv cb bv in - FStar_Compiler_Util.bind_opt uu___5 - (fun bv1 -> - let uu___6 = FStar_TypeChecker_NBETerm.unembed e_aqualv cb q in - FStar_Compiler_Util.bind_opt uu___6 - (fun q1 -> - let uu___7 = - FStar_TypeChecker_NBETerm.unembed e_attributes cb attrs in - FStar_Compiler_Util.bind_opt uu___7 - (fun attrs1 -> - let uu___8 = - FStar_TypeChecker_NBETerm.unembed e_term cb sort in - FStar_Compiler_Util.bind_opt uu___8 - (fun sort1 -> - FStar_Pervasives_Native.Some - { - FStar_Reflection_V1_Data.binder_bv = bv1; - FStar_Reflection_V1_Data.binder_qual = q1; - FStar_Reflection_V1_Data.binder_attrs = - attrs1; - FStar_Reflection_V1_Data.binder_sort = sort1 - })))) - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded binder_view: %s" - uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_binder_view unembed_binder_view - FStar_Reflection_V1_Constants.fstar_refl_binder_view_fv -let (e_comp_view : - FStar_Reflection_V1_Data.comp_view FStar_TypeChecker_NBETerm.embedding) = - let embed_comp_view cb cv = - match cv with - | FStar_Reflection_V1_Data.C_Total t -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_term cb t in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V1_Constants.ref_C_Total.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.C_GTotal t -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_term cb t in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V1_Constants.ref_C_GTotal.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.C_Lemma (pre, post, pats) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_term cb pre in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = FStar_TypeChecker_NBETerm.embed e_term cb post in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = FStar_TypeChecker_NBETerm.embed e_term cb pats in - FStar_TypeChecker_NBETerm.as_arg uu___6 in - [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V1_Constants.ref_C_Lemma.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.C_Eff (us, eff, res, args, decrs) -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_list e_universe) cb us in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed - FStar_TypeChecker_NBETerm.e_string_list cb eff in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = FStar_TypeChecker_NBETerm.embed e_term cb res in - FStar_TypeChecker_NBETerm.as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_list e_argv) cb args in - FStar_TypeChecker_NBETerm.as_arg uu___8 in - let uu___8 = - let uu___9 = - let uu___10 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_list e_term) cb decrs in - FStar_TypeChecker_NBETerm.as_arg uu___10 in - [uu___9] in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V1_Constants.ref_C_Eff.FStar_Reflection_V1_Constants.fv - [] uu___ in - let unembed_comp_view cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, (t1, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_C_Total.FStar_Reflection_V1_Constants.lid - -> - let uu___2 = FStar_TypeChecker_NBETerm.unembed e_term cb t1 in - FStar_Compiler_Util.bind_opt uu___2 - (fun t2 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.C_Total t2)) - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, (t1, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_C_GTotal.FStar_Reflection_V1_Constants.lid - -> - let uu___2 = FStar_TypeChecker_NBETerm.unembed e_term cb t1 in - FStar_Compiler_Util.bind_opt uu___2 - (fun t2 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.C_GTotal t2)) - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, (post, uu___1)::(pre, uu___2)::(pats, uu___3)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_C_Lemma.FStar_Reflection_V1_Constants.lid - -> - let uu___4 = FStar_TypeChecker_NBETerm.unembed e_term cb pre in - FStar_Compiler_Util.bind_opt uu___4 - (fun pre1 -> - let uu___5 = FStar_TypeChecker_NBETerm.unembed e_term cb post in - FStar_Compiler_Util.bind_opt uu___5 - (fun post1 -> - let uu___6 = - FStar_TypeChecker_NBETerm.unembed e_term cb pats in - FStar_Compiler_Util.bind_opt uu___6 - (fun pats1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.C_Lemma - (pre1, post1, pats1))))) - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, - (decrs, uu___1)::(args, uu___2)::(res, uu___3)::(eff, uu___4):: - (us, uu___5)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_C_Eff.FStar_Reflection_V1_Constants.lid - -> - let uu___6 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_list e_universe) cb us in - FStar_Compiler_Util.bind_opt uu___6 - (fun us1 -> - let uu___7 = - FStar_TypeChecker_NBETerm.unembed - FStar_TypeChecker_NBETerm.e_string_list cb eff in - FStar_Compiler_Util.bind_opt uu___7 - (fun eff1 -> - let uu___8 = - FStar_TypeChecker_NBETerm.unembed e_term cb res in - FStar_Compiler_Util.bind_opt uu___8 - (fun res1 -> - let uu___9 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_list e_argv) cb args in - FStar_Compiler_Util.bind_opt uu___9 - (fun args1 -> - let uu___10 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_list e_term) cb - decrs in - FStar_Compiler_Util.bind_opt uu___10 - (fun decrs1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.C_Eff - (us1, eff1, res1, args1, decrs1))))))) - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded comp_view: %s" - uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_comp_view unembed_comp_view - FStar_Reflection_V1_Constants.fstar_refl_comp_view_fv -let (e_sigelt : - FStar_Syntax_Syntax.sigelt FStar_TypeChecker_NBETerm.embedding) = - let embed_sigelt cb se = - mk_lazy cb se FStar_Reflection_V1_Constants.fstar_refl_sigelt - FStar_Syntax_Syntax.Lazy_sigelt in - let unembed_sigelt cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Lazy - (FStar_Pervasives.Inl - { FStar_Syntax_Syntax.blob = b; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_sigelt; - FStar_Syntax_Syntax.ltyp = uu___; - FStar_Syntax_Syntax.rng = uu___1;_}, - uu___2) - -> - let uu___3 = FStar_Dyn.undyn b in FStar_Pervasives_Native.Some uu___3 - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded sigelt: %s" uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_sigelt unembed_sigelt - FStar_Reflection_V1_Constants.fstar_refl_sigelt_fv -let (e_univ_name : - FStar_Reflection_V1_Data.univ_name FStar_TypeChecker_NBETerm.embedding) = - e_ident -let (e_univ_names : - FStar_Reflection_V1_Data.univ_name Prims.list - FStar_TypeChecker_NBETerm.embedding) - = FStar_TypeChecker_NBETerm.e_list e_univ_name -let (e_string_list : - Prims.string Prims.list FStar_TypeChecker_NBETerm.embedding) = - FStar_TypeChecker_NBETerm.e_list FStar_TypeChecker_NBETerm.e_string -let (e_ctor : - (Prims.string Prims.list * FStar_Syntax_Syntax.term) - FStar_TypeChecker_NBETerm.embedding) - = FStar_TypeChecker_NBETerm.e_tuple2 e_string_list e_term -let (e_lb_view : - FStar_Reflection_V1_Data.lb_view FStar_TypeChecker_NBETerm.embedding) = - let embed_lb_view cb lbv = - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed e_fv cb - lbv.FStar_Reflection_V1_Data.lb_fv in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed e_univ_names cb - lbv.FStar_Reflection_V1_Data.lb_us in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - FStar_TypeChecker_NBETerm.embed e_term cb - lbv.FStar_Reflection_V1_Data.lb_typ in - FStar_TypeChecker_NBETerm.as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - FStar_TypeChecker_NBETerm.embed e_term cb - lbv.FStar_Reflection_V1_Data.lb_def in - FStar_TypeChecker_NBETerm.as_arg uu___8 in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V1_Constants.ref_Mk_lb.FStar_Reflection_V1_Constants.fv - [] uu___ in - let unembed_lb_view cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, - (fv', uu___1)::(us, uu___2)::(typ, uu___3)::(def, uu___4)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Mk_lb.FStar_Reflection_V1_Constants.lid - -> - let uu___5 = FStar_TypeChecker_NBETerm.unembed e_fv cb fv' in - FStar_Compiler_Util.bind_opt uu___5 - (fun fv'1 -> - let uu___6 = - FStar_TypeChecker_NBETerm.unembed e_univ_names cb us in - FStar_Compiler_Util.bind_opt uu___6 - (fun us1 -> - let uu___7 = - FStar_TypeChecker_NBETerm.unembed e_term cb typ in - FStar_Compiler_Util.bind_opt uu___7 - (fun typ1 -> - let uu___8 = - FStar_TypeChecker_NBETerm.unembed e_term cb def in - FStar_Compiler_Util.bind_opt uu___8 - (fun def1 -> - FStar_Pervasives_Native.Some - { - FStar_Reflection_V1_Data.lb_fv = fv'1; - FStar_Reflection_V1_Data.lb_us = us1; - FStar_Reflection_V1_Data.lb_typ = typ1; - FStar_Reflection_V1_Data.lb_def = def1 - })))) - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded lb_view: %s" uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_lb_view unembed_lb_view - FStar_Reflection_V1_Constants.fstar_refl_lb_view_fv -let (e_lid : FStar_Ident.lid FStar_TypeChecker_NBETerm.embedding) = - let embed rng lid = - let uu___ = FStar_Ident.path_of_lid lid in - FStar_TypeChecker_NBETerm.embed e_string_list rng uu___ in - let unembed cb t = - let uu___ = FStar_TypeChecker_NBETerm.unembed e_string_list cb t in - FStar_Compiler_Util.map_opt uu___ - (fun p -> - FStar_Ident.lid_of_path p FStar_Compiler_Range_Type.dummyRange) in - FStar_TypeChecker_NBETerm.mk_emb embed unembed - (fun uu___ -> - mkConstruct FStar_Reflection_V1_Constants.fstar_refl_aqualv_fv [] []) - (fun uu___ -> - fv_as_emb_typ FStar_Reflection_V1_Constants.fstar_refl_aqualv_fv) -let (e_letbinding : - FStar_Syntax_Syntax.letbinding FStar_TypeChecker_NBETerm.embedding) = - let embed_letbinding cb lb = - mk_lazy cb lb FStar_Reflection_V1_Constants.fstar_refl_letbinding - FStar_Syntax_Syntax.Lazy_letbinding in - let unembed_letbinding cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Lazy - (FStar_Pervasives.Inl - { FStar_Syntax_Syntax.blob = lb; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_letbinding; - FStar_Syntax_Syntax.ltyp = uu___; - FStar_Syntax_Syntax.rng = uu___1;_}, - uu___2) - -> - let uu___3 = FStar_Dyn.undyn lb in - FStar_Pervasives_Native.Some uu___3 - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded letbinding: %s" - uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_letbinding unembed_letbinding - FStar_Reflection_V1_Constants.fstar_refl_letbinding_fv -let (e_sigelt_view : - FStar_Reflection_V1_Data.sigelt_view FStar_TypeChecker_NBETerm.embedding) = - let embed_sigelt_view cb sev = - match sev with - | FStar_Reflection_V1_Data.Sg_Let (r, lbs) -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed - FStar_TypeChecker_NBETerm.e_bool cb r in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_list e_letbinding) cb lbs in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V1_Constants.ref_Sg_Let.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.Sg_Inductive (nm, univs, bs, t, dcs) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_string_list cb nm in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed e_univ_names cb univs in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = FStar_TypeChecker_NBETerm.embed e_binders cb bs in - FStar_TypeChecker_NBETerm.as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = FStar_TypeChecker_NBETerm.embed e_term cb t in - FStar_TypeChecker_NBETerm.as_arg uu___8 in - let uu___8 = - let uu___9 = - let uu___10 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_list e_ctor) cb dcs in - FStar_TypeChecker_NBETerm.as_arg uu___10 in - [uu___9] in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V1_Constants.ref_Sg_Inductive.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.Sg_Val (nm, univs, t) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_string_list cb nm in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed e_univ_names cb univs in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = FStar_TypeChecker_NBETerm.embed e_term cb t in - FStar_TypeChecker_NBETerm.as_arg uu___6 in - [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V1_Constants.ref_Sg_Val.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.Unk -> - mkConstruct - FStar_Reflection_V1_Constants.ref_Unk.FStar_Reflection_V1_Constants.fv - [] [] in - let unembed_sigelt_view cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, - (dcs, uu___1)::(t1, uu___2)::(bs, uu___3)::(us, uu___4)::(nm, - uu___5)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Sg_Inductive.FStar_Reflection_V1_Constants.lid - -> - let uu___6 = FStar_TypeChecker_NBETerm.unembed e_string_list cb nm in - FStar_Compiler_Util.bind_opt uu___6 - (fun nm1 -> - let uu___7 = - FStar_TypeChecker_NBETerm.unembed e_univ_names cb us in - FStar_Compiler_Util.bind_opt uu___7 - (fun us1 -> - let uu___8 = - FStar_TypeChecker_NBETerm.unembed e_binders cb bs in - FStar_Compiler_Util.bind_opt uu___8 - (fun bs1 -> - let uu___9 = - FStar_TypeChecker_NBETerm.unembed e_term cb t1 in - FStar_Compiler_Util.bind_opt uu___9 - (fun t2 -> - let uu___10 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_list e_ctor) cb - dcs in - FStar_Compiler_Util.bind_opt uu___10 - (fun dcs1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Sg_Inductive - (nm1, us1, bs1, t2, dcs1))))))) - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, (lbs, uu___1)::(r, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Sg_Let.FStar_Reflection_V1_Constants.lid - -> - let uu___3 = - FStar_TypeChecker_NBETerm.unembed FStar_TypeChecker_NBETerm.e_bool - cb r in - FStar_Compiler_Util.bind_opt uu___3 - (fun r1 -> - let uu___4 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_list e_letbinding) cb lbs in - FStar_Compiler_Util.bind_opt uu___4 - (fun lbs1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Sg_Let (r1, lbs1)))) - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, (t1, uu___1)::(us, uu___2)::(nm, uu___3)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Sg_Val.FStar_Reflection_V1_Constants.lid - -> - let uu___4 = FStar_TypeChecker_NBETerm.unembed e_string_list cb nm in - FStar_Compiler_Util.bind_opt uu___4 - (fun nm1 -> - let uu___5 = - FStar_TypeChecker_NBETerm.unembed e_univ_names cb us in - FStar_Compiler_Util.bind_opt uu___5 - (fun us1 -> - let uu___6 = FStar_TypeChecker_NBETerm.unembed e_term cb t1 in - FStar_Compiler_Util.bind_opt uu___6 - (fun t2 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Sg_Val (nm1, us1, t2))))) - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_Unk.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.Unk - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded sigelt_view: %s" - uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_sigelt_view unembed_sigelt_view - FStar_Reflection_V1_Constants.fstar_refl_sigelt_view_fv -let (e_name : Prims.string Prims.list FStar_TypeChecker_NBETerm.embedding) = - FStar_TypeChecker_NBETerm.e_list FStar_TypeChecker_NBETerm.e_string -let (e_qualifier : - FStar_Reflection_V1_Data.qualifier FStar_TypeChecker_NBETerm.embedding) = - let embed cb q = - match q with - | FStar_Reflection_V1_Data.Assumption -> - mkConstruct - FStar_Reflection_V1_Constants.ref_qual_Assumption.FStar_Reflection_V1_Constants.fv - [] [] - | FStar_Reflection_V1_Data.New -> - mkConstruct - FStar_Reflection_V1_Constants.ref_qual_New.FStar_Reflection_V1_Constants.fv - [] [] - | FStar_Reflection_V1_Data.Private -> - mkConstruct - FStar_Reflection_V1_Constants.ref_qual_Private.FStar_Reflection_V1_Constants.fv - [] [] - | FStar_Reflection_V1_Data.Unfold_for_unification_and_vcgen -> - mkConstruct - FStar_Reflection_V1_Constants.ref_qual_Unfold_for_unification_and_vcgen.FStar_Reflection_V1_Constants.fv - [] [] - | FStar_Reflection_V1_Data.Visible_default -> - mkConstruct - FStar_Reflection_V1_Constants.ref_qual_Visible_default.FStar_Reflection_V1_Constants.fv - [] [] - | FStar_Reflection_V1_Data.Irreducible -> - mkConstruct - FStar_Reflection_V1_Constants.ref_qual_Irreducible.FStar_Reflection_V1_Constants.fv - [] [] - | FStar_Reflection_V1_Data.Inline_for_extraction -> - mkConstruct - FStar_Reflection_V1_Constants.ref_qual_Inline_for_extraction.FStar_Reflection_V1_Constants.fv - [] [] - | FStar_Reflection_V1_Data.NoExtract -> - mkConstruct - FStar_Reflection_V1_Constants.ref_qual_NoExtract.FStar_Reflection_V1_Constants.fv - [] [] - | FStar_Reflection_V1_Data.Noeq -> - mkConstruct - FStar_Reflection_V1_Constants.ref_qual_Noeq.FStar_Reflection_V1_Constants.fv - [] [] - | FStar_Reflection_V1_Data.Unopteq -> - mkConstruct - FStar_Reflection_V1_Constants.ref_qual_Unopteq.FStar_Reflection_V1_Constants.fv - [] [] - | FStar_Reflection_V1_Data.TotalEffect -> - mkConstruct - FStar_Reflection_V1_Constants.ref_qual_TotalEffect.FStar_Reflection_V1_Constants.fv - [] [] - | FStar_Reflection_V1_Data.Logic -> - mkConstruct - FStar_Reflection_V1_Constants.ref_qual_Logic.FStar_Reflection_V1_Constants.fv - [] [] - | FStar_Reflection_V1_Data.Reifiable -> - mkConstruct - FStar_Reflection_V1_Constants.ref_qual_Reifiable.FStar_Reflection_V1_Constants.fv - [] [] - | FStar_Reflection_V1_Data.ExceptionConstructor -> - mkConstruct - FStar_Reflection_V1_Constants.ref_qual_ExceptionConstructor.FStar_Reflection_V1_Constants.fv - [] [] - | FStar_Reflection_V1_Data.HasMaskedEffect -> - mkConstruct - FStar_Reflection_V1_Constants.ref_qual_HasMaskedEffect.FStar_Reflection_V1_Constants.fv - [] [] - | FStar_Reflection_V1_Data.Effect -> - mkConstruct - FStar_Reflection_V1_Constants.ref_qual_Effect.FStar_Reflection_V1_Constants.fv - [] [] - | FStar_Reflection_V1_Data.OnlyName -> - mkConstruct - FStar_Reflection_V1_Constants.ref_qual_OnlyName.FStar_Reflection_V1_Constants.fv - [] [] - | FStar_Reflection_V1_Data.Reflectable l -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_name cb l in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V1_Constants.ref_qual_Reflectable.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.Discriminator l -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_name cb l in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V1_Constants.ref_qual_Discriminator.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.Action l -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_name cb l in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V1_Constants.ref_qual_Action.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.Projector (l, i) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_name cb l in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = FStar_TypeChecker_NBETerm.embed e_ident cb i in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V1_Constants.ref_qual_Projector.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.RecordType (ids1, ids2) -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_list e_ident) cb ids1 in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_list e_ident) cb ids2 in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V1_Constants.ref_qual_RecordType.FStar_Reflection_V1_Constants.fv - [] uu___ - | FStar_Reflection_V1_Data.RecordConstructor (ids1, ids2) -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_list e_ident) cb ids1 in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_list e_ident) cb ids2 in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V1_Constants.ref_qual_RecordConstructor.FStar_Reflection_V1_Constants.fv - [] uu___ in - let unembed cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_Assumption.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.Assumption - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_New.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.New - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_Private.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.Private - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_Unfold_for_unification_and_vcgen.FStar_Reflection_V1_Constants.lid - -> - FStar_Pervasives_Native.Some - FStar_Reflection_V1_Data.Unfold_for_unification_and_vcgen - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_Visible_default.FStar_Reflection_V1_Constants.lid - -> - FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.Visible_default - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_Irreducible.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.Irreducible - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_Inline_for_extraction.FStar_Reflection_V1_Constants.lid - -> - FStar_Pervasives_Native.Some - FStar_Reflection_V1_Data.Inline_for_extraction - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_NoExtract.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.NoExtract - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_Noeq.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.Noeq - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_Unopteq.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.Unopteq - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_TotalEffect.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.TotalEffect - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_Logic.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.Logic - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_Reifiable.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.Reifiable - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_ExceptionConstructor.FStar_Reflection_V1_Constants.lid - -> - FStar_Pervasives_Native.Some - FStar_Reflection_V1_Data.ExceptionConstructor - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_HasMaskedEffect.FStar_Reflection_V1_Constants.lid - -> - FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.HasMaskedEffect - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_Effect.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.Effect - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_OnlyName.FStar_Reflection_V1_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V1_Data.OnlyName - | FStar_TypeChecker_NBETerm.Construct (fv, [], (l, uu___)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_Reflectable.FStar_Reflection_V1_Constants.lid - -> - let uu___1 = FStar_TypeChecker_NBETerm.unembed e_name cb l in - FStar_Compiler_Util.bind_opt uu___1 - (fun l1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Reflectable l1)) - | FStar_TypeChecker_NBETerm.Construct (fv, [], (l, uu___)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_Discriminator.FStar_Reflection_V1_Constants.lid - -> - let uu___1 = FStar_TypeChecker_NBETerm.unembed e_name cb l in - FStar_Compiler_Util.bind_opt uu___1 - (fun l1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Discriminator l1)) - | FStar_TypeChecker_NBETerm.Construct (fv, [], (l, uu___)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_Action.FStar_Reflection_V1_Constants.lid - -> - let uu___1 = FStar_TypeChecker_NBETerm.unembed e_name cb l in - FStar_Compiler_Util.bind_opt uu___1 - (fun l1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Action l1)) - | FStar_TypeChecker_NBETerm.Construct - (fv, [], (i, uu___)::(l, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_Projector.FStar_Reflection_V1_Constants.lid - -> - let uu___2 = FStar_TypeChecker_NBETerm.unembed e_ident cb i in - FStar_Compiler_Util.bind_opt uu___2 - (fun i1 -> - let uu___3 = FStar_TypeChecker_NBETerm.unembed e_name cb l in - FStar_Compiler_Util.bind_opt uu___3 - (fun l1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.Projector (l1, i1)))) - | FStar_TypeChecker_NBETerm.Construct - (fv, [], (ids2, uu___)::(ids1, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_RecordType.FStar_Reflection_V1_Constants.lid - -> - let uu___2 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_list e_ident) cb ids1 in - FStar_Compiler_Util.bind_opt uu___2 - (fun ids11 -> - let uu___3 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_list e_ident) cb ids2 in - FStar_Compiler_Util.bind_opt uu___3 - (fun ids21 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.RecordType (ids11, ids21)))) - | FStar_TypeChecker_NBETerm.Construct - (fv, [], (ids2, uu___)::(ids1, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V1_Constants.ref_qual_RecordConstructor.FStar_Reflection_V1_Constants.lid - -> - let uu___2 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_list e_ident) cb ids1 in - FStar_Compiler_Util.bind_opt uu___2 - (fun ids11 -> - let uu___3 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_list e_ident) cb ids2 in - FStar_Compiler_Util.bind_opt uu___3 - (fun ids21 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V1_Data.RecordConstructor - (ids11, ids21)))) - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded qualifier: %s" - uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - FStar_TypeChecker_NBETerm.mk_emb embed unembed - (fun uu___ -> - mkConstruct FStar_Reflection_V1_Constants.fstar_refl_qualifier_fv [] - []) - (fun uu___ -> - fv_as_emb_typ FStar_Reflection_V1_Constants.fstar_refl_qualifier_fv) -let (e_qualifiers : - FStar_Reflection_V1_Data.qualifier Prims.list - FStar_TypeChecker_NBETerm.embedding) - = FStar_TypeChecker_NBETerm.e_list e_qualifier -let (e_vconfig : FStar_Order.order FStar_TypeChecker_NBETerm.embedding) = - let emb cb o = failwith "emb vconfig NBE" in - let unemb cb t = failwith "unemb vconfig NBE" in - let uu___ = - FStar_Syntax_Syntax.lid_as_fv FStar_Parser_Const.vconfig_lid - FStar_Pervasives_Native.None in - mk_emb' emb unemb uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Reflection_V2_Arith.ml b/ocaml/fstar-lib/generated/FStar_Reflection_V2_Arith.ml index 34d73b20eaf..0290be4ca44 100644 --- a/ocaml/fstar-lib/generated/FStar_Reflection_V2_Arith.ml +++ b/ocaml/fstar-lib/generated/FStar_Reflection_V2_Arith.ml @@ -1,7 +1,7 @@ open Prims type expr = | Lit of Prims.int - | Atom of Prims.nat * FStar_Reflection_Types.term + | Atom of Prims.nat * FStarC_Reflection_Types.term | Plus of expr * expr | Mult of expr * expr | Minus of expr * expr @@ -26,7 +26,7 @@ let (uu___is_Atom : expr -> Prims.bool) = match projectee with | Atom (_0, _1) -> true | uu___ -> false let (__proj__Atom__item___0 : expr -> Prims.nat) = fun projectee -> match projectee with | Atom (_0, _1) -> _0 -let (__proj__Atom__item___1 : expr -> FStar_Reflection_Types.term) = +let (__proj__Atom__item___1 : expr -> FStarC_Reflection_Types.term) = fun projectee -> match projectee with | Atom (_0, _1) -> _1 let (uu___is_Plus : expr -> Prims.bool) = fun projectee -> @@ -180,7 +180,7 @@ let (ne : expr -> expr -> prop) = fun e1 -> fun e2 -> CompProp (e1, C_Ne, e2) let (gt : expr -> expr -> prop) = fun e1 -> fun e2 -> CompProp (e1, C_Gt, e2) let (ge : expr -> expr -> prop) = fun e1 -> fun e2 -> CompProp ((Plus ((Lit Prims.int_one), e1)), C_Gt, e2) -type st = (Prims.nat * FStar_Reflection_Types.term Prims.list) +type st = (Prims.nat * FStarC_Reflection_Types.term Prims.list) type 'a tm = st -> ((Prims.string, ('a * st)) FStar_Pervasives.either, unit) @@ -354,13 +354,13 @@ let rec find_idx : ((i + Prims.int_one), x1)))))) uu___1)))) uu___1 uu___ -let (atom : FStar_Reflection_Types.term -> expr tm) = +let (atom : FStarC_Reflection_Types.term -> expr tm) = fun t -> fun uu___ -> match uu___ with | (n, atoms) -> let uu___1 = - find_idx (FStar_Tactics_V2_Builtins.term_eq_old t) atoms in + find_idx (FStarC_Tactics_V2_Builtins.term_eq_old t) atoms in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -392,17 +392,17 @@ let fail : 'a . Prims.string -> 'a tm = Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> FStar_Pervasives.Inl s))) uu___ -let rec (as_arith_expr : FStar_Reflection_Types.term -> expr tm) = +let rec (as_arith_expr : FStarC_Reflection_Types.term -> expr tm) = fun t -> let uu___ = FStar_Reflection_V2_Collect.collect_app_ln t in match uu___ with | (hd, tl) -> - (match ((FStar_Reflection_V2_Builtins.inspect_ln hd), tl) with - | (FStar_Reflection_V2_Data.Tv_FVar fv, - (e1, FStar_Reflection_V2_Data.Q_Implicit)::(e2, - FStar_Reflection_V2_Data.Q_Explicit):: - (e3, FStar_Reflection_V2_Data.Q_Explicit)::[]) -> - let qn = FStar_Reflection_V2_Builtins.inspect_fv fv in + (match ((FStarC_Reflection_V2_Builtins.inspect_ln hd), tl) with + | (FStarC_Reflection_V2_Data.Tv_FVar fv, + (e1, FStarC_Reflection_V2_Data.Q_Implicit)::(e2, + FStarC_Reflection_V2_Data.Q_Explicit):: + (e3, FStarC_Reflection_V2_Data.Q_Explicit)::[]) -> + let qn = FStarC_Reflection_V2_Builtins.inspect_fv fv in let e2' = as_arith_expr e2 in let e3' = as_arith_expr e3 in if qn = FStar_Reflection_Const.land_qn @@ -465,11 +465,11 @@ let rec (as_arith_expr : FStar_Reflection_Types.term -> expr tm) = fun uu___11 -> Lsub (uu___10, uu___11)) e2' e3' else atom t - | (FStar_Reflection_V2_Data.Tv_FVar fv, - (l, FStar_Reflection_V2_Data.Q_Explicit)::(r, - FStar_Reflection_V2_Data.Q_Explicit)::[]) + | (FStarC_Reflection_V2_Data.Tv_FVar fv, + (l, FStarC_Reflection_V2_Data.Q_Explicit)::(r, + FStarC_Reflection_V2_Data.Q_Explicit)::[]) -> - let qn = FStar_Reflection_V2_Builtins.inspect_fv fv in + let qn = FStarC_Reflection_V2_Builtins.inspect_fv fv in let ll = as_arith_expr l in let rr = as_arith_expr r in if qn = FStar_Reflection_Const.add_qn @@ -493,27 +493,27 @@ let rec (as_arith_expr : FStar_Reflection_Types.term -> expr tm) = (fun uu___4 -> fun uu___5 -> Mult (uu___4, uu___5)) ll rr else atom t - | (FStar_Reflection_V2_Data.Tv_FVar fv, - (l, FStar_Reflection_V2_Data.Q_Implicit)::(r, - FStar_Reflection_V2_Data.Q_Explicit)::[]) + | (FStarC_Reflection_V2_Data.Tv_FVar fv, + (l, FStarC_Reflection_V2_Data.Q_Implicit)::(r, + FStarC_Reflection_V2_Data.Q_Explicit)::[]) -> - let qn = FStar_Reflection_V2_Builtins.inspect_fv fv in + let qn = FStarC_Reflection_V2_Builtins.inspect_fv fv in let ll = as_arith_expr l in let rr = as_arith_expr r in if qn = FStar_Reflection_Const.nat_bv_qn then liftM (fun uu___1 -> NatToBv uu___1) rr else atom t - | (FStar_Reflection_V2_Data.Tv_FVar fv, - (a, FStar_Reflection_V2_Data.Q_Explicit)::[]) -> - let qn = FStar_Reflection_V2_Builtins.inspect_fv fv in + | (FStarC_Reflection_V2_Data.Tv_FVar fv, + (a, FStarC_Reflection_V2_Data.Q_Explicit)::[]) -> + let qn = FStarC_Reflection_V2_Builtins.inspect_fv fv in let aa = as_arith_expr a in if qn = FStar_Reflection_Const.neg_qn then liftM (fun uu___1 -> Neg uu___1) aa else atom t - | (FStar_Reflection_V2_Data.Tv_Const (FStar_Reflection_V2_Data.C_Int - i), uu___1) -> return (Lit i) + | (FStarC_Reflection_V2_Data.Tv_Const + (FStarC_Reflection_V2_Data.C_Int i), uu___1) -> return (Lit i) | uu___1 -> atom t) -let (is_arith_expr : FStar_Reflection_Types.term -> expr tm) = +let (is_arith_expr : FStarC_Reflection_Types.term -> expr tm) = fun t -> op_let_Bang (as_arith_expr t) (fun a -> @@ -523,23 +523,24 @@ let (is_arith_expr : FStar_Reflection_Types.term -> expr tm) = FStar_Reflection_V2_Derived_Lemmas.collect_app_ref t1 in (match uu___1 with | (hd, tl) -> - (match ((FStar_Reflection_V2_Builtins.inspect_ln hd), tl) + (match ((FStarC_Reflection_V2_Builtins.inspect_ln hd), tl) with - | (FStar_Reflection_V2_Data.Tv_FVar uu___2, []) -> + | (FStarC_Reflection_V2_Data.Tv_FVar uu___2, []) -> return a - | (FStar_Reflection_V2_Data.Tv_BVar uu___2, []) -> + | (FStarC_Reflection_V2_Data.Tv_BVar uu___2, []) -> + return a + | (FStarC_Reflection_V2_Data.Tv_Var uu___2, []) -> return a - | (FStar_Reflection_V2_Data.Tv_Var uu___2, []) -> return a | uu___2 -> op_let_Bang - (lift FStar_Tactics_V2_Builtins.term_to_string t1) + (lift FStarC_Tactics_V2_Builtins.term_to_string t1) (fun s -> fail (Prims.strcat "not an arithmetic expression: (" (Prims.strcat s ")"))))) | uu___ -> return a) let rec (is_arith_prop : - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.term -> st -> ((Prims.string, (prop * st)) FStar_Pervasives.either, unit) FStar_Tactics_Effect.tac_repr) @@ -569,7 +570,7 @@ let rec (is_arith_prop : liftM2 (fun uu___ -> fun uu___1 -> OrProp (uu___, uu___1)) (is_arith_prop l) (is_arith_prop r) | uu___ -> - op_let_Bang (lift FStar_Tactics_V2_Builtins.term_to_string t) + op_let_Bang (lift FStarC_Tactics_V2_Builtins.term_to_string t) (fun s -> fail (Prims.strcat "connector (" (Prims.strcat s ")")))) i diff --git a/ocaml/fstar-lib/generated/FStar_Reflection_V2_Builtins.ml b/ocaml/fstar-lib/generated/FStar_Reflection_V2_Builtins.ml deleted file mode 100644 index d4606d8937e..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Reflection_V2_Builtins.ml +++ /dev/null @@ -1,1468 +0,0 @@ -open Prims -let (get_env : unit -> FStar_TypeChecker_Env.env) = - fun uu___ -> - let uu___1 = - FStar_Compiler_Effect.op_Bang - FStar_TypeChecker_Normalize.reflection_env_hook in - match uu___1 with - | FStar_Pervasives_Native.None -> - failwith "impossible: env_hook unset in reflection" - | FStar_Pervasives_Native.Some e -> e -let (inspect_bqual : - FStar_Syntax_Syntax.bqual -> FStar_Reflection_V2_Data.aqualv) = - fun bq -> - match bq with - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit uu___) -> - FStar_Reflection_V2_Data.Q_Implicit - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta t) -> - FStar_Reflection_V2_Data.Q_Meta t - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Equality) -> - FStar_Reflection_V2_Data.Q_Equality - | FStar_Pervasives_Native.None -> FStar_Reflection_V2_Data.Q_Explicit -let (inspect_aqual : - FStar_Syntax_Syntax.aqual -> FStar_Reflection_V2_Data.aqualv) = - fun aq -> - match aq with - | FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = uu___;_} - -> FStar_Reflection_V2_Data.Q_Implicit - | uu___ -> FStar_Reflection_V2_Data.Q_Explicit -let (pack_bqual : - FStar_Reflection_V2_Data.aqualv -> FStar_Syntax_Syntax.bqual) = - fun aqv -> - match aqv with - | FStar_Reflection_V2_Data.Q_Implicit -> - FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit false) - | FStar_Reflection_V2_Data.Q_Meta t -> - FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta t) - | FStar_Reflection_V2_Data.Q_Equality -> - FStar_Pervasives_Native.Some FStar_Syntax_Syntax.Equality - | FStar_Reflection_V2_Data.Q_Explicit -> FStar_Pervasives_Native.None -let (pack_aqual : - FStar_Reflection_V2_Data.aqualv -> FStar_Syntax_Syntax.aqual) = - fun aqv -> - match aqv with - | FStar_Reflection_V2_Data.Q_Implicit -> - FStar_Syntax_Syntax.as_aqual_implicit true - | uu___ -> FStar_Pervasives_Native.None -let (inspect_fv : FStar_Syntax_Syntax.fv -> Prims.string Prims.list) = - fun fv -> - let uu___ = FStar_Syntax_Syntax.lid_of_fv fv in - FStar_Ident.path_of_lid uu___ -let (pack_fv : Prims.string Prims.list -> FStar_Syntax_Syntax.fv) = - fun ns -> - let lid = FStar_Parser_Const.p2l ns in - let fallback uu___ = - let quals = - let uu___1 = FStar_Ident.lid_equals lid FStar_Parser_Const.cons_lid in - if uu___1 - then FStar_Pervasives_Native.Some FStar_Syntax_Syntax.Data_ctor - else - (let uu___3 = FStar_Ident.lid_equals lid FStar_Parser_Const.nil_lid in - if uu___3 - then FStar_Pervasives_Native.Some FStar_Syntax_Syntax.Data_ctor - else - (let uu___5 = - FStar_Ident.lid_equals lid FStar_Parser_Const.some_lid in - if uu___5 - then FStar_Pervasives_Native.Some FStar_Syntax_Syntax.Data_ctor - else - (let uu___7 = - FStar_Ident.lid_equals lid FStar_Parser_Const.none_lid in - if uu___7 - then - FStar_Pervasives_Native.Some FStar_Syntax_Syntax.Data_ctor - else FStar_Pervasives_Native.None))) in - let uu___1 = FStar_Parser_Const.p2l ns in - FStar_Syntax_Syntax.lid_as_fv uu___1 quals in - let uu___ = - FStar_Compiler_Effect.op_Bang - FStar_TypeChecker_Normalize.reflection_env_hook in - match uu___ with - | FStar_Pervasives_Native.None -> fallback () - | FStar_Pervasives_Native.Some env -> - let qninfo = FStar_TypeChecker_Env.lookup_qname env lid in - (match qninfo with - | FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr (se, _us), _rng) -> - let quals = FStar_Syntax_DsEnv.fv_qual_of_se se in - let uu___1 = FStar_Parser_Const.p2l ns in - FStar_Syntax_Syntax.lid_as_fv uu___1 quals - | uu___1 -> fallback ()) -let rec last : 'a . 'a Prims.list -> 'a = - fun l -> - match l with - | [] -> failwith "last: empty list" - | x::[] -> x - | uu___::xs -> last xs -let rec init : 'a . 'a Prims.list -> 'a Prims.list = - fun l -> - match l with - | [] -> failwith "init: empty list" - | x::[] -> [] - | x::xs -> let uu___ = init xs in x :: uu___ -let (inspect_const : - FStar_Syntax_Syntax.sconst -> FStar_Reflection_V2_Data.vconst) = - fun c -> - match c with - | FStar_Const.Const_unit -> FStar_Reflection_V2_Data.C_Unit - | FStar_Const.Const_int (s, uu___) -> - let uu___1 = FStar_BigInt.big_int_of_string s in - FStar_Reflection_V2_Data.C_Int uu___1 - | FStar_Const.Const_bool (true) -> FStar_Reflection_V2_Data.C_True - | FStar_Const.Const_bool (false) -> FStar_Reflection_V2_Data.C_False - | FStar_Const.Const_string (s, uu___) -> - FStar_Reflection_V2_Data.C_String s - | FStar_Const.Const_range r -> FStar_Reflection_V2_Data.C_Range r - | FStar_Const.Const_reify uu___ -> FStar_Reflection_V2_Data.C_Reify - | FStar_Const.Const_reflect l -> - let uu___ = FStar_Ident.path_of_lid l in - FStar_Reflection_V2_Data.C_Reflect uu___ - | FStar_Const.Const_real s -> FStar_Reflection_V2_Data.C_Real s - | uu___ -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_const c in - FStar_Compiler_Util.format1 "unknown constant: %s" uu___2 in - failwith uu___1 -let (inspect_universe : - FStar_Syntax_Syntax.universe -> FStar_Reflection_V2_Data.universe_view) = - fun u -> - match u with - | FStar_Syntax_Syntax.U_zero -> FStar_Reflection_V2_Data.Uv_Zero - | FStar_Syntax_Syntax.U_succ u1 -> FStar_Reflection_V2_Data.Uv_Succ u1 - | FStar_Syntax_Syntax.U_max us -> FStar_Reflection_V2_Data.Uv_Max us - | FStar_Syntax_Syntax.U_bvar n -> - let uu___ = FStar_BigInt.of_int_fs n in - FStar_Reflection_V2_Data.Uv_BVar uu___ - | FStar_Syntax_Syntax.U_name i -> FStar_Reflection_V2_Data.Uv_Name i - | FStar_Syntax_Syntax.U_unif u1 -> FStar_Reflection_V2_Data.Uv_Unif u1 - | FStar_Syntax_Syntax.U_unknown -> FStar_Reflection_V2_Data.Uv_Unk -let (pack_universe : - FStar_Reflection_V2_Data.universe_view -> FStar_Syntax_Syntax.universe) = - fun uv -> - match uv with - | FStar_Reflection_V2_Data.Uv_Zero -> FStar_Syntax_Syntax.U_zero - | FStar_Reflection_V2_Data.Uv_Succ u -> FStar_Syntax_Syntax.U_succ u - | FStar_Reflection_V2_Data.Uv_Max us -> FStar_Syntax_Syntax.U_max us - | FStar_Reflection_V2_Data.Uv_BVar n -> - let uu___ = FStar_BigInt.to_int_fs n in - FStar_Syntax_Syntax.U_bvar uu___ - | FStar_Reflection_V2_Data.Uv_Name i -> FStar_Syntax_Syntax.U_name i - | FStar_Reflection_V2_Data.Uv_Unif u -> FStar_Syntax_Syntax.U_unif u - | FStar_Reflection_V2_Data.Uv_Unk -> FStar_Syntax_Syntax.U_unknown -let rec (inspect_pat : - FStar_Syntax_Syntax.pat -> FStar_Reflection_V2_Data.pattern) = - fun p -> - match p.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_constant c -> - let uu___ = inspect_const c in - FStar_Reflection_V2_Data.Pat_Constant uu___ - | FStar_Syntax_Syntax.Pat_cons (fv, us_opt, ps) -> - let uu___ = - FStar_Compiler_List.map - (fun uu___1 -> - match uu___1 with - | (p1, b) -> let uu___2 = inspect_pat p1 in (uu___2, b)) ps in - FStar_Reflection_V2_Data.Pat_Cons (fv, us_opt, uu___) - | FStar_Syntax_Syntax.Pat_var bv -> - let uu___ = - let uu___1 = FStar_Ident.string_of_id bv.FStar_Syntax_Syntax.ppname in - FStar_Compiler_Sealed.seal uu___1 in - FStar_Reflection_V2_Data.Pat_Var - ((FStar_Compiler_Sealed.seal bv.FStar_Syntax_Syntax.sort), uu___) - | FStar_Syntax_Syntax.Pat_dot_term eopt -> - FStar_Reflection_V2_Data.Pat_Dot_Term eopt -let rec (inspect_ln : - FStar_Syntax_Syntax.term -> FStar_Reflection_V2_Data.term_view) = - fun t -> - let t1 = FStar_Syntax_Subst.compress_subst t in - match t1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t2; FStar_Syntax_Syntax.meta = uu___;_} - -> inspect_ln t2 - | FStar_Syntax_Syntax.Tm_name bv -> FStar_Reflection_V2_Data.Tv_Var bv - | FStar_Syntax_Syntax.Tm_bvar bv -> FStar_Reflection_V2_Data.Tv_BVar bv - | FStar_Syntax_Syntax.Tm_fvar fv -> FStar_Reflection_V2_Data.Tv_FVar fv - | FStar_Syntax_Syntax.Tm_uinst (t2, us) -> - (match t2.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_fvar fv -> - FStar_Reflection_V2_Data.Tv_UInst (fv, us) - | uu___ -> - failwith "Reflection::inspect_ln: uinst for a non-fvar node") - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t2; - FStar_Syntax_Syntax.asc = (FStar_Pervasives.Inl ty, tacopt, eq); - FStar_Syntax_Syntax.eff_opt = uu___;_} - -> FStar_Reflection_V2_Data.Tv_AscribedT (t2, ty, tacopt, eq) - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t2; - FStar_Syntax_Syntax.asc = (FStar_Pervasives.Inr cty, tacopt, eq); - FStar_Syntax_Syntax.eff_opt = uu___;_} - -> FStar_Reflection_V2_Data.Tv_AscribedC (t2, cty, tacopt, eq) - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = uu___; FStar_Syntax_Syntax.args = [];_} -> - failwith "inspect_ln: empty arguments on Tm_app" - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = hd; FStar_Syntax_Syntax.args = args;_} -> - let uu___ = last args in - (match uu___ with - | (a, q) -> - let q' = inspect_aqual q in - let uu___1 = - let uu___2 = - let uu___3 = init args in FStar_Syntax_Util.mk_app hd uu___3 in - (uu___2, (a, q')) in - FStar_Reflection_V2_Data.Tv_App uu___1) - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = []; FStar_Syntax_Syntax.body = uu___; - FStar_Syntax_Syntax.rc_opt = uu___1;_} - -> failwith "inspect_ln: empty arguments on Tm_abs" - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = b::bs; FStar_Syntax_Syntax.body = t2; - FStar_Syntax_Syntax.rc_opt = k;_} - -> - let body = - match bs with - | [] -> t2 - | bs1 -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = bs1; - FStar_Syntax_Syntax.body = t2; - FStar_Syntax_Syntax.rc_opt = k - }) t2.FStar_Syntax_Syntax.pos in - FStar_Reflection_V2_Data.Tv_Abs (b, body) - | FStar_Syntax_Syntax.Tm_type u -> FStar_Reflection_V2_Data.Tv_Type u - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = []; FStar_Syntax_Syntax.comp = uu___;_} - -> failwith "inspect_ln: empty binders on arrow" - | FStar_Syntax_Syntax.Tm_arrow uu___ -> - let uu___1 = FStar_Syntax_Util.arrow_one_ln t1 in - (match uu___1 with - | FStar_Pervasives_Native.Some (b, c) -> - FStar_Reflection_V2_Data.Tv_Arrow (b, c) - | FStar_Pervasives_Native.None -> failwith "impossible") - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = bv; FStar_Syntax_Syntax.phi = t2;_} -> - let uu___ = - let uu___1 = FStar_Syntax_Syntax.mk_binder bv in (uu___1, t2) in - FStar_Reflection_V2_Data.Tv_Refine uu___ - | FStar_Syntax_Syntax.Tm_constant c -> - let uu___ = inspect_const c in - FStar_Reflection_V2_Data.Tv_Const uu___ - | FStar_Syntax_Syntax.Tm_uvar (ctx_u, s) -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Syntax_Unionfind.uvar_unique_id - ctx_u.FStar_Syntax_Syntax.ctx_uvar_head in - FStar_BigInt.of_int_fs uu___2 in - (uu___1, (ctx_u, s)) in - FStar_Reflection_V2_Data.Tv_Uvar uu___ - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (isrec, lb::[]); - FStar_Syntax_Syntax.body1 = t2;_} - -> - if lb.FStar_Syntax_Syntax.lbunivs <> [] - then FStar_Reflection_V2_Data.Tv_Unsupp - else - (match lb.FStar_Syntax_Syntax.lbname with - | FStar_Pervasives.Inr uu___1 -> - FStar_Reflection_V2_Data.Tv_Unsupp - | FStar_Pervasives.Inl bv -> - let uu___1 = - let uu___2 = FStar_Syntax_Syntax.mk_binder bv in - (isrec, (lb.FStar_Syntax_Syntax.lbattrs), uu___2, - (lb.FStar_Syntax_Syntax.lbdef), t2) in - FStar_Reflection_V2_Data.Tv_Let uu___1) - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = t2; - FStar_Syntax_Syntax.ret_opt = ret_opt; - FStar_Syntax_Syntax.brs = brs; - FStar_Syntax_Syntax.rc_opt1 = uu___;_} - -> - let brs1 = - FStar_Compiler_List.map - (fun uu___1 -> - match uu___1 with - | (pat, uu___2, t3) -> - let uu___3 = inspect_pat pat in (uu___3, t3)) brs in - FStar_Reflection_V2_Data.Tv_Match (t2, ret_opt, brs1) - | FStar_Syntax_Syntax.Tm_unknown -> FStar_Reflection_V2_Data.Tv_Unknown - | FStar_Syntax_Syntax.Tm_lazy i -> - let uu___ = FStar_Syntax_Util.unfold_lazy i in inspect_ln uu___ - | uu___ -> - ((let uu___2 = - let uu___3 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t1 in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.format2 - "inspect_ln: outside of expected syntax (%s, %s)" uu___3 uu___4 in - FStar_Errors.log_issue (FStar_Syntax_Syntax.has_range_syntax ()) t1 - FStar_Errors_Codes.Warning_CantInspect () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Reflection_V2_Data.Tv_Unsupp) -let (inspect_comp : - FStar_Syntax_Syntax.comp -> FStar_Reflection_V2_Data.comp_view) = - fun c -> - let get_dec flags = - let uu___ = - FStar_Compiler_List.tryFind - (fun uu___1 -> - match uu___1 with - | FStar_Syntax_Syntax.DECREASES uu___2 -> true - | uu___2 -> false) flags in - match uu___ with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.DECREASES - (FStar_Syntax_Syntax.Decreases_lex ts)) -> ts - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.DECREASES - (FStar_Syntax_Syntax.Decreases_wf uu___1)) -> - ((let uu___3 = - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_comp c in - FStar_Compiler_Util.format1 - "inspect_comp: inspecting comp with wf decreases clause is not yet supported: %s skipping the decreases clause" - uu___4 in - FStar_Errors.log_issue (FStar_Syntax_Syntax.has_range_syntax ()) - c FStar_Errors_Codes.Warning_CantInspect () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___3)); - []) - | uu___1 -> failwith "Impossible!" in - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total t -> FStar_Reflection_V2_Data.C_Total t - | FStar_Syntax_Syntax.GTotal t -> FStar_Reflection_V2_Data.C_GTotal t - | FStar_Syntax_Syntax.Comp ct -> - let uopt = - if - (FStar_Compiler_List.length ct.FStar_Syntax_Syntax.comp_univs) = - Prims.int_zero - then FStar_Syntax_Syntax.U_unknown - else FStar_Compiler_List.hd ct.FStar_Syntax_Syntax.comp_univs in - let uu___ = - FStar_Ident.lid_equals ct.FStar_Syntax_Syntax.effect_name - FStar_Parser_Const.effect_Lemma_lid in - if uu___ - then - (match ct.FStar_Syntax_Syntax.effect_args with - | (pre, uu___1)::(post, uu___2)::(pats, uu___3)::uu___4 -> - FStar_Reflection_V2_Data.C_Lemma (pre, post, pats) - | uu___1 -> - failwith "inspect_comp: Lemma does not have enough arguments?") - else - (let inspect_arg uu___2 = - match uu___2 with - | (a, q) -> let uu___3 = inspect_aqual q in (a, uu___3) in - let uu___2 = - let uu___3 = - FStar_Ident.path_of_lid ct.FStar_Syntax_Syntax.effect_name in - let uu___4 = - FStar_Compiler_List.map inspect_arg - ct.FStar_Syntax_Syntax.effect_args in - let uu___5 = get_dec ct.FStar_Syntax_Syntax.flags in - ((ct.FStar_Syntax_Syntax.comp_univs), uu___3, - (ct.FStar_Syntax_Syntax.result_typ), uu___4, uu___5) in - FStar_Reflection_V2_Data.C_Eff uu___2) -let (pack_comp : - FStar_Reflection_V2_Data.comp_view -> FStar_Syntax_Syntax.comp) = - fun cv -> - let urefl_to_univs u = - if u = FStar_Syntax_Syntax.U_unknown then [] else [u] in - let urefl_to_univ_opt u = - if u = FStar_Syntax_Syntax.U_unknown - then FStar_Pervasives_Native.None - else FStar_Pervasives_Native.Some u in - match cv with - | FStar_Reflection_V2_Data.C_Total t -> FStar_Syntax_Syntax.mk_Total t - | FStar_Reflection_V2_Data.C_GTotal t -> FStar_Syntax_Syntax.mk_GTotal t - | FStar_Reflection_V2_Data.C_Lemma (pre, post, pats) -> - let ct = - let uu___ = - let uu___1 = FStar_Syntax_Syntax.as_arg pre in - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.as_arg post in - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.as_arg pats in [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - { - FStar_Syntax_Syntax.comp_univs = []; - FStar_Syntax_Syntax.effect_name = - FStar_Parser_Const.effect_Lemma_lid; - FStar_Syntax_Syntax.result_typ = FStar_Syntax_Syntax.t_unit; - FStar_Syntax_Syntax.effect_args = uu___; - FStar_Syntax_Syntax.flags = [] - } in - FStar_Syntax_Syntax.mk_Comp ct - | FStar_Reflection_V2_Data.C_Eff (us, ef, res, args, decrs) -> - let pack_arg uu___ = - match uu___ with - | (a, q) -> let uu___1 = pack_aqual q in (a, uu___1) in - let flags = - if (FStar_Compiler_List.length decrs) = Prims.int_zero - then [] - else - [FStar_Syntax_Syntax.DECREASES - (FStar_Syntax_Syntax.Decreases_lex decrs)] in - let ct = - let uu___ = - FStar_Ident.lid_of_path ef FStar_Compiler_Range_Type.dummyRange in - let uu___1 = FStar_Compiler_List.map pack_arg args in - { - FStar_Syntax_Syntax.comp_univs = us; - FStar_Syntax_Syntax.effect_name = uu___; - FStar_Syntax_Syntax.result_typ = res; - FStar_Syntax_Syntax.effect_args = uu___1; - FStar_Syntax_Syntax.flags = flags - } in - FStar_Syntax_Syntax.mk_Comp ct -let (pack_const : - FStar_Reflection_V2_Data.vconst -> FStar_Syntax_Syntax.sconst) = - fun c -> - match c with - | FStar_Reflection_V2_Data.C_Unit -> FStar_Const.Const_unit - | FStar_Reflection_V2_Data.C_Int i -> - let uu___ = - let uu___1 = FStar_BigInt.string_of_big_int i in - (uu___1, FStar_Pervasives_Native.None) in - FStar_Const.Const_int uu___ - | FStar_Reflection_V2_Data.C_True -> FStar_Const.Const_bool true - | FStar_Reflection_V2_Data.C_False -> FStar_Const.Const_bool false - | FStar_Reflection_V2_Data.C_String s -> - FStar_Const.Const_string (s, FStar_Compiler_Range_Type.dummyRange) - | FStar_Reflection_V2_Data.C_Range r -> FStar_Const.Const_range r - | FStar_Reflection_V2_Data.C_Reify -> - FStar_Const.Const_reify FStar_Pervasives_Native.None - | FStar_Reflection_V2_Data.C_Reflect ns -> - let uu___ = - FStar_Ident.lid_of_path ns FStar_Compiler_Range_Type.dummyRange in - FStar_Const.Const_reflect uu___ - | FStar_Reflection_V2_Data.C_Real r -> FStar_Const.Const_real r -let rec (pack_pat : - FStar_Reflection_V2_Data.pattern -> FStar_Syntax_Syntax.pat) = - fun p -> - let wrap v = - { - FStar_Syntax_Syntax.v = v; - FStar_Syntax_Syntax.p = FStar_Compiler_Range_Type.dummyRange - } in - match p with - | FStar_Reflection_V2_Data.Pat_Constant c -> - let uu___ = - let uu___1 = pack_const c in - FStar_Syntax_Syntax.Pat_constant uu___1 in - wrap uu___ - | FStar_Reflection_V2_Data.Pat_Cons (head, univs, subpats) -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with - | (p1, b) -> let uu___4 = pack_pat p1 in (uu___4, b)) - subpats in - (head, univs, uu___2) in - FStar_Syntax_Syntax.Pat_cons uu___1 in - wrap uu___ - | FStar_Reflection_V2_Data.Pat_Var (sort, ppname) -> - let bv = - FStar_Syntax_Syntax.gen_bv (FStar_Compiler_Sealed.unseal ppname) - FStar_Pervasives_Native.None (FStar_Compiler_Sealed.unseal sort) in - wrap (FStar_Syntax_Syntax.Pat_var bv) - | FStar_Reflection_V2_Data.Pat_Dot_Term eopt -> - wrap (FStar_Syntax_Syntax.Pat_dot_term eopt) -let (pack_ln : - FStar_Reflection_V2_Data.term_view -> FStar_Syntax_Syntax.term) = - fun tv -> - match tv with - | FStar_Reflection_V2_Data.Tv_Var bv -> - FStar_Syntax_Syntax.bv_to_name - { - FStar_Syntax_Syntax.ppname = (bv.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = (bv.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = FStar_Syntax_Syntax.tun - } - | FStar_Reflection_V2_Data.Tv_BVar bv -> - FStar_Syntax_Syntax.bv_to_tm - { - FStar_Syntax_Syntax.ppname = (bv.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = (bv.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = FStar_Syntax_Syntax.tun - } - | FStar_Reflection_V2_Data.Tv_FVar fv -> FStar_Syntax_Syntax.fv_to_tm fv - | FStar_Reflection_V2_Data.Tv_UInst (fv, us) -> - let uu___ = FStar_Syntax_Syntax.fv_to_tm fv in - FStar_Syntax_Syntax.mk_Tm_uinst uu___ us - | FStar_Reflection_V2_Data.Tv_App (l, (r, q)) -> - let q' = pack_aqual q in FStar_Syntax_Util.mk_app l [(r, q')] - | FStar_Reflection_V2_Data.Tv_Abs (b, t) -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = [b]; - FStar_Syntax_Syntax.body = t; - FStar_Syntax_Syntax.rc_opt = FStar_Pervasives_Native.None - }) t.FStar_Syntax_Syntax.pos - | FStar_Reflection_V2_Data.Tv_Arrow (b, c) -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = [b]; FStar_Syntax_Syntax.comp = c }) - c.FStar_Syntax_Syntax.pos - | FStar_Reflection_V2_Data.Tv_Type u -> - FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_type u) - FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V2_Data.Tv_Refine (b, t) -> - let bv = b.FStar_Syntax_Syntax.binder_bv in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = bv; FStar_Syntax_Syntax.phi = t }) - t.FStar_Syntax_Syntax.pos - | FStar_Reflection_V2_Data.Tv_Const c -> - let uu___ = - let uu___1 = pack_const c in FStar_Syntax_Syntax.Tm_constant uu___1 in - FStar_Syntax_Syntax.mk uu___ FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V2_Data.Tv_Uvar (u, ctx_u_s) -> - FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_uvar ctx_u_s) - FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V2_Data.Tv_Let (isrec, attrs, b, t1, t2) -> - let bv = b.FStar_Syntax_Syntax.binder_bv in - let lb = - FStar_Syntax_Util.mk_letbinding (FStar_Pervasives.Inl bv) [] - bv.FStar_Syntax_Syntax.sort FStar_Parser_Const.effect_Tot_lid t1 - attrs FStar_Compiler_Range_Type.dummyRange in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = (isrec, [lb]); - FStar_Syntax_Syntax.body1 = t2 - }) FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V2_Data.Tv_Match (t, ret_opt, brs) -> - let brs1 = - FStar_Compiler_List.map - (fun uu___ -> - match uu___ with - | (pat, t1) -> - let uu___1 = pack_pat pat in - (uu___1, FStar_Pervasives_Native.None, t1)) brs in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_match - { - FStar_Syntax_Syntax.scrutinee = t; - FStar_Syntax_Syntax.ret_opt = ret_opt; - FStar_Syntax_Syntax.brs = brs1; - FStar_Syntax_Syntax.rc_opt1 = FStar_Pervasives_Native.None - }) FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V2_Data.Tv_AscribedT (e, t, tacopt, use_eq) -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_ascribed - { - FStar_Syntax_Syntax.tm = e; - FStar_Syntax_Syntax.asc = - ((FStar_Pervasives.Inl t), tacopt, use_eq); - FStar_Syntax_Syntax.eff_opt = FStar_Pervasives_Native.None - }) FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V2_Data.Tv_AscribedC (e, c, tacopt, use_eq) -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_ascribed - { - FStar_Syntax_Syntax.tm = e; - FStar_Syntax_Syntax.asc = - ((FStar_Pervasives.Inr c), tacopt, use_eq); - FStar_Syntax_Syntax.eff_opt = FStar_Pervasives_Native.None - }) FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V2_Data.Tv_Unknown -> - FStar_Syntax_Syntax.mk FStar_Syntax_Syntax.Tm_unknown - FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V2_Data.Tv_Unsupp -> - (FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_CantInspect () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic "packing a Tv_Unsupp into Tm_unknown"); - FStar_Syntax_Syntax.mk FStar_Syntax_Syntax.Tm_unknown - FStar_Compiler_Range_Type.dummyRange) -let (compare_bv : - FStar_Syntax_Syntax.bv -> FStar_Syntax_Syntax.bv -> FStar_Order.order) = - fun x -> - fun y -> - let n = FStar_Syntax_Syntax.order_bv x y in - if n < Prims.int_zero - then FStar_Order.Lt - else if n = Prims.int_zero then FStar_Order.Eq else FStar_Order.Gt -let (compare_namedv : - FStar_Reflection_V2_Data.namedv -> - FStar_Reflection_V2_Data.namedv -> FStar_Order.order) - = - fun x -> - fun y -> - let n = FStar_Syntax_Syntax.order_bv x y in - if n < Prims.int_zero - then FStar_Order.Lt - else if n = Prims.int_zero then FStar_Order.Eq else FStar_Order.Gt -let (lookup_attr_ses : - FStar_Syntax_Syntax.term -> - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.sigelt Prims.list) - = - fun attr -> - fun env -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress_subst attr in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_fvar fv -> - let uu___1 = - let uu___2 = FStar_Syntax_Syntax.lid_of_fv fv in - FStar_Ident.string_of_lid uu___2 in - FStar_TypeChecker_Env.lookup_attr env uu___1 - | uu___1 -> [] -let (lookup_attr : - FStar_Syntax_Syntax.term -> - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.fv Prims.list) - = - fun attr -> - fun env -> - let ses = lookup_attr_ses attr env in - FStar_Compiler_List.concatMap - (fun se -> - let uu___ = FStar_Syntax_Util.lid_of_sigelt se in - match uu___ with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some l -> - let uu___1 = - FStar_Syntax_Syntax.lid_as_fv l FStar_Pervasives_Native.None in - [uu___1]) ses -let (all_defs_in_env : - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.fv Prims.list) = - fun env -> - let uu___ = FStar_TypeChecker_Env.lidents env in - FStar_Compiler_List.map - (fun l -> FStar_Syntax_Syntax.lid_as_fv l FStar_Pervasives_Native.None) - uu___ -let (defs_in_module : - FStar_TypeChecker_Env.env -> - FStar_Reflection_V2_Data.name -> FStar_Syntax_Syntax.fv Prims.list) - = - fun env -> - fun modul -> - let uu___ = FStar_TypeChecker_Env.lidents env in - FStar_Compiler_List.concatMap - (fun l -> - let ns = - let uu___1 = - let uu___2 = FStar_Ident.ids_of_lid l in init uu___2 in - FStar_Compiler_List.map FStar_Ident.string_of_id uu___1 in - if ns = modul - then - let uu___1 = - FStar_Syntax_Syntax.lid_as_fv l FStar_Pervasives_Native.None in - [uu___1] - else []) uu___ -let (lookup_typ : - FStar_TypeChecker_Env.env -> - Prims.string Prims.list -> - FStar_Syntax_Syntax.sigelt FStar_Pervasives_Native.option) - = - fun env -> - fun ns -> - let lid = FStar_Parser_Const.p2l ns in - FStar_TypeChecker_Env.lookup_sigelt env lid -let (sigelt_attrs : - FStar_Syntax_Syntax.sigelt -> FStar_Syntax_Syntax.attribute Prims.list) = - fun se -> se.FStar_Syntax_Syntax.sigattrs -let (set_sigelt_attrs : - FStar_Syntax_Syntax.attribute Prims.list -> - FStar_Syntax_Syntax.sigelt -> FStar_Syntax_Syntax.sigelt) - = - fun attrs -> - fun se -> - { - FStar_Syntax_Syntax.sigel = (se.FStar_Syntax_Syntax.sigel); - FStar_Syntax_Syntax.sigrng = (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = (se.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = attrs; - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = (se.FStar_Syntax_Syntax.sigopts) - } -let (rd_to_syntax_qual : - FStar_Reflection_V2_Data.qualifier -> FStar_Syntax_Syntax.qualifier) = - fun uu___ -> - match uu___ with - | FStar_Reflection_V2_Data.Assumption -> FStar_Syntax_Syntax.Assumption - | FStar_Reflection_V2_Data.New -> FStar_Syntax_Syntax.New - | FStar_Reflection_V2_Data.Private -> FStar_Syntax_Syntax.Private - | FStar_Reflection_V2_Data.Unfold_for_unification_and_vcgen -> - FStar_Syntax_Syntax.Unfold_for_unification_and_vcgen - | FStar_Reflection_V2_Data.Visible_default -> - FStar_Syntax_Syntax.Visible_default - | FStar_Reflection_V2_Data.Irreducible -> FStar_Syntax_Syntax.Irreducible - | FStar_Reflection_V2_Data.Inline_for_extraction -> - FStar_Syntax_Syntax.Inline_for_extraction - | FStar_Reflection_V2_Data.NoExtract -> FStar_Syntax_Syntax.NoExtract - | FStar_Reflection_V2_Data.Noeq -> FStar_Syntax_Syntax.Noeq - | FStar_Reflection_V2_Data.Unopteq -> FStar_Syntax_Syntax.Unopteq - | FStar_Reflection_V2_Data.TotalEffect -> FStar_Syntax_Syntax.TotalEffect - | FStar_Reflection_V2_Data.Logic -> FStar_Syntax_Syntax.Logic - | FStar_Reflection_V2_Data.Reifiable -> FStar_Syntax_Syntax.Reifiable - | FStar_Reflection_V2_Data.Reflectable l -> - let uu___1 = - FStar_Ident.lid_of_path l FStar_Compiler_Range_Type.dummyRange in - FStar_Syntax_Syntax.Reflectable uu___1 - | FStar_Reflection_V2_Data.Discriminator l -> - let uu___1 = - FStar_Ident.lid_of_path l FStar_Compiler_Range_Type.dummyRange in - FStar_Syntax_Syntax.Discriminator uu___1 - | FStar_Reflection_V2_Data.Projector (l, i) -> - let uu___1 = - let uu___2 = - FStar_Ident.lid_of_path l FStar_Compiler_Range_Type.dummyRange in - (uu___2, i) in - FStar_Syntax_Syntax.Projector uu___1 - | FStar_Reflection_V2_Data.RecordType (l1, l2) -> - FStar_Syntax_Syntax.RecordType (l1, l2) - | FStar_Reflection_V2_Data.RecordConstructor (l1, l2) -> - FStar_Syntax_Syntax.RecordConstructor (l1, l2) - | FStar_Reflection_V2_Data.Action l -> - let uu___1 = - FStar_Ident.lid_of_path l FStar_Compiler_Range_Type.dummyRange in - FStar_Syntax_Syntax.Action uu___1 - | FStar_Reflection_V2_Data.ExceptionConstructor -> - FStar_Syntax_Syntax.ExceptionConstructor - | FStar_Reflection_V2_Data.HasMaskedEffect -> - FStar_Syntax_Syntax.HasMaskedEffect - | FStar_Reflection_V2_Data.Effect -> FStar_Syntax_Syntax.Effect - | FStar_Reflection_V2_Data.OnlyName -> FStar_Syntax_Syntax.OnlyName -let (syntax_to_rd_qual : - FStar_Syntax_Syntax.qualifier -> FStar_Reflection_V2_Data.qualifier) = - fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.Assumption -> FStar_Reflection_V2_Data.Assumption - | FStar_Syntax_Syntax.New -> FStar_Reflection_V2_Data.New - | FStar_Syntax_Syntax.Private -> FStar_Reflection_V2_Data.Private - | FStar_Syntax_Syntax.Unfold_for_unification_and_vcgen -> - FStar_Reflection_V2_Data.Unfold_for_unification_and_vcgen - | FStar_Syntax_Syntax.Visible_default -> - FStar_Reflection_V2_Data.Visible_default - | FStar_Syntax_Syntax.Irreducible -> FStar_Reflection_V2_Data.Irreducible - | FStar_Syntax_Syntax.Inline_for_extraction -> - FStar_Reflection_V2_Data.Inline_for_extraction - | FStar_Syntax_Syntax.NoExtract -> FStar_Reflection_V2_Data.NoExtract - | FStar_Syntax_Syntax.Noeq -> FStar_Reflection_V2_Data.Noeq - | FStar_Syntax_Syntax.Unopteq -> FStar_Reflection_V2_Data.Unopteq - | FStar_Syntax_Syntax.TotalEffect -> FStar_Reflection_V2_Data.TotalEffect - | FStar_Syntax_Syntax.Logic -> FStar_Reflection_V2_Data.Logic - | FStar_Syntax_Syntax.Reifiable -> FStar_Reflection_V2_Data.Reifiable - | FStar_Syntax_Syntax.Reflectable l -> - let uu___1 = FStar_Ident.path_of_lid l in - FStar_Reflection_V2_Data.Reflectable uu___1 - | FStar_Syntax_Syntax.Discriminator l -> - let uu___1 = FStar_Ident.path_of_lid l in - FStar_Reflection_V2_Data.Discriminator uu___1 - | FStar_Syntax_Syntax.Projector (l, i) -> - let uu___1 = let uu___2 = FStar_Ident.path_of_lid l in (uu___2, i) in - FStar_Reflection_V2_Data.Projector uu___1 - | FStar_Syntax_Syntax.RecordType (l1, l2) -> - FStar_Reflection_V2_Data.RecordType (l1, l2) - | FStar_Syntax_Syntax.RecordConstructor (l1, l2) -> - FStar_Reflection_V2_Data.RecordConstructor (l1, l2) - | FStar_Syntax_Syntax.Action l -> - let uu___1 = FStar_Ident.path_of_lid l in - FStar_Reflection_V2_Data.Action uu___1 - | FStar_Syntax_Syntax.ExceptionConstructor -> - FStar_Reflection_V2_Data.ExceptionConstructor - | FStar_Syntax_Syntax.HasMaskedEffect -> - FStar_Reflection_V2_Data.HasMaskedEffect - | FStar_Syntax_Syntax.Effect -> FStar_Reflection_V2_Data.Effect - | FStar_Syntax_Syntax.OnlyName -> FStar_Reflection_V2_Data.OnlyName -let (inspect_ident : - FStar_Ident.ident -> (Prims.string * FStar_Compiler_Range_Type.range)) = - fun i -> - let uu___ = FStar_Ident.string_of_id i in - let uu___1 = FStar_Ident.range_of_id i in (uu___, uu___1) -let (pack_ident : - (Prims.string * FStar_Compiler_Range_Type.range) -> FStar_Ident.ident) = - fun i -> FStar_Ident.mk_ident i -let (sigelt_quals : - FStar_Syntax_Syntax.sigelt -> FStar_Reflection_V2_Data.qualifier Prims.list) - = - fun se -> - FStar_Compiler_List.map syntax_to_rd_qual se.FStar_Syntax_Syntax.sigquals -let (set_sigelt_quals : - FStar_Reflection_V2_Data.qualifier Prims.list -> - FStar_Syntax_Syntax.sigelt -> FStar_Syntax_Syntax.sigelt) - = - fun quals -> - fun se -> - let uu___ = FStar_Compiler_List.map rd_to_syntax_qual quals in - { - FStar_Syntax_Syntax.sigel = (se.FStar_Syntax_Syntax.sigel); - FStar_Syntax_Syntax.sigrng = (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = uu___; - FStar_Syntax_Syntax.sigmeta = (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = (se.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = (se.FStar_Syntax_Syntax.sigopts) - } -let (sigelt_opts : - FStar_Syntax_Syntax.sigelt -> - FStar_VConfig.vconfig FStar_Pervasives_Native.option) - = fun se -> se.FStar_Syntax_Syntax.sigopts -let (embed_vconfig : FStar_VConfig.vconfig -> FStar_Syntax_Syntax.term) = - fun vcfg -> - let uu___ = - FStar_Syntax_Embeddings_Base.embed FStar_Syntax_Embeddings.e_vconfig - vcfg in - uu___ FStar_Compiler_Range_Type.dummyRange FStar_Pervasives_Native.None - FStar_Syntax_Embeddings_Base.id_norm_cb -let (inspect_sigelt : - FStar_Syntax_Syntax.sigelt -> FStar_Reflection_V2_Data.sigelt_view) = - fun se -> - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (r, lbs); - FStar_Syntax_Syntax.lids1 = uu___;_} - -> FStar_Reflection_V2_Data.Sg_Let (r, lbs) - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = lid; FStar_Syntax_Syntax.us = us; - FStar_Syntax_Syntax.params = param_bs; - FStar_Syntax_Syntax.num_uniform_params = uu___; - FStar_Syntax_Syntax.t = ty; FStar_Syntax_Syntax.mutuals = uu___1; - FStar_Syntax_Syntax.ds = c_lids; - FStar_Syntax_Syntax.injective_type_params = uu___2;_} - -> - let nm = FStar_Ident.path_of_lid lid in - let inspect_ctor c_lid = - let uu___3 = - let uu___4 = get_env () in - FStar_TypeChecker_Env.lookup_sigelt uu___4 c_lid in - match uu___3 with - | FStar_Pervasives_Native.Some - { - FStar_Syntax_Syntax.sigel = FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = lid1; - FStar_Syntax_Syntax.us1 = us1; - FStar_Syntax_Syntax.t1 = cty; - FStar_Syntax_Syntax.ty_lid = uu___4; - FStar_Syntax_Syntax.num_ty_params = nparam; - FStar_Syntax_Syntax.mutuals1 = uu___5; - FStar_Syntax_Syntax.injective_type_params1 = uu___6;_}; - FStar_Syntax_Syntax.sigrng = uu___7; - FStar_Syntax_Syntax.sigquals = uu___8; - FStar_Syntax_Syntax.sigmeta = uu___9; - FStar_Syntax_Syntax.sigattrs = uu___10; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___11; - FStar_Syntax_Syntax.sigopts = uu___12;_} - -> let uu___13 = FStar_Ident.path_of_lid lid1 in (uu___13, cty) - | uu___4 -> - failwith "impossible: inspect_sigelt: did not find ctor" in - let uu___3 = - let uu___4 = FStar_Compiler_List.map inspect_ctor c_lids in - (nm, us, param_bs, ty, uu___4) in - FStar_Reflection_V2_Data.Sg_Inductive uu___3 - | FStar_Syntax_Syntax.Sig_declare_typ - { FStar_Syntax_Syntax.lid2 = lid; FStar_Syntax_Syntax.us2 = us; - FStar_Syntax_Syntax.t2 = ty;_} - -> - let nm = FStar_Ident.path_of_lid lid in - FStar_Reflection_V2_Data.Sg_Val (nm, us, ty) - | uu___ -> FStar_Reflection_V2_Data.Unk -let (pack_sigelt : - FStar_Reflection_V2_Data.sigelt_view -> FStar_Syntax_Syntax.sigelt) = - fun sv -> - let check_lid lid = - let uu___ = - let uu___1 = - let uu___2 = FStar_Ident.path_of_lid lid in - FStar_Compiler_List.length uu___2 in - uu___1 <= Prims.int_one in - if uu___ - then - let uu___1 = - let uu___2 = - let uu___3 = FStar_Ident.string_of_lid lid in - Prims.strcat uu___3 "\" (did you forget a module path?)" in - Prims.strcat "pack_sigelt: invalid long identifier \"" uu___2 in - failwith uu___1 - else () in - match sv with - | FStar_Reflection_V2_Data.Sg_Let (r, lbs) -> - let pack_letbinding lb = - let uu___ = lb in - match uu___ with - | { FStar_Syntax_Syntax.lbname = nm; - FStar_Syntax_Syntax.lbunivs = uu___1; - FStar_Syntax_Syntax.lbtyp = uu___2; - FStar_Syntax_Syntax.lbeff = uu___3; - FStar_Syntax_Syntax.lbdef = uu___4; - FStar_Syntax_Syntax.lbattrs = uu___5; - FStar_Syntax_Syntax.lbpos = uu___6;_} -> - let lid = - match nm with - | FStar_Pervasives.Inr fv -> FStar_Syntax_Syntax.lid_of_fv fv - | uu___7 -> - failwith - "impossible: pack_sigelt: bv in toplevel let binding" in - (check_lid lid; (lid, lb)) in - let packed = FStar_Compiler_List.map pack_letbinding lbs in - let lbs1 = FStar_Compiler_List.map FStar_Pervasives_Native.snd packed in - let lids = FStar_Compiler_List.map FStar_Pervasives_Native.fst packed in - FStar_Syntax_Syntax.mk_sigelt - (FStar_Syntax_Syntax.Sig_let - { - FStar_Syntax_Syntax.lbs1 = (r, lbs1); - FStar_Syntax_Syntax.lids1 = lids - }) - | FStar_Reflection_V2_Data.Sg_Inductive - (nm, us_names, param_bs, ty, ctors) -> - let ind_lid = - FStar_Ident.lid_of_path nm FStar_Compiler_Range_Type.dummyRange in - (check_lid ind_lid; - (let nparam = FStar_Compiler_List.length param_bs in - let injective_type_params = false in - let pack_ctor c = - let uu___1 = c in - match uu___1 with - | (nm1, ty1) -> - let lid = - FStar_Ident.lid_of_path nm1 - FStar_Compiler_Range_Type.dummyRange in - FStar_Syntax_Syntax.mk_sigelt - (FStar_Syntax_Syntax.Sig_datacon - { - FStar_Syntax_Syntax.lid1 = lid; - FStar_Syntax_Syntax.us1 = us_names; - FStar_Syntax_Syntax.t1 = ty1; - FStar_Syntax_Syntax.ty_lid = ind_lid; - FStar_Syntax_Syntax.num_ty_params = nparam; - FStar_Syntax_Syntax.mutuals1 = []; - FStar_Syntax_Syntax.injective_type_params1 = - injective_type_params - }) in - let ctor_ses = FStar_Compiler_List.map pack_ctor ctors in - let c_lids = - FStar_Compiler_List.map - (fun se -> - let uu___1 = FStar_Syntax_Util.lid_of_sigelt se in - FStar_Compiler_Util.must uu___1) ctor_ses in - let ind_se = - FStar_Syntax_Syntax.mk_sigelt - (FStar_Syntax_Syntax.Sig_inductive_typ - { - FStar_Syntax_Syntax.lid = ind_lid; - FStar_Syntax_Syntax.us = us_names; - FStar_Syntax_Syntax.params = param_bs; - FStar_Syntax_Syntax.num_uniform_params = - FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.t = ty; - FStar_Syntax_Syntax.mutuals = []; - FStar_Syntax_Syntax.ds = c_lids; - FStar_Syntax_Syntax.injective_type_params = - injective_type_params - }) in - let se = - FStar_Syntax_Syntax.mk_sigelt - (FStar_Syntax_Syntax.Sig_bundle - { - FStar_Syntax_Syntax.ses = (ind_se :: ctor_ses); - FStar_Syntax_Syntax.lids = (ind_lid :: c_lids) - }) in - { - FStar_Syntax_Syntax.sigel = (se.FStar_Syntax_Syntax.sigel); - FStar_Syntax_Syntax.sigrng = (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = (FStar_Syntax_Syntax.Noeq :: - (se.FStar_Syntax_Syntax.sigquals)); - FStar_Syntax_Syntax.sigmeta = (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = (se.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = (se.FStar_Syntax_Syntax.sigopts) - })) - | FStar_Reflection_V2_Data.Sg_Val (nm, us_names, ty) -> - let val_lid = - FStar_Ident.lid_of_path nm FStar_Compiler_Range_Type.dummyRange in - (check_lid val_lid; - FStar_Syntax_Syntax.mk_sigelt - (FStar_Syntax_Syntax.Sig_declare_typ - { - FStar_Syntax_Syntax.lid2 = val_lid; - FStar_Syntax_Syntax.us2 = us_names; - FStar_Syntax_Syntax.t2 = ty - })) - | FStar_Reflection_V2_Data.Unk -> - failwith "packing Unk, this should never happen" -let (inspect_lb : - FStar_Syntax_Syntax.letbinding -> FStar_Reflection_V2_Data.lb_view) = - fun lb -> - let uu___ = lb in - match uu___ with - | { FStar_Syntax_Syntax.lbname = nm; FStar_Syntax_Syntax.lbunivs = us; - FStar_Syntax_Syntax.lbtyp = typ; FStar_Syntax_Syntax.lbeff = uu___1; - FStar_Syntax_Syntax.lbdef = def; - FStar_Syntax_Syntax.lbattrs = uu___2; - FStar_Syntax_Syntax.lbpos = uu___3;_} -> - (match nm with - | FStar_Pervasives.Inr fv -> - { - FStar_Reflection_V2_Data.lb_fv = fv; - FStar_Reflection_V2_Data.lb_us = us; - FStar_Reflection_V2_Data.lb_typ = typ; - FStar_Reflection_V2_Data.lb_def = def - } - | uu___4 -> failwith "Impossible: bv in top-level let binding") -let (pack_lb : - FStar_Reflection_V2_Data.lb_view -> FStar_Syntax_Syntax.letbinding) = - fun lbv -> - let uu___ = lbv in - match uu___ with - | { FStar_Reflection_V2_Data.lb_fv = fv; - FStar_Reflection_V2_Data.lb_us = us; - FStar_Reflection_V2_Data.lb_typ = typ; - FStar_Reflection_V2_Data.lb_def = def;_} -> - FStar_Syntax_Util.mk_letbinding (FStar_Pervasives.Inr fv) us typ - FStar_Parser_Const.effect_Tot_lid def [] - FStar_Compiler_Range_Type.dummyRange -let (inspect_namedv : - FStar_Reflection_V2_Data.namedv -> FStar_Reflection_V2_Data.namedv_view) = - fun v -> - if v.FStar_Syntax_Syntax.index < Prims.int_zero - then - (let uu___1 = - let uu___2 = FStar_Ident.string_of_id v.FStar_Syntax_Syntax.ppname in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - v.FStar_Syntax_Syntax.sort in - FStar_Compiler_Util.format3 - "inspect_namedv: uniq is negative (%s : %s), uniq = %s" uu___2 - uu___3 (Prims.string_of_int v.FStar_Syntax_Syntax.index) in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_CantInspect () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1)) - else (); - (let uu___1 = FStar_BigInt.of_int_fs v.FStar_Syntax_Syntax.index in - let uu___2 = - let uu___3 = FStar_Ident.string_of_id v.FStar_Syntax_Syntax.ppname in - FStar_Compiler_Sealed.seal uu___3 in - { - FStar_Reflection_V2_Data.uniq = uu___1; - FStar_Reflection_V2_Data.sort = - (FStar_Compiler_Sealed.seal v.FStar_Syntax_Syntax.sort); - FStar_Reflection_V2_Data.ppname = uu___2 - }) -let (pack_namedv : - FStar_Reflection_V2_Data.namedv_view -> FStar_Reflection_V2_Data.namedv) = - fun vv -> - (let uu___1 = - let uu___2 = FStar_BigInt.to_int_fs vv.FStar_Reflection_V2_Data.uniq in - uu___2 < Prims.int_zero in - if uu___1 - then - let uu___2 = - let uu___3 = - let uu___4 = - FStar_BigInt.to_int_fs vv.FStar_Reflection_V2_Data.uniq in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) uu___4 in - FStar_Compiler_Util.format2 - "pack_namedv: uniq is negative (%s), uniq = %s" - (FStar_Compiler_Sealed.unseal vv.FStar_Reflection_V2_Data.ppname) - uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_CantInspect () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2) - else ()); - (let uu___1 = - FStar_Ident.mk_ident - ((FStar_Compiler_Sealed.unseal vv.FStar_Reflection_V2_Data.ppname), - FStar_Compiler_Range_Type.dummyRange) in - let uu___2 = FStar_BigInt.to_int_fs vv.FStar_Reflection_V2_Data.uniq in - { - FStar_Syntax_Syntax.ppname = uu___1; - FStar_Syntax_Syntax.index = uu___2; - FStar_Syntax_Syntax.sort = - (FStar_Compiler_Sealed.unseal vv.FStar_Reflection_V2_Data.sort) - }) -let (inspect_bv : FStar_Syntax_Syntax.bv -> FStar_Reflection_V2_Data.bv_view) - = - fun bv -> - if bv.FStar_Syntax_Syntax.index < Prims.int_zero - then - (let uu___1 = - let uu___2 = FStar_Ident.string_of_id bv.FStar_Syntax_Syntax.ppname in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - bv.FStar_Syntax_Syntax.sort in - FStar_Compiler_Util.format3 - "inspect_bv: index is negative (%s : %s), index = %s" uu___2 - uu___3 (Prims.string_of_int bv.FStar_Syntax_Syntax.index) in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_CantInspect () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1)) - else (); - (let uu___1 = FStar_BigInt.of_int_fs bv.FStar_Syntax_Syntax.index in - let uu___2 = - let uu___3 = FStar_Ident.string_of_id bv.FStar_Syntax_Syntax.ppname in - FStar_Compiler_Sealed.seal uu___3 in - { - FStar_Reflection_V2_Data.index = uu___1; - FStar_Reflection_V2_Data.sort1 = - (FStar_Compiler_Sealed.seal bv.FStar_Syntax_Syntax.sort); - FStar_Reflection_V2_Data.ppname1 = uu___2 - }) -let (pack_bv : FStar_Reflection_V2_Data.bv_view -> FStar_Syntax_Syntax.bv) = - fun bvv -> - (let uu___1 = - let uu___2 = FStar_BigInt.to_int_fs bvv.FStar_Reflection_V2_Data.index in - uu___2 < Prims.int_zero in - if uu___1 - then - let uu___2 = - let uu___3 = - let uu___4 = - FStar_BigInt.to_int_fs bvv.FStar_Reflection_V2_Data.index in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) uu___4 in - FStar_Compiler_Util.format2 - "pack_bv: index is negative (%s), index = %s" - (FStar_Compiler_Sealed.unseal bvv.FStar_Reflection_V2_Data.ppname1) - uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_CantInspect () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2) - else ()); - (let uu___1 = - FStar_Ident.mk_ident - ((FStar_Compiler_Sealed.unseal bvv.FStar_Reflection_V2_Data.ppname1), - FStar_Compiler_Range_Type.dummyRange) in - let uu___2 = FStar_BigInt.to_int_fs bvv.FStar_Reflection_V2_Data.index in - { - FStar_Syntax_Syntax.ppname = uu___1; - FStar_Syntax_Syntax.index = uu___2; - FStar_Syntax_Syntax.sort = - (FStar_Compiler_Sealed.unseal bvv.FStar_Reflection_V2_Data.sort1) - }) -let (inspect_binder : - FStar_Syntax_Syntax.binder -> FStar_Reflection_V2_Data.binder_view) = - fun b -> - let attrs = - FStar_Syntax_Util.encode_positivity_attributes - b.FStar_Syntax_Syntax.binder_positivity - b.FStar_Syntax_Syntax.binder_attrs in - let uu___ = inspect_bqual b.FStar_Syntax_Syntax.binder_qual in - let uu___1 = - let uu___2 = - FStar_Ident.string_of_id - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.ppname in - FStar_Compiler_Sealed.seal uu___2 in - { - FStar_Reflection_V2_Data.sort2 = - ((b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort); - FStar_Reflection_V2_Data.qual = uu___; - FStar_Reflection_V2_Data.attrs = attrs; - FStar_Reflection_V2_Data.ppname2 = uu___1 - } -let (pack_binder : - FStar_Reflection_V2_Data.binder_view -> FStar_Syntax_Syntax.binder) = - fun bview -> - let uu___ = - FStar_Syntax_Util.parse_positivity_attributes - bview.FStar_Reflection_V2_Data.attrs in - match uu___ with - | (pqual, attrs) -> - let uu___1 = - let uu___2 = - FStar_Ident.mk_ident - ((FStar_Compiler_Sealed.unseal - bview.FStar_Reflection_V2_Data.ppname2), - FStar_Compiler_Range_Type.dummyRange) in - { - FStar_Syntax_Syntax.ppname = uu___2; - FStar_Syntax_Syntax.index = Prims.int_zero; - FStar_Syntax_Syntax.sort = (bview.FStar_Reflection_V2_Data.sort2) - } in - let uu___2 = pack_bqual bview.FStar_Reflection_V2_Data.qual in - { - FStar_Syntax_Syntax.binder_bv = uu___1; - FStar_Syntax_Syntax.binder_qual = uu___2; - FStar_Syntax_Syntax.binder_positivity = pqual; - FStar_Syntax_Syntax.binder_attrs = attrs - } -let (moduleof : FStar_TypeChecker_Env.env -> Prims.string Prims.list) = - fun e -> FStar_Ident.path_of_lid e.FStar_TypeChecker_Env.curmodule -let (env_open_modules : - FStar_TypeChecker_Env.env -> FStar_Reflection_V2_Data.name Prims.list) = - fun e -> - let uu___ = FStar_Syntax_DsEnv.open_modules e.FStar_TypeChecker_Env.dsenv in - FStar_Compiler_List.map - (fun uu___1 -> - match uu___1 with - | (l, m) -> - let uu___2 = FStar_Ident.ids_of_lid l in - FStar_Compiler_List.map FStar_Ident.string_of_id uu___2) uu___ -let (bv_to_binding : - FStar_Syntax_Syntax.bv -> FStar_Reflection_V2_Data.binding) = - fun bv -> - let uu___ = FStar_BigInt.of_int_fs bv.FStar_Syntax_Syntax.index in - let uu___1 = - let uu___2 = FStar_Ident.string_of_id bv.FStar_Syntax_Syntax.ppname in - FStar_Compiler_Sealed.seal uu___2 in - { - FStar_Reflection_V2_Data.uniq1 = uu___; - FStar_Reflection_V2_Data.sort3 = (bv.FStar_Syntax_Syntax.sort); - FStar_Reflection_V2_Data.ppname3 = uu___1 - } -let (vars_of_env : - FStar_TypeChecker_Env.env -> FStar_Reflection_V2_Data.binding Prims.list) = - fun e -> - let uu___ = FStar_TypeChecker_Env.all_binders e in - FStar_Compiler_List.map - (fun b -> bv_to_binding b.FStar_Syntax_Syntax.binder_bv) uu___ -let eqopt : - 'uuuuu . - unit -> - ('uuuuu -> 'uuuuu -> Prims.bool) -> - 'uuuuu FStar_Pervasives_Native.option -> - 'uuuuu FStar_Pervasives_Native.option -> Prims.bool - = fun uu___ -> FStar_Syntax_Util.eqopt -let eqlist : - 'uuuuu . - unit -> - ('uuuuu -> 'uuuuu -> Prims.bool) -> - 'uuuuu Prims.list -> 'uuuuu Prims.list -> Prims.bool - = fun uu___ -> FStar_Syntax_Util.eqlist -let eqprod : - 'uuuuu 'uuuuu1 . - unit -> - ('uuuuu -> 'uuuuu -> Prims.bool) -> - ('uuuuu1 -> 'uuuuu1 -> Prims.bool) -> - ('uuuuu * 'uuuuu1) -> ('uuuuu * 'uuuuu1) -> Prims.bool - = fun uu___ -> FStar_Syntax_Util.eqprod -let rec (term_eq : - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term -> Prims.bool) = - fun t1 -> - fun t2 -> - let uu___ = - let uu___1 = inspect_ln t1 in - let uu___2 = inspect_ln t2 in (uu___1, uu___2) in - match uu___ with - | (FStar_Reflection_V2_Data.Tv_Var bv1, FStar_Reflection_V2_Data.Tv_Var - bv2) -> bv_eq bv1 bv2 - | (FStar_Reflection_V2_Data.Tv_BVar bv1, - FStar_Reflection_V2_Data.Tv_BVar bv2) -> bv_eq bv1 bv2 - | (FStar_Reflection_V2_Data.Tv_FVar fv1, - FStar_Reflection_V2_Data.Tv_FVar fv2) -> - FStar_Syntax_Syntax.fv_eq fv1 fv2 - | (FStar_Reflection_V2_Data.Tv_UInst (fv1, us1), - FStar_Reflection_V2_Data.Tv_UInst (fv2, us2)) -> - (FStar_Syntax_Syntax.fv_eq fv1 fv2) && (univs_eq us1 us2) - | (FStar_Reflection_V2_Data.Tv_App (h1, arg1), - FStar_Reflection_V2_Data.Tv_App (h2, arg2)) -> - (term_eq h1 h2) && (arg_eq arg1 arg2) - | (FStar_Reflection_V2_Data.Tv_Abs (b1, t11), - FStar_Reflection_V2_Data.Tv_Abs (b2, t21)) -> - (binder_eq b1 b2) && (term_eq t11 t21) - | (FStar_Reflection_V2_Data.Tv_Arrow (b1, c1), - FStar_Reflection_V2_Data.Tv_Arrow (b2, c2)) -> - (binder_eq b1 b2) && (comp_eq c1 c2) - | (FStar_Reflection_V2_Data.Tv_Type u1, - FStar_Reflection_V2_Data.Tv_Type u2) -> univ_eq u1 u2 - | (FStar_Reflection_V2_Data.Tv_Refine (b1, t11), - FStar_Reflection_V2_Data.Tv_Refine (b2, t21)) -> - (term_eq - (b1.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort - (b2.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort) - && (term_eq t11 t21) - | (FStar_Reflection_V2_Data.Tv_Const c1, - FStar_Reflection_V2_Data.Tv_Const c2) -> const_eq c1 c2 - | (FStar_Reflection_V2_Data.Tv_Uvar (n1, uv1), - FStar_Reflection_V2_Data.Tv_Uvar (n2, uv2)) -> n1 = n2 - | (FStar_Reflection_V2_Data.Tv_Let (r1, ats1, b1, m1, n1), - FStar_Reflection_V2_Data.Tv_Let (r2, ats2, b2, m2, n2)) -> - ((((r1 = r2) && ((eqlist ()) term_eq ats1 ats2)) && - (binder_eq b1 b2)) - && (term_eq m1 m2)) - && (term_eq n1 n2) - | (FStar_Reflection_V2_Data.Tv_Match (h1, an1, brs1), - FStar_Reflection_V2_Data.Tv_Match (h2, an2, brs2)) -> - ((term_eq h1 h2) && ((eqopt ()) match_ret_asc_eq an1 an2)) && - ((eqlist ()) branch_eq brs1 brs2) - | (FStar_Reflection_V2_Data.Tv_AscribedT (e1, t11, topt1, eq1), - FStar_Reflection_V2_Data.Tv_AscribedT (e2, t21, topt2, eq2)) -> - (((term_eq e1 e2) && (term_eq t11 t21)) && - ((eqopt ()) term_eq topt1 topt2)) - && (eq1 = eq2) - | (FStar_Reflection_V2_Data.Tv_AscribedC (e1, c1, topt1, eq1), - FStar_Reflection_V2_Data.Tv_AscribedC (e2, c2, topt2, eq2)) -> - (((term_eq e1 e2) && (comp_eq c1 c2)) && - ((eqopt ()) term_eq topt1 topt2)) - && (eq1 = eq2) - | (FStar_Reflection_V2_Data.Tv_Unknown, - FStar_Reflection_V2_Data.Tv_Unknown) -> true - | uu___1 -> false -and (arg_eq : - FStar_Reflection_V2_Data.argv -> - FStar_Reflection_V2_Data.argv -> Prims.bool) - = - fun arg1 -> - fun arg2 -> - let uu___ = arg1 in - match uu___ with - | (a1, aq1) -> - let uu___1 = arg2 in - (match uu___1 with - | (a2, aq2) -> (term_eq a1 a2) && (aqual_eq aq1 aq2)) -and (aqual_eq : - FStar_Reflection_V2_Data.aqualv -> - FStar_Reflection_V2_Data.aqualv -> Prims.bool) - = - fun aq1 -> - fun aq2 -> - match (aq1, aq2) with - | (FStar_Reflection_V2_Data.Q_Implicit, - FStar_Reflection_V2_Data.Q_Implicit) -> true - | (FStar_Reflection_V2_Data.Q_Explicit, - FStar_Reflection_V2_Data.Q_Explicit) -> true - | (FStar_Reflection_V2_Data.Q_Meta t1, FStar_Reflection_V2_Data.Q_Meta - t2) -> term_eq t1 t2 - | uu___ -> false -and (binder_eq : - FStar_Syntax_Syntax.binder -> FStar_Syntax_Syntax.binder -> Prims.bool) = - fun b1 -> - fun b2 -> - let bview1 = inspect_binder b1 in - let bview2 = inspect_binder b2 in - ((term_eq bview1.FStar_Reflection_V2_Data.sort2 - bview2.FStar_Reflection_V2_Data.sort2) - && - (aqual_eq bview1.FStar_Reflection_V2_Data.qual - bview2.FStar_Reflection_V2_Data.qual)) - && - ((eqlist ()) term_eq bview1.FStar_Reflection_V2_Data.attrs - bview2.FStar_Reflection_V2_Data.attrs) -and (bv_eq : FStar_Syntax_Syntax.bv -> FStar_Syntax_Syntax.bv -> Prims.bool) - = - fun bv1 -> - fun bv2 -> bv1.FStar_Syntax_Syntax.index = bv2.FStar_Syntax_Syntax.index -and (comp_eq : - FStar_Syntax_Syntax.comp -> FStar_Syntax_Syntax.comp -> Prims.bool) = - fun c1 -> - fun c2 -> - let uu___ = - let uu___1 = inspect_comp c1 in - let uu___2 = inspect_comp c2 in (uu___1, uu___2) in - match uu___ with - | (FStar_Reflection_V2_Data.C_Total t1, - FStar_Reflection_V2_Data.C_Total t2) -> term_eq t1 t2 - | (FStar_Reflection_V2_Data.C_GTotal t1, - FStar_Reflection_V2_Data.C_GTotal t2) -> term_eq t1 t2 - | (FStar_Reflection_V2_Data.C_Lemma (pre1, post1, pats1), - FStar_Reflection_V2_Data.C_Lemma (pre2, post2, pats2)) -> - ((term_eq pre1 pre2) && (term_eq post1 post2)) && - (term_eq pats1 pats2) - | (FStar_Reflection_V2_Data.C_Eff (us1, name1, t1, args1, decrs1), - FStar_Reflection_V2_Data.C_Eff (us2, name2, t2, args2, decrs2)) -> - ((((univs_eq us1 us2) && (name1 = name2)) && (term_eq t1 t2)) && - ((eqlist ()) arg_eq args1 args2)) - && ((eqlist ()) term_eq decrs1 decrs2) - | uu___1 -> false -and (match_ret_asc_eq : - FStar_Syntax_Syntax.match_returns_ascription -> - FStar_Syntax_Syntax.match_returns_ascription -> Prims.bool) - = fun a1 -> fun a2 -> (eqprod ()) binder_eq ascription_eq a1 a2 -and (ascription_eq : - FStar_Syntax_Syntax.ascription -> - FStar_Syntax_Syntax.ascription -> Prims.bool) - = - fun asc1 -> - fun asc2 -> - let uu___ = asc1 in - match uu___ with - | (a1, topt1, eq1) -> - let uu___1 = asc2 in - (match uu___1 with - | (a2, topt2, eq2) -> - ((match (a1, a2) with - | (FStar_Pervasives.Inl t1, FStar_Pervasives.Inl t2) -> - term_eq t1 t2 - | (FStar_Pervasives.Inr c1, FStar_Pervasives.Inr c2) -> - comp_eq c1 c2) - && ((eqopt ()) term_eq topt1 topt2)) - && (eq1 = eq2)) -and (branch_eq : - FStar_Reflection_V2_Data.branch -> - FStar_Reflection_V2_Data.branch -> Prims.bool) - = fun c1 -> fun c2 -> (eqprod ()) pattern_eq term_eq c1 c2 -and (pattern_eq : - FStar_Reflection_V2_Data.pattern -> - FStar_Reflection_V2_Data.pattern -> Prims.bool) - = - fun p1 -> - fun p2 -> - match (p1, p2) with - | (FStar_Reflection_V2_Data.Pat_Constant c1, - FStar_Reflection_V2_Data.Pat_Constant c2) -> const_eq c1 c2 - | (FStar_Reflection_V2_Data.Pat_Cons (fv1, us1, subpats1), - FStar_Reflection_V2_Data.Pat_Cons (fv2, us2, subpats2)) -> - ((FStar_Syntax_Syntax.fv_eq fv1 fv2) && - ((eqopt ()) ((eqlist ()) univ_eq) us1 us2)) - && - ((eqlist ()) - ((eqprod ()) pattern_eq (fun b1 -> fun b2 -> b1 = b2)) - subpats1 subpats2) - | (FStar_Reflection_V2_Data.Pat_Var (uu___, uu___1), - FStar_Reflection_V2_Data.Pat_Var (uu___2, uu___3)) -> true - | (FStar_Reflection_V2_Data.Pat_Dot_Term topt1, - FStar_Reflection_V2_Data.Pat_Dot_Term topt2) -> - (eqopt ()) term_eq topt1 topt2 - | uu___ -> false -and (const_eq : - FStar_Reflection_V2_Data.vconst -> - FStar_Reflection_V2_Data.vconst -> Prims.bool) - = fun c1 -> fun c2 -> c1 = c2 -and (univ_eq : - FStar_Syntax_Syntax.universe -> FStar_Syntax_Syntax.universe -> Prims.bool) - = fun u1 -> fun u2 -> FStar_Syntax_Util.eq_univs u1 u2 -and (univs_eq : - FStar_Syntax_Syntax.universe Prims.list -> - FStar_Syntax_Syntax.universe Prims.list -> Prims.bool) - = fun us1 -> fun us2 -> (eqlist ()) univ_eq us1 us2 -let (implode_qn : Prims.string Prims.list -> Prims.string) = - fun ns -> FStar_Compiler_String.concat "." ns -let (explode_qn : Prims.string -> Prims.string Prims.list) = - fun s -> FStar_Compiler_String.split [46] s -let (compare_string : Prims.string -> Prims.string -> FStar_BigInt.t) = - fun s1 -> - fun s2 -> FStar_BigInt.of_int_fs (FStar_Compiler_String.compare s1 s2) -let (push_binder : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.binder -> FStar_TypeChecker_Env.env) - = fun e -> fun b -> FStar_TypeChecker_Env.push_binders e [b] -let (push_namedv : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.bv -> FStar_TypeChecker_Env.env) - = - fun e -> - fun b -> - let uu___ = let uu___1 = FStar_Syntax_Syntax.mk_binder b in [uu___1] in - FStar_TypeChecker_Env.push_binders e uu___ -let (subst_term : - FStar_Syntax_Syntax.subst_elt Prims.list -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = fun s -> fun t -> FStar_Syntax_Subst.subst s t -let (subst_comp : - FStar_Syntax_Syntax.subst_elt Prims.list -> - FStar_Syntax_Syntax.comp -> FStar_Syntax_Syntax.comp) - = fun s -> fun c -> FStar_Syntax_Subst.subst_comp s c -let (range_of_term : - FStar_Syntax_Syntax.term -> FStar_Compiler_Range_Type.range) = - fun t -> t.FStar_Syntax_Syntax.pos -let (range_of_sigelt : - FStar_Syntax_Syntax.sigelt -> FStar_Compiler_Range_Type.range) = - fun s -> s.FStar_Syntax_Syntax.sigrng \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Reflection_V2_Collect.ml b/ocaml/fstar-lib/generated/FStar_Reflection_V2_Collect.ml index bead6d8c285..6c4b185d85c 100644 --- a/ocaml/fstar-lib/generated/FStar_Reflection_V2_Collect.ml +++ b/ocaml/fstar-lib/generated/FStar_Reflection_V2_Collect.ml @@ -1,57 +1,59 @@ open Prims let rec (inspect_ln_unascribe : - FStar_Reflection_Types.term -> FStar_Reflection_V2_Data.term_view) = + FStarC_Reflection_Types.term -> FStarC_Reflection_V2_Data.term_view) = fun t -> - match FStar_Reflection_V2_Builtins.inspect_ln t with - | FStar_Reflection_V2_Data.Tv_AscribedT (t', uu___, uu___1, uu___2) -> + match FStarC_Reflection_V2_Builtins.inspect_ln t with + | FStarC_Reflection_V2_Data.Tv_AscribedT (t', uu___, uu___1, uu___2) -> inspect_ln_unascribe t' - | FStar_Reflection_V2_Data.Tv_AscribedC (t', uu___, uu___1, uu___2) -> + | FStarC_Reflection_V2_Data.Tv_AscribedC (t', uu___, uu___1, uu___2) -> inspect_ln_unascribe t' | tv -> tv let rec (collect_app_ln' : - FStar_Reflection_V2_Data.argv Prims.list -> - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.term * FStar_Reflection_V2_Data.argv + FStarC_Reflection_V2_Data.argv Prims.list -> + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.term * FStarC_Reflection_V2_Data.argv Prims.list)) = fun args -> fun t -> match inspect_ln_unascribe t with - | FStar_Reflection_V2_Data.Tv_App (l, r) -> + | FStarC_Reflection_V2_Data.Tv_App (l, r) -> collect_app_ln' (r :: args) l | uu___ -> (t, args) let (collect_app_ln : - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.term * FStar_Reflection_V2_Data.argv Prims.list)) + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.term * FStarC_Reflection_V2_Data.argv + Prims.list)) = collect_app_ln' [] let rec (collect_arr' : - FStar_Reflection_Types.binder Prims.list -> - FStar_Reflection_Types.comp -> - (FStar_Reflection_Types.binder Prims.list * - FStar_Reflection_Types.comp)) + FStarC_Reflection_Types.binder Prims.list -> + FStarC_Reflection_Types.comp -> + (FStarC_Reflection_Types.binder Prims.list * + FStarC_Reflection_Types.comp)) = fun bs -> fun c -> - match FStar_Reflection_V2_Builtins.inspect_comp c with - | FStar_Reflection_V2_Data.C_Total t -> + match FStarC_Reflection_V2_Builtins.inspect_comp c with + | FStarC_Reflection_V2_Data.C_Total t -> (match inspect_ln_unascribe t with - | FStar_Reflection_V2_Data.Tv_Arrow (b, c1) -> + | FStarC_Reflection_V2_Data.Tv_Arrow (b, c1) -> collect_arr' (b :: bs) c1 | uu___ -> (bs, c)) | uu___ -> (bs, c) let (collect_arr_ln_bs : - FStar_Reflection_Types.typ -> - (FStar_Reflection_Types.binder Prims.list * FStar_Reflection_Types.comp)) + FStarC_Reflection_Types.typ -> + (FStarC_Reflection_Types.binder Prims.list * + FStarC_Reflection_Types.comp)) = fun t -> let uu___ = collect_arr' [] - (FStar_Reflection_V2_Builtins.pack_comp - (FStar_Reflection_V2_Data.C_Total t)) in + (FStarC_Reflection_V2_Builtins.pack_comp + (FStarC_Reflection_V2_Data.C_Total t)) in match uu___ with | (bs, c) -> ((FStar_List_Tot_Base.rev bs), c) let (collect_arr_ln : - FStar_Reflection_Types.typ -> - (FStar_Reflection_Types.typ Prims.list * FStar_Reflection_Types.comp)) + FStarC_Reflection_Types.typ -> + (FStarC_Reflection_Types.typ Prims.list * FStarC_Reflection_Types.comp)) = fun t -> let uu___ = collect_arr_ln_bs t in @@ -59,22 +61,23 @@ let (collect_arr_ln : | (bs, c) -> ((FStar_List_Tot_Base.map (fun b -> - (FStar_Reflection_V2_Builtins.inspect_binder b).FStar_Reflection_V2_Data.sort2) + (FStarC_Reflection_V2_Builtins.inspect_binder b).FStarC_Reflection_V2_Data.sort2) bs), c) let rec (collect_abs' : - FStar_Reflection_Types.binder Prims.list -> - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.binder Prims.list * - FStar_Reflection_Types.term)) + FStarC_Reflection_Types.binder Prims.list -> + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.binder Prims.list * + FStarC_Reflection_Types.term)) = fun bs -> fun t -> match inspect_ln_unascribe t with - | FStar_Reflection_V2_Data.Tv_Abs (b, t') -> collect_abs' (b :: bs) t' + | FStarC_Reflection_V2_Data.Tv_Abs (b, t') -> collect_abs' (b :: bs) t' | uu___ -> (bs, t) let (collect_abs_ln : - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.binder Prims.list * FStar_Reflection_Types.term)) + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.binder Prims.list * + FStarC_Reflection_Types.term)) = fun t -> let uu___ = collect_abs' [] t in diff --git a/ocaml/fstar-lib/generated/FStar_Reflection_V2_Compare.ml b/ocaml/fstar-lib/generated/FStar_Reflection_V2_Compare.ml index 891d58d2416..c0d77cc302c 100644 --- a/ocaml/fstar-lib/generated/FStar_Reflection_V2_Compare.ml +++ b/ocaml/fstar-lib/generated/FStar_Reflection_V2_Compare.ml @@ -1,7 +1,7 @@ open Prims let (compare_name : - FStar_Reflection_Types.name -> - FStar_Reflection_Types.name -> FStar_Order.order) + FStarC_Reflection_Types.name -> + FStarC_Reflection_Types.name -> FStar_Order.order) = fun n1 -> fun n2 -> @@ -9,327 +9,331 @@ let (compare_name : (fun s1 -> fun s2 -> FStar_Order.order_from_int - (FStar_Reflection_V2_Builtins.compare_string s1 s2)) + (FStarC_Reflection_V2_Builtins.compare_string s1 s2)) let _ = - FStar_Tactics_Native.register_plugin + FStarC_Tactics_Native.register_plugin "FStar.Reflection.V2.Compare.compare_name" (Prims.of_int (2)) (fun _psc -> fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Reflection.V2.Compare.compare_name" (fun _ -> - (FStar_Syntax_Embeddings.arrow_as_prim_step_2 - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_string) - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_string) FStar_Order.e_order - compare_name - (FStar_Ident.lid_of_str + (FStarC_Syntax_Embeddings.arrow_as_prim_step_2 + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_string) + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_string) + FStar_Order.e_order compare_name + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Compare.compare_name") cb us) args)) (fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Reflection.V2.Compare.compare_name" (fun _ -> - (FStar_TypeChecker_NBETerm.arrow_as_prim_step_2 - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_string) - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_string) - (FStar_TypeChecker_NBETerm.e_unsupported ()) compare_name - (FStar_Ident.lid_of_str + (FStarC_TypeChecker_NBETerm.arrow_as_prim_step_2 + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_string) + (FStarC_TypeChecker_NBETerm.e_list + FStarC_TypeChecker_NBETerm.e_string) + (FStarC_TypeChecker_NBETerm.e_unsupported ()) compare_name + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Compare.compare_name") cb us) args)) let (compare_fv : - FStar_Reflection_Types.fv -> FStar_Reflection_Types.fv -> FStar_Order.order) + FStarC_Reflection_Types.fv -> + FStarC_Reflection_Types.fv -> FStar_Order.order) = fun f1 -> fun f2 -> - compare_name (FStar_Reflection_V2_Builtins.inspect_fv f1) - (FStar_Reflection_V2_Builtins.inspect_fv f2) + compare_name (FStarC_Reflection_V2_Builtins.inspect_fv f1) + (FStarC_Reflection_V2_Builtins.inspect_fv f2) let _ = - FStar_Tactics_Native.register_plugin + FStarC_Tactics_Native.register_plugin "FStar.Reflection.V2.Compare.compare_fv" (Prims.of_int (2)) (fun _psc -> fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Reflection.V2.Compare.compare_fv" (fun _ -> - (FStar_Syntax_Embeddings.arrow_as_prim_step_2 - FStar_Reflection_V2_Embeddings.e_fv - FStar_Reflection_V2_Embeddings.e_fv FStar_Order.e_order + (FStarC_Syntax_Embeddings.arrow_as_prim_step_2 + FStarC_Reflection_V2_Embeddings.e_fv + FStarC_Reflection_V2_Embeddings.e_fv FStar_Order.e_order compare_fv - (FStar_Ident.lid_of_str + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Compare.compare_fv") cb us) args)) (fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Reflection.V2.Compare.compare_fv" (fun _ -> - (FStar_TypeChecker_NBETerm.arrow_as_prim_step_2 - FStar_Reflection_V2_NBEEmbeddings.e_fv - FStar_Reflection_V2_NBEEmbeddings.e_fv - (FStar_TypeChecker_NBETerm.e_unsupported ()) compare_fv - (FStar_Ident.lid_of_str + (FStarC_TypeChecker_NBETerm.arrow_as_prim_step_2 + FStarC_Reflection_V2_NBEEmbeddings.e_fv + FStarC_Reflection_V2_NBEEmbeddings.e_fv + (FStarC_TypeChecker_NBETerm.e_unsupported ()) compare_fv + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Compare.compare_fv") cb us) args)) let (compare_const : - FStar_Reflection_V2_Data.vconst -> - FStar_Reflection_V2_Data.vconst -> FStar_Order.order) + FStarC_Reflection_V2_Data.vconst -> + FStarC_Reflection_V2_Data.vconst -> FStar_Order.order) = fun c1 -> fun c2 -> match (c1, c2) with - | (FStar_Reflection_V2_Data.C_Unit, FStar_Reflection_V2_Data.C_Unit) -> - FStar_Order.Eq - | (FStar_Reflection_V2_Data.C_Int i, FStar_Reflection_V2_Data.C_Int j) - -> FStar_Order.order_from_int (i - j) - | (FStar_Reflection_V2_Data.C_True, FStar_Reflection_V2_Data.C_True) -> - FStar_Order.Eq - | (FStar_Reflection_V2_Data.C_False, FStar_Reflection_V2_Data.C_False) + | (FStarC_Reflection_V2_Data.C_Unit, FStarC_Reflection_V2_Data.C_Unit) -> FStar_Order.Eq - | (FStar_Reflection_V2_Data.C_String s1, - FStar_Reflection_V2_Data.C_String s2) -> - FStar_Order.order_from_int - (FStar_Reflection_V2_Builtins.compare_string s1 s2) - | (FStar_Reflection_V2_Data.C_Range r1, - FStar_Reflection_V2_Data.C_Range r2) -> FStar_Order.Eq - | (FStar_Reflection_V2_Data.C_Reify, FStar_Reflection_V2_Data.C_Reify) + | (FStarC_Reflection_V2_Data.C_Int i, FStarC_Reflection_V2_Data.C_Int + j) -> FStar_Order.order_from_int (i - j) + | (FStarC_Reflection_V2_Data.C_True, FStarC_Reflection_V2_Data.C_True) -> FStar_Order.Eq - | (FStar_Reflection_V2_Data.C_Reflect l1, - FStar_Reflection_V2_Data.C_Reflect l2) -> compare_name l1 l2 - | (FStar_Reflection_V2_Data.C_Real r1, FStar_Reflection_V2_Data.C_Real - r2) -> + | (FStarC_Reflection_V2_Data.C_False, + FStarC_Reflection_V2_Data.C_False) -> FStar_Order.Eq + | (FStarC_Reflection_V2_Data.C_String s1, + FStarC_Reflection_V2_Data.C_String s2) -> + FStar_Order.order_from_int + (FStarC_Reflection_V2_Builtins.compare_string s1 s2) + | (FStarC_Reflection_V2_Data.C_Range r1, + FStarC_Reflection_V2_Data.C_Range r2) -> FStar_Order.Eq + | (FStarC_Reflection_V2_Data.C_Reify, + FStarC_Reflection_V2_Data.C_Reify) -> FStar_Order.Eq + | (FStarC_Reflection_V2_Data.C_Reflect l1, + FStarC_Reflection_V2_Data.C_Reflect l2) -> compare_name l1 l2 + | (FStarC_Reflection_V2_Data.C_Real r1, + FStarC_Reflection_V2_Data.C_Real r2) -> FStar_Order.order_from_int - (FStar_Reflection_V2_Builtins.compare_string r1 r2) - | (FStar_Reflection_V2_Data.C_Unit, uu___) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.C_Unit) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.C_Int uu___, uu___1) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.C_Int uu___1) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.C_True, uu___) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.C_True) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.C_False, uu___) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.C_False) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.C_String uu___, uu___1) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.C_String uu___1) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.C_Range uu___, uu___1) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.C_Range uu___1) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.C_Reify, uu___) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.C_Reify) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.C_Reflect uu___, uu___1) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.C_Reflect uu___1) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.C_Real uu___, uu___1) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.C_Real uu___1) -> FStar_Order.Gt + (FStarC_Reflection_V2_Builtins.compare_string r1 r2) + | (FStarC_Reflection_V2_Data.C_Unit, uu___) -> FStar_Order.Lt + | (uu___, FStarC_Reflection_V2_Data.C_Unit) -> FStar_Order.Gt + | (FStarC_Reflection_V2_Data.C_Int uu___, uu___1) -> FStar_Order.Lt + | (uu___, FStarC_Reflection_V2_Data.C_Int uu___1) -> FStar_Order.Gt + | (FStarC_Reflection_V2_Data.C_True, uu___) -> FStar_Order.Lt + | (uu___, FStarC_Reflection_V2_Data.C_True) -> FStar_Order.Gt + | (FStarC_Reflection_V2_Data.C_False, uu___) -> FStar_Order.Lt + | (uu___, FStarC_Reflection_V2_Data.C_False) -> FStar_Order.Gt + | (FStarC_Reflection_V2_Data.C_String uu___, uu___1) -> FStar_Order.Lt + | (uu___, FStarC_Reflection_V2_Data.C_String uu___1) -> FStar_Order.Gt + | (FStarC_Reflection_V2_Data.C_Range uu___, uu___1) -> FStar_Order.Lt + | (uu___, FStarC_Reflection_V2_Data.C_Range uu___1) -> FStar_Order.Gt + | (FStarC_Reflection_V2_Data.C_Reify, uu___) -> FStar_Order.Lt + | (uu___, FStarC_Reflection_V2_Data.C_Reify) -> FStar_Order.Gt + | (FStarC_Reflection_V2_Data.C_Reflect uu___, uu___1) -> FStar_Order.Lt + | (uu___, FStarC_Reflection_V2_Data.C_Reflect uu___1) -> FStar_Order.Gt + | (FStarC_Reflection_V2_Data.C_Real uu___, uu___1) -> FStar_Order.Lt + | (uu___, FStarC_Reflection_V2_Data.C_Real uu___1) -> FStar_Order.Gt let _ = - FStar_Tactics_Native.register_plugin + FStarC_Tactics_Native.register_plugin "FStar.Reflection.V2.Compare.compare_const" (Prims.of_int (2)) (fun _psc -> fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Reflection.V2.Compare.compare_const" (fun _ -> - (FStar_Syntax_Embeddings.arrow_as_prim_step_2 - FStar_Reflection_V2_Embeddings.e_vconst - FStar_Reflection_V2_Embeddings.e_vconst + (FStarC_Syntax_Embeddings.arrow_as_prim_step_2 + FStarC_Reflection_V2_Embeddings.e_vconst + FStarC_Reflection_V2_Embeddings.e_vconst FStar_Order.e_order compare_const - (FStar_Ident.lid_of_str + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Compare.compare_const") cb us) args)) (fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Reflection.V2.Compare.compare_const" (fun _ -> - (FStar_TypeChecker_NBETerm.arrow_as_prim_step_2 - FStar_Reflection_V2_NBEEmbeddings.e_vconst - FStar_Reflection_V2_NBEEmbeddings.e_vconst - (FStar_TypeChecker_NBETerm.e_unsupported ()) compare_const - (FStar_Ident.lid_of_str + (FStarC_TypeChecker_NBETerm.arrow_as_prim_step_2 + FStarC_Reflection_V2_NBEEmbeddings.e_vconst + FStarC_Reflection_V2_NBEEmbeddings.e_vconst + (FStarC_TypeChecker_NBETerm.e_unsupported ()) + compare_const + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Compare.compare_const") cb us) args)) let (compare_ident : - FStar_Reflection_Types.ident -> - FStar_Reflection_Types.ident -> FStar_Order.order) + FStarC_Reflection_Types.ident -> + FStarC_Reflection_Types.ident -> FStar_Order.order) = fun i1 -> fun i2 -> - let uu___ = FStar_Reflection_V2_Builtins.inspect_ident i1 in + let uu___ = FStarC_Reflection_V2_Builtins.inspect_ident i1 in match uu___ with | (nm1, uu___1) -> - let uu___2 = FStar_Reflection_V2_Builtins.inspect_ident i2 in + let uu___2 = FStarC_Reflection_V2_Builtins.inspect_ident i2 in (match uu___2 with | (nm2, uu___3) -> FStar_Order.order_from_int - (FStar_Reflection_V2_Builtins.compare_string nm1 nm2)) + (FStarC_Reflection_V2_Builtins.compare_string nm1 nm2)) let _ = - FStar_Tactics_Native.register_plugin + FStarC_Tactics_Native.register_plugin "FStar.Reflection.V2.Compare.compare_ident" (Prims.of_int (2)) (fun _psc -> fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Reflection.V2.Compare.compare_ident" (fun _ -> - (FStar_Syntax_Embeddings.arrow_as_prim_step_2 - FStar_Reflection_V2_Embeddings.e_ident - FStar_Reflection_V2_Embeddings.e_ident + (FStarC_Syntax_Embeddings.arrow_as_prim_step_2 + FStarC_Reflection_V2_Embeddings.e_ident + FStarC_Reflection_V2_Embeddings.e_ident FStar_Order.e_order compare_ident - (FStar_Ident.lid_of_str + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Compare.compare_ident") cb us) args)) (fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Reflection.V2.Compare.compare_ident" (fun _ -> - (FStar_TypeChecker_NBETerm.arrow_as_prim_step_2 - FStar_Reflection_V2_NBEEmbeddings.e_ident - FStar_Reflection_V2_NBEEmbeddings.e_ident - (FStar_TypeChecker_NBETerm.e_unsupported ()) compare_ident - (FStar_Ident.lid_of_str + (FStarC_TypeChecker_NBETerm.arrow_as_prim_step_2 + FStarC_Reflection_V2_NBEEmbeddings.e_ident + FStarC_Reflection_V2_NBEEmbeddings.e_ident + (FStarC_TypeChecker_NBETerm.e_unsupported ()) + compare_ident + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Compare.compare_ident") cb us) args)) let rec (compare_universe : - FStar_Reflection_Types.universe -> - FStar_Reflection_Types.universe -> FStar_Order.order) + FStarC_Reflection_Types.universe -> + FStarC_Reflection_Types.universe -> FStar_Order.order) = fun u1 -> fun u2 -> - match ((FStar_Reflection_V2_Builtins.inspect_universe u1), - (FStar_Reflection_V2_Builtins.inspect_universe u2)) + match ((FStarC_Reflection_V2_Builtins.inspect_universe u1), + (FStarC_Reflection_V2_Builtins.inspect_universe u2)) with - | (FStar_Reflection_V2_Data.Uv_Zero, FStar_Reflection_V2_Data.Uv_Zero) - -> FStar_Order.Eq - | (FStar_Reflection_V2_Data.Uv_Succ u11, - FStar_Reflection_V2_Data.Uv_Succ u21) -> compare_universe u11 u21 - | (FStar_Reflection_V2_Data.Uv_Max us1, FStar_Reflection_V2_Data.Uv_Max - us2) -> + | (FStarC_Reflection_V2_Data.Uv_Zero, + FStarC_Reflection_V2_Data.Uv_Zero) -> FStar_Order.Eq + | (FStarC_Reflection_V2_Data.Uv_Succ u11, + FStarC_Reflection_V2_Data.Uv_Succ u21) -> compare_universe u11 u21 + | (FStarC_Reflection_V2_Data.Uv_Max us1, + FStarC_Reflection_V2_Data.Uv_Max us2) -> FStar_Order.compare_list us1 us2 (fun x -> fun y -> compare_universe x y) - | (FStar_Reflection_V2_Data.Uv_BVar n1, - FStar_Reflection_V2_Data.Uv_BVar n2) -> + | (FStarC_Reflection_V2_Data.Uv_BVar n1, + FStarC_Reflection_V2_Data.Uv_BVar n2) -> FStar_Order.compare_int n1 n2 - | (FStar_Reflection_V2_Data.Uv_Name i1, - FStar_Reflection_V2_Data.Uv_Name i2) -> compare_ident i1 i2 - | (FStar_Reflection_V2_Data.Uv_Unif u11, - FStar_Reflection_V2_Data.Uv_Unif u21) -> FStar_Order.Eq - | (FStar_Reflection_V2_Data.Uv_Unk, FStar_Reflection_V2_Data.Uv_Unk) -> - FStar_Order.Eq - | (FStar_Reflection_V2_Data.Uv_Zero, uu___) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.Uv_Zero) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.Uv_Succ uu___, uu___1) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.Uv_Succ uu___1) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.Uv_Max uu___, uu___1) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.Uv_Max uu___1) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.Uv_BVar uu___, uu___1) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.Uv_BVar uu___1) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.Uv_Name uu___, uu___1) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.Uv_Name uu___1) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.Uv_Unif uu___, uu___1) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.Uv_Unif uu___1) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.Uv_Unk, uu___) -> FStar_Order.Lt + | (FStarC_Reflection_V2_Data.Uv_Name i1, + FStarC_Reflection_V2_Data.Uv_Name i2) -> compare_ident i1 i2 + | (FStarC_Reflection_V2_Data.Uv_Unif u11, + FStarC_Reflection_V2_Data.Uv_Unif u21) -> FStar_Order.Eq + | (FStarC_Reflection_V2_Data.Uv_Unk, FStarC_Reflection_V2_Data.Uv_Unk) + -> FStar_Order.Eq + | (FStarC_Reflection_V2_Data.Uv_Zero, uu___) -> FStar_Order.Lt + | (uu___, FStarC_Reflection_V2_Data.Uv_Zero) -> FStar_Order.Gt + | (FStarC_Reflection_V2_Data.Uv_Succ uu___, uu___1) -> FStar_Order.Lt + | (uu___, FStarC_Reflection_V2_Data.Uv_Succ uu___1) -> FStar_Order.Gt + | (FStarC_Reflection_V2_Data.Uv_Max uu___, uu___1) -> FStar_Order.Lt + | (uu___, FStarC_Reflection_V2_Data.Uv_Max uu___1) -> FStar_Order.Gt + | (FStarC_Reflection_V2_Data.Uv_BVar uu___, uu___1) -> FStar_Order.Lt + | (uu___, FStarC_Reflection_V2_Data.Uv_BVar uu___1) -> FStar_Order.Gt + | (FStarC_Reflection_V2_Data.Uv_Name uu___, uu___1) -> FStar_Order.Lt + | (uu___, FStarC_Reflection_V2_Data.Uv_Name uu___1) -> FStar_Order.Gt + | (FStarC_Reflection_V2_Data.Uv_Unif uu___, uu___1) -> FStar_Order.Lt + | (uu___, FStarC_Reflection_V2_Data.Uv_Unif uu___1) -> FStar_Order.Gt + | (FStarC_Reflection_V2_Data.Uv_Unk, uu___) -> FStar_Order.Lt let _ = - FStar_Tactics_Native.register_plugin + FStarC_Tactics_Native.register_plugin "FStar.Reflection.V2.Compare.compare_universe" (Prims.of_int (2)) (fun _psc -> fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Reflection.V2.Compare.compare_universe" (fun _ -> - (FStar_Syntax_Embeddings.arrow_as_prim_step_2 - FStar_Reflection_V2_Embeddings.e_universe - FStar_Reflection_V2_Embeddings.e_universe + (FStarC_Syntax_Embeddings.arrow_as_prim_step_2 + FStarC_Reflection_V2_Embeddings.e_universe + FStarC_Reflection_V2_Embeddings.e_universe FStar_Order.e_order compare_universe - (FStar_Ident.lid_of_str + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Compare.compare_universe") cb us) args)) (fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Reflection.V2.Compare.compare_universe" (fun _ -> - (FStar_TypeChecker_NBETerm.arrow_as_prim_step_2 - FStar_Reflection_V2_NBEEmbeddings.e_universe - FStar_Reflection_V2_NBEEmbeddings.e_universe - (FStar_TypeChecker_NBETerm.e_unsupported ()) + (FStarC_TypeChecker_NBETerm.arrow_as_prim_step_2 + FStarC_Reflection_V2_NBEEmbeddings.e_universe + FStarC_Reflection_V2_NBEEmbeddings.e_universe + (FStarC_TypeChecker_NBETerm.e_unsupported ()) compare_universe - (FStar_Ident.lid_of_str + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Compare.compare_universe") cb us) args)) let (compare_universes : - FStar_Reflection_V2_Data.universes -> - FStar_Reflection_V2_Data.universes -> FStar_Order.order) + FStarC_Reflection_V2_Data.universes -> + FStarC_Reflection_V2_Data.universes -> FStar_Order.order) = fun us1 -> fun us2 -> FStar_Order.compare_list us1 us2 compare_universe let _ = - FStar_Tactics_Native.register_plugin + FStarC_Tactics_Native.register_plugin "FStar.Reflection.V2.Compare.compare_universes" (Prims.of_int (2)) (fun _psc -> fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Reflection.V2.Compare.compare_universes" (fun _ -> - (FStar_Syntax_Embeddings.arrow_as_prim_step_2 - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_universe) - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_universe) + (FStarC_Syntax_Embeddings.arrow_as_prim_step_2 + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_universe) + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_universe) FStar_Order.e_order compare_universes - (FStar_Ident.lid_of_str + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Compare.compare_universes") cb us) args)) (fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Reflection.V2.Compare.compare_universes" (fun _ -> - (FStar_TypeChecker_NBETerm.arrow_as_prim_step_2 - (FStar_TypeChecker_NBETerm.e_list - FStar_Reflection_V2_NBEEmbeddings.e_universe) - (FStar_TypeChecker_NBETerm.e_list - FStar_Reflection_V2_NBEEmbeddings.e_universe) - (FStar_TypeChecker_NBETerm.e_unsupported ()) + (FStarC_TypeChecker_NBETerm.arrow_as_prim_step_2 + (FStarC_TypeChecker_NBETerm.e_list + FStarC_Reflection_V2_NBEEmbeddings.e_universe) + (FStarC_TypeChecker_NBETerm.e_list + FStarC_Reflection_V2_NBEEmbeddings.e_universe) + (FStarC_TypeChecker_NBETerm.e_unsupported ()) compare_universes - (FStar_Ident.lid_of_str + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Compare.compare_universes") cb us) args)) let rec (__compare_term : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> FStar_Order.order) + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> FStar_Order.order) = fun s -> fun t -> - match ((FStar_Reflection_V2_Builtins.inspect_ln s), - (FStar_Reflection_V2_Builtins.inspect_ln t)) + match ((FStarC_Reflection_V2_Builtins.inspect_ln s), + (FStarC_Reflection_V2_Builtins.inspect_ln t)) with - | (FStar_Reflection_V2_Data.Tv_Var sv, FStar_Reflection_V2_Data.Tv_Var - tv) -> FStar_Reflection_V2_Derived.compare_namedv sv tv - | (FStar_Reflection_V2_Data.Tv_BVar sv, - FStar_Reflection_V2_Data.Tv_BVar tv) -> + | (FStarC_Reflection_V2_Data.Tv_Var sv, + FStarC_Reflection_V2_Data.Tv_Var tv) -> + FStar_Reflection_V2_Derived.compare_namedv sv tv + | (FStarC_Reflection_V2_Data.Tv_BVar sv, + FStarC_Reflection_V2_Data.Tv_BVar tv) -> FStar_Reflection_V2_Derived.compare_bv sv tv - | (FStar_Reflection_V2_Data.Tv_FVar sv, - FStar_Reflection_V2_Data.Tv_FVar tv) -> compare_fv sv tv - | (FStar_Reflection_V2_Data.Tv_UInst (sv, sus), - FStar_Reflection_V2_Data.Tv_UInst (tv, tus)) -> + | (FStarC_Reflection_V2_Data.Tv_FVar sv, + FStarC_Reflection_V2_Data.Tv_FVar tv) -> compare_fv sv tv + | (FStarC_Reflection_V2_Data.Tv_UInst (sv, sus), + FStarC_Reflection_V2_Data.Tv_UInst (tv, tus)) -> FStar_Order.lex (compare_fv sv tv) (fun uu___ -> compare_universes sus tus) - | (FStar_Reflection_V2_Data.Tv_App (uu___, uu___1), - FStar_Reflection_V2_Data.Tv_App (uu___2, uu___3)) -> + | (FStarC_Reflection_V2_Data.Tv_App (uu___, uu___1), + FStarC_Reflection_V2_Data.Tv_App (uu___2, uu___3)) -> let uu___4 = FStar_Reflection_V2_Derived_Lemmas.collect_app_ref s in (match uu___4 with | (h1, aa1) -> @@ -339,36 +343,36 @@ let rec (__compare_term : | (h2, aa2) -> FStar_Order.lex (__compare_term h1 h2) (fun uu___6 -> compare_argv_list () () aa1 aa2))) - | (FStar_Reflection_V2_Data.Tv_Abs (b1, e1), - FStar_Reflection_V2_Data.Tv_Abs (b2, e2)) -> + | (FStarC_Reflection_V2_Data.Tv_Abs (b1, e1), + FStarC_Reflection_V2_Data.Tv_Abs (b2, e2)) -> FStar_Order.lex (__compare_binder b1 b2) (fun uu___ -> __compare_term e1 e2) - | (FStar_Reflection_V2_Data.Tv_Refine (b1, e1), - FStar_Reflection_V2_Data.Tv_Refine (b2, e2)) -> + | (FStarC_Reflection_V2_Data.Tv_Refine (b1, e1), + FStarC_Reflection_V2_Data.Tv_Refine (b2, e2)) -> FStar_Order.lex (__compare_binder b1 b2) (fun uu___ -> __compare_term e1 e2) - | (FStar_Reflection_V2_Data.Tv_Arrow (b1, e1), - FStar_Reflection_V2_Data.Tv_Arrow (b2, e2)) -> + | (FStarC_Reflection_V2_Data.Tv_Arrow (b1, e1), + FStarC_Reflection_V2_Data.Tv_Arrow (b2, e2)) -> FStar_Order.lex (__compare_binder b1 b2) (fun uu___ -> __compare_comp e1 e2) - | (FStar_Reflection_V2_Data.Tv_Type su, - FStar_Reflection_V2_Data.Tv_Type tu) -> compare_universe su tu - | (FStar_Reflection_V2_Data.Tv_Const c1, - FStar_Reflection_V2_Data.Tv_Const c2) -> compare_const c1 c2 - | (FStar_Reflection_V2_Data.Tv_Uvar (u1, uu___), - FStar_Reflection_V2_Data.Tv_Uvar (u2, uu___1)) -> + | (FStarC_Reflection_V2_Data.Tv_Type su, + FStarC_Reflection_V2_Data.Tv_Type tu) -> compare_universe su tu + | (FStarC_Reflection_V2_Data.Tv_Const c1, + FStarC_Reflection_V2_Data.Tv_Const c2) -> compare_const c1 c2 + | (FStarC_Reflection_V2_Data.Tv_Uvar (u1, uu___), + FStarC_Reflection_V2_Data.Tv_Uvar (u2, uu___1)) -> FStar_Order.compare_int u1 u2 - | (FStar_Reflection_V2_Data.Tv_Let (_r1, _attrs1, b1, t1, t1'), - FStar_Reflection_V2_Data.Tv_Let (_r2, _attrs2, b2, t2, t2')) -> + | (FStarC_Reflection_V2_Data.Tv_Let (_r1, _attrs1, b1, t1, t1'), + FStarC_Reflection_V2_Data.Tv_Let (_r2, _attrs2, b2, t2, t2')) -> FStar_Order.lex (__compare_binder b1 b2) (fun uu___ -> FStar_Order.lex (__compare_term t1 t2) (fun uu___1 -> __compare_term t1' t2')) - | (FStar_Reflection_V2_Data.Tv_Match (uu___, uu___1, uu___2), - FStar_Reflection_V2_Data.Tv_Match (uu___3, uu___4, uu___5)) -> + | (FStarC_Reflection_V2_Data.Tv_Match (uu___, uu___1, uu___2), + FStarC_Reflection_V2_Data.Tv_Match (uu___3, uu___4, uu___5)) -> FStar_Order.Eq - | (FStar_Reflection_V2_Data.Tv_AscribedT (e1, t1, tac1, uu___), - FStar_Reflection_V2_Data.Tv_AscribedT (e2, t2, tac2, uu___1)) -> + | (FStarC_Reflection_V2_Data.Tv_AscribedT (e1, t1, tac1, uu___), + FStarC_Reflection_V2_Data.Tv_AscribedT (e2, t2, tac2, uu___1)) -> FStar_Order.lex (__compare_term e1 e2) (fun uu___2 -> FStar_Order.lex (__compare_term t1 t2) @@ -383,8 +387,8 @@ let rec (__compare_term : | (FStar_Pervasives_Native.Some e11, FStar_Pervasives_Native.Some e21) -> __compare_term e11 e21)) - | (FStar_Reflection_V2_Data.Tv_AscribedC (e1, c1, tac1, uu___), - FStar_Reflection_V2_Data.Tv_AscribedC (e2, c2, tac2, uu___1)) -> + | (FStarC_Reflection_V2_Data.Tv_AscribedC (e1, c1, tac1, uu___), + FStarC_Reflection_V2_Data.Tv_AscribedC (e2, c2, tac2, uu___1)) -> FStar_Order.lex (__compare_term e1 e2) (fun uu___2 -> FStar_Order.lex (__compare_comp c1 c2) @@ -399,67 +403,67 @@ let rec (__compare_term : | (FStar_Pervasives_Native.Some e11, FStar_Pervasives_Native.Some e21) -> __compare_term e11 e21)) - | (FStar_Reflection_V2_Data.Tv_Unknown, - FStar_Reflection_V2_Data.Tv_Unknown) -> FStar_Order.Eq - | (FStar_Reflection_V2_Data.Tv_Unsupp, - FStar_Reflection_V2_Data.Tv_Unsupp) -> FStar_Order.Eq - | (FStar_Reflection_V2_Data.Tv_Var uu___, uu___1) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.Tv_Var uu___1) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.Tv_BVar uu___, uu___1) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.Tv_BVar uu___1) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.Tv_FVar uu___, uu___1) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.Tv_FVar uu___1) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.Tv_UInst (uu___, uu___1), uu___2) -> + | (FStarC_Reflection_V2_Data.Tv_Unknown, + FStarC_Reflection_V2_Data.Tv_Unknown) -> FStar_Order.Eq + | (FStarC_Reflection_V2_Data.Tv_Unsupp, + FStarC_Reflection_V2_Data.Tv_Unsupp) -> FStar_Order.Eq + | (FStarC_Reflection_V2_Data.Tv_Var uu___, uu___1) -> FStar_Order.Lt + | (uu___, FStarC_Reflection_V2_Data.Tv_Var uu___1) -> FStar_Order.Gt + | (FStarC_Reflection_V2_Data.Tv_BVar uu___, uu___1) -> FStar_Order.Lt + | (uu___, FStarC_Reflection_V2_Data.Tv_BVar uu___1) -> FStar_Order.Gt + | (FStarC_Reflection_V2_Data.Tv_FVar uu___, uu___1) -> FStar_Order.Lt + | (uu___, FStarC_Reflection_V2_Data.Tv_FVar uu___1) -> FStar_Order.Gt + | (FStarC_Reflection_V2_Data.Tv_UInst (uu___, uu___1), uu___2) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.Tv_UInst (uu___1, uu___2)) -> + | (uu___, FStarC_Reflection_V2_Data.Tv_UInst (uu___1, uu___2)) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.Tv_App (uu___, uu___1), uu___2) -> + | (FStarC_Reflection_V2_Data.Tv_App (uu___, uu___1), uu___2) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.Tv_App (uu___1, uu___2)) -> + | (uu___, FStarC_Reflection_V2_Data.Tv_App (uu___1, uu___2)) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.Tv_Abs (uu___, uu___1), uu___2) -> + | (FStarC_Reflection_V2_Data.Tv_Abs (uu___, uu___1), uu___2) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.Tv_Abs (uu___1, uu___2)) -> + | (uu___, FStarC_Reflection_V2_Data.Tv_Abs (uu___1, uu___2)) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.Tv_Arrow (uu___, uu___1), uu___2) -> + | (FStarC_Reflection_V2_Data.Tv_Arrow (uu___, uu___1), uu___2) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.Tv_Arrow (uu___1, uu___2)) -> + | (uu___, FStarC_Reflection_V2_Data.Tv_Arrow (uu___1, uu___2)) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.Tv_Type uu___, uu___1) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.Tv_Type uu___1) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.Tv_Refine (uu___, uu___1), uu___2) -> + | (FStarC_Reflection_V2_Data.Tv_Type uu___, uu___1) -> FStar_Order.Lt + | (uu___, FStarC_Reflection_V2_Data.Tv_Type uu___1) -> FStar_Order.Gt + | (FStarC_Reflection_V2_Data.Tv_Refine (uu___, uu___1), uu___2) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.Tv_Refine (uu___1, uu___2)) -> + | (uu___, FStarC_Reflection_V2_Data.Tv_Refine (uu___1, uu___2)) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.Tv_Const uu___, uu___1) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.Tv_Const uu___1) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.Tv_Uvar (uu___, uu___1), uu___2) -> + | (FStarC_Reflection_V2_Data.Tv_Const uu___, uu___1) -> FStar_Order.Lt + | (uu___, FStarC_Reflection_V2_Data.Tv_Const uu___1) -> FStar_Order.Gt + | (FStarC_Reflection_V2_Data.Tv_Uvar (uu___, uu___1), uu___2) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.Tv_Uvar (uu___1, uu___2)) -> + | (uu___, FStarC_Reflection_V2_Data.Tv_Uvar (uu___1, uu___2)) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.Tv_Let + | (FStarC_Reflection_V2_Data.Tv_Let (uu___, uu___1, uu___2, uu___3, uu___4), uu___5) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.Tv_Let + | (uu___, FStarC_Reflection_V2_Data.Tv_Let (uu___1, uu___2, uu___3, uu___4, uu___5)) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.Tv_Match (uu___, uu___1, uu___2), uu___3) + | (FStarC_Reflection_V2_Data.Tv_Match (uu___, uu___1, uu___2), uu___3) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.Tv_Match (uu___1, uu___2, uu___3)) + | (uu___, FStarC_Reflection_V2_Data.Tv_Match (uu___1, uu___2, uu___3)) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.Tv_AscribedT + | (FStarC_Reflection_V2_Data.Tv_AscribedT (uu___, uu___1, uu___2, uu___3), uu___4) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.Tv_AscribedT + | (uu___, FStarC_Reflection_V2_Data.Tv_AscribedT (uu___1, uu___2, uu___3, uu___4)) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.Tv_AscribedC + | (FStarC_Reflection_V2_Data.Tv_AscribedC (uu___, uu___1, uu___2, uu___3), uu___4) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.Tv_AscribedC + | (uu___, FStarC_Reflection_V2_Data.Tv_AscribedC (uu___1, uu___2, uu___3, uu___4)) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.Tv_Unknown, uu___) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.Tv_Unknown) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.Tv_Unsupp, uu___) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.Tv_Unsupp) -> FStar_Order.Gt + | (FStarC_Reflection_V2_Data.Tv_Unknown, uu___) -> FStar_Order.Lt + | (uu___, FStarC_Reflection_V2_Data.Tv_Unknown) -> FStar_Order.Gt + | (FStarC_Reflection_V2_Data.Tv_Unsupp, uu___) -> FStar_Order.Lt + | (uu___, FStarC_Reflection_V2_Data.Tv_Unsupp) -> FStar_Order.Gt and (__compare_term_list : - FStar_Reflection_Types.term Prims.list -> - FStar_Reflection_Types.term Prims.list -> FStar_Order.order) + FStarC_Reflection_Types.term Prims.list -> + FStarC_Reflection_Types.term Prims.list -> FStar_Order.order) = fun l1 -> fun l2 -> @@ -473,8 +477,8 @@ and (__compare_term_list : and (compare_argv : unit -> unit -> - FStar_Reflection_V2_Data.argv -> - FStar_Reflection_V2_Data.argv -> FStar_Order.order) + FStarC_Reflection_V2_Data.argv -> + FStarC_Reflection_V2_Data.argv -> FStar_Order.order) = fun b1 -> fun b2 -> @@ -487,16 +491,18 @@ and (compare_argv : (match uu___1 with | (t2, q2) -> (match (q1, q2) with - | (FStar_Reflection_V2_Data.Q_Implicit, - FStar_Reflection_V2_Data.Q_Explicit) -> FStar_Order.Lt - | (FStar_Reflection_V2_Data.Q_Explicit, - FStar_Reflection_V2_Data.Q_Implicit) -> FStar_Order.Gt + | (FStarC_Reflection_V2_Data.Q_Implicit, + FStarC_Reflection_V2_Data.Q_Explicit) -> + FStar_Order.Lt + | (FStarC_Reflection_V2_Data.Q_Explicit, + FStarC_Reflection_V2_Data.Q_Implicit) -> + FStar_Order.Gt | (uu___2, uu___3) -> __compare_term t1 t2)) and (compare_argv_list : unit -> unit -> - FStar_Reflection_V2_Data.argv Prims.list -> - FStar_Reflection_V2_Data.argv Prims.list -> FStar_Order.order) + FStarC_Reflection_V2_Data.argv Prims.list -> + FStarC_Reflection_V2_Data.argv Prims.list -> FStar_Order.order) = fun b1 -> fun b2 -> @@ -510,150 +516,151 @@ and (compare_argv_list : FStar_Order.lex (compare_argv () () hd1 hd2) (fun uu___ -> compare_argv_list () () tl1 tl2) and (__compare_comp : - FStar_Reflection_Types.comp -> - FStar_Reflection_Types.comp -> FStar_Order.order) + FStarC_Reflection_Types.comp -> + FStarC_Reflection_Types.comp -> FStar_Order.order) = fun c1 -> fun c2 -> - let cv1 = FStar_Reflection_V2_Builtins.inspect_comp c1 in - let cv2 = FStar_Reflection_V2_Builtins.inspect_comp c2 in + let cv1 = FStarC_Reflection_V2_Builtins.inspect_comp c1 in + let cv2 = FStarC_Reflection_V2_Builtins.inspect_comp c2 in match (cv1, cv2) with - | (FStar_Reflection_V2_Data.C_Total t1, - FStar_Reflection_V2_Data.C_Total t2) -> __compare_term t1 t2 - | (FStar_Reflection_V2_Data.C_GTotal t1, - FStar_Reflection_V2_Data.C_GTotal t2) -> __compare_term t1 t2 - | (FStar_Reflection_V2_Data.C_Lemma (p1, q1, s1), - FStar_Reflection_V2_Data.C_Lemma (p2, q2, s2)) -> + | (FStarC_Reflection_V2_Data.C_Total t1, + FStarC_Reflection_V2_Data.C_Total t2) -> __compare_term t1 t2 + | (FStarC_Reflection_V2_Data.C_GTotal t1, + FStarC_Reflection_V2_Data.C_GTotal t2) -> __compare_term t1 t2 + | (FStarC_Reflection_V2_Data.C_Lemma (p1, q1, s1), + FStarC_Reflection_V2_Data.C_Lemma (p2, q2, s2)) -> FStar_Order.lex (__compare_term p1 p2) (fun uu___ -> FStar_Order.lex (__compare_term q1 q2) (fun uu___1 -> __compare_term s1 s2)) - | (FStar_Reflection_V2_Data.C_Eff (us1, eff1, res1, args1, _decrs1), - FStar_Reflection_V2_Data.C_Eff (us2, eff2, res2, args2, _decrs2)) -> + | (FStarC_Reflection_V2_Data.C_Eff (us1, eff1, res1, args1, _decrs1), + FStarC_Reflection_V2_Data.C_Eff (us2, eff2, res2, args2, _decrs2)) + -> FStar_Order.lex (compare_universes us1 us2) (fun uu___ -> FStar_Order.lex (compare_name eff1 eff2) (fun uu___1 -> __compare_term res1 res2)) - | (FStar_Reflection_V2_Data.C_Total uu___, uu___1) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.C_Total uu___1) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.C_GTotal uu___, uu___1) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.C_GTotal uu___1) -> FStar_Order.Gt - | (FStar_Reflection_V2_Data.C_Lemma (uu___, uu___1, uu___2), uu___3) -> - FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.C_Lemma (uu___1, uu___2, uu___3)) -> - FStar_Order.Gt - | (FStar_Reflection_V2_Data.C_Eff + | (FStarC_Reflection_V2_Data.C_Total uu___, uu___1) -> FStar_Order.Lt + | (uu___, FStarC_Reflection_V2_Data.C_Total uu___1) -> FStar_Order.Gt + | (FStarC_Reflection_V2_Data.C_GTotal uu___, uu___1) -> FStar_Order.Lt + | (uu___, FStarC_Reflection_V2_Data.C_GTotal uu___1) -> FStar_Order.Gt + | (FStarC_Reflection_V2_Data.C_Lemma (uu___, uu___1, uu___2), uu___3) + -> FStar_Order.Lt + | (uu___, FStarC_Reflection_V2_Data.C_Lemma (uu___1, uu___2, uu___3)) + -> FStar_Order.Gt + | (FStarC_Reflection_V2_Data.C_Eff (uu___, uu___1, uu___2, uu___3, uu___4), uu___5) -> FStar_Order.Lt - | (uu___, FStar_Reflection_V2_Data.C_Eff + | (uu___, FStarC_Reflection_V2_Data.C_Eff (uu___1, uu___2, uu___3, uu___4, uu___5)) -> FStar_Order.Gt and (__compare_binder : - FStar_Reflection_Types.binder -> - FStar_Reflection_Types.binder -> FStar_Order.order) + FStarC_Reflection_Types.binder -> + FStarC_Reflection_Types.binder -> FStar_Order.order) = fun b1 -> fun b2 -> - let bview1 = FStar_Reflection_V2_Builtins.inspect_binder b1 in - let bview2 = FStar_Reflection_V2_Builtins.inspect_binder b2 in - __compare_term bview1.FStar_Reflection_V2_Data.sort2 - bview2.FStar_Reflection_V2_Data.sort2 + let bview1 = FStarC_Reflection_V2_Builtins.inspect_binder b1 in + let bview2 = FStarC_Reflection_V2_Builtins.inspect_binder b2 in + __compare_term bview1.FStarC_Reflection_V2_Data.sort2 + bview2.FStarC_Reflection_V2_Data.sort2 let (compare_term : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> FStar_Order.order) + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> FStar_Order.order) = __compare_term let _ = - FStar_Tactics_Native.register_plugin + FStarC_Tactics_Native.register_plugin "FStar.Reflection.V2.Compare.compare_term" (Prims.of_int (2)) (fun _psc -> fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Reflection.V2.Compare.compare_term" (fun _ -> - (FStar_Syntax_Embeddings.arrow_as_prim_step_2 - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_term + (FStarC_Syntax_Embeddings.arrow_as_prim_step_2 + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_term FStar_Order.e_order compare_term - (FStar_Ident.lid_of_str + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Compare.compare_term") cb us) args)) (fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Reflection.V2.Compare.compare_term" (fun _ -> - (FStar_TypeChecker_NBETerm.arrow_as_prim_step_2 - FStar_Reflection_V2_NBEEmbeddings.e_term - FStar_Reflection_V2_NBEEmbeddings.e_term - (FStar_TypeChecker_NBETerm.e_unsupported ()) compare_term - (FStar_Ident.lid_of_str + (FStarC_TypeChecker_NBETerm.arrow_as_prim_step_2 + FStarC_Reflection_V2_NBEEmbeddings.e_term + FStarC_Reflection_V2_NBEEmbeddings.e_term + (FStarC_TypeChecker_NBETerm.e_unsupported ()) compare_term + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Compare.compare_term") cb us) args)) let (compare_comp : - FStar_Reflection_Types.comp -> - FStar_Reflection_Types.comp -> FStar_Order.order) + FStarC_Reflection_Types.comp -> + FStarC_Reflection_Types.comp -> FStar_Order.order) = __compare_comp let _ = - FStar_Tactics_Native.register_plugin + FStarC_Tactics_Native.register_plugin "FStar.Reflection.V2.Compare.compare_comp" (Prims.of_int (2)) (fun _psc -> fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Reflection.V2.Compare.compare_comp" (fun _ -> - (FStar_Syntax_Embeddings.arrow_as_prim_step_2 - FStar_Reflection_V2_Embeddings.e_comp - FStar_Reflection_V2_Embeddings.e_comp + (FStarC_Syntax_Embeddings.arrow_as_prim_step_2 + FStarC_Reflection_V2_Embeddings.e_comp + FStarC_Reflection_V2_Embeddings.e_comp FStar_Order.e_order compare_comp - (FStar_Ident.lid_of_str + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Compare.compare_comp") cb us) args)) (fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Reflection.V2.Compare.compare_comp" (fun _ -> - (FStar_TypeChecker_NBETerm.arrow_as_prim_step_2 - FStar_Reflection_V2_NBEEmbeddings.e_comp - FStar_Reflection_V2_NBEEmbeddings.e_comp - (FStar_TypeChecker_NBETerm.e_unsupported ()) compare_comp - (FStar_Ident.lid_of_str + (FStarC_TypeChecker_NBETerm.arrow_as_prim_step_2 + FStarC_Reflection_V2_NBEEmbeddings.e_comp + FStarC_Reflection_V2_NBEEmbeddings.e_comp + (FStarC_TypeChecker_NBETerm.e_unsupported ()) compare_comp + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Compare.compare_comp") cb us) args)) let (compare_binder : - FStar_Reflection_Types.binder -> - FStar_Reflection_Types.binder -> FStar_Order.order) + FStarC_Reflection_Types.binder -> + FStarC_Reflection_Types.binder -> FStar_Order.order) = __compare_binder let _ = - FStar_Tactics_Native.register_plugin + FStarC_Tactics_Native.register_plugin "FStar.Reflection.V2.Compare.compare_binder" (Prims.of_int (2)) (fun _psc -> fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Reflection.V2.Compare.compare_binder" (fun _ -> - (FStar_Syntax_Embeddings.arrow_as_prim_step_2 - FStar_Reflection_V2_Embeddings.e_binder - FStar_Reflection_V2_Embeddings.e_binder + (FStarC_Syntax_Embeddings.arrow_as_prim_step_2 + FStarC_Reflection_V2_Embeddings.e_binder + FStarC_Reflection_V2_Embeddings.e_binder FStar_Order.e_order compare_binder - (FStar_Ident.lid_of_str + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Compare.compare_binder") cb us) args)) (fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Reflection.V2.Compare.compare_binder" (fun _ -> - (FStar_TypeChecker_NBETerm.arrow_as_prim_step_2 - FStar_Reflection_V2_NBEEmbeddings.e_binder - FStar_Reflection_V2_NBEEmbeddings.e_binder - (FStar_TypeChecker_NBETerm.e_unsupported ()) + (FStarC_TypeChecker_NBETerm.arrow_as_prim_step_2 + FStarC_Reflection_V2_NBEEmbeddings.e_binder + FStarC_Reflection_V2_NBEEmbeddings.e_binder + (FStarC_TypeChecker_NBETerm.e_unsupported ()) compare_binder - (FStar_Ident.lid_of_str + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Compare.compare_binder") cb us) args)) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Reflection_V2_Constants.ml b/ocaml/fstar-lib/generated/FStar_Reflection_V2_Constants.ml deleted file mode 100644 index 5943b4b7ae7..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Reflection_V2_Constants.ml +++ /dev/null @@ -1,509 +0,0 @@ -open Prims -type refl_constant = - { - lid: FStar_Ident.lid ; - fv: FStar_Syntax_Syntax.fv ; - t: FStar_Syntax_Syntax.term } -let (__proj__Mkrefl_constant__item__lid : refl_constant -> FStar_Ident.lid) = - fun projectee -> match projectee with | { lid; fv; t;_} -> lid -let (__proj__Mkrefl_constant__item__fv : - refl_constant -> FStar_Syntax_Syntax.fv) = - fun projectee -> match projectee with | { lid; fv; t;_} -> fv -let (__proj__Mkrefl_constant__item__t : - refl_constant -> FStar_Syntax_Syntax.term) = - fun projectee -> match projectee with | { lid; fv; t;_} -> t -let (refl_constant_lid : refl_constant -> FStar_Ident.lid) = fun rc -> rc.lid -let (refl_constant_term : refl_constant -> FStar_Syntax_Syntax.term) = - fun rc -> rc.t -let (fstar_syntax_syntax_lid : Prims.string Prims.list -> FStar_Ident.lident) - = - fun s -> - FStar_Ident.lid_of_path - (FStar_Compiler_List.op_At ["FStar"; "Stubs"; "Syntax"; "Syntax"] s) - FStar_Compiler_Range_Type.dummyRange -let (fstar_refl_lid : Prims.string Prims.list -> FStar_Ident.lident) = - fun s -> - FStar_Ident.lid_of_path - (FStar_Compiler_List.op_At ["FStar"; "Stubs"; "Reflection"] s) - FStar_Compiler_Range_Type.dummyRange -let (fstar_refl_types_lid : Prims.string -> FStar_Ident.lident) = - fun s -> fstar_refl_lid ["Types"; s] -let (fstar_refl_builtins_lid : Prims.string -> FStar_Ident.lident) = - fun s -> fstar_refl_lid ["V2"; "Builtins"; s] -let (fstar_refl_data_lid : Prims.string -> FStar_Ident.lident) = - fun s -> fstar_refl_lid ["V2"; "Data"; s] -let (fstar_syntax_syntax_const : Prims.string Prims.list -> refl_constant) = - fun s -> - let lid = fstar_syntax_syntax_lid s in - let uu___ = - FStar_Syntax_Syntax.lid_as_fv lid - (FStar_Pervasives_Native.Some FStar_Syntax_Syntax.Data_ctor) in - let uu___1 = FStar_Syntax_Syntax.tdataconstr lid in - { lid; fv = uu___; t = uu___1 } -let (fstar_refl_data_const : Prims.string -> refl_constant) = - fun s -> - let lid = fstar_refl_data_lid s in - let uu___ = - FStar_Syntax_Syntax.lid_as_fv lid - (FStar_Pervasives_Native.Some FStar_Syntax_Syntax.Data_ctor) in - let uu___1 = FStar_Syntax_Syntax.tdataconstr lid in - { lid; fv = uu___; t = uu___1 } -let (mk_refl_types_lid_as_term : Prims.string -> FStar_Syntax_Syntax.term) = - fun s -> - let uu___ = fstar_refl_types_lid s in FStar_Syntax_Syntax.tconst uu___ -let (mk_refl_types_lid_as_fv : Prims.string -> FStar_Syntax_Syntax.fv) = - fun s -> - let uu___ = fstar_refl_types_lid s in FStar_Syntax_Syntax.fvconst uu___ -let (mk_refl_data_lid_as_term : Prims.string -> FStar_Syntax_Syntax.term) = - fun s -> - let uu___ = fstar_refl_data_lid s in FStar_Syntax_Syntax.tconst uu___ -let (mk_refl_data_lid_as_fv : Prims.string -> FStar_Syntax_Syntax.fv) = - fun s -> - let uu___ = fstar_refl_data_lid s in FStar_Syntax_Syntax.fvconst uu___ -let (mk_ss_lid_as_fv : Prims.string -> FStar_Syntax_Syntax.fv) = - fun s -> - let uu___ = fstar_syntax_syntax_lid [s] in - FStar_Syntax_Syntax.fvconst uu___ -let (mk_ss_lid_as_term : Prims.string -> FStar_Syntax_Syntax.term) = - fun s -> - let uu___ = fstar_syntax_syntax_lid [s] in - FStar_Syntax_Syntax.tconst uu___ -let (mk_inspect_pack_pair : Prims.string -> (refl_constant * refl_constant)) - = - fun s -> - let inspect_lid = fstar_refl_builtins_lid (Prims.strcat "inspect" s) in - let pack_lid = fstar_refl_builtins_lid (Prims.strcat "pack" s) in - let inspect_fv = - FStar_Syntax_Syntax.lid_as_fv inspect_lid FStar_Pervasives_Native.None in - let pack_fv = - FStar_Syntax_Syntax.lid_as_fv pack_lid FStar_Pervasives_Native.None in - let inspect = - let uu___ = FStar_Syntax_Syntax.fv_to_tm inspect_fv in - { lid = inspect_lid; fv = inspect_fv; t = uu___ } in - let pack = - let uu___ = FStar_Syntax_Syntax.fv_to_tm pack_fv in - { lid = pack_lid; fv = pack_fv; t = uu___ } in - (inspect, pack) -let (uu___0 : (refl_constant * refl_constant)) = mk_inspect_pack_pair "_ln" -let (fstar_refl_inspect_ln : refl_constant) = - match uu___0 with - | (fstar_refl_inspect_ln1, fstar_refl_pack_ln) -> fstar_refl_inspect_ln1 -let (fstar_refl_pack_ln : refl_constant) = - match uu___0 with - | (fstar_refl_inspect_ln1, fstar_refl_pack_ln1) -> fstar_refl_pack_ln1 -let (uu___1 : (refl_constant * refl_constant)) = mk_inspect_pack_pair "_fv" -let (fstar_refl_inspect_fv : refl_constant) = - match uu___1 with - | (fstar_refl_inspect_fv1, fstar_refl_pack_fv) -> fstar_refl_inspect_fv1 -let (fstar_refl_pack_fv : refl_constant) = - match uu___1 with - | (fstar_refl_inspect_fv1, fstar_refl_pack_fv1) -> fstar_refl_pack_fv1 -let (uu___2 : (refl_constant * refl_constant)) = mk_inspect_pack_pair "_bv" -let (fstar_refl_inspect_bv : refl_constant) = - match uu___2 with - | (fstar_refl_inspect_bv1, fstar_refl_pack_bv) -> fstar_refl_inspect_bv1 -let (fstar_refl_pack_bv : refl_constant) = - match uu___2 with - | (fstar_refl_inspect_bv1, fstar_refl_pack_bv1) -> fstar_refl_pack_bv1 -let (uu___3 : (refl_constant * refl_constant)) = - mk_inspect_pack_pair "_namedv" -let (fstar_refl_inspect_namedv : refl_constant) = - match uu___3 with - | (fstar_refl_inspect_namedv1, fstar_refl_pack_namedv) -> - fstar_refl_inspect_namedv1 -let (fstar_refl_pack_namedv : refl_constant) = - match uu___3 with - | (fstar_refl_inspect_namedv1, fstar_refl_pack_namedv1) -> - fstar_refl_pack_namedv1 -let (uu___4 : (refl_constant * refl_constant)) = - mk_inspect_pack_pair "_binder" -let (fstar_refl_inspect_binder : refl_constant) = - match uu___4 with - | (fstar_refl_inspect_binder1, fstar_refl_pack_binder) -> - fstar_refl_inspect_binder1 -let (fstar_refl_pack_binder : refl_constant) = - match uu___4 with - | (fstar_refl_inspect_binder1, fstar_refl_pack_binder1) -> - fstar_refl_pack_binder1 -let (uu___5 : (refl_constant * refl_constant)) = mk_inspect_pack_pair "_comp" -let (fstar_refl_inspect_comp : refl_constant) = - match uu___5 with - | (fstar_refl_inspect_comp1, fstar_refl_pack_comp) -> - fstar_refl_inspect_comp1 -let (fstar_refl_pack_comp : refl_constant) = - match uu___5 with - | (fstar_refl_inspect_comp1, fstar_refl_pack_comp1) -> - fstar_refl_pack_comp1 -let (uu___6 : (refl_constant * refl_constant)) = - mk_inspect_pack_pair "_sigelt" -let (fstar_refl_inspect_sigelt : refl_constant) = - match uu___6 with - | (fstar_refl_inspect_sigelt1, fstar_refl_pack_sigelt) -> - fstar_refl_inspect_sigelt1 -let (fstar_refl_pack_sigelt : refl_constant) = - match uu___6 with - | (fstar_refl_inspect_sigelt1, fstar_refl_pack_sigelt1) -> - fstar_refl_pack_sigelt1 -let (uu___7 : (refl_constant * refl_constant)) = mk_inspect_pack_pair "_lb" -let (fstar_refl_inspect_lb : refl_constant) = - match uu___7 with - | (fstar_refl_inspect_lb1, fstar_refl_pack_lb) -> fstar_refl_inspect_lb1 -let (fstar_refl_pack_lb : refl_constant) = - match uu___7 with - | (fstar_refl_inspect_lb1, fstar_refl_pack_lb1) -> fstar_refl_pack_lb1 -let (uu___8 : (refl_constant * refl_constant)) = - mk_inspect_pack_pair "_universe" -let (fstar_refl_inspect_universe : refl_constant) = - match uu___8 with - | (fstar_refl_inspect_universe1, fstar_refl_pack_universe) -> - fstar_refl_inspect_universe1 -let (fstar_refl_pack_universe : refl_constant) = - match uu___8 with - | (fstar_refl_inspect_universe1, fstar_refl_pack_universe1) -> - fstar_refl_pack_universe1 -let (fstar_refl_env : FStar_Syntax_Syntax.term) = - mk_refl_types_lid_as_term "env" -let (fstar_refl_env_fv : FStar_Syntax_Syntax.fv) = - mk_refl_types_lid_as_fv "env" -let (fstar_refl_namedv : FStar_Syntax_Syntax.term) = - mk_refl_types_lid_as_term "namedv" -let (fstar_refl_namedv_fv : FStar_Syntax_Syntax.fv) = - mk_refl_types_lid_as_fv "namedv" -let (fstar_refl_bv : FStar_Syntax_Syntax.term) = - mk_refl_types_lid_as_term "bv" -let (fstar_refl_bv_fv : FStar_Syntax_Syntax.fv) = - mk_refl_types_lid_as_fv "bv" -let (fstar_refl_fv : FStar_Syntax_Syntax.term) = - mk_refl_types_lid_as_term "fv" -let (fstar_refl_fv_fv : FStar_Syntax_Syntax.fv) = - mk_refl_types_lid_as_fv "fv" -let (fstar_refl_comp : FStar_Syntax_Syntax.term) = - mk_refl_types_lid_as_term "comp" -let (fstar_refl_comp_fv : FStar_Syntax_Syntax.fv) = - mk_refl_types_lid_as_fv "comp" -let (fstar_refl_binding : FStar_Syntax_Syntax.term) = - mk_refl_types_lid_as_term "binding" -let (fstar_refl_binding_fv : FStar_Syntax_Syntax.fv) = - mk_refl_types_lid_as_fv "binding" -let (fstar_refl_binder : FStar_Syntax_Syntax.term) = - mk_refl_types_lid_as_term "binder" -let (fstar_refl_binder_fv : FStar_Syntax_Syntax.fv) = - mk_refl_types_lid_as_fv "binder" -let (fstar_refl_sigelt : FStar_Syntax_Syntax.term) = - mk_refl_types_lid_as_term "sigelt" -let (fstar_refl_sigelt_fv : FStar_Syntax_Syntax.fv) = - mk_refl_types_lid_as_fv "sigelt" -let (fstar_refl_term : FStar_Syntax_Syntax.term) = - mk_refl_types_lid_as_term "term" -let (fstar_refl_term_fv : FStar_Syntax_Syntax.fv) = - mk_refl_types_lid_as_fv "term" -let (fstar_refl_letbinding : FStar_Syntax_Syntax.term) = - mk_refl_types_lid_as_term "letbinding" -let (fstar_refl_letbinding_fv : FStar_Syntax_Syntax.fv) = - mk_refl_types_lid_as_fv "letbinding" -let (fstar_refl_ident : FStar_Syntax_Syntax.term) = - mk_refl_types_lid_as_term "ident" -let (fstar_refl_ident_fv : FStar_Syntax_Syntax.fv) = - mk_refl_types_lid_as_fv "ident" -let (fstar_refl_univ_name : FStar_Syntax_Syntax.term) = - mk_refl_types_lid_as_term "univ_name" -let (fstar_refl_univ_name_fv : FStar_Syntax_Syntax.fv) = - mk_refl_types_lid_as_fv "univ_name" -let (fstar_refl_optionstate : FStar_Syntax_Syntax.term) = - mk_refl_types_lid_as_term "optionstate" -let (fstar_refl_optionstate_fv : FStar_Syntax_Syntax.fv) = - mk_refl_types_lid_as_fv "optionstate" -let (fstar_refl_universe : FStar_Syntax_Syntax.term) = - mk_refl_types_lid_as_term "universe" -let (fstar_refl_universe_fv : FStar_Syntax_Syntax.fv) = - mk_refl_types_lid_as_fv "universe" -let (fstar_refl_universe_uvar : FStar_Syntax_Syntax.term) = - mk_refl_types_lid_as_term "universe_uvar" -let (fstar_refl_universe_uvar_fv : FStar_Syntax_Syntax.fv) = - mk_refl_types_lid_as_fv "universe_uvar" -let (fstar_refl_ctx_uvar_and_subst : FStar_Syntax_Syntax.term) = - mk_refl_types_lid_as_term "ctx_uvar_and_subst" -let (fstar_refl_ctx_uvar_and_subst_fv : FStar_Syntax_Syntax.fv) = - mk_refl_types_lid_as_fv "ctx_uvar_and_subst" -let (fstar_refl_aqualv : FStar_Syntax_Syntax.term) = - mk_refl_data_lid_as_term "aqualv" -let (fstar_refl_aqualv_fv : FStar_Syntax_Syntax.fv) = - mk_refl_data_lid_as_fv "aqualv" -let (fstar_refl_comp_view : FStar_Syntax_Syntax.term) = - mk_refl_data_lid_as_term "comp_view" -let (fstar_refl_comp_view_fv : FStar_Syntax_Syntax.fv) = - mk_refl_data_lid_as_fv "comp_view" -let (fstar_refl_term_view : FStar_Syntax_Syntax.term) = - mk_refl_data_lid_as_term "term_view" -let (fstar_refl_term_view_fv : FStar_Syntax_Syntax.fv) = - mk_refl_data_lid_as_fv "term_view" -let (fstar_refl_pattern : FStar_Syntax_Syntax.term) = - mk_refl_data_lid_as_term "pattern" -let (fstar_refl_pattern_fv : FStar_Syntax_Syntax.fv) = - mk_refl_data_lid_as_fv "pattern" -let (fstar_refl_branch : FStar_Syntax_Syntax.term) = - mk_refl_data_lid_as_term "branch" -let (fstar_refl_branch_fv : FStar_Syntax_Syntax.fv) = - mk_refl_data_lid_as_fv "branch" -let (fstar_refl_namedv_view : FStar_Syntax_Syntax.term) = - mk_refl_data_lid_as_term "namedv_view" -let (fstar_refl_namedv_view_fv : FStar_Syntax_Syntax.fv) = - mk_refl_data_lid_as_fv "namedv_view" -let (fstar_refl_bv_view : FStar_Syntax_Syntax.term) = - mk_refl_data_lid_as_term "bv_view" -let (fstar_refl_bv_view_fv : FStar_Syntax_Syntax.fv) = - mk_refl_data_lid_as_fv "bv_view" -let (fstar_refl_binder_view : FStar_Syntax_Syntax.term) = - mk_refl_data_lid_as_term "binder_view" -let (fstar_refl_binder_view_fv : FStar_Syntax_Syntax.fv) = - mk_refl_data_lid_as_fv "binder_view" -let (fstar_refl_vconst : FStar_Syntax_Syntax.term) = - mk_refl_data_lid_as_term "vconst" -let (fstar_refl_vconst_fv : FStar_Syntax_Syntax.fv) = - mk_refl_data_lid_as_fv "vconst" -let (fstar_refl_lb_view : FStar_Syntax_Syntax.term) = - mk_refl_data_lid_as_term "lb_view" -let (fstar_refl_lb_view_fv : FStar_Syntax_Syntax.fv) = - mk_refl_data_lid_as_fv "lb_view" -let (fstar_refl_sigelt_view : FStar_Syntax_Syntax.term) = - mk_refl_data_lid_as_term "sigelt_view" -let (fstar_refl_sigelt_view_fv : FStar_Syntax_Syntax.fv) = - mk_refl_data_lid_as_fv "sigelt_view" -let (fstar_refl_qualifier : FStar_Syntax_Syntax.term) = - mk_refl_data_lid_as_term "qualifier" -let (fstar_refl_qualifier_fv : FStar_Syntax_Syntax.fv) = - mk_refl_data_lid_as_fv "qualifier" -let (fstar_refl_universe_view : FStar_Syntax_Syntax.term) = - mk_refl_data_lid_as_term "universe_view" -let (fstar_refl_universe_view_fv : FStar_Syntax_Syntax.fv) = - mk_refl_data_lid_as_fv "universe_view" -let (fstar_refl_subst_elt : FStar_Syntax_Syntax.term) = - mk_ss_lid_as_term "subst_elt" -let (fstar_refl_subst_elt_fv : FStar_Syntax_Syntax.fv) = - mk_ss_lid_as_fv "subst_elt" -let (fstar_refl_subst : FStar_Syntax_Syntax.term) = mk_ss_lid_as_term "subst" -let (fstar_refl_subst_fv : FStar_Syntax_Syntax.fv) = mk_ss_lid_as_fv "subst" -let (ref_Mk_namedv_view : refl_constant) = - let lid = fstar_refl_data_lid "Mknamedv_view" in - let attr = - let uu___ = - let uu___9 = fstar_refl_data_lid "namedv_view" in - let uu___10 = - let uu___11 = - FStar_Ident.mk_ident ("uniq", FStar_Compiler_Range_Type.dummyRange) in - let uu___12 = - let uu___13 = - FStar_Ident.mk_ident - ("sort", FStar_Compiler_Range_Type.dummyRange) in - let uu___14 = - let uu___15 = - FStar_Ident.mk_ident - ("ppname", FStar_Compiler_Range_Type.dummyRange) in - [uu___15] in - uu___13 :: uu___14 in - uu___11 :: uu___12 in - (uu___9, uu___10) in - FStar_Syntax_Syntax.Record_ctor uu___ in - let fv = - FStar_Syntax_Syntax.lid_as_fv lid (FStar_Pervasives_Native.Some attr) in - let uu___ = FStar_Syntax_Syntax.fv_to_tm fv in { lid; fv; t = uu___ } -let (ref_Mk_bv_view : refl_constant) = - let lid = fstar_refl_data_lid "Mkbv_view" in - let attr = - let uu___ = - let uu___9 = fstar_refl_data_lid "bv_view" in - let uu___10 = - let uu___11 = - FStar_Ident.mk_ident - ("index", FStar_Compiler_Range_Type.dummyRange) in - let uu___12 = - let uu___13 = - FStar_Ident.mk_ident - ("sort", FStar_Compiler_Range_Type.dummyRange) in - let uu___14 = - let uu___15 = - FStar_Ident.mk_ident - ("ppname", FStar_Compiler_Range_Type.dummyRange) in - [uu___15] in - uu___13 :: uu___14 in - uu___11 :: uu___12 in - (uu___9, uu___10) in - FStar_Syntax_Syntax.Record_ctor uu___ in - let fv = - FStar_Syntax_Syntax.lid_as_fv lid (FStar_Pervasives_Native.Some attr) in - let uu___ = FStar_Syntax_Syntax.fv_to_tm fv in { lid; fv; t = uu___ } -let (ref_Mk_binding : refl_constant) = - let lid = fstar_refl_data_lid "Mkbinding" in - let attr = - let uu___ = - let uu___9 = fstar_refl_data_lid "binding" in - let uu___10 = - let uu___11 = - FStar_Ident.mk_ident ("uniq", FStar_Compiler_Range_Type.dummyRange) in - let uu___12 = - let uu___13 = - FStar_Ident.mk_ident - ("sort", FStar_Compiler_Range_Type.dummyRange) in - let uu___14 = - let uu___15 = - FStar_Ident.mk_ident - ("ppname", FStar_Compiler_Range_Type.dummyRange) in - [uu___15] in - uu___13 :: uu___14 in - uu___11 :: uu___12 in - (uu___9, uu___10) in - FStar_Syntax_Syntax.Record_ctor uu___ in - let fv = - FStar_Syntax_Syntax.lid_as_fv lid (FStar_Pervasives_Native.Some attr) in - let uu___ = FStar_Syntax_Syntax.fv_to_tm fv in { lid; fv; t = uu___ } -let (ref_Mk_binder_view : refl_constant) = - let lid = fstar_refl_data_lid "Mkbinder_view" in - let attr = - let uu___ = - let uu___9 = fstar_refl_data_lid "binder_view" in - let uu___10 = - let uu___11 = - FStar_Ident.mk_ident ("sort", FStar_Compiler_Range_Type.dummyRange) in - let uu___12 = - let uu___13 = - FStar_Ident.mk_ident - ("qual", FStar_Compiler_Range_Type.dummyRange) in - let uu___14 = - let uu___15 = - FStar_Ident.mk_ident - ("attrs", FStar_Compiler_Range_Type.dummyRange) in - let uu___16 = - let uu___17 = - FStar_Ident.mk_ident - ("ppname", FStar_Compiler_Range_Type.dummyRange) in - [uu___17] in - uu___15 :: uu___16 in - uu___13 :: uu___14 in - uu___11 :: uu___12 in - (uu___9, uu___10) in - FStar_Syntax_Syntax.Record_ctor uu___ in - let fv = - FStar_Syntax_Syntax.lid_as_fv lid (FStar_Pervasives_Native.Some attr) in - let uu___ = FStar_Syntax_Syntax.fv_to_tm fv in { lid; fv; t = uu___ } -let (ref_Mk_lb : refl_constant) = - let lid = fstar_refl_data_lid "Mklb_view" in - let attr = - let uu___ = - let uu___9 = fstar_refl_data_lid "lb_view" in - let uu___10 = - let uu___11 = - FStar_Ident.mk_ident - ("lb_fv", FStar_Compiler_Range_Type.dummyRange) in - let uu___12 = - let uu___13 = - FStar_Ident.mk_ident - ("lb_us", FStar_Compiler_Range_Type.dummyRange) in - let uu___14 = - let uu___15 = - FStar_Ident.mk_ident - ("lb_typ", FStar_Compiler_Range_Type.dummyRange) in - let uu___16 = - let uu___17 = - FStar_Ident.mk_ident - ("lb_def", FStar_Compiler_Range_Type.dummyRange) in - [uu___17] in - uu___15 :: uu___16 in - uu___13 :: uu___14 in - uu___11 :: uu___12 in - (uu___9, uu___10) in - FStar_Syntax_Syntax.Record_ctor uu___ in - let fv = - FStar_Syntax_Syntax.lid_as_fv lid (FStar_Pervasives_Native.Some attr) in - let uu___ = FStar_Syntax_Syntax.fv_to_tm fv in { lid; fv; t = uu___ } -let (ref_Q_Explicit : refl_constant) = fstar_refl_data_const "Q_Explicit" -let (ref_Q_Implicit : refl_constant) = fstar_refl_data_const "Q_Implicit" -let (ref_Q_Equality : refl_constant) = fstar_refl_data_const "Q_Equality" -let (ref_Q_Meta : refl_constant) = fstar_refl_data_const "Q_Meta" -let (ref_DB : refl_constant) = fstar_syntax_syntax_const ["DB"] -let (ref_DT : refl_constant) = fstar_syntax_syntax_const ["DT"] -let (ref_NM : refl_constant) = fstar_syntax_syntax_const ["NM"] -let (ref_NT : refl_constant) = fstar_syntax_syntax_const ["NT"] -let (ref_UN : refl_constant) = fstar_syntax_syntax_const ["UN"] -let (ref_UD : refl_constant) = fstar_syntax_syntax_const ["UD"] -let (ref_C_Unit : refl_constant) = fstar_refl_data_const "C_Unit" -let (ref_C_True : refl_constant) = fstar_refl_data_const "C_True" -let (ref_C_False : refl_constant) = fstar_refl_data_const "C_False" -let (ref_C_Int : refl_constant) = fstar_refl_data_const "C_Int" -let (ref_C_String : refl_constant) = fstar_refl_data_const "C_String" -let (ref_C_Range : refl_constant) = fstar_refl_data_const "C_Range" -let (ref_C_Reify : refl_constant) = fstar_refl_data_const "C_Reify" -let (ref_C_Reflect : refl_constant) = fstar_refl_data_const "C_Reflect" -let (ref_C_Real : refl_constant) = fstar_refl_data_const "C_Real" -let (ref_Pat_Constant : refl_constant) = fstar_refl_data_const "Pat_Constant" -let (ref_Pat_Cons : refl_constant) = fstar_refl_data_const "Pat_Cons" -let (ref_Pat_Var : refl_constant) = fstar_refl_data_const "Pat_Var" -let (ref_Pat_Dot_Term : refl_constant) = fstar_refl_data_const "Pat_Dot_Term" -let (ref_Uv_Zero : refl_constant) = fstar_refl_data_const "Uv_Zero" -let (ref_Uv_Succ : refl_constant) = fstar_refl_data_const "Uv_Succ" -let (ref_Uv_Max : refl_constant) = fstar_refl_data_const "Uv_Max" -let (ref_Uv_BVar : refl_constant) = fstar_refl_data_const "Uv_BVar" -let (ref_Uv_Name : refl_constant) = fstar_refl_data_const "Uv_Name" -let (ref_Uv_Unif : refl_constant) = fstar_refl_data_const "Uv_Unif" -let (ref_Uv_Unk : refl_constant) = fstar_refl_data_const "Uv_Unk" -let (ref_Tv_Var : refl_constant) = fstar_refl_data_const "Tv_Var" -let (ref_Tv_BVar : refl_constant) = fstar_refl_data_const "Tv_BVar" -let (ref_Tv_FVar : refl_constant) = fstar_refl_data_const "Tv_FVar" -let (ref_Tv_UInst : refl_constant) = fstar_refl_data_const "Tv_UInst" -let (ref_Tv_App : refl_constant) = fstar_refl_data_const "Tv_App" -let (ref_Tv_Abs : refl_constant) = fstar_refl_data_const "Tv_Abs" -let (ref_Tv_Arrow : refl_constant) = fstar_refl_data_const "Tv_Arrow" -let (ref_Tv_Type : refl_constant) = fstar_refl_data_const "Tv_Type" -let (ref_Tv_Refine : refl_constant) = fstar_refl_data_const "Tv_Refine" -let (ref_Tv_Const : refl_constant) = fstar_refl_data_const "Tv_Const" -let (ref_Tv_Uvar : refl_constant) = fstar_refl_data_const "Tv_Uvar" -let (ref_Tv_Let : refl_constant) = fstar_refl_data_const "Tv_Let" -let (ref_Tv_Match : refl_constant) = fstar_refl_data_const "Tv_Match" -let (ref_Tv_AscT : refl_constant) = fstar_refl_data_const "Tv_AscribedT" -let (ref_Tv_AscC : refl_constant) = fstar_refl_data_const "Tv_AscribedC" -let (ref_Tv_Unknown : refl_constant) = fstar_refl_data_const "Tv_Unknown" -let (ref_Tv_Unsupp : refl_constant) = fstar_refl_data_const "Tv_Unsupp" -let (ref_C_Total : refl_constant) = fstar_refl_data_const "C_Total" -let (ref_C_GTotal : refl_constant) = fstar_refl_data_const "C_GTotal" -let (ref_C_Lemma : refl_constant) = fstar_refl_data_const "C_Lemma" -let (ref_C_Eff : refl_constant) = fstar_refl_data_const "C_Eff" -let (ref_Sg_Let : refl_constant) = fstar_refl_data_const "Sg_Let" -let (ref_Sg_Inductive : refl_constant) = fstar_refl_data_const "Sg_Inductive" -let (ref_Sg_Val : refl_constant) = fstar_refl_data_const "Sg_Val" -let (ref_Unk : refl_constant) = fstar_refl_data_const "Unk" -let (ref_qual_Assumption : refl_constant) = - fstar_refl_data_const "Assumption" -let (ref_qual_InternalAssumption : refl_constant) = - fstar_refl_data_const "InternalAssumption" -let (ref_qual_New : refl_constant) = fstar_refl_data_const "New" -let (ref_qual_Private : refl_constant) = fstar_refl_data_const "Private" -let (ref_qual_Unfold_for_unification_and_vcgen : refl_constant) = - fstar_refl_data_const "Unfold_for_unification_and_vcgen" -let (ref_qual_Visible_default : refl_constant) = - fstar_refl_data_const "Visible_default" -let (ref_qual_Irreducible : refl_constant) = - fstar_refl_data_const "Irreducible" -let (ref_qual_Inline_for_extraction : refl_constant) = - fstar_refl_data_const "Inline_for_extraction" -let (ref_qual_NoExtract : refl_constant) = fstar_refl_data_const "NoExtract" -let (ref_qual_Noeq : refl_constant) = fstar_refl_data_const "Noeq" -let (ref_qual_Unopteq : refl_constant) = fstar_refl_data_const "Unopteq" -let (ref_qual_TotalEffect : refl_constant) = - fstar_refl_data_const "TotalEffect" -let (ref_qual_Logic : refl_constant) = fstar_refl_data_const "Logic" -let (ref_qual_Reifiable : refl_constant) = fstar_refl_data_const "Reifiable" -let (ref_qual_Reflectable : refl_constant) = - fstar_refl_data_const "Reflectable" -let (ref_qual_Discriminator : refl_constant) = - fstar_refl_data_const "Discriminator" -let (ref_qual_Projector : refl_constant) = fstar_refl_data_const "Projector" -let (ref_qual_RecordType : refl_constant) = - fstar_refl_data_const "RecordType" -let (ref_qual_RecordConstructor : refl_constant) = - fstar_refl_data_const "RecordConstructor" -let (ref_qual_Action : refl_constant) = fstar_refl_data_const "Action" -let (ref_qual_ExceptionConstructor : refl_constant) = - fstar_refl_data_const "ExceptionConstructor" -let (ref_qual_HasMaskedEffect : refl_constant) = - fstar_refl_data_const "HasMaskedEffect" -let (ref_qual_Effect : refl_constant) = fstar_refl_data_const "Effect" -let (ref_qual_OnlyName : refl_constant) = fstar_refl_data_const "OnlyName" \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Reflection_V2_Data.ml b/ocaml/fstar-lib/generated/FStar_Reflection_V2_Data.ml deleted file mode 100644 index a0c0f625048..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Reflection_V2_Data.ml +++ /dev/null @@ -1,529 +0,0 @@ -open Prims -type name = Prims.string Prims.list -type typ = FStar_Syntax_Syntax.term -type binders = FStar_Syntax_Syntax.binder Prims.list -type ppname_t = Prims.string FStar_Compiler_Sealed.sealed -let (as_ppname : Prims.string -> ppname_t) = - fun x -> FStar_Compiler_Sealed.seal x -type simple_binder = FStar_Reflection_Types.binder -type ident_view = (Prims.string * FStar_Compiler_Range_Type.range) -type namedv = FStar_Syntax_Syntax.bv -type vconst = - | C_Unit - | C_Int of FStar_BigInt.t - | C_True - | C_False - | C_String of Prims.string - | C_Range of FStar_Compiler_Range_Type.range - | C_Reify - | C_Reflect of name - | C_Real of Prims.string -let (uu___is_C_Unit : vconst -> Prims.bool) = - fun projectee -> match projectee with | C_Unit -> true | uu___ -> false -let (uu___is_C_Int : vconst -> Prims.bool) = - fun projectee -> match projectee with | C_Int _0 -> true | uu___ -> false -let (__proj__C_Int__item___0 : vconst -> FStar_BigInt.t) = - fun projectee -> match projectee with | C_Int _0 -> _0 -let (uu___is_C_True : vconst -> Prims.bool) = - fun projectee -> match projectee with | C_True -> true | uu___ -> false -let (uu___is_C_False : vconst -> Prims.bool) = - fun projectee -> match projectee with | C_False -> true | uu___ -> false -let (uu___is_C_String : vconst -> Prims.bool) = - fun projectee -> - match projectee with | C_String _0 -> true | uu___ -> false -let (__proj__C_String__item___0 : vconst -> Prims.string) = - fun projectee -> match projectee with | C_String _0 -> _0 -let (uu___is_C_Range : vconst -> Prims.bool) = - fun projectee -> match projectee with | C_Range _0 -> true | uu___ -> false -let (__proj__C_Range__item___0 : vconst -> FStar_Compiler_Range_Type.range) = - fun projectee -> match projectee with | C_Range _0 -> _0 -let (uu___is_C_Reify : vconst -> Prims.bool) = - fun projectee -> match projectee with | C_Reify -> true | uu___ -> false -let (uu___is_C_Reflect : vconst -> Prims.bool) = - fun projectee -> - match projectee with | C_Reflect _0 -> true | uu___ -> false -let (__proj__C_Reflect__item___0 : vconst -> name) = - fun projectee -> match projectee with | C_Reflect _0 -> _0 -let (uu___is_C_Real : vconst -> Prims.bool) = - fun projectee -> match projectee with | C_Real _0 -> true | uu___ -> false -let (__proj__C_Real__item___0 : vconst -> Prims.string) = - fun projectee -> match projectee with | C_Real _0 -> _0 -type universes = FStar_Syntax_Syntax.universe Prims.list -type pattern = - | Pat_Constant of vconst - | Pat_Cons of FStar_Syntax_Syntax.fv * universes - FStar_Pervasives_Native.option * (pattern * Prims.bool) Prims.list - | Pat_Var of FStar_Syntax_Syntax.term FStar_Compiler_Sealed.sealed * - ppname_t - | Pat_Dot_Term of FStar_Syntax_Syntax.term FStar_Pervasives_Native.option -let (uu___is_Pat_Constant : pattern -> Prims.bool) = - fun projectee -> - match projectee with | Pat_Constant c -> true | uu___ -> false -let (__proj__Pat_Constant__item__c : pattern -> vconst) = - fun projectee -> match projectee with | Pat_Constant c -> c -let (uu___is_Pat_Cons : pattern -> Prims.bool) = - fun projectee -> - match projectee with - | Pat_Cons (head, univs, subpats) -> true - | uu___ -> false -let (__proj__Pat_Cons__item__head : pattern -> FStar_Syntax_Syntax.fv) = - fun projectee -> - match projectee with | Pat_Cons (head, univs, subpats) -> head -let (__proj__Pat_Cons__item__univs : - pattern -> universes FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with | Pat_Cons (head, univs, subpats) -> univs -let (__proj__Pat_Cons__item__subpats : - pattern -> (pattern * Prims.bool) Prims.list) = - fun projectee -> - match projectee with | Pat_Cons (head, univs, subpats) -> subpats -let (uu___is_Pat_Var : pattern -> Prims.bool) = - fun projectee -> - match projectee with | Pat_Var (sort, ppname) -> true | uu___ -> false -let (__proj__Pat_Var__item__sort : - pattern -> FStar_Syntax_Syntax.term FStar_Compiler_Sealed.sealed) = - fun projectee -> match projectee with | Pat_Var (sort, ppname) -> sort -let (__proj__Pat_Var__item__ppname : pattern -> ppname_t) = - fun projectee -> match projectee with | Pat_Var (sort, ppname) -> ppname -let (uu___is_Pat_Dot_Term : pattern -> Prims.bool) = - fun projectee -> - match projectee with | Pat_Dot_Term t -> true | uu___ -> false -let (__proj__Pat_Dot_Term__item__t : - pattern -> FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) = - fun projectee -> match projectee with | Pat_Dot_Term t -> t -type branch = (pattern * FStar_Syntax_Syntax.term) -type aqualv = - | Q_Implicit - | Q_Explicit - | Q_Equality - | Q_Meta of FStar_Syntax_Syntax.term -let (uu___is_Q_Implicit : aqualv -> Prims.bool) = - fun projectee -> match projectee with | Q_Implicit -> true | uu___ -> false -let (uu___is_Q_Explicit : aqualv -> Prims.bool) = - fun projectee -> match projectee with | Q_Explicit -> true | uu___ -> false -let (uu___is_Q_Equality : aqualv -> Prims.bool) = - fun projectee -> match projectee with | Q_Equality -> true | uu___ -> false -let (uu___is_Q_Meta : aqualv -> Prims.bool) = - fun projectee -> match projectee with | Q_Meta _0 -> true | uu___ -> false -let (__proj__Q_Meta__item___0 : aqualv -> FStar_Syntax_Syntax.term) = - fun projectee -> match projectee with | Q_Meta _0 -> _0 -type argv = (FStar_Syntax_Syntax.term * aqualv) -type namedv_view = - { - uniq: FStar_BigInt.t ; - sort: typ FStar_Compiler_Sealed.sealed ; - ppname: ppname_t } -let (__proj__Mknamedv_view__item__uniq : namedv_view -> FStar_BigInt.t) = - fun projectee -> match projectee with | { uniq; sort; ppname;_} -> uniq -let (__proj__Mknamedv_view__item__sort : - namedv_view -> typ FStar_Compiler_Sealed.sealed) = - fun projectee -> match projectee with | { uniq; sort; ppname;_} -> sort -let (__proj__Mknamedv_view__item__ppname : namedv_view -> ppname_t) = - fun projectee -> match projectee with | { uniq; sort; ppname;_} -> ppname -type bv_view = - { - index: FStar_BigInt.t ; - sort1: typ FStar_Compiler_Sealed.sealed ; - ppname1: ppname_t } -let (__proj__Mkbv_view__item__index : bv_view -> FStar_BigInt.t) = - fun projectee -> - match projectee with - | { index; sort1 = sort; ppname1 = ppname;_} -> index -let (__proj__Mkbv_view__item__sort : - bv_view -> typ FStar_Compiler_Sealed.sealed) = - fun projectee -> - match projectee with | { index; sort1 = sort; ppname1 = ppname;_} -> sort -let (__proj__Mkbv_view__item__ppname : bv_view -> ppname_t) = - fun projectee -> - match projectee with - | { index; sort1 = sort; ppname1 = ppname;_} -> ppname -type binder_view = - { - sort2: typ ; - qual: aqualv ; - attrs: FStar_Syntax_Syntax.term Prims.list ; - ppname2: ppname_t } -let (__proj__Mkbinder_view__item__sort : binder_view -> typ) = - fun projectee -> - match projectee with - | { sort2 = sort; qual; attrs; ppname2 = ppname;_} -> sort -let (__proj__Mkbinder_view__item__qual : binder_view -> aqualv) = - fun projectee -> - match projectee with - | { sort2 = sort; qual; attrs; ppname2 = ppname;_} -> qual -let (__proj__Mkbinder_view__item__attrs : - binder_view -> FStar_Syntax_Syntax.term Prims.list) = - fun projectee -> - match projectee with - | { sort2 = sort; qual; attrs; ppname2 = ppname;_} -> attrs -let (__proj__Mkbinder_view__item__ppname : binder_view -> ppname_t) = - fun projectee -> - match projectee with - | { sort2 = sort; qual; attrs; ppname2 = ppname;_} -> ppname -type binding = { - uniq1: FStar_BigInt.t ; - sort3: typ ; - ppname3: ppname_t } -let (__proj__Mkbinding__item__uniq : binding -> FStar_BigInt.t) = - fun projectee -> - match projectee with - | { uniq1 = uniq; sort3 = sort; ppname3 = ppname;_} -> uniq -let (__proj__Mkbinding__item__sort : binding -> typ) = - fun projectee -> - match projectee with - | { uniq1 = uniq; sort3 = sort; ppname3 = ppname;_} -> sort -let (__proj__Mkbinding__item__ppname : binding -> ppname_t) = - fun projectee -> - match projectee with - | { uniq1 = uniq; sort3 = sort; ppname3 = ppname;_} -> ppname -type bindings = binding Prims.list -type universe_view = - | Uv_Zero - | Uv_Succ of FStar_Syntax_Syntax.universe - | Uv_Max of universes - | Uv_BVar of FStar_BigInt.t - | Uv_Name of FStar_Syntax_Syntax.univ_name - | Uv_Unif of FStar_Syntax_Syntax.universe_uvar - | Uv_Unk -let (uu___is_Uv_Zero : universe_view -> Prims.bool) = - fun projectee -> match projectee with | Uv_Zero -> true | uu___ -> false -let (uu___is_Uv_Succ : universe_view -> Prims.bool) = - fun projectee -> match projectee with | Uv_Succ _0 -> true | uu___ -> false -let (__proj__Uv_Succ__item___0 : - universe_view -> FStar_Syntax_Syntax.universe) = - fun projectee -> match projectee with | Uv_Succ _0 -> _0 -let (uu___is_Uv_Max : universe_view -> Prims.bool) = - fun projectee -> match projectee with | Uv_Max _0 -> true | uu___ -> false -let (__proj__Uv_Max__item___0 : universe_view -> universes) = - fun projectee -> match projectee with | Uv_Max _0 -> _0 -let (uu___is_Uv_BVar : universe_view -> Prims.bool) = - fun projectee -> match projectee with | Uv_BVar _0 -> true | uu___ -> false -let (__proj__Uv_BVar__item___0 : universe_view -> FStar_BigInt.t) = - fun projectee -> match projectee with | Uv_BVar _0 -> _0 -let (uu___is_Uv_Name : universe_view -> Prims.bool) = - fun projectee -> match projectee with | Uv_Name _0 -> true | uu___ -> false -let (__proj__Uv_Name__item___0 : - universe_view -> FStar_Syntax_Syntax.univ_name) = - fun projectee -> match projectee with | Uv_Name _0 -> _0 -let (uu___is_Uv_Unif : universe_view -> Prims.bool) = - fun projectee -> match projectee with | Uv_Unif _0 -> true | uu___ -> false -let (__proj__Uv_Unif__item___0 : - universe_view -> FStar_Syntax_Syntax.universe_uvar) = - fun projectee -> match projectee with | Uv_Unif _0 -> _0 -let (uu___is_Uv_Unk : universe_view -> Prims.bool) = - fun projectee -> match projectee with | Uv_Unk -> true | uu___ -> false -type term_view = - | Tv_Var of namedv - | Tv_BVar of FStar_Syntax_Syntax.bv - | Tv_FVar of FStar_Syntax_Syntax.fv - | Tv_UInst of (FStar_Syntax_Syntax.fv * universes) - | Tv_App of (FStar_Syntax_Syntax.term * argv) - | Tv_Abs of (FStar_Syntax_Syntax.binder * FStar_Syntax_Syntax.term) - | Tv_Arrow of (FStar_Syntax_Syntax.binder * FStar_Syntax_Syntax.comp) - | Tv_Type of FStar_Syntax_Syntax.universe - | Tv_Refine of (FStar_Syntax_Syntax.binder * FStar_Syntax_Syntax.term) - | Tv_Const of vconst - | Tv_Uvar of (FStar_BigInt.t * FStar_Syntax_Syntax.ctx_uvar_and_subst) - | Tv_Let of (Prims.bool * FStar_Syntax_Syntax.term Prims.list * - FStar_Syntax_Syntax.binder * FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.term) - | Tv_Match of (FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.match_returns_ascription FStar_Pervasives_Native.option - * branch Prims.list) - | Tv_AscribedT of (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option * Prims.bool) - | Tv_AscribedC of (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.comp * - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option * Prims.bool) - | Tv_Unknown - | Tv_Unsupp -let (uu___is_Tv_Var : term_view -> Prims.bool) = - fun projectee -> match projectee with | Tv_Var _0 -> true | uu___ -> false -let (__proj__Tv_Var__item___0 : term_view -> namedv) = - fun projectee -> match projectee with | Tv_Var _0 -> _0 -let (uu___is_Tv_BVar : term_view -> Prims.bool) = - fun projectee -> match projectee with | Tv_BVar _0 -> true | uu___ -> false -let (__proj__Tv_BVar__item___0 : term_view -> FStar_Syntax_Syntax.bv) = - fun projectee -> match projectee with | Tv_BVar _0 -> _0 -let (uu___is_Tv_FVar : term_view -> Prims.bool) = - fun projectee -> match projectee with | Tv_FVar _0 -> true | uu___ -> false -let (__proj__Tv_FVar__item___0 : term_view -> FStar_Syntax_Syntax.fv) = - fun projectee -> match projectee with | Tv_FVar _0 -> _0 -let (uu___is_Tv_UInst : term_view -> Prims.bool) = - fun projectee -> - match projectee with | Tv_UInst _0 -> true | uu___ -> false -let (__proj__Tv_UInst__item___0 : - term_view -> (FStar_Syntax_Syntax.fv * universes)) = - fun projectee -> match projectee with | Tv_UInst _0 -> _0 -let (uu___is_Tv_App : term_view -> Prims.bool) = - fun projectee -> match projectee with | Tv_App _0 -> true | uu___ -> false -let (__proj__Tv_App__item___0 : - term_view -> (FStar_Syntax_Syntax.term * argv)) = - fun projectee -> match projectee with | Tv_App _0 -> _0 -let (uu___is_Tv_Abs : term_view -> Prims.bool) = - fun projectee -> match projectee with | Tv_Abs _0 -> true | uu___ -> false -let (__proj__Tv_Abs__item___0 : - term_view -> (FStar_Syntax_Syntax.binder * FStar_Syntax_Syntax.term)) = - fun projectee -> match projectee with | Tv_Abs _0 -> _0 -let (uu___is_Tv_Arrow : term_view -> Prims.bool) = - fun projectee -> - match projectee with | Tv_Arrow _0 -> true | uu___ -> false -let (__proj__Tv_Arrow__item___0 : - term_view -> (FStar_Syntax_Syntax.binder * FStar_Syntax_Syntax.comp)) = - fun projectee -> match projectee with | Tv_Arrow _0 -> _0 -let (uu___is_Tv_Type : term_view -> Prims.bool) = - fun projectee -> match projectee with | Tv_Type _0 -> true | uu___ -> false -let (__proj__Tv_Type__item___0 : term_view -> FStar_Syntax_Syntax.universe) = - fun projectee -> match projectee with | Tv_Type _0 -> _0 -let (uu___is_Tv_Refine : term_view -> Prims.bool) = - fun projectee -> - match projectee with | Tv_Refine _0 -> true | uu___ -> false -let (__proj__Tv_Refine__item___0 : - term_view -> (FStar_Syntax_Syntax.binder * FStar_Syntax_Syntax.term)) = - fun projectee -> match projectee with | Tv_Refine _0 -> _0 -let (uu___is_Tv_Const : term_view -> Prims.bool) = - fun projectee -> - match projectee with | Tv_Const _0 -> true | uu___ -> false -let (__proj__Tv_Const__item___0 : term_view -> vconst) = - fun projectee -> match projectee with | Tv_Const _0 -> _0 -let (uu___is_Tv_Uvar : term_view -> Prims.bool) = - fun projectee -> match projectee with | Tv_Uvar _0 -> true | uu___ -> false -let (__proj__Tv_Uvar__item___0 : - term_view -> (FStar_BigInt.t * FStar_Syntax_Syntax.ctx_uvar_and_subst)) = - fun projectee -> match projectee with | Tv_Uvar _0 -> _0 -let (uu___is_Tv_Let : term_view -> Prims.bool) = - fun projectee -> match projectee with | Tv_Let _0 -> true | uu___ -> false -let (__proj__Tv_Let__item___0 : - term_view -> - (Prims.bool * FStar_Syntax_Syntax.term Prims.list * - FStar_Syntax_Syntax.binder * FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.term)) - = fun projectee -> match projectee with | Tv_Let _0 -> _0 -let (uu___is_Tv_Match : term_view -> Prims.bool) = - fun projectee -> - match projectee with | Tv_Match _0 -> true | uu___ -> false -let (__proj__Tv_Match__item___0 : - term_view -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.match_returns_ascription - FStar_Pervasives_Native.option * branch Prims.list)) - = fun projectee -> match projectee with | Tv_Match _0 -> _0 -let (uu___is_Tv_AscribedT : term_view -> Prims.bool) = - fun projectee -> - match projectee with | Tv_AscribedT _0 -> true | uu___ -> false -let (__proj__Tv_AscribedT__item___0 : - term_view -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option * Prims.bool)) - = fun projectee -> match projectee with | Tv_AscribedT _0 -> _0 -let (uu___is_Tv_AscribedC : term_view -> Prims.bool) = - fun projectee -> - match projectee with | Tv_AscribedC _0 -> true | uu___ -> false -let (__proj__Tv_AscribedC__item___0 : - term_view -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.comp * - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option * Prims.bool)) - = fun projectee -> match projectee with | Tv_AscribedC _0 -> _0 -let (uu___is_Tv_Unknown : term_view -> Prims.bool) = - fun projectee -> match projectee with | Tv_Unknown -> true | uu___ -> false -let (uu___is_Tv_Unsupp : term_view -> Prims.bool) = - fun projectee -> match projectee with | Tv_Unsupp -> true | uu___ -> false -let (notAscription : term_view -> Prims.bool) = - fun tv -> - (Prims.op_Negation (uu___is_Tv_AscribedT tv)) && - (Prims.op_Negation (uu___is_Tv_AscribedC tv)) -type comp_view = - | C_Total of typ - | C_GTotal of typ - | C_Lemma of (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.term) - | C_Eff of (universes * name * FStar_Syntax_Syntax.term * argv Prims.list * - FStar_Syntax_Syntax.term Prims.list) -let (uu___is_C_Total : comp_view -> Prims.bool) = - fun projectee -> match projectee with | C_Total _0 -> true | uu___ -> false -let (__proj__C_Total__item___0 : comp_view -> typ) = - fun projectee -> match projectee with | C_Total _0 -> _0 -let (uu___is_C_GTotal : comp_view -> Prims.bool) = - fun projectee -> - match projectee with | C_GTotal _0 -> true | uu___ -> false -let (__proj__C_GTotal__item___0 : comp_view -> typ) = - fun projectee -> match projectee with | C_GTotal _0 -> _0 -let (uu___is_C_Lemma : comp_view -> Prims.bool) = - fun projectee -> match projectee with | C_Lemma _0 -> true | uu___ -> false -let (__proj__C_Lemma__item___0 : - comp_view -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.term)) - = fun projectee -> match projectee with | C_Lemma _0 -> _0 -let (uu___is_C_Eff : comp_view -> Prims.bool) = - fun projectee -> match projectee with | C_Eff _0 -> true | uu___ -> false -let (__proj__C_Eff__item___0 : - comp_view -> - (universes * name * FStar_Syntax_Syntax.term * argv Prims.list * - FStar_Syntax_Syntax.term Prims.list)) - = fun projectee -> match projectee with | C_Eff _0 -> _0 -type ctor = (name * typ) -type lb_view = - { - lb_fv: FStar_Syntax_Syntax.fv ; - lb_us: FStar_Syntax_Syntax.univ_name Prims.list ; - lb_typ: typ ; - lb_def: FStar_Syntax_Syntax.term } -let (__proj__Mklb_view__item__lb_fv : lb_view -> FStar_Syntax_Syntax.fv) = - fun projectee -> - match projectee with | { lb_fv; lb_us; lb_typ; lb_def;_} -> lb_fv -let (__proj__Mklb_view__item__lb_us : - lb_view -> FStar_Syntax_Syntax.univ_name Prims.list) = - fun projectee -> - match projectee with | { lb_fv; lb_us; lb_typ; lb_def;_} -> lb_us -let (__proj__Mklb_view__item__lb_typ : lb_view -> typ) = - fun projectee -> - match projectee with | { lb_fv; lb_us; lb_typ; lb_def;_} -> lb_typ -let (__proj__Mklb_view__item__lb_def : lb_view -> FStar_Syntax_Syntax.term) = - fun projectee -> - match projectee with | { lb_fv; lb_us; lb_typ; lb_def;_} -> lb_def -type sigelt_view = - | Sg_Let of (Prims.bool * FStar_Syntax_Syntax.letbinding Prims.list) - | Sg_Inductive of (name * FStar_Syntax_Syntax.univ_name Prims.list * - FStar_Syntax_Syntax.binder Prims.list * typ * ctor Prims.list) - | Sg_Val of (name * FStar_Syntax_Syntax.univ_name Prims.list * typ) - | Unk -let (uu___is_Sg_Let : sigelt_view -> Prims.bool) = - fun projectee -> match projectee with | Sg_Let _0 -> true | uu___ -> false -let (__proj__Sg_Let__item___0 : - sigelt_view -> (Prims.bool * FStar_Syntax_Syntax.letbinding Prims.list)) = - fun projectee -> match projectee with | Sg_Let _0 -> _0 -let (uu___is_Sg_Inductive : sigelt_view -> Prims.bool) = - fun projectee -> - match projectee with | Sg_Inductive _0 -> true | uu___ -> false -let (__proj__Sg_Inductive__item___0 : - sigelt_view -> - (name * FStar_Syntax_Syntax.univ_name Prims.list * - FStar_Syntax_Syntax.binder Prims.list * typ * ctor Prims.list)) - = fun projectee -> match projectee with | Sg_Inductive _0 -> _0 -let (uu___is_Sg_Val : sigelt_view -> Prims.bool) = - fun projectee -> match projectee with | Sg_Val _0 -> true | uu___ -> false -let (__proj__Sg_Val__item___0 : - sigelt_view -> (name * FStar_Syntax_Syntax.univ_name Prims.list * typ)) = - fun projectee -> match projectee with | Sg_Val _0 -> _0 -let (uu___is_Unk : sigelt_view -> Prims.bool) = - fun projectee -> match projectee with | Unk -> true | uu___ -> false -type qualifier = - | Assumption - | InternalAssumption - | New - | Private - | Unfold_for_unification_and_vcgen - | Visible_default - | Irreducible - | Inline_for_extraction - | NoExtract - | Noeq - | Unopteq - | TotalEffect - | Logic - | Reifiable - | Reflectable of name - | Discriminator of name - | Projector of (name * FStar_Ident.ident) - | RecordType of (FStar_Ident.ident Prims.list * FStar_Ident.ident - Prims.list) - | RecordConstructor of (FStar_Ident.ident Prims.list * FStar_Ident.ident - Prims.list) - | Action of name - | ExceptionConstructor - | HasMaskedEffect - | Effect - | OnlyName -let (uu___is_Assumption : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Assumption -> true | uu___ -> false -let (uu___is_InternalAssumption : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | InternalAssumption -> true | uu___ -> false -let (uu___is_New : qualifier -> Prims.bool) = - fun projectee -> match projectee with | New -> true | uu___ -> false -let (uu___is_Private : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Private -> true | uu___ -> false -let (uu___is_Unfold_for_unification_and_vcgen : qualifier -> Prims.bool) = - fun projectee -> - match projectee with - | Unfold_for_unification_and_vcgen -> true - | uu___ -> false -let (uu___is_Visible_default : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | Visible_default -> true | uu___ -> false -let (uu___is_Irreducible : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | Irreducible -> true | uu___ -> false -let (uu___is_Inline_for_extraction : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | Inline_for_extraction -> true | uu___ -> false -let (uu___is_NoExtract : qualifier -> Prims.bool) = - fun projectee -> match projectee with | NoExtract -> true | uu___ -> false -let (uu___is_Noeq : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Noeq -> true | uu___ -> false -let (uu___is_Unopteq : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Unopteq -> true | uu___ -> false -let (uu___is_TotalEffect : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | TotalEffect -> true | uu___ -> false -let (uu___is_Logic : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Logic -> true | uu___ -> false -let (uu___is_Reifiable : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Reifiable -> true | uu___ -> false -let (uu___is_Reflectable : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | Reflectable _0 -> true | uu___ -> false -let (__proj__Reflectable__item___0 : qualifier -> name) = - fun projectee -> match projectee with | Reflectable _0 -> _0 -let (uu___is_Discriminator : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | Discriminator _0 -> true | uu___ -> false -let (__proj__Discriminator__item___0 : qualifier -> name) = - fun projectee -> match projectee with | Discriminator _0 -> _0 -let (uu___is_Projector : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | Projector _0 -> true | uu___ -> false -let (__proj__Projector__item___0 : qualifier -> (name * FStar_Ident.ident)) = - fun projectee -> match projectee with | Projector _0 -> _0 -let (uu___is_RecordType : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | RecordType _0 -> true | uu___ -> false -let (__proj__RecordType__item___0 : - qualifier -> (FStar_Ident.ident Prims.list * FStar_Ident.ident Prims.list)) - = fun projectee -> match projectee with | RecordType _0 -> _0 -let (uu___is_RecordConstructor : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | RecordConstructor _0 -> true | uu___ -> false -let (__proj__RecordConstructor__item___0 : - qualifier -> (FStar_Ident.ident Prims.list * FStar_Ident.ident Prims.list)) - = fun projectee -> match projectee with | RecordConstructor _0 -> _0 -let (uu___is_Action : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Action _0 -> true | uu___ -> false -let (__proj__Action__item___0 : qualifier -> name) = - fun projectee -> match projectee with | Action _0 -> _0 -let (uu___is_ExceptionConstructor : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | ExceptionConstructor -> true | uu___ -> false -let (uu___is_HasMaskedEffect : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | HasMaskedEffect -> true | uu___ -> false -let (uu___is_Effect : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Effect -> true | uu___ -> false -let (uu___is_OnlyName : qualifier -> Prims.bool) = - fun projectee -> match projectee with | OnlyName -> true | uu___ -> false -type qualifiers = qualifier Prims.list -type var = FStar_BigInt.t -type exp = - | Unit - | Var of var - | Mult of (exp * exp) -let (uu___is_Unit : exp -> Prims.bool) = - fun projectee -> match projectee with | Unit -> true | uu___ -> false -let (uu___is_Var : exp -> Prims.bool) = - fun projectee -> match projectee with | Var _0 -> true | uu___ -> false -let (__proj__Var__item___0 : exp -> var) = - fun projectee -> match projectee with | Var _0 -> _0 -let (uu___is_Mult : exp -> Prims.bool) = - fun projectee -> match projectee with | Mult _0 -> true | uu___ -> false -let (__proj__Mult__item___0 : exp -> (exp * exp)) = - fun projectee -> match projectee with | Mult _0 -> _0 -type decls = FStar_Syntax_Syntax.sigelt Prims.list \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Reflection_V2_Derived.ml b/ocaml/fstar-lib/generated/FStar_Reflection_V2_Derived.ml index 69f429a6536..320f436e7e7 100644 --- a/ocaml/fstar-lib/generated/FStar_Reflection_V2_Derived.ml +++ b/ocaml/fstar-lib/generated/FStar_Reflection_V2_Derived.ml @@ -1,113 +1,123 @@ open Prims let (type_of_binder : - FStar_Reflection_Types.binder -> FStar_Reflection_Types.typ) = + FStarC_Reflection_Types.binder -> FStarC_Reflection_Types.typ) = fun b -> - (FStar_Reflection_V2_Builtins.inspect_binder b).FStar_Reflection_V2_Data.sort2 + (FStarC_Reflection_V2_Builtins.inspect_binder b).FStarC_Reflection_V2_Data.sort2 let rec (inspect_ln_unascribe : - FStar_Reflection_Types.term -> FStar_Reflection_V2_Data.term_view) = + FStarC_Reflection_Types.term -> FStarC_Reflection_V2_Data.term_view) = fun t -> - match FStar_Reflection_V2_Builtins.inspect_ln t with - | FStar_Reflection_V2_Data.Tv_AscribedT (t', uu___, uu___1, uu___2) -> + match FStarC_Reflection_V2_Builtins.inspect_ln t with + | FStarC_Reflection_V2_Data.Tv_AscribedT (t', uu___, uu___1, uu___2) -> inspect_ln_unascribe t' - | FStar_Reflection_V2_Data.Tv_AscribedC (t', uu___, uu___1, uu___2) -> + | FStarC_Reflection_V2_Data.Tv_AscribedC (t', uu___, uu___1, uu___2) -> inspect_ln_unascribe t' | tv -> tv let (compare_bv : - FStar_Reflection_Types.bv -> FStar_Reflection_Types.bv -> FStar_Order.order) + FStarC_Reflection_Types.bv -> + FStarC_Reflection_Types.bv -> FStar_Order.order) = fun v1 -> fun v2 -> FStar_Order.compare_int - (FStar_Reflection_V2_Builtins.inspect_bv v1).FStar_Reflection_V2_Data.index - (FStar_Reflection_V2_Builtins.inspect_bv v2).FStar_Reflection_V2_Data.index + (FStarC_Reflection_V2_Builtins.inspect_bv v1).FStarC_Reflection_V2_Data.index + (FStarC_Reflection_V2_Builtins.inspect_bv v2).FStarC_Reflection_V2_Data.index let (compare_namedv : - FStar_Reflection_Types.namedv -> - FStar_Reflection_Types.namedv -> FStar_Order.order) + FStarC_Reflection_Types.namedv -> + FStarC_Reflection_Types.namedv -> FStar_Order.order) = fun v1 -> fun v2 -> FStar_Order.compare_int - (FStar_Reflection_V2_Builtins.inspect_namedv v1).FStar_Reflection_V2_Data.uniq - (FStar_Reflection_V2_Builtins.inspect_namedv v2).FStar_Reflection_V2_Data.uniq + (FStarC_Reflection_V2_Builtins.inspect_namedv v1).FStarC_Reflection_V2_Data.uniq + (FStarC_Reflection_V2_Builtins.inspect_namedv v2).FStarC_Reflection_V2_Data.uniq let (shift : - Prims.int -> FStar_Syntax_Syntax.subst_elt -> FStar_Syntax_Syntax.subst_elt) + Prims.int -> + FStarC_Syntax_Syntax.subst_elt -> FStarC_Syntax_Syntax.subst_elt) = fun n -> fun s -> match s with - | FStar_Syntax_Syntax.DB (i, t) -> FStar_Syntax_Syntax.DB ((i + n), t) - | FStar_Syntax_Syntax.DT (i, t) -> FStar_Syntax_Syntax.DT ((i + n), t) - | FStar_Syntax_Syntax.UN (i, t) -> FStar_Syntax_Syntax.UN ((i + n), t) - | FStar_Syntax_Syntax.NM (x, i) -> FStar_Syntax_Syntax.NM (x, (i + n)) - | FStar_Syntax_Syntax.UD (x, i) -> FStar_Syntax_Syntax.UD (x, (i + n)) - | FStar_Syntax_Syntax.NT (uu___, uu___1) -> s + | FStarC_Syntax_Syntax.DB (i, t) -> + FStarC_Syntax_Syntax.DB ((i + n), t) + | FStarC_Syntax_Syntax.DT (i, t) -> + FStarC_Syntax_Syntax.DT ((i + n), t) + | FStarC_Syntax_Syntax.UN (i, t) -> + FStarC_Syntax_Syntax.UN ((i + n), t) + | FStarC_Syntax_Syntax.NM (x, i) -> + FStarC_Syntax_Syntax.NM (x, (i + n)) + | FStarC_Syntax_Syntax.UD (x, i) -> + FStarC_Syntax_Syntax.UD (x, (i + n)) + | FStarC_Syntax_Syntax.NT (uu___, uu___1) -> s let (shift_subst : Prims.int -> - FStar_Syntax_Syntax.subst_elt Prims.list -> - FStar_Syntax_Syntax.subst_elt Prims.list) + FStarC_Syntax_Syntax.subst_elt Prims.list -> + FStarC_Syntax_Syntax.subst_elt Prims.list) = fun n -> fun s -> FStar_List_Tot_Base.map (shift n) s let (subst1 : - FStar_Reflection_Types.namedv -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> FStar_Reflection_Types.term) + FStarC_Reflection_Types.namedv -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term) = fun n -> fun t1 -> fun t2 -> - FStar_Reflection_V2_Builtins.subst_term - [FStar_Syntax_Syntax.NT (n, t1)] t2 + FStarC_Reflection_V2_Builtins.subst_term + [FStarC_Syntax_Syntax.NT (n, t1)] t2 let (mk_binder : Prims.string -> - FStar_Reflection_Types.typ -> FStar_Reflection_V2_Data.simple_binder) + FStarC_Reflection_Types.typ -> FStarC_Reflection_V2_Data.simple_binder) = fun nm -> fun sort -> let bv = { - FStar_Reflection_V2_Data.sort2 = sort; - FStar_Reflection_V2_Data.qual = FStar_Reflection_V2_Data.Q_Explicit; - FStar_Reflection_V2_Data.attrs = []; - FStar_Reflection_V2_Data.ppname2 = (FStar_Sealed.seal nm) + FStarC_Reflection_V2_Data.sort2 = sort; + FStarC_Reflection_V2_Data.qual = + FStarC_Reflection_V2_Data.Q_Explicit; + FStarC_Reflection_V2_Data.attrs = []; + FStarC_Reflection_V2_Data.ppname2 = (FStar_Sealed.seal nm) } in - FStar_Reflection_V2_Builtins.pack_binder bv + FStarC_Reflection_V2_Builtins.pack_binder bv let (mk_implicit_binder : - Prims.string -> FStar_Reflection_Types.typ -> FStar_Reflection_Types.binder) + Prims.string -> + FStarC_Reflection_Types.typ -> FStarC_Reflection_Types.binder) = fun nm -> fun sort -> - FStar_Reflection_V2_Builtins.pack_binder + FStarC_Reflection_V2_Builtins.pack_binder { - FStar_Reflection_V2_Data.sort2 = sort; - FStar_Reflection_V2_Data.qual = FStar_Reflection_V2_Data.Q_Implicit; - FStar_Reflection_V2_Data.attrs = []; - FStar_Reflection_V2_Data.ppname2 = (FStar_Sealed.seal nm) + FStarC_Reflection_V2_Data.sort2 = sort; + FStarC_Reflection_V2_Data.qual = + FStarC_Reflection_V2_Data.Q_Implicit; + FStarC_Reflection_V2_Data.attrs = []; + FStarC_Reflection_V2_Data.ppname2 = (FStar_Sealed.seal nm) } let (push_binding : - FStar_Reflection_Types.env -> - FStar_Reflection_V2_Data.binding -> FStar_Reflection_Types.env) + FStarC_Reflection_Types.env -> + FStarC_Reflection_V2_Data.binding -> FStarC_Reflection_Types.env) = fun e -> fun b -> let nv = - FStar_Reflection_V2_Builtins.pack_namedv + FStarC_Reflection_V2_Builtins.pack_namedv { - FStar_Reflection_V2_Data.uniq = - (b.FStar_Reflection_V2_Data.uniq1); - FStar_Reflection_V2_Data.sort = - (FStar_Sealed.seal b.FStar_Reflection_V2_Data.sort3); - FStar_Reflection_V2_Data.ppname = - (b.FStar_Reflection_V2_Data.ppname3) + FStarC_Reflection_V2_Data.uniq = + (b.FStarC_Reflection_V2_Data.uniq1); + FStarC_Reflection_V2_Data.sort = + (FStar_Sealed.seal b.FStarC_Reflection_V2_Data.sort3); + FStarC_Reflection_V2_Data.ppname = + (b.FStarC_Reflection_V2_Data.ppname3) } in - FStar_Reflection_V2_Builtins.push_namedv e nv -let rec (flatten_name : FStar_Reflection_Types.name -> Prims.string) = + FStarC_Reflection_V2_Builtins.push_namedv e nv +let rec (flatten_name : FStarC_Reflection_Types.name -> Prims.string) = fun ns -> match ns with | [] -> "" | n::[] -> n | n::ns1 -> Prims.strcat n (Prims.strcat "." (flatten_name ns1)) let rec (mk_app : - FStar_Reflection_Types.term -> - FStar_Reflection_V2_Data.argv Prims.list -> FStar_Reflection_Types.term) + FStarC_Reflection_Types.term -> + FStarC_Reflection_V2_Data.argv Prims.list -> FStarC_Reflection_Types.term) = fun t -> fun args -> @@ -115,112 +125,115 @@ let rec (mk_app : | [] -> t | x::xs -> mk_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App (t, x))) xs + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App (t, x))) xs let (mk_e_app : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term Prims.list -> FStar_Reflection_Types.term) + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term Prims.list -> FStarC_Reflection_Types.term) = fun t -> fun args -> - let e t1 = (t1, FStar_Reflection_V2_Data.Q_Explicit) in + let e t1 = (t1, FStarC_Reflection_V2_Data.Q_Explicit) in mk_app t (FStar_List_Tot_Base.map e args) -let (u_unk : FStar_Reflection_Types.universe) = - FStar_Reflection_V2_Builtins.pack_universe FStar_Reflection_V2_Data.Uv_Unk +let (u_unk : FStarC_Reflection_Types.universe) = + FStarC_Reflection_V2_Builtins.pack_universe + FStarC_Reflection_V2_Data.Uv_Unk let rec (mk_tot_arr_ln : - FStar_Reflection_Types.binder Prims.list -> - FStar_Reflection_Types.term -> FStar_Reflection_Types.term) + FStarC_Reflection_Types.binder Prims.list -> + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term) = fun bs -> fun cod -> match bs with | [] -> cod | b::bs1 -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Arrow + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Arrow (b, - (FStar_Reflection_V2_Builtins.pack_comp - (FStar_Reflection_V2_Data.C_Total (mk_tot_arr_ln bs1 cod))))) + (FStarC_Reflection_V2_Builtins.pack_comp + (FStarC_Reflection_V2_Data.C_Total + (mk_tot_arr_ln bs1 cod))))) let rec (mk_arr_ln : - FStar_Reflection_Types.binder Prims.list -> - FStar_Reflection_Types.comp -> FStar_Reflection_Types.term) + FStarC_Reflection_Types.binder Prims.list -> + FStarC_Reflection_Types.comp -> FStarC_Reflection_Types.term) = fun bs -> fun cod -> match bs with | b::[] -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Arrow (b, cod)) + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Arrow (b, cod)) | b::bs1 -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Arrow + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Arrow (b, - (FStar_Reflection_V2_Builtins.pack_comp - (FStar_Reflection_V2_Data.C_Total (mk_arr_ln bs1 cod))))) -let (fv_to_string : FStar_Reflection_Types.fv -> Prims.string) = + (FStarC_Reflection_V2_Builtins.pack_comp + (FStarC_Reflection_V2_Data.C_Total (mk_arr_ln bs1 cod))))) +let (fv_to_string : FStarC_Reflection_Types.fv -> Prims.string) = fun fv -> - FStar_Reflection_V2_Builtins.implode_qn - (FStar_Reflection_V2_Builtins.inspect_fv fv) -let (mk_stringlit : Prims.string -> FStar_Reflection_Types.term) = + FStarC_Reflection_V2_Builtins.implode_qn + (FStarC_Reflection_V2_Builtins.inspect_fv fv) +let (mk_stringlit : Prims.string -> FStarC_Reflection_Types.term) = fun s -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const - (FStar_Reflection_V2_Data.C_String s)) + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const + (FStarC_Reflection_V2_Data.C_String s)) let (mk_strcat : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> FStar_Reflection_Types.term) + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term) = fun t1 -> fun t2 -> mk_e_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv ["Prims"; "strcat"]))) + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "strcat"]))) [t1; t2] let (mk_cons : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> FStar_Reflection_Types.term) + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term) = fun h -> fun t -> mk_e_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv FStar_Reflection_Const.cons_qn))) [h; t] let (mk_cons_t : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> FStar_Reflection_Types.term) + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term) = fun ty -> fun h -> fun t -> mk_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv FStar_Reflection_Const.cons_qn))) - [(ty, FStar_Reflection_V2_Data.Q_Implicit); - (h, FStar_Reflection_V2_Data.Q_Explicit); - (t, FStar_Reflection_V2_Data.Q_Explicit)] + [(ty, FStarC_Reflection_V2_Data.Q_Implicit); + (h, FStarC_Reflection_V2_Data.Q_Explicit); + (t, FStarC_Reflection_V2_Data.Q_Explicit)] let rec (mk_list : - FStar_Reflection_Types.term Prims.list -> FStar_Reflection_Types.term) = + FStarC_Reflection_Types.term Prims.list -> FStarC_Reflection_Types.term) = fun ts -> match ts with | [] -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv FStar_Reflection_Const.nil_qn)) | t::ts1 -> mk_cons t (mk_list ts1) let (mktuple_n : - FStar_Reflection_Types.term Prims.list -> FStar_Reflection_Types.term) = + FStarC_Reflection_Types.term Prims.list -> FStarC_Reflection_Types.term) = fun ts -> match FStar_List_Tot_Base.length ts with | uu___ when uu___ = Prims.int_zero -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const FStar_Reflection_V2_Data.C_Unit) + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const + FStarC_Reflection_V2_Data.C_Unit) | uu___ when uu___ = Prims.int_one -> let uu___1 = ts in (match uu___1 with | x::[] -> x) | n -> @@ -241,22 +254,22 @@ let (mktuple_n : | uu___ when uu___ = (Prims.of_int (8)) -> FStar_Reflection_Const.mktuple8_qn in mk_e_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv qn))) ts + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv qn))) ts let (destruct_tuple : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term Prims.list FStar_Pervasives_Native.option) + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term Prims.list FStar_Pervasives_Native.option) = fun t -> let uu___ = FStar_Reflection_V2_Collect.collect_app_ln t in match uu___ with | (head, args) -> - (match FStar_Reflection_V2_Builtins.inspect_ln head with - | FStar_Reflection_V2_Data.Tv_FVar fv -> + (match FStarC_Reflection_V2_Builtins.inspect_ln head with + | FStarC_Reflection_V2_Data.Tv_FVar fv -> if FStar_List_Tot_Base.mem - (FStar_Reflection_V2_Builtins.inspect_fv fv) + (FStarC_Reflection_V2_Builtins.inspect_fv fv) [FStar_Reflection_Const.mktuple2_qn; FStar_Reflection_Const.mktuple3_qn; FStar_Reflection_Const.mktuple4_qn; @@ -271,134 +284,137 @@ let (destruct_tuple : match uu___1 with | (t1, q) -> (match q with - | FStar_Reflection_V2_Data.Q_Explicit -> [t1] + | FStarC_Reflection_V2_Data.Q_Explicit -> [t1] | uu___2 -> [])) args) else FStar_Pervasives_Native.None | uu___1 -> FStar_Pervasives_Native.None) let (mkpair : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> FStar_Reflection_Types.term) + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term) = fun t1 -> fun t2 -> mktuple_n [t1; t2] -let rec (head : FStar_Reflection_Types.term -> FStar_Reflection_Types.term) = +let rec (head : FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term) + = fun t -> - match FStar_Reflection_V2_Builtins.inspect_ln t with - | FStar_Reflection_V2_Data.Tv_Match (t1, uu___, uu___1) -> head t1 - | FStar_Reflection_V2_Data.Tv_Let (uu___, uu___1, uu___2, t1, uu___3) -> + match FStarC_Reflection_V2_Builtins.inspect_ln t with + | FStarC_Reflection_V2_Data.Tv_Match (t1, uu___, uu___1) -> head t1 + | FStarC_Reflection_V2_Data.Tv_Let (uu___, uu___1, uu___2, t1, uu___3) -> head t1 - | FStar_Reflection_V2_Data.Tv_Abs (uu___, t1) -> head t1 - | FStar_Reflection_V2_Data.Tv_Refine (uu___, t1) -> head t1 - | FStar_Reflection_V2_Data.Tv_App (t1, uu___) -> head t1 - | FStar_Reflection_V2_Data.Tv_AscribedT (t1, uu___, uu___1, uu___2) -> + | FStarC_Reflection_V2_Data.Tv_Abs (uu___, t1) -> head t1 + | FStarC_Reflection_V2_Data.Tv_Refine (uu___, t1) -> head t1 + | FStarC_Reflection_V2_Data.Tv_App (t1, uu___) -> head t1 + | FStarC_Reflection_V2_Data.Tv_AscribedT (t1, uu___, uu___1, uu___2) -> head t1 - | FStar_Reflection_V2_Data.Tv_AscribedC (t1, uu___, uu___1, uu___2) -> + | FStarC_Reflection_V2_Data.Tv_AscribedC (t1, uu___, uu___1, uu___2) -> head t1 - | FStar_Reflection_V2_Data.Tv_Unknown -> t - | FStar_Reflection_V2_Data.Tv_Uvar (uu___, uu___1) -> t - | FStar_Reflection_V2_Data.Tv_Const uu___ -> t - | FStar_Reflection_V2_Data.Tv_Type uu___ -> t - | FStar_Reflection_V2_Data.Tv_Var uu___ -> t - | FStar_Reflection_V2_Data.Tv_BVar uu___ -> t - | FStar_Reflection_V2_Data.Tv_FVar uu___ -> t - | FStar_Reflection_V2_Data.Tv_UInst (uu___, uu___1) -> t - | FStar_Reflection_V2_Data.Tv_Arrow (uu___, uu___1) -> t - | FStar_Reflection_V2_Data.Tv_Unsupp -> t -let (is_fvar : FStar_Reflection_Types.term -> Prims.string -> Prims.bool) = + | FStarC_Reflection_V2_Data.Tv_Unknown -> t + | FStarC_Reflection_V2_Data.Tv_Uvar (uu___, uu___1) -> t + | FStarC_Reflection_V2_Data.Tv_Const uu___ -> t + | FStarC_Reflection_V2_Data.Tv_Type uu___ -> t + | FStarC_Reflection_V2_Data.Tv_Var uu___ -> t + | FStarC_Reflection_V2_Data.Tv_BVar uu___ -> t + | FStarC_Reflection_V2_Data.Tv_FVar uu___ -> t + | FStarC_Reflection_V2_Data.Tv_UInst (uu___, uu___1) -> t + | FStarC_Reflection_V2_Data.Tv_Arrow (uu___, uu___1) -> t + | FStarC_Reflection_V2_Data.Tv_Unsupp -> t +let (is_fvar : FStarC_Reflection_Types.term -> Prims.string -> Prims.bool) = fun t -> fun nm -> match inspect_ln_unascribe t with - | FStar_Reflection_V2_Data.Tv_FVar fv -> - (FStar_Reflection_V2_Builtins.implode_qn - (FStar_Reflection_V2_Builtins.inspect_fv fv)) + | FStarC_Reflection_V2_Data.Tv_FVar fv -> + (FStarC_Reflection_V2_Builtins.implode_qn + (FStarC_Reflection_V2_Builtins.inspect_fv fv)) = nm - | FStar_Reflection_V2_Data.Tv_UInst (fv, uu___) -> - (FStar_Reflection_V2_Builtins.implode_qn - (FStar_Reflection_V2_Builtins.inspect_fv fv)) + | FStarC_Reflection_V2_Data.Tv_UInst (fv, uu___) -> + (FStarC_Reflection_V2_Builtins.implode_qn + (FStarC_Reflection_V2_Builtins.inspect_fv fv)) = nm | uu___ -> false let rec (is_any_fvar : - FStar_Reflection_Types.term -> Prims.string Prims.list -> Prims.bool) = + FStarC_Reflection_Types.term -> Prims.string Prims.list -> Prims.bool) = fun t -> fun nms -> match nms with | [] -> false | v::vs -> (is_fvar t v) || (is_any_fvar t vs) -let (is_uvar : FStar_Reflection_Types.term -> Prims.bool) = +let (is_uvar : FStarC_Reflection_Types.term -> Prims.bool) = fun t -> - match FStar_Reflection_V2_Builtins.inspect_ln (head t) with - | FStar_Reflection_V2_Data.Tv_Uvar (uu___, uu___1) -> true + match FStarC_Reflection_V2_Builtins.inspect_ln (head t) with + | FStarC_Reflection_V2_Data.Tv_Uvar (uu___, uu___1) -> true | uu___ -> false let (binder_set_qual : - FStar_Reflection_V2_Data.aqualv -> - FStar_Reflection_Types.binder -> FStar_Reflection_Types.binder) + FStarC_Reflection_V2_Data.aqualv -> + FStarC_Reflection_Types.binder -> FStarC_Reflection_Types.binder) = fun q -> fun b -> - let bview = FStar_Reflection_V2_Builtins.inspect_binder b in - FStar_Reflection_V2_Builtins.pack_binder + let bview = FStarC_Reflection_V2_Builtins.inspect_binder b in + FStarC_Reflection_V2_Builtins.pack_binder { - FStar_Reflection_V2_Data.sort2 = - (bview.FStar_Reflection_V2_Data.sort2); - FStar_Reflection_V2_Data.qual = q; - FStar_Reflection_V2_Data.attrs = - (bview.FStar_Reflection_V2_Data.attrs); - FStar_Reflection_V2_Data.ppname2 = - (bview.FStar_Reflection_V2_Data.ppname2) + FStarC_Reflection_V2_Data.sort2 = + (bview.FStarC_Reflection_V2_Data.sort2); + FStarC_Reflection_V2_Data.qual = q; + FStarC_Reflection_V2_Data.attrs = + (bview.FStarC_Reflection_V2_Data.attrs); + FStarC_Reflection_V2_Data.ppname2 = + (bview.FStarC_Reflection_V2_Data.ppname2) } let (add_check_with : - FStar_VConfig.vconfig -> - FStar_Reflection_Types.sigelt -> FStar_Reflection_Types.sigelt) + FStarC_VConfig.vconfig -> + FStarC_Reflection_Types.sigelt -> FStarC_Reflection_Types.sigelt) = fun vcfg -> fun se -> - let attrs = FStar_Reflection_V2_Builtins.sigelt_attrs se in - let vcfg_t = FStar_Reflection_V2_Builtins.embed_vconfig vcfg in + let attrs = FStarC_Reflection_V2_Builtins.sigelt_attrs se in + let vcfg_t = FStarC_Reflection_V2_Builtins.embed_vconfig vcfg in let t = - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Stubs"; "VConfig"; "check_with"]))), - (vcfg_t, FStar_Reflection_V2_Data.Q_Explicit))) in - FStar_Reflection_V2_Builtins.set_sigelt_attrs (t :: attrs) se -let (un_uinst : FStar_Reflection_Types.term -> FStar_Reflection_Types.term) = + (vcfg_t, FStarC_Reflection_V2_Data.Q_Explicit))) in + FStarC_Reflection_V2_Builtins.set_sigelt_attrs (t :: attrs) se +let (un_uinst : FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term) + = fun t -> - match FStar_Reflection_V2_Builtins.inspect_ln t with - | FStar_Reflection_V2_Data.Tv_UInst (fv, uu___) -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar fv) + match FStarC_Reflection_V2_Builtins.inspect_ln t with + | FStarC_Reflection_V2_Data.Tv_UInst (fv, uu___) -> + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar fv) | uu___ -> t let rec (is_name_imp : - FStar_Reflection_Types.name -> FStar_Reflection_Types.term -> Prims.bool) = + FStarC_Reflection_Types.name -> FStarC_Reflection_Types.term -> Prims.bool) + = fun nm -> fun t -> match inspect_ln_unascribe t with - | FStar_Reflection_V2_Data.Tv_FVar fv -> - if (FStar_Reflection_V2_Builtins.inspect_fv fv) = nm + | FStarC_Reflection_V2_Data.Tv_FVar fv -> + if (FStarC_Reflection_V2_Builtins.inspect_fv fv) = nm then true else false - | FStar_Reflection_V2_Data.Tv_UInst (fv, uu___) -> - if (FStar_Reflection_V2_Builtins.inspect_fv fv) = nm + | FStarC_Reflection_V2_Data.Tv_UInst (fv, uu___) -> + if (FStarC_Reflection_V2_Builtins.inspect_fv fv) = nm then true else false - | FStar_Reflection_V2_Data.Tv_App - (l, (uu___, FStar_Reflection_V2_Data.Q_Implicit)) -> + | FStarC_Reflection_V2_Data.Tv_App + (l, (uu___, FStarC_Reflection_V2_Data.Q_Implicit)) -> is_name_imp nm l | uu___ -> false let (unsquash_term : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term FStar_Pervasives_Native.option) + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term FStar_Pervasives_Native.option) = fun t -> match inspect_ln_unascribe t with - | FStar_Reflection_V2_Data.Tv_App - (l, (r, FStar_Reflection_V2_Data.Q_Explicit)) -> + | FStarC_Reflection_V2_Data.Tv_App + (l, (r, FStarC_Reflection_V2_Data.Q_Explicit)) -> if is_name_imp FStar_Reflection_Const.squash_qn l then FStar_Pervasives_Native.Some r else FStar_Pervasives_Native.None | uu___ -> FStar_Pervasives_Native.None let (maybe_unsquash_term : - FStar_Reflection_Types.term -> FStar_Reflection_Types.term) = + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term) = fun t -> match unsquash_term t with | FStar_Pervasives_Native.Some t' -> t' diff --git a/ocaml/fstar-lib/generated/FStar_Reflection_V2_Derived_Lemmas.ml b/ocaml/fstar-lib/generated/FStar_Reflection_V2_Derived_Lemmas.ml index a6a5315ee2c..9ad19feb760 100644 --- a/ocaml/fstar-lib/generated/FStar_Reflection_V2_Derived_Lemmas.ml +++ b/ocaml/fstar-lib/generated/FStar_Reflection_V2_Derived_Lemmas.ml @@ -5,22 +5,25 @@ type ('a, 'r, 'l, 'r1) op_Less_Less_Colon = unit let rec list_ref : 'a 'p . 'a Prims.list -> 'a Prims.list = fun l -> match l with | [] -> [] | x::xs -> x :: (list_ref xs) let (collect_app_ref : - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.term * FStar_Reflection_V2_Data.argv Prims.list)) + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.term * FStarC_Reflection_V2_Data.argv + Prims.list)) = fun t -> let uu___ = FStar_Reflection_V2_Collect.collect_app_ln t in match uu___ with | (h, a) -> (h, (list_ref a)) let (collect_abs_ln_ref : - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.binder Prims.list * FStar_Reflection_Types.term)) + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.binder Prims.list * + FStarC_Reflection_Types.term)) = fun t -> let uu___ = FStar_Reflection_V2_Collect.collect_abs_ln t in match uu___ with | (bds, body) -> ((list_ref bds), body) let (collect_arr_ln_bs_ref : - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.binder Prims.list * FStar_Reflection_Types.comp)) + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.binder Prims.list * + FStarC_Reflection_Types.comp)) = fun t -> let uu___ = FStar_Reflection_V2_Collect.collect_arr_ln_bs t in diff --git a/ocaml/fstar-lib/generated/FStar_Reflection_V2_Embeddings.ml b/ocaml/fstar-lib/generated/FStar_Reflection_V2_Embeddings.ml deleted file mode 100644 index 80a8be58b52..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Reflection_V2_Embeddings.ml +++ /dev/null @@ -1,2688 +0,0 @@ -open Prims -type namedv = FStar_Syntax_Syntax.bv -let mk_emb : - 'uuuuu . - (FStar_Compiler_Range_Type.range -> 'uuuuu -> FStar_Syntax_Syntax.term) - -> - (FStar_Syntax_Syntax.term -> 'uuuuu FStar_Pervasives_Native.option) -> - FStar_Syntax_Syntax.term -> - 'uuuuu FStar_Syntax_Embeddings_Base.embedding - = - fun f -> - fun g -> - fun t -> - let uu___ = FStar_Syntax_Embeddings_Base.term_as_fv t in - FStar_Syntax_Embeddings_Base.mk_emb - (fun x -> fun r -> fun _topt -> fun _norm -> f r x) - (fun x -> fun _norm -> g x) uu___ -let embed : - 'a . - 'a FStar_Syntax_Embeddings_Base.embedding -> - FStar_Compiler_Range_Type.range -> 'a -> FStar_Syntax_Syntax.term - = - fun uu___ -> - fun r -> - fun x -> - let uu___1 = FStar_Syntax_Embeddings_Base.embed uu___ x in - uu___1 r FStar_Pervasives_Native.None - FStar_Syntax_Embeddings_Base.id_norm_cb -let try_unembed : - 'a . - 'a FStar_Syntax_Embeddings_Base.embedding -> - FStar_Syntax_Syntax.term -> 'a FStar_Pervasives_Native.option - = - fun uu___ -> - fun x -> - FStar_Syntax_Embeddings_Base.try_unembed uu___ x - FStar_Syntax_Embeddings_Base.id_norm_cb -let curry : - 'uuuuu 'uuuuu1 'uuuuu2 . - (('uuuuu * 'uuuuu1) -> 'uuuuu2) -> 'uuuuu -> 'uuuuu1 -> 'uuuuu2 - = fun f -> fun x -> fun y -> f (x, y) -let curry3 : - 'uuuuu 'uuuuu1 'uuuuu2 'uuuuu3 . - (('uuuuu * 'uuuuu1 * 'uuuuu2) -> 'uuuuu3) -> - 'uuuuu -> 'uuuuu1 -> 'uuuuu2 -> 'uuuuu3 - = fun f -> fun x -> fun y -> fun z -> f (x, y, z) -let curry4 : - 'uuuuu 'uuuuu1 'uuuuu2 'uuuuu3 'uuuuu4 . - (('uuuuu * 'uuuuu1 * 'uuuuu2 * 'uuuuu3) -> 'uuuuu4) -> - 'uuuuu -> 'uuuuu1 -> 'uuuuu2 -> 'uuuuu3 -> 'uuuuu4 - = fun f -> fun x -> fun y -> fun z -> fun w -> f (x, y, z, w) -let curry5 : - 'uuuuu 'uuuuu1 'uuuuu2 'uuuuu3 'uuuuu4 'uuuuu5 . - (('uuuuu * 'uuuuu1 * 'uuuuu2 * 'uuuuu3 * 'uuuuu4) -> 'uuuuu5) -> - 'uuuuu -> 'uuuuu1 -> 'uuuuu2 -> 'uuuuu3 -> 'uuuuu4 -> 'uuuuu5 - = fun f -> fun x -> fun y -> fun z -> fun w -> fun v -> f (x, y, z, w, v) -let (head_fv_and_args : - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.fv * FStar_Syntax_Syntax.args) - FStar_Pervasives_Native.option) - = - fun t -> - let t1 = FStar_Syntax_Util.unascribe t in - let uu___ = FStar_Syntax_Util.head_and_args t1 in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = FStar_Syntax_Util.un_uinst hd in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - FStar_Pervasives_Native.Some (fv, args) - | uu___2 -> FStar_Pervasives_Native.None) -let (noaqs : FStar_Syntax_Syntax.antiquotations) = (Prims.int_zero, []) -let (e_bv : FStar_Syntax_Syntax.bv FStar_Syntax_Embeddings_Base.embedding) = - FStar_Syntax_Embeddings_Base.e_lazy FStar_Syntax_Syntax.Lazy_bv - FStar_Reflection_V2_Constants.fstar_refl_bv -let (e_namedv : namedv FStar_Syntax_Embeddings_Base.embedding) = - FStar_Syntax_Embeddings_Base.e_lazy FStar_Syntax_Syntax.Lazy_namedv - FStar_Reflection_V2_Constants.fstar_refl_namedv -let (e_binder : - FStar_Syntax_Syntax.binder FStar_Syntax_Embeddings_Base.embedding) = - FStar_Syntax_Embeddings_Base.e_lazy FStar_Syntax_Syntax.Lazy_binder - FStar_Reflection_V2_Constants.fstar_refl_binder -let (e_fv : FStar_Syntax_Syntax.fv FStar_Syntax_Embeddings_Base.embedding) = - FStar_Syntax_Embeddings_Base.e_lazy FStar_Syntax_Syntax.Lazy_fvar - FStar_Reflection_V2_Constants.fstar_refl_fv -let (e_comp : - FStar_Syntax_Syntax.comp FStar_Syntax_Embeddings_Base.embedding) = - FStar_Syntax_Embeddings_Base.e_lazy FStar_Syntax_Syntax.Lazy_comp - FStar_Reflection_V2_Constants.fstar_refl_comp -let (e_universe : - FStar_Syntax_Syntax.universe FStar_Syntax_Embeddings_Base.embedding) = - FStar_Syntax_Embeddings_Base.e_lazy FStar_Syntax_Syntax.Lazy_universe - FStar_Reflection_V2_Constants.fstar_refl_universe -let (e_ident : FStar_Ident.ident FStar_Syntax_Embeddings_Base.embedding) = - FStar_Syntax_Embeddings_Base.e_lazy FStar_Syntax_Syntax.Lazy_ident - FStar_Reflection_V2_Constants.fstar_refl_ident -let (e_env : - FStar_TypeChecker_Env.env FStar_Syntax_Embeddings_Base.embedding) = - FStar_Syntax_Embeddings_Base.e_lazy FStar_Syntax_Syntax.Lazy_env - FStar_Reflection_V2_Constants.fstar_refl_env -let (e_sigelt : - FStar_Syntax_Syntax.sigelt FStar_Syntax_Embeddings_Base.embedding) = - FStar_Syntax_Embeddings_Base.e_lazy FStar_Syntax_Syntax.Lazy_sigelt - FStar_Reflection_V2_Constants.fstar_refl_sigelt -let (e_letbinding : - FStar_Syntax_Syntax.letbinding FStar_Syntax_Embeddings_Base.embedding) = - FStar_Syntax_Embeddings_Base.e_lazy FStar_Syntax_Syntax.Lazy_letbinding - FStar_Reflection_V2_Constants.fstar_refl_letbinding -let (e_ctx_uvar_and_subst : - FStar_Syntax_Syntax.ctx_uvar_and_subst - FStar_Syntax_Embeddings_Base.embedding) - = - FStar_Syntax_Embeddings_Base.e_lazy FStar_Syntax_Syntax.Lazy_uvar - FStar_Reflection_V2_Constants.fstar_refl_ctx_uvar_and_subst -let (e_universe_uvar : - FStar_Syntax_Syntax.universe_uvar FStar_Syntax_Embeddings_Base.embedding) = - FStar_Syntax_Embeddings_Base.e_lazy FStar_Syntax_Syntax.Lazy_universe_uvar - FStar_Reflection_V2_Constants.fstar_refl_universe_uvar -let rec mapM_opt : - 'a 'b . - ('a -> 'b FStar_Pervasives_Native.option) -> - 'a Prims.list -> 'b Prims.list FStar_Pervasives_Native.option - = - fun f -> - fun l -> - match l with - | [] -> FStar_Pervasives_Native.Some [] - | x::xs -> - let uu___ = f x in - FStar_Compiler_Util.bind_opt uu___ - (fun x1 -> - let uu___1 = mapM_opt f xs in - FStar_Compiler_Util.bind_opt uu___1 - (fun xs1 -> FStar_Pervasives_Native.Some (x1 :: xs1))) -let (e_term_aq : - FStar_Syntax_Syntax.antiquotations -> - FStar_Syntax_Syntax.term FStar_Syntax_Embeddings_Base.embedding) - = - fun aq -> - let embed_term rng t = - let qi = - { - FStar_Syntax_Syntax.qkind = FStar_Syntax_Syntax.Quote_static; - FStar_Syntax_Syntax.antiquotations = aq - } in - FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_quoted (t, qi)) rng in - let rec unembed_term t = - let apply_antiquotations t1 aq1 = - let uu___ = aq1 in - match uu___ with - | (shift, aqs) -> - let aqs1 = FStar_Compiler_List.rev aqs in - let uu___1 = mapM_opt unembed_term aqs1 in - FStar_Compiler_Util.bind_opt uu___1 - (fun aq_ts -> - let uu___2 = - let uu___3 = - FStar_Compiler_List.mapi - (fun i -> - fun at -> - let x = - FStar_Syntax_Syntax.new_bv - FStar_Pervasives_Native.None - FStar_Syntax_Syntax.t_term in - ((FStar_Syntax_Syntax.DB ((shift + i), x)), - (FStar_Syntax_Syntax.NT (x, at)))) aq_ts in - FStar_Compiler_List.unzip uu___3 in - match uu___2 with - | (subst_open, subst) -> - let uu___3 = - let uu___4 = FStar_Syntax_Subst.subst subst_open t1 in - FStar_Syntax_Subst.subst subst uu___4 in - FStar_Pervasives_Native.Some uu___3) in - let t1 = FStar_Syntax_Util.unmeta t in - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t1 in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_quoted (tm, qi) -> - apply_antiquotations tm qi.FStar_Syntax_Syntax.antiquotations - | uu___1 -> FStar_Pervasives_Native.None in - mk_emb embed_term unembed_term FStar_Syntax_Syntax.t_term -let (e_term : - FStar_Syntax_Syntax.term FStar_Syntax_Embeddings_Base.embedding) = - e_term_aq noaqs -let (e_sort : - FStar_Syntax_Syntax.term FStar_Compiler_Sealed.sealed - FStar_Syntax_Embeddings_Base.embedding) - = FStar_Syntax_Embeddings.e_sealed e_term -let (e_ppname : - FStar_Reflection_V2_Data.ppname_t FStar_Syntax_Embeddings_Base.embedding) = - FStar_Syntax_Embeddings.e_sealed FStar_Syntax_Embeddings.e_string -let (e_aqualv : - FStar_Reflection_V2_Data.aqualv FStar_Syntax_Embeddings_Base.embedding) = - let embed_aqualv rng q = - let r = - match q with - | FStar_Reflection_V2_Data.Q_Explicit -> - FStar_Reflection_V2_Constants.ref_Q_Explicit.FStar_Reflection_V2_Constants.t - | FStar_Reflection_V2_Data.Q_Implicit -> - FStar_Reflection_V2_Constants.ref_Q_Implicit.FStar_Reflection_V2_Constants.t - | FStar_Reflection_V2_Data.Q_Equality -> - FStar_Reflection_V2_Constants.ref_Q_Equality.FStar_Reflection_V2_Constants.t - | FStar_Reflection_V2_Data.Q_Meta t -> - let uu___ = - let uu___1 = - let uu___2 = embed e_term rng t in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Q_Meta.FStar_Reflection_V2_Constants.t - uu___ FStar_Compiler_Range_Type.dummyRange in - { - FStar_Syntax_Syntax.n = (r.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = rng; - FStar_Syntax_Syntax.vars = (r.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = (r.FStar_Syntax_Syntax.hash_code) - } in - let unembed_aqualv t = - let uu___ = head_fv_and_args t in - FStar_Syntax_Embeddings_AppEmb.op_let_Question uu___ - (fun uu___1 -> - match uu___1 with - | (fv, args) -> - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Q_Explicit.FStar_Reflection_V2_Constants.lid - then - let uu___2 = - FStar_Syntax_Embeddings_AppEmb.pure - FStar_Reflection_V2_Data.Q_Explicit in - FStar_Syntax_Embeddings_AppEmb.run args uu___2 - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Q_Implicit.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.pure - FStar_Reflection_V2_Data.Q_Implicit in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Q_Equality.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.pure - FStar_Reflection_V2_Data.Q_Equality in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Q_Meta.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___3 -> - FStar_Reflection_V2_Data.Q_Meta uu___3) e_term in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else FStar_Pervasives_Native.None) in - mk_emb embed_aqualv unembed_aqualv - FStar_Reflection_V2_Constants.fstar_refl_aqualv -let (e_binders : - FStar_Syntax_Syntax.binders FStar_Syntax_Embeddings_Base.embedding) = - FStar_Syntax_Embeddings.e_list e_binder -let (e_universe_view : - FStar_Reflection_V2_Data.universe_view - FStar_Syntax_Embeddings_Base.embedding) - = - let embed_universe_view rng uv = - match uv with - | FStar_Reflection_V2_Data.Uv_Zero -> - FStar_Reflection_V2_Constants.ref_Uv_Zero.FStar_Reflection_V2_Constants.t - | FStar_Reflection_V2_Data.Uv_Succ u -> - let uu___ = - let uu___1 = - let uu___2 = embed e_universe rng u in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Uv_Succ.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Reflection_V2_Data.Uv_Max us -> - let uu___ = - let uu___1 = - let uu___2 = - embed (FStar_Syntax_Embeddings.e_list e_universe) rng us in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Uv_Max.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Reflection_V2_Data.Uv_BVar n -> - let uu___ = - let uu___1 = - let uu___2 = embed FStar_Syntax_Embeddings.e_int rng n in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Uv_BVar.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Reflection_V2_Data.Uv_Name i -> - let uu___ = - let uu___1 = - let uu___2 = embed e_ident rng i in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Uv_Name.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Reflection_V2_Data.Uv_Unif u -> - let uu___ = - let uu___1 = - let uu___2 = embed e_universe_uvar rng u in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Uv_Unif.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Reflection_V2_Data.Uv_Unk -> - FStar_Reflection_V2_Constants.ref_Uv_Unk.FStar_Reflection_V2_Constants.t in - let unembed_universe_view t = - let uu___ = head_fv_and_args t in - FStar_Syntax_Embeddings_AppEmb.op_let_Question uu___ - (fun uu___1 -> - match uu___1 with - | (fv, args) -> - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Uv_Zero.FStar_Reflection_V2_Constants.lid - then - let uu___2 = - FStar_Syntax_Embeddings_AppEmb.pure - FStar_Reflection_V2_Data.Uv_Zero in - FStar_Syntax_Embeddings_AppEmb.run args uu___2 - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Uv_Succ.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___3 -> FStar_Reflection_V2_Data.Uv_Succ uu___3) - e_universe in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Uv_Max.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___3 -> FStar_Reflection_V2_Data.Uv_Max uu___3) - (FStar_Syntax_Embeddings.e_list e_universe) in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Uv_BVar.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___3 -> - FStar_Reflection_V2_Data.Uv_BVar uu___3) - FStar_Syntax_Embeddings.e_int in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Uv_Name.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___3 -> - FStar_Reflection_V2_Data.Uv_Name uu___3) - e_ident in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Uv_Unif.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___3 -> - FStar_Reflection_V2_Data.Uv_Unif uu___3) - e_universe_uvar in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Uv_Unk.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.pure - FStar_Reflection_V2_Data.Uv_Unk in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else FStar_Pervasives_Native.None) in - mk_emb embed_universe_view unembed_universe_view - FStar_Reflection_V2_Constants.fstar_refl_universe_view -let (e_vconst : - FStar_Reflection_V2_Data.vconst FStar_Syntax_Embeddings_Base.embedding) = - let embed_const rng c = - let r = - match c with - | FStar_Reflection_V2_Data.C_Unit -> - FStar_Reflection_V2_Constants.ref_C_Unit.FStar_Reflection_V2_Constants.t - | FStar_Reflection_V2_Data.C_True -> - FStar_Reflection_V2_Constants.ref_C_True.FStar_Reflection_V2_Constants.t - | FStar_Reflection_V2_Data.C_False -> - FStar_Reflection_V2_Constants.ref_C_False.FStar_Reflection_V2_Constants.t - | FStar_Reflection_V2_Data.C_Int i -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_BigInt.string_of_big_int i in - FStar_Syntax_Util.exp_int uu___3 in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_C_Int.FStar_Reflection_V2_Constants.t - uu___ FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V2_Data.C_String s -> - let uu___ = - let uu___1 = - let uu___2 = embed FStar_Syntax_Embeddings.e_string rng s in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_C_String.FStar_Reflection_V2_Constants.t - uu___ FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V2_Data.C_Range r1 -> - let uu___ = - let uu___1 = - let uu___2 = embed FStar_Syntax_Embeddings.e_range rng r1 in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_C_Range.FStar_Reflection_V2_Constants.t - uu___ FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V2_Data.C_Reify -> - FStar_Reflection_V2_Constants.ref_C_Reify.FStar_Reflection_V2_Constants.t - | FStar_Reflection_V2_Data.C_Reflect ns -> - let uu___ = - let uu___1 = - let uu___2 = embed FStar_Syntax_Embeddings.e_string_list rng ns in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_C_Reflect.FStar_Reflection_V2_Constants.t - uu___ FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V2_Data.C_Real s -> - let uu___ = - let uu___1 = - let uu___2 = embed FStar_Syntax_Embeddings.e_string rng s in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_C_Real.FStar_Reflection_V2_Constants.t - uu___ FStar_Compiler_Range_Type.dummyRange in - { - FStar_Syntax_Syntax.n = (r.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = rng; - FStar_Syntax_Syntax.vars = (r.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = (r.FStar_Syntax_Syntax.hash_code) - } in - let unembed_const t = - let uu___ = head_fv_and_args t in - FStar_Syntax_Embeddings_AppEmb.op_let_Question uu___ - (fun uu___1 -> - match uu___1 with - | (fv, args) -> - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_C_Unit.FStar_Reflection_V2_Constants.lid - then - let uu___2 = - FStar_Syntax_Embeddings_AppEmb.pure - FStar_Reflection_V2_Data.C_Unit in - FStar_Syntax_Embeddings_AppEmb.run args uu___2 - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_C_True.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.pure - FStar_Reflection_V2_Data.C_True in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_C_False.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.pure - FStar_Reflection_V2_Data.C_False in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_C_Int.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___3 -> - FStar_Reflection_V2_Data.C_Int uu___3) - FStar_Syntax_Embeddings.e_int in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_C_String.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___3 -> - FStar_Reflection_V2_Data.C_String uu___3) - FStar_Syntax_Embeddings.e_string in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_C_Range.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___3 -> - FStar_Reflection_V2_Data.C_Range uu___3) - FStar_Syntax_Embeddings.e_range in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_C_Reify.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.pure - FStar_Reflection_V2_Data.C_Reify in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_C_Reflect.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___3 -> - FStar_Reflection_V2_Data.C_Reflect - uu___3) - FStar_Syntax_Embeddings.e_string_list in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_C_Real.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___3 -> - FStar_Reflection_V2_Data.C_Real uu___3) - FStar_Syntax_Embeddings.e_string in - FStar_Syntax_Embeddings_AppEmb.run args - uu___2) - else FStar_Pervasives_Native.None) in - mk_emb embed_const unembed_const - FStar_Reflection_V2_Constants.fstar_refl_vconst -let rec e_pattern_aq : - 'uuuuu . - 'uuuuu -> - FStar_Reflection_V2_Data.pattern FStar_Syntax_Embeddings_Base.embedding - = - fun aq -> - let rec embed_pattern rng p = - match p with - | FStar_Reflection_V2_Data.Pat_Constant c -> - let uu___ = - let uu___1 = - let uu___2 = embed e_vconst rng c in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Pat_Constant.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Reflection_V2_Data.Pat_Cons (head, univs, subpats) -> - let uu___ = - let uu___1 = - let uu___2 = embed e_fv rng head in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - embed - (FStar_Syntax_Embeddings.e_option - (FStar_Syntax_Embeddings.e_list e_universe)) rng univs in - FStar_Syntax_Syntax.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = e_pattern_aq aq in - FStar_Syntax_Embeddings.e_tuple2 uu___9 - FStar_Syntax_Embeddings.e_bool in - FStar_Syntax_Embeddings.e_list uu___8 in - embed uu___7 rng subpats in - FStar_Syntax_Syntax.as_arg uu___6 in - [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Pat_Cons.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Reflection_V2_Data.Pat_Var (sort, ppname) -> - let uu___ = - let uu___1 = - let uu___2 = embed e_sort rng sort in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - embed - (FStar_Syntax_Embeddings.e_sealed - FStar_Syntax_Embeddings.e_string) rng ppname in - FStar_Syntax_Syntax.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Pat_Var.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Reflection_V2_Data.Pat_Dot_Term eopt -> - let uu___ = - let uu___1 = - let uu___2 = - embed (FStar_Syntax_Embeddings.e_option e_term) rng eopt in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Pat_Dot_Term.FStar_Reflection_V2_Constants.t - uu___ rng in - let rec unembed_pattern t = - let uu___ = head_fv_and_args t in - FStar_Syntax_Embeddings_AppEmb.op_let_Question uu___ - (fun uu___1 -> - match uu___1 with - | (fv, args) -> - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Pat_Constant.FStar_Reflection_V2_Constants.lid - then - let uu___2 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___3 -> - FStar_Reflection_V2_Data.Pat_Constant uu___3) - e_vconst in - FStar_Syntax_Embeddings_AppEmb.run args uu___2 - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Pat_Cons.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - let uu___3 = - let uu___4 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___5 -> - fun uu___6 -> - fun uu___7 -> - FStar_Reflection_V2_Data.Pat_Cons - (uu___5, uu___6, uu___7)) e_fv in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___4 - (FStar_Syntax_Embeddings.e_option - (FStar_Syntax_Embeddings.e_list e_universe)) in - let uu___4 = - let uu___5 = - let uu___6 = e_pattern_aq aq in - FStar_Syntax_Embeddings.e_tuple2 uu___6 - FStar_Syntax_Embeddings.e_bool in - FStar_Syntax_Embeddings.e_list uu___5 in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___3 uu___4 in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Pat_Var.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - let uu___3 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___4 -> - fun uu___5 -> - FStar_Reflection_V2_Data.Pat_Var - (uu___4, uu___5)) e_sort in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___3 e_ppname in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Pat_Dot_Term.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___3 -> - FStar_Reflection_V2_Data.Pat_Dot_Term uu___3) - (FStar_Syntax_Embeddings.e_option e_term) in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else FStar_Pervasives_Native.None) in - mk_emb embed_pattern unembed_pattern - FStar_Reflection_V2_Constants.fstar_refl_pattern -let (e_pattern : - FStar_Reflection_V2_Data.pattern FStar_Syntax_Embeddings_Base.embedding) = - e_pattern_aq noaqs -let (e_branch : - FStar_Reflection_V2_Data.branch FStar_Syntax_Embeddings_Base.embedding) = - FStar_Syntax_Embeddings.e_tuple2 e_pattern e_term -let (e_argv : - FStar_Reflection_V2_Data.argv FStar_Syntax_Embeddings_Base.embedding) = - FStar_Syntax_Embeddings.e_tuple2 e_term e_aqualv -let (e_args : - FStar_Reflection_V2_Data.argv Prims.list - FStar_Syntax_Embeddings_Base.embedding) - = FStar_Syntax_Embeddings.e_list e_argv -let (e_branch_aq : - FStar_Syntax_Syntax.antiquotations -> - (FStar_Reflection_V2_Data.pattern * FStar_Syntax_Syntax.term) - FStar_Syntax_Embeddings_Base.embedding) - = - fun aq -> - let uu___ = e_pattern_aq aq in - let uu___1 = e_term_aq aq in - FStar_Syntax_Embeddings.e_tuple2 uu___ uu___1 -let (e_argv_aq : - FStar_Syntax_Syntax.antiquotations -> - (FStar_Syntax_Syntax.term * FStar_Reflection_V2_Data.aqualv) - FStar_Syntax_Embeddings_Base.embedding) - = - fun aq -> - let uu___ = e_term_aq aq in - FStar_Syntax_Embeddings.e_tuple2 uu___ e_aqualv -let (e_match_returns_annotation : - (FStar_Syntax_Syntax.binder * ((FStar_Syntax_Syntax.term, - FStar_Syntax_Syntax.comp) FStar_Pervasives.either * - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option * Prims.bool)) - FStar_Pervasives_Native.option FStar_Syntax_Embeddings_Base.embedding) - = - FStar_Syntax_Embeddings.e_option - (FStar_Syntax_Embeddings.e_tuple2 e_binder - (FStar_Syntax_Embeddings.e_tuple3 - (FStar_Syntax_Embeddings.e_either e_term e_comp) - (FStar_Syntax_Embeddings.e_option e_term) - FStar_Syntax_Embeddings.e_bool)) -let (e_term_view_aq : - FStar_Syntax_Syntax.antiquotations -> - FStar_Reflection_V2_Data.term_view FStar_Syntax_Embeddings_Base.embedding) - = - fun aq -> - let push uu___ = - match uu___ with | (s, aq1) -> ((s + Prims.int_one), aq1) in - let embed_term_view rng t = - match t with - | FStar_Reflection_V2_Data.Tv_FVar fv -> - let uu___ = - let uu___1 = - let uu___2 = embed e_fv rng fv in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Tv_FVar.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Reflection_V2_Data.Tv_BVar fv -> - let uu___ = - let uu___1 = - let uu___2 = embed e_bv rng fv in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Tv_BVar.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Reflection_V2_Data.Tv_Var bv -> - let uu___ = - let uu___1 = - let uu___2 = embed e_namedv rng bv in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Tv_Var.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Reflection_V2_Data.Tv_UInst (fv, us) -> - let uu___ = - let uu___1 = - let uu___2 = embed e_fv rng fv in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - embed (FStar_Syntax_Embeddings.e_list e_universe) rng us in - FStar_Syntax_Syntax.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Tv_UInst.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Reflection_V2_Data.Tv_App (hd, a) -> - let uu___ = - let uu___1 = - let uu___2 = let uu___3 = e_term_aq aq in embed uu___3 rng hd in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = let uu___5 = e_argv_aq aq in embed uu___5 rng a in - FStar_Syntax_Syntax.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Tv_App.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Reflection_V2_Data.Tv_Abs (b, t1) -> - let uu___ = - let uu___1 = - let uu___2 = embed e_binder rng b in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = e_term_aq (push aq) in embed uu___5 rng t1 in - FStar_Syntax_Syntax.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Tv_Abs.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Reflection_V2_Data.Tv_Arrow (b, c) -> - let uu___ = - let uu___1 = - let uu___2 = embed e_binder rng b in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = embed e_comp rng c in - FStar_Syntax_Syntax.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Tv_Arrow.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Reflection_V2_Data.Tv_Type u -> - let uu___ = - let uu___1 = - let uu___2 = embed e_universe rng u in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Tv_Type.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Reflection_V2_Data.Tv_Refine (b, t1) -> - let uu___ = - let uu___1 = - let uu___2 = embed e_binder rng b in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = e_term_aq (push aq) in embed uu___5 rng t1 in - FStar_Syntax_Syntax.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Tv_Refine.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Reflection_V2_Data.Tv_Const c -> - let uu___ = - let uu___1 = - let uu___2 = embed e_vconst rng c in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Tv_Const.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Reflection_V2_Data.Tv_Uvar (u, ctx_u) -> - let uu___ = - let uu___1 = - let uu___2 = embed FStar_Syntax_Embeddings.e_int rng u in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = embed e_ctx_uvar_and_subst rng ctx_u in - FStar_Syntax_Syntax.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Tv_Uvar.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Reflection_V2_Data.Tv_Let (r, attrs, b, t1, t2) -> - let uu___ = - let uu___1 = - let uu___2 = embed FStar_Syntax_Embeddings.e_bool rng r in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - embed (FStar_Syntax_Embeddings.e_list e_term) rng attrs in - FStar_Syntax_Syntax.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = embed e_binder rng b in - FStar_Syntax_Syntax.as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = e_term_aq aq in embed uu___9 rng t1 in - FStar_Syntax_Syntax.as_arg uu___8 in - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = e_term_aq (push aq) in - embed uu___11 rng t2 in - FStar_Syntax_Syntax.as_arg uu___10 in - [uu___9] in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Tv_Let.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Reflection_V2_Data.Tv_Match (t1, ret_opt, brs) -> - let uu___ = - let uu___1 = - let uu___2 = let uu___3 = e_term_aq aq in embed uu___3 rng t1 in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = embed e_match_returns_annotation rng ret_opt in - FStar_Syntax_Syntax.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = e_branch_aq aq in - FStar_Syntax_Embeddings.e_list uu___8 in - embed uu___7 rng brs in - FStar_Syntax_Syntax.as_arg uu___6 in - [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Tv_Match.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Reflection_V2_Data.Tv_AscribedT (e, t1, tacopt, use_eq) -> - let uu___ = - let uu___1 = - let uu___2 = let uu___3 = e_term_aq aq in embed uu___3 rng e in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = let uu___5 = e_term_aq aq in embed uu___5 rng t1 in - FStar_Syntax_Syntax.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = e_term_aq aq in - FStar_Syntax_Embeddings.e_option uu___8 in - embed uu___7 rng tacopt in - FStar_Syntax_Syntax.as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - embed FStar_Syntax_Embeddings.e_bool rng use_eq in - FStar_Syntax_Syntax.as_arg uu___8 in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Tv_AscT.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Reflection_V2_Data.Tv_AscribedC (e, c, tacopt, use_eq) -> - let uu___ = - let uu___1 = - let uu___2 = let uu___3 = e_term_aq aq in embed uu___3 rng e in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = embed e_comp rng c in - FStar_Syntax_Syntax.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = e_term_aq aq in - FStar_Syntax_Embeddings.e_option uu___8 in - embed uu___7 rng tacopt in - FStar_Syntax_Syntax.as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - embed FStar_Syntax_Embeddings.e_bool rng use_eq in - FStar_Syntax_Syntax.as_arg uu___8 in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Tv_AscC.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Reflection_V2_Data.Tv_Unknown -> - let uu___ = - FStar_Reflection_V2_Constants.ref_Tv_Unknown.FStar_Reflection_V2_Constants.t in - { - FStar_Syntax_Syntax.n = (uu___.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = rng; - FStar_Syntax_Syntax.vars = (uu___.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (uu___.FStar_Syntax_Syntax.hash_code) - } - | FStar_Reflection_V2_Data.Tv_Unsupp -> - let uu___ = - FStar_Reflection_V2_Constants.ref_Tv_Unsupp.FStar_Reflection_V2_Constants.t in - { - FStar_Syntax_Syntax.n = (uu___.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = rng; - FStar_Syntax_Syntax.vars = (uu___.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (uu___.FStar_Syntax_Syntax.hash_code) - } in - let unembed_term_view t = - let uu___ = head_fv_and_args t in - FStar_Syntax_Embeddings_AppEmb.op_let_Question uu___ - (fun uu___1 -> - match uu___1 with - | (fv, args) -> - let xTv_Let a b c d e = - FStar_Reflection_V2_Data.Tv_Let (a, b, c, d, e) in - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_FVar.FStar_Reflection_V2_Constants.lid - then - let uu___2 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___3 -> FStar_Reflection_V2_Data.Tv_FVar uu___3) - e_fv in - FStar_Syntax_Embeddings_AppEmb.run args uu___2 - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_BVar.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___3 -> - FStar_Reflection_V2_Data.Tv_BVar uu___3) e_bv in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_Var.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___3 -> - FStar_Reflection_V2_Data.Tv_Var uu___3) e_namedv in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_UInst.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - let uu___3 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (curry - (fun uu___4 -> - FStar_Reflection_V2_Data.Tv_UInst uu___4)) - e_fv in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___3 - (FStar_Syntax_Embeddings.e_list e_universe) in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_App.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - let uu___3 = - let uu___4 = e_term_aq aq in - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (curry - (fun uu___5 -> - FStar_Reflection_V2_Data.Tv_App uu___5)) - uu___4 in - let uu___4 = e_argv_aq aq in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___3 uu___4 in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_Abs.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - let uu___3 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (curry - (fun uu___4 -> - FStar_Reflection_V2_Data.Tv_Abs - uu___4)) e_binder in - let uu___4 = e_term_aq (push aq) in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___3 uu___4 in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_Arrow.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - let uu___3 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (curry - (fun uu___4 -> - FStar_Reflection_V2_Data.Tv_Arrow - uu___4)) e_binder in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___3 e_comp in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_Type.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___3 -> - FStar_Reflection_V2_Data.Tv_Type - uu___3) e_universe in - FStar_Syntax_Embeddings_AppEmb.run args - uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_Refine.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - let uu___3 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (curry - (fun uu___4 -> - FStar_Reflection_V2_Data.Tv_Refine - uu___4)) e_binder in - let uu___4 = e_term_aq (push aq) in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___3 uu___4 in - FStar_Syntax_Embeddings_AppEmb.run args - uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_Const.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___3 -> - FStar_Reflection_V2_Data.Tv_Const - uu___3) e_vconst in - FStar_Syntax_Embeddings_AppEmb.run args - uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_Uvar.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - let uu___3 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (curry - (fun uu___4 -> - FStar_Reflection_V2_Data.Tv_Uvar - uu___4)) - FStar_Syntax_Embeddings.e_int in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___3 e_ctx_uvar_and_subst in - FStar_Syntax_Embeddings_AppEmb.run args - uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_Let.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - xTv_Let - FStar_Syntax_Embeddings.e_bool in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___6 - (FStar_Syntax_Embeddings.e_list - e_term) in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___5 e_binder in - let uu___5 = e_term_aq aq in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___4 uu___5 in - let uu___4 = e_term_aq (push aq) in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___3 uu___4 in - FStar_Syntax_Embeddings_AppEmb.run - args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_Match.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = e_term_aq aq in - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (curry3 - (fun uu___6 -> - FStar_Reflection_V2_Data.Tv_Match - uu___6)) uu___5 in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___4 - e_match_returns_annotation in - let uu___4 = - let uu___5 = e_branch_aq aq in - FStar_Syntax_Embeddings.e_list - uu___5 in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___3 uu___4 in - FStar_Syntax_Embeddings_AppEmb.run - args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_AscT.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = e_term_aq aq in - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (curry4 - (fun uu___7 -> - FStar_Reflection_V2_Data.Tv_AscribedT - uu___7)) uu___6 in - let uu___6 = e_term_aq aq in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___5 uu___6 in - let uu___5 = - let uu___6 = e_term_aq aq in - FStar_Syntax_Embeddings.e_option - uu___6 in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___4 uu___5 in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___3 - FStar_Syntax_Embeddings.e_bool in - FStar_Syntax_Embeddings_AppEmb.run - args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_AscC.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - e_term_aq aq in - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (curry4 - (fun uu___7 -> - FStar_Reflection_V2_Data.Tv_AscribedC - uu___7)) - uu___6 in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___5 e_comp in - let uu___5 = - let uu___6 = e_term_aq aq in - FStar_Syntax_Embeddings.e_option - uu___6 in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___4 uu___5 in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___3 - FStar_Syntax_Embeddings.e_bool in - FStar_Syntax_Embeddings_AppEmb.run - args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid - fv - FStar_Reflection_V2_Constants.ref_Tv_Unknown.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.pure - FStar_Reflection_V2_Data.Tv_Unknown in - FStar_Syntax_Embeddings_AppEmb.run - args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid - fv - FStar_Reflection_V2_Constants.ref_Tv_Unsupp.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.pure - FStar_Reflection_V2_Data.Tv_Unsupp in - FStar_Syntax_Embeddings_AppEmb.run - args uu___2) - else - FStar_Pervasives_Native.None) in - mk_emb embed_term_view unembed_term_view - FStar_Reflection_V2_Constants.fstar_refl_term_view -let (e_term_view : - FStar_Reflection_V2_Data.term_view FStar_Syntax_Embeddings_Base.embedding) - = e_term_view_aq noaqs -let (e_name : Prims.string Prims.list FStar_Syntax_Embeddings_Base.embedding) - = FStar_Syntax_Embeddings.e_list FStar_Syntax_Embeddings.e_string -let (e_namedv_view : - FStar_Reflection_V2_Data.namedv_view FStar_Syntax_Embeddings_Base.embedding) - = - let embed_namedv_view rng namedvv = - let uu___ = - let uu___1 = - let uu___2 = - embed FStar_Syntax_Embeddings.e_int rng - namedvv.FStar_Reflection_V2_Data.uniq in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = embed e_sort rng namedvv.FStar_Reflection_V2_Data.sort in - FStar_Syntax_Syntax.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - embed - (FStar_Syntax_Embeddings.e_sealed - FStar_Syntax_Embeddings.e_string) rng - namedvv.FStar_Reflection_V2_Data.ppname in - FStar_Syntax_Syntax.as_arg uu___6 in - [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Mk_namedv_view.FStar_Reflection_V2_Constants.t - uu___ rng in - let unembed_namedv_view t = - let uu___ = head_fv_and_args t in - FStar_Syntax_Embeddings_AppEmb.op_let_Question uu___ - (fun uu___1 -> - match uu___1 with - | (fv, args) -> - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Mk_namedv_view.FStar_Reflection_V2_Constants.lid - then - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___5 -> - fun uu___6 -> - fun uu___7 -> - { - FStar_Reflection_V2_Data.uniq = uu___5; - FStar_Reflection_V2_Data.sort = uu___6; - FStar_Reflection_V2_Data.ppname = uu___7 - }) FStar_Syntax_Embeddings.e_int in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___4 e_sort in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___3 e_ppname in - FStar_Syntax_Embeddings_AppEmb.run args uu___2 - else FStar_Pervasives_Native.None) in - mk_emb embed_namedv_view unembed_namedv_view - FStar_Reflection_V2_Constants.fstar_refl_namedv_view -let (e_bv_view : - FStar_Reflection_V2_Data.bv_view FStar_Syntax_Embeddings_Base.embedding) = - let embed_bv_view rng bvv = - let uu___ = - let uu___1 = - let uu___2 = - embed FStar_Syntax_Embeddings.e_int rng - bvv.FStar_Reflection_V2_Data.index in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = embed e_sort rng bvv.FStar_Reflection_V2_Data.sort1 in - FStar_Syntax_Syntax.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - embed - (FStar_Syntax_Embeddings.e_sealed - FStar_Syntax_Embeddings.e_string) rng - bvv.FStar_Reflection_V2_Data.ppname1 in - FStar_Syntax_Syntax.as_arg uu___6 in - [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Mk_bv_view.FStar_Reflection_V2_Constants.t - uu___ rng in - let unembed_bv_view t = - let uu___ = head_fv_and_args t in - FStar_Syntax_Embeddings_AppEmb.op_let_Question uu___ - (fun uu___1 -> - match uu___1 with - | (fv, args) -> - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Mk_bv_view.FStar_Reflection_V2_Constants.lid - then - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___5 -> - fun uu___6 -> - fun uu___7 -> - { - FStar_Reflection_V2_Data.index = uu___5; - FStar_Reflection_V2_Data.sort1 = uu___6; - FStar_Reflection_V2_Data.ppname1 = uu___7 - }) FStar_Syntax_Embeddings.e_int in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___4 e_sort in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___3 e_ppname in - FStar_Syntax_Embeddings_AppEmb.run args uu___2 - else FStar_Pervasives_Native.None) in - mk_emb embed_bv_view unembed_bv_view - FStar_Reflection_V2_Constants.fstar_refl_bv_view -let (e_binding : - FStar_Reflection_V2_Data.binding FStar_Syntax_Embeddings_Base.embedding) = - let embed1 rng bindingv = - let uu___ = - let uu___1 = - let uu___2 = - embed FStar_Syntax_Embeddings.e_int rng - bindingv.FStar_Reflection_V2_Data.uniq1 in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - embed e_term rng bindingv.FStar_Reflection_V2_Data.sort3 in - FStar_Syntax_Syntax.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - embed - (FStar_Syntax_Embeddings.e_sealed - FStar_Syntax_Embeddings.e_string) rng - bindingv.FStar_Reflection_V2_Data.ppname3 in - FStar_Syntax_Syntax.as_arg uu___6 in - [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Mk_binding.FStar_Reflection_V2_Constants.t - uu___ rng in - let unembed t = - let uu___ = head_fv_and_args t in - FStar_Syntax_Embeddings_AppEmb.op_let_Question uu___ - (fun uu___1 -> - match uu___1 with - | (fv, args) -> - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Mk_binding.FStar_Reflection_V2_Constants.lid - then - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___5 -> - fun uu___6 -> - fun uu___7 -> - { - FStar_Reflection_V2_Data.uniq1 = uu___5; - FStar_Reflection_V2_Data.sort3 = uu___6; - FStar_Reflection_V2_Data.ppname3 = uu___7 - }) FStar_Syntax_Embeddings.e_int in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___4 e_term in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___3 e_ppname in - FStar_Syntax_Embeddings_AppEmb.run args uu___2 - else FStar_Pervasives_Native.None) in - mk_emb embed1 unembed FStar_Reflection_V2_Constants.fstar_refl_binding -let (e_attribute : - FStar_Syntax_Syntax.attribute FStar_Syntax_Embeddings_Base.embedding) = - e_term -let (e_attributes : - FStar_Syntax_Syntax.attribute Prims.list - FStar_Syntax_Embeddings_Base.embedding) - = FStar_Syntax_Embeddings.e_list e_attribute -let (e_binder_view : - FStar_Reflection_V2_Data.binder_view FStar_Syntax_Embeddings_Base.embedding) - = - let embed_binder_view rng bview = - let uu___ = - let uu___1 = - let uu___2 = embed e_term rng bview.FStar_Reflection_V2_Data.sort2 in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = embed e_aqualv rng bview.FStar_Reflection_V2_Data.qual in - FStar_Syntax_Syntax.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - embed e_attributes rng bview.FStar_Reflection_V2_Data.attrs in - FStar_Syntax_Syntax.as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - embed - (FStar_Syntax_Embeddings.e_sealed - FStar_Syntax_Embeddings.e_string) rng - bview.FStar_Reflection_V2_Data.ppname2 in - FStar_Syntax_Syntax.as_arg uu___8 in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Mk_binder_view.FStar_Reflection_V2_Constants.t - uu___ rng in - let unembed_binder_view t = - let uu___ = head_fv_and_args t in - FStar_Syntax_Embeddings_AppEmb.op_let_Question uu___ - (fun uu___1 -> - match uu___1 with - | (fv, args) -> - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Mk_binder_view.FStar_Reflection_V2_Constants.lid - then - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___6 -> - fun uu___7 -> - fun uu___8 -> - fun uu___9 -> - { - FStar_Reflection_V2_Data.sort2 = uu___6; - FStar_Reflection_V2_Data.qual = uu___7; - FStar_Reflection_V2_Data.attrs = uu___8; - FStar_Reflection_V2_Data.ppname2 = uu___9 - }) e_term in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___5 e_aqualv in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___4 (FStar_Syntax_Embeddings.e_list e_term) in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___3 e_ppname in - FStar_Syntax_Embeddings_AppEmb.run args uu___2 - else FStar_Pervasives_Native.None) in - mk_emb embed_binder_view unembed_binder_view - FStar_Reflection_V2_Constants.fstar_refl_binder_view -let (e_comp_view : - FStar_Reflection_V2_Data.comp_view FStar_Syntax_Embeddings_Base.embedding) - = - let embed_comp_view rng cv = - match cv with - | FStar_Reflection_V2_Data.C_Total t -> - let uu___ = - let uu___1 = - let uu___2 = embed e_term rng t in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_C_Total.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Reflection_V2_Data.C_GTotal t -> - let uu___ = - let uu___1 = - let uu___2 = embed e_term rng t in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_C_GTotal.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Reflection_V2_Data.C_Lemma (pre, post, pats) -> - let uu___ = - let uu___1 = - let uu___2 = embed e_term rng pre in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = embed e_term rng post in - FStar_Syntax_Syntax.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = embed e_term rng pats in - FStar_Syntax_Syntax.as_arg uu___6 in - [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_C_Lemma.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Reflection_V2_Data.C_Eff (us, eff, res, args, decrs) -> - let uu___ = - let uu___1 = - let uu___2 = - embed (FStar_Syntax_Embeddings.e_list e_universe) rng us in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - embed FStar_Syntax_Embeddings.e_string_list rng eff in - FStar_Syntax_Syntax.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = embed e_term rng res in - FStar_Syntax_Syntax.as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - embed (FStar_Syntax_Embeddings.e_list e_argv) rng args in - FStar_Syntax_Syntax.as_arg uu___8 in - let uu___8 = - let uu___9 = - let uu___10 = - embed (FStar_Syntax_Embeddings.e_list e_term) rng decrs in - FStar_Syntax_Syntax.as_arg uu___10 in - [uu___9] in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_C_Eff.FStar_Reflection_V2_Constants.t - uu___ rng in - let unembed_comp_view t = - let uu___ = head_fv_and_args t in - FStar_Syntax_Embeddings_AppEmb.op_let_Question uu___ - (fun uu___1 -> - match uu___1 with - | (fv, args) -> - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_C_Total.FStar_Reflection_V2_Constants.lid - then - let uu___2 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___3 -> FStar_Reflection_V2_Data.C_Total uu___3) - e_term in - FStar_Syntax_Embeddings_AppEmb.run args uu___2 - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_C_GTotal.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___3 -> FStar_Reflection_V2_Data.C_GTotal uu___3) - e_term in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_C_Lemma.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - let uu___3 = - let uu___4 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (curry3 - (fun uu___5 -> - FStar_Reflection_V2_Data.C_Lemma uu___5)) - e_term in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___4 e_term in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___3 e_term in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_C_Eff.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (curry5 - (fun uu___7 -> - FStar_Reflection_V2_Data.C_Eff uu___7)) - (FStar_Syntax_Embeddings.e_list e_universe) in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___6 FStar_Syntax_Embeddings.e_string_list in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___5 e_term in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___4 (FStar_Syntax_Embeddings.e_list e_argv) in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___3 (FStar_Syntax_Embeddings.e_list e_term) in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else FStar_Pervasives_Native.None) in - mk_emb embed_comp_view unembed_comp_view - FStar_Reflection_V2_Constants.fstar_refl_comp_view -let (e_univ_name : - FStar_Syntax_Syntax.univ_name FStar_Syntax_Embeddings_Base.embedding) = - e_ident -let (e_univ_names : - FStar_Syntax_Syntax.univ_name Prims.list - FStar_Syntax_Embeddings_Base.embedding) - = FStar_Syntax_Embeddings.e_list e_univ_name -let (e_subst_elt : - FStar_Syntax_Syntax.subst_elt FStar_Syntax_Embeddings_Base.embedding) = - let ee rng e = - match e with - | FStar_Syntax_Syntax.DB (i, x) -> - let uu___ = - let uu___1 = - let uu___2 = embed FStar_Syntax_Embeddings.e_fsint rng i in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = embed e_namedv rng x in - FStar_Syntax_Syntax.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_DB.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Syntax_Syntax.DT (i, t) -> - let uu___ = - let uu___1 = - let uu___2 = embed FStar_Syntax_Embeddings.e_fsint rng i in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = embed e_term rng t in - FStar_Syntax_Syntax.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_DT.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Syntax_Syntax.NM (x, i) -> - let uu___ = - let uu___1 = - let uu___2 = embed e_namedv rng x in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = embed FStar_Syntax_Embeddings.e_fsint rng i in - FStar_Syntax_Syntax.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_NM.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Syntax_Syntax.NT (x, t) -> - let uu___ = - let uu___1 = - let uu___2 = embed e_namedv rng x in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = embed e_term rng t in - FStar_Syntax_Syntax.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_NT.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Syntax_Syntax.UN (i, u) -> - let uu___ = - let uu___1 = - let uu___2 = embed FStar_Syntax_Embeddings.e_fsint rng i in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = embed e_universe rng u in - FStar_Syntax_Syntax.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_UN.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Syntax_Syntax.UD (u, i) -> - let uu___ = - let uu___1 = - let uu___2 = embed e_univ_name rng u in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = embed FStar_Syntax_Embeddings.e_fsint rng i in - FStar_Syntax_Syntax.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_UD.FStar_Reflection_V2_Constants.t - uu___ rng in - let uu t = - let uu___ = head_fv_and_args t in - FStar_Syntax_Embeddings_AppEmb.op_let_Question uu___ - (fun uu___1 -> - match uu___1 with - | (fv, args) -> - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_DB.FStar_Reflection_V2_Constants.lid - then - let uu___2 = - let uu___3 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (curry (fun uu___4 -> FStar_Syntax_Syntax.DB uu___4)) - FStar_Syntax_Embeddings.e_fsint in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___3 e_namedv in - FStar_Syntax_Embeddings_AppEmb.run args uu___2 - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_DT.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - let uu___3 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (curry (fun uu___4 -> FStar_Syntax_Syntax.DT uu___4)) - FStar_Syntax_Embeddings.e_fsint in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___3 e_term in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_NM.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - let uu___3 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (curry - (fun uu___4 -> FStar_Syntax_Syntax.NM uu___4)) - e_namedv in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___3 FStar_Syntax_Embeddings.e_fsint in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_NT.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - let uu___3 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (curry - (fun uu___4 -> FStar_Syntax_Syntax.NT uu___4)) - e_namedv in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___3 e_term in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_UN.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - let uu___3 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (curry - (fun uu___4 -> FStar_Syntax_Syntax.UN uu___4)) - FStar_Syntax_Embeddings.e_fsint in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___3 e_universe in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_UD.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - let uu___3 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (curry - (fun uu___4 -> - FStar_Syntax_Syntax.UD uu___4)) e_ident in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___3 FStar_Syntax_Embeddings.e_fsint in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else FStar_Pervasives_Native.None) in - mk_emb ee uu FStar_Reflection_V2_Constants.fstar_refl_subst_elt -let (e_subst : - FStar_Syntax_Syntax.subst_elt Prims.list - FStar_Syntax_Embeddings_Base.embedding) - = FStar_Syntax_Embeddings.e_list e_subst_elt -let (e_ctor : - (Prims.string Prims.list * FStar_Syntax_Syntax.term) - FStar_Syntax_Embeddings_Base.embedding) - = - FStar_Syntax_Embeddings.e_tuple2 FStar_Syntax_Embeddings.e_string_list - e_term -let (e_lb_view : - FStar_Reflection_V2_Data.lb_view FStar_Syntax_Embeddings_Base.embedding) = - let embed_lb_view rng lbv = - let uu___ = - let uu___1 = - let uu___2 = embed e_fv rng lbv.FStar_Reflection_V2_Data.lb_fv in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - embed (FStar_Syntax_Embeddings.e_list e_univ_name) rng - lbv.FStar_Reflection_V2_Data.lb_us in - FStar_Syntax_Syntax.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = embed e_term rng lbv.FStar_Reflection_V2_Data.lb_typ in - FStar_Syntax_Syntax.as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - embed e_term rng lbv.FStar_Reflection_V2_Data.lb_def in - FStar_Syntax_Syntax.as_arg uu___8 in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Mk_lb.FStar_Reflection_V2_Constants.t - uu___ rng in - let unembed_lb_view t = - let uu___ = head_fv_and_args t in - FStar_Syntax_Embeddings_AppEmb.op_let_Question uu___ - (fun uu___1 -> - match uu___1 with - | (fv, args) -> - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Mk_lb.FStar_Reflection_V2_Constants.lid - then - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___6 -> - fun uu___7 -> - fun uu___8 -> - fun uu___9 -> - { - FStar_Reflection_V2_Data.lb_fv = uu___6; - FStar_Reflection_V2_Data.lb_us = uu___7; - FStar_Reflection_V2_Data.lb_typ = uu___8; - FStar_Reflection_V2_Data.lb_def = uu___9 - }) e_fv in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___5 e_univ_names in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___4 e_term in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___3 e_term in - FStar_Syntax_Embeddings_AppEmb.run args uu___2 - else FStar_Pervasives_Native.None) in - mk_emb embed_lb_view unembed_lb_view - FStar_Reflection_V2_Constants.fstar_refl_lb_view -let (e_sigelt_view : - FStar_Reflection_V2_Data.sigelt_view FStar_Syntax_Embeddings_Base.embedding) - = - let embed_sigelt_view rng sev = - match sev with - | FStar_Reflection_V2_Data.Sg_Let (r, lbs) -> - let uu___ = - let uu___1 = - let uu___2 = embed FStar_Syntax_Embeddings.e_bool rng r in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - embed (FStar_Syntax_Embeddings.e_list e_letbinding) rng lbs in - FStar_Syntax_Syntax.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Sg_Let.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Reflection_V2_Data.Sg_Inductive (nm, univs, bs, t, dcs) -> - let uu___ = - let uu___1 = - let uu___2 = embed FStar_Syntax_Embeddings.e_string_list rng nm in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - embed (FStar_Syntax_Embeddings.e_list e_univ_name) rng univs in - FStar_Syntax_Syntax.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = embed e_binders rng bs in - FStar_Syntax_Syntax.as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = embed e_term rng t in - FStar_Syntax_Syntax.as_arg uu___8 in - let uu___8 = - let uu___9 = - let uu___10 = - embed (FStar_Syntax_Embeddings.e_list e_ctor) rng dcs in - FStar_Syntax_Syntax.as_arg uu___10 in - [uu___9] in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Sg_Inductive.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Reflection_V2_Data.Sg_Val (nm, univs, t) -> - let uu___ = - let uu___1 = - let uu___2 = embed FStar_Syntax_Embeddings.e_string_list rng nm in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - embed (FStar_Syntax_Embeddings.e_list e_univ_name) rng univs in - FStar_Syntax_Syntax.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = embed e_term rng t in - FStar_Syntax_Syntax.as_arg uu___6 in - [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_Sg_Val.FStar_Reflection_V2_Constants.t - uu___ rng - | FStar_Reflection_V2_Data.Unk -> - let uu___ = - FStar_Reflection_V2_Constants.ref_Unk.FStar_Reflection_V2_Constants.t in - { - FStar_Syntax_Syntax.n = (uu___.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = rng; - FStar_Syntax_Syntax.vars = (uu___.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (uu___.FStar_Syntax_Syntax.hash_code) - } in - let unembed_sigelt_view t = - let uu___ = head_fv_and_args t in - FStar_Syntax_Embeddings_AppEmb.op_let_Question uu___ - (fun uu___1 -> - match uu___1 with - | (fv, args) -> - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Sg_Inductive.FStar_Reflection_V2_Constants.lid - then - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (curry5 - (fun uu___7 -> - FStar_Reflection_V2_Data.Sg_Inductive uu___7)) - FStar_Syntax_Embeddings.e_string_list in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___6 e_univ_names in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___5 e_binders in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___4 e_term in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___3 (FStar_Syntax_Embeddings.e_list e_ctor) in - FStar_Syntax_Embeddings_AppEmb.run args uu___2 - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Sg_Let.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - let uu___3 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (curry - (fun uu___4 -> - FStar_Reflection_V2_Data.Sg_Let uu___4)) - FStar_Syntax_Embeddings.e_bool in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___3 (FStar_Syntax_Embeddings.e_list e_letbinding) in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Sg_Val.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - let uu___3 = - let uu___4 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (curry3 - (fun uu___5 -> - FStar_Reflection_V2_Data.Sg_Val uu___5)) - FStar_Syntax_Embeddings.e_string_list in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___4 e_univ_names in - FStar_Syntax_Embeddings_AppEmb.op_Less_Star_Star_Greater - uu___3 e_term in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Unk.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.pure - FStar_Reflection_V2_Data.Unk in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else FStar_Pervasives_Native.None) in - mk_emb embed_sigelt_view unembed_sigelt_view - FStar_Reflection_V2_Constants.fstar_refl_sigelt_view -let (e_qualifier : - FStar_Reflection_V2_Data.qualifier FStar_Syntax_Embeddings_Base.embedding) - = - let embed1 rng q = - let r = - match q with - | FStar_Reflection_V2_Data.Assumption -> - FStar_Reflection_V2_Constants.ref_qual_Assumption.FStar_Reflection_V2_Constants.t - | FStar_Reflection_V2_Data.InternalAssumption -> - FStar_Reflection_V2_Constants.ref_qual_InternalAssumption.FStar_Reflection_V2_Constants.t - | FStar_Reflection_V2_Data.New -> - FStar_Reflection_V2_Constants.ref_qual_New.FStar_Reflection_V2_Constants.t - | FStar_Reflection_V2_Data.Private -> - FStar_Reflection_V2_Constants.ref_qual_Private.FStar_Reflection_V2_Constants.t - | FStar_Reflection_V2_Data.Unfold_for_unification_and_vcgen -> - FStar_Reflection_V2_Constants.ref_qual_Unfold_for_unification_and_vcgen.FStar_Reflection_V2_Constants.t - | FStar_Reflection_V2_Data.Visible_default -> - FStar_Reflection_V2_Constants.ref_qual_Visible_default.FStar_Reflection_V2_Constants.t - | FStar_Reflection_V2_Data.Irreducible -> - FStar_Reflection_V2_Constants.ref_qual_Irreducible.FStar_Reflection_V2_Constants.t - | FStar_Reflection_V2_Data.Inline_for_extraction -> - FStar_Reflection_V2_Constants.ref_qual_Inline_for_extraction.FStar_Reflection_V2_Constants.t - | FStar_Reflection_V2_Data.NoExtract -> - FStar_Reflection_V2_Constants.ref_qual_NoExtract.FStar_Reflection_V2_Constants.t - | FStar_Reflection_V2_Data.Noeq -> - FStar_Reflection_V2_Constants.ref_qual_Noeq.FStar_Reflection_V2_Constants.t - | FStar_Reflection_V2_Data.Unopteq -> - FStar_Reflection_V2_Constants.ref_qual_Unopteq.FStar_Reflection_V2_Constants.t - | FStar_Reflection_V2_Data.TotalEffect -> - FStar_Reflection_V2_Constants.ref_qual_TotalEffect.FStar_Reflection_V2_Constants.t - | FStar_Reflection_V2_Data.Logic -> - FStar_Reflection_V2_Constants.ref_qual_Logic.FStar_Reflection_V2_Constants.t - | FStar_Reflection_V2_Data.Reifiable -> - FStar_Reflection_V2_Constants.ref_qual_Reifiable.FStar_Reflection_V2_Constants.t - | FStar_Reflection_V2_Data.ExceptionConstructor -> - FStar_Reflection_V2_Constants.ref_qual_ExceptionConstructor.FStar_Reflection_V2_Constants.t - | FStar_Reflection_V2_Data.HasMaskedEffect -> - FStar_Reflection_V2_Constants.ref_qual_HasMaskedEffect.FStar_Reflection_V2_Constants.t - | FStar_Reflection_V2_Data.Effect -> - FStar_Reflection_V2_Constants.ref_qual_Effect.FStar_Reflection_V2_Constants.t - | FStar_Reflection_V2_Data.OnlyName -> - FStar_Reflection_V2_Constants.ref_qual_OnlyName.FStar_Reflection_V2_Constants.t - | FStar_Reflection_V2_Data.Reflectable l -> - let uu___ = - let uu___1 = - let uu___2 = embed FStar_Syntax_Embeddings.e_string_list rng l in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_qual_Reflectable.FStar_Reflection_V2_Constants.t - uu___ FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V2_Data.Discriminator l -> - let uu___ = - let uu___1 = - let uu___2 = embed FStar_Syntax_Embeddings.e_string_list rng l in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_qual_Discriminator.FStar_Reflection_V2_Constants.t - uu___ FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V2_Data.Action l -> - let uu___ = - let uu___1 = - let uu___2 = embed FStar_Syntax_Embeddings.e_string_list rng l in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_qual_Action.FStar_Reflection_V2_Constants.t - uu___ FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V2_Data.Projector (l, i) -> - let uu___ = - let uu___1 = - let uu___2 = - embed - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Syntax_Embeddings.e_string_list e_univ_name) rng - (l, i) in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_qual_Projector.FStar_Reflection_V2_Constants.t - uu___ FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V2_Data.RecordType (ids1, ids2) -> - let uu___ = - let uu___1 = - let uu___2 = - embed - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_list e_univ_name) - (FStar_Syntax_Embeddings.e_list e_univ_name)) rng - (ids1, ids2) in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_qual_RecordType.FStar_Reflection_V2_Constants.t - uu___ FStar_Compiler_Range_Type.dummyRange - | FStar_Reflection_V2_Data.RecordConstructor (ids1, ids2) -> - let uu___ = - let uu___1 = - let uu___2 = - embed - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_list e_univ_name) - (FStar_Syntax_Embeddings.e_list e_univ_name)) rng - (ids1, ids2) in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.ref_qual_RecordConstructor.FStar_Reflection_V2_Constants.t - uu___ FStar_Compiler_Range_Type.dummyRange in - { - FStar_Syntax_Syntax.n = (r.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = rng; - FStar_Syntax_Syntax.vars = (r.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = (r.FStar_Syntax_Syntax.hash_code) - } in - let unembed t = - let uu___ = head_fv_and_args t in - FStar_Syntax_Embeddings_AppEmb.op_let_Question uu___ - (fun uu___1 -> - match uu___1 with - | (fv, args) -> - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_Assumption.FStar_Reflection_V2_Constants.lid - then - let uu___2 = - FStar_Syntax_Embeddings_AppEmb.pure - FStar_Reflection_V2_Data.Assumption in - FStar_Syntax_Embeddings_AppEmb.run args uu___2 - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_InternalAssumption.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.pure - FStar_Reflection_V2_Data.InternalAssumption in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_New.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.pure - FStar_Reflection_V2_Data.New in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_Private.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.pure - FStar_Reflection_V2_Data.Private in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_Unfold_for_unification_and_vcgen.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.pure - FStar_Reflection_V2_Data.Unfold_for_unification_and_vcgen in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_Visible_default.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.pure - FStar_Reflection_V2_Data.Visible_default in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_Irreducible.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.pure - FStar_Reflection_V2_Data.Irreducible in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_Inline_for_extraction.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.pure - FStar_Reflection_V2_Data.Inline_for_extraction in - FStar_Syntax_Embeddings_AppEmb.run args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_NoExtract.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.pure - FStar_Reflection_V2_Data.NoExtract in - FStar_Syntax_Embeddings_AppEmb.run args - uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_Noeq.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.pure - FStar_Reflection_V2_Data.Noeq in - FStar_Syntax_Embeddings_AppEmb.run args - uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_Unopteq.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.pure - FStar_Reflection_V2_Data.Unopteq in - FStar_Syntax_Embeddings_AppEmb.run args - uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_TotalEffect.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.pure - FStar_Reflection_V2_Data.TotalEffect in - FStar_Syntax_Embeddings_AppEmb.run args - uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_Logic.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.pure - FStar_Reflection_V2_Data.Logic in - FStar_Syntax_Embeddings_AppEmb.run - args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_Reifiable.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.pure - FStar_Reflection_V2_Data.Reifiable in - FStar_Syntax_Embeddings_AppEmb.run - args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_ExceptionConstructor.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.pure - FStar_Reflection_V2_Data.ExceptionConstructor in - FStar_Syntax_Embeddings_AppEmb.run - args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_HasMaskedEffect.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.pure - FStar_Reflection_V2_Data.HasMaskedEffect in - FStar_Syntax_Embeddings_AppEmb.run - args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid - fv - FStar_Reflection_V2_Constants.ref_qual_Effect.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.pure - FStar_Reflection_V2_Data.Effect in - FStar_Syntax_Embeddings_AppEmb.run - args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid - fv - FStar_Reflection_V2_Constants.ref_qual_OnlyName.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.pure - FStar_Reflection_V2_Data.OnlyName in - FStar_Syntax_Embeddings_AppEmb.run - args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid - fv - FStar_Reflection_V2_Constants.ref_qual_Reflectable.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___3 -> - FStar_Reflection_V2_Data.Reflectable - uu___3) e_name in - FStar_Syntax_Embeddings_AppEmb.run - args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid - fv - FStar_Reflection_V2_Constants.ref_qual_Discriminator.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___3 -> - FStar_Reflection_V2_Data.Discriminator - uu___3) e_name in - FStar_Syntax_Embeddings_AppEmb.run - args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid - fv - FStar_Reflection_V2_Constants.ref_qual_Action.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___3 -> - FStar_Reflection_V2_Data.Action - uu___3) - e_name in - FStar_Syntax_Embeddings_AppEmb.run - args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid - fv - FStar_Reflection_V2_Constants.ref_qual_Projector.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___3 -> - FStar_Reflection_V2_Data.Projector - uu___3) - (FStar_Syntax_Embeddings.e_tuple2 - e_name - e_ident) in - FStar_Syntax_Embeddings_AppEmb.run - args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid - fv - FStar_Reflection_V2_Constants.ref_qual_RecordType.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___3 - -> - FStar_Reflection_V2_Data.RecordType - uu___3) - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_list - e_ident) - (FStar_Syntax_Embeddings.e_list - e_ident)) in - FStar_Syntax_Embeddings_AppEmb.run - args uu___2) - else - if - FStar_Syntax_Syntax.fv_eq_lid - fv - FStar_Reflection_V2_Constants.ref_qual_RecordConstructor.FStar_Reflection_V2_Constants.lid - then - (let uu___2 = - FStar_Syntax_Embeddings_AppEmb.op_Less_Dollar_Dollar_Greater - (fun uu___3 - -> - FStar_Reflection_V2_Data.RecordConstructor - uu___3) - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_list - e_ident) - (FStar_Syntax_Embeddings.e_list - e_ident)) in - FStar_Syntax_Embeddings_AppEmb.run - args uu___2) - else - FStar_Pervasives_Native.None) in - mk_emb embed1 unembed FStar_Reflection_V2_Constants.fstar_refl_qualifier -let (e_qualifiers : - FStar_Reflection_V2_Data.qualifier Prims.list - FStar_Syntax_Embeddings_Base.embedding) - = FStar_Syntax_Embeddings.e_list e_qualifier -let (unfold_lazy_bv : - FStar_Syntax_Syntax.lazyinfo -> FStar_Syntax_Syntax.term) = - fun i -> - let bv = FStar_Dyn.undyn i.FStar_Syntax_Syntax.blob in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Reflection_V2_Builtins.inspect_bv bv in - embed e_bv_view i.FStar_Syntax_Syntax.rng uu___3 in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.fstar_refl_pack_bv.FStar_Reflection_V2_Constants.t - uu___ i.FStar_Syntax_Syntax.rng -let (unfold_lazy_namedv : - FStar_Syntax_Syntax.lazyinfo -> FStar_Syntax_Syntax.term) = - fun i -> - let namedv1 = FStar_Dyn.undyn i.FStar_Syntax_Syntax.blob in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Reflection_V2_Builtins.inspect_namedv namedv1 in - embed e_namedv_view i.FStar_Syntax_Syntax.rng uu___3 in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.fstar_refl_pack_namedv.FStar_Reflection_V2_Constants.t - uu___ i.FStar_Syntax_Syntax.rng -let (unfold_lazy_binder : - FStar_Syntax_Syntax.lazyinfo -> FStar_Syntax_Syntax.term) = - fun i -> - let binder = FStar_Dyn.undyn i.FStar_Syntax_Syntax.blob in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Reflection_V2_Builtins.inspect_binder binder in - embed e_binder_view i.FStar_Syntax_Syntax.rng uu___3 in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.fstar_refl_pack_binder.FStar_Reflection_V2_Constants.t - uu___ i.FStar_Syntax_Syntax.rng -let (unfold_lazy_letbinding : - FStar_Syntax_Syntax.lazyinfo -> FStar_Syntax_Syntax.term) = - fun i -> - let lb = FStar_Dyn.undyn i.FStar_Syntax_Syntax.blob in - let lbv = FStar_Reflection_V2_Builtins.inspect_lb lb in - let uu___ = - let uu___1 = - let uu___2 = - embed e_fv i.FStar_Syntax_Syntax.rng - lbv.FStar_Reflection_V2_Data.lb_fv in - FStar_Syntax_Syntax.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - embed (FStar_Syntax_Embeddings.e_list e_univ_name) - i.FStar_Syntax_Syntax.rng lbv.FStar_Reflection_V2_Data.lb_us in - FStar_Syntax_Syntax.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - embed e_term i.FStar_Syntax_Syntax.rng - lbv.FStar_Reflection_V2_Data.lb_typ in - FStar_Syntax_Syntax.as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - embed e_term i.FStar_Syntax_Syntax.rng - lbv.FStar_Reflection_V2_Data.lb_def in - FStar_Syntax_Syntax.as_arg uu___8 in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.fstar_refl_pack_lb.FStar_Reflection_V2_Constants.t - uu___ i.FStar_Syntax_Syntax.rng -let (unfold_lazy_fvar : - FStar_Syntax_Syntax.lazyinfo -> FStar_Syntax_Syntax.term) = - fun i -> - let fv = FStar_Dyn.undyn i.FStar_Syntax_Syntax.blob in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Reflection_V2_Builtins.inspect_fv fv in - embed FStar_Syntax_Embeddings.e_string_list - i.FStar_Syntax_Syntax.rng uu___3 in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.fstar_refl_pack_fv.FStar_Reflection_V2_Constants.t - uu___ i.FStar_Syntax_Syntax.rng -let (unfold_lazy_comp : - FStar_Syntax_Syntax.lazyinfo -> FStar_Syntax_Syntax.term) = - fun i -> - let comp = FStar_Dyn.undyn i.FStar_Syntax_Syntax.blob in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Reflection_V2_Builtins.inspect_comp comp in - embed e_comp_view i.FStar_Syntax_Syntax.rng uu___3 in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.fstar_refl_pack_comp.FStar_Reflection_V2_Constants.t - uu___ i.FStar_Syntax_Syntax.rng -let (unfold_lazy_env : - FStar_Syntax_Syntax.lazyinfo -> FStar_Syntax_Syntax.term) = - fun i -> FStar_Syntax_Util.exp_unit -let (unfold_lazy_optionstate : - FStar_Syntax_Syntax.lazyinfo -> FStar_Syntax_Syntax.term) = - fun i -> FStar_Syntax_Util.exp_unit -let (unfold_lazy_sigelt : - FStar_Syntax_Syntax.lazyinfo -> FStar_Syntax_Syntax.term) = - fun i -> - let sigelt = FStar_Dyn.undyn i.FStar_Syntax_Syntax.blob in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Reflection_V2_Builtins.inspect_sigelt sigelt in - embed e_sigelt_view i.FStar_Syntax_Syntax.rng uu___3 in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.fstar_refl_pack_sigelt.FStar_Reflection_V2_Constants.t - uu___ i.FStar_Syntax_Syntax.rng -let (unfold_lazy_universe : - FStar_Syntax_Syntax.lazyinfo -> FStar_Syntax_Syntax.term) = - fun i -> - let u = FStar_Dyn.undyn i.FStar_Syntax_Syntax.blob in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Reflection_V2_Builtins.inspect_universe u in - embed e_universe_view i.FStar_Syntax_Syntax.rng uu___3 in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Reflection_V2_Constants.fstar_refl_pack_universe.FStar_Reflection_V2_Constants.t - uu___ i.FStar_Syntax_Syntax.rng -let (unfold_lazy_doc : - FStar_Syntax_Syntax.lazyinfo -> FStar_Syntax_Syntax.term) = - fun i -> - let d = FStar_Dyn.undyn i.FStar_Syntax_Syntax.blob in - let lid = FStar_Ident.lid_of_str "FStar.Stubs.Pprint.arbitrary_string" in - let s = FStar_Pprint.render d in - let uu___ = FStar_Syntax_Syntax.fvar lid FStar_Pervasives_Native.None in - let uu___1 = - let uu___2 = - let uu___3 = - embed FStar_Syntax_Embeddings.e_string i.FStar_Syntax_Syntax.rng s in - FStar_Syntax_Syntax.as_arg uu___3 in - [uu___2] in - FStar_Syntax_Syntax.mk_Tm_app uu___ uu___1 i.FStar_Syntax_Syntax.rng \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Reflection_V2_Formula.ml b/ocaml/fstar-lib/generated/FStar_Reflection_V2_Formula.ml index ec3811e70ff..6e8dfdcc7c6 100644 --- a/ocaml/fstar-lib/generated/FStar_Reflection_V2_Formula.ml +++ b/ocaml/fstar-lib/generated/FStar_Reflection_V2_Formula.ml @@ -1,7 +1,7 @@ open Prims let (term_eq : - FStar_Reflection_Types.term -> FStar_Reflection_Types.term -> Prims.bool) = - FStar_Reflection_TermEq_Simple.term_eq + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term -> Prims.bool) + = FStar_Reflection_TermEq_Simple.term_eq let rec (inspect_unascribe : FStar_Tactics_NamedView.term -> (FStar_Tactics_NamedView.term_view, unit) FStar_Tactics_Effect.tac_repr) @@ -34,9 +34,9 @@ let rec (inspect_unascribe : (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> tv)))) uu___1) let rec (collect_app' : - FStar_Reflection_V2_Data.argv Prims.list -> + FStarC_Reflection_V2_Data.argv Prims.list -> FStar_Tactics_NamedView.term -> - ((FStar_Tactics_NamedView.term * FStar_Reflection_V2_Data.argv + ((FStar_Tactics_NamedView.term * FStarC_Reflection_V2_Data.argv Prims.list), unit) FStar_Tactics_Effect.tac_repr) = @@ -66,33 +66,33 @@ let rec (collect_app' : (fun uu___3 -> (t, args))))) uu___1) let (collect_app : FStar_Tactics_NamedView.term -> - ((FStar_Tactics_NamedView.term * FStar_Reflection_V2_Data.argv + ((FStar_Tactics_NamedView.term * FStarC_Reflection_V2_Data.argv Prims.list), unit) FStar_Tactics_Effect.tac_repr) = collect_app' [] type comparison = - | Eq of FStar_Reflection_Types.typ FStar_Pervasives_Native.option - | BoolEq of FStar_Reflection_Types.typ FStar_Pervasives_Native.option + | Eq of FStarC_Reflection_Types.typ FStar_Pervasives_Native.option + | BoolEq of FStarC_Reflection_Types.typ FStar_Pervasives_Native.option | Lt | Le | Gt | Ge let rec __knot_e_comparison _ = - FStar_Syntax_Embeddings_Base.mk_extracted_embedding + FStarC_Syntax_Embeddings_Base.mk_extracted_embedding "FStar.Reflection.V2.Formula.comparison" (fun tm_0 -> match tm_0 with | ("FStar.Reflection.V2.Formula.Eq", _0_2::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - (FStar_Syntax_Embeddings.e_option - FStar_Reflection_V2_Embeddings.e_term) _0_2) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + (FStarC_Syntax_Embeddings.e_option + FStarC_Reflection_V2_Embeddings.e_term) _0_2) (fun _0_2 -> FStar_Pervasives_Native.Some (Eq _0_2)) | ("FStar.Reflection.V2.Formula.BoolEq", _0_4::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - (FStar_Syntax_Embeddings.e_option - FStar_Reflection_V2_Embeddings.e_term) _0_4) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + (FStarC_Syntax_Embeddings.e_option + FStarC_Reflection_V2_Embeddings.e_term) _0_4) (fun _0_4 -> FStar_Pervasives_Native.Some (BoolEq _0_4)) | ("FStar.Reflection.V2.Formula.Lt", []) -> FStar_Pervasives_Native.Some Lt @@ -106,47 +106,51 @@ let rec __knot_e_comparison _ = (fun tm_9 -> match tm_9 with | Eq _0_11 -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Reflection.V2.Formula.Eq")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - (FStar_Syntax_Embeddings.e_option - FStar_Reflection_V2_Embeddings.e_term) _0_11), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Formula.Eq")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed + (FStarC_Syntax_Embeddings.e_option + FStarC_Reflection_V2_Embeddings.e_term) _0_11), FStar_Pervasives_Native.None)] | BoolEq _0_13 -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Reflection.V2.Formula.BoolEq")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - (FStar_Syntax_Embeddings.e_option - FStar_Reflection_V2_Embeddings.e_term) _0_13), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Formula.BoolEq")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed + (FStarC_Syntax_Embeddings.e_option + FStarC_Reflection_V2_Embeddings.e_term) _0_13), FStar_Pervasives_Native.None)] | Lt -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Reflection.V2.Formula.Lt")) [] + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Formula.Lt")) + [] | Le -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Reflection.V2.Formula.Le")) [] + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Formula.Le")) + [] | Gt -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Reflection.V2.Formula.Gt")) [] + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Formula.Gt")) + [] | Ge -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Reflection.V2.Formula.Ge")) []) + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Formula.Ge")) + []) let e_comparison = __knot_e_comparison () let (uu___is_Eq : comparison -> Prims.bool) = fun projectee -> match projectee with | Eq _0 -> true | uu___ -> false let (__proj__Eq__item___0 : - comparison -> FStar_Reflection_Types.typ FStar_Pervasives_Native.option) = + comparison -> FStarC_Reflection_Types.typ FStar_Pervasives_Native.option) = fun projectee -> match projectee with | Eq _0 -> _0 let (uu___is_BoolEq : comparison -> Prims.bool) = fun projectee -> match projectee with | BoolEq _0 -> true | uu___ -> false let (__proj__BoolEq__item___0 : - comparison -> FStar_Reflection_Types.typ FStar_Pervasives_Native.option) = + comparison -> FStarC_Reflection_Types.typ FStar_Pervasives_Native.option) = fun projectee -> match projectee with | BoolEq _0 -> _0 let (uu___is_Lt : comparison -> Prims.bool) = fun projectee -> match projectee with | Lt -> true | uu___ -> false @@ -166,17 +170,17 @@ type formula = | Not of FStar_Tactics_NamedView.term | Implies of FStar_Tactics_NamedView.term * FStar_Tactics_NamedView.term | Iff of FStar_Tactics_NamedView.term * FStar_Tactics_NamedView.term - | Forall of FStar_Tactics_NamedView.bv * FStar_Reflection_Types.typ * + | Forall of FStar_Tactics_NamedView.bv * FStarC_Reflection_Types.typ * FStar_Tactics_NamedView.term - | Exists of FStar_Tactics_NamedView.bv * FStar_Reflection_Types.typ * + | Exists of FStar_Tactics_NamedView.bv * FStarC_Reflection_Types.typ * FStar_Tactics_NamedView.term | App of FStar_Tactics_NamedView.term * FStar_Tactics_NamedView.term | Name of FStar_Tactics_NamedView.namedv - | FV of FStar_Reflection_Types.fv + | FV of FStarC_Reflection_Types.fv | IntLit of Prims.int | F_Unknown let rec __knot_e_formula _ = - FStar_Syntax_Embeddings_Base.mk_extracted_embedding + FStarC_Syntax_Embeddings_Base.mk_extracted_embedding "FStar.Reflection.V2.Formula.formula" (fun tm_18 -> match tm_18 with @@ -185,119 +189,119 @@ let rec __knot_e_formula _ = | ("FStar.Reflection.V2.Formula.False_", []) -> FStar_Pervasives_Native.Some False_ | ("FStar.Reflection.V2.Formula.Comp", _0_22::_1_23::_2_24::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed e_comparison + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed e_comparison _0_22) (fun _0_22 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_term _1_23) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_term _1_23) (fun _1_23 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_term _2_24) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_term _2_24) (fun _2_24 -> FStar_Pervasives_Native.Some (Comp (_0_22, _1_23, _2_24))))) | ("FStar.Reflection.V2.Formula.And", _0_26::_1_27::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_term _0_26) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_term _0_26) (fun _0_26 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_term _1_27) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_term _1_27) (fun _1_27 -> FStar_Pervasives_Native.Some (And (_0_26, _1_27)))) | ("FStar.Reflection.V2.Formula.Or", _0_29::_1_30::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_term _0_29) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_term _0_29) (fun _0_29 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_term _1_30) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_term _1_30) (fun _1_30 -> FStar_Pervasives_Native.Some (Or (_0_29, _1_30)))) | ("FStar.Reflection.V2.Formula.Not", _0_32::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_term _0_32) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_term _0_32) (fun _0_32 -> FStar_Pervasives_Native.Some (Not _0_32)) | ("FStar.Reflection.V2.Formula.Implies", _0_34::_1_35::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_term _0_34) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_term _0_34) (fun _0_34 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_term _1_35) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_term _1_35) (fun _1_35 -> FStar_Pervasives_Native.Some (Implies (_0_34, _1_35)))) | ("FStar.Reflection.V2.Formula.Iff", _0_37::_1_38::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_term _0_37) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_term _0_37) (fun _0_37 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_term _1_38) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_term _1_38) (fun _1_38 -> FStar_Pervasives_Native.Some (Iff (_0_37, _1_38)))) | ("FStar.Reflection.V2.Formula.Forall", _0_40::_1_41::_2_42::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_bv_view _0_40) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_bv_view _0_40) (fun _0_40 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_term _1_41) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_term _1_41) (fun _1_41 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_term _2_42) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_term _2_42) (fun _2_42 -> FStar_Pervasives_Native.Some (Forall (_0_40, _1_41, _2_42))))) | ("FStar.Reflection.V2.Formula.Exists", _0_44::_1_45::_2_46::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_bv_view _0_44) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_bv_view _0_44) (fun _0_44 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_term _1_45) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_term _1_45) (fun _1_45 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_term _2_46) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_term _2_46) (fun _2_46 -> FStar_Pervasives_Native.Some (Exists (_0_44, _1_45, _2_46))))) | ("FStar.Reflection.V2.Formula.App", _0_48::_1_49::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_term _0_48) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_term _0_48) (fun _0_48 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_term _1_49) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_term _1_49) (fun _1_49 -> FStar_Pervasives_Native.Some (App (_0_48, _1_49)))) | ("FStar.Reflection.V2.Formula.Name", _0_51::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_namedv_view _0_51) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_namedv_view _0_51) (fun _0_51 -> FStar_Pervasives_Native.Some (Name _0_51)) | ("FStar.Reflection.V2.Formula.FV", _0_53::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_fv _0_53) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_fv _0_53) (fun _0_53 -> FStar_Pervasives_Native.Some (FV _0_53)) | ("FStar.Reflection.V2.Formula.IntLit", _0_55::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Syntax_Embeddings.e_int _0_55) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Syntax_Embeddings.e_int _0_55) (fun _0_55 -> FStar_Pervasives_Native.Some (IntLit _0_55)) | ("FStar.Reflection.V2.Formula.F_Unknown", []) -> FStar_Pervasives_Native.Some F_Unknown @@ -305,135 +309,136 @@ let rec __knot_e_formula _ = (fun tm_57 -> match tm_57 with | True_ -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Reflection.V2.Formula.True_")) + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Formula.True_")) [] | False_ -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Reflection.V2.Formula.False_")) + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Formula.False_")) [] | Comp (_0_61, _1_62, _2_63) -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Reflection.V2.Formula.Comp")) - [((FStar_Syntax_Embeddings_Base.extracted_embed e_comparison + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Formula.Comp")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed e_comparison _0_61), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_term _1_62), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_term _1_62), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_term _2_63), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_term _2_63), FStar_Pervasives_Native.None)] | And (_0_65, _1_66) -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Reflection.V2.Formula.And")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_term _0_65), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Formula.And")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_term _0_65), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_term _1_66), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_term _1_66), FStar_Pervasives_Native.None)] | Or (_0_68, _1_69) -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Reflection.V2.Formula.Or")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_term _0_68), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Formula.Or")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_term _0_68), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_term _1_69), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_term _1_69), FStar_Pervasives_Native.None)] | Not _0_71 -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Reflection.V2.Formula.Not")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_term _0_71), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Formula.Not")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_term _0_71), FStar_Pervasives_Native.None)] | Implies (_0_73, _1_74) -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Reflection.V2.Formula.Implies")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_term _0_73), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str + "FStar.Reflection.V2.Formula.Implies")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_term _0_73), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_term _1_74), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_term _1_74), FStar_Pervasives_Native.None)] | Iff (_0_76, _1_77) -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Reflection.V2.Formula.Iff")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_term _0_76), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Formula.Iff")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_term _0_76), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_term _1_77), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_term _1_77), FStar_Pervasives_Native.None)] | Forall (_0_79, _1_80, _2_81) -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Reflection.V2.Formula.Forall")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_bv_view _0_79), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Formula.Forall")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_bv_view _0_79), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_term _1_80), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_term _1_80), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_term _2_81), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_term _2_81), FStar_Pervasives_Native.None)] | Exists (_0_83, _1_84, _2_85) -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Reflection.V2.Formula.Exists")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_bv_view _0_83), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Formula.Exists")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_bv_view _0_83), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_term _1_84), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_term _1_84), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_term _2_85), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_term _2_85), FStar_Pervasives_Native.None)] | App (_0_87, _1_88) -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Reflection.V2.Formula.App")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_term _0_87), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Formula.App")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_term _0_87), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_term _1_88), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_term _1_88), FStar_Pervasives_Native.None)] | Name _0_90 -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Reflection.V2.Formula.Name")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_namedv_view _0_90), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Formula.Name")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_namedv_view _0_90), FStar_Pervasives_Native.None)] | FV _0_92 -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Reflection.V2.Formula.FV")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_fv _0_92), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Formula.FV")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_fv _0_92), FStar_Pervasives_Native.None)] | IntLit _0_94 -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Reflection.V2.Formula.IntLit")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Syntax_Embeddings.e_int _0_94), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Formula.IntLit")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Syntax_Embeddings.e_int _0_94), FStar_Pervasives_Native.None)] | F_Unknown -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Reflection.V2.Formula.F_Unknown")) []) let e_formula = __knot_e_formula () let (uu___is_True_ : formula -> Prims.bool) = @@ -486,7 +491,7 @@ let (uu___is_Forall : formula -> Prims.bool) = match projectee with | Forall (_0, _1, _2) -> true | uu___ -> false let (__proj__Forall__item___0 : formula -> FStar_Tactics_NamedView.bv) = fun projectee -> match projectee with | Forall (_0, _1, _2) -> _0 -let (__proj__Forall__item___1 : formula -> FStar_Reflection_Types.typ) = +let (__proj__Forall__item___1 : formula -> FStarC_Reflection_Types.typ) = fun projectee -> match projectee with | Forall (_0, _1, _2) -> _1 let (__proj__Forall__item___2 : formula -> FStar_Tactics_NamedView.term) = fun projectee -> match projectee with | Forall (_0, _1, _2) -> _2 @@ -495,7 +500,7 @@ let (uu___is_Exists : formula -> Prims.bool) = match projectee with | Exists (_0, _1, _2) -> true | uu___ -> false let (__proj__Exists__item___0 : formula -> FStar_Tactics_NamedView.bv) = fun projectee -> match projectee with | Exists (_0, _1, _2) -> _0 -let (__proj__Exists__item___1 : formula -> FStar_Reflection_Types.typ) = +let (__proj__Exists__item___1 : formula -> FStarC_Reflection_Types.typ) = fun projectee -> match projectee with | Exists (_0, _1, _2) -> _1 let (__proj__Exists__item___2 : formula -> FStar_Tactics_NamedView.term) = fun projectee -> match projectee with | Exists (_0, _1, _2) -> _2 @@ -512,7 +517,7 @@ let (__proj__Name__item___0 : formula -> FStar_Tactics_NamedView.namedv) = fun projectee -> match projectee with | Name _0 -> _0 let (uu___is_FV : formula -> Prims.bool) = fun projectee -> match projectee with | FV _0 -> true | uu___ -> false -let (__proj__FV__item___0 : formula -> FStar_Reflection_Types.fv) = +let (__proj__FV__item___0 : formula -> FStarC_Reflection_Types.fv) = fun projectee -> match projectee with | FV _0 -> _0 let (uu___is_IntLit : formula -> Prims.bool) = fun projectee -> match projectee with | IntLit _0 -> true | uu___ -> false @@ -527,10 +532,10 @@ let (mk_Forall : let b = FStar_Tactics_NamedView.pack_bv { - FStar_Reflection_V2_Data.index = Prims.int_zero; - FStar_Reflection_V2_Data.sort1 = (FStar_Sealed.seal typ); - FStar_Reflection_V2_Data.ppname1 = - (FStar_Reflection_V2_Data.as_ppname "x") + FStarC_Reflection_V2_Data.index = Prims.int_zero; + FStarC_Reflection_V2_Data.sort1 = (FStar_Sealed.seal typ); + FStarC_Reflection_V2_Data.ppname1 = + (FStarC_Reflection_V2_Data.as_ppname "x") } in Forall (b, typ, @@ -539,7 +544,7 @@ let (mk_Forall : (pred, ((FStar_Tactics_NamedView.pack (FStar_Tactics_NamedView.Tv_BVar b)), - FStar_Reflection_V2_Data.Q_Explicit))))) + FStarC_Reflection_V2_Data.Q_Explicit))))) let (mk_Exists : FStar_Tactics_NamedView.term -> FStar_Tactics_NamedView.term -> formula) = fun typ -> @@ -547,10 +552,10 @@ let (mk_Exists : let b = FStar_Tactics_NamedView.pack_bv { - FStar_Reflection_V2_Data.index = Prims.int_zero; - FStar_Reflection_V2_Data.sort1 = (FStar_Sealed.seal typ); - FStar_Reflection_V2_Data.ppname1 = - (FStar_Reflection_V2_Data.as_ppname "x") + FStarC_Reflection_V2_Data.index = Prims.int_zero; + FStarC_Reflection_V2_Data.sort1 = (FStar_Sealed.seal typ); + FStarC_Reflection_V2_Data.ppname1 = + (FStarC_Reflection_V2_Data.as_ppname "x") } in Exists (b, typ, @@ -559,7 +564,7 @@ let (mk_Exists : (pred, ((FStar_Tactics_NamedView.pack (FStar_Tactics_NamedView.Tv_BVar b)), - FStar_Reflection_V2_Data.Q_Explicit))))) + FStarC_Reflection_V2_Data.Q_Explicit))))) let (term_as_formula' : FStar_Tactics_NamedView.term -> (formula, unit) FStar_Tactics_Effect.tac_repr) @@ -591,13 +596,13 @@ let (term_as_formula' : (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> if - (FStar_Reflection_V2_Builtins.inspect_fv fv) = + (FStarC_Reflection_V2_Builtins.inspect_fv fv) = FStar_Reflection_Const.true_qn then True_ else if - (FStar_Reflection_V2_Builtins.inspect_fv fv) = - FStar_Reflection_Const.false_qn + (FStarC_Reflection_V2_Builtins.inspect_fv fv) + = FStar_Reflection_Const.false_qn then False_ else FV fv))) | FStar_Tactics_NamedView.Tv_UInst (fv, uu___2) -> @@ -606,13 +611,13 @@ let (term_as_formula' : (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> if - (FStar_Reflection_V2_Builtins.inspect_fv fv) = + (FStarC_Reflection_V2_Builtins.inspect_fv fv) = FStar_Reflection_Const.true_qn then True_ else if - (FStar_Reflection_V2_Builtins.inspect_fv fv) = - FStar_Reflection_Const.false_qn + (FStarC_Reflection_V2_Builtins.inspect_fv fv) + = FStar_Reflection_Const.false_qn then False_ else FV fv))) | FStar_Tactics_NamedView.Tv_App (h0, t1) -> @@ -718,14 +723,14 @@ let (term_as_formula' : | (FStar_Tactics_NamedView.Tv_FVar fv, (a1, - FStar_Reflection_V2_Data.Q_Implicit):: + FStarC_Reflection_V2_Data.Q_Implicit):: (a2, - FStar_Reflection_V2_Data.Q_Explicit):: + FStarC_Reflection_V2_Data.Q_Explicit):: (a3, - FStar_Reflection_V2_Data.Q_Explicit)::[]) + FStarC_Reflection_V2_Data.Q_Explicit)::[]) -> if - (FStar_Reflection_V2_Builtins.inspect_fv + (FStarC_Reflection_V2_Builtins.inspect_fv fv) = FStar_Reflection_Const.eq2_qn @@ -737,7 +742,7 @@ let (term_as_formula' : a3) else if - (FStar_Reflection_V2_Builtins.inspect_fv + (FStarC_Reflection_V2_Builtins.inspect_fv fv) = FStar_Reflection_Const.eq1_qn then @@ -748,7 +753,7 @@ let (term_as_formula' : a3) else if - (FStar_Reflection_V2_Builtins.inspect_fv + (FStarC_Reflection_V2_Builtins.inspect_fv fv) = FStar_Reflection_Const.lt_qn then @@ -757,7 +762,7 @@ let (term_as_formula' : a3) else if - (FStar_Reflection_V2_Builtins.inspect_fv + (FStarC_Reflection_V2_Builtins.inspect_fv fv) = FStar_Reflection_Const.lte_qn then @@ -766,7 +771,7 @@ let (term_as_formula' : a3) else if - (FStar_Reflection_V2_Builtins.inspect_fv + (FStarC_Reflection_V2_Builtins.inspect_fv fv) = FStar_Reflection_Const.gt_qn then @@ -775,7 +780,7 @@ let (term_as_formula' : a3) else if - (FStar_Reflection_V2_Builtins.inspect_fv + (FStarC_Reflection_V2_Builtins.inspect_fv fv) = FStar_Reflection_Const.gte_qn then @@ -790,12 +795,12 @@ let (term_as_formula' : | (FStar_Tactics_NamedView.Tv_FVar fv, (a1, - FStar_Reflection_V2_Data.Q_Explicit):: + FStarC_Reflection_V2_Data.Q_Explicit):: (a2, - FStar_Reflection_V2_Data.Q_Explicit)::[]) + FStarC_Reflection_V2_Data.Q_Explicit)::[]) -> if - (FStar_Reflection_V2_Builtins.inspect_fv + (FStarC_Reflection_V2_Builtins.inspect_fv fv) = FStar_Reflection_Const.imp_qn @@ -804,7 +809,7 @@ let (term_as_formula' : (a1, a2) else if - (FStar_Reflection_V2_Builtins.inspect_fv + (FStarC_Reflection_V2_Builtins.inspect_fv fv) = FStar_Reflection_Const.and_qn then @@ -812,7 +817,7 @@ let (term_as_formula' : (a1, a2) else if - (FStar_Reflection_V2_Builtins.inspect_fv + (FStarC_Reflection_V2_Builtins.inspect_fv fv) = FStar_Reflection_Const.iff_qn then @@ -820,7 +825,7 @@ let (term_as_formula' : (a1, a2) else if - (FStar_Reflection_V2_Builtins.inspect_fv + (FStarC_Reflection_V2_Builtins.inspect_fv fv) = FStar_Reflection_Const.or_qn then @@ -828,7 +833,7 @@ let (term_as_formula' : (a1, a2) else if - (FStar_Reflection_V2_Builtins.inspect_fv + (FStarC_Reflection_V2_Builtins.inspect_fv fv) = FStar_Reflection_Const.eq2_qn then @@ -838,7 +843,7 @@ let (term_as_formula' : a1, a2) else if - (FStar_Reflection_V2_Builtins.inspect_fv + (FStarC_Reflection_V2_Builtins.inspect_fv fv) = FStar_Reflection_Const.eq1_qn then @@ -854,12 +859,12 @@ let (term_as_formula' : | (FStar_Tactics_NamedView.Tv_FVar fv, (a1, - FStar_Reflection_V2_Data.Q_Implicit):: + FStarC_Reflection_V2_Data.Q_Implicit):: (a2, - FStar_Reflection_V2_Data.Q_Explicit)::[]) + FStarC_Reflection_V2_Data.Q_Explicit)::[]) -> if - (FStar_Reflection_V2_Builtins.inspect_fv + (FStarC_Reflection_V2_Builtins.inspect_fv fv) = FStar_Reflection_Const.forall_qn @@ -868,7 +873,7 @@ let (term_as_formula' : a2 else if - (FStar_Reflection_V2_Builtins.inspect_fv + (FStarC_Reflection_V2_Builtins.inspect_fv fv) = FStar_Reflection_Const.exists_qn then @@ -882,33 +887,33 @@ let (term_as_formula' : | (FStar_Tactics_NamedView.Tv_FVar fv, (a, - FStar_Reflection_V2_Data.Q_Explicit)::[]) + FStarC_Reflection_V2_Data.Q_Explicit)::[]) -> if - (FStar_Reflection_V2_Builtins.inspect_fv + (FStarC_Reflection_V2_Builtins.inspect_fv fv) = FStar_Reflection_Const.not_qn then Not a else if - (FStar_Reflection_V2_Builtins.inspect_fv + (FStarC_Reflection_V2_Builtins.inspect_fv fv) = FStar_Reflection_Const.b2t_qn then (if term_eq a - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const - FStar_Reflection_V2_Data.C_False)) + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const + FStarC_Reflection_V2_Data.C_False)) then False_ else if term_eq a - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const - FStar_Reflection_V2_Data.C_True)) + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const + FStarC_Reflection_V2_Data.C_True)) then True_ else @@ -928,7 +933,7 @@ let (term_as_formula' : t1)))))) uu___5))) uu___3))) | FStar_Tactics_NamedView.Tv_Const - (FStar_Reflection_V2_Data.C_Int i) -> + (FStarC_Reflection_V2_Data.C_Int i) -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac @@ -993,21 +998,21 @@ let (term_as_formula' : Obj.magic (Obj.repr (FStar_Tactics_Effect.raise - (FStar_Tactics_Common.TacticFailure - ([FStar_Pprint.arbitrary_string + (FStarC_Tactics_Common.TacticFailure + ([FStarC_Pprint.arbitrary_string "Unexpected: term_as_formula"], FStar_Pervasives_Native.None))))) uu___1) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Reflection.V2.Formula.term_as_formula'" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Reflection.V2.Formula.term_as_formula' (plugin)" - (FStar_Tactics_Native.from_tactic_1 term_as_formula') - FStar_Reflection_V2_Embeddings.e_term e_formula psc ncb us + (FStarC_Tactics_Native.from_tactic_1 term_as_formula') + FStarC_Reflection_V2_Embeddings.e_term e_formula psc ncb us args) let (term_as_formula : FStar_Tactics_NamedView.term -> @@ -1036,91 +1041,91 @@ let (formula_as_term_view : formula -> FStar_Tactics_NamedView.term_view) = fun a -> FStar_Tactics_NamedView.Tv_App ((FStar_Tactics_NamedView.pack tv1), a)) tv args in - let e = FStar_Reflection_V2_Data.Q_Explicit in - let i = FStar_Reflection_V2_Data.Q_Implicit in + let e = FStarC_Reflection_V2_Data.Q_Explicit in + let i = FStarC_Reflection_V2_Data.Q_Implicit in match f with | True_ -> FStar_Tactics_NamedView.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_fv FStar_Reflection_Const.true_qn) | False_ -> FStar_Tactics_NamedView.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_fv FStar_Reflection_Const.false_qn) | Comp (Eq (FStar_Pervasives_Native.None), l, r) -> mk_app' (FStar_Tactics_NamedView.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_fv FStar_Reflection_Const.eq2_qn)) [(l, e); (r, e)] | Comp (Eq (FStar_Pervasives_Native.Some t), l, r) -> mk_app' (FStar_Tactics_NamedView.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_fv FStar_Reflection_Const.eq2_qn)) [(t, i); (l, e); (r, e)] | Comp (BoolEq (FStar_Pervasives_Native.None), l, r) -> mk_app' (FStar_Tactics_NamedView.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_fv FStar_Reflection_Const.eq1_qn)) [(l, e); (r, e)] | Comp (BoolEq (FStar_Pervasives_Native.Some t), l, r) -> mk_app' (FStar_Tactics_NamedView.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_fv FStar_Reflection_Const.eq1_qn)) [(t, i); (l, e); (r, e)] | Comp (Lt, l, r) -> mk_app' (FStar_Tactics_NamedView.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_fv FStar_Reflection_Const.lt_qn)) [(l, e); (r, e)] | Comp (Le, l, r) -> mk_app' (FStar_Tactics_NamedView.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_fv FStar_Reflection_Const.lte_qn)) [(l, e); (r, e)] | Comp (Gt, l, r) -> mk_app' (FStar_Tactics_NamedView.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_fv FStar_Reflection_Const.gt_qn)) [(l, e); (r, e)] | Comp (Ge, l, r) -> mk_app' (FStar_Tactics_NamedView.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_fv FStar_Reflection_Const.gte_qn)) [(l, e); (r, e)] | And (p, q) -> mk_app' (FStar_Tactics_NamedView.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_fv FStar_Reflection_Const.and_qn)) [(p, e); (q, e)] | Or (p, q) -> mk_app' (FStar_Tactics_NamedView.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_fv FStar_Reflection_Const.or_qn)) [(p, e); (q, e)] | Implies (p, q) -> mk_app' (FStar_Tactics_NamedView.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_fv FStar_Reflection_Const.imp_qn)) [(p, e); (q, e)] | Not p -> mk_app' (FStar_Tactics_NamedView.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_fv FStar_Reflection_Const.not_qn)) [(p, e)] | Iff (p, q) -> mk_app' (FStar_Tactics_NamedView.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_fv FStar_Reflection_Const.iff_qn)) [(p, e); (q, e)] | Forall (b, sort, t) -> FStar_Tactics_NamedView.Tv_Unknown | Exists (b, sort, t) -> FStar_Tactics_NamedView.Tv_Unknown | App (p, q) -> FStar_Tactics_NamedView.Tv_App - (p, (q, FStar_Reflection_V2_Data.Q_Explicit)) + (p, (q, FStarC_Reflection_V2_Data.Q_Explicit)) | Name b -> FStar_Tactics_NamedView.Tv_Var b | FV fv -> FStar_Tactics_NamedView.Tv_FVar fv | IntLit i1 -> - FStar_Tactics_NamedView.Tv_Const (FStar_Reflection_V2_Data.C_Int i1) + FStar_Tactics_NamedView.Tv_Const (FStarC_Reflection_V2_Data.C_Int i1) | F_Unknown -> FStar_Tactics_NamedView.Tv_Unknown let (formula_as_term : formula -> FStar_Tactics_NamedView.term) = fun f -> FStar_Tactics_NamedView.pack (formula_as_term_view f) @@ -1148,7 +1153,7 @@ let (namedv_to_string : (fun namedvv -> Obj.magic (FStar_Tactics_Unseal.unseal - namedvv.FStar_Reflection_V2_Data.ppname)) uu___1) + namedvv.FStarC_Reflection_V2_Data.ppname)) uu___1) let (formula_to_string : formula -> (Prims.string, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> @@ -1178,7 +1183,8 @@ let (formula_to_string : (Obj.repr (let uu___2 = let uu___3 = - FStar_Tactics_V2_Builtins.term_to_string t in + FStarC_Tactics_V2_Builtins.term_to_string + t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1239,7 +1245,7 @@ let (formula_to_string : let uu___3 = let uu___4 = let uu___5 = - FStar_Tactics_V2_Builtins.term_to_string l in + FStarC_Tactics_V2_Builtins.term_to_string l in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1263,7 +1269,7 @@ let (formula_to_string : let uu___7 = let uu___8 = let uu___9 = - FStar_Tactics_V2_Builtins.term_to_string + FStarC_Tactics_V2_Builtins.term_to_string r in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1407,7 +1413,8 @@ let (formula_to_string : (Obj.repr (let uu___2 = let uu___3 = - FStar_Tactics_V2_Builtins.term_to_string t in + FStarC_Tactics_V2_Builtins.term_to_string + t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1468,7 +1475,7 @@ let (formula_to_string : let uu___3 = let uu___4 = let uu___5 = - FStar_Tactics_V2_Builtins.term_to_string l in + FStarC_Tactics_V2_Builtins.term_to_string l in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1492,7 +1499,7 @@ let (formula_to_string : let uu___7 = let uu___8 = let uu___9 = - FStar_Tactics_V2_Builtins.term_to_string + FStarC_Tactics_V2_Builtins.term_to_string r in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1624,7 +1631,7 @@ let (formula_to_string : Obj.magic (Obj.repr (let uu___ = - let uu___1 = FStar_Tactics_V2_Builtins.term_to_string l in + let uu___1 = FStarC_Tactics_V2_Builtins.term_to_string l in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1644,7 +1651,7 @@ let (formula_to_string : let uu___3 = let uu___4 = let uu___5 = - FStar_Tactics_V2_Builtins.term_to_string r in + FStarC_Tactics_V2_Builtins.term_to_string r in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1727,7 +1734,7 @@ let (formula_to_string : Obj.magic (Obj.repr (let uu___ = - let uu___1 = FStar_Tactics_V2_Builtins.term_to_string l in + let uu___1 = FStarC_Tactics_V2_Builtins.term_to_string l in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1747,7 +1754,7 @@ let (formula_to_string : let uu___3 = let uu___4 = let uu___5 = - FStar_Tactics_V2_Builtins.term_to_string r in + FStarC_Tactics_V2_Builtins.term_to_string r in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1830,7 +1837,7 @@ let (formula_to_string : Obj.magic (Obj.repr (let uu___ = - let uu___1 = FStar_Tactics_V2_Builtins.term_to_string l in + let uu___1 = FStarC_Tactics_V2_Builtins.term_to_string l in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1850,7 +1857,7 @@ let (formula_to_string : let uu___3 = let uu___4 = let uu___5 = - FStar_Tactics_V2_Builtins.term_to_string r in + FStarC_Tactics_V2_Builtins.term_to_string r in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1933,7 +1940,7 @@ let (formula_to_string : Obj.magic (Obj.repr (let uu___ = - let uu___1 = FStar_Tactics_V2_Builtins.term_to_string l in + let uu___1 = FStarC_Tactics_V2_Builtins.term_to_string l in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1953,7 +1960,7 @@ let (formula_to_string : let uu___3 = let uu___4 = let uu___5 = - FStar_Tactics_V2_Builtins.term_to_string r in + FStarC_Tactics_V2_Builtins.term_to_string r in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2036,7 +2043,7 @@ let (formula_to_string : Obj.magic (Obj.repr (let uu___ = - let uu___1 = FStar_Tactics_V2_Builtins.term_to_string p in + let uu___1 = FStarC_Tactics_V2_Builtins.term_to_string p in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2056,7 +2063,7 @@ let (formula_to_string : let uu___3 = let uu___4 = let uu___5 = - FStar_Tactics_V2_Builtins.term_to_string q in + FStarC_Tactics_V2_Builtins.term_to_string q in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2139,7 +2146,7 @@ let (formula_to_string : Obj.magic (Obj.repr (let uu___ = - let uu___1 = FStar_Tactics_V2_Builtins.term_to_string p in + let uu___1 = FStarC_Tactics_V2_Builtins.term_to_string p in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2159,7 +2166,7 @@ let (formula_to_string : let uu___3 = let uu___4 = let uu___5 = - FStar_Tactics_V2_Builtins.term_to_string q in + FStarC_Tactics_V2_Builtins.term_to_string q in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2242,7 +2249,7 @@ let (formula_to_string : Obj.magic (Obj.repr (let uu___ = - let uu___1 = FStar_Tactics_V2_Builtins.term_to_string p in + let uu___1 = FStarC_Tactics_V2_Builtins.term_to_string p in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2262,7 +2269,7 @@ let (formula_to_string : let uu___3 = let uu___4 = let uu___5 = - FStar_Tactics_V2_Builtins.term_to_string q in + FStarC_Tactics_V2_Builtins.term_to_string q in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2345,7 +2352,7 @@ let (formula_to_string : Obj.magic (Obj.repr (let uu___ = - let uu___1 = FStar_Tactics_V2_Builtins.term_to_string p in + let uu___1 = FStarC_Tactics_V2_Builtins.term_to_string p in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2382,7 +2389,7 @@ let (formula_to_string : Obj.magic (Obj.repr (let uu___ = - let uu___1 = FStar_Tactics_V2_Builtins.term_to_string p in + let uu___1 = FStarC_Tactics_V2_Builtins.term_to_string p in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2402,7 +2409,7 @@ let (formula_to_string : let uu___3 = let uu___4 = let uu___5 = - FStar_Tactics_V2_Builtins.term_to_string q in + FStarC_Tactics_V2_Builtins.term_to_string q in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2485,7 +2492,7 @@ let (formula_to_string : Obj.magic (Obj.repr (let uu___ = - let uu___1 = FStar_Tactics_V2_Builtins.term_to_string t in + let uu___1 = FStarC_Tactics_V2_Builtins.term_to_string t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2522,7 +2529,7 @@ let (formula_to_string : Obj.magic (Obj.repr (let uu___ = - let uu___1 = FStar_Tactics_V2_Builtins.term_to_string t in + let uu___1 = FStarC_Tactics_V2_Builtins.term_to_string t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2559,7 +2566,7 @@ let (formula_to_string : Obj.magic (Obj.repr (let uu___ = - let uu___1 = FStar_Tactics_V2_Builtins.term_to_string p in + let uu___1 = FStarC_Tactics_V2_Builtins.term_to_string p in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2579,7 +2586,7 @@ let (formula_to_string : let uu___3 = let uu___4 = let uu___5 = - FStar_Tactics_V2_Builtins.term_to_string q in + FStarC_Tactics_V2_Builtins.term_to_string q in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2703,7 +2710,7 @@ let (formula_to_string : Prims.strcat "FV (" (Prims.strcat (FStar_Reflection_V2_Derived.flatten_name - (FStar_Reflection_V2_Builtins.inspect_fv fv)) + (FStarC_Reflection_V2_Builtins.inspect_fv fv)) ")")))) | IntLit i -> Obj.magic diff --git a/ocaml/fstar-lib/generated/FStar_Reflection_V2_Interpreter.ml b/ocaml/fstar-lib/generated/FStar_Reflection_V2_Interpreter.ml deleted file mode 100644 index d75a7b7229f..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Reflection_V2_Interpreter.ml +++ /dev/null @@ -1,627 +0,0 @@ -open Prims -let solve : 'a . 'a -> 'a = fun ev -> ev -let mk1 : - 'res 't1 . - Prims.string -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 'res FStar_Syntax_Embeddings_Base.embedding -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 'res FStar_TypeChecker_NBETerm.embedding -> - ('t1 -> 'res) -> FStar_TypeChecker_Primops_Base.primitive_step - = - fun nm -> - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun f -> - let lid = - FStar_Reflection_V2_Constants.fstar_refl_builtins_lid nm in - FStar_TypeChecker_Primops_Base.mk1' Prims.int_zero lid uu___ - uu___2 uu___1 uu___3 - (fun x -> - let uu___4 = f x in FStar_Pervasives_Native.Some uu___4) - (fun x -> - let uu___4 = f x in FStar_Pervasives_Native.Some uu___4) -let mk2 : - 'res 't1 't2 . - Prims.string -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 'res FStar_Syntax_Embeddings_Base.embedding -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 'res FStar_TypeChecker_NBETerm.embedding -> - ('t1 -> 't2 -> 'res) -> - FStar_TypeChecker_Primops_Base.primitive_step - = - fun nm -> - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun uu___4 -> - fun uu___5 -> - fun f -> - let lid = - FStar_Reflection_V2_Constants.fstar_refl_builtins_lid nm in - FStar_TypeChecker_Primops_Base.mk2' Prims.int_zero lid - uu___ uu___3 uu___1 uu___4 uu___2 uu___5 - (fun x -> - fun y -> - let uu___6 = f x y in - FStar_Pervasives_Native.Some uu___6) - (fun x -> - fun y -> - let uu___6 = f x y in - FStar_Pervasives_Native.Some uu___6) -let mk3 : - 'res 't1 't2 't3 . - Prims.string -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 'res FStar_Syntax_Embeddings_Base.embedding -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 'res FStar_TypeChecker_NBETerm.embedding -> - ('t1 -> 't2 -> 't3 -> 'res) -> - FStar_TypeChecker_Primops_Base.primitive_step - = - fun nm -> - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun uu___4 -> - fun uu___5 -> - fun uu___6 -> - fun uu___7 -> - fun f -> - let lid = - FStar_Reflection_V2_Constants.fstar_refl_builtins_lid - nm in - FStar_TypeChecker_Primops_Base.mk3' Prims.int_zero lid - uu___ uu___4 uu___1 uu___5 uu___2 uu___6 uu___3 - uu___7 - (fun x -> - fun y -> - fun z -> - let uu___8 = f x y z in - FStar_Pervasives_Native.Some uu___8) - (fun x -> - fun y -> - fun z -> - let uu___8 = f x y z in - FStar_Pervasives_Native.Some uu___8) -let (reflection_primops : - FStar_TypeChecker_Primops_Base.primitive_step Prims.list) = - let uu___ = - mk1 "inspect_ln" FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_term_view - FStar_Reflection_V2_NBEEmbeddings.e_term - FStar_Reflection_V2_NBEEmbeddings.e_term_view - FStar_Reflection_V2_Builtins.inspect_ln in - let uu___1 = - let uu___2 = - mk1 "pack_ln" FStar_Reflection_V2_Embeddings.e_term_view - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_NBEEmbeddings.e_term_view - FStar_Reflection_V2_NBEEmbeddings.e_term - FStar_Reflection_V2_Builtins.pack_ln in - let uu___3 = - let uu___4 = - mk1 "inspect_fv" FStar_Reflection_V2_Embeddings.e_fv - FStar_Syntax_Embeddings.e_string_list - FStar_Reflection_V2_NBEEmbeddings.e_fv - FStar_TypeChecker_NBETerm.e_string_list - FStar_Reflection_V2_Builtins.inspect_fv in - let uu___5 = - let uu___6 = - mk1 "pack_fv" FStar_Syntax_Embeddings.e_string_list - FStar_Reflection_V2_Embeddings.e_fv - FStar_TypeChecker_NBETerm.e_string_list - FStar_Reflection_V2_NBEEmbeddings.e_fv - FStar_Reflection_V2_Builtins.pack_fv in - let uu___7 = - let uu___8 = - mk1 "inspect_comp" FStar_Reflection_V2_Embeddings.e_comp - FStar_Reflection_V2_Embeddings.e_comp_view - FStar_Reflection_V2_NBEEmbeddings.e_comp - FStar_Reflection_V2_NBEEmbeddings.e_comp_view - FStar_Reflection_V2_Builtins.inspect_comp in - let uu___9 = - let uu___10 = - mk1 "pack_comp" FStar_Reflection_V2_Embeddings.e_comp_view - FStar_Reflection_V2_Embeddings.e_comp - FStar_Reflection_V2_NBEEmbeddings.e_comp_view - FStar_Reflection_V2_NBEEmbeddings.e_comp - FStar_Reflection_V2_Builtins.pack_comp in - let uu___11 = - let uu___12 = - mk1 "inspect_universe" - FStar_Reflection_V2_Embeddings.e_universe - FStar_Reflection_V2_Embeddings.e_universe_view - FStar_Reflection_V2_NBEEmbeddings.e_universe - FStar_Reflection_V2_NBEEmbeddings.e_universe_view - FStar_Reflection_V2_Builtins.inspect_universe in - let uu___13 = - let uu___14 = - mk1 "pack_universe" - FStar_Reflection_V2_Embeddings.e_universe_view - FStar_Reflection_V2_Embeddings.e_universe - FStar_Reflection_V2_NBEEmbeddings.e_universe_view - FStar_Reflection_V2_NBEEmbeddings.e_universe - FStar_Reflection_V2_Builtins.pack_universe in - let uu___15 = - let uu___16 = - mk1 "inspect_sigelt" - FStar_Reflection_V2_Embeddings.e_sigelt - FStar_Reflection_V2_Embeddings.e_sigelt_view - FStar_Reflection_V2_NBEEmbeddings.e_sigelt - FStar_Reflection_V2_NBEEmbeddings.e_sigelt_view - FStar_Reflection_V2_Builtins.inspect_sigelt in - let uu___17 = - let uu___18 = - mk1 "pack_sigelt" - FStar_Reflection_V2_Embeddings.e_sigelt_view - FStar_Reflection_V2_Embeddings.e_sigelt - FStar_Reflection_V2_NBEEmbeddings.e_sigelt_view - FStar_Reflection_V2_NBEEmbeddings.e_sigelt - FStar_Reflection_V2_Builtins.pack_sigelt in - let uu___19 = - let uu___20 = - mk1 "inspect_lb" - FStar_Reflection_V2_Embeddings.e_letbinding - FStar_Reflection_V2_Embeddings.e_lb_view - FStar_Reflection_V2_NBEEmbeddings.e_letbinding - FStar_Reflection_V2_NBEEmbeddings.e_lb_view - FStar_Reflection_V2_Builtins.inspect_lb in - let uu___21 = - let uu___22 = - mk1 "pack_lb" - FStar_Reflection_V2_Embeddings.e_lb_view - FStar_Reflection_V2_Embeddings.e_letbinding - FStar_Reflection_V2_NBEEmbeddings.e_lb_view - FStar_Reflection_V2_NBEEmbeddings.e_letbinding - FStar_Reflection_V2_Builtins.pack_lb in - let uu___23 = - let uu___24 = - mk1 "inspect_namedv" - FStar_Reflection_V2_Embeddings.e_namedv - FStar_Reflection_V2_Embeddings.e_namedv_view - FStar_Reflection_V2_NBEEmbeddings.e_namedv - FStar_Reflection_V2_NBEEmbeddings.e_namedv_view - FStar_Reflection_V2_Builtins.inspect_namedv in - let uu___25 = - let uu___26 = - mk1 "pack_namedv" - FStar_Reflection_V2_Embeddings.e_namedv_view - FStar_Reflection_V2_Embeddings.e_namedv - FStar_Reflection_V2_NBEEmbeddings.e_namedv_view - FStar_Reflection_V2_NBEEmbeddings.e_namedv - FStar_Reflection_V2_Builtins.pack_namedv in - let uu___27 = - let uu___28 = - mk1 "inspect_bv" - FStar_Reflection_V2_Embeddings.e_bv - FStar_Reflection_V2_Embeddings.e_bv_view - FStar_Reflection_V2_NBEEmbeddings.e_bv - FStar_Reflection_V2_NBEEmbeddings.e_bv_view - FStar_Reflection_V2_Builtins.inspect_bv in - let uu___29 = - let uu___30 = - mk1 "pack_bv" - FStar_Reflection_V2_Embeddings.e_bv_view - FStar_Reflection_V2_Embeddings.e_bv - FStar_Reflection_V2_NBEEmbeddings.e_bv_view - FStar_Reflection_V2_NBEEmbeddings.e_bv - FStar_Reflection_V2_Builtins.pack_bv in - let uu___31 = - let uu___32 = - mk1 "inspect_binder" - FStar_Reflection_V2_Embeddings.e_binder - FStar_Reflection_V2_Embeddings.e_binder_view - FStar_Reflection_V2_NBEEmbeddings.e_binder - FStar_Reflection_V2_NBEEmbeddings.e_binder_view - FStar_Reflection_V2_Builtins.inspect_binder in - let uu___33 = - let uu___34 = - mk1 "pack_binder" - FStar_Reflection_V2_Embeddings.e_binder_view - FStar_Reflection_V2_Embeddings.e_binder - FStar_Reflection_V2_NBEEmbeddings.e_binder_view - FStar_Reflection_V2_NBEEmbeddings.e_binder - FStar_Reflection_V2_Builtins.pack_binder in - let uu___35 = - let uu___36 = - mk1 "sigelt_opts" - FStar_Reflection_V2_Embeddings.e_sigelt - (FStar_Syntax_Embeddings.e_option - FStar_Syntax_Embeddings.e_vconfig) - FStar_Reflection_V2_NBEEmbeddings.e_sigelt - (FStar_TypeChecker_NBETerm.e_option - FStar_TypeChecker_NBETerm.e_vconfig) - FStar_Reflection_V2_Builtins.sigelt_opts in - let uu___37 = - let uu___38 = - mk1 "embed_vconfig" - FStar_Syntax_Embeddings.e_vconfig - FStar_Reflection_V2_Embeddings.e_term - FStar_TypeChecker_NBETerm.e_vconfig - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Reflection_V2_Builtins.embed_vconfig in - let uu___39 = - let uu___40 = - mk1 "sigelt_attrs" - FStar_Reflection_V2_Embeddings.e_sigelt - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_term) - FStar_Reflection_V2_NBEEmbeddings.e_sigelt - FStar_Reflection_V2_NBEEmbeddings.e_attributes - FStar_Reflection_V2_Builtins.sigelt_attrs in - let uu___41 = - let uu___42 = - mk2 "set_sigelt_attrs" - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_term) - FStar_Reflection_V2_Embeddings.e_sigelt - FStar_Reflection_V2_Embeddings.e_sigelt - FStar_Reflection_V2_NBEEmbeddings.e_attributes - FStar_Reflection_V2_NBEEmbeddings.e_sigelt - FStar_Reflection_V2_NBEEmbeddings.e_sigelt - FStar_Reflection_V2_Builtins.set_sigelt_attrs in - let uu___43 = - let uu___44 = - mk1 "sigelt_quals" - FStar_Reflection_V2_Embeddings.e_sigelt - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_qualifier) - FStar_Reflection_V2_NBEEmbeddings.e_sigelt - FStar_Reflection_V2_NBEEmbeddings.e_qualifiers - FStar_Reflection_V2_Builtins.sigelt_quals in - let uu___45 = - let uu___46 = - mk2 "set_sigelt_quals" - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_qualifier) - FStar_Reflection_V2_Embeddings.e_sigelt - FStar_Reflection_V2_Embeddings.e_sigelt - FStar_Reflection_V2_NBEEmbeddings.e_qualifiers - FStar_Reflection_V2_NBEEmbeddings.e_sigelt - FStar_Reflection_V2_NBEEmbeddings.e_sigelt - FStar_Reflection_V2_Builtins.set_sigelt_quals in - let uu___47 = - let uu___48 = - mk2 "subst_term" - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_subst_elt) - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_NBEEmbeddings.e_subst - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Reflection_V2_Builtins.subst_term in - let uu___49 = - let uu___50 = - mk2 "subst_comp" - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_subst_elt) - FStar_Reflection_V2_Embeddings.e_comp - FStar_Reflection_V2_Embeddings.e_comp - FStar_Reflection_V2_NBEEmbeddings.e_subst - FStar_Reflection_V2_NBEEmbeddings.e_comp - FStar_Reflection_V2_NBEEmbeddings.e_comp - FStar_Reflection_V2_Builtins.subst_comp in - let uu___51 = - let uu___52 = - mk2 "compare_bv" - FStar_Reflection_V2_Embeddings.e_bv - FStar_Reflection_V2_Embeddings.e_bv - FStar_Syntax_Embeddings.e_order - FStar_Reflection_V2_NBEEmbeddings.e_bv - FStar_Reflection_V2_NBEEmbeddings.e_bv - FStar_TypeChecker_NBETerm.e_order - FStar_Reflection_V2_Builtins.compare_bv in - let uu___53 = - let uu___54 = - mk2 - "compare_namedv" - FStar_Reflection_V2_Embeddings.e_namedv - FStar_Reflection_V2_Embeddings.e_namedv - FStar_Syntax_Embeddings.e_order - FStar_Reflection_V2_NBEEmbeddings.e_namedv - FStar_Reflection_V2_NBEEmbeddings.e_namedv - FStar_TypeChecker_NBETerm.e_order - FStar_Reflection_V2_Builtins.compare_namedv in - let uu___55 = - let uu___56 = - mk2 - "lookup_attr_ses" - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_env - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_sigelt) - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Reflection_V2_NBEEmbeddings.e_env - (FStar_TypeChecker_NBETerm.e_list - FStar_Reflection_V2_NBEEmbeddings.e_sigelt) - FStar_Reflection_V2_Builtins.lookup_attr_ses in - let uu___57 = - let uu___58 = - mk2 - "lookup_attr" - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_env - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_fv) - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Reflection_V2_NBEEmbeddings.e_env - (FStar_TypeChecker_NBETerm.e_list - FStar_Reflection_V2_NBEEmbeddings.e_fv) - FStar_Reflection_V2_Builtins.lookup_attr in - let uu___59 = - let uu___60 = - mk1 - "all_defs_in_env" - FStar_Reflection_V2_Embeddings.e_env - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_fv) - FStar_Reflection_V2_NBEEmbeddings.e_env - (FStar_TypeChecker_NBETerm.e_list - FStar_Reflection_V2_NBEEmbeddings.e_fv) - FStar_Reflection_V2_Builtins.all_defs_in_env in - let uu___61 = - let uu___62 = - mk2 - "defs_in_module" - FStar_Reflection_V2_Embeddings.e_env - FStar_Syntax_Embeddings.e_string_list - ( - FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_fv) - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_TypeChecker_NBETerm.e_string_list - ( - FStar_TypeChecker_NBETerm.e_list - FStar_Reflection_V2_NBEEmbeddings.e_fv) - FStar_Reflection_V2_Builtins.defs_in_module in - let uu___63 = - let uu___64 - = - mk2 - "term_eq" - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_term - FStar_Syntax_Embeddings.e_bool - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_TypeChecker_NBETerm.e_bool - FStar_Reflection_V2_Builtins.term_eq in - let uu___65 - = - let uu___66 - = - mk1 - "moduleof" - FStar_Reflection_V2_Embeddings.e_env - FStar_Syntax_Embeddings.e_string_list - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_TypeChecker_NBETerm.e_string_list - FStar_Reflection_V2_Builtins.moduleof in - let uu___67 - = - let uu___68 - = - mk1 - "vars_of_env" - FStar_Reflection_V2_Embeddings.e_env - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_binding) - FStar_Reflection_V2_NBEEmbeddings.e_env - (FStar_TypeChecker_NBETerm.e_list - FStar_Reflection_V2_NBEEmbeddings.e_binding) - FStar_Reflection_V2_Builtins.vars_of_env in - let uu___69 - = - let uu___70 - = - mk2 - "lookup_typ" - FStar_Reflection_V2_Embeddings.e_env - FStar_Syntax_Embeddings.e_string_list - (FStar_Syntax_Embeddings.e_option - FStar_Reflection_V2_Embeddings.e_sigelt) - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_TypeChecker_NBETerm.e_string_list - (FStar_TypeChecker_NBETerm.e_option - FStar_Reflection_V2_NBEEmbeddings.e_sigelt) - FStar_Reflection_V2_Builtins.lookup_typ in - let uu___71 - = - let uu___72 - = - mk1 - "env_open_modules" - FStar_Reflection_V2_Embeddings.e_env - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_string_list) - FStar_Reflection_V2_NBEEmbeddings.e_env - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_string_list) - FStar_Reflection_V2_Builtins.env_open_modules in - let uu___73 - = - let uu___74 - = - mk1 - "implode_qn" - FStar_Syntax_Embeddings.e_string_list - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string_list - FStar_TypeChecker_NBETerm.e_string - FStar_Reflection_V2_Builtins.implode_qn in - let uu___75 - = - let uu___76 - = - mk1 - "explode_qn" - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_string_list - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_string_list - FStar_Reflection_V2_Builtins.explode_qn in - let uu___77 - = - let uu___78 - = - mk2 - "compare_string" - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_int - FStar_Reflection_V2_Builtins.compare_string in - let uu___79 - = - let uu___80 - = - mk2 - "push_namedv" - FStar_Reflection_V2_Embeddings.e_env - FStar_Reflection_V2_Embeddings.e_namedv - FStar_Reflection_V2_Embeddings.e_env - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_Reflection_V2_NBEEmbeddings.e_namedv - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_Reflection_V2_Builtins.push_namedv in - let uu___81 - = - let uu___82 - = - mk1 - "range_of_term" - FStar_Reflection_V2_Embeddings.e_term - FStar_Syntax_Embeddings.e_range - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_TypeChecker_NBETerm.e_range - FStar_Reflection_V2_Builtins.range_of_term in - let uu___83 - = - let uu___84 - = - mk1 - "range_of_sigelt" - FStar_Reflection_V2_Embeddings.e_sigelt - FStar_Syntax_Embeddings.e_range - FStar_Reflection_V2_NBEEmbeddings.e_sigelt - FStar_TypeChecker_NBETerm.e_range - FStar_Reflection_V2_Builtins.range_of_sigelt in - let uu___85 - = - let uu___86 - = - mk1 - "inspect_ident" - FStar_Reflection_V2_Embeddings.e_univ_name - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_range) - FStar_Reflection_V2_NBEEmbeddings.e_univ_name - (FStar_TypeChecker_NBETerm.e_tuple2 - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_range) - FStar_Reflection_V2_Builtins.inspect_ident in - let uu___87 - = - let uu___88 - = - mk1 - "pack_ident" - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_range) - FStar_Reflection_V2_Embeddings.e_univ_name - (FStar_TypeChecker_NBETerm.e_tuple2 - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_range) - FStar_Reflection_V2_NBEEmbeddings.e_univ_name - FStar_Reflection_V2_Builtins.pack_ident in - [uu___88] in - uu___86 - :: - uu___87 in - uu___84 - :: - uu___85 in - uu___82 - :: - uu___83 in - uu___80 - :: - uu___81 in - uu___78 - :: - uu___79 in - uu___76 - :: - uu___77 in - uu___74 - :: - uu___75 in - uu___72 - :: - uu___73 in - uu___70 - :: - uu___71 in - uu___68 - :: - uu___69 in - uu___66 - :: - uu___67 in - uu___64 :: - uu___65 in - uu___62 :: - uu___63 in - uu___60 :: - uu___61 in - uu___58 :: - uu___59 in - uu___56 :: uu___57 in - uu___54 :: uu___55 in - uu___52 :: uu___53 in - uu___50 :: uu___51 in - uu___48 :: uu___49 in - uu___46 :: uu___47 in - uu___44 :: uu___45 in - uu___42 :: uu___43 in - uu___40 :: uu___41 in - uu___38 :: uu___39 in - uu___36 :: uu___37 in - uu___34 :: uu___35 in - uu___32 :: uu___33 in - uu___30 :: uu___31 in - uu___28 :: uu___29 in - uu___26 :: uu___27 in - uu___24 :: uu___25 in - uu___22 :: uu___23 in - uu___20 :: uu___21 in - uu___18 :: uu___19 in - uu___16 :: uu___17 in - uu___14 :: uu___15 in - uu___12 :: uu___13 in - uu___10 :: uu___11 in - uu___8 :: uu___9 in - uu___6 :: uu___7 in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - uu___ :: uu___1 -let (uu___0 : unit) = - FStar_List.iter FStar_TypeChecker_Cfg.register_extra_step - reflection_primops \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Reflection_V2_NBEEmbeddings.ml b/ocaml/fstar-lib/generated/FStar_Reflection_V2_NBEEmbeddings.ml deleted file mode 100644 index 41cb0fa4fde..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Reflection_V2_NBEEmbeddings.ml +++ /dev/null @@ -1,2638 +0,0 @@ -open Prims -let (noaqs : FStar_Syntax_Syntax.antiquotations) = (Prims.int_zero, []) -let (mkFV : - FStar_Syntax_Syntax.fv -> - FStar_Syntax_Syntax.universe Prims.list -> - (FStar_TypeChecker_NBETerm.t * FStar_Syntax_Syntax.aqual) Prims.list -> - FStar_TypeChecker_NBETerm.t) - = - fun fv -> - fun us -> - fun ts -> - FStar_TypeChecker_NBETerm.mkFV fv (FStar_Compiler_List.rev us) - (FStar_Compiler_List.rev ts) -let (mkConstruct : - FStar_Syntax_Syntax.fv -> - FStar_Syntax_Syntax.universe Prims.list -> - (FStar_TypeChecker_NBETerm.t * FStar_Syntax_Syntax.aqual) Prims.list -> - FStar_TypeChecker_NBETerm.t) - = - fun fv -> - fun us -> - fun ts -> - FStar_TypeChecker_NBETerm.mkConstruct fv (FStar_Compiler_List.rev us) - (FStar_Compiler_List.rev ts) -let (fv_as_emb_typ : FStar_Syntax_Syntax.fv -> FStar_Syntax_Syntax.emb_typ) = - fun fv -> - let uu___ = - let uu___1 = - FStar_Ident.string_of_lid - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - (uu___1, []) in - FStar_Syntax_Syntax.ET_app uu___ -let mk_emb' : - 'uuuuu . - (FStar_TypeChecker_NBETerm.nbe_cbs -> - 'uuuuu -> FStar_TypeChecker_NBETerm.t) - -> - (FStar_TypeChecker_NBETerm.nbe_cbs -> - FStar_TypeChecker_NBETerm.t -> 'uuuuu FStar_Pervasives_Native.option) - -> - FStar_Syntax_Syntax.fv -> 'uuuuu FStar_TypeChecker_NBETerm.embedding - = - fun x -> - fun y -> - fun fv -> - FStar_TypeChecker_NBETerm.mk_emb x y (fun uu___ -> mkFV fv [] []) - (fun uu___ -> fv_as_emb_typ fv) -let mk_lazy : - 'uuuuu . - FStar_TypeChecker_NBETerm.nbe_cbs -> - 'uuuuu -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.lazy_kind -> FStar_TypeChecker_NBETerm.t - = - fun cb -> - fun obj -> - fun ty -> - fun kind -> - let li = - { - FStar_Syntax_Syntax.blob = (FStar_Dyn.mkdyn obj); - FStar_Syntax_Syntax.lkind = kind; - FStar_Syntax_Syntax.ltyp = ty; - FStar_Syntax_Syntax.rng = FStar_Compiler_Range_Type.dummyRange - } in - let thunk = - FStar_Thunk.mk - (fun uu___ -> - let uu___1 = FStar_Syntax_Util.unfold_lazy li in - FStar_TypeChecker_NBETerm.translate_cb cb uu___1) in - FStar_TypeChecker_NBETerm.mk_t - (FStar_TypeChecker_NBETerm.Lazy - ((FStar_Pervasives.Inl li), thunk)) -let (e_bv : FStar_Syntax_Syntax.bv FStar_TypeChecker_NBETerm.embedding) = - let embed_bv cb bv = - mk_lazy cb bv FStar_Reflection_V2_Constants.fstar_refl_bv - FStar_Syntax_Syntax.Lazy_bv in - let unembed_bv cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Lazy - (FStar_Pervasives.Inl - { FStar_Syntax_Syntax.blob = b; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_bv; - FStar_Syntax_Syntax.ltyp = uu___; - FStar_Syntax_Syntax.rng = uu___1;_}, - uu___2) - -> - let uu___3 = FStar_Dyn.undyn b in FStar_Pervasives_Native.Some uu___3 - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded bv: %s" uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_bv unembed_bv FStar_Reflection_V2_Constants.fstar_refl_bv_fv -let (e_namedv : - FStar_Reflection_V2_Data.namedv FStar_TypeChecker_NBETerm.embedding) = - let embed_namedv cb namedv = - mk_lazy cb namedv FStar_Reflection_V2_Constants.fstar_refl_namedv - FStar_Syntax_Syntax.Lazy_namedv in - let unembed_namedv cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Lazy - (FStar_Pervasives.Inl - { FStar_Syntax_Syntax.blob = b; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_namedv; - FStar_Syntax_Syntax.ltyp = uu___; - FStar_Syntax_Syntax.rng = uu___1;_}, - uu___2) - -> - let uu___3 = FStar_Dyn.undyn b in FStar_Pervasives_Native.Some uu___3 - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded namedv: %s" uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_namedv unembed_namedv - FStar_Reflection_V2_Constants.fstar_refl_namedv_fv -let (e_binder : - FStar_Syntax_Syntax.binder FStar_TypeChecker_NBETerm.embedding) = - let embed_binder cb b = - mk_lazy cb b FStar_Reflection_V2_Constants.fstar_refl_binder - FStar_Syntax_Syntax.Lazy_binder in - let unembed_binder cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Lazy - (FStar_Pervasives.Inl - { FStar_Syntax_Syntax.blob = b; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_binder; - FStar_Syntax_Syntax.ltyp = uu___; - FStar_Syntax_Syntax.rng = uu___1;_}, - uu___2) - -> - let uu___3 = FStar_Dyn.undyn b in FStar_Pervasives_Native.Some uu___3 - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded binder: %s" uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_binder unembed_binder - FStar_Reflection_V2_Constants.fstar_refl_binder_fv -let rec mapM_opt : - 'a 'b . - ('a -> 'b FStar_Pervasives_Native.option) -> - 'a Prims.list -> 'b Prims.list FStar_Pervasives_Native.option - = - fun f -> - fun l -> - match l with - | [] -> FStar_Pervasives_Native.Some [] - | x::xs -> - let uu___ = f x in - FStar_Compiler_Util.bind_opt uu___ - (fun x1 -> - let uu___1 = mapM_opt f xs in - FStar_Compiler_Util.bind_opt uu___1 - (fun xs1 -> FStar_Pervasives_Native.Some (x1 :: xs1))) -let (e_term_aq : - (Prims.int * FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - Prims.list) -> - FStar_Syntax_Syntax.term FStar_TypeChecker_NBETerm.embedding) - = - fun aq -> - let embed_term cb t = - let qi = - { - FStar_Syntax_Syntax.qkind = FStar_Syntax_Syntax.Quote_static; - FStar_Syntax_Syntax.antiquotations = aq - } in - FStar_TypeChecker_NBETerm.mk_t - (FStar_TypeChecker_NBETerm.Quote (t, qi)) in - let unembed_term cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Quote (tm, qi) -> - let uu___ = - FStar_Reflection_V2_Embeddings.e_term_aq (Prims.int_zero, []) in - let uu___1 = - FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_quoted (tm, qi)) - FStar_Compiler_Range_Type.dummyRange in - FStar_Syntax_Embeddings_Base.unembed uu___ uu___1 - FStar_Syntax_Embeddings_Base.id_norm_cb - | uu___ -> FStar_Pervasives_Native.None in - { - FStar_TypeChecker_NBETerm.em = embed_term; - FStar_TypeChecker_NBETerm.un = unembed_term; - FStar_TypeChecker_NBETerm.typ = - (fun uu___ -> - mkFV FStar_Reflection_V2_Constants.fstar_refl_term_fv [] []); - FStar_TypeChecker_NBETerm.e_typ = - (fun uu___ -> - fv_as_emb_typ FStar_Reflection_V2_Constants.fstar_refl_term_fv) - } -let (e_term : FStar_Syntax_Syntax.term FStar_TypeChecker_NBETerm.embedding) = - e_term_aq (Prims.int_zero, []) -let (e_sort : - FStar_Syntax_Syntax.term FStar_Compiler_Sealed.sealed - FStar_TypeChecker_NBETerm.embedding) - = FStar_TypeChecker_NBETerm.e_sealed e_term -let (e_ppname : - Prims.string FStar_Compiler_Sealed.sealed - FStar_TypeChecker_NBETerm.embedding) - = FStar_TypeChecker_NBETerm.e_sealed FStar_TypeChecker_NBETerm.e_string -let (e_aqualv : - FStar_Reflection_V2_Data.aqualv FStar_TypeChecker_NBETerm.embedding) = - let embed_aqualv cb q = - match q with - | FStar_Reflection_V2_Data.Q_Explicit -> - mkConstruct - FStar_Reflection_V2_Constants.ref_Q_Explicit.FStar_Reflection_V2_Constants.fv - [] [] - | FStar_Reflection_V2_Data.Q_Implicit -> - mkConstruct - FStar_Reflection_V2_Constants.ref_Q_Implicit.FStar_Reflection_V2_Constants.fv - [] [] - | FStar_Reflection_V2_Data.Q_Meta t -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_term cb t in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V2_Constants.ref_Q_Meta.FStar_Reflection_V2_Constants.fv - [] uu___ in - let unembed_aqualv cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Q_Explicit.FStar_Reflection_V2_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V2_Data.Q_Explicit - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Q_Implicit.FStar_Reflection_V2_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V2_Data.Q_Implicit - | FStar_TypeChecker_NBETerm.Construct (fv, [], (t1, uu___)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Q_Meta.FStar_Reflection_V2_Constants.lid - -> - let uu___1 = FStar_TypeChecker_NBETerm.unembed e_term cb t1 in - FStar_Compiler_Util.bind_opt uu___1 - (fun t2 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.Q_Meta t2)) - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded aqualv: %s" uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - FStar_TypeChecker_NBETerm.mk_emb embed_aqualv unembed_aqualv - (fun uu___ -> - mkConstruct FStar_Reflection_V2_Constants.fstar_refl_aqualv_fv [] []) - (fun uu___ -> - fv_as_emb_typ FStar_Reflection_V2_Constants.fstar_refl_aqualv_fv) -let (e_binders : - FStar_Syntax_Syntax.binders FStar_TypeChecker_NBETerm.embedding) = - FStar_TypeChecker_NBETerm.e_list e_binder -let (e_fv : FStar_Syntax_Syntax.fv FStar_TypeChecker_NBETerm.embedding) = - let embed_fv cb fv = - mk_lazy cb fv FStar_Reflection_V2_Constants.fstar_refl_fv - FStar_Syntax_Syntax.Lazy_fvar in - let unembed_fv cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Lazy - (FStar_Pervasives.Inl - { FStar_Syntax_Syntax.blob = b; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_fvar; - FStar_Syntax_Syntax.ltyp = uu___; - FStar_Syntax_Syntax.rng = uu___1;_}, - uu___2) - -> - let uu___3 = FStar_Dyn.undyn b in FStar_Pervasives_Native.Some uu___3 - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded fvar: %s" uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_fv unembed_fv FStar_Reflection_V2_Constants.fstar_refl_fv_fv -let (e_comp : FStar_Syntax_Syntax.comp FStar_TypeChecker_NBETerm.embedding) = - let embed_comp cb c = - mk_lazy cb c FStar_Reflection_V2_Constants.fstar_refl_comp - FStar_Syntax_Syntax.Lazy_comp in - let unembed_comp cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Lazy - (FStar_Pervasives.Inl - { FStar_Syntax_Syntax.blob = b; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_comp; - FStar_Syntax_Syntax.ltyp = uu___; - FStar_Syntax_Syntax.rng = uu___1;_}, - uu___2) - -> - let uu___3 = FStar_Dyn.undyn b in FStar_Pervasives_Native.Some uu___3 - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded comp: %s" uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_comp unembed_comp - FStar_Reflection_V2_Constants.fstar_refl_comp_fv -let (e_env : FStar_TypeChecker_Env.env FStar_TypeChecker_NBETerm.embedding) = - let embed_env cb e = - mk_lazy cb e FStar_Reflection_V2_Constants.fstar_refl_env - FStar_Syntax_Syntax.Lazy_env in - let unembed_env cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Lazy - (FStar_Pervasives.Inl - { FStar_Syntax_Syntax.blob = b; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_env; - FStar_Syntax_Syntax.ltyp = uu___; - FStar_Syntax_Syntax.rng = uu___1;_}, - uu___2) - -> - let uu___3 = FStar_Dyn.undyn b in FStar_Pervasives_Native.Some uu___3 - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded env: %s" uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_env unembed_env - FStar_Reflection_V2_Constants.fstar_refl_env_fv -let (e_vconst : - FStar_Reflection_V2_Data.vconst FStar_TypeChecker_NBETerm.embedding) = - let embed_const cb c = - match c with - | FStar_Reflection_V2_Data.C_Unit -> - mkConstruct - FStar_Reflection_V2_Constants.ref_C_Unit.FStar_Reflection_V2_Constants.fv - [] [] - | FStar_Reflection_V2_Data.C_True -> - mkConstruct - FStar_Reflection_V2_Constants.ref_C_True.FStar_Reflection_V2_Constants.fv - [] [] - | FStar_Reflection_V2_Data.C_False -> - mkConstruct - FStar_Reflection_V2_Constants.ref_C_False.FStar_Reflection_V2_Constants.fv - [] [] - | FStar_Reflection_V2_Data.C_Int i -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.mk_t - (FStar_TypeChecker_NBETerm.Constant - (FStar_TypeChecker_NBETerm.Int i)) in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V2_Constants.ref_C_Int.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.C_String s -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed - FStar_TypeChecker_NBETerm.e_string cb s in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V2_Constants.ref_C_String.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.C_Range r -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed - FStar_TypeChecker_NBETerm.e_range cb r in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V2_Constants.ref_C_Range.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.C_Reify -> - mkConstruct - FStar_Reflection_V2_Constants.ref_C_Reify.FStar_Reflection_V2_Constants.fv - [] [] - | FStar_Reflection_V2_Data.C_Reflect ns -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed - FStar_TypeChecker_NBETerm.e_string_list cb ns in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V2_Constants.ref_C_Reflect.FStar_Reflection_V2_Constants.fv - [] uu___ in - let unembed_const cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_C_Unit.FStar_Reflection_V2_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V2_Data.C_Unit - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_C_True.FStar_Reflection_V2_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V2_Data.C_True - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_C_False.FStar_Reflection_V2_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V2_Data.C_False - | FStar_TypeChecker_NBETerm.Construct (fv, [], (i, uu___)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_C_Int.FStar_Reflection_V2_Constants.lid - -> - let uu___1 = - FStar_TypeChecker_NBETerm.unembed FStar_TypeChecker_NBETerm.e_int - cb i in - FStar_Compiler_Util.bind_opt uu___1 - (fun i1 -> - FStar_Pervasives_Native.Some (FStar_Reflection_V2_Data.C_Int i1)) - | FStar_TypeChecker_NBETerm.Construct (fv, [], (s, uu___)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_C_String.FStar_Reflection_V2_Constants.lid - -> - let uu___1 = - FStar_TypeChecker_NBETerm.unembed - FStar_TypeChecker_NBETerm.e_string cb s in - FStar_Compiler_Util.bind_opt uu___1 - (fun s1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.C_String s1)) - | FStar_TypeChecker_NBETerm.Construct (fv, [], (r, uu___)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_C_Range.FStar_Reflection_V2_Constants.lid - -> - let uu___1 = - FStar_TypeChecker_NBETerm.unembed FStar_TypeChecker_NBETerm.e_range - cb r in - FStar_Compiler_Util.bind_opt uu___1 - (fun r1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.C_Range r1)) - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_C_Reify.FStar_Reflection_V2_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V2_Data.C_Reify - | FStar_TypeChecker_NBETerm.Construct (fv, [], (ns, uu___)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_C_Reflect.FStar_Reflection_V2_Constants.lid - -> - let uu___1 = - FStar_TypeChecker_NBETerm.unembed - FStar_TypeChecker_NBETerm.e_string_list cb ns in - FStar_Compiler_Util.bind_opt uu___1 - (fun ns1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.C_Reflect ns1)) - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded vconst: %s" uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_const unembed_const - FStar_Reflection_V2_Constants.fstar_refl_vconst_fv -let (e_universe : - FStar_Syntax_Syntax.universe FStar_TypeChecker_NBETerm.embedding) = - let embed_universe cb u = - mk_lazy cb u FStar_Reflection_V2_Constants.fstar_refl_universe - FStar_Syntax_Syntax.Lazy_universe in - let unembed_universe cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Lazy - (FStar_Pervasives.Inl - { FStar_Syntax_Syntax.blob = b; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_universe; - FStar_Syntax_Syntax.ltyp = uu___; - FStar_Syntax_Syntax.rng = uu___1;_}, - uu___2) - -> - let uu___3 = FStar_Dyn.undyn b in FStar_Pervasives_Native.Some uu___3 - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded universe: %s" uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_universe unembed_universe - FStar_Reflection_V2_Constants.fstar_refl_universe_fv -let rec e_pattern_aq : - 'uuuuu . - 'uuuuu -> - FStar_Reflection_V2_Data.pattern FStar_TypeChecker_NBETerm.embedding - = - fun aq -> - let embed_pattern cb p = - match p with - | FStar_Reflection_V2_Data.Pat_Constant c -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_vconst cb c in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V2_Constants.ref_Pat_Constant.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.Pat_Cons (fv, us_opt, ps) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_fv cb fv in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_option - (FStar_TypeChecker_NBETerm.e_list e_universe)) cb - us_opt in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = e_pattern_aq aq in - FStar_TypeChecker_NBETerm.e_tuple2 uu___9 - FStar_TypeChecker_NBETerm.e_bool in - FStar_TypeChecker_NBETerm.e_list uu___8 in - FStar_TypeChecker_NBETerm.embed uu___7 cb ps in - FStar_TypeChecker_NBETerm.as_arg uu___6 in - [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V2_Constants.ref_Pat_Cons.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.Pat_Var (sort, ppname) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_sort cb sort in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed e_ppname cb ppname in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V2_Constants.ref_Pat_Var.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.Pat_Dot_Term eopt -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_option e_term) cb eopt in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V2_Constants.ref_Pat_Dot_Term.FStar_Reflection_V2_Constants.fv - [] uu___ in - let unembed_pattern cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Construct (fv, [], (c, uu___)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Pat_Constant.FStar_Reflection_V2_Constants.lid - -> - let uu___1 = FStar_TypeChecker_NBETerm.unembed e_vconst cb c in - FStar_Compiler_Util.bind_opt uu___1 - (fun c1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.Pat_Constant c1)) - | FStar_TypeChecker_NBETerm.Construct - (fv, [], (ps, uu___)::(us_opt, uu___1)::(f, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Pat_Cons.FStar_Reflection_V2_Constants.lid - -> - let uu___3 = FStar_TypeChecker_NBETerm.unembed e_fv cb f in - FStar_Compiler_Util.bind_opt uu___3 - (fun f1 -> - let uu___4 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_option - (FStar_TypeChecker_NBETerm.e_list e_universe)) cb - us_opt in - FStar_Compiler_Util.bind_opt uu___4 - (fun us -> - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = e_pattern_aq aq in - FStar_TypeChecker_NBETerm.e_tuple2 uu___8 - FStar_TypeChecker_NBETerm.e_bool in - FStar_TypeChecker_NBETerm.e_list uu___7 in - FStar_TypeChecker_NBETerm.unembed uu___6 cb ps in - FStar_Compiler_Util.bind_opt uu___5 - (fun ps1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.Pat_Cons (f1, us, ps1))))) - | FStar_TypeChecker_NBETerm.Construct - (fv, [], (ppname, uu___)::(sort, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Pat_Var.FStar_Reflection_V2_Constants.lid - -> - let uu___2 = FStar_TypeChecker_NBETerm.unembed e_sort cb sort in - FStar_Compiler_Util.bind_opt uu___2 - (fun sort1 -> - let uu___3 = - FStar_TypeChecker_NBETerm.unembed e_ppname cb ppname in - FStar_Compiler_Util.bind_opt uu___3 - (fun ppname1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.Pat_Var (sort1, ppname1)))) - | FStar_TypeChecker_NBETerm.Construct (fv, [], (eopt, uu___)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Pat_Dot_Term.FStar_Reflection_V2_Constants.lid - -> - let uu___1 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_option e_term) cb eopt in - FStar_Compiler_Util.bind_opt uu___1 - (fun eopt1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.Pat_Dot_Term eopt1)) - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded pattern: %s" - uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_pattern unembed_pattern - FStar_Reflection_V2_Constants.fstar_refl_pattern_fv -let (e_pattern : - FStar_Reflection_V2_Data.pattern FStar_TypeChecker_NBETerm.embedding) = - e_pattern_aq noaqs -let (e_branch : - FStar_Reflection_V2_Data.branch FStar_TypeChecker_NBETerm.embedding) = - FStar_TypeChecker_NBETerm.e_tuple2 e_pattern e_term -let (e_argv : - FStar_Reflection_V2_Data.argv FStar_TypeChecker_NBETerm.embedding) = - FStar_TypeChecker_NBETerm.e_tuple2 e_term e_aqualv -let (e_branch_aq : - (Prims.int * FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - Prims.list) -> - (FStar_Reflection_V2_Data.pattern * FStar_Syntax_Syntax.term) - FStar_TypeChecker_NBETerm.embedding) - = - fun aq -> - let uu___ = e_pattern_aq aq in - FStar_TypeChecker_NBETerm.e_tuple2 uu___ (e_term_aq aq) -let (e_argv_aq : - (Prims.int * FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - Prims.list) -> - (FStar_Syntax_Syntax.term * FStar_Reflection_V2_Data.aqualv) - FStar_TypeChecker_NBETerm.embedding) - = fun aq -> FStar_TypeChecker_NBETerm.e_tuple2 (e_term_aq aq) e_aqualv -let (e_match_returns_annotation : - (FStar_Syntax_Syntax.binder * ((FStar_Syntax_Syntax.term, - FStar_Syntax_Syntax.comp) FStar_Pervasives.either * - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option * Prims.bool)) - FStar_Pervasives_Native.option FStar_TypeChecker_NBETerm.embedding) - = - FStar_TypeChecker_NBETerm.e_option - (FStar_TypeChecker_NBETerm.e_tuple2 e_binder - (FStar_TypeChecker_NBETerm.e_tuple3 - (FStar_TypeChecker_NBETerm.e_either e_term e_comp) - (FStar_TypeChecker_NBETerm.e_option e_term) - FStar_TypeChecker_NBETerm.e_bool)) -let unlazy_as_t : - 'uuuuu . - FStar_Syntax_Syntax.lazy_kind -> FStar_TypeChecker_NBETerm.t -> 'uuuuu - = - fun k -> - fun t -> - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Lazy - (FStar_Pervasives.Inl - { FStar_Syntax_Syntax.blob = v; FStar_Syntax_Syntax.lkind = k'; - FStar_Syntax_Syntax.ltyp = uu___; - FStar_Syntax_Syntax.rng = uu___1;_}, - uu___2) - when - FStar_Class_Deq.op_Equals_Question - FStar_Syntax_Syntax.deq_lazy_kind k k' - -> FStar_Dyn.undyn v - | uu___ -> failwith "Not a Lazy of the expected kind (NBE)" -let (e_ident : FStar_Ident.ident FStar_TypeChecker_NBETerm.embedding) = - let embed_ident cb se = - mk_lazy cb se FStar_Reflection_V2_Constants.fstar_refl_ident - FStar_Syntax_Syntax.Lazy_ident in - let unembed_ident cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Lazy - (FStar_Pervasives.Inl - { FStar_Syntax_Syntax.blob = b; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_ident; - FStar_Syntax_Syntax.ltyp = uu___; - FStar_Syntax_Syntax.rng = uu___1;_}, - uu___2) - -> - let uu___3 = FStar_Dyn.undyn b in FStar_Pervasives_Native.Some uu___3 - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded ident: %s" uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_ident unembed_ident - FStar_Reflection_V2_Constants.fstar_refl_ident_fv -let (e_univ_name : - FStar_Syntax_Syntax.univ_name FStar_TypeChecker_NBETerm.embedding) = - e_ident -let (e_univ_names : - FStar_Syntax_Syntax.univ_name Prims.list - FStar_TypeChecker_NBETerm.embedding) - = FStar_TypeChecker_NBETerm.e_list e_univ_name -let (e_universe_view : - FStar_Reflection_V2_Data.universe_view FStar_TypeChecker_NBETerm.embedding) - = - let embed_universe_view cb uv = - match uv with - | FStar_Reflection_V2_Data.Uv_Zero -> - mkConstruct - FStar_Reflection_V2_Constants.ref_Uv_Zero.FStar_Reflection_V2_Constants.fv - [] [] - | FStar_Reflection_V2_Data.Uv_Succ u -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_universe cb u in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V2_Constants.ref_Uv_Succ.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.Uv_Max us -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_list e_universe) cb us in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V2_Constants.ref_Uv_Max.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.Uv_BVar n -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed FStar_TypeChecker_NBETerm.e_int - cb n in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V2_Constants.ref_Uv_BVar.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.Uv_Name i -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_ident cb i in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V2_Constants.ref_Uv_Name.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.Uv_Unif u -> - let uu___ = - let uu___1 = - let uu___2 = - mk_lazy cb u FStar_Syntax_Util.t_universe_uvar - FStar_Syntax_Syntax.Lazy_universe_uvar in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V2_Constants.ref_Uv_Unif.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.Uv_Unk -> - mkConstruct - FStar_Reflection_V2_Constants.ref_Uv_Unk.FStar_Reflection_V2_Constants.fv - [] [] in - let unembed_universe_view cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Uv_Zero.FStar_Reflection_V2_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V2_Data.Uv_Zero - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, (u, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Uv_Succ.FStar_Reflection_V2_Constants.lid - -> - let uu___2 = FStar_TypeChecker_NBETerm.unembed e_universe cb u in - FStar_Compiler_Util.bind_opt uu___2 - (fun u1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.Uv_Succ u1)) - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, (us, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Uv_Max.FStar_Reflection_V2_Constants.lid - -> - let uu___2 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_list e_universe) cb us in - FStar_Compiler_Util.bind_opt uu___2 - (fun us1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.Uv_Max us1)) - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, (n, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Uv_BVar.FStar_Reflection_V2_Constants.lid - -> - let uu___2 = - FStar_TypeChecker_NBETerm.unembed FStar_TypeChecker_NBETerm.e_int - cb n in - FStar_Compiler_Util.bind_opt uu___2 - (fun n1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.Uv_BVar n1)) - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, (i, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Uv_Name.FStar_Reflection_V2_Constants.lid - -> - let uu___2 = FStar_TypeChecker_NBETerm.unembed e_ident cb i in - FStar_Compiler_Util.bind_opt uu___2 - (fun i1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.Uv_Name i1)) - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, (u, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Uv_Unif.FStar_Reflection_V2_Constants.lid - -> - let u1 = unlazy_as_t FStar_Syntax_Syntax.Lazy_universe_uvar u in - FStar_Pervasives_Native.Some (FStar_Reflection_V2_Data.Uv_Unif u1) - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Uv_Unk.FStar_Reflection_V2_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V2_Data.Uv_Unk - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded universe view: %s" - uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_universe_view unembed_universe_view - FStar_Reflection_V2_Constants.fstar_refl_universe_view_fv -let (e_subst_elt : - FStar_Syntax_Syntax.subst_elt FStar_TypeChecker_NBETerm.embedding) = - let embed_const cb e = - match e with - | FStar_Syntax_Syntax.DB (i, x) -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_BigInt.of_int_fs i in - FStar_TypeChecker_NBETerm.embed FStar_TypeChecker_NBETerm.e_int - cb uu___3 in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = FStar_TypeChecker_NBETerm.embed e_namedv cb x in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V2_Constants.ref_DB.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Syntax_Syntax.NM (x, i) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_namedv cb x in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_BigInt.of_int_fs i in - FStar_TypeChecker_NBETerm.embed - FStar_TypeChecker_NBETerm.e_int cb uu___5 in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V2_Constants.ref_NM.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Syntax_Syntax.NT (x, t) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_namedv cb x in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = FStar_TypeChecker_NBETerm.embed e_term cb t in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V2_Constants.ref_NT.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Syntax_Syntax.UN (i, u) -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_BigInt.of_int_fs i in - FStar_TypeChecker_NBETerm.embed FStar_TypeChecker_NBETerm.e_int - cb uu___3 in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = FStar_TypeChecker_NBETerm.embed e_universe cb u in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V2_Constants.ref_UN.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Syntax_Syntax.UD (n, i) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_univ_name cb n in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_BigInt.of_int_fs i in - FStar_TypeChecker_NBETerm.embed - FStar_TypeChecker_NBETerm.e_int cb uu___5 in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V2_Constants.ref_UD.FStar_Reflection_V2_Constants.fv - [] uu___ in - let unembed_const cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Construct - (fv, [], (x, uu___)::(i, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_DB.FStar_Reflection_V2_Constants.lid - -> - let uu___2 = - FStar_TypeChecker_NBETerm.unembed FStar_TypeChecker_NBETerm.e_int - cb i in - FStar_Compiler_Util.bind_opt uu___2 - (fun i1 -> - let uu___3 = FStar_TypeChecker_NBETerm.unembed e_namedv cb x in - FStar_Compiler_Util.bind_opt uu___3 - (fun x1 -> - let uu___4 = - let uu___5 = - let uu___6 = FStar_BigInt.to_int_fs i1 in (uu___6, x1) in - FStar_Syntax_Syntax.DB uu___5 in - FStar_Pervasives_Native.Some uu___4)) - | FStar_TypeChecker_NBETerm.Construct - (fv, [], (i, uu___)::(x, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_NM.FStar_Reflection_V2_Constants.lid - -> - let uu___2 = FStar_TypeChecker_NBETerm.unembed e_namedv cb x in - FStar_Compiler_Util.bind_opt uu___2 - (fun x1 -> - let uu___3 = - FStar_TypeChecker_NBETerm.unembed - FStar_TypeChecker_NBETerm.e_int cb i in - FStar_Compiler_Util.bind_opt uu___3 - (fun i1 -> - let uu___4 = - let uu___5 = - let uu___6 = FStar_BigInt.to_int_fs i1 in (x1, uu___6) in - FStar_Syntax_Syntax.NM uu___5 in - FStar_Pervasives_Native.Some uu___4)) - | FStar_TypeChecker_NBETerm.Construct - (fv, [], (t1, uu___)::(x, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_NT.FStar_Reflection_V2_Constants.lid - -> - let uu___2 = FStar_TypeChecker_NBETerm.unembed e_namedv cb x in - FStar_Compiler_Util.bind_opt uu___2 - (fun x1 -> - let uu___3 = FStar_TypeChecker_NBETerm.unembed e_term cb t1 in - FStar_Compiler_Util.bind_opt uu___3 - (fun t2 -> - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.NT (x1, t2)))) - | FStar_TypeChecker_NBETerm.Construct - (fv, [], (u, uu___)::(i, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_UN.FStar_Reflection_V2_Constants.lid - -> - let uu___2 = - FStar_TypeChecker_NBETerm.unembed FStar_TypeChecker_NBETerm.e_int - cb i in - FStar_Compiler_Util.bind_opt uu___2 - (fun i1 -> - let uu___3 = FStar_TypeChecker_NBETerm.unembed e_universe cb u in - FStar_Compiler_Util.bind_opt uu___3 - (fun u1 -> - let uu___4 = - let uu___5 = - let uu___6 = FStar_BigInt.to_int_fs i1 in (uu___6, u1) in - FStar_Syntax_Syntax.UN uu___5 in - FStar_Pervasives_Native.Some uu___4)) - | FStar_TypeChecker_NBETerm.Construct - (fv, [], (i, uu___)::(n, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_UD.FStar_Reflection_V2_Constants.lid - -> - let uu___2 = FStar_TypeChecker_NBETerm.unembed e_univ_name cb n in - FStar_Compiler_Util.bind_opt uu___2 - (fun n1 -> - let uu___3 = - FStar_TypeChecker_NBETerm.unembed - FStar_TypeChecker_NBETerm.e_int cb i in - FStar_Compiler_Util.bind_opt uu___3 - (fun i1 -> - let uu___4 = - let uu___5 = - let uu___6 = FStar_BigInt.to_int_fs i1 in (n1, uu___6) in - FStar_Syntax_Syntax.UD uu___5 in - FStar_Pervasives_Native.Some uu___4)) - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded vconst: %s" uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_const unembed_const - FStar_Reflection_V2_Constants.fstar_refl_subst_elt_fv -let (e_subst : - FStar_Syntax_Syntax.subst_elt Prims.list - FStar_TypeChecker_NBETerm.embedding) - = FStar_TypeChecker_NBETerm.e_list e_subst_elt -let (e_term_view_aq : - (Prims.int * FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - Prims.list) -> - FStar_Reflection_V2_Data.term_view FStar_TypeChecker_NBETerm.embedding) - = - fun aq -> - let shift uu___ = - match uu___ with | (s, aqs) -> ((s + Prims.int_one), aqs) in - let embed_term_view cb tv = - match tv with - | FStar_Reflection_V2_Data.Tv_FVar fv -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_fv cb fv in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V2_Constants.ref_Tv_FVar.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.Tv_BVar bv -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_bv cb bv in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V2_Constants.ref_Tv_BVar.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.Tv_Var bv -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_bv cb bv in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V2_Constants.ref_Tv_Var.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.Tv_UInst (fv, us) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_fv cb fv in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_list e_universe) cb us in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V2_Constants.ref_Tv_UInst.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.Tv_App (hd, a) -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed (e_term_aq aq) cb hd in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed (e_argv_aq aq) cb a in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V2_Constants.ref_Tv_App.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.Tv_Abs (b, t) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_binder cb b in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed (e_term_aq (shift aq)) cb t in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V2_Constants.ref_Tv_Abs.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.Tv_Arrow (b, c) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_binder cb b in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = FStar_TypeChecker_NBETerm.embed e_comp cb c in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V2_Constants.ref_Tv_Arrow.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.Tv_Type u -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_universe cb u in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V2_Constants.ref_Tv_Type.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.Tv_Refine (b, t) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_binder cb b in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed (e_term_aq (shift aq)) cb t in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V2_Constants.ref_Tv_Refine.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.Tv_Const c -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_vconst cb c in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V2_Constants.ref_Tv_Const.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.Tv_Uvar (u, d) -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed - FStar_TypeChecker_NBETerm.e_int cb u in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - mk_lazy cb (u, d) FStar_Syntax_Util.t_ctx_uvar_and_sust - FStar_Syntax_Syntax.Lazy_uvar in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V2_Constants.ref_Tv_Uvar.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.Tv_Let (r, attrs, b, t1, t2) -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed - FStar_TypeChecker_NBETerm.e_bool cb r in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_list e_term) cb attrs in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = FStar_TypeChecker_NBETerm.embed e_binder cb b in - FStar_TypeChecker_NBETerm.as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - FStar_TypeChecker_NBETerm.embed (e_term_aq aq) cb t1 in - FStar_TypeChecker_NBETerm.as_arg uu___8 in - let uu___8 = - let uu___9 = - let uu___10 = - FStar_TypeChecker_NBETerm.embed - (e_term_aq (shift aq)) cb t2 in - FStar_TypeChecker_NBETerm.as_arg uu___10 in - [uu___9] in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V2_Constants.ref_Tv_Let.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.Tv_Match (t, ret_opt, brs) -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed (e_term_aq aq) cb t in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed e_match_returns_annotation - cb ret_opt in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = e_branch_aq aq in - FStar_TypeChecker_NBETerm.e_list uu___8 in - FStar_TypeChecker_NBETerm.embed uu___7 cb brs in - FStar_TypeChecker_NBETerm.as_arg uu___6 in - [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V2_Constants.ref_Tv_Match.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.Tv_AscribedT (e, t, tacopt, use_eq) -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed (e_term_aq aq) cb e in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed (e_term_aq aq) cb t in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_option (e_term_aq aq)) cb - tacopt in - FStar_TypeChecker_NBETerm.as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - FStar_TypeChecker_NBETerm.embed - FStar_TypeChecker_NBETerm.e_bool cb use_eq in - FStar_TypeChecker_NBETerm.as_arg uu___8 in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V2_Constants.ref_Tv_AscT.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.Tv_AscribedC (e, c, tacopt, use_eq) -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed (e_term_aq aq) cb e in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = FStar_TypeChecker_NBETerm.embed e_comp cb c in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_option (e_term_aq aq)) cb - tacopt in - FStar_TypeChecker_NBETerm.as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - FStar_TypeChecker_NBETerm.embed - FStar_TypeChecker_NBETerm.e_bool cb use_eq in - FStar_TypeChecker_NBETerm.as_arg uu___8 in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V2_Constants.ref_Tv_AscT.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.Tv_Unknown -> - mkConstruct - FStar_Reflection_V2_Constants.ref_Tv_Unknown.FStar_Reflection_V2_Constants.fv - [] [] - | FStar_Reflection_V2_Data.Tv_Unsupp -> - mkConstruct - FStar_Reflection_V2_Constants.ref_Tv_Unsupp.FStar_Reflection_V2_Constants.fv - [] [] in - let unembed_term_view cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, (b, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_Var.FStar_Reflection_V2_Constants.lid - -> - let uu___2 = FStar_TypeChecker_NBETerm.unembed e_bv cb b in - FStar_Compiler_Util.bind_opt uu___2 - (fun b1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.Tv_Var b1)) - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, (b, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_BVar.FStar_Reflection_V2_Constants.lid - -> - let uu___2 = FStar_TypeChecker_NBETerm.unembed e_bv cb b in - FStar_Compiler_Util.bind_opt uu___2 - (fun b1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.Tv_BVar b1)) - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, (f, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_FVar.FStar_Reflection_V2_Constants.lid - -> - let uu___2 = FStar_TypeChecker_NBETerm.unembed e_fv cb f in - FStar_Compiler_Util.bind_opt uu___2 - (fun f1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.Tv_FVar f1)) - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, (f, uu___1)::(us, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_UInst.FStar_Reflection_V2_Constants.lid - -> - let uu___3 = FStar_TypeChecker_NBETerm.unembed e_fv cb f in - FStar_Compiler_Util.bind_opt uu___3 - (fun f1 -> - let uu___4 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_list e_universe) cb us in - FStar_Compiler_Util.bind_opt uu___4 - (fun us1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.Tv_UInst (f1, us1)))) - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, (r, uu___1)::(l, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_App.FStar_Reflection_V2_Constants.lid - -> - let uu___3 = FStar_TypeChecker_NBETerm.unembed e_term cb l in - FStar_Compiler_Util.bind_opt uu___3 - (fun l1 -> - let uu___4 = FStar_TypeChecker_NBETerm.unembed e_argv cb r in - FStar_Compiler_Util.bind_opt uu___4 - (fun r1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.Tv_App (l1, r1)))) - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, (t1, uu___1)::(b, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_Abs.FStar_Reflection_V2_Constants.lid - -> - let uu___3 = FStar_TypeChecker_NBETerm.unembed e_binder cb b in - FStar_Compiler_Util.bind_opt uu___3 - (fun b1 -> - let uu___4 = FStar_TypeChecker_NBETerm.unembed e_term cb t1 in - FStar_Compiler_Util.bind_opt uu___4 - (fun t2 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.Tv_Abs (b1, t2)))) - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, (t1, uu___1)::(b, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_Arrow.FStar_Reflection_V2_Constants.lid - -> - let uu___3 = FStar_TypeChecker_NBETerm.unembed e_binder cb b in - FStar_Compiler_Util.bind_opt uu___3 - (fun b1 -> - let uu___4 = FStar_TypeChecker_NBETerm.unembed e_comp cb t1 in - FStar_Compiler_Util.bind_opt uu___4 - (fun c -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.Tv_Arrow (b1, c)))) - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, (u, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_Type.FStar_Reflection_V2_Constants.lid - -> - let uu___2 = FStar_TypeChecker_NBETerm.unembed e_universe cb u in - FStar_Compiler_Util.bind_opt uu___2 - (fun u1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.Tv_Type u1)) - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, (t1, uu___1)::(b, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_Refine.FStar_Reflection_V2_Constants.lid - -> - let uu___3 = FStar_TypeChecker_NBETerm.unembed e_binder cb b in - FStar_Compiler_Util.bind_opt uu___3 - (fun b1 -> - let uu___4 = FStar_TypeChecker_NBETerm.unembed e_term cb t1 in - FStar_Compiler_Util.bind_opt uu___4 - (fun t2 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.Tv_Refine (b1, t2)))) - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, (c, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_Const.FStar_Reflection_V2_Constants.lid - -> - let uu___2 = FStar_TypeChecker_NBETerm.unembed e_vconst cb c in - FStar_Compiler_Util.bind_opt uu___2 - (fun c1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.Tv_Const c1)) - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, (l, uu___1)::(u, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_Uvar.FStar_Reflection_V2_Constants.lid - -> - let uu___3 = - FStar_TypeChecker_NBETerm.unembed FStar_TypeChecker_NBETerm.e_int - cb u in - FStar_Compiler_Util.bind_opt uu___3 - (fun u1 -> - let ctx_u_s = unlazy_as_t FStar_Syntax_Syntax.Lazy_uvar l in - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.Tv_Uvar (u1, ctx_u_s))) - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, - (t2, uu___1)::(t1, uu___2)::(b, uu___3)::(attrs, uu___4):: - (r, uu___5)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_Let.FStar_Reflection_V2_Constants.lid - -> - let uu___6 = - FStar_TypeChecker_NBETerm.unembed - FStar_TypeChecker_NBETerm.e_bool cb r in - FStar_Compiler_Util.bind_opt uu___6 - (fun r1 -> - let uu___7 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_list e_term) cb attrs in - FStar_Compiler_Util.bind_opt uu___7 - (fun attrs1 -> - let uu___8 = - FStar_TypeChecker_NBETerm.unembed e_binder cb b in - FStar_Compiler_Util.bind_opt uu___8 - (fun b1 -> - let uu___9 = - FStar_TypeChecker_NBETerm.unembed e_term cb t1 in - FStar_Compiler_Util.bind_opt uu___9 - (fun t11 -> - let uu___10 = - FStar_TypeChecker_NBETerm.unembed e_term cb - t2 in - FStar_Compiler_Util.bind_opt uu___10 - (fun t21 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.Tv_Let - (r1, attrs1, b1, t11, t21))))))) - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, (brs, uu___1)::(ret_opt, uu___2)::(t1, uu___3)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_Match.FStar_Reflection_V2_Constants.lid - -> - let uu___4 = FStar_TypeChecker_NBETerm.unembed e_term cb t1 in - FStar_Compiler_Util.bind_opt uu___4 - (fun t2 -> - let uu___5 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_list e_branch) cb brs in - FStar_Compiler_Util.bind_opt uu___5 - (fun brs1 -> - let uu___6 = - FStar_TypeChecker_NBETerm.unembed - e_match_returns_annotation cb ret_opt in - FStar_Compiler_Util.bind_opt uu___6 - (fun ret_opt1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.Tv_Match - (t2, ret_opt1, brs1))))) - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, - (tacopt, uu___1)::(t1, uu___2)::(e, uu___3)::(use_eq, uu___4)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_AscT.FStar_Reflection_V2_Constants.lid - -> - let uu___5 = FStar_TypeChecker_NBETerm.unembed e_term cb e in - FStar_Compiler_Util.bind_opt uu___5 - (fun e1 -> - let uu___6 = FStar_TypeChecker_NBETerm.unembed e_term cb t1 in - FStar_Compiler_Util.bind_opt uu___6 - (fun t2 -> - let uu___7 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_option e_term) cb tacopt in - FStar_Compiler_Util.bind_opt uu___7 - (fun tacopt1 -> - let uu___8 = - FStar_TypeChecker_NBETerm.unembed - FStar_TypeChecker_NBETerm.e_bool cb use_eq in - FStar_Compiler_Util.bind_opt uu___8 - (fun use_eq1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.Tv_AscribedT - (e1, t2, tacopt1, use_eq1)))))) - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, - (tacopt, uu___1)::(c, uu___2)::(e, uu___3)::(use_eq, uu___4)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_AscC.FStar_Reflection_V2_Constants.lid - -> - let uu___5 = FStar_TypeChecker_NBETerm.unembed e_term cb e in - FStar_Compiler_Util.bind_opt uu___5 - (fun e1 -> - let uu___6 = FStar_TypeChecker_NBETerm.unembed e_comp cb c in - FStar_Compiler_Util.bind_opt uu___6 - (fun c1 -> - let uu___7 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_option e_term) cb tacopt in - FStar_Compiler_Util.bind_opt uu___7 - (fun tacopt1 -> - let uu___8 = - FStar_TypeChecker_NBETerm.unembed - FStar_TypeChecker_NBETerm.e_bool cb use_eq in - FStar_Compiler_Util.bind_opt uu___8 - (fun use_eq1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.Tv_AscribedC - (e1, c1, tacopt1, use_eq1)))))) - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_Unknown.FStar_Reflection_V2_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V2_Data.Tv_Unknown - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Tv_Unsupp.FStar_Reflection_V2_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V2_Data.Tv_Unsupp - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded term_view: %s" - uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_term_view unembed_term_view - FStar_Reflection_V2_Constants.fstar_refl_term_view_fv -let (e_term_view : - FStar_Reflection_V2_Data.term_view FStar_TypeChecker_NBETerm.embedding) = - e_term_view_aq (Prims.int_zero, []) -let (e_namedv_view : - FStar_Reflection_V2_Data.namedv_view FStar_TypeChecker_NBETerm.embedding) = - let embed_namedv_view cb namedvv = - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed FStar_TypeChecker_NBETerm.e_int cb - namedvv.FStar_Reflection_V2_Data.uniq in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed e_ppname cb - namedvv.FStar_Reflection_V2_Data.ppname in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - FStar_TypeChecker_NBETerm.embed e_sort cb - namedvv.FStar_Reflection_V2_Data.sort in - FStar_TypeChecker_NBETerm.as_arg uu___6 in - [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V2_Constants.ref_Mk_namedv_view.FStar_Reflection_V2_Constants.fv - [] uu___ in - let unembed_namedv_view cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, (sort, uu___1)::(ppname, uu___2)::(uniq, uu___3)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Mk_namedv_view.FStar_Reflection_V2_Constants.lid - -> - let uu___4 = - FStar_TypeChecker_NBETerm.unembed FStar_TypeChecker_NBETerm.e_int - cb uniq in - FStar_Compiler_Util.bind_opt uu___4 - (fun uniq1 -> - let uu___5 = - FStar_TypeChecker_NBETerm.unembed e_ppname cb ppname in - FStar_Compiler_Util.bind_opt uu___5 - (fun ppname1 -> - let uu___6 = - FStar_TypeChecker_NBETerm.unembed e_sort cb sort in - FStar_Compiler_Util.bind_opt uu___6 - (fun sort1 -> - let r = - { - FStar_Reflection_V2_Data.uniq = uniq1; - FStar_Reflection_V2_Data.sort = sort1; - FStar_Reflection_V2_Data.ppname = ppname1 - } in - FStar_Pervasives_Native.Some r))) - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded namedv_view: %s" - uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_namedv_view unembed_namedv_view - FStar_Reflection_V2_Constants.fstar_refl_namedv_view_fv -let (e_bv_view : - FStar_Reflection_V2_Data.bv_view FStar_TypeChecker_NBETerm.embedding) = - let embed_bv_view cb bvv = - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed FStar_TypeChecker_NBETerm.e_int cb - bvv.FStar_Reflection_V2_Data.index in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed e_ppname cb - bvv.FStar_Reflection_V2_Data.ppname1 in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - FStar_TypeChecker_NBETerm.embed e_sort cb - bvv.FStar_Reflection_V2_Data.sort1 in - FStar_TypeChecker_NBETerm.as_arg uu___6 in - [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V2_Constants.ref_Mk_bv_view.FStar_Reflection_V2_Constants.fv - [] uu___ in - let unembed_bv_view cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, (sort, uu___1)::(ppname, uu___2)::(idx, uu___3)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Mk_bv_view.FStar_Reflection_V2_Constants.lid - -> - let uu___4 = - FStar_TypeChecker_NBETerm.unembed FStar_TypeChecker_NBETerm.e_int - cb idx in - FStar_Compiler_Util.bind_opt uu___4 - (fun idx1 -> - let uu___5 = - FStar_TypeChecker_NBETerm.unembed e_ppname cb ppname in - FStar_Compiler_Util.bind_opt uu___5 - (fun ppname1 -> - let uu___6 = - FStar_TypeChecker_NBETerm.unembed e_sort cb sort in - FStar_Compiler_Util.bind_opt uu___6 - (fun sort1 -> - let r = - { - FStar_Reflection_V2_Data.index = idx1; - FStar_Reflection_V2_Data.sort1 = sort1; - FStar_Reflection_V2_Data.ppname1 = ppname1 - } in - FStar_Pervasives_Native.Some r))) - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded bv_view: %s" uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_bv_view unembed_bv_view - FStar_Reflection_V2_Constants.fstar_refl_bv_view_fv -let (e_attribute : - FStar_Syntax_Syntax.attribute FStar_TypeChecker_NBETerm.embedding) = e_term -let (e_attributes : - FStar_Syntax_Syntax.attribute Prims.list - FStar_TypeChecker_NBETerm.embedding) - = FStar_TypeChecker_NBETerm.e_list e_attribute -let (e_binding : - FStar_Reflection_V2_Data.binding FStar_TypeChecker_NBETerm.embedding) = - let embed cb b = - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed FStar_TypeChecker_NBETerm.e_int cb - b.FStar_Reflection_V2_Data.uniq1 in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed e_term cb - b.FStar_Reflection_V2_Data.sort3 in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - FStar_TypeChecker_NBETerm.embed e_ppname cb - b.FStar_Reflection_V2_Data.ppname3 in - FStar_TypeChecker_NBETerm.as_arg uu___6 in - [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V2_Constants.ref_Mk_binding.FStar_Reflection_V2_Constants.fv - [] uu___ in - let unembed cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, (ppname, uu___1)::(sort, uu___2)::(uniq, uu___3)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Mk_binding.FStar_Reflection_V2_Constants.lid - -> - let uu___4 = - FStar_TypeChecker_NBETerm.unembed FStar_TypeChecker_NBETerm.e_int - cb uniq in - FStar_Compiler_Util.bind_opt uu___4 - (fun uniq1 -> - let uu___5 = FStar_TypeChecker_NBETerm.unembed e_term cb sort in - FStar_Compiler_Util.bind_opt uu___5 - (fun sort1 -> - let uu___6 = - FStar_TypeChecker_NBETerm.unembed e_ppname cb ppname in - FStar_Compiler_Util.bind_opt uu___6 - (fun ppname1 -> - let r = - { - FStar_Reflection_V2_Data.uniq1 = uniq1; - FStar_Reflection_V2_Data.sort3 = sort1; - FStar_Reflection_V2_Data.ppname3 = ppname1 - } in - FStar_Pervasives_Native.Some r))) in - mk_emb' embed unembed FStar_Reflection_V2_Constants.fstar_refl_binding_fv -let (e_binder_view : - FStar_Reflection_V2_Data.binder_view FStar_TypeChecker_NBETerm.embedding) = - let embed_binder_view cb bview = - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed e_term cb - bview.FStar_Reflection_V2_Data.sort2 in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed e_aqualv cb - bview.FStar_Reflection_V2_Data.qual in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - FStar_TypeChecker_NBETerm.embed e_attributes cb - bview.FStar_Reflection_V2_Data.attrs in - FStar_TypeChecker_NBETerm.as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - FStar_TypeChecker_NBETerm.embed e_ppname cb - bview.FStar_Reflection_V2_Data.ppname2 in - FStar_TypeChecker_NBETerm.as_arg uu___8 in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V2_Constants.ref_Mk_binder_view.FStar_Reflection_V2_Constants.fv - [] uu___ in - let unembed_binder_view cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, - (ppname, uu___1)::(attrs, uu___2)::(q, uu___3)::(sort, uu___4)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Mk_binder_view.FStar_Reflection_V2_Constants.lid - -> - let uu___5 = FStar_TypeChecker_NBETerm.unembed e_term cb sort in - FStar_Compiler_Util.bind_opt uu___5 - (fun sort1 -> - let uu___6 = FStar_TypeChecker_NBETerm.unembed e_aqualv cb q in - FStar_Compiler_Util.bind_opt uu___6 - (fun q1 -> - let uu___7 = - FStar_TypeChecker_NBETerm.unembed e_attributes cb attrs in - FStar_Compiler_Util.bind_opt uu___7 - (fun attrs1 -> - let uu___8 = - FStar_TypeChecker_NBETerm.unembed e_ppname cb ppname in - FStar_Compiler_Util.bind_opt uu___8 - (fun ppname1 -> - let r = - { - FStar_Reflection_V2_Data.sort2 = sort1; - FStar_Reflection_V2_Data.qual = q1; - FStar_Reflection_V2_Data.attrs = attrs1; - FStar_Reflection_V2_Data.ppname2 = ppname1 - } in - FStar_Pervasives_Native.Some r)))) - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded binder_view: %s" - uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_binder_view unembed_binder_view - FStar_Reflection_V2_Constants.fstar_refl_binder_view_fv -let (e_comp_view : - FStar_Reflection_V2_Data.comp_view FStar_TypeChecker_NBETerm.embedding) = - let embed_comp_view cb cv = - match cv with - | FStar_Reflection_V2_Data.C_Total t -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_term cb t in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V2_Constants.ref_C_Total.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.C_GTotal t -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_term cb t in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V2_Constants.ref_C_GTotal.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.C_Lemma (pre, post, pats) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_term cb pre in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = FStar_TypeChecker_NBETerm.embed e_term cb post in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = FStar_TypeChecker_NBETerm.embed e_term cb pats in - FStar_TypeChecker_NBETerm.as_arg uu___6 in - [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V2_Constants.ref_C_Lemma.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.C_Eff (us, eff, res, args, decrs) -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_list e_universe) cb us in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed - FStar_TypeChecker_NBETerm.e_string_list cb eff in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = FStar_TypeChecker_NBETerm.embed e_term cb res in - FStar_TypeChecker_NBETerm.as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_list e_argv) cb args in - FStar_TypeChecker_NBETerm.as_arg uu___8 in - let uu___8 = - let uu___9 = - let uu___10 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_list e_term) cb decrs in - FStar_TypeChecker_NBETerm.as_arg uu___10 in - [uu___9] in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V2_Constants.ref_C_Eff.FStar_Reflection_V2_Constants.fv - [] uu___ in - let unembed_comp_view cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, (t1, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_C_Total.FStar_Reflection_V2_Constants.lid - -> - let uu___2 = FStar_TypeChecker_NBETerm.unembed e_term cb t1 in - FStar_Compiler_Util.bind_opt uu___2 - (fun t2 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.C_Total t2)) - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, (t1, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_C_GTotal.FStar_Reflection_V2_Constants.lid - -> - let uu___2 = FStar_TypeChecker_NBETerm.unembed e_term cb t1 in - FStar_Compiler_Util.bind_opt uu___2 - (fun t2 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.C_GTotal t2)) - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, (post, uu___1)::(pre, uu___2)::(pats, uu___3)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_C_Lemma.FStar_Reflection_V2_Constants.lid - -> - let uu___4 = FStar_TypeChecker_NBETerm.unembed e_term cb pre in - FStar_Compiler_Util.bind_opt uu___4 - (fun pre1 -> - let uu___5 = FStar_TypeChecker_NBETerm.unembed e_term cb post in - FStar_Compiler_Util.bind_opt uu___5 - (fun post1 -> - let uu___6 = - FStar_TypeChecker_NBETerm.unembed e_term cb pats in - FStar_Compiler_Util.bind_opt uu___6 - (fun pats1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.C_Lemma - (pre1, post1, pats1))))) - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, - (decrs, uu___1)::(args, uu___2)::(res, uu___3)::(eff, uu___4):: - (us, uu___5)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_C_Eff.FStar_Reflection_V2_Constants.lid - -> - let uu___6 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_list e_universe) cb us in - FStar_Compiler_Util.bind_opt uu___6 - (fun us1 -> - let uu___7 = - FStar_TypeChecker_NBETerm.unembed - FStar_TypeChecker_NBETerm.e_string_list cb eff in - FStar_Compiler_Util.bind_opt uu___7 - (fun eff1 -> - let uu___8 = - FStar_TypeChecker_NBETerm.unembed e_term cb res in - FStar_Compiler_Util.bind_opt uu___8 - (fun res1 -> - let uu___9 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_list e_argv) cb args in - FStar_Compiler_Util.bind_opt uu___9 - (fun args1 -> - let uu___10 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_list e_term) cb - decrs in - FStar_Compiler_Util.bind_opt uu___10 - (fun decrs1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.C_Eff - (us1, eff1, res1, args1, decrs1))))))) - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded comp_view: %s" - uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_comp_view unembed_comp_view - FStar_Reflection_V2_Constants.fstar_refl_comp_view_fv -let (e_sigelt : - FStar_Syntax_Syntax.sigelt FStar_TypeChecker_NBETerm.embedding) = - let embed_sigelt cb se = - mk_lazy cb se FStar_Reflection_V2_Constants.fstar_refl_sigelt - FStar_Syntax_Syntax.Lazy_sigelt in - let unembed_sigelt cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Lazy - (FStar_Pervasives.Inl - { FStar_Syntax_Syntax.blob = b; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_sigelt; - FStar_Syntax_Syntax.ltyp = uu___; - FStar_Syntax_Syntax.rng = uu___1;_}, - uu___2) - -> - let uu___3 = FStar_Dyn.undyn b in FStar_Pervasives_Native.Some uu___3 - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded sigelt: %s" uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_sigelt unembed_sigelt - FStar_Reflection_V2_Constants.fstar_refl_sigelt_fv -let (e_string_list : - Prims.string Prims.list FStar_TypeChecker_NBETerm.embedding) = - FStar_TypeChecker_NBETerm.e_list FStar_TypeChecker_NBETerm.e_string -let (e_ctor : - (Prims.string Prims.list * FStar_Syntax_Syntax.term) - FStar_TypeChecker_NBETerm.embedding) - = FStar_TypeChecker_NBETerm.e_tuple2 e_string_list e_term -let (e_lb_view : - FStar_Reflection_V2_Data.lb_view FStar_TypeChecker_NBETerm.embedding) = - let embed_lb_view cb lbv = - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed e_fv cb - lbv.FStar_Reflection_V2_Data.lb_fv in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed e_univ_names cb - lbv.FStar_Reflection_V2_Data.lb_us in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - FStar_TypeChecker_NBETerm.embed e_term cb - lbv.FStar_Reflection_V2_Data.lb_typ in - FStar_TypeChecker_NBETerm.as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - FStar_TypeChecker_NBETerm.embed e_term cb - lbv.FStar_Reflection_V2_Data.lb_def in - FStar_TypeChecker_NBETerm.as_arg uu___8 in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V2_Constants.ref_Mk_lb.FStar_Reflection_V2_Constants.fv - [] uu___ in - let unembed_lb_view cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, - (fv', uu___1)::(us, uu___2)::(typ, uu___3)::(def, uu___4)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Mk_lb.FStar_Reflection_V2_Constants.lid - -> - let uu___5 = FStar_TypeChecker_NBETerm.unembed e_fv cb fv' in - FStar_Compiler_Util.bind_opt uu___5 - (fun fv'1 -> - let uu___6 = - FStar_TypeChecker_NBETerm.unembed e_univ_names cb us in - FStar_Compiler_Util.bind_opt uu___6 - (fun us1 -> - let uu___7 = - FStar_TypeChecker_NBETerm.unembed e_term cb typ in - FStar_Compiler_Util.bind_opt uu___7 - (fun typ1 -> - let uu___8 = - FStar_TypeChecker_NBETerm.unembed e_term cb def in - FStar_Compiler_Util.bind_opt uu___8 - (fun def1 -> - FStar_Pervasives_Native.Some - { - FStar_Reflection_V2_Data.lb_fv = fv'1; - FStar_Reflection_V2_Data.lb_us = us1; - FStar_Reflection_V2_Data.lb_typ = typ1; - FStar_Reflection_V2_Data.lb_def = def1 - })))) - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded lb_view: %s" uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_lb_view unembed_lb_view - FStar_Reflection_V2_Constants.fstar_refl_lb_view_fv -let (e_lid : FStar_Ident.lid FStar_TypeChecker_NBETerm.embedding) = - let embed rng lid = - let uu___ = FStar_Ident.path_of_lid lid in - FStar_TypeChecker_NBETerm.embed e_string_list rng uu___ in - let unembed cb t = - let uu___ = FStar_TypeChecker_NBETerm.unembed e_string_list cb t in - FStar_Compiler_Util.map_opt uu___ - (fun p -> - FStar_Ident.lid_of_path p FStar_Compiler_Range_Type.dummyRange) in - FStar_TypeChecker_NBETerm.mk_emb embed unembed - (fun uu___ -> - mkConstruct FStar_Reflection_V2_Constants.fstar_refl_aqualv_fv [] []) - (fun uu___ -> - fv_as_emb_typ FStar_Reflection_V2_Constants.fstar_refl_aqualv_fv) -let (e_letbinding : - FStar_Syntax_Syntax.letbinding FStar_TypeChecker_NBETerm.embedding) = - let embed_letbinding cb lb = - mk_lazy cb lb FStar_Reflection_V2_Constants.fstar_refl_letbinding - FStar_Syntax_Syntax.Lazy_letbinding in - let unembed_letbinding cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Lazy - (FStar_Pervasives.Inl - { FStar_Syntax_Syntax.blob = lb; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_letbinding; - FStar_Syntax_Syntax.ltyp = uu___; - FStar_Syntax_Syntax.rng = uu___1;_}, - uu___2) - -> - let uu___3 = FStar_Dyn.undyn lb in - FStar_Pervasives_Native.Some uu___3 - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded letbinding: %s" - uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_letbinding unembed_letbinding - FStar_Reflection_V2_Constants.fstar_refl_letbinding_fv -let (e_sigelt_view : - FStar_Reflection_V2_Data.sigelt_view FStar_TypeChecker_NBETerm.embedding) = - let embed_sigelt_view cb sev = - match sev with - | FStar_Reflection_V2_Data.Sg_Let (r, lbs) -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed - FStar_TypeChecker_NBETerm.e_bool cb r in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_list e_letbinding) cb lbs in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - [uu___3] in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V2_Constants.ref_Sg_Let.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.Sg_Inductive (nm, univs, bs, t, dcs) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_string_list cb nm in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed e_univ_names cb univs in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = FStar_TypeChecker_NBETerm.embed e_binders cb bs in - FStar_TypeChecker_NBETerm.as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = FStar_TypeChecker_NBETerm.embed e_term cb t in - FStar_TypeChecker_NBETerm.as_arg uu___8 in - let uu___8 = - let uu___9 = - let uu___10 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_list e_ctor) cb dcs in - FStar_TypeChecker_NBETerm.as_arg uu___10 in - [uu___9] in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V2_Constants.ref_Sg_Inductive.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.Sg_Val (nm, univs, t) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_string_list cb nm in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.embed e_univ_names cb univs in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = FStar_TypeChecker_NBETerm.embed e_term cb t in - FStar_TypeChecker_NBETerm.as_arg uu___6 in - [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mkConstruct - FStar_Reflection_V2_Constants.ref_Sg_Val.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.Unk -> - mkConstruct - FStar_Reflection_V2_Constants.ref_Unk.FStar_Reflection_V2_Constants.fv - [] [] in - let unembed_sigelt_view cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, - (dcs, uu___1)::(t1, uu___2)::(bs, uu___3)::(us, uu___4)::(nm, - uu___5)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Sg_Inductive.FStar_Reflection_V2_Constants.lid - -> - let uu___6 = FStar_TypeChecker_NBETerm.unembed e_string_list cb nm in - FStar_Compiler_Util.bind_opt uu___6 - (fun nm1 -> - let uu___7 = - FStar_TypeChecker_NBETerm.unembed e_univ_names cb us in - FStar_Compiler_Util.bind_opt uu___7 - (fun us1 -> - let uu___8 = - FStar_TypeChecker_NBETerm.unembed e_binders cb bs in - FStar_Compiler_Util.bind_opt uu___8 - (fun bs1 -> - let uu___9 = - FStar_TypeChecker_NBETerm.unembed e_term cb t1 in - FStar_Compiler_Util.bind_opt uu___9 - (fun t2 -> - let uu___10 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_list e_ctor) cb - dcs in - FStar_Compiler_Util.bind_opt uu___10 - (fun dcs1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.Sg_Inductive - (nm1, us1, bs1, t2, dcs1))))))) - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, (lbs, uu___1)::(r, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Sg_Let.FStar_Reflection_V2_Constants.lid - -> - let uu___3 = - FStar_TypeChecker_NBETerm.unembed FStar_TypeChecker_NBETerm.e_bool - cb r in - FStar_Compiler_Util.bind_opt uu___3 - (fun r1 -> - let uu___4 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_list e_letbinding) cb lbs in - FStar_Compiler_Util.bind_opt uu___4 - (fun lbs1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.Sg_Let (r1, lbs1)))) - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___, (t1, uu___1)::(us, uu___2)::(nm, uu___3)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Sg_Val.FStar_Reflection_V2_Constants.lid - -> - let uu___4 = FStar_TypeChecker_NBETerm.unembed e_string_list cb nm in - FStar_Compiler_Util.bind_opt uu___4 - (fun nm1 -> - let uu___5 = - FStar_TypeChecker_NBETerm.unembed e_univ_names cb us in - FStar_Compiler_Util.bind_opt uu___5 - (fun us1 -> - let uu___6 = FStar_TypeChecker_NBETerm.unembed e_term cb t1 in - FStar_Compiler_Util.bind_opt uu___6 - (fun t2 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.Sg_Val (nm1, us1, t2))))) - | FStar_TypeChecker_NBETerm.Construct (fv, uu___, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_Unk.FStar_Reflection_V2_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V2_Data.Unk - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded sigelt_view: %s" - uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb' embed_sigelt_view unembed_sigelt_view - FStar_Reflection_V2_Constants.fstar_refl_sigelt_view_fv -let (e_name : - FStar_Reflection_V2_Data.name FStar_TypeChecker_NBETerm.embedding) = - FStar_TypeChecker_NBETerm.e_list FStar_TypeChecker_NBETerm.e_string -let (e_qualifier : - FStar_Reflection_V2_Data.qualifier FStar_TypeChecker_NBETerm.embedding) = - let embed cb q = - match q with - | FStar_Reflection_V2_Data.Assumption -> - mkConstruct - FStar_Reflection_V2_Constants.ref_qual_Assumption.FStar_Reflection_V2_Constants.fv - [] [] - | FStar_Reflection_V2_Data.New -> - mkConstruct - FStar_Reflection_V2_Constants.ref_qual_New.FStar_Reflection_V2_Constants.fv - [] [] - | FStar_Reflection_V2_Data.Private -> - mkConstruct - FStar_Reflection_V2_Constants.ref_qual_Private.FStar_Reflection_V2_Constants.fv - [] [] - | FStar_Reflection_V2_Data.Unfold_for_unification_and_vcgen -> - mkConstruct - FStar_Reflection_V2_Constants.ref_qual_Unfold_for_unification_and_vcgen.FStar_Reflection_V2_Constants.fv - [] [] - | FStar_Reflection_V2_Data.Visible_default -> - mkConstruct - FStar_Reflection_V2_Constants.ref_qual_Visible_default.FStar_Reflection_V2_Constants.fv - [] [] - | FStar_Reflection_V2_Data.Irreducible -> - mkConstruct - FStar_Reflection_V2_Constants.ref_qual_Irreducible.FStar_Reflection_V2_Constants.fv - [] [] - | FStar_Reflection_V2_Data.Inline_for_extraction -> - mkConstruct - FStar_Reflection_V2_Constants.ref_qual_Inline_for_extraction.FStar_Reflection_V2_Constants.fv - [] [] - | FStar_Reflection_V2_Data.NoExtract -> - mkConstruct - FStar_Reflection_V2_Constants.ref_qual_NoExtract.FStar_Reflection_V2_Constants.fv - [] [] - | FStar_Reflection_V2_Data.Noeq -> - mkConstruct - FStar_Reflection_V2_Constants.ref_qual_Noeq.FStar_Reflection_V2_Constants.fv - [] [] - | FStar_Reflection_V2_Data.Unopteq -> - mkConstruct - FStar_Reflection_V2_Constants.ref_qual_Unopteq.FStar_Reflection_V2_Constants.fv - [] [] - | FStar_Reflection_V2_Data.TotalEffect -> - mkConstruct - FStar_Reflection_V2_Constants.ref_qual_TotalEffect.FStar_Reflection_V2_Constants.fv - [] [] - | FStar_Reflection_V2_Data.Logic -> - mkConstruct - FStar_Reflection_V2_Constants.ref_qual_Logic.FStar_Reflection_V2_Constants.fv - [] [] - | FStar_Reflection_V2_Data.Reifiable -> - mkConstruct - FStar_Reflection_V2_Constants.ref_qual_Reifiable.FStar_Reflection_V2_Constants.fv - [] [] - | FStar_Reflection_V2_Data.ExceptionConstructor -> - mkConstruct - FStar_Reflection_V2_Constants.ref_qual_ExceptionConstructor.FStar_Reflection_V2_Constants.fv - [] [] - | FStar_Reflection_V2_Data.HasMaskedEffect -> - mkConstruct - FStar_Reflection_V2_Constants.ref_qual_HasMaskedEffect.FStar_Reflection_V2_Constants.fv - [] [] - | FStar_Reflection_V2_Data.Effect -> - mkConstruct - FStar_Reflection_V2_Constants.ref_qual_Effect.FStar_Reflection_V2_Constants.fv - [] [] - | FStar_Reflection_V2_Data.OnlyName -> - mkConstruct - FStar_Reflection_V2_Constants.ref_qual_OnlyName.FStar_Reflection_V2_Constants.fv - [] [] - | FStar_Reflection_V2_Data.Reflectable l -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_name cb l in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V2_Constants.ref_qual_Reflectable.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.Discriminator l -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_name cb l in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V2_Constants.ref_qual_Discriminator.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.Action l -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.embed e_name cb l in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V2_Constants.ref_qual_Action.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.Projector li -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_tuple2 e_name e_ident) cb li in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V2_Constants.ref_qual_Projector.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.RecordType ids12 -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_tuple2 - (FStar_TypeChecker_NBETerm.e_list e_ident) - (FStar_TypeChecker_NBETerm.e_list e_ident)) cb ids12 in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V2_Constants.ref_qual_RecordType.FStar_Reflection_V2_Constants.fv - [] uu___ - | FStar_Reflection_V2_Data.RecordConstructor ids12 -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_tuple2 - (FStar_TypeChecker_NBETerm.e_list e_ident) - (FStar_TypeChecker_NBETerm.e_list e_ident)) cb ids12 in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct - FStar_Reflection_V2_Constants.ref_qual_RecordConstructor.FStar_Reflection_V2_Constants.fv - [] uu___ in - let unembed cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_Assumption.FStar_Reflection_V2_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V2_Data.Assumption - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_New.FStar_Reflection_V2_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V2_Data.New - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_Private.FStar_Reflection_V2_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V2_Data.Private - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_Unfold_for_unification_and_vcgen.FStar_Reflection_V2_Constants.lid - -> - FStar_Pervasives_Native.Some - FStar_Reflection_V2_Data.Unfold_for_unification_and_vcgen - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_Visible_default.FStar_Reflection_V2_Constants.lid - -> - FStar_Pervasives_Native.Some FStar_Reflection_V2_Data.Visible_default - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_Irreducible.FStar_Reflection_V2_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V2_Data.Irreducible - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_Inline_for_extraction.FStar_Reflection_V2_Constants.lid - -> - FStar_Pervasives_Native.Some - FStar_Reflection_V2_Data.Inline_for_extraction - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_NoExtract.FStar_Reflection_V2_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V2_Data.NoExtract - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_Noeq.FStar_Reflection_V2_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V2_Data.Noeq - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_Unopteq.FStar_Reflection_V2_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V2_Data.Unopteq - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_TotalEffect.FStar_Reflection_V2_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V2_Data.TotalEffect - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_Logic.FStar_Reflection_V2_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V2_Data.Logic - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_Reifiable.FStar_Reflection_V2_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V2_Data.Reifiable - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_ExceptionConstructor.FStar_Reflection_V2_Constants.lid - -> - FStar_Pervasives_Native.Some - FStar_Reflection_V2_Data.ExceptionConstructor - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_HasMaskedEffect.FStar_Reflection_V2_Constants.lid - -> - FStar_Pervasives_Native.Some FStar_Reflection_V2_Data.HasMaskedEffect - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_Effect.FStar_Reflection_V2_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V2_Data.Effect - | FStar_TypeChecker_NBETerm.Construct (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_OnlyName.FStar_Reflection_V2_Constants.lid - -> FStar_Pervasives_Native.Some FStar_Reflection_V2_Data.OnlyName - | FStar_TypeChecker_NBETerm.Construct (fv, [], (l, uu___)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_Reflectable.FStar_Reflection_V2_Constants.lid - -> - let uu___1 = FStar_TypeChecker_NBETerm.unembed e_name cb l in - FStar_Compiler_Util.bind_opt uu___1 - (fun l1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.Reflectable l1)) - | FStar_TypeChecker_NBETerm.Construct (fv, [], (l, uu___)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_Discriminator.FStar_Reflection_V2_Constants.lid - -> - let uu___1 = FStar_TypeChecker_NBETerm.unembed e_name cb l in - FStar_Compiler_Util.bind_opt uu___1 - (fun l1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.Discriminator l1)) - | FStar_TypeChecker_NBETerm.Construct (fv, [], (l, uu___)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_Action.FStar_Reflection_V2_Constants.lid - -> - let uu___1 = FStar_TypeChecker_NBETerm.unembed e_name cb l in - FStar_Compiler_Util.bind_opt uu___1 - (fun l1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.Action l1)) - | FStar_TypeChecker_NBETerm.Construct (fv, [], (li, uu___)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_Projector.FStar_Reflection_V2_Constants.lid - -> - let uu___1 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_tuple2 e_name e_ident) cb li in - FStar_Compiler_Util.bind_opt uu___1 - (fun li1 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.Projector li1)) - | FStar_TypeChecker_NBETerm.Construct (fv, [], (ids12, uu___)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_RecordType.FStar_Reflection_V2_Constants.lid - -> - let uu___1 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_tuple2 - (FStar_TypeChecker_NBETerm.e_list e_ident) - (FStar_TypeChecker_NBETerm.e_list e_ident)) cb ids12 in - FStar_Compiler_Util.bind_opt uu___1 - (fun ids121 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.RecordType ids121)) - | FStar_TypeChecker_NBETerm.Construct (fv, [], (ids12, uu___)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Reflection_V2_Constants.ref_qual_RecordConstructor.FStar_Reflection_V2_Constants.lid - -> - let uu___1 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_tuple2 - (FStar_TypeChecker_NBETerm.e_list e_ident) - (FStar_TypeChecker_NBETerm.e_list e_ident)) cb ids12 in - FStar_Compiler_Util.bind_opt uu___1 - (fun ids121 -> - FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Data.RecordConstructor ids121)) - | uu___ -> - ((let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded qualifier: %s" - uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - FStar_TypeChecker_NBETerm.mk_emb embed unembed - (fun uu___ -> - mkConstruct FStar_Reflection_V2_Constants.fstar_refl_qualifier_fv [] - []) - (fun uu___ -> - fv_as_emb_typ FStar_Reflection_V2_Constants.fstar_refl_qualifier_fv) -let (e_qualifiers : - FStar_Reflection_V2_Data.qualifier Prims.list - FStar_TypeChecker_NBETerm.embedding) - = FStar_TypeChecker_NBETerm.e_list e_qualifier -let (e_vconfig : FStar_Order.order FStar_TypeChecker_NBETerm.embedding) = - let emb cb o = failwith "emb vconfig NBE" in - let unemb cb t = failwith "unemb vconfig NBE" in - let uu___ = - FStar_Syntax_Syntax.lid_as_fv FStar_Parser_Const.vconfig_lid - FStar_Pervasives_Native.None in - mk_emb' emb unemb uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml deleted file mode 100644 index 9aefeb86327..00000000000 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Encode.ml +++ /dev/null @@ -1,7935 +0,0 @@ -open Prims -type encoding_depth = (Prims.int * Prims.int) -let (dbg_SMTEncoding : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "SMTEncoding" -let (dbg_SMTQuery : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "SMTQuery" -let (dbg_Time : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Time" -let (norm_before_encoding : - FStar_SMTEncoding_Env.env_t -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun env -> - fun t -> - let steps = - [FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.Simplify; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.AllowUnboundUniverses; - FStar_TypeChecker_Env.EraseUniverses; - FStar_TypeChecker_Env.Exclude FStar_TypeChecker_Env.Zeta] in - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_Env.current_module - env.FStar_SMTEncoding_Env.tcenv in - FStar_Ident.string_of_lid uu___2 in - FStar_Pervasives_Native.Some uu___1 in - FStar_Profiling.profile - (fun uu___1 -> - FStar_TypeChecker_Normalize.normalize steps - env.FStar_SMTEncoding_Env.tcenv t) uu___ - "FStar.SMTEncoding.Encode.norm_before_encoding" -let (norm_before_encoding_us : - FStar_SMTEncoding_Env.env_t -> - FStar_Syntax_Syntax.univ_names -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun env -> - fun us -> - fun t -> - let env_u = - let uu___ = - FStar_TypeChecker_Env.push_univ_vars - env.FStar_SMTEncoding_Env.tcenv us in - { - FStar_SMTEncoding_Env.bvar_bindings = - (env.FStar_SMTEncoding_Env.bvar_bindings); - FStar_SMTEncoding_Env.fvar_bindings = - (env.FStar_SMTEncoding_Env.fvar_bindings); - FStar_SMTEncoding_Env.depth = (env.FStar_SMTEncoding_Env.depth); - FStar_SMTEncoding_Env.tcenv = uu___; - FStar_SMTEncoding_Env.warn = (env.FStar_SMTEncoding_Env.warn); - FStar_SMTEncoding_Env.nolabels = - (env.FStar_SMTEncoding_Env.nolabels); - FStar_SMTEncoding_Env.use_zfuel_name = - (env.FStar_SMTEncoding_Env.use_zfuel_name); - FStar_SMTEncoding_Env.encode_non_total_function_typ = - (env.FStar_SMTEncoding_Env.encode_non_total_function_typ); - FStar_SMTEncoding_Env.current_module_name = - (env.FStar_SMTEncoding_Env.current_module_name); - FStar_SMTEncoding_Env.encoding_quantifier = - (env.FStar_SMTEncoding_Env.encoding_quantifier); - FStar_SMTEncoding_Env.global_cache = - (env.FStar_SMTEncoding_Env.global_cache) - } in - let uu___ = FStar_Syntax_Subst.open_univ_vars us t in - match uu___ with - | (us1, t1) -> - let t2 = norm_before_encoding env_u t1 in - FStar_Syntax_Subst.close_univ_vars us1 t2 -let (norm_with_steps : - FStar_TypeChecker_Env.steps -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun steps -> - fun env -> - fun t -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_Env.current_module env in - FStar_Ident.string_of_lid uu___2 in - FStar_Pervasives_Native.Some uu___1 in - FStar_Profiling.profile - (fun uu___1 -> FStar_TypeChecker_Normalize.normalize steps env t) - uu___ "FStar.SMTEncoding.Encode.norm" -type prims_t = - { - mk: - FStar_Ident.lident -> - Prims.string -> - (FStar_SMTEncoding_Term.term * Prims.int * - FStar_SMTEncoding_Term.decl Prims.list) - ; - is: FStar_Ident.lident -> Prims.bool } -let (__proj__Mkprims_t__item__mk : - prims_t -> - FStar_Ident.lident -> - Prims.string -> - (FStar_SMTEncoding_Term.term * Prims.int * - FStar_SMTEncoding_Term.decl Prims.list)) - = fun projectee -> match projectee with | { mk; is;_} -> mk -let (__proj__Mkprims_t__item__is : - prims_t -> FStar_Ident.lident -> Prims.bool) = - fun projectee -> match projectee with | { mk; is;_} -> is -type defn_rel_type = - | Eq - | ValidIff -let (uu___is_Eq : defn_rel_type -> Prims.bool) = - fun projectee -> match projectee with | Eq -> true | uu___ -> false -let (uu___is_ValidIff : defn_rel_type -> Prims.bool) = - fun projectee -> match projectee with | ValidIff -> true | uu___ -> false -let (rel_type_f : - defn_rel_type -> - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = - fun uu___ -> - match uu___ with - | Eq -> FStar_SMTEncoding_Util.mkEq - | ValidIff -> - (fun uu___1 -> - match uu___1 with - | (x, y) -> - let uu___2 = - let uu___3 = FStar_SMTEncoding_Term.mk_Valid x in - (uu___3, y) in - FStar_SMTEncoding_Util.mkEq uu___2) -let (prims : prims_t) = - let module_name = "Prims" in - let uu___ = - FStar_SMTEncoding_Env.fresh_fvar module_name "a" - FStar_SMTEncoding_Term.Term_sort in - match uu___ with - | (asym, a) -> - let uu___1 = - FStar_SMTEncoding_Env.fresh_fvar module_name "x" - FStar_SMTEncoding_Term.Term_sort in - (match uu___1 with - | (xsym, x) -> - let uu___2 = - FStar_SMTEncoding_Env.fresh_fvar module_name "y" - FStar_SMTEncoding_Term.Term_sort in - (match uu___2 with - | (ysym, y) -> - let quant_with_pre rel vars precondition body rng x1 = - let xname_decl = - let uu___3 = - let uu___4 = - FStar_Compiler_List.map - FStar_SMTEncoding_Term.fv_sort vars in - (x1, uu___4, FStar_SMTEncoding_Term.Term_sort, - FStar_Pervasives_Native.None) in - FStar_SMTEncoding_Term.DeclFun uu___3 in - let xtok = Prims.strcat x1 "@tok" in - let xtok_decl = - FStar_SMTEncoding_Term.DeclFun - (xtok, [], FStar_SMTEncoding_Term.Term_sort, - FStar_Pervasives_Native.None) in - let xapp = - let uu___3 = - let uu___4 = - FStar_Compiler_List.map - FStar_SMTEncoding_Util.mkFreeV vars in - (x1, uu___4) in - FStar_SMTEncoding_Util.mkApp uu___3 in - let xtok1 = FStar_SMTEncoding_Util.mkApp (xtok, []) in - let xtok_app = - FStar_SMTEncoding_EncodeTerm.mk_Apply xtok1 vars in - let tot_fun_axioms = - let all_vars_but_one = - FStar_Pervasives_Native.fst - (FStar_Compiler_Util.prefix vars) in - let axiom_name = Prims.strcat "primitive_tot_fun_" x1 in - let tot_fun_axiom_for_x = - let uu___3 = - let uu___4 = FStar_SMTEncoding_Term.mk_IsTotFun xtok1 in - (uu___4, FStar_Pervasives_Native.None, axiom_name) in - FStar_SMTEncoding_Util.mkAssume uu___3 in - let uu___3 = - FStar_Compiler_List.fold_left - (fun uu___4 -> - fun var -> - match uu___4 with - | (axioms, app, vars1) -> - let app1 = - FStar_SMTEncoding_EncodeTerm.mk_Apply app - [var] in - let vars2 = - FStar_Compiler_List.op_At vars1 [var] in - let axiom_name1 = - Prims.strcat axiom_name - (Prims.strcat "." - (Prims.string_of_int - (FStar_Compiler_List.length vars2))) in - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_SMTEncoding_Term.mk_IsTotFun - app1 in - ([[app1]], vars2, uu___11) in - FStar_SMTEncoding_Term.mkForall - rng uu___10 in - (uu___9, - FStar_Pervasives_Native.None, - axiom_name1) in - FStar_SMTEncoding_Util.mkAssume uu___8 in - [uu___7] in - FStar_Compiler_List.op_At axioms uu___6 in - (uu___5, app1, vars2)) - ([tot_fun_axiom_for_x], xtok1, []) all_vars_but_one in - match uu___3 with | (axioms, uu___4, uu___5) -> axioms in - let rel_body = - let rel_body1 = rel_type_f rel (xapp, body) in - match precondition with - | FStar_Pervasives_Native.None -> rel_body1 - | FStar_Pervasives_Native.Some pre -> - FStar_SMTEncoding_Util.mkImp (pre, rel_body1) in - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - FStar_SMTEncoding_Term.mkForall rng - ([[xapp]], vars, rel_body) in - (uu___9, FStar_Pervasives_Native.None, - (Prims.strcat "primitive_" x1)) in - FStar_SMTEncoding_Util.mkAssume uu___8 in - [uu___7] in - xtok_decl :: uu___6 in - xname_decl :: uu___5 in - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_SMTEncoding_Util.mkEq - (xtok_app, xapp) in - ([[xtok_app]], vars, uu___11) in - FStar_SMTEncoding_Term.mkForall rng uu___10 in - (uu___9, - (FStar_Pervasives_Native.Some - "Name-token correspondence"), - (Prims.strcat "token_correspondence_" x1)) in - FStar_SMTEncoding_Util.mkAssume uu___8 in - [uu___7] in - FStar_Compiler_List.op_At tot_fun_axioms uu___6 in - FStar_Compiler_List.op_At uu___4 uu___5 in - (xtok1, (FStar_Compiler_List.length vars), uu___3) in - let quant rel vars body = - quant_with_pre rel vars FStar_Pervasives_Native.None body in - let axy = - FStar_Compiler_List.map FStar_SMTEncoding_Term.mk_fv - [(asym, FStar_SMTEncoding_Term.Term_sort); - (xsym, FStar_SMTEncoding_Term.Term_sort); - (ysym, FStar_SMTEncoding_Term.Term_sort)] in - let xy = - FStar_Compiler_List.map FStar_SMTEncoding_Term.mk_fv - [(xsym, FStar_SMTEncoding_Term.Term_sort); - (ysym, FStar_SMTEncoding_Term.Term_sort)] in - let qx = - FStar_Compiler_List.map FStar_SMTEncoding_Term.mk_fv - [(xsym, FStar_SMTEncoding_Term.Term_sort)] in - let prims1 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = FStar_SMTEncoding_Util.mkEq (x, y) in - FStar_SMTEncoding_Term.boxBool uu___6 in - quant Eq axy uu___5 in - (FStar_Parser_Const.op_Eq, uu___4) in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = FStar_SMTEncoding_Util.mkEq (x, y) in - FStar_SMTEncoding_Util.mkNot uu___9 in - FStar_SMTEncoding_Term.boxBool uu___8 in - quant Eq axy uu___7 in - (FStar_Parser_Const.op_notEq, uu___6) in - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_SMTEncoding_Term.unboxBool x in - let uu___13 = - FStar_SMTEncoding_Term.unboxBool y in - (uu___12, uu___13) in - FStar_SMTEncoding_Util.mkAnd uu___11 in - FStar_SMTEncoding_Term.boxBool uu___10 in - quant Eq xy uu___9 in - (FStar_Parser_Const.op_And, uu___8) in - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - FStar_SMTEncoding_Term.unboxBool x in - let uu___15 = - FStar_SMTEncoding_Term.unboxBool y in - (uu___14, uu___15) in - FStar_SMTEncoding_Util.mkOr uu___13 in - FStar_SMTEncoding_Term.boxBool uu___12 in - quant Eq xy uu___11 in - (FStar_Parser_Const.op_Or, uu___10) in - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - FStar_SMTEncoding_Term.unboxBool x in - FStar_SMTEncoding_Util.mkNot uu___15 in - FStar_SMTEncoding_Term.boxBool uu___14 in - quant Eq qx uu___13 in - (FStar_Parser_Const.op_Negation, uu___12) in - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = - let uu___17 = - let uu___18 = - FStar_SMTEncoding_Term.unboxInt x in - let uu___19 = - FStar_SMTEncoding_Term.unboxInt y in - (uu___18, uu___19) in - FStar_SMTEncoding_Util.mkLT uu___17 in - FStar_SMTEncoding_Term.boxBool uu___16 in - quant Eq xy uu___15 in - (FStar_Parser_Const.op_LT, uu___14) in - let uu___14 = - let uu___15 = - let uu___16 = - let uu___17 = - let uu___18 = - let uu___19 = - let uu___20 = - FStar_SMTEncoding_Term.unboxInt x in - let uu___21 = - FStar_SMTEncoding_Term.unboxInt y in - (uu___20, uu___21) in - FStar_SMTEncoding_Util.mkLTE uu___19 in - FStar_SMTEncoding_Term.boxBool uu___18 in - quant Eq xy uu___17 in - (FStar_Parser_Const.op_LTE, uu___16) in - let uu___16 = - let uu___17 = - let uu___18 = - let uu___19 = - let uu___20 = - let uu___21 = - let uu___22 = - FStar_SMTEncoding_Term.unboxInt x in - let uu___23 = - FStar_SMTEncoding_Term.unboxInt y in - (uu___22, uu___23) in - FStar_SMTEncoding_Util.mkGT uu___21 in - FStar_SMTEncoding_Term.boxBool uu___20 in - quant Eq xy uu___19 in - (FStar_Parser_Const.op_GT, uu___18) in - let uu___18 = - let uu___19 = - let uu___20 = - let uu___21 = - let uu___22 = - let uu___23 = - let uu___24 = - FStar_SMTEncoding_Term.unboxInt - x in - let uu___25 = - FStar_SMTEncoding_Term.unboxInt - y in - (uu___24, uu___25) in - FStar_SMTEncoding_Util.mkGTE - uu___23 in - FStar_SMTEncoding_Term.boxBool - uu___22 in - quant Eq xy uu___21 in - (FStar_Parser_Const.op_GTE, uu___20) in - let uu___20 = - let uu___21 = - let uu___22 = - let uu___23 = - let uu___24 = - let uu___25 = - let uu___26 = - FStar_SMTEncoding_Term.unboxInt - x in - let uu___27 = - FStar_SMTEncoding_Term.unboxInt - y in - (uu___26, uu___27) in - FStar_SMTEncoding_Util.mkSub - uu___25 in - FStar_SMTEncoding_Term.boxInt - uu___24 in - quant Eq xy uu___23 in - (FStar_Parser_Const.op_Subtraction, - uu___22) in - let uu___22 = - let uu___23 = - let uu___24 = - let uu___25 = - let uu___26 = - let uu___27 = - FStar_SMTEncoding_Term.unboxInt - x in - FStar_SMTEncoding_Util.mkMinus - uu___27 in - FStar_SMTEncoding_Term.boxInt - uu___26 in - quant Eq qx uu___25 in - (FStar_Parser_Const.op_Minus, - uu___24) in - let uu___24 = - let uu___25 = - let uu___26 = - let uu___27 = - let uu___28 = - let uu___29 = - let uu___30 = - FStar_SMTEncoding_Term.unboxInt - x in - let uu___31 = - FStar_SMTEncoding_Term.unboxInt - y in - (uu___30, uu___31) in - FStar_SMTEncoding_Util.mkAdd - uu___29 in - FStar_SMTEncoding_Term.boxInt - uu___28 in - quant Eq xy uu___27 in - (FStar_Parser_Const.op_Addition, - uu___26) in - let uu___26 = - let uu___27 = - let uu___28 = - let uu___29 = - let uu___30 = - let uu___31 = - let uu___32 = - FStar_SMTEncoding_Term.unboxInt - x in - let uu___33 = - FStar_SMTEncoding_Term.unboxInt - y in - (uu___32, uu___33) in - FStar_SMTEncoding_Util.mkMul - uu___31 in - FStar_SMTEncoding_Term.boxInt - uu___30 in - quant Eq xy uu___29 in - (FStar_Parser_Const.op_Multiply, - uu___28) in - let uu___28 = - let uu___29 = - let uu___30 = - let uu___31 = - let uu___32 = - let uu___33 = - let uu___34 = - let uu___35 = - FStar_SMTEncoding_Term.unboxInt - y in - let uu___36 = - FStar_SMTEncoding_Util.mkInteger - "0" in - (uu___35, uu___36) in - FStar_SMTEncoding_Util.mkEq - uu___34 in - FStar_SMTEncoding_Util.mkNot - uu___33 in - FStar_Pervasives_Native.Some - uu___32 in - let uu___32 = - let uu___33 = - let uu___34 = - let uu___35 = - FStar_SMTEncoding_Term.unboxInt - x in - let uu___36 = - FStar_SMTEncoding_Term.unboxInt - y in - (uu___35, uu___36) in - FStar_SMTEncoding_Util.mkDiv - uu___34 in - FStar_SMTEncoding_Term.boxInt - uu___33 in - quant_with_pre Eq xy uu___31 - uu___32 in - (FStar_Parser_Const.op_Division, - uu___30) in - let uu___30 = - let uu___31 = - let uu___32 = - let uu___33 = - let uu___34 = - let uu___35 = - let uu___36 = - let uu___37 = - FStar_SMTEncoding_Term.unboxInt - y in - let uu___38 = - FStar_SMTEncoding_Util.mkInteger - "0" in - (uu___37, uu___38) in - FStar_SMTEncoding_Util.mkEq - uu___36 in - FStar_SMTEncoding_Util.mkNot - uu___35 in - FStar_Pervasives_Native.Some - uu___34 in - let uu___34 = - let uu___35 = - let uu___36 = - let uu___37 = - FStar_SMTEncoding_Term.unboxInt - x in - let uu___38 = - FStar_SMTEncoding_Term.unboxInt - y in - (uu___37, uu___38) in - FStar_SMTEncoding_Util.mkMod - uu___36 in - FStar_SMTEncoding_Term.boxInt - uu___35 in - quant_with_pre Eq xy - uu___33 uu___34 in - (FStar_Parser_Const.op_Modulus, - uu___32) in - let uu___32 = - let uu___33 = - let uu___34 = - let uu___35 = - let uu___36 = - let uu___37 = - FStar_SMTEncoding_Term.unboxReal - x in - let uu___38 = - FStar_SMTEncoding_Term.unboxReal - y in - (uu___37, uu___38) in - FStar_SMTEncoding_Util.mkLT - uu___36 in - quant ValidIff xy uu___35 in - (FStar_Parser_Const.real_op_LT, - uu___34) in - let uu___34 = - let uu___35 = - let uu___36 = - let uu___37 = - let uu___38 = - let uu___39 = - FStar_SMTEncoding_Term.unboxReal - x in - let uu___40 = - FStar_SMTEncoding_Term.unboxReal - y in - (uu___39, uu___40) in - FStar_SMTEncoding_Util.mkLTE - uu___38 in - quant ValidIff xy - uu___37 in - (FStar_Parser_Const.real_op_LTE, - uu___36) in - let uu___36 = - let uu___37 = - let uu___38 = - let uu___39 = - let uu___40 = - let uu___41 = - FStar_SMTEncoding_Term.unboxReal - x in - let uu___42 = - FStar_SMTEncoding_Term.unboxReal - y in - (uu___41, - uu___42) in - FStar_SMTEncoding_Util.mkGT - uu___40 in - quant ValidIff xy - uu___39 in - (FStar_Parser_Const.real_op_GT, - uu___38) in - let uu___38 = - let uu___39 = - let uu___40 = - let uu___41 = - let uu___42 = - let uu___43 = - FStar_SMTEncoding_Term.unboxReal - x in - let uu___44 = - FStar_SMTEncoding_Term.unboxReal - y in - (uu___43, - uu___44) in - FStar_SMTEncoding_Util.mkGTE - uu___42 in - quant ValidIff xy - uu___41 in - (FStar_Parser_Const.real_op_GTE, - uu___40) in - let uu___40 = - let uu___41 = - let uu___42 = - let uu___43 = - let uu___44 = - let uu___45 = - let uu___46 - = - FStar_SMTEncoding_Term.unboxReal - x in - let uu___47 - = - FStar_SMTEncoding_Term.unboxReal - y in - (uu___46, - uu___47) in - FStar_SMTEncoding_Util.mkSub - uu___45 in - FStar_SMTEncoding_Term.boxReal - uu___44 in - quant Eq xy - uu___43 in - (FStar_Parser_Const.real_op_Subtraction, - uu___42) in - let uu___42 = - let uu___43 = - let uu___44 = - let uu___45 = - let uu___46 = - let uu___47 - = - let uu___48 - = - FStar_SMTEncoding_Term.unboxReal - x in - let uu___49 - = - FStar_SMTEncoding_Term.unboxReal - y in - (uu___48, - uu___49) in - FStar_SMTEncoding_Util.mkAdd - uu___47 in - FStar_SMTEncoding_Term.boxReal - uu___46 in - quant Eq xy - uu___45 in - (FStar_Parser_Const.real_op_Addition, - uu___44) in - let uu___44 = - let uu___45 = - let uu___46 = - let uu___47 = - let uu___48 - = - let uu___49 - = - let uu___50 - = - FStar_SMTEncoding_Term.unboxReal - x in - let uu___51 - = - FStar_SMTEncoding_Term.unboxReal - y in - (uu___50, - uu___51) in - FStar_SMTEncoding_Util.mkMul - uu___49 in - FStar_SMTEncoding_Term.boxReal - uu___48 in - quant Eq xy - uu___47 in - (FStar_Parser_Const.real_op_Multiply, - uu___46) in - let uu___46 = - let uu___47 = - let uu___48 = - let uu___49 - = - let uu___50 - = - let uu___51 - = - let uu___52 - = - let uu___53 - = - FStar_SMTEncoding_Term.unboxReal - y in - let uu___54 - = - FStar_SMTEncoding_Util.mkReal - "0" in - (uu___53, - uu___54) in - FStar_SMTEncoding_Util.mkEq - uu___52 in - FStar_SMTEncoding_Util.mkNot - uu___51 in - FStar_Pervasives_Native.Some - uu___50 in - let uu___50 - = - let uu___51 - = - let uu___52 - = - let uu___53 - = - FStar_SMTEncoding_Term.unboxReal - x in - let uu___54 - = - FStar_SMTEncoding_Term.unboxReal - y in - (uu___53, - uu___54) in - FStar_SMTEncoding_Util.mkRealDiv - uu___52 in - FStar_SMTEncoding_Term.boxReal - uu___51 in - quant_with_pre - Eq xy - uu___49 - uu___50 in - (FStar_Parser_Const.real_op_Division, - uu___48) in - let uu___48 = - let uu___49 = - let uu___50 - = - let uu___51 - = - let uu___52 - = - let uu___53 - = - FStar_SMTEncoding_Term.unboxInt - x in - FStar_SMTEncoding_Term.mkRealOfInt - uu___53 - FStar_Compiler_Range_Type.dummyRange in - FStar_SMTEncoding_Term.boxReal - uu___52 in - quant Eq - qx - uu___51 in - (FStar_Parser_Const.real_of_int, - uu___50) in - [uu___49] in - uu___47 :: - uu___48 in - uu___45 :: - uu___46 in - uu___43 :: uu___44 in - uu___41 :: uu___42 in - uu___39 :: uu___40 in - uu___37 :: uu___38 in - uu___35 :: uu___36 in - uu___33 :: uu___34 in - uu___31 :: uu___32 in - uu___29 :: uu___30 in - uu___27 :: uu___28 in - uu___25 :: uu___26 in - uu___23 :: uu___24 in - uu___21 :: uu___22 in - uu___19 :: uu___20 in - uu___17 :: uu___18 in - uu___15 :: uu___16 in - uu___13 :: uu___14 in - uu___11 :: uu___12 in - uu___9 :: uu___10 in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - let mk l v = - let uu___3 = - let uu___4 = - FStar_Compiler_List.find - (fun uu___5 -> - match uu___5 with - | (l', uu___6) -> FStar_Ident.lid_equals l l') - prims1 in - FStar_Compiler_Option.map - (fun uu___5 -> - match uu___5 with - | (uu___6, b) -> - let uu___7 = FStar_Ident.range_of_lid l in - b uu___7 v) uu___4 in - FStar_Compiler_Option.get uu___3 in - let is l = - FStar_Compiler_Util.for_some - (fun uu___3 -> - match uu___3 with - | (l', uu___4) -> FStar_Ident.lid_equals l l') prims1 in - { mk; is })) -let (pretype_axiom : - Prims.bool -> - FStar_Compiler_Range_Type.range -> - FStar_SMTEncoding_Env.env_t -> - FStar_SMTEncoding_Term.term -> - FStar_SMTEncoding_Term.fv Prims.list -> FStar_SMTEncoding_Term.decl) - = - fun term_constr_eq -> - fun rng -> - fun env -> - fun tapp -> - fun vars -> - let uu___ = - FStar_SMTEncoding_Env.fresh_fvar - env.FStar_SMTEncoding_Env.current_module_name "x" - FStar_SMTEncoding_Term.Term_sort in - match uu___ with - | (xxsym, xx) -> - let uu___1 = - FStar_SMTEncoding_Env.fresh_fvar - env.FStar_SMTEncoding_Env.current_module_name "f" - FStar_SMTEncoding_Term.Fuel_sort in - (match uu___1 with - | (ffsym, ff) -> - let xx_has_type = - FStar_SMTEncoding_Term.mk_HasTypeFuel ff xx tapp in - let tapp_hash = FStar_SMTEncoding_Term.hash_of_term tapp in - let module_name = - env.FStar_SMTEncoding_Env.current_module_name in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_SMTEncoding_Term.mk_fv - (xxsym, FStar_SMTEncoding_Term.Term_sort) in - let uu___7 = - let uu___8 = - FStar_SMTEncoding_Term.mk_fv - (ffsym, FStar_SMTEncoding_Term.Fuel_sort) in - uu___8 :: vars in - uu___6 :: uu___7 in - let uu___6 = - let uu___7 = - let uu___8 = - if term_constr_eq - then - let uu___9 = - let uu___10 = - FStar_SMTEncoding_Util.mkApp - ("Term_constr_id", [tapp]) in - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - FStar_SMTEncoding_Util.mkApp - ("PreType", [xx]) in - [uu___14] in - ("Term_constr_id", uu___13) in - FStar_SMTEncoding_Util.mkApp uu___12 in - (uu___10, uu___11) in - FStar_SMTEncoding_Util.mkEq uu___9 - else - (let uu___10 = - let uu___11 = - FStar_SMTEncoding_Util.mkApp - ("PreType", [xx]) in - (tapp, uu___11) in - FStar_SMTEncoding_Util.mkEq uu___10) in - (xx_has_type, uu___8) in - FStar_SMTEncoding_Util.mkImp uu___7 in - ([[xx_has_type]], uu___5, uu___6) in - FStar_SMTEncoding_Term.mkForall rng uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Compiler_Util.digest_of_string tapp_hash in - Prims.strcat "_pretyping_" uu___7 in - Prims.strcat module_name uu___6 in - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.mk_unique - uu___5 in - (uu___3, (FStar_Pervasives_Native.Some "pretyping"), - uu___4) in - FStar_SMTEncoding_Util.mkAssume uu___2) -let (primitive_type_axioms : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident -> - Prims.string -> - FStar_SMTEncoding_Term.term -> FStar_SMTEncoding_Term.decl Prims.list) - = - let xx = - FStar_SMTEncoding_Term.mk_fv ("x", FStar_SMTEncoding_Term.Term_sort) in - let x = FStar_SMTEncoding_Util.mkFreeV xx in - let yy = - FStar_SMTEncoding_Term.mk_fv ("y", FStar_SMTEncoding_Term.Term_sort) in - let y = FStar_SMTEncoding_Util.mkFreeV yy in - let mkForall_fuel env = - let uu___ = - let uu___1 = FStar_TypeChecker_Env.current_module env in - FStar_Ident.string_of_lid uu___1 in - FStar_SMTEncoding_EncodeTerm.mkForall_fuel uu___ in - let mk_unit env nm tt = - let typing_pred = FStar_SMTEncoding_Term.mk_HasType x tt in - let uu___ = - let uu___1 = - let uu___2 = - FStar_SMTEncoding_Term.mk_HasType - FStar_SMTEncoding_Term.mk_Term_unit tt in - (uu___2, (FStar_Pervasives_Native.Some "unit typing"), "unit_typing") in - FStar_SMTEncoding_Util.mkAssume uu___1 in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_SMTEncoding_Util.mkEq - (x, FStar_SMTEncoding_Term.mk_Term_unit) in - (typing_pred, uu___8) in - FStar_SMTEncoding_Util.mkImp uu___7 in - ([[typing_pred]], [xx], uu___6) in - let uu___6 = - let uu___7 = FStar_TypeChecker_Env.get_range env in - let uu___8 = mkForall_fuel env in uu___8 uu___7 in - uu___6 uu___5 in - (uu___4, (FStar_Pervasives_Native.Some "unit inversion"), - "unit_inversion") in - FStar_SMTEncoding_Util.mkAssume uu___3 in - [uu___2] in - uu___ :: uu___1 in - let mk_bool env nm tt = - let typing_pred = FStar_SMTEncoding_Term.mk_HasType x tt in - let bb = - FStar_SMTEncoding_Term.mk_fv ("b", FStar_SMTEncoding_Term.Bool_sort) in - let b = FStar_SMTEncoding_Util.mkFreeV bb in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_TypeChecker_Env.get_range env in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = FStar_SMTEncoding_Term.boxBool b in [uu___7] in - [uu___6] in - let uu___6 = - let uu___7 = FStar_SMTEncoding_Term.boxBool b in - FStar_SMTEncoding_Term.mk_HasType uu___7 tt in - (uu___5, [bb], uu___6) in - FStar_SMTEncoding_Term.mkForall uu___3 uu___4 in - (uu___2, (FStar_Pervasives_Native.Some "bool typing"), "bool_typing") in - FStar_SMTEncoding_Util.mkAssume uu___1 in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_SMTEncoding_Term.mk_tester - (FStar_Pervasives_Native.fst - FStar_SMTEncoding_Term.boxBoolFun) x in - (typing_pred, uu___8) in - FStar_SMTEncoding_Util.mkImp uu___7 in - ([[typing_pred]], [xx], uu___6) in - let uu___6 = - let uu___7 = FStar_TypeChecker_Env.get_range env in - let uu___8 = mkForall_fuel env in uu___8 uu___7 in - uu___6 uu___5 in - (uu___4, (FStar_Pervasives_Native.Some "bool inversion"), - "bool_inversion") in - FStar_SMTEncoding_Util.mkAssume uu___3 in - [uu___2] in - uu___ :: uu___1 in - let mk_int env nm tt = - let lex_t = - let uu___ = - let uu___1 = - let uu___2 = FStar_Ident.string_of_lid FStar_Parser_Const.lex_t_lid in - (uu___2, FStar_SMTEncoding_Term.Term_sort) in - FStar_SMTEncoding_Term.mk_fv uu___1 in - FStar_SMTEncoding_Util.mkFreeV uu___ in - let typing_pred = FStar_SMTEncoding_Term.mk_HasType x tt in - let typing_pred_y = FStar_SMTEncoding_Term.mk_HasType y tt in - let aa = - FStar_SMTEncoding_Term.mk_fv ("a", FStar_SMTEncoding_Term.Int_sort) in - let a = FStar_SMTEncoding_Util.mkFreeV aa in - let bb = - FStar_SMTEncoding_Term.mk_fv ("b", FStar_SMTEncoding_Term.Int_sort) in - let b = FStar_SMTEncoding_Util.mkFreeV bb in - let precedes_y_x = - let uu___ = - FStar_SMTEncoding_Util.mkApp ("Prims.precedes", [lex_t; lex_t; y; x]) in - FStar_SMTEncoding_Term.mk_Valid uu___ in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_TypeChecker_Env.get_range env in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = FStar_SMTEncoding_Term.boxInt b in [uu___7] in - [uu___6] in - let uu___6 = - let uu___7 = FStar_SMTEncoding_Term.boxInt b in - FStar_SMTEncoding_Term.mk_HasType uu___7 tt in - (uu___5, [bb], uu___6) in - FStar_SMTEncoding_Term.mkForall uu___3 uu___4 in - (uu___2, (FStar_Pervasives_Native.Some "int typing"), "int_typing") in - FStar_SMTEncoding_Util.mkAssume uu___1 in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_SMTEncoding_Term.mk_tester - (FStar_Pervasives_Native.fst - FStar_SMTEncoding_Term.boxIntFun) x in - (typing_pred, uu___8) in - FStar_SMTEncoding_Util.mkImp uu___7 in - ([[typing_pred]], [xx], uu___6) in - let uu___6 = - let uu___7 = FStar_TypeChecker_Env.get_range env in - let uu___8 = mkForall_fuel env in uu___8 uu___7 in - uu___6 uu___5 in - (uu___4, (FStar_Pervasives_Native.Some "int inversion"), - "int_inversion") in - FStar_SMTEncoding_Util.mkAssume uu___3 in - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = - FStar_SMTEncoding_Term.unboxInt x in - let uu___17 = - FStar_SMTEncoding_Util.mkInteger' - Prims.int_zero in - (uu___16, uu___17) in - FStar_SMTEncoding_Util.mkGT uu___15 in - let uu___15 = - let uu___16 = - let uu___17 = - let uu___18 = - FStar_SMTEncoding_Term.unboxInt y in - let uu___19 = - FStar_SMTEncoding_Util.mkInteger' - Prims.int_zero in - (uu___18, uu___19) in - FStar_SMTEncoding_Util.mkGTE uu___17 in - let uu___17 = - let uu___18 = - let uu___19 = - let uu___20 = - FStar_SMTEncoding_Term.unboxInt y in - let uu___21 = - FStar_SMTEncoding_Term.unboxInt x in - (uu___20, uu___21) in - FStar_SMTEncoding_Util.mkLT uu___19 in - [uu___18] in - uu___16 :: uu___17 in - uu___14 :: uu___15 in - typing_pred_y :: uu___13 in - typing_pred :: uu___12 in - FStar_SMTEncoding_Util.mk_and_l uu___11 in - (uu___10, precedes_y_x) in - FStar_SMTEncoding_Util.mkImp uu___9 in - ([[typing_pred; typing_pred_y; precedes_y_x]], [xx; yy], - uu___8) in - let uu___8 = - let uu___9 = FStar_TypeChecker_Env.get_range env in - let uu___10 = mkForall_fuel env in uu___10 uu___9 in - uu___8 uu___7 in - (uu___6, - (FStar_Pervasives_Native.Some - "well-founded ordering on nat (alt)"), - "well-founded-ordering-on-nat") in - FStar_SMTEncoding_Util.mkAssume uu___5 in - [uu___4] in - uu___2 :: uu___3 in - uu___ :: uu___1 in - let mk_real env nm tt = - let typing_pred = FStar_SMTEncoding_Term.mk_HasType x tt in - let aa = - FStar_SMTEncoding_Term.mk_fv - ("a", (FStar_SMTEncoding_Term.Sort "Real")) in - let a = FStar_SMTEncoding_Util.mkFreeV aa in - let bb = - FStar_SMTEncoding_Term.mk_fv - ("b", (FStar_SMTEncoding_Term.Sort "Real")) in - let b = FStar_SMTEncoding_Util.mkFreeV bb in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_TypeChecker_Env.get_range env in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = FStar_SMTEncoding_Term.boxReal b in [uu___7] in - [uu___6] in - let uu___6 = - let uu___7 = FStar_SMTEncoding_Term.boxReal b in - FStar_SMTEncoding_Term.mk_HasType uu___7 tt in - (uu___5, [bb], uu___6) in - FStar_SMTEncoding_Term.mkForall uu___3 uu___4 in - (uu___2, (FStar_Pervasives_Native.Some "real typing"), "real_typing") in - FStar_SMTEncoding_Util.mkAssume uu___1 in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_SMTEncoding_Term.mk_tester - (FStar_Pervasives_Native.fst - FStar_SMTEncoding_Term.boxRealFun) x in - (typing_pred, uu___8) in - FStar_SMTEncoding_Util.mkImp uu___7 in - ([[typing_pred]], [xx], uu___6) in - let uu___6 = - let uu___7 = FStar_TypeChecker_Env.get_range env in - let uu___8 = mkForall_fuel env in uu___8 uu___7 in - uu___6 uu___5 in - (uu___4, (FStar_Pervasives_Native.Some "real inversion"), - "real_inversion") in - FStar_SMTEncoding_Util.mkAssume uu___3 in - [uu___2] in - uu___ :: uu___1 in - let mk_str env nm tt = - let typing_pred = FStar_SMTEncoding_Term.mk_HasType x tt in - let bb = - FStar_SMTEncoding_Term.mk_fv ("b", FStar_SMTEncoding_Term.String_sort) in - let b = FStar_SMTEncoding_Util.mkFreeV bb in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_TypeChecker_Env.get_range env in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = FStar_SMTEncoding_Term.boxString b in [uu___7] in - [uu___6] in - let uu___6 = - let uu___7 = FStar_SMTEncoding_Term.boxString b in - FStar_SMTEncoding_Term.mk_HasType uu___7 tt in - (uu___5, [bb], uu___6) in - FStar_SMTEncoding_Term.mkForall uu___3 uu___4 in - (uu___2, (FStar_Pervasives_Native.Some "string typing"), - "string_typing") in - FStar_SMTEncoding_Util.mkAssume uu___1 in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_SMTEncoding_Term.mk_tester - (FStar_Pervasives_Native.fst - FStar_SMTEncoding_Term.boxStringFun) x in - (typing_pred, uu___8) in - FStar_SMTEncoding_Util.mkImp uu___7 in - ([[typing_pred]], [xx], uu___6) in - let uu___6 = - let uu___7 = FStar_TypeChecker_Env.get_range env in - let uu___8 = mkForall_fuel env in uu___8 uu___7 in - uu___6 uu___5 in - (uu___4, (FStar_Pervasives_Native.Some "string inversion"), - "string_inversion") in - FStar_SMTEncoding_Util.mkAssume uu___3 in - [uu___2] in - uu___ :: uu___1 in - let mk_true_interp env nm true_tm = - let valid = FStar_SMTEncoding_Util.mkApp ("Valid", [true_tm]) in - let uu___ = - FStar_SMTEncoding_Util.mkAssume - (valid, (FStar_Pervasives_Native.Some "True interpretation"), - "true_interp") in - [uu___] in - let mk_false_interp env nm false_tm = - let valid = FStar_SMTEncoding_Util.mkApp ("Valid", [false_tm]) in - let uu___ = - let uu___1 = - let uu___2 = - FStar_SMTEncoding_Util.mkIff - (FStar_SMTEncoding_Util.mkFalse, valid) in - (uu___2, (FStar_Pervasives_Native.Some "False interpretation"), - "false_interp") in - FStar_SMTEncoding_Util.mkAssume uu___1 in - [uu___] in - let mk_and_interp env conj uu___ = - let aa = - FStar_SMTEncoding_Term.mk_fv ("a", FStar_SMTEncoding_Term.Term_sort) in - let bb = - FStar_SMTEncoding_Term.mk_fv ("b", FStar_SMTEncoding_Term.Term_sort) in - let a = FStar_SMTEncoding_Util.mkFreeV aa in - let b = FStar_SMTEncoding_Util.mkFreeV bb in - let l_and_a_b = FStar_SMTEncoding_Util.mkApp (conj, [a; b]) in - let valid = FStar_SMTEncoding_Util.mkApp ("Valid", [l_and_a_b]) in - let valid_a = FStar_SMTEncoding_Util.mkApp ("Valid", [a]) in - let valid_b = FStar_SMTEncoding_Util.mkApp ("Valid", [b]) in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_TypeChecker_Env.get_range env in - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = FStar_SMTEncoding_Util.mkAnd (valid_a, valid_b) in - (uu___8, valid) in - FStar_SMTEncoding_Util.mkIff uu___7 in - ([[l_and_a_b]], [aa; bb], uu___6) in - FStar_SMTEncoding_Term.mkForall uu___4 uu___5 in - (uu___3, (FStar_Pervasives_Native.Some "/\\ interpretation"), - "l_and-interp") in - FStar_SMTEncoding_Util.mkAssume uu___2 in - [uu___1] in - let mk_or_interp env disj uu___ = - let aa = - FStar_SMTEncoding_Term.mk_fv ("a", FStar_SMTEncoding_Term.Term_sort) in - let bb = - FStar_SMTEncoding_Term.mk_fv ("b", FStar_SMTEncoding_Term.Term_sort) in - let a = FStar_SMTEncoding_Util.mkFreeV aa in - let b = FStar_SMTEncoding_Util.mkFreeV bb in - let l_or_a_b = FStar_SMTEncoding_Util.mkApp (disj, [a; b]) in - let valid = FStar_SMTEncoding_Util.mkApp ("Valid", [l_or_a_b]) in - let valid_a = FStar_SMTEncoding_Util.mkApp ("Valid", [a]) in - let valid_b = FStar_SMTEncoding_Util.mkApp ("Valid", [b]) in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_TypeChecker_Env.get_range env in - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = FStar_SMTEncoding_Util.mkOr (valid_a, valid_b) in - (uu___8, valid) in - FStar_SMTEncoding_Util.mkIff uu___7 in - ([[l_or_a_b]], [aa; bb], uu___6) in - FStar_SMTEncoding_Term.mkForall uu___4 uu___5 in - (uu___3, (FStar_Pervasives_Native.Some "\\/ interpretation"), - "l_or-interp") in - FStar_SMTEncoding_Util.mkAssume uu___2 in - [uu___1] in - let mk_eq2_interp env eq2 tt = - let aa = - FStar_SMTEncoding_Term.mk_fv ("a", FStar_SMTEncoding_Term.Term_sort) in - let xx1 = - FStar_SMTEncoding_Term.mk_fv ("x", FStar_SMTEncoding_Term.Term_sort) in - let yy1 = - FStar_SMTEncoding_Term.mk_fv ("y", FStar_SMTEncoding_Term.Term_sort) in - let a = FStar_SMTEncoding_Util.mkFreeV aa in - let x1 = FStar_SMTEncoding_Util.mkFreeV xx1 in - let y1 = FStar_SMTEncoding_Util.mkFreeV yy1 in - let eq2_x_y = FStar_SMTEncoding_Util.mkApp (eq2, [a; x1; y1]) in - let valid = FStar_SMTEncoding_Util.mkApp ("Valid", [eq2_x_y]) in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_TypeChecker_Env.get_range env in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = FStar_SMTEncoding_Util.mkEq (x1, y1) in - (uu___7, valid) in - FStar_SMTEncoding_Util.mkIff uu___6 in - ([[eq2_x_y]], [aa; xx1; yy1], uu___5) in - FStar_SMTEncoding_Term.mkForall uu___3 uu___4 in - (uu___2, (FStar_Pervasives_Native.Some "Eq2 interpretation"), - "eq2-interp") in - FStar_SMTEncoding_Util.mkAssume uu___1 in - [uu___] in - let mk_imp_interp env imp tt = - let aa = - FStar_SMTEncoding_Term.mk_fv ("a", FStar_SMTEncoding_Term.Term_sort) in - let bb = - FStar_SMTEncoding_Term.mk_fv ("b", FStar_SMTEncoding_Term.Term_sort) in - let a = FStar_SMTEncoding_Util.mkFreeV aa in - let b = FStar_SMTEncoding_Util.mkFreeV bb in - let l_imp_a_b = FStar_SMTEncoding_Util.mkApp (imp, [a; b]) in - let valid = FStar_SMTEncoding_Util.mkApp ("Valid", [l_imp_a_b]) in - let valid_a = FStar_SMTEncoding_Util.mkApp ("Valid", [a]) in - let valid_b = FStar_SMTEncoding_Util.mkApp ("Valid", [b]) in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_TypeChecker_Env.get_range env in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = FStar_SMTEncoding_Util.mkImp (valid_a, valid_b) in - (uu___7, valid) in - FStar_SMTEncoding_Util.mkIff uu___6 in - ([[l_imp_a_b]], [aa; bb], uu___5) in - FStar_SMTEncoding_Term.mkForall uu___3 uu___4 in - (uu___2, (FStar_Pervasives_Native.Some "==> interpretation"), - "l_imp-interp") in - FStar_SMTEncoding_Util.mkAssume uu___1 in - [uu___] in - let mk_iff_interp env iff tt = - let aa = - FStar_SMTEncoding_Term.mk_fv ("a", FStar_SMTEncoding_Term.Term_sort) in - let bb = - FStar_SMTEncoding_Term.mk_fv ("b", FStar_SMTEncoding_Term.Term_sort) in - let a = FStar_SMTEncoding_Util.mkFreeV aa in - let b = FStar_SMTEncoding_Util.mkFreeV bb in - let l_iff_a_b = FStar_SMTEncoding_Util.mkApp (iff, [a; b]) in - let valid = FStar_SMTEncoding_Util.mkApp ("Valid", [l_iff_a_b]) in - let valid_a = FStar_SMTEncoding_Util.mkApp ("Valid", [a]) in - let valid_b = FStar_SMTEncoding_Util.mkApp ("Valid", [b]) in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_TypeChecker_Env.get_range env in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = FStar_SMTEncoding_Util.mkIff (valid_a, valid_b) in - (uu___7, valid) in - FStar_SMTEncoding_Util.mkIff uu___6 in - ([[l_iff_a_b]], [aa; bb], uu___5) in - FStar_SMTEncoding_Term.mkForall uu___3 uu___4 in - (uu___2, (FStar_Pervasives_Native.Some "<==> interpretation"), - "l_iff-interp") in - FStar_SMTEncoding_Util.mkAssume uu___1 in - [uu___] in - let mk_not_interp env l_not tt = - let aa = - FStar_SMTEncoding_Term.mk_fv ("a", FStar_SMTEncoding_Term.Term_sort) in - let a = FStar_SMTEncoding_Util.mkFreeV aa in - let l_not_a = FStar_SMTEncoding_Util.mkApp (l_not, [a]) in - let valid = FStar_SMTEncoding_Util.mkApp ("Valid", [l_not_a]) in - let not_valid_a = - let uu___ = FStar_SMTEncoding_Util.mkApp ("Valid", [a]) in - FStar_SMTEncoding_Util.mkNot uu___ in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_TypeChecker_Env.get_range env in - let uu___4 = - let uu___5 = FStar_SMTEncoding_Util.mkIff (not_valid_a, valid) in - ([[l_not_a]], [aa], uu___5) in - FStar_SMTEncoding_Term.mkForall uu___3 uu___4 in - (uu___2, (FStar_Pervasives_Native.Some "not interpretation"), - "l_not-interp") in - FStar_SMTEncoding_Util.mkAssume uu___1 in - [uu___] in - let mk_range_interp env range tt = - let range_ty = FStar_SMTEncoding_Util.mkApp (range, []) in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_SMTEncoding_Term.mk_Range_const () in - FStar_SMTEncoding_Term.mk_HasTypeZ uu___3 range_ty in - let uu___3 = - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.mk_unique - "typing_range_const" in - (uu___2, (FStar_Pervasives_Native.Some "Range_const typing"), uu___3) in - FStar_SMTEncoding_Util.mkAssume uu___1 in - [uu___] in - let mk_inversion_axiom env inversion tt = - let tt1 = - FStar_SMTEncoding_Term.mk_fv ("t", FStar_SMTEncoding_Term.Term_sort) in - let t = FStar_SMTEncoding_Util.mkFreeV tt1 in - let xx1 = - FStar_SMTEncoding_Term.mk_fv ("x", FStar_SMTEncoding_Term.Term_sort) in - let x1 = FStar_SMTEncoding_Util.mkFreeV xx1 in - let inversion_t = FStar_SMTEncoding_Util.mkApp (inversion, [t]) in - let valid = FStar_SMTEncoding_Util.mkApp ("Valid", [inversion_t]) in - let body = - let hastypeZ = FStar_SMTEncoding_Term.mk_HasTypeZ x1 t in - let hastypeS = - let uu___ = FStar_SMTEncoding_Term.n_fuel Prims.int_one in - FStar_SMTEncoding_Term.mk_HasTypeFuel uu___ x1 t in - let uu___ = FStar_TypeChecker_Env.get_range env in - let uu___1 = - let uu___2 = FStar_SMTEncoding_Util.mkImp (hastypeZ, hastypeS) in - ([[hastypeZ]], [xx1], uu___2) in - FStar_SMTEncoding_Term.mkForall uu___ uu___1 in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_TypeChecker_Env.get_range env in - let uu___4 = - let uu___5 = FStar_SMTEncoding_Util.mkImp (valid, body) in - ([[inversion_t]], [tt1], uu___5) in - FStar_SMTEncoding_Term.mkForall uu___3 uu___4 in - (uu___2, (FStar_Pervasives_Native.Some "inversion interpretation"), - "inversion-interp") in - FStar_SMTEncoding_Util.mkAssume uu___1 in - [uu___] in - let prims1 = - [(FStar_Parser_Const.unit_lid, mk_unit); - (FStar_Parser_Const.bool_lid, mk_bool); - (FStar_Parser_Const.int_lid, mk_int); - (FStar_Parser_Const.real_lid, mk_real); - (FStar_Parser_Const.string_lid, mk_str); - (FStar_Parser_Const.true_lid, mk_true_interp); - (FStar_Parser_Const.false_lid, mk_false_interp); - (FStar_Parser_Const.and_lid, mk_and_interp); - (FStar_Parser_Const.or_lid, mk_or_interp); - (FStar_Parser_Const.eq2_lid, mk_eq2_interp); - (FStar_Parser_Const.imp_lid, mk_imp_interp); - (FStar_Parser_Const.iff_lid, mk_iff_interp); - (FStar_Parser_Const.not_lid, mk_not_interp); - (FStar_Parser_Const.range_lid, mk_range_interp); - (FStar_Parser_Const.inversion_lid, mk_inversion_axiom)] in - fun env -> - fun t -> - fun s -> - fun tt -> - let uu___ = - FStar_Compiler_Util.find_opt - (fun uu___1 -> - match uu___1 with - | (l, uu___2) -> FStar_Ident.lid_equals l t) prims1 in - match uu___ with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some (uu___1, f) -> f env s tt -let (encode_smt_lemma : - FStar_SMTEncoding_Env.env_t -> - FStar_Syntax_Syntax.fv -> - FStar_Syntax_Syntax.typ -> FStar_SMTEncoding_Term.decls_elt Prims.list) - = - fun env -> - fun fv -> - fun t -> - let lid = (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - let uu___ = - FStar_SMTEncoding_EncodeTerm.encode_function_type_as_formula t env in - match uu___ with - | (form, decls) -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = FStar_Ident.string_of_lid lid in - Prims.strcat "Lemma: " uu___7 in - FStar_Pervasives_Native.Some uu___6 in - let uu___6 = - let uu___7 = FStar_Ident.string_of_lid lid in - Prims.strcat "lemma_" uu___7 in - (form, uu___5, uu___6) in - FStar_SMTEncoding_Util.mkAssume uu___4 in - [uu___3] in - FStar_SMTEncoding_Term.mk_decls_trivial uu___2 in - FStar_Compiler_List.op_At decls uu___1 -let (encode_free_var : - Prims.bool -> - FStar_SMTEncoding_Env.env_t -> - FStar_Syntax_Syntax.fv -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.qualifier Prims.list -> - (FStar_SMTEncoding_Term.decls_t * FStar_SMTEncoding_Env.env_t)) - = - fun uninterpreted -> - fun env -> - fun fv -> - fun tt -> - fun t_norm -> - fun quals -> - let lid = - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - let uu___ = - ((let uu___1 = - (FStar_Syntax_Util.is_pure_or_ghost_function t_norm) || - (FStar_SMTEncoding_Util.is_smt_reifiable_function - env.FStar_SMTEncoding_Env.tcenv t_norm) in - Prims.op_Negation uu___1) || - (FStar_Syntax_Util.is_lemma t_norm)) - || uninterpreted in - if uu___ - then - let arg_sorts = - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress t_norm in - uu___2.FStar_Syntax_Syntax.n in - match uu___1 with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = binders; - FStar_Syntax_Syntax.comp = uu___2;_} - -> - FStar_Compiler_List.map - (fun uu___3 -> FStar_SMTEncoding_Term.Term_sort) - binders - | uu___2 -> [] in - let arity = FStar_Compiler_List.length arg_sorts in - let uu___1 = - FStar_SMTEncoding_Env.new_term_constant_and_tok_from_lid - env lid arity in - match uu___1 with - | (vname, vtok, env1) -> - let d = - FStar_SMTEncoding_Term.DeclFun - (vname, arg_sorts, FStar_SMTEncoding_Term.Term_sort, - (FStar_Pervasives_Native.Some - "Uninterpreted function symbol for impure function")) in - let dd = - FStar_SMTEncoding_Term.DeclFun - (vtok, [], FStar_SMTEncoding_Term.Term_sort, - (FStar_Pervasives_Native.Some - "Uninterpreted name for impure function")) in - let uu___2 = - FStar_SMTEncoding_Term.mk_decls_trivial [d; dd] in - (uu___2, env1) - else - (let uu___2 = prims.is lid in - if uu___2 - then - let vname = - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.new_fvar - lid in - let uu___3 = prims.mk lid vname in - match uu___3 with - | (tok, arity, definition) -> - let env1 = - FStar_SMTEncoding_Env.push_free_var env lid arity - vname (FStar_Pervasives_Native.Some tok) in - let uu___4 = - FStar_SMTEncoding_Term.mk_decls_trivial definition in - (uu___4, env1) - else - (let encode_non_total_function_typ = - let uu___4 = FStar_Ident.nsstr lid in uu___4 <> "Prims" in - let uu___4 = - let uu___5 = - FStar_SMTEncoding_EncodeTerm.curried_arrow_formals_comp - t_norm in - match uu___5 with - | (args, comp) -> - let tcenv_comp = - FStar_TypeChecker_Env.push_binders - env.FStar_SMTEncoding_Env.tcenv args in - let comp1 = - let uu___6 = - FStar_SMTEncoding_Util.is_smt_reifiable_comp - env.FStar_SMTEncoding_Env.tcenv comp in - if uu___6 - then - let uu___7 = - FStar_TypeChecker_Env.reify_comp - { - FStar_TypeChecker_Env.solver = - (tcenv_comp.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (tcenv_comp.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (tcenv_comp.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (tcenv_comp.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (tcenv_comp.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (tcenv_comp.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (tcenv_comp.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (tcenv_comp.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (tcenv_comp.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (tcenv_comp.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (tcenv_comp.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (tcenv_comp.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (tcenv_comp.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (tcenv_comp.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (tcenv_comp.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (tcenv_comp.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (tcenv_comp.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (tcenv_comp.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = true; - FStar_TypeChecker_Env.lax_universes = - (tcenv_comp.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (tcenv_comp.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (tcenv_comp.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (tcenv_comp.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (tcenv_comp.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (tcenv_comp.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (tcenv_comp.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (tcenv_comp.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (tcenv_comp.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (tcenv_comp.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (tcenv_comp.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (tcenv_comp.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (tcenv_comp.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (tcenv_comp.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (tcenv_comp.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (tcenv_comp.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (tcenv_comp.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (tcenv_comp.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (tcenv_comp.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (tcenv_comp.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (tcenv_comp.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (tcenv_comp.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (tcenv_comp.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (tcenv_comp.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (tcenv_comp.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (tcenv_comp.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (tcenv_comp.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (tcenv_comp.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (tcenv_comp.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (tcenv_comp.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (tcenv_comp.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (tcenv_comp.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (tcenv_comp.FStar_TypeChecker_Env.missing_decl) - } comp FStar_Syntax_Syntax.U_unknown in - FStar_Syntax_Syntax.mk_Total uu___7 - else comp in - if encode_non_total_function_typ - then - let uu___6 = - FStar_TypeChecker_Util.pure_or_ghost_pre_and_post - tcenv_comp comp1 in - (args, uu___6) - else - (args, - (FStar_Pervasives_Native.None, - (FStar_Syntax_Util.comp_result comp1))) in - match uu___4 with - | (formals, (pre_opt, res_t)) -> - let mk_disc_proj_axioms guard encoded_res_t vapp vars - = - FStar_Compiler_List.collect - (fun uu___5 -> - match uu___5 with - | FStar_Syntax_Syntax.Discriminator d -> - let uu___6 = - FStar_Compiler_Util.prefix vars in - (match uu___6 with - | (uu___7, xxv) -> - let xx = - let uu___8 = - let uu___9 = - let uu___10 = - FStar_SMTEncoding_Term.fv_name - xxv in - (uu___10, - FStar_SMTEncoding_Term.Term_sort) in - FStar_SMTEncoding_Term.mk_fv - uu___9 in - FStar_SMTEncoding_Util.mkFreeV - uu___8 in - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Syntax_Syntax.range_of_fv - fv in - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = - let uu___17 = - let uu___18 = - FStar_Ident.string_of_lid - d in - FStar_SMTEncoding_Env.escape - uu___18 in - FStar_SMTEncoding_Term.mk_tester - uu___17 xx in - FStar_SMTEncoding_Term.boxBool - uu___16 in - (vapp, uu___15) in - FStar_SMTEncoding_Util.mkEq - uu___14 in - ([[vapp]], vars, uu___13) in - FStar_SMTEncoding_Term.mkForall - uu___11 uu___12 in - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Ident.string_of_lid d in - FStar_SMTEncoding_Env.escape - uu___13 in - Prims.strcat "disc_equation_" - uu___12 in - (uu___10, - (FStar_Pervasives_Native.Some - "Discriminator equation"), - uu___11) in - FStar_SMTEncoding_Util.mkAssume - uu___9 in - [uu___8]) - | FStar_Syntax_Syntax.Projector (d, f) -> - let uu___6 = - FStar_Compiler_Util.prefix vars in - (match uu___6 with - | (uu___7, xxv) -> - let xx = - let uu___8 = - let uu___9 = - let uu___10 = - FStar_SMTEncoding_Term.fv_name - xxv in - (uu___10, - FStar_SMTEncoding_Term.Term_sort) in - FStar_SMTEncoding_Term.mk_fv - uu___9 in - FStar_SMTEncoding_Util.mkFreeV - uu___8 in - let f1 = - { - FStar_Syntax_Syntax.ppname = f; - FStar_Syntax_Syntax.index = - Prims.int_zero; - FStar_Syntax_Syntax.sort = - FStar_Syntax_Syntax.tun - } in - let tp_name = - FStar_SMTEncoding_Env.mk_term_projector_name - d f1 in - let prim_app = - FStar_SMTEncoding_Util.mkApp - (tp_name, [xx]) in - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Syntax_Syntax.range_of_fv - fv in - let uu___12 = - let uu___13 = - FStar_SMTEncoding_Util.mkEq - (vapp, prim_app) in - ([[vapp]], vars, uu___13) in - FStar_SMTEncoding_Term.mkForall - uu___11 uu___12 in - (uu___10, - (FStar_Pervasives_Native.Some - "Projector equation"), - (Prims.strcat "proj_equation_" - tp_name)) in - FStar_SMTEncoding_Util.mkAssume - uu___9 in - [uu___8]) - | uu___6 -> []) quals in - let uu___5 = - FStar_SMTEncoding_EncodeTerm.encode_binders - FStar_Pervasives_Native.None formals env in - (match uu___5 with - | (vars, guards, env', decls1, uu___6) -> - let uu___7 = - match pre_opt with - | FStar_Pervasives_Native.None -> - let uu___8 = - FStar_SMTEncoding_Util.mk_and_l guards in - (uu___8, decls1) - | FStar_Pervasives_Native.Some p -> - let uu___8 = - FStar_SMTEncoding_EncodeTerm.encode_formula - p env' in - (match uu___8 with - | (g, ds) -> - let uu___9 = - FStar_SMTEncoding_Util.mk_and_l (g - :: guards) in - (uu___9, - (FStar_Compiler_List.op_At decls1 - ds))) in - (match uu___7 with - | (guard, decls11) -> - let dummy_var = - FStar_SMTEncoding_Term.mk_fv - ("@dummy", - FStar_SMTEncoding_Term.dummy_sort) in - let dummy_tm = - FStar_SMTEncoding_Term.mkFreeV dummy_var - FStar_Compiler_Range_Type.dummyRange in - let should_thunk uu___8 = - let is_type t = - let uu___9 = - let uu___10 = - FStar_Syntax_Subst.compress t in - uu___10.FStar_Syntax_Syntax.n in - match uu___9 with - | FStar_Syntax_Syntax.Tm_type uu___10 - -> true - | uu___10 -> false in - let is_squash t = - let uu___9 = - FStar_Syntax_Util.head_and_args t in - match uu___9 with - | (head, uu___10) -> - let uu___11 = - let uu___12 = - FStar_Syntax_Util.un_uinst head in - uu___12.FStar_Syntax_Syntax.n in - (match uu___11 with - | FStar_Syntax_Syntax.Tm_fvar fv1 - -> - FStar_Syntax_Syntax.fv_eq_lid - fv1 - FStar_Parser_Const.squash_lid - | FStar_Syntax_Syntax.Tm_refine - { - FStar_Syntax_Syntax.b = - { - FStar_Syntax_Syntax.ppname - = uu___12; - FStar_Syntax_Syntax.index - = uu___13; - FStar_Syntax_Syntax.sort - = - { - FStar_Syntax_Syntax.n - = - FStar_Syntax_Syntax.Tm_fvar - fv1; - FStar_Syntax_Syntax.pos - = uu___14; - FStar_Syntax_Syntax.vars - = uu___15; - FStar_Syntax_Syntax.hash_code - = uu___16;_};_}; - FStar_Syntax_Syntax.phi = - uu___17;_} - -> - FStar_Syntax_Syntax.fv_eq_lid - fv1 - FStar_Parser_Const.unit_lid - | uu___12 -> false) in - (((let uu___9 = FStar_Ident.nsstr lid in - uu___9 <> "Prims") && - (Prims.op_Negation - (FStar_Compiler_List.contains - FStar_Syntax_Syntax.Logic quals))) - && - (let uu___9 = is_squash t_norm in - Prims.op_Negation uu___9)) - && - (let uu___9 = is_type t_norm in - Prims.op_Negation uu___9) in - let uu___8 = - match vars with - | [] when should_thunk () -> - (true, [dummy_var]) - | uu___9 -> (false, vars) in - (match uu___8 with - | (thunked, vars1) -> - let arity = - FStar_Compiler_List.length formals in - let uu___9 = - FStar_SMTEncoding_Env.new_term_constant_and_tok_from_lid_maybe_thunked - env lid arity thunked in - (match uu___9 with - | (vname, vtok_opt, env1) -> - let get_vtok uu___10 = - FStar_Compiler_Option.get - vtok_opt in - let vtok_tm = - match formals with - | [] when - Prims.op_Negation thunked - -> - FStar_SMTEncoding_Util.mkApp - (vname, []) - | [] when thunked -> - FStar_SMTEncoding_Util.mkApp - (vname, [dummy_tm]) - | uu___10 -> - let uu___11 = - let uu___12 = get_vtok () in - (uu___12, []) in - FStar_SMTEncoding_Util.mkApp - uu___11 in - let vtok_app = - FStar_SMTEncoding_EncodeTerm.mk_Apply - vtok_tm vars1 in - let vapp = - let uu___10 = - let uu___11 = - FStar_Compiler_List.map - FStar_SMTEncoding_Util.mkFreeV - vars1 in - (vname, uu___11) in - FStar_SMTEncoding_Util.mkApp - uu___10 in - let uu___10 = - let vname_decl = - let uu___11 = - let uu___12 = - FStar_Compiler_List.map - FStar_SMTEncoding_Term.fv_sort - vars1 in - (vname, uu___12, - FStar_SMTEncoding_Term.Term_sort, - FStar_Pervasives_Native.None) in - FStar_SMTEncoding_Term.DeclFun - uu___11 in - let uu___11 = - let env2 = - { - FStar_SMTEncoding_Env.bvar_bindings - = - (env1.FStar_SMTEncoding_Env.bvar_bindings); - FStar_SMTEncoding_Env.fvar_bindings - = - (env1.FStar_SMTEncoding_Env.fvar_bindings); - FStar_SMTEncoding_Env.depth - = - (env1.FStar_SMTEncoding_Env.depth); - FStar_SMTEncoding_Env.tcenv - = - (env1.FStar_SMTEncoding_Env.tcenv); - FStar_SMTEncoding_Env.warn - = - (env1.FStar_SMTEncoding_Env.warn); - FStar_SMTEncoding_Env.nolabels - = - (env1.FStar_SMTEncoding_Env.nolabels); - FStar_SMTEncoding_Env.use_zfuel_name - = - (env1.FStar_SMTEncoding_Env.use_zfuel_name); - FStar_SMTEncoding_Env.encode_non_total_function_typ - = - encode_non_total_function_typ; - FStar_SMTEncoding_Env.current_module_name - = - (env1.FStar_SMTEncoding_Env.current_module_name); - FStar_SMTEncoding_Env.encoding_quantifier - = - (env1.FStar_SMTEncoding_Env.encoding_quantifier); - FStar_SMTEncoding_Env.global_cache - = - (env1.FStar_SMTEncoding_Env.global_cache) - } in - let uu___12 = - let uu___13 = - FStar_SMTEncoding_EncodeTerm.head_normal - env2 tt in - Prims.op_Negation uu___13 in - if uu___12 - then - FStar_SMTEncoding_EncodeTerm.encode_term_pred - FStar_Pervasives_Native.None - tt env2 vtok_tm - else - FStar_SMTEncoding_EncodeTerm.encode_term_pred - FStar_Pervasives_Native.None - t_norm env2 vtok_tm in - match uu___11 with - | (tok_typing, decls2) -> - let uu___12 = - match vars1 with - | [] -> - let tok_typing1 = - FStar_SMTEncoding_Util.mkAssume - (tok_typing, - (FStar_Pervasives_Native.Some - "function token typing"), - (Prims.strcat - "function_token_typing_" - vname)) in - let uu___13 = - let uu___14 = - FStar_SMTEncoding_Term.mk_decls_trivial - [tok_typing1] in - FStar_Compiler_List.op_At - decls2 uu___14 in - let uu___14 = - let uu___15 = - let uu___16 = - FStar_SMTEncoding_Util.mkApp - (vname, []) in - FStar_Pervasives_Native.Some - uu___16 in - FStar_SMTEncoding_Env.push_free_var - env1 lid arity - vname uu___15 in - (uu___13, uu___14) - | uu___13 when thunked -> - (decls2, env1) - | uu___13 -> - let vtok = - get_vtok () in - let vtok_decl = - FStar_SMTEncoding_Term.DeclFun - (vtok, [], - FStar_SMTEncoding_Term.Term_sort, - FStar_Pervasives_Native.None) in - let name_tok_corr_formula - pat = - let uu___14 = - FStar_Syntax_Syntax.range_of_fv - fv in - let uu___15 = - let uu___16 = - FStar_SMTEncoding_Util.mkEq - (vtok_app, - vapp) in - ([[pat]], vars1, - uu___16) in - FStar_SMTEncoding_Term.mkForall - uu___14 uu___15 in - let name_tok_corr = - let uu___14 = - let uu___15 = - name_tok_corr_formula - vtok_app in - (uu___15, - (FStar_Pervasives_Native.Some - "Name-token correspondence"), - (Prims.strcat - "token_correspondence_" - vname)) in - FStar_SMTEncoding_Util.mkAssume - uu___14 in - let tok_typing1 = - let ff = - FStar_SMTEncoding_Term.mk_fv - ("ty", - FStar_SMTEncoding_Term.Term_sort) in - let f = - FStar_SMTEncoding_Util.mkFreeV - ff in - let vtok_app_r = - let uu___14 = - let uu___15 = - FStar_SMTEncoding_Term.mk_fv - (vtok, - FStar_SMTEncoding_Term.Term_sort) in - [uu___15] in - FStar_SMTEncoding_EncodeTerm.mk_Apply - f uu___14 in - let guarded_tok_typing - = - let uu___14 = - FStar_Syntax_Syntax.range_of_fv - fv in - let uu___15 = - let uu___16 = - let uu___17 = - let uu___18 - = - FStar_SMTEncoding_Term.mk_NoHoist - f - tok_typing in - let uu___19 - = - name_tok_corr_formula - vapp in - (uu___18, - uu___19) in - FStar_SMTEncoding_Util.mkAnd - uu___17 in - ([[vtok_app_r]], - [ff], - uu___16) in - FStar_SMTEncoding_Term.mkForall - uu___14 uu___15 in - FStar_SMTEncoding_Util.mkAssume - (guarded_tok_typing, - (FStar_Pervasives_Native.Some - "function token typing"), - (Prims.strcat - "function_token_typing_" - vname)) in - let uu___14 = - let uu___15 = - FStar_SMTEncoding_Term.mk_decls_trivial - [vtok_decl; - name_tok_corr; - tok_typing1] in - FStar_Compiler_List.op_At - decls2 uu___15 in - (uu___14, env1) in - (match uu___12 with - | (tok_decl, env2) -> - let uu___13 = - let uu___14 = - FStar_SMTEncoding_Term.mk_decls_trivial - [vname_decl] in - FStar_Compiler_List.op_At - uu___14 tok_decl in - (uu___13, env2)) in - (match uu___10 with - | (decls2, env2) -> - let uu___11 = - let res_t1 = - FStar_Syntax_Subst.compress - res_t in - let uu___12 = - FStar_SMTEncoding_EncodeTerm.encode_term - res_t1 env' in - match uu___12 with - | (encoded_res_t, decls) - -> - let uu___13 = - FStar_SMTEncoding_Term.mk_HasType - vapp encoded_res_t in - (encoded_res_t, - uu___13, decls) in - (match uu___11 with - | (encoded_res_t, ty_pred, - decls3) -> - let typingAx = - let uu___12 = - let uu___13 = - let uu___14 = - FStar_Syntax_Syntax.range_of_fv - fv in - let uu___15 = - let uu___16 = - FStar_SMTEncoding_Util.mkImp - (guard, - ty_pred) in - ([[vapp]], - vars1, - uu___16) in - FStar_SMTEncoding_Term.mkForall - uu___14 uu___15 in - (uu___13, - (FStar_Pervasives_Native.Some - "free var typing"), - (Prims.strcat - "typing_" - vname)) in - FStar_SMTEncoding_Util.mkAssume - uu___12 in - let freshness = - if - FStar_Compiler_List.contains - FStar_Syntax_Syntax.New - quals - then - let uu___12 = - let uu___13 = - FStar_Syntax_Syntax.range_of_fv - fv in - let uu___14 = - let uu___15 = - FStar_Compiler_List.map - FStar_SMTEncoding_Term.fv_sort - vars1 in - let uu___16 = - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.next_id - () in - (vname, - uu___15, - FStar_SMTEncoding_Term.Term_sort, - uu___16) in - FStar_SMTEncoding_Term.fresh_constructor - uu___13 uu___14 in - let uu___13 = - let uu___14 = - let uu___15 = - FStar_Syntax_Syntax.range_of_fv - fv in - pretype_axiom - false uu___15 - env2 vapp - vars1 in - [uu___14] in - uu___12 :: uu___13 - else [] in - let g = - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = - let uu___17 - = - mk_disc_proj_axioms - guard - encoded_res_t - vapp - vars1 in - typingAx :: - uu___17 in - FStar_Compiler_List.op_At - freshness - uu___16 in - FStar_SMTEncoding_Term.mk_decls_trivial - uu___15 in - FStar_Compiler_List.op_At - decls3 uu___14 in - FStar_Compiler_List.op_At - decls2 uu___13 in - FStar_Compiler_List.op_At - decls11 uu___12 in - (g, env2))))))))) -let (declare_top_level_let : - FStar_SMTEncoding_Env.env_t -> - FStar_Syntax_Syntax.fv -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term -> - (FStar_SMTEncoding_Env.fvar_binding * - FStar_SMTEncoding_Term.decls_t * FStar_SMTEncoding_Env.env_t)) - = - fun env -> - fun x -> - fun t -> - fun t_norm -> - let uu___ = - FStar_SMTEncoding_Env.lookup_fvar_binding env - (x.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - match uu___ with - | FStar_Pervasives_Native.None -> - let uu___1 = encode_free_var false env x t t_norm [] in - (match uu___1 with - | (decls, env1) -> - let fvb = - FStar_SMTEncoding_Env.lookup_lid env1 - (x.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - (fvb, decls, env1)) - | FStar_Pervasives_Native.Some fvb -> (fvb, [], env) -let (encode_top_level_val : - Prims.bool -> - FStar_SMTEncoding_Env.env_t -> - FStar_Syntax_Syntax.univ_names -> - FStar_Syntax_Syntax.fv -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.qualifier Prims.list -> - (FStar_SMTEncoding_Term.decls_elt Prims.list * - FStar_SMTEncoding_Env.env_t)) - = - fun uninterpreted -> - fun env -> - fun us -> - fun fv -> - fun t -> - fun quals -> - let tt = - let uu___ = - let uu___1 = - let uu___2 = FStar_Syntax_Syntax.lid_of_fv fv in - FStar_Ident.nsstr uu___2 in - uu___1 = "FStar.Ghost" in - if uu___ - then - norm_with_steps - [FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.Simplify; - FStar_TypeChecker_Env.AllowUnboundUniverses; - FStar_TypeChecker_Env.EraseUniverses; - FStar_TypeChecker_Env.Exclude FStar_TypeChecker_Env.Zeta] - env.FStar_SMTEncoding_Env.tcenv t - else norm_before_encoding_us env us t in - let uu___ = encode_free_var uninterpreted env fv t tt quals in - match uu___ with - | (decls, env1) -> - let uu___1 = FStar_Syntax_Util.is_smt_lemma t in - if uu___1 - then - let uu___2 = - let uu___3 = encode_smt_lemma env1 fv tt in - FStar_Compiler_List.op_At decls uu___3 in - (uu___2, env1) - else (decls, env1) -let (encode_top_level_vals : - FStar_SMTEncoding_Env.env_t -> - FStar_Syntax_Syntax.letbinding Prims.list -> - FStar_Syntax_Syntax.qualifier Prims.list -> - (FStar_SMTEncoding_Term.decls_elt Prims.list * - FStar_SMTEncoding_Env.env_t)) - = - fun env -> - fun bindings -> - fun quals -> - FStar_Compiler_List.fold_left - (fun uu___ -> - fun lb -> - match uu___ with - | (decls, env1) -> - let uu___1 = - let uu___2 = - FStar_Compiler_Util.right - lb.FStar_Syntax_Syntax.lbname in - encode_top_level_val false env1 - lb.FStar_Syntax_Syntax.lbunivs uu___2 - lb.FStar_Syntax_Syntax.lbtyp quals in - (match uu___1 with - | (decls', env2) -> - ((FStar_Compiler_List.op_At decls decls'), env2))) - ([], env) bindings -exception Let_rec_unencodeable -let (uu___is_Let_rec_unencodeable : Prims.exn -> Prims.bool) = - fun projectee -> - match projectee with | Let_rec_unencodeable -> true | uu___ -> false -let (copy_env : FStar_SMTEncoding_Env.env_t -> FStar_SMTEncoding_Env.env_t) = - fun en -> - let uu___ = - FStar_Compiler_Util.smap_copy en.FStar_SMTEncoding_Env.global_cache in - { - FStar_SMTEncoding_Env.bvar_bindings = - (en.FStar_SMTEncoding_Env.bvar_bindings); - FStar_SMTEncoding_Env.fvar_bindings = - (en.FStar_SMTEncoding_Env.fvar_bindings); - FStar_SMTEncoding_Env.depth = (en.FStar_SMTEncoding_Env.depth); - FStar_SMTEncoding_Env.tcenv = (en.FStar_SMTEncoding_Env.tcenv); - FStar_SMTEncoding_Env.warn = (en.FStar_SMTEncoding_Env.warn); - FStar_SMTEncoding_Env.nolabels = (en.FStar_SMTEncoding_Env.nolabels); - FStar_SMTEncoding_Env.use_zfuel_name = - (en.FStar_SMTEncoding_Env.use_zfuel_name); - FStar_SMTEncoding_Env.encode_non_total_function_typ = - (en.FStar_SMTEncoding_Env.encode_non_total_function_typ); - FStar_SMTEncoding_Env.current_module_name = - (en.FStar_SMTEncoding_Env.current_module_name); - FStar_SMTEncoding_Env.encoding_quantifier = - (en.FStar_SMTEncoding_Env.encoding_quantifier); - FStar_SMTEncoding_Env.global_cache = uu___ - } -let (encode_top_level_let : - FStar_SMTEncoding_Env.env_t -> - (Prims.bool * FStar_Syntax_Syntax.letbinding Prims.list) -> - FStar_Syntax_Syntax.qualifier Prims.list -> - (FStar_SMTEncoding_Term.decls_t * FStar_SMTEncoding_Env.env_t)) - = - fun env -> - fun uu___ -> - fun quals -> - match uu___ with - | (is_rec, bindings) -> - let eta_expand binders formals body t = - let nbinders = FStar_Compiler_List.length binders in - let uu___1 = FStar_Compiler_Util.first_N nbinders formals in - match uu___1 with - | (formals1, extra_formals) -> - let subst = - FStar_Compiler_List.map2 - (fun uu___2 -> - fun uu___3 -> - match (uu___2, uu___3) with - | ({ FStar_Syntax_Syntax.binder_bv = formal; - FStar_Syntax_Syntax.binder_qual = uu___4; - FStar_Syntax_Syntax.binder_positivity = - uu___5; - FStar_Syntax_Syntax.binder_attrs = uu___6;_}, - { FStar_Syntax_Syntax.binder_bv = binder; - FStar_Syntax_Syntax.binder_qual = uu___7; - FStar_Syntax_Syntax.binder_positivity = - uu___8; - FStar_Syntax_Syntax.binder_attrs = uu___9;_}) - -> - let uu___10 = - let uu___11 = - FStar_Syntax_Syntax.bv_to_name binder in - (formal, uu___11) in - FStar_Syntax_Syntax.NT uu___10) formals1 - binders in - let extra_formals1 = - let uu___2 = - FStar_Compiler_List.map - (fun b -> - let uu___3 = - let uu___4 = b.FStar_Syntax_Syntax.binder_bv in - let uu___5 = - FStar_Syntax_Subst.subst subst - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - { - FStar_Syntax_Syntax.ppname = - (uu___4.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (uu___4.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = uu___5 - } in - { - FStar_Syntax_Syntax.binder_bv = uu___3; - FStar_Syntax_Syntax.binder_qual = - (b.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity = - (b.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs = - (b.FStar_Syntax_Syntax.binder_attrs) - }) extra_formals in - FStar_Syntax_Util.name_binders uu___2 in - let body1 = - let uu___2 = FStar_Syntax_Subst.compress body in - let uu___3 = - let uu___4 = - FStar_Syntax_Util.args_of_binders extra_formals1 in - FStar_Pervasives_Native.snd uu___4 in - FStar_Syntax_Syntax.extend_app_n uu___2 uu___3 - body.FStar_Syntax_Syntax.pos in - ((FStar_Compiler_List.op_At binders extra_formals1), body1) in - let destruct_bound_function t e = - let tcenv = - let uu___1 = env.FStar_SMTEncoding_Env.tcenv in - { - FStar_TypeChecker_Env.solver = - (uu___1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (uu___1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (uu___1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (uu___1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (uu___1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (uu___1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (uu___1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (uu___1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (uu___1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (uu___1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (uu___1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (uu___1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (uu___1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (uu___1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (uu___1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (uu___1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (uu___1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (uu___1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = true; - FStar_TypeChecker_Env.lax_universes = - (uu___1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (uu___1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (uu___1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (uu___1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (uu___1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (uu___1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (uu___1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (uu___1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (uu___1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (uu___1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (uu___1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (uu___1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (uu___1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (uu___1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (uu___1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (uu___1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (uu___1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (uu___1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (uu___1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (uu___1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (uu___1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (uu___1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (uu___1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (uu___1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (uu___1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (uu___1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (uu___1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (uu___1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (uu___1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (uu___1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (uu___1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (uu___1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (uu___1.FStar_TypeChecker_Env.missing_decl) - } in - let subst_comp formals actuals comp = - let subst = - FStar_Compiler_List.map2 - (fun uu___1 -> - fun uu___2 -> - match (uu___1, uu___2) with - | ({ FStar_Syntax_Syntax.binder_bv = x; - FStar_Syntax_Syntax.binder_qual = uu___3; - FStar_Syntax_Syntax.binder_positivity = uu___4; - FStar_Syntax_Syntax.binder_attrs = uu___5;_}, - { FStar_Syntax_Syntax.binder_bv = b; - FStar_Syntax_Syntax.binder_qual = uu___6; - FStar_Syntax_Syntax.binder_positivity = uu___7; - FStar_Syntax_Syntax.binder_attrs = uu___8;_}) - -> - let uu___9 = - let uu___10 = FStar_Syntax_Syntax.bv_to_name b in - (x, uu___10) in - FStar_Syntax_Syntax.NT uu___9) formals actuals in - FStar_Syntax_Subst.subst_comp subst comp in - let rec arrow_formals_comp_norm norm t1 = - let t2 = - let uu___1 = FStar_Syntax_Subst.compress t1 in - FStar_Syntax_Util.unascribe uu___1 in - match t2.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = formals; - FStar_Syntax_Syntax.comp = comp;_} - -> FStar_Syntax_Subst.open_comp formals comp - | FStar_Syntax_Syntax.Tm_refine uu___1 -> - let uu___2 = FStar_Syntax_Util.unrefine t2 in - arrow_formals_comp_norm norm uu___2 - | uu___1 when Prims.op_Negation norm -> - let t_norm = - norm_with_steps - [FStar_TypeChecker_Env.AllowUnboundUniverses; - FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Weak; - FStar_TypeChecker_Env.HNF; - FStar_TypeChecker_Env.Exclude - FStar_TypeChecker_Env.Zeta; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.EraseUniverses] tcenv t2 in - arrow_formals_comp_norm true t_norm - | uu___1 -> - let uu___2 = FStar_Syntax_Syntax.mk_Total t2 in - ([], uu___2) in - let aux t1 e1 = - let uu___1 = FStar_Syntax_Util.abs_formals e1 in - match uu___1 with - | (binders, body, lopt) -> - let uu___2 = - match binders with - | [] -> arrow_formals_comp_norm true t1 - | uu___3 -> arrow_formals_comp_norm false t1 in - (match uu___2 with - | (formals, comp) -> - let nformals = FStar_Compiler_List.length formals in - let nbinders = FStar_Compiler_List.length binders in - let uu___3 = - if nformals < nbinders - then - let uu___4 = - FStar_Compiler_Util.first_N nformals binders in - match uu___4 with - | (bs0, rest) -> - let body1 = - FStar_Syntax_Util.abs rest body lopt in - let uu___5 = subst_comp formals bs0 comp in - (bs0, body1, uu___5) - else - if nformals > nbinders - then - (let uu___5 = - eta_expand binders formals body - (FStar_Syntax_Util.comp_result comp) in - match uu___5 with - | (binders1, body1) -> - let uu___6 = - subst_comp formals binders1 comp in - (binders1, body1, uu___6)) - else - (let uu___6 = subst_comp formals binders comp in - (binders, body, uu___6)) in - (match uu___3 with - | (binders1, body1, comp1) -> - (binders1, body1, comp1))) in - let uu___1 = aux t e in - match uu___1 with - | (binders, body, comp) -> - let uu___2 = - let tcenv1 = - FStar_TypeChecker_Env.push_binders tcenv binders in - let uu___3 = - FStar_SMTEncoding_Util.is_smt_reifiable_comp tcenv1 - comp in - if uu___3 - then - let eff_name = FStar_Syntax_Util.comp_effect_name comp in - let comp1 = - FStar_TypeChecker_Env.reify_comp tcenv1 comp - FStar_Syntax_Syntax.U_unknown in - let body1 = - let uu___4 = - FStar_Syntax_Util.mk_reify body - (FStar_Pervasives_Native.Some eff_name) in - FStar_TypeChecker_Util.norm_reify tcenv1 [] uu___4 in - let uu___4 = aux comp1 body1 in - match uu___4 with - | (more_binders, body2, comp2) -> - ((FStar_Compiler_List.op_At binders more_binders), - body2, comp2) - else (binders, body, comp) in - (match uu___2 with - | (binders1, body1, comp1) -> - let uu___3 = - FStar_Syntax_Util.ascribe body1 - ((FStar_Pervasives.Inl - (FStar_Syntax_Util.comp_result comp1)), - FStar_Pervasives_Native.None, false) in - (binders1, uu___3, comp1)) in - (try - (fun uu___1 -> - match () with - | () -> - let uu___2 = - FStar_Compiler_Util.for_all - (fun lb -> - FStar_Syntax_Util.is_lemma - lb.FStar_Syntax_Syntax.lbtyp) bindings in - if uu___2 - then encode_top_level_vals env bindings quals - else - (let uu___4 = - FStar_Compiler_List.fold_left - (fun uu___5 -> - fun lb -> - match uu___5 with - | (toks, typs, decls, env1) -> - ((let uu___7 = - FStar_Syntax_Util.is_lemma - lb.FStar_Syntax_Syntax.lbtyp in - if uu___7 - then - FStar_Compiler_Effect.raise - Let_rec_unencodeable - else ()); - (let t_norm = - if is_rec - then - FStar_TypeChecker_Normalize.unfold_whnf' - [FStar_TypeChecker_Env.AllowUnboundUniverses] - env1.FStar_SMTEncoding_Env.tcenv - lb.FStar_Syntax_Syntax.lbtyp - else - norm_before_encoding env1 - lb.FStar_Syntax_Syntax.lbtyp in - let uu___7 = - let uu___8 = - FStar_Compiler_Util.right - lb.FStar_Syntax_Syntax.lbname in - declare_top_level_let env1 uu___8 - lb.FStar_Syntax_Syntax.lbtyp - t_norm in - match uu___7 with - | (tok, decl, env2) -> - ((tok :: toks), (t_norm :: typs), - (decl :: decls), env2)))) - ([], [], [], env) bindings in - match uu___4 with - | (toks, typs, decls, env1) -> - let toks_fvbs = FStar_Compiler_List.rev toks in - let decls1 = - FStar_Compiler_List.flatten - (FStar_Compiler_List.rev decls) in - let env_decls = copy_env env1 in - let typs1 = FStar_Compiler_List.rev typs in - let encode_non_rec_lbdef bindings1 typs2 toks1 - env2 = - match (bindings1, typs2, toks1) with - | ({ FStar_Syntax_Syntax.lbname = lbn; - FStar_Syntax_Syntax.lbunivs = uvs; - FStar_Syntax_Syntax.lbtyp = uu___5; - FStar_Syntax_Syntax.lbeff = uu___6; - FStar_Syntax_Syntax.lbdef = e; - FStar_Syntax_Syntax.lbattrs = uu___7; - FStar_Syntax_Syntax.lbpos = uu___8;_}::[], - t_norm::[], fvb::[]) -> - let flid = - fvb.FStar_SMTEncoding_Env.fvar_lid in - let uu___9 = - let uu___10 = - FStar_TypeChecker_Env.open_universes_in - env2.FStar_SMTEncoding_Env.tcenv uvs - [e; t_norm] in - match uu___10 with - | (tcenv', uu___11, e_t) -> - let uu___12 = - match e_t with - | e1::t_norm1::[] -> (e1, t_norm1) - | uu___13 -> failwith "Impossible" in - (match uu___12 with - | (e1, t_norm1) -> - ({ - FStar_SMTEncoding_Env.bvar_bindings - = - (env2.FStar_SMTEncoding_Env.bvar_bindings); - FStar_SMTEncoding_Env.fvar_bindings - = - (env2.FStar_SMTEncoding_Env.fvar_bindings); - FStar_SMTEncoding_Env.depth - = - (env2.FStar_SMTEncoding_Env.depth); - FStar_SMTEncoding_Env.tcenv - = tcenv'; - FStar_SMTEncoding_Env.warn = - (env2.FStar_SMTEncoding_Env.warn); - FStar_SMTEncoding_Env.nolabels - = - (env2.FStar_SMTEncoding_Env.nolabels); - FStar_SMTEncoding_Env.use_zfuel_name - = - (env2.FStar_SMTEncoding_Env.use_zfuel_name); - FStar_SMTEncoding_Env.encode_non_total_function_typ - = - (env2.FStar_SMTEncoding_Env.encode_non_total_function_typ); - FStar_SMTEncoding_Env.current_module_name - = - (env2.FStar_SMTEncoding_Env.current_module_name); - FStar_SMTEncoding_Env.encoding_quantifier - = - (env2.FStar_SMTEncoding_Env.encoding_quantifier); - FStar_SMTEncoding_Env.global_cache - = - (env2.FStar_SMTEncoding_Env.global_cache) - }, e1, t_norm1)) in - (match uu___9 with - | (env', e1, t_norm1) -> - let uu___10 = - destruct_bound_function t_norm1 e1 in - (match uu___10 with - | (binders, body, t_body_comp) -> - let t_body = - FStar_Syntax_Util.comp_result - t_body_comp in - ((let uu___12 = - FStar_Compiler_Effect.op_Bang - dbg_SMTEncoding in - if uu___12 - then - let uu___13 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binder) - binders in - let uu___14 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - body in - FStar_Compiler_Util.print2 - "Encoding let : binders=[%s], body=%s\n" - uu___13 uu___14 - else ()); - (let uu___12 = - FStar_SMTEncoding_EncodeTerm.encode_binders - FStar_Pervasives_Native.None - binders env' in - match uu___12 with - | (vars, binder_guards, env'1, - binder_decls, uu___13) -> - let uu___14 = - if - fvb.FStar_SMTEncoding_Env.fvb_thunked - && (vars = []) - then - let dummy_var = - FStar_SMTEncoding_Term.mk_fv - ("@dummy", - FStar_SMTEncoding_Term.dummy_sort) in - let dummy_tm = - FStar_SMTEncoding_Term.mkFreeV - dummy_var - FStar_Compiler_Range_Type.dummyRange in - let app = - let uu___15 = - FStar_Syntax_Syntax.range_of_lbname - lbn in - FStar_SMTEncoding_Term.mkApp - ((fvb.FStar_SMTEncoding_Env.smt_id), - [dummy_tm]) - uu___15 in - ([dummy_var], app) - else - (let uu___16 = - let uu___17 = - FStar_Syntax_Syntax.range_of_lbname - lbn in - let uu___18 = - FStar_Compiler_List.map - FStar_SMTEncoding_Util.mkFreeV - vars in - FStar_SMTEncoding_EncodeTerm.maybe_curry_fvb - uu___17 fvb - uu___18 in - (vars, uu___16)) in - (match uu___14 with - | (vars1, app) -> - let is_logical = - let uu___15 = - let uu___16 = - FStar_Syntax_Subst.compress - t_body in - uu___16.FStar_Syntax_Syntax.n in - match uu___15 with - | FStar_Syntax_Syntax.Tm_fvar - fv when - FStar_Syntax_Syntax.fv_eq_lid - fv - FStar_Parser_Const.logical_lid - -> true - | uu___16 -> false in - let is_smt_theory_symbol - = - let fv = - FStar_Compiler_Util.right - lbn in - FStar_TypeChecker_Env.fv_has_attr - env2.FStar_SMTEncoding_Env.tcenv - fv - FStar_Parser_Const.smt_theory_symbol_attr_lid in - let is_sub_singleton - = - FStar_Syntax_Util.is_sub_singleton - body in - let should_encode_logical - = - (Prims.op_Negation - is_smt_theory_symbol) - && - ((FStar_Compiler_List.contains - FStar_Syntax_Syntax.Logic - quals) - || is_logical) in - let make_eqn name pat - app1 body1 = - let uu___15 = - let uu___16 = - let uu___17 = - FStar_Syntax_Syntax.range_of_lbname - lbn in - let uu___18 = - let uu___19 = - FStar_SMTEncoding_Util.mkEq - (app1, - body1) in - ([[pat]], - vars1, - uu___19) in - FStar_SMTEncoding_Term.mkForall - uu___17 - uu___18 in - let uu___17 = - let uu___18 = - let uu___19 = - FStar_Ident.string_of_lid - flid in - FStar_Compiler_Util.format1 - "Equation for %s" - uu___19 in - FStar_Pervasives_Native.Some - uu___18 in - (uu___16, - uu___17, - (Prims.strcat - name - (Prims.strcat - "_" - fvb.FStar_SMTEncoding_Env.smt_id))) in - FStar_SMTEncoding_Util.mkAssume - uu___15 in - let uu___15 = - let basic_eqn_name - = - if - should_encode_logical - then - "defn_equation" - else "equation" in - let uu___16 = - let app_is_prop = - FStar_SMTEncoding_Term.mk_subtype_of_unit - app in - if - should_encode_logical - then - let uu___17 = - is_sub_singleton - && - (let uu___18 - = - FStar_Options_Ext.get - "retain_old_prop_typing" in - uu___18 = - "") in - (if uu___17 - then - let uu___18 - = - let uu___19 - = - let uu___20 - = - let uu___21 - = - FStar_Syntax_Syntax.range_of_lbname - lbn in - let uu___22 - = - let uu___23 - = - let uu___24 - = - let uu___25 - = - FStar_SMTEncoding_Util.mk_and_l - binder_guards in - let uu___26 - = - FStar_SMTEncoding_Term.mk_Valid - app_is_prop in - (uu___25, - uu___26) in - FStar_SMTEncoding_Util.mkImp - uu___24 in - ([ - [app_is_prop]], - vars1, - uu___23) in - FStar_SMTEncoding_Term.mkForall - uu___21 - uu___22 in - let uu___21 - = - let uu___22 - = - let uu___23 - = - FStar_Ident.string_of_lid - flid in - FStar_Compiler_Util.format1 - "Prop-typing for %s" - uu___23 in - FStar_Pervasives_Native.Some - uu___22 in - (uu___20, - uu___21, - (Prims.strcat - basic_eqn_name - (Prims.strcat - "_" - fvb.FStar_SMTEncoding_Env.smt_id))) in - FStar_SMTEncoding_Util.mkAssume - uu___19 in - (uu___18, - []) - else - (let uu___19 - = - FStar_SMTEncoding_EncodeTerm.encode_term - body - env'1 in - match uu___19 - with - | (body1, - decls2) - -> - let uu___20 - = - make_eqn - basic_eqn_name - app_is_prop - app body1 in - (uu___20, - decls2))) - else - (let uu___18 = - FStar_SMTEncoding_EncodeTerm.encode_term - body env'1 in - match uu___18 - with - | (body1, - decls2) -> - let uu___19 - = - make_eqn - basic_eqn_name - app app - body1 in - (uu___19, - decls2)) in - match uu___16 with - | (basic_eqn, - decls2) -> - if - should_encode_logical - then - let uu___17 = - let uu___18 - = - FStar_SMTEncoding_Term.mk_Valid - app in - let uu___19 - = - FStar_SMTEncoding_EncodeTerm.encode_formula - body - env'1 in - (app, - uu___18, - uu___19) in - (match uu___17 - with - | (pat, - app1, - (body1, - decls21)) - -> - let logical_eqn - = - make_eqn - "equation" - pat app1 - body1 in - ([logical_eqn; - basic_eqn], - (FStar_Compiler_List.op_At - decls2 - decls21))) - else - ([basic_eqn], - decls2) in - (match uu___15 with - | (eqns, decls2) -> - let uu___16 = - let uu___17 = - let uu___18 - = - let uu___19 - = - let uu___20 - = - let uu___21 - = - primitive_type_axioms - env2.FStar_SMTEncoding_Env.tcenv - flid - fvb.FStar_SMTEncoding_Env.smt_id - app in - FStar_Compiler_List.op_At - eqns - uu___21 in - FStar_SMTEncoding_Term.mk_decls_trivial - uu___20 in - FStar_Compiler_List.op_At - decls2 - uu___19 in - FStar_Compiler_List.op_At - binder_decls - uu___18 in - FStar_Compiler_List.op_At - decls1 - uu___17 in - (uu___16, env2))))))) - | uu___5 -> failwith "Impossible" in - let encode_rec_lbdefs bindings1 typs2 toks1 env2 - = - let fuel = - let uu___5 = - let uu___6 = - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.fresh - env2.FStar_SMTEncoding_Env.current_module_name - "fuel" in - (uu___6, FStar_SMTEncoding_Term.Fuel_sort) in - FStar_SMTEncoding_Term.mk_fv uu___5 in - let fuel_tm = - FStar_SMTEncoding_Util.mkFreeV fuel in - let env0 = env2 in - let uu___5 = - FStar_Compiler_List.fold_left - (fun uu___6 -> - fun fvb -> - match uu___6 with - | (gtoks, env3) -> - let flid = - fvb.FStar_SMTEncoding_Env.fvar_lid in - let g = - let uu___7 = - FStar_Ident.lid_add_suffix - flid "fuel_instrumented" in - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.new_fvar - uu___7 in - let gtok = - let uu___7 = - FStar_Ident.lid_add_suffix - flid - "fuel_instrumented_token" in - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.new_fvar - uu___7 in - let env4 = - let uu___7 = - let uu___8 = - FStar_SMTEncoding_Util.mkApp - (g, [fuel_tm]) in - FStar_Pervasives_Native.Some - uu___8 in - FStar_SMTEncoding_Env.push_free_var - env3 flid - fvb.FStar_SMTEncoding_Env.smt_arity - gtok uu___7 in - (((fvb, g, gtok) :: gtoks), env4)) - ([], env2) toks1 in - match uu___5 with - | (gtoks, env3) -> - let gtoks1 = FStar_Compiler_List.rev gtoks in - let encode_one_binding env01 uu___6 t_norm - uu___7 = - match (uu___6, uu___7) with - | ((fvb, g, gtok), - { FStar_Syntax_Syntax.lbname = lbn; - FStar_Syntax_Syntax.lbunivs = uvs; - FStar_Syntax_Syntax.lbtyp = uu___8; - FStar_Syntax_Syntax.lbeff = uu___9; - FStar_Syntax_Syntax.lbdef = e; - FStar_Syntax_Syntax.lbattrs = - uu___10; - FStar_Syntax_Syntax.lbpos = uu___11;_}) - -> - let uu___12 = - let uu___13 = - FStar_TypeChecker_Env.open_universes_in - env3.FStar_SMTEncoding_Env.tcenv - uvs [e; t_norm] in - match uu___13 with - | (tcenv', uu___14, e_t) -> - let uu___15 = - match e_t with - | e1::t_norm1::[] -> - (e1, t_norm1) - | uu___16 -> - failwith "Impossible" in - (match uu___15 with - | (e1, t_norm1) -> - ({ - FStar_SMTEncoding_Env.bvar_bindings - = - (env3.FStar_SMTEncoding_Env.bvar_bindings); - FStar_SMTEncoding_Env.fvar_bindings - = - (env3.FStar_SMTEncoding_Env.fvar_bindings); - FStar_SMTEncoding_Env.depth - = - (env3.FStar_SMTEncoding_Env.depth); - FStar_SMTEncoding_Env.tcenv - = tcenv'; - FStar_SMTEncoding_Env.warn - = - (env3.FStar_SMTEncoding_Env.warn); - FStar_SMTEncoding_Env.nolabels - = - (env3.FStar_SMTEncoding_Env.nolabels); - FStar_SMTEncoding_Env.use_zfuel_name - = - (env3.FStar_SMTEncoding_Env.use_zfuel_name); - FStar_SMTEncoding_Env.encode_non_total_function_typ - = - (env3.FStar_SMTEncoding_Env.encode_non_total_function_typ); - FStar_SMTEncoding_Env.current_module_name - = - (env3.FStar_SMTEncoding_Env.current_module_name); - FStar_SMTEncoding_Env.encoding_quantifier - = - (env3.FStar_SMTEncoding_Env.encoding_quantifier); - FStar_SMTEncoding_Env.global_cache - = - (env3.FStar_SMTEncoding_Env.global_cache) - }, e1, t_norm1)) in - (match uu___12 with - | (env', e1, t_norm1) -> - ((let uu___14 = - FStar_Compiler_Effect.op_Bang - dbg_SMTEncoding in - if uu___14 - then - let uu___15 = - FStar_Class_Show.show - (FStar_Class_Show.show_either - FStar_Syntax_Print.showable_bv - FStar_Syntax_Print.showable_fv) - lbn in - let uu___16 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t_norm1 in - let uu___17 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - e1 in - FStar_Compiler_Util.print3 - "Encoding let rec %s : %s = %s\n" - uu___15 uu___16 uu___17 - else ()); - (let uu___14 = - destruct_bound_function - t_norm1 e1 in - match uu___14 with - | (binders, body, tres_comp) - -> - let curry = - fvb.FStar_SMTEncoding_Env.smt_arity - <> - (FStar_Compiler_List.length - binders) in - let uu___15 = - FStar_TypeChecker_Util.pure_or_ghost_pre_and_post - env3.FStar_SMTEncoding_Env.tcenv - tres_comp in - (match uu___15 with - | (pre_opt, tres) -> - ((let uu___17 = - FStar_Compiler_Effect.op_Bang - dbg_SMTEncoding in - if uu___17 - then - let uu___18 = - FStar_Class_Show.show - (FStar_Class_Show.show_either - FStar_Syntax_Print.showable_bv - FStar_Syntax_Print.showable_fv) - lbn in - let uu___19 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binder) - binders in - let uu___20 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - body in - let uu___21 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_comp - tres_comp in - FStar_Compiler_Util.print4 - "Encoding let rec %s: \n\tbinders=[%s], \n\tbody=%s, \n\ttres=%s\n" - uu___18 - uu___19 - uu___20 - uu___21 - else ()); - (let uu___17 = - FStar_SMTEncoding_EncodeTerm.encode_binders - FStar_Pervasives_Native.None - binders env' in - match uu___17 with - | (vars, guards, - env'1, - binder_decls, - uu___18) -> - let uu___19 = - match pre_opt - with - | FStar_Pervasives_Native.None - -> - let uu___20 - = - FStar_SMTEncoding_Util.mk_and_l - guards in - (uu___20, - []) - | FStar_Pervasives_Native.Some - pre -> - let uu___20 - = - FStar_SMTEncoding_EncodeTerm.encode_formula - pre env'1 in - (match uu___20 - with - | - (guard, - decls0) - -> - let uu___21 - = - FStar_SMTEncoding_Util.mk_and_l - (FStar_Compiler_List.op_At - guards - [guard]) in - (uu___21, - decls0)) in - (match uu___19 - with - | (guard, - guard_decls) - -> - let binder_decls1 - = - FStar_Compiler_List.op_At - binder_decls - guard_decls in - let decl_g - = - let uu___20 - = - let uu___21 - = - let uu___22 - = - let uu___23 - = - let uu___24 - = - FStar_Compiler_Util.first_N - fvb.FStar_SMTEncoding_Env.smt_arity - vars in - FStar_Pervasives_Native.fst - uu___24 in - FStar_Compiler_List.map - FStar_SMTEncoding_Term.fv_sort - uu___23 in - FStar_SMTEncoding_Term.Fuel_sort - :: - uu___22 in - (g, - uu___21, - FStar_SMTEncoding_Term.Term_sort, - (FStar_Pervasives_Native.Some - "Fuel-instrumented function name")) in - FStar_SMTEncoding_Term.DeclFun - uu___20 in - let decl_g_tok - = - FStar_SMTEncoding_Term.DeclFun - (gtok, - [], - FStar_SMTEncoding_Term.Term_sort, - (FStar_Pervasives_Native.Some - "Token for fuel-instrumented partial applications")) in - let env02 - = - FStar_SMTEncoding_Env.push_zfuel_name - env01 - fvb.FStar_SMTEncoding_Env.fvar_lid - g gtok in - let vars_tm - = - FStar_Compiler_List.map - FStar_SMTEncoding_Util.mkFreeV - vars in - let rng = - FStar_Syntax_Syntax.range_of_lbname - lbn in - let app = - let uu___20 - = - FStar_Compiler_List.map - FStar_SMTEncoding_Util.mkFreeV - vars in - FStar_SMTEncoding_EncodeTerm.maybe_curry_fvb - rng fvb - uu___20 in - let mk_g_app - args = - FStar_SMTEncoding_EncodeTerm.maybe_curry_app - rng - (FStar_Pervasives.Inl - (FStar_SMTEncoding_Term.Var - g)) - (fvb.FStar_SMTEncoding_Env.smt_arity - + - Prims.int_one) - args in - let gsapp - = - let uu___20 - = - let uu___21 - = - FStar_SMTEncoding_Util.mkApp - ("SFuel", - [fuel_tm]) in - uu___21 - :: - vars_tm in - mk_g_app - uu___20 in - let gmax - = - let uu___20 - = - let uu___21 - = - FStar_SMTEncoding_Util.mkApp - ("MaxFuel", - []) in - uu___21 - :: - vars_tm in - mk_g_app - uu___20 in - let uu___20 - = - FStar_SMTEncoding_EncodeTerm.encode_term - body - env'1 in - (match uu___20 - with - | - (body_tm, - decls2) - -> - let eqn_g - = - let uu___21 - = - let uu___22 - = - let uu___23 - = - FStar_Syntax_Syntax.range_of_lbname - lbn in - let uu___24 - = - let uu___25 - = - let uu___26 - = - let uu___27 - = - FStar_SMTEncoding_Util.mkEq - (gsapp, - body_tm) in - (guard, - uu___27) in - FStar_SMTEncoding_Util.mkImp - uu___26 in - ([ - [gsapp]], - (FStar_Pervasives_Native.Some - Prims.int_zero), - (fuel :: - vars), - uu___25) in - FStar_SMTEncoding_Term.mkForall' - uu___23 - uu___24 in - let uu___23 - = - let uu___24 - = - let uu___25 - = - FStar_Ident.string_of_lid - fvb.FStar_SMTEncoding_Env.fvar_lid in - FStar_Compiler_Util.format1 - "Equation for fuel-instrumented recursive function: %s" - uu___25 in - FStar_Pervasives_Native.Some - uu___24 in - (uu___22, - uu___23, - (Prims.strcat - "equation_with_fuel_" - g)) in - FStar_SMTEncoding_Util.mkAssume - uu___21 in - let eqn_f - = - let uu___21 - = - let uu___22 - = - let uu___23 - = - FStar_Syntax_Syntax.range_of_lbname - lbn in - let uu___24 - = - let uu___25 - = - FStar_SMTEncoding_Util.mkEq - (app, - gmax) in - ([[app]], - vars, - uu___25) in - FStar_SMTEncoding_Term.mkForall - uu___23 - uu___24 in - (uu___22, - (FStar_Pervasives_Native.Some - "Correspondence of recursive function to instrumented version"), - (Prims.strcat - "@fuel_correspondence_" - g)) in - FStar_SMTEncoding_Util.mkAssume - uu___21 in - let eqn_g' - = - let uu___21 - = - let uu___22 - = - let uu___23 - = - FStar_Syntax_Syntax.range_of_lbname - lbn in - let uu___24 - = - let uu___25 - = - let uu___26 - = - let uu___27 - = - let uu___28 - = - let uu___29 - = - FStar_SMTEncoding_Term.n_fuel - Prims.int_zero in - uu___29 - :: - vars_tm in - mk_g_app - uu___28 in - (gsapp, - uu___27) in - FStar_SMTEncoding_Util.mkEq - uu___26 in - ([ - [gsapp]], - (fuel :: - vars), - uu___25) in - FStar_SMTEncoding_Term.mkForall - uu___23 - uu___24 in - (uu___22, - (FStar_Pervasives_Native.Some - "Fuel irrelevance"), - (Prims.strcat - "@fuel_irrelevance_" - g)) in - FStar_SMTEncoding_Util.mkAssume - uu___21 in - let uu___21 - = - let gapp - = - mk_g_app - (fuel_tm - :: - vars_tm) in - let tok_corr - = - let tok_app - = - let uu___22 - = - let uu___23 - = - FStar_SMTEncoding_Term.mk_fv - (gtok, - FStar_SMTEncoding_Term.Term_sort) in - FStar_SMTEncoding_Util.mkFreeV - uu___23 in - FStar_SMTEncoding_EncodeTerm.mk_Apply - uu___22 - (fuel :: - vars) in - let tot_fun_axioms - = - let head - = - let uu___22 - = - FStar_SMTEncoding_Term.mk_fv - (gtok, - FStar_SMTEncoding_Term.Term_sort) in - FStar_SMTEncoding_Util.mkFreeV - uu___22 in - let vars1 - = fuel :: - vars in - let guards1 - = - FStar_Compiler_List.map - (fun - uu___22 - -> - FStar_SMTEncoding_Util.mkTrue) - vars1 in - let uu___22 - = - FStar_Syntax_Util.is_pure_comp - tres_comp in - FStar_SMTEncoding_EncodeTerm.isTotFun_axioms - rng head - vars1 - guards1 - uu___22 in - let uu___22 - = - let uu___23 - = - let uu___24 - = - let uu___25 - = - let uu___26 - = - FStar_Syntax_Syntax.range_of_lbname - lbn in - let uu___27 - = - let uu___28 - = - FStar_SMTEncoding_Util.mkEq - (tok_app, - gapp) in - ([ - [tok_app]], - (fuel :: - vars), - uu___28) in - FStar_SMTEncoding_Term.mkForall - uu___26 - uu___27 in - (uu___25, - tot_fun_axioms) in - FStar_SMTEncoding_Util.mkAnd - uu___24 in - (uu___23, - (FStar_Pervasives_Native.Some - "Fuel token correspondence"), - (Prims.strcat - "fuel_token_correspondence_" - gtok)) in - FStar_SMTEncoding_Util.mkAssume - uu___22 in - let uu___22 - = - let uu___23 - = - FStar_SMTEncoding_EncodeTerm.encode_term_pred - FStar_Pervasives_Native.None - tres - env'1 - gapp in - match uu___23 - with - | - (g_typing, - d3) -> - let uu___24 - = - let uu___25 - = - let uu___26 - = - let uu___27 - = - let uu___28 - = - FStar_Syntax_Syntax.range_of_lbname - lbn in - let uu___29 - = - let uu___30 - = - FStar_SMTEncoding_Util.mkImp - (guard, - g_typing) in - ([[gapp]], - (fuel :: - vars), - uu___30) in - FStar_SMTEncoding_Term.mkForall - uu___28 - uu___29 in - (uu___27, - (FStar_Pervasives_Native.Some - "Typing correspondence of token to term"), - (Prims.strcat - "token_correspondence_" - g)) in - FStar_SMTEncoding_Util.mkAssume - uu___26 in - [uu___25] in - (d3, - uu___24) in - match uu___22 - with - | - (aux_decls, - typing_corr) - -> - (aux_decls, - (FStar_Compiler_List.op_At - typing_corr - [tok_corr])) in - (match uu___21 - with - | - (aux_decls, - g_typing) - -> - let uu___22 - = - let uu___23 - = - let uu___24 - = - let uu___25 - = - FStar_SMTEncoding_Term.mk_decls_trivial - [decl_g; - decl_g_tok] in - FStar_Compiler_List.op_At - aux_decls - uu___25 in - FStar_Compiler_List.op_At - decls2 - uu___24 in - FStar_Compiler_List.op_At - binder_decls1 - uu___23 in - let uu___23 - = - FStar_SMTEncoding_Term.mk_decls_trivial - (FStar_Compiler_List.op_At - [eqn_g; - eqn_g'; - eqn_f] - g_typing) in - (uu___22, - uu___23, - env02)))))))))) in - let uu___6 = - let uu___7 = - FStar_Compiler_List.zip3 gtoks1 typs2 - bindings1 in - FStar_Compiler_List.fold_left - (fun uu___8 -> - fun uu___9 -> - match (uu___8, uu___9) with - | ((decls2, eqns, env01), - (gtok, ty, lb)) -> - let uu___10 = - encode_one_binding env01 - gtok ty lb in - (match uu___10 with - | (decls', eqns', env02) -> - ((decls' :: decls2), - (FStar_Compiler_List.op_At - eqns' eqns), env02))) - ([decls1], [], env0) uu___7 in - (match uu___6 with - | (decls2, eqns, env01) -> - let uu___7 = - let isDeclFun uu___8 = - match uu___8 with - | FStar_SMTEncoding_Term.DeclFun - uu___9 -> true - | uu___9 -> false in - let uu___8 = - FStar_Compiler_List.fold_left - (fun uu___9 -> - fun elt -> - match uu___9 with - | (prefix_decls, elts, - rest) -> - let uu___10 = - (FStar_Compiler_Util.is_some - elt.FStar_SMTEncoding_Term.key) - && - (FStar_Compiler_List.existsb - isDeclFun - elt.FStar_SMTEncoding_Term.decls) in - if uu___10 - then - (prefix_decls, - (FStar_Compiler_List.op_At - elts [elt]), - rest) - else - (let uu___12 = - FStar_Compiler_List.partition - isDeclFun - elt.FStar_SMTEncoding_Term.decls in - match uu___12 with - | (elt_decl_funs, - elt_rest) -> - ((FStar_Compiler_List.op_At - prefix_decls - elt_decl_funs), - elts, - (FStar_Compiler_List.op_At - rest - [{ - FStar_SMTEncoding_Term.sym_name - = - (elt.FStar_SMTEncoding_Term.sym_name); - FStar_SMTEncoding_Term.key - = - (elt.FStar_SMTEncoding_Term.key); - FStar_SMTEncoding_Term.decls - = - elt_rest; - FStar_SMTEncoding_Term.a_names - = - (elt.FStar_SMTEncoding_Term.a_names) - }])))) - ([], [], []) - (FStar_Compiler_List.flatten - decls2) in - match uu___8 with - | (prefix_decls, elts, rest) -> - let uu___9 = - FStar_SMTEncoding_Term.mk_decls_trivial - prefix_decls in - (uu___9, elts, rest) in - (match uu___7 with - | (prefix_decls, elts, rest) -> - let eqns1 = - FStar_Compiler_List.rev eqns in - ((FStar_Compiler_List.op_At - prefix_decls - (FStar_Compiler_List.op_At - elts - (FStar_Compiler_List.op_At - rest eqns1))), env01))) in - let uu___5 = - (FStar_Compiler_Util.for_some - (fun uu___6 -> - match uu___6 with - | FStar_Syntax_Syntax.HasMaskedEffect -> - true - | uu___7 -> false) quals) - || - (FStar_Compiler_Util.for_some - (fun t -> - let uu___6 = - (FStar_Syntax_Util.is_pure_or_ghost_function - t) - || - (FStar_SMTEncoding_Util.is_smt_reifiable_function - env1.FStar_SMTEncoding_Env.tcenv - t) in - Prims.op_Negation uu___6) typs1) in - if uu___5 - then (decls1, env_decls) - else - (try - (fun uu___7 -> - match () with - | () -> - if Prims.op_Negation is_rec - then - encode_non_rec_lbdef bindings - typs1 toks_fvbs env1 - else - encode_rec_lbdefs bindings typs1 - toks_fvbs env1) () - with - | FStar_SMTEncoding_Env.Inner_let_rec names - -> - let plural = - (FStar_Compiler_List.length names) > - Prims.int_one in - let r = - let uu___8 = - FStar_Compiler_List.hd names in - FStar_Pervasives_Native.snd uu___8 in - ((let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - FStar_Compiler_List.map - FStar_Pervasives_Native.fst - names in - FStar_Compiler_String.concat - "," uu___15 in - FStar_Compiler_Util.format3 - "Definitions of inner let-rec%s %s and %s enclosing top-level letbinding are not encoded to the solver, you will only be able to reason with their types" - (if plural then "s" else "") - uu___14 - (if plural - then "their" - else "its") in - FStar_Errors_Msg.text uu___13 in - [uu___12] in - let uu___12 = - FStar_Errors.get_ctx () in - (FStar_Errors_Codes.Warning_DefinitionNotTranslated, - uu___11, r, uu___12) in - [uu___10] in - FStar_TypeChecker_Err.add_errors - env1.FStar_SMTEncoding_Env.tcenv - uu___9); - (decls1, env_decls))))) () - with - | Let_rec_unencodeable -> - let msg = - let uu___2 = - FStar_Compiler_List.map - (fun lb -> - FStar_Class_Show.show - (FStar_Class_Show.show_either - FStar_Syntax_Print.showable_bv - FStar_Syntax_Print.showable_fv) - lb.FStar_Syntax_Syntax.lbname) bindings in - FStar_Compiler_String.concat " and " uu___2 in - let decl = - FStar_SMTEncoding_Term.Caption - (Prims.strcat "let rec unencodeable: Skipping: " msg) in - let uu___2 = FStar_SMTEncoding_Term.mk_decls_trivial [decl] in - (uu___2, env)) -let (encode_sig_inductive : - FStar_SMTEncoding_Env.env_t -> - FStar_Syntax_Syntax.sigelt -> - (FStar_SMTEncoding_Term.decls_t * FStar_SMTEncoding_Env.env_t)) - = - fun env -> - fun se -> - let uu___ = se.FStar_Syntax_Syntax.sigel in - match uu___ with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = t; - FStar_Syntax_Syntax.us = universe_names; - FStar_Syntax_Syntax.params = tps; - FStar_Syntax_Syntax.num_uniform_params = uu___1; - FStar_Syntax_Syntax.t = k; FStar_Syntax_Syntax.mutuals = uu___2; - FStar_Syntax_Syntax.ds = datas; - FStar_Syntax_Syntax.injective_type_params = injective_type_params;_} - -> - let t_lid = t in - let tcenv = env.FStar_SMTEncoding_Env.tcenv in - let quals = se.FStar_Syntax_Syntax.sigquals in - let is_logical = - FStar_Compiler_Util.for_some - (fun uu___3 -> - match uu___3 with - | FStar_Syntax_Syntax.Logic -> true - | FStar_Syntax_Syntax.Assumption -> true - | uu___4 -> false) quals in - let constructor_or_logic_type_decl c = - if is_logical - then - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Compiler_List.map - (fun f -> f.FStar_SMTEncoding_Term.field_sort) - c.FStar_SMTEncoding_Term.constr_fields in - ((c.FStar_SMTEncoding_Term.constr_name), uu___5, - FStar_SMTEncoding_Term.Term_sort, - FStar_Pervasives_Native.None) in - FStar_SMTEncoding_Term.DeclFun uu___4 in - [uu___3] - else - (let uu___4 = FStar_Ident.range_of_lid t in - FStar_SMTEncoding_Term.constructor_to_decl uu___4 c) in - let inversion_axioms env1 tapp vars = - let uu___3 = - FStar_Compiler_Util.for_some - (fun l -> - let uu___4 = - FStar_TypeChecker_Env.try_lookup_lid - env1.FStar_SMTEncoding_Env.tcenv l in - FStar_Compiler_Option.isNone uu___4) datas in - if uu___3 - then [] - else - (let uu___5 = - FStar_SMTEncoding_Env.fresh_fvar - env1.FStar_SMTEncoding_Env.current_module_name "x" - FStar_SMTEncoding_Term.Term_sort in - match uu___5 with - | (xxsym, xx) -> - let uu___6 = - FStar_Compiler_List.fold_left - (fun uu___7 -> - fun l -> - match uu___7 with - | (out, decls) -> - let is_l = - FStar_SMTEncoding_Env.mk_data_tester env1 l - xx in - let uu___8 = - let uu___9 = - injective_type_params || - (let uu___10 = - FStar_Options_Ext.get - "compat:injectivity" in - uu___10 <> "") in - if uu___9 - then - let uu___10 = - FStar_TypeChecker_Env.lookup_datacon - env1.FStar_SMTEncoding_Env.tcenv l in - match uu___10 with - | (uu___11, data_t) -> - let uu___12 = - FStar_Syntax_Util.arrow_formals - data_t in - (match uu___12 with - | (args, res) -> - let indices = - let uu___13 = - FStar_Syntax_Util.head_and_args_full - res in - FStar_Pervasives_Native.snd - uu___13 in - let env2 = - FStar_Compiler_List.fold_left - (fun env3 -> - fun uu___13 -> - match uu___13 with - | { - FStar_Syntax_Syntax.binder_bv - = x; - FStar_Syntax_Syntax.binder_qual - = uu___14; - FStar_Syntax_Syntax.binder_positivity - = uu___15; - FStar_Syntax_Syntax.binder_attrs - = uu___16;_} - -> - let uu___17 = - let uu___18 = - let uu___19 = - FStar_SMTEncoding_Env.mk_term_projector_name - l x in - (uu___19, [xx]) in - FStar_SMTEncoding_Util.mkApp - uu___18 in - FStar_SMTEncoding_Env.push_term_var - env3 x uu___17) - env1 args in - let uu___13 = - FStar_SMTEncoding_EncodeTerm.encode_args - indices env2 in - (match uu___13 with - | (indices1, decls') -> - (if - (FStar_Compiler_List.length - indices1) - <> - (FStar_Compiler_List.length - vars) - then failwith "Impossible" - else (); - (let eqs = - FStar_Compiler_List.map2 - (fun v -> - fun a -> - let uu___15 = - let uu___16 = - FStar_SMTEncoding_Util.mkFreeV - v in - (uu___16, a) in - FStar_SMTEncoding_Util.mkEq - uu___15) vars - indices1 in - let uu___15 = - let uu___16 = - let uu___17 = - FStar_SMTEncoding_Util.mk_and_l - eqs in - (is_l, uu___17) in - FStar_SMTEncoding_Util.mkAnd - uu___16 in - (uu___15, decls'))))) - else (is_l, []) in - (match uu___8 with - | (inversion_case, decls') -> - let uu___9 = - FStar_SMTEncoding_Util.mkOr - (out, inversion_case) in - (uu___9, - (FStar_Compiler_List.op_At decls - decls')))) - (FStar_SMTEncoding_Util.mkFalse, []) datas in - (match uu___6 with - | (data_ax, decls) -> - let uu___7 = - FStar_SMTEncoding_Env.fresh_fvar - env1.FStar_SMTEncoding_Env.current_module_name - "f" FStar_SMTEncoding_Term.Fuel_sort in - (match uu___7 with - | (ffsym, ff) -> - let fuel_guarded_inversion = - let xx_has_type_sfuel = - if - (FStar_Compiler_List.length datas) > - Prims.int_one - then - let uu___8 = - FStar_SMTEncoding_Util.mkApp - ("SFuel", [ff]) in - FStar_SMTEncoding_Term.mk_HasTypeFuel - uu___8 xx tapp - else - FStar_SMTEncoding_Term.mk_HasTypeFuel ff - xx tapp in - let uu___8 = - let uu___9 = - let uu___10 = FStar_Ident.range_of_lid t in - let uu___11 = - let uu___12 = - let uu___13 = - FStar_SMTEncoding_Term.mk_fv - (ffsym, - FStar_SMTEncoding_Term.Fuel_sort) in - let uu___14 = - let uu___15 = - FStar_SMTEncoding_Term.mk_fv - (xxsym, - FStar_SMTEncoding_Term.Term_sort) in - uu___15 :: vars in - FStar_SMTEncoding_Env.add_fuel uu___13 - uu___14 in - let uu___13 = - FStar_SMTEncoding_Util.mkImp - (xx_has_type_sfuel, data_ax) in - ([[xx_has_type_sfuel]], uu___12, - uu___13) in - FStar_SMTEncoding_Term.mkForall uu___10 - uu___11 in - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Ident.string_of_lid t in - Prims.strcat "fuel_guarded_inversion_" - uu___12 in - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.mk_unique - uu___11 in - (uu___9, - (FStar_Pervasives_Native.Some - "inversion axiom"), uu___10) in - FStar_SMTEncoding_Util.mkAssume uu___8 in - let uu___8 = - FStar_SMTEncoding_Term.mk_decls_trivial - [fuel_guarded_inversion] in - FStar_Compiler_List.op_At decls uu___8))) in - let uu___3 = - let k1 = - match tps with - | [] -> k - | uu___4 -> - let uu___5 = - let uu___6 = - let uu___7 = FStar_Syntax_Syntax.mk_Total k in - { - FStar_Syntax_Syntax.bs1 = tps; - FStar_Syntax_Syntax.comp = uu___7 - } in - FStar_Syntax_Syntax.Tm_arrow uu___6 in - FStar_Syntax_Syntax.mk uu___5 k.FStar_Syntax_Syntax.pos in - let k2 = norm_before_encoding env k1 in - FStar_Syntax_Util.arrow_formals k2 in - (match uu___3 with - | (formals, res) -> - let uu___4 = - FStar_SMTEncoding_EncodeTerm.encode_binders - FStar_Pervasives_Native.None formals env in - (match uu___4 with - | (vars, guards, env', binder_decls, uu___5) -> - let arity = FStar_Compiler_List.length vars in - let uu___6 = - FStar_SMTEncoding_Env.new_term_constant_and_tok_from_lid - env t arity in - (match uu___6 with - | (tname, ttok, env1) -> - let ttok_tm = - FStar_SMTEncoding_Util.mkApp (ttok, []) in - let guard = FStar_SMTEncoding_Util.mk_and_l guards in - let tapp = - let uu___7 = - let uu___8 = - FStar_Compiler_List.map - FStar_SMTEncoding_Util.mkFreeV vars in - (tname, uu___8) in - FStar_SMTEncoding_Util.mkApp uu___7 in - let uu___7 = - let tname_decl = - let uu___8 = - let uu___9 = - FStar_Compiler_List.map - (fun fv -> - let uu___10 = - let uu___11 = - FStar_SMTEncoding_Term.fv_name fv in - Prims.strcat tname uu___11 in - let uu___11 = - FStar_SMTEncoding_Term.fv_sort fv in - { - FStar_SMTEncoding_Term.field_name = - uu___10; - FStar_SMTEncoding_Term.field_sort = - uu___11; - FStar_SMTEncoding_Term.field_projectible - = false - }) vars in - let uu___10 = - let uu___11 = - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.next_id - () in - FStar_Pervasives_Native.Some uu___11 in - { - FStar_SMTEncoding_Term.constr_name = tname; - FStar_SMTEncoding_Term.constr_fields = - uu___9; - FStar_SMTEncoding_Term.constr_sort = - FStar_SMTEncoding_Term.Term_sort; - FStar_SMTEncoding_Term.constr_id = uu___10; - FStar_SMTEncoding_Term.constr_base = false - } in - constructor_or_logic_type_decl uu___8 in - let uu___8 = - match vars with - | [] -> - let uu___9 = - let uu___10 = - let uu___11 = - FStar_SMTEncoding_Util.mkApp - (tname, []) in - FStar_Pervasives_Native.Some uu___11 in - FStar_SMTEncoding_Env.push_free_var env1 t - arity tname uu___10 in - ([], uu___9) - | uu___9 -> - let ttok_decl = - FStar_SMTEncoding_Term.DeclFun - (ttok, [], - FStar_SMTEncoding_Term.Term_sort, - (FStar_Pervasives_Native.Some "token")) in - let ttok_fresh = - let uu___10 = - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.next_id - () in - FStar_SMTEncoding_Term.fresh_token - (ttok, FStar_SMTEncoding_Term.Term_sort) - uu___10 in - let ttok_app = - FStar_SMTEncoding_EncodeTerm.mk_Apply - ttok_tm vars in - let pats = [[ttok_app]; [tapp]] in - let name_tok_corr = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Ident.range_of_lid t in - let uu___13 = - let uu___14 = - FStar_SMTEncoding_Util.mkEq - (ttok_app, tapp) in - (pats, FStar_Pervasives_Native.None, - vars, uu___14) in - FStar_SMTEncoding_Term.mkForall' - uu___12 uu___13 in - (uu___11, - (FStar_Pervasives_Native.Some - "name-token correspondence"), - (Prims.strcat "token_correspondence_" - ttok)) in - FStar_SMTEncoding_Util.mkAssume uu___10 in - ([ttok_decl; ttok_fresh; name_tok_corr], - env1) in - match uu___8 with - | (tok_decls, env2) -> - ((FStar_Compiler_List.op_At tname_decl - tok_decls), env2) in - (match uu___7 with - | (decls, env2) -> - let kindingAx = - let uu___8 = - FStar_SMTEncoding_EncodeTerm.encode_term_pred - FStar_Pervasives_Native.None res env' - tapp in - match uu___8 with - | (k1, decls1) -> - let karr = - if - (FStar_Compiler_List.length formals) - > Prims.int_zero - then - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_SMTEncoding_Term.mk_PreType - ttok_tm in - FStar_SMTEncoding_Term.mk_tester - "Tm_arrow" uu___12 in - (uu___11, - (FStar_Pervasives_Native.Some - "kinding"), - (Prims.strcat "pre_kinding_" - ttok)) in - FStar_SMTEncoding_Util.mkAssume - uu___10 in - [uu___9] - else [] in - let rng = FStar_Ident.range_of_lid t in - let tot_fun_axioms = - let uu___9 = - FStar_Compiler_List.map - (fun uu___10 -> - FStar_SMTEncoding_Util.mkTrue) - vars in - FStar_SMTEncoding_EncodeTerm.isTotFun_axioms - rng ttok_tm vars uu___9 true in - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = - let uu___17 = - let uu___18 = - FStar_SMTEncoding_Util.mkImp - (guard, k1) in - ([[tapp]], vars, - uu___18) in - FStar_SMTEncoding_Term.mkForall - rng uu___17 in - (tot_fun_axioms, uu___16) in - FStar_SMTEncoding_Util.mkAnd - uu___15 in - (uu___14, - FStar_Pervasives_Native.None, - (Prims.strcat "kinding_" ttok)) in - FStar_SMTEncoding_Util.mkAssume - uu___13 in - [uu___12] in - FStar_Compiler_List.op_At karr - uu___11 in - FStar_SMTEncoding_Term.mk_decls_trivial - uu___10 in - FStar_Compiler_List.op_At decls1 uu___9 in - let aux = - let uu___8 = - let uu___9 = - inversion_axioms env2 tapp vars in - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Ident.range_of_lid t in - pretype_axiom - (Prims.op_Negation - injective_type_params) uu___13 - env2 tapp vars in - [uu___12] in - FStar_SMTEncoding_Term.mk_decls_trivial - uu___11 in - FStar_Compiler_List.op_At uu___9 uu___10 in - FStar_Compiler_List.op_At kindingAx uu___8 in - let uu___8 = - let uu___9 = - FStar_SMTEncoding_Term.mk_decls_trivial - decls in - FStar_Compiler_List.op_At uu___9 - (FStar_Compiler_List.op_At binder_decls aux) in - (uu___8, env2))))) -let (encode_datacon : - FStar_SMTEncoding_Env.env_t -> - FStar_Syntax_Syntax.sigelt -> - (FStar_SMTEncoding_Term.decls_t * FStar_SMTEncoding_Env.env_t)) - = - fun env -> - fun se -> - let uu___ = se.FStar_Syntax_Syntax.sigel in - match uu___ with - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = d; FStar_Syntax_Syntax.us1 = us; - FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = uu___1; - FStar_Syntax_Syntax.num_ty_params = n_tps; - FStar_Syntax_Syntax.mutuals1 = mutuals; - FStar_Syntax_Syntax.injective_type_params1 = - injective_type_params;_} - -> - let quals = se.FStar_Syntax_Syntax.sigquals in - let t1 = norm_before_encoding_us env us t in - let uu___2 = FStar_Syntax_Util.arrow_formals t1 in - (match uu___2 with - | (formals, t_res) -> - let arity = FStar_Compiler_List.length formals in - let uu___3 = - FStar_SMTEncoding_Env.new_term_constant_and_tok_from_lid env - d arity in - (match uu___3 with - | (ddconstrsym, ddtok, env1) -> - let ddtok_tm = FStar_SMTEncoding_Util.mkApp (ddtok, []) in - let uu___4 = - FStar_SMTEncoding_Env.fresh_fvar - env1.FStar_SMTEncoding_Env.current_module_name "f" - FStar_SMTEncoding_Term.Fuel_sort in - (match uu___4 with - | (fuel_var, fuel_tm) -> - let s_fuel_tm = - FStar_SMTEncoding_Util.mkApp ("SFuel", [fuel_tm]) in - let uu___5 = - FStar_SMTEncoding_EncodeTerm.encode_binders - (FStar_Pervasives_Native.Some fuel_tm) formals - env1 in - (match uu___5 with - | (vars, guards, env', binder_decls, names) -> - let injective_type_params1 = - injective_type_params || - (let uu___6 = - FStar_Options_Ext.get - "compat:injectivity" in - uu___6 <> "") in - let fields = - FStar_Compiler_List.mapi - (fun n -> - fun x -> - let field_projectible = - (n >= n_tps) || - injective_type_params1 in - let uu___6 = - FStar_SMTEncoding_Env.mk_term_projector_name - d x in - { - FStar_SMTEncoding_Term.field_name = - uu___6; - FStar_SMTEncoding_Term.field_sort = - FStar_SMTEncoding_Term.Term_sort; - FStar_SMTEncoding_Term.field_projectible - = field_projectible - }) names in - let datacons = - let uu___6 = FStar_Ident.range_of_lid d in - let uu___7 = - let uu___8 = - let uu___9 = - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.next_id - () in - FStar_Pervasives_Native.Some uu___9 in - { - FStar_SMTEncoding_Term.constr_name = - ddconstrsym; - FStar_SMTEncoding_Term.constr_fields = - fields; - FStar_SMTEncoding_Term.constr_sort = - FStar_SMTEncoding_Term.Term_sort; - FStar_SMTEncoding_Term.constr_id = uu___8; - FStar_SMTEncoding_Term.constr_base = - (Prims.op_Negation - injective_type_params1) - } in - FStar_SMTEncoding_Term.constructor_to_decl - uu___6 uu___7 in - let app = - FStar_SMTEncoding_EncodeTerm.mk_Apply - ddtok_tm vars in - let guard = - FStar_SMTEncoding_Util.mk_and_l guards in - let xvars = - FStar_Compiler_List.map - FStar_SMTEncoding_Util.mkFreeV vars in - let dapp = - FStar_SMTEncoding_Util.mkApp - (ddconstrsym, xvars) in - let uu___6 = - FStar_SMTEncoding_EncodeTerm.encode_term_pred - FStar_Pervasives_Native.None t1 env1 - ddtok_tm in - (match uu___6 with - | (tok_typing, decls3) -> - let tok_typing1 = - match fields with - | uu___7::uu___8 -> - let ff = - FStar_SMTEncoding_Term.mk_fv - ("ty", - FStar_SMTEncoding_Term.Term_sort) in - let f = - FStar_SMTEncoding_Util.mkFreeV ff in - let vtok_app_l = - FStar_SMTEncoding_EncodeTerm.mk_Apply - ddtok_tm [ff] in - let vtok_app_r = - let uu___9 = - let uu___10 = - FStar_SMTEncoding_Term.mk_fv - (ddtok, - FStar_SMTEncoding_Term.Term_sort) in - [uu___10] in - FStar_SMTEncoding_EncodeTerm.mk_Apply - f uu___9 in - let uu___9 = - FStar_Ident.range_of_lid d in - let uu___10 = - let uu___11 = - FStar_SMTEncoding_Term.mk_NoHoist - f tok_typing in - ([[vtok_app_l]; [vtok_app_r]], - [ff], uu___11) in - FStar_SMTEncoding_Term.mkForall - uu___9 uu___10 - | uu___7 -> tok_typing in - let uu___7 = - let uu___8 = - FStar_SMTEncoding_EncodeTerm.encode_term - t_res env' in - match uu___8 with - | (t_res_tm, t_res_decls) -> - let uu___9 = - FStar_SMTEncoding_Term.mk_HasTypeWithFuel - (FStar_Pervasives_Native.Some - fuel_tm) dapp t_res_tm in - (uu___9, t_res_tm, t_res_decls) in - (match uu___7 with - | (ty_pred', t_res_tm, decls_pred) -> - let proxy_fresh = - match formals with - | [] -> [] - | uu___8 -> - let uu___9 = - let uu___10 = - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.next_id - () in - FStar_SMTEncoding_Term.fresh_token - (ddtok, - FStar_SMTEncoding_Term.Term_sort) - uu___10 in - [uu___9] in - let encode_elim uu___8 = - let uu___9 = - FStar_Syntax_Util.head_and_args - t_res in - match uu___9 with - | (head, args) -> - let uu___10 = - let uu___11 = - FStar_Syntax_Subst.compress - head in - uu___11.FStar_Syntax_Syntax.n in - (match uu___10 with - | FStar_Syntax_Syntax.Tm_uinst - ({ - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_fvar - fv; - FStar_Syntax_Syntax.pos - = uu___11; - FStar_Syntax_Syntax.vars - = uu___12; - FStar_Syntax_Syntax.hash_code - = uu___13;_}, - uu___14) - -> - let encoded_head_fvb = - FStar_SMTEncoding_Env.lookup_free_var_name - env' - fv.FStar_Syntax_Syntax.fv_name in - let uu___15 = - FStar_SMTEncoding_EncodeTerm.encode_args - args env' in - (match uu___15 with - | (encoded_args, - arg_decls) -> - let uu___16 = - let uu___17 = - FStar_Compiler_List.zip - args - encoded_args in - FStar_Compiler_List.fold_left - (fun uu___18 -> - fun uu___19 -> - match - (uu___18, - uu___19) - with - | ((env2, - arg_vars, - eqns_or_guards, - i), - (orig_arg, - arg)) -> - let uu___20 - = - let uu___21 - = - FStar_Syntax_Syntax.new_bv - FStar_Pervasives_Native.None - FStar_Syntax_Syntax.tun in - FStar_SMTEncoding_Env.gen_term_var - env2 - uu___21 in - (match uu___20 - with - | - (uu___21, - xv, env3) - -> - let eqns - = - if - i < n_tps - then - eqns_or_guards - else - (let uu___23 - = - FStar_SMTEncoding_Util.mkEq - (arg, xv) in - uu___23 - :: - eqns_or_guards) in - (env3, - (xv :: - arg_vars), - eqns, - (i + - Prims.int_one)))) - (env', [], [], - Prims.int_zero) - uu___17 in - (match uu___16 with - | (uu___17, - arg_vars, - elim_eqns_or_guards, - uu___18) -> - let arg_vars1 = - FStar_Compiler_List.rev - arg_vars in - let uu___19 = - FStar_Compiler_List.splitAt - n_tps - arg_vars1 in - (match uu___19 - with - | (arg_params, - uu___20) -> - let uu___21 - = - FStar_Compiler_List.splitAt - n_tps - vars in - (match uu___21 - with - | - (data_arg_params, - uu___22) - -> - let elim_eqns_and_guards - = - let uu___23 - = - FStar_SMTEncoding_Util.mk_and_l - (FStar_Compiler_List.op_At - elim_eqns_or_guards - guards) in - FStar_Compiler_List.fold_left2 - (fun - elim_eqns_and_guards1 - -> - fun - data_arg_param - -> - fun - arg_param - -> - FStar_SMTEncoding_Term.subst - elim_eqns_and_guards1 - data_arg_param - arg_param) - uu___23 - data_arg_params - arg_params in - let ty = - FStar_SMTEncoding_EncodeTerm.maybe_curry_fvb - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.p - encoded_head_fvb - arg_vars1 in - let xvars1 - = - FStar_Compiler_List.map - FStar_SMTEncoding_Util.mkFreeV - vars in - let dapp1 - = - FStar_SMTEncoding_Util.mkApp - (ddconstrsym, - xvars1) in - let ty_pred - = - FStar_SMTEncoding_Term.mk_HasTypeWithFuel - (FStar_Pervasives_Native.Some - s_fuel_tm) - dapp1 ty in - let arg_binders - = - FStar_Compiler_List.map - FStar_SMTEncoding_Term.fv_of_term - arg_vars1 in - let typing_inversion - = - let uu___23 - = - let uu___24 - = - let uu___25 - = - FStar_Ident.range_of_lid - d in - let uu___26 - = - let uu___27 - = - let uu___28 - = - FStar_SMTEncoding_Term.mk_fv - (fuel_var, - FStar_SMTEncoding_Term.Fuel_sort) in - FStar_SMTEncoding_Env.add_fuel - uu___28 - (FStar_Compiler_List.op_At - vars - arg_binders) in - let uu___28 - = - FStar_SMTEncoding_Util.mkImp - (ty_pred, - elim_eqns_and_guards) in - ([ - [ty_pred]], - uu___27, - uu___28) in - FStar_SMTEncoding_Term.mkForall - uu___25 - uu___26 in - (uu___24, - (FStar_Pervasives_Native.Some - "data constructor typing elim"), - (Prims.strcat - "data_elim_" - ddconstrsym)) in - FStar_SMTEncoding_Util.mkAssume - uu___23 in - let lex_t - = - let uu___23 - = - let uu___24 - = - let uu___25 - = - FStar_Ident.string_of_lid - FStar_Parser_Const.lex_t_lid in - (uu___25, - FStar_SMTEncoding_Term.Term_sort) in - FStar_SMTEncoding_Term.mk_fv - uu___24 in - FStar_SMTEncoding_Util.mkFreeV - uu___23 in - let subterm_ordering - = - let prec - = - let uu___23 - = - FStar_Compiler_List.mapi - (fun i -> - fun v -> - if - i < n_tps - then [] - else - (let uu___25 - = - let uu___26 - = - FStar_SMTEncoding_Util.mkFreeV - v in - FStar_SMTEncoding_Util.mk_Precedes - lex_t - lex_t - uu___26 - dapp1 in - [uu___25])) - vars in - FStar_Compiler_List.flatten - uu___23 in - let uu___23 - = - let uu___24 - = - let uu___25 - = - FStar_Ident.range_of_lid - d in - let uu___26 - = - let uu___27 - = - let uu___28 - = - FStar_SMTEncoding_Term.mk_fv - (fuel_var, - FStar_SMTEncoding_Term.Fuel_sort) in - FStar_SMTEncoding_Env.add_fuel - uu___28 - (FStar_Compiler_List.op_At - vars - arg_binders) in - let uu___28 - = - let uu___29 - = - let uu___30 - = - FStar_SMTEncoding_Util.mk_and_l - prec in - (ty_pred, - uu___30) in - FStar_SMTEncoding_Util.mkImp - uu___29 in - ([ - [ty_pred]], - uu___27, - uu___28) in - FStar_SMTEncoding_Term.mkForall - uu___25 - uu___26 in - (uu___24, - (FStar_Pervasives_Native.Some - "subterm ordering"), - (Prims.strcat - "subterm_ordering_" - ddconstrsym)) in - FStar_SMTEncoding_Util.mkAssume - uu___23 in - let uu___23 - = - let uu___24 - = - FStar_Compiler_Util.first_N - n_tps - formals in - match uu___24 - with - | - (uu___25, - formals') - -> - let uu___26 - = - FStar_Compiler_Util.first_N - n_tps - vars in - (match uu___26 - with - | - (uu___27, - vars') -> - let norm - t2 = - FStar_TypeChecker_Normalize.unfold_whnf' - [FStar_TypeChecker_Env.AllowUnboundUniverses; - FStar_TypeChecker_Env.EraseUniverses; - FStar_TypeChecker_Env.Unascribe; - FStar_TypeChecker_Env.Exclude - FStar_TypeChecker_Env.Zeta] - env'.FStar_SMTEncoding_Env.tcenv - t2 in - let warn_compat - uu___28 = - let uu___29 - = - let uu___30 - = - FStar_Errors_Msg.text - "Using 'compat:2954' to use a permissive encoding of the subterm ordering on the codomain of a constructor." in - let uu___31 - = - let uu___32 - = - FStar_Errors_Msg.text - "This is deprecated and will be removed in a future version of F*." in - [uu___32] in - uu___30 - :: - uu___31 in - FStar_Errors.log_issue - FStar_Syntax_Syntax.hasRange_fv - fv - FStar_Errors_Codes.Warning_DeprecatedGeneric - () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic - uu___29) in - let uu___28 - = - FStar_Compiler_List.fold_left2 - (fun - uu___29 - -> - fun - formal -> - fun var - -> - match uu___29 - with - | - (codomain_prec_l, - cod_decls) - -> - let rec binder_and_codomain_type - t2 = - let t3 = - FStar_Syntax_Util.unrefine - t2 in - let uu___30 - = - let uu___31 - = - FStar_Syntax_Subst.compress - t3 in - uu___31.FStar_Syntax_Syntax.n in - match uu___30 - with - | - FStar_Syntax_Syntax.Tm_arrow - uu___31 - -> - let uu___32 - = - let uu___33 - = - FStar_Syntax_Util.unrefine - t3 in - FStar_Syntax_Util.arrow_formals_comp - uu___33 in - (match uu___32 - with - | - (bs, c) - -> - (match bs - with - | - [] -> - FStar_Pervasives_Native.None - | - uu___33 - when - let uu___34 - = - FStar_Syntax_Util.is_tot_or_gtot_comp - c in - Prims.op_Negation - uu___34 - -> - FStar_Pervasives_Native.None - | - uu___33 - -> - let uu___34 - = - FStar_Syntax_Util.is_lemma_comp - c in - if - uu___34 - then - FStar_Pervasives_Native.None - else - (let t4 = - FStar_Syntax_Util.unrefine - (FStar_Syntax_Util.comp_result - c) in - let t5 = - norm t4 in - let uu___36 - = - (FStar_Syntax_Syntax.is_type - t5) || - (FStar_Syntax_Util.is_sub_singleton - t5) in - if - uu___36 - then - FStar_Pervasives_Native.None - else - (let uu___38 - = - FStar_Syntax_Util.head_and_args_full - t5 in - match uu___38 - with - | - (head1, - uu___39) - -> - let uu___40 - = - let uu___41 - = - FStar_Syntax_Util.un_uinst - head1 in - uu___41.FStar_Syntax_Syntax.n in - (match uu___40 - with - | - FStar_Syntax_Syntax.Tm_fvar - fv1 -> - let uu___41 - = - FStar_Compiler_Util.for_some - (FStar_Syntax_Syntax.fv_eq_lid - fv1) - mutuals in - if - uu___41 - then - FStar_Pervasives_Native.Some - (bs, c) - else - (let uu___43 - = - let uu___44 - = - FStar_Options_Ext.get - "compat:2954" in - uu___44 - <> "" in - if - uu___43 - then - (warn_compat - (); - FStar_Pervasives_Native.Some - (bs, c)) - else - FStar_Pervasives_Native.None) - | - uu___41 - -> - let uu___42 - = - let uu___43 - = - FStar_Options_Ext.get - "compat:2954" in - uu___43 - <> "" in - if - uu___42 - then - (warn_compat - (); - FStar_Pervasives_Native.Some - (bs, c)) - else - FStar_Pervasives_Native.None))))) - | - uu___31 - -> - let uu___32 - = - FStar_Syntax_Util.head_and_args - t3 in - (match uu___32 - with - | - (head1, - uu___33) - -> - let t' = - norm t3 in - let uu___34 - = - FStar_Syntax_Util.head_and_args - t' in - (match uu___34 - with - | - (head', - uu___35) - -> - let uu___36 - = - FStar_TypeChecker_TermEqAndSimplify.eq_tm - env1.FStar_SMTEncoding_Env.tcenv - head1 - head' in - (match uu___36 - with - | - FStar_TypeChecker_TermEqAndSimplify.Equal - -> - FStar_Pervasives_Native.None - | - FStar_TypeChecker_TermEqAndSimplify.NotEqual - -> - binder_and_codomain_type - t' - | - uu___37 - -> - let uu___38 - = - let uu___39 - = - FStar_Syntax_Subst.compress - head1 in - uu___39.FStar_Syntax_Syntax.n in - (match uu___38 - with - | - FStar_Syntax_Syntax.Tm_fvar - uu___39 - -> - binder_and_codomain_type - t' - | - FStar_Syntax_Syntax.Tm_name - uu___39 - -> - binder_and_codomain_type - t' - | - FStar_Syntax_Syntax.Tm_uinst - uu___39 - -> - binder_and_codomain_type - t' - | - uu___39 - -> - FStar_Pervasives_Native.None)))) in - let uu___30 - = - binder_and_codomain_type - (formal.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - (match uu___30 - with - | - FStar_Pervasives_Native.None - -> - (codomain_prec_l, - cod_decls) - | - FStar_Pervasives_Native.Some - (bs, c) - -> - let uu___31 - = - FStar_SMTEncoding_EncodeTerm.encode_binders - FStar_Pervasives_Native.None - bs env' in - (match uu___31 - with - | - (bs', - guards', - _env', - bs_decls, - uu___32) - -> - let fun_app - = - let uu___33 - = - FStar_SMTEncoding_Util.mkFreeV - var in - FStar_SMTEncoding_EncodeTerm.mk_Apply - uu___33 - bs' in - let uu___33 - = - let uu___34 - = - let uu___35 - = - FStar_Ident.range_of_lid - d in - let uu___36 - = - let uu___37 - = - let uu___38 - = - let uu___39 - = - FStar_SMTEncoding_Util.mk_Precedes - lex_t - lex_t - fun_app - dapp1 in - [uu___39] in - [uu___38] in - let uu___38 - = - let uu___39 - = - let uu___40 - = - FStar_SMTEncoding_Util.mk_and_l - (ty_pred' - :: - guards') in - let uu___41 - = - FStar_SMTEncoding_Util.mk_Precedes - lex_t - lex_t - fun_app - dapp1 in - (uu___40, - uu___41) in - FStar_SMTEncoding_Util.mkImp - uu___39 in - (uu___37, - bs', - uu___38) in - FStar_SMTEncoding_Term.mkForall - uu___35 - uu___36 in - uu___34 - :: - codomain_prec_l in - (uu___33, - (FStar_Compiler_List.op_At - bs_decls - cod_decls))))) - ([], []) - formals' - vars' in - (match uu___28 - with - | - (codomain_prec_l, - cod_decls) - -> - (match codomain_prec_l - with - | - [] -> - ([], - cod_decls) - | - uu___29 - -> - let uu___30 - = - let uu___31 - = - let uu___32 - = - let uu___33 - = - let uu___34 - = - FStar_Ident.range_of_lid - d in - let uu___35 - = - let uu___36 - = - let uu___37 - = - FStar_SMTEncoding_Term.mk_fv - (fuel_var, - FStar_SMTEncoding_Term.Fuel_sort) in - FStar_SMTEncoding_Env.add_fuel - uu___37 - (FStar_Compiler_List.op_At - vars - arg_binders) in - let uu___37 - = - FStar_SMTEncoding_Util.mk_and_l - codomain_prec_l in - ([ - [ty_pred]], - uu___36, - uu___37) in - FStar_SMTEncoding_Term.mkForall - uu___34 - uu___35 in - (uu___33, - (FStar_Pervasives_Native.Some - "well-founded ordering on codomain"), - (Prims.strcat - "well_founded_ordering_on_codomain_" - ddconstrsym)) in - FStar_SMTEncoding_Util.mkAssume - uu___32 in - [uu___31] in - (uu___30, - cod_decls)))) in - (match uu___23 - with - | - (codomain_ordering, - codomain_decls) - -> - ((FStar_Compiler_List.op_At - arg_decls - codomain_decls), - (FStar_Compiler_List.op_At - [typing_inversion; - subterm_ordering] - codomain_ordering))))))) - | FStar_Syntax_Syntax.Tm_fvar - fv -> - let encoded_head_fvb = - FStar_SMTEncoding_Env.lookup_free_var_name - env' - fv.FStar_Syntax_Syntax.fv_name in - let uu___11 = - FStar_SMTEncoding_EncodeTerm.encode_args - args env' in - (match uu___11 with - | (encoded_args, - arg_decls) -> - let uu___12 = - let uu___13 = - FStar_Compiler_List.zip - args - encoded_args in - FStar_Compiler_List.fold_left - (fun uu___14 -> - fun uu___15 -> - match - (uu___14, - uu___15) - with - | ((env2, - arg_vars, - eqns_or_guards, - i), - (orig_arg, - arg)) -> - let uu___16 - = - let uu___17 - = - FStar_Syntax_Syntax.new_bv - FStar_Pervasives_Native.None - FStar_Syntax_Syntax.tun in - FStar_SMTEncoding_Env.gen_term_var - env2 - uu___17 in - (match uu___16 - with - | - (uu___17, - xv, env3) - -> - let eqns - = - if - i < n_tps - then - eqns_or_guards - else - (let uu___19 - = - FStar_SMTEncoding_Util.mkEq - (arg, xv) in - uu___19 - :: - eqns_or_guards) in - (env3, - (xv :: - arg_vars), - eqns, - (i + - Prims.int_one)))) - (env', [], [], - Prims.int_zero) - uu___13 in - (match uu___12 with - | (uu___13, - arg_vars, - elim_eqns_or_guards, - uu___14) -> - let arg_vars1 = - FStar_Compiler_List.rev - arg_vars in - let uu___15 = - FStar_Compiler_List.splitAt - n_tps - arg_vars1 in - (match uu___15 - with - | (arg_params, - uu___16) -> - let uu___17 - = - FStar_Compiler_List.splitAt - n_tps - vars in - (match uu___17 - with - | - (data_arg_params, - uu___18) - -> - let elim_eqns_and_guards - = - let uu___19 - = - FStar_SMTEncoding_Util.mk_and_l - (FStar_Compiler_List.op_At - elim_eqns_or_guards - guards) in - FStar_Compiler_List.fold_left2 - (fun - elim_eqns_and_guards1 - -> - fun - data_arg_param - -> - fun - arg_param - -> - FStar_SMTEncoding_Term.subst - elim_eqns_and_guards1 - data_arg_param - arg_param) - uu___19 - data_arg_params - arg_params in - let ty = - FStar_SMTEncoding_EncodeTerm.maybe_curry_fvb - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.p - encoded_head_fvb - arg_vars1 in - let xvars1 - = - FStar_Compiler_List.map - FStar_SMTEncoding_Util.mkFreeV - vars in - let dapp1 - = - FStar_SMTEncoding_Util.mkApp - (ddconstrsym, - xvars1) in - let ty_pred - = - FStar_SMTEncoding_Term.mk_HasTypeWithFuel - (FStar_Pervasives_Native.Some - s_fuel_tm) - dapp1 ty in - let arg_binders - = - FStar_Compiler_List.map - FStar_SMTEncoding_Term.fv_of_term - arg_vars1 in - let typing_inversion - = - let uu___19 - = - let uu___20 - = - let uu___21 - = - FStar_Ident.range_of_lid - d in - let uu___22 - = - let uu___23 - = - let uu___24 - = - FStar_SMTEncoding_Term.mk_fv - (fuel_var, - FStar_SMTEncoding_Term.Fuel_sort) in - FStar_SMTEncoding_Env.add_fuel - uu___24 - (FStar_Compiler_List.op_At - vars - arg_binders) in - let uu___24 - = - FStar_SMTEncoding_Util.mkImp - (ty_pred, - elim_eqns_and_guards) in - ([ - [ty_pred]], - uu___23, - uu___24) in - FStar_SMTEncoding_Term.mkForall - uu___21 - uu___22 in - (uu___20, - (FStar_Pervasives_Native.Some - "data constructor typing elim"), - (Prims.strcat - "data_elim_" - ddconstrsym)) in - FStar_SMTEncoding_Util.mkAssume - uu___19 in - let lex_t - = - let uu___19 - = - let uu___20 - = - let uu___21 - = - FStar_Ident.string_of_lid - FStar_Parser_Const.lex_t_lid in - (uu___21, - FStar_SMTEncoding_Term.Term_sort) in - FStar_SMTEncoding_Term.mk_fv - uu___20 in - FStar_SMTEncoding_Util.mkFreeV - uu___19 in - let subterm_ordering - = - let prec - = - let uu___19 - = - FStar_Compiler_List.mapi - (fun i -> - fun v -> - if - i < n_tps - then [] - else - (let uu___21 - = - let uu___22 - = - FStar_SMTEncoding_Util.mkFreeV - v in - FStar_SMTEncoding_Util.mk_Precedes - lex_t - lex_t - uu___22 - dapp1 in - [uu___21])) - vars in - FStar_Compiler_List.flatten - uu___19 in - let uu___19 - = - let uu___20 - = - let uu___21 - = - FStar_Ident.range_of_lid - d in - let uu___22 - = - let uu___23 - = - let uu___24 - = - FStar_SMTEncoding_Term.mk_fv - (fuel_var, - FStar_SMTEncoding_Term.Fuel_sort) in - FStar_SMTEncoding_Env.add_fuel - uu___24 - (FStar_Compiler_List.op_At - vars - arg_binders) in - let uu___24 - = - let uu___25 - = - let uu___26 - = - FStar_SMTEncoding_Util.mk_and_l - prec in - (ty_pred, - uu___26) in - FStar_SMTEncoding_Util.mkImp - uu___25 in - ([ - [ty_pred]], - uu___23, - uu___24) in - FStar_SMTEncoding_Term.mkForall - uu___21 - uu___22 in - (uu___20, - (FStar_Pervasives_Native.Some - "subterm ordering"), - (Prims.strcat - "subterm_ordering_" - ddconstrsym)) in - FStar_SMTEncoding_Util.mkAssume - uu___19 in - let uu___19 - = - let uu___20 - = - FStar_Compiler_Util.first_N - n_tps - formals in - match uu___20 - with - | - (uu___21, - formals') - -> - let uu___22 - = - FStar_Compiler_Util.first_N - n_tps - vars in - (match uu___22 - with - | - (uu___23, - vars') -> - let norm - t2 = - FStar_TypeChecker_Normalize.unfold_whnf' - [FStar_TypeChecker_Env.AllowUnboundUniverses; - FStar_TypeChecker_Env.EraseUniverses; - FStar_TypeChecker_Env.Unascribe; - FStar_TypeChecker_Env.Exclude - FStar_TypeChecker_Env.Zeta] - env'.FStar_SMTEncoding_Env.tcenv - t2 in - let warn_compat - uu___24 = - let uu___25 - = - let uu___26 - = - FStar_Errors_Msg.text - "Using 'compat:2954' to use a permissive encoding of the subterm ordering on the codomain of a constructor." in - let uu___27 - = - let uu___28 - = - FStar_Errors_Msg.text - "This is deprecated and will be removed in a future version of F*." in - [uu___28] in - uu___26 - :: - uu___27 in - FStar_Errors.log_issue - FStar_Syntax_Syntax.hasRange_fv - fv - FStar_Errors_Codes.Warning_DeprecatedGeneric - () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic - uu___25) in - let uu___24 - = - FStar_Compiler_List.fold_left2 - (fun - uu___25 - -> - fun - formal -> - fun var - -> - match uu___25 - with - | - (codomain_prec_l, - cod_decls) - -> - let rec binder_and_codomain_type - t2 = - let t3 = - FStar_Syntax_Util.unrefine - t2 in - let uu___26 - = - let uu___27 - = - FStar_Syntax_Subst.compress - t3 in - uu___27.FStar_Syntax_Syntax.n in - match uu___26 - with - | - FStar_Syntax_Syntax.Tm_arrow - uu___27 - -> - let uu___28 - = - let uu___29 - = - FStar_Syntax_Util.unrefine - t3 in - FStar_Syntax_Util.arrow_formals_comp - uu___29 in - (match uu___28 - with - | - (bs, c) - -> - (match bs - with - | - [] -> - FStar_Pervasives_Native.None - | - uu___29 - when - let uu___30 - = - FStar_Syntax_Util.is_tot_or_gtot_comp - c in - Prims.op_Negation - uu___30 - -> - FStar_Pervasives_Native.None - | - uu___29 - -> - let uu___30 - = - FStar_Syntax_Util.is_lemma_comp - c in - if - uu___30 - then - FStar_Pervasives_Native.None - else - (let t4 = - FStar_Syntax_Util.unrefine - (FStar_Syntax_Util.comp_result - c) in - let t5 = - norm t4 in - let uu___32 - = - (FStar_Syntax_Syntax.is_type - t5) || - (FStar_Syntax_Util.is_sub_singleton - t5) in - if - uu___32 - then - FStar_Pervasives_Native.None - else - (let uu___34 - = - FStar_Syntax_Util.head_and_args_full - t5 in - match uu___34 - with - | - (head1, - uu___35) - -> - let uu___36 - = - let uu___37 - = - FStar_Syntax_Util.un_uinst - head1 in - uu___37.FStar_Syntax_Syntax.n in - (match uu___36 - with - | - FStar_Syntax_Syntax.Tm_fvar - fv1 -> - let uu___37 - = - FStar_Compiler_Util.for_some - (FStar_Syntax_Syntax.fv_eq_lid - fv1) - mutuals in - if - uu___37 - then - FStar_Pervasives_Native.Some - (bs, c) - else - (let uu___39 - = - let uu___40 - = - FStar_Options_Ext.get - "compat:2954" in - uu___40 - <> "" in - if - uu___39 - then - (warn_compat - (); - FStar_Pervasives_Native.Some - (bs, c)) - else - FStar_Pervasives_Native.None) - | - uu___37 - -> - let uu___38 - = - let uu___39 - = - FStar_Options_Ext.get - "compat:2954" in - uu___39 - <> "" in - if - uu___38 - then - (warn_compat - (); - FStar_Pervasives_Native.Some - (bs, c)) - else - FStar_Pervasives_Native.None))))) - | - uu___27 - -> - let uu___28 - = - FStar_Syntax_Util.head_and_args - t3 in - (match uu___28 - with - | - (head1, - uu___29) - -> - let t' = - norm t3 in - let uu___30 - = - FStar_Syntax_Util.head_and_args - t' in - (match uu___30 - with - | - (head', - uu___31) - -> - let uu___32 - = - FStar_TypeChecker_TermEqAndSimplify.eq_tm - env1.FStar_SMTEncoding_Env.tcenv - head1 - head' in - (match uu___32 - with - | - FStar_TypeChecker_TermEqAndSimplify.Equal - -> - FStar_Pervasives_Native.None - | - FStar_TypeChecker_TermEqAndSimplify.NotEqual - -> - binder_and_codomain_type - t' - | - uu___33 - -> - let uu___34 - = - let uu___35 - = - FStar_Syntax_Subst.compress - head1 in - uu___35.FStar_Syntax_Syntax.n in - (match uu___34 - with - | - FStar_Syntax_Syntax.Tm_fvar - uu___35 - -> - binder_and_codomain_type - t' - | - FStar_Syntax_Syntax.Tm_name - uu___35 - -> - binder_and_codomain_type - t' - | - FStar_Syntax_Syntax.Tm_uinst - uu___35 - -> - binder_and_codomain_type - t' - | - uu___35 - -> - FStar_Pervasives_Native.None)))) in - let uu___26 - = - binder_and_codomain_type - (formal.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - (match uu___26 - with - | - FStar_Pervasives_Native.None - -> - (codomain_prec_l, - cod_decls) - | - FStar_Pervasives_Native.Some - (bs, c) - -> - let uu___27 - = - FStar_SMTEncoding_EncodeTerm.encode_binders - FStar_Pervasives_Native.None - bs env' in - (match uu___27 - with - | - (bs', - guards', - _env', - bs_decls, - uu___28) - -> - let fun_app - = - let uu___29 - = - FStar_SMTEncoding_Util.mkFreeV - var in - FStar_SMTEncoding_EncodeTerm.mk_Apply - uu___29 - bs' in - let uu___29 - = - let uu___30 - = - let uu___31 - = - FStar_Ident.range_of_lid - d in - let uu___32 - = - let uu___33 - = - let uu___34 - = - let uu___35 - = - FStar_SMTEncoding_Util.mk_Precedes - lex_t - lex_t - fun_app - dapp1 in - [uu___35] in - [uu___34] in - let uu___34 - = - let uu___35 - = - let uu___36 - = - FStar_SMTEncoding_Util.mk_and_l - (ty_pred' - :: - guards') in - let uu___37 - = - FStar_SMTEncoding_Util.mk_Precedes - lex_t - lex_t - fun_app - dapp1 in - (uu___36, - uu___37) in - FStar_SMTEncoding_Util.mkImp - uu___35 in - (uu___33, - bs', - uu___34) in - FStar_SMTEncoding_Term.mkForall - uu___31 - uu___32 in - uu___30 - :: - codomain_prec_l in - (uu___29, - (FStar_Compiler_List.op_At - bs_decls - cod_decls))))) - ([], []) - formals' - vars' in - (match uu___24 - with - | - (codomain_prec_l, - cod_decls) - -> - (match codomain_prec_l - with - | - [] -> - ([], - cod_decls) - | - uu___25 - -> - let uu___26 - = - let uu___27 - = - let uu___28 - = - let uu___29 - = - let uu___30 - = - FStar_Ident.range_of_lid - d in - let uu___31 - = - let uu___32 - = - let uu___33 - = - FStar_SMTEncoding_Term.mk_fv - (fuel_var, - FStar_SMTEncoding_Term.Fuel_sort) in - FStar_SMTEncoding_Env.add_fuel - uu___33 - (FStar_Compiler_List.op_At - vars - arg_binders) in - let uu___33 - = - FStar_SMTEncoding_Util.mk_and_l - codomain_prec_l in - ([ - [ty_pred]], - uu___32, - uu___33) in - FStar_SMTEncoding_Term.mkForall - uu___30 - uu___31 in - (uu___29, - (FStar_Pervasives_Native.Some - "well-founded ordering on codomain"), - (Prims.strcat - "well_founded_ordering_on_codomain_" - ddconstrsym)) in - FStar_SMTEncoding_Util.mkAssume - uu___28 in - [uu___27] in - (uu___26, - cod_decls)))) in - (match uu___19 - with - | - (codomain_ordering, - codomain_decls) - -> - ((FStar_Compiler_List.op_At - arg_decls - codomain_decls), - (FStar_Compiler_List.op_At - [typing_inversion; - subterm_ordering] - codomain_ordering))))))) - | uu___11 -> - ((let uu___13 = - let uu___14 = - FStar_Class_Show.show - FStar_Ident.showable_lident - d in - let uu___15 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - head in - FStar_Compiler_Util.format2 - "Constructor %s builds an unexpected type %s" - uu___14 uu___15 in - FStar_Errors.log_issue - FStar_Syntax_Syntax.has_range_sigelt - se - FStar_Errors_Codes.Warning_ConstructorBuildsUnexpectedType - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___13)); - ([], []))) in - let uu___8 = encode_elim () in - (match uu___8 with - | (decls2, elim) -> - let data_cons_typing_intro_decl - = - let uu___9 = - match t_res_tm.FStar_SMTEncoding_Term.tm - with - | FStar_SMTEncoding_Term.App - (op, args) -> - let uu___10 = - FStar_Compiler_List.splitAt - n_tps args in - (match uu___10 with - | (targs, iargs) -> - let uu___11 = - let uu___12 = - FStar_Compiler_List.map - (fun uu___13 - -> - FStar_SMTEncoding_Env.fresh_fvar - env1.FStar_SMTEncoding_Env.current_module_name - "i" - FStar_SMTEncoding_Term.Term_sort) - iargs in - FStar_Compiler_List.split - uu___12 in - (match uu___11 with - | (fresh_ivars, - fresh_iargs) -> - let additional_guards - = - let uu___12 - = - FStar_Compiler_List.map2 - (fun a -> - fun - fresh_a - -> - FStar_SMTEncoding_Util.mkEq - (a, - fresh_a)) - iargs - fresh_iargs in - FStar_SMTEncoding_Util.mk_and_l - uu___12 in - let uu___12 = - FStar_SMTEncoding_Term.mk_HasTypeWithFuel - (FStar_Pervasives_Native.Some - fuel_tm) - dapp - { - FStar_SMTEncoding_Term.tm - = - (FStar_SMTEncoding_Term.App - (op, - (FStar_Compiler_List.op_At - targs - fresh_iargs))); - FStar_SMTEncoding_Term.freevars - = - (t_res_tm.FStar_SMTEncoding_Term.freevars); - FStar_SMTEncoding_Term.rng - = - (t_res_tm.FStar_SMTEncoding_Term.rng) - } in - let uu___13 = - let uu___14 - = - FStar_Compiler_List.map - (fun s -> - FStar_SMTEncoding_Term.mk_fv - (s, - FStar_SMTEncoding_Term.Term_sort)) - fresh_ivars in - FStar_Compiler_List.op_At - vars - uu___14 in - let uu___14 = - FStar_SMTEncoding_Util.mkAnd - (guard, - additional_guards) in - (uu___12, - uu___13, - uu___14))) - | uu___10 -> - (ty_pred', vars, guard) in - match uu___9 with - | (ty_pred'1, vars1, guard1) - -> - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Ident.range_of_lid - d in - let uu___13 = - let uu___14 = - let uu___15 = - FStar_SMTEncoding_Term.mk_fv - (fuel_var, - FStar_SMTEncoding_Term.Fuel_sort) in - FStar_SMTEncoding_Env.add_fuel - uu___15 vars1 in - let uu___15 = - FStar_SMTEncoding_Util.mkImp - (guard1, - ty_pred'1) in - ([[ty_pred'1]], - uu___14, uu___15) in - FStar_SMTEncoding_Term.mkForall - uu___12 uu___13 in - (uu___11, - (FStar_Pervasives_Native.Some - "data constructor typing intro"), - (Prims.strcat - "data_typing_intro_" - ddtok)) in - FStar_SMTEncoding_Util.mkAssume - uu___10 in - let g = - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = - let uu___17 = - let uu___18 - = - let uu___19 - = - FStar_Class_Show.show - FStar_Ident.showable_lident - d in - FStar_Compiler_Util.format1 - "data constructor proxy: %s" - uu___19 in - FStar_Pervasives_Native.Some - uu___18 in - (ddtok, [], - FStar_SMTEncoding_Term.Term_sort, - uu___17) in - FStar_SMTEncoding_Term.DeclFun - uu___16 in - [uu___15] in - FStar_Compiler_List.op_At - uu___14 - proxy_fresh in - FStar_SMTEncoding_Term.mk_decls_trivial - uu___13 in - let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = - let uu___17 = - FStar_SMTEncoding_Util.mkAssume - (tok_typing1, - (FStar_Pervasives_Native.Some - "typing for data constructor proxy"), - (Prims.strcat - "typing_tok_" - ddtok)) in - let uu___18 = - let uu___19 = - let uu___20 - = - let uu___21 - = - let uu___22 - = - FStar_Ident.range_of_lid - d in - let uu___23 - = - let uu___24 - = - FStar_SMTEncoding_Util.mkEq - (app, - dapp) in - ([[app]], - vars, - uu___24) in - FStar_SMTEncoding_Term.mkForall - uu___22 - uu___23 in - (uu___21, - (FStar_Pervasives_Native.Some - "equality for proxy"), - (Prims.strcat - "equality_tok_" - ddtok)) in - FStar_SMTEncoding_Util.mkAssume - uu___20 in - [uu___19; - data_cons_typing_intro_decl] in - uu___17 :: - uu___18 in - FStar_Compiler_List.op_At - uu___16 elim in - FStar_SMTEncoding_Term.mk_decls_trivial - uu___15 in - FStar_Compiler_List.op_At - decls_pred uu___14 in - FStar_Compiler_List.op_At - uu___12 uu___13 in - FStar_Compiler_List.op_At - decls3 uu___11 in - FStar_Compiler_List.op_At - decls2 uu___10 in - FStar_Compiler_List.op_At - binder_decls uu___9 in - let uu___9 = - let uu___10 = - FStar_SMTEncoding_Term.mk_decls_trivial - datacons in - FStar_Compiler_List.op_At - uu___10 g in - (uu___9, env1)))))))) -let rec (encode_sigelt : - FStar_SMTEncoding_Env.env_t -> - FStar_Syntax_Syntax.sigelt -> - (FStar_SMTEncoding_Term.decls_t * FStar_SMTEncoding_Env.env_t)) - = - fun env -> - fun se -> - let nm = FStar_Syntax_Print.sigelt_to_string_short se in - let uu___ = - let uu___1 = - let uu___2 = FStar_Syntax_Print.sigelt_to_string_short se in - FStar_Compiler_Util.format1 - "While encoding top-level declaration `%s`" uu___2 in - FStar_Errors.with_ctx uu___1 (fun uu___2 -> encode_sigelt' env se) in - match uu___ with - | (g, env1) -> - let g1 = - match g with - | [] -> - ((let uu___2 = FStar_Compiler_Effect.op_Bang dbg_SMTEncoding in - if uu___2 - then - FStar_Compiler_Util.print1 "Skipped encoding of %s\n" nm - else ()); - (let uu___2 = - let uu___3 = - let uu___4 = - FStar_Compiler_Util.format1 "" nm in - FStar_SMTEncoding_Term.Caption uu___4 in - [uu___3] in - FStar_SMTEncoding_Term.mk_decls_trivial uu___2)) - | uu___1 -> - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Compiler_Util.format1 "" nm in - FStar_SMTEncoding_Term.Caption uu___5 in - [uu___4] in - FStar_SMTEncoding_Term.mk_decls_trivial uu___3 in - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Compiler_Util.format1 "" nm in - FStar_SMTEncoding_Term.Caption uu___7 in - [uu___6] in - FStar_SMTEncoding_Term.mk_decls_trivial uu___5 in - FStar_Compiler_List.op_At g uu___4 in - FStar_Compiler_List.op_At uu___2 uu___3 in - (g1, env1) -and (encode_sigelt' : - FStar_SMTEncoding_Env.env_t -> - FStar_Syntax_Syntax.sigelt -> - (FStar_SMTEncoding_Term.decls_t * FStar_SMTEncoding_Env.env_t)) - = - fun env -> - fun se -> - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_SMTEncoding in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_sigelt se in - FStar_Compiler_Util.print1 "@@@Encoding sigelt %s\n" uu___2 - else ()); - (let is_opaque_to_smt t = - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress t in - uu___2.FStar_Syntax_Syntax.n in - match uu___1 with - | FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_string - (s, uu___2)) -> s = "opaque_to_smt" - | uu___2 -> false in - let is_uninterpreted_by_smt t = - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress t in - uu___2.FStar_Syntax_Syntax.n in - match uu___1 with - | FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_string - (s, uu___2)) -> s = "uninterpreted_by_smt" - | uu___2 -> false in - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_splice uu___1 -> - failwith "impossible -- splice should have been removed by Tc.fs" - | FStar_Syntax_Syntax.Sig_fail uu___1 -> - failwith - "impossible -- Sig_fail should have been removed by Tc.fs" - | FStar_Syntax_Syntax.Sig_pragma uu___1 -> ([], env) - | FStar_Syntax_Syntax.Sig_effect_abbrev uu___1 -> ([], env) - | FStar_Syntax_Syntax.Sig_sub_effect uu___1 -> ([], env) - | FStar_Syntax_Syntax.Sig_polymonadic_bind uu___1 -> ([], env) - | FStar_Syntax_Syntax.Sig_polymonadic_subcomp uu___1 -> ([], env) - | FStar_Syntax_Syntax.Sig_new_effect ed -> - let uu___1 = - let uu___2 = - FStar_SMTEncoding_Util.is_smt_reifiable_effect - env.FStar_SMTEncoding_Env.tcenv ed.FStar_Syntax_Syntax.mname in - Prims.op_Negation uu___2 in - if uu___1 - then ([], env) - else - (let close_effect_params tm = - match ed.FStar_Syntax_Syntax.binders with - | [] -> tm - | uu___3 -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = - (ed.FStar_Syntax_Syntax.binders); - FStar_Syntax_Syntax.body = tm; - FStar_Syntax_Syntax.rc_opt = - (FStar_Pervasives_Native.Some - (FStar_Syntax_Util.mk_residual_comp - FStar_Parser_Const.effect_Tot_lid - FStar_Pervasives_Native.None - [FStar_Syntax_Syntax.TOTAL])) - }) tm.FStar_Syntax_Syntax.pos in - let encode_action env1 a = - let action_defn = - let uu___3 = - close_effect_params a.FStar_Syntax_Syntax.action_defn in - norm_before_encoding env1 uu___3 in - let uu___3 = - FStar_Syntax_Util.arrow_formals_comp - a.FStar_Syntax_Syntax.action_typ in - match uu___3 with - | (formals, uu___4) -> - let arity = FStar_Compiler_List.length formals in - let uu___5 = - FStar_SMTEncoding_Env.new_term_constant_and_tok_from_lid - env1 a.FStar_Syntax_Syntax.action_name arity in - (match uu___5 with - | (aname, atok, env2) -> - let uu___6 = - FStar_SMTEncoding_EncodeTerm.encode_term - action_defn env2 in - (match uu___6 with - | (tm, decls) -> - let a_decls = - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Compiler_List.map - (fun uu___10 -> - FStar_SMTEncoding_Term.Term_sort) - formals in - (aname, uu___9, - FStar_SMTEncoding_Term.Term_sort, - (FStar_Pervasives_Native.Some "Action")) in - FStar_SMTEncoding_Term.DeclFun uu___8 in - [uu___7; - FStar_SMTEncoding_Term.DeclFun - (atok, [], - FStar_SMTEncoding_Term.Term_sort, - (FStar_Pervasives_Native.Some - "Action token"))] in - let uu___7 = - let aux uu___8 uu___9 = - match (uu___8, uu___9) with - | ({ FStar_Syntax_Syntax.binder_bv = bv; - FStar_Syntax_Syntax.binder_qual = - uu___10; - FStar_Syntax_Syntax.binder_positivity - = uu___11; - FStar_Syntax_Syntax.binder_attrs = - uu___12;_}, - (env3, acc_sorts, acc)) -> - let uu___13 = - FStar_SMTEncoding_Env.gen_term_var - env3 bv in - (match uu___13 with - | (xxsym, xx, env4) -> - let uu___14 = - let uu___15 = - FStar_SMTEncoding_Term.mk_fv - (xxsym, - FStar_SMTEncoding_Term.Term_sort) in - uu___15 :: acc_sorts in - (env4, uu___14, (xx :: acc))) in - FStar_Compiler_List.fold_right aux formals - (env2, [], []) in - (match uu___7 with - | (uu___8, xs_sorts, xs) -> - let app = - FStar_SMTEncoding_Util.mkApp (aname, xs) in - let a_eq = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Ident.range_of_lid - a.FStar_Syntax_Syntax.action_name in - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - FStar_SMTEncoding_EncodeTerm.mk_Apply - tm xs_sorts in - (app, uu___15) in - FStar_SMTEncoding_Util.mkEq - uu___14 in - ([[app]], xs_sorts, uu___13) in - FStar_SMTEncoding_Term.mkForall - uu___11 uu___12 in - (uu___10, - (FStar_Pervasives_Native.Some - "Action equality"), - (Prims.strcat aname "_equality")) in - FStar_SMTEncoding_Util.mkAssume uu___9 in - let tok_correspondence = - let tok_term = - let uu___9 = - FStar_SMTEncoding_Term.mk_fv - (atok, - FStar_SMTEncoding_Term.Term_sort) in - FStar_SMTEncoding_Util.mkFreeV uu___9 in - let tok_app = - FStar_SMTEncoding_EncodeTerm.mk_Apply - tok_term xs_sorts in - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Ident.range_of_lid - a.FStar_Syntax_Syntax.action_name in - let uu___12 = - let uu___13 = - FStar_SMTEncoding_Util.mkEq - (tok_app, app) in - ([[tok_app]], xs_sorts, uu___13) in - FStar_SMTEncoding_Term.mkForall - uu___11 uu___12 in - (uu___10, - (FStar_Pervasives_Native.Some - "Action token correspondence"), - (Prims.strcat aname - "_token_correspondence")) in - FStar_SMTEncoding_Util.mkAssume uu___9 in - let uu___9 = - let uu___10 = - FStar_SMTEncoding_Term.mk_decls_trivial - (FStar_Compiler_List.op_At a_decls - [a_eq; tok_correspondence]) in - FStar_Compiler_List.op_At decls uu___10 in - (env2, uu___9)))) in - let uu___3 = - FStar_Compiler_Util.fold_map encode_action env - ed.FStar_Syntax_Syntax.actions in - match uu___3 with - | (env1, decls2) -> - ((FStar_Compiler_List.flatten decls2), env1)) - | FStar_Syntax_Syntax.Sig_declare_typ - { FStar_Syntax_Syntax.lid2 = lid; - FStar_Syntax_Syntax.us2 = uu___1; - FStar_Syntax_Syntax.t2 = uu___2;_} - when FStar_Ident.lid_equals lid FStar_Parser_Const.precedes_lid -> - let uu___3 = - FStar_SMTEncoding_Env.new_term_constant_and_tok_from_lid env lid - (Prims.of_int (4)) in - (match uu___3 with | (tname, ttok, env1) -> ([], env1)) - | FStar_Syntax_Syntax.Sig_declare_typ - { FStar_Syntax_Syntax.lid2 = lid; FStar_Syntax_Syntax.us2 = us; - FStar_Syntax_Syntax.t2 = t;_} - -> - let quals = se.FStar_Syntax_Syntax.sigquals in - let will_encode_definition = - let uu___1 = - FStar_Compiler_Util.for_some - (fun uu___2 -> - match uu___2 with - | FStar_Syntax_Syntax.Assumption -> true - | FStar_Syntax_Syntax.Projector uu___3 -> true - | FStar_Syntax_Syntax.Discriminator uu___3 -> true - | FStar_Syntax_Syntax.Irreducible -> true - | uu___3 -> false) quals in - Prims.op_Negation uu___1 in - if will_encode_definition - then ([], env) - else - (let fv = - FStar_Syntax_Syntax.lid_as_fv lid - FStar_Pervasives_Native.None in - let uu___2 = - let uu___3 = - FStar_Compiler_Util.for_some is_uninterpreted_by_smt - se.FStar_Syntax_Syntax.sigattrs in - encode_top_level_val uu___3 env us fv t quals in - match uu___2 with - | (decls, env1) -> - let tname = FStar_Ident.string_of_lid lid in - let tsym = - let uu___3 = - FStar_SMTEncoding_Env.try_lookup_free_var env1 lid in - FStar_Compiler_Option.get uu___3 in - let uu___3 = - let uu___4 = - let uu___5 = - primitive_type_axioms - env1.FStar_SMTEncoding_Env.tcenv lid tname tsym in - FStar_SMTEncoding_Term.mk_decls_trivial uu___5 in - FStar_Compiler_List.op_At decls uu___4 in - (uu___3, env1)) - | FStar_Syntax_Syntax.Sig_assume - { FStar_Syntax_Syntax.lid3 = l; FStar_Syntax_Syntax.us3 = us; - FStar_Syntax_Syntax.phi1 = f;_} - -> - let uu___1 = FStar_Syntax_Subst.open_univ_vars us f in - (match uu___1 with - | (uvs, f1) -> - let env1 = - let uu___2 = - FStar_TypeChecker_Env.push_univ_vars - env.FStar_SMTEncoding_Env.tcenv uvs in - { - FStar_SMTEncoding_Env.bvar_bindings = - (env.FStar_SMTEncoding_Env.bvar_bindings); - FStar_SMTEncoding_Env.fvar_bindings = - (env.FStar_SMTEncoding_Env.fvar_bindings); - FStar_SMTEncoding_Env.depth = - (env.FStar_SMTEncoding_Env.depth); - FStar_SMTEncoding_Env.tcenv = uu___2; - FStar_SMTEncoding_Env.warn = - (env.FStar_SMTEncoding_Env.warn); - FStar_SMTEncoding_Env.nolabels = - (env.FStar_SMTEncoding_Env.nolabels); - FStar_SMTEncoding_Env.use_zfuel_name = - (env.FStar_SMTEncoding_Env.use_zfuel_name); - FStar_SMTEncoding_Env.encode_non_total_function_typ = - (env.FStar_SMTEncoding_Env.encode_non_total_function_typ); - FStar_SMTEncoding_Env.current_module_name = - (env.FStar_SMTEncoding_Env.current_module_name); - FStar_SMTEncoding_Env.encoding_quantifier = - (env.FStar_SMTEncoding_Env.encoding_quantifier); - FStar_SMTEncoding_Env.global_cache = - (env.FStar_SMTEncoding_Env.global_cache) - } in - let f2 = norm_before_encoding env1 f1 in - let uu___2 = - FStar_SMTEncoding_EncodeTerm.encode_formula f2 env1 in - (match uu___2 with - | (f3, decls) -> - let g = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Class_Show.show - FStar_Ident.showable_lident l in - FStar_Compiler_Util.format1 "Assumption: %s" - uu___8 in - FStar_Pervasives_Native.Some uu___7 in - let uu___7 = - let uu___8 = - let uu___9 = FStar_Ident.string_of_lid l in - Prims.strcat "assumption_" uu___9 in - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.mk_unique - uu___8 in - (f3, uu___6, uu___7) in - FStar_SMTEncoding_Util.mkAssume uu___5 in - [uu___4] in - FStar_SMTEncoding_Term.mk_decls_trivial uu___3 in - ((FStar_Compiler_List.op_At decls g), env1))) - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = lbs; - FStar_Syntax_Syntax.lids1 = uu___1;_} - when - (FStar_Compiler_List.contains FStar_Syntax_Syntax.Irreducible - se.FStar_Syntax_Syntax.sigquals) - || - (FStar_Compiler_Util.for_some is_opaque_to_smt - se.FStar_Syntax_Syntax.sigattrs) - -> - let attrs = se.FStar_Syntax_Syntax.sigattrs in - let uu___2 = - FStar_Compiler_Util.fold_map - (fun env1 -> - fun lb -> - let lid = - let uu___3 = - let uu___4 = - FStar_Compiler_Util.right - lb.FStar_Syntax_Syntax.lbname in - uu___4.FStar_Syntax_Syntax.fv_name in - uu___3.FStar_Syntax_Syntax.v in - let uu___3 = - let uu___4 = - FStar_TypeChecker_Env.try_lookup_val_decl - env1.FStar_SMTEncoding_Env.tcenv lid in - FStar_Compiler_Option.isNone uu___4 in - if uu___3 - then - let val_decl = - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_declare_typ - { - FStar_Syntax_Syntax.lid2 = lid; - FStar_Syntax_Syntax.us2 = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.t2 = - (lb.FStar_Syntax_Syntax.lbtyp) - }); - FStar_Syntax_Syntax.sigrng = - (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (FStar_Syntax_Syntax.Irreducible :: - (se.FStar_Syntax_Syntax.sigquals)); - FStar_Syntax_Syntax.sigmeta = - (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se.FStar_Syntax_Syntax.sigopts) - } in - let uu___4 = encode_sigelt' env1 val_decl in - match uu___4 with | (decls, env2) -> (env2, decls) - else (env1, [])) env (FStar_Pervasives_Native.snd lbs) in - (match uu___2 with - | (env1, decls) -> ((FStar_Compiler_List.flatten decls), env1)) - | FStar_Syntax_Syntax.Sig_let - { - FStar_Syntax_Syntax.lbs1 = - (uu___1, - { FStar_Syntax_Syntax.lbname = FStar_Pervasives.Inr b2t; - FStar_Syntax_Syntax.lbunivs = uu___2; - FStar_Syntax_Syntax.lbtyp = uu___3; - FStar_Syntax_Syntax.lbeff = uu___4; - FStar_Syntax_Syntax.lbdef = uu___5; - FStar_Syntax_Syntax.lbattrs = uu___6; - FStar_Syntax_Syntax.lbpos = uu___7;_}::[]); - FStar_Syntax_Syntax.lids1 = uu___8;_} - when FStar_Syntax_Syntax.fv_eq_lid b2t FStar_Parser_Const.b2t_lid - -> - let uu___9 = - FStar_SMTEncoding_Env.new_term_constant_and_tok_from_lid env - (b2t.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - Prims.int_one in - (match uu___9 with - | (tname, ttok, env1) -> - let xx = - FStar_SMTEncoding_Term.mk_fv - ("x", FStar_SMTEncoding_Term.Term_sort) in - let x = FStar_SMTEncoding_Util.mkFreeV xx in - let b2t_x = FStar_SMTEncoding_Util.mkApp ("Prims.b2t", [x]) in - let valid_b2t_x = - FStar_SMTEncoding_Util.mkApp ("Valid", [b2t_x]) in - let bool_ty = - let uu___10 = - FStar_Syntax_Syntax.withsort FStar_Parser_Const.bool_lid in - FStar_SMTEncoding_Env.lookup_free_var env1 uu___10 in - let decls = - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = FStar_Syntax_Syntax.range_of_fv b2t in - let uu___15 = - let uu___16 = - let uu___17 = - let uu___18 = - FStar_SMTEncoding_Util.mkApp - ((FStar_Pervasives_Native.snd - FStar_SMTEncoding_Term.boxBoolFun), - [x]) in - (valid_b2t_x, uu___18) in - FStar_SMTEncoding_Util.mkEq uu___17 in - ([[b2t_x]], [xx], uu___16) in - FStar_SMTEncoding_Term.mkForall uu___14 uu___15 in - (uu___13, (FStar_Pervasives_Native.Some "b2t def"), - "b2t_def") in - FStar_SMTEncoding_Util.mkAssume uu___12 in - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = FStar_Syntax_Syntax.range_of_fv b2t in - let uu___17 = - let uu___18 = - let uu___19 = - let uu___20 = - FStar_SMTEncoding_Term.mk_HasType x - bool_ty in - let uu___21 = - FStar_SMTEncoding_Term.mk_HasType b2t_x - FStar_SMTEncoding_Term.mk_Term_type in - (uu___20, uu___21) in - FStar_SMTEncoding_Util.mkImp uu___19 in - ([[b2t_x]], [xx], uu___18) in - FStar_SMTEncoding_Term.mkForall uu___16 uu___17 in - (uu___15, - (FStar_Pervasives_Native.Some "b2t typing"), - "b2t_typing") in - FStar_SMTEncoding_Util.mkAssume uu___14 in - [uu___13] in - uu___11 :: uu___12 in - (FStar_SMTEncoding_Term.DeclFun - (tname, [FStar_SMTEncoding_Term.Term_sort], - FStar_SMTEncoding_Term.Term_sort, - FStar_Pervasives_Native.None)) - :: uu___10 in - let uu___10 = FStar_SMTEncoding_Term.mk_decls_trivial decls in - (uu___10, env1)) - | FStar_Syntax_Syntax.Sig_let uu___1 when - FStar_Compiler_Util.for_some - (fun uu___2 -> - match uu___2 with - | FStar_Syntax_Syntax.Discriminator uu___3 -> true - | uu___3 -> false) se.FStar_Syntax_Syntax.sigquals - -> - ((let uu___3 = FStar_Compiler_Effect.op_Bang dbg_SMTEncoding in - if uu___3 - then - let uu___4 = FStar_Syntax_Print.sigelt_to_string_short se in - FStar_Compiler_Util.print1 "Not encoding discriminator '%s'\n" - uu___4 - else ()); - ([], env)) - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = uu___1; - FStar_Syntax_Syntax.lids1 = lids;_} - when - (FStar_Compiler_Util.for_some - (fun l -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_Ident.ns_of_lid l in - FStar_Compiler_List.hd uu___4 in - FStar_Ident.string_of_id uu___3 in - uu___2 = "Prims") lids) - && - (FStar_Compiler_Util.for_some - (fun uu___2 -> - match uu___2 with - | FStar_Syntax_Syntax.Unfold_for_unification_and_vcgen -> - true - | uu___3 -> false) se.FStar_Syntax_Syntax.sigquals) - -> - ((let uu___3 = FStar_Compiler_Effect.op_Bang dbg_SMTEncoding in - if uu___3 - then - let uu___4 = FStar_Syntax_Print.sigelt_to_string_short se in - FStar_Compiler_Util.print1 - "Not encoding unfold let from Prims '%s'\n" uu___4 - else ()); - ([], env)) - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (false, lb::[]); - FStar_Syntax_Syntax.lids1 = uu___1;_} - when - FStar_Compiler_Util.for_some - (fun uu___2 -> - match uu___2 with - | FStar_Syntax_Syntax.Projector uu___3 -> true - | uu___3 -> false) se.FStar_Syntax_Syntax.sigquals - -> - let fv = FStar_Compiler_Util.right lb.FStar_Syntax_Syntax.lbname in - let l = (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - let uu___2 = FStar_SMTEncoding_Env.try_lookup_free_var env l in - (match uu___2 with - | FStar_Pervasives_Native.Some uu___3 -> ([], env) - | FStar_Pervasives_Native.None -> - let se1 = - let uu___3 = FStar_Ident.range_of_lid l in - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_declare_typ - { - FStar_Syntax_Syntax.lid2 = l; - FStar_Syntax_Syntax.us2 = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.t2 = - (lb.FStar_Syntax_Syntax.lbtyp) - }); - FStar_Syntax_Syntax.sigrng = uu___3; - FStar_Syntax_Syntax.sigquals = - (se.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se.FStar_Syntax_Syntax.sigopts) - } in - encode_sigelt env se1) - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (is_rec, bindings); - FStar_Syntax_Syntax.lids1 = uu___1;_} - -> - let bindings1 = - FStar_Compiler_List.map - (fun lb -> - let def = - norm_before_encoding_us env - lb.FStar_Syntax_Syntax.lbunivs - lb.FStar_Syntax_Syntax.lbdef in - let typ = - norm_before_encoding_us env - lb.FStar_Syntax_Syntax.lbunivs - lb.FStar_Syntax_Syntax.lbtyp in - { - FStar_Syntax_Syntax.lbname = - (lb.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = typ; - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = def; - FStar_Syntax_Syntax.lbattrs = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - }) bindings in - encode_top_level_let env (is_rec, bindings1) - se.FStar_Syntax_Syntax.sigquals - | FStar_Syntax_Syntax.Sig_bundle - { FStar_Syntax_Syntax.ses = ses; - FStar_Syntax_Syntax.lids = uu___1;_} - -> - let uu___2 = - FStar_Compiler_List.fold_left - (fun uu___3 -> - fun se1 -> - match uu___3 with - | (g, env1) -> - let uu___4 = - match se1.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ uu___5 -> - encode_sig_inductive env1 se1 - | FStar_Syntax_Syntax.Sig_datacon uu___5 -> - encode_datacon env1 se1 - | uu___5 -> encode_sigelt env1 se1 in - (match uu___4 with - | (g', env2) -> - ((FStar_Compiler_List.op_At g g'), env2))) - ([], env) ses in - (match uu___2 with - | (g, env1) -> - let uu___3 = - FStar_Compiler_List.fold_left - (fun uu___4 -> - fun elt -> - match uu___4 with - | (g', inversions) -> - let uu___5 = - FStar_Compiler_List.partition - (fun uu___6 -> - match uu___6 with - | FStar_SMTEncoding_Term.Assume - { - FStar_SMTEncoding_Term.assumption_term - = uu___7; - FStar_SMTEncoding_Term.assumption_caption - = FStar_Pervasives_Native.Some - "inversion axiom"; - FStar_SMTEncoding_Term.assumption_name - = uu___8; - FStar_SMTEncoding_Term.assumption_fact_ids - = uu___9; - FStar_SMTEncoding_Term.assumption_free_names - = uu___10;_} - -> false - | uu___7 -> true) - elt.FStar_SMTEncoding_Term.decls in - (match uu___5 with - | (elt_g', elt_inversions) -> - ((FStar_Compiler_List.op_At g' - [{ - FStar_SMTEncoding_Term.sym_name = - (elt.FStar_SMTEncoding_Term.sym_name); - FStar_SMTEncoding_Term.key = - (elt.FStar_SMTEncoding_Term.key); - FStar_SMTEncoding_Term.decls = - elt_g'; - FStar_SMTEncoding_Term.a_names = - (elt.FStar_SMTEncoding_Term.a_names) - }]), - (FStar_Compiler_List.op_At inversions - elt_inversions)))) ([], []) g in - (match uu___3 with - | (g', inversions) -> - let uu___4 = - FStar_Compiler_List.fold_left - (fun uu___5 -> - fun elt -> - match uu___5 with - | (decls, elts, rest) -> - let uu___6 = - (FStar_Compiler_Util.is_some - elt.FStar_SMTEncoding_Term.key) - && - (FStar_Compiler_List.existsb - (fun uu___7 -> - match uu___7 with - | FStar_SMTEncoding_Term.DeclFun - uu___8 -> true - | uu___8 -> false) - elt.FStar_SMTEncoding_Term.decls) in - if uu___6 - then - (decls, - (FStar_Compiler_List.op_At elts [elt]), - rest) - else - (let uu___8 = - FStar_Compiler_List.partition - (fun uu___9 -> - match uu___9 with - | FStar_SMTEncoding_Term.DeclFun - uu___10 -> true - | uu___10 -> false) - elt.FStar_SMTEncoding_Term.decls in - match uu___8 with - | (elt_decls, elt_rest) -> - ((FStar_Compiler_List.op_At decls - elt_decls), elts, - (FStar_Compiler_List.op_At rest - [{ - FStar_SMTEncoding_Term.sym_name - = - (elt.FStar_SMTEncoding_Term.sym_name); - FStar_SMTEncoding_Term.key = - (elt.FStar_SMTEncoding_Term.key); - FStar_SMTEncoding_Term.decls - = elt_rest; - FStar_SMTEncoding_Term.a_names - = - (elt.FStar_SMTEncoding_Term.a_names) - }])))) ([], [], []) g' in - (match uu___4 with - | (decls, elts, rest) -> - let uu___5 = - let uu___6 = - FStar_SMTEncoding_Term.mk_decls_trivial decls in - let uu___7 = - let uu___8 = - let uu___9 = - FStar_SMTEncoding_Term.mk_decls_trivial - inversions in - FStar_Compiler_List.op_At rest uu___9 in - FStar_Compiler_List.op_At elts uu___8 in - FStar_Compiler_List.op_At uu___6 uu___7 in - (uu___5, env1))))) -let (encode_env_bindings : - FStar_SMTEncoding_Env.env_t -> - FStar_Syntax_Syntax.binding Prims.list -> - (FStar_SMTEncoding_Term.decls_t * FStar_SMTEncoding_Env.env_t)) - = - fun env -> - fun bindings -> - let encode_binding b uu___ = - match uu___ with - | (i, decls, env1) -> - (match b with - | FStar_Syntax_Syntax.Binding_univ uu___1 -> - ((i + Prims.int_one), decls, env1) - | FStar_Syntax_Syntax.Binding_var x -> - let t1 = - norm_before_encoding env1 x.FStar_Syntax_Syntax.sort in - ((let uu___2 = FStar_Compiler_Effect.op_Bang dbg_SMTEncoding in - if uu___2 - then - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_bv x in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - x.FStar_Syntax_Syntax.sort in - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - t1 in - FStar_Compiler_Util.print3 "Normalized %s : %s to %s\n" - uu___3 uu___4 uu___5 - else ()); - (let uu___2 = - FStar_SMTEncoding_EncodeTerm.encode_term t1 env1 in - match uu___2 with - | (t, decls') -> - let t_hash = FStar_SMTEncoding_Term.hash_of_term t in - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Compiler_Util.digest_of_string t_hash in - Prims.strcat uu___6 - (Prims.strcat "_" (Prims.string_of_int i)) in - Prims.strcat "x_" uu___5 in - FStar_SMTEncoding_Env.new_term_constant_from_string - env1 x uu___4 in - (match uu___3 with - | (xxsym, xx, env') -> - let t2 = - FStar_SMTEncoding_Term.mk_HasTypeWithFuel - FStar_Pervasives_Native.None xx t in - let caption = - let uu___4 = FStar_Options.log_queries () in - if uu___4 - then - let uu___5 = - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_bv x in - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - x.FStar_Syntax_Syntax.sort in - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.format3 "%s : %s (%s)" - uu___6 uu___7 uu___8 in - FStar_Pervasives_Native.Some uu___5 - else FStar_Pervasives_Native.None in - let ax = - let a_name = Prims.strcat "binder_" xxsym in - FStar_SMTEncoding_Util.mkAssume - (t2, (FStar_Pervasives_Native.Some a_name), - a_name) in - let g = - let uu___4 = - FStar_SMTEncoding_Term.mk_decls_trivial - [FStar_SMTEncoding_Term.DeclFun - (xxsym, [], - FStar_SMTEncoding_Term.Term_sort, - caption)] in - let uu___5 = - let uu___6 = - FStar_SMTEncoding_Term.mk_decls_trivial - [ax] in - FStar_Compiler_List.op_At decls' uu___6 in - FStar_Compiler_List.op_At uu___4 uu___5 in - ((i + Prims.int_one), - (FStar_Compiler_List.op_At decls g), env')))) - | FStar_Syntax_Syntax.Binding_lid (x, (uu___1, t)) -> - let t_norm = norm_before_encoding env1 t in - let fv = - FStar_Syntax_Syntax.lid_as_fv x - FStar_Pervasives_Native.None in - let uu___2 = encode_free_var false env1 fv t t_norm [] in - (match uu___2 with - | (g, env') -> - ((i + Prims.int_one), - (FStar_Compiler_List.op_At decls g), env'))) in - let uu___ = - FStar_Compiler_List.fold_right encode_binding bindings - (Prims.int_zero, [], env) in - match uu___ with | (uu___1, decls, env1) -> (decls, env1) -let (encode_labels : - FStar_SMTEncoding_Term.error_label Prims.list -> - (FStar_SMTEncoding_Term.decl Prims.list * FStar_SMTEncoding_Term.decl - Prims.list)) - = - fun labs -> - let prefix = - FStar_Compiler_List.map - (fun uu___ -> - match uu___ with - | (l, uu___1, uu___2) -> - let uu___3 = - let uu___4 = FStar_SMTEncoding_Term.fv_name l in - (uu___4, [], FStar_SMTEncoding_Term.Bool_sort, - FStar_Pervasives_Native.None) in - FStar_SMTEncoding_Term.DeclFun uu___3) labs in - let suffix = - FStar_Compiler_List.collect - (fun uu___ -> - match uu___ with - | (l, uu___1, uu___2) -> - let uu___3 = - let uu___4 = FStar_SMTEncoding_Term.fv_name l in - FStar_SMTEncoding_Term.Echo uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = FStar_SMTEncoding_Util.mkFreeV l in - FStar_SMTEncoding_Term.Eval uu___6 in - [uu___5] in - uu___3 :: uu___4) labs in - (prefix, suffix) -let (last_env : - FStar_SMTEncoding_Env.env_t Prims.list FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref [] -let (init_env : FStar_TypeChecker_Env.env -> unit) = - fun tcenv -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Compiler_Util.psmap_empty () in - let uu___3 = - let uu___4 = FStar_Compiler_Util.psmap_empty () in (uu___4, []) in - let uu___4 = - let uu___5 = FStar_TypeChecker_Env.current_module tcenv in - FStar_Ident.string_of_lid uu___5 in - let uu___5 = FStar_Compiler_Util.smap_create (Prims.of_int (100)) in - { - FStar_SMTEncoding_Env.bvar_bindings = uu___2; - FStar_SMTEncoding_Env.fvar_bindings = uu___3; - FStar_SMTEncoding_Env.depth = Prims.int_zero; - FStar_SMTEncoding_Env.tcenv = tcenv; - FStar_SMTEncoding_Env.warn = true; - FStar_SMTEncoding_Env.nolabels = false; - FStar_SMTEncoding_Env.use_zfuel_name = false; - FStar_SMTEncoding_Env.encode_non_total_function_typ = true; - FStar_SMTEncoding_Env.current_module_name = uu___4; - FStar_SMTEncoding_Env.encoding_quantifier = false; - FStar_SMTEncoding_Env.global_cache = uu___5 - } in - [uu___1] in - FStar_Compiler_Effect.op_Colon_Equals last_env uu___ -let (get_env : - FStar_Ident.lident -> - FStar_TypeChecker_Env.env -> FStar_SMTEncoding_Env.env_t) - = - fun cmn -> - fun tcenv -> - let uu___ = FStar_Compiler_Effect.op_Bang last_env in - match uu___ with - | [] -> failwith "No env; call init first!" - | e::uu___1 -> - let uu___2 = FStar_Ident.string_of_lid cmn in - { - FStar_SMTEncoding_Env.bvar_bindings = - (e.FStar_SMTEncoding_Env.bvar_bindings); - FStar_SMTEncoding_Env.fvar_bindings = - (e.FStar_SMTEncoding_Env.fvar_bindings); - FStar_SMTEncoding_Env.depth = (e.FStar_SMTEncoding_Env.depth); - FStar_SMTEncoding_Env.tcenv = tcenv; - FStar_SMTEncoding_Env.warn = (e.FStar_SMTEncoding_Env.warn); - FStar_SMTEncoding_Env.nolabels = - (e.FStar_SMTEncoding_Env.nolabels); - FStar_SMTEncoding_Env.use_zfuel_name = - (e.FStar_SMTEncoding_Env.use_zfuel_name); - FStar_SMTEncoding_Env.encode_non_total_function_typ = - (e.FStar_SMTEncoding_Env.encode_non_total_function_typ); - FStar_SMTEncoding_Env.current_module_name = uu___2; - FStar_SMTEncoding_Env.encoding_quantifier = - (e.FStar_SMTEncoding_Env.encoding_quantifier); - FStar_SMTEncoding_Env.global_cache = - (e.FStar_SMTEncoding_Env.global_cache) - } -let (set_env : FStar_SMTEncoding_Env.env_t -> unit) = - fun env -> - let uu___ = FStar_Compiler_Effect.op_Bang last_env in - match uu___ with - | [] -> failwith "Empty env stack" - | uu___1::tl -> - FStar_Compiler_Effect.op_Colon_Equals last_env (env :: tl) -let (get_current_env : - FStar_TypeChecker_Env.env -> FStar_SMTEncoding_Env.env_t) = - fun tcenv -> - let uu___ = FStar_TypeChecker_Env.current_module tcenv in - get_env uu___ tcenv -let (push_env : unit -> unit) = - fun uu___ -> - let uu___1 = FStar_Compiler_Effect.op_Bang last_env in - match uu___1 with - | [] -> failwith "Empty env stack" - | hd::tl -> - let top = copy_env hd in - FStar_Compiler_Effect.op_Colon_Equals last_env (top :: hd :: tl) -let (pop_env : unit -> unit) = - fun uu___ -> - let uu___1 = FStar_Compiler_Effect.op_Bang last_env in - match uu___1 with - | [] -> failwith "Popping an empty stack" - | uu___2::tl -> FStar_Compiler_Effect.op_Colon_Equals last_env tl -let (snapshot_env : unit -> (Prims.int * unit)) = - fun uu___ -> FStar_Common.snapshot push_env last_env () -let (rollback_env : Prims.int FStar_Pervasives_Native.option -> unit) = - fun depth -> FStar_Common.rollback pop_env last_env depth -let (init : FStar_TypeChecker_Env.env -> unit) = - fun tcenv -> - init_env tcenv; - FStar_SMTEncoding_Z3.giveZ3 [FStar_SMTEncoding_Term.DefPrelude] -let (snapshot_encoding : Prims.string -> encoding_depth) = - fun msg -> - FStar_Compiler_Util.atomically - (fun uu___ -> - let uu___1 = snapshot_env () in - match uu___1 with - | (env_depth, ()) -> - let uu___2 = - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.snapshot () in - (match uu___2 with - | (varops_depth, ()) -> (env_depth, varops_depth))) -let (rollback_encoding : - Prims.string -> encoding_depth FStar_Pervasives_Native.option -> unit) = - fun msg -> - fun depth -> - FStar_Compiler_Util.atomically - (fun uu___ -> - let uu___1 = - match depth with - | FStar_Pervasives_Native.Some (s1, s2) -> - ((FStar_Pervasives_Native.Some s1), - (FStar_Pervasives_Native.Some s2)) - | FStar_Pervasives_Native.None -> - (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) in - match uu___1 with - | (env_depth, varops_depth) -> - (rollback_env env_depth; - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.rollback - varops_depth)) -let (push_encoding_state : Prims.string -> unit) = - fun msg -> let uu___ = snapshot_encoding msg in () -let (pop_encoding_state : Prims.string -> unit) = - fun msg -> rollback_encoding msg FStar_Pervasives_Native.None -let (open_fact_db_tags : - FStar_SMTEncoding_Env.env_t -> FStar_SMTEncoding_Term.fact_db_id Prims.list) - = fun env -> [] -let (place_decl_in_fact_dbs : - FStar_SMTEncoding_Env.env_t -> - FStar_SMTEncoding_Term.fact_db_id Prims.list -> - FStar_SMTEncoding_Term.decl -> FStar_SMTEncoding_Term.decl) - = - fun env -> - fun fact_db_ids -> - fun d -> - match (fact_db_ids, d) with - | (uu___::uu___1, FStar_SMTEncoding_Term.Assume a) -> - FStar_SMTEncoding_Term.Assume - { - FStar_SMTEncoding_Term.assumption_term = - (a.FStar_SMTEncoding_Term.assumption_term); - FStar_SMTEncoding_Term.assumption_caption = - (a.FStar_SMTEncoding_Term.assumption_caption); - FStar_SMTEncoding_Term.assumption_name = - (a.FStar_SMTEncoding_Term.assumption_name); - FStar_SMTEncoding_Term.assumption_fact_ids = fact_db_ids; - FStar_SMTEncoding_Term.assumption_free_names = - (a.FStar_SMTEncoding_Term.assumption_free_names) - } - | uu___ -> d -let (place_decl_elt_in_fact_dbs : - FStar_SMTEncoding_Env.env_t -> - FStar_SMTEncoding_Term.fact_db_id Prims.list -> - FStar_SMTEncoding_Term.decls_elt -> FStar_SMTEncoding_Term.decls_elt) - = - fun env -> - fun fact_db_ids -> - fun elt -> - let uu___ = - FStar_Compiler_List.map (place_decl_in_fact_dbs env fact_db_ids) - elt.FStar_SMTEncoding_Term.decls in - { - FStar_SMTEncoding_Term.sym_name = - (elt.FStar_SMTEncoding_Term.sym_name); - FStar_SMTEncoding_Term.key = (elt.FStar_SMTEncoding_Term.key); - FStar_SMTEncoding_Term.decls = uu___; - FStar_SMTEncoding_Term.a_names = - (elt.FStar_SMTEncoding_Term.a_names) - } -let (fact_dbs_for_lid : - FStar_SMTEncoding_Env.env_t -> - FStar_Ident.lid -> FStar_SMTEncoding_Term.fact_db_id Prims.list) - = - fun env -> - fun lid -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Ident.ns_of_lid lid in - FStar_Ident.lid_of_ids uu___3 in - FStar_SMTEncoding_Term.Namespace uu___2 in - let uu___2 = open_fact_db_tags env in uu___1 :: uu___2 in - (FStar_SMTEncoding_Term.Name lid) :: uu___ -let (encode_top_level_facts : - FStar_SMTEncoding_Env.env_t -> - FStar_Syntax_Syntax.sigelt -> - (FStar_SMTEncoding_Term.decls_elt Prims.list * - FStar_SMTEncoding_Env.env_t)) - = - fun env -> - fun se -> - let fact_db_ids = - FStar_Compiler_List.collect (fact_dbs_for_lid env) - (FStar_Syntax_Util.lids_of_sigelt se) in - let uu___ = encode_sigelt env se in - match uu___ with - | (g, env1) -> - let g1 = - FStar_Compiler_List.map - (place_decl_elt_in_fact_dbs env1 fact_db_ids) g in - (g1, env1) -let (recover_caching_and_update_env : - FStar_SMTEncoding_Env.env_t -> - FStar_SMTEncoding_Term.decls_t -> FStar_SMTEncoding_Term.decls_t) - = - fun env -> - fun decls -> - FStar_Compiler_List.collect - (fun elt -> - if elt.FStar_SMTEncoding_Term.key = FStar_Pervasives_Native.None - then [elt] - else - (let uu___1 = - let uu___2 = - FStar_Compiler_Util.must elt.FStar_SMTEncoding_Term.key in - FStar_Compiler_Util.smap_try_find - env.FStar_SMTEncoding_Env.global_cache uu___2 in - match uu___1 with - | FStar_Pervasives_Native.Some cache_elt -> - FStar_SMTEncoding_Term.mk_decls_trivial - [FStar_SMTEncoding_Term.RetainAssumptions - (cache_elt.FStar_SMTEncoding_Term.a_names)] - | FStar_Pervasives_Native.None -> - ((let uu___3 = - FStar_Compiler_Util.must elt.FStar_SMTEncoding_Term.key in - FStar_Compiler_Util.smap_add - env.FStar_SMTEncoding_Env.global_cache uu___3 elt); - [elt]))) decls -let (encode_sig : - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.sigelt -> unit) = - fun tcenv -> - fun se -> - let caption decls = - let uu___ = FStar_Options.log_queries () in - if uu___ - then - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Print.sigelt_to_string_short se in - Prims.strcat "encoding sigelt " uu___3 in - FStar_SMTEncoding_Term.Caption uu___2 in - uu___1 :: decls - else decls in - (let uu___1 = FStar_Compiler_Debug.medium () in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_sigelt se in - FStar_Compiler_Util.print1 "+++++++++++Encoding sigelt %s\n" uu___2 - else ()); - (let env = - let uu___1 = FStar_TypeChecker_Env.current_module tcenv in - get_env uu___1 tcenv in - let uu___1 = encode_top_level_facts env se in - match uu___1 with - | (decls, env1) -> - (set_env env1; - (let uu___3 = - let uu___4 = - let uu___5 = recover_caching_and_update_env env1 decls in - FStar_SMTEncoding_Term.decls_list_of uu___5 in - caption uu___4 in - FStar_SMTEncoding_Z3.giveZ3 uu___3))) -let (give_decls_to_z3_and_set_env : - FStar_SMTEncoding_Env.env_t -> - Prims.string -> FStar_SMTEncoding_Term.decls_t -> unit) - = - fun env -> - fun name -> - fun decls -> - let caption decls1 = - let uu___ = FStar_Options.log_queries () in - if uu___ - then - let msg = Prims.strcat "Externals for " name in - [FStar_SMTEncoding_Term.Module - (name, - (FStar_Compiler_List.op_At - ((FStar_SMTEncoding_Term.Caption msg) :: decls1) - [FStar_SMTEncoding_Term.Caption (Prims.strcat "End " msg)]))] - else [FStar_SMTEncoding_Term.Module (name, decls1)] in - set_env - { - FStar_SMTEncoding_Env.bvar_bindings = - (env.FStar_SMTEncoding_Env.bvar_bindings); - FStar_SMTEncoding_Env.fvar_bindings = - (env.FStar_SMTEncoding_Env.fvar_bindings); - FStar_SMTEncoding_Env.depth = (env.FStar_SMTEncoding_Env.depth); - FStar_SMTEncoding_Env.tcenv = (env.FStar_SMTEncoding_Env.tcenv); - FStar_SMTEncoding_Env.warn = true; - FStar_SMTEncoding_Env.nolabels = - (env.FStar_SMTEncoding_Env.nolabels); - FStar_SMTEncoding_Env.use_zfuel_name = - (env.FStar_SMTEncoding_Env.use_zfuel_name); - FStar_SMTEncoding_Env.encode_non_total_function_typ = - (env.FStar_SMTEncoding_Env.encode_non_total_function_typ); - FStar_SMTEncoding_Env.current_module_name = - (env.FStar_SMTEncoding_Env.current_module_name); - FStar_SMTEncoding_Env.encoding_quantifier = - (env.FStar_SMTEncoding_Env.encoding_quantifier); - FStar_SMTEncoding_Env.global_cache = - (env.FStar_SMTEncoding_Env.global_cache) - }; - (let z3_decls = - let uu___1 = - let uu___2 = recover_caching_and_update_env env decls in - FStar_SMTEncoding_Term.decls_list_of uu___2 in - caption uu___1 in - FStar_SMTEncoding_Z3.giveZ3 z3_decls) -let (encode_modul : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.modul -> - (FStar_SMTEncoding_Term.decls_t * FStar_SMTEncoding_Env.fvar_binding - Prims.list)) - = - fun tcenv -> - fun modul -> - let uu___ = (FStar_Options.lax ()) && (FStar_Options.ml_ish ()) in - if uu___ - then ([], []) - else - (let tcenv1 = - FStar_TypeChecker_Env.set_current_module tcenv - modul.FStar_Syntax_Syntax.name in - FStar_Syntax_Unionfind.with_uf_enabled - (fun uu___2 -> - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.reset_fresh - (); - (let name = - let uu___4 = - FStar_Ident.string_of_lid modul.FStar_Syntax_Syntax.name in - FStar_Compiler_Util.format2 "%s %s" - (if modul.FStar_Syntax_Syntax.is_interface - then "interface" - else "module") uu___4 in - (let uu___5 = FStar_Compiler_Debug.medium () in - if uu___5 - then - FStar_Compiler_Util.print2 - "+++++++++++Encoding externals for %s ... %s declarations\n" - name - (Prims.string_of_int - (FStar_Compiler_List.length - modul.FStar_Syntax_Syntax.declarations)) - else ()); - (let env = - let uu___5 = get_env modul.FStar_Syntax_Syntax.name tcenv1 in - FStar_SMTEncoding_Env.reset_current_module_fvbs uu___5 in - let encode_signature env1 ses = - FStar_Compiler_List.fold_left - (fun uu___5 -> - fun se -> - match uu___5 with - | (g, env2) -> - let uu___6 = encode_top_level_facts env2 se in - (match uu___6 with - | (g', env3) -> - ((FStar_Compiler_List.op_At g g'), env3))) - ([], env1) ses in - let uu___5 = - encode_signature - { - FStar_SMTEncoding_Env.bvar_bindings = - (env.FStar_SMTEncoding_Env.bvar_bindings); - FStar_SMTEncoding_Env.fvar_bindings = - (env.FStar_SMTEncoding_Env.fvar_bindings); - FStar_SMTEncoding_Env.depth = - (env.FStar_SMTEncoding_Env.depth); - FStar_SMTEncoding_Env.tcenv = - (env.FStar_SMTEncoding_Env.tcenv); - FStar_SMTEncoding_Env.warn = false; - FStar_SMTEncoding_Env.nolabels = - (env.FStar_SMTEncoding_Env.nolabels); - FStar_SMTEncoding_Env.use_zfuel_name = - (env.FStar_SMTEncoding_Env.use_zfuel_name); - FStar_SMTEncoding_Env.encode_non_total_function_typ = - (env.FStar_SMTEncoding_Env.encode_non_total_function_typ); - FStar_SMTEncoding_Env.current_module_name = - (env.FStar_SMTEncoding_Env.current_module_name); - FStar_SMTEncoding_Env.encoding_quantifier = - (env.FStar_SMTEncoding_Env.encoding_quantifier); - FStar_SMTEncoding_Env.global_cache = - (env.FStar_SMTEncoding_Env.global_cache) - } modul.FStar_Syntax_Syntax.declarations in - match uu___5 with - | (decls, env1) -> - (give_decls_to_z3_and_set_env env1 name decls; - (let uu___8 = FStar_Compiler_Debug.medium () in - if uu___8 - then - FStar_Compiler_Util.print1 - "Done encoding externals for %s\n" name - else ()); - (decls, - (FStar_SMTEncoding_Env.get_current_module_fvbs env1))))))) -let (encode_modul_from_cache : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.modul -> - (FStar_SMTEncoding_Term.decls_t * FStar_SMTEncoding_Env.fvar_binding - Prims.list) -> unit) - = - fun tcenv -> - fun tcmod -> - fun uu___ -> - match uu___ with - | (decls, fvbs) -> - let uu___1 = (FStar_Options.lax ()) && (FStar_Options.ml_ish ()) in - if uu___1 - then () - else - (let tcenv1 = - FStar_TypeChecker_Env.set_current_module tcenv - tcmod.FStar_Syntax_Syntax.name in - let name = - let uu___3 = - FStar_Ident.string_of_lid tcmod.FStar_Syntax_Syntax.name in - FStar_Compiler_Util.format2 "%s %s" - (if tcmod.FStar_Syntax_Syntax.is_interface - then "interface" - else "module") uu___3 in - (let uu___4 = FStar_Compiler_Debug.medium () in - if uu___4 - then - FStar_Compiler_Util.print2 - "+++++++++++Encoding externals from cache for %s ... %s decls\n" - name - (Prims.string_of_int (FStar_Compiler_List.length decls)) - else ()); - (let env = - let uu___4 = get_env tcmod.FStar_Syntax_Syntax.name tcenv1 in - FStar_SMTEncoding_Env.reset_current_module_fvbs uu___4 in - let env1 = - FStar_Compiler_List.fold_left - (fun env2 -> - fun fvb -> - FStar_SMTEncoding_Env.add_fvar_binding_to_env fvb - env2) env (FStar_Compiler_List.rev fvbs) in - give_decls_to_z3_and_set_env env1 name decls; - (let uu___5 = FStar_Compiler_Debug.medium () in - if uu___5 - then - FStar_Compiler_Util.print1 - "Done encoding externals from cache for %s\n" name - else ()))) -let (encode_query : - (unit -> Prims.string) FStar_Pervasives_Native.option -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - (FStar_SMTEncoding_Term.decl Prims.list * - FStar_SMTEncoding_ErrorReporting.label Prims.list * - FStar_SMTEncoding_Term.decl * FStar_SMTEncoding_Term.decl - Prims.list)) - = - fun use_env_msg -> - fun tcenv -> - fun q -> - FStar_Errors.with_ctx "While encoding a query" - (fun uu___ -> - (let uu___2 = - let uu___3 = FStar_TypeChecker_Env.current_module tcenv in - FStar_Ident.string_of_lid uu___3 in - FStar_SMTEncoding_Z3.query_logging.FStar_SMTEncoding_Z3.set_module_name - uu___2); - (let env = - let uu___2 = FStar_TypeChecker_Env.current_module tcenv in - get_env uu___2 tcenv in - let uu___2 = - let rec aux bindings = - match bindings with - | (FStar_Syntax_Syntax.Binding_var x)::rest -> - let uu___3 = aux rest in - (match uu___3 with - | (out, rest1) -> - let t = - let uu___4 = - FStar_Syntax_Formula.destruct_typ_as_formula - x.FStar_Syntax_Syntax.sort in - match uu___4 with - | FStar_Pervasives_Native.Some uu___5 -> - let uu___6 = - FStar_Syntax_Syntax.new_bv - FStar_Pervasives_Native.None - FStar_Syntax_Syntax.t_unit in - FStar_Syntax_Util.refine uu___6 - x.FStar_Syntax_Syntax.sort - | uu___5 -> x.FStar_Syntax_Syntax.sort in - let t1 = - norm_with_steps - [FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Simplify; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.EraseUniverses] - env.FStar_SMTEncoding_Env.tcenv t in - let uu___4 = - let uu___5 = - FStar_Syntax_Syntax.mk_binder - { - FStar_Syntax_Syntax.ppname = - (x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (x.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = t1 - } in - uu___5 :: out in - (uu___4, rest1)) - | uu___3 -> ([], bindings) in - let uu___3 = aux tcenv.FStar_TypeChecker_Env.gamma in - match uu___3 with - | (closing, bindings) -> - let uu___4 = - FStar_Syntax_Util.close_forall_no_univs - (FStar_Compiler_List.rev closing) q in - (uu___4, bindings) in - match uu___2 with - | (q1, bindings) -> - let uu___3 = encode_env_bindings env bindings in - (match uu___3 with - | (env_decls, env1) -> - ((let uu___5 = - ((FStar_Compiler_Debug.medium ()) || - (FStar_Compiler_Effect.op_Bang dbg_SMTEncoding)) - || (FStar_Compiler_Effect.op_Bang dbg_SMTQuery) in - if uu___5 - then - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term q1 in - FStar_Compiler_Util.print1 - "Encoding query formula {: %s\n" uu___6 - else ()); - (let uu___5 = - FStar_Compiler_Util.record_time - (fun uu___6 -> - FStar_SMTEncoding_EncodeTerm.encode_formula - q1 env1) in - match uu___5 with - | ((phi, qdecls), ms) -> - let uu___6 = - let uu___7 = - FStar_TypeChecker_Env.get_range tcenv in - FStar_SMTEncoding_ErrorReporting.label_goals - use_env_msg uu___7 phi in - (match uu___6 with - | (labels, phi1) -> - let uu___7 = encode_labels labels in - (match uu___7 with - | (label_prefix, label_suffix) -> - let caption = - let uu___8 = - (FStar_Options.log_queries ()) || - (FStar_Options.log_failing_queries - ()) in - if uu___8 - then - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - q1 in - Prims.strcat - "Encoding query formula : " - uu___11 in - FStar_SMTEncoding_Term.Caption - uu___10 in - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - FStar_Errors.get_ctx () in - FStar_Compiler_String.concat - "\n" uu___14 in - Prims.strcat "Context: " - uu___13 in - FStar_SMTEncoding_Term.Caption - uu___12 in - [uu___11] in - uu___9 :: uu___10 - else [] in - let query_prelude = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_SMTEncoding_Term.mk_decls_trivial - label_prefix in - let uu___12 = - let uu___13 = - FStar_SMTEncoding_Term.mk_decls_trivial - caption in - FStar_Compiler_List.op_At - qdecls uu___13 in - FStar_Compiler_List.op_At - uu___11 uu___12 in - FStar_Compiler_List.op_At - env_decls uu___10 in - recover_caching_and_update_env - env1 uu___9 in - FStar_SMTEncoding_Term.decls_list_of - uu___8 in - let qry = - let uu___8 = - let uu___9 = - FStar_SMTEncoding_Util.mkNot - phi1 in - let uu___10 = - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.mk_unique - "@query" in - (uu___9, - (FStar_Pervasives_Native.Some - "query"), uu___10) in - FStar_SMTEncoding_Util.mkAssume - uu___8 in - let suffix = - FStar_Compiler_List.op_At - [FStar_SMTEncoding_Term.Echo - ""] - (FStar_Compiler_List.op_At - label_suffix - [FStar_SMTEncoding_Term.Echo - ""; - FStar_SMTEncoding_Term.Echo - "Done!"]) in - ((let uu___9 = - ((FStar_Compiler_Debug.medium ()) - || - (FStar_Compiler_Effect.op_Bang - dbg_SMTEncoding)) - || - (FStar_Compiler_Effect.op_Bang - dbg_SMTQuery) in - if uu___9 - then - FStar_Compiler_Util.print_string - "} Done encoding\n" - else ()); - (let uu___10 = - ((FStar_Compiler_Debug.medium ()) - || - (FStar_Compiler_Effect.op_Bang - dbg_SMTEncoding)) - || - (FStar_Compiler_Effect.op_Bang - dbg_Time) in - if uu___10 - then - FStar_Compiler_Util.print1 - "Encoding took %sms\n" - (Prims.string_of_int ms) - else ()); - (query_prelude, labels, qry, suffix))))))))) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_EncodeTerm.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_EncodeTerm.ml deleted file mode 100644 index 231e7eb47d2..00000000000 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_EncodeTerm.ml +++ /dev/null @@ -1,3946 +0,0 @@ -open Prims -let (dbg_PartialApp : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "PartialApp" -let (dbg_SMTEncoding : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "SMTEncoding" -let (dbg_SMTEncodingReify : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "SMTEncodingReify" -let mkForall_fuel' : - 'uuuuu . - Prims.string -> - FStar_Compiler_Range_Type.range -> - 'uuuuu -> - (FStar_SMTEncoding_Term.pat Prims.list Prims.list * - FStar_SMTEncoding_Term.fvs * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term - = - fun mname -> - fun r -> - fun n -> - fun uu___ -> - match uu___ with - | (pats, vars, body) -> - let fallback uu___1 = - FStar_SMTEncoding_Term.mkForall r (pats, vars, body) in - let uu___1 = FStar_Options.unthrottle_inductives () in - if uu___1 - then fallback () - else - (let uu___3 = - FStar_SMTEncoding_Env.fresh_fvar mname "f" - FStar_SMTEncoding_Term.Fuel_sort in - match uu___3 with - | (fsym, fterm) -> - let add_fuel tms = - FStar_Compiler_List.map - (fun p -> - match p.FStar_SMTEncoding_Term.tm with - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Var "HasType", args) - -> - FStar_SMTEncoding_Util.mkApp - ("HasTypeFuel", (fterm :: args)) - | uu___4 -> p) tms in - let pats1 = FStar_Compiler_List.map add_fuel pats in - let body1 = - match body.FStar_SMTEncoding_Term.tm with - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Imp, guard::body'::[]) -> - let guard1 = - match guard.FStar_SMTEncoding_Term.tm with - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.And, guards) -> - let uu___4 = add_fuel guards in - FStar_SMTEncoding_Util.mk_and_l uu___4 - | uu___4 -> - let uu___5 = add_fuel [guard] in - FStar_Compiler_List.hd uu___5 in - FStar_SMTEncoding_Util.mkImp (guard1, body') - | uu___4 -> body in - let vars1 = - let uu___4 = - FStar_SMTEncoding_Term.mk_fv - (fsym, FStar_SMTEncoding_Term.Fuel_sort) in - uu___4 :: vars in - FStar_SMTEncoding_Term.mkForall r (pats1, vars1, body1)) -let (mkForall_fuel : - Prims.string -> - FStar_Compiler_Range_Type.range -> - (FStar_SMTEncoding_Term.pat Prims.list Prims.list * - FStar_SMTEncoding_Term.fvs * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = fun mname -> fun r -> mkForall_fuel' mname r Prims.int_one -let (head_normal : - FStar_SMTEncoding_Env.env_t -> FStar_Syntax_Syntax.term -> Prims.bool) = - fun env -> - fun t -> - let t1 = FStar_Syntax_Util.unmeta t in - match t1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_arrow uu___ -> true - | FStar_Syntax_Syntax.Tm_refine uu___ -> true - | FStar_Syntax_Syntax.Tm_bvar uu___ -> true - | FStar_Syntax_Syntax.Tm_uvar uu___ -> true - | FStar_Syntax_Syntax.Tm_abs uu___ -> true - | FStar_Syntax_Syntax.Tm_constant uu___ -> true - | FStar_Syntax_Syntax.Tm_fvar fv -> - let uu___ = - FStar_TypeChecker_Env.lookup_definition - [FStar_TypeChecker_Env.Eager_unfolding_only] - env.FStar_SMTEncoding_Env.tcenv - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - FStar_Compiler_Option.isNone uu___ - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___; - FStar_Syntax_Syntax.vars = uu___1; - FStar_Syntax_Syntax.hash_code = uu___2;_}; - FStar_Syntax_Syntax.args = uu___3;_} - -> - let uu___4 = - FStar_TypeChecker_Env.lookup_definition - [FStar_TypeChecker_Env.Eager_unfolding_only] - env.FStar_SMTEncoding_Env.tcenv - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - FStar_Compiler_Option.isNone uu___4 - | uu___ -> false -let (head_redex : - FStar_SMTEncoding_Env.env_t -> FStar_Syntax_Syntax.term -> Prims.bool) = - fun env -> - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Util.un_uinst t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = uu___1; - FStar_Syntax_Syntax.body = uu___2; - FStar_Syntax_Syntax.rc_opt = FStar_Pervasives_Native.Some rc;_} - -> - ((FStar_Ident.lid_equals rc.FStar_Syntax_Syntax.residual_effect - FStar_Parser_Const.effect_Tot_lid) - || - (FStar_Ident.lid_equals rc.FStar_Syntax_Syntax.residual_effect - FStar_Parser_Const.effect_GTot_lid)) - || - (FStar_Compiler_List.existsb - (fun uu___3 -> - match uu___3 with - | FStar_Syntax_Syntax.TOTAL -> true - | uu___4 -> false) rc.FStar_Syntax_Syntax.residual_flags) - | FStar_Syntax_Syntax.Tm_fvar fv -> - let uu___1 = - FStar_TypeChecker_Env.lookup_definition - [FStar_TypeChecker_Env.Eager_unfolding_only] - env.FStar_SMTEncoding_Env.tcenv - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - FStar_Compiler_Option.isSome uu___1 - | uu___1 -> false -let (norm_with_steps : - FStar_TypeChecker_Env.steps -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun steps -> - fun env -> - fun t -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_Env.current_module env in - FStar_Ident.string_of_lid uu___2 in - FStar_Pervasives_Native.Some uu___1 in - FStar_Profiling.profile - (fun uu___1 -> FStar_TypeChecker_Normalize.normalize steps env t) - uu___ "FStar.SMTEncoding.EncodeTerm.norm_with_steps" -let (normalize_refinement : - FStar_TypeChecker_Env.steps -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.typ) - = - fun steps -> - fun env -> - fun t -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_Env.current_module env in - FStar_Ident.string_of_lid uu___2 in - FStar_Pervasives_Native.Some uu___1 in - FStar_Profiling.profile - (fun uu___1 -> - FStar_TypeChecker_Normalize.normalize_refinement steps env t) - uu___ "FStar.SMTEncoding.EncodeTerm.normalize_refinement" -let (whnf : - FStar_SMTEncoding_Env.env_t -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun env -> - fun t -> - let uu___ = head_normal env t in - if uu___ - then t - else - norm_with_steps - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Weak; - FStar_TypeChecker_Env.HNF; - FStar_TypeChecker_Env.Exclude FStar_TypeChecker_Env.Zeta; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.EraseUniverses] - env.FStar_SMTEncoding_Env.tcenv t -let (norm : - FStar_SMTEncoding_Env.env_t -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun env -> - fun t -> - norm_with_steps - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Exclude FStar_TypeChecker_Env.Zeta; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.EraseUniverses] env.FStar_SMTEncoding_Env.tcenv - t -let (maybe_whnf : - FStar_SMTEncoding_Env.env_t -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = - fun env -> - fun t -> - let t' = whnf env t in - let uu___ = FStar_Syntax_Util.head_and_args t' in - match uu___ with - | (head', uu___1) -> - let uu___2 = head_redex env head' in - if uu___2 - then FStar_Pervasives_Native.None - else FStar_Pervasives_Native.Some t' -let (trivial_post : FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = - fun t -> - let uu___ = let uu___1 = FStar_Syntax_Syntax.null_binder t in [uu___1] in - let uu___1 = - FStar_Syntax_Syntax.fvar FStar_Parser_Const.true_lid - FStar_Pervasives_Native.None in - FStar_Syntax_Util.abs uu___ uu___1 FStar_Pervasives_Native.None -let (mk_Apply : - FStar_SMTEncoding_Term.term -> - FStar_SMTEncoding_Term.fvs -> FStar_SMTEncoding_Term.term) - = - fun e -> - fun vars -> - FStar_Compiler_List.fold_left - (fun out -> - fun var -> - let uu___ = FStar_SMTEncoding_Term.fv_sort var in - match uu___ with - | FStar_SMTEncoding_Term.Fuel_sort -> - let uu___1 = FStar_SMTEncoding_Util.mkFreeV var in - FStar_SMTEncoding_Term.mk_ApplyTF out uu___1 - | s -> - let uu___1 = FStar_SMTEncoding_Util.mkFreeV var in - FStar_SMTEncoding_Util.mk_ApplyTT out uu___1) e vars -let (mk_Apply_args : - FStar_SMTEncoding_Term.term -> - FStar_SMTEncoding_Term.term Prims.list -> FStar_SMTEncoding_Term.term) - = - fun e -> - fun args -> - FStar_Compiler_List.fold_left FStar_SMTEncoding_Util.mk_ApplyTT e args -let raise_arity_mismatch : - 'a . - Prims.string -> - Prims.int -> Prims.int -> FStar_Compiler_Range_Type.range -> 'a - = - fun head -> - fun arity -> - fun n_args -> - fun rng -> - let uu___ = - let uu___1 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) arity in - let uu___2 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) n_args in - FStar_Compiler_Util.format3 - "Head symbol %s expects at least %s arguments; got only %s" - head uu___1 uu___2 in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range rng - FStar_Errors_Codes.Fatal_SMTEncodingArityMismatch () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___) -let (isTotFun_axioms : - FStar_Compiler_Range_Type.range -> - FStar_SMTEncoding_Term.term -> - FStar_SMTEncoding_Term.fvs -> - FStar_SMTEncoding_Term.term Prims.list -> - Prims.bool -> FStar_SMTEncoding_Term.term) - = - fun pos -> - fun head -> - fun vars -> - fun guards -> - fun is_pure -> - let maybe_mkForall pat vars1 body = - match vars1 with - | [] -> body - | uu___ -> - FStar_SMTEncoding_Term.mkForall pos (pat, vars1, body) in - let rec is_tot_fun_axioms ctx ctx_guard head1 vars1 guards1 = - match (vars1, guards1) with - | ([], []) -> FStar_SMTEncoding_Util.mkTrue - | (uu___::[], uu___1) -> - if is_pure - then - let uu___2 = - let uu___3 = - let uu___4 = FStar_SMTEncoding_Term.mk_IsTotFun head1 in - (ctx_guard, uu___4) in - FStar_SMTEncoding_Util.mkImp uu___3 in - maybe_mkForall [[head1]] ctx uu___2 - else FStar_SMTEncoding_Util.mkTrue - | (x::vars2, g_x::guards2) -> - let is_tot_fun_head = - let uu___ = - let uu___1 = - let uu___2 = FStar_SMTEncoding_Term.mk_IsTotFun head1 in - (ctx_guard, uu___2) in - FStar_SMTEncoding_Util.mkImp uu___1 in - maybe_mkForall [[head1]] ctx uu___ in - let app = mk_Apply head1 [x] in - let ctx1 = FStar_Compiler_List.op_At ctx [x] in - let ctx_guard1 = - FStar_SMTEncoding_Util.mkAnd (ctx_guard, g_x) in - let rest = - is_tot_fun_axioms ctx1 ctx_guard1 app vars2 guards2 in - FStar_SMTEncoding_Util.mkAnd (is_tot_fun_head, rest) - | uu___ -> failwith "impossible: isTotFun_axioms" in - is_tot_fun_axioms [] FStar_SMTEncoding_Util.mkTrue head vars - guards -let (maybe_curry_app : - FStar_Compiler_Range_Type.range -> - (FStar_SMTEncoding_Term.op, FStar_SMTEncoding_Term.term) - FStar_Pervasives.either -> - Prims.int -> - FStar_SMTEncoding_Term.term Prims.list -> FStar_SMTEncoding_Term.term) - = - fun rng -> - fun head -> - fun arity -> - fun args -> - let n_args = FStar_Compiler_List.length args in - match head with - | FStar_Pervasives.Inr head1 -> mk_Apply_args head1 args - | FStar_Pervasives.Inl head1 -> - if n_args = arity - then FStar_SMTEncoding_Util.mkApp' (head1, args) - else - if n_args > arity - then - (let uu___1 = FStar_Compiler_Util.first_N arity args in - match uu___1 with - | (args1, rest) -> - let head2 = - FStar_SMTEncoding_Util.mkApp' (head1, args1) in - mk_Apply_args head2 rest) - else - (let uu___2 = FStar_SMTEncoding_Term.op_to_string head1 in - raise_arity_mismatch uu___2 arity n_args rng) -let (maybe_curry_fvb : - FStar_Compiler_Range_Type.range -> - FStar_SMTEncoding_Env.fvar_binding -> - FStar_SMTEncoding_Term.term Prims.list -> FStar_SMTEncoding_Term.term) - = - fun rng -> - fun fvb -> - fun args -> - if fvb.FStar_SMTEncoding_Env.fvb_thunked - then - let uu___ = FStar_SMTEncoding_Env.force_thunk fvb in - mk_Apply_args uu___ args - else - maybe_curry_app rng - (FStar_Pervasives.Inl - (FStar_SMTEncoding_Term.Var (fvb.FStar_SMTEncoding_Env.smt_id))) - fvb.FStar_SMTEncoding_Env.smt_arity args -let (is_app : FStar_SMTEncoding_Term.op -> Prims.bool) = - fun uu___ -> - match uu___ with - | FStar_SMTEncoding_Term.Var "ApplyTT" -> true - | FStar_SMTEncoding_Term.Var "ApplyTF" -> true - | uu___1 -> false -let check_pattern_vars : - 'uuuuu . - FStar_SMTEncoding_Env.env_t -> - FStar_Syntax_Syntax.binder Prims.list -> - (FStar_Syntax_Syntax.term * 'uuuuu) Prims.list -> unit - = - fun env -> - fun vars -> - fun pats -> - let pats1 = - FStar_Compiler_List.map - (fun uu___ -> - match uu___ with - | (x, uu___1) -> - norm_with_steps - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.AllowUnboundUniverses; - FStar_TypeChecker_Env.EraseUniverses] - env.FStar_SMTEncoding_Env.tcenv x) pats in - match pats1 with - | [] -> () - | hd::tl -> - let pat_vars = - let uu___ = FStar_Syntax_Free.names hd in - FStar_Compiler_List.fold_left - (fun uu___2 -> - fun uu___1 -> - (fun out -> - fun x -> - let uu___1 = FStar_Syntax_Free.names x in - Obj.magic - (FStar_Class_Setlike.union () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) - (Obj.magic out) (Obj.magic uu___1))) uu___2 - uu___1) uu___ tl in - let uu___ = - FStar_Compiler_Util.find_opt - (fun uu___1 -> - match uu___1 with - | { FStar_Syntax_Syntax.binder_bv = b; - FStar_Syntax_Syntax.binder_qual = uu___2; - FStar_Syntax_Syntax.binder_positivity = uu___3; - FStar_Syntax_Syntax.binder_attrs = uu___4;_} -> - let uu___5 = - FStar_Class_Setlike.mem () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) b - (Obj.magic pat_vars) in - Prims.op_Negation uu___5) vars in - (match uu___ with - | FStar_Pervasives_Native.None -> () - | FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.binder_bv = x; - FStar_Syntax_Syntax.binder_qual = uu___1; - FStar_Syntax_Syntax.binder_positivity = uu___2; - FStar_Syntax_Syntax.binder_attrs = uu___3;_} - -> - let pos = - FStar_Compiler_List.fold_left - (fun out -> - fun t -> - FStar_Compiler_Range_Ops.union_ranges out - t.FStar_Syntax_Syntax.pos) - hd.FStar_Syntax_Syntax.pos tl in - let uu___4 = - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_bv x in - FStar_Compiler_Util.format1 - "SMT pattern misses at least one bound variable: %s" - uu___5 in - FStar_Errors.log_issue FStar_Class_HasRange.hasRange_range - pos FStar_Errors_Codes.Warning_SMTPatternIllFormed () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4)) -type label = - (FStar_SMTEncoding_Term.fv * Prims.string * - FStar_Compiler_Range_Type.range) -type labels = label Prims.list -type pattern = - { - pat_vars: (FStar_Syntax_Syntax.bv * FStar_SMTEncoding_Term.fv) Prims.list ; - pat_term: - unit -> (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.decls_t) ; - guard: FStar_SMTEncoding_Term.term -> FStar_SMTEncoding_Term.term ; - projections: - FStar_SMTEncoding_Term.term -> - (FStar_Syntax_Syntax.bv * FStar_SMTEncoding_Term.term) Prims.list - } -let (__proj__Mkpattern__item__pat_vars : - pattern -> (FStar_Syntax_Syntax.bv * FStar_SMTEncoding_Term.fv) Prims.list) - = - fun projectee -> - match projectee with - | { pat_vars; pat_term; guard; projections;_} -> pat_vars -let (__proj__Mkpattern__item__pat_term : - pattern -> - unit -> (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.decls_t)) - = - fun projectee -> - match projectee with - | { pat_vars; pat_term; guard; projections;_} -> pat_term -let (__proj__Mkpattern__item__guard : - pattern -> FStar_SMTEncoding_Term.term -> FStar_SMTEncoding_Term.term) = - fun projectee -> - match projectee with - | { pat_vars; pat_term; guard; projections;_} -> guard -let (__proj__Mkpattern__item__projections : - pattern -> - FStar_SMTEncoding_Term.term -> - (FStar_Syntax_Syntax.bv * FStar_SMTEncoding_Term.term) Prims.list) - = - fun projectee -> - match projectee with - | { pat_vars; pat_term; guard; projections;_} -> projections -let (as_function_typ : - FStar_SMTEncoding_Env.env_t -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term) - = - fun env -> - fun t0 -> - let rec aux norm1 t = - let t1 = FStar_Syntax_Subst.compress t in - match t1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_arrow uu___ -> t1 - | FStar_Syntax_Syntax.Tm_refine uu___ -> - let uu___1 = FStar_Syntax_Util.unrefine t1 in aux true uu___1 - | uu___ -> - if norm1 - then let uu___1 = whnf env t1 in aux false uu___1 - else - (let uu___2 = - let uu___3 = - FStar_Compiler_Range_Ops.string_of_range - t0.FStar_Syntax_Syntax.pos in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t0 in - FStar_Compiler_Util.format2 - "(%s) Expected a function typ; got %s" uu___3 uu___4 in - failwith uu___2) in - aux true t0 -let rec (curried_arrow_formals_comp : - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.binders * FStar_Syntax_Syntax.comp)) - = - fun k -> - let k1 = FStar_Syntax_Subst.compress k in - match k1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; FStar_Syntax_Syntax.comp = c;_} -> - FStar_Syntax_Subst.open_comp bs c - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = bv; FStar_Syntax_Syntax.phi = uu___;_} -> - let uu___1 = curried_arrow_formals_comp bv.FStar_Syntax_Syntax.sort in - (match uu___1 with - | (args, res) -> - (match args with - | [] -> - let uu___2 = FStar_Syntax_Syntax.mk_Total k1 in - ([], uu___2) - | uu___2 -> (args, res))) - | uu___ -> let uu___1 = FStar_Syntax_Syntax.mk_Total k1 in ([], uu___1) -let is_arithmetic_primitive : - 'uuuuu . - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - 'uuuuu Prims.list -> Prims.bool - = - fun head -> - fun args -> - match ((head.FStar_Syntax_Syntax.n), args) with - | (FStar_Syntax_Syntax.Tm_fvar fv, uu___::uu___1::[]) -> - ((((((((((((FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.op_Addition) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.op_Subtraction)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.op_Multiply)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.op_Division)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.op_Modulus)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.real_op_LT)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.real_op_LTE)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.real_op_GT)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.real_op_GTE)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.real_op_Addition)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.real_op_Subtraction)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.real_op_Multiply)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.real_op_Division) - | (FStar_Syntax_Syntax.Tm_fvar fv, uu___::[]) -> - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.op_Minus - | uu___ -> false -let (isInteger : FStar_Syntax_Syntax.term' -> Prims.bool) = - fun tm -> - match tm with - | FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_int - (n, FStar_Pervasives_Native.None)) -> true - | uu___ -> false -let (getInteger : FStar_Syntax_Syntax.term' -> Prims.int) = - fun tm -> - match tm with - | FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_int - (n, FStar_Pervasives_Native.None)) -> - FStar_Compiler_Util.int_of_string n - | uu___ -> failwith "Expected an Integer term" -let is_BitVector_primitive : - 'uuuuu . - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - (FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * 'uuuuu) - Prims.list -> Prims.bool - = - fun head -> - fun args -> - match ((head.FStar_Syntax_Syntax.n), args) with - | (FStar_Syntax_Syntax.Tm_fvar fv, (sz_arg, uu___)::uu___1::uu___2::[]) - -> - (((((((((((((((((FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.bv_and_lid) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.bv_xor_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.bv_or_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.bv_add_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.bv_sub_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.bv_shift_left_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.bv_shift_right_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.bv_udiv_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.bv_mod_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.bv_mul_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.bv_shift_left'_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.bv_shift_right'_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.bv_udiv_unsafe_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.bv_mod_unsafe_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.bv_mul'_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.bv_ult_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.bv_uext_lid)) - && (isInteger sz_arg.FStar_Syntax_Syntax.n) - | (FStar_Syntax_Syntax.Tm_fvar fv, (sz_arg, uu___)::uu___1::[]) -> - ((FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.nat_to_bv_lid) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.bv_to_nat_lid)) - && (isInteger sz_arg.FStar_Syntax_Syntax.n) - | uu___ -> false -let rec (encode_const : - FStar_Const.sconst -> - FStar_SMTEncoding_Env.env_t -> - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.decls_elt - Prims.list)) - = - fun c -> - fun env -> - FStar_Errors.with_ctx "While encoding a constant to SMT" - (fun uu___ -> - match c with - | FStar_Const.Const_unit -> - (FStar_SMTEncoding_Term.mk_Term_unit, []) - | FStar_Const.Const_bool (true) -> - let uu___1 = - FStar_SMTEncoding_Term.boxBool FStar_SMTEncoding_Util.mkTrue in - (uu___1, []) - | FStar_Const.Const_bool (false) -> - let uu___1 = - FStar_SMTEncoding_Term.boxBool - FStar_SMTEncoding_Util.mkFalse in - (uu___1, []) - | FStar_Const.Const_char c1 -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_SMTEncoding_Util.mkInteger' - (FStar_Compiler_Util.int_of_char c1) in - FStar_SMTEncoding_Term.boxInt uu___5 in - [uu___4] in - ("FStar.Char.__char_of_int", uu___3) in - FStar_SMTEncoding_Util.mkApp uu___2 in - (uu___1, []) - | FStar_Const.Const_int (i, FStar_Pervasives_Native.None) -> - let uu___1 = - let uu___2 = FStar_SMTEncoding_Util.mkInteger i in - FStar_SMTEncoding_Term.boxInt uu___2 in - (uu___1, []) - | FStar_Const.Const_int (repr, FStar_Pervasives_Native.Some sw) -> - let syntax_term = - FStar_ToSyntax_ToSyntax.desugar_machine_integer - (env.FStar_SMTEncoding_Env.tcenv).FStar_TypeChecker_Env.dsenv - repr sw FStar_Compiler_Range_Type.dummyRange in - encode_term syntax_term env - | FStar_Const.Const_string (s, uu___1) -> - let uu___2 = - let uu___3 = FStar_SMTEncoding_Util.mk_String_const s in - FStar_SMTEncoding_Term.boxString uu___3 in - (uu___2, []) - | FStar_Const.Const_range uu___1 -> - let uu___2 = FStar_SMTEncoding_Term.mk_Range_const () in - (uu___2, []) - | FStar_Const.Const_effect -> - (FStar_SMTEncoding_Term.mk_Term_type, []) - | FStar_Const.Const_real r -> - let uu___1 = - let uu___2 = FStar_SMTEncoding_Util.mkReal r in - FStar_SMTEncoding_Term.boxReal uu___2 in - (uu___1, []) - | c1 -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_const c1 in - FStar_Compiler_Util.format1 "Unhandled constant: %s" uu___2 in - failwith uu___1) -and (encode_binders : - FStar_SMTEncoding_Term.term FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.binders -> - FStar_SMTEncoding_Env.env_t -> - (FStar_SMTEncoding_Term.fv Prims.list * FStar_SMTEncoding_Term.term - Prims.list * FStar_SMTEncoding_Env.env_t * - FStar_SMTEncoding_Term.decls_t * FStar_Syntax_Syntax.bv Prims.list)) - = - fun fuel_opt -> - fun bs -> - fun env -> - (let uu___1 = FStar_Compiler_Debug.medium () in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show - (FStar_Class_Show.show_list FStar_Syntax_Print.showable_binder) - bs in - FStar_Compiler_Util.print1 "Encoding binders %s\n" uu___2 - else ()); - (let uu___1 = - FStar_Compiler_List.fold_left - (fun uu___2 -> - fun b -> - match uu___2 with - | (vars, guards, env1, decls, names) -> - let uu___3 = - let x = b.FStar_Syntax_Syntax.binder_bv in - let uu___4 = - FStar_SMTEncoding_Env.gen_term_var env1 x in - match uu___4 with - | (xxsym, xx, env') -> - let uu___5 = - let uu___6 = - norm env1 x.FStar_Syntax_Syntax.sort in - encode_term_pred fuel_opt uu___6 env1 xx in - (match uu___5 with - | (guard_x_t, decls') -> - let uu___6 = - FStar_SMTEncoding_Term.mk_fv - (xxsym, - FStar_SMTEncoding_Term.Term_sort) in - (uu___6, guard_x_t, env', decls', x)) in - (match uu___3 with - | (v, g, env2, decls', n) -> - ((v :: vars), (g :: guards), env2, - (FStar_Compiler_List.op_At decls decls'), (n :: - names)))) ([], [], env, [], []) bs in - match uu___1 with - | (vars, guards, env1, decls, names) -> - ((FStar_Compiler_List.rev vars), - (FStar_Compiler_List.rev guards), env1, decls, - (FStar_Compiler_List.rev names))) -and (encode_term_pred : - FStar_SMTEncoding_Term.term FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.typ -> - FStar_SMTEncoding_Env.env_t -> - FStar_SMTEncoding_Term.term -> - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.decls_t)) - = - fun fuel_opt -> - fun t -> - fun env -> - fun e -> - let uu___ = encode_term t env in - match uu___ with - | (t1, decls) -> - let uu___1 = - FStar_SMTEncoding_Term.mk_HasTypeWithFuel fuel_opt e t1 in - (uu___1, decls) -and (encode_arith_term : - FStar_SMTEncoding_Env.env_t -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.args -> - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.decls_t)) - = - fun env -> - fun head -> - fun args_e -> - let uu___ = encode_args args_e env in - match uu___ with - | (arg_tms, decls) -> - let head_fv = - match head.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_fvar fv -> fv - | uu___1 -> failwith "Impossible" in - let unary unbox arg_tms1 = - let uu___1 = FStar_Compiler_List.hd arg_tms1 in unbox uu___1 in - let binary unbox arg_tms1 = - let uu___1 = - let uu___2 = FStar_Compiler_List.hd arg_tms1 in unbox uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = FStar_Compiler_List.tl arg_tms1 in - FStar_Compiler_List.hd uu___4 in - unbox uu___3 in - (uu___1, uu___2) in - let mk_default uu___1 = - let uu___2 = - FStar_SMTEncoding_Env.lookup_free_var_sym env - head_fv.FStar_Syntax_Syntax.fv_name in - match uu___2 with - | (fname, fuel_args, arity) -> - let args = FStar_Compiler_List.op_At fuel_args arg_tms in - maybe_curry_app head.FStar_Syntax_Syntax.pos fname arity - args in - let mk_l box op mk_args ts = - let uu___1 = FStar_Options.smtencoding_l_arith_native () in - if uu___1 - then - let uu___2 = let uu___3 = mk_args ts in op uu___3 in - box uu___2 - else mk_default () in - let mk_nl box unbox nm op ts = - let uu___1 = FStar_Options.smtencoding_nl_arith_wrapped () in - if uu___1 - then - let uu___2 = binary unbox ts in - match uu___2 with - | (t1, t2) -> - let uu___3 = FStar_SMTEncoding_Util.mkApp (nm, [t1; t2]) in - box uu___3 - else - (let uu___3 = FStar_Options.smtencoding_nl_arith_native () in - if uu___3 - then - let uu___4 = let uu___5 = binary unbox ts in op uu___5 in - box uu___4 - else mk_default ()) in - let add box unbox = - mk_l box FStar_SMTEncoding_Util.mkAdd (binary unbox) in - let sub box unbox = - mk_l box FStar_SMTEncoding_Util.mkSub (binary unbox) in - let minus box unbox = - mk_l box FStar_SMTEncoding_Util.mkMinus (unary unbox) in - let mul box unbox nm = - mk_nl box unbox nm FStar_SMTEncoding_Util.mkMul in - let div box unbox nm = - mk_nl box unbox nm FStar_SMTEncoding_Util.mkDiv in - let modulus box unbox = - mk_nl box unbox "_mod" FStar_SMTEncoding_Util.mkMod in - let ops = - [(FStar_Parser_Const.op_Addition, - (add FStar_SMTEncoding_Term.boxInt - FStar_SMTEncoding_Term.unboxInt)); - (FStar_Parser_Const.op_Subtraction, - (sub FStar_SMTEncoding_Term.boxInt - FStar_SMTEncoding_Term.unboxInt)); - (FStar_Parser_Const.op_Multiply, - (mul FStar_SMTEncoding_Term.boxInt - FStar_SMTEncoding_Term.unboxInt "_mul")); - (FStar_Parser_Const.op_Division, - (div FStar_SMTEncoding_Term.boxInt - FStar_SMTEncoding_Term.unboxInt "_div")); - (FStar_Parser_Const.op_Modulus, - (modulus FStar_SMTEncoding_Term.boxInt - FStar_SMTEncoding_Term.unboxInt)); - (FStar_Parser_Const.op_Minus, - (minus FStar_SMTEncoding_Term.boxInt - FStar_SMTEncoding_Term.unboxInt)); - (FStar_Parser_Const.real_op_Addition, - (add FStar_SMTEncoding_Term.boxReal - FStar_SMTEncoding_Term.unboxReal)); - (FStar_Parser_Const.real_op_Subtraction, - (sub FStar_SMTEncoding_Term.boxReal - FStar_SMTEncoding_Term.unboxReal)); - (FStar_Parser_Const.real_op_Multiply, - (mul FStar_SMTEncoding_Term.boxReal - FStar_SMTEncoding_Term.unboxReal "_rmul")); - (FStar_Parser_Const.real_op_Division, - (mk_nl FStar_SMTEncoding_Term.boxReal - FStar_SMTEncoding_Term.unboxReal "_rdiv" - FStar_SMTEncoding_Util.mkRealDiv)); - (FStar_Parser_Const.real_op_LT, - (mk_l FStar_SMTEncoding_Term.boxBool - FStar_SMTEncoding_Util.mkLT - (binary FStar_SMTEncoding_Term.unboxReal))); - (FStar_Parser_Const.real_op_LTE, - (mk_l FStar_SMTEncoding_Term.boxBool - FStar_SMTEncoding_Util.mkLTE - (binary FStar_SMTEncoding_Term.unboxReal))); - (FStar_Parser_Const.real_op_GT, - (mk_l FStar_SMTEncoding_Term.boxBool - FStar_SMTEncoding_Util.mkGT - (binary FStar_SMTEncoding_Term.unboxReal))); - (FStar_Parser_Const.real_op_GTE, - (mk_l FStar_SMTEncoding_Term.boxBool - FStar_SMTEncoding_Util.mkGTE - (binary FStar_SMTEncoding_Term.unboxReal)))] in - let uu___1 = - let uu___2 = - FStar_Compiler_List.tryFind - (fun uu___3 -> - match uu___3 with - | (l, uu___4) -> FStar_Syntax_Syntax.fv_eq_lid head_fv l) - ops in - FStar_Compiler_Util.must uu___2 in - (match uu___1 with - | (uu___2, op) -> let uu___3 = op arg_tms in (uu___3, decls)) -and (encode_BitVector_term : - FStar_SMTEncoding_Env.env_t -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - (FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) - Prims.list -> - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.decls_elt - Prims.list)) - = - fun env -> - fun head -> - fun args_e -> - let uu___ = FStar_Compiler_List.hd args_e in - match uu___ with - | (tm_sz, uu___1) -> - let uu___2 = uu___ in - let sz = getInteger tm_sz.FStar_Syntax_Syntax.n in - let sz_key = - FStar_Compiler_Util.format1 "BitVector_%s" - (Prims.string_of_int sz) in - let sz_decls = - let uu___3 = FStar_SMTEncoding_Term.mkBvConstructor sz in - match uu___3 with - | (t_decls, constr_name, discriminator_name) -> - let uu___4 = - let uu___5 = - let head1 = - FStar_Syntax_Syntax.lid_as_fv - FStar_Parser_Const.bv_t_lid - FStar_Pervasives_Native.None in - let t = - let uu___6 = FStar_Syntax_Syntax.fv_to_tm head1 in - FStar_Syntax_Util.mk_app uu___6 - [(tm_sz, FStar_Pervasives_Native.None)] in - encode_term t env in - match uu___5 with - | (bv_t_n, decls) -> - let xsym = - let uu___6 = - let uu___7 = - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.fresh - env.FStar_SMTEncoding_Env.current_module_name - "x" in - (uu___7, FStar_SMTEncoding_Term.Term_sort) in - FStar_SMTEncoding_Term.mk_fv uu___6 in - let x = FStar_SMTEncoding_Util.mkFreeV xsym in - let x_has_type_bv_t_n = - FStar_SMTEncoding_Term.mk_HasType x bv_t_n in - let ax = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - FStar_SMTEncoding_Util.mkApp - (discriminator_name, [x]) in - (x_has_type_bv_t_n, uu___9) in - FStar_SMTEncoding_Util.mkImp uu___8 in - ([[x_has_type_bv_t_n]], [xsym], uu___7) in - FStar_SMTEncoding_Term.mkForall - head.FStar_Syntax_Syntax.pos uu___6 in - let name = - Prims.strcat "typing_inversion_for_" constr_name in - let uu___6 = - FStar_SMTEncoding_Util.mkAssume - (ax, (FStar_Pervasives_Native.Some name), name) in - (decls, uu___6) in - (match uu___4 with - | (decls, typing_inversion) -> - let uu___5 = - FStar_SMTEncoding_Term.mk_decls "" sz_key - (FStar_Compiler_List.op_At t_decls - [typing_inversion]) [] in - FStar_Compiler_List.op_At decls uu___5) in - let uu___3 = - match ((head.FStar_Syntax_Syntax.n), args_e) with - | (FStar_Syntax_Syntax.Tm_fvar fv, - uu___4::(sz_arg, uu___5)::uu___6::[]) when - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.bv_uext_lid) - && (isInteger sz_arg.FStar_Syntax_Syntax.n) - -> - let uu___7 = - let uu___8 = FStar_Compiler_List.tail args_e in - FStar_Compiler_List.tail uu___8 in - let uu___8 = - let uu___9 = getInteger sz_arg.FStar_Syntax_Syntax.n in - FStar_Pervasives_Native.Some uu___9 in - (uu___7, uu___8) - | (FStar_Syntax_Syntax.Tm_fvar fv, - uu___4::(sz_arg, uu___5)::uu___6::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.bv_uext_lid - -> - let uu___7 = - let uu___8 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - sz_arg in - FStar_Compiler_Util.format1 - "Not a constant bitvector extend size: %s" uu___8 in - failwith uu___7 - | uu___4 -> - let uu___5 = FStar_Compiler_List.tail args_e in - (uu___5, FStar_Pervasives_Native.None) in - (match uu___3 with - | (arg_tms, ext_sz) -> - let uu___4 = encode_args arg_tms env in - (match uu___4 with - | (arg_tms1, decls) -> - let head_fv = - match head.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_fvar fv -> fv - | uu___5 -> failwith "Impossible" in - let unary arg_tms2 = - let uu___5 = FStar_Compiler_List.hd arg_tms2 in - FStar_SMTEncoding_Term.unboxBitVec sz uu___5 in - let unary_arith arg_tms2 = - let uu___5 = FStar_Compiler_List.hd arg_tms2 in - FStar_SMTEncoding_Term.unboxInt uu___5 in - let binary arg_tms2 = - let uu___5 = - let uu___6 = FStar_Compiler_List.hd arg_tms2 in - FStar_SMTEncoding_Term.unboxBitVec sz uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = FStar_Compiler_List.tl arg_tms2 in - FStar_Compiler_List.hd uu___8 in - FStar_SMTEncoding_Term.unboxBitVec sz uu___7 in - (uu___5, uu___6) in - let binary_arith arg_tms2 = - let uu___5 = - let uu___6 = FStar_Compiler_List.hd arg_tms2 in - FStar_SMTEncoding_Term.unboxBitVec sz uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = FStar_Compiler_List.tl arg_tms2 in - FStar_Compiler_List.hd uu___8 in - FStar_SMTEncoding_Term.unboxInt uu___7 in - (uu___5, uu___6) in - let mk_bv op mk_args resBox ts = - let uu___5 = let uu___6 = mk_args ts in op uu___6 in - resBox uu___5 in - let bv_and = - mk_bv FStar_SMTEncoding_Util.mkBvAnd binary - (FStar_SMTEncoding_Term.boxBitVec sz) in - let bv_xor = - mk_bv FStar_SMTEncoding_Util.mkBvXor binary - (FStar_SMTEncoding_Term.boxBitVec sz) in - let bv_or = - mk_bv FStar_SMTEncoding_Util.mkBvOr binary - (FStar_SMTEncoding_Term.boxBitVec sz) in - let bv_add = - mk_bv FStar_SMTEncoding_Util.mkBvAdd binary - (FStar_SMTEncoding_Term.boxBitVec sz) in - let bv_sub = - mk_bv FStar_SMTEncoding_Util.mkBvSub binary - (FStar_SMTEncoding_Term.boxBitVec sz) in - let bv_shl = - mk_bv (FStar_SMTEncoding_Util.mkBvShl sz) - binary_arith (FStar_SMTEncoding_Term.boxBitVec sz) in - let bv_shr = - mk_bv (FStar_SMTEncoding_Util.mkBvShr sz) - binary_arith (FStar_SMTEncoding_Term.boxBitVec sz) in - let bv_udiv = - mk_bv (FStar_SMTEncoding_Util.mkBvUdiv sz) - binary_arith (FStar_SMTEncoding_Term.boxBitVec sz) in - let bv_mod = - mk_bv (FStar_SMTEncoding_Util.mkBvMod sz) - binary_arith (FStar_SMTEncoding_Term.boxBitVec sz) in - let bv_mul = - mk_bv (FStar_SMTEncoding_Util.mkBvMul sz) - binary_arith (FStar_SMTEncoding_Term.boxBitVec sz) in - let bv_shl' = - mk_bv (FStar_SMTEncoding_Util.mkBvShl' sz) binary - (FStar_SMTEncoding_Term.boxBitVec sz) in - let bv_shr' = - mk_bv (FStar_SMTEncoding_Util.mkBvShr' sz) binary - (FStar_SMTEncoding_Term.boxBitVec sz) in - let bv_udiv_unsafe = - mk_bv (FStar_SMTEncoding_Util.mkBvUdivUnsafe sz) - binary (FStar_SMTEncoding_Term.boxBitVec sz) in - let bv_mod_unsafe = - mk_bv (FStar_SMTEncoding_Util.mkBvModUnsafe sz) - binary (FStar_SMTEncoding_Term.boxBitVec sz) in - let bv_mul' = - mk_bv (FStar_SMTEncoding_Util.mkBvMul' sz) binary - (FStar_SMTEncoding_Term.boxBitVec sz) in - let bv_ult = - mk_bv FStar_SMTEncoding_Util.mkBvUlt binary - FStar_SMTEncoding_Term.boxBool in - let bv_uext arg_tms2 = - let uu___5 = - let uu___6 = - match ext_sz with - | FStar_Pervasives_Native.Some x -> x - | FStar_Pervasives_Native.None -> - failwith "impossible" in - FStar_SMTEncoding_Util.mkBvUext uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - match ext_sz with - | FStar_Pervasives_Native.Some x -> x - | FStar_Pervasives_Native.None -> - failwith "impossible" in - sz + uu___8 in - FStar_SMTEncoding_Term.boxBitVec uu___7 in - mk_bv uu___5 unary uu___6 arg_tms2 in - let to_int = - mk_bv FStar_SMTEncoding_Util.mkBvToNat unary - FStar_SMTEncoding_Term.boxInt in - let bv_to = - mk_bv (FStar_SMTEncoding_Util.mkNatToBv sz) - unary_arith (FStar_SMTEncoding_Term.boxBitVec sz) in - let ops = - [(FStar_Parser_Const.bv_and_lid, bv_and); - (FStar_Parser_Const.bv_xor_lid, bv_xor); - (FStar_Parser_Const.bv_or_lid, bv_or); - (FStar_Parser_Const.bv_add_lid, bv_add); - (FStar_Parser_Const.bv_sub_lid, bv_sub); - (FStar_Parser_Const.bv_shift_left_lid, bv_shl); - (FStar_Parser_Const.bv_shift_right_lid, bv_shr); - (FStar_Parser_Const.bv_udiv_lid, bv_udiv); - (FStar_Parser_Const.bv_mod_lid, bv_mod); - (FStar_Parser_Const.bv_mul_lid, bv_mul); - (FStar_Parser_Const.bv_shift_left'_lid, bv_shl'); - (FStar_Parser_Const.bv_shift_right'_lid, bv_shr'); - (FStar_Parser_Const.bv_udiv_unsafe_lid, - bv_udiv_unsafe); - (FStar_Parser_Const.bv_mod_unsafe_lid, bv_mod_unsafe); - (FStar_Parser_Const.bv_mul'_lid, bv_mul'); - (FStar_Parser_Const.bv_ult_lid, bv_ult); - (FStar_Parser_Const.bv_uext_lid, bv_uext); - (FStar_Parser_Const.bv_to_nat_lid, to_int); - (FStar_Parser_Const.nat_to_bv_lid, bv_to)] in - let uu___5 = - let uu___6 = - FStar_Compiler_List.tryFind - (fun uu___7 -> - match uu___7 with - | (l, uu___8) -> - FStar_Syntax_Syntax.fv_eq_lid head_fv l) - ops in - FStar_Compiler_Util.must uu___6 in - (match uu___5 with - | (uu___6, op) -> - let uu___7 = op arg_tms1 in - (uu___7, - (FStar_Compiler_List.op_At sz_decls decls))))) -and (encode_deeply_embedded_quantifier : - FStar_Syntax_Syntax.term -> - FStar_SMTEncoding_Env.env_t -> - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.decls_t)) - = - fun t -> - fun env -> - let env1 = - { - FStar_SMTEncoding_Env.bvar_bindings = - (env.FStar_SMTEncoding_Env.bvar_bindings); - FStar_SMTEncoding_Env.fvar_bindings = - (env.FStar_SMTEncoding_Env.fvar_bindings); - FStar_SMTEncoding_Env.depth = (env.FStar_SMTEncoding_Env.depth); - FStar_SMTEncoding_Env.tcenv = (env.FStar_SMTEncoding_Env.tcenv); - FStar_SMTEncoding_Env.warn = (env.FStar_SMTEncoding_Env.warn); - FStar_SMTEncoding_Env.nolabels = - (env.FStar_SMTEncoding_Env.nolabels); - FStar_SMTEncoding_Env.use_zfuel_name = - (env.FStar_SMTEncoding_Env.use_zfuel_name); - FStar_SMTEncoding_Env.encode_non_total_function_typ = - (env.FStar_SMTEncoding_Env.encode_non_total_function_typ); - FStar_SMTEncoding_Env.current_module_name = - (env.FStar_SMTEncoding_Env.current_module_name); - FStar_SMTEncoding_Env.encoding_quantifier = true; - FStar_SMTEncoding_Env.global_cache = - (env.FStar_SMTEncoding_Env.global_cache) - } in - let uu___ = encode_term t env1 in - match uu___ with - | (tm, decls) -> - let vars = FStar_SMTEncoding_Term.free_variables tm in - let valid_tm = FStar_SMTEncoding_Term.mk_Valid tm in - let key = - FStar_SMTEncoding_Term.mkForall t.FStar_Syntax_Syntax.pos - ([], vars, valid_tm) in - let tkey_hash = FStar_SMTEncoding_Term.hash_of_term key in - (match tm.FStar_SMTEncoding_Term.tm with - | FStar_SMTEncoding_Term.App - (uu___1, - { - FStar_SMTEncoding_Term.tm = FStar_SMTEncoding_Term.FreeV - uu___2; - FStar_SMTEncoding_Term.freevars = uu___3; - FStar_SMTEncoding_Term.rng = uu___4;_}::{ - FStar_SMTEncoding_Term.tm - = - FStar_SMTEncoding_Term.FreeV - uu___5; - FStar_SMTEncoding_Term.freevars - = uu___6; - FStar_SMTEncoding_Term.rng - = uu___7;_}::[]) - -> - (FStar_Errors.log_issue - (FStar_Syntax_Syntax.has_range_syntax ()) t - FStar_Errors_Codes.Warning_QuantifierWithoutPattern () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Not encoding deeply embedded, unguarded quantifier to SMT"); - (tm, decls)) - | uu___1 -> - let uu___2 = encode_formula t env1 in - (match uu___2 with - | (phi, decls') -> - let interp = - match vars with - | [] -> - let uu___3 = - let uu___4 = FStar_SMTEncoding_Term.mk_Valid tm in - (uu___4, phi) in - FStar_SMTEncoding_Util.mkIff uu___3 - | uu___3 -> - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_SMTEncoding_Term.mk_Valid tm in - (uu___7, phi) in - FStar_SMTEncoding_Util.mkIff uu___6 in - ([[valid_tm]], vars, uu___5) in - FStar_SMTEncoding_Term.mkForall - t.FStar_Syntax_Syntax.pos uu___4 in - let ax = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Compiler_Util.digest_of_string tkey_hash in - Prims.strcat "l_quant_interp_" uu___5 in - (interp, - (FStar_Pervasives_Native.Some - "Interpretation of deeply embedded quantifier"), - uu___4) in - FStar_SMTEncoding_Util.mkAssume uu___3 in - let uu___3 = - let uu___4 = - let uu___5 = - FStar_SMTEncoding_Term.mk_decls "" tkey_hash - [ax] (FStar_Compiler_List.op_At decls decls') in - FStar_Compiler_List.op_At decls' uu___5 in - FStar_Compiler_List.op_At decls uu___4 in - (tm, uu___3))) -and (encode_term : - FStar_Syntax_Syntax.typ -> - FStar_SMTEncoding_Env.env_t -> - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.decls_t)) - = - fun t -> - fun env -> - FStar_Defensive.def_check_scoped FStar_TypeChecker_Env.hasBinders_env - FStar_Class_Binders.hasNames_term FStar_Syntax_Print.pretty_term - t.FStar_Syntax_Syntax.pos "encode_term" - env.FStar_SMTEncoding_Env.tcenv t; - (let t1 = FStar_Syntax_Subst.compress t in - let t0 = t1 in - (let uu___2 = FStar_Compiler_Effect.op_Bang dbg_SMTEncoding in - if uu___2 - then - let uu___3 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t1 in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.print2 "(%s) %s\n" uu___3 uu___4 - else ()); - (match t1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_delayed uu___2 -> - let uu___3 = - let uu___4 = - FStar_Compiler_Range_Ops.string_of_range - t1.FStar_Syntax_Syntax.pos in - let uu___5 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t1 in - let uu___6 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.format3 "(%s) Impossible: %s\n%s\n" uu___4 - uu___5 uu___6 in - failwith uu___3 - | FStar_Syntax_Syntax.Tm_unknown -> - let uu___2 = - let uu___3 = - FStar_Compiler_Range_Ops.string_of_range - t1.FStar_Syntax_Syntax.pos in - let uu___4 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t1 in - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.format3 "(%s) Impossible: %s\n%s\n" uu___3 - uu___4 uu___5 in - failwith uu___2 - | FStar_Syntax_Syntax.Tm_lazy i -> - let e = FStar_Syntax_Util.unfold_lazy i in - ((let uu___3 = FStar_Compiler_Effect.op_Bang dbg_SMTEncoding in - if uu___3 - then - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - FStar_Compiler_Util.print2 ">> Unfolded (%s) ~> (%s)\n" - uu___4 uu___5 - else ()); - encode_term e env) - | FStar_Syntax_Syntax.Tm_bvar x -> - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_bv x in - FStar_Compiler_Util.format1 - "Impossible: locally nameless; got %s" uu___3 in - failwith uu___2 - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t2; - FStar_Syntax_Syntax.asc = (k, uu___2, uu___3); - FStar_Syntax_Syntax.eff_opt = uu___4;_} - -> - let uu___5 = - match k with - | FStar_Pervasives.Inl t3 -> FStar_Syntax_Util.is_unit t3 - | uu___6 -> false in - if uu___5 - then (FStar_SMTEncoding_Term.mk_Term_unit, []) - else encode_term t2 env - | FStar_Syntax_Syntax.Tm_quoted (qt, uu___2) -> - let tv = - let uu___3 = - let uu___4 = FStar_Reflection_V2_Builtins.inspect_ln qt in - FStar_Syntax_Embeddings_Base.embed - FStar_Reflection_V2_Embeddings.e_term_view uu___4 in - uu___3 t1.FStar_Syntax_Syntax.pos FStar_Pervasives_Native.None - FStar_Syntax_Embeddings_Base.id_norm_cb in - ((let uu___4 = FStar_Compiler_Effect.op_Bang dbg_SMTEncoding in - if uu___4 - then - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t0 in - let uu___6 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term tv in - FStar_Compiler_Util.print2 ">> Inspected (%s) ~> (%s)\n" - uu___5 uu___6 - else ()); - (let t2 = - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.as_arg tv in [uu___5] in - FStar_Syntax_Util.mk_app - (FStar_Reflection_V2_Constants.refl_constant_term - FStar_Reflection_V2_Constants.fstar_refl_pack_ln) uu___4 in - encode_term t2 env)) - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t2; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_pattern - uu___2;_} - -> - encode_term t2 - { - FStar_SMTEncoding_Env.bvar_bindings = - (env.FStar_SMTEncoding_Env.bvar_bindings); - FStar_SMTEncoding_Env.fvar_bindings = - (env.FStar_SMTEncoding_Env.fvar_bindings); - FStar_SMTEncoding_Env.depth = - (env.FStar_SMTEncoding_Env.depth); - FStar_SMTEncoding_Env.tcenv = - (env.FStar_SMTEncoding_Env.tcenv); - FStar_SMTEncoding_Env.warn = (env.FStar_SMTEncoding_Env.warn); - FStar_SMTEncoding_Env.nolabels = - (env.FStar_SMTEncoding_Env.nolabels); - FStar_SMTEncoding_Env.use_zfuel_name = - (env.FStar_SMTEncoding_Env.use_zfuel_name); - FStar_SMTEncoding_Env.encode_non_total_function_typ = - (env.FStar_SMTEncoding_Env.encode_non_total_function_typ); - FStar_SMTEncoding_Env.current_module_name = - (env.FStar_SMTEncoding_Env.current_module_name); - FStar_SMTEncoding_Env.encoding_quantifier = false; - FStar_SMTEncoding_Env.global_cache = - (env.FStar_SMTEncoding_Env.global_cache) - } - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t2; - FStar_Syntax_Syntax.meta = uu___2;_} - -> encode_term t2 env - | FStar_Syntax_Syntax.Tm_name x -> - let t2 = FStar_SMTEncoding_Env.lookup_term_var env x in (t2, []) - | FStar_Syntax_Syntax.Tm_fvar v -> - let encode_freev uu___2 = - let fvb = - FStar_SMTEncoding_Env.lookup_free_var_name env - v.FStar_Syntax_Syntax.fv_name in - let tok = - FStar_SMTEncoding_Env.lookup_free_var env - v.FStar_Syntax_Syntax.fv_name in - let tkey_hash = FStar_SMTEncoding_Term.hash_of_term tok in - let uu___3 = - if fvb.FStar_SMTEncoding_Env.smt_arity > Prims.int_zero - then - match tok.FStar_SMTEncoding_Term.tm with - | FStar_SMTEncoding_Term.FreeV uu___4 -> - let sym_name = - let uu___5 = - FStar_Compiler_Util.digest_of_string tkey_hash in - Prims.strcat "@kick_partial_app_" uu___5 in - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_SMTEncoding_Term.kick_partial_app tok in - (uu___8, - (FStar_Pervasives_Native.Some - "kick_partial_app"), sym_name) in - FStar_SMTEncoding_Util.mkAssume uu___7 in - [uu___6] in - (uu___5, sym_name) - | FStar_SMTEncoding_Term.App (uu___4, []) -> - let sym_name = - let uu___5 = - FStar_Compiler_Util.digest_of_string tkey_hash in - Prims.strcat "@kick_partial_app_" uu___5 in - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_SMTEncoding_Term.kick_partial_app tok in - (uu___8, - (FStar_Pervasives_Native.Some - "kick_partial_app"), sym_name) in - FStar_SMTEncoding_Util.mkAssume uu___7 in - [uu___6] in - (uu___5, sym_name) - | uu___4 -> ([], "") - else ([], "") in - match uu___3 with - | (aux_decls, sym_name) -> - let uu___4 = - if aux_decls = [] - then FStar_SMTEncoding_Term.mk_decls_trivial [] - else - FStar_SMTEncoding_Term.mk_decls sym_name tkey_hash - aux_decls [] in - (tok, uu___4) in - let uu___2 = head_redex env t1 in - if uu___2 - then - let uu___3 = maybe_whnf env t1 in - (match uu___3 with - | FStar_Pervasives_Native.None -> encode_freev () - | FStar_Pervasives_Native.Some t2 -> encode_term t2 env) - else encode_freev () - | FStar_Syntax_Syntax.Tm_type uu___2 -> - (FStar_SMTEncoding_Term.mk_Term_type, []) - | FStar_Syntax_Syntax.Tm_uinst (t2, uu___2) -> encode_term t2 env - | FStar_Syntax_Syntax.Tm_constant c -> encode_const c env - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = binders; - FStar_Syntax_Syntax.comp = c;_} - -> - let module_name = env.FStar_SMTEncoding_Env.current_module_name in - let uu___2 = FStar_Syntax_Subst.open_comp binders c in - (match uu___2 with - | (binders1, res) -> - let uu___3 = - (env.FStar_SMTEncoding_Env.encode_non_total_function_typ - && (FStar_Syntax_Util.is_pure_or_ghost_comp res)) - || (FStar_Syntax_Util.is_tot_or_gtot_comp res) in - if uu___3 - then - let uu___4 = - encode_binders FStar_Pervasives_Native.None binders1 env in - (match uu___4 with - | (vars, guards_l, env', decls, uu___5) -> - let fsym = - let uu___6 = - let uu___7 = - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.fresh - module_name "f" in - (uu___7, FStar_SMTEncoding_Term.Term_sort) in - FStar_SMTEncoding_Term.mk_fv uu___6 in - let f = FStar_SMTEncoding_Util.mkFreeV fsym in - let app = mk_Apply f vars in - let tcenv_bs = - let uu___6 = env'.FStar_SMTEncoding_Env.tcenv in - { - FStar_TypeChecker_Env.solver = - (uu___6.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (uu___6.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (uu___6.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (uu___6.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (uu___6.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (uu___6.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (uu___6.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (uu___6.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (uu___6.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (uu___6.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (uu___6.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (uu___6.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (uu___6.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (uu___6.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (uu___6.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (uu___6.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (uu___6.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (uu___6.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = true; - FStar_TypeChecker_Env.lax_universes = - (uu___6.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (uu___6.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (uu___6.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (uu___6.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (uu___6.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (uu___6.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (uu___6.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (uu___6.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (uu___6.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (uu___6.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (uu___6.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (uu___6.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (uu___6.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (uu___6.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (uu___6.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (uu___6.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (uu___6.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (uu___6.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (uu___6.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (uu___6.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (uu___6.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (uu___6.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (uu___6.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (uu___6.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (uu___6.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (uu___6.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (uu___6.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (uu___6.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (uu___6.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (uu___6.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (uu___6.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (uu___6.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (uu___6.FStar_TypeChecker_Env.missing_decl) - } in - let uu___6 = - FStar_TypeChecker_Util.pure_or_ghost_pre_and_post - tcenv_bs res in - (match uu___6 with - | (pre_opt, res_t) -> - let uu___7 = - encode_term_pred FStar_Pervasives_Native.None - res_t env' app in - (match uu___7 with - | (res_pred, decls') -> - let uu___8 = - match pre_opt with - | FStar_Pervasives_Native.None -> - let uu___9 = - FStar_SMTEncoding_Util.mk_and_l - guards_l in - (uu___9, []) - | FStar_Pervasives_Native.Some pre -> - let uu___9 = encode_formula pre env' in - (match uu___9 with - | (guard, decls0) -> - let uu___10 = - FStar_SMTEncoding_Util.mk_and_l - (guard :: guards_l) in - (uu___10, decls0)) in - (match uu___8 with - | (guards, guard_decls) -> - let is_pure = - let uu___9 = - FStar_TypeChecker_Normalize.maybe_ghost_to_pure - env.FStar_SMTEncoding_Env.tcenv - res in - FStar_Syntax_Util.is_pure_comp - uu___9 in - let t_interp = - let uu___9 = - let uu___10 = - FStar_SMTEncoding_Util.mkImp - (guards, res_pred) in - ([[app]], vars, uu___10) in - FStar_SMTEncoding_Term.mkForall - t1.FStar_Syntax_Syntax.pos uu___9 in - let t_interp1 = - let tot_fun_axioms = - isTotFun_axioms - t1.FStar_Syntax_Syntax.pos f - vars guards_l is_pure in - FStar_SMTEncoding_Util.mkAnd - (t_interp, tot_fun_axioms) in - let cvars = - let uu___9 = - FStar_SMTEncoding_Term.free_variables - t_interp1 in - FStar_Compiler_List.filter - (fun x -> - let uu___10 = - FStar_SMTEncoding_Term.fv_name - x in - let uu___11 = - FStar_SMTEncoding_Term.fv_name - fsym in - uu___10 <> uu___11) uu___9 in - let tkey = - FStar_SMTEncoding_Term.mkForall - t1.FStar_Syntax_Syntax.pos - ([], (fsym :: cvars), t_interp1) in - let prefix = - if is_pure - then "Tm_arrow_" - else "Tm_ghost_arrow_" in - let tkey_hash = - let uu___9 = - FStar_SMTEncoding_Term.hash_of_term - tkey in - Prims.strcat prefix uu___9 in - let tsym = - let uu___9 = - FStar_Compiler_Util.digest_of_string - tkey_hash in - Prims.strcat prefix uu___9 in - let cvar_sorts = - FStar_Compiler_List.map - FStar_SMTEncoding_Term.fv_sort - cvars in - let caption = - let uu___9 = - FStar_Options.log_queries () in - if uu___9 - then - let uu___10 = - let uu___11 = - FStar_TypeChecker_Normalize.term_to_string - env.FStar_SMTEncoding_Env.tcenv - t0 in - FStar_Compiler_Util.replace_char - uu___11 10 32 in - FStar_Pervasives_Native.Some - uu___10 - else FStar_Pervasives_Native.None in - let tdecl = - FStar_SMTEncoding_Term.DeclFun - (tsym, cvar_sorts, - FStar_SMTEncoding_Term.Term_sort, - caption) in - let t2 = - let uu___9 = - let uu___10 = - FStar_Compiler_List.map - FStar_SMTEncoding_Util.mkFreeV - cvars in - (tsym, uu___10) in - FStar_SMTEncoding_Util.mkApp uu___9 in - let t_has_kind = - FStar_SMTEncoding_Term.mk_HasType t2 - FStar_SMTEncoding_Term.mk_Term_type in - let k_assumption = - let a_name = - Prims.strcat "kinding_" tsym in - let uu___9 = - let uu___10 = - FStar_SMTEncoding_Term.mkForall - t0.FStar_Syntax_Syntax.pos - ([[t_has_kind]], cvars, - t_has_kind) in - (uu___10, - (FStar_Pervasives_Native.Some - a_name), a_name) in - FStar_SMTEncoding_Util.mkAssume - uu___9 in - let f_has_t = - FStar_SMTEncoding_Term.mk_HasType f - t2 in - let f_has_t_z = - FStar_SMTEncoding_Term.mk_HasTypeZ f - t2 in - let pre_typing = - let a_name = - Prims.strcat "pre_typing_" tsym in - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - FStar_SMTEncoding_Term.mk_PreType - f in - FStar_SMTEncoding_Term.mk_tester - "Tm_arrow" uu___15 in - (f_has_t, uu___14) in - FStar_SMTEncoding_Util.mkImp - uu___13 in - ([[f_has_t]], (fsym :: cvars), - uu___12) in - let uu___12 = - mkForall_fuel module_name - t0.FStar_Syntax_Syntax.pos in - uu___12 uu___11 in - (uu___10, - (FStar_Pervasives_Native.Some - "pre-typing for functions"), - (Prims.strcat module_name - (Prims.strcat "_" a_name))) in - FStar_SMTEncoding_Util.mkAssume - uu___9 in - let t_interp2 = - let a_name = - Prims.strcat "interpretation_" - tsym in - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_SMTEncoding_Util.mkIff - (f_has_t_z, t_interp1) in - ([[f_has_t_z]], (fsym :: - cvars), uu___12) in - FStar_SMTEncoding_Term.mkForall - t0.FStar_Syntax_Syntax.pos - uu___11 in - (uu___10, - (FStar_Pervasives_Native.Some - a_name), - (Prims.strcat module_name - (Prims.strcat "_" a_name))) in - FStar_SMTEncoding_Util.mkAssume - uu___9 in - let t_decls = - [tdecl; - k_assumption; - pre_typing; - t_interp2] in - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_SMTEncoding_Term.mk_decls - tsym tkey_hash t_decls - (FStar_Compiler_List.op_At - decls - (FStar_Compiler_List.op_At - decls' guard_decls)) in - FStar_Compiler_List.op_At - guard_decls uu___12 in - FStar_Compiler_List.op_At decls' - uu___11 in - FStar_Compiler_List.op_At decls - uu___10 in - (t2, uu___9))))) - else - (let tkey_hash = - let uu___5 = - encode_binders FStar_Pervasives_Native.None binders1 - env in - match uu___5 with - | (vars, guards_l, env_bs, uu___6, uu___7) -> - let c1 = - let uu___8 = - let uu___9 = - FStar_TypeChecker_Env.push_binders - env.FStar_SMTEncoding_Env.tcenv binders1 in - FStar_TypeChecker_Env.unfold_effect_abbrev - uu___9 res in - FStar_Syntax_Syntax.mk_Comp uu___8 in - let uu___8 = - encode_term (FStar_Syntax_Util.comp_result c1) - env_bs in - (match uu___8 with - | (ct, uu___9) -> - let uu___10 = - let uu___11 = - FStar_Syntax_Util.comp_effect_args c1 in - encode_args uu___11 env_bs in - (match uu___10 with - | (effect_args, uu___11) -> - let tkey = - let uu___12 = - let uu___13 = - FStar_SMTEncoding_Util.mk_and_l - (FStar_Compiler_List.op_At - guards_l - (FStar_Compiler_List.op_At - [ct] effect_args)) in - ([], vars, uu___13) in - FStar_SMTEncoding_Term.mkForall - t1.FStar_Syntax_Syntax.pos uu___12 in - let tkey_hash1 = - let uu___12 = - let uu___13 = - FStar_SMTEncoding_Term.hash_of_term - tkey in - let uu___14 = - let uu___15 = - FStar_Ident.string_of_lid - (FStar_Syntax_Util.comp_effect_name - c1) in - Prims.strcat "@Effect=" uu___15 in - Prims.strcat uu___13 uu___14 in - Prims.strcat "Non_total_Tm_arrow" - uu___12 in - FStar_Compiler_Util.digest_of_string - tkey_hash1)) in - let tsym = Prims.strcat "Non_total_Tm_arrow_" tkey_hash in - let env0 = env in - let uu___5 = - let fvs = - let uu___6 = FStar_Syntax_Free.names t0 in - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) - (Obj.magic uu___6) in - let getfreeV t2 = - match t2.FStar_SMTEncoding_Term.tm with - | FStar_SMTEncoding_Term.FreeV fv -> fv - | uu___6 -> - failwith - "Impossible: getfreeV: gen_term_var should always returns a FreeV" in - let uu___6 = - FStar_Compiler_List.fold_left - (fun uu___7 -> - fun bv -> - match uu___7 with - | (env1, decls, vars, tms, guards) -> - let uu___8 = - FStar_TypeChecker_Env.lookup_bv - env1.FStar_SMTEncoding_Env.tcenv bv in - (match uu___8 with - | (sort, uu___9) -> - let uu___10 = - FStar_SMTEncoding_Env.gen_term_var - env1 bv in - (match uu___10 with - | (sym, smt_tm, env2) -> - let fv = getfreeV smt_tm in - let uu___11 = - let uu___12 = norm env2 sort in - encode_term_pred - FStar_Pervasives_Native.None - uu___12 env2 smt_tm in - (match uu___11 with - | (guard, decls') -> - (env2, - (FStar_Compiler_List.op_At - decls' decls), (fv :: - vars), (smt_tm :: tms), - (guard :: guards)))))) - (env, [], [], [], []) fvs in - (fvs, uu___6) in - match uu___5 with - | (fstar_fvs, - (env1, fv_decls, fv_vars, fv_tms, fv_guards)) -> - let fv_decls1 = FStar_Compiler_List.rev fv_decls in - let fv_vars1 = FStar_Compiler_List.rev fv_vars in - let fv_tms1 = FStar_Compiler_List.rev fv_tms in - let fv_guards1 = FStar_Compiler_List.rev fv_guards in - let arg_sorts = - FStar_Compiler_List.map - (fun uu___6 -> FStar_SMTEncoding_Term.Term_sort) - fv_tms1 in - let tdecl = - FStar_SMTEncoding_Term.DeclFun - (tsym, arg_sorts, - FStar_SMTEncoding_Term.Term_sort, - FStar_Pervasives_Native.None) in - let tapp = - FStar_SMTEncoding_Util.mkApp (tsym, fv_tms1) in - let t_kinding = - let a_name = - Prims.strcat "non_total_function_typing_" tsym in - let axiom = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - FStar_SMTEncoding_Term.mk_HasType tapp - FStar_SMTEncoding_Term.mk_Term_type in - [uu___9] in - [uu___8] in - let uu___8 = - let uu___9 = - let uu___10 = - FStar_SMTEncoding_Util.mk_and_l - fv_guards1 in - let uu___11 = - FStar_SMTEncoding_Term.mk_HasType tapp - FStar_SMTEncoding_Term.mk_Term_type in - (uu___10, uu___11) in - FStar_SMTEncoding_Util.mkImp uu___9 in - (uu___7, fv_vars1, uu___8) in - FStar_SMTEncoding_Term.mkForall - t0.FStar_Syntax_Syntax.pos uu___6 in - let svars = - FStar_SMTEncoding_Term.free_variables axiom in - let axiom1 = - FStar_SMTEncoding_Term.mkForall - t0.FStar_Syntax_Syntax.pos ([], svars, axiom) in - FStar_SMTEncoding_Util.mkAssume - (axiom1, - (FStar_Pervasives_Native.Some - "Typing for non-total arrows"), a_name) in - let tapp_concrete = - let uu___6 = - let uu___7 = - FStar_Compiler_List.map - (FStar_SMTEncoding_Env.lookup_term_var env0) - fstar_fvs in - (tsym, uu___7) in - FStar_SMTEncoding_Util.mkApp uu___6 in - let uu___6 = - let uu___7 = - FStar_SMTEncoding_Term.mk_decls tsym tkey_hash - [tdecl; t_kinding] [] in - FStar_Compiler_List.op_At fv_decls1 uu___7 in - (tapp_concrete, uu___6))) - | FStar_Syntax_Syntax.Tm_refine uu___2 -> - let uu___3 = - let steps = - [FStar_TypeChecker_Env.Weak; - FStar_TypeChecker_Env.HNF; - FStar_TypeChecker_Env.EraseUniverses] in - let uu___4 = - normalize_refinement steps env.FStar_SMTEncoding_Env.tcenv t0 in - match uu___4 with - | { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x; - FStar_Syntax_Syntax.phi = f;_}; - FStar_Syntax_Syntax.pos = uu___5; - FStar_Syntax_Syntax.vars = uu___6; - FStar_Syntax_Syntax.hash_code = uu___7;_} -> - let uu___8 = - let uu___9 = - let uu___10 = FStar_Syntax_Syntax.mk_binder x in - [uu___10] in - FStar_Syntax_Subst.open_term uu___9 f in - (match uu___8 with - | (b, f1) -> - let uu___9 = - let uu___10 = FStar_Compiler_List.hd b in - uu___10.FStar_Syntax_Syntax.binder_bv in - (uu___9, f1)) - | uu___5 -> failwith "impossible" in - (match uu___3 with - | (x, f) -> - let uu___4 = encode_term x.FStar_Syntax_Syntax.sort env in - (match uu___4 with - | (base_t, decls) -> - let uu___5 = FStar_SMTEncoding_Env.gen_term_var env x in - (match uu___5 with - | (x1, xtm, env') -> - let uu___6 = encode_formula f env' in - (match uu___6 with - | (refinement, decls') -> - let uu___7 = - FStar_SMTEncoding_Env.fresh_fvar - env.FStar_SMTEncoding_Env.current_module_name - "f" FStar_SMTEncoding_Term.Fuel_sort in - (match uu___7 with - | (fsym, fterm) -> - let tm_has_type_with_fuel = - FStar_SMTEncoding_Term.mk_HasTypeWithFuel - (FStar_Pervasives_Native.Some fterm) - xtm base_t in - let encoding = - FStar_SMTEncoding_Util.mkAnd - (tm_has_type_with_fuel, refinement) in - let cvars = - let uu___8 = - let uu___9 = - FStar_SMTEncoding_Term.free_variables - refinement in - let uu___10 = - FStar_SMTEncoding_Term.free_variables - tm_has_type_with_fuel in - FStar_Compiler_List.op_At uu___9 - uu___10 in - FStar_Compiler_Util.remove_dups - FStar_SMTEncoding_Term.fv_eq uu___8 in - let cvars1 = - FStar_Compiler_List.filter - (fun y -> - (let uu___8 = - FStar_SMTEncoding_Term.fv_name - y in - uu___8 <> x1) && - (let uu___8 = - FStar_SMTEncoding_Term.fv_name - y in - uu___8 <> fsym)) cvars in - let xfv = - FStar_SMTEncoding_Term.mk_fv - (x1, - FStar_SMTEncoding_Term.Term_sort) in - let ffv = - FStar_SMTEncoding_Term.mk_fv - (fsym, - FStar_SMTEncoding_Term.Fuel_sort) in - let tkey = - FStar_SMTEncoding_Term.mkForall - t0.FStar_Syntax_Syntax.pos - ([], (ffv :: xfv :: cvars1), - encoding) in - let tkey_hash = - FStar_SMTEncoding_Term.hash_of_term - tkey in - ((let uu___9 = - FStar_Compiler_Effect.op_Bang - dbg_SMTEncoding in - if uu___9 - then - let uu___10 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - f in - let uu___11 = - FStar_Compiler_Util.digest_of_string - tkey_hash in - FStar_Compiler_Util.print3 - "Encoding Tm_refine %s with tkey_hash %s and digest %s\n" - uu___10 tkey_hash uu___11 - else ()); - (let tsym = - let uu___9 = - FStar_Compiler_Util.digest_of_string - tkey_hash in - Prims.strcat "Tm_refine_" uu___9 in - let cvar_sorts = - FStar_Compiler_List.map - FStar_SMTEncoding_Term.fv_sort - cvars1 in - let tdecl = - FStar_SMTEncoding_Term.DeclFun - (tsym, cvar_sorts, - FStar_SMTEncoding_Term.Term_sort, - FStar_Pervasives_Native.None) in - let t2 = - let uu___9 = - let uu___10 = - FStar_Compiler_List.map - FStar_SMTEncoding_Util.mkFreeV - cvars1 in - (tsym, uu___10) in - FStar_SMTEncoding_Util.mkApp uu___9 in - let x_has_base_t = - FStar_SMTEncoding_Term.mk_HasType - xtm base_t in - let x_has_t = - FStar_SMTEncoding_Term.mk_HasTypeWithFuel - (FStar_Pervasives_Native.Some - fterm) xtm t2 in - let t_has_kind = - FStar_SMTEncoding_Term.mk_HasType t2 - FStar_SMTEncoding_Term.mk_Term_type in - let t_haseq_base = - FStar_SMTEncoding_Term.mk_haseq - base_t in - let t_haseq_ref = - FStar_SMTEncoding_Term.mk_haseq t2 in - let t_haseq = - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_SMTEncoding_Util.mkIff - (t_haseq_ref, - t_haseq_base) in - ([[t_haseq_ref]], cvars1, - uu___12) in - FStar_SMTEncoding_Term.mkForall - t0.FStar_Syntax_Syntax.pos - uu___11 in - (uu___10, - (FStar_Pervasives_Native.Some - (Prims.strcat "haseq for " - tsym)), - (Prims.strcat "haseq" tsym)) in - FStar_SMTEncoding_Util.mkAssume - uu___9 in - let t_kinding = - let uu___9 = - let uu___10 = - FStar_SMTEncoding_Term.mkForall - t0.FStar_Syntax_Syntax.pos - ([[t_has_kind]], cvars1, - t_has_kind) in - (uu___10, - (FStar_Pervasives_Native.Some - "refinement kinding"), - (Prims.strcat - "refinement_kinding_" tsym)) in - FStar_SMTEncoding_Util.mkAssume - uu___9 in - let t_interp = - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_SMTEncoding_Util.mkIff - (x_has_t, encoding) in - ([[x_has_t]], (ffv :: xfv :: - cvars1), uu___12) in - FStar_SMTEncoding_Term.mkForall - t0.FStar_Syntax_Syntax.pos - uu___11 in - (uu___10, - (FStar_Pervasives_Native.Some - "refinement_interpretation"), - (Prims.strcat - "refinement_interpretation_" - tsym)) in - FStar_SMTEncoding_Util.mkAssume - uu___9 in - let t_decls = - [tdecl; - t_kinding; - t_interp; - t_haseq] in - let uu___9 = - let uu___10 = - let uu___11 = - FStar_SMTEncoding_Term.mk_decls - tsym tkey_hash t_decls - (FStar_Compiler_List.op_At - decls decls') in - FStar_Compiler_List.op_At decls' - uu___11 in - FStar_Compiler_List.op_At decls - uu___10 in - (t2, uu___9)))))))) - | FStar_Syntax_Syntax.Tm_uvar (uv, uu___2) -> - let ttm = - let uu___3 = - FStar_Syntax_Unionfind.uvar_id - uv.FStar_Syntax_Syntax.ctx_uvar_head in - FStar_SMTEncoding_Util.mk_Term_uvar uu___3 in - let uu___3 = - let uu___4 = FStar_Syntax_Util.ctx_uvar_typ uv in - encode_term_pred FStar_Pervasives_Native.None uu___4 env ttm in - (match uu___3 with - | (t_has_k, decls) -> - let d = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Syntax_Unionfind.uvar_id - uv.FStar_Syntax_Syntax.ctx_uvar_head in - FStar_Compiler_Util.string_of_int uu___8 in - FStar_Compiler_Util.format1 "uvar_typing_%s" uu___7 in - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.mk_unique - uu___6 in - (t_has_k, (FStar_Pervasives_Native.Some "Uvar typing"), - uu___5) in - FStar_SMTEncoding_Util.mkAssume uu___4 in - let uu___4 = - let uu___5 = FStar_SMTEncoding_Term.mk_decls_trivial [d] in - FStar_Compiler_List.op_At decls uu___5 in - (ttm, uu___4)) - | FStar_Syntax_Syntax.Tm_app uu___2 -> - let uu___3 = FStar_Syntax_Util.head_and_args t0 in - (match uu___3 with - | (head, args_e) -> - let uu___4 = - let uu___5 = head_redex env head in - if uu___5 - then - let uu___6 = maybe_whnf env t0 in - match uu___6 with - | FStar_Pervasives_Native.None -> (head, args_e) - | FStar_Pervasives_Native.Some t2 -> - FStar_Syntax_Util.head_and_args t2 - else (head, args_e) in - (match uu___4 with - | (head1, args_e1) -> - let uu___5 = - let uu___6 = - let uu___7 = FStar_Syntax_Subst.compress head1 in - uu___7.FStar_Syntax_Syntax.n in - (uu___6, args_e1) in - if is_arithmetic_primitive head1 args_e1 - then encode_arith_term env head1 args_e1 - else - if is_BitVector_primitive head1 args_e1 - then encode_BitVector_term env head1 args_e1 - else - (match uu___5 with - | (FStar_Syntax_Syntax.Tm_fvar fv, - (arg, uu___6)::[]) when - ((FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.squash_lid) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.auto_squash_lid)) - && - (let uu___7 = - FStar_Syntax_Formula.destruct_typ_as_formula - arg in - FStar_Compiler_Option.isSome uu___7) - -> - let dummy = - FStar_Syntax_Syntax.new_bv - FStar_Pervasives_Native.None - FStar_Syntax_Syntax.t_unit in - let t2 = FStar_Syntax_Util.refine dummy arg in - encode_term t2 env - | (FStar_Syntax_Syntax.Tm_uinst - ({ - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___6; - FStar_Syntax_Syntax.vars = uu___7; - FStar_Syntax_Syntax.hash_code = uu___8;_}, - uu___9), - (arg, uu___10)::[]) when - ((FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.squash_lid) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.auto_squash_lid)) - && - (let uu___11 = - FStar_Syntax_Formula.destruct_typ_as_formula - arg in - FStar_Compiler_Option.isSome uu___11) - -> - let dummy = - FStar_Syntax_Syntax.new_bv - FStar_Pervasives_Native.None - FStar_Syntax_Syntax.t_unit in - let t2 = FStar_Syntax_Util.refine dummy arg in - encode_term t2 env - | (FStar_Syntax_Syntax.Tm_fvar fv, uu___6) when - (Prims.op_Negation - env.FStar_SMTEncoding_Env.encoding_quantifier) - && - ((FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.forall_lid) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.exists_lid)) - -> encode_deeply_embedded_quantifier t0 env - | (FStar_Syntax_Syntax.Tm_uinst - ({ - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___6; - FStar_Syntax_Syntax.vars = uu___7; - FStar_Syntax_Syntax.hash_code = uu___8;_}, - uu___9), - uu___10) when - (Prims.op_Negation - env.FStar_SMTEncoding_Env.encoding_quantifier) - && - ((FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.forall_lid) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.exists_lid)) - -> encode_deeply_embedded_quantifier t0 env - | (FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_range_of), - (arg, uu___6)::[]) -> - encode_const - (FStar_Const.Const_range - (arg.FStar_Syntax_Syntax.pos)) env - | (FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_set_range_of), - (arg, uu___6)::(rng, uu___7)::[]) -> - encode_term arg env - | (FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_reify lopt), uu___6) -> - let fallback uu___7 = - let f = - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.fresh - env.FStar_SMTEncoding_Env.current_module_name - "Tm_reify" in - let decl = - FStar_SMTEncoding_Term.DeclFun - (f, [], - FStar_SMTEncoding_Term.Term_sort, - (FStar_Pervasives_Native.Some - "Imprecise reify")) in - let uu___8 = - let uu___9 = - FStar_SMTEncoding_Term.mk_fv - (f, FStar_SMTEncoding_Term.Term_sort) in - FStar_SMTEncoding_Util.mkFreeV uu___9 in - let uu___9 = - FStar_SMTEncoding_Term.mk_decls_trivial - [decl] in - (uu___8, uu___9) in - (match lopt with - | FStar_Pervasives_Native.None -> fallback () - | FStar_Pervasives_Native.Some l when - let uu___7 = - FStar_TypeChecker_Env.norm_eff_name - env.FStar_SMTEncoding_Env.tcenv l in - FStar_TypeChecker_Env.is_layered_effect - env.FStar_SMTEncoding_Env.tcenv uu___7 - -> fallback () - | uu___7 -> - let e0 = - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Compiler_List.hd args_e1 in - FStar_Pervasives_Native.fst uu___10 in - FStar_Syntax_Util.mk_reify uu___9 - lopt in - FStar_TypeChecker_Util.norm_reify - env.FStar_SMTEncoding_Env.tcenv [] - uu___8 in - ((let uu___9 = - FStar_Compiler_Effect.op_Bang - dbg_SMTEncodingReify in - if uu___9 - then - let uu___10 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - e0 in - FStar_Compiler_Util.print1 - "Result of normalization %s\n" - uu___10 - else ()); - (let e = - let uu___9 = - FStar_TypeChecker_Util.remove_reify - e0 in - let uu___10 = - FStar_Compiler_List.tl args_e1 in - FStar_Syntax_Syntax.mk_Tm_app uu___9 - uu___10 t0.FStar_Syntax_Syntax.pos in - encode_term e env))) - | (FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_reflect uu___6), - (arg, uu___7)::[]) -> encode_term arg env - | (FStar_Syntax_Syntax.Tm_fvar fv, - uu___6::(phi, uu___7)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.by_tactic_lid - -> encode_term phi env - | (FStar_Syntax_Syntax.Tm_uinst - ({ - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___6; - FStar_Syntax_Syntax.vars = uu___7; - FStar_Syntax_Syntax.hash_code = uu___8;_}, - uu___9), - uu___10::(phi, uu___11)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.by_tactic_lid - -> encode_term phi env - | (FStar_Syntax_Syntax.Tm_fvar fv, - uu___6::uu___7::(phi, uu___8)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.rewrite_by_tactic_lid - -> encode_term phi env - | (FStar_Syntax_Syntax.Tm_uinst - ({ - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___6; - FStar_Syntax_Syntax.vars = uu___7; - FStar_Syntax_Syntax.hash_code = uu___8;_}, - uu___9), - uu___10::uu___11::(phi, uu___12)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.rewrite_by_tactic_lid - -> encode_term phi env - | uu___6 -> - let uu___7 = encode_args args_e1 env in - (match uu___7 with - | (args, decls) -> - let encode_partial_app ht_opt = - let uu___8 = encode_term head1 env in - match uu___8 with - | (smt_head, decls') -> - let app_tm = - mk_Apply_args smt_head args in - (app_tm, - (FStar_Compiler_List.op_At decls - decls')) in - let encode_full_app fv = - let uu___8 = - FStar_SMTEncoding_Env.lookup_free_var_sym - env fv in - match uu___8 with - | (fname, fuel_args, arity) -> - let tm = - maybe_curry_app - t0.FStar_Syntax_Syntax.pos - fname arity - (FStar_Compiler_List.op_At - fuel_args args) in - (tm, decls) in - let head2 = - FStar_Syntax_Subst.compress head1 in - let head_type = - match head2.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_uinst - ({ - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_name x; - FStar_Syntax_Syntax.pos = uu___8; - FStar_Syntax_Syntax.vars = - uu___9; - FStar_Syntax_Syntax.hash_code = - uu___10;_}, - uu___11) - -> - FStar_Pervasives_Native.Some - (x.FStar_Syntax_Syntax.sort) - | FStar_Syntax_Syntax.Tm_name x -> - FStar_Pervasives_Native.Some - (x.FStar_Syntax_Syntax.sort) - | FStar_Syntax_Syntax.Tm_uinst - ({ - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___8; - FStar_Syntax_Syntax.vars = - uu___9; - FStar_Syntax_Syntax.hash_code = - uu___10;_}, - uu___11) - -> - let uu___12 = - let uu___13 = - let uu___14 = - FStar_TypeChecker_Env.lookup_lid - env.FStar_SMTEncoding_Env.tcenv - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - FStar_Pervasives_Native.fst - uu___14 in - FStar_Pervasives_Native.snd - uu___13 in - FStar_Pervasives_Native.Some - uu___12 - | FStar_Syntax_Syntax.Tm_fvar fv -> - let uu___8 = - let uu___9 = - let uu___10 = - FStar_TypeChecker_Env.lookup_lid - env.FStar_SMTEncoding_Env.tcenv - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - FStar_Pervasives_Native.fst - uu___10 in - FStar_Pervasives_Native.snd - uu___9 in - FStar_Pervasives_Native.Some uu___8 - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = uu___8; - FStar_Syntax_Syntax.asc = - (FStar_Pervasives.Inl t2, - uu___9, uu___10); - FStar_Syntax_Syntax.eff_opt = - uu___11;_} - -> FStar_Pervasives_Native.Some t2 - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = uu___8; - FStar_Syntax_Syntax.asc = - (FStar_Pervasives.Inr c, - uu___9, uu___10); - FStar_Syntax_Syntax.eff_opt = - uu___11;_} - -> - FStar_Pervasives_Native.Some - (FStar_Syntax_Util.comp_result c) - | uu___8 -> - FStar_Pervasives_Native.None in - (match head_type with - | FStar_Pervasives_Native.None -> - encode_partial_app - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some - head_type1 -> - let uu___8 = - let head_type2 = - let uu___9 = - normalize_refinement - [FStar_TypeChecker_Env.Weak; - FStar_TypeChecker_Env.HNF; - FStar_TypeChecker_Env.EraseUniverses] - env.FStar_SMTEncoding_Env.tcenv - head_type1 in - FStar_Syntax_Util.unrefine - uu___9 in - let uu___9 = - curried_arrow_formals_comp - head_type2 in - match uu___9 with - | (formals, c) -> - if - (FStar_Compiler_List.length - formals) - < - (FStar_Compiler_List.length - args) - then - let head_type3 = - let uu___10 = - normalize_refinement - [FStar_TypeChecker_Env.Weak; - FStar_TypeChecker_Env.HNF; - FStar_TypeChecker_Env.EraseUniverses; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant] - env.FStar_SMTEncoding_Env.tcenv - head_type2 in - FStar_Syntax_Util.unrefine - uu___10 in - let uu___10 = - curried_arrow_formals_comp - head_type3 in - (match uu___10 with - | (formals1, c1) -> - (head_type3, formals1, - c1)) - else (head_type2, formals, c) in - (match uu___8 with - | (head_type2, formals, c) -> - ((let uu___10 = - FStar_Compiler_Effect.op_Bang - dbg_PartialApp in - if uu___10 - then - let uu___11 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - head_type2 in - let uu___12 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binder) - formals in - let uu___13 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - (FStar_Class_Show.show_tuple2 - FStar_Syntax_Print.showable_term - FStar_Syntax_Print.showable_aqual)) - args_e1 in - FStar_Compiler_Util.print3 - "Encoding partial application, head_type = %s, formals = %s, args = %s\n" - uu___11 uu___12 uu___13 - else ()); - (match head2.FStar_Syntax_Syntax.n - with - | FStar_Syntax_Syntax.Tm_uinst - ({ - FStar_Syntax_Syntax.n - = - FStar_Syntax_Syntax.Tm_fvar - fv; - FStar_Syntax_Syntax.pos - = uu___10; - FStar_Syntax_Syntax.vars - = uu___11; - FStar_Syntax_Syntax.hash_code - = uu___12;_}, - uu___13) - when - (FStar_Compiler_List.length - formals) - = - (FStar_Compiler_List.length - args) - -> - encode_full_app - fv.FStar_Syntax_Syntax.fv_name - | FStar_Syntax_Syntax.Tm_fvar - fv when - (FStar_Compiler_List.length - formals) - = - (FStar_Compiler_List.length - args) - -> - encode_full_app - fv.FStar_Syntax_Syntax.fv_name - | uu___10 -> - if - (FStar_Compiler_List.length - formals) - > - (FStar_Compiler_List.length - args) - then - encode_partial_app - (FStar_Pervasives_Native.Some - (head_type2, - formals, c)) - else - encode_partial_app - FStar_Pervasives_Native.None)))))))) - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs; FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = lopt;_} - -> - let uu___2 = FStar_Syntax_Subst.open_term' bs body in - (match uu___2 with - | (bs1, body1, opening) -> - let fallback uu___3 = - let uu___4 = - let fvs = - let uu___5 = FStar_Syntax_Free.names t0 in - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) - (Obj.magic uu___5) in - let tms = - FStar_Compiler_List.map - (FStar_SMTEncoding_Env.lookup_term_var env) fvs in - let uu___5 = - FStar_Compiler_List.map - (fun uu___6 -> FStar_SMTEncoding_Term.Term_sort) fvs in - (uu___5, tms) in - match uu___4 with - | (arg_sorts, arg_terms) -> - let f = - FStar_SMTEncoding_Env.varops.FStar_SMTEncoding_Env.fresh - env.FStar_SMTEncoding_Env.current_module_name - "Tm_abs" in - let decl = - FStar_SMTEncoding_Term.DeclFun - (f, arg_sorts, FStar_SMTEncoding_Term.Term_sort, - (FStar_Pervasives_Native.Some - "Imprecise function encoding")) in - let fv = - let uu___5 = - FStar_SMTEncoding_Term.mk_fv - (f, FStar_SMTEncoding_Term.Term_sort) in - FStar_SMTEncoding_Util.mkFreeV uu___5 in - let fapp = FStar_SMTEncoding_Util.mkApp (f, arg_terms) in - let uu___5 = - FStar_SMTEncoding_Term.mk_decls_trivial [decl] in - (fapp, uu___5) in - let is_impure rc = - let uu___3 = - FStar_TypeChecker_Util.is_pure_or_ghost_effect - env.FStar_SMTEncoding_Env.tcenv - rc.FStar_Syntax_Syntax.residual_effect in - Prims.op_Negation uu___3 in - let codomain_eff rc = - let res_typ = - match rc.FStar_Syntax_Syntax.residual_typ with - | FStar_Pervasives_Native.None -> - let uu___3 = - let uu___4 = - FStar_TypeChecker_Env.get_range - env.FStar_SMTEncoding_Env.tcenv in - FStar_TypeChecker_Util.new_implicit_var - "SMTEncoding codomain" uu___4 - env.FStar_SMTEncoding_Env.tcenv - FStar_Syntax_Util.ktype0 false in - (match uu___3 with | (t2, uu___4, uu___5) -> t2) - | FStar_Pervasives_Native.Some t2 -> t2 in - let uu___3 = - FStar_Ident.lid_equals - rc.FStar_Syntax_Syntax.residual_effect - FStar_Parser_Const.effect_Tot_lid in - if uu___3 - then - let uu___4 = FStar_Syntax_Syntax.mk_Total res_typ in - FStar_Pervasives_Native.Some uu___4 - else - (let uu___5 = - FStar_Ident.lid_equals - rc.FStar_Syntax_Syntax.residual_effect - FStar_Parser_Const.effect_GTot_lid in - if uu___5 - then - let uu___6 = FStar_Syntax_Syntax.mk_GTotal res_typ in - FStar_Pervasives_Native.Some uu___6 - else FStar_Pervasives_Native.None) in - (match lopt with - | FStar_Pervasives_Native.None -> - ((let uu___4 = - let uu___5 = - let uu___6 = - FStar_Errors_Msg.text - "Losing precision when encoding a function literal:" in - let uu___7 = - FStar_Class_PP.pp - FStar_Syntax_Print.pretty_term t0 in - FStar_Pprint.prefix (Prims.of_int (2)) - Prims.int_one uu___6 uu___7 in - let uu___6 = - let uu___7 = - FStar_Errors_Msg.text - "Unannotated abstraction in the compiler?" in - [uu___7] in - uu___5 :: uu___6 in - FStar_Errors.log_issue - (FStar_Syntax_Syntax.has_range_syntax ()) t0 - FStar_Errors_Codes.Warning_FunctionLiteralPrecisionLoss - () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___4)); - fallback ()) - | FStar_Pervasives_Native.Some rc -> - let uu___3 = - (is_impure rc) && - (let uu___4 = - FStar_SMTEncoding_Util.is_smt_reifiable_rc - env.FStar_SMTEncoding_Env.tcenv rc in - Prims.op_Negation uu___4) in - if uu___3 - then fallback () - else - (let uu___5 = - encode_binders FStar_Pervasives_Native.None bs1 - env in - match uu___5 with - | (vars, guards, envbody, decls, uu___6) -> - let body2 = - let uu___7 = - FStar_SMTEncoding_Util.is_smt_reifiable_rc - env.FStar_SMTEncoding_Env.tcenv rc in - if uu___7 - then - let uu___8 = - FStar_Syntax_Util.mk_reify body1 - (FStar_Pervasives_Native.Some - (rc.FStar_Syntax_Syntax.residual_effect)) in - FStar_TypeChecker_Util.norm_reify - env.FStar_SMTEncoding_Env.tcenv [] uu___8 - else body1 in - let uu___7 = encode_term body2 envbody in - (match uu___7 with - | (body3, decls') -> - let is_pure = - FStar_Syntax_Util.is_pure_effect - rc.FStar_Syntax_Syntax.residual_effect in - let uu___8 = - let uu___9 = codomain_eff rc in - match uu___9 with - | FStar_Pervasives_Native.None -> - (FStar_Pervasives_Native.None, []) - | FStar_Pervasives_Native.Some c -> - let tfun = - FStar_Syntax_Util.arrow bs1 c in - let uu___10 = encode_term tfun env in - (match uu___10 with - | (t2, decls1) -> - ((FStar_Pervasives_Native.Some - t2), decls1)) in - (match uu___8 with - | (arrow_t_opt, decls'') -> - let key_body = - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_SMTEncoding_Util.mk_and_l - guards in - (uu___12, body3) in - FStar_SMTEncoding_Util.mkImp - uu___11 in - ([], vars, uu___10) in - FStar_SMTEncoding_Term.mkForall - t0.FStar_Syntax_Syntax.pos uu___9 in - let cvars = - FStar_SMTEncoding_Term.free_variables - key_body in - let uu___9 = - match arrow_t_opt with - | FStar_Pervasives_Native.None -> - (cvars, key_body) - | FStar_Pervasives_Native.Some t2 -> - let uu___10 = - let uu___11 = - let uu___12 = - FStar_SMTEncoding_Term.free_variables - t2 in - FStar_Compiler_List.op_At - uu___12 cvars in - FStar_Compiler_Util.remove_dups - FStar_SMTEncoding_Term.fv_eq - uu___11 in - let uu___11 = - FStar_SMTEncoding_Util.mkAnd - (key_body, t2) in - (uu___10, uu___11) in - (match uu___9 with - | (cvars1, key_body1) -> - let tkey = - FStar_SMTEncoding_Term.mkForall - t0.FStar_Syntax_Syntax.pos - ([], cvars1, key_body1) in - let tkey_hash = - FStar_SMTEncoding_Term.hash_of_term - tkey in - ((let uu___11 = - FStar_Compiler_Effect.op_Bang - dbg_PartialApp in - if uu___11 - then - let uu___12 = - let uu___13 = - FStar_Compiler_List.map - FStar_SMTEncoding_Term.fv_name - vars in - FStar_Compiler_String.concat - ", " uu___13 in - let uu___13 = - FStar_SMTEncoding_Term.print_smt_term - body3 in - FStar_Compiler_Util.print2 - "Checking eta expansion of\n\tvars={%s}\n\tbody=%s\n" - uu___12 uu___13 - else ()); - (let cvar_sorts = - FStar_Compiler_List.map - FStar_SMTEncoding_Term.fv_sort - cvars1 in - let fsym = - let uu___11 = - FStar_Compiler_Util.digest_of_string - tkey_hash in - Prims.strcat "Tm_abs_" - uu___11 in - let fdecl = - FStar_SMTEncoding_Term.DeclFun - (fsym, cvar_sorts, - FStar_SMTEncoding_Term.Term_sort, - FStar_Pervasives_Native.None) in - let f = - let uu___11 = - let uu___12 = - FStar_Compiler_List.map - FStar_SMTEncoding_Util.mkFreeV - cvars1 in - (fsym, uu___12) in - FStar_SMTEncoding_Util.mkApp - uu___11 in - let app = mk_Apply f vars in - let typing_f = - match arrow_t_opt with - | FStar_Pervasives_Native.None - -> - let tot_fun_ax = - let ax = - let uu___11 = - FStar_Compiler_List.map - (fun uu___12 -> - FStar_SMTEncoding_Util.mkTrue) - vars in - isTotFun_axioms - t0.FStar_Syntax_Syntax.pos - f vars uu___11 - is_pure in - match cvars1 with - | [] -> ax - | uu___11 -> - FStar_SMTEncoding_Term.mkForall - t0.FStar_Syntax_Syntax.pos - ([[f]], cvars1, - ax) in - let a_name = - Prims.strcat "tot_fun_" - fsym in - let uu___11 = - FStar_SMTEncoding_Util.mkAssume - (tot_fun_ax, - (FStar_Pervasives_Native.Some - a_name), a_name) in - [uu___11] - | FStar_Pervasives_Native.Some - t2 -> - let f_has_t = - FStar_SMTEncoding_Term.mk_HasTypeWithFuel - FStar_Pervasives_Native.None - f t2 in - let a_name = - Prims.strcat "typing_" - fsym in - let uu___11 = - let uu___12 = - let uu___13 = - FStar_SMTEncoding_Term.mkForall - t0.FStar_Syntax_Syntax.pos - ([[f]], cvars1, - f_has_t) in - (uu___13, - (FStar_Pervasives_Native.Some - a_name), a_name) in - FStar_SMTEncoding_Util.mkAssume - uu___12 in - [uu___11] in - let interp_f = - let a_name = - Prims.strcat - "interpretation_" fsym in - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - FStar_SMTEncoding_Util.mkEq - (app, body3) in - ([[app]], - (FStar_Compiler_List.op_At - vars cvars1), - uu___14) in - FStar_SMTEncoding_Term.mkForall - t0.FStar_Syntax_Syntax.pos - uu___13 in - (uu___12, - (FStar_Pervasives_Native.Some - a_name), a_name) in - FStar_SMTEncoding_Util.mkAssume - uu___11 in - let f_decls = - FStar_Compiler_List.op_At - (fdecl :: typing_f) - [interp_f] in - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - FStar_SMTEncoding_Term.mk_decls - fsym tkey_hash - f_decls - (FStar_Compiler_List.op_At - decls - (FStar_Compiler_List.op_At - decls' decls'')) in - FStar_Compiler_List.op_At - decls'' uu___14 in - FStar_Compiler_List.op_At - decls' uu___13 in - FStar_Compiler_List.op_At - decls uu___12 in - (f, uu___11))))))))) - | FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = - (uu___2, - { FStar_Syntax_Syntax.lbname = FStar_Pervasives.Inr uu___3; - FStar_Syntax_Syntax.lbunivs = uu___4; - FStar_Syntax_Syntax.lbtyp = uu___5; - FStar_Syntax_Syntax.lbeff = uu___6; - FStar_Syntax_Syntax.lbdef = uu___7; - FStar_Syntax_Syntax.lbattrs = uu___8; - FStar_Syntax_Syntax.lbpos = uu___9;_}::uu___10); - FStar_Syntax_Syntax.body1 = uu___11;_} - -> failwith "Impossible: already handled by encoding of Sig_let" - | FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = - (false, - { FStar_Syntax_Syntax.lbname = FStar_Pervasives.Inl x; - FStar_Syntax_Syntax.lbunivs = uu___2; - FStar_Syntax_Syntax.lbtyp = t11; - FStar_Syntax_Syntax.lbeff = uu___3; - FStar_Syntax_Syntax.lbdef = e1; - FStar_Syntax_Syntax.lbattrs = uu___4; - FStar_Syntax_Syntax.lbpos = uu___5;_}::[]); - FStar_Syntax_Syntax.body1 = e2;_} - -> encode_let x t11 e1 e2 env encode_term - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (false, uu___2::uu___3); - FStar_Syntax_Syntax.body1 = uu___4;_} - -> - failwith "Impossible: non-recursive let with multiple bindings" - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (uu___2, lbs); - FStar_Syntax_Syntax.body1 = uu___3;_} - -> - let names = - FStar_Compiler_List.map - (fun lb -> - let uu___4 = lb in - match uu___4 with - | { FStar_Syntax_Syntax.lbname = lbname; - FStar_Syntax_Syntax.lbunivs = uu___5; - FStar_Syntax_Syntax.lbtyp = uu___6; - FStar_Syntax_Syntax.lbeff = uu___7; - FStar_Syntax_Syntax.lbdef = uu___8; - FStar_Syntax_Syntax.lbattrs = uu___9; - FStar_Syntax_Syntax.lbpos = uu___10;_} -> - let x = FStar_Compiler_Util.left lbname in - let uu___11 = - FStar_Ident.string_of_id - x.FStar_Syntax_Syntax.ppname in - let uu___12 = FStar_Syntax_Syntax.range_of_bv x in - (uu___11, uu___12)) lbs in - FStar_Compiler_Effect.raise - (FStar_SMTEncoding_Env.Inner_let_rec names) - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = e; - FStar_Syntax_Syntax.ret_opt = uu___2; - FStar_Syntax_Syntax.brs = pats; - FStar_Syntax_Syntax.rc_opt1 = uu___3;_} - -> - encode_match e pats FStar_SMTEncoding_Term.mk_Term_unit env - encode_term)) -and (encode_let : - FStar_Syntax_Syntax.bv -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> - FStar_SMTEncoding_Env.env_t -> - (FStar_Syntax_Syntax.term -> - FStar_SMTEncoding_Env.env_t -> - (FStar_SMTEncoding_Term.term * - FStar_SMTEncoding_Term.decls_t)) - -> - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.decls_t)) - = - fun x -> - fun t1 -> - fun e1 -> - fun e2 -> - fun env -> - fun encode_body -> - let uu___ = - let uu___1 = - FStar_Syntax_Util.ascribe e1 - ((FStar_Pervasives.Inl t1), FStar_Pervasives_Native.None, - false) in - encode_term uu___1 env in - match uu___ with - | (ee1, decls1) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.mk_binder x in - [uu___3] in - FStar_Syntax_Subst.open_term uu___2 e2 in - (match uu___1 with - | (xs, e21) -> - let x1 = - let uu___2 = FStar_Compiler_List.hd xs in - uu___2.FStar_Syntax_Syntax.binder_bv in - let env' = - FStar_SMTEncoding_Env.push_term_var env x1 ee1 in - let uu___2 = encode_body e21 env' in - (match uu___2 with - | (ee2, decls2) -> - (ee2, (FStar_Compiler_List.op_At decls1 decls2)))) -and (encode_match : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.branch Prims.list -> - FStar_SMTEncoding_Term.term -> - FStar_SMTEncoding_Env.env_t -> - (FStar_Syntax_Syntax.term -> - FStar_SMTEncoding_Env.env_t -> - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.decls_t)) - -> (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.decls_t)) - = - fun e -> - fun pats -> - fun default_case -> - fun env -> - fun encode_br -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Syntax_Syntax.mk FStar_Syntax_Syntax.Tm_unknown - FStar_Compiler_Range_Type.dummyRange in - FStar_Syntax_Syntax.null_bv uu___2 in - FStar_SMTEncoding_Env.gen_term_var env uu___1 in - match uu___ with - | (scrsym, scr', env1) -> - let uu___1 = encode_term e env1 in - (match uu___1 with - | (scr, decls) -> - let uu___2 = - let encode_branch b uu___3 = - match uu___3 with - | (else_case, decls1) -> - let uu___4 = FStar_Syntax_Subst.open_branch b in - (match uu___4 with - | (p, w, br) -> - let uu___5 = encode_pat env1 p in - (match uu___5 with - | (env0, pattern1) -> - let guard = pattern1.guard scr' in - let projections = - pattern1.projections scr' in - let env2 = - FStar_Compiler_List.fold_left - (fun env3 -> - fun uu___6 -> - match uu___6 with - | (x, t) -> - FStar_SMTEncoding_Env.push_term_var - env3 x t) env1 - projections in - let uu___6 = - match w with - | FStar_Pervasives_Native.None -> - (guard, []) - | FStar_Pervasives_Native.Some w1 -> - let uu___7 = encode_term w1 env2 in - (match uu___7 with - | (w2, decls2) -> - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_SMTEncoding_Term.boxBool - FStar_SMTEncoding_Util.mkTrue in - (w2, uu___12) in - FStar_SMTEncoding_Util.mkEq - uu___11 in - (guard, uu___10) in - FStar_SMTEncoding_Util.mkAnd - uu___9 in - (uu___8, decls2)) in - (match uu___6 with - | (guard1, decls2) -> - let uu___7 = encode_br br env2 in - (match uu___7 with - | (br1, decls3) -> - let uu___8 = - FStar_SMTEncoding_Util.mkITE - (guard1, br1, else_case) in - (uu___8, - (FStar_Compiler_List.op_At - decls1 - (FStar_Compiler_List.op_At - decls2 decls3))))))) in - FStar_Compiler_List.fold_right encode_branch pats - (default_case, decls) in - (match uu___2 with - | (match_tm, decls1) -> - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_SMTEncoding_Term.mk_fv - (scrsym, - FStar_SMTEncoding_Term.Term_sort) in - (uu___7, scr) in - [uu___6] in - (uu___5, match_tm) in - FStar_SMTEncoding_Term.mkLet' uu___4 - FStar_Compiler_Range_Type.dummyRange in - (uu___3, decls1))) -and (encode_pat : - FStar_SMTEncoding_Env.env_t -> - FStar_Syntax_Syntax.pat -> (FStar_SMTEncoding_Env.env_t * pattern)) - = - fun env -> - fun pat -> - (let uu___1 = FStar_Compiler_Debug.medium () in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_pat pat in - FStar_Compiler_Util.print1 "Encoding pattern %s\n" uu___2 - else ()); - (let uu___1 = FStar_TypeChecker_Util.decorated_pattern_as_term pat in - match uu___1 with - | (vars, pat_term) -> - let uu___2 = - FStar_Compiler_List.fold_left - (fun uu___3 -> - fun v -> - match uu___3 with - | (env1, vars1) -> - let uu___4 = - FStar_SMTEncoding_Env.gen_term_var env1 v in - (match uu___4 with - | (xx, uu___5, env2) -> - let uu___6 = - let uu___7 = - let uu___8 = - FStar_SMTEncoding_Term.mk_fv - (xx, FStar_SMTEncoding_Term.Term_sort) in - (v, uu___8) in - uu___7 :: vars1 in - (env2, uu___6))) (env, []) vars in - (match uu___2 with - | (env1, vars1) -> - let rec mk_guard pat1 scrutinee = - match pat1.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_var uu___3 -> - FStar_SMTEncoding_Util.mkTrue - | FStar_Syntax_Syntax.Pat_dot_term uu___3 -> - FStar_SMTEncoding_Util.mkTrue - | FStar_Syntax_Syntax.Pat_constant c -> - let uu___3 = encode_const c env1 in - (match uu___3 with - | (tm, decls) -> - ((match decls with - | uu___5::uu___6 -> - failwith - "Unexpected encoding of constant pattern" - | uu___5 -> ()); - FStar_SMTEncoding_Util.mkEq (scrutinee, tm))) - | FStar_Syntax_Syntax.Pat_cons (f, uu___3, args) -> - let is_f = - let tc_name = - FStar_TypeChecker_Env.typ_of_datacon - env1.FStar_SMTEncoding_Env.tcenv - (f.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - let uu___4 = - FStar_TypeChecker_Env.datacons_of_typ - env1.FStar_SMTEncoding_Env.tcenv tc_name in - match uu___4 with - | (uu___5, uu___6::[]) -> - FStar_SMTEncoding_Util.mkTrue - | uu___5 -> - FStar_SMTEncoding_Env.mk_data_tester env1 - (f.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - scrutinee in - let sub_term_guards = - FStar_Compiler_List.mapi - (fun i -> - fun uu___4 -> - match uu___4 with - | (arg, uu___5) -> - let proj = - FStar_SMTEncoding_Env.primitive_projector_by_pos - env1.FStar_SMTEncoding_Env.tcenv - (f.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - i in - let uu___6 = - FStar_SMTEncoding_Util.mkApp - (proj, [scrutinee]) in - mk_guard arg uu___6) args in - FStar_SMTEncoding_Util.mk_and_l (is_f :: - sub_term_guards) in - let rec mk_projections pat1 scrutinee = - match pat1.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_dot_term uu___3 -> [] - | FStar_Syntax_Syntax.Pat_var x -> [(x, scrutinee)] - | FStar_Syntax_Syntax.Pat_constant uu___3 -> [] - | FStar_Syntax_Syntax.Pat_cons (f, uu___3, args) -> - let uu___4 = - FStar_Compiler_List.mapi - (fun i -> - fun uu___5 -> - match uu___5 with - | (arg, uu___6) -> - let proj = - FStar_SMTEncoding_Env.primitive_projector_by_pos - env1.FStar_SMTEncoding_Env.tcenv - (f.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - i in - let uu___7 = - FStar_SMTEncoding_Util.mkApp - (proj, [scrutinee]) in - mk_projections arg uu___7) args in - FStar_Compiler_List.flatten uu___4 in - let pat_term1 uu___3 = encode_term pat_term env1 in - let pattern1 = - { - pat_vars = vars1; - pat_term = pat_term1; - guard = (mk_guard pat); - projections = (mk_projections pat) - } in - (env1, pattern1))) -and (encode_args : - FStar_Syntax_Syntax.args -> - FStar_SMTEncoding_Env.env_t -> - (FStar_SMTEncoding_Term.term Prims.list * - FStar_SMTEncoding_Term.decls_t)) - = - fun l -> - fun env -> - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun uu___2 -> - match (uu___1, uu___2) with - | ((tms, decls), (t, uu___3)) -> - let uu___4 = encode_term t env in - (match uu___4 with - | (t1, decls') -> - ((t1 :: tms), - (FStar_Compiler_List.op_At decls decls')))) - ([], []) l in - match uu___ with | (l1, decls) -> ((FStar_Compiler_List.rev l1), decls) -and (encode_smt_patterns : - FStar_Syntax_Syntax.arg Prims.list Prims.list -> - FStar_SMTEncoding_Env.env_t -> - (FStar_SMTEncoding_Term.term Prims.list Prims.list * - FStar_SMTEncoding_Term.decls_t)) - = - fun pats_l -> - fun env -> - let env1 = - { - FStar_SMTEncoding_Env.bvar_bindings = - (env.FStar_SMTEncoding_Env.bvar_bindings); - FStar_SMTEncoding_Env.fvar_bindings = - (env.FStar_SMTEncoding_Env.fvar_bindings); - FStar_SMTEncoding_Env.depth = (env.FStar_SMTEncoding_Env.depth); - FStar_SMTEncoding_Env.tcenv = (env.FStar_SMTEncoding_Env.tcenv); - FStar_SMTEncoding_Env.warn = (env.FStar_SMTEncoding_Env.warn); - FStar_SMTEncoding_Env.nolabels = - (env.FStar_SMTEncoding_Env.nolabels); - FStar_SMTEncoding_Env.use_zfuel_name = true; - FStar_SMTEncoding_Env.encode_non_total_function_typ = - (env.FStar_SMTEncoding_Env.encode_non_total_function_typ); - FStar_SMTEncoding_Env.current_module_name = - (env.FStar_SMTEncoding_Env.current_module_name); - FStar_SMTEncoding_Env.encoding_quantifier = - (env.FStar_SMTEncoding_Env.encoding_quantifier); - FStar_SMTEncoding_Env.global_cache = - (env.FStar_SMTEncoding_Env.global_cache) - } in - let encode_smt_pattern t = - let uu___ = FStar_Syntax_Util.head_and_args t in - match uu___ with - | (head, args) -> - let head1 = FStar_Syntax_Util.un_uinst head in - (match ((head1.FStar_Syntax_Syntax.n), args) with - | (FStar_Syntax_Syntax.Tm_fvar fv, - uu___1::(x, uu___2)::(t1, uu___3)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.has_type_lid - -> - let uu___4 = encode_term x env1 in - (match uu___4 with - | (x1, decls) -> - let uu___5 = encode_term t1 env1 in - (match uu___5 with - | (t2, decls') -> - let uu___6 = - FStar_SMTEncoding_Term.mk_HasType x1 t2 in - (uu___6, (FStar_Compiler_List.op_At decls decls')))) - | uu___1 -> encode_term t env1) in - FStar_Compiler_List.fold_right - (fun pats -> - fun uu___ -> - match uu___ with - | (pats_l1, decls) -> - let uu___1 = - FStar_Compiler_List.fold_right - (fun uu___2 -> - fun uu___3 -> - match (uu___2, uu___3) with - | ((p, uu___4), (pats1, decls1)) -> - let uu___5 = encode_smt_pattern p in - (match uu___5 with - | (t, d) -> - let uu___6 = - FStar_SMTEncoding_Term.check_pattern_ok - t in - (match uu___6 with - | FStar_Pervasives_Native.None -> - ((t :: pats1), - (FStar_Compiler_List.op_At d decls1)) - | FStar_Pervasives_Native.Some - illegal_subterm -> - ((let uu___8 = - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - p in - let uu___10 = - FStar_Class_Show.show - FStar_SMTEncoding_Term.showable_smt_term - illegal_subterm in - FStar_Compiler_Util.format2 - "Pattern %s contains illegal sub-term (%s); dropping it" - uu___9 uu___10 in - FStar_Errors.log_issue - (FStar_Syntax_Syntax.has_range_syntax - ()) p - FStar_Errors_Codes.Warning_SMTPatternIllFormed - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___8)); - (pats1, - (FStar_Compiler_List.op_At d - decls1)))))) pats ([], decls) in - (match uu___1 with - | (pats1, decls1) -> ((pats1 :: pats_l1), decls1))) pats_l - ([], []) -and (encode_formula : - FStar_Syntax_Syntax.typ -> - FStar_SMTEncoding_Env.env_t -> - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.decls_t)) - = - fun phi -> - fun env -> - let debug phi1 = - let uu___ = FStar_Compiler_Effect.op_Bang dbg_SMTEncoding in - if uu___ - then - let uu___1 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term phi1 in - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term phi1 in - FStar_Compiler_Util.print2 "Formula (%s) %s\n" uu___1 uu___2 - else () in - let enc f r l = - let uu___ = - FStar_Compiler_Util.fold_map - (fun decls -> - fun x -> - let uu___1 = encode_term (FStar_Pervasives_Native.fst x) env in - match uu___1 with - | (t, decls') -> - ((FStar_Compiler_List.op_At decls decls'), t)) [] l in - match uu___ with - | (decls, args) -> - let uu___1 = - let uu___2 = f args in - { - FStar_SMTEncoding_Term.tm = - (uu___2.FStar_SMTEncoding_Term.tm); - FStar_SMTEncoding_Term.freevars = - (uu___2.FStar_SMTEncoding_Term.freevars); - FStar_SMTEncoding_Term.rng = r - } in - (uu___1, decls) in - let const_op f r uu___ = let uu___1 = f r in (uu___1, []) in - let un_op f l = let uu___ = FStar_Compiler_List.hd l in f uu___ in - let bin_op f uu___ = - match uu___ with - | t1::t2::[] -> f (t1, t2) - | uu___1 -> failwith "Impossible" in - let enc_prop_c f r l = - let uu___ = - FStar_Compiler_Util.fold_map - (fun decls -> - fun uu___1 -> - match uu___1 with - | (t, uu___2) -> - let uu___3 = encode_formula t env in - (match uu___3 with - | (phi1, decls') -> - ((FStar_Compiler_List.op_At decls decls'), phi1))) - [] l in - match uu___ with - | (decls, phis) -> - let uu___1 = - let uu___2 = f phis in - { - FStar_SMTEncoding_Term.tm = - (uu___2.FStar_SMTEncoding_Term.tm); - FStar_SMTEncoding_Term.freevars = - (uu___2.FStar_SMTEncoding_Term.freevars); - FStar_SMTEncoding_Term.rng = r - } in - (uu___1, decls) in - let eq_op r args = - let rf = - FStar_Compiler_List.filter - (fun uu___ -> - match uu___ with - | (a, q) -> - (match q with - | FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = uu___1;_} - -> false - | uu___1 -> true)) args in - if (FStar_Compiler_List.length rf) <> (Prims.of_int (2)) - then - let uu___ = - FStar_Compiler_Util.format1 - "eq_op: got %s non-implicit arguments instead of 2?" - (Prims.string_of_int (FStar_Compiler_List.length rf)) in - failwith uu___ - else - (let uu___1 = enc (bin_op FStar_SMTEncoding_Util.mkEq) in - uu___1 r rf) in - let mk_imp r uu___ = - match uu___ with - | (lhs, uu___1)::(rhs, uu___2)::[] -> - let uu___3 = encode_formula rhs env in - (match uu___3 with - | (l1, decls1) -> - (match l1.FStar_SMTEncoding_Term.tm with - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.TrueOp, uu___4) -> (l1, decls1) - | uu___4 -> - let uu___5 = encode_formula lhs env in - (match uu___5 with - | (l2, decls2) -> - let uu___6 = - FStar_SMTEncoding_Term.mkImp (l2, l1) r in - (uu___6, - (FStar_Compiler_List.op_At decls1 decls2))))) - | uu___1 -> failwith "impossible" in - let mk_ite r uu___ = - match uu___ with - | (guard, uu___1)::(_then, uu___2)::(_else, uu___3)::[] -> - let uu___4 = encode_formula guard env in - (match uu___4 with - | (g, decls1) -> - let uu___5 = encode_formula _then env in - (match uu___5 with - | (t, decls2) -> - let uu___6 = encode_formula _else env in - (match uu___6 with - | (e, decls3) -> - let res = FStar_SMTEncoding_Term.mkITE (g, t, e) r in - (res, - (FStar_Compiler_List.op_At decls1 - (FStar_Compiler_List.op_At decls2 decls3)))))) - | uu___1 -> failwith "impossible" in - let unboxInt_l f l = - let uu___ = FStar_Compiler_List.map FStar_SMTEncoding_Term.unboxInt l in - f uu___ in - let connectives = - let uu___ = - let uu___1 = enc_prop_c (bin_op FStar_SMTEncoding_Util.mkAnd) in - (FStar_Parser_Const.and_lid, uu___1) in - let uu___1 = - let uu___2 = - let uu___3 = enc_prop_c (bin_op FStar_SMTEncoding_Util.mkOr) in - (FStar_Parser_Const.or_lid, uu___3) in - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = enc_prop_c (bin_op FStar_SMTEncoding_Util.mkIff) in - (FStar_Parser_Const.iff_lid, uu___6) in - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - enc_prop_c (un_op FStar_SMTEncoding_Util.mkNot) in - (FStar_Parser_Const.not_lid, uu___9) in - [uu___8; - (FStar_Parser_Const.eq2_lid, eq_op); - (FStar_Parser_Const.c_eq2_lid, eq_op); - (FStar_Parser_Const.true_lid, - (const_op FStar_SMTEncoding_Term.mkTrue)); - (FStar_Parser_Const.false_lid, - (const_op FStar_SMTEncoding_Term.mkFalse))] in - (FStar_Parser_Const.ite_lid, mk_ite) :: uu___7 in - uu___5 :: uu___6 in - (FStar_Parser_Const.imp_lid, mk_imp) :: uu___4 in - uu___2 :: uu___3 in - uu___ :: uu___1 in - let rec fallback phi1 = - match phi1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = phi'; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_labeled - (msg, r, b);_} - -> - let uu___ = encode_formula phi' env in - (match uu___ with - | (phi2, decls) -> - let uu___1 = - FStar_SMTEncoding_Term.mk - (FStar_SMTEncoding_Term.Labeled (phi2, msg, r)) r in - (uu___1, decls)) - | FStar_Syntax_Syntax.Tm_meta uu___ -> - let uu___1 = FStar_Syntax_Util.unmeta phi1 in - encode_formula uu___1 env - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = e; - FStar_Syntax_Syntax.ret_opt = uu___; - FStar_Syntax_Syntax.brs = pats; - FStar_Syntax_Syntax.rc_opt1 = uu___1;_} - -> - let uu___2 = - encode_match e pats FStar_SMTEncoding_Term.mkUnreachable env - encode_formula in - (match uu___2 with | (t, decls) -> (t, decls)) - | FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = - (false, - { FStar_Syntax_Syntax.lbname = FStar_Pervasives.Inl x; - FStar_Syntax_Syntax.lbunivs = uu___; - FStar_Syntax_Syntax.lbtyp = t1; - FStar_Syntax_Syntax.lbeff = uu___1; - FStar_Syntax_Syntax.lbdef = e1; - FStar_Syntax_Syntax.lbattrs = uu___2; - FStar_Syntax_Syntax.lbpos = uu___3;_}::[]); - FStar_Syntax_Syntax.body1 = e2;_} - -> - let uu___4 = encode_let x t1 e1 e2 env encode_formula in - (match uu___4 with | (t, decls) -> (t, decls)) - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = args;_} - -> - let head1 = FStar_Syntax_Util.un_uinst head in - (match ((head1.FStar_Syntax_Syntax.n), args) with - | (FStar_Syntax_Syntax.Tm_fvar fv, - uu___::(x, uu___1)::(t, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.has_type_lid - -> - let uu___3 = encode_term x env in - (match uu___3 with - | (x1, decls) -> - let uu___4 = encode_term t env in - (match uu___4 with - | (t1, decls') -> - let uu___5 = - FStar_SMTEncoding_Term.mk_HasType x1 t1 in - (uu___5, (FStar_Compiler_List.op_At decls decls')))) - | (FStar_Syntax_Syntax.Tm_fvar fv, uu___::(phi2, uu___1)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.by_tactic_lid - -> encode_formula phi2 env - | (FStar_Syntax_Syntax.Tm_uinst - ({ FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___; - FStar_Syntax_Syntax.vars = uu___1; - FStar_Syntax_Syntax.hash_code = uu___2;_}, - uu___3), - uu___4::(phi2, uu___5)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.by_tactic_lid - -> encode_formula phi2 env - | (FStar_Syntax_Syntax.Tm_fvar fv, - uu___::uu___1::(phi2, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.rewrite_by_tactic_lid - -> encode_formula phi2 env - | (FStar_Syntax_Syntax.Tm_uinst - ({ FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___; - FStar_Syntax_Syntax.vars = uu___1; - FStar_Syntax_Syntax.hash_code = uu___2;_}, - uu___3), - uu___4::uu___5::(phi2, uu___6)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.rewrite_by_tactic_lid - -> encode_formula phi2 env - | (FStar_Syntax_Syntax.Tm_fvar fv, - (r, uu___)::(msg, uu___1)::(phi2, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.labeled_lid - -> - let uu___3 = - let uu___4 = - FStar_Syntax_Embeddings_Base.try_unembed - FStar_Syntax_Embeddings.e_range r - FStar_Syntax_Embeddings_Base.id_norm_cb in - let uu___5 = - FStar_Syntax_Embeddings_Base.try_unembed - FStar_Syntax_Embeddings.e_string msg - FStar_Syntax_Embeddings_Base.id_norm_cb in - (uu___4, uu___5) in - (match uu___3 with - | (FStar_Pervasives_Native.Some r1, - FStar_Pervasives_Native.Some s) -> - let phi3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = FStar_Errors_Msg.mkmsg s in - (uu___8, r1, false) in - FStar_Syntax_Syntax.Meta_labeled uu___7 in - { - FStar_Syntax_Syntax.tm2 = phi2; - FStar_Syntax_Syntax.meta = uu___6 - } in - FStar_Syntax_Syntax.Tm_meta uu___5 in - FStar_Syntax_Syntax.mk uu___4 r1 in - fallback phi3 - | (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.Some s) -> - let phi3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = FStar_Errors_Msg.mkmsg s in - (uu___8, (phi2.FStar_Syntax_Syntax.pos), - false) in - FStar_Syntax_Syntax.Meta_labeled uu___7 in - { - FStar_Syntax_Syntax.tm2 = phi2; - FStar_Syntax_Syntax.meta = uu___6 - } in - FStar_Syntax_Syntax.Tm_meta uu___5 in - FStar_Syntax_Syntax.mk uu___4 - phi2.FStar_Syntax_Syntax.pos in - fallback phi3 - | uu___4 -> fallback phi2) - | (FStar_Syntax_Syntax.Tm_fvar fv, (t, uu___)::[]) when - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.squash_lid) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.auto_squash_lid) - -> encode_formula t env - | uu___ -> - let encode_valid uu___1 = - let uu___2 = encode_term phi1 env in - match uu___2 with - | (tt, decls) -> - let tt1 = - let uu___3 = - let uu___4 = - FStar_Compiler_Range_Type.use_range - tt.FStar_SMTEncoding_Term.rng in - let uu___5 = - FStar_Compiler_Range_Type.use_range - phi1.FStar_Syntax_Syntax.pos in - FStar_Compiler_Range_Ops.rng_included uu___4 - uu___5 in - if uu___3 - then tt - else - { - FStar_SMTEncoding_Term.tm = - (tt.FStar_SMTEncoding_Term.tm); - FStar_SMTEncoding_Term.freevars = - (tt.FStar_SMTEncoding_Term.freevars); - FStar_SMTEncoding_Term.rng = - (phi1.FStar_Syntax_Syntax.pos) - } in - let uu___3 = FStar_SMTEncoding_Term.mk_Valid tt1 in - (uu___3, decls) in - let uu___1 = head_redex env head1 in - if uu___1 - then - let uu___2 = maybe_whnf env head1 in - (match uu___2 with - | FStar_Pervasives_Native.None -> encode_valid () - | FStar_Pervasives_Native.Some phi2 -> - encode_formula phi2 env) - else encode_valid ()) - | uu___ -> - let uu___1 = encode_term phi1 env in - (match uu___1 with - | (tt, decls) -> - let tt1 = - let uu___2 = - let uu___3 = - FStar_Compiler_Range_Type.use_range - tt.FStar_SMTEncoding_Term.rng in - let uu___4 = - FStar_Compiler_Range_Type.use_range - phi1.FStar_Syntax_Syntax.pos in - FStar_Compiler_Range_Ops.rng_included uu___3 uu___4 in - if uu___2 - then tt - else - { - FStar_SMTEncoding_Term.tm = - (tt.FStar_SMTEncoding_Term.tm); - FStar_SMTEncoding_Term.freevars = - (tt.FStar_SMTEncoding_Term.freevars); - FStar_SMTEncoding_Term.rng = - (phi1.FStar_Syntax_Syntax.pos) - } in - let uu___2 = FStar_SMTEncoding_Term.mk_Valid tt1 in - (uu___2, decls)) in - let encode_q_body env1 bs ps body = - let uu___ = encode_binders FStar_Pervasives_Native.None bs env1 in - match uu___ with - | (vars, guards, env2, decls, uu___1) -> - let uu___2 = encode_smt_patterns ps env2 in - (match uu___2 with - | (pats, decls') -> - let uu___3 = encode_formula body env2 in - (match uu___3 with - | (body1, decls'') -> - let guards1 = - match pats with - | ({ - FStar_SMTEncoding_Term.tm = - FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Var gf, p::[]); - FStar_SMTEncoding_Term.freevars = uu___4; - FStar_SMTEncoding_Term.rng = uu___5;_}::[])::[] - when - let uu___6 = - FStar_Ident.string_of_lid - FStar_Parser_Const.guard_free in - uu___6 = gf -> [] - | uu___4 -> guards in - let uu___4 = FStar_SMTEncoding_Util.mk_and_l guards1 in - (vars, pats, uu___4, body1, - (FStar_Compiler_List.op_At decls - (FStar_Compiler_List.op_At decls' decls''))))) in - debug phi; - (let phi1 = FStar_Syntax_Util.unascribe phi in - let uu___1 = FStar_Syntax_Formula.destruct_typ_as_formula phi1 in - match uu___1 with - | FStar_Pervasives_Native.None -> fallback phi1 - | FStar_Pervasives_Native.Some (FStar_Syntax_Formula.BaseConn - (op, arms)) -> - let uu___2 = - FStar_Compiler_List.tryFind - (fun uu___3 -> - match uu___3 with - | (l, uu___4) -> FStar_Ident.lid_equals op l) connectives in - (match uu___2 with - | FStar_Pervasives_Native.None -> fallback phi1 - | FStar_Pervasives_Native.Some (uu___3, f) -> - f phi1.FStar_Syntax_Syntax.pos arms) - | FStar_Pervasives_Native.Some (FStar_Syntax_Formula.QAll - (vars, pats, body)) -> - (FStar_Compiler_List.iter (check_pattern_vars env vars) pats; - (let uu___3 = encode_q_body env vars pats body in - match uu___3 with - | (vars1, pats1, guard, body1, decls) -> - let tm = - let uu___4 = - let uu___5 = FStar_SMTEncoding_Util.mkImp (guard, body1) in - (pats1, vars1, uu___5) in - FStar_SMTEncoding_Term.mkForall - phi1.FStar_Syntax_Syntax.pos uu___4 in - (tm, decls))) - | FStar_Pervasives_Native.Some (FStar_Syntax_Formula.QEx - (vars, pats, body)) -> - (FStar_Compiler_List.iter (check_pattern_vars env vars) pats; - (let uu___3 = encode_q_body env vars pats body in - match uu___3 with - | (vars1, pats1, guard, body1, decls) -> - let uu___4 = - let uu___5 = - let uu___6 = FStar_SMTEncoding_Util.mkAnd (guard, body1) in - (pats1, vars1, uu___6) in - FStar_SMTEncoding_Term.mkExists - phi1.FStar_Syntax_Syntax.pos uu___5 in - (uu___4, decls)))) -let (encode_function_type_as_formula : - FStar_Syntax_Syntax.typ -> - FStar_SMTEncoding_Env.env_t -> - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.decls_t)) - = - fun t -> - fun env -> - let universe_of_binders binders = - FStar_Compiler_List.map (fun uu___ -> FStar_Syntax_Syntax.U_zero) - binders in - let quant = FStar_Syntax_Util.smt_lemma_as_forall t universe_of_binders in - let env1 = - { - FStar_SMTEncoding_Env.bvar_bindings = - (env.FStar_SMTEncoding_Env.bvar_bindings); - FStar_SMTEncoding_Env.fvar_bindings = - (env.FStar_SMTEncoding_Env.fvar_bindings); - FStar_SMTEncoding_Env.depth = (env.FStar_SMTEncoding_Env.depth); - FStar_SMTEncoding_Env.tcenv = (env.FStar_SMTEncoding_Env.tcenv); - FStar_SMTEncoding_Env.warn = (env.FStar_SMTEncoding_Env.warn); - FStar_SMTEncoding_Env.nolabels = - (env.FStar_SMTEncoding_Env.nolabels); - FStar_SMTEncoding_Env.use_zfuel_name = true; - FStar_SMTEncoding_Env.encode_non_total_function_typ = - (env.FStar_SMTEncoding_Env.encode_non_total_function_typ); - FStar_SMTEncoding_Env.current_module_name = - (env.FStar_SMTEncoding_Env.current_module_name); - FStar_SMTEncoding_Env.encoding_quantifier = - (env.FStar_SMTEncoding_Env.encoding_quantifier); - FStar_SMTEncoding_Env.global_cache = - (env.FStar_SMTEncoding_Env.global_cache) - } in - encode_formula quant env1 \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Env.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Env.ml deleted file mode 100644 index 578c18f5589..00000000000 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Env.ml +++ /dev/null @@ -1,1098 +0,0 @@ -open Prims -let (dbg_PartialApp : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "PartialApp" -exception Inner_let_rec of (Prims.string * FStar_Compiler_Range_Type.range) - Prims.list -let (uu___is_Inner_let_rec : Prims.exn -> Prims.bool) = - fun projectee -> - match projectee with | Inner_let_rec uu___ -> true | uu___ -> false -let (__proj__Inner_let_rec__item__uu___ : - Prims.exn -> (Prims.string * FStar_Compiler_Range_Type.range) Prims.list) = - fun projectee -> match projectee with | Inner_let_rec uu___ -> uu___ -let add_fuel : 'uuuuu . 'uuuuu -> 'uuuuu Prims.list -> 'uuuuu Prims.list = - fun x -> - fun tl -> - let uu___ = FStar_Options.unthrottle_inductives () in - if uu___ then tl else x :: tl -let withenv : - 'uuuuu 'uuuuu1 'uuuuu2 . - 'uuuuu -> ('uuuuu1 * 'uuuuu2) -> ('uuuuu1 * 'uuuuu2 * 'uuuuu) - = fun c -> fun uu___ -> match uu___ with | (a, b) -> (a, b, c) -let vargs : - 'uuuuu 'uuuuu1 'uuuuu2 . - (('uuuuu, 'uuuuu1) FStar_Pervasives.either * 'uuuuu2) Prims.list -> - (('uuuuu, 'uuuuu1) FStar_Pervasives.either * 'uuuuu2) Prims.list - = - fun args -> - FStar_Compiler_List.filter - (fun uu___ -> - match uu___ with - | (FStar_Pervasives.Inl uu___1, uu___2) -> false - | uu___1 -> true) args -let (escape : Prims.string -> Prims.string) = - fun s -> FStar_Compiler_Util.replace_char s 39 95 -let (mk_term_projector_name : - FStar_Ident.lident -> FStar_Syntax_Syntax.bv -> Prims.string) = - fun lid -> - fun a -> - let uu___ = - let uu___1 = FStar_Ident.string_of_lid lid in - let uu___2 = FStar_Ident.string_of_id a.FStar_Syntax_Syntax.ppname in - FStar_Compiler_Util.format2 "%s_%s" uu___1 uu___2 in - escape uu___ -let (primitive_projector_by_pos : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident -> Prims.int -> Prims.string) - = - fun env -> - fun lid -> - fun i -> - let fail uu___ = - let uu___1 = - let uu___2 = FStar_Ident.string_of_lid lid in - FStar_Compiler_Util.format2 - "Projector %s on data constructor %s not found" - (Prims.string_of_int i) uu___2 in - failwith uu___1 in - let uu___ = FStar_TypeChecker_Env.lookup_datacon env lid in - match uu___ with - | (uu___1, t) -> - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress t in - uu___3.FStar_Syntax_Syntax.n in - (match uu___2 with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; - FStar_Syntax_Syntax.comp = c;_} - -> - let uu___3 = FStar_Syntax_Subst.open_comp bs c in - (match uu___3 with - | (binders, uu___4) -> - if - (i < Prims.int_zero) || - (i >= (FStar_Compiler_List.length binders)) - then fail () - else - (let b = FStar_Compiler_List.nth binders i in - mk_term_projector_name lid - b.FStar_Syntax_Syntax.binder_bv)) - | uu___3 -> fail ()) -let (mk_term_projector_name_by_pos : - FStar_Ident.lident -> Prims.int -> Prims.string) = - fun lid -> - fun i -> - let uu___ = - let uu___1 = FStar_Ident.string_of_lid lid in - FStar_Compiler_Util.format2 "%s_%s" uu___1 (Prims.string_of_int i) in - escape uu___ -let (mk_term_projector : - FStar_Ident.lident -> FStar_Syntax_Syntax.bv -> FStar_SMTEncoding_Term.term) - = - fun lid -> - fun a -> - let uu___ = - let uu___1 = - let uu___2 = mk_term_projector_name lid a in - (uu___2, - (FStar_SMTEncoding_Term.Arrow - (FStar_SMTEncoding_Term.Term_sort, - FStar_SMTEncoding_Term.Term_sort))) in - FStar_SMTEncoding_Term.mk_fv uu___1 in - FStar_SMTEncoding_Util.mkFreeV uu___ -let (mk_term_projector_by_pos : - FStar_Ident.lident -> Prims.int -> FStar_SMTEncoding_Term.term) = - fun lid -> - fun i -> - let uu___ = - let uu___1 = - let uu___2 = mk_term_projector_name_by_pos lid i in - (uu___2, - (FStar_SMTEncoding_Term.Arrow - (FStar_SMTEncoding_Term.Term_sort, - FStar_SMTEncoding_Term.Term_sort))) in - FStar_SMTEncoding_Term.mk_fv uu___1 in - FStar_SMTEncoding_Util.mkFreeV uu___ -let mk_data_tester : - 'uuuuu . - 'uuuuu -> - FStar_Ident.lident -> - FStar_SMTEncoding_Term.term -> FStar_SMTEncoding_Term.term - = - fun env -> - fun l -> - fun x -> - let uu___ = let uu___1 = FStar_Ident.string_of_lid l in escape uu___1 in - FStar_SMTEncoding_Term.mk_tester uu___ x -type varops_t = - { - push: unit -> unit ; - pop: unit -> unit ; - snapshot: unit -> (Prims.int * unit) ; - rollback: Prims.int FStar_Pervasives_Native.option -> unit ; - new_var: FStar_Ident.ident -> Prims.int -> Prims.string ; - new_fvar: FStar_Ident.lident -> Prims.string ; - fresh: Prims.string -> Prims.string -> Prims.string ; - reset_fresh: unit -> unit ; - next_id: unit -> Prims.int ; - mk_unique: Prims.string -> Prims.string } -let (__proj__Mkvarops_t__item__push : varops_t -> unit -> unit) = - fun projectee -> - match projectee with - | { push; pop; snapshot; rollback; new_var; new_fvar; fresh; reset_fresh; - next_id; mk_unique;_} -> push -let (__proj__Mkvarops_t__item__pop : varops_t -> unit -> unit) = - fun projectee -> - match projectee with - | { push; pop; snapshot; rollback; new_var; new_fvar; fresh; reset_fresh; - next_id; mk_unique;_} -> pop -let (__proj__Mkvarops_t__item__snapshot : - varops_t -> unit -> (Prims.int * unit)) = - fun projectee -> - match projectee with - | { push; pop; snapshot; rollback; new_var; new_fvar; fresh; reset_fresh; - next_id; mk_unique;_} -> snapshot -let (__proj__Mkvarops_t__item__rollback : - varops_t -> Prims.int FStar_Pervasives_Native.option -> unit) = - fun projectee -> - match projectee with - | { push; pop; snapshot; rollback; new_var; new_fvar; fresh; reset_fresh; - next_id; mk_unique;_} -> rollback -let (__proj__Mkvarops_t__item__new_var : - varops_t -> FStar_Ident.ident -> Prims.int -> Prims.string) = - fun projectee -> - match projectee with - | { push; pop; snapshot; rollback; new_var; new_fvar; fresh; reset_fresh; - next_id; mk_unique;_} -> new_var -let (__proj__Mkvarops_t__item__new_fvar : - varops_t -> FStar_Ident.lident -> Prims.string) = - fun projectee -> - match projectee with - | { push; pop; snapshot; rollback; new_var; new_fvar; fresh; reset_fresh; - next_id; mk_unique;_} -> new_fvar -let (__proj__Mkvarops_t__item__fresh : - varops_t -> Prims.string -> Prims.string -> Prims.string) = - fun projectee -> - match projectee with - | { push; pop; snapshot; rollback; new_var; new_fvar; fresh; reset_fresh; - next_id; mk_unique;_} -> fresh -let (__proj__Mkvarops_t__item__reset_fresh : varops_t -> unit -> unit) = - fun projectee -> - match projectee with - | { push; pop; snapshot; rollback; new_var; new_fvar; fresh; reset_fresh; - next_id; mk_unique;_} -> reset_fresh -let (__proj__Mkvarops_t__item__next_id : varops_t -> unit -> Prims.int) = - fun projectee -> - match projectee with - | { push; pop; snapshot; rollback; new_var; new_fvar; fresh; reset_fresh; - next_id; mk_unique;_} -> next_id -let (__proj__Mkvarops_t__item__mk_unique : - varops_t -> Prims.string -> Prims.string) = - fun projectee -> - match projectee with - | { push; pop; snapshot; rollback; new_var; new_fvar; fresh; reset_fresh; - next_id; mk_unique;_} -> mk_unique -let (varops : varops_t) = - let initial_ctr = (Prims.of_int (100)) in - let ctr = FStar_Compiler_Util.mk_ref initial_ctr in - let new_scope uu___ = FStar_Compiler_Util.smap_create (Prims.of_int (100)) in - let scopes = - let uu___ = let uu___1 = new_scope () in [uu___1] in - FStar_Compiler_Util.mk_ref uu___ in - let mk_unique y = - let y1 = escape y in - let y2 = - let uu___ = - let uu___1 = FStar_Compiler_Effect.op_Bang scopes in - FStar_Compiler_Util.find_map uu___1 - (fun names -> FStar_Compiler_Util.smap_try_find names y1) in - match uu___ with - | FStar_Pervasives_Native.None -> y1 - | FStar_Pervasives_Native.Some uu___1 -> - (FStar_Compiler_Util.incr ctr; - (let uu___3 = - let uu___4 = - let uu___5 = FStar_Compiler_Effect.op_Bang ctr in - Prims.string_of_int uu___5 in - Prims.strcat "__" uu___4 in - Prims.strcat y1 uu___3)) in - let top_scope = - let uu___ = FStar_Compiler_Effect.op_Bang scopes in - FStar_Compiler_List.hd uu___ in - FStar_Compiler_Util.smap_add top_scope y2 true; y2 in - let new_var pp rn = - let uu___ = - let uu___1 = FStar_Ident.string_of_id pp in - Prims.strcat uu___1 (Prims.strcat "__" (Prims.string_of_int rn)) in - mk_unique uu___ in - let new_fvar lid = - let uu___ = FStar_Ident.string_of_lid lid in mk_unique uu___ in - let next_id uu___ = - FStar_Compiler_Util.incr ctr; FStar_Compiler_Effect.op_Bang ctr in - let fresh mname pfx = - let uu___ = let uu___1 = next_id () in Prims.string_of_int uu___1 in - FStar_Compiler_Util.format3 "%s_%s_%s" pfx mname uu___ in - let reset_fresh uu___ = - FStar_Compiler_Effect.op_Colon_Equals ctr initial_ctr in - let push uu___ = - let uu___1 = - let uu___2 = new_scope () in - let uu___3 = FStar_Compiler_Effect.op_Bang scopes in uu___2 :: uu___3 in - FStar_Compiler_Effect.op_Colon_Equals scopes uu___1 in - let pop uu___ = - let uu___1 = - let uu___2 = FStar_Compiler_Effect.op_Bang scopes in - FStar_Compiler_List.tl uu___2 in - FStar_Compiler_Effect.op_Colon_Equals scopes uu___1 in - let snapshot uu___ = FStar_Common.snapshot push scopes () in - let rollback depth = FStar_Common.rollback pop scopes depth in - { - push; - pop; - snapshot; - rollback; - new_var; - new_fvar; - fresh; - reset_fresh; - next_id; - mk_unique - } -type fvar_binding = - { - fvar_lid: FStar_Ident.lident ; - smt_arity: Prims.int ; - smt_id: Prims.string ; - smt_token: FStar_SMTEncoding_Term.term FStar_Pervasives_Native.option ; - smt_fuel_partial_app: - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) - FStar_Pervasives_Native.option - ; - fvb_thunked: Prims.bool } -let (__proj__Mkfvar_binding__item__fvar_lid : - fvar_binding -> FStar_Ident.lident) = - fun projectee -> - match projectee with - | { fvar_lid; smt_arity; smt_id; smt_token; smt_fuel_partial_app; - fvb_thunked;_} -> fvar_lid -let (__proj__Mkfvar_binding__item__smt_arity : fvar_binding -> Prims.int) = - fun projectee -> - match projectee with - | { fvar_lid; smt_arity; smt_id; smt_token; smt_fuel_partial_app; - fvb_thunked;_} -> smt_arity -let (__proj__Mkfvar_binding__item__smt_id : fvar_binding -> Prims.string) = - fun projectee -> - match projectee with - | { fvar_lid; smt_arity; smt_id; smt_token; smt_fuel_partial_app; - fvb_thunked;_} -> smt_id -let (__proj__Mkfvar_binding__item__smt_token : - fvar_binding -> FStar_SMTEncoding_Term.term FStar_Pervasives_Native.option) - = - fun projectee -> - match projectee with - | { fvar_lid; smt_arity; smt_id; smt_token; smt_fuel_partial_app; - fvb_thunked;_} -> smt_token -let (__proj__Mkfvar_binding__item__smt_fuel_partial_app : - fvar_binding -> - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) - FStar_Pervasives_Native.option) - = - fun projectee -> - match projectee with - | { fvar_lid; smt_arity; smt_id; smt_token; smt_fuel_partial_app; - fvb_thunked;_} -> smt_fuel_partial_app -let (__proj__Mkfvar_binding__item__fvb_thunked : fvar_binding -> Prims.bool) - = - fun projectee -> - match projectee with - | { fvar_lid; smt_arity; smt_id; smt_token; smt_fuel_partial_app; - fvb_thunked;_} -> fvb_thunked -let (fvb_to_string : fvar_binding -> Prims.string) = - fun fvb -> - let term_opt_to_string uu___ = - match uu___ with - | FStar_Pervasives_Native.None -> "None" - | FStar_Pervasives_Native.Some s -> - FStar_SMTEncoding_Term.print_smt_term s in - let term_pair_opt_to_string uu___ = - match uu___ with - | FStar_Pervasives_Native.None -> "None" - | FStar_Pervasives_Native.Some (s0, s1) -> - let uu___1 = FStar_SMTEncoding_Term.print_smt_term s0 in - let uu___2 = FStar_SMTEncoding_Term.print_smt_term s1 in - FStar_Compiler_Util.format2 "(%s, %s)" uu___1 uu___2 in - let uu___ = FStar_Ident.string_of_lid fvb.fvar_lid in - let uu___1 = term_opt_to_string fvb.smt_token in - let uu___2 = term_pair_opt_to_string fvb.smt_fuel_partial_app in - let uu___3 = FStar_Compiler_Util.string_of_bool fvb.fvb_thunked in - FStar_Compiler_Util.format6 - "{ lid = %s;\n smt_arity = %s;\n smt_id = %s;\n smt_token = %s;\n smt_fuel_partial_app = %s;\n fvb_thunked = %s }" - uu___ (Prims.string_of_int fvb.smt_arity) fvb.smt_id uu___1 uu___2 - uu___3 -let (check_valid_fvb : fvar_binding -> unit) = - fun fvb -> - if - ((FStar_Compiler_Option.isSome fvb.smt_token) || - (FStar_Compiler_Option.isSome fvb.smt_fuel_partial_app)) - && fvb.fvb_thunked - then - (let uu___1 = - let uu___2 = FStar_Ident.string_of_lid fvb.fvar_lid in - FStar_Compiler_Util.format1 "Unexpected thunked SMT symbol: %s" - uu___2 in - failwith uu___1) - else - if fvb.fvb_thunked && (fvb.smt_arity <> Prims.int_zero) - then - (let uu___2 = - let uu___3 = FStar_Ident.string_of_lid fvb.fvar_lid in - FStar_Compiler_Util.format1 - "Unexpected arity of thunked SMT symbol: %s" uu___3 in - failwith uu___2) - else (); - (match fvb.smt_token with - | FStar_Pervasives_Native.Some - { FStar_SMTEncoding_Term.tm = FStar_SMTEncoding_Term.FreeV uu___1; - FStar_SMTEncoding_Term.freevars = uu___2; - FStar_SMTEncoding_Term.rng = uu___3;_} - -> - let uu___4 = - let uu___5 = fvb_to_string fvb in - FStar_Compiler_Util.format1 "bad fvb\n%s" uu___5 in - failwith uu___4 - | uu___1 -> ()) -let binder_of_eithervar : - 'uuuuu 'uuuuu1 . - 'uuuuu -> ('uuuuu * 'uuuuu1 FStar_Pervasives_Native.option) - = fun v -> (v, FStar_Pervasives_Native.None) -type env_t = - { - bvar_bindings: - (FStar_Syntax_Syntax.bv * FStar_SMTEncoding_Term.term) - FStar_Compiler_Util.pimap FStar_Compiler_Util.psmap - ; - fvar_bindings: - (fvar_binding FStar_Compiler_Util.psmap * fvar_binding Prims.list) ; - depth: Prims.int ; - tcenv: FStar_TypeChecker_Env.env ; - warn: Prims.bool ; - nolabels: Prims.bool ; - use_zfuel_name: Prims.bool ; - encode_non_total_function_typ: Prims.bool ; - current_module_name: Prims.string ; - encoding_quantifier: Prims.bool ; - global_cache: FStar_SMTEncoding_Term.decls_elt FStar_Compiler_Util.smap } -let (__proj__Mkenv_t__item__bvar_bindings : - env_t -> - (FStar_Syntax_Syntax.bv * FStar_SMTEncoding_Term.term) - FStar_Compiler_Util.pimap FStar_Compiler_Util.psmap) - = - fun projectee -> - match projectee with - | { bvar_bindings; fvar_bindings; depth; tcenv; warn; nolabels; - use_zfuel_name; encode_non_total_function_typ; current_module_name; - encoding_quantifier; global_cache;_} -> bvar_bindings -let (__proj__Mkenv_t__item__fvar_bindings : - env_t -> (fvar_binding FStar_Compiler_Util.psmap * fvar_binding Prims.list)) - = - fun projectee -> - match projectee with - | { bvar_bindings; fvar_bindings; depth; tcenv; warn; nolabels; - use_zfuel_name; encode_non_total_function_typ; current_module_name; - encoding_quantifier; global_cache;_} -> fvar_bindings -let (__proj__Mkenv_t__item__depth : env_t -> Prims.int) = - fun projectee -> - match projectee with - | { bvar_bindings; fvar_bindings; depth; tcenv; warn; nolabels; - use_zfuel_name; encode_non_total_function_typ; current_module_name; - encoding_quantifier; global_cache;_} -> depth -let (__proj__Mkenv_t__item__tcenv : env_t -> FStar_TypeChecker_Env.env) = - fun projectee -> - match projectee with - | { bvar_bindings; fvar_bindings; depth; tcenv; warn; nolabels; - use_zfuel_name; encode_non_total_function_typ; current_module_name; - encoding_quantifier; global_cache;_} -> tcenv -let (__proj__Mkenv_t__item__warn : env_t -> Prims.bool) = - fun projectee -> - match projectee with - | { bvar_bindings; fvar_bindings; depth; tcenv; warn; nolabels; - use_zfuel_name; encode_non_total_function_typ; current_module_name; - encoding_quantifier; global_cache;_} -> warn -let (__proj__Mkenv_t__item__nolabels : env_t -> Prims.bool) = - fun projectee -> - match projectee with - | { bvar_bindings; fvar_bindings; depth; tcenv; warn; nolabels; - use_zfuel_name; encode_non_total_function_typ; current_module_name; - encoding_quantifier; global_cache;_} -> nolabels -let (__proj__Mkenv_t__item__use_zfuel_name : env_t -> Prims.bool) = - fun projectee -> - match projectee with - | { bvar_bindings; fvar_bindings; depth; tcenv; warn; nolabels; - use_zfuel_name; encode_non_total_function_typ; current_module_name; - encoding_quantifier; global_cache;_} -> use_zfuel_name -let (__proj__Mkenv_t__item__encode_non_total_function_typ : - env_t -> Prims.bool) = - fun projectee -> - match projectee with - | { bvar_bindings; fvar_bindings; depth; tcenv; warn; nolabels; - use_zfuel_name; encode_non_total_function_typ; current_module_name; - encoding_quantifier; global_cache;_} -> encode_non_total_function_typ -let (__proj__Mkenv_t__item__current_module_name : env_t -> Prims.string) = - fun projectee -> - match projectee with - | { bvar_bindings; fvar_bindings; depth; tcenv; warn; nolabels; - use_zfuel_name; encode_non_total_function_typ; current_module_name; - encoding_quantifier; global_cache;_} -> current_module_name -let (__proj__Mkenv_t__item__encoding_quantifier : env_t -> Prims.bool) = - fun projectee -> - match projectee with - | { bvar_bindings; fvar_bindings; depth; tcenv; warn; nolabels; - use_zfuel_name; encode_non_total_function_typ; current_module_name; - encoding_quantifier; global_cache;_} -> encoding_quantifier -let (__proj__Mkenv_t__item__global_cache : - env_t -> FStar_SMTEncoding_Term.decls_elt FStar_Compiler_Util.smap) = - fun projectee -> - match projectee with - | { bvar_bindings; fvar_bindings; depth; tcenv; warn; nolabels; - use_zfuel_name; encode_non_total_function_typ; current_module_name; - encoding_quantifier; global_cache;_} -> global_cache -let (print_env : env_t -> Prims.string) = - fun e -> - let bvars = - FStar_Compiler_Util.psmap_fold e.bvar_bindings - (fun _k -> - fun pi -> - fun acc -> - FStar_Compiler_Util.pimap_fold pi - (fun _i -> - fun uu___ -> - fun acc1 -> - match uu___ with - | (x, _term) -> - let uu___1 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_bv x in - uu___1 :: acc1) acc) [] in - let allvars = - FStar_Compiler_Util.psmap_fold - (FStar_Pervasives_Native.fst e.fvar_bindings) - (fun _k -> fun fvb -> fun acc -> (fvb.fvar_lid) :: acc) [] in - let last_fvar = - match FStar_Compiler_List.rev allvars with - | [] -> "" - | l::uu___ -> - let uu___1 = FStar_Class_Show.show FStar_Ident.showable_lident l in - Prims.strcat "...," uu___1 in - FStar_Compiler_String.concat ", " (last_fvar :: bvars) -let (lookup_bvar_binding : - env_t -> - FStar_Syntax_Syntax.bv -> - (FStar_Syntax_Syntax.bv * FStar_SMTEncoding_Term.term) - FStar_Pervasives_Native.option) - = - fun env -> - fun bv -> - let uu___ = - let uu___1 = FStar_Ident.string_of_id bv.FStar_Syntax_Syntax.ppname in - FStar_Compiler_Util.psmap_try_find env.bvar_bindings uu___1 in - match uu___ with - | FStar_Pervasives_Native.Some bvs -> - FStar_Compiler_Util.pimap_try_find bvs bv.FStar_Syntax_Syntax.index - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None -let (lookup_fvar_binding : - env_t -> FStar_Ident.lident -> fvar_binding FStar_Pervasives_Native.option) - = - fun env -> - fun lid -> - let uu___ = FStar_Ident.string_of_lid lid in - FStar_Compiler_Util.psmap_try_find - (FStar_Pervasives_Native.fst env.fvar_bindings) uu___ -let add_bvar_binding : - 'uuuuu . - (FStar_Syntax_Syntax.bv * 'uuuuu) -> - (FStar_Syntax_Syntax.bv * 'uuuuu) FStar_Compiler_Util.pimap - FStar_Compiler_Util.psmap -> - (FStar_Syntax_Syntax.bv * 'uuuuu) FStar_Compiler_Util.pimap - FStar_Compiler_Util.psmap - = - fun bvb -> - fun bvbs -> - let uu___ = - FStar_Ident.string_of_id - (FStar_Pervasives_Native.fst bvb).FStar_Syntax_Syntax.ppname in - FStar_Compiler_Util.psmap_modify bvbs uu___ - (fun pimap_opt -> - let uu___1 = - let uu___2 = FStar_Compiler_Util.pimap_empty () in - FStar_Compiler_Util.dflt uu___2 pimap_opt in - FStar_Compiler_Util.pimap_add uu___1 - (FStar_Pervasives_Native.fst bvb).FStar_Syntax_Syntax.index bvb) -let (add_fvar_binding : - fvar_binding -> - (fvar_binding FStar_Compiler_Util.psmap * fvar_binding Prims.list) -> - (fvar_binding FStar_Compiler_Util.psmap * fvar_binding Prims.list)) - = - fun fvb -> - fun uu___ -> - match uu___ with - | (fvb_map, fvb_list) -> - let uu___1 = - let uu___2 = FStar_Ident.string_of_lid fvb.fvar_lid in - FStar_Compiler_Util.psmap_add fvb_map uu___2 fvb in - (uu___1, (fvb :: fvb_list)) -let (fresh_fvar : - Prims.string -> - Prims.string -> - FStar_SMTEncoding_Term.sort -> - (Prims.string * FStar_SMTEncoding_Term.term)) - = - fun mname -> - fun x -> - fun s -> - let xsym = varops.fresh mname x in - let uu___ = - let uu___1 = FStar_SMTEncoding_Term.mk_fv (xsym, s) in - FStar_SMTEncoding_Util.mkFreeV uu___1 in - (xsym, uu___) -let (gen_term_var : - env_t -> - FStar_Syntax_Syntax.bv -> - (Prims.string * FStar_SMTEncoding_Term.term * env_t)) - = - fun env -> - fun x -> - let ysym = Prims.strcat "@x" (Prims.string_of_int env.depth) in - let y = - let uu___ = - FStar_SMTEncoding_Term.mk_fv - (ysym, FStar_SMTEncoding_Term.Term_sort) in - FStar_SMTEncoding_Util.mkFreeV uu___ in - let uu___ = - let uu___1 = add_bvar_binding (x, y) env.bvar_bindings in - let uu___2 = FStar_TypeChecker_Env.push_bv env.tcenv x in - { - bvar_bindings = uu___1; - fvar_bindings = (env.fvar_bindings); - depth = (env.depth + Prims.int_one); - tcenv = uu___2; - warn = (env.warn); - nolabels = (env.nolabels); - use_zfuel_name = (env.use_zfuel_name); - encode_non_total_function_typ = (env.encode_non_total_function_typ); - current_module_name = (env.current_module_name); - encoding_quantifier = (env.encoding_quantifier); - global_cache = (env.global_cache) - } in - (ysym, y, uu___) -let (new_term_constant : - env_t -> - FStar_Syntax_Syntax.bv -> - (Prims.string * FStar_SMTEncoding_Term.term * env_t)) - = - fun env -> - fun x -> - let ysym = - varops.new_var x.FStar_Syntax_Syntax.ppname - x.FStar_Syntax_Syntax.index in - let y = FStar_SMTEncoding_Util.mkApp (ysym, []) in - let uu___ = - let uu___1 = add_bvar_binding (x, y) env.bvar_bindings in - let uu___2 = FStar_TypeChecker_Env.push_bv env.tcenv x in - { - bvar_bindings = uu___1; - fvar_bindings = (env.fvar_bindings); - depth = (env.depth); - tcenv = uu___2; - warn = (env.warn); - nolabels = (env.nolabels); - use_zfuel_name = (env.use_zfuel_name); - encode_non_total_function_typ = (env.encode_non_total_function_typ); - current_module_name = (env.current_module_name); - encoding_quantifier = (env.encoding_quantifier); - global_cache = (env.global_cache) - } in - (ysym, y, uu___) -let (new_term_constant_from_string : - env_t -> - FStar_Syntax_Syntax.bv -> - Prims.string -> (Prims.string * FStar_SMTEncoding_Term.term * env_t)) - = - fun env -> - fun x -> - fun str -> - let ysym = varops.mk_unique str in - let y = FStar_SMTEncoding_Util.mkApp (ysym, []) in - let uu___ = - let uu___1 = add_bvar_binding (x, y) env.bvar_bindings in - let uu___2 = FStar_TypeChecker_Env.push_bv env.tcenv x in - { - bvar_bindings = uu___1; - fvar_bindings = (env.fvar_bindings); - depth = (env.depth); - tcenv = uu___2; - warn = (env.warn); - nolabels = (env.nolabels); - use_zfuel_name = (env.use_zfuel_name); - encode_non_total_function_typ = - (env.encode_non_total_function_typ); - current_module_name = (env.current_module_name); - encoding_quantifier = (env.encoding_quantifier); - global_cache = (env.global_cache) - } in - (ysym, y, uu___) -let (push_term_var : - env_t -> FStar_Syntax_Syntax.bv -> FStar_SMTEncoding_Term.term -> env_t) = - fun env -> - fun x -> - fun t -> - let uu___ = add_bvar_binding (x, t) env.bvar_bindings in - let uu___1 = FStar_TypeChecker_Env.push_bv env.tcenv x in - { - bvar_bindings = uu___; - fvar_bindings = (env.fvar_bindings); - depth = (env.depth); - tcenv = uu___1; - warn = (env.warn); - nolabels = (env.nolabels); - use_zfuel_name = (env.use_zfuel_name); - encode_non_total_function_typ = (env.encode_non_total_function_typ); - current_module_name = (env.current_module_name); - encoding_quantifier = (env.encoding_quantifier); - global_cache = (env.global_cache) - } -let (lookup_term_var : - env_t -> FStar_Syntax_Syntax.bv -> FStar_SMTEncoding_Term.term) = - fun env -> - fun a -> - let uu___ = lookup_bvar_binding env a in - match uu___ with - | FStar_Pervasives_Native.Some (b, t) -> t - | FStar_Pervasives_Native.None -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_bv a in - let uu___3 = print_env env in - FStar_Compiler_Util.format2 - "Bound term variable not found %s in environment: %s" uu___2 - uu___3 in - failwith uu___1 -let (mk_fvb : - FStar_Ident.lident -> - Prims.string -> - Prims.int -> - FStar_SMTEncoding_Term.term FStar_Pervasives_Native.option -> - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) - FStar_Pervasives_Native.option -> Prims.bool -> fvar_binding) - = - fun lid -> - fun fname -> - fun arity -> - fun ftok -> - fun fuel_partial_app -> - fun thunked -> - let fvb = - { - fvar_lid = lid; - smt_arity = arity; - smt_id = fname; - smt_token = ftok; - smt_fuel_partial_app = fuel_partial_app; - fvb_thunked = thunked - } in - check_valid_fvb fvb; fvb -let (new_term_constant_and_tok_from_lid_aux : - env_t -> - FStar_Ident.lident -> - Prims.int -> - Prims.bool -> - (Prims.string * Prims.string FStar_Pervasives_Native.option * - env_t)) - = - fun env -> - fun x -> - fun arity -> - fun thunked -> - let fname = varops.new_fvar x in - let uu___ = - if thunked - then (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) - else - (let ftok_name = Prims.strcat fname "@tok" in - let ftok = FStar_SMTEncoding_Util.mkApp (ftok_name, []) in - ((FStar_Pervasives_Native.Some ftok_name), - (FStar_Pervasives_Native.Some ftok))) in - match uu___ with - | (ftok_name, ftok) -> - let fvb = - mk_fvb x fname arity ftok FStar_Pervasives_Native.None - thunked in - let uu___1 = - let uu___2 = add_fvar_binding fvb env.fvar_bindings in - { - bvar_bindings = (env.bvar_bindings); - fvar_bindings = uu___2; - depth = (env.depth); - tcenv = (env.tcenv); - warn = (env.warn); - nolabels = (env.nolabels); - use_zfuel_name = (env.use_zfuel_name); - encode_non_total_function_typ = - (env.encode_non_total_function_typ); - current_module_name = (env.current_module_name); - encoding_quantifier = (env.encoding_quantifier); - global_cache = (env.global_cache) - } in - (fname, ftok_name, uu___1) -let (new_term_constant_and_tok_from_lid : - env_t -> - FStar_Ident.lident -> Prims.int -> (Prims.string * Prims.string * env_t)) - = - fun env -> - fun x -> - fun arity -> - let uu___ = new_term_constant_and_tok_from_lid_aux env x arity false in - match uu___ with - | (fname, ftok_name_opt, env1) -> - let uu___1 = FStar_Compiler_Option.get ftok_name_opt in - (fname, uu___1, env1) -let (new_term_constant_and_tok_from_lid_maybe_thunked : - env_t -> - FStar_Ident.lident -> - Prims.int -> - Prims.bool -> - (Prims.string * Prims.string FStar_Pervasives_Native.option * - env_t)) - = - fun env -> - fun x -> - fun arity -> - fun th -> new_term_constant_and_tok_from_lid_aux env x arity th -let fail_fvar_lookup : 'uuuuu . env_t -> FStar_Ident.lident -> 'uuuuu = - fun env -> - fun a -> - let q = FStar_TypeChecker_Env.lookup_qname env.tcenv a in - match q with - | FStar_Pervasives_Native.None -> - let uu___ = - let uu___1 = FStar_Class_Show.show FStar_Ident.showable_lident a in - FStar_Compiler_Util.format1 - "Name %s not found in the smtencoding and typechecker env" - uu___1 in - failwith uu___ - | uu___ -> - let quals = FStar_TypeChecker_Env.quals_of_qninfo q in - let uu___1 = - (FStar_Compiler_Util.is_some quals) && - (let uu___2 = FStar_Compiler_Util.must quals in - FStar_Compiler_List.contains - FStar_Syntax_Syntax.Unfold_for_unification_and_vcgen uu___2) in - if uu___1 - then - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Ident.showable_lident a in - FStar_Compiler_Util.format1 - "Name %s not found in the smtencoding env (the symbol is marked unfold, expected it to reduce)" - uu___3 in - FStar_Errors.raise_error FStar_Ident.hasrange_lident a - FStar_Errors_Codes.Fatal_IdentifierNotFound () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2) - else - (let uu___3 = - let uu___4 = - FStar_Class_Show.show FStar_Ident.showable_lident a in - FStar_Compiler_Util.format1 - "Name %s not found in the smtencoding env" uu___4 in - failwith uu___3) -let (lookup_lid : env_t -> FStar_Ident.lident -> fvar_binding) = - fun env -> - fun a -> - let uu___ = lookup_fvar_binding env a in - match uu___ with - | FStar_Pervasives_Native.None -> fail_fvar_lookup env a - | FStar_Pervasives_Native.Some s -> (check_valid_fvb s; s) -let (push_free_var_maybe_thunked : - env_t -> - FStar_Ident.lident -> - Prims.int -> - Prims.string -> - FStar_SMTEncoding_Term.term FStar_Pervasives_Native.option -> - Prims.bool -> env_t) - = - fun env -> - fun x -> - fun arity -> - fun fname -> - fun ftok -> - fun thunked -> - let fvb = - mk_fvb x fname arity ftok FStar_Pervasives_Native.None - thunked in - let uu___ = add_fvar_binding fvb env.fvar_bindings in - { - bvar_bindings = (env.bvar_bindings); - fvar_bindings = uu___; - depth = (env.depth); - tcenv = (env.tcenv); - warn = (env.warn); - nolabels = (env.nolabels); - use_zfuel_name = (env.use_zfuel_name); - encode_non_total_function_typ = - (env.encode_non_total_function_typ); - current_module_name = (env.current_module_name); - encoding_quantifier = (env.encoding_quantifier); - global_cache = (env.global_cache) - } -let (push_free_var : - env_t -> - FStar_Ident.lident -> - Prims.int -> - Prims.string -> - FStar_SMTEncoding_Term.term FStar_Pervasives_Native.option -> env_t) - = - fun env -> - fun x -> - fun arity -> - fun fname -> - fun ftok -> - push_free_var_maybe_thunked env x arity fname ftok false -let (push_free_var_thunk : - env_t -> - FStar_Ident.lident -> - Prims.int -> - Prims.string -> - FStar_SMTEncoding_Term.term FStar_Pervasives_Native.option -> env_t) - = - fun env -> - fun x -> - fun arity -> - fun fname -> - fun ftok -> - push_free_var_maybe_thunked env x arity fname ftok - (arity = Prims.int_zero) -let (push_zfuel_name : - env_t -> FStar_Ident.lident -> Prims.string -> Prims.string -> env_t) = - fun env -> - fun x -> - fun f -> - fun ftok -> - let fvb = lookup_lid env x in - let t3 = - let uu___ = - let uu___1 = - let uu___2 = FStar_SMTEncoding_Util.mkApp ("ZFuel", []) in - [uu___2] in - (f, uu___1) in - FStar_SMTEncoding_Util.mkApp uu___ in - let t3' = - let uu___ = FStar_SMTEncoding_Util.mkApp (ftok, []) in - let uu___1 = FStar_SMTEncoding_Util.mkApp ("ZFuel", []) in - FStar_SMTEncoding_Term.mk_ApplyTF uu___ uu___1 in - let fvb1 = - mk_fvb x fvb.smt_id fvb.smt_arity fvb.smt_token - (FStar_Pervasives_Native.Some (t3, t3')) false in - let uu___ = add_fvar_binding fvb1 env.fvar_bindings in - { - bvar_bindings = (env.bvar_bindings); - fvar_bindings = uu___; - depth = (env.depth); - tcenv = (env.tcenv); - warn = (env.warn); - nolabels = (env.nolabels); - use_zfuel_name = (env.use_zfuel_name); - encode_non_total_function_typ = - (env.encode_non_total_function_typ); - current_module_name = (env.current_module_name); - encoding_quantifier = (env.encoding_quantifier); - global_cache = (env.global_cache) - } -let (force_thunk : fvar_binding -> FStar_SMTEncoding_Term.term) = - fun fvb -> - if - (Prims.op_Negation fvb.fvb_thunked) || - (fvb.smt_arity <> Prims.int_zero) - then failwith "Forcing a non-thunk in the SMT encoding" - else (); - FStar_SMTEncoding_Util.mkFreeV - (FStar_SMTEncoding_Term.FV - ((fvb.smt_id), FStar_SMTEncoding_Term.Term_sort, true)) -let (try_lookup_free_var : - env_t -> - FStar_Ident.lident -> - FStar_SMTEncoding_Term.term FStar_Pervasives_Native.option) - = - fun env -> - fun l -> - let uu___ = lookup_fvar_binding env l in - match uu___ with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some fvb -> - ((let uu___2 = FStar_Compiler_Effect.op_Bang dbg_PartialApp in - if uu___2 - then - let uu___3 = FStar_Ident.string_of_lid l in - let uu___4 = fvb_to_string fvb in - FStar_Compiler_Util.print2 "Looked up %s found\n%s\n" uu___3 - uu___4 - else ()); - if fvb.fvb_thunked - then - (let uu___2 = force_thunk fvb in - FStar_Pervasives_Native.Some uu___2) - else - (match fvb.smt_fuel_partial_app with - | FStar_Pervasives_Native.Some (uu___3, f) when - env.use_zfuel_name -> FStar_Pervasives_Native.Some f - | uu___3 -> - (match fvb.smt_token with - | FStar_Pervasives_Native.Some t -> - (match t.FStar_SMTEncoding_Term.tm with - | FStar_SMTEncoding_Term.App (uu___4, fuel::[]) -> - let uu___5 = - let uu___6 = - let uu___7 = - FStar_SMTEncoding_Term.fv_of_term fuel in - FStar_SMTEncoding_Term.fv_name uu___7 in - FStar_Compiler_Util.starts_with uu___6 "fuel" in - if uu___5 - then - let uu___6 = - let uu___7 = - let uu___8 = - FStar_SMTEncoding_Term.mk_fv - ((fvb.smt_id), - FStar_SMTEncoding_Term.Term_sort) in - FStar_SMTEncoding_Util.mkFreeV uu___8 in - FStar_SMTEncoding_Term.mk_ApplyTF uu___7 fuel in - FStar_Pervasives_Native.Some uu___6 - else FStar_Pervasives_Native.Some t - | uu___4 -> FStar_Pervasives_Native.Some t) - | uu___4 -> FStar_Pervasives_Native.None))) -let (lookup_free_var : - env_t -> - FStar_Ident.lident FStar_Syntax_Syntax.withinfo_t -> - FStar_SMTEncoding_Term.term) - = - fun env -> - fun a -> - let uu___ = try_lookup_free_var env a.FStar_Syntax_Syntax.v in - match uu___ with - | FStar_Pervasives_Native.Some t -> t - | FStar_Pervasives_Native.None -> - fail_fvar_lookup env a.FStar_Syntax_Syntax.v -let (lookup_free_var_name : - env_t -> FStar_Ident.lident FStar_Syntax_Syntax.withinfo_t -> fvar_binding) - = fun env -> fun a -> lookup_lid env a.FStar_Syntax_Syntax.v -let (lookup_free_var_sym : - env_t -> - FStar_Ident.lident FStar_Syntax_Syntax.withinfo_t -> - ((FStar_SMTEncoding_Term.op, FStar_SMTEncoding_Term.term) - FStar_Pervasives.either * FStar_SMTEncoding_Term.term Prims.list * - Prims.int)) - = - fun env -> - fun a -> - let fvb = lookup_lid env a.FStar_Syntax_Syntax.v in - match fvb.smt_fuel_partial_app with - | FStar_Pervasives_Native.Some - ({ FStar_SMTEncoding_Term.tm = FStar_SMTEncoding_Term.App (g, zf); - FStar_SMTEncoding_Term.freevars = uu___; - FStar_SMTEncoding_Term.rng = uu___1;_}, - uu___2) - when env.use_zfuel_name -> - ((FStar_Pervasives.Inl g), zf, (fvb.smt_arity + Prims.int_one)) - | uu___ -> - (match fvb.smt_token with - | FStar_Pervasives_Native.None when fvb.fvb_thunked -> - let uu___1 = - let uu___2 = force_thunk fvb in FStar_Pervasives.Inr uu___2 in - (uu___1, [], (fvb.smt_arity)) - | FStar_Pervasives_Native.None -> - ((FStar_Pervasives.Inl - (FStar_SMTEncoding_Term.Var (fvb.smt_id))), [], - (fvb.smt_arity)) - | FStar_Pervasives_Native.Some sym -> - (match sym.FStar_SMTEncoding_Term.tm with - | FStar_SMTEncoding_Term.App (g, fuel::[]) -> - ((FStar_Pervasives.Inl g), [fuel], - (fvb.smt_arity + Prims.int_one)) - | uu___1 -> - ((FStar_Pervasives.Inl - (FStar_SMTEncoding_Term.Var (fvb.smt_id))), [], - (fvb.smt_arity)))) -let (tok_of_name : - env_t -> - Prims.string -> - FStar_SMTEncoding_Term.term FStar_Pervasives_Native.option) - = - fun env -> - fun nm -> - let uu___ = - FStar_Compiler_Util.psmap_find_map - (FStar_Pervasives_Native.fst env.fvar_bindings) - (fun uu___1 -> - fun fvb -> - check_valid_fvb fvb; - if fvb.smt_id = nm - then fvb.smt_token - else FStar_Pervasives_Native.None) in - match uu___ with - | FStar_Pervasives_Native.Some b -> FStar_Pervasives_Native.Some b - | FStar_Pervasives_Native.None -> - FStar_Compiler_Util.psmap_find_map env.bvar_bindings - (fun uu___1 -> - fun pi -> - FStar_Compiler_Util.pimap_fold pi - (fun uu___2 -> - fun y -> - fun res -> - match (res, y) with - | (FStar_Pervasives_Native.Some uu___3, uu___4) -> - res - | (FStar_Pervasives_Native.None, - (uu___3, - { - FStar_SMTEncoding_Term.tm = - FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Var sym, []); - FStar_SMTEncoding_Term.freevars = uu___4; - FStar_SMTEncoding_Term.rng = uu___5;_})) - when sym = nm -> - FStar_Pervasives_Native.Some - (FStar_Pervasives_Native.snd y) - | uu___3 -> FStar_Pervasives_Native.None) - FStar_Pervasives_Native.None) -let (reset_current_module_fvbs : env_t -> env_t) = - fun env -> - { - bvar_bindings = (env.bvar_bindings); - fvar_bindings = ((FStar_Pervasives_Native.fst env.fvar_bindings), []); - depth = (env.depth); - tcenv = (env.tcenv); - warn = (env.warn); - nolabels = (env.nolabels); - use_zfuel_name = (env.use_zfuel_name); - encode_non_total_function_typ = (env.encode_non_total_function_typ); - current_module_name = (env.current_module_name); - encoding_quantifier = (env.encoding_quantifier); - global_cache = (env.global_cache) - } -let (get_current_module_fvbs : env_t -> fvar_binding Prims.list) = - fun env -> FStar_Pervasives_Native.snd env.fvar_bindings -let (add_fvar_binding_to_env : fvar_binding -> env_t -> env_t) = - fun fvb -> - fun env -> - let uu___ = add_fvar_binding fvb env.fvar_bindings in - { - bvar_bindings = (env.bvar_bindings); - fvar_bindings = uu___; - depth = (env.depth); - tcenv = (env.tcenv); - warn = (env.warn); - nolabels = (env.nolabels); - use_zfuel_name = (env.use_zfuel_name); - encode_non_total_function_typ = (env.encode_non_total_function_typ); - current_module_name = (env.current_module_name); - encoding_quantifier = (env.encoding_quantifier); - global_cache = (env.global_cache) - } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_ErrorReporting.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_ErrorReporting.ml deleted file mode 100644 index 19fe7ee2cd0..00000000000 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_ErrorReporting.ml +++ /dev/null @@ -1,875 +0,0 @@ -open Prims -type label = FStar_SMTEncoding_Term.error_label -type labels = label Prims.list -exception Not_a_wp_implication of Prims.string -let (uu___is_Not_a_wp_implication : Prims.exn -> Prims.bool) = - fun projectee -> - match projectee with - | Not_a_wp_implication uu___ -> true - | uu___ -> false -let (__proj__Not_a_wp_implication__item__uu___ : Prims.exn -> Prims.string) = - fun projectee -> match projectee with | Not_a_wp_implication uu___ -> uu___ -let (sort_labels : - (FStar_SMTEncoding_Term.error_label * Prims.bool) Prims.list -> - ((FStar_SMTEncoding_Term.fv * FStar_Errors_Msg.error_message * - FStar_Compiler_Range_Type.range) * Prims.bool) Prims.list) - = - fun l -> - FStar_Compiler_List.sortWith - (fun uu___ -> - fun uu___1 -> - match (uu___, uu___1) with - | (((uu___2, uu___3, r1), uu___4), ((uu___5, uu___6, r2), uu___7)) - -> FStar_Compiler_Range_Ops.compare r1 r2) l -let (remove_dups : - labels -> - (FStar_SMTEncoding_Term.fv * FStar_Errors_Msg.error_message * - FStar_Compiler_Range_Type.range) Prims.list) - = - fun l -> - FStar_Compiler_Util.remove_dups - (fun uu___ -> - fun uu___1 -> - match (uu___, uu___1) with - | ((uu___2, m1, r1), (uu___3, m2, r2)) -> (r1 = r2) && (m1 = m2)) - l -type msg = (Prims.string * FStar_Compiler_Range_Type.range) -type ranges = - (Prims.string FStar_Pervasives_Native.option * - FStar_Compiler_Range_Type.range) Prims.list -let (__ctr : Prims.int FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref Prims.int_zero -let (fresh_label : - FStar_Errors_Msg.error_message -> - FStar_Compiler_Range_Type.range -> - FStar_SMTEncoding_Term.term -> (label * FStar_SMTEncoding_Term.term)) - = - fun message -> - fun range -> - fun t -> - let l = - FStar_Compiler_Util.incr __ctr; - (let uu___1 = - let uu___2 = FStar_Compiler_Effect.op_Bang __ctr in - FStar_Compiler_Util.string_of_int uu___2 in - FStar_Compiler_Util.format1 "label_%s" uu___1) in - let lvar = - FStar_SMTEncoding_Term.mk_fv (l, FStar_SMTEncoding_Term.Bool_sort) in - let label1 = (lvar, message, range) in - let lterm = FStar_SMTEncoding_Util.mkFreeV lvar in - let lt = FStar_SMTEncoding_Term.mkOr (lterm, t) range in (label1, lt) -let (label_goals : - (unit -> Prims.string) FStar_Pervasives_Native.option -> - FStar_Compiler_Range_Type.range -> - FStar_SMTEncoding_Term.term -> (labels * FStar_SMTEncoding_Term.term)) - = - fun use_env_msg -> - fun r -> - fun q -> - let rec is_a_post_condition post_name_opt tm = - match (post_name_opt, (tm.FStar_SMTEncoding_Term.tm)) with - | (FStar_Pervasives_Native.None, uu___) -> false - | (FStar_Pervasives_Native.Some nm, FStar_SMTEncoding_Term.FreeV - fv) -> - let uu___ = FStar_SMTEncoding_Term.fv_name fv in nm = uu___ - | (uu___, FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Var "Valid", tm1::[])) -> - is_a_post_condition post_name_opt tm1 - | (uu___, FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Var "ApplyTT", tm1::uu___1)) -> - is_a_post_condition post_name_opt tm1 - | uu___ -> false in - let conjuncts t = - match t.FStar_SMTEncoding_Term.tm with - | FStar_SMTEncoding_Term.App (FStar_SMTEncoding_Term.And, cs) -> cs - | uu___ -> [t] in - let is_guard_free tm = - match tm.FStar_SMTEncoding_Term.tm with - | FStar_SMTEncoding_Term.Quant - (FStar_SMTEncoding_Term.Forall, - ({ - FStar_SMTEncoding_Term.tm = FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Var "Prims.guard_free", p::[]); - FStar_SMTEncoding_Term.freevars = uu___; - FStar_SMTEncoding_Term.rng = uu___1;_}::[])::[], - iopt, uu___2, - { - FStar_SMTEncoding_Term.tm = FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Imp, l::r1::[]); - FStar_SMTEncoding_Term.freevars = uu___3; - FStar_SMTEncoding_Term.rng = uu___4;_}) - -> true - | uu___ -> false in - let is_a_named_continuation lhs = - FStar_Compiler_Util.for_some is_guard_free (conjuncts lhs) in - let uu___ = - match use_env_msg with - | FStar_Pervasives_Native.None -> (false, FStar_Pprint.empty) - | FStar_Pervasives_Native.Some f -> - let uu___1 = - let uu___2 = f () in FStar_Pprint.doc_of_string uu___2 in - (true, uu___1) in - match uu___ with - | (flag, msg_prefix) -> - let fresh_label1 msg1 ropt rng t = - let msg2 = - if flag - then - let uu___1 = - let uu___2 = - FStar_Errors_Msg.text - "Failed to verify implicit argument: " in - FStar_Pprint.op_Hat_Hat uu___2 msg_prefix in - uu___1 :: msg1 - else msg1 in - let rng1 = - match ropt with - | FStar_Pervasives_Native.None -> rng - | FStar_Pervasives_Native.Some r1 -> - let uu___1 = - let uu___2 = FStar_Compiler_Range_Type.use_range rng in - let uu___3 = FStar_Compiler_Range_Type.use_range r1 in - FStar_Compiler_Range_Ops.rng_included uu___2 uu___3 in - if uu___1 - then rng - else - (let uu___3 = FStar_Compiler_Range_Type.def_range rng in - FStar_Compiler_Range_Type.set_def_range r1 uu___3) in - fresh_label msg2 rng1 t in - let rec aux default_msg ropt post_name_opt labels1 q1 = - match q1.FStar_SMTEncoding_Term.tm with - | FStar_SMTEncoding_Term.BoundV uu___1 -> (labels1, q1) - | FStar_SMTEncoding_Term.Integer uu___1 -> (labels1, q1) - | FStar_SMTEncoding_Term.String uu___1 -> (labels1, q1) - | FStar_SMTEncoding_Term.Real uu___1 -> (labels1, q1) - | FStar_SMTEncoding_Term.LblPos uu___1 -> failwith "Impossible" - | FStar_SMTEncoding_Term.Labeled (arg, d::[], label_range) when - let uu___1 = FStar_Errors_Msg.renderdoc d in - uu___1 = "Could not prove post-condition" -> - let fallback debug_msg = - aux default_msg - (FStar_Pervasives_Native.Some label_range) - post_name_opt labels1 arg in - (try - (fun uu___1 -> - match () with - | () -> - (match arg.FStar_SMTEncoding_Term.tm with - | FStar_SMTEncoding_Term.Quant - (FStar_SMTEncoding_Term.Forall, pats, iopt, - post::sorts, - { - FStar_SMTEncoding_Term.tm = - FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Imp, - lhs::rhs::[]); - FStar_SMTEncoding_Term.freevars = uu___2; - FStar_SMTEncoding_Term.rng = rng;_}) - -> - let post_name = - let uu___3 = - let uu___4 = FStar_GenSym.next_id () in - FStar_Compiler_Util.string_of_int uu___4 in - Prims.strcat "^^post_condition_" uu___3 in - let names = - let uu___3 = - FStar_SMTEncoding_Term.mk_fv - (post_name, post) in - let uu___4 = - FStar_Compiler_List.map - (fun s -> - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_GenSym.next_id () in - FStar_Compiler_Util.string_of_int - uu___8 in - Prims.strcat "^^" uu___7 in - (uu___6, s) in - FStar_SMTEncoding_Term.mk_fv uu___5) - sorts in - uu___3 :: uu___4 in - let instantiation = - FStar_Compiler_List.map - FStar_SMTEncoding_Util.mkFreeV names in - let uu___3 = - let uu___4 = - FStar_SMTEncoding_Term.inst - instantiation lhs in - let uu___5 = - FStar_SMTEncoding_Term.inst - instantiation rhs in - (uu___4, uu___5) in - (match uu___3 with - | (lhs1, rhs1) -> - let uu___4 = - match lhs1.FStar_SMTEncoding_Term.tm - with - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.And, - clauses_lhs) - -> - let uu___5 = - FStar_Compiler_Util.prefix - clauses_lhs in - (match uu___5 with - | (req, ens) -> - (match ens.FStar_SMTEncoding_Term.tm - with - | FStar_SMTEncoding_Term.Quant - (FStar_SMTEncoding_Term.Forall, - pats_ens, iopt_ens, - sorts_ens, - { - FStar_SMTEncoding_Term.tm - = - FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Imp, - ensures_conjuncts::post1::[]); - FStar_SMTEncoding_Term.freevars - = uu___6; - FStar_SMTEncoding_Term.rng - = rng_ens;_}) - -> - let uu___7 = - is_a_post_condition - (FStar_Pervasives_Native.Some - post_name) post1 in - if uu___7 - then - let uu___8 = - let uu___9 = - FStar_Errors_Msg.mkmsg - "Could not prove post-condition" in - aux uu___9 - FStar_Pervasives_Native.None - (FStar_Pervasives_Native.Some - post_name) - labels1 - ensures_conjuncts in - (match uu___8 with - | (labels2, - ensures_conjuncts1) - -> - let pats_ens1 = - match pats_ens - with - | [] -> - [[post1]] - | []::[] -> - [[post1]] - | uu___9 -> - pats_ens in - let ens1 = - let uu___9 = - let uu___10 - = - let uu___11 - = - FStar_SMTEncoding_Term.mk - (FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Imp, - [ensures_conjuncts1; - post1])) - rng_ens in - (FStar_SMTEncoding_Term.Forall, - pats_ens1, - iopt_ens, - sorts_ens, - uu___11) in - FStar_SMTEncoding_Term.Quant - uu___10 in - FStar_SMTEncoding_Term.mk - uu___9 - ens.FStar_SMTEncoding_Term.rng in - let lhs2 = - FStar_SMTEncoding_Term.mk - (FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.And, - (FStar_Compiler_List.op_At - req - [ens1]))) - lhs1.FStar_SMTEncoding_Term.rng in - let uu___9 = - FStar_SMTEncoding_Term.abstr - names lhs2 in - (labels2, - uu___9)) - else - (let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 - = - FStar_SMTEncoding_Term.print_smt_term - post1 in - Prims.strcat - " ... " - uu___13 in - Prims.strcat - post_name - uu___12 in - Prims.strcat - "Ensures clause doesn't match post name: " - uu___11 in - Not_a_wp_implication - uu___10 in - FStar_Compiler_Effect.raise - uu___9) - | uu___6 -> - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_SMTEncoding_Term.print_smt_term - ens in - Prims.strcat - " ... " - uu___11 in - Prims.strcat - post_name - uu___10 in - Prims.strcat - "Ensures clause doesn't have the expected shape for post-condition " - uu___9 in - Not_a_wp_implication - uu___8 in - FStar_Compiler_Effect.raise - uu___7)) - | uu___5 -> - let uu___6 = - let uu___7 = - let uu___8 = - FStar_SMTEncoding_Term.print_smt_term - lhs1 in - Prims.strcat - "LHS not a conjunct: " - uu___8 in - Not_a_wp_implication uu___7 in - FStar_Compiler_Effect.raise - uu___6 in - (match uu___4 with - | (labels2, lhs2) -> - let uu___5 = - let uu___6 = - aux default_msg - FStar_Pervasives_Native.None - (FStar_Pervasives_Native.Some - post_name) labels2 rhs1 in - match uu___6 with - | (labels3, rhs2) -> - let uu___7 = - FStar_SMTEncoding_Term.abstr - names rhs2 in - (labels3, uu___7) in - (match uu___5 with - | (labels3, rhs2) -> - let body = - FStar_SMTEncoding_Term.mkImp - (lhs2, rhs2) rng in - let uu___6 = - FStar_SMTEncoding_Term.mk - (FStar_SMTEncoding_Term.Quant - (FStar_SMTEncoding_Term.Forall, - pats, iopt, (post :: - sorts), body)) - q1.FStar_SMTEncoding_Term.rng in - (labels3, uu___6)))) - | uu___2 -> fallback "arg not a quant: ")) () - with | Not_a_wp_implication msg1 -> fallback msg1) - | FStar_SMTEncoding_Term.Labeled (arg, reason, r1) -> - aux reason (FStar_Pervasives_Native.Some r1) post_name_opt - labels1 arg - | FStar_SMTEncoding_Term.Quant - (FStar_SMTEncoding_Term.Forall, [], - FStar_Pervasives_Native.None, sorts, - { - FStar_SMTEncoding_Term.tm = FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Imp, lhs::rhs::[]); - FStar_SMTEncoding_Term.freevars = uu___1; - FStar_SMTEncoding_Term.rng = rng;_}) - when is_a_named_continuation lhs -> - let uu___2 = FStar_Compiler_Util.prefix sorts in - (match uu___2 with - | (sorts', post) -> - let new_post_name = - let uu___3 = - let uu___4 = FStar_GenSym.next_id () in - FStar_Compiler_Util.string_of_int uu___4 in - Prims.strcat "^^post_condition_" uu___3 in - let names = - let uu___3 = - FStar_Compiler_List.map - (fun s -> - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = FStar_GenSym.next_id () in - FStar_Compiler_Util.string_of_int - uu___7 in - Prims.strcat "^^" uu___6 in - (uu___5, s) in - FStar_SMTEncoding_Term.mk_fv uu___4) sorts' in - let uu___4 = - let uu___5 = - FStar_SMTEncoding_Term.mk_fv - (new_post_name, post) in - [uu___5] in - FStar_Compiler_List.op_At uu___3 uu___4 in - let instantiation = - FStar_Compiler_List.map - FStar_SMTEncoding_Util.mkFreeV names in - let uu___3 = - let uu___4 = - FStar_SMTEncoding_Term.inst instantiation lhs in - let uu___5 = - FStar_SMTEncoding_Term.inst instantiation rhs in - (uu___4, uu___5) in - (match uu___3 with - | (lhs1, rhs1) -> - let uu___4 = - FStar_Compiler_Util.fold_map - (fun labels2 -> - fun tm -> - match tm.FStar_SMTEncoding_Term.tm with - | FStar_SMTEncoding_Term.Quant - (FStar_SMTEncoding_Term.Forall, - ({ - FStar_SMTEncoding_Term.tm = - FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Var - "Prims.guard_free", p::[]); - FStar_SMTEncoding_Term.freevars - = uu___5; - FStar_SMTEncoding_Term.rng = - uu___6;_}::[])::[], - iopt, sorts1, - { - FStar_SMTEncoding_Term.tm = - FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Imp, - l0::r1::[]); - FStar_SMTEncoding_Term.freevars = - uu___7; - FStar_SMTEncoding_Term.rng = - uu___8;_}) - -> - let uu___9 = - is_a_post_condition - (FStar_Pervasives_Native.Some - new_post_name) r1 in - if uu___9 - then - let uu___10 = - aux default_msg - FStar_Pervasives_Native.None - post_name_opt labels2 l0 in - (match uu___10 with - | (labels3, l) -> - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - FStar_SMTEncoding_Util.norng - FStar_SMTEncoding_Term.mk - (FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Imp, - [l; r1])) in - (FStar_SMTEncoding_Term.Forall, - [[p]], - (FStar_Pervasives_Native.Some - Prims.int_zero), - sorts1, uu___14) in - FStar_SMTEncoding_Term.Quant - uu___13 in - FStar_SMTEncoding_Term.mk - uu___12 - q1.FStar_SMTEncoding_Term.rng in - (labels3, uu___11)) - else (labels2, tm) - | uu___5 -> (labels2, tm)) labels1 - (conjuncts lhs1) in - (match uu___4 with - | (labels2, lhs_conjs) -> - let uu___5 = - aux default_msg - FStar_Pervasives_Native.None - (FStar_Pervasives_Native.Some - new_post_name) labels2 rhs1 in - (match uu___5 with - | (labels3, rhs2) -> - let body = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_SMTEncoding_Term.mk_and_l - lhs_conjs - lhs1.FStar_SMTEncoding_Term.rng in - (uu___8, rhs2) in - FStar_SMTEncoding_Term.mkImp uu___7 - rng in - FStar_SMTEncoding_Term.abstr names - uu___6 in - let q2 = - FStar_SMTEncoding_Term.mk - (FStar_SMTEncoding_Term.Quant - (FStar_SMTEncoding_Term.Forall, - [], - FStar_Pervasives_Native.None, - sorts, body)) - q1.FStar_SMTEncoding_Term.rng in - (labels3, q2))))) - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Imp, lhs::rhs::[]) -> - let uu___1 = aux default_msg ropt post_name_opt labels1 rhs in - (match uu___1 with - | (labels2, rhs1) -> - let uu___2 = FStar_SMTEncoding_Util.mkImp (lhs, rhs1) in - (labels2, uu___2)) - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.And, conjuncts1) -> - let uu___1 = - FStar_Compiler_Util.fold_map - (aux default_msg ropt post_name_opt) labels1 conjuncts1 in - (match uu___1 with - | (labels2, conjuncts2) -> - let uu___2 = - FStar_SMTEncoding_Term.mk_and_l conjuncts2 - q1.FStar_SMTEncoding_Term.rng in - (labels2, uu___2)) - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.ITE, hd::q11::q2::[]) -> - let uu___1 = aux default_msg ropt post_name_opt labels1 q11 in - (match uu___1 with - | (labels2, q12) -> - let uu___2 = - aux default_msg ropt post_name_opt labels2 q2 in - (match uu___2 with - | (labels3, q21) -> - let uu___3 = - FStar_SMTEncoding_Term.mkITE (hd, q12, q21) - q1.FStar_SMTEncoding_Term.rng in - (labels3, uu___3))) - | FStar_SMTEncoding_Term.Quant - (FStar_SMTEncoding_Term.Exists, uu___1, uu___2, uu___3, - uu___4) - -> - let uu___5 = - fresh_label1 default_msg ropt - q1.FStar_SMTEncoding_Term.rng q1 in - (match uu___5 with | (lab, q2) -> ((lab :: labels1), q2)) - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Iff, uu___1) -> - let uu___2 = - fresh_label1 default_msg ropt - q1.FStar_SMTEncoding_Term.rng q1 in - (match uu___2 with | (lab, q2) -> ((lab :: labels1), q2)) - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Or, uu___1) -> - let uu___2 = - fresh_label1 default_msg ropt - q1.FStar_SMTEncoding_Term.rng q1 in - (match uu___2 with | (lab, q2) -> ((lab :: labels1), q2)) - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Var "Unreachable", uu___1) -> - (labels1, q1) - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Var uu___1, uu___2) when - is_a_post_condition post_name_opt q1 -> (labels1, q1) - | FStar_SMTEncoding_Term.FreeV uu___1 -> - let uu___2 = - fresh_label1 default_msg ropt - q1.FStar_SMTEncoding_Term.rng q1 in - (match uu___2 with | (lab, q2) -> ((lab :: labels1), q2)) - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.TrueOp, uu___1) -> - let uu___2 = - fresh_label1 default_msg ropt - q1.FStar_SMTEncoding_Term.rng q1 in - (match uu___2 with | (lab, q2) -> ((lab :: labels1), q2)) - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.FalseOp, uu___1) -> - let uu___2 = - fresh_label1 default_msg ropt - q1.FStar_SMTEncoding_Term.rng q1 in - (match uu___2 with | (lab, q2) -> ((lab :: labels1), q2)) - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Not, uu___1) -> - let uu___2 = - fresh_label1 default_msg ropt - q1.FStar_SMTEncoding_Term.rng q1 in - (match uu___2 with | (lab, q2) -> ((lab :: labels1), q2)) - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Eq, uu___1) -> - let uu___2 = - fresh_label1 default_msg ropt - q1.FStar_SMTEncoding_Term.rng q1 in - (match uu___2 with | (lab, q2) -> ((lab :: labels1), q2)) - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.LT, uu___1) -> - let uu___2 = - fresh_label1 default_msg ropt - q1.FStar_SMTEncoding_Term.rng q1 in - (match uu___2 with | (lab, q2) -> ((lab :: labels1), q2)) - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.LTE, uu___1) -> - let uu___2 = - fresh_label1 default_msg ropt - q1.FStar_SMTEncoding_Term.rng q1 in - (match uu___2 with | (lab, q2) -> ((lab :: labels1), q2)) - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.GT, uu___1) -> - let uu___2 = - fresh_label1 default_msg ropt - q1.FStar_SMTEncoding_Term.rng q1 in - (match uu___2 with | (lab, q2) -> ((lab :: labels1), q2)) - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.GTE, uu___1) -> - let uu___2 = - fresh_label1 default_msg ropt - q1.FStar_SMTEncoding_Term.rng q1 in - (match uu___2 with | (lab, q2) -> ((lab :: labels1), q2)) - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.BvUlt, uu___1) -> - let uu___2 = - fresh_label1 default_msg ropt - q1.FStar_SMTEncoding_Term.rng q1 in - (match uu___2 with | (lab, q2) -> ((lab :: labels1), q2)) - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Var uu___1, uu___2) -> - let uu___3 = - fresh_label1 default_msg ropt - q1.FStar_SMTEncoding_Term.rng q1 in - (match uu___3 with | (lab, q2) -> ((lab :: labels1), q2)) - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.RealDiv, uu___1) -> - failwith "Impossible: non-propositional term" - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Add, uu___1) -> - failwith "Impossible: non-propositional term" - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Sub, uu___1) -> - failwith "Impossible: non-propositional term" - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Div, uu___1) -> - failwith "Impossible: non-propositional term" - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Mul, uu___1) -> - failwith "Impossible: non-propositional term" - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Minus, uu___1) -> - failwith "Impossible: non-propositional term" - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Mod, uu___1) -> - failwith "Impossible: non-propositional term" - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.BvAnd, uu___1) -> - failwith "Impossible: non-propositional term" - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.BvXor, uu___1) -> - failwith "Impossible: non-propositional term" - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.BvOr, uu___1) -> - failwith "Impossible: non-propositional term" - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.BvAdd, uu___1) -> - failwith "Impossible: non-propositional term" - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.BvSub, uu___1) -> - failwith "Impossible: non-propositional term" - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.BvShl, uu___1) -> - failwith "Impossible: non-propositional term" - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.BvShr, uu___1) -> - failwith "Impossible: non-propositional term" - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.BvUdiv, uu___1) -> - failwith "Impossible: non-propositional term" - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.BvMod, uu___1) -> - failwith "Impossible: non-propositional term" - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.BvMul, uu___1) -> - failwith "Impossible: non-propositional term" - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.BvUext uu___1, uu___2) -> - failwith "Impossible: non-propositional term" - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.BvToNat, uu___1) -> - failwith "Impossible: non-propositional term" - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.NatToBv uu___1, uu___2) -> - failwith "Impossible: non-propositional term" - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.ITE, uu___1) -> - failwith "Impossible: arity mismatch" - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Imp, uu___1) -> - failwith "Impossible: arity mismatch" - | FStar_SMTEncoding_Term.Quant - (FStar_SMTEncoding_Term.Forall, pats, iopt, sorts, body) -> - let uu___1 = - aux default_msg ropt post_name_opt labels1 body in - (match uu___1 with - | (labels2, body1) -> - let uu___2 = - FStar_SMTEncoding_Term.mk - (FStar_SMTEncoding_Term.Quant - (FStar_SMTEncoding_Term.Forall, pats, iopt, - sorts, body1)) q1.FStar_SMTEncoding_Term.rng in - (labels2, uu___2)) - | FStar_SMTEncoding_Term.Let (es, body) -> - let uu___1 = - aux default_msg ropt post_name_opt labels1 body in - (match uu___1 with - | (labels2, body1) -> - let uu___2 = - FStar_SMTEncoding_Term.mkLet (es, body1) - q1.FStar_SMTEncoding_Term.rng in - (labels2, uu___2)) in - (FStar_Compiler_Effect.op_Colon_Equals __ctr Prims.int_zero; - (let uu___2 = FStar_Errors_Msg.mkmsg "Assertion failed" in - aux uu___2 FStar_Pervasives_Native.None - FStar_Pervasives_Native.None [] q)) -let (detail_errors : - Prims.bool -> - FStar_TypeChecker_Env.env -> - labels -> - (FStar_SMTEncoding_Term.decl Prims.list -> - FStar_SMTEncoding_Z3.z3result) - -> unit) - = - fun hint_replay -> - fun env -> - fun all_labels -> - fun askZ3 -> - let print_banner uu___ = - let msg1 = - let uu___1 = - let uu___2 = FStar_TypeChecker_Env.get_range env in - FStar_Compiler_Range_Ops.string_of_range uu___2 in - let uu___2 = - FStar_Compiler_Util.string_of_int (Prims.of_int (5)) in - let uu___3 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length all_labels) in - FStar_Compiler_Util.format4 - "Detailed %s report follows for %s\nTaking %s seconds per proof obligation (%s proofs in total)\n" - (if hint_replay then "hint replay" else "error") uu___1 - uu___2 uu___3 in - FStar_Compiler_Util.print_error msg1 in - let print_result uu___ = - match uu___ with - | ((uu___1, msg1, r), success) -> - if success - then - let uu___2 = FStar_Compiler_Range_Ops.string_of_range r in - FStar_Compiler_Util.print1 - "OK: proof obligation at %s was proven in isolation\n" - uu___2 - else - if hint_replay - then - (let uu___3 = - let uu___4 = - FStar_Errors_Msg.text - "Hint failed to replay this sub-proof" in - uu___4 :: msg1 in - FStar_Errors.log_issue - FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Warning_HintFailedToReplayProof () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___3)) - else - (let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Class_Show.show - FStar_Compiler_Range_Ops.showable_range r in - FStar_Compiler_Util.format1 - "XX: proof obligation at %s failed." uu___8 in - FStar_Errors_Msg.text uu___7 in - [uu___6] in - FStar_Compiler_List.op_At uu___5 msg1 in - FStar_Errors.log_issue - FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Error_ProofObligationFailed () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___4)) in - let elim labs = - FStar_Compiler_List.map - (fun uu___ -> - match uu___ with - | (l, uu___1, uu___2) -> - let tm = - let uu___3 = - let uu___4 = FStar_SMTEncoding_Util.mkFreeV l in - (uu___4, FStar_SMTEncoding_Util.mkTrue) in - FStar_SMTEncoding_Util.mkEq uu___3 in - let a = - let uu___3 = - let uu___4 = - let uu___5 = FStar_SMTEncoding_Util.mkFreeV l in - (uu___5, FStar_SMTEncoding_Util.mkTrue) in - FStar_SMTEncoding_Util.mkEq uu___4 in - let uu___4 = - let uu___5 = FStar_SMTEncoding_Term.fv_name l in - Prims.strcat "@disable_label_" uu___5 in - let uu___5 = - FStar_SMTEncoding_Term.free_top_level_names tm in - { - FStar_SMTEncoding_Term.assumption_term = uu___3; - FStar_SMTEncoding_Term.assumption_caption = - (FStar_Pervasives_Native.Some "Disabling label"); - FStar_SMTEncoding_Term.assumption_name = uu___4; - FStar_SMTEncoding_Term.assumption_fact_ids = []; - FStar_SMTEncoding_Term.assumption_free_names = - uu___5 - } in - FStar_SMTEncoding_Term.Assume a) labs in - let rec linear_check eliminated errors active = - FStar_SMTEncoding_Z3.refresh - (FStar_Pervasives_Native.Some - (env.FStar_TypeChecker_Env.proof_ns)); - (match active with - | [] -> - let results = - let uu___1 = - FStar_Compiler_List.map (fun x -> (x, true)) eliminated in - let uu___2 = - FStar_Compiler_List.map (fun x -> (x, false)) errors in - FStar_Compiler_List.op_At uu___1 uu___2 in - sort_labels results - | hd::tl -> - ((let uu___2 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length active) in - FStar_Compiler_Util.print1 "%s, " uu___2); - (let decls = - elim - (FStar_Compiler_List.op_At eliminated - (FStar_Compiler_List.op_At errors tl)) in - let result = askZ3 decls in - match result.FStar_SMTEncoding_Z3.z3result_status with - | FStar_SMTEncoding_Z3.UNSAT uu___2 -> - linear_check (hd :: eliminated) errors tl - | uu___2 -> linear_check eliminated (hd :: errors) tl))) in - print_banner (); - FStar_Options.set_option "z3rlimit" - (FStar_Options.Int (Prims.of_int (5))); - (let res = linear_check [] [] all_labels in - FStar_Compiler_Util.print_string "\n"; - FStar_Compiler_List.iter print_result res; - (let uu___4 = - FStar_Compiler_Util.for_all FStar_Pervasives_Native.snd res in - if uu___4 - then - FStar_Compiler_Util.print_string - "Failed: the heuristic of trying each proof in isolation failed to identify a precise error\n" - else ())) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Pruning.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Pruning.ml deleted file mode 100644 index a8a22926b88..00000000000 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Pruning.ml +++ /dev/null @@ -1,1071 +0,0 @@ -open Prims -type triggers = Prims.string Prims.list Prims.list -type triggers_set = Prims.string FStar_Compiler_RBSet.t Prims.list -let (triggers_as_triggers_set : triggers -> triggers_set) = - fun ts -> - FStar_Compiler_List.map - (fun uu___ -> - (Obj.magic - (FStar_Class_Setlike.from_list () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)))) uu___) ts -type pruning_state = - { - macro_freenames: Prims.string Prims.list FStar_Compiler_Util.psmap ; - trigger_to_assumption: - FStar_SMTEncoding_Term.assumption Prims.list FStar_Compiler_Util.psmap ; - assumption_to_triggers: triggers_set FStar_Compiler_Util.psmap ; - assumption_name_map: FStar_SMTEncoding_Term.decl FStar_Compiler_Util.psmap ; - ambients: Prims.string Prims.list ; - extra_roots: FStar_SMTEncoding_Term.assumption Prims.list } -let (__proj__Mkpruning_state__item__macro_freenames : - pruning_state -> Prims.string Prims.list FStar_Compiler_Util.psmap) = - fun projectee -> - match projectee with - | { macro_freenames; trigger_to_assumption; assumption_to_triggers; - assumption_name_map; ambients; extra_roots;_} -> macro_freenames -let (__proj__Mkpruning_state__item__trigger_to_assumption : - pruning_state -> - FStar_SMTEncoding_Term.assumption Prims.list FStar_Compiler_Util.psmap) - = - fun projectee -> - match projectee with - | { macro_freenames; trigger_to_assumption; assumption_to_triggers; - assumption_name_map; ambients; extra_roots;_} -> - trigger_to_assumption -let (__proj__Mkpruning_state__item__assumption_to_triggers : - pruning_state -> triggers_set FStar_Compiler_Util.psmap) = - fun projectee -> - match projectee with - | { macro_freenames; trigger_to_assumption; assumption_to_triggers; - assumption_name_map; ambients; extra_roots;_} -> - assumption_to_triggers -let (__proj__Mkpruning_state__item__assumption_name_map : - pruning_state -> FStar_SMTEncoding_Term.decl FStar_Compiler_Util.psmap) = - fun projectee -> - match projectee with - | { macro_freenames; trigger_to_assumption; assumption_to_triggers; - assumption_name_map; ambients; extra_roots;_} -> assumption_name_map -let (__proj__Mkpruning_state__item__ambients : - pruning_state -> Prims.string Prims.list) = - fun projectee -> - match projectee with - | { macro_freenames; trigger_to_assumption; assumption_to_triggers; - assumption_name_map; ambients; extra_roots;_} -> ambients -let (__proj__Mkpruning_state__item__extra_roots : - pruning_state -> FStar_SMTEncoding_Term.assumption Prims.list) = - fun projectee -> - match projectee with - | { macro_freenames; trigger_to_assumption; assumption_to_triggers; - assumption_name_map; ambients; extra_roots;_} -> extra_roots -let (debug : (unit -> unit) -> unit) = - fun f -> - let uu___ = - let uu___1 = FStar_Options_Ext.get "debug_context_pruning" in - uu___1 <> "" in - if uu___ then f () else () -let (print_pruning_state : pruning_state -> Prims.string) = - fun p -> - let t_to_a = - FStar_Compiler_Util.psmap_fold p.trigger_to_assumption - (fun k -> - fun v -> fun acc -> (k, (FStar_Compiler_List.length v)) :: acc) [] in - let t_to_a1 = - FStar_Compiler_Util.sort_with - (fun x -> - fun y -> - (FStar_Pervasives_Native.snd x) - - (FStar_Pervasives_Native.snd y)) t_to_a in - let a_to_t = - FStar_Compiler_Util.psmap_fold p.assumption_to_triggers - (fun k -> - fun v -> - fun acc -> - let uu___ = - let uu___1 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - (FStar_Compiler_RBSet.showable_rbset - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_string))) v in - FStar_Compiler_Util.format2 "[%s -> %s]" k uu___1 in - uu___ :: acc) [] in - let macros = - FStar_Compiler_Util.psmap_fold p.macro_freenames - (fun k -> - fun v -> - fun acc -> - let uu___ = - let uu___1 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_string)) v in - FStar_Compiler_Util.format2 "[%s -> %s]" k uu___1 in - uu___ :: acc) [] in - let uu___ = - let uu___1 = - FStar_Compiler_List.map - (FStar_Class_Show.show - (FStar_Class_Show.show_tuple2 - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_string) - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int))) t_to_a1 in - FStar_Compiler_String.concat "\n\t" uu___1 in - FStar_Compiler_Util.format3 - "Pruning state:\n\tTriggers to assumptions:\n\t%s\nAssumptions to triggers:\n\t%s\nMacros:\n\t%s\n" - uu___ (FStar_Compiler_String.concat "\n\t" a_to_t) - (FStar_Compiler_String.concat "\n\t" macros) -let (show_pruning_state : pruning_state FStar_Class_Show.showable) = - { FStar_Class_Show.show = print_pruning_state } -let (init : pruning_state) = - let uu___ = FStar_Compiler_Util.psmap_empty () in - let uu___1 = FStar_Compiler_Util.psmap_empty () in - let uu___2 = FStar_Compiler_Util.psmap_empty () in - let uu___3 = FStar_Compiler_Util.psmap_empty () in - { - macro_freenames = uu___; - trigger_to_assumption = uu___1; - assumption_to_triggers = uu___2; - assumption_name_map = uu___3; - ambients = []; - extra_roots = [] - } -let (add_trigger_to_assumption : - FStar_SMTEncoding_Term.assumption -> - pruning_state -> Prims.string -> pruning_state) - = - fun a -> - fun p -> - fun trig -> - let uu___ = - FStar_Compiler_Util.psmap_try_find p.trigger_to_assumption trig in - match uu___ with - | FStar_Pervasives_Native.None -> - let uu___1 = - FStar_Compiler_Util.psmap_add p.trigger_to_assumption trig [a] in - { - macro_freenames = (p.macro_freenames); - trigger_to_assumption = uu___1; - assumption_to_triggers = (p.assumption_to_triggers); - assumption_name_map = (p.assumption_name_map); - ambients = (p.ambients); - extra_roots = (p.extra_roots) - } - | FStar_Pervasives_Native.Some l -> - let uu___1 = - FStar_Compiler_Util.psmap_add p.trigger_to_assumption trig (a - :: l) in - { - macro_freenames = (p.macro_freenames); - trigger_to_assumption = uu___1; - assumption_to_triggers = (p.assumption_to_triggers); - assumption_name_map = (p.assumption_name_map); - ambients = (p.ambients); - extra_roots = (p.extra_roots) - } -let (exclude_names : Prims.string FStar_Compiler_RBSet.t) = - Obj.magic - (FStar_Class_Setlike.from_list () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset FStar_Class_Ord.ord_string)) - ["SFuel"; - "ZFuel"; - "HasType"; - "HasTypeZ"; - "HasTypeFuel"; - "Valid"; - "ApplyTT"; - "ApplyTF"; - "Prims.lex_t"]) -let (free_top_level_names : - FStar_SMTEncoding_Term.term -> Prims.string FStar_Compiler_RBSet.t) = - fun uu___ -> - (fun t -> - let uu___ = FStar_SMTEncoding_Term.free_top_level_names t in - Obj.magic - (FStar_Class_Setlike.diff () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset FStar_Class_Ord.ord_string)) - (Obj.magic uu___) (Obj.magic exclude_names))) uu___ -let (assumption_free_names : - FStar_SMTEncoding_Term.assumption -> Prims.string FStar_Compiler_RBSet.t) = - fun uu___ -> - (fun a -> - Obj.magic - (FStar_Class_Setlike.diff () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset FStar_Class_Ord.ord_string)) - (Obj.magic a.FStar_SMTEncoding_Term.assumption_free_names) - (Obj.magic exclude_names))) uu___ -let (triggers_of_term : FStar_SMTEncoding_Term.term -> triggers_set) = - fun t -> - let rec aux t1 = - match t1.FStar_SMTEncoding_Term.tm with - | FStar_SMTEncoding_Term.Quant - (FStar_SMTEncoding_Term.Forall, triggers1, uu___, uu___1, uu___2) - -> - FStar_Compiler_List.map - (fun disjunct -> - let uu___3 = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) ()) in - FStar_Compiler_List.fold_left - (fun uu___5 -> - fun uu___4 -> - (fun out -> - fun t2 -> - let uu___4 = free_top_level_names t2 in - Obj.magic - (FStar_Class_Setlike.union () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) - (Obj.magic out) (Obj.magic uu___4))) uu___5 - uu___4) uu___3 disjunct) triggers1 - | FStar_SMTEncoding_Term.Labeled (t2, uu___, uu___1) -> aux t2 - | FStar_SMTEncoding_Term.LblPos (t2, uu___) -> aux t2 - | uu___ -> [] in - aux t -let (maybe_add_ambient : - FStar_SMTEncoding_Term.assumption -> pruning_state -> pruning_state) = - fun a -> - fun p -> - let add_assumption_with_triggers triggers1 = - let p1 = - let uu___ = - FStar_Compiler_Util.psmap_add p.assumption_to_triggers - a.FStar_SMTEncoding_Term.assumption_name triggers1 in - { - macro_freenames = (p.macro_freenames); - trigger_to_assumption = (p.trigger_to_assumption); - assumption_to_triggers = uu___; - assumption_name_map = (p.assumption_name_map); - ambients = (p.ambients); - extra_roots = (p.extra_roots) - } in - let uu___ = - FStar_Compiler_List.map - (fun uu___1 -> - (Obj.magic - (FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)))) uu___1) triggers1 in - FStar_Compiler_List.fold_left - (FStar_Compiler_List.fold_left (add_trigger_to_assumption a)) p1 - uu___ in - let is_empty triggers1 = - match triggers1 with - | [] -> true - | t::[] -> - FStar_Class_Setlike.is_empty () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) (Obj.magic t) - | uu___ -> false in - let is_ambient_refinement ty = - match ty.FStar_SMTEncoding_Term.tm with - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Var "Prims.squash", uu___) -> true - | FStar_SMTEncoding_Term.App (FStar_SMTEncoding_Term.Var name, uu___) - -> FStar_Compiler_Util.starts_with name "Tm_refine_" - | FStar_SMTEncoding_Term.FreeV (FStar_SMTEncoding_Term.FV - (name, uu___, uu___1)) -> - FStar_Compiler_Util.starts_with name "Tm_refine_" - | uu___ -> false in - let ambient_refinement_payload ty = - match ty.FStar_SMTEncoding_Term.tm with - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Var "Prims.squash", t::[]) -> t - | uu___ -> ty in - if - a.FStar_SMTEncoding_Term.assumption_name = - "function_token_typing_Prims.__cache_version_number__" - then - { - macro_freenames = (p.macro_freenames); - trigger_to_assumption = (p.trigger_to_assumption); - assumption_to_triggers = (p.assumption_to_triggers); - assumption_name_map = (p.assumption_name_map); - ambients = ((a.FStar_SMTEncoding_Term.assumption_name) :: - (p.ambients)); - extra_roots = (p.extra_roots) - } - else - (match (a.FStar_SMTEncoding_Term.assumption_term).FStar_SMTEncoding_Term.tm - with - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Iff, t0::t1::[]) when - FStar_Compiler_Util.starts_with - a.FStar_SMTEncoding_Term.assumption_name "l_quant_interp" - -> - let triggers_lhs = free_top_level_names t0 in - add_assumption_with_triggers [triggers_lhs] - | uu___ when - FStar_Compiler_Util.starts_with - a.FStar_SMTEncoding_Term.assumption_name "assumption_" - -> - let triggers1 = - triggers_of_term a.FStar_SMTEncoding_Term.assumption_term in - let uu___1 = is_empty triggers1 in - if uu___1 - then - let triggers2 = - let uu___2 = - free_top_level_names - a.FStar_SMTEncoding_Term.assumption_term in - [uu___2] in - add_assumption_with_triggers triggers2 - else add_assumption_with_triggers triggers1 - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Var "HasType", term::ty::[]) when - is_ambient_refinement ty -> - let triggers1 = triggers_of_term (ambient_refinement_payload ty) in - let uu___ = is_empty triggers1 in - if uu___ - then - { - macro_freenames = (p.macro_freenames); - trigger_to_assumption = (p.trigger_to_assumption); - assumption_to_triggers = (p.assumption_to_triggers); - assumption_name_map = (p.assumption_name_map); - ambients = ((a.FStar_SMTEncoding_Term.assumption_name) :: - (p.ambients)); - extra_roots = (a :: (p.extra_roots)) - } - else add_assumption_with_triggers triggers1 - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Var "Valid", - { - FStar_SMTEncoding_Term.tm = FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Var "ApplyTT", - { - FStar_SMTEncoding_Term.tm = FStar_SMTEncoding_Term.FreeV - (FStar_SMTEncoding_Term.FV - ("__uu__PartialApp", uu___, uu___1)); - FStar_SMTEncoding_Term.freevars = uu___2; - FStar_SMTEncoding_Term.rng = uu___3;_}::term::[]); - FStar_SMTEncoding_Term.freevars = uu___4; - FStar_SMTEncoding_Term.rng = uu___5;_}::[]) - -> - let triggers1 = - match term.FStar_SMTEncoding_Term.tm with - | FStar_SMTEncoding_Term.FreeV (FStar_SMTEncoding_Term.FV - (token, uu___6, uu___7)) -> - if FStar_Compiler_Util.ends_with token "@tok" - then - let uu___8 = - Obj.magic - (FStar_Class_Setlike.singleton () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) token) in - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Compiler_Util.substring token Prims.int_zero - ((FStar_Compiler_String.length token) - - (Prims.of_int (4))) in - Obj.magic - (FStar_Class_Setlike.singleton () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) uu___11) in - [uu___10] in - uu___8 :: uu___9 - else - (let uu___9 = - Obj.magic - (FStar_Class_Setlike.singleton () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) token) in - [uu___9]) - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Var token, []) -> - if FStar_Compiler_Util.ends_with token "@tok" - then - let uu___6 = - Obj.magic - (FStar_Class_Setlike.singleton () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) token) in - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Compiler_Util.substring token Prims.int_zero - ((FStar_Compiler_String.length token) - - (Prims.of_int (4))) in - Obj.magic - (FStar_Class_Setlike.singleton () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) uu___9) in - [uu___8] in - uu___6 :: uu___7 - else - (let uu___7 = - Obj.magic - (FStar_Class_Setlike.singleton () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) token) in - [uu___7]) - | uu___6 -> [] in - add_assumption_with_triggers triggers1 - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Var "Valid", - { - FStar_SMTEncoding_Term.tm = FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Var "ApplyTT", - { - FStar_SMTEncoding_Term.tm = FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Var "__uu__PartialApp", uu___); - FStar_SMTEncoding_Term.freevars = uu___1; - FStar_SMTEncoding_Term.rng = uu___2;_}::term::[]); - FStar_SMTEncoding_Term.freevars = uu___3; - FStar_SMTEncoding_Term.rng = uu___4;_}::[]) - -> - let triggers1 = - match term.FStar_SMTEncoding_Term.tm with - | FStar_SMTEncoding_Term.FreeV (FStar_SMTEncoding_Term.FV - (token, uu___5, uu___6)) -> - if FStar_Compiler_Util.ends_with token "@tok" - then - let uu___7 = - Obj.magic - (FStar_Class_Setlike.singleton () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) token) in - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Compiler_Util.substring token Prims.int_zero - ((FStar_Compiler_String.length token) - - (Prims.of_int (4))) in - Obj.magic - (FStar_Class_Setlike.singleton () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) uu___10) in - [uu___9] in - uu___7 :: uu___8 - else - (let uu___8 = - Obj.magic - (FStar_Class_Setlike.singleton () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) token) in - [uu___8]) - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Var token, []) -> - if FStar_Compiler_Util.ends_with token "@tok" - then - let uu___5 = - Obj.magic - (FStar_Class_Setlike.singleton () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) token) in - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Compiler_Util.substring token Prims.int_zero - ((FStar_Compiler_String.length token) - - (Prims.of_int (4))) in - Obj.magic - (FStar_Class_Setlike.singleton () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) uu___8) in - [uu___7] in - uu___5 :: uu___6 - else - (let uu___6 = - Obj.magic - (FStar_Class_Setlike.singleton () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) token) in - [uu___6]) - | uu___5 -> [] in - add_assumption_with_triggers triggers1 - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Var "Valid", term::[]) -> - let uu___ = let uu___1 = free_top_level_names term in [uu___1] in - add_assumption_with_triggers uu___ - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Var "HasType", term::uu___::[]) -> - let uu___1 = let uu___2 = free_top_level_names term in [uu___2] in - add_assumption_with_triggers uu___1 - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Var "IsTotFun", term::[]) -> - let uu___ = let uu___1 = free_top_level_names term in [uu___1] in - add_assumption_with_triggers uu___ - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Var "is-Tm_arrow", term::[]) -> - let uu___ = let uu___1 = free_top_level_names term in [uu___1] in - add_assumption_with_triggers uu___ - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Eq, - uu___::{ - FStar_SMTEncoding_Term.tm = FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Var "Term_constr_id", - term::[]); - FStar_SMTEncoding_Term.freevars = uu___1; - FStar_SMTEncoding_Term.rng = uu___2;_}::[]) - -> - let uu___3 = let uu___4 = free_top_level_names term in [uu___4] in - add_assumption_with_triggers uu___3 - | FStar_SMTEncoding_Term.App (FStar_SMTEncoding_Term.And, tms) -> - let t1 = FStar_Compiler_List.collect triggers_of_term tms in - add_assumption_with_triggers t1 - | FStar_SMTEncoding_Term.App (FStar_SMTEncoding_Term.Eq, t0::t1::[]) - when - FStar_Compiler_Util.starts_with - a.FStar_SMTEncoding_Term.assumption_name "equation_" - -> - let t01 = free_top_level_names t0 in - add_assumption_with_triggers [t01] - | FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.Iff, t0::t1::[]) -> - let t01 = free_top_level_names t0 in - let t11 = free_top_level_names t1 in - add_assumption_with_triggers [t01; t11] - | FStar_SMTEncoding_Term.App (FStar_SMTEncoding_Term.Eq, t0::t1::[]) - -> - let t01 = free_top_level_names t0 in - let t11 = free_top_level_names t1 in - add_assumption_with_triggers [t01; t11] - | FStar_SMTEncoding_Term.App (FStar_SMTEncoding_Term.TrueOp, uu___) - -> p - | uu___ -> - { - macro_freenames = (p.macro_freenames); - trigger_to_assumption = (p.trigger_to_assumption); - assumption_to_triggers = (p.assumption_to_triggers); - assumption_name_map = (p.assumption_name_map); - ambients = ((a.FStar_SMTEncoding_Term.assumption_name) :: - (p.ambients)); - extra_roots = (p.extra_roots) - }) -let (add_assumption_to_triggers : - FStar_SMTEncoding_Term.assumption -> - pruning_state -> triggers_set -> pruning_state) - = - fun a -> - fun p -> - fun trigs -> - let p1 = - let uu___ = - FStar_Compiler_Util.psmap_add p.assumption_name_map - a.FStar_SMTEncoding_Term.assumption_name - (FStar_SMTEncoding_Term.Assume a) in - { - macro_freenames = (p.macro_freenames); - trigger_to_assumption = (p.trigger_to_assumption); - assumption_to_triggers = (p.assumption_to_triggers); - assumption_name_map = uu___; - ambients = (p.ambients); - extra_roots = (p.extra_roots) - } in - match trigs with - | [] -> maybe_add_ambient a p1 - | uu___ -> - let uu___1 = - FStar_Compiler_Util.psmap_add p1.assumption_to_triggers - a.FStar_SMTEncoding_Term.assumption_name trigs in - { - macro_freenames = (p1.macro_freenames); - trigger_to_assumption = (p1.trigger_to_assumption); - assumption_to_triggers = uu___1; - assumption_name_map = (p1.assumption_name_map); - ambients = (p1.ambients); - extra_roots = (p1.extra_roots) - } -let (trigger_reached : pruning_state -> Prims.string -> pruning_state) = - fun p -> - fun trig -> - let uu___ = - FStar_Compiler_Util.psmap_remove p.trigger_to_assumption trig in - { - macro_freenames = (p.macro_freenames); - trigger_to_assumption = uu___; - assumption_to_triggers = (p.assumption_to_triggers); - assumption_name_map = (p.assumption_name_map); - ambients = (p.ambients); - extra_roots = (p.extra_roots) - } -let (remove_trigger_for_assumption : - pruning_state -> - Prims.string -> Prims.string -> (pruning_state * Prims.bool)) - = - fun p -> - fun trig -> - fun aname -> - let uu___ = - FStar_Compiler_Util.psmap_try_find p.assumption_to_triggers aname in - match uu___ with - | FStar_Pervasives_Native.None -> (p, false) - | FStar_Pervasives_Native.Some l -> - let remaining_triggers = - FStar_Compiler_List.map - (fun uu___1 -> - (fun ts -> - Obj.magic - (FStar_Class_Setlike.remove () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) trig - (Obj.magic ts))) uu___1) l in - let eligible = - FStar_Compiler_Util.for_some - (fun uu___1 -> - (Obj.magic - (FStar_Class_Setlike.is_empty () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)))) uu___1) - remaining_triggers in - let uu___1 = - let uu___2 = - FStar_Compiler_Util.psmap_add p.assumption_to_triggers aname - remaining_triggers in - { - macro_freenames = (p.macro_freenames); - trigger_to_assumption = (p.trigger_to_assumption); - assumption_to_triggers = uu___2; - assumption_name_map = (p.assumption_name_map); - ambients = (p.ambients); - extra_roots = (p.extra_roots) - } in - (uu___1, eligible) -let rec (assumptions_of_decl : - FStar_SMTEncoding_Term.decl -> FStar_SMTEncoding_Term.assumption Prims.list) - = - fun d -> - match d with - | FStar_SMTEncoding_Term.Assume a -> [a] - | FStar_SMTEncoding_Term.Module (uu___, ds) -> - FStar_Compiler_List.collect assumptions_of_decl ds - | d1 -> [] -let rec (add_decl : - FStar_SMTEncoding_Term.decl -> pruning_state -> pruning_state) = - fun d -> - fun p -> - match d with - | FStar_SMTEncoding_Term.Assume a -> - let triggers1 = - triggers_of_term a.FStar_SMTEncoding_Term.assumption_term in - let p1 = - let uu___ = - FStar_Compiler_List.map - (fun uu___1 -> - (Obj.magic - (FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)))) uu___1) - triggers1 in - FStar_Compiler_List.fold_left - (FStar_Compiler_List.fold_left (add_trigger_to_assumption a)) p - uu___ in - add_assumption_to_triggers a p1 triggers1 - | FStar_SMTEncoding_Term.Module (uu___, ds) -> - FStar_Compiler_List.fold_left (fun p1 -> fun d1 -> add_decl d1 p1) - p ds - | FStar_SMTEncoding_Term.DefineFun (macro, uu___, uu___1, body, uu___2) - -> - let free_names = - let uu___3 = free_top_level_names body in - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) (Obj.magic uu___3) in - let p1 = - let uu___3 = - FStar_Compiler_Util.psmap_add p.macro_freenames macro - free_names in - { - macro_freenames = uu___3; - trigger_to_assumption = (p.trigger_to_assumption); - assumption_to_triggers = (p.assumption_to_triggers); - assumption_name_map = (p.assumption_name_map); - ambients = (p.ambients); - extra_roots = (p.extra_roots) - } in - p1 - | uu___ -> p -let (add_decls : - FStar_SMTEncoding_Term.decl Prims.list -> pruning_state -> pruning_state) = - fun ds -> - fun p -> - FStar_Compiler_List.fold_left (fun p1 -> fun d -> add_decl d p1) p ds -type sym = Prims.string -type reached_assumption_names = Prims.string FStar_Compiler_RBSet.rbset -type ctxt = { - p: pruning_state ; - reached: reached_assumption_names } -let (__proj__Mkctxt__item__p : ctxt -> pruning_state) = - fun projectee -> match projectee with | { p; reached;_} -> p -let (__proj__Mkctxt__item__reached : ctxt -> reached_assumption_names) = - fun projectee -> match projectee with | { p; reached;_} -> reached -type 'a st = ctxt -> ('a * ctxt) -let (get : ctxt st) = fun s -> (s, s) -let (put : ctxt -> unit st) = fun c -> fun uu___ -> ((), c) -let (st_monad : unit st FStar_Class_Monad.monad) = - { - FStar_Class_Monad.return = - (fun uu___1 -> - fun uu___ -> - (fun a -> fun x -> fun s -> Obj.magic (x, s)) uu___1 uu___); - FStar_Class_Monad.op_let_Bang = - (fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun a -> - fun b -> - fun m -> - let m = Obj.magic m in - fun f -> - let f = Obj.magic f in - fun s -> - let uu___ = m s in - match uu___ with - | (x, s1) -> - let uu___1 = f x in Obj.magic (uu___1 s1)) - uu___3 uu___2 uu___1 uu___) - } -let (mark_trigger_reached : sym -> unit st) = - fun x -> - FStar_Class_Monad.op_let_Bang st_monad () () (Obj.magic get) - (fun uu___ -> - (fun ctxt1 -> - let ctxt1 = Obj.magic ctxt1 in - let uu___ = - let uu___1 = trigger_reached ctxt1.p x in - { p = uu___1; reached = (ctxt1.reached) } in - Obj.magic (put uu___)) uu___) -let (find_assumptions_waiting_on_trigger : - sym -> FStar_SMTEncoding_Term.assumption Prims.list st) = - fun uu___ -> - (fun x -> - Obj.magic - (FStar_Class_Monad.op_let_Bang st_monad () () (Obj.magic get) - (fun uu___ -> - (fun ctxt1 -> - let ctxt1 = Obj.magic ctxt1 in - let uu___ = - FStar_Compiler_Util.psmap_try_find - (ctxt1.p).trigger_to_assumption x in - match uu___ with - | FStar_Pervasives_Native.None -> - Obj.magic - (FStar_Class_Monad.return st_monad () (Obj.magic [])) - | FStar_Pervasives_Native.Some l -> - Obj.magic - (FStar_Class_Monad.return st_monad () (Obj.magic l))) - uu___))) uu___ -let (reached_assumption : Prims.string -> unit st) = - fun aname -> - FStar_Class_Monad.op_let_Bang st_monad () () (Obj.magic get) - (fun uu___ -> - (fun ctxt1 -> - let ctxt1 = Obj.magic ctxt1 in - let p = - let uu___ = ctxt1.p in - let uu___1 = - FStar_Compiler_Util.psmap_remove - (ctxt1.p).assumption_to_triggers aname in - { - macro_freenames = (uu___.macro_freenames); - trigger_to_assumption = (uu___.trigger_to_assumption); - assumption_to_triggers = uu___1; - assumption_name_map = (uu___.assumption_name_map); - ambients = (uu___.ambients); - extra_roots = (uu___.extra_roots) - } in - let uu___ = - let uu___1 = - Obj.magic - (FStar_Class_Setlike.add () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) aname - (Obj.magic ctxt1.reached)) in - { p = (ctxt1.p); reached = uu___1 } in - Obj.magic (put uu___)) uu___) -let (remove_trigger_for : - sym -> FStar_SMTEncoding_Term.assumption -> Prims.bool st) = - fun uu___1 -> - fun uu___ -> - (fun trig -> - fun a -> - Obj.magic - (FStar_Class_Monad.op_let_Bang st_monad () () (Obj.magic get) - (fun uu___ -> - (fun ctxt1 -> - let ctxt1 = Obj.magic ctxt1 in - let uu___ = - remove_trigger_for_assumption ctxt1.p trig - a.FStar_SMTEncoding_Term.assumption_name in - match uu___ with - | (p, eligible) -> - let uu___1 = put { p; reached = (ctxt1.reached) } in - Obj.magic - (FStar_Class_Monad.op_let_Bang st_monad () () - uu___1 - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - Obj.magic - (FStar_Class_Monad.return st_monad () - (Obj.magic eligible))) uu___2))) - uu___))) uu___1 uu___ -let (already_reached : Prims.string -> Prims.bool st) = - fun uu___ -> - (fun aname -> - Obj.magic - (FStar_Class_Monad.op_let_Bang st_monad () () (Obj.magic get) - (fun uu___ -> - (fun ctxt1 -> - let ctxt1 = Obj.magic ctxt1 in - let uu___ = - FStar_Class_Setlike.mem () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) aname - (Obj.magic ctxt1.reached) in - Obj.magic - (FStar_Class_Monad.return st_monad () (Obj.magic uu___))) - uu___))) uu___ -let (trigger_pending_assumptions : - sym Prims.list -> FStar_SMTEncoding_Term.assumption Prims.list st) = - fun uu___ -> - (fun lids -> - Obj.magic - (FStar_Class_Monad.foldM_left st_monad () () - (fun uu___1 -> - fun uu___ -> - (fun acc -> - let acc = Obj.magic acc in - fun lid -> - let lid = Obj.magic lid in - let uu___ = find_assumptions_waiting_on_trigger lid in - Obj.magic - (FStar_Class_Monad.op_let_Bang st_monad () () - (Obj.magic uu___) - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - match uu___1 with - | [] -> - Obj.magic - (FStar_Class_Monad.return st_monad () - (Obj.magic acc)) - | assumptions -> - let uu___2 = mark_trigger_reached lid in - Obj.magic - (FStar_Class_Monad.op_let_Bang - st_monad () () uu___2 - (fun uu___3 -> - (fun uu___3 -> - let uu___3 = Obj.magic uu___3 in - Obj.magic - (FStar_Class_Monad.foldM_left - st_monad () () - (fun uu___5 -> - fun uu___4 -> - (fun acc1 -> - let acc1 = - Obj.magic acc1 in - fun assumption - -> - let assumption - = - Obj.magic - assumption in - let uu___4 = - remove_trigger_for - lid - assumption in - Obj.magic - (FStar_Class_Monad.op_let_Bang - st_monad - () () - ( - Obj.magic - uu___4) - ( - fun - uu___5 -> - (fun - uu___5 -> - let uu___5 - = - Obj.magic - uu___5 in - if uu___5 - then - Obj.magic - (FStar_Class_Monad.return - st_monad - () - (Obj.magic - (assumption - :: acc1))) - else - Obj.magic - (FStar_Class_Monad.return - st_monad - () - (Obj.magic - acc1))) - uu___5))) - uu___5 uu___4) - (Obj.magic acc) - (Obj.magic assumptions))) - uu___3))) uu___1))) uu___1 - uu___) (Obj.magic []) (Obj.magic lids))) uu___ -let rec (scan : FStar_SMTEncoding_Term.assumption Prims.list -> unit st) = - fun ds -> - FStar_Class_Monad.op_let_Bang st_monad () () (Obj.magic get) - (fun uu___ -> - (fun ctxt1 -> - let ctxt1 = Obj.magic ctxt1 in - let macro_expand s = - let uu___ = - FStar_Compiler_Util.psmap_try_find (ctxt1.p).macro_freenames - s in - match uu___ with - | FStar_Pervasives_Native.None -> [s] - | FStar_Pervasives_Native.Some l -> s :: l in - let new_syms = - FStar_Compiler_List.collect - (fun a -> - let uu___ = - let uu___1 = assumption_free_names a in - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) (Obj.magic uu___1) in - FStar_Compiler_List.collect macro_expand uu___) ds in - let uu___ = trigger_pending_assumptions new_syms in - Obj.magic - (FStar_Class_Monad.op_let_Bang st_monad () () (Obj.magic uu___) - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - match uu___1 with - | [] -> - Obj.magic - (FStar_Class_Monad.return st_monad () - (Obj.repr ())) - | triggered -> - let uu___2 = - Obj.magic - (FStar_Class_Monad.foldM_left st_monad () () - (fun uu___4 -> - fun uu___3 -> - (fun acc -> - let acc = Obj.magic acc in - fun assumption -> - let assumption = - Obj.magic assumption in - let uu___3 = - already_reached - assumption.FStar_SMTEncoding_Term.assumption_name in - Obj.magic - (FStar_Class_Monad.op_let_Bang - st_monad () () - (Obj.magic uu___3) - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = - Obj.magic uu___4 in - if uu___4 - then - Obj.magic - (FStar_Class_Monad.return - st_monad () - (Obj.magic acc)) - else - (let uu___6 = - reached_assumption - assumption.FStar_SMTEncoding_Term.assumption_name in - Obj.magic - (FStar_Class_Monad.op_let_Bang - st_monad () () - uu___6 - (fun uu___7 -> - (fun uu___7 - -> - let uu___7 - = - Obj.magic - uu___7 in - Obj.magic - (FStar_Class_Monad.return - st_monad - () - (Obj.magic - (assumption - :: acc)))) - uu___7)))) - uu___4))) uu___4 uu___3) - (Obj.magic []) (Obj.magic triggered)) in - Obj.magic - (FStar_Class_Monad.op_let_Bang st_monad () () - (Obj.magic uu___2) - (fun uu___3 -> - (fun to_scan -> - let to_scan = Obj.magic to_scan in - Obj.magic (scan to_scan)) uu___3))) - uu___1))) uu___) -let (prune : - pruning_state -> - FStar_SMTEncoding_Term.decl Prims.list -> - FStar_SMTEncoding_Term.decl Prims.list) - = - fun p -> - fun roots -> - let roots1 = FStar_Compiler_List.collect assumptions_of_decl roots in - let init1 = - let uu___ = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) ()) in - { p; reached = uu___ } in - let uu___ = - let uu___1 = scan (FStar_List_Tot_Base.op_At roots1 p.extra_roots) in - uu___1 init1 in - match uu___ with - | (uu___1, ctxt1) -> - let reached_names = - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) (Obj.magic ctxt1.reached) in - let reached_assumptions = - FStar_Compiler_List.collect - (fun name -> - let uu___2 = - FStar_Compiler_Util.psmap_try_find - (ctxt1.p).assumption_name_map name in - match uu___2 with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some a -> [a]) - (FStar_List_Tot_Base.op_At reached_names p.ambients) in - reached_assumptions \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Solver.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Solver.ml deleted file mode 100644 index 2d7484cf86c..00000000000 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Solver.ml +++ /dev/null @@ -1,2510 +0,0 @@ -open Prims -exception SplitQueryAndRetry -let (uu___is_SplitQueryAndRetry : Prims.exn -> Prims.bool) = - fun projectee -> - match projectee with | SplitQueryAndRetry -> true | uu___ -> false -let (dbg_SMTQuery : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "SMTQuery" -let (dbg_SMTFail : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "SMTFail" -let (z3_replay_result : (unit * unit)) = ((), ()) -let z3_result_as_replay_result : - 'uuuuu 'uuuuu1 'uuuuu2 . - ('uuuuu, ('uuuuu1 * 'uuuuu2)) FStar_Pervasives.either -> - ('uuuuu, 'uuuuu1) FStar_Pervasives.either - = - fun uu___ -> - match uu___ with - | FStar_Pervasives.Inl l -> FStar_Pervasives.Inl l - | FStar_Pervasives.Inr (r, uu___1) -> FStar_Pervasives.Inr r -let (recorded_hints : - FStar_Compiler_Hints.hints FStar_Pervasives_Native.option - FStar_Compiler_Effect.ref) - = FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None -let (replaying_hints : - FStar_Compiler_Hints.hints FStar_Pervasives_Native.option - FStar_Compiler_Effect.ref) - = FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None -let (use_hints : unit -> Prims.bool) = - fun uu___ -> - (FStar_Options.use_hints ()) && - (let uu___1 = FStar_Options_Ext.get "context_pruning" in uu___1 = "") -let initialize_hints_db : 'uuuuu . Prims.string -> 'uuuuu -> unit = - fun src_filename -> - fun format_filename -> - (let uu___1 = FStar_Options.record_hints () in - if uu___1 - then - FStar_Compiler_Effect.op_Colon_Equals recorded_hints - (FStar_Pervasives_Native.Some []) - else ()); - (let norm_src_filename = - FStar_Compiler_Util.normalize_file_path src_filename in - let val_filename = FStar_Options.hint_file_for_src norm_src_filename in - let uu___1 = FStar_Compiler_Hints.read_hints val_filename in - match uu___1 with - | FStar_Compiler_Hints.HintsOK hints -> - let expected_digest = - FStar_Compiler_Util.digest_of_file norm_src_filename in - ((let uu___3 = FStar_Options.hint_info () in - if uu___3 - then - FStar_Compiler_Util.print3 "(%s) digest is %s from %s.\n" - norm_src_filename - (if - hints.FStar_Compiler_Hints.module_digest = - expected_digest - then "valid; using hints" - else "invalid; using potentially stale hints") val_filename - else ()); - FStar_Compiler_Effect.op_Colon_Equals replaying_hints - (FStar_Pervasives_Native.Some - (hints.FStar_Compiler_Hints.hints))) - | FStar_Compiler_Hints.MalformedJson -> - let uu___3 = use_hints () in - if uu___3 - then - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Compiler_Util.format1 - "Malformed JSON hints file: %s; ran without hints" - val_filename in - FStar_Errors_Msg.text uu___6 in - [uu___5] in - FStar_Errors.log_issue0 - FStar_Errors_Codes.Warning_CouldNotReadHints () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___4) - else () - | FStar_Compiler_Hints.UnableToOpen -> - let uu___3 = use_hints () in - if uu___3 - then - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Compiler_Util.format1 - "Unable to open hints file: %s; ran without hints" - val_filename in - FStar_Errors_Msg.text uu___6 in - [uu___5] in - FStar_Errors.log_issue0 - FStar_Errors_Codes.Warning_CouldNotReadHints () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___4) - else ()) -let (finalize_hints_db : Prims.string -> unit) = - fun src_filename -> - (let uu___1 = FStar_Options.record_hints () in - if uu___1 - then - let hints = - let uu___2 = FStar_Compiler_Effect.op_Bang recorded_hints in - FStar_Compiler_Option.get uu___2 in - let hints_db = - let uu___2 = FStar_Compiler_Util.digest_of_file src_filename in - { - FStar_Compiler_Hints.module_digest = uu___2; - FStar_Compiler_Hints.hints = hints - } in - let norm_src_filename = - FStar_Compiler_Util.normalize_file_path src_filename in - let val_filename = FStar_Options.hint_file_for_src norm_src_filename in - FStar_Compiler_Hints.write_hints val_filename hints_db - else ()); - FStar_Compiler_Effect.op_Colon_Equals recorded_hints - FStar_Pervasives_Native.None; - FStar_Compiler_Effect.op_Colon_Equals replaying_hints - FStar_Pervasives_Native.None -let with_hints_db : 'a . Prims.string -> (unit -> 'a) -> 'a = - fun fname -> - fun f -> - initialize_hints_db fname false; - (let result = f () in finalize_hints_db fname; result) -type errors = - { - error_reason: Prims.string ; - error_rlimit: Prims.int ; - error_fuel: Prims.int ; - error_ifuel: Prims.int ; - error_hint: Prims.string Prims.list FStar_Pervasives_Native.option ; - error_messages: FStar_Errors.error Prims.list } -let (__proj__Mkerrors__item__error_reason : errors -> Prims.string) = - fun projectee -> - match projectee with - | { error_reason; error_rlimit; error_fuel; error_ifuel; error_hint; - error_messages;_} -> error_reason -let (__proj__Mkerrors__item__error_rlimit : errors -> Prims.int) = - fun projectee -> - match projectee with - | { error_reason; error_rlimit; error_fuel; error_ifuel; error_hint; - error_messages;_} -> error_rlimit -let (__proj__Mkerrors__item__error_fuel : errors -> Prims.int) = - fun projectee -> - match projectee with - | { error_reason; error_rlimit; error_fuel; error_ifuel; error_hint; - error_messages;_} -> error_fuel -let (__proj__Mkerrors__item__error_ifuel : errors -> Prims.int) = - fun projectee -> - match projectee with - | { error_reason; error_rlimit; error_fuel; error_ifuel; error_hint; - error_messages;_} -> error_ifuel -let (__proj__Mkerrors__item__error_hint : - errors -> Prims.string Prims.list FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { error_reason; error_rlimit; error_fuel; error_ifuel; error_hint; - error_messages;_} -> error_hint -let (__proj__Mkerrors__item__error_messages : - errors -> FStar_Errors.error Prims.list) = - fun projectee -> - match projectee with - | { error_reason; error_rlimit; error_fuel; error_ifuel; error_hint; - error_messages;_} -> error_messages -let (error_to_short_string : errors -> Prims.string) = - fun err -> - let uu___ = - FStar_Class_Show.show - (FStar_Class_Show.printableshow FStar_Class_Printable.printable_int) - err.error_rlimit in - let uu___1 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow FStar_Class_Printable.printable_int) - err.error_fuel in - let uu___2 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow FStar_Class_Printable.printable_int) - err.error_ifuel in - FStar_Compiler_Util.format5 "%s (rlimit=%s; fuel=%s; ifuel=%s%s)" - err.error_reason uu___ uu___1 uu___2 - (if FStar_Compiler_Option.isSome err.error_hint - then "; with hint" - else "") -let (error_to_is_timeout : errors -> Prims.string Prims.list) = - fun err -> - if FStar_Compiler_Util.ends_with err.error_reason "canceled" - then - let uu___ = - let uu___1 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) err.error_rlimit in - let uu___2 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) err.error_fuel in - let uu___3 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) err.error_ifuel in - FStar_Compiler_Util.format5 - "timeout (rlimit=%s; fuel=%s; ifuel=%s; %s)" err.error_reason - uu___1 uu___2 uu___3 - (if FStar_Compiler_Option.isSome err.error_hint - then "with hint" - else "") in - [uu___] - else [] -type query_settings = - { - query_env: FStar_SMTEncoding_Env.env_t ; - query_decl: FStar_SMTEncoding_Term.decl ; - query_name: Prims.string ; - query_index: Prims.int ; - query_range: FStar_Compiler_Range_Type.range ; - query_fuel: Prims.int ; - query_ifuel: Prims.int ; - query_rlimit: Prims.int ; - query_hint: - FStar_SMTEncoding_UnsatCore.unsat_core FStar_Pervasives_Native.option ; - query_errors: errors Prims.list ; - query_all_labels: FStar_SMTEncoding_Term.error_labels ; - query_suffix: FStar_SMTEncoding_Term.decl Prims.list ; - query_hash: Prims.string FStar_Pervasives_Native.option ; - query_can_be_split_and_retried: Prims.bool ; - query_term: FStar_Syntax_Syntax.term } -let (__proj__Mkquery_settings__item__query_env : - query_settings -> FStar_SMTEncoding_Env.env_t) = - fun projectee -> - match projectee with - | { query_env; query_decl; query_name; query_index; query_range; - query_fuel; query_ifuel; query_rlimit; query_hint; query_errors; - query_all_labels; query_suffix; query_hash; - query_can_be_split_and_retried; query_term;_} -> query_env -let (__proj__Mkquery_settings__item__query_decl : - query_settings -> FStar_SMTEncoding_Term.decl) = - fun projectee -> - match projectee with - | { query_env; query_decl; query_name; query_index; query_range; - query_fuel; query_ifuel; query_rlimit; query_hint; query_errors; - query_all_labels; query_suffix; query_hash; - query_can_be_split_and_retried; query_term;_} -> query_decl -let (__proj__Mkquery_settings__item__query_name : - query_settings -> Prims.string) = - fun projectee -> - match projectee with - | { query_env; query_decl; query_name; query_index; query_range; - query_fuel; query_ifuel; query_rlimit; query_hint; query_errors; - query_all_labels; query_suffix; query_hash; - query_can_be_split_and_retried; query_term;_} -> query_name -let (__proj__Mkquery_settings__item__query_index : - query_settings -> Prims.int) = - fun projectee -> - match projectee with - | { query_env; query_decl; query_name; query_index; query_range; - query_fuel; query_ifuel; query_rlimit; query_hint; query_errors; - query_all_labels; query_suffix; query_hash; - query_can_be_split_and_retried; query_term;_} -> query_index -let (__proj__Mkquery_settings__item__query_range : - query_settings -> FStar_Compiler_Range_Type.range) = - fun projectee -> - match projectee with - | { query_env; query_decl; query_name; query_index; query_range; - query_fuel; query_ifuel; query_rlimit; query_hint; query_errors; - query_all_labels; query_suffix; query_hash; - query_can_be_split_and_retried; query_term;_} -> query_range -let (__proj__Mkquery_settings__item__query_fuel : - query_settings -> Prims.int) = - fun projectee -> - match projectee with - | { query_env; query_decl; query_name; query_index; query_range; - query_fuel; query_ifuel; query_rlimit; query_hint; query_errors; - query_all_labels; query_suffix; query_hash; - query_can_be_split_and_retried; query_term;_} -> query_fuel -let (__proj__Mkquery_settings__item__query_ifuel : - query_settings -> Prims.int) = - fun projectee -> - match projectee with - | { query_env; query_decl; query_name; query_index; query_range; - query_fuel; query_ifuel; query_rlimit; query_hint; query_errors; - query_all_labels; query_suffix; query_hash; - query_can_be_split_and_retried; query_term;_} -> query_ifuel -let (__proj__Mkquery_settings__item__query_rlimit : - query_settings -> Prims.int) = - fun projectee -> - match projectee with - | { query_env; query_decl; query_name; query_index; query_range; - query_fuel; query_ifuel; query_rlimit; query_hint; query_errors; - query_all_labels; query_suffix; query_hash; - query_can_be_split_and_retried; query_term;_} -> query_rlimit -let (__proj__Mkquery_settings__item__query_hint : - query_settings -> - FStar_SMTEncoding_UnsatCore.unsat_core FStar_Pervasives_Native.option) - = - fun projectee -> - match projectee with - | { query_env; query_decl; query_name; query_index; query_range; - query_fuel; query_ifuel; query_rlimit; query_hint; query_errors; - query_all_labels; query_suffix; query_hash; - query_can_be_split_and_retried; query_term;_} -> query_hint -let (__proj__Mkquery_settings__item__query_errors : - query_settings -> errors Prims.list) = - fun projectee -> - match projectee with - | { query_env; query_decl; query_name; query_index; query_range; - query_fuel; query_ifuel; query_rlimit; query_hint; query_errors; - query_all_labels; query_suffix; query_hash; - query_can_be_split_and_retried; query_term;_} -> query_errors -let (__proj__Mkquery_settings__item__query_all_labels : - query_settings -> FStar_SMTEncoding_Term.error_labels) = - fun projectee -> - match projectee with - | { query_env; query_decl; query_name; query_index; query_range; - query_fuel; query_ifuel; query_rlimit; query_hint; query_errors; - query_all_labels; query_suffix; query_hash; - query_can_be_split_and_retried; query_term;_} -> query_all_labels -let (__proj__Mkquery_settings__item__query_suffix : - query_settings -> FStar_SMTEncoding_Term.decl Prims.list) = - fun projectee -> - match projectee with - | { query_env; query_decl; query_name; query_index; query_range; - query_fuel; query_ifuel; query_rlimit; query_hint; query_errors; - query_all_labels; query_suffix; query_hash; - query_can_be_split_and_retried; query_term;_} -> query_suffix -let (__proj__Mkquery_settings__item__query_hash : - query_settings -> Prims.string FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { query_env; query_decl; query_name; query_index; query_range; - query_fuel; query_ifuel; query_rlimit; query_hint; query_errors; - query_all_labels; query_suffix; query_hash; - query_can_be_split_and_retried; query_term;_} -> query_hash -let (__proj__Mkquery_settings__item__query_can_be_split_and_retried : - query_settings -> Prims.bool) = - fun projectee -> - match projectee with - | { query_env; query_decl; query_name; query_index; query_range; - query_fuel; query_ifuel; query_rlimit; query_hint; query_errors; - query_all_labels; query_suffix; query_hash; - query_can_be_split_and_retried; query_term;_} -> - query_can_be_split_and_retried -let (__proj__Mkquery_settings__item__query_term : - query_settings -> FStar_Syntax_Syntax.term) = - fun projectee -> - match projectee with - | { query_env; query_decl; query_name; query_index; query_range; - query_fuel; query_ifuel; query_rlimit; query_hint; query_errors; - query_all_labels; query_suffix; query_hash; - query_can_be_split_and_retried; query_term;_} -> query_term -let (convert_rlimit : Prims.int -> Prims.int) = - fun r -> - let uu___ = - let uu___1 = FStar_Options.z3_version () in - FStar_Compiler_Misc.version_ge uu___1 "4.12.3" in - if uu___ - then (Prims.parse_int "500000") * r - else (Prims.parse_int "544656") * r -let (with_fuel_and_diagnostics : - query_settings -> - FStar_SMTEncoding_Term.decl Prims.list -> - FStar_SMTEncoding_Term.decl Prims.list) - = - fun settings -> - fun label_assumptions -> - let n = settings.query_fuel in - let i = settings.query_ifuel in - let rlimit = convert_rlimit settings.query_rlimit in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Compiler_Util.string_of_int n in - let uu___4 = FStar_Compiler_Util.string_of_int i in - FStar_Compiler_Util.format2 "" uu___3 - uu___4 in - FStar_SMTEncoding_Term.Caption uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = FStar_SMTEncoding_Util.mkApp ("MaxFuel", []) in - let uu___8 = FStar_SMTEncoding_Term.n_fuel n in - (uu___7, uu___8) in - FStar_SMTEncoding_Util.mkEq uu___6 in - (uu___5, FStar_Pervasives_Native.None, "@MaxFuel_assumption") in - FStar_SMTEncoding_Util.mkAssume uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - FStar_SMTEncoding_Util.mkApp ("MaxIFuel", []) in - let uu___10 = FStar_SMTEncoding_Term.n_fuel i in - (uu___9, uu___10) in - FStar_SMTEncoding_Util.mkEq uu___8 in - (uu___7, FStar_Pervasives_Native.None, - "@MaxIFuel_assumption") in - FStar_SMTEncoding_Util.mkAssume uu___6 in - [uu___5; settings.query_decl] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = FStar_Compiler_Util.string_of_int rlimit in - ("rlimit", uu___6) in - FStar_SMTEncoding_Term.SetOption uu___5 in - [uu___4; - FStar_SMTEncoding_Term.CheckSat; - FStar_SMTEncoding_Term.SetOption ("rlimit", "0"); - FStar_SMTEncoding_Term.GetReasonUnknown; - FStar_SMTEncoding_Term.GetUnsatCore] in - let uu___4 = - let uu___5 = - let uu___6 = - (FStar_Options.print_z3_statistics ()) || - (FStar_Options.query_stats ()) in - if uu___6 then [FStar_SMTEncoding_Term.GetStatistics] else [] in - FStar_Compiler_List.op_At uu___5 settings.query_suffix in - FStar_Compiler_List.op_At uu___3 uu___4 in - FStar_Compiler_List.op_At label_assumptions uu___2 in - FStar_Compiler_List.op_At uu___ uu___1 -let (used_hint : query_settings -> Prims.bool) = - fun s -> FStar_Compiler_Option.isSome s.query_hint -let (get_hint_for : - Prims.string -> - Prims.int -> FStar_Compiler_Hints.hint FStar_Pervasives_Native.option) - = - fun qname -> - fun qindex -> - let uu___ = FStar_Compiler_Effect.op_Bang replaying_hints in - match uu___ with - | FStar_Pervasives_Native.Some hints -> - FStar_Compiler_Util.find_map hints - (fun uu___1 -> - match uu___1 with - | FStar_Pervasives_Native.Some hint when - (hint.FStar_Compiler_Hints.hint_name = qname) && - (hint.FStar_Compiler_Hints.hint_index = qindex) - -> FStar_Pervasives_Native.Some hint - | uu___2 -> FStar_Pervasives_Native.None) - | uu___1 -> FStar_Pervasives_Native.None -let (query_errors : - query_settings -> - FStar_SMTEncoding_Z3.z3result -> errors FStar_Pervasives_Native.option) - = - fun settings -> - fun z3result -> - match z3result.FStar_SMTEncoding_Z3.z3result_status with - | FStar_SMTEncoding_Z3.UNSAT uu___ -> FStar_Pervasives_Native.None - | uu___ -> - let uu___1 = - FStar_SMTEncoding_Z3.status_string_and_errors - z3result.FStar_SMTEncoding_Z3.z3result_status in - (match uu___1 with - | (msg, error_labels) -> - let err = - let uu___2 = - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with - | (uu___4, x, y) -> - let uu___5 = FStar_Errors.get_ctx () in - (FStar_Errors_Codes.Error_Z3SolverError, x, y, - uu___5)) error_labels in - { - error_reason = msg; - error_rlimit = (settings.query_rlimit); - error_fuel = (settings.query_fuel); - error_ifuel = (settings.query_ifuel); - error_hint = (settings.query_hint); - error_messages = uu___2 - } in - FStar_Pervasives_Native.Some err) -let (detail_hint_replay : - query_settings -> FStar_SMTEncoding_Z3.z3result -> unit) = - fun settings -> - fun z3result -> - let uu___ = - (used_hint settings) && (FStar_Options.detail_hint_replay ()) in - if uu___ - then - match z3result.FStar_SMTEncoding_Z3.z3result_status with - | FStar_SMTEncoding_Z3.UNSAT uu___1 -> () - | _failed -> - let ask_z3 label_assumptions = - let uu___1 = - with_fuel_and_diagnostics settings label_assumptions in - let uu___2 = - let uu___3 = - FStar_Compiler_Util.string_of_int settings.query_index in - FStar_Compiler_Util.format2 "(%s, %s)" settings.query_name - uu___3 in - FStar_SMTEncoding_Z3.ask settings.query_range - settings.query_hash settings.query_all_labels uu___1 uu___2 - false FStar_Pervasives_Native.None in - FStar_SMTEncoding_ErrorReporting.detail_errors true - (settings.query_env).FStar_SMTEncoding_Env.tcenv - settings.query_all_labels ask_z3 - else () -let (find_localized_errors : - errors Prims.list -> errors FStar_Pervasives_Native.option) = - fun errs -> - FStar_Compiler_List.tryFind - (fun err -> match err.error_messages with | [] -> false | uu___ -> true) - errs -let (errors_to_report : - Prims.bool -> query_settings -> FStar_Errors.error Prims.list) = - fun tried_recovery -> - fun settings -> - let format_smt_error msg = - let d = - let uu___ = FStar_Pprint.doc_of_string "SMT solver says:" in - let uu___1 = - let uu___2 = FStar_Errors_Msg.sublist FStar_Pprint.empty msg in - let uu___3 = - let uu___4 = - let uu___5 = FStar_Pprint.doc_of_string "Note:" in - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Errors_Msg.text - "'canceled' or 'resource limits reached' means the SMT query timed out, so you might want to increase the rlimit" in - let uu___9 = - let uu___10 = - FStar_Errors_Msg.text - "'incomplete quantifiers' means Z3 could not prove the query, so try to spell out your proof out in greater detail, increase fuel or ifuel" in - let uu___11 = - let uu___12 = - FStar_Errors_Msg.text - "'unknown' means Z3 provided no further reason for the proof failing" in - [uu___12] in - uu___10 :: uu___11 in - uu___8 :: uu___9 in - FStar_Errors_Msg.bulleted uu___7 in - FStar_Pprint.op_Hat_Hat uu___5 uu___6 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline uu___4 in - FStar_Pprint.op_Hat_Hat uu___2 uu___3 in - FStar_Pprint.op_Hat_Hat uu___ uu___1 in - [d] in - let recovery_failed_msg = - if tried_recovery - then - let uu___ = - FStar_Errors_Msg.text - "This query was retried due to the --proof_recovery option, yet it\n still failed on all attempts." in - [uu___] - else [] in - let basic_errors = - let smt_error = - let uu___ = FStar_Options.query_stats () in - if uu___ - then - let uu___1 = - let uu___2 = - FStar_Compiler_List.map error_to_short_string - settings.query_errors in - FStar_Compiler_List.map FStar_Pprint.doc_of_string uu___2 in - format_smt_error uu___1 - else - (let uu___2 = - FStar_Compiler_List.fold_left - (fun uu___3 -> - fun err -> - match uu___3 with - | (ic, cc, uc, bc) -> - let err1 = - FStar_Compiler_Util.substring_from - err.error_reason - (FStar_Compiler_String.length - "unknown because ") in - if - FStar_Compiler_Util.starts_with err1 - "(incomplete" - then ((ic + Prims.int_one), cc, uc, bc) - else - if - ((FStar_Compiler_Util.starts_with err1 - "canceled") - || - (FStar_Compiler_Util.starts_with err1 - "(resource")) - || - (FStar_Compiler_Util.starts_with err1 - "timeout") - then (ic, (cc + Prims.int_one), uc, bc) - else - if - FStar_Compiler_Util.starts_with err1 - "Overflow encountered when expanding old_vector" - then (ic, cc, uc, (bc + Prims.int_one)) - else (ic, cc, (uc + Prims.int_one), bc)) - (Prims.int_zero, Prims.int_zero, Prims.int_zero, - Prims.int_zero) settings.query_errors in - match uu___2 with - | (incomplete_count, canceled_count, unknown_count, - z3_overflow_bug_count) -> - (if z3_overflow_bug_count > Prims.int_zero - then - (let uu___4 = - let uu___5 = - FStar_Errors_Msg.text - "Z3 ran into an internal overflow while trying to prove this query." in - let uu___6 = - let uu___7 = - FStar_Errors_Msg.text - "Try breaking it down, or using --split_queries." in - [uu___7] in - uu___5 :: uu___6 in - FStar_Errors.log_issue - FStar_Class_HasRange.hasRange_range - settings.query_range - FStar_Errors_Codes.Warning_UnexpectedZ3Stderr () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___4)) - else (); - (let base = - match (incomplete_count, canceled_count, unknown_count) - with - | (uu___4, uu___5, uu___6) when - ((uu___5 = Prims.int_zero) && - (uu___6 = Prims.int_zero)) - && (incomplete_count > Prims.int_zero) - -> - let uu___7 = - FStar_Errors_Msg.text - "The SMT solver could not prove the query. Use --query_stats for more details." in - [uu___7] - | (uu___4, uu___5, uu___6) when - ((uu___4 = Prims.int_zero) && - (uu___6 = Prims.int_zero)) - && (canceled_count > Prims.int_zero) - -> - let uu___7 = - FStar_Errors_Msg.text - "The SMT query timed out, you might want to increase the rlimit" in - [uu___7] - | (uu___4, uu___5, uu___6) -> - let uu___7 = - FStar_Errors_Msg.text - "Try with --query_stats to get more details" in - [uu___7] in - FStar_Compiler_List.op_At base recovery_failed_msg))) in - let uu___ = - let uu___1 = find_localized_errors settings.query_errors in - (uu___1, (settings.query_all_labels)) in - match uu___ with - | (FStar_Pervasives_Native.Some err, uu___1) -> - FStar_TypeChecker_Err.errors_smt_detail - (settings.query_env).FStar_SMTEncoding_Env.tcenv - err.error_messages smt_error - | (FStar_Pervasives_Native.None, (uu___1, msg, rng)::[]) -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_Errors.get_ctx () in - (FStar_Errors_Codes.Error_Z3SolverError, msg, rng, uu___4) in - [uu___3] in - FStar_TypeChecker_Err.errors_smt_detail - (settings.query_env).FStar_SMTEncoding_Env.tcenv uu___2 - recovery_failed_msg - | (FStar_Pervasives_Native.None, uu___1) -> - if settings.query_can_be_split_and_retried - then FStar_Compiler_Effect.raise SplitQueryAndRetry - else - (let l = FStar_Compiler_List.length settings.query_all_labels in - let labels = - if l = Prims.int_zero - then - let dummy_fv = - FStar_SMTEncoding_Term.mk_fv - ("", FStar_SMTEncoding_Term.dummy_sort) in - let msg = - let uu___3 = - let uu___4 = - FStar_Errors_Msg.text - "Failed to prove the following goal, although it appears to be trivial:" in - let uu___5 = - FStar_Class_PP.pp FStar_Syntax_Print.pretty_term - settings.query_term in - FStar_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in - [uu___3] in - let range = - FStar_TypeChecker_Env.get_range - (settings.query_env).FStar_SMTEncoding_Env.tcenv in - [(dummy_fv, msg, range)] - else - if l > Prims.int_one - then - ((let uu___5 = - let uu___6 = FStar_Options.split_queries () in - uu___6 <> FStar_Options.No in - if uu___5 - then - let uu___6 = - FStar_TypeChecker_Env.get_range - (settings.query_env).FStar_SMTEncoding_Env.tcenv in - FStar_TypeChecker_Err.log_issue_text - (settings.query_env).FStar_SMTEncoding_Env.tcenv - uu___6 - (FStar_Errors_Codes.Warning_SplitAndRetryQueries, - "The verification condition was to be split into several atomic sub-goals, but this query has multiple sub-goals---the error report may be inaccurate") - else ()); - settings.query_all_labels) - else settings.query_all_labels in - FStar_Compiler_List.collect - (fun uu___3 -> - match uu___3 with - | (uu___4, msg, rng) -> - let uu___5 = - let uu___6 = - let uu___7 = FStar_Errors.get_ctx () in - (FStar_Errors_Codes.Error_Z3SolverError, msg, - rng, uu___7) in - [uu___6] in - FStar_TypeChecker_Err.errors_smt_detail - (settings.query_env).FStar_SMTEncoding_Env.tcenv - uu___5 recovery_failed_msg) labels) in - (let uu___ = FStar_Options.detail_errors () in - if uu___ - then - let initial_fuel = - let uu___1 = FStar_Options.initial_fuel () in - let uu___2 = FStar_Options.initial_ifuel () in - { - query_env = (settings.query_env); - query_decl = (settings.query_decl); - query_name = (settings.query_name); - query_index = (settings.query_index); - query_range = (settings.query_range); - query_fuel = uu___1; - query_ifuel = uu___2; - query_rlimit = (settings.query_rlimit); - query_hint = FStar_Pervasives_Native.None; - query_errors = (settings.query_errors); - query_all_labels = (settings.query_all_labels); - query_suffix = (settings.query_suffix); - query_hash = (settings.query_hash); - query_can_be_split_and_retried = - (settings.query_can_be_split_and_retried); - query_term = (settings.query_term) - } in - let ask_z3 label_assumptions = - let uu___1 = - with_fuel_and_diagnostics initial_fuel label_assumptions in - let uu___2 = - let uu___3 = - FStar_Compiler_Util.string_of_int settings.query_index in - FStar_Compiler_Util.format2 "(%s, %s)" settings.query_name - uu___3 in - FStar_SMTEncoding_Z3.ask settings.query_range settings.query_hash - settings.query_all_labels uu___1 uu___2 false - FStar_Pervasives_Native.None in - FStar_SMTEncoding_ErrorReporting.detail_errors false - (settings.query_env).FStar_SMTEncoding_Env.tcenv - settings.query_all_labels ask_z3 - else ()); - basic_errors -let (report_errors : Prims.bool -> query_settings -> unit) = - fun tried_recovery -> - fun qry_settings -> - let uu___ = errors_to_report tried_recovery qry_settings in - FStar_Errors.add_errors uu___ -type unique_string_accumulator = - { - add: Prims.string -> unit ; - get: unit -> Prims.string Prims.list ; - clear: unit -> unit } -let (__proj__Mkunique_string_accumulator__item__add : - unique_string_accumulator -> Prims.string -> unit) = - fun projectee -> match projectee with | { add; get; clear;_} -> add -let (__proj__Mkunique_string_accumulator__item__get : - unique_string_accumulator -> unit -> Prims.string Prims.list) = - fun projectee -> match projectee with | { add; get; clear;_} -> get -let (__proj__Mkunique_string_accumulator__item__clear : - unique_string_accumulator -> unit -> unit) = - fun projectee -> match projectee with | { add; get; clear;_} -> clear -let (mk_unique_string_accumulator : unit -> unique_string_accumulator) = - fun uu___ -> - let strings = FStar_Compiler_Util.mk_ref [] in - let add m = - let ms = FStar_Compiler_Effect.op_Bang strings in - if FStar_Compiler_List.contains m ms - then () - else FStar_Compiler_Effect.op_Colon_Equals strings (m :: ms) in - let get uu___1 = - let uu___2 = FStar_Compiler_Effect.op_Bang strings in - FStar_Compiler_Util.sort_with FStar_Compiler_String.compare uu___2 in - let clear uu___1 = FStar_Compiler_Effect.op_Colon_Equals strings [] in - { add; get; clear } -let (query_info : query_settings -> FStar_SMTEncoding_Z3.z3result -> unit) = - fun settings -> - fun z3result -> - let process_unsat_core core = - let uu___ = mk_unique_string_accumulator () in - match uu___ with - | { add = add_module_name; get = get_module_names; clear = uu___1;_} - -> - let add_module_name1 s = add_module_name s in - let uu___2 = mk_unique_string_accumulator () in - (match uu___2 with - | { add = add_discarded_name; get = get_discarded_names; - clear = uu___3;_} -> - let parse_axiom_name s = - let chars = FStar_Compiler_String.list_of_string s in - let first_upper_index = - FStar_Compiler_Util.try_find_index - FStar_Compiler_Util.is_upper chars in - match first_upper_index with - | FStar_Pervasives_Native.None -> - (add_discarded_name s; []) - | FStar_Pervasives_Native.Some first_upper_index1 -> - let name_and_suffix = - FStar_Compiler_Util.substring_from s - first_upper_index1 in - let components = - FStar_Compiler_String.split [46] name_and_suffix in - let excluded_suffixes = - ["fuel_instrumented"; - "_pretyping"; - "_Tm_refine"; - "_Tm_abs"; - "@"; - "_interpretation_Tm_arrow"; - "MaxFuel_assumption"; - "MaxIFuel_assumption"] in - let exclude_suffix s1 = - let s2 = FStar_Compiler_Util.trim_string s1 in - let sopt = - FStar_Compiler_Util.find_map excluded_suffixes - (fun sfx -> - if FStar_Compiler_Util.contains s2 sfx - then - let uu___4 = - FStar_Compiler_List.hd - (FStar_Compiler_Util.split s2 sfx) in - FStar_Pervasives_Native.Some uu___4 - else FStar_Pervasives_Native.None) in - match sopt with - | FStar_Pervasives_Native.None -> - if s2 = "" then [] else [s2] - | FStar_Pervasives_Native.Some s3 -> - if s3 = "" then [] else [s3] in - let components1 = - match components with - | [] -> [] - | uu___4 -> - let uu___5 = - FStar_Compiler_Util.prefix components in - (match uu___5 with - | (lident, last) -> - let components2 = - let uu___6 = exclude_suffix last in - FStar_Compiler_List.op_At lident uu___6 in - let module_name = - FStar_Compiler_Util.prefix_until - (fun s1 -> - let uu___6 = - let uu___7 = - FStar_Compiler_Util.char_at s1 - Prims.int_zero in - FStar_Compiler_Util.is_upper - uu___7 in - Prims.op_Negation uu___6) - components2 in - ((match module_name with - | FStar_Pervasives_Native.None -> () - | FStar_Pervasives_Native.Some - (m, uu___7, uu___8) -> - add_module_name1 - (FStar_Compiler_String.concat "." m)); - components2)) in - if components1 = [] - then (add_discarded_name s; []) - else [FStar_Compiler_String.concat "." components1] in - let should_log = - (FStar_Options.hint_info ()) || - (FStar_Options.query_stats ()) in - let maybe_log f = if should_log then f () else () in - (match core with - | FStar_Pervasives_Native.None -> - maybe_log - (fun uu___4 -> - FStar_Compiler_Util.print_string "no unsat core\n") - | FStar_Pervasives_Native.Some core1 -> - let core2 = - FStar_Compiler_List.collect parse_axiom_name core1 in - maybe_log - (fun uu___4 -> - (let uu___6 = - let uu___7 = get_module_names () in - FStar_Compiler_String.concat - "\nZ3 Proof Stats:\t" uu___7 in - FStar_Compiler_Util.print1 - "Z3 Proof Stats: Modules relevant to this proof:\nZ3 Proof Stats:\t%s\n" - uu___6); - FStar_Compiler_Util.print1 - "Z3 Proof Stats (Detail 1): Specifically:\nZ3 Proof Stats (Detail 1):\t%s\n" - (FStar_Compiler_String.concat - "\nZ3 Proof Stats (Detail 1):\t" core2); - (let uu___7 = - let uu___8 = get_discarded_names () in - FStar_Compiler_String.concat ", " uu___8 in - FStar_Compiler_Util.print1 - "Z3 Proof Stats (Detail 2): Note, this report ignored the following names in the context: %s\n" - uu___7)))) in - let uu___ = - (FStar_Options.hint_info ()) || (FStar_Options.query_stats ()) in - if uu___ - then - let uu___1 = - FStar_SMTEncoding_Z3.status_string_and_errors - z3result.FStar_SMTEncoding_Z3.z3result_status in - match uu___1 with - | (status_string, errs) -> - let at_log_file = - match z3result.FStar_SMTEncoding_Z3.z3result_log_file with - | FStar_Pervasives_Native.None -> "" - | FStar_Pervasives_Native.Some s -> Prims.strcat "@" s in - let uu___2 = - match z3result.FStar_SMTEncoding_Z3.z3result_status with - | FStar_SMTEncoding_Z3.UNSAT core -> - let uu___3 = FStar_Compiler_Util.colorize_green "succeeded" in - (uu___3, core) - | uu___3 -> - let uu___4 = - FStar_Compiler_Util.colorize_red - (Prims.strcat "failed {reason-unknown=" - (Prims.strcat status_string "}")) in - (uu___4, FStar_Pervasives_Native.None) in - (match uu___2 with - | (tag, core) -> - let range = - let uu___3 = - let uu___4 = - FStar_Class_Show.show - FStar_Compiler_Range_Ops.showable_range - settings.query_range in - Prims.strcat uu___4 (Prims.strcat at_log_file ")") in - Prims.strcat "(" uu___3 in - let used_hint_tag = - if used_hint settings then " (with hint)" else "" in - let stats = - let uu___3 = FStar_Options.query_stats () in - if uu___3 - then - let f k v a = - Prims.strcat a - (Prims.strcat k - (Prims.strcat "=" (Prims.strcat v " "))) in - let str = - FStar_Compiler_Util.smap_fold - z3result.FStar_SMTEncoding_Z3.z3result_statistics f - "statistics={" in - let uu___4 = - FStar_Compiler_Util.substring str Prims.int_zero - ((FStar_Compiler_String.length str) - Prims.int_one) in - Prims.strcat uu___4 "}" - else "" in - ((let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - settings.query_index in - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - z3result.FStar_SMTEncoding_Z3.z3result_time in - let uu___12 = - let uu___13 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - settings.query_fuel in - let uu___14 = - let uu___15 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - settings.query_ifuel in - let uu___16 = - let uu___17 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - settings.query_rlimit in - [uu___17] in - uu___15 :: uu___16 in - uu___13 :: uu___14 in - uu___11 :: uu___12 in - used_hint_tag :: uu___10 in - tag :: uu___9 in - uu___7 :: uu___8 in - (settings.query_name) :: uu___6 in - range :: uu___5 in - FStar_Compiler_Util.print - "%s\tQuery-stats (%s, %s)\t%s%s in %s milliseconds with fuel %s and ifuel %s and rlimit %s\n" - uu___4); - (let uu___5 = FStar_Options.print_z3_statistics () in - if uu___5 then process_unsat_core core else ()); - FStar_Compiler_List.iter - (fun uu___5 -> - match uu___5 with - | (uu___6, msg, range1) -> - let msg1 = - if used_hint settings - then - let uu___7 = - FStar_Pprint.doc_of_string - "Hint-replay failed" in - uu___7 :: msg - else msg in - FStar_Errors.log_issue - FStar_Class_HasRange.hasRange_range range1 - FStar_Errors_Codes.Warning_HitReplayFailed () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic msg1)) errs)) - else - (let uu___2 = - let uu___3 = FStar_Options_Ext.get "profile_context" in - uu___3 <> "" in - if uu___2 - then - match z3result.FStar_SMTEncoding_Z3.z3result_status with - | FStar_SMTEncoding_Z3.UNSAT core -> process_unsat_core core - | uu___3 -> () - else ()) -let (store_hint : FStar_Compiler_Hints.hint -> unit) = - fun hint -> - let uu___ = FStar_Compiler_Effect.op_Bang recorded_hints in - match uu___ with - | FStar_Pervasives_Native.Some l -> - FStar_Compiler_Effect.op_Colon_Equals recorded_hints - (FStar_Pervasives_Native.Some - (FStar_Compiler_List.op_At l [FStar_Pervasives_Native.Some hint])) - | uu___1 -> () -let (record_hint : query_settings -> FStar_SMTEncoding_Z3.z3result -> unit) = - fun settings -> - fun z3result -> - let uu___ = - let uu___1 = FStar_Options.record_hints () in - Prims.op_Negation uu___1 in - if uu___ - then () - else - (let mk_hint core = - { - FStar_Compiler_Hints.hint_name = (settings.query_name); - FStar_Compiler_Hints.hint_index = (settings.query_index); - FStar_Compiler_Hints.fuel = (settings.query_fuel); - FStar_Compiler_Hints.ifuel = (settings.query_ifuel); - FStar_Compiler_Hints.unsat_core = core; - FStar_Compiler_Hints.query_elapsed_time = Prims.int_zero; - FStar_Compiler_Hints.hash = - (match z3result.FStar_SMTEncoding_Z3.z3result_status with - | FStar_SMTEncoding_Z3.UNSAT core1 -> - z3result.FStar_SMTEncoding_Z3.z3result_query_hash - | uu___2 -> FStar_Pervasives_Native.None) - } in - match z3result.FStar_SMTEncoding_Z3.z3result_status with - | FStar_SMTEncoding_Z3.UNSAT (FStar_Pervasives_Native.None) -> - let uu___2 = - let uu___3 = - get_hint_for settings.query_name settings.query_index in - FStar_Compiler_Option.get uu___3 in - store_hint uu___2 - | FStar_SMTEncoding_Z3.UNSAT unsat_core -> - if used_hint settings - then store_hint (mk_hint settings.query_hint) - else store_hint (mk_hint unsat_core) - | uu___2 -> ()) -let (process_result : - query_settings -> - FStar_SMTEncoding_Z3.z3result -> errors FStar_Pervasives_Native.option) - = - fun settings -> - fun result -> - let errs = query_errors settings result in - query_info settings result; - record_hint settings result; - detail_hint_replay settings result; - errs -let (fold_queries : - query_settings Prims.list -> - (query_settings -> FStar_SMTEncoding_Z3.z3result) -> - (query_settings -> - FStar_SMTEncoding_Z3.z3result -> - errors FStar_Pervasives_Native.option) - -> (errors Prims.list, query_settings) FStar_Pervasives.either) - = - fun qs -> - fun ask -> - fun f -> - let rec aux acc qs1 = - match qs1 with - | [] -> FStar_Pervasives.Inl acc - | q::qs2 -> - let res = ask q in - let uu___ = f q res in - (match uu___ with - | FStar_Pervasives_Native.None -> FStar_Pervasives.Inr q - | FStar_Pervasives_Native.Some errs -> aux (errs :: acc) qs2) in - aux [] qs -let (full_query_id : query_settings -> Prims.string) = - fun settings -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Compiler_Util.string_of_int settings.query_index in - Prims.strcat uu___3 ")" in - Prims.strcat ", " uu___2 in - Prims.strcat settings.query_name uu___1 in - Prims.strcat "(" uu___ -let collect_dups : 'a . 'a Prims.list -> ('a * Prims.int) Prims.list = - fun l -> - let acc = [] in - let rec add_one acc1 x = - match acc1 with - | [] -> [(x, Prims.int_one)] - | (h, n)::t -> - if h = x - then (h, (n + Prims.int_one)) :: t - else (let uu___1 = add_one t x in (h, n) :: uu___1) in - FStar_Compiler_List.fold_left add_one acc l -type answer = - { - ok: Prims.bool ; - cache_hit: Prims.bool ; - quaking: Prims.bool ; - quaking_or_retrying: Prims.bool ; - lo: Prims.int ; - hi: Prims.int ; - nsuccess: Prims.int ; - total_ran: Prims.int ; - tried_recovery: Prims.bool ; - errs: errors Prims.list Prims.list } -let (__proj__Mkanswer__item__ok : answer -> Prims.bool) = - fun projectee -> - match projectee with - | { ok; cache_hit; quaking; quaking_or_retrying; lo; hi; nsuccess; - total_ran; tried_recovery; errs;_} -> ok -let (__proj__Mkanswer__item__cache_hit : answer -> Prims.bool) = - fun projectee -> - match projectee with - | { ok; cache_hit; quaking; quaking_or_retrying; lo; hi; nsuccess; - total_ran; tried_recovery; errs;_} -> cache_hit -let (__proj__Mkanswer__item__quaking : answer -> Prims.bool) = - fun projectee -> - match projectee with - | { ok; cache_hit; quaking; quaking_or_retrying; lo; hi; nsuccess; - total_ran; tried_recovery; errs;_} -> quaking -let (__proj__Mkanswer__item__quaking_or_retrying : answer -> Prims.bool) = - fun projectee -> - match projectee with - | { ok; cache_hit; quaking; quaking_or_retrying; lo; hi; nsuccess; - total_ran; tried_recovery; errs;_} -> quaking_or_retrying -let (__proj__Mkanswer__item__lo : answer -> Prims.int) = - fun projectee -> - match projectee with - | { ok; cache_hit; quaking; quaking_or_retrying; lo; hi; nsuccess; - total_ran; tried_recovery; errs;_} -> lo -let (__proj__Mkanswer__item__hi : answer -> Prims.int) = - fun projectee -> - match projectee with - | { ok; cache_hit; quaking; quaking_or_retrying; lo; hi; nsuccess; - total_ran; tried_recovery; errs;_} -> hi -let (__proj__Mkanswer__item__nsuccess : answer -> Prims.int) = - fun projectee -> - match projectee with - | { ok; cache_hit; quaking; quaking_or_retrying; lo; hi; nsuccess; - total_ran; tried_recovery; errs;_} -> nsuccess -let (__proj__Mkanswer__item__total_ran : answer -> Prims.int) = - fun projectee -> - match projectee with - | { ok; cache_hit; quaking; quaking_or_retrying; lo; hi; nsuccess; - total_ran; tried_recovery; errs;_} -> total_ran -let (__proj__Mkanswer__item__tried_recovery : answer -> Prims.bool) = - fun projectee -> - match projectee with - | { ok; cache_hit; quaking; quaking_or_retrying; lo; hi; nsuccess; - total_ran; tried_recovery; errs;_} -> tried_recovery -let (__proj__Mkanswer__item__errs : answer -> errors Prims.list Prims.list) = - fun projectee -> - match projectee with - | { ok; cache_hit; quaking; quaking_or_retrying; lo; hi; nsuccess; - total_ran; tried_recovery; errs;_} -> errs -let (ans_ok : answer) = - { - ok = true; - cache_hit = false; - quaking = false; - quaking_or_retrying = false; - lo = Prims.int_one; - hi = Prims.int_one; - nsuccess = Prims.int_one; - total_ran = Prims.int_one; - tried_recovery = false; - errs = [] - } -let (ans_fail : answer) = - { - ok = false; - cache_hit = (ans_ok.cache_hit); - quaking = (ans_ok.quaking); - quaking_or_retrying = (ans_ok.quaking_or_retrying); - lo = (ans_ok.lo); - hi = (ans_ok.hi); - nsuccess = Prims.int_zero; - total_ran = (ans_ok.total_ran); - tried_recovery = (ans_ok.tried_recovery); - errs = (ans_ok.errs) - } -let (uu___0 : answer FStar_Class_Show.showable) = - { - FStar_Class_Show.show = - (fun ans -> - let uu___ = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) ans.ok in - let uu___1 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) ans.nsuccess in - let uu___2 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) ans.lo in - let uu___3 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) ans.hi in - let uu___4 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) ans.tried_recovery in - FStar_Compiler_Util.format5 - "ok=%s nsuccess=%s lo=%s hi=%s tried_recovery=%s" uu___ uu___1 - uu___2 uu___3 uu___4) - } -let (make_solver_configs : - Prims.bool -> - Prims.bool -> - FStar_SMTEncoding_Env.env_t -> - FStar_SMTEncoding_Term.error_labels -> - FStar_SMTEncoding_Term.decl -> - FStar_Syntax_Syntax.term -> - FStar_SMTEncoding_Term.decl Prims.list -> - (query_settings Prims.list * FStar_Compiler_Hints.hint - FStar_Pervasives_Native.option)) - = - fun can_split -> - fun is_retry -> - fun env -> - fun all_labels -> - fun query -> - fun query_term -> - fun suffix -> - let uu___ = - let uu___1 = - match (env.FStar_SMTEncoding_Env.tcenv).FStar_TypeChecker_Env.qtbl_name_and_index - with - | (FStar_Pervasives_Native.None, uu___2) -> - failwith "No query name set!" - | (FStar_Pervasives_Native.Some (q, _typ, n), uu___2) -> - let uu___3 = FStar_Ident.string_of_lid q in - (uu___3, n) in - match uu___1 with - | (qname, index) -> - let rlimit = - let uu___2 = FStar_Options.z3_rlimit_factor () in - let uu___3 = FStar_Options.z3_rlimit () in - uu___2 * uu___3 in - let next_hint = get_hint_for qname index in - let default_settings = - let uu___2 = - FStar_TypeChecker_Env.get_range - env.FStar_SMTEncoding_Env.tcenv in - let uu___3 = FStar_Options.initial_fuel () in - let uu___4 = FStar_Options.initial_ifuel () in - { - query_env = env; - query_decl = query; - query_name = qname; - query_index = index; - query_range = uu___2; - query_fuel = uu___3; - query_ifuel = uu___4; - query_rlimit = rlimit; - query_hint = FStar_Pervasives_Native.None; - query_errors = []; - query_all_labels = all_labels; - query_suffix = suffix; - query_hash = - (match next_hint with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some - { FStar_Compiler_Hints.hint_name = uu___5; - FStar_Compiler_Hints.hint_index = uu___6; - FStar_Compiler_Hints.fuel = uu___7; - FStar_Compiler_Hints.ifuel = uu___8; - FStar_Compiler_Hints.unsat_core = uu___9; - FStar_Compiler_Hints.query_elapsed_time = - uu___10; - FStar_Compiler_Hints.hash = h;_} - -> h); - query_can_be_split_and_retried = can_split; - query_term - } in - (default_settings, next_hint) in - match uu___ with - | (default_settings, next_hint) -> - let use_hints_setting = - let uu___1 = - (use_hints ()) && - (FStar_Compiler_Util.is_some next_hint) in - if uu___1 - then - let uu___2 = FStar_Compiler_Util.must next_hint in - match uu___2 with - | { FStar_Compiler_Hints.hint_name = uu___3; - FStar_Compiler_Hints.hint_index = uu___4; - FStar_Compiler_Hints.fuel = i; - FStar_Compiler_Hints.ifuel = j; - FStar_Compiler_Hints.unsat_core = - FStar_Pervasives_Native.Some core; - FStar_Compiler_Hints.query_elapsed_time = uu___5; - FStar_Compiler_Hints.hash = h;_} -> - [{ - query_env = (default_settings.query_env); - query_decl = (default_settings.query_decl); - query_name = (default_settings.query_name); - query_index = (default_settings.query_index); - query_range = (default_settings.query_range); - query_fuel = i; - query_ifuel = j; - query_rlimit = (default_settings.query_rlimit); - query_hint = - (FStar_Pervasives_Native.Some core); - query_errors = (default_settings.query_errors); - query_all_labels = - (default_settings.query_all_labels); - query_suffix = (default_settings.query_suffix); - query_hash = (default_settings.query_hash); - query_can_be_split_and_retried = - (default_settings.query_can_be_split_and_retried); - query_term = (default_settings.query_term) - }] - else [] in - let initial_fuel_max_ifuel = - let uu___1 = - let uu___2 = FStar_Options.max_ifuel () in - let uu___3 = FStar_Options.initial_ifuel () in - uu___2 > uu___3 in - if uu___1 - then - let uu___2 = - let uu___3 = FStar_Options.max_ifuel () in - { - query_env = (default_settings.query_env); - query_decl = (default_settings.query_decl); - query_name = (default_settings.query_name); - query_index = (default_settings.query_index); - query_range = (default_settings.query_range); - query_fuel = (default_settings.query_fuel); - query_ifuel = uu___3; - query_rlimit = (default_settings.query_rlimit); - query_hint = (default_settings.query_hint); - query_errors = (default_settings.query_errors); - query_all_labels = - (default_settings.query_all_labels); - query_suffix = (default_settings.query_suffix); - query_hash = (default_settings.query_hash); - query_can_be_split_and_retried = - (default_settings.query_can_be_split_and_retried); - query_term = (default_settings.query_term) - } in - [uu___2] - else [] in - let half_max_fuel_max_ifuel = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Options.max_fuel () in - uu___3 / (Prims.of_int (2)) in - let uu___3 = FStar_Options.initial_fuel () in - uu___2 > uu___3 in - if uu___1 - then - let uu___2 = - let uu___3 = - let uu___4 = FStar_Options.max_fuel () in - uu___4 / (Prims.of_int (2)) in - let uu___4 = FStar_Options.max_ifuel () in - { - query_env = (default_settings.query_env); - query_decl = (default_settings.query_decl); - query_name = (default_settings.query_name); - query_index = (default_settings.query_index); - query_range = (default_settings.query_range); - query_fuel = uu___3; - query_ifuel = uu___4; - query_rlimit = (default_settings.query_rlimit); - query_hint = (default_settings.query_hint); - query_errors = (default_settings.query_errors); - query_all_labels = - (default_settings.query_all_labels); - query_suffix = (default_settings.query_suffix); - query_hash = (default_settings.query_hash); - query_can_be_split_and_retried = - (default_settings.query_can_be_split_and_retried); - query_term = (default_settings.query_term) - } in - [uu___2] - else [] in - let max_fuel_max_ifuel = - let uu___1 = - (let uu___2 = FStar_Options.max_fuel () in - let uu___3 = FStar_Options.initial_fuel () in - uu___2 > uu___3) && - (let uu___2 = FStar_Options.max_ifuel () in - let uu___3 = FStar_Options.initial_ifuel () in - uu___2 >= uu___3) in - if uu___1 - then - let uu___2 = - let uu___3 = FStar_Options.max_fuel () in - let uu___4 = FStar_Options.max_ifuel () in - { - query_env = (default_settings.query_env); - query_decl = (default_settings.query_decl); - query_name = (default_settings.query_name); - query_index = (default_settings.query_index); - query_range = (default_settings.query_range); - query_fuel = uu___3; - query_ifuel = uu___4; - query_rlimit = (default_settings.query_rlimit); - query_hint = (default_settings.query_hint); - query_errors = (default_settings.query_errors); - query_all_labels = - (default_settings.query_all_labels); - query_suffix = (default_settings.query_suffix); - query_hash = (default_settings.query_hash); - query_can_be_split_and_retried = - (default_settings.query_can_be_split_and_retried); - query_term = (default_settings.query_term) - } in - [uu___2] - else [] in - let cfgs = - if is_retry - then [default_settings] - else - FStar_Compiler_List.op_At use_hints_setting - (FStar_Compiler_List.op_At [default_settings] - (FStar_Compiler_List.op_At - initial_fuel_max_ifuel - (FStar_Compiler_List.op_At - half_max_fuel_max_ifuel max_fuel_max_ifuel))) in - (cfgs, next_hint) -let (__ask_solver : - query_settings Prims.list -> - (errors Prims.list, query_settings) FStar_Pervasives.either) - = - fun configs -> - let check_one_config config = - (let uu___1 = FStar_Options.z3_refresh () in - if uu___1 - then - FStar_SMTEncoding_Z3.refresh - (FStar_Pervasives_Native.Some - (((config.query_env).FStar_SMTEncoding_Env.tcenv).FStar_TypeChecker_Env.proof_ns)) - else ()); - (let uu___1 = with_fuel_and_diagnostics config [] in - let uu___2 = - let uu___3 = FStar_Compiler_Util.string_of_int config.query_index in - FStar_Compiler_Util.format2 "(%s, %s)" config.query_name uu___3 in - FStar_SMTEncoding_Z3.ask config.query_range config.query_hash - config.query_all_labels uu___1 uu___2 (used_hint config) - config.query_hint) in - fold_queries configs check_one_config process_result -let (ask_solver_quake : query_settings Prims.list -> answer) = - fun configs -> - let lo = FStar_Options.quake_lo () in - let hi = FStar_Options.quake_hi () in - let seed = FStar_Options.z3_seed () in - let default_settings = FStar_Compiler_List.hd configs in - let name = full_query_id default_settings in - let quaking = - (hi > Prims.int_one) && - (let uu___ = FStar_Options.retry () in Prims.op_Negation uu___) in - let quaking_or_retrying = hi > Prims.int_one in - let hi1 = if hi < Prims.int_one then Prims.int_one else hi in - let lo1 = - if lo < Prims.int_one - then Prims.int_one - else if lo > hi1 then hi1 else lo in - let run_one seed1 = - let uu___ = FStar_Options.z3_refresh () in - if uu___ - then - FStar_Options.with_saved_options - (fun uu___1 -> - FStar_Options.set_option "z3seed" (FStar_Options.Int seed1); - __ask_solver configs) - else __ask_solver configs in - let rec fold_nat' f acc lo2 hi2 = - if lo2 > hi2 - then acc - else - (let uu___1 = f acc lo2 in - fold_nat' f uu___1 (lo2 + Prims.int_one) hi2) in - let best_fuel = FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None in - let best_ifuel = FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None in - let maybe_improve r n = - let uu___ = FStar_Compiler_Effect.op_Bang r in - match uu___ with - | FStar_Pervasives_Native.None -> - FStar_Compiler_Effect.op_Colon_Equals r - (FStar_Pervasives_Native.Some n) - | FStar_Pervasives_Native.Some m -> - if n < m - then - FStar_Compiler_Effect.op_Colon_Equals r - (FStar_Pervasives_Native.Some n) - else () in - let uu___ = - fold_nat' - (fun uu___1 -> - fun n -> - match uu___1 with - | (nsucc, nfail, rs) -> - let uu___2 = - (let uu___3 = FStar_Options.quake_keep () in - Prims.op_Negation uu___3) && - ((nsucc >= lo1) || (nfail > (hi1 - lo1))) in - if uu___2 - then (nsucc, nfail, rs) - else - ((let uu___5 = - (quaking_or_retrying && - ((FStar_Options.interactive ()) || - (FStar_Compiler_Debug.any ()))) - && (n > Prims.int_zero) in - if uu___5 - then - let uu___6 = - if quaking - then - let uu___7 = - FStar_Compiler_Util.string_of_int nsucc in - FStar_Compiler_Util.format1 - "succeeded %s times and " uu___7 - else "" in - let uu___7 = - if quaking - then FStar_Compiler_Util.string_of_int nfail - else - (let uu___9 = - FStar_Compiler_Util.string_of_int nfail in - Prims.strcat uu___9 " times") in - let uu___8 = - FStar_Compiler_Util.string_of_int (hi1 - n) in - FStar_Compiler_Util.print5 - "%s: so far query %s %sfailed %s (%s runs remain)\n" - (if quaking then "Quake" else "Retry") name uu___6 - uu___7 uu___8 - else ()); - (let r = run_one (seed + n) in - let uu___5 = - match r with - | FStar_Pervasives.Inr cfg -> - (maybe_improve best_fuel cfg.query_fuel; - maybe_improve best_ifuel cfg.query_ifuel; - ((nsucc + Prims.int_one), nfail)) - | uu___6 -> (nsucc, (nfail + Prims.int_one)) in - match uu___5 with - | (nsucc1, nfail1) -> (nsucc1, nfail1, (r :: rs))))) - (Prims.int_zero, Prims.int_zero, []) Prims.int_zero - (hi1 - Prims.int_one) in - match uu___ with - | (nsuccess, nfailures, rs) -> - let total_ran = nsuccess + nfailures in - (if quaking - then - (let fuel_msg = - let uu___2 = - let uu___3 = FStar_Compiler_Effect.op_Bang best_fuel in - let uu___4 = FStar_Compiler_Effect.op_Bang best_ifuel in - (uu___3, uu___4) in - match uu___2 with - | (FStar_Pervasives_Native.Some f, FStar_Pervasives_Native.Some - i) -> - let uu___3 = FStar_Compiler_Util.string_of_int f in - let uu___4 = FStar_Compiler_Util.string_of_int i in - FStar_Compiler_Util.format2 - " (best fuel=%s, best ifuel=%s)" uu___3 uu___4 - | (uu___3, uu___4) -> "" in - let uu___2 = FStar_Compiler_Util.string_of_int nsuccess in - let uu___3 = FStar_Compiler_Util.string_of_int total_ran in - FStar_Compiler_Util.print5 - "Quake: query %s succeeded %s/%s times%s%s\n" name uu___2 - uu___3 (if total_ran < hi1 then " (early finish)" else "") - fuel_msg) - else (); - (let all_errs = - FStar_Compiler_List.concatMap - (fun uu___2 -> - match uu___2 with - | FStar_Pervasives.Inr uu___3 -> [] - | FStar_Pervasives.Inl es -> [es]) rs in - { - ok = (nsuccess >= lo1); - cache_hit = false; - quaking; - quaking_or_retrying; - lo = lo1; - hi = hi1; - nsuccess; - total_ran; - tried_recovery = false; - errs = all_errs - })) -type recovery_hammer = - | IncreaseRLimit of Prims.int - | RestartAnd of recovery_hammer -let (uu___is_IncreaseRLimit : recovery_hammer -> Prims.bool) = - fun projectee -> - match projectee with | IncreaseRLimit _0 -> true | uu___ -> false -let (__proj__IncreaseRLimit__item___0 : recovery_hammer -> Prims.int) = - fun projectee -> match projectee with | IncreaseRLimit _0 -> _0 -let (uu___is_RestartAnd : recovery_hammer -> Prims.bool) = - fun projectee -> - match projectee with | RestartAnd _0 -> true | uu___ -> false -let (__proj__RestartAnd__item___0 : recovery_hammer -> recovery_hammer) = - fun projectee -> match projectee with | RestartAnd _0 -> _0 -let rec (pp_hammer : recovery_hammer -> FStar_Pprint.document) = - fun h -> - match h with - | IncreaseRLimit factor -> - let uu___ = FStar_Errors_Msg.text "increasing its rlimit by" in - let uu___1 = - let uu___2 = FStar_Class_PP.pp FStar_Class_PP.pp_int factor in - let uu___3 = FStar_Pprint.doc_of_string "x" in - FStar_Pprint.op_Hat_Hat uu___2 uu___3 in - FStar_Pprint.op_Hat_Slash_Hat uu___ uu___1 - | RestartAnd h1 -> - let uu___ = FStar_Errors_Msg.text "restarting the solver and" in - let uu___1 = pp_hammer h1 in - FStar_Pprint.op_Hat_Slash_Hat uu___ uu___1 -let (ask_solver_recover : query_settings Prims.list -> answer) = - fun configs -> - let uu___ = FStar_Options.proof_recovery () in - if uu___ - then - let r = ask_solver_quake configs in - (if r.ok - then r - else - (let restarted = FStar_Compiler_Util.mk_ref false in - let cfg = FStar_Compiler_List.last configs in - (let uu___3 = - let uu___4 = - FStar_Errors_Msg.text - "This query failed to be solved. Will now retry with higher rlimits due to --proof_recovery." in - [uu___4] in - FStar_Errors.diag FStar_Class_HasRange.hasRange_range - cfg.query_range () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___3)); - (let try_factor n = - (let uu___4 = - let uu___5 = - let uu___6 = - FStar_Errors_Msg.text "Retrying query with rlimit factor" in - let uu___7 = FStar_Class_PP.pp FStar_Class_PP.pp_int n in - FStar_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in - [uu___5] in - FStar_Errors.diag FStar_Class_HasRange.hasRange_range - cfg.query_range () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___4)); - (let cfg1 = - { - query_env = (cfg.query_env); - query_decl = (cfg.query_decl); - query_name = (cfg.query_name); - query_index = (cfg.query_index); - query_range = (cfg.query_range); - query_fuel = (cfg.query_fuel); - query_ifuel = (cfg.query_ifuel); - query_rlimit = (n * cfg.query_rlimit); - query_hint = (cfg.query_hint); - query_errors = (cfg.query_errors); - query_all_labels = (cfg.query_all_labels); - query_suffix = (cfg.query_suffix); - query_hash = (cfg.query_hash); - query_can_be_split_and_retried = - (cfg.query_can_be_split_and_retried); - query_term = (cfg.query_term) - } in - ask_solver_quake [cfg1]) in - let rec try_hammer h = - match h with - | IncreaseRLimit factor -> try_factor factor - | RestartAnd h1 -> - ((let uu___4 = - let uu___5 = - FStar_Errors_Msg.text "Trying a solver restart" in - [uu___5] in - FStar_Errors.diag FStar_Class_HasRange.hasRange_range - cfg.query_range () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___4)); - (((cfg.query_env).FStar_SMTEncoding_Env.tcenv).FStar_TypeChecker_Env.solver).FStar_TypeChecker_Env.refresh - (FStar_Pervasives_Native.Some - (((cfg.query_env).FStar_SMTEncoding_Env.tcenv).FStar_TypeChecker_Env.proof_ns)); - try_hammer h1) in - let rec aux hammers = - match hammers with - | [] -> - { - ok = (r.ok); - cache_hit = (r.cache_hit); - quaking = (r.quaking); - quaking_or_retrying = (r.quaking_or_retrying); - lo = (r.lo); - hi = (r.hi); - nsuccess = (r.nsuccess); - total_ran = (r.total_ran); - tried_recovery = true; - errs = (r.errs) - } - | h::hs -> - let r1 = try_hammer h in - if r1.ok - then - ((let uu___4 = - let uu___5 = - let uu___6 = - FStar_Errors_Msg.text - "This query succeeded after " in - let uu___7 = pp_hammer h in - FStar_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in - let uu___6 = - let uu___7 = - FStar_Errors_Msg.text - "Increase the rlimit in the file or simplify the proof. This is only succeeding due to --proof_recovery being given." in - [uu___7] in - uu___5 :: uu___6 in - FStar_Errors.log_issue - FStar_Class_HasRange.hasRange_range cfg.query_range - FStar_Errors_Codes.Warning_ProofRecovery () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___4)); - r1) - else aux hs in - aux - [IncreaseRLimit (Prims.of_int (2)); - IncreaseRLimit (Prims.of_int (4)); - IncreaseRLimit (Prims.of_int (8)); - RestartAnd (IncreaseRLimit (Prims.of_int (8)))]))) - else ask_solver_quake configs -let (failing_query_ctr : Prims.int FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref Prims.int_zero -let (maybe_save_failing_query : - FStar_SMTEncoding_Env.env_t -> query_settings -> unit) = - fun env -> - fun qs -> - (let uu___1 = FStar_Options.log_failing_queries () in - if uu___1 - then - let mod1 = - let uu___2 = - FStar_TypeChecker_Env.current_module - env.FStar_SMTEncoding_Env.tcenv in - FStar_Class_Show.show FStar_Ident.showable_lident uu___2 in - let n = - (let uu___3 = - let uu___4 = FStar_Compiler_Effect.op_Bang failing_query_ctr in - uu___4 + Prims.int_one in - FStar_Compiler_Effect.op_Colon_Equals failing_query_ctr uu___3); - FStar_Compiler_Effect.op_Bang failing_query_ctr in - let file_name = - let uu___2 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) n in - FStar_Compiler_Util.format2 "failedQueries-%s-%s.smt2" mod1 uu___2 in - let query_str = - let uu___2 = with_fuel_and_diagnostics qs [] in - let uu___3 = - let uu___4 = FStar_Compiler_Util.string_of_int qs.query_index in - FStar_Compiler_Util.format2 "(%s, %s)" qs.query_name uu___4 in - FStar_SMTEncoding_Z3.ask_text qs.query_range qs.query_hash - qs.query_all_labels uu___2 uu___3 qs.query_hint in - FStar_Compiler_Util.write_file file_name query_str - else ()); - (let uu___2 = FStar_Compiler_Effect.op_Bang dbg_SMTFail in - if uu___2 - then - let uu___3 = - let uu___4 = FStar_Errors_Msg.text "This query failed:" in - let uu___5 = - let uu___6 = - FStar_Class_PP.pp FStar_Syntax_Print.pretty_term qs.query_term in - [uu___6] in - uu___4 :: uu___5 in - FStar_Errors.diag FStar_Class_HasRange.hasRange_range qs.query_range - () (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___3) - else ()) -let (ask_solver : - FStar_SMTEncoding_Env.env_t -> - query_settings Prims.list -> - FStar_Compiler_Hints.hint FStar_Pervasives_Native.option -> - (query_settings Prims.list * answer)) - = - fun env -> - fun configs -> - fun next_hint -> - let default_settings = FStar_Compiler_List.hd configs in - let skip = - ((env.FStar_SMTEncoding_Env.tcenv).FStar_TypeChecker_Env.admit || - (FStar_TypeChecker_Env.too_early_in_prims - env.FStar_SMTEncoding_Env.tcenv)) - || - (let uu___ = FStar_Options.admit_except () in - match uu___ with - | FStar_Pervasives_Native.Some id -> - if FStar_Compiler_Util.starts_with id "(" - then - let uu___1 = full_query_id default_settings in - uu___1 <> id - else default_settings.query_name <> id - | FStar_Pervasives_Native.None -> false) in - let ans = - if skip - then - ((let uu___1 = - (FStar_Options.record_hints ()) && - (FStar_Compiler_Util.is_some next_hint) in - if uu___1 - then - let uu___2 = FStar_Compiler_Util.must next_hint in - store_hint uu___2 - else ()); - ans_ok) - else - (let ans1 = ask_solver_recover configs in - let cfg = FStar_Compiler_List.last configs in - if Prims.op_Negation ans1.ok - then maybe_save_failing_query env cfg - else (); - ans1) in - (configs, ans) -let (report : FStar_TypeChecker_Env.env -> query_settings -> answer -> unit) - = - fun env -> - fun default_settings -> - fun a -> - let nsuccess = a.nsuccess in - let name = full_query_id default_settings in - let lo = a.lo in - let hi = a.hi in - let total_ran = a.total_ran in - let all_errs = a.errs in - let quaking_or_retrying = a.quaking_or_retrying in - let quaking = a.quaking in - if nsuccess < lo - then - let uu___ = - quaking_or_retrying && - (let uu___1 = FStar_Options.query_stats () in - Prims.op_Negation uu___1) in - (if uu___ - then - let errors_to_report1 errs = - errors_to_report a.tried_recovery - { - query_env = (default_settings.query_env); - query_decl = (default_settings.query_decl); - query_name = (default_settings.query_name); - query_index = (default_settings.query_index); - query_range = (default_settings.query_range); - query_fuel = (default_settings.query_fuel); - query_ifuel = (default_settings.query_ifuel); - query_rlimit = (default_settings.query_rlimit); - query_hint = (default_settings.query_hint); - query_errors = errs; - query_all_labels = (default_settings.query_all_labels); - query_suffix = (default_settings.query_suffix); - query_hash = (default_settings.query_hash); - query_can_be_split_and_retried = - (default_settings.query_can_be_split_and_retried); - query_term = (default_settings.query_term) - } in - let errs = FStar_Compiler_List.map errors_to_report1 all_errs in - let errs1 = collect_dups (FStar_Compiler_List.flatten errs) in - let errs2 = - FStar_Compiler_List.map - (fun uu___1 -> - match uu___1 with - | ((e, m, r, ctx), n) -> - let m1 = - if n > Prims.int_one - then - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Compiler_Util.string_of_int n in - FStar_Compiler_Util.format1 - "Repeated %s times" uu___5 in - FStar_Pprint.doc_of_string uu___4 in - [uu___3] in - FStar_Compiler_List.op_At m uu___2 - else m in - (e, m1, r, ctx)) errs1 in - (FStar_Errors.add_errors errs2; - if quaking - then - (let rng = - match FStar_Pervasives_Native.fst - env.FStar_TypeChecker_Env.qtbl_name_and_index - with - | FStar_Pervasives_Native.Some (l, uu___2, uu___3) -> - FStar_Ident.range_of_lid l - | uu___2 -> FStar_Compiler_Range_Type.dummyRange in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Compiler_Util.string_of_int nsuccess in - let uu___7 = - FStar_Compiler_Util.string_of_int total_ran in - let uu___8 = FStar_Compiler_Util.string_of_int lo in - let uu___9 = FStar_Compiler_Util.string_of_int hi in - FStar_Compiler_Util.format6 - "Query %s failed the quake test, %s out of %s attempts succeded, but the threshold was %s out of %s%s" - name uu___6 uu___7 uu___8 uu___9 - (if total_ran < hi then " (early abort)" else "") in - FStar_Errors_Msg.text uu___5 in - [uu___4] in - (FStar_Errors_Codes.Error_QuakeFailed, uu___3) in - FStar_TypeChecker_Err.log_issue env rng uu___2) - else ()) - else - (let report1 errs = - report_errors a.tried_recovery - { - query_env = (default_settings.query_env); - query_decl = (default_settings.query_decl); - query_name = (default_settings.query_name); - query_index = (default_settings.query_index); - query_range = (default_settings.query_range); - query_fuel = (default_settings.query_fuel); - query_ifuel = (default_settings.query_ifuel); - query_rlimit = (default_settings.query_rlimit); - query_hint = (default_settings.query_hint); - query_errors = errs; - query_all_labels = (default_settings.query_all_labels); - query_suffix = (default_settings.query_suffix); - query_hash = (default_settings.query_hash); - query_can_be_split_and_retried = - (default_settings.query_can_be_split_and_retried); - query_term = (default_settings.query_term) - } in - FStar_Compiler_List.iter report1 all_errs)) - else () -type solver_cfg = - { - seed: Prims.int ; - cliopt: Prims.string Prims.list ; - smtopt: Prims.string Prims.list ; - facts: (Prims.string Prims.list * Prims.bool) Prims.list ; - valid_intro: Prims.bool ; - valid_elim: Prims.bool ; - z3version: Prims.string ; - context_pruning: Prims.bool } -let (__proj__Mksolver_cfg__item__seed : solver_cfg -> Prims.int) = - fun projectee -> - match projectee with - | { seed; cliopt; smtopt; facts; valid_intro; valid_elim; z3version; - context_pruning;_} -> seed -let (__proj__Mksolver_cfg__item__cliopt : - solver_cfg -> Prims.string Prims.list) = - fun projectee -> - match projectee with - | { seed; cliopt; smtopt; facts; valid_intro; valid_elim; z3version; - context_pruning;_} -> cliopt -let (__proj__Mksolver_cfg__item__smtopt : - solver_cfg -> Prims.string Prims.list) = - fun projectee -> - match projectee with - | { seed; cliopt; smtopt; facts; valid_intro; valid_elim; z3version; - context_pruning;_} -> smtopt -let (__proj__Mksolver_cfg__item__facts : - solver_cfg -> (Prims.string Prims.list * Prims.bool) Prims.list) = - fun projectee -> - match projectee with - | { seed; cliopt; smtopt; facts; valid_intro; valid_elim; z3version; - context_pruning;_} -> facts -let (__proj__Mksolver_cfg__item__valid_intro : solver_cfg -> Prims.bool) = - fun projectee -> - match projectee with - | { seed; cliopt; smtopt; facts; valid_intro; valid_elim; z3version; - context_pruning;_} -> valid_intro -let (__proj__Mksolver_cfg__item__valid_elim : solver_cfg -> Prims.bool) = - fun projectee -> - match projectee with - | { seed; cliopt; smtopt; facts; valid_intro; valid_elim; z3version; - context_pruning;_} -> valid_elim -let (__proj__Mksolver_cfg__item__z3version : solver_cfg -> Prims.string) = - fun projectee -> - match projectee with - | { seed; cliopt; smtopt; facts; valid_intro; valid_elim; z3version; - context_pruning;_} -> z3version -let (__proj__Mksolver_cfg__item__context_pruning : solver_cfg -> Prims.bool) - = - fun projectee -> - match projectee with - | { seed; cliopt; smtopt; facts; valid_intro; valid_elim; z3version; - context_pruning;_} -> context_pruning -let (_last_cfg : - solver_cfg FStar_Pervasives_Native.option FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None -let (get_cfg : FStar_TypeChecker_Env.env -> solver_cfg) = - fun env -> - let uu___ = FStar_Options.z3_seed () in - let uu___1 = FStar_Options.z3_cliopt () in - let uu___2 = FStar_Options.z3_smtopt () in - let uu___3 = FStar_Options.smtencoding_valid_intro () in - let uu___4 = FStar_Options.smtencoding_valid_elim () in - let uu___5 = FStar_Options.z3_version () in - let uu___6 = - let uu___7 = FStar_Options_Ext.get "context_pruning" in uu___7 <> "" in - { - seed = uu___; - cliopt = uu___1; - smtopt = uu___2; - facts = (env.FStar_TypeChecker_Env.proof_ns); - valid_intro = uu___3; - valid_elim = uu___4; - z3version = uu___5; - context_pruning = uu___6 - } -let (save_cfg : FStar_TypeChecker_Env.env -> unit) = - fun env -> - let uu___ = - let uu___1 = get_cfg env in FStar_Pervasives_Native.Some uu___1 in - FStar_Compiler_Effect.op_Colon_Equals _last_cfg uu___ -let (maybe_refresh_solver : FStar_TypeChecker_Env.env -> unit) = - fun env -> - let uu___ = FStar_Compiler_Effect.op_Bang _last_cfg in - match uu___ with - | FStar_Pervasives_Native.None -> save_cfg env - | FStar_Pervasives_Native.Some cfg -> - let uu___1 = let uu___2 = get_cfg env in cfg <> uu___2 in - if uu___1 - then - (save_cfg env; - FStar_SMTEncoding_Z3.refresh - (FStar_Pervasives_Native.Some - (env.FStar_TypeChecker_Env.proof_ns))) - else () -let finally : 'a . (unit -> unit) -> (unit -> 'a) -> 'a = - fun h -> - fun f -> - let r = - try (fun uu___ -> match () with | () -> f ()) () - with | uu___ -> (h (); FStar_Compiler_Effect.raise uu___) in - h (); r -let (encode_and_ask : - Prims.bool -> - Prims.bool -> - (unit -> Prims.string) FStar_Pervasives_Native.option -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> (query_settings Prims.list * answer)) - = - fun can_split -> - fun is_retry -> - fun use_env_msg -> - fun tcenv -> - fun q -> - let do1 uu___ = - maybe_refresh_solver tcenv; - (let msg = - let uu___2 = - let uu___3 = FStar_TypeChecker_Env.get_range tcenv in - FStar_Compiler_Range_Ops.string_of_range uu___3 in - FStar_Compiler_Util.format1 "Starting query at %s" uu___2 in - FStar_SMTEncoding_Encode.push_encoding_state msg; - (let uu___3 = - FStar_SMTEncoding_Encode.encode_query use_env_msg tcenv q in - match uu___3 with - | (prefix, labels, qry, suffix) -> - (FStar_SMTEncoding_Z3.start_query msg prefix qry; - (let finish_query uu___5 = - let msg1 = - let uu___6 = - let uu___7 = - FStar_TypeChecker_Env.get_range tcenv in - FStar_Compiler_Range_Ops.string_of_range uu___7 in - FStar_Compiler_Util.format1 "Ending query at %s" - uu___6 in - FStar_SMTEncoding_Encode.pop_encoding_state msg1; - FStar_SMTEncoding_Z3.finish_query msg1 in - finally finish_query - (fun uu___5 -> - let tcenv1 = - FStar_TypeChecker_Env.incr_query_index tcenv in - match qry with - | FStar_SMTEncoding_Term.Assume - { - FStar_SMTEncoding_Term.assumption_term = - { - FStar_SMTEncoding_Term.tm = - FStar_SMTEncoding_Term.App - (FStar_SMTEncoding_Term.FalseOp, - uu___6); - FStar_SMTEncoding_Term.freevars = uu___7; - FStar_SMTEncoding_Term.rng = uu___8;_}; - FStar_SMTEncoding_Term.assumption_caption = - uu___9; - FStar_SMTEncoding_Term.assumption_name = - uu___10; - FStar_SMTEncoding_Term.assumption_fact_ids = - uu___11; - FStar_SMTEncoding_Term.assumption_free_names - = uu___12;_} - -> ([], ans_ok) - | uu___6 when tcenv1.FStar_TypeChecker_Env.admit - -> ([], ans_ok) - | FStar_SMTEncoding_Term.Assume uu___6 -> - ((let uu___8 = - (is_retry || - (let uu___9 = - FStar_Options.split_queries () in - uu___9 = FStar_Options.Always)) - && (FStar_Compiler_Debug.any ()) in - if uu___8 - then - let n = FStar_Compiler_List.length labels in - (if n <> Prims.int_one - then - let uu___9 = - FStar_TypeChecker_Env.get_range - tcenv1 in - let uu___10 = - let uu___11 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - q in - let uu___12 = - FStar_SMTEncoding_Term.declToSmt "" - qry in - let uu___13 = - FStar_Compiler_Util.string_of_int n in - FStar_Compiler_Util.format3 - "Encoded split query %s\nto %s\nwith %s labels" - uu___11 uu___12 uu___13 in - FStar_Errors.diag - FStar_Class_HasRange.hasRange_range - uu___9 () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___10) - else ()) - else ()); - (let env = - FStar_SMTEncoding_Encode.get_current_env - tcenv1 in - let uu___8 = - make_solver_configs can_split is_retry env - labels qry q suffix in - match uu___8 with - | (configs, next_hint) -> - ask_solver env configs next_hint)) - | uu___6 -> failwith "Impossible"))))) in - let uu___ = - FStar_SMTEncoding_Solver_Cache.try_find_query_cache tcenv q in - if uu___ - then - ([], - { - ok = (ans_ok.ok); - cache_hit = true; - quaking = (ans_ok.quaking); - quaking_or_retrying = (ans_ok.quaking_or_retrying); - lo = (ans_ok.lo); - hi = (ans_ok.hi); - nsuccess = (ans_ok.nsuccess); - total_ran = (ans_ok.total_ran); - tried_recovery = (ans_ok.tried_recovery); - errs = (ans_ok.errs) - }) - else - (let uu___2 = do1 () in - match uu___2 with - | (cfgs, ans) -> - (if ans.ok - then - FStar_SMTEncoding_Solver_Cache.query_cache_add tcenv q - else (); - (cfgs, ans))) -let (do_solve : - Prims.bool -> - Prims.bool -> - (unit -> Prims.string) FStar_Pervasives_Native.option -> - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.term -> unit) - = - fun can_split -> - fun is_retry -> - fun use_env_msg -> - fun tcenv -> - fun q -> - let ans_opt = - try - (fun uu___ -> - match () with - | () -> - let uu___1 = - encode_and_ask can_split is_retry use_env_msg tcenv - q in - FStar_Pervasives_Native.Some uu___1) () - with - | FStar_SMTEncoding_Env.Inner_let_rec names -> - ((let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Compiler_List.map - FStar_Pervasives_Native.fst names in - FStar_Compiler_String.concat "," uu___7 in - FStar_Compiler_Util.format1 - "Could not encode the query since F* does not support precise smtencoding of inner let-recs yet (in this case %s)" - uu___6 in - FStar_Errors_Msg.text uu___5 in - [uu___4] in - (FStar_Errors_Codes.Error_NonTopRecFunctionNotFullyEncoded, - uu___3) in - FStar_TypeChecker_Err.log_issue tcenv - tcenv.FStar_TypeChecker_Env.range uu___2); - FStar_Pervasives_Native.None) in - match ans_opt with - | FStar_Pervasives_Native.Some (default_settings::uu___, ans) - when Prims.op_Negation ans.ok -> - report tcenv default_settings ans - | FStar_Pervasives_Native.Some (uu___, ans) when ans.ok -> () - | FStar_Pervasives_Native.Some ([], ans) when - Prims.op_Negation ans.ok -> - failwith "impossible: bad answer from encode_and_ask" - | FStar_Pervasives_Native.None -> () -let (split_and_solve : - Prims.bool -> - (unit -> Prims.string) FStar_Pervasives_Native.option -> - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.term -> unit) - = - fun retrying -> - fun use_env_msg -> - fun tcenv -> - fun q -> - (let uu___1 = - (FStar_Compiler_Debug.any ()) || (FStar_Options.query_stats ()) in - if uu___1 - then - let range = - let uu___2 = - let uu___3 = - let uu___4 = FStar_TypeChecker_Env.get_range tcenv in - FStar_Compiler_Range_Ops.string_of_range uu___4 in - Prims.strcat uu___3 ")" in - Prims.strcat "(" uu___2 in - FStar_Compiler_Util.print2 - "%s\tQuery-stats splitting query because %s\n" range - (if retrying - then "retrying failed query" - else "--split_queries is always") - else ()); - (let goals = - let uu___1 = FStar_TypeChecker_Env.split_smt_query tcenv q in - match uu___1 with - | FStar_Pervasives_Native.None -> - failwith "Impossible: split_query callback is not set" - | FStar_Pervasives_Native.Some goals1 -> goals1 in - FStar_Compiler_List.iter - (fun uu___2 -> - match uu___2 with - | (env, goal) -> do_solve false retrying use_env_msg env goal) - goals; - (let uu___2 = - (let uu___3 = FStar_Errors.get_err_count () in - uu___3 = Prims.int_zero) && retrying in - if uu___2 - then - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Errors_Msg.text - "The verification condition succeeded after splitting it to localize potential errors, although the original non-split verification condition failed. If you want to rely on splitting queries for verifying your program please use the '--split_queries always' option rather than relying on it implicitly." in - [uu___5] in - (FStar_Errors_Codes.Warning_SplitAndRetryQueries, uu___4) in - FStar_TypeChecker_Err.log_issue tcenv - tcenv.FStar_TypeChecker_Env.range uu___3 - else ())) -let disable_quake_for : 'a . (unit -> 'a) -> 'a = - fun f -> - FStar_Options.with_saved_options - (fun uu___ -> - FStar_Options.set_option "quake_hi" - (FStar_Options.Int Prims.int_one); - f ()) -let (do_solve_maybe_split : - (unit -> Prims.string) FStar_Pervasives_Native.option -> - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.term -> unit) - = - fun use_env_msg -> - fun tcenv -> - fun q -> - if tcenv.FStar_TypeChecker_Env.admit - then () - else - (let uu___1 = FStar_Options.split_queries () in - match uu___1 with - | FStar_Options.No -> do_solve false false use_env_msg tcenv q - | FStar_Options.OnFailure -> - let can_split = - let uu___2 = - let uu___3 = FStar_Options.quake_hi () in - uu___3 > Prims.int_one in - Prims.op_Negation uu___2 in - (try - (fun uu___2 -> - match () with - | () -> do_solve can_split false use_env_msg tcenv q) () - with - | SplitQueryAndRetry -> - split_and_solve true use_env_msg tcenv q) - | FStar_Options.Always -> - split_and_solve false use_env_msg tcenv q) -let (solve : - (unit -> Prims.string) FStar_Pervasives_Native.option -> - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.term -> unit) - = - fun use_env_msg -> - fun tcenv -> - fun q -> - let uu___ = FStar_Options.no_smt () in - if uu___ - then - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Errors_Msg.text - "A query could not be solved internally, and --no_smt was given." in - let uu___4 = - let uu___5 = - let uu___6 = FStar_Errors_Msg.text "Query = " in - let uu___7 = - FStar_Class_PP.pp FStar_Syntax_Print.pretty_term q in - FStar_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in - [uu___5] in - uu___3 :: uu___4 in - (FStar_Errors_Codes.Error_NoSMTButNeeded, uu___2) in - FStar_TypeChecker_Err.log_issue tcenv - tcenv.FStar_TypeChecker_Env.range uu___1 - else - (let uu___2 = - let uu___3 = - let uu___4 = FStar_TypeChecker_Env.current_module tcenv in - FStar_Ident.string_of_lid uu___4 in - FStar_Pervasives_Native.Some uu___3 in - FStar_Profiling.profile - (fun uu___3 -> do_solve_maybe_split use_env_msg tcenv q) uu___2 - "FStar.SMTEncoding.solve_top_level") -let (solve_sync : - (unit -> Prims.string) FStar_Pervasives_Native.option -> - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.term -> answer) - = - fun use_env_msg -> - fun tcenv -> - fun q -> - let uu___ = FStar_Options.no_smt () in - if uu___ - then ans_fail - else - (let go uu___2 = - (let uu___4 = FStar_Compiler_Effect.op_Bang dbg_SMTQuery in - if uu___4 - then - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Errors_Msg.text - "Running synchronous SMT query. Q =" in - let uu___8 = - FStar_Class_PP.pp FStar_Syntax_Print.pretty_term q in - FStar_Pprint.prefix (Prims.of_int (2)) Prims.int_one - uu___7 uu___8 in - [uu___6] in - FStar_Errors.diag FStar_Class_HasRange.hasRange_range - q.FStar_Syntax_Syntax.pos () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___5) - else ()); - (let uu___4 = - disable_quake_for - (fun uu___5 -> - encode_and_ask false false use_env_msg tcenv q) in - match uu___4 with | (_cfgs, ans) -> ans) in - let uu___2 = - let uu___3 = - let uu___4 = FStar_TypeChecker_Env.current_module tcenv in - FStar_Ident.string_of_lid uu___4 in - FStar_Pervasives_Native.Some uu___3 in - FStar_Profiling.profile go uu___2 - "FStar.SMTEncoding.solve_sync_top_level") -let (solve_sync_bool : - (unit -> Prims.string) FStar_Pervasives_Native.option -> - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.term -> Prims.bool) - = - fun use_env_msg -> - fun tcenv -> fun q -> let ans = solve_sync use_env_msg tcenv q in ans.ok -let (snapshot : Prims.string -> ((Prims.int * Prims.int * Prims.int) * unit)) - = - fun msg -> - let uu___ = FStar_SMTEncoding_Encode.snapshot_encoding msg in - match uu___ with - | (v0, v1) -> - let v2 = FStar_SMTEncoding_Z3.snapshot msg in ((v0, v1, v2), ()) -let (rollback : - Prims.string -> - (Prims.int * Prims.int * Prims.int) FStar_Pervasives_Native.option -> - unit) - = - fun msg -> - fun tok -> - let uu___ = - match tok with - | FStar_Pervasives_Native.None -> - (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) - | FStar_Pervasives_Native.Some (v0, v1, v2) -> - ((FStar_Pervasives_Native.Some (v0, v1)), - (FStar_Pervasives_Native.Some v2)) in - match uu___ with - | (tok01, tok2) -> - (FStar_SMTEncoding_Encode.rollback_encoding msg tok01; - FStar_SMTEncoding_Z3.rollback msg tok2) -let (solver : FStar_TypeChecker_Env.solver_t) = - { - FStar_TypeChecker_Env.init = - (fun e -> save_cfg e; FStar_SMTEncoding_Encode.init e); - FStar_TypeChecker_Env.snapshot = snapshot; - FStar_TypeChecker_Env.rollback = rollback; - FStar_TypeChecker_Env.encode_sig = FStar_SMTEncoding_Encode.encode_sig; - FStar_TypeChecker_Env.preprocess = - (fun e -> - fun g -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Options.peek () in (e, g, uu___2) in - [uu___1] in - (false, uu___)); - FStar_TypeChecker_Env.spinoff_strictly_positive_goals = - FStar_Pervasives_Native.None; - FStar_TypeChecker_Env.handle_smt_goal = (fun e -> fun g -> [(e, g)]); - FStar_TypeChecker_Env.solve = solve; - FStar_TypeChecker_Env.solve_sync = solve_sync_bool; - FStar_TypeChecker_Env.finish = (fun uu___ -> ()); - FStar_TypeChecker_Env.refresh = FStar_SMTEncoding_Z3.refresh - } -let (dummy : FStar_TypeChecker_Env.solver_t) = - { - FStar_TypeChecker_Env.init = (fun uu___ -> ()); - FStar_TypeChecker_Env.snapshot = - (fun uu___ -> ((Prims.int_zero, Prims.int_zero, Prims.int_zero), ())); - FStar_TypeChecker_Env.rollback = (fun uu___ -> fun uu___1 -> ()); - FStar_TypeChecker_Env.encode_sig = (fun uu___ -> fun uu___1 -> ()); - FStar_TypeChecker_Env.preprocess = - (fun e -> - fun g -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Options.peek () in (e, g, uu___2) in - [uu___1] in - (false, uu___)); - FStar_TypeChecker_Env.spinoff_strictly_positive_goals = - FStar_Pervasives_Native.None; - FStar_TypeChecker_Env.handle_smt_goal = (fun e -> fun g -> [(e, g)]); - FStar_TypeChecker_Env.solve = - (fun uu___ -> fun uu___1 -> fun uu___2 -> ()); - FStar_TypeChecker_Env.solve_sync = - (fun uu___ -> fun uu___1 -> fun uu___2 -> false); - FStar_TypeChecker_Env.finish = (fun uu___ -> ()); - FStar_TypeChecker_Env.refresh = (fun uu___ -> ()) - } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_SolverState.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_SolverState.ml deleted file mode 100644 index 9cd42004663..00000000000 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_SolverState.ml +++ /dev/null @@ -1,808 +0,0 @@ -open Prims -type using_facts_from_setting = - (Prims.string Prims.list * Prims.bool) Prims.list -type decl_name_set = Prims.bool FStar_Compiler_Util.psmap -let (empty_decl_names : Prims.bool FStar_Compiler_Util.psmap) = - FStar_Compiler_Util.psmap_empty () -let (decl_names_contains : Prims.string -> decl_name_set -> Prims.bool) = - fun x -> - fun s -> - let uu___ = FStar_Compiler_Util.psmap_try_find s x in - FStar_Pervasives_Native.uu___is_Some uu___ -let (add_name : - Prims.string -> decl_name_set -> Prims.bool FStar_Compiler_Util.psmap) = - fun x -> fun s -> FStar_Compiler_Util.psmap_add s x true -type decls_at_level = - { - pruning_state: FStar_SMTEncoding_Pruning.pruning_state ; - given_decl_names: decl_name_set ; - all_decls_at_level_rev: FStar_SMTEncoding_Term.decl Prims.list Prims.list ; - given_some_decls: Prims.bool ; - to_flush_rev: FStar_SMTEncoding_Term.decl Prims.list Prims.list ; - named_assumptions: - FStar_SMTEncoding_Term.assumption FStar_Compiler_Util.psmap ; - pruning_roots: - FStar_SMTEncoding_Term.decl Prims.list FStar_Pervasives_Native.option } -let (__proj__Mkdecls_at_level__item__pruning_state : - decls_at_level -> FStar_SMTEncoding_Pruning.pruning_state) = - fun projectee -> - match projectee with - | { pruning_state; given_decl_names; all_decls_at_level_rev; - given_some_decls; to_flush_rev; named_assumptions; pruning_roots;_} - -> pruning_state -let (__proj__Mkdecls_at_level__item__given_decl_names : - decls_at_level -> decl_name_set) = - fun projectee -> - match projectee with - | { pruning_state; given_decl_names; all_decls_at_level_rev; - given_some_decls; to_flush_rev; named_assumptions; pruning_roots;_} - -> given_decl_names -let (__proj__Mkdecls_at_level__item__all_decls_at_level_rev : - decls_at_level -> FStar_SMTEncoding_Term.decl Prims.list Prims.list) = - fun projectee -> - match projectee with - | { pruning_state; given_decl_names; all_decls_at_level_rev; - given_some_decls; to_flush_rev; named_assumptions; pruning_roots;_} - -> all_decls_at_level_rev -let (__proj__Mkdecls_at_level__item__given_some_decls : - decls_at_level -> Prims.bool) = - fun projectee -> - match projectee with - | { pruning_state; given_decl_names; all_decls_at_level_rev; - given_some_decls; to_flush_rev; named_assumptions; pruning_roots;_} - -> given_some_decls -let (__proj__Mkdecls_at_level__item__to_flush_rev : - decls_at_level -> FStar_SMTEncoding_Term.decl Prims.list Prims.list) = - fun projectee -> - match projectee with - | { pruning_state; given_decl_names; all_decls_at_level_rev; - given_some_decls; to_flush_rev; named_assumptions; pruning_roots;_} - -> to_flush_rev -let (__proj__Mkdecls_at_level__item__named_assumptions : - decls_at_level -> - FStar_SMTEncoding_Term.assumption FStar_Compiler_Util.psmap) - = - fun projectee -> - match projectee with - | { pruning_state; given_decl_names; all_decls_at_level_rev; - given_some_decls; to_flush_rev; named_assumptions; pruning_roots;_} - -> named_assumptions -let (__proj__Mkdecls_at_level__item__pruning_roots : - decls_at_level -> - FStar_SMTEncoding_Term.decl Prims.list FStar_Pervasives_Native.option) - = - fun projectee -> - match projectee with - | { pruning_state; given_decl_names; all_decls_at_level_rev; - given_some_decls; to_flush_rev; named_assumptions; pruning_roots;_} - -> pruning_roots -let (init_given_decls_at_level : decls_at_level) = - let uu___ = FStar_Compiler_Util.psmap_empty () in - { - pruning_state = FStar_SMTEncoding_Pruning.init; - given_decl_names = empty_decl_names; - all_decls_at_level_rev = []; - given_some_decls = false; - to_flush_rev = []; - named_assumptions = uu___; - pruning_roots = FStar_Pervasives_Native.None - } -type solver_state = - { - levels: decls_at_level Prims.list ; - pending_flushes_rev: FStar_SMTEncoding_Term.decl Prims.list ; - using_facts_from: using_facts_from_setting FStar_Pervasives_Native.option ; - retain_assumptions: decl_name_set } -let (__proj__Mksolver_state__item__levels : - solver_state -> decls_at_level Prims.list) = - fun projectee -> - match projectee with - | { levels; pending_flushes_rev; using_facts_from; retain_assumptions;_} - -> levels -let (__proj__Mksolver_state__item__pending_flushes_rev : - solver_state -> FStar_SMTEncoding_Term.decl Prims.list) = - fun projectee -> - match projectee with - | { levels; pending_flushes_rev; using_facts_from; retain_assumptions;_} - -> pending_flushes_rev -let (__proj__Mksolver_state__item__using_facts_from : - solver_state -> using_facts_from_setting FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { levels; pending_flushes_rev; using_facts_from; retain_assumptions;_} - -> using_facts_from -let (__proj__Mksolver_state__item__retain_assumptions : - solver_state -> decl_name_set) = - fun projectee -> - match projectee with - | { levels; pending_flushes_rev; using_facts_from; retain_assumptions;_} - -> retain_assumptions -let (depth : solver_state -> Prims.int) = - fun s -> FStar_Compiler_List.length s.levels -let (solver_state_to_string : solver_state -> Prims.string) = - fun s -> - let levels = - FStar_Compiler_List.map - (fun level -> - let uu___ = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_nat) - (FStar_Compiler_List.length level.all_decls_at_level_rev) in - let uu___1 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - level.given_some_decls in - let uu___2 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_nat) - (FStar_Compiler_List.length level.to_flush_rev) in - FStar_Compiler_Util.format3 - "Level { all_decls=%s; given_decls=%s; to_flush=%s }" uu___ - uu___1 uu___2) s.levels in - let uu___ = - FStar_Class_Show.show - (FStar_Class_Show.show_list - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_string)) levels in - let uu___1 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow FStar_Class_Printable.printable_nat) - (FStar_Compiler_List.length s.pending_flushes_rev) in - FStar_Compiler_Util.format2 - "Solver state { levels=%s; pending_flushes=%s }" uu___ uu___1 -let (showable_solver_state : solver_state FStar_Class_Show.showable) = - { FStar_Class_Show.show = solver_state_to_string } -let (debug : Prims.string -> solver_state -> solver_state -> unit) = - fun msg -> - fun s0 -> - fun s1 -> - let uu___ = - let uu___1 = FStar_Options_Ext.get "debug_solver_state" in - uu___1 <> "" in - if uu___ - then - let uu___1 = solver_state_to_string s0 in - let uu___2 = solver_state_to_string s1 in - FStar_Compiler_Util.print3 - "Debug (%s):{\n\t before=%s\n\t after=%s\n}" msg uu___1 uu___2 - else () -let (peek : solver_state -> (decls_at_level * decls_at_level Prims.list)) = - fun s -> - match s.levels with - | [] -> failwith "Solver state cannot have an empty stack" - | hd::tl -> (hd, tl) -let (replace_head : decls_at_level -> solver_state -> solver_state) = - fun hd -> - fun s -> - let uu___ = - let uu___1 = FStar_Compiler_List.tl s.levels in hd :: uu___1 in - { - levels = uu___; - pending_flushes_rev = (s.pending_flushes_rev); - using_facts_from = (s.using_facts_from); - retain_assumptions = (s.retain_assumptions) - } -let (init : unit -> solver_state) = - fun uu___ -> - let uu___1 = - let uu___2 = FStar_Options.using_facts_from () in - FStar_Pervasives_Native.Some uu___2 in - { - levels = [init_given_decls_at_level]; - pending_flushes_rev = []; - using_facts_from = uu___1; - retain_assumptions = empty_decl_names - } -let (push : solver_state -> solver_state) = - fun s -> - let uu___ = peek s in - match uu___ with - | (hd, uu___1) -> - let push1 = - FStar_SMTEncoding_Term.Push (FStar_Compiler_List.length s.levels) in - let next = - { - pruning_state = (hd.pruning_state); - given_decl_names = (hd.given_decl_names); - all_decls_at_level_rev = []; - given_some_decls = false; - to_flush_rev = [[push1]]; - named_assumptions = (hd.named_assumptions); - pruning_roots = FStar_Pervasives_Native.None - } in - { - levels = (next :: (s.levels)); - pending_flushes_rev = (s.pending_flushes_rev); - using_facts_from = (s.using_facts_from); - retain_assumptions = (s.retain_assumptions) - } -let (pop : solver_state -> solver_state) = - fun s -> - let uu___ = peek s in - match uu___ with - | (hd, tl) -> - (if Prims.uu___is_Nil tl - then failwith "Solver state cannot have an empty stack" - else (); - (let s1 = - if Prims.op_Negation hd.given_some_decls - then - { - levels = tl; - pending_flushes_rev = (s.pending_flushes_rev); - using_facts_from = (s.using_facts_from); - retain_assumptions = (s.retain_assumptions) - } - else - { - levels = tl; - pending_flushes_rev = - ((FStar_SMTEncoding_Term.Pop - (FStar_Compiler_List.length tl)) :: - (s.pending_flushes_rev)); - using_facts_from = (s.using_facts_from); - retain_assumptions = (s.retain_assumptions) - } in - s1)) -let (filter_using_facts_from : - using_facts_from_setting FStar_Pervasives_Native.option -> - FStar_SMTEncoding_Term.assumption FStar_Compiler_Util.psmap -> - decl_name_set -> - (Prims.string -> Prims.bool) -> - FStar_SMTEncoding_Term.decl Prims.list -> - FStar_SMTEncoding_Term.decl Prims.list) - = - fun using_facts_from -> - fun named_assumptions -> - fun retain_assumptions -> - fun already_given_decl -> - fun ds -> - match using_facts_from with - | FStar_Pervasives_Native.None -> ds - | FStar_Pervasives_Native.Some (([], true)::[]) -> ds - | FStar_Pervasives_Native.Some using_facts_from1 -> - let keep_assumption a = - match a.FStar_SMTEncoding_Term.assumption_fact_ids with - | [] -> true - | uu___ -> - (decl_names_contains - a.FStar_SMTEncoding_Term.assumption_name - retain_assumptions) - || - (FStar_Compiler_Util.for_some - (fun uu___1 -> - match uu___1 with - | FStar_SMTEncoding_Term.Name lid -> - FStar_TypeChecker_Env.should_enc_lid - using_facts_from1 lid - | uu___2 -> false) - a.FStar_SMTEncoding_Term.assumption_fact_ids) in - let already_given_map = - FStar_Compiler_Util.smap_create (Prims.of_int (1000)) in - let add_assumption a = - FStar_Compiler_Util.smap_add already_given_map - a.FStar_SMTEncoding_Term.assumption_name true in - let already_given a = - (let uu___ = - FStar_Compiler_Util.smap_try_find already_given_map - a.FStar_SMTEncoding_Term.assumption_name in - FStar_Pervasives_Native.uu___is_Some uu___) || - (already_given_decl - a.FStar_SMTEncoding_Term.assumption_name) in - let map_decl d = - match d with - | FStar_SMTEncoding_Term.Assume a -> - let uu___ = - (keep_assumption a) && - (let uu___1 = already_given a in - Prims.op_Negation uu___1) in - if uu___ then (add_assumption a; [d]) else [] - | FStar_SMTEncoding_Term.RetainAssumptions names -> - let assumptions = - FStar_Compiler_List.collect - (fun name -> - let uu___ = - FStar_Compiler_Util.psmap_try_find - named_assumptions name in - match uu___ with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some a -> - let uu___1 = already_given a in - if uu___1 - then [] - else - (add_assumption a; - [FStar_SMTEncoding_Term.Assume a])) names in - assumptions - | uu___ -> [d] in - let ds1 = FStar_Compiler_List.collect map_decl ds in ds1 -let (already_given_decl : solver_state -> Prims.string -> Prims.bool) = - fun s -> - fun aname -> - FStar_Compiler_Util.for_some - (fun level -> decl_names_contains aname level.given_decl_names) - s.levels -let rec (flatten : - FStar_SMTEncoding_Term.decl -> FStar_SMTEncoding_Term.decl Prims.list) = - fun d -> - match d with - | FStar_SMTEncoding_Term.Module (uu___, ds) -> - FStar_Compiler_List.collect flatten ds - | uu___ -> [d] -let (add_named_assumptions : - FStar_SMTEncoding_Term.assumption FStar_Compiler_Util.psmap -> - FStar_SMTEncoding_Term.decl Prims.list -> - FStar_SMTEncoding_Term.assumption FStar_Compiler_Util.psmap) - = - fun named_assumptions -> - fun ds -> - FStar_Compiler_List.fold_left - (fun named_assumptions1 -> - fun d -> - match d with - | FStar_SMTEncoding_Term.Assume a -> - FStar_Compiler_Util.psmap_add named_assumptions1 - a.FStar_SMTEncoding_Term.assumption_name a - | uu___ -> named_assumptions1) named_assumptions ds -let (add_retain_assumptions : - FStar_SMTEncoding_Term.decl Prims.list -> solver_state -> solver_state) = - fun ds -> - fun s -> - let ra = - FStar_Compiler_List.fold_left - (fun ra1 -> - fun d -> - match d with - | FStar_SMTEncoding_Term.RetainAssumptions names -> - FStar_Compiler_List.fold_left - (fun ra2 -> fun name -> add_name name ra2) ra1 names - | uu___ -> ra1) s.retain_assumptions ds in - { - levels = (s.levels); - pending_flushes_rev = (s.pending_flushes_rev); - using_facts_from = (s.using_facts_from); - retain_assumptions = ra - } -let (give_delay_assumptions : - Prims.bool -> - FStar_SMTEncoding_Term.decl Prims.list -> solver_state -> solver_state) - = - fun resetting -> - fun ds -> - fun s -> - let decls = FStar_Compiler_List.collect flatten ds in - let uu___ = - FStar_Compiler_List.partition FStar_SMTEncoding_Term.uu___is_Assume - decls in - match uu___ with - | (assumptions, rest) -> - let uu___1 = peek s in - (match uu___1 with - | (hd, tl) -> - let hd1 = - { - pruning_state = (hd.pruning_state); - given_decl_names = (hd.given_decl_names); - all_decls_at_level_rev = (ds :: - (hd.all_decls_at_level_rev)); - given_some_decls = (hd.given_some_decls); - to_flush_rev = (rest :: (hd.to_flush_rev)); - named_assumptions = (hd.named_assumptions); - pruning_roots = (hd.pruning_roots) - } in - if resetting - then - { - levels = (hd1 :: tl); - pending_flushes_rev = (s.pending_flushes_rev); - using_facts_from = (s.using_facts_from); - retain_assumptions = (s.retain_assumptions) - } - else - (let hd2 = - let uu___3 = - FStar_SMTEncoding_Pruning.add_decls decls - hd1.pruning_state in - let uu___4 = - add_named_assumptions hd1.named_assumptions - assumptions in - { - pruning_state = uu___3; - given_decl_names = (hd1.given_decl_names); - all_decls_at_level_rev = (hd1.all_decls_at_level_rev); - given_some_decls = (hd1.given_some_decls); - to_flush_rev = (hd1.to_flush_rev); - named_assumptions = uu___4; - pruning_roots = (hd1.pruning_roots) - } in - add_retain_assumptions decls - { - levels = (hd2 :: tl); - pending_flushes_rev = (s.pending_flushes_rev); - using_facts_from = (s.using_facts_from); - retain_assumptions = (s.retain_assumptions) - })) -let (give_now : - Prims.bool -> - FStar_SMTEncoding_Term.decl Prims.list -> solver_state -> solver_state) - = - fun resetting -> - fun ds -> - fun s -> - let decls = FStar_Compiler_List.collect flatten ds in - let uu___ = - FStar_Compiler_List.partition FStar_SMTEncoding_Term.uu___is_Assume - decls in - match uu___ with - | (assumptions, uu___1) -> - let uu___2 = peek s in - (match uu___2 with - | (hd, tl) -> - let named_assumptions = - if resetting - then hd.named_assumptions - else - add_named_assumptions hd.named_assumptions assumptions in - let ds_to_flush = - filter_using_facts_from s.using_facts_from - named_assumptions s.retain_assumptions - (already_given_decl s) decls in - let given = - FStar_Compiler_List.fold_left - (fun given1 -> - fun d -> - match d with - | FStar_SMTEncoding_Term.Assume a -> - add_name - a.FStar_SMTEncoding_Term.assumption_name - given1 - | uu___3 -> given1) hd.given_decl_names ds_to_flush in - let hd1 = - { - pruning_state = (hd.pruning_state); - given_decl_names = given; - all_decls_at_level_rev = (ds :: - (hd.all_decls_at_level_rev)); - given_some_decls = (hd.given_some_decls); - to_flush_rev = (ds_to_flush :: (hd.to_flush_rev)); - named_assumptions = (hd.named_assumptions); - pruning_roots = (hd.pruning_roots) - } in - if resetting - then - { - levels = (hd1 :: tl); - pending_flushes_rev = (s.pending_flushes_rev); - using_facts_from = (s.using_facts_from); - retain_assumptions = (s.retain_assumptions) - } - else - (let hd2 = - let uu___4 = - FStar_SMTEncoding_Pruning.add_decls decls - hd1.pruning_state in - { - pruning_state = uu___4; - given_decl_names = (hd1.given_decl_names); - all_decls_at_level_rev = (hd1.all_decls_at_level_rev); - given_some_decls = (hd1.given_some_decls); - to_flush_rev = (hd1.to_flush_rev); - named_assumptions; - pruning_roots = (hd1.pruning_roots) - } in - add_retain_assumptions decls - { - levels = (hd2 :: tl); - pending_flushes_rev = (s.pending_flushes_rev); - using_facts_from = (s.using_facts_from); - retain_assumptions = (s.retain_assumptions) - })) -let (give_aux : - Prims.bool -> - FStar_SMTEncoding_Term.decl Prims.list -> solver_state -> solver_state) - = - fun resetting -> - fun ds -> - fun s -> - let uu___ = - let uu___1 = FStar_Options_Ext.get "context_pruning" in - uu___1 <> "" in - if uu___ - then give_delay_assumptions resetting ds s - else give_now resetting ds s -let (give : - FStar_SMTEncoding_Term.decl Prims.list -> solver_state -> solver_state) = - give_aux false -let (reset : - using_facts_from_setting FStar_Pervasives_Native.option -> - solver_state -> solver_state) - = - fun using_facts_from -> - fun s -> - let s_new = init () in - let s_new1 = - { - levels = (s_new.levels); - pending_flushes_rev = (s_new.pending_flushes_rev); - using_facts_from; - retain_assumptions = (s.retain_assumptions) - } in - let set_pruning_roots level s1 = - let uu___ = peek s1 in - match uu___ with - | (hd, tl) -> - let hd1 = - { - pruning_state = (hd.pruning_state); - given_decl_names = (hd.given_decl_names); - all_decls_at_level_rev = (hd.all_decls_at_level_rev); - given_some_decls = (hd.given_some_decls); - to_flush_rev = (hd.to_flush_rev); - named_assumptions = (hd.named_assumptions); - pruning_roots = (level.pruning_roots) - } in - { - levels = (hd1 :: tl); - pending_flushes_rev = (s1.pending_flushes_rev); - using_facts_from = (s1.using_facts_from); - retain_assumptions = (s1.retain_assumptions) - } in - let rebuild_level now level s_new2 = - let uu___ = peek s_new2 in - match uu___ with - | (hd, tl) -> - let hd1 = - { - pruning_state = (level.pruning_state); - given_decl_names = (hd.given_decl_names); - all_decls_at_level_rev = (hd.all_decls_at_level_rev); - given_some_decls = (hd.given_some_decls); - to_flush_rev = (hd.to_flush_rev); - named_assumptions = (level.named_assumptions); - pruning_roots = (hd.pruning_roots) - } in - let s_new3 = - { - levels = (hd1 :: tl); - pending_flushes_rev = (s_new2.pending_flushes_rev); - using_facts_from = (s_new2.using_facts_from); - retain_assumptions = (s_new2.retain_assumptions) - } in - let s1 = - FStar_Compiler_List.fold_right - (if now then give_now true else give_aux true) - level.all_decls_at_level_rev s_new3 in - let uu___1 = set_pruning_roots level s1 in - (uu___1, - (FStar_Pervasives_Native.uu___is_Some level.pruning_roots)) in - let rec rebuild levels s_new2 = - match levels with - | last::[] -> rebuild_level false last s_new2 - | level::levels1 -> - let uu___ = rebuild levels1 s_new2 in - (match uu___ with - | (s_new3, now) -> - let s_new4 = push s_new3 in rebuild_level now level s_new4) in - let uu___ = rebuild s.levels s_new1 in - FStar_Pervasives_Native.fst uu___ -let (name_of_assumption : FStar_SMTEncoding_Term.decl -> Prims.string) = - fun d -> - match d with - | FStar_SMTEncoding_Term.Assume a -> - a.FStar_SMTEncoding_Term.assumption_name - | uu___ -> failwith "Expected an assumption" -let (prune_level : - FStar_SMTEncoding_Term.decl Prims.list -> - decls_at_level -> solver_state -> decls_at_level) - = - fun roots -> - fun hd -> - fun s -> - let to_give = FStar_SMTEncoding_Pruning.prune hd.pruning_state roots in - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun to_give1 -> - match uu___1 with - | (decl_name_set1, can_give) -> - let name = name_of_assumption to_give1 in - let uu___2 = - let uu___3 = decl_names_contains name decl_name_set1 in - Prims.op_Negation uu___3 in - if uu___2 - then - let uu___3 = add_name name decl_name_set1 in - (uu___3, (to_give1 :: can_give)) - else (decl_name_set1, can_give)) - ((hd.given_decl_names), []) to_give in - match uu___ with - | (given_decl_names, can_give) -> - let can_give1 = - filter_using_facts_from s.using_facts_from hd.named_assumptions - s.retain_assumptions (already_given_decl s) can_give in - let hd1 = - { - pruning_state = (hd.pruning_state); - given_decl_names; - all_decls_at_level_rev = (hd.all_decls_at_level_rev); - given_some_decls = (hd.given_some_decls); - to_flush_rev = (can_give1 :: (hd.to_flush_rev)); - named_assumptions = (hd.named_assumptions); - pruning_roots = (hd.pruning_roots) - } in - hd1 -let (prune_sim : - FStar_SMTEncoding_Term.decl Prims.list -> - solver_state -> Prims.string Prims.list) - = - fun roots -> - fun s -> - let uu___ = peek s in - match uu___ with - | (hd, tl) -> - let to_give = - FStar_SMTEncoding_Pruning.prune hd.pruning_state roots in - let can_give = - filter_using_facts_from s.using_facts_from hd.named_assumptions - s.retain_assumptions (already_given_decl s) to_give in - let uu___1 = - let uu___2 = - FStar_Compiler_List.filter - FStar_SMTEncoding_Term.uu___is_Assume roots in - FStar_List_Tot_Base.op_At uu___2 can_give in - FStar_Compiler_List.map name_of_assumption uu___1 -let (start_query : - Prims.string -> - FStar_SMTEncoding_Term.decl Prims.list -> - FStar_SMTEncoding_Term.decl -> solver_state -> solver_state) - = - fun msg -> - fun roots_to_push -> - fun qry -> - fun s -> - let uu___ = peek s in - match uu___ with - | (hd, tl) -> - let s1 = - { - levels = - ({ - pruning_state = (hd.pruning_state); - given_decl_names = (hd.given_decl_names); - all_decls_at_level_rev = (hd.all_decls_at_level_rev); - given_some_decls = (hd.given_some_decls); - to_flush_rev = (hd.to_flush_rev); - named_assumptions = (hd.named_assumptions); - pruning_roots = - (FStar_Pervasives_Native.Some (qry :: roots_to_push)) - } :: tl); - pending_flushes_rev = (s.pending_flushes_rev); - using_facts_from = (s.using_facts_from); - retain_assumptions = (s.retain_assumptions) - } in - let s2 = push s1 in - let s3 = give [FStar_SMTEncoding_Term.Caption msg] s2 in - give_now false roots_to_push s3 -let (finish_query : Prims.string -> solver_state -> solver_state) = - fun msg -> - fun s -> - let s1 = give [FStar_SMTEncoding_Term.Caption msg] s in - let s2 = pop s1 in - let uu___ = peek s2 in - match uu___ with - | (hd, tl) -> - { - levels = - ({ - pruning_state = (hd.pruning_state); - given_decl_names = (hd.given_decl_names); - all_decls_at_level_rev = (hd.all_decls_at_level_rev); - given_some_decls = (hd.given_some_decls); - to_flush_rev = (hd.to_flush_rev); - named_assumptions = (hd.named_assumptions); - pruning_roots = FStar_Pervasives_Native.None - } :: tl); - pending_flushes_rev = (s2.pending_flushes_rev); - using_facts_from = (s2.using_facts_from); - retain_assumptions = (s2.retain_assumptions) - } -let (filter_with_unsat_core : - Prims.string -> - FStar_SMTEncoding_UnsatCore.unsat_core -> - solver_state -> FStar_SMTEncoding_Term.decl Prims.list) - = - fun queryid -> - fun core -> - fun s -> - let rec all_decls levels = - match levels with - | last::[] -> last.all_decls_at_level_rev - | level::levels1 -> - let uu___ = - let uu___1 = all_decls levels1 in - [FStar_SMTEncoding_Term.Push - (FStar_Compiler_List.length levels1)] - :: uu___1 in - FStar_List_Tot_Base.op_At level.all_decls_at_level_rev uu___ in - let all_decls1 = all_decls s.levels in - let all_decls2 = - FStar_Compiler_List.flatten (FStar_Compiler_List.rev all_decls1) in - FStar_SMTEncoding_UnsatCore.filter core all_decls2 -let (would_have_pruned : - solver_state -> Prims.string Prims.list FStar_Pervasives_Native.option) = - fun s -> - let uu___ = - let uu___1 = FStar_Options_Ext.get "context_pruning_sim" in uu___1 = "" in - if uu___ - then FStar_Pervasives_Native.None - else - (let rec aux levels = - match levels with - | [] -> FStar_Pervasives_Native.None - | level::levels1 -> - (match level.pruning_roots with - | FStar_Pervasives_Native.Some roots -> - let uu___2 = prune_sim roots s in - FStar_Pervasives_Native.Some uu___2 - | FStar_Pervasives_Native.None -> aux levels1) in - aux s.levels) -let (flush : - solver_state -> (FStar_SMTEncoding_Term.decl Prims.list * solver_state)) = - fun s -> - let s1 = - let uu___ = - let uu___1 = FStar_Options_Ext.get "context_pruning" in uu___1 <> "" in - if uu___ - then - let rec aux levels = - match levels with - | [] -> [] - | level::levels1 -> - (match level.pruning_roots with - | FStar_Pervasives_Native.Some roots -> - let hd = prune_level roots level s in hd :: levels1 - | FStar_Pervasives_Native.None -> - let uu___1 = aux levels1 in level :: uu___1) in - let uu___1 = aux s.levels in - { - levels = uu___1; - pending_flushes_rev = (s.pending_flushes_rev); - using_facts_from = (s.using_facts_from); - retain_assumptions = (s.retain_assumptions) - } - else s in - let to_flush = - let uu___ = - let uu___1 = - FStar_Compiler_List.collect (fun level -> level.to_flush_rev) - s1.levels in - FStar_Compiler_List.rev uu___1 in - FStar_Compiler_List.flatten uu___ in - let levels = - FStar_Compiler_List.map - (fun level -> - { - pruning_state = (level.pruning_state); - given_decl_names = (level.given_decl_names); - all_decls_at_level_rev = (level.all_decls_at_level_rev); - given_some_decls = - (level.given_some_decls || - (Prims.uu___is_Cons level.to_flush_rev)); - to_flush_rev = []; - named_assumptions = (level.named_assumptions); - pruning_roots = (level.pruning_roots) - }) s1.levels in - let s11 = - { - levels; - pending_flushes_rev = []; - using_facts_from = (s1.using_facts_from); - retain_assumptions = (s1.retain_assumptions) - } in - let flushed = - FStar_List_Tot_Base.op_At - (FStar_Compiler_List.rev s1.pending_flushes_rev) to_flush in - (flushed, s11) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Solver_Cache.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Solver_Cache.ml deleted file mode 100644 index e47fae5b51d..00000000000 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Solver_Cache.ml +++ /dev/null @@ -1,381 +0,0 @@ -open Prims -let (hashable_lident : FStar_Ident.lident FStar_Class_Hashable.hashable) = - { - FStar_Class_Hashable.hash = - (fun l -> - let uu___ = FStar_Class_Show.show FStar_Ident.showable_lident l in - FStar_Class_Hashable.hash FStar_Class_Hashable.hashable_string uu___) - } -let (hashable_ident : FStar_Ident.ident FStar_Class_Hashable.hashable) = - { - FStar_Class_Hashable.hash = - (fun i -> - let uu___ = FStar_Class_Show.show FStar_Ident.showable_ident i in - FStar_Class_Hashable.hash FStar_Class_Hashable.hashable_string uu___) - } -let (hashable_binding : - FStar_Syntax_Syntax.binding FStar_Class_Hashable.hashable) = - { - FStar_Class_Hashable.hash = - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.Binding_var bv -> - FStar_Class_Hashable.hash FStar_Syntax_Hash.hashable_term - bv.FStar_Syntax_Syntax.sort - | FStar_Syntax_Syntax.Binding_lid (l, (us, t)) -> - let uu___1 = - let uu___2 = FStar_Class_Hashable.hash hashable_lident l in - let uu___3 = - FStar_Class_Hashable.hash - (FStar_Class_Hashable.hashable_list hashable_ident) us in - FStar_Hash.mix uu___2 uu___3 in - let uu___2 = - FStar_Class_Hashable.hash FStar_Syntax_Hash.hashable_term t in - FStar_Hash.mix uu___1 uu___2 - | FStar_Syntax_Syntax.Binding_univ u -> - FStar_Class_Hashable.hash hashable_ident u) - } -let (hashable_bv : FStar_Syntax_Syntax.bv FStar_Class_Hashable.hashable) = - { - FStar_Class_Hashable.hash = - (fun b -> - FStar_Class_Hashable.hash FStar_Syntax_Hash.hashable_term - b.FStar_Syntax_Syntax.sort) - } -let (hashable_fv : FStar_Syntax_Syntax.fv FStar_Class_Hashable.hashable) = - { - FStar_Class_Hashable.hash = - (fun f -> - FStar_Class_Hashable.hash hashable_lident - (f.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v) - } -let (hashable_binder : - FStar_Syntax_Syntax.binder FStar_Class_Hashable.hashable) = - { - FStar_Class_Hashable.hash = - (fun b -> - FStar_Class_Hashable.hash hashable_bv - b.FStar_Syntax_Syntax.binder_bv) - } -let (hashable_letbinding : - FStar_Syntax_Syntax.letbinding FStar_Class_Hashable.hashable) = - { - FStar_Class_Hashable.hash = - (fun lb -> - let uu___ = - let uu___1 = - FStar_Class_Hashable.hash - (FStar_Class_Hashable.hashable_either hashable_bv hashable_fv) - lb.FStar_Syntax_Syntax.lbname in - let uu___2 = - FStar_Class_Hashable.hash FStar_Syntax_Hash.hashable_term - lb.FStar_Syntax_Syntax.lbtyp in - FStar_Hash.mix uu___1 uu___2 in - let uu___1 = - FStar_Class_Hashable.hash FStar_Syntax_Hash.hashable_term - lb.FStar_Syntax_Syntax.lbdef in - FStar_Hash.mix uu___ uu___1) - } -let (hashable_pragma : - FStar_Syntax_Syntax.pragma FStar_Class_Hashable.hashable) = - { - FStar_Class_Hashable.hash = - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.SetOptions s -> - let uu___1 = - FStar_Class_Hashable.hash FStar_Class_Hashable.hashable_int - Prims.int_one in - let uu___2 = - FStar_Class_Hashable.hash FStar_Class_Hashable.hashable_string - s in - FStar_Hash.mix uu___1 uu___2 - | FStar_Syntax_Syntax.ResetOptions s -> - let uu___1 = - FStar_Class_Hashable.hash FStar_Class_Hashable.hashable_int - (Prims.of_int (2)) in - let uu___2 = - FStar_Class_Hashable.hash - (FStar_Class_Hashable.hashable_option - FStar_Class_Hashable.hashable_string) s in - FStar_Hash.mix uu___1 uu___2 - | FStar_Syntax_Syntax.PushOptions s -> - let uu___1 = - FStar_Class_Hashable.hash FStar_Class_Hashable.hashable_int - (Prims.of_int (3)) in - let uu___2 = - FStar_Class_Hashable.hash - (FStar_Class_Hashable.hashable_option - FStar_Class_Hashable.hashable_string) s in - FStar_Hash.mix uu___1 uu___2 - | FStar_Syntax_Syntax.PopOptions -> - FStar_Class_Hashable.hash FStar_Class_Hashable.hashable_int - (Prims.of_int (4)) - | FStar_Syntax_Syntax.RestartSolver -> - FStar_Class_Hashable.hash FStar_Class_Hashable.hashable_int - (Prims.of_int (5)) - | FStar_Syntax_Syntax.PrintEffectsGraph -> - FStar_Class_Hashable.hash FStar_Class_Hashable.hashable_int - (Prims.of_int (6))) - } -let rec (hash_sigelt : FStar_Syntax_Syntax.sigelt -> FStar_Hash.hash_code) = - fun se -> hash_sigelt' se.FStar_Syntax_Syntax.sigel -and (hash_sigelt' : FStar_Syntax_Syntax.sigelt' -> FStar_Hash.hash_code) = - fun se -> - match se with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = lid; FStar_Syntax_Syntax.us = us; - FStar_Syntax_Syntax.params = params; - FStar_Syntax_Syntax.num_uniform_params = num_uniform_params; - FStar_Syntax_Syntax.t = t; FStar_Syntax_Syntax.mutuals = mutuals; - FStar_Syntax_Syntax.ds = ds; - FStar_Syntax_Syntax.injective_type_params = injective_type_params;_} - -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Class_Hashable.hash - FStar_Class_Hashable.hashable_int Prims.int_zero in - let uu___8 = - FStar_Class_Hashable.hash hashable_lident lid in - FStar_Hash.mix uu___7 uu___8 in - let uu___7 = - FStar_Class_Hashable.hash - (FStar_Class_Hashable.hashable_list hashable_ident) - us in - FStar_Hash.mix uu___6 uu___7 in - let uu___6 = - FStar_Class_Hashable.hash - (FStar_Class_Hashable.hashable_list hashable_binder) - params in - FStar_Hash.mix uu___5 uu___6 in - let uu___5 = - FStar_Class_Hashable.hash - (FStar_Class_Hashable.hashable_option - FStar_Class_Hashable.hashable_int) num_uniform_params in - FStar_Hash.mix uu___4 uu___5 in - let uu___4 = - FStar_Class_Hashable.hash FStar_Syntax_Hash.hashable_term t in - FStar_Hash.mix uu___3 uu___4 in - let uu___3 = - FStar_Class_Hashable.hash - (FStar_Class_Hashable.hashable_list hashable_lident) mutuals in - FStar_Hash.mix uu___2 uu___3 in - let uu___2 = - FStar_Class_Hashable.hash - (FStar_Class_Hashable.hashable_list hashable_lident) ds in - FStar_Hash.mix uu___1 uu___2 in - let uu___1 = - FStar_Class_Hashable.hash FStar_Class_Hashable.hashable_bool - injective_type_params in - FStar_Hash.mix uu___ uu___1 - | FStar_Syntax_Syntax.Sig_bundle - { FStar_Syntax_Syntax.ses = ses; FStar_Syntax_Syntax.lids = lids;_} - -> - let uu___ = - let uu___1 = - FStar_Class_Hashable.hash FStar_Class_Hashable.hashable_int - Prims.int_one in - let uu___2 = - (FStar_Class_Hashable.hashable_list - { FStar_Class_Hashable.hash = hash_sigelt }).FStar_Class_Hashable.hash - ses in - FStar_Hash.mix uu___1 uu___2 in - let uu___1 = - FStar_Class_Hashable.hash - (FStar_Class_Hashable.hashable_list hashable_lident) lids in - FStar_Hash.mix uu___ uu___1 - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = lid; FStar_Syntax_Syntax.us1 = us; - FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = ty_lid; - FStar_Syntax_Syntax.num_ty_params = num_ty_params; - FStar_Syntax_Syntax.mutuals1 = mutuals; - FStar_Syntax_Syntax.injective_type_params1 = injective_type_params;_} - -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Class_Hashable.hash - FStar_Class_Hashable.hashable_int (Prims.of_int (2)) in - let uu___7 = - FStar_Class_Hashable.hash hashable_lident lid in - FStar_Hash.mix uu___6 uu___7 in - let uu___6 = - FStar_Class_Hashable.hash - (FStar_Class_Hashable.hashable_list hashable_ident) us in - FStar_Hash.mix uu___5 uu___6 in - let uu___5 = - FStar_Class_Hashable.hash FStar_Syntax_Hash.hashable_term t in - FStar_Hash.mix uu___4 uu___5 in - let uu___4 = FStar_Class_Hashable.hash hashable_lident ty_lid in - FStar_Hash.mix uu___3 uu___4 in - let uu___3 = - FStar_Class_Hashable.hash FStar_Class_Hashable.hashable_int - num_ty_params in - FStar_Hash.mix uu___2 uu___3 in - let uu___2 = - FStar_Class_Hashable.hash - (FStar_Class_Hashable.hashable_list hashable_lident) mutuals in - FStar_Hash.mix uu___1 uu___2 in - let uu___1 = - FStar_Class_Hashable.hash FStar_Class_Hashable.hashable_bool - injective_type_params in - FStar_Hash.mix uu___ uu___1 - | FStar_Syntax_Syntax.Sig_declare_typ - { FStar_Syntax_Syntax.lid2 = lid; FStar_Syntax_Syntax.us2 = us; - FStar_Syntax_Syntax.t2 = t;_} - -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Class_Hashable.hash FStar_Class_Hashable.hashable_int - (Prims.of_int (3)) in - let uu___3 = FStar_Class_Hashable.hash hashable_lident lid in - FStar_Hash.mix uu___2 uu___3 in - let uu___2 = - FStar_Class_Hashable.hash - (FStar_Class_Hashable.hashable_list hashable_ident) us in - FStar_Hash.mix uu___1 uu___2 in - let uu___1 = - FStar_Class_Hashable.hash FStar_Syntax_Hash.hashable_term t in - FStar_Hash.mix uu___ uu___1 - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = lbs; FStar_Syntax_Syntax.lids1 = lids;_} - -> - let uu___ = - let uu___1 = - FStar_Class_Hashable.hash FStar_Class_Hashable.hashable_int - (Prims.of_int (4)) in - let uu___2 = - FStar_Class_Hashable.hash - (FStar_Class_Hashable.hashable_tuple2 - FStar_Class_Hashable.hashable_bool - (FStar_Class_Hashable.hashable_list hashable_letbinding)) - lbs in - FStar_Hash.mix uu___1 uu___2 in - let uu___1 = - FStar_Class_Hashable.hash - (FStar_Class_Hashable.hashable_list hashable_lident) lids in - FStar_Hash.mix uu___ uu___1 - | FStar_Syntax_Syntax.Sig_assume - { FStar_Syntax_Syntax.lid3 = lid; FStar_Syntax_Syntax.us3 = us; - FStar_Syntax_Syntax.phi1 = phi;_} - -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Class_Hashable.hash FStar_Class_Hashable.hashable_int - (Prims.of_int (5)) in - let uu___3 = FStar_Class_Hashable.hash hashable_lident lid in - FStar_Hash.mix uu___2 uu___3 in - let uu___2 = - FStar_Class_Hashable.hash - (FStar_Class_Hashable.hashable_list hashable_ident) us in - FStar_Hash.mix uu___1 uu___2 in - let uu___1 = - FStar_Class_Hashable.hash FStar_Syntax_Hash.hashable_term phi in - FStar_Hash.mix uu___ uu___1 - | FStar_Syntax_Syntax.Sig_pragma p -> - let uu___ = - FStar_Class_Hashable.hash FStar_Class_Hashable.hashable_int - (Prims.of_int (6)) in - let uu___1 = FStar_Class_Hashable.hash hashable_pragma p in - FStar_Hash.mix uu___ uu___1 - | uu___ -> - FStar_Class_Hashable.hash FStar_Class_Hashable.hashable_int - Prims.int_zero -let (hashable_sigelt : - FStar_Syntax_Syntax.sigelt FStar_Class_Hashable.hashable) = - { FStar_Class_Hashable.hash = hash_sigelt } -let (hashable_env : FStar_TypeChecker_Env.env FStar_Class_Hashable.hashable) - = - { - FStar_Class_Hashable.hash = - (fun e -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Class_Hashable.hash - (FStar_Class_Hashable.hashable_list hashable_binding) - e.FStar_TypeChecker_Env.gamma in - let uu___3 = - FStar_Class_Hashable.hash - (FStar_Class_Hashable.hashable_list - (FStar_Class_Hashable.hashable_tuple2 - (FStar_Class_Hashable.hashable_list hashable_lident) - hashable_sigelt)) e.FStar_TypeChecker_Env.gamma_sig in - FStar_Hash.mix uu___2 uu___3 in - let uu___2 = - FStar_Class_Hashable.hash - (FStar_Class_Hashable.hashable_list - (FStar_Class_Hashable.hashable_tuple2 - (FStar_Class_Hashable.hashable_list - FStar_Class_Hashable.hashable_string) - FStar_Class_Hashable.hashable_bool)) - e.FStar_TypeChecker_Env.proof_ns in - FStar_Hash.mix uu___1 uu___2 in - let uu___1 = - FStar_Class_Hashable.hash FStar_Class_Hashable.hashable_bool - e.FStar_TypeChecker_Env.admit in - FStar_Hash.mix uu___ uu___1) - } -let (query_cache_ref : - FStar_Hash.hash_code FStar_Compiler_RBSet.t FStar_Compiler_Effect.ref) = - let uu___ = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Hashable.ord_hash_code)) ()) in - FStar_Compiler_Util.mk_ref uu___ -let (on : unit -> Prims.bool) = - fun uu___ -> (FStar_Options.query_cache ()) && (FStar_Options.ide ()) -let (query_cache_add : - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.term -> unit) = - fun g -> - fun q -> - let uu___ = on () in - if uu___ - then - let h = - FStar_Class_Hashable.hash - (FStar_Class_Hashable.hashable_tuple2 hashable_env - FStar_Syntax_Hash.hashable_term) (g, q) in - let uu___1 = - let uu___2 = FStar_Compiler_Effect.op_Bang query_cache_ref in - Obj.magic - (FStar_Class_Setlike.add () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Hashable.ord_hash_code)) h - (Obj.magic uu___2)) in - FStar_Compiler_Effect.op_Colon_Equals query_cache_ref uu___1 - else () -let (try_find_query_cache : - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.term -> Prims.bool) = - fun g -> - fun q -> - let uu___ = on () in - if uu___ - then - let h = - FStar_Class_Hashable.hash - (FStar_Class_Hashable.hashable_tuple2 hashable_env - FStar_Syntax_Hash.hashable_term) (g, q) in - let r = - let uu___1 = FStar_Compiler_Effect.op_Bang query_cache_ref in - FStar_Class_Setlike.mem () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Hashable.ord_hash_code)) h (Obj.magic uu___1) in - r - else false \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Term.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Term.ml deleted file mode 100644 index e87542529db..00000000000 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Term.ml +++ /dev/null @@ -1,2546 +0,0 @@ -open Prims -type sort = - | Bool_sort - | Int_sort - | String_sort - | Term_sort - | Fuel_sort - | BitVec_sort of Prims.int - | Array of (sort * sort) - | Arrow of (sort * sort) - | Sort of Prims.string -let (uu___is_Bool_sort : sort -> Prims.bool) = - fun projectee -> match projectee with | Bool_sort -> true | uu___ -> false -let (uu___is_Int_sort : sort -> Prims.bool) = - fun projectee -> match projectee with | Int_sort -> true | uu___ -> false -let (uu___is_String_sort : sort -> Prims.bool) = - fun projectee -> - match projectee with | String_sort -> true | uu___ -> false -let (uu___is_Term_sort : sort -> Prims.bool) = - fun projectee -> match projectee with | Term_sort -> true | uu___ -> false -let (uu___is_Fuel_sort : sort -> Prims.bool) = - fun projectee -> match projectee with | Fuel_sort -> true | uu___ -> false -let (uu___is_BitVec_sort : sort -> Prims.bool) = - fun projectee -> - match projectee with | BitVec_sort _0 -> true | uu___ -> false -let (__proj__BitVec_sort__item___0 : sort -> Prims.int) = - fun projectee -> match projectee with | BitVec_sort _0 -> _0 -let (uu___is_Array : sort -> Prims.bool) = - fun projectee -> match projectee with | Array _0 -> true | uu___ -> false -let (__proj__Array__item___0 : sort -> (sort * sort)) = - fun projectee -> match projectee with | Array _0 -> _0 -let (uu___is_Arrow : sort -> Prims.bool) = - fun projectee -> match projectee with | Arrow _0 -> true | uu___ -> false -let (__proj__Arrow__item___0 : sort -> (sort * sort)) = - fun projectee -> match projectee with | Arrow _0 -> _0 -let (uu___is_Sort : sort -> Prims.bool) = - fun projectee -> match projectee with | Sort _0 -> true | uu___ -> false -let (__proj__Sort__item___0 : sort -> Prims.string) = - fun projectee -> match projectee with | Sort _0 -> _0 -type op = - | TrueOp - | FalseOp - | Not - | And - | Or - | Imp - | Iff - | Eq - | LT - | LTE - | GT - | GTE - | Add - | Sub - | Div - | RealDiv - | Mul - | Minus - | Mod - | BvAnd - | BvXor - | BvOr - | BvAdd - | BvSub - | BvShl - | BvShr - | BvUdiv - | BvMod - | BvMul - | BvUlt - | BvUext of Prims.int - | NatToBv of Prims.int - | BvToNat - | ITE - | Var of Prims.string -let (uu___is_TrueOp : op -> Prims.bool) = - fun projectee -> match projectee with | TrueOp -> true | uu___ -> false -let (uu___is_FalseOp : op -> Prims.bool) = - fun projectee -> match projectee with | FalseOp -> true | uu___ -> false -let (uu___is_Not : op -> Prims.bool) = - fun projectee -> match projectee with | Not -> true | uu___ -> false -let (uu___is_And : op -> Prims.bool) = - fun projectee -> match projectee with | And -> true | uu___ -> false -let (uu___is_Or : op -> Prims.bool) = - fun projectee -> match projectee with | Or -> true | uu___ -> false -let (uu___is_Imp : op -> Prims.bool) = - fun projectee -> match projectee with | Imp -> true | uu___ -> false -let (uu___is_Iff : op -> Prims.bool) = - fun projectee -> match projectee with | Iff -> true | uu___ -> false -let (uu___is_Eq : op -> Prims.bool) = - fun projectee -> match projectee with | Eq -> true | uu___ -> false -let (uu___is_LT : op -> Prims.bool) = - fun projectee -> match projectee with | LT -> true | uu___ -> false -let (uu___is_LTE : op -> Prims.bool) = - fun projectee -> match projectee with | LTE -> true | uu___ -> false -let (uu___is_GT : op -> Prims.bool) = - fun projectee -> match projectee with | GT -> true | uu___ -> false -let (uu___is_GTE : op -> Prims.bool) = - fun projectee -> match projectee with | GTE -> true | uu___ -> false -let (uu___is_Add : op -> Prims.bool) = - fun projectee -> match projectee with | Add -> true | uu___ -> false -let (uu___is_Sub : op -> Prims.bool) = - fun projectee -> match projectee with | Sub -> true | uu___ -> false -let (uu___is_Div : op -> Prims.bool) = - fun projectee -> match projectee with | Div -> true | uu___ -> false -let (uu___is_RealDiv : op -> Prims.bool) = - fun projectee -> match projectee with | RealDiv -> true | uu___ -> false -let (uu___is_Mul : op -> Prims.bool) = - fun projectee -> match projectee with | Mul -> true | uu___ -> false -let (uu___is_Minus : op -> Prims.bool) = - fun projectee -> match projectee with | Minus -> true | uu___ -> false -let (uu___is_Mod : op -> Prims.bool) = - fun projectee -> match projectee with | Mod -> true | uu___ -> false -let (uu___is_BvAnd : op -> Prims.bool) = - fun projectee -> match projectee with | BvAnd -> true | uu___ -> false -let (uu___is_BvXor : op -> Prims.bool) = - fun projectee -> match projectee with | BvXor -> true | uu___ -> false -let (uu___is_BvOr : op -> Prims.bool) = - fun projectee -> match projectee with | BvOr -> true | uu___ -> false -let (uu___is_BvAdd : op -> Prims.bool) = - fun projectee -> match projectee with | BvAdd -> true | uu___ -> false -let (uu___is_BvSub : op -> Prims.bool) = - fun projectee -> match projectee with | BvSub -> true | uu___ -> false -let (uu___is_BvShl : op -> Prims.bool) = - fun projectee -> match projectee with | BvShl -> true | uu___ -> false -let (uu___is_BvShr : op -> Prims.bool) = - fun projectee -> match projectee with | BvShr -> true | uu___ -> false -let (uu___is_BvUdiv : op -> Prims.bool) = - fun projectee -> match projectee with | BvUdiv -> true | uu___ -> false -let (uu___is_BvMod : op -> Prims.bool) = - fun projectee -> match projectee with | BvMod -> true | uu___ -> false -let (uu___is_BvMul : op -> Prims.bool) = - fun projectee -> match projectee with | BvMul -> true | uu___ -> false -let (uu___is_BvUlt : op -> Prims.bool) = - fun projectee -> match projectee with | BvUlt -> true | uu___ -> false -let (uu___is_BvUext : op -> Prims.bool) = - fun projectee -> match projectee with | BvUext _0 -> true | uu___ -> false -let (__proj__BvUext__item___0 : op -> Prims.int) = - fun projectee -> match projectee with | BvUext _0 -> _0 -let (uu___is_NatToBv : op -> Prims.bool) = - fun projectee -> match projectee with | NatToBv _0 -> true | uu___ -> false -let (__proj__NatToBv__item___0 : op -> Prims.int) = - fun projectee -> match projectee with | NatToBv _0 -> _0 -let (uu___is_BvToNat : op -> Prims.bool) = - fun projectee -> match projectee with | BvToNat -> true | uu___ -> false -let (uu___is_ITE : op -> Prims.bool) = - fun projectee -> match projectee with | ITE -> true | uu___ -> false -let (uu___is_Var : op -> Prims.bool) = - fun projectee -> match projectee with | Var _0 -> true | uu___ -> false -let (__proj__Var__item___0 : op -> Prims.string) = - fun projectee -> match projectee with | Var _0 -> _0 -type qop = - | Forall - | Exists -let (uu___is_Forall : qop -> Prims.bool) = - fun projectee -> match projectee with | Forall -> true | uu___ -> false -let (uu___is_Exists : qop -> Prims.bool) = - fun projectee -> match projectee with | Exists -> true | uu___ -> false -type term' = - | Integer of Prims.string - | String of Prims.string - | Real of Prims.string - | BoundV of Prims.int - | FreeV of fv - | App of (op * term Prims.list) - | Quant of (qop * term Prims.list Prims.list * Prims.int - FStar_Pervasives_Native.option * sort Prims.list * term) - | Let of (term Prims.list * term) - | Labeled of (term * FStar_Errors_Msg.error_message * - FStar_Compiler_Range_Type.range) - | LblPos of (term * Prims.string) -and term = - { - tm: term' ; - freevars: fv Prims.list FStar_Syntax_Syntax.memo ; - rng: FStar_Compiler_Range_Type.range } -and fv = - | FV of (Prims.string * sort * Prims.bool) -let (uu___is_Integer : term' -> Prims.bool) = - fun projectee -> match projectee with | Integer _0 -> true | uu___ -> false -let (__proj__Integer__item___0 : term' -> Prims.string) = - fun projectee -> match projectee with | Integer _0 -> _0 -let (uu___is_String : term' -> Prims.bool) = - fun projectee -> match projectee with | String _0 -> true | uu___ -> false -let (__proj__String__item___0 : term' -> Prims.string) = - fun projectee -> match projectee with | String _0 -> _0 -let (uu___is_Real : term' -> Prims.bool) = - fun projectee -> match projectee with | Real _0 -> true | uu___ -> false -let (__proj__Real__item___0 : term' -> Prims.string) = - fun projectee -> match projectee with | Real _0 -> _0 -let (uu___is_BoundV : term' -> Prims.bool) = - fun projectee -> match projectee with | BoundV _0 -> true | uu___ -> false -let (__proj__BoundV__item___0 : term' -> Prims.int) = - fun projectee -> match projectee with | BoundV _0 -> _0 -let (uu___is_FreeV : term' -> Prims.bool) = - fun projectee -> match projectee with | FreeV _0 -> true | uu___ -> false -let (__proj__FreeV__item___0 : term' -> fv) = - fun projectee -> match projectee with | FreeV _0 -> _0 -let (uu___is_App : term' -> Prims.bool) = - fun projectee -> match projectee with | App _0 -> true | uu___ -> false -let (__proj__App__item___0 : term' -> (op * term Prims.list)) = - fun projectee -> match projectee with | App _0 -> _0 -let (uu___is_Quant : term' -> Prims.bool) = - fun projectee -> match projectee with | Quant _0 -> true | uu___ -> false -let (__proj__Quant__item___0 : - term' -> - (qop * term Prims.list Prims.list * Prims.int - FStar_Pervasives_Native.option * sort Prims.list * term)) - = fun projectee -> match projectee with | Quant _0 -> _0 -let (uu___is_Let : term' -> Prims.bool) = - fun projectee -> match projectee with | Let _0 -> true | uu___ -> false -let (__proj__Let__item___0 : term' -> (term Prims.list * term)) = - fun projectee -> match projectee with | Let _0 -> _0 -let (uu___is_Labeled : term' -> Prims.bool) = - fun projectee -> match projectee with | Labeled _0 -> true | uu___ -> false -let (__proj__Labeled__item___0 : - term' -> - (term * FStar_Errors_Msg.error_message * FStar_Compiler_Range_Type.range)) - = fun projectee -> match projectee with | Labeled _0 -> _0 -let (uu___is_LblPos : term' -> Prims.bool) = - fun projectee -> match projectee with | LblPos _0 -> true | uu___ -> false -let (__proj__LblPos__item___0 : term' -> (term * Prims.string)) = - fun projectee -> match projectee with | LblPos _0 -> _0 -let (__proj__Mkterm__item__tm : term -> term') = - fun projectee -> match projectee with | { tm; freevars; rng;_} -> tm -let (__proj__Mkterm__item__freevars : - term -> fv Prims.list FStar_Syntax_Syntax.memo) = - fun projectee -> match projectee with | { tm; freevars; rng;_} -> freevars -let (__proj__Mkterm__item__rng : term -> FStar_Compiler_Range_Type.range) = - fun projectee -> match projectee with | { tm; freevars; rng;_} -> rng -let (uu___is_FV : fv -> Prims.bool) = fun projectee -> true -let (__proj__FV__item___0 : fv -> (Prims.string * sort * Prims.bool)) = - fun projectee -> match projectee with | FV _0 -> _0 -type pat = term -type fvs = fv Prims.list -type caption = Prims.string FStar_Pervasives_Native.option -type binders = (Prims.string * sort) Prims.list -type constructor_field = - { - field_name: Prims.string ; - field_sort: sort ; - field_projectible: Prims.bool } -let (__proj__Mkconstructor_field__item__field_name : - constructor_field -> Prims.string) = - fun projectee -> - match projectee with - | { field_name; field_sort; field_projectible;_} -> field_name -let (__proj__Mkconstructor_field__item__field_sort : - constructor_field -> sort) = - fun projectee -> - match projectee with - | { field_name; field_sort; field_projectible;_} -> field_sort -let (__proj__Mkconstructor_field__item__field_projectible : - constructor_field -> Prims.bool) = - fun projectee -> - match projectee with - | { field_name; field_sort; field_projectible;_} -> field_projectible -type constructor_t = - { - constr_name: Prims.string ; - constr_fields: constructor_field Prims.list ; - constr_sort: sort ; - constr_id: Prims.int FStar_Pervasives_Native.option ; - constr_base: Prims.bool } -let (__proj__Mkconstructor_t__item__constr_name : - constructor_t -> Prims.string) = - fun projectee -> - match projectee with - | { constr_name; constr_fields; constr_sort; constr_id; constr_base;_} -> - constr_name -let (__proj__Mkconstructor_t__item__constr_fields : - constructor_t -> constructor_field Prims.list) = - fun projectee -> - match projectee with - | { constr_name; constr_fields; constr_sort; constr_id; constr_base;_} -> - constr_fields -let (__proj__Mkconstructor_t__item__constr_sort : constructor_t -> sort) = - fun projectee -> - match projectee with - | { constr_name; constr_fields; constr_sort; constr_id; constr_base;_} -> - constr_sort -let (__proj__Mkconstructor_t__item__constr_id : - constructor_t -> Prims.int FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { constr_name; constr_fields; constr_sort; constr_id; constr_base;_} -> - constr_id -let (__proj__Mkconstructor_t__item__constr_base : - constructor_t -> Prims.bool) = - fun projectee -> - match projectee with - | { constr_name; constr_fields; constr_sort; constr_id; constr_base;_} -> - constr_base -type constructors = constructor_t Prims.list -type fact_db_id = - | Name of FStar_Ident.lid - | Namespace of FStar_Ident.lid - | Tag of Prims.string -let (uu___is_Name : fact_db_id -> Prims.bool) = - fun projectee -> match projectee with | Name _0 -> true | uu___ -> false -let (__proj__Name__item___0 : fact_db_id -> FStar_Ident.lid) = - fun projectee -> match projectee with | Name _0 -> _0 -let (uu___is_Namespace : fact_db_id -> Prims.bool) = - fun projectee -> - match projectee with | Namespace _0 -> true | uu___ -> false -let (__proj__Namespace__item___0 : fact_db_id -> FStar_Ident.lid) = - fun projectee -> match projectee with | Namespace _0 -> _0 -let (uu___is_Tag : fact_db_id -> Prims.bool) = - fun projectee -> match projectee with | Tag _0 -> true | uu___ -> false -let (__proj__Tag__item___0 : fact_db_id -> Prims.string) = - fun projectee -> match projectee with | Tag _0 -> _0 -type assumption = - { - assumption_term: term ; - assumption_caption: caption ; - assumption_name: Prims.string ; - assumption_fact_ids: fact_db_id Prims.list ; - assumption_free_names: Prims.string FStar_Compiler_RBSet.t } -let (__proj__Mkassumption__item__assumption_term : assumption -> term) = - fun projectee -> - match projectee with - | { assumption_term; assumption_caption; assumption_name; - assumption_fact_ids; assumption_free_names;_} -> assumption_term -let (__proj__Mkassumption__item__assumption_caption : assumption -> caption) - = - fun projectee -> - match projectee with - | { assumption_term; assumption_caption; assumption_name; - assumption_fact_ids; assumption_free_names;_} -> assumption_caption -let (__proj__Mkassumption__item__assumption_name : - assumption -> Prims.string) = - fun projectee -> - match projectee with - | { assumption_term; assumption_caption; assumption_name; - assumption_fact_ids; assumption_free_names;_} -> assumption_name -let (__proj__Mkassumption__item__assumption_fact_ids : - assumption -> fact_db_id Prims.list) = - fun projectee -> - match projectee with - | { assumption_term; assumption_caption; assumption_name; - assumption_fact_ids; assumption_free_names;_} -> assumption_fact_ids -let (__proj__Mkassumption__item__assumption_free_names : - assumption -> Prims.string FStar_Compiler_RBSet.t) = - fun projectee -> - match projectee with - | { assumption_term; assumption_caption; assumption_name; - assumption_fact_ids; assumption_free_names;_} -> - assumption_free_names -type decl = - | DefPrelude - | DeclFun of (Prims.string * sort Prims.list * sort * caption) - | DefineFun of (Prims.string * sort Prims.list * sort * term * caption) - | Assume of assumption - | Caption of Prims.string - | Module of (Prims.string * decl Prims.list) - | Eval of term - | Echo of Prims.string - | RetainAssumptions of Prims.string Prims.list - | Push of Prims.int - | Pop of Prims.int - | CheckSat - | GetUnsatCore - | SetOption of (Prims.string * Prims.string) - | GetStatistics - | GetReasonUnknown -let (uu___is_DefPrelude : decl -> Prims.bool) = - fun projectee -> match projectee with | DefPrelude -> true | uu___ -> false -let (uu___is_DeclFun : decl -> Prims.bool) = - fun projectee -> match projectee with | DeclFun _0 -> true | uu___ -> false -let (__proj__DeclFun__item___0 : - decl -> (Prims.string * sort Prims.list * sort * caption)) = - fun projectee -> match projectee with | DeclFun _0 -> _0 -let (uu___is_DefineFun : decl -> Prims.bool) = - fun projectee -> - match projectee with | DefineFun _0 -> true | uu___ -> false -let (__proj__DefineFun__item___0 : - decl -> (Prims.string * sort Prims.list * sort * term * caption)) = - fun projectee -> match projectee with | DefineFun _0 -> _0 -let (uu___is_Assume : decl -> Prims.bool) = - fun projectee -> match projectee with | Assume _0 -> true | uu___ -> false -let (__proj__Assume__item___0 : decl -> assumption) = - fun projectee -> match projectee with | Assume _0 -> _0 -let (uu___is_Caption : decl -> Prims.bool) = - fun projectee -> match projectee with | Caption _0 -> true | uu___ -> false -let (__proj__Caption__item___0 : decl -> Prims.string) = - fun projectee -> match projectee with | Caption _0 -> _0 -let (uu___is_Module : decl -> Prims.bool) = - fun projectee -> match projectee with | Module _0 -> true | uu___ -> false -let (__proj__Module__item___0 : decl -> (Prims.string * decl Prims.list)) = - fun projectee -> match projectee with | Module _0 -> _0 -let (uu___is_Eval : decl -> Prims.bool) = - fun projectee -> match projectee with | Eval _0 -> true | uu___ -> false -let (__proj__Eval__item___0 : decl -> term) = - fun projectee -> match projectee with | Eval _0 -> _0 -let (uu___is_Echo : decl -> Prims.bool) = - fun projectee -> match projectee with | Echo _0 -> true | uu___ -> false -let (__proj__Echo__item___0 : decl -> Prims.string) = - fun projectee -> match projectee with | Echo _0 -> _0 -let (uu___is_RetainAssumptions : decl -> Prims.bool) = - fun projectee -> - match projectee with | RetainAssumptions _0 -> true | uu___ -> false -let (__proj__RetainAssumptions__item___0 : decl -> Prims.string Prims.list) = - fun projectee -> match projectee with | RetainAssumptions _0 -> _0 -let (uu___is_Push : decl -> Prims.bool) = - fun projectee -> match projectee with | Push _0 -> true | uu___ -> false -let (__proj__Push__item___0 : decl -> Prims.int) = - fun projectee -> match projectee with | Push _0 -> _0 -let (uu___is_Pop : decl -> Prims.bool) = - fun projectee -> match projectee with | Pop _0 -> true | uu___ -> false -let (__proj__Pop__item___0 : decl -> Prims.int) = - fun projectee -> match projectee with | Pop _0 -> _0 -let (uu___is_CheckSat : decl -> Prims.bool) = - fun projectee -> match projectee with | CheckSat -> true | uu___ -> false -let (uu___is_GetUnsatCore : decl -> Prims.bool) = - fun projectee -> - match projectee with | GetUnsatCore -> true | uu___ -> false -let (uu___is_SetOption : decl -> Prims.bool) = - fun projectee -> - match projectee with | SetOption _0 -> true | uu___ -> false -let (__proj__SetOption__item___0 : decl -> (Prims.string * Prims.string)) = - fun projectee -> match projectee with | SetOption _0 -> _0 -let (uu___is_GetStatistics : decl -> Prims.bool) = - fun projectee -> - match projectee with | GetStatistics -> true | uu___ -> false -let (uu___is_GetReasonUnknown : decl -> Prims.bool) = - fun projectee -> - match projectee with | GetReasonUnknown -> true | uu___ -> false -type decls_elt = - { - sym_name: Prims.string FStar_Pervasives_Native.option ; - key: Prims.string FStar_Pervasives_Native.option ; - decls: decl Prims.list ; - a_names: Prims.string Prims.list } -let (__proj__Mkdecls_elt__item__sym_name : - decls_elt -> Prims.string FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with | { sym_name; key; decls; a_names;_} -> sym_name -let (__proj__Mkdecls_elt__item__key : - decls_elt -> Prims.string FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with | { sym_name; key; decls; a_names;_} -> key -let (__proj__Mkdecls_elt__item__decls : decls_elt -> decl Prims.list) = - fun projectee -> - match projectee with | { sym_name; key; decls; a_names;_} -> decls -let (__proj__Mkdecls_elt__item__a_names : - decls_elt -> Prims.string Prims.list) = - fun projectee -> - match projectee with | { sym_name; key; decls; a_names;_} -> a_names -type decls_t = decls_elt Prims.list -let (escape : Prims.string -> Prims.string) = - fun s -> FStar_Compiler_Util.replace_char s 39 95 -let rec (strSort : sort -> Prims.string) = - fun x -> - match x with - | Bool_sort -> "Bool" - | Int_sort -> "Int" - | Term_sort -> "Term" - | String_sort -> "FString" - | Fuel_sort -> "Fuel" - | BitVec_sort n -> - let uu___ = FStar_Compiler_Util.string_of_int n in - FStar_Compiler_Util.format1 "(_ BitVec %s)" uu___ - | Array (s1, s2) -> - let uu___ = strSort s1 in - let uu___1 = strSort s2 in - FStar_Compiler_Util.format2 "(Array %s %s)" uu___ uu___1 - | Arrow (s1, s2) -> - let uu___ = strSort s1 in - let uu___1 = strSort s2 in - FStar_Compiler_Util.format2 "(%s -> %s)" uu___ uu___1 - | Sort s -> s -let (mk_decls : - Prims.string -> - Prims.string -> decl Prims.list -> decls_elt Prims.list -> decls_t) - = - fun name -> - fun key -> - fun decls -> - fun aux_decls -> - let uu___ = - let uu___1 = - let sm = FStar_Compiler_Util.smap_create (Prims.of_int (20)) in - FStar_Compiler_List.iter - (fun elt -> - FStar_Compiler_List.iter - (fun s -> FStar_Compiler_Util.smap_add sm s "0") - elt.a_names) aux_decls; - FStar_Compiler_List.iter - (fun d -> - match d with - | Assume a -> - FStar_Compiler_Util.smap_add sm a.assumption_name "0" - | uu___4 -> ()) decls; - FStar_Compiler_Util.smap_keys sm in - { - sym_name = (FStar_Pervasives_Native.Some name); - key = (FStar_Pervasives_Native.Some key); - decls; - a_names = uu___1 - } in - [uu___] -let (mk_decls_trivial : decl Prims.list -> decls_t) = - fun decls -> - let uu___ = - let uu___1 = - FStar_Compiler_List.collect - (fun uu___2 -> - match uu___2 with - | Assume a -> [a.assumption_name] - | uu___3 -> []) decls in - { - sym_name = FStar_Pervasives_Native.None; - key = FStar_Pervasives_Native.None; - decls; - a_names = uu___1 - } in - [uu___] -let (decls_list_of : decls_t -> decl Prims.list) = - fun l -> FStar_Compiler_List.collect (fun elt -> elt.decls) l -let (mk_fv : (Prims.string * sort) -> fv) = - fun uu___ -> match uu___ with | (x, y) -> FV (x, y, false) -let (fv_name : fv -> Prims.string) = - fun x -> let uu___ = x in match uu___ with | FV (nm, uu___1, uu___2) -> nm -let (deq_fv : fv FStar_Class_Deq.deq) = - { - FStar_Class_Deq.op_Equals_Question = - (fun fv1 -> - fun fv2 -> - let uu___ = fv_name fv1 in - let uu___1 = fv_name fv2 in uu___ = uu___1) - } -let (ord_fv : fv FStar_Class_Ord.ord) = - { - FStar_Class_Ord.super = deq_fv; - FStar_Class_Ord.cmp = - (fun fv1 -> - fun fv2 -> - let uu___ = - let uu___1 = fv_name fv1 in - let uu___2 = fv_name fv2 in - FStar_Compiler_Util.compare uu___1 uu___2 in - FStar_Compiler_Order.order_from_int uu___) - } -let (fv_sort : fv -> sort) = - fun x -> - let uu___ = x in match uu___ with | FV (uu___1, sort1, uu___2) -> sort1 -let (fv_force : fv -> Prims.bool) = - fun x -> - let uu___ = x in match uu___ with | FV (uu___1, uu___2, force) -> force -type error_label = - (fv * FStar_Errors_Msg.error_message * FStar_Compiler_Range_Type.range) -type error_labels = error_label Prims.list -let (fv_eq : fv -> fv -> Prims.bool) = - fun x -> - fun y -> - let uu___ = fv_name x in let uu___1 = fv_name y in uu___ = uu___1 -let (fvs_subset_of : fvs -> fvs -> Prims.bool) = - fun x -> - fun y -> - let uu___ = - Obj.magic - (FStar_Class_Setlike.from_list () - (Obj.magic (FStar_Compiler_RBSet.setlike_rbset ord_fv)) x) in - let uu___1 = - Obj.magic - (FStar_Class_Setlike.from_list () - (Obj.magic (FStar_Compiler_RBSet.setlike_rbset ord_fv)) y) in - FStar_Class_Setlike.subset () - (Obj.magic (FStar_Compiler_RBSet.setlike_rbset ord_fv)) - (Obj.magic uu___) (Obj.magic uu___1) -let (freevar_eq : term -> term -> Prims.bool) = - fun x -> - fun y -> - match ((x.tm), (y.tm)) with - | (FreeV x1, FreeV y1) -> fv_eq x1 y1 - | uu___ -> false -let (freevar_sort : term -> sort) = - fun uu___ -> - match uu___ with - | { tm = FreeV x; freevars = uu___1; rng = uu___2;_} -> fv_sort x - | uu___1 -> failwith "impossible" -let (fv_of_term : term -> fv) = - fun uu___ -> - match uu___ with - | { tm = FreeV fv1; freevars = uu___1; rng = uu___2;_} -> fv1 - | uu___1 -> failwith "impossible" -let rec (freevars : term -> fv Prims.list) = - fun t -> - match t.tm with - | Integer uu___ -> [] - | String uu___ -> [] - | Real uu___ -> [] - | BoundV uu___ -> [] - | FreeV fv1 when fv_force fv1 -> [] - | FreeV fv1 -> [fv1] - | App (uu___, tms) -> FStar_Compiler_List.collect freevars tms - | Quant (uu___, uu___1, uu___2, uu___3, t1) -> freevars t1 - | Labeled (t1, uu___, uu___1) -> freevars t1 - | LblPos (t1, uu___) -> freevars t1 - | Let (es, body) -> FStar_Compiler_List.collect freevars (body :: es) -let (free_variables : term -> fvs) = - fun t -> - let uu___ = FStar_Compiler_Effect.op_Bang t.freevars in - match uu___ with - | FStar_Pervasives_Native.Some b -> b - | FStar_Pervasives_Native.None -> - let fvs1 = - let uu___1 = freevars t in - FStar_Compiler_Util.remove_dups fv_eq uu___1 in - (FStar_Compiler_Effect.op_Colon_Equals t.freevars - (FStar_Pervasives_Native.Some fvs1); - fvs1) -let (free_top_level_names : term -> Prims.string FStar_Compiler_RBSet.t) = - fun t -> - let rec free_top_level_names1 uu___1 uu___ = - (fun acc -> - fun t1 -> - match t1.tm with - | FreeV (FV (nm, uu___, uu___1)) -> - Obj.magic - (Obj.repr - (FStar_Class_Setlike.add () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) nm (Obj.magic acc))) - | App (Var s, args) -> - Obj.magic - (Obj.repr - (let acc1 = - Obj.magic - (FStar_Class_Setlike.add () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) s - (Obj.magic acc)) in - FStar_Compiler_List.fold_left free_top_level_names1 acc1 - args)) - | App (uu___, args) -> - Obj.magic - (Obj.repr - (FStar_Compiler_List.fold_left free_top_level_names1 acc - args)) - | Quant (uu___, pats, uu___1, uu___2, body) -> - Obj.magic - (Obj.repr - (let acc1 = - FStar_Compiler_List.fold_left - (fun acc2 -> - fun pats1 -> - FStar_Compiler_List.fold_left - free_top_level_names1 acc2 pats1) acc pats in - free_top_level_names1 acc1 body)) - | Let (tms, t2) -> - Obj.magic - (Obj.repr - (let acc1 = - FStar_Compiler_List.fold_left free_top_level_names1 - acc tms in - free_top_level_names1 acc1 t2)) - | Labeled (t2, uu___, uu___1) -> - Obj.magic (Obj.repr (free_top_level_names1 acc t2)) - | LblPos (t2, uu___) -> - Obj.magic (Obj.repr (free_top_level_names1 acc t2)) - | uu___ -> Obj.magic (Obj.repr acc)) uu___1 uu___ in - let uu___ = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset FStar_Class_Ord.ord_string)) - ()) in - free_top_level_names1 uu___ t -let (qop_to_string : qop -> Prims.string) = - fun uu___ -> match uu___ with | Forall -> "forall" | Exists -> "exists" -let (op_to_string : op -> Prims.string) = - fun uu___ -> - match uu___ with - | TrueOp -> "true" - | FalseOp -> "false" - | Not -> "not" - | And -> "and" - | Or -> "or" - | Imp -> "implies" - | Iff -> "iff" - | Eq -> "=" - | LT -> "<" - | LTE -> "<=" - | GT -> ">" - | GTE -> ">=" - | Add -> "+" - | Sub -> "-" - | Div -> "div" - | RealDiv -> "/" - | Mul -> "*" - | Minus -> "-" - | Mod -> "mod" - | ITE -> "ite" - | BvAnd -> "bvand" - | BvXor -> "bvxor" - | BvOr -> "bvor" - | BvAdd -> "bvadd" - | BvSub -> "bvsub" - | BvShl -> "bvshl" - | BvShr -> "bvlshr" - | BvUdiv -> "bvudiv" - | BvMod -> "bvurem" - | BvMul -> "bvmul" - | BvUlt -> "bvult" - | BvToNat -> "bv2int" - | BvUext n -> - let uu___1 = FStar_Compiler_Util.string_of_int n in - FStar_Compiler_Util.format1 "(_ zero_extend %s)" uu___1 - | NatToBv n -> - let uu___1 = FStar_Compiler_Util.string_of_int n in - FStar_Compiler_Util.format1 "(_ int2bv %s)" uu___1 - | Var s -> s -let (weightToSmt : Prims.int FStar_Pervasives_Native.option -> Prims.string) - = - fun uu___ -> - match uu___ with - | FStar_Pervasives_Native.None -> "" - | FStar_Pervasives_Native.Some i -> - let uu___1 = FStar_Compiler_Util.string_of_int i in - FStar_Compiler_Util.format1 ":weight %s\n" uu___1 -let rec (hash_of_term' : term' -> Prims.string) = - fun t -> - match t with - | Integer i -> i - | String s -> s - | Real r -> r - | BoundV i -> - let uu___ = FStar_Compiler_Util.string_of_int i in - Prims.strcat "@" uu___ - | FreeV x -> - let uu___ = fv_name x in - let uu___1 = - let uu___2 = let uu___3 = fv_sort x in strSort uu___3 in - Prims.strcat ":" uu___2 in - Prims.strcat uu___ uu___1 - | App (op1, tms) -> - let uu___ = - let uu___1 = op_to_string op1 in - let uu___2 = - let uu___3 = - let uu___4 = FStar_Compiler_List.map hash_of_term tms in - FStar_Compiler_String.concat " " uu___4 in - Prims.strcat uu___3 ")" in - Prims.strcat uu___1 uu___2 in - Prims.strcat "(" uu___ - | Labeled (t1, r1, r2) -> - let uu___ = hash_of_term t1 in - let uu___1 = - let uu___2 = FStar_Errors_Msg.rendermsg r1 in - let uu___3 = FStar_Compiler_Range_Ops.string_of_range r2 in - Prims.strcat uu___2 uu___3 in - Prims.strcat uu___ uu___1 - | LblPos (t1, r) -> - let uu___ = - let uu___1 = hash_of_term t1 in - Prims.strcat uu___1 (Prims.strcat " :lblpos " (Prims.strcat r ")")) in - Prims.strcat "(! " uu___ - | Quant (qop1, pats, wopt, sorts, body) -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Compiler_List.map strSort sorts in - FStar_Compiler_String.concat " " uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = hash_of_term body in - let uu___7 = - let uu___8 = - let uu___9 = weightToSmt wopt in - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Compiler_List.map - (fun pats1 -> - let uu___14 = - FStar_Compiler_List.map hash_of_term - pats1 in - FStar_Compiler_String.concat " " uu___14) - pats in - FStar_Compiler_String.concat "; " uu___13 in - Prims.strcat uu___12 "))" in - Prims.strcat " " uu___11 in - Prims.strcat uu___9 uu___10 in - Prims.strcat " " uu___8 in - Prims.strcat uu___6 uu___7 in - Prims.strcat ")(! " uu___5 in - Prims.strcat uu___3 uu___4 in - Prims.strcat " (" uu___2 in - Prims.strcat (qop_to_string qop1) uu___1 in - Prims.strcat "(" uu___ - | Let (es, body) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Compiler_List.map hash_of_term es in - FStar_Compiler_String.concat " " uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = hash_of_term body in Prims.strcat uu___4 ")" in - Prims.strcat ") " uu___3 in - Prims.strcat uu___1 uu___2 in - Prims.strcat "(let (" uu___ -and (hash_of_term : term -> Prims.string) = fun tm -> hash_of_term' tm.tm -let (mkBoxFunctions : Prims.string -> (Prims.string * Prims.string)) = - fun s -> (s, (Prims.strcat s "_proj_0")) -let (boxIntFun : (Prims.string * Prims.string)) = mkBoxFunctions "BoxInt" -let (boxBoolFun : (Prims.string * Prims.string)) = mkBoxFunctions "BoxBool" -let (boxStringFun : (Prims.string * Prims.string)) = - mkBoxFunctions "BoxString" -let (boxBitVecFun : Prims.int -> (Prims.string * Prims.string)) = - fun sz -> - let uu___ = - let uu___1 = FStar_Compiler_Util.string_of_int sz in - Prims.strcat "BoxBitVec" uu___1 in - mkBoxFunctions uu___ -let (boxRealFun : (Prims.string * Prims.string)) = mkBoxFunctions "BoxReal" -let (isInjective : Prims.string -> Prims.bool) = - fun s -> - if (FStar_String.strlen s) >= (Prims.of_int (3)) - then - (let uu___ = - FStar_Compiler_String.substring s Prims.int_zero (Prims.of_int (3)) in - uu___ = "Box") && - (let uu___ = - FStar_Compiler_List.existsML (fun c -> c = 46) - (FStar_String.list_of_string s) in - Prims.op_Negation uu___) - else false -let (mk : term' -> FStar_Compiler_Range_Type.range -> term) = - fun t -> - fun r -> - let uu___ = FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None in - { tm = t; freevars = uu___; rng = r } -let (mkTrue : FStar_Compiler_Range_Type.range -> term) = - fun r -> mk (App (TrueOp, [])) r -let (mkFalse : FStar_Compiler_Range_Type.range -> term) = - fun r -> mk (App (FalseOp, [])) r -let (mkUnreachable : term) = - mk (App ((Var "Unreachable"), [])) FStar_Compiler_Range_Type.dummyRange -let (mkInteger : Prims.string -> FStar_Compiler_Range_Type.range -> term) = - fun i -> - fun r -> - let uu___ = - let uu___1 = FStar_Compiler_Util.ensure_decimal i in Integer uu___1 in - mk uu___ r -let (mkInteger' : Prims.int -> FStar_Compiler_Range_Type.range -> term) = - fun i -> - fun r -> - let uu___ = FStar_Compiler_Util.string_of_int i in mkInteger uu___ r -let (mkReal : Prims.string -> FStar_Compiler_Range_Type.range -> term) = - fun i -> fun r -> mk (Real i) r -let (mkBoundV : Prims.int -> FStar_Compiler_Range_Type.range -> term) = - fun i -> fun r -> mk (BoundV i) r -let (mkFreeV : fv -> FStar_Compiler_Range_Type.range -> term) = - fun x -> fun r -> mk (FreeV x) r -let (mkApp' : - (op * term Prims.list) -> FStar_Compiler_Range_Type.range -> term) = - fun f -> fun r -> mk (App f) r -let (mkApp : - (Prims.string * term Prims.list) -> FStar_Compiler_Range_Type.range -> term) - = - fun uu___ -> - fun r -> match uu___ with | (s, args) -> mk (App ((Var s), args)) r -let (mkNot : term -> FStar_Compiler_Range_Type.range -> term) = - fun t -> - fun r -> - match t.tm with - | App (TrueOp, uu___) -> mkFalse r - | App (FalseOp, uu___) -> mkTrue r - | uu___ -> mkApp' (Not, [t]) r -let (mkAnd : (term * term) -> FStar_Compiler_Range_Type.range -> term) = - fun uu___ -> - fun r -> - match uu___ with - | (t1, t2) -> - (match ((t1.tm), (t2.tm)) with - | (App (TrueOp, uu___1), uu___2) -> t2 - | (uu___1, App (TrueOp, uu___2)) -> t1 - | (App (FalseOp, uu___1), uu___2) -> mkFalse r - | (uu___1, App (FalseOp, uu___2)) -> mkFalse r - | (App (And, ts1), App (And, ts2)) -> - mkApp' (And, (FStar_Compiler_List.op_At ts1 ts2)) r - | (uu___1, App (And, ts2)) -> mkApp' (And, (t1 :: ts2)) r - | (App (And, ts1), uu___1) -> - mkApp' (And, (FStar_Compiler_List.op_At ts1 [t2])) r - | uu___1 -> mkApp' (And, [t1; t2]) r) -let (mkOr : (term * term) -> FStar_Compiler_Range_Type.range -> term) = - fun uu___ -> - fun r -> - match uu___ with - | (t1, t2) -> - (match ((t1.tm), (t2.tm)) with - | (App (TrueOp, uu___1), uu___2) -> mkTrue r - | (uu___1, App (TrueOp, uu___2)) -> mkTrue r - | (App (FalseOp, uu___1), uu___2) -> t2 - | (uu___1, App (FalseOp, uu___2)) -> t1 - | (App (Or, ts1), App (Or, ts2)) -> - mkApp' (Or, (FStar_Compiler_List.op_At ts1 ts2)) r - | (uu___1, App (Or, ts2)) -> mkApp' (Or, (t1 :: ts2)) r - | (App (Or, ts1), uu___1) -> - mkApp' (Or, (FStar_Compiler_List.op_At ts1 [t2])) r - | uu___1 -> mkApp' (Or, [t1; t2]) r) -let (mkImp : (term * term) -> FStar_Compiler_Range_Type.range -> term) = - fun uu___ -> - fun r -> - match uu___ with - | (t1, t2) -> - (match ((t1.tm), (t2.tm)) with - | (uu___1, App (TrueOp, uu___2)) -> mkTrue r - | (App (FalseOp, uu___1), uu___2) -> mkTrue r - | (App (TrueOp, uu___1), uu___2) -> t2 - | (uu___1, App (Imp, t1'::t2'::[])) -> - let uu___2 = - let uu___3 = let uu___4 = mkAnd (t1, t1') r in [uu___4; t2'] in - (Imp, uu___3) in - mkApp' uu___2 r - | uu___1 -> mkApp' (Imp, [t1; t2]) r) -let (mk_bin_op : - op -> (term * term) -> FStar_Compiler_Range_Type.range -> term) = - fun op1 -> - fun uu___ -> - fun r -> match uu___ with | (t1, t2) -> mkApp' (op1, [t1; t2]) r -let (mkMinus : term -> FStar_Compiler_Range_Type.range -> term) = - fun t -> fun r -> mkApp' (Minus, [t]) r -let (mkNatToBv : - Prims.int -> term -> FStar_Compiler_Range_Type.range -> term) = - fun sz -> fun t -> fun r -> mkApp' ((NatToBv sz), [t]) r -let (mkBvUext : Prims.int -> term -> FStar_Compiler_Range_Type.range -> term) - = fun sz -> fun t -> fun r -> mkApp' ((BvUext sz), [t]) r -let (mkBvToNat : term -> FStar_Compiler_Range_Type.range -> term) = - fun t -> fun r -> mkApp' (BvToNat, [t]) r -let (mkBvAnd : (term * term) -> FStar_Compiler_Range_Type.range -> term) = - mk_bin_op BvAnd -let (mkBvXor : (term * term) -> FStar_Compiler_Range_Type.range -> term) = - mk_bin_op BvXor -let (mkBvOr : (term * term) -> FStar_Compiler_Range_Type.range -> term) = - mk_bin_op BvOr -let (mkBvAdd : (term * term) -> FStar_Compiler_Range_Type.range -> term) = - mk_bin_op BvAdd -let (mkBvSub : (term * term) -> FStar_Compiler_Range_Type.range -> term) = - mk_bin_op BvSub -let (mkBvShl : - Prims.int -> (term * term) -> FStar_Compiler_Range_Type.range -> term) = - fun sz -> - fun uu___ -> - fun r -> - match uu___ with - | (t1, t2) -> - let uu___1 = - let uu___2 = - let uu___3 = let uu___4 = mkNatToBv sz t2 r in [uu___4] in t1 - :: uu___3 in - (BvShl, uu___2) in - mkApp' uu___1 r -let (mkBvShr : - Prims.int -> (term * term) -> FStar_Compiler_Range_Type.range -> term) = - fun sz -> - fun uu___ -> - fun r -> - match uu___ with - | (t1, t2) -> - let uu___1 = - let uu___2 = - let uu___3 = let uu___4 = mkNatToBv sz t2 r in [uu___4] in t1 - :: uu___3 in - (BvShr, uu___2) in - mkApp' uu___1 r -let (mkBvUdiv : - Prims.int -> (term * term) -> FStar_Compiler_Range_Type.range -> term) = - fun sz -> - fun uu___ -> - fun r -> - match uu___ with - | (t1, t2) -> - let uu___1 = - let uu___2 = - let uu___3 = let uu___4 = mkNatToBv sz t2 r in [uu___4] in t1 - :: uu___3 in - (BvUdiv, uu___2) in - mkApp' uu___1 r -let (mkBvMod : - Prims.int -> (term * term) -> FStar_Compiler_Range_Type.range -> term) = - fun sz -> - fun uu___ -> - fun r -> - match uu___ with - | (t1, t2) -> - let uu___1 = - let uu___2 = - let uu___3 = let uu___4 = mkNatToBv sz t2 r in [uu___4] in t1 - :: uu___3 in - (BvMod, uu___2) in - mkApp' uu___1 r -let (mkBvMul : - Prims.int -> (term * term) -> FStar_Compiler_Range_Type.range -> term) = - fun sz -> - fun uu___ -> - fun r -> - match uu___ with - | (t1, t2) -> - let uu___1 = - let uu___2 = - let uu___3 = let uu___4 = mkNatToBv sz t2 r in [uu___4] in t1 - :: uu___3 in - (BvMul, uu___2) in - mkApp' uu___1 r -let (mkBvShl' : - Prims.int -> (term * term) -> FStar_Compiler_Range_Type.range -> term) = - fun sz -> - fun uu___ -> - fun r -> match uu___ with | (t1, t2) -> mkApp' (BvShl, [t1; t2]) r -let (mkBvShr' : - Prims.int -> (term * term) -> FStar_Compiler_Range_Type.range -> term) = - fun sz -> - fun uu___ -> - fun r -> match uu___ with | (t1, t2) -> mkApp' (BvShr, [t1; t2]) r -let (mkBvMul' : - Prims.int -> (term * term) -> FStar_Compiler_Range_Type.range -> term) = - fun sz -> - fun uu___ -> - fun r -> match uu___ with | (t1, t2) -> mkApp' (BvMul, [t1; t2]) r -let (mkBvUdivUnsafe : - Prims.int -> (term * term) -> FStar_Compiler_Range_Type.range -> term) = - fun sz -> - fun uu___ -> - fun r -> match uu___ with | (t1, t2) -> mkApp' (BvUdiv, [t1; t2]) r -let (mkBvModUnsafe : - Prims.int -> (term * term) -> FStar_Compiler_Range_Type.range -> term) = - fun sz -> - fun uu___ -> - fun r -> match uu___ with | (t1, t2) -> mkApp' (BvMod, [t1; t2]) r -let (mkBvUlt : (term * term) -> FStar_Compiler_Range_Type.range -> term) = - mk_bin_op BvUlt -let (mkIff : (term * term) -> FStar_Compiler_Range_Type.range -> term) = - mk_bin_op Iff -let (mkEq : (term * term) -> FStar_Compiler_Range_Type.range -> term) = - fun uu___ -> - fun r -> - match uu___ with - | (t1, t2) -> - (match ((t1.tm), (t2.tm)) with - | (App (Var f1, s1::[]), App (Var f2, s2::[])) when - (f1 = f2) && (isInjective f1) -> mk_bin_op Eq (s1, s2) r - | uu___1 -> mk_bin_op Eq (t1, t2) r) -let (mkLT : (term * term) -> FStar_Compiler_Range_Type.range -> term) = - mk_bin_op LT -let (mkLTE : (term * term) -> FStar_Compiler_Range_Type.range -> term) = - mk_bin_op LTE -let (mkGT : (term * term) -> FStar_Compiler_Range_Type.range -> term) = - mk_bin_op GT -let (mkGTE : (term * term) -> FStar_Compiler_Range_Type.range -> term) = - mk_bin_op GTE -let (mkAdd : (term * term) -> FStar_Compiler_Range_Type.range -> term) = - mk_bin_op Add -let (mkSub : (term * term) -> FStar_Compiler_Range_Type.range -> term) = - mk_bin_op Sub -let (mkDiv : (term * term) -> FStar_Compiler_Range_Type.range -> term) = - mk_bin_op Div -let (mkRealDiv : (term * term) -> FStar_Compiler_Range_Type.range -> term) = - mk_bin_op RealDiv -let (mkMul : (term * term) -> FStar_Compiler_Range_Type.range -> term) = - mk_bin_op Mul -let (mkMod : (term * term) -> FStar_Compiler_Range_Type.range -> term) = - mk_bin_op Mod -let (mkRealOfInt : term -> FStar_Compiler_Range_Type.range -> term) = - fun t -> fun r -> mkApp ("to_real", [t]) r -let (mkITE : (term * term * term) -> FStar_Compiler_Range_Type.range -> term) - = - fun uu___ -> - fun r -> - match uu___ with - | (t1, t2, t3) -> - (match t1.tm with - | App (TrueOp, uu___1) -> t2 - | App (FalseOp, uu___1) -> t3 - | uu___1 -> - (match ((t2.tm), (t3.tm)) with - | (App (TrueOp, uu___2), App (TrueOp, uu___3)) -> mkTrue r - | (App (TrueOp, uu___2), uu___3) -> - let uu___4 = let uu___5 = mkNot t1 t1.rng in (uu___5, t3) in - mkImp uu___4 r - | (uu___2, App (TrueOp, uu___3)) -> mkImp (t1, t2) r - | (uu___2, uu___3) -> mkApp' (ITE, [t1; t2; t3]) r)) -let (mkCases : term Prims.list -> FStar_Compiler_Range_Type.range -> term) = - fun t -> - fun r -> - match t with - | [] -> failwith "Impos" - | hd::tl -> - FStar_Compiler_List.fold_left - (fun out -> fun t1 -> mkAnd (out, t1) r) hd tl -let (check_pattern_ok : term -> term FStar_Pervasives_Native.option) = - fun t -> - let rec aux t1 = - match t1.tm with - | Integer uu___ -> FStar_Pervasives_Native.None - | String uu___ -> FStar_Pervasives_Native.None - | Real uu___ -> FStar_Pervasives_Native.None - | BoundV uu___ -> FStar_Pervasives_Native.None - | FreeV uu___ -> FStar_Pervasives_Native.None - | Let (tms, tm) -> aux_l (tm :: tms) - | App (head, terms) -> - let head_ok = - match head with - | Var uu___ -> true - | TrueOp -> true - | FalseOp -> true - | Not -> false - | And -> false - | Or -> false - | Imp -> false - | Iff -> false - | Eq -> false - | LT -> true - | LTE -> true - | GT -> true - | GTE -> true - | Add -> true - | Sub -> true - | Div -> true - | RealDiv -> true - | Mul -> true - | Minus -> true - | Mod -> true - | BvAnd -> false - | BvXor -> false - | BvOr -> false - | BvAdd -> false - | BvSub -> false - | BvShl -> false - | BvShr -> false - | BvUdiv -> false - | BvMod -> false - | BvMul -> false - | BvUlt -> false - | BvUext uu___ -> false - | NatToBv uu___ -> false - | BvToNat -> false - | ITE -> false in - if Prims.op_Negation head_ok - then FStar_Pervasives_Native.Some t1 - else aux_l terms - | Labeled (t2, uu___, uu___1) -> aux t2 - | Quant uu___ -> FStar_Pervasives_Native.Some t1 - | LblPos uu___ -> FStar_Pervasives_Native.Some t1 - and aux_l ts = - match ts with - | [] -> FStar_Pervasives_Native.None - | t1::ts1 -> - let uu___ = aux t1 in - (match uu___ with - | FStar_Pervasives_Native.Some t2 -> - FStar_Pervasives_Native.Some t2 - | FStar_Pervasives_Native.None -> aux_l ts1) in - aux t -let rec (print_smt_term : term -> Prims.string) = - fun t -> - match t.tm with - | Integer n -> FStar_Compiler_Util.format1 "(Integer %s)" n - | String s -> FStar_Compiler_Util.format1 "(String %s)" s - | Real r -> FStar_Compiler_Util.format1 "(Real %s)" r - | BoundV n -> - let uu___ = FStar_Compiler_Util.string_of_int n in - FStar_Compiler_Util.format1 "(BoundV %s)" uu___ - | FreeV fv1 -> - let uu___ = fv_name fv1 in - FStar_Compiler_Util.format1 "(FreeV %s)" uu___ - | App (op1, l) -> - let uu___ = op_to_string op1 in - let uu___1 = print_smt_term_list l in - FStar_Compiler_Util.format2 "(%s %s)" uu___ uu___1 - | Labeled (t1, r1, r2) -> - let uu___ = FStar_Errors_Msg.rendermsg r1 in - let uu___1 = print_smt_term t1 in - FStar_Compiler_Util.format2 "(Labeled '%s' %s)" uu___ uu___1 - | LblPos (t1, s) -> - let uu___ = print_smt_term t1 in - FStar_Compiler_Util.format2 "(LblPos %s %s)" s uu___ - | Quant (qop1, l, uu___, uu___1, t1) -> - let uu___2 = print_smt_term_list_list l in - let uu___3 = print_smt_term t1 in - FStar_Compiler_Util.format3 "(%s %s %s)" (qop_to_string qop1) uu___2 - uu___3 - | Let (es, body) -> - let uu___ = print_smt_term_list es in - let uu___1 = print_smt_term body in - FStar_Compiler_Util.format2 "(let %s %s)" uu___ uu___1 -and (print_smt_term_list : term Prims.list -> Prims.string) = - fun l -> - let uu___ = FStar_Compiler_List.map print_smt_term l in - FStar_Compiler_String.concat " " uu___ -and (print_smt_term_list_list : term Prims.list Prims.list -> Prims.string) = - fun l -> - FStar_Compiler_List.fold_left - (fun s -> - fun l1 -> - let uu___ = - let uu___1 = - let uu___2 = print_smt_term_list l1 in - Prims.strcat uu___2 " ] " in - Prims.strcat "; [ " uu___1 in - Prims.strcat s uu___) "" l -let (mkQuant : - FStar_Compiler_Range_Type.range -> - Prims.bool -> - (qop * term Prims.list Prims.list * Prims.int - FStar_Pervasives_Native.option * sort Prims.list * term) -> term) - = - fun r -> - fun check_pats -> - fun uu___ -> - match uu___ with - | (qop1, pats, wopt, vars, body) -> - let all_pats_ok pats1 = - if Prims.op_Negation check_pats - then pats1 - else - (let uu___2 = - FStar_Compiler_Util.find_map pats1 - (fun x -> - FStar_Compiler_Util.find_map x check_pattern_ok) in - match uu___2 with - | FStar_Pervasives_Native.None -> pats1 - | FStar_Pervasives_Native.Some p -> - ((let uu___4 = - let uu___5 = print_smt_term p in - FStar_Compiler_Util.format1 - "Pattern (%s) contains illegal symbols; dropping it" - uu___5 in - FStar_Errors.log_issue - FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Warning_SMTPatternIllFormed () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4)); - [])) in - if (FStar_Compiler_List.length vars) = Prims.int_zero - then body - else - (match body.tm with - | App (TrueOp, uu___2) -> body - | uu___2 -> - let uu___3 = - let uu___4 = - let uu___5 = all_pats_ok pats in - (qop1, uu___5, wopt, vars, body) in - Quant uu___4 in - mk uu___3 r) -let (mkLet : - (term Prims.list * term) -> FStar_Compiler_Range_Type.range -> term) = - fun uu___ -> - fun r -> - match uu___ with - | (es, body) -> - if (FStar_Compiler_List.length es) = Prims.int_zero - then body - else mk (Let (es, body)) r -let (abstr : fv Prims.list -> term -> term) = - fun fvs1 -> - fun t -> - let nvars = FStar_Compiler_List.length fvs1 in - let index_of fv1 = - let uu___ = FStar_Compiler_Util.try_find_index (fv_eq fv1) fvs1 in - match uu___ with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some i -> - FStar_Pervasives_Native.Some (nvars - (i + Prims.int_one)) in - let rec aux ix t1 = - let uu___ = FStar_Compiler_Effect.op_Bang t1.freevars in - match uu___ with - | FStar_Pervasives_Native.Some [] -> t1 - | uu___1 -> - (match t1.tm with - | Integer uu___2 -> t1 - | String uu___2 -> t1 - | Real uu___2 -> t1 - | BoundV uu___2 -> t1 - | FreeV x -> - let uu___2 = index_of x in - (match uu___2 with - | FStar_Pervasives_Native.None -> t1 - | FStar_Pervasives_Native.Some i -> - mkBoundV (i + ix) t1.rng) - | App (op1, tms) -> - let uu___2 = - let uu___3 = FStar_Compiler_List.map (aux ix) tms in - (op1, uu___3) in - mkApp' uu___2 t1.rng - | Labeled (t2, r1, r2) -> - let uu___2 = - let uu___3 = let uu___4 = aux ix t2 in (uu___4, r1, r2) in - Labeled uu___3 in - mk uu___2 t2.rng - | LblPos (t2, r) -> - let uu___2 = - let uu___3 = let uu___4 = aux ix t2 in (uu___4, r) in - LblPos uu___3 in - mk uu___2 t2.rng - | Quant (qop1, pats, wopt, vars, body) -> - let n = FStar_Compiler_List.length vars in - let uu___2 = - let uu___3 = - FStar_Compiler_List.map - (FStar_Compiler_List.map (aux (ix + n))) pats in - let uu___4 = aux (ix + n) body in - (qop1, uu___3, wopt, vars, uu___4) in - mkQuant t1.rng false uu___2 - | Let (es, body) -> - let uu___2 = - FStar_Compiler_List.fold_left - (fun uu___3 -> - fun e -> - match uu___3 with - | (ix1, l) -> - let uu___4 = - let uu___5 = aux ix1 e in uu___5 :: l in - ((ix1 + Prims.int_one), uu___4)) (ix, []) es in - (match uu___2 with - | (ix1, es_rev) -> - let uu___3 = - let uu___4 = aux ix1 body in - ((FStar_Compiler_List.rev es_rev), uu___4) in - mkLet uu___3 t1.rng)) in - aux Prims.int_zero t -let (inst : term Prims.list -> term -> term) = - fun tms -> - fun t -> - let tms1 = FStar_Compiler_List.rev tms in - let n = FStar_Compiler_List.length tms1 in - let rec aux shift t1 = - match t1.tm with - | Integer uu___ -> t1 - | String uu___ -> t1 - | Real uu___ -> t1 - | FreeV uu___ -> t1 - | BoundV i -> - if (Prims.int_zero <= (i - shift)) && ((i - shift) < n) - then FStar_Compiler_List.nth tms1 (i - shift) - else t1 - | App (op1, tms2) -> - let uu___ = - let uu___1 = FStar_Compiler_List.map (aux shift) tms2 in - (op1, uu___1) in - mkApp' uu___ t1.rng - | Labeled (t2, r1, r2) -> - let uu___ = - let uu___1 = let uu___2 = aux shift t2 in (uu___2, r1, r2) in - Labeled uu___1 in - mk uu___ t2.rng - | LblPos (t2, r) -> - let uu___ = - let uu___1 = let uu___2 = aux shift t2 in (uu___2, r) in - LblPos uu___1 in - mk uu___ t2.rng - | Quant (qop1, pats, wopt, vars, body) -> - let m = FStar_Compiler_List.length vars in - let shift1 = shift + m in - let uu___ = - let uu___1 = - FStar_Compiler_List.map - (FStar_Compiler_List.map (aux shift1)) pats in - let uu___2 = aux shift1 body in - (qop1, uu___1, wopt, vars, uu___2) in - mkQuant t1.rng false uu___ - | Let (es, body) -> - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun e -> - match uu___1 with - | (ix, es1) -> - let uu___2 = - let uu___3 = aux shift e in uu___3 :: es1 in - ((shift + Prims.int_one), uu___2)) (shift, []) es in - (match uu___ with - | (shift1, es_rev) -> - let uu___1 = - let uu___2 = aux shift1 body in - ((FStar_Compiler_List.rev es_rev), uu___2) in - mkLet uu___1 t1.rng) in - aux Prims.int_zero t -let (subst : term -> fv -> term -> term) = - fun t -> fun fv1 -> fun s -> let uu___ = abstr [fv1] t in inst [s] uu___ -let (mkQuant' : - FStar_Compiler_Range_Type.range -> - (qop * term Prims.list Prims.list * Prims.int - FStar_Pervasives_Native.option * fv Prims.list * term) -> term) - = - fun r -> - fun uu___ -> - match uu___ with - | (qop1, pats, wopt, vars, body) -> - let uu___1 = - let uu___2 = - FStar_Compiler_List.map (FStar_Compiler_List.map (abstr vars)) - pats in - let uu___3 = FStar_Compiler_List.map fv_sort vars in - let uu___4 = abstr vars body in - (qop1, uu___2, wopt, uu___3, uu___4) in - mkQuant r true uu___1 -let (mkForall : - FStar_Compiler_Range_Type.range -> - (pat Prims.list Prims.list * fvs * term) -> term) - = - fun r -> - fun uu___ -> - match uu___ with - | (pats, vars, body) -> - mkQuant' r (Forall, pats, FStar_Pervasives_Native.None, vars, body) -let (mkForall'' : - FStar_Compiler_Range_Type.range -> - (pat Prims.list Prims.list * Prims.int FStar_Pervasives_Native.option * - sort Prims.list * term) -> term) - = - fun r -> - fun uu___ -> - match uu___ with - | (pats, wopt, sorts, body) -> - mkQuant r true (Forall, pats, wopt, sorts, body) -let (mkForall' : - FStar_Compiler_Range_Type.range -> - (pat Prims.list Prims.list * Prims.int FStar_Pervasives_Native.option * - fvs * term) -> term) - = - fun r -> - fun uu___ -> - match uu___ with - | (pats, wopt, vars, body) -> - mkQuant' r (Forall, pats, wopt, vars, body) -let (mkExists : - FStar_Compiler_Range_Type.range -> - (pat Prims.list Prims.list * fvs * term) -> term) - = - fun r -> - fun uu___ -> - match uu___ with - | (pats, vars, body) -> - mkQuant' r (Exists, pats, FStar_Pervasives_Native.None, vars, body) -let (mkLet' : - ((fv * term) Prims.list * term) -> FStar_Compiler_Range_Type.range -> term) - = - fun uu___ -> - fun r -> - match uu___ with - | (bindings, body) -> - let uu___1 = FStar_Compiler_List.split bindings in - (match uu___1 with - | (vars, es) -> - let uu___2 = let uu___3 = abstr vars body in (es, uu___3) in - mkLet uu___2 r) -let (norng : FStar_Compiler_Range_Type.range) = - FStar_Compiler_Range_Type.dummyRange -let (mkDefineFun : - (Prims.string * fv Prims.list * sort * term * caption) -> decl) = - fun uu___ -> - match uu___ with - | (nm, vars, s, tm, c) -> - let uu___1 = - let uu___2 = FStar_Compiler_List.map fv_sort vars in - let uu___3 = abstr vars tm in (nm, uu___2, s, uu___3, c) in - DefineFun uu___1 -let (constr_id_of_sort : sort -> Prims.string) = - fun sort1 -> - let uu___ = strSort sort1 in - FStar_Compiler_Util.format1 "%s_constr_id" uu___ -let (fresh_token : (Prims.string * sort) -> Prims.int -> decl) = - fun uu___ -> - fun id -> - match uu___ with - | (tok_name, sort1) -> - let a_name = Prims.strcat "fresh_token_" tok_name in - let tm = - let uu___1 = - let uu___2 = mkInteger' id norng in - let uu___3 = - let uu___4 = - let uu___5 = constr_id_of_sort sort1 in - let uu___6 = - let uu___7 = mkApp (tok_name, []) norng in [uu___7] in - (uu___5, uu___6) in - mkApp uu___4 norng in - (uu___2, uu___3) in - mkEq uu___1 norng in - let a = - let uu___1 = escape a_name in - let uu___2 = free_top_level_names tm in - { - assumption_term = tm; - assumption_caption = - (FStar_Pervasives_Native.Some "fresh token"); - assumption_name = uu___1; - assumption_fact_ids = []; - assumption_free_names = uu___2 - } in - Assume a -let (fresh_constructor : - FStar_Compiler_Range_Type.range -> - (Prims.string * sort Prims.list * sort * Prims.int) -> decl) - = - fun rng -> - fun uu___ -> - match uu___ with - | (name, arg_sorts, sort1, id) -> - let id1 = FStar_Compiler_Util.string_of_int id in - let bvars = - FStar_Compiler_List.mapi - (fun i -> - fun s -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Compiler_Util.string_of_int i in - Prims.strcat "x_" uu___4 in - (uu___3, s) in - mk_fv uu___2 in - mkFreeV uu___1 norng) arg_sorts in - let bvar_names = FStar_Compiler_List.map fv_of_term bvars in - let capp = mkApp (name, bvars) norng in - let cid_app = - let uu___1 = - let uu___2 = constr_id_of_sort sort1 in (uu___2, [capp]) in - mkApp uu___1 norng in - let a_name = Prims.strcat "constructor_distinct_" name in - let tm = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = mkInteger id1 norng in (uu___4, cid_app) in - mkEq uu___3 norng in - ([[capp]], bvar_names, uu___2) in - mkForall rng uu___1 in - let a = - let uu___1 = escape a_name in - let uu___2 = free_top_level_names tm in - { - assumption_term = tm; - assumption_caption = - (FStar_Pervasives_Native.Some "Constructor distinct"); - assumption_name = uu___1; - assumption_fact_ids = []; - assumption_free_names = uu___2 - } in - Assume a -let (injective_constructor : - FStar_Compiler_Range_Type.range -> - (Prims.string * constructor_field Prims.list * sort) -> decl Prims.list) - = - fun rng -> - fun uu___ -> - match uu___ with - | (name, fields, sort1) -> - let n_bvars = FStar_Compiler_List.length fields in - let bvar_name i = - let uu___1 = FStar_Compiler_Util.string_of_int i in - Prims.strcat "x_" uu___1 in - let bvar_index i = n_bvars - (i + Prims.int_one) in - let bvar i s = - let uu___1 = - let uu___2 = let uu___3 = bvar_name i in (uu___3, s) in - mk_fv uu___2 in - mkFreeV uu___1 in - let bvars = - FStar_Compiler_List.mapi - (fun i -> - fun f -> let uu___1 = bvar i f.field_sort in uu___1 norng) - fields in - let bvar_names = FStar_Compiler_List.map fv_of_term bvars in - let capp = mkApp (name, bvars) norng in - let uu___1 = - FStar_Compiler_List.mapi - (fun i -> - fun uu___2 -> - match uu___2 with - | { field_name = name1; field_sort = s; - field_projectible = projectible;_} -> - if projectible - then - let cproj_app = mkApp (name1, [capp]) norng in - let proj_name = - DeclFun - (name1, [sort1], s, - (FStar_Pervasives_Native.Some "Projector")) in - let tm = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = bvar i s in uu___7 norng in - (cproj_app, uu___6) in - mkEq uu___5 norng in - ([[capp]], bvar_names, uu___4) in - mkForall rng uu___3 in - let a = - let uu___3 = - escape - (Prims.strcat "projection_inverse_" name1) in - let uu___4 = free_top_level_names tm in - { - assumption_term = tm; - assumption_caption = - (FStar_Pervasives_Native.Some - "Projection inverse"); - assumption_name = uu___3; - assumption_fact_ids = []; - assumption_free_names = uu___4 - } in - [proj_name; Assume a] - else []) fields in - FStar_Compiler_List.flatten uu___1 -let (discriminator_name : constructor_t -> Prims.string) = - fun constr -> Prims.strcat "is-" constr.constr_name -let (constructor_to_decl : - FStar_Compiler_Range_Type.range -> constructor_t -> decl Prims.list) = - fun rng -> - fun constr -> - let sort1 = constr.constr_sort in - let field_sorts = - FStar_Compiler_List.map (fun f -> f.field_sort) constr.constr_fields in - let cdecl = - DeclFun - ((constr.constr_name), field_sorts, (constr.constr_sort), - (FStar_Pervasives_Native.Some "Constructor")) in - let cid = - match constr.constr_id with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some id -> - let uu___ = - fresh_constructor rng - ((constr.constr_name), field_sorts, sort1, id) in - [uu___] in - let disc = - let disc_name = discriminator_name constr in - let xfv = mk_fv ("x", sort1) in - let xx = mkFreeV xfv norng in - let uu___ = - let uu___1 = - FStar_Compiler_List.mapi - (fun i -> - fun uu___2 -> - match uu___2 with - | { field_name = proj; field_sort = s; - field_projectible = projectible;_} -> - if projectible - then - let uu___3 = mkApp (proj, [xx]) norng in - (uu___3, []) - else - (let fi = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Compiler_Util.string_of_int i in - Prims.strcat "f_" uu___6 in - (uu___5, s) in - mk_fv uu___4 in - let uu___4 = mkFreeV fi norng in (uu___4, [fi]))) - constr.constr_fields in - FStar_Compiler_List.split uu___1 in - match uu___ with - | (proj_terms, ex_vars) -> - let ex_vars1 = FStar_Compiler_List.flatten ex_vars in - let disc_inv_body = - let uu___1 = - let uu___2 = mkApp ((constr.constr_name), proj_terms) norng in - (xx, uu___2) in - mkEq uu___1 norng in - let disc_inv_body1 = - match ex_vars1 with - | [] -> disc_inv_body - | uu___1 -> mkExists norng ([], ex_vars1, disc_inv_body) in - let disc_ax = - match constr.constr_id with - | FStar_Pervasives_Native.None -> disc_inv_body1 - | FStar_Pervasives_Native.Some id -> - let disc_eq = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = constr_id_of_sort constr.constr_sort in - (uu___4, [xx]) in - mkApp uu___3 norng in - let uu___3 = - let uu___4 = FStar_Compiler_Util.string_of_int id in - mkInteger uu___4 norng in - (uu___2, uu___3) in - mkEq uu___1 norng in - mkAnd (disc_eq, disc_inv_body1) norng in - let def = - mkDefineFun - (disc_name, [xfv], Bool_sort, disc_ax, - (FStar_Pervasives_Native.Some "Discriminator definition")) in - def in - let projs = - injective_constructor rng - ((constr.constr_name), (constr.constr_fields), sort1) in - let base = - if Prims.op_Negation constr.constr_base - then [] - else - (let arg_sorts = - let uu___1 = - FStar_Compiler_List.filter (fun f -> f.field_projectible) - constr.constr_fields in - FStar_Compiler_List.map (fun uu___2 -> Term_sort) uu___1 in - let base_name = Prims.strcat constr.constr_name "@base" in - let decl1 = - DeclFun - (base_name, arg_sorts, Term_sort, - (FStar_Pervasives_Native.Some "Constructor base")) in - let formals = - FStar_Compiler_List.mapi - (fun i -> - fun uu___1 -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_Compiler_Util.string_of_int i in - Prims.strcat "x" uu___4 in - (uu___3, Term_sort) in - mk_fv uu___2) constr.constr_fields in - let constructed_term = - let uu___1 = - let uu___2 = - FStar_Compiler_List.map (fun fv1 -> mkFreeV fv1 norng) - formals in - ((constr.constr_name), uu___2) in - mkApp uu___1 norng in - let inj_formals = - let uu___1 = - FStar_Compiler_List.map2 - (fun f -> - fun fld -> if fld.field_projectible then [f] else []) - formals constr.constr_fields in - FStar_Compiler_List.flatten uu___1 in - let base_term = - let uu___1 = - let uu___2 = - FStar_Compiler_List.map (fun fv1 -> mkFreeV fv1 norng) - inj_formals in - (base_name, uu___2) in - mkApp uu___1 norng in - let eq = mkEq (constructed_term, base_term) norng in - let guard = - mkApp ((discriminator_name constr), [constructed_term]) norng in - let q = - let uu___1 = - let uu___2 = mkImp (guard, eq) norng in - ([[constructed_term]], formals, uu___2) in - mkForall rng uu___1 in - let a = - let uu___1 = - escape (Prims.strcat "constructor_base_" constr.constr_name) in - let uu___2 = free_top_level_names q in - { - assumption_term = q; - assumption_caption = - (FStar_Pervasives_Native.Some "Constructor base"); - assumption_name = uu___1; - assumption_fact_ids = []; - assumption_free_names = uu___2 - } in - [decl1; Assume a]) in - let uu___ = - let uu___1 = - let uu___2 = - FStar_Compiler_Util.format1 "" - constr.constr_name in - Caption uu___2 in - [uu___1; cdecl] in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Compiler_Util.format1 "" - constr.constr_name in - Caption uu___7 in - [uu___6] in - FStar_Compiler_List.op_At base uu___5 in - FStar_Compiler_List.op_At [disc] uu___4 in - FStar_Compiler_List.op_At projs uu___3 in - FStar_Compiler_List.op_At cid uu___2 in - FStar_Compiler_List.op_At uu___ uu___1 -let (name_binders_inner : - Prims.string FStar_Pervasives_Native.option -> - fv Prims.list -> - Prims.int -> - sort Prims.list -> - (fv Prims.list * Prims.string Prims.list * Prims.int)) - = - fun prefix_opt -> - fun outer_names -> - fun start -> - fun sorts -> - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun s -> - match uu___1 with - | (names, binders1, n) -> - let prefix = - match s with | Term_sort -> "@x" | uu___2 -> "@u" in - let prefix1 = - match prefix_opt with - | FStar_Pervasives_Native.None -> prefix - | FStar_Pervasives_Native.Some p -> - Prims.strcat p prefix in - let nm = - let uu___2 = FStar_Compiler_Util.string_of_int n in - Prims.strcat prefix1 uu___2 in - let names1 = - let uu___2 = mk_fv (nm, s) in uu___2 :: names in - let b = - let uu___2 = strSort s in - FStar_Compiler_Util.format2 "(%s %s)" nm uu___2 in - (names1, (b :: binders1), (n + Prims.int_one))) - (outer_names, [], start) sorts in - match uu___ with - | (names, binders1, n) -> - (names, (FStar_Compiler_List.rev binders1), n) -let (name_macro_binders : - sort Prims.list -> (fv Prims.list * Prims.string Prims.list)) = - fun sorts -> - let uu___ = - name_binders_inner (FStar_Pervasives_Native.Some "__") [] - Prims.int_zero sorts in - match uu___ with - | (names, binders1, n) -> ((FStar_Compiler_List.rev names), binders1) -let (termToSmt : Prims.bool -> Prims.string -> term -> Prims.string) = - let string_id_counter = FStar_Compiler_Util.mk_ref Prims.int_zero in - let string_cache = FStar_Compiler_Util.smap_create (Prims.of_int (20)) in - fun print_ranges -> - fun enclosing_name -> - fun t -> - let next_qid = - let ctr = FStar_Compiler_Util.mk_ref Prims.int_zero in - fun depth -> - let n = FStar_Compiler_Effect.op_Bang ctr in - FStar_Compiler_Util.incr ctr; - if n = Prims.int_zero - then enclosing_name - else - (let uu___2 = FStar_Compiler_Util.string_of_int n in - FStar_Compiler_Util.format2 "%s.%s" enclosing_name uu___2) in - let remove_guard_free pats = - FStar_Compiler_List.map - (fun ps -> - FStar_Compiler_List.map - (fun tm -> - match tm.tm with - | App - (Var "Prims.guard_free", - { tm = BoundV uu___; freevars = uu___1; - rng = uu___2;_}::[]) - -> tm - | App (Var "Prims.guard_free", p::[]) -> p - | uu___ -> tm) ps) pats in - let rec aux' depth n names t1 = - let aux1 = aux (depth + Prims.int_one) in - match t1.tm with - | Integer i -> i - | Real r -> r - | String s -> - let id_opt = FStar_Compiler_Util.smap_try_find string_cache s in - (match id_opt with - | FStar_Pervasives_Native.Some id -> id - | FStar_Pervasives_Native.None -> - let id = - let uu___ = - FStar_Compiler_Effect.op_Bang string_id_counter in - FStar_Compiler_Util.string_of_int uu___ in - (FStar_Compiler_Util.incr string_id_counter; - FStar_Compiler_Util.smap_add string_cache s id; - id)) - | BoundV i -> - let uu___ = FStar_Compiler_List.nth names i in fv_name uu___ - | FreeV x when fv_force x -> - let uu___ = - let uu___1 = fv_name x in Prims.strcat uu___1 " Dummy_value)" in - Prims.strcat "(" uu___ - | FreeV x -> fv_name x - | App (op1, []) -> op_to_string op1 - | App (op1, tms) -> - let uu___ = op_to_string op1 in - let uu___1 = - let uu___2 = FStar_Compiler_List.map (aux1 n names) tms in - FStar_Compiler_String.concat "\n" uu___2 in - FStar_Compiler_Util.format2 "(%s %s)" uu___ uu___1 - | Labeled (t2, uu___, uu___1) -> aux1 n names t2 - | LblPos (t2, s) -> - let uu___ = aux1 n names t2 in - FStar_Compiler_Util.format2 "(! %s :lblpos %s)" uu___ s - | Quant (qop1, pats, wopt, sorts, body) -> - let qid = next_qid () in - let uu___ = - name_binders_inner FStar_Pervasives_Native.None names n sorts in - (match uu___ with - | (names1, binders1, n1) -> - let binders2 = FStar_Compiler_String.concat " " binders1 in - let pats1 = remove_guard_free pats in - let pats_str = - match pats1 with - | []::[] -> if print_ranges then ";;no pats" else "" - | [] -> if print_ranges then ";;no pats" else "" - | uu___1 -> - let uu___2 = - FStar_Compiler_List.map - (fun pats2 -> - let uu___3 = - let uu___4 = - FStar_Compiler_List.map - (fun p -> - let uu___5 = aux1 n1 names1 p in - FStar_Compiler_Util.format1 "%s" - uu___5) pats2 in - FStar_Compiler_String.concat " " uu___4 in - FStar_Compiler_Util.format1 "\n:pattern (%s)" - uu___3) pats1 in - FStar_Compiler_String.concat "\n" uu___2 in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = aux1 n1 names1 body in - let uu___5 = - let uu___6 = weightToSmt wopt in - [uu___6; pats_str; qid] in - uu___4 :: uu___5 in - binders2 :: uu___3 in - (qop_to_string qop1) :: uu___2 in - FStar_Compiler_Util.format - "(%s (%s)\n (! %s\n %s\n%s\n:qid %s))" uu___1) - | Let (es, body) -> - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun e -> - match uu___1 with - | (names0, binders1, n0) -> - let nm = - let uu___2 = - FStar_Compiler_Util.string_of_int n0 in - Prims.strcat "@lb" uu___2 in - let names01 = - let uu___2 = mk_fv (nm, Term_sort) in uu___2 :: - names0 in - let b = - let uu___2 = aux1 n names e in - FStar_Compiler_Util.format2 "(%s %s)" nm uu___2 in - (names01, (b :: binders1), (n0 + Prims.int_one))) - (names, [], n) es in - (match uu___ with - | (names1, binders1, n1) -> - let uu___1 = aux1 n1 names1 body in - FStar_Compiler_Util.format2 "(let (%s)\n%s)" - (FStar_Compiler_String.concat " " binders1) uu___1) - and aux depth n names t1 = - let s = aux' depth n names t1 in - if print_ranges && (t1.rng <> norng) - then - let uu___ = FStar_Compiler_Range_Ops.string_of_range t1.rng in - let uu___1 = FStar_Compiler_Range_Ops.string_of_use_range t1.rng in - FStar_Compiler_Util.format3 "\n;; def=%s; use=%s\n%s\n" uu___ - uu___1 s - else s in - aux Prims.int_zero Prims.int_zero [] t -let (caption_to_string : - Prims.bool -> Prims.string FStar_Pervasives_Native.option -> Prims.string) - = - fun print_captions -> - fun uu___ -> - match uu___ with - | FStar_Pervasives_Native.Some c when print_captions -> - let c1 = - let uu___1 = - FStar_Compiler_List.map FStar_Compiler_Util.trim_string - (FStar_Compiler_String.split [10] c) in - FStar_Compiler_String.concat " " uu___1 in - Prims.strcat ";;;;;;;;;;;;;;;;" (Prims.strcat c1 "\n") - | uu___1 -> "" -let rec (declToSmt' : Prims.bool -> Prims.string -> decl -> Prims.string) = - fun print_captions -> - fun z3options -> - fun decl1 -> - match decl1 with - | DefPrelude -> mkPrelude z3options - | Module (s, decls) -> - let res = - let uu___ = - FStar_Compiler_List.map (declToSmt' print_captions z3options) - decls in - FStar_Compiler_String.concat "\n" uu___ in - let uu___ = FStar_Options.keep_query_captions () in - if uu___ - then - let uu___1 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length decls) in - let uu___2 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_String.length res) in - FStar_Compiler_Util.format5 - "\n;;; Start %s\n%s\n;;; End %s (%s decls; total size %s)" s - res s uu___1 uu___2 - else res - | Caption c -> - if print_captions - then - let uu___ = - let uu___1 = - FStar_Compiler_List.map - (fun s -> Prims.strcat "; " (Prims.strcat s "\n")) - (FStar_Compiler_Util.splitlines c) in - FStar_Compiler_String.concat "" uu___1 in - Prims.strcat "\n" uu___ - else "" - | DeclFun (f, argsorts, retsort, c) -> - let l = FStar_Compiler_List.map strSort argsorts in - let uu___ = caption_to_string print_captions c in - let uu___1 = strSort retsort in - FStar_Compiler_Util.format4 "%s(declare-fun %s (%s) %s)" uu___ f - (FStar_Compiler_String.concat " " l) uu___1 - | DefineFun (f, arg_sorts, retsort, body, c) -> - let uu___ = name_macro_binders arg_sorts in - (match uu___ with - | (names, binders1) -> - let body1 = - let uu___1 = - FStar_Compiler_List.map (fun x -> mkFreeV x norng) names in - inst uu___1 body in - let uu___1 = caption_to_string print_captions c in - let uu___2 = strSort retsort in - let uu___3 = - let uu___4 = escape f in - termToSmt print_captions uu___4 body1 in - FStar_Compiler_Util.format5 "%s(define-fun %s (%s) %s\n %s)" - uu___1 f (FStar_Compiler_String.concat " " binders1) - uu___2 uu___3) - | Assume a -> - let fact_ids_to_string ids = - FStar_Compiler_List.map - (fun uu___ -> - match uu___ with - | Name n -> - let uu___1 = FStar_Ident.string_of_lid n in - Prims.strcat "Name " uu___1 - | Namespace ns -> - let uu___1 = FStar_Ident.string_of_lid ns in - Prims.strcat "Namespace " uu___1 - | Tag t -> Prims.strcat "Tag " t) ids in - let fids = - if print_captions - then - let uu___ = - let uu___1 = fact_ids_to_string a.assumption_fact_ids in - FStar_Compiler_String.concat "; " uu___1 in - FStar_Compiler_Util.format1 ";;; Fact-ids: %s\n" uu___ - else "" in - let n = a.assumption_name in - let uu___ = caption_to_string print_captions a.assumption_caption in - let uu___1 = termToSmt print_captions n a.assumption_term in - FStar_Compiler_Util.format4 "%s%s(assert (! %s\n:named %s))" - uu___ fids uu___1 n - | Eval t -> - let uu___ = termToSmt print_captions "eval" t in - FStar_Compiler_Util.format1 "(eval %s)" uu___ - | Echo s -> FStar_Compiler_Util.format1 "(echo \"%s\")" s - | RetainAssumptions uu___ -> "" - | CheckSat -> - "(echo \"\")\n(check-sat)\n(echo \"\")" - | GetUnsatCore -> - "(echo \"\")\n(get-unsat-core)\n(echo \"\")" - | Push n -> - let uu___ = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) n in - FStar_Compiler_Util.format1 "(push) ;; push{%s" uu___ - | Pop n -> - let uu___ = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) n in - FStar_Compiler_Util.format1 "(pop) ;; %s}pop" uu___ - | SetOption (s, v) -> - FStar_Compiler_Util.format2 "(set-option :%s %s)" s v - | GetStatistics -> - "(echo \"\")\n(get-info :all-statistics)\n(echo \"\")" - | GetReasonUnknown -> - "(echo \"\")\n(get-info :reason-unknown)\n(echo \"\")" -and (declToSmt : Prims.string -> decl -> Prims.string) = - fun z3options -> - fun decl1 -> - let uu___ = FStar_Options.keep_query_captions () in - declToSmt' uu___ z3options decl1 -and (mkPrelude : Prims.string -> Prims.string) = - fun z3options -> - let basic = - Prims.strcat z3options - "(declare-sort FString)\n(declare-fun FString_constr_id (FString) Int)\n\n(declare-sort Term)\n(declare-fun Term_constr_id (Term) Int)\n(declare-sort Dummy_sort)\n(declare-fun Dummy_value () Dummy_sort)\n(declare-datatypes () ((Fuel \n(ZFuel) \n(SFuel (prec Fuel)))))\n(declare-fun MaxIFuel () Fuel)\n(declare-fun MaxFuel () Fuel)\n(declare-fun PreType (Term) Term)\n(declare-fun Valid (Term) Bool)\n(declare-fun HasTypeFuel (Fuel Term Term) Bool)\n(define-fun HasTypeZ ((x Term) (t Term)) Bool\n(HasTypeFuel ZFuel x t))\n(define-fun HasType ((x Term) (t Term)) Bool\n(HasTypeFuel MaxIFuel x t))\n(declare-fun IsTotFun (Term) Bool)\n\n ;;fuel irrelevance\n(assert (forall ((f Fuel) (x Term) (t Term))\n(! (= (HasTypeFuel (SFuel f) x t)\n(HasTypeZ x t))\n:pattern ((HasTypeFuel (SFuel f) x t)))))\n(declare-fun NoHoist (Term Bool) Bool)\n;;no-hoist\n(assert (forall ((dummy Term) (b Bool))\n(! (= (NoHoist dummy b)\nb)\n:pattern ((NoHoist dummy b)))))\n(define-fun IsTyped ((x Term)) Bool\n(exists ((t Term)) (HasTypeZ x t)))\n(declare-fun ApplyTF (Term Fuel) Term)\n(declare-fun ApplyTT (Term Term) Term)\n(declare-fun Prec (Term Term) Bool)\n(assert (forall ((x Term) (y Term) (z Term))\n(! (implies (and (Prec x y) (Prec y z))\n(Prec x z))\n :pattern ((Prec x z) (Prec x y)))))\n(assert (forall ((x Term) (y Term))\n(implies (Prec x y)\n(not (Prec y x)))))\n(declare-fun Closure (Term) Term)\n(declare-fun ConsTerm (Term Term) Term)\n(declare-fun ConsFuel (Fuel Term) Term)\n(declare-fun Tm_uvar (Int) Term)\n(define-fun Reify ((x Term)) Term x)\n(declare-fun Prims.precedes (Term Term Term Term) Term)\n(declare-fun Range_const (Int) Term)\n(declare-fun _mul (Int Int) Int)\n(declare-fun _div (Int Int) Int)\n(declare-fun _mod (Int Int) Int)\n(declare-fun __uu__PartialApp () Term)\n(assert (forall ((x Int) (y Int)) (! (= (_mul x y) (* x y)) :pattern ((_mul x y)))))\n(assert (forall ((x Int) (y Int)) (! (= (_div x y) (div x y)) :pattern ((_div x y)))))\n(assert (forall ((x Int) (y Int)) (! (= (_mod x y) (mod x y)) :pattern ((_mod x y)))))\n(declare-fun _rmul (Real Real) Real)\n(declare-fun _rdiv (Real Real) Real)\n(assert (forall ((x Real) (y Real)) (! (= (_rmul x y) (* x y)) :pattern ((_rmul x y)))))\n(assert (forall ((x Real) (y Real)) (! (= (_rdiv x y) (/ x y)) :pattern ((_rdiv x y)))))\n(define-fun Unreachable () Bool false)" in - let as_constr uu___ = - match uu___ with - | (name, fields, sort1, id, _injective) -> - let uu___1 = - FStar_Compiler_List.map - (fun uu___2 -> - match uu___2 with - | (field_name, field_sort, field_projectible) -> - { field_name; field_sort; field_projectible }) fields in - { - constr_name = name; - constr_fields = uu___1; - constr_sort = sort1; - constr_id = (FStar_Pervasives_Native.Some id); - constr_base = false - } in - let constrs = - FStar_Compiler_List.map as_constr - [("FString_const", [("FString_const_proj_0", Int_sort, true)], - String_sort, Prims.int_zero, true); - ("Tm_type", [], Term_sort, (Prims.of_int (2)), true); - ("Tm_arrow", [("Tm_arrow_id", Int_sort, true)], Term_sort, - (Prims.of_int (3)), false); - ("Tm_unit", [], Term_sort, (Prims.of_int (6)), true); - ((FStar_Pervasives_Native.fst boxIntFun), - [((FStar_Pervasives_Native.snd boxIntFun), Int_sort, true)], - Term_sort, (Prims.of_int (7)), true); - ((FStar_Pervasives_Native.fst boxBoolFun), - [((FStar_Pervasives_Native.snd boxBoolFun), Bool_sort, true)], - Term_sort, (Prims.of_int (8)), true); - ((FStar_Pervasives_Native.fst boxStringFun), - [((FStar_Pervasives_Native.snd boxStringFun), String_sort, true)], - Term_sort, (Prims.of_int (9)), true); - ((FStar_Pervasives_Native.fst boxRealFun), - [((FStar_Pervasives_Native.snd boxRealFun), (Sort "Real"), true)], - Term_sort, (Prims.of_int (10)), true)] in - let bcons = - let uu___ = - let uu___1 = - FStar_Compiler_List.collect (constructor_to_decl norng) constrs in - FStar_Compiler_List.map (declToSmt z3options) uu___1 in - FStar_Compiler_String.concat "\n" uu___ in - let precedes_partial_app = - "\n(declare-fun Prims.precedes@tok () Term)\n(assert\n(forall ((@x0 Term) (@x1 Term) (@x2 Term) (@x3 Term))\n(! (= (ApplyTT (ApplyTT (ApplyTT (ApplyTT Prims.precedes@tok\n@x0)\n@x1)\n@x2)\n@x3)\n(Prims.precedes @x0 @x1 @x2 @x3))\n\n:pattern ((ApplyTT (ApplyTT (ApplyTT (ApplyTT Prims.precedes@tok\n@x0)\n@x1)\n@x2)\n@x3)))))\n" in - let lex_ordering = - "\n(declare-fun Prims.lex_t () Term)\n(assert (forall ((t1 Term) (t2 Term) (e1 Term) (e2 Term))\n(! (iff (Valid (Prims.precedes t1 t2 e1 e2))\n(Valid (Prims.precedes Prims.lex_t Prims.lex_t e1 e2)))\n:pattern (Prims.precedes t1 t2 e1 e2))))\n(assert (forall ((t1 Term) (t2 Term))\n(! (iff (Valid (Prims.precedes Prims.lex_t Prims.lex_t t1 t2)) \n(Prec t1 t2))\n:pattern ((Prims.precedes Prims.lex_t Prims.lex_t t1 t2)))))\n" in - let valid_intro = - "(assert (forall ((e Term) (t Term))\n(! (implies (HasType e t)\n(Valid t))\n:pattern ((HasType e t)\n(Valid t))\n:qid __prelude_valid_intro)))\n" in - let valid_elim = - "(assert (forall ((t Term))\n(! (implies (Valid t)\n(exists ((e Term)) (HasType e t)))\n:pattern ((Valid t))\n:qid __prelude_valid_elim)))\n" in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Options.smtencoding_valid_intro () in - if uu___5 then valid_intro else "" in - let uu___5 = - let uu___6 = FStar_Options.smtencoding_valid_elim () in - if uu___6 then valid_elim else "" in - Prims.strcat uu___4 uu___5 in - Prims.strcat lex_ordering uu___3 in - Prims.strcat precedes_partial_app uu___2 in - Prims.strcat bcons uu___1 in - Prims.strcat basic uu___ -let (declsToSmt : Prims.string -> decl Prims.list -> Prims.string) = - fun z3options -> - fun decls -> - let uu___ = FStar_Compiler_List.map (declToSmt z3options) decls in - FStar_Compiler_String.concat "\n" uu___ -let (declToSmt_no_caps : Prims.string -> decl -> Prims.string) = - fun z3options -> fun decl1 -> declToSmt' false z3options decl1 -let (mkBvConstructor : - Prims.int -> (decl Prims.list * Prims.string * Prims.string)) = - fun sz -> - let constr = - let uu___ = - let uu___1 = boxBitVecFun sz in FStar_Pervasives_Native.fst uu___1 in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = boxBitVecFun sz in - FStar_Pervasives_Native.snd uu___4 in - { - field_name = uu___3; - field_sort = (BitVec_sort sz); - field_projectible = true - } in - [uu___2] in - { - constr_name = uu___; - constr_fields = uu___1; - constr_sort = Term_sort; - constr_id = FStar_Pervasives_Native.None; - constr_base = false - } in - let uu___ = constructor_to_decl norng constr in - (uu___, (constr.constr_name), (discriminator_name constr)) -let (__range_c : Prims.int FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref Prims.int_zero -let (mk_Range_const : unit -> term) = - fun uu___ -> - let i = FStar_Compiler_Effect.op_Bang __range_c in - (let uu___2 = - let uu___3 = FStar_Compiler_Effect.op_Bang __range_c in - uu___3 + Prims.int_one in - FStar_Compiler_Effect.op_Colon_Equals __range_c uu___2); - (let uu___2 = - let uu___3 = let uu___4 = mkInteger' i norng in [uu___4] in - ("Range_const", uu___3) in - mkApp uu___2 norng) -let (mk_Term_type : term) = mkApp ("Tm_type", []) norng -let (mk_Term_app : term -> term -> FStar_Compiler_Range_Type.range -> term) = - fun t1 -> fun t2 -> fun r -> mkApp ("Tm_app", [t1; t2]) r -let (mk_Term_uvar : Prims.int -> FStar_Compiler_Range_Type.range -> term) = - fun i -> - fun r -> - let uu___ = - let uu___1 = let uu___2 = mkInteger' i norng in [uu___2] in - ("Tm_uvar", uu___1) in - mkApp uu___ r -let (mk_Term_unit : term) = mkApp ("Tm_unit", []) norng -let (elim_box : Prims.bool -> Prims.string -> Prims.string -> term -> term) = - fun cond -> - fun u -> - fun v -> - fun t -> - match t.tm with - | App (Var v', t1::[]) when (v = v') && cond -> t1 - | uu___ -> mkApp (u, [t]) t.rng -let (maybe_elim_box : Prims.string -> Prims.string -> term -> term) = - fun u -> - fun v -> - fun t -> - let uu___ = FStar_Options.smtencoding_elim_box () in - elim_box uu___ u v t -let (boxInt : term -> term) = - fun t -> - maybe_elim_box (FStar_Pervasives_Native.fst boxIntFun) - (FStar_Pervasives_Native.snd boxIntFun) t -let (unboxInt : term -> term) = - fun t -> - maybe_elim_box (FStar_Pervasives_Native.snd boxIntFun) - (FStar_Pervasives_Native.fst boxIntFun) t -let (boxBool : term -> term) = - fun t -> - maybe_elim_box (FStar_Pervasives_Native.fst boxBoolFun) - (FStar_Pervasives_Native.snd boxBoolFun) t -let (unboxBool : term -> term) = - fun t -> - maybe_elim_box (FStar_Pervasives_Native.snd boxBoolFun) - (FStar_Pervasives_Native.fst boxBoolFun) t -let (boxString : term -> term) = - fun t -> - maybe_elim_box (FStar_Pervasives_Native.fst boxStringFun) - (FStar_Pervasives_Native.snd boxStringFun) t -let (unboxString : term -> term) = - fun t -> - maybe_elim_box (FStar_Pervasives_Native.snd boxStringFun) - (FStar_Pervasives_Native.fst boxStringFun) t -let (boxReal : term -> term) = - fun t -> - maybe_elim_box (FStar_Pervasives_Native.fst boxRealFun) - (FStar_Pervasives_Native.snd boxRealFun) t -let (unboxReal : term -> term) = - fun t -> - maybe_elim_box (FStar_Pervasives_Native.snd boxRealFun) - (FStar_Pervasives_Native.fst boxRealFun) t -let (boxBitVec : Prims.int -> term -> term) = - fun sz -> - fun t -> - let uu___ = - let uu___1 = boxBitVecFun sz in FStar_Pervasives_Native.fst uu___1 in - let uu___1 = - let uu___2 = boxBitVecFun sz in FStar_Pervasives_Native.snd uu___2 in - elim_box true uu___ uu___1 t -let (unboxBitVec : Prims.int -> term -> term) = - fun sz -> - fun t -> - let uu___ = - let uu___1 = boxBitVecFun sz in FStar_Pervasives_Native.snd uu___1 in - let uu___1 = - let uu___2 = boxBitVecFun sz in FStar_Pervasives_Native.fst uu___2 in - elim_box true uu___ uu___1 t -let (boxTerm : sort -> term -> term) = - fun sort1 -> - fun t -> - match sort1 with - | Int_sort -> boxInt t - | Bool_sort -> boxBool t - | String_sort -> boxString t - | BitVec_sort sz -> boxBitVec sz t - | Sort "Real" -> boxReal t - | uu___ -> FStar_Compiler_Effect.raise FStar_Compiler_Util.Impos -let (unboxTerm : sort -> term -> term) = - fun sort1 -> - fun t -> - match sort1 with - | Int_sort -> unboxInt t - | Bool_sort -> unboxBool t - | String_sort -> unboxString t - | BitVec_sort sz -> unboxBitVec sz t - | Sort "Real" -> unboxReal t - | uu___ -> FStar_Compiler_Effect.raise FStar_Compiler_Util.Impos -let (getBoxedInteger : term -> Prims.int FStar_Pervasives_Native.option) = - fun t -> - match t.tm with - | App (Var s, t2::[]) when s = (FStar_Pervasives_Native.fst boxIntFun) -> - (match t2.tm with - | Integer n -> - let uu___ = FStar_Compiler_Util.int_of_string n in - FStar_Pervasives_Native.Some uu___ - | uu___ -> FStar_Pervasives_Native.None) - | uu___ -> FStar_Pervasives_Native.None -let (mk_PreType : term -> term) = fun t -> mkApp ("PreType", [t]) t.rng -let (mk_Valid : term -> term) = - fun t -> - match t.tm with - | App - (Var "Prims.b2t", - { tm = App (Var "Prims.op_Equality", uu___::t1::t2::[]); - freevars = uu___1; rng = uu___2;_}::[]) - -> mkEq (t1, t2) t.rng - | App - (Var "Prims.b2t", - { tm = App (Var "Prims.op_disEquality", uu___::t1::t2::[]); - freevars = uu___1; rng = uu___2;_}::[]) - -> let uu___3 = mkEq (t1, t2) norng in mkNot uu___3 t.rng - | App - (Var "Prims.b2t", - { tm = App (Var "Prims.op_LessThanOrEqual", t1::t2::[]); - freevars = uu___; rng = uu___1;_}::[]) - -> - let uu___2 = - let uu___3 = unboxInt t1 in - let uu___4 = unboxInt t2 in (uu___3, uu___4) in - mkLTE uu___2 t.rng - | App - (Var "Prims.b2t", - { tm = App (Var "Prims.op_LessThan", t1::t2::[]); freevars = uu___; - rng = uu___1;_}::[]) - -> - let uu___2 = - let uu___3 = unboxInt t1 in - let uu___4 = unboxInt t2 in (uu___3, uu___4) in - mkLT uu___2 t.rng - | App - (Var "Prims.b2t", - { tm = App (Var "Prims.op_GreaterThanOrEqual", t1::t2::[]); - freevars = uu___; rng = uu___1;_}::[]) - -> - let uu___2 = - let uu___3 = unboxInt t1 in - let uu___4 = unboxInt t2 in (uu___3, uu___4) in - mkGTE uu___2 t.rng - | App - (Var "Prims.b2t", - { tm = App (Var "Prims.op_GreaterThan", t1::t2::[]); - freevars = uu___; rng = uu___1;_}::[]) - -> - let uu___2 = - let uu___3 = unboxInt t1 in - let uu___4 = unboxInt t2 in (uu___3, uu___4) in - mkGT uu___2 t.rng - | App - (Var "Prims.b2t", - { tm = App (Var "Prims.op_AmpAmp", t1::t2::[]); freevars = uu___; - rng = uu___1;_}::[]) - -> - let uu___2 = - let uu___3 = unboxBool t1 in - let uu___4 = unboxBool t2 in (uu___3, uu___4) in - mkAnd uu___2 t.rng - | App - (Var "Prims.b2t", - { tm = App (Var "Prims.op_BarBar", t1::t2::[]); freevars = uu___; - rng = uu___1;_}::[]) - -> - let uu___2 = - let uu___3 = unboxBool t1 in - let uu___4 = unboxBool t2 in (uu___3, uu___4) in - mkOr uu___2 t.rng - | App - (Var "Prims.b2t", - { tm = App (Var "Prims.op_Negation", t1::[]); freevars = uu___; - rng = uu___1;_}::[]) - -> let uu___2 = unboxBool t1 in mkNot uu___2 t1.rng - | App - (Var "Prims.b2t", - { tm = App (Var "FStar.BV.bvult", t0::t1::t2::[]); freevars = uu___; - rng = uu___1;_}::[]) - when - let uu___2 = getBoxedInteger t0 in FStar_Compiler_Util.is_some uu___2 - -> - let sz = - let uu___2 = getBoxedInteger t0 in - match uu___2 with - | FStar_Pervasives_Native.Some sz1 -> sz1 - | uu___3 -> failwith "impossible" in - let uu___2 = - let uu___3 = unboxBitVec sz t1 in - let uu___4 = unboxBitVec sz t2 in (uu___3, uu___4) in - mkBvUlt uu___2 t.rng - | App - (Var "Prims.equals", - uu___::{ tm = App (Var "FStar.BV.bvult", t0::t1::t2::[]); - freevars = uu___1; rng = uu___2;_}::uu___3::[]) - when - let uu___4 = getBoxedInteger t0 in FStar_Compiler_Util.is_some uu___4 - -> - let sz = - let uu___4 = getBoxedInteger t0 in - match uu___4 with - | FStar_Pervasives_Native.Some sz1 -> sz1 - | uu___5 -> failwith "impossible" in - let uu___4 = - let uu___5 = unboxBitVec sz t1 in - let uu___6 = unboxBitVec sz t2 in (uu___5, uu___6) in - mkBvUlt uu___4 t.rng - | App (Var "Prims.b2t", t1::[]) -> - let uu___ = unboxBool t1 in - { tm = (uu___.tm); freevars = (uu___.freevars); rng = (t.rng) } - | uu___ -> mkApp ("Valid", [t]) t.rng -let (mk_unit_type : term) = mkApp ("Prims.unit", []) norng -let (mk_subtype_of_unit : term -> term) = - fun v -> mkApp ("Prims.subtype_of", [v; mk_unit_type]) v.rng -let (mk_HasType : term -> term -> term) = - fun v -> fun t -> mkApp ("HasType", [v; t]) t.rng -let (mk_HasTypeZ : term -> term -> term) = - fun v -> fun t -> mkApp ("HasTypeZ", [v; t]) t.rng -let (mk_IsTotFun : term -> term) = fun t -> mkApp ("IsTotFun", [t]) t.rng -let (mk_HasTypeFuel : term -> term -> term -> term) = - fun f -> - fun v -> - fun t -> - let uu___ = FStar_Options.unthrottle_inductives () in - if uu___ - then mk_HasType v t - else mkApp ("HasTypeFuel", [f; v; t]) t.rng -let (mk_HasTypeWithFuel : - term FStar_Pervasives_Native.option -> term -> term -> term) = - fun f -> - fun v -> - fun t -> - match f with - | FStar_Pervasives_Native.None -> mk_HasType v t - | FStar_Pervasives_Native.Some f1 -> mk_HasTypeFuel f1 v t -let (mk_NoHoist : term -> term -> term) = - fun dummy -> fun b -> mkApp ("NoHoist", [dummy; b]) b.rng -let (mk_tester : Prims.string -> term -> term) = - fun n -> fun t -> mkApp ((Prims.strcat "is-" n), [t]) t.rng -let (mk_ApplyTF : term -> term -> term) = - fun t -> fun t' -> mkApp ("ApplyTF", [t; t']) t.rng -let (mk_ApplyTT : term -> term -> FStar_Compiler_Range_Type.range -> term) = - fun t -> fun t' -> fun r -> mkApp ("ApplyTT", [t; t']) r -let (kick_partial_app : term -> term) = - fun t -> - let uu___ = - let uu___1 = mkApp ("__uu__PartialApp", []) t.rng in - mk_ApplyTT uu___1 t t.rng in - mk_Valid uu___ -let (mk_String_const : - Prims.string -> FStar_Compiler_Range_Type.range -> term) = - fun s -> - fun r -> - let uu___ = - let uu___1 = let uu___2 = mk (String s) r in [uu___2] in - ("FString_const", uu___1) in - mkApp uu___ r -let (mk_Precedes : - term -> term -> term -> term -> FStar_Compiler_Range_Type.range -> term) = - fun x1 -> - fun x2 -> - fun x3 -> - fun x4 -> - fun r -> - let uu___ = mkApp ("Prims.precedes", [x1; x2; x3; x4]) r in - mk_Valid uu___ -let rec (n_fuel : Prims.int -> term) = - fun n -> - if n = Prims.int_zero - then mkApp ("ZFuel", []) norng - else - (let uu___1 = - let uu___2 = let uu___3 = n_fuel (n - Prims.int_one) in [uu___3] in - ("SFuel", uu___2) in - mkApp uu___1 norng) -let (mk_and_l : term Prims.list -> FStar_Compiler_Range_Type.range -> term) = - fun l -> - fun r -> - let uu___ = mkTrue r in - FStar_Compiler_List.fold_right (fun p1 -> fun p2 -> mkAnd (p1, p2) r) l - uu___ -let (mk_or_l : term Prims.list -> FStar_Compiler_Range_Type.range -> term) = - fun l -> - fun r -> - let uu___ = mkFalse r in - FStar_Compiler_List.fold_right (fun p1 -> fun p2 -> mkOr (p1, p2) r) l - uu___ -let (mk_haseq : term -> term) = - fun t -> let uu___ = mkApp ("Prims.hasEq", [t]) t.rng in mk_Valid uu___ -let (dummy_sort : sort) = Sort "Dummy_sort" -let (showable_smt_term : term FStar_Class_Show.showable) = - { FStar_Class_Show.show = print_smt_term } -let (showable_decl : decl FStar_Class_Show.showable) = - { FStar_Class_Show.show = (declToSmt_no_caps "") } -let rec (names_of_decl : decl -> Prims.string Prims.list) = - fun d -> - match d with - | Assume a -> [a.assumption_name] - | Module (uu___, ds) -> FStar_Compiler_List.collect names_of_decl ds - | uu___ -> [] -let (decl_to_string_short : decl -> Prims.string) = - fun d -> - match d with - | DefPrelude -> "prelude" - | DeclFun (s, uu___, uu___1, uu___2) -> Prims.strcat "DeclFun " s - | DefineFun (s, uu___, uu___1, uu___2, uu___3) -> - Prims.strcat "DefineFun " s - | Assume a -> Prims.strcat "Assumption " a.assumption_name - | Caption s -> Prims.strcat "Caption " s - | Module (s, uu___) -> Prims.strcat "Module " s - | Eval uu___ -> "Eval" - | Echo s -> Prims.strcat "Echo " s - | RetainAssumptions uu___ -> "RetainAssumptions" - | Push n -> - let uu___ = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) n in - FStar_Compiler_Util.format1 "push %s" uu___ - | Pop n -> - let uu___ = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) n in - FStar_Compiler_Util.format1 "pop %s" uu___ - | CheckSat -> "check-sat" - | GetUnsatCore -> "get-unsat-core" - | SetOption (s, v) -> - Prims.strcat "SetOption " (Prims.strcat s (Prims.strcat " " v)) - | GetStatistics -> "get-statistics" - | GetReasonUnknown -> "get-reason-unknown" \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_UnsatCore.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_UnsatCore.ml deleted file mode 100644 index c8e9a34c839..00000000000 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_UnsatCore.ml +++ /dev/null @@ -1,47 +0,0 @@ -open Prims -type unsat_core = Prims.string Prims.list -let (filter : - unsat_core -> - FStar_SMTEncoding_Term.decl Prims.list -> - FStar_SMTEncoding_Term.decl Prims.list) - = - fun core -> - fun decls -> - let rec aux theory = - let theory_rev = FStar_Compiler_List.rev theory in - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun d -> - match uu___1 with - | (keep, n_retained, n_pruned) -> - (match d with - | FStar_SMTEncoding_Term.Assume a -> - if - FStar_Compiler_List.contains - a.FStar_SMTEncoding_Term.assumption_name core - then - ((d :: keep), (n_retained + Prims.int_one), - n_pruned) - else - if - FStar_Compiler_Util.starts_with - a.FStar_SMTEncoding_Term.assumption_name "@" - then ((d :: keep), n_retained, n_pruned) - else - (keep, n_retained, (n_pruned + Prims.int_one)) - | FStar_SMTEncoding_Term.Module (name, decls1) -> - let uu___2 = aux decls1 in - (match uu___2 with - | (keep', n, m) -> - (((FStar_SMTEncoding_Term.Module (name, keep')) - :: keep), (n_retained + n), (n_pruned + m))) - | uu___2 -> ((d :: keep), n_retained, n_pruned))) - ([FStar_SMTEncoding_Term.Caption - (Prims.strcat "UNSAT CORE USED: " - (FStar_Compiler_String.concat ", " core))], - Prims.int_zero, Prims.int_zero) theory_rev in - match uu___ with - | (keep, n_retained, n_pruned) -> (keep, n_retained, n_pruned) in - let uu___ = aux decls in - match uu___ with | (keep, uu___1, uu___2) -> keep \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Util.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Util.ml deleted file mode 100644 index 440c9e442ba..00000000000 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Util.ml +++ /dev/null @@ -1,285 +0,0 @@ -open Prims -let (mkAssume : - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.caption * - Prims.string) -> FStar_SMTEncoding_Term.decl) - = - fun uu___ -> - match uu___ with - | (tm, cap, nm) -> - let uu___1 = - let uu___2 = FStar_SMTEncoding_Term.escape nm in - let uu___3 = FStar_SMTEncoding_Term.free_top_level_names tm in - { - FStar_SMTEncoding_Term.assumption_term = tm; - FStar_SMTEncoding_Term.assumption_caption = cap; - FStar_SMTEncoding_Term.assumption_name = uu___2; - FStar_SMTEncoding_Term.assumption_fact_ids = []; - FStar_SMTEncoding_Term.assumption_free_names = uu___3 - } in - FStar_SMTEncoding_Term.Assume uu___1 -let norng : - 'uuuuu 'uuuuu1 . - ('uuuuu -> FStar_Compiler_Range_Type.range -> 'uuuuu1) -> - 'uuuuu -> 'uuuuu1 - = fun f -> fun x -> f x FStar_Compiler_Range_Type.dummyRange -let (mkTrue : FStar_SMTEncoding_Term.term) = - FStar_SMTEncoding_Term.mkTrue FStar_Compiler_Range_Type.dummyRange -let (mkFalse : FStar_SMTEncoding_Term.term) = - FStar_SMTEncoding_Term.mkFalse FStar_Compiler_Range_Type.dummyRange -let (mkInteger : Prims.string -> FStar_SMTEncoding_Term.term) = - norng FStar_SMTEncoding_Term.mkInteger -let (mkInteger' : Prims.int -> FStar_SMTEncoding_Term.term) = - norng FStar_SMTEncoding_Term.mkInteger' -let (mkReal : Prims.string -> FStar_SMTEncoding_Term.term) = - norng FStar_SMTEncoding_Term.mkReal -let (mkBoundV : Prims.int -> FStar_SMTEncoding_Term.term) = - norng FStar_SMTEncoding_Term.mkBoundV -let (mkFreeV : FStar_SMTEncoding_Term.fv -> FStar_SMTEncoding_Term.term) = - norng FStar_SMTEncoding_Term.mkFreeV -let (mkApp' : - (FStar_SMTEncoding_Term.op * FStar_SMTEncoding_Term.term Prims.list) -> - FStar_SMTEncoding_Term.term) - = norng FStar_SMTEncoding_Term.mkApp' -let (mkApp : - (Prims.string * FStar_SMTEncoding_Term.term Prims.list) -> - FStar_SMTEncoding_Term.term) - = norng FStar_SMTEncoding_Term.mkApp -let (mkNot : FStar_SMTEncoding_Term.term -> FStar_SMTEncoding_Term.term) = - norng FStar_SMTEncoding_Term.mkNot -let (mkMinus : FStar_SMTEncoding_Term.term -> FStar_SMTEncoding_Term.term) = - norng FStar_SMTEncoding_Term.mkMinus -let (mkAnd : - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = norng FStar_SMTEncoding_Term.mkAnd -let (mkOr : - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = norng FStar_SMTEncoding_Term.mkOr -let (mkImp : - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = norng FStar_SMTEncoding_Term.mkImp -let (mkIff : - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = norng FStar_SMTEncoding_Term.mkIff -let (mkEq : - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = norng FStar_SMTEncoding_Term.mkEq -let (mkLT : - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = norng FStar_SMTEncoding_Term.mkLT -let (mkLTE : - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = norng FStar_SMTEncoding_Term.mkLTE -let (mkGT : - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = norng FStar_SMTEncoding_Term.mkGT -let (mkGTE : - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = norng FStar_SMTEncoding_Term.mkGTE -let (mkAdd : - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = norng FStar_SMTEncoding_Term.mkAdd -let (mkSub : - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = norng FStar_SMTEncoding_Term.mkSub -let (mkDiv : - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = norng FStar_SMTEncoding_Term.mkDiv -let (mkRealDiv : - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = norng FStar_SMTEncoding_Term.mkRealDiv -let (mkMul : - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = norng FStar_SMTEncoding_Term.mkMul -let (mkMod : - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = norng FStar_SMTEncoding_Term.mkMod -let (mkNatToBv : - Prims.int -> FStar_SMTEncoding_Term.term -> FStar_SMTEncoding_Term.term) = - fun sz -> norng (FStar_SMTEncoding_Term.mkNatToBv sz) -let (mkBvAnd : - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = norng FStar_SMTEncoding_Term.mkBvAnd -let (mkBvXor : - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = norng FStar_SMTEncoding_Term.mkBvXor -let (mkBvOr : - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = norng FStar_SMTEncoding_Term.mkBvOr -let (mkBvAdd : - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = norng FStar_SMTEncoding_Term.mkBvAdd -let (mkBvSub : - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = norng FStar_SMTEncoding_Term.mkBvSub -let (mkBvShl : - Prims.int -> - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = fun sz -> norng (FStar_SMTEncoding_Term.mkBvShl sz) -let (mkBvShr : - Prims.int -> - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = fun sz -> norng (FStar_SMTEncoding_Term.mkBvShr sz) -let (mkBvUdiv : - Prims.int -> - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = fun sz -> norng (FStar_SMTEncoding_Term.mkBvUdiv sz) -let (mkBvMod : - Prims.int -> - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = fun sz -> norng (FStar_SMTEncoding_Term.mkBvMod sz) -let (mkBvMul : - Prims.int -> - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = fun sz -> norng (FStar_SMTEncoding_Term.mkBvMul sz) -let (mkBvShl' : - Prims.int -> - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = fun sz -> norng (FStar_SMTEncoding_Term.mkBvShl' sz) -let (mkBvShr' : - Prims.int -> - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = fun sz -> norng (FStar_SMTEncoding_Term.mkBvShr' sz) -let (mkBvUdivUnsafe : - Prims.int -> - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = fun sz -> norng (FStar_SMTEncoding_Term.mkBvUdivUnsafe sz) -let (mkBvModUnsafe : - Prims.int -> - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = fun sz -> norng (FStar_SMTEncoding_Term.mkBvModUnsafe sz) -let (mkBvMul' : - Prims.int -> - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = fun sz -> norng (FStar_SMTEncoding_Term.mkBvMul' sz) -let (mkBvUlt : - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term) -> - FStar_SMTEncoding_Term.term) - = norng FStar_SMTEncoding_Term.mkBvUlt -let (mkBvUext : - Prims.int -> FStar_SMTEncoding_Term.term -> FStar_SMTEncoding_Term.term) = - fun sz -> norng (FStar_SMTEncoding_Term.mkBvUext sz) -let (mkBvToNat : FStar_SMTEncoding_Term.term -> FStar_SMTEncoding_Term.term) - = norng FStar_SMTEncoding_Term.mkBvToNat -let (mkITE : - (FStar_SMTEncoding_Term.term * FStar_SMTEncoding_Term.term * - FStar_SMTEncoding_Term.term) -> FStar_SMTEncoding_Term.term) - = norng FStar_SMTEncoding_Term.mkITE -let (mkCases : - FStar_SMTEncoding_Term.term Prims.list -> FStar_SMTEncoding_Term.term) = - norng FStar_SMTEncoding_Term.mkCases -let norng2 : - 'uuuuu 'uuuuu1 'uuuuu2 . - ('uuuuu -> 'uuuuu1 -> FStar_Compiler_Range_Type.range -> 'uuuuu2) -> - 'uuuuu -> 'uuuuu1 -> 'uuuuu2 - = fun f -> fun x -> fun y -> f x y FStar_Compiler_Range_Type.dummyRange -let norng3 : - 'uuuuu 'uuuuu1 'uuuuu2 'uuuuu3 . - ('uuuuu -> - 'uuuuu1 -> 'uuuuu2 -> FStar_Compiler_Range_Type.range -> 'uuuuu3) - -> 'uuuuu -> 'uuuuu1 -> 'uuuuu2 -> 'uuuuu3 - = - fun f -> - fun x -> fun y -> fun z -> f x y z FStar_Compiler_Range_Type.dummyRange -let norng4 : - 'uuuuu 'uuuuu1 'uuuuu2 'uuuuu3 'uuuuu4 . - ('uuuuu -> - 'uuuuu1 -> - 'uuuuu2 -> 'uuuuu3 -> FStar_Compiler_Range_Type.range -> 'uuuuu4) - -> 'uuuuu -> 'uuuuu1 -> 'uuuuu2 -> 'uuuuu3 -> 'uuuuu4 - = - fun f -> - fun x -> - fun y -> - fun z -> fun w -> f x y z w FStar_Compiler_Range_Type.dummyRange -let (mk_Term_app : - FStar_SMTEncoding_Term.term -> - FStar_SMTEncoding_Term.term -> FStar_SMTEncoding_Term.term) - = norng2 FStar_SMTEncoding_Term.mk_Term_app -let (mk_Term_uvar : Prims.int -> FStar_SMTEncoding_Term.term) = - norng FStar_SMTEncoding_Term.mk_Term_uvar -let (mk_and_l : - FStar_SMTEncoding_Term.term Prims.list -> FStar_SMTEncoding_Term.term) = - norng FStar_SMTEncoding_Term.mk_and_l -let (mk_or_l : - FStar_SMTEncoding_Term.term Prims.list -> FStar_SMTEncoding_Term.term) = - norng FStar_SMTEncoding_Term.mk_or_l -let (mk_ApplyTT : - FStar_SMTEncoding_Term.term -> - FStar_SMTEncoding_Term.term -> FStar_SMTEncoding_Term.term) - = norng2 FStar_SMTEncoding_Term.mk_ApplyTT -let (mk_String_const : Prims.string -> FStar_SMTEncoding_Term.term) = - norng FStar_SMTEncoding_Term.mk_String_const -let (mk_Precedes : - FStar_SMTEncoding_Term.term -> - FStar_SMTEncoding_Term.term -> - FStar_SMTEncoding_Term.term -> - FStar_SMTEncoding_Term.term -> FStar_SMTEncoding_Term.term) - = norng4 FStar_SMTEncoding_Term.mk_Precedes -let (is_smt_reifiable_effect : - FStar_TypeChecker_Env.env -> FStar_Ident.lident -> Prims.bool) = - fun en -> - fun l -> - let l1 = FStar_TypeChecker_Env.norm_eff_name en l in - (FStar_TypeChecker_Env.is_reifiable_effect en l1) && - (let uu___ = - let uu___1 = FStar_TypeChecker_Env.get_effect_decl en l1 in - FStar_Syntax_Util.is_layered uu___1 in - Prims.op_Negation uu___) -let (is_smt_reifiable_comp : - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.comp -> Prims.bool) = - fun en -> - fun c -> - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Comp ct -> - is_smt_reifiable_effect en ct.FStar_Syntax_Syntax.effect_name - | uu___ -> false -let (is_smt_reifiable_rc : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.residual_comp -> Prims.bool) - = - fun en -> - fun rc -> - is_smt_reifiable_effect en rc.FStar_Syntax_Syntax.residual_effect -let (is_smt_reifiable_function : - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.term -> Prims.bool) = - fun en -> - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = uu___1; FStar_Syntax_Syntax.comp = c;_} - -> - is_smt_reifiable_effect en (FStar_Syntax_Util.comp_effect_name c) - | uu___1 -> false \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Z3.ml b/ocaml/fstar-lib/generated/FStar_SMTEncoding_Z3.ml deleted file mode 100644 index 9edd1e6dc3d..00000000000 --- a/ocaml/fstar-lib/generated/FStar_SMTEncoding_Z3.ml +++ /dev/null @@ -1,1385 +0,0 @@ -open Prims -type z3status = - | UNSAT of FStar_SMTEncoding_UnsatCore.unsat_core - FStar_Pervasives_Native.option - | SAT of (FStar_SMTEncoding_Term.error_labels * Prims.string - FStar_Pervasives_Native.option) - | UNKNOWN of (FStar_SMTEncoding_Term.error_labels * Prims.string - FStar_Pervasives_Native.option) - | TIMEOUT of (FStar_SMTEncoding_Term.error_labels * Prims.string - FStar_Pervasives_Native.option) - | KILLED -let (uu___is_UNSAT : z3status -> Prims.bool) = - fun projectee -> match projectee with | UNSAT _0 -> true | uu___ -> false -let (__proj__UNSAT__item___0 : - z3status -> - FStar_SMTEncoding_UnsatCore.unsat_core FStar_Pervasives_Native.option) - = fun projectee -> match projectee with | UNSAT _0 -> _0 -let (uu___is_SAT : z3status -> Prims.bool) = - fun projectee -> match projectee with | SAT _0 -> true | uu___ -> false -let (__proj__SAT__item___0 : - z3status -> - (FStar_SMTEncoding_Term.error_labels * Prims.string - FStar_Pervasives_Native.option)) - = fun projectee -> match projectee with | SAT _0 -> _0 -let (uu___is_UNKNOWN : z3status -> Prims.bool) = - fun projectee -> match projectee with | UNKNOWN _0 -> true | uu___ -> false -let (__proj__UNKNOWN__item___0 : - z3status -> - (FStar_SMTEncoding_Term.error_labels * Prims.string - FStar_Pervasives_Native.option)) - = fun projectee -> match projectee with | UNKNOWN _0 -> _0 -let (uu___is_TIMEOUT : z3status -> Prims.bool) = - fun projectee -> match projectee with | TIMEOUT _0 -> true | uu___ -> false -let (__proj__TIMEOUT__item___0 : - z3status -> - (FStar_SMTEncoding_Term.error_labels * Prims.string - FStar_Pervasives_Native.option)) - = fun projectee -> match projectee with | TIMEOUT _0 -> _0 -let (uu___is_KILLED : z3status -> Prims.bool) = - fun projectee -> match projectee with | KILLED -> true | uu___ -> false -type z3statistics = Prims.string FStar_Compiler_Util.smap -type z3result = - { - z3result_status: z3status ; - z3result_time: Prims.int ; - z3result_statistics: z3statistics ; - z3result_query_hash: Prims.string FStar_Pervasives_Native.option ; - z3result_log_file: Prims.string FStar_Pervasives_Native.option } -let (__proj__Mkz3result__item__z3result_status : z3result -> z3status) = - fun projectee -> - match projectee with - | { z3result_status; z3result_time; z3result_statistics; - z3result_query_hash; z3result_log_file;_} -> z3result_status -let (__proj__Mkz3result__item__z3result_time : z3result -> Prims.int) = - fun projectee -> - match projectee with - | { z3result_status; z3result_time; z3result_statistics; - z3result_query_hash; z3result_log_file;_} -> z3result_time -let (__proj__Mkz3result__item__z3result_statistics : - z3result -> z3statistics) = - fun projectee -> - match projectee with - | { z3result_status; z3result_time; z3result_statistics; - z3result_query_hash; z3result_log_file;_} -> z3result_statistics -let (__proj__Mkz3result__item__z3result_query_hash : - z3result -> Prims.string FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { z3result_status; z3result_time; z3result_statistics; - z3result_query_hash; z3result_log_file;_} -> z3result_query_hash -let (__proj__Mkz3result__item__z3result_log_file : - z3result -> Prims.string FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { z3result_status; z3result_time; z3result_statistics; - z3result_query_hash; z3result_log_file;_} -> z3result_log_file -type query_log = - { - get_module_name: unit -> Prims.string ; - set_module_name: Prims.string -> unit ; - write_to_log: Prims.bool -> Prims.string -> Prims.string ; - append_to_log: Prims.string -> Prims.string ; - close_log: unit -> unit } -let (__proj__Mkquery_log__item__get_module_name : - query_log -> unit -> Prims.string) = - fun projectee -> - match projectee with - | { get_module_name; set_module_name; write_to_log; append_to_log; - close_log;_} -> get_module_name -let (__proj__Mkquery_log__item__set_module_name : - query_log -> Prims.string -> unit) = - fun projectee -> - match projectee with - | { get_module_name; set_module_name; write_to_log; append_to_log; - close_log;_} -> set_module_name -let (__proj__Mkquery_log__item__write_to_log : - query_log -> Prims.bool -> Prims.string -> Prims.string) = - fun projectee -> - match projectee with - | { get_module_name; set_module_name; write_to_log; append_to_log; - close_log;_} -> write_to_log -let (__proj__Mkquery_log__item__append_to_log : - query_log -> Prims.string -> Prims.string) = - fun projectee -> - match projectee with - | { get_module_name; set_module_name; write_to_log; append_to_log; - close_log;_} -> append_to_log -let (__proj__Mkquery_log__item__close_log : query_log -> unit -> unit) = - fun projectee -> - match projectee with - | { get_module_name; set_module_name; write_to_log; append_to_log; - close_log;_} -> close_log -let (_already_warned_solver_mismatch : Prims.bool FStar_Compiler_Effect.ref) - = FStar_Compiler_Util.mk_ref false -let (_already_warned_version_mismatch : Prims.bool FStar_Compiler_Effect.ref) - = FStar_Compiler_Util.mk_ref false -let (z3url : Prims.string) = "https://github.com/Z3Prover/z3/releases" -let (inpath : Prims.string -> Prims.bool) = - fun path -> - try - (fun uu___ -> - match () with - | () -> - let s = - FStar_Compiler_Util.run_process "z3_pathtest" path - ["-version"] FStar_Pervasives_Native.None in - s <> "") () - with | uu___ -> false -let (z3_exe : unit -> Prims.string) = - let cache = FStar_Compiler_Util.smap_create (Prims.of_int (5)) in - let find_or k f = - let uu___ = FStar_Compiler_Util.smap_try_find cache k in - match uu___ with - | FStar_Pervasives_Native.Some v -> v - | FStar_Pervasives_Native.None -> - let v = f k in (FStar_Compiler_Util.smap_add cache k v; v) in - fun uu___ -> - let uu___1 = FStar_Options.z3_version () in - find_or uu___1 - (fun version -> - let path = - let z3_v = FStar_Platform.exe (Prims.strcat "z3-" version) in - let smto = FStar_Options.smt () in - if FStar_Pervasives_Native.uu___is_Some smto - then FStar_Pervasives_Native.__proj__Some__item__v smto - else - (let uu___3 = inpath z3_v in - if uu___3 then z3_v else FStar_Platform.exe "z3") in - (let uu___3 = FStar_Compiler_Debug.any () in - if uu___3 - then FStar_Compiler_Util.print1 "Chosen Z3 executable: %s\n" path - else ()); - path) -type label = Prims.string -let (status_tag : z3status -> Prims.string) = - fun uu___ -> - match uu___ with - | SAT uu___1 -> "sat" - | UNSAT uu___1 -> "unsat" - | UNKNOWN uu___1 -> "unknown" - | TIMEOUT uu___1 -> "timeout" - | KILLED -> "killed" -let (status_string_and_errors : - z3status -> (Prims.string * FStar_SMTEncoding_Term.error_labels)) = - fun s -> - match s with - | KILLED -> ((status_tag s), []) - | UNSAT uu___ -> ((status_tag s), []) - | SAT (errs, msg) -> - let uu___ = - FStar_Compiler_Util.format2 "%s%s" (status_tag s) - (match msg with - | FStar_Pervasives_Native.None -> "" - | FStar_Pervasives_Native.Some msg1 -> - Prims.strcat " because " msg1) in - (uu___, errs) - | UNKNOWN (errs, msg) -> - let uu___ = - FStar_Compiler_Util.format2 "%s%s" (status_tag s) - (match msg with - | FStar_Pervasives_Native.None -> "" - | FStar_Pervasives_Native.Some msg1 -> - Prims.strcat " because " msg1) in - (uu___, errs) - | TIMEOUT (errs, msg) -> - let uu___ = - FStar_Compiler_Util.format2 "%s%s" (status_tag s) - (match msg with - | FStar_Pervasives_Native.None -> "" - | FStar_Pervasives_Native.Some msg1 -> - Prims.strcat " because " msg1) in - (uu___, errs) -let (query_logging : query_log) = - let query_number = FStar_Compiler_Util.mk_ref Prims.int_zero in - let log_file_opt = FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None in - let used_file_names = FStar_Compiler_Util.mk_ref [] in - let current_module_name = - FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None in - let current_file_name = - FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None in - let set_module_name n = - FStar_Compiler_Effect.op_Colon_Equals current_module_name - (FStar_Pervasives_Native.Some n) in - let get_module_name uu___ = - let uu___1 = FStar_Compiler_Effect.op_Bang current_module_name in - match uu___1 with - | FStar_Pervasives_Native.None -> failwith "Module name not set" - | FStar_Pervasives_Native.Some n -> n in - let next_file_name uu___ = - let n = get_module_name () in - let file_name = - let uu___1 = - let uu___2 = FStar_Compiler_Effect.op_Bang used_file_names in - FStar_Compiler_List.tryFind - (fun uu___3 -> match uu___3 with | (m, uu___4) -> n = m) uu___2 in - match uu___1 with - | FStar_Pervasives_Native.None -> - ((let uu___3 = - let uu___4 = FStar_Compiler_Effect.op_Bang used_file_names in - (n, Prims.int_zero) :: uu___4 in - FStar_Compiler_Effect.op_Colon_Equals used_file_names uu___3); - n) - | FStar_Pervasives_Native.Some (uu___2, k) -> - ((let uu___4 = - let uu___5 = FStar_Compiler_Effect.op_Bang used_file_names in - (n, (k + Prims.int_one)) :: uu___5 in - FStar_Compiler_Effect.op_Colon_Equals used_file_names uu___4); - (let uu___4 = - FStar_Compiler_Util.string_of_int (k + Prims.int_one) in - FStar_Compiler_Util.format2 "%s-%s" n uu___4)) in - FStar_Compiler_Util.format1 "queries-%s.smt2" file_name in - let new_log_file uu___ = - let file_name = next_file_name () in - FStar_Compiler_Effect.op_Colon_Equals current_file_name - (FStar_Pervasives_Native.Some file_name); - (let c = FStar_Compiler_Util.open_file_for_writing file_name in - FStar_Compiler_Effect.op_Colon_Equals log_file_opt - (FStar_Pervasives_Native.Some (c, file_name)); - (c, file_name)) in - let get_log_file uu___ = - let uu___1 = FStar_Compiler_Effect.op_Bang log_file_opt in - match uu___1 with - | FStar_Pervasives_Native.None -> new_log_file () - | FStar_Pervasives_Native.Some c -> c in - let append_to_log str = - let uu___ = get_log_file () in - match uu___ with - | (f, nm) -> (FStar_Compiler_Util.append_to_file f str; nm) in - let write_to_new_log str = - let file_name = next_file_name () in - FStar_Compiler_Util.write_file file_name str; file_name in - let write_to_log fresh str = - if fresh then write_to_new_log str else append_to_log str in - let close_log uu___ = - let uu___1 = FStar_Compiler_Effect.op_Bang log_file_opt in - match uu___1 with - | FStar_Pervasives_Native.None -> () - | FStar_Pervasives_Native.Some (c, uu___2) -> - (FStar_Compiler_Util.close_out_channel c; - FStar_Compiler_Effect.op_Colon_Equals log_file_opt - FStar_Pervasives_Native.None) in - let log_file_name uu___ = - let uu___1 = FStar_Compiler_Effect.op_Bang current_file_name in - match uu___1 with - | FStar_Pervasives_Native.None -> failwith "no log file" - | FStar_Pervasives_Native.Some n -> n in - { get_module_name; set_module_name; write_to_log; append_to_log; close_log - } -let (z3_cmd_and_args : unit -> (Prims.string * Prims.string Prims.list)) = - fun uu___ -> - let cmd = z3_exe () in - let cmd_args = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = FStar_Options.z3_seed () in - FStar_Compiler_Util.string_of_int uu___6 in - FStar_Compiler_Util.format1 "smt.random_seed=%s" uu___5 in - [uu___4] in - "-in" :: uu___3 in - "-smt2" :: uu___2 in - let uu___2 = FStar_Options.z3_cliopt () in - FStar_Compiler_List.append uu___1 uu___2 in - (cmd, cmd_args) -let (warn_handler : FStar_Errors_Msg.error_message -> Prims.string -> unit) = - fun suf -> - fun s -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Errors_Msg.text "Unexpected output from Z3:" in - let uu___4 = - let uu___5 = - let uu___6 = FStar_Pprint.blank (Prims.of_int (2)) in - let uu___7 = - let uu___8 = - let uu___9 = FStar_Pprint.arbitrary_string s in - FStar_Pprint.dquotes uu___9 in - FStar_Pprint.align uu___8 in - FStar_Pprint.op_Hat_Hat uu___6 uu___7 in - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline uu___5 in - FStar_Pprint.op_Hat_Hat uu___3 uu___4 in - [uu___2] in - FStar_Compiler_List.op_At uu___1 suf in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_UnexpectedZ3Output - () (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___) -let (check_z3version : FStar_Compiler_Util.proc -> unit) = - fun p -> - let getinfo arg = - let s = - let uu___ = - FStar_Compiler_Util.format1 "(get-info :%s)\n(echo \"Done!\")\n" - arg in - FStar_Compiler_Util.ask_process p uu___ (fun uu___1 -> "Killed") - (warn_handler []) in - if FStar_Compiler_Util.starts_with s (Prims.strcat "(:" arg) - then - let ss = FStar_Compiler_String.split [34] s in - FStar_Compiler_List.nth ss Prims.int_one - else - (warn_handler [] s; - (let uu___2 = - let uu___3 = FStar_Compiler_Util.proc_prog p in - FStar_Compiler_Util.format1 "Could not run Z3 from `%s'" uu___3 in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Error_Z3InvocationError () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2))) in - let name = getinfo "name" in - (let uu___1 = - (name <> "Z3") && - (let uu___2 = - FStar_Compiler_Effect.op_Bang _already_warned_solver_mismatch in - Prims.op_Negation uu___2) in - if uu___1 - then - ((let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = FStar_Options.z3_version () in - Prims.strcat "z3-" uu___6 in - FStar_Platform.exe uu___5 in - FStar_Compiler_Util.format3 - "Unexpected SMT solver: expected to be talking to Z3, got %s.\nPlease download the correct version of Z3 from %s\nand install it into your $PATH as `%s'." - name z3url uu___4 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_SolverMismatch () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___3)); - FStar_Compiler_Effect.op_Colon_Equals _already_warned_solver_mismatch - true) - else ()); - (let ver_found = - let uu___1 = - let uu___2 = - let uu___3 = getinfo "version" in - FStar_Compiler_Util.split uu___3 "-" in - FStar_Compiler_List.hd uu___2 in - FStar_Compiler_Util.trim_string uu___1 in - let ver_conf = - let uu___1 = FStar_Options.z3_version () in - FStar_Compiler_Util.trim_string uu___1 in - let uu___2 = - (ver_conf <> ver_found) && - (let uu___3 = - FStar_Compiler_Effect.op_Bang _already_warned_version_mismatch in - Prims.op_Negation uu___3) in - if uu___2 - then - ((let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = FStar_Compiler_Util.proc_prog p in - FStar_Compiler_Util.format3 - "Unexpected Z3 version for '%s': expected '%s', got '%s'." - uu___7 ver_conf ver_found in - FStar_Errors_Msg.text uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Errors_Msg.text - "Please download the correct version of Z3 from" in - let uu___10 = FStar_Pprint.url z3url in - FStar_Pprint.prefix (Prims.of_int (4)) Prims.int_one uu___9 - uu___10 in - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Errors_Msg.text - "and install it into your $PATH as" in - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = - let uu___17 = FStar_Options.z3_version () in - Prims.strcat "z3-" uu___17 in - FStar_Platform.exe uu___16 in - FStar_Pprint.doc_of_string uu___15 in - FStar_Pprint.squotes uu___14 in - FStar_Pprint.op_Hat_Hat uu___13 FStar_Pprint.dot in - FStar_Pprint.op_Hat_Slash_Hat uu___11 uu___12 in - FStar_Pprint.group uu___10 in - FStar_Pprint.op_Hat_Slash_Hat uu___8 uu___9 in - [uu___7] in - uu___5 :: uu___6 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_SolverMismatch () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___4)); - FStar_Errors.stop_if_err (); - FStar_Compiler_Effect.op_Colon_Equals - _already_warned_version_mismatch true) - else ()) -let (new_z3proc : - Prims.string -> - (Prims.string * Prims.string Prims.list) -> FStar_Compiler_Util.proc) - = - fun id -> - fun cmd_and_args -> - let proc = - try - (fun uu___ -> - match () with - | () -> - FStar_Compiler_Util.start_process id - (FStar_Pervasives_Native.fst cmd_and_args) - (FStar_Pervasives_Native.snd cmd_and_args) - (fun s -> s = "Done!")) () - with - | uu___ -> - let uu___1 = - let uu___2 = - FStar_Errors_Msg.text "Could not start SMT solver process." in - let uu___3 = - let uu___4 = - let uu___5 = FStar_Errors_Msg.text "Command:" in - let uu___6 = - let uu___7 = - FStar_Pprint.arbitrary_string - (FStar_Pervasives_Native.fst cmd_and_args) in - FStar_Pprint.squotes uu___7 in - FStar_Pprint.prefix (Prims.of_int (2)) Prims.int_one uu___5 - uu___6 in - let uu___5 = - let uu___6 = - let uu___7 = FStar_Errors_Msg.text "Exception:" in - let uu___8 = - let uu___9 = FStar_Compiler_Util.print_exn uu___ in - FStar_Pprint.arbitrary_string uu___9 in - FStar_Pprint.prefix (Prims.of_int (2)) Prims.int_one - uu___7 uu___8 in - [uu___6] in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Error_Z3InvocationError () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___1) in - check_z3version proc; proc -let (new_z3proc_with_id : - (Prims.string * Prims.string Prims.list) -> FStar_Compiler_Util.proc) = - let ctr = FStar_Compiler_Util.mk_ref (Prims.of_int (-1)) in - fun cmd_and_args -> - let p = - let uu___ = - let uu___1 = - FStar_Compiler_Util.incr ctr; - (let uu___3 = FStar_Compiler_Effect.op_Bang ctr in - FStar_Compiler_Util.string_of_int uu___3) in - FStar_Compiler_Util.format1 "z3-bg-%s" uu___1 in - new_z3proc uu___ cmd_and_args in - p -type bgproc = - { - ask: Prims.string -> Prims.string ; - refresh: unit -> unit ; - restart: unit -> unit ; - version: unit -> Prims.string ; - ctxt: FStar_SMTEncoding_SolverState.solver_state } -let (__proj__Mkbgproc__item__ask : bgproc -> Prims.string -> Prims.string) = - fun projectee -> - match projectee with | { ask; refresh; restart; version; ctxt;_} -> ask -let (__proj__Mkbgproc__item__refresh : bgproc -> unit -> unit) = - fun projectee -> - match projectee with - | { ask; refresh; restart; version; ctxt;_} -> refresh -let (__proj__Mkbgproc__item__restart : bgproc -> unit -> unit) = - fun projectee -> - match projectee with - | { ask; refresh; restart; version; ctxt;_} -> restart -let (__proj__Mkbgproc__item__version : bgproc -> unit -> Prims.string) = - fun projectee -> - match projectee with - | { ask; refresh; restart; version; ctxt;_} -> version -let (__proj__Mkbgproc__item__ctxt : - bgproc -> FStar_SMTEncoding_SolverState.solver_state) = - fun projectee -> - match projectee with | { ask; refresh; restart; version; ctxt;_} -> ctxt -let (cmd_and_args_to_string : - (Prims.string * Prims.string Prims.list) -> Prims.string) = - fun cmd_and_args -> - FStar_Compiler_String.concat "" - ["cmd="; - FStar_Pervasives_Native.fst cmd_and_args; - " args=["; - FStar_Compiler_String.concat ", " - (FStar_Pervasives_Native.snd cmd_and_args); - "]"] -let (bg_z3_proc : bgproc FStar_Compiler_Effect.ref) = - let the_z3proc = FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None in - let the_z3proc_params = - FStar_Compiler_Util.mk_ref (FStar_Pervasives_Native.Some ("", [""])) in - let the_z3proc_ask_count = FStar_Compiler_Util.mk_ref Prims.int_zero in - let the_z3proc_version = FStar_Compiler_Util.mk_ref "" in - let make_new_z3_proc cmd_and_args = - (let uu___1 = - let uu___2 = new_z3proc_with_id cmd_and_args in - FStar_Pervasives_Native.Some uu___2 in - FStar_Compiler_Effect.op_Colon_Equals the_z3proc uu___1); - FStar_Compiler_Effect.op_Colon_Equals the_z3proc_params - (FStar_Pervasives_Native.Some cmd_and_args); - FStar_Compiler_Effect.op_Colon_Equals the_z3proc_ask_count Prims.int_zero in - (let uu___1 = FStar_Options.z3_version () in - FStar_Compiler_Effect.op_Colon_Equals the_z3proc_version uu___1); - (let z3proc uu___1 = - (let uu___3 = - let uu___4 = FStar_Compiler_Effect.op_Bang the_z3proc in - uu___4 = FStar_Pervasives_Native.None in - if uu___3 - then let uu___4 = z3_cmd_and_args () in make_new_z3_proc uu___4 - else ()); - (let uu___3 = FStar_Compiler_Effect.op_Bang the_z3proc in - FStar_Compiler_Util.must uu___3) in - let ask input = - FStar_Compiler_Util.incr the_z3proc_ask_count; - (let kill_handler uu___2 = "\nkilled\n" in - let uu___2 = z3proc () in - FStar_Compiler_Util.ask_process uu___2 input kill_handler - (warn_handler [])) in - let maybe_kill_z3proc uu___1 = - let uu___2 = - let uu___3 = FStar_Compiler_Effect.op_Bang the_z3proc in - uu___3 <> FStar_Pervasives_Native.None in - if uu___2 - then - ((let uu___4 = - let uu___5 = FStar_Compiler_Effect.op_Bang the_z3proc in - FStar_Compiler_Util.must uu___5 in - FStar_Compiler_Util.kill_process uu___4); - FStar_Compiler_Effect.op_Colon_Equals the_z3proc - FStar_Pervasives_Native.None) - else () in - let refresh uu___1 = - let next_params = z3_cmd_and_args () in - let old_params = - let uu___2 = FStar_Compiler_Effect.op_Bang the_z3proc_params in - FStar_Compiler_Util.must uu___2 in - let old_version = FStar_Compiler_Effect.op_Bang the_z3proc_version in - let next_version = FStar_Options.z3_version () in - (let uu___3 = - (((FStar_Options.log_queries ()) || - (let uu___4 = FStar_Compiler_Effect.op_Bang the_z3proc_ask_count in - uu___4 > Prims.int_zero)) - || (old_params <> next_params)) - || (old_version <> next_version) in - if uu___3 - then - (maybe_kill_z3proc (); - (let uu___6 = FStar_Options.query_stats () in - if uu___6 - then - let uu___7 = - let uu___8 = FStar_Compiler_Effect.op_Bang the_z3proc_ask_count in - FStar_Compiler_Util.string_of_int uu___8 in - FStar_Compiler_Util.print3 - "Refreshing the z3proc (ask_count=%s old=[%s] new=[%s])\n" - uu___7 (cmd_and_args_to_string old_params) - (cmd_and_args_to_string next_params) - else ()); - make_new_z3_proc next_params) - else ()); - query_logging.close_log () in - let restart uu___1 = - maybe_kill_z3proc (); - query_logging.close_log (); - (let next_params = z3_cmd_and_args () in make_new_z3_proc next_params) in - let x = [] in - let uu___1 = - let uu___2 = FStar_SMTEncoding_SolverState.init () in - { - ask = (FStar_Compiler_Util.with_monitor x ask); - refresh = (FStar_Compiler_Util.with_monitor x refresh); - restart = (FStar_Compiler_Util.with_monitor x restart); - version = - (fun uu___3 -> FStar_Compiler_Effect.op_Bang the_z3proc_version); - ctxt = uu___2 - } in - FStar_Compiler_Util.mk_ref uu___1) -type smt_output_section = Prims.string Prims.list -type smt_output = - { - smt_result: smt_output_section ; - smt_reason_unknown: smt_output_section FStar_Pervasives_Native.option ; - smt_unsat_core: smt_output_section FStar_Pervasives_Native.option ; - smt_statistics: smt_output_section FStar_Pervasives_Native.option ; - smt_labels: smt_output_section FStar_Pervasives_Native.option } -let (__proj__Mksmt_output__item__smt_result : - smt_output -> smt_output_section) = - fun projectee -> - match projectee with - | { smt_result; smt_reason_unknown; smt_unsat_core; smt_statistics; - smt_labels;_} -> smt_result -let (__proj__Mksmt_output__item__smt_reason_unknown : - smt_output -> smt_output_section FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { smt_result; smt_reason_unknown; smt_unsat_core; smt_statistics; - smt_labels;_} -> smt_reason_unknown -let (__proj__Mksmt_output__item__smt_unsat_core : - smt_output -> smt_output_section FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { smt_result; smt_reason_unknown; smt_unsat_core; smt_statistics; - smt_labels;_} -> smt_unsat_core -let (__proj__Mksmt_output__item__smt_statistics : - smt_output -> smt_output_section FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { smt_result; smt_reason_unknown; smt_unsat_core; smt_statistics; - smt_labels;_} -> smt_statistics -let (__proj__Mksmt_output__item__smt_labels : - smt_output -> smt_output_section FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { smt_result; smt_reason_unknown; smt_unsat_core; smt_statistics; - smt_labels;_} -> smt_labels -let (smt_output_sections : - Prims.string FStar_Pervasives_Native.option -> - FStar_Compiler_Range_Type.range -> Prims.string Prims.list -> smt_output) - = - fun log_file -> - fun r -> - fun lines -> - let rec until tag lines1 = - match lines1 with - | [] -> FStar_Pervasives_Native.None - | l::lines2 -> - if tag = l - then FStar_Pervasives_Native.Some ([], lines2) - else - (let uu___1 = until tag lines2 in - FStar_Compiler_Util.map_opt uu___1 - (fun uu___2 -> - match uu___2 with - | (until_tag, rest) -> ((l :: until_tag), rest))) in - let start_tag tag = Prims.strcat "<" (Prims.strcat tag ">") in - let end_tag tag = Prims.strcat "") in - let find_section tag lines1 = - let uu___ = until (start_tag tag) lines1 in - match uu___ with - | FStar_Pervasives_Native.None -> - (FStar_Pervasives_Native.None, lines1) - | FStar_Pervasives_Native.Some (prefix, suffix) -> - let uu___1 = until (end_tag tag) suffix in - (match uu___1 with - | FStar_Pervasives_Native.None -> - failwith - (Prims.strcat "Parse error: " - (Prims.strcat (end_tag tag) " not found")) - | FStar_Pervasives_Native.Some (section, suffix1) -> - ((FStar_Pervasives_Native.Some section), - (FStar_Compiler_List.op_At prefix suffix1))) in - let uu___ = find_section "result" lines in - match uu___ with - | (result_opt, lines1) -> - let result = - match result_opt with - | FStar_Pervasives_Native.None -> - let uu___1 = - FStar_Compiler_Util.format1 - "Unexpexted output from Z3: no result section found:\n%s" - (FStar_Compiler_String.concat "\n" lines1) in - failwith uu___1 - | FStar_Pervasives_Native.Some result1 -> result1 in - let uu___1 = find_section "reason-unknown" lines1 in - (match uu___1 with - | (reason_unknown, lines2) -> - let uu___2 = find_section "unsat-core" lines2 in - (match uu___2 with - | (unsat_core, lines3) -> - let uu___3 = find_section "statistics" lines3 in - (match uu___3 with - | (statistics, lines4) -> - let uu___4 = find_section "labels" lines4 in - (match uu___4 with - | (labels, lines5) -> - let remaining = - let uu___5 = until "Done!" lines5 in - match uu___5 with - | FStar_Pervasives_Native.None -> lines5 - | FStar_Pervasives_Native.Some - (prefix, suffix) -> - FStar_Compiler_List.op_At prefix suffix in - ((match remaining with - | [] -> () - | uu___6 -> - let msg = - FStar_Compiler_String.concat "\n" - remaining in - let suf = - match log_file with - | FStar_Pervasives_Native.Some - log_file1 -> - let uu___7 = - let uu___8 = - FStar_Errors_Msg.text - "Log file:" in - let uu___9 = - FStar_Pprint.doc_of_string - log_file1 in - FStar_Pprint.op_Hat_Slash_Hat - uu___8 uu___9 in - [uu___7] - | FStar_Pervasives_Native.None -> [] in - warn_handler suf msg); - (let uu___6 = - FStar_Compiler_Util.must result_opt in - { - smt_result = uu___6; - smt_reason_unknown = reason_unknown; - smt_unsat_core = unsat_core; - smt_statistics = statistics; - smt_labels = labels - })))))) -let with_solver_state : - 'a . - (FStar_SMTEncoding_SolverState.solver_state -> - ('a * FStar_SMTEncoding_SolverState.solver_state)) - -> 'a - = - fun f -> - let ss = FStar_Compiler_Effect.op_Bang bg_z3_proc in - let uu___ = f ss.ctxt in - match uu___ with - | (res, ctxt) -> - (FStar_Compiler_Effect.op_Colon_Equals bg_z3_proc - { - ask = (ss.ask); - refresh = (ss.refresh); - restart = (ss.restart); - version = (ss.version); - ctxt - }; - res) -let (with_solver_state_unit : - (FStar_SMTEncoding_SolverState.solver_state -> - FStar_SMTEncoding_SolverState.solver_state) - -> unit) - = fun f -> with_solver_state (fun x -> let uu___ = f x in ((), uu___)) -let reading_solver_state : - 'a . (FStar_SMTEncoding_SolverState.solver_state -> 'a) -> 'a = - fun f -> let ss = FStar_Compiler_Effect.op_Bang bg_z3_proc in f ss.ctxt -let (push : Prims.string -> unit) = - fun msg -> - with_solver_state_unit FStar_SMTEncoding_SolverState.push; - with_solver_state_unit - (FStar_SMTEncoding_SolverState.give - [FStar_SMTEncoding_Term.Caption msg]) -let (pop : Prims.string -> unit) = - fun msg -> - with_solver_state_unit - (FStar_SMTEncoding_SolverState.give - [FStar_SMTEncoding_Term.Caption msg]); - with_solver_state_unit FStar_SMTEncoding_SolverState.pop -let (snapshot : Prims.string -> Prims.int) = - fun msg -> - let d = reading_solver_state FStar_SMTEncoding_SolverState.depth in - push msg; d -let (rollback : - Prims.string -> Prims.int FStar_Pervasives_Native.option -> unit) = - fun msg -> - fun depth -> - let rec rollback_aux msg1 depth1 = - let d = reading_solver_state FStar_SMTEncoding_SolverState.depth in - match depth1 with - | FStar_Pervasives_Native.None -> pop msg1 - | FStar_Pervasives_Native.Some n -> - if d = n then () else (pop msg1; rollback_aux msg1 depth1) in - rollback_aux msg depth -let (start_query : - Prims.string -> - FStar_SMTEncoding_Term.decl Prims.list -> - FStar_SMTEncoding_Term.decl -> unit) - = - fun msg -> - fun roots_to_push -> - fun qry -> - with_solver_state_unit - (FStar_SMTEncoding_SolverState.start_query msg roots_to_push qry) -let (finish_query : Prims.string -> unit) = - fun msg -> - with_solver_state_unit (FStar_SMTEncoding_SolverState.finish_query msg) -let (giveZ3 : FStar_SMTEncoding_Term.decl Prims.list -> unit) = - fun decls -> - with_solver_state_unit (FStar_SMTEncoding_SolverState.give decls) -let (refresh : - FStar_SMTEncoding_SolverState.using_facts_from_setting - FStar_Pervasives_Native.option -> unit) - = - fun using_facts_from -> - (let uu___1 = FStar_Compiler_Effect.op_Bang bg_z3_proc in - uu___1.refresh ()); - with_solver_state_unit - (FStar_SMTEncoding_SolverState.reset using_facts_from) -let (doZ3Exe : - Prims.string FStar_Pervasives_Native.option -> - FStar_Compiler_Range_Type.range -> - Prims.bool -> - Prims.string -> - FStar_SMTEncoding_Term.error_labels -> - Prims.string -> (z3status * z3statistics)) - = - fun log_file -> - fun r -> - fun fresh -> - fun input -> - fun label_messages -> - fun queryid -> - let parse z3out = - let lines = - FStar_Compiler_List.map FStar_Compiler_Util.trim_string - (FStar_Compiler_String.split [10] z3out) in - let smt_output1 = smt_output_sections log_file r lines in - let unsat_core = - match smt_output1.smt_unsat_core with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some s -> - let s1 = - FStar_Compiler_Util.trim_string - (FStar_Compiler_String.concat " " s) in - let s2 = - FStar_Compiler_Util.substring s1 Prims.int_one - ((FStar_Compiler_String.length s1) - - (Prims.of_int (2))) in - if FStar_Compiler_Util.starts_with s2 "error" - then FStar_Pervasives_Native.None - else - (let uu___1 = - FStar_Compiler_Util.sort_with - FStar_Compiler_String.compare - (FStar_Compiler_Util.split s2 " ") in - FStar_Pervasives_Native.Some uu___1) in - let labels = - match smt_output1.smt_labels with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some lines1 -> - let rec lblnegs lines2 = - match lines2 with - | lname::"false"::rest when - FStar_Compiler_Util.starts_with lname "label_" -> - let uu___ = lblnegs rest in lname :: uu___ - | lname::uu___::rest when - FStar_Compiler_Util.starts_with lname "label_" -> - lblnegs rest - | uu___ -> [] in - let lblnegs1 = lblnegs lines1 in - FStar_Compiler_List.collect - (fun l -> - let uu___ = - FStar_Compiler_List.tryFind - (fun uu___1 -> - match uu___1 with - | (m, uu___2, uu___3) -> - let uu___4 = - FStar_SMTEncoding_Term.fv_name m in - uu___4 = l) label_messages in - match uu___ with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some (lbl, msg, r1) -> - [(lbl, msg, r1)]) lblnegs1 in - let statistics = - let statistics1 = - FStar_Compiler_Util.smap_create Prims.int_zero in - match smt_output1.smt_statistics with - | FStar_Pervasives_Native.None -> statistics1 - | FStar_Pervasives_Native.Some lines1 -> - let parse_line line = - let pline = - FStar_Compiler_Util.split - (FStar_Compiler_Util.trim_string line) ":" in - match pline with - | "("::entry::[] -> - let tokens = FStar_Compiler_Util.split entry " " in - let key = FStar_Compiler_List.hd tokens in - let ltok = - FStar_Compiler_List.nth tokens - ((FStar_Compiler_List.length tokens) - - Prims.int_one) in - let value = - if FStar_Compiler_Util.ends_with ltok ")" - then - FStar_Compiler_Util.substring ltok - Prims.int_zero - ((FStar_Compiler_String.length ltok) - - Prims.int_one) - else ltok in - FStar_Compiler_Util.smap_add statistics1 key - value - | ""::entry::[] -> - let tokens = FStar_Compiler_Util.split entry " " in - let key = FStar_Compiler_List.hd tokens in - let ltok = - FStar_Compiler_List.nth tokens - ((FStar_Compiler_List.length tokens) - - Prims.int_one) in - let value = - if FStar_Compiler_Util.ends_with ltok ")" - then - FStar_Compiler_Util.substring ltok - Prims.int_zero - ((FStar_Compiler_String.length ltok) - - Prims.int_one) - else ltok in - FStar_Compiler_Util.smap_add statistics1 key - value - | uu___ -> () in - (FStar_Compiler_List.iter parse_line lines1; - statistics1) in - let reason_unknown = - FStar_Compiler_Util.map_opt smt_output1.smt_reason_unknown - (fun x -> - let ru = FStar_Compiler_String.concat " " x in - if - FStar_Compiler_Util.starts_with ru - "(:reason-unknown \"" - then - let reason = - FStar_Compiler_Util.substring_from ru - (FStar_Compiler_String.length - "(:reason-unknown \"") in - let res = - FStar_Compiler_String.substring reason - Prims.int_zero - ((FStar_Compiler_String.length reason) - - (Prims.of_int (2))) in - res - else ru) in - let status = - (let uu___1 = FStar_Compiler_Debug.any () in - if uu___1 - then - let uu___2 = - FStar_Compiler_Util.format1 "Z3 says: %s\n" - (FStar_Compiler_String.concat "\n" - smt_output1.smt_result) in - FStar_Compiler_Util.print_string uu___2 - else ()); - (match smt_output1.smt_result with - | "unsat"::[] -> UNSAT unsat_core - | "sat"::[] -> SAT (labels, reason_unknown) - | "unknown"::[] -> UNKNOWN (labels, reason_unknown) - | "timeout"::[] -> TIMEOUT (labels, reason_unknown) - | "killed"::[] -> - ((let uu___2 = - FStar_Compiler_Effect.op_Bang bg_z3_proc in - uu___2.restart ()); - KILLED) - | uu___1 -> - let uu___2 = - FStar_Compiler_Util.format1 - "Unexpected output from Z3: got output result: %s\n" - (FStar_Compiler_String.concat "\n" - smt_output1.smt_result) in - failwith uu___2) in - (status, statistics) in - let log_result fwrite uu___ = - match uu___ with - | (res, _stats) -> - ((match log_file with - | FStar_Pervasives_Native.Some fname -> - (fwrite fname (Prims.strcat "; QUERY ID: " queryid); - (let uu___4 = - let uu___5 = - let uu___6 = status_string_and_errors res in - FStar_Pervasives_Native.fst uu___6 in - Prims.strcat "; STATUS: " uu___5 in - fwrite fname uu___4); - (match res with - | UNSAT (FStar_Pervasives_Native.Some core) -> - fwrite fname - (Prims.strcat "; UNSAT CORE GENERATED: " - (FStar_Compiler_String.concat ", " core)) - | uu___4 -> ())) - | FStar_Pervasives_Native.None -> ()); - (let log_file_name = - match log_file with - | FStar_Pervasives_Native.Some fname -> fname - | uu___2 -> "" in - let uu___3 = - let uu___4 = - reading_solver_state - FStar_SMTEncoding_SolverState.would_have_pruned in - (uu___4, res) in - match uu___3 with - | (FStar_Pervasives_Native.Some names, UNSAT - (FStar_Pervasives_Native.Some core)) -> - let whitelist = - ["BoxInt"; - "BoxBool"; - "BoxString"; - "BoxReal"; - "Tm_unit"; - "FString_const"] in - let missing = - FStar_Compiler_List.filter - (fun name -> - (((((let uu___4 = - FStar_Compiler_Util.for_some - (fun wl -> - FStar_Compiler_Util.contains - name wl) whitelist in - Prims.op_Negation uu___4) && - (Prims.op_Negation - (FStar_Compiler_Util.starts_with - name "binder_"))) - && - (Prims.op_Negation - (FStar_Compiler_Util.starts_with - name "@query"))) - && - (Prims.op_Negation - (FStar_Compiler_Util.starts_with name - "@MaxFuel"))) - && - (Prims.op_Negation - (FStar_Compiler_Util.starts_with name - "@MaxIFuel"))) - && - (let uu___4 = - FStar_Compiler_Util.for_some - (fun name' -> name = name') names in - Prims.op_Negation uu___4)) core in - (match missing with - | [] -> () - | uu___4 -> - FStar_Compiler_Util.print3 - "Query %s (%s): Pruned theory would miss %s\n" - queryid log_file_name - (FStar_Compiler_String.concat ", " missing)) - | uu___4 -> ())) in - if fresh - then - let proc = - let uu___ = z3_cmd_and_args () in new_z3proc_with_id uu___ in - let kill_handler uu___ = "\nkilled\n" in - let out = - FStar_Compiler_Util.ask_process proc input kill_handler - (warn_handler []) in - let r1 = parse (FStar_Compiler_Util.trim_string out) in - (log_result - (fun fname -> - fun s -> - let h = - FStar_Compiler_Util.open_file_for_appending fname in - FStar_Compiler_Util.append_to_file h s; - FStar_Compiler_Util.close_out_channel h) r1; - FStar_Compiler_Util.kill_process proc; - r1) - else - (let out = - let uu___1 = FStar_Compiler_Effect.op_Bang bg_z3_proc in - uu___1.ask input in - let r1 = parse (FStar_Compiler_Util.trim_string out) in - log_result - (fun _fname -> - fun s -> - let uu___2 = query_logging.append_to_log s in ()) r1; - r1) -let (z3_options : Prims.string -> Prims.string) = - fun ver -> - let opts = - ["(set-option :global-decls false)"; - "(set-option :smt.mbqi false)"; - "(set-option :auto_config false)"; - "(set-option :produce-unsat-cores true)"; - "(set-option :model true)"; - "(set-option :smt.case_split 3)"; - "(set-option :smt.relevancy 2)"] in - let opts1 = - let uu___ = - let uu___1 = FStar_Compiler_Misc.version_ge ver "4.12.3" in - if uu___1 - then - ["(set-option :rewriter.enable_der false)"; - "(set-option :rewriter.sort_disjunctions false)"; - "(set-option :pi.decompose_patterns false)"; - "(set-option :smt.arith.solver 6)"] - else ["(set-option :smt.arith.solver 2)"] in - FStar_Compiler_List.op_At opts uu___ in - Prims.strcat (FStar_Compiler_String.concat "\n" opts1) "\n" -let (context_profile : FStar_SMTEncoding_Term.decl Prims.list -> unit) = - fun theory -> - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun d -> - match uu___1 with - | (out, _total) -> - (match d with - | FStar_SMTEncoding_Term.Module (name, decls) -> - let decls1 = - FStar_Compiler_List.filter - (fun uu___2 -> - match uu___2 with - | FStar_SMTEncoding_Term.Assume uu___3 -> true - | uu___3 -> false) decls in - let n = FStar_Compiler_List.length decls1 in - (((name, n) :: out), (n + _total)) - | uu___2 -> (out, _total))) ([], Prims.int_zero) theory in - match uu___ with - | (modules, total_decls) -> - let modules1 = - FStar_Compiler_List.sortWith - (fun uu___1 -> - fun uu___2 -> - match (uu___1, uu___2) with - | ((uu___3, n), (uu___4, m)) -> m - n) modules in - (if modules1 <> [] - then - (let uu___2 = FStar_Compiler_Util.string_of_int total_decls in - FStar_Compiler_Util.print1 - "Z3 Proof Stats: context_profile with %s assertions\n" uu___2) - else (); - FStar_Compiler_List.iter - (fun uu___2 -> - match uu___2 with - | (m, n) -> - if n <> Prims.int_zero - then - let uu___3 = FStar_Compiler_Util.string_of_int n in - FStar_Compiler_Util.print2 - "Z3 Proof Stats: %s produced %s SMT decls\n" m uu___3 - else ()) modules1) -let (mk_input : - Prims.bool -> - FStar_SMTEncoding_Term.decl Prims.list -> - (Prims.string * Prims.string FStar_Pervasives_Native.option * - Prims.string FStar_Pervasives_Native.option)) - = - fun fresh -> - fun theory -> - let ver = FStar_Options.z3_version () in - let theory1 = - let uu___ = - let uu___1 = - let uu___2 = FStar_Compiler_Effect.op_Bang FStar_Options._version in - let uu___3 = FStar_Compiler_Effect.op_Bang FStar_Options._commit in - FStar_Compiler_Util.format3 - "Z3 invocation started by F*\nF* version: %s -- commit hash: %s\nZ3 version (according to F*): %s" - uu___2 uu___3 ver in - FStar_SMTEncoding_Term.Caption uu___1 in - uu___ :: theory in - let options = z3_options ver in - let options1 = - let uu___ = - let uu___1 = - let uu___2 = FStar_Options.z3_smtopt () in - FStar_Compiler_String.concat "\n" uu___2 in - Prims.strcat uu___1 "\n\n" in - Prims.strcat options uu___ in - (let uu___1 = FStar_Options.print_z3_statistics () in - if uu___1 then context_profile theory1 else ()); - (let uu___1 = - let uu___2 = - (FStar_Options.record_hints ()) || - ((FStar_Options.use_hints ()) && - (FStar_Options.use_hint_hashes ())) in - if uu___2 - then - let uu___3 = - let uu___4 = - FStar_Compiler_Util.prefix_until - (fun uu___5 -> - match uu___5 with - | FStar_SMTEncoding_Term.CheckSat -> true - | uu___6 -> false) theory1 in - FStar_Compiler_Option.get uu___4 in - match uu___3 with - | (prefix, check_sat, suffix) -> - let pp = - FStar_Compiler_List.map - (FStar_SMTEncoding_Term.declToSmt options1) in - let suffix1 = check_sat :: suffix in - let ps_lines = pp prefix in - let ss_lines = pp suffix1 in - let ps = FStar_Compiler_String.concat "\n" ps_lines in - let ss = FStar_Compiler_String.concat "\n" ss_lines in - let hs = - let uu___4 = FStar_Options.keep_query_captions () in - if uu___4 - then - let uu___5 = - FStar_Compiler_List.map - (FStar_SMTEncoding_Term.declToSmt_no_caps options1) - prefix in - FStar_Compiler_String.concat "\n" uu___5 - else ps in - let hs1 = Prims.strcat hs (Prims.strcat "Z3 version: " ver) in - let uu___4 = - let uu___5 = FStar_Compiler_Util.digest_of_string hs1 in - FStar_Pervasives_Native.Some uu___5 in - ((Prims.strcat ps (Prims.strcat "\n" ss)), uu___4) - else - (let uu___4 = - let uu___5 = - FStar_Compiler_List.map - (FStar_SMTEncoding_Term.declToSmt options1) theory1 in - FStar_Compiler_String.concat "\n" uu___5 in - (uu___4, FStar_Pervasives_Native.None)) in - match uu___1 with - | (r, hash) -> - let log_file_name = - let uu___2 = FStar_Options.log_queries () in - if uu___2 - then - let uu___3 = query_logging.write_to_log fresh r in - FStar_Pervasives_Native.Some uu___3 - else FStar_Pervasives_Native.None in - (r, hash, log_file_name)) -let (cache_hit : - Prims.string FStar_Pervasives_Native.option -> - Prims.string FStar_Pervasives_Native.option -> - Prims.string FStar_Pervasives_Native.option -> - z3result FStar_Pervasives_Native.option) - = - fun log_file -> - fun cache -> - fun qhash -> - let uu___ = - (FStar_Options.use_hints ()) && (FStar_Options.use_hint_hashes ()) in - if uu___ - then - match qhash with - | FStar_Pervasives_Native.Some x when qhash = cache -> - let stats = FStar_Compiler_Util.smap_create Prims.int_zero in - (FStar_Compiler_Util.smap_add stats "fstar_cache_hit" "1"; - (let result = - { - z3result_status = (UNSAT FStar_Pervasives_Native.None); - z3result_time = Prims.int_zero; - z3result_statistics = stats; - z3result_query_hash = qhash; - z3result_log_file = log_file - } in - FStar_Pervasives_Native.Some result)) - | uu___1 -> FStar_Pervasives_Native.None - else FStar_Pervasives_Native.None -let (z3_job : - Prims.string FStar_Pervasives_Native.option -> - FStar_Compiler_Range_Type.range -> - Prims.bool -> - FStar_SMTEncoding_Term.error_labels -> - Prims.string -> - Prims.string FStar_Pervasives_Native.option -> - Prims.string -> z3result) - = - fun log_file -> - fun r -> - fun fresh -> - fun label_messages -> - fun input -> - fun qhash -> - fun queryid -> - let uu___ = - let uu___1 = - let uu___2 = query_logging.get_module_name () in - FStar_Pervasives_Native.Some uu___2 in - FStar_Profiling.profile - (fun uu___2 -> - try - (fun uu___3 -> - match () with - | () -> - FStar_Compiler_Util.record_time - (fun uu___4 -> - doZ3Exe log_file r fresh input - label_messages queryid)) () - with - | uu___3 -> - (refresh FStar_Pervasives_Native.None; - FStar_Compiler_Effect.raise uu___3)) uu___1 - "FStar.SMTEncoding.Z3 (aggregate query time)" in - match uu___ with - | ((status, statistics), elapsed_time) -> - { - z3result_status = status; - z3result_time = elapsed_time; - z3result_statistics = statistics; - z3result_query_hash = qhash; - z3result_log_file = log_file - } -let (ask_text : - FStar_Compiler_Range_Type.range -> - Prims.string FStar_Pervasives_Native.option -> - FStar_SMTEncoding_Term.error_labels -> - FStar_SMTEncoding_Term.decl Prims.list -> - Prims.string -> - FStar_SMTEncoding_UnsatCore.unsat_core - FStar_Pervasives_Native.option -> Prims.string) - = - fun r -> - fun cache -> - fun label_messages -> - fun qry -> - fun queryid -> - fun core -> - let theory = - match core with - | FStar_Pervasives_Native.None -> - with_solver_state FStar_SMTEncoding_SolverState.flush - | FStar_Pervasives_Native.Some core1 -> - reading_solver_state - (FStar_SMTEncoding_SolverState.filter_with_unsat_core - queryid core1) in - let query_tail = - FStar_Compiler_List.op_At - ((FStar_SMTEncoding_Term.Push Prims.int_zero) :: qry) - [FStar_SMTEncoding_Term.Pop Prims.int_zero] in - let theory1 = FStar_Compiler_List.op_At theory query_tail in - let uu___ = mk_input true theory1 in - match uu___ with | (input, qhash, log_file_name) -> input -let (ask : - FStar_Compiler_Range_Type.range -> - Prims.string FStar_Pervasives_Native.option -> - FStar_SMTEncoding_Term.error_labels -> - FStar_SMTEncoding_Term.decl Prims.list -> - Prims.string -> - Prims.bool -> - FStar_SMTEncoding_UnsatCore.unsat_core - FStar_Pervasives_Native.option -> z3result) - = - fun r -> - fun cache -> - fun label_messages -> - fun qry -> - fun queryid -> - fun fresh -> - fun core -> - let theory = - match core with - | FStar_Pervasives_Native.None -> - with_solver_state FStar_SMTEncoding_SolverState.flush - | FStar_Pervasives_Native.Some core1 -> - (if Prims.op_Negation fresh - then - failwith - "Unexpected: unsat core must only be used with fresh solvers" - else (); - reading_solver_state - (FStar_SMTEncoding_SolverState.filter_with_unsat_core - queryid core1)) in - let theory1 = - FStar_Compiler_List.op_At theory - (FStar_Compiler_List.op_At - ((FStar_SMTEncoding_Term.Push Prims.int_zero) :: qry) - [FStar_SMTEncoding_Term.Pop Prims.int_zero]) in - let uu___ = mk_input fresh theory1 in - match uu___ with - | (input, qhash, log_file_name) -> - let just_ask uu___1 = - z3_job log_file_name r fresh label_messages input qhash - queryid in - let result = - if fresh - then - let uu___1 = cache_hit log_file_name cache qhash in - match uu___1 with - | FStar_Pervasives_Native.Some z3r -> z3r - | FStar_Pervasives_Native.None -> just_ask () - else just_ask () in - result \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_Compress.ml b/ocaml/fstar-lib/generated/FStar_Syntax_Compress.ml deleted file mode 100644 index 4c4bd4352a9..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Syntax_Compress.ml +++ /dev/null @@ -1,164 +0,0 @@ -open Prims -let (compress1_t : - Prims.bool -> - Prims.bool -> FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun allow_uvars -> - fun allow_names -> - fun t -> - let mk x = FStar_Syntax_Syntax.mk x t.FStar_Syntax_Syntax.pos in - match t.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_uvar (uv, s) when - Prims.op_Negation allow_uvars -> - let uu___ = - let uu___1 = - FStar_Class_Show.show FStar_Syntax_Print.showable_ctxu uv in - FStar_Compiler_Util.format1 - "Internal error: unexpected unresolved uvar in deep_compress: %s" - uu___1 in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Error_UnexpectedUnresolvedUvar () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___) - | FStar_Syntax_Syntax.Tm_name bv when Prims.op_Negation allow_names - -> - ((let uu___1 = FStar_Compiler_Debug.any () in - if uu___1 - then - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_bv bv in - FStar_Compiler_Util.format1 "Tm_name %s in deep compress" - uu___3 in - FStar_Errors.log_issue - (FStar_Syntax_Syntax.has_range_syntax ()) t - FStar_Errors_Codes.Warning_NameEscape () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2) - else ()); - (let uu___1 = - let uu___2 = - let uu___3 = mk FStar_Syntax_Syntax.Tm_unknown in - { - FStar_Syntax_Syntax.ppname = - (bv.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (bv.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = uu___3 - } in - FStar_Syntax_Syntax.Tm_name uu___2 in - mk uu___1)) - | FStar_Syntax_Syntax.Tm_bvar bv -> - let uu___ = - let uu___1 = - let uu___2 = mk FStar_Syntax_Syntax.Tm_unknown in - { - FStar_Syntax_Syntax.ppname = - (bv.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = (bv.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = uu___2 - } in - FStar_Syntax_Syntax.Tm_bvar uu___1 in - mk uu___ - | FStar_Syntax_Syntax.Tm_name bv -> - let uu___ = - let uu___1 = - let uu___2 = mk FStar_Syntax_Syntax.Tm_unknown in - { - FStar_Syntax_Syntax.ppname = - (bv.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = (bv.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = uu___2 - } in - FStar_Syntax_Syntax.Tm_name uu___1 in - mk uu___ - | uu___ -> t -let (compress1_u : - Prims.bool -> - Prims.bool -> - FStar_Syntax_Syntax.universe -> FStar_Syntax_Syntax.universe) - = - fun allow_uvars -> - fun allow_names -> - fun u -> - match u with - | FStar_Syntax_Syntax.U_name bv when Prims.op_Negation allow_names -> - ((let uu___1 = FStar_Compiler_Debug.any () in - if uu___1 - then - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Ident.showable_ident bv in - FStar_Compiler_Util.format1 "U_name %s in deep compress" - uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NameEscape - () (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2) - else ()); - u) - | FStar_Syntax_Syntax.U_unif uv when Prims.op_Negation allow_uvars -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Syntax_Unionfind.univ_uvar_id uv in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) uu___2 in - FStar_Compiler_Util.format1 - "Internal error: unexpected unresolved (universe) uvar in deep_compress: %s" - uu___1 in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Error_UnexpectedUnresolvedUvar () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___) - | uu___ -> u -let (deep_compress : - Prims.bool -> - Prims.bool -> FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun allow_uvars -> - fun allow_names -> - fun tm -> - FStar_Errors.with_ctx "While deep-compressing a term" - (fun uu___ -> - let uu___1 = compress1_t allow_uvars allow_names in - let uu___2 = compress1_u allow_uvars allow_names in - FStar_Syntax_Visit.visit_term_univs true uu___1 uu___2 tm) -let (deep_compress_uvars : - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = - deep_compress false true -let (deep_compress_if_no_uvars : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = - fun tm -> - FStar_Errors.with_ctx "While deep-compressing a term" - (fun uu___ -> - try - (fun uu___1 -> - match () with - | () -> - let uu___2 = - let uu___3 = compress1_t false true in - let uu___4 = compress1_u false true in - FStar_Syntax_Visit.visit_term_univs true uu___3 uu___4 tm in - FStar_Pervasives_Native.Some uu___2) () - with - | FStar_Errors.Error - (FStar_Errors_Codes.Error_UnexpectedUnresolvedUvar, uu___2, - uu___3, uu___4) - -> FStar_Pervasives_Native.None) -let (deep_compress_se : - Prims.bool -> - Prims.bool -> FStar_Syntax_Syntax.sigelt -> FStar_Syntax_Syntax.sigelt) - = - fun allow_uvars -> - fun allow_names -> - fun se -> - let uu___ = - let uu___1 = FStar_Syntax_Print.sigelt_to_string_short se in - FStar_Compiler_Util.format1 "While deep-compressing %s" uu___1 in - FStar_Errors.with_ctx uu___ - (fun uu___1 -> - let uu___2 = compress1_t allow_uvars allow_names in - let uu___3 = compress1_u allow_uvars allow_names in - FStar_Syntax_Visit.visit_sigelt true uu___2 uu___3 se) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_DsEnv.ml b/ocaml/fstar-lib/generated/FStar_Syntax_DsEnv.ml deleted file mode 100644 index d20ca6da0d4..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Syntax_DsEnv.ml +++ /dev/null @@ -1,4105 +0,0 @@ -open Prims -let (ugly_sigelt_to_string_hook : - (FStar_Syntax_Syntax.sigelt -> Prims.string) FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref (fun uu___ -> "") -type used_marker = Prims.bool FStar_Compiler_Effect.ref -type record_or_dc = - { - typename: FStar_Ident.lident ; - constrname: FStar_Ident.ident ; - parms: FStar_Syntax_Syntax.binders ; - fields: (FStar_Ident.ident * FStar_Syntax_Syntax.typ) Prims.list ; - is_private: Prims.bool ; - is_record: Prims.bool } -let (__proj__Mkrecord_or_dc__item__typename : - record_or_dc -> FStar_Ident.lident) = - fun projectee -> - match projectee with - | { typename; constrname; parms; fields; is_private; is_record;_} -> - typename -let (__proj__Mkrecord_or_dc__item__constrname : - record_or_dc -> FStar_Ident.ident) = - fun projectee -> - match projectee with - | { typename; constrname; parms; fields; is_private; is_record;_} -> - constrname -let (__proj__Mkrecord_or_dc__item__parms : - record_or_dc -> FStar_Syntax_Syntax.binders) = - fun projectee -> - match projectee with - | { typename; constrname; parms; fields; is_private; is_record;_} -> - parms -let (__proj__Mkrecord_or_dc__item__fields : - record_or_dc -> (FStar_Ident.ident * FStar_Syntax_Syntax.typ) Prims.list) = - fun projectee -> - match projectee with - | { typename; constrname; parms; fields; is_private; is_record;_} -> - fields -let (__proj__Mkrecord_or_dc__item__is_private : record_or_dc -> Prims.bool) = - fun projectee -> - match projectee with - | { typename; constrname; parms; fields; is_private; is_record;_} -> - is_private -let (__proj__Mkrecord_or_dc__item__is_record : record_or_dc -> Prims.bool) = - fun projectee -> - match projectee with - | { typename; constrname; parms; fields; is_private; is_record;_} -> - is_record -let (ugly_sigelt_to_string : FStar_Syntax_Syntax.sigelt -> Prims.string) = - fun se -> - let uu___ = FStar_Compiler_Effect.op_Bang ugly_sigelt_to_string_hook in - uu___ se -type local_binding = - (FStar_Ident.ident * FStar_Syntax_Syntax.bv * used_marker) -type rec_binding = (FStar_Ident.ident * FStar_Ident.lid * used_marker) -type scope_mod = - | Local_binding of local_binding - | Rec_binding of rec_binding - | Module_abbrev of FStar_Syntax_Syntax.module_abbrev - | Open_module_or_namespace of FStar_Syntax_Syntax.open_module_or_namespace - - | Top_level_def of FStar_Ident.ident - | Record_or_dc of record_or_dc -let (uu___is_Local_binding : scope_mod -> Prims.bool) = - fun projectee -> - match projectee with | Local_binding _0 -> true | uu___ -> false -let (__proj__Local_binding__item___0 : scope_mod -> local_binding) = - fun projectee -> match projectee with | Local_binding _0 -> _0 -let (uu___is_Rec_binding : scope_mod -> Prims.bool) = - fun projectee -> - match projectee with | Rec_binding _0 -> true | uu___ -> false -let (__proj__Rec_binding__item___0 : scope_mod -> rec_binding) = - fun projectee -> match projectee with | Rec_binding _0 -> _0 -let (uu___is_Module_abbrev : scope_mod -> Prims.bool) = - fun projectee -> - match projectee with | Module_abbrev _0 -> true | uu___ -> false -let (__proj__Module_abbrev__item___0 : - scope_mod -> FStar_Syntax_Syntax.module_abbrev) = - fun projectee -> match projectee with | Module_abbrev _0 -> _0 -let (uu___is_Open_module_or_namespace : scope_mod -> Prims.bool) = - fun projectee -> - match projectee with - | Open_module_or_namespace _0 -> true - | uu___ -> false -let (__proj__Open_module_or_namespace__item___0 : - scope_mod -> FStar_Syntax_Syntax.open_module_or_namespace) = - fun projectee -> match projectee with | Open_module_or_namespace _0 -> _0 -let (uu___is_Top_level_def : scope_mod -> Prims.bool) = - fun projectee -> - match projectee with | Top_level_def _0 -> true | uu___ -> false -let (__proj__Top_level_def__item___0 : scope_mod -> FStar_Ident.ident) = - fun projectee -> match projectee with | Top_level_def _0 -> _0 -let (uu___is_Record_or_dc : scope_mod -> Prims.bool) = - fun projectee -> - match projectee with | Record_or_dc _0 -> true | uu___ -> false -let (__proj__Record_or_dc__item___0 : scope_mod -> record_or_dc) = - fun projectee -> match projectee with | Record_or_dc _0 -> _0 -type string_set = Prims.string FStar_Compiler_RBSet.t -type exported_id_kind = - | Exported_id_term_type - | Exported_id_field -let (uu___is_Exported_id_term_type : exported_id_kind -> Prims.bool) = - fun projectee -> - match projectee with | Exported_id_term_type -> true | uu___ -> false -let (uu___is_Exported_id_field : exported_id_kind -> Prims.bool) = - fun projectee -> - match projectee with | Exported_id_field -> true | uu___ -> false -type exported_id_set = - exported_id_kind -> string_set FStar_Compiler_Effect.ref -type env = - { - curmodule: FStar_Ident.lident FStar_Pervasives_Native.option ; - curmonad: FStar_Ident.ident FStar_Pervasives_Native.option ; - modules: (FStar_Ident.lident * FStar_Syntax_Syntax.modul) Prims.list ; - scope_mods: scope_mod Prims.list ; - exported_ids: exported_id_set FStar_Compiler_Util.smap ; - trans_exported_ids: exported_id_set FStar_Compiler_Util.smap ; - includes: - (FStar_Ident.lident * FStar_Syntax_Syntax.restriction) Prims.list - FStar_Compiler_Effect.ref FStar_Compiler_Util.smap - ; - sigaccum: FStar_Syntax_Syntax.sigelts ; - sigmap: (FStar_Syntax_Syntax.sigelt * Prims.bool) FStar_Compiler_Util.smap ; - iface: Prims.bool ; - admitted_iface: Prims.bool ; - expect_typ: Prims.bool ; - remaining_iface_decls: - (FStar_Ident.lident * FStar_Parser_AST.decl Prims.list) Prims.list ; - syntax_only: Prims.bool ; - ds_hooks: dsenv_hooks ; - dep_graph: FStar_Parser_Dep.deps } -and dsenv_hooks = - { - ds_push_open_hook: - env -> FStar_Syntax_Syntax.open_module_or_namespace -> unit ; - ds_push_include_hook: env -> FStar_Ident.lident -> unit ; - ds_push_module_abbrev_hook: - env -> FStar_Ident.ident -> FStar_Ident.lident -> unit } -let (__proj__Mkenv__item__curmodule : - env -> FStar_Ident.lident FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { curmodule; curmonad; modules; scope_mods; exported_ids; - trans_exported_ids; includes; sigaccum; sigmap; iface; - admitted_iface; expect_typ; remaining_iface_decls; syntax_only; - ds_hooks; dep_graph;_} -> curmodule -let (__proj__Mkenv__item__curmonad : - env -> FStar_Ident.ident FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { curmodule; curmonad; modules; scope_mods; exported_ids; - trans_exported_ids; includes; sigaccum; sigmap; iface; - admitted_iface; expect_typ; remaining_iface_decls; syntax_only; - ds_hooks; dep_graph;_} -> curmonad -let (__proj__Mkenv__item__modules : - env -> (FStar_Ident.lident * FStar_Syntax_Syntax.modul) Prims.list) = - fun projectee -> - match projectee with - | { curmodule; curmonad; modules; scope_mods; exported_ids; - trans_exported_ids; includes; sigaccum; sigmap; iface; - admitted_iface; expect_typ; remaining_iface_decls; syntax_only; - ds_hooks; dep_graph;_} -> modules -let (__proj__Mkenv__item__scope_mods : env -> scope_mod Prims.list) = - fun projectee -> - match projectee with - | { curmodule; curmonad; modules; scope_mods; exported_ids; - trans_exported_ids; includes; sigaccum; sigmap; iface; - admitted_iface; expect_typ; remaining_iface_decls; syntax_only; - ds_hooks; dep_graph;_} -> scope_mods -let (__proj__Mkenv__item__exported_ids : - env -> exported_id_set FStar_Compiler_Util.smap) = - fun projectee -> - match projectee with - | { curmodule; curmonad; modules; scope_mods; exported_ids; - trans_exported_ids; includes; sigaccum; sigmap; iface; - admitted_iface; expect_typ; remaining_iface_decls; syntax_only; - ds_hooks; dep_graph;_} -> exported_ids -let (__proj__Mkenv__item__trans_exported_ids : - env -> exported_id_set FStar_Compiler_Util.smap) = - fun projectee -> - match projectee with - | { curmodule; curmonad; modules; scope_mods; exported_ids; - trans_exported_ids; includes; sigaccum; sigmap; iface; - admitted_iface; expect_typ; remaining_iface_decls; syntax_only; - ds_hooks; dep_graph;_} -> trans_exported_ids -let (__proj__Mkenv__item__includes : - env -> - (FStar_Ident.lident * FStar_Syntax_Syntax.restriction) Prims.list - FStar_Compiler_Effect.ref FStar_Compiler_Util.smap) - = - fun projectee -> - match projectee with - | { curmodule; curmonad; modules; scope_mods; exported_ids; - trans_exported_ids; includes; sigaccum; sigmap; iface; - admitted_iface; expect_typ; remaining_iface_decls; syntax_only; - ds_hooks; dep_graph;_} -> includes -let (__proj__Mkenv__item__sigaccum : env -> FStar_Syntax_Syntax.sigelts) = - fun projectee -> - match projectee with - | { curmodule; curmonad; modules; scope_mods; exported_ids; - trans_exported_ids; includes; sigaccum; sigmap; iface; - admitted_iface; expect_typ; remaining_iface_decls; syntax_only; - ds_hooks; dep_graph;_} -> sigaccum -let (__proj__Mkenv__item__sigmap : - env -> (FStar_Syntax_Syntax.sigelt * Prims.bool) FStar_Compiler_Util.smap) - = - fun projectee -> - match projectee with - | { curmodule; curmonad; modules; scope_mods; exported_ids; - trans_exported_ids; includes; sigaccum; sigmap; iface; - admitted_iface; expect_typ; remaining_iface_decls; syntax_only; - ds_hooks; dep_graph;_} -> sigmap -let (__proj__Mkenv__item__iface : env -> Prims.bool) = - fun projectee -> - match projectee with - | { curmodule; curmonad; modules; scope_mods; exported_ids; - trans_exported_ids; includes; sigaccum; sigmap; iface; - admitted_iface; expect_typ; remaining_iface_decls; syntax_only; - ds_hooks; dep_graph;_} -> iface -let (__proj__Mkenv__item__admitted_iface : env -> Prims.bool) = - fun projectee -> - match projectee with - | { curmodule; curmonad; modules; scope_mods; exported_ids; - trans_exported_ids; includes; sigaccum; sigmap; iface; - admitted_iface; expect_typ; remaining_iface_decls; syntax_only; - ds_hooks; dep_graph;_} -> admitted_iface -let (__proj__Mkenv__item__expect_typ : env -> Prims.bool) = - fun projectee -> - match projectee with - | { curmodule; curmonad; modules; scope_mods; exported_ids; - trans_exported_ids; includes; sigaccum; sigmap; iface; - admitted_iface; expect_typ; remaining_iface_decls; syntax_only; - ds_hooks; dep_graph;_} -> expect_typ -let (__proj__Mkenv__item__remaining_iface_decls : - env -> (FStar_Ident.lident * FStar_Parser_AST.decl Prims.list) Prims.list) - = - fun projectee -> - match projectee with - | { curmodule; curmonad; modules; scope_mods; exported_ids; - trans_exported_ids; includes; sigaccum; sigmap; iface; - admitted_iface; expect_typ; remaining_iface_decls; syntax_only; - ds_hooks; dep_graph;_} -> remaining_iface_decls -let (__proj__Mkenv__item__syntax_only : env -> Prims.bool) = - fun projectee -> - match projectee with - | { curmodule; curmonad; modules; scope_mods; exported_ids; - trans_exported_ids; includes; sigaccum; sigmap; iface; - admitted_iface; expect_typ; remaining_iface_decls; syntax_only; - ds_hooks; dep_graph;_} -> syntax_only -let (__proj__Mkenv__item__ds_hooks : env -> dsenv_hooks) = - fun projectee -> - match projectee with - | { curmodule; curmonad; modules; scope_mods; exported_ids; - trans_exported_ids; includes; sigaccum; sigmap; iface; - admitted_iface; expect_typ; remaining_iface_decls; syntax_only; - ds_hooks; dep_graph;_} -> ds_hooks -let (__proj__Mkenv__item__dep_graph : env -> FStar_Parser_Dep.deps) = - fun projectee -> - match projectee with - | { curmodule; curmonad; modules; scope_mods; exported_ids; - trans_exported_ids; includes; sigaccum; sigmap; iface; - admitted_iface; expect_typ; remaining_iface_decls; syntax_only; - ds_hooks; dep_graph;_} -> dep_graph -let (__proj__Mkdsenv_hooks__item__ds_push_open_hook : - dsenv_hooks -> env -> FStar_Syntax_Syntax.open_module_or_namespace -> unit) - = - fun projectee -> - match projectee with - | { ds_push_open_hook; ds_push_include_hook; - ds_push_module_abbrev_hook;_} -> ds_push_open_hook -let (__proj__Mkdsenv_hooks__item__ds_push_include_hook : - dsenv_hooks -> env -> FStar_Ident.lident -> unit) = - fun projectee -> - match projectee with - | { ds_push_open_hook; ds_push_include_hook; - ds_push_module_abbrev_hook;_} -> ds_push_include_hook -let (__proj__Mkdsenv_hooks__item__ds_push_module_abbrev_hook : - dsenv_hooks -> env -> FStar_Ident.ident -> FStar_Ident.lident -> unit) = - fun projectee -> - match projectee with - | { ds_push_open_hook; ds_push_include_hook; - ds_push_module_abbrev_hook;_} -> ds_push_module_abbrev_hook -let (mk_dsenv_hooks : - (env -> FStar_Syntax_Syntax.open_module_or_namespace -> unit) -> - (env -> FStar_Ident.lident -> unit) -> - (env -> FStar_Ident.ident -> FStar_Ident.lident -> unit) -> dsenv_hooks) - = - fun open_hook -> - fun include_hook -> - fun module_abbrev_hook -> - { - ds_push_open_hook = open_hook; - ds_push_include_hook = include_hook; - ds_push_module_abbrev_hook = module_abbrev_hook - } -type 'a withenv = env -> ('a * env) -type foundname = - | Term_name of (FStar_Syntax_Syntax.typ * FStar_Syntax_Syntax.attribute - Prims.list) - | Eff_name of (FStar_Syntax_Syntax.sigelt * FStar_Ident.lident) -let (uu___is_Term_name : foundname -> Prims.bool) = - fun projectee -> - match projectee with | Term_name _0 -> true | uu___ -> false -let (__proj__Term_name__item___0 : - foundname -> - (FStar_Syntax_Syntax.typ * FStar_Syntax_Syntax.attribute Prims.list)) - = fun projectee -> match projectee with | Term_name _0 -> _0 -let (uu___is_Eff_name : foundname -> Prims.bool) = - fun projectee -> - match projectee with | Eff_name _0 -> true | uu___ -> false -let (__proj__Eff_name__item___0 : - foundname -> (FStar_Syntax_Syntax.sigelt * FStar_Ident.lident)) = - fun projectee -> match projectee with | Eff_name _0 -> _0 -let (default_ds_hooks : dsenv_hooks) = - { - ds_push_open_hook = (fun uu___ -> fun uu___1 -> ()); - ds_push_include_hook = (fun uu___ -> fun uu___1 -> ()); - ds_push_module_abbrev_hook = - (fun uu___ -> fun uu___1 -> fun uu___2 -> ()) - } -let (set_iface : env -> Prims.bool -> env) = - fun env1 -> - fun b -> - { - curmodule = (env1.curmodule); - curmonad = (env1.curmonad); - modules = (env1.modules); - scope_mods = (env1.scope_mods); - exported_ids = (env1.exported_ids); - trans_exported_ids = (env1.trans_exported_ids); - includes = (env1.includes); - sigaccum = (env1.sigaccum); - sigmap = (env1.sigmap); - iface = b; - admitted_iface = (env1.admitted_iface); - expect_typ = (env1.expect_typ); - remaining_iface_decls = (env1.remaining_iface_decls); - syntax_only = (env1.syntax_only); - ds_hooks = (env1.ds_hooks); - dep_graph = (env1.dep_graph) - } -let (iface : env -> Prims.bool) = fun e -> e.iface -let (set_admitted_iface : env -> Prims.bool -> env) = - fun e -> - fun b -> - { - curmodule = (e.curmodule); - curmonad = (e.curmonad); - modules = (e.modules); - scope_mods = (e.scope_mods); - exported_ids = (e.exported_ids); - trans_exported_ids = (e.trans_exported_ids); - includes = (e.includes); - sigaccum = (e.sigaccum); - sigmap = (e.sigmap); - iface = (e.iface); - admitted_iface = b; - expect_typ = (e.expect_typ); - remaining_iface_decls = (e.remaining_iface_decls); - syntax_only = (e.syntax_only); - ds_hooks = (e.ds_hooks); - dep_graph = (e.dep_graph) - } -let (admitted_iface : env -> Prims.bool) = fun e -> e.admitted_iface -let (set_expect_typ : env -> Prims.bool -> env) = - fun e -> - fun b -> - { - curmodule = (e.curmodule); - curmonad = (e.curmonad); - modules = (e.modules); - scope_mods = (e.scope_mods); - exported_ids = (e.exported_ids); - trans_exported_ids = (e.trans_exported_ids); - includes = (e.includes); - sigaccum = (e.sigaccum); - sigmap = (e.sigmap); - iface = (e.iface); - admitted_iface = (e.admitted_iface); - expect_typ = b; - remaining_iface_decls = (e.remaining_iface_decls); - syntax_only = (e.syntax_only); - ds_hooks = (e.ds_hooks); - dep_graph = (e.dep_graph) - } -let (expect_typ : env -> Prims.bool) = fun e -> e.expect_typ -let (all_exported_id_kinds : exported_id_kind Prims.list) = - [Exported_id_field; Exported_id_term_type] -let (transitive_exported_ids : - env -> FStar_Ident.lident -> Prims.string Prims.list) = - fun env1 -> - fun lid -> - let module_name = FStar_Ident.string_of_lid lid in - let uu___ = - FStar_Compiler_Util.smap_try_find env1.trans_exported_ids module_name in - match uu___ with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some exported_id_set1 -> - let uu___1 = - let uu___2 = exported_id_set1 Exported_id_term_type in - FStar_Compiler_Effect.op_Bang uu___2 in - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset FStar_Class_Ord.ord_string)) - (Obj.magic uu___1) -let (opens_and_abbrevs : - env -> - (FStar_Syntax_Syntax.open_module_or_namespace, - FStar_Syntax_Syntax.module_abbrev) FStar_Pervasives.either Prims.list) - = - fun env1 -> - FStar_Compiler_List.collect - (fun uu___ -> - match uu___ with - | Open_module_or_namespace payload -> [FStar_Pervasives.Inl payload] - | Module_abbrev (id, lid) -> [FStar_Pervasives.Inr (id, lid)] - | uu___1 -> []) env1.scope_mods -let (open_modules : - env -> (FStar_Ident.lident * FStar_Syntax_Syntax.modul) Prims.list) = - fun e -> e.modules -let (open_modules_and_namespaces : env -> FStar_Ident.lident Prims.list) = - fun env1 -> - FStar_Compiler_List.filter_map - (fun uu___ -> - match uu___ with - | Open_module_or_namespace (lid, _info, _restriction) -> - FStar_Pervasives_Native.Some lid - | uu___1 -> FStar_Pervasives_Native.None) env1.scope_mods -let (module_abbrevs : - env -> (FStar_Ident.ident * FStar_Ident.lident) Prims.list) = - fun env1 -> - FStar_Compiler_List.filter_map - (fun uu___ -> - match uu___ with - | Module_abbrev (l, m) -> FStar_Pervasives_Native.Some (l, m) - | uu___1 -> FStar_Pervasives_Native.None) env1.scope_mods -let (set_current_module : env -> FStar_Ident.lident -> env) = - fun e -> - fun l -> - { - curmodule = (FStar_Pervasives_Native.Some l); - curmonad = (e.curmonad); - modules = (e.modules); - scope_mods = (e.scope_mods); - exported_ids = (e.exported_ids); - trans_exported_ids = (e.trans_exported_ids); - includes = (e.includes); - sigaccum = (e.sigaccum); - sigmap = (e.sigmap); - iface = (e.iface); - admitted_iface = (e.admitted_iface); - expect_typ = (e.expect_typ); - remaining_iface_decls = (e.remaining_iface_decls); - syntax_only = (e.syntax_only); - ds_hooks = (e.ds_hooks); - dep_graph = (e.dep_graph) - } -let (current_module : env -> FStar_Ident.lident) = - fun env1 -> - match env1.curmodule with - | FStar_Pervasives_Native.None -> failwith "Unset current module" - | FStar_Pervasives_Native.Some m -> m -let (iface_decls : - env -> - FStar_Ident.lident -> - FStar_Parser_AST.decl Prims.list FStar_Pervasives_Native.option) - = - fun env1 -> - fun l -> - let uu___ = - FStar_Compiler_List.tryFind - (fun uu___1 -> - match uu___1 with | (m, uu___2) -> FStar_Ident.lid_equals l m) - env1.remaining_iface_decls in - match uu___ with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (uu___1, decls) -> - FStar_Pervasives_Native.Some decls -let (set_iface_decls : - env -> FStar_Ident.lident -> FStar_Parser_AST.decl Prims.list -> env) = - fun env1 -> - fun l -> - fun ds -> - let uu___ = - FStar_Compiler_List.partition - (fun uu___1 -> - match uu___1 with | (m, uu___2) -> FStar_Ident.lid_equals l m) - env1.remaining_iface_decls in - match uu___ with - | (uu___1, rest) -> - { - curmodule = (env1.curmodule); - curmonad = (env1.curmonad); - modules = (env1.modules); - scope_mods = (env1.scope_mods); - exported_ids = (env1.exported_ids); - trans_exported_ids = (env1.trans_exported_ids); - includes = (env1.includes); - sigaccum = (env1.sigaccum); - sigmap = (env1.sigmap); - iface = (env1.iface); - admitted_iface = (env1.admitted_iface); - expect_typ = (env1.expect_typ); - remaining_iface_decls = ((l, ds) :: rest); - syntax_only = (env1.syntax_only); - ds_hooks = (env1.ds_hooks); - dep_graph = (env1.dep_graph) - } -let (qual : FStar_Ident.lident -> FStar_Ident.ident -> FStar_Ident.lident) = - FStar_Ident.qual_id -let (qualify : env -> FStar_Ident.ident -> FStar_Ident.lident) = - fun env1 -> - fun id -> - match env1.curmonad with - | FStar_Pervasives_Native.None -> - let uu___ = current_module env1 in qual uu___ id - | FStar_Pervasives_Native.Some monad -> - let uu___ = let uu___1 = current_module env1 in qual uu___1 monad in - FStar_Syntax_Util.mk_field_projector_name_from_ident uu___ id -let (syntax_only : env -> Prims.bool) = fun env1 -> env1.syntax_only -let (set_syntax_only : env -> Prims.bool -> env) = - fun env1 -> - fun b -> - { - curmodule = (env1.curmodule); - curmonad = (env1.curmonad); - modules = (env1.modules); - scope_mods = (env1.scope_mods); - exported_ids = (env1.exported_ids); - trans_exported_ids = (env1.trans_exported_ids); - includes = (env1.includes); - sigaccum = (env1.sigaccum); - sigmap = (env1.sigmap); - iface = (env1.iface); - admitted_iface = (env1.admitted_iface); - expect_typ = (env1.expect_typ); - remaining_iface_decls = (env1.remaining_iface_decls); - syntax_only = b; - ds_hooks = (env1.ds_hooks); - dep_graph = (env1.dep_graph) - } -let (ds_hooks : env -> dsenv_hooks) = fun env1 -> env1.ds_hooks -let (set_ds_hooks : env -> dsenv_hooks -> env) = - fun env1 -> - fun hooks -> - { - curmodule = (env1.curmodule); - curmonad = (env1.curmonad); - modules = (env1.modules); - scope_mods = (env1.scope_mods); - exported_ids = (env1.exported_ids); - trans_exported_ids = (env1.trans_exported_ids); - includes = (env1.includes); - sigaccum = (env1.sigaccum); - sigmap = (env1.sigmap); - iface = (env1.iface); - admitted_iface = (env1.admitted_iface); - expect_typ = (env1.expect_typ); - remaining_iface_decls = (env1.remaining_iface_decls); - syntax_only = (env1.syntax_only); - ds_hooks = hooks; - dep_graph = (env1.dep_graph) - } -let new_sigmap : 'uuuuu . unit -> 'uuuuu FStar_Compiler_Util.smap = - fun uu___ -> FStar_Compiler_Util.smap_create (Prims.of_int (100)) -let (empty_env : FStar_Parser_Dep.deps -> env) = - fun deps -> - let uu___ = new_sigmap () in - let uu___1 = new_sigmap () in - let uu___2 = new_sigmap () in - let uu___3 = new_sigmap () in - { - curmodule = FStar_Pervasives_Native.None; - curmonad = FStar_Pervasives_Native.None; - modules = []; - scope_mods = []; - exported_ids = uu___; - trans_exported_ids = uu___1; - includes = uu___2; - sigaccum = []; - sigmap = uu___3; - iface = false; - admitted_iface = false; - expect_typ = false; - remaining_iface_decls = []; - syntax_only = false; - ds_hooks = default_ds_hooks; - dep_graph = deps - } -let (dep_graph : env -> FStar_Parser_Dep.deps) = fun env1 -> env1.dep_graph -let (set_dep_graph : env -> FStar_Parser_Dep.deps -> env) = - fun env1 -> - fun ds -> - { - curmodule = (env1.curmodule); - curmonad = (env1.curmonad); - modules = (env1.modules); - scope_mods = (env1.scope_mods); - exported_ids = (env1.exported_ids); - trans_exported_ids = (env1.trans_exported_ids); - includes = (env1.includes); - sigaccum = (env1.sigaccum); - sigmap = (env1.sigmap); - iface = (env1.iface); - admitted_iface = (env1.admitted_iface); - expect_typ = (env1.expect_typ); - remaining_iface_decls = (env1.remaining_iface_decls); - syntax_only = (env1.syntax_only); - ds_hooks = (env1.ds_hooks); - dep_graph = ds - } -let (sigmap : - env -> (FStar_Syntax_Syntax.sigelt * Prims.bool) FStar_Compiler_Util.smap) - = fun env1 -> env1.sigmap -let (set_bv_range : - FStar_Syntax_Syntax.bv -> - FStar_Compiler_Range_Type.range -> FStar_Syntax_Syntax.bv) - = - fun bv -> - fun r -> - let id = FStar_Ident.set_id_range r bv.FStar_Syntax_Syntax.ppname in - { - FStar_Syntax_Syntax.ppname = id; - FStar_Syntax_Syntax.index = (bv.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = (bv.FStar_Syntax_Syntax.sort) - } -let (bv_to_name : - FStar_Syntax_Syntax.bv -> - FStar_Compiler_Range_Type.range -> FStar_Syntax_Syntax.term) - = - fun bv -> - fun r -> - let uu___ = set_bv_range bv r in FStar_Syntax_Syntax.bv_to_name uu___ -let (unmangleMap : - (Prims.string * Prims.string * FStar_Syntax_Syntax.fv_qual - FStar_Pervasives_Native.option) Prims.list) - = - [("op_ColonColon", "Cons", - (FStar_Pervasives_Native.Some FStar_Syntax_Syntax.Data_ctor)); - ("not", "op_Negation", FStar_Pervasives_Native.None)] -let (unmangleOpName : - FStar_Ident.ident -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = - fun id -> - FStar_Compiler_Util.find_map unmangleMap - (fun uu___ -> - match uu___ with - | (x, y, dq) -> - let uu___1 = - let uu___2 = FStar_Ident.string_of_id id in uu___2 = x in - if uu___1 - then - let uu___2 = - let uu___3 = - let uu___4 = FStar_Ident.range_of_id id in - FStar_Ident.lid_of_path ["Prims"; y] uu___4 in - FStar_Syntax_Syntax.fvar_with_dd uu___3 dq in - FStar_Pervasives_Native.Some uu___2 - else FStar_Pervasives_Native.None) -type 'a cont_t = - | Cont_ok of 'a - | Cont_fail - | Cont_ignore -let uu___is_Cont_ok : 'a . 'a cont_t -> Prims.bool = - fun projectee -> match projectee with | Cont_ok _0 -> true | uu___ -> false -let __proj__Cont_ok__item___0 : 'a . 'a cont_t -> 'a = - fun projectee -> match projectee with | Cont_ok _0 -> _0 -let uu___is_Cont_fail : 'a . 'a cont_t -> Prims.bool = - fun projectee -> match projectee with | Cont_fail -> true | uu___ -> false -let uu___is_Cont_ignore : 'a . 'a cont_t -> Prims.bool = - fun projectee -> - match projectee with | Cont_ignore -> true | uu___ -> false -let option_of_cont : - 'a . - (unit -> 'a FStar_Pervasives_Native.option) -> - 'a cont_t -> 'a FStar_Pervasives_Native.option - = - fun k_ignore -> - fun uu___ -> - match uu___ with - | Cont_ok a1 -> FStar_Pervasives_Native.Some a1 - | Cont_fail -> FStar_Pervasives_Native.None - | Cont_ignore -> k_ignore () -let find_in_record : - 'uuuuu . - FStar_Ident.ident Prims.list -> - FStar_Ident.ident -> - record_or_dc -> (record_or_dc -> 'uuuuu cont_t) -> 'uuuuu cont_t - = - fun ns -> - fun id -> - fun record -> - fun cont -> - let typename' = - let uu___ = - let uu___1 = - let uu___2 = FStar_Ident.ident_of_lid record.typename in - [uu___2] in - FStar_Compiler_List.op_At ns uu___1 in - FStar_Ident.lid_of_ids uu___ in - let uu___ = FStar_Ident.lid_equals typename' record.typename in - if uu___ - then - let fname = - let uu___1 = - let uu___2 = FStar_Ident.ns_of_lid record.typename in - FStar_Compiler_List.op_At uu___2 [id] in - FStar_Ident.lid_of_ids uu___1 in - let find = - FStar_Compiler_Util.find_map record.fields - (fun uu___1 -> - match uu___1 with - | (f, uu___2) -> - let uu___3 = - let uu___4 = FStar_Ident.string_of_id id in - let uu___5 = FStar_Ident.string_of_id f in - uu___4 = uu___5 in - if uu___3 - then FStar_Pervasives_Native.Some record - else FStar_Pervasives_Native.None) in - match find with - | FStar_Pervasives_Native.Some r -> cont r - | FStar_Pervasives_Native.None -> Cont_ignore - else Cont_ignore -let (get_exported_id_set : - env -> - Prims.string -> - (exported_id_kind -> string_set FStar_Compiler_Effect.ref) - FStar_Pervasives_Native.option) - = - fun e -> - fun mname -> FStar_Compiler_Util.smap_try_find e.exported_ids mname -let (get_trans_exported_id_set : - env -> - Prims.string -> - (exported_id_kind -> string_set FStar_Compiler_Effect.ref) - FStar_Pervasives_Native.option) - = - fun e -> - fun mname -> FStar_Compiler_Util.smap_try_find e.trans_exported_ids mname -let (string_of_exported_id_kind : exported_id_kind -> Prims.string) = - fun uu___ -> - match uu___ with - | Exported_id_field -> "field" - | Exported_id_term_type -> "term/type" -let (is_exported_id_termtype : exported_id_kind -> Prims.bool) = - fun uu___ -> - match uu___ with | Exported_id_term_type -> true | uu___1 -> false -let (is_exported_id_field : exported_id_kind -> Prims.bool) = - fun uu___ -> match uu___ with | Exported_id_field -> true | uu___1 -> false -let find_in_module_with_includes : - 'a . - exported_id_kind -> - (FStar_Ident.lident -> 'a cont_t) -> - 'a cont_t -> - env -> FStar_Ident.lident -> FStar_Ident.ident -> 'a cont_t - = - fun eikind -> - fun find_in_module -> - fun find_in_module_default -> - fun env1 -> - fun ns -> - fun id -> - let rec aux uu___ = - match uu___ with - | [] -> find_in_module_default - | (modul, id1)::q -> - let mname = FStar_Ident.string_of_lid modul in - let not_shadowed = - let uu___1 = get_exported_id_set env1 mname in - match uu___1 with - | FStar_Pervasives_Native.None -> true - | FStar_Pervasives_Native.Some mex -> - let mexports = - let uu___2 = mex eikind in - FStar_Compiler_Effect.op_Bang uu___2 in - let uu___2 = FStar_Ident.string_of_id id1 in - FStar_Class_Setlike.mem () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) uu___2 - (Obj.magic mexports) in - let mincludes = - let uu___1 = - FStar_Compiler_Util.smap_try_find env1.includes mname in - match uu___1 with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some minc -> - let uu___2 = FStar_Compiler_Effect.op_Bang minc in - FStar_Compiler_List.filter_map - (fun uu___3 -> - match uu___3 with - | (ns1, restriction) -> - let opt = - FStar_Syntax_Syntax.is_ident_allowed_by_restriction - id1 restriction in - FStar_Compiler_Util.map_opt opt - (fun id2 -> (ns1, id2))) uu___2 in - let look_into = - if not_shadowed - then - let uu___1 = qual modul id1 in find_in_module uu___1 - else Cont_ignore in - (match look_into with - | Cont_ignore -> - aux (FStar_Compiler_List.op_At mincludes q) - | uu___1 -> look_into) in - aux [(ns, id)] -let try_lookup_id'' : - 'a . - env -> - FStar_Ident.ident -> - exported_id_kind -> - (local_binding -> 'a cont_t) -> - (rec_binding -> 'a cont_t) -> - (record_or_dc -> 'a cont_t) -> - (FStar_Ident.lident -> 'a cont_t) -> - ('a cont_t -> FStar_Ident.ident -> 'a cont_t) -> - 'a FStar_Pervasives_Native.option - = - fun env1 -> - fun id -> - fun eikind -> - fun k_local_binding -> - fun k_rec_binding -> - fun k_record -> - fun find_in_module -> - fun lookup_default_id -> - let check_local_binding_id uu___ = - match uu___ with - | (id', uu___1, uu___2) -> - let uu___3 = FStar_Ident.string_of_id id' in - let uu___4 = FStar_Ident.string_of_id id in - uu___3 = uu___4 in - let check_rec_binding_id uu___ = - match uu___ with - | (id', uu___1, uu___2) -> - let uu___3 = FStar_Ident.string_of_id id' in - let uu___4 = FStar_Ident.string_of_id id in - uu___3 = uu___4 in - let curmod_ns = - let uu___ = current_module env1 in - FStar_Ident.ids_of_lid uu___ in - let proc uu___ = - match uu___ with - | Local_binding l when check_local_binding_id l -> - let uu___1 = l in - (match uu___1 with - | (uu___2, uu___3, used_marker1) -> - (FStar_Compiler_Effect.op_Colon_Equals - used_marker1 true; - k_local_binding l)) - | Rec_binding r when check_rec_binding_id r -> - let uu___1 = r in - (match uu___1 with - | (uu___2, uu___3, used_marker1) -> - (FStar_Compiler_Effect.op_Colon_Equals - used_marker1 true; - k_rec_binding r)) - | Open_module_or_namespace - (ns, FStar_Syntax_Syntax.Open_module, restriction) -> - let uu___1 = - FStar_Syntax_Syntax.is_ident_allowed_by_restriction - id restriction in - (match uu___1 with - | FStar_Pervasives_Native.None -> Cont_ignore - | FStar_Pervasives_Native.Some id1 -> - find_in_module_with_includes eikind - find_in_module Cont_ignore env1 ns id1) - | Top_level_def id' when - let uu___1 = FStar_Ident.string_of_id id' in - let uu___2 = FStar_Ident.string_of_id id in - uu___1 = uu___2 -> lookup_default_id Cont_ignore id - | Record_or_dc r when is_exported_id_field eikind -> - let uu___1 = FStar_Ident.lid_of_ids curmod_ns in - find_in_module_with_includes Exported_id_field - (fun lid -> - let id1 = FStar_Ident.ident_of_lid lid in - let uu___2 = FStar_Ident.ns_of_lid lid in - find_in_record uu___2 id1 r k_record) - Cont_ignore env1 uu___1 id - | Record_or_dc r when is_exported_id_termtype eikind -> - let uu___1 = - let uu___2 = FStar_Ident.ident_of_lid r.typename in - FStar_Ident.ident_equals uu___2 id in - if uu___1 then k_record r else Cont_ignore - | uu___1 -> Cont_ignore in - let rec aux uu___ = - match uu___ with - | a1::q -> - let uu___1 = proc a1 in - option_of_cont (fun uu___2 -> aux q) uu___1 - | [] -> - let uu___1 = lookup_default_id Cont_fail id in - option_of_cont - (fun uu___2 -> FStar_Pervasives_Native.None) uu___1 in - aux env1.scope_mods -let found_local_binding : - 'uuuuu 'uuuuu1 . - FStar_Compiler_Range_Type.range -> - ('uuuuu * FStar_Syntax_Syntax.bv * 'uuuuu1) -> FStar_Syntax_Syntax.term - = - fun r -> fun uu___ -> match uu___ with | (id', x, uu___1) -> bv_to_name x r -let find_in_module : - 'uuuuu . - env -> - FStar_Ident.lident -> - (FStar_Ident.lident -> - (FStar_Syntax_Syntax.sigelt * Prims.bool) -> 'uuuuu) - -> 'uuuuu -> 'uuuuu - = - fun env1 -> - fun lid -> - fun k_global_def -> - fun k_not_found -> - let uu___ = - let uu___1 = FStar_Ident.string_of_lid lid in - FStar_Compiler_Util.smap_try_find (sigmap env1) uu___1 in - match uu___ with - | FStar_Pervasives_Native.Some sb -> k_global_def lid sb - | FStar_Pervasives_Native.None -> k_not_found -let (try_lookup_id : - env -> - FStar_Ident.ident -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = - fun env1 -> - fun id -> - let uu___ = unmangleOpName id in - match uu___ with - | FStar_Pervasives_Native.Some f -> FStar_Pervasives_Native.Some f - | uu___1 -> - try_lookup_id'' env1 id Exported_id_term_type - (fun r -> - let uu___2 = - let uu___3 = FStar_Ident.range_of_id id in - found_local_binding uu___3 r in - Cont_ok uu___2) (fun uu___2 -> Cont_fail) - (fun uu___2 -> Cont_ignore) - (fun i -> - find_in_module env1 i (fun uu___2 -> fun uu___3 -> Cont_fail) - Cont_ignore) (fun uu___2 -> fun uu___3 -> Cont_fail) -let lookup_default_id : - 'a . - env -> - FStar_Ident.ident -> - (FStar_Ident.lident -> - (FStar_Syntax_Syntax.sigelt * Prims.bool) -> 'a cont_t) - -> 'a cont_t -> 'a cont_t - = - fun env1 -> - fun id -> - fun k_global_def -> - fun k_not_found -> - let find_in_monad = - match env1.curmonad with - | FStar_Pervasives_Native.Some uu___ -> - let lid = qualify env1 id in - let uu___1 = - let uu___2 = FStar_Ident.string_of_lid lid in - FStar_Compiler_Util.smap_try_find (sigmap env1) uu___2 in - (match uu___1 with - | FStar_Pervasives_Native.Some r -> - let uu___2 = k_global_def lid r in - FStar_Pervasives_Native.Some uu___2 - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None) - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None in - match find_in_monad with - | FStar_Pervasives_Native.Some v -> v - | FStar_Pervasives_Native.None -> - let lid = let uu___ = current_module env1 in qual uu___ id in - find_in_module env1 lid k_global_def k_not_found -let (lid_is_curmod : env -> FStar_Ident.lident -> Prims.bool) = - fun env1 -> - fun lid -> - match env1.curmodule with - | FStar_Pervasives_Native.None -> false - | FStar_Pervasives_Native.Some m -> FStar_Ident.lid_equals lid m -let (module_is_defined : env -> FStar_Ident.lident -> Prims.bool) = - fun env1 -> - fun lid -> - (lid_is_curmod env1 lid) || - (FStar_Compiler_List.existsb - (fun x -> - FStar_Ident.lid_equals lid (FStar_Pervasives_Native.fst x)) - env1.modules) -let (resolve_module_name : - env -> - FStar_Ident.lident -> - Prims.bool -> FStar_Ident.lident FStar_Pervasives_Native.option) - = - fun env1 -> - fun lid -> - fun honor_ns -> - let nslen = - let uu___ = FStar_Ident.ns_of_lid lid in - FStar_Compiler_List.length uu___ in - let rec aux uu___ = - match uu___ with - | [] -> - let uu___1 = module_is_defined env1 lid in - if uu___1 - then FStar_Pervasives_Native.Some lid - else FStar_Pervasives_Native.None - | (Open_module_or_namespace - (ns, FStar_Syntax_Syntax.Open_namespace, restriction))::q when - honor_ns -> - let new_lid = - let uu___1 = - let uu___2 = FStar_Ident.path_of_lid ns in - let uu___3 = FStar_Ident.path_of_lid lid in - FStar_Compiler_List.op_At uu___2 uu___3 in - let uu___2 = FStar_Ident.range_of_lid lid in - FStar_Ident.lid_of_path uu___1 uu___2 in - let uu___1 = module_is_defined env1 new_lid in - if uu___1 then FStar_Pervasives_Native.Some new_lid else aux q - | (Module_abbrev (name, modul))::uu___1 when - (nslen = Prims.int_zero) && - (let uu___2 = FStar_Ident.string_of_id name in - let uu___3 = - let uu___4 = FStar_Ident.ident_of_lid lid in - FStar_Ident.string_of_id uu___4 in - uu___2 = uu___3) - -> FStar_Pervasives_Native.Some modul - | uu___1::q -> aux q in - aux env1.scope_mods -let (is_open : - env -> FStar_Ident.lident -> FStar_Syntax_Syntax.open_kind -> Prims.bool) = - fun env1 -> - fun lid -> - fun open_kind -> - FStar_Compiler_List.existsb - (fun uu___ -> - match uu___ with - | Open_module_or_namespace - (ns, k, FStar_Syntax_Syntax.Unrestricted) -> - (k = open_kind) && (FStar_Ident.lid_equals lid ns) - | uu___1 -> false) env1.scope_mods -let (namespace_is_open : env -> FStar_Ident.lident -> Prims.bool) = - fun env1 -> fun lid -> is_open env1 lid FStar_Syntax_Syntax.Open_namespace -let (module_is_open : env -> FStar_Ident.lident -> Prims.bool) = - fun env1 -> - fun lid -> - (lid_is_curmod env1 lid) || - (is_open env1 lid FStar_Syntax_Syntax.Open_module) -let (shorten_module_path : - env -> - FStar_Ident.ident Prims.list -> - Prims.bool -> - (FStar_Ident.ident Prims.list * FStar_Ident.ident Prims.list)) - = - fun env1 -> - fun ids -> - fun is_full_path -> - let rec aux revns id = - let lid = - FStar_Ident.lid_of_ns_and_id (FStar_Compiler_List.rev revns) id in - let uu___ = namespace_is_open env1 lid in - if uu___ - then - FStar_Pervasives_Native.Some - ((FStar_Compiler_List.rev (id :: revns)), []) - else - (match revns with - | [] -> FStar_Pervasives_Native.None - | ns_last_id::rev_ns_prefix -> - let uu___2 = aux rev_ns_prefix ns_last_id in - FStar_Compiler_Util.map_option - (fun uu___3 -> - match uu___3 with - | (stripped_ids, rev_kept_ids) -> - (stripped_ids, (id :: rev_kept_ids))) uu___2) in - let do_shorten env2 ids1 = - match FStar_Compiler_List.rev ids1 with - | [] -> ([], []) - | ns_last_id::ns_rev_prefix -> - let uu___ = aux ns_rev_prefix ns_last_id in - (match uu___ with - | FStar_Pervasives_Native.None -> ([], ids1) - | FStar_Pervasives_Native.Some (stripped_ids, rev_kept_ids) -> - (stripped_ids, (FStar_Compiler_List.rev rev_kept_ids))) in - if - is_full_path && ((FStar_Compiler_List.length ids) > Prims.int_zero) - then - let uu___ = - let uu___1 = FStar_Ident.lid_of_ids ids in - resolve_module_name env1 uu___1 true in - match uu___ with - | FStar_Pervasives_Native.Some m when module_is_open env1 m -> - (ids, []) - | uu___1 -> do_shorten env1 ids - else do_shorten env1 ids -let resolve_in_open_namespaces'' : - 'a . - env -> - FStar_Ident.lident -> - exported_id_kind -> - (local_binding -> 'a cont_t) -> - (rec_binding -> 'a cont_t) -> - (record_or_dc -> 'a cont_t) -> - (FStar_Ident.lident -> 'a cont_t) -> - ('a cont_t -> FStar_Ident.ident -> 'a cont_t) -> - 'a FStar_Pervasives_Native.option - = - fun env1 -> - fun lid -> - fun eikind -> - fun k_local_binding -> - fun k_rec_binding -> - fun k_record -> - fun f_module -> - fun l_default -> - let uu___ = FStar_Ident.ns_of_lid lid in - match uu___ with - | uu___1::uu___2 -> - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = FStar_Ident.ns_of_lid lid in - FStar_Ident.lid_of_ids uu___6 in - let uu___6 = FStar_Ident.range_of_lid lid in - FStar_Ident.set_lid_range uu___5 uu___6 in - resolve_module_name env1 uu___4 true in - (match uu___3 with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some modul -> - let uu___4 = - let uu___5 = FStar_Ident.ident_of_lid lid in - find_in_module_with_includes eikind f_module - Cont_fail env1 modul uu___5 in - option_of_cont - (fun uu___5 -> FStar_Pervasives_Native.None) - uu___4) - | [] -> - let uu___1 = FStar_Ident.ident_of_lid lid in - try_lookup_id'' env1 uu___1 eikind k_local_binding - k_rec_binding k_record f_module l_default -let cont_of_option : - 'a . 'a cont_t -> 'a FStar_Pervasives_Native.option -> 'a cont_t = - fun k_none -> - fun uu___ -> - match uu___ with - | FStar_Pervasives_Native.Some v -> Cont_ok v - | FStar_Pervasives_Native.None -> k_none -let resolve_in_open_namespaces' : - 'a . - env -> - FStar_Ident.lident -> - (local_binding -> 'a FStar_Pervasives_Native.option) -> - (rec_binding -> 'a FStar_Pervasives_Native.option) -> - (FStar_Ident.lident -> - (FStar_Syntax_Syntax.sigelt * Prims.bool) -> - 'a FStar_Pervasives_Native.option) - -> 'a FStar_Pervasives_Native.option - = - fun env1 -> - fun lid -> - fun k_local_binding -> - fun k_rec_binding -> - fun k_global_def -> - let k_global_def' k lid1 def = - let uu___ = k_global_def lid1 def in cont_of_option k uu___ in - let f_module lid' = - let k = Cont_ignore in - find_in_module env1 lid' (k_global_def' k) k in - let l_default k i = lookup_default_id env1 i (k_global_def' k) k in - resolve_in_open_namespaces'' env1 lid Exported_id_term_type - (fun l -> - let uu___ = k_local_binding l in - cont_of_option Cont_fail uu___) - (fun r -> - let uu___ = k_rec_binding r in - cont_of_option Cont_fail uu___) (fun uu___ -> Cont_ignore) - f_module l_default -let (fv_qual_of_se : - FStar_Syntax_Syntax.sigelt -> - FStar_Syntax_Syntax.fv_qual FStar_Pervasives_Native.option) - = - fun se -> - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = uu___; FStar_Syntax_Syntax.us1 = uu___1; - FStar_Syntax_Syntax.t1 = uu___2; FStar_Syntax_Syntax.ty_lid = l; - FStar_Syntax_Syntax.num_ty_params = uu___3; - FStar_Syntax_Syntax.mutuals1 = uu___4; - FStar_Syntax_Syntax.injective_type_params1 = uu___5;_} - -> - let qopt = - FStar_Compiler_Util.find_map se.FStar_Syntax_Syntax.sigquals - (fun uu___6 -> - match uu___6 with - | FStar_Syntax_Syntax.RecordConstructor (uu___7, fs) -> - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Record_ctor (l, fs)) - | uu___7 -> FStar_Pervasives_Native.None) in - (match qopt with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.Some FStar_Syntax_Syntax.Data_ctor - | x -> x) - | FStar_Syntax_Syntax.Sig_declare_typ uu___ -> - FStar_Pervasives_Native.None - | uu___ -> FStar_Pervasives_Native.None -let (lb_fv : - FStar_Syntax_Syntax.letbinding Prims.list -> - FStar_Ident.lident -> FStar_Syntax_Syntax.fv) - = - fun lbs -> - fun lid -> - let uu___ = - FStar_Compiler_Util.find_map lbs - (fun lb -> - let fv = FStar_Compiler_Util.right lb.FStar_Syntax_Syntax.lbname in - let uu___1 = FStar_Syntax_Syntax.fv_eq_lid fv lid in - if uu___1 - then FStar_Pervasives_Native.Some fv - else FStar_Pervasives_Native.None) in - FStar_Compiler_Util.must uu___ -let (ns_of_lid_equals : - FStar_Ident.lident -> FStar_Ident.lident -> Prims.bool) = - fun lid -> - fun ns -> - (let uu___ = - let uu___1 = FStar_Ident.ns_of_lid lid in - FStar_Compiler_List.length uu___1 in - let uu___1 = - let uu___2 = FStar_Ident.ids_of_lid ns in - FStar_Compiler_List.length uu___2 in - uu___ = uu___1) && - (let uu___ = - let uu___1 = FStar_Ident.ns_of_lid lid in - FStar_Ident.lid_of_ids uu___1 in - FStar_Ident.lid_equals uu___ ns) -let (try_lookup_name : - Prims.bool -> - Prims.bool -> - env -> FStar_Ident.lident -> foundname FStar_Pervasives_Native.option) - = - fun any_val -> - fun exclude_interf -> - fun env1 -> - fun lid -> - let occurrence_range = FStar_Ident.range_of_lid lid in - let k_global_def source_lid uu___ = - match uu___ with - | (uu___1, true) when exclude_interf -> - FStar_Pervasives_Native.None - | (se, uu___1) -> - (match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ uu___2 -> - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Syntax_Syntax.fvar_with_dd source_lid - FStar_Pervasives_Native.None in - (uu___5, (se.FStar_Syntax_Syntax.sigattrs)) in - Term_name uu___4 in - FStar_Pervasives_Native.Some uu___3 - | FStar_Syntax_Syntax.Sig_datacon uu___2 -> - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = fv_qual_of_se se in - FStar_Syntax_Syntax.fvar_with_dd source_lid uu___6 in - (uu___5, (se.FStar_Syntax_Syntax.sigattrs)) in - Term_name uu___4 in - FStar_Pervasives_Native.Some uu___3 - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (uu___2, lbs); - FStar_Syntax_Syntax.lids1 = uu___3;_} - -> - let fv = lb_fv lbs source_lid in - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Syntax.fvar_with_dd source_lid - fv.FStar_Syntax_Syntax.fv_qual in - (uu___6, (se.FStar_Syntax_Syntax.sigattrs)) in - Term_name uu___5 in - FStar_Pervasives_Native.Some uu___4 - | FStar_Syntax_Syntax.Sig_declare_typ - { FStar_Syntax_Syntax.lid2 = lid1; - FStar_Syntax_Syntax.us2 = uu___2; - FStar_Syntax_Syntax.t2 = uu___3;_} - -> - let quals = se.FStar_Syntax_Syntax.sigquals in - let uu___4 = - any_val || - (FStar_Compiler_Util.for_some - (fun uu___5 -> - match uu___5 with - | FStar_Syntax_Syntax.Assumption -> true - | uu___6 -> false) quals) in - if uu___4 - then - let lid2 = - let uu___5 = FStar_Ident.range_of_lid source_lid in - FStar_Ident.set_lid_range lid1 uu___5 in - let uu___5 = - FStar_Compiler_Util.find_map quals - (fun uu___6 -> - match uu___6 with - | FStar_Syntax_Syntax.Reflectable refl_monad -> - FStar_Pervasives_Native.Some refl_monad - | uu___7 -> FStar_Pervasives_Native.None) in - (match uu___5 with - | FStar_Pervasives_Native.Some refl_monad -> - let refl_const = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_reflect refl_monad)) - occurrence_range in - FStar_Pervasives_Native.Some - (Term_name - (refl_const, - (se.FStar_Syntax_Syntax.sigattrs))) - | uu___6 -> - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = fv_qual_of_se se in - FStar_Syntax_Syntax.fvar_with_dd lid2 - uu___10 in - (uu___9, (se.FStar_Syntax_Syntax.sigattrs)) in - Term_name uu___8 in - FStar_Pervasives_Native.Some uu___7) - else FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Sig_new_effect ne -> - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Ident.range_of_lid source_lid in - FStar_Ident.set_lid_range - ne.FStar_Syntax_Syntax.mname uu___5 in - (se, uu___4) in - Eff_name uu___3 in - FStar_Pervasives_Native.Some uu___2 - | FStar_Syntax_Syntax.Sig_effect_abbrev uu___2 -> - FStar_Pervasives_Native.Some (Eff_name (se, source_lid)) - | FStar_Syntax_Syntax.Sig_splice - { FStar_Syntax_Syntax.is_typed = uu___2; - FStar_Syntax_Syntax.lids2 = lids; - FStar_Syntax_Syntax.tac = t;_} - -> - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Syntax_Syntax.fvar_with_dd source_lid - FStar_Pervasives_Native.None in - (uu___5, []) in - Term_name uu___4 in - FStar_Pervasives_Native.Some uu___3 - | uu___2 -> FStar_Pervasives_Native.None) in - let k_local_binding r = - let t = - let uu___ = FStar_Ident.range_of_lid lid in - found_local_binding uu___ r in - FStar_Pervasives_Native.Some (Term_name (t, [])) in - let k_rec_binding uu___ = - match uu___ with - | (id, l, used_marker1) -> - (FStar_Compiler_Effect.op_Colon_Equals used_marker1 true; - (let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = FStar_Ident.range_of_lid lid in - FStar_Ident.set_lid_range l uu___6 in - FStar_Syntax_Syntax.fvar_with_dd uu___5 - FStar_Pervasives_Native.None in - (uu___4, []) in - Term_name uu___3 in - FStar_Pervasives_Native.Some uu___2)) in - let found_unmangled = - let uu___ = FStar_Ident.ns_of_lid lid in - match uu___ with - | [] -> - let uu___1 = - let uu___2 = FStar_Ident.ident_of_lid lid in - unmangleOpName uu___2 in - (match uu___1 with - | FStar_Pervasives_Native.Some t -> - FStar_Pervasives_Native.Some (Term_name (t, [])) - | uu___2 -> FStar_Pervasives_Native.None) - | uu___1 -> FStar_Pervasives_Native.None in - match found_unmangled with - | FStar_Pervasives_Native.None -> - resolve_in_open_namespaces' env1 lid k_local_binding - k_rec_binding k_global_def - | x -> x -let (try_lookup_effect_name' : - Prims.bool -> - env -> - FStar_Ident.lident -> - (FStar_Syntax_Syntax.sigelt * FStar_Ident.lident) - FStar_Pervasives_Native.option) - = - fun exclude_interf -> - fun env1 -> - fun lid -> - let uu___ = try_lookup_name true exclude_interf env1 lid in - match uu___ with - | FStar_Pervasives_Native.Some (Eff_name (o, l)) -> - FStar_Pervasives_Native.Some (o, l) - | uu___1 -> FStar_Pervasives_Native.None -let (try_lookup_effect_name : - env -> - FStar_Ident.lident -> FStar_Ident.lident FStar_Pervasives_Native.option) - = - fun env1 -> - fun l -> - let uu___ = - try_lookup_effect_name' (Prims.op_Negation env1.iface) env1 l in - match uu___ with - | FStar_Pervasives_Native.Some (o, l1) -> - FStar_Pervasives_Native.Some l1 - | uu___1 -> FStar_Pervasives_Native.None -let (try_lookup_effect_name_and_attributes : - env -> - FStar_Ident.lident -> - (FStar_Ident.lident * FStar_Syntax_Syntax.cflag Prims.list) - FStar_Pervasives_Native.option) - = - fun env1 -> - fun l -> - let uu___ = - try_lookup_effect_name' (Prims.op_Negation env1.iface) env1 l in - match uu___ with - | FStar_Pervasives_Native.Some - ({ - FStar_Syntax_Syntax.sigel = FStar_Syntax_Syntax.Sig_new_effect - ne; - FStar_Syntax_Syntax.sigrng = uu___1; - FStar_Syntax_Syntax.sigquals = uu___2; - FStar_Syntax_Syntax.sigmeta = uu___3; - FStar_Syntax_Syntax.sigattrs = uu___4; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___5; - FStar_Syntax_Syntax.sigopts = uu___6;_}, - l1) - -> - FStar_Pervasives_Native.Some - (l1, (ne.FStar_Syntax_Syntax.cattributes)) - | FStar_Pervasives_Native.Some - ({ - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_effect_abbrev - { FStar_Syntax_Syntax.lid4 = uu___1; - FStar_Syntax_Syntax.us4 = uu___2; - FStar_Syntax_Syntax.bs2 = uu___3; - FStar_Syntax_Syntax.comp1 = uu___4; - FStar_Syntax_Syntax.cflags = cattributes;_}; - FStar_Syntax_Syntax.sigrng = uu___5; - FStar_Syntax_Syntax.sigquals = uu___6; - FStar_Syntax_Syntax.sigmeta = uu___7; - FStar_Syntax_Syntax.sigattrs = uu___8; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___9; - FStar_Syntax_Syntax.sigopts = uu___10;_}, - l1) - -> FStar_Pervasives_Native.Some (l1, cattributes) - | uu___1 -> FStar_Pervasives_Native.None -let (try_lookup_effect_defn : - env -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.eff_decl FStar_Pervasives_Native.option) - = - fun env1 -> - fun l -> - let uu___ = - try_lookup_effect_name' (Prims.op_Negation env1.iface) env1 l in - match uu___ with - | FStar_Pervasives_Native.Some - ({ - FStar_Syntax_Syntax.sigel = FStar_Syntax_Syntax.Sig_new_effect - ne; - FStar_Syntax_Syntax.sigrng = uu___1; - FStar_Syntax_Syntax.sigquals = uu___2; - FStar_Syntax_Syntax.sigmeta = uu___3; - FStar_Syntax_Syntax.sigattrs = uu___4; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___5; - FStar_Syntax_Syntax.sigopts = uu___6;_}, - uu___7) - -> FStar_Pervasives_Native.Some ne - | uu___1 -> FStar_Pervasives_Native.None -let (is_effect_name : env -> FStar_Ident.lident -> Prims.bool) = - fun env1 -> - fun lid -> - let uu___ = try_lookup_effect_name env1 lid in - match uu___ with - | FStar_Pervasives_Native.None -> false - | FStar_Pervasives_Native.Some uu___1 -> true -let (try_lookup_root_effect_name : - env -> - FStar_Ident.lident -> FStar_Ident.lident FStar_Pervasives_Native.option) - = - fun env1 -> - fun l -> - let uu___ = - try_lookup_effect_name' (Prims.op_Negation env1.iface) env1 l in - match uu___ with - | FStar_Pervasives_Native.Some - ({ - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_effect_abbrev - { FStar_Syntax_Syntax.lid4 = l'; - FStar_Syntax_Syntax.us4 = uu___1; - FStar_Syntax_Syntax.bs2 = uu___2; - FStar_Syntax_Syntax.comp1 = uu___3; - FStar_Syntax_Syntax.cflags = uu___4;_}; - FStar_Syntax_Syntax.sigrng = uu___5; - FStar_Syntax_Syntax.sigquals = uu___6; - FStar_Syntax_Syntax.sigmeta = uu___7; - FStar_Syntax_Syntax.sigattrs = uu___8; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___9; - FStar_Syntax_Syntax.sigopts = uu___10;_}, - uu___11) - -> - let rec aux new_name = - let uu___12 = - let uu___13 = FStar_Ident.string_of_lid new_name in - FStar_Compiler_Util.smap_try_find (sigmap env1) uu___13 in - match uu___12 with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (s, uu___13) -> - (match s.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_new_effect ne -> - let uu___14 = - let uu___15 = FStar_Ident.range_of_lid l in - FStar_Ident.set_lid_range ne.FStar_Syntax_Syntax.mname - uu___15 in - FStar_Pervasives_Native.Some uu___14 - | FStar_Syntax_Syntax.Sig_effect_abbrev - { FStar_Syntax_Syntax.lid4 = uu___14; - FStar_Syntax_Syntax.us4 = uu___15; - FStar_Syntax_Syntax.bs2 = uu___16; - FStar_Syntax_Syntax.comp1 = cmp; - FStar_Syntax_Syntax.cflags = uu___17;_} - -> - let l'' = FStar_Syntax_Util.comp_effect_name cmp in - aux l'' - | uu___14 -> FStar_Pervasives_Native.None) in - aux l' - | FStar_Pervasives_Native.Some (uu___1, l') -> - FStar_Pervasives_Native.Some l' - | uu___1 -> FStar_Pervasives_Native.None -let (lookup_letbinding_quals_and_attrs : - env -> - FStar_Ident.lident -> - (FStar_Syntax_Syntax.qualifier Prims.list * - FStar_Syntax_Syntax.attribute Prims.list)) - = - fun env1 -> - fun lid -> - let k_global_def lid1 uu___ = - match uu___ with - | ({ - FStar_Syntax_Syntax.sigel = FStar_Syntax_Syntax.Sig_declare_typ - uu___1; - FStar_Syntax_Syntax.sigrng = uu___2; - FStar_Syntax_Syntax.sigquals = quals; - FStar_Syntax_Syntax.sigmeta = uu___3; - FStar_Syntax_Syntax.sigattrs = attrs; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___4; - FStar_Syntax_Syntax.sigopts = uu___5;_}, - uu___6) -> FStar_Pervasives_Native.Some (quals, attrs) - | uu___1 -> FStar_Pervasives_Native.None in - let uu___ = - resolve_in_open_namespaces' env1 lid - (fun uu___1 -> FStar_Pervasives_Native.None) - (fun uu___1 -> FStar_Pervasives_Native.None) k_global_def in - match uu___ with - | FStar_Pervasives_Native.Some qa -> qa - | uu___1 -> ([], []) -let (try_lookup_module : - env -> - FStar_Ident.path -> - FStar_Syntax_Syntax.modul FStar_Pervasives_Native.option) - = - fun env1 -> - fun path -> - let uu___ = - FStar_Compiler_List.tryFind - (fun uu___1 -> - match uu___1 with - | (mlid, modul) -> - let uu___2 = FStar_Ident.path_of_lid mlid in uu___2 = path) - env1.modules in - match uu___ with - | FStar_Pervasives_Native.Some (uu___1, modul) -> - FStar_Pervasives_Native.Some modul - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None -let (try_lookup_let : - env -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = - fun env1 -> - fun lid -> - let k_global_def lid1 uu___ = - match uu___ with - | ({ - FStar_Syntax_Syntax.sigel = FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (uu___1, lbs); - FStar_Syntax_Syntax.lids1 = uu___2;_}; - FStar_Syntax_Syntax.sigrng = uu___3; - FStar_Syntax_Syntax.sigquals = uu___4; - FStar_Syntax_Syntax.sigmeta = uu___5; - FStar_Syntax_Syntax.sigattrs = uu___6; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___7; - FStar_Syntax_Syntax.sigopts = uu___8;_}, - uu___9) -> - let fv = lb_fv lbs lid1 in - let uu___10 = - FStar_Syntax_Syntax.fvar_with_dd lid1 - fv.FStar_Syntax_Syntax.fv_qual in - FStar_Pervasives_Native.Some uu___10 - | uu___1 -> FStar_Pervasives_Native.None in - resolve_in_open_namespaces' env1 lid - (fun uu___ -> FStar_Pervasives_Native.None) - (fun uu___ -> FStar_Pervasives_Native.None) k_global_def -let (try_lookup_definition : - env -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = - fun env1 -> - fun lid -> - let k_global_def lid1 uu___ = - match uu___ with - | ({ - FStar_Syntax_Syntax.sigel = FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = lbs; - FStar_Syntax_Syntax.lids1 = uu___1;_}; - FStar_Syntax_Syntax.sigrng = uu___2; - FStar_Syntax_Syntax.sigquals = uu___3; - FStar_Syntax_Syntax.sigmeta = uu___4; - FStar_Syntax_Syntax.sigattrs = uu___5; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___6; - FStar_Syntax_Syntax.sigopts = uu___7;_}, - uu___8) -> - FStar_Compiler_Util.find_map (FStar_Pervasives_Native.snd lbs) - (fun lb -> - match lb.FStar_Syntax_Syntax.lbname with - | FStar_Pervasives.Inr fv when - FStar_Syntax_Syntax.fv_eq_lid fv lid1 -> - FStar_Pervasives_Native.Some - (lb.FStar_Syntax_Syntax.lbdef) - | uu___9 -> FStar_Pervasives_Native.None) - | uu___1 -> FStar_Pervasives_Native.None in - resolve_in_open_namespaces' env1 lid - (fun uu___ -> FStar_Pervasives_Native.None) - (fun uu___ -> FStar_Pervasives_Native.None) k_global_def -let (empty_include_smap : - (FStar_Ident.lident * FStar_Syntax_Syntax.restriction) Prims.list - FStar_Compiler_Effect.ref FStar_Compiler_Util.smap) - = new_sigmap () -let (empty_exported_id_smap : exported_id_set FStar_Compiler_Util.smap) = - new_sigmap () -let (try_lookup_lid' : - Prims.bool -> - Prims.bool -> - env -> - FStar_Ident.lident -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.attribute - Prims.list) FStar_Pervasives_Native.option) - = - fun any_val -> - fun exclude_interface -> - fun env1 -> - fun lid -> - let uu___ = try_lookup_name any_val exclude_interface env1 lid in - match uu___ with - | FStar_Pervasives_Native.Some (Term_name (e, attrs)) -> - FStar_Pervasives_Native.Some (e, attrs) - | uu___1 -> FStar_Pervasives_Native.None -let (drop_attributes : - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.attribute Prims.list) - FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = - fun x -> - match x with - | FStar_Pervasives_Native.Some (t, uu___) -> - FStar_Pervasives_Native.Some t - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None -let (try_lookup_lid_with_attributes : - env -> - FStar_Ident.lident -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.attribute Prims.list) - FStar_Pervasives_Native.option) - = fun env1 -> fun l -> try_lookup_lid' env1.iface false env1 l -let (try_lookup_lid : - env -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = - fun env1 -> - fun l -> - let uu___ = try_lookup_lid_with_attributes env1 l in - drop_attributes uu___ -let (resolve_to_fully_qualified_name : - env -> - FStar_Ident.lident -> FStar_Ident.lident FStar_Pervasives_Native.option) - = - fun env1 -> - fun l -> - let r = - let uu___ = try_lookup_name true false env1 l in - match uu___ with - | FStar_Pervasives_Native.Some (Term_name (e, attrs)) -> - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress e in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - FStar_Pervasives_Native.Some - ((fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v) - | uu___2 -> FStar_Pervasives_Native.None) - | FStar_Pervasives_Native.Some (Eff_name (o, l1)) -> - FStar_Pervasives_Native.Some l1 - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None in - r -let (is_abbrev : - env -> - FStar_Ident.lident -> FStar_Ident.ipath FStar_Pervasives_Native.option) - = - fun env1 -> - fun lid -> - FStar_Compiler_List.tryPick - (fun uu___ -> - match uu___ with - | Module_abbrev (id, ns) when FStar_Ident.lid_equals lid ns -> - FStar_Pervasives_Native.Some [id] - | uu___1 -> FStar_Pervasives_Native.None) env1.scope_mods -let (try_shorten_abbrev : - env -> - FStar_Ident.ipath -> - (FStar_Ident.ipath * FStar_Ident.ident Prims.list) - FStar_Pervasives_Native.option) - = - fun env1 -> - fun ns -> - let rec aux ns1 rest = - match ns1 with - | [] -> FStar_Pervasives_Native.None - | hd::tl -> - let uu___ = - let uu___1 = - FStar_Ident.lid_of_ids (FStar_Compiler_List.rev ns1) in - is_abbrev env1 uu___1 in - (match uu___ with - | FStar_Pervasives_Native.Some short -> - FStar_Pervasives_Native.Some (short, rest) - | uu___1 -> aux tl (hd :: rest)) in - aux (FStar_Compiler_List.rev ns) [] -let (shorten_lid' : env -> FStar_Ident.lident -> FStar_Ident.lident) = - fun env1 -> - fun lid0 -> - let id0 = FStar_Ident.ident_of_lid lid0 in - let ns0 = FStar_Ident.ns_of_lid lid0 in - let uu___ = - let uu___1 = try_shorten_abbrev env1 ns0 in - match uu___1 with - | FStar_Pervasives_Native.None -> ([], ns0) - | FStar_Pervasives_Native.Some (ns, rest) -> (ns, rest) in - match uu___ with - | (pref, ns) -> - let rec tails l = - match l with - | [] -> [[]] - | uu___1::tl -> let uu___2 = tails tl in l :: uu___2 in - let suffs = let uu___1 = tails ns in FStar_Compiler_List.rev uu___1 in - let try1 lid' = - let uu___1 = resolve_to_fully_qualified_name env1 lid' in - match uu___1 with - | FStar_Pervasives_Native.Some lid2 when - FStar_Ident.lid_equals lid2 lid0 -> true - | uu___2 -> false in - let rec go nss = - match nss with - | ns1::rest -> - let lid' = - FStar_Ident.lid_of_ns_and_id - (FStar_Compiler_List.op_At pref ns1) id0 in - let uu___1 = try1 lid' in if uu___1 then lid' else go rest - | [] -> lid0 in - let r = go suffs in r -let (shorten_lid : env -> FStar_Ident.lid -> FStar_Ident.lid) = - fun env1 -> - fun lid0 -> - match env1.curmodule with - | FStar_Pervasives_Native.None -> lid0 - | uu___ -> shorten_lid' env1 lid0 -let (try_lookup_lid_with_attributes_no_resolve : - env -> - FStar_Ident.lident -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.attribute Prims.list) - FStar_Pervasives_Native.option) - = - fun env1 -> - fun l -> - let env' = - { - curmodule = (env1.curmodule); - curmonad = (env1.curmonad); - modules = (env1.modules); - scope_mods = []; - exported_ids = empty_exported_id_smap; - trans_exported_ids = (env1.trans_exported_ids); - includes = empty_include_smap; - sigaccum = (env1.sigaccum); - sigmap = (env1.sigmap); - iface = (env1.iface); - admitted_iface = (env1.admitted_iface); - expect_typ = (env1.expect_typ); - remaining_iface_decls = (env1.remaining_iface_decls); - syntax_only = (env1.syntax_only); - ds_hooks = (env1.ds_hooks); - dep_graph = (env1.dep_graph) - } in - try_lookup_lid_with_attributes env' l -let (try_lookup_lid_no_resolve : - env -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = - fun env1 -> - fun l -> - let uu___ = try_lookup_lid_with_attributes_no_resolve env1 l in - drop_attributes uu___ -let (try_lookup_datacon : - env -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.fv FStar_Pervasives_Native.option) - = - fun env1 -> - fun lid -> - let k_global_def lid1 se = - match se with - | ({ - FStar_Syntax_Syntax.sigel = FStar_Syntax_Syntax.Sig_declare_typ - uu___; - FStar_Syntax_Syntax.sigrng = uu___1; - FStar_Syntax_Syntax.sigquals = quals; - FStar_Syntax_Syntax.sigmeta = uu___2; - FStar_Syntax_Syntax.sigattrs = uu___3; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___4; - FStar_Syntax_Syntax.sigopts = uu___5;_}, - uu___6) -> - let uu___7 = - FStar_Compiler_Util.for_some - (fun uu___8 -> - match uu___8 with - | FStar_Syntax_Syntax.Assumption -> true - | uu___9 -> false) quals in - if uu___7 - then - let uu___8 = - FStar_Syntax_Syntax.lid_and_dd_as_fv lid1 - FStar_Pervasives_Native.None in - FStar_Pervasives_Native.Some uu___8 - else FStar_Pervasives_Native.None - | ({ - FStar_Syntax_Syntax.sigel = FStar_Syntax_Syntax.Sig_splice uu___; - FStar_Syntax_Syntax.sigrng = uu___1; - FStar_Syntax_Syntax.sigquals = uu___2; - FStar_Syntax_Syntax.sigmeta = uu___3; - FStar_Syntax_Syntax.sigattrs = uu___4; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___5; - FStar_Syntax_Syntax.sigopts = uu___6;_}, - uu___7) -> - let qual1 = fv_qual_of_se (FStar_Pervasives_Native.fst se) in - let uu___8 = FStar_Syntax_Syntax.lid_and_dd_as_fv lid1 qual1 in - FStar_Pervasives_Native.Some uu___8 - | ({ - FStar_Syntax_Syntax.sigel = FStar_Syntax_Syntax.Sig_datacon - uu___; - FStar_Syntax_Syntax.sigrng = uu___1; - FStar_Syntax_Syntax.sigquals = uu___2; - FStar_Syntax_Syntax.sigmeta = uu___3; - FStar_Syntax_Syntax.sigattrs = uu___4; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___5; - FStar_Syntax_Syntax.sigopts = uu___6;_}, - uu___7) -> - let qual1 = fv_qual_of_se (FStar_Pervasives_Native.fst se) in - let uu___8 = FStar_Syntax_Syntax.lid_and_dd_as_fv lid1 qual1 in - FStar_Pervasives_Native.Some uu___8 - | uu___ -> FStar_Pervasives_Native.None in - resolve_in_open_namespaces' env1 lid - (fun uu___ -> FStar_Pervasives_Native.None) - (fun uu___ -> FStar_Pervasives_Native.None) k_global_def -let (find_all_datacons : - env -> - FStar_Ident.lident -> - FStar_Ident.lident Prims.list FStar_Pervasives_Native.option) - = - fun env1 -> - fun lid -> - let k_global_def lid1 uu___ = - match uu___ with - | ({ - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = uu___1; - FStar_Syntax_Syntax.us = uu___2; - FStar_Syntax_Syntax.params = uu___3; - FStar_Syntax_Syntax.num_uniform_params = uu___4; - FStar_Syntax_Syntax.t = uu___5; - FStar_Syntax_Syntax.mutuals = datas; - FStar_Syntax_Syntax.ds = uu___6; - FStar_Syntax_Syntax.injective_type_params = uu___7;_}; - FStar_Syntax_Syntax.sigrng = uu___8; - FStar_Syntax_Syntax.sigquals = uu___9; - FStar_Syntax_Syntax.sigmeta = uu___10; - FStar_Syntax_Syntax.sigattrs = uu___11; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___12; - FStar_Syntax_Syntax.sigopts = uu___13;_}, - uu___14) -> FStar_Pervasives_Native.Some datas - | uu___1 -> FStar_Pervasives_Native.None in - resolve_in_open_namespaces' env1 lid - (fun uu___ -> FStar_Pervasives_Native.None) - (fun uu___ -> FStar_Pervasives_Native.None) k_global_def -let (record_cache_aux_with_filter : - ((((unit -> unit) * (unit -> unit)) * (((unit -> (Prims.int * unit)) * - (Prims.int FStar_Pervasives_Native.option -> unit)) * - ((unit -> record_or_dc Prims.list) * (record_or_dc -> unit)))) * - (unit -> unit))) - = - let record_cache = FStar_Compiler_Util.mk_ref [[]] in - let push uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Compiler_Effect.op_Bang record_cache in - FStar_Compiler_List.hd uu___3 in - let uu___3 = FStar_Compiler_Effect.op_Bang record_cache in uu___2 :: - uu___3 in - FStar_Compiler_Effect.op_Colon_Equals record_cache uu___1 in - let pop uu___ = - let uu___1 = - let uu___2 = FStar_Compiler_Effect.op_Bang record_cache in - FStar_Compiler_List.tl uu___2 in - FStar_Compiler_Effect.op_Colon_Equals record_cache uu___1 in - let snapshot uu___ = FStar_Common.snapshot push record_cache () in - let rollback depth = FStar_Common.rollback pop record_cache depth in - let peek uu___ = - let uu___1 = FStar_Compiler_Effect.op_Bang record_cache in - FStar_Compiler_List.hd uu___1 in - let insert r = - let uu___ = - let uu___1 = let uu___2 = peek () in r :: uu___2 in - let uu___2 = - let uu___3 = FStar_Compiler_Effect.op_Bang record_cache in - FStar_Compiler_List.tl uu___3 in - uu___1 :: uu___2 in - FStar_Compiler_Effect.op_Colon_Equals record_cache uu___ in - let filter uu___ = - let rc = peek () in - let filtered = - FStar_Compiler_List.filter (fun r -> Prims.op_Negation r.is_private) rc in - let uu___1 = - let uu___2 = - let uu___3 = FStar_Compiler_Effect.op_Bang record_cache in - FStar_Compiler_List.tl uu___3 in - filtered :: uu___2 in - FStar_Compiler_Effect.op_Colon_Equals record_cache uu___1 in - let aux = ((push, pop), ((snapshot, rollback), (peek, insert))) in - (aux, filter) -let (record_cache_aux : - (((unit -> unit) * (unit -> unit)) * (((unit -> (Prims.int * unit)) * - (Prims.int FStar_Pervasives_Native.option -> unit)) * - ((unit -> record_or_dc Prims.list) * (record_or_dc -> unit))))) - = FStar_Pervasives_Native.fst record_cache_aux_with_filter -let (filter_record_cache : unit -> unit) = - FStar_Pervasives_Native.snd record_cache_aux_with_filter -let (push_record_cache : unit -> unit) = - FStar_Pervasives_Native.fst (FStar_Pervasives_Native.fst record_cache_aux) -let (pop_record_cache : unit -> unit) = - FStar_Pervasives_Native.snd (FStar_Pervasives_Native.fst record_cache_aux) -let (snapshot_record_cache : unit -> (Prims.int * unit)) = - FStar_Pervasives_Native.fst - (FStar_Pervasives_Native.fst - (FStar_Pervasives_Native.snd record_cache_aux)) -let (rollback_record_cache : - Prims.int FStar_Pervasives_Native.option -> unit) = - FStar_Pervasives_Native.snd - (FStar_Pervasives_Native.fst - (FStar_Pervasives_Native.snd record_cache_aux)) -let (peek_record_cache : unit -> record_or_dc Prims.list) = - FStar_Pervasives_Native.fst - (FStar_Pervasives_Native.snd - (FStar_Pervasives_Native.snd record_cache_aux)) -let (insert_record_cache : record_or_dc -> unit) = - FStar_Pervasives_Native.snd - (FStar_Pervasives_Native.snd - (FStar_Pervasives_Native.snd record_cache_aux)) -let (extract_record : - env -> - scope_mod Prims.list FStar_Compiler_Effect.ref -> - FStar_Syntax_Syntax.sigelt -> unit) - = - fun e -> - fun new_globs -> - fun se -> - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_bundle - { FStar_Syntax_Syntax.ses = sigs; - FStar_Syntax_Syntax.lids = uu___;_} - -> - let is_record = - FStar_Compiler_Util.for_some - (fun uu___1 -> - match uu___1 with - | FStar_Syntax_Syntax.RecordType uu___2 -> true - | FStar_Syntax_Syntax.RecordConstructor uu___2 -> true - | uu___2 -> false) in - let find_dc dc = - FStar_Compiler_Util.find_opt - (fun uu___1 -> - match uu___1 with - | { - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = lid; - FStar_Syntax_Syntax.us1 = uu___2; - FStar_Syntax_Syntax.t1 = uu___3; - FStar_Syntax_Syntax.ty_lid = uu___4; - FStar_Syntax_Syntax.num_ty_params = uu___5; - FStar_Syntax_Syntax.mutuals1 = uu___6; - FStar_Syntax_Syntax.injective_type_params1 = - uu___7;_}; - FStar_Syntax_Syntax.sigrng = uu___8; - FStar_Syntax_Syntax.sigquals = uu___9; - FStar_Syntax_Syntax.sigmeta = uu___10; - FStar_Syntax_Syntax.sigattrs = uu___11; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___12; - FStar_Syntax_Syntax.sigopts = uu___13;_} -> - FStar_Ident.lid_equals dc lid - | uu___2 -> false) sigs in - FStar_Compiler_List.iter - (fun uu___1 -> - match uu___1 with - | { - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = typename; - FStar_Syntax_Syntax.us = univs; - FStar_Syntax_Syntax.params = parms; - FStar_Syntax_Syntax.num_uniform_params = uu___2; - FStar_Syntax_Syntax.t = uu___3; - FStar_Syntax_Syntax.mutuals = uu___4; - FStar_Syntax_Syntax.ds = dc::[]; - FStar_Syntax_Syntax.injective_type_params = uu___5;_}; - FStar_Syntax_Syntax.sigrng = uu___6; - FStar_Syntax_Syntax.sigquals = typename_quals; - FStar_Syntax_Syntax.sigmeta = uu___7; - FStar_Syntax_Syntax.sigattrs = uu___8; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___9; - FStar_Syntax_Syntax.sigopts = uu___10;_} -> - let uu___11 = - let uu___12 = find_dc dc in - FStar_Compiler_Util.must uu___12 in - (match uu___11 with - | { - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = constrname; - FStar_Syntax_Syntax.us1 = uu___12; - FStar_Syntax_Syntax.t1 = t; - FStar_Syntax_Syntax.ty_lid = uu___13; - FStar_Syntax_Syntax.num_ty_params = n; - FStar_Syntax_Syntax.mutuals1 = uu___14; - FStar_Syntax_Syntax.injective_type_params1 = - uu___15;_}; - FStar_Syntax_Syntax.sigrng = uu___16; - FStar_Syntax_Syntax.sigquals = uu___17; - FStar_Syntax_Syntax.sigmeta = uu___18; - FStar_Syntax_Syntax.sigattrs = uu___19; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___20; - FStar_Syntax_Syntax.sigopts = uu___21;_} -> - let uu___22 = FStar_Syntax_Util.arrow_formals t in - (match uu___22 with - | (all_formals, uu___23) -> - let uu___24 = - FStar_Compiler_Util.first_N n all_formals in - (match uu___24 with - | (_params, formals) -> - let is_rec = is_record typename_quals in - let formals' = - FStar_Compiler_List.collect - (fun f -> - let uu___25 = - (FStar_Syntax_Syntax.is_null_bv - f.FStar_Syntax_Syntax.binder_bv) - || - (is_rec && - (FStar_Syntax_Syntax.is_bqual_implicit - f.FStar_Syntax_Syntax.binder_qual)) in - if uu___25 then [] else [f]) - formals in - let fields' = - FStar_Compiler_List.map - (fun f -> - (((f.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.ppname), - ((f.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort))) - formals' in - let fields = fields' in - let record = - let uu___25 = - FStar_Ident.ident_of_lid constrname in - { - typename; - constrname = uu___25; - parms; - fields; - is_private = - (FStar_Compiler_List.contains - FStar_Syntax_Syntax.Private - typename_quals); - is_record = is_rec - } in - ((let uu___26 = - let uu___27 = - FStar_Compiler_Effect.op_Bang - new_globs in - (Record_or_dc record) :: uu___27 in - FStar_Compiler_Effect.op_Colon_Equals - new_globs uu___26); - (match () with - | () -> - ((let add_field uu___27 = - match uu___27 with - | (id, uu___28) -> - let modul = - let uu___29 = - let uu___30 = - FStar_Ident.ns_of_lid - constrname in - FStar_Ident.lid_of_ids - uu___30 in - FStar_Ident.string_of_lid - uu___29 in - let uu___29 = - get_exported_id_set e - modul in - (match uu___29 with - | FStar_Pervasives_Native.Some - my_ex -> - let my_exported_ids = - my_ex - Exported_id_field in - ((let uu___31 = - let uu___32 = - FStar_Ident.string_of_id - id in - let uu___33 = - FStar_Compiler_Effect.op_Bang - my_exported_ids in - Obj.magic - (FStar_Class_Setlike.add - () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) - uu___32 - (Obj.magic - uu___33)) in - FStar_Compiler_Effect.op_Colon_Equals - my_exported_ids - uu___31); - (match () with - | () -> - let projname = - let uu___31 = - let uu___32 - = - FStar_Syntax_Util.mk_field_projector_name_from_ident - constrname - id in - FStar_Ident.ident_of_lid - uu___32 in - FStar_Ident.string_of_id - uu___31 in - let uu___32 = - let uu___33 = - FStar_Compiler_Effect.op_Bang - my_exported_ids in - Obj.magic - (FStar_Class_Setlike.add - () - ( - Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) - projname - ( - Obj.magic - uu___33)) in - FStar_Compiler_Effect.op_Colon_Equals - my_exported_ids - uu___32)) - | FStar_Pervasives_Native.None - -> ()) in - FStar_Compiler_List.iter - add_field fields'); - (match () with - | () -> - insert_record_cache record)))))) - | uu___12 -> ()) - | uu___2 -> ()) sigs - | uu___ -> () -let (try_lookup_record_or_dc_by_field_name : - env -> FStar_Ident.lident -> record_or_dc FStar_Pervasives_Native.option) = - fun env1 -> - fun fieldname -> - let find_in_cache fieldname1 = - let uu___ = - let uu___1 = FStar_Ident.ns_of_lid fieldname1 in - let uu___2 = FStar_Ident.ident_of_lid fieldname1 in - (uu___1, uu___2) in - match uu___ with - | (ns, id) -> - let uu___1 = peek_record_cache () in - FStar_Compiler_Util.find_map uu___1 - (fun record -> - let uu___2 = - find_in_record ns id record (fun r -> Cont_ok r) in - option_of_cont (fun uu___3 -> FStar_Pervasives_Native.None) - uu___2) in - resolve_in_open_namespaces'' env1 fieldname Exported_id_field - (fun uu___ -> Cont_ignore) (fun uu___ -> Cont_ignore) - (fun r -> Cont_ok r) - (fun fn -> - let uu___ = find_in_cache fn in cont_of_option Cont_ignore uu___) - (fun k -> fun uu___ -> k) -let (try_lookup_record_by_field_name : - env -> FStar_Ident.lident -> record_or_dc FStar_Pervasives_Native.option) = - fun env1 -> - fun fieldname -> - let uu___ = try_lookup_record_or_dc_by_field_name env1 fieldname in - match uu___ with - | FStar_Pervasives_Native.Some r when r.is_record -> - FStar_Pervasives_Native.Some r - | uu___1 -> FStar_Pervasives_Native.None -let (try_lookup_record_type : - env -> FStar_Ident.lident -> record_or_dc FStar_Pervasives_Native.option) = - fun env1 -> - fun typename -> - let find_in_cache name = - let uu___ = - let uu___1 = FStar_Ident.ns_of_lid name in - let uu___2 = FStar_Ident.ident_of_lid name in (uu___1, uu___2) in - match uu___ with - | (ns, id) -> - let uu___1 = peek_record_cache () in - FStar_Compiler_Util.find_map uu___1 - (fun record -> - let uu___2 = - let uu___3 = FStar_Ident.ident_of_lid record.typename in - FStar_Ident.ident_equals uu___3 id in - if uu___2 - then FStar_Pervasives_Native.Some record - else FStar_Pervasives_Native.None) in - resolve_in_open_namespaces'' env1 typename Exported_id_term_type - (fun uu___ -> Cont_ignore) (fun uu___ -> Cont_ignore) - (fun r -> Cont_ok r) - (fun l -> - let uu___ = find_in_cache l in cont_of_option Cont_ignore uu___) - (fun k -> fun uu___ -> k) -let (belongs_to_record : - env -> FStar_Ident.lident -> record_or_dc -> Prims.bool) = - fun env1 -> - fun lid -> - fun record -> - let uu___ = try_lookup_record_by_field_name env1 lid in - match uu___ with - | FStar_Pervasives_Native.Some record' when - let uu___1 = FStar_Ident.nsstr record.typename in - let uu___2 = FStar_Ident.nsstr record'.typename in - uu___1 = uu___2 -> - let uu___1 = - let uu___2 = FStar_Ident.ns_of_lid record.typename in - let uu___3 = FStar_Ident.ident_of_lid lid in - find_in_record uu___2 uu___3 record (fun uu___4 -> Cont_ok ()) in - (match uu___1 with | Cont_ok uu___2 -> true | uu___2 -> false) - | uu___1 -> false -let (try_lookup_dc_by_field_name : - env -> - FStar_Ident.lident -> - (FStar_Ident.lident * Prims.bool) FStar_Pervasives_Native.option) - = - fun env1 -> - fun fieldname -> - let uu___ = try_lookup_record_or_dc_by_field_name env1 fieldname in - match uu___ with - | FStar_Pervasives_Native.Some r -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Ident.ns_of_lid r.typename in - FStar_Compiler_List.op_At uu___5 [r.constrname] in - FStar_Ident.lid_of_ids uu___4 in - let uu___4 = FStar_Ident.range_of_lid fieldname in - FStar_Ident.set_lid_range uu___3 uu___4 in - (uu___2, (r.is_record)) in - FStar_Pervasives_Native.Some uu___1 - | uu___1 -> FStar_Pervasives_Native.None -let (string_set_ref_new : unit -> string_set FStar_Compiler_Effect.ref) = - fun uu___ -> - let uu___1 = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset FStar_Class_Ord.ord_string)) - ()) in - FStar_Compiler_Util.mk_ref uu___1 -let (exported_id_set_new : - unit -> exported_id_kind -> string_set FStar_Compiler_Effect.ref) = - fun uu___ -> - let term_type_set = string_set_ref_new () in - let field_set = string_set_ref_new () in - fun uu___1 -> - match uu___1 with - | Exported_id_term_type -> term_type_set - | Exported_id_field -> field_set -let (unique : - Prims.bool -> Prims.bool -> env -> FStar_Ident.lident -> Prims.bool) = - fun any_val -> - fun exclude_interface -> - fun env1 -> - fun lid -> - let filter_scope_mods uu___ = - match uu___ with | Rec_binding uu___1 -> true | uu___1 -> false in - let this_env = - let uu___ = - FStar_Compiler_List.filter filter_scope_mods env1.scope_mods in - { - curmodule = (env1.curmodule); - curmonad = (env1.curmonad); - modules = (env1.modules); - scope_mods = uu___; - exported_ids = empty_exported_id_smap; - trans_exported_ids = (env1.trans_exported_ids); - includes = empty_include_smap; - sigaccum = (env1.sigaccum); - sigmap = (env1.sigmap); - iface = (env1.iface); - admitted_iface = (env1.admitted_iface); - expect_typ = (env1.expect_typ); - remaining_iface_decls = (env1.remaining_iface_decls); - syntax_only = (env1.syntax_only); - ds_hooks = (env1.ds_hooks); - dep_graph = (env1.dep_graph) - } in - let uu___ = try_lookup_lid' any_val exclude_interface this_env lid in - match uu___ with - | FStar_Pervasives_Native.None -> true - | FStar_Pervasives_Native.Some uu___1 -> false -let (push_scope_mod : env -> scope_mod -> env) = - fun env1 -> - fun scope_mod1 -> - { - curmodule = (env1.curmodule); - curmonad = (env1.curmonad); - modules = (env1.modules); - scope_mods = (scope_mod1 :: (env1.scope_mods)); - exported_ids = (env1.exported_ids); - trans_exported_ids = (env1.trans_exported_ids); - includes = (env1.includes); - sigaccum = (env1.sigaccum); - sigmap = (env1.sigmap); - iface = (env1.iface); - admitted_iface = (env1.admitted_iface); - expect_typ = (env1.expect_typ); - remaining_iface_decls = (env1.remaining_iface_decls); - syntax_only = (env1.syntax_only); - ds_hooks = (env1.ds_hooks); - dep_graph = (env1.dep_graph) - } -let (push_bv' : - env -> FStar_Ident.ident -> (env * FStar_Syntax_Syntax.bv * used_marker)) = - fun env1 -> - fun x -> - let r = FStar_Ident.range_of_id x in - let bv = - let uu___ = FStar_Ident.string_of_id x in - FStar_Syntax_Syntax.gen_bv uu___ (FStar_Pervasives_Native.Some r) - { - FStar_Syntax_Syntax.n = - (FStar_Syntax_Syntax.tun.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = r; - FStar_Syntax_Syntax.vars = - (FStar_Syntax_Syntax.tun.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (FStar_Syntax_Syntax.tun.FStar_Syntax_Syntax.hash_code) - } in - let used_marker1 = FStar_Compiler_Util.mk_ref false in - ((push_scope_mod env1 (Local_binding (x, bv, used_marker1))), bv, - used_marker1) -let (push_bv : env -> FStar_Ident.ident -> (env * FStar_Syntax_Syntax.bv)) = - fun env1 -> - fun x -> - let uu___ = push_bv' env1 x in - match uu___ with | (env2, bv, uu___1) -> (env2, bv) -let (push_top_level_rec_binding : - env -> FStar_Ident.ident -> (env * Prims.bool FStar_Compiler_Effect.ref)) = - fun env0 -> - fun x -> - let l = qualify env0 x in - let uu___ = - (unique false true env0 l) || (FStar_Options.interactive ()) in - if uu___ - then - let used_marker1 = FStar_Compiler_Util.mk_ref false in - ((push_scope_mod env0 (Rec_binding (x, l, used_marker1))), - used_marker1) - else - (let uu___2 = - let uu___3 = FStar_Ident.string_of_lid l in - Prims.strcat "Duplicate top-level names " uu___3 in - FStar_Errors.raise_error FStar_Ident.hasrange_lident l - FStar_Errors_Codes.Fatal_DuplicateTopLevelNames () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)) -let (push_sigelt' : Prims.bool -> env -> FStar_Syntax_Syntax.sigelt -> env) = - fun fail_on_dup -> - fun env1 -> - fun s -> - let err l = - let sopt = - let uu___ = FStar_Ident.string_of_lid l in - FStar_Compiler_Util.smap_try_find (sigmap env1) uu___ in - let r = - match sopt with - | FStar_Pervasives_Native.Some (se, uu___) -> - let uu___1 = - FStar_Compiler_Util.find_opt (FStar_Ident.lid_equals l) - (FStar_Syntax_Util.lids_of_sigelt se) in - (match uu___1 with - | FStar_Pervasives_Native.Some l1 -> - let uu___2 = FStar_Ident.range_of_lid l1 in - FStar_Compiler_Range_Ops.string_of_range uu___2 - | FStar_Pervasives_Native.None -> "") - | FStar_Pervasives_Native.None -> "" in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Ident.string_of_lid l in - FStar_Compiler_Util.format1 "Duplicate top-level names [%s]" - uu___3 in - FStar_Errors_Msg.text uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Compiler_Util.format1 "Previously declared at %s" r in - FStar_Errors_Msg.text uu___4 in - [uu___3] in - uu___1 :: uu___2 in - FStar_Errors.raise_error FStar_Ident.hasrange_lident l - FStar_Errors_Codes.Fatal_DuplicateTopLevelNames () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___) in - let globals = FStar_Compiler_Util.mk_ref env1.scope_mods in - let env2 = - let uu___ = - match s.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_let uu___1 -> (false, true) - | FStar_Syntax_Syntax.Sig_bundle uu___1 -> (false, true) - | uu___1 -> (false, false) in - match uu___ with - | (any_val, exclude_interface) -> - let lids = FStar_Syntax_Util.lids_of_sigelt s in - let uu___1 = - FStar_Compiler_Util.find_map lids - (fun l -> - let uu___2 = - let uu___3 = unique any_val exclude_interface env1 l in - Prims.op_Negation uu___3 in - if uu___2 - then FStar_Pervasives_Native.Some l - else FStar_Pervasives_Native.None) in - (match uu___1 with - | FStar_Pervasives_Native.Some l when fail_on_dup -> err l - | uu___2 -> - (extract_record env1 globals s; - { - curmodule = (env1.curmodule); - curmonad = (env1.curmonad); - modules = (env1.modules); - scope_mods = (env1.scope_mods); - exported_ids = (env1.exported_ids); - trans_exported_ids = (env1.trans_exported_ids); - includes = (env1.includes); - sigaccum = (s :: (env1.sigaccum)); - sigmap = (env1.sigmap); - iface = (env1.iface); - admitted_iface = (env1.admitted_iface); - expect_typ = (env1.expect_typ); - remaining_iface_decls = (env1.remaining_iface_decls); - syntax_only = (env1.syntax_only); - ds_hooks = (env1.ds_hooks); - dep_graph = (env1.dep_graph) - })) in - let env3 = - let uu___ = FStar_Compiler_Effect.op_Bang globals in - { - curmodule = (env2.curmodule); - curmonad = (env2.curmonad); - modules = (env2.modules); - scope_mods = uu___; - exported_ids = (env2.exported_ids); - trans_exported_ids = (env2.trans_exported_ids); - includes = (env2.includes); - sigaccum = (env2.sigaccum); - sigmap = (env2.sigmap); - iface = (env2.iface); - admitted_iface = (env2.admitted_iface); - expect_typ = (env2.expect_typ); - remaining_iface_decls = (env2.remaining_iface_decls); - syntax_only = (env2.syntax_only); - ds_hooks = (env2.ds_hooks); - dep_graph = (env2.dep_graph) - } in - let uu___ = - match s.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_bundle - { FStar_Syntax_Syntax.ses = ses; - FStar_Syntax_Syntax.lids = uu___1;_} - -> - let uu___2 = - FStar_Compiler_List.map - (fun se -> ((FStar_Syntax_Util.lids_of_sigelt se), se)) ses in - (env3, uu___2) - | uu___1 -> (env3, [((FStar_Syntax_Util.lids_of_sigelt s), s)]) in - match uu___ with - | (env4, lss) -> - (FStar_Compiler_List.iter - (fun uu___2 -> - match uu___2 with - | (lids, se) -> - FStar_Compiler_List.iter - (fun lid -> - (let uu___4 = - let uu___5 = - let uu___6 = FStar_Ident.ident_of_lid lid in - Top_level_def uu___6 in - let uu___6 = - FStar_Compiler_Effect.op_Bang globals in - uu___5 :: uu___6 in - FStar_Compiler_Effect.op_Colon_Equals globals - uu___4); - (match () with - | () -> - let modul = - let uu___4 = - let uu___5 = FStar_Ident.ns_of_lid lid in - FStar_Ident.lid_of_ids uu___5 in - FStar_Ident.string_of_lid uu___4 in - ((let uu___5 = get_exported_id_set env4 modul in - match uu___5 with - | FStar_Pervasives_Native.Some f -> - let my_exported_ids = - f Exported_id_term_type in - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Ident.ident_of_lid lid in - FStar_Ident.string_of_id uu___8 in - let uu___8 = - FStar_Compiler_Effect.op_Bang - my_exported_ids in - Obj.magic - (FStar_Class_Setlike.add () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) - uu___7 (Obj.magic uu___8)) in - FStar_Compiler_Effect.op_Colon_Equals - my_exported_ids uu___6 - | FStar_Pervasives_Native.None -> ()); - (match () with - | () -> - let is_iface = - env4.iface && - (Prims.op_Negation - env4.admitted_iface) in - let uu___5 = - FStar_Ident.string_of_lid lid in - FStar_Compiler_Util.smap_add - (sigmap env4) uu___5 - (se, - (env4.iface && - (Prims.op_Negation - env4.admitted_iface))))))) - lids) lss; - (let env5 = - let uu___2 = FStar_Compiler_Effect.op_Bang globals in - { - curmodule = (env4.curmodule); - curmonad = (env4.curmonad); - modules = (env4.modules); - scope_mods = uu___2; - exported_ids = (env4.exported_ids); - trans_exported_ids = (env4.trans_exported_ids); - includes = (env4.includes); - sigaccum = (env4.sigaccum); - sigmap = (env4.sigmap); - iface = (env4.iface); - admitted_iface = (env4.admitted_iface); - expect_typ = (env4.expect_typ); - remaining_iface_decls = (env4.remaining_iface_decls); - syntax_only = (env4.syntax_only); - ds_hooks = (env4.ds_hooks); - dep_graph = (env4.dep_graph) - } in - env5)) -let (push_sigelt : env -> FStar_Syntax_Syntax.sigelt -> env) = - fun env1 -> fun se -> push_sigelt' true env1 se -let (push_sigelt_force : env -> FStar_Syntax_Syntax.sigelt -> env) = - fun env1 -> fun se -> push_sigelt' false env1 se -let (find_data_constructors_for_typ : - env -> - FStar_Ident.lident -> - FStar_Ident.lident Prims.list FStar_Pervasives_Native.option) - = - fun env1 -> - fun lid -> - let k_global_def lid1 uu___ = - match uu___ with - | ({ - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = uu___1; - FStar_Syntax_Syntax.us = uu___2; - FStar_Syntax_Syntax.params = uu___3; - FStar_Syntax_Syntax.num_uniform_params = uu___4; - FStar_Syntax_Syntax.t = uu___5; - FStar_Syntax_Syntax.mutuals = uu___6; - FStar_Syntax_Syntax.ds = ds; - FStar_Syntax_Syntax.injective_type_params = uu___7;_}; - FStar_Syntax_Syntax.sigrng = uu___8; - FStar_Syntax_Syntax.sigquals = uu___9; - FStar_Syntax_Syntax.sigmeta = uu___10; - FStar_Syntax_Syntax.sigattrs = uu___11; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___12; - FStar_Syntax_Syntax.sigopts = uu___13;_}, - uu___14) -> FStar_Pervasives_Native.Some ds - | uu___1 -> FStar_Pervasives_Native.None in - resolve_in_open_namespaces' env1 lid - (fun uu___ -> FStar_Pervasives_Native.None) - (fun uu___ -> FStar_Pervasives_Native.None) k_global_def -let (find_binders_for_datacons : - env -> - FStar_Ident.lident -> - FStar_Ident.ident Prims.list FStar_Pervasives_Native.option) - = - fun env1 -> - fun lid -> - let k_global_def lid1 uu___ = - match uu___ with - | ({ - FStar_Syntax_Syntax.sigel = FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = uu___1; - FStar_Syntax_Syntax.us1 = uu___2; - FStar_Syntax_Syntax.t1 = t; - FStar_Syntax_Syntax.ty_lid = uu___3; - FStar_Syntax_Syntax.num_ty_params = uu___4; - FStar_Syntax_Syntax.mutuals1 = uu___5; - FStar_Syntax_Syntax.injective_type_params1 = uu___6;_}; - FStar_Syntax_Syntax.sigrng = uu___7; - FStar_Syntax_Syntax.sigquals = uu___8; - FStar_Syntax_Syntax.sigmeta = uu___9; - FStar_Syntax_Syntax.sigattrs = uu___10; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___11; - FStar_Syntax_Syntax.sigopts = uu___12;_}, - uu___13) -> - let uu___14 = - let uu___15 = - let uu___16 = FStar_Syntax_Util.arrow_formals_comp_ln t in - FStar_Pervasives_Native.fst uu___16 in - FStar_Compiler_List.map - (fun x -> - (x.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.ppname) - uu___15 in - FStar_Pervasives_Native.Some uu___14 - | uu___1 -> FStar_Pervasives_Native.None in - resolve_in_open_namespaces' env1 lid - (fun uu___ -> FStar_Pervasives_Native.None) - (fun uu___ -> FStar_Pervasives_Native.None) k_global_def -let elab_restriction : - 'uuuuu . - (env -> FStar_Ident.lident -> FStar_Syntax_Syntax.restriction -> 'uuuuu) - -> - env -> FStar_Ident.lident -> FStar_Syntax_Syntax.restriction -> 'uuuuu - = - fun f -> - fun env1 -> - fun ns -> - fun restriction -> - match restriction with - | FStar_Syntax_Syntax.Unrestricted -> f env1 ns restriction - | FStar_Syntax_Syntax.AllowList l -> - let mk_lid id = - let uu___ = - let uu___1 = - let uu___2 = FStar_Ident.qual_id ns id in - FStar_Ident.ids_of_lid uu___2 in - FStar_Ident.lid_of_ids uu___1 in - let uu___1 = FStar_Ident.range_of_id id in - FStar_Ident.set_lid_range uu___ uu___1 in - let name_exists id = - let lid = mk_lid id in - let uu___ = try_lookup_lid env1 lid in - match uu___ with - | FStar_Pervasives_Native.Some uu___1 -> true - | FStar_Pervasives_Native.None -> - let uu___1 = - try_lookup_record_or_dc_by_field_name env1 lid in - FStar_Compiler_Util.is_some uu___1 in - let l1 = - let uu___ = - let uu___1 = - FStar_Compiler_List.map - (fun uu___2 -> - match uu___2 with - | (id, renamed) -> - let with_id_range = - let uu___3 = - FStar_Ident.range_of_id - (FStar_Compiler_Util.dflt id renamed) in - FStar_Ident.set_id_range uu___3 in - let uu___3 = - let uu___4 = mk_lid id in - find_data_constructors_for_typ env1 uu___4 in - (match uu___3 with - | FStar_Pervasives_Native.Some idents -> - FStar_Compiler_List.map - (fun id1 -> - let uu___4 = - let uu___5 = - FStar_Ident.ident_of_lid id1 in - with_id_range uu___5 in - (uu___4, FStar_Pervasives_Native.None)) - idents - | FStar_Pervasives_Native.None -> [])) l in - FStar_Compiler_List.flatten uu___1 in - FStar_Compiler_List.append l uu___ in - let l2 = - let constructor_lid_to_desugared_record_lids = - let uu___ = - let uu___1 = - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_list () () - (Obj.magic env1.modules) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - match uu___2 with - | (uu___3, - { FStar_Syntax_Syntax.name = uu___4; - FStar_Syntax_Syntax.declarations = - declarations; - FStar_Syntax_Syntax.is_interface = - uu___5;_}) - -> - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_list () () - (Obj.magic declarations) - (fun uu___6 -> - (fun sigelt -> - let sigelt = Obj.magic sigelt in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_list - () () - (match sigelt.FStar_Syntax_Syntax.sigel - with - | FStar_Syntax_Syntax.Sig_bundle - { - FStar_Syntax_Syntax.ses - = ses; - FStar_Syntax_Syntax.lids - = uu___6;_} - -> Obj.magic ses - | uu___6 -> - Obj.magic []) - (fun uu___6 -> - (fun sigelt1 -> - let sigelt1 = - Obj.magic - sigelt1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_list - () () - (Obj.magic - (FStar_Syntax_Util.lids_of_sigelt - sigelt1)) - (fun uu___6 - -> - (fun lid - -> - let lid = - Obj.magic - lid in - let uu___6 - = - FStar_Syntax_Util.get_attribute - FStar_Parser_Const.desugar_of_variant_record_lid - sigelt1.FStar_Syntax_Syntax.sigattrs in - match uu___6 - with - | - FStar_Pervasives_Native.Some - (({ - FStar_Syntax_Syntax.n - = - FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_string - (s, - uu___7)); - FStar_Syntax_Syntax.pos - = uu___8; - FStar_Syntax_Syntax.vars - = uu___9; - FStar_Syntax_Syntax.hash_code - = uu___10;_}, - FStar_Pervasives_Native.None)::[]) - -> - let uu___11 - = - let uu___12 - = - FStar_Ident.lid_of_str - s in - (uu___12, - lid) in - Obj.magic - [uu___11] - | - uu___7 -> - Obj.magic - []) - uu___6))) - uu___6))) uu___6))) - uu___2)) in - FStar_Compiler_List.filter - (fun uu___2 -> - match uu___2 with - | (cons, lid) -> - (let uu___3 = FStar_Ident.ns_of_lid cons in - let uu___4 = FStar_Ident.ns_of_lid lid in - FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq - (FStar_Class_Ord.ord_list - FStar_Syntax_Syntax.ord_ident)) uu___3 - uu___4) - && - (let uu___3 = FStar_Ident.ns_of_lid lid in - let uu___4 = FStar_Ident.ids_of_lid ns in - FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq - (FStar_Class_Ord.ord_list - FStar_Syntax_Syntax.ord_ident)) - uu___3 uu___4)) uu___1 in - FStar_Compiler_List.map - (fun uu___1 -> - match uu___1 with - | (cons, lid) -> - let uu___2 = FStar_Ident.ident_of_lid cons in - let uu___3 = FStar_Ident.ident_of_lid lid in - (uu___2, uu___3)) uu___ in - let uu___ = - let uu___1 = - FStar_Compiler_List.filter - (fun uu___2 -> - match uu___2 with - | (cons, uu___3) -> - let uu___4 = - FStar_Compiler_List.find - (fun uu___5 -> - match uu___5 with - | (lid, uu___6) -> - FStar_Class_Deq.op_Equals_Question - FStar_Syntax_Syntax.deq_univ_name - lid cons) l1 in - FStar_Pervasives_Native.uu___is_Some uu___4) - constructor_lid_to_desugared_record_lids in - FStar_Compiler_List.map - (fun uu___2 -> - match uu___2 with - | (uu___3, lid) -> (lid, FStar_Pervasives_Native.None)) - uu___1 in - FStar_Compiler_List.append l1 uu___ in - let l3 = - let uu___ = - let uu___1 = - FStar_Compiler_List.map - (fun uu___2 -> - match uu___2 with - | (id, renamed) -> - let with_renamed_range = - let uu___3 = - FStar_Ident.range_of_id - (FStar_Compiler_Util.dflt id renamed) in - FStar_Ident.set_id_range uu___3 in - let with_id_range = - let uu___3 = - FStar_Ident.range_of_id - (FStar_Compiler_Util.dflt id renamed) in - FStar_Ident.set_id_range uu___3 in - let lid = mk_lid id in - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - find_binders_for_datacons env1 lid in - match uu___6 with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some l4 -> l4 in - FStar_Compiler_List.map - (fun binder -> - let uu___6 = - let uu___7 = - FStar_Syntax_Util.mk_field_projector_name_from_ident - lid binder in - FStar_Ident.ident_of_lid uu___7 in - let uu___7 = - FStar_Compiler_Util.map_opt renamed - (fun renamed1 -> - let uu___8 = - let uu___9 = - FStar_Ident.lid_of_ids - [renamed1] in - FStar_Syntax_Util.mk_field_projector_name_from_ident - uu___9 binder in - FStar_Ident.ident_of_lid uu___8) in - (uu___6, uu___7)) uu___5 in - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Ident.lid_of_ids [id] in - FStar_Syntax_Util.mk_discriminator - uu___11 in - let uu___11 = - FStar_Compiler_Util.map_opt - renamed - (fun renamed1 -> - let uu___12 = - FStar_Ident.lid_of_ids - [renamed1] in - FStar_Syntax_Util.mk_discriminator - uu___12) in - (uu___10, uu___11) in - [uu___9] in - FStar_Compiler_List.map - (fun uu___9 -> - match uu___9 with - | (x, y) -> - let uu___10 = - FStar_Ident.ident_of_lid x in - let uu___11 = - FStar_Compiler_Util.map_opt y - FStar_Ident.ident_of_lid in - (uu___10, uu___11)) uu___8 in - FStar_Compiler_List.filter - (fun uu___8 -> - match uu___8 with - | (x, uu___9) -> name_exists x) - uu___7 in - let uu___7 = - let uu___8 = - try_lookup_record_type env1 lid in - match uu___8 with - | FStar_Pervasives_Native.Some - { typename = uu___9; constrname; - parms = uu___10; fields; - is_private = uu___11; - is_record = uu___12;_} - -> - FStar_Compiler_List.map - (fun uu___13 -> - match uu___13 with - | (id1, uu___14) -> - (id1, - FStar_Pervasives_Native.None)) - fields - | FStar_Pervasives_Native.None -> [] in - FStar_Compiler_List.op_At uu___6 uu___7 in - FStar_Compiler_List.op_At uu___4 uu___5 in - FStar_Compiler_List.map - (fun uu___4 -> - match uu___4 with - | (id1, renamed1) -> - let uu___5 = with_id_range id1 in - let uu___6 = - FStar_Compiler_Util.map_opt renamed1 - with_renamed_range in - (uu___5, uu___6)) uu___3) l2 in - FStar_Compiler_List.flatten uu___1 in - FStar_Compiler_List.append l2 uu___ in - ((let final_idents = - FStar_Compiler_List.mapi - (fun i -> - fun uu___ -> - match uu___ with - | (id, renamed) -> - ((FStar_Compiler_Util.dflt id renamed), i)) l3 in - let uu___ = - FStar_Compiler_Util.find_dup - (fun uu___1 -> - fun uu___2 -> - match (uu___1, uu___2) with - | ((x, uu___3), (y, uu___4)) -> - FStar_Class_Deq.op_Equals_Question - FStar_Syntax_Syntax.deq_univ_name x y) - final_idents in - match uu___ with - | FStar_Pervasives_Native.Some (id, i) -> - let others = - FStar_Compiler_List.filter - (fun uu___1 -> - match uu___1 with - | (id', i') -> - (FStar_Class_Deq.op_Equals_Question - FStar_Syntax_Syntax.deq_univ_name id id') - && - (let uu___2 = - FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq - FStar_Class_Ord.ord_int) i i' in - Prims.op_Negation uu___2)) final_idents in - ((let uu___2 = - FStar_Compiler_List.mapi - (fun nth -> - fun uu___3 -> - match uu___3 with - | (other, uu___4) -> - let nth1 = - match nth with - | uu___5 when uu___5 = Prims.int_zero -> - "first" - | uu___5 when uu___5 = Prims.int_one -> - "second" - | uu___5 when - uu___5 = (Prims.of_int (2)) -> - "third" - | nth2 -> - let uu___5 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - (nth2 + Prims.int_one) in - Prims.strcat uu___5 "th" in - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Class_Show.show - FStar_Ident.showable_ident other in - Prims.strcat uu___8 - (Prims.strcat " " - (Prims.strcat nth1 - " occurence comes from this declaration")) in - FStar_Errors_Msg.text uu___7 in - [uu___6] in - let uu___6 = - let uu___7 = - FStar_Ident.range_of_id other in - FStar_Pervasives_Native.Some uu___7 in - { - FStar_Errors.issue_msg = uu___5; - FStar_Errors.issue_level = - FStar_Errors.EError; - FStar_Errors.issue_range = uu___6; - FStar_Errors.issue_number = - FStar_Pervasives_Native.None; - FStar_Errors.issue_ctx = [] - }) others in - FStar_Errors.add_issues uu___2); - (let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - ((FStar_Compiler_List.length others) + - Prims.int_one) in - Prims.strcat uu___5 " times" in - Prims.strcat "The name %s was imported " uu___4 in - let uu___4 = FStar_Ident.string_of_id id in - FStar_Compiler_Util.format1 uu___3 uu___4 in - FStar_Errors.raise_error FStar_Ident.hasrange_ident id - FStar_Errors_Codes.Fatal_DuplicateTopLevelNames () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2))) - | FStar_Pervasives_Native.None -> ()); - FStar_Compiler_List.iter - (fun uu___1 -> - match uu___1 with - | (id, _renamed) -> - let uu___2 = - let uu___3 = name_exists id in - Prims.op_Negation uu___3 in - if uu___2 - then - let uu___3 = - let uu___4 = - let uu___5 = mk_lid id in - FStar_Ident.string_of_lid uu___5 in - FStar_Compiler_Util.format1 - "Definition %s cannot be found" uu___4 in - FStar_Errors.raise_error FStar_Ident.hasrange_ident - id FStar_Errors_Codes.Fatal_NameNotFound () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___3) - else ()) l3; - f env1 ns (FStar_Syntax_Syntax.AllowList l3)) -let (push_namespace' : - env -> FStar_Ident.lident -> FStar_Syntax_Syntax.restriction -> env) = - fun env1 -> - fun ns -> - fun restriction -> - let uu___ = - let uu___1 = resolve_module_name env1 ns false in - match uu___1 with - | FStar_Pervasives_Native.None -> - let module_names = - FStar_Compiler_List.map FStar_Pervasives_Native.fst - env1.modules in - let module_names1 = - match env1.curmodule with - | FStar_Pervasives_Native.None -> module_names - | FStar_Pervasives_Native.Some l -> l :: module_names in - let uu___2 = - FStar_Compiler_Util.for_some - (fun m -> - let uu___3 = - let uu___4 = FStar_Ident.string_of_lid m in - Prims.strcat uu___4 "." in - let uu___4 = - let uu___5 = FStar_Ident.string_of_lid ns in - Prims.strcat uu___5 "." in - FStar_Compiler_Util.starts_with uu___3 uu___4) - module_names1 in - if uu___2 - then (ns, FStar_Syntax_Syntax.Open_namespace) - else - (let uu___4 = - let uu___5 = FStar_Ident.string_of_lid ns in - FStar_Compiler_Util.format1 "Namespace %s cannot be found" - uu___5 in - FStar_Errors.raise_error FStar_Ident.hasrange_lident ns - FStar_Errors_Codes.Fatal_NameSpaceNotFound () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4)) - | FStar_Pervasives_Native.Some ns' -> - (ns', FStar_Syntax_Syntax.Open_module) in - match uu___ with - | (ns', kd) -> - ((env1.ds_hooks).ds_push_open_hook env1 (ns', kd, restriction); - push_scope_mod env1 - (Open_module_or_namespace (ns', kd, restriction))) -let (push_include' : - env -> FStar_Ident.lident -> FStar_Syntax_Syntax.restriction -> env) = - fun env1 -> - fun ns -> - fun restriction -> - let ns0 = ns in - let uu___ = resolve_module_name env1 ns false in - match uu___ with - | FStar_Pervasives_Native.Some ns1 -> - ((env1.ds_hooks).ds_push_include_hook env1 ns1; - (let env2 = - push_scope_mod env1 - (Open_module_or_namespace - (ns1, FStar_Syntax_Syntax.Open_module, restriction)) in - let curmod = - let uu___2 = current_module env2 in - FStar_Ident.string_of_lid uu___2 in - (let uu___3 = - FStar_Compiler_Util.smap_try_find env2.includes curmod in - match uu___3 with - | FStar_Pervasives_Native.None -> () - | FStar_Pervasives_Native.Some incl -> - let uu___4 = - let uu___5 = FStar_Compiler_Effect.op_Bang incl in - (ns1, restriction) :: uu___5 in - FStar_Compiler_Effect.op_Colon_Equals incl uu___4); - (match () with - | () -> - let uu___3 = - let uu___4 = FStar_Ident.string_of_lid ns1 in - get_trans_exported_id_set env2 uu___4 in - (match uu___3 with - | FStar_Pervasives_Native.Some ns_trans_exports -> - ((let uu___5 = - let uu___6 = get_exported_id_set env2 curmod in - let uu___7 = - get_trans_exported_id_set env2 curmod in - (uu___6, uu___7) in - match uu___5 with - | (FStar_Pervasives_Native.Some cur_exports, - FStar_Pervasives_Native.Some cur_trans_exports) - -> - let update_exports k = - let ns_ex = - let uu___6 = ns_trans_exports k in - FStar_Compiler_Effect.op_Bang uu___6 in - let ex = cur_exports k in - (let uu___7 = - let uu___8 = - FStar_Compiler_Effect.op_Bang ex in - Obj.magic - (FStar_Class_Setlike.diff () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) - (Obj.magic uu___8) (Obj.magic ns_ex)) in - FStar_Compiler_Effect.op_Colon_Equals ex - uu___7); - (match () with - | () -> - let trans_ex = cur_trans_exports k in - let uu___8 = - let uu___9 = - FStar_Compiler_Effect.op_Bang - trans_ex in - Obj.magic - (FStar_Class_Setlike.union () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) - (Obj.magic uu___9) - (Obj.magic ns_ex)) in - FStar_Compiler_Effect.op_Colon_Equals - trans_ex uu___8) in - FStar_Compiler_List.iter update_exports - all_exported_id_kinds - | uu___6 -> ()); - (match () with | () -> env2)) - | FStar_Pervasives_Native.None -> - let uu___4 = - let uu___5 = FStar_Ident.string_of_lid ns1 in - FStar_Compiler_Util.format1 - "include: Module %s was not prepared" uu___5 in - FStar_Errors.raise_error FStar_Ident.hasrange_lident - ns1 - FStar_Errors_Codes.Fatal_IncludeModuleNotPrepared - () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4))))) - | uu___1 -> - let uu___2 = - let uu___3 = FStar_Ident.string_of_lid ns in - FStar_Compiler_Util.format1 - "include: Module %s cannot be found" uu___3 in - FStar_Errors.raise_error FStar_Ident.hasrange_lident ns - FStar_Errors_Codes.Fatal_ModuleNotFound () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2) -let (push_namespace : - env -> FStar_Ident.lident -> FStar_Syntax_Syntax.restriction -> env) = - elab_restriction push_namespace' -let (push_include : - env -> FStar_Ident.lident -> FStar_Syntax_Syntax.restriction -> env) = - elab_restriction push_include' -let (push_module_abbrev : - env -> FStar_Ident.ident -> FStar_Ident.lident -> env) = - fun env1 -> - fun x -> - fun l -> - let uu___ = module_is_defined env1 l in - if uu___ - then - ((env1.ds_hooks).ds_push_module_abbrev_hook env1 x l; - push_scope_mod env1 (Module_abbrev (x, l))) - else - (let uu___2 = - let uu___3 = FStar_Ident.string_of_lid l in - FStar_Compiler_Util.format1 "Module %s cannot be found" uu___3 in - FStar_Errors.raise_error FStar_Ident.hasrange_lident l - FStar_Errors_Codes.Fatal_ModuleNotFound () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)) -let (check_admits : - env -> FStar_Syntax_Syntax.modul -> FStar_Syntax_Syntax.modul) = - fun env1 -> - fun m -> - let admitted_sig_lids = - FStar_Compiler_List.fold_left - (fun lids -> - fun se -> - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_declare_typ - { FStar_Syntax_Syntax.lid2 = l; - FStar_Syntax_Syntax.us2 = u; - FStar_Syntax_Syntax.t2 = t;_} - when - Prims.op_Negation - (FStar_Compiler_List.contains - FStar_Syntax_Syntax.Assumption - se.FStar_Syntax_Syntax.sigquals) - -> - let uu___ = - let uu___1 = FStar_Ident.string_of_lid l in - FStar_Compiler_Util.smap_try_find (sigmap env1) uu___1 in - (match uu___ with - | FStar_Pervasives_Native.Some - ({ - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_let uu___1; - FStar_Syntax_Syntax.sigrng = uu___2; - FStar_Syntax_Syntax.sigquals = uu___3; - FStar_Syntax_Syntax.sigmeta = uu___4; - FStar_Syntax_Syntax.sigattrs = uu___5; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___6; - FStar_Syntax_Syntax.sigopts = uu___7;_}, - uu___8) - -> lids - | FStar_Pervasives_Native.Some - ({ - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_inductive_typ uu___1; - FStar_Syntax_Syntax.sigrng = uu___2; - FStar_Syntax_Syntax.sigquals = uu___3; - FStar_Syntax_Syntax.sigmeta = uu___4; - FStar_Syntax_Syntax.sigattrs = uu___5; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___6; - FStar_Syntax_Syntax.sigopts = uu___7;_}, - uu___8) - -> lids - | FStar_Pervasives_Native.Some - ({ - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_splice uu___1; - FStar_Syntax_Syntax.sigrng = uu___2; - FStar_Syntax_Syntax.sigquals = uu___3; - FStar_Syntax_Syntax.sigmeta = uu___4; - FStar_Syntax_Syntax.sigattrs = uu___5; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___6; - FStar_Syntax_Syntax.sigopts = uu___7;_}, - uu___8) - -> lids - | uu___1 -> - ((let uu___3 = - let uu___4 = FStar_Options.interactive () in - Prims.op_Negation uu___4 in - if uu___3 - then - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Class_Show.show - FStar_Ident.showable_lident l in - FStar_Pprint.doc_of_string uu___7 in - let uu___7 = - FStar_Errors_Msg.text - "is declared but no definition was found" in - FStar_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in - let uu___6 = - let uu___7 = - FStar_Errors_Msg.text - "Add an 'assume' if this is intentional" in - [uu___7] in - uu___5 :: uu___6 in - FStar_Errors.log_issue - FStar_Ident.hasrange_lident l - FStar_Errors_Codes.Error_AdmitWithoutDefinition - () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___4) - else ()); - (let quals = FStar_Syntax_Syntax.Assumption :: - (se.FStar_Syntax_Syntax.sigquals) in - (let uu___4 = FStar_Ident.string_of_lid l in - FStar_Compiler_Util.smap_add (sigmap env1) uu___4 - ({ - FStar_Syntax_Syntax.sigel = - (se.FStar_Syntax_Syntax.sigel); - FStar_Syntax_Syntax.sigrng = - (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = quals; - FStar_Syntax_Syntax.sigmeta = - (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se.FStar_Syntax_Syntax.sigopts) - }, false)); - l - :: - lids))) - | uu___ -> lids) [] env1.sigaccum in - m -let (finish : env -> FStar_Syntax_Syntax.modul -> env) = - fun env1 -> - fun modul -> - FStar_Compiler_List.iter - (fun se -> - let quals = se.FStar_Syntax_Syntax.sigquals in - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_bundle - { FStar_Syntax_Syntax.ses = ses; - FStar_Syntax_Syntax.lids = uu___1;_} - -> - if - FStar_Compiler_List.contains FStar_Syntax_Syntax.Private - quals - then - FStar_Compiler_List.iter - (fun se1 -> - match se1.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = lid; - FStar_Syntax_Syntax.us1 = uu___2; - FStar_Syntax_Syntax.t1 = uu___3; - FStar_Syntax_Syntax.ty_lid = uu___4; - FStar_Syntax_Syntax.num_ty_params = uu___5; - FStar_Syntax_Syntax.mutuals1 = uu___6; - FStar_Syntax_Syntax.injective_type_params1 = - uu___7;_} - -> - let uu___8 = FStar_Ident.string_of_lid lid in - FStar_Compiler_Util.smap_remove (sigmap env1) - uu___8 - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = lid; - FStar_Syntax_Syntax.us = univ_names; - FStar_Syntax_Syntax.params = binders; - FStar_Syntax_Syntax.num_uniform_params = uu___2; - FStar_Syntax_Syntax.t = typ; - FStar_Syntax_Syntax.mutuals = uu___3; - FStar_Syntax_Syntax.ds = uu___4; - FStar_Syntax_Syntax.injective_type_params = - uu___5;_} - -> - ((let uu___7 = FStar_Ident.string_of_lid lid in - FStar_Compiler_Util.smap_remove (sigmap env1) - uu___7); - if - Prims.op_Negation - (FStar_Compiler_List.contains - FStar_Syntax_Syntax.Private quals) - then - (let sigel = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Syntax_Syntax.mk_Total typ in - { - FStar_Syntax_Syntax.bs1 = binders; - FStar_Syntax_Syntax.comp = uu___11 - } in - FStar_Syntax_Syntax.Tm_arrow uu___10 in - let uu___10 = - FStar_Ident.range_of_lid lid in - FStar_Syntax_Syntax.mk uu___9 uu___10 in - { - FStar_Syntax_Syntax.lid2 = lid; - FStar_Syntax_Syntax.us2 = univ_names; - FStar_Syntax_Syntax.t2 = uu___8 - } in - FStar_Syntax_Syntax.Sig_declare_typ uu___7 in - let se2 = - { - FStar_Syntax_Syntax.sigel = sigel; - FStar_Syntax_Syntax.sigrng = - (se1.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (FStar_Syntax_Syntax.Assumption :: quals); - FStar_Syntax_Syntax.sigmeta = - (se1.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se1.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se1.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se1.FStar_Syntax_Syntax.sigopts) - } in - let uu___7 = FStar_Ident.string_of_lid lid in - FStar_Compiler_Util.smap_add (sigmap env1) - uu___7 (se2, false)) - else ()) - | uu___2 -> ()) ses - else () - | FStar_Syntax_Syntax.Sig_declare_typ - { FStar_Syntax_Syntax.lid2 = lid; - FStar_Syntax_Syntax.us2 = uu___1; - FStar_Syntax_Syntax.t2 = uu___2;_} - -> - if - FStar_Compiler_List.contains FStar_Syntax_Syntax.Private - quals - then - let uu___3 = FStar_Ident.string_of_lid lid in - FStar_Compiler_Util.smap_remove (sigmap env1) uu___3 - else () - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (uu___1, lbs); - FStar_Syntax_Syntax.lids1 = uu___2;_} - -> - if - FStar_Compiler_List.contains FStar_Syntax_Syntax.Private - quals - then - FStar_Compiler_List.iter - (fun lb -> - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Compiler_Util.right - lb.FStar_Syntax_Syntax.lbname in - uu___6.FStar_Syntax_Syntax.fv_name in - uu___5.FStar_Syntax_Syntax.v in - FStar_Ident.string_of_lid uu___4 in - FStar_Compiler_Util.smap_remove (sigmap env1) uu___3) - lbs - else () - | uu___1 -> ()) modul.FStar_Syntax_Syntax.declarations; - (let curmod = - let uu___1 = current_module env1 in FStar_Ident.string_of_lid uu___1 in - (let uu___2 = - let uu___3 = get_exported_id_set env1 curmod in - let uu___4 = get_trans_exported_id_set env1 curmod in - (uu___3, uu___4) in - match uu___2 with - | (FStar_Pervasives_Native.Some cur_ex, FStar_Pervasives_Native.Some - cur_trans_ex) -> - let update_exports eikind = - let cur_ex_set = - let uu___3 = cur_ex eikind in - FStar_Compiler_Effect.op_Bang uu___3 in - let cur_trans_ex_set_ref = cur_trans_ex eikind in - let uu___3 = - let uu___4 = - FStar_Compiler_Effect.op_Bang cur_trans_ex_set_ref in - Obj.magic - (FStar_Class_Setlike.union () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_string)) - (Obj.magic cur_ex_set) (Obj.magic uu___4)) in - FStar_Compiler_Effect.op_Colon_Equals cur_trans_ex_set_ref - uu___3 in - FStar_Compiler_List.iter update_exports all_exported_id_kinds - | uu___3 -> ()); - (match () with - | () -> - (filter_record_cache (); - (match () with - | () -> - { - curmodule = FStar_Pervasives_Native.None; - curmonad = (env1.curmonad); - modules = (((modul.FStar_Syntax_Syntax.name), modul) :: - (env1.modules)); - scope_mods = []; - exported_ids = (env1.exported_ids); - trans_exported_ids = (env1.trans_exported_ids); - includes = (env1.includes); - sigaccum = []; - sigmap = (env1.sigmap); - iface = (env1.iface); - admitted_iface = (env1.admitted_iface); - expect_typ = (env1.expect_typ); - remaining_iface_decls = (env1.remaining_iface_decls); - syntax_only = (env1.syntax_only); - ds_hooks = (env1.ds_hooks); - dep_graph = (env1.dep_graph) - })))) -let (stack : env Prims.list FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref [] -let (push : env -> env) = - fun env1 -> - FStar_Compiler_Util.atomically - (fun uu___ -> - push_record_cache (); - (let uu___3 = - let uu___4 = FStar_Compiler_Effect.op_Bang stack in env1 :: - uu___4 in - FStar_Compiler_Effect.op_Colon_Equals stack uu___3); - (let uu___3 = FStar_Compiler_Util.smap_copy env1.exported_ids in - let uu___4 = FStar_Compiler_Util.smap_copy env1.trans_exported_ids in - let uu___5 = FStar_Compiler_Util.smap_copy env1.includes in - let uu___6 = FStar_Compiler_Util.smap_copy env1.sigmap in - { - curmodule = (env1.curmodule); - curmonad = (env1.curmonad); - modules = (env1.modules); - scope_mods = (env1.scope_mods); - exported_ids = uu___3; - trans_exported_ids = uu___4; - includes = uu___5; - sigaccum = (env1.sigaccum); - sigmap = uu___6; - iface = (env1.iface); - admitted_iface = (env1.admitted_iface); - expect_typ = (env1.expect_typ); - remaining_iface_decls = (env1.remaining_iface_decls); - syntax_only = (env1.syntax_only); - ds_hooks = (env1.ds_hooks); - dep_graph = (env1.dep_graph) - })) -let (pop : unit -> env) = - fun uu___ -> - FStar_Compiler_Util.atomically - (fun uu___1 -> - let uu___2 = FStar_Compiler_Effect.op_Bang stack in - match uu___2 with - | env1::tl -> - (pop_record_cache (); - FStar_Compiler_Effect.op_Colon_Equals stack tl; - env1) - | uu___3 -> failwith "Impossible: Too many pops") -let (snapshot : env -> (Prims.int * env)) = - fun env1 -> FStar_Common.snapshot push stack env1 -let (rollback : Prims.int FStar_Pervasives_Native.option -> env) = - fun depth -> FStar_Common.rollback pop stack depth -let (export_interface : FStar_Ident.lident -> env -> env) = - fun m -> - fun env1 -> - let sigelt_in_m se = - match FStar_Syntax_Util.lids_of_sigelt se with - | l::uu___ -> - let uu___1 = FStar_Ident.nsstr l in - let uu___2 = FStar_Ident.string_of_lid m in uu___1 = uu___2 - | uu___ -> false in - let sm = sigmap env1 in - let env2 = pop () in - let keys = FStar_Compiler_Util.smap_keys sm in - let sm' = sigmap env2 in - FStar_Compiler_List.iter - (fun k -> - let uu___1 = FStar_Compiler_Util.smap_try_find sm' k in - match uu___1 with - | FStar_Pervasives_Native.Some (se, true) when sigelt_in_m se -> - (FStar_Compiler_Util.smap_remove sm' k; - (let se1 = - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_declare_typ - { FStar_Syntax_Syntax.lid2 = l; - FStar_Syntax_Syntax.us2 = u; - FStar_Syntax_Syntax.t2 = t;_} - -> - { - FStar_Syntax_Syntax.sigel = - (se.FStar_Syntax_Syntax.sigel); - FStar_Syntax_Syntax.sigrng = - (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (FStar_Syntax_Syntax.Assumption :: - (se.FStar_Syntax_Syntax.sigquals)); - FStar_Syntax_Syntax.sigmeta = - (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se.FStar_Syntax_Syntax.sigopts) - } - | uu___3 -> se in - FStar_Compiler_Util.smap_add sm' k (se1, false))) - | uu___2 -> ()) keys; - env2 -let (finish_module_or_interface : - env -> FStar_Syntax_Syntax.modul -> (env * FStar_Syntax_Syntax.modul)) = - fun env1 -> - fun modul -> - let modul1 = - if Prims.op_Negation modul.FStar_Syntax_Syntax.is_interface - then check_admits env1 modul - else modul in - let uu___ = finish env1 modul1 in (uu___, modul1) -type exported_ids = - { - exported_id_terms: string_set ; - exported_id_fields: string_set } -let (__proj__Mkexported_ids__item__exported_id_terms : - exported_ids -> string_set) = - fun projectee -> - match projectee with - | { exported_id_terms; exported_id_fields;_} -> exported_id_terms -let (__proj__Mkexported_ids__item__exported_id_fields : - exported_ids -> string_set) = - fun projectee -> - match projectee with - | { exported_id_terms; exported_id_fields;_} -> exported_id_fields -let (as_exported_ids : exported_id_set -> exported_ids) = - fun e -> - let terms = - let uu___ = e Exported_id_term_type in - FStar_Compiler_Effect.op_Bang uu___ in - let fields = - let uu___ = e Exported_id_field in FStar_Compiler_Effect.op_Bang uu___ in - { exported_id_terms = terms; exported_id_fields = fields } -let (as_exported_id_set : - exported_ids FStar_Pervasives_Native.option -> - exported_id_kind -> string_set FStar_Compiler_Effect.ref) - = - fun e -> - match e with - | FStar_Pervasives_Native.None -> exported_id_set_new () - | FStar_Pervasives_Native.Some e1 -> - let terms = FStar_Compiler_Util.mk_ref e1.exported_id_terms in - let fields = FStar_Compiler_Util.mk_ref e1.exported_id_fields in - (fun uu___ -> - match uu___ with - | Exported_id_term_type -> terms - | Exported_id_field -> fields) -type module_inclusion_info = - { - mii_exported_ids: exported_ids FStar_Pervasives_Native.option ; - mii_trans_exported_ids: exported_ids FStar_Pervasives_Native.option ; - mii_includes: - (FStar_Ident.lident * FStar_Syntax_Syntax.restriction) Prims.list - FStar_Pervasives_Native.option - } -let (__proj__Mkmodule_inclusion_info__item__mii_exported_ids : - module_inclusion_info -> exported_ids FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { mii_exported_ids; mii_trans_exported_ids; mii_includes;_} -> - mii_exported_ids -let (__proj__Mkmodule_inclusion_info__item__mii_trans_exported_ids : - module_inclusion_info -> exported_ids FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { mii_exported_ids; mii_trans_exported_ids; mii_includes;_} -> - mii_trans_exported_ids -let (__proj__Mkmodule_inclusion_info__item__mii_includes : - module_inclusion_info -> - (FStar_Ident.lident * FStar_Syntax_Syntax.restriction) Prims.list - FStar_Pervasives_Native.option) - = - fun projectee -> - match projectee with - | { mii_exported_ids; mii_trans_exported_ids; mii_includes;_} -> - mii_includes -let (default_mii : module_inclusion_info) = - { - mii_exported_ids = FStar_Pervasives_Native.None; - mii_trans_exported_ids = FStar_Pervasives_Native.None; - mii_includes = FStar_Pervasives_Native.None - } -let as_includes : - 'uuuuu . - 'uuuuu Prims.list FStar_Pervasives_Native.option -> - 'uuuuu Prims.list FStar_Compiler_Effect.ref - = - fun uu___ -> - match uu___ with - | FStar_Pervasives_Native.None -> FStar_Compiler_Util.mk_ref [] - | FStar_Pervasives_Native.Some l -> FStar_Compiler_Util.mk_ref l -let (inclusion_info : env -> FStar_Ident.lident -> module_inclusion_info) = - fun env1 -> - fun l -> - let mname = FStar_Ident.string_of_lid l in - let as_ids_opt m = - let uu___ = FStar_Compiler_Util.smap_try_find m mname in - FStar_Compiler_Util.map_opt uu___ as_exported_ids in - let uu___ = as_ids_opt env1.exported_ids in - let uu___1 = as_ids_opt env1.trans_exported_ids in - let uu___2 = - let uu___3 = FStar_Compiler_Util.smap_try_find env1.includes mname in - FStar_Compiler_Util.map_opt uu___3 - (fun r -> FStar_Compiler_Effect.op_Bang r) in - { - mii_exported_ids = uu___; - mii_trans_exported_ids = uu___1; - mii_includes = uu___2 - } -let (prepare_module_or_interface : - Prims.bool -> - Prims.bool -> - env -> - FStar_Ident.lident -> module_inclusion_info -> (env * Prims.bool)) - = - fun intf -> - fun admitted -> - fun env1 -> - fun mname -> - fun mii -> - let prep env2 = - let filename = - let uu___ = FStar_Ident.string_of_lid mname in - FStar_Compiler_Util.strcat uu___ ".fst" in - let auto_open = - FStar_Parser_Dep.hard_coded_dependencies filename in - let auto_open1 = - let convert_kind uu___ = - match uu___ with - | FStar_Parser_Dep.Open_namespace -> - FStar_Syntax_Syntax.Open_namespace - | FStar_Parser_Dep.Open_module -> - FStar_Syntax_Syntax.Open_module in - FStar_Compiler_List.map - (fun uu___ -> - match uu___ with - | (lid, kind) -> - (lid, (convert_kind kind), - FStar_Syntax_Syntax.Unrestricted)) auto_open in - let namespace_of_module = - let uu___ = - let uu___1 = - let uu___2 = FStar_Ident.ns_of_lid mname in - FStar_Compiler_List.length uu___2 in - uu___1 > Prims.int_zero in - if uu___ - then - let uu___1 = - let uu___2 = - let uu___3 = FStar_Ident.ns_of_lid mname in - FStar_Ident.lid_of_ids uu___3 in - (uu___2, FStar_Syntax_Syntax.Open_namespace, - FStar_Syntax_Syntax.Unrestricted) in - [uu___1] - else [] in - let auto_open2 = - FStar_Compiler_List.op_At namespace_of_module - (FStar_Compiler_List.rev auto_open1) in - (let uu___1 = FStar_Ident.string_of_lid mname in - let uu___2 = as_exported_id_set mii.mii_exported_ids in - FStar_Compiler_Util.smap_add env2.exported_ids uu___1 uu___2); - (match () with - | () -> - ((let uu___2 = FStar_Ident.string_of_lid mname in - let uu___3 = - as_exported_id_set mii.mii_trans_exported_ids in - FStar_Compiler_Util.smap_add env2.trans_exported_ids - uu___2 uu___3); - (match () with - | () -> - ((let uu___3 = FStar_Ident.string_of_lid mname in - let uu___4 = as_includes mii.mii_includes in - FStar_Compiler_Util.smap_add env2.includes uu___3 - uu___4); - (match () with - | () -> - let env' = - let uu___3 = - FStar_Compiler_List.map - (fun x -> Open_module_or_namespace x) - auto_open2 in - { - curmodule = - (FStar_Pervasives_Native.Some mname); - curmonad = (env2.curmonad); - modules = (env2.modules); - scope_mods = uu___3; - exported_ids = (env2.exported_ids); - trans_exported_ids = - (env2.trans_exported_ids); - includes = (env2.includes); - sigaccum = (env2.sigaccum); - sigmap = (env2.sigmap); - iface = intf; - admitted_iface = admitted; - expect_typ = (env2.expect_typ); - remaining_iface_decls = - (env2.remaining_iface_decls); - syntax_only = (env2.syntax_only); - ds_hooks = (env2.ds_hooks); - dep_graph = (env2.dep_graph) - } in - (FStar_Compiler_List.iter - (fun op -> - (env2.ds_hooks).ds_push_open_hook env' - op) - (FStar_Compiler_List.rev auto_open2); - env')))))) in - let uu___ = - FStar_Compiler_Util.find_opt - (fun uu___1 -> - match uu___1 with - | (l, uu___2) -> FStar_Ident.lid_equals l mname) - env1.modules in - match uu___ with - | FStar_Pervasives_Native.None -> - let uu___1 = prep env1 in (uu___1, false) - | FStar_Pervasives_Native.Some (uu___1, m) -> - ((let uu___3 = - (let uu___4 = FStar_Options.interactive () in - Prims.op_Negation uu___4) && - ((Prims.op_Negation m.FStar_Syntax_Syntax.is_interface) - || intf) in - if uu___3 - then - let uu___4 = - let uu___5 = FStar_Ident.string_of_lid mname in - FStar_Compiler_Util.format1 - "Duplicate module or interface name: %s" uu___5 in - FStar_Errors.raise_error FStar_Ident.hasrange_lident - mname - FStar_Errors_Codes.Fatal_DuplicateModuleOrInterface () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4) - else ()); - (let uu___3 = let uu___4 = push env1 in prep uu___4 in - (uu___3, true))) -let (enter_monad_scope : env -> FStar_Ident.ident -> env) = - fun env1 -> - fun mname -> - match env1.curmonad with - | FStar_Pervasives_Native.Some mname' -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Ident.showable_ident mname in - let uu___3 = - let uu___4 = - FStar_Class_Show.show FStar_Ident.showable_ident mname' in - Prims.strcat ", but already in monad scope " uu___4 in - Prims.strcat uu___2 uu___3 in - Prims.strcat "Trying to define monad " uu___1 in - FStar_Errors.raise_error FStar_Ident.hasrange_ident mname - FStar_Errors_Codes.Fatal_MonadAlreadyDefined () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___) - | FStar_Pervasives_Native.None -> - { - curmodule = (env1.curmodule); - curmonad = (FStar_Pervasives_Native.Some mname); - modules = (env1.modules); - scope_mods = (env1.scope_mods); - exported_ids = (env1.exported_ids); - trans_exported_ids = (env1.trans_exported_ids); - includes = (env1.includes); - sigaccum = (env1.sigaccum); - sigmap = (env1.sigmap); - iface = (env1.iface); - admitted_iface = (env1.admitted_iface); - expect_typ = (env1.expect_typ); - remaining_iface_decls = (env1.remaining_iface_decls); - syntax_only = (env1.syntax_only); - ds_hooks = (env1.ds_hooks); - dep_graph = (env1.dep_graph) - } -let fail_or : - 'a . - env -> - (FStar_Ident.lident -> 'a FStar_Pervasives_Native.option) -> - FStar_Ident.lident -> 'a - = - fun env1 -> - fun lookup -> - fun lid -> - let uu___ = lookup lid in - match uu___ with - | FStar_Pervasives_Native.Some r -> r - | FStar_Pervasives_Native.None -> - let opened_modules = - FStar_Compiler_List.map - (fun uu___1 -> - match uu___1 with - | (lid1, uu___2) -> FStar_Ident.string_of_lid lid1) - env1.modules in - let msg = - let uu___1 = - let uu___2 = FStar_Ident.string_of_lid lid in - FStar_Compiler_Util.format1 "Identifier not found: [%s]" - uu___2 in - FStar_Errors_Msg.mkmsg uu___1 in - let msg1 = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Ident.ns_of_lid lid in - FStar_Compiler_List.length uu___3 in - uu___2 = Prims.int_zero in - if uu___1 - then msg - else - (let modul = - let uu___3 = - let uu___4 = FStar_Ident.ns_of_lid lid in - FStar_Ident.lid_of_ids uu___4 in - let uu___4 = FStar_Ident.range_of_lid lid in - FStar_Ident.set_lid_range uu___3 uu___4 in - let subdoc d = - let uu___3 = - let uu___4 = FStar_Pprint.align d in - FStar_Pprint.op_Hat_Hat FStar_Pprint.hardline uu___4 in - FStar_Pprint.nest (Prims.of_int (2)) uu___3 in - let uu___3 = resolve_module_name env1 modul true in - match uu___3 with - | FStar_Pervasives_Native.None -> - let opened_modules1 = - FStar_Errors_Msg.text - (FStar_Compiler_String.concat ", " opened_modules) in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = FStar_Ident.string_of_lid modul in - FStar_Compiler_Util.format1 - "Could not resolve module name %s" uu___7 in - FStar_Errors_Msg.text uu___6 in - [uu___5] in - FStar_Compiler_List.op_At msg uu___4 - | FStar_Pervasives_Native.Some modul' when - let uu___4 = - FStar_Compiler_List.existsb - (fun m -> - let uu___5 = FStar_Ident.string_of_lid modul' in - m = uu___5) opened_modules in - Prims.op_Negation uu___4 -> - let opened_modules1 = - FStar_Errors_Msg.text - (FStar_Compiler_String.concat ", " opened_modules) in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = FStar_Ident.string_of_lid modul in - let uu___9 = FStar_Ident.string_of_lid modul' in - FStar_Compiler_Util.format2 - "Module %s resolved into %s, which does not belong to the list of modules in scope, namely:" - uu___8 uu___9 in - FStar_Errors_Msg.text uu___7 in - let uu___7 = subdoc opened_modules1 in - FStar_Pprint.op_Hat_Hat uu___6 uu___7 in - [uu___5] in - FStar_Compiler_List.op_At msg uu___4 - | FStar_Pervasives_Native.Some modul' -> - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = FStar_Ident.string_of_lid modul in - let uu___8 = FStar_Ident.string_of_lid modul' in - let uu___9 = - let uu___10 = FStar_Ident.ident_of_lid lid in - FStar_Ident.string_of_id uu___10 in - FStar_Compiler_Util.format3 - "Module %s resolved into %s, definition %s not found" - uu___7 uu___8 uu___9 in - FStar_Errors_Msg.text uu___6 in - [uu___5] in - FStar_Compiler_List.op_At msg uu___4) in - FStar_Errors.raise_error FStar_Ident.hasrange_lident lid - FStar_Errors_Codes.Fatal_IdentifierNotFound () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic msg1) -let fail_or2 : - 'a . - (FStar_Ident.ident -> 'a FStar_Pervasives_Native.option) -> - FStar_Ident.ident -> 'a - = - fun lookup -> - fun id -> - let uu___ = lookup id in - match uu___ with - | FStar_Pervasives_Native.None -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Ident.string_of_id id in - Prims.strcat uu___3 "]" in - Prims.strcat "Identifier not found [" uu___2 in - FStar_Errors.raise_error FStar_Ident.hasrange_ident id - FStar_Errors_Codes.Fatal_IdentifierNotFound () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) - | FStar_Pervasives_Native.Some r -> r -let (resolve_name : - env -> - FStar_Ident.lident -> - (FStar_Syntax_Syntax.bv, FStar_Syntax_Syntax.fv) - FStar_Pervasives.either FStar_Pervasives_Native.option) - = - fun e -> - fun name -> - let uu___ = try_lookup_name false false e name in - match uu___ with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (Term_name (e1, attrs)) -> - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress e1 in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_name n -> - FStar_Pervasives_Native.Some (FStar_Pervasives.Inl n) - | FStar_Syntax_Syntax.Tm_fvar fv -> - FStar_Pervasives_Native.Some (FStar_Pervasives.Inr fv) - | uu___2 -> FStar_Pervasives_Native.None) - | FStar_Pervasives_Native.Some (Eff_name (se, l)) -> - let uu___1 = - let uu___2 = - FStar_Syntax_Syntax.lid_and_dd_as_fv l - FStar_Pervasives_Native.None in - FStar_Pervasives.Inr uu___2 in - FStar_Pervasives_Native.Some uu___1 \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_Embeddings.ml b/ocaml/fstar-lib/generated/FStar_Syntax_Embeddings.ml deleted file mode 100644 index 40309a081c7..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Syntax_Embeddings.ml +++ /dev/null @@ -1,3183 +0,0 @@ -open Prims -let (id_norm_cb : FStar_Syntax_Embeddings_Base.norm_cb) = - fun uu___ -> - match uu___ with - | FStar_Pervasives.Inr x -> x - | FStar_Pervasives.Inl l -> - let uu___1 = - FStar_Syntax_Syntax.lid_as_fv l FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___1 -exception Embedding_failure -let (uu___is_Embedding_failure : Prims.exn -> Prims.bool) = - fun projectee -> - match projectee with | Embedding_failure -> true | uu___ -> false -exception Unembedding_failure -let (uu___is_Unembedding_failure : Prims.exn -> Prims.bool) = - fun projectee -> - match projectee with | Unembedding_failure -> true | uu___ -> false -let (map_shadow : - FStar_Syntax_Embeddings_Base.shadow_term -> - (FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) -> - FStar_Syntax_Embeddings_Base.shadow_term) - = fun s -> fun f -> FStar_Compiler_Util.map_opt s (FStar_Thunk.map f) -let (force_shadow : - FStar_Syntax_Embeddings_Base.shadow_term -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = fun s -> FStar_Compiler_Util.map_opt s FStar_Thunk.force -type 'a printer = 'a -> Prims.string -let unknown_printer : - 'uuuuu . FStar_Syntax_Syntax.typ -> 'uuuuu -> Prims.string = - fun typ -> - fun uu___ -> - let uu___1 = FStar_Class_Show.show FStar_Syntax_Print.showable_term typ in - FStar_Compiler_Util.format1 "unknown %s" uu___1 -let (term_as_fv : FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.fv) = - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_fvar fv -> fv - | uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.format1 "Embeddings not defined for type %s" - uu___3 in - failwith uu___2 -let lazy_embed : - 'a . - 'a printer -> - (unit -> FStar_Syntax_Syntax.emb_typ) -> - FStar_Compiler_Range_Type.range -> - (unit -> FStar_Syntax_Syntax.term) -> - 'a -> - (unit -> FStar_Syntax_Syntax.term) -> FStar_Syntax_Syntax.term - = - fun pa -> - fun et -> - fun rng -> - fun ta -> - fun x -> - fun f -> - (let uu___1 = - FStar_Compiler_Effect.op_Bang FStar_Options.debug_embedding in - if uu___1 - then - let uu___2 = - let uu___3 = ta () in - FStar_Class_Show.show FStar_Syntax_Print.showable_term - uu___3 in - let uu___3 = - let uu___4 = et () in - FStar_Class_Show.show FStar_Syntax_Syntax.showable_emb_typ - uu___4 in - let uu___4 = pa x in - FStar_Compiler_Util.print3 - "Embedding a %s\n\temb_typ=%s\n\tvalue is %s\n" uu___2 - uu___3 uu___4 - else ()); - (let uu___1 = - FStar_Compiler_Effect.op_Bang FStar_Options.eager_embedding in - if uu___1 - then f () - else - (let thunk = FStar_Thunk.mk f in - let uu___3 = - let uu___4 = let uu___5 = et () in (uu___5, thunk) in - FStar_Syntax_Syntax.Lazy_embedding uu___4 in - FStar_Syntax_Util.mk_lazy x FStar_Syntax_Syntax.tun uu___3 - (FStar_Pervasives_Native.Some rng))) -let lazy_unembed : - 'a . - 'a printer -> - (unit -> FStar_Syntax_Syntax.emb_typ) -> - FStar_Syntax_Syntax.term -> - (unit -> FStar_Syntax_Syntax.term) -> - (FStar_Syntax_Syntax.term -> 'a FStar_Pervasives_Native.option) - -> 'a FStar_Pervasives_Native.option - = - fun pa -> - fun et -> - fun x -> - fun ta -> - fun f -> - let et1 = et () in - let x1 = FStar_Syntax_Embeddings_Base.unmeta_div_results x in - match x1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_lazy - { FStar_Syntax_Syntax.blob = b; - FStar_Syntax_Syntax.lkind = - FStar_Syntax_Syntax.Lazy_embedding (et', t); - FStar_Syntax_Syntax.ltyp = uu___; - FStar_Syntax_Syntax.rng = uu___1;_} - -> - let uu___2 = - (et1 <> et') || - (FStar_Compiler_Effect.op_Bang - FStar_Options.eager_embedding) in - if uu___2 - then - let res = let uu___3 = FStar_Thunk.force t in f uu___3 in - ((let uu___4 = - FStar_Compiler_Effect.op_Bang - FStar_Options.debug_embedding in - if uu___4 - then - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Syntax.showable_emb_typ et1 in - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Syntax.showable_emb_typ et' in - let uu___7 = - match res with - | FStar_Pervasives_Native.None -> "None" - | FStar_Pervasives_Native.Some x2 -> - let uu___8 = pa x2 in Prims.strcat "Some " uu___8 in - FStar_Compiler_Util.print3 - "Unembed cancellation failed\n\t%s <> %s\nvalue is %s\n" - uu___5 uu___6 uu___7 - else ()); - res) - else - (let a1 = FStar_Dyn.undyn b in - (let uu___5 = - FStar_Compiler_Effect.op_Bang - FStar_Options.debug_embedding in - if uu___5 - then - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Syntax.showable_emb_typ et1 in - let uu___7 = pa a1 in - FStar_Compiler_Util.print2 - "Unembed cancelled for %s\n\tvalue is %s\n" uu___6 - uu___7 - else ()); - FStar_Pervasives_Native.Some a1) - | uu___ -> - let aopt = f x1 in - ((let uu___2 = - FStar_Compiler_Effect.op_Bang - FStar_Options.debug_embedding in - if uu___2 - then - let uu___3 = - FStar_Class_Show.show - FStar_Syntax_Syntax.showable_emb_typ et1 in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - x1 in - let uu___5 = - match aopt with - | FStar_Pervasives_Native.None -> "None" - | FStar_Pervasives_Native.Some a1 -> - let uu___6 = pa a1 in Prims.strcat "Some " uu___6 in - FStar_Compiler_Util.print3 - "Unembedding:\n\temb_typ=%s\n\tterm is %s\n\tvalue is %s\n" - uu___3 uu___4 uu___5 - else ()); - aopt) -let (mk_any_emb : - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.term FStar_Syntax_Embeddings_Base.embedding) - = - fun typ -> - let em t _r _shadow _norm = - (let uu___1 = - FStar_Compiler_Effect.op_Bang FStar_Options.debug_embedding in - if uu___1 - then - let uu___2 = unknown_printer typ t in - FStar_Compiler_Util.print1 "Embedding abstract: %s\n" uu___2 - else ()); - t in - let un t _n = - (let uu___1 = - FStar_Compiler_Effect.op_Bang FStar_Options.debug_embedding in - if uu___1 - then - let uu___2 = unknown_printer typ t in - FStar_Compiler_Util.print1 "Unembedding abstract: %s\n" uu___2 - else ()); - FStar_Pervasives_Native.Some t in - FStar_Syntax_Embeddings_Base.mk_emb_full em un (fun uu___ -> typ) - (unknown_printer typ) (fun uu___ -> FStar_Syntax_Syntax.ET_abstract) -let (e_any : FStar_Syntax_Syntax.term FStar_Syntax_Embeddings_Base.embedding) - = - let em t r _shadow _norm = - { - FStar_Syntax_Syntax.n = (t.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = r; - FStar_Syntax_Syntax.vars = (t.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = (t.FStar_Syntax_Syntax.hash_code) - } in - let un t _n = FStar_Pervasives_Native.Some t in - FStar_Syntax_Embeddings_Base.mk_emb_full em un - (fun uu___ -> FStar_Syntax_Syntax.t_term) - (FStar_Class_Show.show FStar_Syntax_Print.showable_term) - (fun uu___ -> - let uu___1 = - let uu___2 = FStar_Ident.string_of_lid FStar_Parser_Const.term_lid in - (uu___2, []) in - FStar_Syntax_Syntax.ET_app uu___1) -let (e_unit : unit FStar_Syntax_Embeddings_Base.embedding) = - let em u rng _shadow _norm = - { - FStar_Syntax_Syntax.n = - (FStar_Syntax_Util.exp_unit.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = rng; - FStar_Syntax_Syntax.vars = - (FStar_Syntax_Util.exp_unit.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (FStar_Syntax_Util.exp_unit.FStar_Syntax_Syntax.hash_code) - } in - let un t0 _norm = - let t = FStar_Syntax_Util.unascribe t0 in - match t.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_unit) -> - FStar_Pervasives_Native.Some () - | uu___ -> FStar_Pervasives_Native.None in - FStar_Syntax_Embeddings_Base.mk_emb_full em un - (fun uu___ -> FStar_Syntax_Syntax.t_unit) (fun uu___ -> "()") - (fun uu___ -> - let uu___1 = - let uu___2 = FStar_Ident.string_of_lid FStar_Parser_Const.unit_lid in - (uu___2, []) in - FStar_Syntax_Syntax.ET_app uu___1) -let (e_bool : Prims.bool FStar_Syntax_Embeddings_Base.embedding) = - let em b rng _shadow _norm = - let t = - if b - then FStar_Syntax_Util.exp_true_bool - else FStar_Syntax_Util.exp_false_bool in - { - FStar_Syntax_Syntax.n = (t.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = rng; - FStar_Syntax_Syntax.vars = (t.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = (t.FStar_Syntax_Syntax.hash_code) - } in - let un t _norm = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_bool b) -> - FStar_Pervasives_Native.Some b - | uu___1 -> FStar_Pervasives_Native.None in - FStar_Syntax_Embeddings_Base.mk_emb_full em un - (fun uu___ -> FStar_Syntax_Syntax.t_bool) - FStar_Compiler_Util.string_of_bool - (fun uu___ -> - let uu___1 = - let uu___2 = FStar_Ident.string_of_lid FStar_Parser_Const.bool_lid in - (uu___2, []) in - FStar_Syntax_Syntax.ET_app uu___1) -let (e_char : FStar_Char.char FStar_Syntax_Embeddings_Base.embedding) = - let em c rng _shadow _norm = - let t = FStar_Syntax_Util.exp_char c in - { - FStar_Syntax_Syntax.n = (t.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = rng; - FStar_Syntax_Syntax.vars = (t.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = (t.FStar_Syntax_Syntax.hash_code) - } in - let un t _norm = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_char c) -> - FStar_Pervasives_Native.Some c - | uu___1 -> FStar_Pervasives_Native.None in - FStar_Syntax_Embeddings_Base.mk_emb_full em un - (fun uu___ -> FStar_Syntax_Syntax.t_char) - FStar_Compiler_Util.string_of_char - (fun uu___ -> - let uu___1 = - let uu___2 = FStar_Ident.string_of_lid FStar_Parser_Const.char_lid in - (uu___2, []) in - FStar_Syntax_Syntax.ET_app uu___1) -let (e_int : FStar_BigInt.t FStar_Syntax_Embeddings_Base.embedding) = - let ty = FStar_Syntax_Syntax.t_int in - let emb_t_int = - let uu___ = - let uu___1 = FStar_Ident.string_of_lid FStar_Parser_Const.int_lid in - (uu___1, []) in - FStar_Syntax_Syntax.ET_app uu___ in - let em i rng _shadow _norm = - lazy_embed FStar_BigInt.string_of_big_int (fun uu___ -> emb_t_int) rng - (fun uu___ -> ty) i - (fun uu___ -> - let uu___1 = FStar_BigInt.string_of_big_int i in - FStar_Syntax_Util.exp_int uu___1) in - let un t _norm = - lazy_unembed FStar_BigInt.string_of_big_int (fun uu___ -> emb_t_int) t - (fun uu___ -> ty) - (fun t1 -> - match t1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_int (s, uu___)) - -> - let uu___1 = FStar_BigInt.big_int_of_string s in - FStar_Pervasives_Native.Some uu___1 - | uu___ -> FStar_Pervasives_Native.None) in - FStar_Syntax_Embeddings_Base.mk_emb_full em un (fun uu___ -> ty) - FStar_BigInt.string_of_big_int (fun uu___ -> emb_t_int) -let (e_fsint : Prims.int FStar_Syntax_Embeddings_Base.embedding) = - FStar_Syntax_Embeddings_Base.embed_as e_int FStar_BigInt.to_int_fs - FStar_BigInt.of_int_fs FStar_Pervasives_Native.None -let (e_string : Prims.string FStar_Syntax_Embeddings_Base.embedding) = - let emb_t_string = - let uu___ = - let uu___1 = FStar_Ident.string_of_lid FStar_Parser_Const.string_lid in - (uu___1, []) in - FStar_Syntax_Syntax.ET_app uu___ in - let em s rng _shadow _norm = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_string (s, rng))) - rng in - let un t _norm = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_string (s, uu___1)) - -> FStar_Pervasives_Native.Some s - | uu___1 -> FStar_Pervasives_Native.None in - FStar_Syntax_Embeddings_Base.mk_emb_full em un - (fun uu___ -> FStar_Syntax_Syntax.t_string) - (fun x -> Prims.strcat "\"" (Prims.strcat x "\"")) - (fun uu___ -> emb_t_string) -let (e_real : - FStar_Compiler_Real.real FStar_Syntax_Embeddings_Base.embedding) = - let ty = FStar_Syntax_Syntax.t_real in - let emb_t_real = - let uu___ = - let uu___1 = FStar_Ident.string_of_lid FStar_Parser_Const.real_lid in - (uu___1, []) in - FStar_Syntax_Syntax.ET_app uu___ in - let em r rng _shadow _norm = - let uu___ = r in - match uu___ with - | FStar_Compiler_Real.Real s -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_real s)) rng in - let un t _norm = - let uu___ = - let uu___1 = FStar_Syntax_Embeddings_Base.unmeta_div_results t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_real s) -> - FStar_Pervasives_Native.Some (FStar_Compiler_Real.Real s) - | uu___1 -> FStar_Pervasives_Native.None in - FStar_Syntax_Embeddings_Base.mk_emb_full em un (fun uu___ -> ty) - (fun uu___ -> "") (fun uu___ -> emb_t_real) -let e_option : - 'a . - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'a FStar_Pervasives_Native.option - FStar_Syntax_Embeddings_Base.embedding - = - fun ea -> - let typ uu___ = - let uu___1 = FStar_Syntax_Embeddings_Base.type_of ea in - FStar_Syntax_Syntax.t_option_of uu___1 in - let emb_t_option_a uu___ = - let uu___1 = - let uu___2 = FStar_Ident.string_of_lid FStar_Parser_Const.option_lid in - let uu___3 = - let uu___4 = FStar_Syntax_Embeddings_Base.emb_typ_of ea () in - [uu___4] in - (uu___2, uu___3) in - FStar_Syntax_Syntax.ET_app uu___1 in - let printer1 x = - let uu___ = FStar_Syntax_Embeddings_Base.printer_of ea in - FStar_Common.string_of_option uu___ x in - let em o rng shadow norm = - lazy_embed printer1 emb_t_option_a rng - (fun uu___ -> - let uu___1 = FStar_Syntax_Embeddings_Base.type_of ea in - FStar_Syntax_Syntax.t_option_of uu___1) o - (fun uu___ -> - match o with - | FStar_Pervasives_Native.None -> - let uu___1 = - let uu___2 = - FStar_Syntax_Syntax.tdataconstr - FStar_Parser_Const.none_lid in - FStar_Syntax_Syntax.mk_Tm_uinst uu___2 - [FStar_Syntax_Syntax.U_zero] in - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Embeddings_Base.type_of ea in - FStar_Syntax_Syntax.iarg uu___4 in - [uu___3] in - FStar_Syntax_Syntax.mk_Tm_app uu___1 uu___2 rng - | FStar_Pervasives_Native.Some a1 -> - let shadow_a = - map_shadow shadow - (fun t -> - let v = FStar_Ident.mk_ident ("v", rng) in - let some_v = - FStar_Syntax_Util.mk_field_projector_name_from_ident - FStar_Parser_Const.some_lid v in - let some_v_tm = - let uu___1 = - FStar_Syntax_Syntax.lid_as_fv some_v - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___1 in - let uu___1 = - FStar_Syntax_Syntax.mk_Tm_uinst some_v_tm - [FStar_Syntax_Syntax.U_zero] in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Syntax_Embeddings_Base.type_of ea in - FStar_Syntax_Syntax.iarg uu___4 in - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.as_arg t in - [uu___5] in - uu___3 :: uu___4 in - FStar_Syntax_Syntax.mk_Tm_app uu___1 uu___2 rng) in - let uu___1 = - let uu___2 = - FStar_Syntax_Syntax.tdataconstr - FStar_Parser_Const.some_lid in - FStar_Syntax_Syntax.mk_Tm_uinst uu___2 - [FStar_Syntax_Syntax.U_zero] in - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Embeddings_Base.type_of ea in - FStar_Syntax_Syntax.iarg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = FStar_Syntax_Embeddings_Base.embed ea a1 in - uu___7 rng shadow_a norm in - FStar_Syntax_Syntax.as_arg uu___6 in - [uu___5] in - uu___3 :: uu___4 in - FStar_Syntax_Syntax.mk_Tm_app uu___1 uu___2 rng) in - let un t norm = - lazy_unembed printer1 emb_t_option_a t - (fun uu___ -> - let uu___1 = FStar_Syntax_Embeddings_Base.type_of ea in - FStar_Syntax_Syntax.t_option_of uu___1) - (fun t1 -> - let uu___ = FStar_Syntax_Util.head_and_args_full t1 in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst hd in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, uu___2) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.none_lid - -> - FStar_Pervasives_Native.Some FStar_Pervasives_Native.None - | (FStar_Syntax_Syntax.Tm_fvar fv, uu___2::(a1, uu___3)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.some_lid - -> - let uu___4 = - FStar_Syntax_Embeddings_Base.try_unembed ea a1 norm in - FStar_Compiler_Util.bind_opt uu___4 - (fun a2 -> - FStar_Pervasives_Native.Some - (FStar_Pervasives_Native.Some a2)) - | uu___2 -> FStar_Pervasives_Native.None)) in - FStar_Syntax_Embeddings_Base.mk_emb_full em un typ printer1 - emb_t_option_a -let e_tuple2 : - 'a 'b . - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'b FStar_Syntax_Embeddings_Base.embedding -> - ('a * 'b) FStar_Syntax_Embeddings_Base.embedding - = - fun ea -> - fun eb -> - let typ uu___ = - let uu___1 = FStar_Syntax_Embeddings_Base.type_of ea in - let uu___2 = FStar_Syntax_Embeddings_Base.type_of eb in - FStar_Syntax_Syntax.t_tuple2_of uu___1 uu___2 in - let emb_t_pair uu___ = - let uu___1 = - let uu___2 = - FStar_Ident.string_of_lid FStar_Parser_Const.lid_tuple2 in - let uu___3 = - let uu___4 = FStar_Syntax_Embeddings_Base.emb_typ_of ea () in - let uu___5 = - let uu___6 = FStar_Syntax_Embeddings_Base.emb_typ_of eb () in - [uu___6] in - uu___4 :: uu___5 in - (uu___2, uu___3) in - FStar_Syntax_Syntax.ET_app uu___1 in - let printer1 uu___ = - match uu___ with - | (x, y) -> - let uu___1 = - let uu___2 = FStar_Syntax_Embeddings_Base.printer_of ea in - uu___2 x in - let uu___2 = - let uu___3 = FStar_Syntax_Embeddings_Base.printer_of eb in - uu___3 y in - FStar_Compiler_Util.format2 "(%s, %s)" uu___1 uu___2 in - let em x rng shadow norm = - lazy_embed printer1 emb_t_pair rng typ x - (fun uu___ -> - let proj i ab = - let proj_1 = - let uu___1 = - FStar_Parser_Const.mk_tuple_data_lid (Prims.of_int (2)) - rng in - let uu___2 = - FStar_Syntax_Syntax.null_bv FStar_Syntax_Syntax.tun in - FStar_Syntax_Util.mk_field_projector_name uu___1 uu___2 i in - let proj_1_tm = - let uu___1 = - FStar_Syntax_Syntax.lid_as_fv proj_1 - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___1 in - let uu___1 = - FStar_Syntax_Syntax.mk_Tm_uinst proj_1_tm - [FStar_Syntax_Syntax.U_zero] in - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Embeddings_Base.type_of ea in - FStar_Syntax_Syntax.iarg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = FStar_Syntax_Embeddings_Base.type_of eb in - FStar_Syntax_Syntax.iarg uu___6 in - let uu___6 = - let uu___7 = FStar_Syntax_Syntax.as_arg ab in [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - FStar_Syntax_Syntax.mk_Tm_app uu___1 uu___2 rng in - let shadow_a = map_shadow shadow (proj Prims.int_one) in - let shadow_b = map_shadow shadow (proj (Prims.of_int (2))) in - let uu___1 = - let uu___2 = - FStar_Syntax_Syntax.tdataconstr - FStar_Parser_Const.lid_Mktuple2 in - FStar_Syntax_Syntax.mk_Tm_uinst uu___2 - [FStar_Syntax_Syntax.U_zero; FStar_Syntax_Syntax.U_zero] in - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Embeddings_Base.type_of ea in - FStar_Syntax_Syntax.iarg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = FStar_Syntax_Embeddings_Base.type_of eb in - FStar_Syntax_Syntax.iarg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Syntax_Embeddings_Base.embed ea - (FStar_Pervasives_Native.fst x) in - uu___9 rng shadow_a norm in - FStar_Syntax_Syntax.as_arg uu___8 in - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Syntax_Embeddings_Base.embed eb - (FStar_Pervasives_Native.snd x) in - uu___11 rng shadow_b norm in - FStar_Syntax_Syntax.as_arg uu___10 in - [uu___9] in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - FStar_Syntax_Syntax.mk_Tm_app uu___1 uu___2 rng) in - let un t norm = - lazy_unembed printer1 emb_t_pair t typ - (fun uu___ -> - (fun t1 -> - let uu___ = FStar_Syntax_Util.head_and_args_full t1 in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst hd in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, - uu___2::uu___3::(a1, uu___4)::(b1, uu___5)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.lid_Mktuple2 - -> - Obj.magic - (Obj.repr - (let uu___6 = - FStar_Syntax_Embeddings_Base.try_unembed ea - a1 norm in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic uu___6) - (fun uu___7 -> - (fun a2 -> - let a2 = Obj.magic a2 in - let uu___7 = - FStar_Syntax_Embeddings_Base.try_unembed - eb b1 norm in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () - () (Obj.magic uu___7) - (fun uu___8 -> - (fun b2 -> - let b2 = Obj.magic b2 in - Obj.magic - (FStar_Pervasives_Native.Some - (a2, b2))) uu___8))) - uu___7))) - | uu___2 -> - Obj.magic (Obj.repr FStar_Pervasives_Native.None))) - uu___) in - FStar_Syntax_Embeddings_Base.mk_emb_full em un typ printer1 emb_t_pair -let e_tuple3 : - 'a 'b 'c . - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'b FStar_Syntax_Embeddings_Base.embedding -> - 'c FStar_Syntax_Embeddings_Base.embedding -> - ('a * 'b * 'c) FStar_Syntax_Embeddings_Base.embedding - = - fun ea -> - fun eb -> - fun ec -> - let typ uu___ = - let uu___1 = FStar_Syntax_Embeddings_Base.type_of ea in - let uu___2 = FStar_Syntax_Embeddings_Base.type_of eb in - let uu___3 = FStar_Syntax_Embeddings_Base.type_of ec in - FStar_Syntax_Syntax.t_tuple3_of uu___1 uu___2 uu___3 in - let emb_t_pair uu___ = - let uu___1 = - let uu___2 = - FStar_Ident.string_of_lid FStar_Parser_Const.lid_tuple3 in - let uu___3 = - let uu___4 = FStar_Syntax_Embeddings_Base.emb_typ_of ea () in - let uu___5 = - let uu___6 = FStar_Syntax_Embeddings_Base.emb_typ_of eb () in - let uu___7 = - let uu___8 = FStar_Syntax_Embeddings_Base.emb_typ_of ec () in - [uu___8] in - uu___6 :: uu___7 in - uu___4 :: uu___5 in - (uu___2, uu___3) in - FStar_Syntax_Syntax.ET_app uu___1 in - let printer1 uu___ = - match uu___ with - | (x, y, z) -> - let uu___1 = - let uu___2 = FStar_Syntax_Embeddings_Base.printer_of ea in - uu___2 x in - let uu___2 = - let uu___3 = FStar_Syntax_Embeddings_Base.printer_of eb in - uu___3 y in - let uu___3 = - let uu___4 = FStar_Syntax_Embeddings_Base.printer_of ec in - uu___4 z in - FStar_Compiler_Util.format3 "(%s, %s, %s)" uu___1 uu___2 uu___3 in - let em uu___ rng shadow norm = - match uu___ with - | (x1, x2, x3) -> - lazy_embed printer1 emb_t_pair rng typ (x1, x2, x3) - (fun uu___1 -> - let proj i abc = - let proj_i = - let uu___2 = - FStar_Parser_Const.mk_tuple_data_lid - (Prims.of_int (3)) rng in - let uu___3 = - FStar_Syntax_Syntax.null_bv FStar_Syntax_Syntax.tun in - FStar_Syntax_Util.mk_field_projector_name uu___2 - uu___3 i in - let proj_i_tm = - let uu___2 = - FStar_Syntax_Syntax.lid_as_fv proj_i - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___2 in - let uu___2 = - FStar_Syntax_Syntax.mk_Tm_uinst proj_i_tm - [FStar_Syntax_Syntax.U_zero] in - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Embeddings_Base.type_of ea in - FStar_Syntax_Syntax.iarg uu___5 in - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Syntax_Embeddings_Base.type_of eb in - FStar_Syntax_Syntax.iarg uu___7 in - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Syntax_Embeddings_Base.type_of ec in - FStar_Syntax_Syntax.iarg uu___9 in - let uu___9 = - let uu___10 = FStar_Syntax_Syntax.as_arg abc in - [uu___10] in - uu___8 :: uu___9 in - uu___6 :: uu___7 in - uu___4 :: uu___5 in - FStar_Syntax_Syntax.mk_Tm_app uu___2 uu___3 rng in - let shadow_a = map_shadow shadow (proj Prims.int_one) in - let shadow_b = map_shadow shadow (proj (Prims.of_int (2))) in - let shadow_c = map_shadow shadow (proj (Prims.of_int (3))) in - let uu___2 = - let uu___3 = - FStar_Syntax_Syntax.tdataconstr - FStar_Parser_Const.lid_Mktuple3 in - FStar_Syntax_Syntax.mk_Tm_uinst uu___3 - [FStar_Syntax_Syntax.U_zero; - FStar_Syntax_Syntax.U_zero; - FStar_Syntax_Syntax.U_zero] in - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Embeddings_Base.type_of ea in - FStar_Syntax_Syntax.iarg uu___5 in - let uu___5 = - let uu___6 = - let uu___7 = FStar_Syntax_Embeddings_Base.type_of eb in - FStar_Syntax_Syntax.iarg uu___7 in - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Syntax_Embeddings_Base.type_of ec in - FStar_Syntax_Syntax.iarg uu___9 in - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Syntax_Embeddings_Base.embed ea x1 in - uu___12 rng shadow_a norm in - FStar_Syntax_Syntax.as_arg uu___11 in - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - FStar_Syntax_Embeddings_Base.embed eb x2 in - uu___14 rng shadow_b norm in - FStar_Syntax_Syntax.as_arg uu___13 in - let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = - FStar_Syntax_Embeddings_Base.embed ec x3 in - uu___16 rng shadow_c norm in - FStar_Syntax_Syntax.as_arg uu___15 in - [uu___14] in - uu___12 :: uu___13 in - uu___10 :: uu___11 in - uu___8 :: uu___9 in - uu___6 :: uu___7 in - uu___4 :: uu___5 in - FStar_Syntax_Syntax.mk_Tm_app uu___2 uu___3 rng) in - let un t norm = - lazy_unembed printer1 emb_t_pair t typ - (fun uu___ -> - (fun t1 -> - let uu___ = FStar_Syntax_Util.head_and_args_full t1 in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst hd in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, - uu___2::uu___3::uu___4::(a1, uu___5)::(b1, uu___6):: - (c1, uu___7)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.lid_Mktuple3 - -> - Obj.magic - (Obj.repr - (let uu___8 = - FStar_Syntax_Embeddings_Base.try_unembed - ea a1 norm in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic uu___8) - (fun uu___9 -> - (fun a2 -> - let a2 = Obj.magic a2 in - let uu___9 = - FStar_Syntax_Embeddings_Base.try_unembed - eb b1 norm in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () (Obj.magic uu___9) - (fun uu___10 -> - (fun b2 -> - let b2 = Obj.magic b2 in - let uu___10 = - FStar_Syntax_Embeddings_Base.try_unembed - ec c1 norm in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () - (Obj.magic uu___10) - (fun uu___11 -> - (fun c2 -> - let c2 = - Obj.magic c2 in - Obj.magic - (FStar_Pervasives_Native.Some - (a2, b2, - c2))) - uu___11))) - uu___10))) uu___9))) - | uu___2 -> - Obj.magic (Obj.repr FStar_Pervasives_Native.None))) - uu___) in - FStar_Syntax_Embeddings_Base.mk_emb_full em un typ printer1 - emb_t_pair -let e_tuple4 : - 'a 'b 'c 'd . - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'b FStar_Syntax_Embeddings_Base.embedding -> - 'c FStar_Syntax_Embeddings_Base.embedding -> - 'd FStar_Syntax_Embeddings_Base.embedding -> - ('a * 'b * 'c * 'd) FStar_Syntax_Embeddings_Base.embedding - = - fun ea -> - fun eb -> - fun ec -> - fun ed -> - let typ uu___ = - let uu___1 = FStar_Syntax_Embeddings_Base.type_of ea in - let uu___2 = FStar_Syntax_Embeddings_Base.type_of eb in - let uu___3 = FStar_Syntax_Embeddings_Base.type_of ec in - let uu___4 = FStar_Syntax_Embeddings_Base.type_of ed in - FStar_Syntax_Syntax.t_tuple4_of uu___1 uu___2 uu___3 uu___4 in - let emb_t_pair uu___ = - let uu___1 = - let uu___2 = - FStar_Ident.string_of_lid FStar_Parser_Const.lid_tuple4 in - let uu___3 = - let uu___4 = FStar_Syntax_Embeddings_Base.emb_typ_of ea () in - let uu___5 = - let uu___6 = FStar_Syntax_Embeddings_Base.emb_typ_of eb () in - let uu___7 = - let uu___8 = - FStar_Syntax_Embeddings_Base.emb_typ_of ec () in - let uu___9 = - let uu___10 = - FStar_Syntax_Embeddings_Base.emb_typ_of ed () in - [uu___10] in - uu___8 :: uu___9 in - uu___6 :: uu___7 in - uu___4 :: uu___5 in - (uu___2, uu___3) in - FStar_Syntax_Syntax.ET_app uu___1 in - let printer1 uu___ = - match uu___ with - | (x, y, z, w) -> - let uu___1 = - let uu___2 = FStar_Syntax_Embeddings_Base.printer_of ea in - uu___2 x in - let uu___2 = - let uu___3 = FStar_Syntax_Embeddings_Base.printer_of eb in - uu___3 y in - let uu___3 = - let uu___4 = FStar_Syntax_Embeddings_Base.printer_of ec in - uu___4 z in - let uu___4 = - let uu___5 = FStar_Syntax_Embeddings_Base.printer_of ed in - uu___5 w in - FStar_Compiler_Util.format4 "(%s, %s, %s, %s)" uu___1 uu___2 - uu___3 uu___4 in - let em uu___ rng shadow norm = - match uu___ with - | (x1, x2, x3, x4) -> - lazy_embed printer1 emb_t_pair rng typ (x1, x2, x3, x4) - (fun uu___1 -> - let proj i abcd = - let proj_i = - let uu___2 = - FStar_Parser_Const.mk_tuple_data_lid - (Prims.of_int (4)) rng in - let uu___3 = - FStar_Syntax_Syntax.null_bv - FStar_Syntax_Syntax.tun in - FStar_Syntax_Util.mk_field_projector_name uu___2 - uu___3 i in - let proj_i_tm = - let uu___2 = - FStar_Syntax_Syntax.lid_as_fv proj_i - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___2 in - let uu___2 = - FStar_Syntax_Syntax.mk_Tm_uinst proj_i_tm - [FStar_Syntax_Syntax.U_zero] in - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Syntax_Embeddings_Base.type_of ea in - FStar_Syntax_Syntax.iarg uu___5 in - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Syntax_Embeddings_Base.type_of eb in - FStar_Syntax_Syntax.iarg uu___7 in - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Syntax_Embeddings_Base.type_of ec in - FStar_Syntax_Syntax.iarg uu___9 in - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Syntax_Embeddings_Base.type_of ed in - FStar_Syntax_Syntax.iarg uu___11 in - let uu___11 = - let uu___12 = - FStar_Syntax_Syntax.as_arg abcd in - [uu___12] in - uu___10 :: uu___11 in - uu___8 :: uu___9 in - uu___6 :: uu___7 in - uu___4 :: uu___5 in - FStar_Syntax_Syntax.mk_Tm_app uu___2 uu___3 rng in - let shadow_a = map_shadow shadow (proj Prims.int_one) in - let shadow_b = - map_shadow shadow (proj (Prims.of_int (2))) in - let shadow_c = - map_shadow shadow (proj (Prims.of_int (3))) in - let shadow_d = - map_shadow shadow (proj (Prims.of_int (4))) in - let uu___2 = - let uu___3 = - FStar_Syntax_Syntax.tdataconstr - FStar_Parser_Const.lid_Mktuple4 in - FStar_Syntax_Syntax.mk_Tm_uinst uu___3 - [FStar_Syntax_Syntax.U_zero; - FStar_Syntax_Syntax.U_zero; - FStar_Syntax_Syntax.U_zero; - FStar_Syntax_Syntax.U_zero] in - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Embeddings_Base.type_of ea in - FStar_Syntax_Syntax.iarg uu___5 in - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Syntax_Embeddings_Base.type_of eb in - FStar_Syntax_Syntax.iarg uu___7 in - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Syntax_Embeddings_Base.type_of ec in - FStar_Syntax_Syntax.iarg uu___9 in - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Syntax_Embeddings_Base.type_of ed in - FStar_Syntax_Syntax.iarg uu___11 in - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - FStar_Syntax_Embeddings_Base.embed ea x1 in - uu___14 rng shadow_a norm in - FStar_Syntax_Syntax.as_arg uu___13 in - let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = - FStar_Syntax_Embeddings_Base.embed eb - x2 in - uu___16 rng shadow_b norm in - FStar_Syntax_Syntax.as_arg uu___15 in - let uu___15 = - let uu___16 = - let uu___17 = - let uu___18 = - FStar_Syntax_Embeddings_Base.embed - ec x3 in - uu___18 rng shadow_c norm in - FStar_Syntax_Syntax.as_arg uu___17 in - let uu___17 = - let uu___18 = - let uu___19 = - let uu___20 = - FStar_Syntax_Embeddings_Base.embed - ed x4 in - uu___20 rng shadow_d norm in - FStar_Syntax_Syntax.as_arg uu___19 in - [uu___18] in - uu___16 :: uu___17 in - uu___14 :: uu___15 in - uu___12 :: uu___13 in - uu___10 :: uu___11 in - uu___8 :: uu___9 in - uu___6 :: uu___7 in - uu___4 :: uu___5 in - FStar_Syntax_Syntax.mk_Tm_app uu___2 uu___3 rng) in - let un t norm = - lazy_unembed printer1 emb_t_pair t typ - (fun uu___ -> - (fun t1 -> - let uu___ = FStar_Syntax_Util.head_and_args_full t1 in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst hd in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, - uu___2::uu___3::uu___4::uu___5::(a1, uu___6):: - (b1, uu___7)::(c1, uu___8)::(d1, uu___9)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.lid_Mktuple4 - -> - Obj.magic - (Obj.repr - (let uu___10 = - FStar_Syntax_Embeddings_Base.try_unembed - ea a1 norm in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic uu___10) - (fun uu___11 -> - (fun a2 -> - let a2 = Obj.magic a2 in - let uu___11 = - FStar_Syntax_Embeddings_Base.try_unembed - eb b1 norm in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () (Obj.magic uu___11) - (fun uu___12 -> - (fun b2 -> - let b2 = Obj.magic b2 in - let uu___12 = - FStar_Syntax_Embeddings_Base.try_unembed - ec c1 norm in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () - (Obj.magic uu___12) - (fun uu___13 -> - (fun c2 -> - let c2 = - Obj.magic - c2 in - let uu___13 - = - FStar_Syntax_Embeddings_Base.try_unembed - ed d1 - norm in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () - (Obj.magic - uu___13) - (fun - uu___14 - -> - (fun d2 - -> - let d2 = - Obj.magic - d2 in - Obj.magic - (FStar_Pervasives_Native.Some - (a2, b2, - c2, d2))) - uu___14))) - uu___13))) - uu___12))) uu___11))) - | uu___2 -> - Obj.magic - (Obj.repr FStar_Pervasives_Native.None))) - uu___) in - FStar_Syntax_Embeddings_Base.mk_emb_full em un typ printer1 - emb_t_pair -let e_tuple5 : - 'a 'b 'c 'd 'e . - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'b FStar_Syntax_Embeddings_Base.embedding -> - 'c FStar_Syntax_Embeddings_Base.embedding -> - 'd FStar_Syntax_Embeddings_Base.embedding -> - 'e FStar_Syntax_Embeddings_Base.embedding -> - ('a * 'b * 'c * 'd * 'e) FStar_Syntax_Embeddings_Base.embedding - = - fun ea -> - fun eb -> - fun ec -> - fun ed -> - fun ee -> - let typ uu___ = - let uu___1 = FStar_Syntax_Embeddings_Base.type_of ea in - let uu___2 = FStar_Syntax_Embeddings_Base.type_of eb in - let uu___3 = FStar_Syntax_Embeddings_Base.type_of ec in - let uu___4 = FStar_Syntax_Embeddings_Base.type_of ed in - let uu___5 = FStar_Syntax_Embeddings_Base.type_of ee in - FStar_Syntax_Syntax.t_tuple5_of uu___1 uu___2 uu___3 uu___4 - uu___5 in - let emb_t_pair uu___ = - let uu___1 = - let uu___2 = - FStar_Ident.string_of_lid FStar_Parser_Const.lid_tuple5 in - let uu___3 = - let uu___4 = FStar_Syntax_Embeddings_Base.emb_typ_of ea () in - let uu___5 = - let uu___6 = - FStar_Syntax_Embeddings_Base.emb_typ_of eb () in - let uu___7 = - let uu___8 = - FStar_Syntax_Embeddings_Base.emb_typ_of ec () in - let uu___9 = - let uu___10 = - FStar_Syntax_Embeddings_Base.emb_typ_of ed () in - let uu___11 = - let uu___12 = - FStar_Syntax_Embeddings_Base.emb_typ_of ee () in - [uu___12] in - uu___10 :: uu___11 in - uu___8 :: uu___9 in - uu___6 :: uu___7 in - uu___4 :: uu___5 in - (uu___2, uu___3) in - FStar_Syntax_Syntax.ET_app uu___1 in - let printer1 uu___ = - match uu___ with - | (x, y, z, w, v) -> - let uu___1 = - let uu___2 = FStar_Syntax_Embeddings_Base.printer_of ea in - uu___2 x in - let uu___2 = - let uu___3 = FStar_Syntax_Embeddings_Base.printer_of eb in - uu___3 y in - let uu___3 = - let uu___4 = FStar_Syntax_Embeddings_Base.printer_of ec in - uu___4 z in - let uu___4 = - let uu___5 = FStar_Syntax_Embeddings_Base.printer_of ed in - uu___5 w in - let uu___5 = - let uu___6 = FStar_Syntax_Embeddings_Base.printer_of ee in - uu___6 v in - FStar_Compiler_Util.format5 "(%s, %s, %s, %s, %s)" uu___1 - uu___2 uu___3 uu___4 uu___5 in - let em uu___ rng shadow norm = - match uu___ with - | (x1, x2, x3, x4, x5) -> - lazy_embed printer1 emb_t_pair rng typ (x1, x2, x3, x4, x5) - (fun uu___1 -> - let proj i abcde = - let proj_i = - let uu___2 = - FStar_Parser_Const.mk_tuple_data_lid - (Prims.of_int (5)) rng in - let uu___3 = - FStar_Syntax_Syntax.null_bv - FStar_Syntax_Syntax.tun in - FStar_Syntax_Util.mk_field_projector_name uu___2 - uu___3 i in - let proj_i_tm = - let uu___2 = - FStar_Syntax_Syntax.lid_as_fv proj_i - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___2 in - let uu___2 = - FStar_Syntax_Syntax.mk_Tm_uinst proj_i_tm - [FStar_Syntax_Syntax.U_zero] in - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Syntax_Embeddings_Base.type_of ea in - FStar_Syntax_Syntax.iarg uu___5 in - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Syntax_Embeddings_Base.type_of eb in - FStar_Syntax_Syntax.iarg uu___7 in - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Syntax_Embeddings_Base.type_of ec in - FStar_Syntax_Syntax.iarg uu___9 in - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Syntax_Embeddings_Base.type_of ed in - FStar_Syntax_Syntax.iarg uu___11 in - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Syntax_Embeddings_Base.type_of - ee in - FStar_Syntax_Syntax.iarg uu___13 in - let uu___13 = - let uu___14 = - FStar_Syntax_Syntax.as_arg abcde in - [uu___14] in - uu___12 :: uu___13 in - uu___10 :: uu___11 in - uu___8 :: uu___9 in - uu___6 :: uu___7 in - uu___4 :: uu___5 in - FStar_Syntax_Syntax.mk_Tm_app uu___2 uu___3 rng in - let shadow_a = map_shadow shadow (proj Prims.int_one) in - let shadow_b = - map_shadow shadow (proj (Prims.of_int (2))) in - let shadow_c = - map_shadow shadow (proj (Prims.of_int (3))) in - let shadow_d = - map_shadow shadow (proj (Prims.of_int (4))) in - let shadow_e = - map_shadow shadow (proj (Prims.of_int (5))) in - let uu___2 = - let uu___3 = - FStar_Syntax_Syntax.tdataconstr - FStar_Parser_Const.lid_Mktuple5 in - FStar_Syntax_Syntax.mk_Tm_uinst uu___3 - [FStar_Syntax_Syntax.U_zero; - FStar_Syntax_Syntax.U_zero; - FStar_Syntax_Syntax.U_zero; - FStar_Syntax_Syntax.U_zero; - FStar_Syntax_Syntax.U_zero] in - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Syntax_Embeddings_Base.type_of ea in - FStar_Syntax_Syntax.iarg uu___5 in - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Syntax_Embeddings_Base.type_of eb in - FStar_Syntax_Syntax.iarg uu___7 in - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Syntax_Embeddings_Base.type_of ec in - FStar_Syntax_Syntax.iarg uu___9 in - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Syntax_Embeddings_Base.type_of ed in - FStar_Syntax_Syntax.iarg uu___11 in - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Syntax_Embeddings_Base.type_of ee in - FStar_Syntax_Syntax.iarg uu___13 in - let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = - FStar_Syntax_Embeddings_Base.embed - ea x1 in - uu___16 rng shadow_a norm in - FStar_Syntax_Syntax.as_arg uu___15 in - let uu___15 = - let uu___16 = - let uu___17 = - let uu___18 = - FStar_Syntax_Embeddings_Base.embed - eb x2 in - uu___18 rng shadow_b norm in - FStar_Syntax_Syntax.as_arg uu___17 in - let uu___17 = - let uu___18 = - let uu___19 = - let uu___20 = - FStar_Syntax_Embeddings_Base.embed - ec x3 in - uu___20 rng shadow_c norm in - FStar_Syntax_Syntax.as_arg uu___19 in - let uu___19 = - let uu___20 = - let uu___21 = - let uu___22 = - FStar_Syntax_Embeddings_Base.embed - ed x4 in - uu___22 rng shadow_d norm in - FStar_Syntax_Syntax.as_arg uu___21 in - let uu___21 = - let uu___22 = - let uu___23 = - let uu___24 = - FStar_Syntax_Embeddings_Base.embed - ee x5 in - uu___24 rng shadow_e norm in - FStar_Syntax_Syntax.as_arg - uu___23 in - [uu___22] in - uu___20 :: uu___21 in - uu___18 :: uu___19 in - uu___16 :: uu___17 in - uu___14 :: uu___15 in - uu___12 :: uu___13 in - uu___10 :: uu___11 in - uu___8 :: uu___9 in - uu___6 :: uu___7 in - uu___4 :: uu___5 in - FStar_Syntax_Syntax.mk_Tm_app uu___2 uu___3 rng) in - let un t norm = - lazy_unembed printer1 emb_t_pair t typ - (fun uu___ -> - (fun t1 -> - let uu___ = FStar_Syntax_Util.head_and_args_full t1 in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst hd in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, - uu___2::uu___3::uu___4::uu___5::uu___6:: - (a1, uu___7)::(b1, uu___8)::(c1, uu___9):: - (d1, uu___10)::(e1, uu___11)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.lid_Mktuple5 - -> - Obj.magic - (Obj.repr - (let uu___12 = - FStar_Syntax_Embeddings_Base.try_unembed - ea a1 norm in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic uu___12) - (fun uu___13 -> - (fun a2 -> - let a2 = Obj.magic a2 in - let uu___13 = - FStar_Syntax_Embeddings_Base.try_unembed - eb b1 norm in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () (Obj.magic uu___13) - (fun uu___14 -> - (fun b2 -> - let b2 = Obj.magic b2 in - let uu___14 = - FStar_Syntax_Embeddings_Base.try_unembed - ec c1 norm in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () - (Obj.magic - uu___14) - (fun uu___15 -> - (fun c2 -> - let c2 = - Obj.magic - c2 in - let uu___15 - = - FStar_Syntax_Embeddings_Base.try_unembed - ed d1 - norm in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () - (Obj.magic - uu___15) - (fun - uu___16 - -> - (fun d2 - -> - let d2 = - Obj.magic - d2 in - let uu___16 - = - FStar_Syntax_Embeddings_Base.try_unembed - ee e1 - norm in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () - (Obj.magic - uu___16) - (fun - uu___17 - -> - (fun e2 - -> - let e2 = - Obj.magic - e2 in - Obj.magic - (FStar_Pervasives_Native.Some - (a2, b2, - c2, d2, - e2))) - uu___17))) - uu___16))) - uu___15))) - uu___14))) uu___13))) - | uu___2 -> - Obj.magic - (Obj.repr FStar_Pervasives_Native.None))) - uu___) in - FStar_Syntax_Embeddings_Base.mk_emb_full em un typ printer1 - emb_t_pair -let e_either : - 'a 'b . - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'b FStar_Syntax_Embeddings_Base.embedding -> - ('a, 'b) FStar_Pervasives.either - FStar_Syntax_Embeddings_Base.embedding - = - fun ea -> - fun eb -> - let typ uu___ = - let uu___1 = FStar_Syntax_Embeddings_Base.type_of ea in - let uu___2 = FStar_Syntax_Embeddings_Base.type_of eb in - FStar_Syntax_Syntax.t_either_of uu___1 uu___2 in - let emb_t_sum_a_b uu___ = - let uu___1 = - let uu___2 = - FStar_Ident.string_of_lid FStar_Parser_Const.either_lid in - let uu___3 = - let uu___4 = FStar_Syntax_Embeddings_Base.emb_typ_of ea () in - let uu___5 = - let uu___6 = FStar_Syntax_Embeddings_Base.emb_typ_of eb () in - [uu___6] in - uu___4 :: uu___5 in - (uu___2, uu___3) in - FStar_Syntax_Syntax.ET_app uu___1 in - let printer1 s = - match s with - | FStar_Pervasives.Inl a1 -> - let uu___ = - let uu___1 = FStar_Syntax_Embeddings_Base.printer_of ea in - uu___1 a1 in - FStar_Compiler_Util.format1 "Inl %s" uu___ - | FStar_Pervasives.Inr b1 -> - let uu___ = - let uu___1 = FStar_Syntax_Embeddings_Base.printer_of eb in - uu___1 b1 in - FStar_Compiler_Util.format1 "Inr %s" uu___ in - let em s rng shadow norm = - lazy_embed printer1 emb_t_sum_a_b rng typ s - (match s with - | FStar_Pervasives.Inl a1 -> - (fun uu___ -> - let shadow_a = - map_shadow shadow - (fun t -> - let v = FStar_Ident.mk_ident ("v", rng) in - let some_v = - FStar_Syntax_Util.mk_field_projector_name_from_ident - FStar_Parser_Const.inl_lid v in - let some_v_tm = - let uu___1 = - FStar_Syntax_Syntax.lid_as_fv some_v - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___1 in - let uu___1 = - FStar_Syntax_Syntax.mk_Tm_uinst some_v_tm - [FStar_Syntax_Syntax.U_zero] in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Syntax_Embeddings_Base.type_of ea in - FStar_Syntax_Syntax.iarg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Embeddings_Base.type_of eb in - FStar_Syntax_Syntax.iarg uu___6 in - let uu___6 = - let uu___7 = FStar_Syntax_Syntax.as_arg t in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - FStar_Syntax_Syntax.mk_Tm_app uu___1 uu___2 rng) in - let uu___1 = - let uu___2 = - FStar_Syntax_Syntax.tdataconstr - FStar_Parser_Const.inl_lid in - FStar_Syntax_Syntax.mk_Tm_uinst uu___2 - [FStar_Syntax_Syntax.U_zero; - FStar_Syntax_Syntax.U_zero] in - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Embeddings_Base.type_of ea in - FStar_Syntax_Syntax.iarg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = FStar_Syntax_Embeddings_Base.type_of eb in - FStar_Syntax_Syntax.iarg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Syntax_Embeddings_Base.embed ea a1 in - uu___9 rng shadow_a norm in - FStar_Syntax_Syntax.as_arg uu___8 in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - FStar_Syntax_Syntax.mk_Tm_app uu___1 uu___2 rng) - | FStar_Pervasives.Inr b1 -> - (fun uu___ -> - let shadow_b = - map_shadow shadow - (fun t -> - let v = FStar_Ident.mk_ident ("v", rng) in - let some_v = - FStar_Syntax_Util.mk_field_projector_name_from_ident - FStar_Parser_Const.inr_lid v in - let some_v_tm = - let uu___1 = - FStar_Syntax_Syntax.lid_as_fv some_v - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___1 in - let uu___1 = - FStar_Syntax_Syntax.mk_Tm_uinst some_v_tm - [FStar_Syntax_Syntax.U_zero] in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Syntax_Embeddings_Base.type_of ea in - FStar_Syntax_Syntax.iarg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Embeddings_Base.type_of eb in - FStar_Syntax_Syntax.iarg uu___6 in - let uu___6 = - let uu___7 = FStar_Syntax_Syntax.as_arg t in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - FStar_Syntax_Syntax.mk_Tm_app uu___1 uu___2 rng) in - let uu___1 = - let uu___2 = - FStar_Syntax_Syntax.tdataconstr - FStar_Parser_Const.inr_lid in - FStar_Syntax_Syntax.mk_Tm_uinst uu___2 - [FStar_Syntax_Syntax.U_zero; - FStar_Syntax_Syntax.U_zero] in - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Embeddings_Base.type_of ea in - FStar_Syntax_Syntax.iarg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = FStar_Syntax_Embeddings_Base.type_of eb in - FStar_Syntax_Syntax.iarg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Syntax_Embeddings_Base.embed eb b1 in - uu___9 rng shadow_b norm in - FStar_Syntax_Syntax.as_arg uu___8 in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - FStar_Syntax_Syntax.mk_Tm_app uu___1 uu___2 rng)) in - let un t norm = - lazy_unembed printer1 emb_t_sum_a_b t typ - (fun t1 -> - let uu___ = FStar_Syntax_Util.head_and_args_full t1 in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst hd in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, - uu___2::uu___3::(a1, uu___4)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.inl_lid - -> - let uu___5 = - FStar_Syntax_Embeddings_Base.try_unembed ea a1 norm in - FStar_Compiler_Util.bind_opt uu___5 - (fun a2 -> - FStar_Pervasives_Native.Some - (FStar_Pervasives.Inl a2)) - | (FStar_Syntax_Syntax.Tm_fvar fv, - uu___2::uu___3::(b1, uu___4)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.inr_lid - -> - let uu___5 = - FStar_Syntax_Embeddings_Base.try_unembed eb b1 norm in - FStar_Compiler_Util.bind_opt uu___5 - (fun b2 -> - FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr b2)) - | uu___2 -> FStar_Pervasives_Native.None)) in - FStar_Syntax_Embeddings_Base.mk_emb_full em un typ printer1 - emb_t_sum_a_b -let e_list : - 'a . - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'a Prims.list FStar_Syntax_Embeddings_Base.embedding - = - fun ea -> - let typ uu___ = - let uu___1 = FStar_Syntax_Embeddings_Base.type_of ea in - FStar_Syntax_Syntax.t_list_of uu___1 in - let emb_t_list_a uu___ = - let uu___1 = - let uu___2 = FStar_Ident.string_of_lid FStar_Parser_Const.list_lid in - let uu___3 = - let uu___4 = FStar_Syntax_Embeddings_Base.emb_typ_of ea () in - [uu___4] in - (uu___2, uu___3) in - FStar_Syntax_Syntax.ET_app uu___1 in - let printer1 l = - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Embeddings_Base.printer_of ea in - FStar_Compiler_List.map uu___3 l in - FStar_Compiler_String.concat "; " uu___2 in - Prims.strcat uu___1 "]" in - Prims.strcat "[" uu___ in - let rec em l rng shadow_l norm = - lazy_embed printer1 emb_t_list_a rng typ l - (fun uu___ -> - let t = - let uu___1 = FStar_Syntax_Embeddings_Base.type_of ea in - FStar_Syntax_Syntax.iarg uu___1 in - match l with - | [] -> - let uu___1 = - let uu___2 = - FStar_Syntax_Syntax.tdataconstr FStar_Parser_Const.nil_lid in - FStar_Syntax_Syntax.mk_Tm_uinst uu___2 - [FStar_Syntax_Syntax.U_zero] in - FStar_Syntax_Syntax.mk_Tm_app uu___1 [t] rng - | hd::tl -> - let cons = - let uu___1 = - FStar_Syntax_Syntax.tdataconstr - FStar_Parser_Const.cons_lid in - FStar_Syntax_Syntax.mk_Tm_uinst uu___1 - [FStar_Syntax_Syntax.U_zero] in - let proj f cons_tm = - let fid = FStar_Ident.mk_ident (f, rng) in - let proj1 = - FStar_Syntax_Util.mk_field_projector_name_from_ident - FStar_Parser_Const.cons_lid fid in - let proj_tm = - let uu___1 = - FStar_Syntax_Syntax.lid_as_fv proj1 - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___1 in - let uu___1 = - FStar_Syntax_Syntax.mk_Tm_uinst proj_tm - [FStar_Syntax_Syntax.U_zero] in - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Embeddings_Base.type_of ea in - FStar_Syntax_Syntax.iarg uu___4 in - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.as_arg cons_tm in - [uu___5] in - uu___3 :: uu___4 in - FStar_Syntax_Syntax.mk_Tm_app uu___1 uu___2 rng in - let shadow_hd = map_shadow shadow_l (proj "hd") in - let shadow_tl = map_shadow shadow_l (proj "tl") in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Embeddings_Base.embed ea hd in - uu___5 rng shadow_hd norm in - FStar_Syntax_Syntax.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = em tl rng shadow_tl norm in - FStar_Syntax_Syntax.as_arg uu___6 in - [uu___5] in - uu___3 :: uu___4 in - t :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app cons uu___1 rng) in - let rec un t norm = - lazy_unembed printer1 emb_t_list_a t typ - (fun t1 -> - let uu___ = FStar_Syntax_Util.head_and_args_full t1 in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst hd in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, uu___2) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.nil_lid - -> FStar_Pervasives_Native.Some [] - | (FStar_Syntax_Syntax.Tm_fvar fv, - (uu___2, FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = uu___3;_}):: - (hd1, FStar_Pervasives_Native.None)::(tl, - FStar_Pervasives_Native.None)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.cons_lid - -> - let uu___4 = - FStar_Syntax_Embeddings_Base.try_unembed ea hd1 norm in - FStar_Compiler_Util.bind_opt uu___4 - (fun hd2 -> - let uu___5 = un tl norm in - FStar_Compiler_Util.bind_opt uu___5 - (fun tl1 -> - FStar_Pervasives_Native.Some (hd2 :: tl1))) - | (FStar_Syntax_Syntax.Tm_fvar fv, - (hd1, FStar_Pervasives_Native.None)::(tl, - FStar_Pervasives_Native.None)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.cons_lid - -> - let uu___2 = - FStar_Syntax_Embeddings_Base.try_unembed ea hd1 norm in - FStar_Compiler_Util.bind_opt uu___2 - (fun hd2 -> - let uu___3 = un tl norm in - FStar_Compiler_Util.bind_opt uu___3 - (fun tl1 -> - FStar_Pervasives_Native.Some (hd2 :: tl1))) - | uu___2 -> FStar_Pervasives_Native.None)) in - FStar_Syntax_Embeddings_Base.mk_emb_full em un typ printer1 emb_t_list_a -let (e_string_list : - Prims.string Prims.list FStar_Syntax_Embeddings_Base.embedding) = - e_list e_string -let (steps_Simpl : FStar_Syntax_Syntax.term) = - FStar_Syntax_Syntax.tconst FStar_Parser_Const.steps_simpl -let (steps_Weak : FStar_Syntax_Syntax.term) = - FStar_Syntax_Syntax.tconst FStar_Parser_Const.steps_weak -let (steps_HNF : FStar_Syntax_Syntax.term) = - FStar_Syntax_Syntax.tconst FStar_Parser_Const.steps_hnf -let (steps_Primops : FStar_Syntax_Syntax.term) = - FStar_Syntax_Syntax.tconst FStar_Parser_Const.steps_primops -let (steps_Delta : FStar_Syntax_Syntax.term) = - FStar_Syntax_Syntax.tconst FStar_Parser_Const.steps_delta -let (steps_Zeta : FStar_Syntax_Syntax.term) = - FStar_Syntax_Syntax.tconst FStar_Parser_Const.steps_zeta -let (steps_ZetaFull : FStar_Syntax_Syntax.term) = - FStar_Syntax_Syntax.tconst FStar_Parser_Const.steps_zeta_full -let (steps_Iota : FStar_Syntax_Syntax.term) = - FStar_Syntax_Syntax.tconst FStar_Parser_Const.steps_iota -let (steps_Reify : FStar_Syntax_Syntax.term) = - FStar_Syntax_Syntax.tconst FStar_Parser_Const.steps_reify -let (steps_NormDebug : FStar_Syntax_Syntax.term) = - FStar_Syntax_Syntax.tconst FStar_Parser_Const.steps_norm_debug -let (steps_UnfoldOnly : FStar_Syntax_Syntax.term) = - FStar_Syntax_Syntax.tconst FStar_Parser_Const.steps_unfoldonly -let (steps_UnfoldFully : FStar_Syntax_Syntax.term) = - FStar_Syntax_Syntax.tconst FStar_Parser_Const.steps_unfoldonly -let (steps_UnfoldAttr : FStar_Syntax_Syntax.term) = - FStar_Syntax_Syntax.tconst FStar_Parser_Const.steps_unfoldattr -let (steps_UnfoldQual : FStar_Syntax_Syntax.term) = - FStar_Syntax_Syntax.tconst FStar_Parser_Const.steps_unfoldqual -let (steps_UnfoldNamespace : FStar_Syntax_Syntax.term) = - FStar_Syntax_Syntax.tconst FStar_Parser_Const.steps_unfoldnamespace -let (steps_Unascribe : FStar_Syntax_Syntax.term) = - FStar_Syntax_Syntax.tconst FStar_Parser_Const.steps_unascribe -let (steps_NBE : FStar_Syntax_Syntax.term) = - FStar_Syntax_Syntax.tconst FStar_Parser_Const.steps_nbe -let (steps_Unmeta : FStar_Syntax_Syntax.term) = - FStar_Syntax_Syntax.tconst FStar_Parser_Const.steps_unmeta -let (e_norm_step : - FStar_Pervasives.norm_step FStar_Syntax_Embeddings_Base.embedding) = - let typ uu___ = FStar_Syntax_Syntax.t_norm_step in - let emb_t_norm_step uu___ = - let uu___1 = - let uu___2 = FStar_Ident.string_of_lid FStar_Parser_Const.norm_step_lid in - (uu___2, []) in - FStar_Syntax_Syntax.ET_app uu___1 in - let printer1 uu___ = "norm_step" in - let em n rng _shadow norm = - lazy_embed printer1 emb_t_norm_step rng typ n - (fun uu___ -> - match n with - | FStar_Pervasives.Simpl -> steps_Simpl - | FStar_Pervasives.Weak -> steps_Weak - | FStar_Pervasives.HNF -> steps_HNF - | FStar_Pervasives.Primops -> steps_Primops - | FStar_Pervasives.Delta -> steps_Delta - | FStar_Pervasives.Zeta -> steps_Zeta - | FStar_Pervasives.ZetaFull -> steps_ZetaFull - | FStar_Pervasives.Iota -> steps_Iota - | FStar_Pervasives.Unascribe -> steps_Unascribe - | FStar_Pervasives.NBE -> steps_NBE - | FStar_Pervasives.Unmeta -> steps_Unmeta - | FStar_Pervasives.Reify -> steps_Reify - | FStar_Pervasives.NormDebug -> steps_NormDebug - | FStar_Pervasives.UnfoldOnly l -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Syntax_Embeddings_Base.embed e_string_list l in - uu___4 rng FStar_Pervasives_Native.None norm in - FStar_Syntax_Syntax.as_arg uu___3 in - [uu___2] in - FStar_Syntax_Syntax.mk_Tm_app steps_UnfoldOnly uu___1 rng - | FStar_Pervasives.UnfoldFully l -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Syntax_Embeddings_Base.embed e_string_list l in - uu___4 rng FStar_Pervasives_Native.None norm in - FStar_Syntax_Syntax.as_arg uu___3 in - [uu___2] in - FStar_Syntax_Syntax.mk_Tm_app steps_UnfoldFully uu___1 rng - | FStar_Pervasives.UnfoldAttr l -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Syntax_Embeddings_Base.embed e_string_list l in - uu___4 rng FStar_Pervasives_Native.None norm in - FStar_Syntax_Syntax.as_arg uu___3 in - [uu___2] in - FStar_Syntax_Syntax.mk_Tm_app steps_UnfoldAttr uu___1 rng - | FStar_Pervasives.UnfoldQual l -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Syntax_Embeddings_Base.embed e_string_list l in - uu___4 rng FStar_Pervasives_Native.None norm in - FStar_Syntax_Syntax.as_arg uu___3 in - [uu___2] in - FStar_Syntax_Syntax.mk_Tm_app steps_UnfoldQual uu___1 rng - | FStar_Pervasives.UnfoldNamespace l -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Syntax_Embeddings_Base.embed e_string_list l in - uu___4 rng FStar_Pervasives_Native.None norm in - FStar_Syntax_Syntax.as_arg uu___3 in - [uu___2] in - FStar_Syntax_Syntax.mk_Tm_app steps_UnfoldNamespace uu___1 rng) in - let un t norm = - lazy_unembed printer1 emb_t_norm_step t typ - (fun t1 -> - let uu___ = FStar_Syntax_Util.head_and_args t1 in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst hd in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.steps_simpl - -> FStar_Pervasives_Native.Some FStar_Pervasives.Simpl - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.steps_weak - -> FStar_Pervasives_Native.Some FStar_Pervasives.Weak - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.steps_hnf - -> FStar_Pervasives_Native.Some FStar_Pervasives.HNF - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.steps_primops - -> FStar_Pervasives_Native.Some FStar_Pervasives.Primops - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.steps_delta - -> FStar_Pervasives_Native.Some FStar_Pervasives.Delta - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.steps_zeta - -> FStar_Pervasives_Native.Some FStar_Pervasives.Zeta - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.steps_zeta_full - -> FStar_Pervasives_Native.Some FStar_Pervasives.ZetaFull - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.steps_iota - -> FStar_Pervasives_Native.Some FStar_Pervasives.Iota - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.steps_unascribe - -> FStar_Pervasives_Native.Some FStar_Pervasives.Unascribe - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.steps_nbe - -> FStar_Pervasives_Native.Some FStar_Pervasives.NBE - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.steps_unmeta - -> FStar_Pervasives_Native.Some FStar_Pervasives.Unmeta - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.steps_reify - -> FStar_Pervasives_Native.Some FStar_Pervasives.Reify - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.steps_norm_debug - -> FStar_Pervasives_Native.Some FStar_Pervasives.NormDebug - | (FStar_Syntax_Syntax.Tm_fvar fv, (l, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.steps_unfoldonly - -> - let uu___3 = - FStar_Syntax_Embeddings_Base.try_unembed e_string_list l - norm in - FStar_Compiler_Util.bind_opt uu___3 - (fun ss -> - FStar_Pervasives_Native.Some - (FStar_Pervasives.UnfoldOnly ss)) - | (FStar_Syntax_Syntax.Tm_fvar fv, (l, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.steps_unfoldfully - -> - let uu___3 = - FStar_Syntax_Embeddings_Base.try_unembed e_string_list l - norm in - FStar_Compiler_Util.bind_opt uu___3 - (fun ss -> - FStar_Pervasives_Native.Some - (FStar_Pervasives.UnfoldFully ss)) - | (FStar_Syntax_Syntax.Tm_fvar fv, (l, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.steps_unfoldattr - -> - let uu___3 = - FStar_Syntax_Embeddings_Base.try_unembed e_string_list l - norm in - FStar_Compiler_Util.bind_opt uu___3 - (fun ss -> - FStar_Pervasives_Native.Some - (FStar_Pervasives.UnfoldAttr ss)) - | (FStar_Syntax_Syntax.Tm_fvar fv, (l, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.steps_unfoldqual - -> - let uu___3 = - FStar_Syntax_Embeddings_Base.try_unembed e_string_list l - norm in - FStar_Compiler_Util.bind_opt uu___3 - (fun ss -> - FStar_Pervasives_Native.Some - (FStar_Pervasives.UnfoldQual ss)) - | (FStar_Syntax_Syntax.Tm_fvar fv, (l, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.steps_unfoldnamespace - -> - let uu___3 = - FStar_Syntax_Embeddings_Base.try_unembed e_string_list l - norm in - FStar_Compiler_Util.bind_opt uu___3 - (fun ss -> - FStar_Pervasives_Native.Some - (FStar_Pervasives.UnfoldNamespace ss)) - | uu___2 -> FStar_Pervasives_Native.None)) in - FStar_Syntax_Embeddings_Base.mk_emb_full em un typ printer1 emb_t_norm_step -let (e_vconfig : - FStar_VConfig.vconfig FStar_Syntax_Embeddings_Base.embedding) = - let em vcfg rng _shadow norm = - let uu___ = - FStar_Syntax_Syntax.tdataconstr FStar_Parser_Const.mkvconfig_lid in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Syntax_Embeddings_Base.embed e_fsint - vcfg.FStar_VConfig.initial_fuel in - uu___4 rng FStar_Pervasives_Native.None norm in - FStar_Syntax_Syntax.as_arg uu___3 in - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Embeddings_Base.embed e_fsint - vcfg.FStar_VConfig.max_fuel in - uu___6 rng FStar_Pervasives_Native.None norm in - FStar_Syntax_Syntax.as_arg uu___5 in - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Syntax_Embeddings_Base.embed e_fsint - vcfg.FStar_VConfig.initial_ifuel in - uu___8 rng FStar_Pervasives_Native.None norm in - FStar_Syntax_Syntax.as_arg uu___7 in - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Syntax_Embeddings_Base.embed e_fsint - vcfg.FStar_VConfig.max_ifuel in - uu___10 rng FStar_Pervasives_Native.None norm in - FStar_Syntax_Syntax.as_arg uu___9 in - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Syntax_Embeddings_Base.embed e_bool - vcfg.FStar_VConfig.detail_errors in - uu___12 rng FStar_Pervasives_Native.None norm in - FStar_Syntax_Syntax.as_arg uu___11 in - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - FStar_Syntax_Embeddings_Base.embed e_bool - vcfg.FStar_VConfig.detail_hint_replay in - uu___14 rng FStar_Pervasives_Native.None norm in - FStar_Syntax_Syntax.as_arg uu___13 in - let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = - FStar_Syntax_Embeddings_Base.embed e_bool - vcfg.FStar_VConfig.no_smt in - uu___16 rng FStar_Pervasives_Native.None norm in - FStar_Syntax_Syntax.as_arg uu___15 in - let uu___15 = - let uu___16 = - let uu___17 = - let uu___18 = - FStar_Syntax_Embeddings_Base.embed e_fsint - vcfg.FStar_VConfig.quake_lo in - uu___18 rng FStar_Pervasives_Native.None norm in - FStar_Syntax_Syntax.as_arg uu___17 in - let uu___17 = - let uu___18 = - let uu___19 = - let uu___20 = - FStar_Syntax_Embeddings_Base.embed e_fsint - vcfg.FStar_VConfig.quake_hi in - uu___20 rng FStar_Pervasives_Native.None norm in - FStar_Syntax_Syntax.as_arg uu___19 in - let uu___19 = - let uu___20 = - let uu___21 = - let uu___22 = - FStar_Syntax_Embeddings_Base.embed e_bool - vcfg.FStar_VConfig.quake_keep in - uu___22 rng FStar_Pervasives_Native.None norm in - FStar_Syntax_Syntax.as_arg uu___21 in - let uu___21 = - let uu___22 = - let uu___23 = - let uu___24 = - FStar_Syntax_Embeddings_Base.embed e_bool - vcfg.FStar_VConfig.retry in - uu___24 rng FStar_Pervasives_Native.None norm in - FStar_Syntax_Syntax.as_arg uu___23 in - let uu___23 = - let uu___24 = - let uu___25 = - let uu___26 = - FStar_Syntax_Embeddings_Base.embed e_bool - vcfg.FStar_VConfig.smtencoding_elim_box in - uu___26 rng FStar_Pervasives_Native.None norm in - FStar_Syntax_Syntax.as_arg uu___25 in - let uu___25 = - let uu___26 = - let uu___27 = - let uu___28 = - FStar_Syntax_Embeddings_Base.embed - e_string - vcfg.FStar_VConfig.smtencoding_nl_arith_repr in - uu___28 rng FStar_Pervasives_Native.None - norm in - FStar_Syntax_Syntax.as_arg uu___27 in - let uu___27 = - let uu___28 = - let uu___29 = - let uu___30 = - FStar_Syntax_Embeddings_Base.embed - e_string - vcfg.FStar_VConfig.smtencoding_l_arith_repr in - uu___30 rng FStar_Pervasives_Native.None - norm in - FStar_Syntax_Syntax.as_arg uu___29 in - let uu___29 = - let uu___30 = - let uu___31 = - let uu___32 = - FStar_Syntax_Embeddings_Base.embed - e_bool - vcfg.FStar_VConfig.smtencoding_valid_intro in - uu___32 rng - FStar_Pervasives_Native.None norm in - FStar_Syntax_Syntax.as_arg uu___31 in - let uu___31 = - let uu___32 = - let uu___33 = - let uu___34 = - FStar_Syntax_Embeddings_Base.embed - e_bool - vcfg.FStar_VConfig.smtencoding_valid_elim in - uu___34 rng - FStar_Pervasives_Native.None norm in - FStar_Syntax_Syntax.as_arg uu___33 in - let uu___33 = - let uu___34 = - let uu___35 = - let uu___36 = - FStar_Syntax_Embeddings_Base.embed - e_bool - vcfg.FStar_VConfig.tcnorm in - uu___36 rng - FStar_Pervasives_Native.None norm in - FStar_Syntax_Syntax.as_arg uu___35 in - let uu___35 = - let uu___36 = - let uu___37 = - let uu___38 = - FStar_Syntax_Embeddings_Base.embed - e_bool - vcfg.FStar_VConfig.no_plugins in - uu___38 rng - FStar_Pervasives_Native.None - norm in - FStar_Syntax_Syntax.as_arg uu___37 in - let uu___37 = - let uu___38 = - let uu___39 = - let uu___40 = - FStar_Syntax_Embeddings_Base.embed - e_bool - vcfg.FStar_VConfig.no_tactics in - uu___40 rng - FStar_Pervasives_Native.None - norm in - FStar_Syntax_Syntax.as_arg - uu___39 in - let uu___39 = - let uu___40 = - let uu___41 = - let uu___42 = - FStar_Syntax_Embeddings_Base.embed - e_string_list - vcfg.FStar_VConfig.z3cliopt in - uu___42 rng - FStar_Pervasives_Native.None - norm in - FStar_Syntax_Syntax.as_arg - uu___41 in - let uu___41 = - let uu___42 = - let uu___43 = - let uu___44 = - FStar_Syntax_Embeddings_Base.embed - e_string_list - vcfg.FStar_VConfig.z3smtopt in - uu___44 rng - FStar_Pervasives_Native.None - norm in - FStar_Syntax_Syntax.as_arg - uu___43 in - let uu___43 = - let uu___44 = - let uu___45 = - let uu___46 = - FStar_Syntax_Embeddings_Base.embed - e_bool - vcfg.FStar_VConfig.z3refresh in - uu___46 rng - FStar_Pervasives_Native.None - norm in - FStar_Syntax_Syntax.as_arg - uu___45 in - let uu___45 = - let uu___46 = - let uu___47 = - let uu___48 = - FStar_Syntax_Embeddings_Base.embed - e_fsint - vcfg.FStar_VConfig.z3rlimit in - uu___48 rng - FStar_Pervasives_Native.None - norm in - FStar_Syntax_Syntax.as_arg - uu___47 in - let uu___47 = - let uu___48 = - let uu___49 = - let uu___50 = - FStar_Syntax_Embeddings_Base.embed - e_fsint - vcfg.FStar_VConfig.z3rlimit_factor in - uu___50 rng - FStar_Pervasives_Native.None - norm in - FStar_Syntax_Syntax.as_arg - uu___49 in - let uu___49 = - let uu___50 = - let uu___51 = - let uu___52 = - FStar_Syntax_Embeddings_Base.embed - e_fsint - vcfg.FStar_VConfig.z3seed in - uu___52 rng - FStar_Pervasives_Native.None - norm in - FStar_Syntax_Syntax.as_arg - uu___51 in - let uu___51 = - let uu___52 = - let uu___53 = - let uu___54 = - FStar_Syntax_Embeddings_Base.embed - e_string - vcfg.FStar_VConfig.z3version in - uu___54 rng - FStar_Pervasives_Native.None - norm in - FStar_Syntax_Syntax.as_arg - uu___53 in - let uu___53 = - let uu___54 = - let uu___55 = - let uu___56 = - FStar_Syntax_Embeddings_Base.embed - e_bool - vcfg.FStar_VConfig.trivial_pre_for_unannotated_effectful_fns in - uu___56 rng - FStar_Pervasives_Native.None - norm in - FStar_Syntax_Syntax.as_arg - uu___55 in - let uu___55 = - let uu___56 = - let uu___57 = - let uu___58 = - FStar_Syntax_Embeddings_Base.embed - ( - e_option - e_string) - vcfg.FStar_VConfig.reuse_hint_for in - uu___58 rng - FStar_Pervasives_Native.None - norm in - FStar_Syntax_Syntax.as_arg - uu___57 in - [uu___56] in - uu___54 :: uu___55 in - uu___52 :: uu___53 in - uu___50 :: uu___51 in - uu___48 :: uu___49 in - uu___46 :: uu___47 in - uu___44 :: uu___45 in - uu___42 :: uu___43 in - uu___40 :: uu___41 in - uu___38 :: uu___39 in - uu___36 :: uu___37 in - uu___34 :: uu___35 in - uu___32 :: uu___33 in - uu___30 :: uu___31 in - uu___28 :: uu___29 in - uu___26 :: uu___27 in - uu___24 :: uu___25 in - uu___22 :: uu___23 in - uu___20 :: uu___21 in - uu___18 :: uu___19 in - uu___16 :: uu___17 in - uu___14 :: uu___15 in - uu___12 :: uu___13 in - uu___10 :: uu___11 in - uu___8 :: uu___9 in - uu___6 :: uu___7 in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - FStar_Syntax_Syntax.mk_Tm_app uu___ uu___1 rng in - let un t norm = - let uu___ = FStar_Syntax_Util.head_and_args t in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst hd in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, - (initial_fuel, uu___2)::(max_fuel, uu___3)::(initial_ifuel, - uu___4)::(max_ifuel, - uu___5):: - (detail_errors, uu___6)::(detail_hint_replay, uu___7)::(no_smt, - uu___8):: - (quake_lo, uu___9)::(quake_hi, uu___10)::(quake_keep, uu___11):: - (retry, uu___12)::(smtencoding_elim_box, uu___13)::(smtencoding_nl_arith_repr, - uu___14):: - (smtencoding_l_arith_repr, uu___15)::(smtencoding_valid_intro, - uu___16)::(smtencoding_valid_elim, - uu___17):: - (tcnorm, uu___18)::(no_plugins, uu___19)::(no_tactics, uu___20):: - (z3cliopt, uu___21)::(z3smtopt, uu___22)::(z3refresh, uu___23):: - (z3rlimit, uu___24)::(z3rlimit_factor, uu___25)::(z3seed, - uu___26):: - (z3version, uu___27)::(trivial_pre_for_unannotated_effectful_fns, - uu___28)::(reuse_hint_for, uu___29)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.mkvconfig_lid - -> - let uu___30 = - FStar_Syntax_Embeddings_Base.try_unembed e_fsint initial_fuel - norm in - FStar_Compiler_Util.bind_opt uu___30 - (fun initial_fuel1 -> - let uu___31 = - FStar_Syntax_Embeddings_Base.try_unembed e_fsint max_fuel - norm in - FStar_Compiler_Util.bind_opt uu___31 - (fun max_fuel1 -> - let uu___32 = - FStar_Syntax_Embeddings_Base.try_unembed e_fsint - initial_ifuel norm in - FStar_Compiler_Util.bind_opt uu___32 - (fun initial_ifuel1 -> - let uu___33 = - FStar_Syntax_Embeddings_Base.try_unembed - e_fsint max_ifuel norm in - FStar_Compiler_Util.bind_opt uu___33 - (fun max_ifuel1 -> - let uu___34 = - FStar_Syntax_Embeddings_Base.try_unembed - e_bool detail_errors norm in - FStar_Compiler_Util.bind_opt uu___34 - (fun detail_errors1 -> - let uu___35 = - FStar_Syntax_Embeddings_Base.try_unembed - e_bool detail_hint_replay norm in - FStar_Compiler_Util.bind_opt uu___35 - (fun detail_hint_replay1 -> - let uu___36 = - FStar_Syntax_Embeddings_Base.try_unembed - e_bool no_smt norm in - FStar_Compiler_Util.bind_opt - uu___36 - (fun no_smt1 -> - let uu___37 = - FStar_Syntax_Embeddings_Base.try_unembed - e_fsint quake_lo norm in - FStar_Compiler_Util.bind_opt - uu___37 - (fun quake_lo1 -> - let uu___38 = - FStar_Syntax_Embeddings_Base.try_unembed - e_fsint quake_hi - norm in - FStar_Compiler_Util.bind_opt - uu___38 - (fun quake_hi1 -> - let uu___39 = - FStar_Syntax_Embeddings_Base.try_unembed - e_bool - quake_keep norm in - FStar_Compiler_Util.bind_opt - uu___39 - (fun quake_keep1 - -> - let uu___40 = - FStar_Syntax_Embeddings_Base.try_unembed - e_bool - retry norm in - FStar_Compiler_Util.bind_opt - uu___40 - (fun retry1 - -> - let uu___41 - = - FStar_Syntax_Embeddings_Base.try_unembed - e_bool - smtencoding_elim_box - norm in - FStar_Compiler_Util.bind_opt - uu___41 - (fun - smtencoding_elim_box1 - -> - let uu___42 - = - FStar_Syntax_Embeddings_Base.try_unembed - e_string - smtencoding_nl_arith_repr - norm in - FStar_Compiler_Util.bind_opt - uu___42 - (fun - smtencoding_nl_arith_repr1 - -> - let uu___43 - = - FStar_Syntax_Embeddings_Base.try_unembed - e_string - smtencoding_l_arith_repr - norm in - FStar_Compiler_Util.bind_opt - uu___43 - (fun - smtencoding_l_arith_repr1 - -> - let uu___44 - = - FStar_Syntax_Embeddings_Base.try_unembed - e_bool - smtencoding_valid_intro - norm in - FStar_Compiler_Util.bind_opt - uu___44 - (fun - smtencoding_valid_intro1 - -> - let uu___45 - = - FStar_Syntax_Embeddings_Base.try_unembed - e_bool - smtencoding_valid_elim - norm in - FStar_Compiler_Util.bind_opt - uu___45 - (fun - smtencoding_valid_elim1 - -> - let uu___46 - = - FStar_Syntax_Embeddings_Base.try_unembed - e_bool - tcnorm - norm in - FStar_Compiler_Util.bind_opt - uu___46 - (fun - tcnorm1 - -> - let uu___47 - = - FStar_Syntax_Embeddings_Base.try_unembed - e_bool - no_plugins - norm in - FStar_Compiler_Util.bind_opt - uu___47 - (fun - no_plugins1 - -> - let uu___48 - = - FStar_Syntax_Embeddings_Base.try_unembed - e_bool - no_tactics - norm in - FStar_Compiler_Util.bind_opt - uu___48 - (fun - no_tactics1 - -> - let uu___49 - = - FStar_Syntax_Embeddings_Base.try_unembed - e_string_list - z3cliopt - norm in - FStar_Compiler_Util.bind_opt - uu___49 - (fun - z3cliopt1 - -> - let uu___50 - = - FStar_Syntax_Embeddings_Base.try_unembed - e_string_list - z3smtopt - norm in - FStar_Compiler_Util.bind_opt - uu___50 - (fun - z3smtopt1 - -> - let uu___51 - = - FStar_Syntax_Embeddings_Base.try_unembed - e_bool - z3refresh - norm in - FStar_Compiler_Util.bind_opt - uu___51 - (fun - z3refresh1 - -> - let uu___52 - = - FStar_Syntax_Embeddings_Base.try_unembed - e_fsint - z3rlimit - norm in - FStar_Compiler_Util.bind_opt - uu___52 - (fun - z3rlimit1 - -> - let uu___53 - = - FStar_Syntax_Embeddings_Base.try_unembed - e_fsint - z3rlimit_factor - norm in - FStar_Compiler_Util.bind_opt - uu___53 - (fun - z3rlimit_factor1 - -> - let uu___54 - = - FStar_Syntax_Embeddings_Base.try_unembed - e_fsint - z3seed - norm in - FStar_Compiler_Util.bind_opt - uu___54 - (fun - z3seed1 - -> - let uu___55 - = - FStar_Syntax_Embeddings_Base.try_unembed - e_string - z3version - norm in - FStar_Compiler_Util.bind_opt - uu___55 - (fun - z3version1 - -> - let uu___56 - = - FStar_Syntax_Embeddings_Base.try_unembed - e_bool - trivial_pre_for_unannotated_effectful_fns - norm in - FStar_Compiler_Util.bind_opt - uu___56 - (fun - trivial_pre_for_unannotated_effectful_fns1 - -> - let uu___57 - = - FStar_Syntax_Embeddings_Base.try_unembed - (e_option - e_string) - reuse_hint_for - norm in - FStar_Compiler_Util.bind_opt - uu___57 - (fun - reuse_hint_for1 - -> - FStar_Pervasives_Native.Some - { - FStar_VConfig.initial_fuel - = - initial_fuel1; - FStar_VConfig.max_fuel - = - max_fuel1; - FStar_VConfig.initial_ifuel - = - initial_ifuel1; - FStar_VConfig.max_ifuel - = - max_ifuel1; - FStar_VConfig.detail_errors - = - detail_errors1; - FStar_VConfig.detail_hint_replay - = - detail_hint_replay1; - FStar_VConfig.no_smt - = no_smt1; - FStar_VConfig.quake_lo - = - quake_lo1; - FStar_VConfig.quake_hi - = - quake_hi1; - FStar_VConfig.quake_keep - = - quake_keep1; - FStar_VConfig.retry - = retry1; - FStar_VConfig.smtencoding_elim_box - = - smtencoding_elim_box1; - FStar_VConfig.smtencoding_nl_arith_repr - = - smtencoding_nl_arith_repr1; - FStar_VConfig.smtencoding_l_arith_repr - = - smtencoding_l_arith_repr1; - FStar_VConfig.smtencoding_valid_intro - = - smtencoding_valid_intro1; - FStar_VConfig.smtencoding_valid_elim - = - smtencoding_valid_elim1; - FStar_VConfig.tcnorm - = tcnorm1; - FStar_VConfig.no_plugins - = - no_plugins1; - FStar_VConfig.no_tactics - = - no_tactics1; - FStar_VConfig.z3cliopt - = - z3cliopt1; - FStar_VConfig.z3smtopt - = - z3smtopt1; - FStar_VConfig.z3refresh - = - z3refresh1; - FStar_VConfig.z3rlimit - = - z3rlimit1; - FStar_VConfig.z3rlimit_factor - = - z3rlimit_factor1; - FStar_VConfig.z3seed - = z3seed1; - FStar_VConfig.z3version - = - z3version1; - FStar_VConfig.trivial_pre_for_unannotated_effectful_fns - = - trivial_pre_for_unannotated_effectful_fns1; - FStar_VConfig.reuse_hint_for - = - reuse_hint_for1 - })))))))))))))))))))))))))))) - | uu___2 -> FStar_Pervasives_Native.None) in - FStar_Syntax_Embeddings_Base.mk_emb_full em un - (fun uu___ -> FStar_Syntax_Syntax.t_vconfig) (fun uu___ -> "vconfig") - (fun uu___ -> - let uu___1 = - let uu___2 = - FStar_Ident.string_of_lid FStar_Parser_Const.vconfig_lid in - (uu___2, []) in - FStar_Syntax_Syntax.ET_app uu___1) -let (e_order : FStar_Order.order FStar_Syntax_Embeddings_Base.embedding) = - let ord_Lt_lid = - FStar_Ident.lid_of_path ["FStar"; "Order"; "Lt"] - FStar_Compiler_Range_Type.dummyRange in - let ord_Eq_lid = - FStar_Ident.lid_of_path ["FStar"; "Order"; "Eq"] - FStar_Compiler_Range_Type.dummyRange in - let ord_Gt_lid = - FStar_Ident.lid_of_path ["FStar"; "Order"; "Gt"] - FStar_Compiler_Range_Type.dummyRange in - let ord_Lt = FStar_Syntax_Syntax.tdataconstr ord_Lt_lid in - let ord_Eq = FStar_Syntax_Syntax.tdataconstr ord_Eq_lid in - let ord_Gt = FStar_Syntax_Syntax.tdataconstr ord_Gt_lid in - let ord_Lt_fv = - FStar_Syntax_Syntax.lid_as_fv ord_Lt_lid - (FStar_Pervasives_Native.Some FStar_Syntax_Syntax.Data_ctor) in - let ord_Eq_fv = - FStar_Syntax_Syntax.lid_as_fv ord_Eq_lid - (FStar_Pervasives_Native.Some FStar_Syntax_Syntax.Data_ctor) in - let ord_Gt_fv = - FStar_Syntax_Syntax.lid_as_fv ord_Gt_lid - (FStar_Pervasives_Native.Some FStar_Syntax_Syntax.Data_ctor) in - let embed_order o rng shadow cb = - let r = - match o with - | FStar_Order.Lt -> ord_Lt - | FStar_Order.Eq -> ord_Eq - | FStar_Order.Gt -> ord_Gt in - { - FStar_Syntax_Syntax.n = (r.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = rng; - FStar_Syntax_Syntax.vars = (r.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = (r.FStar_Syntax_Syntax.hash_code) - } in - let unembed_order t cb = - let t1 = FStar_Syntax_Util.unascribe t in - let uu___ = FStar_Syntax_Util.head_and_args t1 in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst hd in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv ord_Lt_lid -> - FStar_Pervasives_Native.Some FStar_Order.Lt - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv ord_Eq_lid -> - FStar_Pervasives_Native.Some FStar_Order.Eq - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv ord_Gt_lid -> - FStar_Pervasives_Native.Some FStar_Order.Gt - | uu___2 -> FStar_Pervasives_Native.None) in - let uu___ = - FStar_Syntax_Syntax.lid_as_fv FStar_Parser_Const.order_lid - FStar_Pervasives_Native.None in - FStar_Syntax_Embeddings_Base.mk_emb embed_order unembed_order uu___ -let or_else : 'a . 'a FStar_Pervasives_Native.option -> (unit -> 'a) -> 'a = - fun f -> - fun g -> - match f with - | FStar_Pervasives_Native.Some x -> x - | FStar_Pervasives_Native.None -> g () -let e_arrow : - 'a 'b . - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'b FStar_Syntax_Embeddings_Base.embedding -> - ('a -> 'b) FStar_Syntax_Embeddings_Base.embedding - = - fun ea -> - fun eb -> - let typ uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = FStar_Syntax_Embeddings_Base.type_of ea in - FStar_Syntax_Syntax.null_bv uu___6 in - FStar_Syntax_Syntax.mk_binder uu___5 in - [uu___4] in - let uu___4 = - let uu___5 = FStar_Syntax_Embeddings_Base.type_of eb in - FStar_Syntax_Syntax.mk_Total uu___5 in - { - FStar_Syntax_Syntax.bs1 = uu___3; - FStar_Syntax_Syntax.comp = uu___4 - } in - FStar_Syntax_Syntax.Tm_arrow uu___2 in - FStar_Syntax_Syntax.mk uu___1 FStar_Compiler_Range_Type.dummyRange in - let emb_t_arr_a_b uu___ = - let uu___1 = - let uu___2 = FStar_Syntax_Embeddings_Base.emb_typ_of ea () in - let uu___3 = FStar_Syntax_Embeddings_Base.emb_typ_of eb () in - (uu___2, uu___3) in - FStar_Syntax_Syntax.ET_fun uu___1 in - let printer1 f = "" in - let em f rng shadow_f norm = - lazy_embed printer1 emb_t_arr_a_b rng typ f - (fun uu___ -> - let uu___1 = force_shadow shadow_f in - match uu___1 with - | FStar_Pervasives_Native.None -> - FStar_Compiler_Effect.raise Embedding_failure - | FStar_Pervasives_Native.Some repr_f -> - ((let uu___3 = - FStar_Compiler_Effect.op_Bang - FStar_Options.debug_embedding in - if uu___3 - then - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - repr_f in - let uu___5 = FStar_Compiler_Util.stack_dump () in - FStar_Compiler_Util.print2 - "e_arrow forced back to term using shadow %s; repr=%s\n" - uu___4 uu___5 - else ()); - (let res = norm (FStar_Pervasives.Inr repr_f) in - (let uu___4 = - FStar_Compiler_Effect.op_Bang - FStar_Options.debug_embedding in - if uu___4 - then - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term repr_f in - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term res in - let uu___7 = FStar_Compiler_Util.stack_dump () in - FStar_Compiler_Util.print3 - "e_arrow forced back to term using shadow %s; repr=%s\n\t%s\n" - uu___5 uu___6 uu___7 - else ()); - res))) in - let un f norm = - lazy_unembed printer1 emb_t_arr_a_b f typ - (fun f1 -> - let f_wrapped a1 = - (let uu___1 = - FStar_Compiler_Effect.op_Bang FStar_Options.debug_embedding in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term f1 in - let uu___3 = FStar_Compiler_Util.stack_dump () in - FStar_Compiler_Util.print2 - "Calling back into normalizer for %s\n%s\n" uu___2 uu___3 - else ()); - (let a_tm = - let uu___1 = FStar_Syntax_Embeddings_Base.embed ea a1 in - uu___1 f1.FStar_Syntax_Syntax.pos - FStar_Pervasives_Native.None norm in - let b_tm = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Syntax.as_arg a_tm in - [uu___4] in - FStar_Syntax_Syntax.mk_Tm_app f1 uu___3 - f1.FStar_Syntax_Syntax.pos in - FStar_Pervasives.Inr uu___2 in - norm uu___1 in - let uu___1 = - FStar_Syntax_Embeddings_Base.unembed eb b_tm norm in - match uu___1 with - | FStar_Pervasives_Native.None -> - FStar_Compiler_Effect.raise Unembedding_failure - | FStar_Pervasives_Native.Some b1 -> b1) in - FStar_Pervasives_Native.Some f_wrapped) in - FStar_Syntax_Embeddings_Base.mk_emb_full em un typ printer1 - emb_t_arr_a_b -let e_sealed : - 'a . - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'a FStar_Compiler_Sealed.sealed FStar_Syntax_Embeddings_Base.embedding - = - fun ea -> - let typ uu___ = - let uu___1 = FStar_Syntax_Embeddings_Base.type_of ea in - FStar_Syntax_Syntax.t_sealed_of uu___1 in - let emb_ty_a uu___ = - let uu___1 = - let uu___2 = FStar_Ident.string_of_lid FStar_Parser_Const.sealed_lid in - let uu___3 = - let uu___4 = FStar_Syntax_Embeddings_Base.emb_typ_of ea () in - [uu___4] in - (uu___2, uu___3) in - FStar_Syntax_Syntax.ET_app uu___1 in - let printer1 x = - let uu___ = - let uu___1 = - let uu___2 = FStar_Syntax_Embeddings_Base.printer_of ea in - uu___2 (FStar_Compiler_Sealed.unseal x) in - Prims.strcat uu___1 ")" in - Prims.strcat "(seal " uu___ in - let em a1 rng shadow norm = - let shadow_a = - map_shadow shadow - (fun t -> - let unseal = - FStar_Syntax_Util.fvar_const FStar_Parser_Const.unseal_lid in - let uu___ = - FStar_Syntax_Syntax.mk_Tm_uinst unseal - [FStar_Syntax_Syntax.U_zero] in - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Embeddings_Base.type_of ea in - FStar_Syntax_Syntax.iarg uu___3 in - let uu___3 = - let uu___4 = FStar_Syntax_Syntax.as_arg t in [uu___4] in - uu___2 :: uu___3 in - FStar_Syntax_Syntax.mk_Tm_app uu___ uu___1 rng) in - let uu___ = - let uu___1 = FStar_Syntax_Util.fvar_const FStar_Parser_Const.seal_lid in - FStar_Syntax_Syntax.mk_Tm_uinst uu___1 [FStar_Syntax_Syntax.U_zero] in - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Embeddings_Base.type_of ea in - FStar_Syntax_Syntax.iarg uu___3 in - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Embeddings_Base.embed ea - (FStar_Compiler_Sealed.unseal a1) in - uu___6 rng shadow_a norm in - FStar_Syntax_Syntax.as_arg uu___5 in - [uu___4] in - uu___2 :: uu___3 in - FStar_Syntax_Syntax.mk_Tm_app uu___ uu___1 rng in - let un uu___1 uu___ = - (fun t -> - fun norm -> - let uu___ = FStar_Syntax_Util.head_and_args_full t in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst hd in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, uu___2::(a1, uu___3)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.seal_lid - -> - Obj.magic - (Obj.repr - (let uu___4 = - FStar_Syntax_Embeddings_Base.try_unembed ea a1 - norm in - FStar_Class_Monad.fmap - FStar_Class_Monad.monad_option () () - (fun uu___5 -> - (Obj.magic FStar_Compiler_Sealed.seal) uu___5) - (Obj.magic uu___4))) - | uu___2 -> Obj.magic (Obj.repr FStar_Pervasives_Native.None))) - uu___1 uu___ in - FStar_Syntax_Embeddings_Base.mk_emb_full em un typ printer1 emb_ty_a -let (e___range : - FStar_Compiler_Range_Type.range FStar_Syntax_Embeddings_Base.embedding) = - let em r rng _shadow _norm = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_range r)) rng in - let un t _norm = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_range r) -> - FStar_Pervasives_Native.Some r - | uu___1 -> FStar_Pervasives_Native.None in - FStar_Syntax_Embeddings_Base.mk_emb_full em un - (fun uu___ -> FStar_Syntax_Syntax.t___range) - FStar_Compiler_Range_Ops.string_of_range - (fun uu___ -> - let uu___1 = - let uu___2 = FStar_Ident.string_of_lid FStar_Parser_Const.range_lid in - (uu___2, []) in - FStar_Syntax_Syntax.ET_app uu___1) -let (e_range : - FStar_Compiler_Range_Type.range FStar_Syntax_Embeddings_Base.embedding) = - FStar_Syntax_Embeddings_Base.embed_as (e_sealed e___range) - FStar_Compiler_Sealed.unseal FStar_Compiler_Sealed.seal - FStar_Pervasives_Native.None -let (e_issue : FStar_Errors.issue FStar_Syntax_Embeddings_Base.embedding) = - let uu___ = - FStar_Syntax_Syntax.fvar FStar_Parser_Const.issue_lid - FStar_Pervasives_Native.None in - FStar_Syntax_Embeddings_Base.e_lazy FStar_Syntax_Syntax.Lazy_issue uu___ -let (e_document : - FStar_Pprint.document FStar_Syntax_Embeddings_Base.embedding) = - let uu___ = - FStar_Syntax_Syntax.fvar FStar_Parser_Const.document_lid - FStar_Pervasives_Native.None in - FStar_Syntax_Embeddings_Base.e_lazy FStar_Syntax_Syntax.Lazy_doc uu___ -type abstract_term = - | Abstract of FStar_Syntax_Syntax.term -let (uu___is_Abstract : abstract_term -> Prims.bool) = fun projectee -> true -let (__proj__Abstract__item__t : abstract_term -> FStar_Syntax_Syntax.term) = - fun projectee -> match projectee with | Abstract t -> t -let arrow_as_prim_step_1 : - 'a 'b . - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'b FStar_Syntax_Embeddings_Base.embedding -> - ('a -> 'b) -> - FStar_Ident.lid -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option - = - fun ea -> - fun eb -> - fun f -> - fun fv_lid -> - fun norm -> - let rng = FStar_Ident.range_of_lid fv_lid in - let f_wrapped _us args = - let uu___ = args in - match uu___ with - | (x, uu___1)::[] -> - let shadow_app = - let uu___2 = - FStar_Thunk.mk - (fun uu___3 -> - let uu___4 = norm (FStar_Pervasives.Inl fv_lid) in - FStar_Syntax_Syntax.mk_Tm_app uu___4 args rng) in - FStar_Pervasives_Native.Some uu___2 in - let uu___2 = - let uu___3 = - FStar_Syntax_Embeddings_Base.try_unembed ea x norm in - FStar_Compiler_Util.map_opt uu___3 - (fun x1 -> - let uu___4 = - let uu___5 = f x1 in - FStar_Syntax_Embeddings_Base.embed eb uu___5 in - uu___4 rng shadow_app norm) in - (match uu___2 with - | FStar_Pervasives_Native.Some x1 -> - FStar_Pervasives_Native.Some x1 - | FStar_Pervasives_Native.None -> force_shadow shadow_app) in - f_wrapped -let arrow_as_prim_step_2 : - 'a 'b 'c . - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'b FStar_Syntax_Embeddings_Base.embedding -> - 'c FStar_Syntax_Embeddings_Base.embedding -> - ('a -> 'b -> 'c) -> - FStar_Ident.lid -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option - = - fun ea -> - fun eb -> - fun ec -> - fun f -> - fun fv_lid -> - fun norm -> - let rng = FStar_Ident.range_of_lid fv_lid in - let f_wrapped _us args = - let uu___ = args in - match uu___ with - | (x, uu___1)::(y, uu___2)::[] -> - let shadow_app = - let uu___3 = - FStar_Thunk.mk - (fun uu___4 -> - let uu___5 = norm (FStar_Pervasives.Inl fv_lid) in - FStar_Syntax_Syntax.mk_Tm_app uu___5 args rng) in - FStar_Pervasives_Native.Some uu___3 in - let uu___3 = - let uu___4 = - FStar_Syntax_Embeddings_Base.try_unembed ea x norm in - FStar_Compiler_Util.bind_opt uu___4 - (fun x1 -> - let uu___5 = - FStar_Syntax_Embeddings_Base.try_unembed eb y - norm in - FStar_Compiler_Util.bind_opt uu___5 - (fun y1 -> - let uu___6 = - let uu___7 = - let uu___8 = f x1 y1 in - FStar_Syntax_Embeddings_Base.embed ec - uu___8 in - uu___7 rng shadow_app norm in - FStar_Pervasives_Native.Some uu___6)) in - (match uu___3 with - | FStar_Pervasives_Native.Some x1 -> - FStar_Pervasives_Native.Some x1 - | FStar_Pervasives_Native.None -> - force_shadow shadow_app) in - f_wrapped -let arrow_as_prim_step_3 : - 'a 'b 'c 'd . - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'b FStar_Syntax_Embeddings_Base.embedding -> - 'c FStar_Syntax_Embeddings_Base.embedding -> - 'd FStar_Syntax_Embeddings_Base.embedding -> - ('a -> 'b -> 'c -> 'd) -> - FStar_Ident.lid -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option - = - fun ea -> - fun eb -> - fun ec -> - fun ed -> - fun f -> - fun fv_lid -> - fun norm -> - let rng = FStar_Ident.range_of_lid fv_lid in - let f_wrapped _us args = - let uu___ = args in - match uu___ with - | (x, uu___1)::(y, uu___2)::(z, uu___3)::[] -> - let shadow_app = - let uu___4 = - FStar_Thunk.mk - (fun uu___5 -> - let uu___6 = - norm (FStar_Pervasives.Inl fv_lid) in - FStar_Syntax_Syntax.mk_Tm_app uu___6 args rng) in - FStar_Pervasives_Native.Some uu___4 in - let uu___4 = - let uu___5 = - FStar_Syntax_Embeddings_Base.try_unembed ea x norm in - FStar_Compiler_Util.bind_opt uu___5 - (fun x1 -> - let uu___6 = - FStar_Syntax_Embeddings_Base.try_unembed eb y - norm in - FStar_Compiler_Util.bind_opt uu___6 - (fun y1 -> - let uu___7 = - FStar_Syntax_Embeddings_Base.try_unembed - ec z norm in - FStar_Compiler_Util.bind_opt uu___7 - (fun z1 -> - let uu___8 = - let uu___9 = - let uu___10 = f x1 y1 z1 in - FStar_Syntax_Embeddings_Base.embed - ed uu___10 in - uu___9 rng shadow_app norm in - FStar_Pervasives_Native.Some uu___8))) in - (match uu___4 with - | FStar_Pervasives_Native.Some x1 -> - FStar_Pervasives_Native.Some x1 - | FStar_Pervasives_Native.None -> - force_shadow shadow_app) in - f_wrapped -let debug_wrap : 'a . Prims.string -> (unit -> 'a) -> 'a = - fun s -> - fun f -> - (let uu___1 = - FStar_Compiler_Effect.op_Bang FStar_Options.debug_embedding in - if uu___1 - then FStar_Compiler_Util.print1 "++++starting %s\n" s - else ()); - (let res = f () in - (let uu___2 = - FStar_Compiler_Effect.op_Bang FStar_Options.debug_embedding in - if uu___2 - then FStar_Compiler_Util.print1 "------ending %s\n" s - else ()); - res) -let (e_abstract_term : abstract_term FStar_Syntax_Embeddings_Base.embedding) - = - FStar_Syntax_Embeddings_Base.embed_as e_any (fun x -> Abstract x) - (fun x -> match x with | Abstract x1 -> x1) FStar_Pervasives_Native.None \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_Embeddings_AppEmb.ml b/ocaml/fstar-lib/generated/FStar_Syntax_Embeddings_AppEmb.ml deleted file mode 100644 index ab8ebf0c3b8..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Syntax_Embeddings_AppEmb.ml +++ /dev/null @@ -1,87 +0,0 @@ -open Prims -type 'a appemb = - FStar_Syntax_Syntax.args -> - ('a * FStar_Syntax_Syntax.args) FStar_Pervasives_Native.option -let one : 'a . 'a FStar_Syntax_Embeddings_Base.embedding -> 'a appemb = - fun e -> - fun args -> - match args with - | (t, uu___)::xs -> - let uu___1 = - FStar_Syntax_Embeddings_Base.try_unembed e t - FStar_Syntax_Embeddings_Base.id_norm_cb in - (match uu___1 with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some v -> - FStar_Pervasives_Native.Some (v, xs)) -let op_let_Question : - 'uuuuu 'uuuuu1 . - 'uuuuu FStar_Pervasives_Native.option -> - ('uuuuu -> 'uuuuu1 FStar_Pervasives_Native.option) -> - 'uuuuu1 FStar_Pervasives_Native.option - = - fun o -> - fun f -> - match o with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some v -> f v -let op_Less_Star_Greater : - 'a 'b . ('a -> 'b) appemb -> 'a appemb -> 'b appemb = - fun u1 -> - fun u2 -> - fun args -> - let uu___ = u1 args in - op_let_Question uu___ - (fun uu___1 -> - match uu___1 with - | (f, args') -> - let uu___2 = u2 args' in - op_let_Question uu___2 - (fun uu___3 -> - match uu___3 with - | (v, args'') -> - let uu___4 = let uu___5 = f v in (uu___5, args'') in - FStar_Pervasives_Native.Some uu___4)) -let op_Less_Star_Star_Greater : - 'a 'b . - ('a -> 'b) appemb -> - 'a FStar_Syntax_Embeddings_Base.embedding -> 'b appemb - = fun u1 -> fun u2 -> let uu___ = one u2 in op_Less_Star_Greater u1 uu___ -let pure : 'a . 'a -> 'a appemb = - fun x -> fun args -> FStar_Pervasives_Native.Some (x, args) -let op_Less_Dollar_Greater : 'a 'b . ('a -> 'b) -> 'a appemb -> 'b appemb = - fun u1 -> fun u2 -> let uu___ = pure u1 in op_Less_Star_Greater uu___ u2 -let op_Less_Dollar_Dollar_Greater : - 'a 'b . - ('a -> 'b) -> 'a FStar_Syntax_Embeddings_Base.embedding -> 'b appemb - = - fun u1 -> - fun u2 -> - let uu___ = pure u1 in - let uu___1 = one u2 in op_Less_Star_Greater uu___ uu___1 -let run : - 'a . - FStar_Syntax_Syntax.args -> - 'a appemb -> 'a FStar_Pervasives_Native.option - = - fun args -> - fun u -> - let uu___ = u args in - match uu___ with - | FStar_Pervasives_Native.Some (r, []) -> - FStar_Pervasives_Native.Some r - | uu___1 -> FStar_Pervasives_Native.None -let wrap : - 'a . - (FStar_Syntax_Syntax.term -> 'a FStar_Pervasives_Native.option) -> - 'a appemb - = - fun f -> - fun args -> - match args with - | (t, uu___)::xs -> - let uu___1 = f t in - (match uu___1 with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some v -> - FStar_Pervasives_Native.Some (v, xs)) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_Embeddings_Base.ml b/ocaml/fstar-lib/generated/FStar_Syntax_Embeddings_Base.ml deleted file mode 100644 index a9ade7e74b6..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Syntax_Embeddings_Base.ml +++ /dev/null @@ -1,506 +0,0 @@ -open Prims -type norm_cb = - (FStar_Ident.lident, FStar_Syntax_Syntax.term) FStar_Pervasives.either -> - FStar_Syntax_Syntax.term -type shadow_term = - FStar_Syntax_Syntax.term FStar_Thunk.t FStar_Pervasives_Native.option -type embed_t = - FStar_Compiler_Range_Type.range -> - shadow_term -> norm_cb -> FStar_Syntax_Syntax.term -type 'a unembed_t = norm_cb -> 'a FStar_Pervasives_Native.option -type 'a raw_embedder = 'a -> embed_t -type 'a raw_unembedder = FStar_Syntax_Syntax.term -> 'a unembed_t -type 'a printer = 'a -> Prims.string -let (id_norm_cb : norm_cb) = - fun uu___ -> - match uu___ with - | FStar_Pervasives.Inr x -> x - | FStar_Pervasives.Inl l -> - let uu___1 = - FStar_Syntax_Syntax.lid_as_fv l FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___1 -exception Embedding_failure -let (uu___is_Embedding_failure : Prims.exn -> Prims.bool) = - fun projectee -> - match projectee with | Embedding_failure -> true | uu___ -> false -exception Unembedding_failure -let (uu___is_Unembedding_failure : Prims.exn -> Prims.bool) = - fun projectee -> - match projectee with | Unembedding_failure -> true | uu___ -> false -let (map_shadow : - shadow_term -> - (FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) -> shadow_term) - = fun s -> fun f -> FStar_Compiler_Util.map_opt s (FStar_Thunk.map f) -let (force_shadow : - shadow_term -> FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) = - fun s -> FStar_Compiler_Util.map_opt s FStar_Thunk.force -type 'a embedding = - { - em: 'a -> embed_t ; - un: FStar_Syntax_Syntax.term -> 'a unembed_t ; - print: 'a printer ; - typ: unit -> FStar_Syntax_Syntax.typ ; - e_typ: unit -> FStar_Syntax_Syntax.emb_typ } -let __proj__Mkembedding__item__em : 'a . 'a embedding -> 'a -> embed_t = - fun projectee -> - match projectee with | { em; un; print; typ; e_typ;_} -> em -let __proj__Mkembedding__item__un : - 'a . 'a embedding -> FStar_Syntax_Syntax.term -> 'a unembed_t = - fun projectee -> - match projectee with | { em; un; print; typ; e_typ;_} -> un -let __proj__Mkembedding__item__print : 'a . 'a embedding -> 'a printer = - fun projectee -> - match projectee with | { em; un; print; typ; e_typ;_} -> print -let __proj__Mkembedding__item__typ : - 'a . 'a embedding -> unit -> FStar_Syntax_Syntax.typ = - fun projectee -> - match projectee with | { em; un; print; typ; e_typ;_} -> typ -let __proj__Mkembedding__item__e_typ : - 'a . 'a embedding -> unit -> FStar_Syntax_Syntax.emb_typ = - fun projectee -> - match projectee with | { em; un; print; typ; e_typ;_} -> e_typ -let em : 'a . 'a embedding -> 'a -> embed_t = - fun projectee -> - match projectee with | { em = em1; un; print; typ; e_typ;_} -> em1 -let un : 'a . 'a embedding -> FStar_Syntax_Syntax.term -> 'a unembed_t = - fun projectee -> - match projectee with | { em = em1; un = un1; print; typ; e_typ;_} -> un1 -let print : 'a . 'a embedding -> 'a printer = - fun projectee -> - match projectee with - | { em = em1; un = un1; print = print1; typ; e_typ;_} -> print1 -let typ : 'a . 'a embedding -> unit -> FStar_Syntax_Syntax.typ = - fun projectee -> - match projectee with - | { em = em1; un = un1; print = print1; typ = typ1; e_typ;_} -> typ1 -let e_typ : 'a . 'a embedding -> unit -> FStar_Syntax_Syntax.emb_typ = - fun projectee -> - match projectee with - | { em = em1; un = un1; print = print1; typ = typ1; e_typ = e_typ1;_} -> - e_typ1 -let emb_typ_of : 'a . 'a embedding -> unit -> FStar_Syntax_Syntax.emb_typ = - fun e -> fun uu___ -> e.e_typ () -let unknown_printer : 'a . FStar_Syntax_Syntax.term -> 'a -> Prims.string = - fun typ1 -> - fun uu___ -> - let uu___1 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term typ1 in - FStar_Compiler_Util.format1 "unknown %s" uu___1 -let (term_as_fv : FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.fv) = - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_fvar fv -> fv - | uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.format1 "Embeddings not defined for type %s" - uu___3 in - failwith uu___2 -let mk_emb : - 'a . - 'a raw_embedder -> - 'a raw_unembedder -> FStar_Syntax_Syntax.fv -> 'a embedding - = - fun em1 -> - fun un1 -> - fun fv -> - { - em = em1; - un = un1; - print = - (fun x -> - let typ1 = FStar_Syntax_Syntax.fv_to_tm fv in - unknown_printer typ1 x); - typ = (fun uu___ -> FStar_Syntax_Syntax.fv_to_tm fv); - e_typ = - (fun uu___ -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.lid_of_fv fv in - FStar_Ident.string_of_lid uu___3 in - (uu___2, []) in - FStar_Syntax_Syntax.ET_app uu___1) - } -let mk_emb_full : - 'a . - 'a raw_embedder -> - 'a raw_unembedder -> - (unit -> FStar_Syntax_Syntax.typ) -> - ('a -> Prims.string) -> - (unit -> FStar_Syntax_Syntax.emb_typ) -> 'a embedding - = - fun em1 -> - fun un1 -> - fun typ1 -> - fun printe -> - fun emb_typ -> - { em = em1; un = un1; print = printe; typ = typ1; e_typ = emb_typ - } -let rec (unmeta_div_results : - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t'; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_monadic_lift - (src, dst, uu___1);_} - -> - let uu___2 = - (FStar_Ident.lid_equals src FStar_Parser_Const.effect_PURE_lid) && - (FStar_Ident.lid_equals dst FStar_Parser_Const.effect_DIV_lid) in - if uu___2 then unmeta_div_results t' else t - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t'; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_monadic - (m, uu___1);_} - -> - let uu___2 = - FStar_Ident.lid_equals m FStar_Parser_Const.effect_DIV_lid in - if uu___2 then unmeta_div_results t' else t - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t'; FStar_Syntax_Syntax.meta = uu___1;_} - -> unmeta_div_results t' - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t'; FStar_Syntax_Syntax.asc = uu___1; - FStar_Syntax_Syntax.eff_opt = uu___2;_} - -> unmeta_div_results t' - | uu___1 -> t -let type_of : 'a . 'a embedding -> FStar_Syntax_Syntax.typ = - fun e -> e.typ () -let printer_of : 'a . 'a embedding -> 'a printer = fun e -> e.print -let set_type : 'a . FStar_Syntax_Syntax.typ -> 'a embedding -> 'a embedding = - fun ty -> - fun e -> - { - em = (e.em); - un = (e.un); - print = (e.print); - typ = (fun uu___ -> ty); - e_typ = (e.e_typ) - } -let embed : 'a . 'a embedding -> 'a -> embed_t = fun e -> e.em -let try_unembed : - 'a . - 'a embedding -> - FStar_Syntax_Syntax.term -> - norm_cb -> 'a FStar_Pervasives_Native.option - = - fun e -> - fun t -> - fun n -> - let t1 = unmeta_div_results t in - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t1 in e.un uu___1 in - uu___ n -let unembed : - 'a . - 'a embedding -> - FStar_Syntax_Syntax.term -> - norm_cb -> 'a FStar_Pervasives_Native.option - = - fun e -> - fun t -> - fun n -> - let r = try_unembed e t n in - if FStar_Pervasives_Native.uu___is_None r - then - (let uu___1 = - let uu___2 = - let uu___3 = - FStar_Errors_Msg.text "Unembedding failed for type" in - let uu___4 = - let uu___5 = type_of e in - FStar_Class_PP.pp FStar_Syntax_Print.pretty_term uu___5 in - FStar_Pprint.op_Hat_Slash_Hat uu___3 uu___4 in - let uu___3 = - let uu___4 = - let uu___5 = FStar_Errors_Msg.text "emb_typ = " in - let uu___6 = - let uu___7 = - let uu___8 = emb_typ_of e () in - FStar_Class_Show.show - FStar_Syntax_Syntax.showable_emb_typ uu___8 in - FStar_Pprint.doc_of_string uu___7 in - FStar_Pprint.op_Hat_Slash_Hat uu___5 uu___6 in - let uu___5 = - let uu___6 = - let uu___7 = FStar_Errors_Msg.text "Term =" in - let uu___8 = - FStar_Class_PP.pp FStar_Syntax_Print.pretty_term t in - FStar_Pprint.op_Hat_Slash_Hat uu___7 uu___8 in - [uu___6] in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - FStar_Errors.log_issue (FStar_Syntax_Syntax.has_range_syntax ()) t - FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___1)) - else (); - r -let embed_as : - 'a 'b . - 'a embedding -> - ('a -> 'b) -> - ('b -> 'a) -> - FStar_Syntax_Syntax.typ FStar_Pervasives_Native.option -> - 'b embedding - = - fun ea -> - fun ab -> - fun ba -> - fun o -> - mk_emb_full (fun x -> let uu___ = ba x in embed ea uu___) - (fun t -> - fun cb -> - let uu___ = try_unembed ea t cb in - FStar_Compiler_Util.map_opt uu___ ab) - (fun uu___ -> - match o with - | FStar_Pervasives_Native.Some t -> t - | uu___1 -> type_of ea) - (fun x -> - let uu___ = let uu___1 = ba x in ea.print uu___1 in - FStar_Compiler_Util.format1 "(embed_as>> %s)\n" uu___) - ea.e_typ -let e_lazy : - 'a . - FStar_Syntax_Syntax.lazy_kind -> FStar_Syntax_Syntax.term -> 'a embedding - = - fun k -> - fun ty -> - let ee x rng _topt _norm = - FStar_Syntax_Util.mk_lazy x ty k (FStar_Pervasives_Native.Some rng) in - let uu t _norm = - let t0 = t in - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_lazy - { FStar_Syntax_Syntax.blob = b; - FStar_Syntax_Syntax.lkind = lkind; - FStar_Syntax_Syntax.ltyp = uu___1; - FStar_Syntax_Syntax.rng = uu___2;_} - when - FStar_Class_Deq.op_Equals_Question - FStar_Syntax_Syntax.deq_lazy_kind lkind k - -> - let uu___3 = FStar_Dyn.undyn b in - FStar_Pervasives_Native.Some uu___3 - | FStar_Syntax_Syntax.Tm_lazy - { FStar_Syntax_Syntax.blob = b; - FStar_Syntax_Syntax.lkind = lkind; - FStar_Syntax_Syntax.ltyp = uu___1; - FStar_Syntax_Syntax.rng = uu___2;_} - -> - ((let uu___4 = - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Syntax.showable_lazy_kind k in - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Syntax.showable_lazy_kind lkind in - let uu___7 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t0 in - FStar_Compiler_Util.format3 - "Warning, lazy unembedding failed, tag mismatch.\n\tExpected %s, got %s\n\tt = %s." - uu___5 uu___6 uu___7 in - FStar_Errors.log_issue - (FStar_Syntax_Syntax.has_range_syntax ()) t0 - FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4)); - FStar_Pervasives_Native.None) - | uu___1 -> FStar_Pervasives_Native.None in - let uu___ = term_as_fv ty in mk_emb ee uu uu___ -let lazy_embed : - 'a . - 'a printer -> - FStar_Syntax_Syntax.emb_typ -> - FStar_Compiler_Range_Type.range -> - FStar_Syntax_Syntax.term -> - 'a -> - (unit -> FStar_Syntax_Syntax.term) -> FStar_Syntax_Syntax.term - = - fun pa -> - fun et -> - fun rng -> - fun ta -> - fun x -> - fun f -> - (let uu___1 = - FStar_Compiler_Effect.op_Bang FStar_Options.debug_embedding in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term ta in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Syntax.showable_emb_typ - et in - let uu___4 = pa x in - FStar_Compiler_Util.print3 - "Embedding a %s\n\temb_typ=%s\n\tvalue is %s\n" uu___2 - uu___3 uu___4 - else ()); - (let uu___1 = - FStar_Compiler_Effect.op_Bang FStar_Options.eager_embedding in - if uu___1 - then f () - else - (let thunk = FStar_Thunk.mk f in - FStar_Syntax_Util.mk_lazy x FStar_Syntax_Syntax.tun - (FStar_Syntax_Syntax.Lazy_embedding (et, thunk)) - (FStar_Pervasives_Native.Some rng))) -let lazy_unembed : - 'a . - 'a printer -> - FStar_Syntax_Syntax.emb_typ -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term -> 'a FStar_Pervasives_Native.option) - -> 'a FStar_Pervasives_Native.option - = - fun pa -> - fun et -> - fun x -> - fun ta -> - fun f -> - let x1 = FStar_Syntax_Subst.compress x in - match x1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_lazy - { FStar_Syntax_Syntax.blob = b; - FStar_Syntax_Syntax.lkind = - FStar_Syntax_Syntax.Lazy_embedding (et', t); - FStar_Syntax_Syntax.ltyp = uu___; - FStar_Syntax_Syntax.rng = uu___1;_} - -> - let uu___2 = - (et <> et') || - (FStar_Compiler_Effect.op_Bang - FStar_Options.eager_embedding) in - if uu___2 - then - let res = let uu___3 = FStar_Thunk.force t in f uu___3 in - ((let uu___4 = - FStar_Compiler_Effect.op_Bang - FStar_Options.debug_embedding in - if uu___4 - then - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Syntax.showable_emb_typ et in - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Syntax.showable_emb_typ et' in - let uu___7 = - match res with - | FStar_Pervasives_Native.None -> "None" - | FStar_Pervasives_Native.Some x2 -> - let uu___8 = pa x2 in Prims.strcat "Some " uu___8 in - FStar_Compiler_Util.print3 - "Unembed cancellation failed\n\t%s <> %s\nvalue is %s\n" - uu___5 uu___6 uu___7 - else ()); - res) - else - (let a1 = FStar_Dyn.undyn b in - (let uu___5 = - FStar_Compiler_Effect.op_Bang - FStar_Options.debug_embedding in - if uu___5 - then - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Syntax.showable_emb_typ et in - let uu___7 = pa a1 in - FStar_Compiler_Util.print2 - "Unembed cancelled for %s\n\tvalue is %s\n" uu___6 - uu___7 - else ()); - FStar_Pervasives_Native.Some a1) - | uu___ -> - let aopt = f x1 in - ((let uu___2 = - FStar_Compiler_Effect.op_Bang - FStar_Options.debug_embedding in - if uu___2 - then - let uu___3 = - FStar_Class_Show.show - FStar_Syntax_Syntax.showable_emb_typ et in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - x1 in - let uu___5 = - match aopt with - | FStar_Pervasives_Native.None -> "None" - | FStar_Pervasives_Native.Some a1 -> - let uu___6 = pa a1 in Prims.strcat "Some " uu___6 in - FStar_Compiler_Util.print3 - "Unembedding:\n\temb_typ=%s\n\tterm is %s\n\tvalue is %s\n" - uu___3 uu___4 uu___5 - else ()); - aopt) -let op_let_Question : - 'uuuuu 'uuuuu1 . - 'uuuuu FStar_Pervasives_Native.option -> - ('uuuuu -> 'uuuuu1 FStar_Pervasives_Native.option) -> - 'uuuuu1 FStar_Pervasives_Native.option - = fun o -> fun f -> FStar_Compiler_Util.bind_opt o f -let mk_extracted_embedding : - 'a . - Prims.string -> - ((Prims.string * FStar_Syntax_Syntax.term Prims.list) -> - 'a FStar_Pervasives_Native.option) - -> ('a -> FStar_Syntax_Syntax.term) -> 'a embedding - = - fun name -> - fun u -> - fun e -> - let uu t _norm = - let uu___ = FStar_Syntax_Util.head_and_args t in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Util.un_uinst hd in - FStar_Syntax_Subst.compress uu___4 in - uu___3.FStar_Syntax_Syntax.n in - match uu___2 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - FStar_Pervasives_Native.Some - ((fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v) - | uu___3 -> FStar_Pervasives_Native.None in - op_let_Question uu___1 - (fun hd_lid -> - let uu___2 = - let uu___3 = FStar_Ident.string_of_lid hd_lid in - let uu___4 = - FStar_Compiler_List.map FStar_Pervasives_Native.fst - args in - (uu___3, uu___4) in - u uu___2) in - let ee x rng _topt _norm = e x in - let uu___ = - let uu___1 = FStar_Ident.lid_of_str name in - FStar_Syntax_Syntax.lid_as_fv uu___1 FStar_Pervasives_Native.None in - mk_emb ee uu uu___ -let extracted_embed : 'a . 'a embedding -> 'a -> FStar_Syntax_Syntax.term = - fun e -> - fun x -> - let uu___ = embed e x in - uu___ FStar_Compiler_Range_Type.dummyRange FStar_Pervasives_Native.None - id_norm_cb -let extracted_unembed : - 'a . - 'a embedding -> - FStar_Syntax_Syntax.term -> 'a FStar_Pervasives_Native.option - = fun e -> fun t -> try_unembed e t id_norm_cb \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_Formula.ml b/ocaml/fstar-lib/generated/FStar_Syntax_Formula.ml deleted file mode 100644 index 0add42448bd..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Syntax_Formula.ml +++ /dev/null @@ -1,458 +0,0 @@ -open Prims -type qpats = FStar_Syntax_Syntax.args Prims.list -type connective = - | QAll of (FStar_Syntax_Syntax.binders * qpats * FStar_Syntax_Syntax.typ) - | QEx of (FStar_Syntax_Syntax.binders * qpats * FStar_Syntax_Syntax.typ) - | BaseConn of (FStar_Ident.lident * FStar_Syntax_Syntax.args) -let (uu___is_QAll : connective -> Prims.bool) = - fun projectee -> match projectee with | QAll _0 -> true | uu___ -> false -let (__proj__QAll__item___0 : - connective -> - (FStar_Syntax_Syntax.binders * qpats * FStar_Syntax_Syntax.typ)) - = fun projectee -> match projectee with | QAll _0 -> _0 -let (uu___is_QEx : connective -> Prims.bool) = - fun projectee -> match projectee with | QEx _0 -> true | uu___ -> false -let (__proj__QEx__item___0 : - connective -> - (FStar_Syntax_Syntax.binders * qpats * FStar_Syntax_Syntax.typ)) - = fun projectee -> match projectee with | QEx _0 -> _0 -let (uu___is_BaseConn : connective -> Prims.bool) = - fun projectee -> - match projectee with | BaseConn _0 -> true | uu___ -> false -let (__proj__BaseConn__item___0 : - connective -> (FStar_Ident.lident * FStar_Syntax_Syntax.args)) = - fun projectee -> match projectee with | BaseConn _0 -> _0 -let (connective_to_string : connective -> Prims.string) = - fun c -> - match c with - | QAll p -> - let uu___ = - FStar_Class_Show.show - (FStar_Class_Show.show_tuple3 - (FStar_Class_Show.show_list FStar_Syntax_Print.showable_binder) - (FStar_Class_Show.show_list - (FStar_Class_Show.show_list - (FStar_Class_Show.show_tuple2 - FStar_Syntax_Print.showable_term - FStar_Syntax_Print.showable_aqual))) - FStar_Syntax_Print.showable_term) p in - Prims.strcat "QAll " uu___ - | QEx p -> - let uu___ = - FStar_Class_Show.show - (FStar_Class_Show.show_tuple3 - (FStar_Class_Show.show_list FStar_Syntax_Print.showable_binder) - (FStar_Class_Show.show_list - (FStar_Class_Show.show_list - (FStar_Class_Show.show_tuple2 - FStar_Syntax_Print.showable_term - FStar_Syntax_Print.showable_aqual))) - FStar_Syntax_Print.showable_term) p in - Prims.strcat "QEx " uu___ - | BaseConn p -> - let uu___ = - FStar_Class_Show.show - (FStar_Class_Show.show_tuple2 FStar_Ident.showable_lident - (FStar_Class_Show.show_list - (FStar_Class_Show.show_tuple2 - FStar_Syntax_Print.showable_term - FStar_Syntax_Print.showable_aqual))) p in - Prims.strcat "BaseConn" uu___ -let (showable_connective : connective FStar_Class_Show.showable) = - { FStar_Class_Show.show = connective_to_string } -let (destruct_base_table : - (Prims.int * (FStar_Ident.lident * FStar_Ident.lident) Prims.list) - Prims.list) - = - let f x = (x, x) in - [(Prims.int_zero, - [f FStar_Parser_Const.true_lid; f FStar_Parser_Const.false_lid]); - (Prims.int_one, [f FStar_Parser_Const.not_lid]); - ((Prims.of_int (2)), - [f FStar_Parser_Const.and_lid; - f FStar_Parser_Const.or_lid; - f FStar_Parser_Const.imp_lid; - f FStar_Parser_Const.iff_lid; - f FStar_Parser_Const.eq2_lid]); - ((Prims.of_int (3)), - [f FStar_Parser_Const.ite_lid; f FStar_Parser_Const.eq2_lid])] -let (destruct_sq_base_table : - (Prims.int * (FStar_Ident.lident * FStar_Ident.lident) Prims.list) - Prims.list) - = - [(Prims.int_zero, - [(FStar_Parser_Const.c_true_lid, FStar_Parser_Const.true_lid); - (FStar_Parser_Const.empty_type_lid, FStar_Parser_Const.false_lid)]); - ((Prims.of_int (2)), - [(FStar_Parser_Const.c_and_lid, FStar_Parser_Const.and_lid); - (FStar_Parser_Const.c_or_lid, FStar_Parser_Const.or_lid); - (FStar_Parser_Const.c_eq2_lid, FStar_Parser_Const.eq2_lid)]); - ((Prims.of_int (3)), - [(FStar_Parser_Const.c_eq2_lid, FStar_Parser_Const.eq2_lid)])] -let rec (unmeta_monadic : - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = - fun f -> - let f1 = FStar_Syntax_Subst.compress f in - match f1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_monadic uu___;_} - -> unmeta_monadic t - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_monadic_lift - uu___;_} - -> unmeta_monadic t - | uu___ -> f1 -let (lookup_arity_lid : - (Prims.int * (FStar_Ident.lident * FStar_Ident.lident) Prims.list) - Prims.list -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.args -> connective FStar_Pervasives_Native.option) - = - fun table -> - fun target_lid -> - fun args -> - let arg_len = FStar_Compiler_List.length args in - let aux uu___ = - match uu___ with - | (arity, lids) -> - if arg_len = arity - then - FStar_Compiler_Util.find_map lids - (fun uu___1 -> - match uu___1 with - | (lid, out_lid) -> - let uu___2 = FStar_Ident.lid_equals target_lid lid in - if uu___2 - then - FStar_Pervasives_Native.Some - (BaseConn (out_lid, args)) - else FStar_Pervasives_Native.None) - else FStar_Pervasives_Native.None in - FStar_Compiler_Util.find_map table aux -let (destruct_base_conn : - FStar_Syntax_Syntax.term -> connective FStar_Pervasives_Native.option) = - fun t -> - let uu___ = FStar_Syntax_Util.head_and_args t in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = FStar_Syntax_Util.un_uinst hd in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - lookup_arity_lid destruct_base_table - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v args - | uu___2 -> FStar_Pervasives_Native.None) -let (destruct_sq_base_conn : - FStar_Syntax_Syntax.term -> connective FStar_Pervasives_Native.option) = - fun uu___ -> - (fun t -> - let uu___ = FStar_Syntax_Util.un_squash t in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Class_Monad.monad_option () () - (Obj.magic uu___) - (fun uu___1 -> - (fun t1 -> - let t1 = Obj.magic t1 in - let t2 = FStar_Syntax_Util.unmeta t1 in - let uu___1 = FStar_Syntax_Util.head_and_args_full t2 in - match uu___1 with - | (hd, args) -> - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst hd in - uu___3.FStar_Syntax_Syntax.n in - (match uu___2 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - Obj.magic - (lookup_arity_lid destruct_sq_base_table - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - args) - | uu___3 -> Obj.magic FStar_Pervasives_Native.None)) - uu___1))) uu___ -let (patterns : - FStar_Syntax_Syntax.term -> - ((FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) - Prims.list Prims.list * FStar_Syntax_Syntax.term)) - = - fun t -> - let t1 = FStar_Syntax_Subst.compress t in - match t1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t2; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_pattern - (uu___, pats);_} - -> let uu___1 = FStar_Syntax_Subst.compress t2 in (pats, uu___1) - | uu___ -> ([], t1) -let (destruct_q_conn : - FStar_Syntax_Syntax.term -> connective FStar_Pervasives_Native.option) = - fun t -> - let is_q fa fv = - if fa - then - FStar_Syntax_Util.is_forall - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - else - FStar_Syntax_Util.is_exists - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - let flat t1 = - let uu___ = FStar_Syntax_Util.head_and_args t1 in - match uu___ with - | (t2, args) -> - let uu___1 = FStar_Syntax_Util.un_uinst t2 in - let uu___2 = - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with - | (t3, imp) -> - let uu___4 = FStar_Syntax_Util.unascribe t3 in - (uu___4, imp)) args in - (uu___1, uu___2) in - let rec aux qopt out t1 = - let uu___ = let uu___1 = flat t1 in (qopt, uu___1) in - match uu___ with - | (FStar_Pervasives_Native.Some fa, - ({ FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar tc; - FStar_Syntax_Syntax.pos = uu___1; - FStar_Syntax_Syntax.vars = uu___2; - FStar_Syntax_Syntax.hash_code = uu___3;_}, - ({ - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = b::[]; - FStar_Syntax_Syntax.body = t2; - FStar_Syntax_Syntax.rc_opt = uu___4;_}; - FStar_Syntax_Syntax.pos = uu___5; - FStar_Syntax_Syntax.vars = uu___6; - FStar_Syntax_Syntax.hash_code = uu___7;_}, - uu___8)::[])) - when is_q fa tc -> aux qopt (b :: out) t2 - | (FStar_Pervasives_Native.Some fa, - ({ FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar tc; - FStar_Syntax_Syntax.pos = uu___1; - FStar_Syntax_Syntax.vars = uu___2; - FStar_Syntax_Syntax.hash_code = uu___3;_}, - uu___4::({ - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = b::[]; - FStar_Syntax_Syntax.body = t2; - FStar_Syntax_Syntax.rc_opt = uu___5;_}; - FStar_Syntax_Syntax.pos = uu___6; - FStar_Syntax_Syntax.vars = uu___7; - FStar_Syntax_Syntax.hash_code = uu___8;_}, - uu___9)::[])) - when is_q fa tc -> aux qopt (b :: out) t2 - | (FStar_Pervasives_Native.None, - ({ FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar tc; - FStar_Syntax_Syntax.pos = uu___1; - FStar_Syntax_Syntax.vars = uu___2; - FStar_Syntax_Syntax.hash_code = uu___3;_}, - ({ - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = b::[]; - FStar_Syntax_Syntax.body = t2; - FStar_Syntax_Syntax.rc_opt = uu___4;_}; - FStar_Syntax_Syntax.pos = uu___5; - FStar_Syntax_Syntax.vars = uu___6; - FStar_Syntax_Syntax.hash_code = uu___7;_}, - uu___8)::[])) - when - FStar_Syntax_Util.is_qlid - (tc.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - -> - let uu___9 = - let uu___10 = - FStar_Syntax_Util.is_forall - (tc.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - FStar_Pervasives_Native.Some uu___10 in - aux uu___9 (b :: out) t2 - | (FStar_Pervasives_Native.None, - ({ FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar tc; - FStar_Syntax_Syntax.pos = uu___1; - FStar_Syntax_Syntax.vars = uu___2; - FStar_Syntax_Syntax.hash_code = uu___3;_}, - uu___4::({ - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = b::[]; - FStar_Syntax_Syntax.body = t2; - FStar_Syntax_Syntax.rc_opt = uu___5;_}; - FStar_Syntax_Syntax.pos = uu___6; - FStar_Syntax_Syntax.vars = uu___7; - FStar_Syntax_Syntax.hash_code = uu___8;_}, - uu___9)::[])) - when - FStar_Syntax_Util.is_qlid - (tc.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - -> - let uu___10 = - let uu___11 = - FStar_Syntax_Util.is_forall - (tc.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - FStar_Pervasives_Native.Some uu___11 in - aux uu___10 (b :: out) t2 - | (FStar_Pervasives_Native.Some b, uu___1) -> - let bs = FStar_Compiler_List.rev out in - let uu___2 = FStar_Syntax_Subst.open_term bs t1 in - (match uu___2 with - | (bs1, t2) -> - let uu___3 = patterns t2 in - (match uu___3 with - | (pats, body) -> - if b - then - FStar_Pervasives_Native.Some (QAll (bs1, pats, body)) - else FStar_Pervasives_Native.Some (QEx (bs1, pats, body)))) - | uu___1 -> FStar_Pervasives_Native.None in - aux FStar_Pervasives_Native.None [] t -let rec (destruct_sq_forall : - FStar_Syntax_Syntax.term -> connective FStar_Pervasives_Native.option) = - fun uu___ -> - (fun t -> - let uu___ = FStar_Syntax_Util.un_squash t in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Class_Monad.monad_option () () - (Obj.magic uu___) - (fun uu___1 -> - (fun t1 -> - let t1 = Obj.magic t1 in - let t2 = FStar_Syntax_Util.unmeta t1 in - let uu___1 = FStar_Syntax_Util.arrow_one t2 in - match uu___1 with - | FStar_Pervasives_Native.Some (b, c) -> - let uu___2 = - let uu___3 = FStar_Syntax_Util.is_tot_or_gtot_comp c in - Prims.op_Negation uu___3 in - if uu___2 - then Obj.magic FStar_Pervasives_Native.None - else - (let q = FStar_Syntax_Util.comp_result c in - let uu___4 = - FStar_Syntax_Util.is_free_in - b.FStar_Syntax_Syntax.binder_bv q in - if uu___4 - then - let uu___5 = patterns q in - match uu___5 with - | (pats, q1) -> - Obj.magic - (maybe_collect - (FStar_Pervasives_Native.Some - (QAll ([b], pats, q1)))) - else - (let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Syntax_Syntax.as_arg - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - let uu___10 = - let uu___11 = - FStar_Syntax_Syntax.as_arg q in - [uu___11] in - uu___9 :: uu___10 in - (FStar_Parser_Const.imp_lid, uu___8) in - BaseConn uu___7 in - Obj.magic (FStar_Pervasives_Native.Some uu___6))) - | uu___2 -> Obj.magic FStar_Pervasives_Native.None) uu___1))) - uu___ -and (destruct_sq_exists : - FStar_Syntax_Syntax.term -> connective FStar_Pervasives_Native.option) = - fun uu___ -> - (fun t -> - let uu___ = FStar_Syntax_Util.un_squash t in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Class_Monad.monad_option () () - (Obj.magic uu___) - (fun uu___1 -> - (fun t1 -> - let t1 = Obj.magic t1 in - let t2 = FStar_Syntax_Util.unmeta t1 in - let uu___1 = FStar_Syntax_Util.head_and_args_full t2 in - match uu___1 with - | (hd, args) -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Util.un_uinst hd in - uu___4.FStar_Syntax_Syntax.n in - (uu___3, args) in - (match uu___2 with - | (FStar_Syntax_Syntax.Tm_fvar fv, - (a1, uu___3)::(a2, uu___4)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.dtuple2_lid - -> - let uu___5 = - let uu___6 = FStar_Syntax_Subst.compress a2 in - uu___6.FStar_Syntax_Syntax.n in - (match uu___5 with - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = b::[]; - FStar_Syntax_Syntax.body = q; - FStar_Syntax_Syntax.rc_opt = uu___6;_} - -> - let uu___7 = - FStar_Syntax_Subst.open_term [b] q in - (match uu___7 with - | (bs, q1) -> - let b1 = - match bs with - | b2::[] -> b2 - | uu___8 -> failwith "impossible" in - let uu___8 = patterns q1 in - (match uu___8 with - | (pats, q2) -> - Obj.magic - (maybe_collect - (FStar_Pervasives_Native.Some - (QEx ([b1], pats, q2)))))) - | uu___6 -> - Obj.magic FStar_Pervasives_Native.None) - | uu___3 -> Obj.magic FStar_Pervasives_Native.None)) - uu___1))) uu___ -and (maybe_collect : - connective FStar_Pervasives_Native.option -> - connective FStar_Pervasives_Native.option) - = - fun f -> - match f with - | FStar_Pervasives_Native.Some (QAll (bs, pats, phi)) -> - let uu___ = destruct_sq_forall phi in - (match uu___ with - | FStar_Pervasives_Native.Some (QAll (bs', pats', psi)) -> - FStar_Pervasives_Native.Some - (QAll - ((FStar_Compiler_List.op_At bs bs'), - (FStar_Compiler_List.op_At pats pats'), psi)) - | uu___1 -> f) - | FStar_Pervasives_Native.Some (QEx (bs, pats, phi)) -> - let uu___ = destruct_sq_exists phi in - (match uu___ with - | FStar_Pervasives_Native.Some (QEx (bs', pats', psi)) -> - FStar_Pervasives_Native.Some - (QEx - ((FStar_Compiler_List.op_At bs bs'), - (FStar_Compiler_List.op_At pats pats'), psi)) - | uu___1 -> f) - | uu___ -> f -let (destruct_typ_as_formula : - FStar_Syntax_Syntax.term -> connective FStar_Pervasives_Native.option) = - fun f -> - let phi = unmeta_monadic f in - let r = - let uu___ = destruct_base_conn phi in - FStar_Compiler_Util.catch_opt uu___ - (fun uu___1 -> - let uu___2 = destruct_q_conn phi in - FStar_Compiler_Util.catch_opt uu___2 - (fun uu___3 -> - let uu___4 = destruct_sq_base_conn phi in - FStar_Compiler_Util.catch_opt uu___4 - (fun uu___5 -> - let uu___6 = destruct_sq_forall phi in - FStar_Compiler_Util.catch_opt uu___6 - (fun uu___7 -> - let uu___8 = destruct_sq_exists phi in - FStar_Compiler_Util.catch_opt uu___8 - (fun uu___9 -> FStar_Pervasives_Native.None))))) in - r \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_Free.ml b/ocaml/fstar-lib/generated/FStar_Syntax_Free.ml deleted file mode 100644 index 518b568cd7c..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Syntax_Free.ml +++ /dev/null @@ -1,754 +0,0 @@ -open Prims -let (compare_uv : - FStar_Syntax_Syntax.ctx_uvar -> FStar_Syntax_Syntax.ctx_uvar -> Prims.int) - = - fun uv1 -> - fun uv2 -> - let uu___ = - FStar_Syntax_Unionfind.uvar_id uv1.FStar_Syntax_Syntax.ctx_uvar_head in - let uu___1 = - FStar_Syntax_Unionfind.uvar_id uv2.FStar_Syntax_Syntax.ctx_uvar_head in - uu___ - uu___1 -let (compare_universe_uvar : - FStar_Syntax_Syntax.universe_uvar -> - FStar_Syntax_Syntax.universe_uvar -> Prims.int) - = - fun x -> - fun y -> - let uu___ = FStar_Syntax_Unionfind.univ_uvar_id x in - let uu___1 = FStar_Syntax_Unionfind.univ_uvar_id y in uu___ - uu___1 -let (deq_ctx_uvar : FStar_Syntax_Syntax.ctx_uvar FStar_Class_Deq.deq) = - { - FStar_Class_Deq.op_Equals_Question = - (fun u -> - fun v -> - let uu___ = - FStar_Syntax_Unionfind.uvar_id - u.FStar_Syntax_Syntax.ctx_uvar_head in - let uu___1 = - FStar_Syntax_Unionfind.uvar_id - v.FStar_Syntax_Syntax.ctx_uvar_head in - FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq FStar_Class_Ord.ord_int) uu___ uu___1) - } -let (ord_ctx_uvar : FStar_Syntax_Syntax.ctx_uvar FStar_Class_Ord.ord) = - { - FStar_Class_Ord.super = deq_ctx_uvar; - FStar_Class_Ord.cmp = - (fun u -> - fun v -> - let uu___ = - FStar_Syntax_Unionfind.uvar_id - u.FStar_Syntax_Syntax.ctx_uvar_head in - let uu___1 = - FStar_Syntax_Unionfind.uvar_id - v.FStar_Syntax_Syntax.ctx_uvar_head in - FStar_Class_Ord.cmp FStar_Class_Ord.ord_int uu___ uu___1) - } -let (deq_univ_uvar : FStar_Syntax_Syntax.universe_uvar FStar_Class_Deq.deq) = - { - FStar_Class_Deq.op_Equals_Question = - (fun u -> - fun v -> - let uu___ = FStar_Syntax_Unionfind.univ_uvar_id u in - let uu___1 = FStar_Syntax_Unionfind.univ_uvar_id v in - FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq FStar_Class_Ord.ord_int) uu___ uu___1) - } -let (ord_univ_uvar : FStar_Syntax_Syntax.universe_uvar FStar_Class_Ord.ord) = - { - FStar_Class_Ord.super = deq_univ_uvar; - FStar_Class_Ord.cmp = - (fun u -> - fun v -> - let uu___ = FStar_Syntax_Unionfind.univ_uvar_id u in - let uu___1 = FStar_Syntax_Unionfind.univ_uvar_id v in - FStar_Class_Ord.cmp FStar_Class_Ord.ord_int uu___ uu___1) - } -let (ctx_uvar_typ : - FStar_Syntax_Syntax.ctx_uvar -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun u -> - let uu___ = - FStar_Syntax_Unionfind.find_decoration - u.FStar_Syntax_Syntax.ctx_uvar_head in - uu___.FStar_Syntax_Syntax.uvar_decoration_typ -type use_cache_t = - | Def - | NoCache - | Full -let (uu___is_Def : use_cache_t -> Prims.bool) = - fun projectee -> match projectee with | Def -> true | uu___ -> false -let (uu___is_NoCache : use_cache_t -> Prims.bool) = - fun projectee -> match projectee with | NoCache -> true | uu___ -> false -let (uu___is_Full : use_cache_t -> Prims.bool) = - fun projectee -> match projectee with | Full -> true | uu___ -> false -type free_vars_and_fvars = - (FStar_Syntax_Syntax.free_vars * FStar_Ident.lident FStar_Compiler_RBSet.t) -let rec snoc : - 'a . 'a FStar_Class_Deq.deq -> 'a Prims.list -> 'a -> 'a Prims.list = - fun uu___ -> - fun xx -> - fun y -> - match xx with - | [] -> [y] - | x::xx' -> - let uu___1 = FStar_Class_Deq.op_Equals_Question uu___ x y in - if uu___1 - then xx - else (let uu___3 = snoc uu___ xx' y in x :: uu___3) -let op_At_At : - 'a . - 'a FStar_Class_Deq.deq -> 'a Prims.list -> 'a Prims.list -> 'a Prims.list - = - fun uu___ -> - fun xs -> - fun ys -> - FStar_Compiler_List.fold_left (fun xs1 -> fun y -> snoc uu___ xs1 y) - xs ys -let (no_free_vars : free_vars_and_fvars) = - let uu___ = - let uu___1 = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) ()) in - let uu___2 = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic (FStar_Compiler_FlatSet.setlike_flat_set ord_ctx_uvar)) - ()) in - let uu___3 = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic (FStar_Compiler_FlatSet.setlike_flat_set ord_univ_uvar)) - ()) in - let uu___4 = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_ident)) ()) in - { - FStar_Syntax_Syntax.free_names = uu___1; - FStar_Syntax_Syntax.free_uvars = uu___2; - FStar_Syntax_Syntax.free_univs = uu___3; - FStar_Syntax_Syntax.free_univ_names = uu___4 - } in - let uu___1 = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset FStar_Syntax_Syntax.ord_fv)) - ()) in - (uu___, uu___1) -let (singleton_fvar : FStar_Syntax_Syntax.fv -> free_vars_and_fvars) = - fun fv -> - let uu___ = - let uu___1 = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Syntax.ord_fv)) ()) in - Obj.magic - (FStar_Class_Setlike.add () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset FStar_Syntax_Syntax.ord_fv)) - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - (Obj.magic uu___1)) in - ((FStar_Pervasives_Native.fst no_free_vars), uu___) -let (singleton_bv : - FStar_Syntax_Syntax.bv -> - (FStar_Syntax_Syntax.free_vars * FStar_Ident.lident - FStar_Compiler_RBSet.t)) - = - fun x -> - let uu___ = - let uu___1 = FStar_Pervasives_Native.fst no_free_vars in - let uu___2 = - Obj.magic - (FStar_Class_Setlike.singleton () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) x) in - { - FStar_Syntax_Syntax.free_names = uu___2; - FStar_Syntax_Syntax.free_uvars = - (uu___1.FStar_Syntax_Syntax.free_uvars); - FStar_Syntax_Syntax.free_univs = - (uu___1.FStar_Syntax_Syntax.free_univs); - FStar_Syntax_Syntax.free_univ_names = - (uu___1.FStar_Syntax_Syntax.free_univ_names) - } in - (uu___, (FStar_Pervasives_Native.snd no_free_vars)) -let (singleton_uv : - FStar_Syntax_Syntax.ctx_uvar -> - (FStar_Syntax_Syntax.free_vars * FStar_Ident.lident - FStar_Compiler_RBSet.t)) - = - fun x -> - let uu___ = - let uu___1 = FStar_Pervasives_Native.fst no_free_vars in - let uu___2 = - Obj.magic - (FStar_Class_Setlike.singleton () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set ord_ctx_uvar)) x) in - { - FStar_Syntax_Syntax.free_names = - (uu___1.FStar_Syntax_Syntax.free_names); - FStar_Syntax_Syntax.free_uvars = uu___2; - FStar_Syntax_Syntax.free_univs = - (uu___1.FStar_Syntax_Syntax.free_univs); - FStar_Syntax_Syntax.free_univ_names = - (uu___1.FStar_Syntax_Syntax.free_univ_names) - } in - (uu___, (FStar_Pervasives_Native.snd no_free_vars)) -let (singleton_univ : - FStar_Syntax_Syntax.universe_uvar -> - (FStar_Syntax_Syntax.free_vars * FStar_Ident.lident - FStar_Compiler_RBSet.t)) - = - fun x -> - let uu___ = - let uu___1 = FStar_Pervasives_Native.fst no_free_vars in - let uu___2 = - Obj.magic - (FStar_Class_Setlike.singleton () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set ord_univ_uvar)) x) in - { - FStar_Syntax_Syntax.free_names = - (uu___1.FStar_Syntax_Syntax.free_names); - FStar_Syntax_Syntax.free_uvars = - (uu___1.FStar_Syntax_Syntax.free_uvars); - FStar_Syntax_Syntax.free_univs = uu___2; - FStar_Syntax_Syntax.free_univ_names = - (uu___1.FStar_Syntax_Syntax.free_univ_names) - } in - (uu___, (FStar_Pervasives_Native.snd no_free_vars)) -let (singleton_univ_name : - FStar_Syntax_Syntax.univ_name -> - (FStar_Syntax_Syntax.free_vars * FStar_Ident.lident - FStar_Compiler_RBSet.t)) - = - fun x -> - let uu___ = - let uu___1 = FStar_Pervasives_Native.fst no_free_vars in - let uu___2 = - Obj.magic - (FStar_Class_Setlike.singleton () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_ident)) x) in - { - FStar_Syntax_Syntax.free_names = - (uu___1.FStar_Syntax_Syntax.free_names); - FStar_Syntax_Syntax.free_uvars = - (uu___1.FStar_Syntax_Syntax.free_uvars); - FStar_Syntax_Syntax.free_univs = - (uu___1.FStar_Syntax_Syntax.free_univs); - FStar_Syntax_Syntax.free_univ_names = uu___2 - } in - (uu___, (FStar_Pervasives_Native.snd no_free_vars)) -let (op_Plus_Plus : - free_vars_and_fvars -> - free_vars_and_fvars -> - (FStar_Syntax_Syntax.free_vars * FStar_Ident.lident - FStar_Compiler_RBSet.t)) - = - fun f1 -> - fun f2 -> - let uu___ = - let uu___1 = - Obj.magic - (FStar_Class_Setlike.union () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) - (Obj.magic - (FStar_Pervasives_Native.fst f1).FStar_Syntax_Syntax.free_names) - (Obj.magic - (FStar_Pervasives_Native.fst f2).FStar_Syntax_Syntax.free_names)) in - let uu___2 = - Obj.magic - (FStar_Class_Setlike.union () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set ord_ctx_uvar)) - (Obj.magic - (FStar_Pervasives_Native.fst f1).FStar_Syntax_Syntax.free_uvars) - (Obj.magic - (FStar_Pervasives_Native.fst f2).FStar_Syntax_Syntax.free_uvars)) in - let uu___3 = - Obj.magic - (FStar_Class_Setlike.union () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set ord_univ_uvar)) - (Obj.magic - (FStar_Pervasives_Native.fst f1).FStar_Syntax_Syntax.free_univs) - (Obj.magic - (FStar_Pervasives_Native.fst f2).FStar_Syntax_Syntax.free_univs)) in - let uu___4 = - Obj.magic - (FStar_Class_Setlike.union () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_ident)) - (Obj.magic - (FStar_Pervasives_Native.fst f1).FStar_Syntax_Syntax.free_univ_names) - (Obj.magic - (FStar_Pervasives_Native.fst f2).FStar_Syntax_Syntax.free_univ_names)) in - { - FStar_Syntax_Syntax.free_names = uu___1; - FStar_Syntax_Syntax.free_uvars = uu___2; - FStar_Syntax_Syntax.free_univs = uu___3; - FStar_Syntax_Syntax.free_univ_names = uu___4 - } in - let uu___1 = - Obj.magic - (FStar_Class_Setlike.union () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Syntax.ord_fv)) - (Obj.magic (FStar_Pervasives_Native.snd f1)) - (Obj.magic (FStar_Pervasives_Native.snd f2))) in - (uu___, uu___1) -let rec (free_univs : FStar_Syntax_Syntax.universe -> free_vars_and_fvars) = - fun u -> - let uu___ = FStar_Syntax_Subst.compress_univ u in - match uu___ with - | FStar_Syntax_Syntax.U_zero -> no_free_vars - | FStar_Syntax_Syntax.U_bvar uu___1 -> no_free_vars - | FStar_Syntax_Syntax.U_unknown -> no_free_vars - | FStar_Syntax_Syntax.U_name uname -> singleton_univ_name uname - | FStar_Syntax_Syntax.U_succ u1 -> free_univs u1 - | FStar_Syntax_Syntax.U_max us -> - FStar_Compiler_List.fold_left - (fun out -> - fun x -> let uu___1 = free_univs x in op_Plus_Plus out uu___1) - no_free_vars us - | FStar_Syntax_Syntax.U_unif u1 -> singleton_univ u1 -let rec (free_names_and_uvs' : - FStar_Syntax_Syntax.term -> use_cache_t -> free_vars_and_fvars) = - fun tm -> - fun use_cache -> - let aux_binders bs from_body = - let from_binders = free_names_and_uvars_binders bs use_cache in - op_Plus_Plus from_binders from_body in - let t = FStar_Syntax_Subst.compress tm in - match t.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_delayed uu___ -> failwith "Impossible" - | FStar_Syntax_Syntax.Tm_name x -> singleton_bv x - | FStar_Syntax_Syntax.Tm_uvar (uv, (s, uu___)) -> - let uu___1 = singleton_uv uv in - let uu___2 = - if use_cache = Full - then - let uu___3 = ctx_uvar_typ uv in - free_names_and_uvars uu___3 use_cache - else no_free_vars in - op_Plus_Plus uu___1 uu___2 - | FStar_Syntax_Syntax.Tm_type u -> free_univs u - | FStar_Syntax_Syntax.Tm_bvar uu___ -> no_free_vars - | FStar_Syntax_Syntax.Tm_fvar fv -> singleton_fvar fv - | FStar_Syntax_Syntax.Tm_constant uu___ -> no_free_vars - | FStar_Syntax_Syntax.Tm_lazy uu___ -> no_free_vars - | FStar_Syntax_Syntax.Tm_unknown -> no_free_vars - | FStar_Syntax_Syntax.Tm_uinst (t1, us) -> - let f = free_names_and_uvars t1 use_cache in - FStar_Compiler_List.fold_left - (fun out -> - fun u -> let uu___ = free_univs u in op_Plus_Plus out uu___) f - us - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs; FStar_Syntax_Syntax.body = t1; - FStar_Syntax_Syntax.rc_opt = ropt;_} - -> - let uu___ = - let uu___1 = free_names_and_uvars t1 use_cache in - aux_binders bs uu___1 in - let uu___1 = - match ropt with - | FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.residual_effect = uu___2; - FStar_Syntax_Syntax.residual_typ = - FStar_Pervasives_Native.Some t2; - FStar_Syntax_Syntax.residual_flags = uu___3;_} - -> free_names_and_uvars t2 use_cache - | uu___2 -> no_free_vars in - op_Plus_Plus uu___ uu___1 - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; FStar_Syntax_Syntax.comp = c;_} -> - let uu___ = free_names_and_uvars_comp c use_cache in - aux_binders bs uu___ - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = bv; FStar_Syntax_Syntax.phi = t1;_} -> - let uu___ = - let uu___1 = FStar_Syntax_Syntax.mk_binder bv in [uu___1] in - let uu___1 = free_names_and_uvars t1 use_cache in - aux_binders uu___ uu___1 - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = t1; FStar_Syntax_Syntax.args = args;_} - -> - let uu___ = free_names_and_uvars t1 use_cache in - free_names_and_uvars_args args uu___ use_cache - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = t1; - FStar_Syntax_Syntax.ret_opt = asc_opt; - FStar_Syntax_Syntax.brs = pats; - FStar_Syntax_Syntax.rc_opt1 = rc_opt;_} - -> - let uu___ = - match rc_opt with - | FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.residual_effect = uu___1; - FStar_Syntax_Syntax.residual_typ = - FStar_Pervasives_Native.Some t2; - FStar_Syntax_Syntax.residual_flags = uu___2;_} - -> free_names_and_uvars t2 use_cache - | uu___1 -> no_free_vars in - let uu___1 = - let uu___2 = - let uu___3 = free_names_and_uvars t1 use_cache in - let uu___4 = - match asc_opt with - | FStar_Pervasives_Native.None -> no_free_vars - | FStar_Pervasives_Native.Some (b, asc) -> - let uu___5 = free_names_and_uvars_binders [b] use_cache in - let uu___6 = - free_names_and_uvars_ascription asc use_cache in - op_Plus_Plus uu___5 uu___6 in - op_Plus_Plus uu___3 uu___4 in - FStar_Compiler_List.fold_left - (fun n -> - fun uu___3 -> - match uu___3 with - | (p, wopt, t2) -> - let n1 = - match wopt with - | FStar_Pervasives_Native.None -> no_free_vars - | FStar_Pervasives_Native.Some w -> - free_names_and_uvars w use_cache in - let n2 = free_names_and_uvars t2 use_cache in - let n3 = - let uu___4 = FStar_Syntax_Syntax.pat_bvs p in - FStar_Compiler_List.fold_left - (fun n4 -> - fun x -> - let uu___5 = - free_names_and_uvars - x.FStar_Syntax_Syntax.sort use_cache in - op_Plus_Plus n4 uu___5) n uu___4 in - let uu___4 = op_Plus_Plus n3 n1 in - op_Plus_Plus uu___4 n2) uu___2 pats in - op_Plus_Plus uu___ uu___1 - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t1; FStar_Syntax_Syntax.asc = asc; - FStar_Syntax_Syntax.eff_opt = uu___;_} - -> - let uu___1 = free_names_and_uvars t1 use_cache in - let uu___2 = free_names_and_uvars_ascription asc use_cache in - op_Plus_Plus uu___1 uu___2 - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = lbs; FStar_Syntax_Syntax.body1 = t1;_} - -> - let uu___ = free_names_and_uvars t1 use_cache in - FStar_Compiler_List.fold_left - (fun n -> - fun lb -> - let uu___1 = - let uu___2 = - free_names_and_uvars lb.FStar_Syntax_Syntax.lbtyp - use_cache in - op_Plus_Plus n uu___2 in - let uu___2 = - free_names_and_uvars lb.FStar_Syntax_Syntax.lbdef - use_cache in - op_Plus_Plus uu___1 uu___2) uu___ - (FStar_Pervasives_Native.snd lbs) - | FStar_Syntax_Syntax.Tm_quoted (tm1, qi) -> - (match qi.FStar_Syntax_Syntax.qkind with - | FStar_Syntax_Syntax.Quote_static -> - FStar_Compiler_List.fold_left - (fun n -> - fun t1 -> - let uu___ = free_names_and_uvars t1 use_cache in - op_Plus_Plus n uu___) no_free_vars - (FStar_Pervasives_Native.snd - qi.FStar_Syntax_Syntax.antiquotations) - | FStar_Syntax_Syntax.Quote_dynamic -> - free_names_and_uvars tm1 use_cache) - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t1; FStar_Syntax_Syntax.meta = m;_} -> - let u1 = free_names_and_uvars t1 use_cache in - (match m with - | FStar_Syntax_Syntax.Meta_pattern (uu___, args) -> - FStar_Compiler_List.fold_right - (fun a -> - fun acc -> free_names_and_uvars_args a acc use_cache) - args u1 - | FStar_Syntax_Syntax.Meta_monadic (uu___, t') -> - let uu___1 = free_names_and_uvars t' use_cache in - op_Plus_Plus u1 uu___1 - | FStar_Syntax_Syntax.Meta_monadic_lift (uu___, uu___1, t') -> - let uu___2 = free_names_and_uvars t' use_cache in - op_Plus_Plus u1 uu___2 - | FStar_Syntax_Syntax.Meta_labeled uu___ -> u1 - | FStar_Syntax_Syntax.Meta_desugared uu___ -> u1 - | FStar_Syntax_Syntax.Meta_named uu___ -> u1) -and (free_names_and_uvars_binders : - FStar_Syntax_Syntax.binders -> use_cache_t -> free_vars_and_fvars) = - fun bs -> - fun use_cache -> - FStar_Compiler_List.fold_left - (fun n -> - fun b -> - let uu___ = - free_names_and_uvars - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort - use_cache in - op_Plus_Plus n uu___) no_free_vars bs -and (free_names_and_uvars_ascription : - ((FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax, - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax) - FStar_Pervasives.either * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax FStar_Pervasives_Native.option * Prims.bool) - -> use_cache_t -> free_vars_and_fvars) - = - fun asc -> - fun use_cache -> - let uu___ = asc in - match uu___ with - | (asc1, tacopt, uu___1) -> - let uu___2 = - match asc1 with - | FStar_Pervasives.Inl t -> free_names_and_uvars t use_cache - | FStar_Pervasives.Inr c -> free_names_and_uvars_comp c use_cache in - let uu___3 = - match tacopt with - | FStar_Pervasives_Native.None -> no_free_vars - | FStar_Pervasives_Native.Some tac -> - free_names_and_uvars tac use_cache in - op_Plus_Plus uu___2 uu___3 -and (free_names_and_uvars : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - use_cache_t -> free_vars_and_fvars) - = - fun t -> - fun use_cache -> - let t1 = FStar_Syntax_Subst.compress t in - let uu___ = FStar_Compiler_Effect.op_Bang t1.FStar_Syntax_Syntax.vars in - match uu___ with - | FStar_Pervasives_Native.Some n when - let uu___1 = should_invalidate_cache n use_cache in - Prims.op_Negation uu___1 -> - let uu___1 = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Syntax.ord_fv)) ()) in - (n, uu___1) - | uu___1 -> - (FStar_Compiler_Effect.op_Colon_Equals t1.FStar_Syntax_Syntax.vars - FStar_Pervasives_Native.None; - (let n = free_names_and_uvs' t1 use_cache in - if use_cache <> Full - then - FStar_Compiler_Effect.op_Colon_Equals - t1.FStar_Syntax_Syntax.vars - (FStar_Pervasives_Native.Some (FStar_Pervasives_Native.fst n)) - else (); - n)) -and (free_names_and_uvars_args : - (FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) - Prims.list -> free_vars_and_fvars -> use_cache_t -> free_vars_and_fvars) - = - fun args -> - fun acc -> - fun use_cache -> - FStar_Compiler_List.fold_left - (fun n -> - fun uu___ -> - match uu___ with - | (x, uu___1) -> - let uu___2 = free_names_and_uvars x use_cache in - op_Plus_Plus n uu___2) acc args -and (free_names_and_uvars_comp : - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> - use_cache_t -> free_vars_and_fvars) - = - fun c -> - fun use_cache -> - let uu___ = FStar_Compiler_Effect.op_Bang c.FStar_Syntax_Syntax.vars in - match uu___ with - | FStar_Pervasives_Native.Some n -> - let uu___1 = should_invalidate_cache n use_cache in - if uu___1 - then - (FStar_Compiler_Effect.op_Colon_Equals c.FStar_Syntax_Syntax.vars - FStar_Pervasives_Native.None; - free_names_and_uvars_comp c use_cache) - else - (let uu___3 = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Syntax.ord_fv)) ()) in - (n, uu___3)) - | uu___1 -> - let n = - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.GTotal t -> - free_names_and_uvars t use_cache - | FStar_Syntax_Syntax.Total t -> free_names_and_uvars t use_cache - | FStar_Syntax_Syntax.Comp ct -> - let decreases_vars = - let uu___2 = - FStar_Compiler_List.tryFind - (fun uu___3 -> - match uu___3 with - | FStar_Syntax_Syntax.DECREASES uu___4 -> true - | uu___4 -> false) ct.FStar_Syntax_Syntax.flags in - match uu___2 with - | FStar_Pervasives_Native.None -> no_free_vars - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.DECREASES dec_order) -> - free_names_and_uvars_dec_order dec_order use_cache in - let us = - let uu___2 = - free_names_and_uvars ct.FStar_Syntax_Syntax.result_typ - use_cache in - op_Plus_Plus uu___2 decreases_vars in - let us1 = - free_names_and_uvars_args - ct.FStar_Syntax_Syntax.effect_args us use_cache in - FStar_Compiler_List.fold_left - (fun us2 -> - fun u -> - let uu___2 = free_univs u in op_Plus_Plus us2 uu___2) - us1 ct.FStar_Syntax_Syntax.comp_univs in - (FStar_Compiler_Effect.op_Colon_Equals c.FStar_Syntax_Syntax.vars - (FStar_Pervasives_Native.Some (FStar_Pervasives_Native.fst n)); - n) -and (free_names_and_uvars_dec_order : - FStar_Syntax_Syntax.decreases_order -> use_cache_t -> free_vars_and_fvars) - = - fun dec_order -> - fun use_cache -> - match dec_order with - | FStar_Syntax_Syntax.Decreases_lex l -> - FStar_Compiler_List.fold_left - (fun acc -> - fun t -> - let uu___ = free_names_and_uvars t use_cache in - op_Plus_Plus acc uu___) no_free_vars l - | FStar_Syntax_Syntax.Decreases_wf (rel, e) -> - let uu___ = free_names_and_uvars rel use_cache in - let uu___1 = free_names_and_uvars e use_cache in - op_Plus_Plus uu___ uu___1 -and (should_invalidate_cache : - FStar_Syntax_Syntax.free_vars -> use_cache_t -> Prims.bool) = - fun n -> - fun use_cache -> - ((use_cache <> Def) || - (FStar_Class_Setlike.for_any () - (Obj.magic (FStar_Compiler_FlatSet.setlike_flat_set ord_ctx_uvar)) - (fun u -> - let uu___ = - FStar_Syntax_Unionfind.find - u.FStar_Syntax_Syntax.ctx_uvar_head in - match uu___ with - | FStar_Pervasives_Native.Some uu___1 -> true - | uu___1 -> false) - (Obj.magic n.FStar_Syntax_Syntax.free_uvars))) - || - (FStar_Class_Setlike.for_any () - (Obj.magic (FStar_Compiler_FlatSet.setlike_flat_set ord_univ_uvar)) - (fun u -> - let uu___ = FStar_Syntax_Unionfind.univ_find u in - match uu___ with - | FStar_Pervasives_Native.Some uu___1 -> true - | FStar_Pervasives_Native.None -> false) - (Obj.magic n.FStar_Syntax_Syntax.free_univs)) -let (names : - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.bv FStar_Compiler_FlatSet.t) - = - fun t -> - let uu___ = - let uu___1 = free_names_and_uvars t Def in - FStar_Pervasives_Native.fst uu___1 in - uu___.FStar_Syntax_Syntax.free_names -let (uvars : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.ctx_uvar FStar_Compiler_FlatSet.t) - = - fun t -> - let uu___ = - let uu___1 = free_names_and_uvars t Def in - FStar_Pervasives_Native.fst uu___1 in - uu___.FStar_Syntax_Syntax.free_uvars -let (univs : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.universe_uvar FStar_Compiler_FlatSet.t) - = - fun t -> - let uu___ = - let uu___1 = free_names_and_uvars t Def in - FStar_Pervasives_Native.fst uu___1 in - uu___.FStar_Syntax_Syntax.free_univs -let (univnames : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.univ_name FStar_Compiler_FlatSet.t) - = - fun t -> - let uu___ = - let uu___1 = free_names_and_uvars t Def in - FStar_Pervasives_Native.fst uu___1 in - uu___.FStar_Syntax_Syntax.free_univ_names -let (univnames_comp : - FStar_Syntax_Syntax.comp -> - FStar_Syntax_Syntax.univ_name FStar_Compiler_FlatSet.t) - = - fun c -> - let uu___ = - let uu___1 = free_names_and_uvars_comp c Def in - FStar_Pervasives_Native.fst uu___1 in - uu___.FStar_Syntax_Syntax.free_univ_names -let (fvars : - FStar_Syntax_Syntax.term -> FStar_Ident.lident FStar_Compiler_RBSet.t) = - fun t -> - let uu___ = free_names_and_uvars t NoCache in - FStar_Pervasives_Native.snd uu___ -let (names_of_binders : - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.bv FStar_Compiler_FlatSet.t) - = - fun bs -> - let uu___ = - let uu___1 = free_names_and_uvars_binders bs Def in - FStar_Pervasives_Native.fst uu___1 in - uu___.FStar_Syntax_Syntax.free_names -let (uvars_uncached : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.ctx_uvar FStar_Compiler_FlatSet.t) - = - fun t -> - let uu___ = - let uu___1 = free_names_and_uvars t NoCache in - FStar_Pervasives_Native.fst uu___1 in - uu___.FStar_Syntax_Syntax.free_uvars -let (uvars_full : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.ctx_uvar FStar_Compiler_FlatSet.t) - = - fun t -> - let uu___ = - let uu___1 = free_names_and_uvars t Full in - FStar_Pervasives_Native.fst uu___1 in - uu___.FStar_Syntax_Syntax.free_uvars \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_Hash.ml b/ocaml/fstar-lib/generated/FStar_Syntax_Hash.ml deleted file mode 100644 index 4596f69576e..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Syntax_Hash.ml +++ /dev/null @@ -1,1251 +0,0 @@ -open Prims -type 't mm = Prims.bool -> ('t * Prims.bool) -let op_let_Question : 's 't . 't mm -> ('t -> 's mm) -> 's mm = - fun f -> - fun g -> - fun b -> - let uu___ = f b in - match uu___ with | (t1, b1) -> let uu___1 = g t1 in uu___1 b1 -let ret : 't . 't -> 't mm = fun x -> fun b -> (x, b) -let (should_memo : Prims.bool mm) = fun b -> (b, b) -let (no_memo : unit mm) = fun uu___ -> ((), false) -let maybe_memoize : - 'a . - 'a FStar_Syntax_Syntax.syntax -> - ('a FStar_Syntax_Syntax.syntax -> FStar_Hash.hash_code mm) -> - FStar_Hash.hash_code mm - = - fun h -> - fun f -> - fun should_memo1 -> - if should_memo1 - then - let uu___ = - FStar_Compiler_Effect.op_Bang h.FStar_Syntax_Syntax.hash_code in - match uu___ with - | FStar_Pervasives_Native.Some c -> (c, should_memo1) - | FStar_Pervasives_Native.None -> - let uu___1 = let uu___2 = f h in uu___2 should_memo1 in - (match uu___1 with - | (c, should_memo2) -> - (if should_memo2 - then - FStar_Compiler_Effect.op_Colon_Equals - h.FStar_Syntax_Syntax.hash_code - (FStar_Pervasives_Native.Some c) - else (); - (c, should_memo2))) - else (let uu___1 = f h in uu___1 should_memo1) -let (of_int : Prims.int -> FStar_Hash.hash_code mm) = - fun i -> let uu___ = FStar_Hash.of_int i in ret uu___ -let (of_string : Prims.string -> FStar_Hash.hash_code mm) = - fun s -> let uu___ = FStar_Hash.of_string s in ret uu___ -let (mix : - FStar_Hash.hash_code mm -> - FStar_Hash.hash_code mm -> FStar_Hash.hash_code mm) - = - fun f -> - fun g -> - fun b -> - let uu___ = f b in - match uu___ with - | (x, b0) -> - let uu___1 = g b in - (match uu___1 with - | (y, b1) -> - let uu___2 = FStar_Hash.mix x y in (uu___2, (b0 && b1))) -let (nil_hc : FStar_Hash.hash_code mm) = of_int (Prims.of_int (1229)) -let (cons_hc : FStar_Hash.hash_code mm) = of_int (Prims.of_int (1231)) -let (mix_list : - FStar_Hash.hash_code mm Prims.list -> FStar_Hash.hash_code mm) = - fun l -> FStar_Compiler_List.fold_right mix l nil_hc -let (mix_list_lit : - FStar_Hash.hash_code mm Prims.list -> FStar_Hash.hash_code mm) = mix_list -let hash_list : - 'a . - ('a -> FStar_Hash.hash_code mm) -> - 'a Prims.list -> FStar_Hash.hash_code mm - = - fun h -> - fun ts -> let uu___ = FStar_Compiler_List.map h ts in mix_list uu___ -let hash_option : - 'a . - ('a -> FStar_Hash.hash_code mm) -> - 'a FStar_Pervasives_Native.option -> FStar_Hash.hash_code mm - = - fun h -> - fun o -> - match o with - | FStar_Pervasives_Native.None -> - let uu___ = FStar_Hash.of_int (Prims.of_int (1237)) in ret uu___ - | FStar_Pervasives_Native.Some o1 -> - let uu___ = - let uu___1 = FStar_Hash.of_int (Prims.of_int (1249)) in - ret uu___1 in - let uu___1 = h o1 in mix uu___ uu___1 -let (hash_doc : FStar_Pprint.document -> FStar_Hash.hash_code mm) = - fun d -> - let uu___ = - FStar_Pprint.pretty_string (FStar_Compiler_Util.float_of_string "1.0") - (Prims.of_int (80)) d in - of_string uu___ -let (hash_doc_list : - FStar_Pprint.document Prims.list -> FStar_Hash.hash_code mm) = - fun ds -> hash_list hash_doc ds -let hash_pair : - 'a 'b . - ('a -> FStar_Hash.hash_code mm) -> - ('b -> FStar_Hash.hash_code mm) -> ('a * 'b) -> FStar_Hash.hash_code mm - = - fun h -> - fun i -> - fun x -> - let uu___ = h (FStar_Pervasives_Native.fst x) in - let uu___1 = i (FStar_Pervasives_Native.snd x) in mix uu___ uu___1 -let rec (hash_term : FStar_Syntax_Syntax.term -> FStar_Hash.hash_code mm) = - fun t -> maybe_memoize t hash_term' -and (hash_comp : - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> - FStar_Hash.hash_code mm) - = fun c -> maybe_memoize c hash_comp' -and (hash_term' : FStar_Syntax_Syntax.term -> FStar_Hash.hash_code mm) = - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_bvar bv -> - let uu___1 = of_int (Prims.of_int (3)) in - let uu___2 = of_int bv.FStar_Syntax_Syntax.index in mix uu___1 uu___2 - | FStar_Syntax_Syntax.Tm_name bv -> - let uu___1 = of_int (Prims.of_int (5)) in - let uu___2 = of_int bv.FStar_Syntax_Syntax.index in mix uu___1 uu___2 - | FStar_Syntax_Syntax.Tm_fvar fv -> - let uu___1 = of_int (Prims.of_int (7)) in - let uu___2 = hash_fv fv in mix uu___1 uu___2 - | FStar_Syntax_Syntax.Tm_uinst (t1, us) -> - let uu___1 = of_int (Prims.of_int (11)) in - let uu___2 = - let uu___3 = hash_term t1 in - let uu___4 = hash_list hash_universe us in mix uu___3 uu___4 in - mix uu___1 uu___2 - | FStar_Syntax_Syntax.Tm_constant sc -> - let uu___1 = of_int (Prims.of_int (13)) in - let uu___2 = hash_constant sc in mix uu___1 uu___2 - | FStar_Syntax_Syntax.Tm_type u -> - let uu___1 = of_int (Prims.of_int (17)) in - let uu___2 = hash_universe u in mix uu___1 uu___2 - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs; FStar_Syntax_Syntax.body = t1; - FStar_Syntax_Syntax.rc_opt = rcopt;_} - -> - let uu___1 = of_int (Prims.of_int (19)) in - let uu___2 = - let uu___3 = hash_list hash_binder bs in - let uu___4 = - let uu___5 = hash_term t1 in - let uu___6 = hash_option hash_rc rcopt in mix uu___5 uu___6 in - mix uu___3 uu___4 in - mix uu___1 uu___2 - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; FStar_Syntax_Syntax.comp = c;_} -> - let uu___1 = of_int (Prims.of_int (23)) in - let uu___2 = - let uu___3 = hash_list hash_binder bs in - let uu___4 = hash_comp c in mix uu___3 uu___4 in - mix uu___1 uu___2 - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = b; FStar_Syntax_Syntax.phi = t1;_} -> - let uu___1 = of_int (Prims.of_int (29)) in - let uu___2 = - let uu___3 = hash_bv b in - let uu___4 = hash_term t1 in mix uu___3 uu___4 in - mix uu___1 uu___2 - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = t1; FStar_Syntax_Syntax.args = args;_} -> - let uu___1 = of_int (Prims.of_int (31)) in - let uu___2 = - let uu___3 = hash_term t1 in - let uu___4 = hash_list hash_arg args in mix uu___3 uu___4 in - mix uu___1 uu___2 - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = t1; - FStar_Syntax_Syntax.ret_opt = asc_opt; - FStar_Syntax_Syntax.brs = branches; - FStar_Syntax_Syntax.rc_opt1 = rcopt;_} - -> - let uu___1 = of_int (Prims.of_int (37)) in - let uu___2 = - let uu___3 = hash_option hash_match_returns asc_opt in - let uu___4 = - let uu___5 = - let uu___6 = hash_term t1 in - let uu___7 = hash_list hash_branch branches in - mix uu___6 uu___7 in - let uu___6 = hash_option hash_rc rcopt in mix uu___5 uu___6 in - mix uu___3 uu___4 in - mix uu___1 uu___2 - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t1; FStar_Syntax_Syntax.asc = a; - FStar_Syntax_Syntax.eff_opt = lopt;_} - -> - let uu___1 = of_int (Prims.of_int (43)) in - let uu___2 = - let uu___3 = hash_term t1 in - let uu___4 = - let uu___5 = hash_ascription a in - let uu___6 = hash_option hash_lid lopt in mix uu___5 uu___6 in - mix uu___3 uu___4 in - mix uu___1 uu___2 - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (false, lb::[]); - FStar_Syntax_Syntax.body1 = t1;_} - -> - let uu___1 = of_int (Prims.of_int (47)) in - let uu___2 = - let uu___3 = hash_lb lb in - let uu___4 = hash_term t1 in mix uu___3 uu___4 in - mix uu___1 uu___2 - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (uu___1, lbs); - FStar_Syntax_Syntax.body1 = t1;_} - -> - let uu___2 = of_int (Prims.of_int (51)) in - let uu___3 = - let uu___4 = hash_list hash_lb lbs in - let uu___5 = hash_term t1 in mix uu___4 uu___5 in - mix uu___2 uu___3 - | FStar_Syntax_Syntax.Tm_uvar uv -> - let uu___1 = of_int (Prims.of_int (53)) in - let uu___2 = hash_uvar uv in mix uu___1 uu___2 - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t1; FStar_Syntax_Syntax.meta = m;_} -> - let uu___1 = of_int (Prims.of_int (61)) in - let uu___2 = - let uu___3 = hash_term t1 in - let uu___4 = hash_meta m in mix uu___3 uu___4 in - mix uu___1 uu___2 - | FStar_Syntax_Syntax.Tm_lazy li -> - let uu___1 = of_int (Prims.of_int (67)) in - let uu___2 = hash_lazyinfo li in mix uu___1 uu___2 - | FStar_Syntax_Syntax.Tm_quoted (t1, qi) -> - let uu___1 = of_int (Prims.of_int (71)) in - let uu___2 = - let uu___3 = hash_term t1 in - let uu___4 = hash_quoteinfo qi in mix uu___3 uu___4 in - mix uu___1 uu___2 - | FStar_Syntax_Syntax.Tm_unknown -> of_int (Prims.of_int (73)) - | FStar_Syntax_Syntax.Tm_delayed uu___1 -> failwith "Impossible" -and (hash_comp' : FStar_Syntax_Syntax.comp -> FStar_Hash.hash_code mm) = - fun c -> - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total t -> - let uu___ = - let uu___1 = of_int (Prims.of_int (811)) in - let uu___2 = let uu___3 = hash_term t in [uu___3] in uu___1 :: - uu___2 in - mix_list_lit uu___ - | FStar_Syntax_Syntax.GTotal t -> - let uu___ = - let uu___1 = of_int (Prims.of_int (821)) in - let uu___2 = let uu___3 = hash_term t in [uu___3] in uu___1 :: - uu___2 in - mix_list_lit uu___ - | FStar_Syntax_Syntax.Comp ct -> - let uu___ = - let uu___1 = of_int (Prims.of_int (823)) in - let uu___2 = - let uu___3 = - hash_list hash_universe ct.FStar_Syntax_Syntax.comp_univs in - let uu___4 = - let uu___5 = hash_lid ct.FStar_Syntax_Syntax.effect_name in - let uu___6 = - let uu___7 = hash_term ct.FStar_Syntax_Syntax.result_typ in - let uu___8 = - let uu___9 = - hash_list hash_arg ct.FStar_Syntax_Syntax.effect_args in - let uu___10 = - let uu___11 = - hash_list hash_flag ct.FStar_Syntax_Syntax.flags in - [uu___11] in - uu___9 :: uu___10 in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mix_list_lit uu___ -and (hash_lb : FStar_Syntax_Syntax.letbinding -> FStar_Hash.hash_code mm) = - fun lb -> - let uu___ = - let uu___1 = of_int (Prims.of_int (79)) in - let uu___2 = - let uu___3 = hash_lbname lb.FStar_Syntax_Syntax.lbname in - let uu___4 = - let uu___5 = hash_list hash_ident lb.FStar_Syntax_Syntax.lbunivs in - let uu___6 = - let uu___7 = hash_term lb.FStar_Syntax_Syntax.lbtyp in - let uu___8 = - let uu___9 = hash_lid lb.FStar_Syntax_Syntax.lbeff in - let uu___10 = - let uu___11 = hash_term lb.FStar_Syntax_Syntax.lbdef in - let uu___12 = - let uu___13 = - hash_list hash_term lb.FStar_Syntax_Syntax.lbattrs in - [uu___13] in - uu___11 :: uu___12 in - uu___9 :: uu___10 in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mix_list_lit uu___ -and (hash_match_returns : - (FStar_Syntax_Syntax.binder * - ((FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax, - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax) - FStar_Pervasives.either * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax FStar_Pervasives_Native.option * Prims.bool)) - -> FStar_Hash.hash_code mm) - = - fun uu___ -> - match uu___ with - | (b, asc) -> - let uu___1 = hash_binder b in - let uu___2 = hash_ascription asc in mix uu___1 uu___2 -and (hash_branch : - (FStar_Syntax_Syntax.pat' FStar_Syntax_Syntax.withinfo_t * - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - FStar_Pervasives_Native.option * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax) -> FStar_Hash.hash_code mm) - = - fun b -> - let uu___ = b in - match uu___ with - | (p, topt, t) -> - let uu___1 = - let uu___2 = of_int (Prims.of_int (83)) in - let uu___3 = - let uu___4 = hash_pat p in - let uu___5 = - let uu___6 = hash_option hash_term topt in - let uu___7 = let uu___8 = hash_term t in [uu___8] in uu___6 :: - uu___7 in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - mix_list_lit uu___1 -and (hash_pat : - FStar_Syntax_Syntax.pat' FStar_Syntax_Syntax.withinfo_t -> - FStar_Hash.hash_code mm) - = - fun p -> - match p.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_constant c -> - let uu___ = of_int (Prims.of_int (89)) in - let uu___1 = hash_constant c in mix uu___ uu___1 - | FStar_Syntax_Syntax.Pat_cons (fv, us, args) -> - let uu___ = - let uu___1 = of_int (Prims.of_int (97)) in - let uu___2 = - let uu___3 = hash_fv fv in - let uu___4 = - let uu___5 = hash_option (hash_list hash_universe) us in - let uu___6 = - let uu___7 = hash_list (hash_pair hash_pat hash_bool) args in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mix_list_lit uu___ - | FStar_Syntax_Syntax.Pat_var bv -> - let uu___ = of_int (Prims.of_int (101)) in - let uu___1 = hash_bv bv in mix uu___ uu___1 - | FStar_Syntax_Syntax.Pat_dot_term t -> - let uu___ = - let uu___1 = of_int (Prims.of_int (107)) in - let uu___2 = let uu___3 = hash_option hash_term t in [uu___3] in - uu___1 :: uu___2 in - mix_list_lit uu___ -and (hash_bv : FStar_Syntax_Syntax.bv -> FStar_Hash.hash_code mm) = - fun b -> hash_term b.FStar_Syntax_Syntax.sort -and (hash_fv : FStar_Syntax_Syntax.fv -> FStar_Hash.hash_code mm) = - fun fv -> - let uu___ = - FStar_Ident.string_of_lid - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - of_string uu___ -and (hash_binder : FStar_Syntax_Syntax.binder -> FStar_Hash.hash_code mm) = - fun b -> - let uu___ = - let uu___1 = hash_bv b.FStar_Syntax_Syntax.binder_bv in - let uu___2 = - let uu___3 = hash_option hash_bqual b.FStar_Syntax_Syntax.binder_qual in - let uu___4 = - let uu___5 = hash_list hash_term b.FStar_Syntax_Syntax.binder_attrs in - [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mix_list_lit uu___ -and (hash_universe : FStar_Syntax_Syntax.universe -> FStar_Hash.hash_code mm) - = - fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.U_zero -> of_int (Prims.of_int (179)) - | FStar_Syntax_Syntax.U_succ u -> - let uu___1 = of_int (Prims.of_int (181)) in - let uu___2 = hash_universe u in mix uu___1 uu___2 - | FStar_Syntax_Syntax.U_max us -> - let uu___1 = of_int (Prims.of_int (191)) in - let uu___2 = hash_list hash_universe us in mix uu___1 uu___2 - | FStar_Syntax_Syntax.U_bvar i -> - let uu___1 = of_int (Prims.of_int (193)) in - let uu___2 = of_int i in mix uu___1 uu___2 - | FStar_Syntax_Syntax.U_name i -> - let uu___1 = of_int (Prims.of_int (197)) in - let uu___2 = hash_ident i in mix uu___1 uu___2 - | FStar_Syntax_Syntax.U_unif uv -> - let uu___1 = of_int (Prims.of_int (199)) in - let uu___2 = hash_universe_uvar uv in mix uu___1 uu___2 - | FStar_Syntax_Syntax.U_unknown -> of_int (Prims.of_int (211)) -and (hash_arg : - (FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) -> - FStar_Hash.hash_code mm) - = - fun uu___ -> - match uu___ with - | (t, aq) -> - let uu___1 = hash_term t in - let uu___2 = hash_option hash_arg_qualifier aq in mix uu___1 uu___2 -and (hash_arg_qualifier : - FStar_Syntax_Syntax.arg_qualifier -> FStar_Hash.hash_code mm) = - fun aq -> - let uu___ = hash_bool aq.FStar_Syntax_Syntax.aqual_implicit in - let uu___1 = hash_list hash_term aq.FStar_Syntax_Syntax.aqual_attributes in - mix uu___ uu___1 -and (hash_bqual : - FStar_Syntax_Syntax.binder_qualifier -> FStar_Hash.hash_code mm) = - fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.Implicit (true) -> of_int (Prims.of_int (419)) - | FStar_Syntax_Syntax.Implicit (false) -> of_int (Prims.of_int (421)) - | FStar_Syntax_Syntax.Meta t -> - let uu___1 = of_int (Prims.of_int (431)) in - let uu___2 = hash_term t in mix uu___1 uu___2 - | FStar_Syntax_Syntax.Equality -> of_int (Prims.of_int (433)) -and (hash_uvar : - (FStar_Syntax_Syntax.ctx_uvar * (FStar_Syntax_Syntax.subst_elt Prims.list - Prims.list * FStar_Syntax_Syntax.maybe_set_use_range)) -> - FStar_Hash.hash_code mm) - = - fun uu___ -> - match uu___ with - | (u, uu___1) -> - let uu___2 = - FStar_Syntax_Unionfind.uvar_id u.FStar_Syntax_Syntax.ctx_uvar_head in - of_int uu___2 -and (hash_universe_uvar : - (FStar_Syntax_Syntax.universe FStar_Pervasives_Native.option - FStar_Unionfind.p_uvar * FStar_Syntax_Syntax.version * - FStar_Compiler_Range_Type.range) -> FStar_Hash.hash_code mm) - = - fun u -> let uu___ = FStar_Syntax_Unionfind.univ_uvar_id u in of_int uu___ -and (hash_ascription : - ((FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax, - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax) - FStar_Pervasives.either * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax FStar_Pervasives_Native.option * Prims.bool) - -> FStar_Hash.hash_code mm) - = - fun uu___ -> - match uu___ with - | (a, to1, b) -> - let uu___1 = - match a with - | FStar_Pervasives.Inl t -> hash_term t - | FStar_Pervasives.Inr c -> hash_comp c in - let uu___2 = hash_option hash_term to1 in mix uu___1 uu___2 -and (hash_bool : Prims.bool -> FStar_Hash.hash_code mm) = - fun b -> - if b then of_int (Prims.of_int (307)) else of_int (Prims.of_int (311)) -and (hash_constant : FStar_Syntax_Syntax.sconst -> FStar_Hash.hash_code mm) = - fun uu___ -> - match uu___ with - | FStar_Const.Const_effect -> of_int (Prims.of_int (283)) - | FStar_Const.Const_unit -> of_int (Prims.of_int (293)) - | FStar_Const.Const_bool b -> hash_bool b - | FStar_Const.Const_int (s, o) -> - let uu___1 = of_int (Prims.of_int (313)) in - let uu___2 = - let uu___3 = of_string s in - let uu___4 = hash_option hash_sw o in mix uu___3 uu___4 in - mix uu___1 uu___2 - | FStar_Const.Const_char c -> - let uu___1 = of_int (Prims.of_int (317)) in - let uu___2 = of_int (FStar_Char.int_of_char c) in mix uu___1 uu___2 - | FStar_Const.Const_real s -> - let uu___1 = of_int (Prims.of_int (337)) in - let uu___2 = of_string s in mix uu___1 uu___2 - | FStar_Const.Const_string (s, uu___1) -> - let uu___2 = of_int (Prims.of_int (349)) in - let uu___3 = of_string s in mix uu___2 uu___3 - | FStar_Const.Const_range_of -> of_int (Prims.of_int (353)) - | FStar_Const.Const_set_range_of -> of_int (Prims.of_int (359)) - | FStar_Const.Const_range r -> - let uu___1 = of_int (Prims.of_int (367)) in - let uu___2 = - let uu___3 = FStar_Compiler_Range_Ops.string_of_range r in - of_string uu___3 in - mix uu___1 uu___2 - | FStar_Const.Const_reify uu___1 -> of_int (Prims.of_int (367)) - | FStar_Const.Const_reflect l -> - let uu___1 = of_int (Prims.of_int (373)) in - let uu___2 = hash_lid l in mix uu___1 uu___2 -and (hash_sw : - (FStar_Const.signedness * FStar_Const.width) -> FStar_Hash.hash_code mm) = - fun uu___ -> - match uu___ with - | (s, w) -> - let uu___1 = - match s with - | FStar_Const.Unsigned -> of_int (Prims.of_int (547)) - | FStar_Const.Signed -> of_int (Prims.of_int (557)) in - let uu___2 = - match w with - | FStar_Const.Int8 -> of_int (Prims.of_int (563)) - | FStar_Const.Int16 -> of_int (Prims.of_int (569)) - | FStar_Const.Int32 -> of_int (Prims.of_int (571)) - | FStar_Const.Int64 -> of_int (Prims.of_int (577)) - | FStar_Const.Sizet -> of_int (Prims.of_int (583)) in - mix uu___1 uu___2 -and (hash_ident : FStar_Syntax_Syntax.univ_name -> FStar_Hash.hash_code mm) = - fun i -> let uu___ = FStar_Ident.string_of_id i in of_string uu___ -and (hash_lid : FStar_Ident.lident -> FStar_Hash.hash_code mm) = - fun l -> let uu___ = FStar_Ident.string_of_lid l in of_string uu___ -and (hash_lbname : - (FStar_Syntax_Syntax.bv, FStar_Syntax_Syntax.fv) FStar_Pervasives.either -> - FStar_Hash.hash_code mm) - = - fun l -> - match l with - | FStar_Pervasives.Inl bv -> hash_bv bv - | FStar_Pervasives.Inr fv -> hash_fv fv -and (hash_rc : FStar_Syntax_Syntax.residual_comp -> FStar_Hash.hash_code mm) - = - fun rc -> - let uu___ = - let uu___1 = hash_lid rc.FStar_Syntax_Syntax.residual_effect in - let uu___2 = - let uu___3 = - hash_option hash_term rc.FStar_Syntax_Syntax.residual_typ in - let uu___4 = - let uu___5 = - hash_list hash_flag rc.FStar_Syntax_Syntax.residual_flags in - [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mix_list_lit uu___ -and (hash_flag : FStar_Syntax_Syntax.cflag -> FStar_Hash.hash_code mm) = - fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.TOTAL -> of_int (Prims.of_int (947)) - | FStar_Syntax_Syntax.MLEFFECT -> of_int (Prims.of_int (953)) - | FStar_Syntax_Syntax.LEMMA -> of_int (Prims.of_int (967)) - | FStar_Syntax_Syntax.RETURN -> of_int (Prims.of_int (971)) - | FStar_Syntax_Syntax.PARTIAL_RETURN -> of_int (Prims.of_int (977)) - | FStar_Syntax_Syntax.SOMETRIVIAL -> of_int (Prims.of_int (983)) - | FStar_Syntax_Syntax.TRIVIAL_POSTCONDITION -> - of_int (Prims.of_int (991)) - | FStar_Syntax_Syntax.SHOULD_NOT_INLINE -> of_int (Prims.of_int (997)) - | FStar_Syntax_Syntax.CPS -> of_int (Prims.of_int (1009)) - | FStar_Syntax_Syntax.DECREASES (FStar_Syntax_Syntax.Decreases_lex ts) -> - let uu___1 = of_int (Prims.of_int (1013)) in - let uu___2 = hash_list hash_term ts in mix uu___1 uu___2 - | FStar_Syntax_Syntax.DECREASES (FStar_Syntax_Syntax.Decreases_wf - (t0, t1)) -> - let uu___1 = of_int (Prims.of_int (2341)) in - let uu___2 = hash_list hash_term [t0; t1] in mix uu___1 uu___2 -and (hash_meta : FStar_Syntax_Syntax.metadata -> FStar_Hash.hash_code mm) = - fun m -> - match m with - | FStar_Syntax_Syntax.Meta_pattern (ts, args) -> - let uu___ = - let uu___1 = of_int (Prims.of_int (1019)) in - let uu___2 = - let uu___3 = hash_list hash_term ts in - let uu___4 = - let uu___5 = hash_list (hash_list hash_arg) args in [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mix_list_lit uu___ - | FStar_Syntax_Syntax.Meta_named l -> - let uu___ = - let uu___1 = of_int (Prims.of_int (1021)) in - let uu___2 = let uu___3 = hash_lid l in [uu___3] in uu___1 :: - uu___2 in - mix_list_lit uu___ - | FStar_Syntax_Syntax.Meta_labeled (s, r, uu___) -> - let uu___1 = - let uu___2 = of_int (Prims.of_int (1031)) in - let uu___3 = - let uu___4 = hash_doc_list s in - let uu___5 = - let uu___6 = - let uu___7 = FStar_Compiler_Range_Ops.string_of_range r in - of_string uu___7 in - [uu___6] in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - mix_list_lit uu___1 - | FStar_Syntax_Syntax.Meta_desugared msi -> - let uu___ = - let uu___1 = of_int (Prims.of_int (1033)) in - let uu___2 = let uu___3 = hash_meta_source_info msi in [uu___3] in - uu___1 :: uu___2 in - mix_list_lit uu___ - | FStar_Syntax_Syntax.Meta_monadic (m1, t) -> - let uu___ = - let uu___1 = of_int (Prims.of_int (1039)) in - let uu___2 = - let uu___3 = hash_lid m1 in - let uu___4 = let uu___5 = hash_term t in [uu___5] in uu___3 :: - uu___4 in - uu___1 :: uu___2 in - mix_list_lit uu___ - | FStar_Syntax_Syntax.Meta_monadic_lift (m0, m1, t) -> - let uu___ = - let uu___1 = of_int (Prims.of_int (1069)) in - let uu___2 = - let uu___3 = hash_lid m0 in - let uu___4 = - let uu___5 = hash_lid m1 in - let uu___6 = let uu___7 = hash_term t in [uu___7] in uu___5 :: - uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mix_list_lit uu___ -and (hash_meta_source_info : - FStar_Syntax_Syntax.meta_source_info -> FStar_Hash.hash_code mm) = - fun m -> - match m with - | FStar_Syntax_Syntax.Sequence -> of_int (Prims.of_int (1049)) - | FStar_Syntax_Syntax.Primop -> of_int (Prims.of_int (1051)) - | FStar_Syntax_Syntax.Masked_effect -> of_int (Prims.of_int (1061)) - | FStar_Syntax_Syntax.Meta_smt_pat -> of_int (Prims.of_int (1063)) - | FStar_Syntax_Syntax.Machine_integer sw -> - let uu___ = of_int (Prims.of_int (1069)) in - let uu___1 = hash_sw sw in mix uu___ uu___1 -and (hash_lazyinfo : FStar_Syntax_Syntax.lazyinfo -> FStar_Hash.hash_code mm) - = fun li -> of_int Prims.int_zero -and (hash_quoteinfo : - FStar_Syntax_Syntax.quoteinfo -> FStar_Hash.hash_code mm) = - fun qi -> - let uu___ = - hash_bool - (qi.FStar_Syntax_Syntax.qkind = FStar_Syntax_Syntax.Quote_static) in - let uu___1 = - hash_list hash_term - (FStar_Pervasives_Native.snd qi.FStar_Syntax_Syntax.antiquotations) in - mix uu___ uu___1 -let rec equal_list : - 'uuuuu 'uuuuu1 . - ('uuuuu -> 'uuuuu1 -> Prims.bool) -> - 'uuuuu Prims.list -> 'uuuuu1 Prims.list -> Prims.bool - = - fun f -> - fun l1 -> - fun l2 -> - match (l1, l2) with - | ([], []) -> true - | (h1::t1, h2::t2) -> (f h1 h2) && (equal_list f t1 t2) - | uu___ -> false -let equal_opt : - 'uuuuu 'uuuuu1 . - ('uuuuu -> 'uuuuu1 -> Prims.bool) -> - 'uuuuu FStar_Pervasives_Native.option -> - 'uuuuu1 FStar_Pervasives_Native.option -> Prims.bool - = - fun f -> - fun o1 -> - fun o2 -> - match (o1, o2) with - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> - true - | (FStar_Pervasives_Native.Some a, FStar_Pervasives_Native.Some b) -> - f a b - | uu___ -> false -let equal_pair : - 'uuuuu 'uuuuu1 'uuuuu2 'uuuuu3 . - ('uuuuu -> 'uuuuu1 -> Prims.bool) -> - ('uuuuu2 -> 'uuuuu3 -> Prims.bool) -> - ('uuuuu * 'uuuuu2) -> ('uuuuu1 * 'uuuuu3) -> Prims.bool - = - fun f -> - fun g -> - fun uu___ -> - fun uu___1 -> - match (uu___, uu___1) with - | ((x1, y1), (x2, y2)) -> (f x1 x2) && (g y1 y2) -let equal_poly : 'uuuuu . 'uuuuu -> 'uuuuu -> Prims.bool = - fun x -> fun y -> x = y -let (ext_hash_term : FStar_Syntax_Syntax.term -> FStar_Hash.hash_code) = - fun t -> - let uu___ = let uu___1 = hash_term t in uu___1 true in - FStar_Pervasives_Native.fst uu___ -let (ext_hash_term_no_memo : - FStar_Syntax_Syntax.term -> FStar_Hash.hash_code) = - fun t -> - let uu___ = let uu___1 = hash_term t in uu___1 false in - FStar_Pervasives_Native.fst uu___ -let rec (equal_term : - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term -> Prims.bool) = - fun t1 -> - fun t2 -> - let uu___ = FStar_Compiler_Util.physical_equality t1 t2 in - if uu___ - then true - else - (let uu___2 = - FStar_Compiler_Util.physical_equality t1.FStar_Syntax_Syntax.n - t2.FStar_Syntax_Syntax.n in - if uu___2 - then true - else - (let uu___4 = - let uu___5 = ext_hash_term t1 in - let uu___6 = ext_hash_term t2 in uu___5 <> uu___6 in - if uu___4 - then false - else - (let uu___6 = - let uu___7 = - let uu___8 = FStar_Syntax_Subst.compress t1 in - uu___8.FStar_Syntax_Syntax.n in - let uu___8 = - let uu___9 = FStar_Syntax_Subst.compress t2 in - uu___9.FStar_Syntax_Syntax.n in - (uu___7, uu___8) in - match uu___6 with - | (FStar_Syntax_Syntax.Tm_bvar x, FStar_Syntax_Syntax.Tm_bvar - y) -> - x.FStar_Syntax_Syntax.index = y.FStar_Syntax_Syntax.index - | (FStar_Syntax_Syntax.Tm_name x, FStar_Syntax_Syntax.Tm_name - y) -> - x.FStar_Syntax_Syntax.index = y.FStar_Syntax_Syntax.index - | (FStar_Syntax_Syntax.Tm_fvar f, FStar_Syntax_Syntax.Tm_fvar - g) -> equal_fv f g - | (FStar_Syntax_Syntax.Tm_uinst (t11, u1), - FStar_Syntax_Syntax.Tm_uinst (t21, u2)) -> - (equal_term t11 t21) && (equal_list equal_universe u1 u2) - | (FStar_Syntax_Syntax.Tm_constant c1, - FStar_Syntax_Syntax.Tm_constant c2) -> equal_constant c1 c2 - | (FStar_Syntax_Syntax.Tm_type u1, FStar_Syntax_Syntax.Tm_type - u2) -> equal_universe u1 u2 - | (FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs1; - FStar_Syntax_Syntax.body = t11; - FStar_Syntax_Syntax.rc_opt = rc1;_}, - FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs2; - FStar_Syntax_Syntax.body = t21; - FStar_Syntax_Syntax.rc_opt = rc2;_}) - -> - ((equal_list equal_binder bs1 bs2) && (equal_term t11 t21)) - && (equal_opt equal_rc rc1 rc2) - | (FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs1; - FStar_Syntax_Syntax.comp = c1;_}, - FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs2; - FStar_Syntax_Syntax.comp = c2;_}) - -> (equal_list equal_binder bs1 bs2) && (equal_comp c1 c2) - | (FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = b1; - FStar_Syntax_Syntax.phi = t11;_}, - FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = b2; - FStar_Syntax_Syntax.phi = t21;_}) - -> (equal_bv b1 b2) && (equal_term t11 t21) - | (FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = t11; - FStar_Syntax_Syntax.args = as1;_}, - FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = t21; - FStar_Syntax_Syntax.args = as2;_}) - -> (equal_term t11 t21) && (equal_list equal_arg as1 as2) - | (FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = t11; - FStar_Syntax_Syntax.ret_opt = asc_opt1; - FStar_Syntax_Syntax.brs = bs1; - FStar_Syntax_Syntax.rc_opt1 = ropt1;_}, - FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = t21; - FStar_Syntax_Syntax.ret_opt = asc_opt2; - FStar_Syntax_Syntax.brs = bs2; - FStar_Syntax_Syntax.rc_opt1 = ropt2;_}) - -> - (((equal_term t11 t21) && - (equal_opt equal_match_returns asc_opt1 asc_opt2)) - && (equal_list equal_branch bs1 bs2)) - && (equal_opt equal_rc ropt1 ropt2) - | (FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t11; - FStar_Syntax_Syntax.asc = a1; - FStar_Syntax_Syntax.eff_opt = l1;_}, - FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t21; - FStar_Syntax_Syntax.asc = a2; - FStar_Syntax_Syntax.eff_opt = l2;_}) - -> - ((equal_term t11 t21) && (equal_ascription a1 a2)) && - (equal_opt FStar_Ident.lid_equals l1 l2) - | (FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (r1, lbs1); - FStar_Syntax_Syntax.body1 = t11;_}, - FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (r2, lbs2); - FStar_Syntax_Syntax.body1 = t21;_}) - -> - ((r1 = r2) && (equal_list equal_letbinding lbs1 lbs2)) && - (equal_term t11 t21) - | (FStar_Syntax_Syntax.Tm_uvar u1, FStar_Syntax_Syntax.Tm_uvar - u2) -> equal_uvar u1 u2 - | (FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t11; - FStar_Syntax_Syntax.meta = m1;_}, - FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t21; - FStar_Syntax_Syntax.meta = m2;_}) - -> (equal_term t11 t21) && (equal_meta m1 m2) - | (FStar_Syntax_Syntax.Tm_lazy l1, FStar_Syntax_Syntax.Tm_lazy - l2) -> equal_lazyinfo l1 l2 - | (FStar_Syntax_Syntax.Tm_quoted (t11, q1), - FStar_Syntax_Syntax.Tm_quoted (t21, q2)) -> - (equal_term t11 t21) && (equal_quoteinfo q1 q2) - | (FStar_Syntax_Syntax.Tm_unknown, - FStar_Syntax_Syntax.Tm_unknown) -> true - | uu___7 -> false))) -and (equal_comp : - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> Prims.bool) - = - fun c1 -> - fun c2 -> - let uu___ = FStar_Compiler_Util.physical_equality c1 c2 in - if uu___ - then true - else - (match ((c1.FStar_Syntax_Syntax.n), (c2.FStar_Syntax_Syntax.n)) with - | (FStar_Syntax_Syntax.Total t1, FStar_Syntax_Syntax.Total t2) -> - equal_term t1 t2 - | (FStar_Syntax_Syntax.GTotal t1, FStar_Syntax_Syntax.GTotal t2) -> - equal_term t1 t2 - | (FStar_Syntax_Syntax.Comp ct1, FStar_Syntax_Syntax.Comp ct2) -> - ((((FStar_Ident.lid_equals ct1.FStar_Syntax_Syntax.effect_name - ct2.FStar_Syntax_Syntax.effect_name) - && - (equal_list equal_universe - ct1.FStar_Syntax_Syntax.comp_univs - ct2.FStar_Syntax_Syntax.comp_univs)) - && - (equal_term ct1.FStar_Syntax_Syntax.result_typ - ct2.FStar_Syntax_Syntax.result_typ)) - && - (equal_list equal_arg ct1.FStar_Syntax_Syntax.effect_args - ct2.FStar_Syntax_Syntax.effect_args)) - && - (equal_list equal_flag ct1.FStar_Syntax_Syntax.flags - ct2.FStar_Syntax_Syntax.flags)) -and (equal_binder : - FStar_Syntax_Syntax.binder -> FStar_Syntax_Syntax.binder -> Prims.bool) = - fun b1 -> - fun b2 -> - let uu___ = FStar_Compiler_Util.physical_equality b1 b2 in - if uu___ - then true - else - ((equal_bv b1.FStar_Syntax_Syntax.binder_bv - b2.FStar_Syntax_Syntax.binder_bv) - && - (equal_bqual b1.FStar_Syntax_Syntax.binder_qual - b2.FStar_Syntax_Syntax.binder_qual)) - && - (equal_list equal_term b1.FStar_Syntax_Syntax.binder_attrs - b2.FStar_Syntax_Syntax.binder_attrs) -and (equal_match_returns : - (FStar_Syntax_Syntax.binder * - ((FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax, - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax) - FStar_Pervasives.either * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax FStar_Pervasives_Native.option * Prims.bool)) - -> - (FStar_Syntax_Syntax.binder * - ((FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax, - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax) - FStar_Pervasives.either * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax FStar_Pervasives_Native.option * - Prims.bool)) -> Prims.bool) - = - fun uu___ -> - fun uu___1 -> - match (uu___, uu___1) with - | ((b1, asc1), (b2, asc2)) -> - (equal_binder b1 b2) && (equal_ascription asc1 asc2) -and (equal_ascription : - ((FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax, - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax) - FStar_Pervasives.either * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax FStar_Pervasives_Native.option * Prims.bool) - -> - ((FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax, - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax) - FStar_Pervasives.either * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax FStar_Pervasives_Native.option * Prims.bool) - -> Prims.bool) - = - fun x1 -> - fun x2 -> - let uu___ = FStar_Compiler_Util.physical_equality x1 x2 in - if uu___ - then true - else - (let uu___2 = x1 in - match uu___2 with - | (a1, t1, b1) -> - let uu___3 = x2 in - (match uu___3 with - | (a2, t2, b2) -> - ((match (a1, a2) with - | (FStar_Pervasives.Inl t11, FStar_Pervasives.Inl t21) -> - equal_term t11 t21 - | (FStar_Pervasives.Inr c1, FStar_Pervasives.Inr c2) -> - equal_comp c1 c2 - | uu___4 -> false) && (equal_opt equal_term t1 t2)) && - (b1 = b2))) -and (equal_letbinding : - FStar_Syntax_Syntax.letbinding -> - FStar_Syntax_Syntax.letbinding -> Prims.bool) - = - fun l1 -> - fun l2 -> - let uu___ = FStar_Compiler_Util.physical_equality l1 l2 in - if uu___ - then true - else - (((((equal_lbname l1.FStar_Syntax_Syntax.lbname - l2.FStar_Syntax_Syntax.lbname) - && - (equal_list FStar_Ident.ident_equals - l1.FStar_Syntax_Syntax.lbunivs - l2.FStar_Syntax_Syntax.lbunivs)) - && - (equal_term l1.FStar_Syntax_Syntax.lbtyp - l2.FStar_Syntax_Syntax.lbtyp)) - && - (FStar_Ident.lid_equals l1.FStar_Syntax_Syntax.lbeff - l2.FStar_Syntax_Syntax.lbeff)) - && - (equal_term l1.FStar_Syntax_Syntax.lbdef - l2.FStar_Syntax_Syntax.lbdef)) - && - (equal_list equal_term l1.FStar_Syntax_Syntax.lbattrs - l2.FStar_Syntax_Syntax.lbattrs) -and (equal_uvar : - (FStar_Syntax_Syntax.ctx_uvar * (FStar_Syntax_Syntax.subst_elt Prims.list - Prims.list * FStar_Syntax_Syntax.maybe_set_use_range)) -> - (FStar_Syntax_Syntax.ctx_uvar * (FStar_Syntax_Syntax.subst_elt Prims.list - Prims.list * FStar_Syntax_Syntax.maybe_set_use_range)) -> Prims.bool) - = - fun uu___ -> - fun uu___1 -> - match (uu___, uu___1) with - | ((u1, (s1, uu___2)), (u2, (s2, uu___3))) -> - (FStar_Syntax_Unionfind.equiv u1.FStar_Syntax_Syntax.ctx_uvar_head - u2.FStar_Syntax_Syntax.ctx_uvar_head) - && (equal_list (equal_list equal_subst_elt) s1 s2) -and (equal_bv : - FStar_Syntax_Syntax.bv -> FStar_Syntax_Syntax.bv -> Prims.bool) = - fun b1 -> - fun b2 -> - let uu___ = FStar_Compiler_Util.physical_equality b1 b2 in - if uu___ - then true - else - (FStar_Ident.ident_equals b1.FStar_Syntax_Syntax.ppname - b2.FStar_Syntax_Syntax.ppname) - && - (equal_term b1.FStar_Syntax_Syntax.sort b2.FStar_Syntax_Syntax.sort) -and (equal_fv : - FStar_Syntax_Syntax.fv -> FStar_Syntax_Syntax.fv -> Prims.bool) = - fun f1 -> - fun f2 -> - let uu___ = FStar_Compiler_Util.physical_equality f1 f2 in - if uu___ - then true - else - FStar_Ident.lid_equals - (f1.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - (f2.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v -and (equal_universe : - FStar_Syntax_Syntax.universe -> FStar_Syntax_Syntax.universe -> Prims.bool) - = - fun u1 -> - fun u2 -> - let uu___ = FStar_Compiler_Util.physical_equality u1 u2 in - if uu___ - then true - else - (let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress_univ u1 in - let uu___4 = FStar_Syntax_Subst.compress_univ u2 in - (uu___3, uu___4) in - match uu___2 with - | (FStar_Syntax_Syntax.U_zero, FStar_Syntax_Syntax.U_zero) -> true - | (FStar_Syntax_Syntax.U_succ u11, FStar_Syntax_Syntax.U_succ u21) - -> equal_universe u11 u21 - | (FStar_Syntax_Syntax.U_max us1, FStar_Syntax_Syntax.U_max us2) -> - equal_list equal_universe us1 us2 - | (FStar_Syntax_Syntax.U_bvar i1, FStar_Syntax_Syntax.U_bvar i2) -> - i1 = i2 - | (FStar_Syntax_Syntax.U_name x1, FStar_Syntax_Syntax.U_name x2) -> - FStar_Ident.ident_equals x1 x2 - | (FStar_Syntax_Syntax.U_unif u11, FStar_Syntax_Syntax.U_unif u21) - -> FStar_Syntax_Unionfind.univ_equiv u11 u21 - | (FStar_Syntax_Syntax.U_unknown, FStar_Syntax_Syntax.U_unknown) -> - true - | uu___3 -> false) -and (equal_constant : - FStar_Syntax_Syntax.sconst -> FStar_Syntax_Syntax.sconst -> Prims.bool) = - fun c1 -> - fun c2 -> - let uu___ = FStar_Compiler_Util.physical_equality c1 c2 in - if uu___ - then true - else - (match (c1, c2) with - | (FStar_Const.Const_effect, FStar_Const.Const_effect) -> true - | (FStar_Const.Const_unit, FStar_Const.Const_unit) -> true - | (FStar_Const.Const_bool b1, FStar_Const.Const_bool b2) -> b1 = b2 - | (FStar_Const.Const_int (s1, o1), FStar_Const.Const_int (s2, o2)) - -> (s1 = s2) && (o1 = o2) - | (FStar_Const.Const_char c11, FStar_Const.Const_char c21) -> - c11 = c21 - | (FStar_Const.Const_real s1, FStar_Const.Const_real s2) -> s1 = s2 - | (FStar_Const.Const_string (s1, uu___2), FStar_Const.Const_string - (s2, uu___3)) -> s1 = s2 - | (FStar_Const.Const_range_of, FStar_Const.Const_range_of) -> true - | (FStar_Const.Const_set_range_of, FStar_Const.Const_set_range_of) - -> true - | (FStar_Const.Const_range r1, FStar_Const.Const_range r2) -> - let uu___2 = FStar_Compiler_Range_Ops.compare r1 r2 in - uu___2 = Prims.int_zero - | (FStar_Const.Const_reify uu___2, FStar_Const.Const_reify uu___3) - -> true - | (FStar_Const.Const_reflect l1, FStar_Const.Const_reflect l2) -> - FStar_Ident.lid_equals l1 l2 - | uu___2 -> false) -and (equal_arg : - (FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) -> - (FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) -> - Prims.bool) - = - fun arg1 -> - fun arg2 -> - let uu___ = FStar_Compiler_Util.physical_equality arg1 arg2 in - if uu___ - then true - else - (let uu___2 = arg1 in - match uu___2 with - | (t1, a1) -> - let uu___3 = arg2 in - (match uu___3 with - | (t2, a2) -> - (equal_term t1 t2) && (equal_opt equal_arg_qualifier a1 a2))) -and (equal_bqual : - FStar_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> - Prims.bool) - = fun b1 -> fun b2 -> equal_opt equal_binder_qualifier b1 b2 -and (equal_binder_qualifier : - FStar_Syntax_Syntax.binder_qualifier -> - FStar_Syntax_Syntax.binder_qualifier -> Prims.bool) - = - fun b1 -> - fun b2 -> - match (b1, b2) with - | (FStar_Syntax_Syntax.Implicit b11, FStar_Syntax_Syntax.Implicit b21) - -> b11 = b21 - | (FStar_Syntax_Syntax.Equality, FStar_Syntax_Syntax.Equality) -> true - | (FStar_Syntax_Syntax.Meta t1, FStar_Syntax_Syntax.Meta t2) -> - equal_term t1 t2 - | uu___ -> false -and (equal_branch : - (FStar_Syntax_Syntax.pat' FStar_Syntax_Syntax.withinfo_t * - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - FStar_Pervasives_Native.option * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax) -> - (FStar_Syntax_Syntax.pat' FStar_Syntax_Syntax.withinfo_t * - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - FStar_Pervasives_Native.option * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax) -> Prims.bool) - = - fun uu___ -> - fun uu___1 -> - match (uu___, uu___1) with - | ((p1, w1, t1), (p2, w2, t2)) -> - ((equal_pat p1 p2) && (equal_opt equal_term w1 w2)) && - (equal_term t1 t2) -and (equal_pat : - FStar_Syntax_Syntax.pat' FStar_Syntax_Syntax.withinfo_t -> - FStar_Syntax_Syntax.pat' FStar_Syntax_Syntax.withinfo_t -> Prims.bool) - = - fun p1 -> - fun p2 -> - let uu___ = FStar_Compiler_Util.physical_equality p1 p2 in - if uu___ - then true - else - (match ((p1.FStar_Syntax_Syntax.v), (p2.FStar_Syntax_Syntax.v)) with - | (FStar_Syntax_Syntax.Pat_constant c1, - FStar_Syntax_Syntax.Pat_constant c2) -> equal_constant c1 c2 - | (FStar_Syntax_Syntax.Pat_cons (fv1, us1, args1), - FStar_Syntax_Syntax.Pat_cons (fv2, us2, args2)) -> - ((equal_fv fv1 fv2) && - (equal_opt (equal_list equal_universe) us1 us2)) - && (equal_list (equal_pair equal_pat equal_poly) args1 args2) - | (FStar_Syntax_Syntax.Pat_var bv1, FStar_Syntax_Syntax.Pat_var bv2) - -> equal_bv bv1 bv2 - | (FStar_Syntax_Syntax.Pat_dot_term t1, - FStar_Syntax_Syntax.Pat_dot_term t2) -> - equal_opt equal_term t1 t2 - | uu___2 -> false) -and (equal_meta : - FStar_Syntax_Syntax.metadata -> FStar_Syntax_Syntax.metadata -> Prims.bool) - = - fun m1 -> - fun m2 -> - match (m1, m2) with - | (FStar_Syntax_Syntax.Meta_pattern (ts1, args1), - FStar_Syntax_Syntax.Meta_pattern (ts2, args2)) -> - (equal_list equal_term ts1 ts2) && - (equal_list (equal_list equal_arg) args1 args2) - | (FStar_Syntax_Syntax.Meta_named l1, FStar_Syntax_Syntax.Meta_named - l2) -> FStar_Ident.lid_equals l1 l2 - | (FStar_Syntax_Syntax.Meta_labeled (s1, r1, uu___), - FStar_Syntax_Syntax.Meta_labeled (s2, r2, uu___1)) -> - (s1 = s2) && - (let uu___2 = FStar_Compiler_Range_Ops.compare r1 r2 in - uu___2 = Prims.int_zero) - | (FStar_Syntax_Syntax.Meta_desugared msi1, - FStar_Syntax_Syntax.Meta_desugared msi2) -> msi1 = msi2 - | (FStar_Syntax_Syntax.Meta_monadic (m11, t1), - FStar_Syntax_Syntax.Meta_monadic (m21, t2)) -> - (FStar_Ident.lid_equals m11 m21) && (equal_term t1 t2) - | (FStar_Syntax_Syntax.Meta_monadic_lift (m11, n1, t1), - FStar_Syntax_Syntax.Meta_monadic_lift (m21, n2, t2)) -> - ((FStar_Ident.lid_equals m11 m21) && (FStar_Ident.lid_equals n1 n2)) - && (equal_term t1 t2) -and (equal_lazyinfo : - FStar_Syntax_Syntax.lazyinfo -> FStar_Syntax_Syntax.lazyinfo -> Prims.bool) - = - fun l1 -> - fun l2 -> - FStar_Compiler_Util.physical_equality l1.FStar_Syntax_Syntax.blob - l2.FStar_Syntax_Syntax.blob -and (equal_quoteinfo : - FStar_Syntax_Syntax.quoteinfo -> - FStar_Syntax_Syntax.quoteinfo -> Prims.bool) - = - fun q1 -> - fun q2 -> - ((q1.FStar_Syntax_Syntax.qkind = q2.FStar_Syntax_Syntax.qkind) && - ((FStar_Pervasives_Native.fst q1.FStar_Syntax_Syntax.antiquotations) - = - (FStar_Pervasives_Native.fst - q2.FStar_Syntax_Syntax.antiquotations))) - && - (equal_list equal_term - (FStar_Pervasives_Native.snd q1.FStar_Syntax_Syntax.antiquotations) - (FStar_Pervasives_Native.snd q2.FStar_Syntax_Syntax.antiquotations)) -and (equal_rc : - FStar_Syntax_Syntax.residual_comp -> - FStar_Syntax_Syntax.residual_comp -> Prims.bool) - = - fun r1 -> - fun r2 -> - ((FStar_Ident.lid_equals r1.FStar_Syntax_Syntax.residual_effect - r2.FStar_Syntax_Syntax.residual_effect) - && - (equal_opt equal_term r1.FStar_Syntax_Syntax.residual_typ - r2.FStar_Syntax_Syntax.residual_typ)) - && - (equal_list equal_flag r1.FStar_Syntax_Syntax.residual_flags - r2.FStar_Syntax_Syntax.residual_flags) -and (equal_flag : - FStar_Syntax_Syntax.cflag -> FStar_Syntax_Syntax.cflag -> Prims.bool) = - fun f1 -> - fun f2 -> - match (f1, f2) with - | (FStar_Syntax_Syntax.DECREASES t1, FStar_Syntax_Syntax.DECREASES t2) - -> equal_decreases_order t1 t2 - | uu___ -> f1 = f2 -and (equal_decreases_order : - FStar_Syntax_Syntax.decreases_order -> - FStar_Syntax_Syntax.decreases_order -> Prims.bool) - = - fun d1 -> - fun d2 -> - match (d1, d2) with - | (FStar_Syntax_Syntax.Decreases_lex ts1, - FStar_Syntax_Syntax.Decreases_lex ts2) -> - equal_list equal_term ts1 ts2 - | (FStar_Syntax_Syntax.Decreases_wf (t1, t1'), - FStar_Syntax_Syntax.Decreases_wf (t2, t2')) -> - (equal_term t1 t2) && (equal_term t1' t2') -and (equal_arg_qualifier : - FStar_Syntax_Syntax.arg_qualifier -> - FStar_Syntax_Syntax.arg_qualifier -> Prims.bool) - = - fun a1 -> - fun a2 -> - (a1.FStar_Syntax_Syntax.aqual_implicit = - a2.FStar_Syntax_Syntax.aqual_implicit) - && - (equal_list equal_term a1.FStar_Syntax_Syntax.aqual_attributes - a2.FStar_Syntax_Syntax.aqual_attributes) -and (equal_lbname : - (FStar_Syntax_Syntax.bv, FStar_Syntax_Syntax.fv) FStar_Pervasives.either -> - (FStar_Syntax_Syntax.bv, FStar_Syntax_Syntax.fv) FStar_Pervasives.either - -> Prims.bool) - = - fun l1 -> - fun l2 -> - match (l1, l2) with - | (FStar_Pervasives.Inl b1, FStar_Pervasives.Inl b2) -> - FStar_Ident.ident_equals b1.FStar_Syntax_Syntax.ppname - b2.FStar_Syntax_Syntax.ppname - | (FStar_Pervasives.Inr f1, FStar_Pervasives.Inr f2) -> - FStar_Ident.lid_equals - (f1.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - (f2.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v -and (equal_subst_elt : - FStar_Syntax_Syntax.subst_elt -> - FStar_Syntax_Syntax.subst_elt -> Prims.bool) - = - fun s1 -> - fun s2 -> - match (s1, s2) with - | (FStar_Syntax_Syntax.DB (i1, bv1), FStar_Syntax_Syntax.DB (i2, bv2)) - -> (i1 = i2) && (equal_bv bv1 bv2) - | (FStar_Syntax_Syntax.NM (bv1, i1), FStar_Syntax_Syntax.NM (bv2, i2)) - -> (i1 = i2) && (equal_bv bv1 bv2) - | (FStar_Syntax_Syntax.NT (bv1, t1), FStar_Syntax_Syntax.NT (bv2, t2)) - -> (equal_bv bv1 bv2) && (equal_term t1 t2) - | (FStar_Syntax_Syntax.UN (i1, u1), FStar_Syntax_Syntax.UN (i2, u2)) -> - (i1 = i2) && (equal_universe u1 u2) - | (FStar_Syntax_Syntax.UD (un1, i1), FStar_Syntax_Syntax.UD (un2, i2)) - -> (i1 = i2) && (FStar_Ident.ident_equals un1 un2) -let (hashable_term : FStar_Syntax_Syntax.term FStar_Class_Hashable.hashable) - = { FStar_Class_Hashable.hash = ext_hash_term } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_InstFV.ml b/ocaml/fstar-lib/generated/FStar_Syntax_InstFV.ml deleted file mode 100644 index 6efa29a0515..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Syntax_InstFV.ml +++ /dev/null @@ -1,384 +0,0 @@ -open Prims -type inst_t = (FStar_Ident.lident * FStar_Syntax_Syntax.universes) Prims.list -let mk : - 'uuuuu 'uuuuu1 . - 'uuuuu FStar_Syntax_Syntax.syntax -> - 'uuuuu1 -> 'uuuuu1 FStar_Syntax_Syntax.syntax - = fun t -> fun s -> FStar_Syntax_Syntax.mk s t.FStar_Syntax_Syntax.pos -let rec (inst : - (FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.fv -> FStar_Syntax_Syntax.term) - -> FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun s -> - fun t -> - let t1 = FStar_Syntax_Subst.compress t in - let mk1 = mk t1 in - match t1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_delayed uu___ -> failwith "Impossible" - | FStar_Syntax_Syntax.Tm_name uu___ -> t1 - | FStar_Syntax_Syntax.Tm_uvar uu___ -> t1 - | FStar_Syntax_Syntax.Tm_uvar uu___ -> t1 - | FStar_Syntax_Syntax.Tm_type uu___ -> t1 - | FStar_Syntax_Syntax.Tm_bvar uu___ -> t1 - | FStar_Syntax_Syntax.Tm_constant uu___ -> t1 - | FStar_Syntax_Syntax.Tm_quoted uu___ -> t1 - | FStar_Syntax_Syntax.Tm_unknown -> t1 - | FStar_Syntax_Syntax.Tm_uinst uu___ -> t1 - | FStar_Syntax_Syntax.Tm_lazy uu___ -> t1 - | FStar_Syntax_Syntax.Tm_fvar fv -> s t1 fv - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs; FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = lopt;_} - -> - let bs1 = inst_binders s bs in - let body1 = inst s body in - let uu___ = - let uu___1 = - let uu___2 = inst_lcomp_opt s lopt in - { - FStar_Syntax_Syntax.bs = bs1; - FStar_Syntax_Syntax.body = body1; - FStar_Syntax_Syntax.rc_opt = uu___2 - } in - FStar_Syntax_Syntax.Tm_abs uu___1 in - mk1 uu___ - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; FStar_Syntax_Syntax.comp = c;_} -> - let bs1 = inst_binders s bs in - let c1 = inst_comp s c in - mk1 - (FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs1; FStar_Syntax_Syntax.comp = c1 - }) - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = bv; FStar_Syntax_Syntax.phi = t2;_} -> - let bv1 = - let uu___ = inst s bv.FStar_Syntax_Syntax.sort in - { - FStar_Syntax_Syntax.ppname = (bv.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = (bv.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = uu___ - } in - let t3 = inst s t2 in - mk1 - (FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = bv1; FStar_Syntax_Syntax.phi = t3 }) - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = t2; FStar_Syntax_Syntax.args = args;_} - -> - let uu___ = - let uu___1 = - let uu___2 = inst s t2 in - let uu___3 = inst_args s args in - { - FStar_Syntax_Syntax.hd = uu___2; - FStar_Syntax_Syntax.args = uu___3 - } in - FStar_Syntax_Syntax.Tm_app uu___1 in - mk1 uu___ - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = t2; - FStar_Syntax_Syntax.ret_opt = asc_opt; - FStar_Syntax_Syntax.brs = pats; - FStar_Syntax_Syntax.rc_opt1 = lopt;_} - -> - let pats1 = - FStar_Compiler_List.map - (fun uu___ -> - match uu___ with - | (p, wopt, t3) -> - let wopt1 = - match wopt with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some w -> - let uu___1 = inst s w in - FStar_Pervasives_Native.Some uu___1 in - let t4 = inst s t3 in (p, wopt1, t4)) pats in - let asc_opt1 = - match asc_opt with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (b, asc) -> - let uu___ = - let uu___1 = inst_binder s b in - let uu___2 = inst_ascription s asc in (uu___1, uu___2) in - FStar_Pervasives_Native.Some uu___ in - let uu___ = - let uu___1 = - let uu___2 = inst s t2 in - let uu___3 = inst_lcomp_opt s lopt in - { - FStar_Syntax_Syntax.scrutinee = uu___2; - FStar_Syntax_Syntax.ret_opt = asc_opt1; - FStar_Syntax_Syntax.brs = pats1; - FStar_Syntax_Syntax.rc_opt1 = uu___3 - } in - FStar_Syntax_Syntax.Tm_match uu___1 in - mk1 uu___ - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t11; FStar_Syntax_Syntax.asc = asc; - FStar_Syntax_Syntax.eff_opt = f;_} - -> - let uu___ = - let uu___1 = - let uu___2 = inst s t11 in - let uu___3 = inst_ascription s asc in - { - FStar_Syntax_Syntax.tm = uu___2; - FStar_Syntax_Syntax.asc = uu___3; - FStar_Syntax_Syntax.eff_opt = f - } in - FStar_Syntax_Syntax.Tm_ascribed uu___1 in - mk1 uu___ - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = lbs; FStar_Syntax_Syntax.body1 = t2;_} - -> - let lbs1 = - let uu___ = - FStar_Compiler_List.map - (fun lb -> - let uu___1 = inst s lb.FStar_Syntax_Syntax.lbtyp in - let uu___2 = inst s lb.FStar_Syntax_Syntax.lbdef in - { - FStar_Syntax_Syntax.lbname = - (lb.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = uu___1; - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = uu___2; - FStar_Syntax_Syntax.lbattrs = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - }) (FStar_Pervasives_Native.snd lbs) in - ((FStar_Pervasives_Native.fst lbs), uu___) in - let uu___ = - let uu___1 = - let uu___2 = inst s t2 in - { - FStar_Syntax_Syntax.lbs = lbs1; - FStar_Syntax_Syntax.body1 = uu___2 - } in - FStar_Syntax_Syntax.Tm_let uu___1 in - mk1 uu___ - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t2; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_pattern - (bvs, args);_} - -> - let uu___ = - let uu___1 = - let uu___2 = inst s t2 in - let uu___3 = - let uu___4 = - let uu___5 = FStar_Compiler_List.map (inst_args s) args in - (bvs, uu___5) in - FStar_Syntax_Syntax.Meta_pattern uu___4 in - { - FStar_Syntax_Syntax.tm2 = uu___2; - FStar_Syntax_Syntax.meta = uu___3 - } in - FStar_Syntax_Syntax.Tm_meta uu___1 in - mk1 uu___ - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t2; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_monadic - (m, t');_} - -> - let uu___ = - let uu___1 = - let uu___2 = inst s t2 in - let uu___3 = - let uu___4 = let uu___5 = inst s t' in (m, uu___5) in - FStar_Syntax_Syntax.Meta_monadic uu___4 in - { - FStar_Syntax_Syntax.tm2 = uu___2; - FStar_Syntax_Syntax.meta = uu___3 - } in - FStar_Syntax_Syntax.Tm_meta uu___1 in - mk1 uu___ - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t2; FStar_Syntax_Syntax.meta = tag;_} - -> - let uu___ = - let uu___1 = - let uu___2 = inst s t2 in - { - FStar_Syntax_Syntax.tm2 = uu___2; - FStar_Syntax_Syntax.meta = tag - } in - FStar_Syntax_Syntax.Tm_meta uu___1 in - mk1 uu___ -and (inst_binder : - (FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.fv -> FStar_Syntax_Syntax.term) - -> FStar_Syntax_Syntax.binder -> FStar_Syntax_Syntax.binder) - = - fun s -> - fun b -> - let uu___ = - let uu___1 = b.FStar_Syntax_Syntax.binder_bv in - let uu___2 = - inst s (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - { - FStar_Syntax_Syntax.ppname = (uu___1.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = (uu___1.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = uu___2 - } in - let uu___1 = - FStar_Compiler_List.map (inst s) b.FStar_Syntax_Syntax.binder_attrs in - { - FStar_Syntax_Syntax.binder_bv = uu___; - FStar_Syntax_Syntax.binder_qual = (b.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity = - (b.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs = uu___1 - } -and (inst_binders : - (FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.fv -> FStar_Syntax_Syntax.term) - -> FStar_Syntax_Syntax.binders -> FStar_Syntax_Syntax.binders) - = fun s -> fun bs -> FStar_Compiler_List.map (inst_binder s) bs -and (inst_args : - (FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.fv -> FStar_Syntax_Syntax.term) - -> - (FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) - Prims.list -> - (FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) - Prims.list) - = - fun s -> - fun args -> - FStar_Compiler_List.map - (fun uu___ -> - match uu___ with - | (a, imp) -> let uu___1 = inst s a in (uu___1, imp)) args -and (inst_comp : - (FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.fv -> FStar_Syntax_Syntax.term) - -> - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax) - = - fun s -> - fun c -> - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total t -> - let uu___ = inst s t in FStar_Syntax_Syntax.mk_Total uu___ - | FStar_Syntax_Syntax.GTotal t -> - let uu___ = inst s t in FStar_Syntax_Syntax.mk_GTotal uu___ - | FStar_Syntax_Syntax.Comp ct -> - let ct1 = - let uu___ = inst s ct.FStar_Syntax_Syntax.result_typ in - let uu___1 = inst_args s ct.FStar_Syntax_Syntax.effect_args in - let uu___2 = - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with - | FStar_Syntax_Syntax.DECREASES dec_order -> - let uu___4 = inst_decreases_order s dec_order in - FStar_Syntax_Syntax.DECREASES uu___4 - | f -> f) ct.FStar_Syntax_Syntax.flags in - { - FStar_Syntax_Syntax.comp_univs = - (ct.FStar_Syntax_Syntax.comp_univs); - FStar_Syntax_Syntax.effect_name = - (ct.FStar_Syntax_Syntax.effect_name); - FStar_Syntax_Syntax.result_typ = uu___; - FStar_Syntax_Syntax.effect_args = uu___1; - FStar_Syntax_Syntax.flags = uu___2 - } in - FStar_Syntax_Syntax.mk_Comp ct1 -and (inst_decreases_order : - (FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.fv -> FStar_Syntax_Syntax.term) - -> - FStar_Syntax_Syntax.decreases_order -> - FStar_Syntax_Syntax.decreases_order) - = - fun s -> - fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.Decreases_lex l -> - let uu___1 = FStar_Compiler_List.map (inst s) l in - FStar_Syntax_Syntax.Decreases_lex uu___1 - | FStar_Syntax_Syntax.Decreases_wf (rel, e) -> - let uu___1 = - let uu___2 = inst s rel in - let uu___3 = inst s e in (uu___2, uu___3) in - FStar_Syntax_Syntax.Decreases_wf uu___1 -and (inst_lcomp_opt : - (FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.fv -> FStar_Syntax_Syntax.term) - -> - FStar_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option) - = - fun s -> - fun l -> - match l with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some rc -> - let uu___ = - let uu___1 = - FStar_Compiler_Util.map_opt rc.FStar_Syntax_Syntax.residual_typ - (inst s) in - { - FStar_Syntax_Syntax.residual_effect = - (rc.FStar_Syntax_Syntax.residual_effect); - FStar_Syntax_Syntax.residual_typ = uu___1; - FStar_Syntax_Syntax.residual_flags = - (rc.FStar_Syntax_Syntax.residual_flags) - } in - FStar_Pervasives_Native.Some uu___ -and (inst_ascription : - (FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.fv -> FStar_Syntax_Syntax.term) - -> - FStar_Syntax_Syntax.ascription -> - ((FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax, - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax) - FStar_Pervasives.either * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax FStar_Pervasives_Native.option * - Prims.bool)) - = - fun s -> - fun asc -> - let uu___ = asc in - match uu___ with - | (annot, topt, use_eq) -> - let annot1 = - match annot with - | FStar_Pervasives.Inl t -> - let uu___1 = inst s t in FStar_Pervasives.Inl uu___1 - | FStar_Pervasives.Inr c -> - let uu___1 = inst_comp s c in FStar_Pervasives.Inr uu___1 in - let topt1 = FStar_Compiler_Util.map_opt topt (inst s) in - (annot1, topt1, use_eq) -let (instantiate : - inst_t -> FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = - fun i -> - fun t -> - match i with - | [] -> t - | uu___ -> - let inst_fv t1 fv = - let uu___1 = - FStar_Compiler_Util.find_opt - (fun uu___2 -> - match uu___2 with - | (x, uu___3) -> - FStar_Ident.lid_equals x - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v) - i in - match uu___1 with - | FStar_Pervasives_Native.None -> t1 - | FStar_Pervasives_Native.Some (uu___2, us) -> - mk t1 (FStar_Syntax_Syntax.Tm_uinst (t1, us)) in - inst inst_fv t \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_MutRecTy.ml b/ocaml/fstar-lib/generated/FStar_Syntax_MutRecTy.ml deleted file mode 100644 index 6aff1ea63b2..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Syntax_MutRecTy.ml +++ /dev/null @@ -1,455 +0,0 @@ -open Prims -let (disentangle_abbrevs_from_bundle : - FStar_Syntax_Syntax.sigelt Prims.list -> - FStar_Syntax_Syntax.qualifier Prims.list -> - FStar_Ident.lident Prims.list -> - FStar_Compiler_Range_Type.range -> - (FStar_Syntax_Syntax.sigelt * FStar_Syntax_Syntax.sigelt - Prims.list)) - = - fun sigelts -> - fun quals -> - fun members -> - fun rng -> - let sigattrs = - FStar_Compiler_List.collect - (fun s -> - match s.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ uu___ -> - s.FStar_Syntax_Syntax.sigattrs - | FStar_Syntax_Syntax.Sig_let uu___ -> - s.FStar_Syntax_Syntax.sigattrs - | uu___ -> []) sigelts in - let sigattrs1 = FStar_Syntax_Util.deduplicate_terms sigattrs in - let type_abbrev_sigelts = - FStar_Compiler_List.collect - (fun x -> - match x.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_let - { - FStar_Syntax_Syntax.lbs1 = - (false, - { - FStar_Syntax_Syntax.lbname = FStar_Pervasives.Inr - uu___; - FStar_Syntax_Syntax.lbunivs = uu___1; - FStar_Syntax_Syntax.lbtyp = uu___2; - FStar_Syntax_Syntax.lbeff = uu___3; - FStar_Syntax_Syntax.lbdef = uu___4; - FStar_Syntax_Syntax.lbattrs = uu___5; - FStar_Syntax_Syntax.lbpos = uu___6;_}::[]); - FStar_Syntax_Syntax.lids1 = uu___7;_} - -> [x] - | FStar_Syntax_Syntax.Sig_let uu___ -> - failwith - "mutrecty: disentangle_abbrevs_from_bundle: type_abbrev_sigelts: impossible" - | uu___ -> []) sigelts in - match type_abbrev_sigelts with - | [] -> - ({ - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_bundle - { - FStar_Syntax_Syntax.ses = sigelts; - FStar_Syntax_Syntax.lids = members - }); - FStar_Syntax_Syntax.sigrng = rng; - FStar_Syntax_Syntax.sigquals = quals; - FStar_Syntax_Syntax.sigmeta = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs = sigattrs1; - FStar_Syntax_Syntax.sigopens_and_abbrevs = []; - FStar_Syntax_Syntax.sigopts = FStar_Pervasives_Native.None - }, []) - | uu___ -> - let type_abbrevs = - FStar_Compiler_List.map - (fun x -> - match x.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_let - { - FStar_Syntax_Syntax.lbs1 = - (uu___1, - { - FStar_Syntax_Syntax.lbname = - FStar_Pervasives.Inr fv; - FStar_Syntax_Syntax.lbunivs = uu___2; - FStar_Syntax_Syntax.lbtyp = uu___3; - FStar_Syntax_Syntax.lbeff = uu___4; - FStar_Syntax_Syntax.lbdef = uu___5; - FStar_Syntax_Syntax.lbattrs = uu___6; - FStar_Syntax_Syntax.lbpos = uu___7;_}::[]); - FStar_Syntax_Syntax.lids1 = uu___8;_} - -> - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - | uu___1 -> - failwith - "mutrecty: disentangle_abbrevs_from_bundle: type_abbrevs: impossible") - type_abbrev_sigelts in - let unfolded_type_abbrevs = - let rev_unfolded_type_abbrevs = FStar_Compiler_Util.mk_ref [] in - let in_progress = FStar_Compiler_Util.mk_ref [] in - let not_unfolded_yet = - FStar_Compiler_Util.mk_ref type_abbrev_sigelts in - let remove_not_unfolded lid = - let uu___1 = - let uu___2 = - FStar_Compiler_Effect.op_Bang not_unfolded_yet in - FStar_Compiler_List.filter - (fun x -> - match x.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_let - { - FStar_Syntax_Syntax.lbs1 = - (uu___3, - { - FStar_Syntax_Syntax.lbname = - FStar_Pervasives.Inr fv; - FStar_Syntax_Syntax.lbunivs = uu___4; - FStar_Syntax_Syntax.lbtyp = uu___5; - FStar_Syntax_Syntax.lbeff = uu___6; - FStar_Syntax_Syntax.lbdef = uu___7; - FStar_Syntax_Syntax.lbattrs = uu___8; - FStar_Syntax_Syntax.lbpos = uu___9;_}::[]); - FStar_Syntax_Syntax.lids1 = uu___10;_} - -> - let uu___11 = - FStar_Ident.lid_equals lid - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - Prims.op_Negation uu___11 - | uu___3 -> true) uu___2 in - FStar_Compiler_Effect.op_Colon_Equals not_unfolded_yet - uu___1 in - let rec unfold_abbrev_fv t fv = - let replacee x = - match x.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_let - { - FStar_Syntax_Syntax.lbs1 = - (uu___1, - { - FStar_Syntax_Syntax.lbname = - FStar_Pervasives.Inr fv'; - FStar_Syntax_Syntax.lbunivs = uu___2; - FStar_Syntax_Syntax.lbtyp = uu___3; - FStar_Syntax_Syntax.lbeff = uu___4; - FStar_Syntax_Syntax.lbdef = uu___5; - FStar_Syntax_Syntax.lbattrs = uu___6; - FStar_Syntax_Syntax.lbpos = uu___7;_}::[]); - FStar_Syntax_Syntax.lids1 = uu___8;_} - when - FStar_Ident.lid_equals - (fv'.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - -> FStar_Pervasives_Native.Some x - | uu___1 -> FStar_Pervasives_Native.None in - let replacee_term x = - match replacee x with - | FStar_Pervasives_Native.Some - { - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_let - { - FStar_Syntax_Syntax.lbs1 = - (uu___1, - { FStar_Syntax_Syntax.lbname = uu___2; - FStar_Syntax_Syntax.lbunivs = uu___3; - FStar_Syntax_Syntax.lbtyp = uu___4; - FStar_Syntax_Syntax.lbeff = uu___5; - FStar_Syntax_Syntax.lbdef = tm; - FStar_Syntax_Syntax.lbattrs = uu___6; - FStar_Syntax_Syntax.lbpos = uu___7;_}::[]); - FStar_Syntax_Syntax.lids1 = uu___8;_}; - FStar_Syntax_Syntax.sigrng = uu___9; - FStar_Syntax_Syntax.sigquals = uu___10; - FStar_Syntax_Syntax.sigmeta = uu___11; - FStar_Syntax_Syntax.sigattrs = uu___12; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___13; - FStar_Syntax_Syntax.sigopts = uu___14;_} - -> FStar_Pervasives_Native.Some tm - | uu___1 -> FStar_Pervasives_Native.None in - let uu___1 = - let uu___2 = - FStar_Compiler_Effect.op_Bang rev_unfolded_type_abbrevs in - FStar_Compiler_Util.find_map uu___2 replacee_term in - match uu___1 with - | FStar_Pervasives_Native.Some x -> x - | FStar_Pervasives_Native.None -> - let uu___2 = - FStar_Compiler_Util.find_map type_abbrev_sigelts - replacee in - (match uu___2 with - | FStar_Pervasives_Native.Some se -> - let uu___3 = - let uu___4 = - FStar_Compiler_Effect.op_Bang in_progress in - FStar_Compiler_List.existsb - (fun x -> - FStar_Ident.lid_equals x - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v) - uu___4 in - if uu___3 - then - let msg = - let uu___4 = - FStar_Ident.string_of_lid - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - FStar_Compiler_Util.format1 - "Cycle on %s in mutually recursive type abbreviations" - uu___4 in - FStar_Errors.raise_error - FStar_Ident.hasrange_lident - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - FStar_Errors_Codes.Fatal_CycleInRecTypeAbbreviation - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic msg) - else unfold_abbrev se - | uu___3 -> t) - and unfold_abbrev x = - match x.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (false, lb::[]); - FStar_Syntax_Syntax.lids1 = uu___1;_} - -> - let quals1 = - FStar_Compiler_List.filter - (fun uu___2 -> - match uu___2 with - | FStar_Syntax_Syntax.Noeq -> false - | uu___3 -> true) x.FStar_Syntax_Syntax.sigquals in - let lid = - match lb.FStar_Syntax_Syntax.lbname with - | FStar_Pervasives.Inr fv -> - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - | uu___2 -> - failwith - "mutrecty: disentangle_abbrevs_from_bundle: rename_abbrev: lid: impossible" in - ((let uu___3 = - let uu___4 = - FStar_Compiler_Effect.op_Bang in_progress in - lid :: uu___4 in - FStar_Compiler_Effect.op_Colon_Equals in_progress - uu___3); - (match () with - | () -> - (remove_not_unfolded lid; - (match () with - | () -> - let ty' = - FStar_Syntax_InstFV.inst unfold_abbrev_fv - lb.FStar_Syntax_Syntax.lbtyp in - let tm' = - FStar_Syntax_InstFV.inst unfold_abbrev_fv - lb.FStar_Syntax_Syntax.lbdef in - let lb' = - { - FStar_Syntax_Syntax.lbname = - (lb.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = ty'; - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = tm'; - FStar_Syntax_Syntax.lbattrs = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - } in - let sigelt' = - FStar_Syntax_Syntax.Sig_let - { - FStar_Syntax_Syntax.lbs1 = - (false, [lb']); - FStar_Syntax_Syntax.lids1 = [lid] - } in - ((let uu___5 = - let uu___6 = - FStar_Compiler_Effect.op_Bang - rev_unfolded_type_abbrevs in - { - FStar_Syntax_Syntax.sigel = sigelt'; - FStar_Syntax_Syntax.sigrng = - (x.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = quals1; - FStar_Syntax_Syntax.sigmeta = - (x.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (x.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs - = - (x.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (x.FStar_Syntax_Syntax.sigopts) - } :: uu___6 in - FStar_Compiler_Effect.op_Colon_Equals - rev_unfolded_type_abbrevs uu___5); - (match () with - | () -> - ((let uu___6 = - let uu___7 = - FStar_Compiler_Effect.op_Bang - in_progress in - FStar_Compiler_List.tl uu___7 in - FStar_Compiler_Effect.op_Colon_Equals - in_progress uu___6); - (match () with | () -> tm')))))))) - | uu___1 -> - failwith - "mutrecty: disentangle_abbrevs_from_bundle: rename_abbrev: impossible" in - let rec aux uu___1 = - let uu___2 = FStar_Compiler_Effect.op_Bang not_unfolded_yet in - match uu___2 with - | x::uu___3 -> let _unused = unfold_abbrev x in aux () - | uu___3 -> - let uu___4 = - FStar_Compiler_Effect.op_Bang - rev_unfolded_type_abbrevs in - FStar_Compiler_List.rev uu___4 in - aux () in - let filter_out_type_abbrevs l = - FStar_Compiler_List.filter - (fun lid -> - FStar_Compiler_List.for_all - (fun lid' -> - let uu___1 = FStar_Ident.lid_equals lid lid' in - Prims.op_Negation uu___1) type_abbrevs) l in - let inductives_with_abbrevs_unfolded = - let find_in_unfolded fv = - FStar_Compiler_Util.find_map unfolded_type_abbrevs - (fun x -> - match x.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_let - { - FStar_Syntax_Syntax.lbs1 = - (uu___1, - { - FStar_Syntax_Syntax.lbname = - FStar_Pervasives.Inr fv'; - FStar_Syntax_Syntax.lbunivs = uu___2; - FStar_Syntax_Syntax.lbtyp = uu___3; - FStar_Syntax_Syntax.lbeff = uu___4; - FStar_Syntax_Syntax.lbdef = tm; - FStar_Syntax_Syntax.lbattrs = uu___5; - FStar_Syntax_Syntax.lbpos = uu___6;_}::[]); - FStar_Syntax_Syntax.lids1 = uu___7;_} - when - FStar_Ident.lid_equals - (fv'.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - -> FStar_Pervasives_Native.Some tm - | uu___1 -> FStar_Pervasives_Native.None) in - let unfold_fv t fv = - let uu___1 = find_in_unfolded fv in - match uu___1 with - | FStar_Pervasives_Native.Some t' -> t' - | uu___2 -> t in - let unfold_in_sig x = - match x.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = lid; - FStar_Syntax_Syntax.us = univs; - FStar_Syntax_Syntax.params = bnd; - FStar_Syntax_Syntax.num_uniform_params = num_uniform; - FStar_Syntax_Syntax.t = ty; - FStar_Syntax_Syntax.mutuals = mut; - FStar_Syntax_Syntax.ds = dc; - FStar_Syntax_Syntax.injective_type_params = - injective_type_params;_} - -> - let bnd' = - FStar_Syntax_InstFV.inst_binders unfold_fv bnd in - let ty' = FStar_Syntax_InstFV.inst unfold_fv ty in - let mut' = filter_out_type_abbrevs mut in - [{ - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_inductive_typ - { - FStar_Syntax_Syntax.lid = lid; - FStar_Syntax_Syntax.us = univs; - FStar_Syntax_Syntax.params = bnd'; - FStar_Syntax_Syntax.num_uniform_params = - num_uniform; - FStar_Syntax_Syntax.t = ty'; - FStar_Syntax_Syntax.mutuals = mut'; - FStar_Syntax_Syntax.ds = dc; - FStar_Syntax_Syntax.injective_type_params = - injective_type_params - }); - FStar_Syntax_Syntax.sigrng = - (x.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (x.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (x.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (x.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (x.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (x.FStar_Syntax_Syntax.sigopts) - }] - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = lid; - FStar_Syntax_Syntax.us1 = univs; - FStar_Syntax_Syntax.t1 = ty; - FStar_Syntax_Syntax.ty_lid = res; - FStar_Syntax_Syntax.num_ty_params = npars; - FStar_Syntax_Syntax.mutuals1 = mut; - FStar_Syntax_Syntax.injective_type_params1 = - injective_type_params;_} - -> - let ty' = FStar_Syntax_InstFV.inst unfold_fv ty in - let mut' = filter_out_type_abbrevs mut in - [{ - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_datacon - { - FStar_Syntax_Syntax.lid1 = lid; - FStar_Syntax_Syntax.us1 = univs; - FStar_Syntax_Syntax.t1 = ty'; - FStar_Syntax_Syntax.ty_lid = res; - FStar_Syntax_Syntax.num_ty_params = npars; - FStar_Syntax_Syntax.mutuals1 = mut'; - FStar_Syntax_Syntax.injective_type_params1 = - injective_type_params - }); - FStar_Syntax_Syntax.sigrng = - (x.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (x.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (x.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (x.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (x.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (x.FStar_Syntax_Syntax.sigopts) - }] - | FStar_Syntax_Syntax.Sig_let uu___1 -> [] - | uu___1 -> - failwith - "mutrecty: inductives_with_abbrevs_unfolded: unfold_in_sig: impossible" in - FStar_Compiler_List.collect unfold_in_sig sigelts in - let new_members = filter_out_type_abbrevs members in - let new_bundle = - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_bundle - { - FStar_Syntax_Syntax.ses = - inductives_with_abbrevs_unfolded; - FStar_Syntax_Syntax.lids = new_members - }); - FStar_Syntax_Syntax.sigrng = rng; - FStar_Syntax_Syntax.sigquals = quals; - FStar_Syntax_Syntax.sigmeta = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs = sigattrs1; - FStar_Syntax_Syntax.sigopens_and_abbrevs = []; - FStar_Syntax_Syntax.sigopts = FStar_Pervasives_Native.None - } in - (new_bundle, unfolded_type_abbrevs) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_Print.ml b/ocaml/fstar-lib/generated/FStar_Syntax_Print.ml deleted file mode 100644 index 701bfe161cb..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Syntax_Print.ml +++ /dev/null @@ -1,949 +0,0 @@ -open Prims -let (sli : FStar_Ident.lident -> Prims.string) = - fun l -> - let uu___ = FStar_Options.print_real_names () in - if uu___ - then FStar_Ident.string_of_lid l - else - (let uu___2 = FStar_Ident.ident_of_lid l in - FStar_Ident.string_of_id uu___2) -let (lid_to_string : FStar_Ident.lid -> Prims.string) = fun l -> sli l -let (fv_to_string : FStar_Syntax_Syntax.fv -> Prims.string) = - fun fv -> - lid_to_string (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v -let (bv_to_string : FStar_Syntax_Syntax.bv -> Prims.string) = - fun bv -> - let uu___ = FStar_Options.print_real_names () in - if uu___ - then - let uu___1 = - FStar_Class_Show.show FStar_Ident.showable_ident - bv.FStar_Syntax_Syntax.ppname in - let uu___2 = - let uu___3 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - bv.FStar_Syntax_Syntax.index in - Prims.strcat "#" uu___3 in - Prims.strcat uu___1 uu___2 - else - FStar_Class_Show.show FStar_Ident.showable_ident - bv.FStar_Syntax_Syntax.ppname -let (nm_to_string : FStar_Syntax_Syntax.bv -> Prims.string) = - fun bv -> - let uu___ = FStar_Options.print_real_names () in - if uu___ - then bv_to_string bv - else FStar_Ident.string_of_id bv.FStar_Syntax_Syntax.ppname -let (db_to_string : FStar_Syntax_Syntax.bv -> Prims.string) = - fun bv -> - let uu___ = FStar_Ident.string_of_id bv.FStar_Syntax_Syntax.ppname in - let uu___1 = - let uu___2 = - FStar_Compiler_Util.string_of_int bv.FStar_Syntax_Syntax.index in - Prims.strcat "@" uu___2 in - Prims.strcat uu___ uu___1 -let (filter_imp : - FStar_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> - Prims.bool) - = - fun aq -> - match aq with - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta t) when - FStar_Syntax_Util.is_fvar FStar_Parser_Const.tcresolve_lid t -> true - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit uu___) -> - false - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta uu___) -> false - | uu___ -> true -let filter_imp_args : - 'uuuuu . - ('uuuuu * FStar_Syntax_Syntax.arg_qualifier - FStar_Pervasives_Native.option) Prims.list -> - ('uuuuu * FStar_Syntax_Syntax.arg_qualifier - FStar_Pervasives_Native.option) Prims.list - = - fun args -> - FStar_Compiler_List.filter - (fun uu___ -> - match uu___ with - | (uu___1, FStar_Pervasives_Native.None) -> true - | (uu___1, FStar_Pervasives_Native.Some a) -> - Prims.op_Negation a.FStar_Syntax_Syntax.aqual_implicit) args -let (filter_imp_binders : - FStar_Syntax_Syntax.binder Prims.list -> - FStar_Syntax_Syntax.binder Prims.list) - = - fun bs -> - FStar_Compiler_List.filter - (fun b -> filter_imp b.FStar_Syntax_Syntax.binder_qual) bs -let (const_to_string : FStar_Const.sconst -> Prims.string) = - FStar_Parser_Const.const_to_string -let (lbname_to_string : - (FStar_Syntax_Syntax.bv, FStar_Syntax_Syntax.fv) FStar_Pervasives.either -> - Prims.string) - = - fun uu___ -> - match uu___ with - | FStar_Pervasives.Inl l -> bv_to_string l - | FStar_Pervasives.Inr l -> - lid_to_string (l.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v -let (uvar_to_string : FStar_Syntax_Syntax.uvar -> Prims.string) = - fun u -> - let uu___ = FStar_Options.hide_uvar_nums () in - if uu___ - then "?" - else - (let uu___2 = - let uu___3 = FStar_Syntax_Unionfind.uvar_id u in - FStar_Compiler_Util.string_of_int uu___3 in - Prims.strcat "?" uu___2) -let (version_to_string : FStar_Syntax_Syntax.version -> Prims.string) = - fun v -> - let uu___ = FStar_Compiler_Util.string_of_int v.FStar_Syntax_Syntax.major in - let uu___1 = - FStar_Compiler_Util.string_of_int v.FStar_Syntax_Syntax.minor in - FStar_Compiler_Util.format2 "%s.%s" uu___ uu___1 -let (univ_uvar_to_string : - (FStar_Syntax_Syntax.universe FStar_Pervasives_Native.option - FStar_Unionfind.p_uvar * FStar_Syntax_Syntax.version * - FStar_Compiler_Range_Type.range) -> Prims.string) - = - fun u -> - let uu___ = FStar_Options.hide_uvar_nums () in - if uu___ - then "?" - else - (let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Unionfind.univ_uvar_id u in - FStar_Compiler_Util.string_of_int uu___4 in - let uu___4 = - let uu___5 = - match u with | (uu___6, u1, uu___7) -> version_to_string u1 in - Prims.strcat ":" uu___5 in - Prims.strcat uu___3 uu___4 in - Prims.strcat "?" uu___2) -let rec (int_of_univ : - Prims.int -> - FStar_Syntax_Syntax.universe -> - (Prims.int * FStar_Syntax_Syntax.universe - FStar_Pervasives_Native.option)) - = - fun n -> - fun u -> - let uu___ = FStar_Syntax_Subst.compress_univ u in - match uu___ with - | FStar_Syntax_Syntax.U_zero -> (n, FStar_Pervasives_Native.None) - | FStar_Syntax_Syntax.U_succ u1 -> int_of_univ (n + Prims.int_one) u1 - | uu___1 -> (n, (FStar_Pervasives_Native.Some u)) -let rec (univ_to_string : FStar_Syntax_Syntax.universe -> Prims.string) = - fun u -> - FStar_Errors.with_ctx "While printing universe" - (fun uu___ -> - let uu___1 = FStar_Syntax_Subst.compress_univ u in - match uu___1 with - | FStar_Syntax_Syntax.U_unif u1 -> - let uu___2 = univ_uvar_to_string u1 in - Prims.strcat "U_unif " uu___2 - | FStar_Syntax_Syntax.U_name x -> - let uu___2 = FStar_Ident.string_of_id x in - Prims.strcat "U_name " uu___2 - | FStar_Syntax_Syntax.U_bvar x -> - let uu___2 = FStar_Compiler_Util.string_of_int x in - Prims.strcat "@" uu___2 - | FStar_Syntax_Syntax.U_zero -> "0" - | FStar_Syntax_Syntax.U_succ u1 -> - let uu___2 = int_of_univ Prims.int_one u1 in - (match uu___2 with - | (n, FStar_Pervasives_Native.None) -> - FStar_Compiler_Util.string_of_int n - | (n, FStar_Pervasives_Native.Some u2) -> - let uu___3 = univ_to_string u2 in - let uu___4 = FStar_Compiler_Util.string_of_int n in - FStar_Compiler_Util.format2 "(%s + %s)" uu___3 uu___4) - | FStar_Syntax_Syntax.U_max us -> - let uu___2 = - let uu___3 = FStar_Compiler_List.map univ_to_string us in - FStar_Compiler_String.concat ", " uu___3 in - FStar_Compiler_Util.format1 "(max %s)" uu___2 - | FStar_Syntax_Syntax.U_unknown -> "unknown") -let (univs_to_string : - FStar_Syntax_Syntax.universe Prims.list -> Prims.string) = - fun us -> - let uu___ = FStar_Compiler_List.map univ_to_string us in - FStar_Compiler_String.concat ", " uu___ -let (qual_to_string : FStar_Syntax_Syntax.qualifier -> Prims.string) = - fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.Assumption -> "assume" - | FStar_Syntax_Syntax.InternalAssumption -> "internal_assume" - | FStar_Syntax_Syntax.New -> "new" - | FStar_Syntax_Syntax.Private -> "private" - | FStar_Syntax_Syntax.Unfold_for_unification_and_vcgen -> "unfold" - | FStar_Syntax_Syntax.Inline_for_extraction -> "inline_for_extraction" - | FStar_Syntax_Syntax.NoExtract -> "noextract" - | FStar_Syntax_Syntax.Visible_default -> "visible" - | FStar_Syntax_Syntax.Irreducible -> "irreducible" - | FStar_Syntax_Syntax.Noeq -> "noeq" - | FStar_Syntax_Syntax.Unopteq -> "unopteq" - | FStar_Syntax_Syntax.Logic -> "logic" - | FStar_Syntax_Syntax.TotalEffect -> "total" - | FStar_Syntax_Syntax.Discriminator l -> - let uu___1 = lid_to_string l in - FStar_Compiler_Util.format1 "(Discriminator %s)" uu___1 - | FStar_Syntax_Syntax.Projector (l, x) -> - let uu___1 = lid_to_string l in - let uu___2 = FStar_Ident.string_of_id x in - FStar_Compiler_Util.format2 "(Projector %s %s)" uu___1 uu___2 - | FStar_Syntax_Syntax.RecordType (ns, fns) -> - let uu___1 = - let uu___2 = FStar_Ident.path_of_ns ns in - FStar_Ident.text_of_path uu___2 in - let uu___2 = - let uu___3 = FStar_Compiler_List.map FStar_Ident.string_of_id fns in - FStar_Compiler_String.concat ", " uu___3 in - FStar_Compiler_Util.format2 "(RecordType %s %s)" uu___1 uu___2 - | FStar_Syntax_Syntax.RecordConstructor (ns, fns) -> - let uu___1 = - let uu___2 = FStar_Ident.path_of_ns ns in - FStar_Ident.text_of_path uu___2 in - let uu___2 = - let uu___3 = FStar_Compiler_List.map FStar_Ident.string_of_id fns in - FStar_Compiler_String.concat ", " uu___3 in - FStar_Compiler_Util.format2 "(RecordConstructor %s %s)" uu___1 uu___2 - | FStar_Syntax_Syntax.Action eff_lid -> - let uu___1 = lid_to_string eff_lid in - FStar_Compiler_Util.format1 "(Action %s)" uu___1 - | FStar_Syntax_Syntax.ExceptionConstructor -> "ExceptionConstructor" - | FStar_Syntax_Syntax.HasMaskedEffect -> "HasMaskedEffect" - | FStar_Syntax_Syntax.Effect -> "Effect" - | FStar_Syntax_Syntax.Reifiable -> "reify" - | FStar_Syntax_Syntax.Reflectable l -> - let uu___1 = FStar_Ident.string_of_lid l in - FStar_Compiler_Util.format1 "(reflect %s)" uu___1 - | FStar_Syntax_Syntax.OnlyName -> "OnlyName" -let (quals_to_string : - FStar_Syntax_Syntax.qualifier Prims.list -> Prims.string) = - fun quals -> - match quals with - | [] -> "" - | uu___ -> - let uu___1 = FStar_Compiler_List.map qual_to_string quals in - FStar_Compiler_String.concat " " uu___1 -let (quals_to_string' : - FStar_Syntax_Syntax.qualifier Prims.list -> Prims.string) = - fun quals -> - match quals with - | [] -> "" - | uu___ -> let uu___1 = quals_to_string quals in Prims.strcat uu___1 " " -let (paren : Prims.string -> Prims.string) = - fun s -> Prims.strcat "(" (Prims.strcat s ")") -let (lkind_to_string : FStar_Syntax_Syntax.lazy_kind -> Prims.string) = - fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.BadLazy -> "BadLazy" - | FStar_Syntax_Syntax.Lazy_bv -> "Lazy_bv" - | FStar_Syntax_Syntax.Lazy_namedv -> "Lazy_namedv" - | FStar_Syntax_Syntax.Lazy_binder -> "Lazy_binder" - | FStar_Syntax_Syntax.Lazy_optionstate -> "Lazy_optionstate" - | FStar_Syntax_Syntax.Lazy_fvar -> "Lazy_fvar" - | FStar_Syntax_Syntax.Lazy_comp -> "Lazy_comp" - | FStar_Syntax_Syntax.Lazy_env -> "Lazy_env" - | FStar_Syntax_Syntax.Lazy_proofstate -> "Lazy_proofstate" - | FStar_Syntax_Syntax.Lazy_goal -> "Lazy_goal" - | FStar_Syntax_Syntax.Lazy_sigelt -> "Lazy_sigelt" - | FStar_Syntax_Syntax.Lazy_uvar -> "Lazy_uvar" - | FStar_Syntax_Syntax.Lazy_letbinding -> "Lazy_letbinding" - | FStar_Syntax_Syntax.Lazy_embedding (e, uu___1) -> - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Syntax.showable_emb_typ e in - Prims.strcat uu___3 ")" in - Prims.strcat "Lazy_embedding(" uu___2 - | FStar_Syntax_Syntax.Lazy_universe -> "Lazy_universe" - | FStar_Syntax_Syntax.Lazy_universe_uvar -> "Lazy_universe_uvar" - | FStar_Syntax_Syntax.Lazy_issue -> "Lazy_issue" - | FStar_Syntax_Syntax.Lazy_ident -> "Lazy_ident" - | FStar_Syntax_Syntax.Lazy_doc -> "Lazy_doc" - | FStar_Syntax_Syntax.Lazy_extension s -> - Prims.strcat "Lazy_extension:" s -let (term_to_string : FStar_Syntax_Syntax.term -> Prims.string) = - fun x -> - let uu___ = FStar_Options.ugly () in - if uu___ - then FStar_Syntax_Print_Ugly.term_to_string x - else FStar_Syntax_Print_Pretty.term_to_string x -let (term_to_string' : - FStar_Syntax_DsEnv.env -> FStar_Syntax_Syntax.term -> Prims.string) = - fun env -> - fun x -> - let uu___ = FStar_Options.ugly () in - if uu___ - then FStar_Syntax_Print_Ugly.term_to_string x - else FStar_Syntax_Print_Pretty.term_to_string' env x -let (comp_to_string : FStar_Syntax_Syntax.comp -> Prims.string) = - fun c -> - let uu___ = FStar_Options.ugly () in - if uu___ - then FStar_Syntax_Print_Ugly.comp_to_string c - else FStar_Syntax_Print_Pretty.comp_to_string c -let (comp_to_string' : - FStar_Syntax_DsEnv.env -> FStar_Syntax_Syntax.comp -> Prims.string) = - fun env -> - fun c -> - let uu___ = FStar_Options.ugly () in - if uu___ - then FStar_Syntax_Print_Ugly.comp_to_string c - else FStar_Syntax_Print_Pretty.comp_to_string' env c -let (sigelt_to_string : FStar_Syntax_Syntax.sigelt -> Prims.string) = - fun x -> - let uu___ = FStar_Options.ugly () in - if uu___ - then FStar_Syntax_Print_Ugly.sigelt_to_string x - else FStar_Syntax_Print_Pretty.sigelt_to_string x -let (sigelt_to_string' : - FStar_Syntax_DsEnv.env -> FStar_Syntax_Syntax.sigelt -> Prims.string) = - fun env -> - fun x -> - let uu___ = FStar_Options.ugly () in - if uu___ - then FStar_Syntax_Print_Ugly.sigelt_to_string x - else FStar_Syntax_Print_Pretty.sigelt_to_string' env x -let (pat_to_string : FStar_Syntax_Syntax.pat -> Prims.string) = - fun x -> - let uu___ = FStar_Options.ugly () in - if uu___ - then FStar_Syntax_Print_Ugly.pat_to_string x - else FStar_Syntax_Print_Pretty.pat_to_string x -let (term_to_doc' : - FStar_Syntax_DsEnv.env -> FStar_Syntax_Syntax.term -> FStar_Pprint.document) - = - fun dsenv -> - fun t -> - let uu___ = FStar_Options.ugly () in - if uu___ - then - let uu___1 = FStar_Syntax_Print_Ugly.term_to_string t in - FStar_Pprint.arbitrary_string uu___1 - else FStar_Syntax_Print_Pretty.term_to_doc' dsenv t -let (univ_to_doc' : - FStar_Syntax_DsEnv.env -> - FStar_Syntax_Syntax.universe -> FStar_Pprint.document) - = - fun dsenv -> - fun t -> - let uu___ = FStar_Options.ugly () in - if uu___ - then - let uu___1 = FStar_Syntax_Print_Ugly.univ_to_string t in - FStar_Pprint.arbitrary_string uu___1 - else FStar_Syntax_Print_Pretty.univ_to_doc' dsenv t -let (comp_to_doc' : - FStar_Syntax_DsEnv.env -> FStar_Syntax_Syntax.comp -> FStar_Pprint.document) - = - fun dsenv -> - fun t -> - let uu___ = FStar_Options.ugly () in - if uu___ - then - let uu___1 = FStar_Syntax_Print_Ugly.comp_to_string t in - FStar_Pprint.arbitrary_string uu___1 - else FStar_Syntax_Print_Pretty.comp_to_doc' dsenv t -let (sigelt_to_doc' : - FStar_Syntax_DsEnv.env -> - FStar_Syntax_Syntax.sigelt -> FStar_Pprint.document) - = - fun dsenv -> - fun t -> - let uu___ = FStar_Options.ugly () in - if uu___ - then - let uu___1 = FStar_Syntax_Print_Ugly.sigelt_to_string t in - FStar_Pprint.arbitrary_string uu___1 - else FStar_Syntax_Print_Pretty.sigelt_to_doc' dsenv t -let (term_to_doc : FStar_Syntax_Syntax.term -> FStar_Pprint.document) = - fun t -> - let uu___ = FStar_Options.ugly () in - if uu___ - then - let uu___1 = FStar_Syntax_Print_Ugly.term_to_string t in - FStar_Pprint.arbitrary_string uu___1 - else FStar_Syntax_Print_Pretty.term_to_doc t -let (univ_to_doc : FStar_Syntax_Syntax.universe -> FStar_Pprint.document) = - fun t -> - let uu___ = FStar_Options.ugly () in - if uu___ - then - let uu___1 = FStar_Syntax_Print_Ugly.univ_to_string t in - FStar_Pprint.arbitrary_string uu___1 - else FStar_Syntax_Print_Pretty.univ_to_doc t -let (comp_to_doc : FStar_Syntax_Syntax.comp -> FStar_Pprint.document) = - fun t -> - let uu___ = FStar_Options.ugly () in - if uu___ - then - let uu___1 = FStar_Syntax_Print_Ugly.comp_to_string t in - FStar_Pprint.arbitrary_string uu___1 - else FStar_Syntax_Print_Pretty.comp_to_doc t -let (sigelt_to_doc : FStar_Syntax_Syntax.sigelt -> FStar_Pprint.document) = - fun t -> - let uu___ = FStar_Options.ugly () in - if uu___ - then - let uu___1 = FStar_Syntax_Print_Ugly.sigelt_to_string t in - FStar_Pprint.arbitrary_string uu___1 - else FStar_Syntax_Print_Pretty.sigelt_to_doc t -let (binder_to_string : FStar_Syntax_Syntax.binder -> Prims.string) = - fun b -> - let uu___ = FStar_Options.ugly () in - if uu___ - then FStar_Syntax_Print_Pretty.binder_to_string' false b - else FStar_Syntax_Print_Ugly.binder_to_string b -let (aqual_to_string : FStar_Syntax_Syntax.aqual -> Prims.string) = - fun q -> - match q with - | FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = uu___;_} - -> "#" - | uu___ -> "" -let (bqual_to_string' : - Prims.string -> FStar_Syntax_Syntax.bqual -> Prims.string) = - fun s -> - fun b -> - match b with - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit (false)) - -> Prims.strcat "#" s - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit (true)) -> - Prims.strcat "#." s - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Equality) -> - Prims.strcat "$" s - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta t) when - FStar_Syntax_Util.is_fvar FStar_Parser_Const.tcresolve_lid t -> - Prims.strcat "{|" (Prims.strcat s "|}") - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta t) -> - let uu___ = - let uu___1 = term_to_string t in - Prims.strcat uu___1 (Prims.strcat "]" s) in - Prims.strcat "#[" uu___ - | FStar_Pervasives_Native.None -> s -let (bqual_to_string : FStar_Syntax_Syntax.bqual -> Prims.string) = - fun q -> bqual_to_string' "" q -let (subst_elt_to_string : FStar_Syntax_Syntax.subst_elt -> Prims.string) = - fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.DB (i, x) -> - let uu___1 = FStar_Compiler_Util.string_of_int i in - let uu___2 = bv_to_string x in - FStar_Compiler_Util.format2 "DB (%s, %s)" uu___1 uu___2 - | FStar_Syntax_Syntax.DT (i, t) -> - let uu___1 = FStar_Compiler_Util.string_of_int i in - let uu___2 = term_to_string t in - FStar_Compiler_Util.format2 "DT (%s, %s)" uu___1 uu___2 - | FStar_Syntax_Syntax.NM (x, i) -> - let uu___1 = bv_to_string x in - let uu___2 = FStar_Compiler_Util.string_of_int i in - FStar_Compiler_Util.format2 "NM (%s, %s)" uu___1 uu___2 - | FStar_Syntax_Syntax.NT (x, t) -> - let uu___1 = bv_to_string x in - let uu___2 = term_to_string t in - FStar_Compiler_Util.format2 "NT (%s, %s)" uu___1 uu___2 - | FStar_Syntax_Syntax.UN (i, u) -> - let uu___1 = FStar_Compiler_Util.string_of_int i in - let uu___2 = univ_to_string u in - FStar_Compiler_Util.format2 "UN (%s, %s)" uu___1 uu___2 - | FStar_Syntax_Syntax.UD (u, i) -> - let uu___1 = FStar_Ident.string_of_id u in - let uu___2 = FStar_Compiler_Util.string_of_int i in - FStar_Compiler_Util.format2 "UD (%s, %s)" uu___1 uu___2 -let (modul_to_string : FStar_Syntax_Syntax.modul -> Prims.string) = - fun m -> - let uu___ = - FStar_Class_Show.show FStar_Ident.showable_lident - m.FStar_Syntax_Syntax.name in - let uu___1 = - let uu___2 = - FStar_Compiler_List.map sigelt_to_string - m.FStar_Syntax_Syntax.declarations in - FStar_Compiler_String.concat "\n" uu___2 in - FStar_Compiler_Util.format2 "module %s\nDeclarations: [\n%s\n]\n" uu___ - uu___1 -let (metadata_to_string : FStar_Syntax_Syntax.metadata -> Prims.string) = - fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.Meta_pattern (uu___1, ps) -> - let pats = - let uu___2 = - FStar_Compiler_List.map - (fun args -> - let uu___3 = - FStar_Compiler_List.map - (fun uu___4 -> - match uu___4 with | (t, uu___5) -> term_to_string t) - args in - FStar_Compiler_String.concat "; " uu___3) ps in - FStar_Compiler_String.concat "\\/" uu___2 in - FStar_Compiler_Util.format1 "{Meta_pattern %s}" pats - | FStar_Syntax_Syntax.Meta_named lid -> - let uu___1 = sli lid in - FStar_Compiler_Util.format1 "{Meta_named %s}" uu___1 - | FStar_Syntax_Syntax.Meta_labeled (l, r, uu___1) -> - let uu___2 = FStar_Errors_Msg.rendermsg l in - let uu___3 = FStar_Compiler_Range_Ops.string_of_range r in - FStar_Compiler_Util.format2 "{Meta_labeled (%s, %s)}" uu___2 uu___3 - | FStar_Syntax_Syntax.Meta_desugared msi -> "{Meta_desugared}" - | FStar_Syntax_Syntax.Meta_monadic (m, t) -> - let uu___1 = sli m in - let uu___2 = term_to_string t in - FStar_Compiler_Util.format2 "{Meta_monadic(%s @ %s)}" uu___1 uu___2 - | FStar_Syntax_Syntax.Meta_monadic_lift (m, m', t) -> - let uu___1 = sli m in - let uu___2 = sli m' in - let uu___3 = term_to_string t in - FStar_Compiler_Util.format3 "{Meta_monadic_lift(%s -> %s @ %s)}" - uu___1 uu___2 uu___3 -let (showable_term : FStar_Syntax_Syntax.term FStar_Class_Show.showable) = - { FStar_Class_Show.show = term_to_string } -let (showable_univ : FStar_Syntax_Syntax.universe FStar_Class_Show.showable) - = { FStar_Class_Show.show = univ_to_string } -let (showable_comp : FStar_Syntax_Syntax.comp FStar_Class_Show.showable) = - { FStar_Class_Show.show = comp_to_string } -let (showable_sigelt : FStar_Syntax_Syntax.sigelt FStar_Class_Show.showable) - = { FStar_Class_Show.show = sigelt_to_string } -let (showable_bv : FStar_Syntax_Syntax.bv FStar_Class_Show.showable) = - { FStar_Class_Show.show = bv_to_string } -let (showable_fv : FStar_Syntax_Syntax.fv FStar_Class_Show.showable) = - { FStar_Class_Show.show = fv_to_string } -let (showable_binder : FStar_Syntax_Syntax.binder FStar_Class_Show.showable) - = { FStar_Class_Show.show = binder_to_string } -let (showable_uvar : FStar_Syntax_Syntax.uvar FStar_Class_Show.showable) = - { FStar_Class_Show.show = uvar_to_string } -let (ctx_uvar_to_string : FStar_Syntax_Syntax.ctx_uvar -> Prims.string) = - fun ctx_uvar -> - let reason_string = - FStar_Compiler_Util.format1 "(* %s *)\n" - ctx_uvar.FStar_Syntax_Syntax.ctx_uvar_reason in - let uu___ = - let uu___1 = - FStar_Compiler_List.map (FStar_Class_Show.show showable_binder) - ctx_uvar.FStar_Syntax_Syntax.ctx_uvar_binders in - FStar_Compiler_String.concat ", " uu___1 in - let uu___1 = uvar_to_string ctx_uvar.FStar_Syntax_Syntax.ctx_uvar_head in - let uu___2 = - let uu___3 = FStar_Syntax_Util.ctx_uvar_typ ctx_uvar in - term_to_string uu___3 in - let uu___3 = - let uu___4 = FStar_Syntax_Util.ctx_uvar_should_check ctx_uvar in - match uu___4 with - | FStar_Syntax_Syntax.Allow_unresolved s -> - Prims.strcat "Allow_unresolved " s - | FStar_Syntax_Syntax.Allow_untyped s -> - Prims.strcat "Allow_untyped " s - | FStar_Syntax_Syntax.Allow_ghost s -> Prims.strcat "Allow_ghost " s - | FStar_Syntax_Syntax.Strict -> "Strict" - | FStar_Syntax_Syntax.Already_checked -> "Already_checked" in - FStar_Compiler_Util.format5 "%s(%s |- %s : %s) %s" reason_string uu___ - uu___1 uu___2 uu___3 -let (showable_ctxu : FStar_Syntax_Syntax.ctx_uvar FStar_Class_Show.showable) - = { FStar_Class_Show.show = ctx_uvar_to_string } -let (showable_binding : - FStar_Syntax_Syntax.binding FStar_Class_Show.showable) = - { - FStar_Class_Show.show = - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.Binding_var x -> - let uu___1 = FStar_Class_Show.show showable_bv x in - Prims.strcat "Binding_var " uu___1 - | FStar_Syntax_Syntax.Binding_lid x -> - let uu___1 = - FStar_Class_Show.show - (FStar_Class_Show.show_tuple2 FStar_Ident.showable_lident - (FStar_Class_Show.show_tuple2 - (FStar_Class_Show.show_list FStar_Ident.showable_ident) - showable_term)) x in - Prims.strcat "Binding_lid " uu___1 - | FStar_Syntax_Syntax.Binding_univ x -> - let uu___1 = FStar_Class_Show.show FStar_Ident.showable_ident x in - Prims.strcat "Binding_univ " uu___1) - } -let (showable_subst_elt : - FStar_Syntax_Syntax.subst_elt FStar_Class_Show.showable) = - { FStar_Class_Show.show = subst_elt_to_string } -let (showable_branch : FStar_Syntax_Syntax.branch FStar_Class_Show.showable) - = { FStar_Class_Show.show = FStar_Syntax_Print_Ugly.branch_to_string } -let (showable_qualifier : - FStar_Syntax_Syntax.qualifier FStar_Class_Show.showable) = - { FStar_Class_Show.show = qual_to_string } -let (showable_pat : FStar_Syntax_Syntax.pat FStar_Class_Show.showable) = - { FStar_Class_Show.show = pat_to_string } -let (showable_const : FStar_Const.sconst FStar_Class_Show.showable) = - { FStar_Class_Show.show = const_to_string } -let (showable_letbinding : - FStar_Syntax_Syntax.letbinding FStar_Class_Show.showable) = - { FStar_Class_Show.show = FStar_Syntax_Print_Ugly.lb_to_string } -let (showable_modul : FStar_Syntax_Syntax.modul FStar_Class_Show.showable) = - { FStar_Class_Show.show = modul_to_string } -let (showable_metadata : - FStar_Syntax_Syntax.metadata FStar_Class_Show.showable) = - { FStar_Class_Show.show = metadata_to_string } -let (showable_ctx_uvar_meta : - FStar_Syntax_Syntax.ctx_uvar_meta_t FStar_Class_Show.showable) = - { - FStar_Class_Show.show = - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.Ctx_uvar_meta_attr attr -> - let uu___1 = FStar_Class_Show.show showable_term attr in - Prims.strcat "Ctx_uvar_meta_attr " uu___1 - | FStar_Syntax_Syntax.Ctx_uvar_meta_tac r -> - let uu___1 = FStar_Class_Show.show showable_term r in - Prims.strcat "Ctx_uvar_meta_tac " uu___1) - } -let (showable_aqual : FStar_Syntax_Syntax.aqual FStar_Class_Show.showable) = - { FStar_Class_Show.show = aqual_to_string } -let (tscheme_to_string : FStar_Syntax_Syntax.tscheme -> Prims.string) = - fun ts -> - let uu___ = FStar_Options.ugly () in - if uu___ - then FStar_Syntax_Print_Ugly.tscheme_to_string ts - else FStar_Syntax_Print_Pretty.tscheme_to_string ts -let (sub_eff_to_string : FStar_Syntax_Syntax.sub_eff -> Prims.string) = - fun se -> - let tsopt_to_string ts_opt = - if FStar_Compiler_Util.is_some ts_opt - then - let uu___ = FStar_Compiler_Util.must ts_opt in - tscheme_to_string uu___ - else "" in - let uu___ = lid_to_string se.FStar_Syntax_Syntax.source in - let uu___1 = lid_to_string se.FStar_Syntax_Syntax.target in - let uu___2 = tsopt_to_string se.FStar_Syntax_Syntax.lift in - let uu___3 = tsopt_to_string se.FStar_Syntax_Syntax.lift_wp in - FStar_Compiler_Util.format4 - "sub_effect %s ~> %s : lift = %s ;; lift_wp = %s" uu___ uu___1 uu___2 - uu___3 -let (showable_sub_eff : - FStar_Syntax_Syntax.sub_eff FStar_Class_Show.showable) = - { FStar_Class_Show.show = sub_eff_to_string } -let (pretty_term : FStar_Syntax_Syntax.term FStar_Class_PP.pretty) = - { FStar_Class_PP.pp = term_to_doc } -let (pretty_univ : FStar_Syntax_Syntax.universe FStar_Class_PP.pretty) = - { FStar_Class_PP.pp = univ_to_doc } -let (pretty_sigelt : FStar_Syntax_Syntax.sigelt FStar_Class_PP.pretty) = - { FStar_Class_PP.pp = sigelt_to_doc } -let (pretty_comp : FStar_Syntax_Syntax.comp FStar_Class_PP.pretty) = - { FStar_Class_PP.pp = comp_to_doc } -let (pretty_ctxu : FStar_Syntax_Syntax.ctx_uvar FStar_Class_PP.pretty) = - { - FStar_Class_PP.pp = - (fun x -> - let uu___ = FStar_Class_Show.show showable_ctxu x in - FStar_Pprint.doc_of_string uu___) - } -let (pretty_uvar : FStar_Syntax_Syntax.uvar FStar_Class_PP.pretty) = - { - FStar_Class_PP.pp = - (fun x -> - let uu___ = FStar_Class_Show.show showable_uvar x in - FStar_Pprint.doc_of_string uu___) - } -let (pretty_binder : FStar_Syntax_Syntax.binder FStar_Class_PP.pretty) = - { - FStar_Class_PP.pp = - (fun x -> - let uu___ = FStar_Class_Show.show showable_binder x in - FStar_Pprint.doc_of_string uu___) - } -let (pretty_bv : FStar_Syntax_Syntax.bv FStar_Class_PP.pretty) = - { - FStar_Class_PP.pp = - (fun x -> - let uu___ = FStar_Class_Show.show showable_bv x in - FStar_Pprint.doc_of_string uu___) - } -let (pretty_binding : FStar_Syntax_Syntax.binding FStar_Class_PP.pretty) = - { - FStar_Class_PP.pp = - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.Binding_var bv -> - FStar_Class_PP.pp pretty_bv bv - | FStar_Syntax_Syntax.Binding_lid (l, (us, t)) -> - let uu___1 = FStar_Class_PP.pp FStar_Ident.pretty_lident l in - let uu___2 = - let uu___3 = FStar_Class_PP.pp pretty_term t in - FStar_Pprint.op_Hat_Hat FStar_Pprint.colon uu___3 in - FStar_Pprint.op_Hat_Hat uu___1 uu___2 - | FStar_Syntax_Syntax.Binding_univ u -> - FStar_Class_PP.pp FStar_Ident.pretty_ident u) - } -let rec (sigelt_to_string_short : FStar_Syntax_Syntax.sigelt -> Prims.string) - = - fun x -> - match x.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_pragma p -> - FStar_Class_Show.show FStar_Syntax_Syntax.showable_pragma p - | FStar_Syntax_Syntax.Sig_let - { - FStar_Syntax_Syntax.lbs1 = - (false, - { FStar_Syntax_Syntax.lbname = lb; - FStar_Syntax_Syntax.lbunivs = uu___; - FStar_Syntax_Syntax.lbtyp = uu___1; - FStar_Syntax_Syntax.lbeff = uu___2; - FStar_Syntax_Syntax.lbdef = uu___3; - FStar_Syntax_Syntax.lbattrs = uu___4; - FStar_Syntax_Syntax.lbpos = uu___5;_}::[]); - FStar_Syntax_Syntax.lids1 = uu___6;_} - -> - let uu___7 = lbname_to_string lb in - FStar_Compiler_Util.format1 "let %s" uu___7 - | FStar_Syntax_Syntax.Sig_let - { - FStar_Syntax_Syntax.lbs1 = - (true, - { FStar_Syntax_Syntax.lbname = lb; - FStar_Syntax_Syntax.lbunivs = uu___; - FStar_Syntax_Syntax.lbtyp = uu___1; - FStar_Syntax_Syntax.lbeff = uu___2; - FStar_Syntax_Syntax.lbdef = uu___3; - FStar_Syntax_Syntax.lbattrs = uu___4; - FStar_Syntax_Syntax.lbpos = uu___5;_}::[]); - FStar_Syntax_Syntax.lids1 = uu___6;_} - -> - let uu___7 = lbname_to_string lb in - FStar_Compiler_Util.format1 "let rec %s" uu___7 - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (true, lbs); - FStar_Syntax_Syntax.lids1 = uu___;_} - -> - let uu___1 = - let uu___2 = - FStar_Compiler_List.map - (fun lb -> lbname_to_string lb.FStar_Syntax_Syntax.lbname) lbs in - FStar_Compiler_String.concat " and " uu___2 in - FStar_Compiler_Util.format1 "let rec %s" uu___1 - | FStar_Syntax_Syntax.Sig_let uu___ -> - failwith "Impossible: sigelt_to_string_short, ill-formed let" - | FStar_Syntax_Syntax.Sig_declare_typ - { FStar_Syntax_Syntax.lid2 = lid; FStar_Syntax_Syntax.us2 = uu___; - FStar_Syntax_Syntax.t2 = uu___1;_} - -> - let uu___2 = FStar_Ident.string_of_lid lid in - FStar_Compiler_Util.format1 "val %s" uu___2 - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = lid; FStar_Syntax_Syntax.us = uu___; - FStar_Syntax_Syntax.params = uu___1; - FStar_Syntax_Syntax.num_uniform_params = uu___2; - FStar_Syntax_Syntax.t = uu___3; - FStar_Syntax_Syntax.mutuals = uu___4; - FStar_Syntax_Syntax.ds = uu___5; - FStar_Syntax_Syntax.injective_type_params = uu___6;_} - -> - let uu___7 = FStar_Ident.string_of_lid lid in - FStar_Compiler_Util.format1 "type %s" uu___7 - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = lid; FStar_Syntax_Syntax.us1 = uu___; - FStar_Syntax_Syntax.t1 = uu___1; - FStar_Syntax_Syntax.ty_lid = t_lid; - FStar_Syntax_Syntax.num_ty_params = uu___2; - FStar_Syntax_Syntax.mutuals1 = uu___3; - FStar_Syntax_Syntax.injective_type_params1 = uu___4;_} - -> - let uu___5 = FStar_Ident.string_of_lid lid in - let uu___6 = FStar_Ident.string_of_lid t_lid in - FStar_Compiler_Util.format2 "datacon %s for type %s" uu___5 uu___6 - | FStar_Syntax_Syntax.Sig_assume - { FStar_Syntax_Syntax.lid3 = lid; FStar_Syntax_Syntax.us3 = uu___; - FStar_Syntax_Syntax.phi1 = uu___1;_} - -> - let uu___2 = FStar_Ident.string_of_lid lid in - FStar_Compiler_Util.format1 "assume %s" uu___2 - | FStar_Syntax_Syntax.Sig_bundle - { FStar_Syntax_Syntax.ses = ses; FStar_Syntax_Syntax.lids = uu___;_} - -> - let uu___1 = FStar_Compiler_List.hd ses in - sigelt_to_string_short uu___1 - | FStar_Syntax_Syntax.Sig_fail - { FStar_Syntax_Syntax.errs = uu___; - FStar_Syntax_Syntax.fail_in_lax = uu___1; - FStar_Syntax_Syntax.ses1 = ses;_} - -> - let uu___2 = - let uu___3 = FStar_Compiler_List.hd ses in - sigelt_to_string_short uu___3 in - FStar_Compiler_Util.format1 "[@@expect_failure] %s" uu___2 - | FStar_Syntax_Syntax.Sig_new_effect ed -> - let kw = - let uu___ = FStar_Syntax_Util.is_layered ed in - if uu___ - then "layered_effect" - else - (let uu___2 = FStar_Syntax_Util.is_dm4f ed in - if uu___2 then "new_effect_for_free" else "new_effect") in - let uu___ = lid_to_string ed.FStar_Syntax_Syntax.mname in - FStar_Compiler_Util.format2 "%s { %s ... }" kw uu___ - | FStar_Syntax_Syntax.Sig_sub_effect se -> - let uu___ = lid_to_string se.FStar_Syntax_Syntax.source in - let uu___1 = lid_to_string se.FStar_Syntax_Syntax.target in - FStar_Compiler_Util.format2 "sub_effect %s ~> %s" uu___ uu___1 - | FStar_Syntax_Syntax.Sig_effect_abbrev - { FStar_Syntax_Syntax.lid4 = l; FStar_Syntax_Syntax.us4 = uu___; - FStar_Syntax_Syntax.bs2 = tps; FStar_Syntax_Syntax.comp1 = c; - FStar_Syntax_Syntax.cflags = uu___1;_} - -> - let uu___2 = sli l in - let uu___3 = - let uu___4 = - FStar_Compiler_List.map (FStar_Class_Show.show showable_binder) - tps in - FStar_Compiler_String.concat " " uu___4 in - let uu___4 = FStar_Class_Show.show showable_comp c in - FStar_Compiler_Util.format3 "effect %s %s = %s" uu___2 uu___3 uu___4 - | FStar_Syntax_Syntax.Sig_splice - { FStar_Syntax_Syntax.is_typed = is_typed; - FStar_Syntax_Syntax.lids2 = lids; - FStar_Syntax_Syntax.tac = uu___;_} - -> - let uu___1 = - let uu___2 = FStar_Compiler_List.map FStar_Ident.string_of_lid lids in - FStar_Compiler_String.concat "; " uu___2 in - FStar_Compiler_Util.format3 "%splice%s[%s] (...)" "%s" - (if is_typed then "_t" else "") uu___1 - | FStar_Syntax_Syntax.Sig_polymonadic_bind - { FStar_Syntax_Syntax.m_lid = m; FStar_Syntax_Syntax.n_lid = n; - FStar_Syntax_Syntax.p_lid = p; FStar_Syntax_Syntax.tm3 = uu___; - FStar_Syntax_Syntax.typ = uu___1; - FStar_Syntax_Syntax.kind1 = uu___2;_} - -> - let uu___3 = FStar_Ident.string_of_lid m in - let uu___4 = FStar_Ident.string_of_lid n in - let uu___5 = FStar_Ident.string_of_lid p in - FStar_Compiler_Util.format3 "polymonadic_bind (%s, %s) |> %s" uu___3 - uu___4 uu___5 - | FStar_Syntax_Syntax.Sig_polymonadic_subcomp - { FStar_Syntax_Syntax.m_lid1 = m; FStar_Syntax_Syntax.n_lid1 = n; - FStar_Syntax_Syntax.tm4 = uu___; FStar_Syntax_Syntax.typ1 = uu___1; - FStar_Syntax_Syntax.kind2 = uu___2;_} - -> - let uu___3 = FStar_Ident.string_of_lid m in - let uu___4 = FStar_Ident.string_of_lid n in - FStar_Compiler_Util.format2 "polymonadic_subcomp %s <: %s" uu___3 - uu___4 -let (binder_to_json : - FStar_Syntax_DsEnv.env -> FStar_Syntax_Syntax.binder -> FStar_Json.json) = - fun env -> - fun b -> - let n = - let uu___ = - let uu___1 = nm_to_string b.FStar_Syntax_Syntax.binder_bv in - bqual_to_string' uu___1 b.FStar_Syntax_Syntax.binder_qual in - FStar_Json.JsonStr uu___ in - let t = - let uu___ = - term_to_string' env - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - FStar_Json.JsonStr uu___ in - FStar_Json.JsonAssoc [("name", n); ("type", t)] -let (binders_to_json : - FStar_Syntax_DsEnv.env -> FStar_Syntax_Syntax.binders -> FStar_Json.json) = - fun env -> - fun bs -> - let uu___ = FStar_Compiler_List.map (binder_to_json env) bs in - FStar_Json.JsonList uu___ -let (eff_decl_to_string : FStar_Syntax_Syntax.eff_decl -> Prims.string) = - fun ed -> - let uu___ = FStar_Options.ugly () in - if uu___ - then FStar_Syntax_Print_Ugly.eff_decl_to_string ed - else FStar_Syntax_Print_Pretty.eff_decl_to_string ed -let (showable_eff_decl : - FStar_Syntax_Syntax.eff_decl FStar_Class_Show.showable) = - { FStar_Class_Show.show = eff_decl_to_string } -let (args_to_string : FStar_Syntax_Syntax.args -> Prims.string) = - fun args -> - let uu___ = - FStar_Compiler_List.map - (fun uu___1 -> - match uu___1 with - | (a, q) -> - let uu___2 = aqual_to_string q in - let uu___3 = term_to_string a in Prims.strcat uu___2 uu___3) - args in - FStar_Compiler_String.concat " " uu___ -let (showable_decreases_order : - FStar_Syntax_Syntax.decreases_order FStar_Class_Show.showable) = - { - FStar_Class_Show.show = - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.Decreases_lex l -> - let uu___1 = - FStar_Class_Show.show - (FStar_Class_Show.show_list showable_term) l in - Prims.strcat "Decreases_lex " uu___1 - | FStar_Syntax_Syntax.Decreases_wf l -> - let uu___1 = - FStar_Class_Show.show - (FStar_Class_Show.show_tuple2 showable_term showable_term) l in - Prims.strcat "Decreases_wf " uu___1) - } -let (cflag_to_string : FStar_Syntax_Syntax.cflag -> Prims.string) = - fun c -> - match c with - | FStar_Syntax_Syntax.TOTAL -> "total" - | FStar_Syntax_Syntax.MLEFFECT -> "ml" - | FStar_Syntax_Syntax.RETURN -> "return" - | FStar_Syntax_Syntax.PARTIAL_RETURN -> "partial_return" - | FStar_Syntax_Syntax.SOMETRIVIAL -> "sometrivial" - | FStar_Syntax_Syntax.TRIVIAL_POSTCONDITION -> "trivial_postcondition" - | FStar_Syntax_Syntax.SHOULD_NOT_INLINE -> "should_not_inline" - | FStar_Syntax_Syntax.LEMMA -> "lemma" - | FStar_Syntax_Syntax.CPS -> "cps" - | FStar_Syntax_Syntax.DECREASES do1 -> - let uu___ = FStar_Class_Show.show showable_decreases_order do1 in - Prims.strcat "decreases " uu___ -let (showable_cflag : FStar_Syntax_Syntax.cflag FStar_Class_Show.showable) = - { FStar_Class_Show.show = cflag_to_string } -let (binder_to_string_with_type : FStar_Syntax_Syntax.binder -> Prims.string) - = - fun b -> - let uu___ = FStar_Options.ugly () in - if uu___ - then - let attrs = - match b.FStar_Syntax_Syntax.binder_attrs with - | [] -> "" - | ts -> - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Compiler_List.map - (FStar_Class_Show.show showable_term) ts in - FStar_Compiler_String.concat ", " uu___3 in - Prims.strcat uu___2 "] " in - Prims.strcat "[@@@" uu___1 in - let uu___1 = FStar_Syntax_Syntax.is_null_binder b in - (if uu___1 - then - let uu___2 = - let uu___3 = - term_to_string - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - Prims.strcat "_:" uu___3 in - Prims.strcat attrs uu___2 - else - (let uu___3 = - let uu___4 = - let uu___5 = nm_to_string b.FStar_Syntax_Syntax.binder_bv in - let uu___6 = - let uu___7 = - term_to_string - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - Prims.strcat ": " uu___7 in - Prims.strcat uu___5 uu___6 in - Prims.strcat attrs uu___4 in - bqual_to_string' uu___3 b.FStar_Syntax_Syntax.binder_qual)) - else FStar_Syntax_Print_Pretty.binder_to_string' false b \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_Print_Pretty.ml b/ocaml/fstar-lib/generated/FStar_Syntax_Print_Pretty.ml deleted file mode 100644 index 1e5bcf1e2b0..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Syntax_Print_Pretty.ml +++ /dev/null @@ -1,164 +0,0 @@ -open Prims -let (rfrac : FStar_BaseTypes.float) = - FStar_Compiler_Util.float_of_string "1.0" -let (width : Prims.int) = (Prims.of_int (100)) -let (pp : FStar_Pprint.document -> Prims.string) = - fun d -> FStar_Pprint.pretty_string rfrac width d -let (term_to_doc' : - FStar_Syntax_DsEnv.env -> FStar_Syntax_Syntax.term -> FStar_Pprint.document) - = - fun env -> - fun tm -> - FStar_GenSym.with_frozen_gensym - (fun uu___ -> - let e = FStar_Syntax_Resugar.resugar_term' env tm in - FStar_Parser_ToDocument.term_to_document e) -let (univ_to_doc' : - FStar_Syntax_DsEnv.env -> - FStar_Syntax_Syntax.universe -> FStar_Pprint.document) - = - fun env -> - fun u -> - FStar_GenSym.with_frozen_gensym - (fun uu___ -> - let e = - FStar_Syntax_Resugar.resugar_universe' env u - FStar_Compiler_Range_Type.dummyRange in - FStar_Parser_ToDocument.term_to_document e) -let (term_to_string' : - FStar_Syntax_DsEnv.env -> FStar_Syntax_Syntax.term -> Prims.string) = - fun env -> - fun tm -> - FStar_GenSym.with_frozen_gensym - (fun uu___ -> let d = term_to_doc' env tm in pp d) -let (univ_to_string' : - FStar_Syntax_DsEnv.env -> FStar_Syntax_Syntax.universe -> Prims.string) = - fun env -> - fun u -> - FStar_GenSym.with_frozen_gensym - (fun uu___ -> let d = univ_to_doc' env u in pp d) -let (comp_to_doc' : - FStar_Syntax_DsEnv.env -> FStar_Syntax_Syntax.comp -> FStar_Pprint.document) - = - fun env -> - fun c -> - FStar_GenSym.with_frozen_gensym - (fun uu___ -> - let e = FStar_Syntax_Resugar.resugar_comp' env c in - FStar_Parser_ToDocument.term_to_document e) -let (comp_to_string' : - FStar_Syntax_DsEnv.env -> FStar_Syntax_Syntax.comp -> Prims.string) = - fun env -> - fun c -> - FStar_GenSym.with_frozen_gensym - (fun uu___ -> let d = comp_to_doc' env c in pp d) -let (sigelt_to_doc' : - FStar_Syntax_DsEnv.env -> - FStar_Syntax_Syntax.sigelt -> FStar_Pprint.document) - = - fun env -> - fun se -> - FStar_GenSym.with_frozen_gensym - (fun uu___ -> - let uu___1 = FStar_Syntax_Resugar.resugar_sigelt' env se in - match uu___1 with - | FStar_Pervasives_Native.None -> FStar_Pprint.empty - | FStar_Pervasives_Native.Some d -> - FStar_Parser_ToDocument.decl_to_document d) -let (sigelt_to_string' : - FStar_Syntax_DsEnv.env -> FStar_Syntax_Syntax.sigelt -> Prims.string) = - fun env -> - fun se -> - FStar_GenSym.with_frozen_gensym - (fun uu___ -> let d = sigelt_to_doc' env se in pp d) -let (term_to_doc : FStar_Syntax_Syntax.term -> FStar_Pprint.document) = - fun tm -> - FStar_GenSym.with_frozen_gensym - (fun uu___ -> - let e = FStar_Syntax_Resugar.resugar_term tm in - FStar_Parser_ToDocument.term_to_document e) -let (univ_to_doc : FStar_Syntax_Syntax.universe -> FStar_Pprint.document) = - fun u -> - FStar_GenSym.with_frozen_gensym - (fun uu___ -> - let e = - FStar_Syntax_Resugar.resugar_universe u - FStar_Compiler_Range_Type.dummyRange in - FStar_Parser_ToDocument.term_to_document e) -let (comp_to_doc : FStar_Syntax_Syntax.comp -> FStar_Pprint.document) = - fun c -> - FStar_GenSym.with_frozen_gensym - (fun uu___ -> - let e = FStar_Syntax_Resugar.resugar_comp c in - FStar_Parser_ToDocument.term_to_document e) -let (sigelt_to_doc : FStar_Syntax_Syntax.sigelt -> FStar_Pprint.document) = - fun se -> - FStar_GenSym.with_frozen_gensym - (fun uu___ -> - let uu___1 = FStar_Syntax_Resugar.resugar_sigelt se in - match uu___1 with - | FStar_Pervasives_Native.None -> FStar_Pprint.empty - | FStar_Pervasives_Native.Some d -> - FStar_Parser_ToDocument.decl_to_document d) -let (term_to_string : FStar_Syntax_Syntax.term -> Prims.string) = - fun tm -> - FStar_GenSym.with_frozen_gensym - (fun uu___ -> let d = term_to_doc tm in pp d) -let (comp_to_string : FStar_Syntax_Syntax.comp -> Prims.string) = - fun c -> - FStar_GenSym.with_frozen_gensym - (fun uu___ -> - let e = FStar_Syntax_Resugar.resugar_comp c in - let d = FStar_Parser_ToDocument.term_to_document e in pp d) -let (sigelt_to_string : FStar_Syntax_Syntax.sigelt -> Prims.string) = - fun se -> - FStar_GenSym.with_frozen_gensym - (fun uu___ -> - let uu___1 = FStar_Syntax_Resugar.resugar_sigelt se in - match uu___1 with - | FStar_Pervasives_Native.None -> "" - | FStar_Pervasives_Native.Some d -> - let d1 = FStar_Parser_ToDocument.decl_to_document d in pp d1) -let (univ_to_string : FStar_Syntax_Syntax.universe -> Prims.string) = - fun u -> - FStar_GenSym.with_frozen_gensym - (fun uu___ -> - let e = - FStar_Syntax_Resugar.resugar_universe u - FStar_Compiler_Range_Type.dummyRange in - let d = FStar_Parser_ToDocument.term_to_document e in pp d) -let (tscheme_to_string : FStar_Syntax_Syntax.tscheme -> Prims.string) = - fun ts -> - FStar_GenSym.with_frozen_gensym - (fun uu___ -> - let d = FStar_Syntax_Resugar.resugar_tscheme ts in - let d1 = FStar_Parser_ToDocument.decl_to_document d in pp d1) -let (pat_to_string : FStar_Syntax_Syntax.pat -> Prims.string) = - fun p -> - FStar_GenSym.with_frozen_gensym - (fun uu___ -> - let e = - let uu___1 = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) ()) in - FStar_Syntax_Resugar.resugar_pat p uu___1 in - let d = FStar_Parser_ToDocument.pat_to_document e in pp d) -let (binder_to_string' : - Prims.bool -> FStar_Syntax_Syntax.binder -> Prims.string) = - fun is_arrow -> - fun b -> - FStar_GenSym.with_frozen_gensym - (fun uu___ -> - let e = - FStar_Syntax_Resugar.resugar_binder b - FStar_Compiler_Range_Type.dummyRange in - let d = FStar_Parser_ToDocument.binder_to_document e in pp d) -let (eff_decl_to_string : FStar_Syntax_Syntax.eff_decl -> Prims.string) = - fun ed -> - FStar_GenSym.with_frozen_gensym - (fun uu___ -> - let d = FStar_Syntax_Resugar.resugar_eff_decl ed in - let d1 = FStar_Parser_ToDocument.decl_to_document d in pp d1) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_Print_Ugly.ml b/ocaml/fstar-lib/generated/FStar_Syntax_Print_Ugly.ml deleted file mode 100644 index c4d0ed5ed92..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Syntax_Print_Ugly.ml +++ /dev/null @@ -1,1458 +0,0 @@ -open Prims -let (sli : FStar_Ident.lident -> Prims.string) = - fun l -> - let uu___ = FStar_Options.print_real_names () in - if uu___ - then FStar_Ident.string_of_lid l - else - (let uu___2 = FStar_Ident.ident_of_lid l in - FStar_Ident.string_of_id uu___2) -let (lid_to_string : FStar_Ident.lid -> Prims.string) = fun l -> sli l -let (fv_to_string : FStar_Syntax_Syntax.fv -> Prims.string) = - fun fv -> - lid_to_string (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v -let (bv_to_string : FStar_Syntax_Syntax.bv -> Prims.string) = - fun bv -> - let uu___ = FStar_Ident.string_of_id bv.FStar_Syntax_Syntax.ppname in - let uu___1 = - let uu___2 = - FStar_Compiler_Util.string_of_int bv.FStar_Syntax_Syntax.index in - Prims.strcat "#" uu___2 in - Prims.strcat uu___ uu___1 -let (nm_to_string : FStar_Syntax_Syntax.bv -> Prims.string) = - fun bv -> - let uu___ = FStar_Options.print_real_names () in - if uu___ - then bv_to_string bv - else FStar_Ident.string_of_id bv.FStar_Syntax_Syntax.ppname -let (db_to_string : FStar_Syntax_Syntax.bv -> Prims.string) = - fun bv -> - let uu___ = FStar_Ident.string_of_id bv.FStar_Syntax_Syntax.ppname in - let uu___1 = - let uu___2 = - FStar_Compiler_Util.string_of_int bv.FStar_Syntax_Syntax.index in - Prims.strcat "@" uu___2 in - Prims.strcat uu___ uu___1 -let (filter_imp : - FStar_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> - Prims.bool) - = - fun aq -> - match aq with - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta t) when - FStar_Syntax_Util.is_fvar FStar_Parser_Const.tcresolve_lid t -> true - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit uu___) -> - false - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta uu___) -> false - | uu___ -> true -let filter_imp_args : - 'uuuuu . - ('uuuuu * FStar_Syntax_Syntax.arg_qualifier - FStar_Pervasives_Native.option) Prims.list -> - ('uuuuu * FStar_Syntax_Syntax.arg_qualifier - FStar_Pervasives_Native.option) Prims.list - = - fun args -> - FStar_Compiler_List.filter - (fun uu___ -> - match uu___ with - | (uu___1, FStar_Pervasives_Native.None) -> true - | (uu___1, FStar_Pervasives_Native.Some a) -> - Prims.op_Negation a.FStar_Syntax_Syntax.aqual_implicit) args -let (filter_imp_binders : - FStar_Syntax_Syntax.binder Prims.list -> - FStar_Syntax_Syntax.binder Prims.list) - = - fun bs -> - FStar_Compiler_List.filter - (fun b -> filter_imp b.FStar_Syntax_Syntax.binder_qual) bs -let (const_to_string : FStar_Const.sconst -> Prims.string) = - FStar_Parser_Const.const_to_string -let (lbname_to_string : - (FStar_Syntax_Syntax.bv, FStar_Syntax_Syntax.fv) FStar_Pervasives.either -> - Prims.string) - = - fun uu___ -> - match uu___ with - | FStar_Pervasives.Inl l -> bv_to_string l - | FStar_Pervasives.Inr l -> - lid_to_string (l.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v -let (uvar_to_string : FStar_Syntax_Syntax.uvar -> Prims.string) = - fun u -> - let uu___ = FStar_Options.hide_uvar_nums () in - if uu___ - then "?" - else - (let uu___2 = - let uu___3 = FStar_Syntax_Unionfind.uvar_id u in - FStar_Compiler_Util.string_of_int uu___3 in - Prims.strcat "?" uu___2) -let (version_to_string : FStar_Syntax_Syntax.version -> Prims.string) = - fun v -> - let uu___ = FStar_Compiler_Util.string_of_int v.FStar_Syntax_Syntax.major in - let uu___1 = - FStar_Compiler_Util.string_of_int v.FStar_Syntax_Syntax.minor in - FStar_Compiler_Util.format2 "%s.%s" uu___ uu___1 -let (univ_uvar_to_string : - (FStar_Syntax_Syntax.universe FStar_Pervasives_Native.option - FStar_Unionfind.p_uvar * FStar_Syntax_Syntax.version * - FStar_Compiler_Range_Type.range) -> Prims.string) - = - fun u -> - let uu___ = FStar_Options.hide_uvar_nums () in - if uu___ - then "?" - else - (let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Unionfind.univ_uvar_id u in - FStar_Compiler_Util.string_of_int uu___4 in - let uu___4 = - let uu___5 = - match u with | (uu___6, u1, uu___7) -> version_to_string u1 in - Prims.strcat ":" uu___5 in - Prims.strcat uu___3 uu___4 in - Prims.strcat "?" uu___2) -let rec (int_of_univ : - Prims.int -> - FStar_Syntax_Syntax.universe -> - (Prims.int * FStar_Syntax_Syntax.universe - FStar_Pervasives_Native.option)) - = - fun n -> - fun u -> - let uu___ = FStar_Syntax_Subst.compress_univ u in - match uu___ with - | FStar_Syntax_Syntax.U_zero -> (n, FStar_Pervasives_Native.None) - | FStar_Syntax_Syntax.U_succ u1 -> int_of_univ (n + Prims.int_one) u1 - | uu___1 -> (n, (FStar_Pervasives_Native.Some u)) -let rec (univ_to_string : FStar_Syntax_Syntax.universe -> Prims.string) = - fun u -> - FStar_Errors.with_ctx "While printing universe" - (fun uu___ -> - let uu___1 = FStar_Syntax_Subst.compress_univ u in - match uu___1 with - | FStar_Syntax_Syntax.U_unif u1 -> - let uu___2 = univ_uvar_to_string u1 in - Prims.strcat "U_unif " uu___2 - | FStar_Syntax_Syntax.U_name x -> - let uu___2 = FStar_Ident.string_of_id x in - Prims.strcat "U_name " uu___2 - | FStar_Syntax_Syntax.U_bvar x -> - let uu___2 = FStar_Compiler_Util.string_of_int x in - Prims.strcat "@" uu___2 - | FStar_Syntax_Syntax.U_zero -> "0" - | FStar_Syntax_Syntax.U_succ u1 -> - let uu___2 = int_of_univ Prims.int_one u1 in - (match uu___2 with - | (n, FStar_Pervasives_Native.None) -> - FStar_Compiler_Util.string_of_int n - | (n, FStar_Pervasives_Native.Some u2) -> - let uu___3 = univ_to_string u2 in - let uu___4 = FStar_Compiler_Util.string_of_int n in - FStar_Compiler_Util.format2 "(%s + %s)" uu___3 uu___4) - | FStar_Syntax_Syntax.U_max us -> - let uu___2 = - let uu___3 = FStar_Compiler_List.map univ_to_string us in - FStar_Compiler_String.concat ", " uu___3 in - FStar_Compiler_Util.format1 "(max %s)" uu___2 - | FStar_Syntax_Syntax.U_unknown -> "unknown") -let (univs_to_string : - FStar_Syntax_Syntax.universe Prims.list -> Prims.string) = - fun us -> - let uu___ = FStar_Compiler_List.map univ_to_string us in - FStar_Compiler_String.concat ", " uu___ -let (univ_names_to_string : FStar_Ident.ident Prims.list -> Prims.string) = - fun us -> - let uu___ = - FStar_Compiler_List.map (fun x -> FStar_Ident.string_of_id x) us in - FStar_Compiler_String.concat ", " uu___ -let (qual_to_string : FStar_Syntax_Syntax.qualifier -> Prims.string) = - fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.Assumption -> "assume" - | FStar_Syntax_Syntax.InternalAssumption -> "internal_assume" - | FStar_Syntax_Syntax.New -> "new" - | FStar_Syntax_Syntax.Private -> "private" - | FStar_Syntax_Syntax.Unfold_for_unification_and_vcgen -> "unfold" - | FStar_Syntax_Syntax.Inline_for_extraction -> "inline_for_extraction" - | FStar_Syntax_Syntax.NoExtract -> "noextract" - | FStar_Syntax_Syntax.Visible_default -> "visible" - | FStar_Syntax_Syntax.Irreducible -> "irreducible" - | FStar_Syntax_Syntax.Noeq -> "noeq" - | FStar_Syntax_Syntax.Unopteq -> "unopteq" - | FStar_Syntax_Syntax.Logic -> "logic" - | FStar_Syntax_Syntax.TotalEffect -> "total" - | FStar_Syntax_Syntax.Discriminator l -> - let uu___1 = lid_to_string l in - FStar_Compiler_Util.format1 "(Discriminator %s)" uu___1 - | FStar_Syntax_Syntax.Projector (l, x) -> - let uu___1 = lid_to_string l in - let uu___2 = FStar_Ident.string_of_id x in - FStar_Compiler_Util.format2 "(Projector %s %s)" uu___1 uu___2 - | FStar_Syntax_Syntax.RecordType (ns, fns) -> - let uu___1 = - let uu___2 = FStar_Ident.path_of_ns ns in - FStar_Ident.text_of_path uu___2 in - let uu___2 = - let uu___3 = FStar_Compiler_List.map FStar_Ident.string_of_id fns in - FStar_Compiler_String.concat ", " uu___3 in - FStar_Compiler_Util.format2 "(RecordType %s %s)" uu___1 uu___2 - | FStar_Syntax_Syntax.RecordConstructor (ns, fns) -> - let uu___1 = - let uu___2 = FStar_Ident.path_of_ns ns in - FStar_Ident.text_of_path uu___2 in - let uu___2 = - let uu___3 = FStar_Compiler_List.map FStar_Ident.string_of_id fns in - FStar_Compiler_String.concat ", " uu___3 in - FStar_Compiler_Util.format2 "(RecordConstructor %s %s)" uu___1 uu___2 - | FStar_Syntax_Syntax.Action eff_lid -> - let uu___1 = lid_to_string eff_lid in - FStar_Compiler_Util.format1 "(Action %s)" uu___1 - | FStar_Syntax_Syntax.ExceptionConstructor -> "ExceptionConstructor" - | FStar_Syntax_Syntax.HasMaskedEffect -> "HasMaskedEffect" - | FStar_Syntax_Syntax.Effect -> "Effect" - | FStar_Syntax_Syntax.Reifiable -> "reify" - | FStar_Syntax_Syntax.Reflectable l -> - let uu___1 = FStar_Ident.string_of_lid l in - FStar_Compiler_Util.format1 "(reflect %s)" uu___1 - | FStar_Syntax_Syntax.OnlyName -> "OnlyName" -let (quals_to_string : - FStar_Syntax_Syntax.qualifier Prims.list -> Prims.string) = - fun quals -> - match quals with - | [] -> "" - | uu___ -> - let uu___1 = FStar_Compiler_List.map qual_to_string quals in - FStar_Compiler_String.concat " " uu___1 -let (quals_to_string' : - FStar_Syntax_Syntax.qualifier Prims.list -> Prims.string) = - fun quals -> - match quals with - | [] -> "" - | uu___ -> let uu___1 = quals_to_string quals in Prims.strcat uu___1 " " -let (paren : Prims.string -> Prims.string) = - fun s -> Prims.strcat "(" (Prims.strcat s ")") -let rec (term_to_string : FStar_Syntax_Syntax.term -> Prims.string) = - fun x -> - FStar_Errors.with_ctx "While ugly-printing a term" - (fun uu___ -> - let x1 = FStar_Syntax_Subst.compress x in - let x2 = - let uu___1 = FStar_Options.print_implicits () in - if uu___1 then x1 else FStar_Syntax_Util.unmeta x1 in - match x2.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_delayed uu___1 -> failwith "impossible" - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = uu___1; - FStar_Syntax_Syntax.args = [];_} - -> failwith "Empty args!" - | FStar_Syntax_Syntax.Tm_lazy - { FStar_Syntax_Syntax.blob = b; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_embedding - (uu___1, thunk); - FStar_Syntax_Syntax.ltyp = uu___2; - FStar_Syntax_Syntax.rng = uu___3;_} - -> - let uu___4 = - let uu___5 = - let uu___6 = FStar_Thunk.force thunk in - term_to_string uu___6 in - Prims.strcat uu___5 "]" in - Prims.strcat "[LAZYEMB:" uu___4 - | FStar_Syntax_Syntax.Tm_lazy i -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Compiler_Effect.op_Bang - FStar_Syntax_Syntax.lazy_chooser in - FStar_Compiler_Util.must uu___5 in - uu___4 i.FStar_Syntax_Syntax.lkind i in - term_to_string uu___3 in - Prims.strcat uu___2 "]" in - Prims.strcat "[lazy:" uu___1 - | FStar_Syntax_Syntax.Tm_quoted (tm, qi) -> - (match qi.FStar_Syntax_Syntax.qkind with - | FStar_Syntax_Syntax.Quote_static -> - let uu___1 = term_to_string tm in - let uu___2 = - (FStar_Common.string_of_list ()) term_to_string - (FStar_Pervasives_Native.snd - qi.FStar_Syntax_Syntax.antiquotations) in - FStar_Compiler_Util.format2 "`(%s)%s" uu___1 uu___2 - | FStar_Syntax_Syntax.Quote_dynamic -> - let uu___1 = term_to_string tm in - FStar_Compiler_Util.format1 "quote (%s)" uu___1) - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_pattern - (uu___1, ps);_} - -> - let pats = - let uu___2 = - FStar_Compiler_List.map - (fun args -> - let uu___3 = - FStar_Compiler_List.map - (fun uu___4 -> - match uu___4 with - | (t1, uu___5) -> term_to_string t1) args in - FStar_Compiler_String.concat "; " uu___3) ps in - FStar_Compiler_String.concat "\\/" uu___2 in - let uu___2 = term_to_string t in - FStar_Compiler_Util.format2 "{:pattern %s} %s" pats uu___2 - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_monadic - (m, t');_} - -> - let uu___1 = sli m in - let uu___2 = term_to_string t' in - let uu___3 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t in - let uu___4 = term_to_string t in - FStar_Compiler_Util.format4 "(MetaMonadic-{%s %s} (%s) %s)" - uu___1 uu___2 uu___3 uu___4 - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t; - FStar_Syntax_Syntax.meta = - FStar_Syntax_Syntax.Meta_monadic_lift (m0, m1, t');_} - -> - let uu___1 = term_to_string t' in - let uu___2 = sli m0 in - let uu___3 = sli m1 in - let uu___4 = term_to_string t in - FStar_Compiler_Util.format4 - "(MetaMonadicLift-{%s : %s -> %s} %s)" uu___1 uu___2 uu___3 - uu___4 - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_labeled - (l, r, b);_} - -> - let uu___1 = FStar_Errors_Msg.rendermsg l in - let uu___2 = FStar_Compiler_Range_Ops.string_of_range r in - let uu___3 = term_to_string t in - FStar_Compiler_Util.format3 "Meta_labeled(%s, %s){%s}" uu___1 - uu___2 uu___3 - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_named l;_} - -> - let uu___1 = lid_to_string l in - let uu___2 = - FStar_Compiler_Range_Ops.string_of_range - t.FStar_Syntax_Syntax.pos in - let uu___3 = term_to_string t in - FStar_Compiler_Util.format3 "Meta_named(%s, %s){%s}" uu___1 - uu___2 uu___3 - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_desugared - uu___1;_} - -> - let uu___2 = term_to_string t in - FStar_Compiler_Util.format1 "Meta_desugared{%s}" uu___2 - | FStar_Syntax_Syntax.Tm_bvar x3 -> - let uu___1 = db_to_string x3 in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term - x3.FStar_Syntax_Syntax.sort in - Prims.strcat uu___4 ")" in - Prims.strcat ":(" uu___3 in - Prims.strcat uu___1 uu___2 - | FStar_Syntax_Syntax.Tm_name x3 -> nm_to_string x3 - | FStar_Syntax_Syntax.Tm_fvar f -> - let pref = - match f.FStar_Syntax_Syntax.fv_qual with - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Unresolved_projector uu___1) -> - "(Unresolved_projector)" - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Unresolved_constructor uu___1) -> - "(Unresolved_constructor)" - | uu___1 -> "" in - let uu___1 = fv_to_string f in Prims.strcat pref uu___1 - | FStar_Syntax_Syntax.Tm_uvar (u, ([], uu___1)) -> - let uu___2 = - (FStar_Options.print_bound_var_types ()) && - (FStar_Options.print_effect_args ()) in - if uu___2 - then ctx_uvar_to_string_aux true u - else - (let uu___4 = - let uu___5 = - FStar_Syntax_Unionfind.uvar_id - u.FStar_Syntax_Syntax.ctx_uvar_head in - FStar_Compiler_Util.string_of_int uu___5 in - Prims.strcat "?" uu___4) - | FStar_Syntax_Syntax.Tm_uvar (u, s) -> - let uu___1 = - (FStar_Options.print_bound_var_types ()) && - (FStar_Options.print_effect_args ()) in - if uu___1 - then - let uu___2 = ctx_uvar_to_string_aux true u in - let uu___3 = - let uu___4 = - FStar_Compiler_List.map subst_to_string - (FStar_Pervasives_Native.fst s) in - FStar_Compiler_String.concat "; " uu___4 in - FStar_Compiler_Util.format2 "(%s @ %s)" uu___2 uu___3 - else - (let uu___3 = - let uu___4 = - FStar_Syntax_Unionfind.uvar_id - u.FStar_Syntax_Syntax.ctx_uvar_head in - FStar_Compiler_Util.string_of_int uu___4 in - Prims.strcat "?" uu___3) - | FStar_Syntax_Syntax.Tm_constant c -> const_to_string c - | FStar_Syntax_Syntax.Tm_type u -> - let uu___1 = FStar_Options.print_universes () in - if uu___1 - then - let uu___2 = univ_to_string u in - FStar_Compiler_Util.format1 "Type u#(%s)" uu___2 - else "Type" - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; FStar_Syntax_Syntax.comp = c;_} - -> - let uu___1 = binders_to_string " -> " bs in - let uu___2 = comp_to_string c in - FStar_Compiler_Util.format2 "(%s -> %s)" uu___1 uu___2 - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs; FStar_Syntax_Syntax.body = t2; - FStar_Syntax_Syntax.rc_opt = lc;_} - -> - (match lc with - | FStar_Pervasives_Native.Some rc when - FStar_Options.print_implicits () -> - let uu___1 = binders_to_string " " bs in - let uu___2 = term_to_string t2 in - let uu___3 = - FStar_Ident.string_of_lid - rc.FStar_Syntax_Syntax.residual_effect in - let uu___4 = - if - FStar_Compiler_Option.isNone - rc.FStar_Syntax_Syntax.residual_typ - then "None" - else - (let uu___6 = - FStar_Compiler_Option.get - rc.FStar_Syntax_Syntax.residual_typ in - term_to_string uu___6) in - FStar_Compiler_Util.format4 - "(fun %s -> (%s $$ (residual) %s %s))" uu___1 uu___2 - uu___3 uu___4 - | uu___1 -> - let uu___2 = binders_to_string " " bs in - let uu___3 = term_to_string t2 in - FStar_Compiler_Util.format2 "(fun %s -> %s)" uu___2 uu___3) - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = xt; FStar_Syntax_Syntax.phi = f;_} -> - let uu___1 = bv_to_string xt in - let uu___2 = term_to_string xt.FStar_Syntax_Syntax.sort in - let uu___3 = formula_to_string f in - FStar_Compiler_Util.format3 "(%s:%s{%s})" uu___1 uu___2 uu___3 - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = t; FStar_Syntax_Syntax.args = args;_} - -> - let uu___1 = term_to_string t in - let uu___2 = args_to_string args in - FStar_Compiler_Util.format2 "(%s %s)" uu___1 uu___2 - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = lbs; - FStar_Syntax_Syntax.body1 = e;_} - -> - let uu___1 = lbs_to_string [] lbs in - let uu___2 = term_to_string e in - FStar_Compiler_Util.format2 "%s\nin\n%s" uu___1 uu___2 - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = e; - FStar_Syntax_Syntax.asc = (annot, topt, b); - FStar_Syntax_Syntax.eff_opt = eff_name;_} - -> - let annot1 = - match annot with - | FStar_Pervasives.Inl t -> - let uu___1 = - let uu___2 = - FStar_Compiler_Util.map_opt eff_name - FStar_Ident.string_of_lid in - FStar_Compiler_Util.dflt "default" uu___2 in - let uu___2 = term_to_string t in - FStar_Compiler_Util.format2 "[%s] %s" uu___1 uu___2 - | FStar_Pervasives.Inr c -> comp_to_string c in - let topt1 = - match topt with - | FStar_Pervasives_Native.None -> "" - | FStar_Pervasives_Native.Some t -> - let uu___1 = term_to_string t in - FStar_Compiler_Util.format1 "by %s" uu___1 in - let s = if b then "ascribed_eq" else "ascribed" in - let uu___1 = term_to_string e in - FStar_Compiler_Util.format4 "(%s <%s: %s %s)" uu___1 s annot1 - topt1 - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = head; - FStar_Syntax_Syntax.ret_opt = asc_opt; - FStar_Syntax_Syntax.brs = branches; - FStar_Syntax_Syntax.rc_opt1 = lc;_} - -> - let lc_str = - match lc with - | FStar_Pervasives_Native.Some lc1 when - FStar_Options.print_implicits () -> - let uu___1 = - if - FStar_Compiler_Option.isNone - lc1.FStar_Syntax_Syntax.residual_typ - then "None" - else - (let uu___3 = - FStar_Compiler_Option.get - lc1.FStar_Syntax_Syntax.residual_typ in - term_to_string uu___3) in - FStar_Compiler_Util.format1 " (residual_comp:%s)" uu___1 - | uu___1 -> "" in - let uu___1 = term_to_string head in - let uu___2 = - match asc_opt with - | FStar_Pervasives_Native.None -> "" - | FStar_Pervasives_Native.Some (b, (asc, tacopt, use_eq)) -> - let s = if use_eq then "returns$" else "returns" in - let uu___3 = binder_to_string b in - let uu___4 = - match asc with - | FStar_Pervasives.Inl t -> term_to_string t - | FStar_Pervasives.Inr c -> comp_to_string c in - let uu___5 = - match tacopt with - | FStar_Pervasives_Native.None -> "" - | FStar_Pervasives_Native.Some tac -> - let uu___6 = term_to_string tac in - FStar_Compiler_Util.format1 " by %s" uu___6 in - FStar_Compiler_Util.format4 "as %s %s %s%s " uu___3 s - uu___4 uu___5 in - let uu___3 = - let uu___4 = FStar_Compiler_List.map branch_to_string branches in - FStar_Compiler_Util.concat_l "\n\t|" uu___4 in - FStar_Compiler_Util.format4 "(match %s %swith\n\t| %s%s)" uu___1 - uu___2 uu___3 lc_str - | FStar_Syntax_Syntax.Tm_uinst (t, us) -> - let uu___1 = FStar_Options.print_universes () in - if uu___1 - then - let uu___2 = term_to_string t in - let uu___3 = univs_to_string us in - FStar_Compiler_Util.format2 "%s<%s>" uu___2 uu___3 - else term_to_string t - | FStar_Syntax_Syntax.Tm_unknown -> "_") -and (branch_to_string : FStar_Syntax_Syntax.branch -> Prims.string) = - fun uu___ -> - match uu___ with - | (p, wopt, e) -> - let uu___1 = pat_to_string p in - let uu___2 = - match wopt with - | FStar_Pervasives_Native.None -> "" - | FStar_Pervasives_Native.Some w -> - let uu___3 = term_to_string w in - FStar_Compiler_Util.format1 "when %s" uu___3 in - let uu___3 = term_to_string e in - FStar_Compiler_Util.format3 "%s %s -> %s" uu___1 uu___2 uu___3 -and (ctx_uvar_to_string_aux : - Prims.bool -> FStar_Syntax_Syntax.ctx_uvar -> Prims.string) = - fun print_reason -> - fun ctx_uvar -> - let reason_string = - if print_reason - then - FStar_Compiler_Util.format1 "(* %s *)\n" - ctx_uvar.FStar_Syntax_Syntax.ctx_uvar_reason - else - (let uu___1 = - let uu___2 = - FStar_Compiler_Range_Ops.start_of_range - ctx_uvar.FStar_Syntax_Syntax.ctx_uvar_range in - FStar_Compiler_Range_Ops.string_of_pos uu___2 in - let uu___2 = - let uu___3 = - FStar_Compiler_Range_Ops.end_of_range - ctx_uvar.FStar_Syntax_Syntax.ctx_uvar_range in - FStar_Compiler_Range_Ops.string_of_pos uu___3 in - FStar_Compiler_Util.format2 "(%s-%s) " uu___1 uu___2) in - let uu___ = - binders_to_string ", " ctx_uvar.FStar_Syntax_Syntax.ctx_uvar_binders in - let uu___1 = uvar_to_string ctx_uvar.FStar_Syntax_Syntax.ctx_uvar_head in - let uu___2 = - let uu___3 = FStar_Syntax_Util.ctx_uvar_typ ctx_uvar in - term_to_string uu___3 in - let uu___3 = - let uu___4 = FStar_Syntax_Util.ctx_uvar_should_check ctx_uvar in - match uu___4 with - | FStar_Syntax_Syntax.Allow_unresolved s -> - Prims.strcat "Allow_unresolved " s - | FStar_Syntax_Syntax.Allow_untyped s -> - Prims.strcat "Allow_untyped " s - | FStar_Syntax_Syntax.Allow_ghost s -> Prims.strcat "Allow_ghost " s - | FStar_Syntax_Syntax.Strict -> "Strict" - | FStar_Syntax_Syntax.Already_checked -> "Already_checked" in - FStar_Compiler_Util.format5 "%s(%s |- %s : %s) %s" reason_string uu___ - uu___1 uu___2 uu___3 -and (subst_elt_to_string : FStar_Syntax_Syntax.subst_elt -> Prims.string) = - fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.DB (i, x) -> - let uu___1 = FStar_Compiler_Util.string_of_int i in - let uu___2 = bv_to_string x in - FStar_Compiler_Util.format2 "DB (%s, %s)" uu___1 uu___2 - | FStar_Syntax_Syntax.DT (i, t) -> - let uu___1 = FStar_Compiler_Util.string_of_int i in - let uu___2 = term_to_string t in - FStar_Compiler_Util.format2 "DT (%s, %s)" uu___1 uu___2 - | FStar_Syntax_Syntax.NM (x, i) -> - let uu___1 = bv_to_string x in - let uu___2 = FStar_Compiler_Util.string_of_int i in - FStar_Compiler_Util.format2 "NM (%s, %s)" uu___1 uu___2 - | FStar_Syntax_Syntax.NT (x, t) -> - let uu___1 = bv_to_string x in - let uu___2 = term_to_string t in - FStar_Compiler_Util.format2 "NT (%s, %s)" uu___1 uu___2 - | FStar_Syntax_Syntax.UN (i, u) -> - let uu___1 = FStar_Compiler_Util.string_of_int i in - let uu___2 = univ_to_string u in - FStar_Compiler_Util.format2 "UN (%s, %s)" uu___1 uu___2 - | FStar_Syntax_Syntax.UD (u, i) -> - let uu___1 = FStar_Ident.string_of_id u in - let uu___2 = FStar_Compiler_Util.string_of_int i in - FStar_Compiler_Util.format2 "UD (%s, %s)" uu___1 uu___2 -and (subst_to_string : - FStar_Syntax_Syntax.subst_elt Prims.list -> Prims.string) = - fun s -> - let uu___ = FStar_Compiler_List.map subst_elt_to_string s in - FStar_Compiler_String.concat "; " uu___ -and (pat_to_string : FStar_Syntax_Syntax.pat -> Prims.string) = - fun x -> - match x.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_cons (l, us_opt, pats) -> - let uu___ = fv_to_string l in - let uu___1 = - let uu___2 = - let uu___3 = FStar_Options.print_universes () in - Prims.op_Negation uu___3 in - if uu___2 - then " " - else - (match us_opt with - | FStar_Pervasives_Native.None -> " " - | FStar_Pervasives_Native.Some us -> - let uu___4 = - let uu___5 = FStar_Compiler_List.map univ_to_string us in - FStar_Compiler_String.concat " " uu___5 in - FStar_Compiler_Util.format1 " %s " uu___4) in - let uu___2 = - let uu___3 = - FStar_Compiler_List.map - (fun uu___4 -> - match uu___4 with - | (x1, b) -> - let p = pat_to_string x1 in - if b then Prims.strcat "#" p else p) pats in - FStar_Compiler_String.concat " " uu___3 in - FStar_Compiler_Util.format3 "(%s%s%s)" uu___ uu___1 uu___2 - | FStar_Syntax_Syntax.Pat_dot_term topt -> - let uu___ = FStar_Options.print_bound_var_types () in - if uu___ - then - let uu___1 = - if topt = FStar_Pervasives_Native.None - then "_" - else - (let uu___3 = FStar_Compiler_Util.must topt in - term_to_string uu___3) in - FStar_Compiler_Util.format1 ".%s" uu___1 - else "._" - | FStar_Syntax_Syntax.Pat_var x1 -> - let uu___ = FStar_Options.print_bound_var_types () in - if uu___ - then - let uu___1 = bv_to_string x1 in - let uu___2 = term_to_string x1.FStar_Syntax_Syntax.sort in - FStar_Compiler_Util.format2 "%s:%s" uu___1 uu___2 - else bv_to_string x1 - | FStar_Syntax_Syntax.Pat_constant c -> const_to_string c -and (lbs_to_string : - FStar_Syntax_Syntax.qualifier Prims.list -> - (Prims.bool * FStar_Syntax_Syntax.letbinding Prims.list) -> Prims.string) - = - fun quals -> - fun lbs -> - let uu___ = quals_to_string' quals in - let uu___1 = - let uu___2 = - FStar_Compiler_List.map - (fun lb -> - let uu___3 = attrs_to_string lb.FStar_Syntax_Syntax.lbattrs in - let uu___4 = lbname_to_string lb.FStar_Syntax_Syntax.lbname in - let uu___5 = - let uu___6 = FStar_Options.print_universes () in - if uu___6 - then - let uu___7 = - let uu___8 = - univ_names_to_string lb.FStar_Syntax_Syntax.lbunivs in - Prims.strcat uu___8 ">" in - Prims.strcat "<" uu___7 - else "" in - let uu___6 = term_to_string lb.FStar_Syntax_Syntax.lbtyp in - let uu___7 = term_to_string lb.FStar_Syntax_Syntax.lbdef in - FStar_Compiler_Util.format5 "%s%s %s : %s = %s" uu___3 uu___4 - uu___5 uu___6 uu___7) (FStar_Pervasives_Native.snd lbs) in - FStar_Compiler_Util.concat_l "\n and " uu___2 in - FStar_Compiler_Util.format3 "%slet %s %s" uu___ - (if FStar_Pervasives_Native.fst lbs then "rec" else "") uu___1 -and (attrs_to_string : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax Prims.list -> - Prims.string) - = - fun uu___ -> - match uu___ with - | [] -> "" - | tms -> - let uu___1 = - let uu___2 = - FStar_Compiler_List.map - (fun t -> let uu___3 = term_to_string t in paren uu___3) tms in - FStar_Compiler_String.concat "; " uu___2 in - FStar_Compiler_Util.format1 "[@ %s]" uu___1 -and (binder_attrs_to_string : - FStar_Syntax_Syntax.term Prims.list -> Prims.string) = - fun uu___ -> - if FStar_Options.any_dump_module () - then "" - else - (match uu___ with - | [] -> "" - | tms -> - let uu___1 = - let uu___2 = - FStar_Compiler_List.map - (fun t -> let uu___3 = term_to_string t in paren uu___3) tms in - FStar_Compiler_String.concat "; " uu___2 in - FStar_Compiler_Util.format1 "[@@@ %s]" uu___1) -and (bqual_to_string' : - Prims.string -> - FStar_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> - Prims.string) - = - fun s -> - fun uu___ -> - match uu___ with - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit (false)) - -> Prims.strcat "#" s - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit (true)) -> - Prims.strcat "#." s - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Equality) -> - Prims.strcat "$" s - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta t) when - FStar_Syntax_Util.is_fvar FStar_Parser_Const.tcresolve_lid t -> - Prims.strcat "{|" (Prims.strcat s "|}") - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta t) -> - let uu___1 = - let uu___2 = term_to_string t in - Prims.strcat uu___2 (Prims.strcat "]" s) in - Prims.strcat "#[" uu___1 - | FStar_Pervasives_Native.None -> s -and (aqual_to_string' : - Prims.string -> - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option -> - Prims.string) - = - fun s -> - fun uu___ -> - match uu___ with - | FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = uu___1;_} - -> Prims.strcat "#" s - | uu___1 -> s -and (binder_to_string' : - Prims.bool -> FStar_Syntax_Syntax.binder -> Prims.string) = - fun is_arrow -> - fun b -> - let attrs = binder_attrs_to_string b.FStar_Syntax_Syntax.binder_attrs in - let uu___ = FStar_Syntax_Syntax.is_null_binder b in - if uu___ - then - let uu___1 = - let uu___2 = - term_to_string - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - Prims.strcat "_:" uu___2 in - Prims.strcat attrs uu___1 - else - (let uu___2 = - (Prims.op_Negation is_arrow) && - (let uu___3 = FStar_Options.print_bound_var_types () in - Prims.op_Negation uu___3) in - if uu___2 - then - let uu___3 = - let uu___4 = nm_to_string b.FStar_Syntax_Syntax.binder_bv in - Prims.strcat attrs uu___4 in - bqual_to_string' uu___3 b.FStar_Syntax_Syntax.binder_qual - else - (let uu___4 = - let uu___5 = - let uu___6 = nm_to_string b.FStar_Syntax_Syntax.binder_bv in - let uu___7 = - let uu___8 = - term_to_string - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - Prims.strcat ":" uu___8 in - Prims.strcat uu___6 uu___7 in - Prims.strcat attrs uu___5 in - bqual_to_string' uu___4 b.FStar_Syntax_Syntax.binder_qual)) -and (binder_to_string : FStar_Syntax_Syntax.binder -> Prims.string) = - fun b -> binder_to_string' false b -and (arrow_binder_to_string : FStar_Syntax_Syntax.binder -> Prims.string) = - fun b -> binder_to_string' true b -and (binders_to_string : - Prims.string -> FStar_Syntax_Syntax.binder Prims.list -> Prims.string) = - fun sep -> - fun bs -> - let bs1 = - let uu___ = FStar_Options.print_implicits () in - if uu___ then bs else filter_imp_binders bs in - if sep = " -> " - then - let uu___ = FStar_Compiler_List.map arrow_binder_to_string bs1 in - FStar_Compiler_String.concat sep uu___ - else - (let uu___1 = FStar_Compiler_List.map binder_to_string bs1 in - FStar_Compiler_String.concat sep uu___1) -and (arg_to_string : - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.arg_qualifier - FStar_Pervasives_Native.option) -> Prims.string) - = - fun uu___ -> - match uu___ with - | (a, imp) -> - let uu___1 = term_to_string a in aqual_to_string' uu___1 imp -and (args_to_string : - (FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) - Prims.list -> Prims.string) - = - fun args -> - let args1 = - let uu___ = FStar_Options.print_implicits () in - if uu___ then args else filter_imp_args args in - let uu___ = FStar_Compiler_List.map arg_to_string args1 in - FStar_Compiler_String.concat " " uu___ -and (comp_to_string : FStar_Syntax_Syntax.comp -> Prims.string) = - fun c -> - FStar_Errors.with_ctx "While ugly-printing a computation" - (fun uu___ -> - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total t -> - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress t in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_type uu___2 when - let uu___3 = - (FStar_Options.print_implicits ()) || - (FStar_Options.print_universes ()) in - Prims.op_Negation uu___3 -> term_to_string t - | uu___2 -> - let uu___3 = term_to_string t in - FStar_Compiler_Util.format1 "Tot %s" uu___3) - | FStar_Syntax_Syntax.GTotal t -> - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress t in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_type uu___2 when - let uu___3 = - (FStar_Options.print_implicits ()) || - (FStar_Options.print_universes ()) in - Prims.op_Negation uu___3 -> term_to_string t - | uu___2 -> - let uu___3 = term_to_string t in - FStar_Compiler_Util.format1 "GTot %s" uu___3) - | FStar_Syntax_Syntax.Comp c1 -> - let basic = - let uu___1 = FStar_Options.print_effect_args () in - if uu___1 - then - let uu___2 = sli c1.FStar_Syntax_Syntax.effect_name in - let uu___3 = - let uu___4 = - FStar_Compiler_List.map univ_to_string - c1.FStar_Syntax_Syntax.comp_univs in - FStar_Compiler_String.concat ", " uu___4 in - let uu___4 = - term_to_string c1.FStar_Syntax_Syntax.result_typ in - let uu___5 = - let uu___6 = - FStar_Compiler_List.map arg_to_string - c1.FStar_Syntax_Syntax.effect_args in - FStar_Compiler_String.concat ", " uu___6 in - let uu___6 = cflags_to_string c1.FStar_Syntax_Syntax.flags in - FStar_Compiler_Util.format5 "%s<%s> (%s) %s (attributes %s)" - uu___2 uu___3 uu___4 uu___5 uu___6 - else - (let uu___3 = - (FStar_Compiler_Util.for_some - (fun uu___4 -> - match uu___4 with - | FStar_Syntax_Syntax.TOTAL -> true - | uu___5 -> false) c1.FStar_Syntax_Syntax.flags) - && - (let uu___4 = FStar_Options.print_effect_args () in - Prims.op_Negation uu___4) in - if uu___3 - then - let uu___4 = - term_to_string c1.FStar_Syntax_Syntax.result_typ in - FStar_Compiler_Util.format1 "Tot %s" uu___4 - else - (let uu___5 = - ((let uu___6 = FStar_Options.print_effect_args () in - Prims.op_Negation uu___6) && - (let uu___6 = FStar_Options.print_implicits () in - Prims.op_Negation uu___6)) - && - (let uu___6 = FStar_Parser_Const.effect_ML_lid () in - FStar_Ident.lid_equals - c1.FStar_Syntax_Syntax.effect_name uu___6) in - if uu___5 - then term_to_string c1.FStar_Syntax_Syntax.result_typ - else - (let uu___7 = - (let uu___8 = FStar_Options.print_effect_args () in - Prims.op_Negation uu___8) && - (FStar_Compiler_Util.for_some - (fun uu___8 -> - match uu___8 with - | FStar_Syntax_Syntax.MLEFFECT -> true - | uu___9 -> false) - c1.FStar_Syntax_Syntax.flags) in - if uu___7 - then - let uu___8 = - term_to_string c1.FStar_Syntax_Syntax.result_typ in - FStar_Compiler_Util.format1 "ALL %s" uu___8 - else - (let uu___9 = - sli c1.FStar_Syntax_Syntax.effect_name in - let uu___10 = - term_to_string c1.FStar_Syntax_Syntax.result_typ in - FStar_Compiler_Util.format2 "%s (%s)" uu___9 - uu___10)))) in - let dec = - let uu___1 = - FStar_Compiler_List.collect - (fun uu___2 -> - match uu___2 with - | FStar_Syntax_Syntax.DECREASES dec_order -> - (match dec_order with - | FStar_Syntax_Syntax.Decreases_lex l -> - let uu___3 = - let uu___4 = - match l with - | [] -> "" - | hd::tl -> - let uu___5 = term_to_string hd in - FStar_Compiler_List.fold_left - (fun s -> - fun t -> - let uu___6 = - let uu___7 = term_to_string t in - Prims.strcat ";" uu___7 in - Prims.strcat s uu___6) uu___5 - tl in - FStar_Compiler_Util.format1 - " (decreases [%s])" uu___4 in - [uu___3] - | FStar_Syntax_Syntax.Decreases_wf (rel, e) -> - let uu___3 = - let uu___4 = term_to_string rel in - let uu___5 = term_to_string e in - FStar_Compiler_Util.format2 - "(decreases {:well-founded %s %s})" uu___4 - uu___5 in - [uu___3]) - | uu___3 -> []) c1.FStar_Syntax_Syntax.flags in - FStar_Compiler_String.concat " " uu___1 in - FStar_Compiler_Util.format2 "%s%s" basic dec) -and (cflag_to_string : FStar_Syntax_Syntax.cflag -> Prims.string) = - fun c -> - match c with - | FStar_Syntax_Syntax.TOTAL -> "total" - | FStar_Syntax_Syntax.MLEFFECT -> "ml" - | FStar_Syntax_Syntax.RETURN -> "return" - | FStar_Syntax_Syntax.PARTIAL_RETURN -> "partial_return" - | FStar_Syntax_Syntax.SOMETRIVIAL -> "sometrivial" - | FStar_Syntax_Syntax.TRIVIAL_POSTCONDITION -> "trivial_postcondition" - | FStar_Syntax_Syntax.SHOULD_NOT_INLINE -> "should_not_inline" - | FStar_Syntax_Syntax.LEMMA -> "lemma" - | FStar_Syntax_Syntax.CPS -> "cps" - | FStar_Syntax_Syntax.DECREASES uu___ -> "" -and (cflags_to_string : FStar_Syntax_Syntax.cflag Prims.list -> Prims.string) - = fun fs -> (FStar_Common.string_of_list ()) cflag_to_string fs -and (formula_to_string : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> Prims.string) = - fun phi -> term_to_string phi -let (aqual_to_string : - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option -> - Prims.string) - = fun aq -> aqual_to_string' "" aq -let (bqual_to_string : - FStar_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> - Prims.string) - = fun bq -> bqual_to_string' "" bq -let (lb_to_string : FStar_Syntax_Syntax.letbinding -> Prims.string) = - fun lb -> lbs_to_string [] (false, [lb]) -let comp_to_string' : - 'uuuuu . 'uuuuu -> FStar_Syntax_Syntax.comp -> Prims.string = - fun env -> fun c -> comp_to_string c -let term_to_string' : - 'uuuuu . 'uuuuu -> FStar_Syntax_Syntax.term -> Prims.string = - fun env -> fun x -> term_to_string x -let (enclose_universes : Prims.string -> Prims.string) = - fun s -> - let uu___ = FStar_Options.print_universes () in - if uu___ then Prims.strcat "<" (Prims.strcat s ">") else "" -let (tscheme_to_string : FStar_Syntax_Syntax.tscheme -> Prims.string) = - fun s -> - let uu___ = s in - match uu___ with - | (us, t) -> - let uu___1 = - let uu___2 = univ_names_to_string us in enclose_universes uu___2 in - let uu___2 = term_to_string t in - FStar_Compiler_Util.format2 "%s%s" uu___1 uu___2 -let (action_to_string : FStar_Syntax_Syntax.action -> Prims.string) = - fun a -> - let uu___ = sli a.FStar_Syntax_Syntax.action_name in - let uu___1 = binders_to_string " " a.FStar_Syntax_Syntax.action_params in - let uu___2 = - let uu___3 = univ_names_to_string a.FStar_Syntax_Syntax.action_univs in - enclose_universes uu___3 in - let uu___3 = term_to_string a.FStar_Syntax_Syntax.action_typ in - let uu___4 = term_to_string a.FStar_Syntax_Syntax.action_defn in - FStar_Compiler_Util.format5 "%s%s %s : %s = %s" uu___ uu___1 uu___2 - uu___3 uu___4 -let (wp_eff_combinators_to_string : - FStar_Syntax_Syntax.wp_eff_combinators -> Prims.string) = - fun combs -> - let tscheme_opt_to_string uu___ = - match uu___ with - | FStar_Pervasives_Native.Some ts -> tscheme_to_string ts - | FStar_Pervasives_Native.None -> "None" in - let uu___ = - let uu___1 = tscheme_to_string combs.FStar_Syntax_Syntax.ret_wp in - let uu___2 = - let uu___3 = tscheme_to_string combs.FStar_Syntax_Syntax.bind_wp in - let uu___4 = - let uu___5 = tscheme_to_string combs.FStar_Syntax_Syntax.stronger in - let uu___6 = - let uu___7 = - tscheme_to_string combs.FStar_Syntax_Syntax.if_then_else in - let uu___8 = - let uu___9 = tscheme_to_string combs.FStar_Syntax_Syntax.ite_wp in - let uu___10 = - let uu___11 = - tscheme_to_string combs.FStar_Syntax_Syntax.close_wp in - let uu___12 = - let uu___13 = - tscheme_to_string combs.FStar_Syntax_Syntax.trivial in - let uu___14 = - let uu___15 = - tscheme_opt_to_string combs.FStar_Syntax_Syntax.repr in - let uu___16 = - let uu___17 = - tscheme_opt_to_string - combs.FStar_Syntax_Syntax.return_repr in - let uu___18 = - let uu___19 = - tscheme_opt_to_string - combs.FStar_Syntax_Syntax.bind_repr in - [uu___19] in - uu___17 :: uu___18 in - uu___15 :: uu___16 in - uu___13 :: uu___14 in - uu___11 :: uu___12 in - uu___9 :: uu___10 in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Compiler_Util.format - "{\nret_wp = %s\n; bind_wp = %s\n; stronger = %s\n; if_then_else = %s\n; ite_wp = %s\n; close_wp = %s\n; trivial = %s\n; repr = %s\n; return_repr = %s\n; bind_repr = %s\n}\n" - uu___ -let (sub_eff_to_string : FStar_Syntax_Syntax.sub_eff -> Prims.string) = - fun se -> - let tsopt_to_string ts_opt = - if FStar_Compiler_Util.is_some ts_opt - then - let uu___ = FStar_Compiler_Util.must ts_opt in - tscheme_to_string uu___ - else "" in - let uu___ = lid_to_string se.FStar_Syntax_Syntax.source in - let uu___1 = lid_to_string se.FStar_Syntax_Syntax.target in - let uu___2 = tsopt_to_string se.FStar_Syntax_Syntax.lift in - let uu___3 = tsopt_to_string se.FStar_Syntax_Syntax.lift_wp in - FStar_Compiler_Util.format4 - "sub_effect %s ~> %s : lift = %s ;; lift_wp = %s" uu___ uu___1 uu___2 - uu___3 -let (layered_eff_combinators_to_string : - FStar_Syntax_Syntax.layered_eff_combinators -> Prims.string) = - fun combs -> - let to_str uu___ = - match uu___ with - | (ts_t, ts_ty, kopt) -> - let uu___1 = tscheme_to_string ts_t in - let uu___2 = tscheme_to_string ts_ty in - let uu___3 = - FStar_Class_Show.show - (FStar_Class_Show.show_option - FStar_Syntax_Syntax.showable_indexed_effect_combinator_kind) - kopt in - FStar_Compiler_Util.format3 "(%s) : (%s)<%s>" uu___1 uu___2 uu___3 in - let to_str2 uu___ = - match uu___ with - | (ts_t, ts_ty) -> - let uu___1 = tscheme_to_string ts_t in - let uu___2 = tscheme_to_string ts_ty in - FStar_Compiler_Util.format2 "(%s) : (%s)" uu___1 uu___2 in - let uu___ = - let uu___1 = to_str2 combs.FStar_Syntax_Syntax.l_repr in - let uu___2 = - let uu___3 = to_str2 combs.FStar_Syntax_Syntax.l_return in - let uu___4 = - let uu___5 = to_str combs.FStar_Syntax_Syntax.l_bind in - let uu___6 = - let uu___7 = to_str combs.FStar_Syntax_Syntax.l_subcomp in - let uu___8 = - let uu___9 = to_str combs.FStar_Syntax_Syntax.l_if_then_else in - let uu___10 = - let uu___11 = - if - FStar_Pervasives_Native.uu___is_None - combs.FStar_Syntax_Syntax.l_close - then "" - else - (let uu___13 = - let uu___14 = - FStar_Compiler_Util.must - combs.FStar_Syntax_Syntax.l_close in - to_str2 uu___14 in - FStar_Compiler_Util.format1 "; l_close = %s\n" uu___13) in - [uu___11] in - uu___9 :: uu___10 in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Compiler_Util.format - "{\n; l_repr = %s\n; l_return = %s\n; l_bind = %s\n; l_subcomp = %s\n; l_if_then_else = %s\n\n %s\n }\n" - uu___ -let (eff_combinators_to_string : - FStar_Syntax_Syntax.eff_combinators -> Prims.string) = - fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.Primitive_eff combs -> - wp_eff_combinators_to_string combs - | FStar_Syntax_Syntax.DM4F_eff combs -> - wp_eff_combinators_to_string combs - | FStar_Syntax_Syntax.Layered_eff combs -> - layered_eff_combinators_to_string combs -let (eff_extraction_mode_to_string : - FStar_Syntax_Syntax.eff_extraction_mode -> Prims.string) = - fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.Extract_none s -> - FStar_Compiler_Util.format1 "none (%s)" s - | FStar_Syntax_Syntax.Extract_reify -> "reify" - | FStar_Syntax_Syntax.Extract_primitive -> "primitive" -let (eff_decl_to_string : FStar_Syntax_Syntax.eff_decl -> Prims.string) = - fun ed -> - let actions_to_string actions = - let uu___ = FStar_Compiler_List.map action_to_string actions in - FStar_Compiler_String.concat ",\n\t" uu___ in - let eff_name = - let uu___ = FStar_Syntax_Util.is_layered ed in - if uu___ then "layered_effect" else "new_effect" in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = lid_to_string ed.FStar_Syntax_Syntax.mname in - let uu___4 = - let uu___5 = - let uu___6 = univ_names_to_string ed.FStar_Syntax_Syntax.univs in - enclose_universes uu___6 in - let uu___6 = - let uu___7 = - binders_to_string " " ed.FStar_Syntax_Syntax.binders in - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Syntax_Util.effect_sig_ts - ed.FStar_Syntax_Syntax.signature in - tscheme_to_string uu___10 in - let uu___10 = - let uu___11 = - eff_combinators_to_string - ed.FStar_Syntax_Syntax.combinators in - let uu___12 = - let uu___13 = - actions_to_string ed.FStar_Syntax_Syntax.actions in - [uu___13] in - uu___11 :: uu___12 in - uu___9 :: uu___10 in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - "" :: uu___2 in - eff_name :: uu___1 in - FStar_Compiler_Util.format - "%s%s { %s%s %s : %s \n %s\nand effect_actions\n\t%s\n}\n" uu___ -let rec (sigelt_to_string : FStar_Syntax_Syntax.sigelt -> Prims.string) = - fun x -> - let basic = - match x.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_pragma p -> - FStar_Class_Show.show FStar_Syntax_Syntax.showable_pragma p - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = lid; FStar_Syntax_Syntax.us = univs; - FStar_Syntax_Syntax.params = tps; - FStar_Syntax_Syntax.num_uniform_params = uu___; - FStar_Syntax_Syntax.t = k; FStar_Syntax_Syntax.mutuals = uu___1; - FStar_Syntax_Syntax.ds = uu___2; - FStar_Syntax_Syntax.injective_type_params = uu___3;_} - -> - let quals_str = quals_to_string' x.FStar_Syntax_Syntax.sigquals in - let binders_str = binders_to_string " " tps in - let term_str = term_to_string k in - let uu___4 = FStar_Options.print_universes () in - if uu___4 - then - let uu___5 = FStar_Ident.string_of_lid lid in - let uu___6 = univ_names_to_string univs in - FStar_Compiler_Util.format5 "%stype %s<%s> %s : %s" quals_str - uu___5 uu___6 binders_str term_str - else - (let uu___6 = FStar_Ident.string_of_lid lid in - FStar_Compiler_Util.format4 "%stype %s %s : %s" quals_str uu___6 - binders_str term_str) - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = lid; FStar_Syntax_Syntax.us1 = univs; - FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = uu___; - FStar_Syntax_Syntax.num_ty_params = uu___1; - FStar_Syntax_Syntax.mutuals1 = uu___2; - FStar_Syntax_Syntax.injective_type_params1 = uu___3;_} - -> - let uu___4 = FStar_Options.print_universes () in - if uu___4 - then - let uu___5 = univ_names_to_string univs in - let uu___6 = FStar_Ident.string_of_lid lid in - let uu___7 = term_to_string t in - FStar_Compiler_Util.format3 "datacon<%s> %s : %s" uu___5 uu___6 - uu___7 - else - (let uu___6 = FStar_Ident.string_of_lid lid in - let uu___7 = term_to_string t in - FStar_Compiler_Util.format2 "datacon %s : %s" uu___6 uu___7) - | FStar_Syntax_Syntax.Sig_declare_typ - { FStar_Syntax_Syntax.lid2 = lid; FStar_Syntax_Syntax.us2 = univs; - FStar_Syntax_Syntax.t2 = t;_} - -> - let uu___ = quals_to_string' x.FStar_Syntax_Syntax.sigquals in - let uu___1 = FStar_Ident.string_of_lid lid in - let uu___2 = - let uu___3 = FStar_Options.print_universes () in - if uu___3 - then - let uu___4 = univ_names_to_string univs in - FStar_Compiler_Util.format1 "<%s>" uu___4 - else "" in - let uu___3 = term_to_string t in - FStar_Compiler_Util.format4 "%sval %s %s : %s" uu___ uu___1 uu___2 - uu___3 - | FStar_Syntax_Syntax.Sig_assume - { FStar_Syntax_Syntax.lid3 = lid; FStar_Syntax_Syntax.us3 = us; - FStar_Syntax_Syntax.phi1 = f;_} - -> - let uu___ = FStar_Options.print_universes () in - if uu___ - then - let uu___1 = FStar_Ident.string_of_lid lid in - let uu___2 = univ_names_to_string us in - let uu___3 = term_to_string f in - FStar_Compiler_Util.format3 "assume %s<%s> : %s" uu___1 uu___2 - uu___3 - else - (let uu___2 = FStar_Ident.string_of_lid lid in - let uu___3 = term_to_string f in - FStar_Compiler_Util.format2 "assume %s : %s" uu___2 uu___3) - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = lbs; - FStar_Syntax_Syntax.lids1 = uu___;_} - -> - let lbs1 = - let uu___1 = - FStar_Compiler_List.map - (fun lb -> - { - FStar_Syntax_Syntax.lbname = - (lb.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = - (lb.FStar_Syntax_Syntax.lbtyp); - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = - (lb.FStar_Syntax_Syntax.lbdef); - FStar_Syntax_Syntax.lbattrs = []; - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - }) (FStar_Pervasives_Native.snd lbs) in - ((FStar_Pervasives_Native.fst lbs), uu___1) in - lbs_to_string x.FStar_Syntax_Syntax.sigquals lbs1 - | FStar_Syntax_Syntax.Sig_bundle - { FStar_Syntax_Syntax.ses = ses; - FStar_Syntax_Syntax.lids = uu___;_} - -> - let uu___1 = - let uu___2 = FStar_Compiler_List.map sigelt_to_string ses in - FStar_Compiler_String.concat "\n" uu___2 in - Prims.strcat "(* Sig_bundle *)" uu___1 - | FStar_Syntax_Syntax.Sig_fail - { FStar_Syntax_Syntax.errs = errs; - FStar_Syntax_Syntax.fail_in_lax = lax; - FStar_Syntax_Syntax.ses1 = ses;_} - -> - let uu___ = FStar_Compiler_Util.string_of_bool lax in - let uu___1 = - (FStar_Common.string_of_list ()) - FStar_Compiler_Util.string_of_int errs in - let uu___2 = - let uu___3 = FStar_Compiler_List.map sigelt_to_string ses in - FStar_Compiler_String.concat "\n" uu___3 in - FStar_Compiler_Util.format3 - "(* Sig_fail %s %s *)\n%s\n(* / Sig_fail*)\n" uu___ uu___1 uu___2 - | FStar_Syntax_Syntax.Sig_new_effect ed -> - let uu___ = - let uu___1 = FStar_Syntax_Util.is_dm4f ed in - if uu___1 then "(* DM4F *)" else "" in - let uu___1 = - let uu___2 = quals_to_string' x.FStar_Syntax_Syntax.sigquals in - let uu___3 = eff_decl_to_string ed in Prims.strcat uu___2 uu___3 in - Prims.strcat uu___ uu___1 - | FStar_Syntax_Syntax.Sig_sub_effect se -> sub_eff_to_string se - | FStar_Syntax_Syntax.Sig_effect_abbrev - { FStar_Syntax_Syntax.lid4 = l; FStar_Syntax_Syntax.us4 = univs; - FStar_Syntax_Syntax.bs2 = tps; FStar_Syntax_Syntax.comp1 = c; - FStar_Syntax_Syntax.cflags = flags;_} - -> - let uu___ = FStar_Options.print_universes () in - if uu___ - then - let uu___1 = - let uu___2 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 = tps; - FStar_Syntax_Syntax.comp = c - }) FStar_Compiler_Range_Type.dummyRange in - FStar_Syntax_Subst.open_univ_vars univs uu___2 in - (match uu___1 with - | (univs1, t) -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Subst.compress t in - uu___4.FStar_Syntax_Syntax.n in - match uu___3 with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; - FStar_Syntax_Syntax.comp = c1;_} - -> (bs, c1) - | uu___4 -> failwith "impossible" in - (match uu___2 with - | (tps1, c1) -> - let uu___3 = sli l in - let uu___4 = univ_names_to_string univs1 in - let uu___5 = binders_to_string " " tps1 in - let uu___6 = comp_to_string c1 in - FStar_Compiler_Util.format4 "effect %s<%s> %s = %s" - uu___3 uu___4 uu___5 uu___6)) - else - (let uu___2 = sli l in - let uu___3 = binders_to_string " " tps in - let uu___4 = comp_to_string c in - FStar_Compiler_Util.format3 "effect %s %s = %s" uu___2 uu___3 - uu___4) - | FStar_Syntax_Syntax.Sig_splice - { FStar_Syntax_Syntax.is_typed = is_typed; - FStar_Syntax_Syntax.lids2 = lids; FStar_Syntax_Syntax.tac = t;_} - -> - let uu___ = - let uu___1 = - FStar_Compiler_List.map - (FStar_Class_Show.show FStar_Ident.showable_lident) lids in - FStar_Compiler_String.concat "; " uu___1 in - let uu___1 = term_to_string t in - FStar_Compiler_Util.format3 "splice%s[%s] (%s)" - (if is_typed then "_t" else "") uu___ uu___1 - | FStar_Syntax_Syntax.Sig_polymonadic_bind - { FStar_Syntax_Syntax.m_lid = m; FStar_Syntax_Syntax.n_lid = n; - FStar_Syntax_Syntax.p_lid = p; FStar_Syntax_Syntax.tm3 = t; - FStar_Syntax_Syntax.typ = ty; FStar_Syntax_Syntax.kind1 = k;_} - -> - let uu___ = FStar_Class_Show.show FStar_Ident.showable_lident m in - let uu___1 = FStar_Class_Show.show FStar_Ident.showable_lident n in - let uu___2 = FStar_Class_Show.show FStar_Ident.showable_lident p in - let uu___3 = tscheme_to_string t in - let uu___4 = tscheme_to_string ty in - let uu___5 = - FStar_Class_Show.show - (FStar_Class_Show.show_option - FStar_Syntax_Syntax.showable_indexed_effect_combinator_kind) - k in - FStar_Compiler_Util.format6 - "polymonadic_bind (%s, %s) |> %s = (%s, %s)<%s>" uu___ uu___1 - uu___2 uu___3 uu___4 uu___5 - | FStar_Syntax_Syntax.Sig_polymonadic_subcomp - { FStar_Syntax_Syntax.m_lid1 = m; FStar_Syntax_Syntax.n_lid1 = n; - FStar_Syntax_Syntax.tm4 = t; FStar_Syntax_Syntax.typ1 = ty; - FStar_Syntax_Syntax.kind2 = k;_} - -> - let uu___ = FStar_Class_Show.show FStar_Ident.showable_lident m in - let uu___1 = FStar_Class_Show.show FStar_Ident.showable_lident n in - let uu___2 = tscheme_to_string t in - let uu___3 = tscheme_to_string ty in - let uu___4 = - FStar_Class_Show.show - (FStar_Class_Show.show_option - FStar_Syntax_Syntax.showable_indexed_effect_combinator_kind) - k in - FStar_Compiler_Util.format5 - "polymonadic_subcomp %s <: %s = (%s, %s)<%s>" uu___ uu___1 uu___2 - uu___3 uu___4 in - match x.FStar_Syntax_Syntax.sigattrs with - | [] -> Prims.strcat "[@ ]" (Prims.strcat "\n" basic) - | uu___ -> - let uu___1 = attrs_to_string x.FStar_Syntax_Syntax.sigattrs in - Prims.strcat uu___1 (Prims.strcat "\n" basic) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_Resugar.ml b/ocaml/fstar-lib/generated/FStar_Syntax_Resugar.ml deleted file mode 100644 index 0637ddef677..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Syntax_Resugar.ml +++ /dev/null @@ -1,3622 +0,0 @@ -open Prims -let (doc_to_string : FStar_Pprint.document -> Prims.string) = - fun doc -> - FStar_Pprint.pretty_string (FStar_Compiler_Util.float_of_string "1.0") - (Prims.of_int (100)) doc -let (parser_term_to_string : FStar_Parser_AST.term -> Prims.string) = - fun t -> - let uu___ = FStar_Parser_ToDocument.term_to_document t in - doc_to_string uu___ -let (parser_pat_to_string : FStar_Parser_AST.pattern -> Prims.string) = - fun t -> - let uu___ = FStar_Parser_ToDocument.pat_to_document t in - doc_to_string uu___ -let (tts : FStar_Syntax_Syntax.term -> Prims.string) = - fun t -> FStar_Syntax_Util.tts t -let map_opt : - 'uuuuu 'uuuuu1 . - unit -> - ('uuuuu -> 'uuuuu1 FStar_Pervasives_Native.option) -> - 'uuuuu Prims.list -> 'uuuuu1 Prims.list - = fun uu___ -> FStar_Compiler_List.filter_map -let (bv_as_unique_ident : FStar_Syntax_Syntax.bv -> FStar_Ident.ident) = - fun x -> - let unique_name = - let uu___ = - (let uu___1 = FStar_Ident.string_of_id x.FStar_Syntax_Syntax.ppname in - FStar_Compiler_Util.starts_with FStar_Ident.reserved_prefix uu___1) - || (FStar_Options.print_real_names ()) in - if uu___ - then - let uu___1 = FStar_Ident.string_of_id x.FStar_Syntax_Syntax.ppname in - let uu___2 = - FStar_Compiler_Util.string_of_int x.FStar_Syntax_Syntax.index in - Prims.strcat uu___1 uu___2 - else FStar_Ident.string_of_id x.FStar_Syntax_Syntax.ppname in - let uu___ = - let uu___1 = FStar_Ident.range_of_id x.FStar_Syntax_Syntax.ppname in - (unique_name, uu___1) in - FStar_Ident.mk_ident uu___ -let (is_imp_bqual : - FStar_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> - Prims.bool) - = - fun a -> - match a with - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta t) when - FStar_Syntax_Util.is_fvar FStar_Parser_Const.tcresolve_lid t -> false - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit uu___) -> - true - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta uu___) -> true - | uu___ -> false -let (no_imp_args : FStar_Syntax_Syntax.args -> FStar_Syntax_Syntax.args) = - fun args -> - FStar_Compiler_List.filter - (fun uu___ -> - match uu___ with - | (uu___1, FStar_Pervasives_Native.None) -> true - | (uu___1, FStar_Pervasives_Native.Some arg) -> - Prims.op_Negation arg.FStar_Syntax_Syntax.aqual_implicit) args -let (no_imp_bs : - FStar_Syntax_Syntax.binder Prims.list -> - FStar_Syntax_Syntax.binder Prims.list) - = - fun bs -> - FStar_Compiler_List.filter - (fun b -> - Prims.op_Negation (is_imp_bqual b.FStar_Syntax_Syntax.binder_qual)) - bs -let (filter_imp_args : FStar_Syntax_Syntax.args -> FStar_Syntax_Syntax.args) - = - fun args -> - let uu___ = FStar_Options.print_implicits () in - if uu___ then args else no_imp_args args -let (filter_imp_bs : - FStar_Syntax_Syntax.binder Prims.list -> - FStar_Syntax_Syntax.binder Prims.list) - = - fun bs -> - let uu___ = FStar_Options.print_implicits () in - if uu___ then bs else no_imp_bs bs -let filter_pattern_imp : - 'uuuuu . - ('uuuuu * Prims.bool) Prims.list -> ('uuuuu * Prims.bool) Prims.list - = - fun xs -> - let uu___ = FStar_Options.print_implicits () in - if uu___ - then xs - else - FStar_Compiler_List.filter - (fun uu___2 -> - match uu___2 with - | (uu___3, is_implicit) -> Prims.op_Negation is_implicit) xs -let (label : Prims.string -> FStar_Parser_AST.term -> FStar_Parser_AST.term) - = - fun s -> - fun t -> - if s = "" - then t - else - FStar_Parser_AST.mk_term (FStar_Parser_AST.Labeled (t, s, true)) - t.FStar_Parser_AST.range FStar_Parser_AST.Un -let rec (universe_to_int : - Prims.int -> - FStar_Syntax_Syntax.universe -> - (Prims.int * FStar_Syntax_Syntax.universe)) - = - fun n -> - fun u -> - let uu___ = FStar_Syntax_Subst.compress_univ u in - match uu___ with - | FStar_Syntax_Syntax.U_succ u1 -> - universe_to_int (n + Prims.int_one) u1 - | uu___1 -> (n, u) -let (universe_to_string : FStar_Ident.ident Prims.list -> Prims.string) = - fun univs -> - let uu___ = FStar_Options.print_universes () in - if uu___ - then - let uu___1 = - FStar_Compiler_List.map (fun x -> FStar_Ident.string_of_id x) univs in - FStar_Compiler_String.concat ", " uu___1 - else "" -let rec (resugar_universe : - FStar_Syntax_Syntax.universe -> - FStar_Compiler_Range_Type.range -> FStar_Parser_AST.term) - = - fun u -> - fun r -> - let mk a r1 = FStar_Parser_AST.mk_term a r1 FStar_Parser_AST.Un in - let u1 = FStar_Syntax_Subst.compress_univ u in - match u1 with - | FStar_Syntax_Syntax.U_zero -> - mk - (FStar_Parser_AST.Const - (FStar_Const.Const_int ("0", FStar_Pervasives_Native.None))) r - | FStar_Syntax_Syntax.U_succ uu___ -> - let uu___1 = universe_to_int Prims.int_zero u1 in - (match uu___1 with - | (n, u2) -> - (match u2 with - | FStar_Syntax_Syntax.U_zero -> - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Compiler_Util.string_of_int n in - (uu___5, FStar_Pervasives_Native.None) in - FStar_Const.Const_int uu___4 in - FStar_Parser_AST.Const uu___3 in - mk uu___2 r - | uu___2 -> - let e1 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = FStar_Compiler_Util.string_of_int n in - (uu___6, FStar_Pervasives_Native.None) in - FStar_Const.Const_int uu___5 in - FStar_Parser_AST.Const uu___4 in - mk uu___3 r in - let e2 = resugar_universe u2 r in - let uu___3 = - let uu___4 = - let uu___5 = FStar_Ident.id_of_text "+" in - (uu___5, [e1; e2]) in - FStar_Parser_AST.Op uu___4 in - mk uu___3 r)) - | FStar_Syntax_Syntax.U_max l -> - (match l with - | [] -> failwith "Impossible: U_max without arguments" - | uu___ -> - let t = - let uu___1 = - let uu___2 = FStar_Ident.lid_of_path ["max"] r in - FStar_Parser_AST.Var uu___2 in - mk uu___1 r in - FStar_Compiler_List.fold_left - (fun acc -> - fun x -> - let uu___1 = - let uu___2 = - let uu___3 = resugar_universe x r in - (acc, uu___3, FStar_Parser_AST.Nothing) in - FStar_Parser_AST.App uu___2 in - mk uu___1 r) t l) - | FStar_Syntax_Syntax.U_name u2 -> mk (FStar_Parser_AST.Uvar u2) r - | FStar_Syntax_Syntax.U_unif uu___ -> mk FStar_Parser_AST.Wild r - | FStar_Syntax_Syntax.U_bvar x -> - let id = - let uu___ = - let uu___1 = - let uu___2 = FStar_Compiler_Util.string_of_int x in - FStar_Compiler_Util.strcat "uu__univ_bvar_" uu___2 in - (uu___1, r) in - FStar_Ident.mk_ident uu___ in - mk (FStar_Parser_AST.Uvar id) r - | FStar_Syntax_Syntax.U_unknown -> mk FStar_Parser_AST.Wild r -let (resugar_universe' : - FStar_Syntax_DsEnv.env -> - FStar_Syntax_Syntax.universe -> - FStar_Compiler_Range_Type.range -> FStar_Parser_AST.term) - = fun env -> fun u -> fun r -> resugar_universe u r -type expected_arity = Prims.int FStar_Pervasives_Native.option -let rec (resugar_term_as_op : - FStar_Syntax_Syntax.term -> - (Prims.string * expected_arity) FStar_Pervasives_Native.option) - = - fun t -> - let infix_prim_ops = - [(FStar_Parser_Const.op_Addition, "+"); - (FStar_Parser_Const.op_Subtraction, "-"); - (FStar_Parser_Const.op_Minus, "-"); - (FStar_Parser_Const.op_Multiply, "*"); - (FStar_Parser_Const.op_Division, "/"); - (FStar_Parser_Const.op_Modulus, "%"); - (FStar_Parser_Const.read_lid, "!"); - (FStar_Parser_Const.list_append_lid, "@"); - (FStar_Parser_Const.list_tot_append_lid, "@"); - (FStar_Parser_Const.op_Eq, "="); - (FStar_Parser_Const.op_ColonEq, ":="); - (FStar_Parser_Const.op_notEq, "<>"); - (FStar_Parser_Const.not_lid, "~"); - (FStar_Parser_Const.op_And, "&&"); - (FStar_Parser_Const.op_Or, "||"); - (FStar_Parser_Const.op_LTE, "<="); - (FStar_Parser_Const.op_GTE, ">="); - (FStar_Parser_Const.op_LT, "<"); - (FStar_Parser_Const.op_GT, ">"); - (FStar_Parser_Const.op_Modulus, "mod"); - (FStar_Parser_Const.and_lid, "/\\"); - (FStar_Parser_Const.or_lid, "\\/"); - (FStar_Parser_Const.imp_lid, "==>"); - (FStar_Parser_Const.iff_lid, "<==>"); - (FStar_Parser_Const.precedes_lid, "<<"); - (FStar_Parser_Const.eq2_lid, "=="); - (FStar_Parser_Const.forall_lid, "forall"); - (FStar_Parser_Const.exists_lid, "exists"); - (FStar_Parser_Const.salloc_lid, "alloc"); - (FStar_Parser_Const.calc_finish_lid, "calc_finish")] in - let fallback fv = - let uu___ = - FStar_Compiler_Util.find_opt - (fun d -> - FStar_Syntax_Syntax.fv_eq_lid fv (FStar_Pervasives_Native.fst d)) - infix_prim_ops in - match uu___ with - | FStar_Pervasives_Native.Some op -> - FStar_Pervasives_Native.Some - ((FStar_Pervasives_Native.snd op), FStar_Pervasives_Native.None) - | uu___1 -> - let length = - let uu___2 = - FStar_Ident.nsstr - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - FStar_Compiler_String.length uu___2 in - let str = - if length = Prims.int_zero - then - FStar_Ident.string_of_lid - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - else - (let uu___3 = - FStar_Ident.string_of_lid - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - FStar_Compiler_Util.substring_from uu___3 - (length + Prims.int_one)) in - let uu___2 = - (FStar_Compiler_Util.starts_with str "dtuple") && - (let uu___3 = - let uu___4 = - FStar_Compiler_Util.substring_from str (Prims.of_int (6)) in - FStar_Compiler_Util.safe_int_of_string uu___4 in - FStar_Compiler_Option.isSome uu___3) in - if uu___2 - then - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Compiler_Util.substring_from str (Prims.of_int (6)) in - FStar_Compiler_Util.safe_int_of_string uu___5 in - ("dtuple", uu___4) in - FStar_Pervasives_Native.Some uu___3 - else - (let uu___4 = - (FStar_Compiler_Util.starts_with str "tuple") && - (let uu___5 = - let uu___6 = - FStar_Compiler_Util.substring_from str - (Prims.of_int (5)) in - FStar_Compiler_Util.safe_int_of_string uu___6 in - FStar_Compiler_Option.isSome uu___5) in - if uu___4 - then - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Compiler_Util.substring_from str - (Prims.of_int (5)) in - FStar_Compiler_Util.safe_int_of_string uu___7 in - ("tuple", uu___6) in - FStar_Pervasives_Native.Some uu___5 - else - if FStar_Compiler_Util.starts_with str "try_with" - then - FStar_Pervasives_Native.Some - ("try_with", FStar_Pervasives_Native.None) - else - (let uu___7 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.sread_lid in - if uu___7 - then - let uu___8 = - let uu___9 = - FStar_Ident.string_of_lid - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - (uu___9, FStar_Pervasives_Native.None) in - FStar_Pervasives_Native.Some uu___8 - else FStar_Pervasives_Native.None)) in - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_fvar fv -> - let length = - let uu___1 = - FStar_Ident.nsstr - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - FStar_Compiler_String.length uu___1 in - let s = - if length = Prims.int_zero - then - FStar_Ident.string_of_lid - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - else - (let uu___2 = - FStar_Ident.string_of_lid - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - FStar_Compiler_Util.substring_from uu___2 - (length + Prims.int_one)) in - let uu___1 = FStar_Parser_AST.string_to_op s in - (match uu___1 with - | FStar_Pervasives_Native.Some t1 -> FStar_Pervasives_Native.Some t1 - | uu___2 -> fallback fv) - | FStar_Syntax_Syntax.Tm_uinst (e, us) -> resugar_term_as_op e - | uu___1 -> FStar_Pervasives_Native.None -let (is_true_pat : FStar_Syntax_Syntax.pat -> Prims.bool) = - fun p -> - match p.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_constant (FStar_Const.Const_bool (true)) -> - true - | uu___ -> false -let (is_tuple_constructor_lid : FStar_Ident.lident -> Prims.bool) = - fun lid -> - (FStar_Parser_Const.is_tuple_data_lid' lid) || - (FStar_Parser_Const.is_dtuple_data_lid' lid) -let (may_shorten : FStar_Ident.lident -> Prims.bool) = - fun lid -> - let uu___ = FStar_Options.print_real_names () in - if uu___ - then false - else - (let uu___2 = FStar_Ident.string_of_lid lid in - match uu___2 with - | "Prims.Nil" -> false - | "Prims.Cons" -> false - | uu___3 -> - let uu___4 = is_tuple_constructor_lid lid in - Prims.op_Negation uu___4) -let (maybe_shorten_lid : - FStar_Syntax_DsEnv.env -> FStar_Ident.lident -> FStar_Ident.lident) = - fun env -> - fun lid -> - let uu___ = may_shorten lid in - if uu___ then FStar_Syntax_DsEnv.shorten_lid env lid else lid -let (maybe_shorten_fv : - FStar_Syntax_DsEnv.env -> FStar_Syntax_Syntax.fv -> FStar_Ident.lident) = - fun env -> - fun fv -> - let lid = (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - maybe_shorten_lid env lid -let (serialize_machine_integer_desc : - (FStar_Const.signedness * FStar_Const.width) -> Prims.string Prims.list) = - fun uu___ -> - match uu___ with - | (s, w) -> - let sU = - match s with - | FStar_Const.Unsigned -> "U" - | FStar_Const.Signed -> "" in - let sW = - match w with - | FStar_Const.Int8 -> "8" - | FStar_Const.Int16 -> "16" - | FStar_Const.Int32 -> "32" - | FStar_Const.Int64 -> "64" in - let su = - match s with - | FStar_Const.Unsigned -> "u" - | FStar_Const.Signed -> "" in - let uu___1 = - FStar_Compiler_Util.format3 "FStar.%sInt%s.__%sint_to_t" sU sW su in - let uu___2 = - let uu___3 = - FStar_Compiler_Util.format3 "FStar.%sInt%s.%sint_to_t" sU sW su in - [uu___3] in - uu___1 :: uu___2 -let (parse_machine_integer_desc : - FStar_Syntax_Syntax.fv -> - ((FStar_Const.signedness * FStar_Const.width) * Prims.string) - FStar_Pervasives_Native.option) - = - let signs = [FStar_Const.Unsigned; FStar_Const.Signed] in - let widths = - [FStar_Const.Int8; - FStar_Const.Int16; - FStar_Const.Int32; - FStar_Const.Int64] in - let descs = - let uu___ = - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Class_Monad.monad_list () () - (Obj.magic signs) - (fun uu___1 -> - (fun s -> - let s = Obj.magic s in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_list () () (Obj.magic widths) - (fun uu___1 -> - (fun w -> - let w = Obj.magic w in - let uu___1 = - serialize_machine_integer_desc (s, w) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_list () () - (Obj.magic uu___1) - (fun uu___2 -> - (fun desc -> - let desc = Obj.magic desc in - Obj.magic [((s, w), desc)]) uu___2))) - uu___1))) uu___1)) in - ((FStar_Const.Unsigned, FStar_Const.Sizet), "FStar.SizeT.__uint_to_t") :: - uu___ in - fun fv -> - FStar_Compiler_List.tryFind - (fun uu___ -> - match uu___ with - | (uu___1, d) -> - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.lid_of_fv fv in - FStar_Ident.string_of_lid uu___3 in - d = uu___2) descs -let (can_resugar_machine_integer_fv : FStar_Syntax_Syntax.fv -> Prims.bool) = - fun fv -> - let uu___ = parse_machine_integer_desc fv in - FStar_Compiler_Option.isSome uu___ -let (resugar_machine_integer : - FStar_Syntax_Syntax.fv -> - Prims.string -> FStar_Compiler_Range_Type.range -> FStar_Parser_AST.term) - = - fun fv -> - fun i -> - fun pos -> - let uu___ = parse_machine_integer_desc fv in - match uu___ with - | FStar_Pervasives_Native.None -> - failwith - "Impossible: should be guarded by can_resugar_machine_integer" - | FStar_Pervasives_Native.Some (sw, uu___1) -> - FStar_Parser_AST.mk_term - (FStar_Parser_AST.Const - (FStar_Const.Const_int - (i, (FStar_Pervasives_Native.Some sw)))) pos - FStar_Parser_AST.Un -let rec (__is_list_literal : - FStar_Ident.lident -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term Prims.list FStar_Pervasives_Native.option) - = - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun cons_lid -> - fun nil_lid -> - fun t -> - let uu___ = FStar_Syntax_Util.head_and_args_full t in - match uu___ with - | (hd, args) -> - let hd1 = - let uu___1 = FStar_Syntax_Util.un_uinst hd in - FStar_Syntax_Subst.compress uu___1 in - let args1 = filter_imp_args args in - (match ((hd1.FStar_Syntax_Syntax.n), args1) with - | (FStar_Syntax_Syntax.Tm_fvar fv, - (hd2, FStar_Pervasives_Native.None)::(tl, - FStar_Pervasives_Native.None)::[]) - when FStar_Syntax_Syntax.fv_eq_lid fv cons_lid -> - Obj.magic - (Obj.repr - (let uu___1 = - __is_list_literal cons_lid nil_lid tl in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic uu___1) - (fun uu___2 -> - (fun tl1 -> - let tl1 = Obj.magic tl1 in - Obj.magic - (FStar_Class_Monad.return - FStar_Class_Monad.monad_option () - (Obj.magic (hd2 :: tl1)))) uu___2))) - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv nil_lid -> - Obj.magic - (Obj.repr - (FStar_Class_Monad.return - FStar_Class_Monad.monad_option () - (Obj.magic []))) - | (uu___1, uu___2) -> - Obj.magic (Obj.repr FStar_Pervasives_Native.None))) - uu___2 uu___1 uu___ -let (is_list_literal : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term Prims.list FStar_Pervasives_Native.option) - = __is_list_literal FStar_Parser_Const.cons_lid FStar_Parser_Const.nil_lid -let (is_seq_literal : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term Prims.list FStar_Pervasives_Native.option) - = - __is_list_literal FStar_Parser_Const.seq_cons_lid - FStar_Parser_Const.seq_empty_lid -let (can_resugar_machine_integer : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.args -> - (FStar_Syntax_Syntax.fv * Prims.string) FStar_Pervasives_Native.option) - = - fun hd -> - fun args -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress hd in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_fvar fv when can_resugar_machine_integer_fv fv - -> - (match args with - | (a, FStar_Pervasives_Native.None)::[] -> - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress a in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_int - (i, FStar_Pervasives_Native.None)) -> - FStar_Pervasives_Native.Some (fv, i) - | uu___2 -> FStar_Pervasives_Native.None) - | uu___1 -> FStar_Pervasives_Native.None) - | uu___1 -> FStar_Pervasives_Native.None -let rec (resugar_term' : - FStar_Syntax_DsEnv.env -> FStar_Syntax_Syntax.term -> FStar_Parser_AST.term) - = - fun env -> - fun t -> - let mk a = - FStar_Parser_AST.mk_term a t.FStar_Syntax_Syntax.pos - FStar_Parser_AST.Un in - let name a r = - let uu___ = FStar_Ident.lid_of_path [a] r in - FStar_Parser_AST.Name uu___ in - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_delayed uu___1 -> - failwith "Tm_delayed is impossible after compress" - | FStar_Syntax_Syntax.Tm_lazy i -> - let uu___1 = FStar_Syntax_Util.unfold_lazy i in - resugar_term' env uu___1 - | FStar_Syntax_Syntax.Tm_bvar x -> - let l = - let uu___1 = let uu___2 = bv_as_unique_ident x in [uu___2] in - FStar_Ident.lid_of_ids uu___1 in - mk (FStar_Parser_AST.Var l) - | FStar_Syntax_Syntax.Tm_name x -> - let l = - let uu___1 = let uu___2 = bv_as_unique_ident x in [uu___2] in - FStar_Ident.lid_of_ids uu___1 in - mk (FStar_Parser_AST.Var l) - | FStar_Syntax_Syntax.Tm_fvar fv -> - let a = (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - let length = - let uu___1 = - FStar_Ident.nsstr - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - FStar_Compiler_String.length uu___1 in - let s = - if length = Prims.int_zero - then FStar_Ident.string_of_lid a - else - (let uu___2 = FStar_Ident.string_of_lid a in - FStar_Compiler_Util.substring_from uu___2 - (length + Prims.int_one)) in - let is_prefix = Prims.strcat FStar_Ident.reserved_prefix "is_" in - if FStar_Compiler_Util.starts_with s is_prefix - then - let rest = - FStar_Compiler_Util.substring_from s - (FStar_Compiler_String.length is_prefix) in - let uu___1 = - let uu___2 = - FStar_Ident.lid_of_path [rest] t.FStar_Syntax_Syntax.pos in - FStar_Parser_AST.Discrim uu___2 in - mk uu___1 - else - if - FStar_Compiler_Util.starts_with s - FStar_Syntax_Util.field_projector_prefix - then - (let rest = - FStar_Compiler_Util.substring_from s - (FStar_Compiler_String.length - FStar_Syntax_Util.field_projector_prefix) in - let r = - FStar_Compiler_Util.split rest - FStar_Syntax_Util.field_projector_sep in - match r with - | fst::snd::[] -> - let l = - FStar_Ident.lid_of_path [fst] t.FStar_Syntax_Syntax.pos in - let r1 = - FStar_Ident.mk_ident (snd, (t.FStar_Syntax_Syntax.pos)) in - mk (FStar_Parser_AST.Projector (l, r1)) - | uu___2 -> failwith "wrong projector format") - else - (let uu___3 = - FStar_Ident.lid_equals a FStar_Parser_Const.smtpat_lid in - if uu___3 - then - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = FStar_Ident.range_of_lid a in - ("SMTPat", uu___7) in - FStar_Ident.mk_ident uu___6 in - FStar_Parser_AST.Tvar uu___5 in - mk uu___4 - else - (let uu___5 = - FStar_Ident.lid_equals a FStar_Parser_Const.smtpatOr_lid in - if uu___5 - then - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = FStar_Ident.range_of_lid a in - ("SMTPatOr", uu___9) in - FStar_Ident.mk_ident uu___8 in - FStar_Parser_AST.Tvar uu___7 in - mk uu___6 - else - (let uu___7 = - ((FStar_Ident.lid_equals a - FStar_Parser_Const.assert_lid) - || - (FStar_Ident.lid_equals a - FStar_Parser_Const.assume_lid)) - || - (let uu___8 = - let uu___9 = - FStar_Compiler_String.get s Prims.int_zero in - FStar_Char.uppercase uu___9 in - let uu___9 = - FStar_Compiler_String.get s Prims.int_zero in - uu___8 <> uu___9) in - if uu___7 - then - let uu___8 = - let uu___9 = maybe_shorten_fv env fv in - FStar_Parser_AST.Var uu___9 in - mk uu___8 - else - (let uu___9 = - let uu___10 = - let uu___11 = maybe_shorten_fv env fv in - (uu___11, []) in - FStar_Parser_AST.Construct uu___10 in - mk uu___9)))) - | FStar_Syntax_Syntax.Tm_uinst (e, universes) -> - let e1 = resugar_term' env e in - let uu___1 = FStar_Options.print_universes () in - if uu___1 - then - let univs = - FStar_Compiler_List.map - (fun x -> resugar_universe x t.FStar_Syntax_Syntax.pos) - universes in - (match e1 with - | { FStar_Parser_AST.tm = FStar_Parser_AST.Construct (hd, args); - FStar_Parser_AST.range = r; FStar_Parser_AST.level = l;_} -> - let args1 = - let uu___2 = - FStar_Compiler_List.map - (fun u -> (u, FStar_Parser_AST.UnivApp)) univs in - FStar_Compiler_List.op_At args uu___2 in - FStar_Parser_AST.mk_term - (FStar_Parser_AST.Construct (hd, args1)) r l - | uu___2 -> - FStar_Compiler_List.fold_left - (fun acc -> - fun u -> - mk - (FStar_Parser_AST.App - (acc, u, FStar_Parser_AST.UnivApp))) e1 univs) - else e1 - | FStar_Syntax_Syntax.Tm_constant c -> - let uu___1 = FStar_Syntax_Syntax.is_teff t in - if uu___1 - then - let uu___2 = name "Effect" t.FStar_Syntax_Syntax.pos in mk uu___2 - else mk (FStar_Parser_AST.Const c) - | FStar_Syntax_Syntax.Tm_type u -> - let uu___1 = - match u with - | FStar_Syntax_Syntax.U_zero -> ("Type0", false) - | FStar_Syntax_Syntax.U_unknown -> ("Type", false) - | uu___2 -> ("Type", true) in - (match uu___1 with - | (nm, needs_app) -> - let typ = - let uu___2 = name nm t.FStar_Syntax_Syntax.pos in mk uu___2 in - let uu___2 = needs_app && (FStar_Options.print_universes ()) in - if uu___2 - then - let uu___3 = - let uu___4 = - let uu___5 = - resugar_universe u t.FStar_Syntax_Syntax.pos in - (typ, uu___5, FStar_Parser_AST.UnivApp) in - FStar_Parser_AST.App uu___4 in - mk uu___3 - else typ) - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = xs; FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = uu___1;_} - -> - let uu___2 = FStar_Syntax_Subst.open_term xs body in - (match uu___2 with - | (xs1, body1) -> - let xs2 = filter_imp_bs xs1 in - let body_bv = FStar_Syntax_Free.names body1 in - let patterns = - FStar_Compiler_List.map - (fun x -> - resugar_bv_as_pat env x.FStar_Syntax_Syntax.binder_bv - x.FStar_Syntax_Syntax.binder_qual body_bv) xs2 in - let body2 = resugar_term' env body1 in - if FStar_Compiler_List.isEmpty patterns - then body2 - else mk (FStar_Parser_AST.Abs (patterns, body2))) - | FStar_Syntax_Syntax.Tm_arrow uu___1 -> - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Util.canon_arrow t in - FStar_Syntax_Subst.compress uu___5 in - uu___4.FStar_Syntax_Syntax.n in - match uu___3 with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = xs; - FStar_Syntax_Syntax.comp = body;_} - -> (xs, body) - | uu___4 -> failwith "impossible: Tm_arrow in resugar_term" in - (match uu___2 with - | (xs, body) -> - let uu___3 = FStar_Syntax_Subst.open_comp xs body in - (match uu___3 with - | (xs1, body1) -> - let xs2 = filter_imp_bs xs1 in - let body2 = resugar_comp' env body1 in - let xs3 = - let uu___4 = - FStar_Compiler_List.map - (fun b -> - resugar_binder' env b t.FStar_Syntax_Syntax.pos) - xs2 in - FStar_Compiler_List.rev uu___4 in - let rec aux body3 uu___4 = - match uu___4 with - | [] -> body3 - | hd::tl -> - let body4 = - mk (FStar_Parser_AST.Product ([hd], body3)) in - aux body4 tl in - aux body2 xs3)) - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x; FStar_Syntax_Syntax.phi = phi;_} -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.mk_binder x in [uu___3] in - FStar_Syntax_Subst.open_term uu___2 phi in - (match uu___1 with - | (x1, phi1) -> - let b = - let uu___2 = FStar_Compiler_List.hd x1 in - resugar_binder' env uu___2 t.FStar_Syntax_Syntax.pos in - let uu___2 = - let uu___3 = - let uu___4 = resugar_term' env phi1 in (b, uu___4) in - FStar_Parser_AST.Refine uu___3 in - mk uu___2) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___1; - FStar_Syntax_Syntax.vars = uu___2; - FStar_Syntax_Syntax.hash_code = uu___3;_}; - FStar_Syntax_Syntax.args = (e, uu___4)::[];_} - when - (let uu___5 = FStar_Options.print_implicits () in - Prims.op_Negation uu___5) && - (FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.b2t_lid) - -> resugar_term' env e - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = hd; FStar_Syntax_Syntax.args = args;_} - when - let uu___1 = can_resugar_machine_integer hd args in - FStar_Pervasives_Native.uu___is_Some uu___1 -> - let uu___1 = can_resugar_machine_integer hd args in - (match uu___1 with - | FStar_Pervasives_Native.Some (fv, i) -> - resugar_machine_integer fv i t.FStar_Syntax_Syntax.pos) - | FStar_Syntax_Syntax.Tm_app uu___1 -> - let t1 = FStar_Syntax_Util.canon_app t in - let uu___2 = t1.FStar_Syntax_Syntax.n in - (match uu___2 with - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = e; - FStar_Syntax_Syntax.args = args;_} - -> - let is_hide_or_reveal e1 = - let uu___3 = FStar_Syntax_Util.un_uinst e1 in - match uu___3 with - | { FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___4; - FStar_Syntax_Syntax.vars = uu___5; - FStar_Syntax_Syntax.hash_code = uu___6;_} -> - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.hide) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.reveal) - | uu___4 -> false in - let rec last uu___3 = - match uu___3 with - | hd::[] -> [hd] - | hd::tl -> last tl - | uu___4 -> failwith "last of an empty list" in - let first_two_explicit args1 = - let rec drop_implicits args2 = - match args2 with - | (uu___3, FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = uu___4;_})::tl - -> drop_implicits tl - | uu___3 -> args2 in - let uu___3 = drop_implicits args1 in - match uu___3 with - | [] -> failwith "not_enough explicit_arguments" - | uu___4::[] -> failwith "not_enough explicit_arguments" - | a1::a2::uu___4 -> [a1; a2] in - let resugar_as_app e1 args1 = - let args2 = - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with - | (e2, qual) -> - let uu___4 = resugar_term' env e2 in - let uu___5 = resugar_aqual env qual in - (uu___4, uu___5)) args1 in - let uu___3 = resugar_term' env e1 in - match uu___3 with - | { - FStar_Parser_AST.tm = FStar_Parser_AST.Construct - (hd, previous_args); - FStar_Parser_AST.range = r; - FStar_Parser_AST.level = l;_} -> - FStar_Parser_AST.mk_term - (FStar_Parser_AST.Construct - (hd, - (FStar_Compiler_List.op_At previous_args args2))) - r l - | e2 -> - FStar_Compiler_List.fold_left - (fun acc -> - fun uu___4 -> - match uu___4 with - | (x, qual) -> - mk (FStar_Parser_AST.App (acc, x, qual))) e2 - args2 in - let args1 = filter_imp_args args in - let is_projector t2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Subst.compress t2 in - FStar_Syntax_Util.un_uinst uu___5 in - uu___4.FStar_Syntax_Syntax.n in - match uu___3 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - let a = - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - let length = - let uu___4 = - FStar_Ident.nsstr - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - FStar_Compiler_String.length uu___4 in - let s = - if length = Prims.int_zero - then FStar_Ident.string_of_lid a - else - (let uu___5 = FStar_Ident.string_of_lid a in - FStar_Compiler_Util.substring_from uu___5 - (length + Prims.int_one)) in - if - FStar_Compiler_Util.starts_with s - FStar_Syntax_Util.field_projector_prefix - then - let rest = - FStar_Compiler_Util.substring_from s - (FStar_Compiler_String.length - FStar_Syntax_Util.field_projector_prefix) in - let r = - FStar_Compiler_Util.split rest - FStar_Syntax_Util.field_projector_sep in - (match r with - | fst::snd::[] -> - let l = - FStar_Ident.lid_of_path [fst] - t2.FStar_Syntax_Syntax.pos in - let r1 = - FStar_Ident.mk_ident - (snd, (t2.FStar_Syntax_Syntax.pos)) in - FStar_Pervasives_Native.Some (l, r1) - | uu___4 -> failwith "wrong projector format") - else FStar_Pervasives_Native.None - | uu___4 -> FStar_Pervasives_Native.None in - let uu___3 = - ((let uu___4 = is_projector e in - FStar_Pervasives_Native.uu___is_Some uu___4) && - ((FStar_Compiler_List.length args1) >= Prims.int_one)) - && - (let uu___4 = - let uu___5 = FStar_Compiler_List.hd args1 in - FStar_Pervasives_Native.snd uu___5 in - FStar_Pervasives_Native.uu___is_None uu___4) in - if uu___3 - then - let uu___4 = args1 in - (match uu___4 with - | arg1::rest_args -> - let uu___5 = - let uu___6 = is_projector e in - FStar_Pervasives_Native.__proj__Some__item__v uu___6 in - (match uu___5 with - | (uu___6, fi) -> - let arg = - resugar_term' env - (FStar_Pervasives_Native.fst arg1) in - let h = - let uu___7 = - let uu___8 = - let uu___9 = FStar_Ident.lid_of_ids [fi] in - (arg, uu___9) in - FStar_Parser_AST.Project uu___8 in - mk uu___7 in - FStar_Compiler_List.fold_left - (fun acc -> - fun uu___7 -> - match uu___7 with - | (a, q) -> - let aa = resugar_term' env a in - let qq = resugar_aqual env q in - mk (FStar_Parser_AST.App (acc, aa, qq))) - h rest_args)) - else - (let uu___5 = - (((let uu___6 = FStar_Options.print_implicits () in - Prims.op_Negation uu___6) && - (let uu___6 = - FStar_Options_Ext.get "show_hide_reveal" in - uu___6 = "")) - && (is_hide_or_reveal e)) - && ((FStar_Compiler_List.length args1) = Prims.int_one) in - if uu___5 - then - let uu___6 = args1 in - match uu___6 with - | (e1, uu___7)::[] -> resugar_term' env e1 - else - (let unsnoc l = - let rec unsnoc' acc uu___7 = - match uu___7 with - | [] -> failwith "unsnoc: empty list" - | x::[] -> ((FStar_Compiler_List.rev acc), x) - | x::xs -> unsnoc' (x :: acc) xs in - unsnoc' [] l in - let resugar_tuple_type env1 args2 = - let typs = - FStar_Compiler_List.map - (fun uu___7 -> - match uu___7 with - | (x, uu___8) -> resugar_term' env1 x) args2 in - let uu___7 = unsnoc typs in - match uu___7 with - | (pre, last1) -> - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Compiler_List.map - (fun uu___11 -> - FStar_Pervasives.Inr uu___11) pre in - (uu___10, last1) in - FStar_Parser_AST.Sum uu___9 in - mk uu___8 in - let resugar_dtuple_type env1 hd args2 = - let fancy_resugar uu___7 = - (fun uu___7 -> - let n = FStar_Compiler_List.length args2 in - let take n1 l = - let uu___8 = FStar_Compiler_List.splitAt n1 l in - FStar_Pervasives_Native.fst uu___8 in - let uu___8 = - let uu___9 = - let uu___10 = FStar_Compiler_List.last args2 in - FStar_Pervasives_Native.fst uu___10 in - FStar_Syntax_Util.abs_formals uu___9 in - match uu___8 with - | (bs, uu___9, uu___10) -> - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (if - (FStar_Compiler_List.length bs) < - (n - Prims.int_one) - then FStar_Pervasives_Native.None - else FStar_Pervasives_Native.Some ()) - (fun uu___11 -> - (fun uu___11 -> - let uu___11 = Obj.magic uu___11 in - let bs1 = - take (n - Prims.int_one) bs in - let concatM uu___12 l = - FStar_Class_Monad.mapM uu___12 - () () - (fun uu___13 -> - (fun x -> - let x = Obj.magic x in - Obj.magic x) uu___13) - (Obj.magic l) in - let rec open_lambda_binders - uu___13 uu___12 = - (fun t2 -> - fun bs2 -> - match bs2 with - | [] -> - Obj.magic - (Obj.repr - (FStar_Pervasives_Native.Some - t2)) - | b::bs3 -> - Obj.magic - (Obj.repr - (let uu___12 = - FStar_Syntax_Util.abs_one_ln - t2 in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () - (Obj.magic - uu___12) - (fun uu___13 -> - (fun uu___13 - -> - let uu___13 - = - Obj.magic - uu___13 in - match uu___13 - with - | - (uu___14, - body) -> - let uu___15 - = - FStar_Syntax_Subst.open_term - [b] body in - (match uu___15 - with - | - (uu___16, - body1) -> - Obj.magic - (open_lambda_binders - body1 bs3))) - uu___13)))) - uu___13 uu___12 in - let uu___12 = - Obj.magic - (FStar_Class_Monad.mapMi - FStar_Class_Monad.monad_option - () () - (fun uu___14 -> - fun uu___13 -> - (fun i -> - fun uu___13 -> - let uu___13 = - Obj.magic - uu___13 in - match uu___13 - with - | (t2, uu___14) - -> - let uu___15 = - take i bs1 in - Obj.magic - (open_lambda_binders - t2 - uu___15)) - uu___14 uu___13) - (Obj.magic args2)) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () (Obj.magic uu___12) - (fun uu___13 -> - (fun opened_bs_types -> - let opened_bs_types = - Obj.magic - opened_bs_types in - let set_binder_sort t2 - b = - { - FStar_Syntax_Syntax.binder_bv - = - (let uu___13 = - b.FStar_Syntax_Syntax.binder_bv in - { - FStar_Syntax_Syntax.ppname - = - (uu___13.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index - = - (uu___13.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort - = t2 - }); - FStar_Syntax_Syntax.binder_qual - = - (b.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity - = - (b.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs - = - (b.FStar_Syntax_Syntax.binder_attrs) - } in - let uu___13 = - unsnoc - opened_bs_types in - match uu___13 with - | (pre_bs_types, - last_type) -> - let bs2 = - FStar_Compiler_List.map2 - (fun b -> - fun t2 -> - let b1 = - set_binder_sort - t2 b in - resugar_binder' - env1 b1 - t2.FStar_Syntax_Syntax.pos) - bs1 - pre_bs_types in - let uu___14 = - let uu___15 = - let uu___16 = - let uu___17 = - FStar_Compiler_List.map - ( - fun - uu___18 - -> - FStar_Pervasives.Inl - uu___18) - bs2 in - let uu___18 = - resugar_term' - env1 - last_type in - (uu___17, - uu___18) in - FStar_Parser_AST.Sum - uu___16 in - mk uu___15 in - Obj.magic - (FStar_Pervasives_Native.Some - uu___14)) - uu___13))) uu___11))) - uu___7 in - let uu___7 = fancy_resugar () in - match uu___7 with - | FStar_Pervasives_Native.Some r -> r - | FStar_Pervasives_Native.None -> - resugar_as_app hd args2 in - let uu___7 = is_list_literal t1 in - match uu___7 with - | FStar_Pervasives_Native.Some ts -> - let uu___8 = - let uu___9 = - FStar_Compiler_List.map (resugar_term' env) ts in - FStar_Parser_AST.ListLiteral uu___9 in - mk uu___8 - | FStar_Pervasives_Native.None -> - let uu___8 = is_seq_literal t1 in - (match uu___8 with - | FStar_Pervasives_Native.Some ts -> - let uu___9 = - let uu___10 = - FStar_Compiler_List.map (resugar_term' env) - ts in - FStar_Parser_AST.SeqLiteral uu___10 in - mk uu___9 - | FStar_Pervasives_Native.None -> - let uu___9 = resugar_term_as_op e in - (match uu___9 with - | FStar_Pervasives_Native.None -> - resugar_as_app e args1 - | FStar_Pervasives_Native.Some - ("calc_finish", uu___10) -> - let uu___11 = resugar_calc env t1 in - (match uu___11 with - | FStar_Pervasives_Native.Some r -> r - | uu___12 -> resugar_as_app e args1) - | FStar_Pervasives_Native.Some ("tuple", n) - when - (FStar_Pervasives_Native.Some - (FStar_Compiler_List.length args1)) - = n - -> resugar_tuple_type env args1 - | FStar_Pervasives_Native.Some ("dtuple", n) - when - (FStar_Pervasives_Native.Some - (FStar_Compiler_List.length args1)) - = n - -> resugar_dtuple_type env e args1 - | FStar_Pervasives_Native.Some - (ref_read, uu___10) when - let uu___11 = - FStar_Ident.string_of_lid - FStar_Parser_Const.sread_lid in - ref_read = uu___11 -> - let uu___11 = FStar_Compiler_List.hd args1 in - (match uu___11 with - | (t2, uu___12) -> - let uu___13 = - let uu___14 = - FStar_Syntax_Subst.compress t2 in - uu___14.FStar_Syntax_Syntax.n in - (match uu___13 with - | FStar_Syntax_Syntax.Tm_fvar fv - when - let uu___14 = - FStar_Ident.string_of_lid - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - FStar_Syntax_Util.field_projector_contains_constructor - uu___14 - -> - let f = - let uu___14 = - let uu___15 = - FStar_Ident.string_of_lid - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - [uu___15] in - FStar_Ident.lid_of_path - uu___14 - t2.FStar_Syntax_Syntax.pos in - let uu___14 = - let uu___15 = - let uu___16 = - resugar_term' env t2 in - (uu___16, f) in - FStar_Parser_AST.Project - uu___15 in - mk uu___14 - | uu___14 -> resugar_term' env t2)) - | FStar_Pervasives_Native.Some - ("try_with", uu___10) when - (FStar_Compiler_List.length args1) > - Prims.int_one - -> - (try - (fun uu___11 -> - match () with - | () -> - let new_args = - first_two_explicit args1 in - let uu___12 = - match new_args with - | (a1, uu___13)::(a2, uu___14)::[] - -> (a1, a2) - | uu___13 -> - failwith - "wrong arguments to try_with" in - (match uu___12 with - | (body, handler) -> - let decomp term = - let uu___13 = - let uu___14 = - FStar_Syntax_Subst.compress - term in - uu___14.FStar_Syntax_Syntax.n in - match uu___13 with - | FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs - = x; - FStar_Syntax_Syntax.body - = e1; - FStar_Syntax_Syntax.rc_opt - = uu___14;_} - -> - let uu___15 = - FStar_Syntax_Subst.open_term - x e1 in - (match uu___15 with - | (x1, e2) -> e2) - | uu___14 -> - let uu___15 = - let uu___16 = - let uu___17 = - resugar_term' - env term in - FStar_Parser_AST.term_to_string - uu___17 in - Prims.strcat - "wrong argument format to try_with: " - uu___16 in - failwith uu___15 in - let body1 = - let uu___13 = decomp body in - resugar_term' env uu___13 in - let handler1 = - let uu___13 = - decomp handler in - resugar_term' env uu___13 in - let rec resugar_body t2 = - match t2.FStar_Parser_AST.tm - with - | FStar_Parser_AST.Match - (e1, - FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None, - (uu___13, uu___14, - b)::[]) - -> b - | FStar_Parser_AST.Let - (uu___13, uu___14, b) - -> b - | FStar_Parser_AST.Ascribed - (t11, t21, t3, - use_eq) - -> - let uu___13 = - let uu___14 = - let uu___15 = - resugar_body - t11 in - (uu___15, t21, - t3, use_eq) in - FStar_Parser_AST.Ascribed - uu___14 in - mk uu___13 - | uu___13 -> - failwith - "unexpected body format to try_with" in - let e1 = resugar_body body1 in - let rec resugar_branches t2 - = - match t2.FStar_Parser_AST.tm - with - | FStar_Parser_AST.Match - (e2, - FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None, - branches) - -> branches - | FStar_Parser_AST.Ascribed - (t11, t21, t3, - uu___13) - -> - resugar_branches t11 - | uu___13 -> [] in - let branches = - resugar_branches handler1 in - mk - (FStar_Parser_AST.TryWith - (e1, branches)))) () - with | uu___11 -> resugar_as_app e args1) - | FStar_Pervasives_Native.Some - ("try_with", uu___10) -> - resugar_as_app e args1 - | FStar_Pervasives_Native.Some (op, uu___10) - when - (((((((op = "=") || (op = "==")) || - (op = "===")) - || (op = "@")) - || (op = ":=")) - || (op = "|>")) - || (op = "<<")) - && (FStar_Options.print_implicits ()) - -> resugar_as_app e args1 - | FStar_Pervasives_Native.Some (op, uu___10) - when - (FStar_Compiler_Util.starts_with op - "forall") - || - (FStar_Compiler_Util.starts_with op - "exists") - -> - let rec uncurry xs pats t2 flavor_matches - = - match t2.FStar_Parser_AST.tm with - | FStar_Parser_AST.QExists - (xs', (uu___11, pats'), body) when - flavor_matches t2 -> - uncurry - (FStar_Compiler_List.op_At xs xs') - (FStar_Compiler_List.op_At pats - pats') body flavor_matches - | FStar_Parser_AST.QForall - (xs', (uu___11, pats'), body) when - flavor_matches t2 -> - uncurry - (FStar_Compiler_List.op_At xs xs') - (FStar_Compiler_List.op_At pats - pats') body flavor_matches - | FStar_Parser_AST.QuantOp - (uu___11, xs', (uu___12, pats'), - body) - when flavor_matches t2 -> - uncurry - (FStar_Compiler_List.op_At xs xs') - (FStar_Compiler_List.op_At pats - pats') body flavor_matches - | uu___11 -> (xs, pats, t2) in - let resugar_forall_body body = - let uu___11 = - let uu___12 = - FStar_Syntax_Subst.compress body in - uu___12.FStar_Syntax_Syntax.n in - match uu___11 with - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = xs; - FStar_Syntax_Syntax.body = body1; - FStar_Syntax_Syntax.rc_opt = - uu___12;_} - -> - let uu___13 = - FStar_Syntax_Subst.open_term xs - body1 in - (match uu___13 with - | (xs1, body2) -> - let xs2 = filter_imp_bs xs1 in - let xs3 = - FStar_Compiler_List.map - (fun b -> - resugar_binder' env b - t1.FStar_Syntax_Syntax.pos) - xs2 in - let uu___14 = - let uu___15 = - let uu___16 = - FStar_Syntax_Subst.compress - body2 in - uu___16.FStar_Syntax_Syntax.n in - match uu___15 with - | FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 - = e1; - FStar_Syntax_Syntax.meta - = m;_} - -> - let body3 = - resugar_term' env e1 in - let uu___16 = - match m with - | FStar_Syntax_Syntax.Meta_pattern - (uu___17, pats) -> - let uu___18 = - FStar_Compiler_List.map - (fun es -> - FStar_Compiler_List.map - (fun - uu___19 - -> - match uu___19 - with - | - (e2, - uu___20) - -> - resugar_term' - env e2) - es) pats in - (uu___18, body3) - | FStar_Syntax_Syntax.Meta_labeled - (s, r, p) -> - let uu___17 = - let uu___18 = - let uu___19 = - let uu___20 = - FStar_Errors_Msg.rendermsg - s in - (body3, - uu___20, p) in - FStar_Parser_AST.Labeled - uu___19 in - mk uu___18 in - ([], uu___17) - | uu___17 -> - failwith - "wrong pattern format for QForall/QExists" in - (match uu___16 with - | (pats, body4) -> - (pats, body4)) - | uu___16 -> - let uu___17 = - resugar_term' env body2 in - ([], uu___17) in - (match uu___14 with - | (pats, body3) -> - let decompile_op op1 = - let uu___15 = - FStar_Parser_AST.string_to_op - op1 in - match uu___15 with - | FStar_Pervasives_Native.None - -> op1 - | FStar_Pervasives_Native.Some - (op2, uu___16) -> - op2 in - let flavor_matches t2 = - match ((t2.FStar_Parser_AST.tm), - op) - with - | (FStar_Parser_AST.QExists - uu___15, "exists") -> - true - | (FStar_Parser_AST.QForall - uu___15, "forall") -> - true - | (FStar_Parser_AST.QuantOp - (id, uu___15, - uu___16, uu___17), - uu___18) -> - let uu___19 = - FStar_Ident.string_of_id - id in - uu___19 = op - | uu___15 -> false in - let uu___15 = - uncurry xs3 pats body3 - flavor_matches in - (match uu___15 with - | (xs4, pats1, body4) -> - let binders = - FStar_Parser_AST.idents_of_binders - xs4 - t1.FStar_Syntax_Syntax.pos in - if op = "forall" - then - mk - (FStar_Parser_AST.QForall - (xs4, - (binders, - pats1), - body4)) - else - if op = "exists" - then - mk - (FStar_Parser_AST.QExists - (xs4, - (binders, - pats1), - body4)) - else - (let uu___18 = - let uu___19 = - let uu___20 - = - FStar_Ident.id_of_text - op in - (uu___20, - xs4, - (binders, - pats1), - body4) in - FStar_Parser_AST.QuantOp - uu___19 in - mk uu___18)))) - | uu___12 -> - if op = "forall" - then - let uu___13 = - let uu___14 = - let uu___15 = - resugar_term' env body in - ([], ([], []), uu___15) in - FStar_Parser_AST.QForall uu___14 in - mk uu___13 - else - (let uu___14 = - let uu___15 = - let uu___16 = - resugar_term' env body in - ([], ([], []), uu___16) in - FStar_Parser_AST.QExists - uu___15 in - mk uu___14) in - if - (FStar_Compiler_List.length args1) > - Prims.int_zero - then - let args2 = last args1 in - (match args2 with - | (b, uu___11)::[] -> - resugar_forall_body b - | uu___11 -> - failwith - "wrong args format to QForall") - else resugar_as_app e args1 - | FStar_Pervasives_Native.Some - ("alloc", uu___10) -> - let uu___11 = FStar_Compiler_List.hd args1 in - (match uu___11 with - | (e1, uu___12) -> resugar_term' env e1) - | FStar_Pervasives_Native.Some - (op, expected_arity1) -> - let op1 = FStar_Ident.id_of_text op in - let resugar args2 = - FStar_Compiler_List.map - (fun uu___10 -> - match uu___10 with - | (e1, qual) -> - let uu___11 = - resugar_term' env e1 in - let uu___12 = - resugar_aqual env qual in - (uu___11, uu___12)) args2 in - (match expected_arity1 with - | FStar_Pervasives_Native.None -> - let resugared_args = resugar args1 in - let expect_n = - FStar_Parser_ToDocument.handleable_args_length - op1 in - if - (FStar_Compiler_List.length - resugared_args) - >= expect_n - then - let uu___10 = - FStar_Compiler_Util.first_N - expect_n resugared_args in - (match uu___10 with - | (op_args, rest) -> - let head = - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Compiler_List.map - FStar_Pervasives_Native.fst - op_args in - (op1, uu___13) in - FStar_Parser_AST.Op - uu___12 in - mk uu___11 in - FStar_Compiler_List.fold_left - (fun head1 -> - fun uu___11 -> - match uu___11 with - | (arg, qual) -> - mk - (FStar_Parser_AST.App - (head1, arg, - qual))) head - rest) - else resugar_as_app e args1 - | FStar_Pervasives_Native.Some n when - (FStar_Compiler_List.length args1) = - n - -> - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = resugar args1 in - FStar_Compiler_List.map - FStar_Pervasives_Native.fst - uu___13 in - (op1, uu___12) in - FStar_Parser_AST.Op uu___11 in - mk uu___10 - | uu___10 -> resugar_as_app e args1)))))) - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = e; - FStar_Syntax_Syntax.ret_opt = FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.brs = (pat, wopt, t1)::[]; - FStar_Syntax_Syntax.rc_opt1 = uu___1;_} - -> - let uu___2 = FStar_Syntax_Subst.open_branch (pat, wopt, t1) in - (match uu___2 with - | (pat1, wopt1, t2) -> - let branch_bv = FStar_Syntax_Free.names t2 in - let bnds = - let uu___3 = - let uu___4 = - let uu___5 = resugar_pat' env pat1 branch_bv in - let uu___6 = resugar_term' env e in (uu___5, uu___6) in - (FStar_Pervasives_Native.None, uu___4) in - [uu___3] in - let body = resugar_term' env t2 in - mk - (FStar_Parser_AST.Let - (FStar_Parser_AST.NoLetQualifier, bnds, body))) - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = e; - FStar_Syntax_Syntax.ret_opt = asc_opt; - FStar_Syntax_Syntax.brs = branches; - FStar_Syntax_Syntax.rc_opt1 = uu___1;_} - -> - let resugar_branch uu___2 = - match uu___2 with - | (pat, wopt, b) -> - let uu___3 = FStar_Syntax_Subst.open_branch (pat, wopt, b) in - (match uu___3 with - | (pat1, wopt1, b1) -> - let branch_bv = FStar_Syntax_Free.names b1 in - let pat2 = resugar_pat' env pat1 branch_bv in - let wopt2 = - match wopt1 with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some e1 -> - let uu___4 = resugar_term' env e1 in - FStar_Pervasives_Native.Some uu___4 in - let b2 = resugar_term' env b1 in (pat2, wopt2, b2)) in - let asc_opt1 = - resugar_match_returns env e t.FStar_Syntax_Syntax.pos asc_opt in - let uu___2 = - let uu___3 = - let uu___4 = resugar_term' env e in - let uu___5 = FStar_Compiler_List.map resugar_branch branches in - (uu___4, FStar_Pervasives_Native.None, asc_opt1, uu___5) in - FStar_Parser_AST.Match uu___3 in - mk uu___2 - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = e; FStar_Syntax_Syntax.asc = asc; - FStar_Syntax_Syntax.eff_opt = uu___1;_} - -> - let uu___2 = resugar_ascription env asc in - (match uu___2 with - | (asc1, tac_opt, b) -> - let uu___3 = - let uu___4 = - let uu___5 = resugar_term' env e in - (uu___5, asc1, tac_opt, b) in - FStar_Parser_AST.Ascribed uu___4 in - mk uu___3) - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (is_rec, source_lbs); - FStar_Syntax_Syntax.body1 = body;_} - -> - let mk_pat a = - FStar_Parser_AST.mk_pattern a t.FStar_Syntax_Syntax.pos in - let uu___1 = FStar_Syntax_Subst.open_let_rec source_lbs body in - (match uu___1 with - | (source_lbs1, body1) -> - let resugar_one_binding bnd = - let attrs_opt = - match bnd.FStar_Syntax_Syntax.lbattrs with - | [] -> FStar_Pervasives_Native.None - | tms -> - let uu___2 = - FStar_Compiler_List.map (resugar_term' env) tms in - FStar_Pervasives_Native.Some uu___2 in - let uu___2 = - let uu___3 = - FStar_Syntax_Util.mk_conj bnd.FStar_Syntax_Syntax.lbtyp - bnd.FStar_Syntax_Syntax.lbdef in - FStar_Syntax_Subst.open_univ_vars - bnd.FStar_Syntax_Syntax.lbunivs uu___3 in - match uu___2 with - | (univs, td) -> - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Subst.compress td in - uu___5.FStar_Syntax_Syntax.n in - match uu___4 with - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = uu___5; - FStar_Syntax_Syntax.args = - (t1, uu___6)::(d, uu___7)::[];_} - -> (t1, d) - | uu___5 -> failwith "wrong let binding format" in - (match uu___3 with - | (typ, def) -> - let uu___4 = - let uu___5 = - let uu___6 = FStar_Syntax_Subst.compress def in - uu___6.FStar_Syntax_Syntax.n in - match uu___5 with - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = b; - FStar_Syntax_Syntax.body = t1; - FStar_Syntax_Syntax.rc_opt = uu___6;_} - -> - let uu___7 = - FStar_Syntax_Subst.open_term b t1 in - (match uu___7 with - | (b1, t2) -> - let b2 = filter_imp_bs b1 in - (b2, t2, true)) - | uu___6 -> ([], def, false) in - (match uu___4 with - | (binders, term, is_pat_app) -> - let uu___5 = - match bnd.FStar_Syntax_Syntax.lbname with - | FStar_Pervasives.Inr fv -> - let uu___6 = - mk_pat - (FStar_Parser_AST.PatName - ((fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v)) in - (uu___6, term) - | FStar_Pervasives.Inl bv -> - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = bv_as_unique_ident bv in - (uu___9, - FStar_Pervasives_Native.None, - []) in - FStar_Parser_AST.PatVar uu___8 in - mk_pat uu___7 in - (uu___6, term) in - (match uu___5 with - | (pat, term1) -> - let uu___6 = - if is_pat_app - then - let args = - FStar_Compiler_List.map - (fun b -> - let q = - resugar_bqual env - b.FStar_Syntax_Syntax.binder_qual in - let uu___7 = - let uu___8 = - let uu___9 = - bv_as_unique_ident - b.FStar_Syntax_Syntax.binder_bv in - let uu___10 = - FStar_Compiler_List.map - (resugar_term' env) - b.FStar_Syntax_Syntax.binder_attrs in - (uu___9, q, uu___10) in - FStar_Parser_AST.PatVar - uu___8 in - mk_pat uu___7) binders in - let uu___7 = - let uu___8 = - mk_pat - (FStar_Parser_AST.PatApp - (pat, args)) in - let uu___9 = - resugar_term' env term1 in - (uu___8, uu___9) in - let uu___8 = universe_to_string univs in - (uu___7, uu___8) - else - (let uu___8 = - let uu___9 = - resugar_term' env term1 in - (pat, uu___9) in - let uu___9 = - universe_to_string univs in - (uu___8, uu___9)) in - (attrs_opt, uu___6)))) in - let r = - FStar_Compiler_List.map resugar_one_binding source_lbs1 in - let bnds = - let f uu___2 = - match uu___2 with - | (attrs, (pb, univs)) -> - let uu___3 = - let uu___4 = FStar_Options.print_universes () in - Prims.op_Negation uu___4 in - if uu___3 - then (attrs, pb) - else - (let uu___5 = - let uu___6 = - label univs (FStar_Pervasives_Native.snd pb) in - ((FStar_Pervasives_Native.fst pb), uu___6) in - (attrs, uu___5)) in - FStar_Compiler_List.map f r in - let body2 = resugar_term' env body1 in - mk - (FStar_Parser_AST.Let - ((if is_rec - then FStar_Parser_AST.Rec - else FStar_Parser_AST.NoLetQualifier), bnds, body2))) - | FStar_Syntax_Syntax.Tm_uvar (u, uu___1) -> - let s = - let uu___2 = - let uu___3 = - FStar_Syntax_Unionfind.uvar_id - u.FStar_Syntax_Syntax.ctx_uvar_head in - FStar_Compiler_Util.string_of_int uu___3 in - Prims.strcat "?u" uu___2 in - let uu___2 = mk FStar_Parser_AST.Wild in label s uu___2 - | FStar_Syntax_Syntax.Tm_quoted (tm, qi) -> - let qi1 = - match qi.FStar_Syntax_Syntax.qkind with - | FStar_Syntax_Syntax.Quote_static -> FStar_Parser_AST.Static - | FStar_Syntax_Syntax.Quote_dynamic -> FStar_Parser_AST.Dynamic in - let uu___1 = - let uu___2 = let uu___3 = resugar_term' env tm in (uu___3, qi1) in - FStar_Parser_AST.Quote uu___2 in - mk uu___1 - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = e; FStar_Syntax_Syntax.meta = m;_} -> - let resugar_meta_desugared uu___1 = - match uu___1 with - | FStar_Syntax_Syntax.Sequence -> - let term = resugar_term' env e in - let rec resugar_seq t1 = - match t1.FStar_Parser_AST.tm with - | FStar_Parser_AST.Let (uu___2, (uu___3, (p, t11))::[], t2) - -> mk (FStar_Parser_AST.Seq (t11, t2)) - | FStar_Parser_AST.Ascribed (t11, t2, t3, use_eq) -> - let uu___2 = - let uu___3 = - let uu___4 = resugar_seq t11 in - (uu___4, t2, t3, use_eq) in - FStar_Parser_AST.Ascribed uu___3 in - mk uu___2 - | uu___2 -> t1 in - resugar_seq term - | FStar_Syntax_Syntax.Machine_integer (uu___2, uu___3) -> - resugar_term' env e - | FStar_Syntax_Syntax.Primop -> resugar_term' env e - | FStar_Syntax_Syntax.Masked_effect -> resugar_term' env e - | FStar_Syntax_Syntax.Meta_smt_pat -> resugar_term' env e in - (match m with - | FStar_Syntax_Syntax.Meta_labeled uu___1 -> resugar_term' env e - | FStar_Syntax_Syntax.Meta_desugared i -> resugar_meta_desugared i - | FStar_Syntax_Syntax.Meta_named t1 -> - mk (FStar_Parser_AST.Name t1) - | FStar_Syntax_Syntax.Meta_pattern uu___1 -> resugar_term' env e - | FStar_Syntax_Syntax.Meta_monadic uu___1 -> resugar_term' env e - | FStar_Syntax_Syntax.Meta_monadic_lift uu___1 -> - resugar_term' env e) - | FStar_Syntax_Syntax.Tm_unknown -> mk FStar_Parser_AST.Wild -and (resugar_ascription : - FStar_Syntax_DsEnv.env -> - ((FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax, - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax) - FStar_Pervasives.either * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax FStar_Pervasives_Native.option * Prims.bool) - -> - (FStar_Parser_AST.term * FStar_Parser_AST.term - FStar_Pervasives_Native.option * Prims.bool)) - = - fun env -> - fun uu___ -> - match uu___ with - | (asc, tac_opt, b) -> - let uu___1 = - match asc with - | FStar_Pervasives.Inl n -> resugar_term' env n - | FStar_Pervasives.Inr n -> resugar_comp' env n in - let uu___2 = - FStar_Compiler_Util.map_opt tac_opt (resugar_term' env) in - (uu___1, uu___2, b) -and (resugar_calc : - FStar_Syntax_DsEnv.env -> - FStar_Syntax_Syntax.term -> - FStar_Parser_AST.term FStar_Pervasives_Native.option) - = - fun uu___1 -> - fun uu___ -> - (fun env -> - fun t0 -> - let mk a = - FStar_Parser_AST.mk_term a t0.FStar_Syntax_Syntax.pos - FStar_Parser_AST.Un in - let resugar_calc_finish t = - let uu___ = FStar_Syntax_Util.head_and_args t in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Util.un_uinst hd in - FStar_Syntax_Subst.compress uu___4 in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, - (uu___2, FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = uu___3;_}):: - (rel, FStar_Pervasives_Native.None)::(uu___4, - FStar_Pervasives_Native.Some - { - FStar_Syntax_Syntax.aqual_implicit - = true; - FStar_Syntax_Syntax.aqual_attributes - = uu___5;_}):: - (uu___6, FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = uu___7;_}):: - (uu___8, FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = uu___9;_}):: - (pf, FStar_Pervasives_Native.None)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.calc_finish_lid - -> - let pf1 = FStar_Syntax_Util.unthunk pf in - FStar_Pervasives_Native.Some (rel, pf1) - | uu___2 -> FStar_Pervasives_Native.None) in - let un_eta_rel rel = - let bv_eq_tm b t = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_name b' when - FStar_Syntax_Syntax.bv_eq b b' -> true - | uu___1 -> false in - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress rel in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = b1::b2::[]; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = uu___1;_} - -> - let uu___2 = FStar_Syntax_Subst.open_term [b1; b2] body in - (match uu___2 with - | (b11::b21::[], body1) -> - let body2 = FStar_Syntax_Util.unascribe body1 in - let body3 = - let uu___3 = FStar_Syntax_Util.unb2t body2 in - match uu___3 with - | FStar_Pervasives_Native.Some body4 -> body4 - | FStar_Pervasives_Native.None -> body2 in - let uu___3 = - let uu___4 = FStar_Syntax_Subst.compress body3 in - uu___4.FStar_Syntax_Syntax.n in - (match uu___3 with - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = e; - FStar_Syntax_Syntax.args = args;_} - when - (FStar_Compiler_List.length args) >= - (Prims.of_int (2)) - -> - (match FStar_Compiler_List.rev args with - | (a1, FStar_Pervasives_Native.None)::(a2, - FStar_Pervasives_Native.None)::rest - -> - let uu___4 = - (bv_eq_tm b11.FStar_Syntax_Syntax.binder_bv - a2) - && - (bv_eq_tm - b21.FStar_Syntax_Syntax.binder_bv a1) in - if uu___4 - then - let uu___5 = - FStar_Syntax_Util.mk_app e - (FStar_Compiler_List.rev rest) in - FStar_Pervasives_Native.Some uu___5 - else FStar_Pervasives_Native.Some rel - | uu___4 -> FStar_Pervasives_Native.Some rel) - | uu___4 -> FStar_Pervasives_Native.Some rel)) - | uu___1 -> FStar_Pervasives_Native.Some rel in - let resugar_step pack = - let uu___ = FStar_Syntax_Util.head_and_args pack in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Util.un_uinst hd in - FStar_Syntax_Subst.compress uu___4 in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, - (uu___2, FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = uu___3;_}):: - (uu___4, FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = uu___5;_}):: - (uu___6, FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = uu___7;_}):: - (rel, FStar_Pervasives_Native.None)::(z, - FStar_Pervasives_Native.None):: - (uu___8, FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = uu___9;_}):: - (pf, FStar_Pervasives_Native.None)::(j, - FStar_Pervasives_Native.None)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.calc_step_lid - -> - let pf1 = FStar_Syntax_Util.unthunk pf in - let j1 = FStar_Syntax_Util.unthunk j in - FStar_Pervasives_Native.Some (z, rel, j1, pf1) - | uu___2 -> FStar_Pervasives_Native.None) in - let resugar_init pack = - let uu___ = FStar_Syntax_Util.head_and_args pack in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Util.un_uinst hd in - FStar_Syntax_Subst.compress uu___4 in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, - (uu___2, FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = uu___3;_}):: - (x, FStar_Pervasives_Native.None)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.calc_init_lid - -> FStar_Pervasives_Native.Some x - | uu___2 -> FStar_Pervasives_Native.None) in - let rec resugar_all_steps pack = - let uu___ = resugar_step pack in - match uu___ with - | FStar_Pervasives_Native.Some (t, r, j, k) -> - let uu___1 = resugar_all_steps k in - FStar_Compiler_Util.bind_opt uu___1 - (fun uu___2 -> - match uu___2 with - | (steps, k1) -> - FStar_Pervasives_Native.Some - (((t, r, j) :: steps), k1)) - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.Some ([], pack) in - let resugar_rel rel = - let rel1 = - let uu___ = un_eta_rel rel in - match uu___ with - | FStar_Pervasives_Native.Some rel2 -> rel2 - | FStar_Pervasives_Native.None -> rel in - let fallback uu___ = - let uu___1 = - let uu___2 = resugar_term' env rel1 in - FStar_Parser_AST.Paren uu___2 in - mk uu___1 in - let uu___ = resugar_term_as_op rel1 in - match uu___ with - | FStar_Pervasives_Native.Some (s, FStar_Pervasives_Native.None) - -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Ident.id_of_text s in (uu___3, []) in - FStar_Parser_AST.Op uu___2 in - mk uu___1 - | FStar_Pervasives_Native.Some - (s, FStar_Pervasives_Native.Some uu___1) when - uu___1 = (Prims.of_int (2)) -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_Ident.id_of_text s in (uu___4, []) in - FStar_Parser_AST.Op uu___3 in - mk uu___2 - | uu___1 -> fallback () in - let build_calc rel x0 steps = - let r = resugar_term' env in - let uu___ = - let uu___1 = - let uu___2 = resugar_rel rel in - let uu___3 = r x0 in - let uu___4 = - FStar_Compiler_List.map - (fun uu___5 -> - match uu___5 with - | (z, rel1, j) -> - let uu___6 = - let uu___7 = resugar_rel rel1 in - let uu___8 = r j in - let uu___9 = r z in (uu___7, uu___8, uu___9) in - FStar_Parser_AST.CalcStep uu___6) steps in - (uu___2, uu___3, uu___4) in - FStar_Parser_AST.CalcProof uu___1 in - mk uu___ in - let uu___ = resugar_calc_finish t0 in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Class_Monad.monad_option () - () (Obj.magic uu___) - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - match uu___1 with - | (rel, pack) -> - let uu___2 = resugar_all_steps pack in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic uu___2) - (fun uu___3 -> - (fun uu___3 -> - let uu___3 = Obj.magic uu___3 in - match uu___3 with - | (steps, k) -> - let uu___4 = resugar_init k in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () (Obj.magic uu___4) - (fun uu___5 -> - (fun x0 -> - let x0 = Obj.magic x0 in - let uu___5 = - build_calc rel x0 - (FStar_Compiler_List.rev - steps) in - Obj.magic - (FStar_Pervasives_Native.Some - uu___5)) uu___5))) - uu___3))) uu___1))) uu___1 uu___ -and (resugar_match_returns : - FStar_Syntax_DsEnv.env -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Compiler_Range_Type.range -> - (FStar_Syntax_Syntax.binder * - ((FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax, - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax) - FStar_Pervasives.either * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax FStar_Pervasives_Native.option * - Prims.bool)) FStar_Pervasives_Native.option -> - (FStar_Ident.ident FStar_Pervasives_Native.option * - FStar_Parser_AST.term * Prims.bool) - FStar_Pervasives_Native.option) - = - fun env -> - fun scrutinee -> - fun r -> - fun asc_opt -> - match asc_opt with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (b, asc) -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.open_ascription [b] asc in - match uu___1 with - | (bs, asc1) -> - let b1 = FStar_Compiler_List.hd bs in - let uu___2 = - let uu___3 = - FStar_Ident.string_of_id - (b1.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.ppname in - uu___3 = FStar_Parser_Const.match_returns_def_name in - if uu___2 - then - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Subst.compress scrutinee in - FStar_Syntax_Util.unascribe uu___5 in - uu___4.FStar_Syntax_Syntax.n in - (match uu___3 with - | FStar_Syntax_Syntax.Tm_name sbv -> - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Syntax_Syntax.bv_to_name sbv in - ((b1.FStar_Syntax_Syntax.binder_bv), - uu___8) in - FStar_Syntax_Syntax.NT uu___7 in - [uu___6] in - FStar_Syntax_Subst.subst_ascription uu___5 asc1 in - (FStar_Pervasives_Native.None, uu___4) - | uu___4 -> (FStar_Pervasives_Native.None, asc1)) - else ((FStar_Pervasives_Native.Some b1), asc1) in - (match uu___ with - | (bopt, asc1) -> - let bopt1 = - FStar_Compiler_Util.map_option - (fun b1 -> - let uu___1 = resugar_binder' env b1 r in - FStar_Parser_AST.ident_of_binder r uu___1) bopt in - let uu___1 = - let uu___2 = resugar_ascription env asc1 in - match uu___2 with - | (asc2, FStar_Pervasives_Native.None, use_eq) -> - (asc2, use_eq) - | uu___3 -> - failwith - "resugaring does not support match return annotation with a tactic" in - (match uu___1 with - | (asc2, use_eq) -> - FStar_Pervasives_Native.Some (bopt1, asc2, use_eq))) -and (resugar_comp' : - FStar_Syntax_DsEnv.env -> FStar_Syntax_Syntax.comp -> FStar_Parser_AST.term) - = - fun env -> - fun c -> - let mk a = - FStar_Parser_AST.mk_term a c.FStar_Syntax_Syntax.pos - FStar_Parser_AST.Un in - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total typ -> - let t = resugar_term' env typ in - let uu___ = FStar_Options.print_implicits () in - if uu___ - then - mk - (FStar_Parser_AST.Construct - (FStar_Parser_Const.effect_Tot_lid, - [(t, FStar_Parser_AST.Nothing)])) - else t - | FStar_Syntax_Syntax.GTotal typ -> - let t = resugar_term' env typ in - mk - (FStar_Parser_AST.Construct - (FStar_Parser_Const.effect_GTot_lid, - [(t, FStar_Parser_AST.Nothing)])) - | FStar_Syntax_Syntax.Comp c1 -> - let result = - let uu___ = resugar_term' env c1.FStar_Syntax_Syntax.result_typ in - (uu___, FStar_Parser_AST.Nothing) in - let mk_decreases fl = - let rec aux l uu___ = - match uu___ with - | [] -> l - | hd::tl -> - (match hd with - | FStar_Syntax_Syntax.DECREASES dec_order -> - let d = - match dec_order with - | FStar_Syntax_Syntax.Decreases_lex (t::[]) -> - resugar_term' env t - | FStar_Syntax_Syntax.Decreases_lex ts -> - let uu___1 = - let uu___2 = - FStar_Compiler_List.map (resugar_term' env) - ts in - FStar_Parser_AST.LexList uu___2 in - mk uu___1 - | FStar_Syntax_Syntax.Decreases_wf (rel, e) -> - let uu___1 = - let uu___2 = - let uu___3 = resugar_term' env rel in - let uu___4 = resugar_term' env e in - (uu___3, uu___4) in - FStar_Parser_AST.WFOrder uu___2 in - mk uu___1 in - let e = - mk - (FStar_Parser_AST.Decreases - (d, FStar_Pervasives_Native.None)) in - aux (e :: l) tl - | uu___1 -> aux l tl) in - aux [] fl in - let uu___ = - (FStar_Ident.lid_equals c1.FStar_Syntax_Syntax.effect_name - FStar_Parser_Const.effect_Lemma_lid) - && - ((FStar_Compiler_List.length c1.FStar_Syntax_Syntax.effect_args) - = (Prims.of_int (3))) in - if uu___ - then - let args = - FStar_Compiler_List.map - (fun uu___1 -> - match uu___1 with - | (e, uu___2) -> - let uu___3 = resugar_term' env e in - (uu___3, FStar_Parser_AST.Nothing)) - c1.FStar_Syntax_Syntax.effect_args in - let uu___1 = - match c1.FStar_Syntax_Syntax.effect_args with - | (pre, uu___2)::(post, uu___3)::(pats, uu___4)::[] -> - (pre, post, pats) - | uu___2 -> failwith "impossible" in - (match uu___1 with - | (pre, post, pats) -> - let pre1 = - let uu___2 = - FStar_Syntax_Util.is_fvar FStar_Parser_Const.true_lid - pre in - if uu___2 then [] else [pre] in - let post1 = FStar_Syntax_Util.unthunk_lemma_post post in - let pats1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.head_of pats in - FStar_Syntax_Util.is_fvar FStar_Parser_Const.nil_lid - uu___3 in - if uu___2 then [] else [pats] in - let pre2 = - FStar_Compiler_List.map - (fun t -> - let uu___2 = - let uu___3 = - let uu___4 = resugar_term' env t in - (uu___4, FStar_Pervasives_Native.None) in - FStar_Parser_AST.Requires uu___3 in - mk uu___2) pre1 in - let post2 = - let uu___2 = - let uu___3 = - let uu___4 = resugar_term' env post1 in - (uu___4, FStar_Pervasives_Native.None) in - FStar_Parser_AST.Ensures uu___3 in - mk uu___2 in - let pats2 = - FStar_Compiler_List.map (resugar_term' env) pats1 in - let decrease = mk_decreases c1.FStar_Syntax_Syntax.flags in - let uu___2 = - let uu___3 = - let uu___4 = - maybe_shorten_lid env - c1.FStar_Syntax_Syntax.effect_name in - let uu___5 = - FStar_Compiler_List.map - (fun t -> (t, FStar_Parser_AST.Nothing)) - (FStar_Compiler_List.op_At pre2 - (FStar_Compiler_List.op_At (post2 :: decrease) - pats2)) in - (uu___4, uu___5) in - FStar_Parser_AST.Construct uu___3 in - mk uu___2) - else - (let uu___2 = FStar_Options.print_effect_args () in - if uu___2 - then - let args = - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with - | (e, uu___4) -> - let uu___5 = resugar_term' env e in - (uu___5, FStar_Parser_AST.Nothing)) - c1.FStar_Syntax_Syntax.effect_args in - let decrease = - let uu___3 = mk_decreases c1.FStar_Syntax_Syntax.flags in - FStar_Compiler_List.map - (fun t -> (t, FStar_Parser_AST.Nothing)) uu___3 in - let uu___3 = - let uu___4 = - let uu___5 = - maybe_shorten_lid env c1.FStar_Syntax_Syntax.effect_name in - (uu___5, - (FStar_Compiler_List.op_At (result :: decrease) args)) in - FStar_Parser_AST.Construct uu___4 in - mk uu___3 - else - (let uu___4 = - let uu___5 = - let uu___6 = - maybe_shorten_lid env - c1.FStar_Syntax_Syntax.effect_name in - (uu___6, [result]) in - FStar_Parser_AST.Construct uu___5 in - mk uu___4)) -and (resugar_binder' : - FStar_Syntax_DsEnv.env -> - FStar_Syntax_Syntax.binder -> - FStar_Compiler_Range_Type.range -> FStar_Parser_AST.binder) - = - fun env -> - fun b -> - fun r -> - let imp = resugar_bqual env b.FStar_Syntax_Syntax.binder_qual in - let e = - resugar_term' env - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - let attrs = - FStar_Compiler_List.map (resugar_term' env) - b.FStar_Syntax_Syntax.binder_attrs in - let b' = - match e.FStar_Parser_AST.tm with - | FStar_Parser_AST.Wild -> - let uu___ = bv_as_unique_ident b.FStar_Syntax_Syntax.binder_bv in - FStar_Parser_AST.Variable uu___ - | uu___ -> - let uu___1 = - FStar_Syntax_Syntax.is_null_bv - b.FStar_Syntax_Syntax.binder_bv in - if uu___1 - then FStar_Parser_AST.NoName e - else - (let uu___3 = - let uu___4 = - bv_as_unique_ident b.FStar_Syntax_Syntax.binder_bv in - (uu___4, e) in - FStar_Parser_AST.Annotated uu___3) in - FStar_Parser_AST.mk_binder_with_attrs b' r - FStar_Parser_AST.Type_level imp attrs -and (resugar_bv_as_pat' : - FStar_Syntax_DsEnv.env -> - FStar_Syntax_Syntax.bv -> - FStar_Parser_AST.arg_qualifier FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.bv FStar_Compiler_FlatSet.t -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - FStar_Pervasives_Native.option -> FStar_Parser_AST.pattern) - = - fun env -> - fun v -> - fun aqual -> - fun body_bv -> - fun typ_opt -> - let mk a = - let uu___ = FStar_Syntax_Syntax.range_of_bv v in - FStar_Parser_AST.mk_pattern a uu___ in - let used = - FStar_Class_Setlike.mem () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) v (Obj.magic body_bv) in - let pat = - let uu___ = - if used - then - let uu___1 = - let uu___2 = bv_as_unique_ident v in (uu___2, aqual, []) in - FStar_Parser_AST.PatVar uu___1 - else FStar_Parser_AST.PatWild (aqual, []) in - mk uu___ in - match typ_opt with - | FStar_Pervasives_Native.None -> pat - | FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_unknown; - FStar_Syntax_Syntax.pos = uu___; - FStar_Syntax_Syntax.vars = uu___1; - FStar_Syntax_Syntax.hash_code = uu___2;_} - -> pat - | FStar_Pervasives_Native.Some typ -> - let uu___ = FStar_Options.print_bound_var_types () in - if uu___ - then - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = resugar_term' env typ in - (uu___4, FStar_Pervasives_Native.None) in - (pat, uu___3) in - FStar_Parser_AST.PatAscribed uu___2 in - mk uu___1 - else pat -and (resugar_bv_as_pat : - FStar_Syntax_DsEnv.env -> - FStar_Syntax_Syntax.bv -> - FStar_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.bv FStar_Compiler_FlatSet.t -> - FStar_Parser_AST.pattern) - = - fun env -> - fun x -> - fun qual -> - fun body_bv -> - let bq = resugar_bqual env qual in - let uu___ = - let uu___1 = - FStar_Syntax_Subst.compress x.FStar_Syntax_Syntax.sort in - FStar_Pervasives_Native.Some uu___1 in - resugar_bv_as_pat' env x bq body_bv uu___ -and (resugar_pat' : - FStar_Syntax_DsEnv.env -> - FStar_Syntax_Syntax.pat -> - FStar_Syntax_Syntax.bv FStar_Compiler_FlatSet.t -> - FStar_Parser_AST.pattern) - = - fun env -> - fun p -> - fun branch_bv -> - let mk a = FStar_Parser_AST.mk_pattern a p.FStar_Syntax_Syntax.p in - let to_arg_qual bopt = - FStar_Compiler_Util.bind_opt bopt - (fun b -> - if b - then FStar_Pervasives_Native.Some FStar_Parser_AST.Implicit - else FStar_Pervasives_Native.None) in - let must_print args = - FStar_Compiler_List.existsML - (fun uu___ -> - match uu___ with - | (pattern, is_implicit) -> - (match pattern.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_var bv -> - is_implicit && - (FStar_Class_Setlike.mem () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) bv - (Obj.magic branch_bv)) - | uu___1 -> false)) args in - let resugar_plain_pat_cons' fv args = - let uu___ = - let uu___1 = - let uu___2 = - mk - (FStar_Parser_AST.PatName - ((fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v)) in - (uu___2, args) in - FStar_Parser_AST.PatApp uu___1 in - mk uu___ in - let rec resugar_plain_pat_cons fv args = - let args1 = - let uu___ = - let uu___1 = must_print args in Prims.op_Negation uu___1 in - if uu___ then filter_pattern_imp args else args in - let args2 = - FStar_Compiler_List.map - (fun uu___ -> - match uu___ with - | (p1, b) -> aux p1 (FStar_Pervasives_Native.Some b)) args1 in - resugar_plain_pat_cons' fv args2 - and aux p1 imp_opt = - match p1.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_constant c -> - mk (FStar_Parser_AST.PatConst c) - | FStar_Syntax_Syntax.Pat_cons (fv, uu___, args) when - FStar_Ident.lid_equals - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - FStar_Parser_Const.nil_lid - -> - let uu___1 = filter_pattern_imp args in - (match uu___1 with - | [] -> mk (FStar_Parser_AST.PatList []) - | uu___2 -> resugar_plain_pat_cons fv args) - | FStar_Syntax_Syntax.Pat_cons (fv, uu___, args) when - FStar_Ident.lid_equals - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - FStar_Parser_Const.cons_lid - -> - let uu___1 = filter_pattern_imp args in - (match uu___1 with - | (hd, false)::(tl, false)::[] -> - let hd' = aux hd (FStar_Pervasives_Native.Some false) in - let uu___2 = aux tl (FStar_Pervasives_Native.Some false) in - (match uu___2 with - | { FStar_Parser_AST.pat = FStar_Parser_AST.PatList tl'; - FStar_Parser_AST.prange = p2;_} -> - FStar_Parser_AST.mk_pattern - (FStar_Parser_AST.PatList (hd' :: tl')) p2 - | tl' -> resugar_plain_pat_cons' fv [hd'; tl']) - | uu___2 -> resugar_plain_pat_cons fv args) - | FStar_Syntax_Syntax.Pat_cons (fv, uu___, []) -> - mk - (FStar_Parser_AST.PatName - ((fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v)) - | FStar_Syntax_Syntax.Pat_cons (fv, uu___, args) when - (is_tuple_constructor_lid - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v) - && (let uu___1 = must_print args in Prims.op_Negation uu___1) - -> - let args1 = - FStar_Compiler_List.filter_map - (fun uu___1 -> - match uu___1 with - | (p2, is_implicit) -> - if is_implicit - then FStar_Pervasives_Native.None - else - (let uu___3 = - aux p2 (FStar_Pervasives_Native.Some false) in - FStar_Pervasives_Native.Some uu___3)) args in - let is_dependent_tuple = - FStar_Parser_Const.is_dtuple_data_lid' - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - mk (FStar_Parser_AST.PatTuple (args1, is_dependent_tuple)) - | FStar_Syntax_Syntax.Pat_cons - ({ FStar_Syntax_Syntax.fv_name = uu___; - FStar_Syntax_Syntax.fv_qual = FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Record_ctor (name, fields));_}, - uu___1, args) - -> - let fields1 = - let uu___2 = - FStar_Compiler_List.map - (fun f -> FStar_Ident.lid_of_ids [f]) fields in - FStar_Compiler_List.rev uu___2 in - let args1 = - let uu___2 = - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with - | (p2, b) -> aux p2 (FStar_Pervasives_Native.Some b)) - args in - FStar_Compiler_List.rev uu___2 in - let rec map2 l1 l2 = - match (l1, l2) with - | ([], []) -> [] - | ([], hd::tl) -> [] - | (hd::tl, []) -> - let uu___2 = - let uu___3 = - mk - (FStar_Parser_AST.PatWild - (FStar_Pervasives_Native.None, [])) in - (hd, uu___3) in - let uu___3 = map2 tl [] in uu___2 :: uu___3 - | (hd1::tl1, hd2::tl2) -> - let uu___2 = map2 tl1 tl2 in (hd1, hd2) :: uu___2 in - let args2 = - let uu___2 = map2 fields1 args1 in - FStar_Compiler_List.rev uu___2 in - mk (FStar_Parser_AST.PatRecord args2) - | FStar_Syntax_Syntax.Pat_cons (fv, uu___, args) -> - resugar_plain_pat_cons fv args - | FStar_Syntax_Syntax.Pat_var v -> - let uu___ = - let uu___1 = - FStar_Ident.string_of_id v.FStar_Syntax_Syntax.ppname in - FStar_Parser_AST.string_to_op uu___1 in - (match uu___ with - | FStar_Pervasives_Native.Some (op, uu___1) -> - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Ident.range_of_id - v.FStar_Syntax_Syntax.ppname in - (op, uu___5) in - FStar_Ident.mk_ident uu___4 in - FStar_Parser_AST.PatOp uu___3 in - mk uu___2 - | FStar_Pervasives_Native.None -> - let uu___1 = to_arg_qual imp_opt in - resugar_bv_as_pat' env v uu___1 branch_bv - FStar_Pervasives_Native.None) - | FStar_Syntax_Syntax.Pat_dot_term uu___ -> - mk - (FStar_Parser_AST.PatWild - ((FStar_Pervasives_Native.Some FStar_Parser_AST.Implicit), - [])) in - aux p FStar_Pervasives_Native.None -and (resugar_bqual : - FStar_Syntax_DsEnv.env -> - FStar_Syntax_Syntax.bqual -> - FStar_Parser_AST.arg_qualifier FStar_Pervasives_Native.option) - = - fun env -> - fun q -> - match q with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit b) -> - FStar_Pervasives_Native.Some FStar_Parser_AST.Implicit - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Equality) -> - FStar_Pervasives_Native.Some FStar_Parser_AST.Equality - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta t) when - FStar_Syntax_Util.is_fvar FStar_Parser_Const.tcresolve_lid t -> - FStar_Pervasives_Native.Some FStar_Parser_AST.TypeClassArg - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta t) -> - let uu___ = - let uu___1 = resugar_term' env t in FStar_Parser_AST.Meta uu___1 in - FStar_Pervasives_Native.Some uu___ -and (resugar_aqual : - FStar_Syntax_DsEnv.env -> FStar_Syntax_Syntax.aqual -> FStar_Parser_AST.imp) - = - fun env -> - fun q -> - match q with - | FStar_Pervasives_Native.None -> FStar_Parser_AST.Nothing - | FStar_Pervasives_Native.Some a -> - if a.FStar_Syntax_Syntax.aqual_implicit - then FStar_Parser_AST.Hash - else FStar_Parser_AST.Nothing -let (resugar_qualifier : - FStar_Syntax_Syntax.qualifier -> - FStar_Parser_AST.qualifier FStar_Pervasives_Native.option) - = - fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.Assumption -> - FStar_Pervasives_Native.Some FStar_Parser_AST.Assumption - | FStar_Syntax_Syntax.InternalAssumption -> FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.New -> - FStar_Pervasives_Native.Some FStar_Parser_AST.New - | FStar_Syntax_Syntax.Private -> - FStar_Pervasives_Native.Some FStar_Parser_AST.Private - | FStar_Syntax_Syntax.Unfold_for_unification_and_vcgen -> - FStar_Pervasives_Native.Some - FStar_Parser_AST.Unfold_for_unification_and_vcgen - | FStar_Syntax_Syntax.Visible_default -> FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Irreducible -> - FStar_Pervasives_Native.Some FStar_Parser_AST.Irreducible - | FStar_Syntax_Syntax.Inline_for_extraction -> - FStar_Pervasives_Native.Some FStar_Parser_AST.Inline_for_extraction - | FStar_Syntax_Syntax.NoExtract -> - FStar_Pervasives_Native.Some FStar_Parser_AST.NoExtract - | FStar_Syntax_Syntax.Noeq -> - FStar_Pervasives_Native.Some FStar_Parser_AST.Noeq - | FStar_Syntax_Syntax.Unopteq -> - FStar_Pervasives_Native.Some FStar_Parser_AST.Unopteq - | FStar_Syntax_Syntax.TotalEffect -> - FStar_Pervasives_Native.Some FStar_Parser_AST.TotalEffect - | FStar_Syntax_Syntax.Logic -> FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Reifiable -> - FStar_Pervasives_Native.Some FStar_Parser_AST.Reifiable - | FStar_Syntax_Syntax.Reflectable uu___1 -> - FStar_Pervasives_Native.Some FStar_Parser_AST.Reflectable - | FStar_Syntax_Syntax.Discriminator uu___1 -> - FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Projector uu___1 -> FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.RecordType uu___1 -> FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.RecordConstructor uu___1 -> - FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Action uu___1 -> FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.ExceptionConstructor -> - FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.HasMaskedEffect -> FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Effect -> - FStar_Pervasives_Native.Some FStar_Parser_AST.Effect_qual - | FStar_Syntax_Syntax.OnlyName -> FStar_Pervasives_Native.None -let (resugar_pragma : FStar_Syntax_Syntax.pragma -> FStar_Parser_AST.pragma) - = - fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.ShowOptions -> FStar_Parser_AST.ShowOptions - | FStar_Syntax_Syntax.SetOptions s -> FStar_Parser_AST.SetOptions s - | FStar_Syntax_Syntax.ResetOptions s -> FStar_Parser_AST.ResetOptions s - | FStar_Syntax_Syntax.PushOptions s -> FStar_Parser_AST.PushOptions s - | FStar_Syntax_Syntax.PopOptions -> FStar_Parser_AST.PopOptions - | FStar_Syntax_Syntax.RestartSolver -> FStar_Parser_AST.RestartSolver - | FStar_Syntax_Syntax.PrintEffectsGraph -> - FStar_Parser_AST.PrintEffectsGraph -let (drop_n_bs : - Prims.int -> FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = - fun n -> - fun t -> - let uu___ = FStar_Syntax_Util.arrow_formals_comp_ln t in - match uu___ with - | (bs, c) -> - let bs1 = - let uu___1 = FStar_Compiler_List.splitAt n bs in - FStar_Pervasives_Native.snd uu___1 in - FStar_Syntax_Util.arrow bs1 c -let (resugar_typ : - FStar_Syntax_DsEnv.env -> - FStar_Syntax_Syntax.sigelt Prims.list -> - FStar_Syntax_Syntax.sigelt -> - (FStar_Syntax_Syntax.sigelts * FStar_Parser_AST.tycon)) - = - fun env -> - fun datacon_ses -> - fun se -> - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = tylid; FStar_Syntax_Syntax.us = uvs; - FStar_Syntax_Syntax.params = bs; - FStar_Syntax_Syntax.num_uniform_params = uu___; - FStar_Syntax_Syntax.t = t; - FStar_Syntax_Syntax.mutuals = uu___1; - FStar_Syntax_Syntax.ds = datacons; - FStar_Syntax_Syntax.injective_type_params = uu___2;_} - -> - let uu___3 = - FStar_Compiler_List.partition - (fun se1 -> - match se1.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = uu___4; - FStar_Syntax_Syntax.us1 = uu___5; - FStar_Syntax_Syntax.t1 = uu___6; - FStar_Syntax_Syntax.ty_lid = inductive_lid; - FStar_Syntax_Syntax.num_ty_params = uu___7; - FStar_Syntax_Syntax.mutuals1 = uu___8; - FStar_Syntax_Syntax.injective_type_params1 = uu___9;_} - -> FStar_Ident.lid_equals inductive_lid tylid - | uu___4 -> failwith "unexpected") datacon_ses in - (match uu___3 with - | (current_datacons, other_datacons) -> - let bs1 = filter_imp_bs bs in - let bs2 = - FStar_Compiler_List.map - (fun b -> - resugar_binder' env b t.FStar_Syntax_Syntax.pos) bs1 in - let tyc = - let uu___4 = - (FStar_Compiler_Util.for_some - FStar_Syntax_Syntax.uu___is_RecordType - se.FStar_Syntax_Syntax.sigquals) - && - ((FStar_Compiler_List.length current_datacons) = - Prims.int_one) in - if uu___4 - then - let uu___5 = current_datacons in - match uu___5 with - | dc::[] -> - (match dc.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = l; - FStar_Syntax_Syntax.us1 = univs; - FStar_Syntax_Syntax.t1 = typ; - FStar_Syntax_Syntax.ty_lid = uu___6; - FStar_Syntax_Syntax.num_ty_params = num; - FStar_Syntax_Syntax.mutuals1 = uu___7; - FStar_Syntax_Syntax.injective_type_params1 = - uu___8;_} - -> - let typ1 = drop_n_bs num typ in - let fields = - let uu___9 = - FStar_Syntax_Util.arrow_formals_comp_ln - typ1 in - match uu___9 with - | (bs3, uu___10) -> - let bs4 = filter_imp_bs bs3 in - FStar_Compiler_List.map - (fun b -> - let q = - resugar_bqual env - b.FStar_Syntax_Syntax.binder_qual in - let uu___11 = - bv_as_unique_ident - b.FStar_Syntax_Syntax.binder_bv in - let uu___12 = - FStar_Compiler_List.map - (resugar_term' env) - b.FStar_Syntax_Syntax.binder_attrs in - let uu___13 = - resugar_term' env - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - (uu___11, q, uu___12, uu___13)) bs4 in - let uu___9 = - let uu___10 = FStar_Ident.ident_of_lid tylid in - let uu___11 = - FStar_Compiler_List.map (resugar_term' env) - se.FStar_Syntax_Syntax.sigattrs in - (uu___10, bs2, FStar_Pervasives_Native.None, - uu___11, fields) in - FStar_Parser_AST.TyconRecord uu___9 - | uu___6 -> failwith "ggg1") - else - (let resugar_datacon constructors se1 = - match se1.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = l; - FStar_Syntax_Syntax.us1 = univs; - FStar_Syntax_Syntax.t1 = typ; - FStar_Syntax_Syntax.ty_lid = uu___6; - FStar_Syntax_Syntax.num_ty_params = num; - FStar_Syntax_Syntax.mutuals1 = uu___7; - FStar_Syntax_Syntax.injective_type_params1 = - uu___8;_} - -> - let typ1 = drop_n_bs num typ in - let c = - let uu___9 = FStar_Ident.ident_of_lid l in - let uu___10 = - let uu___11 = - let uu___12 = resugar_term' env typ1 in - FStar_Parser_AST.VpArbitrary uu___12 in - FStar_Pervasives_Native.Some uu___11 in - let uu___11 = - FStar_Compiler_List.map (resugar_term' env) - se1.FStar_Syntax_Syntax.sigattrs in - (uu___9, uu___10, uu___11) in - c :: constructors - | uu___6 -> failwith "unexpected" in - let constructors = - FStar_Compiler_List.fold_left resugar_datacon [] - current_datacons in - let uu___6 = - let uu___7 = FStar_Ident.ident_of_lid tylid in - (uu___7, bs2, FStar_Pervasives_Native.None, - constructors) in - FStar_Parser_AST.TyconVariant uu___6) in - (other_datacons, tyc)) - | uu___ -> - failwith - "Impossible : only Sig_inductive_typ can be resugared as types" -let (mk_decl : - FStar_Compiler_Range_Type.range -> - FStar_Syntax_Syntax.qualifier Prims.list -> - FStar_Parser_AST.decl' -> FStar_Parser_AST.decl) - = - fun r -> - fun q -> - fun d' -> - let uu___ = FStar_Compiler_List.choose resugar_qualifier q in - { - FStar_Parser_AST.d = d'; - FStar_Parser_AST.drange = r; - FStar_Parser_AST.quals = uu___; - FStar_Parser_AST.attrs = []; - FStar_Parser_AST.interleaved = false - } -let (decl'_to_decl : - FStar_Syntax_Syntax.sigelt -> - FStar_Parser_AST.decl' -> FStar_Parser_AST.decl) - = - fun se -> - fun d' -> - mk_decl se.FStar_Syntax_Syntax.sigrng se.FStar_Syntax_Syntax.sigquals - d' -let (resugar_tscheme'' : - FStar_Syntax_DsEnv.env -> - Prims.string -> FStar_Syntax_Syntax.tscheme -> FStar_Parser_AST.decl) - = - fun env -> - fun name -> - fun ts -> - let uu___ = ts in - match uu___ with - | (univs, typ) -> - let name1 = - FStar_Ident.mk_ident (name, (typ.FStar_Syntax_Syntax.pos)) in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = resugar_term' env typ in - (name1, [], FStar_Pervasives_Native.None, uu___6) in - FStar_Parser_AST.TyconAbbrev uu___5 in - [uu___4] in - (false, false, uu___3) in - FStar_Parser_AST.Tycon uu___2 in - mk_decl typ.FStar_Syntax_Syntax.pos [] uu___1 -let (resugar_tscheme' : - FStar_Syntax_DsEnv.env -> - FStar_Syntax_Syntax.tscheme -> FStar_Parser_AST.decl) - = fun env -> fun ts -> resugar_tscheme'' env "tscheme" ts -let (resugar_wp_eff_combinators : - FStar_Syntax_DsEnv.env -> - Prims.bool -> - FStar_Syntax_Syntax.wp_eff_combinators -> - FStar_Parser_AST.decl Prims.list) - = - fun env -> - fun for_free -> - fun combs -> - let resugar_opt name tsopt = - match tsopt with - | FStar_Pervasives_Native.Some ts -> - let uu___ = resugar_tscheme'' env name ts in [uu___] - | FStar_Pervasives_Native.None -> [] in - let repr = resugar_opt "repr" combs.FStar_Syntax_Syntax.repr in - let return_repr = - resugar_opt "return_repr" combs.FStar_Syntax_Syntax.return_repr in - let bind_repr = - resugar_opt "bind_repr" combs.FStar_Syntax_Syntax.bind_repr in - if for_free - then - FStar_Compiler_List.op_At repr - (FStar_Compiler_List.op_At return_repr bind_repr) - else - (let uu___1 = - resugar_tscheme'' env "ret_wp" combs.FStar_Syntax_Syntax.ret_wp in - let uu___2 = - let uu___3 = - resugar_tscheme'' env "bind_wp" - combs.FStar_Syntax_Syntax.bind_wp in - let uu___4 = - let uu___5 = - resugar_tscheme'' env "stronger" - combs.FStar_Syntax_Syntax.stronger in - let uu___6 = - let uu___7 = - resugar_tscheme'' env "if_then_else" - combs.FStar_Syntax_Syntax.if_then_else in - let uu___8 = - let uu___9 = - resugar_tscheme'' env "ite_wp" - combs.FStar_Syntax_Syntax.ite_wp in - let uu___10 = - let uu___11 = - resugar_tscheme'' env "close_wp" - combs.FStar_Syntax_Syntax.close_wp in - let uu___12 = - let uu___13 = - resugar_tscheme'' env "trivial" - combs.FStar_Syntax_Syntax.trivial in - uu___13 :: - (FStar_Compiler_List.op_At repr - (FStar_Compiler_List.op_At return_repr bind_repr)) in - uu___11 :: uu___12 in - uu___9 :: uu___10 in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2) -let (resugar_layered_eff_combinators : - FStar_Syntax_DsEnv.env -> - FStar_Syntax_Syntax.layered_eff_combinators -> - FStar_Parser_AST.decl Prims.list) - = - fun env -> - fun combs -> - let resugar name uu___ = - match uu___ with - | (ts, uu___1, uu___2) -> resugar_tscheme'' env name ts in - let resugar2 name uu___ = - match uu___ with | (ts, uu___1) -> resugar_tscheme'' env name ts in - let uu___ = resugar2 "repr" combs.FStar_Syntax_Syntax.l_repr in - let uu___1 = - let uu___2 = resugar2 "return" combs.FStar_Syntax_Syntax.l_return in - let uu___3 = - let uu___4 = resugar "bind" combs.FStar_Syntax_Syntax.l_bind in - let uu___5 = - let uu___6 = - resugar "subcomp" combs.FStar_Syntax_Syntax.l_subcomp in - let uu___7 = - let uu___8 = - resugar "if_then_else" - combs.FStar_Syntax_Syntax.l_if_then_else in - [uu___8] in - uu___6 :: uu___7 in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - uu___ :: uu___1 -let (resugar_combinators : - FStar_Syntax_DsEnv.env -> - FStar_Syntax_Syntax.eff_combinators -> FStar_Parser_AST.decl Prims.list) - = - fun env -> - fun combs -> - match combs with - | FStar_Syntax_Syntax.Primitive_eff combs1 -> - resugar_wp_eff_combinators env false combs1 - | FStar_Syntax_Syntax.DM4F_eff combs1 -> - resugar_wp_eff_combinators env true combs1 - | FStar_Syntax_Syntax.Layered_eff combs1 -> - resugar_layered_eff_combinators env combs1 -let (resugar_eff_decl' : - FStar_Syntax_DsEnv.env -> - FStar_Syntax_Syntax.eff_decl -> FStar_Parser_AST.decl) - = - fun env -> - fun ed -> - let r = FStar_Compiler_Range_Type.dummyRange in - let q = [] in - let resugar_action d for_free = - let action_params = - FStar_Syntax_Subst.open_binders d.FStar_Syntax_Syntax.action_params in - let uu___ = - FStar_Syntax_Subst.open_term action_params - d.FStar_Syntax_Syntax.action_defn in - match uu___ with - | (bs, action_defn) -> - let uu___1 = - FStar_Syntax_Subst.open_term action_params - d.FStar_Syntax_Syntax.action_typ in - (match uu___1 with - | (bs1, action_typ) -> - let action_params1 = filter_imp_bs action_params in - let action_params2 = - let uu___2 = - FStar_Compiler_List.map - (fun b -> resugar_binder' env b r) action_params1 in - FStar_Compiler_List.rev uu___2 in - let action_defn1 = resugar_term' env action_defn in - let action_typ1 = resugar_term' env action_typ in - if for_free - then - let a = - let uu___2 = - let uu___3 = FStar_Ident.lid_of_str "construct" in - (uu___3, - [(action_defn1, FStar_Parser_AST.Nothing); - (action_typ1, FStar_Parser_AST.Nothing)]) in - FStar_Parser_AST.Construct uu___2 in - let t = FStar_Parser_AST.mk_term a r FStar_Parser_AST.Un in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Ident.ident_of_lid - d.FStar_Syntax_Syntax.action_name in - (uu___7, action_params2, - FStar_Pervasives_Native.None, t) in - FStar_Parser_AST.TyconAbbrev uu___6 in - [uu___5] in - (false, false, uu___4) in - FStar_Parser_AST.Tycon uu___3 in - mk_decl r q uu___2 - else - (let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Ident.ident_of_lid - d.FStar_Syntax_Syntax.action_name in - (uu___8, action_params2, - FStar_Pervasives_Native.None, action_defn1) in - FStar_Parser_AST.TyconAbbrev uu___7 in - [uu___6] in - (false, false, uu___5) in - FStar_Parser_AST.Tycon uu___4 in - mk_decl r q uu___3)) in - let eff_name = FStar_Ident.ident_of_lid ed.FStar_Syntax_Syntax.mname in - let uu___ = - let sig_ts = - FStar_Syntax_Util.effect_sig_ts ed.FStar_Syntax_Syntax.signature in - FStar_Syntax_Subst.open_term ed.FStar_Syntax_Syntax.binders - (FStar_Pervasives_Native.snd sig_ts) in - match uu___ with - | (eff_binders, eff_typ) -> - let eff_binders1 = filter_imp_bs eff_binders in - let eff_binders2 = - let uu___1 = - FStar_Compiler_List.map (fun b -> resugar_binder' env b r) - eff_binders1 in - FStar_Compiler_List.rev uu___1 in - let eff_typ1 = resugar_term' env eff_typ in - let mandatory_members_decls = - resugar_combinators env ed.FStar_Syntax_Syntax.combinators in - let actions = - FStar_Compiler_List.map (fun a -> resugar_action a false) - ed.FStar_Syntax_Syntax.actions in - let decls = - FStar_Compiler_List.op_At mandatory_members_decls actions in - mk_decl r q - (FStar_Parser_AST.NewEffect - (FStar_Parser_AST.DefineEffect - (eff_name, eff_binders2, eff_typ1, decls))) -let (resugar_sigelt' : - FStar_Syntax_DsEnv.env -> - FStar_Syntax_Syntax.sigelt -> - FStar_Parser_AST.decl FStar_Pervasives_Native.option) - = - fun env -> - fun se -> - let d = - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_bundle - { FStar_Syntax_Syntax.ses = ses; - FStar_Syntax_Syntax.lids = uu___;_} - -> - let uu___1 = - FStar_Compiler_List.partition - (fun se1 -> - match se1.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ uu___2 -> true - | FStar_Syntax_Syntax.Sig_declare_typ uu___2 -> true - | FStar_Syntax_Syntax.Sig_datacon uu___2 -> false - | uu___2 -> - failwith - "Found a sigelt which is neither a type declaration or a data constructor in a sigelt") - ses in - (match uu___1 with - | (decl_typ_ses, datacon_ses) -> - let retrieve_datacons_and_resugar uu___2 se1 = - match uu___2 with - | (datacon_ses1, tycons) -> - let uu___3 = resugar_typ env datacon_ses1 se1 in - (match uu___3 with - | (datacon_ses2, tyc) -> - (datacon_ses2, (tyc :: tycons))) in - let uu___2 = - FStar_Compiler_List.fold_left - retrieve_datacons_and_resugar (datacon_ses, []) - decl_typ_ses in - (match uu___2 with - | (leftover_datacons, tycons) -> - (match leftover_datacons with - | [] -> - let uu___3 = - decl'_to_decl se - (FStar_Parser_AST.Tycon (false, false, tycons)) in - FStar_Pervasives_Native.Some uu___3 - | se1::[] -> - (match se1.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = l; - FStar_Syntax_Syntax.us1 = uu___3; - FStar_Syntax_Syntax.t1 = uu___4; - FStar_Syntax_Syntax.ty_lid = uu___5; - FStar_Syntax_Syntax.num_ty_params = uu___6; - FStar_Syntax_Syntax.mutuals1 = uu___7; - FStar_Syntax_Syntax.injective_type_params1 - = uu___8;_} - -> - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Ident.ident_of_lid l in - (uu___12, FStar_Pervasives_Native.None) in - FStar_Parser_AST.Exception uu___11 in - decl'_to_decl se1 uu___10 in - FStar_Pervasives_Native.Some uu___9 - | uu___3 -> - failwith - "wrong format for resguar to Exception") - | uu___3 -> failwith "Should not happen hopefully"))) - | FStar_Syntax_Syntax.Sig_fail uu___ -> FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = lbs; - FStar_Syntax_Syntax.lids1 = uu___;_} - -> - let uu___1 = - FStar_Compiler_Util.for_some - (fun uu___2 -> - match uu___2 with - | FStar_Syntax_Syntax.Projector (uu___3, uu___4) -> true - | FStar_Syntax_Syntax.Discriminator uu___3 -> true - | uu___3 -> false) se.FStar_Syntax_Syntax.sigquals in - if uu___1 - then FStar_Pervasives_Native.None - else - (let mk e = - FStar_Syntax_Syntax.mk e se.FStar_Syntax_Syntax.sigrng in - let dummy = mk FStar_Syntax_Syntax.Tm_unknown in - let nopath_lbs uu___3 = - match uu___3 with - | (is_rec, lbs1) -> - let nopath fv = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = FStar_Syntax_Syntax.lid_of_fv fv in - FStar_Ident.ident_of_lid uu___7 in - [uu___6] in - FStar_Ident.lid_of_ids uu___5 in - FStar_Syntax_Syntax.lid_as_fv uu___4 - FStar_Pervasives_Native.None in - let lbs2 = - FStar_Compiler_List.map - (fun lb -> - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Compiler_Util.right - lb.FStar_Syntax_Syntax.lbname in - nopath uu___6 in - FStar_Pervasives.Inr uu___5 in - { - FStar_Syntax_Syntax.lbname = uu___4; - FStar_Syntax_Syntax.lbunivs = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = - (lb.FStar_Syntax_Syntax.lbtyp); - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = - (lb.FStar_Syntax_Syntax.lbdef); - FStar_Syntax_Syntax.lbattrs = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - }) lbs1 in - (is_rec, lbs2) in - let lbs1 = nopath_lbs lbs in - let desugared_let = - mk - (FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = lbs1; - FStar_Syntax_Syntax.body1 = dummy - }) in - let t = resugar_term' env desugared_let in - match t.FStar_Parser_AST.tm with - | FStar_Parser_AST.Let (isrec, lets, uu___3) -> - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Compiler_List.map - FStar_Pervasives_Native.snd lets in - (isrec, uu___7) in - FStar_Parser_AST.TopLevelLet uu___6 in - decl'_to_decl se uu___5 in - FStar_Pervasives_Native.Some uu___4 - | uu___3 -> failwith "Should not happen hopefully") - | FStar_Syntax_Syntax.Sig_assume - { FStar_Syntax_Syntax.lid3 = lid; - FStar_Syntax_Syntax.us3 = uu___; - FStar_Syntax_Syntax.phi1 = fml;_} - -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Ident.ident_of_lid lid in - let uu___5 = resugar_term' env fml in (uu___4, uu___5) in - FStar_Parser_AST.Assume uu___3 in - decl'_to_decl se uu___2 in - FStar_Pervasives_Native.Some uu___1 - | FStar_Syntax_Syntax.Sig_new_effect ed -> - let a_decl = resugar_eff_decl' env ed in - let q = - FStar_Compiler_List.choose resugar_qualifier - se.FStar_Syntax_Syntax.sigquals in - FStar_Pervasives_Native.Some - { - FStar_Parser_AST.d = (a_decl.FStar_Parser_AST.d); - FStar_Parser_AST.drange = (a_decl.FStar_Parser_AST.drange); - FStar_Parser_AST.quals = q; - FStar_Parser_AST.attrs = (a_decl.FStar_Parser_AST.attrs); - FStar_Parser_AST.interleaved = - (a_decl.FStar_Parser_AST.interleaved) - } - | FStar_Syntax_Syntax.Sig_sub_effect e -> - let src = e.FStar_Syntax_Syntax.source in - let dst = e.FStar_Syntax_Syntax.target in - let lift_wp = - match e.FStar_Syntax_Syntax.lift_wp with - | FStar_Pervasives_Native.Some (uu___, t) -> - let uu___1 = resugar_term' env t in - FStar_Pervasives_Native.Some uu___1 - | uu___ -> FStar_Pervasives_Native.None in - let lift = - match e.FStar_Syntax_Syntax.lift with - | FStar_Pervasives_Native.Some (uu___, t) -> - let uu___1 = resugar_term' env t in - FStar_Pervasives_Native.Some uu___1 - | uu___ -> FStar_Pervasives_Native.None in - let op = - match (lift_wp, lift) with - | (FStar_Pervasives_Native.Some t, - FStar_Pervasives_Native.None) -> - FStar_Parser_AST.NonReifiableLift t - | (FStar_Pervasives_Native.Some wp, - FStar_Pervasives_Native.Some t) -> - FStar_Parser_AST.ReifiableLift (wp, t) - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.Some - t) -> FStar_Parser_AST.LiftForFree t - | uu___ -> failwith "Should not happen hopefully" in - let uu___ = - decl'_to_decl se - (FStar_Parser_AST.SubEffect - { - FStar_Parser_AST.msource = src; - FStar_Parser_AST.mdest = dst; - FStar_Parser_AST.lift_op = op; - FStar_Parser_AST.braced = false - }) in - FStar_Pervasives_Native.Some uu___ - | FStar_Syntax_Syntax.Sig_effect_abbrev - { FStar_Syntax_Syntax.lid4 = lid; FStar_Syntax_Syntax.us4 = vs; - FStar_Syntax_Syntax.bs2 = bs; FStar_Syntax_Syntax.comp1 = c; - FStar_Syntax_Syntax.cflags = flags;_} - -> - let uu___ = FStar_Syntax_Subst.open_comp bs c in - (match uu___ with - | (bs1, c1) -> - let bs2 = filter_imp_bs bs1 in - let bs3 = - FStar_Compiler_List.map - (fun b -> - resugar_binder' env b se.FStar_Syntax_Syntax.sigrng) - bs2 in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = FStar_Ident.ident_of_lid lid in - let uu___8 = resugar_comp' env c1 in - (uu___7, bs3, FStar_Pervasives_Native.None, - uu___8) in - FStar_Parser_AST.TyconAbbrev uu___6 in - [uu___5] in - (false, false, uu___4) in - FStar_Parser_AST.Tycon uu___3 in - decl'_to_decl se uu___2 in - FStar_Pervasives_Native.Some uu___1) - | FStar_Syntax_Syntax.Sig_pragma p -> - let uu___ = - decl'_to_decl se (FStar_Parser_AST.Pragma (resugar_pragma p)) in - FStar_Pervasives_Native.Some uu___ - | FStar_Syntax_Syntax.Sig_declare_typ - { FStar_Syntax_Syntax.lid2 = lid; FStar_Syntax_Syntax.us2 = uvs; - FStar_Syntax_Syntax.t2 = t;_} - -> - let uu___ = - FStar_Compiler_Util.for_some - (fun uu___1 -> - match uu___1 with - | FStar_Syntax_Syntax.Projector (uu___2, uu___3) -> true - | FStar_Syntax_Syntax.Discriminator uu___2 -> true - | uu___2 -> false) se.FStar_Syntax_Syntax.sigquals in - if uu___ - then FStar_Pervasives_Native.None - else - (let t' = - let uu___2 = - (let uu___3 = FStar_Options.print_universes () in - Prims.op_Negation uu___3) || - (FStar_Compiler_List.isEmpty uvs) in - if uu___2 - then resugar_term' env t - else - (let uu___4 = FStar_Syntax_Subst.open_univ_vars uvs t in - match uu___4 with - | (uvs1, t1) -> - let universes = universe_to_string uvs1 in - let uu___5 = resugar_term' env t1 in - label universes uu___5) in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Ident.ident_of_lid lid in - (uu___5, t') in - FStar_Parser_AST.Val uu___4 in - decl'_to_decl se uu___3 in - FStar_Pervasives_Native.Some uu___2) - | FStar_Syntax_Syntax.Sig_splice - { FStar_Syntax_Syntax.is_typed = is_typed; - FStar_Syntax_Syntax.lids2 = ids; FStar_Syntax_Syntax.tac = t;_} - -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Compiler_List.map - (fun l -> FStar_Ident.ident_of_lid l) ids in - let uu___4 = resugar_term' env t in - (is_typed, uu___3, uu___4) in - FStar_Parser_AST.Splice uu___2 in - decl'_to_decl se uu___1 in - FStar_Pervasives_Native.Some uu___ - | FStar_Syntax_Syntax.Sig_inductive_typ uu___ -> - FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Sig_datacon uu___ -> - FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Sig_polymonadic_bind - { FStar_Syntax_Syntax.m_lid = m; FStar_Syntax_Syntax.n_lid = n; - FStar_Syntax_Syntax.p_lid = p; - FStar_Syntax_Syntax.tm3 = (uu___, t); - FStar_Syntax_Syntax.typ = uu___1; - FStar_Syntax_Syntax.kind1 = uu___2;_} - -> - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = resugar_term' env t in (m, n, p, uu___6) in - FStar_Parser_AST.Polymonadic_bind uu___5 in - decl'_to_decl se uu___4 in - FStar_Pervasives_Native.Some uu___3 - | FStar_Syntax_Syntax.Sig_polymonadic_subcomp - { FStar_Syntax_Syntax.m_lid1 = m; FStar_Syntax_Syntax.n_lid1 = n; - FStar_Syntax_Syntax.tm4 = (uu___, t); - FStar_Syntax_Syntax.typ1 = uu___1; - FStar_Syntax_Syntax.kind2 = uu___2;_} - -> - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = resugar_term' env t in (m, n, uu___6) in - FStar_Parser_AST.Polymonadic_subcomp uu___5 in - decl'_to_decl se uu___4 in - FStar_Pervasives_Native.Some uu___3 in - match d with - | FStar_Pervasives_Native.Some d1 -> - let uu___ = - let uu___1 = - FStar_Compiler_List.map (resugar_term' env) - se.FStar_Syntax_Syntax.sigattrs in - { - FStar_Parser_AST.d = (d1.FStar_Parser_AST.d); - FStar_Parser_AST.drange = (d1.FStar_Parser_AST.drange); - FStar_Parser_AST.quals = (d1.FStar_Parser_AST.quals); - FStar_Parser_AST.attrs = uu___1; - FStar_Parser_AST.interleaved = - (d1.FStar_Parser_AST.interleaved) - } in - FStar_Pervasives_Native.Some uu___ - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None -let (empty_env : FStar_Syntax_DsEnv.env) = - FStar_Syntax_DsEnv.empty_env FStar_Parser_Dep.empty_deps -let noenv : 'a . (FStar_Syntax_DsEnv.env -> 'a) -> 'a = fun f -> f empty_env -let (resugar_term : FStar_Syntax_Syntax.term -> FStar_Parser_AST.term) = - fun t -> let uu___ = noenv resugar_term' in uu___ t -let (resugar_sigelt : - FStar_Syntax_Syntax.sigelt -> - FStar_Parser_AST.decl FStar_Pervasives_Native.option) - = fun se -> let uu___ = noenv resugar_sigelt' in uu___ se -let (resugar_comp : FStar_Syntax_Syntax.comp -> FStar_Parser_AST.term) = - fun c -> let uu___ = noenv resugar_comp' in uu___ c -let (resugar_pat : - FStar_Syntax_Syntax.pat -> - FStar_Syntax_Syntax.bv FStar_Compiler_FlatSet.t -> - FStar_Parser_AST.pattern) - = - fun p -> - fun branch_bv -> let uu___ = noenv resugar_pat' in uu___ p branch_bv -let (resugar_binder : - FStar_Syntax_Syntax.binder -> - FStar_Compiler_Range_Type.range -> FStar_Parser_AST.binder) - = fun b -> fun r -> let uu___ = noenv resugar_binder' in uu___ b r -let (resugar_tscheme : FStar_Syntax_Syntax.tscheme -> FStar_Parser_AST.decl) - = fun ts -> let uu___ = noenv resugar_tscheme' in uu___ ts -let (resugar_eff_decl : - FStar_Syntax_Syntax.eff_decl -> FStar_Parser_AST.decl) = - fun ed -> let uu___ = noenv resugar_eff_decl' in uu___ ed \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_Subst.ml b/ocaml/fstar-lib/generated/FStar_Syntax_Subst.ml deleted file mode 100644 index 5ff799423d0..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Syntax_Subst.ml +++ /dev/null @@ -1,1713 +0,0 @@ -open Prims -let subst_to_string : - 'uuuuu . (FStar_Syntax_Syntax.bv * 'uuuuu) Prims.list -> Prims.string = - fun s -> - let uu___ = - FStar_Compiler_List.map - (fun uu___1 -> - match uu___1 with - | (b, uu___2) -> - FStar_Ident.string_of_id b.FStar_Syntax_Syntax.ppname) s in - FStar_Compiler_String.concat ", " uu___ -let rec apply_until_some : - 'uuuuu 'uuuuu1 . - ('uuuuu -> 'uuuuu1 FStar_Pervasives_Native.option) -> - 'uuuuu Prims.list -> - ('uuuuu Prims.list * 'uuuuu1) FStar_Pervasives_Native.option - = - fun f -> - fun s -> - match s with - | [] -> FStar_Pervasives_Native.None - | s0::rest -> - let uu___ = f s0 in - (match uu___ with - | FStar_Pervasives_Native.None -> apply_until_some f rest - | FStar_Pervasives_Native.Some st -> - FStar_Pervasives_Native.Some (rest, st)) -let map_some_curry : - 'uuuuu 'uuuuu1 'uuuuu2 . - ('uuuuu -> 'uuuuu1 -> 'uuuuu2) -> - 'uuuuu2 -> ('uuuuu * 'uuuuu1) FStar_Pervasives_Native.option -> 'uuuuu2 - = - fun f -> - fun x -> - fun uu___ -> - match uu___ with - | FStar_Pervasives_Native.None -> x - | FStar_Pervasives_Native.Some (a, b) -> f a b -let apply_until_some_then_map : - 'uuuuu 'uuuuu1 'uuuuu2 . - ('uuuuu -> 'uuuuu1 FStar_Pervasives_Native.option) -> - 'uuuuu Prims.list -> - ('uuuuu Prims.list -> 'uuuuu1 -> 'uuuuu2) -> 'uuuuu2 -> 'uuuuu2 - = - fun f -> - fun s -> - fun g -> - fun t -> let uu___ = apply_until_some f s in map_some_curry g t uu___ -let compose_subst : - 'uuuuu . - ('uuuuu Prims.list * FStar_Syntax_Syntax.maybe_set_use_range) -> - ('uuuuu Prims.list * FStar_Syntax_Syntax.maybe_set_use_range) -> - ('uuuuu Prims.list * FStar_Syntax_Syntax.maybe_set_use_range) - = - fun s1 -> - fun s2 -> - let s = - FStar_Compiler_List.op_At (FStar_Pervasives_Native.fst s1) - (FStar_Pervasives_Native.fst s2) in - let ropt = - match FStar_Pervasives_Native.snd s2 with - | FStar_Syntax_Syntax.SomeUseRange uu___ -> - FStar_Pervasives_Native.snd s2 - | uu___ -> FStar_Pervasives_Native.snd s1 in - (s, ropt) -let (delay : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - (FStar_Syntax_Syntax.subst_elt Prims.list Prims.list * - FStar_Syntax_Syntax.maybe_set_use_range) -> FStar_Syntax_Syntax.term) - = - fun t -> - fun s -> - match t.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_delayed - { FStar_Syntax_Syntax.tm1 = t'; FStar_Syntax_Syntax.substs = s';_} - -> - FStar_Syntax_Syntax.mk_Tm_delayed (t', (compose_subst s' s)) - t.FStar_Syntax_Syntax.pos - | uu___ -> - FStar_Syntax_Syntax.mk_Tm_delayed (t, s) t.FStar_Syntax_Syntax.pos -let rec (force_uvar' : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - (FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * Prims.bool)) - = - fun t -> - match t.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_uvar - ({ FStar_Syntax_Syntax.ctx_uvar_head = uv; - FStar_Syntax_Syntax.ctx_uvar_gamma = uu___; - FStar_Syntax_Syntax.ctx_uvar_binders = uu___1; - FStar_Syntax_Syntax.ctx_uvar_reason = uu___2; - FStar_Syntax_Syntax.ctx_uvar_range = uu___3; - FStar_Syntax_Syntax.ctx_uvar_meta = uu___4;_}, - s) - -> - let uu___5 = FStar_Syntax_Unionfind.find uv in - (match uu___5 with - | FStar_Pervasives_Native.Some t' -> - let uu___6 = - let uu___7 = let uu___8 = delay t' s in force_uvar' uu___8 in - FStar_Pervasives_Native.fst uu___7 in - (uu___6, true) - | uu___6 -> (t, false)) - | uu___ -> (t, false) -let (force_uvar : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun t -> - let uu___ = force_uvar' t in - match uu___ with - | (t', forced) -> - if forced - then - delay t' - ([], - (FStar_Syntax_Syntax.SomeUseRange (t.FStar_Syntax_Syntax.pos))) - else t -let rec (compress_univ : - FStar_Syntax_Syntax.universe -> FStar_Syntax_Syntax.universe) = - fun u -> - match u with - | FStar_Syntax_Syntax.U_unif u' -> - let uu___ = FStar_Syntax_Unionfind.univ_find u' in - (match uu___ with - | FStar_Pervasives_Native.Some u1 -> compress_univ u1 - | uu___1 -> u) - | uu___ -> u -let (subst_bv : - FStar_Syntax_Syntax.bv -> - FStar_Syntax_Syntax.subst_elt Prims.list -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - FStar_Pervasives_Native.option) - = - fun a -> - fun s -> - FStar_Compiler_Util.find_map s - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.DB (i, x) when - i = a.FStar_Syntax_Syntax.index -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.range_of_bv a in - FStar_Syntax_Syntax.set_range_of_bv x uu___3 in - FStar_Syntax_Syntax.bv_to_name uu___2 in - FStar_Pervasives_Native.Some uu___1 - | FStar_Syntax_Syntax.DT (i, t) when - i = a.FStar_Syntax_Syntax.index -> - FStar_Pervasives_Native.Some t - | uu___1 -> FStar_Pervasives_Native.None) -let (subst_nm : - FStar_Syntax_Syntax.bv -> - FStar_Syntax_Syntax.subst_elt Prims.list -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - FStar_Pervasives_Native.option) - = - fun a -> - fun s -> - FStar_Compiler_Util.find_map s - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.NM (x, i) when FStar_Syntax_Syntax.bv_eq a x - -> - let uu___1 = - FStar_Syntax_Syntax.bv_to_tm - { - FStar_Syntax_Syntax.ppname = - (a.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = i; - FStar_Syntax_Syntax.sort = (a.FStar_Syntax_Syntax.sort) - } in - FStar_Pervasives_Native.Some uu___1 - | FStar_Syntax_Syntax.NT (x, t) when FStar_Syntax_Syntax.bv_eq a x - -> FStar_Pervasives_Native.Some t - | uu___1 -> FStar_Pervasives_Native.None) -let (subst_univ_bv : - Prims.int -> - FStar_Syntax_Syntax.subst_elt Prims.list -> - FStar_Syntax_Syntax.universe FStar_Pervasives_Native.option) - = - fun x -> - fun s -> - FStar_Compiler_Util.find_map s - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.UN (y, t) when x = y -> - FStar_Pervasives_Native.Some t - | uu___1 -> FStar_Pervasives_Native.None) -let (subst_univ_nm : - FStar_Syntax_Syntax.univ_name -> - FStar_Syntax_Syntax.subst_elt Prims.list -> - FStar_Syntax_Syntax.universe FStar_Pervasives_Native.option) - = - fun x -> - fun s -> - FStar_Compiler_Util.find_map s - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.UD (y, i) when FStar_Ident.ident_equals x y - -> FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.U_bvar i) - | uu___1 -> FStar_Pervasives_Native.None) -let rec (subst_univ : - FStar_Syntax_Syntax.subst_elt Prims.list Prims.list -> - FStar_Syntax_Syntax.universe -> FStar_Syntax_Syntax.universe) - = - fun s -> - fun u -> - let u1 = compress_univ u in - match u1 with - | FStar_Syntax_Syntax.U_bvar x -> - apply_until_some_then_map (subst_univ_bv x) s subst_univ u1 - | FStar_Syntax_Syntax.U_name x -> - apply_until_some_then_map (subst_univ_nm x) s subst_univ u1 - | FStar_Syntax_Syntax.U_zero -> u1 - | FStar_Syntax_Syntax.U_unknown -> u1 - | FStar_Syntax_Syntax.U_unif uu___ -> u1 - | FStar_Syntax_Syntax.U_succ u2 -> - let uu___ = subst_univ s u2 in FStar_Syntax_Syntax.U_succ uu___ - | FStar_Syntax_Syntax.U_max us -> - let uu___ = FStar_Compiler_List.map (subst_univ s) us in - FStar_Syntax_Syntax.U_max uu___ -let tag_with_range : - 'uuuuu . - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - ('uuuuu * FStar_Syntax_Syntax.maybe_set_use_range) -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - = - fun t -> - fun s -> - match FStar_Pervasives_Native.snd s with - | FStar_Syntax_Syntax.NoUseRange -> t - | FStar_Syntax_Syntax.SomeUseRange r -> - let uu___ = - let uu___1 = - FStar_Compiler_Range_Type.use_range t.FStar_Syntax_Syntax.pos in - let uu___2 = FStar_Compiler_Range_Type.use_range r in - FStar_Compiler_Range_Ops.rng_included uu___1 uu___2 in - if uu___ - then t - else - (let r1 = - let uu___2 = FStar_Compiler_Range_Type.use_range r in - FStar_Compiler_Range_Type.set_use_range - t.FStar_Syntax_Syntax.pos uu___2 in - let t' = - match t.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_bvar bv -> - let uu___2 = FStar_Syntax_Syntax.set_range_of_bv bv r1 in - FStar_Syntax_Syntax.Tm_bvar uu___2 - | FStar_Syntax_Syntax.Tm_name bv -> - let uu___2 = FStar_Syntax_Syntax.set_range_of_bv bv r1 in - FStar_Syntax_Syntax.Tm_name uu___2 - | FStar_Syntax_Syntax.Tm_fvar fv -> - let l = FStar_Syntax_Syntax.lid_of_fv fv in - let v = - let uu___2 = fv.FStar_Syntax_Syntax.fv_name in - let uu___3 = FStar_Ident.set_lid_range l r1 in - { - FStar_Syntax_Syntax.v = uu___3; - FStar_Syntax_Syntax.p = (uu___2.FStar_Syntax_Syntax.p) - } in - let fv1 = - { - FStar_Syntax_Syntax.fv_name = v; - FStar_Syntax_Syntax.fv_qual = - (fv.FStar_Syntax_Syntax.fv_qual) - } in - FStar_Syntax_Syntax.Tm_fvar fv1 - | t'1 -> t'1 in - { - FStar_Syntax_Syntax.n = t'; - FStar_Syntax_Syntax.pos = r1; - FStar_Syntax_Syntax.vars = (t.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (t.FStar_Syntax_Syntax.hash_code) - }) -let tag_lid_with_range : - 'uuuuu . - FStar_Ident.lident -> - ('uuuuu * FStar_Syntax_Syntax.maybe_set_use_range) -> - FStar_Ident.lident - = - fun l -> - fun s -> - match FStar_Pervasives_Native.snd s with - | FStar_Syntax_Syntax.NoUseRange -> l - | FStar_Syntax_Syntax.SomeUseRange r -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Ident.range_of_lid l in - FStar_Compiler_Range_Type.use_range uu___2 in - let uu___2 = FStar_Compiler_Range_Type.use_range r in - FStar_Compiler_Range_Ops.rng_included uu___1 uu___2 in - if uu___ - then l - else - (let uu___2 = - let uu___3 = FStar_Ident.range_of_lid l in - let uu___4 = FStar_Compiler_Range_Type.use_range r in - FStar_Compiler_Range_Type.set_use_range uu___3 uu___4 in - FStar_Ident.set_lid_range l uu___2) -let (mk_range : - FStar_Compiler_Range_Type.range -> - FStar_Syntax_Syntax.subst_ts -> FStar_Compiler_Range_Type.range) - = - fun r -> - fun s -> - match FStar_Pervasives_Native.snd s with - | FStar_Syntax_Syntax.NoUseRange -> r - | FStar_Syntax_Syntax.SomeUseRange r' -> - let uu___ = - let uu___1 = FStar_Compiler_Range_Type.use_range r in - let uu___2 = FStar_Compiler_Range_Type.use_range r' in - FStar_Compiler_Range_Ops.rng_included uu___1 uu___2 in - if uu___ - then r - else - (let uu___2 = FStar_Compiler_Range_Type.use_range r' in - FStar_Compiler_Range_Type.set_use_range r uu___2) -let rec (subst' : - FStar_Syntax_Syntax.subst_ts -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun s -> - fun t -> - let subst_tail tl = subst' (tl, (FStar_Pervasives_Native.snd s)) in - match s with - | ([], FStar_Syntax_Syntax.NoUseRange) -> t - | ([]::[], FStar_Syntax_Syntax.NoUseRange) -> t - | uu___ -> - let t0 = t in - (match t0.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_unknown -> tag_with_range t0 s - | FStar_Syntax_Syntax.Tm_constant uu___1 -> tag_with_range t0 s - | FStar_Syntax_Syntax.Tm_fvar uu___1 -> tag_with_range t0 s - | FStar_Syntax_Syntax.Tm_delayed - { FStar_Syntax_Syntax.tm1 = t'; - FStar_Syntax_Syntax.substs = s';_} - -> - FStar_Syntax_Syntax.mk_Tm_delayed (t', (compose_subst s' s)) - t.FStar_Syntax_Syntax.pos - | FStar_Syntax_Syntax.Tm_bvar a -> - apply_until_some_then_map (subst_bv a) - (FStar_Pervasives_Native.fst s) subst_tail t0 - | FStar_Syntax_Syntax.Tm_name a -> - apply_until_some_then_map (subst_nm a) - (FStar_Pervasives_Native.fst s) subst_tail t0 - | FStar_Syntax_Syntax.Tm_type u -> - let uu___1 = - let uu___2 = subst_univ (FStar_Pervasives_Native.fst s) u in - FStar_Syntax_Syntax.Tm_type uu___2 in - let uu___2 = mk_range t0.FStar_Syntax_Syntax.pos s in - FStar_Syntax_Syntax.mk uu___1 uu___2 - | uu___1 -> - let uu___2 = mk_range t.FStar_Syntax_Syntax.pos s in - FStar_Syntax_Syntax.mk_Tm_delayed (t0, s) uu___2) -let (subst_dec_order' : - FStar_Syntax_Syntax.subst_ts -> - FStar_Syntax_Syntax.decreases_order -> - FStar_Syntax_Syntax.decreases_order) - = - fun s -> - fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.Decreases_lex l -> - let uu___1 = FStar_Compiler_List.map (subst' s) l in - FStar_Syntax_Syntax.Decreases_lex uu___1 - | FStar_Syntax_Syntax.Decreases_wf (rel, e) -> - let uu___1 = - let uu___2 = subst' s rel in - let uu___3 = subst' s e in (uu___2, uu___3) in - FStar_Syntax_Syntax.Decreases_wf uu___1 -let (subst_flags' : - FStar_Syntax_Syntax.subst_ts -> - FStar_Syntax_Syntax.cflag Prims.list -> - FStar_Syntax_Syntax.cflag Prims.list) - = - fun s -> - fun flags -> - FStar_Compiler_List.map - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.DECREASES dec_order -> - let uu___1 = subst_dec_order' s dec_order in - FStar_Syntax_Syntax.DECREASES uu___1 - | f -> f) flags -let (subst_bqual' : - FStar_Syntax_Syntax.subst_ts -> - FStar_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option) - = - fun s -> - fun i -> - match i with - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta t) -> - let uu___ = - let uu___1 = subst' s t in FStar_Syntax_Syntax.Meta uu___1 in - FStar_Pervasives_Native.Some uu___ - | uu___ -> i -let (subst_aqual' : - FStar_Syntax_Syntax.subst_ts -> - FStar_Syntax_Syntax.aqual -> FStar_Syntax_Syntax.aqual) - = - fun s -> - fun i -> - match i with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some a -> - let uu___ = - let uu___1 = - FStar_Compiler_List.map (subst' s) - a.FStar_Syntax_Syntax.aqual_attributes in - { - FStar_Syntax_Syntax.aqual_implicit = - (a.FStar_Syntax_Syntax.aqual_implicit); - FStar_Syntax_Syntax.aqual_attributes = uu___1 - } in - FStar_Pervasives_Native.Some uu___ -let (subst_comp_typ' : - (FStar_Syntax_Syntax.subst_elt Prims.list Prims.list * - FStar_Syntax_Syntax.maybe_set_use_range) -> - FStar_Syntax_Syntax.comp_typ -> FStar_Syntax_Syntax.comp_typ) - = - fun s -> - fun t -> - match s with - | ([], FStar_Syntax_Syntax.NoUseRange) -> t - | ([]::[], FStar_Syntax_Syntax.NoUseRange) -> t - | uu___ -> - let uu___1 = - FStar_Compiler_List.map - (subst_univ (FStar_Pervasives_Native.fst s)) - t.FStar_Syntax_Syntax.comp_univs in - let uu___2 = tag_lid_with_range t.FStar_Syntax_Syntax.effect_name s in - let uu___3 = subst' s t.FStar_Syntax_Syntax.result_typ in - let uu___4 = - FStar_Compiler_List.map - (fun uu___5 -> - match uu___5 with - | (t1, imp) -> - let uu___6 = subst' s t1 in - let uu___7 = subst_aqual' s imp in (uu___6, uu___7)) - t.FStar_Syntax_Syntax.effect_args in - let uu___5 = subst_flags' s t.FStar_Syntax_Syntax.flags in - { - FStar_Syntax_Syntax.comp_univs = uu___1; - FStar_Syntax_Syntax.effect_name = uu___2; - FStar_Syntax_Syntax.result_typ = uu___3; - FStar_Syntax_Syntax.effect_args = uu___4; - FStar_Syntax_Syntax.flags = uu___5 - } -let (subst_comp' : - (FStar_Syntax_Syntax.subst_elt Prims.list Prims.list * - FStar_Syntax_Syntax.maybe_set_use_range) -> - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax) - = - fun s -> - fun t -> - match s with - | ([], FStar_Syntax_Syntax.NoUseRange) -> t - | ([]::[], FStar_Syntax_Syntax.NoUseRange) -> t - | uu___ -> - (match t.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total t1 -> - let uu___1 = subst' s t1 in - FStar_Syntax_Syntax.mk_Total uu___1 - | FStar_Syntax_Syntax.GTotal t1 -> - let uu___1 = subst' s t1 in - FStar_Syntax_Syntax.mk_GTotal uu___1 - | FStar_Syntax_Syntax.Comp ct -> - let uu___1 = subst_comp_typ' s ct in - FStar_Syntax_Syntax.mk_Comp uu___1) -let (subst_ascription' : - FStar_Syntax_Syntax.subst_ts -> - FStar_Syntax_Syntax.ascription -> - ((FStar_Syntax_Syntax.term, - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax) - FStar_Pervasives.either * FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option * Prims.bool)) - = - fun s -> - fun asc -> - let uu___ = asc in - match uu___ with - | (annot, topt, use_eq) -> - let annot1 = - match annot with - | FStar_Pervasives.Inl t -> - let uu___1 = subst' s t in FStar_Pervasives.Inl uu___1 - | FStar_Pervasives.Inr c -> - let uu___1 = subst_comp' s c in FStar_Pervasives.Inr uu___1 in - let uu___1 = FStar_Compiler_Util.map_opt topt (subst' s) in - (annot1, uu___1, use_eq) -let (shift : - Prims.int -> FStar_Syntax_Syntax.subst_elt -> FStar_Syntax_Syntax.subst_elt) - = - fun n -> - fun s -> - match s with - | FStar_Syntax_Syntax.DB (i, t) -> FStar_Syntax_Syntax.DB ((i + n), t) - | FStar_Syntax_Syntax.DT (i, t) -> FStar_Syntax_Syntax.DT ((i + n), t) - | FStar_Syntax_Syntax.UN (i, t) -> FStar_Syntax_Syntax.UN ((i + n), t) - | FStar_Syntax_Syntax.NM (x, i) -> FStar_Syntax_Syntax.NM (x, (i + n)) - | FStar_Syntax_Syntax.UD (x, i) -> FStar_Syntax_Syntax.UD (x, (i + n)) - | FStar_Syntax_Syntax.NT uu___ -> s -let (shift_subst : - Prims.int -> FStar_Syntax_Syntax.subst_t -> FStar_Syntax_Syntax.subst_t) = - fun n -> fun s -> FStar_Compiler_List.map (shift n) s -let shift_subst' : - 'uuuuu . - Prims.int -> - (FStar_Syntax_Syntax.subst_t Prims.list * 'uuuuu) -> - (FStar_Syntax_Syntax.subst_t Prims.list * 'uuuuu) - = - fun n -> - fun s -> - let uu___ = - FStar_Compiler_List.map (shift_subst n) - (FStar_Pervasives_Native.fst s) in - (uu___, (FStar_Pervasives_Native.snd s)) -let (subst_binder' : - FStar_Syntax_Syntax.subst_ts -> - FStar_Syntax_Syntax.binder -> FStar_Syntax_Syntax.binder) - = - fun s -> - fun b -> - let uu___ = - let uu___1 = b.FStar_Syntax_Syntax.binder_bv in - let uu___2 = - subst' s (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - { - FStar_Syntax_Syntax.ppname = (uu___1.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = (uu___1.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = uu___2 - } in - let uu___1 = subst_bqual' s b.FStar_Syntax_Syntax.binder_qual in - let uu___2 = - FStar_Compiler_List.map (subst' s) b.FStar_Syntax_Syntax.binder_attrs in - FStar_Syntax_Syntax.mk_binder_with_attrs uu___ uu___1 - b.FStar_Syntax_Syntax.binder_positivity uu___2 -let (subst_binder : - FStar_Syntax_Syntax.subst_elt Prims.list -> - FStar_Syntax_Syntax.binder -> FStar_Syntax_Syntax.binder) - = fun s -> fun b -> subst_binder' ([s], FStar_Syntax_Syntax.NoUseRange) b -let (subst_binders' : - (FStar_Syntax_Syntax.subst_elt Prims.list Prims.list * - FStar_Syntax_Syntax.maybe_set_use_range) -> - FStar_Syntax_Syntax.binder Prims.list -> - FStar_Syntax_Syntax.binder Prims.list) - = - fun s -> - fun bs -> - FStar_Compiler_List.mapi - (fun i -> - fun b -> - if i = Prims.int_zero - then subst_binder' s b - else (let uu___1 = shift_subst' i s in subst_binder' uu___1 b)) - bs -let (subst_binders : - FStar_Syntax_Syntax.subst_elt Prims.list -> - FStar_Syntax_Syntax.binders -> FStar_Syntax_Syntax.binders) - = - fun s -> fun bs -> subst_binders' ([s], FStar_Syntax_Syntax.NoUseRange) bs -let subst_arg' : - 'uuuuu . - FStar_Syntax_Syntax.subst_ts -> - (FStar_Syntax_Syntax.term * 'uuuuu) -> - (FStar_Syntax_Syntax.term * 'uuuuu) - = - fun s -> - fun uu___ -> - match uu___ with | (t, imp) -> let uu___1 = subst' s t in (uu___1, imp) -let subst_args' : - 'uuuuu . - FStar_Syntax_Syntax.subst_ts -> - (FStar_Syntax_Syntax.term * 'uuuuu) Prims.list -> - (FStar_Syntax_Syntax.term * 'uuuuu) Prims.list - = fun s -> FStar_Compiler_List.map (subst_arg' s) -let (subst_univs_opt : - FStar_Syntax_Syntax.subst_elt Prims.list Prims.list -> - FStar_Syntax_Syntax.universe Prims.list FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.universe Prims.list FStar_Pervasives_Native.option) - = - fun sub -> - fun us_opt -> - match us_opt with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some us -> - let uu___ = FStar_Compiler_List.map (subst_univ sub) us in - FStar_Pervasives_Native.Some uu___ -let (subst_pat' : - (FStar_Syntax_Syntax.subst_t Prims.list * - FStar_Syntax_Syntax.maybe_set_use_range) -> - FStar_Syntax_Syntax.pat' FStar_Syntax_Syntax.withinfo_t -> - (FStar_Syntax_Syntax.pat * Prims.int)) - = - fun s -> - fun p -> - let rec aux n p1 = - match p1.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_constant uu___ -> (p1, n) - | FStar_Syntax_Syntax.Pat_cons (fv, us_opt, pats) -> - let us_opt1 = - let uu___ = - let uu___1 = shift_subst' n s in - FStar_Pervasives_Native.fst uu___1 in - subst_univs_opt uu___ us_opt in - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun uu___2 -> - match (uu___1, uu___2) with - | ((pats1, n1), (p2, imp)) -> - let uu___3 = aux n1 p2 in - (match uu___3 with - | (p3, m) -> (((p3, imp) :: pats1), m))) ([], n) - pats in - (match uu___ with - | (pats1, n1) -> - ({ - FStar_Syntax_Syntax.v = - (FStar_Syntax_Syntax.Pat_cons - (fv, us_opt1, (FStar_Compiler_List.rev pats1))); - FStar_Syntax_Syntax.p = (p1.FStar_Syntax_Syntax.p) - }, n1)) - | FStar_Syntax_Syntax.Pat_var x -> - let s1 = shift_subst' n s in - let x1 = - let uu___ = subst' s1 x.FStar_Syntax_Syntax.sort in - { - FStar_Syntax_Syntax.ppname = (x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = (x.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = uu___ - } in - ({ - FStar_Syntax_Syntax.v = (FStar_Syntax_Syntax.Pat_var x1); - FStar_Syntax_Syntax.p = (p1.FStar_Syntax_Syntax.p) - }, (n + Prims.int_one)) - | FStar_Syntax_Syntax.Pat_dot_term eopt -> - let s1 = shift_subst' n s in - let eopt1 = FStar_Compiler_Util.map_option (subst' s1) eopt in - ({ - FStar_Syntax_Syntax.v = - (FStar_Syntax_Syntax.Pat_dot_term eopt1); - FStar_Syntax_Syntax.p = (p1.FStar_Syntax_Syntax.p) - }, n) in - aux Prims.int_zero p -let (push_subst_lcomp : - FStar_Syntax_Syntax.subst_ts -> - FStar_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option) - = - fun s -> - fun lopt -> - match lopt with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some rc -> - let residual_typ = - FStar_Compiler_Util.map_opt rc.FStar_Syntax_Syntax.residual_typ - (subst' s) in - let rc1 = - { - FStar_Syntax_Syntax.residual_effect = - (rc.FStar_Syntax_Syntax.residual_effect); - FStar_Syntax_Syntax.residual_typ = residual_typ; - FStar_Syntax_Syntax.residual_flags = - (rc.FStar_Syntax_Syntax.residual_flags) - } in - FStar_Pervasives_Native.Some rc1 -let (compose_uvar_subst : - FStar_Syntax_Syntax.ctx_uvar -> - FStar_Syntax_Syntax.subst_ts -> - FStar_Syntax_Syntax.subst_ts -> FStar_Syntax_Syntax.subst_ts) - = - fun u -> - fun s0 -> - fun s -> - let should_retain x = - FStar_Compiler_Util.for_some - (fun b -> - FStar_Syntax_Syntax.bv_eq x b.FStar_Syntax_Syntax.binder_bv) - u.FStar_Syntax_Syntax.ctx_uvar_binders in - let rec aux uu___ = - match uu___ with - | [] -> [] - | hd_subst::rest -> - let hd = - FStar_Compiler_List.collect - (fun uu___1 -> - match uu___1 with - | FStar_Syntax_Syntax.NT (x, t) -> - let uu___2 = should_retain x in - if uu___2 - then - let uu___3 = - let uu___4 = - let uu___5 = - delay t - (rest, FStar_Syntax_Syntax.NoUseRange) in - (x, uu___5) in - FStar_Syntax_Syntax.NT uu___4 in - [uu___3] - else [] - | FStar_Syntax_Syntax.NM (x, i) -> - let uu___2 = should_retain x in - if uu___2 - then - let x_i = - FStar_Syntax_Syntax.bv_to_tm - { - FStar_Syntax_Syntax.ppname = - (x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = i; - FStar_Syntax_Syntax.sort = - (x.FStar_Syntax_Syntax.sort) - } in - let t = - subst' (rest, FStar_Syntax_Syntax.NoUseRange) - x_i in - (match t.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_bvar x_j -> - [FStar_Syntax_Syntax.NM - (x, (x_j.FStar_Syntax_Syntax.index))] - | uu___3 -> [FStar_Syntax_Syntax.NT (x, t)]) - else [] - | uu___2 -> []) hd_subst in - let uu___1 = aux rest in FStar_Compiler_List.op_At hd uu___1 in - let uu___ = - aux - (FStar_Compiler_List.op_At (FStar_Pervasives_Native.fst s0) - (FStar_Pervasives_Native.fst s)) in - match uu___ with - | [] -> ([], (FStar_Pervasives_Native.snd s)) - | s' -> ([s'], (FStar_Pervasives_Native.snd s)) -let rec (push_subst_aux : - Prims.bool -> - FStar_Syntax_Syntax.subst_ts -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun resolve_uvars -> - fun s -> - fun t -> - let mk t' = - let uu___ = mk_range t.FStar_Syntax_Syntax.pos s in - FStar_Syntax_Syntax.mk t' uu___ in - match t.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_delayed uu___ -> - failwith "Impossible (delayed node in push_subst)" - | FStar_Syntax_Syntax.Tm_lazy i -> - (match i.FStar_Syntax_Syntax.lkind with - | FStar_Syntax_Syntax.Lazy_embedding uu___ -> - let t1 = - let uu___1 = - let uu___2 = - FStar_Compiler_Effect.op_Bang - FStar_Syntax_Syntax.lazy_chooser in - FStar_Compiler_Util.must uu___2 in - uu___1 i.FStar_Syntax_Syntax.lkind i in - push_subst_aux resolve_uvars s t1 - | uu___ -> tag_with_range t s) - | FStar_Syntax_Syntax.Tm_constant uu___ -> tag_with_range t s - | FStar_Syntax_Syntax.Tm_fvar uu___ -> tag_with_range t s - | FStar_Syntax_Syntax.Tm_unknown -> tag_with_range t s - | FStar_Syntax_Syntax.Tm_uvar (uv, s0) -> - let fallback uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = compose_uvar_subst uv s0 s in (uv, uu___4) in - FStar_Syntax_Syntax.Tm_uvar uu___3 in - { - FStar_Syntax_Syntax.n = uu___2; - FStar_Syntax_Syntax.pos = (t.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = (t.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (t.FStar_Syntax_Syntax.hash_code) - } in - tag_with_range uu___1 s in - if Prims.op_Negation resolve_uvars - then fallback () - else - (let uu___1 = - FStar_Syntax_Unionfind.find - uv.FStar_Syntax_Syntax.ctx_uvar_head in - match uu___1 with - | FStar_Pervasives_Native.None -> fallback () - | FStar_Pervasives_Native.Some t1 -> - push_subst_aux resolve_uvars (compose_subst s0 s) t1) - | FStar_Syntax_Syntax.Tm_type uu___ -> subst' s t - | FStar_Syntax_Syntax.Tm_bvar uu___ -> subst' s t - | FStar_Syntax_Syntax.Tm_name uu___ -> subst' s t - | FStar_Syntax_Syntax.Tm_uinst (t', us) -> - let us1 = - FStar_Compiler_List.map - (subst_univ (FStar_Pervasives_Native.fst s)) us in - let uu___ = mk (FStar_Syntax_Syntax.Tm_uinst (t', us1)) in - tag_with_range uu___ s - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = t0; FStar_Syntax_Syntax.args = args;_} - -> - let uu___ = - let uu___1 = - let uu___2 = subst' s t0 in - let uu___3 = subst_args' s args in - { - FStar_Syntax_Syntax.hd = uu___2; - FStar_Syntax_Syntax.args = uu___3 - } in - FStar_Syntax_Syntax.Tm_app uu___1 in - mk uu___ - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t0; FStar_Syntax_Syntax.asc = asc; - FStar_Syntax_Syntax.eff_opt = lopt;_} - -> - let uu___ = - let uu___1 = - let uu___2 = subst' s t0 in - let uu___3 = subst_ascription' s asc in - { - FStar_Syntax_Syntax.tm = uu___2; - FStar_Syntax_Syntax.asc = uu___3; - FStar_Syntax_Syntax.eff_opt = lopt - } in - FStar_Syntax_Syntax.Tm_ascribed uu___1 in - mk uu___ - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs; FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = lopt;_} - -> - let n = FStar_Compiler_List.length bs in - let s' = shift_subst' n s in - let uu___ = - let uu___1 = - let uu___2 = subst_binders' s bs in - let uu___3 = subst' s' body in - let uu___4 = push_subst_lcomp s' lopt in - { - FStar_Syntax_Syntax.bs = uu___2; - FStar_Syntax_Syntax.body = uu___3; - FStar_Syntax_Syntax.rc_opt = uu___4 - } in - FStar_Syntax_Syntax.Tm_abs uu___1 in - mk uu___ - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; - FStar_Syntax_Syntax.comp = comp;_} - -> - let n = FStar_Compiler_List.length bs in - let uu___ = - let uu___1 = - let uu___2 = subst_binders' s bs in - let uu___3 = - let uu___4 = shift_subst' n s in subst_comp' uu___4 comp in - { - FStar_Syntax_Syntax.bs1 = uu___2; - FStar_Syntax_Syntax.comp = uu___3 - } in - FStar_Syntax_Syntax.Tm_arrow uu___1 in - mk uu___ - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x; FStar_Syntax_Syntax.phi = phi;_} -> - let x1 = - let uu___ = subst' s x.FStar_Syntax_Syntax.sort in - { - FStar_Syntax_Syntax.ppname = (x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = (x.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = uu___ - } in - let phi1 = - let uu___ = shift_subst' Prims.int_one s in subst' uu___ phi in - mk - (FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x1; FStar_Syntax_Syntax.phi = phi1 - }) - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = t0; - FStar_Syntax_Syntax.ret_opt = asc_opt; - FStar_Syntax_Syntax.brs = pats; - FStar_Syntax_Syntax.rc_opt1 = lopt;_} - -> - let t01 = subst' s t0 in - let pats1 = - FStar_Compiler_List.map - (fun uu___ -> - match uu___ with - | (pat, wopt, branch) -> - let uu___1 = subst_pat' s pat in - (match uu___1 with - | (pat1, n) -> - let s1 = shift_subst' n s in - let wopt1 = - match wopt with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some w -> - let uu___2 = subst' s1 w in - FStar_Pervasives_Native.Some uu___2 in - let branch1 = subst' s1 branch in - (pat1, wopt1, branch1))) pats in - let asc_opt1 = - match asc_opt with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (b, asc) -> - let b1 = subst_binder' s b in - let asc1 = - let uu___ = shift_subst' Prims.int_one s in - subst_ascription' uu___ asc in - FStar_Pervasives_Native.Some (b1, asc1) in - let uu___ = - let uu___1 = - let uu___2 = push_subst_lcomp s lopt in - { - FStar_Syntax_Syntax.scrutinee = t01; - FStar_Syntax_Syntax.ret_opt = asc_opt1; - FStar_Syntax_Syntax.brs = pats1; - FStar_Syntax_Syntax.rc_opt1 = uu___2 - } in - FStar_Syntax_Syntax.Tm_match uu___1 in - mk uu___ - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (is_rec, lbs); - FStar_Syntax_Syntax.body1 = body;_} - -> - let n = FStar_Compiler_List.length lbs in - let sn = shift_subst' n s in - let body1 = subst' sn body in - let lbs1 = - FStar_Compiler_List.map - (fun lb -> - let lbt = subst' s lb.FStar_Syntax_Syntax.lbtyp in - let lbd = - let uu___ = - is_rec && - (FStar_Compiler_Util.is_left - lb.FStar_Syntax_Syntax.lbname) in - if uu___ - then subst' sn lb.FStar_Syntax_Syntax.lbdef - else subst' s lb.FStar_Syntax_Syntax.lbdef in - let lbname = - match lb.FStar_Syntax_Syntax.lbname with - | FStar_Pervasives.Inl x -> - FStar_Pervasives.Inl - { - FStar_Syntax_Syntax.ppname = - (x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (x.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = lbt - } - | FStar_Pervasives.Inr fv -> FStar_Pervasives.Inr fv in - let lbattrs = - FStar_Compiler_List.map (subst' s) - lb.FStar_Syntax_Syntax.lbattrs in - { - FStar_Syntax_Syntax.lbname = lbname; - FStar_Syntax_Syntax.lbunivs = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = lbt; - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = lbd; - FStar_Syntax_Syntax.lbattrs = lbattrs; - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - }) lbs in - mk - (FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = (is_rec, lbs1); - FStar_Syntax_Syntax.body1 = body1 - }) - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t0; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_pattern - (bs, ps);_} - -> - let uu___ = - let uu___1 = - let uu___2 = subst' s t0 in - let uu___3 = - let uu___4 = - let uu___5 = FStar_Compiler_List.map (subst' s) bs in - let uu___6 = FStar_Compiler_List.map (subst_args' s) ps in - (uu___5, uu___6) in - FStar_Syntax_Syntax.Meta_pattern uu___4 in - { - FStar_Syntax_Syntax.tm2 = uu___2; - FStar_Syntax_Syntax.meta = uu___3 - } in - FStar_Syntax_Syntax.Tm_meta uu___1 in - mk uu___ - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t0; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_monadic - (m, t1);_} - -> - let uu___ = - let uu___1 = - let uu___2 = subst' s t0 in - let uu___3 = - let uu___4 = let uu___5 = subst' s t1 in (m, uu___5) in - FStar_Syntax_Syntax.Meta_monadic uu___4 in - { - FStar_Syntax_Syntax.tm2 = uu___2; - FStar_Syntax_Syntax.meta = uu___3 - } in - FStar_Syntax_Syntax.Tm_meta uu___1 in - mk uu___ - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t0; - FStar_Syntax_Syntax.meta = - FStar_Syntax_Syntax.Meta_monadic_lift (m1, m2, t1);_} - -> - let uu___ = - let uu___1 = - let uu___2 = subst' s t0 in - let uu___3 = - let uu___4 = let uu___5 = subst' s t1 in (m1, m2, uu___5) in - FStar_Syntax_Syntax.Meta_monadic_lift uu___4 in - { - FStar_Syntax_Syntax.tm2 = uu___2; - FStar_Syntax_Syntax.meta = uu___3 - } in - FStar_Syntax_Syntax.Tm_meta uu___1 in - mk uu___ - | FStar_Syntax_Syntax.Tm_quoted (tm, qi) -> - (match qi.FStar_Syntax_Syntax.qkind with - | FStar_Syntax_Syntax.Quote_dynamic -> - let uu___ = - let uu___1 = let uu___2 = subst' s tm in (uu___2, qi) in - FStar_Syntax_Syntax.Tm_quoted uu___1 in - mk uu___ - | FStar_Syntax_Syntax.Quote_static -> - let qi1 = FStar_Syntax_Syntax.on_antiquoted (subst' s) qi in - mk (FStar_Syntax_Syntax.Tm_quoted (tm, qi1))) - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t1; FStar_Syntax_Syntax.meta = m;_} - -> - let uu___ = - let uu___1 = - let uu___2 = subst' s t1 in - { - FStar_Syntax_Syntax.tm2 = uu___2; - FStar_Syntax_Syntax.meta = m - } in - FStar_Syntax_Syntax.Tm_meta uu___1 in - mk uu___ -let (push_subst : - FStar_Syntax_Syntax.subst_ts -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = fun s -> fun t -> push_subst_aux true s t -let (compress_subst : FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = - fun t -> - match t.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_delayed - { FStar_Syntax_Syntax.tm1 = t1; FStar_Syntax_Syntax.substs = s;_} -> - let resolve_uvars = false in push_subst_aux resolve_uvars s t1 - | uu___ -> t -let rec (compress_slow : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun t -> - let t1 = force_uvar t in - match t1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_delayed - { FStar_Syntax_Syntax.tm1 = t'; FStar_Syntax_Syntax.substs = s;_} -> - let uu___ = push_subst s t' in compress uu___ - | uu___ -> t1 -and (compress : FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = - fun t -> - match t.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_delayed uu___ -> let r = compress_slow t in r - | FStar_Syntax_Syntax.Tm_uvar uu___ -> let r = compress_slow t in r - | uu___ -> t -let (subst : - FStar_Syntax_Syntax.subst_elt Prims.list -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = fun s -> fun t -> subst' ([s], FStar_Syntax_Syntax.NoUseRange) t -let (set_use_range : - FStar_Compiler_Range_Type.range -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun r -> - fun t -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Compiler_Range_Type.use_range r in - FStar_Compiler_Range_Type.set_def_range r uu___3 in - FStar_Syntax_Syntax.SomeUseRange uu___2 in - ([], uu___1) in - subst' uu___ t -let (subst_comp : - FStar_Syntax_Syntax.subst_elt Prims.list -> - FStar_Syntax_Syntax.comp -> FStar_Syntax_Syntax.comp) - = fun s -> fun t -> subst_comp' ([s], FStar_Syntax_Syntax.NoUseRange) t -let (subst_bqual : - FStar_Syntax_Syntax.subst_elt Prims.list -> - FStar_Syntax_Syntax.bqual -> FStar_Syntax_Syntax.bqual) - = - fun s -> fun imp -> subst_bqual' ([s], FStar_Syntax_Syntax.NoUseRange) imp -let (subst_aqual : - FStar_Syntax_Syntax.subst_elt Prims.list -> - FStar_Syntax_Syntax.aqual -> FStar_Syntax_Syntax.aqual) - = - fun s -> fun imp -> subst_aqual' ([s], FStar_Syntax_Syntax.NoUseRange) imp -let (subst_ascription : - FStar_Syntax_Syntax.subst_elt Prims.list -> - FStar_Syntax_Syntax.ascription -> FStar_Syntax_Syntax.ascription) - = - fun s -> - fun asc -> subst_ascription' ([s], FStar_Syntax_Syntax.NoUseRange) asc -let (subst_decreasing_order : - FStar_Syntax_Syntax.subst_elt Prims.list -> - FStar_Syntax_Syntax.decreases_order -> - FStar_Syntax_Syntax.decreases_order) - = - fun s -> - fun dec -> subst_dec_order' ([s], FStar_Syntax_Syntax.NoUseRange) dec -let (subst_residual_comp : - FStar_Syntax_Syntax.subst_elt Prims.list -> - FStar_Syntax_Syntax.residual_comp -> FStar_Syntax_Syntax.residual_comp) - = - fun s -> - fun rc -> - match rc.FStar_Syntax_Syntax.residual_typ with - | FStar_Pervasives_Native.None -> rc - | FStar_Pervasives_Native.Some t -> - let uu___ = - let uu___1 = subst s t in FStar_Pervasives_Native.Some uu___1 in - { - FStar_Syntax_Syntax.residual_effect = - (rc.FStar_Syntax_Syntax.residual_effect); - FStar_Syntax_Syntax.residual_typ = uu___; - FStar_Syntax_Syntax.residual_flags = - (rc.FStar_Syntax_Syntax.residual_flags) - } -let (closing_subst : - FStar_Syntax_Syntax.binders -> FStar_Syntax_Syntax.subst_elt Prims.list) = - fun bs -> - let uu___ = - FStar_Compiler_List.fold_right - (fun b -> - fun uu___1 -> - match uu___1 with - | (subst1, n) -> - (((FStar_Syntax_Syntax.NM - ((b.FStar_Syntax_Syntax.binder_bv), n)) :: subst1), - (n + Prims.int_one))) bs ([], Prims.int_zero) in - FStar_Pervasives_Native.fst uu___ -let (open_binders' : - FStar_Syntax_Syntax.binders -> - (FStar_Syntax_Syntax.binders * FStar_Syntax_Syntax.subst_t)) - = - fun bs -> - let rec aux bs1 o = - match bs1 with - | [] -> ([], o) - | b::bs' -> - let x' = - let uu___ = - FStar_Syntax_Syntax.freshen_bv b.FStar_Syntax_Syntax.binder_bv in - let uu___1 = - subst o - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - { - FStar_Syntax_Syntax.ppname = (uu___.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = (uu___.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = uu___1 - } in - let imp = subst_bqual o b.FStar_Syntax_Syntax.binder_qual in - let attrs = - FStar_Compiler_List.map (subst o) - b.FStar_Syntax_Syntax.binder_attrs in - let o1 = - let uu___ = shift_subst Prims.int_one o in - (FStar_Syntax_Syntax.DB (Prims.int_zero, x')) :: uu___ in - let uu___ = aux bs' o1 in - (match uu___ with - | (bs'1, o2) -> - let uu___1 = - let uu___2 = - FStar_Syntax_Syntax.mk_binder_with_attrs x' imp - b.FStar_Syntax_Syntax.binder_positivity attrs in - uu___2 :: bs'1 in - (uu___1, o2)) in - aux bs [] -let (open_binders : - FStar_Syntax_Syntax.binders -> FStar_Syntax_Syntax.binders) = - fun bs -> let uu___ = open_binders' bs in FStar_Pervasives_Native.fst uu___ -let (open_term' : - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.binders * FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.subst_t)) - = - fun bs -> - fun t -> - let uu___ = open_binders' bs in - match uu___ with - | (bs', opening) -> - let uu___1 = subst opening t in (bs', uu___1, opening) -let (open_term : - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.binders * FStar_Syntax_Syntax.term)) - = - fun bs -> - fun t -> - let uu___ = open_term' bs t in - match uu___ with | (b, t1, uu___1) -> (b, t1) -let (open_comp : - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.comp -> - (FStar_Syntax_Syntax.binders * FStar_Syntax_Syntax.comp)) - = - fun bs -> - fun t -> - let uu___ = open_binders' bs in - match uu___ with - | (bs', opening) -> let uu___1 = subst_comp opening t in (bs', uu___1) -let (open_ascription : - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.ascription -> - (FStar_Syntax_Syntax.binders * FStar_Syntax_Syntax.ascription)) - = - fun bs -> - fun asc -> - let uu___ = open_binders' bs in - match uu___ with - | (bs', opening) -> - let uu___1 = subst_ascription opening asc in (bs', uu___1) -let (open_pat : - FStar_Syntax_Syntax.pat -> - (FStar_Syntax_Syntax.pat * FStar_Syntax_Syntax.subst_t)) - = - fun p -> - let rec open_pat_aux sub p1 = - match p1.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_constant uu___ -> (p1, sub) - | FStar_Syntax_Syntax.Pat_cons (fv, us_opt, pats) -> - let us_opt1 = subst_univs_opt [sub] us_opt in - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun uu___2 -> - match (uu___1, uu___2) with - | ((pats1, sub1), (p2, imp)) -> - let uu___3 = open_pat_aux sub1 p2 in - (match uu___3 with - | (p3, sub2) -> (((p3, imp) :: pats1), sub2))) - ([], sub) pats in - (match uu___ with - | (pats1, sub1) -> - ({ - FStar_Syntax_Syntax.v = - (FStar_Syntax_Syntax.Pat_cons - (fv, us_opt1, (FStar_Compiler_List.rev pats1))); - FStar_Syntax_Syntax.p = (p1.FStar_Syntax_Syntax.p) - }, sub1)) - | FStar_Syntax_Syntax.Pat_var x -> - let x' = - let uu___ = FStar_Syntax_Syntax.freshen_bv x in - let uu___1 = subst sub x.FStar_Syntax_Syntax.sort in - { - FStar_Syntax_Syntax.ppname = (uu___.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = (uu___.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = uu___1 - } in - let sub1 = - let uu___ = shift_subst Prims.int_one sub in - (FStar_Syntax_Syntax.DB (Prims.int_zero, x')) :: uu___ in - ({ - FStar_Syntax_Syntax.v = (FStar_Syntax_Syntax.Pat_var x'); - FStar_Syntax_Syntax.p = (p1.FStar_Syntax_Syntax.p) - }, sub1) - | FStar_Syntax_Syntax.Pat_dot_term eopt -> - let eopt1 = FStar_Compiler_Util.map_option (subst sub) eopt in - ({ - FStar_Syntax_Syntax.v = (FStar_Syntax_Syntax.Pat_dot_term eopt1); - FStar_Syntax_Syntax.p = (p1.FStar_Syntax_Syntax.p) - }, sub) in - open_pat_aux [] p -let (open_branch' : - FStar_Syntax_Syntax.branch -> - (FStar_Syntax_Syntax.branch * FStar_Syntax_Syntax.subst_t)) - = - fun uu___ -> - match uu___ with - | (p, wopt, e) -> - let uu___1 = open_pat p in - (match uu___1 with - | (p1, opening) -> - let wopt1 = - match wopt with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some w -> - let uu___2 = subst opening w in - FStar_Pervasives_Native.Some uu___2 in - let e1 = subst opening e in ((p1, wopt1, e1), opening)) -let (open_branch : FStar_Syntax_Syntax.branch -> FStar_Syntax_Syntax.branch) - = - fun br -> - let uu___ = open_branch' br in match uu___ with | (br1, uu___1) -> br1 -let (close : - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = fun bs -> fun t -> let uu___ = closing_subst bs in subst uu___ t -let (close_comp : - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.comp -> FStar_Syntax_Syntax.comp) - = fun bs -> fun c -> let uu___ = closing_subst bs in subst_comp uu___ c -let (close_binders : - FStar_Syntax_Syntax.binders -> FStar_Syntax_Syntax.binders) = - fun bs -> - let rec aux s bs1 = - match bs1 with - | [] -> [] - | b::tl -> - let x = - let uu___ = b.FStar_Syntax_Syntax.binder_bv in - let uu___1 = - subst s - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - { - FStar_Syntax_Syntax.ppname = (uu___.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = (uu___.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = uu___1 - } in - let imp = subst_bqual s b.FStar_Syntax_Syntax.binder_qual in - let attrs = - FStar_Compiler_List.map (subst s) - b.FStar_Syntax_Syntax.binder_attrs in - let s' = - let uu___ = shift_subst Prims.int_one s in - (FStar_Syntax_Syntax.NM (x, Prims.int_zero)) :: uu___ in - let uu___ = - FStar_Syntax_Syntax.mk_binder_with_attrs x imp - b.FStar_Syntax_Syntax.binder_positivity attrs in - let uu___1 = aux s' tl in uu___ :: uu___1 in - aux [] bs -let (close_ascription : - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.ascription -> FStar_Syntax_Syntax.ascription) - = - fun bs -> - fun asc -> let uu___ = closing_subst bs in subst_ascription uu___ asc -let (close_pat : - FStar_Syntax_Syntax.pat' FStar_Syntax_Syntax.withinfo_t -> - (FStar_Syntax_Syntax.pat' FStar_Syntax_Syntax.withinfo_t * - FStar_Syntax_Syntax.subst_elt Prims.list)) - = - fun p -> - let rec aux sub p1 = - match p1.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_constant uu___ -> (p1, sub) - | FStar_Syntax_Syntax.Pat_cons (fv, us_opt, pats) -> - let us_opt1 = subst_univs_opt [sub] us_opt in - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun uu___2 -> - match (uu___1, uu___2) with - | ((pats1, sub1), (p2, imp)) -> - let uu___3 = aux sub1 p2 in - (match uu___3 with - | (p3, sub2) -> (((p3, imp) :: pats1), sub2))) - ([], sub) pats in - (match uu___ with - | (pats1, sub1) -> - ({ - FStar_Syntax_Syntax.v = - (FStar_Syntax_Syntax.Pat_cons - (fv, us_opt1, (FStar_Compiler_List.rev pats1))); - FStar_Syntax_Syntax.p = (p1.FStar_Syntax_Syntax.p) - }, sub1)) - | FStar_Syntax_Syntax.Pat_var x -> - let x1 = - let uu___ = subst sub x.FStar_Syntax_Syntax.sort in - { - FStar_Syntax_Syntax.ppname = (x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = (x.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = uu___ - } in - let sub1 = - let uu___ = shift_subst Prims.int_one sub in - (FStar_Syntax_Syntax.NM (x1, Prims.int_zero)) :: uu___ in - ({ - FStar_Syntax_Syntax.v = (FStar_Syntax_Syntax.Pat_var x1); - FStar_Syntax_Syntax.p = (p1.FStar_Syntax_Syntax.p) - }, sub1) - | FStar_Syntax_Syntax.Pat_dot_term eopt -> - let eopt1 = FStar_Compiler_Util.map_option (subst sub) eopt in - ({ - FStar_Syntax_Syntax.v = (FStar_Syntax_Syntax.Pat_dot_term eopt1); - FStar_Syntax_Syntax.p = (p1.FStar_Syntax_Syntax.p) - }, sub) in - aux [] p -let (close_branch : FStar_Syntax_Syntax.branch -> FStar_Syntax_Syntax.branch) - = - fun uu___ -> - match uu___ with - | (p, wopt, e) -> - let uu___1 = close_pat p in - (match uu___1 with - | (p1, closing) -> - let wopt1 = - match wopt with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some w -> - let uu___2 = subst closing w in - FStar_Pervasives_Native.Some uu___2 in - let e1 = subst closing e in (p1, wopt1, e1)) -let (univ_var_opening : - FStar_Syntax_Syntax.univ_names -> - (FStar_Syntax_Syntax.subst_elt Prims.list * FStar_Syntax_Syntax.univ_name - Prims.list)) - = - fun us -> - let n = (FStar_Compiler_List.length us) - Prims.int_one in - let s = - FStar_Compiler_List.mapi - (fun i -> - fun u -> - FStar_Syntax_Syntax.UN ((n - i), (FStar_Syntax_Syntax.U_name u))) - us in - (s, us) -let (univ_var_closing : - FStar_Syntax_Syntax.univ_names -> FStar_Syntax_Syntax.subst_elt Prims.list) - = - fun us -> - let n = (FStar_Compiler_List.length us) - Prims.int_one in - FStar_Compiler_List.mapi - (fun i -> fun u -> FStar_Syntax_Syntax.UD (u, (n - i))) us -let (open_univ_vars : - FStar_Syntax_Syntax.univ_names -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.univ_names * FStar_Syntax_Syntax.term)) - = - fun us -> - fun t -> - let uu___ = univ_var_opening us in - match uu___ with | (s, us') -> let t1 = subst s t in (us', t1) -let (open_univ_vars_comp : - FStar_Syntax_Syntax.univ_names -> - FStar_Syntax_Syntax.comp -> - (FStar_Syntax_Syntax.univ_names * FStar_Syntax_Syntax.comp)) - = - fun us -> - fun c -> - let uu___ = univ_var_opening us in - match uu___ with - | (s, us') -> let uu___1 = subst_comp s c in (us', uu___1) -let (close_univ_vars : - FStar_Syntax_Syntax.univ_names -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = fun us -> fun t -> let s = univ_var_closing us in subst s t -let (close_univ_vars_comp : - FStar_Syntax_Syntax.univ_names -> - FStar_Syntax_Syntax.comp -> FStar_Syntax_Syntax.comp) - = - fun us -> - fun c -> - let n = (FStar_Compiler_List.length us) - Prims.int_one in - let s = - FStar_Compiler_List.mapi - (fun i -> fun u -> FStar_Syntax_Syntax.UD (u, (n - i))) us in - subst_comp s c -let (open_let_rec : - FStar_Syntax_Syntax.letbinding Prims.list -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.letbinding Prims.list * FStar_Syntax_Syntax.term)) - = - fun lbs -> - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Syntax.is_top_level lbs in - if uu___1 - then (Prims.int_zero, lbs, []) - else - FStar_Compiler_List.fold_right - (fun lb -> - fun uu___3 -> - match uu___3 with - | (i, lbs1, out) -> - let x = - let uu___4 = - FStar_Compiler_Util.left - lb.FStar_Syntax_Syntax.lbname in - FStar_Syntax_Syntax.freshen_bv uu___4 in - ((i + Prims.int_one), - ({ - FStar_Syntax_Syntax.lbname = - (FStar_Pervasives.Inl x); - FStar_Syntax_Syntax.lbunivs = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = - (lb.FStar_Syntax_Syntax.lbtyp); - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = - (lb.FStar_Syntax_Syntax.lbdef); - FStar_Syntax_Syntax.lbattrs = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - } :: lbs1), ((FStar_Syntax_Syntax.DB (i, x)) :: out))) - lbs (Prims.int_zero, [], []) in - match uu___ with - | (n_let_recs, lbs1, let_rec_opening) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Compiler_List.hd lbs1 in - uu___3.FStar_Syntax_Syntax.lbunivs in - FStar_Compiler_List.fold_right - (fun u -> - fun uu___3 -> - match uu___3 with - | (i, us, out) -> - let u1 = - FStar_Syntax_Syntax.new_univ_name - FStar_Pervasives_Native.None in - ((i + Prims.int_one), (u1 :: us), - ((FStar_Syntax_Syntax.UN - (i, (FStar_Syntax_Syntax.U_name u1))) :: out))) - uu___2 (n_let_recs, [], let_rec_opening) in - (match uu___1 with - | (uu___2, us, u_let_rec_opening) -> - let lbs2 = - FStar_Compiler_List.map - (fun lb -> - let uu___3 = - subst u_let_rec_opening lb.FStar_Syntax_Syntax.lbtyp in - let uu___4 = - subst u_let_rec_opening lb.FStar_Syntax_Syntax.lbdef in - { - FStar_Syntax_Syntax.lbname = - (lb.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs = us; - FStar_Syntax_Syntax.lbtyp = uu___3; - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = uu___4; - FStar_Syntax_Syntax.lbattrs = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - }) lbs1 in - let t1 = subst let_rec_opening t in (lbs2, t1)) -let (close_let_rec : - FStar_Syntax_Syntax.letbinding Prims.list -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.letbinding Prims.list * FStar_Syntax_Syntax.term)) - = - fun lbs -> - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Syntax.is_top_level lbs in - if uu___1 - then (Prims.int_zero, []) - else - FStar_Compiler_List.fold_right - (fun lb -> - fun uu___3 -> - match uu___3 with - | (i, out) -> - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Compiler_Util.left - lb.FStar_Syntax_Syntax.lbname in - (uu___7, i) in - FStar_Syntax_Syntax.NM uu___6 in - uu___5 :: out in - ((i + Prims.int_one), uu___4)) lbs (Prims.int_zero, []) in - match uu___ with - | (n_let_recs, let_rec_closing) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Compiler_List.hd lbs in - uu___3.FStar_Syntax_Syntax.lbunivs in - FStar_Compiler_List.fold_right - (fun u -> - fun uu___3 -> - match uu___3 with - | (i, out) -> - ((i + Prims.int_one), ((FStar_Syntax_Syntax.UD (u, i)) - :: out))) uu___2 (n_let_recs, let_rec_closing) in - (match uu___1 with - | (uu___2, u_let_rec_closing) -> - let lbs1 = - FStar_Compiler_List.map - (fun lb -> - let uu___3 = - subst u_let_rec_closing lb.FStar_Syntax_Syntax.lbtyp in - let uu___4 = - subst u_let_rec_closing lb.FStar_Syntax_Syntax.lbdef in - { - FStar_Syntax_Syntax.lbname = - (lb.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = uu___3; - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = uu___4; - FStar_Syntax_Syntax.lbattrs = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - }) lbs in - let t1 = subst let_rec_closing t in (lbs1, t1)) -let (close_tscheme : - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.tscheme -> FStar_Syntax_Syntax.tscheme) - = - fun binders -> - fun uu___ -> - match uu___ with - | (us, t) -> - let n = (FStar_Compiler_List.length binders) - Prims.int_one in - let k = FStar_Compiler_List.length us in - let s = - FStar_Compiler_List.mapi - (fun i -> - fun b -> - FStar_Syntax_Syntax.NM - ((b.FStar_Syntax_Syntax.binder_bv), (k + (n - i)))) - binders in - let t1 = subst s t in (us, t1) -let (close_univ_vars_tscheme : - FStar_Syntax_Syntax.univ_names -> - FStar_Syntax_Syntax.tscheme -> FStar_Syntax_Syntax.tscheme) - = - fun us -> - fun uu___ -> - match uu___ with - | (us', t) -> - let n = (FStar_Compiler_List.length us) - Prims.int_one in - let k = FStar_Compiler_List.length us' in - let s = - FStar_Compiler_List.mapi - (fun i -> fun x -> FStar_Syntax_Syntax.UD (x, (k + (n - i)))) - us in - let uu___1 = subst s t in (us', uu___1) -let (subst_tscheme : - FStar_Syntax_Syntax.subst_elt Prims.list -> - FStar_Syntax_Syntax.tscheme -> FStar_Syntax_Syntax.tscheme) - = - fun s -> - fun uu___ -> - match uu___ with - | (us, t) -> - let s1 = shift_subst (FStar_Compiler_List.length us) s in - let uu___1 = subst s1 t in (us, uu___1) -let (opening_of_binders : - FStar_Syntax_Syntax.binders -> FStar_Syntax_Syntax.subst_t) = - fun bs -> - let n = (FStar_Compiler_List.length bs) - Prims.int_one in - FStar_Compiler_List.mapi - (fun i -> - fun b -> - FStar_Syntax_Syntax.DB - ((n - i), (b.FStar_Syntax_Syntax.binder_bv))) bs -let (closing_of_binders : - FStar_Syntax_Syntax.binders -> FStar_Syntax_Syntax.subst_t) = - fun bs -> closing_subst bs -let (open_term_1 : - FStar_Syntax_Syntax.binder -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.binder * FStar_Syntax_Syntax.term)) - = - fun b -> - fun t -> - let uu___ = open_term [b] t in - match uu___ with - | (b1::[], t1) -> (b1, t1) - | uu___1 -> failwith "impossible: open_term_1" -let (open_term_bvs : - FStar_Syntax_Syntax.bv Prims.list -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.bv Prims.list * FStar_Syntax_Syntax.term)) - = - fun bvs -> - fun t -> - let uu___ = - let uu___1 = - FStar_Compiler_List.map FStar_Syntax_Syntax.mk_binder bvs in - open_term uu___1 t in - match uu___ with - | (bs, t1) -> - let uu___1 = - FStar_Compiler_List.map - (fun b -> b.FStar_Syntax_Syntax.binder_bv) bs in - (uu___1, t1) -let (open_term_bv : - FStar_Syntax_Syntax.bv -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.bv * FStar_Syntax_Syntax.term)) - = - fun bv -> - fun t -> - let uu___ = open_term_bvs [bv] t in - match uu___ with - | (bv1::[], t1) -> (bv1, t1) - | uu___1 -> failwith "impossible: open_term_bv" \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_Syntax.ml b/ocaml/fstar-lib/generated/FStar_Syntax_Syntax.ml deleted file mode 100644 index 355592e6119..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Syntax_Syntax.ml +++ /dev/null @@ -1,3328 +0,0 @@ -open Prims -type 'a withinfo_t = { - v: 'a ; - p: FStar_Compiler_Range_Type.range }[@@deriving yojson,show] -let __proj__Mkwithinfo_t__item__v : 'a . 'a withinfo_t -> 'a = - fun projectee -> match projectee with | { v; p;_} -> v -let __proj__Mkwithinfo_t__item__p : - 'a . 'a withinfo_t -> FStar_Compiler_Range_Type.range = - fun projectee -> match projectee with | { v; p;_} -> p -type var = FStar_Ident.lident withinfo_t[@@deriving yojson,show] -type sconst = FStar_Const.sconst[@@deriving yojson,show] -type pragma = - | ShowOptions - | SetOptions of Prims.string - | ResetOptions of Prims.string FStar_Pervasives_Native.option - | PushOptions of Prims.string FStar_Pervasives_Native.option - | PopOptions - | RestartSolver - | PrintEffectsGraph [@@deriving yojson,show] -let (uu___is_ShowOptions : pragma -> Prims.bool) = - fun projectee -> - match projectee with | ShowOptions -> true | uu___ -> false -let (uu___is_SetOptions : pragma -> Prims.bool) = - fun projectee -> - match projectee with | SetOptions _0 -> true | uu___ -> false -let (__proj__SetOptions__item___0 : pragma -> Prims.string) = - fun projectee -> match projectee with | SetOptions _0 -> _0 -let (uu___is_ResetOptions : pragma -> Prims.bool) = - fun projectee -> - match projectee with | ResetOptions _0 -> true | uu___ -> false -let (__proj__ResetOptions__item___0 : - pragma -> Prims.string FStar_Pervasives_Native.option) = - fun projectee -> match projectee with | ResetOptions _0 -> _0 -let (uu___is_PushOptions : pragma -> Prims.bool) = - fun projectee -> - match projectee with | PushOptions _0 -> true | uu___ -> false -let (__proj__PushOptions__item___0 : - pragma -> Prims.string FStar_Pervasives_Native.option) = - fun projectee -> match projectee with | PushOptions _0 -> _0 -let (uu___is_PopOptions : pragma -> Prims.bool) = - fun projectee -> match projectee with | PopOptions -> true | uu___ -> false -let (uu___is_RestartSolver : pragma -> Prims.bool) = - fun projectee -> - match projectee with | RestartSolver -> true | uu___ -> false -let (uu___is_PrintEffectsGraph : pragma -> Prims.bool) = - fun projectee -> - match projectee with | PrintEffectsGraph -> true | uu___ -> false -let (pragma_to_string : pragma -> Prims.string) = - fun p -> - match p with - | ShowOptions -> "#show-options" - | ResetOptions (FStar_Pervasives_Native.None) -> "#reset-options" - | ResetOptions (FStar_Pervasives_Native.Some s) -> - FStar_Compiler_Util.format1 "#reset-options \"%s\"" s - | SetOptions s -> FStar_Compiler_Util.format1 "#set-options \"%s\"" s - | PushOptions (FStar_Pervasives_Native.None) -> "#push-options" - | PushOptions (FStar_Pervasives_Native.Some s) -> - FStar_Compiler_Util.format1 "#push-options \"%s\"" s - | RestartSolver -> "#restart-solver" - | PrintEffectsGraph -> "#print-effects-graph" - | PopOptions -> "#pop-options" -let (showable_pragma : pragma FStar_Class_Show.showable) = - { FStar_Class_Show.show = pragma_to_string } -type 'a memo = - (('a FStar_Pervasives_Native.option FStar_Compiler_Effect.ref)[@printer - fun fmt -> - fun _ -> - Format.pp_print_string - fmt - "None"]) -[@@deriving yojson,show] -type emb_typ = - | ET_abstract - | ET_fun of (emb_typ * emb_typ) - | ET_app of (Prims.string * emb_typ Prims.list) -let (uu___is_ET_abstract : emb_typ -> Prims.bool) = - fun projectee -> - match projectee with | ET_abstract -> true | uu___ -> false -let (uu___is_ET_fun : emb_typ -> Prims.bool) = - fun projectee -> match projectee with | ET_fun _0 -> true | uu___ -> false -let (__proj__ET_fun__item___0 : emb_typ -> (emb_typ * emb_typ)) = - fun projectee -> match projectee with | ET_fun _0 -> _0 -let (uu___is_ET_app : emb_typ -> Prims.bool) = - fun projectee -> match projectee with | ET_app _0 -> true | uu___ -> false -let (__proj__ET_app__item___0 : - emb_typ -> (Prims.string * emb_typ Prims.list)) = - fun projectee -> match projectee with | ET_app _0 -> _0 -type version = { - major: Prims.int ; - minor: Prims.int }[@@deriving yojson,show] -let (__proj__Mkversion__item__major : version -> Prims.int) = - fun projectee -> match projectee with | { major; minor;_} -> major -let (__proj__Mkversion__item__minor : version -> Prims.int) = - fun projectee -> match projectee with | { major; minor;_} -> minor -type universe = - | U_zero - | U_succ of universe - | U_max of universe Prims.list - | U_bvar of Prims.int - | U_name of FStar_Ident.ident - | U_unif of (universe FStar_Pervasives_Native.option FStar_Unionfind.p_uvar - * version * FStar_Compiler_Range_Type.range) - | U_unknown [@@deriving yojson,show] -let (uu___is_U_zero : universe -> Prims.bool) = - fun projectee -> match projectee with | U_zero -> true | uu___ -> false -let (uu___is_U_succ : universe -> Prims.bool) = - fun projectee -> match projectee with | U_succ _0 -> true | uu___ -> false -let (__proj__U_succ__item___0 : universe -> universe) = - fun projectee -> match projectee with | U_succ _0 -> _0 -let (uu___is_U_max : universe -> Prims.bool) = - fun projectee -> match projectee with | U_max _0 -> true | uu___ -> false -let (__proj__U_max__item___0 : universe -> universe Prims.list) = - fun projectee -> match projectee with | U_max _0 -> _0 -let (uu___is_U_bvar : universe -> Prims.bool) = - fun projectee -> match projectee with | U_bvar _0 -> true | uu___ -> false -let (__proj__U_bvar__item___0 : universe -> Prims.int) = - fun projectee -> match projectee with | U_bvar _0 -> _0 -let (uu___is_U_name : universe -> Prims.bool) = - fun projectee -> match projectee with | U_name _0 -> true | uu___ -> false -let (__proj__U_name__item___0 : universe -> FStar_Ident.ident) = - fun projectee -> match projectee with | U_name _0 -> _0 -let (uu___is_U_unif : universe -> Prims.bool) = - fun projectee -> match projectee with | U_unif _0 -> true | uu___ -> false -let (__proj__U_unif__item___0 : - universe -> - (universe FStar_Pervasives_Native.option FStar_Unionfind.p_uvar * version - * FStar_Compiler_Range_Type.range)) - = fun projectee -> match projectee with | U_unif _0 -> _0 -let (uu___is_U_unknown : universe -> Prims.bool) = - fun projectee -> match projectee with | U_unknown -> true | uu___ -> false -type univ_name = FStar_Ident.ident[@@deriving yojson,show] -type universe_uvar = - (universe FStar_Pervasives_Native.option FStar_Unionfind.p_uvar * version * - FStar_Compiler_Range_Type.range)[@@deriving yojson,show] -type univ_names = univ_name Prims.list[@@deriving yojson,show] -type universes = universe Prims.list[@@deriving yojson,show] -type monad_name = FStar_Ident.lident[@@deriving yojson,show] -type quote_kind = - | Quote_static - | Quote_dynamic [@@deriving yojson,show] -let (uu___is_Quote_static : quote_kind -> Prims.bool) = - fun projectee -> - match projectee with | Quote_static -> true | uu___ -> false -let (uu___is_Quote_dynamic : quote_kind -> Prims.bool) = - fun projectee -> - match projectee with | Quote_dynamic -> true | uu___ -> false -type maybe_set_use_range = - | NoUseRange - | SomeUseRange of FStar_Compiler_Range_Type.range [@@deriving yojson,show] -let (uu___is_NoUseRange : maybe_set_use_range -> Prims.bool) = - fun projectee -> match projectee with | NoUseRange -> true | uu___ -> false -let (uu___is_SomeUseRange : maybe_set_use_range -> Prims.bool) = - fun projectee -> - match projectee with | SomeUseRange _0 -> true | uu___ -> false -let (__proj__SomeUseRange__item___0 : - maybe_set_use_range -> FStar_Compiler_Range_Type.range) = - fun projectee -> match projectee with | SomeUseRange _0 -> _0 -type delta_depth = - | Delta_constant_at_level of Prims.int - | Delta_equational_at_level of Prims.int - | Delta_abstract of delta_depth [@@deriving yojson,show] -let (uu___is_Delta_constant_at_level : delta_depth -> Prims.bool) = - fun projectee -> - match projectee with - | Delta_constant_at_level _0 -> true - | uu___ -> false -let (__proj__Delta_constant_at_level__item___0 : delta_depth -> Prims.int) = - fun projectee -> match projectee with | Delta_constant_at_level _0 -> _0 -let (uu___is_Delta_equational_at_level : delta_depth -> Prims.bool) = - fun projectee -> - match projectee with - | Delta_equational_at_level _0 -> true - | uu___ -> false -let (__proj__Delta_equational_at_level__item___0 : delta_depth -> Prims.int) - = - fun projectee -> match projectee with | Delta_equational_at_level _0 -> _0 -let (uu___is_Delta_abstract : delta_depth -> Prims.bool) = - fun projectee -> - match projectee with | Delta_abstract _0 -> true | uu___ -> false -let (__proj__Delta_abstract__item___0 : delta_depth -> delta_depth) = - fun projectee -> match projectee with | Delta_abstract _0 -> _0 -type should_check_uvar = - | Allow_unresolved of Prims.string - | Allow_untyped of Prims.string - | Allow_ghost of Prims.string - | Strict - | Already_checked [@@deriving yojson,show] -let (uu___is_Allow_unresolved : should_check_uvar -> Prims.bool) = - fun projectee -> - match projectee with | Allow_unresolved _0 -> true | uu___ -> false -let (__proj__Allow_unresolved__item___0 : should_check_uvar -> Prims.string) - = fun projectee -> match projectee with | Allow_unresolved _0 -> _0 -let (uu___is_Allow_untyped : should_check_uvar -> Prims.bool) = - fun projectee -> - match projectee with | Allow_untyped _0 -> true | uu___ -> false -let (__proj__Allow_untyped__item___0 : should_check_uvar -> Prims.string) = - fun projectee -> match projectee with | Allow_untyped _0 -> _0 -let (uu___is_Allow_ghost : should_check_uvar -> Prims.bool) = - fun projectee -> - match projectee with | Allow_ghost _0 -> true | uu___ -> false -let (__proj__Allow_ghost__item___0 : should_check_uvar -> Prims.string) = - fun projectee -> match projectee with | Allow_ghost _0 -> _0 -let (uu___is_Strict : should_check_uvar -> Prims.bool) = - fun projectee -> match projectee with | Strict -> true | uu___ -> false -let (uu___is_Already_checked : should_check_uvar -> Prims.bool) = - fun projectee -> - match projectee with | Already_checked -> true | uu___ -> false -type positivity_qualifier = - | BinderStrictlyPositive - | BinderUnused -let (uu___is_BinderStrictlyPositive : positivity_qualifier -> Prims.bool) = - fun projectee -> - match projectee with | BinderStrictlyPositive -> true | uu___ -> false -let (uu___is_BinderUnused : positivity_qualifier -> Prims.bool) = - fun projectee -> - match projectee with | BinderUnused -> true | uu___ -> false -type term'__Tm_abs__payload = - { - bs: binder Prims.list ; - body: term' syntax ; - rc_opt: residual_comp FStar_Pervasives_Native.option } -and term'__Tm_arrow__payload = { - bs1: binder Prims.list ; - comp: comp' syntax } -and term'__Tm_refine__payload = { - b: bv ; - phi: term' syntax } -and term'__Tm_app__payload = - { - hd: term' syntax ; - args: - (term' syntax * arg_qualifier FStar_Pervasives_Native.option) Prims.list } -and term'__Tm_match__payload = - { - scrutinee: term' syntax ; - ret_opt: - (binder * ((term' syntax, comp' syntax) FStar_Pervasives.either * term' - syntax FStar_Pervasives_Native.option * Prims.bool)) - FStar_Pervasives_Native.option - ; - brs: - (pat' withinfo_t * term' syntax FStar_Pervasives_Native.option * term' - syntax) Prims.list - ; - rc_opt1: residual_comp FStar_Pervasives_Native.option } -and term'__Tm_ascribed__payload = - { - tm: term' syntax ; - asc: - ((term' syntax, comp' syntax) FStar_Pervasives.either * term' syntax - FStar_Pervasives_Native.option * Prims.bool) - ; - eff_opt: FStar_Ident.lident FStar_Pervasives_Native.option } -and term'__Tm_let__payload = - { - lbs: (Prims.bool * letbinding Prims.list) ; - body1: term' syntax } -and term'__Tm_delayed__payload = - { - tm1: term' syntax ; - substs: (subst_elt Prims.list Prims.list * maybe_set_use_range) } -and term'__Tm_meta__payload = { - tm2: term' syntax ; - meta: metadata } -and term' = - | Tm_bvar of bv - | Tm_name of bv - | Tm_fvar of fv - | Tm_uinst of (term' syntax * universes) - | Tm_constant of sconst - | Tm_type of universe - | Tm_abs of term'__Tm_abs__payload - | Tm_arrow of term'__Tm_arrow__payload - | Tm_refine of term'__Tm_refine__payload - | Tm_app of term'__Tm_app__payload - | Tm_match of term'__Tm_match__payload - | Tm_ascribed of term'__Tm_ascribed__payload - | Tm_let of term'__Tm_let__payload - | Tm_uvar of (ctx_uvar * (subst_elt Prims.list Prims.list * - maybe_set_use_range)) - | Tm_delayed of term'__Tm_delayed__payload - | Tm_meta of term'__Tm_meta__payload - | Tm_lazy of lazyinfo - | Tm_quoted of (term' syntax * quoteinfo) - | Tm_unknown -and ctx_uvar = - { - ctx_uvar_head: - ((term' syntax FStar_Pervasives_Native.option * uvar_decoration) - FStar_Unionfind.p_uvar * version * FStar_Compiler_Range_Type.range) - ; - ctx_uvar_gamma: binding Prims.list ; - ctx_uvar_binders: binder Prims.list ; - ctx_uvar_reason: Prims.string ; - ctx_uvar_range: FStar_Compiler_Range_Type.range ; - ctx_uvar_meta: ctx_uvar_meta_t FStar_Pervasives_Native.option } -and ctx_uvar_meta_t = - | Ctx_uvar_meta_tac of term' syntax - | Ctx_uvar_meta_attr of term' syntax -and uvar_decoration = - { - uvar_decoration_typ: term' syntax ; - uvar_decoration_typedness_depends_on: ctx_uvar Prims.list ; - uvar_decoration_should_check: should_check_uvar ; - uvar_decoration_should_unrefine: Prims.bool } -and pat' = - | Pat_constant of sconst - | Pat_cons of (fv * universes FStar_Pervasives_Native.option * (pat' - withinfo_t * Prims.bool) Prims.list) - | Pat_var of bv - | Pat_dot_term of term' syntax FStar_Pervasives_Native.option -and letbinding = - { - lbname: (bv, fv) FStar_Pervasives.either ; - lbunivs: univ_name Prims.list ; - lbtyp: term' syntax ; - lbeff: FStar_Ident.lident ; - lbdef: term' syntax ; - lbattrs: term' syntax Prims.list ; - lbpos: FStar_Compiler_Range_Type.range } -and quoteinfo = - { - qkind: quote_kind ; - antiquotations: (Prims.int * term' syntax Prims.list) } -and comp_typ = - { - comp_univs: universes ; - effect_name: FStar_Ident.lident ; - result_typ: term' syntax ; - effect_args: - (term' syntax * arg_qualifier FStar_Pervasives_Native.option) Prims.list ; - flags: cflag Prims.list } -and comp' = - | Total of term' syntax - | GTotal of term' syntax - | Comp of comp_typ -and binder = - { - binder_bv: bv ; - binder_qual: binder_qualifier FStar_Pervasives_Native.option ; - binder_positivity: positivity_qualifier FStar_Pervasives_Native.option ; - binder_attrs: term' syntax Prims.list } -and decreases_order = - | Decreases_lex of term' syntax Prims.list - | Decreases_wf of (term' syntax * term' syntax) -and cflag = - | TOTAL - | MLEFFECT - | LEMMA - | RETURN - | PARTIAL_RETURN - | SOMETRIVIAL - | TRIVIAL_POSTCONDITION - | SHOULD_NOT_INLINE - | CPS - | DECREASES of decreases_order -and metadata = - | Meta_pattern of (term' syntax Prims.list * (term' syntax * arg_qualifier - FStar_Pervasives_Native.option) Prims.list Prims.list) - | Meta_named of FStar_Ident.lident - | Meta_labeled of (FStar_Pprint.document Prims.list * - FStar_Compiler_Range_Type.range * Prims.bool) - | Meta_desugared of meta_source_info - | Meta_monadic of (monad_name * term' syntax) - | Meta_monadic_lift of (monad_name * monad_name * term' syntax) -and meta_source_info = - | Sequence - | Primop - | Masked_effect - | Meta_smt_pat - | Machine_integer of (FStar_Const.signedness * FStar_Const.width) -and fv_qual = - | Data_ctor - | Record_projector of (FStar_Ident.lident * FStar_Ident.ident) - | Record_ctor of (FStar_Ident.lident * FStar_Ident.ident Prims.list) - | Unresolved_projector of fv FStar_Pervasives_Native.option - | Unresolved_constructor of unresolved_constructor -and unresolved_constructor = - { - uc_base_term: Prims.bool ; - uc_typename: FStar_Ident.lident FStar_Pervasives_Native.option ; - uc_fields: FStar_Ident.lident Prims.list } -and subst_elt = - | DB of (Prims.int * bv) - | DT of (Prims.int * term' syntax) - | NM of (bv * Prims.int) - | NT of (bv * term' syntax) - | UN of (Prims.int * universe) - | UD of (univ_name * Prims.int) -and 'a syntax = - { - n: 'a ; - pos: FStar_Compiler_Range_Type.range ; - vars: free_vars memo ; - hash_code: FStar_Hash.hash_code memo } -and bv = { - ppname: FStar_Ident.ident ; - index: Prims.int ; - sort: term' syntax } -and fv = { - fv_name: var ; - fv_qual: fv_qual FStar_Pervasives_Native.option } -and free_vars = - { - free_names: bv FStar_Compiler_FlatSet.t ; - free_uvars: ctx_uvar FStar_Compiler_FlatSet.t ; - free_univs: universe_uvar FStar_Compiler_FlatSet.t ; - free_univ_names: univ_name FStar_Compiler_FlatSet.t } -and residual_comp = - { - residual_effect: FStar_Ident.lident ; - residual_typ: term' syntax FStar_Pervasives_Native.option ; - residual_flags: cflag Prims.list } -and lazyinfo = - { - blob: FStar_Dyn.dyn ; - lkind: lazy_kind ; - ltyp: term' syntax ; - rng: FStar_Compiler_Range_Type.range } -and lazy_kind = - | BadLazy - | Lazy_bv - | Lazy_namedv - | Lazy_binder - | Lazy_optionstate - | Lazy_fvar - | Lazy_comp - | Lazy_env - | Lazy_proofstate - | Lazy_goal - | Lazy_sigelt - | Lazy_uvar - | Lazy_letbinding - | Lazy_embedding of (emb_typ * term' syntax FStar_Thunk.t) - | Lazy_universe - | Lazy_universe_uvar - | Lazy_issue - | Lazy_ident - | Lazy_doc - | Lazy_extension of Prims.string - | Lazy_tref -and binding = - | Binding_var of bv - | Binding_lid of (FStar_Ident.lident * (univ_names * term' syntax)) - | Binding_univ of univ_name -and binder_qualifier = - | Implicit of Prims.bool - | Meta of term' syntax - | Equality -and arg_qualifier = - { - aqual_implicit: Prims.bool ; - aqual_attributes: term' syntax Prims.list } -let (__proj__Mkterm'__Tm_abs__payload__item__bs : - term'__Tm_abs__payload -> binder Prims.list) = - fun projectee -> match projectee with | { bs; body; rc_opt;_} -> bs -let (__proj__Mkterm'__Tm_abs__payload__item__body : - term'__Tm_abs__payload -> term' syntax) = - fun projectee -> match projectee with | { bs; body; rc_opt;_} -> body -let (__proj__Mkterm'__Tm_abs__payload__item__rc_opt : - term'__Tm_abs__payload -> residual_comp FStar_Pervasives_Native.option) = - fun projectee -> match projectee with | { bs; body; rc_opt;_} -> rc_opt -let (__proj__Mkterm'__Tm_arrow__payload__item__bs : - term'__Tm_arrow__payload -> binder Prims.list) = - fun projectee -> match projectee with | { bs1 = bs; comp;_} -> bs -let (__proj__Mkterm'__Tm_arrow__payload__item__comp : - term'__Tm_arrow__payload -> comp' syntax) = - fun projectee -> match projectee with | { bs1 = bs; comp;_} -> comp -let (__proj__Mkterm'__Tm_refine__payload__item__b : - term'__Tm_refine__payload -> bv) = - fun projectee -> match projectee with | { b; phi;_} -> b -let (__proj__Mkterm'__Tm_refine__payload__item__phi : - term'__Tm_refine__payload -> term' syntax) = - fun projectee -> match projectee with | { b; phi;_} -> phi -let (__proj__Mkterm'__Tm_app__payload__item__hd : - term'__Tm_app__payload -> term' syntax) = - fun projectee -> match projectee with | { hd; args;_} -> hd -let (__proj__Mkterm'__Tm_app__payload__item__args : - term'__Tm_app__payload -> - (term' syntax * arg_qualifier FStar_Pervasives_Native.option) Prims.list) - = fun projectee -> match projectee with | { hd; args;_} -> args -let (__proj__Mkterm'__Tm_match__payload__item__scrutinee : - term'__Tm_match__payload -> term' syntax) = - fun projectee -> - match projectee with - | { scrutinee; ret_opt; brs; rc_opt1 = rc_opt;_} -> scrutinee -let (__proj__Mkterm'__Tm_match__payload__item__ret_opt : - term'__Tm_match__payload -> - (binder * ((term' syntax, comp' syntax) FStar_Pervasives.either * term' - syntax FStar_Pervasives_Native.option * Prims.bool)) - FStar_Pervasives_Native.option) - = - fun projectee -> - match projectee with - | { scrutinee; ret_opt; brs; rc_opt1 = rc_opt;_} -> ret_opt -let (__proj__Mkterm'__Tm_match__payload__item__brs : - term'__Tm_match__payload -> - (pat' withinfo_t * term' syntax FStar_Pervasives_Native.option * term' - syntax) Prims.list) - = - fun projectee -> - match projectee with - | { scrutinee; ret_opt; brs; rc_opt1 = rc_opt;_} -> brs -let (__proj__Mkterm'__Tm_match__payload__item__rc_opt : - term'__Tm_match__payload -> residual_comp FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { scrutinee; ret_opt; brs; rc_opt1 = rc_opt;_} -> rc_opt -let (__proj__Mkterm'__Tm_ascribed__payload__item__tm : - term'__Tm_ascribed__payload -> term' syntax) = - fun projectee -> match projectee with | { tm; asc; eff_opt;_} -> tm -let (__proj__Mkterm'__Tm_ascribed__payload__item__asc : - term'__Tm_ascribed__payload -> - ((term' syntax, comp' syntax) FStar_Pervasives.either * term' syntax - FStar_Pervasives_Native.option * Prims.bool)) - = fun projectee -> match projectee with | { tm; asc; eff_opt;_} -> asc -let (__proj__Mkterm'__Tm_ascribed__payload__item__eff_opt : - term'__Tm_ascribed__payload -> - FStar_Ident.lident FStar_Pervasives_Native.option) - = fun projectee -> match projectee with | { tm; asc; eff_opt;_} -> eff_opt -let (__proj__Mkterm'__Tm_let__payload__item__lbs : - term'__Tm_let__payload -> (Prims.bool * letbinding Prims.list)) = - fun projectee -> match projectee with | { lbs; body1 = body;_} -> lbs -let (__proj__Mkterm'__Tm_let__payload__item__body : - term'__Tm_let__payload -> term' syntax) = - fun projectee -> match projectee with | { lbs; body1 = body;_} -> body -let (__proj__Mkterm'__Tm_delayed__payload__item__tm : - term'__Tm_delayed__payload -> term' syntax) = - fun projectee -> match projectee with | { tm1 = tm; substs;_} -> tm -let (__proj__Mkterm'__Tm_delayed__payload__item__substs : - term'__Tm_delayed__payload -> - (subst_elt Prims.list Prims.list * maybe_set_use_range)) - = fun projectee -> match projectee with | { tm1 = tm; substs;_} -> substs -let (__proj__Mkterm'__Tm_meta__payload__item__tm : - term'__Tm_meta__payload -> term' syntax) = - fun projectee -> match projectee with | { tm2 = tm; meta;_} -> tm -let (__proj__Mkterm'__Tm_meta__payload__item__meta : - term'__Tm_meta__payload -> metadata) = - fun projectee -> match projectee with | { tm2 = tm; meta;_} -> meta -let (uu___is_Tm_bvar : term' -> Prims.bool) = - fun projectee -> match projectee with | Tm_bvar _0 -> true | uu___ -> false -let (__proj__Tm_bvar__item___0 : term' -> bv) = - fun projectee -> match projectee with | Tm_bvar _0 -> _0 -let (uu___is_Tm_name : term' -> Prims.bool) = - fun projectee -> match projectee with | Tm_name _0 -> true | uu___ -> false -let (__proj__Tm_name__item___0 : term' -> bv) = - fun projectee -> match projectee with | Tm_name _0 -> _0 -let (uu___is_Tm_fvar : term' -> Prims.bool) = - fun projectee -> match projectee with | Tm_fvar _0 -> true | uu___ -> false -let (__proj__Tm_fvar__item___0 : term' -> fv) = - fun projectee -> match projectee with | Tm_fvar _0 -> _0 -let (uu___is_Tm_uinst : term' -> Prims.bool) = - fun projectee -> - match projectee with | Tm_uinst _0 -> true | uu___ -> false -let (__proj__Tm_uinst__item___0 : term' -> (term' syntax * universes)) = - fun projectee -> match projectee with | Tm_uinst _0 -> _0 -let (uu___is_Tm_constant : term' -> Prims.bool) = - fun projectee -> - match projectee with | Tm_constant _0 -> true | uu___ -> false -let (__proj__Tm_constant__item___0 : term' -> sconst) = - fun projectee -> match projectee with | Tm_constant _0 -> _0 -let (uu___is_Tm_type : term' -> Prims.bool) = - fun projectee -> match projectee with | Tm_type _0 -> true | uu___ -> false -let (__proj__Tm_type__item___0 : term' -> universe) = - fun projectee -> match projectee with | Tm_type _0 -> _0 -let (uu___is_Tm_abs : term' -> Prims.bool) = - fun projectee -> match projectee with | Tm_abs _0 -> true | uu___ -> false -let (__proj__Tm_abs__item___0 : term' -> term'__Tm_abs__payload) = - fun projectee -> match projectee with | Tm_abs _0 -> _0 -let (uu___is_Tm_arrow : term' -> Prims.bool) = - fun projectee -> - match projectee with | Tm_arrow _0 -> true | uu___ -> false -let (__proj__Tm_arrow__item___0 : term' -> term'__Tm_arrow__payload) = - fun projectee -> match projectee with | Tm_arrow _0 -> _0 -let (uu___is_Tm_refine : term' -> Prims.bool) = - fun projectee -> - match projectee with | Tm_refine _0 -> true | uu___ -> false -let (__proj__Tm_refine__item___0 : term' -> term'__Tm_refine__payload) = - fun projectee -> match projectee with | Tm_refine _0 -> _0 -let (uu___is_Tm_app : term' -> Prims.bool) = - fun projectee -> match projectee with | Tm_app _0 -> true | uu___ -> false -let (__proj__Tm_app__item___0 : term' -> term'__Tm_app__payload) = - fun projectee -> match projectee with | Tm_app _0 -> _0 -let (uu___is_Tm_match : term' -> Prims.bool) = - fun projectee -> - match projectee with | Tm_match _0 -> true | uu___ -> false -let (__proj__Tm_match__item___0 : term' -> term'__Tm_match__payload) = - fun projectee -> match projectee with | Tm_match _0 -> _0 -let (uu___is_Tm_ascribed : term' -> Prims.bool) = - fun projectee -> - match projectee with | Tm_ascribed _0 -> true | uu___ -> false -let (__proj__Tm_ascribed__item___0 : term' -> term'__Tm_ascribed__payload) = - fun projectee -> match projectee with | Tm_ascribed _0 -> _0 -let (uu___is_Tm_let : term' -> Prims.bool) = - fun projectee -> match projectee with | Tm_let _0 -> true | uu___ -> false -let (__proj__Tm_let__item___0 : term' -> term'__Tm_let__payload) = - fun projectee -> match projectee with | Tm_let _0 -> _0 -let (uu___is_Tm_uvar : term' -> Prims.bool) = - fun projectee -> match projectee with | Tm_uvar _0 -> true | uu___ -> false -let (__proj__Tm_uvar__item___0 : - term' -> - (ctx_uvar * (subst_elt Prims.list Prims.list * maybe_set_use_range))) - = fun projectee -> match projectee with | Tm_uvar _0 -> _0 -let (uu___is_Tm_delayed : term' -> Prims.bool) = - fun projectee -> - match projectee with | Tm_delayed _0 -> true | uu___ -> false -let (__proj__Tm_delayed__item___0 : term' -> term'__Tm_delayed__payload) = - fun projectee -> match projectee with | Tm_delayed _0 -> _0 -let (uu___is_Tm_meta : term' -> Prims.bool) = - fun projectee -> match projectee with | Tm_meta _0 -> true | uu___ -> false -let (__proj__Tm_meta__item___0 : term' -> term'__Tm_meta__payload) = - fun projectee -> match projectee with | Tm_meta _0 -> _0 -let (uu___is_Tm_lazy : term' -> Prims.bool) = - fun projectee -> match projectee with | Tm_lazy _0 -> true | uu___ -> false -let (__proj__Tm_lazy__item___0 : term' -> lazyinfo) = - fun projectee -> match projectee with | Tm_lazy _0 -> _0 -let (uu___is_Tm_quoted : term' -> Prims.bool) = - fun projectee -> - match projectee with | Tm_quoted _0 -> true | uu___ -> false -let (__proj__Tm_quoted__item___0 : term' -> (term' syntax * quoteinfo)) = - fun projectee -> match projectee with | Tm_quoted _0 -> _0 -let (uu___is_Tm_unknown : term' -> Prims.bool) = - fun projectee -> match projectee with | Tm_unknown -> true | uu___ -> false -let (__proj__Mkctx_uvar__item__ctx_uvar_head : - ctx_uvar -> - ((term' syntax FStar_Pervasives_Native.option * uvar_decoration) - FStar_Unionfind.p_uvar * version * FStar_Compiler_Range_Type.range)) - = - fun projectee -> - match projectee with - | { ctx_uvar_head; ctx_uvar_gamma; ctx_uvar_binders; ctx_uvar_reason; - ctx_uvar_range; ctx_uvar_meta;_} -> ctx_uvar_head -let (__proj__Mkctx_uvar__item__ctx_uvar_gamma : - ctx_uvar -> binding Prims.list) = - fun projectee -> - match projectee with - | { ctx_uvar_head; ctx_uvar_gamma; ctx_uvar_binders; ctx_uvar_reason; - ctx_uvar_range; ctx_uvar_meta;_} -> ctx_uvar_gamma -let (__proj__Mkctx_uvar__item__ctx_uvar_binders : - ctx_uvar -> binder Prims.list) = - fun projectee -> - match projectee with - | { ctx_uvar_head; ctx_uvar_gamma; ctx_uvar_binders; ctx_uvar_reason; - ctx_uvar_range; ctx_uvar_meta;_} -> ctx_uvar_binders -let (__proj__Mkctx_uvar__item__ctx_uvar_reason : ctx_uvar -> Prims.string) = - fun projectee -> - match projectee with - | { ctx_uvar_head; ctx_uvar_gamma; ctx_uvar_binders; ctx_uvar_reason; - ctx_uvar_range; ctx_uvar_meta;_} -> ctx_uvar_reason -let (__proj__Mkctx_uvar__item__ctx_uvar_range : - ctx_uvar -> FStar_Compiler_Range_Type.range) = - fun projectee -> - match projectee with - | { ctx_uvar_head; ctx_uvar_gamma; ctx_uvar_binders; ctx_uvar_reason; - ctx_uvar_range; ctx_uvar_meta;_} -> ctx_uvar_range -let (__proj__Mkctx_uvar__item__ctx_uvar_meta : - ctx_uvar -> ctx_uvar_meta_t FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { ctx_uvar_head; ctx_uvar_gamma; ctx_uvar_binders; ctx_uvar_reason; - ctx_uvar_range; ctx_uvar_meta;_} -> ctx_uvar_meta -let (uu___is_Ctx_uvar_meta_tac : ctx_uvar_meta_t -> Prims.bool) = - fun projectee -> - match projectee with | Ctx_uvar_meta_tac _0 -> true | uu___ -> false -let (__proj__Ctx_uvar_meta_tac__item___0 : ctx_uvar_meta_t -> term' syntax) = - fun projectee -> match projectee with | Ctx_uvar_meta_tac _0 -> _0 -let (uu___is_Ctx_uvar_meta_attr : ctx_uvar_meta_t -> Prims.bool) = - fun projectee -> - match projectee with | Ctx_uvar_meta_attr _0 -> true | uu___ -> false -let (__proj__Ctx_uvar_meta_attr__item___0 : ctx_uvar_meta_t -> term' syntax) - = fun projectee -> match projectee with | Ctx_uvar_meta_attr _0 -> _0 -let (__proj__Mkuvar_decoration__item__uvar_decoration_typ : - uvar_decoration -> term' syntax) = - fun projectee -> - match projectee with - | { uvar_decoration_typ; uvar_decoration_typedness_depends_on; - uvar_decoration_should_check; uvar_decoration_should_unrefine;_} -> - uvar_decoration_typ -let (__proj__Mkuvar_decoration__item__uvar_decoration_typedness_depends_on : - uvar_decoration -> ctx_uvar Prims.list) = - fun projectee -> - match projectee with - | { uvar_decoration_typ; uvar_decoration_typedness_depends_on; - uvar_decoration_should_check; uvar_decoration_should_unrefine;_} -> - uvar_decoration_typedness_depends_on -let (__proj__Mkuvar_decoration__item__uvar_decoration_should_check : - uvar_decoration -> should_check_uvar) = - fun projectee -> - match projectee with - | { uvar_decoration_typ; uvar_decoration_typedness_depends_on; - uvar_decoration_should_check; uvar_decoration_should_unrefine;_} -> - uvar_decoration_should_check -let (__proj__Mkuvar_decoration__item__uvar_decoration_should_unrefine : - uvar_decoration -> Prims.bool) = - fun projectee -> - match projectee with - | { uvar_decoration_typ; uvar_decoration_typedness_depends_on; - uvar_decoration_should_check; uvar_decoration_should_unrefine;_} -> - uvar_decoration_should_unrefine -let (uu___is_Pat_constant : pat' -> Prims.bool) = - fun projectee -> - match projectee with | Pat_constant _0 -> true | uu___ -> false -let (__proj__Pat_constant__item___0 : pat' -> sconst) = - fun projectee -> match projectee with | Pat_constant _0 -> _0 -let (uu___is_Pat_cons : pat' -> Prims.bool) = - fun projectee -> - match projectee with | Pat_cons _0 -> true | uu___ -> false -let (__proj__Pat_cons__item___0 : - pat' -> - (fv * universes FStar_Pervasives_Native.option * (pat' withinfo_t * - Prims.bool) Prims.list)) - = fun projectee -> match projectee with | Pat_cons _0 -> _0 -let (uu___is_Pat_var : pat' -> Prims.bool) = - fun projectee -> match projectee with | Pat_var _0 -> true | uu___ -> false -let (__proj__Pat_var__item___0 : pat' -> bv) = - fun projectee -> match projectee with | Pat_var _0 -> _0 -let (uu___is_Pat_dot_term : pat' -> Prims.bool) = - fun projectee -> - match projectee with | Pat_dot_term _0 -> true | uu___ -> false -let (__proj__Pat_dot_term__item___0 : - pat' -> term' syntax FStar_Pervasives_Native.option) = - fun projectee -> match projectee with | Pat_dot_term _0 -> _0 -let (__proj__Mkletbinding__item__lbname : - letbinding -> (bv, fv) FStar_Pervasives.either) = - fun projectee -> - match projectee with - | { lbname; lbunivs; lbtyp; lbeff; lbdef; lbattrs; lbpos;_} -> lbname -let (__proj__Mkletbinding__item__lbunivs : - letbinding -> univ_name Prims.list) = - fun projectee -> - match projectee with - | { lbname; lbunivs; lbtyp; lbeff; lbdef; lbattrs; lbpos;_} -> lbunivs -let (__proj__Mkletbinding__item__lbtyp : letbinding -> term' syntax) = - fun projectee -> - match projectee with - | { lbname; lbunivs; lbtyp; lbeff; lbdef; lbattrs; lbpos;_} -> lbtyp -let (__proj__Mkletbinding__item__lbeff : letbinding -> FStar_Ident.lident) = - fun projectee -> - match projectee with - | { lbname; lbunivs; lbtyp; lbeff; lbdef; lbattrs; lbpos;_} -> lbeff -let (__proj__Mkletbinding__item__lbdef : letbinding -> term' syntax) = - fun projectee -> - match projectee with - | { lbname; lbunivs; lbtyp; lbeff; lbdef; lbattrs; lbpos;_} -> lbdef -let (__proj__Mkletbinding__item__lbattrs : - letbinding -> term' syntax Prims.list) = - fun projectee -> - match projectee with - | { lbname; lbunivs; lbtyp; lbeff; lbdef; lbattrs; lbpos;_} -> lbattrs -let (__proj__Mkletbinding__item__lbpos : - letbinding -> FStar_Compiler_Range_Type.range) = - fun projectee -> - match projectee with - | { lbname; lbunivs; lbtyp; lbeff; lbdef; lbattrs; lbpos;_} -> lbpos -let (__proj__Mkquoteinfo__item__qkind : quoteinfo -> quote_kind) = - fun projectee -> match projectee with | { qkind; antiquotations;_} -> qkind -let (__proj__Mkquoteinfo__item__antiquotations : - quoteinfo -> (Prims.int * term' syntax Prims.list)) = - fun projectee -> - match projectee with | { qkind; antiquotations;_} -> antiquotations -let (__proj__Mkcomp_typ__item__comp_univs : comp_typ -> universes) = - fun projectee -> - match projectee with - | { comp_univs; effect_name; result_typ; effect_args; flags;_} -> - comp_univs -let (__proj__Mkcomp_typ__item__effect_name : comp_typ -> FStar_Ident.lident) - = - fun projectee -> - match projectee with - | { comp_univs; effect_name; result_typ; effect_args; flags;_} -> - effect_name -let (__proj__Mkcomp_typ__item__result_typ : comp_typ -> term' syntax) = - fun projectee -> - match projectee with - | { comp_univs; effect_name; result_typ; effect_args; flags;_} -> - result_typ -let (__proj__Mkcomp_typ__item__effect_args : - comp_typ -> - (term' syntax * arg_qualifier FStar_Pervasives_Native.option) Prims.list) - = - fun projectee -> - match projectee with - | { comp_univs; effect_name; result_typ; effect_args; flags;_} -> - effect_args -let (__proj__Mkcomp_typ__item__flags : comp_typ -> cflag Prims.list) = - fun projectee -> - match projectee with - | { comp_univs; effect_name; result_typ; effect_args; flags;_} -> flags -let (uu___is_Total : comp' -> Prims.bool) = - fun projectee -> match projectee with | Total _0 -> true | uu___ -> false -let (__proj__Total__item___0 : comp' -> term' syntax) = - fun projectee -> match projectee with | Total _0 -> _0 -let (uu___is_GTotal : comp' -> Prims.bool) = - fun projectee -> match projectee with | GTotal _0 -> true | uu___ -> false -let (__proj__GTotal__item___0 : comp' -> term' syntax) = - fun projectee -> match projectee with | GTotal _0 -> _0 -let (uu___is_Comp : comp' -> Prims.bool) = - fun projectee -> match projectee with | Comp _0 -> true | uu___ -> false -let (__proj__Comp__item___0 : comp' -> comp_typ) = - fun projectee -> match projectee with | Comp _0 -> _0 -let (__proj__Mkbinder__item__binder_bv : binder -> bv) = - fun projectee -> - match projectee with - | { binder_bv; binder_qual; binder_positivity; binder_attrs;_} -> - binder_bv -let (__proj__Mkbinder__item__binder_qual : - binder -> binder_qualifier FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { binder_bv; binder_qual; binder_positivity; binder_attrs;_} -> - binder_qual -let (__proj__Mkbinder__item__binder_positivity : - binder -> positivity_qualifier FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { binder_bv; binder_qual; binder_positivity; binder_attrs;_} -> - binder_positivity -let (__proj__Mkbinder__item__binder_attrs : - binder -> term' syntax Prims.list) = - fun projectee -> - match projectee with - | { binder_bv; binder_qual; binder_positivity; binder_attrs;_} -> - binder_attrs -let (uu___is_Decreases_lex : decreases_order -> Prims.bool) = - fun projectee -> - match projectee with | Decreases_lex _0 -> true | uu___ -> false -let (__proj__Decreases_lex__item___0 : - decreases_order -> term' syntax Prims.list) = - fun projectee -> match projectee with | Decreases_lex _0 -> _0 -let (uu___is_Decreases_wf : decreases_order -> Prims.bool) = - fun projectee -> - match projectee with | Decreases_wf _0 -> true | uu___ -> false -let (__proj__Decreases_wf__item___0 : - decreases_order -> (term' syntax * term' syntax)) = - fun projectee -> match projectee with | Decreases_wf _0 -> _0 -let (uu___is_TOTAL : cflag -> Prims.bool) = - fun projectee -> match projectee with | TOTAL -> true | uu___ -> false -let (uu___is_MLEFFECT : cflag -> Prims.bool) = - fun projectee -> match projectee with | MLEFFECT -> true | uu___ -> false -let (uu___is_LEMMA : cflag -> Prims.bool) = - fun projectee -> match projectee with | LEMMA -> true | uu___ -> false -let (uu___is_RETURN : cflag -> Prims.bool) = - fun projectee -> match projectee with | RETURN -> true | uu___ -> false -let (uu___is_PARTIAL_RETURN : cflag -> Prims.bool) = - fun projectee -> - match projectee with | PARTIAL_RETURN -> true | uu___ -> false -let (uu___is_SOMETRIVIAL : cflag -> Prims.bool) = - fun projectee -> - match projectee with | SOMETRIVIAL -> true | uu___ -> false -let (uu___is_TRIVIAL_POSTCONDITION : cflag -> Prims.bool) = - fun projectee -> - match projectee with | TRIVIAL_POSTCONDITION -> true | uu___ -> false -let (uu___is_SHOULD_NOT_INLINE : cflag -> Prims.bool) = - fun projectee -> - match projectee with | SHOULD_NOT_INLINE -> true | uu___ -> false -let (uu___is_CPS : cflag -> Prims.bool) = - fun projectee -> match projectee with | CPS -> true | uu___ -> false -let (uu___is_DECREASES : cflag -> Prims.bool) = - fun projectee -> - match projectee with | DECREASES _0 -> true | uu___ -> false -let (__proj__DECREASES__item___0 : cflag -> decreases_order) = - fun projectee -> match projectee with | DECREASES _0 -> _0 -let (uu___is_Meta_pattern : metadata -> Prims.bool) = - fun projectee -> - match projectee with | Meta_pattern _0 -> true | uu___ -> false -let (__proj__Meta_pattern__item___0 : - metadata -> - (term' syntax Prims.list * (term' syntax * arg_qualifier - FStar_Pervasives_Native.option) Prims.list Prims.list)) - = fun projectee -> match projectee with | Meta_pattern _0 -> _0 -let (uu___is_Meta_named : metadata -> Prims.bool) = - fun projectee -> - match projectee with | Meta_named _0 -> true | uu___ -> false -let (__proj__Meta_named__item___0 : metadata -> FStar_Ident.lident) = - fun projectee -> match projectee with | Meta_named _0 -> _0 -let (uu___is_Meta_labeled : metadata -> Prims.bool) = - fun projectee -> - match projectee with | Meta_labeled _0 -> true | uu___ -> false -let (__proj__Meta_labeled__item___0 : - metadata -> - (FStar_Pprint.document Prims.list * FStar_Compiler_Range_Type.range * - Prims.bool)) - = fun projectee -> match projectee with | Meta_labeled _0 -> _0 -let (uu___is_Meta_desugared : metadata -> Prims.bool) = - fun projectee -> - match projectee with | Meta_desugared _0 -> true | uu___ -> false -let (__proj__Meta_desugared__item___0 : metadata -> meta_source_info) = - fun projectee -> match projectee with | Meta_desugared _0 -> _0 -let (uu___is_Meta_monadic : metadata -> Prims.bool) = - fun projectee -> - match projectee with | Meta_monadic _0 -> true | uu___ -> false -let (__proj__Meta_monadic__item___0 : - metadata -> (monad_name * term' syntax)) = - fun projectee -> match projectee with | Meta_monadic _0 -> _0 -let (uu___is_Meta_monadic_lift : metadata -> Prims.bool) = - fun projectee -> - match projectee with | Meta_monadic_lift _0 -> true | uu___ -> false -let (__proj__Meta_monadic_lift__item___0 : - metadata -> (monad_name * monad_name * term' syntax)) = - fun projectee -> match projectee with | Meta_monadic_lift _0 -> _0 -let (uu___is_Sequence : meta_source_info -> Prims.bool) = - fun projectee -> match projectee with | Sequence -> true | uu___ -> false -let (uu___is_Primop : meta_source_info -> Prims.bool) = - fun projectee -> match projectee with | Primop -> true | uu___ -> false -let (uu___is_Masked_effect : meta_source_info -> Prims.bool) = - fun projectee -> - match projectee with | Masked_effect -> true | uu___ -> false -let (uu___is_Meta_smt_pat : meta_source_info -> Prims.bool) = - fun projectee -> - match projectee with | Meta_smt_pat -> true | uu___ -> false -let (uu___is_Machine_integer : meta_source_info -> Prims.bool) = - fun projectee -> - match projectee with | Machine_integer _0 -> true | uu___ -> false -let (__proj__Machine_integer__item___0 : - meta_source_info -> (FStar_Const.signedness * FStar_Const.width)) = - fun projectee -> match projectee with | Machine_integer _0 -> _0 -let (uu___is_Data_ctor : fv_qual -> Prims.bool) = - fun projectee -> match projectee with | Data_ctor -> true | uu___ -> false -let (uu___is_Record_projector : fv_qual -> Prims.bool) = - fun projectee -> - match projectee with | Record_projector _0 -> true | uu___ -> false -let (__proj__Record_projector__item___0 : - fv_qual -> (FStar_Ident.lident * FStar_Ident.ident)) = - fun projectee -> match projectee with | Record_projector _0 -> _0 -let (uu___is_Record_ctor : fv_qual -> Prims.bool) = - fun projectee -> - match projectee with | Record_ctor _0 -> true | uu___ -> false -let (__proj__Record_ctor__item___0 : - fv_qual -> (FStar_Ident.lident * FStar_Ident.ident Prims.list)) = - fun projectee -> match projectee with | Record_ctor _0 -> _0 -let (uu___is_Unresolved_projector : fv_qual -> Prims.bool) = - fun projectee -> - match projectee with | Unresolved_projector _0 -> true | uu___ -> false -let (__proj__Unresolved_projector__item___0 : - fv_qual -> fv FStar_Pervasives_Native.option) = - fun projectee -> match projectee with | Unresolved_projector _0 -> _0 -let (uu___is_Unresolved_constructor : fv_qual -> Prims.bool) = - fun projectee -> - match projectee with | Unresolved_constructor _0 -> true | uu___ -> false -let (__proj__Unresolved_constructor__item___0 : - fv_qual -> unresolved_constructor) = - fun projectee -> match projectee with | Unresolved_constructor _0 -> _0 -let (__proj__Mkunresolved_constructor__item__uc_base_term : - unresolved_constructor -> Prims.bool) = - fun projectee -> - match projectee with - | { uc_base_term; uc_typename; uc_fields;_} -> uc_base_term -let (__proj__Mkunresolved_constructor__item__uc_typename : - unresolved_constructor -> FStar_Ident.lident FStar_Pervasives_Native.option) - = - fun projectee -> - match projectee with - | { uc_base_term; uc_typename; uc_fields;_} -> uc_typename -let (__proj__Mkunresolved_constructor__item__uc_fields : - unresolved_constructor -> FStar_Ident.lident Prims.list) = - fun projectee -> - match projectee with - | { uc_base_term; uc_typename; uc_fields;_} -> uc_fields -let (uu___is_DB : subst_elt -> Prims.bool) = - fun projectee -> match projectee with | DB _0 -> true | uu___ -> false -let (__proj__DB__item___0 : subst_elt -> (Prims.int * bv)) = - fun projectee -> match projectee with | DB _0 -> _0 -let (uu___is_DT : subst_elt -> Prims.bool) = - fun projectee -> match projectee with | DT _0 -> true | uu___ -> false -let (__proj__DT__item___0 : subst_elt -> (Prims.int * term' syntax)) = - fun projectee -> match projectee with | DT _0 -> _0 -let (uu___is_NM : subst_elt -> Prims.bool) = - fun projectee -> match projectee with | NM _0 -> true | uu___ -> false -let (__proj__NM__item___0 : subst_elt -> (bv * Prims.int)) = - fun projectee -> match projectee with | NM _0 -> _0 -let (uu___is_NT : subst_elt -> Prims.bool) = - fun projectee -> match projectee with | NT _0 -> true | uu___ -> false -let (__proj__NT__item___0 : subst_elt -> (bv * term' syntax)) = - fun projectee -> match projectee with | NT _0 -> _0 -let (uu___is_UN : subst_elt -> Prims.bool) = - fun projectee -> match projectee with | UN _0 -> true | uu___ -> false -let (__proj__UN__item___0 : subst_elt -> (Prims.int * universe)) = - fun projectee -> match projectee with | UN _0 -> _0 -let (uu___is_UD : subst_elt -> Prims.bool) = - fun projectee -> match projectee with | UD _0 -> true | uu___ -> false -let (__proj__UD__item___0 : subst_elt -> (univ_name * Prims.int)) = - fun projectee -> match projectee with | UD _0 -> _0 -let __proj__Mksyntax__item__n : 'a . 'a syntax -> 'a = - fun projectee -> match projectee with | { n; pos; vars; hash_code;_} -> n -let __proj__Mksyntax__item__pos : - 'a . 'a syntax -> FStar_Compiler_Range_Type.range = - fun projectee -> match projectee with | { n; pos; vars; hash_code;_} -> pos -let __proj__Mksyntax__item__vars : 'a . 'a syntax -> free_vars memo = - fun projectee -> - match projectee with | { n; pos; vars; hash_code;_} -> vars -let __proj__Mksyntax__item__hash_code : - 'a . 'a syntax -> FStar_Hash.hash_code memo = - fun projectee -> - match projectee with | { n; pos; vars; hash_code;_} -> hash_code -let (__proj__Mkbv__item__ppname : bv -> FStar_Ident.ident) = - fun projectee -> match projectee with | { ppname; index; sort;_} -> ppname -let (__proj__Mkbv__item__index : bv -> Prims.int) = - fun projectee -> match projectee with | { ppname; index; sort;_} -> index -let (__proj__Mkbv__item__sort : bv -> term' syntax) = - fun projectee -> match projectee with | { ppname; index; sort;_} -> sort -let (__proj__Mkfv__item__fv_name : fv -> var) = - fun projectee -> - match projectee with | { fv_name; fv_qual = fv_qual1;_} -> fv_name -let (__proj__Mkfv__item__fv_qual : - fv -> fv_qual FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with | { fv_name; fv_qual = fv_qual1;_} -> fv_qual1 -let (__proj__Mkfree_vars__item__free_names : - free_vars -> bv FStar_Compiler_FlatSet.t) = - fun projectee -> - match projectee with - | { free_names; free_uvars; free_univs; free_univ_names;_} -> free_names -let (__proj__Mkfree_vars__item__free_uvars : - free_vars -> ctx_uvar FStar_Compiler_FlatSet.t) = - fun projectee -> - match projectee with - | { free_names; free_uvars; free_univs; free_univ_names;_} -> free_uvars -let (__proj__Mkfree_vars__item__free_univs : - free_vars -> universe_uvar FStar_Compiler_FlatSet.t) = - fun projectee -> - match projectee with - | { free_names; free_uvars; free_univs; free_univ_names;_} -> free_univs -let (__proj__Mkfree_vars__item__free_univ_names : - free_vars -> univ_name FStar_Compiler_FlatSet.t) = - fun projectee -> - match projectee with - | { free_names; free_uvars; free_univs; free_univ_names;_} -> - free_univ_names -let (__proj__Mkresidual_comp__item__residual_effect : - residual_comp -> FStar_Ident.lident) = - fun projectee -> - match projectee with - | { residual_effect; residual_typ; residual_flags;_} -> residual_effect -let (__proj__Mkresidual_comp__item__residual_typ : - residual_comp -> term' syntax FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { residual_effect; residual_typ; residual_flags;_} -> residual_typ -let (__proj__Mkresidual_comp__item__residual_flags : - residual_comp -> cflag Prims.list) = - fun projectee -> - match projectee with - | { residual_effect; residual_typ; residual_flags;_} -> residual_flags -let (__proj__Mklazyinfo__item__blob : lazyinfo -> FStar_Dyn.dyn) = - fun projectee -> match projectee with | { blob; lkind; ltyp; rng;_} -> blob -let (__proj__Mklazyinfo__item__lkind : lazyinfo -> lazy_kind) = - fun projectee -> - match projectee with | { blob; lkind; ltyp; rng;_} -> lkind -let (__proj__Mklazyinfo__item__ltyp : lazyinfo -> term' syntax) = - fun projectee -> match projectee with | { blob; lkind; ltyp; rng;_} -> ltyp -let (__proj__Mklazyinfo__item__rng : - lazyinfo -> FStar_Compiler_Range_Type.range) = - fun projectee -> match projectee with | { blob; lkind; ltyp; rng;_} -> rng -let (uu___is_BadLazy : lazy_kind -> Prims.bool) = - fun projectee -> match projectee with | BadLazy -> true | uu___ -> false -let (uu___is_Lazy_bv : lazy_kind -> Prims.bool) = - fun projectee -> match projectee with | Lazy_bv -> true | uu___ -> false -let (uu___is_Lazy_namedv : lazy_kind -> Prims.bool) = - fun projectee -> - match projectee with | Lazy_namedv -> true | uu___ -> false -let (uu___is_Lazy_binder : lazy_kind -> Prims.bool) = - fun projectee -> - match projectee with | Lazy_binder -> true | uu___ -> false -let (uu___is_Lazy_optionstate : lazy_kind -> Prims.bool) = - fun projectee -> - match projectee with | Lazy_optionstate -> true | uu___ -> false -let (uu___is_Lazy_fvar : lazy_kind -> Prims.bool) = - fun projectee -> match projectee with | Lazy_fvar -> true | uu___ -> false -let (uu___is_Lazy_comp : lazy_kind -> Prims.bool) = - fun projectee -> match projectee with | Lazy_comp -> true | uu___ -> false -let (uu___is_Lazy_env : lazy_kind -> Prims.bool) = - fun projectee -> match projectee with | Lazy_env -> true | uu___ -> false -let (uu___is_Lazy_proofstate : lazy_kind -> Prims.bool) = - fun projectee -> - match projectee with | Lazy_proofstate -> true | uu___ -> false -let (uu___is_Lazy_goal : lazy_kind -> Prims.bool) = - fun projectee -> match projectee with | Lazy_goal -> true | uu___ -> false -let (uu___is_Lazy_sigelt : lazy_kind -> Prims.bool) = - fun projectee -> - match projectee with | Lazy_sigelt -> true | uu___ -> false -let (uu___is_Lazy_uvar : lazy_kind -> Prims.bool) = - fun projectee -> match projectee with | Lazy_uvar -> true | uu___ -> false -let (uu___is_Lazy_letbinding : lazy_kind -> Prims.bool) = - fun projectee -> - match projectee with | Lazy_letbinding -> true | uu___ -> false -let (uu___is_Lazy_embedding : lazy_kind -> Prims.bool) = - fun projectee -> - match projectee with | Lazy_embedding _0 -> true | uu___ -> false -let (__proj__Lazy_embedding__item___0 : - lazy_kind -> (emb_typ * term' syntax FStar_Thunk.t)) = - fun projectee -> match projectee with | Lazy_embedding _0 -> _0 -let (uu___is_Lazy_universe : lazy_kind -> Prims.bool) = - fun projectee -> - match projectee with | Lazy_universe -> true | uu___ -> false -let (uu___is_Lazy_universe_uvar : lazy_kind -> Prims.bool) = - fun projectee -> - match projectee with | Lazy_universe_uvar -> true | uu___ -> false -let (uu___is_Lazy_issue : lazy_kind -> Prims.bool) = - fun projectee -> match projectee with | Lazy_issue -> true | uu___ -> false -let (uu___is_Lazy_ident : lazy_kind -> Prims.bool) = - fun projectee -> match projectee with | Lazy_ident -> true | uu___ -> false -let (uu___is_Lazy_doc : lazy_kind -> Prims.bool) = - fun projectee -> match projectee with | Lazy_doc -> true | uu___ -> false -let (uu___is_Lazy_extension : lazy_kind -> Prims.bool) = - fun projectee -> - match projectee with | Lazy_extension _0 -> true | uu___ -> false -let (__proj__Lazy_extension__item___0 : lazy_kind -> Prims.string) = - fun projectee -> match projectee with | Lazy_extension _0 -> _0 -let (uu___is_Lazy_tref : lazy_kind -> Prims.bool) = - fun projectee -> match projectee with | Lazy_tref -> true | uu___ -> false -let (uu___is_Binding_var : binding -> Prims.bool) = - fun projectee -> - match projectee with | Binding_var _0 -> true | uu___ -> false -let (__proj__Binding_var__item___0 : binding -> bv) = - fun projectee -> match projectee with | Binding_var _0 -> _0 -let (uu___is_Binding_lid : binding -> Prims.bool) = - fun projectee -> - match projectee with | Binding_lid _0 -> true | uu___ -> false -let (__proj__Binding_lid__item___0 : - binding -> (FStar_Ident.lident * (univ_names * term' syntax))) = - fun projectee -> match projectee with | Binding_lid _0 -> _0 -let (uu___is_Binding_univ : binding -> Prims.bool) = - fun projectee -> - match projectee with | Binding_univ _0 -> true | uu___ -> false -let (__proj__Binding_univ__item___0 : binding -> univ_name) = - fun projectee -> match projectee with | Binding_univ _0 -> _0 -let (uu___is_Implicit : binder_qualifier -> Prims.bool) = - fun projectee -> - match projectee with | Implicit _0 -> true | uu___ -> false -let (__proj__Implicit__item___0 : binder_qualifier -> Prims.bool) = - fun projectee -> match projectee with | Implicit _0 -> _0 -let (uu___is_Meta : binder_qualifier -> Prims.bool) = - fun projectee -> match projectee with | Meta _0 -> true | uu___ -> false -let (__proj__Meta__item___0 : binder_qualifier -> term' syntax) = - fun projectee -> match projectee with | Meta _0 -> _0 -let (uu___is_Equality : binder_qualifier -> Prims.bool) = - fun projectee -> match projectee with | Equality -> true | uu___ -> false -let (__proj__Mkarg_qualifier__item__aqual_implicit : - arg_qualifier -> Prims.bool) = - fun projectee -> - match projectee with - | { aqual_implicit; aqual_attributes;_} -> aqual_implicit -let (__proj__Mkarg_qualifier__item__aqual_attributes : - arg_qualifier -> term' syntax Prims.list) = - fun projectee -> - match projectee with - | { aqual_implicit; aqual_attributes;_} -> aqual_attributes -type subst_ts = (subst_elt Prims.list Prims.list * maybe_set_use_range) -type ctx_uvar_and_subst = - (ctx_uvar * (subst_elt Prims.list Prims.list * maybe_set_use_range)) -type term = term' syntax -type uvar = - ((term' syntax FStar_Pervasives_Native.option * uvar_decoration) - FStar_Unionfind.p_uvar * version * FStar_Compiler_Range_Type.range) -type uvars = ctx_uvar FStar_Compiler_FlatSet.t -type comp = comp' syntax -type ascription = - ((term' syntax, comp' syntax) FStar_Pervasives.either * term' syntax - FStar_Pervasives_Native.option * Prims.bool) -type match_returns_ascription = - (binder * ((term' syntax, comp' syntax) FStar_Pervasives.either * term' - syntax FStar_Pervasives_Native.option * Prims.bool)) -type pat = pat' withinfo_t -type branch = - (pat' withinfo_t * term' syntax FStar_Pervasives_Native.option * term' - syntax) -type antiquotations = (Prims.int * term' syntax Prims.list) -type typ = term' syntax -type aqual = arg_qualifier FStar_Pervasives_Native.option -type arg = (term' syntax * arg_qualifier FStar_Pervasives_Native.option) -type args = - (term' syntax * arg_qualifier FStar_Pervasives_Native.option) Prims.list -type binders = binder Prims.list -type lbname = (bv, fv) FStar_Pervasives.either -type letbindings = (Prims.bool * letbinding Prims.list) -type freenames = bv FStar_Compiler_FlatSet.t -type attribute = term' syntax -type tscheme = (univ_name Prims.list * term' syntax) -type gamma = binding Prims.list -type bqual = binder_qualifier FStar_Pervasives_Native.option -type freenames_l = bv Prims.list -type formula = typ -type formulae = typ Prims.list -type qualifier = - | Assumption - | New - | Private - | Unfold_for_unification_and_vcgen - | Irreducible - | Inline_for_extraction - | NoExtract - | Noeq - | Unopteq - | TotalEffect - | Logic - | Reifiable - | Reflectable of FStar_Ident.lident - | Visible_default - | Discriminator of FStar_Ident.lident - | Projector of (FStar_Ident.lident * FStar_Ident.ident) - | RecordType of (FStar_Ident.ident Prims.list * FStar_Ident.ident - Prims.list) - | RecordConstructor of (FStar_Ident.ident Prims.list * FStar_Ident.ident - Prims.list) - | Action of FStar_Ident.lident - | ExceptionConstructor - | HasMaskedEffect - | Effect - | OnlyName - | InternalAssumption -let (uu___is_Assumption : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Assumption -> true | uu___ -> false -let (uu___is_New : qualifier -> Prims.bool) = - fun projectee -> match projectee with | New -> true | uu___ -> false -let (uu___is_Private : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Private -> true | uu___ -> false -let (uu___is_Unfold_for_unification_and_vcgen : qualifier -> Prims.bool) = - fun projectee -> - match projectee with - | Unfold_for_unification_and_vcgen -> true - | uu___ -> false -let (uu___is_Irreducible : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | Irreducible -> true | uu___ -> false -let (uu___is_Inline_for_extraction : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | Inline_for_extraction -> true | uu___ -> false -let (uu___is_NoExtract : qualifier -> Prims.bool) = - fun projectee -> match projectee with | NoExtract -> true | uu___ -> false -let (uu___is_Noeq : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Noeq -> true | uu___ -> false -let (uu___is_Unopteq : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Unopteq -> true | uu___ -> false -let (uu___is_TotalEffect : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | TotalEffect -> true | uu___ -> false -let (uu___is_Logic : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Logic -> true | uu___ -> false -let (uu___is_Reifiable : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Reifiable -> true | uu___ -> false -let (uu___is_Reflectable : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | Reflectable _0 -> true | uu___ -> false -let (__proj__Reflectable__item___0 : qualifier -> FStar_Ident.lident) = - fun projectee -> match projectee with | Reflectable _0 -> _0 -let (uu___is_Visible_default : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | Visible_default -> true | uu___ -> false -let (uu___is_Discriminator : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | Discriminator _0 -> true | uu___ -> false -let (__proj__Discriminator__item___0 : qualifier -> FStar_Ident.lident) = - fun projectee -> match projectee with | Discriminator _0 -> _0 -let (uu___is_Projector : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | Projector _0 -> true | uu___ -> false -let (__proj__Projector__item___0 : - qualifier -> (FStar_Ident.lident * FStar_Ident.ident)) = - fun projectee -> match projectee with | Projector _0 -> _0 -let (uu___is_RecordType : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | RecordType _0 -> true | uu___ -> false -let (__proj__RecordType__item___0 : - qualifier -> (FStar_Ident.ident Prims.list * FStar_Ident.ident Prims.list)) - = fun projectee -> match projectee with | RecordType _0 -> _0 -let (uu___is_RecordConstructor : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | RecordConstructor _0 -> true | uu___ -> false -let (__proj__RecordConstructor__item___0 : - qualifier -> (FStar_Ident.ident Prims.list * FStar_Ident.ident Prims.list)) - = fun projectee -> match projectee with | RecordConstructor _0 -> _0 -let (uu___is_Action : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Action _0 -> true | uu___ -> false -let (__proj__Action__item___0 : qualifier -> FStar_Ident.lident) = - fun projectee -> match projectee with | Action _0 -> _0 -let (uu___is_ExceptionConstructor : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | ExceptionConstructor -> true | uu___ -> false -let (uu___is_HasMaskedEffect : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | HasMaskedEffect -> true | uu___ -> false -let (uu___is_Effect : qualifier -> Prims.bool) = - fun projectee -> match projectee with | Effect -> true | uu___ -> false -let (uu___is_OnlyName : qualifier -> Prims.bool) = - fun projectee -> match projectee with | OnlyName -> true | uu___ -> false -let (uu___is_InternalAssumption : qualifier -> Prims.bool) = - fun projectee -> - match projectee with | InternalAssumption -> true | uu___ -> false -let rec (emb_typ_to_string : emb_typ -> Prims.string) = - fun uu___ -> - match uu___ with - | ET_abstract -> "abstract" - | ET_app (h, []) -> h - | ET_app (h, args1) -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Compiler_List.map emb_typ_to_string args1 in - FStar_Compiler_String.concat " " uu___5 in - Prims.strcat uu___4 ")" in - Prims.strcat " " uu___3 in - Prims.strcat h uu___2 in - Prims.strcat "(" uu___1 - | ET_fun (a, b) -> - let uu___1 = - let uu___2 = emb_typ_to_string a in - let uu___3 = - let uu___4 = emb_typ_to_string b in Prims.strcat ") -> " uu___4 in - Prims.strcat uu___2 uu___3 in - Prims.strcat "(" uu___1 -let (showable_emb_typ : emb_typ FStar_Class_Show.showable) = - { FStar_Class_Show.show = emb_typ_to_string } -let rec (delta_depth_to_string : delta_depth -> Prims.string) = - fun uu___ -> - match uu___ with - | Delta_constant_at_level i -> - let uu___1 = FStar_Compiler_Util.string_of_int i in - Prims.strcat "Delta_constant_at_level " uu___1 - | Delta_equational_at_level i -> - let uu___1 = FStar_Compiler_Util.string_of_int i in - Prims.strcat "Delta_equational_at_level " uu___1 - | Delta_abstract d -> - let uu___1 = - let uu___2 = delta_depth_to_string d in Prims.strcat uu___2 ")" in - Prims.strcat "Delta_abstract (" uu___1 -let (showable_delta_depth : delta_depth FStar_Class_Show.showable) = - { FStar_Class_Show.show = delta_depth_to_string } -let (showable_should_check_uvar : - should_check_uvar FStar_Class_Show.showable) = - { - FStar_Class_Show.show = - (fun uu___ -> - match uu___ with - | Allow_unresolved s -> Prims.strcat "Allow_unresolved " s - | Allow_untyped s -> Prims.strcat "Allow_untyped " s - | Allow_ghost s -> Prims.strcat "Allow_ghost " s - | Strict -> "Strict" - | Already_checked -> "Already_checked") - } -let (lazy_chooser : - (lazy_kind -> lazyinfo -> term) FStar_Pervasives_Native.option - FStar_Compiler_Effect.ref) - = FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None -let (is_internal_qualifier : qualifier -> Prims.bool) = - fun q -> - match q with - | Visible_default -> true - | Discriminator uu___ -> true - | Projector uu___ -> true - | RecordType uu___ -> true - | RecordConstructor uu___ -> true - | Action uu___ -> true - | ExceptionConstructor -> true - | HasMaskedEffect -> true - | Effect -> true - | OnlyName -> true - | InternalAssumption -> true - | uu___ -> false -type tycon = (FStar_Ident.lident * binders * typ) -type monad_abbrev = { - mabbrev: FStar_Ident.lident ; - parms: binders ; - def: typ } -let (__proj__Mkmonad_abbrev__item__mabbrev : - monad_abbrev -> FStar_Ident.lident) = - fun projectee -> match projectee with | { mabbrev; parms; def;_} -> mabbrev -let (__proj__Mkmonad_abbrev__item__parms : monad_abbrev -> binders) = - fun projectee -> match projectee with | { mabbrev; parms; def;_} -> parms -let (__proj__Mkmonad_abbrev__item__def : monad_abbrev -> typ) = - fun projectee -> match projectee with | { mabbrev; parms; def;_} -> def -type indexed_effect_binder_kind = - | Type_binder - | Substitutive_binder - | BindCont_no_abstraction_binder - | Range_binder - | Repr_binder - | Ad_hoc_binder -let (uu___is_Type_binder : indexed_effect_binder_kind -> Prims.bool) = - fun projectee -> - match projectee with | Type_binder -> true | uu___ -> false -let (uu___is_Substitutive_binder : indexed_effect_binder_kind -> Prims.bool) - = - fun projectee -> - match projectee with | Substitutive_binder -> true | uu___ -> false -let (uu___is_BindCont_no_abstraction_binder : - indexed_effect_binder_kind -> Prims.bool) = - fun projectee -> - match projectee with - | BindCont_no_abstraction_binder -> true - | uu___ -> false -let (uu___is_Range_binder : indexed_effect_binder_kind -> Prims.bool) = - fun projectee -> - match projectee with | Range_binder -> true | uu___ -> false -let (uu___is_Repr_binder : indexed_effect_binder_kind -> Prims.bool) = - fun projectee -> - match projectee with | Repr_binder -> true | uu___ -> false -let (uu___is_Ad_hoc_binder : indexed_effect_binder_kind -> Prims.bool) = - fun projectee -> - match projectee with | Ad_hoc_binder -> true | uu___ -> false -let (showable_indexed_effect_binder_kind : - indexed_effect_binder_kind FStar_Class_Show.showable) = - { - FStar_Class_Show.show = - (fun uu___ -> - match uu___ with - | Type_binder -> "Type_binder" - | Substitutive_binder -> "Substitutive_binder" - | BindCont_no_abstraction_binder -> "BindCont_no_abstraction_binder" - | Range_binder -> "Range_binder" - | Repr_binder -> "Repr_binder" - | Ad_hoc_binder -> "Ad_hoc_binder") - } -let (tagged_indexed_effect_binder_kind : - indexed_effect_binder_kind FStar_Class_Tagged.tagged) = - { - FStar_Class_Tagged.tag_of = - (fun uu___ -> - match uu___ with - | Type_binder -> "Type_binder" - | Substitutive_binder -> "Substitutive_binder" - | BindCont_no_abstraction_binder -> "BindCont_no_abstraction_binder" - | Range_binder -> "Range_binder" - | Repr_binder -> "Repr_binder" - | Ad_hoc_binder -> "Ad_hoc_binder") - } -type indexed_effect_combinator_kind = - | Substitutive_combinator of indexed_effect_binder_kind Prims.list - | Substitutive_invariant_combinator - | Ad_hoc_combinator -let (uu___is_Substitutive_combinator : - indexed_effect_combinator_kind -> Prims.bool) = - fun projectee -> - match projectee with - | Substitutive_combinator _0 -> true - | uu___ -> false -let (__proj__Substitutive_combinator__item___0 : - indexed_effect_combinator_kind -> indexed_effect_binder_kind Prims.list) = - fun projectee -> match projectee with | Substitutive_combinator _0 -> _0 -let (uu___is_Substitutive_invariant_combinator : - indexed_effect_combinator_kind -> Prims.bool) = - fun projectee -> - match projectee with - | Substitutive_invariant_combinator -> true - | uu___ -> false -let (uu___is_Ad_hoc_combinator : - indexed_effect_combinator_kind -> Prims.bool) = - fun projectee -> - match projectee with | Ad_hoc_combinator -> true | uu___ -> false -let (showable_indexed_effect_combinator_kind : - indexed_effect_combinator_kind FStar_Class_Show.showable) = - { - FStar_Class_Show.show = - (fun uu___ -> - match uu___ with - | Substitutive_combinator ks -> - let uu___1 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - showable_indexed_effect_binder_kind) ks in - Prims.strcat "Substitutive_combinator " uu___1 - | Substitutive_invariant_combinator -> - "Substitutive_invariant_combinator" - | Ad_hoc_combinator -> "Ad_hoc_combinator") - } -let (tagged_indexed_effect_combinator_kind : - indexed_effect_combinator_kind FStar_Class_Tagged.tagged) = - { - FStar_Class_Tagged.tag_of = - (fun uu___ -> - match uu___ with - | Substitutive_combinator uu___1 -> "Substitutive_combinator" - | Substitutive_invariant_combinator -> - "Substitutive_invariant_combinator" - | Ad_hoc_combinator -> "Ad_hoc_combinator") - } -type sub_eff = - { - source: FStar_Ident.lident ; - target: FStar_Ident.lident ; - lift_wp: tscheme FStar_Pervasives_Native.option ; - lift: tscheme FStar_Pervasives_Native.option ; - kind: indexed_effect_combinator_kind FStar_Pervasives_Native.option } -let (__proj__Mksub_eff__item__source : sub_eff -> FStar_Ident.lident) = - fun projectee -> - match projectee with | { source; target; lift_wp; lift; kind;_} -> source -let (__proj__Mksub_eff__item__target : sub_eff -> FStar_Ident.lident) = - fun projectee -> - match projectee with | { source; target; lift_wp; lift; kind;_} -> target -let (__proj__Mksub_eff__item__lift_wp : - sub_eff -> tscheme FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { source; target; lift_wp; lift; kind;_} -> lift_wp -let (__proj__Mksub_eff__item__lift : - sub_eff -> tscheme FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with | { source; target; lift_wp; lift; kind;_} -> lift -let (__proj__Mksub_eff__item__kind : - sub_eff -> indexed_effect_combinator_kind FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with | { source; target; lift_wp; lift; kind;_} -> kind -type action = - { - action_name: FStar_Ident.lident ; - action_unqualified_name: FStar_Ident.ident ; - action_univs: univ_names ; - action_params: binders ; - action_defn: term ; - action_typ: typ } -let (__proj__Mkaction__item__action_name : action -> FStar_Ident.lident) = - fun projectee -> - match projectee with - | { action_name; action_unqualified_name; action_univs; action_params; - action_defn; action_typ;_} -> action_name -let (__proj__Mkaction__item__action_unqualified_name : - action -> FStar_Ident.ident) = - fun projectee -> - match projectee with - | { action_name; action_unqualified_name; action_univs; action_params; - action_defn; action_typ;_} -> action_unqualified_name -let (__proj__Mkaction__item__action_univs : action -> univ_names) = - fun projectee -> - match projectee with - | { action_name; action_unqualified_name; action_univs; action_params; - action_defn; action_typ;_} -> action_univs -let (__proj__Mkaction__item__action_params : action -> binders) = - fun projectee -> - match projectee with - | { action_name; action_unqualified_name; action_univs; action_params; - action_defn; action_typ;_} -> action_params -let (__proj__Mkaction__item__action_defn : action -> term) = - fun projectee -> - match projectee with - | { action_name; action_unqualified_name; action_univs; action_params; - action_defn; action_typ;_} -> action_defn -let (__proj__Mkaction__item__action_typ : action -> typ) = - fun projectee -> - match projectee with - | { action_name; action_unqualified_name; action_univs; action_params; - action_defn; action_typ;_} -> action_typ -type wp_eff_combinators = - { - ret_wp: tscheme ; - bind_wp: tscheme ; - stronger: tscheme ; - if_then_else: tscheme ; - ite_wp: tscheme ; - close_wp: tscheme ; - trivial: tscheme ; - repr: tscheme FStar_Pervasives_Native.option ; - return_repr: tscheme FStar_Pervasives_Native.option ; - bind_repr: tscheme FStar_Pervasives_Native.option } -let (__proj__Mkwp_eff_combinators__item__ret_wp : - wp_eff_combinators -> tscheme) = - fun projectee -> - match projectee with - | { ret_wp; bind_wp; stronger; if_then_else; ite_wp; close_wp; trivial; - repr; return_repr; bind_repr;_} -> ret_wp -let (__proj__Mkwp_eff_combinators__item__bind_wp : - wp_eff_combinators -> tscheme) = - fun projectee -> - match projectee with - | { ret_wp; bind_wp; stronger; if_then_else; ite_wp; close_wp; trivial; - repr; return_repr; bind_repr;_} -> bind_wp -let (__proj__Mkwp_eff_combinators__item__stronger : - wp_eff_combinators -> tscheme) = - fun projectee -> - match projectee with - | { ret_wp; bind_wp; stronger; if_then_else; ite_wp; close_wp; trivial; - repr; return_repr; bind_repr;_} -> stronger -let (__proj__Mkwp_eff_combinators__item__if_then_else : - wp_eff_combinators -> tscheme) = - fun projectee -> - match projectee with - | { ret_wp; bind_wp; stronger; if_then_else; ite_wp; close_wp; trivial; - repr; return_repr; bind_repr;_} -> if_then_else -let (__proj__Mkwp_eff_combinators__item__ite_wp : - wp_eff_combinators -> tscheme) = - fun projectee -> - match projectee with - | { ret_wp; bind_wp; stronger; if_then_else; ite_wp; close_wp; trivial; - repr; return_repr; bind_repr;_} -> ite_wp -let (__proj__Mkwp_eff_combinators__item__close_wp : - wp_eff_combinators -> tscheme) = - fun projectee -> - match projectee with - | { ret_wp; bind_wp; stronger; if_then_else; ite_wp; close_wp; trivial; - repr; return_repr; bind_repr;_} -> close_wp -let (__proj__Mkwp_eff_combinators__item__trivial : - wp_eff_combinators -> tscheme) = - fun projectee -> - match projectee with - | { ret_wp; bind_wp; stronger; if_then_else; ite_wp; close_wp; trivial; - repr; return_repr; bind_repr;_} -> trivial -let (__proj__Mkwp_eff_combinators__item__repr : - wp_eff_combinators -> tscheme FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { ret_wp; bind_wp; stronger; if_then_else; ite_wp; close_wp; trivial; - repr; return_repr; bind_repr;_} -> repr -let (__proj__Mkwp_eff_combinators__item__return_repr : - wp_eff_combinators -> tscheme FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { ret_wp; bind_wp; stronger; if_then_else; ite_wp; close_wp; trivial; - repr; return_repr; bind_repr;_} -> return_repr -let (__proj__Mkwp_eff_combinators__item__bind_repr : - wp_eff_combinators -> tscheme FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { ret_wp; bind_wp; stronger; if_then_else; ite_wp; close_wp; trivial; - repr; return_repr; bind_repr;_} -> bind_repr -type layered_eff_combinators = - { - l_repr: (tscheme * tscheme) ; - l_return: (tscheme * tscheme) ; - l_bind: - (tscheme * tscheme * indexed_effect_combinator_kind - FStar_Pervasives_Native.option) - ; - l_subcomp: - (tscheme * tscheme * indexed_effect_combinator_kind - FStar_Pervasives_Native.option) - ; - l_if_then_else: - (tscheme * tscheme * indexed_effect_combinator_kind - FStar_Pervasives_Native.option) - ; - l_close: (tscheme * tscheme) FStar_Pervasives_Native.option } -let (__proj__Mklayered_eff_combinators__item__l_repr : - layered_eff_combinators -> (tscheme * tscheme)) = - fun projectee -> - match projectee with - | { l_repr; l_return; l_bind; l_subcomp; l_if_then_else; l_close;_} -> - l_repr -let (__proj__Mklayered_eff_combinators__item__l_return : - layered_eff_combinators -> (tscheme * tscheme)) = - fun projectee -> - match projectee with - | { l_repr; l_return; l_bind; l_subcomp; l_if_then_else; l_close;_} -> - l_return -let (__proj__Mklayered_eff_combinators__item__l_bind : - layered_eff_combinators -> - (tscheme * tscheme * indexed_effect_combinator_kind - FStar_Pervasives_Native.option)) - = - fun projectee -> - match projectee with - | { l_repr; l_return; l_bind; l_subcomp; l_if_then_else; l_close;_} -> - l_bind -let (__proj__Mklayered_eff_combinators__item__l_subcomp : - layered_eff_combinators -> - (tscheme * tscheme * indexed_effect_combinator_kind - FStar_Pervasives_Native.option)) - = - fun projectee -> - match projectee with - | { l_repr; l_return; l_bind; l_subcomp; l_if_then_else; l_close;_} -> - l_subcomp -let (__proj__Mklayered_eff_combinators__item__l_if_then_else : - layered_eff_combinators -> - (tscheme * tscheme * indexed_effect_combinator_kind - FStar_Pervasives_Native.option)) - = - fun projectee -> - match projectee with - | { l_repr; l_return; l_bind; l_subcomp; l_if_then_else; l_close;_} -> - l_if_then_else -let (__proj__Mklayered_eff_combinators__item__l_close : - layered_eff_combinators -> - (tscheme * tscheme) FStar_Pervasives_Native.option) - = - fun projectee -> - match projectee with - | { l_repr; l_return; l_bind; l_subcomp; l_if_then_else; l_close;_} -> - l_close -type eff_combinators = - | Primitive_eff of wp_eff_combinators - | DM4F_eff of wp_eff_combinators - | Layered_eff of layered_eff_combinators -let (uu___is_Primitive_eff : eff_combinators -> Prims.bool) = - fun projectee -> - match projectee with | Primitive_eff _0 -> true | uu___ -> false -let (__proj__Primitive_eff__item___0 : eff_combinators -> wp_eff_combinators) - = fun projectee -> match projectee with | Primitive_eff _0 -> _0 -let (uu___is_DM4F_eff : eff_combinators -> Prims.bool) = - fun projectee -> - match projectee with | DM4F_eff _0 -> true | uu___ -> false -let (__proj__DM4F_eff__item___0 : eff_combinators -> wp_eff_combinators) = - fun projectee -> match projectee with | DM4F_eff _0 -> _0 -let (uu___is_Layered_eff : eff_combinators -> Prims.bool) = - fun projectee -> - match projectee with | Layered_eff _0 -> true | uu___ -> false -let (__proj__Layered_eff__item___0 : - eff_combinators -> layered_eff_combinators) = - fun projectee -> match projectee with | Layered_eff _0 -> _0 -type effect_signature = - | Layered_eff_sig of (Prims.int * tscheme) - | WP_eff_sig of tscheme -let (uu___is_Layered_eff_sig : effect_signature -> Prims.bool) = - fun projectee -> - match projectee with | Layered_eff_sig _0 -> true | uu___ -> false -let (__proj__Layered_eff_sig__item___0 : - effect_signature -> (Prims.int * tscheme)) = - fun projectee -> match projectee with | Layered_eff_sig _0 -> _0 -let (uu___is_WP_eff_sig : effect_signature -> Prims.bool) = - fun projectee -> - match projectee with | WP_eff_sig _0 -> true | uu___ -> false -let (__proj__WP_eff_sig__item___0 : effect_signature -> tscheme) = - fun projectee -> match projectee with | WP_eff_sig _0 -> _0 -type eff_extraction_mode = - | Extract_none of Prims.string - | Extract_reify - | Extract_primitive -let (uu___is_Extract_none : eff_extraction_mode -> Prims.bool) = - fun projectee -> - match projectee with | Extract_none _0 -> true | uu___ -> false -let (__proj__Extract_none__item___0 : eff_extraction_mode -> Prims.string) = - fun projectee -> match projectee with | Extract_none _0 -> _0 -let (uu___is_Extract_reify : eff_extraction_mode -> Prims.bool) = - fun projectee -> - match projectee with | Extract_reify -> true | uu___ -> false -let (uu___is_Extract_primitive : eff_extraction_mode -> Prims.bool) = - fun projectee -> - match projectee with | Extract_primitive -> true | uu___ -> false -let (showable_eff_extraction_mode : - eff_extraction_mode FStar_Class_Show.showable) = - { - FStar_Class_Show.show = - (fun uu___ -> - match uu___ with - | Extract_none s -> Prims.strcat "Extract_none " s - | Extract_reify -> "Extract_reify" - | Extract_primitive -> "Extract_primitive") - } -let (tagged_eff_extraction_mode : - eff_extraction_mode FStar_Class_Tagged.tagged) = - { - FStar_Class_Tagged.tag_of = - (fun uu___ -> - match uu___ with - | Extract_none uu___1 -> "Extract_none" - | Extract_reify -> "Extract_reify" - | Extract_primitive -> "Extract_primitive") - } -type eff_decl = - { - mname: FStar_Ident.lident ; - cattributes: cflag Prims.list ; - univs: univ_names ; - binders: binders ; - signature: effect_signature ; - combinators: eff_combinators ; - actions: action Prims.list ; - eff_attrs: attribute Prims.list ; - extraction_mode: eff_extraction_mode } -let (__proj__Mkeff_decl__item__mname : eff_decl -> FStar_Ident.lident) = - fun projectee -> - match projectee with - | { mname; cattributes; univs; binders = binders1; signature; - combinators; actions; eff_attrs; extraction_mode;_} -> mname -let (__proj__Mkeff_decl__item__cattributes : eff_decl -> cflag Prims.list) = - fun projectee -> - match projectee with - | { mname; cattributes; univs; binders = binders1; signature; - combinators; actions; eff_attrs; extraction_mode;_} -> cattributes -let (__proj__Mkeff_decl__item__univs : eff_decl -> univ_names) = - fun projectee -> - match projectee with - | { mname; cattributes; univs; binders = binders1; signature; - combinators; actions; eff_attrs; extraction_mode;_} -> univs -let (__proj__Mkeff_decl__item__binders : eff_decl -> binders) = - fun projectee -> - match projectee with - | { mname; cattributes; univs; binders = binders1; signature; - combinators; actions; eff_attrs; extraction_mode;_} -> binders1 -let (__proj__Mkeff_decl__item__signature : eff_decl -> effect_signature) = - fun projectee -> - match projectee with - | { mname; cattributes; univs; binders = binders1; signature; - combinators; actions; eff_attrs; extraction_mode;_} -> signature -let (__proj__Mkeff_decl__item__combinators : eff_decl -> eff_combinators) = - fun projectee -> - match projectee with - | { mname; cattributes; univs; binders = binders1; signature; - combinators; actions; eff_attrs; extraction_mode;_} -> combinators -let (__proj__Mkeff_decl__item__actions : eff_decl -> action Prims.list) = - fun projectee -> - match projectee with - | { mname; cattributes; univs; binders = binders1; signature; - combinators; actions; eff_attrs; extraction_mode;_} -> actions -let (__proj__Mkeff_decl__item__eff_attrs : eff_decl -> attribute Prims.list) - = - fun projectee -> - match projectee with - | { mname; cattributes; univs; binders = binders1; signature; - combinators; actions; eff_attrs; extraction_mode;_} -> eff_attrs -let (__proj__Mkeff_decl__item__extraction_mode : - eff_decl -> eff_extraction_mode) = - fun projectee -> - match projectee with - | { mname; cattributes; univs; binders = binders1; signature; - combinators; actions; eff_attrs; extraction_mode;_} -> - extraction_mode -type sig_metadata = - { - sigmeta_active: Prims.bool ; - sigmeta_fact_db_ids: Prims.string Prims.list ; - sigmeta_admit: Prims.bool ; - sigmeta_spliced: Prims.bool ; - sigmeta_already_checked: Prims.bool ; - sigmeta_extension_data: (Prims.string * FStar_Dyn.dyn) Prims.list } -let (__proj__Mksig_metadata__item__sigmeta_active : - sig_metadata -> Prims.bool) = - fun projectee -> - match projectee with - | { sigmeta_active; sigmeta_fact_db_ids; sigmeta_admit; sigmeta_spliced; - sigmeta_already_checked; sigmeta_extension_data;_} -> sigmeta_active -let (__proj__Mksig_metadata__item__sigmeta_fact_db_ids : - sig_metadata -> Prims.string Prims.list) = - fun projectee -> - match projectee with - | { sigmeta_active; sigmeta_fact_db_ids; sigmeta_admit; sigmeta_spliced; - sigmeta_already_checked; sigmeta_extension_data;_} -> - sigmeta_fact_db_ids -let (__proj__Mksig_metadata__item__sigmeta_admit : - sig_metadata -> Prims.bool) = - fun projectee -> - match projectee with - | { sigmeta_active; sigmeta_fact_db_ids; sigmeta_admit; sigmeta_spliced; - sigmeta_already_checked; sigmeta_extension_data;_} -> sigmeta_admit -let (__proj__Mksig_metadata__item__sigmeta_spliced : - sig_metadata -> Prims.bool) = - fun projectee -> - match projectee with - | { sigmeta_active; sigmeta_fact_db_ids; sigmeta_admit; sigmeta_spliced; - sigmeta_already_checked; sigmeta_extension_data;_} -> sigmeta_spliced -let (__proj__Mksig_metadata__item__sigmeta_already_checked : - sig_metadata -> Prims.bool) = - fun projectee -> - match projectee with - | { sigmeta_active; sigmeta_fact_db_ids; sigmeta_admit; sigmeta_spliced; - sigmeta_already_checked; sigmeta_extension_data;_} -> - sigmeta_already_checked -let (__proj__Mksig_metadata__item__sigmeta_extension_data : - sig_metadata -> (Prims.string * FStar_Dyn.dyn) Prims.list) = - fun projectee -> - match projectee with - | { sigmeta_active; sigmeta_fact_db_ids; sigmeta_admit; sigmeta_spliced; - sigmeta_already_checked; sigmeta_extension_data;_} -> - sigmeta_extension_data -type open_kind = - | Open_module - | Open_namespace -let (uu___is_Open_module : open_kind -> Prims.bool) = - fun projectee -> - match projectee with | Open_module -> true | uu___ -> false -let (uu___is_Open_namespace : open_kind -> Prims.bool) = - fun projectee -> - match projectee with | Open_namespace -> true | uu___ -> false -type ident_alias = FStar_Ident.ident FStar_Pervasives_Native.option -type restriction = - | Unrestricted - | AllowList of (FStar_Ident.ident * ident_alias) Prims.list -let (uu___is_Unrestricted : restriction -> Prims.bool) = - fun projectee -> - match projectee with | Unrestricted -> true | uu___ -> false -let (uu___is_AllowList : restriction -> Prims.bool) = - fun projectee -> - match projectee with | AllowList _0 -> true | uu___ -> false -let (__proj__AllowList__item___0 : - restriction -> (FStar_Ident.ident * ident_alias) Prims.list) = - fun projectee -> match projectee with | AllowList _0 -> _0 -type open_module_or_namespace = - (FStar_Ident.lident * open_kind * restriction) -type module_abbrev = (FStar_Ident.ident * FStar_Ident.lident) -type sigelt'__Sig_inductive_typ__payload = - { - lid: FStar_Ident.lident ; - us: univ_names ; - params: binders ; - num_uniform_params: Prims.int FStar_Pervasives_Native.option ; - t: typ ; - mutuals: FStar_Ident.lident Prims.list ; - ds: FStar_Ident.lident Prims.list ; - injective_type_params: Prims.bool } -and sigelt'__Sig_bundle__payload = - { - ses: sigelt Prims.list ; - lids: FStar_Ident.lident Prims.list } -and sigelt'__Sig_datacon__payload = - { - lid1: FStar_Ident.lident ; - us1: univ_names ; - t1: typ ; - ty_lid: FStar_Ident.lident ; - num_ty_params: Prims.int ; - mutuals1: FStar_Ident.lident Prims.list ; - injective_type_params1: Prims.bool } -and sigelt'__Sig_declare_typ__payload = - { - lid2: FStar_Ident.lident ; - us2: univ_names ; - t2: typ } -and sigelt'__Sig_let__payload = - { - lbs1: letbindings ; - lids1: FStar_Ident.lident Prims.list } -and sigelt'__Sig_assume__payload = - { - lid3: FStar_Ident.lident ; - us3: univ_names ; - phi1: formula } -and sigelt'__Sig_effect_abbrev__payload = - { - lid4: FStar_Ident.lident ; - us4: univ_names ; - bs2: binders ; - comp1: comp ; - cflags: cflag Prims.list } -and sigelt'__Sig_splice__payload = - { - is_typed: Prims.bool ; - lids2: FStar_Ident.lident Prims.list ; - tac: term } -and sigelt'__Sig_polymonadic_bind__payload = - { - m_lid: FStar_Ident.lident ; - n_lid: FStar_Ident.lident ; - p_lid: FStar_Ident.lident ; - tm3: tscheme ; - typ: tscheme ; - kind1: indexed_effect_combinator_kind FStar_Pervasives_Native.option } -and sigelt'__Sig_polymonadic_subcomp__payload = - { - m_lid1: FStar_Ident.lident ; - n_lid1: FStar_Ident.lident ; - tm4: tscheme ; - typ1: tscheme ; - kind2: indexed_effect_combinator_kind FStar_Pervasives_Native.option } -and sigelt'__Sig_fail__payload = - { - errs: Prims.int Prims.list ; - fail_in_lax: Prims.bool ; - ses1: sigelt Prims.list } -and sigelt' = - | Sig_inductive_typ of sigelt'__Sig_inductive_typ__payload - | Sig_bundle of sigelt'__Sig_bundle__payload - | Sig_datacon of sigelt'__Sig_datacon__payload - | Sig_declare_typ of sigelt'__Sig_declare_typ__payload - | Sig_let of sigelt'__Sig_let__payload - | Sig_assume of sigelt'__Sig_assume__payload - | Sig_new_effect of eff_decl - | Sig_sub_effect of sub_eff - | Sig_effect_abbrev of sigelt'__Sig_effect_abbrev__payload - | Sig_pragma of pragma - | Sig_splice of sigelt'__Sig_splice__payload - | Sig_polymonadic_bind of sigelt'__Sig_polymonadic_bind__payload - | Sig_polymonadic_subcomp of sigelt'__Sig_polymonadic_subcomp__payload - | Sig_fail of sigelt'__Sig_fail__payload -and sigelt = - { - sigel: sigelt' ; - sigrng: FStar_Compiler_Range_Type.range ; - sigquals: qualifier Prims.list ; - sigmeta: sig_metadata ; - sigattrs: attribute Prims.list ; - sigopens_and_abbrevs: - (open_module_or_namespace, module_abbrev) FStar_Pervasives.either - Prims.list - ; - sigopts: FStar_VConfig.vconfig FStar_Pervasives_Native.option } -let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__lid : - sigelt'__Sig_inductive_typ__payload -> FStar_Ident.lident) = - fun projectee -> - match projectee with - | { lid; us; params; num_uniform_params; t; mutuals; ds; - injective_type_params;_} -> lid -let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__us : - sigelt'__Sig_inductive_typ__payload -> univ_names) = - fun projectee -> - match projectee with - | { lid; us; params; num_uniform_params; t; mutuals; ds; - injective_type_params;_} -> us -let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__params : - sigelt'__Sig_inductive_typ__payload -> binders) = - fun projectee -> - match projectee with - | { lid; us; params; num_uniform_params; t; mutuals; ds; - injective_type_params;_} -> params -let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__num_uniform_params - : - sigelt'__Sig_inductive_typ__payload -> - Prims.int FStar_Pervasives_Native.option) - = - fun projectee -> - match projectee with - | { lid; us; params; num_uniform_params; t; mutuals; ds; - injective_type_params;_} -> num_uniform_params -let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__t : - sigelt'__Sig_inductive_typ__payload -> typ) = - fun projectee -> - match projectee with - | { lid; us; params; num_uniform_params; t; mutuals; ds; - injective_type_params;_} -> t -let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__mutuals : - sigelt'__Sig_inductive_typ__payload -> FStar_Ident.lident Prims.list) = - fun projectee -> - match projectee with - | { lid; us; params; num_uniform_params; t; mutuals; ds; - injective_type_params;_} -> mutuals -let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__ds : - sigelt'__Sig_inductive_typ__payload -> FStar_Ident.lident Prims.list) = - fun projectee -> - match projectee with - | { lid; us; params; num_uniform_params; t; mutuals; ds; - injective_type_params;_} -> ds -let (__proj__Mksigelt'__Sig_inductive_typ__payload__item__injective_type_params - : sigelt'__Sig_inductive_typ__payload -> Prims.bool) = - fun projectee -> - match projectee with - | { lid; us; params; num_uniform_params; t; mutuals; ds; - injective_type_params;_} -> injective_type_params -let (__proj__Mksigelt'__Sig_bundle__payload__item__ses : - sigelt'__Sig_bundle__payload -> sigelt Prims.list) = - fun projectee -> match projectee with | { ses; lids;_} -> ses -let (__proj__Mksigelt'__Sig_bundle__payload__item__lids : - sigelt'__Sig_bundle__payload -> FStar_Ident.lident Prims.list) = - fun projectee -> match projectee with | { ses; lids;_} -> lids -let (__proj__Mksigelt'__Sig_datacon__payload__item__lid : - sigelt'__Sig_datacon__payload -> FStar_Ident.lident) = - fun projectee -> - match projectee with - | { lid1 = lid; us1 = us; t1 = t; ty_lid; num_ty_params; - mutuals1 = mutuals; injective_type_params1 = injective_type_params;_} - -> lid -let (__proj__Mksigelt'__Sig_datacon__payload__item__us : - sigelt'__Sig_datacon__payload -> univ_names) = - fun projectee -> - match projectee with - | { lid1 = lid; us1 = us; t1 = t; ty_lid; num_ty_params; - mutuals1 = mutuals; injective_type_params1 = injective_type_params;_} - -> us -let (__proj__Mksigelt'__Sig_datacon__payload__item__t : - sigelt'__Sig_datacon__payload -> typ) = - fun projectee -> - match projectee with - | { lid1 = lid; us1 = us; t1 = t; ty_lid; num_ty_params; - mutuals1 = mutuals; injective_type_params1 = injective_type_params;_} - -> t -let (__proj__Mksigelt'__Sig_datacon__payload__item__ty_lid : - sigelt'__Sig_datacon__payload -> FStar_Ident.lident) = - fun projectee -> - match projectee with - | { lid1 = lid; us1 = us; t1 = t; ty_lid; num_ty_params; - mutuals1 = mutuals; injective_type_params1 = injective_type_params;_} - -> ty_lid -let (__proj__Mksigelt'__Sig_datacon__payload__item__num_ty_params : - sigelt'__Sig_datacon__payload -> Prims.int) = - fun projectee -> - match projectee with - | { lid1 = lid; us1 = us; t1 = t; ty_lid; num_ty_params; - mutuals1 = mutuals; injective_type_params1 = injective_type_params;_} - -> num_ty_params -let (__proj__Mksigelt'__Sig_datacon__payload__item__mutuals : - sigelt'__Sig_datacon__payload -> FStar_Ident.lident Prims.list) = - fun projectee -> - match projectee with - | { lid1 = lid; us1 = us; t1 = t; ty_lid; num_ty_params; - mutuals1 = mutuals; injective_type_params1 = injective_type_params;_} - -> mutuals -let (__proj__Mksigelt'__Sig_datacon__payload__item__injective_type_params : - sigelt'__Sig_datacon__payload -> Prims.bool) = - fun projectee -> - match projectee with - | { lid1 = lid; us1 = us; t1 = t; ty_lid; num_ty_params; - mutuals1 = mutuals; injective_type_params1 = injective_type_params;_} - -> injective_type_params -let (__proj__Mksigelt'__Sig_declare_typ__payload__item__lid : - sigelt'__Sig_declare_typ__payload -> FStar_Ident.lident) = - fun projectee -> - match projectee with | { lid2 = lid; us2 = us; t2 = t;_} -> lid -let (__proj__Mksigelt'__Sig_declare_typ__payload__item__us : - sigelt'__Sig_declare_typ__payload -> univ_names) = - fun projectee -> - match projectee with | { lid2 = lid; us2 = us; t2 = t;_} -> us -let (__proj__Mksigelt'__Sig_declare_typ__payload__item__t : - sigelt'__Sig_declare_typ__payload -> typ) = - fun projectee -> - match projectee with | { lid2 = lid; us2 = us; t2 = t;_} -> t -let (__proj__Mksigelt'__Sig_let__payload__item__lbs : - sigelt'__Sig_let__payload -> letbindings) = - fun projectee -> - match projectee with | { lbs1 = lbs; lids1 = lids;_} -> lbs -let (__proj__Mksigelt'__Sig_let__payload__item__lids : - sigelt'__Sig_let__payload -> FStar_Ident.lident Prims.list) = - fun projectee -> - match projectee with | { lbs1 = lbs; lids1 = lids;_} -> lids -let (__proj__Mksigelt'__Sig_assume__payload__item__lid : - sigelt'__Sig_assume__payload -> FStar_Ident.lident) = - fun projectee -> - match projectee with | { lid3 = lid; us3 = us; phi1 = phi;_} -> lid -let (__proj__Mksigelt'__Sig_assume__payload__item__us : - sigelt'__Sig_assume__payload -> univ_names) = - fun projectee -> - match projectee with | { lid3 = lid; us3 = us; phi1 = phi;_} -> us -let (__proj__Mksigelt'__Sig_assume__payload__item__phi : - sigelt'__Sig_assume__payload -> formula) = - fun projectee -> - match projectee with | { lid3 = lid; us3 = us; phi1 = phi;_} -> phi -let (__proj__Mksigelt'__Sig_effect_abbrev__payload__item__lid : - sigelt'__Sig_effect_abbrev__payload -> FStar_Ident.lident) = - fun projectee -> - match projectee with - | { lid4 = lid; us4 = us; bs2 = bs; comp1; cflags;_} -> lid -let (__proj__Mksigelt'__Sig_effect_abbrev__payload__item__us : - sigelt'__Sig_effect_abbrev__payload -> univ_names) = - fun projectee -> - match projectee with - | { lid4 = lid; us4 = us; bs2 = bs; comp1; cflags;_} -> us -let (__proj__Mksigelt'__Sig_effect_abbrev__payload__item__bs : - sigelt'__Sig_effect_abbrev__payload -> binders) = - fun projectee -> - match projectee with - | { lid4 = lid; us4 = us; bs2 = bs; comp1; cflags;_} -> bs -let (__proj__Mksigelt'__Sig_effect_abbrev__payload__item__comp : - sigelt'__Sig_effect_abbrev__payload -> comp) = - fun projectee -> - match projectee with - | { lid4 = lid; us4 = us; bs2 = bs; comp1; cflags;_} -> comp1 -let (__proj__Mksigelt'__Sig_effect_abbrev__payload__item__cflags : - sigelt'__Sig_effect_abbrev__payload -> cflag Prims.list) = - fun projectee -> - match projectee with - | { lid4 = lid; us4 = us; bs2 = bs; comp1; cflags;_} -> cflags -let (__proj__Mksigelt'__Sig_splice__payload__item__is_typed : - sigelt'__Sig_splice__payload -> Prims.bool) = - fun projectee -> - match projectee with | { is_typed; lids2 = lids; tac;_} -> is_typed -let (__proj__Mksigelt'__Sig_splice__payload__item__lids : - sigelt'__Sig_splice__payload -> FStar_Ident.lident Prims.list) = - fun projectee -> - match projectee with | { is_typed; lids2 = lids; tac;_} -> lids -let (__proj__Mksigelt'__Sig_splice__payload__item__tac : - sigelt'__Sig_splice__payload -> term) = - fun projectee -> - match projectee with | { is_typed; lids2 = lids; tac;_} -> tac -let (__proj__Mksigelt'__Sig_polymonadic_bind__payload__item__m_lid : - sigelt'__Sig_polymonadic_bind__payload -> FStar_Ident.lident) = - fun projectee -> - match projectee with - | { m_lid; n_lid; p_lid; tm3 = tm; typ = typ1; kind1 = kind;_} -> m_lid -let (__proj__Mksigelt'__Sig_polymonadic_bind__payload__item__n_lid : - sigelt'__Sig_polymonadic_bind__payload -> FStar_Ident.lident) = - fun projectee -> - match projectee with - | { m_lid; n_lid; p_lid; tm3 = tm; typ = typ1; kind1 = kind;_} -> n_lid -let (__proj__Mksigelt'__Sig_polymonadic_bind__payload__item__p_lid : - sigelt'__Sig_polymonadic_bind__payload -> FStar_Ident.lident) = - fun projectee -> - match projectee with - | { m_lid; n_lid; p_lid; tm3 = tm; typ = typ1; kind1 = kind;_} -> p_lid -let (__proj__Mksigelt'__Sig_polymonadic_bind__payload__item__tm : - sigelt'__Sig_polymonadic_bind__payload -> tscheme) = - fun projectee -> - match projectee with - | { m_lid; n_lid; p_lid; tm3 = tm; typ = typ1; kind1 = kind;_} -> tm -let (__proj__Mksigelt'__Sig_polymonadic_bind__payload__item__typ : - sigelt'__Sig_polymonadic_bind__payload -> tscheme) = - fun projectee -> - match projectee with - | { m_lid; n_lid; p_lid; tm3 = tm; typ = typ1; kind1 = kind;_} -> typ1 -let (__proj__Mksigelt'__Sig_polymonadic_bind__payload__item__kind : - sigelt'__Sig_polymonadic_bind__payload -> - indexed_effect_combinator_kind FStar_Pervasives_Native.option) - = - fun projectee -> - match projectee with - | { m_lid; n_lid; p_lid; tm3 = tm; typ = typ1; kind1 = kind;_} -> kind -let (__proj__Mksigelt'__Sig_polymonadic_subcomp__payload__item__m_lid : - sigelt'__Sig_polymonadic_subcomp__payload -> FStar_Ident.lident) = - fun projectee -> - match projectee with - | { m_lid1 = m_lid; n_lid1 = n_lid; tm4 = tm; typ1; kind2 = kind;_} -> - m_lid -let (__proj__Mksigelt'__Sig_polymonadic_subcomp__payload__item__n_lid : - sigelt'__Sig_polymonadic_subcomp__payload -> FStar_Ident.lident) = - fun projectee -> - match projectee with - | { m_lid1 = m_lid; n_lid1 = n_lid; tm4 = tm; typ1; kind2 = kind;_} -> - n_lid -let (__proj__Mksigelt'__Sig_polymonadic_subcomp__payload__item__tm : - sigelt'__Sig_polymonadic_subcomp__payload -> tscheme) = - fun projectee -> - match projectee with - | { m_lid1 = m_lid; n_lid1 = n_lid; tm4 = tm; typ1; kind2 = kind;_} -> tm -let (__proj__Mksigelt'__Sig_polymonadic_subcomp__payload__item__typ : - sigelt'__Sig_polymonadic_subcomp__payload -> tscheme) = - fun projectee -> - match projectee with - | { m_lid1 = m_lid; n_lid1 = n_lid; tm4 = tm; typ1; kind2 = kind;_} -> - typ1 -let (__proj__Mksigelt'__Sig_polymonadic_subcomp__payload__item__kind : - sigelt'__Sig_polymonadic_subcomp__payload -> - indexed_effect_combinator_kind FStar_Pervasives_Native.option) - = - fun projectee -> - match projectee with - | { m_lid1 = m_lid; n_lid1 = n_lid; tm4 = tm; typ1; kind2 = kind;_} -> - kind -let (__proj__Mksigelt'__Sig_fail__payload__item__errs : - sigelt'__Sig_fail__payload -> Prims.int Prims.list) = - fun projectee -> - match projectee with | { errs; fail_in_lax; ses1 = ses;_} -> errs -let (__proj__Mksigelt'__Sig_fail__payload__item__fail_in_lax : - sigelt'__Sig_fail__payload -> Prims.bool) = - fun projectee -> - match projectee with | { errs; fail_in_lax; ses1 = ses;_} -> fail_in_lax -let (__proj__Mksigelt'__Sig_fail__payload__item__ses : - sigelt'__Sig_fail__payload -> sigelt Prims.list) = - fun projectee -> - match projectee with | { errs; fail_in_lax; ses1 = ses;_} -> ses -let (uu___is_Sig_inductive_typ : sigelt' -> Prims.bool) = - fun projectee -> - match projectee with | Sig_inductive_typ _0 -> true | uu___ -> false -let (__proj__Sig_inductive_typ__item___0 : - sigelt' -> sigelt'__Sig_inductive_typ__payload) = - fun projectee -> match projectee with | Sig_inductive_typ _0 -> _0 -let (uu___is_Sig_bundle : sigelt' -> Prims.bool) = - fun projectee -> - match projectee with | Sig_bundle _0 -> true | uu___ -> false -let (__proj__Sig_bundle__item___0 : sigelt' -> sigelt'__Sig_bundle__payload) - = fun projectee -> match projectee with | Sig_bundle _0 -> _0 -let (uu___is_Sig_datacon : sigelt' -> Prims.bool) = - fun projectee -> - match projectee with | Sig_datacon _0 -> true | uu___ -> false -let (__proj__Sig_datacon__item___0 : - sigelt' -> sigelt'__Sig_datacon__payload) = - fun projectee -> match projectee with | Sig_datacon _0 -> _0 -let (uu___is_Sig_declare_typ : sigelt' -> Prims.bool) = - fun projectee -> - match projectee with | Sig_declare_typ _0 -> true | uu___ -> false -let (__proj__Sig_declare_typ__item___0 : - sigelt' -> sigelt'__Sig_declare_typ__payload) = - fun projectee -> match projectee with | Sig_declare_typ _0 -> _0 -let (uu___is_Sig_let : sigelt' -> Prims.bool) = - fun projectee -> match projectee with | Sig_let _0 -> true | uu___ -> false -let (__proj__Sig_let__item___0 : sigelt' -> sigelt'__Sig_let__payload) = - fun projectee -> match projectee with | Sig_let _0 -> _0 -let (uu___is_Sig_assume : sigelt' -> Prims.bool) = - fun projectee -> - match projectee with | Sig_assume _0 -> true | uu___ -> false -let (__proj__Sig_assume__item___0 : sigelt' -> sigelt'__Sig_assume__payload) - = fun projectee -> match projectee with | Sig_assume _0 -> _0 -let (uu___is_Sig_new_effect : sigelt' -> Prims.bool) = - fun projectee -> - match projectee with | Sig_new_effect _0 -> true | uu___ -> false -let (__proj__Sig_new_effect__item___0 : sigelt' -> eff_decl) = - fun projectee -> match projectee with | Sig_new_effect _0 -> _0 -let (uu___is_Sig_sub_effect : sigelt' -> Prims.bool) = - fun projectee -> - match projectee with | Sig_sub_effect _0 -> true | uu___ -> false -let (__proj__Sig_sub_effect__item___0 : sigelt' -> sub_eff) = - fun projectee -> match projectee with | Sig_sub_effect _0 -> _0 -let (uu___is_Sig_effect_abbrev : sigelt' -> Prims.bool) = - fun projectee -> - match projectee with | Sig_effect_abbrev _0 -> true | uu___ -> false -let (__proj__Sig_effect_abbrev__item___0 : - sigelt' -> sigelt'__Sig_effect_abbrev__payload) = - fun projectee -> match projectee with | Sig_effect_abbrev _0 -> _0 -let (uu___is_Sig_pragma : sigelt' -> Prims.bool) = - fun projectee -> - match projectee with | Sig_pragma _0 -> true | uu___ -> false -let (__proj__Sig_pragma__item___0 : sigelt' -> pragma) = - fun projectee -> match projectee with | Sig_pragma _0 -> _0 -let (uu___is_Sig_splice : sigelt' -> Prims.bool) = - fun projectee -> - match projectee with | Sig_splice _0 -> true | uu___ -> false -let (__proj__Sig_splice__item___0 : sigelt' -> sigelt'__Sig_splice__payload) - = fun projectee -> match projectee with | Sig_splice _0 -> _0 -let (uu___is_Sig_polymonadic_bind : sigelt' -> Prims.bool) = - fun projectee -> - match projectee with | Sig_polymonadic_bind _0 -> true | uu___ -> false -let (__proj__Sig_polymonadic_bind__item___0 : - sigelt' -> sigelt'__Sig_polymonadic_bind__payload) = - fun projectee -> match projectee with | Sig_polymonadic_bind _0 -> _0 -let (uu___is_Sig_polymonadic_subcomp : sigelt' -> Prims.bool) = - fun projectee -> - match projectee with - | Sig_polymonadic_subcomp _0 -> true - | uu___ -> false -let (__proj__Sig_polymonadic_subcomp__item___0 : - sigelt' -> sigelt'__Sig_polymonadic_subcomp__payload) = - fun projectee -> match projectee with | Sig_polymonadic_subcomp _0 -> _0 -let (uu___is_Sig_fail : sigelt' -> Prims.bool) = - fun projectee -> - match projectee with | Sig_fail _0 -> true | uu___ -> false -let (__proj__Sig_fail__item___0 : sigelt' -> sigelt'__Sig_fail__payload) = - fun projectee -> match projectee with | Sig_fail _0 -> _0 -let (__proj__Mksigelt__item__sigel : sigelt -> sigelt') = - fun projectee -> - match projectee with - | { sigel; sigrng; sigquals; sigmeta; sigattrs; sigopens_and_abbrevs; - sigopts;_} -> sigel -let (__proj__Mksigelt__item__sigrng : - sigelt -> FStar_Compiler_Range_Type.range) = - fun projectee -> - match projectee with - | { sigel; sigrng; sigquals; sigmeta; sigattrs; sigopens_and_abbrevs; - sigopts;_} -> sigrng -let (__proj__Mksigelt__item__sigquals : sigelt -> qualifier Prims.list) = - fun projectee -> - match projectee with - | { sigel; sigrng; sigquals; sigmeta; sigattrs; sigopens_and_abbrevs; - sigopts;_} -> sigquals -let (__proj__Mksigelt__item__sigmeta : sigelt -> sig_metadata) = - fun projectee -> - match projectee with - | { sigel; sigrng; sigquals; sigmeta; sigattrs; sigopens_and_abbrevs; - sigopts;_} -> sigmeta -let (__proj__Mksigelt__item__sigattrs : sigelt -> attribute Prims.list) = - fun projectee -> - match projectee with - | { sigel; sigrng; sigquals; sigmeta; sigattrs; sigopens_and_abbrevs; - sigopts;_} -> sigattrs -let (__proj__Mksigelt__item__sigopens_and_abbrevs : - sigelt -> - (open_module_or_namespace, module_abbrev) FStar_Pervasives.either - Prims.list) - = - fun projectee -> - match projectee with - | { sigel; sigrng; sigquals; sigmeta; sigattrs; sigopens_and_abbrevs; - sigopts;_} -> sigopens_and_abbrevs -let (__proj__Mksigelt__item__sigopts : - sigelt -> FStar_VConfig.vconfig FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { sigel; sigrng; sigquals; sigmeta; sigattrs; sigopens_and_abbrevs; - sigopts;_} -> sigopts -type sigelts = sigelt Prims.list -type modul = - { - name: FStar_Ident.lident ; - declarations: sigelts ; - is_interface: Prims.bool } -let (__proj__Mkmodul__item__name : modul -> FStar_Ident.lident) = - fun projectee -> - match projectee with | { name; declarations; is_interface;_} -> name -let (__proj__Mkmodul__item__declarations : modul -> sigelts) = - fun projectee -> - match projectee with - | { name; declarations; is_interface;_} -> declarations -let (__proj__Mkmodul__item__is_interface : modul -> Prims.bool) = - fun projectee -> - match projectee with - | { name; declarations; is_interface;_} -> is_interface -let (mod_name : modul -> FStar_Ident.lident) = fun m -> m.name -let (contains_reflectable : qualifier Prims.list -> Prims.bool) = - fun l -> - FStar_Compiler_Util.for_some - (fun uu___ -> - match uu___ with | Reflectable uu___1 -> true | uu___1 -> false) l -let withinfo : 'a . 'a -> FStar_Compiler_Range_Type.range -> 'a withinfo_t = - fun v -> fun r -> { v; p = r } -let withsort : 'a . 'a -> 'a withinfo_t = - fun v -> withinfo v FStar_Compiler_Range_Type.dummyRange -let (order_bv : bv -> bv -> Prims.int) = fun x -> fun y -> x.index - y.index -let (bv_eq : bv -> bv -> Prims.bool) = - fun x -> fun y -> let uu___ = order_bv x y in uu___ = Prims.int_zero -let (order_ident : FStar_Ident.ident -> FStar_Ident.ident -> Prims.int) = - fun x -> - fun y -> - let uu___ = FStar_Ident.string_of_id x in - let uu___1 = FStar_Ident.string_of_id y in - FStar_Compiler_String.compare uu___ uu___1 -let (order_fv : FStar_Ident.lident -> FStar_Ident.lident -> Prims.int) = - fun x -> - fun y -> - let uu___ = FStar_Ident.string_of_lid x in - let uu___1 = FStar_Ident.string_of_lid y in - FStar_Compiler_String.compare uu___ uu___1 -let (range_of_lbname : lbname -> FStar_Compiler_Range_Type.range) = - fun l -> - match l with - | FStar_Pervasives.Inl x -> FStar_Ident.range_of_id x.ppname - | FStar_Pervasives.Inr fv1 -> FStar_Ident.range_of_lid (fv1.fv_name).v -let (range_of_bv : bv -> FStar_Compiler_Range_Type.range) = - fun x -> FStar_Ident.range_of_id x.ppname -let (set_range_of_bv : bv -> FStar_Compiler_Range_Type.range -> bv) = - fun x -> - fun r -> - let uu___ = FStar_Ident.set_id_range r x.ppname in - { ppname = uu___; index = (x.index); sort = (x.sort) } -let (on_antiquoted : (term -> term) -> quoteinfo -> quoteinfo) = - fun f -> - fun qi -> - let uu___ = qi.antiquotations in - match uu___ with - | (s, aqs) -> - let aqs' = FStar_Compiler_List.map f aqs in - { qkind = (qi.qkind); antiquotations = (s, aqs') } -let (lookup_aq : bv -> antiquotations -> term) = - fun bv1 -> - fun aq -> - try - (fun uu___ -> - match () with - | () -> - FStar_Compiler_List.nth (FStar_Pervasives_Native.snd aq) - ((((FStar_Compiler_List.length - (FStar_Pervasives_Native.snd aq)) - - Prims.int_one) - - bv1.index) - + (FStar_Pervasives_Native.fst aq))) () - with | uu___ -> failwith "antiquotation out of bounds" -type path = Prims.string Prims.list -type subst_t = subst_elt Prims.list -let deq_instance_from_cmp : - 'uuuuu . - ('uuuuu -> 'uuuuu -> FStar_Compiler_Order.order) -> - 'uuuuu FStar_Class_Deq.deq - = - fun f -> - { - FStar_Class_Deq.op_Equals_Question = - (fun x -> fun y -> let uu___ = f x y in FStar_Compiler_Order.eq uu___) - } -let ord_instance_from_cmp : - 'uuuuu . - ('uuuuu -> 'uuuuu -> FStar_Compiler_Order.order) -> - 'uuuuu FStar_Class_Ord.ord - = - fun f -> - { - FStar_Class_Ord.super = (deq_instance_from_cmp f); - FStar_Class_Ord.cmp = f - } -let (order_univ_name : univ_name -> univ_name -> Prims.int) = - fun x -> - fun y -> - let uu___ = FStar_Ident.string_of_id x in - let uu___1 = FStar_Ident.string_of_id y in - FStar_Compiler_String.compare uu___ uu___1 -let (deq_bv : bv FStar_Class_Deq.deq) = - deq_instance_from_cmp - (fun x -> - fun y -> - let uu___ = order_bv x y in - FStar_Compiler_Order.order_from_int uu___) -let (deq_ident : FStar_Ident.ident FStar_Class_Deq.deq) = - deq_instance_from_cmp - (fun x -> - fun y -> - let uu___ = order_ident x y in - FStar_Compiler_Order.order_from_int uu___) -let (deq_fv : FStar_Ident.lident FStar_Class_Deq.deq) = - deq_instance_from_cmp - (fun x -> - fun y -> - let uu___ = order_fv x y in - FStar_Compiler_Order.order_from_int uu___) -let (deq_univ_name : univ_name FStar_Class_Deq.deq) = - deq_instance_from_cmp - (fun x -> - fun y -> - let uu___ = order_univ_name x y in - FStar_Compiler_Order.order_from_int uu___) -let (deq_delta_depth : delta_depth FStar_Class_Deq.deq) = - { FStar_Class_Deq.op_Equals_Question = (fun x -> fun y -> x = y) } -let (ord_bv : bv FStar_Class_Ord.ord) = - ord_instance_from_cmp - (fun x -> - fun y -> - let uu___ = order_bv x y in - FStar_Compiler_Order.order_from_int uu___) -let (ord_ident : FStar_Ident.ident FStar_Class_Ord.ord) = - ord_instance_from_cmp - (fun x -> - fun y -> - let uu___ = order_ident x y in - FStar_Compiler_Order.order_from_int uu___) -let (ord_fv : FStar_Ident.lident FStar_Class_Ord.ord) = - ord_instance_from_cmp - (fun x -> - fun y -> - let uu___ = order_fv x y in - FStar_Compiler_Order.order_from_int uu___) -let syn : - 'uuuuu 'uuuuu1 'uuuuu2 . - 'uuuuu -> 'uuuuu1 -> ('uuuuu1 -> 'uuuuu -> 'uuuuu2) -> 'uuuuu2 - = fun p -> fun k -> fun f -> f k p -let mk_fvs : - 'uuuuu . - unit -> 'uuuuu FStar_Pervasives_Native.option FStar_Compiler_Effect.ref - = fun uu___ -> FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None -let mk_uvs : - 'uuuuu . - unit -> 'uuuuu FStar_Pervasives_Native.option FStar_Compiler_Effect.ref - = fun uu___ -> FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None -let (list_of_freenames : freenames -> bv Prims.list) = - fun fvs -> - FStar_Class_Setlike.elems () - (Obj.magic (FStar_Compiler_FlatSet.setlike_flat_set ord_bv)) - (Obj.magic fvs) -let mk : 'a . 'a -> FStar_Compiler_Range_Type.range -> 'a syntax = - fun t -> - fun r -> - let uu___ = FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None in - let uu___1 = FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None in - { n = t; pos = r; vars = uu___; hash_code = uu___1 } -let (bv_to_tm : bv -> term) = - fun bv1 -> let uu___ = range_of_bv bv1 in mk (Tm_bvar bv1) uu___ -let (bv_to_name : bv -> term) = - fun bv1 -> let uu___ = range_of_bv bv1 in mk (Tm_name bv1) uu___ -let (binders_to_names : binders -> term Prims.list) = - fun bs -> FStar_Compiler_List.map (fun b -> bv_to_name b.binder_bv) bs -let (mk_Tm_app : term -> args -> FStar_Compiler_Range_Type.range -> term) = - fun t1 -> - fun args1 -> - fun p -> - match args1 with - | [] -> t1 - | uu___ -> mk (Tm_app { hd = t1; args = args1 }) p -let (mk_Tm_uinst : term -> universes -> term) = - fun t -> - fun us -> - match t.n with - | Tm_fvar uu___ -> - (match us with | [] -> t | us1 -> mk (Tm_uinst (t, us1)) t.pos) - | uu___ -> failwith "Unexpected universe instantiation" -let (extend_app_n : term -> args -> FStar_Compiler_Range_Type.range -> term) - = - fun t -> - fun args' -> - fun r -> - match t.n with - | Tm_app { hd; args = args1;_} -> - mk_Tm_app hd (FStar_Compiler_List.op_At args1 args') r - | uu___ -> mk_Tm_app t args' r -let (extend_app : term -> arg -> FStar_Compiler_Range_Type.range -> term) = - fun t -> fun arg1 -> fun r -> extend_app_n t [arg1] r -let (mk_Tm_delayed : - (term * subst_ts) -> FStar_Compiler_Range_Type.range -> term) = - fun lr -> - fun pos -> - mk - (Tm_delayed - { - tm1 = (FStar_Pervasives_Native.fst lr); - substs = (FStar_Pervasives_Native.snd lr) - }) pos -let (mk_Total : typ -> comp) = fun t -> mk (Total t) t.pos -let (mk_GTotal : typ -> comp) = fun t -> mk (GTotal t) t.pos -let (mk_Comp : comp_typ -> comp) = fun ct -> mk (Comp ct) (ct.result_typ).pos -let (mk_lb : - (lbname * univ_name Prims.list * FStar_Ident.lident * typ * term * - attribute Prims.list * FStar_Compiler_Range_Type.range) -> letbinding) - = - fun uu___ -> - match uu___ with - | (x, univs, eff, t, e, attrs, pos) -> - { - lbname = x; - lbunivs = univs; - lbtyp = t; - lbeff = eff; - lbdef = e; - lbattrs = attrs; - lbpos = pos - } -let (mk_Tac : typ -> comp) = - fun t -> - mk_Comp - { - comp_univs = [U_zero]; - effect_name = FStar_Parser_Const.effect_Tac_lid; - result_typ = t; - effect_args = []; - flags = [SOMETRIVIAL; TRIVIAL_POSTCONDITION] - } -let (default_sigmeta : sig_metadata) = - { - sigmeta_active = true; - sigmeta_fact_db_ids = []; - sigmeta_admit = false; - sigmeta_spliced = false; - sigmeta_already_checked = false; - sigmeta_extension_data = [] - } -let (mk_sigelt : sigelt' -> sigelt) = - fun e -> - { - sigel = e; - sigrng = FStar_Compiler_Range_Type.dummyRange; - sigquals = []; - sigmeta = default_sigmeta; - sigattrs = []; - sigopens_and_abbrevs = []; - sigopts = FStar_Pervasives_Native.None - } -let (mk_subst : subst_t -> subst_t) = fun s -> s -let (extend_subst : subst_elt -> subst_elt Prims.list -> subst_t) = - fun x -> fun s -> x :: s -let (argpos : arg -> FStar_Compiler_Range_Type.range) = - fun x -> (FStar_Pervasives_Native.fst x).pos -let (tun : term) = mk Tm_unknown FStar_Compiler_Range_Type.dummyRange -let (teff : term) = - mk (Tm_constant FStar_Const.Const_effect) - FStar_Compiler_Range_Type.dummyRange -let (is_teff : term -> Prims.bool) = - fun t -> - match t.n with - | Tm_constant (FStar_Const.Const_effect) -> true - | uu___ -> false -let (is_type : term -> Prims.bool) = - fun t -> match t.n with | Tm_type uu___ -> true | uu___ -> false -let (null_id : FStar_Ident.ident) = - FStar_Ident.mk_ident ("_", FStar_Compiler_Range_Type.dummyRange) -let (null_bv : term -> bv) = - fun k -> - let uu___ = FStar_GenSym.next_id () in - { ppname = null_id; index = uu___; sort = k } -let (is_null_bv : bv -> Prims.bool) = - fun b -> - let uu___ = FStar_Ident.string_of_id b.ppname in - let uu___1 = FStar_Ident.string_of_id null_id in uu___ = uu___1 -let (is_null_binder : binder -> Prims.bool) = fun b -> is_null_bv b.binder_bv -let (range_of_ropt : - FStar_Compiler_Range_Type.range FStar_Pervasives_Native.option -> - FStar_Compiler_Range_Type.range) - = - fun uu___ -> - match uu___ with - | FStar_Pervasives_Native.None -> FStar_Compiler_Range_Type.dummyRange - | FStar_Pervasives_Native.Some r -> r -let (gen_bv' : - FStar_Ident.ident -> - FStar_Compiler_Range_Type.range FStar_Pervasives_Native.option -> - typ -> bv) - = - fun id -> - fun r -> - fun t -> - let uu___ = FStar_GenSym.next_id () in - { ppname = id; index = uu___; sort = t } -let (gen_bv : - Prims.string -> - FStar_Compiler_Range_Type.range FStar_Pervasives_Native.option -> - typ -> bv) - = - fun s -> - fun r -> - fun t -> - let id = FStar_Ident.mk_ident (s, (range_of_ropt r)) in - gen_bv' id r t -let (new_bv : - FStar_Compiler_Range_Type.range FStar_Pervasives_Native.option -> typ -> bv) - = fun ropt -> fun t -> gen_bv FStar_Ident.reserved_prefix ropt t -let (freshen_bv : bv -> bv) = - fun bv1 -> - let uu___ = is_null_bv bv1 in - if uu___ - then - let uu___1 = - let uu___2 = range_of_bv bv1 in FStar_Pervasives_Native.Some uu___2 in - new_bv uu___1 bv1.sort - else - (let uu___2 = FStar_GenSym.next_id () in - { ppname = (bv1.ppname); index = uu___2; sort = (bv1.sort) }) -let (mk_binder_with_attrs : - bv -> - bqual -> - positivity_qualifier FStar_Pervasives_Native.option -> - attribute Prims.list -> binder) - = - fun bv1 -> - fun aqual1 -> - fun pqual -> - fun attrs -> - { - binder_bv = bv1; - binder_qual = aqual1; - binder_positivity = pqual; - binder_attrs = attrs - } -let (mk_binder : bv -> binder) = - fun a -> - mk_binder_with_attrs a FStar_Pervasives_Native.None - FStar_Pervasives_Native.None [] -let (null_binder : term -> binder) = - fun t -> let uu___ = null_bv t in mk_binder uu___ -let (imp_tag : binder_qualifier) = Implicit false -let (iarg : term -> arg) = - fun t -> - (t, - (FStar_Pervasives_Native.Some - { aqual_implicit = true; aqual_attributes = [] })) -let (as_arg : term -> arg) = fun t -> (t, FStar_Pervasives_Native.None) -let (is_top_level : letbinding Prims.list -> Prims.bool) = - fun uu___ -> - match uu___ with - | { lbname = FStar_Pervasives.Inr uu___1; lbunivs = uu___2; - lbtyp = uu___3; lbeff = uu___4; lbdef = uu___5; lbattrs = uu___6; - lbpos = uu___7;_}::uu___8 -> true - | uu___1 -> false -let (freenames_of_binders : binders -> freenames) = - fun bs -> - let uu___ = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic (FStar_Compiler_FlatSet.setlike_flat_set ord_bv)) ()) in - FStar_Compiler_List.fold_right - (fun uu___2 -> - fun uu___1 -> - (fun b -> - fun out -> - Obj.magic - (FStar_Class_Setlike.add () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set ord_bv)) - b.binder_bv (Obj.magic out))) uu___2 uu___1) bs uu___ -let (binders_of_list : bv Prims.list -> binders) = - fun fvs -> FStar_Compiler_List.map (fun t -> mk_binder t) fvs -let (binders_of_freenames : freenames -> binders) = - fun fvs -> - let uu___ = - FStar_Class_Setlike.elems () - (Obj.magic (FStar_Compiler_FlatSet.setlike_flat_set ord_bv)) - (Obj.magic fvs) in - binders_of_list uu___ -let (is_bqual_implicit : bqual -> Prims.bool) = - fun uu___ -> - match uu___ with - | FStar_Pervasives_Native.Some (Implicit uu___1) -> true - | uu___1 -> false -let (is_aqual_implicit : aqual -> Prims.bool) = - fun uu___ -> - match uu___ with - | FStar_Pervasives_Native.Some - { aqual_implicit = b; aqual_attributes = uu___1;_} -> b - | uu___1 -> false -let (is_bqual_implicit_or_meta : bqual -> Prims.bool) = - fun uu___ -> - match uu___ with - | FStar_Pervasives_Native.Some (Implicit uu___1) -> true - | FStar_Pervasives_Native.Some (Meta uu___1) -> true - | uu___1 -> false -let (as_bqual_implicit : Prims.bool -> bqual) = - fun uu___ -> - if uu___ - then FStar_Pervasives_Native.Some imp_tag - else FStar_Pervasives_Native.None -let (as_aqual_implicit : Prims.bool -> aqual) = - fun uu___ -> - if uu___ - then - FStar_Pervasives_Native.Some - { aqual_implicit = true; aqual_attributes = [] } - else FStar_Pervasives_Native.None -let (pat_bvs : pat -> bv Prims.list) = - fun p -> - let rec aux b p1 = - match p1.v with - | Pat_dot_term uu___ -> b - | Pat_constant uu___ -> b - | Pat_var x -> x :: b - | Pat_cons (uu___, uu___1, pats) -> - FStar_Compiler_List.fold_left - (fun b1 -> - fun uu___2 -> match uu___2 with | (p2, uu___3) -> aux b1 p2) b - pats in - let uu___ = aux [] p in FStar_Compiler_List.rev uu___ -let (freshen_binder : binder -> binder) = - fun b -> - let uu___ = freshen_bv b.binder_bv in - { - binder_bv = uu___; - binder_qual = (b.binder_qual); - binder_positivity = (b.binder_positivity); - binder_attrs = (b.binder_attrs) - } -let (new_univ_name : - FStar_Compiler_Range_Type.range FStar_Pervasives_Native.option -> univ_name) - = - fun ropt -> - let id = FStar_GenSym.next_id () in - let uu___ = - let uu___1 = - let uu___2 = FStar_Compiler_Util.string_of_int id in - Prims.strcat FStar_Ident.reserved_prefix uu___2 in - (uu___1, (range_of_ropt ropt)) in - FStar_Ident.mk_ident uu___ -let (lbname_eq : - (bv, FStar_Ident.lident) FStar_Pervasives.either -> - (bv, FStar_Ident.lident) FStar_Pervasives.either -> Prims.bool) - = - fun l1 -> - fun l2 -> - match (l1, l2) with - | (FStar_Pervasives.Inl x, FStar_Pervasives.Inl y) -> bv_eq x y - | (FStar_Pervasives.Inr l, FStar_Pervasives.Inr m) -> - FStar_Ident.lid_equals l m - | uu___ -> false -let (fv_eq : fv -> fv -> Prims.bool) = - fun fv1 -> - fun fv2 -> FStar_Ident.lid_equals (fv1.fv_name).v (fv2.fv_name).v -let (fv_eq_lid : fv -> FStar_Ident.lident -> Prims.bool) = - fun fv1 -> fun lid -> FStar_Ident.lid_equals (fv1.fv_name).v lid -let (set_bv_range : bv -> FStar_Compiler_Range_Type.range -> bv) = - fun bv1 -> - fun r -> - let uu___ = FStar_Ident.set_id_range r bv1.ppname in - { ppname = uu___; index = (bv1.index); sort = (bv1.sort) } -let (lid_and_dd_as_fv : - FStar_Ident.lident -> fv_qual FStar_Pervasives_Native.option -> fv) = - fun l -> - fun dq -> - let uu___ = - let uu___1 = FStar_Ident.range_of_lid l in withinfo l uu___1 in - { fv_name = uu___; fv_qual = dq } -let (lid_as_fv : - FStar_Ident.lident -> fv_qual FStar_Pervasives_Native.option -> fv) = - fun l -> - fun dq -> - let uu___ = - let uu___1 = FStar_Ident.range_of_lid l in withinfo l uu___1 in - { fv_name = uu___; fv_qual = dq } -let (fv_to_tm : fv -> term) = - fun fv1 -> - let uu___ = FStar_Ident.range_of_lid (fv1.fv_name).v in - mk (Tm_fvar fv1) uu___ -let (fvar_with_dd : - FStar_Ident.lident -> fv_qual FStar_Pervasives_Native.option -> term) = - fun l -> fun dq -> let uu___ = lid_and_dd_as_fv l dq in fv_to_tm uu___ -let (fvar : - FStar_Ident.lident -> fv_qual FStar_Pervasives_Native.option -> term) = - fun l -> fun dq -> let uu___ = lid_as_fv l dq in fv_to_tm uu___ -let (lid_of_fv : fv -> FStar_Ident.lid) = fun fv1 -> (fv1.fv_name).v -let (range_of_fv : fv -> FStar_Compiler_Range_Type.range) = - fun fv1 -> let uu___ = lid_of_fv fv1 in FStar_Ident.range_of_lid uu___ -let (set_range_of_fv : fv -> FStar_Compiler_Range_Type.range -> fv) = - fun fv1 -> - fun r -> - let uu___ = - let uu___1 = fv1.fv_name in - let uu___2 = - let uu___3 = lid_of_fv fv1 in FStar_Ident.set_lid_range uu___3 r in - { v = uu___2; p = (uu___1.p) } in - { fv_name = uu___; fv_qual = (fv1.fv_qual) } -let (has_simple_attribute : term Prims.list -> Prims.string -> Prims.bool) = - fun l -> - fun s -> - FStar_Compiler_List.existsb - (fun uu___ -> - match uu___ with - | { n = Tm_constant (FStar_Const.Const_string (data, uu___1)); - pos = uu___2; vars = uu___3; hash_code = uu___4;_} when - data = s -> true - | uu___1 -> false) l -let rec (eq_pat : pat -> pat -> Prims.bool) = - fun p1 -> - fun p2 -> - match ((p1.v), (p2.v)) with - | (Pat_constant c1, Pat_constant c2) -> FStar_Const.eq_const c1 c2 - | (Pat_cons (fv1, us1, as1), Pat_cons (fv2, us2, as2)) -> - let uu___ = - (fv_eq fv1 fv2) && - ((FStar_Compiler_List.length as1) = - (FStar_Compiler_List.length as2)) in - if uu___ - then - (FStar_Compiler_List.forall2 - (fun uu___1 -> - fun uu___2 -> - match (uu___1, uu___2) with - | ((p11, b1), (p21, b2)) -> (b1 = b2) && (eq_pat p11 p21)) - as1 as2) - && - ((match (us1, us2) with - | (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None) -> true - | (FStar_Pervasives_Native.Some us11, - FStar_Pervasives_Native.Some us21) -> - (FStar_Compiler_List.length us11) = - (FStar_Compiler_List.length us21) - | uu___1 -> false)) - else false - | (Pat_var uu___, Pat_var uu___1) -> true - | (Pat_dot_term uu___, Pat_dot_term uu___1) -> true - | (uu___, uu___1) -> false -let (delta_constant : delta_depth) = Delta_constant_at_level Prims.int_zero -let (delta_equational : delta_depth) = - Delta_equational_at_level Prims.int_zero -let (fvconst : FStar_Ident.lident -> fv) = - fun l -> lid_and_dd_as_fv l FStar_Pervasives_Native.None -let (tconst : FStar_Ident.lident -> term) = - fun l -> - let uu___ = let uu___1 = fvconst l in Tm_fvar uu___1 in - mk uu___ FStar_Compiler_Range_Type.dummyRange -let (tabbrev : FStar_Ident.lident -> term) = - fun l -> - let uu___ = - let uu___1 = lid_and_dd_as_fv l FStar_Pervasives_Native.None in - Tm_fvar uu___1 in - mk uu___ FStar_Compiler_Range_Type.dummyRange -let (tdataconstr : FStar_Ident.lident -> term) = - fun l -> - let uu___ = lid_and_dd_as_fv l (FStar_Pervasives_Native.Some Data_ctor) in - fv_to_tm uu___ -let (t_unit : term) = tconst FStar_Parser_Const.unit_lid -let (t_bool : term) = tconst FStar_Parser_Const.bool_lid -let (t_int : term) = tconst FStar_Parser_Const.int_lid -let (t_string : term) = tconst FStar_Parser_Const.string_lid -let (t_exn : term) = tconst FStar_Parser_Const.exn_lid -let (t_real : term) = tconst FStar_Parser_Const.real_lid -let (t_float : term) = tconst FStar_Parser_Const.float_lid -let (t_char : term) = tabbrev FStar_Parser_Const.char_lid -let (t_range : term) = tconst FStar_Parser_Const.range_lid -let (t___range : term) = tconst FStar_Parser_Const.__range_lid -let (t_vconfig : term) = tconst FStar_Parser_Const.vconfig_lid -let (t_term : term) = tconst FStar_Parser_Const.term_lid -let (t_term_view : term) = tabbrev FStar_Parser_Const.term_view_lid -let (t_order : term) = tconst FStar_Parser_Const.order_lid -let (t_decls : term) = tabbrev FStar_Parser_Const.decls_lid -let (t_binder : term) = tconst FStar_Parser_Const.binder_lid -let (t_binders : term) = tconst FStar_Parser_Const.binders_lid -let (t_bv : term) = tconst FStar_Parser_Const.bv_lid -let (t_fv : term) = tconst FStar_Parser_Const.fv_lid -let (t_norm_step : term) = tconst FStar_Parser_Const.norm_step_lid -let (t_tac_of : term -> term -> term) = - fun a -> - fun b -> - let uu___ = - let uu___1 = tabbrev FStar_Parser_Const.tac_lid in - mk_Tm_uinst uu___1 [U_zero; U_zero] in - let uu___1 = - let uu___2 = as_arg a in - let uu___3 = let uu___4 = as_arg b in [uu___4] in uu___2 :: uu___3 in - mk_Tm_app uu___ uu___1 FStar_Compiler_Range_Type.dummyRange -let (t_tactic_of : term -> term) = - fun t -> - let uu___ = - let uu___1 = tabbrev FStar_Parser_Const.tactic_lid in - mk_Tm_uinst uu___1 [U_zero] in - let uu___1 = let uu___2 = as_arg t in [uu___2] in - mk_Tm_app uu___ uu___1 FStar_Compiler_Range_Type.dummyRange -let (t_tactic_unit : term) = t_tactic_of t_unit -let (t_list_of : term -> term) = - fun t -> - let uu___ = - let uu___1 = tabbrev FStar_Parser_Const.list_lid in - mk_Tm_uinst uu___1 [U_zero] in - let uu___1 = let uu___2 = as_arg t in [uu___2] in - mk_Tm_app uu___ uu___1 FStar_Compiler_Range_Type.dummyRange -let (t_option_of : term -> term) = - fun t -> - let uu___ = - let uu___1 = tabbrev FStar_Parser_Const.option_lid in - mk_Tm_uinst uu___1 [U_zero] in - let uu___1 = let uu___2 = as_arg t in [uu___2] in - mk_Tm_app uu___ uu___1 FStar_Compiler_Range_Type.dummyRange -let (t_tuple2_of : term -> term -> term) = - fun t1 -> - fun t2 -> - let uu___ = - let uu___1 = tabbrev FStar_Parser_Const.lid_tuple2 in - mk_Tm_uinst uu___1 [U_zero; U_zero] in - let uu___1 = - let uu___2 = as_arg t1 in - let uu___3 = let uu___4 = as_arg t2 in [uu___4] in uu___2 :: uu___3 in - mk_Tm_app uu___ uu___1 FStar_Compiler_Range_Type.dummyRange -let (t_tuple3_of : term -> term -> term -> term) = - fun t1 -> - fun t2 -> - fun t3 -> - let uu___ = - let uu___1 = tabbrev FStar_Parser_Const.lid_tuple3 in - mk_Tm_uinst uu___1 [U_zero; U_zero; U_zero] in - let uu___1 = - let uu___2 = as_arg t1 in - let uu___3 = - let uu___4 = as_arg t2 in - let uu___5 = let uu___6 = as_arg t3 in [uu___6] in uu___4 :: - uu___5 in - uu___2 :: uu___3 in - mk_Tm_app uu___ uu___1 FStar_Compiler_Range_Type.dummyRange -let (t_tuple4_of : term -> term -> term -> term -> term) = - fun t1 -> - fun t2 -> - fun t3 -> - fun t4 -> - let uu___ = - let uu___1 = tabbrev FStar_Parser_Const.lid_tuple4 in - mk_Tm_uinst uu___1 [U_zero; U_zero; U_zero; U_zero] in - let uu___1 = - let uu___2 = as_arg t1 in - let uu___3 = - let uu___4 = as_arg t2 in - let uu___5 = - let uu___6 = as_arg t3 in - let uu___7 = let uu___8 = as_arg t4 in [uu___8] in uu___6 :: - uu___7 in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - mk_Tm_app uu___ uu___1 FStar_Compiler_Range_Type.dummyRange -let (t_tuple5_of : term -> term -> term -> term -> term -> term) = - fun t1 -> - fun t2 -> - fun t3 -> - fun t4 -> - fun t5 -> - let uu___ = - let uu___1 = tabbrev FStar_Parser_Const.lid_tuple5 in - mk_Tm_uinst uu___1 [U_zero; U_zero; U_zero; U_zero; U_zero] in - let uu___1 = - let uu___2 = as_arg t1 in - let uu___3 = - let uu___4 = as_arg t2 in - let uu___5 = - let uu___6 = as_arg t3 in - let uu___7 = - let uu___8 = as_arg t4 in - let uu___9 = let uu___10 = as_arg t5 in [uu___10] in - uu___8 :: uu___9 in - uu___6 :: uu___7 in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - mk_Tm_app uu___ uu___1 FStar_Compiler_Range_Type.dummyRange -let (t_either_of : term -> term -> term) = - fun t1 -> - fun t2 -> - let uu___ = - let uu___1 = tabbrev FStar_Parser_Const.either_lid in - mk_Tm_uinst uu___1 [U_zero; U_zero] in - let uu___1 = - let uu___2 = as_arg t1 in - let uu___3 = let uu___4 = as_arg t2 in [uu___4] in uu___2 :: uu___3 in - mk_Tm_app uu___ uu___1 FStar_Compiler_Range_Type.dummyRange -let (t_sealed_of : term -> term) = - fun t -> - let uu___ = - let uu___1 = tabbrev FStar_Parser_Const.sealed_lid in - mk_Tm_uinst uu___1 [U_zero] in - let uu___1 = let uu___2 = as_arg t in [uu___2] in - mk_Tm_app uu___ uu___1 FStar_Compiler_Range_Type.dummyRange -let (t_erased_of : term -> term) = - fun t -> - let uu___ = - let uu___1 = tabbrev FStar_Parser_Const.erased_lid in - mk_Tm_uinst uu___1 [U_zero] in - let uu___1 = let uu___2 = as_arg t in [uu___2] in - mk_Tm_app uu___ uu___1 FStar_Compiler_Range_Type.dummyRange -let (unit_const_with_range : FStar_Compiler_Range_Type.range -> term) = - fun r -> mk (Tm_constant FStar_Const.Const_unit) r -let (unit_const : term) = - unit_const_with_range FStar_Compiler_Range_Type.dummyRange -let (show_restriction : restriction FStar_Class_Show.showable) = - { - FStar_Class_Show.show = - (fun uu___ -> - match uu___ with - | Unrestricted -> "Unrestricted" - | AllowList allow_list -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - (FStar_Class_Show.show_tuple2 - FStar_Ident.showable_ident - (FStar_Class_Show.show_option - FStar_Ident.showable_ident))) allow_list in - Prims.strcat uu___2 ")" in - Prims.strcat "(AllowList " uu___1) - } -let (is_ident_allowed_by_restriction' : - FStar_Ident.ident -> - restriction -> FStar_Ident.ident FStar_Pervasives_Native.option) - = - fun id -> - fun uu___ -> - match uu___ with - | Unrestricted -> FStar_Pervasives_Native.Some id - | AllowList allow_list -> - let uu___1 = - FStar_Compiler_List.find - (fun uu___2 -> - match uu___2 with - | (dest_id, renamed_id) -> - FStar_Class_Deq.op_Equals_Question deq_univ_name - (FStar_Compiler_Util.dflt dest_id renamed_id) id) - allow_list in - FStar_Compiler_Util.map_opt uu___1 FStar_Pervasives_Native.fst -let (is_ident_allowed_by_restriction : - FStar_Ident.ident -> - restriction -> FStar_Ident.ident FStar_Pervasives_Native.option) - = - let debug = FStar_Compiler_Debug.get_toggle "open_include_restrictions" in - fun id -> - fun restriction1 -> - let result = is_ident_allowed_by_restriction' id restriction1 in - (let uu___1 = FStar_Compiler_Effect.op_Bang debug in - if uu___1 - then - let uu___2 = - let uu___3 = - let uu___4 = FStar_Class_Show.show FStar_Ident.showable_ident id in - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Class_Show.show show_restriction restriction1 in - let uu___8 = - let uu___9 = - FStar_Class_Show.show - (FStar_Class_Show.show_option - FStar_Ident.showable_ident) result in - Prims.strcat ") = " uu___9 in - Prims.strcat uu___7 uu___8 in - Prims.strcat ", " uu___6 in - Prims.strcat uu___4 uu___5 in - Prims.strcat "is_ident_allowed_by_restriction(" uu___3 in - FStar_Compiler_Util.print_endline uu___2 - else ()); - result -let has_range_syntax : 'a . unit -> 'a syntax FStar_Class_HasRange.hasRange = - fun uu___ -> - { - FStar_Class_HasRange.pos = (fun t -> t.pos); - FStar_Class_HasRange.setPos = - (fun r -> - fun t -> - { n = (t.n); pos = r; vars = (t.vars); hash_code = (t.hash_code) - }) - } -let has_range_withinfo : - 'a . unit -> 'a withinfo_t FStar_Class_HasRange.hasRange = - fun uu___ -> - { - FStar_Class_HasRange.pos = (fun t -> t.p); - FStar_Class_HasRange.setPos = (fun r -> fun t -> { v = (t.v); p = r }) - } -let (has_range_sigelt : sigelt FStar_Class_HasRange.hasRange) = - { - FStar_Class_HasRange.pos = (fun t -> t.sigrng); - FStar_Class_HasRange.setPos = - (fun r -> - fun t -> - { - sigel = (t.sigel); - sigrng = r; - sigquals = (t.sigquals); - sigmeta = (t.sigmeta); - sigattrs = (t.sigattrs); - sigopens_and_abbrevs = (t.sigopens_and_abbrevs); - sigopts = (t.sigopts) - }) - } -let (hasRange_fv : fv FStar_Class_HasRange.hasRange) = - { - FStar_Class_HasRange.pos = range_of_fv; - FStar_Class_HasRange.setPos = (fun r -> fun f -> set_range_of_fv f r) - } -let (hasRange_bv : bv FStar_Class_HasRange.hasRange) = - { - FStar_Class_HasRange.pos = range_of_bv; - FStar_Class_HasRange.setPos = (fun r -> fun f -> set_range_of_bv f r) - } -let (hasRange_binder : binder FStar_Class_HasRange.hasRange) = - { - FStar_Class_HasRange.pos = - (fun b -> FStar_Class_HasRange.pos hasRange_bv b.binder_bv); - FStar_Class_HasRange.setPos = - (fun r -> - fun b -> - let uu___ = FStar_Class_HasRange.setPos hasRange_bv r b.binder_bv in - { - binder_bv = uu___; - binder_qual = (b.binder_qual); - binder_positivity = (b.binder_positivity); - binder_attrs = (b.binder_attrs) - }) - } -let (showable_lazy_kind : lazy_kind FStar_Class_Show.showable) = - { - FStar_Class_Show.show = - (fun uu___ -> - match uu___ with - | BadLazy -> "BadLazy" - | Lazy_bv -> "Lazy_bv" - | Lazy_namedv -> "Lazy_namedv" - | Lazy_binder -> "Lazy_binder" - | Lazy_optionstate -> "Lazy_optionstate" - | Lazy_fvar -> "Lazy_fvar" - | Lazy_comp -> "Lazy_comp" - | Lazy_env -> "Lazy_env" - | Lazy_proofstate -> "Lazy_proofstate" - | Lazy_goal -> "Lazy_goal" - | Lazy_sigelt -> "Lazy_sigelt" - | Lazy_letbinding -> "Lazy_letbinding" - | Lazy_uvar -> "Lazy_uvar" - | Lazy_universe -> "Lazy_universe" - | Lazy_universe_uvar -> "Lazy_universe_uvar" - | Lazy_issue -> "Lazy_issue" - | Lazy_doc -> "Lazy_doc" - | Lazy_ident -> "Lazy_ident" - | Lazy_tref -> "Lazy_tref" - | Lazy_embedding uu___1 -> "Lazy_embedding _" - | Lazy_extension s -> Prims.strcat "Lazy_extension " s - | uu___1 -> failwith "FIXME! lazy_kind_to_string must be complete") - } -let (deq_lazy_kind : lazy_kind FStar_Class_Deq.deq) = - { - FStar_Class_Deq.op_Equals_Question = - (fun k -> - fun k' -> - match (k, k') with - | (BadLazy, BadLazy) -> true - | (Lazy_bv, Lazy_bv) -> true - | (Lazy_namedv, Lazy_namedv) -> true - | (Lazy_binder, Lazy_binder) -> true - | (Lazy_optionstate, Lazy_optionstate) -> true - | (Lazy_fvar, Lazy_fvar) -> true - | (Lazy_comp, Lazy_comp) -> true - | (Lazy_env, Lazy_env) -> true - | (Lazy_proofstate, Lazy_proofstate) -> true - | (Lazy_goal, Lazy_goal) -> true - | (Lazy_sigelt, Lazy_sigelt) -> true - | (Lazy_letbinding, Lazy_letbinding) -> true - | (Lazy_uvar, Lazy_uvar) -> true - | (Lazy_universe, Lazy_universe) -> true - | (Lazy_universe_uvar, Lazy_universe_uvar) -> true - | (Lazy_issue, Lazy_issue) -> true - | (Lazy_ident, Lazy_ident) -> true - | (Lazy_doc, Lazy_doc) -> true - | (Lazy_tref, Lazy_tref) -> true - | (Lazy_extension s, Lazy_extension t) -> s = t - | (Lazy_embedding uu___, uu___1) -> false - | (uu___, Lazy_embedding uu___1) -> false - | uu___ -> false) - } -let (tagged_term : term FStar_Class_Tagged.tagged) = - { - FStar_Class_Tagged.tag_of = - (fun t -> - match t.n with - | Tm_bvar { ppname = uu___; index = uu___1; sort = uu___2;_} -> - "Tm_bvar" - | Tm_name { ppname = uu___; index = uu___1; sort = uu___2;_} -> - "Tm_name" - | Tm_fvar { fv_name = uu___; fv_qual = uu___1;_} -> "Tm_fvar" - | Tm_uinst (uu___, uu___1) -> "Tm_uinst" - | Tm_constant uu___ -> "Tm_constant" - | Tm_type uu___ -> "Tm_type" - | Tm_quoted - (uu___, { qkind = Quote_static; antiquotations = uu___1;_}) -> - "Tm_quoted(static)" - | Tm_quoted - (uu___, { qkind = Quote_dynamic; antiquotations = uu___1;_}) -> - "Tm_quoted(dynamic)" - | Tm_abs { bs = uu___; body = uu___1; rc_opt = uu___2;_} -> "Tm_abs" - | Tm_arrow { bs1 = uu___; comp = uu___1;_} -> "Tm_arrow" - | Tm_refine { b = uu___; phi = uu___1;_} -> "Tm_refine" - | Tm_app { hd = uu___; args = uu___1;_} -> "Tm_app" - | Tm_match - { scrutinee = uu___; ret_opt = uu___1; brs = uu___2; - rc_opt1 = uu___3;_} - -> "Tm_match" - | Tm_ascribed { tm = uu___; asc = uu___1; eff_opt = uu___2;_} -> - "Tm_ascribed" - | Tm_let { lbs = uu___; body1 = uu___1;_} -> "Tm_let" - | Tm_uvar (uu___, uu___1) -> "Tm_uvar" - | Tm_delayed { tm1 = uu___; substs = uu___1;_} -> "Tm_delayed" - | Tm_meta { tm2 = uu___; meta = uu___1;_} -> "Tm_meta" - | Tm_unknown -> "Tm_unknown" - | Tm_lazy - { blob = uu___; lkind = uu___1; ltyp = uu___2; rng = uu___3;_} - -> "Tm_lazy") - } -let (tagged_sigelt : sigelt FStar_Class_Tagged.tagged) = - { - FStar_Class_Tagged.tag_of = - (fun se -> - match se.sigel with - | Sig_inductive_typ - { lid = uu___; us = uu___1; params = uu___2; - num_uniform_params = uu___3; t = uu___4; mutuals = uu___5; - ds = uu___6; injective_type_params = uu___7;_} - -> "Sig_inductive_typ" - | Sig_bundle { ses = uu___; lids = uu___1;_} -> "Sig_bundle" - | Sig_datacon - { lid1 = uu___; us1 = uu___1; t1 = uu___2; ty_lid = uu___3; - num_ty_params = uu___4; mutuals1 = uu___5; - injective_type_params1 = uu___6;_} - -> "Sig_datacon" - | Sig_declare_typ { lid2 = uu___; us2 = uu___1; t2 = uu___2;_} -> - "Sig_declare_typ" - | Sig_let { lbs1 = uu___; lids1 = uu___1;_} -> "Sig_let" - | Sig_assume { lid3 = uu___; us3 = uu___1; phi1 = uu___2;_} -> - "Sig_assume" - | Sig_new_effect - { mname = uu___; cattributes = uu___1; univs = uu___2; - binders = uu___3; signature = uu___4; combinators = uu___5; - actions = uu___6; eff_attrs = uu___7; - extraction_mode = uu___8;_} - -> "Sig_new_effect" - | Sig_sub_effect - { source = uu___; target = uu___1; lift_wp = uu___2; - lift = uu___3; kind = uu___4;_} - -> "Sig_sub_effect" - | Sig_effect_abbrev - { lid4 = uu___; us4 = uu___1; bs2 = uu___2; comp1 = uu___3; - cflags = uu___4;_} - -> "Sig_effect_abbrev" - | Sig_pragma uu___ -> "Sig_pragma" - | Sig_splice { is_typed = uu___; lids2 = uu___1; tac = uu___2;_} -> - "Sig_splice" - | Sig_polymonadic_bind - { m_lid = uu___; n_lid = uu___1; p_lid = uu___2; tm3 = uu___3; - typ = uu___4; kind1 = uu___5;_} - -> "Sig_polymonadic_bind" - | Sig_polymonadic_subcomp - { m_lid1 = uu___; n_lid1 = uu___1; tm4 = uu___2; typ1 = uu___3; - kind2 = uu___4;_} - -> "Sig_polymonadic_subcomp" - | Sig_fail { errs = uu___; fail_in_lax = uu___1; ses1 = uu___2;_} -> - "Sig_fail") - } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_Unionfind.ml b/ocaml/fstar-lib/generated/FStar_Syntax_Unionfind.ml deleted file mode 100644 index 45c7d487764..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Syntax_Unionfind.ml +++ /dev/null @@ -1,412 +0,0 @@ -open Prims -type vops_t = - { - next_major: unit -> FStar_Syntax_Syntax.version ; - next_minor: unit -> FStar_Syntax_Syntax.version } -let (__proj__Mkvops_t__item__next_major : - vops_t -> unit -> FStar_Syntax_Syntax.version) = - fun projectee -> - match projectee with | { next_major; next_minor;_} -> next_major -let (__proj__Mkvops_t__item__next_minor : - vops_t -> unit -> FStar_Syntax_Syntax.version) = - fun projectee -> - match projectee with | { next_major; next_minor;_} -> next_minor -let (vops : vops_t) = - let major = FStar_Compiler_Util.mk_ref Prims.int_zero in - let minor = FStar_Compiler_Util.mk_ref Prims.int_zero in - let next_major uu___ = - FStar_Compiler_Effect.op_Colon_Equals minor Prims.int_zero; - (let uu___2 = - FStar_Compiler_Util.incr major; FStar_Compiler_Effect.op_Bang major in - { - FStar_Syntax_Syntax.major = uu___2; - FStar_Syntax_Syntax.minor = Prims.int_zero - }) in - let next_minor uu___ = - let uu___1 = FStar_Compiler_Effect.op_Bang major in - let uu___2 = - FStar_Compiler_Util.incr minor; FStar_Compiler_Effect.op_Bang minor in - { FStar_Syntax_Syntax.major = uu___1; FStar_Syntax_Syntax.minor = uu___2 - } in - { next_major; next_minor } -type tgraph = - (FStar_Syntax_Syntax.term FStar_Pervasives_Native.option * - FStar_Syntax_Syntax.uvar_decoration) FStar_Unionfind.puf -type ugraph = - FStar_Syntax_Syntax.universe FStar_Pervasives_Native.option - FStar_Unionfind.puf -type uf = - { - term_graph: tgraph ; - univ_graph: ugraph ; - version: FStar_Syntax_Syntax.version ; - ro: Prims.bool } -let (__proj__Mkuf__item__term_graph : uf -> tgraph) = - fun projectee -> - match projectee with - | { term_graph; univ_graph; version; ro;_} -> term_graph -let (__proj__Mkuf__item__univ_graph : uf -> ugraph) = - fun projectee -> - match projectee with - | { term_graph; univ_graph; version; ro;_} -> univ_graph -let (__proj__Mkuf__item__version : uf -> FStar_Syntax_Syntax.version) = - fun projectee -> - match projectee with - | { term_graph; univ_graph; version; ro;_} -> version -let (__proj__Mkuf__item__ro : uf -> Prims.bool) = - fun projectee -> - match projectee with | { term_graph; univ_graph; version; ro;_} -> ro -let (empty : FStar_Syntax_Syntax.version -> uf) = - fun v -> - let uu___ = FStar_Unionfind.puf_empty () in - let uu___1 = FStar_Unionfind.puf_empty () in - { term_graph = uu___; univ_graph = uu___1; version = v; ro = false } -let (version_to_string : FStar_Syntax_Syntax.version -> Prims.string) = - fun v -> - let uu___ = FStar_Compiler_Util.string_of_int v.FStar_Syntax_Syntax.major in - let uu___1 = - FStar_Compiler_Util.string_of_int v.FStar_Syntax_Syntax.minor in - FStar_Compiler_Util.format2 "%s.%s" uu___ uu___1 -let (state : uf FStar_Compiler_Effect.ref) = - let uu___ = let uu___1 = vops.next_major () in empty uu___1 in - FStar_Compiler_Util.mk_ref uu___ -type tx = - | TX of uf -let (uu___is_TX : tx -> Prims.bool) = fun projectee -> true -let (__proj__TX__item___0 : tx -> uf) = - fun projectee -> match projectee with | TX _0 -> _0 -let (get : unit -> uf) = fun uu___ -> FStar_Compiler_Effect.op_Bang state -let (set_ro : unit -> unit) = - fun uu___ -> - let s = get () in - FStar_Compiler_Effect.op_Colon_Equals state - { - term_graph = (s.term_graph); - univ_graph = (s.univ_graph); - version = (s.version); - ro = true - } -let (set_rw : unit -> unit) = - fun uu___ -> - let s = get () in - FStar_Compiler_Effect.op_Colon_Equals state - { - term_graph = (s.term_graph); - univ_graph = (s.univ_graph); - version = (s.version); - ro = false - } -let with_uf_enabled : 'a . (unit -> 'a) -> 'a = - fun f -> - let s = get () in - set_rw (); - (let restore uu___1 = if s.ro then set_ro () else () in - let r = - let uu___1 = FStar_Options.trace_error () in - if uu___1 - then f () - else - (try (fun uu___3 -> match () with | () -> f ()) () - with | uu___3 -> (restore (); FStar_Compiler_Effect.raise uu___3)) in - restore (); r) -let (fail_if_ro : unit -> unit) = - fun uu___ -> - let uu___1 = let uu___2 = get () in uu___2.ro in - if uu___1 - then - FStar_Errors.raise_error0 FStar_Errors_Codes.Fatal_BadUvar () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic "Internal error: UF graph was in read-only mode") - else () -let (set : uf -> unit) = - fun u -> fail_if_ro (); FStar_Compiler_Effect.op_Colon_Equals state u -let (reset : unit -> unit) = - fun uu___ -> - fail_if_ro (); - (let v = vops.next_major () in - let uu___2 = - let uu___3 = empty v in - { - term_graph = (uu___3.term_graph); - univ_graph = (uu___3.univ_graph); - version = (uu___3.version); - ro = false - } in - set uu___2) -let (new_transaction : unit -> tx) = - fun uu___ -> - let tx1 = let uu___1 = get () in TX uu___1 in - (let uu___2 = - let uu___3 = get () in - let uu___4 = vops.next_minor () in - { - term_graph = (uu___3.term_graph); - univ_graph = (uu___3.univ_graph); - version = uu___4; - ro = (uu___3.ro) - } in - set uu___2); - tx1 -let (commit : tx -> unit) = fun tx1 -> () -let (rollback : tx -> unit) = - fun uu___ -> match uu___ with | TX uf1 -> set uf1 -let update_in_tx : 'a . 'a FStar_Compiler_Effect.ref -> 'a -> unit = - fun r -> fun x -> () -let (get_term_graph : unit -> tgraph) = - fun uu___ -> let uu___1 = get () in uu___1.term_graph -let (get_version : unit -> FStar_Syntax_Syntax.version) = - fun uu___ -> let uu___1 = get () in uu___1.version -let (set_term_graph : tgraph -> unit) = - fun tg -> - let uu___ = - let uu___1 = get () in - { - term_graph = tg; - univ_graph = (uu___1.univ_graph); - version = (uu___1.version); - ro = (uu___1.ro) - } in - set uu___ -let (chk_v_t : - FStar_Syntax_Syntax.uvar -> - (FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - FStar_Pervasives_Native.option * FStar_Syntax_Syntax.uvar_decoration) - FStar_Unionfind.p_uvar) - = - fun su -> - let uu___ = su in - match uu___ with - | (u, v, rng) -> - let uvar_to_string u1 = - let uu___1 = - let uu___2 = FStar_Unionfind.puf_unique_id u1 in - FStar_Compiler_Util.string_of_int uu___2 in - Prims.strcat "?" uu___1 in - let expected = get_version () in - if - (v.FStar_Syntax_Syntax.major = expected.FStar_Syntax_Syntax.major) - && - (v.FStar_Syntax_Syntax.minor <= - expected.FStar_Syntax_Syntax.minor) - then u - else - (let uu___2 = - let uu___3 = - let uu___4 = - FStar_Errors_Msg.text - "Internal error: incompatible version for term unification variable" in - let uu___5 = - let uu___6 = uvar_to_string u in - FStar_Pprint.doc_of_string uu___6 in - FStar_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in - let uu___4 = - let uu___5 = - let uu___6 = FStar_Errors_Msg.text "Current version: " in - let uu___7 = - let uu___8 = version_to_string expected in - FStar_Pprint.doc_of_string uu___8 in - FStar_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in - let uu___6 = - let uu___7 = - let uu___8 = FStar_Errors_Msg.text "Got version: " in - let uu___9 = - let uu___10 = version_to_string v in - FStar_Pprint.doc_of_string uu___10 in - FStar_Pprint.op_Hat_Slash_Hat uu___8 uu___9 in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range rng - FStar_Errors_Codes.Fatal_BadUvar () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___2)) -let (uvar_id : FStar_Syntax_Syntax.uvar -> Prims.int) = - fun u -> - let uu___ = get_term_graph () in - let uu___1 = chk_v_t u in FStar_Unionfind.puf_id uu___ uu___1 -let (uvar_unique_id : FStar_Syntax_Syntax.uvar -> Prims.int) = - fun u -> let uu___ = chk_v_t u in FStar_Unionfind.puf_unique_id uu___ -let (fresh : - FStar_Syntax_Syntax.uvar_decoration -> - FStar_Compiler_Range_Type.range -> FStar_Syntax_Syntax.uvar) - = - fun decoration -> - fun rng -> - fail_if_ro (); - (let uu___1 = - let uu___2 = get_term_graph () in - FStar_Unionfind.puf_fresh uu___2 - (FStar_Pervasives_Native.None, decoration) in - let uu___2 = get_version () in (uu___1, uu___2, rng)) -let (find_core : - FStar_Syntax_Syntax.uvar -> - (FStar_Syntax_Syntax.term FStar_Pervasives_Native.option * - FStar_Syntax_Syntax.uvar_decoration)) - = - fun u -> - let uu___ = get_term_graph () in - let uu___1 = chk_v_t u in FStar_Unionfind.puf_find uu___ uu___1 -let (find : - FStar_Syntax_Syntax.uvar -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = fun u -> let uu___ = find_core u in FStar_Pervasives_Native.fst uu___ -let (find_decoration : - FStar_Syntax_Syntax.uvar -> FStar_Syntax_Syntax.uvar_decoration) = - fun u -> let uu___ = find_core u in FStar_Pervasives_Native.snd uu___ -let (change : FStar_Syntax_Syntax.uvar -> FStar_Syntax_Syntax.term -> unit) = - fun u -> - fun t -> - let uu___ = find_core u in - match uu___ with - | (uu___1, dec) -> - let uu___2 = - let uu___3 = get_term_graph () in - let uu___4 = chk_v_t u in - FStar_Unionfind.puf_change uu___3 uu___4 - ((FStar_Pervasives_Native.Some t), dec) in - set_term_graph uu___2 -let (change_decoration : - FStar_Syntax_Syntax.uvar -> FStar_Syntax_Syntax.uvar_decoration -> unit) = - fun u -> - fun d -> - let uu___ = find_core u in - match uu___ with - | (t, uu___1) -> - let uu___2 = - let uu___3 = get_term_graph () in - let uu___4 = chk_v_t u in - FStar_Unionfind.puf_change uu___3 uu___4 (t, d) in - set_term_graph uu___2 -let (equiv : - FStar_Syntax_Syntax.uvar -> FStar_Syntax_Syntax.uvar -> Prims.bool) = - fun u -> - fun v -> - let uu___ = get_term_graph () in - let uu___1 = chk_v_t u in - let uu___2 = chk_v_t v in - FStar_Unionfind.puf_equivalent uu___ uu___1 uu___2 -let (union : FStar_Syntax_Syntax.uvar -> FStar_Syntax_Syntax.uvar -> unit) = - fun u -> - fun v -> - let uu___ = - let uu___1 = get_term_graph () in - let uu___2 = chk_v_t u in - let uu___3 = chk_v_t v in - FStar_Unionfind.puf_union uu___1 uu___2 uu___3 in - set_term_graph uu___ -let (get_univ_graph : unit -> ugraph) = - fun uu___ -> let uu___1 = get () in uu___1.univ_graph -let chk_v_u : - 'uuuuu . - ('uuuuu FStar_Unionfind.p_uvar * FStar_Syntax_Syntax.version * - FStar_Compiler_Range_Type.range) -> 'uuuuu FStar_Unionfind.p_uvar - = - fun uu___ -> - match uu___ with - | (u, v, rng) -> - let uvar_to_string u1 = - let uu___1 = - let uu___2 = FStar_Unionfind.puf_unique_id u1 in - FStar_Compiler_Util.string_of_int uu___2 in - Prims.strcat "?" uu___1 in - let expected = get_version () in - if - (v.FStar_Syntax_Syntax.major = expected.FStar_Syntax_Syntax.major) - && - (v.FStar_Syntax_Syntax.minor <= - expected.FStar_Syntax_Syntax.minor) - then u - else - (let uu___2 = - let uu___3 = - let uu___4 = - FStar_Errors_Msg.text - "Internal error: incompatible version for universe unification variable" in - let uu___5 = - let uu___6 = uvar_to_string u in - FStar_Pprint.doc_of_string uu___6 in - FStar_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in - let uu___4 = - let uu___5 = - let uu___6 = FStar_Errors_Msg.text "Current version: " in - let uu___7 = - let uu___8 = version_to_string expected in - FStar_Pprint.doc_of_string uu___8 in - FStar_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in - let uu___6 = - let uu___7 = - let uu___8 = FStar_Errors_Msg.text "Got version: " in - let uu___9 = - let uu___10 = version_to_string v in - FStar_Pprint.doc_of_string uu___10 in - FStar_Pprint.op_Hat_Slash_Hat uu___8 uu___9 in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range rng - FStar_Errors_Codes.Fatal_BadUvar () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___2)) -let (set_univ_graph : ugraph -> unit) = - fun ug -> - let uu___ = - let uu___1 = get () in - { - term_graph = (uu___1.term_graph); - univ_graph = ug; - version = (uu___1.version); - ro = (uu___1.ro) - } in - set uu___ -let (univ_uvar_id : FStar_Syntax_Syntax.universe_uvar -> Prims.int) = - fun u -> - let uu___ = get_univ_graph () in - let uu___1 = chk_v_u u in FStar_Unionfind.puf_id uu___ uu___1 -let (univ_fresh : - FStar_Compiler_Range_Type.range -> FStar_Syntax_Syntax.universe_uvar) = - fun rng -> - fail_if_ro (); - (let uu___1 = - let uu___2 = get_univ_graph () in - FStar_Unionfind.puf_fresh uu___2 FStar_Pervasives_Native.None in - let uu___2 = get_version () in (uu___1, uu___2, rng)) -let (univ_find : - FStar_Syntax_Syntax.universe_uvar -> - FStar_Syntax_Syntax.universe FStar_Pervasives_Native.option) - = - fun u -> - let uu___ = get_univ_graph () in - let uu___1 = chk_v_u u in FStar_Unionfind.puf_find uu___ uu___1 -let (univ_change : - FStar_Syntax_Syntax.universe_uvar -> FStar_Syntax_Syntax.universe -> unit) - = - fun u -> - fun t -> - let uu___ = - let uu___1 = get_univ_graph () in - let uu___2 = chk_v_u u in - FStar_Unionfind.puf_change uu___1 uu___2 - (FStar_Pervasives_Native.Some t) in - set_univ_graph uu___ -let (univ_equiv : - FStar_Syntax_Syntax.universe_uvar -> - FStar_Syntax_Syntax.universe_uvar -> Prims.bool) - = - fun u -> - fun v -> - let uu___ = get_univ_graph () in - let uu___1 = chk_v_u u in - let uu___2 = chk_v_u v in - FStar_Unionfind.puf_equivalent uu___ uu___1 uu___2 -let (univ_union : - FStar_Syntax_Syntax.universe_uvar -> - FStar_Syntax_Syntax.universe_uvar -> unit) - = - fun u -> - fun v -> - let uu___ = - let uu___1 = get_univ_graph () in - let uu___2 = chk_v_u u in - let uu___3 = chk_v_u v in - FStar_Unionfind.puf_union uu___1 uu___2 uu___3 in - set_univ_graph uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_Util.ml b/ocaml/fstar-lib/generated/FStar_Syntax_Util.ml deleted file mode 100644 index fbb07ded44b..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Syntax_Util.ml +++ /dev/null @@ -1,4661 +0,0 @@ -open Prims -let (tts_f : - (FStar_Syntax_Syntax.term -> Prims.string) FStar_Pervasives_Native.option - FStar_Compiler_Effect.ref) - = FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None -let (tts : FStar_Syntax_Syntax.term -> Prims.string) = - fun t -> - let uu___ = FStar_Compiler_Effect.op_Bang tts_f in - match uu___ with - | FStar_Pervasives_Native.None -> "<>" - | FStar_Pervasives_Native.Some f -> f t -let (ttd_f : - (FStar_Syntax_Syntax.term -> FStar_Pprint.document) - FStar_Pervasives_Native.option FStar_Compiler_Effect.ref) - = FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None -let (ttd : FStar_Syntax_Syntax.term -> FStar_Pprint.document) = - fun t -> - let uu___ = FStar_Compiler_Effect.op_Bang ttd_f in - match uu___ with - | FStar_Pervasives_Native.None -> - FStar_Pprint.doc_of_string "<>" - | FStar_Pervasives_Native.Some f -> f t -let (mk_discriminator : FStar_Ident.lident -> FStar_Ident.lident) = - fun lid -> - let uu___ = - let uu___1 = FStar_Ident.ns_of_lid lid in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = FStar_Ident.ident_of_lid lid in - FStar_Ident.string_of_id uu___8 in - Prims.strcat "is_" uu___7 in - Prims.strcat FStar_Ident.reserved_prefix uu___6 in - let uu___6 = FStar_Ident.range_of_lid lid in (uu___5, uu___6) in - FStar_Ident.mk_ident uu___4 in - [uu___3] in - FStar_Compiler_List.op_At uu___1 uu___2 in - FStar_Ident.lid_of_ids uu___ -let (is_name : FStar_Ident.lident -> Prims.bool) = - fun lid -> - let c = - let uu___ = - let uu___1 = FStar_Ident.ident_of_lid lid in - FStar_Ident.string_of_id uu___1 in - FStar_Compiler_Util.char_at uu___ Prims.int_zero in - FStar_Compiler_Util.is_upper c -let (aqual_of_binder : - FStar_Syntax_Syntax.binder -> FStar_Syntax_Syntax.aqual) = - fun b -> - match ((b.FStar_Syntax_Syntax.binder_qual), - (b.FStar_Syntax_Syntax.binder_attrs)) - with - | (FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit uu___), - uu___1) -> - FStar_Pervasives_Native.Some - { - FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = - (b.FStar_Syntax_Syntax.binder_attrs) - } - | (FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta uu___), uu___1) - -> - FStar_Pervasives_Native.Some - { - FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = - (b.FStar_Syntax_Syntax.binder_attrs) - } - | (uu___, uu___1::uu___2) -> - FStar_Pervasives_Native.Some - { - FStar_Syntax_Syntax.aqual_implicit = false; - FStar_Syntax_Syntax.aqual_attributes = - (b.FStar_Syntax_Syntax.binder_attrs) - } - | uu___ -> FStar_Pervasives_Native.None -let (bqual_and_attrs_of_aqual : - FStar_Syntax_Syntax.aqual -> - (FStar_Syntax_Syntax.bqual * FStar_Syntax_Syntax.attribute Prims.list)) - = - fun a -> - match a with - | FStar_Pervasives_Native.None -> (FStar_Pervasives_Native.None, []) - | FStar_Pervasives_Native.Some a1 -> - ((if a1.FStar_Syntax_Syntax.aqual_implicit - then FStar_Pervasives_Native.Some FStar_Syntax_Syntax.imp_tag - else FStar_Pervasives_Native.None), - (a1.FStar_Syntax_Syntax.aqual_attributes)) -let (arg_of_non_null_binder : - FStar_Syntax_Syntax.binder -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.aqual)) - = - fun b -> - let uu___ = - FStar_Syntax_Syntax.bv_to_name b.FStar_Syntax_Syntax.binder_bv in - let uu___1 = aqual_of_binder b in (uu___, uu___1) -let (args_of_non_null_binders : - FStar_Syntax_Syntax.binders -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.aqual) Prims.list) - = - fun binders -> - FStar_Compiler_List.collect - (fun b -> - let uu___ = FStar_Syntax_Syntax.is_null_binder b in - if uu___ - then [] - else (let uu___2 = arg_of_non_null_binder b in [uu___2])) binders -let (args_of_binders : - FStar_Syntax_Syntax.binders -> - (FStar_Syntax_Syntax.binders * FStar_Syntax_Syntax.args)) - = - fun binders -> - let uu___ = - FStar_Compiler_List.map - (fun b -> - let uu___1 = FStar_Syntax_Syntax.is_null_binder b in - if uu___1 - then - let b1 = - let uu___2 = - FStar_Syntax_Syntax.new_bv FStar_Pervasives_Native.None - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - { - FStar_Syntax_Syntax.binder_bv = uu___2; - FStar_Syntax_Syntax.binder_qual = - (b.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity = - (b.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs = - (b.FStar_Syntax_Syntax.binder_attrs) - } in - let uu___2 = arg_of_non_null_binder b1 in (b1, uu___2) - else (let uu___3 = arg_of_non_null_binder b in (b, uu___3))) - binders in - FStar_Compiler_List.unzip uu___ -let (name_binders : - FStar_Syntax_Syntax.binder Prims.list -> - FStar_Syntax_Syntax.binder Prims.list) - = - fun binders -> - FStar_Compiler_List.mapi - (fun i -> - fun b -> - let uu___ = FStar_Syntax_Syntax.is_null_binder b in - if uu___ - then - let bname = - let uu___1 = - let uu___2 = FStar_Compiler_Util.string_of_int i in - Prims.strcat "_" uu___2 in - FStar_Ident.id_of_text uu___1 in - let bv = - { - FStar_Syntax_Syntax.ppname = bname; - FStar_Syntax_Syntax.index = Prims.int_zero; - FStar_Syntax_Syntax.sort = - ((b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort) - } in - { - FStar_Syntax_Syntax.binder_bv = bv; - FStar_Syntax_Syntax.binder_qual = - (b.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity = - (b.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs = - (b.FStar_Syntax_Syntax.binder_attrs) - } - else b) binders -let (name_function_binders : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun t -> - match t.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = binders; - FStar_Syntax_Syntax.comp = comp;_} - -> - let uu___ = - let uu___1 = - let uu___2 = name_binders binders in - { - FStar_Syntax_Syntax.bs1 = uu___2; - FStar_Syntax_Syntax.comp = comp - } in - FStar_Syntax_Syntax.Tm_arrow uu___1 in - FStar_Syntax_Syntax.mk uu___ t.FStar_Syntax_Syntax.pos - | uu___ -> t -let (null_binders_of_tks : - (FStar_Syntax_Syntax.typ * FStar_Syntax_Syntax.bqual) Prims.list -> - FStar_Syntax_Syntax.binders) - = - fun tks -> - FStar_Compiler_List.map - (fun uu___ -> - match uu___ with - | (t, imp) -> - let uu___1 = FStar_Syntax_Syntax.null_binder t in - { - FStar_Syntax_Syntax.binder_bv = - (uu___1.FStar_Syntax_Syntax.binder_bv); - FStar_Syntax_Syntax.binder_qual = imp; - FStar_Syntax_Syntax.binder_positivity = - (uu___1.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs = - (uu___1.FStar_Syntax_Syntax.binder_attrs) - }) tks -let (binders_of_tks : - (FStar_Syntax_Syntax.typ * FStar_Syntax_Syntax.bqual) Prims.list -> - FStar_Syntax_Syntax.binders) - = - fun tks -> - FStar_Compiler_List.map - (fun uu___ -> - match uu___ with - | (t, imp) -> - let uu___1 = - FStar_Syntax_Syntax.new_bv - (FStar_Pervasives_Native.Some (t.FStar_Syntax_Syntax.pos)) t in - FStar_Syntax_Syntax.mk_binder_with_attrs uu___1 imp - FStar_Pervasives_Native.None []) tks -let mk_subst : 'uuuuu . 'uuuuu -> 'uuuuu Prims.list = fun s -> [s] -let (subst_of_list : - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.args -> FStar_Syntax_Syntax.subst_t) - = - fun formals -> - fun actuals -> - if - (FStar_Compiler_List.length formals) = - (FStar_Compiler_List.length actuals) - then - FStar_Compiler_List.fold_right2 - (fun f -> - fun a -> - fun out -> - (FStar_Syntax_Syntax.NT - ((f.FStar_Syntax_Syntax.binder_bv), - (FStar_Pervasives_Native.fst a))) - :: out) formals actuals [] - else failwith "Ill-formed substitution" -let (rename_binders : - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.binders -> FStar_Syntax_Syntax.subst_t) - = - fun replace_xs -> - fun with_ys -> - if - (FStar_Compiler_List.length replace_xs) = - (FStar_Compiler_List.length with_ys) - then - FStar_Compiler_List.map2 - (fun x -> - fun y -> - let uu___ = - let uu___1 = - FStar_Syntax_Syntax.bv_to_name - y.FStar_Syntax_Syntax.binder_bv in - ((x.FStar_Syntax_Syntax.binder_bv), uu___1) in - FStar_Syntax_Syntax.NT uu___) replace_xs with_ys - else failwith "Ill-formed substitution" -let rec (unmeta : FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = - fun e -> - let e1 = FStar_Syntax_Subst.compress e in - match e1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = e2; FStar_Syntax_Syntax.meta = uu___;_} - -> unmeta e2 - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = e2; FStar_Syntax_Syntax.asc = uu___; - FStar_Syntax_Syntax.eff_opt = uu___1;_} - -> unmeta e2 - | uu___ -> e1 -let rec (unmeta_safe : FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun e -> - let e1 = FStar_Syntax_Subst.compress e in - match e1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = e'; FStar_Syntax_Syntax.meta = m;_} -> - (match m with - | FStar_Syntax_Syntax.Meta_monadic uu___ -> e1 - | FStar_Syntax_Syntax.Meta_monadic_lift uu___ -> e1 - | uu___ -> unmeta_safe e') - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = e2; FStar_Syntax_Syntax.asc = uu___; - FStar_Syntax_Syntax.eff_opt = uu___1;_} - -> unmeta_safe e2 - | uu___ -> e1 -let (unmeta_lift : FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t1; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_monadic_lift - uu___1;_} - -> t1 - | uu___1 -> t -let rec (univ_kernel : - FStar_Syntax_Syntax.universe -> (FStar_Syntax_Syntax.universe * Prims.int)) - = - fun u -> - let uu___ = FStar_Syntax_Subst.compress_univ u in - match uu___ with - | FStar_Syntax_Syntax.U_unknown -> (u, Prims.int_zero) - | FStar_Syntax_Syntax.U_name uu___1 -> (u, Prims.int_zero) - | FStar_Syntax_Syntax.U_unif uu___1 -> (u, Prims.int_zero) - | FStar_Syntax_Syntax.U_max uu___1 -> (u, Prims.int_zero) - | FStar_Syntax_Syntax.U_zero -> (u, Prims.int_zero) - | FStar_Syntax_Syntax.U_succ u1 -> - let uu___1 = univ_kernel u1 in - (match uu___1 with | (k, n) -> (k, (n + Prims.int_one))) - | FStar_Syntax_Syntax.U_bvar i -> - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) i in - Prims.strcat uu___3 ")" in - Prims.strcat "Imposible: univ_kernel (U_bvar " uu___2 in - failwith uu___1 -let (constant_univ_as_nat : FStar_Syntax_Syntax.universe -> Prims.int) = - fun u -> let uu___ = univ_kernel u in FStar_Pervasives_Native.snd uu___ -let rec (compare_univs : - FStar_Syntax_Syntax.universe -> FStar_Syntax_Syntax.universe -> Prims.int) - = - fun u1 -> - fun u2 -> - let rec compare_kernel uk1 uk2 = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress_univ uk1 in - let uu___2 = FStar_Syntax_Subst.compress_univ uk2 in - (uu___1, uu___2) in - match uu___ with - | (FStar_Syntax_Syntax.U_bvar uu___1, uu___2) -> - failwith "Impossible: compare_kernel bvar" - | (uu___1, FStar_Syntax_Syntax.U_bvar uu___2) -> - failwith "Impossible: compare_kernel bvar" - | (FStar_Syntax_Syntax.U_succ uu___1, uu___2) -> - failwith "Impossible: compare_kernel succ" - | (uu___1, FStar_Syntax_Syntax.U_succ uu___2) -> - failwith "Impossible: compare_kernel succ" - | (FStar_Syntax_Syntax.U_unknown, FStar_Syntax_Syntax.U_unknown) -> - Prims.int_zero - | (FStar_Syntax_Syntax.U_unknown, uu___1) -> (Prims.of_int (-1)) - | (uu___1, FStar_Syntax_Syntax.U_unknown) -> Prims.int_one - | (FStar_Syntax_Syntax.U_zero, FStar_Syntax_Syntax.U_zero) -> - Prims.int_zero - | (FStar_Syntax_Syntax.U_zero, uu___1) -> (Prims.of_int (-1)) - | (uu___1, FStar_Syntax_Syntax.U_zero) -> Prims.int_one - | (FStar_Syntax_Syntax.U_name u11, FStar_Syntax_Syntax.U_name u21) -> - let uu___1 = FStar_Ident.string_of_id u11 in - let uu___2 = FStar_Ident.string_of_id u21 in - FStar_Compiler_String.compare uu___1 uu___2 - | (FStar_Syntax_Syntax.U_name uu___1, uu___2) -> (Prims.of_int (-1)) - | (uu___1, FStar_Syntax_Syntax.U_name uu___2) -> Prims.int_one - | (FStar_Syntax_Syntax.U_unif u11, FStar_Syntax_Syntax.U_unif u21) -> - let uu___1 = FStar_Syntax_Unionfind.univ_uvar_id u11 in - let uu___2 = FStar_Syntax_Unionfind.univ_uvar_id u21 in - uu___1 - uu___2 - | (FStar_Syntax_Syntax.U_unif uu___1, uu___2) -> (Prims.of_int (-1)) - | (uu___1, FStar_Syntax_Syntax.U_unif uu___2) -> Prims.int_one - | (FStar_Syntax_Syntax.U_max us1, FStar_Syntax_Syntax.U_max us2) -> - let n1 = FStar_Compiler_List.length us1 in - let n2 = FStar_Compiler_List.length us2 in - if n1 <> n2 - then n1 - n2 - else - (let copt = - let uu___2 = FStar_Compiler_List.zip us1 us2 in - FStar_Compiler_Util.find_map uu___2 - (fun uu___3 -> - match uu___3 with - | (u11, u21) -> - let c = compare_univs u11 u21 in - if c <> Prims.int_zero - then FStar_Pervasives_Native.Some c - else FStar_Pervasives_Native.None) in - match copt with - | FStar_Pervasives_Native.None -> Prims.int_zero - | FStar_Pervasives_Native.Some c -> c) in - let uu___ = univ_kernel u1 in - match uu___ with - | (uk1, n1) -> - let uu___1 = univ_kernel u2 in - (match uu___1 with - | (uk2, n2) -> - let uu___2 = compare_kernel uk1 uk2 in - (match uu___2 with - | uu___3 when uu___3 = Prims.int_zero -> n1 - n2 - | n -> n)) -let (eq_univs : - FStar_Syntax_Syntax.universe -> FStar_Syntax_Syntax.universe -> Prims.bool) - = - fun u1 -> - fun u2 -> let uu___ = compare_univs u1 u2 in uu___ = Prims.int_zero -let (eq_univs_list : - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.universes -> Prims.bool) - = - fun us -> - fun vs -> - ((FStar_Compiler_List.length us) = (FStar_Compiler_List.length vs)) && - (FStar_Compiler_List.forall2 eq_univs us vs) -let (ml_comp : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Compiler_Range_Type.range -> FStar_Syntax_Syntax.comp) - = - fun t -> - fun r -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Parser_Const.effect_ML_lid () in - FStar_Ident.set_lid_range uu___2 r in - { - FStar_Syntax_Syntax.comp_univs = [FStar_Syntax_Syntax.U_zero]; - FStar_Syntax_Syntax.effect_name = uu___1; - FStar_Syntax_Syntax.result_typ = t; - FStar_Syntax_Syntax.effect_args = []; - FStar_Syntax_Syntax.flags = [FStar_Syntax_Syntax.MLEFFECT] - } in - FStar_Syntax_Syntax.mk_Comp uu___ -let (comp_effect_name : - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> FStar_Ident.lident) - = - fun c -> - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Comp c1 -> c1.FStar_Syntax_Syntax.effect_name - | FStar_Syntax_Syntax.Total uu___ -> FStar_Parser_Const.effect_Tot_lid - | FStar_Syntax_Syntax.GTotal uu___ -> FStar_Parser_Const.effect_GTot_lid -let (comp_flags : - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.cflag Prims.list) - = - fun c -> - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total uu___ -> [FStar_Syntax_Syntax.TOTAL] - | FStar_Syntax_Syntax.GTotal uu___ -> [FStar_Syntax_Syntax.SOMETRIVIAL] - | FStar_Syntax_Syntax.Comp ct -> ct.FStar_Syntax_Syntax.flags -let (comp_eff_name_res_and_args : - FStar_Syntax_Syntax.comp -> - (FStar_Ident.lident * FStar_Syntax_Syntax.typ * FStar_Syntax_Syntax.args)) - = - fun c -> - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total t -> - (FStar_Parser_Const.effect_Tot_lid, t, []) - | FStar_Syntax_Syntax.GTotal t -> - (FStar_Parser_Const.effect_GTot_lid, t, []) - | FStar_Syntax_Syntax.Comp c1 -> - ((c1.FStar_Syntax_Syntax.effect_name), - (c1.FStar_Syntax_Syntax.result_typ), - (c1.FStar_Syntax_Syntax.effect_args)) -let (effect_indices_from_repr : - FStar_Syntax_Syntax.term -> - Prims.bool -> - FStar_Compiler_Range_Type.range -> - Prims.string -> FStar_Syntax_Syntax.term Prims.list) - = - fun repr -> - fun is_layered -> - fun r -> - fun err -> - let err1 uu___ = - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_UnexpectedEffect () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic err) in - let repr1 = FStar_Syntax_Subst.compress repr in - if is_layered - then - match repr1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = uu___; - FStar_Syntax_Syntax.args = uu___1::is;_} - -> FStar_Compiler_List.map FStar_Pervasives_Native.fst is - | uu___ -> err1 () - else - (match repr1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = uu___1; - FStar_Syntax_Syntax.comp = c;_} - -> - let uu___2 = comp_eff_name_res_and_args c in - (match uu___2 with - | (uu___3, uu___4, args) -> - FStar_Compiler_List.map FStar_Pervasives_Native.fst - args) - | uu___1 -> err1 ()) -let (destruct_comp : - FStar_Syntax_Syntax.comp_typ -> - (FStar_Syntax_Syntax.universe * FStar_Syntax_Syntax.typ * - FStar_Syntax_Syntax.typ)) - = - fun c -> - let wp = - match c.FStar_Syntax_Syntax.effect_args with - | (wp1, uu___)::[] -> wp1 - | uu___ -> - let uu___1 = - let uu___2 = - FStar_Ident.string_of_lid c.FStar_Syntax_Syntax.effect_name in - let uu___3 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length c.FStar_Syntax_Syntax.effect_args) in - FStar_Compiler_Util.format2 - "Impossible: Got a computation %s with %s effect args" uu___2 - uu___3 in - failwith uu___1 in - let uu___ = FStar_Compiler_List.hd c.FStar_Syntax_Syntax.comp_univs in - (uu___, (c.FStar_Syntax_Syntax.result_typ), wp) -let (is_named_tot : - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> Prims.bool) = - fun c -> - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Comp c1 -> - FStar_Ident.lid_equals c1.FStar_Syntax_Syntax.effect_name - FStar_Parser_Const.effect_Tot_lid - | FStar_Syntax_Syntax.Total uu___ -> true - | FStar_Syntax_Syntax.GTotal uu___ -> false -let (is_total_comp : - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> Prims.bool) = - fun c -> - (FStar_Ident.lid_equals (comp_effect_name c) - FStar_Parser_Const.effect_Tot_lid) - || - (FStar_Compiler_Util.for_some - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.TOTAL -> true - | FStar_Syntax_Syntax.RETURN -> true - | uu___1 -> false) (comp_flags c)) -let (is_partial_return : - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> Prims.bool) = - fun c -> - FStar_Compiler_Util.for_some - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.RETURN -> true - | FStar_Syntax_Syntax.PARTIAL_RETURN -> true - | uu___1 -> false) (comp_flags c) -let (is_tot_or_gtot_comp : - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> Prims.bool) = - fun c -> - (is_total_comp c) || - (FStar_Ident.lid_equals FStar_Parser_Const.effect_GTot_lid - (comp_effect_name c)) -let (is_pure_effect : FStar_Ident.lident -> Prims.bool) = - fun l -> - ((FStar_Ident.lid_equals l FStar_Parser_Const.effect_Tot_lid) || - (FStar_Ident.lid_equals l FStar_Parser_Const.effect_PURE_lid)) - || (FStar_Ident.lid_equals l FStar_Parser_Const.effect_Pure_lid) -let (is_pure_comp : - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> Prims.bool) = - fun c -> - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total uu___ -> true - | FStar_Syntax_Syntax.GTotal uu___ -> false - | FStar_Syntax_Syntax.Comp ct -> - ((is_total_comp c) || - (is_pure_effect ct.FStar_Syntax_Syntax.effect_name)) - || - (FStar_Compiler_Util.for_some - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.LEMMA -> true - | uu___1 -> false) ct.FStar_Syntax_Syntax.flags) -let (is_ghost_effect : FStar_Ident.lident -> Prims.bool) = - fun l -> - ((FStar_Ident.lid_equals FStar_Parser_Const.effect_GTot_lid l) || - (FStar_Ident.lid_equals FStar_Parser_Const.effect_GHOST_lid l)) - || (FStar_Ident.lid_equals FStar_Parser_Const.effect_Ghost_lid l) -let (is_div_effect : FStar_Ident.lident -> Prims.bool) = - fun l -> - ((FStar_Ident.lid_equals l FStar_Parser_Const.effect_DIV_lid) || - (FStar_Ident.lid_equals l FStar_Parser_Const.effect_Div_lid)) - || (FStar_Ident.lid_equals l FStar_Parser_Const.effect_Dv_lid) -let (is_pure_or_ghost_comp : - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> Prims.bool) = - fun c -> (is_pure_comp c) || (is_ghost_effect (comp_effect_name c)) -let (is_pure_or_ghost_effect : FStar_Ident.lident -> Prims.bool) = - fun l -> (is_pure_effect l) || (is_ghost_effect l) -let (is_pure_or_ghost_function : FStar_Syntax_Syntax.term -> Prims.bool) = - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = uu___1; FStar_Syntax_Syntax.comp = c;_} - -> is_pure_or_ghost_comp c - | uu___1 -> true -let (is_lemma_comp : - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> Prims.bool) = - fun c -> - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Comp ct -> - FStar_Ident.lid_equals ct.FStar_Syntax_Syntax.effect_name - FStar_Parser_Const.effect_Lemma_lid - | uu___ -> false -let (is_lemma : FStar_Syntax_Syntax.term -> Prims.bool) = - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = uu___1; FStar_Syntax_Syntax.comp = c;_} - -> is_lemma_comp c - | uu___1 -> false -let rec (head_of : FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = t1; FStar_Syntax_Syntax.args = uu___1;_} - -> head_of t1 - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = t1; - FStar_Syntax_Syntax.ret_opt = uu___1; - FStar_Syntax_Syntax.brs = uu___2; - FStar_Syntax_Syntax.rc_opt1 = uu___3;_} - -> head_of t1 - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = uu___1; FStar_Syntax_Syntax.body = t1; - FStar_Syntax_Syntax.rc_opt = uu___2;_} - -> head_of t1 - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t1; FStar_Syntax_Syntax.asc = uu___1; - FStar_Syntax_Syntax.eff_opt = uu___2;_} - -> head_of t1 - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t1; FStar_Syntax_Syntax.meta = uu___1;_} - -> head_of t1 - | uu___1 -> t -let (head_and_args : - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * - (FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) - Prims.list)) - = - fun t -> - let t1 = FStar_Syntax_Subst.compress t in - match t1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head; FStar_Syntax_Syntax.args = args;_} - -> (head, args) - | uu___ -> (t1, []) -let rec (__head_and_args_full : - (FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) - Prims.list -> - Prims.bool -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * (FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax * FStar_Syntax_Syntax.arg_qualifier - FStar_Pervasives_Native.option) Prims.list)) - = - fun acc -> - fun unmeta1 -> - fun t -> - let t1 = FStar_Syntax_Subst.compress t in - match t1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = args;_} - -> - __head_and_args_full (FStar_Compiler_List.op_At args acc) unmeta1 - head - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = tm; - FStar_Syntax_Syntax.meta = uu___;_} - when unmeta1 -> __head_and_args_full acc unmeta1 tm - | uu___ -> (t1, acc) -let (head_and_args_full : - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * (FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax * FStar_Syntax_Syntax.arg_qualifier - FStar_Pervasives_Native.option) Prims.list)) - = fun t -> __head_and_args_full [] false t -let (head_and_args_full_unmeta : - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * (FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax * FStar_Syntax_Syntax.arg_qualifier - FStar_Pervasives_Native.option) Prims.list)) - = fun t -> __head_and_args_full [] true t -let rec (leftmost_head : - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = - fun t -> - let t1 = FStar_Syntax_Subst.compress t in - match t1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = t0; FStar_Syntax_Syntax.args = uu___;_} -> - leftmost_head t0 - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t0; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_pattern uu___;_} - -> leftmost_head t0 - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t0; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_named uu___;_} - -> leftmost_head t0 - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t0; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_labeled uu___;_} - -> leftmost_head t0 - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t0; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_desugared uu___;_} - -> leftmost_head t0 - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t0; FStar_Syntax_Syntax.asc = uu___; - FStar_Syntax_Syntax.eff_opt = uu___1;_} - -> leftmost_head t0 - | uu___ -> t1 -let (leftmost_head_and_args : - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * (FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax * FStar_Syntax_Syntax.arg_qualifier - FStar_Pervasives_Native.option) Prims.list)) - = - fun t -> - let rec aux t1 args = - let t2 = FStar_Syntax_Subst.compress t1 in - match t2.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = t0; FStar_Syntax_Syntax.args = args';_} - -> aux t0 (FStar_Compiler_List.op_At args' args) - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t0; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_pattern uu___;_} - -> aux t0 args - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t0; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_named uu___;_} - -> aux t0 args - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t0; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_labeled uu___;_} - -> aux t0 args - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t0; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_desugared - uu___;_} - -> aux t0 args - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t0; FStar_Syntax_Syntax.asc = uu___; - FStar_Syntax_Syntax.eff_opt = uu___1;_} - -> aux t0 args - | uu___ -> (t2, args) in - aux t [] -let (un_uinst : FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = - fun t -> - let t1 = FStar_Syntax_Subst.compress t in - match t1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_uinst (t2, uu___) -> - FStar_Syntax_Subst.compress t2 - | uu___ -> t1 -let (is_ml_comp : - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> Prims.bool) = - fun c -> - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Comp c1 -> - (let uu___ = FStar_Parser_Const.effect_ML_lid () in - FStar_Ident.lid_equals c1.FStar_Syntax_Syntax.effect_name uu___) || - (FStar_Compiler_Util.for_some - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.MLEFFECT -> true - | uu___1 -> false) c1.FStar_Syntax_Syntax.flags) - | uu___ -> false -let (comp_result : - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun c -> - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total t -> t - | FStar_Syntax_Syntax.GTotal t -> t - | FStar_Syntax_Syntax.Comp ct -> ct.FStar_Syntax_Syntax.result_typ -let (set_result_typ : - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.comp) - = - fun c -> - fun t -> - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total uu___ -> FStar_Syntax_Syntax.mk_Total t - | FStar_Syntax_Syntax.GTotal uu___ -> FStar_Syntax_Syntax.mk_GTotal t - | FStar_Syntax_Syntax.Comp ct -> - FStar_Syntax_Syntax.mk_Comp - { - FStar_Syntax_Syntax.comp_univs = - (ct.FStar_Syntax_Syntax.comp_univs); - FStar_Syntax_Syntax.effect_name = - (ct.FStar_Syntax_Syntax.effect_name); - FStar_Syntax_Syntax.result_typ = t; - FStar_Syntax_Syntax.effect_args = - (ct.FStar_Syntax_Syntax.effect_args); - FStar_Syntax_Syntax.flags = (ct.FStar_Syntax_Syntax.flags) - } -let (is_trivial_wp : - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> Prims.bool) = - fun c -> - FStar_Compiler_Util.for_some - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.TOTAL -> true - | FStar_Syntax_Syntax.RETURN -> true - | uu___1 -> false) (comp_flags c) -let (comp_effect_args : FStar_Syntax_Syntax.comp -> FStar_Syntax_Syntax.args) - = - fun c -> - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total uu___ -> [] - | FStar_Syntax_Syntax.GTotal uu___ -> [] - | FStar_Syntax_Syntax.Comp ct -> ct.FStar_Syntax_Syntax.effect_args -let (primops : FStar_Ident.lident Prims.list) = - [FStar_Parser_Const.op_Eq; - FStar_Parser_Const.op_notEq; - FStar_Parser_Const.op_LT; - FStar_Parser_Const.op_LTE; - FStar_Parser_Const.op_GT; - FStar_Parser_Const.op_GTE; - FStar_Parser_Const.op_Subtraction; - FStar_Parser_Const.op_Minus; - FStar_Parser_Const.op_Addition; - FStar_Parser_Const.op_Multiply; - FStar_Parser_Const.op_Division; - FStar_Parser_Const.op_Modulus; - FStar_Parser_Const.op_And; - FStar_Parser_Const.op_Or; - FStar_Parser_Const.op_Negation] -let (is_primop_lid : FStar_Ident.lident -> Prims.bool) = - fun l -> FStar_Compiler_Util.for_some (FStar_Ident.lid_equals l) primops -let (is_primop : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> Prims.bool) = - fun f -> - match f.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_fvar fv -> - is_primop_lid (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - | uu___ -> false -let rec (unascribe : FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = - fun e -> - let e1 = FStar_Syntax_Subst.compress e in - match e1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = e2; FStar_Syntax_Syntax.asc = uu___; - FStar_Syntax_Syntax.eff_opt = uu___1;_} - -> unascribe e2 - | uu___ -> e1 -let rec (ascribe : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - ((FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax, - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax) - FStar_Pervasives.either * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax FStar_Pervasives_Native.option * Prims.bool) - -> FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun t -> - fun k -> - match t.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t'; FStar_Syntax_Syntax.asc = uu___; - FStar_Syntax_Syntax.eff_opt = uu___1;_} - -> ascribe t' k - | uu___ -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_ascribed - { - FStar_Syntax_Syntax.tm = t; - FStar_Syntax_Syntax.asc = k; - FStar_Syntax_Syntax.eff_opt = FStar_Pervasives_Native.None - }) t.FStar_Syntax_Syntax.pos -let (unfold_lazy : FStar_Syntax_Syntax.lazyinfo -> FStar_Syntax_Syntax.term) - = - fun i -> - let uu___ = - let uu___1 = - FStar_Compiler_Effect.op_Bang FStar_Syntax_Syntax.lazy_chooser in - FStar_Compiler_Util.must uu___1 in - uu___ i.FStar_Syntax_Syntax.lkind i -let rec (unlazy : FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_lazy i -> - let uu___1 = unfold_lazy i in unlazy uu___1 - | uu___1 -> t -let (unlazy_emb : FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_lazy i -> - (match i.FStar_Syntax_Syntax.lkind with - | FStar_Syntax_Syntax.Lazy_embedding uu___1 -> - let uu___2 = unfold_lazy i in unlazy uu___2 - | uu___1 -> t) - | uu___1 -> t -let unlazy_as_t : - 'uuuuu . - FStar_Syntax_Syntax.lazy_kind -> FStar_Syntax_Syntax.term -> 'uuuuu - = - fun k -> - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_lazy - { FStar_Syntax_Syntax.blob = v; FStar_Syntax_Syntax.lkind = k'; - FStar_Syntax_Syntax.ltyp = uu___1; - FStar_Syntax_Syntax.rng = uu___2;_} - -> - let uu___3 = - FStar_Class_Deq.op_Equals_Question - FStar_Syntax_Syntax.deq_lazy_kind k k' in - if uu___3 - then FStar_Dyn.undyn v - else - (let uu___5 = - let uu___6 = - FStar_Class_Show.show FStar_Syntax_Syntax.showable_lazy_kind - k in - let uu___7 = - FStar_Class_Show.show FStar_Syntax_Syntax.showable_lazy_kind - k' in - FStar_Compiler_Util.format2 - "Expected Tm_lazy of kind %s, got %s" uu___6 uu___7 in - failwith uu___5) - | uu___1 -> failwith "Not a Tm_lazy of the expected kind" -let mk_lazy : - 'a . - 'a -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.lazy_kind -> - FStar_Compiler_Range_Type.range FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.term - = - fun t -> - fun typ -> - fun k -> - fun r -> - let rng = - match r with - | FStar_Pervasives_Native.Some r1 -> r1 - | FStar_Pervasives_Native.None -> - FStar_Compiler_Range_Type.dummyRange in - let i = - { - FStar_Syntax_Syntax.blob = (FStar_Dyn.mkdyn t); - FStar_Syntax_Syntax.lkind = k; - FStar_Syntax_Syntax.ltyp = typ; - FStar_Syntax_Syntax.rng = rng - } in - FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_lazy i) rng -let (canon_app : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term) - = - fun t -> - let uu___ = let uu___1 = unascribe t in head_and_args_full uu___1 in - match uu___ with - | (hd, args) -> - FStar_Syntax_Syntax.mk_Tm_app hd args t.FStar_Syntax_Syntax.pos -let rec (unrefine : FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = - fun t -> - let t1 = FStar_Syntax_Subst.compress t in - match t1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x; FStar_Syntax_Syntax.phi = uu___;_} -> - unrefine x.FStar_Syntax_Syntax.sort - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t2; FStar_Syntax_Syntax.asc = uu___; - FStar_Syntax_Syntax.eff_opt = uu___1;_} - -> unrefine t2 - | uu___ -> t1 -let rec (is_uvar : FStar_Syntax_Syntax.term -> Prims.bool) = - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_uvar uu___1 -> true - | FStar_Syntax_Syntax.Tm_uinst (t1, uu___1) -> is_uvar t1 - | FStar_Syntax_Syntax.Tm_app uu___1 -> - let uu___2 = - let uu___3 = head_and_args t in FStar_Pervasives_Native.fst uu___3 in - is_uvar uu___2 - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t1; FStar_Syntax_Syntax.asc = uu___1; - FStar_Syntax_Syntax.eff_opt = uu___2;_} - -> is_uvar t1 - | uu___1 -> false -let rec (is_unit : FStar_Syntax_Syntax.term -> Prims.bool) = - fun t -> - let uu___ = let uu___1 = unrefine t in uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_fvar fv -> - ((FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.unit_lid) || - (FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.squash_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.auto_squash_lid) - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head; FStar_Syntax_Syntax.args = uu___1;_} - -> is_unit head - | FStar_Syntax_Syntax.Tm_uinst (t1, uu___1) -> is_unit t1 - | uu___1 -> false -let (is_eqtype_no_unrefine : FStar_Syntax_Syntax.term -> Prims.bool) = - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_fvar fv -> - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.eqtype_lid - | uu___1 -> false -let (is_fun : FStar_Syntax_Syntax.term -> Prims.bool) = - fun e -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress e in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_abs uu___1 -> true - | uu___1 -> false -let (is_function_typ : FStar_Syntax_Syntax.term -> Prims.bool) = - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_arrow uu___1 -> true - | uu___1 -> false -let rec (pre_typ : FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = - fun t -> - let t1 = FStar_Syntax_Subst.compress t in - match t1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x; FStar_Syntax_Syntax.phi = uu___;_} -> - pre_typ x.FStar_Syntax_Syntax.sort - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t2; FStar_Syntax_Syntax.asc = uu___; - FStar_Syntax_Syntax.eff_opt = uu___1;_} - -> pre_typ t2 - | uu___ -> t1 -let (destruct : - FStar_Syntax_Syntax.term -> - FStar_Ident.lident -> - (FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) - Prims.list FStar_Pervasives_Native.option) - = - fun typ -> - fun lid -> - let typ1 = FStar_Syntax_Subst.compress typ in - let uu___ = let uu___1 = un_uinst typ1 in uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head; FStar_Syntax_Syntax.args = args;_} - -> - let head1 = un_uinst head in - (match head1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_fvar tc when - FStar_Syntax_Syntax.fv_eq_lid tc lid -> - FStar_Pervasives_Native.Some args - | uu___1 -> FStar_Pervasives_Native.None) - | FStar_Syntax_Syntax.Tm_fvar tc when - FStar_Syntax_Syntax.fv_eq_lid tc lid -> - FStar_Pervasives_Native.Some [] - | uu___1 -> FStar_Pervasives_Native.None -let (lids_of_sigelt : - FStar_Syntax_Syntax.sigelt -> FStar_Ident.lident Prims.list) = - fun se -> - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = uu___; - FStar_Syntax_Syntax.lids1 = lids;_} - -> lids - | FStar_Syntax_Syntax.Sig_splice - { FStar_Syntax_Syntax.is_typed = uu___; - FStar_Syntax_Syntax.lids2 = lids; - FStar_Syntax_Syntax.tac = uu___1;_} - -> lids - | FStar_Syntax_Syntax.Sig_bundle - { FStar_Syntax_Syntax.ses = uu___; FStar_Syntax_Syntax.lids = lids;_} - -> lids - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = lid; FStar_Syntax_Syntax.us = uu___; - FStar_Syntax_Syntax.params = uu___1; - FStar_Syntax_Syntax.num_uniform_params = uu___2; - FStar_Syntax_Syntax.t = uu___3; - FStar_Syntax_Syntax.mutuals = uu___4; - FStar_Syntax_Syntax.ds = uu___5; - FStar_Syntax_Syntax.injective_type_params = uu___6;_} - -> [lid] - | FStar_Syntax_Syntax.Sig_effect_abbrev - { FStar_Syntax_Syntax.lid4 = lid; FStar_Syntax_Syntax.us4 = uu___; - FStar_Syntax_Syntax.bs2 = uu___1; - FStar_Syntax_Syntax.comp1 = uu___2; - FStar_Syntax_Syntax.cflags = uu___3;_} - -> [lid] - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = lid; FStar_Syntax_Syntax.us1 = uu___; - FStar_Syntax_Syntax.t1 = uu___1; - FStar_Syntax_Syntax.ty_lid = uu___2; - FStar_Syntax_Syntax.num_ty_params = uu___3; - FStar_Syntax_Syntax.mutuals1 = uu___4; - FStar_Syntax_Syntax.injective_type_params1 = uu___5;_} - -> [lid] - | FStar_Syntax_Syntax.Sig_declare_typ - { FStar_Syntax_Syntax.lid2 = lid; FStar_Syntax_Syntax.us2 = uu___; - FStar_Syntax_Syntax.t2 = uu___1;_} - -> [lid] - | FStar_Syntax_Syntax.Sig_assume - { FStar_Syntax_Syntax.lid3 = lid; FStar_Syntax_Syntax.us3 = uu___; - FStar_Syntax_Syntax.phi1 = uu___1;_} - -> [lid] - | FStar_Syntax_Syntax.Sig_new_effect d -> [d.FStar_Syntax_Syntax.mname] - | FStar_Syntax_Syntax.Sig_sub_effect uu___ -> [] - | FStar_Syntax_Syntax.Sig_pragma uu___ -> [] - | FStar_Syntax_Syntax.Sig_fail uu___ -> [] - | FStar_Syntax_Syntax.Sig_polymonadic_bind uu___ -> [] - | FStar_Syntax_Syntax.Sig_polymonadic_subcomp uu___ -> [] -let (lid_of_sigelt : - FStar_Syntax_Syntax.sigelt -> - FStar_Ident.lident FStar_Pervasives_Native.option) - = - fun se -> - match lids_of_sigelt se with - | l::[] -> FStar_Pervasives_Native.Some l - | uu___ -> FStar_Pervasives_Native.None -let (quals_of_sigelt : - FStar_Syntax_Syntax.sigelt -> FStar_Syntax_Syntax.qualifier Prims.list) = - fun x -> x.FStar_Syntax_Syntax.sigquals -let (range_of_sigelt : - FStar_Syntax_Syntax.sigelt -> FStar_Compiler_Range_Type.range) = - fun x -> x.FStar_Syntax_Syntax.sigrng -let range_of_arg : - 'uuuuu 'uuuuu1 . - ('uuuuu FStar_Syntax_Syntax.syntax * 'uuuuu1) -> - FStar_Compiler_Range_Type.range - = - fun uu___ -> match uu___ with | (hd, uu___1) -> hd.FStar_Syntax_Syntax.pos -let range_of_args : - 'uuuuu 'uuuuu1 . - ('uuuuu FStar_Syntax_Syntax.syntax * 'uuuuu1) Prims.list -> - FStar_Compiler_Range_Type.range -> FStar_Compiler_Range_Type.range - = - fun args -> - fun r -> - FStar_Compiler_List.fold_left - (fun r1 -> - fun a -> FStar_Compiler_Range_Ops.union_ranges r1 (range_of_arg a)) - r args -let (mk_app : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - (FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) - Prims.list -> FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun f -> - fun args -> - match args with - | [] -> f - | uu___ -> - let r = range_of_args args f.FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = f; FStar_Syntax_Syntax.args = args - }) r -let (mk_app_binders : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.binder Prims.list -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun f -> - fun bs -> - let uu___ = - FStar_Compiler_List.map - (fun b -> - let uu___1 = - FStar_Syntax_Syntax.bv_to_name b.FStar_Syntax_Syntax.binder_bv in - let uu___2 = aqual_of_binder b in (uu___1, uu___2)) bs in - mk_app f uu___ -let (field_projector_prefix : Prims.string) = "__proj__" -let (field_projector_sep : Prims.string) = "__item__" -let (field_projector_contains_constructor : Prims.string -> Prims.bool) = - fun s -> FStar_Compiler_Util.starts_with s field_projector_prefix -let (mk_field_projector_name_from_string : - Prims.string -> Prims.string -> Prims.string) = - fun constr -> - fun field -> - Prims.strcat field_projector_prefix - (Prims.strcat constr (Prims.strcat field_projector_sep field)) -let (mk_field_projector_name_from_ident : - FStar_Ident.lident -> FStar_Ident.ident -> FStar_Ident.lident) = - fun lid -> - fun i -> - let itext = FStar_Ident.string_of_id i in - let newi = - if field_projector_contains_constructor itext - then i - else - (let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Ident.ident_of_lid lid in - FStar_Ident.string_of_id uu___4 in - mk_field_projector_name_from_string uu___3 itext in - let uu___3 = FStar_Ident.range_of_id i in (uu___2, uu___3) in - FStar_Ident.mk_ident uu___1) in - let uu___ = - let uu___1 = FStar_Ident.ns_of_lid lid in - FStar_Compiler_List.op_At uu___1 [newi] in - FStar_Ident.lid_of_ids uu___ -let (mk_field_projector_name : - FStar_Ident.lident -> - FStar_Syntax_Syntax.bv -> Prims.int -> FStar_Ident.lident) - = - fun lid -> - fun x -> - fun i -> - let nm = - let uu___ = FStar_Syntax_Syntax.is_null_bv x in - if uu___ - then - let uu___1 = - let uu___2 = - let uu___3 = FStar_Compiler_Util.string_of_int i in - Prims.strcat "_" uu___3 in - let uu___3 = FStar_Syntax_Syntax.range_of_bv x in - (uu___2, uu___3) in - FStar_Ident.mk_ident uu___1 - else x.FStar_Syntax_Syntax.ppname in - mk_field_projector_name_from_ident lid nm -let (ses_of_sigbundle : - FStar_Syntax_Syntax.sigelt -> FStar_Syntax_Syntax.sigelt Prims.list) = - fun se -> - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_bundle - { FStar_Syntax_Syntax.ses = ses; FStar_Syntax_Syntax.lids = uu___;_} - -> ses - | uu___ -> failwith "ses_of_sigbundle: not a Sig_bundle" -let (set_uvar : FStar_Syntax_Syntax.uvar -> FStar_Syntax_Syntax.term -> unit) - = - fun uv -> - fun t -> - let uu___ = FStar_Syntax_Unionfind.find uv in - match uu___ with - | FStar_Pervasives_Native.Some t' -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Unionfind.uvar_id uv in - FStar_Compiler_Util.string_of_int uu___3 in - let uu___3 = tts t in - let uu___4 = tts t' in - FStar_Compiler_Util.format3 - "Changing a fixed uvar! ?%s to %s but it is already set to %s\n" - uu___2 uu___3 uu___4 in - failwith uu___1 - | uu___1 -> FStar_Syntax_Unionfind.change uv t -let (qualifier_equal : - FStar_Syntax_Syntax.qualifier -> - FStar_Syntax_Syntax.qualifier -> Prims.bool) - = - fun q1 -> - fun q2 -> - match (q1, q2) with - | (FStar_Syntax_Syntax.Discriminator l1, - FStar_Syntax_Syntax.Discriminator l2) -> - FStar_Ident.lid_equals l1 l2 - | (FStar_Syntax_Syntax.Projector (l1a, l1b), - FStar_Syntax_Syntax.Projector (l2a, l2b)) -> - (FStar_Ident.lid_equals l1a l2a) && - (let uu___ = FStar_Ident.string_of_id l1b in - let uu___1 = FStar_Ident.string_of_id l2b in uu___ = uu___1) - | (FStar_Syntax_Syntax.RecordType (ns1, f1), - FStar_Syntax_Syntax.RecordType (ns2, f2)) -> - ((((FStar_Compiler_List.length ns1) = - (FStar_Compiler_List.length ns2)) - && - (FStar_Compiler_List.forall2 - (fun x1 -> - fun x2 -> - let uu___ = FStar_Ident.string_of_id x1 in - let uu___1 = FStar_Ident.string_of_id x2 in - uu___ = uu___1) f1 f2)) - && - ((FStar_Compiler_List.length f1) = - (FStar_Compiler_List.length f2))) - && - (FStar_Compiler_List.forall2 - (fun x1 -> - fun x2 -> - let uu___ = FStar_Ident.string_of_id x1 in - let uu___1 = FStar_Ident.string_of_id x2 in - uu___ = uu___1) f1 f2) - | (FStar_Syntax_Syntax.RecordConstructor (ns1, f1), - FStar_Syntax_Syntax.RecordConstructor (ns2, f2)) -> - ((((FStar_Compiler_List.length ns1) = - (FStar_Compiler_List.length ns2)) - && - (FStar_Compiler_List.forall2 - (fun x1 -> - fun x2 -> - let uu___ = FStar_Ident.string_of_id x1 in - let uu___1 = FStar_Ident.string_of_id x2 in - uu___ = uu___1) f1 f2)) - && - ((FStar_Compiler_List.length f1) = - (FStar_Compiler_List.length f2))) - && - (FStar_Compiler_List.forall2 - (fun x1 -> - fun x2 -> - let uu___ = FStar_Ident.string_of_id x1 in - let uu___1 = FStar_Ident.string_of_id x2 in - uu___ = uu___1) f1 f2) - | uu___ -> q1 = q2 -let (abs : - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun bs -> - fun t -> - fun lopt -> - let close_lopt lopt1 = - match lopt1 with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some rc -> - let uu___ = - let uu___1 = - FStar_Compiler_Util.map_opt - rc.FStar_Syntax_Syntax.residual_typ - (FStar_Syntax_Subst.close bs) in - { - FStar_Syntax_Syntax.residual_effect = - (rc.FStar_Syntax_Syntax.residual_effect); - FStar_Syntax_Syntax.residual_typ = uu___1; - FStar_Syntax_Syntax.residual_flags = - (rc.FStar_Syntax_Syntax.residual_flags) - } in - FStar_Pervasives_Native.Some uu___ in - match bs with - | [] -> t - | uu___ -> - let body = - let uu___1 = FStar_Syntax_Subst.close bs t in - FStar_Syntax_Subst.compress uu___1 in - (match body.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs'; - FStar_Syntax_Syntax.body = t1; - FStar_Syntax_Syntax.rc_opt = lopt';_} - -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Subst.close_binders bs in - FStar_Compiler_List.op_At uu___4 bs' in - let uu___4 = close_lopt lopt' in - { - FStar_Syntax_Syntax.bs = uu___3; - FStar_Syntax_Syntax.body = t1; - FStar_Syntax_Syntax.rc_opt = uu___4 - } in - FStar_Syntax_Syntax.Tm_abs uu___2 in - FStar_Syntax_Syntax.mk uu___1 t1.FStar_Syntax_Syntax.pos - | uu___1 -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Subst.close_binders bs in - let uu___5 = close_lopt lopt in - { - FStar_Syntax_Syntax.bs = uu___4; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = uu___5 - } in - FStar_Syntax_Syntax.Tm_abs uu___3 in - FStar_Syntax_Syntax.mk uu___2 t.FStar_Syntax_Syntax.pos) -let (arrow_ln : - FStar_Syntax_Syntax.binder Prims.list -> - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun bs -> - fun c -> - match bs with - | [] -> comp_result c - | uu___ -> - let uu___1 = - FStar_Compiler_List.fold_left - (fun a -> - fun b -> - FStar_Compiler_Range_Ops.union_ranges a - ((b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort).FStar_Syntax_Syntax.pos) - c.FStar_Syntax_Syntax.pos bs in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; FStar_Syntax_Syntax.comp = c }) - uu___1 -let (arrow : - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.comp -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun bs -> - fun c -> - let c1 = FStar_Syntax_Subst.close_comp bs c in - let bs1 = FStar_Syntax_Subst.close_binders bs in arrow_ln bs1 c1 -let (flat_arrow : - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.comp -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun bs -> - fun c -> - let t = arrow bs c in - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs1; FStar_Syntax_Syntax.comp = c1;_} - -> - (match c1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total tres -> - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress tres in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs'; - FStar_Syntax_Syntax.comp = c';_} - -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 = - (FStar_Compiler_List.op_At bs1 bs'); - FStar_Syntax_Syntax.comp = c' - }) t.FStar_Syntax_Syntax.pos - | uu___2 -> t) - | uu___1 -> t) - | uu___1 -> t -let rec (canon_arrow : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; FStar_Syntax_Syntax.comp = c;_} -> - let cn = - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total t1 -> - let uu___1 = canon_arrow t1 in FStar_Syntax_Syntax.Total uu___1 - | uu___1 -> c.FStar_Syntax_Syntax.n in - let c1 = - { - FStar_Syntax_Syntax.n = cn; - FStar_Syntax_Syntax.pos = (c.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = (c.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = (c.FStar_Syntax_Syntax.hash_code) - } in - flat_arrow bs c1 - | uu___1 -> t -let (refine : - FStar_Syntax_Syntax.bv -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun b -> - fun t -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Syntax.mk_binder b in [uu___4] in - FStar_Syntax_Subst.close uu___3 t in - { FStar_Syntax_Syntax.b = b; FStar_Syntax_Syntax.phi = uu___2 } in - FStar_Syntax_Syntax.Tm_refine uu___1 in - let uu___1 = - let uu___2 = FStar_Syntax_Syntax.range_of_bv b in - FStar_Compiler_Range_Ops.union_ranges uu___2 - t.FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.mk uu___ uu___1 -let (branch : FStar_Syntax_Syntax.branch -> FStar_Syntax_Syntax.branch) = - fun b -> FStar_Syntax_Subst.close_branch b -let (has_decreases : FStar_Syntax_Syntax.comp -> Prims.bool) = - fun c -> - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Comp ct -> - let uu___ = - FStar_Compiler_Util.find_opt - (fun uu___1 -> - match uu___1 with - | FStar_Syntax_Syntax.DECREASES uu___2 -> true - | uu___2 -> false) ct.FStar_Syntax_Syntax.flags in - (match uu___ with - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.DECREASES - uu___1) -> true - | uu___1 -> false) - | uu___ -> false -let rec (arrow_formals_comp_ln : - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.binder Prims.list * FStar_Syntax_Syntax.comp)) - = - fun k -> - let k1 = FStar_Syntax_Subst.compress k in - match k1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; FStar_Syntax_Syntax.comp = c;_} -> - let uu___ = - (is_total_comp c) && - (let uu___1 = has_decreases c in Prims.op_Negation uu___1) in - if uu___ - then - let uu___1 = arrow_formals_comp_ln (comp_result c) in - (match uu___1 with - | (bs', k2) -> ((FStar_Compiler_List.op_At bs bs'), k2)) - else (bs, c) - | FStar_Syntax_Syntax.Tm_refine - { - FStar_Syntax_Syntax.b = - { FStar_Syntax_Syntax.ppname = uu___; - FStar_Syntax_Syntax.index = uu___1; - FStar_Syntax_Syntax.sort = s;_}; - FStar_Syntax_Syntax.phi = uu___2;_} - -> - let rec aux s1 k2 = - let uu___3 = - let uu___4 = FStar_Syntax_Subst.compress s1 in - uu___4.FStar_Syntax_Syntax.n in - match uu___3 with - | FStar_Syntax_Syntax.Tm_arrow uu___4 -> arrow_formals_comp_ln s1 - | FStar_Syntax_Syntax.Tm_refine - { - FStar_Syntax_Syntax.b = - { FStar_Syntax_Syntax.ppname = uu___4; - FStar_Syntax_Syntax.index = uu___5; - FStar_Syntax_Syntax.sort = s2;_}; - FStar_Syntax_Syntax.phi = uu___6;_} - -> aux s2 k2 - | uu___4 -> - let uu___5 = FStar_Syntax_Syntax.mk_Total k2 in ([], uu___5) in - aux s k1 - | uu___ -> let uu___1 = FStar_Syntax_Syntax.mk_Total k1 in ([], uu___1) -let (arrow_formals_comp : - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.binders * FStar_Syntax_Syntax.comp)) - = - fun k -> - let uu___ = arrow_formals_comp_ln k in - match uu___ with | (bs, c) -> FStar_Syntax_Subst.open_comp bs c -let (arrow_formals_ln : - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.binder Prims.list * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax)) - = - fun k -> - let uu___ = arrow_formals_comp_ln k in - match uu___ with | (bs, c) -> (bs, (comp_result c)) -let (arrow_formals : - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.binders * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax)) - = - fun k -> - let uu___ = arrow_formals_comp k in - match uu___ with | (bs, c) -> (bs, (comp_result c)) -let (let_rec_arity : - FStar_Syntax_Syntax.letbinding -> - (Prims.int * Prims.bool Prims.list FStar_Pervasives_Native.option)) - = - fun lb -> - let rec arrow_until_decreases k = - let k1 = FStar_Syntax_Subst.compress k in - match k1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; FStar_Syntax_Syntax.comp = c;_} -> - let uu___ = FStar_Syntax_Subst.open_comp bs c in - (match uu___ with - | (bs1, c1) -> - let uu___1 = - FStar_Compiler_Util.find_opt - (fun uu___2 -> - match uu___2 with - | FStar_Syntax_Syntax.DECREASES uu___3 -> true - | uu___3 -> false) (comp_flags c1) in - (match uu___1 with - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.DECREASES - d) -> (bs1, (FStar_Pervasives_Native.Some d)) - | uu___2 -> - let uu___3 = is_total_comp c1 in - if uu___3 - then - let uu___4 = arrow_until_decreases (comp_result c1) in - (match uu___4 with - | (bs', d) -> ((FStar_Compiler_List.op_At bs1 bs'), d)) - else (bs1, FStar_Pervasives_Native.None))) - | FStar_Syntax_Syntax.Tm_refine - { - FStar_Syntax_Syntax.b = - { FStar_Syntax_Syntax.ppname = uu___; - FStar_Syntax_Syntax.index = uu___1; - FStar_Syntax_Syntax.sort = k2;_}; - FStar_Syntax_Syntax.phi = uu___2;_} - -> arrow_until_decreases k2 - | uu___ -> ([], FStar_Pervasives_Native.None) in - let uu___ = arrow_until_decreases lb.FStar_Syntax_Syntax.lbtyp in - match uu___ with - | (bs, dopt) -> - let n_univs = - FStar_Compiler_List.length lb.FStar_Syntax_Syntax.lbunivs in - let uu___1 = - FStar_Compiler_Util.map_opt dopt - (fun d -> - let d_bvs = - match d with - | FStar_Syntax_Syntax.Decreases_lex l -> - Obj.magic - (Obj.repr - (let uu___2 = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) ()) in - FStar_Compiler_List.fold_left - (fun uu___4 -> - fun uu___3 -> - (fun s -> - fun t -> - let uu___3 = FStar_Syntax_Free.names t in - Obj.magic - (FStar_Class_Setlike.union () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) - (Obj.magic s) (Obj.magic uu___3))) - uu___4 uu___3) uu___2 l)) - | FStar_Syntax_Syntax.Decreases_wf (rel, e) -> - Obj.magic - (Obj.repr - (let uu___2 = FStar_Syntax_Free.names rel in - let uu___3 = FStar_Syntax_Free.names e in - FStar_Class_Setlike.union () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) - (Obj.magic uu___2) (Obj.magic uu___3))) in - let uu___2 = - FStar_Common.tabulate n_univs (fun uu___3 -> false) in - let uu___3 = - FStar_Compiler_List.map - (fun b -> - FStar_Class_Setlike.mem () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) - b.FStar_Syntax_Syntax.binder_bv (Obj.magic d_bvs)) bs in - FStar_Compiler_List.op_At uu___2 uu___3) in - ((n_univs + (FStar_Compiler_List.length bs)), uu___1) -let (abs_formals_maybe_unascribe_body : - Prims.bool -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.binders * FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option)) - = - fun maybe_unascribe -> - fun t -> - let subst_lcomp_opt s l = - match l with - | FStar_Pervasives_Native.Some rc -> - let uu___ = - let uu___1 = - FStar_Compiler_Util.map_opt - rc.FStar_Syntax_Syntax.residual_typ - (FStar_Syntax_Subst.subst s) in - { - FStar_Syntax_Syntax.residual_effect = - (rc.FStar_Syntax_Syntax.residual_effect); - FStar_Syntax_Syntax.residual_typ = uu___1; - FStar_Syntax_Syntax.residual_flags = - (rc.FStar_Syntax_Syntax.residual_flags) - } in - FStar_Pervasives_Native.Some uu___ - | uu___ -> l in - let rec aux t1 abs_body_lcomp = - let uu___ = - let uu___1 = unmeta_safe t1 in uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs; FStar_Syntax_Syntax.body = t2; - FStar_Syntax_Syntax.rc_opt = what;_} - -> - if maybe_unascribe - then - let uu___1 = aux t2 what in - (match uu___1 with - | (bs', t3, what1) -> - ((FStar_Compiler_List.op_At bs bs'), t3, what1)) - else (bs, t2, what) - | uu___1 -> ([], t1, abs_body_lcomp) in - let uu___ = aux t FStar_Pervasives_Native.None in - match uu___ with - | (bs, t1, abs_body_lcomp) -> - let uu___1 = FStar_Syntax_Subst.open_term' bs t1 in - (match uu___1 with - | (bs1, t2, opening) -> - let abs_body_lcomp1 = subst_lcomp_opt opening abs_body_lcomp in - (bs1, t2, abs_body_lcomp1)) -let (abs_formals : - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.binders * FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option)) - = fun t -> abs_formals_maybe_unascribe_body true t -let (remove_inacc : FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = - fun t -> - let no_acc b = - let aq = - match b.FStar_Syntax_Syntax.binder_qual with - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit (true)) - -> - FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit false) - | aq1 -> aq1 in - { - FStar_Syntax_Syntax.binder_bv = (b.FStar_Syntax_Syntax.binder_bv); - FStar_Syntax_Syntax.binder_qual = aq; - FStar_Syntax_Syntax.binder_positivity = - (b.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs = - (b.FStar_Syntax_Syntax.binder_attrs) - } in - let uu___ = arrow_formals_comp_ln t in - match uu___ with - | (bs, c) -> - (match bs with - | [] -> t - | uu___1 -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_Compiler_List.map no_acc bs in - { - FStar_Syntax_Syntax.bs1 = uu___4; - FStar_Syntax_Syntax.comp = c - } in - FStar_Syntax_Syntax.Tm_arrow uu___3 in - FStar_Syntax_Syntax.mk uu___2 t.FStar_Syntax_Syntax.pos) -let (mk_letbinding : - (FStar_Syntax_Syntax.bv, FStar_Syntax_Syntax.fv) FStar_Pervasives.either -> - FStar_Syntax_Syntax.univ_name Prims.list -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax Prims.list - -> - FStar_Compiler_Range_Type.range -> - FStar_Syntax_Syntax.letbinding) - = - fun lbname -> - fun univ_vars -> - fun typ -> - fun eff -> - fun def -> - fun lbattrs -> - fun pos -> - { - FStar_Syntax_Syntax.lbname = lbname; - FStar_Syntax_Syntax.lbunivs = univ_vars; - FStar_Syntax_Syntax.lbtyp = typ; - FStar_Syntax_Syntax.lbeff = eff; - FStar_Syntax_Syntax.lbdef = def; - FStar_Syntax_Syntax.lbattrs = lbattrs; - FStar_Syntax_Syntax.lbpos = pos - } -let (close_univs_and_mk_letbinding : - FStar_Syntax_Syntax.fv Prims.list FStar_Pervasives_Native.option -> - (FStar_Syntax_Syntax.bv, FStar_Syntax_Syntax.fv) FStar_Pervasives.either - -> - FStar_Syntax_Syntax.univ_name Prims.list -> - FStar_Syntax_Syntax.term -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax Prims.list - -> - FStar_Compiler_Range_Type.range -> - FStar_Syntax_Syntax.letbinding) - = - fun recs -> - fun lbname -> - fun univ_vars -> - fun typ -> - fun eff -> - fun def -> - fun attrs -> - fun pos -> - let def1 = - match (recs, univ_vars) with - | (FStar_Pervasives_Native.None, uu___) -> def - | (uu___, []) -> def - | (FStar_Pervasives_Native.Some fvs, uu___) -> - let universes = - FStar_Compiler_List.map - (fun uu___1 -> FStar_Syntax_Syntax.U_name uu___1) - univ_vars in - let inst = - FStar_Compiler_List.map - (fun fv -> - (((fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v), - universes)) fvs in - FStar_Syntax_InstFV.instantiate inst def in - let typ1 = FStar_Syntax_Subst.close_univ_vars univ_vars typ in - let def2 = - FStar_Syntax_Subst.close_univ_vars univ_vars def1 in - mk_letbinding lbname univ_vars typ1 eff def2 attrs pos -let (open_univ_vars_binders_and_comp : - FStar_Syntax_Syntax.univ_names -> - FStar_Syntax_Syntax.binder Prims.list -> - FStar_Syntax_Syntax.comp -> - (FStar_Syntax_Syntax.univ_names * FStar_Syntax_Syntax.binder - Prims.list * FStar_Syntax_Syntax.comp)) - = - fun uvs -> - fun binders -> - fun c -> - match binders with - | [] -> - let uu___ = FStar_Syntax_Subst.open_univ_vars_comp uvs c in - (match uu___ with | (uvs1, c1) -> (uvs1, [], c1)) - | uu___ -> - let t' = arrow binders c in - let uu___1 = FStar_Syntax_Subst.open_univ_vars uvs t' in - (match uu___1 with - | (uvs1, t'1) -> - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress t'1 in - uu___3.FStar_Syntax_Syntax.n in - (match uu___2 with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = binders1; - FStar_Syntax_Syntax.comp = c1;_} - -> (uvs1, binders1, c1) - | uu___3 -> failwith "Impossible")) -let (is_tuple_constructor : FStar_Syntax_Syntax.typ -> Prims.bool) = - fun t -> - match t.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_fvar fv -> - let uu___ = - FStar_Ident.string_of_lid - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - FStar_Parser_Const.is_tuple_constructor_string uu___ - | uu___ -> false -let (is_dtuple_constructor : FStar_Syntax_Syntax.typ -> Prims.bool) = - fun t -> - match t.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_fvar fv -> - FStar_Parser_Const.is_dtuple_constructor_lid - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - | uu___ -> false -let (is_lid_equality : FStar_Ident.lident -> Prims.bool) = - fun x -> FStar_Ident.lid_equals x FStar_Parser_Const.eq2_lid -let (is_forall : FStar_Ident.lident -> Prims.bool) = - fun lid -> FStar_Ident.lid_equals lid FStar_Parser_Const.forall_lid -let (is_exists : FStar_Ident.lident -> Prims.bool) = - fun lid -> FStar_Ident.lid_equals lid FStar_Parser_Const.exists_lid -let (is_qlid : FStar_Ident.lident -> Prims.bool) = - fun lid -> (is_forall lid) || (is_exists lid) -let (is_equality : - FStar_Ident.lident FStar_Syntax_Syntax.withinfo_t -> Prims.bool) = - fun x -> is_lid_equality x.FStar_Syntax_Syntax.v -let (lid_is_connective : FStar_Ident.lident -> Prims.bool) = - let lst = - [FStar_Parser_Const.and_lid; - FStar_Parser_Const.or_lid; - FStar_Parser_Const.not_lid; - FStar_Parser_Const.iff_lid; - FStar_Parser_Const.imp_lid] in - fun lid -> FStar_Compiler_Util.for_some (FStar_Ident.lid_equals lid) lst -let (is_constructor : - FStar_Syntax_Syntax.term -> FStar_Ident.lident -> Prims.bool) = - fun t -> - fun lid -> - let uu___ = let uu___1 = pre_typ t in uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_fvar tc -> - FStar_Ident.lid_equals - (tc.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v lid - | uu___1 -> false -let rec (is_constructed_typ : - FStar_Syntax_Syntax.term -> FStar_Ident.lident -> Prims.bool) = - fun t -> - fun lid -> - let uu___ = let uu___1 = pre_typ t in uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_fvar uu___1 -> is_constructor t lid - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = t1; FStar_Syntax_Syntax.args = uu___1;_} - -> is_constructed_typ t1 lid - | FStar_Syntax_Syntax.Tm_uinst (t1, uu___1) -> - is_constructed_typ t1 lid - | uu___1 -> false -let rec (get_tycon : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = - fun t -> - let t1 = pre_typ t in - match t1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_bvar uu___ -> FStar_Pervasives_Native.Some t1 - | FStar_Syntax_Syntax.Tm_name uu___ -> FStar_Pervasives_Native.Some t1 - | FStar_Syntax_Syntax.Tm_fvar uu___ -> FStar_Pervasives_Native.Some t1 - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = t2; FStar_Syntax_Syntax.args = uu___;_} -> - get_tycon t2 - | uu___ -> FStar_Pervasives_Native.None -let (is_fstar_tactics_by_tactic : FStar_Syntax_Syntax.term -> Prims.bool) = - fun t -> - let uu___ = let uu___1 = un_uinst t in uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_fvar fv -> - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.by_tactic_lid - | uu___1 -> false -let (ktype : FStar_Syntax_Syntax.term) = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_type FStar_Syntax_Syntax.U_unknown) - FStar_Compiler_Range_Type.dummyRange -let (ktype0 : FStar_Syntax_Syntax.term) = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_type FStar_Syntax_Syntax.U_zero) - FStar_Compiler_Range_Type.dummyRange -let (type_u : - unit -> (FStar_Syntax_Syntax.typ * FStar_Syntax_Syntax.universe)) = - fun uu___ -> - let u = - let uu___1 = - FStar_Syntax_Unionfind.univ_fresh - FStar_Compiler_Range_Type.dummyRange in - FStar_Syntax_Syntax.U_unif uu___1 in - let uu___1 = - FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_type u) - FStar_Compiler_Range_Type.dummyRange in - (uu___1, u) -let (type_with_u : FStar_Syntax_Syntax.universe -> FStar_Syntax_Syntax.typ) = - fun u -> - FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_type u) - FStar_Compiler_Range_Type.dummyRange -let (attr_substitute : FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - let uu___ = - let uu___1 = - FStar_Syntax_Syntax.lid_as_fv FStar_Parser_Const.attr_substitute_lid - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.Tm_fvar uu___1 in - FStar_Syntax_Syntax.mk uu___ FStar_Compiler_Range_Type.dummyRange -let (exp_bool : Prims.bool -> FStar_Syntax_Syntax.term) = - fun b -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_bool b)) - FStar_Compiler_Range_Type.dummyRange -let (exp_true_bool : FStar_Syntax_Syntax.term) = exp_bool true -let (exp_false_bool : FStar_Syntax_Syntax.term) = exp_bool false -let (exp_unit : FStar_Syntax_Syntax.term) = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_constant FStar_Const.Const_unit) - FStar_Compiler_Range_Type.dummyRange -let (exp_int : Prims.string -> FStar_Syntax_Syntax.term) = - fun s -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_int (s, FStar_Pervasives_Native.None))) - FStar_Compiler_Range_Type.dummyRange -let (exp_char : FStar_BaseTypes.char -> FStar_Syntax_Syntax.term) = - fun c -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_char c)) - FStar_Compiler_Range_Type.dummyRange -let (exp_string : Prims.string -> FStar_Syntax_Syntax.term) = - fun s -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_string (s, FStar_Compiler_Range_Type.dummyRange))) - FStar_Compiler_Range_Type.dummyRange -let (fvar_const : FStar_Ident.lident -> FStar_Syntax_Syntax.term) = - fun l -> FStar_Syntax_Syntax.fvar_with_dd l FStar_Pervasives_Native.None -let (tand : FStar_Syntax_Syntax.term) = fvar_const FStar_Parser_Const.and_lid -let (tor : FStar_Syntax_Syntax.term) = fvar_const FStar_Parser_Const.or_lid -let (timp : FStar_Syntax_Syntax.term) = - FStar_Syntax_Syntax.fvar_with_dd FStar_Parser_Const.imp_lid - FStar_Pervasives_Native.None -let (tiff : FStar_Syntax_Syntax.term) = - FStar_Syntax_Syntax.fvar_with_dd FStar_Parser_Const.iff_lid - FStar_Pervasives_Native.None -let (t_bool : FStar_Syntax_Syntax.term) = - fvar_const FStar_Parser_Const.bool_lid -let (b2t_v : FStar_Syntax_Syntax.term) = - fvar_const FStar_Parser_Const.b2t_lid -let (t_not : FStar_Syntax_Syntax.term) = - fvar_const FStar_Parser_Const.not_lid -let (t_false : FStar_Syntax_Syntax.term) = - fvar_const FStar_Parser_Const.false_lid -let (t_true : FStar_Syntax_Syntax.term) = - fvar_const FStar_Parser_Const.true_lid -let (tac_opaque_attr : FStar_Syntax_Syntax.term) = exp_string "tac_opaque" -let (dm4f_bind_range_attr : FStar_Syntax_Syntax.term) = - fvar_const FStar_Parser_Const.dm4f_bind_range_attr -let (tcdecltime_attr : FStar_Syntax_Syntax.term) = - fvar_const FStar_Parser_Const.tcdecltime_attr -let (inline_let_attr : FStar_Syntax_Syntax.term) = - fvar_const FStar_Parser_Const.inline_let_attr -let (rename_let_attr : FStar_Syntax_Syntax.term) = - fvar_const FStar_Parser_Const.rename_let_attr -let (t_ctx_uvar_and_sust : FStar_Syntax_Syntax.term) = - fvar_const FStar_Parser_Const.ctx_uvar_and_subst_lid -let (t_universe_uvar : FStar_Syntax_Syntax.term) = - fvar_const FStar_Parser_Const.universe_uvar_lid -let (t_dsl_tac_typ : FStar_Syntax_Syntax.term) = - FStar_Syntax_Syntax.fvar FStar_Parser_Const.dsl_tac_typ_lid - FStar_Pervasives_Native.None -let (mk_conj_opt : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - FStar_Pervasives_Native.option) - = - fun phi1 -> - fun phi2 -> - match phi1 with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.Some phi2 - | FStar_Pervasives_Native.Some phi11 -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Syntax.as_arg phi11 in - let uu___5 = - let uu___6 = FStar_Syntax_Syntax.as_arg phi2 in [uu___6] in - uu___4 :: uu___5 in - { - FStar_Syntax_Syntax.hd = tand; - FStar_Syntax_Syntax.args = uu___3 - } in - FStar_Syntax_Syntax.Tm_app uu___2 in - let uu___2 = - FStar_Compiler_Range_Ops.union_ranges - phi11.FStar_Syntax_Syntax.pos phi2.FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.mk uu___1 uu___2 in - FStar_Pervasives_Native.Some uu___ -let (mk_binop : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun op_t -> - fun phi1 -> - fun phi2 -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.as_arg phi1 in - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.as_arg phi2 in [uu___5] in - uu___3 :: uu___4 in - { - FStar_Syntax_Syntax.hd = op_t; - FStar_Syntax_Syntax.args = uu___2 - } in - FStar_Syntax_Syntax.Tm_app uu___1 in - let uu___1 = - FStar_Compiler_Range_Ops.union_ranges phi1.FStar_Syntax_Syntax.pos - phi2.FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.mk uu___ uu___1 -let (mk_neg : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun phi -> - let uu___ = - let uu___1 = - let uu___2 = let uu___3 = FStar_Syntax_Syntax.as_arg phi in [uu___3] in - { FStar_Syntax_Syntax.hd = t_not; FStar_Syntax_Syntax.args = uu___2 } in - FStar_Syntax_Syntax.Tm_app uu___1 in - FStar_Syntax_Syntax.mk uu___ phi.FStar_Syntax_Syntax.pos -let (mk_conj : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = fun phi1 -> fun phi2 -> mk_binop tand phi1 phi2 -let (mk_conj_l : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax Prims.list -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun phi -> - match phi with - | [] -> - FStar_Syntax_Syntax.fvar_with_dd FStar_Parser_Const.true_lid - FStar_Pervasives_Native.None - | hd::tl -> FStar_Compiler_List.fold_right mk_conj tl hd -let (mk_disj : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = fun phi1 -> fun phi2 -> mk_binop tor phi1 phi2 -let (mk_disj_l : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax Prims.list -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun phi -> - match phi with - | [] -> t_false - | hd::tl -> FStar_Compiler_List.fold_right mk_disj tl hd -let (mk_imp : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term) - = fun phi1 -> fun phi2 -> mk_binop timp phi1 phi2 -let (mk_iff : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term) - = fun phi1 -> fun phi2 -> mk_binop tiff phi1 phi2 -let (b2t : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun e -> - let uu___ = - let uu___1 = - let uu___2 = let uu___3 = FStar_Syntax_Syntax.as_arg e in [uu___3] in - { FStar_Syntax_Syntax.hd = b2t_v; FStar_Syntax_Syntax.args = uu___2 } in - FStar_Syntax_Syntax.Tm_app uu___1 in - FStar_Syntax_Syntax.mk uu___ e.FStar_Syntax_Syntax.pos -let (unb2t : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = - fun e -> - let uu___ = head_and_args e in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress hd in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, (e1, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.b2t_lid -> - FStar_Pervasives_Native.Some e1 - | uu___2 -> FStar_Pervasives_Native.None) -let (is_t_true : FStar_Syntax_Syntax.term -> Prims.bool) = - fun t -> - let uu___ = let uu___1 = unmeta t in uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_fvar fv -> - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.true_lid - | uu___1 -> false -let (mk_conj_simp : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun t1 -> - fun t2 -> - let uu___ = is_t_true t1 in - if uu___ - then t2 - else - (let uu___2 = is_t_true t2 in if uu___2 then t1 else mk_conj t1 t2) -let (mk_disj_simp : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun t1 -> - fun t2 -> - let uu___ = is_t_true t1 in - if uu___ - then t_true - else - (let uu___2 = is_t_true t2 in - if uu___2 then t_true else mk_disj t1 t2) -let (teq : FStar_Syntax_Syntax.term) = fvar_const FStar_Parser_Const.eq2_lid -let (mk_untyped_eq2 : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun e1 -> - fun e2 -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.as_arg e1 in - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.as_arg e2 in [uu___5] in - uu___3 :: uu___4 in - { FStar_Syntax_Syntax.hd = teq; FStar_Syntax_Syntax.args = uu___2 } in - FStar_Syntax_Syntax.Tm_app uu___1 in - let uu___1 = - FStar_Compiler_Range_Ops.union_ranges e1.FStar_Syntax_Syntax.pos - e2.FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.mk uu___ uu___1 -let (mk_eq2 : - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun u -> - fun t -> - fun e1 -> - fun e2 -> - let eq_inst = FStar_Syntax_Syntax.mk_Tm_uinst teq [u] in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.iarg t in - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.as_arg e1 in - let uu___6 = - let uu___7 = FStar_Syntax_Syntax.as_arg e2 in [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - { - FStar_Syntax_Syntax.hd = eq_inst; - FStar_Syntax_Syntax.args = uu___2 - } in - FStar_Syntax_Syntax.Tm_app uu___1 in - let uu___1 = - FStar_Compiler_Range_Ops.union_ranges e1.FStar_Syntax_Syntax.pos - e2.FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.mk uu___ uu___1 -let (mk_eq3_no_univ : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - let teq3 = fvar_const FStar_Parser_Const.eq3_lid in - fun t1 -> - fun t2 -> - fun e1 -> - fun e2 -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.iarg t1 in - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.iarg t2 in - let uu___6 = - let uu___7 = FStar_Syntax_Syntax.as_arg e1 in - let uu___8 = - let uu___9 = FStar_Syntax_Syntax.as_arg e2 in [uu___9] in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - { - FStar_Syntax_Syntax.hd = teq3; - FStar_Syntax_Syntax.args = uu___2 - } in - FStar_Syntax_Syntax.Tm_app uu___1 in - let uu___1 = - FStar_Compiler_Range_Ops.union_ranges e1.FStar_Syntax_Syntax.pos - e2.FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.mk uu___ uu___1 -let (mk_has_type : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun t -> - fun x -> - fun t' -> - let t_has_type = fvar_const FStar_Parser_Const.has_type_lid in - let t_has_type1 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_uinst - (t_has_type, - [FStar_Syntax_Syntax.U_zero; FStar_Syntax_Syntax.U_zero])) - FStar_Compiler_Range_Type.dummyRange in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.iarg t in - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.as_arg x in - let uu___6 = - let uu___7 = FStar_Syntax_Syntax.as_arg t' in [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - { - FStar_Syntax_Syntax.hd = t_has_type1; - FStar_Syntax_Syntax.args = uu___2 - } in - FStar_Syntax_Syntax.Tm_app uu___1 in - FStar_Syntax_Syntax.mk uu___ FStar_Compiler_Range_Type.dummyRange -let (tforall : FStar_Syntax_Syntax.term) = - FStar_Syntax_Syntax.fvar_with_dd FStar_Parser_Const.forall_lid - FStar_Pervasives_Native.None -let (texists : FStar_Syntax_Syntax.term) = - FStar_Syntax_Syntax.fvar_with_dd FStar_Parser_Const.exists_lid - FStar_Pervasives_Native.None -let (t_haseq : FStar_Syntax_Syntax.term) = - FStar_Syntax_Syntax.fvar_with_dd FStar_Parser_Const.haseq_lid - FStar_Pervasives_Native.None -let (decidable_eq : FStar_Syntax_Syntax.term) = - fvar_const FStar_Parser_Const.op_Eq -let (mk_decidable_eq : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun t -> - fun e1 -> - fun e2 -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.iarg t in - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.as_arg e1 in - let uu___6 = - let uu___7 = FStar_Syntax_Syntax.as_arg e2 in [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - { - FStar_Syntax_Syntax.hd = decidable_eq; - FStar_Syntax_Syntax.args = uu___2 - } in - FStar_Syntax_Syntax.Tm_app uu___1 in - let uu___1 = - FStar_Compiler_Range_Ops.union_ranges e1.FStar_Syntax_Syntax.pos - e2.FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.mk uu___ uu___1 -let (b_and : FStar_Syntax_Syntax.term) = fvar_const FStar_Parser_Const.op_And -let (mk_and : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun e1 -> - fun e2 -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.as_arg e1 in - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.as_arg e2 in [uu___5] in - uu___3 :: uu___4 in - { FStar_Syntax_Syntax.hd = b_and; FStar_Syntax_Syntax.args = uu___2 - } in - FStar_Syntax_Syntax.Tm_app uu___1 in - let uu___1 = - FStar_Compiler_Range_Ops.union_ranges e1.FStar_Syntax_Syntax.pos - e2.FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.mk uu___ uu___1 -let (mk_and_l : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax Prims.list -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun l -> - match l with - | [] -> exp_true_bool - | hd::tl -> FStar_Compiler_List.fold_left mk_and hd tl -let (mk_boolean_negation : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun b -> - let uu___ = - let uu___1 = - let uu___2 = fvar_const FStar_Parser_Const.op_Negation in - let uu___3 = let uu___4 = FStar_Syntax_Syntax.as_arg b in [uu___4] in - { FStar_Syntax_Syntax.hd = uu___2; FStar_Syntax_Syntax.args = uu___3 - } in - FStar_Syntax_Syntax.Tm_app uu___1 in - FStar_Syntax_Syntax.mk uu___ b.FStar_Syntax_Syntax.pos -let (mk_residual_comp : - FStar_Ident.lident -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.cflag Prims.list -> - FStar_Syntax_Syntax.residual_comp) - = - fun l -> - fun t -> - fun f -> - { - FStar_Syntax_Syntax.residual_effect = l; - FStar_Syntax_Syntax.residual_typ = t; - FStar_Syntax_Syntax.residual_flags = f - } -let (residual_tot : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.residual_comp) - = - fun t -> - { - FStar_Syntax_Syntax.residual_effect = FStar_Parser_Const.effect_Tot_lid; - FStar_Syntax_Syntax.residual_typ = (FStar_Pervasives_Native.Some t); - FStar_Syntax_Syntax.residual_flags = [FStar_Syntax_Syntax.TOTAL] - } -let (residual_gtot : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.residual_comp) - = - fun t -> - { - FStar_Syntax_Syntax.residual_effect = - FStar_Parser_Const.effect_GTot_lid; - FStar_Syntax_Syntax.residual_typ = (FStar_Pervasives_Native.Some t); - FStar_Syntax_Syntax.residual_flags = [FStar_Syntax_Syntax.TOTAL] - } -let (residual_comp_of_comp : - FStar_Syntax_Syntax.comp -> FStar_Syntax_Syntax.residual_comp) = - fun c -> - let uu___ = - FStar_Compiler_List.filter - (fun uu___1 -> - match uu___1 with - | FStar_Syntax_Syntax.DECREASES uu___2 -> false - | uu___2 -> true) (comp_flags c) in - { - FStar_Syntax_Syntax.residual_effect = (comp_effect_name c); - FStar_Syntax_Syntax.residual_typ = - (FStar_Pervasives_Native.Some (comp_result c)); - FStar_Syntax_Syntax.residual_flags = uu___ - } -let (mk_forall_aux : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.bv -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun fa -> - fun x -> - fun body -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Syntax_Syntax.iarg x.FStar_Syntax_Syntax.sort in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = FStar_Syntax_Syntax.mk_binder x in - [uu___8] in - abs uu___7 body - (FStar_Pervasives_Native.Some (residual_tot ktype0)) in - FStar_Syntax_Syntax.as_arg uu___6 in - [uu___5] in - uu___3 :: uu___4 in - { FStar_Syntax_Syntax.hd = fa; FStar_Syntax_Syntax.args = uu___2 - } in - FStar_Syntax_Syntax.Tm_app uu___1 in - FStar_Syntax_Syntax.mk uu___ FStar_Compiler_Range_Type.dummyRange -let (mk_forall_no_univ : - FStar_Syntax_Syntax.bv -> - FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.typ) - = fun x -> fun body -> mk_forall_aux tforall x body -let (mk_forall : - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.bv -> - FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.typ) - = - fun u -> - fun x -> - fun body -> - let tforall1 = FStar_Syntax_Syntax.mk_Tm_uinst tforall [u] in - mk_forall_aux tforall1 x body -let (close_forall_no_univs : - FStar_Syntax_Syntax.binder Prims.list -> - FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.typ) - = - fun bs -> - fun f -> - FStar_Compiler_List.fold_right - (fun b -> - fun f1 -> - let uu___ = FStar_Syntax_Syntax.is_null_binder b in - if uu___ - then f1 - else mk_forall_no_univ b.FStar_Syntax_Syntax.binder_bv f1) bs f -let (mk_exists_aux : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.bv -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun fa -> - fun x -> - fun body -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Syntax_Syntax.iarg x.FStar_Syntax_Syntax.sort in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = FStar_Syntax_Syntax.mk_binder x in - [uu___8] in - abs uu___7 body - (FStar_Pervasives_Native.Some (residual_tot ktype0)) in - FStar_Syntax_Syntax.as_arg uu___6 in - [uu___5] in - uu___3 :: uu___4 in - { FStar_Syntax_Syntax.hd = fa; FStar_Syntax_Syntax.args = uu___2 - } in - FStar_Syntax_Syntax.Tm_app uu___1 in - FStar_Syntax_Syntax.mk uu___ FStar_Compiler_Range_Type.dummyRange -let (mk_exists_no_univ : - FStar_Syntax_Syntax.bv -> - FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.typ) - = fun x -> fun body -> mk_exists_aux texists x body -let (mk_exists : - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.bv -> - FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.typ) - = - fun u -> - fun x -> - fun body -> - let texists1 = FStar_Syntax_Syntax.mk_Tm_uinst texists [u] in - mk_exists_aux texists1 x body -let (close_exists_no_univs : - FStar_Syntax_Syntax.binder Prims.list -> - FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.typ) - = - fun bs -> - fun f -> - FStar_Compiler_List.fold_right - (fun b -> - fun f1 -> - let uu___ = FStar_Syntax_Syntax.is_null_binder b in - if uu___ - then f1 - else mk_exists_no_univ b.FStar_Syntax_Syntax.binder_bv f1) bs f -let (if_then_else : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun b -> - fun t1 -> - fun t2 -> - let then_branch = - let uu___ = - FStar_Syntax_Syntax.withinfo - (FStar_Syntax_Syntax.Pat_constant (FStar_Const.Const_bool true)) - t1.FStar_Syntax_Syntax.pos in - (uu___, FStar_Pervasives_Native.None, t1) in - let else_branch = - let uu___ = - FStar_Syntax_Syntax.withinfo - (FStar_Syntax_Syntax.Pat_constant - (FStar_Const.Const_bool false)) t2.FStar_Syntax_Syntax.pos in - (uu___, FStar_Pervasives_Native.None, t2) in - let uu___ = - let uu___1 = - FStar_Compiler_Range_Ops.union_ranges t1.FStar_Syntax_Syntax.pos - t2.FStar_Syntax_Syntax.pos in - FStar_Compiler_Range_Ops.union_ranges b.FStar_Syntax_Syntax.pos - uu___1 in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_match - { - FStar_Syntax_Syntax.scrutinee = b; - FStar_Syntax_Syntax.ret_opt = FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.brs = [then_branch; else_branch]; - FStar_Syntax_Syntax.rc_opt1 = FStar_Pervasives_Native.None - }) uu___ -let (mk_squash : - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun u -> - fun p -> - let sq = - FStar_Syntax_Syntax.fvar_with_dd FStar_Parser_Const.squash_lid - FStar_Pervasives_Native.None in - let uu___ = FStar_Syntax_Syntax.mk_Tm_uinst sq [u] in - let uu___1 = let uu___2 = FStar_Syntax_Syntax.as_arg p in [uu___2] in - mk_app uu___ uu___1 -let (mk_auto_squash : - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun u -> - fun p -> - let sq = - FStar_Syntax_Syntax.fvar_with_dd FStar_Parser_Const.auto_squash_lid - FStar_Pervasives_Native.None in - let uu___ = FStar_Syntax_Syntax.mk_Tm_uinst sq [u] in - let uu___1 = let uu___2 = FStar_Syntax_Syntax.as_arg p in [uu___2] in - mk_app uu___ uu___1 -let (un_squash : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - FStar_Pervasives_Native.option) - = - fun t -> - let uu___ = head_and_args t in - match uu___ with - | (head, args) -> - let head1 = unascribe head in - let head2 = un_uinst head1 in - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress head2 in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, (p, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.squash_lid - -> FStar_Pervasives_Native.Some p - | (FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = b; FStar_Syntax_Syntax.phi = p;_}, []) - -> - (match (b.FStar_Syntax_Syntax.sort).FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.unit_lid - -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Syntax.mk_binder b in - [uu___4] in - FStar_Syntax_Subst.open_term uu___3 p in - (match uu___2 with - | (bs, p1) -> - let b1 = - match bs with - | b2::[] -> b2 - | uu___3 -> failwith "impossible" in - let uu___3 = - let uu___4 = FStar_Syntax_Free.names p1 in - FStar_Class_Setlike.mem () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) - b1.FStar_Syntax_Syntax.binder_bv - (Obj.magic uu___4) in - if uu___3 - then FStar_Pervasives_Native.None - else FStar_Pervasives_Native.Some p1) - | uu___2 -> FStar_Pervasives_Native.None) - | uu___2 -> FStar_Pervasives_Native.None) -let (is_squash : - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.universe * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax) FStar_Pervasives_Native.option) - = - fun t -> - let uu___ = head_and_args t in - match uu___ with - | (head, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress head in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_uinst - ({ FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___2; - FStar_Syntax_Syntax.vars = uu___3; - FStar_Syntax_Syntax.hash_code = uu___4;_}, - u::[]), - (t1, uu___5)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.squash_lid - -> FStar_Pervasives_Native.Some (u, t1) - | uu___2 -> FStar_Pervasives_Native.None) -let (is_auto_squash : - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.universe * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax) FStar_Pervasives_Native.option) - = - fun t -> - let uu___ = head_and_args t in - match uu___ with - | (head, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress head in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_uinst - ({ FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___2; - FStar_Syntax_Syntax.vars = uu___3; - FStar_Syntax_Syntax.hash_code = uu___4;_}, - u::[]), - (t1, uu___5)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.auto_squash_lid - -> FStar_Pervasives_Native.Some (u, t1) - | uu___2 -> FStar_Pervasives_Native.None) -let (is_sub_singleton : FStar_Syntax_Syntax.term -> Prims.bool) = - fun t -> - let uu___ = let uu___1 = unmeta t in head_and_args uu___1 in - match uu___ with - | (head, uu___1) -> - let uu___2 = - let uu___3 = un_uinst head in uu___3.FStar_Syntax_Syntax.n in - (match uu___2 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - (((((((((((((((((FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.unit_lid) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.squash_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.auto_squash_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.and_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.or_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.not_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.imp_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.iff_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.ite_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.exists_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.forall_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.true_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.false_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.eq2_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.b2t_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.haseq_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.has_type_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.precedes_lid) - | uu___3 -> false) -let (arrow_one_ln : - FStar_Syntax_Syntax.typ -> - (FStar_Syntax_Syntax.binder * FStar_Syntax_Syntax.comp) - FStar_Pervasives_Native.option) - = - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = []; FStar_Syntax_Syntax.comp = uu___1;_} - -> failwith "fatal: empty binders on arrow?" - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = b::[]; FStar_Syntax_Syntax.comp = c;_} -> - FStar_Pervasives_Native.Some (b, c) - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = b::bs; FStar_Syntax_Syntax.comp = c;_} -> - let rng' = - FStar_Compiler_List.fold_left - (fun a -> - fun b1 -> - FStar_Compiler_Range_Ops.union_ranges a - ((b1.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort).FStar_Syntax_Syntax.pos) - c.FStar_Syntax_Syntax.pos bs in - let c' = - let uu___1 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; FStar_Syntax_Syntax.comp = c - }) rng' in - FStar_Syntax_Syntax.mk_Total uu___1 in - FStar_Pervasives_Native.Some (b, c') - | uu___1 -> FStar_Pervasives_Native.None -let (arrow_one : - FStar_Syntax_Syntax.typ -> - (FStar_Syntax_Syntax.binder * FStar_Syntax_Syntax.comp) - FStar_Pervasives_Native.option) - = - fun t -> - let uu___ = arrow_one_ln t in - FStar_Compiler_Util.bind_opt uu___ - (fun uu___1 -> - match uu___1 with - | (b, c) -> - let uu___2 = FStar_Syntax_Subst.open_comp [b] c in - (match uu___2 with - | (bs, c1) -> - let b1 = - match bs with - | b2::[] -> b2 - | uu___3 -> - failwith - "impossible: open_comp returned different amount of binders" in - FStar_Pervasives_Native.Some (b1, c1))) -let (abs_one_ln : - FStar_Syntax_Syntax.typ -> - (FStar_Syntax_Syntax.binder * FStar_Syntax_Syntax.term) - FStar_Pervasives_Native.option) - = - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = []; FStar_Syntax_Syntax.body = uu___1; - FStar_Syntax_Syntax.rc_opt = uu___2;_} - -> failwith "fatal: empty binders on abs?" - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = b::[]; FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = uu___1;_} - -> FStar_Pervasives_Native.Some (b, body) - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = b::bs; FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = rc_opt;_} - -> - let uu___1 = let uu___2 = abs bs body rc_opt in (b, uu___2) in - FStar_Pervasives_Native.Some uu___1 - | uu___1 -> FStar_Pervasives_Native.None -let (is_free_in : - FStar_Syntax_Syntax.bv -> FStar_Syntax_Syntax.term -> Prims.bool) = - fun bv -> - fun t -> - let uu___ = FStar_Syntax_Free.names t in - FStar_Class_Setlike.mem () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) bv (Obj.magic uu___) -let (action_as_lb : - FStar_Ident.lident -> - FStar_Syntax_Syntax.action -> - FStar_Compiler_Range_Type.range -> FStar_Syntax_Syntax.sigelt) - = - fun eff_lid -> - fun a -> - fun pos -> - let lb = - let uu___ = - let uu___1 = - FStar_Syntax_Syntax.lid_and_dd_as_fv - a.FStar_Syntax_Syntax.action_name - FStar_Pervasives_Native.None in - FStar_Pervasives.Inr uu___1 in - let uu___1 = - let uu___2 = - FStar_Syntax_Syntax.mk_Total a.FStar_Syntax_Syntax.action_typ in - arrow a.FStar_Syntax_Syntax.action_params uu___2 in - let uu___2 = - abs a.FStar_Syntax_Syntax.action_params - a.FStar_Syntax_Syntax.action_defn FStar_Pervasives_Native.None in - close_univs_and_mk_letbinding FStar_Pervasives_Native.None uu___ - a.FStar_Syntax_Syntax.action_univs uu___1 - FStar_Parser_Const.effect_Tot_lid uu___2 [] pos in - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_let - { - FStar_Syntax_Syntax.lbs1 = (false, [lb]); - FStar_Syntax_Syntax.lids1 = - [a.FStar_Syntax_Syntax.action_name] - }); - FStar_Syntax_Syntax.sigrng = - ((a.FStar_Syntax_Syntax.action_defn).FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.sigquals = - [FStar_Syntax_Syntax.Visible_default; - FStar_Syntax_Syntax.Action eff_lid]; - FStar_Syntax_Syntax.sigmeta = FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs = []; - FStar_Syntax_Syntax.sigopens_and_abbrevs = []; - FStar_Syntax_Syntax.sigopts = FStar_Pervasives_Native.None - } -let (mk_reify : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Ident.lident FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun t -> - fun lopt -> - let reify_ = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_reify lopt)) - t.FStar_Syntax_Syntax.pos in - let uu___ = - let uu___1 = - let uu___2 = let uu___3 = FStar_Syntax_Syntax.as_arg t in [uu___3] in - { - FStar_Syntax_Syntax.hd = reify_; - FStar_Syntax_Syntax.args = uu___2 - } in - FStar_Syntax_Syntax.Tm_app uu___1 in - FStar_Syntax_Syntax.mk uu___ t.FStar_Syntax_Syntax.pos -let (mk_reflect : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun t -> - let reflect_ = - let uu___ = - let uu___1 = - let uu___2 = FStar_Ident.lid_of_str "Bogus.Effect" in - FStar_Const.Const_reflect uu___2 in - FStar_Syntax_Syntax.Tm_constant uu___1 in - FStar_Syntax_Syntax.mk uu___ t.FStar_Syntax_Syntax.pos in - let uu___ = - let uu___1 = - let uu___2 = let uu___3 = FStar_Syntax_Syntax.as_arg t in [uu___3] in - { - FStar_Syntax_Syntax.hd = reflect_; - FStar_Syntax_Syntax.args = uu___2 - } in - FStar_Syntax_Syntax.Tm_app uu___1 in - FStar_Syntax_Syntax.mk uu___ t.FStar_Syntax_Syntax.pos -let rec (incr_delta_depth : - FStar_Syntax_Syntax.delta_depth -> FStar_Syntax_Syntax.delta_depth) = - fun d -> - match d with - | FStar_Syntax_Syntax.Delta_constant_at_level i -> - FStar_Syntax_Syntax.Delta_constant_at_level (i + Prims.int_one) - | FStar_Syntax_Syntax.Delta_equational_at_level i -> - FStar_Syntax_Syntax.Delta_equational_at_level (i + Prims.int_one) - | FStar_Syntax_Syntax.Delta_abstract d1 -> incr_delta_depth d1 -let (is_unknown : FStar_Syntax_Syntax.term -> Prims.bool) = - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_unknown -> true - | uu___1 -> false -let rec apply_last : - 'uuuuu . ('uuuuu -> 'uuuuu) -> 'uuuuu Prims.list -> 'uuuuu Prims.list = - fun f -> - fun l -> - match l with - | [] -> failwith "apply_last: got empty list" - | a::[] -> let uu___ = f a in [uu___] - | x::xs -> let uu___ = apply_last f xs in x :: uu___ -let (dm4f_lid : - FStar_Syntax_Syntax.eff_decl -> Prims.string -> FStar_Ident.lident) = - fun ed -> - fun name -> - let p = FStar_Ident.path_of_lid ed.FStar_Syntax_Syntax.mname in - let p' = - apply_last - (fun s -> - Prims.strcat "_dm4f_" (Prims.strcat s (Prims.strcat "_" name))) - p in - FStar_Ident.lid_of_path p' FStar_Compiler_Range_Type.dummyRange -let (mk_list : - FStar_Syntax_Syntax.term -> - FStar_Compiler_Range_Type.range -> - FStar_Syntax_Syntax.term Prims.list -> FStar_Syntax_Syntax.term) - = - fun typ -> - fun rng -> - fun l -> - let ctor l1 = - let uu___ = - let uu___1 = - FStar_Syntax_Syntax.lid_as_fv l1 - (FStar_Pervasives_Native.Some FStar_Syntax_Syntax.Data_ctor) in - FStar_Syntax_Syntax.Tm_fvar uu___1 in - FStar_Syntax_Syntax.mk uu___ rng in - let cons args pos = - let uu___ = - let uu___1 = ctor FStar_Parser_Const.cons_lid in - FStar_Syntax_Syntax.mk_Tm_uinst uu___1 - [FStar_Syntax_Syntax.U_zero] in - FStar_Syntax_Syntax.mk_Tm_app uu___ args pos in - let nil args pos = - let uu___ = - let uu___1 = ctor FStar_Parser_Const.nil_lid in - FStar_Syntax_Syntax.mk_Tm_uinst uu___1 - [FStar_Syntax_Syntax.U_zero] in - FStar_Syntax_Syntax.mk_Tm_app uu___ args pos in - let uu___ = - let uu___1 = let uu___2 = FStar_Syntax_Syntax.iarg typ in [uu___2] in - nil uu___1 rng in - FStar_Compiler_List.fold_right - (fun t -> - fun a -> - let uu___1 = - let uu___2 = FStar_Syntax_Syntax.iarg typ in - let uu___3 = - let uu___4 = FStar_Syntax_Syntax.as_arg t in - let uu___5 = - let uu___6 = FStar_Syntax_Syntax.as_arg a in [uu___6] in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - cons uu___1 t.FStar_Syntax_Syntax.pos) l uu___ -let rec eqlist : - 'a . - ('a -> 'a -> Prims.bool) -> 'a Prims.list -> 'a Prims.list -> Prims.bool - = - fun eq -> - fun xs -> - fun ys -> - match (xs, ys) with - | ([], []) -> true - | (x::xs1, y::ys1) -> (eq x y) && (eqlist eq xs1 ys1) - | uu___ -> false -let eqsum : - 'a 'b . - ('a -> 'a -> Prims.bool) -> - ('b -> 'b -> Prims.bool) -> - ('a, 'b) FStar_Pervasives.either -> - ('a, 'b) FStar_Pervasives.either -> Prims.bool - = - fun e1 -> - fun e2 -> - fun x -> - fun y -> - match (x, y) with - | (FStar_Pervasives.Inl x1, FStar_Pervasives.Inl y1) -> e1 x1 y1 - | (FStar_Pervasives.Inr x1, FStar_Pervasives.Inr y1) -> e2 x1 y1 - | uu___ -> false -let eqprod : - 'a 'b . - ('a -> 'a -> Prims.bool) -> - ('b -> 'b -> Prims.bool) -> ('a * 'b) -> ('a * 'b) -> Prims.bool - = - fun e1 -> - fun e2 -> - fun x -> - fun y -> - match (x, y) with - | ((x1, x2), (y1, y2)) -> (e1 x1 y1) && (e2 x2 y2) -let eqopt : - 'a . - ('a -> 'a -> Prims.bool) -> - 'a FStar_Pervasives_Native.option -> - 'a FStar_Pervasives_Native.option -> Prims.bool - = - fun e -> - fun x -> - fun y -> - match (x, y) with - | (FStar_Pervasives_Native.Some x1, FStar_Pervasives_Native.Some y1) - -> e x1 y1 - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> - true - | uu___ -> false -let (debug_term_eq : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref false -let (check : Prims.bool -> Prims.string -> Prims.bool -> Prims.bool) = - fun dbg -> - fun msg -> - fun cond -> - if cond - then true - else - (if dbg - then FStar_Compiler_Util.print1 ">>> term_eq failing: %s\n" msg - else (); - false) -let (fail : Prims.bool -> Prims.string -> Prims.bool) = - fun dbg -> fun msg -> check dbg msg false -let rec (term_eq_dbg : - Prims.bool -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term -> Prims.bool) - = - fun dbg -> - fun t1 -> - fun t2 -> - let t11 = let uu___ = unmeta_safe t1 in canon_app uu___ in - let t21 = let uu___ = unmeta_safe t2 in canon_app uu___ in - let check1 = check dbg in - let fail1 = fail dbg in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = un_uinst t11 in FStar_Syntax_Subst.compress uu___3 in - uu___2.FStar_Syntax_Syntax.n in - let uu___2 = - let uu___3 = - let uu___4 = un_uinst t21 in FStar_Syntax_Subst.compress uu___4 in - uu___3.FStar_Syntax_Syntax.n in - (uu___1, uu___2) in - match uu___ with - | (FStar_Syntax_Syntax.Tm_uinst uu___1, uu___2) -> - failwith "term_eq: impossible, should have been removed" - | (uu___1, FStar_Syntax_Syntax.Tm_uinst uu___2) -> - failwith "term_eq: impossible, should have been removed" - | (FStar_Syntax_Syntax.Tm_delayed uu___1, uu___2) -> - failwith "term_eq: impossible, should have been removed" - | (uu___1, FStar_Syntax_Syntax.Tm_delayed uu___2) -> - failwith "term_eq: impossible, should have been removed" - | (FStar_Syntax_Syntax.Tm_ascribed uu___1, uu___2) -> - failwith "term_eq: impossible, should have been removed" - | (uu___1, FStar_Syntax_Syntax.Tm_ascribed uu___2) -> - failwith "term_eq: impossible, should have been removed" - | (FStar_Syntax_Syntax.Tm_bvar x, FStar_Syntax_Syntax.Tm_bvar y) -> - check1 "bvar" - (x.FStar_Syntax_Syntax.index = y.FStar_Syntax_Syntax.index) - | (FStar_Syntax_Syntax.Tm_name x, FStar_Syntax_Syntax.Tm_name y) -> - check1 "name" - (x.FStar_Syntax_Syntax.index = y.FStar_Syntax_Syntax.index) - | (FStar_Syntax_Syntax.Tm_fvar x, FStar_Syntax_Syntax.Tm_fvar y) -> - let uu___1 = FStar_Syntax_Syntax.fv_eq x y in - check1 "fvar" uu___1 - | (FStar_Syntax_Syntax.Tm_constant c1, - FStar_Syntax_Syntax.Tm_constant c2) -> - let uu___1 = FStar_Const.eq_const c1 c2 in check1 "const" uu___1 - | (FStar_Syntax_Syntax.Tm_type uu___1, FStar_Syntax_Syntax.Tm_type - uu___2) -> true - | (FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = b1; FStar_Syntax_Syntax.body = t12; - FStar_Syntax_Syntax.rc_opt = k1;_}, - FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = b2; FStar_Syntax_Syntax.body = t22; - FStar_Syntax_Syntax.rc_opt = k2;_}) - -> - (let uu___1 = eqlist (binder_eq_dbg dbg) b1 b2 in - check1 "abs binders" uu___1) && - (let uu___1 = term_eq_dbg dbg t12 t22 in - check1 "abs bodies" uu___1) - | (FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = b1; FStar_Syntax_Syntax.comp = c1;_}, - FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = b2; FStar_Syntax_Syntax.comp = c2;_}) - -> - (let uu___1 = eqlist (binder_eq_dbg dbg) b1 b2 in - check1 "arrow binders" uu___1) && - (let uu___1 = comp_eq_dbg dbg c1 c2 in - check1 "arrow comp" uu___1) - | (FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = b1; FStar_Syntax_Syntax.phi = t12;_}, - FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = b2; FStar_Syntax_Syntax.phi = t22;_}) -> - (let uu___1 = - term_eq_dbg dbg b1.FStar_Syntax_Syntax.sort - b2.FStar_Syntax_Syntax.sort in - check1 "refine bv sort" uu___1) && - (let uu___1 = term_eq_dbg dbg t12 t22 in - check1 "refine formula" uu___1) - | (FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = f1; FStar_Syntax_Syntax.args = a1;_}, - FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = f2; FStar_Syntax_Syntax.args = a2;_}) - -> - (let uu___1 = term_eq_dbg dbg f1 f2 in check1 "app head" uu___1) - && - (let uu___1 = eqlist (arg_eq_dbg dbg) a1 a2 in - check1 "app args" uu___1) - | (FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = t12; - FStar_Syntax_Syntax.ret_opt = FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.brs = bs1; - FStar_Syntax_Syntax.rc_opt1 = uu___1;_}, - FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = t22; - FStar_Syntax_Syntax.ret_opt = FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.brs = bs2; - FStar_Syntax_Syntax.rc_opt1 = uu___2;_}) - -> - (let uu___3 = term_eq_dbg dbg t12 t22 in - check1 "match head" uu___3) && - (let uu___3 = eqlist (branch_eq_dbg dbg) bs1 bs2 in - check1 "match branches" uu___3) - | (FStar_Syntax_Syntax.Tm_lazy uu___1, uu___2) -> - let uu___3 = - let uu___4 = unlazy t11 in term_eq_dbg dbg uu___4 t21 in - check1 "lazy_l" uu___3 - | (uu___1, FStar_Syntax_Syntax.Tm_lazy uu___2) -> - let uu___3 = - let uu___4 = unlazy t21 in term_eq_dbg dbg t11 uu___4 in - check1 "lazy_r" uu___3 - | (FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (b1, lbs1); - FStar_Syntax_Syntax.body1 = t12;_}, - FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (b2, lbs2); - FStar_Syntax_Syntax.body1 = t22;_}) - -> - ((check1 "let flag" (b1 = b2)) && - (let uu___1 = eqlist (letbinding_eq_dbg dbg) lbs1 lbs2 in - check1 "let lbs" uu___1)) - && - (let uu___1 = term_eq_dbg dbg t12 t22 in - check1 "let body" uu___1) - | (FStar_Syntax_Syntax.Tm_uvar (u1, uu___1), - FStar_Syntax_Syntax.Tm_uvar (u2, uu___2)) -> - check1 "uvar" - (u1.FStar_Syntax_Syntax.ctx_uvar_head = - u2.FStar_Syntax_Syntax.ctx_uvar_head) - | (FStar_Syntax_Syntax.Tm_quoted (qt1, qi1), - FStar_Syntax_Syntax.Tm_quoted (qt2, qi2)) -> - (let uu___1 = quote_info_eq_dbg dbg qi1 qi2 in - check1 "tm_quoted qi" uu___1) && - (let uu___1 = term_eq_dbg dbg qt1 qt2 in - check1 "tm_quoted payload" uu___1) - | (FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t12; FStar_Syntax_Syntax.meta = m1;_}, - FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t22; FStar_Syntax_Syntax.meta = m2;_}) - -> - (match (m1, m2) with - | (FStar_Syntax_Syntax.Meta_monadic (n1, ty1), - FStar_Syntax_Syntax.Meta_monadic (n2, ty2)) -> - (let uu___1 = FStar_Ident.lid_equals n1 n2 in - check1 "meta_monadic lid" uu___1) && - (let uu___1 = term_eq_dbg dbg ty1 ty2 in - check1 "meta_monadic type" uu___1) - | (FStar_Syntax_Syntax.Meta_monadic_lift (s1, t13, ty1), - FStar_Syntax_Syntax.Meta_monadic_lift (s2, t23, ty2)) -> - ((let uu___1 = FStar_Ident.lid_equals s1 s2 in - check1 "meta_monadic_lift src" uu___1) && - (let uu___1 = FStar_Ident.lid_equals t13 t23 in - check1 "meta_monadic_lift tgt" uu___1)) - && - (let uu___1 = term_eq_dbg dbg ty1 ty2 in - check1 "meta_monadic_lift type" uu___1) - | uu___1 -> fail1 "metas") - | (FStar_Syntax_Syntax.Tm_unknown, uu___1) -> fail1 "unk" - | (uu___1, FStar_Syntax_Syntax.Tm_unknown) -> fail1 "unk" - | (FStar_Syntax_Syntax.Tm_bvar uu___1, uu___2) -> fail1 "bottom" - | (FStar_Syntax_Syntax.Tm_name uu___1, uu___2) -> fail1 "bottom" - | (FStar_Syntax_Syntax.Tm_fvar uu___1, uu___2) -> fail1 "bottom" - | (FStar_Syntax_Syntax.Tm_constant uu___1, uu___2) -> fail1 "bottom" - | (FStar_Syntax_Syntax.Tm_type uu___1, uu___2) -> fail1 "bottom" - | (FStar_Syntax_Syntax.Tm_abs uu___1, uu___2) -> fail1 "bottom" - | (FStar_Syntax_Syntax.Tm_arrow uu___1, uu___2) -> fail1 "bottom" - | (FStar_Syntax_Syntax.Tm_refine uu___1, uu___2) -> fail1 "bottom" - | (FStar_Syntax_Syntax.Tm_app uu___1, uu___2) -> fail1 "bottom" - | (FStar_Syntax_Syntax.Tm_match uu___1, uu___2) -> fail1 "bottom" - | (FStar_Syntax_Syntax.Tm_let uu___1, uu___2) -> fail1 "bottom" - | (FStar_Syntax_Syntax.Tm_uvar uu___1, uu___2) -> fail1 "bottom" - | (FStar_Syntax_Syntax.Tm_meta uu___1, uu___2) -> fail1 "bottom" - | (uu___1, FStar_Syntax_Syntax.Tm_bvar uu___2) -> fail1 "bottom" - | (uu___1, FStar_Syntax_Syntax.Tm_name uu___2) -> fail1 "bottom" - | (uu___1, FStar_Syntax_Syntax.Tm_fvar uu___2) -> fail1 "bottom" - | (uu___1, FStar_Syntax_Syntax.Tm_constant uu___2) -> fail1 "bottom" - | (uu___1, FStar_Syntax_Syntax.Tm_type uu___2) -> fail1 "bottom" - | (uu___1, FStar_Syntax_Syntax.Tm_abs uu___2) -> fail1 "bottom" - | (uu___1, FStar_Syntax_Syntax.Tm_arrow uu___2) -> fail1 "bottom" - | (uu___1, FStar_Syntax_Syntax.Tm_refine uu___2) -> fail1 "bottom" - | (uu___1, FStar_Syntax_Syntax.Tm_app uu___2) -> fail1 "bottom" - | (uu___1, FStar_Syntax_Syntax.Tm_match uu___2) -> fail1 "bottom" - | (uu___1, FStar_Syntax_Syntax.Tm_let uu___2) -> fail1 "bottom" - | (uu___1, FStar_Syntax_Syntax.Tm_uvar uu___2) -> fail1 "bottom" - | (uu___1, FStar_Syntax_Syntax.Tm_meta uu___2) -> fail1 "bottom" -and (arg_eq_dbg : - Prims.bool -> - (FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) -> - (FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) -> - Prims.bool) - = - fun dbg -> - fun a1 -> - fun a2 -> - eqprod - (fun t1 -> - fun t2 -> - let uu___ = term_eq_dbg dbg t1 t2 in check dbg "arg tm" uu___) - (fun q1 -> - fun q2 -> - let uu___ = aqual_eq_dbg dbg q1 q2 in - check dbg "arg qual" uu___) a1 a2 -and (binder_eq_dbg : - Prims.bool -> - FStar_Syntax_Syntax.binder -> FStar_Syntax_Syntax.binder -> Prims.bool) - = - fun dbg -> - fun b1 -> - fun b2 -> - ((let uu___ = - term_eq_dbg dbg - (b1.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort - (b2.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - check dbg "binder_sort" uu___) && - (let uu___ = - bqual_eq_dbg dbg b1.FStar_Syntax_Syntax.binder_qual - b2.FStar_Syntax_Syntax.binder_qual in - check dbg "binder qual" uu___)) - && - (let uu___ = - eqlist (term_eq_dbg dbg) b1.FStar_Syntax_Syntax.binder_attrs - b2.FStar_Syntax_Syntax.binder_attrs in - check dbg "binder attrs" uu___) -and (comp_eq_dbg : - Prims.bool -> - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> Prims.bool) - = - fun dbg -> - fun c1 -> - fun c2 -> - let uu___ = comp_eff_name_res_and_args c1 in - match uu___ with - | (eff1, res1, args1) -> - let uu___1 = comp_eff_name_res_and_args c2 in - (match uu___1 with - | (eff2, res2, args2) -> - ((let uu___2 = FStar_Ident.lid_equals eff1 eff2 in - check dbg "comp eff" uu___2) && - (let uu___2 = term_eq_dbg dbg res1 res2 in - check dbg "comp result typ" uu___2)) - && true) -and (branch_eq_dbg : - Prims.bool -> - (FStar_Syntax_Syntax.pat' FStar_Syntax_Syntax.withinfo_t * - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - FStar_Pervasives_Native.option * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax) -> - (FStar_Syntax_Syntax.pat' FStar_Syntax_Syntax.withinfo_t * - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - FStar_Pervasives_Native.option * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax) -> Prims.bool) - = - fun dbg -> - fun uu___ -> - fun uu___1 -> - match (uu___, uu___1) with - | ((p1, w1, t1), (p2, w2, t2)) -> - ((let uu___2 = FStar_Syntax_Syntax.eq_pat p1 p2 in - check dbg "branch pat" uu___2) && - (let uu___2 = term_eq_dbg dbg t1 t2 in - check dbg "branch body" uu___2)) - && - (let uu___2 = - match (w1, w2) with - | (FStar_Pervasives_Native.Some x, - FStar_Pervasives_Native.Some y) -> term_eq_dbg dbg x y - | (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None) -> true - | uu___3 -> false in - check dbg "branch when" uu___2) -and (letbinding_eq_dbg : - Prims.bool -> - FStar_Syntax_Syntax.letbinding -> - FStar_Syntax_Syntax.letbinding -> Prims.bool) - = - fun dbg -> - fun lb1 -> - fun lb2 -> - ((let uu___ = - eqsum (fun bv1 -> fun bv2 -> true) FStar_Syntax_Syntax.fv_eq - lb1.FStar_Syntax_Syntax.lbname lb2.FStar_Syntax_Syntax.lbname in - check dbg "lb bv" uu___) && - (let uu___ = - term_eq_dbg dbg lb1.FStar_Syntax_Syntax.lbtyp - lb2.FStar_Syntax_Syntax.lbtyp in - check dbg "lb typ" uu___)) - && - (let uu___ = - term_eq_dbg dbg lb1.FStar_Syntax_Syntax.lbdef - lb2.FStar_Syntax_Syntax.lbdef in - check dbg "lb def" uu___) -and (quote_info_eq_dbg : - Prims.bool -> - FStar_Syntax_Syntax.quoteinfo -> - FStar_Syntax_Syntax.quoteinfo -> Prims.bool) - = - fun dbg -> - fun q1 -> - fun q2 -> - if q1.FStar_Syntax_Syntax.qkind <> q2.FStar_Syntax_Syntax.qkind - then false - else - antiquotations_eq_dbg dbg - (FStar_Pervasives_Native.snd - q1.FStar_Syntax_Syntax.antiquotations) - (FStar_Pervasives_Native.snd - q2.FStar_Syntax_Syntax.antiquotations) -and (antiquotations_eq_dbg : - Prims.bool -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax Prims.list -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax Prims.list -> - Prims.bool) - = - fun dbg -> - fun a1 -> - fun a2 -> - match (a1, a2) with - | ([], []) -> true - | ([], uu___) -> false - | (uu___, []) -> false - | (t1::a11, t2::a21) -> - let uu___ = - let uu___1 = term_eq_dbg dbg t1 t2 in Prims.op_Negation uu___1 in - if uu___ then false else antiquotations_eq_dbg dbg a11 a21 -and (bqual_eq_dbg : - Prims.bool -> - FStar_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> - Prims.bool) - = - fun dbg -> - fun a1 -> - fun a2 -> - match (a1, a2) with - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> - true - | (FStar_Pervasives_Native.None, uu___) -> false - | (uu___, FStar_Pervasives_Native.None) -> false - | (FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit b1), - FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit b2)) - when b1 = b2 -> true - | (FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta t1), - FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta t2)) -> - term_eq_dbg dbg t1 t2 - | (FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Equality), - FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Equality)) -> - true - | uu___ -> false -and (aqual_eq_dbg : - Prims.bool -> - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option -> - Prims.bool) - = - fun dbg -> - fun a1 -> - fun a2 -> - match (a1, a2) with - | (FStar_Pervasives_Native.Some a11, FStar_Pervasives_Native.Some - a21) -> - if - (a11.FStar_Syntax_Syntax.aqual_implicit = - a21.FStar_Syntax_Syntax.aqual_implicit) - && - ((FStar_Compiler_List.length - a11.FStar_Syntax_Syntax.aqual_attributes) - = - (FStar_Compiler_List.length - a21.FStar_Syntax_Syntax.aqual_attributes)) - then - FStar_Compiler_List.fold_left2 - (fun out -> - fun t1 -> - fun t2 -> - if Prims.op_Negation out - then false - else term_eq_dbg dbg t1 t2) true - a11.FStar_Syntax_Syntax.aqual_attributes - a21.FStar_Syntax_Syntax.aqual_attributes - else false - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> - true - | uu___ -> false -let (eq_aqual : - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option -> - Prims.bool) - = fun a1 -> fun a2 -> aqual_eq_dbg false a1 a2 -let (eq_bqual : - FStar_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> - Prims.bool) - = fun b1 -> fun b2 -> bqual_eq_dbg false b1 b2 -let (term_eq : - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term -> Prims.bool) = - fun t1 -> - fun t2 -> - let r = - let uu___ = FStar_Compiler_Effect.op_Bang debug_term_eq in - term_eq_dbg uu___ t1 t2 in - FStar_Compiler_Effect.op_Colon_Equals debug_term_eq false; r -let rec (sizeof : FStar_Syntax_Syntax.term -> Prims.int) = - fun t -> - match t.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_delayed uu___ -> - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress t in sizeof uu___2 in - Prims.int_one + uu___1 - | FStar_Syntax_Syntax.Tm_bvar bv -> - let uu___ = sizeof bv.FStar_Syntax_Syntax.sort in - Prims.int_one + uu___ - | FStar_Syntax_Syntax.Tm_name bv -> - let uu___ = sizeof bv.FStar_Syntax_Syntax.sort in - Prims.int_one + uu___ - | FStar_Syntax_Syntax.Tm_uinst (t1, us) -> - let uu___ = sizeof t1 in (FStar_Compiler_List.length us) + uu___ - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs; FStar_Syntax_Syntax.body = t1; - FStar_Syntax_Syntax.rc_opt = uu___;_} - -> - let uu___1 = sizeof t1 in - let uu___2 = - FStar_Compiler_List.fold_left - (fun acc -> - fun b -> - let uu___3 = - sizeof - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - acc + uu___3) Prims.int_zero bs in - uu___1 + uu___2 - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = hd; FStar_Syntax_Syntax.args = args;_} -> - let uu___ = sizeof hd in - let uu___1 = - FStar_Compiler_List.fold_left - (fun acc -> - fun uu___2 -> - match uu___2 with - | (arg, uu___3) -> let uu___4 = sizeof arg in acc + uu___4) - Prims.int_zero args in - uu___ + uu___1 - | uu___ -> Prims.int_one -let (is_fvar : FStar_Ident.lident -> FStar_Syntax_Syntax.term -> Prims.bool) - = - fun lid -> - fun t -> - let uu___ = let uu___1 = un_uinst t in uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_fvar fv -> - FStar_Syntax_Syntax.fv_eq_lid fv lid - | uu___1 -> false -let (is_synth_by_tactic : FStar_Syntax_Syntax.term -> Prims.bool) = - fun t -> is_fvar FStar_Parser_Const.synth_lid t -let (has_attribute : - FStar_Syntax_Syntax.attribute Prims.list -> - FStar_Ident.lident -> Prims.bool) - = - fun attrs -> fun attr -> FStar_Compiler_Util.for_some (is_fvar attr) attrs -let (get_attribute : - FStar_Ident.lident -> - FStar_Syntax_Syntax.attribute Prims.list -> - FStar_Syntax_Syntax.args FStar_Pervasives_Native.option) - = - fun attr -> - fun attrs -> - FStar_Compiler_List.tryPick - (fun t -> - let uu___ = head_and_args t in - match uu___ with - | (head, args) -> - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress head in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv attr -> - FStar_Pervasives_Native.Some args - | uu___2 -> FStar_Pervasives_Native.None)) attrs -let (remove_attr : - FStar_Ident.lident -> - FStar_Syntax_Syntax.attribute Prims.list -> - FStar_Syntax_Syntax.attribute Prims.list) - = - fun attr -> - fun attrs -> - FStar_Compiler_List.filter - (fun a -> let uu___ = is_fvar attr a in Prims.op_Negation uu___) - attrs -let (process_pragma : - FStar_Syntax_Syntax.pragma -> FStar_Compiler_Range_Type.range -> unit) = - fun p -> - fun r -> - FStar_Errors.set_option_warning_callback_range - (FStar_Pervasives_Native.Some r); - (let set_options s = - let uu___1 = FStar_Options.set_options s in - match uu___1 with - | FStar_Getopt.Success -> () - | FStar_Getopt.Help -> - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_FailToProcessPragma () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Failed to process pragma: use 'fstar --help' to see which options are available") - | FStar_Getopt.Error s1 -> - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_FailToProcessPragma () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic (Prims.strcat "Failed to process pragma: " s1)) in - match p with - | FStar_Syntax_Syntax.ShowOptions -> () - | FStar_Syntax_Syntax.SetOptions o -> set_options o - | FStar_Syntax_Syntax.ResetOptions sopt -> - ((let uu___2 = FStar_Options.restore_cmd_line_options false in ()); - (match sopt with - | FStar_Pervasives_Native.None -> () - | FStar_Pervasives_Native.Some s -> set_options s)) - | FStar_Syntax_Syntax.PushOptions sopt -> - (FStar_Options.internal_push (); - (match sopt with - | FStar_Pervasives_Native.None -> () - | FStar_Pervasives_Native.Some s -> set_options s)) - | FStar_Syntax_Syntax.RestartSolver -> () - | FStar_Syntax_Syntax.PopOptions -> - let uu___1 = - let uu___2 = FStar_Options.internal_pop () in - Prims.op_Negation uu___2 in - if uu___1 - then - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_FailToProcessPragma () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic "Cannot #pop-options, stack would become empty") - else () - | FStar_Syntax_Syntax.PrintEffectsGraph -> ()) -let rec (unbound_variables : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.bv Prims.list) - = - fun tm -> - let t = FStar_Syntax_Subst.compress tm in - match t.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_delayed uu___ -> failwith "Impossible" - | FStar_Syntax_Syntax.Tm_name x -> [] - | FStar_Syntax_Syntax.Tm_uvar uu___ -> [] - | FStar_Syntax_Syntax.Tm_type u -> [] - | FStar_Syntax_Syntax.Tm_bvar x -> [x] - | FStar_Syntax_Syntax.Tm_fvar uu___ -> [] - | FStar_Syntax_Syntax.Tm_constant uu___ -> [] - | FStar_Syntax_Syntax.Tm_lazy uu___ -> [] - | FStar_Syntax_Syntax.Tm_unknown -> [] - | FStar_Syntax_Syntax.Tm_uinst (t1, us) -> unbound_variables t1 - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs; FStar_Syntax_Syntax.body = t1; - FStar_Syntax_Syntax.rc_opt = uu___;_} - -> - let uu___1 = FStar_Syntax_Subst.open_term bs t1 in - (match uu___1 with - | (bs1, t2) -> - let uu___2 = - FStar_Compiler_List.collect - (fun b -> - unbound_variables - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort) - bs1 in - let uu___3 = unbound_variables t2 in - FStar_Compiler_List.op_At uu___2 uu___3) - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; FStar_Syntax_Syntax.comp = c;_} -> - let uu___ = FStar_Syntax_Subst.open_comp bs c in - (match uu___ with - | (bs1, c1) -> - let uu___1 = - FStar_Compiler_List.collect - (fun b -> - unbound_variables - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort) - bs1 in - let uu___2 = unbound_variables_comp c1 in - FStar_Compiler_List.op_At uu___1 uu___2) - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = b; FStar_Syntax_Syntax.phi = t1;_} -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Syntax_Syntax.mk_binder b in [uu___2] in - FStar_Syntax_Subst.open_term uu___1 t1 in - (match uu___ with - | (bs, t2) -> - let uu___1 = - FStar_Compiler_List.collect - (fun b1 -> - unbound_variables - (b1.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort) - bs in - let uu___2 = unbound_variables t2 in - FStar_Compiler_List.op_At uu___1 uu___2) - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = t1; FStar_Syntax_Syntax.args = args;_} -> - let uu___ = - FStar_Compiler_List.collect - (fun uu___1 -> - match uu___1 with | (x, uu___2) -> unbound_variables x) args in - let uu___1 = unbound_variables t1 in - FStar_Compiler_List.op_At uu___ uu___1 - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = t1; - FStar_Syntax_Syntax.ret_opt = asc_opt; - FStar_Syntax_Syntax.brs = pats; - FStar_Syntax_Syntax.rc_opt1 = uu___;_} - -> - let uu___1 = unbound_variables t1 in - let uu___2 = - let uu___3 = - match asc_opt with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some (b, asc) -> - let uu___4 = FStar_Syntax_Subst.open_ascription [b] asc in - (match uu___4 with - | (bs, asc1) -> - let uu___5 = - FStar_Compiler_List.collect - (fun b1 -> - unbound_variables - (b1.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort) - bs in - let uu___6 = unbound_variables_ascription asc1 in - FStar_Compiler_List.op_At uu___5 uu___6) in - let uu___4 = - FStar_Compiler_List.collect - (fun br -> - let uu___5 = FStar_Syntax_Subst.open_branch br in - match uu___5 with - | (p, wopt, t2) -> - let uu___6 = unbound_variables t2 in - let uu___7 = - match wopt with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some t3 -> - unbound_variables t3 in - FStar_Compiler_List.op_At uu___6 uu___7) pats in - FStar_Compiler_List.op_At uu___3 uu___4 in - FStar_Compiler_List.op_At uu___1 uu___2 - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t1; FStar_Syntax_Syntax.asc = asc; - FStar_Syntax_Syntax.eff_opt = uu___;_} - -> - let uu___1 = unbound_variables t1 in - let uu___2 = unbound_variables_ascription asc in - FStar_Compiler_List.op_At uu___1 uu___2 - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (false, lb::[]); - FStar_Syntax_Syntax.body1 = t1;_} - -> - let uu___ = unbound_variables lb.FStar_Syntax_Syntax.lbtyp in - let uu___1 = - let uu___2 = unbound_variables lb.FStar_Syntax_Syntax.lbdef in - let uu___3 = - match lb.FStar_Syntax_Syntax.lbname with - | FStar_Pervasives.Inr uu___4 -> unbound_variables t1 - | FStar_Pervasives.Inl bv -> - let uu___4 = - let uu___5 = - let uu___6 = FStar_Syntax_Syntax.mk_binder bv in [uu___6] in - FStar_Syntax_Subst.open_term uu___5 t1 in - (match uu___4 with | (uu___5, t2) -> unbound_variables t2) in - FStar_Compiler_List.op_At uu___2 uu___3 in - FStar_Compiler_List.op_At uu___ uu___1 - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (uu___, lbs); - FStar_Syntax_Syntax.body1 = t1;_} - -> - let uu___1 = FStar_Syntax_Subst.open_let_rec lbs t1 in - (match uu___1 with - | (lbs1, t2) -> - let uu___2 = unbound_variables t2 in - let uu___3 = - FStar_Compiler_List.collect - (fun lb -> - let uu___4 = - unbound_variables lb.FStar_Syntax_Syntax.lbtyp in - let uu___5 = - unbound_variables lb.FStar_Syntax_Syntax.lbdef in - FStar_Compiler_List.op_At uu___4 uu___5) lbs1 in - FStar_Compiler_List.op_At uu___2 uu___3) - | FStar_Syntax_Syntax.Tm_quoted (tm1, qi) -> - (match qi.FStar_Syntax_Syntax.qkind with - | FStar_Syntax_Syntax.Quote_static -> [] - | FStar_Syntax_Syntax.Quote_dynamic -> unbound_variables tm1) - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t1; FStar_Syntax_Syntax.meta = m;_} -> - let uu___ = unbound_variables t1 in - let uu___1 = - match m with - | FStar_Syntax_Syntax.Meta_pattern (uu___2, args) -> - FStar_Compiler_List.collect - (FStar_Compiler_List.collect - (fun uu___3 -> - match uu___3 with | (a, uu___4) -> unbound_variables a)) - args - | FStar_Syntax_Syntax.Meta_monadic_lift (uu___2, uu___3, t') -> - unbound_variables t' - | FStar_Syntax_Syntax.Meta_monadic (uu___2, t') -> - unbound_variables t' - | FStar_Syntax_Syntax.Meta_labeled uu___2 -> [] - | FStar_Syntax_Syntax.Meta_desugared uu___2 -> [] - | FStar_Syntax_Syntax.Meta_named uu___2 -> [] in - FStar_Compiler_List.op_At uu___ uu___1 -and (unbound_variables_ascription : - ((FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax, - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax) - FStar_Pervasives.either * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax FStar_Pervasives_Native.option * Prims.bool) - -> FStar_Syntax_Syntax.bv Prims.list) - = - fun asc -> - let uu___ = asc in - match uu___ with - | (asc1, topt, uu___1) -> - let uu___2 = - match asc1 with - | FStar_Pervasives.Inl t2 -> unbound_variables t2 - | FStar_Pervasives.Inr c2 -> unbound_variables_comp c2 in - let uu___3 = - match topt with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some tac -> unbound_variables tac in - FStar_Compiler_List.op_At uu___2 uu___3 -and (unbound_variables_comp : - FStar_Syntax_Syntax.comp -> FStar_Syntax_Syntax.bv Prims.list) = - fun c -> - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total t -> unbound_variables t - | FStar_Syntax_Syntax.GTotal t -> unbound_variables t - | FStar_Syntax_Syntax.Comp ct -> - let uu___ = unbound_variables ct.FStar_Syntax_Syntax.result_typ in - let uu___1 = - FStar_Compiler_List.collect - (fun uu___2 -> - match uu___2 with | (a, uu___3) -> unbound_variables a) - ct.FStar_Syntax_Syntax.effect_args in - FStar_Compiler_List.op_At uu___ uu___1 -let (extract_attr' : - FStar_Ident.lid -> - FStar_Syntax_Syntax.term Prims.list -> - (FStar_Syntax_Syntax.term Prims.list * FStar_Syntax_Syntax.args) - FStar_Pervasives_Native.option) - = - fun attr_lid -> - fun attrs -> - let rec aux acc attrs1 = - match attrs1 with - | [] -> FStar_Pervasives_Native.None - | h::t -> - let uu___ = head_and_args h in - (match uu___ with - | (head, args) -> - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress head in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv attr_lid -> - let attrs' = FStar_Compiler_List.rev_acc acc t in - FStar_Pervasives_Native.Some (attrs', args) - | uu___2 -> aux (h :: acc) t)) in - aux [] attrs -let (extract_attr : - FStar_Ident.lid -> - FStar_Syntax_Syntax.sigelt -> - (FStar_Syntax_Syntax.sigelt * FStar_Syntax_Syntax.args) - FStar_Pervasives_Native.option) - = - fun attr_lid -> - fun se -> - let uu___ = extract_attr' attr_lid se.FStar_Syntax_Syntax.sigattrs in - match uu___ with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (attrs', t) -> - FStar_Pervasives_Native.Some - ({ - FStar_Syntax_Syntax.sigel = (se.FStar_Syntax_Syntax.sigel); - FStar_Syntax_Syntax.sigrng = (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = attrs'; - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = (se.FStar_Syntax_Syntax.sigopts) - }, t) -let (is_smt_lemma : FStar_Syntax_Syntax.term -> Prims.bool) = - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = uu___1; FStar_Syntax_Syntax.comp = c;_} - -> - (match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Comp ct when - FStar_Ident.lid_equals ct.FStar_Syntax_Syntax.effect_name - FStar_Parser_Const.effect_Lemma_lid - -> - (match ct.FStar_Syntax_Syntax.effect_args with - | _req::_ens::(pats, uu___2)::uu___3 -> - let pats' = unmeta pats in - let uu___4 = head_and_args pats' in - (match uu___4 with - | (head, uu___5) -> - let uu___6 = - let uu___7 = un_uinst head in - uu___7.FStar_Syntax_Syntax.n in - (match uu___6 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.cons_lid - | uu___7 -> false)) - | uu___2 -> false) - | uu___2 -> false) - | uu___1 -> false -let rec (list_elements : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term Prims.list FStar_Pervasives_Native.option) - = - fun e -> - let uu___ = let uu___1 = unmeta e in head_and_args uu___1 in - match uu___ with - | (head, args) -> - let uu___1 = - let uu___2 = - let uu___3 = un_uinst head in uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, uu___2) when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.nil_lid -> - FStar_Pervasives_Native.Some [] - | (FStar_Syntax_Syntax.Tm_fvar fv, - uu___2::(hd, uu___3)::(tl, uu___4)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.cons_lid -> - let uu___5 = - let uu___6 = - let uu___7 = list_elements tl in - FStar_Compiler_Util.must uu___7 in - hd :: uu___6 in - FStar_Pervasives_Native.Some uu___5 - | uu___2 -> FStar_Pervasives_Native.None) -let (destruct_lemma_with_smt_patterns : - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.binders * FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.arg Prims.list - Prims.list) FStar_Pervasives_Native.option) - = - fun t -> - let lemma_pats p = - let smt_pat_or t1 = - let uu___ = let uu___1 = unmeta t1 in head_and_args uu___1 in - match uu___ with - | (head, args) -> - let uu___1 = - let uu___2 = - let uu___3 = un_uinst head in uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, (e, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.smtpatOr_lid - -> FStar_Pervasives_Native.Some e - | uu___2 -> FStar_Pervasives_Native.None) in - let one_pat p1 = - let uu___ = let uu___1 = unmeta p1 in head_and_args uu___1 in - match uu___ with - | (head, args) -> - let uu___1 = - let uu___2 = - let uu___3 = un_uinst head in uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, (uu___2, uu___3)::arg::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.smtpat_lid - -> arg - | uu___2 -> - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Errors_Msg.text "Not an atomic SMT pattern:" in - let uu___6 = ttd p1 in - FStar_Pprint.prefix (Prims.of_int (2)) Prims.int_one - uu___5 uu___6 in - let uu___5 = - let uu___6 = - FStar_Errors_Msg.text - "Patterns on lemmas must be a list of simple SMTPat's;or a single SMTPatOr containing a list;of lists of patterns." in - [uu___6] in - uu___4 :: uu___5 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) p1 - FStar_Errors_Codes.Error_IllSMTPat () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___3)) in - let list_literal_elements e = - let uu___ = list_elements e in - match uu___ with - | FStar_Pervasives_Native.Some l -> l - | FStar_Pervasives_Native.None -> - (FStar_Errors.log_issue (FStar_Syntax_Syntax.has_range_syntax ()) - e FStar_Errors_Codes.Warning_NonListLiteralSMTPattern () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "SMT pattern is not a list literal; ignoring the pattern"); - []) in - let elts = list_literal_elements p in - match elts with - | t1::[] -> - let uu___ = smt_pat_or t1 in - (match uu___ with - | FStar_Pervasives_Native.Some e -> - let uu___1 = list_literal_elements e in - FStar_Compiler_List.map - (fun branch1 -> - let uu___2 = list_literal_elements branch1 in - FStar_Compiler_List.map one_pat uu___2) uu___1 - | uu___1 -> - let uu___2 = FStar_Compiler_List.map one_pat elts in [uu___2]) - | uu___ -> - let uu___1 = FStar_Compiler_List.map one_pat elts in [uu___1] in - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = binders; FStar_Syntax_Syntax.comp = c;_} - -> - let uu___1 = FStar_Syntax_Subst.open_comp binders c in - (match uu___1 with - | (binders1, c1) -> - (match c1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Comp - { FStar_Syntax_Syntax.comp_univs = uu___2; - FStar_Syntax_Syntax.effect_name = uu___3; - FStar_Syntax_Syntax.result_typ = uu___4; - FStar_Syntax_Syntax.effect_args = - (pre, uu___5)::(post, uu___6)::(pats, uu___7)::[]; - FStar_Syntax_Syntax.flags = uu___8;_} - -> - let uu___9 = - let uu___10 = lemma_pats pats in - (binders1, pre, post, uu___10) in - FStar_Pervasives_Native.Some uu___9 - | uu___2 -> failwith "impos")) - | uu___1 -> FStar_Pervasives_Native.None -let (triggers_of_smt_lemma : - FStar_Syntax_Syntax.term -> FStar_Ident.lident Prims.list Prims.list) = - fun t -> - let uu___ = destruct_lemma_with_smt_patterns t in - match uu___ with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some (uu___1, uu___2, uu___3, pats) -> - FStar_Compiler_List.map - (FStar_Compiler_List.collect - (fun uu___4 -> - match uu___4 with - | (t1, uu___5) -> - let uu___6 = FStar_Syntax_Free.fvars t1 in - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Syntax.ord_fv)) (Obj.magic uu___6))) - pats -let (unthunk : FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = b::[]; FStar_Syntax_Syntax.body = e; - FStar_Syntax_Syntax.rc_opt = uu___1;_} - -> - let uu___2 = FStar_Syntax_Subst.open_term [b] e in - (match uu___2 with - | (bs, e1) -> - let b1 = FStar_Compiler_List.hd bs in - let uu___3 = is_free_in b1.FStar_Syntax_Syntax.binder_bv e1 in - if uu___3 - then - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.as_arg exp_unit in [uu___5] in - mk_app t uu___4 - else e1) - | uu___1 -> - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.as_arg exp_unit in [uu___3] in - mk_app t uu___2 -let (unthunk_lemma_post : - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = fun t -> unthunk t -let (smt_lemma_as_forall : - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.binders -> FStar_Syntax_Syntax.universe Prims.list) - -> FStar_Syntax_Syntax.term) - = - fun t -> - fun universe_of_binders -> - let uu___ = - let uu___1 = destruct_lemma_with_smt_patterns t in - match uu___1 with - | FStar_Pervasives_Native.None -> failwith "impos" - | FStar_Pervasives_Native.Some res -> res in - match uu___ with - | (binders, pre, post, patterns) -> - let post1 = unthunk_lemma_post post in - let body = - let uu___1 = - let uu___2 = - let uu___3 = mk_imp pre post1 in - let uu___4 = - let uu___5 = - let uu___6 = FStar_Syntax_Syntax.binders_to_names binders in - (uu___6, patterns) in - FStar_Syntax_Syntax.Meta_pattern uu___5 in - { - FStar_Syntax_Syntax.tm2 = uu___3; - FStar_Syntax_Syntax.meta = uu___4 - } in - FStar_Syntax_Syntax.Tm_meta uu___2 in - FStar_Syntax_Syntax.mk uu___1 t.FStar_Syntax_Syntax.pos in - let quant = - let uu___1 = universe_of_binders binders in - FStar_Compiler_List.fold_right2 - (fun b -> - fun u -> - fun out -> mk_forall u b.FStar_Syntax_Syntax.binder_bv out) - binders uu___1 body in - quant -let (effect_sig_ts : - FStar_Syntax_Syntax.effect_signature -> FStar_Syntax_Syntax.tscheme) = - fun sig1 -> - match sig1 with - | FStar_Syntax_Syntax.Layered_eff_sig (uu___, ts) -> ts - | FStar_Syntax_Syntax.WP_eff_sig ts -> ts -let (apply_eff_sig : - (FStar_Syntax_Syntax.tscheme -> FStar_Syntax_Syntax.tscheme) -> - FStar_Syntax_Syntax.effect_signature -> - FStar_Syntax_Syntax.effect_signature) - = - fun f -> - fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.Layered_eff_sig (n, ts) -> - let uu___1 = let uu___2 = f ts in (n, uu___2) in - FStar_Syntax_Syntax.Layered_eff_sig uu___1 - | FStar_Syntax_Syntax.WP_eff_sig ts -> - let uu___1 = f ts in FStar_Syntax_Syntax.WP_eff_sig uu___1 -let (eff_decl_of_new_effect : - FStar_Syntax_Syntax.sigelt -> FStar_Syntax_Syntax.eff_decl) = - fun se -> - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_new_effect ne -> ne - | uu___ -> failwith "eff_decl_of_new_effect: not a Sig_new_effect" -let (is_layered : FStar_Syntax_Syntax.eff_decl -> Prims.bool) = - fun ed -> - match ed.FStar_Syntax_Syntax.combinators with - | FStar_Syntax_Syntax.Layered_eff uu___ -> true - | uu___ -> false -let (is_dm4f : FStar_Syntax_Syntax.eff_decl -> Prims.bool) = - fun ed -> - match ed.FStar_Syntax_Syntax.combinators with - | FStar_Syntax_Syntax.DM4F_eff uu___ -> true - | uu___ -> false -let (apply_wp_eff_combinators : - (FStar_Syntax_Syntax.tscheme -> FStar_Syntax_Syntax.tscheme) -> - FStar_Syntax_Syntax.wp_eff_combinators -> - FStar_Syntax_Syntax.wp_eff_combinators) - = - fun f -> - fun combs -> - let uu___ = f combs.FStar_Syntax_Syntax.ret_wp in - let uu___1 = f combs.FStar_Syntax_Syntax.bind_wp in - let uu___2 = f combs.FStar_Syntax_Syntax.stronger in - let uu___3 = f combs.FStar_Syntax_Syntax.if_then_else in - let uu___4 = f combs.FStar_Syntax_Syntax.ite_wp in - let uu___5 = f combs.FStar_Syntax_Syntax.close_wp in - let uu___6 = f combs.FStar_Syntax_Syntax.trivial in - let uu___7 = - FStar_Compiler_Util.map_option f combs.FStar_Syntax_Syntax.repr in - let uu___8 = - FStar_Compiler_Util.map_option f - combs.FStar_Syntax_Syntax.return_repr in - let uu___9 = - FStar_Compiler_Util.map_option f combs.FStar_Syntax_Syntax.bind_repr in - { - FStar_Syntax_Syntax.ret_wp = uu___; - FStar_Syntax_Syntax.bind_wp = uu___1; - FStar_Syntax_Syntax.stronger = uu___2; - FStar_Syntax_Syntax.if_then_else = uu___3; - FStar_Syntax_Syntax.ite_wp = uu___4; - FStar_Syntax_Syntax.close_wp = uu___5; - FStar_Syntax_Syntax.trivial = uu___6; - FStar_Syntax_Syntax.repr = uu___7; - FStar_Syntax_Syntax.return_repr = uu___8; - FStar_Syntax_Syntax.bind_repr = uu___9 - } -let (apply_layered_eff_combinators : - (FStar_Syntax_Syntax.tscheme -> FStar_Syntax_Syntax.tscheme) -> - FStar_Syntax_Syntax.layered_eff_combinators -> - FStar_Syntax_Syntax.layered_eff_combinators) - = - fun f -> - fun combs -> - let map2 uu___ = - match uu___ with - | (ts1, ts2) -> - let uu___1 = f ts1 in let uu___2 = f ts2 in (uu___1, uu___2) in - let map3 uu___ = - match uu___ with - | (ts1, ts2, k) -> - let uu___1 = f ts1 in let uu___2 = f ts2 in (uu___1, uu___2, k) in - let uu___ = map2 combs.FStar_Syntax_Syntax.l_repr in - let uu___1 = map2 combs.FStar_Syntax_Syntax.l_return in - let uu___2 = map3 combs.FStar_Syntax_Syntax.l_bind in - let uu___3 = map3 combs.FStar_Syntax_Syntax.l_subcomp in - let uu___4 = map3 combs.FStar_Syntax_Syntax.l_if_then_else in - let uu___5 = - FStar_Compiler_Util.map_option map2 combs.FStar_Syntax_Syntax.l_close in - { - FStar_Syntax_Syntax.l_repr = uu___; - FStar_Syntax_Syntax.l_return = uu___1; - FStar_Syntax_Syntax.l_bind = uu___2; - FStar_Syntax_Syntax.l_subcomp = uu___3; - FStar_Syntax_Syntax.l_if_then_else = uu___4; - FStar_Syntax_Syntax.l_close = uu___5 - } -let (apply_eff_combinators : - (FStar_Syntax_Syntax.tscheme -> FStar_Syntax_Syntax.tscheme) -> - FStar_Syntax_Syntax.eff_combinators -> - FStar_Syntax_Syntax.eff_combinators) - = - fun f -> - fun combs -> - match combs with - | FStar_Syntax_Syntax.Primitive_eff combs1 -> - let uu___ = apply_wp_eff_combinators f combs1 in - FStar_Syntax_Syntax.Primitive_eff uu___ - | FStar_Syntax_Syntax.DM4F_eff combs1 -> - let uu___ = apply_wp_eff_combinators f combs1 in - FStar_Syntax_Syntax.DM4F_eff uu___ - | FStar_Syntax_Syntax.Layered_eff combs1 -> - let uu___ = apply_layered_eff_combinators f combs1 in - FStar_Syntax_Syntax.Layered_eff uu___ -let (get_layered_close_combinator : - FStar_Syntax_Syntax.eff_decl -> - FStar_Syntax_Syntax.tscheme FStar_Pervasives_Native.option) - = - fun ed -> - match ed.FStar_Syntax_Syntax.combinators with - | FStar_Syntax_Syntax.Layered_eff - { FStar_Syntax_Syntax.l_repr = uu___; - FStar_Syntax_Syntax.l_return = uu___1; - FStar_Syntax_Syntax.l_bind = uu___2; - FStar_Syntax_Syntax.l_subcomp = uu___3; - FStar_Syntax_Syntax.l_if_then_else = uu___4; - FStar_Syntax_Syntax.l_close = FStar_Pervasives_Native.None;_} - -> FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Layered_eff - { FStar_Syntax_Syntax.l_repr = uu___; - FStar_Syntax_Syntax.l_return = uu___1; - FStar_Syntax_Syntax.l_bind = uu___2; - FStar_Syntax_Syntax.l_subcomp = uu___3; - FStar_Syntax_Syntax.l_if_then_else = uu___4; - FStar_Syntax_Syntax.l_close = FStar_Pervasives_Native.Some - (ts, uu___5);_} - -> FStar_Pervasives_Native.Some ts - | uu___ -> FStar_Pervasives_Native.None -let (get_wp_close_combinator : - FStar_Syntax_Syntax.eff_decl -> - FStar_Syntax_Syntax.tscheme FStar_Pervasives_Native.option) - = - fun ed -> - match ed.FStar_Syntax_Syntax.combinators with - | FStar_Syntax_Syntax.Primitive_eff combs -> - FStar_Pervasives_Native.Some (combs.FStar_Syntax_Syntax.close_wp) - | FStar_Syntax_Syntax.DM4F_eff combs -> - FStar_Pervasives_Native.Some (combs.FStar_Syntax_Syntax.close_wp) - | uu___ -> FStar_Pervasives_Native.None -let (get_eff_repr : - FStar_Syntax_Syntax.eff_decl -> - FStar_Syntax_Syntax.tscheme FStar_Pervasives_Native.option) - = - fun ed -> - match ed.FStar_Syntax_Syntax.combinators with - | FStar_Syntax_Syntax.Primitive_eff combs -> - combs.FStar_Syntax_Syntax.repr - | FStar_Syntax_Syntax.DM4F_eff combs -> combs.FStar_Syntax_Syntax.repr - | FStar_Syntax_Syntax.Layered_eff combs -> - FStar_Pervasives_Native.Some - (FStar_Pervasives_Native.fst combs.FStar_Syntax_Syntax.l_repr) -let (get_bind_vc_combinator : - FStar_Syntax_Syntax.eff_decl -> - (FStar_Syntax_Syntax.tscheme * - FStar_Syntax_Syntax.indexed_effect_combinator_kind - FStar_Pervasives_Native.option)) - = - fun ed -> - match ed.FStar_Syntax_Syntax.combinators with - | FStar_Syntax_Syntax.Primitive_eff combs -> - ((combs.FStar_Syntax_Syntax.bind_wp), FStar_Pervasives_Native.None) - | FStar_Syntax_Syntax.DM4F_eff combs -> - ((combs.FStar_Syntax_Syntax.bind_wp), FStar_Pervasives_Native.None) - | FStar_Syntax_Syntax.Layered_eff combs -> - ((FStar_Pervasives_Native.__proj__Mktuple3__item___2 - combs.FStar_Syntax_Syntax.l_bind), - (FStar_Pervasives_Native.__proj__Mktuple3__item___3 - combs.FStar_Syntax_Syntax.l_bind)) -let (get_return_vc_combinator : - FStar_Syntax_Syntax.eff_decl -> FStar_Syntax_Syntax.tscheme) = - fun ed -> - match ed.FStar_Syntax_Syntax.combinators with - | FStar_Syntax_Syntax.Primitive_eff combs -> - combs.FStar_Syntax_Syntax.ret_wp - | FStar_Syntax_Syntax.DM4F_eff combs -> combs.FStar_Syntax_Syntax.ret_wp - | FStar_Syntax_Syntax.Layered_eff combs -> - FStar_Pervasives_Native.snd combs.FStar_Syntax_Syntax.l_return -let (get_bind_repr : - FStar_Syntax_Syntax.eff_decl -> - FStar_Syntax_Syntax.tscheme FStar_Pervasives_Native.option) - = - fun ed -> - match ed.FStar_Syntax_Syntax.combinators with - | FStar_Syntax_Syntax.Primitive_eff combs -> - combs.FStar_Syntax_Syntax.bind_repr - | FStar_Syntax_Syntax.DM4F_eff combs -> - combs.FStar_Syntax_Syntax.bind_repr - | FStar_Syntax_Syntax.Layered_eff combs -> - FStar_Pervasives_Native.Some - (FStar_Pervasives_Native.__proj__Mktuple3__item___1 - combs.FStar_Syntax_Syntax.l_bind) -let (get_return_repr : - FStar_Syntax_Syntax.eff_decl -> - FStar_Syntax_Syntax.tscheme FStar_Pervasives_Native.option) - = - fun ed -> - match ed.FStar_Syntax_Syntax.combinators with - | FStar_Syntax_Syntax.Primitive_eff combs -> - combs.FStar_Syntax_Syntax.return_repr - | FStar_Syntax_Syntax.DM4F_eff combs -> - combs.FStar_Syntax_Syntax.return_repr - | FStar_Syntax_Syntax.Layered_eff combs -> - FStar_Pervasives_Native.Some - (FStar_Pervasives_Native.fst combs.FStar_Syntax_Syntax.l_return) -let (get_wp_trivial_combinator : - FStar_Syntax_Syntax.eff_decl -> - FStar_Syntax_Syntax.tscheme FStar_Pervasives_Native.option) - = - fun ed -> - match ed.FStar_Syntax_Syntax.combinators with - | FStar_Syntax_Syntax.Primitive_eff combs -> - FStar_Pervasives_Native.Some (combs.FStar_Syntax_Syntax.trivial) - | FStar_Syntax_Syntax.DM4F_eff combs -> - FStar_Pervasives_Native.Some (combs.FStar_Syntax_Syntax.trivial) - | uu___ -> FStar_Pervasives_Native.None -let (get_layered_if_then_else_combinator : - FStar_Syntax_Syntax.eff_decl -> - (FStar_Syntax_Syntax.tscheme * - FStar_Syntax_Syntax.indexed_effect_combinator_kind - FStar_Pervasives_Native.option) FStar_Pervasives_Native.option) - = - fun ed -> - match ed.FStar_Syntax_Syntax.combinators with - | FStar_Syntax_Syntax.Layered_eff combs -> - FStar_Pervasives_Native.Some - ((FStar_Pervasives_Native.__proj__Mktuple3__item___1 - combs.FStar_Syntax_Syntax.l_if_then_else), - (FStar_Pervasives_Native.__proj__Mktuple3__item___3 - combs.FStar_Syntax_Syntax.l_if_then_else)) - | uu___ -> FStar_Pervasives_Native.None -let (get_wp_if_then_else_combinator : - FStar_Syntax_Syntax.eff_decl -> - FStar_Syntax_Syntax.tscheme FStar_Pervasives_Native.option) - = - fun ed -> - match ed.FStar_Syntax_Syntax.combinators with - | FStar_Syntax_Syntax.Primitive_eff combs -> - FStar_Pervasives_Native.Some (combs.FStar_Syntax_Syntax.if_then_else) - | FStar_Syntax_Syntax.DM4F_eff combs -> - FStar_Pervasives_Native.Some (combs.FStar_Syntax_Syntax.if_then_else) - | uu___ -> FStar_Pervasives_Native.None -let (get_wp_ite_combinator : - FStar_Syntax_Syntax.eff_decl -> - FStar_Syntax_Syntax.tscheme FStar_Pervasives_Native.option) - = - fun ed -> - match ed.FStar_Syntax_Syntax.combinators with - | FStar_Syntax_Syntax.Primitive_eff combs -> - FStar_Pervasives_Native.Some (combs.FStar_Syntax_Syntax.ite_wp) - | FStar_Syntax_Syntax.DM4F_eff combs -> - FStar_Pervasives_Native.Some (combs.FStar_Syntax_Syntax.ite_wp) - | uu___ -> FStar_Pervasives_Native.None -let (get_stronger_vc_combinator : - FStar_Syntax_Syntax.eff_decl -> - (FStar_Syntax_Syntax.tscheme * - FStar_Syntax_Syntax.indexed_effect_combinator_kind - FStar_Pervasives_Native.option)) - = - fun ed -> - match ed.FStar_Syntax_Syntax.combinators with - | FStar_Syntax_Syntax.Primitive_eff combs -> - ((combs.FStar_Syntax_Syntax.stronger), FStar_Pervasives_Native.None) - | FStar_Syntax_Syntax.DM4F_eff combs -> - ((combs.FStar_Syntax_Syntax.stronger), FStar_Pervasives_Native.None) - | FStar_Syntax_Syntax.Layered_eff combs -> - ((FStar_Pervasives_Native.__proj__Mktuple3__item___2 - combs.FStar_Syntax_Syntax.l_subcomp), - (FStar_Pervasives_Native.__proj__Mktuple3__item___3 - combs.FStar_Syntax_Syntax.l_subcomp)) -let (get_stronger_repr : - FStar_Syntax_Syntax.eff_decl -> - FStar_Syntax_Syntax.tscheme FStar_Pervasives_Native.option) - = - fun ed -> - match ed.FStar_Syntax_Syntax.combinators with - | FStar_Syntax_Syntax.Primitive_eff uu___ -> FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.DM4F_eff uu___ -> FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Layered_eff combs -> - FStar_Pervasives_Native.Some - (FStar_Pervasives_Native.__proj__Mktuple3__item___1 - combs.FStar_Syntax_Syntax.l_subcomp) -let (aqual_is_erasable : FStar_Syntax_Syntax.aqual -> Prims.bool) = - fun aq -> - match aq with - | FStar_Pervasives_Native.None -> false - | FStar_Pervasives_Native.Some aq1 -> - FStar_Compiler_Util.for_some - (is_fvar FStar_Parser_Const.erasable_attr) - aq1.FStar_Syntax_Syntax.aqual_attributes -let (is_erased_head : - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.universe * FStar_Syntax_Syntax.term) - FStar_Pervasives_Native.option) - = - fun t -> - let uu___ = head_and_args t in - match uu___ with - | (head, args) -> - (match ((head.FStar_Syntax_Syntax.n), args) with - | (FStar_Syntax_Syntax.Tm_uinst - ({ FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___1; - FStar_Syntax_Syntax.vars = uu___2; - FStar_Syntax_Syntax.hash_code = uu___3;_}, - u::[]), - (ty, uu___4)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.erased_lid - -> FStar_Pervasives_Native.Some (u, ty) - | uu___1 -> FStar_Pervasives_Native.None) -let (apply_reveal : - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun u -> - fun ty -> - fun v -> - let head = - let uu___ = - FStar_Ident.set_lid_range FStar_Parser_Const.reveal - v.FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.fvar uu___ FStar_Pervasives_Native.None in - let uu___ = FStar_Syntax_Syntax.mk_Tm_uinst head [u] in - let uu___1 = - let uu___2 = FStar_Syntax_Syntax.iarg ty in - let uu___3 = let uu___4 = FStar_Syntax_Syntax.as_arg v in [uu___4] in - uu___2 :: uu___3 in - FStar_Syntax_Syntax.mk_Tm_app uu___ uu___1 v.FStar_Syntax_Syntax.pos -let (check_mutual_universes : - FStar_Syntax_Syntax.letbinding Prims.list -> unit) = - fun lbs -> - let uu___ = lbs in - match uu___ with - | lb::lbs1 -> - let expected = lb.FStar_Syntax_Syntax.lbunivs in - let expected_len = FStar_Compiler_List.length expected in - FStar_Compiler_List.iter - (fun lb1 -> - let uu___1 = - ((FStar_Compiler_List.length lb1.FStar_Syntax_Syntax.lbunivs) - <> expected_len) - || - (let uu___2 = - FStar_Compiler_List.forall2 FStar_Ident.ident_equals - lb1.FStar_Syntax_Syntax.lbunivs expected in - Prims.op_Negation uu___2) in - if uu___1 - then - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range - lb1.FStar_Syntax_Syntax.lbpos - FStar_Errors_Codes.Fatal_IncompatibleUniverse () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Mutually recursive definitions do not abstract over the same universes") - else ()) lbs1 -let (ctx_uvar_should_check : - FStar_Syntax_Syntax.ctx_uvar -> FStar_Syntax_Syntax.should_check_uvar) = - fun u -> - let uu___ = - FStar_Syntax_Unionfind.find_decoration - u.FStar_Syntax_Syntax.ctx_uvar_head in - uu___.FStar_Syntax_Syntax.uvar_decoration_should_check -let (ctx_uvar_typ : - FStar_Syntax_Syntax.ctx_uvar -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun u -> - let uu___ = - FStar_Syntax_Unionfind.find_decoration - u.FStar_Syntax_Syntax.ctx_uvar_head in - uu___.FStar_Syntax_Syntax.uvar_decoration_typ -let (ctx_uvar_typedness_deps : - FStar_Syntax_Syntax.ctx_uvar -> FStar_Syntax_Syntax.ctx_uvar Prims.list) = - fun u -> - let uu___ = - FStar_Syntax_Unionfind.find_decoration - u.FStar_Syntax_Syntax.ctx_uvar_head in - uu___.FStar_Syntax_Syntax.uvar_decoration_typedness_depends_on -let (flatten_refinement : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun t -> - let rec aux t1 unascribe1 = - let t2 = FStar_Syntax_Subst.compress t1 in - match t2.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t3; FStar_Syntax_Syntax.asc = uu___; - FStar_Syntax_Syntax.eff_opt = uu___1;_} - when unascribe1 -> aux t3 true - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x; FStar_Syntax_Syntax.phi = phi;_} -> - let t0 = aux x.FStar_Syntax_Syntax.sort true in - (match t0.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = y; FStar_Syntax_Syntax.phi = phi1;_} - -> - let uu___ = - let uu___1 = - let uu___2 = mk_conj_simp phi1 phi in - { - FStar_Syntax_Syntax.b = y; - FStar_Syntax_Syntax.phi = uu___2 - } in - FStar_Syntax_Syntax.Tm_refine uu___1 in - FStar_Syntax_Syntax.mk uu___ t0.FStar_Syntax_Syntax.pos - | uu___ -> t2) - | uu___ -> t2 in - aux t false -let (contains_strictly_positive_attribute : - FStar_Syntax_Syntax.attribute Prims.list -> Prims.bool) = - fun attrs -> - has_attribute attrs FStar_Parser_Const.binder_strictly_positive_attr -let (contains_unused_attribute : - FStar_Syntax_Syntax.attribute Prims.list -> Prims.bool) = - fun attrs -> has_attribute attrs FStar_Parser_Const.binder_unused_attr -let (parse_positivity_attributes : - FStar_Syntax_Syntax.attribute Prims.list -> - (FStar_Syntax_Syntax.positivity_qualifier FStar_Pervasives_Native.option - * FStar_Syntax_Syntax.attribute Prims.list)) - = - fun attrs -> - let uu___ = contains_unused_attribute attrs in - if uu___ - then - ((FStar_Pervasives_Native.Some FStar_Syntax_Syntax.BinderUnused), - attrs) - else - (let uu___2 = contains_strictly_positive_attribute attrs in - if uu___2 - then - ((FStar_Pervasives_Native.Some - FStar_Syntax_Syntax.BinderStrictlyPositive), attrs) - else (FStar_Pervasives_Native.None, attrs)) -let (encode_positivity_attributes : - FStar_Syntax_Syntax.positivity_qualifier FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.attribute Prims.list -> - FStar_Syntax_Syntax.attribute Prims.list) - = - fun pqual -> - fun attrs -> - match pqual with - | FStar_Pervasives_Native.None -> attrs - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.BinderStrictlyPositive) -> - let uu___ = contains_strictly_positive_attribute attrs in - if uu___ - then attrs - else - (let uu___2 = - let uu___3 = - FStar_Syntax_Syntax.lid_as_fv - FStar_Parser_Const.binder_strictly_positive_attr - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___3 in - uu___2 :: attrs) - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.BinderUnused) -> - let uu___ = contains_unused_attribute attrs in - if uu___ - then attrs - else - (let uu___2 = - let uu___3 = - FStar_Syntax_Syntax.lid_as_fv - FStar_Parser_Const.binder_unused_attr - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___3 in - uu___2 :: attrs) -let (is_binder_strictly_positive : FStar_Syntax_Syntax.binder -> Prims.bool) - = - fun b -> - b.FStar_Syntax_Syntax.binder_positivity = - (FStar_Pervasives_Native.Some - FStar_Syntax_Syntax.BinderStrictlyPositive) -let (is_binder_unused : FStar_Syntax_Syntax.binder -> Prims.bool) = - fun b -> - b.FStar_Syntax_Syntax.binder_positivity = - (FStar_Pervasives_Native.Some FStar_Syntax_Syntax.BinderUnused) -let (deduplicate_terms : - FStar_Syntax_Syntax.term Prims.list -> FStar_Syntax_Syntax.term Prims.list) - = - fun l -> FStar_Compiler_List.deduplicate (fun x -> fun y -> term_eq x y) l -let (eq_binding : - FStar_Syntax_Syntax.binding -> FStar_Syntax_Syntax.binding -> Prims.bool) = - fun b1 -> - fun b2 -> - match (b1, b2) with - | (FStar_Syntax_Syntax.Binding_var bv1, FStar_Syntax_Syntax.Binding_var - bv2) -> - (FStar_Syntax_Syntax.bv_eq bv1 bv2) && - (term_eq bv1.FStar_Syntax_Syntax.sort - bv2.FStar_Syntax_Syntax.sort) - | (FStar_Syntax_Syntax.Binding_lid (lid1, uu___), - FStar_Syntax_Syntax.Binding_lid (lid2, uu___1)) -> - FStar_Ident.lid_equals lid1 lid2 - | (FStar_Syntax_Syntax.Binding_univ u1, - FStar_Syntax_Syntax.Binding_univ u2) -> - FStar_Ident.ident_equals u1 u2 - | uu___ -> false \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_Visit.ml b/ocaml/fstar-lib/generated/FStar_Syntax_Visit.ml deleted file mode 100644 index 45f42edec3f..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Syntax_Visit.ml +++ /dev/null @@ -1,84 +0,0 @@ -open Prims -type 'a id = - | I of 'a -let uu___is_I : 'a . 'a id -> Prims.bool = fun projectee -> true -let __proj__I__item__run : 'a . 'a id -> 'a = - fun projectee -> match projectee with | I run -> run -let (uu___0 : unit id FStar_Class_Monad.monad) = - { - FStar_Class_Monad.return = - (fun uu___1 -> - fun uu___ -> (fun a -> fun a1 -> Obj.magic (I a1)) uu___1 uu___); - FStar_Class_Monad.op_let_Bang = - (fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun a -> - fun b -> - fun uu___ -> - let uu___ = Obj.magic uu___ in - fun f -> - let f = Obj.magic f in - match uu___ with | I a1 -> Obj.magic (f a1)) uu___3 - uu___2 uu___1 uu___) - } -let op_Less_Less : - 'uuuuu 'uuuuu1 'uuuuu2 . - ('uuuuu -> 'uuuuu1) -> ('uuuuu2 -> 'uuuuu) -> 'uuuuu2 -> 'uuuuu1 - = fun f -> fun g -> fun x -> let uu___ = g x in f uu___ -let (visit_term : - Prims.bool -> - (FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun pq -> - fun vt -> - fun t -> - let uu___ = - Obj.magic - (FStar_Syntax_VisitM.visitM_term uu___0 pq - (fun uu___1 -> - (Obj.magic (op_Less_Less (fun uu___1 -> I uu___1) vt)) - uu___1) t) in - __proj__I__item__run uu___ -let (visit_term_univs : - Prims.bool -> - (FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) -> - (FStar_Syntax_Syntax.universe -> FStar_Syntax_Syntax.universe) -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun pq -> - fun vt -> - fun vu -> - fun t -> - let uu___ = - Obj.magic - (FStar_Syntax_VisitM.visitM_term_univs uu___0 pq - (fun uu___1 -> - (Obj.magic (op_Less_Less (fun uu___1 -> I uu___1) vt)) - uu___1) - (fun uu___1 -> - (Obj.magic (op_Less_Less (fun uu___1 -> I uu___1) vu)) - uu___1) t) in - __proj__I__item__run uu___ -let (visit_sigelt : - Prims.bool -> - (FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) -> - (FStar_Syntax_Syntax.universe -> FStar_Syntax_Syntax.universe) -> - FStar_Syntax_Syntax.sigelt -> FStar_Syntax_Syntax.sigelt) - = - fun pq -> - fun vt -> - fun vu -> - fun se -> - let uu___ = - Obj.magic - (FStar_Syntax_VisitM.visitM_sigelt uu___0 pq - (fun uu___1 -> - (Obj.magic (op_Less_Less (fun uu___1 -> I uu___1) vt)) - uu___1) - (fun uu___1 -> - (Obj.magic (op_Less_Less (fun uu___1 -> I uu___1) vu)) - uu___1) se) in - __proj__I__item__run uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Syntax_VisitM.ml b/ocaml/fstar-lib/generated/FStar_Syntax_VisitM.ml deleted file mode 100644 index 4c506becca3..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Syntax_VisitM.ml +++ /dev/null @@ -1,2293 +0,0 @@ -open Prims -type ('m, 'a) endo = 'a -> 'm -type 'm lvm = - { - lvm_monad: 'm FStar_Class_Monad.monad ; - f_term: ('m, FStar_Syntax_Syntax.term) endo ; - f_binder: ('m, FStar_Syntax_Syntax.binder) endo ; - f_binding_bv: ('m, FStar_Syntax_Syntax.bv) endo ; - f_br: ('m, FStar_Syntax_Syntax.branch) endo ; - f_comp: ('m, FStar_Syntax_Syntax.comp) endo ; - f_residual_comp: ('m, FStar_Syntax_Syntax.residual_comp) endo ; - f_univ: ('m, FStar_Syntax_Syntax.universe) endo ; - proc_quotes: Prims.bool } -let __proj__Mklvm__item__lvm_monad : - 'm . 'm lvm -> 'm FStar_Class_Monad.monad = - fun projectee -> - match projectee with - | { lvm_monad; f_term; f_binder; f_binding_bv; f_br; f_comp; - f_residual_comp; f_univ; proc_quotes;_} -> lvm_monad -let __proj__Mklvm__item__f_term : - 'm . 'm lvm -> ('m, FStar_Syntax_Syntax.term) endo = - fun projectee -> - match projectee with - | { lvm_monad; f_term; f_binder; f_binding_bv; f_br; f_comp; - f_residual_comp; f_univ; proc_quotes;_} -> f_term -let __proj__Mklvm__item__f_binder : - 'm . 'm lvm -> ('m, FStar_Syntax_Syntax.binder) endo = - fun projectee -> - match projectee with - | { lvm_monad; f_term; f_binder; f_binding_bv; f_br; f_comp; - f_residual_comp; f_univ; proc_quotes;_} -> f_binder -let __proj__Mklvm__item__f_binding_bv : - 'm . 'm lvm -> ('m, FStar_Syntax_Syntax.bv) endo = - fun projectee -> - match projectee with - | { lvm_monad; f_term; f_binder; f_binding_bv; f_br; f_comp; - f_residual_comp; f_univ; proc_quotes;_} -> f_binding_bv -let __proj__Mklvm__item__f_br : - 'm . 'm lvm -> ('m, FStar_Syntax_Syntax.branch) endo = - fun projectee -> - match projectee with - | { lvm_monad; f_term; f_binder; f_binding_bv; f_br; f_comp; - f_residual_comp; f_univ; proc_quotes;_} -> f_br -let __proj__Mklvm__item__f_comp : - 'm . 'm lvm -> ('m, FStar_Syntax_Syntax.comp) endo = - fun projectee -> - match projectee with - | { lvm_monad; f_term; f_binder; f_binding_bv; f_br; f_comp; - f_residual_comp; f_univ; proc_quotes;_} -> f_comp -let __proj__Mklvm__item__f_residual_comp : - 'm . 'm lvm -> ('m, FStar_Syntax_Syntax.residual_comp) endo = - fun projectee -> - match projectee with - | { lvm_monad; f_term; f_binder; f_binding_bv; f_br; f_comp; - f_residual_comp; f_univ; proc_quotes;_} -> f_residual_comp -let __proj__Mklvm__item__f_univ : - 'm . 'm lvm -> ('m, FStar_Syntax_Syntax.universe) endo = - fun projectee -> - match projectee with - | { lvm_monad; f_term; f_binder; f_binding_bv; f_br; f_comp; - f_residual_comp; f_univ; proc_quotes;_} -> f_univ -let __proj__Mklvm__item__proc_quotes : 'm . 'm lvm -> Prims.bool = - fun projectee -> - match projectee with - | { lvm_monad; f_term; f_binder; f_binding_bv; f_br; f_comp; - f_residual_comp; f_univ; proc_quotes;_} -> proc_quotes -let lvm_monad : 'm . 'm lvm -> 'm FStar_Class_Monad.monad = - fun projectee -> - match projectee with - | { lvm_monad = lvm_monad1; f_term; f_binder; f_binding_bv; f_br; - f_comp; f_residual_comp; f_univ; proc_quotes;_} -> lvm_monad1 -let f_term : 'm . 'm lvm -> ('m, FStar_Syntax_Syntax.term) endo = - fun projectee -> - match projectee with - | { lvm_monad = lvm_monad1; f_term = f_term1; f_binder; f_binding_bv; - f_br; f_comp; f_residual_comp; f_univ; proc_quotes;_} -> f_term1 -let f_binder : 'm . 'm lvm -> ('m, FStar_Syntax_Syntax.binder) endo = - fun projectee -> - match projectee with - | { lvm_monad = lvm_monad1; f_term = f_term1; f_binder = f_binder1; - f_binding_bv; f_br; f_comp; f_residual_comp; f_univ; proc_quotes;_} - -> f_binder1 -let f_binding_bv : 'm . 'm lvm -> ('m, FStar_Syntax_Syntax.bv) endo = - fun projectee -> - match projectee with - | { lvm_monad = lvm_monad1; f_term = f_term1; f_binder = f_binder1; - f_binding_bv = f_binding_bv1; f_br; f_comp; f_residual_comp; - f_univ; proc_quotes;_} -> f_binding_bv1 -let f_br : 'm . 'm lvm -> ('m, FStar_Syntax_Syntax.branch) endo = - fun projectee -> - match projectee with - | { lvm_monad = lvm_monad1; f_term = f_term1; f_binder = f_binder1; - f_binding_bv = f_binding_bv1; f_br = f_br1; f_comp; f_residual_comp; - f_univ; proc_quotes;_} -> f_br1 -let f_comp : 'm . 'm lvm -> ('m, FStar_Syntax_Syntax.comp) endo = - fun projectee -> - match projectee with - | { lvm_monad = lvm_monad1; f_term = f_term1; f_binder = f_binder1; - f_binding_bv = f_binding_bv1; f_br = f_br1; f_comp = f_comp1; - f_residual_comp; f_univ; proc_quotes;_} -> f_comp1 -let f_residual_comp : - 'm . 'm lvm -> ('m, FStar_Syntax_Syntax.residual_comp) endo = - fun projectee -> - match projectee with - | { lvm_monad = lvm_monad1; f_term = f_term1; f_binder = f_binder1; - f_binding_bv = f_binding_bv1; f_br = f_br1; f_comp = f_comp1; - f_residual_comp = f_residual_comp1; f_univ; proc_quotes;_} -> - f_residual_comp1 -let f_univ : 'm . 'm lvm -> ('m, FStar_Syntax_Syntax.universe) endo = - fun projectee -> - match projectee with - | { lvm_monad = lvm_monad1; f_term = f_term1; f_binder = f_binder1; - f_binding_bv = f_binding_bv1; f_br = f_br1; f_comp = f_comp1; - f_residual_comp = f_residual_comp1; f_univ = f_univ1; proc_quotes;_} - -> f_univ1 -let proc_quotes : 'm . 'm lvm -> Prims.bool = - fun projectee -> - match projectee with - | { lvm_monad = lvm_monad1; f_term = f_term1; f_binder = f_binder1; - f_binding_bv = f_binding_bv1; f_br = f_br1; f_comp = f_comp1; - f_residual_comp = f_residual_comp1; f_univ = f_univ1; - proc_quotes = proc_quotes1;_} -> proc_quotes1 -let _lvm_monad : 'm . 'm lvm -> 'm FStar_Class_Monad.monad = - fun uu___ -> lvm_monad uu___ -let novfs : 'm . 'm FStar_Class_Monad.monad -> 'm lvm = - fun uu___ -> - { - lvm_monad = uu___; - f_term = (Obj.magic (FStar_Class_Monad.return uu___ ())); - f_binder = (Obj.magic (FStar_Class_Monad.return uu___ ())); - f_binding_bv = (Obj.magic (FStar_Class_Monad.return uu___ ())); - f_br = (Obj.magic (FStar_Class_Monad.return uu___ ())); - f_comp = (Obj.magic (FStar_Class_Monad.return uu___ ())); - f_residual_comp = (Obj.magic (FStar_Class_Monad.return uu___ ())); - f_univ = (Obj.magic (FStar_Class_Monad.return uu___ ())); - proc_quotes = false - } -let f_aqual : 'm . 'm lvm -> FStar_Syntax_Syntax.arg_qualifier -> 'm = - fun uu___ -> - fun aq -> - let uu___1 = aq in - match uu___1 with - | { FStar_Syntax_Syntax.aqual_implicit = i; - FStar_Syntax_Syntax.aqual_attributes = attrs;_} -> - let uu___2 = - FStar_Class_Monad.mapM (_lvm_monad uu___) () () - (fun uu___3 -> (Obj.magic (f_term uu___)) uu___3) - (Obj.magic attrs) in - FStar_Class_Monad.op_let_Bang (_lvm_monad uu___) () () uu___2 - (fun uu___3 -> - (fun attrs1 -> - let attrs1 = Obj.magic attrs1 in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad uu___) () - (Obj.magic - { - FStar_Syntax_Syntax.aqual_implicit = i; - FStar_Syntax_Syntax.aqual_attributes = attrs1 - }))) uu___3) -let on_sub_arg : 'm . 'm lvm -> FStar_Syntax_Syntax.arg -> 'm = - fun uu___ -> - fun a -> - let uu___1 = a in - match uu___1 with - | (t, q) -> - let uu___2 = f_term uu___ t in - FStar_Class_Monad.op_let_Bang (_lvm_monad uu___) () () uu___2 - (fun uu___3 -> - (fun t1 -> - let t1 = Obj.magic t1 in - let uu___3 = - FStar_Class_Monad.map_optM (_lvm_monad uu___) () () - (fun uu___4 -> (Obj.magic (f_aqual uu___)) uu___4) - (Obj.magic q) in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad uu___) () () - uu___3 - (fun uu___4 -> - (fun q1 -> - let q1 = Obj.magic q1 in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad uu___) - () (Obj.magic (t1, q1)))) uu___4))) uu___3) -let on_sub_tscheme : - 'm . - 'm FStar_Class_Monad.monad -> 'm lvm -> FStar_Syntax_Syntax.tscheme -> 'm - = - fun uu___ -> - fun uu___1 -> - fun ts -> - let uu___2 = ts in - match uu___2 with - | (us, t) -> - let uu___3 = f_term uu___1 t in - FStar_Class_Monad.op_let_Bang uu___ () () uu___3 - (fun uu___4 -> - (fun t1 -> - let t1 = Obj.magic t1 in - Obj.magic - (FStar_Class_Monad.return uu___ () (Obj.magic (us, t1)))) - uu___4) -let f_arg : 'm . 'm lvm -> FStar_Syntax_Syntax.arg -> 'm = - fun uu___ -> on_sub_arg uu___ -let f_args : 'm . 'm lvm -> FStar_Syntax_Syntax.arg Prims.list -> 'm = - fun uu___1 -> - fun uu___ -> - (fun d -> - let uu___ = f_arg d in - Obj.magic - (FStar_Class_Monad.mapM (_lvm_monad d) () () - (fun uu___1 -> (Obj.magic uu___) uu___1))) uu___1 uu___ -let f_tscheme : 'm . 'm lvm -> FStar_Syntax_Syntax.tscheme -> 'm = - fun uu___ -> on_sub_tscheme (_lvm_monad uu___) uu___ -let on_sub_meta : 'm . 'm lvm -> FStar_Syntax_Syntax.metadata -> 'm = - fun d -> - fun md -> - match md with - | FStar_Syntax_Syntax.Meta_pattern (pats, args) -> - let uu___ = - FStar_Class_Monad.mapM (_lvm_monad d) () () - (fun uu___1 -> (Obj.magic (f_term d)) uu___1) (Obj.magic pats) in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun pats1 -> - let pats1 = Obj.magic pats1 in - let uu___1 = - let uu___2 = f_args d in - FStar_Class_Monad.mapM (_lvm_monad d) () () - (fun uu___3 -> (Obj.magic uu___2) uu___3) - (Obj.magic args) in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () - uu___1 - (fun uu___2 -> - (fun args1 -> - let args1 = Obj.magic args1 in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic - (FStar_Syntax_Syntax.Meta_pattern - (pats1, args1))))) uu___2))) uu___1) - | FStar_Syntax_Syntax.Meta_monadic (m1, typ) -> - let uu___ = f_term d typ in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun typ1 -> - let typ1 = Obj.magic typ1 in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic - (FStar_Syntax_Syntax.Meta_monadic (m1, typ1))))) - uu___1) - | FStar_Syntax_Syntax.Meta_monadic_lift (m1, m2, typ) -> - let uu___ = f_term d typ in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun typ1 -> - let typ1 = Obj.magic typ1 in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic - (FStar_Syntax_Syntax.Meta_monadic_lift - (m1, m2, typ1))))) uu___1) - | FStar_Syntax_Syntax.Meta_named lid -> - FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic (FStar_Syntax_Syntax.Meta_named lid)) - | FStar_Syntax_Syntax.Meta_labeled (s, r, b) -> - FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic (FStar_Syntax_Syntax.Meta_labeled (s, r, b))) - | FStar_Syntax_Syntax.Meta_desugared i -> - FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic (FStar_Syntax_Syntax.Meta_desugared i)) -let on_sub_letbinding : 'm . 'm lvm -> FStar_Syntax_Syntax.letbinding -> 'm = - fun uu___ -> - fun lb -> - let uu___1 = - match lb.FStar_Syntax_Syntax.lbname with - | FStar_Pervasives.Inl bv -> - let uu___2 = f_binding_bv uu___ bv in - FStar_Class_Monad.op_Less_Dollar_Greater (_lvm_monad uu___) () () - (fun uu___3 -> - (fun uu___3 -> - let uu___3 = Obj.magic uu___3 in - Obj.magic (FStar_Pervasives.Inl uu___3)) uu___3) uu___2 - | FStar_Pervasives.Inr fv -> - FStar_Class_Monad.return (_lvm_monad uu___) () - (Obj.magic (FStar_Pervasives.Inr fv)) in - FStar_Class_Monad.op_let_Bang (_lvm_monad uu___) () () uu___1 - (fun uu___2 -> - (fun lbname -> - let lbname = Obj.magic lbname in - let lbunivs = lb.FStar_Syntax_Syntax.lbunivs in - let uu___2 = f_term uu___ lb.FStar_Syntax_Syntax.lbtyp in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad uu___) () () - uu___2 - (fun uu___3 -> - (fun lbtyp -> - let lbtyp = Obj.magic lbtyp in - let lbeff = lb.FStar_Syntax_Syntax.lbeff in - let uu___3 = - FStar_Class_Monad.mapM (_lvm_monad uu___) () () - (fun uu___4 -> (Obj.magic (f_term uu___)) uu___4) - (Obj.magic lb.FStar_Syntax_Syntax.lbattrs) in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad uu___) - () () uu___3 - (fun uu___4 -> - (fun lbattrs -> - let lbattrs = Obj.magic lbattrs in - let lbpos = lb.FStar_Syntax_Syntax.lbpos in - let uu___4 = - f_term uu___ - lb.FStar_Syntax_Syntax.lbdef in - Obj.magic - (FStar_Class_Monad.op_let_Bang - (_lvm_monad uu___) () () uu___4 - (fun uu___5 -> - (fun lbdef -> - let lbdef = Obj.magic lbdef in - Obj.magic - (FStar_Class_Monad.return - (_lvm_monad uu___) () - (Obj.magic - { - FStar_Syntax_Syntax.lbname - = lbname; - FStar_Syntax_Syntax.lbunivs - = lbunivs; - FStar_Syntax_Syntax.lbtyp - = lbtyp; - FStar_Syntax_Syntax.lbeff - = lbeff; - FStar_Syntax_Syntax.lbdef - = lbdef; - FStar_Syntax_Syntax.lbattrs - = lbattrs; - FStar_Syntax_Syntax.lbpos - = lbpos - }))) uu___5))) uu___4))) - uu___3))) uu___2) -let on_sub_ascription : 'm . 'm lvm -> FStar_Syntax_Syntax.ascription -> 'm = - fun uu___ -> - fun a -> - let uu___1 = a in - match uu___1 with - | (tc, tacopt, b) -> - let uu___2 = - match tc with - | FStar_Pervasives.Inl t -> - let uu___3 = f_term uu___ t in - FStar_Class_Monad.op_Less_Dollar_Greater (_lvm_monad uu___) - () () - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - Obj.magic (FStar_Pervasives.Inl uu___4)) uu___4) - uu___3 - | FStar_Pervasives.Inr c -> - let uu___3 = f_comp uu___ c in - FStar_Class_Monad.op_Less_Dollar_Greater (_lvm_monad uu___) - () () - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - Obj.magic (FStar_Pervasives.Inr uu___4)) uu___4) - uu___3 in - FStar_Class_Monad.op_let_Bang (_lvm_monad uu___) () () uu___2 - (fun uu___3 -> - (fun tc1 -> - let tc1 = Obj.magic tc1 in - let uu___3 = - FStar_Class_Monad.map_optM (_lvm_monad uu___) () () - (fun uu___4 -> (Obj.magic (f_term uu___)) uu___4) - (Obj.magic tacopt) in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad uu___) () () - uu___3 - (fun uu___4 -> - (fun tacopt1 -> - let tacopt1 = Obj.magic tacopt1 in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad uu___) - () (Obj.magic (tc1, tacopt1, b)))) uu___4))) - uu___3) -let rec (compress : FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = - fun tm -> - let tm1 = FStar_Syntax_Subst.compress tm in - match tm1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_lazy li -> - let tm' = - let uu___ = - let uu___1 = - FStar_Compiler_Effect.op_Bang FStar_Syntax_Syntax.lazy_chooser in - FStar_Compiler_Util.must uu___1 in - uu___ li.FStar_Syntax_Syntax.lkind li in - compress tm' - | uu___ -> tm1 -let on_sub_term : 'm . 'm lvm -> FStar_Syntax_Syntax.term -> 'm = - fun d -> - fun tm -> - let mk t = FStar_Syntax_Syntax.mk t tm.FStar_Syntax_Syntax.pos in - let tm1 = compress tm in - match tm1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_lazy uu___ -> failwith "impos" - | FStar_Syntax_Syntax.Tm_delayed uu___ -> failwith "impos" - | FStar_Syntax_Syntax.Tm_fvar uu___ -> - FStar_Class_Monad.return (_lvm_monad d) () (Obj.magic tm1) - | FStar_Syntax_Syntax.Tm_constant uu___ -> - FStar_Class_Monad.return (_lvm_monad d) () (Obj.magic tm1) - | FStar_Syntax_Syntax.Tm_unknown -> - FStar_Class_Monad.return (_lvm_monad d) () (Obj.magic tm1) - | FStar_Syntax_Syntax.Tm_bvar uu___ -> - FStar_Class_Monad.return (_lvm_monad d) () (Obj.magic tm1) - | FStar_Syntax_Syntax.Tm_name uu___ -> - FStar_Class_Monad.return (_lvm_monad d) () (Obj.magic tm1) - | FStar_Syntax_Syntax.Tm_uvar uu___ -> - FStar_Class_Monad.return (_lvm_monad d) () (Obj.magic tm1) - | FStar_Syntax_Syntax.Tm_uinst (f, us) -> - let uu___ = f_term d f in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun f1 -> - let f1 = Obj.magic f1 in - let uu___1 = - FStar_Class_Monad.mapM (_lvm_monad d) () () - (fun uu___2 -> (Obj.magic (f_univ d)) uu___2) - (Obj.magic us) in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () - uu___1 - (fun uu___2 -> - (fun us1 -> - let us1 = Obj.magic us1 in - let uu___2 = - mk (FStar_Syntax_Syntax.Tm_uinst (f1, us1)) in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic uu___2))) uu___2))) uu___1) - | FStar_Syntax_Syntax.Tm_type u -> - let uu___ = f_univ d u in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun u1 -> - let u1 = Obj.magic u1 in - let uu___1 = mk (FStar_Syntax_Syntax.Tm_type u1) in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic uu___1))) uu___1) - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = hd; FStar_Syntax_Syntax.args = args;_} - -> - let uu___ = f_term d hd in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun hd1 -> - let hd1 = Obj.magic hd1 in - let uu___1 = - let uu___2 = f_arg d in - FStar_Class_Monad.mapM (_lvm_monad d) () () - (fun uu___3 -> (Obj.magic uu___2) uu___3) - (Obj.magic args) in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () - uu___1 - (fun uu___2 -> - (fun args1 -> - let args1 = Obj.magic args1 in - let uu___2 = - mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = hd1; - FStar_Syntax_Syntax.args = args1 - }) in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic uu___2))) uu___2))) uu___1) - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs; FStar_Syntax_Syntax.body = t; - FStar_Syntax_Syntax.rc_opt = rc_opt;_} - -> - let uu___ = - FStar_Class_Monad.mapM (_lvm_monad d) () () - (fun uu___1 -> (Obj.magic (f_binder d)) uu___1) (Obj.magic bs) in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun bs1 -> - let bs1 = Obj.magic bs1 in - let uu___1 = f_term d t in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () - uu___1 - (fun uu___2 -> - (fun t1 -> - let t1 = Obj.magic t1 in - let uu___2 = - FStar_Class_Monad.map_optM (_lvm_monad d) () - () - (fun uu___3 -> - (Obj.magic (f_residual_comp d)) uu___3) - (Obj.magic rc_opt) in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) - () () uu___2 - (fun uu___3 -> - (fun rc_opt1 -> - let rc_opt1 = Obj.magic rc_opt1 in - let uu___3 = - mk - (FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = bs1; - FStar_Syntax_Syntax.body = - t1; - FStar_Syntax_Syntax.rc_opt = - rc_opt1 - }) in - Obj.magic - (FStar_Class_Monad.return - (_lvm_monad d) () - (Obj.magic uu___3))) uu___3))) - uu___2))) uu___1) - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; FStar_Syntax_Syntax.comp = c;_} -> - let uu___ = - FStar_Class_Monad.mapM (_lvm_monad d) () () - (fun uu___1 -> (Obj.magic (f_binder d)) uu___1) (Obj.magic bs) in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun bs1 -> - let bs1 = Obj.magic bs1 in - let uu___1 = f_comp d c in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () - uu___1 - (fun uu___2 -> - (fun c1 -> - let c1 = Obj.magic c1 in - let uu___2 = - mk - (FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 = bs1; - FStar_Syntax_Syntax.comp = c1 - }) in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic uu___2))) uu___2))) uu___1) - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = bv; FStar_Syntax_Syntax.phi = phi;_} -> - let uu___ = f_binding_bv d bv in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun bv1 -> - let bv1 = Obj.magic bv1 in - let uu___1 = f_term d phi in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () - uu___1 - (fun uu___2 -> - (fun phi1 -> - let phi1 = Obj.magic phi1 in - let uu___2 = - mk - (FStar_Syntax_Syntax.Tm_refine - { - FStar_Syntax_Syntax.b = bv1; - FStar_Syntax_Syntax.phi = phi1 - }) in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic uu___2))) uu___2))) uu___1) - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = sc; - FStar_Syntax_Syntax.ret_opt = asc_opt; - FStar_Syntax_Syntax.brs = brs; - FStar_Syntax_Syntax.rc_opt1 = rc_opt;_} - -> - let uu___ = f_term d sc in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun sc1 -> - let sc1 = Obj.magic sc1 in - let uu___1 = - FStar_Class_Monad.map_optM (_lvm_monad d) () () - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - match uu___2 with - | (b, asc) -> - let uu___3 = - let uu___4 = f_binder d b in - FStar_Class_Monad.op_Less_Dollar_Greater - (_lvm_monad d) () () - (fun uu___5 -> - (fun uu___5 -> - let uu___5 = Obj.magic uu___5 in - Obj.magic - (fun uu___6 -> (uu___5, uu___6))) - uu___5) uu___4 in - let uu___4 = on_sub_ascription d asc in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - (_lvm_monad d) () () uu___3 uu___4)) - uu___2) (Obj.magic asc_opt) in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () - uu___1 - (fun uu___2 -> - (fun asc_opt1 -> - let asc_opt1 = Obj.magic asc_opt1 in - let uu___2 = - FStar_Class_Monad.mapM (_lvm_monad d) () () - (fun uu___3 -> (Obj.magic (f_br d)) uu___3) - (Obj.magic brs) in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) - () () uu___2 - (fun uu___3 -> - (fun brs1 -> - let brs1 = Obj.magic brs1 in - let uu___3 = - FStar_Class_Monad.map_optM - (_lvm_monad d) () () - (fun uu___4 -> - (Obj.magic (f_residual_comp d)) - uu___4) (Obj.magic rc_opt) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - (_lvm_monad d) () () uu___3 - (fun uu___4 -> - (fun rc_opt1 -> - let rc_opt1 = - Obj.magic rc_opt1 in - let uu___4 = - mk - (FStar_Syntax_Syntax.Tm_match - { - FStar_Syntax_Syntax.scrutinee - = sc1; - FStar_Syntax_Syntax.ret_opt - = asc_opt1; - FStar_Syntax_Syntax.brs - = brs1; - FStar_Syntax_Syntax.rc_opt1 - = rc_opt1 - }) in - Obj.magic - (FStar_Class_Monad.return - (_lvm_monad d) () - (Obj.magic uu___4))) - uu___4))) uu___3))) uu___2))) - uu___1) - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = e; FStar_Syntax_Syntax.asc = a; - FStar_Syntax_Syntax.eff_opt = lopt;_} - -> - let uu___ = f_term d e in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun e1 -> - let e1 = Obj.magic e1 in - let uu___1 = on_sub_ascription d a in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () - uu___1 - (fun uu___2 -> - (fun a1 -> - let a1 = Obj.magic a1 in - let uu___2 = - mk - (FStar_Syntax_Syntax.Tm_ascribed - { - FStar_Syntax_Syntax.tm = e1; - FStar_Syntax_Syntax.asc = a1; - FStar_Syntax_Syntax.eff_opt = lopt - }) in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic uu___2))) uu___2))) uu___1) - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (is_rec, lbs); - FStar_Syntax_Syntax.body1 = t;_} - -> - let uu___ = - FStar_Class_Monad.mapM (_lvm_monad d) () () - (fun uu___1 -> (Obj.magic (on_sub_letbinding d)) uu___1) - (Obj.magic lbs) in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun lbs1 -> - let lbs1 = Obj.magic lbs1 in - let uu___1 = f_term d t in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () - uu___1 - (fun uu___2 -> - (fun t1 -> - let t1 = Obj.magic t1 in - let uu___2 = - mk - (FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = - (is_rec, lbs1); - FStar_Syntax_Syntax.body1 = t1 - }) in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic uu___2))) uu___2))) uu___1) - | FStar_Syntax_Syntax.Tm_quoted (qtm, qi) -> - if - d.proc_quotes || - (qi.FStar_Syntax_Syntax.qkind = - FStar_Syntax_Syntax.Quote_dynamic) - then - let uu___ = f_term d qtm in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun qtm1 -> - let qtm1 = Obj.magic qtm1 in - let uu___1 = - mk (FStar_Syntax_Syntax.Tm_quoted (qtm1, qi)) in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic uu___1))) uu___1) - else FStar_Class_Monad.return (_lvm_monad d) () (Obj.magic tm1) - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t; FStar_Syntax_Syntax.meta = md;_} -> - let uu___ = f_term d t in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun t1 -> - let t1 = Obj.magic t1 in - let uu___1 = on_sub_meta d md in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () - uu___1 - (fun uu___2 -> - (fun md1 -> - let md1 = Obj.magic md1 in - let uu___2 = - mk - (FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 = t1; - FStar_Syntax_Syntax.meta = md1 - }) in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic uu___2))) uu___2))) uu___1) -let on_sub_binding_bv : 'm . 'm lvm -> FStar_Syntax_Syntax.bv -> 'm = - fun d -> - fun x -> - let uu___ = f_term d x.FStar_Syntax_Syntax.sort in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun sort -> - let sort = Obj.magic sort in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic - { - FStar_Syntax_Syntax.ppname = - (x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (x.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = sort - }))) uu___1) -let on_sub_binder : 'm . 'm lvm -> FStar_Syntax_Syntax.binder -> 'm = - fun d -> - fun b -> - let uu___ = f_binding_bv d b.FStar_Syntax_Syntax.binder_bv in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun binder_bv -> - let binder_bv = Obj.magic binder_bv in - let uu___1 = - FStar_Class_Monad.map_optM (_lvm_monad d) () () - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - match uu___2 with - | FStar_Syntax_Syntax.Meta t -> - let uu___3 = f_term d t in - Obj.magic - (FStar_Class_Monad.op_Less_Dollar_Greater - (_lvm_monad d) () () - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - Obj.magic - (FStar_Syntax_Syntax.Meta uu___4)) - uu___4) uu___3) - | q -> - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic q))) uu___2) - (Obj.magic b.FStar_Syntax_Syntax.binder_qual) in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___1 - (fun uu___2 -> - (fun binder_qual -> - let binder_qual = Obj.magic binder_qual in - let binder_positivity = - b.FStar_Syntax_Syntax.binder_positivity in - let uu___2 = - FStar_Class_Monad.mapM (_lvm_monad d) () () - (fun uu___3 -> (Obj.magic (f_term d)) uu___3) - (Obj.magic b.FStar_Syntax_Syntax.binder_attrs) in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) () - () uu___2 - (fun uu___3 -> - (fun binder_attrs -> - let binder_attrs = Obj.magic binder_attrs in - Obj.magic - (FStar_Class_Monad.return - (_lvm_monad d) () - (Obj.magic - { - FStar_Syntax_Syntax.binder_bv = - binder_bv; - FStar_Syntax_Syntax.binder_qual - = binder_qual; - FStar_Syntax_Syntax.binder_positivity - = binder_positivity; - FStar_Syntax_Syntax.binder_attrs - = binder_attrs - }))) uu___3))) uu___2))) uu___1) -let rec on_sub_pat : 'm . 'm lvm -> FStar_Syntax_Syntax.pat -> 'm = - fun d -> - fun p0 -> - let mk p = - { - FStar_Syntax_Syntax.v = p; - FStar_Syntax_Syntax.p = (p0.FStar_Syntax_Syntax.p) - } in - match p0.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_constant uu___ -> - FStar_Class_Monad.return (_lvm_monad d) () (Obj.magic p0) - | FStar_Syntax_Syntax.Pat_cons (fv, us, subpats) -> - let uu___ = - FStar_Class_Monad.map_optM (_lvm_monad d) () () - (fun uu___1 -> - (Obj.magic - (FStar_Class_Monad.mapM (_lvm_monad d) () () - (fun uu___1 -> (Obj.magic (f_univ d)) uu___1))) uu___1) - (Obj.magic us) in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun us1 -> - let us1 = Obj.magic us1 in - let uu___1 = - FStar_Class_Monad.mapM (_lvm_monad d) () () - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - match uu___2 with - | (p, b) -> - let uu___3 = - let uu___4 = on_sub_pat d p in - FStar_Class_Monad.op_Less_Dollar_Greater - (_lvm_monad d) () () - (fun uu___5 -> - (fun uu___5 -> - let uu___5 = Obj.magic uu___5 in - Obj.magic - (fun uu___6 -> (uu___5, uu___6))) - uu___5) uu___4 in - let uu___4 = - FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic b) in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - (_lvm_monad d) () () uu___3 uu___4)) - uu___2) (Obj.magic subpats) in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () - uu___1 - (fun uu___2 -> - (fun subpats1 -> - let subpats1 = Obj.magic subpats1 in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic - (mk - (FStar_Syntax_Syntax.Pat_cons - (fv, us1, subpats1)))))) uu___2))) - uu___1) - | FStar_Syntax_Syntax.Pat_var bv -> - let uu___ = f_binding_bv d bv in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun bv1 -> - let bv1 = Obj.magic bv1 in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic (mk (FStar_Syntax_Syntax.Pat_var bv1))))) - uu___1) - | FStar_Syntax_Syntax.Pat_dot_term t -> - let uu___ = - FStar_Class_Monad.map_optM (_lvm_monad d) () () - (fun uu___1 -> (Obj.magic (f_term d)) uu___1) (Obj.magic t) in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun t1 -> - let t1 = Obj.magic t1 in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic (mk (FStar_Syntax_Syntax.Pat_dot_term t1))))) - uu___1) -let on_sub_br : - 'm . - 'm lvm -> - (FStar_Syntax_Syntax.pat * FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option * FStar_Syntax_Syntax.term) -> - 'm - = - fun d -> - fun br -> - let uu___ = br in - match uu___ with - | (pat, wopt, body) -> - let uu___1 = on_sub_pat d pat in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___1 - (fun uu___2 -> - (fun pat1 -> - let pat1 = Obj.magic pat1 in - let uu___2 = - FStar_Class_Monad.map_optM (_lvm_monad d) () () - (fun uu___3 -> (Obj.magic (f_term d)) uu___3) - (Obj.magic wopt) in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () - uu___2 - (fun uu___3 -> - (fun wopt1 -> - let wopt1 = Obj.magic wopt1 in - let uu___3 = f_term d body in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) - () () uu___3 - (fun uu___4 -> - (fun body1 -> - let body1 = Obj.magic body1 in - Obj.magic - (FStar_Class_Monad.return - (_lvm_monad d) () - (Obj.magic (pat1, wopt1, body1)))) - uu___4))) uu___3))) uu___2) -let on_sub_comp_typ : 'm . 'm lvm -> FStar_Syntax_Syntax.comp_typ -> 'm = - fun d -> - fun ct -> - let uu___ = - FStar_Class_Monad.mapM (_lvm_monad d) () () - (fun uu___1 -> (Obj.magic (f_univ d)) uu___1) - (Obj.magic ct.FStar_Syntax_Syntax.comp_univs) in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun comp_univs -> - let comp_univs = Obj.magic comp_univs in - let effect_name = ct.FStar_Syntax_Syntax.effect_name in - let uu___1 = f_term d ct.FStar_Syntax_Syntax.result_typ in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___1 - (fun uu___2 -> - (fun result_typ -> - let result_typ = Obj.magic result_typ in - let uu___2 = - let uu___3 = f_arg d in - FStar_Class_Monad.mapM (_lvm_monad d) () () - (fun uu___4 -> (Obj.magic uu___3) uu___4) - (Obj.magic ct.FStar_Syntax_Syntax.effect_args) in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) () - () uu___2 - (fun uu___3 -> - (fun effect_args -> - let effect_args = Obj.magic effect_args in - let flags = ct.FStar_Syntax_Syntax.flags in - Obj.magic - (FStar_Class_Monad.return - (_lvm_monad d) () - (Obj.magic - { - FStar_Syntax_Syntax.comp_univs - = comp_univs; - FStar_Syntax_Syntax.effect_name - = effect_name; - FStar_Syntax_Syntax.result_typ - = result_typ; - FStar_Syntax_Syntax.effect_args - = effect_args; - FStar_Syntax_Syntax.flags = - flags - }))) uu___3))) uu___2))) uu___1) -let on_sub_comp : - 'm . 'm lvm -> FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> 'm = - fun d -> - fun c -> - let uu___ = - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total typ -> - let uu___1 = f_term d typ in - FStar_Class_Monad.op_Less_Dollar_Greater (_lvm_monad d) () () - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - Obj.magic (FStar_Syntax_Syntax.Total uu___2)) uu___2) - uu___1 - | FStar_Syntax_Syntax.GTotal typ -> - let uu___1 = f_term d typ in - FStar_Class_Monad.op_Less_Dollar_Greater (_lvm_monad d) () () - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - Obj.magic (FStar_Syntax_Syntax.GTotal uu___2)) uu___2) - uu___1 - | FStar_Syntax_Syntax.Comp ct -> - let uu___1 = on_sub_comp_typ d ct in - FStar_Class_Monad.op_Less_Dollar_Greater (_lvm_monad d) () () - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - Obj.magic (FStar_Syntax_Syntax.Comp uu___2)) uu___2) - uu___1 in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun cn -> - let cn = Obj.magic cn in - let uu___1 = - FStar_Syntax_Syntax.mk cn c.FStar_Syntax_Syntax.pos in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic uu___1))) uu___1) -let __on_decreases : - 'm . - 'm lvm -> - (FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> 'm) -> - FStar_Syntax_Syntax.cflag -> 'm - = - fun d -> - fun f -> - fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.DECREASES (FStar_Syntax_Syntax.Decreases_lex l) - -> - let uu___1 = - let uu___2 = - FStar_Class_Monad.mapM (_lvm_monad d) () () - (fun uu___3 -> (Obj.magic f) uu___3) (Obj.magic l) in - FStar_Class_Monad.op_Less_Dollar_Greater (_lvm_monad d) () () - (fun uu___3 -> - (fun uu___3 -> - let uu___3 = Obj.magic uu___3 in - Obj.magic (FStar_Syntax_Syntax.Decreases_lex uu___3)) - uu___3) uu___2 in - FStar_Class_Monad.op_Less_Dollar_Greater (_lvm_monad d) () () - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - Obj.magic (FStar_Syntax_Syntax.DECREASES uu___2)) uu___2) - uu___1 - | FStar_Syntax_Syntax.DECREASES (FStar_Syntax_Syntax.Decreases_wf - (r, t)) -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = f r in - FStar_Class_Monad.op_Less_Dollar_Greater (_lvm_monad d) () - () - (fun uu___5 -> - (fun uu___5 -> - let uu___5 = Obj.magic uu___5 in - Obj.magic (fun uu___6 -> (uu___5, uu___6))) uu___5) - uu___4 in - let uu___4 = f t in - FStar_Class_Monad.op_Less_Star_Greater (_lvm_monad d) () () - uu___3 uu___4 in - FStar_Class_Monad.op_Less_Dollar_Greater (_lvm_monad d) () () - (fun uu___3 -> - (fun uu___3 -> - let uu___3 = Obj.magic uu___3 in - Obj.magic (FStar_Syntax_Syntax.Decreases_wf uu___3)) - uu___3) uu___2 in - FStar_Class_Monad.op_Less_Dollar_Greater (_lvm_monad d) () () - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - Obj.magic (FStar_Syntax_Syntax.DECREASES uu___2)) uu___2) - uu___1 - | f1 -> FStar_Class_Monad.return (_lvm_monad d) () (Obj.magic f1) -let on_sub_residual_comp : - 'm . 'm lvm -> FStar_Syntax_Syntax.residual_comp -> 'm = - fun d -> - fun rc -> - let residual_effect = rc.FStar_Syntax_Syntax.residual_effect in - let uu___ = - FStar_Class_Monad.map_optM (_lvm_monad d) () () - (fun uu___1 -> (Obj.magic (f_term d)) uu___1) - (Obj.magic rc.FStar_Syntax_Syntax.residual_typ) in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun residual_typ -> - let residual_typ = Obj.magic residual_typ in - let uu___1 = - let uu___2 = __on_decreases d (f_term d) in - FStar_Class_Monad.mapM (_lvm_monad d) () () - (fun uu___3 -> (Obj.magic uu___2) uu___3) - (Obj.magic rc.FStar_Syntax_Syntax.residual_flags) in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___1 - (fun uu___2 -> - (fun residual_flags -> - let residual_flags = Obj.magic residual_flags in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic - { - FStar_Syntax_Syntax.residual_effect = - residual_effect; - FStar_Syntax_Syntax.residual_typ = - residual_typ; - FStar_Syntax_Syntax.residual_flags = - residual_flags - }))) uu___2))) uu___1) -let on_sub_univ : 'm . 'm lvm -> FStar_Syntax_Syntax.universe -> 'm = - fun d -> - fun u -> - let u1 = FStar_Syntax_Subst.compress_univ u in - match u1 with - | FStar_Syntax_Syntax.U_max us -> - let uu___ = - FStar_Class_Monad.mapM (_lvm_monad d) () () - (fun uu___1 -> (Obj.magic (f_univ d)) uu___1) (Obj.magic us) in - FStar_Class_Monad.op_Less_Dollar_Greater (_lvm_monad d) () () - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - Obj.magic (FStar_Syntax_Syntax.U_max uu___1)) uu___1) uu___ - | FStar_Syntax_Syntax.U_succ u2 -> - let uu___ = f_univ d u2 in - FStar_Class_Monad.op_Less_Dollar_Greater (_lvm_monad d) () () - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - Obj.magic (FStar_Syntax_Syntax.U_succ uu___1)) uu___1) - uu___ - | FStar_Syntax_Syntax.U_zero -> - FStar_Class_Monad.return (_lvm_monad d) () (Obj.magic u1) - | FStar_Syntax_Syntax.U_bvar uu___ -> - FStar_Class_Monad.return (_lvm_monad d) () (Obj.magic u1) - | FStar_Syntax_Syntax.U_name uu___ -> - FStar_Class_Monad.return (_lvm_monad d) () (Obj.magic u1) - | FStar_Syntax_Syntax.U_unknown -> - FStar_Class_Monad.return (_lvm_monad d) () (Obj.magic u1) - | FStar_Syntax_Syntax.U_unif uu___ -> - FStar_Class_Monad.return (_lvm_monad d) () (Obj.magic u1) -let on_sub_wp_eff_combinators : - 'm . 'm lvm -> FStar_Syntax_Syntax.wp_eff_combinators -> 'm = - fun d -> - fun wpcs -> - let uu___ = - let uu___1 = f_tscheme d in uu___1 wpcs.FStar_Syntax_Syntax.ret_wp in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun ret_wp -> - let ret_wp = Obj.magic ret_wp in - let uu___1 = - let uu___2 = f_tscheme d in - uu___2 wpcs.FStar_Syntax_Syntax.bind_wp in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___1 - (fun uu___2 -> - (fun bind_wp -> - let bind_wp = Obj.magic bind_wp in - let uu___2 = - let uu___3 = f_tscheme d in - uu___3 wpcs.FStar_Syntax_Syntax.stronger in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) () - () uu___2 - (fun uu___3 -> - (fun stronger -> - let stronger = Obj.magic stronger in - let uu___3 = - let uu___4 = f_tscheme d in - uu___4 - wpcs.FStar_Syntax_Syntax.if_then_else in - Obj.magic - (FStar_Class_Monad.op_let_Bang - (_lvm_monad d) () () uu___3 - (fun uu___4 -> - (fun if_then_else -> - let if_then_else = - Obj.magic if_then_else in - let uu___4 = - let uu___5 = f_tscheme d in - uu___5 - wpcs.FStar_Syntax_Syntax.ite_wp in - Obj.magic - (FStar_Class_Monad.op_let_Bang - (_lvm_monad d) () () - uu___4 - (fun uu___5 -> - (fun ite_wp -> - let ite_wp = - Obj.magic ite_wp in - let uu___5 = - let uu___6 = - f_tscheme d in - uu___6 - wpcs.FStar_Syntax_Syntax.close_wp in - Obj.magic - (FStar_Class_Monad.op_let_Bang - (_lvm_monad d) - () () uu___5 - (fun uu___6 -> - (fun - close_wp - -> - let close_wp - = - Obj.magic - close_wp in - let uu___6 - = - let uu___7 - = - f_tscheme - d in - uu___7 - wpcs.FStar_Syntax_Syntax.trivial in - Obj.magic - (FStar_Class_Monad.op_let_Bang - (_lvm_monad - d) () () - uu___6 - (fun - uu___7 -> - (fun - trivial - -> - let trivial - = - Obj.magic - trivial in - let uu___7 - = - let uu___8 - = - f_tscheme - d in - FStar_Class_Monad.map_optM - (_lvm_monad - d) () () - (fun - uu___9 -> - (Obj.magic - uu___8) - uu___9) - (Obj.magic - wpcs.FStar_Syntax_Syntax.repr) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - (_lvm_monad - d) () () - uu___7 - (fun - uu___8 -> - (fun repr - -> - let repr - = - Obj.magic - repr in - let uu___8 - = - let uu___9 - = - f_tscheme - d in - FStar_Class_Monad.map_optM - (_lvm_monad - d) () () - (fun - uu___10 - -> - (Obj.magic - uu___9) - uu___10) - (Obj.magic - wpcs.FStar_Syntax_Syntax.return_repr) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - (_lvm_monad - d) () () - uu___8 - (fun - uu___9 -> - (fun - return_repr - -> - let return_repr - = - Obj.magic - return_repr in - let uu___9 - = - let uu___10 - = - f_tscheme - d in - FStar_Class_Monad.map_optM - (_lvm_monad - d) () () - (fun - uu___11 - -> - (Obj.magic - uu___10) - uu___11) - (Obj.magic - wpcs.FStar_Syntax_Syntax.bind_repr) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - (_lvm_monad - d) () () - uu___9 - (fun - uu___10 - -> - (fun - bind_repr - -> - let bind_repr - = - Obj.magic - bind_repr in - Obj.magic - (FStar_Class_Monad.return - (_lvm_monad - d) () - (Obj.magic - { - FStar_Syntax_Syntax.ret_wp - = ret_wp; - FStar_Syntax_Syntax.bind_wp - = bind_wp; - FStar_Syntax_Syntax.stronger - = - stronger; - FStar_Syntax_Syntax.if_then_else - = - if_then_else; - FStar_Syntax_Syntax.ite_wp - = ite_wp; - FStar_Syntax_Syntax.close_wp - = - close_wp; - FStar_Syntax_Syntax.trivial - = trivial; - FStar_Syntax_Syntax.repr - = repr; - FStar_Syntax_Syntax.return_repr - = - return_repr; - FStar_Syntax_Syntax.bind_repr - = - bind_repr - }))) - uu___10))) - uu___9))) - uu___8))) - uu___7))) - uu___6))) - uu___5))) uu___4))) - uu___3))) uu___2))) uu___1) -let mapTuple2 : - 'a 'b 'c 'd 'm . - 'm FStar_Class_Monad.monad -> ('a -> 'm) -> ('c -> 'm) -> ('a * 'c) -> 'm - = - fun uu___ -> - fun f -> - fun g -> - fun t -> - let uu___1 = - let uu___2 = - f (FStar_Pervasives_Native.__proj__Mktuple2__item___1 t) in - FStar_Class_Monad.op_Less_Dollar_Greater uu___ () () - (fun uu___3 -> - (fun uu___3 -> - let uu___3 = Obj.magic uu___3 in - Obj.magic (fun uu___4 -> (uu___3, uu___4))) uu___3) - uu___2 in - let uu___2 = - g (FStar_Pervasives_Native.__proj__Mktuple2__item___2 t) in - FStar_Class_Monad.op_Less_Star_Greater uu___ () () uu___1 uu___2 -let mapTuple3 : - 'a 'b 'c 'd 'e 'f 'm . - 'm FStar_Class_Monad.monad -> - ('a -> 'm) -> ('c -> 'm) -> ('e -> 'm) -> ('a * 'c * 'e) -> 'm - = - fun uu___ -> - fun f1 -> - fun g -> - fun h -> - fun t -> - let uu___1 = - let uu___2 = - let uu___3 = - f1 (FStar_Pervasives_Native.__proj__Mktuple3__item___1 t) in - FStar_Class_Monad.op_Less_Dollar_Greater uu___ () () - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - Obj.magic - (fun uu___5 -> - fun uu___6 -> (uu___4, uu___5, uu___6))) uu___4) - uu___3 in - let uu___3 = - g (FStar_Pervasives_Native.__proj__Mktuple3__item___2 t) in - FStar_Class_Monad.op_Less_Star_Greater uu___ () () uu___2 - uu___3 in - let uu___2 = - h (FStar_Pervasives_Native.__proj__Mktuple3__item___3 t) in - FStar_Class_Monad.op_Less_Star_Greater uu___ () () uu___1 uu___2 -let on_sub_layered_eff_combinators : - 'm . 'm lvm -> FStar_Syntax_Syntax.layered_eff_combinators -> 'm = - fun d -> - fun lecs -> - let uu___ = - let uu___1 = f_tscheme d in - let uu___2 = f_tscheme d in - mapTuple2 (_lvm_monad d) uu___1 uu___2 - lecs.FStar_Syntax_Syntax.l_repr in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun l_repr -> - let l_repr = Obj.magic l_repr in - let uu___1 = - let uu___2 = f_tscheme d in - let uu___3 = f_tscheme d in - mapTuple2 (_lvm_monad d) uu___2 uu___3 - lecs.FStar_Syntax_Syntax.l_return in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___1 - (fun uu___2 -> - (fun l_return -> - let l_return = Obj.magic l_return in - let uu___2 = - let uu___3 = f_tscheme d in - let uu___4 = f_tscheme d in - mapTuple3 (_lvm_monad d) uu___3 uu___4 - (fun uu___5 -> - (Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) - ())) uu___5) - lecs.FStar_Syntax_Syntax.l_bind in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) () - () uu___2 - (fun uu___3 -> - (fun l_bind -> - let l_bind = Obj.magic l_bind in - let uu___3 = - let uu___4 = f_tscheme d in - let uu___5 = f_tscheme d in - mapTuple3 (_lvm_monad d) uu___4 uu___5 - (fun uu___6 -> - (Obj.magic - (FStar_Class_Monad.return - (_lvm_monad d) ())) uu___6) - lecs.FStar_Syntax_Syntax.l_subcomp in - Obj.magic - (FStar_Class_Monad.op_let_Bang - (_lvm_monad d) () () uu___3 - (fun uu___4 -> - (fun l_subcomp -> - let l_subcomp = - Obj.magic l_subcomp in - let uu___4 = - let uu___5 = f_tscheme d in - let uu___6 = f_tscheme d in - mapTuple3 (_lvm_monad d) - uu___5 uu___6 - (fun uu___7 -> - (Obj.magic - (FStar_Class_Monad.return - (_lvm_monad d) ())) - uu___7) - lecs.FStar_Syntax_Syntax.l_if_then_else in - Obj.magic - (FStar_Class_Monad.op_let_Bang - (_lvm_monad d) () () - uu___4 - (fun uu___5 -> - (fun l_if_then_else -> - let l_if_then_else - = - Obj.magic - l_if_then_else in - let uu___5 = - let uu___6 = - let uu___7 = - f_tscheme d in - let uu___8 = - f_tscheme d in - mapTuple2 - (_lvm_monad d) - uu___7 uu___8 in - FStar_Class_Monad.map_optM - (_lvm_monad d) - () () - (fun uu___7 -> - (Obj.magic - uu___6) - uu___7) - (Obj.magic - lecs.FStar_Syntax_Syntax.l_close) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - (_lvm_monad d) - () () uu___5 - (fun uu___6 -> - (fun - l_close - -> - let l_close - = - Obj.magic - l_close in - Obj.magic - (FStar_Class_Monad.return - (_lvm_monad - d) () - (Obj.magic - { - FStar_Syntax_Syntax.l_repr - = l_repr; - FStar_Syntax_Syntax.l_return - = - l_return; - FStar_Syntax_Syntax.l_bind - = l_bind; - FStar_Syntax_Syntax.l_subcomp - = - l_subcomp; - FStar_Syntax_Syntax.l_if_then_else - = - l_if_then_else; - FStar_Syntax_Syntax.l_close - = l_close - }))) - uu___6))) - uu___5))) uu___4))) - uu___3))) uu___2))) uu___1) -let on_sub_combinators : - 'm . 'm lvm -> FStar_Syntax_Syntax.eff_combinators -> 'm = - fun d -> - fun cbs -> - match cbs with - | FStar_Syntax_Syntax.Primitive_eff wpcs -> - let uu___ = on_sub_wp_eff_combinators d wpcs in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun wpcs1 -> - let wpcs1 = Obj.magic wpcs1 in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic (FStar_Syntax_Syntax.Primitive_eff wpcs1)))) - uu___1) - | FStar_Syntax_Syntax.DM4F_eff wpcs -> - let uu___ = on_sub_wp_eff_combinators d wpcs in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun wpcs1 -> - let wpcs1 = Obj.magic wpcs1 in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic (FStar_Syntax_Syntax.DM4F_eff wpcs1)))) - uu___1) - | FStar_Syntax_Syntax.Layered_eff lecs -> - let uu___ = on_sub_layered_eff_combinators d lecs in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun lecs1 -> - let lecs1 = Obj.magic lecs1 in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic (FStar_Syntax_Syntax.Layered_eff lecs1)))) - uu___1) -let on_sub_effect_signature : - 'm . 'm lvm -> FStar_Syntax_Syntax.effect_signature -> 'm = - fun d -> - fun es -> - match es with - | FStar_Syntax_Syntax.Layered_eff_sig (n, (us, t)) -> - let uu___ = f_term d t in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun t1 -> - let t1 = Obj.magic t1 in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic - (FStar_Syntax_Syntax.Layered_eff_sig (n, (us, t1)))))) - uu___1) - | FStar_Syntax_Syntax.WP_eff_sig (us, t) -> - let uu___ = f_term d t in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun t1 -> - let t1 = Obj.magic t1 in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic (FStar_Syntax_Syntax.WP_eff_sig (us, t1))))) - uu___1) -let on_sub_action : 'm . 'm lvm -> FStar_Syntax_Syntax.action -> 'm = - fun d -> - fun a -> - let action_name = a.FStar_Syntax_Syntax.action_name in - let action_unqualified_name = - a.FStar_Syntax_Syntax.action_unqualified_name in - let action_univs = a.FStar_Syntax_Syntax.action_univs in - let uu___ = - FStar_Class_Monad.mapM (_lvm_monad d) () () - (fun uu___1 -> (Obj.magic (f_binder d)) uu___1) - (Obj.magic a.FStar_Syntax_Syntax.action_params) in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun action_params -> - let action_params = Obj.magic action_params in - let uu___1 = f_term d a.FStar_Syntax_Syntax.action_defn in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___1 - (fun uu___2 -> - (fun action_defn -> - let action_defn = Obj.magic action_defn in - let uu___2 = - f_term d a.FStar_Syntax_Syntax.action_typ in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) () - () uu___2 - (fun uu___3 -> - (fun action_typ -> - let action_typ = Obj.magic action_typ in - Obj.magic - (FStar_Class_Monad.return - (_lvm_monad d) () - (Obj.magic - { - FStar_Syntax_Syntax.action_name - = action_name; - FStar_Syntax_Syntax.action_unqualified_name - = action_unqualified_name; - FStar_Syntax_Syntax.action_univs - = action_univs; - FStar_Syntax_Syntax.action_params - = action_params; - FStar_Syntax_Syntax.action_defn - = action_defn; - FStar_Syntax_Syntax.action_typ - = action_typ - }))) uu___3))) uu___2))) uu___1) -let rec on_sub_sigelt' : 'm . 'm lvm -> FStar_Syntax_Syntax.sigelt' -> 'm = - fun d -> - fun se -> - match se with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = lid; FStar_Syntax_Syntax.us = us; - FStar_Syntax_Syntax.params = params; - FStar_Syntax_Syntax.num_uniform_params = num_uniform_params; - FStar_Syntax_Syntax.t = t; FStar_Syntax_Syntax.mutuals = mutuals; - FStar_Syntax_Syntax.ds = ds; - FStar_Syntax_Syntax.injective_type_params = injective_type_params;_} - -> - let uu___ = - FStar_Class_Monad.mapM (_lvm_monad d) () () - (fun uu___1 -> (Obj.magic (f_binder d)) uu___1) - (Obj.magic params) in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun params1 -> - let params1 = Obj.magic params1 in - let uu___1 = f_term d t in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () - uu___1 - (fun uu___2 -> - (fun t1 -> - let t1 = Obj.magic t1 in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic - (FStar_Syntax_Syntax.Sig_inductive_typ - { - FStar_Syntax_Syntax.lid = lid; - FStar_Syntax_Syntax.us = us; - FStar_Syntax_Syntax.params = - params1; - FStar_Syntax_Syntax.num_uniform_params - = num_uniform_params; - FStar_Syntax_Syntax.t = t1; - FStar_Syntax_Syntax.mutuals = - mutuals; - FStar_Syntax_Syntax.ds = ds; - FStar_Syntax_Syntax.injective_type_params - = injective_type_params - })))) uu___2))) uu___1) - | FStar_Syntax_Syntax.Sig_bundle - { FStar_Syntax_Syntax.ses = ses; FStar_Syntax_Syntax.lids = lids;_} - -> - let uu___ = - FStar_Class_Monad.mapM (_lvm_monad d) () () - (fun uu___1 -> (Obj.magic (on_sub_sigelt d)) uu___1) - (Obj.magic ses) in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun ses1 -> - let ses1 = Obj.magic ses1 in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic - (FStar_Syntax_Syntax.Sig_bundle - { - FStar_Syntax_Syntax.ses = ses1; - FStar_Syntax_Syntax.lids = lids - })))) uu___1) - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = lid; FStar_Syntax_Syntax.us1 = us; - FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = ty_lid; - FStar_Syntax_Syntax.num_ty_params = num_ty_params; - FStar_Syntax_Syntax.mutuals1 = mutuals; - FStar_Syntax_Syntax.injective_type_params1 = - injective_type_params;_} - -> - let uu___ = f_term d t in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun t1 -> - let t1 = Obj.magic t1 in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic - (FStar_Syntax_Syntax.Sig_datacon - { - FStar_Syntax_Syntax.lid1 = lid; - FStar_Syntax_Syntax.us1 = us; - FStar_Syntax_Syntax.t1 = t1; - FStar_Syntax_Syntax.ty_lid = ty_lid; - FStar_Syntax_Syntax.num_ty_params = - num_ty_params; - FStar_Syntax_Syntax.mutuals1 = mutuals; - FStar_Syntax_Syntax.injective_type_params1 = - injective_type_params - })))) uu___1) - | FStar_Syntax_Syntax.Sig_declare_typ - { FStar_Syntax_Syntax.lid2 = lid; FStar_Syntax_Syntax.us2 = us; - FStar_Syntax_Syntax.t2 = t;_} - -> - let uu___ = f_term d t in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun t1 -> - let t1 = Obj.magic t1 in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic - (FStar_Syntax_Syntax.Sig_declare_typ - { - FStar_Syntax_Syntax.lid2 = lid; - FStar_Syntax_Syntax.us2 = us; - FStar_Syntax_Syntax.t2 = t1 - })))) uu___1) - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (is_rec, lbs); - FStar_Syntax_Syntax.lids1 = lids;_} - -> - let uu___ = - FStar_Class_Monad.mapM (_lvm_monad d) () () - (fun uu___1 -> (Obj.magic (on_sub_letbinding d)) uu___1) - (Obj.magic lbs) in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun lbs1 -> - let lbs1 = Obj.magic lbs1 in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic - (FStar_Syntax_Syntax.Sig_let - { - FStar_Syntax_Syntax.lbs1 = (is_rec, lbs1); - FStar_Syntax_Syntax.lids1 = lids - })))) uu___1) - | FStar_Syntax_Syntax.Sig_assume - { FStar_Syntax_Syntax.lid3 = lid; FStar_Syntax_Syntax.us3 = us; - FStar_Syntax_Syntax.phi1 = phi;_} - -> - let uu___ = f_term d phi in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun phi1 -> - let phi1 = Obj.magic phi1 in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic - (FStar_Syntax_Syntax.Sig_assume - { - FStar_Syntax_Syntax.lid3 = lid; - FStar_Syntax_Syntax.us3 = us; - FStar_Syntax_Syntax.phi1 = phi1 - })))) uu___1) - | FStar_Syntax_Syntax.Sig_new_effect ed -> - let mname = ed.FStar_Syntax_Syntax.mname in - let cattributes = ed.FStar_Syntax_Syntax.cattributes in - let univs = ed.FStar_Syntax_Syntax.univs in - let uu___ = - FStar_Class_Monad.mapM (_lvm_monad d) () () - (fun uu___1 -> (Obj.magic (f_binder d)) uu___1) - (Obj.magic ed.FStar_Syntax_Syntax.binders) in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun binders -> - let binders = Obj.magic binders in - let uu___1 = - on_sub_effect_signature d - ed.FStar_Syntax_Syntax.signature in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () - uu___1 - (fun uu___2 -> - (fun signature -> - let signature = Obj.magic signature in - let uu___2 = - on_sub_combinators d - ed.FStar_Syntax_Syntax.combinators in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) - () () uu___2 - (fun uu___3 -> - (fun combinators -> - let combinators = - Obj.magic combinators in - let uu___3 = - FStar_Class_Monad.mapM - (_lvm_monad d) () () - (fun uu___4 -> - (Obj.magic (on_sub_action d)) - uu___4) - (Obj.magic - ed.FStar_Syntax_Syntax.actions) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - (_lvm_monad d) () () uu___3 - (fun uu___4 -> - (fun actions -> - let actions = - Obj.magic actions in - let uu___4 = - FStar_Class_Monad.mapM - (_lvm_monad d) () () - (fun uu___5 -> - (Obj.magic - (f_term d)) - uu___5) - (Obj.magic - ed.FStar_Syntax_Syntax.eff_attrs) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - (_lvm_monad d) () () - uu___4 - (fun uu___5 -> - (fun eff_attrs -> - let eff_attrs = - Obj.magic - eff_attrs in - let extraction_mode - = - ed.FStar_Syntax_Syntax.extraction_mode in - let ed1 = - { - FStar_Syntax_Syntax.mname - = mname; - FStar_Syntax_Syntax.cattributes - = - cattributes; - FStar_Syntax_Syntax.univs - = univs; - FStar_Syntax_Syntax.binders - = binders; - FStar_Syntax_Syntax.signature - = - signature; - FStar_Syntax_Syntax.combinators - = - combinators; - FStar_Syntax_Syntax.actions - = actions; - FStar_Syntax_Syntax.eff_attrs - = - eff_attrs; - FStar_Syntax_Syntax.extraction_mode - = - extraction_mode - } in - Obj.magic - (FStar_Class_Monad.return - (_lvm_monad - d) () - (Obj.magic - (FStar_Syntax_Syntax.Sig_new_effect - ed1)))) - uu___5))) uu___4))) - uu___3))) uu___2))) uu___1) - | FStar_Syntax_Syntax.Sig_sub_effect se1 -> - let source = se1.FStar_Syntax_Syntax.source in - let target = se1.FStar_Syntax_Syntax.target in - let uu___ = - let uu___1 = f_tscheme d in - FStar_Class_Monad.map_optM (_lvm_monad d) () () - (fun uu___2 -> (Obj.magic uu___1) uu___2) - (Obj.magic se1.FStar_Syntax_Syntax.lift_wp) in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun lift_wp -> - let lift_wp = Obj.magic lift_wp in - let uu___1 = - let uu___2 = f_tscheme d in - FStar_Class_Monad.map_optM (_lvm_monad d) () () - (fun uu___3 -> (Obj.magic uu___2) uu___3) - (Obj.magic se1.FStar_Syntax_Syntax.lift) in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () - uu___1 - (fun uu___2 -> - (fun lift -> - let lift = Obj.magic lift in - let kind = se1.FStar_Syntax_Syntax.kind in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic - (FStar_Syntax_Syntax.Sig_sub_effect - { - FStar_Syntax_Syntax.source = source; - FStar_Syntax_Syntax.target = target; - FStar_Syntax_Syntax.lift_wp = - lift_wp; - FStar_Syntax_Syntax.lift = lift; - FStar_Syntax_Syntax.kind = kind - })))) uu___2))) uu___1) - | FStar_Syntax_Syntax.Sig_effect_abbrev - { FStar_Syntax_Syntax.lid4 = lid; FStar_Syntax_Syntax.us4 = us; - FStar_Syntax_Syntax.bs2 = bs; FStar_Syntax_Syntax.comp1 = comp; - FStar_Syntax_Syntax.cflags = cflags;_} - -> - let uu___ = - FStar_Class_Monad.mapM (_lvm_monad d) () () - (fun uu___1 -> (Obj.magic (f_binder d)) uu___1) (Obj.magic bs) in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun binders -> - let binders = Obj.magic binders in - let uu___1 = f_comp d comp in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () - uu___1 - (fun uu___2 -> - (fun comp1 -> - let comp1 = Obj.magic comp1 in - let uu___2 = - let uu___3 = __on_decreases d (f_term d) in - FStar_Class_Monad.mapM (_lvm_monad d) () () - (fun uu___4 -> (Obj.magic uu___3) uu___4) - (Obj.magic cflags) in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) - () () uu___2 - (fun uu___3 -> - (fun cflags1 -> - let cflags1 = Obj.magic cflags1 in - Obj.magic - (FStar_Class_Monad.return - (_lvm_monad d) () - (Obj.magic - (FStar_Syntax_Syntax.Sig_effect_abbrev - { - FStar_Syntax_Syntax.lid4 - = lid; - FStar_Syntax_Syntax.us4 - = us; - FStar_Syntax_Syntax.bs2 - = bs; - FStar_Syntax_Syntax.comp1 - = comp1; - FStar_Syntax_Syntax.cflags - = cflags1 - })))) uu___3))) uu___2))) - uu___1) - | FStar_Syntax_Syntax.Sig_pragma uu___ -> - FStar_Class_Monad.return (_lvm_monad d) () (Obj.magic se) - | FStar_Syntax_Syntax.Sig_polymonadic_bind - { FStar_Syntax_Syntax.m_lid = m_lid; - FStar_Syntax_Syntax.n_lid = n_lid; - FStar_Syntax_Syntax.p_lid = p_lid; FStar_Syntax_Syntax.tm3 = tm; - FStar_Syntax_Syntax.typ = typ; - FStar_Syntax_Syntax.kind1 = kind;_} - -> - let uu___ = let uu___1 = f_tscheme d in uu___1 tm in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun tm1 -> - let tm1 = Obj.magic tm1 in - let uu___1 = let uu___2 = f_tscheme d in uu___2 typ in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () - uu___1 - (fun uu___2 -> - (fun typ1 -> - let typ1 = Obj.magic typ1 in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic - (FStar_Syntax_Syntax.Sig_polymonadic_bind - { - FStar_Syntax_Syntax.m_lid = m_lid; - FStar_Syntax_Syntax.n_lid = n_lid; - FStar_Syntax_Syntax.p_lid = p_lid; - FStar_Syntax_Syntax.tm3 = tm1; - FStar_Syntax_Syntax.typ = typ1; - FStar_Syntax_Syntax.kind1 = kind - })))) uu___2))) uu___1) - | FStar_Syntax_Syntax.Sig_polymonadic_subcomp - { FStar_Syntax_Syntax.m_lid1 = m_lid; - FStar_Syntax_Syntax.n_lid1 = n_lid; FStar_Syntax_Syntax.tm4 = tm; - FStar_Syntax_Syntax.typ1 = typ; - FStar_Syntax_Syntax.kind2 = kind;_} - -> - let uu___ = let uu___1 = f_tscheme d in uu___1 tm in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun tm1 -> - let tm1 = Obj.magic tm1 in - let uu___1 = let uu___2 = f_tscheme d in uu___2 typ in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () - uu___1 - (fun uu___2 -> - (fun typ1 -> - let typ1 = Obj.magic typ1 in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic - (FStar_Syntax_Syntax.Sig_polymonadic_subcomp - { - FStar_Syntax_Syntax.m_lid1 = m_lid; - FStar_Syntax_Syntax.n_lid1 = n_lid; - FStar_Syntax_Syntax.tm4 = tm1; - FStar_Syntax_Syntax.typ1 = typ1; - FStar_Syntax_Syntax.kind2 = kind - })))) uu___2))) uu___1) - | FStar_Syntax_Syntax.Sig_fail - { FStar_Syntax_Syntax.errs = errs; - FStar_Syntax_Syntax.fail_in_lax = fail_in_lax; - FStar_Syntax_Syntax.ses1 = ses;_} - -> - let uu___ = - FStar_Class_Monad.mapM (_lvm_monad d) () () - (fun uu___1 -> (Obj.magic (on_sub_sigelt d)) uu___1) - (Obj.magic ses) in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun ses1 -> - let ses1 = Obj.magic ses1 in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic - (FStar_Syntax_Syntax.Sig_fail - { - FStar_Syntax_Syntax.errs = errs; - FStar_Syntax_Syntax.fail_in_lax = fail_in_lax; - FStar_Syntax_Syntax.ses1 = ses1 - })))) uu___1) - | FStar_Syntax_Syntax.Sig_splice - { FStar_Syntax_Syntax.is_typed = is_typed; - FStar_Syntax_Syntax.lids2 = lids; - FStar_Syntax_Syntax.tac = tac;_} - -> - let uu___ = f_term d tac in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun tac1 -> - let tac1 = Obj.magic tac1 in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic - (FStar_Syntax_Syntax.Sig_splice - { - FStar_Syntax_Syntax.is_typed = is_typed; - FStar_Syntax_Syntax.lids2 = lids; - FStar_Syntax_Syntax.tac = tac1 - })))) uu___1) - | uu___ -> failwith "on_sub_sigelt: missing case" -and on_sub_sigelt : 'm . 'm lvm -> FStar_Syntax_Syntax.sigelt -> 'm = - fun d -> - fun se -> - let uu___ = on_sub_sigelt' d se.FStar_Syntax_Syntax.sigel in - FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___ - (fun uu___1 -> - (fun sigel -> - let sigel = Obj.magic sigel in - let sigrng = se.FStar_Syntax_Syntax.sigrng in - let sigquals = se.FStar_Syntax_Syntax.sigquals in - let sigmeta = se.FStar_Syntax_Syntax.sigmeta in - let uu___1 = - FStar_Class_Monad.mapM (_lvm_monad d) () () - (fun uu___2 -> (Obj.magic (f_term d)) uu___2) - (Obj.magic se.FStar_Syntax_Syntax.sigattrs) in - Obj.magic - (FStar_Class_Monad.op_let_Bang (_lvm_monad d) () () uu___1 - (fun uu___2 -> - (fun sigattrs -> - let sigattrs = Obj.magic sigattrs in - let sigopts = se.FStar_Syntax_Syntax.sigopts in - let sigopens_and_abbrevs = - se.FStar_Syntax_Syntax.sigopens_and_abbrevs in - Obj.magic - (FStar_Class_Monad.return (_lvm_monad d) () - (Obj.magic - { - FStar_Syntax_Syntax.sigel = sigel; - FStar_Syntax_Syntax.sigrng = sigrng; - FStar_Syntax_Syntax.sigquals = sigquals; - FStar_Syntax_Syntax.sigmeta = sigmeta; - FStar_Syntax_Syntax.sigattrs = sigattrs; - FStar_Syntax_Syntax.sigopens_and_abbrevs = - sigopens_and_abbrevs; - FStar_Syntax_Syntax.sigopts = sigopts - }))) uu___2))) uu___1) -let op_Greater_Greater_Equals : - 'm . - 'm FStar_Class_Monad.monad -> unit -> unit -> 'm -> (Obj.t -> 'm) -> 'm - = - fun uu___ -> - fun a -> - fun b -> - fun c -> - fun f -> FStar_Class_Monad.op_let_Bang uu___ () () c (fun x -> f x) -let op_Less_Less_Bar : - 'm . - 'm FStar_Class_Monad.monad -> unit -> unit -> (Obj.t -> 'm) -> 'm -> 'm - = - fun uu___ -> - fun a -> - fun b -> - fun f -> - fun c -> FStar_Class_Monad.op_let_Bang uu___ () () c (fun x -> f x) -let tie_bu : 'm . 'm FStar_Class_Monad.monad -> 'm lvm -> 'm lvm = - fun md -> - fun d -> - let r = let uu___ = novfs md in FStar_Compiler_Util.mk_ref uu___ in - (let uu___1 = - let uu___2 = - let uu___3 = FStar_Compiler_Effect.op_Bang r in uu___3.lvm_monad in - { - lvm_monad = uu___2; - f_term = - (fun x -> - let uu___3 = - let uu___4 = FStar_Compiler_Effect.op_Bang r in - on_sub_term uu___4 x in - op_Less_Less_Bar md () () - (fun uu___4 -> (Obj.magic (f_term d)) uu___4) uu___3); - f_binder = - (fun x -> - let uu___3 = - let uu___4 = FStar_Compiler_Effect.op_Bang r in - on_sub_binder uu___4 x in - op_Less_Less_Bar md () () - (fun uu___4 -> (Obj.magic (f_binder d)) uu___4) uu___3); - f_binding_bv = - (fun x -> - let uu___3 = - let uu___4 = FStar_Compiler_Effect.op_Bang r in - on_sub_binding_bv uu___4 x in - op_Less_Less_Bar md () () - (fun uu___4 -> (Obj.magic (f_binding_bv d)) uu___4) uu___3); - f_br = - (fun x -> - let uu___3 = - let uu___4 = FStar_Compiler_Effect.op_Bang r in - on_sub_br uu___4 x in - op_Less_Less_Bar md () () - (fun uu___4 -> (Obj.magic (f_br d)) uu___4) uu___3); - f_comp = - (fun x -> - let uu___3 = - let uu___4 = FStar_Compiler_Effect.op_Bang r in - on_sub_comp uu___4 x in - op_Less_Less_Bar md () () - (fun uu___4 -> (Obj.magic (f_comp d)) uu___4) uu___3); - f_residual_comp = - (fun x -> - let uu___3 = - let uu___4 = FStar_Compiler_Effect.op_Bang r in - on_sub_residual_comp uu___4 x in - op_Less_Less_Bar md () () - (fun uu___4 -> (Obj.magic (f_residual_comp d)) uu___4) - uu___3); - f_univ = - (fun x -> - let uu___3 = - let uu___4 = FStar_Compiler_Effect.op_Bang r in - on_sub_univ uu___4 x in - op_Less_Less_Bar md () () - (fun uu___4 -> (Obj.magic (f_univ d)) uu___4) uu___3); - proc_quotes = (d.proc_quotes) - } in - FStar_Compiler_Effect.op_Colon_Equals r uu___1); - FStar_Compiler_Effect.op_Bang r -let visitM_term_univs : - 'm . - 'm FStar_Class_Monad.monad -> - Prims.bool -> - (FStar_Syntax_Syntax.term -> 'm) -> - (FStar_Syntax_Syntax.universe -> 'm) -> - FStar_Syntax_Syntax.term -> 'm - = - fun md -> - fun proc_quotes1 -> - fun vt -> - fun vu -> - fun tm -> - let dict = - let uu___ = - let uu___1 = novfs md in - { - lvm_monad = (uu___1.lvm_monad); - f_term = vt; - f_binder = (uu___1.f_binder); - f_binding_bv = (uu___1.f_binding_bv); - f_br = (uu___1.f_br); - f_comp = (uu___1.f_comp); - f_residual_comp = (uu___1.f_residual_comp); - f_univ = vu; - proc_quotes = proc_quotes1 - } in - tie_bu md uu___ in - f_term dict tm -let visitM_term : - 'm . - 'm FStar_Class_Monad.monad -> - Prims.bool -> - (FStar_Syntax_Syntax.term -> 'm) -> FStar_Syntax_Syntax.term -> 'm - = - fun md -> - fun proc_quotes1 -> - fun vt -> - fun tm -> - visitM_term_univs md true vt - (fun uu___ -> (Obj.magic (FStar_Class_Monad.return md ())) uu___) - tm -let visitM_sigelt : - 'm . - 'm FStar_Class_Monad.monad -> - Prims.bool -> - (FStar_Syntax_Syntax.term -> 'm) -> - (FStar_Syntax_Syntax.universe -> 'm) -> - FStar_Syntax_Syntax.sigelt -> 'm - = - fun md -> - fun proc_quotes1 -> - fun vt -> - fun vu -> - fun tm -> - let dict = - let uu___ = - let uu___1 = novfs md in - { - lvm_monad = (uu___1.lvm_monad); - f_term = vt; - f_binder = (uu___1.f_binder); - f_binding_bv = (uu___1.f_binding_bv); - f_br = (uu___1.f_br); - f_comp = (uu___1.f_comp); - f_residual_comp = (uu___1.f_residual_comp); - f_univ = vu; - proc_quotes = proc_quotes1 - } in - tie_bu md uu___ in - on_sub_sigelt dict tm \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_Arith.ml b/ocaml/fstar-lib/generated/FStar_Tactics_Arith.ml index 206cff03b0b..bb9726f0acc 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_Arith.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_Arith.ml @@ -56,7 +56,7 @@ let rec (split_arith : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___2 -> if uu___2 then - let uu___3 = FStar_Tactics_V2_Builtins.prune "" in + let uu___3 = FStarC_Tactics_V2_Builtins.prune "" in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -72,7 +72,8 @@ let rec (split_arith : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (Obj.magic uu___3) (fun uu___4 -> (fun uu___4 -> - let uu___5 = FStar_Tactics_V2_Builtins.addns "Prims" in + let uu___5 = + FStarC_Tactics_V2_Builtins.addns "Prims" in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_BV.ml b/ocaml/fstar-lib/generated/FStar_Tactics_BV.ml index e5580b6d04e..18ed09f1192 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_BV.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_BV.ml @@ -9,9 +9,9 @@ let rec (arith_expr_to_bv : (e1, uu___)) -> let uu___1 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "BV"; "int2bv_mul"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -28,9 +28,9 @@ let rec (arith_expr_to_bv : (fun uu___2 -> let uu___3 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "BV"; @@ -55,9 +55,9 @@ let rec (arith_expr_to_bv : | FStar_Reflection_V2_Arith.MulMod (e1, uu___) -> let uu___1 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "BV"; "int2bv_mul"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -74,9 +74,9 @@ let rec (arith_expr_to_bv : (fun uu___2 -> let uu___3 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "BV"; @@ -102,9 +102,9 @@ let rec (arith_expr_to_bv : (e1, uu___)) -> let uu___1 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "BV"; "int2bv_mod"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -121,9 +121,9 @@ let rec (arith_expr_to_bv : (fun uu___2 -> let uu___3 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "BV"; @@ -148,9 +148,9 @@ let rec (arith_expr_to_bv : | FStar_Reflection_V2_Arith.Umod (e1, uu___) -> let uu___1 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "BV"; "int2bv_mod"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -167,9 +167,9 @@ let rec (arith_expr_to_bv : (fun uu___2 -> let uu___3 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "BV"; @@ -195,9 +195,9 @@ let rec (arith_expr_to_bv : (e1, uu___)) -> let uu___1 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "BV"; "int2bv_div"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -214,9 +214,9 @@ let rec (arith_expr_to_bv : (fun uu___2 -> let uu___3 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "BV"; @@ -241,9 +241,9 @@ let rec (arith_expr_to_bv : | FStar_Reflection_V2_Arith.Udiv (e1, uu___) -> let uu___1 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "BV"; "int2bv_div"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -260,9 +260,9 @@ let rec (arith_expr_to_bv : (fun uu___2 -> let uu___3 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "BV"; @@ -288,9 +288,9 @@ let rec (arith_expr_to_bv : (e1, uu___)) -> let uu___1 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "BV"; "int2bv_shl"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -307,9 +307,9 @@ let rec (arith_expr_to_bv : (fun uu___2 -> let uu___3 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "BV"; @@ -334,9 +334,9 @@ let rec (arith_expr_to_bv : | FStar_Reflection_V2_Arith.Shl (e1, uu___) -> let uu___1 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "BV"; "int2bv_shl"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -353,9 +353,9 @@ let rec (arith_expr_to_bv : (fun uu___2 -> let uu___3 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "BV"; @@ -381,9 +381,9 @@ let rec (arith_expr_to_bv : (e1, uu___)) -> let uu___1 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "BV"; "int2bv_shr"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -400,9 +400,9 @@ let rec (arith_expr_to_bv : (fun uu___2 -> let uu___3 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "BV"; @@ -427,9 +427,9 @@ let rec (arith_expr_to_bv : | FStar_Reflection_V2_Arith.Shr (e1, uu___) -> let uu___1 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "BV"; "int2bv_shr"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -446,9 +446,9 @@ let rec (arith_expr_to_bv : (fun uu___2 -> let uu___3 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "BV"; @@ -474,9 +474,9 @@ let rec (arith_expr_to_bv : (e1, e2)) -> let uu___ = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "BV"; "int2bv_logand"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -493,9 +493,9 @@ let rec (arith_expr_to_bv : (fun uu___1 -> let uu___2 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "BV"; @@ -543,9 +543,9 @@ let rec (arith_expr_to_bv : | FStar_Reflection_V2_Arith.Land (e1, e2) -> let uu___ = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "BV"; "int2bv_logand"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -562,9 +562,9 @@ let rec (arith_expr_to_bv : (fun uu___1 -> let uu___2 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "BV"; @@ -613,9 +613,9 @@ let rec (arith_expr_to_bv : (e1, e2)) -> let uu___ = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "BV"; "int2bv_logxor"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -632,9 +632,9 @@ let rec (arith_expr_to_bv : (fun uu___1 -> let uu___2 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "BV"; @@ -682,9 +682,9 @@ let rec (arith_expr_to_bv : | FStar_Reflection_V2_Arith.Lxor (e1, e2) -> let uu___ = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "BV"; "int2bv_logxor"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -701,9 +701,9 @@ let rec (arith_expr_to_bv : (fun uu___1 -> let uu___2 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "BV"; @@ -752,9 +752,9 @@ let rec (arith_expr_to_bv : (e1, e2)) -> let uu___ = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "BV"; "int2bv_logor"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -771,9 +771,9 @@ let rec (arith_expr_to_bv : (fun uu___1 -> let uu___2 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "BV"; @@ -821,9 +821,9 @@ let rec (arith_expr_to_bv : | FStar_Reflection_V2_Arith.Lor (e1, e2) -> let uu___ = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "BV"; "int2bv_logor"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -840,9 +840,9 @@ let rec (arith_expr_to_bv : (fun uu___1 -> let uu___2 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "BV"; @@ -891,9 +891,9 @@ let rec (arith_expr_to_bv : (e1, e2)) -> let uu___ = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "BV"; "int2bv_add"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -910,9 +910,9 @@ let rec (arith_expr_to_bv : (fun uu___1 -> let uu___2 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "BV"; @@ -960,9 +960,9 @@ let rec (arith_expr_to_bv : | FStar_Reflection_V2_Arith.Ladd (e1, e2) -> let uu___ = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "BV"; "int2bv_add"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -979,9 +979,9 @@ let rec (arith_expr_to_bv : (fun uu___1 -> let uu___2 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "BV"; @@ -1030,9 +1030,9 @@ let rec (arith_expr_to_bv : (e1, e2)) -> let uu___ = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "BV"; "int2bv_sub"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1049,9 +1049,9 @@ let rec (arith_expr_to_bv : (fun uu___1 -> let uu___2 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "BV"; @@ -1099,9 +1099,9 @@ let rec (arith_expr_to_bv : | FStar_Reflection_V2_Arith.Lsub (e1, e2) -> let uu___ = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "BV"; "int2bv_sub"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1118,9 +1118,9 @@ let rec (arith_expr_to_bv : (fun uu___1 -> let uu___2 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "BV"; @@ -1171,7 +1171,7 @@ let (arith_to_bv_tac : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = FStar_Tactics_V2_Derived.focus (fun uu___1 -> let uu___2 = - FStar_Tactics_V2_Builtins.norm + FStarC_Tactics_V2_Builtins.norm [FStar_Pervasives.delta_only ["FStar.BV.bvult"]] in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1260,7 +1260,7 @@ let (arith_to_bv_tac : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = | FStar_Pervasives.Inl s -> let uu___9 = - FStar_Tactics_V2_Builtins.dump + FStarC_Tactics_V2_Builtins.dump s in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1303,7 +1303,7 @@ let (arith_to_bv_tac : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = | uu___6 -> let uu___7 = let uu___8 = - FStar_Tactics_V2_Builtins.term_to_string + FStarC_Tactics_V2_Builtins.term_to_string g in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1353,26 +1353,26 @@ let (arith_to_bv_tac : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = uu___8))) uu___6))) uu___5))) uu___3)) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.BV.arith_to_bv_tac" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.BV.arith_to_bv_tac" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.BV.arith_to_bv_tac (plugin)" - (FStar_Tactics_Native.from_tactic_1 arith_to_bv_tac) - FStar_Syntax_Embeddings.e_unit FStar_Syntax_Embeddings.e_unit - psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 arith_to_bv_tac) + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (bv_tac : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> FStar_Tactics_V2_Derived.focus (fun uu___1 -> let uu___2 = FStar_Tactics_MApply.mapply FStar_Tactics_MApply.termable_term - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "BV"; "Lemmas"; "eq_to_bv"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1391,9 +1391,9 @@ let (bv_tac : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = let uu___4 = FStar_Tactics_MApply.mapply FStar_Tactics_MApply.termable_term - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "BV"; "Lemmas"; "trans"]))) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1455,7 +1455,7 @@ let (bv_tac : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___9 -> (fun uu___9 -> let uu___10 = - FStar_Tactics_V2_Builtins.set_options + FStarC_Tactics_V2_Builtins.set_options "--smtencoding.elim_box true" in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1479,7 +1479,7 @@ let (bv_tac : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___11 -> (fun uu___11 -> let uu___12 = - FStar_Tactics_V2_Builtins.norm + FStarC_Tactics_V2_Builtins.norm [FStar_Pervasives.delta] in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1514,17 +1514,17 @@ let (bv_tac : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = uu___11))) uu___9))) uu___7))) uu___5))) uu___3)) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.BV.bv_tac" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.BV.bv_tac" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.BV.bv_tac (plugin)" - (FStar_Tactics_Native.from_tactic_1 bv_tac) - FStar_Syntax_Embeddings.e_unit FStar_Syntax_Embeddings.e_unit - psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 bv_tac) + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (bv_tac_lt : Prims.int -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun n -> FStar_Tactics_V2_Derived.focus @@ -1535,7 +1535,7 @@ let (bv_tac_lt : Prims.int -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___2 -> FStar_Tactics_NamedView.pack (FStar_Tactics_NamedView.Tv_Const - (FStar_Reflection_V2_Data.C_Int n)))) in + (FStarC_Reflection_V2_Data.C_Int n)))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1555,15 +1555,15 @@ let (bv_tac_lt : Prims.int -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> FStar_Reflection_V2_Derived.mk_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "BV"; "Lemmas"; "trans_lt2"]))) - [(nn, FStar_Reflection_V2_Data.Q_Implicit)])) in + [(nn, FStarC_Reflection_V2_Data.Q_Implicit)])) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1648,7 +1648,7 @@ let (bv_tac_lt : Prims.int -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___8 -> (fun uu___8 -> let uu___9 = - FStar_Tactics_V2_Builtins.set_options + FStarC_Tactics_V2_Builtins.set_options "--smtencoding.elim_box true" in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1683,16 +1683,16 @@ let (bv_tac_lt : Prims.int -> (unit, unit) FStar_Tactics_Effect.tac_repr) = uu___8))) uu___6))) uu___4))) uu___3))) uu___2)) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.BV.bv_tac_lt" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.BV.bv_tac_lt" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.BV.bv_tac_lt (plugin)" - (FStar_Tactics_Native.from_tactic_1 bv_tac_lt) - FStar_Syntax_Embeddings.e_int FStar_Syntax_Embeddings.e_unit + (FStarC_Tactics_Native.from_tactic_1 bv_tac_lt) + FStarC_Syntax_Embeddings.e_int FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (to_bv_tac : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> @@ -1700,9 +1700,9 @@ let (to_bv_tac : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___1 -> let uu___2 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "BV"; "Lemmas"; "eq_to_bv"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1720,9 +1720,9 @@ let (to_bv_tac : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___3 -> let uu___4 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "BV"; "Lemmas"; "trans"]))) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1764,14 +1764,14 @@ let (to_bv_tac : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = Obj.magic (arith_to_bv_tac ())) uu___7))) uu___5))) uu___3)) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.BV.to_bv_tac" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.BV.to_bv_tac" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.BV.to_bv_tac (plugin)" - (FStar_Tactics_Native.from_tactic_1 to_bv_tac) - FStar_Syntax_Embeddings.e_unit FStar_Syntax_Embeddings.e_unit - psc ncb us args) \ No newline at end of file + (FStarC_Tactics_Native.from_tactic_1 to_bv_tac) + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit psc ncb us args) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_BreakVC.ml b/ocaml/fstar-lib/generated/FStar_Tactics_BreakVC.ml index 82e2d99d4c7..f5cfccf40a3 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_BreakVC.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_BreakVC.ml @@ -3,7 +3,7 @@ type ('ps, 'p) break_wp' = unit FStar_Pervasives.spinoff let (post : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> let uu___1 = - FStar_Tactics_V2_Builtins.norm + FStarC_Tactics_V2_Builtins.norm [FStar_Pervasives.delta_fully ["FStar.Tactics.BreakVC.mono_lem"; "FStar.Tactics.BreakVC.break_wp'"]] in diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_Canon.ml b/ocaml/fstar-lib/generated/FStar_Tactics_Canon.ml index 3f0f8af9ef2..f3e95f91d7d 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_Canon.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_Canon.ml @@ -6,9 +6,9 @@ let (step : fun t -> let uu___ = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Canon"; "Lemmas"; "trans"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -69,7 +69,7 @@ let rec (canon_point : FStar_Reflection_V2_Arith.Lit b) -> let uu___1 = - FStar_Tactics_V2_Builtins.norm [FStar_Pervasives.primops] in + FStarC_Tactics_V2_Builtins.norm [FStar_Pervasives.primops] in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -115,7 +115,7 @@ let rec (canon_point : FStar_Reflection_V2_Arith.Lit b) -> let uu___1 = - FStar_Tactics_V2_Builtins.norm + FStarC_Tactics_V2_Builtins.norm [FStar_Pervasives.delta; FStar_Pervasives.primops] in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -160,9 +160,9 @@ let rec (canon_point : | FStar_Reflection_V2_Arith.Neg e1 -> let uu___1 = step_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Canon"; @@ -192,9 +192,9 @@ let rec (canon_point : (a, FStar_Reflection_V2_Arith.Plus (b, c)) -> let uu___1 = step_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Canon"; "Lemmas"; "distr"]))) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -213,9 +213,9 @@ let rec (canon_point : (fun uu___2 -> let uu___3 = step_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Canon"; @@ -302,9 +302,9 @@ let rec (canon_point : (FStar_Reflection_V2_Arith.Plus (a, b), c) -> let uu___1 = step_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Canon"; "Lemmas"; "distl"]))) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -323,9 +323,9 @@ let rec (canon_point : (fun uu___2 -> let uu___3 = step_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Canon"; @@ -412,9 +412,9 @@ let rec (canon_point : (a, FStar_Reflection_V2_Arith.Mult (b, c)) -> let uu___1 = step_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Canon"; @@ -437,9 +437,9 @@ let rec (canon_point : (fun uu___2 -> let uu___3 = step_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Canon"; @@ -523,9 +523,9 @@ let rec (canon_point : (a, FStar_Reflection_V2_Arith.Plus (b, c)) -> let uu___1 = step_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Canon"; @@ -548,9 +548,9 @@ let rec (canon_point : (fun uu___2 -> let uu___3 = step_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Canon"; @@ -637,9 +637,9 @@ let rec (canon_point : then let uu___1 = step_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Canon"; @@ -662,9 +662,9 @@ let rec (canon_point : (fun uu___2 -> let uu___3 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Canon"; @@ -752,9 +752,9 @@ let rec (canon_point : then let uu___1 = step_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Canon"; @@ -777,9 +777,9 @@ let rec (canon_point : (fun uu___2 -> let uu___3 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Canon"; @@ -865,9 +865,9 @@ let rec (canon_point : uu___1 = Prims.int_zero -> let uu___2 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Canon"; @@ -893,9 +893,9 @@ let rec (canon_point : uu___1 = Prims.int_zero -> let uu___2 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Canon"; @@ -922,9 +922,9 @@ let rec (canon_point : then let uu___1 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Canon"; @@ -953,9 +953,9 @@ let rec (canon_point : uu___1 = Prims.int_zero -> let uu___3 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Canon"; @@ -983,9 +983,9 @@ let rec (canon_point : uu___2 = Prims.int_zero -> let uu___3 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Canon"; @@ -1013,9 +1013,9 @@ let rec (canon_point : uu___1 = Prims.int_one -> let uu___2 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Canon"; @@ -1041,9 +1041,9 @@ let rec (canon_point : uu___1 = Prims.int_one -> let uu___2 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Canon"; @@ -1070,9 +1070,9 @@ let rec (canon_point : then let uu___1 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Canon"; @@ -1099,9 +1099,9 @@ let rec (canon_point : | FStar_Reflection_V2_Arith.Minus (a, b) -> let uu___1 = step_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Canon"; @@ -1124,9 +1124,9 @@ let rec (canon_point : (fun uu___2 -> let uu___3 = step_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Canon"; @@ -1248,7 +1248,7 @@ let rec (canon_point : let (canon_point_entry : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> - let uu___1 = FStar_Tactics_V2_Builtins.norm [FStar_Pervasives.primops] in + let uu___1 = FStarC_Tactics_V2_Builtins.norm [FStar_Pervasives.primops] in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1362,7 +1362,7 @@ let (canon_point_entry : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) | uu___6 -> let uu___7 = let uu___8 = - FStar_Tactics_V2_Builtins.term_to_string + FStarC_Tactics_V2_Builtins.term_to_string g in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1413,14 +1413,14 @@ let (canon_point_entry : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) let (canon : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> FStar_Tactics_V2_Derived.pointwise canon_point_entry let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.Canon.canon" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.Canon.canon" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.Canon.canon (plugin)" - (FStar_Tactics_Native.from_tactic_1 canon) - FStar_Syntax_Embeddings.e_unit FStar_Syntax_Embeddings.e_unit - psc ncb us args) \ No newline at end of file + (FStarC_Tactics_Native.from_tactic_1 canon) + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit psc ncb us args) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_CanonCommMonoid.ml b/ocaml/fstar-lib/generated/FStar_Tactics_CanonCommMonoid.ml index 29173aa986b..7520de96eb8 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_CanonCommMonoid.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_CanonCommMonoid.ml @@ -1,10 +1,10 @@ open Prims let (term_eq : - FStar_Reflection_Types.term -> FStar_Reflection_Types.term -> Prims.bool) = - FStar_Reflection_TermEq_Simple.term_eq + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term -> Prims.bool) + = FStar_Reflection_TermEq_Simple.term_eq let (dump : Prims.string -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun m -> - let uu___ = FStar_Tactics_V2_Builtins.debugging () in + let uu___ = FStarC_Tactics_V2_Builtins.debugging () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -19,7 +19,7 @@ let (dump : Prims.string -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___1 -> (fun uu___1 -> if uu___1 - then Obj.magic (Obj.repr (FStar_Tactics_V2_Builtins.dump m)) + then Obj.magic (Obj.repr (FStarC_Tactics_V2_Builtins.dump m)) else Obj.magic (Obj.repr @@ -142,7 +142,7 @@ let rec (where_aux : Obj.magic (Obj.repr (let uu___ = - FStar_Tactics_V2_Builtins.term_eq_old x x' in + FStarC_Tactics_V2_Builtins.term_eq_old x x' in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -465,12 +465,12 @@ let rec reification_aux : | (FStar_Tactics_NamedView.Tv_FVar fv, (t1, - FStar_Reflection_V2_Data.Q_Explicit):: + FStarC_Reflection_V2_Data.Q_Explicit):: (t2, - FStar_Reflection_V2_Data.Q_Explicit)::[]) + FStarC_Reflection_V2_Data.Q_Explicit)::[]) -> let uu___5 = - FStar_Tactics_V2_Builtins.term_eq_old + FStarC_Tactics_V2_Builtins.term_eq_old (FStar_Tactics_NamedView.pack (FStar_Tactics_NamedView.Tv_FVar fv)) mult in @@ -583,7 +583,7 @@ let rec reification_aux : uu___6)) | (uu___5, uu___6) -> let uu___7 = - FStar_Tactics_V2_Builtins.term_eq_old + FStarC_Tactics_V2_Builtins.term_eq_old t unit in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -820,7 +820,7 @@ let rec (term_mem : | hd::tl -> Obj.magic (Obj.repr - (let uu___1 = FStar_Tactics_V2_Builtins.term_eq_old hd x in + (let uu___1 = FStarC_Tactics_V2_Builtins.term_eq_old hd x in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -892,7 +892,7 @@ let (unfold_topdown : (fun uu___2 -> fun uu___3 -> let uu___4 = - FStar_Tactics_V2_Builtins.norm + FStarC_Tactics_V2_Builtins.norm [FStar_Pervasives.delta] in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -954,11 +954,11 @@ let rec quote_list : (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> FStar_Reflection_V2_Derived.mk_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "Nil"]))) - [(ta, FStar_Reflection_V2_Data.Q_Implicit)]))) + [(ta, FStarC_Reflection_V2_Data.Q_Implicit)]))) | x::xs' -> Obj.magic (Obj.repr @@ -988,7 +988,7 @@ let rec quote_list : FStar_Tactics_Effect.lift_div_tac (fun uu___5 -> (uu___4, - FStar_Reflection_V2_Data.Q_Explicit))) in + FStarC_Reflection_V2_Data.Q_Explicit))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1035,7 +1035,7 @@ let rec quote_list : FStar_Tactics_Effect.lift_div_tac (fun uu___8 -> (uu___7, - FStar_Reflection_V2_Data.Q_Explicit))) in + FStarC_Reflection_V2_Data.Q_Explicit))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1102,7 +1102,7 @@ let rec quote_list : FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> (ta, - FStar_Reflection_V2_Data.Q_Implicit) + FStarC_Reflection_V2_Data.Q_Implicit) :: uu___2)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1122,9 +1122,9 @@ let rec quote_list : FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> FStar_Reflection_V2_Derived.mk_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "Cons"]))) uu___1))))) uu___2 uu___1 uu___ let quote_vm : @@ -1180,7 +1180,7 @@ let quote_vm : FStar_Tactics_Effect.lift_div_tac (fun uu___8 -> (uu___7, - FStar_Reflection_V2_Data.Q_Explicit))) in + FStarC_Reflection_V2_Data.Q_Explicit))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1228,7 +1228,7 @@ let quote_vm : FStar_Tactics_Effect.lift_div_tac (fun uu___11 -> (uu___10, - FStar_Reflection_V2_Data.Q_Explicit))) in + FStarC_Reflection_V2_Data.Q_Explicit))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1295,7 +1295,7 @@ let quote_vm : FStar_Tactics_Effect.lift_div_tac (fun uu___6 -> (tb, - FStar_Reflection_V2_Data.Q_Implicit) + FStarC_Reflection_V2_Data.Q_Implicit) :: uu___5)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1314,7 +1314,8 @@ let quote_vm : (fun uu___4 -> FStar_Tactics_Effect.lift_div_tac (fun uu___5 -> - (ta, FStar_Reflection_V2_Data.Q_Implicit) + (ta, + FStarC_Reflection_V2_Data.Q_Implicit) :: uu___4)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1334,9 +1335,9 @@ let quote_vm : FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> FStar_Reflection_V2_Derived.mk_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Pervasives"; "Native"; @@ -1360,9 +1361,9 @@ let quote_vm : (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> FStar_Reflection_V2_Derived.mk_e_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Pervasives"; "Native"; @@ -1420,7 +1421,7 @@ let quote_vm : FStar_Tactics_Effect.lift_div_tac (fun uu___11 -> (uu___10, - FStar_Reflection_V2_Data.Q_Explicit))) in + FStarC_Reflection_V2_Data.Q_Explicit))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1466,10 +1467,10 @@ let quote_vm : (fun uu___9 -> ((FStar_Tactics_NamedView.pack (FStar_Tactics_NamedView.Tv_Const - (FStar_Reflection_V2_Data.C_Int + (FStarC_Reflection_V2_Data.C_Int (FStar_Pervasives_Native.fst p)))), - FStar_Reflection_V2_Data.Q_Explicit) + FStarC_Reflection_V2_Data.Q_Explicit) :: uu___8)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1493,7 +1494,7 @@ let quote_vm : FStar_Tactics_Effect.lift_div_tac (fun uu___8 -> (t_a_star_b, - FStar_Reflection_V2_Data.Q_Implicit) + FStarC_Reflection_V2_Data.Q_Implicit) :: uu___7)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1516,12 +1517,12 @@ let quote_vm : (fun uu___6 -> FStar_Tactics_Effect.lift_div_tac (fun uu___7 -> - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "nat"]))), - FStar_Reflection_V2_Data.Q_Implicit) + FStarC_Reflection_V2_Data.Q_Implicit) :: uu___6)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1545,9 +1546,9 @@ let quote_vm : FStar_Tactics_Effect.lift_div_tac (fun uu___6 -> FStar_Reflection_V2_Derived.mk_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Pervasives"; "Native"; @@ -1579,16 +1580,16 @@ let quote_vm : (FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> FStar_Reflection_V2_Derived.mk_e_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Pervasives"; "Native"; "tuple2"]))) - [FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + [FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "nat"])); t_a_star_b])) in @@ -1670,28 +1671,28 @@ let quote_vm : (fun uu___6 -> FStar_Reflection_V2_Derived.mk_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Pervasives"; "Native"; "Mktuple2"]))) [ ((FStar_Reflection_V2_Derived.mk_e_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "list"]))) [tyentry]), - FStar_Reflection_V2_Data.Q_Implicit); + FStarC_Reflection_V2_Data.Q_Implicit); (t_a_star_b, - FStar_Reflection_V2_Data.Q_Implicit); + FStarC_Reflection_V2_Data.Q_Implicit); (tlist, - FStar_Reflection_V2_Data.Q_Explicit); + FStarC_Reflection_V2_Data.Q_Explicit); (tpair, - FStar_Reflection_V2_Data.Q_Explicit)])))) + FStarC_Reflection_V2_Data.Q_Explicit)])))) uu___5))) uu___4))) uu___3))) uu___2))) uu___1) @@ -1706,9 +1707,9 @@ let rec (quote_exp : (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "CanonCommMonoid"; "Unit"]))))) | Var x -> Obj.magic @@ -1716,16 +1717,16 @@ let rec (quote_exp : (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> FStar_Reflection_V2_Derived.mk_e_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "CanonCommMonoid"; "Var"]))) [FStar_Tactics_NamedView.pack (FStar_Tactics_NamedView.Tv_Const - (FStar_Reflection_V2_Data.C_Int x))]))) + (FStarC_Reflection_V2_Data.C_Int x))]))) | Mult (e1, e2) -> Obj.magic (Obj.repr @@ -1811,9 +1812,9 @@ let rec (quote_exp : FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> FStar_Reflection_V2_Derived.mk_e_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "CanonCommMonoid"; @@ -1857,7 +1858,7 @@ let canon_monoid_aux : fun def -> fun tp -> fun tpc -> - let uu___ = FStar_Tactics_V2_Builtins.norm [] in + let uu___ = FStarC_Tactics_V2_Builtins.norm [] in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1934,7 +1935,7 @@ let canon_monoid_aux : Obj.magic (Obj.repr (let uu___4 = - FStar_Tactics_V2_Builtins.term_eq_old + FStarC_Tactics_V2_Builtins.term_eq_old t ta in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -2105,54 +2106,54 @@ let canon_monoid_aux : uu___12 -> FStar_Reflection_V2_Derived.mk_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "eq2"]))) [ (ta, - FStar_Reflection_V2_Data.Q_Implicit); + FStarC_Reflection_V2_Data.Q_Implicit); ((FStar_Reflection_V2_Derived.mk_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "CanonCommMonoid"; "mdenote"]))) [ (ta, - FStar_Reflection_V2_Data.Q_Implicit); + FStarC_Reflection_V2_Data.Q_Implicit); (tb, - FStar_Reflection_V2_Data.Q_Implicit); + FStarC_Reflection_V2_Data.Q_Implicit); (tm, - FStar_Reflection_V2_Data.Q_Explicit); + FStarC_Reflection_V2_Data.Q_Explicit); (tvm, - FStar_Reflection_V2_Data.Q_Explicit); + FStarC_Reflection_V2_Data.Q_Explicit); (tr1, - FStar_Reflection_V2_Data.Q_Explicit)]), - FStar_Reflection_V2_Data.Q_Explicit); + FStarC_Reflection_V2_Data.Q_Explicit)]), + FStarC_Reflection_V2_Data.Q_Explicit); ((FStar_Reflection_V2_Derived.mk_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "CanonCommMonoid"; "mdenote"]))) [ (ta, - FStar_Reflection_V2_Data.Q_Implicit); + FStarC_Reflection_V2_Data.Q_Implicit); (tb, - FStar_Reflection_V2_Data.Q_Implicit); + FStarC_Reflection_V2_Data.Q_Implicit); (tm, - FStar_Reflection_V2_Data.Q_Explicit); + FStarC_Reflection_V2_Data.Q_Explicit); (tvm, - FStar_Reflection_V2_Data.Q_Explicit); + FStarC_Reflection_V2_Data.Q_Explicit); (tr2, - FStar_Reflection_V2_Data.Q_Explicit)]), - FStar_Reflection_V2_Data.Q_Explicit)])) in + FStarC_Reflection_V2_Data.Q_Explicit)]), + FStarC_Reflection_V2_Data.Q_Explicit)])) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -2213,22 +2214,22 @@ let canon_monoid_aux : FStar_Tactics_MApply.mapply FStar_Tactics_MApply.termable_term (FStar_Reflection_V2_Derived.mk_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "CanonCommMonoid"; "monoid_reflect"]))) [ (ta, - FStar_Reflection_V2_Data.Q_Implicit); + FStarC_Reflection_V2_Data.Q_Implicit); (tb, - FStar_Reflection_V2_Data.Q_Implicit); + FStarC_Reflection_V2_Data.Q_Implicit); (tp, - FStar_Reflection_V2_Data.Q_Explicit); + FStarC_Reflection_V2_Data.Q_Explicit); (tpc, - FStar_Reflection_V2_Data.Q_Explicit)]) in + FStarC_Reflection_V2_Data.Q_Explicit)]) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -2259,16 +2260,16 @@ let canon_monoid_aux : = unfold_topdown [ - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "CanonCommMonoid"; "canon"])); - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "CanonCommMonoid"; @@ -2301,7 +2302,7 @@ let canon_monoid_aux : uu___17 -> Obj.magic - (FStar_Tactics_V2_Builtins.norm + (FStarC_Tactics_V2_Builtins.norm [ FStar_Pervasives.delta_only ["FStar.Tactics.CanonCommMonoid.canon"; @@ -2601,7 +2602,7 @@ let canon_monoid_with : Obj.magic (canon_monoid_aux uu___1 - FStar_Tactics_V2_Builtins.unquote + FStarC_Tactics_V2_Builtins.unquote (fun uu___14 -> diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_CanonCommMonoidSimple.ml b/ocaml/fstar-lib/generated/FStar_Tactics_CanonCommMonoidSimple.ml index 023a95d3ab0..3ffc6be99d4 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_CanonCommMonoidSimple.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_CanonCommMonoidSimple.ml @@ -1,12 +1,12 @@ open Prims let (term_eq : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> (Prims.bool, unit) FStar_Tactics_Effect.tac_repr) - = FStar_Tactics_V2_Builtins.term_eq_old + = FStarC_Tactics_V2_Builtins.term_eq_old let (dump : Prims.string -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun m -> - let uu___ = FStar_Tactics_V2_Builtins.debugging () in + let uu___ = FStarC_Tactics_V2_Builtins.debugging () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -21,7 +21,7 @@ let (dump : Prims.string -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___1 -> (fun uu___1 -> if uu___1 - then Obj.magic (Obj.repr (FStar_Tactics_V2_Builtins.dump m)) + then Obj.magic (Obj.repr (FStarC_Tactics_V2_Builtins.dump m)) else Obj.magic (Obj.repr @@ -269,7 +269,7 @@ let rec reification_aux : (fun vfresh -> let uu___7 = - FStar_Tactics_V2_Builtins.unquote + FStarC_Tactics_V2_Builtins.unquote t1 in Obj.magic ( @@ -377,9 +377,9 @@ let rec reification_aux : | (FStar_Tactics_NamedView.Tv_FVar fv, (t1, - FStar_Reflection_V2_Data.Q_Explicit):: + FStarC_Reflection_V2_Data.Q_Explicit):: (t2, - FStar_Reflection_V2_Data.Q_Explicit)::[]) + FStarC_Reflection_V2_Data.Q_Explicit)::[]) -> let uu___5 = term_eq @@ -677,7 +677,7 @@ let canon_monoid : (unit, unit) FStar_Tactics_Effect.tac_repr = fun m -> - let uu___ = FStar_Tactics_V2_Builtins.norm [] in + let uu___ = FStarC_Tactics_V2_Builtins.norm [] in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -898,7 +898,7 @@ let canon_monoid : uu___15 -> Obj.magic - (FStar_Tactics_V2_Builtins.term_to_string + (FStarC_Tactics_V2_Builtins.term_to_string uu___15)) uu___15) in FStar_Tactics_Effect.tac_bind @@ -1059,9 +1059,9 @@ let canon_monoid : let uu___15 = FStar_Tactics_V2_Derived.apply - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "CanonCommMonoidSimple"; @@ -1093,7 +1093,7 @@ let canon_monoid : uu___16 -> Obj.magic - (FStar_Tactics_V2_Builtins.norm + (FStarC_Tactics_V2_Builtins.norm [ FStar_Pervasives.delta_only ["FStar.Tactics.CanonCommMonoidSimple.canon"; diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_CanonCommMonoidSimple_Equiv.ml b/ocaml/fstar-lib/generated/FStar_Tactics_CanonCommMonoidSimple_Equiv.ml index 0f7cf6b8c22..42cf1d19ce8 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_CanonCommMonoidSimple_Equiv.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_CanonCommMonoidSimple_Equiv.ml @@ -1,7 +1,7 @@ open Prims let (term_eq : - FStar_Reflection_Types.term -> FStar_Reflection_Types.term -> Prims.bool) = - FStar_Reflection_TermEq_Simple.term_eq + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term -> Prims.bool) + = FStar_Reflection_TermEq_Simple.term_eq type atom = Prims.int type exp = | Unit @@ -287,9 +287,9 @@ let rec (reification_aux : match uu___3 with | (FStar_Tactics_NamedView.Tv_FVar fv, (t1, - FStar_Reflection_V2_Data.Q_Explicit):: + FStarC_Reflection_V2_Data.Q_Explicit):: (t2, - FStar_Reflection_V2_Data.Q_Explicit)::[]) + FStarC_Reflection_V2_Data.Q_Explicit)::[]) -> Obj.magic (Obj.repr @@ -394,17 +394,17 @@ let (reification : [FStar_Pervasives.iota; FStar_Pervasives.zeta; FStar_Pervasives.delta] - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Algebra"; "CommMonoid"; "Equiv"; "__proj__CM__item__mult"]))), - (m, FStar_Reflection_V2_Data.Q_Explicit)))) in + (m, FStarC_Reflection_V2_Data.Q_Explicit)))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -426,17 +426,17 @@ let (reification : [FStar_Pervasives.iota; FStar_Pervasives.zeta; FStar_Pervasives.delta] - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Algebra"; "CommMonoid"; "Equiv"; "__proj__CM__item__unit"]))), - (m, FStar_Reflection_V2_Data.Q_Explicit)))) in + (m, FStarC_Reflection_V2_Data.Q_Explicit)))) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -493,9 +493,9 @@ let rec (repeat_cong_right_identity : FStar_Tactics_V2_Derived.or_else (fun uu___ -> FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Algebra"; "CommMonoid"; @@ -504,17 +504,17 @@ let rec (repeat_cong_right_identity : (fun uu___ -> let uu___1 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Algebra"; "CommMonoid"; "Equiv"; "__proj__CM__item__congruence"]))), - (m, FStar_Reflection_V2_Data.Q_Explicit)))) in + (m, FStarC_Reflection_V2_Data.Q_Explicit)))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -551,18 +551,18 @@ let rec (repeat_cong_right_identity : (fun uu___4 -> let uu___5 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Algebra"; "CommMonoid"; "Equiv"; "__proj__EQ__item__reflexivity"]))), (eq, - FStar_Reflection_V2_Data.Q_Explicit)))) in + FStarC_Reflection_V2_Data.Q_Explicit)))) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -594,41 +594,41 @@ let rec (convert_map : fun m -> match m with | [] -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv ["Prims"; "Nil"])) + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "Nil"])) | (a, t)::ps -> let a1 = FStar_Tactics_NamedView.pack (FStar_Tactics_NamedView.Tv_Const - (FStar_Reflection_V2_Data.C_Int a)) in + (FStarC_Reflection_V2_Data.C_Int a)) in let uu___ = convert_map ps in let uu___1 = t in let uu___2 = a1 in - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "Cons"]))), - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Pervasives"; "Native"; "Mktuple2"]))), (uu___2, - FStar_Reflection_V2_Data.Q_Explicit)))), - (uu___1, FStar_Reflection_V2_Data.Q_Explicit)))), - FStar_Reflection_V2_Data.Q_Explicit)))), - (uu___, FStar_Reflection_V2_Data.Q_Explicit))) + FStarC_Reflection_V2_Data.Q_Explicit)))), + (uu___1, FStarC_Reflection_V2_Data.Q_Explicit)))), + FStarC_Reflection_V2_Data.Q_Explicit)))), + (uu___, FStarC_Reflection_V2_Data.Q_Explicit))) let (convert_am : FStar_Tactics_NamedView.term amap -> FStar_Tactics_NamedView.term) = fun am -> @@ -637,23 +637,23 @@ let (convert_am : | (map, def) -> let uu___1 = def in let uu___2 = convert_map map in - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Pervasives"; "Native"; "Mktuple2"]))), - (uu___2, FStar_Reflection_V2_Data.Q_Explicit)))), - (uu___1, FStar_Reflection_V2_Data.Q_Explicit))) + (uu___2, FStarC_Reflection_V2_Data.Q_Explicit)))), + (uu___1, FStarC_Reflection_V2_Data.Q_Explicit))) let rec (quote_exp : exp -> FStar_Tactics_NamedView.term) = fun e -> match e with | Unit -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "CanonCommMonoidSimple"; @@ -662,35 +662,36 @@ let rec (quote_exp : exp -> FStar_Tactics_NamedView.term) = | Mult (e1, e2) -> let uu___ = quote_exp e2 in let uu___1 = quote_exp e1 in - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "CanonCommMonoidSimple"; "Equiv"; "Mult"]))), - (uu___1, FStar_Reflection_V2_Data.Q_Explicit)))), - (uu___, FStar_Reflection_V2_Data.Q_Explicit))) + (uu___1, FStarC_Reflection_V2_Data.Q_Explicit)))), + (uu___, FStarC_Reflection_V2_Data.Q_Explicit))) | Atom n -> let nt = FStar_Tactics_NamedView.pack (FStar_Tactics_NamedView.Tv_Const - (FStar_Reflection_V2_Data.C_Int n)) in - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Data.C_Int n)) in + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "CanonCommMonoidSimple"; "Equiv"; - "Atom"]))), (nt, FStar_Reflection_V2_Data.Q_Explicit))) + "Atom"]))), + (nt, FStarC_Reflection_V2_Data.Q_Explicit))) let (canon_lhs_rhs : FStar_Tactics_NamedView.term -> FStar_Tactics_NamedView.term -> @@ -707,17 +708,17 @@ let (canon_lhs_rhs : [FStar_Pervasives.iota; FStar_Pervasives.zeta; FStar_Pervasives.delta] - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Algebra"; "CommMonoid"; "Equiv"; "__proj__CM__item__unit"]))), - (m, FStar_Reflection_V2_Data.Q_Explicit)))) in + (m, FStarC_Reflection_V2_Data.Q_Explicit)))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -904,72 +905,72 @@ let (canon_lhs_rhs : let uu___10 = FStar_Tactics_V2_Derived.change_sq - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Algebra"; "CommMonoid"; "Equiv"; "__proj__EQ__item__eq"]))), (eq, - FStar_Reflection_V2_Data.Q_Explicit)))), - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Data.Q_Explicit)))), + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "CanonCommMonoidSimple"; "Equiv"; "mdenote"]))), (eq, - FStar_Reflection_V2_Data.Q_Explicit)))), + FStarC_Reflection_V2_Data.Q_Explicit)))), (m, - FStar_Reflection_V2_Data.Q_Explicit)))), + FStarC_Reflection_V2_Data.Q_Explicit)))), (am3, - FStar_Reflection_V2_Data.Q_Explicit)))), + FStarC_Reflection_V2_Data.Q_Explicit)))), (r11, - FStar_Reflection_V2_Data.Q_Explicit)))), - FStar_Reflection_V2_Data.Q_Explicit)))), - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Data.Q_Explicit)))), + FStarC_Reflection_V2_Data.Q_Explicit)))), + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "CanonCommMonoidSimple"; "Equiv"; "mdenote"]))), (eq, - FStar_Reflection_V2_Data.Q_Explicit)))), + FStarC_Reflection_V2_Data.Q_Explicit)))), (m, - FStar_Reflection_V2_Data.Q_Explicit)))), + FStarC_Reflection_V2_Data.Q_Explicit)))), (am3, - FStar_Reflection_V2_Data.Q_Explicit)))), + FStarC_Reflection_V2_Data.Q_Explicit)))), (r21, - FStar_Reflection_V2_Data.Q_Explicit)))), - FStar_Reflection_V2_Data.Q_Explicit)))) in + FStarC_Reflection_V2_Data.Q_Explicit)))), + FStarC_Reflection_V2_Data.Q_Explicit)))) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -999,9 +1000,9 @@ let (canon_lhs_rhs : let uu___12 = FStar_Tactics_V2_Derived.apply - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "CanonCommMonoidSimple"; @@ -1035,7 +1036,7 @@ let (canon_lhs_rhs : -> let uu___14 = - FStar_Tactics_V2_Builtins.norm + FStarC_Tactics_V2_Builtins.norm [FStar_Pervasives.iota; FStar_Pervasives.zeta; FStar_Pervasives.delta_only @@ -1086,18 +1087,18 @@ let (canon_lhs_rhs : uu___16 -> FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Algebra"; "CommMonoid"; "Equiv"; "__proj__EQ__item__reflexivity"]))), (eq, - FStar_Reflection_V2_Data.Q_Explicit))))) + FStarC_Reflection_V2_Data.Q_Explicit))))) (fun uu___16 -> @@ -1119,7 +1120,7 @@ let (canon_monoid : fun eq -> fun m -> let uu___ = - FStar_Tactics_V2_Builtins.norm + FStarC_Tactics_V2_Builtins.norm [FStar_Pervasives.iota; FStar_Pervasives.zeta] in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1231,9 +1232,9 @@ let (canon_monoid : with | ((lhs, - FStar_Reflection_V2_Data.Q_Explicit), + FStarC_Reflection_V2_Data.Q_Explicit), (rhs, - FStar_Reflection_V2_Data.Q_Explicit)) + FStarC_Reflection_V2_Data.Q_Explicit)) -> Obj.repr (canon_lhs_rhs @@ -1257,16 +1258,16 @@ let (canon_monoid : "Goal should be squash applied to a binary relation")))) uu___4))) uu___3))) uu___1) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.CanonCommMonoidSimple.Equiv.canon_monoid" (Prims.of_int (3)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_2 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_2 "FStar.Tactics.CanonCommMonoidSimple.Equiv.canon_monoid (plugin)" - (FStar_Tactics_Native.from_tactic_2 canon_monoid) - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_term - FStar_Syntax_Embeddings.e_unit psc ncb us args) \ No newline at end of file + (FStarC_Tactics_Native.from_tactic_2 canon_monoid) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Syntax_Embeddings.e_unit psc ncb us args) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_CanonCommSemiring.ml b/ocaml/fstar-lib/generated/FStar_Tactics_CanonCommSemiring.ml index 601a17d10c1..8a86d9a7be4 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_CanonCommSemiring.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_CanonCommSemiring.ml @@ -1,7 +1,7 @@ open Prims let (term_eq : - FStar_Reflection_Types.term -> FStar_Reflection_Types.term -> Prims.bool) = - FStar_Reflection_TermEq_Simple.term_eq + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term -> Prims.bool) + = FStar_Reflection_TermEq_Simple.term_eq type ('a, 'cmuadd, 'cmumult) distribute_left_lemma = unit type ('a, 'cmuadd, 'cmumult) distribute_right_lemma = unit type ('a, 'cmuadd, 'cmumult) mult_zero_l_lemma = unit @@ -332,11 +332,11 @@ let rec quote_list : (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> FStar_Reflection_V2_Derived.mk_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "Nil"]))) - [(ta, FStar_Reflection_V2_Data.Q_Implicit)]))) + [(ta, FStarC_Reflection_V2_Data.Q_Implicit)]))) | x::xs' -> Obj.magic (Obj.repr @@ -366,7 +366,7 @@ let rec quote_list : FStar_Tactics_Effect.lift_div_tac (fun uu___5 -> (uu___4, - FStar_Reflection_V2_Data.Q_Explicit))) in + FStarC_Reflection_V2_Data.Q_Explicit))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -413,7 +413,7 @@ let rec quote_list : FStar_Tactics_Effect.lift_div_tac (fun uu___8 -> (uu___7, - FStar_Reflection_V2_Data.Q_Explicit))) in + FStarC_Reflection_V2_Data.Q_Explicit))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -480,7 +480,7 @@ let rec quote_list : FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> (ta, - FStar_Reflection_V2_Data.Q_Implicit) + FStarC_Reflection_V2_Data.Q_Implicit) :: uu___2)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -500,9 +500,9 @@ let rec quote_list : FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> FStar_Reflection_V2_Derived.mk_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "Cons"]))) uu___1))))) uu___2 uu___1 uu___ let quote_vm : @@ -551,7 +551,7 @@ let quote_vm : FStar_Tactics_Effect.lift_div_tac (fun uu___9 -> (uu___8, - FStar_Reflection_V2_Data.Q_Explicit))) in + FStarC_Reflection_V2_Data.Q_Explicit))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -592,9 +592,9 @@ let quote_vm : (fun uu___7 -> ((FStar_Tactics_NamedView.pack (FStar_Tactics_NamedView.Tv_Const - (FStar_Reflection_V2_Data.C_Int + (FStarC_Reflection_V2_Data.C_Int (FStar_Pervasives_Native.fst p)))), - FStar_Reflection_V2_Data.Q_Explicit) + FStarC_Reflection_V2_Data.Q_Explicit) :: uu___6)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -613,7 +613,7 @@ let quote_vm : (fun uu___5 -> FStar_Tactics_Effect.lift_div_tac (fun uu___6 -> - (ta, FStar_Reflection_V2_Data.Q_Implicit) + (ta, FStarC_Reflection_V2_Data.Q_Implicit) :: uu___5)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -632,11 +632,11 @@ let quote_vm : (fun uu___4 -> FStar_Tactics_Effect.lift_div_tac (fun uu___5 -> - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "nat"]))), - FStar_Reflection_V2_Data.Q_Implicit) + FStarC_Reflection_V2_Data.Q_Implicit) :: uu___4)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -656,9 +656,9 @@ let quote_vm : FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> FStar_Reflection_V2_Derived.mk_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Pervasives"; "Native"; @@ -682,16 +682,16 @@ let quote_vm : (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> FStar_Reflection_V2_Derived.mk_e_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Pervasives"; "Native"; "tuple2"]))) - [FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + [FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "nat"])); ta])) in Obj.magic @@ -740,9 +740,9 @@ let quote_vm : (FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> FStar_Reflection_V2_Derived.mk_e_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "list"]))) [tyentry])) in Obj.magic @@ -800,7 +800,7 @@ let quote_vm : uu___11 -> (uu___10, - FStar_Reflection_V2_Data.Q_Explicit))) in + FStarC_Reflection_V2_Data.Q_Explicit))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -846,7 +846,7 @@ let quote_vm : FStar_Tactics_Effect.lift_div_tac (fun uu___9 -> (tlist, - FStar_Reflection_V2_Data.Q_Explicit) + FStarC_Reflection_V2_Data.Q_Explicit) :: uu___8)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -870,7 +870,7 @@ let quote_vm : FStar_Tactics_Effect.lift_div_tac (fun uu___8 -> (ta, - FStar_Reflection_V2_Data.Q_Implicit) + FStarC_Reflection_V2_Data.Q_Implicit) :: uu___7)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -894,7 +894,7 @@ let quote_vm : FStar_Tactics_Effect.lift_div_tac (fun uu___7 -> (tylist, - FStar_Reflection_V2_Data.Q_Implicit) + FStarC_Reflection_V2_Data.Q_Implicit) :: uu___6)) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -919,9 +919,9 @@ let quote_vm : FStar_Tactics_Effect.lift_div_tac (fun uu___6 -> FStar_Reflection_V2_Derived.mk_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Pervasives"; "Native"; @@ -1091,7 +1091,7 @@ let rec interp_p : 'a . 'a cr -> 'a vmap -> 'a polynomial -> 'a = | Popp p1 -> __proj__CR__item__opp r (interp_p r vm p1) let (ddump : Prims.string -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun m -> - let uu___ = FStar_Tactics_V2_Builtins.debugging () in + let uu___ = FStarC_Tactics_V2_Builtins.debugging () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1106,7 +1106,7 @@ let (ddump : Prims.string -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___1 -> (fun uu___1 -> if uu___1 - then Obj.magic (Obj.repr (FStar_Tactics_V2_Builtins.dump m)) + then Obj.magic (Obj.repr (FStarC_Tactics_V2_Builtins.dump m)) else Obj.magic (Obj.repr @@ -1626,7 +1626,7 @@ let (steps : FStar_Pervasives.norm_step Prims.list) = "FStar.List.Tot.Base.op_At"; "FStar.List.Tot.Base.append"]] let (canon_norm : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = - fun uu___ -> FStar_Tactics_V2_Builtins.norm steps + fun uu___ -> FStarC_Tactics_V2_Builtins.norm steps let reification : 'a . (FStar_Tactics_NamedView.term -> ('a, unit) FStar_Tactics_Effect.tac_repr) @@ -1908,7 +1908,7 @@ let rec quote_polynomial : FStar_Tactics_Effect.lift_div_tac (fun uu___5 -> (uu___4, - FStar_Reflection_V2_Data.Q_Explicit))) in + FStarC_Reflection_V2_Data.Q_Explicit))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1952,7 +1952,7 @@ let rec quote_polynomial : FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> (ta, - FStar_Reflection_V2_Data.Q_Implicit) + FStarC_Reflection_V2_Data.Q_Implicit) :: uu___2)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1972,9 +1972,9 @@ let rec quote_polynomial : FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> FStar_Reflection_V2_Derived.mk_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "CanonCommSemiring"; @@ -1985,16 +1985,16 @@ let rec quote_polynomial : (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> FStar_Reflection_V2_Derived.mk_e_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "CanonCommSemiring"; "Pvar"]))) [FStar_Tactics_NamedView.pack (FStar_Tactics_NamedView.Tv_Const - (FStar_Reflection_V2_Data.C_Int x))]))) + (FStarC_Reflection_V2_Data.C_Int x))]))) | Pplus (e1, e2) -> Obj.magic (Obj.repr @@ -2085,9 +2085,9 @@ let rec quote_polynomial : FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> FStar_Reflection_V2_Derived.mk_e_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "CanonCommSemiring"; @@ -2182,9 +2182,9 @@ let rec quote_polynomial : FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> FStar_Reflection_V2_Derived.mk_e_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "CanonCommSemiring"; @@ -2233,9 +2233,9 @@ let rec quote_polynomial : FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> FStar_Reflection_V2_Derived.mk_e_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "CanonCommSemiring"; @@ -2268,7 +2268,7 @@ let canon_semiring_aux : fun munit -> FStar_Tactics_V2_Derived.focus (fun uu___ -> - let uu___1 = FStar_Tactics_V2_Builtins.norm [] in + let uu___1 = FStarC_Tactics_V2_Builtins.norm [] in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2342,31 +2342,31 @@ let canon_semiring_aux : (Obj.repr (let uu___6 = FStar_Tactics_V2_Derived.tcut - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "squash"]))), - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "eq2"]))), (ta, - FStar_Reflection_V2_Data.Q_Implicit)))), + FStarC_Reflection_V2_Data.Q_Implicit)))), (t1, - FStar_Reflection_V2_Data.Q_Explicit)))), + FStarC_Reflection_V2_Data.Q_Explicit)))), (t2, - FStar_Reflection_V2_Data.Q_Explicit)))), - FStar_Reflection_V2_Data.Q_Explicit)))) in + FStarC_Reflection_V2_Data.Q_Explicit)))), + FStarC_Reflection_V2_Data.Q_Explicit)))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2565,41 +2565,41 @@ let canon_semiring_aux : = FStar_Tactics_MApply.mapply FStar_Tactics_MApply.termable_term - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "CanonCommSemiring"; "semiring_reflect"]))), (ta, - FStar_Reflection_V2_Data.Q_Implicit)))), + FStarC_Reflection_V2_Data.Q_Implicit)))), (tr, - FStar_Reflection_V2_Data.Q_Explicit)))), + FStarC_Reflection_V2_Data.Q_Explicit)))), (tvm, - FStar_Reflection_V2_Data.Q_Explicit)))), + FStarC_Reflection_V2_Data.Q_Explicit)))), (te1, - FStar_Reflection_V2_Data.Q_Explicit)))), + FStarC_Reflection_V2_Data.Q_Explicit)))), (te2, - FStar_Reflection_V2_Data.Q_Explicit)))), + FStarC_Reflection_V2_Data.Q_Explicit)))), (t1, - FStar_Reflection_V2_Data.Q_Explicit)))), + FStarC_Reflection_V2_Data.Q_Explicit)))), (t2, - FStar_Reflection_V2_Data.Q_Explicit)))) in + FStarC_Reflection_V2_Data.Q_Explicit)))) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -3079,7 +3079,7 @@ let canon_semiring : 'a . 'a cr -> (unit, unit) FStar_Tactics_Effect.tac_repr Obj.magic (canon_semiring_aux uu___1 - FStar_Tactics_V2_Builtins.unquote + FStarC_Tactics_V2_Builtins.unquote (fun uu___12 -> diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_CanonMonoid.ml b/ocaml/fstar-lib/generated/FStar_Tactics_CanonMonoid.ml index 4602a41c85f..94e6da7a3bf 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_CanonMonoid.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_CanonMonoid.ml @@ -1,10 +1,10 @@ open Prims let (term_eq : - FStar_Reflection_Types.term -> FStar_Reflection_Types.term -> Prims.bool) = - FStar_Reflection_TermEq_Simple.term_eq + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term -> Prims.bool) + = FStar_Reflection_TermEq_Simple.term_eq let (dump : Prims.string -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun m -> - let uu___ = FStar_Tactics_V2_Builtins.debugging () in + let uu___ = FStarC_Tactics_V2_Builtins.debugging () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -19,7 +19,7 @@ let (dump : Prims.string -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___1 -> (fun uu___1 -> if uu___1 - then Obj.magic (Obj.repr (FStar_Tactics_V2_Builtins.dump m)) + then Obj.magic (Obj.repr (FStarC_Tactics_V2_Builtins.dump m)) else Obj.magic (Obj.repr @@ -179,12 +179,12 @@ let rec reification_aux : | (FStar_Tactics_NamedView.Tv_FVar fv, (me1, - FStar_Reflection_V2_Data.Q_Explicit):: + FStarC_Reflection_V2_Data.Q_Explicit):: (me2, - FStar_Reflection_V2_Data.Q_Explicit)::[]) + FStarC_Reflection_V2_Data.Q_Explicit)::[]) -> let uu___5 = - FStar_Tactics_V2_Builtins.term_eq_old + FStarC_Tactics_V2_Builtins.term_eq_old (FStar_Tactics_NamedView.pack (FStar_Tactics_NamedView.Tv_FVar fv)) mult in @@ -276,7 +276,7 @@ let rec reification_aux : uu___8)) else (let uu___8 = - FStar_Tactics_V2_Builtins.unquote + FStarC_Tactics_V2_Builtins.unquote me in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -311,7 +311,7 @@ let rec reification_aux : uu___6)) | (uu___5, uu___6) -> let uu___7 = - FStar_Tactics_V2_Builtins.term_eq_old + FStarC_Tactics_V2_Builtins.term_eq_old me unit in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -347,7 +347,7 @@ let rec reification_aux : (Obj.repr (let uu___10 = - FStar_Tactics_V2_Builtins.unquote + FStarC_Tactics_V2_Builtins.unquote me in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -509,7 +509,7 @@ let canon_monoid : (unit, unit) FStar_Tactics_Effect.tac_repr = fun m -> - let uu___ = FStar_Tactics_V2_Builtins.norm [] in + let uu___ = FStarC_Tactics_V2_Builtins.norm [] in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -661,31 +661,31 @@ let canon_monoid : (fun uu___13 -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "squash"]))), - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "eq2"]))), (uu___12, - FStar_Reflection_V2_Data.Q_Implicit)))), + FStarC_Reflection_V2_Data.Q_Implicit)))), (uu___10, - FStar_Reflection_V2_Data.Q_Explicit)))), + FStarC_Reflection_V2_Data.Q_Explicit)))), (uu___8, - FStar_Reflection_V2_Data.Q_Explicit)))), - FStar_Reflection_V2_Data.Q_Explicit))))))) + FStarC_Reflection_V2_Data.Q_Explicit)))), + FStarC_Reflection_V2_Data.Q_Explicit))))))) uu___10))) uu___8) in FStar_Tactics_Effect.tac_bind @@ -889,9 +889,9 @@ let canon_monoid : let uu___12 = FStar_Tactics_V2_Derived.apply - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "CanonMonoid"; @@ -923,7 +923,7 @@ let canon_monoid : uu___13 -> Obj.magic - (FStar_Tactics_V2_Builtins.norm + (FStarC_Tactics_V2_Builtins.norm [ FStar_Pervasives.delta_only ["FStar.Tactics.CanonMonoid.mldenote"; diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_CheckLN.ml b/ocaml/fstar-lib/generated/FStar_Tactics_CheckLN.ml index a6687ad3019..53843f6bf50 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_CheckLN.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_CheckLN.ml @@ -423,9 +423,9 @@ and (check_comp : = fun c -> match c with - | FStar_Reflection_V2_Data.C_Total typ -> check typ - | FStar_Reflection_V2_Data.C_GTotal typ -> check typ - | FStar_Reflection_V2_Data.C_Lemma (pre, post, pats) -> + | FStarC_Reflection_V2_Data.C_Total typ -> check typ + | FStarC_Reflection_V2_Data.C_GTotal typ -> check typ + | FStarC_Reflection_V2_Data.C_Lemma (pre, post, pats) -> let uu___ = let uu___1 = check pre in FStar_Tactics_Effect.tac_bind @@ -508,7 +508,7 @@ and (check_comp : (fun uu___5 -> false))) else Obj.magic (Obj.repr (check pats))) uu___4)))) uu___1) - | FStar_Reflection_V2_Data.C_Eff (us, nm, res, args, decrs) -> + | FStarC_Reflection_V2_Data.C_Eff (us, nm, res, args, decrs) -> let uu___ = let uu___1 = for_all check_u us in FStar_Tactics_Effect.tac_bind @@ -731,14 +731,14 @@ let (check_ln : (Prims.bool, unit) FStar_Tactics_Effect.tac_repr) = fun t -> check t let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.CheckLN.check_ln" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.CheckLN.check_ln" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.CheckLN.check_ln (plugin)" - (FStar_Tactics_Native.from_tactic_1 check_ln) - FStar_Reflection_V2_Embeddings.e_term - FStar_Syntax_Embeddings.e_bool psc ncb us args) \ No newline at end of file + (FStarC_Tactics_Native.from_tactic_1 check_ln) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Syntax_Embeddings.e_bool psc ncb us args) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_Common.ml b/ocaml/fstar-lib/generated/FStar_Tactics_Common.ml deleted file mode 100644 index b48fa3ef0c1..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Tactics_Common.ml +++ /dev/null @@ -1,23 +0,0 @@ -open Prims -exception NotAListLiteral -let (uu___is_NotAListLiteral : Prims.exn -> Prims.bool) = - fun projectee -> - match projectee with | NotAListLiteral -> true | uu___ -> false -exception TacticFailure of (FStar_Errors_Msg.error_message * - FStar_Compiler_Range_Type.range FStar_Pervasives_Native.option) -let (uu___is_TacticFailure : Prims.exn -> Prims.bool) = - fun projectee -> - match projectee with | TacticFailure uu___ -> true | uu___ -> false -let (__proj__TacticFailure__item__uu___ : - Prims.exn -> - (FStar_Errors_Msg.error_message * FStar_Compiler_Range_Type.range - FStar_Pervasives_Native.option)) - = fun projectee -> match projectee with | TacticFailure uu___ -> uu___ -exception EExn of FStar_Syntax_Syntax.term -let (uu___is_EExn : Prims.exn -> Prims.bool) = - fun projectee -> match projectee with | EExn uu___ -> true | uu___ -> false -let (__proj__EExn__item__uu___ : Prims.exn -> FStar_Syntax_Syntax.term) = - fun projectee -> match projectee with | EExn uu___ -> uu___ -exception SKIP -let (uu___is_SKIP : Prims.exn -> Prims.bool) = - fun projectee -> match projectee with | SKIP -> true | uu___ -> false \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_CtrlRewrite.ml b/ocaml/fstar-lib/generated/FStar_Tactics_CtrlRewrite.ml deleted file mode 100644 index c508850c8fc..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Tactics_CtrlRewrite.ml +++ /dev/null @@ -1,1669 +0,0 @@ -open Prims -type controller_ty = - FStar_Syntax_Syntax.term -> - (Prims.bool * FStar_Tactics_Types.ctrl_flag) FStar_Tactics_Monad.tac -type rewriter_ty = unit FStar_Tactics_Monad.tac -let (rangeof : FStar_Tactics_Types.goal -> FStar_Compiler_Range_Type.range) = - fun g -> - (g.FStar_Tactics_Types.goal_ctx_uvar).FStar_Syntax_Syntax.ctx_uvar_range -let (__do_rewrite : - FStar_Tactics_Types.goal -> - rewriter_ty -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term FStar_Tactics_Monad.tac) - = - fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun g0 -> - fun rewriter -> - fun env -> - fun tm -> - let should_skip = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress tm in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_reify uu___1) -> true - | FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_reflect uu___1) -> true - | FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_range_of) -> true - | FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_set_range_of) -> true - | uu___1 -> false in - if should_skip - then - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () (Obj.magic tm)) - else - (let res = - try - (fun uu___1 -> - match () with - | () -> - FStar_Errors.with_ctx - "While typechecking a subterm for ctrl_rewrite" - (fun uu___2 -> - let uu___3 = - env.FStar_TypeChecker_Env.tc_term - { - FStar_TypeChecker_Env.solver = - (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache - = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ - = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp - = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize - = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars - = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict - = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - true; - FStar_TypeChecker_Env.lax_universes - = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking - = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping - = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of - = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force - = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths - = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook - = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess - = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess - = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info - = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab - = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check - = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl - = - (env.FStar_TypeChecker_Env.missing_decl) - } tm in - FStar_Pervasives_Native.Some uu___3)) - () - with - | FStar_Errors.Error - (FStar_Errors_Codes.Error_LayeredMissingAnnot, - uu___2, uu___3, uu___4) - -> FStar_Pervasives_Native.None - | e -> FStar_Compiler_Effect.raise e in - match res with - | FStar_Pervasives_Native.None -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic tm)) - | FStar_Pervasives_Native.Some (uu___1, lcomp, g) -> - let uu___2 = - let uu___3 = - FStar_TypeChecker_Common.is_pure_or_ghost_lcomp - lcomp in - Prims.op_Negation uu___3 in - if uu___2 - then - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic tm)) - else - (let g1 = - FStar_TypeChecker_Rel.solve_deferred_constraints - env g in - let typ = lcomp.FStar_TypeChecker_Common.res_typ in - let typ1 = - let uu___4 = - let uu___5 = - FStar_Options_Ext.get "__unrefine" in - uu___5 <> "" in - if uu___4 - then - let typ_norm = - FStar_TypeChecker_Normalize.unfold_whnf' - [FStar_TypeChecker_Env.DontUnfoldAttr - [FStar_Parser_Const.do_not_unrefine_attr]] - env typ in - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Syntax_Subst.compress typ_norm in - uu___7.FStar_Syntax_Syntax.n in - FStar_Syntax_Syntax.uu___is_Tm_refine - uu___6 in - (if uu___5 - then - let typ' = - FStar_TypeChecker_Normalize.unfold_whnf' - [FStar_TypeChecker_Env.DontUnfoldAttr - [FStar_Parser_Const.do_not_unrefine_attr]; - FStar_TypeChecker_Env.Unrefine] env - typ_norm in - typ' - else typ) - else typ in - let should_check = - let uu___4 = - FStar_TypeChecker_Common.is_total_lcomp - lcomp in - if uu___4 - then FStar_Pervasives_Native.None - else - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Allow_ghost - "do_rewrite.lhs") in - let uu___4 = - let uu___5 = - FStar_Tactics_Monad.goal_typedness_deps g0 in - FStar_Tactics_Monad.new_uvar "do_rewrite.rhs" - env typ1 should_check uu___5 (rangeof g0) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___4) - (fun uu___5 -> - (fun uu___5 -> - let uu___5 = Obj.magic uu___5 in - match uu___5 with - | (ut, uvar_t) -> - let uu___6 = - FStar_Tactics_Monad.if_verbose - (fun uu___7 -> - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - tm in - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - ut in - FStar_Compiler_Util.print2 - "do_rewrite: making equality\n\t%s ==\n\t%s\n" - uu___8 uu___9) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___6 - (fun uu___7 -> - (fun uu___7 -> - let uu___7 = - Obj.magic uu___7 in - let uu___8 = - let uu___9 = - let uu___10 = - env.FStar_TypeChecker_Env.universe_of - env typ1 in - FStar_Syntax_Util.mk_eq2 - uu___10 typ1 tm - ut in - FStar_Tactics_Monad.add_irrelevant_goal - g0 "do_rewrite.eq" - env uu___9 - FStar_Pervasives_Native.None in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___8 - (fun uu___9 -> - (fun uu___9 -> - let uu___9 - = - Obj.magic - uu___9 in - let uu___10 - = - FStar_Tactics_Monad.focus - rewriter in - Obj.magic - ( - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___10 - (fun - uu___11 - -> - (fun - uu___11 - -> - let uu___11 - = - Obj.magic - uu___11 in - let ut1 = - FStar_TypeChecker_Normalize.reduce_uvar_solutions - env ut in - let uu___12 - = - FStar_Tactics_Monad.if_verbose - (fun - uu___13 - -> - let uu___14 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - tm in - let uu___15 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - ut1 in - FStar_Compiler_Util.print2 - "rewrite_rec: succeeded rewriting\n\t%s to\n\t%s\n" - uu___14 - uu___15) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___12 - (fun - uu___13 - -> - (fun - uu___13 - -> - let uu___13 - = - Obj.magic - uu___13 in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - ut1))) - uu___13))) - uu___11))) - uu___9))) - uu___7))) uu___5))))) - uu___3 uu___2 uu___1 uu___ -let (do_rewrite : - FStar_Tactics_Types.goal -> - rewriter_ty -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term FStar_Tactics_Monad.tac) - = - fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun g0 -> - fun rewriter -> - fun env -> - fun tm -> - let uu___ = - let uu___1 = __do_rewrite g0 rewriter env tm in - FStar_Tactics_Monad.catch uu___1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () (Obj.magic uu___) - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - match uu___1 with - | FStar_Pervasives.Inl - (FStar_Tactics_Common.SKIP) -> - Obj.magic - (Obj.repr - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic tm))) - | FStar_Pervasives.Inl e -> - Obj.magic - (Obj.repr (FStar_Tactics_Monad.traise e)) - | FStar_Pervasives.Inr tm' -> - Obj.magic - (Obj.repr - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic tm')))) uu___1))) uu___3 - uu___2 uu___1 uu___ -type 'a ctac = - 'a -> ('a * FStar_Tactics_Types.ctrl_flag) FStar_Tactics_Monad.tac -let seq_ctac : 'a . 'a ctac -> 'a ctac -> 'a ctac = - fun uu___1 -> - fun uu___ -> - (fun c1 -> - fun c2 -> - fun x -> - let uu___ = c1 x in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac - () () (Obj.magic uu___) - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - match uu___1 with - | (x', flag) -> - (match flag with - | FStar_Tactics_Types.Abort -> - Obj.magic - (Obj.repr - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic - (x', FStar_Tactics_Types.Abort)))) - | FStar_Tactics_Types.Skip -> - Obj.magic - (Obj.repr - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic - (x', FStar_Tactics_Types.Skip)))) - | FStar_Tactics_Types.Continue -> - Obj.magic (Obj.repr (c2 x')))) uu___1))) - uu___1 uu___ -let (par_combine : - (FStar_Tactics_Types.ctrl_flag * FStar_Tactics_Types.ctrl_flag) -> - FStar_Tactics_Types.ctrl_flag) - = - fun uu___ -> - match uu___ with - | (FStar_Tactics_Types.Abort, uu___1) -> FStar_Tactics_Types.Abort - | (uu___1, FStar_Tactics_Types.Abort) -> FStar_Tactics_Types.Abort - | (FStar_Tactics_Types.Skip, uu___1) -> FStar_Tactics_Types.Skip - | (uu___1, FStar_Tactics_Types.Skip) -> FStar_Tactics_Types.Skip - | (FStar_Tactics_Types.Continue, FStar_Tactics_Types.Continue) -> - FStar_Tactics_Types.Continue -let par_ctac : 'a 'b . 'a ctac -> 'b ctac -> ('a * 'b) ctac = - fun uu___1 -> - fun uu___ -> - (fun cl -> - fun cr -> - fun uu___ -> - match uu___ with - | (x, y) -> - let uu___1 = cl x in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - match uu___2 with - | (x1, flag) -> - (match flag with - | FStar_Tactics_Types.Abort -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic - ((x1, y), - FStar_Tactics_Types.Abort))) - | fa -> - let uu___3 = cr y in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___3) - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - match uu___4 with - | (y1, flag1) -> - (match flag1 with - | FStar_Tactics_Types.Abort - -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - ((x1, y1), - FStar_Tactics_Types.Abort))) - | fb -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - ((x1, y1), - (par_combine - (fa, fb))))))) - uu___4)))) uu___2))) uu___1 - uu___ -let rec map_ctac : 'a . 'a ctac -> 'a Prims.list ctac = - fun uu___ -> - (fun c -> - fun xs -> - match xs with - | [] -> - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.magic ([], FStar_Tactics_Types.Continue))) - | x::xs1 -> - let uu___ = - let uu___1 = let uu___2 = map_ctac c in par_ctac c uu___2 in - uu___1 (x, xs1) in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac - () () (Obj.magic uu___) - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - match uu___1 with - | ((x1, xs2), flag) -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic ((x1 :: xs2), flag)))) uu___1))) - uu___ -let ctac_id : 'a . 'a ctac = - fun x -> - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.magic (x, FStar_Tactics_Types.Continue))) -let (ctac_args : - FStar_Syntax_Syntax.term ctac -> FStar_Syntax_Syntax.args ctac) = - fun c -> - let uu___ = let uu___1 = ctac_id in par_ctac c uu___1 in map_ctac uu___ -let (maybe_rewrite : - FStar_Tactics_Types.goal -> - controller_ty -> - rewriter_ty -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * FStar_Tactics_Types.ctrl_flag) - FStar_Tactics_Monad.tac) - = - fun uu___4 -> - fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun g0 -> - fun controller -> - fun rewriter -> - fun env -> - fun tm -> - let uu___ = controller tm in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___) - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - match uu___1 with - | (rw, ctrl_flag) -> - let uu___2 = - if rw - then - Obj.magic - (Obj.repr - (do_rewrite g0 rewriter env tm)) - else - Obj.magic - (Obj.repr - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () (Obj.magic tm))) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () - () (Obj.magic uu___2) - (fun uu___3 -> - (fun tm' -> - let tm' = Obj.magic tm' in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - (tm', ctrl_flag)))) - uu___3))) uu___1))) uu___4 - uu___3 uu___2 uu___1 uu___ -let rec (ctrl_fold_env : - FStar_Tactics_Types.goal -> - FStar_Tactics_Types.direction -> - controller_ty -> - rewriter_ty -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * FStar_Tactics_Types.ctrl_flag) - FStar_Tactics_Monad.tac) - = - fun g0 -> - fun d -> - fun controller -> - fun rewriter -> - fun env -> - fun tm -> - let recurse tm1 = - ctrl_fold_env g0 d controller rewriter env tm1 in - match d with - | FStar_Tactics_Types.TopDown -> - let uu___ = - seq_ctac (maybe_rewrite g0 controller rewriter env) - (on_subterms g0 d controller rewriter env) in - uu___ tm - | FStar_Tactics_Types.BottomUp -> - let uu___ = - seq_ctac (on_subterms g0 d controller rewriter env) - (maybe_rewrite g0 controller rewriter env) in - uu___ tm -and (recurse_option_residual_comp : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.subst_elt Prims.list -> - FStar_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option -> - (FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * - FStar_Tactics_Types.ctrl_flag) FStar_Tactics_Monad.tac) - -> - (FStar_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option * - FStar_Tactics_Types.ctrl_flag) FStar_Tactics_Monad.tac) - = - fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun env -> - fun retyping_subst -> - fun rc_opt -> - fun recurse -> - match rc_opt with - | FStar_Pervasives_Native.None -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic - (FStar_Pervasives_Native.None, - FStar_Tactics_Types.Continue))) - | FStar_Pervasives_Native.Some rc -> - (match rc.FStar_Syntax_Syntax.residual_typ with - | FStar_Pervasives_Native.None -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic - ((FStar_Pervasives_Native.Some rc), - FStar_Tactics_Types.Continue))) - | FStar_Pervasives_Native.Some t -> - let t1 = - FStar_Syntax_Subst.subst retyping_subst t in - let uu___ = recurse env t1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___) - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - match uu___1 with - | (t2, flag) -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - ((FStar_Pervasives_Native.Some - { - FStar_Syntax_Syntax.residual_effect - = - (rc.FStar_Syntax_Syntax.residual_effect); - FStar_Syntax_Syntax.residual_typ - = - (FStar_Pervasives_Native.Some - t2); - FStar_Syntax_Syntax.residual_flags - = - (rc.FStar_Syntax_Syntax.residual_flags) - }), flag)))) uu___1)))) - uu___3 uu___2 uu___1 uu___ -and (on_subterms : - FStar_Tactics_Types.goal -> - FStar_Tactics_Types.direction -> - controller_ty -> - rewriter_ty -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * FStar_Tactics_Types.ctrl_flag) - FStar_Tactics_Monad.tac) - = - fun uu___5 -> - fun uu___4 -> - fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun g0 -> - fun d -> - fun controller -> - fun rewriter -> - fun env -> - fun tm -> - let recurse env1 tm1 = - ctrl_fold_env g0 d controller rewriter env1 tm1 in - let rr = recurse env in - let rec descend_binders uu___8 uu___7 uu___6 - uu___5 uu___4 uu___3 uu___2 uu___1 uu___ = - (fun orig -> - fun accum_binders -> - fun retyping_subst -> - fun accum_flag -> - fun env1 -> - fun bs -> - fun t -> - fun k -> - fun rebuild -> - match bs with - | [] -> - let t1 = - FStar_Syntax_Subst.subst - retyping_subst t in - let uu___ = - recurse env1 t1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic uu___) - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = - Obj.magic - uu___1 in - match uu___1 - with - | (t2, t_flag) - -> - (match t_flag - with - | - FStar_Tactics_Types.Abort - -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - ((orig.FStar_Syntax_Syntax.n), - t_flag))) - | - uu___2 -> - let uu___3 - = - recurse_option_residual_comp - env1 - retyping_subst - k recurse in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic - uu___3) - (fun - uu___4 -> - (fun - uu___4 -> - let uu___4 - = - Obj.magic - uu___4 in - match uu___4 - with - | - (k1, - k_flag) - -> - let bs1 = - FStar_Compiler_List.rev - accum_binders in - let subst - = - FStar_Syntax_Subst.closing_of_binders - bs1 in - let bs2 = - FStar_Syntax_Subst.close_binders - bs1 in - let t3 = - FStar_Syntax_Subst.subst - subst t2 in - let k2 = - FStar_Compiler_Util.map_option - (FStar_Syntax_Subst.subst_residual_comp - subst) k1 in - let uu___5 - = - let uu___6 - = - rebuild - bs2 t3 k2 in - (uu___6, - (par_combine - (accum_flag, - (par_combine - (t_flag, - k_flag))))) in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - uu___5))) - uu___4)))) - uu___1)) - | b::bs1 -> - let s = - FStar_Syntax_Subst.subst - retyping_subst - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - let uu___ = - recurse env1 s in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic uu___) - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = - Obj.magic - uu___1 in - match uu___1 - with - | (s1, flag) - -> - (match flag - with - | - FStar_Tactics_Types.Abort - -> - Obj.magic - (Obj.repr - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - ((orig.FStar_Syntax_Syntax.n), - flag)))) - | - uu___2 -> - Obj.magic - (Obj.repr - (let bv = - let uu___3 - = - b.FStar_Syntax_Syntax.binder_bv in - { - FStar_Syntax_Syntax.ppname - = - (uu___3.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index - = - (uu___3.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort - = s1 - } in - let b1 = - { - FStar_Syntax_Syntax.binder_bv - = bv; - FStar_Syntax_Syntax.binder_qual - = - (b.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity - = - (b.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs - = - (b.FStar_Syntax_Syntax.binder_attrs) - } in - let env2 - = - FStar_TypeChecker_Env.push_binders - env1 - [b1] in - let retyping_subst1 - = - let uu___3 - = - let uu___4 - = - let uu___5 - = - FStar_Syntax_Syntax.bv_to_name - bv in - (bv, - uu___5) in - FStar_Syntax_Syntax.NT - uu___4 in - uu___3 :: - retyping_subst in - descend_binders - orig (b1 - :: - accum_binders) - retyping_subst1 - (par_combine - (accum_flag, - flag)) - env2 bs1 - t k - rebuild)))) - uu___1))) - uu___8 uu___7 uu___6 uu___5 uu___4 uu___3 - uu___2 uu___1 uu___ in - let go uu___ = - (fun uu___ -> - let tm1 = FStar_Syntax_Subst.compress tm in - match tm1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = hd; - FStar_Syntax_Syntax.args = args;_} - -> - Obj.magic - (Obj.repr - (let uu___1 = - let uu___2 = - let uu___3 = ctac_args rr in - par_ctac rr uu___3 in - uu___2 (hd, args) in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () - () (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = - Obj.magic uu___2 in - match uu___2 with - | ((hd1, args1), flag) -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - ((FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd - = hd1; - FStar_Syntax_Syntax.args - = args1 - }), flag)))) - uu___2))) - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs; - FStar_Syntax_Syntax.body = t; - FStar_Syntax_Syntax.rc_opt = k;_} - -> - Obj.magic - (Obj.repr - (let uu___1 = - FStar_Syntax_Subst.open_term' bs - t in - match uu___1 with - | (bs_orig, t1, subst) -> - let k1 = - FStar_Compiler_Util.map_option - (FStar_Syntax_Subst.subst_residual_comp - subst) k in - descend_binders tm1 [] [] - FStar_Tactics_Types.Continue - env bs_orig t1 k1 - (fun bs1 -> - fun t2 -> - fun k2 -> - FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs - = bs1; - FStar_Syntax_Syntax.body - = t2; - FStar_Syntax_Syntax.rc_opt - = k2 - }))) - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x; - FStar_Syntax_Syntax.phi = phi;_} - -> - Obj.magic - (Obj.repr - (let uu___1 = - let uu___2 = - let uu___3 = - FStar_Syntax_Syntax.mk_binder - x in - [uu___3] in - FStar_Syntax_Subst.open_term - uu___2 phi in - match uu___1 with - | (bs, phi1) -> - descend_binders tm1 [] [] - FStar_Tactics_Types.Continue - env bs phi1 - FStar_Pervasives_Native.None - (fun bs1 -> - fun phi2 -> - fun uu___2 -> - let x1 = - match bs1 with - | x2::[] -> - x2.FStar_Syntax_Syntax.binder_bv - | uu___3 -> - failwith - "Impossible" in - FStar_Syntax_Syntax.Tm_refine - { - FStar_Syntax_Syntax.b - = x1; - FStar_Syntax_Syntax.phi - = phi2 - }))) - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; - FStar_Syntax_Syntax.comp = comp;_} - -> - Obj.magic - (Obj.repr - (match comp.FStar_Syntax_Syntax.n - with - | FStar_Syntax_Syntax.Total t -> - Obj.repr - (let uu___1 = - FStar_Syntax_Subst.open_term - bs t in - match uu___1 with - | (bs_orig, t1) -> - descend_binders tm1 [] - [] - FStar_Tactics_Types.Continue - env bs_orig t1 - FStar_Pervasives_Native.None - (fun bs1 -> - fun t2 -> - fun uu___2 -> - FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 - = bs1; - FStar_Syntax_Syntax.comp - = - { - FStar_Syntax_Syntax.n - = - (FStar_Syntax_Syntax.Total - t2); - FStar_Syntax_Syntax.pos - = - (comp.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars - = - (comp.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code - = - (comp.FStar_Syntax_Syntax.hash_code) - } - })) - | FStar_Syntax_Syntax.GTotal t -> - Obj.repr - (let uu___1 = - FStar_Syntax_Subst.open_term - bs t in - match uu___1 with - | (bs_orig, t1) -> - descend_binders tm1 [] - [] - FStar_Tactics_Types.Continue - env bs_orig t1 - FStar_Pervasives_Native.None - (fun bs1 -> - fun t2 -> - fun uu___2 -> - FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 - = bs1; - FStar_Syntax_Syntax.comp - = - { - FStar_Syntax_Syntax.n - = - (FStar_Syntax_Syntax.GTotal - t2); - FStar_Syntax_Syntax.pos - = - (comp.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars - = - (comp.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code - = - (comp.FStar_Syntax_Syntax.hash_code) - } - })) - | uu___1 -> - Obj.repr - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - ((tm1.FStar_Syntax_Syntax.n), - FStar_Tactics_Types.Continue))))) - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = hd; - FStar_Syntax_Syntax.ret_opt = asc_opt; - FStar_Syntax_Syntax.brs = brs; - FStar_Syntax_Syntax.rc_opt1 = lopt;_} - -> - Obj.magic - (Obj.repr - (let c_branch uu___1 = - (fun br -> - let uu___1 = - FStar_Syntax_Subst.open_branch - br in - match uu___1 with - | (pat, w, e) -> - let bvs = - FStar_Syntax_Syntax.pat_bvs - pat in - let uu___2 = - let uu___3 = - FStar_TypeChecker_Env.push_bvs - env bvs in - recurse uu___3 e in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic uu___2) - (fun uu___3 -> - (fun uu___3 -> - let uu___3 = - Obj.magic - uu___3 in - match uu___3 - with - | (e1, flag) -> - let br1 = - FStar_Syntax_Subst.close_branch - (pat, w, - e1) in - Obj.magic - ( - FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - (br1, - flag)))) - uu___3))) uu___1 in - let uu___1 = - let uu___2 = - let uu___3 = map_ctac c_branch in - par_ctac rr uu___3 in - uu___2 (hd, brs) in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () - () (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = - Obj.magic uu___2 in - match uu___2 with - | ((hd1, brs1), flag) -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - ((FStar_Syntax_Syntax.Tm_match - { - FStar_Syntax_Syntax.scrutinee - = hd1; - FStar_Syntax_Syntax.ret_opt - = asc_opt; - FStar_Syntax_Syntax.brs - = brs1; - FStar_Syntax_Syntax.rc_opt1 - = lopt - }), flag)))) - uu___2))) - | FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = - (false, - { - FStar_Syntax_Syntax.lbname = - FStar_Pervasives.Inl bv; - FStar_Syntax_Syntax.lbunivs = - uu___1; - FStar_Syntax_Syntax.lbtyp = uu___2; - FStar_Syntax_Syntax.lbeff = uu___3; - FStar_Syntax_Syntax.lbdef = def; - FStar_Syntax_Syntax.lbattrs = - uu___4; - FStar_Syntax_Syntax.lbpos = uu___5;_}::[]); - FStar_Syntax_Syntax.body1 = e;_} - -> - Obj.magic - (Obj.repr - (let lb = - let uu___6 = - let uu___7 = - FStar_Syntax_Subst.compress - tm1 in - uu___7.FStar_Syntax_Syntax.n in - match uu___6 with - | FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = - (false, lb1::[]); - FStar_Syntax_Syntax.body1 = - uu___7;_} - -> lb1 - | uu___7 -> failwith "impossible" in - let uu___6 = - FStar_Syntax_Subst.open_term_bv - bv e in - match uu___6 with - | (bv1, e1) -> - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - FStar_TypeChecker_Env.push_bv - env bv1 in - recurse uu___10 in - par_ctac rr uu___9 in - uu___8 - ((lb.FStar_Syntax_Syntax.lbdef), - e1) in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () (Obj.magic uu___7) - (fun uu___8 -> - (fun uu___8 -> - let uu___8 = - Obj.magic uu___8 in - match uu___8 with - | ((lbdef, e2), flag) - -> - let lb1 = - { - FStar_Syntax_Syntax.lbname - = - (lb.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs - = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp - = - (lb.FStar_Syntax_Syntax.lbtyp); - FStar_Syntax_Syntax.lbeff - = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef - = lbdef; - FStar_Syntax_Syntax.lbattrs - = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos - = - (lb.FStar_Syntax_Syntax.lbpos) - } in - let e3 = - let uu___9 = - let uu___10 = - FStar_Syntax_Syntax.mk_binder - bv1 in - [uu___10] in - FStar_Syntax_Subst.close - uu___9 e2 in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - ((FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs - = - (false, - [lb1]); - FStar_Syntax_Syntax.body1 - = e3 - }), flag)))) - uu___8))) - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (true, lbs); - FStar_Syntax_Syntax.body1 = e;_} - -> - Obj.magic - (Obj.repr - (let c_lb uu___1 = - (fun lb -> - let uu___1 = - rr - lb.FStar_Syntax_Syntax.lbdef in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = - Obj.magic uu___2 in - match uu___2 with - | (def, flag) -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - ({ - FStar_Syntax_Syntax.lbname - = - (lb.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs - = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp - = - (lb.FStar_Syntax_Syntax.lbtyp); - FStar_Syntax_Syntax.lbeff - = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef - = def; - FStar_Syntax_Syntax.lbattrs - = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos - = - (lb.FStar_Syntax_Syntax.lbpos) - }, flag)))) - uu___2))) uu___1 in - let uu___1 = - FStar_Syntax_Subst.open_let_rec - lbs e in - match uu___1 with - | (lbs1, e1) -> - let uu___2 = - let uu___3 = - let uu___4 = map_ctac c_lb in - par_ctac uu___4 rr in - uu___3 (lbs1, e1) in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () (Obj.magic uu___2) - (fun uu___3 -> - (fun uu___3 -> - let uu___3 = - Obj.magic uu___3 in - match uu___3 with - | ((lbs2, e2), flag) -> - let uu___4 = - FStar_Syntax_Subst.close_let_rec - lbs2 e2 in - (match uu___4 with - | (lbs3, e3) -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - ( - Obj.magic - ((FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs - = - (true, - lbs3); - FStar_Syntax_Syntax.body1 - = e3 - }), flag))))) - uu___3))) - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t; - FStar_Syntax_Syntax.asc = asc; - FStar_Syntax_Syntax.eff_opt = eff;_} - -> - Obj.magic - (Obj.repr - (let uu___1 = rr t in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () - () (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = - Obj.magic uu___2 in - match uu___2 with - | (t1, flag) -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - ((FStar_Syntax_Syntax.Tm_ascribed - { - FStar_Syntax_Syntax.tm - = t1; - FStar_Syntax_Syntax.asc - = asc; - FStar_Syntax_Syntax.eff_opt - = eff - }), flag)))) - uu___2))) - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t; - FStar_Syntax_Syntax.meta = m;_} - -> - Obj.magic - (Obj.repr - (let uu___1 = rr t in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () - () (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = - Obj.magic uu___2 in - match uu___2 with - | (t1, flag) -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - ((FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 - = t1; - FStar_Syntax_Syntax.meta - = m - }), flag)))) - uu___2))) - | uu___1 -> - Obj.magic - (Obj.repr - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic - ((tm1.FStar_Syntax_Syntax.n), - FStar_Tactics_Types.Continue))))) - uu___ in - let uu___ = go () in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___) - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - match uu___1 with - | (tmn', flag) -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - ({ - FStar_Syntax_Syntax.n = - tmn'; - FStar_Syntax_Syntax.pos - = - (tm.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars - = - (tm.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code - = - (tm.FStar_Syntax_Syntax.hash_code) - }, flag)))) uu___1))) - uu___5 uu___4 uu___3 uu___2 uu___1 uu___ -let (do_ctrl_rewrite : - FStar_Tactics_Types.goal -> - FStar_Tactics_Types.direction -> - controller_ty -> - rewriter_ty -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term FStar_Tactics_Monad.tac) - = - fun uu___5 -> - fun uu___4 -> - fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun g0 -> - fun dir -> - fun controller -> - fun rewriter -> - fun env -> - fun tm -> - let uu___ = - ctrl_fold_env g0 dir controller rewriter env tm in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___) - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - match uu___1 with - | (tm', uu___2) -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () (Obj.magic tm'))) uu___1))) - uu___5 uu___4 uu___3 uu___2 uu___1 uu___ -let (ctrl_rewrite : - FStar_Tactics_Types.direction -> - controller_ty -> rewriter_ty -> unit FStar_Tactics_Monad.tac) - = - fun dir -> - fun controller -> - fun rewriter -> - let uu___ = - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.get) - (fun uu___1 -> - (fun ps -> - let ps = Obj.magic ps in - let uu___1 = - match ps.FStar_Tactics_Types.goals with - | g::gs -> (g, gs) - | [] -> failwith "no goals" in - match uu___1 with - | (g, gs) -> - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - FStar_Tactics_Monad.dismiss_all - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - let gt = FStar_Tactics_Types.goal_type g in - let uu___3 = - FStar_Tactics_Monad.if_verbose - (fun uu___4 -> - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - gt in - FStar_Compiler_Util.print1 - "ctrl_rewrite starting with %s\n" - uu___5) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - uu___3 - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - let uu___5 = - let uu___6 = - FStar_Tactics_Types.goal_env - g in - do_ctrl_rewrite g dir - controller rewriter uu___6 gt in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () (Obj.magic uu___5) - (fun uu___6 -> - (fun gt' -> - let gt' = - Obj.magic gt' in - let uu___6 = - FStar_Tactics_Monad.if_verbose - (fun uu___7 -> - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - gt' in - FStar_Compiler_Util.print1 - "ctrl_rewrite seems to have succeded with %s\n" - uu___8) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___6 - (fun uu___7 -> - (fun uu___7 -> - let uu___7 - = - Obj.magic - uu___7 in - let uu___8 - = - FStar_Tactics_Monad.push_goals - gs in - Obj.magic - ( - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___8 - (fun - uu___9 -> - (fun - uu___9 -> - let uu___9 - = - Obj.magic - uu___9 in - let g1 = - FStar_Tactics_Monad.goal_with_type - g gt' in - Obj.magic - (FStar_Tactics_Monad.add_goals - [g1])) - uu___9))) - uu___7))) - uu___6))) uu___4))) - uu___2))) uu___1) in - FStar_Tactics_Monad.wrap_err "ctrl_rewrite" uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_Effect.ml b/ocaml/fstar-lib/generated/FStar_Tactics_Effect.ml index add2fa79220..f3643d1db31 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_Effect.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_Effect.ml @@ -3,10 +3,10 @@ type 'a tac_wp_t0 = unit type ('a, 'wp) tac_wp_monotonic = unit type 'a tac_wp_t = unit type ('a, 'wp) tac_repr = - FStar_Tactics_Types.proofstate -> 'a FStar_Tactics_Result.__result + FStarC_Tactics_Types.proofstate -> 'a FStarC_Tactics_Result.__result type ('a, 'x, 'ps, 'post) tac_return_wp = 'post let tac_return : 'a . 'a -> ('a, Obj.t) tac_repr = - fun x -> fun s -> FStar_Tactics_Result.Success (x, s) + fun x -> fun s -> FStarC_Tactics_Result.Success (x, s) type ('a, 'b, 'wpuf, 'wpug, 'ps, 'post) tac_bind_wp = 'wpuf type ('a, 'wp, 'ps, 'post) tac_wp_compact = unit let tac_bind : @@ -21,16 +21,16 @@ let tac_bind : fun t1 -> fun t2 -> fun ps -> - let ps1 = FStar_Tactics_Types.set_proofstate_range ps r1 in - let ps2 = FStar_Tactics_Types.incr_depth ps1 in + let ps1 = FStarC_Tactics_Types.set_proofstate_range ps r1 in + let ps2 = FStarC_Tactics_Types.incr_depth ps1 in let r = t1 ps2 in match r with - | FStar_Tactics_Result.Success (a1, ps') -> - let ps'1 = FStar_Tactics_Types.set_proofstate_range ps' r2 in - (match FStar_Tactics_Types.tracepoint ps'1 with - | true -> t2 a1 (FStar_Tactics_Types.decr_depth ps'1)) - | FStar_Tactics_Result.Failed (e, ps') -> - FStar_Tactics_Result.Failed (e, ps') + | FStarC_Tactics_Result.Success (a1, ps') -> + let ps'1 = FStarC_Tactics_Types.set_proofstate_range ps' r2 in + (match FStarC_Tactics_Types.tracepoint ps'1 with + | true -> t2 a1 (FStarC_Tactics_Types.decr_depth ps'1)) + | FStarC_Tactics_Result.Failed (e, ps') -> + FStarC_Tactics_Result.Failed (e, ps') type ('a, 'wputhen, 'wpuelse, 'b, 'ps, 'post) tac_if_then_else_wp = unit type ('a, 'wputhen, 'wpuelse, 'f, 'g, 'b) tac_if_then_else = ('a, unit) tac_repr @@ -43,11 +43,11 @@ let __proj__TAC__item__bind = tac_bind type ('a, 'wp, 'uuuuu, 'uuuuu1) lift_div_tac_wp = 'wp let lift_div_tac : 'a 'wp . (unit -> 'a) -> ('a, 'wp) tac_repr = fun f -> - fun ps -> let uu___ = f () in FStar_Tactics_Result.Success (uu___, ps) -let (get : unit -> (FStar_Tactics_Types.proofstate, Obj.t) tac_repr) = - fun uu___ -> fun ps -> FStar_Tactics_Result.Success (ps, ps) + fun ps -> let uu___ = f () in FStarC_Tactics_Result.Success (uu___, ps) +let (get : unit -> (FStarC_Tactics_Types.proofstate, Obj.t) tac_repr) = + fun uu___ -> fun ps -> FStarC_Tactics_Result.Success (ps, ps) let raise : 'a . Prims.exn -> ('a, Obj.t) tac_repr = - fun e -> fun ps -> FStar_Tactics_Result.Failed (e, ps) + fun e -> fun ps -> FStarC_Tactics_Result.Failed (e, ps) type ('uuuuu, 'p) with_tactic = 'p let (rewrite_with_tactic : (unit -> (unit, unit) tac_repr) -> unit -> Obj.t -> Obj.t) = diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_Embedding.ml b/ocaml/fstar-lib/generated/FStar_Tactics_Embedding.ml deleted file mode 100644 index e04229b8dba..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Tactics_Embedding.ml +++ /dev/null @@ -1,1070 +0,0 @@ -open Prims -type name = FStar_Syntax_Syntax.bv -let (fstar_tactics_lid' : Prims.string Prims.list -> FStar_Ident.lid) = - fun s -> FStar_Parser_Const.fstar_tactics_lid' s -let (fstar_stubs_tactics_lid' : Prims.string Prims.list -> FStar_Ident.lid) = - fun s -> FStar_Parser_Const.fstar_stubs_tactics_lid' s -let (lid_as_tm : FStar_Ident.lident -> FStar_Syntax_Syntax.term) = - fun l -> - let uu___ = FStar_Syntax_Syntax.lid_as_fv l FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___ -let (mk_tactic_lid_as_term : Prims.string -> FStar_Syntax_Syntax.term) = - fun s -> let uu___ = fstar_tactics_lid' ["Effect"; s] in lid_as_tm uu___ -type tac_constant = - { - lid: FStar_Ident.lid ; - fv: FStar_Syntax_Syntax.fv ; - t: FStar_Syntax_Syntax.term } -let (__proj__Mktac_constant__item__lid : tac_constant -> FStar_Ident.lid) = - fun projectee -> match projectee with | { lid; fv; t;_} -> lid -let (__proj__Mktac_constant__item__fv : - tac_constant -> FStar_Syntax_Syntax.fv) = - fun projectee -> match projectee with | { lid; fv; t;_} -> fv -let (__proj__Mktac_constant__item__t : - tac_constant -> FStar_Syntax_Syntax.term) = - fun projectee -> match projectee with | { lid; fv; t;_} -> t -let (lid_as_data_fv : FStar_Ident.lident -> FStar_Syntax_Syntax.fv) = - fun l -> - FStar_Syntax_Syntax.lid_as_fv l - (FStar_Pervasives_Native.Some FStar_Syntax_Syntax.Data_ctor) -let (lid_as_data_tm : FStar_Ident.lident -> FStar_Syntax_Syntax.term) = - fun l -> let uu___ = lid_as_data_fv l in FStar_Syntax_Syntax.fv_to_tm uu___ -let (fstar_tactics_data : Prims.string Prims.list -> tac_constant) = - fun ns -> - let lid = fstar_stubs_tactics_lid' ns in - let uu___ = lid_as_data_fv lid in - let uu___1 = lid_as_data_tm lid in { lid; fv = uu___; t = uu___1 } -let (fstar_tactics_const : Prims.string Prims.list -> tac_constant) = - fun ns -> - let lid = fstar_stubs_tactics_lid' ns in - let uu___ = FStar_Syntax_Syntax.fvconst lid in - let uu___1 = FStar_Syntax_Syntax.tconst lid in - { lid; fv = uu___; t = uu___1 } -let (fstar_tc_core_lid : Prims.string -> FStar_Ident.lid) = - fun s -> - FStar_Ident.lid_of_path - (FStar_Compiler_List.op_At ["FStar"; "Stubs"; "TypeChecker"; "Core"] - [s]) FStar_Compiler_Range_Type.dummyRange -let (fstar_tc_core_data : Prims.string -> tac_constant) = - fun s -> - let lid = fstar_tc_core_lid s in - let uu___ = lid_as_data_fv lid in - let uu___1 = lid_as_data_tm lid in { lid; fv = uu___; t = uu___1 } -let (fstar_tc_core_const : Prims.string -> tac_constant) = - fun s -> - let lid = fstar_tc_core_lid s in - let uu___ = FStar_Syntax_Syntax.fvconst lid in - let uu___1 = FStar_Syntax_Syntax.tconst lid in - { lid; fv = uu___; t = uu___1 } -let (fstar_tactics_proofstate : tac_constant) = - fstar_tactics_const ["Types"; "proofstate"] -let (fstar_tactics_goal : tac_constant) = - fstar_tactics_const ["Types"; "goal"] -let (fstar_tactics_TacticFailure : tac_constant) = - fstar_tactics_data ["Common"; "TacticFailure"] -let (fstar_tactics_SKIP : tac_constant) = - fstar_tactics_data ["Common"; "SKIP"] -let (fstar_tactics_result : tac_constant) = - fstar_tactics_const ["Result"; "__result"] -let (fstar_tactics_Success : tac_constant) = - fstar_tactics_data ["Result"; "Success"] -let (fstar_tactics_Failed : tac_constant) = - fstar_tactics_data ["Result"; "Failed"] -let (fstar_tactics_direction : tac_constant) = - fstar_tactics_const ["Types"; "direction"] -let (fstar_tactics_topdown : tac_constant) = - fstar_tactics_data ["Types"; "TopDown"] -let (fstar_tactics_bottomup : tac_constant) = - fstar_tactics_data ["Types"; "BottomUp"] -let (fstar_tactics_ctrl_flag : tac_constant) = - fstar_tactics_const ["Types"; "ctrl_flag"] -let (fstar_tactics_Continue : tac_constant) = - fstar_tactics_data ["Types"; "Continue"] -let (fstar_tactics_Skip : tac_constant) = - fstar_tactics_data ["Types"; "Skip"] -let (fstar_tactics_Abort : tac_constant) = - fstar_tactics_data ["Types"; "Abort"] -let (fstar_tc_core_unfold_side : tac_constant) = - fstar_tc_core_const "unfold_side" -let (fstar_tc_core_unfold_side_Left : tac_constant) = - fstar_tc_core_data "Left" -let (fstar_tc_core_unfold_side_Right : tac_constant) = - fstar_tc_core_data "Right" -let (fstar_tc_core_unfold_side_Both : tac_constant) = - fstar_tc_core_data "Both" -let (fstar_tc_core_unfold_side_Neither : tac_constant) = - fstar_tc_core_data "Neither" -let (fstar_tc_core_tot_or_ghost : tac_constant) = - fstar_tc_core_const "tot_or_ghost" -let (fstar_tc_core_tot_or_ghost_ETotal : tac_constant) = - fstar_tc_core_data "E_Total" -let (fstar_tc_core_tot_or_ghost_EGhost : tac_constant) = - fstar_tc_core_data "E_Ghost" -let (fstar_tactics_guard_policy : tac_constant) = - fstar_tactics_const ["Types"; "guard_policy"] -let (fstar_tactics_SMT : tac_constant) = fstar_tactics_data ["Types"; "SMT"] -let (fstar_tactics_SMTSync : tac_constant) = - fstar_tactics_data ["Types"; "SMTSync"] -let (fstar_tactics_Goal : tac_constant) = - fstar_tactics_data ["Types"; "Goal"] -let (fstar_tactics_Drop : tac_constant) = - fstar_tactics_data ["Types"; "Drop"] -let (fstar_tactics_Force : tac_constant) = - fstar_tactics_data ["Types"; "Force"] -let mk_emb : - 'a . - (FStar_Compiler_Range_Type.range -> 'a -> FStar_Syntax_Syntax.term) -> - (FStar_Syntax_Syntax.term -> 'a FStar_Pervasives_Native.option) -> - FStar_Syntax_Syntax.term -> 'a FStar_Syntax_Embeddings_Base.embedding - = - fun em -> - fun un -> - fun t -> - let uu___ = FStar_Syntax_Embeddings_Base.term_as_fv t in - FStar_Syntax_Embeddings_Base.mk_emb - (fun x -> fun r -> fun _topt -> fun _norm -> em r x) - (fun x -> fun _norm -> un x) uu___ -let embed : - 'a . - 'a FStar_Syntax_Embeddings_Base.embedding -> - FStar_Compiler_Range_Type.range -> 'a -> FStar_Syntax_Syntax.term - = - fun uu___ -> - fun r -> - fun x -> - let uu___1 = FStar_Syntax_Embeddings_Base.embed uu___ x in - uu___1 r FStar_Pervasives_Native.None - FStar_Syntax_Embeddings_Base.id_norm_cb -let unembed' : - 'a . - 'a FStar_Syntax_Embeddings_Base.embedding -> - FStar_Syntax_Syntax.term -> 'a FStar_Pervasives_Native.option - = - fun uu___ -> - fun x -> - FStar_Syntax_Embeddings_Base.unembed uu___ x - FStar_Syntax_Embeddings_Base.id_norm_cb -let (t_result_of : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun t -> - let uu___ = let uu___1 = FStar_Syntax_Syntax.as_arg t in [uu___1] in - FStar_Syntax_Util.mk_app fstar_tactics_result.t uu___ -let (hd'_and_args : - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term' * (FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax * FStar_Syntax_Syntax.arg_qualifier - FStar_Pervasives_Native.option) Prims.list)) - = - fun tm -> - let tm1 = FStar_Syntax_Util.unascribe tm in - let uu___ = FStar_Syntax_Util.head_and_args tm1 in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = FStar_Syntax_Util.un_uinst hd in - uu___2.FStar_Syntax_Syntax.n in - (uu___1, args) -let (e_proofstate : - FStar_Tactics_Types.proofstate FStar_Syntax_Embeddings_Base.embedding) = - FStar_Syntax_Embeddings_Base.e_lazy FStar_Syntax_Syntax.Lazy_proofstate - fstar_tactics_proofstate.t -let (e_goal : - FStar_Tactics_Types.goal FStar_Syntax_Embeddings_Base.embedding) = - FStar_Syntax_Embeddings_Base.e_lazy FStar_Syntax_Syntax.Lazy_goal - fstar_tactics_goal.t -let (unfold_lazy_proofstate : - FStar_Syntax_Syntax.lazyinfo -> FStar_Syntax_Syntax.term) = - fun i -> FStar_Syntax_Util.exp_string "(((proofstate)))" -let (unfold_lazy_goal : - FStar_Syntax_Syntax.lazyinfo -> FStar_Syntax_Syntax.term) = - fun i -> FStar_Syntax_Util.exp_string "(((goal)))" -let (mkFV : - FStar_Syntax_Syntax.fv -> - FStar_Syntax_Syntax.universe Prims.list -> - (FStar_TypeChecker_NBETerm.t * FStar_Syntax_Syntax.aqual) Prims.list -> - FStar_TypeChecker_NBETerm.t) - = - fun fv -> - fun us -> - fun ts -> - FStar_TypeChecker_NBETerm.mkFV fv (FStar_Compiler_List.rev us) - (FStar_Compiler_List.rev ts) -let (mkConstruct : - FStar_Syntax_Syntax.fv -> - FStar_Syntax_Syntax.universe Prims.list -> - (FStar_TypeChecker_NBETerm.t * FStar_Syntax_Syntax.aqual) Prims.list -> - FStar_TypeChecker_NBETerm.t) - = - fun fv -> - fun us -> - fun ts -> - FStar_TypeChecker_NBETerm.mkConstruct fv (FStar_Compiler_List.rev us) - (FStar_Compiler_List.rev ts) -let (fv_as_emb_typ : FStar_Syntax_Syntax.fv -> FStar_Syntax_Syntax.emb_typ) = - fun fv -> - let uu___ = - let uu___1 = - FStar_Class_Show.show FStar_Ident.showable_lident - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - (uu___1, []) in - FStar_Syntax_Syntax.ET_app uu___ -let (e_proofstate_nbe : - FStar_Tactics_Types.proofstate FStar_TypeChecker_NBETerm.embedding) = - let embed_proofstate _cb ps = - let li = - { - FStar_Syntax_Syntax.blob = (FStar_Dyn.mkdyn ps); - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_proofstate; - FStar_Syntax_Syntax.ltyp = (fstar_tactics_proofstate.t); - FStar_Syntax_Syntax.rng = FStar_Compiler_Range_Type.dummyRange - } in - let thunk = - FStar_Thunk.mk - (fun uu___ -> - FStar_TypeChecker_NBETerm.mk_t - (FStar_TypeChecker_NBETerm.Constant - (FStar_TypeChecker_NBETerm.String - ("(((proofstate.nbe)))", - FStar_Compiler_Range_Type.dummyRange)))) in - FStar_TypeChecker_NBETerm.mk_t - (FStar_TypeChecker_NBETerm.Lazy ((FStar_Pervasives.Inl li), thunk)) in - let unembed_proofstate _cb t = - let uu___ = FStar_TypeChecker_NBETerm.nbe_t_of_t t in - match uu___ with - | FStar_TypeChecker_NBETerm.Lazy - (FStar_Pervasives.Inl - { FStar_Syntax_Syntax.blob = b; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_proofstate; - FStar_Syntax_Syntax.ltyp = uu___1; - FStar_Syntax_Syntax.rng = uu___2;_}, - uu___3) - -> - let uu___4 = FStar_Dyn.undyn b in FStar_Pervasives_Native.Some uu___4 - | uu___1 -> - ((let uu___3 = - FStar_Compiler_Effect.op_Bang FStar_Options.debug_embedding in - if uu___3 - then - let uu___4 = - let uu___5 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 - "Not an embedded NBE proofstate: %s\n" uu___5 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4) - else ()); - FStar_Pervasives_Native.None) in - { - FStar_TypeChecker_NBETerm.em = embed_proofstate; - FStar_TypeChecker_NBETerm.un = unembed_proofstate; - FStar_TypeChecker_NBETerm.typ = - (fun uu___ -> mkFV fstar_tactics_proofstate.fv [] []); - FStar_TypeChecker_NBETerm.e_typ = - (fun uu___ -> fv_as_emb_typ fstar_tactics_proofstate.fv) - } -let (e_goal_nbe : - FStar_Tactics_Types.goal FStar_TypeChecker_NBETerm.embedding) = - let embed_goal _cb ps = - let li = - { - FStar_Syntax_Syntax.blob = (FStar_Dyn.mkdyn ps); - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_goal; - FStar_Syntax_Syntax.ltyp = (fstar_tactics_goal.t); - FStar_Syntax_Syntax.rng = FStar_Compiler_Range_Type.dummyRange - } in - let thunk = - FStar_Thunk.mk - (fun uu___ -> - FStar_TypeChecker_NBETerm.mk_t - (FStar_TypeChecker_NBETerm.Constant - (FStar_TypeChecker_NBETerm.String - ("(((goal.nbe)))", FStar_Compiler_Range_Type.dummyRange)))) in - FStar_TypeChecker_NBETerm.mk_t - (FStar_TypeChecker_NBETerm.Lazy ((FStar_Pervasives.Inl li), thunk)) in - let unembed_goal _cb t = - let uu___ = FStar_TypeChecker_NBETerm.nbe_t_of_t t in - match uu___ with - | FStar_TypeChecker_NBETerm.Lazy - (FStar_Pervasives.Inl - { FStar_Syntax_Syntax.blob = b; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_goal; - FStar_Syntax_Syntax.ltyp = uu___1; - FStar_Syntax_Syntax.rng = uu___2;_}, - uu___3) - -> - let uu___4 = FStar_Dyn.undyn b in FStar_Pervasives_Native.Some uu___4 - | uu___1 -> - ((let uu___3 = - FStar_Compiler_Effect.op_Bang FStar_Options.debug_embedding in - if uu___3 - then - let uu___4 = - let uu___5 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded NBE goal: %s" - uu___5 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4) - else ()); - FStar_Pervasives_Native.None) in - { - FStar_TypeChecker_NBETerm.em = embed_goal; - FStar_TypeChecker_NBETerm.un = unembed_goal; - FStar_TypeChecker_NBETerm.typ = - (fun uu___ -> mkFV fstar_tactics_goal.fv [] []); - FStar_TypeChecker_NBETerm.e_typ = - (fun uu___ -> fv_as_emb_typ fstar_tactics_goal.fv) - } -let (e_exn : Prims.exn FStar_Syntax_Embeddings_Base.embedding) = - let embed_exn e rng uu___ uu___1 = - match e with - | FStar_Tactics_Common.TacticFailure s -> - let uu___2 = - let uu___3 = - let uu___4 = - embed - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_document) - (FStar_Syntax_Embeddings.e_option - FStar_Syntax_Embeddings.e_range)) rng s in - FStar_Syntax_Syntax.as_arg uu___4 in - [uu___3] in - FStar_Syntax_Syntax.mk_Tm_app fstar_tactics_TacticFailure.t uu___2 - rng - | FStar_Tactics_Common.SKIP -> - let uu___2 = fstar_tactics_SKIP.t in - { - FStar_Syntax_Syntax.n = (uu___2.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = rng; - FStar_Syntax_Syntax.vars = (uu___2.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (uu___2.FStar_Syntax_Syntax.hash_code) - } - | FStar_Tactics_Common.EExn t -> - { - FStar_Syntax_Syntax.n = (t.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = rng; - FStar_Syntax_Syntax.vars = (t.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = (t.FStar_Syntax_Syntax.hash_code) - } - | e1 -> - let msg = - let uu___2 = FStar_Errors_Msg.text "Uncaught exception" in - let uu___3 = - let uu___4 = - let uu___5 = FStar_Compiler_Util.message_of_exn e1 in - FStar_Pprint.arbitrary_string uu___5 in - [uu___4] in - uu___2 :: uu___3 in - let uu___2 = - let uu___3 = - let uu___4 = - embed - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_document) - (FStar_Syntax_Embeddings.e_option - FStar_Syntax_Embeddings.e_range)) rng - (msg, FStar_Pervasives_Native.None) in - FStar_Syntax_Syntax.as_arg uu___4 in - [uu___3] in - FStar_Syntax_Syntax.mk_Tm_app fstar_tactics_TacticFailure.t uu___2 - rng in - let unembed_exn t uu___ = - let uu___1 = hd'_and_args t in - match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, (s, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tactics_TacticFailure.lid -> - let uu___3 = - unembed' - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_document) - (FStar_Syntax_Embeddings.e_option - FStar_Syntax_Embeddings.e_range)) s in - FStar_Compiler_Util.bind_opt uu___3 - (fun s1 -> - FStar_Pervasives_Native.Some - (FStar_Tactics_Common.TacticFailure s1)) - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tactics_SKIP.lid -> - FStar_Pervasives_Native.Some FStar_Tactics_Common.SKIP - | uu___2 -> FStar_Pervasives_Native.Some (FStar_Tactics_Common.EExn t) in - FStar_Syntax_Embeddings_Base.mk_emb_full embed_exn unembed_exn - (fun uu___ -> FStar_Syntax_Syntax.t_exn) (fun uu___ -> "(exn)") - (fun uu___ -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Ident.showable_lident - FStar_Parser_Const.exn_lid in - (uu___2, []) in - FStar_Syntax_Syntax.ET_app uu___1) -let (e_exn_nbe : Prims.exn FStar_TypeChecker_NBETerm.embedding) = - let embed_exn cb e = - match e with - | FStar_Tactics_Common.TacticFailure s -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_tuple2 - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_document) - (FStar_TypeChecker_NBETerm.e_option - FStar_TypeChecker_NBETerm.e_range)) cb s in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - mkConstruct fstar_tactics_TacticFailure.fv [] uu___ - | FStar_Tactics_Common.SKIP -> mkConstruct fstar_tactics_SKIP.fv [] [] - | uu___ -> - let uu___1 = - let uu___2 = FStar_Compiler_Util.message_of_exn e in - FStar_Compiler_Util.format1 "cannot embed exn (NBE) : %s" uu___2 in - failwith uu___1 in - let unembed_exn cb t = - let uu___ = FStar_TypeChecker_NBETerm.nbe_t_of_t t in - match uu___ with - | FStar_TypeChecker_NBETerm.Construct (fv, uu___1, (s, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tactics_TacticFailure.lid -> - let uu___3 = - FStar_TypeChecker_NBETerm.unembed - (FStar_TypeChecker_NBETerm.e_tuple2 - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_document) - (FStar_TypeChecker_NBETerm.e_option - FStar_TypeChecker_NBETerm.e_range)) cb s in - FStar_Compiler_Util.bind_opt uu___3 - (fun s1 -> - FStar_Pervasives_Native.Some - (FStar_Tactics_Common.TacticFailure s1)) - | FStar_TypeChecker_NBETerm.Construct (fv, uu___1, []) when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tactics_SKIP.lid -> - FStar_Pervasives_Native.Some FStar_Tactics_Common.SKIP - | uu___1 -> FStar_Pervasives_Native.None in - let fv_exn = FStar_Syntax_Syntax.fvconst FStar_Parser_Const.exn_lid in - { - FStar_TypeChecker_NBETerm.em = embed_exn; - FStar_TypeChecker_NBETerm.un = unembed_exn; - FStar_TypeChecker_NBETerm.typ = (fun uu___ -> mkFV fv_exn [] []); - FStar_TypeChecker_NBETerm.e_typ = (fun uu___ -> fv_as_emb_typ fv_exn) - } -let e_result : - 'a . - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'a FStar_Tactics_Result.__result FStar_Syntax_Embeddings_Base.embedding - = - fun ea -> - let embed_result res rng sh cbs = - match res with - | FStar_Tactics_Result.Success (a1, ps) -> - let uu___ = - FStar_Syntax_Syntax.mk_Tm_uinst fstar_tactics_Success.t - [FStar_Syntax_Syntax.U_zero] in - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Embeddings_Base.type_of ea in - FStar_Syntax_Syntax.iarg uu___3 in - let uu___3 = - let uu___4 = - let uu___5 = embed ea rng a1 in - FStar_Syntax_Syntax.as_arg uu___5 in - let uu___5 = - let uu___6 = - let uu___7 = embed e_proofstate rng ps in - FStar_Syntax_Syntax.as_arg uu___7 in - [uu___6] in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - FStar_Syntax_Syntax.mk_Tm_app uu___ uu___1 rng - | FStar_Tactics_Result.Failed (e, ps) -> - let uu___ = - FStar_Syntax_Syntax.mk_Tm_uinst fstar_tactics_Failed.t - [FStar_Syntax_Syntax.U_zero] in - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Embeddings_Base.type_of ea in - FStar_Syntax_Syntax.iarg uu___3 in - let uu___3 = - let uu___4 = - let uu___5 = embed e_exn rng e in - FStar_Syntax_Syntax.as_arg uu___5 in - let uu___5 = - let uu___6 = - let uu___7 = embed e_proofstate rng ps in - FStar_Syntax_Syntax.as_arg uu___7 in - [uu___6] in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - FStar_Syntax_Syntax.mk_Tm_app uu___ uu___1 rng in - let unembed_result t uu___ = - let uu___1 = hd'_and_args t in - match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, _t::(a1, uu___2)::(ps, uu___3)::[]) - when FStar_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Success.lid -> - let uu___4 = unembed' ea a1 in - FStar_Compiler_Util.bind_opt uu___4 - (fun a2 -> - let uu___5 = unembed' e_proofstate ps in - FStar_Compiler_Util.bind_opt uu___5 - (fun ps1 -> - FStar_Pervasives_Native.Some - (FStar_Tactics_Result.Success (a2, ps1)))) - | (FStar_Syntax_Syntax.Tm_fvar fv, _t::(e, uu___2)::(ps, uu___3)::[]) - when FStar_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Failed.lid -> - let uu___4 = unembed' e_exn e in - FStar_Compiler_Util.bind_opt uu___4 - (fun e1 -> - let uu___5 = unembed' e_proofstate ps in - FStar_Compiler_Util.bind_opt uu___5 - (fun ps1 -> - FStar_Pervasives_Native.Some - (FStar_Tactics_Result.Failed (e1, ps1)))) - | uu___2 -> FStar_Pervasives_Native.None in - FStar_Syntax_Embeddings_Base.mk_emb_full embed_result unembed_result - (fun uu___ -> - let uu___1 = FStar_Syntax_Embeddings_Base.type_of ea in - t_result_of uu___1) (fun uu___ -> "") - (fun uu___ -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Ident.showable_lident - fstar_tactics_result.lid in - let uu___3 = - let uu___4 = FStar_Syntax_Embeddings_Base.emb_typ_of ea () in - [uu___4] in - (uu___2, uu___3) in - FStar_Syntax_Syntax.ET_app uu___1) -let e_result_nbe : - 'a . - 'a FStar_TypeChecker_NBETerm.embedding -> - 'a FStar_Tactics_Result.__result FStar_TypeChecker_NBETerm.embedding - = - fun ea -> - let embed_result cb res = - match res with - | FStar_Tactics_Result.Failed (e, ps) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.type_of ea in - FStar_TypeChecker_NBETerm.as_iarg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = FStar_TypeChecker_NBETerm.embed e_exn_nbe cb e in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - FStar_TypeChecker_NBETerm.embed e_proofstate_nbe cb ps in - FStar_TypeChecker_NBETerm.as_arg uu___6 in - [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mkConstruct fstar_tactics_Failed.fv [FStar_Syntax_Syntax.U_zero] - uu___ - | FStar_Tactics_Result.Success (a1, ps) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.type_of ea in - FStar_TypeChecker_NBETerm.as_iarg uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = FStar_TypeChecker_NBETerm.embed ea cb a1 in - FStar_TypeChecker_NBETerm.as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - FStar_TypeChecker_NBETerm.embed e_proofstate_nbe cb ps in - FStar_TypeChecker_NBETerm.as_arg uu___6 in - [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - mkConstruct fstar_tactics_Success.fv [FStar_Syntax_Syntax.U_zero] - uu___ in - let unembed_result cb t = - let uu___ = FStar_TypeChecker_NBETerm.nbe_t_of_t t in - match uu___ with - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___1, (ps, uu___2)::(a1, uu___3)::_t::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Success.lid -> - let uu___4 = FStar_TypeChecker_NBETerm.unembed ea cb a1 in - FStar_Compiler_Util.bind_opt uu___4 - (fun a2 -> - let uu___5 = - FStar_TypeChecker_NBETerm.unembed e_proofstate_nbe cb ps in - FStar_Compiler_Util.bind_opt uu___5 - (fun ps1 -> - FStar_Pervasives_Native.Some - (FStar_Tactics_Result.Success (a2, ps1)))) - | FStar_TypeChecker_NBETerm.Construct - (fv, uu___1, (ps, uu___2)::(e, uu___3)::_t::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Failed.lid -> - let uu___4 = FStar_TypeChecker_NBETerm.unembed e_exn_nbe cb e in - FStar_Compiler_Util.bind_opt uu___4 - (fun e1 -> - let uu___5 = - FStar_TypeChecker_NBETerm.unembed e_proofstate_nbe cb ps in - FStar_Compiler_Util.bind_opt uu___5 - (fun ps1 -> - FStar_Pervasives_Native.Some - (FStar_Tactics_Result.Failed (e1, ps1)))) - | uu___1 -> FStar_Pervasives_Native.None in - { - FStar_TypeChecker_NBETerm.em = embed_result; - FStar_TypeChecker_NBETerm.un = unembed_result; - FStar_TypeChecker_NBETerm.typ = - (fun uu___ -> mkFV fstar_tactics_result.fv [] []); - FStar_TypeChecker_NBETerm.e_typ = - (fun uu___ -> fv_as_emb_typ fstar_tactics_result.fv) - } -let (e_direction : - FStar_Tactics_Types.direction FStar_Syntax_Embeddings_Base.embedding) = - let embed_direction rng d = - match d with - | FStar_Tactics_Types.TopDown -> fstar_tactics_topdown.t - | FStar_Tactics_Types.BottomUp -> fstar_tactics_bottomup.t in - let unembed_direction t = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tactics_topdown.lid -> - FStar_Pervasives_Native.Some FStar_Tactics_Types.TopDown - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tactics_bottomup.lid -> - FStar_Pervasives_Native.Some FStar_Tactics_Types.BottomUp - | uu___1 -> FStar_Pervasives_Native.None in - mk_emb embed_direction unembed_direction fstar_tactics_direction.t -let (e_direction_nbe : - FStar_Tactics_Types.direction FStar_TypeChecker_NBETerm.embedding) = - let embed_direction cb res = - match res with - | FStar_Tactics_Types.TopDown -> - mkConstruct fstar_tactics_topdown.fv [] [] - | FStar_Tactics_Types.BottomUp -> - mkConstruct fstar_tactics_bottomup.fv [] [] in - let unembed_direction cb t = - let uu___ = FStar_TypeChecker_NBETerm.nbe_t_of_t t in - match uu___ with - | FStar_TypeChecker_NBETerm.Construct (fv, uu___1, []) when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tactics_topdown.lid -> - FStar_Pervasives_Native.Some FStar_Tactics_Types.TopDown - | FStar_TypeChecker_NBETerm.Construct (fv, uu___1, []) when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tactics_bottomup.lid -> - FStar_Pervasives_Native.Some FStar_Tactics_Types.BottomUp - | uu___1 -> - ((let uu___3 = - FStar_Compiler_Effect.op_Bang FStar_Options.debug_embedding in - if uu___3 - then - let uu___4 = - let uu___5 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded direction: %s" - uu___5 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4) - else ()); - FStar_Pervasives_Native.None) in - { - FStar_TypeChecker_NBETerm.em = embed_direction; - FStar_TypeChecker_NBETerm.un = unembed_direction; - FStar_TypeChecker_NBETerm.typ = - (fun uu___ -> mkFV fstar_tactics_direction.fv [] []); - FStar_TypeChecker_NBETerm.e_typ = - (fun uu___ -> fv_as_emb_typ fstar_tactics_direction.fv) - } -let (e_ctrl_flag : - FStar_Tactics_Types.ctrl_flag FStar_Syntax_Embeddings_Base.embedding) = - let embed_ctrl_flag rng d = - match d with - | FStar_Tactics_Types.Continue -> fstar_tactics_Continue.t - | FStar_Tactics_Types.Skip -> fstar_tactics_Skip.t - | FStar_Tactics_Types.Abort -> fstar_tactics_Abort.t in - let unembed_ctrl_flag t = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Continue.lid -> - FStar_Pervasives_Native.Some FStar_Tactics_Types.Continue - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Skip.lid -> - FStar_Pervasives_Native.Some FStar_Tactics_Types.Skip - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Abort.lid -> - FStar_Pervasives_Native.Some FStar_Tactics_Types.Abort - | uu___1 -> FStar_Pervasives_Native.None in - mk_emb embed_ctrl_flag unembed_ctrl_flag fstar_tactics_ctrl_flag.t -let (e_ctrl_flag_nbe : - FStar_Tactics_Types.ctrl_flag FStar_TypeChecker_NBETerm.embedding) = - let embed_ctrl_flag cb res = - match res with - | FStar_Tactics_Types.Continue -> - mkConstruct fstar_tactics_Continue.fv [] [] - | FStar_Tactics_Types.Skip -> mkConstruct fstar_tactics_Skip.fv [] [] - | FStar_Tactics_Types.Abort -> mkConstruct fstar_tactics_Abort.fv [] [] in - let unembed_ctrl_flag cb t = - let uu___ = FStar_TypeChecker_NBETerm.nbe_t_of_t t in - match uu___ with - | FStar_TypeChecker_NBETerm.Construct (fv, uu___1, []) when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Continue.lid -> - FStar_Pervasives_Native.Some FStar_Tactics_Types.Continue - | FStar_TypeChecker_NBETerm.Construct (fv, uu___1, []) when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Skip.lid -> - FStar_Pervasives_Native.Some FStar_Tactics_Types.Skip - | FStar_TypeChecker_NBETerm.Construct (fv, uu___1, []) when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Abort.lid -> - FStar_Pervasives_Native.Some FStar_Tactics_Types.Abort - | uu___1 -> - ((let uu___3 = - FStar_Compiler_Effect.op_Bang FStar_Options.debug_embedding in - if uu___3 - then - let uu___4 = - let uu___5 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded ctrl_flag: %s" - uu___5 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4) - else ()); - FStar_Pervasives_Native.None) in - { - FStar_TypeChecker_NBETerm.em = embed_ctrl_flag; - FStar_TypeChecker_NBETerm.un = unembed_ctrl_flag; - FStar_TypeChecker_NBETerm.typ = - (fun uu___ -> mkFV fstar_tactics_ctrl_flag.fv [] []); - FStar_TypeChecker_NBETerm.e_typ = - (fun uu___ -> fv_as_emb_typ fstar_tactics_ctrl_flag.fv) - } -let (e_unfold_side : - FStar_TypeChecker_Core.side FStar_Syntax_Embeddings_Base.embedding) = - let embed_unfold_side rng s = - match s with - | FStar_TypeChecker_Core.Left -> fstar_tc_core_unfold_side_Left.t - | FStar_TypeChecker_Core.Right -> fstar_tc_core_unfold_side_Right.t - | FStar_TypeChecker_Core.Both -> fstar_tc_core_unfold_side_Both.t - | FStar_TypeChecker_Core.Neither -> fstar_tc_core_unfold_side_Neither.t in - let unembed_unfold_side t = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tc_core_unfold_side_Left.lid - -> FStar_Pervasives_Native.Some FStar_TypeChecker_Core.Left - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tc_core_unfold_side_Right.lid - -> FStar_Pervasives_Native.Some FStar_TypeChecker_Core.Right - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tc_core_unfold_side_Both.lid - -> FStar_Pervasives_Native.Some FStar_TypeChecker_Core.Both - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv - fstar_tc_core_unfold_side_Neither.lid - -> FStar_Pervasives_Native.Some FStar_TypeChecker_Core.Neither - | uu___1 -> FStar_Pervasives_Native.None in - mk_emb embed_unfold_side unembed_unfold_side fstar_tc_core_unfold_side.t -let (e_unfold_side_nbe : - FStar_TypeChecker_Core.side FStar_TypeChecker_NBETerm.embedding) = - let embed_unfold_side cb res = - match res with - | FStar_TypeChecker_Core.Left -> - mkConstruct fstar_tc_core_unfold_side_Left.fv [] [] - | FStar_TypeChecker_Core.Right -> - mkConstruct fstar_tc_core_unfold_side_Right.fv [] [] - | FStar_TypeChecker_Core.Both -> - mkConstruct fstar_tc_core_unfold_side_Both.fv [] [] - | FStar_TypeChecker_Core.Neither -> - mkConstruct fstar_tc_core_unfold_side_Neither.fv [] [] in - let unembed_unfold_side cb t = - let uu___ = FStar_TypeChecker_NBETerm.nbe_t_of_t t in - match uu___ with - | FStar_TypeChecker_NBETerm.Construct (fv, uu___1, []) when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tc_core_unfold_side_Left.lid - -> FStar_Pervasives_Native.Some FStar_TypeChecker_Core.Left - | FStar_TypeChecker_NBETerm.Construct (fv, uu___1, []) when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tc_core_unfold_side_Right.lid - -> FStar_Pervasives_Native.Some FStar_TypeChecker_Core.Right - | FStar_TypeChecker_NBETerm.Construct (fv, uu___1, []) when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tc_core_unfold_side_Both.lid - -> FStar_Pervasives_Native.Some FStar_TypeChecker_Core.Both - | FStar_TypeChecker_NBETerm.Construct (fv, uu___1, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - fstar_tc_core_unfold_side_Neither.lid - -> FStar_Pervasives_Native.Some FStar_TypeChecker_Core.Neither - | uu___1 -> - ((let uu___3 = - FStar_Compiler_Effect.op_Bang FStar_Options.debug_embedding in - if uu___3 - then - let uu___4 = - let uu___5 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded unfold_side: %s" - uu___5 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4) - else ()); - FStar_Pervasives_Native.None) in - { - FStar_TypeChecker_NBETerm.em = embed_unfold_side; - FStar_TypeChecker_NBETerm.un = unembed_unfold_side; - FStar_TypeChecker_NBETerm.typ = - (fun uu___ -> mkFV fstar_tc_core_unfold_side.fv [] []); - FStar_TypeChecker_NBETerm.e_typ = - (fun uu___ -> fv_as_emb_typ fstar_tc_core_unfold_side.fv) - } -let (e_tot_or_ghost : - FStar_TypeChecker_Core.tot_or_ghost FStar_Syntax_Embeddings_Base.embedding) - = - let embed_tot_or_ghost rng s = - match s with - | FStar_TypeChecker_Core.E_Total -> fstar_tc_core_tot_or_ghost_ETotal.t - | FStar_TypeChecker_Core.E_Ghost -> fstar_tc_core_tot_or_ghost_EGhost.t in - let unembed_tot_or_ghost t = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv - fstar_tc_core_tot_or_ghost_ETotal.lid - -> FStar_Pervasives_Native.Some FStar_TypeChecker_Core.E_Total - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv - fstar_tc_core_tot_or_ghost_EGhost.lid - -> FStar_Pervasives_Native.Some FStar_TypeChecker_Core.E_Ghost - | uu___1 -> FStar_Pervasives_Native.None in - mk_emb embed_tot_or_ghost unembed_tot_or_ghost fstar_tc_core_tot_or_ghost.t -let (e_tot_or_ghost_nbe : - FStar_TypeChecker_Core.tot_or_ghost FStar_TypeChecker_NBETerm.embedding) = - let embed_tot_or_ghost cb res = - match res with - | FStar_TypeChecker_Core.E_Total -> - mkConstruct fstar_tc_core_tot_or_ghost_ETotal.fv [] [] - | FStar_TypeChecker_Core.E_Ghost -> - mkConstruct fstar_tc_core_tot_or_ghost_EGhost.fv [] [] in - let unembed_tot_or_ghost cb t = - let uu___ = FStar_TypeChecker_NBETerm.nbe_t_of_t t in - match uu___ with - | FStar_TypeChecker_NBETerm.Construct (fv, uu___1, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - fstar_tc_core_tot_or_ghost_ETotal.lid - -> FStar_Pervasives_Native.Some FStar_TypeChecker_Core.E_Total - | FStar_TypeChecker_NBETerm.Construct (fv, uu___1, []) when - FStar_Syntax_Syntax.fv_eq_lid fv - fstar_tc_core_tot_or_ghost_EGhost.lid - -> FStar_Pervasives_Native.Some FStar_TypeChecker_Core.E_Ghost - | uu___1 -> - ((let uu___3 = - FStar_Compiler_Effect.op_Bang FStar_Options.debug_embedding in - if uu___3 - then - let uu___4 = - let uu___5 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded tot_or_ghost: %s" - uu___5 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4) - else ()); - FStar_Pervasives_Native.None) in - { - FStar_TypeChecker_NBETerm.em = embed_tot_or_ghost; - FStar_TypeChecker_NBETerm.un = unembed_tot_or_ghost; - FStar_TypeChecker_NBETerm.typ = - (fun uu___ -> mkFV fstar_tc_core_tot_or_ghost.fv [] []); - FStar_TypeChecker_NBETerm.e_typ = - (fun uu___ -> fv_as_emb_typ fstar_tc_core_tot_or_ghost.fv) - } -let (t_tref : FStar_Syntax_Syntax.term) = - let uu___ = - let uu___1 = - let uu___2 = - FStar_Syntax_Syntax.lid_as_fv FStar_Parser_Const.tref_lid - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___2 in - FStar_Syntax_Syntax.mk_Tm_uinst uu___1 [FStar_Syntax_Syntax.U_zero] in - let uu___1 = - let uu___2 = FStar_Syntax_Syntax.iarg FStar_Syntax_Syntax.t_term in - [uu___2] in - FStar_Syntax_Syntax.mk_Tm_app uu___ uu___1 - FStar_Compiler_Range_Type.dummyRange -let e_tref : - 'a . - unit -> - 'a FStar_Tactics_Types.tref FStar_Syntax_Embeddings_Base.embedding - = - fun uu___ -> - let em r rng _shadow _norm = - FStar_Syntax_Util.mk_lazy r t_tref FStar_Syntax_Syntax.Lazy_tref - (FStar_Pervasives_Native.Some rng) in - let un t uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress t in - uu___3.FStar_Syntax_Syntax.n in - match uu___2 with - | FStar_Syntax_Syntax.Tm_lazy - { FStar_Syntax_Syntax.blob = blob; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_tref; - FStar_Syntax_Syntax.ltyp = uu___3; - FStar_Syntax_Syntax.rng = uu___4;_} - -> - let uu___5 = FStar_Dyn.undyn blob in - FStar_Pervasives_Native.Some uu___5 - | uu___3 -> FStar_Pervasives_Native.None in - FStar_Syntax_Embeddings_Base.mk_emb_full em un (fun uu___1 -> t_tref) - (fun i -> "tref") - (fun uu___1 -> - let uu___2 = - let uu___3 = FStar_Ident.string_of_lid FStar_Parser_Const.tref_lid in - (uu___3, [FStar_Syntax_Syntax.ET_abstract]) in - FStar_Syntax_Syntax.ET_app uu___2) -let e_tref_nbe : - 'a . - unit -> 'a FStar_Tactics_Types.tref FStar_TypeChecker_NBETerm.embedding - = - fun uu___ -> - let embed_tref _cb r = - let li = - { - FStar_Syntax_Syntax.blob = (FStar_Dyn.mkdyn r); - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_tref; - FStar_Syntax_Syntax.ltyp = t_tref; - FStar_Syntax_Syntax.rng = FStar_Compiler_Range_Type.dummyRange - } in - let thunk = - FStar_Thunk.mk - (fun uu___1 -> - FStar_TypeChecker_NBETerm.mk_t - (FStar_TypeChecker_NBETerm.Constant - (FStar_TypeChecker_NBETerm.String - ("(((tref.nbe)))", FStar_Compiler_Range_Type.dummyRange)))) in - FStar_TypeChecker_NBETerm.mk_t - (FStar_TypeChecker_NBETerm.Lazy ((FStar_Pervasives.Inl li), thunk)) in - let unembed_tref _cb t = - let uu___1 = FStar_TypeChecker_NBETerm.nbe_t_of_t t in - match uu___1 with - | FStar_TypeChecker_NBETerm.Lazy - (FStar_Pervasives.Inl - { FStar_Syntax_Syntax.blob = b; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_tref; - FStar_Syntax_Syntax.ltyp = uu___2; - FStar_Syntax_Syntax.rng = uu___3;_}, - uu___4) - -> - let uu___5 = FStar_Dyn.undyn b in - FStar_Pervasives_Native.Some uu___5 - | uu___2 -> - ((let uu___4 = - FStar_Compiler_Effect.op_Bang FStar_Options.debug_embedding in - if uu___4 - then - let uu___5 = - let uu___6 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.format1 "Not an embedded NBE tref: %s\n" - uu___6 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded - () (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___5) - else ()); - FStar_Pervasives_Native.None) in - { - FStar_TypeChecker_NBETerm.em = embed_tref; - FStar_TypeChecker_NBETerm.un = unembed_tref; - FStar_TypeChecker_NBETerm.typ = - (fun uu___1 -> - let term_t = - let uu___2 = - FStar_Syntax_Syntax.lid_as_fv - FStar_Parser_Const.fstar_syntax_syntax_term - FStar_Pervasives_Native.None in - mkFV uu___2 [] [] in - let uu___2 = - FStar_Syntax_Syntax.lid_as_fv FStar_Parser_Const.tref_lid - FStar_Pervasives_Native.None in - let uu___3 = - let uu___4 = FStar_TypeChecker_NBETerm.as_arg term_t in [uu___4] in - mkFV uu___2 [FStar_Syntax_Syntax.U_zero] uu___3); - FStar_TypeChecker_NBETerm.e_typ = - (fun uu___1 -> - let uu___2 = - let uu___3 = - FStar_Ident.string_of_lid FStar_Parser_Const.tref_lid in - (uu___3, [FStar_Syntax_Syntax.ET_abstract]) in - FStar_Syntax_Syntax.ET_app uu___2) - } -let (e_guard_policy : - FStar_Tactics_Types.guard_policy FStar_Syntax_Embeddings_Base.embedding) = - let embed_guard_policy rng p = - match p with - | FStar_Tactics_Types.SMT -> fstar_tactics_SMT.t - | FStar_Tactics_Types.SMTSync -> fstar_tactics_SMTSync.t - | FStar_Tactics_Types.Goal -> fstar_tactics_Goal.t - | FStar_Tactics_Types.Force -> fstar_tactics_Force.t - | FStar_Tactics_Types.Drop -> fstar_tactics_Drop.t in - let unembed_guard_policy t = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tactics_SMT.lid -> - FStar_Pervasives_Native.Some FStar_Tactics_Types.SMT - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tactics_SMTSync.lid -> - FStar_Pervasives_Native.Some FStar_Tactics_Types.SMTSync - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Goal.lid -> - FStar_Pervasives_Native.Some FStar_Tactics_Types.Goal - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Force.lid -> - FStar_Pervasives_Native.Some FStar_Tactics_Types.Force - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Drop.lid -> - FStar_Pervasives_Native.Some FStar_Tactics_Types.Drop - | uu___1 -> FStar_Pervasives_Native.None in - mk_emb embed_guard_policy unembed_guard_policy fstar_tactics_guard_policy.t -let (e_guard_policy_nbe : - FStar_Tactics_Types.guard_policy FStar_TypeChecker_NBETerm.embedding) = - let embed_guard_policy cb p = - match p with - | FStar_Tactics_Types.SMT -> mkConstruct fstar_tactics_SMT.fv [] [] - | FStar_Tactics_Types.SMTSync -> - mkConstruct fstar_tactics_SMTSync.fv [] [] - | FStar_Tactics_Types.Goal -> mkConstruct fstar_tactics_Goal.fv [] [] - | FStar_Tactics_Types.Force -> mkConstruct fstar_tactics_Force.fv [] [] - | FStar_Tactics_Types.Drop -> mkConstruct fstar_tactics_Drop.fv [] [] in - let unembed_guard_policy cb t = - let uu___ = FStar_TypeChecker_NBETerm.nbe_t_of_t t in - match uu___ with - | FStar_TypeChecker_NBETerm.Construct (fv, uu___1, []) when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tactics_SMT.lid -> - FStar_Pervasives_Native.Some FStar_Tactics_Types.SMT - | FStar_TypeChecker_NBETerm.Construct (fv, uu___1, []) when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tactics_SMTSync.lid -> - FStar_Pervasives_Native.Some FStar_Tactics_Types.SMTSync - | FStar_TypeChecker_NBETerm.Construct (fv, uu___1, []) when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Goal.lid -> - FStar_Pervasives_Native.Some FStar_Tactics_Types.Goal - | FStar_TypeChecker_NBETerm.Construct (fv, uu___1, []) when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Force.lid -> - FStar_Pervasives_Native.Some FStar_Tactics_Types.Force - | FStar_TypeChecker_NBETerm.Construct (fv, uu___1, []) when - FStar_Syntax_Syntax.fv_eq_lid fv fstar_tactics_Drop.lid -> - FStar_Pervasives_Native.Some FStar_Tactics_Types.Drop - | uu___1 -> FStar_Pervasives_Native.None in - { - FStar_TypeChecker_NBETerm.em = embed_guard_policy; - FStar_TypeChecker_NBETerm.un = unembed_guard_policy; - FStar_TypeChecker_NBETerm.typ = - (fun uu___ -> mkFV fstar_tactics_guard_policy.fv [] []); - FStar_TypeChecker_NBETerm.e_typ = - (fun uu___ -> fv_as_emb_typ fstar_tactics_guard_policy.fv) - } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_Hooks.ml b/ocaml/fstar-lib/generated/FStar_Tactics_Hooks.ml deleted file mode 100644 index 63d71655d21..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Tactics_Hooks.ml +++ /dev/null @@ -1,2502 +0,0 @@ -open Prims -let (dbg_Tac : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Tac" -let (dbg_SpinoffAll : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "SpinoffAll" -let (run_tactic_on_typ : - FStar_Compiler_Range_Type.range -> - FStar_Compiler_Range_Type.range -> - FStar_Syntax_Syntax.term -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - (FStar_Tactics_Types.goal Prims.list * FStar_Syntax_Syntax.term)) - = - fun rng_tac -> - fun rng_goal -> - fun tactic -> - fun env -> - fun typ -> - let rng = - let uu___ = FStar_Compiler_Range_Type.use_range rng_tac in - let uu___1 = FStar_Compiler_Range_Type.use_range rng_goal in - FStar_Compiler_Range_Type.range_of_rng uu___ uu___1 in - let uu___ = - FStar_Tactics_V2_Basic.proofstate_of_goal_ty rng env typ in - match uu___ with - | (ps, w) -> - let tactic_already_typed = false in - let uu___1 = - FStar_Tactics_Interpreter.run_tactic_on_ps rng_tac rng_goal - false FStar_Syntax_Embeddings.e_unit () - FStar_Syntax_Embeddings.e_unit tactic - tactic_already_typed ps in - (match uu___1 with | (gs, _res) -> (gs, w)) -let (run_tactic_on_all_implicits : - FStar_Compiler_Range_Type.range -> - FStar_Compiler_Range_Type.range -> - FStar_Syntax_Syntax.term -> - FStar_TypeChecker_Env.env -> - FStar_TypeChecker_Env.implicits -> - FStar_Tactics_Types.goal Prims.list) - = - fun rng_tac -> - fun rng_goal -> - fun tactic -> - fun env -> - fun imps -> - let uu___ = - FStar_Tactics_V2_Basic.proofstate_of_all_implicits rng_goal env - imps in - match uu___ with - | (ps, uu___1) -> - let tactic_already_typed = false in - let uu___2 = - let uu___3 = FStar_TypeChecker_Env.get_range env in - FStar_Tactics_Interpreter.run_tactic_on_ps uu___3 rng_goal - true FStar_Syntax_Embeddings.e_unit () - FStar_Syntax_Embeddings.e_unit tactic - tactic_already_typed ps in - (match uu___2 with | (goals, ()) -> goals) -type pol = - | StrictlyPositive - | Pos - | Neg - | Both -let (uu___is_StrictlyPositive : pol -> Prims.bool) = - fun projectee -> - match projectee with | StrictlyPositive -> true | uu___ -> false -let (uu___is_Pos : pol -> Prims.bool) = - fun projectee -> match projectee with | Pos -> true | uu___ -> false -let (uu___is_Neg : pol -> Prims.bool) = - fun projectee -> match projectee with | Neg -> true | uu___ -> false -let (uu___is_Both : pol -> Prims.bool) = - fun projectee -> match projectee with | Both -> true | uu___ -> false -type 'a tres_m = - | Unchanged of 'a - | Simplified of ('a * FStar_Tactics_Types.goal Prims.list) - | Dual of ('a * 'a * FStar_Tactics_Types.goal Prims.list) -let uu___is_Unchanged : 'a . 'a tres_m -> Prims.bool = - fun projectee -> - match projectee with | Unchanged _0 -> true | uu___ -> false -let __proj__Unchanged__item___0 : 'a . 'a tres_m -> 'a = - fun projectee -> match projectee with | Unchanged _0 -> _0 -let uu___is_Simplified : 'a . 'a tres_m -> Prims.bool = - fun projectee -> - match projectee with | Simplified _0 -> true | uu___ -> false -let __proj__Simplified__item___0 : - 'a . 'a tres_m -> ('a * FStar_Tactics_Types.goal Prims.list) = - fun projectee -> match projectee with | Simplified _0 -> _0 -let uu___is_Dual : 'a . 'a tres_m -> Prims.bool = - fun projectee -> match projectee with | Dual _0 -> true | uu___ -> false -let __proj__Dual__item___0 : - 'a . 'a tres_m -> ('a * 'a * FStar_Tactics_Types.goal Prims.list) = - fun projectee -> match projectee with | Dual _0 -> _0 -type tres = FStar_Syntax_Syntax.term tres_m -let tpure : 'uuuuu . 'uuuuu -> 'uuuuu tres_m = fun x -> Unchanged x -let (flip : pol -> pol) = - fun p -> - match p with - | StrictlyPositive -> Neg - | Pos -> Neg - | Neg -> Pos - | Both -> Both -let (getprop : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = - fun e -> - fun t -> - let tn = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Weak; - FStar_TypeChecker_Env.HNF; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant] e t in - FStar_Syntax_Util.un_squash tn -let (by_tactic_interp : - pol -> FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.term -> tres) = - fun pol1 -> - fun e -> - fun t -> - let uu___ = FStar_Syntax_Util.head_and_args t in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst hd in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, - (tactic, FStar_Pervasives_Native.None)::(assertion, - FStar_Pervasives_Native.None)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.by_tactic_lid - -> - (match pol1 with - | StrictlyPositive -> - let uu___2 = - run_tactic_on_typ tactic.FStar_Syntax_Syntax.pos - assertion.FStar_Syntax_Syntax.pos tactic e - assertion in - (match uu___2 with - | (gs, uu___3) -> - Simplified (FStar_Syntax_Util.t_true, gs)) - | Pos -> - let uu___2 = - run_tactic_on_typ tactic.FStar_Syntax_Syntax.pos - assertion.FStar_Syntax_Syntax.pos tactic e - assertion in - (match uu___2 with - | (gs, uu___3) -> - Simplified (FStar_Syntax_Util.t_true, gs)) - | Both -> - let uu___2 = - run_tactic_on_typ tactic.FStar_Syntax_Syntax.pos - assertion.FStar_Syntax_Syntax.pos tactic e - assertion in - (match uu___2 with - | (gs, uu___3) -> - Dual (assertion, FStar_Syntax_Util.t_true, gs)) - | Neg -> Simplified (assertion, [])) - | (FStar_Syntax_Syntax.Tm_fvar fv, - (assertion, FStar_Pervasives_Native.None)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.spinoff_lid - -> - (match pol1 with - | StrictlyPositive -> - let g = - let uu___2 = - FStar_Tactics_Types.goal_of_goal_ty e assertion in - FStar_Pervasives_Native.fst uu___2 in - let g1 = - FStar_Tactics_Types.set_label "spun-off assertion" g in - Simplified (FStar_Syntax_Util.t_true, [g1]) - | Pos -> - let g = - let uu___2 = - FStar_Tactics_Types.goal_of_goal_ty e assertion in - FStar_Pervasives_Native.fst uu___2 in - let g1 = - FStar_Tactics_Types.set_label "spun-off assertion" g in - Simplified (FStar_Syntax_Util.t_true, [g1]) - | Both -> - let g = - let uu___2 = - FStar_Tactics_Types.goal_of_goal_ty e assertion in - FStar_Pervasives_Native.fst uu___2 in - let g1 = - FStar_Tactics_Types.set_label "spun-off assertion" g in - Dual (assertion, FStar_Syntax_Util.t_true, [g1]) - | Neg -> Simplified (assertion, [])) - | (FStar_Syntax_Syntax.Tm_fvar fv, - (tactic, FStar_Pervasives_Native.None)::(typ, - FStar_Pervasives_Native.Some - { - FStar_Syntax_Syntax.aqual_implicit - = true; - FStar_Syntax_Syntax.aqual_attributes - = uu___2;_}):: - (tm, FStar_Pervasives_Native.None)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.rewrite_by_tactic_lid - -> - let uu___3 = - FStar_TypeChecker_Env.new_implicit_var_aux - "rewrite_with_tactic RHS" tm.FStar_Syntax_Syntax.pos e - typ FStar_Syntax_Syntax.Strict - FStar_Pervasives_Native.None false in - (match uu___3 with - | (uvtm, uu___4, g_imp) -> - let u = e.FStar_TypeChecker_Env.universe_of e typ in - let goal = - let uu___5 = FStar_Syntax_Util.mk_eq2 u typ tm uvtm in - FStar_Syntax_Util.mk_squash - FStar_Syntax_Syntax.U_zero uu___5 in - let uu___5 = - run_tactic_on_typ tactic.FStar_Syntax_Syntax.pos - tm.FStar_Syntax_Syntax.pos tactic e goal in - (match uu___5 with - | (gs, uu___6) -> - let tagged_imps = - FStar_TypeChecker_Rel.resolve_implicits_tac e - g_imp in - (FStar_Tactics_Interpreter.report_implicits - tm.FStar_Syntax_Syntax.pos tagged_imps; - Simplified (uvtm, gs)))) - | uu___2 -> Unchanged t) -let explode : - 'a . 'a tres_m -> ('a * 'a * FStar_Tactics_Types.goal Prims.list) = - fun t -> - match t with - | Unchanged t1 -> (t1, t1, []) - | Simplified (t1, gs) -> (t1, t1, gs) - | Dual (tn, tp, gs) -> (tn, tp, gs) -let comb1 : 'a 'b . ('a -> 'b) -> 'a tres_m -> 'b tres_m = - fun f -> - fun uu___ -> - match uu___ with - | Unchanged t -> let uu___1 = f t in Unchanged uu___1 - | Simplified (t, gs) -> - let uu___1 = let uu___2 = f t in (uu___2, gs) in Simplified uu___1 - | Dual (tn, tp, gs) -> - let uu___1 = - let uu___2 = f tn in let uu___3 = f tp in (uu___2, uu___3, gs) in - Dual uu___1 -let comb2 : - 'a 'b 'c . ('a -> 'b -> 'c) -> 'a tres_m -> 'b tres_m -> 'c tres_m = - fun f -> - fun x -> - fun y -> - match (x, y) with - | (Unchanged t1, Unchanged t2) -> - let uu___ = f t1 t2 in Unchanged uu___ - | (Unchanged t1, Simplified (t2, gs)) -> - let uu___ = let uu___1 = f t1 t2 in (uu___1, gs) in - Simplified uu___ - | (Simplified (t1, gs), Unchanged t2) -> - let uu___ = let uu___1 = f t1 t2 in (uu___1, gs) in - Simplified uu___ - | (Simplified (t1, gs1), Simplified (t2, gs2)) -> - let uu___ = - let uu___1 = f t1 t2 in - (uu___1, (FStar_Compiler_List.op_At gs1 gs2)) in - Simplified uu___ - | uu___ -> - let uu___1 = explode x in - (match uu___1 with - | (n1, p1, gs1) -> - let uu___2 = explode y in - (match uu___2 with - | (n2, p2, gs2) -> - let uu___3 = - let uu___4 = f n1 n2 in - let uu___5 = f p1 p2 in - (uu___4, uu___5, (FStar_Compiler_List.op_At gs1 gs2)) in - Dual uu___3)) -let comb_list : 'a . 'a tres_m Prims.list -> 'a Prims.list tres_m = - fun rs -> - let rec aux rs1 acc = - match rs1 with - | [] -> acc - | hd::tl -> - let uu___ = comb2 (fun l -> fun r -> l :: r) hd acc in aux tl uu___ in - aux (FStar_Compiler_List.rev rs) (tpure []) -let emit : 'a . FStar_Tactics_Types.goal Prims.list -> 'a tres_m -> 'a tres_m - = - fun gs -> fun m -> comb2 (fun uu___ -> fun x -> x) (Simplified ((), gs)) m -let rec (traverse : - (pol -> FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.term -> tres) -> - pol -> FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.term -> tres) - = - fun f -> - fun pol1 -> - fun e -> - fun t -> - let r = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_uinst (t1, us) -> - let tr = traverse f pol1 e t1 in - let uu___1 = - comb1 (fun t' -> FStar_Syntax_Syntax.Tm_uinst (t', us)) in - uu___1 tr - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t1; - FStar_Syntax_Syntax.meta = m;_} - -> - let tr = traverse f pol1 e t1 in - let uu___1 = - comb1 - (fun t' -> - FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 = t'; - FStar_Syntax_Syntax.meta = m - }) in - uu___1 tr - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___1; - FStar_Syntax_Syntax.vars = uu___2; - FStar_Syntax_Syntax.hash_code = uu___3;_}; - FStar_Syntax_Syntax.args = (p, uu___4)::(q, uu___5)::[];_} - when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.imp_lid - -> - let x = - FStar_Syntax_Syntax.new_bv FStar_Pervasives_Native.None p in - let r1 = traverse f (flip pol1) e p in - let r2 = - let uu___6 = FStar_TypeChecker_Env.push_bv e x in - traverse f pol1 uu___6 q in - comb2 - (fun l -> - fun r3 -> - let uu___6 = FStar_Syntax_Util.mk_imp l r3 in - uu___6.FStar_Syntax_Syntax.n) r1 r2 - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___1; - FStar_Syntax_Syntax.vars = uu___2; - FStar_Syntax_Syntax.hash_code = uu___3;_}; - FStar_Syntax_Syntax.args = (p, uu___4)::(q, uu___5)::[];_} - when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.iff_lid - -> - let xp = - FStar_Syntax_Syntax.new_bv FStar_Pervasives_Native.None p in - let xq = - FStar_Syntax_Syntax.new_bv FStar_Pervasives_Native.None q in - let r1 = - let uu___6 = FStar_TypeChecker_Env.push_bv e xq in - traverse f Both uu___6 p in - let r2 = - let uu___6 = FStar_TypeChecker_Env.push_bv e xp in - traverse f Both uu___6 q in - (match (r1, r2) with - | (Unchanged uu___6, Unchanged uu___7) -> - comb2 - (fun l -> - fun r3 -> - let uu___8 = FStar_Syntax_Util.mk_iff l r3 in - uu___8.FStar_Syntax_Syntax.n) r1 r2 - | uu___6 -> - let uu___7 = explode r1 in - (match uu___7 with - | (pn, pp, gs1) -> - let uu___8 = explode r2 in - (match uu___8 with - | (qn, qp, gs2) -> - let t1 = - let uu___9 = FStar_Syntax_Util.mk_imp pn qp in - let uu___10 = FStar_Syntax_Util.mk_imp qn pp in - FStar_Syntax_Util.mk_conj uu___9 uu___10 in - Simplified - ((t1.FStar_Syntax_Syntax.n), - (FStar_Compiler_List.op_At gs1 gs2))))) - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = hd; - FStar_Syntax_Syntax.args = args;_} - -> - let r0 = traverse f pol1 e hd in - let r1 = - FStar_Compiler_List.fold_right - (fun uu___1 -> - fun r2 -> - match uu___1 with - | (a, q) -> - let r' = traverse f pol1 e a in - comb2 (fun a1 -> fun args1 -> (a1, q) :: args1) - r' r2) args (tpure []) in - comb2 - (fun hd1 -> - fun args1 -> - FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = hd1; - FStar_Syntax_Syntax.args = args1 - }) r0 r1 - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs; FStar_Syntax_Syntax.body = t1; - FStar_Syntax_Syntax.rc_opt = k;_} - -> - let uu___1 = FStar_Syntax_Subst.open_term bs t1 in - (match uu___1 with - | (bs1, topen) -> - let e' = FStar_TypeChecker_Env.push_binders e bs1 in - let r0 = - FStar_Compiler_List.map - (fun b -> - let r1 = - traverse f (flip pol1) e - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - let uu___2 = - comb1 - (fun s' -> - { - FStar_Syntax_Syntax.binder_bv = - (let uu___3 = - b.FStar_Syntax_Syntax.binder_bv in - { - FStar_Syntax_Syntax.ppname = - (uu___3.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (uu___3.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = s' - }); - FStar_Syntax_Syntax.binder_qual = - (b.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity = - (b.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs = - (b.FStar_Syntax_Syntax.binder_attrs) - }) in - uu___2 r1) bs1 in - let rbs = comb_list r0 in - let rt = traverse f pol1 e' topen in - comb2 - (fun bs2 -> - fun t2 -> - let uu___2 = FStar_Syntax_Util.abs bs2 t2 k in - uu___2.FStar_Syntax_Syntax.n) rbs rt) - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t1; FStar_Syntax_Syntax.asc = asc; - FStar_Syntax_Syntax.eff_opt = ef;_} - -> - let uu___1 = traverse f pol1 e t1 in - let uu___2 = - comb1 - (fun t2 -> - FStar_Syntax_Syntax.Tm_ascribed - { - FStar_Syntax_Syntax.tm = t2; - FStar_Syntax_Syntax.asc = asc; - FStar_Syntax_Syntax.eff_opt = ef - }) in - uu___2 uu___1 - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = sc; - FStar_Syntax_Syntax.ret_opt = asc_opt; - FStar_Syntax_Syntax.brs = brs; - FStar_Syntax_Syntax.rc_opt1 = lopt;_} - -> - let uu___1 = traverse f pol1 e sc in - let uu___2 = - let uu___3 = - FStar_Compiler_List.map - (fun br -> - let uu___4 = FStar_Syntax_Subst.open_branch br in - match uu___4 with - | (pat, w, exp) -> - let bvs = FStar_Syntax_Syntax.pat_bvs pat in - let e1 = FStar_TypeChecker_Env.push_bvs e bvs in - let r1 = traverse f pol1 e1 exp in - let uu___5 = - comb1 - (fun exp1 -> - FStar_Syntax_Subst.close_branch - (pat, w, exp1)) in - uu___5 r1) brs in - comb_list uu___3 in - comb2 - (fun sc1 -> - fun brs1 -> - FStar_Syntax_Syntax.Tm_match - { - FStar_Syntax_Syntax.scrutinee = sc1; - FStar_Syntax_Syntax.ret_opt = asc_opt; - FStar_Syntax_Syntax.brs = brs1; - FStar_Syntax_Syntax.rc_opt1 = lopt - }) uu___1 uu___2 - | x -> tpure x in - match r with - | Unchanged tn' -> - f pol1 e - { - FStar_Syntax_Syntax.n = tn'; - FStar_Syntax_Syntax.pos = (t.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = (t.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (t.FStar_Syntax_Syntax.hash_code) - } - | Simplified (tn', gs) -> - let uu___ = - f pol1 e - { - FStar_Syntax_Syntax.n = tn'; - FStar_Syntax_Syntax.pos = (t.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = (t.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (t.FStar_Syntax_Syntax.hash_code) - } in - emit gs uu___ - | Dual (tn, tp, gs) -> - let rp = - f pol1 e - { - FStar_Syntax_Syntax.n = tp; - FStar_Syntax_Syntax.pos = (t.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = (t.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (t.FStar_Syntax_Syntax.hash_code) - } in - let uu___ = explode rp in - (match uu___ with - | (uu___1, p', gs') -> - Dual - ({ - FStar_Syntax_Syntax.n = tn; - FStar_Syntax_Syntax.pos = (t.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = - (t.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (t.FStar_Syntax_Syntax.hash_code) - }, p', (FStar_Compiler_List.op_At gs gs'))) -let (preprocess : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - (Prims.bool * (FStar_TypeChecker_Env.env * FStar_Syntax_Syntax.term * - FStar_Options.optionstate) Prims.list)) - = - fun env -> - fun goal -> - FStar_Errors.with_ctx "While preprocessing VC with a tactic" - (fun uu___ -> - (let uu___2 = FStar_Compiler_Effect.op_Bang dbg_Tac in - if uu___2 - then - let uu___3 = - let uu___4 = FStar_TypeChecker_Env.all_binders env in - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binder) uu___4 in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term goal in - FStar_Compiler_Util.print2 "About to preprocess %s |= %s\n" - uu___3 uu___4 - else ()); - (let initial = (Prims.int_one, []) in - let uu___2 = - let uu___3 = traverse by_tactic_interp Pos env goal in - match uu___3 with - | Unchanged t' -> (false, (t', [])) - | Simplified (t', gs) -> (true, (t', gs)) - | uu___4 -> - failwith "preprocess: impossible, traverse returned a Dual" in - match uu___2 with - | (did_anything, (t', gs)) -> - ((let uu___4 = FStar_Compiler_Effect.op_Bang dbg_Tac in - if uu___4 - then - let uu___5 = - let uu___6 = FStar_TypeChecker_Env.all_binders env in - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binder) uu___6 in - let uu___6 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - t' in - FStar_Compiler_Util.print2 - "Main goal simplified to: %s |- %s\n" uu___5 uu___6 - else ()); - (let s = initial in - let s1 = - FStar_Compiler_List.fold_left - (fun uu___4 -> - fun g -> - match uu___4 with - | (n, gs1) -> - let phi = - let uu___5 = - let uu___6 = - FStar_Tactics_Types.goal_env g in - let uu___7 = - FStar_Tactics_Types.goal_type g in - getprop uu___6 uu___7 in - match uu___5 with - | FStar_Pervasives_Native.None -> - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Tactics_Types.goal_type g in - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - uu___8 in - FStar_Compiler_Util.format1 - "Tactic returned proof-relevant goal: %s" - uu___7 in - FStar_Errors.raise_error - FStar_TypeChecker_Env.hasRange_env env - FStar_Errors_Codes.Fatal_TacticProofRelevantGoal - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___6) - | FStar_Pervasives_Native.Some phi1 -> phi1 in - ((let uu___6 = - FStar_Compiler_Effect.op_Bang dbg_Tac in - if uu___6 - then - let uu___7 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - n in - let uu___8 = - let uu___9 = - FStar_Tactics_Types.goal_type g in - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - uu___9 in - FStar_Compiler_Util.print2 - "Got goal #%s: %s\n" uu___7 uu___8 - else ()); - (let label = - let uu___6 = - let uu___7 = - FStar_Pprint.doc_of_string - "Could not prove goal #" in - let uu___8 = - let uu___9 = - FStar_Class_PP.pp - FStar_Class_PP.pp_int n in - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Tactics_Types.get_label g in - uu___12 = "" in - if uu___11 - then FStar_Pprint.empty - else - (let uu___13 = - let uu___14 = - FStar_Tactics_Types.get_label - g in - FStar_Pprint.doc_of_string - uu___14 in - FStar_Pprint.parens uu___13) in - FStar_Pprint.op_Hat_Slash_Hat uu___9 - uu___10 in - FStar_Pprint.op_Hat_Hat uu___7 uu___8 in - [uu___6] in - let gt' = - let uu___6 = - FStar_Tactics_Types.goal_range g in - FStar_TypeChecker_Util.label label uu___6 - phi in - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Tactics_Types.goal_env g in - let uu___9 = - FStar_Tactics_Types.goal_opts g in - (uu___8, gt', uu___9) in - uu___7 :: gs1 in - ((n + Prims.int_one), uu___6)))) s gs in - let uu___4 = s1 in - match uu___4 with - | (uu___5, gs1) -> - let gs2 = FStar_Compiler_List.rev gs1 in - let uu___6 = - let uu___7 = - let uu___8 = FStar_Options.peek () in - (env, t', uu___8) in - uu___7 :: gs2 in - (did_anything, uu___6))))) -let rec (traverse_for_spinoff : - pol -> - (FStar_Pprint.document Prims.list * FStar_Compiler_Range_Type.range) - FStar_Pervasives_Native.option -> - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.term -> tres) - = - fun pol1 -> - fun label_ctx -> - fun e -> - fun t -> - let debug_any = FStar_Compiler_Debug.any () in - let traverse1 pol2 e1 t1 = - traverse_for_spinoff pol2 label_ctx e1 t1 in - let traverse_ctx pol2 ctx e1 t1 = - let print_lc uu___ = - match uu___ with - | (msg, rng) -> - let uu___1 = - FStar_Compiler_Range_Ops.string_of_def_range rng in - let uu___2 = - FStar_Compiler_Range_Ops.string_of_use_range rng in - let uu___3 = FStar_Errors_Msg.rendermsg msg in - FStar_Compiler_Util.format3 "(%s,%s) : %s" uu___1 uu___2 - uu___3 in - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_SpinoffAll in - if uu___1 - then - let uu___2 = - match label_ctx with - | FStar_Pervasives_Native.None -> "None" - | FStar_Pervasives_Native.Some lc -> print_lc lc in - let uu___3 = print_lc ctx in - FStar_Compiler_Util.print2 - "Changing label context from %s to %s" uu___2 uu___3 - else ()); - traverse_for_spinoff pol2 (FStar_Pervasives_Native.Some ctx) e1 - t1 in - let should_descend t1 = - let uu___ = FStar_Syntax_Util.head_and_args t1 in - match uu___ with - | (hd, args) -> - let res = - let uu___1 = - let uu___2 = FStar_Syntax_Util.un_uinst hd in - uu___2.FStar_Syntax_Syntax.n in - match uu___1 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - ((((FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.and_lid) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.imp_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.forall_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.auto_squash_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.squash_lid) - | FStar_Syntax_Syntax.Tm_meta uu___2 -> true - | FStar_Syntax_Syntax.Tm_ascribed uu___2 -> true - | FStar_Syntax_Syntax.Tm_abs uu___2 -> true - | uu___2 -> false in - res in - let maybe_spinoff pol2 label_ctx1 e1 t1 = - let label_goal uu___ = - match uu___ with - | (env, t2) -> - let t3 = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress t2 in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, label_ctx1) in - match uu___1 with - | (FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = uu___2; - FStar_Syntax_Syntax.meta = - FStar_Syntax_Syntax.Meta_labeled uu___3;_}, - uu___4) -> t2 - | (uu___2, FStar_Pervasives_Native.Some (msg, r)) -> - FStar_TypeChecker_Util.label msg r t2 - | uu___2 -> t2 in - let t4 = - let uu___1 = FStar_Syntax_Util.is_sub_singleton t3 in - if uu___1 - then t3 - else - FStar_Syntax_Util.mk_auto_squash - FStar_Syntax_Syntax.U_zero t3 in - let uu___1 = FStar_Tactics_Types.goal_of_goal_ty env t4 in - FStar_Pervasives_Native.fst uu___1 in - let spinoff t2 = - match pol2 with - | StrictlyPositive -> - ((let uu___1 = FStar_Compiler_Effect.op_Bang dbg_SpinoffAll in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t2 in - FStar_Compiler_Util.print1 "Spinning off %s\n" uu___2 - else ()); - (let uu___1 = - let uu___2 = - let uu___3 = label_goal (e1, t2) in [uu___3] in - (FStar_Syntax_Util.t_true, uu___2) in - Simplified uu___1)) - | uu___ -> Unchanged t2 in - let t2 = FStar_Syntax_Subst.compress t1 in - let uu___ = - let uu___1 = should_descend t2 in Prims.op_Negation uu___1 in - if uu___ then spinoff t2 else Unchanged t2 in - let rewrite_boolean_conjunction t1 = - let uu___ = FStar_Syntax_Util.head_and_args t1 in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst hd in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, (t2, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.b2t_lid - -> - let uu___3 = FStar_Syntax_Util.head_and_args t2 in - (match uu___3 with - | (hd1, args1) -> - let uu___4 = - let uu___5 = - let uu___6 = FStar_Syntax_Util.un_uinst hd1 in - uu___6.FStar_Syntax_Syntax.n in - (uu___5, args1) in - (match uu___4 with - | (FStar_Syntax_Syntax.Tm_fvar fv1, - (t0, uu___5)::(t11, uu___6)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv1 - FStar_Parser_Const.op_And - -> - let t3 = - let uu___7 = FStar_Syntax_Util.b2t t0 in - let uu___8 = FStar_Syntax_Util.b2t t11 in - FStar_Syntax_Util.mk_conj uu___7 uu___8 in - FStar_Pervasives_Native.Some t3 - | uu___5 -> FStar_Pervasives_Native.None)) - | uu___2 -> FStar_Pervasives_Native.None) in - let try_rewrite_match env t1 = - let rec pat_as_exp env1 p = - let uu___ = - FStar_TypeChecker_PatternUtils.raw_pat_as_exp env1 p in - match uu___ with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (e1, uu___1) -> - let uu___2 = FStar_TypeChecker_Env.clear_expected_typ env1 in - (match uu___2 with - | (env2, uu___3) -> - let uu___4 = - FStar_TypeChecker_TcTerm.tc_trivial_guard - { - FStar_TypeChecker_Env.solver = - (env2.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env2.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env2.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env2.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env2.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env2.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env2.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env2.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env2.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env2.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env2.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env2.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env2.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env2.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env2.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env2.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env2.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env2.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = true; - FStar_TypeChecker_Env.lax_universes = - (env2.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env2.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env2.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env2.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env2.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env2.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env2.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env2.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env2.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env2.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env2.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env2.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env2.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env2.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env2.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env2.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env2.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env2.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env2.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env2.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env2.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env2.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env2.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env2.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env2.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env2.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env2.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env2.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env2.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env2.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env2.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env2.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env2.FStar_TypeChecker_Env.missing_decl) - } e1 in - (match uu___4 with - | (e2, lc) -> - let u = - FStar_TypeChecker_TcTerm.universe_of env2 - lc.FStar_TypeChecker_Common.res_typ in - FStar_Pervasives_Native.Some - (e2, (lc.FStar_TypeChecker_Common.res_typ), u))) in - let bv_universes env1 bvs = - FStar_Compiler_List.map - (fun x -> - let uu___ = - FStar_TypeChecker_TcTerm.universe_of env1 - x.FStar_Syntax_Syntax.sort in - (x, uu___)) bvs in - let mk_forall_l bv_univs term = - FStar_Compiler_List.fold_right - (fun uu___ -> - fun out -> - match uu___ with - | (x, u) -> FStar_Syntax_Util.mk_forall u x out) - bv_univs term in - let mk_exists_l bv_univs term = - FStar_Compiler_List.fold_right - (fun uu___ -> - fun out -> - match uu___ with - | (x, u) -> FStar_Syntax_Util.mk_exists u x out) - bv_univs term in - if pol1 <> StrictlyPositive - then FStar_Pervasives_Native.None - else - (let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress t1 in - uu___2.FStar_Syntax_Syntax.n in - match uu___1 with - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = sc; - FStar_Syntax_Syntax.ret_opt = asc_opt; - FStar_Syntax_Syntax.brs = brs; - FStar_Syntax_Syntax.rc_opt1 = lopt;_} - -> - let rec rewrite_branches path_condition branches = - match branches with - | [] -> - let uu___2 = - FStar_Syntax_Util.mk_imp path_condition - FStar_Syntax_Util.t_false in - FStar_Pervasives.Inr uu___2 - | br::branches1 -> - let uu___2 = FStar_Syntax_Subst.open_branch br in - (match uu___2 with - | (pat, w, body) -> - (match w with - | FStar_Pervasives_Native.Some uu___3 -> - FStar_Pervasives.Inl "when clause" - | uu___3 -> - let bvs = FStar_Syntax_Syntax.pat_bvs pat in - let env1 = - FStar_TypeChecker_Env.push_bvs env bvs in - let bvs_univs = bv_universes env1 bvs in - let uu___4 = pat_as_exp env1 pat in - (match uu___4 with - | FStar_Pervasives_Native.None -> - FStar_Pervasives.Inl - "Ill-typed pattern" - | FStar_Pervasives_Native.Some - (p_e, t2, u) -> - let eqn = - FStar_Syntax_Util.mk_eq2 u t2 sc - p_e in - let branch_goal = - let uu___5 = - FStar_Syntax_Util.mk_imp eqn body in - mk_forall_l bvs_univs uu___5 in - let branch_goal1 = - FStar_Syntax_Util.mk_imp - path_condition branch_goal in - let next_path_condition = - let uu___5 = - let uu___6 = - mk_exists_l bvs_univs eqn in - FStar_Syntax_Util.mk_neg uu___6 in - FStar_Syntax_Util.mk_conj - path_condition uu___5 in - let uu___5 = - rewrite_branches - next_path_condition branches1 in - (match uu___5 with - | FStar_Pervasives.Inl msg -> - FStar_Pervasives.Inl msg - | FStar_Pervasives.Inr rest -> - let uu___6 = - FStar_Syntax_Util.mk_conj - branch_goal1 rest in - FStar_Pervasives.Inr uu___6)))) in - let res = rewrite_branches FStar_Syntax_Util.t_true brs in - (match res with - | FStar_Pervasives.Inl msg -> - (if debug_any - then - (let uu___3 = FStar_TypeChecker_Env.get_range env in - let uu___4 = - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.format2 - "Failed to split match term because %s (%s)" - msg uu___5 in - FStar_Errors.diag - FStar_Class_HasRange.hasRange_range uu___3 () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4)) - else (); - FStar_Pervasives_Native.None) - | FStar_Pervasives.Inr res1 -> - (if debug_any - then - (let uu___3 = FStar_TypeChecker_Env.get_range env in - let uu___4 = - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t1 in - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term res1 in - FStar_Compiler_Util.format2 - "Rewrote match term\n%s\ninto %s\n" uu___5 - uu___6 in - FStar_Errors.diag - FStar_Class_HasRange.hasRange_range uu___3 () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4)) - else (); - FStar_Pervasives_Native.Some res1)) - | uu___2 -> FStar_Pervasives_Native.None) in - let maybe_rewrite_term t1 = - if pol1 <> StrictlyPositive - then FStar_Pervasives_Native.None - else - (let uu___1 = rewrite_boolean_conjunction t1 in - match uu___1 with - | FStar_Pervasives_Native.Some t2 -> - FStar_Pervasives_Native.Some t2 - | FStar_Pervasives_Native.None -> try_rewrite_match e t1) in - let uu___ = maybe_rewrite_term t in - match uu___ with - | FStar_Pervasives_Native.Some t1 -> traverse1 pol1 e t1 - | uu___1 -> - let r = - let t1 = FStar_Syntax_Subst.compress t in - let uu___2 = - let uu___3 = should_descend t1 in Prims.op_Negation uu___3 in - if uu___2 - then tpure t1.FStar_Syntax_Syntax.n - else - (match t1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_uinst (t2, us) -> - let tr = traverse1 pol1 e t2 in - let uu___4 = - comb1 - (fun t' -> FStar_Syntax_Syntax.Tm_uinst (t', us)) in - uu___4 tr - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t2; - FStar_Syntax_Syntax.meta = - FStar_Syntax_Syntax.Meta_labeled (msg, r1, uu___4);_} - -> - let tr = traverse_ctx pol1 (msg, r1) e t2 in - let uu___5 = - comb1 - (fun t' -> - FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 = t'; - FStar_Syntax_Syntax.meta = - (FStar_Syntax_Syntax.Meta_labeled - (msg, r1, false)) - }) in - uu___5 tr - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t2; - FStar_Syntax_Syntax.meta = m;_} - -> - let tr = traverse1 pol1 e t2 in - let uu___4 = - comb1 - (fun t' -> - FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 = t'; - FStar_Syntax_Syntax.meta = m - }) in - uu___4 tr - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t2; - FStar_Syntax_Syntax.asc = asc; - FStar_Syntax_Syntax.eff_opt = ef;_} - -> - let uu___4 = traverse1 pol1 e t2 in - let uu___5 = - comb1 - (fun t3 -> - FStar_Syntax_Syntax.Tm_ascribed - { - FStar_Syntax_Syntax.tm = t3; - FStar_Syntax_Syntax.asc = asc; - FStar_Syntax_Syntax.eff_opt = ef - }) in - uu___5 uu___4 - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___4; - FStar_Syntax_Syntax.vars = uu___5; - FStar_Syntax_Syntax.hash_code = uu___6;_}; - FStar_Syntax_Syntax.args = - (p, uu___7)::(q, uu___8)::[];_} - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.imp_lid - -> - let x = - FStar_Syntax_Syntax.new_bv - FStar_Pervasives_Native.None p in - let r1 = traverse1 (flip pol1) e p in - let r2 = - let uu___9 = FStar_TypeChecker_Env.push_bv e x in - traverse1 pol1 uu___9 q in - comb2 - (fun l -> - fun r3 -> - let uu___9 = FStar_Syntax_Util.mk_imp l r3 in - uu___9.FStar_Syntax_Syntax.n) r1 r2 - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = hd; - FStar_Syntax_Syntax.args = args;_} - -> - let uu___4 = - let uu___5 = - let uu___6 = FStar_Syntax_Util.un_uinst hd in - uu___6.FStar_Syntax_Syntax.n in - (uu___5, args) in - (match uu___4 with - | (FStar_Syntax_Syntax.Tm_fvar fv, - (t2, FStar_Pervasives_Native.Some aq0)::(body, aq)::[]) - when - ((FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.forall_lid) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.exists_lid)) - && aq0.FStar_Syntax_Syntax.aqual_implicit - -> - let r0 = traverse1 pol1 e hd in - let rt = traverse1 (flip pol1) e t2 in - let rbody = traverse1 pol1 e body in - let rargs = - comb2 - (fun t3 -> - fun body1 -> - [(t3, - (FStar_Pervasives_Native.Some aq0)); - (body1, aq)]) rt rbody in - comb2 - (fun hd1 -> - fun args1 -> - FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = hd1; - FStar_Syntax_Syntax.args = args1 - }) r0 rargs - | uu___5 -> - let r0 = traverse1 pol1 e hd in - let r1 = - FStar_Compiler_List.fold_right - (fun uu___6 -> - fun r2 -> - match uu___6 with - | (a, q) -> - let r' = traverse1 pol1 e a in - comb2 - (fun a1 -> - fun args1 -> (a1, q) :: args1) - r' r2) args (tpure []) in - let simplified = - (uu___is_Simplified r0) || - (uu___is_Simplified r1) in - comb2 - (fun hd1 -> - fun args1 -> - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Syntax_Util.un_uinst hd1 in - uu___8.FStar_Syntax_Syntax.n in - (uu___7, args1) in - match uu___6 with - | (FStar_Syntax_Syntax.Tm_fvar fv, - (t2, uu___7)::[]) when - (simplified && - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.squash_lid)) - && - (let uu___8 = - FStar_TypeChecker_TermEqAndSimplify.eq_tm - e t2 FStar_Syntax_Util.t_true in - uu___8 = - FStar_TypeChecker_TermEqAndSimplify.Equal) - -> - ((let uu___9 = - FStar_Compiler_Effect.op_Bang - dbg_SpinoffAll in - if uu___9 - then - FStar_Compiler_Util.print_string - "Simplified squash True to True" - else ()); - FStar_Syntax_Util.t_true.FStar_Syntax_Syntax.n) - | uu___7 -> - let t' = - FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = hd1; - FStar_Syntax_Syntax.args = args1 - } in - t') r0 r1) - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs; - FStar_Syntax_Syntax.body = t2; - FStar_Syntax_Syntax.rc_opt = k;_} - -> - let uu___4 = FStar_Syntax_Subst.open_term bs t2 in - (match uu___4 with - | (bs1, topen) -> - let e' = FStar_TypeChecker_Env.push_binders e bs1 in - let r0 = - FStar_Compiler_List.map - (fun b -> - let r1 = - traverse1 (flip pol1) e - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - let uu___5 = - comb1 - (fun s' -> - { - FStar_Syntax_Syntax.binder_bv = - (let uu___6 = - b.FStar_Syntax_Syntax.binder_bv in - { - FStar_Syntax_Syntax.ppname = - (uu___6.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (uu___6.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = - s' - }); - FStar_Syntax_Syntax.binder_qual = - (b.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity - = - (b.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs - = - (b.FStar_Syntax_Syntax.binder_attrs) - }) in - uu___5 r1) bs1 in - let rbs = comb_list r0 in - let rt = traverse1 pol1 e' topen in - comb2 - (fun bs2 -> - fun t3 -> - let uu___5 = - FStar_Syntax_Util.abs bs2 t3 k in - uu___5.FStar_Syntax_Syntax.n) rbs rt) - | x -> tpure x) in - (match r with - | Unchanged tn' -> - maybe_spinoff pol1 label_ctx e - { - FStar_Syntax_Syntax.n = tn'; - FStar_Syntax_Syntax.pos = (t.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = - (t.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (t.FStar_Syntax_Syntax.hash_code) - } - | Simplified (tn', gs) -> - let uu___2 = - maybe_spinoff pol1 label_ctx e - { - FStar_Syntax_Syntax.n = tn'; - FStar_Syntax_Syntax.pos = - (t.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = - (t.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (t.FStar_Syntax_Syntax.hash_code) - } in - emit gs uu___2 - | Dual (tn, tp, gs) -> - let rp = - maybe_spinoff pol1 label_ctx e - { - FStar_Syntax_Syntax.n = tp; - FStar_Syntax_Syntax.pos = - (t.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = - (t.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (t.FStar_Syntax_Syntax.hash_code) - } in - let uu___2 = explode rp in - (match uu___2 with - | (uu___3, p', gs') -> - Dual - ({ - FStar_Syntax_Syntax.n = tn; - FStar_Syntax_Syntax.pos = - (t.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = - (t.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (t.FStar_Syntax_Syntax.hash_code) - }, p', (FStar_Compiler_List.op_At gs gs')))) -let (pol_to_string : pol -> Prims.string) = - fun uu___ -> - match uu___ with - | StrictlyPositive -> "StrictlyPositive" - | Pos -> "Positive" - | Neg -> "Negative" - | Both -> "Both" -let (spinoff_strictly_positive_goals : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - (FStar_TypeChecker_Env.env * FStar_Syntax_Syntax.term) Prims.list) - = - fun env -> - fun goal -> - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_SpinoffAll in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term goal in - FStar_Compiler_Util.print1 "spinoff_all called with %s\n" uu___2 - else ()); - FStar_Errors.with_ctx "While spinning off all goals" - (fun uu___1 -> - let initial = (Prims.int_one, []) in - let uu___2 = - let uu___3 = - traverse_for_spinoff StrictlyPositive - FStar_Pervasives_Native.None env goal in - match uu___3 with - | Unchanged t' -> (t', []) - | Simplified (t', gs) -> (t', gs) - | uu___4 -> - failwith "preprocess: impossible, traverse returned a Dual" in - match uu___2 with - | (t', gs) -> - let t'1 = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.Simplify; - FStar_TypeChecker_Env.Primops] env t' in - let main_goal = - let t = FStar_TypeChecker_Common.check_trivial t'1 in - match t with - | FStar_TypeChecker_Common.Trivial -> [] - | FStar_TypeChecker_Common.NonTrivial t1 -> - ((let uu___4 = - FStar_Compiler_Effect.op_Bang dbg_SpinoffAll in - if uu___4 - then - let msg = - let uu___5 = - let uu___6 = - FStar_TypeChecker_Env.all_binders env in - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binder) uu___6 in - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.format2 - "Main goal simplified to: %s |- %s\n" uu___5 - uu___6 in - let uu___5 = FStar_TypeChecker_Env.get_range env in - let uu___6 = - FStar_Compiler_Util.format1 - "Verification condition was to be split into several atomic sub-goals, but this query had some sub-goals that couldn't be split---the error report, if any, may be inaccurate.\n%s\n" - msg in - FStar_Errors.diag - FStar_Class_HasRange.hasRange_range uu___5 () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___6) - else ()); - [(env, t1)]) in - let s = initial in - let s1 = - FStar_Compiler_List.fold_left - (fun uu___3 -> - fun g -> - match uu___3 with - | (n, gs1) -> - let phi = FStar_Tactics_Types.goal_type g in - let uu___4 = - let uu___5 = - let uu___6 = FStar_Tactics_Types.goal_env g in - (uu___6, phi) in - uu___5 :: gs1 in - ((n + Prims.int_one), uu___4)) s gs in - let uu___3 = s1 in - (match uu___3 with - | (uu___4, gs1) -> - let gs2 = FStar_Compiler_List.rev gs1 in - let gs3 = - FStar_Compiler_List.filter_map - (fun uu___5 -> - match uu___5 with - | (env1, t) -> - let t1 = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.Simplify; - FStar_TypeChecker_Env.Primops] env1 t in - let uu___6 = - FStar_TypeChecker_Common.check_trivial t1 in - (match uu___6 with - | FStar_TypeChecker_Common.Trivial -> - FStar_Pervasives_Native.None - | FStar_TypeChecker_Common.NonTrivial t2 -> - ((let uu___8 = - FStar_Compiler_Effect.op_Bang - dbg_SpinoffAll in - if uu___8 - then - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t2 in - FStar_Compiler_Util.print1 - "Got goal: %s\n" uu___9 - else ()); - FStar_Pervasives_Native.Some (env1, t2)))) - gs2 in - ((let uu___6 = FStar_TypeChecker_Env.get_range env in - let uu___7 = - let uu___8 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_nat) - (FStar_Compiler_List.length gs3) in - FStar_Compiler_Util.format1 - "Split query into %s sub-goals" uu___8 in - FStar_Errors.diag FStar_Class_HasRange.hasRange_range - uu___6 () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___7)); - FStar_Compiler_List.op_At main_goal gs3))) -let (synthesize : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun env -> - fun typ -> - fun tau -> - FStar_Errors.with_ctx "While synthesizing term with a tactic" - (fun uu___ -> - if env.FStar_TypeChecker_Env.flychecking - then - let uu___1 = - FStar_TypeChecker_Util.fvar_env env - FStar_Parser_Const.magic_lid in - let uu___2 = - let uu___3 = - FStar_Syntax_Syntax.as_arg FStar_Syntax_Util.exp_unit in - [uu___3] in - FStar_Syntax_Syntax.mk_Tm_app uu___1 uu___2 - typ.FStar_Syntax_Syntax.pos - else - (let uu___2 = - run_tactic_on_typ tau.FStar_Syntax_Syntax.pos - typ.FStar_Syntax_Syntax.pos tau env typ in - match uu___2 with - | (gs, w) -> - (FStar_Compiler_List.iter - (fun g -> - let uu___4 = - let uu___5 = FStar_Tactics_Types.goal_env g in - let uu___6 = FStar_Tactics_Types.goal_type g in - getprop uu___5 uu___6 in - match uu___4 with - | FStar_Pervasives_Native.Some vc -> - ((let uu___6 = - FStar_Compiler_Effect.op_Bang dbg_Tac in - if uu___6 - then - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term vc in - FStar_Compiler_Util.print1 - "Synthesis left a goal: %s\n" uu___7 - else ()); - (let guard = - FStar_TypeChecker_Env.guard_of_guard_formula - (FStar_TypeChecker_Common.NonTrivial vc) in - let uu___6 = FStar_Tactics_Types.goal_env g in - FStar_TypeChecker_Rel.force_trivial_guard - uu___6 guard)) - | FStar_Pervasives_Native.None -> - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) typ - FStar_Errors_Codes.Fatal_OpenGoalsInSynthesis - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic "synthesis left open goals")) gs; - w))) -let (solve_implicits : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_TypeChecker_Env.implicits -> unit) - = - fun env -> - fun tau -> - fun imps -> - FStar_Errors.with_ctx "While solving implicits with a tactic" - (fun uu___ -> - if env.FStar_TypeChecker_Env.flychecking - then () - else - (let gs = - let uu___2 = FStar_TypeChecker_Env.get_range env in - run_tactic_on_all_implicits tau.FStar_Syntax_Syntax.pos - uu___2 tau env imps in - (let uu___3 = - FStar_Options.profile_enabled FStar_Pervasives_Native.None - "FStar.TypeChecker" in - if uu___3 - then - let uu___4 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_nat) - (FStar_Compiler_List.length gs) in - FStar_Compiler_Util.print1 - "solve_implicits produced %s goals\n" uu___4 - else ()); - FStar_Options.with_saved_options - (fun uu___3 -> - let uu___4 = FStar_Options.set_options "--no_tactics" in - FStar_Compiler_List.iter - (fun g -> - (let uu___6 = FStar_Tactics_Types.goal_opts g in - FStar_Options.set uu___6); - (let uu___6 = - let uu___7 = FStar_Tactics_Types.goal_env g in - let uu___8 = FStar_Tactics_Types.goal_type g in - getprop uu___7 uu___8 in - match uu___6 with - | FStar_Pervasives_Native.Some vc -> - ((let uu___8 = - FStar_Compiler_Effect.op_Bang dbg_Tac in - if uu___8 - then - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term vc in - FStar_Compiler_Util.print1 - "Synthesis left a goal: %s\n" uu___9 - else ()); - if - Prims.op_Negation - env.FStar_TypeChecker_Env.admit - then - (let guard = - FStar_TypeChecker_Env.guard_of_guard_formula - (FStar_TypeChecker_Common.NonTrivial - vc) in - FStar_Profiling.profile - (fun uu___8 -> - let uu___9 = - FStar_Tactics_Types.goal_env g in - FStar_TypeChecker_Rel.force_trivial_guard - uu___9 guard) - FStar_Pervasives_Native.None - "FStar.TypeChecker.Hooks.force_trivial_guard") - else ()) - | FStar_Pervasives_Native.None -> - FStar_Errors.raise_error - FStar_TypeChecker_Env.hasRange_env env - FStar_Errors_Codes.Fatal_OpenGoalsInSynthesis - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic "synthesis left open goals"))) gs))) -let (find_user_tac_for_attr : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.sigelt FStar_Pervasives_Native.option) - = - fun env -> - fun a -> - let hooks = - FStar_TypeChecker_Env.lookup_attr env - FStar_Parser_Const.handle_smt_goals_attr_string in - FStar_Compiler_Util.try_find (fun uu___ -> true) hooks -let (handle_smt_goal : - FStar_TypeChecker_Env.env -> - FStar_TypeChecker_Env.goal -> - (FStar_TypeChecker_Env.env * FStar_Syntax_Syntax.term) Prims.list) - = - fun env -> - fun goal -> - let uu___ = FStar_TypeChecker_Common.check_trivial goal in - match uu___ with - | FStar_TypeChecker_Common.Trivial -> [(env, goal)] - | FStar_TypeChecker_Common.NonTrivial goal1 -> - let uu___1 = - let uu___2 = - FStar_Syntax_Syntax.tconst - FStar_Parser_Const.handle_smt_goals_attr in - find_user_tac_for_attr env uu___2 in - (match uu___1 with - | FStar_Pervasives_Native.Some tac -> - let tau = - match tac.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = uu___2; - FStar_Syntax_Syntax.lids1 = lid::[];_} - -> - let qn = FStar_TypeChecker_Env.lookup_qname env lid in - let fv = - FStar_Syntax_Syntax.lid_as_fv lid - FStar_Pervasives_Native.None in - let uu___3 = - FStar_Syntax_Syntax.lid_as_fv lid - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___3 - | uu___2 -> failwith "Resolve_tac not found" in - let gs = - FStar_Errors.with_ctx - "While handling an SMT goal with a tactic" - (fun uu___2 -> - let uu___3 = - let uu___4 = FStar_TypeChecker_Env.get_range env in - let uu___5 = - FStar_Syntax_Util.mk_squash - FStar_Syntax_Syntax.U_zero goal1 in - run_tactic_on_typ tau.FStar_Syntax_Syntax.pos uu___4 - tau env uu___5 in - match uu___3 with - | (gs1, uu___4) -> - FStar_Compiler_List.map - (fun g -> - let uu___5 = - let uu___6 = FStar_Tactics_Types.goal_env g in - let uu___7 = FStar_Tactics_Types.goal_type g in - getprop uu___6 uu___7 in - match uu___5 with - | FStar_Pervasives_Native.Some vc -> - ((let uu___7 = - FStar_Compiler_Effect.op_Bang dbg_Tac in - if uu___7 - then - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - vc in - FStar_Compiler_Util.print1 - "handle_smt_goals left a goal: %s\n" - uu___8 - else ()); - (let uu___7 = - FStar_Tactics_Types.goal_env g in - (uu___7, vc))) - | FStar_Pervasives_Native.None -> - FStar_Errors.raise_error - FStar_TypeChecker_Env.hasRange_env env - FStar_Errors_Codes.Fatal_OpenGoalsInSynthesis - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Handling an SMT goal by tactic left non-prop open goals")) - gs1) in - gs - | FStar_Pervasives_Native.None -> [(env, goal1)]) -let (uu___0 : - FStar_Syntax_Syntax.term FStar_Syntax_Embeddings_Base.embedding) = - FStar_Reflection_V2_Embeddings.e_term -type blob_t = - (Prims.string * FStar_Syntax_Syntax.term) FStar_Pervasives_Native.option -type dsl_typed_sigelt_t = (Prims.bool * FStar_Syntax_Syntax.sigelt * blob_t) -type dsl_tac_result_t = - (dsl_typed_sigelt_t Prims.list * dsl_typed_sigelt_t * dsl_typed_sigelt_t - Prims.list) -let (splice : - FStar_TypeChecker_Env.env -> - Prims.bool -> - FStar_Ident.lident Prims.list -> - FStar_Syntax_Syntax.term -> - FStar_Compiler_Range_Type.range -> - FStar_Syntax_Syntax.sigelt Prims.list) - = - fun env -> - fun is_typed -> - fun lids -> - fun tau -> - fun rng -> - FStar_Errors.with_ctx "While running splice with a tactic" - (fun uu___ -> - if env.FStar_TypeChecker_Env.flychecking - then [] - else - (let uu___2 = - if is_typed - then - FStar_TypeChecker_TcTerm.tc_check_tot_or_gtot_term - env tau FStar_Syntax_Util.t_dsl_tac_typ - FStar_Pervasives_Native.None - else - FStar_TypeChecker_TcTerm.tc_tactic - FStar_Syntax_Syntax.t_unit - FStar_Syntax_Syntax.t_decls env tau in - match uu___2 with - | (tau1, uu___3, g) -> - (FStar_TypeChecker_Rel.force_trivial_guard env g; - (let ps = - FStar_Tactics_V2_Basic.proofstate_of_goals - tau1.FStar_Syntax_Syntax.pos env [] [] in - let tactic_already_typed = true in - let uu___5 = - if is_typed - then - (if - (FStar_Compiler_List.length lids) > - Prims.int_one - then - let uu___6 = - let uu___7 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Ident.showable_lident) lids in - FStar_Compiler_Util.format1 - "Typed splice: unexpected lids length (> 1) (%s)" - uu___7 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range rng - FStar_Errors_Codes.Error_BadSplice () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___6) - else - (let val_t = - if - (FStar_Compiler_List.length lids) = - Prims.int_zero - then FStar_Pervasives_Native.None - else - (let uu___8 = - let uu___9 = - FStar_Compiler_List.hd lids in - FStar_TypeChecker_Env.try_lookup_val_decl - env uu___9 in - match uu___8 with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some - ((uvs, tval), uu___9) -> - if - (FStar_Compiler_List.length uvs) - <> Prims.int_zero - then - let uu___10 = - let uu___11 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_nat) - (FStar_Compiler_List.length - uvs) in - FStar_Compiler_Util.format1 - "Typed splice: val declaration for %s is universe polymorphic in %s universes, expected 0" - uu___11 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - rng - FStar_Errors_Codes.Error_BadSplice - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___10) - else - FStar_Pervasives_Native.Some - tval) in - let uu___7 = - FStar_Tactics_Interpreter.run_tactic_on_ps - tau1.FStar_Syntax_Syntax.pos - tau1.FStar_Syntax_Syntax.pos false - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Reflection_V2_Embeddings.e_env - (FStar_Syntax_Embeddings.e_option - uu___0)) - ({ - FStar_TypeChecker_Env.solver = - (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = []; - FStar_TypeChecker_Env.gamma_sig = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp - = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict - = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = false; - FStar_TypeChecker_Env.lax_universes - = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping - = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force - = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths - = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info - = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab - = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env.FStar_TypeChecker_Env.missing_decl) - }, val_t) - (FStar_Syntax_Embeddings.e_tuple3 - (FStar_Syntax_Embeddings.e_list - (FStar_Syntax_Embeddings.e_tuple3 - FStar_Syntax_Embeddings.e_bool - FStar_Reflection_V2_Embeddings.e_sigelt - (FStar_Syntax_Embeddings.e_option - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Syntax_Embeddings.e_string - uu___0)))) - (FStar_Syntax_Embeddings.e_tuple3 - FStar_Syntax_Embeddings.e_bool - FStar_Reflection_V2_Embeddings.e_sigelt - (FStar_Syntax_Embeddings.e_option - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Syntax_Embeddings.e_string - uu___0))) - (FStar_Syntax_Embeddings.e_list - (FStar_Syntax_Embeddings.e_tuple3 - FStar_Syntax_Embeddings.e_bool - FStar_Reflection_V2_Embeddings.e_sigelt - (FStar_Syntax_Embeddings.e_option - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Syntax_Embeddings.e_string - uu___0))))) tau1 - tactic_already_typed ps in - match uu___7 with - | (gs, - (sig_blobs_before, sig_blob, - sig_blobs_after)) -> - let uu___8 = uu___7 in - let sig_blobs = - FStar_Compiler_List.op_At - sig_blobs_before (sig_blob :: - sig_blobs_after) in - let sigelts = - FStar_Compiler_List.map - (fun uu___9 -> - match uu___9 with - | (checked, se, blob_opt) -> - { - FStar_Syntax_Syntax.sigel - = - (se.FStar_Syntax_Syntax.sigel); - FStar_Syntax_Syntax.sigrng - = - (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals - = - (se.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta - = - (let uu___10 = - se.FStar_Syntax_Syntax.sigmeta in - { - FStar_Syntax_Syntax.sigmeta_active - = - (uu___10.FStar_Syntax_Syntax.sigmeta_active); - FStar_Syntax_Syntax.sigmeta_fact_db_ids - = - (uu___10.FStar_Syntax_Syntax.sigmeta_fact_db_ids); - FStar_Syntax_Syntax.sigmeta_admit - = - (uu___10.FStar_Syntax_Syntax.sigmeta_admit); - FStar_Syntax_Syntax.sigmeta_spliced - = - (uu___10.FStar_Syntax_Syntax.sigmeta_spliced); - FStar_Syntax_Syntax.sigmeta_already_checked - = checked; - FStar_Syntax_Syntax.sigmeta_extension_data - = - ((match blob_opt - with - | FStar_Pervasives_Native.Some - (s, blob) -> - [(s, - (FStar_Dyn.mkdyn - blob))] - | FStar_Pervasives_Native.None - -> [])) - }); - FStar_Syntax_Syntax.sigattrs - = - (se.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs - = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts - = - (se.FStar_Syntax_Syntax.sigopts) - }) sig_blobs in - (gs, sigelts))) - else - FStar_Tactics_Interpreter.run_tactic_on_ps - tau1.FStar_Syntax_Syntax.pos - tau1.FStar_Syntax_Syntax.pos false - FStar_Syntax_Embeddings.e_unit () - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_sigelt) - tau1 tactic_already_typed ps in - match uu___5 with - | (gs, sigelts) -> - let sigelts1 = - let set_lb_dd lb = - let uu___6 = lb in - match uu___6 with - | { - FStar_Syntax_Syntax.lbname = - FStar_Pervasives.Inr fv; - FStar_Syntax_Syntax.lbunivs = uu___7; - FStar_Syntax_Syntax.lbtyp = uu___8; - FStar_Syntax_Syntax.lbeff = uu___9; - FStar_Syntax_Syntax.lbdef = lbdef; - FStar_Syntax_Syntax.lbattrs = uu___10; - FStar_Syntax_Syntax.lbpos = uu___11;_} - -> - { - FStar_Syntax_Syntax.lbname = - (FStar_Pervasives.Inr fv); - FStar_Syntax_Syntax.lbunivs = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = - (lb.FStar_Syntax_Syntax.lbtyp); - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = - (lb.FStar_Syntax_Syntax.lbdef); - FStar_Syntax_Syntax.lbattrs = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - } in - FStar_Compiler_List.map - (fun se -> - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_let - { - FStar_Syntax_Syntax.lbs1 = - (is_rec, lbs); - FStar_Syntax_Syntax.lids1 = lids1;_} - -> - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Compiler_List.map - set_lb_dd lbs in - (is_rec, uu___9) in - { - FStar_Syntax_Syntax.lbs1 = - uu___8; - FStar_Syntax_Syntax.lids1 = - lids1 - } in - FStar_Syntax_Syntax.Sig_let uu___7 in - { - FStar_Syntax_Syntax.sigel = uu___6; - FStar_Syntax_Syntax.sigrng = - (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs - = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se.FStar_Syntax_Syntax.sigopts) - } - | uu___6 -> se) sigelts in - (FStar_Options.with_saved_options - (fun uu___7 -> - FStar_Compiler_List.iter - (fun g1 -> - (let uu___9 = - FStar_Tactics_Types.goal_opts g1 in - FStar_Options.set uu___9); - (let uu___9 = - let uu___10 = - FStar_Tactics_Types.goal_env g1 in - let uu___11 = - FStar_Tactics_Types.goal_type - g1 in - getprop uu___10 uu___11 in - match uu___9 with - | FStar_Pervasives_Native.Some vc - -> - ((let uu___11 = - FStar_Compiler_Effect.op_Bang - dbg_Tac in - if uu___11 - then - let uu___12 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - vc in - FStar_Compiler_Util.print1 - "Splice left a goal: %s\n" - uu___12 - else ()); - (let guard = - FStar_TypeChecker_Env.guard_of_guard_formula - (FStar_TypeChecker_Common.NonTrivial - vc) in - let uu___11 = - FStar_Tactics_Types.goal_env - g1 in - FStar_TypeChecker_Rel.force_trivial_guard - uu___11 guard)) - | FStar_Pervasives_Native.None -> - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - rng - FStar_Errors_Codes.Fatal_OpenGoalsInSynthesis - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "splice left open goals"))) - gs); - (let lids' = - FStar_Compiler_List.collect - FStar_Syntax_Util.lids_of_sigelt sigelts1 in - FStar_Compiler_List.iter - (fun lid -> - let uu___8 = - FStar_Compiler_List.tryFind - (FStar_Ident.lid_equals lid) lids' in - match uu___8 with - | FStar_Pervasives_Native.None when - Prims.op_Negation - env.FStar_TypeChecker_Env.flychecking - -> - let uu___9 = - let uu___10 = - FStar_Class_Show.show - FStar_Ident.showable_lident - lid in - let uu___11 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Ident.showable_lident) - lids' in - FStar_Compiler_Util.format2 - "Splice declared the name %s but it was not defined.\nThose defined were: %s" - uu___10 uu___11 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - rng - FStar_Errors_Codes.Fatal_SplicedUndef - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___9) - | uu___9 -> ()) lids; - (let uu___9 = - FStar_Compiler_Effect.op_Bang dbg_Tac in - if uu___9 - then - let uu___10 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_sigelt) - sigelts1 in - FStar_Compiler_Util.print1 - "splice: got decls = {\n\n%s\n\n}\n" - uu___10 - else ()); - (let sigelts2 = - FStar_Compiler_List.map - (fun se -> - (match se.FStar_Syntax_Syntax.sigel - with - | FStar_Syntax_Syntax.Sig_datacon - uu___10 -> - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Errors_Msg.text - "Tactic returned bad sigelt:" in - let uu___14 = - let uu___15 = - FStar_Syntax_Print.sigelt_to_string_short - se in - FStar_Pprint.doc_of_string - uu___15 in - FStar_Pprint.op_Hat_Slash_Hat - uu___13 uu___14 in - let uu___13 = - let uu___14 = - FStar_Errors_Msg.text - "If you wanted to splice an inductive type, call `pack` providing a `Sg_Inductive` to get a proper sigelt." in - [uu___14] in - uu___12 :: uu___13 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - rng - FStar_Errors_Codes.Error_BadSplice - () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___11) - | FStar_Syntax_Syntax.Sig_inductive_typ - uu___10 -> - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Errors_Msg.text - "Tactic returned bad sigelt:" in - let uu___14 = - let uu___15 = - FStar_Syntax_Print.sigelt_to_string_short - se in - FStar_Pprint.doc_of_string - uu___15 in - FStar_Pprint.op_Hat_Slash_Hat - uu___13 uu___14 in - let uu___13 = - let uu___14 = - FStar_Errors_Msg.text - "If you wanted to splice an inductive type, call `pack` providing a `Sg_Inductive` to get a proper sigelt." in - [uu___14] in - uu___12 :: uu___13 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - rng - FStar_Errors_Codes.Error_BadSplice - () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___11) - | uu___10 -> ()); - { - FStar_Syntax_Syntax.sigel = - (se.FStar_Syntax_Syntax.sigel); - FStar_Syntax_Syntax.sigrng = rng; - FStar_Syntax_Syntax.sigquals = - (se.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs - = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se.FStar_Syntax_Syntax.sigopts) - }) sigelts1 in - if is_typed - then () - else - FStar_Compiler_List.iter - (fun se -> - FStar_Compiler_List.iter - (fun q -> - let uu___11 = - FStar_Syntax_Syntax.is_internal_qualifier - q in - if uu___11 - then - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_qualifier - q in - FStar_Compiler_Util.format1 - "The qualifier %s is internal." - uu___15 in - FStar_Errors_Msg.text - uu___14 in - let uu___14 = - let uu___15 = - let uu___16 = - FStar_Errors_Msg.text - "It cannot be attached to spliced declaration:" in - let uu___17 = - let uu___18 = - FStar_Syntax_Print.sigelt_to_string_short - se in - FStar_Pprint.arbitrary_string - uu___18 in - FStar_Pprint.prefix - (Prims.of_int (2)) - Prims.int_one uu___16 - uu___17 in - [uu___15] in - uu___13 :: uu___14 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - rng - FStar_Errors_Codes.Error_InternalQualifier - () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___12) - else ()) - se.FStar_Syntax_Syntax.sigquals) - sigelts2; - (match () with | () -> sigelts2)))))))) -let (mpreprocess : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun env -> - fun tau -> - fun tm -> - FStar_Errors.with_ctx - "While preprocessing a definition with a tactic" - (fun uu___ -> - if env.FStar_TypeChecker_Env.flychecking - then tm - else - (let ps = - FStar_Tactics_V2_Basic.proofstate_of_goals - tm.FStar_Syntax_Syntax.pos env [] [] in - let tactic_already_typed = false in - let uu___2 = - FStar_Tactics_Interpreter.run_tactic_on_ps - tau.FStar_Syntax_Syntax.pos tm.FStar_Syntax_Syntax.pos - false FStar_Reflection_V2_Embeddings.e_term tm - FStar_Reflection_V2_Embeddings.e_term tau - tactic_already_typed ps in - match uu___2 with | (gs, tm1) -> tm1)) -let (postprocess : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun env -> - fun tau -> - fun typ -> - fun tm -> - FStar_Errors.with_ctx - "While postprocessing a definition with a tactic" - (fun uu___ -> - if env.FStar_TypeChecker_Env.flychecking - then tm - else - (let uu___2 = - FStar_TypeChecker_Env.new_implicit_var_aux - "postprocess RHS" tm.FStar_Syntax_Syntax.pos env typ - (FStar_Syntax_Syntax.Allow_untyped "postprocess") - FStar_Pervasives_Native.None false in - match uu___2 with - | (uvtm, uu___3, g_imp) -> - let u = env.FStar_TypeChecker_Env.universe_of env typ in - let goal = - let uu___4 = FStar_Syntax_Util.mk_eq2 u typ tm uvtm in - FStar_Syntax_Util.mk_squash - FStar_Syntax_Syntax.U_zero uu___4 in - let uu___4 = - run_tactic_on_typ tau.FStar_Syntax_Syntax.pos - tm.FStar_Syntax_Syntax.pos tau env goal in - (match uu___4 with - | (gs, w) -> - (FStar_Compiler_List.iter - (fun g -> - let uu___6 = - let uu___7 = - FStar_Tactics_Types.goal_env g in - let uu___8 = - FStar_Tactics_Types.goal_type g in - getprop uu___7 uu___8 in - match uu___6 with - | FStar_Pervasives_Native.Some vc -> - ((let uu___8 = - FStar_Compiler_Effect.op_Bang - dbg_Tac in - if uu___8 - then - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - vc in - FStar_Compiler_Util.print1 - "Postprocessing left a goal: %s\n" - uu___9 - else ()); - (let guard = - FStar_TypeChecker_Env.guard_of_guard_formula - (FStar_TypeChecker_Common.NonTrivial - vc) in - let uu___8 = - FStar_Tactics_Types.goal_env g in - FStar_TypeChecker_Rel.force_trivial_guard - uu___8 guard)) - | FStar_Pervasives_Native.None -> - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax - ()) typ - FStar_Errors_Codes.Fatal_OpenGoalsInSynthesis - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "postprocessing left open goals")) - gs; - (let tagged_imps = - FStar_TypeChecker_Rel.resolve_implicits_tac - env g_imp in - FStar_Tactics_Interpreter.report_implicits - tm.FStar_Syntax_Syntax.pos tagged_imps; - uvtm))))) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_InterpFuns.ml b/ocaml/fstar-lib/generated/FStar_Tactics_InterpFuns.ml deleted file mode 100644 index fa15e66c967..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Tactics_InterpFuns.ml +++ /dev/null @@ -1,13444 +0,0 @@ -open Prims -let solve : 'a . 'a -> 'a = fun ev -> ev -let embed : - 'a . - 'a FStar_Syntax_Embeddings_Base.embedding -> - FStar_Compiler_Range_Type.range -> - 'a -> - FStar_Syntax_Embeddings_Base.norm_cb -> FStar_Syntax_Syntax.term - = - fun e -> - fun rng -> - fun t -> - fun n -> - let uu___ = FStar_Syntax_Embeddings_Base.embed e t in - uu___ rng FStar_Pervasives_Native.None n -let unembed : - 'a . - 'a FStar_Syntax_Embeddings_Base.embedding -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Embeddings_Base.norm_cb -> - 'a FStar_Pervasives_Native.option - = fun e -> fun t -> fun n -> FStar_Syntax_Embeddings_Base.unembed e t n -let interp_ctx : 'a . Prims.string -> (unit -> 'a) -> 'a = - fun s -> - fun f -> - FStar_Errors.with_ctx (Prims.strcat "While running primitive " s) f -let run_wrap : - 'a . - Prims.string -> - 'a FStar_Tactics_Monad.tac -> - FStar_Tactics_Types.proofstate -> 'a FStar_Tactics_Result.__result - = - fun label -> - fun t -> - fun ps -> - interp_ctx label (fun uu___ -> FStar_Tactics_Monad.run_safe t ps) -let (builtin_lid : Prims.string -> FStar_Ident.lid) = - fun nm -> - FStar_Parser_Const.fstar_stubs_tactics_lid' ["V2"; "Builtins"; nm] -let (types_lid : Prims.string -> FStar_Ident.lid) = - fun nm -> FStar_Parser_Const.fstar_stubs_tactics_lid' ["Types"; nm] -let (set_auto_reflect : - Prims.int -> - FStar_TypeChecker_Primops_Base.primitive_step -> - FStar_TypeChecker_Primops_Base.primitive_step) - = - fun arity -> - fun p -> - { - FStar_TypeChecker_Primops_Base.name = - (p.FStar_TypeChecker_Primops_Base.name); - FStar_TypeChecker_Primops_Base.arity = - (p.FStar_TypeChecker_Primops_Base.arity); - FStar_TypeChecker_Primops_Base.univ_arity = - (p.FStar_TypeChecker_Primops_Base.univ_arity); - FStar_TypeChecker_Primops_Base.auto_reflect = - (FStar_Pervasives_Native.Some arity); - FStar_TypeChecker_Primops_Base.strong_reduction_ok = - (p.FStar_TypeChecker_Primops_Base.strong_reduction_ok); - FStar_TypeChecker_Primops_Base.requires_binder_substitution = - (p.FStar_TypeChecker_Primops_Base.requires_binder_substitution); - FStar_TypeChecker_Primops_Base.renorm_after = - (p.FStar_TypeChecker_Primops_Base.renorm_after); - FStar_TypeChecker_Primops_Base.interpretation = - (p.FStar_TypeChecker_Primops_Base.interpretation); - FStar_TypeChecker_Primops_Base.interpretation_nbe = - (p.FStar_TypeChecker_Primops_Base.interpretation_nbe) - } -let mk_tot_step_1 : - 'nres 'nt1 'res 't1 . - Prims.int -> - Prims.string -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 'res FStar_Syntax_Embeddings_Base.embedding -> - 'nt1 FStar_TypeChecker_NBETerm.embedding -> - 'nres FStar_TypeChecker_NBETerm.embedding -> - ('t1 -> 'res) -> - ('nt1 -> 'nres) -> - FStar_TypeChecker_Primops_Base.primitive_step - = - fun uarity -> - fun nm -> - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun f -> - fun nbe_f -> - let lid = types_lid nm in - FStar_TypeChecker_Primops_Base.mk1' uarity lid uu___ uu___2 - uu___1 uu___3 - (fun x -> - let uu___4 = f x in - FStar_Pervasives_Native.Some uu___4) - (fun x -> - let uu___4 = nbe_f x in - FStar_Pervasives_Native.Some uu___4) -let mk_tot_step_2 : - 'nres 'nt1 'nt2 'res 't1 't2 . - Prims.int -> - Prims.string -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 'res FStar_Syntax_Embeddings_Base.embedding -> - 'nt1 FStar_TypeChecker_NBETerm.embedding -> - 'nt2 FStar_TypeChecker_NBETerm.embedding -> - 'nres FStar_TypeChecker_NBETerm.embedding -> - ('t1 -> 't2 -> 'res) -> - ('nt1 -> 'nt2 -> 'nres) -> - FStar_TypeChecker_Primops_Base.primitive_step - = - fun uarity -> - fun nm -> - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun uu___4 -> - fun uu___5 -> - fun f -> - fun nbe_f -> - let lid = types_lid nm in - FStar_TypeChecker_Primops_Base.mk2' uarity lid uu___ - uu___3 uu___1 uu___4 uu___2 uu___5 - (fun x -> - fun y -> - let uu___6 = f x y in - FStar_Pervasives_Native.Some uu___6) - (fun x -> - fun y -> - let uu___6 = nbe_f x y in - FStar_Pervasives_Native.Some uu___6) -let mk_tot_step_1_psc : - 'nres 'nt1 'res 't1 . - Prims.int -> - Prims.string -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 'res FStar_Syntax_Embeddings_Base.embedding -> - 'nt1 FStar_TypeChecker_NBETerm.embedding -> - 'nres FStar_TypeChecker_NBETerm.embedding -> - (FStar_TypeChecker_Primops_Base.psc -> 't1 -> 'res) -> - (FStar_TypeChecker_Primops_Base.psc -> 'nt1 -> 'nres) -> - FStar_TypeChecker_Primops_Base.primitive_step - = - fun us -> - fun nm -> - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun f -> - fun nbe_f -> - let lid = types_lid nm in - FStar_TypeChecker_Primops_Base.mk1_psc' us lid uu___ uu___2 - uu___1 uu___3 - (fun psc -> - fun x -> - let uu___4 = f psc x in - FStar_Pervasives_Native.Some uu___4) - (fun psc -> - fun x -> - let uu___4 = nbe_f psc x in - FStar_Pervasives_Native.Some uu___4) -let mk_tac_step_1 : - 'nres 'nt1 'res 't1 . - Prims.int -> - Prims.string -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 'res FStar_Syntax_Embeddings_Base.embedding -> - 'nt1 FStar_TypeChecker_NBETerm.embedding -> - 'nres FStar_TypeChecker_NBETerm.embedding -> - ('t1 -> 'res FStar_Tactics_Monad.tac) -> - ('nt1 -> 'nres FStar_Tactics_Monad.tac) -> - FStar_TypeChecker_Primops_Base.primitive_step - = - fun univ_arity -> - fun nm -> - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun f -> - fun nbe_f -> - let lid = builtin_lid nm in - let uu___4 = - FStar_TypeChecker_Primops_Base.mk2' univ_arity lid uu___ - uu___2 FStar_Tactics_Embedding.e_proofstate - FStar_Tactics_Embedding.e_proofstate_nbe - (FStar_Tactics_Embedding.e_result uu___1) - (FStar_Tactics_Embedding.e_result_nbe uu___3) - (fun a -> - fun ps -> - let uu___5 = - let uu___6 = f a in run_wrap nm uu___6 ps in - FStar_Pervasives_Native.Some uu___5) - (fun a -> - fun ps -> - let uu___5 = - let uu___6 = nbe_f a in run_wrap nm uu___6 ps in - FStar_Pervasives_Native.Some uu___5) in - set_auto_reflect Prims.int_one uu___4 -let mk_tac_step_2 : - 'nres 'nt1 'nt2 'res 't1 't2 . - Prims.int -> - Prims.string -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 'res FStar_Syntax_Embeddings_Base.embedding -> - 'nt1 FStar_TypeChecker_NBETerm.embedding -> - 'nt2 FStar_TypeChecker_NBETerm.embedding -> - 'nres FStar_TypeChecker_NBETerm.embedding -> - ('t1 -> 't2 -> 'res FStar_Tactics_Monad.tac) -> - ('nt1 -> 'nt2 -> 'nres FStar_Tactics_Monad.tac) -> - FStar_TypeChecker_Primops_Base.primitive_step - = - fun univ_arity -> - fun nm -> - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun uu___4 -> - fun uu___5 -> - fun f -> - fun nbe_f -> - let lid = builtin_lid nm in - let uu___6 = - FStar_TypeChecker_Primops_Base.mk3' univ_arity lid - uu___ uu___3 uu___1 uu___4 - FStar_Tactics_Embedding.e_proofstate - FStar_Tactics_Embedding.e_proofstate_nbe - (FStar_Tactics_Embedding.e_result uu___2) - (FStar_Tactics_Embedding.e_result_nbe uu___5) - (fun a -> - fun b -> - fun ps -> - let uu___7 = - let uu___8 = f a b in - run_wrap nm uu___8 ps in - FStar_Pervasives_Native.Some uu___7) - (fun a -> - fun b -> - fun ps -> - let uu___7 = - let uu___8 = nbe_f a b in - run_wrap nm uu___8 ps in - FStar_Pervasives_Native.Some uu___7) in - set_auto_reflect (Prims.of_int (2)) uu___6 -let mk_tac_step_3 : - 'nres 'nt1 'nt2 'nt3 'res 't1 't2 't3 . - Prims.int -> - Prims.string -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 'res FStar_Syntax_Embeddings_Base.embedding -> - 'nt1 FStar_TypeChecker_NBETerm.embedding -> - 'nt2 FStar_TypeChecker_NBETerm.embedding -> - 'nt3 FStar_TypeChecker_NBETerm.embedding -> - 'nres FStar_TypeChecker_NBETerm.embedding -> - ('t1 -> 't2 -> 't3 -> 'res FStar_Tactics_Monad.tac) - -> - ('nt1 -> - 'nt2 -> 'nt3 -> 'nres FStar_Tactics_Monad.tac) - -> FStar_TypeChecker_Primops_Base.primitive_step - = - fun univ_arity -> - fun nm -> - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun uu___4 -> - fun uu___5 -> - fun uu___6 -> - fun uu___7 -> - fun f -> - fun nbe_f -> - let lid = builtin_lid nm in - let uu___8 = - FStar_TypeChecker_Primops_Base.mk4' univ_arity - lid uu___ uu___4 uu___1 uu___5 uu___2 uu___6 - FStar_Tactics_Embedding.e_proofstate - FStar_Tactics_Embedding.e_proofstate_nbe - (FStar_Tactics_Embedding.e_result uu___3) - (FStar_Tactics_Embedding.e_result_nbe uu___7) - (fun a -> - fun b -> - fun c -> - fun ps -> - let uu___9 = - let uu___10 = f a b c in - run_wrap nm uu___10 ps in - FStar_Pervasives_Native.Some uu___9) - (fun a -> - fun b -> - fun c -> - fun ps -> - let uu___9 = - let uu___10 = nbe_f a b c in - run_wrap nm uu___10 ps in - FStar_Pervasives_Native.Some uu___9) in - set_auto_reflect (Prims.of_int (3)) uu___8 -let mk_tac_step_4 : - 'nres 'nt1 'nt2 'nt3 'nt4 'res 't1 't2 't3 't4 . - Prims.int -> - Prims.string -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 'res FStar_Syntax_Embeddings_Base.embedding -> - 'nt1 FStar_TypeChecker_NBETerm.embedding -> - 'nt2 FStar_TypeChecker_NBETerm.embedding -> - 'nt3 FStar_TypeChecker_NBETerm.embedding -> - 'nt4 FStar_TypeChecker_NBETerm.embedding -> - 'nres FStar_TypeChecker_NBETerm.embedding -> - ('t1 -> - 't2 -> - 't3 -> 't4 -> 'res FStar_Tactics_Monad.tac) - -> - ('nt1 -> - 'nt2 -> - 'nt3 -> - 'nt4 -> 'nres FStar_Tactics_Monad.tac) - -> - FStar_TypeChecker_Primops_Base.primitive_step - = - fun univ_arity -> - fun nm -> - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun uu___4 -> - fun uu___5 -> - fun uu___6 -> - fun uu___7 -> - fun uu___8 -> - fun uu___9 -> - fun f -> - fun nbe_f -> - let lid = builtin_lid nm in - let uu___10 = - FStar_TypeChecker_Primops_Base.mk5' - univ_arity lid uu___ uu___5 uu___1 uu___6 - uu___2 uu___7 uu___3 uu___8 - FStar_Tactics_Embedding.e_proofstate - FStar_Tactics_Embedding.e_proofstate_nbe - (FStar_Tactics_Embedding.e_result uu___4) - (FStar_Tactics_Embedding.e_result_nbe - uu___9) - (fun a -> - fun b -> - fun c -> - fun d -> - fun ps -> - let uu___11 = - let uu___12 = f a b c d in - run_wrap nm uu___12 ps in - FStar_Pervasives_Native.Some - uu___11) - (fun a -> - fun b -> - fun c -> - fun d -> - fun ps -> - let uu___11 = - let uu___12 = nbe_f a b c d in - run_wrap nm uu___12 ps in - FStar_Pervasives_Native.Some - uu___11) in - set_auto_reflect (Prims.of_int (4)) uu___10 -let mk_tac_step_5 : - 'nres 'nt1 'nt2 'nt3 'nt4 'nt5 'res 't1 't2 't3 't4 't5 . - Prims.int -> - Prims.string -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 'res FStar_Syntax_Embeddings_Base.embedding -> - 'nt1 FStar_TypeChecker_NBETerm.embedding -> - 'nt2 FStar_TypeChecker_NBETerm.embedding -> - 'nt3 FStar_TypeChecker_NBETerm.embedding -> - 'nt4 FStar_TypeChecker_NBETerm.embedding -> - 'nt5 FStar_TypeChecker_NBETerm.embedding -> - 'nres FStar_TypeChecker_NBETerm.embedding -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> 'res FStar_Tactics_Monad.tac) - -> - ('nt1 -> - 'nt2 -> - 'nt3 -> - 'nt4 -> - 'nt5 -> - 'nres FStar_Tactics_Monad.tac) - -> - FStar_TypeChecker_Primops_Base.primitive_step - = - fun univ_arity -> - fun nm -> - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun uu___4 -> - fun uu___5 -> - fun uu___6 -> - fun uu___7 -> - fun uu___8 -> - fun uu___9 -> - fun uu___10 -> - fun uu___11 -> - fun f -> - fun nbe_f -> - let lid = builtin_lid nm in - let uu___12 = - FStar_TypeChecker_Primops_Base.mk6' - univ_arity lid uu___ uu___6 uu___1 - uu___7 uu___2 uu___8 uu___3 uu___9 - uu___4 uu___10 - FStar_Tactics_Embedding.e_proofstate - FStar_Tactics_Embedding.e_proofstate_nbe - (FStar_Tactics_Embedding.e_result - uu___5) - (FStar_Tactics_Embedding.e_result_nbe - uu___11) - (fun a -> - fun b -> - fun c -> - fun d -> - fun e -> - fun ps -> - let uu___13 = - let uu___14 = - f a b c d e in - run_wrap nm uu___14 ps in - FStar_Pervasives_Native.Some - uu___13) - (fun a -> - fun b -> - fun c -> - fun d -> - fun e -> - fun ps -> - let uu___13 = - let uu___14 = - nbe_f a b c d e in - run_wrap nm uu___14 ps in - FStar_Pervasives_Native.Some - uu___13) in - set_auto_reflect (Prims.of_int (5)) uu___12 -let (max_tac_arity : Prims.int) = (Prims.of_int (20)) -let mk_tactic_interpretation_1 : - 'r 't1 . - Prims.string -> - ('t1 -> 'r FStar_Tactics_Monad.tac) -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option - = - fun name -> - fun t -> - fun e1 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::[] -> - let uu___2 = unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt uu___2 - (fun a11 -> - let uu___3 = - unembed FStar_Tactics_Embedding.e_proofstate a2 - ncb in - FStar_Compiler_Util.bind_opt uu___3 - (fun ps -> - let ps1 = - FStar_Tactics_Types.set_ps_psc psc ps in - let r1 = - interp_ctx name - (fun uu___4 -> - let uu___5 = t a11 in - FStar_Tactics_Monad.run_safe uu___5 - ps1) in - let uu___4 = - let uu___5 = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed (FStar_Tactics_Embedding.e_result er) - uu___5 r1 ncb in - FStar_Pervasives_Native.Some uu___4)) - | uu___ -> FStar_Pervasives_Native.None -let mk_tactic_interpretation_2 : - 'r 't1 't2 . - Prims.string -> - ('t1 -> 't2 -> 'r FStar_Tactics_Monad.tac) -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option - = - fun name -> - fun t -> - fun e1 -> - fun e2 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2)::[] -> - let uu___3 = unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt uu___3 - (fun a11 -> - let uu___4 = unembed e2 a2 ncb in - FStar_Compiler_Util.bind_opt uu___4 - (fun a21 -> - let uu___5 = - unembed - FStar_Tactics_Embedding.e_proofstate a3 - ncb in - FStar_Compiler_Util.bind_opt uu___5 - (fun ps -> - let ps1 = - FStar_Tactics_Types.set_ps_psc psc - ps in - let r1 = - interp_ctx name - (fun uu___6 -> - let uu___7 = t a11 a21 in - FStar_Tactics_Monad.run_safe - uu___7 ps1) in - let uu___6 = - let uu___7 = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed - (FStar_Tactics_Embedding.e_result - er) uu___7 r1 ncb in - FStar_Pervasives_Native.Some uu___6))) - | uu___ -> FStar_Pervasives_Native.None -let mk_tactic_interpretation_3 : - 'r 't1 't2 't3 . - Prims.string -> - ('t1 -> 't2 -> 't3 -> 'r FStar_Tactics_Monad.tac) -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2)::(a4, uu___3)::[] - -> - let uu___4 = unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt uu___4 - (fun a11 -> - let uu___5 = unembed e2 a2 ncb in - FStar_Compiler_Util.bind_opt uu___5 - (fun a21 -> - let uu___6 = unembed e3 a3 ncb in - FStar_Compiler_Util.bind_opt uu___6 - (fun a31 -> - let uu___7 = - unembed - FStar_Tactics_Embedding.e_proofstate - a4 ncb in - FStar_Compiler_Util.bind_opt uu___7 - (fun ps -> - let ps1 = - FStar_Tactics_Types.set_ps_psc - psc ps in - let r1 = - interp_ctx name - (fun uu___8 -> - let uu___9 = - t a11 a21 a31 in - FStar_Tactics_Monad.run_safe - uu___9 ps1) in - let uu___8 = - let uu___9 = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed - (FStar_Tactics_Embedding.e_result - er) uu___9 r1 ncb in - FStar_Pervasives_Native.Some - uu___8)))) - | uu___ -> FStar_Pervasives_Native.None -let mk_tactic_interpretation_4 : - 'r 't1 't2 't3 't4 . - Prims.string -> - ('t1 -> 't2 -> 't3 -> 't4 -> 'r FStar_Tactics_Monad.tac) -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2)::(a4, - uu___3):: - (a5, uu___4)::[] -> - let uu___5 = unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt uu___5 - (fun a11 -> - let uu___6 = unembed e2 a2 ncb in - FStar_Compiler_Util.bind_opt uu___6 - (fun a21 -> - let uu___7 = unembed e3 a3 ncb in - FStar_Compiler_Util.bind_opt uu___7 - (fun a31 -> - let uu___8 = unembed e4 a4 ncb in - FStar_Compiler_Util.bind_opt - uu___8 - (fun a41 -> - let uu___9 = - unembed - FStar_Tactics_Embedding.e_proofstate - a5 ncb in - FStar_Compiler_Util.bind_opt - uu___9 - (fun ps -> - let ps1 = - FStar_Tactics_Types.set_ps_psc - psc ps in - let r1 = - interp_ctx name - (fun uu___10 -> - let uu___11 = - t a11 a21 a31 - a41 in - FStar_Tactics_Monad.run_safe - uu___11 ps1) in - let uu___10 = - let uu___11 = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed - (FStar_Tactics_Embedding.e_result - er) uu___11 r1 - ncb in - FStar_Pervasives_Native.Some - uu___10))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_tactic_interpretation_5 : - 'r 't1 't2 't3 't4 't5 . - Prims.string -> - ('t1 -> 't2 -> 't3 -> 't4 -> 't5 -> 'r FStar_Tactics_Monad.tac) -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: - (a4, uu___3)::(a5, uu___4)::(a6, uu___5)::[] -> - let uu___6 = unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt uu___6 - (fun a11 -> - let uu___7 = unembed e2 a2 ncb in - FStar_Compiler_Util.bind_opt uu___7 - (fun a21 -> - let uu___8 = unembed e3 a3 ncb in - FStar_Compiler_Util.bind_opt uu___8 - (fun a31 -> - let uu___9 = unembed e4 a4 ncb in - FStar_Compiler_Util.bind_opt - uu___9 - (fun a41 -> - let uu___10 = - unembed e5 a5 ncb in - FStar_Compiler_Util.bind_opt - uu___10 - (fun a51 -> - let uu___11 = - unembed - FStar_Tactics_Embedding.e_proofstate - a6 ncb in - FStar_Compiler_Util.bind_opt - uu___11 - (fun ps -> - let ps1 = - FStar_Tactics_Types.set_ps_psc - psc ps in - let r1 = - interp_ctx name - (fun uu___12 - -> - let uu___13 - = - t a11 a21 - a31 a41 - a51 in - FStar_Tactics_Monad.run_safe - uu___13 - ps1) in - let uu___12 = - let uu___13 = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed - (FStar_Tactics_Embedding.e_result - er) - uu___13 r1 - ncb in - FStar_Pervasives_Native.Some - uu___12)))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_tactic_interpretation_6 : - 'r 't1 't2 't3 't4 't5 't6 . - Prims.string -> - ('t1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 'r FStar_Tactics_Monad.tac) - -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 't6 FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: - (a4, uu___3)::(a5, uu___4)::(a6, uu___5):: - (a7, uu___6)::[] -> - let uu___7 = unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt uu___7 - (fun a11 -> - let uu___8 = unembed e2 a2 ncb in - FStar_Compiler_Util.bind_opt uu___8 - (fun a21 -> - let uu___9 = unembed e3 a3 ncb in - FStar_Compiler_Util.bind_opt uu___9 - (fun a31 -> - let uu___10 = - unembed e4 a4 ncb in - FStar_Compiler_Util.bind_opt - uu___10 - (fun a41 -> - let uu___11 = - unembed e5 a5 ncb in - FStar_Compiler_Util.bind_opt - uu___11 - (fun a51 -> - let uu___12 = - unembed e6 a6 ncb in - FStar_Compiler_Util.bind_opt - uu___12 - (fun a61 -> - let uu___13 = - unembed - FStar_Tactics_Embedding.e_proofstate - a7 ncb in - FStar_Compiler_Util.bind_opt - uu___13 - (fun ps -> - let ps1 = - FStar_Tactics_Types.set_ps_psc - psc ps in - let r1 = - interp_ctx - name - (fun - uu___14 - -> - let uu___15 - = - t a11 a21 - a31 a41 - a51 a61 in - FStar_Tactics_Monad.run_safe - uu___15 - ps1) in - let uu___14 - = - let uu___15 - = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed - (FStar_Tactics_Embedding.e_result - er) - uu___15 - r1 ncb in - FStar_Pervasives_Native.Some - uu___14))))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_tactic_interpretation_7 : - 'r 't1 't2 't3 't4 't5 't6 't7 . - Prims.string -> - ('t1 -> - 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 'r FStar_Tactics_Monad.tac) - -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 't6 FStar_Syntax_Embeddings_Base.embedding -> - 't7 FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: - (a4, uu___3)::(a5, uu___4)::(a6, uu___5):: - (a7, uu___6)::(a8, uu___7)::[] -> - let uu___8 = unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt uu___8 - (fun a11 -> - let uu___9 = unembed e2 a2 ncb in - FStar_Compiler_Util.bind_opt uu___9 - (fun a21 -> - let uu___10 = unembed e3 a3 ncb in - FStar_Compiler_Util.bind_opt - uu___10 - (fun a31 -> - let uu___11 = - unembed e4 a4 ncb in - FStar_Compiler_Util.bind_opt - uu___11 - (fun a41 -> - let uu___12 = - unembed e5 a5 ncb in - FStar_Compiler_Util.bind_opt - uu___12 - (fun a51 -> - let uu___13 = - unembed e6 a6 - ncb in - FStar_Compiler_Util.bind_opt - uu___13 - (fun a61 -> - let uu___14 = - unembed e7 - a7 ncb in - FStar_Compiler_Util.bind_opt - uu___14 - (fun a71 -> - let uu___15 - = - unembed - FStar_Tactics_Embedding.e_proofstate - a8 ncb in - FStar_Compiler_Util.bind_opt - uu___15 - (fun ps - -> - let ps1 = - FStar_Tactics_Types.set_ps_psc - psc ps in - let r1 = - interp_ctx - name - (fun - uu___16 - -> - let uu___17 - = - t a11 a21 - a31 a41 - a51 a61 - a71 in - FStar_Tactics_Monad.run_safe - uu___17 - ps1) in - let uu___16 - = - let uu___17 - = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed - (FStar_Tactics_Embedding.e_result - er) - uu___17 - r1 ncb in - FStar_Pervasives_Native.Some - uu___16)))))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_tactic_interpretation_8 : - 'r 't1 't2 't3 't4 't5 't6 't7 't8 . - Prims.string -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 'r FStar_Tactics_Monad.tac) - -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 't6 FStar_Syntax_Embeddings_Base.embedding -> - 't7 FStar_Syntax_Embeddings_Base.embedding -> - 't8 FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: - (a4, uu___3)::(a5, uu___4)::(a6, uu___5):: - (a7, uu___6)::(a8, uu___7)::(a9, uu___8)::[] - -> - let uu___9 = unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt uu___9 - (fun a11 -> - let uu___10 = unembed e2 a2 ncb in - FStar_Compiler_Util.bind_opt uu___10 - (fun a21 -> - let uu___11 = unembed e3 a3 ncb in - FStar_Compiler_Util.bind_opt - uu___11 - (fun a31 -> - let uu___12 = - unembed e4 a4 ncb in - FStar_Compiler_Util.bind_opt - uu___12 - (fun a41 -> - let uu___13 = - unembed e5 a5 ncb in - FStar_Compiler_Util.bind_opt - uu___13 - (fun a51 -> - let uu___14 = - unembed e6 a6 - ncb in - FStar_Compiler_Util.bind_opt - uu___14 - (fun a61 -> - let uu___15 - = - unembed - e7 a7 ncb in - FStar_Compiler_Util.bind_opt - uu___15 - ( - fun a71 - -> - let uu___16 - = - unembed - e8 a8 ncb in - FStar_Compiler_Util.bind_opt - uu___16 - (fun a81 - -> - let uu___17 - = - unembed - FStar_Tactics_Embedding.e_proofstate - a9 ncb in - FStar_Compiler_Util.bind_opt - uu___17 - (fun ps - -> - let ps1 = - FStar_Tactics_Types.set_ps_psc - psc ps in - let r1 = - interp_ctx - name - (fun - uu___18 - -> - let uu___19 - = - t a11 a21 - a31 a41 - a51 a61 - a71 a81 in - FStar_Tactics_Monad.run_safe - uu___19 - ps1) in - let uu___18 - = - let uu___19 - = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed - (FStar_Tactics_Embedding.e_result - er) - uu___19 - r1 ncb in - FStar_Pervasives_Native.Some - uu___18))))))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_tactic_interpretation_9 : - 'r 't1 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 'r FStar_Tactics_Monad.tac) - -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 't6 FStar_Syntax_Embeddings_Base.embedding -> - 't7 FStar_Syntax_Embeddings_Base.embedding -> - 't8 FStar_Syntax_Embeddings_Base.embedding -> - 't9 FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: - (a4, uu___3)::(a5, uu___4)::(a6, - uu___5):: - (a7, uu___6)::(a8, uu___7)::(a9, - uu___8):: - (a10, uu___9)::[] -> - let uu___10 = unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt uu___10 - (fun a11 -> - let uu___11 = unembed e2 a2 ncb in - FStar_Compiler_Util.bind_opt - uu___11 - (fun a21 -> - let uu___12 = - unembed e3 a3 ncb in - FStar_Compiler_Util.bind_opt - uu___12 - (fun a31 -> - let uu___13 = - unembed e4 a4 ncb in - FStar_Compiler_Util.bind_opt - uu___13 - (fun a41 -> - let uu___14 = - unembed e5 a5 ncb in - FStar_Compiler_Util.bind_opt - uu___14 - (fun a51 -> - let uu___15 = - unembed e6 - a6 ncb in - FStar_Compiler_Util.bind_opt - uu___15 - (fun a61 -> - let uu___16 - = - unembed - e7 a7 ncb in - FStar_Compiler_Util.bind_opt - uu___16 - (fun a71 - -> - let uu___17 - = - unembed - e8 a8 ncb in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a81 - -> - let uu___18 - = - unembed - e9 a9 ncb in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a91 - -> - let uu___19 - = - unembed - FStar_Tactics_Embedding.e_proofstate - a10 ncb in - FStar_Compiler_Util.bind_opt - uu___19 - (fun ps - -> - let ps1 = - FStar_Tactics_Types.set_ps_psc - psc ps in - let r1 = - interp_ctx - name - (fun - uu___20 - -> - let uu___21 - = - t a11 a21 - a31 a41 - a51 a61 - a71 a81 - a91 in - FStar_Tactics_Monad.run_safe - uu___21 - ps1) in - let uu___20 - = - let uu___21 - = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed - (FStar_Tactics_Embedding.e_result - er) - uu___21 - r1 ncb in - FStar_Pervasives_Native.Some - uu___20)))))))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_tactic_interpretation_10 : - 'r 't1 't10 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> 't8 -> 't9 -> 't10 -> 'r FStar_Tactics_Monad.tac) - -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 't6 FStar_Syntax_Embeddings_Base.embedding -> - 't7 FStar_Syntax_Embeddings_Base.embedding -> - 't8 FStar_Syntax_Embeddings_Base.embedding -> - 't9 FStar_Syntax_Embeddings_Base.embedding -> - 't10 FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: - (a4, uu___3)::(a5, uu___4)::(a6, - uu___5):: - (a7, uu___6)::(a8, uu___7)::(a9, - uu___8):: - (a10, uu___9)::(a11, uu___10)::[] -> - let uu___11 = unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt uu___11 - (fun a12 -> - let uu___12 = unembed e2 a2 ncb in - FStar_Compiler_Util.bind_opt - uu___12 - (fun a21 -> - let uu___13 = - unembed e3 a3 ncb in - FStar_Compiler_Util.bind_opt - uu___13 - (fun a31 -> - let uu___14 = - unembed e4 a4 ncb in - FStar_Compiler_Util.bind_opt - uu___14 - (fun a41 -> - let uu___15 = - unembed e5 a5 - ncb in - FStar_Compiler_Util.bind_opt - uu___15 - (fun a51 -> - let uu___16 - = - unembed e6 - a6 ncb in - FStar_Compiler_Util.bind_opt - uu___16 - (fun a61 - -> - let uu___17 - = - unembed - e7 a7 ncb in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a71 - -> - let uu___18 - = - unembed - e8 a8 ncb in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a81 - -> - let uu___19 - = - unembed - e9 a9 ncb in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a91 - -> - let uu___20 - = - unembed - e10 a10 - ncb in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a101 - -> - let uu___21 - = - unembed - FStar_Tactics_Embedding.e_proofstate - a11 ncb in - FStar_Compiler_Util.bind_opt - uu___21 - (fun ps - -> - let ps1 = - FStar_Tactics_Types.set_ps_psc - psc ps in - let r1 = - interp_ctx - name - (fun - uu___22 - -> - let uu___23 - = - t a12 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 in - FStar_Tactics_Monad.run_safe - uu___23 - ps1) in - let uu___22 - = - let uu___23 - = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed - (FStar_Tactics_Embedding.e_result - er) - uu___23 - r1 ncb in - FStar_Pervasives_Native.Some - uu___22))))))))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_tactic_interpretation_11 : - 'r 't1 't10 't11 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> 't9 -> 't10 -> 't11 -> 'r FStar_Tactics_Monad.tac) - -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 't6 FStar_Syntax_Embeddings_Base.embedding -> - 't7 FStar_Syntax_Embeddings_Base.embedding -> - 't8 FStar_Syntax_Embeddings_Base.embedding -> - 't9 FStar_Syntax_Embeddings_Base.embedding -> - 't10 FStar_Syntax_Embeddings_Base.embedding -> - 't11 FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, - uu___2):: - (a4, uu___3)::(a5, uu___4):: - (a6, uu___5)::(a7, uu___6):: - (a8, uu___7)::(a9, uu___8):: - (a10, uu___9)::(a11, uu___10):: - (a12, uu___11)::[] -> - let uu___12 = unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt - uu___12 - (fun a13 -> - let uu___13 = - unembed e2 a2 ncb in - FStar_Compiler_Util.bind_opt - uu___13 - (fun a21 -> - let uu___14 = - unembed e3 a3 ncb in - FStar_Compiler_Util.bind_opt - uu___14 - (fun a31 -> - let uu___15 = - unembed e4 a4 ncb in - FStar_Compiler_Util.bind_opt - uu___15 - (fun a41 -> - let uu___16 = - unembed e5 a5 - ncb in - FStar_Compiler_Util.bind_opt - uu___16 - (fun a51 -> - let uu___17 - = - unembed - e6 a6 ncb in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a61 - -> - let uu___18 - = - unembed - e7 a7 ncb in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a71 - -> - let uu___19 - = - unembed - e8 a8 ncb in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a81 - -> - let uu___20 - = - unembed - e9 a9 ncb in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a91 - -> - let uu___21 - = - unembed - e10 a10 - ncb in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a101 - -> - let uu___22 - = - unembed - e11 a11 - ncb in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a111 - -> - let uu___23 - = - unembed - FStar_Tactics_Embedding.e_proofstate - a12 ncb in - FStar_Compiler_Util.bind_opt - uu___23 - (fun ps - -> - let ps1 = - FStar_Tactics_Types.set_ps_psc - psc ps in - let r1 = - interp_ctx - name - (fun - uu___24 - -> - let uu___25 - = - t a13 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 - a111 in - FStar_Tactics_Monad.run_safe - uu___25 - ps1) in - let uu___24 - = - let uu___25 - = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed - (FStar_Tactics_Embedding.e_result - er) - uu___25 - r1 ncb in - FStar_Pervasives_Native.Some - uu___24)))))))))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_tactic_interpretation_12 : - 'r 't1 't10 't11 't12 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> - 't10 -> 't11 -> 't12 -> 'r FStar_Tactics_Monad.tac) - -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 't6 FStar_Syntax_Embeddings_Base.embedding -> - 't7 FStar_Syntax_Embeddings_Base.embedding -> - 't8 FStar_Syntax_Embeddings_Base.embedding -> - 't9 FStar_Syntax_Embeddings_Base.embedding -> - 't10 FStar_Syntax_Embeddings_Base.embedding -> - 't11 FStar_Syntax_Embeddings_Base.embedding -> - 't12 FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1):: - (a3, uu___2)::(a4, uu___3):: - (a5, uu___4)::(a6, uu___5):: - (a7, uu___6)::(a8, uu___7):: - (a9, uu___8)::(a10, uu___9):: - (a11, uu___10)::(a12, uu___11):: - (a13, uu___12)::[] -> - let uu___13 = unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt - uu___13 - (fun a14 -> - let uu___14 = - unembed e2 a2 ncb in - FStar_Compiler_Util.bind_opt - uu___14 - (fun a21 -> - let uu___15 = - unembed e3 a3 ncb in - FStar_Compiler_Util.bind_opt - uu___15 - (fun a31 -> - let uu___16 = - unembed e4 a4 - ncb in - FStar_Compiler_Util.bind_opt - uu___16 - (fun a41 -> - let uu___17 = - unembed e5 - a5 ncb in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a51 -> - let uu___18 - = - unembed - e6 a6 ncb in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a61 - -> - let uu___19 - = - unembed - e7 a7 ncb in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a71 - -> - let uu___20 - = - unembed - e8 a8 ncb in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a81 - -> - let uu___21 - = - unembed - e9 a9 ncb in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a91 - -> - let uu___22 - = - unembed - e10 a10 - ncb in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a101 - -> - let uu___23 - = - unembed - e11 a11 - ncb in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a111 - -> - let uu___24 - = - unembed - e12 a12 - ncb in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a121 - -> - let uu___25 - = - unembed - FStar_Tactics_Embedding.e_proofstate - a13 ncb in - FStar_Compiler_Util.bind_opt - uu___25 - (fun ps - -> - let ps1 = - FStar_Tactics_Types.set_ps_psc - psc ps in - let r1 = - interp_ctx - name - (fun - uu___26 - -> - let uu___27 - = - t a14 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 - a111 a121 in - FStar_Tactics_Monad.run_safe - uu___27 - ps1) in - let uu___26 - = - let uu___27 - = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed - (FStar_Tactics_Embedding.e_result - er) - uu___27 - r1 ncb in - FStar_Pervasives_Native.Some - uu___26))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_tactic_interpretation_13 : - 'r 't1 't10 't11 't12 't13 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> - 't10 -> - 't11 -> 't12 -> 't13 -> 'r FStar_Tactics_Monad.tac) - -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 't6 FStar_Syntax_Embeddings_Base.embedding -> - 't7 FStar_Syntax_Embeddings_Base.embedding -> - 't8 FStar_Syntax_Embeddings_Base.embedding -> - 't9 FStar_Syntax_Embeddings_Base.embedding -> - 't10 FStar_Syntax_Embeddings_Base.embedding -> - 't11 FStar_Syntax_Embeddings_Base.embedding -> - 't12 FStar_Syntax_Embeddings_Base.embedding -> - 't13 FStar_Syntax_Embeddings_Base.embedding - -> - 'r FStar_Syntax_Embeddings_Base.embedding - -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1):: - (a3, uu___2)::(a4, uu___3):: - (a5, uu___4)::(a6, uu___5):: - (a7, uu___6)::(a8, uu___7):: - (a9, uu___8)::(a10, uu___9):: - (a11, uu___10)::(a12, uu___11):: - (a13, uu___12)::(a14, uu___13)::[] - -> - let uu___14 = unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt - uu___14 - (fun a15 -> - let uu___15 = - unembed e2 a2 ncb in - FStar_Compiler_Util.bind_opt - uu___15 - (fun a21 -> - let uu___16 = - unembed e3 a3 ncb in - FStar_Compiler_Util.bind_opt - uu___16 - (fun a31 -> - let uu___17 = - unembed e4 a4 - ncb in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a41 -> - let uu___18 - = - unembed - e5 a5 ncb in - FStar_Compiler_Util.bind_opt - uu___18 - ( - fun a51 - -> - let uu___19 - = - unembed - e6 a6 ncb in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a61 - -> - let uu___20 - = - unembed - e7 a7 ncb in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a71 - -> - let uu___21 - = - unembed - e8 a8 ncb in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a81 - -> - let uu___22 - = - unembed - e9 a9 ncb in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a91 - -> - let uu___23 - = - unembed - e10 a10 - ncb in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a101 - -> - let uu___24 - = - unembed - e11 a11 - ncb in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a111 - -> - let uu___25 - = - unembed - e12 a12 - ncb in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a121 - -> - let uu___26 - = - unembed - e13 a13 - ncb in - FStar_Compiler_Util.bind_opt - uu___26 - (fun a131 - -> - let uu___27 - = - unembed - FStar_Tactics_Embedding.e_proofstate - a14 ncb in - FStar_Compiler_Util.bind_opt - uu___27 - (fun ps - -> - let ps1 = - FStar_Tactics_Types.set_ps_psc - psc ps in - let r1 = - interp_ctx - name - (fun - uu___28 - -> - let uu___29 - = - t a15 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 - a111 a121 - a131 in - FStar_Tactics_Monad.run_safe - uu___29 - ps1) in - let uu___28 - = - let uu___29 - = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed - (FStar_Tactics_Embedding.e_result - er) - uu___29 - r1 ncb in - FStar_Pervasives_Native.Some - uu___28)))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_tactic_interpretation_14 : - 'r 't1 't10 't11 't12 't13 't14 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> - 't10 -> - 't11 -> - 't12 -> - 't13 -> 't14 -> 'r FStar_Tactics_Monad.tac) - -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 't6 FStar_Syntax_Embeddings_Base.embedding -> - 't7 FStar_Syntax_Embeddings_Base.embedding -> - 't8 FStar_Syntax_Embeddings_Base.embedding -> - 't9 FStar_Syntax_Embeddings_Base.embedding -> - 't10 FStar_Syntax_Embeddings_Base.embedding -> - 't11 FStar_Syntax_Embeddings_Base.embedding -> - 't12 FStar_Syntax_Embeddings_Base.embedding -> - 't13 FStar_Syntax_Embeddings_Base.embedding - -> - 't14 FStar_Syntax_Embeddings_Base.embedding - -> - 'r FStar_Syntax_Embeddings_Base.embedding - -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb - -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun e14 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1):: - (a3, uu___2)::(a4, uu___3):: - (a5, uu___4)::(a6, uu___5):: - (a7, uu___6)::(a8, uu___7):: - (a9, uu___8)::(a10, uu___9):: - (a11, uu___10)::(a12, - uu___11):: - (a13, uu___12)::(a14, - uu___13):: - (a15, uu___14)::[] -> - let uu___15 = - unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt - uu___15 - (fun a16 -> - let uu___16 = - unembed e2 a2 ncb in - FStar_Compiler_Util.bind_opt - uu___16 - (fun a21 -> - let uu___17 = - unembed e3 a3 ncb in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a31 -> - let uu___18 = - unembed e4 - a4 ncb in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a41 -> - let uu___19 - = - unembed - e5 a5 ncb in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a51 - -> - let uu___20 - = - unembed - e6 a6 ncb in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a61 - -> - let uu___21 - = - unembed - e7 a7 ncb in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a71 - -> - let uu___22 - = - unembed - e8 a8 ncb in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a81 - -> - let uu___23 - = - unembed - e9 a9 ncb in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a91 - -> - let uu___24 - = - unembed - e10 a10 - ncb in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a101 - -> - let uu___25 - = - unembed - e11 a11 - ncb in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a111 - -> - let uu___26 - = - unembed - e12 a12 - ncb in - FStar_Compiler_Util.bind_opt - uu___26 - (fun a121 - -> - let uu___27 - = - unembed - e13 a13 - ncb in - FStar_Compiler_Util.bind_opt - uu___27 - (fun a131 - -> - let uu___28 - = - unembed - e14 a14 - ncb in - FStar_Compiler_Util.bind_opt - uu___28 - (fun a141 - -> - let uu___29 - = - unembed - FStar_Tactics_Embedding.e_proofstate - a15 ncb in - FStar_Compiler_Util.bind_opt - uu___29 - (fun ps - -> - let ps1 = - FStar_Tactics_Types.set_ps_psc - psc ps in - let r1 = - interp_ctx - name - (fun - uu___30 - -> - let uu___31 - = - t a16 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 - a111 a121 - a131 a141 in - FStar_Tactics_Monad.run_safe - uu___31 - ps1) in - let uu___30 - = - let uu___31 - = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed - (FStar_Tactics_Embedding.e_result - er) - uu___31 - r1 ncb in - FStar_Pervasives_Native.Some - uu___30))))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_tactic_interpretation_15 : - 'r 't1 't10 't11 't12 't13 't14 't15 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> - 't10 -> - 't11 -> - 't12 -> - 't13 -> - 't14 -> 't15 -> 'r FStar_Tactics_Monad.tac) - -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 't6 FStar_Syntax_Embeddings_Base.embedding -> - 't7 FStar_Syntax_Embeddings_Base.embedding -> - 't8 FStar_Syntax_Embeddings_Base.embedding -> - 't9 FStar_Syntax_Embeddings_Base.embedding -> - 't10 FStar_Syntax_Embeddings_Base.embedding -> - 't11 FStar_Syntax_Embeddings_Base.embedding -> - 't12 FStar_Syntax_Embeddings_Base.embedding -> - 't13 FStar_Syntax_Embeddings_Base.embedding - -> - 't14 FStar_Syntax_Embeddings_Base.embedding - -> - 't15 - FStar_Syntax_Embeddings_Base.embedding - -> - 'r - FStar_Syntax_Embeddings_Base.embedding - -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb - -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun e14 -> - fun e15 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1):: - (a3, uu___2)::(a4, uu___3):: - (a5, uu___4)::(a6, uu___5):: - (a7, uu___6)::(a8, uu___7):: - (a9, uu___8)::(a10, uu___9):: - (a11, uu___10)::(a12, - uu___11):: - (a13, uu___12)::(a14, - uu___13):: - (a15, uu___14)::(a16, - uu___15)::[] - -> - let uu___16 = - unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt - uu___16 - (fun a17 -> - let uu___17 = - unembed e2 a2 ncb in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a21 -> - let uu___18 = - unembed e3 a3 - ncb in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a31 -> - let uu___19 - = - unembed e4 - a4 ncb in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a41 - -> - let uu___20 - = - unembed - e5 a5 ncb in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a51 - -> - let uu___21 - = - unembed - e6 a6 ncb in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a61 - -> - let uu___22 - = - unembed - e7 a7 ncb in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a71 - -> - let uu___23 - = - unembed - e8 a8 ncb in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a81 - -> - let uu___24 - = - unembed - e9 a9 ncb in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a91 - -> - let uu___25 - = - unembed - e10 a10 - ncb in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a101 - -> - let uu___26 - = - unembed - e11 a11 - ncb in - FStar_Compiler_Util.bind_opt - uu___26 - (fun a111 - -> - let uu___27 - = - unembed - e12 a12 - ncb in - FStar_Compiler_Util.bind_opt - uu___27 - (fun a121 - -> - let uu___28 - = - unembed - e13 a13 - ncb in - FStar_Compiler_Util.bind_opt - uu___28 - (fun a131 - -> - let uu___29 - = - unembed - e14 a14 - ncb in - FStar_Compiler_Util.bind_opt - uu___29 - (fun a141 - -> - let uu___30 - = - unembed - e15 a15 - ncb in - FStar_Compiler_Util.bind_opt - uu___30 - (fun a151 - -> - let uu___31 - = - unembed - FStar_Tactics_Embedding.e_proofstate - a16 ncb in - FStar_Compiler_Util.bind_opt - uu___31 - (fun ps - -> - let ps1 = - FStar_Tactics_Types.set_ps_psc - psc ps in - let r1 = - interp_ctx - name - (fun - uu___32 - -> - let uu___33 - = - t a17 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 - a111 a121 - a131 a141 - a151 in - FStar_Tactics_Monad.run_safe - uu___33 - ps1) in - let uu___32 - = - let uu___33 - = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed - (FStar_Tactics_Embedding.e_result - er) - uu___33 - r1 ncb in - FStar_Pervasives_Native.Some - uu___32)))))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_tactic_interpretation_16 : - 'r 't1 't10 't11 't12 't13 't14 't15 't16 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> - 't10 -> - 't11 -> - 't12 -> - 't13 -> - 't14 -> - 't15 -> 't16 -> 'r FStar_Tactics_Monad.tac) - -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 't6 FStar_Syntax_Embeddings_Base.embedding -> - 't7 FStar_Syntax_Embeddings_Base.embedding -> - 't8 FStar_Syntax_Embeddings_Base.embedding -> - 't9 FStar_Syntax_Embeddings_Base.embedding -> - 't10 FStar_Syntax_Embeddings_Base.embedding -> - 't11 FStar_Syntax_Embeddings_Base.embedding -> - 't12 FStar_Syntax_Embeddings_Base.embedding -> - 't13 FStar_Syntax_Embeddings_Base.embedding - -> - 't14 FStar_Syntax_Embeddings_Base.embedding - -> - 't15 - FStar_Syntax_Embeddings_Base.embedding - -> - 't16 - FStar_Syntax_Embeddings_Base.embedding - -> - 'r - FStar_Syntax_Embeddings_Base.embedding - -> - FStar_TypeChecker_Primops_Base.psc - -> - FStar_Syntax_Embeddings_Base.norm_cb - -> - FStar_Syntax_Syntax.universes - -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun e14 -> - fun e15 -> - fun e16 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1):: - (a3, uu___2)::(a4, - uu___3):: - (a5, uu___4)::(a6, - uu___5):: - (a7, uu___6)::(a8, - uu___7):: - (a9, uu___8)::(a10, - uu___9):: - (a11, uu___10)::(a12, - uu___11):: - (a13, uu___12)::(a14, - uu___13):: - (a15, uu___14)::(a16, - uu___15):: - (a17, uu___16)::[] -> - let uu___17 = - unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a18 -> - let uu___18 = - unembed e2 a2 ncb in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a21 -> - let uu___19 = - unembed e3 a3 - ncb in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a31 -> - let uu___20 - = - unembed - e4 a4 ncb in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a41 - -> - let uu___21 - = - unembed - e5 a5 ncb in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a51 - -> - let uu___22 - = - unembed - e6 a6 ncb in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a61 - -> - let uu___23 - = - unembed - e7 a7 ncb in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a71 - -> - let uu___24 - = - unembed - e8 a8 ncb in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a81 - -> - let uu___25 - = - unembed - e9 a9 ncb in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a91 - -> - let uu___26 - = - unembed - e10 a10 - ncb in - FStar_Compiler_Util.bind_opt - uu___26 - (fun a101 - -> - let uu___27 - = - unembed - e11 a11 - ncb in - FStar_Compiler_Util.bind_opt - uu___27 - (fun a111 - -> - let uu___28 - = - unembed - e12 a12 - ncb in - FStar_Compiler_Util.bind_opt - uu___28 - (fun a121 - -> - let uu___29 - = - unembed - e13 a13 - ncb in - FStar_Compiler_Util.bind_opt - uu___29 - (fun a131 - -> - let uu___30 - = - unembed - e14 a14 - ncb in - FStar_Compiler_Util.bind_opt - uu___30 - (fun a141 - -> - let uu___31 - = - unembed - e15 a15 - ncb in - FStar_Compiler_Util.bind_opt - uu___31 - (fun a151 - -> - let uu___32 - = - unembed - e16 a16 - ncb in - FStar_Compiler_Util.bind_opt - uu___32 - (fun a161 - -> - let uu___33 - = - unembed - FStar_Tactics_Embedding.e_proofstate - a17 ncb in - FStar_Compiler_Util.bind_opt - uu___33 - (fun ps - -> - let ps1 = - FStar_Tactics_Types.set_ps_psc - psc ps in - let r1 = - interp_ctx - name - (fun - uu___34 - -> - let uu___35 - = - t a18 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 - a111 a121 - a131 a141 - a151 a161 in - FStar_Tactics_Monad.run_safe - uu___35 - ps1) in - let uu___34 - = - let uu___35 - = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed - (FStar_Tactics_Embedding.e_result - er) - uu___35 - r1 ncb in - FStar_Pervasives_Native.Some - uu___34))))))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_tactic_interpretation_17 : - 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't2 't3 't4 't5 't6 't7 't8 - 't9 . - Prims.string -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> - 't10 -> - 't11 -> - 't12 -> - 't13 -> - 't14 -> - 't15 -> - 't16 -> - 't17 -> 'r FStar_Tactics_Monad.tac) - -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 't6 FStar_Syntax_Embeddings_Base.embedding -> - 't7 FStar_Syntax_Embeddings_Base.embedding -> - 't8 FStar_Syntax_Embeddings_Base.embedding -> - 't9 FStar_Syntax_Embeddings_Base.embedding -> - 't10 FStar_Syntax_Embeddings_Base.embedding -> - 't11 FStar_Syntax_Embeddings_Base.embedding -> - 't12 FStar_Syntax_Embeddings_Base.embedding -> - 't13 FStar_Syntax_Embeddings_Base.embedding - -> - 't14 FStar_Syntax_Embeddings_Base.embedding - -> - 't15 - FStar_Syntax_Embeddings_Base.embedding - -> - 't16 - FStar_Syntax_Embeddings_Base.embedding - -> - 't17 - FStar_Syntax_Embeddings_Base.embedding - -> - 'r - FStar_Syntax_Embeddings_Base.embedding - -> - FStar_TypeChecker_Primops_Base.psc - -> - FStar_Syntax_Embeddings_Base.norm_cb - -> - FStar_Syntax_Syntax.universes - -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun e14 -> - fun e15 -> - fun e16 -> - fun e17 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1):: - (a3, uu___2)::(a4, - uu___3):: - (a5, uu___4)::(a6, - uu___5):: - (a7, uu___6)::(a8, - uu___7):: - (a9, uu___8)::(a10, - uu___9):: - (a11, uu___10):: - (a12, uu___11):: - (a13, uu___12):: - (a14, uu___13):: - (a15, uu___14):: - (a16, uu___15):: - (a17, uu___16):: - (a18, uu___17)::[] -> - let uu___18 = - unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a19 -> - let uu___19 = - unembed e2 a2 - ncb in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a21 -> - let uu___20 = - unembed e3 - a3 ncb in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a31 -> - let uu___21 - = - unembed - e4 a4 ncb in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a41 - -> - let uu___22 - = - unembed - e5 a5 ncb in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a51 - -> - let uu___23 - = - unembed - e6 a6 ncb in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a61 - -> - let uu___24 - = - unembed - e7 a7 ncb in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a71 - -> - let uu___25 - = - unembed - e8 a8 ncb in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a81 - -> - let uu___26 - = - unembed - e9 a9 ncb in - FStar_Compiler_Util.bind_opt - uu___26 - (fun a91 - -> - let uu___27 - = - unembed - e10 a10 - ncb in - FStar_Compiler_Util.bind_opt - uu___27 - (fun a101 - -> - let uu___28 - = - unembed - e11 a11 - ncb in - FStar_Compiler_Util.bind_opt - uu___28 - (fun a111 - -> - let uu___29 - = - unembed - e12 a12 - ncb in - FStar_Compiler_Util.bind_opt - uu___29 - (fun a121 - -> - let uu___30 - = - unembed - e13 a13 - ncb in - FStar_Compiler_Util.bind_opt - uu___30 - (fun a131 - -> - let uu___31 - = - unembed - e14 a14 - ncb in - FStar_Compiler_Util.bind_opt - uu___31 - (fun a141 - -> - let uu___32 - = - unembed - e15 a15 - ncb in - FStar_Compiler_Util.bind_opt - uu___32 - (fun a151 - -> - let uu___33 - = - unembed - e16 a16 - ncb in - FStar_Compiler_Util.bind_opt - uu___33 - (fun a161 - -> - let uu___34 - = - unembed - e17 a17 - ncb in - FStar_Compiler_Util.bind_opt - uu___34 - (fun a171 - -> - let uu___35 - = - unembed - FStar_Tactics_Embedding.e_proofstate - a18 ncb in - FStar_Compiler_Util.bind_opt - uu___35 - (fun ps - -> - let ps1 = - FStar_Tactics_Types.set_ps_psc - psc ps in - let r1 = - interp_ctx - name - (fun - uu___36 - -> - let uu___37 - = - t a19 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 - a111 a121 - a131 a141 - a151 a161 - a171 in - FStar_Tactics_Monad.run_safe - uu___37 - ps1) in - let uu___36 - = - let uu___37 - = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed - (FStar_Tactics_Embedding.e_result - er) - uu___37 - r1 ncb in - FStar_Pervasives_Native.Some - uu___36)))))))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_tactic_interpretation_18 : - 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't18 't2 't3 't4 't5 't6 't7 - 't8 't9 . - Prims.string -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> - 't10 -> - 't11 -> - 't12 -> - 't13 -> - 't14 -> - 't15 -> - 't16 -> - 't17 -> - 't18 -> 'r FStar_Tactics_Monad.tac) - -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 't6 FStar_Syntax_Embeddings_Base.embedding -> - 't7 FStar_Syntax_Embeddings_Base.embedding -> - 't8 FStar_Syntax_Embeddings_Base.embedding -> - 't9 FStar_Syntax_Embeddings_Base.embedding -> - 't10 FStar_Syntax_Embeddings_Base.embedding -> - 't11 FStar_Syntax_Embeddings_Base.embedding -> - 't12 FStar_Syntax_Embeddings_Base.embedding -> - 't13 FStar_Syntax_Embeddings_Base.embedding - -> - 't14 FStar_Syntax_Embeddings_Base.embedding - -> - 't15 - FStar_Syntax_Embeddings_Base.embedding - -> - 't16 - FStar_Syntax_Embeddings_Base.embedding - -> - 't17 - FStar_Syntax_Embeddings_Base.embedding - -> - 't18 - FStar_Syntax_Embeddings_Base.embedding - -> - 'r - FStar_Syntax_Embeddings_Base.embedding - -> - FStar_TypeChecker_Primops_Base.psc - -> - FStar_Syntax_Embeddings_Base.norm_cb - -> - FStar_Syntax_Syntax.universes - -> - FStar_Syntax_Syntax.args - -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun e14 -> - fun e15 -> - fun e16 -> - fun e17 -> - fun e18 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, - uu___1):: - (a3, uu___2):: - (a4, uu___3):: - (a5, uu___4):: - (a6, uu___5):: - (a7, uu___6):: - (a8, uu___7):: - (a9, uu___8):: - (a10, uu___9):: - (a11, uu___10):: - (a12, uu___11):: - (a13, uu___12):: - (a14, uu___13):: - (a15, uu___14):: - (a16, uu___15):: - (a17, uu___16):: - (a18, uu___17):: - (a19, uu___18)::[] -> - let uu___19 = - unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a110 -> - let uu___20 = - unembed e2 a2 - ncb in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a21 -> - let uu___21 - = - unembed - e3 a3 ncb in - FStar_Compiler_Util.bind_opt - uu___21 - ( - fun a31 - -> - let uu___22 - = - unembed - e4 a4 ncb in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a41 - -> - let uu___23 - = - unembed - e5 a5 ncb in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a51 - -> - let uu___24 - = - unembed - e6 a6 ncb in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a61 - -> - let uu___25 - = - unembed - e7 a7 ncb in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a71 - -> - let uu___26 - = - unembed - e8 a8 ncb in - FStar_Compiler_Util.bind_opt - uu___26 - (fun a81 - -> - let uu___27 - = - unembed - e9 a9 ncb in - FStar_Compiler_Util.bind_opt - uu___27 - (fun a91 - -> - let uu___28 - = - unembed - e10 a10 - ncb in - FStar_Compiler_Util.bind_opt - uu___28 - (fun a101 - -> - let uu___29 - = - unembed - e11 a11 - ncb in - FStar_Compiler_Util.bind_opt - uu___29 - (fun a111 - -> - let uu___30 - = - unembed - e12 a12 - ncb in - FStar_Compiler_Util.bind_opt - uu___30 - (fun a121 - -> - let uu___31 - = - unembed - e13 a13 - ncb in - FStar_Compiler_Util.bind_opt - uu___31 - (fun a131 - -> - let uu___32 - = - unembed - e14 a14 - ncb in - FStar_Compiler_Util.bind_opt - uu___32 - (fun a141 - -> - let uu___33 - = - unembed - e15 a15 - ncb in - FStar_Compiler_Util.bind_opt - uu___33 - (fun a151 - -> - let uu___34 - = - unembed - e16 a16 - ncb in - FStar_Compiler_Util.bind_opt - uu___34 - (fun a161 - -> - let uu___35 - = - unembed - e17 a17 - ncb in - FStar_Compiler_Util.bind_opt - uu___35 - (fun a171 - -> - let uu___36 - = - unembed - e18 a18 - ncb in - FStar_Compiler_Util.bind_opt - uu___36 - (fun a181 - -> - let uu___37 - = - unembed - FStar_Tactics_Embedding.e_proofstate - a19 ncb in - FStar_Compiler_Util.bind_opt - uu___37 - (fun ps - -> - let ps1 = - FStar_Tactics_Types.set_ps_psc - psc ps in - let r1 = - interp_ctx - name - (fun - uu___38 - -> - let uu___39 - = - t a110 - a21 a31 - a41 a51 - a61 a71 - a81 a91 - a101 a111 - a121 a131 - a141 a151 - a161 a171 - a181 in - FStar_Tactics_Monad.run_safe - uu___39 - ps1) in - let uu___38 - = - let uu___39 - = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed - (FStar_Tactics_Embedding.e_result - er) - uu___39 - r1 ncb in - FStar_Pervasives_Native.Some - uu___38))))))))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_tactic_interpretation_19 : - 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't18 't19 't2 't3 't4 't5 - 't6 't7 't8 't9 . - Prims.string -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> - 't10 -> - 't11 -> - 't12 -> - 't13 -> - 't14 -> - 't15 -> - 't16 -> - 't17 -> - 't18 -> - 't19 -> 'r FStar_Tactics_Monad.tac) - -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 't6 FStar_Syntax_Embeddings_Base.embedding -> - 't7 FStar_Syntax_Embeddings_Base.embedding -> - 't8 FStar_Syntax_Embeddings_Base.embedding -> - 't9 FStar_Syntax_Embeddings_Base.embedding -> - 't10 FStar_Syntax_Embeddings_Base.embedding -> - 't11 FStar_Syntax_Embeddings_Base.embedding -> - 't12 FStar_Syntax_Embeddings_Base.embedding -> - 't13 FStar_Syntax_Embeddings_Base.embedding - -> - 't14 FStar_Syntax_Embeddings_Base.embedding - -> - 't15 - FStar_Syntax_Embeddings_Base.embedding - -> - 't16 - FStar_Syntax_Embeddings_Base.embedding - -> - 't17 - FStar_Syntax_Embeddings_Base.embedding - -> - 't18 - FStar_Syntax_Embeddings_Base.embedding - -> - 't19 - FStar_Syntax_Embeddings_Base.embedding - -> - 'r - FStar_Syntax_Embeddings_Base.embedding - -> - FStar_TypeChecker_Primops_Base.psc - -> - FStar_Syntax_Embeddings_Base.norm_cb - -> - FStar_Syntax_Syntax.universes - -> - FStar_Syntax_Syntax.args - -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun e14 -> - fun e15 -> - fun e16 -> - fun e17 -> - fun e18 -> - fun e19 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___):: - (a2, uu___1):: - (a3, uu___2):: - (a4, uu___3):: - (a5, uu___4):: - (a6, uu___5):: - (a7, uu___6):: - (a8, uu___7):: - (a9, uu___8):: - (a10, uu___9):: - (a11, uu___10):: - (a12, uu___11):: - (a13, uu___12):: - (a14, uu___13):: - (a15, uu___14):: - (a16, uu___15):: - (a17, uu___16):: - (a18, uu___17):: - (a19, uu___18):: - (a20, uu___19)::[] - -> - let uu___20 = - unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a110 -> - let uu___21 = - unembed e2 - a2 ncb in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a21 -> - let uu___22 - = - unembed - e3 a3 ncb in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a31 - -> - let uu___23 - = - unembed - e4 a4 ncb in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a41 - -> - let uu___24 - = - unembed - e5 a5 ncb in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a51 - -> - let uu___25 - = - unembed - e6 a6 ncb in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a61 - -> - let uu___26 - = - unembed - e7 a7 ncb in - FStar_Compiler_Util.bind_opt - uu___26 - (fun a71 - -> - let uu___27 - = - unembed - e8 a8 ncb in - FStar_Compiler_Util.bind_opt - uu___27 - (fun a81 - -> - let uu___28 - = - unembed - e9 a9 ncb in - FStar_Compiler_Util.bind_opt - uu___28 - (fun a91 - -> - let uu___29 - = - unembed - e10 a10 - ncb in - FStar_Compiler_Util.bind_opt - uu___29 - (fun a101 - -> - let uu___30 - = - unembed - e11 a11 - ncb in - FStar_Compiler_Util.bind_opt - uu___30 - (fun a111 - -> - let uu___31 - = - unembed - e12 a12 - ncb in - FStar_Compiler_Util.bind_opt - uu___31 - (fun a121 - -> - let uu___32 - = - unembed - e13 a13 - ncb in - FStar_Compiler_Util.bind_opt - uu___32 - (fun a131 - -> - let uu___33 - = - unembed - e14 a14 - ncb in - FStar_Compiler_Util.bind_opt - uu___33 - (fun a141 - -> - let uu___34 - = - unembed - e15 a15 - ncb in - FStar_Compiler_Util.bind_opt - uu___34 - (fun a151 - -> - let uu___35 - = - unembed - e16 a16 - ncb in - FStar_Compiler_Util.bind_opt - uu___35 - (fun a161 - -> - let uu___36 - = - unembed - e17 a17 - ncb in - FStar_Compiler_Util.bind_opt - uu___36 - (fun a171 - -> - let uu___37 - = - unembed - e18 a18 - ncb in - FStar_Compiler_Util.bind_opt - uu___37 - (fun a181 - -> - let uu___38 - = - unembed - e19 a19 - ncb in - FStar_Compiler_Util.bind_opt - uu___38 - (fun a191 - -> - let uu___39 - = - unembed - FStar_Tactics_Embedding.e_proofstate - a20 ncb in - FStar_Compiler_Util.bind_opt - uu___39 - (fun ps - -> - let ps1 = - FStar_Tactics_Types.set_ps_psc - psc ps in - let r1 = - interp_ctx - name - (fun - uu___40 - -> - let uu___41 - = - t a110 - a21 a31 - a41 a51 - a61 a71 - a81 a91 - a101 a111 - a121 a131 - a141 a151 - a161 a171 - a181 a191 in - FStar_Tactics_Monad.run_safe - uu___41 - ps1) in - let uu___40 - = - let uu___41 - = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed - (FStar_Tactics_Embedding.e_result - er) - uu___41 - r1 ncb in - FStar_Pervasives_Native.Some - uu___40)))))))))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_tactic_interpretation_20 : - 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't18 't19 't2 't20 't3 't4 - 't5 't6 't7 't8 't9 . - Prims.string -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> - 't10 -> - 't11 -> - 't12 -> - 't13 -> - 't14 -> - 't15 -> - 't16 -> - 't17 -> - 't18 -> - 't19 -> - 't20 -> - 'r FStar_Tactics_Monad.tac) - -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 't6 FStar_Syntax_Embeddings_Base.embedding -> - 't7 FStar_Syntax_Embeddings_Base.embedding -> - 't8 FStar_Syntax_Embeddings_Base.embedding -> - 't9 FStar_Syntax_Embeddings_Base.embedding -> - 't10 FStar_Syntax_Embeddings_Base.embedding -> - 't11 FStar_Syntax_Embeddings_Base.embedding -> - 't12 FStar_Syntax_Embeddings_Base.embedding -> - 't13 FStar_Syntax_Embeddings_Base.embedding - -> - 't14 FStar_Syntax_Embeddings_Base.embedding - -> - 't15 - FStar_Syntax_Embeddings_Base.embedding - -> - 't16 - FStar_Syntax_Embeddings_Base.embedding - -> - 't17 - FStar_Syntax_Embeddings_Base.embedding - -> - 't18 - FStar_Syntax_Embeddings_Base.embedding - -> - 't19 - FStar_Syntax_Embeddings_Base.embedding - -> - 't20 - FStar_Syntax_Embeddings_Base.embedding - -> - 'r - FStar_Syntax_Embeddings_Base.embedding - -> - FStar_TypeChecker_Primops_Base.psc - -> - FStar_Syntax_Embeddings_Base.norm_cb - -> - FStar_Syntax_Syntax.universes - -> - FStar_Syntax_Syntax.args - -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun e14 -> - fun e15 -> - fun e16 -> - fun e17 -> - fun e18 -> - fun e19 -> - fun e20 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___):: - (a2, uu___1):: - (a3, uu___2):: - (a4, uu___3):: - (a5, uu___4):: - (a6, uu___5):: - (a7, uu___6):: - (a8, uu___7):: - (a9, uu___8):: - (a10, uu___9):: - (a11, uu___10):: - (a12, uu___11):: - (a13, uu___12):: - (a14, uu___13):: - (a15, uu___14):: - (a16, uu___15):: - (a17, uu___16):: - (a18, uu___17):: - (a19, uu___18):: - (a20, uu___19):: - (a21, uu___20)::[] - -> - let uu___21 = - unembed e1 a1 - ncb in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a110 -> - let uu___22 - = - unembed e2 - a2 ncb in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a22 - -> - let uu___23 - = - unembed - e3 a3 ncb in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a31 - -> - let uu___24 - = - unembed - e4 a4 ncb in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a41 - -> - let uu___25 - = - unembed - e5 a5 ncb in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a51 - -> - let uu___26 - = - unembed - e6 a6 ncb in - FStar_Compiler_Util.bind_opt - uu___26 - (fun a61 - -> - let uu___27 - = - unembed - e7 a7 ncb in - FStar_Compiler_Util.bind_opt - uu___27 - (fun a71 - -> - let uu___28 - = - unembed - e8 a8 ncb in - FStar_Compiler_Util.bind_opt - uu___28 - (fun a81 - -> - let uu___29 - = - unembed - e9 a9 ncb in - FStar_Compiler_Util.bind_opt - uu___29 - (fun a91 - -> - let uu___30 - = - unembed - e10 a10 - ncb in - FStar_Compiler_Util.bind_opt - uu___30 - (fun a101 - -> - let uu___31 - = - unembed - e11 a11 - ncb in - FStar_Compiler_Util.bind_opt - uu___31 - (fun a111 - -> - let uu___32 - = - unembed - e12 a12 - ncb in - FStar_Compiler_Util.bind_opt - uu___32 - (fun a121 - -> - let uu___33 - = - unembed - e13 a13 - ncb in - FStar_Compiler_Util.bind_opt - uu___33 - (fun a131 - -> - let uu___34 - = - unembed - e14 a14 - ncb in - FStar_Compiler_Util.bind_opt - uu___34 - (fun a141 - -> - let uu___35 - = - unembed - e15 a15 - ncb in - FStar_Compiler_Util.bind_opt - uu___35 - (fun a151 - -> - let uu___36 - = - unembed - e16 a16 - ncb in - FStar_Compiler_Util.bind_opt - uu___36 - (fun a161 - -> - let uu___37 - = - unembed - e17 a17 - ncb in - FStar_Compiler_Util.bind_opt - uu___37 - (fun a171 - -> - let uu___38 - = - unembed - e18 a18 - ncb in - FStar_Compiler_Util.bind_opt - uu___38 - (fun a181 - -> - let uu___39 - = - unembed - e19 a19 - ncb in - FStar_Compiler_Util.bind_opt - uu___39 - (fun a191 - -> - let uu___40 - = - unembed - e20 a20 - ncb in - FStar_Compiler_Util.bind_opt - uu___40 - (fun a201 - -> - let uu___41 - = - unembed - FStar_Tactics_Embedding.e_proofstate - a21 ncb in - FStar_Compiler_Util.bind_opt - uu___41 - (fun ps - -> - let ps1 = - FStar_Tactics_Types.set_ps_psc - psc ps in - let r1 = - interp_ctx - name - (fun - uu___42 - -> - let uu___43 - = - t a110 - a22 a31 - a41 a51 - a61 a71 - a81 a91 - a101 a111 - a121 a131 - a141 a151 - a161 a171 - a181 a191 - a201 in - FStar_Tactics_Monad.run_safe - uu___43 - ps1) in - let uu___42 - = - let uu___43 - = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed - (FStar_Tactics_Embedding.e_result - er) - uu___43 - r1 ncb in - FStar_Pervasives_Native.Some - uu___42))))))))))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_tactic_nbe_interpretation_1 : - 'r 't1 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> 'r FStar_Tactics_Monad.tac) -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun t -> - fun e1 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::[] -> - let uu___2 = FStar_TypeChecker_NBETerm.unembed e1 cb a1 in - FStar_Compiler_Util.bind_opt uu___2 - (fun a11 -> - let uu___3 = - FStar_TypeChecker_NBETerm.unembed - FStar_Tactics_Embedding.e_proofstate_nbe cb a2 in - FStar_Compiler_Util.bind_opt uu___3 - (fun ps -> - let r1 = - interp_ctx name - (fun uu___4 -> - let uu___5 = t a11 in - FStar_Tactics_Monad.run_safe uu___5 ps) in - let uu___4 = - FStar_TypeChecker_NBETerm.embed - (FStar_Tactics_Embedding.e_result_nbe er) - cb r1 in - FStar_Pervasives_Native.Some uu___4)) - | uu___ -> FStar_Pervasives_Native.None -let mk_tactic_nbe_interpretation_2 : - 'r 't1 't2 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> 't2 -> 'r FStar_Tactics_Monad.tac) -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun t -> - fun e1 -> - fun e2 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2)::[] -> - let uu___3 = FStar_TypeChecker_NBETerm.unembed e1 cb a1 in - FStar_Compiler_Util.bind_opt uu___3 - (fun a11 -> - let uu___4 = - FStar_TypeChecker_NBETerm.unembed e2 cb a2 in - FStar_Compiler_Util.bind_opt uu___4 - (fun a21 -> - let uu___5 = - FStar_TypeChecker_NBETerm.unembed - FStar_Tactics_Embedding.e_proofstate_nbe - cb a3 in - FStar_Compiler_Util.bind_opt uu___5 - (fun ps -> - let r1 = - interp_ctx name - (fun uu___6 -> - let uu___7 = t a11 a21 in - FStar_Tactics_Monad.run_safe - uu___7 ps) in - let uu___6 = - FStar_TypeChecker_NBETerm.embed - (FStar_Tactics_Embedding.e_result_nbe - er) cb r1 in - FStar_Pervasives_Native.Some uu___6))) - | uu___ -> FStar_Pervasives_Native.None -let mk_tactic_nbe_interpretation_3 : - 'r 't1 't2 't3 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> 't2 -> 't3 -> 'r FStar_Tactics_Monad.tac) -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2)::(a4, uu___3)::[] - -> - let uu___4 = - FStar_TypeChecker_NBETerm.unembed e1 cb a1 in - FStar_Compiler_Util.bind_opt uu___4 - (fun a11 -> - let uu___5 = - FStar_TypeChecker_NBETerm.unembed e2 cb a2 in - FStar_Compiler_Util.bind_opt uu___5 - (fun a21 -> - let uu___6 = - FStar_TypeChecker_NBETerm.unembed e3 cb - a3 in - FStar_Compiler_Util.bind_opt uu___6 - (fun a31 -> - let uu___7 = - FStar_TypeChecker_NBETerm.unembed - FStar_Tactics_Embedding.e_proofstate_nbe - cb a4 in - FStar_Compiler_Util.bind_opt uu___7 - (fun ps -> - let r1 = - interp_ctx name - (fun uu___8 -> - let uu___9 = t a11 a21 a31 in - FStar_Tactics_Monad.run_safe - uu___9 ps) in - let uu___8 = - FStar_TypeChecker_NBETerm.embed - (FStar_Tactics_Embedding.e_result_nbe - er) cb r1 in - FStar_Pervasives_Native.Some - uu___8)))) - | uu___ -> FStar_Pervasives_Native.None -let mk_tactic_nbe_interpretation_4 : - 'r 't1 't2 't3 't4 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> 't2 -> 't3 -> 't4 -> 'r FStar_Tactics_Monad.tac) -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2)::(a4, uu___3):: - (a5, uu___4)::[] -> - let uu___5 = - FStar_TypeChecker_NBETerm.unembed e1 cb a1 in - FStar_Compiler_Util.bind_opt uu___5 - (fun a11 -> - let uu___6 = - FStar_TypeChecker_NBETerm.unembed e2 cb a2 in - FStar_Compiler_Util.bind_opt uu___6 - (fun a21 -> - let uu___7 = - FStar_TypeChecker_NBETerm.unembed e3 cb - a3 in - FStar_Compiler_Util.bind_opt uu___7 - (fun a31 -> - let uu___8 = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt uu___8 - (fun a41 -> - let uu___9 = - FStar_TypeChecker_NBETerm.unembed - FStar_Tactics_Embedding.e_proofstate_nbe - cb a5 in - FStar_Compiler_Util.bind_opt - uu___9 - (fun ps -> - let r1 = - interp_ctx name - (fun uu___10 -> - let uu___11 = - t a11 a21 a31 a41 in - FStar_Tactics_Monad.run_safe - uu___11 ps) in - let uu___10 = - FStar_TypeChecker_NBETerm.embed - (FStar_Tactics_Embedding.e_result_nbe - er) cb r1 in - FStar_Pervasives_Native.Some - uu___10))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_tactic_nbe_interpretation_5 : - 'r 't1 't2 't3 't4 't5 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> 't2 -> 't3 -> 't4 -> 't5 -> 'r FStar_Tactics_Monad.tac) -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2)::(a4, - uu___3):: - (a5, uu___4)::(a6, uu___5)::[] -> - let uu___6 = - FStar_TypeChecker_NBETerm.unembed e1 cb a1 in - FStar_Compiler_Util.bind_opt uu___6 - (fun a11 -> - let uu___7 = - FStar_TypeChecker_NBETerm.unembed e2 cb a2 in - FStar_Compiler_Util.bind_opt uu___7 - (fun a21 -> - let uu___8 = - FStar_TypeChecker_NBETerm.unembed e3 - cb a3 in - FStar_Compiler_Util.bind_opt uu___8 - (fun a31 -> - let uu___9 = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___9 - (fun a41 -> - let uu___10 = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___10 - (fun a51 -> - let uu___11 = - FStar_TypeChecker_NBETerm.unembed - FStar_Tactics_Embedding.e_proofstate_nbe - cb a6 in - FStar_Compiler_Util.bind_opt - uu___11 - (fun ps -> - let r1 = - interp_ctx name - (fun uu___12 -> - let uu___13 - = - t a11 a21 - a31 a41 - a51 in - FStar_Tactics_Monad.run_safe - uu___13 ps) in - let uu___12 = - FStar_TypeChecker_NBETerm.embed - (FStar_Tactics_Embedding.e_result_nbe - er) cb r1 in - FStar_Pervasives_Native.Some - uu___12)))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_tactic_nbe_interpretation_6 : - 'r 't1 't2 't3 't4 't5 't6 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 'r FStar_Tactics_Monad.tac) - -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 't6 FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: - (a4, uu___3)::(a5, uu___4)::(a6, uu___5):: - (a7, uu___6)::[] -> - let uu___7 = - FStar_TypeChecker_NBETerm.unembed e1 cb a1 in - FStar_Compiler_Util.bind_opt uu___7 - (fun a11 -> - let uu___8 = - FStar_TypeChecker_NBETerm.unembed e2 cb - a2 in - FStar_Compiler_Util.bind_opt uu___8 - (fun a21 -> - let uu___9 = - FStar_TypeChecker_NBETerm.unembed - e3 cb a3 in - FStar_Compiler_Util.bind_opt uu___9 - (fun a31 -> - let uu___10 = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___10 - (fun a41 -> - let uu___11 = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___11 - (fun a51 -> - let uu___12 = - FStar_TypeChecker_NBETerm.unembed - e6 cb a6 in - FStar_Compiler_Util.bind_opt - uu___12 - (fun a61 -> - let uu___13 = - FStar_TypeChecker_NBETerm.unembed - FStar_Tactics_Embedding.e_proofstate_nbe - cb a7 in - FStar_Compiler_Util.bind_opt - uu___13 - (fun ps -> - let r1 = - interp_ctx - name - (fun - uu___14 - -> - let uu___15 - = - t a11 a21 - a31 a41 - a51 a61 in - FStar_Tactics_Monad.run_safe - uu___15 - ps) in - let uu___14 - = - FStar_TypeChecker_NBETerm.embed - (FStar_Tactics_Embedding.e_result_nbe - er) cb r1 in - FStar_Pervasives_Native.Some - uu___14))))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_tactic_nbe_interpretation_7 : - 'r 't1 't2 't3 't4 't5 't6 't7 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> - 't2 -> - 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 'r FStar_Tactics_Monad.tac) - -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 't6 FStar_TypeChecker_NBETerm.embedding -> - 't7 FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: - (a4, uu___3)::(a5, uu___4)::(a6, uu___5):: - (a7, uu___6)::(a8, uu___7)::[] -> - let uu___8 = - FStar_TypeChecker_NBETerm.unembed e1 cb a1 in - FStar_Compiler_Util.bind_opt uu___8 - (fun a11 -> - let uu___9 = - FStar_TypeChecker_NBETerm.unembed e2 - cb a2 in - FStar_Compiler_Util.bind_opt uu___9 - (fun a21 -> - let uu___10 = - FStar_TypeChecker_NBETerm.unembed - e3 cb a3 in - FStar_Compiler_Util.bind_opt - uu___10 - (fun a31 -> - let uu___11 = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___11 - (fun a41 -> - let uu___12 = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___12 - (fun a51 -> - let uu___13 = - FStar_TypeChecker_NBETerm.unembed - e6 cb a6 in - FStar_Compiler_Util.bind_opt - uu___13 - (fun a61 -> - let uu___14 = - FStar_TypeChecker_NBETerm.unembed - e7 cb a7 in - FStar_Compiler_Util.bind_opt - uu___14 - (fun a71 -> - let uu___15 - = - FStar_TypeChecker_NBETerm.unembed - FStar_Tactics_Embedding.e_proofstate_nbe - cb a8 in - FStar_Compiler_Util.bind_opt - uu___15 - (fun ps - -> - let r1 = - interp_ctx - name - (fun - uu___16 - -> - let uu___17 - = - t a11 a21 - a31 a41 - a51 a61 - a71 in - FStar_Tactics_Monad.run_safe - uu___17 - ps) in - let uu___16 - = - FStar_TypeChecker_NBETerm.embed - (FStar_Tactics_Embedding.e_result_nbe - er) cb r1 in - FStar_Pervasives_Native.Some - uu___16)))))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_tactic_nbe_interpretation_8 : - 'r 't1 't2 't3 't4 't5 't6 't7 't8 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 'r FStar_Tactics_Monad.tac) - -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 't6 FStar_TypeChecker_NBETerm.embedding -> - 't7 FStar_TypeChecker_NBETerm.embedding -> - 't8 FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: - (a4, uu___3)::(a5, uu___4)::(a6, uu___5):: - (a7, uu___6)::(a8, uu___7)::(a9, uu___8)::[] - -> - let uu___9 = - FStar_TypeChecker_NBETerm.unembed e1 cb - a1 in - FStar_Compiler_Util.bind_opt uu___9 - (fun a11 -> - let uu___10 = - FStar_TypeChecker_NBETerm.unembed e2 - cb a2 in - FStar_Compiler_Util.bind_opt uu___10 - (fun a21 -> - let uu___11 = - FStar_TypeChecker_NBETerm.unembed - e3 cb a3 in - FStar_Compiler_Util.bind_opt - uu___11 - (fun a31 -> - let uu___12 = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___12 - (fun a41 -> - let uu___13 = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___13 - (fun a51 -> - let uu___14 = - FStar_TypeChecker_NBETerm.unembed - e6 cb a6 in - FStar_Compiler_Util.bind_opt - uu___14 - (fun a61 -> - let uu___15 = - FStar_TypeChecker_NBETerm.unembed - e7 cb a7 in - FStar_Compiler_Util.bind_opt - uu___15 - (fun a71 -> - let uu___16 - = - FStar_TypeChecker_NBETerm.unembed - e8 cb a8 in - FStar_Compiler_Util.bind_opt - uu___16 - (fun a81 - -> - let uu___17 - = - FStar_TypeChecker_NBETerm.unembed - FStar_Tactics_Embedding.e_proofstate_nbe - cb a9 in - FStar_Compiler_Util.bind_opt - uu___17 - (fun ps - -> - let r1 = - interp_ctx - name - (fun - uu___18 - -> - let uu___19 - = - t a11 a21 - a31 a41 - a51 a61 - a71 a81 in - FStar_Tactics_Monad.run_safe - uu___19 - ps) in - let uu___18 - = - FStar_TypeChecker_NBETerm.embed - (FStar_Tactics_Embedding.e_result_nbe - er) cb r1 in - FStar_Pervasives_Native.Some - uu___18))))))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_tactic_nbe_interpretation_9 : - 'r 't1 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> 't7 -> 't8 -> 't9 -> 'r FStar_Tactics_Monad.tac) - -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 't6 FStar_TypeChecker_NBETerm.embedding -> - 't7 FStar_TypeChecker_NBETerm.embedding -> - 't8 FStar_TypeChecker_NBETerm.embedding -> - 't9 FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: - (a4, uu___3)::(a5, uu___4)::(a6, uu___5):: - (a7, uu___6)::(a8, uu___7)::(a9, uu___8):: - (a10, uu___9)::[] -> - let uu___10 = - FStar_TypeChecker_NBETerm.unembed e1 cb - a1 in - FStar_Compiler_Util.bind_opt uu___10 - (fun a11 -> - let uu___11 = - FStar_TypeChecker_NBETerm.unembed - e2 cb a2 in - FStar_Compiler_Util.bind_opt uu___11 - (fun a21 -> - let uu___12 = - FStar_TypeChecker_NBETerm.unembed - e3 cb a3 in - FStar_Compiler_Util.bind_opt - uu___12 - (fun a31 -> - let uu___13 = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___13 - (fun a41 -> - let uu___14 = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___14 - (fun a51 -> - let uu___15 = - FStar_TypeChecker_NBETerm.unembed - e6 cb a6 in - FStar_Compiler_Util.bind_opt - uu___15 - (fun a61 -> - let uu___16 - = - FStar_TypeChecker_NBETerm.unembed - e7 cb a7 in - FStar_Compiler_Util.bind_opt - uu___16 - ( - fun a71 - -> - let uu___17 - = - FStar_TypeChecker_NBETerm.unembed - e8 cb a8 in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a81 - -> - let uu___18 - = - FStar_TypeChecker_NBETerm.unembed - e9 cb a9 in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a91 - -> - let uu___19 - = - FStar_TypeChecker_NBETerm.unembed - FStar_Tactics_Embedding.e_proofstate_nbe - cb a10 in - FStar_Compiler_Util.bind_opt - uu___19 - (fun ps - -> - let r1 = - interp_ctx - name - (fun - uu___20 - -> - let uu___21 - = - t a11 a21 - a31 a41 - a51 a61 - a71 a81 - a91 in - FStar_Tactics_Monad.run_safe - uu___21 - ps) in - let uu___20 - = - FStar_TypeChecker_NBETerm.embed - (FStar_Tactics_Embedding.e_result_nbe - er) cb r1 in - FStar_Pervasives_Native.Some - uu___20)))))))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_tactic_nbe_interpretation_10 : - 'r 't1 't10 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> 't8 -> 't9 -> 't10 -> 'r FStar_Tactics_Monad.tac) - -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 't6 FStar_TypeChecker_NBETerm.embedding -> - 't7 FStar_TypeChecker_NBETerm.embedding -> - 't8 FStar_TypeChecker_NBETerm.embedding -> - 't9 FStar_TypeChecker_NBETerm.embedding -> - 't10 FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: - (a4, uu___3)::(a5, uu___4)::(a6, - uu___5):: - (a7, uu___6)::(a8, uu___7)::(a9, - uu___8):: - (a10, uu___9)::(a11, uu___10)::[] -> - let uu___11 = - FStar_TypeChecker_NBETerm.unembed e1 - cb a1 in - FStar_Compiler_Util.bind_opt uu___11 - (fun a12 -> - let uu___12 = - FStar_TypeChecker_NBETerm.unembed - e2 cb a2 in - FStar_Compiler_Util.bind_opt - uu___12 - (fun a21 -> - let uu___13 = - FStar_TypeChecker_NBETerm.unembed - e3 cb a3 in - FStar_Compiler_Util.bind_opt - uu___13 - (fun a31 -> - let uu___14 = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___14 - (fun a41 -> - let uu___15 = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___15 - (fun a51 -> - let uu___16 = - FStar_TypeChecker_NBETerm.unembed - e6 cb a6 in - FStar_Compiler_Util.bind_opt - uu___16 - (fun a61 -> - let uu___17 - = - FStar_TypeChecker_NBETerm.unembed - e7 cb a7 in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a71 - -> - let uu___18 - = - FStar_TypeChecker_NBETerm.unembed - e8 cb a8 in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a81 - -> - let uu___19 - = - FStar_TypeChecker_NBETerm.unembed - e9 cb a9 in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a91 - -> - let uu___20 - = - FStar_TypeChecker_NBETerm.unembed - e10 cb - a10 in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a101 - -> - let uu___21 - = - FStar_TypeChecker_NBETerm.unembed - FStar_Tactics_Embedding.e_proofstate_nbe - cb a11 in - FStar_Compiler_Util.bind_opt - uu___21 - (fun ps - -> - let r1 = - interp_ctx - name - (fun - uu___22 - -> - let uu___23 - = - t a12 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 in - FStar_Tactics_Monad.run_safe - uu___23 - ps) in - let uu___22 - = - FStar_TypeChecker_NBETerm.embed - (FStar_Tactics_Embedding.e_result_nbe - er) cb r1 in - FStar_Pervasives_Native.Some - uu___22))))))))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_tactic_nbe_interpretation_11 : - 'r 't1 't10 't11 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> 't10 -> 't11 -> 'r FStar_Tactics_Monad.tac) - -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 't6 FStar_TypeChecker_NBETerm.embedding -> - 't7 FStar_TypeChecker_NBETerm.embedding -> - 't8 FStar_TypeChecker_NBETerm.embedding -> - 't9 FStar_TypeChecker_NBETerm.embedding -> - 't10 FStar_TypeChecker_NBETerm.embedding -> - 't11 FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: - (a4, uu___3)::(a5, uu___4)::(a6, - uu___5):: - (a7, uu___6)::(a8, uu___7)::(a9, - uu___8):: - (a10, uu___9)::(a11, uu___10):: - (a12, uu___11)::[] -> - let uu___12 = - FStar_TypeChecker_NBETerm.unembed - e1 cb a1 in - FStar_Compiler_Util.bind_opt uu___12 - (fun a13 -> - let uu___13 = - FStar_TypeChecker_NBETerm.unembed - e2 cb a2 in - FStar_Compiler_Util.bind_opt - uu___13 - (fun a21 -> - let uu___14 = - FStar_TypeChecker_NBETerm.unembed - e3 cb a3 in - FStar_Compiler_Util.bind_opt - uu___14 - (fun a31 -> - let uu___15 = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___15 - (fun a41 -> - let uu___16 = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___16 - (fun a51 -> - let uu___17 - = - FStar_TypeChecker_NBETerm.unembed - e6 cb a6 in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a61 - -> - let uu___18 - = - FStar_TypeChecker_NBETerm.unembed - e7 cb a7 in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a71 - -> - let uu___19 - = - FStar_TypeChecker_NBETerm.unembed - e8 cb a8 in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a81 - -> - let uu___20 - = - FStar_TypeChecker_NBETerm.unembed - e9 cb a9 in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a91 - -> - let uu___21 - = - FStar_TypeChecker_NBETerm.unembed - e10 cb - a10 in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a101 - -> - let uu___22 - = - FStar_TypeChecker_NBETerm.unembed - e11 cb - a11 in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a111 - -> - let uu___23 - = - FStar_TypeChecker_NBETerm.unembed - FStar_Tactics_Embedding.e_proofstate_nbe - cb a12 in - FStar_Compiler_Util.bind_opt - uu___23 - (fun ps - -> - let r1 = - interp_ctx - name - (fun - uu___24 - -> - let uu___25 - = - t a13 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 - a111 in - FStar_Tactics_Monad.run_safe - uu___25 - ps) in - let uu___24 - = - FStar_TypeChecker_NBETerm.embed - (FStar_Tactics_Embedding.e_result_nbe - er) cb r1 in - FStar_Pervasives_Native.Some - uu___24)))))))))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_tactic_nbe_interpretation_12 : - 'r 't1 't10 't11 't12 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> - 't10 -> 't11 -> 't12 -> 'r FStar_Tactics_Monad.tac) - -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 't6 FStar_TypeChecker_NBETerm.embedding -> - 't7 FStar_TypeChecker_NBETerm.embedding -> - 't8 FStar_TypeChecker_NBETerm.embedding -> - 't9 FStar_TypeChecker_NBETerm.embedding -> - 't10 FStar_TypeChecker_NBETerm.embedding -> - 't11 FStar_TypeChecker_NBETerm.embedding -> - 't12 FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, - uu___2):: - (a4, uu___3)::(a5, uu___4):: - (a6, uu___5)::(a7, uu___6):: - (a8, uu___7)::(a9, uu___8):: - (a10, uu___9)::(a11, uu___10):: - (a12, uu___11)::(a13, uu___12)::[] - -> - let uu___13 = - FStar_TypeChecker_NBETerm.unembed - e1 cb a1 in - FStar_Compiler_Util.bind_opt - uu___13 - (fun a14 -> - let uu___14 = - FStar_TypeChecker_NBETerm.unembed - e2 cb a2 in - FStar_Compiler_Util.bind_opt - uu___14 - (fun a21 -> - let uu___15 = - FStar_TypeChecker_NBETerm.unembed - e3 cb a3 in - FStar_Compiler_Util.bind_opt - uu___15 - (fun a31 -> - let uu___16 = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___16 - (fun a41 -> - let uu___17 = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a51 -> - let uu___18 - = - FStar_TypeChecker_NBETerm.unembed - e6 cb a6 in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a61 - -> - let uu___19 - = - FStar_TypeChecker_NBETerm.unembed - e7 cb a7 in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a71 - -> - let uu___20 - = - FStar_TypeChecker_NBETerm.unembed - e8 cb a8 in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a81 - -> - let uu___21 - = - FStar_TypeChecker_NBETerm.unembed - e9 cb a9 in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a91 - -> - let uu___22 - = - FStar_TypeChecker_NBETerm.unembed - e10 cb - a10 in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a101 - -> - let uu___23 - = - FStar_TypeChecker_NBETerm.unembed - e11 cb - a11 in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a111 - -> - let uu___24 - = - FStar_TypeChecker_NBETerm.unembed - e12 cb - a12 in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a121 - -> - let uu___25 - = - FStar_TypeChecker_NBETerm.unembed - FStar_Tactics_Embedding.e_proofstate_nbe - cb a13 in - FStar_Compiler_Util.bind_opt - uu___25 - (fun ps - -> - let r1 = - interp_ctx - name - (fun - uu___26 - -> - let uu___27 - = - t a14 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 - a111 a121 in - FStar_Tactics_Monad.run_safe - uu___27 - ps) in - let uu___26 - = - FStar_TypeChecker_NBETerm.embed - (FStar_Tactics_Embedding.e_result_nbe - er) cb r1 in - FStar_Pervasives_Native.Some - uu___26))))))))))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_tactic_nbe_interpretation_13 : - 'r 't1 't10 't11 't12 't13 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> - 't10 -> - 't11 -> - 't12 -> 't13 -> 'r FStar_Tactics_Monad.tac) - -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 't6 FStar_TypeChecker_NBETerm.embedding -> - 't7 FStar_TypeChecker_NBETerm.embedding -> - 't8 FStar_TypeChecker_NBETerm.embedding -> - 't9 FStar_TypeChecker_NBETerm.embedding -> - 't10 FStar_TypeChecker_NBETerm.embedding -> - 't11 FStar_TypeChecker_NBETerm.embedding -> - 't12 FStar_TypeChecker_NBETerm.embedding -> - 't13 FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1):: - (a3, uu___2)::(a4, uu___3):: - (a5, uu___4)::(a6, uu___5):: - (a7, uu___6)::(a8, uu___7):: - (a9, uu___8)::(a10, uu___9):: - (a11, uu___10)::(a12, uu___11):: - (a13, uu___12)::(a14, uu___13)::[] - -> - let uu___14 = - FStar_TypeChecker_NBETerm.unembed - e1 cb a1 in - FStar_Compiler_Util.bind_opt - uu___14 - (fun a15 -> - let uu___15 = - FStar_TypeChecker_NBETerm.unembed - e2 cb a2 in - FStar_Compiler_Util.bind_opt - uu___15 - (fun a21 -> - let uu___16 = - FStar_TypeChecker_NBETerm.unembed - e3 cb a3 in - FStar_Compiler_Util.bind_opt - uu___16 - (fun a31 -> - let uu___17 = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a41 -> - let uu___18 = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a51 -> - let uu___19 - = - FStar_TypeChecker_NBETerm.unembed - e6 cb a6 in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a61 - -> - let uu___20 - = - FStar_TypeChecker_NBETerm.unembed - e7 cb a7 in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a71 - -> - let uu___21 - = - FStar_TypeChecker_NBETerm.unembed - e8 cb a8 in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a81 - -> - let uu___22 - = - FStar_TypeChecker_NBETerm.unembed - e9 cb a9 in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a91 - -> - let uu___23 - = - FStar_TypeChecker_NBETerm.unembed - e10 cb - a10 in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a101 - -> - let uu___24 - = - FStar_TypeChecker_NBETerm.unembed - e11 cb - a11 in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a111 - -> - let uu___25 - = - FStar_TypeChecker_NBETerm.unembed - e12 cb - a12 in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a121 - -> - let uu___26 - = - FStar_TypeChecker_NBETerm.unembed - e13 cb - a13 in - FStar_Compiler_Util.bind_opt - uu___26 - (fun a131 - -> - let uu___27 - = - FStar_TypeChecker_NBETerm.unembed - FStar_Tactics_Embedding.e_proofstate_nbe - cb a14 in - FStar_Compiler_Util.bind_opt - uu___27 - (fun ps - -> - let r1 = - interp_ctx - name - (fun - uu___28 - -> - let uu___29 - = - t a15 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 - a111 a121 - a131 in - FStar_Tactics_Monad.run_safe - uu___29 - ps) in - let uu___28 - = - FStar_TypeChecker_NBETerm.embed - (FStar_Tactics_Embedding.e_result_nbe - er) cb r1 in - FStar_Pervasives_Native.Some - uu___28)))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_tactic_nbe_interpretation_14 : - 'r 't1 't10 't11 't12 't13 't14 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> - 't10 -> - 't11 -> - 't12 -> - 't13 -> 't14 -> 'r FStar_Tactics_Monad.tac) - -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 't6 FStar_TypeChecker_NBETerm.embedding -> - 't7 FStar_TypeChecker_NBETerm.embedding -> - 't8 FStar_TypeChecker_NBETerm.embedding -> - 't9 FStar_TypeChecker_NBETerm.embedding -> - 't10 FStar_TypeChecker_NBETerm.embedding -> - 't11 FStar_TypeChecker_NBETerm.embedding -> - 't12 FStar_TypeChecker_NBETerm.embedding -> - 't13 FStar_TypeChecker_NBETerm.embedding -> - 't14 FStar_TypeChecker_NBETerm.embedding - -> - 'r FStar_TypeChecker_NBETerm.embedding - -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun e14 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1):: - (a3, uu___2)::(a4, uu___3):: - (a5, uu___4)::(a6, uu___5):: - (a7, uu___6)::(a8, uu___7):: - (a9, uu___8)::(a10, uu___9):: - (a11, uu___10)::(a12, uu___11):: - (a13, uu___12)::(a14, uu___13):: - (a15, uu___14)::[] -> - let uu___15 = - FStar_TypeChecker_NBETerm.unembed - e1 cb a1 in - FStar_Compiler_Util.bind_opt - uu___15 - (fun a16 -> - let uu___16 = - FStar_TypeChecker_NBETerm.unembed - e2 cb a2 in - FStar_Compiler_Util.bind_opt - uu___16 - (fun a21 -> - let uu___17 = - FStar_TypeChecker_NBETerm.unembed - e3 cb a3 in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a31 -> - let uu___18 = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a41 -> - let uu___19 - = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___19 - ( - fun a51 - -> - let uu___20 - = - FStar_TypeChecker_NBETerm.unembed - e6 cb a6 in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a61 - -> - let uu___21 - = - FStar_TypeChecker_NBETerm.unembed - e7 cb a7 in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a71 - -> - let uu___22 - = - FStar_TypeChecker_NBETerm.unembed - e8 cb a8 in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a81 - -> - let uu___23 - = - FStar_TypeChecker_NBETerm.unembed - e9 cb a9 in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a91 - -> - let uu___24 - = - FStar_TypeChecker_NBETerm.unembed - e10 cb - a10 in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a101 - -> - let uu___25 - = - FStar_TypeChecker_NBETerm.unembed - e11 cb - a11 in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a111 - -> - let uu___26 - = - FStar_TypeChecker_NBETerm.unembed - e12 cb - a12 in - FStar_Compiler_Util.bind_opt - uu___26 - (fun a121 - -> - let uu___27 - = - FStar_TypeChecker_NBETerm.unembed - e13 cb - a13 in - FStar_Compiler_Util.bind_opt - uu___27 - (fun a131 - -> - let uu___28 - = - FStar_TypeChecker_NBETerm.unembed - e14 cb - a14 in - FStar_Compiler_Util.bind_opt - uu___28 - (fun a141 - -> - let uu___29 - = - FStar_TypeChecker_NBETerm.unembed - FStar_Tactics_Embedding.e_proofstate_nbe - cb a15 in - FStar_Compiler_Util.bind_opt - uu___29 - (fun ps - -> - let r1 = - interp_ctx - name - (fun - uu___30 - -> - let uu___31 - = - t a16 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 - a111 a121 - a131 a141 in - FStar_Tactics_Monad.run_safe - uu___31 - ps) in - let uu___30 - = - FStar_TypeChecker_NBETerm.embed - (FStar_Tactics_Embedding.e_result_nbe - er) cb r1 in - FStar_Pervasives_Native.Some - uu___30))))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_tactic_nbe_interpretation_15 : - 'r 't1 't10 't11 't12 't13 't14 't15 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> - 't10 -> - 't11 -> - 't12 -> - 't13 -> - 't14 -> 't15 -> 'r FStar_Tactics_Monad.tac) - -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 't6 FStar_TypeChecker_NBETerm.embedding -> - 't7 FStar_TypeChecker_NBETerm.embedding -> - 't8 FStar_TypeChecker_NBETerm.embedding -> - 't9 FStar_TypeChecker_NBETerm.embedding -> - 't10 FStar_TypeChecker_NBETerm.embedding -> - 't11 FStar_TypeChecker_NBETerm.embedding -> - 't12 FStar_TypeChecker_NBETerm.embedding -> - 't13 FStar_TypeChecker_NBETerm.embedding -> - 't14 FStar_TypeChecker_NBETerm.embedding - -> - 't15 - FStar_TypeChecker_NBETerm.embedding - -> - 'r - FStar_TypeChecker_NBETerm.embedding - -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun e14 -> - fun e15 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1):: - (a3, uu___2)::(a4, uu___3):: - (a5, uu___4)::(a6, uu___5):: - (a7, uu___6)::(a8, uu___7):: - (a9, uu___8)::(a10, uu___9):: - (a11, uu___10)::(a12, - uu___11):: - (a13, uu___12)::(a14, - uu___13):: - (a15, uu___14)::(a16, - uu___15)::[] - -> - let uu___16 = - FStar_TypeChecker_NBETerm.unembed - e1 cb a1 in - FStar_Compiler_Util.bind_opt - uu___16 - (fun a17 -> - let uu___17 = - FStar_TypeChecker_NBETerm.unembed - e2 cb a2 in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a21 -> - let uu___18 = - FStar_TypeChecker_NBETerm.unembed - e3 cb a3 in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a31 -> - let uu___19 = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a41 -> - let uu___20 - = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a51 - -> - let uu___21 - = - FStar_TypeChecker_NBETerm.unembed - e6 cb a6 in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a61 - -> - let uu___22 - = - FStar_TypeChecker_NBETerm.unembed - e7 cb a7 in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a71 - -> - let uu___23 - = - FStar_TypeChecker_NBETerm.unembed - e8 cb a8 in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a81 - -> - let uu___24 - = - FStar_TypeChecker_NBETerm.unembed - e9 cb a9 in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a91 - -> - let uu___25 - = - FStar_TypeChecker_NBETerm.unembed - e10 cb - a10 in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a101 - -> - let uu___26 - = - FStar_TypeChecker_NBETerm.unembed - e11 cb - a11 in - FStar_Compiler_Util.bind_opt - uu___26 - (fun a111 - -> - let uu___27 - = - FStar_TypeChecker_NBETerm.unembed - e12 cb - a12 in - FStar_Compiler_Util.bind_opt - uu___27 - (fun a121 - -> - let uu___28 - = - FStar_TypeChecker_NBETerm.unembed - e13 cb - a13 in - FStar_Compiler_Util.bind_opt - uu___28 - (fun a131 - -> - let uu___29 - = - FStar_TypeChecker_NBETerm.unembed - e14 cb - a14 in - FStar_Compiler_Util.bind_opt - uu___29 - (fun a141 - -> - let uu___30 - = - FStar_TypeChecker_NBETerm.unembed - e15 cb - a15 in - FStar_Compiler_Util.bind_opt - uu___30 - (fun a151 - -> - let uu___31 - = - FStar_TypeChecker_NBETerm.unembed - FStar_Tactics_Embedding.e_proofstate_nbe - cb a16 in - FStar_Compiler_Util.bind_opt - uu___31 - (fun ps - -> - let r1 = - interp_ctx - name - (fun - uu___32 - -> - let uu___33 - = - t a17 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 - a111 a121 - a131 a141 - a151 in - FStar_Tactics_Monad.run_safe - uu___33 - ps) in - let uu___32 - = - FStar_TypeChecker_NBETerm.embed - (FStar_Tactics_Embedding.e_result_nbe - er) cb r1 in - FStar_Pervasives_Native.Some - uu___32)))))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_tactic_nbe_interpretation_16 : - 'r 't1 't10 't11 't12 't13 't14 't15 't16 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> - 't10 -> - 't11 -> - 't12 -> - 't13 -> - 't14 -> - 't15 -> - 't16 -> 'r FStar_Tactics_Monad.tac) - -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 't6 FStar_TypeChecker_NBETerm.embedding -> - 't7 FStar_TypeChecker_NBETerm.embedding -> - 't8 FStar_TypeChecker_NBETerm.embedding -> - 't9 FStar_TypeChecker_NBETerm.embedding -> - 't10 FStar_TypeChecker_NBETerm.embedding -> - 't11 FStar_TypeChecker_NBETerm.embedding -> - 't12 FStar_TypeChecker_NBETerm.embedding -> - 't13 FStar_TypeChecker_NBETerm.embedding -> - 't14 FStar_TypeChecker_NBETerm.embedding - -> - 't15 - FStar_TypeChecker_NBETerm.embedding - -> - 't16 - FStar_TypeChecker_NBETerm.embedding - -> - 'r - FStar_TypeChecker_NBETerm.embedding - -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args - -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun e14 -> - fun e15 -> - fun e16 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1):: - (a3, uu___2)::(a4, uu___3):: - (a5, uu___4)::(a6, uu___5):: - (a7, uu___6)::(a8, uu___7):: - (a9, uu___8)::(a10, uu___9):: - (a11, uu___10)::(a12, - uu___11):: - (a13, uu___12)::(a14, - uu___13):: - (a15, uu___14)::(a16, - uu___15):: - (a17, uu___16)::[] -> - let uu___17 = - FStar_TypeChecker_NBETerm.unembed - e1 cb a1 in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a18 -> - let uu___18 = - FStar_TypeChecker_NBETerm.unembed - e2 cb a2 in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a21 -> - let uu___19 = - FStar_TypeChecker_NBETerm.unembed - e3 cb a3 in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a31 -> - let uu___20 - = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a41 - -> - let uu___21 - = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a51 - -> - let uu___22 - = - FStar_TypeChecker_NBETerm.unembed - e6 cb a6 in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a61 - -> - let uu___23 - = - FStar_TypeChecker_NBETerm.unembed - e7 cb a7 in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a71 - -> - let uu___24 - = - FStar_TypeChecker_NBETerm.unembed - e8 cb a8 in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a81 - -> - let uu___25 - = - FStar_TypeChecker_NBETerm.unembed - e9 cb a9 in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a91 - -> - let uu___26 - = - FStar_TypeChecker_NBETerm.unembed - e10 cb - a10 in - FStar_Compiler_Util.bind_opt - uu___26 - (fun a101 - -> - let uu___27 - = - FStar_TypeChecker_NBETerm.unembed - e11 cb - a11 in - FStar_Compiler_Util.bind_opt - uu___27 - (fun a111 - -> - let uu___28 - = - FStar_TypeChecker_NBETerm.unembed - e12 cb - a12 in - FStar_Compiler_Util.bind_opt - uu___28 - (fun a121 - -> - let uu___29 - = - FStar_TypeChecker_NBETerm.unembed - e13 cb - a13 in - FStar_Compiler_Util.bind_opt - uu___29 - (fun a131 - -> - let uu___30 - = - FStar_TypeChecker_NBETerm.unembed - e14 cb - a14 in - FStar_Compiler_Util.bind_opt - uu___30 - (fun a141 - -> - let uu___31 - = - FStar_TypeChecker_NBETerm.unembed - e15 cb - a15 in - FStar_Compiler_Util.bind_opt - uu___31 - (fun a151 - -> - let uu___32 - = - FStar_TypeChecker_NBETerm.unembed - e16 cb - a16 in - FStar_Compiler_Util.bind_opt - uu___32 - (fun a161 - -> - let uu___33 - = - FStar_TypeChecker_NBETerm.unembed - FStar_Tactics_Embedding.e_proofstate_nbe - cb a17 in - FStar_Compiler_Util.bind_opt - uu___33 - (fun ps - -> - let r1 = - interp_ctx - name - (fun - uu___34 - -> - let uu___35 - = - t a18 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 - a111 a121 - a131 a141 - a151 a161 in - FStar_Tactics_Monad.run_safe - uu___35 - ps) in - let uu___34 - = - FStar_TypeChecker_NBETerm.embed - (FStar_Tactics_Embedding.e_result_nbe - er) cb r1 in - FStar_Pervasives_Native.Some - uu___34))))))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_tactic_nbe_interpretation_17 : - 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't2 't3 't4 't5 't6 't7 't8 - 't9 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> - 't10 -> - 't11 -> - 't12 -> - 't13 -> - 't14 -> - 't15 -> - 't16 -> - 't17 -> 'r FStar_Tactics_Monad.tac) - -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 't6 FStar_TypeChecker_NBETerm.embedding -> - 't7 FStar_TypeChecker_NBETerm.embedding -> - 't8 FStar_TypeChecker_NBETerm.embedding -> - 't9 FStar_TypeChecker_NBETerm.embedding -> - 't10 FStar_TypeChecker_NBETerm.embedding -> - 't11 FStar_TypeChecker_NBETerm.embedding -> - 't12 FStar_TypeChecker_NBETerm.embedding -> - 't13 FStar_TypeChecker_NBETerm.embedding -> - 't14 FStar_TypeChecker_NBETerm.embedding - -> - 't15 - FStar_TypeChecker_NBETerm.embedding - -> - 't16 - FStar_TypeChecker_NBETerm.embedding - -> - 't17 - FStar_TypeChecker_NBETerm.embedding - -> - 'r - FStar_TypeChecker_NBETerm.embedding - -> - FStar_Syntax_Syntax.universes - -> - FStar_TypeChecker_NBETerm.args - -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun e14 -> - fun e15 -> - fun e16 -> - fun e17 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1):: - (a3, uu___2)::(a4, - uu___3):: - (a5, uu___4)::(a6, - uu___5):: - (a7, uu___6)::(a8, - uu___7):: - (a9, uu___8)::(a10, - uu___9):: - (a11, uu___10)::(a12, - uu___11):: - (a13, uu___12)::(a14, - uu___13):: - (a15, uu___14)::(a16, - uu___15):: - (a17, uu___16)::(a18, - uu___17)::[] - -> - let uu___18 = - FStar_TypeChecker_NBETerm.unembed - e1 cb a1 in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a19 -> - let uu___19 = - FStar_TypeChecker_NBETerm.unembed - e2 cb a2 in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a21 -> - let uu___20 = - FStar_TypeChecker_NBETerm.unembed - e3 cb a3 in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a31 -> - let uu___21 - = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a41 - -> - let uu___22 - = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a51 - -> - let uu___23 - = - FStar_TypeChecker_NBETerm.unembed - e6 cb a6 in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a61 - -> - let uu___24 - = - FStar_TypeChecker_NBETerm.unembed - e7 cb a7 in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a71 - -> - let uu___25 - = - FStar_TypeChecker_NBETerm.unembed - e8 cb a8 in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a81 - -> - let uu___26 - = - FStar_TypeChecker_NBETerm.unembed - e9 cb a9 in - FStar_Compiler_Util.bind_opt - uu___26 - (fun a91 - -> - let uu___27 - = - FStar_TypeChecker_NBETerm.unembed - e10 cb - a10 in - FStar_Compiler_Util.bind_opt - uu___27 - (fun a101 - -> - let uu___28 - = - FStar_TypeChecker_NBETerm.unembed - e11 cb - a11 in - FStar_Compiler_Util.bind_opt - uu___28 - (fun a111 - -> - let uu___29 - = - FStar_TypeChecker_NBETerm.unembed - e12 cb - a12 in - FStar_Compiler_Util.bind_opt - uu___29 - (fun a121 - -> - let uu___30 - = - FStar_TypeChecker_NBETerm.unembed - e13 cb - a13 in - FStar_Compiler_Util.bind_opt - uu___30 - (fun a131 - -> - let uu___31 - = - FStar_TypeChecker_NBETerm.unembed - e14 cb - a14 in - FStar_Compiler_Util.bind_opt - uu___31 - (fun a141 - -> - let uu___32 - = - FStar_TypeChecker_NBETerm.unembed - e15 cb - a15 in - FStar_Compiler_Util.bind_opt - uu___32 - (fun a151 - -> - let uu___33 - = - FStar_TypeChecker_NBETerm.unembed - e16 cb - a16 in - FStar_Compiler_Util.bind_opt - uu___33 - (fun a161 - -> - let uu___34 - = - FStar_TypeChecker_NBETerm.unembed - e17 cb - a17 in - FStar_Compiler_Util.bind_opt - uu___34 - (fun a171 - -> - let uu___35 - = - FStar_TypeChecker_NBETerm.unembed - FStar_Tactics_Embedding.e_proofstate_nbe - cb a18 in - FStar_Compiler_Util.bind_opt - uu___35 - (fun ps - -> - let r1 = - interp_ctx - name - (fun - uu___36 - -> - let uu___37 - = - t a19 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 - a111 a121 - a131 a141 - a151 a161 - a171 in - FStar_Tactics_Monad.run_safe - uu___37 - ps) in - let uu___36 - = - FStar_TypeChecker_NBETerm.embed - (FStar_Tactics_Embedding.e_result_nbe - er) cb r1 in - FStar_Pervasives_Native.Some - uu___36)))))))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_tactic_nbe_interpretation_18 : - 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't18 't2 't3 't4 't5 't6 't7 - 't8 't9 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> - 't10 -> - 't11 -> - 't12 -> - 't13 -> - 't14 -> - 't15 -> - 't16 -> - 't17 -> - 't18 -> 'r FStar_Tactics_Monad.tac) - -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 't6 FStar_TypeChecker_NBETerm.embedding -> - 't7 FStar_TypeChecker_NBETerm.embedding -> - 't8 FStar_TypeChecker_NBETerm.embedding -> - 't9 FStar_TypeChecker_NBETerm.embedding -> - 't10 FStar_TypeChecker_NBETerm.embedding -> - 't11 FStar_TypeChecker_NBETerm.embedding -> - 't12 FStar_TypeChecker_NBETerm.embedding -> - 't13 FStar_TypeChecker_NBETerm.embedding -> - 't14 FStar_TypeChecker_NBETerm.embedding - -> - 't15 - FStar_TypeChecker_NBETerm.embedding - -> - 't16 - FStar_TypeChecker_NBETerm.embedding - -> - 't17 - FStar_TypeChecker_NBETerm.embedding - -> - 't18 - FStar_TypeChecker_NBETerm.embedding - -> - 'r - FStar_TypeChecker_NBETerm.embedding - -> - FStar_Syntax_Syntax.universes - -> - FStar_TypeChecker_NBETerm.args - -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun e14 -> - fun e15 -> - fun e16 -> - fun e17 -> - fun e18 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1):: - (a3, uu___2)::(a4, - uu___3):: - (a5, uu___4)::(a6, - uu___5):: - (a7, uu___6)::(a8, - uu___7):: - (a9, uu___8)::(a10, - uu___9):: - (a11, uu___10):: - (a12, uu___11):: - (a13, uu___12):: - (a14, uu___13):: - (a15, uu___14):: - (a16, uu___15):: - (a17, uu___16):: - (a18, uu___17):: - (a19, uu___18)::[] -> - let uu___19 = - FStar_TypeChecker_NBETerm.unembed - e1 cb a1 in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a110 -> - let uu___20 = - FStar_TypeChecker_NBETerm.unembed - e2 cb a2 in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a21 -> - let uu___21 = - FStar_TypeChecker_NBETerm.unembed - e3 cb a3 in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a31 -> - let uu___22 - = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a41 - -> - let uu___23 - = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a51 - -> - let uu___24 - = - FStar_TypeChecker_NBETerm.unembed - e6 cb a6 in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a61 - -> - let uu___25 - = - FStar_TypeChecker_NBETerm.unembed - e7 cb a7 in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a71 - -> - let uu___26 - = - FStar_TypeChecker_NBETerm.unembed - e8 cb a8 in - FStar_Compiler_Util.bind_opt - uu___26 - (fun a81 - -> - let uu___27 - = - FStar_TypeChecker_NBETerm.unembed - e9 cb a9 in - FStar_Compiler_Util.bind_opt - uu___27 - (fun a91 - -> - let uu___28 - = - FStar_TypeChecker_NBETerm.unembed - e10 cb - a10 in - FStar_Compiler_Util.bind_opt - uu___28 - (fun a101 - -> - let uu___29 - = - FStar_TypeChecker_NBETerm.unembed - e11 cb - a11 in - FStar_Compiler_Util.bind_opt - uu___29 - (fun a111 - -> - let uu___30 - = - FStar_TypeChecker_NBETerm.unembed - e12 cb - a12 in - FStar_Compiler_Util.bind_opt - uu___30 - (fun a121 - -> - let uu___31 - = - FStar_TypeChecker_NBETerm.unembed - e13 cb - a13 in - FStar_Compiler_Util.bind_opt - uu___31 - (fun a131 - -> - let uu___32 - = - FStar_TypeChecker_NBETerm.unembed - e14 cb - a14 in - FStar_Compiler_Util.bind_opt - uu___32 - (fun a141 - -> - let uu___33 - = - FStar_TypeChecker_NBETerm.unembed - e15 cb - a15 in - FStar_Compiler_Util.bind_opt - uu___33 - (fun a151 - -> - let uu___34 - = - FStar_TypeChecker_NBETerm.unembed - e16 cb - a16 in - FStar_Compiler_Util.bind_opt - uu___34 - (fun a161 - -> - let uu___35 - = - FStar_TypeChecker_NBETerm.unembed - e17 cb - a17 in - FStar_Compiler_Util.bind_opt - uu___35 - (fun a171 - -> - let uu___36 - = - FStar_TypeChecker_NBETerm.unembed - e18 cb - a18 in - FStar_Compiler_Util.bind_opt - uu___36 - (fun a181 - -> - let uu___37 - = - FStar_TypeChecker_NBETerm.unembed - FStar_Tactics_Embedding.e_proofstate_nbe - cb a19 in - FStar_Compiler_Util.bind_opt - uu___37 - (fun ps - -> - let r1 = - interp_ctx - name - (fun - uu___38 - -> - let uu___39 - = - t a110 - a21 a31 - a41 a51 - a61 a71 - a81 a91 - a101 a111 - a121 a131 - a141 a151 - a161 a171 - a181 in - FStar_Tactics_Monad.run_safe - uu___39 - ps) in - let uu___38 - = - FStar_TypeChecker_NBETerm.embed - (FStar_Tactics_Embedding.e_result_nbe - er) cb r1 in - FStar_Pervasives_Native.Some - uu___38))))))))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_tactic_nbe_interpretation_19 : - 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't18 't19 't2 't3 't4 't5 - 't6 't7 't8 't9 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> - 't10 -> - 't11 -> - 't12 -> - 't13 -> - 't14 -> - 't15 -> - 't16 -> - 't17 -> - 't18 -> - 't19 -> - 'r FStar_Tactics_Monad.tac) - -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 't6 FStar_TypeChecker_NBETerm.embedding -> - 't7 FStar_TypeChecker_NBETerm.embedding -> - 't8 FStar_TypeChecker_NBETerm.embedding -> - 't9 FStar_TypeChecker_NBETerm.embedding -> - 't10 FStar_TypeChecker_NBETerm.embedding -> - 't11 FStar_TypeChecker_NBETerm.embedding -> - 't12 FStar_TypeChecker_NBETerm.embedding -> - 't13 FStar_TypeChecker_NBETerm.embedding -> - 't14 FStar_TypeChecker_NBETerm.embedding - -> - 't15 - FStar_TypeChecker_NBETerm.embedding - -> - 't16 - FStar_TypeChecker_NBETerm.embedding - -> - 't17 - FStar_TypeChecker_NBETerm.embedding - -> - 't18 - FStar_TypeChecker_NBETerm.embedding - -> - 't19 - FStar_TypeChecker_NBETerm.embedding - -> - 'r - FStar_TypeChecker_NBETerm.embedding - -> - FStar_Syntax_Syntax.universes - -> - FStar_TypeChecker_NBETerm.args - -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun e14 -> - fun e15 -> - fun e16 -> - fun e17 -> - fun e18 -> - fun e19 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, - uu___1):: - (a3, uu___2):: - (a4, uu___3):: - (a5, uu___4):: - (a6, uu___5):: - (a7, uu___6):: - (a8, uu___7):: - (a9, uu___8):: - (a10, uu___9):: - (a11, uu___10):: - (a12, uu___11):: - (a13, uu___12):: - (a14, uu___13):: - (a15, uu___14):: - (a16, uu___15):: - (a17, uu___16):: - (a18, uu___17):: - (a19, uu___18):: - (a20, uu___19)::[] -> - let uu___20 = - FStar_TypeChecker_NBETerm.unembed - e1 cb a1 in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a110 -> - let uu___21 = - FStar_TypeChecker_NBETerm.unembed - e2 cb a2 in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a21 -> - let uu___22 - = - FStar_TypeChecker_NBETerm.unembed - e3 cb a3 in - FStar_Compiler_Util.bind_opt - uu___22 - ( - fun a31 - -> - let uu___23 - = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a41 - -> - let uu___24 - = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a51 - -> - let uu___25 - = - FStar_TypeChecker_NBETerm.unembed - e6 cb a6 in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a61 - -> - let uu___26 - = - FStar_TypeChecker_NBETerm.unembed - e7 cb a7 in - FStar_Compiler_Util.bind_opt - uu___26 - (fun a71 - -> - let uu___27 - = - FStar_TypeChecker_NBETerm.unembed - e8 cb a8 in - FStar_Compiler_Util.bind_opt - uu___27 - (fun a81 - -> - let uu___28 - = - FStar_TypeChecker_NBETerm.unembed - e9 cb a9 in - FStar_Compiler_Util.bind_opt - uu___28 - (fun a91 - -> - let uu___29 - = - FStar_TypeChecker_NBETerm.unembed - e10 cb - a10 in - FStar_Compiler_Util.bind_opt - uu___29 - (fun a101 - -> - let uu___30 - = - FStar_TypeChecker_NBETerm.unembed - e11 cb - a11 in - FStar_Compiler_Util.bind_opt - uu___30 - (fun a111 - -> - let uu___31 - = - FStar_TypeChecker_NBETerm.unembed - e12 cb - a12 in - FStar_Compiler_Util.bind_opt - uu___31 - (fun a121 - -> - let uu___32 - = - FStar_TypeChecker_NBETerm.unembed - e13 cb - a13 in - FStar_Compiler_Util.bind_opt - uu___32 - (fun a131 - -> - let uu___33 - = - FStar_TypeChecker_NBETerm.unembed - e14 cb - a14 in - FStar_Compiler_Util.bind_opt - uu___33 - (fun a141 - -> - let uu___34 - = - FStar_TypeChecker_NBETerm.unembed - e15 cb - a15 in - FStar_Compiler_Util.bind_opt - uu___34 - (fun a151 - -> - let uu___35 - = - FStar_TypeChecker_NBETerm.unembed - e16 cb - a16 in - FStar_Compiler_Util.bind_opt - uu___35 - (fun a161 - -> - let uu___36 - = - FStar_TypeChecker_NBETerm.unembed - e17 cb - a17 in - FStar_Compiler_Util.bind_opt - uu___36 - (fun a171 - -> - let uu___37 - = - FStar_TypeChecker_NBETerm.unembed - e18 cb - a18 in - FStar_Compiler_Util.bind_opt - uu___37 - (fun a181 - -> - let uu___38 - = - FStar_TypeChecker_NBETerm.unembed - e19 cb - a19 in - FStar_Compiler_Util.bind_opt - uu___38 - (fun a191 - -> - let uu___39 - = - FStar_TypeChecker_NBETerm.unembed - FStar_Tactics_Embedding.e_proofstate_nbe - cb a20 in - FStar_Compiler_Util.bind_opt - uu___39 - (fun ps - -> - let r1 = - interp_ctx - name - (fun - uu___40 - -> - let uu___41 - = - t a110 - a21 a31 - a41 a51 - a61 a71 - a81 a91 - a101 a111 - a121 a131 - a141 a151 - a161 a171 - a181 a191 in - FStar_Tactics_Monad.run_safe - uu___41 - ps) in - let uu___40 - = - FStar_TypeChecker_NBETerm.embed - (FStar_Tactics_Embedding.e_result_nbe - er) cb r1 in - FStar_Pervasives_Native.Some - uu___40)))))))))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_tactic_nbe_interpretation_20 : - 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't18 't19 't2 't20 't3 't4 - 't5 't6 't7 't8 't9 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> - 't10 -> - 't11 -> - 't12 -> - 't13 -> - 't14 -> - 't15 -> - 't16 -> - 't17 -> - 't18 -> - 't19 -> - 't20 -> - 'r FStar_Tactics_Monad.tac) - -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 't6 FStar_TypeChecker_NBETerm.embedding -> - 't7 FStar_TypeChecker_NBETerm.embedding -> - 't8 FStar_TypeChecker_NBETerm.embedding -> - 't9 FStar_TypeChecker_NBETerm.embedding -> - 't10 FStar_TypeChecker_NBETerm.embedding -> - 't11 FStar_TypeChecker_NBETerm.embedding -> - 't12 FStar_TypeChecker_NBETerm.embedding -> - 't13 FStar_TypeChecker_NBETerm.embedding -> - 't14 FStar_TypeChecker_NBETerm.embedding - -> - 't15 - FStar_TypeChecker_NBETerm.embedding - -> - 't16 - FStar_TypeChecker_NBETerm.embedding - -> - 't17 - FStar_TypeChecker_NBETerm.embedding - -> - 't18 - FStar_TypeChecker_NBETerm.embedding - -> - 't19 - FStar_TypeChecker_NBETerm.embedding - -> - 't20 - FStar_TypeChecker_NBETerm.embedding - -> - 'r - FStar_TypeChecker_NBETerm.embedding - -> - FStar_Syntax_Syntax.universes - -> - FStar_TypeChecker_NBETerm.args - -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun t -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun e14 -> - fun e15 -> - fun e16 -> - fun e17 -> - fun e18 -> - fun e19 -> - fun e20 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___):: - (a2, uu___1):: - (a3, uu___2):: - (a4, uu___3):: - (a5, uu___4):: - (a6, uu___5):: - (a7, uu___6):: - (a8, uu___7):: - (a9, uu___8):: - (a10, uu___9):: - (a11, uu___10):: - (a12, uu___11):: - (a13, uu___12):: - (a14, uu___13):: - (a15, uu___14):: - (a16, uu___15):: - (a17, uu___16):: - (a18, uu___17):: - (a19, uu___18):: - (a20, uu___19):: - (a21, uu___20)::[] - -> - let uu___21 = - FStar_TypeChecker_NBETerm.unembed - e1 cb a1 in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a110 -> - let uu___22 = - FStar_TypeChecker_NBETerm.unembed - e2 cb a2 in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a22 -> - let uu___23 - = - FStar_TypeChecker_NBETerm.unembed - e3 cb a3 in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a31 - -> - let uu___24 - = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a41 - -> - let uu___25 - = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a51 - -> - let uu___26 - = - FStar_TypeChecker_NBETerm.unembed - e6 cb a6 in - FStar_Compiler_Util.bind_opt - uu___26 - (fun a61 - -> - let uu___27 - = - FStar_TypeChecker_NBETerm.unembed - e7 cb a7 in - FStar_Compiler_Util.bind_opt - uu___27 - (fun a71 - -> - let uu___28 - = - FStar_TypeChecker_NBETerm.unembed - e8 cb a8 in - FStar_Compiler_Util.bind_opt - uu___28 - (fun a81 - -> - let uu___29 - = - FStar_TypeChecker_NBETerm.unembed - e9 cb a9 in - FStar_Compiler_Util.bind_opt - uu___29 - (fun a91 - -> - let uu___30 - = - FStar_TypeChecker_NBETerm.unembed - e10 cb - a10 in - FStar_Compiler_Util.bind_opt - uu___30 - (fun a101 - -> - let uu___31 - = - FStar_TypeChecker_NBETerm.unembed - e11 cb - a11 in - FStar_Compiler_Util.bind_opt - uu___31 - (fun a111 - -> - let uu___32 - = - FStar_TypeChecker_NBETerm.unembed - e12 cb - a12 in - FStar_Compiler_Util.bind_opt - uu___32 - (fun a121 - -> - let uu___33 - = - FStar_TypeChecker_NBETerm.unembed - e13 cb - a13 in - FStar_Compiler_Util.bind_opt - uu___33 - (fun a131 - -> - let uu___34 - = - FStar_TypeChecker_NBETerm.unembed - e14 cb - a14 in - FStar_Compiler_Util.bind_opt - uu___34 - (fun a141 - -> - let uu___35 - = - FStar_TypeChecker_NBETerm.unembed - e15 cb - a15 in - FStar_Compiler_Util.bind_opt - uu___35 - (fun a151 - -> - let uu___36 - = - FStar_TypeChecker_NBETerm.unembed - e16 cb - a16 in - FStar_Compiler_Util.bind_opt - uu___36 - (fun a161 - -> - let uu___37 - = - FStar_TypeChecker_NBETerm.unembed - e17 cb - a17 in - FStar_Compiler_Util.bind_opt - uu___37 - (fun a171 - -> - let uu___38 - = - FStar_TypeChecker_NBETerm.unembed - e18 cb - a18 in - FStar_Compiler_Util.bind_opt - uu___38 - (fun a181 - -> - let uu___39 - = - FStar_TypeChecker_NBETerm.unembed - e19 cb - a19 in - FStar_Compiler_Util.bind_opt - uu___39 - (fun a191 - -> - let uu___40 - = - FStar_TypeChecker_NBETerm.unembed - e20 cb - a20 in - FStar_Compiler_Util.bind_opt - uu___40 - (fun a201 - -> - let uu___41 - = - FStar_TypeChecker_NBETerm.unembed - FStar_Tactics_Embedding.e_proofstate_nbe - cb a21 in - FStar_Compiler_Util.bind_opt - uu___41 - (fun ps - -> - let r1 = - interp_ctx - name - (fun - uu___42 - -> - let uu___43 - = - t a110 - a22 a31 - a41 a51 - a61 a71 - a81 a91 - a101 a111 - a121 a131 - a141 a151 - a161 a171 - a181 a191 - a201 in - FStar_Tactics_Monad.run_safe - uu___43 - ps) in - let uu___42 - = - FStar_TypeChecker_NBETerm.embed - (FStar_Tactics_Embedding.e_result_nbe - er) cb r1 in - FStar_Pervasives_Native.Some - uu___42))))))))))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_total_interpretation_1 : - 'r 't1 . - Prims.string -> - ('t1 -> 'r) -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option - = - fun name -> - fun f -> - fun e1 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::[] -> - let uu___1 = unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt uu___1 - (fun a11 -> - let r1 = interp_ctx name (fun uu___2 -> f a11) in - let uu___2 = - let uu___3 = - FStar_TypeChecker_Primops_Base.psc_range psc in - embed er uu___3 r1 ncb in - FStar_Pervasives_Native.Some uu___2) - | uu___ -> FStar_Pervasives_Native.None -let mk_total_interpretation_2 : - 'r 't1 't2 . - Prims.string -> - ('t1 -> 't2 -> 'r) -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option - = - fun name -> - fun f -> - fun e1 -> - fun e2 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::[] -> - let uu___2 = unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt uu___2 - (fun a11 -> - let uu___3 = unembed e2 a2 ncb in - FStar_Compiler_Util.bind_opt uu___3 - (fun a21 -> - let r1 = - interp_ctx name (fun uu___4 -> f a11 a21) in - let uu___4 = - let uu___5 = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed er uu___5 r1 ncb in - FStar_Pervasives_Native.Some uu___4)) - | uu___ -> FStar_Pervasives_Native.None -let mk_total_interpretation_3 : - 'r 't1 't2 't3 . - Prims.string -> - ('t1 -> 't2 -> 't3 -> 'r) -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2)::[] -> - let uu___3 = unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt uu___3 - (fun a11 -> - let uu___4 = unembed e2 a2 ncb in - FStar_Compiler_Util.bind_opt uu___4 - (fun a21 -> - let uu___5 = unembed e3 a3 ncb in - FStar_Compiler_Util.bind_opt uu___5 - (fun a31 -> - let r1 = - interp_ctx name - (fun uu___6 -> f a11 a21 a31) in - let uu___6 = - let uu___7 = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed er uu___7 r1 ncb in - FStar_Pervasives_Native.Some uu___6))) - | uu___ -> FStar_Pervasives_Native.None -let mk_total_interpretation_4 : - 'r 't1 't2 't3 't4 . - Prims.string -> - ('t1 -> 't2 -> 't3 -> 't4 -> 'r) -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2)::(a4, - uu___3)::[] - -> - let uu___4 = unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt uu___4 - (fun a11 -> - let uu___5 = unembed e2 a2 ncb in - FStar_Compiler_Util.bind_opt uu___5 - (fun a21 -> - let uu___6 = unembed e3 a3 ncb in - FStar_Compiler_Util.bind_opt uu___6 - (fun a31 -> - let uu___7 = unembed e4 a4 ncb in - FStar_Compiler_Util.bind_opt - uu___7 - (fun a41 -> - let r1 = - interp_ctx name - (fun uu___8 -> - f a11 a21 a31 a41) in - let uu___8 = - let uu___9 = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed er uu___9 r1 ncb in - FStar_Pervasives_Native.Some - uu___8)))) - | uu___ -> FStar_Pervasives_Native.None -let mk_total_interpretation_5 : - 'r 't1 't2 't3 't4 't5 . - Prims.string -> - ('t1 -> 't2 -> 't3 -> 't4 -> 't5 -> 'r) -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: - (a4, uu___3)::(a5, uu___4)::[] -> - let uu___5 = unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt uu___5 - (fun a11 -> - let uu___6 = unembed e2 a2 ncb in - FStar_Compiler_Util.bind_opt uu___6 - (fun a21 -> - let uu___7 = unembed e3 a3 ncb in - FStar_Compiler_Util.bind_opt uu___7 - (fun a31 -> - let uu___8 = unembed e4 a4 ncb in - FStar_Compiler_Util.bind_opt - uu___8 - (fun a41 -> - let uu___9 = - unembed e5 a5 ncb in - FStar_Compiler_Util.bind_opt - uu___9 - (fun a51 -> - let r1 = - interp_ctx name - (fun uu___10 -> - f a11 a21 a31 - a41 a51) in - let uu___10 = - let uu___11 = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed er uu___11 r1 - ncb in - FStar_Pervasives_Native.Some - uu___10))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_total_interpretation_6 : - 'r 't1 't2 't3 't4 't5 't6 . - Prims.string -> - ('t1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 'r) -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 't6 FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: - (a4, uu___3)::(a5, uu___4)::(a6, uu___5)::[] - -> - let uu___6 = unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt uu___6 - (fun a11 -> - let uu___7 = unembed e2 a2 ncb in - FStar_Compiler_Util.bind_opt uu___7 - (fun a21 -> - let uu___8 = unembed e3 a3 ncb in - FStar_Compiler_Util.bind_opt uu___8 - (fun a31 -> - let uu___9 = unembed e4 a4 ncb in - FStar_Compiler_Util.bind_opt - uu___9 - (fun a41 -> - let uu___10 = - unembed e5 a5 ncb in - FStar_Compiler_Util.bind_opt - uu___10 - (fun a51 -> - let uu___11 = - unembed e6 a6 ncb in - FStar_Compiler_Util.bind_opt - uu___11 - (fun a61 -> - let r1 = - interp_ctx - name - (fun - uu___12 - -> - f a11 a21 - a31 a41 - a51 a61) in - let uu___12 = - let uu___13 = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed er - uu___13 r1 - ncb in - FStar_Pervasives_Native.Some - uu___12)))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_total_interpretation_7 : - 'r 't1 't2 't3 't4 't5 't6 't7 . - Prims.string -> - ('t1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 'r) -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 't6 FStar_Syntax_Embeddings_Base.embedding -> - 't7 FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: - (a4, uu___3)::(a5, uu___4)::(a6, uu___5):: - (a7, uu___6)::[] -> - let uu___7 = unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt uu___7 - (fun a11 -> - let uu___8 = unembed e2 a2 ncb in - FStar_Compiler_Util.bind_opt uu___8 - (fun a21 -> - let uu___9 = unembed e3 a3 ncb in - FStar_Compiler_Util.bind_opt - uu___9 - (fun a31 -> - let uu___10 = - unembed e4 a4 ncb in - FStar_Compiler_Util.bind_opt - uu___10 - (fun a41 -> - let uu___11 = - unembed e5 a5 ncb in - FStar_Compiler_Util.bind_opt - uu___11 - (fun a51 -> - let uu___12 = - unembed e6 a6 - ncb in - FStar_Compiler_Util.bind_opt - uu___12 - (fun a61 -> - let uu___13 = - unembed e7 - a7 ncb in - FStar_Compiler_Util.bind_opt - uu___13 - (fun a71 -> - let r1 = - interp_ctx - name - (fun - uu___14 - -> - f a11 a21 - a31 a41 - a51 a61 - a71) in - let uu___14 - = - let uu___15 - = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed er - uu___15 - r1 ncb in - FStar_Pervasives_Native.Some - uu___14))))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_total_interpretation_8 : - 'r 't1 't2 't3 't4 't5 't6 't7 't8 . - Prims.string -> - ('t1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 'r) -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 't6 FStar_Syntax_Embeddings_Base.embedding -> - 't7 FStar_Syntax_Embeddings_Base.embedding -> - 't8 FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: - (a4, uu___3)::(a5, uu___4)::(a6, uu___5):: - (a7, uu___6)::(a8, uu___7)::[] -> - let uu___8 = unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt uu___8 - (fun a11 -> - let uu___9 = unembed e2 a2 ncb in - FStar_Compiler_Util.bind_opt uu___9 - (fun a21 -> - let uu___10 = unembed e3 a3 ncb in - FStar_Compiler_Util.bind_opt - uu___10 - (fun a31 -> - let uu___11 = - unembed e4 a4 ncb in - FStar_Compiler_Util.bind_opt - uu___11 - (fun a41 -> - let uu___12 = - unembed e5 a5 ncb in - FStar_Compiler_Util.bind_opt - uu___12 - (fun a51 -> - let uu___13 = - unembed e6 a6 - ncb in - FStar_Compiler_Util.bind_opt - uu___13 - (fun a61 -> - let uu___14 - = - unembed - e7 a7 ncb in - FStar_Compiler_Util.bind_opt - uu___14 - ( - fun a71 - -> - let uu___15 - = - unembed - e8 a8 ncb in - FStar_Compiler_Util.bind_opt - uu___15 - (fun a81 - -> - let r1 = - interp_ctx - name - (fun - uu___16 - -> - f a11 a21 - a31 a41 - a51 a61 - a71 a81) in - let uu___16 - = - let uu___17 - = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed er - uu___17 - r1 ncb in - FStar_Pervasives_Native.Some - uu___16)))))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_total_interpretation_9 : - 'r 't1 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - ('t1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 'r) -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 't6 FStar_Syntax_Embeddings_Base.embedding -> - 't7 FStar_Syntax_Embeddings_Base.embedding -> - 't8 FStar_Syntax_Embeddings_Base.embedding -> - 't9 FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: - (a4, uu___3)::(a5, uu___4)::(a6, - uu___5):: - (a7, uu___6)::(a8, uu___7)::(a9, - uu___8)::[] - -> - let uu___9 = unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt uu___9 - (fun a11 -> - let uu___10 = unembed e2 a2 ncb in - FStar_Compiler_Util.bind_opt - uu___10 - (fun a21 -> - let uu___11 = - unembed e3 a3 ncb in - FStar_Compiler_Util.bind_opt - uu___11 - (fun a31 -> - let uu___12 = - unembed e4 a4 ncb in - FStar_Compiler_Util.bind_opt - uu___12 - (fun a41 -> - let uu___13 = - unembed e5 a5 ncb in - FStar_Compiler_Util.bind_opt - uu___13 - (fun a51 -> - let uu___14 = - unembed e6 - a6 ncb in - FStar_Compiler_Util.bind_opt - uu___14 - (fun a61 -> - let uu___15 - = - unembed - e7 a7 ncb in - FStar_Compiler_Util.bind_opt - uu___15 - (fun a71 - -> - let uu___16 - = - unembed - e8 a8 ncb in - FStar_Compiler_Util.bind_opt - uu___16 - (fun a81 - -> - let uu___17 - = - unembed - e9 a9 ncb in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a91 - -> - let r1 = - interp_ctx - name - (fun - uu___18 - -> - f a11 a21 - a31 a41 - a51 a61 - a71 a81 - a91) in - let uu___18 - = - let uu___19 - = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed er - uu___19 - r1 ncb in - FStar_Pervasives_Native.Some - uu___18))))))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_total_interpretation_10 : - 'r 't1 't10 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - ('t1 -> - 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 'r) - -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 't6 FStar_Syntax_Embeddings_Base.embedding -> - 't7 FStar_Syntax_Embeddings_Base.embedding -> - 't8 FStar_Syntax_Embeddings_Base.embedding -> - 't9 FStar_Syntax_Embeddings_Base.embedding -> - 't10 FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: - (a4, uu___3)::(a5, uu___4)::(a6, - uu___5):: - (a7, uu___6)::(a8, uu___7)::(a9, - uu___8):: - (a10, uu___9)::[] -> - let uu___10 = unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt uu___10 - (fun a11 -> - let uu___11 = unembed e2 a2 ncb in - FStar_Compiler_Util.bind_opt - uu___11 - (fun a21 -> - let uu___12 = - unembed e3 a3 ncb in - FStar_Compiler_Util.bind_opt - uu___12 - (fun a31 -> - let uu___13 = - unembed e4 a4 ncb in - FStar_Compiler_Util.bind_opt - uu___13 - (fun a41 -> - let uu___14 = - unembed e5 a5 - ncb in - FStar_Compiler_Util.bind_opt - uu___14 - (fun a51 -> - let uu___15 - = - unembed e6 - a6 ncb in - FStar_Compiler_Util.bind_opt - uu___15 - (fun a61 - -> - let uu___16 - = - unembed - e7 a7 ncb in - FStar_Compiler_Util.bind_opt - uu___16 - (fun a71 - -> - let uu___17 - = - unembed - e8 a8 ncb in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a81 - -> - let uu___18 - = - unembed - e9 a9 ncb in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a91 - -> - let uu___19 - = - unembed - e10 a10 - ncb in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a101 - -> - let r1 = - interp_ctx - name - (fun - uu___20 - -> - f a11 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101) in - let uu___20 - = - let uu___21 - = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed er - uu___21 - r1 ncb in - FStar_Pervasives_Native.Some - uu___20)))))))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_total_interpretation_11 : - 'r 't1 't10 't11 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 'r) - -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 't6 FStar_Syntax_Embeddings_Base.embedding -> - 't7 FStar_Syntax_Embeddings_Base.embedding -> - 't8 FStar_Syntax_Embeddings_Base.embedding -> - 't9 FStar_Syntax_Embeddings_Base.embedding -> - 't10 FStar_Syntax_Embeddings_Base.embedding -> - 't11 FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, - uu___2):: - (a4, uu___3)::(a5, uu___4):: - (a6, uu___5)::(a7, uu___6):: - (a8, uu___7)::(a9, uu___8):: - (a10, uu___9)::(a11, uu___10)::[] - -> - let uu___11 = unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt - uu___11 - (fun a12 -> - let uu___12 = - unembed e2 a2 ncb in - FStar_Compiler_Util.bind_opt - uu___12 - (fun a21 -> - let uu___13 = - unembed e3 a3 ncb in - FStar_Compiler_Util.bind_opt - uu___13 - (fun a31 -> - let uu___14 = - unembed e4 a4 ncb in - FStar_Compiler_Util.bind_opt - uu___14 - (fun a41 -> - let uu___15 = - unembed e5 a5 - ncb in - FStar_Compiler_Util.bind_opt - uu___15 - (fun a51 -> - let uu___16 - = - unembed - e6 a6 ncb in - FStar_Compiler_Util.bind_opt - uu___16 - (fun a61 - -> - let uu___17 - = - unembed - e7 a7 ncb in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a71 - -> - let uu___18 - = - unembed - e8 a8 ncb in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a81 - -> - let uu___19 - = - unembed - e9 a9 ncb in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a91 - -> - let uu___20 - = - unembed - e10 a10 - ncb in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a101 - -> - let uu___21 - = - unembed - e11 a11 - ncb in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a111 - -> - let r1 = - interp_ctx - name - (fun - uu___22 - -> - f a12 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 - a111) in - let uu___22 - = - let uu___23 - = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed er - uu___23 - r1 ncb in - FStar_Pervasives_Native.Some - uu___22))))))))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_total_interpretation_12 : - 'r 't1 't10 't11 't12 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 'r) - -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 't6 FStar_Syntax_Embeddings_Base.embedding -> - 't7 FStar_Syntax_Embeddings_Base.embedding -> - 't8 FStar_Syntax_Embeddings_Base.embedding -> - 't9 FStar_Syntax_Embeddings_Base.embedding -> - 't10 FStar_Syntax_Embeddings_Base.embedding -> - 't11 FStar_Syntax_Embeddings_Base.embedding -> - 't12 FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1):: - (a3, uu___2)::(a4, uu___3):: - (a5, uu___4)::(a6, uu___5):: - (a7, uu___6)::(a8, uu___7):: - (a9, uu___8)::(a10, uu___9):: - (a11, uu___10)::(a12, uu___11)::[] - -> - let uu___12 = unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt - uu___12 - (fun a13 -> - let uu___13 = - unembed e2 a2 ncb in - FStar_Compiler_Util.bind_opt - uu___13 - (fun a21 -> - let uu___14 = - unembed e3 a3 ncb in - FStar_Compiler_Util.bind_opt - uu___14 - (fun a31 -> - let uu___15 = - unembed e4 a4 - ncb in - FStar_Compiler_Util.bind_opt - uu___15 - (fun a41 -> - let uu___16 = - unembed e5 - a5 ncb in - FStar_Compiler_Util.bind_opt - uu___16 - (fun a51 -> - let uu___17 - = - unembed - e6 a6 ncb in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a61 - -> - let uu___18 - = - unembed - e7 a7 ncb in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a71 - -> - let uu___19 - = - unembed - e8 a8 ncb in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a81 - -> - let uu___20 - = - unembed - e9 a9 ncb in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a91 - -> - let uu___21 - = - unembed - e10 a10 - ncb in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a101 - -> - let uu___22 - = - unembed - e11 a11 - ncb in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a111 - -> - let uu___23 - = - unembed - e12 a12 - ncb in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a121 - -> - let r1 = - interp_ctx - name - (fun - uu___24 - -> - f a13 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 - a111 a121) in - let uu___24 - = - let uu___25 - = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed er - uu___25 - r1 ncb in - FStar_Pervasives_Native.Some - uu___24)))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_total_interpretation_13 : - 'r 't1 't10 't11 't12 't13 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 'r) - -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 't6 FStar_Syntax_Embeddings_Base.embedding -> - 't7 FStar_Syntax_Embeddings_Base.embedding -> - 't8 FStar_Syntax_Embeddings_Base.embedding -> - 't9 FStar_Syntax_Embeddings_Base.embedding -> - 't10 FStar_Syntax_Embeddings_Base.embedding -> - 't11 FStar_Syntax_Embeddings_Base.embedding -> - 't12 FStar_Syntax_Embeddings_Base.embedding -> - 't13 FStar_Syntax_Embeddings_Base.embedding - -> - 'r FStar_Syntax_Embeddings_Base.embedding - -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1):: - (a3, uu___2)::(a4, uu___3):: - (a5, uu___4)::(a6, uu___5):: - (a7, uu___6)::(a8, uu___7):: - (a9, uu___8)::(a10, uu___9):: - (a11, uu___10)::(a12, uu___11):: - (a13, uu___12)::[] -> - let uu___13 = unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt - uu___13 - (fun a14 -> - let uu___14 = - unembed e2 a2 ncb in - FStar_Compiler_Util.bind_opt - uu___14 - (fun a21 -> - let uu___15 = - unembed e3 a3 ncb in - FStar_Compiler_Util.bind_opt - uu___15 - (fun a31 -> - let uu___16 = - unembed e4 a4 - ncb in - FStar_Compiler_Util.bind_opt - uu___16 - (fun a41 -> - let uu___17 - = - unembed - e5 a5 ncb in - FStar_Compiler_Util.bind_opt - uu___17 - ( - fun a51 - -> - let uu___18 - = - unembed - e6 a6 ncb in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a61 - -> - let uu___19 - = - unembed - e7 a7 ncb in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a71 - -> - let uu___20 - = - unembed - e8 a8 ncb in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a81 - -> - let uu___21 - = - unembed - e9 a9 ncb in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a91 - -> - let uu___22 - = - unembed - e10 a10 - ncb in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a101 - -> - let uu___23 - = - unembed - e11 a11 - ncb in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a111 - -> - let uu___24 - = - unembed - e12 a12 - ncb in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a121 - -> - let uu___25 - = - unembed - e13 a13 - ncb in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a131 - -> - let r1 = - interp_ctx - name - (fun - uu___26 - -> - f a14 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 - a111 a121 - a131) in - let uu___26 - = - let uu___27 - = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed er - uu___27 - r1 ncb in - FStar_Pervasives_Native.Some - uu___26))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_total_interpretation_14 : - 'r 't1 't10 't11 't12 't13 't14 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 'r) - -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 't6 FStar_Syntax_Embeddings_Base.embedding -> - 't7 FStar_Syntax_Embeddings_Base.embedding -> - 't8 FStar_Syntax_Embeddings_Base.embedding -> - 't9 FStar_Syntax_Embeddings_Base.embedding -> - 't10 FStar_Syntax_Embeddings_Base.embedding -> - 't11 FStar_Syntax_Embeddings_Base.embedding -> - 't12 FStar_Syntax_Embeddings_Base.embedding -> - 't13 FStar_Syntax_Embeddings_Base.embedding - -> - 't14 FStar_Syntax_Embeddings_Base.embedding - -> - 'r FStar_Syntax_Embeddings_Base.embedding - -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb - -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun e14 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1):: - (a3, uu___2)::(a4, uu___3):: - (a5, uu___4)::(a6, uu___5):: - (a7, uu___6)::(a8, uu___7):: - (a9, uu___8)::(a10, uu___9):: - (a11, uu___10)::(a12, - uu___11):: - (a13, uu___12)::(a14, - uu___13)::[] - -> - let uu___14 = - unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt - uu___14 - (fun a15 -> - let uu___15 = - unembed e2 a2 ncb in - FStar_Compiler_Util.bind_opt - uu___15 - (fun a21 -> - let uu___16 = - unembed e3 a3 ncb in - FStar_Compiler_Util.bind_opt - uu___16 - (fun a31 -> - let uu___17 = - unembed e4 - a4 ncb in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a41 -> - let uu___18 - = - unembed - e5 a5 ncb in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a51 - -> - let uu___19 - = - unembed - e6 a6 ncb in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a61 - -> - let uu___20 - = - unembed - e7 a7 ncb in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a71 - -> - let uu___21 - = - unembed - e8 a8 ncb in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a81 - -> - let uu___22 - = - unembed - e9 a9 ncb in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a91 - -> - let uu___23 - = - unembed - e10 a10 - ncb in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a101 - -> - let uu___24 - = - unembed - e11 a11 - ncb in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a111 - -> - let uu___25 - = - unembed - e12 a12 - ncb in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a121 - -> - let uu___26 - = - unembed - e13 a13 - ncb in - FStar_Compiler_Util.bind_opt - uu___26 - (fun a131 - -> - let uu___27 - = - unembed - e14 a14 - ncb in - FStar_Compiler_Util.bind_opt - uu___27 - (fun a141 - -> - let r1 = - interp_ctx - name - (fun - uu___28 - -> - f a15 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 - a111 a121 - a131 a141) in - let uu___28 - = - let uu___29 - = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed er - uu___29 - r1 ncb in - FStar_Pervasives_Native.Some - uu___28)))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_total_interpretation_15 : - 'r 't1 't10 't11 't12 't13 't14 't15 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> - 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 'r) - -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 't6 FStar_Syntax_Embeddings_Base.embedding -> - 't7 FStar_Syntax_Embeddings_Base.embedding -> - 't8 FStar_Syntax_Embeddings_Base.embedding -> - 't9 FStar_Syntax_Embeddings_Base.embedding -> - 't10 FStar_Syntax_Embeddings_Base.embedding -> - 't11 FStar_Syntax_Embeddings_Base.embedding -> - 't12 FStar_Syntax_Embeddings_Base.embedding -> - 't13 FStar_Syntax_Embeddings_Base.embedding - -> - 't14 FStar_Syntax_Embeddings_Base.embedding - -> - 't15 - FStar_Syntax_Embeddings_Base.embedding - -> - 'r - FStar_Syntax_Embeddings_Base.embedding - -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb - -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun e14 -> - fun e15 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1):: - (a3, uu___2)::(a4, uu___3):: - (a5, uu___4)::(a6, uu___5):: - (a7, uu___6)::(a8, uu___7):: - (a9, uu___8)::(a10, uu___9):: - (a11, uu___10)::(a12, - uu___11):: - (a13, uu___12)::(a14, - uu___13):: - (a15, uu___14)::[] -> - let uu___15 = - unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt - uu___15 - (fun a16 -> - let uu___16 = - unembed e2 a2 ncb in - FStar_Compiler_Util.bind_opt - uu___16 - (fun a21 -> - let uu___17 = - unembed e3 a3 - ncb in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a31 -> - let uu___18 - = - unembed e4 - a4 ncb in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a41 - -> - let uu___19 - = - unembed - e5 a5 ncb in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a51 - -> - let uu___20 - = - unembed - e6 a6 ncb in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a61 - -> - let uu___21 - = - unembed - e7 a7 ncb in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a71 - -> - let uu___22 - = - unembed - e8 a8 ncb in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a81 - -> - let uu___23 - = - unembed - e9 a9 ncb in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a91 - -> - let uu___24 - = - unembed - e10 a10 - ncb in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a101 - -> - let uu___25 - = - unembed - e11 a11 - ncb in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a111 - -> - let uu___26 - = - unembed - e12 a12 - ncb in - FStar_Compiler_Util.bind_opt - uu___26 - (fun a121 - -> - let uu___27 - = - unembed - e13 a13 - ncb in - FStar_Compiler_Util.bind_opt - uu___27 - (fun a131 - -> - let uu___28 - = - unembed - e14 a14 - ncb in - FStar_Compiler_Util.bind_opt - uu___28 - (fun a141 - -> - let uu___29 - = - unembed - e15 a15 - ncb in - FStar_Compiler_Util.bind_opt - uu___29 - (fun a151 - -> - let r1 = - interp_ctx - name - (fun - uu___30 - -> - f a16 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 - a111 a121 - a131 a141 - a151) in - let uu___30 - = - let uu___31 - = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed er - uu___31 - r1 ncb in - FStar_Pervasives_Native.Some - uu___30))))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_total_interpretation_16 : - 'r 't1 't10 't11 't12 't13 't14 't15 't16 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> - 't10 -> - 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 'r) - -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 't6 FStar_Syntax_Embeddings_Base.embedding -> - 't7 FStar_Syntax_Embeddings_Base.embedding -> - 't8 FStar_Syntax_Embeddings_Base.embedding -> - 't9 FStar_Syntax_Embeddings_Base.embedding -> - 't10 FStar_Syntax_Embeddings_Base.embedding -> - 't11 FStar_Syntax_Embeddings_Base.embedding -> - 't12 FStar_Syntax_Embeddings_Base.embedding -> - 't13 FStar_Syntax_Embeddings_Base.embedding - -> - 't14 FStar_Syntax_Embeddings_Base.embedding - -> - 't15 - FStar_Syntax_Embeddings_Base.embedding - -> - 't16 - FStar_Syntax_Embeddings_Base.embedding - -> - 'r - FStar_Syntax_Embeddings_Base.embedding - -> - FStar_TypeChecker_Primops_Base.psc - -> - FStar_Syntax_Embeddings_Base.norm_cb - -> - FStar_Syntax_Syntax.universes - -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun e14 -> - fun e15 -> - fun e16 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1):: - (a3, uu___2)::(a4, - uu___3):: - (a5, uu___4)::(a6, - uu___5):: - (a7, uu___6)::(a8, - uu___7):: - (a9, uu___8)::(a10, - uu___9):: - (a11, uu___10)::(a12, - uu___11):: - (a13, uu___12)::(a14, - uu___13):: - (a15, uu___14)::(a16, - uu___15)::[] - -> - let uu___16 = - unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt - uu___16 - (fun a17 -> - let uu___17 = - unembed e2 a2 ncb in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a21 -> - let uu___18 = - unembed e3 a3 - ncb in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a31 -> - let uu___19 - = - unembed - e4 a4 ncb in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a41 - -> - let uu___20 - = - unembed - e5 a5 ncb in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a51 - -> - let uu___21 - = - unembed - e6 a6 ncb in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a61 - -> - let uu___22 - = - unembed - e7 a7 ncb in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a71 - -> - let uu___23 - = - unembed - e8 a8 ncb in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a81 - -> - let uu___24 - = - unembed - e9 a9 ncb in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a91 - -> - let uu___25 - = - unembed - e10 a10 - ncb in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a101 - -> - let uu___26 - = - unembed - e11 a11 - ncb in - FStar_Compiler_Util.bind_opt - uu___26 - (fun a111 - -> - let uu___27 - = - unembed - e12 a12 - ncb in - FStar_Compiler_Util.bind_opt - uu___27 - (fun a121 - -> - let uu___28 - = - unembed - e13 a13 - ncb in - FStar_Compiler_Util.bind_opt - uu___28 - (fun a131 - -> - let uu___29 - = - unembed - e14 a14 - ncb in - FStar_Compiler_Util.bind_opt - uu___29 - (fun a141 - -> - let uu___30 - = - unembed - e15 a15 - ncb in - FStar_Compiler_Util.bind_opt - uu___30 - (fun a151 - -> - let uu___31 - = - unembed - e16 a16 - ncb in - FStar_Compiler_Util.bind_opt - uu___31 - (fun a161 - -> - let r1 = - interp_ctx - name - (fun - uu___32 - -> - f a17 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 - a111 a121 - a131 a141 - a151 a161) in - let uu___32 - = - let uu___33 - = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed er - uu___33 - r1 ncb in - FStar_Pervasives_Native.Some - uu___32)))))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_total_interpretation_17 : - 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't2 't3 't4 't5 't6 't7 't8 - 't9 . - Prims.string -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> - 't10 -> - 't11 -> - 't12 -> - 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 'r) - -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 't6 FStar_Syntax_Embeddings_Base.embedding -> - 't7 FStar_Syntax_Embeddings_Base.embedding -> - 't8 FStar_Syntax_Embeddings_Base.embedding -> - 't9 FStar_Syntax_Embeddings_Base.embedding -> - 't10 FStar_Syntax_Embeddings_Base.embedding -> - 't11 FStar_Syntax_Embeddings_Base.embedding -> - 't12 FStar_Syntax_Embeddings_Base.embedding -> - 't13 FStar_Syntax_Embeddings_Base.embedding - -> - 't14 FStar_Syntax_Embeddings_Base.embedding - -> - 't15 - FStar_Syntax_Embeddings_Base.embedding - -> - 't16 - FStar_Syntax_Embeddings_Base.embedding - -> - 't17 - FStar_Syntax_Embeddings_Base.embedding - -> - 'r - FStar_Syntax_Embeddings_Base.embedding - -> - FStar_TypeChecker_Primops_Base.psc - -> - FStar_Syntax_Embeddings_Base.norm_cb - -> - FStar_Syntax_Syntax.universes - -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun e14 -> - fun e15 -> - fun e16 -> - fun e17 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1):: - (a3, uu___2)::(a4, - uu___3):: - (a5, uu___4)::(a6, - uu___5):: - (a7, uu___6)::(a8, - uu___7):: - (a9, uu___8)::(a10, - uu___9):: - (a11, uu___10):: - (a12, uu___11):: - (a13, uu___12):: - (a14, uu___13):: - (a15, uu___14):: - (a16, uu___15):: - (a17, uu___16)::[] -> - let uu___17 = - unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a18 -> - let uu___18 = - unembed e2 a2 - ncb in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a21 -> - let uu___19 = - unembed e3 - a3 ncb in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a31 -> - let uu___20 - = - unembed - e4 a4 ncb in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a41 - -> - let uu___21 - = - unembed - e5 a5 ncb in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a51 - -> - let uu___22 - = - unembed - e6 a6 ncb in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a61 - -> - let uu___23 - = - unembed - e7 a7 ncb in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a71 - -> - let uu___24 - = - unembed - e8 a8 ncb in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a81 - -> - let uu___25 - = - unembed - e9 a9 ncb in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a91 - -> - let uu___26 - = - unembed - e10 a10 - ncb in - FStar_Compiler_Util.bind_opt - uu___26 - (fun a101 - -> - let uu___27 - = - unembed - e11 a11 - ncb in - FStar_Compiler_Util.bind_opt - uu___27 - (fun a111 - -> - let uu___28 - = - unembed - e12 a12 - ncb in - FStar_Compiler_Util.bind_opt - uu___28 - (fun a121 - -> - let uu___29 - = - unembed - e13 a13 - ncb in - FStar_Compiler_Util.bind_opt - uu___29 - (fun a131 - -> - let uu___30 - = - unembed - e14 a14 - ncb in - FStar_Compiler_Util.bind_opt - uu___30 - (fun a141 - -> - let uu___31 - = - unembed - e15 a15 - ncb in - FStar_Compiler_Util.bind_opt - uu___31 - (fun a151 - -> - let uu___32 - = - unembed - e16 a16 - ncb in - FStar_Compiler_Util.bind_opt - uu___32 - (fun a161 - -> - let uu___33 - = - unembed - e17 a17 - ncb in - FStar_Compiler_Util.bind_opt - uu___33 - (fun a171 - -> - let r1 = - interp_ctx - name - (fun - uu___34 - -> - f a18 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 - a111 a121 - a131 a141 - a151 a161 - a171) in - let uu___34 - = - let uu___35 - = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed er - uu___35 - r1 ncb in - FStar_Pervasives_Native.Some - uu___34))))))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_total_interpretation_18 : - 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't18 't2 't3 't4 't5 't6 't7 - 't8 't9 . - Prims.string -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> - 't10 -> - 't11 -> - 't12 -> - 't13 -> - 't14 -> 't15 -> 't16 -> 't17 -> 't18 -> 'r) - -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 't6 FStar_Syntax_Embeddings_Base.embedding -> - 't7 FStar_Syntax_Embeddings_Base.embedding -> - 't8 FStar_Syntax_Embeddings_Base.embedding -> - 't9 FStar_Syntax_Embeddings_Base.embedding -> - 't10 FStar_Syntax_Embeddings_Base.embedding -> - 't11 FStar_Syntax_Embeddings_Base.embedding -> - 't12 FStar_Syntax_Embeddings_Base.embedding -> - 't13 FStar_Syntax_Embeddings_Base.embedding - -> - 't14 FStar_Syntax_Embeddings_Base.embedding - -> - 't15 - FStar_Syntax_Embeddings_Base.embedding - -> - 't16 - FStar_Syntax_Embeddings_Base.embedding - -> - 't17 - FStar_Syntax_Embeddings_Base.embedding - -> - 't18 - FStar_Syntax_Embeddings_Base.embedding - -> - 'r - FStar_Syntax_Embeddings_Base.embedding - -> - FStar_TypeChecker_Primops_Base.psc - -> - FStar_Syntax_Embeddings_Base.norm_cb - -> - FStar_Syntax_Syntax.universes - -> - FStar_Syntax_Syntax.args - -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun e14 -> - fun e15 -> - fun e16 -> - fun e17 -> - fun e18 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, - uu___1):: - (a3, uu___2):: - (a4, uu___3):: - (a5, uu___4):: - (a6, uu___5):: - (a7, uu___6):: - (a8, uu___7):: - (a9, uu___8):: - (a10, uu___9):: - (a11, uu___10):: - (a12, uu___11):: - (a13, uu___12):: - (a14, uu___13):: - (a15, uu___14):: - (a16, uu___15):: - (a17, uu___16):: - (a18, uu___17)::[] -> - let uu___18 = - unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a19 -> - let uu___19 = - unembed e2 a2 - ncb in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a21 -> - let uu___20 - = - unembed - e3 a3 ncb in - FStar_Compiler_Util.bind_opt - uu___20 - ( - fun a31 - -> - let uu___21 - = - unembed - e4 a4 ncb in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a41 - -> - let uu___22 - = - unembed - e5 a5 ncb in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a51 - -> - let uu___23 - = - unembed - e6 a6 ncb in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a61 - -> - let uu___24 - = - unembed - e7 a7 ncb in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a71 - -> - let uu___25 - = - unembed - e8 a8 ncb in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a81 - -> - let uu___26 - = - unembed - e9 a9 ncb in - FStar_Compiler_Util.bind_opt - uu___26 - (fun a91 - -> - let uu___27 - = - unembed - e10 a10 - ncb in - FStar_Compiler_Util.bind_opt - uu___27 - (fun a101 - -> - let uu___28 - = - unembed - e11 a11 - ncb in - FStar_Compiler_Util.bind_opt - uu___28 - (fun a111 - -> - let uu___29 - = - unembed - e12 a12 - ncb in - FStar_Compiler_Util.bind_opt - uu___29 - (fun a121 - -> - let uu___30 - = - unembed - e13 a13 - ncb in - FStar_Compiler_Util.bind_opt - uu___30 - (fun a131 - -> - let uu___31 - = - unembed - e14 a14 - ncb in - FStar_Compiler_Util.bind_opt - uu___31 - (fun a141 - -> - let uu___32 - = - unembed - e15 a15 - ncb in - FStar_Compiler_Util.bind_opt - uu___32 - (fun a151 - -> - let uu___33 - = - unembed - e16 a16 - ncb in - FStar_Compiler_Util.bind_opt - uu___33 - (fun a161 - -> - let uu___34 - = - unembed - e17 a17 - ncb in - FStar_Compiler_Util.bind_opt - uu___34 - (fun a171 - -> - let uu___35 - = - unembed - e18 a18 - ncb in - FStar_Compiler_Util.bind_opt - uu___35 - (fun a181 - -> - let r1 = - interp_ctx - name - (fun - uu___36 - -> - f a19 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 - a111 a121 - a131 a141 - a151 a161 - a171 a181) in - let uu___36 - = - let uu___37 - = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed er - uu___37 - r1 ncb in - FStar_Pervasives_Native.Some - uu___36)))))))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_total_interpretation_19 : - 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't18 't19 't2 't3 't4 't5 - 't6 't7 't8 't9 . - Prims.string -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> - 't10 -> - 't11 -> - 't12 -> - 't13 -> - 't14 -> - 't15 -> 't16 -> 't17 -> 't18 -> 't19 -> 'r) - -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 't6 FStar_Syntax_Embeddings_Base.embedding -> - 't7 FStar_Syntax_Embeddings_Base.embedding -> - 't8 FStar_Syntax_Embeddings_Base.embedding -> - 't9 FStar_Syntax_Embeddings_Base.embedding -> - 't10 FStar_Syntax_Embeddings_Base.embedding -> - 't11 FStar_Syntax_Embeddings_Base.embedding -> - 't12 FStar_Syntax_Embeddings_Base.embedding -> - 't13 FStar_Syntax_Embeddings_Base.embedding - -> - 't14 FStar_Syntax_Embeddings_Base.embedding - -> - 't15 - FStar_Syntax_Embeddings_Base.embedding - -> - 't16 - FStar_Syntax_Embeddings_Base.embedding - -> - 't17 - FStar_Syntax_Embeddings_Base.embedding - -> - 't18 - FStar_Syntax_Embeddings_Base.embedding - -> - 't19 - FStar_Syntax_Embeddings_Base.embedding - -> - 'r - FStar_Syntax_Embeddings_Base.embedding - -> - FStar_TypeChecker_Primops_Base.psc - -> - FStar_Syntax_Embeddings_Base.norm_cb - -> - FStar_Syntax_Syntax.universes - -> - FStar_Syntax_Syntax.args - -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun e14 -> - fun e15 -> - fun e16 -> - fun e17 -> - fun e18 -> - fun e19 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___):: - (a2, uu___1):: - (a3, uu___2):: - (a4, uu___3):: - (a5, uu___4):: - (a6, uu___5):: - (a7, uu___6):: - (a8, uu___7):: - (a9, uu___8):: - (a10, uu___9):: - (a11, uu___10):: - (a12, uu___11):: - (a13, uu___12):: - (a14, uu___13):: - (a15, uu___14):: - (a16, uu___15):: - (a17, uu___16):: - (a18, uu___17):: - (a19, uu___18)::[] - -> - let uu___19 = - unembed e1 a1 ncb in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a110 -> - let uu___20 = - unembed e2 - a2 ncb in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a21 -> - let uu___21 - = - unembed - e3 a3 ncb in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a31 - -> - let uu___22 - = - unembed - e4 a4 ncb in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a41 - -> - let uu___23 - = - unembed - e5 a5 ncb in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a51 - -> - let uu___24 - = - unembed - e6 a6 ncb in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a61 - -> - let uu___25 - = - unembed - e7 a7 ncb in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a71 - -> - let uu___26 - = - unembed - e8 a8 ncb in - FStar_Compiler_Util.bind_opt - uu___26 - (fun a81 - -> - let uu___27 - = - unembed - e9 a9 ncb in - FStar_Compiler_Util.bind_opt - uu___27 - (fun a91 - -> - let uu___28 - = - unembed - e10 a10 - ncb in - FStar_Compiler_Util.bind_opt - uu___28 - (fun a101 - -> - let uu___29 - = - unembed - e11 a11 - ncb in - FStar_Compiler_Util.bind_opt - uu___29 - (fun a111 - -> - let uu___30 - = - unembed - e12 a12 - ncb in - FStar_Compiler_Util.bind_opt - uu___30 - (fun a121 - -> - let uu___31 - = - unembed - e13 a13 - ncb in - FStar_Compiler_Util.bind_opt - uu___31 - (fun a131 - -> - let uu___32 - = - unembed - e14 a14 - ncb in - FStar_Compiler_Util.bind_opt - uu___32 - (fun a141 - -> - let uu___33 - = - unembed - e15 a15 - ncb in - FStar_Compiler_Util.bind_opt - uu___33 - (fun a151 - -> - let uu___34 - = - unembed - e16 a16 - ncb in - FStar_Compiler_Util.bind_opt - uu___34 - (fun a161 - -> - let uu___35 - = - unembed - e17 a17 - ncb in - FStar_Compiler_Util.bind_opt - uu___35 - (fun a171 - -> - let uu___36 - = - unembed - e18 a18 - ncb in - FStar_Compiler_Util.bind_opt - uu___36 - (fun a181 - -> - let uu___37 - = - unembed - e19 a19 - ncb in - FStar_Compiler_Util.bind_opt - uu___37 - (fun a191 - -> - let r1 = - interp_ctx - name - (fun - uu___38 - -> - f a110 - a21 a31 - a41 a51 - a61 a71 - a81 a91 - a101 a111 - a121 a131 - a141 a151 - a161 a171 - a181 a191) in - let uu___38 - = - let uu___39 - = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed er - uu___39 - r1 ncb in - FStar_Pervasives_Native.Some - uu___38))))))))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_total_interpretation_20 : - 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't18 't19 't2 't20 't3 't4 - 't5 't6 't7 't8 't9 . - Prims.string -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> - 't10 -> - 't11 -> - 't12 -> - 't13 -> - 't14 -> - 't15 -> - 't16 -> - 't17 -> 't18 -> 't19 -> 't20 -> 'r) - -> - 't1 FStar_Syntax_Embeddings_Base.embedding -> - 't2 FStar_Syntax_Embeddings_Base.embedding -> - 't3 FStar_Syntax_Embeddings_Base.embedding -> - 't4 FStar_Syntax_Embeddings_Base.embedding -> - 't5 FStar_Syntax_Embeddings_Base.embedding -> - 't6 FStar_Syntax_Embeddings_Base.embedding -> - 't7 FStar_Syntax_Embeddings_Base.embedding -> - 't8 FStar_Syntax_Embeddings_Base.embedding -> - 't9 FStar_Syntax_Embeddings_Base.embedding -> - 't10 FStar_Syntax_Embeddings_Base.embedding -> - 't11 FStar_Syntax_Embeddings_Base.embedding -> - 't12 FStar_Syntax_Embeddings_Base.embedding -> - 't13 FStar_Syntax_Embeddings_Base.embedding - -> - 't14 FStar_Syntax_Embeddings_Base.embedding - -> - 't15 - FStar_Syntax_Embeddings_Base.embedding - -> - 't16 - FStar_Syntax_Embeddings_Base.embedding - -> - 't17 - FStar_Syntax_Embeddings_Base.embedding - -> - 't18 - FStar_Syntax_Embeddings_Base.embedding - -> - 't19 - FStar_Syntax_Embeddings_Base.embedding - -> - 't20 - FStar_Syntax_Embeddings_Base.embedding - -> - 'r - FStar_Syntax_Embeddings_Base.embedding - -> - FStar_TypeChecker_Primops_Base.psc - -> - FStar_Syntax_Embeddings_Base.norm_cb - -> - FStar_Syntax_Syntax.universes - -> - FStar_Syntax_Syntax.args - -> - FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option - = - fun name -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun e14 -> - fun e15 -> - fun e16 -> - fun e17 -> - fun e18 -> - fun e19 -> - fun e20 -> - fun er -> - fun psc -> - fun ncb -> - fun us -> - fun args -> - match args with - | (a1, uu___):: - (a2, uu___1):: - (a3, uu___2):: - (a4, uu___3):: - (a5, uu___4):: - (a6, uu___5):: - (a7, uu___6):: - (a8, uu___7):: - (a9, uu___8):: - (a10, uu___9):: - (a11, uu___10):: - (a12, uu___11):: - (a13, uu___12):: - (a14, uu___13):: - (a15, uu___14):: - (a16, uu___15):: - (a17, uu___16):: - (a18, uu___17):: - (a19, uu___18):: - (a20, uu___19)::[] - -> - let uu___20 = - unembed e1 a1 - ncb in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a110 -> - let uu___21 - = - unembed e2 - a2 ncb in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a21 - -> - let uu___22 - = - unembed - e3 a3 ncb in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a31 - -> - let uu___23 - = - unembed - e4 a4 ncb in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a41 - -> - let uu___24 - = - unembed - e5 a5 ncb in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a51 - -> - let uu___25 - = - unembed - e6 a6 ncb in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a61 - -> - let uu___26 - = - unembed - e7 a7 ncb in - FStar_Compiler_Util.bind_opt - uu___26 - (fun a71 - -> - let uu___27 - = - unembed - e8 a8 ncb in - FStar_Compiler_Util.bind_opt - uu___27 - (fun a81 - -> - let uu___28 - = - unembed - e9 a9 ncb in - FStar_Compiler_Util.bind_opt - uu___28 - (fun a91 - -> - let uu___29 - = - unembed - e10 a10 - ncb in - FStar_Compiler_Util.bind_opt - uu___29 - (fun a101 - -> - let uu___30 - = - unembed - e11 a11 - ncb in - FStar_Compiler_Util.bind_opt - uu___30 - (fun a111 - -> - let uu___31 - = - unembed - e12 a12 - ncb in - FStar_Compiler_Util.bind_opt - uu___31 - (fun a121 - -> - let uu___32 - = - unembed - e13 a13 - ncb in - FStar_Compiler_Util.bind_opt - uu___32 - (fun a131 - -> - let uu___33 - = - unembed - e14 a14 - ncb in - FStar_Compiler_Util.bind_opt - uu___33 - (fun a141 - -> - let uu___34 - = - unembed - e15 a15 - ncb in - FStar_Compiler_Util.bind_opt - uu___34 - (fun a151 - -> - let uu___35 - = - unembed - e16 a16 - ncb in - FStar_Compiler_Util.bind_opt - uu___35 - (fun a161 - -> - let uu___36 - = - unembed - e17 a17 - ncb in - FStar_Compiler_Util.bind_opt - uu___36 - (fun a171 - -> - let uu___37 - = - unembed - e18 a18 - ncb in - FStar_Compiler_Util.bind_opt - uu___37 - (fun a181 - -> - let uu___38 - = - unembed - e19 a19 - ncb in - FStar_Compiler_Util.bind_opt - uu___38 - (fun a191 - -> - let uu___39 - = - unembed - e20 a20 - ncb in - FStar_Compiler_Util.bind_opt - uu___39 - (fun a201 - -> - let r1 = - interp_ctx - name - (fun - uu___40 - -> - f a110 - a21 a31 - a41 a51 - a61 a71 - a81 a91 - a101 a111 - a121 a131 - a141 a151 - a161 a171 - a181 a191 - a201) in - let uu___40 - = - let uu___41 - = - FStar_TypeChecker_Primops_Base.psc_range - psc in - embed er - uu___41 - r1 ncb in - FStar_Pervasives_Native.Some - uu___40)))))))))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_total_nbe_interpretation_1 : - 'r 't1 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> 'r) -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun f -> - fun e1 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::[] -> - let uu___1 = FStar_TypeChecker_NBETerm.unembed e1 cb a1 in - FStar_Compiler_Util.bind_opt uu___1 - (fun a11 -> - let r1 = interp_ctx name (fun uu___2 -> f a11) in - let uu___2 = - FStar_TypeChecker_NBETerm.embed er cb r1 in - FStar_Pervasives_Native.Some uu___2) - | uu___ -> FStar_Pervasives_Native.None -let mk_total_nbe_interpretation_2 : - 'r 't1 't2 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> 't2 -> 'r) -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun f -> - fun e1 -> - fun e2 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::[] -> - let uu___2 = FStar_TypeChecker_NBETerm.unembed e1 cb a1 in - FStar_Compiler_Util.bind_opt uu___2 - (fun a11 -> - let uu___3 = - FStar_TypeChecker_NBETerm.unembed e2 cb a2 in - FStar_Compiler_Util.bind_opt uu___3 - (fun a21 -> - let r1 = - interp_ctx name (fun uu___4 -> f a11 a21) in - let uu___4 = - FStar_TypeChecker_NBETerm.embed er cb r1 in - FStar_Pervasives_Native.Some uu___4)) - | uu___ -> FStar_Pervasives_Native.None -let mk_total_nbe_interpretation_3 : - 'r 't1 't2 't3 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> 't2 -> 't3 -> 'r) -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2)::[] -> - let uu___3 = - FStar_TypeChecker_NBETerm.unembed e1 cb a1 in - FStar_Compiler_Util.bind_opt uu___3 - (fun a11 -> - let uu___4 = - FStar_TypeChecker_NBETerm.unembed e2 cb a2 in - FStar_Compiler_Util.bind_opt uu___4 - (fun a21 -> - let uu___5 = - FStar_TypeChecker_NBETerm.unembed e3 cb - a3 in - FStar_Compiler_Util.bind_opt uu___5 - (fun a31 -> - let r1 = - interp_ctx name - (fun uu___6 -> f a11 a21 a31) in - let uu___6 = - FStar_TypeChecker_NBETerm.embed er - cb r1 in - FStar_Pervasives_Native.Some uu___6))) - | uu___ -> FStar_Pervasives_Native.None -let mk_total_nbe_interpretation_4 : - 'r 't1 't2 't3 't4 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> 't2 -> 't3 -> 't4 -> 'r) -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2)::(a4, uu___3)::[] - -> - let uu___4 = - FStar_TypeChecker_NBETerm.unembed e1 cb a1 in - FStar_Compiler_Util.bind_opt uu___4 - (fun a11 -> - let uu___5 = - FStar_TypeChecker_NBETerm.unembed e2 cb a2 in - FStar_Compiler_Util.bind_opt uu___5 - (fun a21 -> - let uu___6 = - FStar_TypeChecker_NBETerm.unembed e3 cb - a3 in - FStar_Compiler_Util.bind_opt uu___6 - (fun a31 -> - let uu___7 = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt uu___7 - (fun a41 -> - let r1 = - interp_ctx name - (fun uu___8 -> - f a11 a21 a31 a41) in - let uu___8 = - FStar_TypeChecker_NBETerm.embed - er cb r1 in - FStar_Pervasives_Native.Some - uu___8)))) - | uu___ -> FStar_Pervasives_Native.None -let mk_total_nbe_interpretation_5 : - 'r 't1 't2 't3 't4 't5 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> 't2 -> 't3 -> 't4 -> 't5 -> 'r) -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2)::(a4, - uu___3):: - (a5, uu___4)::[] -> - let uu___5 = - FStar_TypeChecker_NBETerm.unembed e1 cb a1 in - FStar_Compiler_Util.bind_opt uu___5 - (fun a11 -> - let uu___6 = - FStar_TypeChecker_NBETerm.unembed e2 cb a2 in - FStar_Compiler_Util.bind_opt uu___6 - (fun a21 -> - let uu___7 = - FStar_TypeChecker_NBETerm.unembed e3 - cb a3 in - FStar_Compiler_Util.bind_opt uu___7 - (fun a31 -> - let uu___8 = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___8 - (fun a41 -> - let uu___9 = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___9 - (fun a51 -> - let r1 = - interp_ctx name - (fun uu___10 -> - f a11 a21 a31 a41 - a51) in - let uu___10 = - FStar_TypeChecker_NBETerm.embed - er cb r1 in - FStar_Pervasives_Native.Some - uu___10))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_total_nbe_interpretation_6 : - 'r 't1 't2 't3 't4 't5 't6 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 'r) -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 't6 FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: - (a4, uu___3)::(a5, uu___4)::(a6, uu___5)::[] -> - let uu___6 = - FStar_TypeChecker_NBETerm.unembed e1 cb a1 in - FStar_Compiler_Util.bind_opt uu___6 - (fun a11 -> - let uu___7 = - FStar_TypeChecker_NBETerm.unembed e2 cb - a2 in - FStar_Compiler_Util.bind_opt uu___7 - (fun a21 -> - let uu___8 = - FStar_TypeChecker_NBETerm.unembed - e3 cb a3 in - FStar_Compiler_Util.bind_opt uu___8 - (fun a31 -> - let uu___9 = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___9 - (fun a41 -> - let uu___10 = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___10 - (fun a51 -> - let uu___11 = - FStar_TypeChecker_NBETerm.unembed - e6 cb a6 in - FStar_Compiler_Util.bind_opt - uu___11 - (fun a61 -> - let r1 = - interp_ctx name - (fun uu___12 - -> - f a11 a21 - a31 a41 - a51 a61) in - let uu___12 = - FStar_TypeChecker_NBETerm.embed - er cb r1 in - FStar_Pervasives_Native.Some - uu___12)))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_total_nbe_interpretation_7 : - 'r 't1 't2 't3 't4 't5 't6 't7 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 'r) -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 't6 FStar_TypeChecker_NBETerm.embedding -> - 't7 FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: - (a4, uu___3)::(a5, uu___4)::(a6, uu___5):: - (a7, uu___6)::[] -> - let uu___7 = - FStar_TypeChecker_NBETerm.unembed e1 cb a1 in - FStar_Compiler_Util.bind_opt uu___7 - (fun a11 -> - let uu___8 = - FStar_TypeChecker_NBETerm.unembed e2 - cb a2 in - FStar_Compiler_Util.bind_opt uu___8 - (fun a21 -> - let uu___9 = - FStar_TypeChecker_NBETerm.unembed - e3 cb a3 in - FStar_Compiler_Util.bind_opt uu___9 - (fun a31 -> - let uu___10 = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___10 - (fun a41 -> - let uu___11 = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___11 - (fun a51 -> - let uu___12 = - FStar_TypeChecker_NBETerm.unembed - e6 cb a6 in - FStar_Compiler_Util.bind_opt - uu___12 - (fun a61 -> - let uu___13 = - FStar_TypeChecker_NBETerm.unembed - e7 cb a7 in - FStar_Compiler_Util.bind_opt - uu___13 - (fun a71 -> - let r1 = - interp_ctx - name - (fun - uu___14 - -> - f a11 a21 - a31 a41 - a51 a61 - a71) in - let uu___14 - = - FStar_TypeChecker_NBETerm.embed - er cb r1 in - FStar_Pervasives_Native.Some - uu___14))))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_total_nbe_interpretation_8 : - 'r 't1 't2 't3 't4 't5 't6 't7 't8 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 'r) -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 't6 FStar_TypeChecker_NBETerm.embedding -> - 't7 FStar_TypeChecker_NBETerm.embedding -> - 't8 FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: - (a4, uu___3)::(a5, uu___4)::(a6, uu___5):: - (a7, uu___6)::(a8, uu___7)::[] -> - let uu___8 = - FStar_TypeChecker_NBETerm.unembed e1 cb - a1 in - FStar_Compiler_Util.bind_opt uu___8 - (fun a11 -> - let uu___9 = - FStar_TypeChecker_NBETerm.unembed e2 - cb a2 in - FStar_Compiler_Util.bind_opt uu___9 - (fun a21 -> - let uu___10 = - FStar_TypeChecker_NBETerm.unembed - e3 cb a3 in - FStar_Compiler_Util.bind_opt - uu___10 - (fun a31 -> - let uu___11 = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___11 - (fun a41 -> - let uu___12 = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___12 - (fun a51 -> - let uu___13 = - FStar_TypeChecker_NBETerm.unembed - e6 cb a6 in - FStar_Compiler_Util.bind_opt - uu___13 - (fun a61 -> - let uu___14 = - FStar_TypeChecker_NBETerm.unembed - e7 cb a7 in - FStar_Compiler_Util.bind_opt - uu___14 - (fun a71 -> - let uu___15 - = - FStar_TypeChecker_NBETerm.unembed - e8 cb a8 in - FStar_Compiler_Util.bind_opt - uu___15 - (fun a81 - -> - let r1 = - interp_ctx - name - (fun - uu___16 - -> - f a11 a21 - a31 a41 - a51 a61 - a71 a81) in - let uu___16 - = - FStar_TypeChecker_NBETerm.embed - er cb r1 in - FStar_Pervasives_Native.Some - uu___16)))))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_total_nbe_interpretation_9 : - 'r 't1 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 'r) - -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 't6 FStar_TypeChecker_NBETerm.embedding -> - 't7 FStar_TypeChecker_NBETerm.embedding -> - 't8 FStar_TypeChecker_NBETerm.embedding -> - 't9 FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: - (a4, uu___3)::(a5, uu___4)::(a6, uu___5):: - (a7, uu___6)::(a8, uu___7)::(a9, uu___8)::[] - -> - let uu___9 = - FStar_TypeChecker_NBETerm.unembed e1 cb - a1 in - FStar_Compiler_Util.bind_opt uu___9 - (fun a11 -> - let uu___10 = - FStar_TypeChecker_NBETerm.unembed - e2 cb a2 in - FStar_Compiler_Util.bind_opt uu___10 - (fun a21 -> - let uu___11 = - FStar_TypeChecker_NBETerm.unembed - e3 cb a3 in - FStar_Compiler_Util.bind_opt - uu___11 - (fun a31 -> - let uu___12 = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___12 - (fun a41 -> - let uu___13 = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___13 - (fun a51 -> - let uu___14 = - FStar_TypeChecker_NBETerm.unembed - e6 cb a6 in - FStar_Compiler_Util.bind_opt - uu___14 - (fun a61 -> - let uu___15 - = - FStar_TypeChecker_NBETerm.unembed - e7 cb a7 in - FStar_Compiler_Util.bind_opt - uu___15 - ( - fun a71 - -> - let uu___16 - = - FStar_TypeChecker_NBETerm.unembed - e8 cb a8 in - FStar_Compiler_Util.bind_opt - uu___16 - (fun a81 - -> - let uu___17 - = - FStar_TypeChecker_NBETerm.unembed - e9 cb a9 in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a91 - -> - let r1 = - interp_ctx - name - (fun - uu___18 - -> - f a11 a21 - a31 a41 - a51 a61 - a71 a81 - a91) in - let uu___18 - = - FStar_TypeChecker_NBETerm.embed - er cb r1 in - FStar_Pervasives_Native.Some - uu___18))))))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_total_nbe_interpretation_10 : - 'r 't1 't10 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> - 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 'r) - -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 't6 FStar_TypeChecker_NBETerm.embedding -> - 't7 FStar_TypeChecker_NBETerm.embedding -> - 't8 FStar_TypeChecker_NBETerm.embedding -> - 't9 FStar_TypeChecker_NBETerm.embedding -> - 't10 FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: - (a4, uu___3)::(a5, uu___4)::(a6, - uu___5):: - (a7, uu___6)::(a8, uu___7)::(a9, - uu___8):: - (a10, uu___9)::[] -> - let uu___10 = - FStar_TypeChecker_NBETerm.unembed e1 - cb a1 in - FStar_Compiler_Util.bind_opt uu___10 - (fun a11 -> - let uu___11 = - FStar_TypeChecker_NBETerm.unembed - e2 cb a2 in - FStar_Compiler_Util.bind_opt - uu___11 - (fun a21 -> - let uu___12 = - FStar_TypeChecker_NBETerm.unembed - e3 cb a3 in - FStar_Compiler_Util.bind_opt - uu___12 - (fun a31 -> - let uu___13 = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___13 - (fun a41 -> - let uu___14 = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___14 - (fun a51 -> - let uu___15 = - FStar_TypeChecker_NBETerm.unembed - e6 cb a6 in - FStar_Compiler_Util.bind_opt - uu___15 - (fun a61 -> - let uu___16 - = - FStar_TypeChecker_NBETerm.unembed - e7 cb a7 in - FStar_Compiler_Util.bind_opt - uu___16 - (fun a71 - -> - let uu___17 - = - FStar_TypeChecker_NBETerm.unembed - e8 cb a8 in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a81 - -> - let uu___18 - = - FStar_TypeChecker_NBETerm.unembed - e9 cb a9 in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a91 - -> - let uu___19 - = - FStar_TypeChecker_NBETerm.unembed - e10 cb - a10 in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a101 - -> - let r1 = - interp_ctx - name - (fun - uu___20 - -> - f a11 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101) in - let uu___20 - = - FStar_TypeChecker_NBETerm.embed - er cb r1 in - FStar_Pervasives_Native.Some - uu___20)))))))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_total_nbe_interpretation_11 : - 'r 't1 't10 't11 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 'r) - -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 't6 FStar_TypeChecker_NBETerm.embedding -> - 't7 FStar_TypeChecker_NBETerm.embedding -> - 't8 FStar_TypeChecker_NBETerm.embedding -> - 't9 FStar_TypeChecker_NBETerm.embedding -> - 't10 FStar_TypeChecker_NBETerm.embedding -> - 't11 FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, uu___2):: - (a4, uu___3)::(a5, uu___4)::(a6, - uu___5):: - (a7, uu___6)::(a8, uu___7)::(a9, - uu___8):: - (a10, uu___9)::(a11, uu___10)::[] -> - let uu___11 = - FStar_TypeChecker_NBETerm.unembed - e1 cb a1 in - FStar_Compiler_Util.bind_opt uu___11 - (fun a12 -> - let uu___12 = - FStar_TypeChecker_NBETerm.unembed - e2 cb a2 in - FStar_Compiler_Util.bind_opt - uu___12 - (fun a21 -> - let uu___13 = - FStar_TypeChecker_NBETerm.unembed - e3 cb a3 in - FStar_Compiler_Util.bind_opt - uu___13 - (fun a31 -> - let uu___14 = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___14 - (fun a41 -> - let uu___15 = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___15 - (fun a51 -> - let uu___16 - = - FStar_TypeChecker_NBETerm.unembed - e6 cb a6 in - FStar_Compiler_Util.bind_opt - uu___16 - (fun a61 - -> - let uu___17 - = - FStar_TypeChecker_NBETerm.unembed - e7 cb a7 in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a71 - -> - let uu___18 - = - FStar_TypeChecker_NBETerm.unembed - e8 cb a8 in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a81 - -> - let uu___19 - = - FStar_TypeChecker_NBETerm.unembed - e9 cb a9 in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a91 - -> - let uu___20 - = - FStar_TypeChecker_NBETerm.unembed - e10 cb - a10 in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a101 - -> - let uu___21 - = - FStar_TypeChecker_NBETerm.unembed - e11 cb - a11 in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a111 - -> - let r1 = - interp_ctx - name - (fun - uu___22 - -> - f a12 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 - a111) in - let uu___22 - = - FStar_TypeChecker_NBETerm.embed - er cb r1 in - FStar_Pervasives_Native.Some - uu___22))))))))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_total_nbe_interpretation_12 : - 'r 't1 't10 't11 't12 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 'r) - -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 't6 FStar_TypeChecker_NBETerm.embedding -> - 't7 FStar_TypeChecker_NBETerm.embedding -> - 't8 FStar_TypeChecker_NBETerm.embedding -> - 't9 FStar_TypeChecker_NBETerm.embedding -> - 't10 FStar_TypeChecker_NBETerm.embedding -> - 't11 FStar_TypeChecker_NBETerm.embedding -> - 't12 FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1)::(a3, - uu___2):: - (a4, uu___3)::(a5, uu___4):: - (a6, uu___5)::(a7, uu___6):: - (a8, uu___7)::(a9, uu___8):: - (a10, uu___9)::(a11, uu___10):: - (a12, uu___11)::[] -> - let uu___12 = - FStar_TypeChecker_NBETerm.unembed - e1 cb a1 in - FStar_Compiler_Util.bind_opt - uu___12 - (fun a13 -> - let uu___13 = - FStar_TypeChecker_NBETerm.unembed - e2 cb a2 in - FStar_Compiler_Util.bind_opt - uu___13 - (fun a21 -> - let uu___14 = - FStar_TypeChecker_NBETerm.unembed - e3 cb a3 in - FStar_Compiler_Util.bind_opt - uu___14 - (fun a31 -> - let uu___15 = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___15 - (fun a41 -> - let uu___16 = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___16 - (fun a51 -> - let uu___17 - = - FStar_TypeChecker_NBETerm.unembed - e6 cb a6 in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a61 - -> - let uu___18 - = - FStar_TypeChecker_NBETerm.unembed - e7 cb a7 in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a71 - -> - let uu___19 - = - FStar_TypeChecker_NBETerm.unembed - e8 cb a8 in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a81 - -> - let uu___20 - = - FStar_TypeChecker_NBETerm.unembed - e9 cb a9 in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a91 - -> - let uu___21 - = - FStar_TypeChecker_NBETerm.unembed - e10 cb - a10 in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a101 - -> - let uu___22 - = - FStar_TypeChecker_NBETerm.unembed - e11 cb - a11 in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a111 - -> - let uu___23 - = - FStar_TypeChecker_NBETerm.unembed - e12 cb - a12 in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a121 - -> - let r1 = - interp_ctx - name - (fun - uu___24 - -> - f a13 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 - a111 a121) in - let uu___24 - = - FStar_TypeChecker_NBETerm.embed - er cb r1 in - FStar_Pervasives_Native.Some - uu___24)))))))))))) - | uu___ -> FStar_Pervasives_Native.None -let mk_total_nbe_interpretation_13 : - 'r 't1 't10 't11 't12 't13 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 'r) - -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 't6 FStar_TypeChecker_NBETerm.embedding -> - 't7 FStar_TypeChecker_NBETerm.embedding -> - 't8 FStar_TypeChecker_NBETerm.embedding -> - 't9 FStar_TypeChecker_NBETerm.embedding -> - 't10 FStar_TypeChecker_NBETerm.embedding -> - 't11 FStar_TypeChecker_NBETerm.embedding -> - 't12 FStar_TypeChecker_NBETerm.embedding -> - 't13 FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1):: - (a3, uu___2)::(a4, uu___3):: - (a5, uu___4)::(a6, uu___5):: - (a7, uu___6)::(a8, uu___7):: - (a9, uu___8)::(a10, uu___9):: - (a11, uu___10)::(a12, uu___11):: - (a13, uu___12)::[] -> - let uu___13 = - FStar_TypeChecker_NBETerm.unembed - e1 cb a1 in - FStar_Compiler_Util.bind_opt - uu___13 - (fun a14 -> - let uu___14 = - FStar_TypeChecker_NBETerm.unembed - e2 cb a2 in - FStar_Compiler_Util.bind_opt - uu___14 - (fun a21 -> - let uu___15 = - FStar_TypeChecker_NBETerm.unembed - e3 cb a3 in - FStar_Compiler_Util.bind_opt - uu___15 - (fun a31 -> - let uu___16 = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___16 - (fun a41 -> - let uu___17 = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a51 -> - let uu___18 - = - FStar_TypeChecker_NBETerm.unembed - e6 cb a6 in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a61 - -> - let uu___19 - = - FStar_TypeChecker_NBETerm.unembed - e7 cb a7 in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a71 - -> - let uu___20 - = - FStar_TypeChecker_NBETerm.unembed - e8 cb a8 in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a81 - -> - let uu___21 - = - FStar_TypeChecker_NBETerm.unembed - e9 cb a9 in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a91 - -> - let uu___22 - = - FStar_TypeChecker_NBETerm.unembed - e10 cb - a10 in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a101 - -> - let uu___23 - = - FStar_TypeChecker_NBETerm.unembed - e11 cb - a11 in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a111 - -> - let uu___24 - = - FStar_TypeChecker_NBETerm.unembed - e12 cb - a12 in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a121 - -> - let uu___25 - = - FStar_TypeChecker_NBETerm.unembed - e13 cb - a13 in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a131 - -> - let r1 = - interp_ctx - name - (fun - uu___26 - -> - f a14 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 - a111 a121 - a131) in - let uu___26 - = - FStar_TypeChecker_NBETerm.embed - er cb r1 in - FStar_Pervasives_Native.Some - uu___26))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_total_nbe_interpretation_14 : - 'r 't1 't10 't11 't12 't13 't14 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 'r) - -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 't6 FStar_TypeChecker_NBETerm.embedding -> - 't7 FStar_TypeChecker_NBETerm.embedding -> - 't8 FStar_TypeChecker_NBETerm.embedding -> - 't9 FStar_TypeChecker_NBETerm.embedding -> - 't10 FStar_TypeChecker_NBETerm.embedding -> - 't11 FStar_TypeChecker_NBETerm.embedding -> - 't12 FStar_TypeChecker_NBETerm.embedding -> - 't13 FStar_TypeChecker_NBETerm.embedding -> - 't14 FStar_TypeChecker_NBETerm.embedding - -> - 'r FStar_TypeChecker_NBETerm.embedding - -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun e14 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1):: - (a3, uu___2)::(a4, uu___3):: - (a5, uu___4)::(a6, uu___5):: - (a7, uu___6)::(a8, uu___7):: - (a9, uu___8)::(a10, uu___9):: - (a11, uu___10)::(a12, uu___11):: - (a13, uu___12)::(a14, uu___13)::[] - -> - let uu___14 = - FStar_TypeChecker_NBETerm.unembed - e1 cb a1 in - FStar_Compiler_Util.bind_opt - uu___14 - (fun a15 -> - let uu___15 = - FStar_TypeChecker_NBETerm.unembed - e2 cb a2 in - FStar_Compiler_Util.bind_opt - uu___15 - (fun a21 -> - let uu___16 = - FStar_TypeChecker_NBETerm.unembed - e3 cb a3 in - FStar_Compiler_Util.bind_opt - uu___16 - (fun a31 -> - let uu___17 = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a41 -> - let uu___18 - = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___18 - ( - fun a51 - -> - let uu___19 - = - FStar_TypeChecker_NBETerm.unembed - e6 cb a6 in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a61 - -> - let uu___20 - = - FStar_TypeChecker_NBETerm.unembed - e7 cb a7 in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a71 - -> - let uu___21 - = - FStar_TypeChecker_NBETerm.unembed - e8 cb a8 in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a81 - -> - let uu___22 - = - FStar_TypeChecker_NBETerm.unembed - e9 cb a9 in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a91 - -> - let uu___23 - = - FStar_TypeChecker_NBETerm.unembed - e10 cb - a10 in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a101 - -> - let uu___24 - = - FStar_TypeChecker_NBETerm.unembed - e11 cb - a11 in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a111 - -> - let uu___25 - = - FStar_TypeChecker_NBETerm.unembed - e12 cb - a12 in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a121 - -> - let uu___26 - = - FStar_TypeChecker_NBETerm.unembed - e13 cb - a13 in - FStar_Compiler_Util.bind_opt - uu___26 - (fun a131 - -> - let uu___27 - = - FStar_TypeChecker_NBETerm.unembed - e14 cb - a14 in - FStar_Compiler_Util.bind_opt - uu___27 - (fun a141 - -> - let r1 = - interp_ctx - name - (fun - uu___28 - -> - f a15 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 - a111 a121 - a131 a141) in - let uu___28 - = - FStar_TypeChecker_NBETerm.embed - er cb r1 in - FStar_Pervasives_Native.Some - uu___28)))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_total_nbe_interpretation_15 : - 'r 't1 't10 't11 't12 't13 't14 't15 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> - 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 'r) - -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 't6 FStar_TypeChecker_NBETerm.embedding -> - 't7 FStar_TypeChecker_NBETerm.embedding -> - 't8 FStar_TypeChecker_NBETerm.embedding -> - 't9 FStar_TypeChecker_NBETerm.embedding -> - 't10 FStar_TypeChecker_NBETerm.embedding -> - 't11 FStar_TypeChecker_NBETerm.embedding -> - 't12 FStar_TypeChecker_NBETerm.embedding -> - 't13 FStar_TypeChecker_NBETerm.embedding -> - 't14 FStar_TypeChecker_NBETerm.embedding - -> - 't15 - FStar_TypeChecker_NBETerm.embedding - -> - 'r - FStar_TypeChecker_NBETerm.embedding - -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun e14 -> - fun e15 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1):: - (a3, uu___2)::(a4, uu___3):: - (a5, uu___4)::(a6, uu___5):: - (a7, uu___6)::(a8, uu___7):: - (a9, uu___8)::(a10, uu___9):: - (a11, uu___10)::(a12, - uu___11):: - (a13, uu___12)::(a14, - uu___13):: - (a15, uu___14)::[] -> - let uu___15 = - FStar_TypeChecker_NBETerm.unembed - e1 cb a1 in - FStar_Compiler_Util.bind_opt - uu___15 - (fun a16 -> - let uu___16 = - FStar_TypeChecker_NBETerm.unembed - e2 cb a2 in - FStar_Compiler_Util.bind_opt - uu___16 - (fun a21 -> - let uu___17 = - FStar_TypeChecker_NBETerm.unembed - e3 cb a3 in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a31 -> - let uu___18 = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a41 -> - let uu___19 - = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a51 - -> - let uu___20 - = - FStar_TypeChecker_NBETerm.unembed - e6 cb a6 in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a61 - -> - let uu___21 - = - FStar_TypeChecker_NBETerm.unembed - e7 cb a7 in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a71 - -> - let uu___22 - = - FStar_TypeChecker_NBETerm.unembed - e8 cb a8 in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a81 - -> - let uu___23 - = - FStar_TypeChecker_NBETerm.unembed - e9 cb a9 in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a91 - -> - let uu___24 - = - FStar_TypeChecker_NBETerm.unembed - e10 cb - a10 in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a101 - -> - let uu___25 - = - FStar_TypeChecker_NBETerm.unembed - e11 cb - a11 in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a111 - -> - let uu___26 - = - FStar_TypeChecker_NBETerm.unembed - e12 cb - a12 in - FStar_Compiler_Util.bind_opt - uu___26 - (fun a121 - -> - let uu___27 - = - FStar_TypeChecker_NBETerm.unembed - e13 cb - a13 in - FStar_Compiler_Util.bind_opt - uu___27 - (fun a131 - -> - let uu___28 - = - FStar_TypeChecker_NBETerm.unembed - e14 cb - a14 in - FStar_Compiler_Util.bind_opt - uu___28 - (fun a141 - -> - let uu___29 - = - FStar_TypeChecker_NBETerm.unembed - e15 cb - a15 in - FStar_Compiler_Util.bind_opt - uu___29 - (fun a151 - -> - let r1 = - interp_ctx - name - (fun - uu___30 - -> - f a16 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 - a111 a121 - a131 a141 - a151) in - let uu___30 - = - FStar_TypeChecker_NBETerm.embed - er cb r1 in - FStar_Pervasives_Native.Some - uu___30))))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_total_nbe_interpretation_16 : - 'r 't1 't10 't11 't12 't13 't14 't15 't16 't2 't3 't4 't5 't6 't7 't8 't9 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> - 't10 -> - 't11 -> - 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 'r) - -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 't6 FStar_TypeChecker_NBETerm.embedding -> - 't7 FStar_TypeChecker_NBETerm.embedding -> - 't8 FStar_TypeChecker_NBETerm.embedding -> - 't9 FStar_TypeChecker_NBETerm.embedding -> - 't10 FStar_TypeChecker_NBETerm.embedding -> - 't11 FStar_TypeChecker_NBETerm.embedding -> - 't12 FStar_TypeChecker_NBETerm.embedding -> - 't13 FStar_TypeChecker_NBETerm.embedding -> - 't14 FStar_TypeChecker_NBETerm.embedding - -> - 't15 - FStar_TypeChecker_NBETerm.embedding - -> - 't16 - FStar_TypeChecker_NBETerm.embedding - -> - 'r - FStar_TypeChecker_NBETerm.embedding - -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args - -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun e14 -> - fun e15 -> - fun e16 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1):: - (a3, uu___2)::(a4, uu___3):: - (a5, uu___4)::(a6, uu___5):: - (a7, uu___6)::(a8, uu___7):: - (a9, uu___8)::(a10, uu___9):: - (a11, uu___10)::(a12, - uu___11):: - (a13, uu___12)::(a14, - uu___13):: - (a15, uu___14)::(a16, - uu___15)::[] - -> - let uu___16 = - FStar_TypeChecker_NBETerm.unembed - e1 cb a1 in - FStar_Compiler_Util.bind_opt - uu___16 - (fun a17 -> - let uu___17 = - FStar_TypeChecker_NBETerm.unembed - e2 cb a2 in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a21 -> - let uu___18 = - FStar_TypeChecker_NBETerm.unembed - e3 cb a3 in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a31 -> - let uu___19 - = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a41 - -> - let uu___20 - = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a51 - -> - let uu___21 - = - FStar_TypeChecker_NBETerm.unembed - e6 cb a6 in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a61 - -> - let uu___22 - = - FStar_TypeChecker_NBETerm.unembed - e7 cb a7 in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a71 - -> - let uu___23 - = - FStar_TypeChecker_NBETerm.unembed - e8 cb a8 in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a81 - -> - let uu___24 - = - FStar_TypeChecker_NBETerm.unembed - e9 cb a9 in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a91 - -> - let uu___25 - = - FStar_TypeChecker_NBETerm.unembed - e10 cb - a10 in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a101 - -> - let uu___26 - = - FStar_TypeChecker_NBETerm.unembed - e11 cb - a11 in - FStar_Compiler_Util.bind_opt - uu___26 - (fun a111 - -> - let uu___27 - = - FStar_TypeChecker_NBETerm.unembed - e12 cb - a12 in - FStar_Compiler_Util.bind_opt - uu___27 - (fun a121 - -> - let uu___28 - = - FStar_TypeChecker_NBETerm.unembed - e13 cb - a13 in - FStar_Compiler_Util.bind_opt - uu___28 - (fun a131 - -> - let uu___29 - = - FStar_TypeChecker_NBETerm.unembed - e14 cb - a14 in - FStar_Compiler_Util.bind_opt - uu___29 - (fun a141 - -> - let uu___30 - = - FStar_TypeChecker_NBETerm.unembed - e15 cb - a15 in - FStar_Compiler_Util.bind_opt - uu___30 - (fun a151 - -> - let uu___31 - = - FStar_TypeChecker_NBETerm.unembed - e16 cb - a16 in - FStar_Compiler_Util.bind_opt - uu___31 - (fun a161 - -> - let r1 = - interp_ctx - name - (fun - uu___32 - -> - f a17 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 - a111 a121 - a131 a141 - a151 a161) in - let uu___32 - = - FStar_TypeChecker_NBETerm.embed - er cb r1 in - FStar_Pervasives_Native.Some - uu___32)))))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_total_nbe_interpretation_17 : - 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't2 't3 't4 't5 't6 't7 't8 - 't9 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> - 't10 -> - 't11 -> - 't12 -> - 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 'r) - -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 't6 FStar_TypeChecker_NBETerm.embedding -> - 't7 FStar_TypeChecker_NBETerm.embedding -> - 't8 FStar_TypeChecker_NBETerm.embedding -> - 't9 FStar_TypeChecker_NBETerm.embedding -> - 't10 FStar_TypeChecker_NBETerm.embedding -> - 't11 FStar_TypeChecker_NBETerm.embedding -> - 't12 FStar_TypeChecker_NBETerm.embedding -> - 't13 FStar_TypeChecker_NBETerm.embedding -> - 't14 FStar_TypeChecker_NBETerm.embedding - -> - 't15 - FStar_TypeChecker_NBETerm.embedding - -> - 't16 - FStar_TypeChecker_NBETerm.embedding - -> - 't17 - FStar_TypeChecker_NBETerm.embedding - -> - 'r - FStar_TypeChecker_NBETerm.embedding - -> - FStar_Syntax_Syntax.universes - -> - FStar_TypeChecker_NBETerm.args - -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun e14 -> - fun e15 -> - fun e16 -> - fun e17 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1):: - (a3, uu___2)::(a4, - uu___3):: - (a5, uu___4)::(a6, - uu___5):: - (a7, uu___6)::(a8, - uu___7):: - (a9, uu___8)::(a10, - uu___9):: - (a11, uu___10)::(a12, - uu___11):: - (a13, uu___12)::(a14, - uu___13):: - (a15, uu___14)::(a16, - uu___15):: - (a17, uu___16)::[] -> - let uu___17 = - FStar_TypeChecker_NBETerm.unembed - e1 cb a1 in - FStar_Compiler_Util.bind_opt - uu___17 - (fun a18 -> - let uu___18 = - FStar_TypeChecker_NBETerm.unembed - e2 cb a2 in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a21 -> - let uu___19 = - FStar_TypeChecker_NBETerm.unembed - e3 cb a3 in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a31 -> - let uu___20 - = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a41 - -> - let uu___21 - = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a51 - -> - let uu___22 - = - FStar_TypeChecker_NBETerm.unembed - e6 cb a6 in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a61 - -> - let uu___23 - = - FStar_TypeChecker_NBETerm.unembed - e7 cb a7 in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a71 - -> - let uu___24 - = - FStar_TypeChecker_NBETerm.unembed - e8 cb a8 in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a81 - -> - let uu___25 - = - FStar_TypeChecker_NBETerm.unembed - e9 cb a9 in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a91 - -> - let uu___26 - = - FStar_TypeChecker_NBETerm.unembed - e10 cb - a10 in - FStar_Compiler_Util.bind_opt - uu___26 - (fun a101 - -> - let uu___27 - = - FStar_TypeChecker_NBETerm.unembed - e11 cb - a11 in - FStar_Compiler_Util.bind_opt - uu___27 - (fun a111 - -> - let uu___28 - = - FStar_TypeChecker_NBETerm.unembed - e12 cb - a12 in - FStar_Compiler_Util.bind_opt - uu___28 - (fun a121 - -> - let uu___29 - = - FStar_TypeChecker_NBETerm.unembed - e13 cb - a13 in - FStar_Compiler_Util.bind_opt - uu___29 - (fun a131 - -> - let uu___30 - = - FStar_TypeChecker_NBETerm.unembed - e14 cb - a14 in - FStar_Compiler_Util.bind_opt - uu___30 - (fun a141 - -> - let uu___31 - = - FStar_TypeChecker_NBETerm.unembed - e15 cb - a15 in - FStar_Compiler_Util.bind_opt - uu___31 - (fun a151 - -> - let uu___32 - = - FStar_TypeChecker_NBETerm.unembed - e16 cb - a16 in - FStar_Compiler_Util.bind_opt - uu___32 - (fun a161 - -> - let uu___33 - = - FStar_TypeChecker_NBETerm.unembed - e17 cb - a17 in - FStar_Compiler_Util.bind_opt - uu___33 - (fun a171 - -> - let r1 = - interp_ctx - name - (fun - uu___34 - -> - f a18 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 - a111 a121 - a131 a141 - a151 a161 - a171) in - let uu___34 - = - FStar_TypeChecker_NBETerm.embed - er cb r1 in - FStar_Pervasives_Native.Some - uu___34))))))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_total_nbe_interpretation_18 : - 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't18 't2 't3 't4 't5 't6 't7 - 't8 't9 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> - 't10 -> - 't11 -> - 't12 -> - 't13 -> - 't14 -> 't15 -> 't16 -> 't17 -> 't18 -> 'r) - -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 't6 FStar_TypeChecker_NBETerm.embedding -> - 't7 FStar_TypeChecker_NBETerm.embedding -> - 't8 FStar_TypeChecker_NBETerm.embedding -> - 't9 FStar_TypeChecker_NBETerm.embedding -> - 't10 FStar_TypeChecker_NBETerm.embedding -> - 't11 FStar_TypeChecker_NBETerm.embedding -> - 't12 FStar_TypeChecker_NBETerm.embedding -> - 't13 FStar_TypeChecker_NBETerm.embedding -> - 't14 FStar_TypeChecker_NBETerm.embedding - -> - 't15 - FStar_TypeChecker_NBETerm.embedding - -> - 't16 - FStar_TypeChecker_NBETerm.embedding - -> - 't17 - FStar_TypeChecker_NBETerm.embedding - -> - 't18 - FStar_TypeChecker_NBETerm.embedding - -> - 'r - FStar_TypeChecker_NBETerm.embedding - -> - FStar_Syntax_Syntax.universes - -> - FStar_TypeChecker_NBETerm.args - -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun e14 -> - fun e15 -> - fun e16 -> - fun e17 -> - fun e18 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, uu___1):: - (a3, uu___2)::(a4, - uu___3):: - (a5, uu___4)::(a6, - uu___5):: - (a7, uu___6)::(a8, - uu___7):: - (a9, uu___8)::(a10, - uu___9):: - (a11, uu___10):: - (a12, uu___11):: - (a13, uu___12):: - (a14, uu___13):: - (a15, uu___14):: - (a16, uu___15):: - (a17, uu___16):: - (a18, uu___17)::[] -> - let uu___18 = - FStar_TypeChecker_NBETerm.unembed - e1 cb a1 in - FStar_Compiler_Util.bind_opt - uu___18 - (fun a19 -> - let uu___19 = - FStar_TypeChecker_NBETerm.unembed - e2 cb a2 in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a21 -> - let uu___20 = - FStar_TypeChecker_NBETerm.unembed - e3 cb a3 in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a31 -> - let uu___21 - = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a41 - -> - let uu___22 - = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a51 - -> - let uu___23 - = - FStar_TypeChecker_NBETerm.unembed - e6 cb a6 in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a61 - -> - let uu___24 - = - FStar_TypeChecker_NBETerm.unembed - e7 cb a7 in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a71 - -> - let uu___25 - = - FStar_TypeChecker_NBETerm.unembed - e8 cb a8 in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a81 - -> - let uu___26 - = - FStar_TypeChecker_NBETerm.unembed - e9 cb a9 in - FStar_Compiler_Util.bind_opt - uu___26 - (fun a91 - -> - let uu___27 - = - FStar_TypeChecker_NBETerm.unembed - e10 cb - a10 in - FStar_Compiler_Util.bind_opt - uu___27 - (fun a101 - -> - let uu___28 - = - FStar_TypeChecker_NBETerm.unembed - e11 cb - a11 in - FStar_Compiler_Util.bind_opt - uu___28 - (fun a111 - -> - let uu___29 - = - FStar_TypeChecker_NBETerm.unembed - e12 cb - a12 in - FStar_Compiler_Util.bind_opt - uu___29 - (fun a121 - -> - let uu___30 - = - FStar_TypeChecker_NBETerm.unembed - e13 cb - a13 in - FStar_Compiler_Util.bind_opt - uu___30 - (fun a131 - -> - let uu___31 - = - FStar_TypeChecker_NBETerm.unembed - e14 cb - a14 in - FStar_Compiler_Util.bind_opt - uu___31 - (fun a141 - -> - let uu___32 - = - FStar_TypeChecker_NBETerm.unembed - e15 cb - a15 in - FStar_Compiler_Util.bind_opt - uu___32 - (fun a151 - -> - let uu___33 - = - FStar_TypeChecker_NBETerm.unembed - e16 cb - a16 in - FStar_Compiler_Util.bind_opt - uu___33 - (fun a161 - -> - let uu___34 - = - FStar_TypeChecker_NBETerm.unembed - e17 cb - a17 in - FStar_Compiler_Util.bind_opt - uu___34 - (fun a171 - -> - let uu___35 - = - FStar_TypeChecker_NBETerm.unembed - e18 cb - a18 in - FStar_Compiler_Util.bind_opt - uu___35 - (fun a181 - -> - let r1 = - interp_ctx - name - (fun - uu___36 - -> - f a19 a21 - a31 a41 - a51 a61 - a71 a81 - a91 a101 - a111 a121 - a131 a141 - a151 a161 - a171 a181) in - let uu___36 - = - FStar_TypeChecker_NBETerm.embed - er cb r1 in - FStar_Pervasives_Native.Some - uu___36)))))))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_total_nbe_interpretation_19 : - 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't18 't19 't2 't3 't4 't5 - 't6 't7 't8 't9 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> - 't10 -> - 't11 -> - 't12 -> - 't13 -> - 't14 -> - 't15 -> - 't16 -> 't17 -> 't18 -> 't19 -> 'r) - -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 't6 FStar_TypeChecker_NBETerm.embedding -> - 't7 FStar_TypeChecker_NBETerm.embedding -> - 't8 FStar_TypeChecker_NBETerm.embedding -> - 't9 FStar_TypeChecker_NBETerm.embedding -> - 't10 FStar_TypeChecker_NBETerm.embedding -> - 't11 FStar_TypeChecker_NBETerm.embedding -> - 't12 FStar_TypeChecker_NBETerm.embedding -> - 't13 FStar_TypeChecker_NBETerm.embedding -> - 't14 FStar_TypeChecker_NBETerm.embedding - -> - 't15 - FStar_TypeChecker_NBETerm.embedding - -> - 't16 - FStar_TypeChecker_NBETerm.embedding - -> - 't17 - FStar_TypeChecker_NBETerm.embedding - -> - 't18 - FStar_TypeChecker_NBETerm.embedding - -> - 't19 - FStar_TypeChecker_NBETerm.embedding - -> - 'r - FStar_TypeChecker_NBETerm.embedding - -> - FStar_Syntax_Syntax.universes - -> - FStar_TypeChecker_NBETerm.args - -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun e14 -> - fun e15 -> - fun e16 -> - fun e17 -> - fun e18 -> - fun e19 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___)::(a2, - uu___1):: - (a3, uu___2):: - (a4, uu___3):: - (a5, uu___4):: - (a6, uu___5):: - (a7, uu___6):: - (a8, uu___7):: - (a9, uu___8):: - (a10, uu___9):: - (a11, uu___10):: - (a12, uu___11):: - (a13, uu___12):: - (a14, uu___13):: - (a15, uu___14):: - (a16, uu___15):: - (a17, uu___16):: - (a18, uu___17):: - (a19, uu___18)::[] -> - let uu___19 = - FStar_TypeChecker_NBETerm.unembed - e1 cb a1 in - FStar_Compiler_Util.bind_opt - uu___19 - (fun a110 -> - let uu___20 = - FStar_TypeChecker_NBETerm.unembed - e2 cb a2 in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a21 -> - let uu___21 - = - FStar_TypeChecker_NBETerm.unembed - e3 cb a3 in - FStar_Compiler_Util.bind_opt - uu___21 - ( - fun a31 - -> - let uu___22 - = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a41 - -> - let uu___23 - = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a51 - -> - let uu___24 - = - FStar_TypeChecker_NBETerm.unembed - e6 cb a6 in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a61 - -> - let uu___25 - = - FStar_TypeChecker_NBETerm.unembed - e7 cb a7 in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a71 - -> - let uu___26 - = - FStar_TypeChecker_NBETerm.unembed - e8 cb a8 in - FStar_Compiler_Util.bind_opt - uu___26 - (fun a81 - -> - let uu___27 - = - FStar_TypeChecker_NBETerm.unembed - e9 cb a9 in - FStar_Compiler_Util.bind_opt - uu___27 - (fun a91 - -> - let uu___28 - = - FStar_TypeChecker_NBETerm.unembed - e10 cb - a10 in - FStar_Compiler_Util.bind_opt - uu___28 - (fun a101 - -> - let uu___29 - = - FStar_TypeChecker_NBETerm.unembed - e11 cb - a11 in - FStar_Compiler_Util.bind_opt - uu___29 - (fun a111 - -> - let uu___30 - = - FStar_TypeChecker_NBETerm.unembed - e12 cb - a12 in - FStar_Compiler_Util.bind_opt - uu___30 - (fun a121 - -> - let uu___31 - = - FStar_TypeChecker_NBETerm.unembed - e13 cb - a13 in - FStar_Compiler_Util.bind_opt - uu___31 - (fun a131 - -> - let uu___32 - = - FStar_TypeChecker_NBETerm.unembed - e14 cb - a14 in - FStar_Compiler_Util.bind_opt - uu___32 - (fun a141 - -> - let uu___33 - = - FStar_TypeChecker_NBETerm.unembed - e15 cb - a15 in - FStar_Compiler_Util.bind_opt - uu___33 - (fun a151 - -> - let uu___34 - = - FStar_TypeChecker_NBETerm.unembed - e16 cb - a16 in - FStar_Compiler_Util.bind_opt - uu___34 - (fun a161 - -> - let uu___35 - = - FStar_TypeChecker_NBETerm.unembed - e17 cb - a17 in - FStar_Compiler_Util.bind_opt - uu___35 - (fun a171 - -> - let uu___36 - = - FStar_TypeChecker_NBETerm.unembed - e18 cb - a18 in - FStar_Compiler_Util.bind_opt - uu___36 - (fun a181 - -> - let uu___37 - = - FStar_TypeChecker_NBETerm.unembed - e19 cb - a19 in - FStar_Compiler_Util.bind_opt - uu___37 - (fun a191 - -> - let r1 = - interp_ctx - name - (fun - uu___38 - -> - f a110 - a21 a31 - a41 a51 - a61 a71 - a81 a91 - a101 a111 - a121 a131 - a141 a151 - a161 a171 - a181 a191) in - let uu___38 - = - FStar_TypeChecker_NBETerm.embed - er cb r1 in - FStar_Pervasives_Native.Some - uu___38))))))))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None -let mk_total_nbe_interpretation_20 : - 'r 't1 't10 't11 't12 't13 't14 't15 't16 't17 't18 't19 't2 't20 't3 't4 - 't5 't6 't7 't8 't9 . - Prims.string -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - ('t1 -> - 't2 -> - 't3 -> - 't4 -> - 't5 -> - 't6 -> - 't7 -> - 't8 -> - 't9 -> - 't10 -> - 't11 -> - 't12 -> - 't13 -> - 't14 -> - 't15 -> - 't16 -> - 't17 -> 't18 -> 't19 -> 't20 -> 'r) - -> - 't1 FStar_TypeChecker_NBETerm.embedding -> - 't2 FStar_TypeChecker_NBETerm.embedding -> - 't3 FStar_TypeChecker_NBETerm.embedding -> - 't4 FStar_TypeChecker_NBETerm.embedding -> - 't5 FStar_TypeChecker_NBETerm.embedding -> - 't6 FStar_TypeChecker_NBETerm.embedding -> - 't7 FStar_TypeChecker_NBETerm.embedding -> - 't8 FStar_TypeChecker_NBETerm.embedding -> - 't9 FStar_TypeChecker_NBETerm.embedding -> - 't10 FStar_TypeChecker_NBETerm.embedding -> - 't11 FStar_TypeChecker_NBETerm.embedding -> - 't12 FStar_TypeChecker_NBETerm.embedding -> - 't13 FStar_TypeChecker_NBETerm.embedding -> - 't14 FStar_TypeChecker_NBETerm.embedding - -> - 't15 - FStar_TypeChecker_NBETerm.embedding - -> - 't16 - FStar_TypeChecker_NBETerm.embedding - -> - 't17 - FStar_TypeChecker_NBETerm.embedding - -> - 't18 - FStar_TypeChecker_NBETerm.embedding - -> - 't19 - FStar_TypeChecker_NBETerm.embedding - -> - 't20 - FStar_TypeChecker_NBETerm.embedding - -> - 'r - FStar_TypeChecker_NBETerm.embedding - -> - FStar_Syntax_Syntax.universes - -> - FStar_TypeChecker_NBETerm.args - -> - FStar_TypeChecker_NBETerm.t - FStar_Pervasives_Native.option - = - fun name -> - fun cb -> - fun f -> - fun e1 -> - fun e2 -> - fun e3 -> - fun e4 -> - fun e5 -> - fun e6 -> - fun e7 -> - fun e8 -> - fun e9 -> - fun e10 -> - fun e11 -> - fun e12 -> - fun e13 -> - fun e14 -> - fun e15 -> - fun e16 -> - fun e17 -> - fun e18 -> - fun e19 -> - fun e20 -> - fun er -> - fun us -> - fun args -> - match args with - | (a1, uu___):: - (a2, uu___1):: - (a3, uu___2):: - (a4, uu___3):: - (a5, uu___4):: - (a6, uu___5):: - (a7, uu___6):: - (a8, uu___7):: - (a9, uu___8):: - (a10, uu___9):: - (a11, uu___10):: - (a12, uu___11):: - (a13, uu___12):: - (a14, uu___13):: - (a15, uu___14):: - (a16, uu___15):: - (a17, uu___16):: - (a18, uu___17):: - (a19, uu___18):: - (a20, uu___19)::[] - -> - let uu___20 = - FStar_TypeChecker_NBETerm.unembed - e1 cb a1 in - FStar_Compiler_Util.bind_opt - uu___20 - (fun a110 -> - let uu___21 = - FStar_TypeChecker_NBETerm.unembed - e2 cb a2 in - FStar_Compiler_Util.bind_opt - uu___21 - (fun a21 -> - let uu___22 - = - FStar_TypeChecker_NBETerm.unembed - e3 cb a3 in - FStar_Compiler_Util.bind_opt - uu___22 - (fun a31 - -> - let uu___23 - = - FStar_TypeChecker_NBETerm.unembed - e4 cb a4 in - FStar_Compiler_Util.bind_opt - uu___23 - (fun a41 - -> - let uu___24 - = - FStar_TypeChecker_NBETerm.unembed - e5 cb a5 in - FStar_Compiler_Util.bind_opt - uu___24 - (fun a51 - -> - let uu___25 - = - FStar_TypeChecker_NBETerm.unembed - e6 cb a6 in - FStar_Compiler_Util.bind_opt - uu___25 - (fun a61 - -> - let uu___26 - = - FStar_TypeChecker_NBETerm.unembed - e7 cb a7 in - FStar_Compiler_Util.bind_opt - uu___26 - (fun a71 - -> - let uu___27 - = - FStar_TypeChecker_NBETerm.unembed - e8 cb a8 in - FStar_Compiler_Util.bind_opt - uu___27 - (fun a81 - -> - let uu___28 - = - FStar_TypeChecker_NBETerm.unembed - e9 cb a9 in - FStar_Compiler_Util.bind_opt - uu___28 - (fun a91 - -> - let uu___29 - = - FStar_TypeChecker_NBETerm.unembed - e10 cb - a10 in - FStar_Compiler_Util.bind_opt - uu___29 - (fun a101 - -> - let uu___30 - = - FStar_TypeChecker_NBETerm.unembed - e11 cb - a11 in - FStar_Compiler_Util.bind_opt - uu___30 - (fun a111 - -> - let uu___31 - = - FStar_TypeChecker_NBETerm.unembed - e12 cb - a12 in - FStar_Compiler_Util.bind_opt - uu___31 - (fun a121 - -> - let uu___32 - = - FStar_TypeChecker_NBETerm.unembed - e13 cb - a13 in - FStar_Compiler_Util.bind_opt - uu___32 - (fun a131 - -> - let uu___33 - = - FStar_TypeChecker_NBETerm.unembed - e14 cb - a14 in - FStar_Compiler_Util.bind_opt - uu___33 - (fun a141 - -> - let uu___34 - = - FStar_TypeChecker_NBETerm.unembed - e15 cb - a15 in - FStar_Compiler_Util.bind_opt - uu___34 - (fun a151 - -> - let uu___35 - = - FStar_TypeChecker_NBETerm.unembed - e16 cb - a16 in - FStar_Compiler_Util.bind_opt - uu___35 - (fun a161 - -> - let uu___36 - = - FStar_TypeChecker_NBETerm.unembed - e17 cb - a17 in - FStar_Compiler_Util.bind_opt - uu___36 - (fun a171 - -> - let uu___37 - = - FStar_TypeChecker_NBETerm.unembed - e18 cb - a18 in - FStar_Compiler_Util.bind_opt - uu___37 - (fun a181 - -> - let uu___38 - = - FStar_TypeChecker_NBETerm.unembed - e19 cb - a19 in - FStar_Compiler_Util.bind_opt - uu___38 - (fun a191 - -> - let uu___39 - = - FStar_TypeChecker_NBETerm.unembed - e20 cb - a20 in - FStar_Compiler_Util.bind_opt - uu___39 - (fun a201 - -> - let r1 = - interp_ctx - name - (fun - uu___40 - -> - f a110 - a21 a31 - a41 a51 - a61 a71 - a81 a91 - a101 a111 - a121 a131 - a141 a151 - a161 a171 - a181 a191 - a201) in - let uu___40 - = - FStar_TypeChecker_NBETerm.embed - er cb r1 in - FStar_Pervasives_Native.Some - uu___40)))))))))))))))))))) - | uu___ -> - FStar_Pervasives_Native.None \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_Interpreter.ml b/ocaml/fstar-lib/generated/FStar_Tactics_Interpreter.ml deleted file mode 100644 index c07a8ac1377..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Tactics_Interpreter.ml +++ /dev/null @@ -1,1224 +0,0 @@ -open Prims -let (dbg_Tac : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Tac" -let solve : 'a . 'a -> 'a = fun ev -> ev -let embed : - 'a . - 'a FStar_Syntax_Embeddings_Base.embedding -> - FStar_Compiler_Range_Type.range -> - 'a -> - FStar_Syntax_Embeddings_Base.norm_cb -> FStar_Syntax_Syntax.term - = - fun uu___ -> - fun r -> - fun x -> - fun norm_cb -> - let uu___1 = FStar_Syntax_Embeddings_Base.embed uu___ x in - uu___1 r FStar_Pervasives_Native.None norm_cb -let unembed : - 'a . - 'a FStar_Syntax_Embeddings_Base.embedding -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Embeddings_Base.norm_cb -> - 'a FStar_Pervasives_Native.option - = - fun uu___ -> - fun a1 -> - fun norm_cb -> FStar_Syntax_Embeddings_Base.unembed uu___ a1 norm_cb -let (native_tactics_steps : - unit -> FStar_TypeChecker_Primops_Base.primitive_step Prims.list) = - fun uu___ -> - let step_from_native_step s = - { - FStar_TypeChecker_Primops_Base.name = (s.FStar_Tactics_Native.name); - FStar_TypeChecker_Primops_Base.arity = (s.FStar_Tactics_Native.arity); - FStar_TypeChecker_Primops_Base.univ_arity = Prims.int_zero; - FStar_TypeChecker_Primops_Base.auto_reflect = - (FStar_Pervasives_Native.Some - (s.FStar_Tactics_Native.arity - Prims.int_one)); - FStar_TypeChecker_Primops_Base.strong_reduction_ok = - (s.FStar_Tactics_Native.strong_reduction_ok); - FStar_TypeChecker_Primops_Base.requires_binder_substitution = false; - FStar_TypeChecker_Primops_Base.renorm_after = false; - FStar_TypeChecker_Primops_Base.interpretation = - (s.FStar_Tactics_Native.tactic); - FStar_TypeChecker_Primops_Base.interpretation_nbe = - (fun _cb -> - fun _us -> - FStar_TypeChecker_NBETerm.dummy_interp - s.FStar_Tactics_Native.name) - } in - let uu___1 = FStar_Tactics_Native.list_all () in - FStar_Compiler_List.map step_from_native_step uu___1 -let (__primitive_steps_ref : - FStar_TypeChecker_Primops_Base.primitive_step Prims.list - FStar_Compiler_Effect.ref) - = FStar_Compiler_Util.mk_ref [] -let (primitive_steps : - unit -> FStar_TypeChecker_Primops_Base.primitive_step Prims.list) = - fun uu___ -> - let uu___1 = native_tactics_steps () in - let uu___2 = FStar_Compiler_Effect.op_Bang __primitive_steps_ref in - FStar_Compiler_List.op_At uu___1 uu___2 -let (register_tactic_primitive_step : - FStar_TypeChecker_Primops_Base.primitive_step -> unit) = - fun s -> - let uu___ = - let uu___1 = FStar_Compiler_Effect.op_Bang __primitive_steps_ref in s - :: uu___1 in - FStar_Compiler_Effect.op_Colon_Equals __primitive_steps_ref uu___ -let rec (t_head_of : FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_app uu___1 -> - let uu___2 = FStar_Syntax_Util.head_and_args_full t in - (match uu___2 with - | (h, args) -> - let h1 = FStar_Syntax_Util.unmeta h in - let uu___3 = - let uu___4 = FStar_Syntax_Subst.compress h1 in - uu___4.FStar_Syntax_Syntax.n in - (match uu___3 with - | FStar_Syntax_Syntax.Tm_uinst uu___4 -> t - | FStar_Syntax_Syntax.Tm_fvar uu___4 -> t - | FStar_Syntax_Syntax.Tm_bvar uu___4 -> t - | FStar_Syntax_Syntax.Tm_name uu___4 -> t - | FStar_Syntax_Syntax.Tm_constant uu___4 -> t - | uu___4 -> t_head_of h1)) - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = t1; - FStar_Syntax_Syntax.ret_opt = uu___1; - FStar_Syntax_Syntax.brs = uu___2; - FStar_Syntax_Syntax.rc_opt1 = uu___3;_} - -> t_head_of t1 - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t1; FStar_Syntax_Syntax.asc = uu___1; - FStar_Syntax_Syntax.eff_opt = uu___2;_} - -> t_head_of t1 - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t1; FStar_Syntax_Syntax.meta = uu___1;_} - -> t_head_of t1 - | uu___1 -> t -let unembed_tactic_0 : - 'b . - 'b FStar_Syntax_Embeddings_Base.embedding -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Embeddings_Base.norm_cb -> 'b FStar_Tactics_Monad.tac - = - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun eb -> - fun embedded_tac_b -> - fun ncb -> - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac - () () (Obj.magic FStar_Tactics_Monad.get) - (fun uu___ -> - (fun proof_state -> - let proof_state = Obj.magic proof_state in - let rng = embedded_tac_b.FStar_Syntax_Syntax.pos in - let embedded_tac_b1 = - FStar_Syntax_Util.mk_reify embedded_tac_b - (FStar_Pervasives_Native.Some - FStar_Parser_Const.effect_TAC_lid) in - let tm = - let uu___ = - let uu___1 = - let uu___2 = - embed FStar_Tactics_Embedding.e_proofstate - rng proof_state ncb in - FStar_Syntax_Syntax.as_arg uu___2 in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app embedded_tac_b1 - uu___ rng in - let steps = - [FStar_TypeChecker_Env.Weak; - FStar_TypeChecker_Env.Reify; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.DontUnfoldAttr - [FStar_Parser_Const.tac_opaque_attr]; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.Unascribe; - FStar_TypeChecker_Env.Tactics] in - let norm_f = - let uu___ = FStar_Options.tactics_nbe () in - if uu___ - then FStar_TypeChecker_NBE.normalize - else - FStar_TypeChecker_Normalize.normalize_with_primitive_steps in - let result = - let uu___ = primitive_steps () in - norm_f uu___ steps - proof_state.FStar_Tactics_Types.main_context tm in - let res = - unembed (FStar_Tactics_Embedding.e_result eb) - result ncb in - match res with - | FStar_Pervasives_Native.Some - (FStar_Tactics_Result.Success (b1, ps)) -> - Obj.magic - (Obj.repr - (let uu___ = FStar_Tactics_Monad.set ps in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () (Obj.magic b1))) uu___1))) - | FStar_Pervasives_Native.Some - (FStar_Tactics_Result.Failed (e, ps)) -> - Obj.magic - (Obj.repr - (let uu___ = FStar_Tactics_Monad.set ps in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - Obj.magic - (FStar_Tactics_Monad.traise e)) - uu___1))) - | FStar_Pervasives_Native.None -> - Obj.magic - (Obj.repr - (let h_result = t_head_of result in - let maybe_admit_tip = - let r = - Obj.magic - (FStar_Syntax_VisitM.visitM_term - FStar_Class_Monad.monad_option - false - (fun uu___ -> - (fun t -> - match t.FStar_Syntax_Syntax.n - with - | FStar_Syntax_Syntax.Tm_fvar - fv when - FStar_Syntax_Syntax.fv_eq_lid - fv - FStar_Parser_Const.admit_lid - -> - Obj.magic - FStar_Pervasives_Native.None - | uu___ -> - Obj.magic - (FStar_Pervasives_Native.Some - t)) uu___) - h_result) in - if - FStar_Pervasives_Native.uu___is_None - r - then - FStar_Pprint.doc_of_string - "The term contains an `admit`, which will not reduce. Did you mean `tadmit()`?" - else FStar_Pprint.empty in - let uu___ = - let uu___1 = - FStar_Pprint.doc_of_string - "Tactic got stuck!" in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Pprint.doc_of_string - "Reduction stopped at: " in - let uu___5 = - FStar_Class_PP.pp - FStar_Syntax_Print.pretty_term - h_result in - FStar_Pprint.op_Hat_Hat uu___4 - uu___5 in - [uu___3; maybe_admit_tip] in - uu___1 :: uu___2 in - FStar_Errors.raise_error - FStar_TypeChecker_Env.hasRange_env - proof_state.FStar_Tactics_Types.main_context - FStar_Errors_Codes.Fatal_TacticGotStuck - () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___)))) uu___))) uu___2 - uu___1 uu___ -let unembed_tactic_nbe_0 : - 'b . - 'b FStar_TypeChecker_NBETerm.embedding -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - FStar_TypeChecker_NBETerm.t -> 'b FStar_Tactics_Monad.tac - = - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun eb -> - fun cb -> - fun embedded_tac_b -> - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac - () () (Obj.magic FStar_Tactics_Monad.get) - (fun uu___ -> - (fun proof_state -> - let proof_state = Obj.magic proof_state in - let result = - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_NBETerm.embed - FStar_Tactics_Embedding.e_proofstate_nbe - cb proof_state in - FStar_TypeChecker_NBETerm.as_arg uu___2 in - [uu___1] in - FStar_TypeChecker_NBETerm.iapp_cb cb - embedded_tac_b uu___ in - let res = - FStar_TypeChecker_NBETerm.unembed - (FStar_Tactics_Embedding.e_result_nbe eb) cb - result in - match res with - | FStar_Pervasives_Native.Some - (FStar_Tactics_Result.Success (b1, ps)) -> - Obj.magic - (Obj.repr - (let uu___ = FStar_Tactics_Monad.set ps in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () (Obj.magic b1))) uu___1))) - | FStar_Pervasives_Native.Some - (FStar_Tactics_Result.Failed (e, ps)) -> - Obj.magic - (Obj.repr - (let uu___ = FStar_Tactics_Monad.set ps in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - Obj.magic - (FStar_Tactics_Monad.traise e)) - uu___1))) - | FStar_Pervasives_Native.None -> - Obj.magic - (Obj.repr - (let uu___ = - let uu___1 = - FStar_Pprint.doc_of_string - "Tactic got stuck (in NBE)!" in - let uu___2 = - let uu___3 = - FStar_Errors_Msg.text - "Please file a bug report with a minimal reproduction of this issue." in - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Pprint.doc_of_string - "Result = " in - let uu___7 = - let uu___8 = - FStar_TypeChecker_NBETerm.t_to_string - result in - FStar_Pprint.arbitrary_string - uu___8 in - FStar_Pprint.op_Hat_Hat uu___6 - uu___7 in - [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Errors.raise_error - FStar_TypeChecker_Env.hasRange_env - proof_state.FStar_Tactics_Types.main_context - FStar_Errors_Codes.Fatal_TacticGotStuck - () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___)))) uu___))) uu___2 - uu___1 uu___ -let unembed_tactic_1 : - 'a 'r . - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Embeddings_Base.norm_cb -> - 'a -> 'r FStar_Tactics_Monad.tac - = - fun ea -> - fun er -> - fun f -> - fun ncb -> - fun x -> - let rng = FStar_Compiler_Range_Type.dummyRange in - let x_tm = embed ea rng x ncb in - let app = - let uu___ = - let uu___1 = FStar_Syntax_Syntax.as_arg x_tm in [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app f uu___ rng in - unembed_tactic_0 er app ncb -let unembed_tactic_nbe_1 : - 'a 'r . - 'a FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - FStar_TypeChecker_NBETerm.nbe_cbs -> - FStar_TypeChecker_NBETerm.t -> 'a -> 'r FStar_Tactics_Monad.tac - = - fun ea -> - fun er -> - fun cb -> - fun f -> - fun x -> - let x_tm = FStar_TypeChecker_NBETerm.embed ea cb x in - let app = - let uu___ = - let uu___1 = FStar_TypeChecker_NBETerm.as_arg x_tm in - [uu___1] in - FStar_TypeChecker_NBETerm.iapp_cb cb f uu___ in - unembed_tactic_nbe_0 er cb app -let e_tactic_thunk : - 'r . - 'r FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Tactics_Monad.tac FStar_Syntax_Embeddings_Base.embedding - = - fun er -> - let uu___ = - FStar_Syntax_Embeddings_Base.term_as_fv FStar_Syntax_Syntax.t_unit in - FStar_Syntax_Embeddings_Base.mk_emb - (fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun uu___4 -> failwith "Impossible: embedding tactic (thunk)?") - (fun t -> - fun cb -> - let uu___1 = - let uu___2 = - unembed_tactic_1 FStar_Syntax_Embeddings.e_unit er t cb in - uu___2 () in - FStar_Pervasives_Native.Some uu___1) uu___ -let e_tactic_nbe_thunk : - 'r . - 'r FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_Tactics_Monad.tac FStar_TypeChecker_NBETerm.embedding - = - fun er -> - FStar_TypeChecker_NBETerm.mk_emb - (fun cb -> - fun uu___ -> failwith "Impossible: NBE embedding tactic (thunk)?") - (fun cb -> - fun t -> - let uu___ = - let uu___1 = - unembed_tactic_nbe_1 FStar_TypeChecker_NBETerm.e_unit er cb t in - uu___1 () in - FStar_Pervasives_Native.Some uu___) - (fun uu___ -> - FStar_TypeChecker_NBETerm.mk_t - (FStar_TypeChecker_NBETerm.Constant FStar_TypeChecker_NBETerm.Unit)) - (FStar_Syntax_Embeddings_Base.emb_typ_of FStar_Syntax_Embeddings.e_unit) -let e_tactic_1 : - 'a 'r . - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - ('a -> 'r FStar_Tactics_Monad.tac) - FStar_Syntax_Embeddings_Base.embedding - = - fun ea -> - fun er -> - let uu___ = - FStar_Syntax_Embeddings_Base.term_as_fv FStar_Syntax_Syntax.t_unit in - FStar_Syntax_Embeddings_Base.mk_emb - (fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun uu___4 -> failwith "Impossible: embedding tactic (1)?") - (fun t -> - fun cb -> - let uu___1 = unembed_tactic_1 ea er t cb in - FStar_Pervasives_Native.Some uu___1) uu___ -let e_tactic_nbe_1 : - 'a 'r . - 'a FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - ('a -> 'r FStar_Tactics_Monad.tac) - FStar_TypeChecker_NBETerm.embedding - = - fun ea -> - fun er -> - FStar_TypeChecker_NBETerm.mk_emb - (fun cb -> - fun uu___ -> failwith "Impossible: NBE embedding tactic (1)?") - (fun cb -> - fun t -> - let uu___ = unembed_tactic_nbe_1 ea er cb t in - FStar_Pervasives_Native.Some uu___) - (fun uu___ -> - FStar_TypeChecker_NBETerm.mk_t - (FStar_TypeChecker_NBETerm.Constant - FStar_TypeChecker_NBETerm.Unit)) - (FStar_Syntax_Embeddings_Base.emb_typ_of - FStar_Syntax_Embeddings.e_unit) -let unembed_tactic_1_alt : - 'a 'r . - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Embeddings_Base.norm_cb -> - ('a -> 'r FStar_Tactics_Monad.tac) FStar_Pervasives_Native.option - = - fun ea -> - fun er -> - fun f -> - fun ncb -> - FStar_Pervasives_Native.Some - (fun x -> - let rng = FStar_Compiler_Range_Type.dummyRange in - let x_tm = embed ea rng x ncb in - let app = - let uu___ = - let uu___1 = FStar_Syntax_Syntax.as_arg x_tm in [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app f uu___ rng in - unembed_tactic_0 er app ncb) -let e_tactic_1_alt : - 'a 'r . - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - ('a -> - FStar_Tactics_Types.proofstate -> 'r FStar_Tactics_Result.__result) - FStar_Syntax_Embeddings_Base.embedding - = - fun ea -> - fun er -> - let em uu___ uu___1 uu___2 uu___3 = - failwith "Impossible: embedding tactic (1)?" in - let un t0 n = - let uu___ = unembed_tactic_1_alt ea er t0 n in - match uu___ with - | FStar_Pervasives_Native.Some f -> - FStar_Pervasives_Native.Some - ((fun x -> let uu___1 = f x in FStar_Tactics_Monad.run uu___1)) - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None in - let uu___ = - FStar_Syntax_Embeddings_Base.term_as_fv FStar_Syntax_Syntax.t_unit in - FStar_Syntax_Embeddings_Base.mk_emb em un uu___ -let (report_implicits : - FStar_Compiler_Range_Type.range -> - FStar_TypeChecker_Rel.tagged_implicits -> unit) - = - fun rng -> - fun is -> - FStar_Compiler_List.iter - (fun uu___1 -> - match uu___1 with - | (imp, tag) -> - (match tag with - | FStar_TypeChecker_Rel.Implicit_unresolved -> - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Errors_Msg.text - "Tactic left uninstantiated unification variable:" in - let uu___5 = - FStar_Class_PP.pp FStar_Syntax_Print.pretty_uvar - (imp.FStar_TypeChecker_Common.imp_uvar).FStar_Syntax_Syntax.ctx_uvar_head in - FStar_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in - let uu___4 = - let uu___5 = - let uu___6 = FStar_Errors_Msg.text "Type:" in - let uu___7 = - let uu___8 = - FStar_Syntax_Util.ctx_uvar_typ - imp.FStar_TypeChecker_Common.imp_uvar in - FStar_Class_PP.pp FStar_Syntax_Print.pretty_term - uu___8 in - FStar_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in - let uu___6 = - let uu___7 = - let uu___8 = FStar_Errors_Msg.text "Reason:" in - let uu___9 = - let uu___10 = - FStar_Pprint.doc_of_string - imp.FStar_TypeChecker_Common.imp_reason in - FStar_Pprint.dquotes uu___10 in - FStar_Pprint.op_Hat_Slash_Hat uu___8 uu___9 in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - FStar_Errors.log_issue - FStar_Class_HasRange.hasRange_range rng - FStar_Errors_Codes.Error_UninstantiatedUnificationVarInTactic - () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___2) - | FStar_TypeChecker_Rel.Implicit_checking_defers_univ_constraint - -> - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Errors_Msg.text - "Tactic left uninstantiated unification variable:" in - let uu___5 = - FStar_Class_PP.pp FStar_Syntax_Print.pretty_uvar - (imp.FStar_TypeChecker_Common.imp_uvar).FStar_Syntax_Syntax.ctx_uvar_head in - FStar_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in - let uu___4 = - let uu___5 = - let uu___6 = FStar_Errors_Msg.text "Type:" in - let uu___7 = - let uu___8 = - FStar_Syntax_Util.ctx_uvar_typ - imp.FStar_TypeChecker_Common.imp_uvar in - FStar_Class_PP.pp FStar_Syntax_Print.pretty_term - uu___8 in - FStar_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in - let uu___6 = - let uu___7 = - let uu___8 = FStar_Errors_Msg.text "Reason:" in - let uu___9 = - let uu___10 = - FStar_Pprint.doc_of_string - imp.FStar_TypeChecker_Common.imp_reason in - FStar_Pprint.dquotes uu___10 in - FStar_Pprint.op_Hat_Slash_Hat uu___8 uu___9 in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - FStar_Errors.log_issue - FStar_Class_HasRange.hasRange_range rng - FStar_Errors_Codes.Error_UninstantiatedUnificationVarInTactic - () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___2) - | FStar_TypeChecker_Rel.Implicit_has_typing_guard (tm, ty) -> - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Errors_Msg.text "Tactic solved goal:" in - let uu___5 = - FStar_Class_PP.pp FStar_Syntax_Print.pretty_uvar - (imp.FStar_TypeChecker_Common.imp_uvar).FStar_Syntax_Syntax.ctx_uvar_head in - FStar_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in - let uu___4 = - let uu___5 = - let uu___6 = FStar_Errors_Msg.text "Type:" in - let uu___7 = - let uu___8 = - FStar_Syntax_Util.ctx_uvar_typ - imp.FStar_TypeChecker_Common.imp_uvar in - FStar_Class_PP.pp FStar_Syntax_Print.pretty_term - uu___8 in - FStar_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in - let uu___6 = - let uu___7 = - let uu___8 = FStar_Errors_Msg.text "To the term:" in - let uu___9 = - FStar_Class_PP.pp - FStar_Syntax_Print.pretty_term tm in - FStar_Pprint.op_Hat_Slash_Hat uu___8 uu___9 in - let uu___8 = - let uu___9 = - FStar_Errors_Msg.text - "But it has a non-trivial typing guard. Use gather_or_solve_explicit_guards_for_resolved_goals to inspect and prove these goals" in - [uu___9] in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - FStar_Errors.log_issue - FStar_Class_HasRange.hasRange_range rng - FStar_Errors_Codes.Error_UninstantiatedUnificationVarInTactic - () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___2))) is; - FStar_Errors.stop_if_err () -let run_unembedded_tactic_on_ps : - 'a 'b . - FStar_Compiler_Range_Type.range -> - FStar_Compiler_Range_Type.range -> - Prims.bool -> - 'a -> - ('a -> 'b FStar_Tactics_Monad.tac) -> - FStar_Tactics_Types.proofstate -> - (FStar_Tactics_Types.goal Prims.list * 'b) - = - fun rng_call -> - fun rng_goal -> - fun background -> - fun arg -> - fun tau -> - fun ps -> - let ps1 = - { - FStar_Tactics_Types.main_context = - (let uu___ = ps.FStar_Tactics_Types.main_context in - { - FStar_TypeChecker_Env.solver = - (uu___.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (uu___.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (uu___.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (uu___.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (uu___.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (uu___.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (uu___.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (uu___.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (uu___.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (uu___.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (uu___.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (uu___.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (uu___.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (uu___.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (uu___.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (uu___.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (uu___.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (uu___.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (uu___.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (uu___.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (uu___.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (uu___.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (uu___.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (uu___.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = true; - FStar_TypeChecker_Env.nocoerce = - (uu___.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (uu___.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (uu___.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (uu___.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (uu___.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (uu___.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (uu___.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (uu___.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (uu___.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (uu___.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (uu___.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (uu___.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (uu___.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (uu___.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (uu___.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (uu___.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (uu___.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (uu___.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (uu___.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (uu___.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (uu___.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (uu___.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (uu___.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (uu___.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (uu___.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (uu___.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (uu___.FStar_TypeChecker_Env.missing_decl) - }); - FStar_Tactics_Types.all_implicits = - (ps.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = (ps.FStar_Tactics_Types.goals); - FStar_Tactics_Types.smt_goals = - (ps.FStar_Tactics_Types.smt_goals); - FStar_Tactics_Types.depth = (ps.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = - (ps.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = (ps.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (ps.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = - (ps.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness = - (ps.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg = - (ps.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = - (ps.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency = - (ps.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure = - (ps.FStar_Tactics_Types.dump_on_failure) - } in - let ps2 = - { - FStar_Tactics_Types.main_context = - (let uu___ = ps1.FStar_Tactics_Types.main_context in - { - FStar_TypeChecker_Env.solver = - (uu___.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = rng_goal; - FStar_TypeChecker_Env.curmodule = - (uu___.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (uu___.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (uu___.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (uu___.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (uu___.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (uu___.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (uu___.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (uu___.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (uu___.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (uu___.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (uu___.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (uu___.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (uu___.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (uu___.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (uu___.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (uu___.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (uu___.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (uu___.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (uu___.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (uu___.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (uu___.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (uu___.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (uu___.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (uu___.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (uu___.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (uu___.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (uu___.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (uu___.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (uu___.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (uu___.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (uu___.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (uu___.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (uu___.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (uu___.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (uu___.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (uu___.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (uu___.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (uu___.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (uu___.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (uu___.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (uu___.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (uu___.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (uu___.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (uu___.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (uu___.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (uu___.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (uu___.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (uu___.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (uu___.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (uu___.FStar_TypeChecker_Env.missing_decl) - }); - FStar_Tactics_Types.all_implicits = - (ps1.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = (ps1.FStar_Tactics_Types.goals); - FStar_Tactics_Types.smt_goals = - (ps1.FStar_Tactics_Types.smt_goals); - FStar_Tactics_Types.depth = (ps1.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = - (ps1.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = (ps1.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (ps1.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = - (ps1.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness = - (ps1.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg = - (ps1.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = - (ps1.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency = - (ps1.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure = - (ps1.FStar_Tactics_Types.dump_on_failure) - } in - let env = ps2.FStar_Tactics_Types.main_context in - let res = - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_Env.current_module - ps2.FStar_Tactics_Types.main_context in - FStar_Ident.string_of_lid uu___2 in - FStar_Pervasives_Native.Some uu___1 in - FStar_Profiling.profile - (fun uu___1 -> - let uu___2 = tau arg in - FStar_Tactics_Monad.run_safe uu___2 ps2) uu___ - "FStar.Tactics.Interpreter.run_safe" in - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_Tac in - if uu___1 then FStar_Compiler_Util.print_string "}\n" else ()); - (match res with - | FStar_Tactics_Result.Success (ret, ps3) -> - ((let uu___2 = FStar_Compiler_Effect.op_Bang dbg_Tac in - if uu___2 - then - FStar_Tactics_Printing.do_dump_proofstate ps3 - "at the finish line" - else ()); - (let remaining_smt_goals = - FStar_Compiler_List.op_At - ps3.FStar_Tactics_Types.goals - ps3.FStar_Tactics_Types.smt_goals in - FStar_Compiler_List.iter - (fun g -> - FStar_Tactics_Monad.mark_goal_implicit_already_checked - g; - (let uu___4 = FStar_Tactics_Monad.is_irrelevant g in - if uu___4 - then - ((let uu___6 = - FStar_Compiler_Effect.op_Bang dbg_Tac in - if uu___6 - then - let uu___7 = - let uu___8 = - FStar_Tactics_Types.goal_witness g in - FStar_Class_Show.show - FStar_Syntax_Print.showable_term uu___8 in - FStar_Compiler_Util.print1 - "Assigning irrelevant goal %s\n" uu___7 - else ()); - (let uu___6 = - let uu___7 = FStar_Tactics_Types.goal_env g in - let uu___8 = - FStar_Tactics_Types.goal_witness g in - FStar_TypeChecker_Rel.teq_nosmt_force uu___7 - uu___8 FStar_Syntax_Util.exp_unit in - if uu___6 - then () - else - (let uu___8 = - let uu___9 = - let uu___10 = - FStar_Tactics_Types.goal_witness g in - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - uu___10 in - FStar_Compiler_Util.format1 - "Irrelevant tactic witness does not unify with (): %s" - uu___9 in - failwith uu___8))) - else ())) remaining_smt_goals; - FStar_Errors.with_ctx - "While checking implicits left by a tactic" - (fun uu___4 -> - (let uu___6 = FStar_Compiler_Effect.op_Bang dbg_Tac in - if uu___6 - then - let uu___7 = - (FStar_Common.string_of_list ()) - (fun imp -> - FStar_Class_Show.show - FStar_Syntax_Print.showable_ctxu - imp.FStar_TypeChecker_Common.imp_uvar) - ps3.FStar_Tactics_Types.all_implicits in - FStar_Compiler_Util.print1 - "About to check tactic implicits: %s\n" uu___7 - else ()); - (let g = - let uu___6 = - FStar_Class_Listlike.from_list - (FStar_Compiler_CList.listlike_clist ()) - ps3.FStar_Tactics_Types.all_implicits in - { - FStar_TypeChecker_Common.guard_f = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.guard_f); - FStar_TypeChecker_Common.deferred_to_tac = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = uu___6 - } in - let g1 = - FStar_TypeChecker_Rel.solve_deferred_constraints - env g in - (let uu___7 = - FStar_Compiler_Effect.op_Bang dbg_Tac in - if uu___7 - then - let uu___8 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_nat) - (FStar_Compiler_List.length - ps3.FStar_Tactics_Types.all_implicits) in - let uu___9 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_TypeChecker_Common.showable_implicit) - ps3.FStar_Tactics_Types.all_implicits in - FStar_Compiler_Util.print2 - "Checked %s implicits (1): %s\n" uu___8 - uu___9 - else ()); - (let tagged_implicits = - FStar_TypeChecker_Rel.resolve_implicits_tac env - g1 in - (let uu___8 = - FStar_Compiler_Effect.op_Bang dbg_Tac in - if uu___8 - then - let uu___9 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_nat) - (FStar_Compiler_List.length - ps3.FStar_Tactics_Types.all_implicits) in - let uu___10 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_TypeChecker_Common.showable_implicit) - ps3.FStar_Tactics_Types.all_implicits in - FStar_Compiler_Util.print2 - "Checked %s implicits (2): %s\n" uu___9 - uu___10 - else ()); - report_implicits rng_goal tagged_implicits))); - (remaining_smt_goals, ret))) - | FStar_Tactics_Result.Failed - (FStar_Errors.Error (code, msg, rng, ctx), ps3) -> - let msg1 = - let uu___1 = FStar_Pprint.doc_of_string "Tactic failed" in - uu___1 :: msg in - FStar_Compiler_Effect.raise - (FStar_Errors.Error (code, msg1, rng, ctx)) - | FStar_Tactics_Result.Failed (e, ps3) -> - (if ps3.FStar_Tactics_Types.dump_on_failure - then - FStar_Tactics_Printing.do_dump_proofstate ps3 - "at the time of failure" - else (); - (let texn_to_doc e1 = - match e1 with - | FStar_Tactics_Common.TacticFailure msg -> msg - | FStar_Tactics_Common.EExn t -> - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - Prims.strcat "Uncaught exception: " uu___5 in - FStar_Pprint.doc_of_string uu___4 in - [uu___3] in - (uu___2, FStar_Pervasives_Native.None) - | e2 -> FStar_Compiler_Effect.raise e2 in - let uu___2 = texn_to_doc e in - match uu___2 with - | (doc, rng) -> - let rng1 = - if background - then - match ps3.FStar_Tactics_Types.goals with - | g::uu___3 -> - (g.FStar_Tactics_Types.goal_ctx_uvar).FStar_Syntax_Syntax.ctx_uvar_range - | uu___3 -> rng_call - else - (match rng with - | FStar_Pervasives_Native.Some r -> r - | uu___4 -> ps3.FStar_Tactics_Types.entry_range) in - let uu___3 = - let uu___4 = - if ps3.FStar_Tactics_Types.dump_on_failure - then - let uu___5 = - FStar_Pprint.doc_of_string "Tactic failed" in - [uu___5] - else [] in - FStar_Compiler_List.op_At uu___4 doc in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range rng1 - FStar_Errors_Codes.Fatal_UserTacticFailure () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___3)))) -let run_tactic_on_ps' : - 'a 'b . - FStar_Compiler_Range_Type.range -> - FStar_Compiler_Range_Type.range -> - Prims.bool -> - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'a -> - 'b FStar_Syntax_Embeddings_Base.embedding -> - FStar_Syntax_Syntax.term -> - Prims.bool -> - FStar_Tactics_Types.proofstate -> - (FStar_Tactics_Types.goal Prims.list * 'b) - = - fun rng_call -> - fun rng_goal -> - fun background -> - fun e_arg -> - fun arg -> - fun e_res -> - fun tactic -> - fun tactic_already_typed -> - fun ps -> - let env = ps.FStar_Tactics_Types.main_context in - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_Tac in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term tactic in - let uu___3 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - tactic_already_typed in - FStar_Compiler_Util.print2 - "Typechecking tactic: (%s) (already_typed: %s) {\n" - uu___2 uu___3 - else ()); - (let g = - if tactic_already_typed - then FStar_TypeChecker_Env.trivial_guard - else - (let uu___2 = - let uu___3 = - FStar_Syntax_Embeddings_Base.type_of e_arg in - let uu___4 = - FStar_Syntax_Embeddings_Base.type_of e_res in - FStar_TypeChecker_TcTerm.tc_tactic uu___3 uu___4 - env tactic in - match uu___2 with | (uu___3, uu___4, g1) -> g1) in - (let uu___2 = FStar_Compiler_Effect.op_Bang dbg_Tac in - if uu___2 - then FStar_Compiler_Util.print_string "}\n" - else ()); - FStar_TypeChecker_Rel.force_trivial_guard env g; - FStar_Errors.stop_if_err (); - (let tau = - unembed_tactic_1 e_arg e_res tactic - FStar_Syntax_Embeddings_Base.id_norm_cb in - run_unembedded_tactic_on_ps rng_call rng_goal - background arg tau ps)) -let run_tactic_on_ps : - 'a 'b . - FStar_Compiler_Range_Type.range -> - FStar_Compiler_Range_Type.range -> - Prims.bool -> - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'a -> - 'b FStar_Syntax_Embeddings_Base.embedding -> - FStar_Syntax_Syntax.term -> - Prims.bool -> - FStar_Tactics_Types.proofstate -> - (FStar_Tactics_Types.goal Prims.list * 'b) - = - fun rng_call -> - fun rng_goal -> - fun background -> - fun e_arg -> - fun arg -> - fun e_res -> - fun tactic -> - fun tactic_already_typed -> - fun ps -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_Env.current_module - ps.FStar_Tactics_Types.main_context in - FStar_Ident.string_of_lid uu___2 in - FStar_Pervasives_Native.Some uu___1 in - FStar_Profiling.profile - (fun uu___1 -> - run_tactic_on_ps' rng_call rng_goal background e_arg - arg e_res tactic tactic_already_typed ps) uu___ - "FStar.Tactics.Interpreter.run_tactic_on_ps" \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_MApply.ml b/ocaml/fstar-lib/generated/FStar_Tactics_MApply.ml index a2926aa9f0a..ea0930c9b84 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_MApply.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_MApply.ml @@ -51,9 +51,9 @@ let rec (apply_squash_or_lem : | () -> let uu___2 = FStar_Tactics_V2_Derived.apply - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Squash"; "return_squash"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -111,7 +111,7 @@ let rec (apply_squash_or_lem : (fun uu___6 -> (fun uu___6 -> Obj.magic - (FStar_Tactics_V2_Builtins.tc + (FStarC_Tactics_V2_Builtins.tc uu___6 t)) uu___6) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -162,7 +162,7 @@ let rec (apply_squash_or_lem : (match FStar_Tactics_NamedView.inspect_comp c with - | FStar_Reflection_V2_Data.C_Lemma + | FStarC_Reflection_V2_Data.C_Lemma (pre, post, uu___7) -> @@ -174,13 +174,13 @@ let rec (apply_squash_or_lem : (FStar_Tactics_Effect.lift_div_tac (fun uu___9 -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App (post, - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const - FStar_Reflection_V2_Data.C_Unit)), - FStar_Reflection_V2_Data.Q_Explicit))))) in + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const + FStarC_Reflection_V2_Data.C_Unit)), + FStarC_Reflection_V2_Data.Q_Explicit))))) in FStar_Tactics_Effect.tac_bind ( FStar_Sealed.seal @@ -277,9 +277,9 @@ let rec (apply_squash_or_lem : (let uu___12 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "MApply"; @@ -325,7 +325,7 @@ let rec (apply_squash_or_lem : uu___11))) uu___10))) uu___9))) - | FStar_Reflection_V2_Data.C_Total + | FStarC_Reflection_V2_Data.C_Total rt -> Obj.magic (Obj.repr @@ -400,9 +400,9 @@ let rec (apply_squash_or_lem : (let uu___10 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "MApply"; @@ -512,9 +512,9 @@ let rec (apply_squash_or_lem : let uu___10 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "MApply"; @@ -557,9 +557,9 @@ let rec (apply_squash_or_lem : let uu___11 = FStar_Tactics_V2_Derived.apply - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Squash"; "return_squash"]))) in @@ -605,17 +605,17 @@ let (mapply0 : FStar_Tactics_NamedView.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun t -> apply_squash_or_lem (Prims.of_int (10)) t let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.MApply.mapply0" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.MApply.mapply0" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.MApply.mapply0 (plugin)" - (FStar_Tactics_Native.from_tactic_1 mapply0) - FStar_Reflection_V2_Embeddings.e_term - FStar_Syntax_Embeddings.e_unit psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 mapply0) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let mapply : 'ty . 'ty termable -> 'ty -> (unit, unit) FStar_Tactics_Effect.tac_repr = fun uu___ -> diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_MkProjectors.ml b/ocaml/fstar-lib/generated/FStar_Tactics_MkProjectors.ml index 6dea1ae6794..c3685c5ad9e 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_MkProjectors.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_MkProjectors.ml @@ -7,7 +7,7 @@ let (debug : (unit, unit) FStar_Tactics_Effect.tac_repr) = fun f -> - let uu___ = FStar_Tactics_V2_Builtins.debugging () in + let uu___ = FStarC_Tactics_V2_Builtins.debugging () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -43,7 +43,7 @@ let (debug : (fun uu___3 -> (fun uu___3 -> Obj.magic - (FStar_Tactics_V2_Builtins.print uu___3)) + (FStarC_Tactics_V2_Builtins.print uu___3)) uu___3))) else Obj.magic @@ -61,7 +61,7 @@ let (mk_one_projector : debug (fun uu___1 -> let uu___2 = - FStar_Tactics_V2_Builtins.dump "ENTRY mk_one_projector" in + FStarC_Tactics_V2_Builtins.dump "ENTRY mk_one_projector" in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -90,7 +90,7 @@ let (mk_one_projector : (Obj.magic uu___) (fun uu___1 -> (fun uu___1 -> - let uu___2 = FStar_Tactics_V2_Builtins.intros np in + let uu___2 = FStarC_Tactics_V2_Builtins.intros np in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -108,7 +108,7 @@ let (mk_one_projector : (Obj.magic uu___2) (fun uu___3 -> (fun _params -> - let uu___3 = FStar_Tactics_V2_Builtins.intro () in + let uu___3 = FStarC_Tactics_V2_Builtins.intro () in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -131,7 +131,7 @@ let (mk_one_projector : (fun uu___4 -> (fun thing -> let uu___4 = - FStar_Tactics_V2_Builtins.t_destruct + FStarC_Tactics_V2_Builtins.t_destruct (FStar_Tactics_V2_SyntaxCoercions.binding_to_term thing) in Obj.magic @@ -196,7 +196,7 @@ let (mk_one_projector : -> let uu___7 = - FStar_Tactics_V2_Builtins.intros + FStarC_Tactics_V2_Builtins.intros i in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -224,7 +224,7 @@ let (mk_one_projector : uu___8 -> let uu___9 = - FStar_Tactics_V2_Builtins.intro + FStarC_Tactics_V2_Builtins.intro () in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -253,7 +253,7 @@ let (mk_one_projector : the_b -> let uu___10 = - FStar_Tactics_V2_Builtins.intros + FStarC_Tactics_V2_Builtins.intros ((arity - i) - Prims.int_one) in @@ -285,7 +285,7 @@ let (mk_one_projector : -> let uu___12 = - FStar_Tactics_V2_Builtins.intro + FStarC_Tactics_V2_Builtins.intro () in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -314,7 +314,7 @@ let (mk_one_projector : -> let uu___13 = - FStar_Tactics_V2_Builtins.rewrite + FStarC_Tactics_V2_Builtins.rewrite eq_b in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -344,7 +344,7 @@ let (mk_one_projector : -> let uu___15 = - FStar_Tactics_V2_Builtins.norm + FStarC_Tactics_V2_Builtins.norm [FStar_Pervasives.iota; FStar_Pervasives.delta_only unf; @@ -394,19 +394,19 @@ let (mk_one_projector : uu___5))) uu___4))) uu___3))) uu___1) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.MkProjectors.mk_one_projector" (Prims.of_int (4)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_3 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_3 "FStar.Tactics.MkProjectors.mk_one_projector (plugin)" - (FStar_Tactics_Native.from_tactic_3 mk_one_projector) - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_string) - FStar_Syntax_Embeddings.e_int FStar_Syntax_Embeddings.e_int - FStar_Syntax_Embeddings.e_unit psc ncb us args) + (FStarC_Tactics_Native.from_tactic_3 mk_one_projector) + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_string) + FStarC_Syntax_Embeddings.e_int FStarC_Syntax_Embeddings.e_int + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (mk_one_method : Prims.string -> Prims.nat -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun proj -> @@ -415,7 +415,7 @@ let (mk_one_method : debug (fun uu___1 -> let uu___2 = - FStar_Tactics_V2_Builtins.dump "ENTRY mk_one_method" in + FStarC_Tactics_V2_Builtins.dump "ENTRY mk_one_method" in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -447,7 +447,7 @@ let (mk_one_method : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> - FStar_Reflection_V2_Builtins.explode_qn proj)) in + FStarC_Reflection_V2_Builtins.explode_qn proj)) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -469,7 +469,7 @@ let (mk_one_method : FStar_Tactics_Util.repeatn np (fun uu___4 -> let uu___5 = - FStar_Tactics_V2_Builtins.intro () in + FStarC_Tactics_V2_Builtins.intro () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -493,7 +493,7 @@ let (mk_one_method : (fun uu___6 -> ((FStar_Tactics_V2_SyntaxCoercions.binding_to_term b), - FStar_Reflection_V2_Data.Q_Implicit)))) in + FStarC_Reflection_V2_Data.Q_Implicit)))) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -516,7 +516,7 @@ let (mk_one_method : (fun uu___4 -> (fun params -> let uu___4 = - FStar_Tactics_V2_Builtins.intro () in + FStarC_Tactics_V2_Builtins.intro () in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -544,7 +544,7 @@ let (mk_one_method : (fun uu___6 -> FStar_Tactics_NamedView.pack (FStar_Tactics_NamedView.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_fv nm)))) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -576,23 +576,24 @@ let (mk_one_method : [ ((FStar_Tactics_V2_SyntaxCoercions.binding_to_term thing), - FStar_Reflection_V2_Data.Q_Explicit)])))) + FStarC_Reflection_V2_Data.Q_Explicit)])))) uu___6))) uu___5))) uu___4))) uu___3))) uu___1) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.MkProjectors.mk_one_method" (Prims.of_int (3)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_2 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_2 "FStar.Tactics.MkProjectors.mk_one_method (plugin)" - (FStar_Tactics_Native.from_tactic_2 mk_one_method) - FStar_Syntax_Embeddings.e_string FStar_Syntax_Embeddings.e_int - FStar_Syntax_Embeddings.e_unit psc ncb us args) + (FStarC_Tactics_Native.from_tactic_2 mk_one_method) + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_int FStarC_Syntax_Embeddings.e_unit + psc ncb us args) let (subst_map : - (FStar_Tactics_NamedView.namedv * FStar_Reflection_Types.fv) Prims.list -> + (FStar_Tactics_NamedView.namedv * FStarC_Reflection_Types.fv) Prims.list -> FStar_Tactics_NamedView.term -> FStar_Tactics_NamedView.term -> (FStar_Tactics_NamedView.term, unit) FStar_Tactics_Effect.tac_repr) @@ -606,13 +607,13 @@ let (subst_map : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> - FStar_Reflection_V2_Builtins.subst_term + FStarC_Reflection_V2_Builtins.subst_term (FStar_List_Tot_Base.map (fun uu___1 -> match uu___1 with | (x, fv) -> - FStar_Syntax_Syntax.NT - ((FStar_Reflection_V2_Builtins.pack_namedv + FStarC_Syntax_Syntax.NT + ((FStarC_Reflection_V2_Builtins.pack_namedv x), (FStar_Reflection_V2_Derived.mk_e_app (FStar_Tactics_NamedView.pack @@ -624,8 +625,8 @@ let (binder_mk_implicit : fun b -> let q = match b.FStar_Tactics_NamedView.qual with - | FStar_Reflection_V2_Data.Q_Explicit -> - FStar_Reflection_V2_Data.Q_Implicit + | FStarC_Reflection_V2_Data.Q_Explicit -> + FStarC_Reflection_V2_Data.Q_Implicit | q1 -> q1 in { FStar_Tactics_NamedView.uniq = (b.FStar_Tactics_NamedView.uniq); @@ -641,12 +642,12 @@ let (binder_to_term : (FStar_Tactics_NamedView.Tv_Var (FStar_Tactics_V2_SyntaxCoercions.binder_to_namedv b)) let (binder_argv : - FStar_Tactics_NamedView.binder -> FStar_Reflection_V2_Data.argv) = + FStar_Tactics_NamedView.binder -> FStarC_Reflection_V2_Data.argv) = fun b -> let q = match b.FStar_Tactics_NamedView.qual with - | FStar_Reflection_V2_Data.Q_Meta uu___ -> - FStar_Reflection_V2_Data.Q_Implicit + | FStarC_Reflection_V2_Data.Q_Meta uu___ -> + FStarC_Reflection_V2_Data.Q_Implicit | q1 -> q1 in ((binder_to_term b), q) let rec list_last : @@ -663,21 +664,21 @@ let rec list_last : | uu___::xs1 -> Obj.magic (Obj.repr (list_last xs1))) uu___ let (embed_int : Prims.int -> FStar_Tactics_NamedView.term) = fun i -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const (FStar_Reflection_V2_Data.C_Int i)) + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const (FStarC_Reflection_V2_Data.C_Int i)) let (embed_string : Prims.string -> FStar_Tactics_NamedView.term) = fun s -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const - (FStar_Reflection_V2_Data.C_String s)) + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const + (FStarC_Reflection_V2_Data.C_String s)) let (substitute_attr : FStar_Tactics_NamedView.term) = - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Pervasives"; "Substitute"])) let (mk_proj_decl : Prims.bool -> - FStar_Reflection_Types.name -> + FStarC_Reflection_Types.name -> Prims.string Prims.list -> FStar_Tactics_NamedView.univ_name Prims.list -> FStar_Tactics_NamedView.binder Prims.list -> @@ -685,9 +686,9 @@ let (mk_proj_decl : FStar_Tactics_NamedView.binder -> FStar_Tactics_NamedView.term -> (FStar_Tactics_NamedView.namedv * - FStar_Reflection_Types.fv) Prims.list -> - ((FStar_Reflection_Types.sigelt Prims.list * - FStar_Reflection_Types.fv), + FStarC_Reflection_Types.fv) Prims.list -> + ((FStarC_Reflection_Types.sigelt Prims.list * + FStarC_Reflection_Types.fv), unit) FStar_Tactics_Effect.tac_repr) = fun is_method -> @@ -746,7 +747,7 @@ let (mk_proj_decl : debug (fun uu___3 -> let uu___4 = - FStar_Tactics_V2_Builtins.term_to_string + FStarC_Tactics_V2_Builtins.term_to_string field.FStar_Tactics_NamedView.sort in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -822,7 +823,7 @@ let (mk_proj_decl : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___6 -> - FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_fv tyqn)) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1092,7 +1093,7 @@ let (mk_proj_decl : (FStar_Tactics_Effect.lift_div_tac (fun uu___8 -> - FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_fv nm)) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1267,7 +1268,7 @@ let (mk_proj_decl : -> let uu___13 = - FStar_Tactics_V2_Builtins.term_to_string + FStarC_Tactics_V2_Builtins.term_to_string projty in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1343,55 +1344,55 @@ let (mk_proj_decl : = projty; FStar_Tactics_NamedView.lb_def = - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Effect"; "synth_by_tactic"]))), - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Abs - ((FStar_Reflection_V2_Builtins.pack_binder + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Abs + ((FStarC_Reflection_V2_Builtins.pack_binder { - FStar_Reflection_V2_Data.sort2 + FStarC_Reflection_V2_Data.sort2 = - (FStar_Reflection_V2_Builtins.pack_ln - FStar_Reflection_V2_Data.Tv_Unknown); - FStar_Reflection_V2_Data.qual + (FStarC_Reflection_V2_Builtins.pack_ln + FStarC_Reflection_V2_Data.Tv_Unknown); + FStarC_Reflection_V2_Data.qual = - FStar_Reflection_V2_Data.Q_Explicit; - FStar_Reflection_V2_Data.attrs + FStarC_Reflection_V2_Data.Q_Explicit; + FStarC_Reflection_V2_Data.attrs = []; - FStar_Reflection_V2_Data.ppname2 + FStarC_Reflection_V2_Data.ppname2 = (FStar_Sealed.seal "uu___") }), - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "MkProjectors"; "mk_one_projector"]))), (unfold_names_tm, - FStar_Reflection_V2_Data.Q_Explicit)))), + FStarC_Reflection_V2_Data.Q_Explicit)))), ((embed_int np), - FStar_Reflection_V2_Data.Q_Explicit)))), + FStarC_Reflection_V2_Data.Q_Explicit)))), ((embed_int idx), - FStar_Reflection_V2_Data.Q_Explicit))))))), - FStar_Reflection_V2_Data.Q_Explicit)))) + FStarC_Reflection_V2_Data.Q_Explicit))))))), + FStarC_Reflection_V2_Data.Q_Explicit)))) }] }) in Obj.magic @@ -1438,9 +1439,9 @@ let (mk_proj_decl : (if FStar_List_Tot_Base.existsb (FStar_Reflection_TermEq_Simple.term_eq - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Typeclasses"; @@ -1577,7 +1578,7 @@ let (mk_proj_decl : (fun uu___20 -> - FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_fv uu___19)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1623,10 +1624,10 @@ let (mk_proj_decl : (rb.FStar_Tactics_NamedView.sort); FStar_Tactics_NamedView.qual = - (FStar_Reflection_V2_Data.Q_Meta - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Data.Q_Meta + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Typeclasses"; @@ -1736,52 +1737,52 @@ let (mk_proj_decl : (fun uu___21 -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Effect"; "synth_by_tactic"]))), - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Abs - ((FStar_Reflection_V2_Builtins.pack_binder + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Abs + ((FStarC_Reflection_V2_Builtins.pack_binder { - FStar_Reflection_V2_Data.sort2 + FStarC_Reflection_V2_Data.sort2 = - (FStar_Reflection_V2_Builtins.pack_ln - FStar_Reflection_V2_Data.Tv_Unknown); - FStar_Reflection_V2_Data.qual + (FStarC_Reflection_V2_Builtins.pack_ln + FStarC_Reflection_V2_Data.Tv_Unknown); + FStarC_Reflection_V2_Data.qual = - FStar_Reflection_V2_Data.Q_Explicit; - FStar_Reflection_V2_Data.attrs + FStarC_Reflection_V2_Data.Q_Explicit; + FStarC_Reflection_V2_Data.attrs = []; - FStar_Reflection_V2_Data.ppname2 + FStarC_Reflection_V2_Data.ppname2 = (FStar_Sealed.seal "uu___") }), - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "MkProjectors"; "mk_one_method"]))), ((embed_string - (FStar_Reflection_V2_Builtins.implode_qn + (FStarC_Reflection_V2_Builtins.implode_qn nm)), - FStar_Reflection_V2_Data.Q_Explicit)))), + FStarC_Reflection_V2_Data.Q_Explicit)))), ((embed_int np), - FStar_Reflection_V2_Data.Q_Explicit))))))), - FStar_Reflection_V2_Data.Q_Explicit))))) in + FStarC_Reflection_V2_Data.Q_Explicit))))))), + FStarC_Reflection_V2_Data.Q_Explicit))))) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1886,12 +1887,12 @@ let (mk_proj_decl : uu___15 -> ((( - FStar_Reflection_V2_Builtins.set_sigelt_attrs + FStarC_Reflection_V2_Builtins.set_sigelt_attrs (FStar_List_Tot_Base.op_At (substitute_attr :: (field.FStar_Tactics_NamedView.attrs)) - (FStar_Reflection_V2_Builtins.sigelt_attrs + (FStarC_Reflection_V2_Builtins.sigelt_attrs se_proj)) se_proj) :: @@ -1909,7 +1910,7 @@ let (mk_proj_decl : let (mk_projs : Prims.bool -> Prims.string -> - (FStar_Reflection_Types.sigelt Prims.list, unit) + (FStarC_Reflection_Types.sigelt Prims.list, unit) FStar_Tactics_Effect.tac_repr) = fun is_class -> @@ -1941,7 +1942,7 @@ let (mk_projs : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> - FStar_Reflection_V2_Builtins.explode_qn tyname)) in + FStarC_Reflection_V2_Builtins.explode_qn tyname)) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1960,7 +1961,7 @@ let (mk_projs : (fun uu___3 -> (fun tyqn -> let uu___3 = - let uu___4 = FStar_Tactics_V2_Builtins.top_env () in + let uu___4 = FStarC_Tactics_V2_Builtins.top_env () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1981,7 +1982,7 @@ let (mk_projs : (fun uu___5 -> FStar_Tactics_Effect.lift_div_tac (fun uu___6 -> - FStar_Reflection_V2_Builtins.lookup_typ + FStarC_Reflection_V2_Builtins.lookup_typ uu___5 tyqn)) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -2273,22 +2274,22 @@ let (mk_projs : (fun uu___18 -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_UInst - ((FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_UInst + ((FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "Nil"]), [ - FStar_Reflection_V2_Builtins.pack_universe - FStar_Reflection_V2_Data.Uv_Zero]))), - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_universe + FStarC_Reflection_V2_Data.Uv_Zero]))), + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "string"]))), - FStar_Reflection_V2_Data.Q_Implicit))))) in + FStarC_Reflection_V2_Data.Q_Implicit))))) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -2378,33 +2379,33 @@ let (mk_projs : field), fv) :: smap), - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_UInst - ((FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_UInst + ((FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "Cons"]), [ - FStar_Reflection_V2_Builtins.pack_universe - FStar_Reflection_V2_Data.Uv_Zero]))), - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_universe + FStarC_Reflection_V2_Data.Uv_Zero]))), + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "string"]))), - FStar_Reflection_V2_Data.Q_Implicit)))), + FStarC_Reflection_V2_Data.Q_Implicit)))), ((embed_string - (FStar_Reflection_V2_Builtins.implode_qn - (FStar_Reflection_V2_Builtins.inspect_fv + (FStarC_Reflection_V2_Builtins.implode_qn + (FStarC_Reflection_V2_Builtins.inspect_fv fv))), - FStar_Reflection_V2_Data.Q_Explicit)))), + FStarC_Reflection_V2_Data.Q_Explicit)))), (unfold_names_tm1, - FStar_Reflection_V2_Data.Q_Explicit)))), + FStarC_Reflection_V2_Data.Q_Explicit)))), (idx + Prims.int_one))))) ([], [], @@ -2460,16 +2461,16 @@ let (mk_projs : uu___6)))) uu___4))) uu___3))) uu___1) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.MkProjectors.mk_projs" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.MkProjectors.mk_projs" (Prims.of_int (3)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_2 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_2 "FStar.Tactics.MkProjectors.mk_projs (plugin)" - (FStar_Tactics_Native.from_tactic_2 mk_projs) - FStar_Syntax_Embeddings.e_bool - FStar_Syntax_Embeddings.e_string - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_sigelt) psc ncb us args) \ No newline at end of file + (FStarC_Tactics_Native.from_tactic_2 mk_projs) + FStarC_Syntax_Embeddings.e_bool + FStarC_Syntax_Embeddings.e_string + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_sigelt) psc ncb us args) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_Monad.ml b/ocaml/fstar-lib/generated/FStar_Tactics_Monad.ml deleted file mode 100644 index 0678fbbdeab..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Tactics_Monad.ml +++ /dev/null @@ -1,1411 +0,0 @@ -open Prims -let (dbg_Core : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Core" -let (dbg_CoreEq : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "CoreEq" -let (dbg_RegisterGoal : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "RegisterGoal" -let (dbg_TacFail : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "TacFail" -let (goal_ctr : Prims.int FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref Prims.int_zero -let (get_goal_ctr : unit -> Prims.int) = - fun uu___ -> FStar_Compiler_Effect.op_Bang goal_ctr -let (incr_goal_ctr : unit -> Prims.int) = - fun uu___ -> - let v = FStar_Compiler_Effect.op_Bang goal_ctr in - FStar_Compiler_Effect.op_Colon_Equals goal_ctr (v + Prims.int_one); v -let (is_goal_safe_as_well_typed : FStar_Tactics_Types.goal -> Prims.bool) = - fun g -> - let uv = g.FStar_Tactics_Types.goal_ctx_uvar in - let all_deps_resolved = - let uu___ = FStar_Syntax_Util.ctx_uvar_typedness_deps uv in - FStar_Compiler_List.for_all - (fun uv1 -> - let uu___1 = - FStar_Syntax_Unionfind.find - uv1.FStar_Syntax_Syntax.ctx_uvar_head in - match uu___1 with - | FStar_Pervasives_Native.Some t -> - let uu___2 = FStar_Syntax_Free.uvars t in - FStar_Class_Setlike.is_empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) (Obj.magic uu___2) - | uu___2 -> false) uu___ in - all_deps_resolved -let (register_goal : FStar_Tactics_Types.goal -> unit) = - fun g -> - let uu___ = - let uu___1 = FStar_Options.compat_pre_core_should_register () in - Prims.op_Negation uu___1 in - if uu___ - then () - else - (let env = FStar_Tactics_Types.goal_env g in - let uu___2 = - env.FStar_TypeChecker_Env.phase1 || (FStar_Options.lax ()) in - if uu___2 - then () - else - (let uv = g.FStar_Tactics_Types.goal_ctx_uvar in - let i = FStar_TypeChecker_Core.incr_goal_ctr () in - let uu___4 = - let uu___5 = - FStar_Syntax_Util.ctx_uvar_should_check - g.FStar_Tactics_Types.goal_ctx_uvar in - FStar_Syntax_Syntax.uu___is_Allow_untyped uu___5 in - if uu___4 - then () - else - (let env1 = - { - FStar_TypeChecker_Env.solver = - (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (uv.FStar_Syntax_Syntax.ctx_uvar_gamma); - FStar_TypeChecker_Env.gamma_sig = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (env.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env.FStar_TypeChecker_Env.missing_decl) - } in - (let uu___7 = FStar_Compiler_Effect.op_Bang dbg_CoreEq in - if uu___7 - then - let uu___8 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) i in - FStar_Compiler_Util.print1 "(%s) Registering goal\n" uu___8 - else ()); - (let should_register = is_goal_safe_as_well_typed g in - if Prims.op_Negation should_register - then - let uu___8 = - (FStar_Compiler_Effect.op_Bang dbg_Core) || - (FStar_Compiler_Effect.op_Bang dbg_RegisterGoal) in - (if uu___8 - then - let uu___9 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) i in - FStar_Compiler_Util.print1 - "(%s) Not registering goal since it has unresolved uvar deps\n" - uu___9 - else ()) - else - ((let uu___9 = - (FStar_Compiler_Effect.op_Bang dbg_Core) || - (FStar_Compiler_Effect.op_Bang dbg_RegisterGoal) in - if uu___9 - then - let uu___10 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) i in - let uu___11 = - FStar_Class_Show.show FStar_Syntax_Print.showable_ctxu - uv in - FStar_Compiler_Util.print2 - "(%s) Registering goal for %s\n" uu___10 uu___11 - else ()); - (let goal_ty = FStar_Syntax_Util.ctx_uvar_typ uv in - let uu___9 = - FStar_TypeChecker_Core.compute_term_type_handle_guards - env1 goal_ty (fun uu___10 -> fun uu___11 -> true) in - match uu___9 with - | FStar_Pervasives.Inl uu___10 -> () - | FStar_Pervasives.Inr err -> - let msg = - let uu___10 = - let uu___11 = FStar_Syntax_Util.ctx_uvar_typ uv in - FStar_Class_Show.show - FStar_Syntax_Print.showable_term uu___11 in - let uu___11 = - FStar_TypeChecker_Core.print_error_short err in - FStar_Compiler_Util.format2 - "Failed to check initial tactic goal %s because %s" - uu___10 uu___11 in - FStar_Errors.log_issue - FStar_Class_HasRange.hasRange_range - uv.FStar_Syntax_Syntax.ctx_uvar_range - FStar_Errors_Codes.Warning_FailedToCheckInitialTacticGoal - () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic msg))))))) -type 'a tac = - { - tac_f: FStar_Tactics_Types.proofstate -> 'a FStar_Tactics_Result.__result } -let __proj__Mktac__item__tac_f : - 'a . - 'a tac -> - FStar_Tactics_Types.proofstate -> 'a FStar_Tactics_Result.__result - = fun projectee -> match projectee with | { tac_f;_} -> tac_f -let mk_tac : - 'a . - (FStar_Tactics_Types.proofstate -> 'a FStar_Tactics_Result.__result) -> - 'a tac - = fun f -> { tac_f = f } -let run : - 'a . - 'a tac -> - FStar_Tactics_Types.proofstate -> 'a FStar_Tactics_Result.__result - = fun t -> fun ps -> t.tac_f ps -let run_safe : - 'a . - 'a tac -> - FStar_Tactics_Types.proofstate -> 'a FStar_Tactics_Result.__result - = - fun t -> - fun ps -> - let uu___ = FStar_Options.tactics_failhard () in - if uu___ - then run t ps - else - (try (fun uu___2 -> match () with | () -> run t ps) () - with | uu___2 -> FStar_Tactics_Result.Failed (uu___2, ps)) -let ret : 'a . 'a -> 'a tac = - fun x -> mk_tac (fun ps -> FStar_Tactics_Result.Success (x, ps)) -let bind : 'a 'b . 'a tac -> ('a -> 'b tac) -> 'b tac = - fun t1 -> - fun t2 -> - mk_tac - (fun ps -> - let uu___ = run t1 ps in - match uu___ with - | FStar_Tactics_Result.Success (a1, q) -> - let uu___1 = t2 a1 in run uu___1 q - | FStar_Tactics_Result.Failed (msg, q) -> - FStar_Tactics_Result.Failed (msg, q)) -let (monad_tac : unit tac FStar_Class_Monad.monad) = - { - FStar_Class_Monad.return = - (fun uu___1 -> fun uu___ -> (fun uu___ -> Obj.magic ret) uu___1 uu___); - FStar_Class_Monad.op_let_Bang = - (fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun uu___1 -> fun uu___ -> Obj.magic bind) uu___3 uu___2 - uu___1 uu___) - } -let (set : FStar_Tactics_Types.proofstate -> unit tac) = - fun ps -> mk_tac (fun uu___ -> FStar_Tactics_Result.Success ((), ps)) -let (get : FStar_Tactics_Types.proofstate tac) = - mk_tac (fun ps -> FStar_Tactics_Result.Success (ps, ps)) -let traise : 'a . Prims.exn -> 'a tac = - fun e -> mk_tac (fun ps -> FStar_Tactics_Result.Failed (e, ps)) -let (do_log : FStar_Tactics_Types.proofstate -> (unit -> unit) -> unit) = - fun ps -> fun f -> if ps.FStar_Tactics_Types.tac_verb_dbg then f () else () -let (log : (unit -> unit) -> unit tac) = - fun f -> - mk_tac (fun ps -> do_log ps f; FStar_Tactics_Result.Success ((), ps)) -let fail_doc : 'a . FStar_Errors_Msg.error_message -> 'a tac = - fun msg -> - mk_tac - (fun ps -> - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_TacFail in - if uu___1 - then - let uu___2 = - let uu___3 = - let uu___4 = FStar_Compiler_List.hd msg in - FStar_Errors_Msg.renderdoc uu___4 in - Prims.strcat "TACTIC FAILING: " uu___3 in - FStar_Tactics_Printing.do_dump_proofstate ps uu___2 - else ()); - FStar_Tactics_Result.Failed - ((FStar_Tactics_Common.TacticFailure - (msg, FStar_Pervasives_Native.None)), ps)) -let fail : 'a . Prims.string -> 'a tac = - fun msg -> - let uu___ = let uu___1 = FStar_Errors_Msg.text msg in [uu___1] in - fail_doc uu___ -let catch : 'a . 'a tac -> (Prims.exn, 'a) FStar_Pervasives.either tac = - fun t -> - mk_tac - (fun ps -> - let idtable = - FStar_Compiler_Effect.op_Bang - (ps.FStar_Tactics_Types.main_context).FStar_TypeChecker_Env.identifier_info in - let tx = FStar_Syntax_Unionfind.new_transaction () in - let uu___ = run t ps in - match uu___ with - | FStar_Tactics_Result.Success (a1, q) -> - (FStar_Syntax_Unionfind.commit tx; - FStar_Tactics_Result.Success ((FStar_Pervasives.Inr a1), q)) - | FStar_Tactics_Result.Failed (m, q) -> - (FStar_Syntax_Unionfind.rollback tx; - FStar_Compiler_Effect.op_Colon_Equals - (ps.FStar_Tactics_Types.main_context).FStar_TypeChecker_Env.identifier_info - idtable; - (let ps1 = - { - FStar_Tactics_Types.main_context = - (ps.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits = - (ps.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = (ps.FStar_Tactics_Types.goals); - FStar_Tactics_Types.smt_goals = - (ps.FStar_Tactics_Types.smt_goals); - FStar_Tactics_Types.depth = (ps.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = - (ps.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = (ps.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (ps.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = - (ps.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness = - (q.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg = - (ps.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = - (ps.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency = - (ps.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure = - (ps.FStar_Tactics_Types.dump_on_failure) - } in - FStar_Tactics_Result.Success ((FStar_Pervasives.Inl m), ps1)))) -let recover : 'a . 'a tac -> (Prims.exn, 'a) FStar_Pervasives.either tac = - fun t -> - mk_tac - (fun ps -> - let uu___ = run t ps in - match uu___ with - | FStar_Tactics_Result.Success (a1, q) -> - FStar_Tactics_Result.Success ((FStar_Pervasives.Inr a1), q) - | FStar_Tactics_Result.Failed (m, q) -> - FStar_Tactics_Result.Success ((FStar_Pervasives.Inl m), q)) -let trytac : 'a . 'a tac -> 'a FStar_Pervasives_Native.option tac = - fun t -> - let uu___ = catch t in - bind uu___ - (fun r -> - match r with - | FStar_Pervasives.Inr v -> ret (FStar_Pervasives_Native.Some v) - | FStar_Pervasives.Inl uu___1 -> ret FStar_Pervasives_Native.None) -let trytac_exn : 'a . 'a tac -> 'a FStar_Pervasives_Native.option tac = - fun t -> - mk_tac - (fun ps -> - try - (fun uu___ -> - match () with | () -> let uu___1 = trytac t in run uu___1 ps) - () - with - | FStar_Errors.Error (uu___1, msg, uu___2, uu___3) -> - (do_log ps - (fun uu___5 -> - let uu___6 = FStar_Errors_Msg.rendermsg msg in - FStar_Compiler_Util.print1 "trytac_exn error: (%s)" uu___6); - FStar_Tactics_Result.Success (FStar_Pervasives_Native.None, ps))) -let rec iter_tac : 'a . ('a -> unit tac) -> 'a Prims.list -> unit tac = - fun f -> - fun l -> - match l with - | [] -> ret () - | hd::tl -> - let uu___ = f hd in - FStar_Class_Monad.op_let_Bang monad_tac () () uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in Obj.magic (iter_tac f tl)) - uu___1) -exception Bad of Prims.string -let (uu___is_Bad : Prims.exn -> Prims.bool) = - fun projectee -> match projectee with | Bad uu___ -> true | uu___ -> false -let (__proj__Bad__item__uu___ : Prims.exn -> Prims.string) = - fun projectee -> match projectee with | Bad uu___ -> uu___ -let (nwarn : Prims.int FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref Prims.int_zero -let (check_valid_goal : FStar_Tactics_Types.goal -> unit) = - fun g -> - let uu___ = FStar_Options.defensive () in - if uu___ - then - try - (fun uu___1 -> - match () with - | () -> - let env = FStar_Tactics_Types.goal_env g in - ((let uu___3 = - let uu___4 = - let uu___5 = FStar_Tactics_Types.goal_witness g in - FStar_TypeChecker_Env.closed env uu___5 in - Prims.op_Negation uu___4 in - if uu___3 - then FStar_Compiler_Effect.raise (Bad "witness") - else ()); - (let uu___4 = - let uu___5 = - let uu___6 = FStar_Tactics_Types.goal_type g in - FStar_TypeChecker_Env.closed env uu___6 in - Prims.op_Negation uu___5 in - if uu___4 - then FStar_Compiler_Effect.raise (Bad "goal type") - else ()); - (let rec aux e = - let uu___4 = FStar_TypeChecker_Env.pop_bv e in - match uu___4 with - | FStar_Pervasives_Native.None -> () - | FStar_Pervasives_Native.Some (bv, e1) -> - ((let uu___6 = - let uu___7 = - FStar_TypeChecker_Env.closed e1 - bv.FStar_Syntax_Syntax.sort in - Prims.op_Negation uu___7 in - if uu___6 - then - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_bv bv in - Prims.strcat "bv: " uu___9 in - Bad uu___8 in - FStar_Compiler_Effect.raise uu___7 - else ()); - aux e1) in - aux env))) () - with - | Bad culprit -> - let uu___2 = - let uu___3 = FStar_Compiler_Effect.op_Bang nwarn in - uu___3 < (Prims.of_int (5)) in - (if uu___2 - then - ((let uu___4 = FStar_Tactics_Types.goal_type g in - let uu___5 = - let uu___6 = FStar_Tactics_Printing.goal_to_string_verbose g in - FStar_Compiler_Util.format2 - "The following goal is ill-formed (%s). Keeping calm and carrying on...\n<%s>\n\n" - culprit uu___6 in - FStar_Errors.log_issue - (FStar_Syntax_Syntax.has_range_syntax ()) uu___4 - FStar_Errors_Codes.Warning_IllFormedGoal () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___5)); - (let uu___4 = - let uu___5 = FStar_Compiler_Effect.op_Bang nwarn in - uu___5 + Prims.int_one in - FStar_Compiler_Effect.op_Colon_Equals nwarn uu___4)) - else ()) - else () -let (check_valid_goals : FStar_Tactics_Types.goal Prims.list -> unit) = - fun gs -> - let uu___ = FStar_Options.defensive () in - if uu___ then FStar_Compiler_List.iter check_valid_goal gs else () -let (set_goals : FStar_Tactics_Types.goal Prims.list -> unit tac) = - fun gs -> - bind get - (fun ps -> - set - { - FStar_Tactics_Types.main_context = - (ps.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits = - (ps.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = gs; - FStar_Tactics_Types.smt_goals = - (ps.FStar_Tactics_Types.smt_goals); - FStar_Tactics_Types.depth = (ps.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = (ps.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = (ps.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (ps.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = - (ps.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness = - (ps.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg = - (ps.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = - (ps.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency = (ps.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure = - (ps.FStar_Tactics_Types.dump_on_failure) - }) -let (set_smt_goals : FStar_Tactics_Types.goal Prims.list -> unit tac) = - fun gs -> - bind get - (fun ps -> - set - { - FStar_Tactics_Types.main_context = - (ps.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits = - (ps.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = (ps.FStar_Tactics_Types.goals); - FStar_Tactics_Types.smt_goals = gs; - FStar_Tactics_Types.depth = (ps.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = (ps.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = (ps.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (ps.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = - (ps.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness = - (ps.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg = - (ps.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = - (ps.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency = (ps.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure = - (ps.FStar_Tactics_Types.dump_on_failure) - }) -let (cur_goals : FStar_Tactics_Types.goal Prims.list tac) = - bind get (fun ps -> ret ps.FStar_Tactics_Types.goals) -let (cur_goal_maybe_solved : FStar_Tactics_Types.goal tac) = - bind cur_goals - (fun uu___ -> - match uu___ with | [] -> fail "No more goals" | hd::tl -> ret hd) -let (cur_goal : FStar_Tactics_Types.goal tac) = - bind cur_goals - (fun uu___ -> - match uu___ with - | [] -> fail "No more goals" - | hd::tl -> - let uu___1 = FStar_Tactics_Types.check_goal_solved' hd in - (match uu___1 with - | FStar_Pervasives_Native.None -> ret hd - | FStar_Pervasives_Native.Some t -> - ((let uu___3 = - FStar_Tactics_Printing.goal_to_string_verbose hd in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.print2 - "!!!!!!!!!!!! GOAL IS ALREADY SOLVED! %s\nsol is %s\n" - uu___3 uu___4); - ret hd))) -let (remove_solved_goals : unit tac) = - bind cur_goals - (fun gs -> - let gs1 = - FStar_Compiler_List.filter - (fun g -> - let uu___ = FStar_Tactics_Types.check_goal_solved g in - Prims.op_Negation uu___) gs in - set_goals gs1) -let (dismiss_all : unit tac) = set_goals [] -let (dismiss : unit tac) = - bind get - (fun ps -> - let uu___ = - let uu___1 = FStar_Compiler_List.tl ps.FStar_Tactics_Types.goals in - { - FStar_Tactics_Types.main_context = - (ps.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits = - (ps.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = uu___1; - FStar_Tactics_Types.smt_goals = (ps.FStar_Tactics_Types.smt_goals); - FStar_Tactics_Types.depth = (ps.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = (ps.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = (ps.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (ps.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = - (ps.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness = (ps.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg = - (ps.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = - (ps.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency = (ps.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure = - (ps.FStar_Tactics_Types.dump_on_failure) - } in - set uu___) -let (replace_cur : FStar_Tactics_Types.goal -> unit tac) = - fun g -> - bind get - (fun ps -> - check_valid_goal g; - (let uu___1 = - let uu___2 = - let uu___3 = - FStar_Compiler_List.tl ps.FStar_Tactics_Types.goals in - g :: uu___3 in - { - FStar_Tactics_Types.main_context = - (ps.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits = - (ps.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = uu___2; - FStar_Tactics_Types.smt_goals = - (ps.FStar_Tactics_Types.smt_goals); - FStar_Tactics_Types.depth = (ps.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = (ps.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = (ps.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (ps.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = - (ps.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness = - (ps.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg = - (ps.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = - (ps.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency = (ps.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure = - (ps.FStar_Tactics_Types.dump_on_failure) - } in - set uu___1)) -let (getopts : FStar_Options.optionstate tac) = - let uu___ = trytac cur_goal_maybe_solved in - bind uu___ - (fun uu___1 -> - match uu___1 with - | FStar_Pervasives_Native.Some g -> ret g.FStar_Tactics_Types.opts - | FStar_Pervasives_Native.None -> - let uu___2 = FStar_Options.peek () in ret uu___2) -let (add_goals : FStar_Tactics_Types.goal Prims.list -> unit tac) = - fun gs -> - bind get - (fun ps -> - check_valid_goals gs; - set - { - FStar_Tactics_Types.main_context = - (ps.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits = - (ps.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = - (FStar_Compiler_List.op_At gs ps.FStar_Tactics_Types.goals); - FStar_Tactics_Types.smt_goals = - (ps.FStar_Tactics_Types.smt_goals); - FStar_Tactics_Types.depth = (ps.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = (ps.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = (ps.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (ps.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = - (ps.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness = - (ps.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg = - (ps.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = - (ps.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency = (ps.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure = - (ps.FStar_Tactics_Types.dump_on_failure) - }) -let (add_smt_goals : FStar_Tactics_Types.goal Prims.list -> unit tac) = - fun gs -> - bind get - (fun ps -> - check_valid_goals gs; - set - { - FStar_Tactics_Types.main_context = - (ps.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits = - (ps.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = (ps.FStar_Tactics_Types.goals); - FStar_Tactics_Types.smt_goals = - (FStar_Compiler_List.op_At gs ps.FStar_Tactics_Types.smt_goals); - FStar_Tactics_Types.depth = (ps.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = (ps.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = (ps.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (ps.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = - (ps.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness = - (ps.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg = - (ps.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = - (ps.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency = (ps.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure = - (ps.FStar_Tactics_Types.dump_on_failure) - }) -let (push_goals : FStar_Tactics_Types.goal Prims.list -> unit tac) = - fun gs -> - bind get - (fun ps -> - check_valid_goals gs; - set - { - FStar_Tactics_Types.main_context = - (ps.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits = - (ps.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = - (FStar_Compiler_List.op_At ps.FStar_Tactics_Types.goals gs); - FStar_Tactics_Types.smt_goals = - (ps.FStar_Tactics_Types.smt_goals); - FStar_Tactics_Types.depth = (ps.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = (ps.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = (ps.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (ps.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = - (ps.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness = - (ps.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg = - (ps.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = - (ps.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency = (ps.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure = - (ps.FStar_Tactics_Types.dump_on_failure) - }) -let (push_smt_goals : FStar_Tactics_Types.goal Prims.list -> unit tac) = - fun gs -> - bind get - (fun ps -> - check_valid_goals gs; - set - { - FStar_Tactics_Types.main_context = - (ps.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits = - (ps.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = (ps.FStar_Tactics_Types.goals); - FStar_Tactics_Types.smt_goals = - (FStar_Compiler_List.op_At ps.FStar_Tactics_Types.smt_goals gs); - FStar_Tactics_Types.depth = (ps.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = (ps.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = (ps.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (ps.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = - (ps.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness = - (ps.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg = - (ps.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = - (ps.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency = (ps.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure = - (ps.FStar_Tactics_Types.dump_on_failure) - }) -let (add_implicits : FStar_TypeChecker_Env.implicits -> unit tac) = - fun i -> - bind get - (fun ps -> - set - { - FStar_Tactics_Types.main_context = - (ps.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits = - (FStar_Compiler_List.op_At i - ps.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = (ps.FStar_Tactics_Types.goals); - FStar_Tactics_Types.smt_goals = - (ps.FStar_Tactics_Types.smt_goals); - FStar_Tactics_Types.depth = (ps.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = (ps.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = (ps.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (ps.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = - (ps.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness = - (ps.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg = - (ps.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = - (ps.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency = (ps.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure = - (ps.FStar_Tactics_Types.dump_on_failure) - }) -let (new_uvar : - Prims.string -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.should_check_uvar FStar_Pervasives_Native.option - -> - FStar_Syntax_Syntax.ctx_uvar Prims.list -> - FStar_Compiler_Range_Type.range -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.ctx_uvar) tac) - = - fun reason -> - fun env -> - fun typ -> - fun sc_opt -> - fun uvar_typedness_deps -> - fun rng -> - let should_check = - match sc_opt with - | FStar_Pervasives_Native.Some sc -> sc - | uu___ -> FStar_Syntax_Syntax.Strict in - let uu___ = - FStar_TypeChecker_Env.new_tac_implicit_var reason rng env typ - should_check uvar_typedness_deps - FStar_Pervasives_Native.None false in - match uu___ with - | (u, ctx_uvar, g_u) -> - let uu___1 = - let uu___2 = - FStar_Class_Listlike.to_list - (FStar_Compiler_CList.listlike_clist ()) - g_u.FStar_TypeChecker_Common.implicits in - add_implicits uu___2 in - bind uu___1 - (fun uu___2 -> - ret (u, (FStar_Pervasives_Native.fst ctx_uvar))) -let (mk_irrelevant_goal : - Prims.string -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.should_check_uvar FStar_Pervasives_Native.option - -> - FStar_Compiler_Range_Type.range -> - FStar_Options.optionstate -> - Prims.string -> FStar_Tactics_Types.goal tac) - = - fun reason -> - fun env -> - fun phi -> - fun sc_opt -> - fun rng -> - fun opts -> - fun label -> - let typ = - let uu___ = env.FStar_TypeChecker_Env.universe_of env phi in - FStar_Syntax_Util.mk_squash uu___ phi in - let uu___ = new_uvar reason env typ sc_opt [] rng in - bind uu___ - (fun uu___1 -> - match uu___1 with - | (uu___2, ctx_uvar) -> - let goal = - FStar_Tactics_Types.mk_goal env ctx_uvar opts - false label in - ret goal) -let (add_irrelevant_goal' : - Prims.string -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.should_check_uvar FStar_Pervasives_Native.option - -> - FStar_Compiler_Range_Type.range -> - FStar_Options.optionstate -> Prims.string -> unit tac) - = - fun reason -> - fun env -> - fun phi -> - fun sc_opt -> - fun rng -> - fun opts -> - fun label -> - let uu___ = - mk_irrelevant_goal reason env phi sc_opt rng opts label in - bind uu___ (fun goal -> add_goals [goal]) -let (add_irrelevant_goal : - FStar_Tactics_Types.goal -> - Prims.string -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.should_check_uvar - FStar_Pervasives_Native.option -> unit tac) - = - fun base_goal -> - fun reason -> - fun env -> - fun phi -> - fun sc_opt -> - add_irrelevant_goal' reason env phi sc_opt - (base_goal.FStar_Tactics_Types.goal_ctx_uvar).FStar_Syntax_Syntax.ctx_uvar_range - base_goal.FStar_Tactics_Types.opts - base_goal.FStar_Tactics_Types.label -let (goal_of_guard : - Prims.string -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.should_check_uvar FStar_Pervasives_Native.option - -> FStar_Compiler_Range_Type.range -> FStar_Tactics_Types.goal tac) - = - fun reason -> - fun e -> - fun f -> - fun sc_opt -> - fun rng -> - bind getopts - (fun opts -> - let uu___ = mk_irrelevant_goal reason e f sc_opt rng opts "" in - bind uu___ - (fun goal -> - let goal1 = - { - FStar_Tactics_Types.goal_main_env = - (goal.FStar_Tactics_Types.goal_main_env); - FStar_Tactics_Types.goal_ctx_uvar = - (goal.FStar_Tactics_Types.goal_ctx_uvar); - FStar_Tactics_Types.opts = - (goal.FStar_Tactics_Types.opts); - FStar_Tactics_Types.is_guard = true; - FStar_Tactics_Types.label = - (goal.FStar_Tactics_Types.label) - } in - ret goal1)) -let wrap_err_doc : 'a . FStar_Errors_Msg.error_message -> 'a tac -> 'a tac = - fun pref -> - fun t -> - mk_tac - (fun ps -> - let uu___ = run t ps in - match uu___ with - | FStar_Tactics_Result.Success (a1, q) -> - FStar_Tactics_Result.Success (a1, q) - | FStar_Tactics_Result.Failed - (FStar_Tactics_Common.TacticFailure (msg, r), q) -> - FStar_Tactics_Result.Failed - ((FStar_Tactics_Common.TacticFailure - ((FStar_Compiler_List.op_At pref msg), r)), q) - | FStar_Tactics_Result.Failed (e, q) -> - FStar_Tactics_Result.Failed (e, q)) -let wrap_err : 'a . Prims.string -> 'a tac -> 'a tac = - fun pref -> - fun t -> - let uu___ = - let uu___1 = - FStar_Errors_Msg.text - (Prims.strcat "'" (Prims.strcat pref "' failed")) in - [uu___1] in - wrap_err_doc uu___ t -let mlog : 'a . (unit -> unit) -> (unit -> 'a tac) -> 'a tac = - fun uu___1 -> - fun uu___ -> - (fun f -> - fun cont -> - let uu___ = log f in - Obj.magic - (FStar_Class_Monad.op_let_Bang monad_tac () () uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in Obj.magic (cont ())) - uu___1))) uu___1 uu___ -let (if_verbose_tac : (unit -> unit tac) -> unit tac) = - fun f -> - FStar_Class_Monad.op_let_Bang monad_tac () () (Obj.magic get) - (fun uu___ -> - (fun ps -> - let ps = Obj.magic ps in - if ps.FStar_Tactics_Types.tac_verb_dbg - then Obj.magic (f ()) - else Obj.magic (ret ())) uu___) -let (if_verbose : (unit -> unit) -> unit tac) = - fun f -> if_verbose_tac (fun uu___ -> f (); ret ()) -let (compress_implicits : unit tac) = - bind get - (fun ps -> - let imps = ps.FStar_Tactics_Types.all_implicits in - let g = - let uu___ = - FStar_Class_Listlike.from_list - (FStar_Compiler_CList.listlike_clist ()) imps in - { - FStar_TypeChecker_Common.guard_f = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.guard_f); - FStar_TypeChecker_Common.deferred_to_tac = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = uu___ - } in - let imps1 = - FStar_TypeChecker_Rel.resolve_implicits_tac - ps.FStar_Tactics_Types.main_context g in - let ps' = - let uu___ = - FStar_Compiler_List.map FStar_Pervasives_Native.fst imps1 in - { - FStar_Tactics_Types.main_context = - (ps.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits = uu___; - FStar_Tactics_Types.goals = (ps.FStar_Tactics_Types.goals); - FStar_Tactics_Types.smt_goals = (ps.FStar_Tactics_Types.smt_goals); - FStar_Tactics_Types.depth = (ps.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = (ps.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = (ps.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (ps.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = - (ps.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness = (ps.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg = - (ps.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = - (ps.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency = (ps.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure = - (ps.FStar_Tactics_Types.dump_on_failure) - } in - set ps') -let (get_phi : - FStar_Tactics_Types.goal -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = - fun g -> - let uu___ = - let uu___1 = FStar_Tactics_Types.goal_env g in - let uu___2 = FStar_Tactics_Types.goal_type g in - FStar_TypeChecker_Normalize.unfold_whnf uu___1 uu___2 in - FStar_Syntax_Util.un_squash uu___ -let (is_irrelevant : FStar_Tactics_Types.goal -> Prims.bool) = - fun g -> let uu___ = get_phi g in FStar_Compiler_Option.isSome uu___ -let (goal_typedness_deps : - FStar_Tactics_Types.goal -> FStar_Syntax_Syntax.ctx_uvar Prims.list) = - fun g -> - FStar_Syntax_Util.ctx_uvar_typedness_deps - g.FStar_Tactics_Types.goal_ctx_uvar -let (set_uvar_expected_typ : - FStar_Syntax_Syntax.ctx_uvar -> FStar_Syntax_Syntax.typ -> unit) = - fun u -> - fun t -> - let dec = - FStar_Syntax_Unionfind.find_decoration - u.FStar_Syntax_Syntax.ctx_uvar_head in - FStar_Syntax_Unionfind.change_decoration - u.FStar_Syntax_Syntax.ctx_uvar_head - { - FStar_Syntax_Syntax.uvar_decoration_typ = t; - FStar_Syntax_Syntax.uvar_decoration_typedness_depends_on = - (dec.FStar_Syntax_Syntax.uvar_decoration_typedness_depends_on); - FStar_Syntax_Syntax.uvar_decoration_should_check = - (dec.FStar_Syntax_Syntax.uvar_decoration_should_check); - FStar_Syntax_Syntax.uvar_decoration_should_unrefine = - (dec.FStar_Syntax_Syntax.uvar_decoration_should_unrefine) - } -let (mark_uvar_with_should_check_tag : - FStar_Syntax_Syntax.ctx_uvar -> - FStar_Syntax_Syntax.should_check_uvar -> unit) - = - fun u -> - fun sc -> - let dec = - FStar_Syntax_Unionfind.find_decoration - u.FStar_Syntax_Syntax.ctx_uvar_head in - FStar_Syntax_Unionfind.change_decoration - u.FStar_Syntax_Syntax.ctx_uvar_head - { - FStar_Syntax_Syntax.uvar_decoration_typ = - (dec.FStar_Syntax_Syntax.uvar_decoration_typ); - FStar_Syntax_Syntax.uvar_decoration_typedness_depends_on = - (dec.FStar_Syntax_Syntax.uvar_decoration_typedness_depends_on); - FStar_Syntax_Syntax.uvar_decoration_should_check = sc; - FStar_Syntax_Syntax.uvar_decoration_should_unrefine = - (dec.FStar_Syntax_Syntax.uvar_decoration_should_unrefine) - } -let (mark_uvar_as_already_checked : FStar_Syntax_Syntax.ctx_uvar -> unit) = - fun u -> - mark_uvar_with_should_check_tag u FStar_Syntax_Syntax.Already_checked -let (mark_goal_implicit_already_checked : FStar_Tactics_Types.goal -> unit) = - fun g -> mark_uvar_as_already_checked g.FStar_Tactics_Types.goal_ctx_uvar -let (goal_with_type : - FStar_Tactics_Types.goal -> - FStar_Syntax_Syntax.typ -> FStar_Tactics_Types.goal) - = - fun g -> - fun t -> - let u = g.FStar_Tactics_Types.goal_ctx_uvar in - set_uvar_expected_typ u t; g -let divide : 'a 'b . FStar_BigInt.t -> 'a tac -> 'b tac -> ('a * 'b) tac = - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun n -> - fun l -> - fun r -> - Obj.magic - (FStar_Class_Monad.op_let_Bang monad_tac () () - (Obj.magic get) - (fun uu___ -> - (fun p -> - let p = Obj.magic p in - let uu___ = - try - (fun uu___1 -> - (fun uu___1 -> - match () with - | () -> - let uu___2 = - let uu___3 = - FStar_BigInt.to_int_fs n in - FStar_Compiler_List.splitAt uu___3 - p.FStar_Tactics_Types.goals in - Obj.magic - (FStar_Class_Monad.return monad_tac - () (Obj.magic uu___2))) uu___1) - () - with | uu___1 -> fail "divide: not enough goals" in - Obj.magic - (FStar_Class_Monad.op_let_Bang monad_tac () () - (Obj.magic uu___) - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - match uu___1 with - | (lgs, rgs) -> - let lp = - { - FStar_Tactics_Types.main_context - = - (p.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits - = - (p.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = lgs; - FStar_Tactics_Types.smt_goals = - []; - FStar_Tactics_Types.depth = - (p.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = - (p.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = - (p.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range - = - (p.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy - = - (p.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness = - (p.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg - = - (p.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state - = - (p.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency = - (p.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure - = - (p.FStar_Tactics_Types.dump_on_failure) - } in - let uu___2 = set lp in - Obj.magic - (FStar_Class_Monad.op_let_Bang - monad_tac () () uu___2 - (fun uu___3 -> - (fun uu___3 -> - let uu___3 = - Obj.magic uu___3 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - monad_tac () () - (Obj.magic l) - (fun uu___4 -> - (fun a1 -> - let a1 = - Obj.magic a1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - monad_tac - () () - ( - Obj.magic - get) - ( - fun - uu___4 -> - (fun lp' - -> - let lp' = - Obj.magic - lp' in - let rp = - { - FStar_Tactics_Types.main_context - = - (lp'.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits - = - (lp'.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals - = rgs; - FStar_Tactics_Types.smt_goals - = []; - FStar_Tactics_Types.depth - = - (lp'.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump - = - (lp'.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc - = - (lp'.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range - = - (lp'.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy - = - (lp'.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness - = - (lp'.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg - = - (lp'.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state - = - (lp'.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency - = - (lp'.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure - = - (lp'.FStar_Tactics_Types.dump_on_failure) - } in - let uu___4 - = set rp in - Obj.magic - (FStar_Class_Monad.op_let_Bang - monad_tac - () () - uu___4 - (fun - uu___5 -> - (fun - uu___5 -> - let uu___5 - = - Obj.magic - uu___5 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - monad_tac - () () - (Obj.magic - r) - (fun - uu___6 -> - (fun b1 - -> - let b1 = - Obj.magic - b1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - monad_tac - () () - (Obj.magic - get) - (fun - uu___6 -> - (fun rp' - -> - let rp' = - Obj.magic - rp' in - let p' = - { - FStar_Tactics_Types.main_context - = - (rp'.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits - = - (rp'.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals - = - (FStar_Compiler_List.op_At - lp'.FStar_Tactics_Types.goals - rp'.FStar_Tactics_Types.goals); - FStar_Tactics_Types.smt_goals - = - (FStar_Compiler_List.op_At - lp'.FStar_Tactics_Types.smt_goals - (FStar_Compiler_List.op_At - rp'.FStar_Tactics_Types.smt_goals - p.FStar_Tactics_Types.smt_goals)); - FStar_Tactics_Types.depth - = - (rp'.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump - = - (rp'.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc - = - (rp'.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range - = - (rp'.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy - = - (rp'.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness - = - (rp'.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg - = - (rp'.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state - = - (rp'.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency - = - (rp'.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure - = - (rp'.FStar_Tactics_Types.dump_on_failure) - } in - let uu___6 - = set p' in - Obj.magic - (FStar_Class_Monad.op_let_Bang - monad_tac - () () - uu___6 - (fun - uu___7 -> - (fun - uu___7 -> - let uu___7 - = - Obj.magic - uu___7 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - monad_tac - () () - remove_solved_goals - (fun - uu___8 -> - (fun - uu___8 -> - let uu___8 - = - Obj.magic - uu___8 in - Obj.magic - (FStar_Class_Monad.return - monad_tac - () - (Obj.magic - (a1, b1)))) - uu___8))) - uu___7))) - uu___6))) - uu___6))) - uu___5))) - uu___4))) - uu___4))) - uu___3))) uu___1))) uu___))) - uu___2 uu___1 uu___ -let focus : 'a . 'a tac -> 'a tac = - fun uu___ -> - (fun f -> - let uu___ = - let uu___1 = FStar_Class_Monad.return monad_tac () (Obj.repr ()) in - divide FStar_BigInt.one f uu___1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang monad_tac () () (Obj.magic uu___) - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - match uu___1 with - | (a1, uu___2) -> - Obj.magic - (FStar_Class_Monad.return monad_tac () (Obj.magic a1))) - uu___1))) uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_NamedView.ml b/ocaml/fstar-lib/generated/FStar_Tactics_NamedView.ml index f6b354c1f92..35cecb5a765 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_NamedView.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_NamedView.ml @@ -1,45 +1,46 @@ open Prims -type namedv = FStar_Reflection_V2_Data.namedv_view -type bv = FStar_Reflection_V2_Data.bv_view -type comp = FStar_Reflection_V2_Data.comp_view -type binding = FStar_Reflection_V2_Data.binding -type term = FStar_Reflection_Types.term -type universe = FStar_Reflection_Types.universe +type namedv = FStarC_Reflection_V2_Data.namedv_view +type bv = FStarC_Reflection_V2_Data.bv_view +type comp = FStarC_Reflection_V2_Data.comp_view +type binding = FStarC_Reflection_V2_Data.binding +type term = FStarC_Reflection_Types.term +type universe = FStarC_Reflection_Types.universe type binder = { uniq: Prims.nat ; - ppname: FStar_Reflection_V2_Data.ppname_t ; - sort: FStar_Reflection_Types.typ ; - qual: FStar_Reflection_V2_Data.aqualv ; + ppname: FStarC_Reflection_V2_Data.ppname_t ; + sort: FStarC_Reflection_Types.typ ; + qual: FStarC_Reflection_V2_Data.aqualv ; attrs: term Prims.list } let rec __knot_e_binder _ = - FStar_Syntax_Embeddings_Base.mk_extracted_embedding + FStarC_Syntax_Embeddings_Base.mk_extracted_embedding "FStar.Tactics.NamedView.binder" (fun tm_0 -> match tm_0 with | ("FStar.Tactics.NamedView.Mkbinder", uniq_2::ppname_3::sort_4::qual_5::attrs_6::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Syntax_Embeddings.e_int uniq_2) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Syntax_Embeddings.e_int uniq_2) (fun uniq_2 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - (FStar_Syntax_Embeddings.e_sealed - FStar_Syntax_Embeddings.e_string) ppname_3) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + (FStarC_Syntax_Embeddings.e_sealed + FStarC_Syntax_Embeddings.e_string) ppname_3) (fun ppname_3 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_term sort_4) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_term sort_4) (fun sort_4 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_aqualv qual_5) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_aqualv + qual_5) (fun qual_5 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_term) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_term) attrs_6) (fun attrs_6 -> FStar_Pervasives_Native.Some @@ -55,39 +56,39 @@ let rec __knot_e_binder _ = match tm_7 with | { uniq = uniq_9; ppname = ppname_10; sort = sort_11; qual = qual_12; attrs = attrs_13;_} -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Tactics.NamedView.Mkbinder")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Syntax_Embeddings.e_int uniq_9), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Mkbinder")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Syntax_Embeddings.e_int uniq_9), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - (FStar_Syntax_Embeddings.e_sealed - FStar_Syntax_Embeddings.e_string) ppname_10), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + (FStarC_Syntax_Embeddings.e_sealed + FStarC_Syntax_Embeddings.e_string) ppname_10), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_term sort_11), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_term sort_11), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_aqualv qual_12), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_aqualv qual_12), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_term) attrs_13), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_term) attrs_13), FStar_Pervasives_Native.None)]) let e_binder = __knot_e_binder () let (__proj__Mkbinder__item__uniq : binder -> Prims.nat) = fun projectee -> match projectee with | { uniq; ppname; sort; qual; attrs;_} -> uniq let (__proj__Mkbinder__item__ppname : - binder -> FStar_Reflection_V2_Data.ppname_t) = + binder -> FStarC_Reflection_V2_Data.ppname_t) = fun projectee -> match projectee with | { uniq; ppname; sort; qual; attrs;_} -> ppname -let (__proj__Mkbinder__item__sort : binder -> FStar_Reflection_Types.typ) = +let (__proj__Mkbinder__item__sort : binder -> FStarC_Reflection_Types.typ) = fun projectee -> match projectee with | { uniq; ppname; sort; qual; attrs;_} -> sort let (__proj__Mkbinder__item__qual : - binder -> FStar_Reflection_V2_Data.aqualv) = + binder -> FStarC_Reflection_V2_Data.aqualv) = fun projectee -> match projectee with | { uniq; ppname; sort; qual; attrs;_} -> qual let (__proj__Mkbinder__item__attrs : binder -> term Prims.list) = @@ -100,46 +101,46 @@ type univ_name = (Prims.string * FStar_Range.range) type named_universe_view = | Uv_Zero | Uv_Succ of universe - | Uv_Max of FStar_Reflection_V2_Data.universes + | Uv_Max of FStarC_Reflection_V2_Data.universes | Uv_BVar of Prims.nat | Uv_Name of univ_name - | Uv_Unif of FStar_Reflection_Types.universe_uvar + | Uv_Unif of FStarC_Reflection_Types.universe_uvar | Uv_Unk let rec __knot_e_named_universe_view _ = - FStar_Syntax_Embeddings_Base.mk_extracted_embedding + FStarC_Syntax_Embeddings_Base.mk_extracted_embedding "FStar.Tactics.NamedView.named_universe_view" (fun tm_14 -> match tm_14 with | ("FStar.Tactics.NamedView.Uv_Zero", []) -> FStar_Pervasives_Native.Some Uv_Zero | ("FStar.Tactics.NamedView.Uv_Succ", _0_17::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_universe _0_17) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_universe _0_17) (fun _0_17 -> FStar_Pervasives_Native.Some (Uv_Succ _0_17)) | ("FStar.Tactics.NamedView.Uv_Max", _0_19::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_universe) _0_19) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_universe) _0_19) (fun _0_19 -> FStar_Pervasives_Native.Some (Uv_Max _0_19)) | ("FStar.Tactics.NamedView.Uv_BVar", _0_21::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Syntax_Embeddings.e_int _0_21) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Syntax_Embeddings.e_int _0_21) (fun _0_21 -> FStar_Pervasives_Native.Some (Uv_BVar _0_21)) | ("FStar.Tactics.NamedView.Uv_Name", _0_23::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Syntax_Embeddings.e_string - (FStar_Syntax_Embeddings.e_sealed - FStar_Syntax_Embeddings.e___range)) _0_23) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Syntax_Embeddings.e_string + (FStarC_Syntax_Embeddings.e_sealed + FStarC_Syntax_Embeddings.e___range)) _0_23) (fun _0_23 -> FStar_Pervasives_Native.Some (Uv_Name _0_23)) | ("FStar.Tactics.NamedView.Uv_Unif", _0_25::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_universe_uvar _0_25) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_universe_uvar _0_25) (fun _0_25 -> FStar_Pervasives_Native.Some (Uv_Unif _0_25)) | ("FStar.Tactics.NamedView.Uv_Unk", []) -> FStar_Pervasives_Native.Some Uv_Unk @@ -147,53 +148,54 @@ let rec __knot_e_named_universe_view _ = (fun tm_27 -> match tm_27 with | Uv_Zero -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Tactics.NamedView.Uv_Zero")) + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Uv_Zero")) [] | Uv_Succ _0_30 -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Tactics.NamedView.Uv_Succ")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_universe _0_30), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Uv_Succ")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_universe _0_30), FStar_Pervasives_Native.None)] | Uv_Max _0_32 -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Tactics.NamedView.Uv_Max")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_universe) _0_32), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Uv_Max")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_universe) _0_32), FStar_Pervasives_Native.None)] | Uv_BVar _0_34 -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Tactics.NamedView.Uv_BVar")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Syntax_Embeddings.e_int _0_34), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Uv_BVar")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Syntax_Embeddings.e_int _0_34), FStar_Pervasives_Native.None)] | Uv_Name _0_36 -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Tactics.NamedView.Uv_Name")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Syntax_Embeddings.e_string - (FStar_Syntax_Embeddings.e_sealed - FStar_Syntax_Embeddings.e___range)) _0_36), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Uv_Name")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Syntax_Embeddings.e_string + (FStarC_Syntax_Embeddings.e_sealed + FStarC_Syntax_Embeddings.e___range)) _0_36), FStar_Pervasives_Native.None)] | Uv_Unif _0_38 -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Tactics.NamedView.Uv_Unif")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_universe_uvar _0_38), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Uv_Unif")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_universe_uvar _0_38), FStar_Pervasives_Native.None)] | Uv_Unk -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Tactics.NamedView.Uv_Unk")) []) + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Uv_Unk")) + []) let e_named_universe_view = __knot_e_named_universe_view () let (uu___is_Uv_Zero : named_universe_view -> Prims.bool) = fun projectee -> match projectee with | Uv_Zero -> true | uu___ -> false @@ -204,7 +206,7 @@ let (__proj__Uv_Succ__item___0 : named_universe_view -> universe) = let (uu___is_Uv_Max : named_universe_view -> Prims.bool) = fun projectee -> match projectee with | Uv_Max _0 -> true | uu___ -> false let (__proj__Uv_Max__item___0 : - named_universe_view -> FStar_Reflection_V2_Data.universes) = + named_universe_view -> FStarC_Reflection_V2_Data.universes) = fun projectee -> match projectee with | Uv_Max _0 -> _0 let (uu___is_Uv_BVar : named_universe_view -> Prims.bool) = fun projectee -> match projectee with | Uv_BVar _0 -> true | uu___ -> false @@ -217,21 +219,21 @@ let (__proj__Uv_Name__item___0 : named_universe_view -> univ_name) = let (uu___is_Uv_Unif : named_universe_view -> Prims.bool) = fun projectee -> match projectee with | Uv_Unif _0 -> true | uu___ -> false let (__proj__Uv_Unif__item___0 : - named_universe_view -> FStar_Reflection_Types.universe_uvar) = + named_universe_view -> FStarC_Reflection_Types.universe_uvar) = fun projectee -> match projectee with | Uv_Unif _0 -> _0 let (uu___is_Uv_Unk : named_universe_view -> Prims.bool) = fun projectee -> match projectee with | Uv_Unk -> true | uu___ -> false type pattern__Pat_Constant__payload = { - c: FStar_Reflection_V2_Data.vconst } + c: FStarC_Reflection_V2_Data.vconst } and pattern__Pat_Cons__payload = { - head: FStar_Reflection_Types.fv ; - univs: FStar_Reflection_V2_Data.universes FStar_Pervasives_Native.option ; + head: FStarC_Reflection_Types.fv ; + univs: FStarC_Reflection_V2_Data.universes FStar_Pervasives_Native.option ; subpats: (pattern * Prims.bool) Prims.list } and pattern__Pat_Var__payload = { v: namedv ; - sort1: FStar_Reflection_Types.typ FStar_Sealed.sealed } + sort1: FStarC_Reflection_Types.typ FStar_Sealed.sealed } and pattern__Pat_Dot_Term__payload = { t: term FStar_Pervasives_Native.option } @@ -241,51 +243,51 @@ and pattern = | Pat_Var of pattern__Pat_Var__payload | Pat_Dot_Term of pattern__Pat_Dot_Term__payload let rec __knot_e_pattern__Pat_Constant__payload _ = - FStar_Syntax_Embeddings_Base.mk_extracted_embedding + FStarC_Syntax_Embeddings_Base.mk_extracted_embedding "FStar.Tactics.NamedView.pattern__Pat_Constant__payload" (fun tm_40 -> match tm_40 with | ("FStar.Tactics.NamedView.Mkpattern__Pat_Constant__payload", c_42::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_vconst c_42) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_vconst c_42) (fun c_42 -> FStar_Pervasives_Native.Some { c = c_42 }) | _ -> FStar_Pervasives_Native.None) (fun tm_43 -> match tm_43 with | { c = c_45;_} -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Mkpattern__Pat_Constant__payload")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_vconst c_45), + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_vconst c_45), FStar_Pervasives_Native.None)]) and __knot_e_pattern__Pat_Cons__payload _ = - FStar_Syntax_Embeddings_Base.mk_extracted_embedding + FStarC_Syntax_Embeddings_Base.mk_extracted_embedding "FStar.Tactics.NamedView.pattern__Pat_Cons__payload" (fun tm_46 -> match tm_46 with | ("FStar.Tactics.NamedView.Mkpattern__Pat_Cons__payload", head_48::univs_49::subpats_50::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_fv head_48) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_fv head_48) (fun head_48 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - (FStar_Syntax_Embeddings.e_option - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_universe)) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + (FStarC_Syntax_Embeddings.e_option + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_universe)) univs_49) (fun univs_49 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - (FStar_Syntax_Embeddings.e_list - (FStar_Syntax_Embeddings.e_tuple2 + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + (FStarC_Syntax_Embeddings.e_list + (FStarC_Syntax_Embeddings.e_tuple2 (__knot_e_pattern ()) - FStar_Syntax_Embeddings.e_bool)) subpats_50) + FStarC_Syntax_Embeddings.e_bool)) subpats_50) (fun subpats_50 -> FStar_Pervasives_Native.Some { @@ -297,38 +299,38 @@ and __knot_e_pattern__Pat_Cons__payload _ = (fun tm_51 -> match tm_51 with | { head = head_53; univs = univs_54; subpats = subpats_55;_} -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Mkpattern__Pat_Cons__payload")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_fv head_53), + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_fv head_53), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - (FStar_Syntax_Embeddings.e_option - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_universe)) univs_54), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + (FStarC_Syntax_Embeddings.e_option + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_universe)) univs_54), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - (FStar_Syntax_Embeddings.e_list - (FStar_Syntax_Embeddings.e_tuple2 (__knot_e_pattern ()) - FStar_Syntax_Embeddings.e_bool)) subpats_55), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + (FStarC_Syntax_Embeddings.e_list + (FStarC_Syntax_Embeddings.e_tuple2 (__knot_e_pattern ()) + FStarC_Syntax_Embeddings.e_bool)) subpats_55), FStar_Pervasives_Native.None)]) and __knot_e_pattern__Pat_Var__payload _ = - FStar_Syntax_Embeddings_Base.mk_extracted_embedding + FStarC_Syntax_Embeddings_Base.mk_extracted_embedding "FStar.Tactics.NamedView.pattern__Pat_Var__payload" (fun tm_56 -> match tm_56 with | ("FStar.Tactics.NamedView.Mkpattern__Pat_Var__payload", v_58::sort_59::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_namedv_view v_58) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_namedv_view v_58) (fun v_58 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - (FStar_Syntax_Embeddings.e_sealed - FStar_Reflection_V2_Embeddings.e_term) sort_59) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + (FStarC_Syntax_Embeddings.e_sealed + FStarC_Reflection_V2_Embeddings.e_term) sort_59) (fun sort_59 -> FStar_Pervasives_Native.Some { v = v_58; sort1 = sort_59 })) @@ -336,97 +338,97 @@ and __knot_e_pattern__Pat_Var__payload _ = (fun tm_60 -> match tm_60 with | { v = v_62; sort1 = sort_63;_} -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Mkpattern__Pat_Var__payload")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_namedv_view v_62), + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_namedv_view v_62), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - (FStar_Syntax_Embeddings.e_sealed - FStar_Reflection_V2_Embeddings.e_term) sort_63), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + (FStarC_Syntax_Embeddings.e_sealed + FStarC_Reflection_V2_Embeddings.e_term) sort_63), FStar_Pervasives_Native.None)]) and __knot_e_pattern__Pat_Dot_Term__payload _ = - FStar_Syntax_Embeddings_Base.mk_extracted_embedding + FStarC_Syntax_Embeddings_Base.mk_extracted_embedding "FStar.Tactics.NamedView.pattern__Pat_Dot_Term__payload" (fun tm_64 -> match tm_64 with | ("FStar.Tactics.NamedView.Mkpattern__Pat_Dot_Term__payload", t_66::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - (FStar_Syntax_Embeddings.e_option - FStar_Reflection_V2_Embeddings.e_term) t_66) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + (FStarC_Syntax_Embeddings.e_option + FStarC_Reflection_V2_Embeddings.e_term) t_66) (fun t_66 -> FStar_Pervasives_Native.Some { t = t_66 }) | _ -> FStar_Pervasives_Native.None) (fun tm_67 -> match tm_67 with | { t = t_69;_} -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Mkpattern__Pat_Dot_Term__payload")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - (FStar_Syntax_Embeddings.e_option - FStar_Reflection_V2_Embeddings.e_term) t_69), + [((FStarC_Syntax_Embeddings_Base.extracted_embed + (FStarC_Syntax_Embeddings.e_option + FStarC_Reflection_V2_Embeddings.e_term) t_69), FStar_Pervasives_Native.None)]) and __knot_e_pattern _ = - FStar_Syntax_Embeddings_Base.mk_extracted_embedding + FStarC_Syntax_Embeddings_Base.mk_extracted_embedding "FStar.Tactics.NamedView.pattern" (fun tm_70 -> match tm_70 with | ("FStar.Tactics.NamedView.Pat_Constant", _0_72::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed (__knot_e_pattern__Pat_Constant__payload ()) _0_72) (fun _0_72 -> FStar_Pervasives_Native.Some (Pat_Constant _0_72)) | ("FStar.Tactics.NamedView.Pat_Cons", _0_74::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed (__knot_e_pattern__Pat_Cons__payload ()) _0_74) (fun _0_74 -> FStar_Pervasives_Native.Some (Pat_Cons _0_74)) | ("FStar.Tactics.NamedView.Pat_Var", _0_76::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed (__knot_e_pattern__Pat_Var__payload ()) _0_76) (fun _0_76 -> FStar_Pervasives_Native.Some (Pat_Var _0_76)) | ("FStar.Tactics.NamedView.Pat_Dot_Term", _0_78::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed (__knot_e_pattern__Pat_Dot_Term__payload ()) _0_78) (fun _0_78 -> FStar_Pervasives_Native.Some (Pat_Dot_Term _0_78)) | _ -> FStar_Pervasives_Native.None) (fun tm_79 -> match tm_79 with | Pat_Constant _0_81 -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Pat_Constant")) - [((FStar_Syntax_Embeddings_Base.extracted_embed + [((FStarC_Syntax_Embeddings_Base.extracted_embed (__knot_e_pattern__Pat_Constant__payload ()) _0_81), FStar_Pervasives_Native.None)] | Pat_Cons _0_83 -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Tactics.NamedView.Pat_Cons")) - [((FStar_Syntax_Embeddings_Base.extracted_embed + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Pat_Cons")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed (__knot_e_pattern__Pat_Cons__payload ()) _0_83), FStar_Pervasives_Native.None)] | Pat_Var _0_85 -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Tactics.NamedView.Pat_Var")) - [((FStar_Syntax_Embeddings_Base.extracted_embed + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Pat_Var")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed (__knot_e_pattern__Pat_Var__payload ()) _0_85), FStar_Pervasives_Native.None)] | Pat_Dot_Term _0_87 -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Pat_Dot_Term")) - [((FStar_Syntax_Embeddings_Base.extracted_embed + [((FStarC_Syntax_Embeddings_Base.extracted_embed (__knot_e_pattern__Pat_Dot_Term__payload ()) _0_87), FStar_Pervasives_Native.None)]) let e_pattern__Pat_Constant__payload = @@ -437,14 +439,14 @@ let e_pattern__Pat_Dot_Term__payload = __knot_e_pattern__Pat_Dot_Term__payload () let e_pattern = __knot_e_pattern () let (__proj__Mkpattern__Pat_Constant__payload__item__c : - pattern__Pat_Constant__payload -> FStar_Reflection_V2_Data.vconst) = + pattern__Pat_Constant__payload -> FStarC_Reflection_V2_Data.vconst) = fun projectee -> match projectee with | { c;_} -> c let (__proj__Mkpattern__Pat_Cons__payload__item__head : - pattern__Pat_Cons__payload -> FStar_Reflection_Types.fv) = + pattern__Pat_Cons__payload -> FStarC_Reflection_Types.fv) = fun projectee -> match projectee with | { head; univs; subpats;_} -> head let (__proj__Mkpattern__Pat_Cons__payload__item__univs : pattern__Pat_Cons__payload -> - FStar_Reflection_V2_Data.universes FStar_Pervasives_Native.option) + FStarC_Reflection_V2_Data.universes FStar_Pervasives_Native.option) = fun projectee -> match projectee with | { head; univs; subpats;_} -> univs let (__proj__Mkpattern__Pat_Cons__payload__item__subpats : @@ -455,7 +457,8 @@ let (__proj__Mkpattern__Pat_Var__payload__item__v : pattern__Pat_Var__payload -> namedv) = fun projectee -> match projectee with | { v; sort1 = sort;_} -> v let (__proj__Mkpattern__Pat_Var__payload__item__sort : - pattern__Pat_Var__payload -> FStar_Reflection_Types.typ FStar_Sealed.sealed) + pattern__Pat_Var__payload -> + FStarC_Reflection_Types.typ FStar_Sealed.sealed) = fun projectee -> match projectee with | { v; sort1 = sort;_} -> sort let (__proj__Mkpattern__Pat_Dot_Term__payload__item__t : pattern__Pat_Dot_Term__payload -> term FStar_Pervasives_Native.option) = @@ -488,16 +491,16 @@ type match_returns_ascription = type named_term_view = | Tv_Var of namedv | Tv_BVar of bv - | Tv_FVar of FStar_Reflection_Types.fv - | Tv_UInst of FStar_Reflection_Types.fv * - FStar_Reflection_V2_Data.universes - | Tv_App of term * FStar_Reflection_V2_Data.argv + | Tv_FVar of FStarC_Reflection_Types.fv + | Tv_UInst of FStarC_Reflection_Types.fv * + FStarC_Reflection_V2_Data.universes + | Tv_App of term * FStarC_Reflection_V2_Data.argv | Tv_Abs of binder * term | Tv_Arrow of binder * comp | Tv_Type of universe | Tv_Refine of simple_binder * term - | Tv_Const of FStar_Reflection_V2_Data.vconst - | Tv_Uvar of Prims.nat * FStar_Reflection_Types.ctx_uvar_and_subst + | Tv_Const of FStarC_Reflection_V2_Data.vconst + | Tv_Uvar of Prims.nat * FStarC_Reflection_Types.ctx_uvar_and_subst | Tv_Let of Prims.bool * term Prims.list * simple_binder * term * term | Tv_Match of term * match_returns_ascription FStar_Pervasives_Native.option * branch Prims.list @@ -508,119 +511,119 @@ type named_term_view = | Tv_Unknown | Tv_Unsupp let rec __knot_e_named_term_view _ = - FStar_Syntax_Embeddings_Base.mk_extracted_embedding + FStarC_Syntax_Embeddings_Base.mk_extracted_embedding "FStar.Tactics.NamedView.named_term_view" (fun tm_88 -> match tm_88 with | ("FStar.Tactics.NamedView.Tv_Var", v_90::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_namedv_view v_90) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_namedv_view v_90) (fun v_90 -> FStar_Pervasives_Native.Some (Tv_Var v_90)) | ("FStar.Tactics.NamedView.Tv_BVar", v_92::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_bv_view v_92) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_bv_view v_92) (fun v_92 -> FStar_Pervasives_Native.Some (Tv_BVar v_92)) | ("FStar.Tactics.NamedView.Tv_FVar", v_94::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_fv v_94) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_fv v_94) (fun v_94 -> FStar_Pervasives_Native.Some (Tv_FVar v_94)) | ("FStar.Tactics.NamedView.Tv_UInst", v_96::us_97::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_fv v_96) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_fv v_96) (fun v_96 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_universe) us_97) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_universe) us_97) (fun us_97 -> FStar_Pervasives_Native.Some (Tv_UInst (v_96, us_97)))) | ("FStar.Tactics.NamedView.Tv_App", hd_99::a_100::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_term hd_99) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_term hd_99) (fun hd_99 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_aqualv) a_100) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_aqualv) a_100) (fun a_100 -> FStar_Pervasives_Native.Some (Tv_App (hd_99, a_100)))) | ("FStar.Tactics.NamedView.Tv_Abs", b_102::body_103::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed e_binder b_102) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed e_binder b_102) (fun b_102 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_term body_103) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_term body_103) (fun body_103 -> FStar_Pervasives_Native.Some (Tv_Abs (b_102, body_103)))) | ("FStar.Tactics.NamedView.Tv_Arrow", b_105::c_106::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed e_binder b_105) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed e_binder b_105) (fun b_105 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_comp_view c_106) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_comp_view c_106) (fun c_106 -> FStar_Pervasives_Native.Some (Tv_Arrow (b_105, c_106)))) | ("FStar.Tactics.NamedView.Tv_Type", _0_108::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_universe _0_108) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_universe _0_108) (fun _0_108 -> FStar_Pervasives_Native.Some (Tv_Type _0_108)) | ("FStar.Tactics.NamedView.Tv_Refine", b_110::ref_111::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed e_binder b_110) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed e_binder b_110) (fun b_110 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_term ref_111) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_term ref_111) (fun ref_111 -> FStar_Pervasives_Native.Some (Tv_Refine (b_110, ref_111)))) | ("FStar.Tactics.NamedView.Tv_Const", _0_113::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_vconst _0_113) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_vconst _0_113) (fun _0_113 -> FStar_Pervasives_Native.Some (Tv_Const _0_113)) | ("FStar.Tactics.NamedView.Tv_Uvar", _0_115::_1_116::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Syntax_Embeddings.e_int _0_115) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Syntax_Embeddings.e_int _0_115) (fun _0_115 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_ctx_uvar_and_subst + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_ctx_uvar_and_subst _1_116) (fun _1_116 -> FStar_Pervasives_Native.Some (Tv_Uvar (_0_115, _1_116)))) | ("FStar.Tactics.NamedView.Tv_Let", recf_118::attrs_119::b_120::def_121::body_122::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Syntax_Embeddings.e_bool recf_118) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Syntax_Embeddings.e_bool recf_118) (fun recf_118 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_term) attrs_119) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_term) attrs_119) (fun attrs_119 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed e_binder b_120) (fun b_120 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_term def_121) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_term def_121) (fun def_121 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_term + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_term body_122) (fun body_122 -> FStar_Pervasives_Native.Some @@ -629,71 +632,71 @@ let rec __knot_e_named_term_view _ = def_121, body_122))))))) | ("FStar.Tactics.NamedView.Tv_Match", scrutinee_124::ret_125::brs_126::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_term scrutinee_124) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_term scrutinee_124) (fun scrutinee_124 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - (FStar_Syntax_Embeddings.e_option - (FStar_Syntax_Embeddings.e_tuple2 e_binder - (FStar_Syntax_Embeddings.e_tuple3 - (FStar_Syntax_Embeddings.e_either - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_comp_view) - (FStar_Syntax_Embeddings.e_option - FStar_Reflection_V2_Embeddings.e_term) - FStar_Syntax_Embeddings.e_bool))) ret_125) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + (FStarC_Syntax_Embeddings.e_option + (FStarC_Syntax_Embeddings.e_tuple2 e_binder + (FStarC_Syntax_Embeddings.e_tuple3 + (FStarC_Syntax_Embeddings.e_either + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_comp_view) + (FStarC_Syntax_Embeddings.e_option + FStarC_Reflection_V2_Embeddings.e_term) + FStarC_Syntax_Embeddings.e_bool))) ret_125) (fun ret_125 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - (FStar_Syntax_Embeddings.e_list - (FStar_Syntax_Embeddings.e_tuple2 e_pattern - FStar_Reflection_V2_Embeddings.e_term)) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + (FStarC_Syntax_Embeddings.e_list + (FStarC_Syntax_Embeddings.e_tuple2 e_pattern + FStarC_Reflection_V2_Embeddings.e_term)) brs_126) (fun brs_126 -> FStar_Pervasives_Native.Some (Tv_Match (scrutinee_124, ret_125, brs_126))))) | ("FStar.Tactics.NamedView.Tv_AscribedT", e_128::t_129::tac_130::use_eq_131::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_term e_128) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_term e_128) (fun e_128 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_term t_129) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_term t_129) (fun t_129 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - (FStar_Syntax_Embeddings.e_option - FStar_Reflection_V2_Embeddings.e_term) tac_130) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + (FStarC_Syntax_Embeddings.e_option + FStarC_Reflection_V2_Embeddings.e_term) tac_130) (fun tac_130 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Syntax_Embeddings.e_bool use_eq_131) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Syntax_Embeddings.e_bool use_eq_131) (fun use_eq_131 -> FStar_Pervasives_Native.Some (Tv_AscribedT (e_128, t_129, tac_130, use_eq_131)))))) | ("FStar.Tactics.NamedView.Tv_AscribedC", e_133::c_134::tac_135::use_eq_136::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_term e_133) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_term e_133) (fun e_133 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_comp_view c_134) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_comp_view c_134) (fun c_134 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - (FStar_Syntax_Embeddings.e_option - FStar_Reflection_V2_Embeddings.e_term) tac_135) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + (FStarC_Syntax_Embeddings.e_option + FStarC_Reflection_V2_Embeddings.e_term) tac_135) (fun tac_135 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Syntax_Embeddings.e_bool use_eq_136) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Syntax_Embeddings.e_bool use_eq_136) (fun use_eq_136 -> FStar_Pervasives_Native.Some (Tv_AscribedC @@ -706,187 +709,187 @@ let rec __knot_e_named_term_view _ = (fun tm_139 -> match tm_139 with | Tv_Var v_141 -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_Var")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_namedv_view v_141), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_Var")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_namedv_view v_141), FStar_Pervasives_Native.None)] | Tv_BVar v_143 -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_BVar")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_bv_view v_143), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_BVar")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_bv_view v_143), FStar_Pervasives_Native.None)] | Tv_FVar v_145 -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_FVar")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_fv v_145), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_FVar")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_fv v_145), FStar_Pervasives_Native.None)] | Tv_UInst (v_147, us_148) -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_UInst")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_fv v_147), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_UInst")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_fv v_147), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_universe) us_148), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_universe) us_148), FStar_Pervasives_Native.None)] | Tv_App (hd_150, a_151) -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_App")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_term hd_150), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_App")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_term hd_150), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_aqualv) a_151), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_aqualv) a_151), FStar_Pervasives_Native.None)] | Tv_Abs (b_153, body_154) -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_Abs")) - [((FStar_Syntax_Embeddings_Base.extracted_embed e_binder b_153), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_Abs")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed e_binder b_153), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_term body_154), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_term body_154), FStar_Pervasives_Native.None)] | Tv_Arrow (b_156, c_157) -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_Arrow")) - [((FStar_Syntax_Embeddings_Base.extracted_embed e_binder b_156), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_Arrow")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed e_binder b_156), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_comp_view c_157), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_comp_view c_157), FStar_Pervasives_Native.None)] | Tv_Type _0_159 -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_Type")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_universe _0_159), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_Type")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_universe _0_159), FStar_Pervasives_Native.None)] | Tv_Refine (b_161, ref_162) -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_Refine")) - [((FStar_Syntax_Embeddings_Base.extracted_embed e_binder b_161), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_Refine")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed e_binder b_161), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_term ref_162), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_term ref_162), FStar_Pervasives_Native.None)] | Tv_Const _0_164 -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_Const")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_vconst _0_164), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_Const")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_vconst _0_164), FStar_Pervasives_Native.None)] | Tv_Uvar (_0_166, _1_167) -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_Uvar")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Syntax_Embeddings.e_int _0_166), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_Uvar")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Syntax_Embeddings.e_int _0_166), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_ctx_uvar_and_subst _1_167), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_ctx_uvar_and_subst _1_167), FStar_Pervasives_Native.None)] | Tv_Let (recf_169, attrs_170, b_171, def_172, body_173) -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_Let")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Syntax_Embeddings.e_bool recf_169), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_Let")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Syntax_Embeddings.e_bool recf_169), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_term) attrs_170), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_term) attrs_170), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed e_binder b_171), + ((FStarC_Syntax_Embeddings_Base.extracted_embed e_binder b_171), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_term def_172), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_term def_172), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_term body_173), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_term body_173), FStar_Pervasives_Native.None)] | Tv_Match (scrutinee_175, ret_176, brs_177) -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_Match")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_term scrutinee_175), + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_Match")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_term scrutinee_175), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - (FStar_Syntax_Embeddings.e_option - (FStar_Syntax_Embeddings.e_tuple2 e_binder - (FStar_Syntax_Embeddings.e_tuple3 - (FStar_Syntax_Embeddings.e_either - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_comp_view) - (FStar_Syntax_Embeddings.e_option - FStar_Reflection_V2_Embeddings.e_term) - FStar_Syntax_Embeddings.e_bool))) ret_176), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + (FStarC_Syntax_Embeddings.e_option + (FStarC_Syntax_Embeddings.e_tuple2 e_binder + (FStarC_Syntax_Embeddings.e_tuple3 + (FStarC_Syntax_Embeddings.e_either + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_comp_view) + (FStarC_Syntax_Embeddings.e_option + FStarC_Reflection_V2_Embeddings.e_term) + FStarC_Syntax_Embeddings.e_bool))) ret_176), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - (FStar_Syntax_Embeddings.e_list - (FStar_Syntax_Embeddings.e_tuple2 e_pattern - FStar_Reflection_V2_Embeddings.e_term)) brs_177), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + (FStarC_Syntax_Embeddings.e_list + (FStarC_Syntax_Embeddings.e_tuple2 e_pattern + FStarC_Reflection_V2_Embeddings.e_term)) brs_177), FStar_Pervasives_Native.None)] | Tv_AscribedT (e_179, t_180, tac_181, use_eq_182) -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_AscribedT")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_term e_179), + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_term e_179), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_term t_180), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_term t_180), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - (FStar_Syntax_Embeddings.e_option - FStar_Reflection_V2_Embeddings.e_term) tac_181), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + (FStarC_Syntax_Embeddings.e_option + FStarC_Reflection_V2_Embeddings.e_term) tac_181), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Syntax_Embeddings.e_bool use_eq_182), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Syntax_Embeddings.e_bool use_eq_182), FStar_Pervasives_Native.None)] | Tv_AscribedC (e_184, c_185, tac_186, use_eq_187) -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_AscribedC")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_term e_184), + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_term e_184), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_comp_view c_185), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_comp_view c_185), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - (FStar_Syntax_Embeddings.e_option - FStar_Reflection_V2_Embeddings.e_term) tac_186), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + (FStarC_Syntax_Embeddings.e_option + FStarC_Reflection_V2_Embeddings.e_term) tac_186), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Syntax_Embeddings.e_bool use_eq_187), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Syntax_Embeddings.e_bool use_eq_187), FStar_Pervasives_Native.None)] | Tv_Unknown -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_Unknown")) + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_Unknown")) [] | Tv_Unsupp -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_Unsupp")) + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Tv_Unsupp")) []) let e_named_term_view = __knot_e_named_term_view () let (uu___is_Tv_Var : named_term_view -> Prims.bool) = @@ -899,16 +902,17 @@ let (__proj__Tv_BVar__item__v : named_term_view -> bv) = fun projectee -> match projectee with | Tv_BVar v -> v let (uu___is_Tv_FVar : named_term_view -> Prims.bool) = fun projectee -> match projectee with | Tv_FVar v -> true | uu___ -> false -let (__proj__Tv_FVar__item__v : named_term_view -> FStar_Reflection_Types.fv) - = fun projectee -> match projectee with | Tv_FVar v -> v +let (__proj__Tv_FVar__item__v : + named_term_view -> FStarC_Reflection_Types.fv) = + fun projectee -> match projectee with | Tv_FVar v -> v let (uu___is_Tv_UInst : named_term_view -> Prims.bool) = fun projectee -> match projectee with | Tv_UInst (v, us) -> true | uu___ -> false let (__proj__Tv_UInst__item__v : - named_term_view -> FStar_Reflection_Types.fv) = + named_term_view -> FStarC_Reflection_Types.fv) = fun projectee -> match projectee with | Tv_UInst (v, us) -> v let (__proj__Tv_UInst__item__us : - named_term_view -> FStar_Reflection_V2_Data.universes) = + named_term_view -> FStarC_Reflection_V2_Data.universes) = fun projectee -> match projectee with | Tv_UInst (v, us) -> us let (uu___is_Tv_App : named_term_view -> Prims.bool) = fun projectee -> @@ -916,7 +920,7 @@ let (uu___is_Tv_App : named_term_view -> Prims.bool) = let (__proj__Tv_App__item__hd : named_term_view -> term) = fun projectee -> match projectee with | Tv_App (hd, a) -> hd let (__proj__Tv_App__item__a : - named_term_view -> FStar_Reflection_V2_Data.argv) = + named_term_view -> FStarC_Reflection_V2_Data.argv) = fun projectee -> match projectee with | Tv_App (hd, a) -> a let (uu___is_Tv_Abs : named_term_view -> Prims.bool) = fun projectee -> @@ -947,7 +951,7 @@ let (uu___is_Tv_Const : named_term_view -> Prims.bool) = fun projectee -> match projectee with | Tv_Const _0 -> true | uu___ -> false let (__proj__Tv_Const__item___0 : - named_term_view -> FStar_Reflection_V2_Data.vconst) = + named_term_view -> FStarC_Reflection_V2_Data.vconst) = fun projectee -> match projectee with | Tv_Const _0 -> _0 let (uu___is_Tv_Uvar : named_term_view -> Prims.bool) = fun projectee -> @@ -955,7 +959,7 @@ let (uu___is_Tv_Uvar : named_term_view -> Prims.bool) = let (__proj__Tv_Uvar__item___0 : named_term_view -> Prims.nat) = fun projectee -> match projectee with | Tv_Uvar (_0, _1) -> _0 let (__proj__Tv_Uvar__item___1 : - named_term_view -> FStar_Reflection_Types.ctx_uvar_and_subst) = + named_term_view -> FStarC_Reflection_Types.ctx_uvar_and_subst) = fun projectee -> match projectee with | Tv_Uvar (_0, _1) -> _1 let (uu___is_Tv_Let : named_term_view -> Prims.bool) = fun projectee -> @@ -1039,36 +1043,36 @@ let (notAscription : named_term_view -> Prims.bool) = (Prims.op_Negation (uu___is_Tv_AscribedC tv)) type letbinding = { - lb_fv: FStar_Reflection_Types.fv ; + lb_fv: FStarC_Reflection_Types.fv ; lb_us: univ_name Prims.list ; - lb_typ: FStar_Reflection_Types.typ ; + lb_typ: FStarC_Reflection_Types.typ ; lb_def: term } let rec __knot_e_letbinding _ = - FStar_Syntax_Embeddings_Base.mk_extracted_embedding + FStarC_Syntax_Embeddings_Base.mk_extracted_embedding "FStar.Tactics.NamedView.letbinding" (fun tm_190 -> match tm_190 with | ("FStar.Tactics.NamedView.Mkletbinding", lb_fv_192::lb_us_193::lb_typ_194::lb_def_195::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_fv lb_fv_192) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_fv lb_fv_192) (fun lb_fv_192 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - (FStar_Syntax_Embeddings.e_list - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Syntax_Embeddings.e_string - (FStar_Syntax_Embeddings.e_sealed - FStar_Syntax_Embeddings.e___range))) lb_us_193) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + (FStarC_Syntax_Embeddings.e_list + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Syntax_Embeddings.e_string + (FStarC_Syntax_Embeddings.e_sealed + FStarC_Syntax_Embeddings.e___range))) lb_us_193) (fun lb_us_193 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_term lb_typ_194) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_term lb_typ_194) (fun lb_typ_194 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_term + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_term lb_def_195) (fun lb_def_195 -> FStar_Pervasives_Native.Some @@ -1083,29 +1087,29 @@ let rec __knot_e_letbinding _ = match tm_196 with | { lb_fv = lb_fv_198; lb_us = lb_us_199; lb_typ = lb_typ_200; lb_def = lb_def_201;_} -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Mkletbinding")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_fv lb_fv_198), + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_fv lb_fv_198), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - (FStar_Syntax_Embeddings.e_list - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Syntax_Embeddings.e_string - (FStar_Syntax_Embeddings.e_sealed - FStar_Syntax_Embeddings.e___range))) lb_us_199), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + (FStarC_Syntax_Embeddings.e_list + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Syntax_Embeddings.e_string + (FStarC_Syntax_Embeddings.e_sealed + FStarC_Syntax_Embeddings.e___range))) lb_us_199), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_term lb_typ_200), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_term lb_typ_200), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_term lb_def_201), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_term lb_def_201), FStar_Pervasives_Native.None)]) let e_letbinding = __knot_e_letbinding () let (__proj__Mkletbinding__item__lb_fv : - letbinding -> FStar_Reflection_Types.fv) = + letbinding -> FStarC_Reflection_Types.fv) = fun projectee -> match projectee with | { lb_fv; lb_us; lb_typ; lb_def;_} -> lb_fv let (__proj__Mkletbinding__item__lb_us : letbinding -> univ_name Prims.list) @@ -1113,7 +1117,7 @@ let (__proj__Mkletbinding__item__lb_us : letbinding -> univ_name Prims.list) fun projectee -> match projectee with | { lb_fv; lb_us; lb_typ; lb_def;_} -> lb_us let (__proj__Mkletbinding__item__lb_typ : - letbinding -> FStar_Reflection_Types.typ) = + letbinding -> FStarC_Reflection_Types.typ) = fun projectee -> match projectee with | { lb_fv; lb_us; lb_typ; lb_def;_} -> lb_typ let (__proj__Mkletbinding__item__lb_def : letbinding -> term) = @@ -1125,35 +1129,35 @@ type named_sigelt_view__Sg_Let__payload = lbs: letbinding Prims.list } and named_sigelt_view__Sg_Inductive__payload = { - nm: FStar_Reflection_Types.name ; + nm: FStarC_Reflection_Types.name ; univs1: univ_name Prims.list ; params: binders ; - typ: FStar_Reflection_Types.typ ; - ctors: FStar_Reflection_V2_Data.ctor Prims.list } + typ: FStarC_Reflection_Types.typ ; + ctors: FStarC_Reflection_V2_Data.ctor Prims.list } and named_sigelt_view__Sg_Val__payload = { - nm1: FStar_Reflection_Types.name ; + nm1: FStarC_Reflection_Types.name ; univs2: univ_name Prims.list ; - typ1: FStar_Reflection_Types.typ } + typ1: FStarC_Reflection_Types.typ } and named_sigelt_view = | Sg_Let of named_sigelt_view__Sg_Let__payload | Sg_Inductive of named_sigelt_view__Sg_Inductive__payload | Sg_Val of named_sigelt_view__Sg_Val__payload | Unk let rec __knot_e_named_sigelt_view__Sg_Let__payload _ = - FStar_Syntax_Embeddings_Base.mk_extracted_embedding + FStarC_Syntax_Embeddings_Base.mk_extracted_embedding "FStar.Tactics.NamedView.named_sigelt_view__Sg_Let__payload" (fun tm_202 -> match tm_202 with | ("FStar.Tactics.NamedView.Mknamed_sigelt_view__Sg_Let__payload", isrec_204::lbs_205::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Syntax_Embeddings.e_bool isrec_204) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Syntax_Embeddings.e_bool isrec_204) (fun isrec_204 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - (FStar_Syntax_Embeddings.e_list e_letbinding) lbs_205) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + (FStarC_Syntax_Embeddings.e_list e_letbinding) lbs_205) (fun lbs_205 -> FStar_Pervasives_Native.Some { isrec = isrec_204; lbs = lbs_205 })) @@ -1161,52 +1165,52 @@ let rec __knot_e_named_sigelt_view__Sg_Let__payload _ = (fun tm_206 -> match tm_206 with | { isrec = isrec_208; lbs = lbs_209;_} -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Mknamed_sigelt_view__Sg_Let__payload")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Syntax_Embeddings.e_bool isrec_208), + [((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Syntax_Embeddings.e_bool isrec_208), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - (FStar_Syntax_Embeddings.e_list e_letbinding) lbs_209), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + (FStarC_Syntax_Embeddings.e_list e_letbinding) lbs_209), FStar_Pervasives_Native.None)]) and __knot_e_named_sigelt_view__Sg_Inductive__payload _ = - FStar_Syntax_Embeddings_Base.mk_extracted_embedding + FStarC_Syntax_Embeddings_Base.mk_extracted_embedding "FStar.Tactics.NamedView.named_sigelt_view__Sg_Inductive__payload" (fun tm_210 -> match tm_210 with | ("FStar.Tactics.NamedView.Mknamed_sigelt_view__Sg_Inductive__payload", nm_212::univs_213::params_214::typ_215::ctors_216::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_string) nm_212) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_string) nm_212) (fun nm_212 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - (FStar_Syntax_Embeddings.e_list - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Syntax_Embeddings.e_string - (FStar_Syntax_Embeddings.e_sealed - FStar_Syntax_Embeddings.e___range))) univs_213) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + (FStarC_Syntax_Embeddings.e_list + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Syntax_Embeddings.e_string + (FStarC_Syntax_Embeddings.e_sealed + FStarC_Syntax_Embeddings.e___range))) univs_213) (fun univs_213 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - (FStar_Syntax_Embeddings.e_list e_binder) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + (FStarC_Syntax_Embeddings.e_list e_binder) params_214) (fun params_214 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_term typ_215) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_term typ_215) (fun typ_215 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - (FStar_Syntax_Embeddings.e_list - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_string) - FStar_Reflection_V2_Embeddings.e_term)) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + (FStarC_Syntax_Embeddings.e_list + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_string) + FStarC_Reflection_V2_Embeddings.e_term)) ctors_216) (fun ctors_216 -> FStar_Pervasives_Native.Some @@ -1222,57 +1226,57 @@ and __knot_e_named_sigelt_view__Sg_Inductive__payload _ = match tm_217 with | { nm = nm_219; univs1 = univs_220; params = params_221; typ = typ_222; ctors = ctors_223;_} -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Mknamed_sigelt_view__Sg_Inductive__payload")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_string) nm_219), + [((FStarC_Syntax_Embeddings_Base.extracted_embed + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_string) nm_219), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - (FStar_Syntax_Embeddings.e_list - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Syntax_Embeddings.e_string - (FStar_Syntax_Embeddings.e_sealed - FStar_Syntax_Embeddings.e___range))) univs_220), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + (FStarC_Syntax_Embeddings.e_list + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Syntax_Embeddings.e_string + (FStarC_Syntax_Embeddings.e_sealed + FStarC_Syntax_Embeddings.e___range))) univs_220), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - (FStar_Syntax_Embeddings.e_list e_binder) params_221), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + (FStarC_Syntax_Embeddings.e_list e_binder) params_221), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_term typ_222), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_term typ_222), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - (FStar_Syntax_Embeddings.e_list - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_string) - FStar_Reflection_V2_Embeddings.e_term)) ctors_223), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + (FStarC_Syntax_Embeddings.e_list + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_string) + FStarC_Reflection_V2_Embeddings.e_term)) ctors_223), FStar_Pervasives_Native.None)]) and __knot_e_named_sigelt_view__Sg_Val__payload _ = - FStar_Syntax_Embeddings_Base.mk_extracted_embedding + FStarC_Syntax_Embeddings_Base.mk_extracted_embedding "FStar.Tactics.NamedView.named_sigelt_view__Sg_Val__payload" (fun tm_224 -> match tm_224 with | ("FStar.Tactics.NamedView.Mknamed_sigelt_view__Sg_Val__payload", nm_226::univs_227::typ_228::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_string) nm_226) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_string) nm_226) (fun nm_226 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - (FStar_Syntax_Embeddings.e_list - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Syntax_Embeddings.e_string - (FStar_Syntax_Embeddings.e_sealed - FStar_Syntax_Embeddings.e___range))) univs_227) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + (FStarC_Syntax_Embeddings.e_list + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Syntax_Embeddings.e_string + (FStarC_Syntax_Embeddings.e_sealed + FStarC_Syntax_Embeddings.e___range))) univs_227) (fun univs_227 -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed - FStar_Reflection_V2_Embeddings.e_term typ_228) + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed + FStarC_Reflection_V2_Embeddings.e_term typ_228) (fun typ_228 -> FStar_Pervasives_Native.Some { @@ -1284,43 +1288,43 @@ and __knot_e_named_sigelt_view__Sg_Val__payload _ = (fun tm_229 -> match tm_229 with | { nm1 = nm_231; univs2 = univs_232; typ1 = typ_233;_} -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Mknamed_sigelt_view__Sg_Val__payload")) - [((FStar_Syntax_Embeddings_Base.extracted_embed - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_string) nm_231), + [((FStarC_Syntax_Embeddings_Base.extracted_embed + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_string) nm_231), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - (FStar_Syntax_Embeddings.e_list - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Syntax_Embeddings.e_string - (FStar_Syntax_Embeddings.e_sealed - FStar_Syntax_Embeddings.e___range))) univs_232), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + (FStarC_Syntax_Embeddings.e_list + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Syntax_Embeddings.e_string + (FStarC_Syntax_Embeddings.e_sealed + FStarC_Syntax_Embeddings.e___range))) univs_232), FStar_Pervasives_Native.None); - ((FStar_Syntax_Embeddings_Base.extracted_embed - FStar_Reflection_V2_Embeddings.e_term typ_233), + ((FStarC_Syntax_Embeddings_Base.extracted_embed + FStarC_Reflection_V2_Embeddings.e_term typ_233), FStar_Pervasives_Native.None)]) and __knot_e_named_sigelt_view _ = - FStar_Syntax_Embeddings_Base.mk_extracted_embedding + FStarC_Syntax_Embeddings_Base.mk_extracted_embedding "FStar.Tactics.NamedView.named_sigelt_view" (fun tm_234 -> match tm_234 with | ("FStar.Tactics.NamedView.Sg_Let", _0_236::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed (__knot_e_named_sigelt_view__Sg_Let__payload ()) _0_236) (fun _0_236 -> FStar_Pervasives_Native.Some (Sg_Let _0_236)) | ("FStar.Tactics.NamedView.Sg_Inductive", _0_238::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed (__knot_e_named_sigelt_view__Sg_Inductive__payload ()) _0_238) (fun _0_238 -> FStar_Pervasives_Native.Some (Sg_Inductive _0_238)) | ("FStar.Tactics.NamedView.Sg_Val", _0_240::[]) -> - FStar_Compiler_Util.bind_opt - (FStar_Syntax_Embeddings_Base.extracted_unembed + FStarC_Compiler_Util.bind_opt + (FStarC_Syntax_Embeddings_Base.extracted_unembed (__knot_e_named_sigelt_view__Sg_Val__payload ()) _0_240) (fun _0_240 -> FStar_Pervasives_Native.Some (Sg_Val _0_240)) | ("FStar.Tactics.NamedView.Unk", []) -> @@ -1329,31 +1333,31 @@ and __knot_e_named_sigelt_view _ = (fun tm_242 -> match tm_242 with | Sg_Let _0_244 -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Tactics.NamedView.Sg_Let")) - [((FStar_Syntax_Embeddings_Base.extracted_embed + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Sg_Let")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed (__knot_e_named_sigelt_view__Sg_Let__payload ()) _0_244), FStar_Pervasives_Native.None)] | Sg_Inductive _0_246 -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Sg_Inductive")) - [((FStar_Syntax_Embeddings_Base.extracted_embed + [((FStarC_Syntax_Embeddings_Base.extracted_embed (__knot_e_named_sigelt_view__Sg_Inductive__payload ()) _0_246), FStar_Pervasives_Native.None)] | Sg_Val _0_248 -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Tactics.NamedView.Sg_Val")) - [((FStar_Syntax_Embeddings_Base.extracted_embed + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Sg_Val")) + [((FStarC_Syntax_Embeddings_Base.extracted_embed (__knot_e_named_sigelt_view__Sg_Val__payload ()) _0_248), FStar_Pervasives_Native.None)] | Unk -> - FStar_Syntax_Util.mk_app - (FStar_Syntax_Syntax.tdataconstr - (FStar_Ident.lid_of_str "FStar.Tactics.NamedView.Unk")) []) + FStarC_Syntax_Util.mk_app + (FStarC_Syntax_Syntax.tdataconstr + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.Unk")) []) let e_named_sigelt_view__Sg_Let__payload = __knot_e_named_sigelt_view__Sg_Let__payload () let e_named_sigelt_view__Sg_Inductive__payload = @@ -1368,7 +1372,7 @@ let (__proj__Mknamed_sigelt_view__Sg_Let__payload__item__lbs : named_sigelt_view__Sg_Let__payload -> letbinding Prims.list) = fun projectee -> match projectee with | { isrec; lbs;_} -> lbs let (__proj__Mknamed_sigelt_view__Sg_Inductive__payload__item__nm : - named_sigelt_view__Sg_Inductive__payload -> FStar_Reflection_Types.name) = + named_sigelt_view__Sg_Inductive__payload -> FStarC_Reflection_Types.name) = fun projectee -> match projectee with | { nm; univs1 = univs; params; typ; ctors;_} -> nm let (__proj__Mknamed_sigelt_view__Sg_Inductive__payload__item__univs : @@ -1382,18 +1386,18 @@ let (__proj__Mknamed_sigelt_view__Sg_Inductive__payload__item__params : match projectee with | { nm; univs1 = univs; params; typ; ctors;_} -> params let (__proj__Mknamed_sigelt_view__Sg_Inductive__payload__item__typ : - named_sigelt_view__Sg_Inductive__payload -> FStar_Reflection_Types.typ) = + named_sigelt_view__Sg_Inductive__payload -> FStarC_Reflection_Types.typ) = fun projectee -> match projectee with | { nm; univs1 = univs; params; typ; ctors;_} -> typ let (__proj__Mknamed_sigelt_view__Sg_Inductive__payload__item__ctors : named_sigelt_view__Sg_Inductive__payload -> - FStar_Reflection_V2_Data.ctor Prims.list) + FStarC_Reflection_V2_Data.ctor Prims.list) = fun projectee -> match projectee with | { nm; univs1 = univs; params; typ; ctors;_} -> ctors let (__proj__Mknamed_sigelt_view__Sg_Val__payload__item__nm : - named_sigelt_view__Sg_Val__payload -> FStar_Reflection_Types.name) = + named_sigelt_view__Sg_Val__payload -> FStarC_Reflection_Types.name) = fun projectee -> match projectee with | { nm1 = nm; univs2 = univs; typ1 = typ;_} -> nm let (__proj__Mknamed_sigelt_view__Sg_Val__payload__item__univs : @@ -1401,7 +1405,7 @@ let (__proj__Mknamed_sigelt_view__Sg_Val__payload__item__univs : fun projectee -> match projectee with | { nm1 = nm; univs2 = univs; typ1 = typ;_} -> univs let (__proj__Mknamed_sigelt_view__Sg_Val__payload__item__typ : - named_sigelt_view__Sg_Val__payload -> FStar_Reflection_Types.typ) = + named_sigelt_view__Sg_Val__payload -> FStarC_Reflection_Types.typ) = fun projectee -> match projectee with | { nm1 = nm; univs2 = univs; typ1 = typ;_} -> typ let (uu___is_Sg_Let : named_sigelt_view -> Prims.bool) = @@ -1425,27 +1429,27 @@ let (uu___is_Unk : named_sigelt_view -> Prims.bool) = let (binder_to_binding : binder -> binding) = fun b -> { - FStar_Reflection_V2_Data.uniq1 = (b.uniq); - FStar_Reflection_V2_Data.sort3 = (b.sort); - FStar_Reflection_V2_Data.ppname3 = (b.ppname) + FStarC_Reflection_V2_Data.uniq1 = (b.uniq); + FStarC_Reflection_V2_Data.sort3 = (b.sort); + FStarC_Reflection_V2_Data.ppname3 = (b.ppname) } let (binding_to_binder : binding -> binder) = fun bnd -> { - uniq = (bnd.FStar_Reflection_V2_Data.uniq1); - ppname = (bnd.FStar_Reflection_V2_Data.ppname3); - sort = (bnd.FStar_Reflection_V2_Data.sort3); - qual = FStar_Reflection_V2_Data.Q_Explicit; + uniq = (bnd.FStarC_Reflection_V2_Data.uniq1); + ppname = (bnd.FStarC_Reflection_V2_Data.ppname3); + sort = (bnd.FStarC_Reflection_V2_Data.sort3); + qual = FStarC_Reflection_V2_Data.Q_Explicit; attrs = [] } let (namedv_to_binder : namedv -> term -> binder) = fun v -> fun sort -> { - uniq = (v.FStar_Reflection_V2_Data.uniq); - ppname = (v.FStar_Reflection_V2_Data.ppname); + uniq = (v.FStarC_Reflection_V2_Data.uniq); + ppname = (v.FStarC_Reflection_V2_Data.ppname); sort; - qual = FStar_Reflection_V2_Data.Q_Explicit; + qual = FStarC_Reflection_V2_Data.Q_Explicit; attrs = [] } exception LengthMismatch @@ -1457,119 +1461,120 @@ let (uu___is_NotEnoughBinders : Prims.exn -> Prims.bool) = fun projectee -> match projectee with | NotEnoughBinders -> true | uu___ -> false let (open_universe_view : - FStar_Reflection_V2_Data.universe_view -> named_universe_view) = + FStarC_Reflection_V2_Data.universe_view -> named_universe_view) = fun v -> match v with - | FStar_Reflection_V2_Data.Uv_Zero -> Uv_Zero - | FStar_Reflection_V2_Data.Uv_Succ u -> Uv_Succ u - | FStar_Reflection_V2_Data.Uv_Max us -> Uv_Max us - | FStar_Reflection_V2_Data.Uv_BVar n -> Uv_BVar n - | FStar_Reflection_V2_Data.Uv_Name i -> - Uv_Name (FStar_Reflection_V2_Builtins.inspect_ident i) - | FStar_Reflection_V2_Data.Uv_Unif uvar -> Uv_Unif uvar - | FStar_Reflection_V2_Data.Uv_Unk -> Uv_Unk + | FStarC_Reflection_V2_Data.Uv_Zero -> Uv_Zero + | FStarC_Reflection_V2_Data.Uv_Succ u -> Uv_Succ u + | FStarC_Reflection_V2_Data.Uv_Max us -> Uv_Max us + | FStarC_Reflection_V2_Data.Uv_BVar n -> Uv_BVar n + | FStarC_Reflection_V2_Data.Uv_Name i -> + Uv_Name (FStarC_Reflection_V2_Builtins.inspect_ident i) + | FStarC_Reflection_V2_Data.Uv_Unif uvar -> Uv_Unif uvar + | FStarC_Reflection_V2_Data.Uv_Unk -> Uv_Unk let (inspect_universe : universe -> named_universe_view) = fun u -> - let v = FStar_Reflection_V2_Builtins.inspect_universe u in + let v = FStarC_Reflection_V2_Builtins.inspect_universe u in open_universe_view v let _ = - FStar_Tactics_Native.register_plugin + FStarC_Tactics_Native.register_plugin "FStar.Tactics.NamedView.inspect_universe" Prims.int_one (fun _psc -> fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Tactics.NamedView.inspect_universe" (fun _ -> - (FStar_Syntax_Embeddings.arrow_as_prim_step_1 - FStar_Reflection_V2_Embeddings.e_universe + (FStarC_Syntax_Embeddings.arrow_as_prim_step_1 + FStarC_Reflection_V2_Embeddings.e_universe e_named_universe_view inspect_universe - (FStar_Ident.lid_of_str + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.inspect_universe") cb us) args)) (fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Tactics.NamedView.inspect_universe" (fun _ -> - (FStar_TypeChecker_NBETerm.arrow_as_prim_step_1 - FStar_Reflection_V2_NBEEmbeddings.e_universe - (FStar_TypeChecker_NBETerm.e_unsupported ()) + (FStarC_TypeChecker_NBETerm.arrow_as_prim_step_1 + FStarC_Reflection_V2_NBEEmbeddings.e_universe + (FStarC_TypeChecker_NBETerm.e_unsupported ()) inspect_universe - (FStar_Ident.lid_of_str + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.inspect_universe") cb us) args)) let (close_universe_view : - named_universe_view -> FStar_Reflection_V2_Data.universe_view) = + named_universe_view -> FStarC_Reflection_V2_Data.universe_view) = fun v -> match v with - | Uv_Zero -> FStar_Reflection_V2_Data.Uv_Zero - | Uv_Succ u -> FStar_Reflection_V2_Data.Uv_Succ u - | Uv_Max us -> FStar_Reflection_V2_Data.Uv_Max us - | Uv_BVar n -> FStar_Reflection_V2_Data.Uv_BVar n + | Uv_Zero -> FStarC_Reflection_V2_Data.Uv_Zero + | Uv_Succ u -> FStarC_Reflection_V2_Data.Uv_Succ u + | Uv_Max us -> FStarC_Reflection_V2_Data.Uv_Max us + | Uv_BVar n -> FStarC_Reflection_V2_Data.Uv_BVar n | Uv_Name i -> - FStar_Reflection_V2_Data.Uv_Name - (FStar_Reflection_V2_Builtins.pack_ident i) - | Uv_Unif uvar -> FStar_Reflection_V2_Data.Uv_Unif uvar - | Uv_Unk -> FStar_Reflection_V2_Data.Uv_Unk + FStarC_Reflection_V2_Data.Uv_Name + (FStarC_Reflection_V2_Builtins.pack_ident i) + | Uv_Unif uvar -> FStarC_Reflection_V2_Data.Uv_Unif uvar + | Uv_Unk -> FStarC_Reflection_V2_Data.Uv_Unk let (pack_universe : named_universe_view -> universe) = fun uv -> let uv1 = close_universe_view uv in - FStar_Reflection_V2_Builtins.pack_universe uv1 + FStarC_Reflection_V2_Builtins.pack_universe uv1 let _ = - FStar_Tactics_Native.register_plugin + FStarC_Tactics_Native.register_plugin "FStar.Tactics.NamedView.pack_universe" Prims.int_one (fun _psc -> fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Tactics.NamedView.pack_universe" (fun _ -> - (FStar_Syntax_Embeddings.arrow_as_prim_step_1 + (FStarC_Syntax_Embeddings.arrow_as_prim_step_1 e_named_universe_view - FStar_Reflection_V2_Embeddings.e_universe pack_universe - (FStar_Ident.lid_of_str + FStarC_Reflection_V2_Embeddings.e_universe pack_universe + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.pack_universe") cb us) args)) (fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Tactics.NamedView.pack_universe" (fun _ -> - (FStar_TypeChecker_NBETerm.arrow_as_prim_step_1 - (FStar_TypeChecker_NBETerm.e_unsupported ()) - FStar_Reflection_V2_NBEEmbeddings.e_universe pack_universe - (FStar_Ident.lid_of_str + (FStarC_TypeChecker_NBETerm.arrow_as_prim_step_1 + (FStarC_TypeChecker_NBETerm.e_unsupported ()) + FStarC_Reflection_V2_NBEEmbeddings.e_universe + pack_universe + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.pack_universe") cb us) args)) let (__binding_to_binder : - binding -> FStar_Reflection_Types.binder -> binder) = + binding -> FStarC_Reflection_Types.binder -> binder) = fun bnd -> fun b -> { - uniq = (bnd.FStar_Reflection_V2_Data.uniq1); - ppname = (bnd.FStar_Reflection_V2_Data.ppname3); - sort = (bnd.FStar_Reflection_V2_Data.sort3); + uniq = (bnd.FStarC_Reflection_V2_Data.uniq1); + ppname = (bnd.FStarC_Reflection_V2_Data.ppname3); + sort = (bnd.FStarC_Reflection_V2_Data.sort3); qual = - ((FStar_Reflection_V2_Builtins.inspect_binder b).FStar_Reflection_V2_Data.qual); + ((FStarC_Reflection_V2_Builtins.inspect_binder b).FStarC_Reflection_V2_Data.qual); attrs = - ((FStar_Reflection_V2_Builtins.inspect_binder b).FStar_Reflection_V2_Data.attrs) + ((FStarC_Reflection_V2_Builtins.inspect_binder b).FStarC_Reflection_V2_Data.attrs) } -let (r_binder_to_namedv : binder -> FStar_Reflection_Types.namedv) = +let (r_binder_to_namedv : binder -> FStarC_Reflection_Types.namedv) = fun b -> - FStar_Reflection_V2_Builtins.pack_namedv + FStarC_Reflection_V2_Builtins.pack_namedv { - FStar_Reflection_V2_Data.uniq = (b.uniq); - FStar_Reflection_V2_Data.sort = (FStar_Sealed.seal b.sort); - FStar_Reflection_V2_Data.ppname = (b.ppname) + FStarC_Reflection_V2_Data.uniq = (b.uniq); + FStarC_Reflection_V2_Data.sort = (FStar_Sealed.seal b.sort); + FStarC_Reflection_V2_Data.ppname = (b.ppname) } let (open_binder : - FStar_Reflection_Types.binder -> + FStarC_Reflection_Types.binder -> (binder, unit) FStar_Tactics_Effect.tac_repr) = fun b -> - let uu___ = FStar_Tactics_V2_Builtins.fresh () in + let uu___ = FStarC_Tactics_V2_Builtins.fresh () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1587,25 +1592,25 @@ let (open_binder : { uniq = n; ppname = - ((FStar_Reflection_V2_Builtins.inspect_binder b).FStar_Reflection_V2_Data.ppname2); + ((FStarC_Reflection_V2_Builtins.inspect_binder b).FStarC_Reflection_V2_Data.ppname2); sort = - ((FStar_Reflection_V2_Builtins.inspect_binder b).FStar_Reflection_V2_Data.sort2); + ((FStarC_Reflection_V2_Builtins.inspect_binder b).FStarC_Reflection_V2_Data.sort2); qual = - ((FStar_Reflection_V2_Builtins.inspect_binder b).FStar_Reflection_V2_Data.qual); + ((FStarC_Reflection_V2_Builtins.inspect_binder b).FStarC_Reflection_V2_Data.qual); attrs = - ((FStar_Reflection_V2_Builtins.inspect_binder b).FStar_Reflection_V2_Data.attrs) + ((FStarC_Reflection_V2_Builtins.inspect_binder b).FStarC_Reflection_V2_Data.attrs) })) -let (close_binder : binder -> FStar_Reflection_Types.binder) = +let (close_binder : binder -> FStarC_Reflection_Types.binder) = fun b -> - FStar_Reflection_V2_Builtins.pack_binder + FStarC_Reflection_V2_Builtins.pack_binder { - FStar_Reflection_V2_Data.sort2 = (b.sort); - FStar_Reflection_V2_Data.qual = (b.qual); - FStar_Reflection_V2_Data.attrs = (b.attrs); - FStar_Reflection_V2_Data.ppname2 = (b.ppname) + FStarC_Reflection_V2_Data.sort2 = (b.sort); + FStarC_Reflection_V2_Data.qual = (b.qual); + FStarC_Reflection_V2_Data.attrs = (b.attrs); + FStarC_Reflection_V2_Data.ppname2 = (b.ppname) } let (open_term_with : - FStar_Reflection_Types.binder -> + FStarC_Reflection_Types.binder -> binder -> term -> (term, unit) FStar_Tactics_Effect.tac_repr) = fun uu___2 -> @@ -1617,19 +1622,19 @@ let (open_term_with : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> - FStar_Reflection_V2_Builtins.subst_term - [FStar_Syntax_Syntax.DB + FStarC_Reflection_V2_Builtins.subst_term + [FStarC_Syntax_Syntax.DB (Prims.int_zero, - (FStar_Reflection_V2_Builtins.pack_namedv + (FStarC_Reflection_V2_Builtins.pack_namedv { - FStar_Reflection_V2_Data.uniq = (nb.uniq); - FStar_Reflection_V2_Data.sort = + FStarC_Reflection_V2_Data.uniq = (nb.uniq); + FStarC_Reflection_V2_Data.sort = (FStar_Sealed.seal nb.sort); - FStar_Reflection_V2_Data.ppname = + FStarC_Reflection_V2_Data.ppname = (nb.ppname) }))] t))) uu___2 uu___1 uu___ let (open_term : - FStar_Reflection_Types.binder -> + FStarC_Reflection_Types.binder -> term -> ((binder * term), unit) FStar_Tactics_Effect.tac_repr) = fun b -> @@ -1665,19 +1670,19 @@ let (open_term : (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> (bndr, uu___2))))) uu___1) -let (subst_comp : FStar_Syntax_Syntax.subst_t -> comp -> comp) = +let (subst_comp : FStarC_Syntax_Syntax.subst_t -> comp -> comp) = fun s -> fun c -> - FStar_Reflection_V2_Builtins.inspect_comp - (FStar_Reflection_V2_Builtins.subst_comp s - (FStar_Reflection_V2_Builtins.pack_comp c)) + FStarC_Reflection_V2_Builtins.inspect_comp + (FStarC_Reflection_V2_Builtins.subst_comp s + (FStarC_Reflection_V2_Builtins.pack_comp c)) let (open_comp : - FStar_Reflection_Types.binder -> + FStarC_Reflection_Types.binder -> comp -> ((binder * comp), unit) FStar_Tactics_Effect.tac_repr) = fun b -> fun t -> - let uu___ = FStar_Tactics_V2_Builtins.fresh () in + let uu___ = FStarC_Tactics_V2_Builtins.fresh () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1696,30 +1701,30 @@ let (open_comp : ({ uniq = n; ppname = - ((FStar_Reflection_V2_Builtins.inspect_binder b).FStar_Reflection_V2_Data.ppname2); + ((FStarC_Reflection_V2_Builtins.inspect_binder b).FStarC_Reflection_V2_Data.ppname2); sort = - ((FStar_Reflection_V2_Builtins.inspect_binder b).FStar_Reflection_V2_Data.sort2); + ((FStarC_Reflection_V2_Builtins.inspect_binder b).FStarC_Reflection_V2_Data.sort2); qual = - ((FStar_Reflection_V2_Builtins.inspect_binder b).FStar_Reflection_V2_Data.qual); + ((FStarC_Reflection_V2_Builtins.inspect_binder b).FStarC_Reflection_V2_Data.qual); attrs = - ((FStar_Reflection_V2_Builtins.inspect_binder b).FStar_Reflection_V2_Data.attrs) + ((FStarC_Reflection_V2_Builtins.inspect_binder b).FStarC_Reflection_V2_Data.attrs) }, (subst_comp - [FStar_Syntax_Syntax.DB + [FStarC_Syntax_Syntax.DB (Prims.int_zero, - (FStar_Reflection_V2_Builtins.pack_namedv + (FStarC_Reflection_V2_Builtins.pack_namedv { - FStar_Reflection_V2_Data.uniq = n; - FStar_Reflection_V2_Data.sort = + FStarC_Reflection_V2_Data.uniq = n; + FStarC_Reflection_V2_Data.sort = (FStar_Sealed.seal - (FStar_Reflection_V2_Builtins.inspect_binder - b).FStar_Reflection_V2_Data.sort2); - FStar_Reflection_V2_Data.ppname = - ((FStar_Reflection_V2_Builtins.inspect_binder - b).FStar_Reflection_V2_Data.ppname2) + (FStarC_Reflection_V2_Builtins.inspect_binder + b).FStarC_Reflection_V2_Data.sort2); + FStarC_Reflection_V2_Data.ppname = + ((FStarC_Reflection_V2_Builtins.inspect_binder + b).FStarC_Reflection_V2_Data.ppname2) }))] t)))) let (open_comp_with : - FStar_Reflection_Types.binder -> + FStarC_Reflection_Types.binder -> binder -> comp -> (comp, unit) FStar_Tactics_Effect.tac_repr) = fun uu___2 -> @@ -1732,23 +1737,23 @@ let (open_comp_with : (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> subst_comp - [FStar_Syntax_Syntax.DB + [FStarC_Syntax_Syntax.DB (Prims.int_zero, - (FStar_Reflection_V2_Builtins.pack_namedv + (FStarC_Reflection_V2_Builtins.pack_namedv { - FStar_Reflection_V2_Data.uniq = (nb.uniq); - FStar_Reflection_V2_Data.sort = + FStarC_Reflection_V2_Data.uniq = (nb.uniq); + FStarC_Reflection_V2_Data.sort = (FStar_Sealed.seal nb.sort); - FStar_Reflection_V2_Data.ppname = + FStarC_Reflection_V2_Data.ppname = (nb.ppname) }))] c))) uu___2 uu___1 uu___ let (open_term_simple : - FStar_Reflection_V2_Data.simple_binder -> + FStarC_Reflection_V2_Data.simple_binder -> term -> ((simple_binder * term), unit) FStar_Tactics_Effect.tac_repr) = fun b -> fun t -> - let uu___ = FStar_Tactics_V2_Builtins.fresh () in + let uu___ = FStarC_Tactics_V2_Builtins.fresh () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1767,35 +1772,35 @@ let (open_term_simple : ({ uniq = n; ppname = - ((FStar_Reflection_V2_Builtins.inspect_binder b).FStar_Reflection_V2_Data.ppname2); + ((FStarC_Reflection_V2_Builtins.inspect_binder b).FStarC_Reflection_V2_Data.ppname2); sort = - ((FStar_Reflection_V2_Builtins.inspect_binder b).FStar_Reflection_V2_Data.sort2); + ((FStarC_Reflection_V2_Builtins.inspect_binder b).FStarC_Reflection_V2_Data.sort2); qual = - ((FStar_Reflection_V2_Builtins.inspect_binder b).FStar_Reflection_V2_Data.qual); + ((FStarC_Reflection_V2_Builtins.inspect_binder b).FStarC_Reflection_V2_Data.qual); attrs = - ((FStar_Reflection_V2_Builtins.inspect_binder b).FStar_Reflection_V2_Data.attrs) + ((FStarC_Reflection_V2_Builtins.inspect_binder b).FStarC_Reflection_V2_Data.attrs) }, - (FStar_Reflection_V2_Builtins.subst_term - [FStar_Syntax_Syntax.DB + (FStarC_Reflection_V2_Builtins.subst_term + [FStarC_Syntax_Syntax.DB (Prims.int_zero, - (FStar_Reflection_V2_Builtins.pack_namedv + (FStarC_Reflection_V2_Builtins.pack_namedv { - FStar_Reflection_V2_Data.uniq = n; - FStar_Reflection_V2_Data.sort = + FStarC_Reflection_V2_Data.uniq = n; + FStarC_Reflection_V2_Data.sort = (FStar_Sealed.seal - (FStar_Reflection_V2_Builtins.inspect_binder - b).FStar_Reflection_V2_Data.sort2); - FStar_Reflection_V2_Data.ppname = - ((FStar_Reflection_V2_Builtins.inspect_binder - b).FStar_Reflection_V2_Data.ppname2) + (FStarC_Reflection_V2_Builtins.inspect_binder + b).FStarC_Reflection_V2_Data.sort2); + FStarC_Reflection_V2_Data.ppname = + ((FStarC_Reflection_V2_Builtins.inspect_binder + b).FStarC_Reflection_V2_Data.ppname2) }))] t)))) let (open_comp_simple : - FStar_Reflection_V2_Data.simple_binder -> + FStarC_Reflection_V2_Data.simple_binder -> comp -> ((simple_binder * comp), unit) FStar_Tactics_Effect.tac_repr) = fun b -> fun t -> - let uu___ = FStar_Tactics_V2_Builtins.fresh () in + let uu___ = FStarC_Tactics_V2_Builtins.fresh () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1814,152 +1819,157 @@ let (open_comp_simple : ({ uniq = n; ppname = - ((FStar_Reflection_V2_Builtins.inspect_binder b).FStar_Reflection_V2_Data.ppname2); + ((FStarC_Reflection_V2_Builtins.inspect_binder b).FStarC_Reflection_V2_Data.ppname2); sort = - ((FStar_Reflection_V2_Builtins.inspect_binder b).FStar_Reflection_V2_Data.sort2); + ((FStarC_Reflection_V2_Builtins.inspect_binder b).FStarC_Reflection_V2_Data.sort2); qual = - ((FStar_Reflection_V2_Builtins.inspect_binder b).FStar_Reflection_V2_Data.qual); + ((FStarC_Reflection_V2_Builtins.inspect_binder b).FStarC_Reflection_V2_Data.qual); attrs = - ((FStar_Reflection_V2_Builtins.inspect_binder b).FStar_Reflection_V2_Data.attrs) + ((FStarC_Reflection_V2_Builtins.inspect_binder b).FStarC_Reflection_V2_Data.attrs) }, (subst_comp - [FStar_Syntax_Syntax.DB + [FStarC_Syntax_Syntax.DB (Prims.int_zero, - (FStar_Reflection_V2_Builtins.pack_namedv + (FStarC_Reflection_V2_Builtins.pack_namedv { - FStar_Reflection_V2_Data.uniq = n; - FStar_Reflection_V2_Data.sort = + FStarC_Reflection_V2_Data.uniq = n; + FStarC_Reflection_V2_Data.sort = (FStar_Sealed.seal - (FStar_Reflection_V2_Builtins.inspect_binder - b).FStar_Reflection_V2_Data.sort2); - FStar_Reflection_V2_Data.ppname = - ((FStar_Reflection_V2_Builtins.inspect_binder - b).FStar_Reflection_V2_Data.ppname2) + (FStarC_Reflection_V2_Builtins.inspect_binder + b).FStarC_Reflection_V2_Data.sort2); + FStarC_Reflection_V2_Data.ppname = + ((FStarC_Reflection_V2_Builtins.inspect_binder + b).FStarC_Reflection_V2_Data.ppname2) }))] t)))) -let (close_term : binder -> term -> (FStar_Reflection_Types.binder * term)) = +let (close_term : binder -> term -> (FStarC_Reflection_Types.binder * term)) + = fun b -> fun t -> let nv = r_binder_to_namedv b in let t' = - FStar_Reflection_V2_Builtins.subst_term - [FStar_Syntax_Syntax.NM (nv, Prims.int_zero)] t in + FStarC_Reflection_V2_Builtins.subst_term + [FStarC_Syntax_Syntax.NM (nv, Prims.int_zero)] t in let b1 = - FStar_Reflection_V2_Builtins.pack_binder + FStarC_Reflection_V2_Builtins.pack_binder { - FStar_Reflection_V2_Data.sort2 = (b.sort); - FStar_Reflection_V2_Data.qual = (b.qual); - FStar_Reflection_V2_Data.attrs = (b.attrs); - FStar_Reflection_V2_Data.ppname2 = (b.ppname) + FStarC_Reflection_V2_Data.sort2 = (b.sort); + FStarC_Reflection_V2_Data.qual = (b.qual); + FStarC_Reflection_V2_Data.attrs = (b.attrs); + FStarC_Reflection_V2_Data.ppname2 = (b.ppname) } in (b1, t') let _ = - FStar_Tactics_Native.register_plugin "FStar.Tactics.NamedView.close_term" + FStarC_Tactics_Native.register_plugin "FStar.Tactics.NamedView.close_term" (Prims.of_int (2)) (fun _psc -> fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Tactics.NamedView.close_term" (fun _ -> - (FStar_Syntax_Embeddings.arrow_as_prim_step_2 e_binder - FStar_Reflection_V2_Embeddings.e_term - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Reflection_V2_Embeddings.e_binder - FStar_Reflection_V2_Embeddings.e_term) close_term - (FStar_Ident.lid_of_str + (FStarC_Syntax_Embeddings.arrow_as_prim_step_2 e_binder + FStarC_Reflection_V2_Embeddings.e_term + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Reflection_V2_Embeddings.e_binder + FStarC_Reflection_V2_Embeddings.e_term) close_term + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.close_term") cb us) args)) (fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Tactics.NamedView.close_term" (fun _ -> - (FStar_TypeChecker_NBETerm.arrow_as_prim_step_2 - (FStar_TypeChecker_NBETerm.e_unsupported ()) - FStar_Reflection_V2_NBEEmbeddings.e_term - (FStar_TypeChecker_NBETerm.e_tuple2 - FStar_Reflection_V2_NBEEmbeddings.e_binder - FStar_Reflection_V2_NBEEmbeddings.e_term) close_term - (FStar_Ident.lid_of_str + (FStarC_TypeChecker_NBETerm.arrow_as_prim_step_2 + (FStarC_TypeChecker_NBETerm.e_unsupported ()) + FStarC_Reflection_V2_NBEEmbeddings.e_term + (FStarC_TypeChecker_NBETerm.e_tuple2 + FStarC_Reflection_V2_NBEEmbeddings.e_binder + FStarC_Reflection_V2_NBEEmbeddings.e_term) close_term + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.close_term") cb us) args)) -let (close_comp : binder -> comp -> (FStar_Reflection_Types.binder * comp)) = +let (close_comp : binder -> comp -> (FStarC_Reflection_Types.binder * comp)) + = fun b -> fun t -> let nv = r_binder_to_namedv b in - let t' = subst_comp [FStar_Syntax_Syntax.NM (nv, Prims.int_zero)] t in + let t' = subst_comp [FStarC_Syntax_Syntax.NM (nv, Prims.int_zero)] t in let b1 = - FStar_Reflection_V2_Builtins.pack_binder + FStarC_Reflection_V2_Builtins.pack_binder { - FStar_Reflection_V2_Data.sort2 = (b.sort); - FStar_Reflection_V2_Data.qual = (b.qual); - FStar_Reflection_V2_Data.attrs = (b.attrs); - FStar_Reflection_V2_Data.ppname2 = (b.ppname) + FStarC_Reflection_V2_Data.sort2 = (b.sort); + FStarC_Reflection_V2_Data.qual = (b.qual); + FStarC_Reflection_V2_Data.attrs = (b.attrs); + FStarC_Reflection_V2_Data.ppname2 = (b.ppname) } in (b1, t') let (close_term_simple : - simple_binder -> term -> (FStar_Reflection_V2_Data.simple_binder * term)) = + simple_binder -> term -> (FStarC_Reflection_V2_Data.simple_binder * term)) + = fun b -> fun t -> let nv = r_binder_to_namedv b in let t' = - FStar_Reflection_V2_Builtins.subst_term - [FStar_Syntax_Syntax.NM (nv, Prims.int_zero)] t in + FStarC_Reflection_V2_Builtins.subst_term + [FStarC_Syntax_Syntax.NM (nv, Prims.int_zero)] t in let bv1 = { - FStar_Reflection_V2_Data.sort2 = (b.sort); - FStar_Reflection_V2_Data.qual = (b.qual); - FStar_Reflection_V2_Data.attrs = (b.attrs); - FStar_Reflection_V2_Data.ppname2 = (b.ppname) + FStarC_Reflection_V2_Data.sort2 = (b.sort); + FStarC_Reflection_V2_Data.qual = (b.qual); + FStarC_Reflection_V2_Data.attrs = (b.attrs); + FStarC_Reflection_V2_Data.ppname2 = (b.ppname) } in - let b1 = FStar_Reflection_V2_Builtins.pack_binder bv1 in (b1, t') + let b1 = FStarC_Reflection_V2_Builtins.pack_binder bv1 in (b1, t') let (close_comp_simple : - simple_binder -> comp -> (FStar_Reflection_V2_Data.simple_binder * comp)) = + simple_binder -> comp -> (FStarC_Reflection_V2_Data.simple_binder * comp)) + = fun b -> fun t -> let nv = r_binder_to_namedv b in - let t' = subst_comp [FStar_Syntax_Syntax.NM (nv, Prims.int_zero)] t in + let t' = subst_comp [FStarC_Syntax_Syntax.NM (nv, Prims.int_zero)] t in let bv1 = { - FStar_Reflection_V2_Data.sort2 = (b.sort); - FStar_Reflection_V2_Data.qual = (b.qual); - FStar_Reflection_V2_Data.attrs = (b.attrs); - FStar_Reflection_V2_Data.ppname2 = (b.ppname) + FStarC_Reflection_V2_Data.sort2 = (b.sort); + FStarC_Reflection_V2_Data.qual = (b.qual); + FStarC_Reflection_V2_Data.attrs = (b.attrs); + FStarC_Reflection_V2_Data.ppname2 = (b.ppname) } in - let b1 = FStar_Reflection_V2_Builtins.pack_binder bv1 in (b1, t') + let b1 = FStarC_Reflection_V2_Builtins.pack_binder bv1 in (b1, t') let (r_subst_binder_sort : - FStar_Syntax_Syntax.subst_t -> - FStar_Reflection_Types.binder -> FStar_Reflection_Types.binder) + FStarC_Syntax_Syntax.subst_t -> + FStarC_Reflection_Types.binder -> FStarC_Reflection_Types.binder) = fun s -> fun b -> - let v = FStar_Reflection_V2_Builtins.inspect_binder b in + let v = FStarC_Reflection_V2_Builtins.inspect_binder b in let v1 = { - FStar_Reflection_V2_Data.sort2 = - (FStar_Reflection_V2_Builtins.subst_term s - v.FStar_Reflection_V2_Data.sort2); - FStar_Reflection_V2_Data.qual = (v.FStar_Reflection_V2_Data.qual); - FStar_Reflection_V2_Data.attrs = (v.FStar_Reflection_V2_Data.attrs); - FStar_Reflection_V2_Data.ppname2 = - (v.FStar_Reflection_V2_Data.ppname2) + FStarC_Reflection_V2_Data.sort2 = + (FStarC_Reflection_V2_Builtins.subst_term s + v.FStarC_Reflection_V2_Data.sort2); + FStarC_Reflection_V2_Data.qual = (v.FStarC_Reflection_V2_Data.qual); + FStarC_Reflection_V2_Data.attrs = + (v.FStarC_Reflection_V2_Data.attrs); + FStarC_Reflection_V2_Data.ppname2 = + (v.FStarC_Reflection_V2_Data.ppname2) } in - FStar_Reflection_V2_Builtins.pack_binder v1 -let (subst_binder_sort : FStar_Syntax_Syntax.subst_t -> binder -> binder) = + FStarC_Reflection_V2_Builtins.pack_binder v1 +let (subst_binder_sort : FStarC_Syntax_Syntax.subst_t -> binder -> binder) = fun s -> fun b -> { uniq = (b.uniq); ppname = (b.ppname); - sort = (FStar_Reflection_V2_Builtins.subst_term s b.sort); + sort = (FStarC_Reflection_V2_Builtins.subst_term s b.sort); qual = (b.qual); attrs = (b.attrs) } let rec (__open_term_n_aux : - FStar_Reflection_Types.binder Prims.list -> + FStarC_Reflection_Types.binder Prims.list -> binder Prims.list -> - FStar_Syntax_Syntax.subst_t -> - ((binder Prims.list * FStar_Syntax_Syntax.subst_t), unit) + FStarC_Syntax_Syntax.subst_t -> + ((binder Prims.list * FStarC_Syntax_Syntax.subst_t), unit) FStar_Tactics_Effect.tac_repr) = fun uu___2 -> @@ -2048,7 +2058,7 @@ let rec (__open_term_n_aux : Obj.magic (__open_term_n_aux bs1 (b2 :: nbs) - ((FStar_Syntax_Syntax.DB + ((FStarC_Syntax_Syntax.DB (Prims.int_zero, nv)) :: (FStar_Reflection_V2_Derived.shift_subst @@ -2057,7 +2067,7 @@ let rec (__open_term_n_aux : uu___2))) uu___1)))) uu___2 uu___1 uu___ let (open_term_n : - FStar_Reflection_Types.binder Prims.list -> + FStarC_Reflection_Types.binder Prims.list -> term -> ((binder Prims.list * term), unit) FStar_Tactics_Effect.tac_repr) = fun bs -> @@ -2081,9 +2091,9 @@ let (open_term_n : match uu___1 with | (nbs, s) -> ((FStar_List_Tot_Base.rev nbs), - (FStar_Reflection_V2_Builtins.subst_term s t)))) + (FStarC_Reflection_V2_Builtins.subst_term s t)))) let rec (open_term_n_with : - FStar_Reflection_Types.binder Prims.list -> + FStarC_Reflection_Types.binder Prims.list -> binder Prims.list -> term -> (term, unit) FStar_Tactics_Effect.tac_repr) = fun uu___2 -> @@ -2146,7 +2156,7 @@ let rec (open_term_n_with : uu___2 uu___1 uu___ let (close_term_n : binder Prims.list -> - term -> (FStar_Reflection_Types.binder Prims.list * term)) + term -> (FStarC_Reflection_Types.binder Prims.list * term)) = fun bs -> fun t -> @@ -2158,15 +2168,15 @@ let (close_term_n : let nv = r_binder_to_namedv b1 in let b2 = close_binder b1 in aux bs2 (b2 :: cbs) - ((FStar_Syntax_Syntax.NM (nv, Prims.int_zero)) :: + ((FStarC_Syntax_Syntax.NM (nv, Prims.int_zero)) :: (FStar_Reflection_V2_Derived.shift_subst Prims.int_one s)) in let uu___ = aux bs [] [] in match uu___ with | (cbs, s) -> ((FStar_List_Tot_Base.rev cbs), - (FStar_Reflection_V2_Builtins.subst_term s t)) + (FStarC_Reflection_V2_Builtins.subst_term s t)) let rec (open_term_n_simple : - FStar_Reflection_V2_Data.simple_binder Prims.list -> + FStarC_Reflection_V2_Data.simple_binder Prims.list -> term -> ((simple_binder Prims.list * term), unit) FStar_Tactics_Effect.tac_repr) = @@ -2230,7 +2240,7 @@ let rec (open_term_n_simple : uu___1)))) uu___1 uu___ let rec (close_term_n_simple : simple_binder Prims.list -> - term -> (FStar_Reflection_V2_Data.simple_binder Prims.list * term)) + term -> (FStarC_Reflection_V2_Data.simple_binder Prims.list * term)) = fun bs -> fun t -> @@ -2243,9 +2253,9 @@ let rec (close_term_n_simple : let uu___1 = close_term_simple b t' in (match uu___1 with | (b', t'') -> ((b' :: bs'), t''))) let rec (open_pat : - FStar_Reflection_V2_Data.pattern -> - FStar_Syntax_Syntax.subst_t -> - ((pattern * FStar_Syntax_Syntax.subst_t), unit) + FStarC_Reflection_V2_Data.pattern -> + FStarC_Syntax_Syntax.subst_t -> + ((pattern * FStarC_Syntax_Syntax.subst_t), unit) FStar_Tactics_Effect.tac_repr) = fun uu___1 -> @@ -2253,12 +2263,12 @@ let rec (open_pat : (fun p -> fun s -> match p with - | FStar_Reflection_V2_Data.Pat_Constant c -> + | FStarC_Reflection_V2_Data.Pat_Constant c -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> ((Pat_Constant { c }), s)))) - | FStar_Reflection_V2_Data.Pat_Var (ssort, n) -> + | FStarC_Reflection_V2_Data.Pat_Var (ssort, n) -> Obj.magic (Obj.repr (let uu___ = FStar_Tactics_Unseal.unseal ssort in @@ -2282,7 +2292,7 @@ let rec (open_pat : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> - FStar_Reflection_V2_Builtins.subst_term + FStarC_Reflection_V2_Builtins.subst_term s sort)) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -2307,7 +2317,7 @@ let rec (open_pat : (fun sort1 -> let uu___2 = let uu___3 = - FStar_Tactics_V2_Builtins.fresh + FStarC_Tactics_V2_Builtins.fresh () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -2331,13 +2341,13 @@ let rec (open_pat : FStar_Tactics_Effect.lift_div_tac (fun uu___5 -> { - FStar_Reflection_V2_Data.uniq + FStarC_Reflection_V2_Data.uniq = uu___4; - FStar_Reflection_V2_Data.sort + FStarC_Reflection_V2_Data.sort = (FStar_Sealed.seal sort1); - FStar_Reflection_V2_Data.ppname + FStarC_Reflection_V2_Data.ppname = n })) in Obj.magic @@ -2369,14 +2379,14 @@ let rec (open_pat : (FStar_Sealed.seal sort1) }), - ((FStar_Syntax_Syntax.DB + ((FStarC_Syntax_Syntax.DB (Prims.int_zero, - (FStar_Reflection_V2_Builtins.pack_namedv + (FStarC_Reflection_V2_Builtins.pack_namedv nvv))) :: (FStar_Reflection_V2_Derived.shift_subst Prims.int_one s))))))) uu___2))) uu___1))) - | FStar_Reflection_V2_Data.Pat_Cons (head, univs, subpats) -> + | FStarC_Reflection_V2_Data.Pat_Cons (head, univs, subpats) -> Obj.magic (Obj.repr (let uu___ = @@ -2437,7 +2447,7 @@ let rec (open_pat : subpats = (FStar_List_Tot_Base.rev subpats1) }), s1))))) - | FStar_Reflection_V2_Data.Pat_Dot_Term + | FStarC_Reflection_V2_Data.Pat_Dot_Term (FStar_Pervasives_Native.None) -> Obj.magic (Obj.repr @@ -2445,7 +2455,7 @@ let rec (open_pat : (fun uu___ -> ((Pat_Dot_Term { t = FStar_Pervasives_Native.None }), s)))) - | FStar_Reflection_V2_Data.Pat_Dot_Term + | FStarC_Reflection_V2_Data.Pat_Dot_Term (FStar_Pervasives_Native.Some t) -> Obj.magic (Obj.repr @@ -2455,11 +2465,11 @@ let rec (open_pat : { t = (FStar_Pervasives_Native.Some - (FStar_Reflection_V2_Builtins.subst_term + (FStarC_Reflection_V2_Builtins.subst_term s t)) }), s))))) uu___1 uu___ let (open_branch : - FStar_Reflection_V2_Data.branch -> + FStarC_Reflection_V2_Data.branch -> (branch, unit) FStar_Tactics_Effect.tac_repr) = fun b -> @@ -2502,23 +2512,24 @@ let (open_branch : match uu___3 with | (pat1, s) -> (pat1, - (FStar_Reflection_V2_Builtins.subst_term s - t)))))) uu___1) + (FStarC_Reflection_V2_Builtins.subst_term + s t)))))) uu___1) let rec (close_pat : pattern -> - FStar_Syntax_Syntax.subst_t -> - (FStar_Reflection_V2_Data.pattern * FStar_Syntax_Syntax.subst_t)) + FStarC_Syntax_Syntax.subst_t -> + (FStarC_Reflection_V2_Data.pattern * FStarC_Syntax_Syntax.subst_t)) = fun p -> fun s -> match p with - | Pat_Constant { c;_} -> ((FStar_Reflection_V2_Data.Pat_Constant c), s) + | Pat_Constant { c;_} -> + ((FStarC_Reflection_V2_Data.Pat_Constant c), s) | Pat_Var { v; sort1 = sort;_} -> - let nv = FStar_Reflection_V2_Builtins.pack_namedv v in - let s1 = (FStar_Syntax_Syntax.NM (nv, Prims.int_zero)) :: + let nv = FStarC_Reflection_V2_Builtins.pack_namedv v in + let s1 = (FStarC_Syntax_Syntax.NM (nv, Prims.int_zero)) :: (FStar_Reflection_V2_Derived.shift_subst Prims.int_one s) in - ((FStar_Reflection_V2_Data.Pat_Var - (sort, (v.FStar_Reflection_V2_Data.ppname))), s1) + ((FStarC_Reflection_V2_Data.Pat_Var + (sort, (v.FStarC_Reflection_V2_Data.ppname))), s1) | Pat_Cons { head; univs; subpats;_} -> let uu___ = FStar_List_Tot_Base.fold_left @@ -2533,16 +2544,16 @@ let rec (close_pat : (match uu___ with | (subpats1, s1) -> let subpats2 = FStar_List_Tot_Base.rev subpats1 in - ((FStar_Reflection_V2_Data.Pat_Cons (head, univs, subpats2)), + ((FStarC_Reflection_V2_Data.Pat_Cons (head, univs, subpats2)), s1)) | Pat_Dot_Term { t = FStar_Pervasives_Native.None;_} -> - ((FStar_Reflection_V2_Data.Pat_Dot_Term + ((FStarC_Reflection_V2_Data.Pat_Dot_Term FStar_Pervasives_Native.None), s) | Pat_Dot_Term { t = FStar_Pervasives_Native.Some t;_} -> - let t1 = FStar_Reflection_V2_Builtins.subst_term s t in - ((FStar_Reflection_V2_Data.Pat_Dot_Term + let t1 = FStarC_Reflection_V2_Builtins.subst_term s t in + ((FStarC_Reflection_V2_Data.Pat_Dot_Term (FStar_Pervasives_Native.Some t1)), s) -let (close_branch : branch -> FStar_Reflection_V2_Data.branch) = +let (close_branch : branch -> FStarC_Reflection_V2_Data.branch) = fun b -> let uu___ = b in match uu___ with @@ -2550,10 +2561,10 @@ let (close_branch : branch -> FStar_Reflection_V2_Data.branch) = let uu___1 = close_pat pat [] in (match uu___1 with | (pat1, s) -> - let t' = FStar_Reflection_V2_Builtins.subst_term s t in + let t' = FStarC_Reflection_V2_Builtins.subst_term s t in (pat1, t')) let (open_match_returns_ascription : - FStar_Syntax_Syntax.match_returns_ascription -> + FStarC_Syntax_Syntax.match_returns_ascription -> (match_returns_ascription, unit) FStar_Tactics_Effect.tac_repr) = fun mra -> @@ -2623,7 +2634,7 @@ let (open_match_returns_ascription : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___5 -> - FStar_Reflection_V2_Builtins.inspect_comp + FStarC_Reflection_V2_Builtins.inspect_comp c)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -2752,7 +2763,8 @@ let (open_match_returns_ascription : (nb, (ct1, topt1, use_eq)))))) uu___4))) uu___3))) uu___1) let (close_match_returns_ascription : - match_returns_ascription -> FStar_Syntax_Syntax.match_returns_ascription) = + match_returns_ascription -> FStarC_Syntax_Syntax.match_returns_ascription) + = fun mra -> let uu___ = mra in match uu___ with @@ -2767,7 +2779,7 @@ let (close_match_returns_ascription : let uu___1 = close_comp nb c in (match uu___1 with | (uu___2, c1) -> - let c2 = FStar_Reflection_V2_Builtins.pack_comp c1 in + let c2 = FStarC_Reflection_V2_Builtins.pack_comp c1 in FStar_Pervasives.Inr c2) in let topt1 = match topt with @@ -2777,73 +2789,73 @@ let (close_match_returns_ascription : (FStar_Pervasives_Native.snd (close_term nb t)) in (b, (ct1, topt1, use_eq)) let (open_view : - FStar_Reflection_V2_Data.term_view -> + FStarC_Reflection_V2_Data.term_view -> (named_term_view, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> (fun tv -> match tv with - | FStar_Reflection_V2_Data.Tv_Var v -> + | FStarC_Reflection_V2_Data.Tv_Var v -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> - Tv_Var (FStar_Reflection_V2_Builtins.inspect_namedv v)))) - | FStar_Reflection_V2_Data.Tv_BVar v -> + Tv_Var (FStarC_Reflection_V2_Builtins.inspect_namedv v)))) + | FStarC_Reflection_V2_Data.Tv_BVar v -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> - Tv_BVar (FStar_Reflection_V2_Builtins.inspect_bv v)))) - | FStar_Reflection_V2_Data.Tv_FVar v -> + Tv_BVar (FStarC_Reflection_V2_Builtins.inspect_bv v)))) + | FStarC_Reflection_V2_Data.Tv_FVar v -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> Tv_FVar v))) - | FStar_Reflection_V2_Data.Tv_UInst (v, us) -> + | FStarC_Reflection_V2_Data.Tv_UInst (v, us) -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> Tv_UInst (v, us)))) - | FStar_Reflection_V2_Data.Tv_App (hd, a) -> + | FStarC_Reflection_V2_Data.Tv_App (hd, a) -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> Tv_App (hd, a)))) - | FStar_Reflection_V2_Data.Tv_Type u -> + | FStarC_Reflection_V2_Data.Tv_Type u -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> Tv_Type u))) - | FStar_Reflection_V2_Data.Tv_Const c -> + | FStarC_Reflection_V2_Data.Tv_Const c -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> Tv_Const c))) - | FStar_Reflection_V2_Data.Tv_Uvar (n, ctx_uvar_and_subst) -> + | FStarC_Reflection_V2_Data.Tv_Uvar (n, ctx_uvar_and_subst) -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> Tv_Uvar (n, ctx_uvar_and_subst)))) - | FStar_Reflection_V2_Data.Tv_AscribedT (e, t, tac, use_eq) -> + | FStarC_Reflection_V2_Data.Tv_AscribedT (e, t, tac, use_eq) -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> Tv_AscribedT (e, t, tac, use_eq)))) - | FStar_Reflection_V2_Data.Tv_AscribedC (e, c, tac, use_eq) -> + | FStarC_Reflection_V2_Data.Tv_AscribedC (e, c, tac, use_eq) -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> Tv_AscribedC - (e, (FStar_Reflection_V2_Builtins.inspect_comp c), + (e, (FStarC_Reflection_V2_Builtins.inspect_comp c), tac, use_eq)))) - | FStar_Reflection_V2_Data.Tv_Unknown -> + | FStarC_Reflection_V2_Data.Tv_Unknown -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> Tv_Unknown))) - | FStar_Reflection_V2_Data.Tv_Unsupp -> + | FStarC_Reflection_V2_Data.Tv_Unsupp -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> Tv_Unsupp))) - | FStar_Reflection_V2_Data.Tv_Abs (b, body) -> + | FStarC_Reflection_V2_Data.Tv_Abs (b, body) -> Obj.magic (Obj.repr (let uu___ = open_term b body in @@ -2864,11 +2876,11 @@ let (open_view : (fun uu___2 -> match uu___1 with | (nb, body1) -> Tv_Abs (nb, body1))))) - | FStar_Reflection_V2_Data.Tv_Arrow (b, c) -> + | FStarC_Reflection_V2_Data.Tv_Arrow (b, c) -> Obj.magic (Obj.repr (let uu___ = - open_comp b (FStar_Reflection_V2_Builtins.inspect_comp c) in + open_comp b (FStarC_Reflection_V2_Builtins.inspect_comp c) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2885,7 +2897,7 @@ let (open_view : FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> match uu___1 with | (nb, c1) -> Tv_Arrow (nb, c1))))) - | FStar_Reflection_V2_Data.Tv_Refine (b, ref) -> + | FStarC_Reflection_V2_Data.Tv_Refine (b, ref) -> Obj.magic (Obj.repr (let uu___ = open_term_simple b ref in @@ -2906,7 +2918,7 @@ let (open_view : (fun uu___2 -> match uu___1 with | (nb, ref1) -> Tv_Refine (nb, ref1))))) - | FStar_Reflection_V2_Data.Tv_Let (recf, attrs, b, def, body) -> + | FStarC_Reflection_V2_Data.Tv_Let (recf, attrs, b, def, body) -> Obj.magic (Obj.repr (let uu___ = open_term_simple b body in @@ -2931,12 +2943,12 @@ let (open_view : (recf, attrs, nb, (if recf then - FStar_Reflection_V2_Builtins.subst_term - [FStar_Syntax_Syntax.DB + FStarC_Reflection_V2_Builtins.subst_term + [FStarC_Syntax_Syntax.DB (Prims.int_zero, (r_binder_to_namedv nb))] def else def), body1))))) - | FStar_Reflection_V2_Data.Tv_Match (scrutinee, ret, brs) -> + | FStarC_Reflection_V2_Data.Tv_Match (scrutinee, ret, brs) -> Obj.magic (Obj.repr (let uu___ = FStar_Tactics_Util.map open_branch brs in @@ -2981,55 +2993,55 @@ let (open_view : (fun uu___2 -> Tv_Match (scrutinee, ret1, brs1))))) uu___1)))) uu___ -let (close_view : named_term_view -> FStar_Reflection_V2_Data.term_view) = +let (close_view : named_term_view -> FStarC_Reflection_V2_Data.term_view) = fun tv -> match tv with | Tv_Var v -> - FStar_Reflection_V2_Data.Tv_Var - (FStar_Reflection_V2_Builtins.pack_namedv v) + FStarC_Reflection_V2_Data.Tv_Var + (FStarC_Reflection_V2_Builtins.pack_namedv v) | Tv_BVar v -> - FStar_Reflection_V2_Data.Tv_BVar - (FStar_Reflection_V2_Builtins.pack_bv v) - | Tv_FVar v -> FStar_Reflection_V2_Data.Tv_FVar v - | Tv_UInst (v, us) -> FStar_Reflection_V2_Data.Tv_UInst (v, us) - | Tv_App (hd, a) -> FStar_Reflection_V2_Data.Tv_App (hd, a) - | Tv_Type u -> FStar_Reflection_V2_Data.Tv_Type u - | Tv_Const c -> FStar_Reflection_V2_Data.Tv_Const c + FStarC_Reflection_V2_Data.Tv_BVar + (FStarC_Reflection_V2_Builtins.pack_bv v) + | Tv_FVar v -> FStarC_Reflection_V2_Data.Tv_FVar v + | Tv_UInst (v, us) -> FStarC_Reflection_V2_Data.Tv_UInst (v, us) + | Tv_App (hd, a) -> FStarC_Reflection_V2_Data.Tv_App (hd, a) + | Tv_Type u -> FStarC_Reflection_V2_Data.Tv_Type u + | Tv_Const c -> FStarC_Reflection_V2_Data.Tv_Const c | Tv_Uvar (n, ctx_uvar_and_subst) -> - FStar_Reflection_V2_Data.Tv_Uvar (n, ctx_uvar_and_subst) + FStarC_Reflection_V2_Data.Tv_Uvar (n, ctx_uvar_and_subst) | Tv_AscribedT (e, t, tac, use_eq) -> - FStar_Reflection_V2_Data.Tv_AscribedT (e, t, tac, use_eq) + FStarC_Reflection_V2_Data.Tv_AscribedT (e, t, tac, use_eq) | Tv_AscribedC (e, c, tac, use_eq) -> - FStar_Reflection_V2_Data.Tv_AscribedC - (e, (FStar_Reflection_V2_Builtins.pack_comp c), tac, use_eq) - | Tv_Unknown -> FStar_Reflection_V2_Data.Tv_Unknown - | Tv_Unsupp -> FStar_Reflection_V2_Data.Tv_Unsupp + FStarC_Reflection_V2_Data.Tv_AscribedC + (e, (FStarC_Reflection_V2_Builtins.pack_comp c), tac, use_eq) + | Tv_Unknown -> FStarC_Reflection_V2_Data.Tv_Unknown + | Tv_Unsupp -> FStarC_Reflection_V2_Data.Tv_Unsupp | Tv_Abs (nb, body) -> let uu___ = close_term nb body in (match uu___ with - | (b, body1) -> FStar_Reflection_V2_Data.Tv_Abs (b, body1)) + | (b, body1) -> FStarC_Reflection_V2_Data.Tv_Abs (b, body1)) | Tv_Arrow (nb, c) -> let uu___ = close_comp nb c in (match uu___ with | (b, c1) -> - let c2 = FStar_Reflection_V2_Builtins.pack_comp c1 in - FStar_Reflection_V2_Data.Tv_Arrow (b, c2)) + let c2 = FStarC_Reflection_V2_Builtins.pack_comp c1 in + FStarC_Reflection_V2_Data.Tv_Arrow (b, c2)) | Tv_Refine (nb, ref) -> let uu___ = close_term_simple nb ref in (match uu___ with - | (b, ref1) -> FStar_Reflection_V2_Data.Tv_Refine (b, ref1)) + | (b, ref1) -> FStarC_Reflection_V2_Data.Tv_Refine (b, ref1)) | Tv_Let (recf, attrs, nb, def, body) -> let def1 = if recf then - FStar_Reflection_V2_Builtins.subst_term - [FStar_Syntax_Syntax.NM + FStarC_Reflection_V2_Builtins.subst_term + [FStarC_Syntax_Syntax.NM ((r_binder_to_namedv nb), Prims.int_zero)] def else def in let uu___ = close_term_simple nb body in (match uu___ with | (b, body1) -> - FStar_Reflection_V2_Data.Tv_Let (recf, attrs, b, def1, body1)) + FStarC_Reflection_V2_Data.Tv_Let (recf, attrs, b, def1, body1)) | Tv_Match (scrutinee, ret, brs) -> let brs1 = FStar_List_Tot_Base.map close_branch brs in let ret1 = @@ -3038,11 +3050,11 @@ let (close_view : named_term_view -> FStar_Reflection_V2_Data.term_view) = | FStar_Pervasives_Native.Some asc -> FStar_Pervasives_Native.Some (close_match_returns_ascription asc) in - FStar_Reflection_V2_Data.Tv_Match (scrutinee, ret1, brs1) + FStarC_Reflection_V2_Data.Tv_Match (scrutinee, ret1, brs1) let (inspect : term -> (named_term_view, unit) FStar_Tactics_Effect.tac_repr) = fun t -> - let uu___ = FStar_Tactics_V2_Builtins.compress t in + let uu___ = FStarC_Tactics_V2_Builtins.compress t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -3059,7 +3071,7 @@ let (inspect : term -> (named_term_view, unit) FStar_Tactics_Effect.tac_repr) let uu___1 = Obj.magic (FStar_Tactics_Effect.lift_div_tac - (fun uu___2 -> FStar_Reflection_V2_Builtins.inspect_ln t1)) in + (fun uu___2 -> FStarC_Reflection_V2_Builtins.inspect_ln t1)) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -3076,48 +3088,48 @@ let (inspect : term -> (named_term_view, unit) FStar_Tactics_Effect.tac_repr) (fun uu___2 -> (fun tv -> Obj.magic (open_view tv)) uu___2))) uu___1) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.NamedView.inspect" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.NamedView.inspect" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.NamedView.inspect (plugin)" - (FStar_Tactics_Native.from_tactic_1 inspect) - FStar_Reflection_V2_Embeddings.e_term e_named_term_view psc + (FStarC_Tactics_Native.from_tactic_1 inspect) + FStarC_Reflection_V2_Embeddings.e_term e_named_term_view psc ncb us args) let (pack : named_term_view -> term) = fun tv -> - let tv1 = close_view tv in FStar_Reflection_V2_Builtins.pack_ln tv1 + let tv1 = close_view tv in FStarC_Reflection_V2_Builtins.pack_ln tv1 let _ = - FStar_Tactics_Native.register_plugin "FStar.Tactics.NamedView.pack" + FStarC_Tactics_Native.register_plugin "FStar.Tactics.NamedView.pack" Prims.int_one (fun _psc -> fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap + FStarC_Syntax_Embeddings.debug_wrap "FStar.Tactics.NamedView.pack" (fun _ -> - (FStar_Syntax_Embeddings.arrow_as_prim_step_1 - e_named_term_view FStar_Reflection_V2_Embeddings.e_term + (FStarC_Syntax_Embeddings.arrow_as_prim_step_1 + e_named_term_view FStarC_Reflection_V2_Embeddings.e_term pack - (FStar_Ident.lid_of_str "FStar.Tactics.NamedView.pack") + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.pack") cb us) args)) (fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap "FStar.Tactics.NamedView.pack" + FStarC_Syntax_Embeddings.debug_wrap "FStar.Tactics.NamedView.pack" (fun _ -> - (FStar_TypeChecker_NBETerm.arrow_as_prim_step_1 - (FStar_TypeChecker_NBETerm.e_unsupported ()) - FStar_Reflection_V2_NBEEmbeddings.e_term pack - (FStar_Ident.lid_of_str "FStar.Tactics.NamedView.pack") cb - us) args)) + (FStarC_TypeChecker_NBETerm.arrow_as_prim_step_1 + (FStarC_TypeChecker_NBETerm.e_unsupported ()) + FStarC_Reflection_V2_NBEEmbeddings.e_term pack + (FStarC_Ident.lid_of_str "FStar.Tactics.NamedView.pack") + cb us) args)) let (open_univ_s : - FStar_Reflection_Types.univ_name Prims.list -> - ((univ_name Prims.list * FStar_Syntax_Syntax.subst_t), unit) + FStarC_Reflection_Types.univ_name Prims.list -> + ((univ_name Prims.list * FStarC_Syntax_Syntax.subst_t), unit) FStar_Tactics_Effect.tac_repr) = fun us -> @@ -3147,10 +3159,10 @@ let (open_univ_s : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> - FStar_Syntax_Syntax.UN + FStarC_Syntax_Syntax.UN (((n - Prims.int_one) - i), - (FStar_Reflection_V2_Builtins.pack_universe - (FStar_Reflection_V2_Data.Uv_Name u)))))) + (FStarC_Reflection_V2_Builtins.pack_universe + (FStarC_Reflection_V2_Data.Uv_Name u)))))) uu___3 uu___2) us in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -3174,7 +3186,7 @@ let (open_univ_s : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> - FStar_Reflection_V2_Builtins.inspect_ident + FStarC_Reflection_V2_Builtins.inspect_ident i))) uu___3) us in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -3197,29 +3209,29 @@ let (open_univ_s : uu___1) let (close_univ_s : univ_name Prims.list -> - (FStar_Reflection_Types.univ_name Prims.list * - FStar_Syntax_Syntax.subst_t)) + (FStarC_Reflection_Types.univ_name Prims.list * + FStarC_Syntax_Syntax.subst_t)) = fun us -> let n = FStar_List_Tot_Base.length us in let us1 = FStar_List_Tot_Base.map - (fun i -> FStar_Reflection_V2_Builtins.pack_ident i) us in + (fun i -> FStarC_Reflection_V2_Builtins.pack_ident i) us in let s = FStar_List_Tot_Base.mapi (fun i -> - fun u -> FStar_Syntax_Syntax.UD (u, ((n - i) - Prims.int_one))) + fun u -> FStarC_Syntax_Syntax.UD (u, ((n - i) - Prims.int_one))) us1 in (us1, s) let (open_lb : - FStar_Reflection_Types.letbinding -> + FStarC_Reflection_Types.letbinding -> (letbinding, unit) FStar_Tactics_Effect.tac_repr) = fun lb -> let uu___ = Obj.magic (FStar_Tactics_Effect.lift_div_tac - (fun uu___1 -> FStar_Reflection_V2_Builtins.inspect_lb lb)) in + (fun uu___1 -> FStarC_Reflection_V2_Builtins.inspect_lb lb)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -3234,10 +3246,10 @@ let (open_lb : (fun uu___1 -> (fun uu___1 -> match uu___1 with - | { FStar_Reflection_V2_Data.lb_fv = lb_fv; - FStar_Reflection_V2_Data.lb_us = lb_us; - FStar_Reflection_V2_Data.lb_typ = lb_typ; - FStar_Reflection_V2_Data.lb_def = lb_def;_} -> + | { FStarC_Reflection_V2_Data.lb_fv = lb_fv; + FStarC_Reflection_V2_Data.lb_us = lb_us; + FStarC_Reflection_V2_Data.lb_typ = lb_typ; + FStarC_Reflection_V2_Data.lb_def = lb_def;_} -> let uu___2 = open_univ_s lb_us in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -3263,13 +3275,13 @@ let (open_lb : lb_fv; lb_us = lb_us1; lb_typ = - (FStar_Reflection_V2_Builtins.subst_term + (FStarC_Reflection_V2_Builtins.subst_term s lb_typ); lb_def = - (FStar_Reflection_V2_Builtins.subst_term + (FStarC_Reflection_V2_Builtins.subst_term s lb_def) })))) uu___1) -let (close_lb : letbinding -> FStar_Reflection_Types.letbinding) = +let (close_lb : letbinding -> FStarC_Reflection_Types.letbinding) = fun lb -> let uu___ = lb in match uu___ with @@ -3277,19 +3289,19 @@ let (close_lb : letbinding -> FStar_Reflection_Types.letbinding) = let uu___1 = close_univ_s lb_us in (match uu___1 with | (lb_us1, s) -> - let lb_typ1 = FStar_Reflection_V2_Builtins.subst_term s lb_typ in - let lb_def1 = FStar_Reflection_V2_Builtins.subst_term s lb_def in - FStar_Reflection_V2_Builtins.pack_lb + let lb_typ1 = FStarC_Reflection_V2_Builtins.subst_term s lb_typ in + let lb_def1 = FStarC_Reflection_V2_Builtins.subst_term s lb_def in + FStarC_Reflection_V2_Builtins.pack_lb { - FStar_Reflection_V2_Data.lb_fv = lb_fv; - FStar_Reflection_V2_Data.lb_us = lb_us1; - FStar_Reflection_V2_Data.lb_typ = lb_typ1; - FStar_Reflection_V2_Data.lb_def = lb_def1 + FStarC_Reflection_V2_Data.lb_fv = lb_fv; + FStarC_Reflection_V2_Data.lb_us = lb_us1; + FStarC_Reflection_V2_Data.lb_typ = lb_typ1; + FStarC_Reflection_V2_Data.lb_def = lb_def1 }) let (subst_r_binders : - FStar_Syntax_Syntax.subst_t -> - FStar_Reflection_Types.binder Prims.list -> - FStar_Reflection_Types.binder Prims.list) + FStarC_Syntax_Syntax.subst_t -> + FStarC_Reflection_Types.binder Prims.list -> + FStarC_Reflection_Types.binder Prims.list) = fun s -> fun bs -> @@ -3331,19 +3343,20 @@ let rec (open_n_binders_from_arrow : (fun uu___1 -> match uu___1 with | Tv_Arrow - (b', FStar_Reflection_V2_Data.C_Total t') -> + (b', FStarC_Reflection_V2_Data.C_Total t') + -> Obj.magic (Obj.repr (let uu___2 = Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> - FStar_Reflection_V2_Builtins.subst_term - [FStar_Syntax_Syntax.NT + FStarC_Reflection_V2_Builtins.subst_term + [FStarC_Syntax_Syntax.NT ((r_binder_to_namedv b'), (pack (Tv_Var - (FStar_Reflection_V2_Builtins.inspect_namedv + (FStarC_Reflection_V2_Builtins.inspect_namedv (r_binder_to_namedv b)))))] t')) in @@ -3377,13 +3390,13 @@ let rec (open_n_binders_from_arrow : NotEnoughBinders))) uu___1)))) uu___1 uu___ let (open_sigelt_view : - FStar_Reflection_V2_Data.sigelt_view -> + FStarC_Reflection_V2_Data.sigelt_view -> (named_sigelt_view, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> (fun sv -> match sv with - | FStar_Reflection_V2_Data.Sg_Let (isrec, lbs) -> + | FStarC_Reflection_V2_Data.Sg_Let (isrec, lbs) -> Obj.magic (Obj.repr (let uu___ = FStar_Tactics_Util.map open_lb lbs in @@ -3402,7 +3415,7 @@ let (open_sigelt_view : (fun lbs1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___1 -> Sg_Let { isrec; lbs = lbs1 })))) - | FStar_Reflection_V2_Data.Sg_Inductive + | FStarC_Reflection_V2_Data.Sg_Inductive (nm, univs, params, typ, ctors) -> Obj.magic (Obj.repr @@ -3478,7 +3491,7 @@ let (open_sigelt_view : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___5 -> - FStar_Reflection_V2_Builtins.subst_term + FStarC_Reflection_V2_Builtins.subst_term (FStar_Reflection_V2_Derived.shift_subst nparams s) typ)) in @@ -3519,7 +3532,7 @@ let (open_sigelt_view : (nm1, ty) -> (nm1, - (FStar_Reflection_V2_Builtins.subst_term + (FStarC_Reflection_V2_Builtins.subst_term s ty))))) uu___6) ctors in @@ -3664,7 +3677,7 @@ let (open_sigelt_view : uu___6))) uu___5))) uu___4))) uu___2))) uu___1))) - | FStar_Reflection_V2_Data.Sg_Val (nm, univs, typ) -> + | FStarC_Reflection_V2_Data.Sg_Val (nm, univs, typ) -> Obj.magic (Obj.repr (let uu___ = open_univ_s univs in @@ -3690,10 +3703,10 @@ let (open_sigelt_view : nm1 = nm; univs2 = univs1; typ1 = - (FStar_Reflection_V2_Builtins.subst_term + (FStarC_Reflection_V2_Builtins.subst_term s typ) })))) - | FStar_Reflection_V2_Data.Unk -> + | FStarC_Reflection_V2_Data.Unk -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> Unk)))) uu___ @@ -3730,7 +3743,7 @@ let rec (mk_arr : (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> - FStar_Reflection_V2_Data.C_Total uu___2)) in + FStarC_Reflection_V2_Data.C_Total uu___2)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -3749,7 +3762,7 @@ let rec (mk_arr : uu___1 uu___ let (close_sigelt_view : named_sigelt_view -> - (FStar_Reflection_V2_Data.sigelt_view, unit) + (FStarC_Reflection_V2_Data.sigelt_view, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> @@ -3760,7 +3773,7 @@ let (close_sigelt_view : (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> - FStar_Reflection_V2_Data.Sg_Let + FStarC_Reflection_V2_Data.Sg_Let (isrec, (FStar_List_Tot_Base.map close_lb lbs))))) | Sg_Inductive { nm; univs1 = univs; params; typ; ctors;_} -> Obj.magic @@ -3930,7 +3943,7 @@ let (close_sigelt_view : (FStar_Tactics_Effect.lift_div_tac (fun uu___8 -> - FStar_Reflection_V2_Builtins.subst_term + FStarC_Reflection_V2_Builtins.subst_term (FStar_Reflection_V2_Derived.shift_subst nparams s) typ1)) in @@ -3976,7 +3989,7 @@ let (close_sigelt_view : (nm1, ty) -> (nm1, - (FStar_Reflection_V2_Builtins.subst_term + (FStarC_Reflection_V2_Builtins.subst_term s ty))))) uu___9) ctors1 in @@ -4005,7 +4018,7 @@ let (close_sigelt_view : FStar_Tactics_Effect.lift_div_tac (fun uu___9 -> - FStar_Reflection_V2_Data.Sg_Inductive + FStarC_Reflection_V2_Data.Sg_Inductive (nm, univs1, params2, @@ -4022,19 +4035,19 @@ let (close_sigelt_view : (fun uu___ -> match close_univ_s univs with | (univs1, s) -> - FStar_Reflection_V2_Data.Sg_Val + FStarC_Reflection_V2_Data.Sg_Val (nm, univs1, - (FStar_Reflection_V2_Builtins.subst_term s typ)))))) + (FStarC_Reflection_V2_Builtins.subst_term s typ)))))) uu___ let (inspect_sigelt : - FStar_Reflection_Types.sigelt -> + FStarC_Reflection_Types.sigelt -> (named_sigelt_view, unit) FStar_Tactics_Effect.tac_repr) = fun s -> let uu___ = Obj.magic (FStar_Tactics_Effect.lift_div_tac - (fun uu___1 -> FStar_Reflection_V2_Builtins.inspect_sigelt s)) in + (fun uu___1 -> FStarC_Reflection_V2_Builtins.inspect_sigelt s)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -4048,20 +4061,20 @@ let (inspect_sigelt : (Prims.of_int (21))))) (Obj.magic uu___) (fun uu___1 -> (fun sv -> Obj.magic (open_sigelt_view sv)) uu___1) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.NamedView.inspect_sigelt" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.NamedView.inspect_sigelt (plugin)" - (FStar_Tactics_Native.from_tactic_1 inspect_sigelt) - FStar_Reflection_V2_Embeddings.e_sigelt e_named_sigelt_view + (FStarC_Tactics_Native.from_tactic_1 inspect_sigelt) + FStarC_Reflection_V2_Embeddings.e_sigelt e_named_sigelt_view psc ncb us args) let (pack_sigelt : named_sigelt_view -> - (FStar_Reflection_Types.sigelt, unit) FStar_Tactics_Effect.tac_repr) + (FStarC_Reflection_Types.sigelt, unit) FStar_Tactics_Effect.tac_repr) = fun sv -> let uu___ = close_sigelt_view sv in @@ -4078,26 +4091,26 @@ let (pack_sigelt : (Prims.of_int (18))))) (Obj.magic uu___) (fun sv1 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___1 -> FStar_Reflection_V2_Builtins.pack_sigelt sv1)) + (fun uu___1 -> FStarC_Reflection_V2_Builtins.pack_sigelt sv1)) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.NamedView.pack_sigelt" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.NamedView.pack_sigelt" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.NamedView.pack_sigelt (plugin)" - (FStar_Tactics_Native.from_tactic_1 pack_sigelt) - e_named_sigelt_view FStar_Reflection_V2_Embeddings.e_sigelt + (FStarC_Tactics_Native.from_tactic_1 pack_sigelt) + e_named_sigelt_view FStarC_Reflection_V2_Embeddings.e_sigelt psc ncb us args) let (tcc : - FStar_Reflection_Types.env -> + FStarC_Reflection_Types.env -> term -> (comp, unit) FStar_Tactics_Effect.tac_repr) = fun e -> fun t -> - let uu___ = FStar_Tactics_V2_Builtins.tcc e t in + let uu___ = FStarC_Tactics_V2_Builtins.tcc e t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -4111,37 +4124,37 @@ let (tcc : (Prims.of_int (18))))) (Obj.magic uu___) (fun c -> FStar_Tactics_Effect.lift_div_tac - (fun uu___1 -> FStar_Reflection_V2_Builtins.inspect_comp c)) + (fun uu___1 -> FStarC_Reflection_V2_Builtins.inspect_comp c)) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.NamedView.tcc" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.NamedView.tcc" (Prims.of_int (3)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_2 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_2 "FStar.Tactics.NamedView.tcc (plugin)" - (FStar_Tactics_Native.from_tactic_2 tcc) - FStar_Reflection_V2_Embeddings.e_env - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_comp_view psc ncb us args) + (FStarC_Tactics_Native.from_tactic_2 tcc) + FStarC_Reflection_V2_Embeddings.e_env + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_comp_view psc ncb us args) let (comp_to_string : comp -> (Prims.string, unit) FStar_Tactics_Effect.tac_repr) = fun c -> - FStar_Tactics_V2_Builtins.comp_to_string - (FStar_Reflection_V2_Builtins.pack_comp c) + FStarC_Tactics_V2_Builtins.comp_to_string + (FStarC_Reflection_V2_Builtins.pack_comp c) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.NamedView.comp_to_string" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.NamedView.comp_to_string (plugin)" - (FStar_Tactics_Native.from_tactic_1 comp_to_string) - FStar_Reflection_V2_Embeddings.e_comp_view - FStar_Syntax_Embeddings.e_string psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 comp_to_string) + FStarC_Reflection_V2_Embeddings.e_comp_view + FStarC_Syntax_Embeddings.e_string psc ncb us args) type universe_view = named_universe_view type term_view = named_term_view type sigelt_view = named_sigelt_view diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_Names.ml b/ocaml/fstar-lib/generated/FStar_Tactics_Names.ml index d4dcf4cbe0f..297318d795b 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_Names.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_Names.ml @@ -3,7 +3,7 @@ exception Appears let (uu___is_Appears : Prims.exn -> Prims.bool) = fun projectee -> match projectee with | Appears -> true | uu___ -> false let (name_appears_in : - FStar_Reflection_Types.name -> + FStarC_Reflection_Types.name -> FStar_Tactics_NamedView.term -> (Prims.bool, unit) FStar_Tactics_Effect.tac_repr) = @@ -35,7 +35,7 @@ let (name_appears_in : (Obj.repr (let uu___4 = if - (FStar_Reflection_V2_Builtins.inspect_fv + (FStarC_Reflection_V2_Builtins.inspect_fv fv) = nm then @@ -85,7 +85,7 @@ let (name_appears_in : (fun uu___1 -> (fun ff -> let uu___1 = - FStar_Tactics_V2_Builtins.catch + FStarC_Tactics_V2_Builtins.catch (fun uu___2 -> let uu___3 = let uu___4 = FStar_Tactics_Visit.visit_tm ff t in @@ -144,16 +144,16 @@ let (name_appears_in : | FStar_Pervasives.Inl e -> FStar_Tactics_Effect.raise e))) uu___1) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.Names.name_appears_in" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.Names.name_appears_in" (Prims.of_int (3)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_2 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_2 "FStar.Tactics.Names.name_appears_in (plugin)" - (FStar_Tactics_Native.from_tactic_2 name_appears_in) - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_string) - FStar_Reflection_V2_Embeddings.e_term - FStar_Syntax_Embeddings.e_bool psc ncb us args) \ No newline at end of file + (FStarC_Tactics_Native.from_tactic_2 name_appears_in) + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_string) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Syntax_Embeddings.e_bool psc ncb us args) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_Parametricity.ml b/ocaml/fstar-lib/generated/FStar_Tactics_Parametricity.ml index 20747ac852a..625efda7e42 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_Parametricity.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_Parametricity.ml @@ -5,19 +5,19 @@ let (uu___is_Unsupported : Prims.exn -> Prims.bool) = match projectee with | Unsupported uu___ -> true | uu___ -> false let (__proj__Unsupported__item__uu___ : Prims.exn -> Prims.string) = fun projectee -> match projectee with | Unsupported uu___ -> uu___ -exception NotFoundFV of FStar_Reflection_Types.fv +exception NotFoundFV of FStarC_Reflection_Types.fv let (uu___is_NotFoundFV : Prims.exn -> Prims.bool) = fun projectee -> match projectee with | NotFoundFV uu___ -> true | uu___ -> false let (__proj__NotFoundFV__item__uu___ : - Prims.exn -> FStar_Reflection_Types.fv) = + Prims.exn -> FStarC_Reflection_Types.fv) = fun projectee -> match projectee with | NotFoundFV uu___ -> uu___ type bvmap = (FStar_Tactics_NamedView.namedv * (FStar_Tactics_NamedView.binder * FStar_Tactics_NamedView.binder * FStar_Tactics_NamedView.binder)) Prims.list type fvmap = - (FStar_Reflection_Types.fv * FStar_Reflection_Types.fv) Prims.list + (FStarC_Reflection_Types.fv * FStarC_Reflection_Types.fv) Prims.list type param_state = { bvmap: bvmap ; fresh: Prims.int ; @@ -144,8 +144,8 @@ let (__proj__NotFoundBV__item__uu___ : fun projectee -> match projectee with | NotFoundBV uu___ -> uu___ let (lookup_rec_fv : param_state -> - FStar_Reflection_Types.fv -> - (FStar_Reflection_Types.fv, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.fv -> + (FStarC_Reflection_Types.fv, unit) FStar_Tactics_Effect.tac_repr) = fun s -> fun f -> @@ -166,8 +166,8 @@ let (lookup_rec_fv : else Obj.repr (aux fs)))) uu___ in aux s.recs let (push_fv : - FStar_Reflection_Types.fv -> - FStar_Reflection_Types.fv -> param_state -> param_state) + FStarC_Reflection_Types.fv -> + FStarC_Reflection_Types.fv -> param_state -> param_state) = fun f1 -> fun f2 -> @@ -193,9 +193,9 @@ let (lookup : Obj.magic (Obj.repr (if - (FStar_Tactics_NamedView.inspect_namedv v).FStar_Reflection_V2_Data.uniq + (FStar_Tactics_NamedView.inspect_namedv v).FStarC_Reflection_V2_Data.uniq = - (FStar_Tactics_NamedView.inspect_namedv v').FStar_Reflection_V2_Data.uniq + (FStar_Tactics_NamedView.inspect_namedv v').FStarC_Reflection_V2_Data.uniq then Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> r)) @@ -299,9 +299,9 @@ let (replace_by : (Prims.of_int (7))))) (Obj.magic uu___) (fun r -> FStar_Tactics_Effect.lift_div_tac (fun uu___1 -> r)) let (tapp : - FStar_Reflection_V2_Data.aqualv -> + FStarC_Reflection_V2_Data.aqualv -> FStar_Tactics_NamedView.term -> - FStar_Reflection_Types.term -> FStar_Tactics_NamedView.term) + FStarC_Reflection_Types.term -> FStar_Tactics_NamedView.term) = fun q -> fun t1 -> @@ -460,15 +460,15 @@ let rec (param' : (FStar_Tactics_NamedView.pack (FStar_Tactics_NamedView.Tv_Arrow (xs, - (FStar_Reflection_V2_Data.C_Total + (FStarC_Reflection_V2_Data.C_Total (FStar_Tactics_NamedView.pack (FStar_Tactics_NamedView.Tv_Arrow (xr, - (FStar_Reflection_V2_Data.C_Total - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Type - (FStar_Reflection_V2_Builtins.pack_universe - FStar_Reflection_V2_Data.Uv_Unk)))))))))))))))))))) + (FStarC_Reflection_V2_Data.C_Total + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Type + (FStarC_Reflection_V2_Builtins.pack_universe + FStarC_Reflection_V2_Data.Uv_Unk)))))))))))))))))))) uu___6))) uu___5))) uu___4))) | FStar_Tactics_NamedView.Tv_Var bv -> @@ -500,7 +500,7 @@ let rec (param' : Obj.magic (Obj.repr (match FStar_Tactics_NamedView.inspect_comp c with - | FStar_Reflection_V2_Data.C_Total t2 -> + | FStarC_Reflection_V2_Data.C_Total t2 -> Obj.repr (let uu___3 = push_binder b s in FStar_Tactics_Effect.tac_bind @@ -796,15 +796,15 @@ let rec (param' : (fun uu___16 -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App (uu___15, (uu___13, - FStar_Reflection_V2_Data.Q_Explicit)))), + FStarC_Reflection_V2_Data.Q_Explicit)))), (uu___11, - FStar_Reflection_V2_Data.Q_Explicit))))))) + FStarC_Reflection_V2_Data.Q_Explicit))))))) uu___13))) uu___11) in Obj.magic @@ -1313,9 +1313,9 @@ let rec (param' : (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const - FStar_Reflection_V2_Data.C_Unit)))) + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const + FStarC_Reflection_V2_Data.C_Unit)))) | FStar_Tactics_NamedView.Tv_AscribedT (t1, uu___3, uu___4, uu___5) -> Obj.magic (Obj.repr (param' s t1)) @@ -1379,8 +1379,8 @@ let rec (param' : (fun r -> FStar_Tactics_Effect.lift_div_tac (fun uu___1 -> r)) and (param_fv : param_state -> - FStar_Reflection_Types.fv -> - (FStar_Reflection_Types.fv, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.fv -> + (FStarC_Reflection_Types.fv, unit) FStar_Tactics_Effect.tac_repr) = fun s -> fun f -> @@ -1391,10 +1391,10 @@ and (param_fv : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> - FStar_Reflection_V2_Builtins.explode_qn + FStarC_Reflection_V2_Builtins.explode_qn (Prims.strcat - (FStar_Reflection_V2_Builtins.implode_qn - (FStar_Reflection_V2_Builtins.inspect_fv f)) + (FStarC_Reflection_V2_Builtins.implode_qn + (FStarC_Reflection_V2_Builtins.inspect_fv f)) "_param"))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1411,7 +1411,7 @@ and (param_fv : (fun uu___2 -> (fun nm' -> let uu___2 = - let uu___3 = FStar_Tactics_V2_Builtins.top_env () in + let uu___3 = FStarC_Tactics_V2_Builtins.top_env () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1429,8 +1429,8 @@ and (param_fv : (fun uu___4 -> FStar_Tactics_Effect.lift_div_tac (fun uu___5 -> - FStar_Reflection_V2_Builtins.lookup_typ uu___4 - nm')) in + FStarC_Reflection_V2_Builtins.lookup_typ + uu___4 nm')) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1454,7 +1454,7 @@ and (param_fv : (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> - FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_fv nm'))) | FStar_Pervasives_Native.None -> Obj.magic @@ -1466,7 +1466,7 @@ and (param_fv : let uu___8 = let uu___9 = last - (FStar_Reflection_V2_Builtins.inspect_fv + (FStarC_Reflection_V2_Builtins.inspect_fv f) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1603,7 +1603,7 @@ and (param_fv : (fun nm'1 -> let uu___5 = let uu___6 = - FStar_Tactics_V2_Builtins.top_env + FStarC_Tactics_V2_Builtins.top_env () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1626,7 +1626,7 @@ and (param_fv : (fun uu___7 -> FStar_Tactics_Effect.lift_div_tac (fun uu___8 -> - FStar_Reflection_V2_Builtins.lookup_typ + FStarC_Reflection_V2_Builtins.lookup_typ uu___7 nm'1)) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1658,7 +1658,7 @@ and (param_fv : FStar_Tactics_Effect.lift_div_tac (fun uu___7 -> - FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_fv nm'1))) | FStar_Pervasives_Native.None -> @@ -1701,7 +1701,7 @@ and (param_fv : let uu___12 = last - (FStar_Reflection_V2_Builtins.inspect_fv + (FStarC_Reflection_V2_Builtins.inspect_fv f) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1817,7 +1817,7 @@ and (param_fv : = let uu___9 = - FStar_Tactics_V2_Builtins.top_env + FStarC_Tactics_V2_Builtins.top_env () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1845,7 +1845,7 @@ and (param_fv : (fun uu___11 -> - FStar_Reflection_V2_Builtins.lookup_typ + FStarC_Reflection_V2_Builtins.lookup_typ uu___10 nm'2)) in Obj.magic @@ -1879,7 +1879,7 @@ and (param_fv : (fun uu___10 -> - FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_fv nm'2) | FStar_Pervasives_Native.None @@ -2213,8 +2213,8 @@ and (param_pat : (Obj.repr (let uu___1 = FStar_Tactics_V2_Derived.fresh_binder_named "cR" - (FStar_Reflection_V2_Builtins.pack_ln - FStar_Reflection_V2_Data.Tv_Unknown) in + (FStarC_Reflection_V2_Builtins.pack_ln + FStarC_Reflection_V2_Data.Tv_Unknown) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2242,8 +2242,8 @@ and (param_pat : b); FStar_Tactics_NamedView.sort1 = (FStar_Sealed.seal - (FStar_Reflection_V2_Builtins.pack_ln - FStar_Reflection_V2_Data.Tv_Unknown)) + (FStarC_Reflection_V2_Builtins.pack_ln + FStarC_Reflection_V2_Data.Tv_Unknown)) })))))))) uu___1) and (param_br : param_state -> @@ -2714,15 +2714,15 @@ and (push_binder : (fun uu___16 -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App (uu___15, (uu___13, - FStar_Reflection_V2_Data.Q_Explicit)))), + FStarC_Reflection_V2_Data.Q_Explicit)))), (uu___11, - FStar_Reflection_V2_Data.Q_Explicit))))))) + FStarC_Reflection_V2_Data.Q_Explicit))))))) uu___13))) uu___11) in Obj.magic @@ -2905,19 +2905,19 @@ let (param : (Prims.of_int (7))))) (Obj.magic uu___) (fun t1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___1 -> t1)) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.Parametricity.param" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.Parametricity.param" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.Parametricity.param (plugin)" - (FStar_Tactics_Native.from_tactic_1 param) - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_term psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 param) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_term psc ncb us args) let (fv_to_tm : - FStar_Reflection_Types.fv -> + FStarC_Reflection_Types.fv -> (FStar_Tactics_NamedView.term, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> @@ -2928,10 +2928,10 @@ let (fv_to_tm : FStar_Tactics_NamedView.pack (FStar_Tactics_NamedView.Tv_FVar f)))) uu___ let (param_ctor : - FStar_Reflection_Types.name -> + FStarC_Reflection_Types.name -> param_state -> - FStar_Reflection_V2_Data.ctor -> - (FStar_Reflection_V2_Data.ctor, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_V2_Data.ctor -> + (FStarC_Reflection_V2_Data.ctor, unit) FStar_Tactics_Effect.tac_repr) = fun nm_ty -> fun s -> @@ -3087,7 +3087,7 @@ let (param_ctor : let uu___5 = let uu___6 = fv_to_tm - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_fv nm) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -3251,7 +3251,7 @@ let (param_ctor : c1 with | - FStar_Reflection_V2_Data.C_Total + FStarC_Reflection_V2_Data.C_Total ty1 -> Obj.magic (FStar_Tactics_Effect.lift_div_tac @@ -3512,10 +3512,10 @@ let (param_ctor : uu___6))) uu___4))) uu___3))) uu___1) let (param_inductive : - FStar_Reflection_Types.sigelt -> - FStar_Reflection_Types.fv -> - FStar_Reflection_Types.fv -> - (FStar_Reflection_Types.decls, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.sigelt -> + FStarC_Reflection_Types.fv -> + FStarC_Reflection_Types.fv -> + (FStarC_Reflection_Types.decls, unit) FStar_Tactics_Effect.tac_repr) = fun se -> fun fv0 -> @@ -3569,7 +3569,7 @@ let (param_inductive : let uu___3 = let uu___4 = fv_to_tm - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_fv nm) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -3936,7 +3936,7 @@ let (param_inductive : { FStar_Tactics_NamedView.nm = - (FStar_Reflection_V2_Builtins.inspect_fv + (FStarC_Reflection_V2_Builtins.inspect_fv fv1); FStar_Tactics_NamedView.univs1 = univs; @@ -4015,10 +4015,10 @@ let (param_inductive : Obj.magic (Obj.repr (FStar_Tactics_V2_Derived.fail ""))) uu___1) let (param_letbinding : - FStar_Reflection_Types.sigelt -> - FStar_Reflection_Types.fv -> - FStar_Reflection_Types.fv -> - (FStar_Reflection_Types.decls, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.sigelt -> + FStarC_Reflection_Types.fv -> + FStarC_Reflection_Types.fv -> + (FStarC_Reflection_Types.decls, unit) FStar_Tactics_Effect.tac_repr) = fun se -> fun fv0 -> @@ -4372,7 +4372,7 @@ let (param_letbinding : uu___1) let (paramd : Prims.string -> - (FStar_Reflection_Types.decls, unit) FStar_Tactics_Effect.tac_repr) + (FStarC_Reflection_Types.decls, unit) FStar_Tactics_Effect.tac_repr) = fun nm -> let uu___ = @@ -4395,7 +4395,7 @@ let (paramd : let uu___4 = let uu___5 = let uu___6 = - last (FStar_Reflection_V2_Builtins.explode_qn nm) in + last (FStarC_Reflection_V2_Builtins.explode_qn nm) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -4463,7 +4463,7 @@ let (paramd : (Obj.magic uu___1) (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___3 -> FStar_Reflection_V2_Builtins.implode_qn uu___2)) in + (fun uu___3 -> FStarC_Reflection_V2_Builtins.implode_qn uu___2)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -4481,8 +4481,8 @@ let (paramd : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> - FStar_Reflection_V2_Builtins.pack_fv - (FStar_Reflection_V2_Builtins.explode_qn nm))) in + FStarC_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.explode_qn nm))) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -4504,8 +4504,8 @@ let (paramd : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> - FStar_Reflection_V2_Builtins.pack_fv - (FStar_Reflection_V2_Builtins.explode_qn + FStarC_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.explode_qn nm'))) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -4526,7 +4526,7 @@ let (paramd : (fun fv1 -> let uu___3 = let uu___4 = - FStar_Tactics_V2_Builtins.top_env () in + FStarC_Tactics_V2_Builtins.top_env () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -4548,9 +4548,9 @@ let (paramd : (fun uu___5 -> FStar_Tactics_Effect.lift_div_tac (fun uu___6 -> - FStar_Reflection_V2_Builtins.lookup_typ + FStarC_Reflection_V2_Builtins.lookup_typ uu___5 - (FStar_Reflection_V2_Builtins.explode_qn + (FStarC_Reflection_V2_Builtins.explode_qn nm))) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -4655,21 +4655,21 @@ let (paramd : uu___4))) uu___3))) uu___2))) uu___1) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.Parametricity.paramd" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.Parametricity.paramd" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.Parametricity.paramd (plugin)" - (FStar_Tactics_Native.from_tactic_1 paramd) - FStar_Syntax_Embeddings.e_string - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_sigelt) psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 paramd) + FStarC_Syntax_Embeddings.e_string + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_sigelt) psc ncb us args) let (paramds : Prims.string Prims.list -> - (FStar_Reflection_Types.decls, unit) FStar_Tactics_Effect.tac_repr) + (FStarC_Reflection_Types.decls, unit) FStar_Tactics_Effect.tac_repr) = fun nms -> let uu___ = FStar_Tactics_Util.map paramd nms in @@ -4688,19 +4688,19 @@ let (paramds : FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> FStar_List_Tot_Base.flatten uu___1)) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.Parametricity.paramds" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.Parametricity.paramds" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.Parametricity.paramds (plugin)" - (FStar_Tactics_Native.from_tactic_1 paramds) - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_string) - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_sigelt) psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 paramds) + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_string) + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_sigelt) psc ncb us args) type ('a, 'x, 'y) param_of_eqtype = unit type ('uuuuu, 'uuuuu1) int_param = unit type ('uuuuu, 'uuuuu1) bool_param = unit diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_PatternMatching.ml b/ocaml/fstar-lib/generated/FStar_Tactics_PatternMatching.ml index 6cff4c935aa..9bc5f96284f 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_PatternMatching.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_PatternMatching.ml @@ -588,7 +588,8 @@ let (and_elim' : (Prims.of_int (145)) (Prims.of_int (2)) (Prims.of_int (145)) (Prims.of_int (9))))) (Obj.magic uu___) (fun uu___1 -> - (fun uu___1 -> Obj.magic (FStar_Tactics_V2_Builtins.clear h)) uu___1) + (fun uu___1 -> Obj.magic (FStarC_Tactics_V2_Builtins.clear h)) + uu___1) let exact_hyp : 'a . FStar_Tactics_NamedView.namedv -> @@ -621,7 +622,7 @@ let exact_hyp : (FStar_Reflection_V2_Derived.mk_app hd [((FStar_Tactics_NamedView.pack (FStar_Tactics_NamedView.Tv_Var h)), - FStar_Reflection_V2_Data.Q_Explicit)]))) uu___1) + FStarC_Reflection_V2_Data.Q_Explicit)]))) uu___1) let (exact_hyp' : FStar_Tactics_NamedView.namedv -> (unit, unit) FStar_Tactics_Effect.tac_repr) @@ -676,7 +677,7 @@ type match_exception = | NonLinearMismatch of (varname * FStar_Tactics_NamedView.term * FStar_Tactics_NamedView.term) | UnsupportedTermInPattern of FStar_Tactics_NamedView.term - | IncorrectTypeInAbsPatBinder of FStar_Reflection_Types.typ + | IncorrectTypeInAbsPatBinder of FStarC_Reflection_Types.typ let (uu___is_NameMismatch : match_exception -> Prims.bool) = fun projectee -> match projectee with | NameMismatch _0 -> true | uu___ -> false @@ -709,7 +710,7 @@ let (uu___is_IncorrectTypeInAbsPatBinder : match_exception -> Prims.bool) = | IncorrectTypeInAbsPatBinder _0 -> true | uu___ -> false let (__proj__IncorrectTypeInAbsPatBinder__item___0 : - match_exception -> FStar_Reflection_Types.typ) = + match_exception -> FStarC_Reflection_Types.typ) = fun projectee -> match projectee with | IncorrectTypeInAbsPatBinder _0 -> _0 let (term_head : @@ -773,7 +774,8 @@ let (string_of_match_exception : (Obj.repr (let uu___1 = let uu___2 = - let uu___3 = FStar_Tactics_V2_Builtins.term_to_string tm in + let uu___3 = + FStarC_Tactics_V2_Builtins.term_to_string tm in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -833,7 +835,7 @@ let (string_of_match_exception : let uu___2 = let uu___3 = let uu___4 = - FStar_Tactics_V2_Builtins.term_to_string t1 in + FStarC_Tactics_V2_Builtins.term_to_string t1 in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -852,7 +854,7 @@ let (string_of_match_exception : (fun uu___5 -> let uu___6 = let uu___7 = - FStar_Tactics_V2_Builtins.term_to_string + FStarC_Tactics_V2_Builtins.term_to_string t2 in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -954,7 +956,7 @@ let (string_of_match_exception : Obj.magic (Obj.repr (let uu___1 = - let uu___2 = FStar_Tactics_V2_Builtins.term_to_string tm in + let uu___2 = FStarC_Tactics_V2_Builtins.term_to_string tm in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1059,7 +1061,7 @@ let (string_of_match_exception : Obj.magic (Obj.repr (let uu___1 = - let uu___2 = FStar_Tactics_V2_Builtins.term_to_string typ in + let uu___2 = FStarC_Tactics_V2_Builtins.term_to_string typ in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1204,7 +1206,7 @@ let (string_of_bindings : | (nm, tm) -> let uu___2 = let uu___3 = - let uu___4 = FStar_Tactics_V2_Builtins.term_to_string tm in + let uu___4 = FStarC_Tactics_V2_Builtins.term_to_string tm in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1781,7 +1783,7 @@ let (string_of_matching_solution : match uu___2 with | (varname1, tm) -> let uu___3 = - let uu___4 = FStar_Tactics_V2_Builtins.term_to_string tm in + let uu___4 = FStarC_Tactics_V2_Builtins.term_to_string tm in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1969,7 +1971,7 @@ let ms_locate_var : (Prims.of_int (55))))) (Obj.magic uu___) (fun uu___1 -> (fun uu___1 -> - Obj.magic (FStar_Tactics_V2_Builtins.unquote uu___1)) uu___1) + Obj.magic (FStarC_Tactics_V2_Builtins.unquote uu___1)) uu___1) let ms_locate_unit : 'uuuuu 'uuuuu1 'a . 'uuuuu -> 'uuuuu1 -> (unit, unit) FStar_Tactics_Effect.tac_repr @@ -2265,9 +2267,9 @@ let (name_of_namedv : = fun x -> FStar_Tactics_Unseal.unseal - (FStar_Tactics_NamedView.inspect_namedv x).FStar_Reflection_V2_Data.ppname + (FStar_Tactics_NamedView.inspect_namedv x).FStarC_Reflection_V2_Data.ppname let rec (pattern_of_term_ex : - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.term -> (pattern match_res, unit) FStar_Tactics_Effect.tac_repr) = fun tm -> @@ -2414,7 +2416,7 @@ let (beta_reduce : (FStar_Tactics_NamedView.term, unit) FStar_Tactics_Effect.tac_repr) = fun tm -> FStar_Tactics_V2_Derived.norm_term [] tm let (pattern_of_term : - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.term -> (pattern, unit) FStar_Tactics_Effect.tac_repr) = fun tm -> @@ -2462,13 +2464,13 @@ type 'a pm_goal = unit let (hyp_qn : Prims.string) = "FStar.Tactics.PatternMatching.hyp" let (goal_qn : Prims.string) = "FStar.Tactics.PatternMatching.pm_goal" type abspat_binder_kind = - | ABKVar of FStar_Reflection_Types.typ + | ABKVar of FStarC_Reflection_Types.typ | ABKHyp | ABKGoal let (uu___is_ABKVar : abspat_binder_kind -> Prims.bool) = fun projectee -> match projectee with | ABKVar _0 -> true | uu___ -> false let (__proj__ABKVar__item___0 : - abspat_binder_kind -> FStar_Reflection_Types.typ) = + abspat_binder_kind -> FStarC_Reflection_Types.typ) = fun projectee -> match projectee with | ABKVar _0 -> _0 let (uu___is_ABKHyp : abspat_binder_kind -> Prims.bool) = fun projectee -> match projectee with | ABKHyp -> true | uu___ -> false @@ -2884,7 +2886,7 @@ let (matching_problem_of_abs : let uu___8 = let uu___9 = let uu___10 = - FStar_Tactics_V2_Builtins.term_to_string + FStarC_Tactics_V2_Builtins.term_to_string (type_of_named_binder binder) in FStar_Tactics_Effect.tac_bind @@ -3099,7 +3101,7 @@ let (matching_problem_of_abs : = let uu___15 = - FStar_Tactics_V2_Builtins.term_to_string + FStarC_Tactics_V2_Builtins.term_to_string typ in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -3707,36 +3709,36 @@ let (arg_type_of_binder_kind : match binder_kind with | ABKVar typ -> typ | ABKHyp -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "NamedView"; "binder"])) | ABKGoal -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "unit"]))))) uu___ let (locate_fn_of_binder_kind : - abspat_binder_kind -> FStar_Reflection_Types.term) = + abspat_binder_kind -> FStarC_Reflection_Types.term) = fun binder_kind -> match binder_kind with | ABKVar uu___ -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "PatternMatching"; "ms_locate_var"])) | ABKHyp -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "PatternMatching"; "ms_locate_hyp"])) | ABKGoal -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "PatternMatching"; "ms_locate_unit"])) let (abspat_arg_of_abspat_argspec : - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.term -> abspat_argspec -> (FStar_Tactics_NamedView.term, unit) FStar_Tactics_Effect.tac_repr) = @@ -3765,7 +3767,7 @@ let (abspat_arg_of_abspat_argspec : let uu___3 = let uu___4 = FStar_Tactics_Unseal.unseal - (argspec.asa_name).FStar_Reflection_V2_Data.ppname3 in + (argspec.asa_name).FStarC_Reflection_V2_Data.ppname3 in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -3783,7 +3785,7 @@ let (abspat_arg_of_abspat_argspec : (fun uu___5 -> FStar_Tactics_Effect.lift_div_tac (fun uu___6 -> - FStar_Reflection_V2_Data.C_String uu___5)) in + FStarC_Reflection_V2_Data.C_String uu___5)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -3860,7 +3862,7 @@ let (abspat_arg_of_abspat_argspec : FStar_Tactics_Effect.lift_div_tac (fun uu___6 -> (uu___5, - FStar_Reflection_V2_Data.Q_Explicit))) in + FStarC_Reflection_V2_Data.Q_Explicit))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -3884,9 +3886,9 @@ let (abspat_arg_of_abspat_argspec : (fun uu___5 -> [uu___4; (solution_term, - FStar_Reflection_V2_Data.Q_Explicit); + FStarC_Reflection_V2_Data.Q_Explicit); (name_tm, - FStar_Reflection_V2_Data.Q_Explicit)])) in + FStarC_Reflection_V2_Data.Q_Explicit)])) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -3915,7 +3917,7 @@ let (abspat_arg_of_abspat_argspec : let rec (hoist_and_apply : FStar_Tactics_NamedView.term -> FStar_Tactics_NamedView.term Prims.list -> - FStar_Reflection_V2_Data.argv Prims.list -> + FStarC_Reflection_V2_Data.argv Prims.list -> (FStar_Tactics_NamedView.term, unit) FStar_Tactics_Effect.tac_repr) = fun uu___2 -> @@ -3958,7 +3960,7 @@ let rec (hoist_and_apply : (fun n -> let uu___1 = let uu___2 = - FStar_Tactics_V2_Builtins.fresh () in + FStarC_Tactics_V2_Builtins.fresh () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -3989,10 +3991,10 @@ let rec (hoist_and_apply : (Prims.strcat "x" (Prims.string_of_int n))); FStar_Tactics_NamedView.sort = - (FStar_Reflection_V2_Builtins.pack_ln - FStar_Reflection_V2_Data.Tv_Unknown); + (FStarC_Reflection_V2_Builtins.pack_ln + FStarC_Reflection_V2_Data.Tv_Unknown); FStar_Tactics_NamedView.qual = - FStar_Reflection_V2_Data.Q_Explicit; + FStarC_Reflection_V2_Data.Q_Explicit; FStar_Tactics_NamedView.attrs = [] })) in @@ -4024,7 +4026,7 @@ let rec (hoist_and_apply : (FStar_Tactics_NamedView.Tv_Var (FStar_Tactics_V2_SyntaxCoercions.binder_to_namedv nb))), - FStar_Reflection_V2_Data.Q_Explicit) + FStarC_Reflection_V2_Data.Q_Explicit) :: hoisted_args) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -4158,9 +4160,9 @@ let (specialize_abspat_continuation : fun continuation -> let uu___ = FStar_Tactics_V2_Derived.fresh_binder - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "PatternMatching"; "matching_solution"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -4251,7 +4253,7 @@ let (specialize_abspat_continuation : let uu___4 = let uu___5 = let uu___6 = - FStar_Tactics_V2_Builtins.term_to_string + FStarC_Tactics_V2_Builtins.term_to_string thunked in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -4353,7 +4355,7 @@ let (specialize_abspat_continuation : = let uu___9 = - FStar_Tactics_V2_Builtins.term_to_string + FStarC_Tactics_V2_Builtins.term_to_string normalized in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -4461,7 +4463,7 @@ let interp_abspat_continuation : (Prims.of_int (47))))) (Obj.magic uu___) (fun uu___1 -> (fun applied -> - Obj.magic (FStar_Tactics_V2_Builtins.unquote applied)) uu___1) + Obj.magic (FStarC_Tactics_V2_Builtins.unquote applied)) uu___1) let interp_abspat : 'a . 'a -> @@ -4534,7 +4536,7 @@ let match_abspat : (fun uu___3 -> FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> - FStar_Reflection_V2_Builtins.vars_of_env uu___3)) in + FStarC_Reflection_V2_Builtins.vars_of_env uu___3)) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_Print.ml b/ocaml/fstar-lib/generated/FStar_Tactics_Print.ml index 1da0e955926..929327587f4 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_Print.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_Print.ml @@ -4,7 +4,8 @@ let (namedv_to_string : (Prims.string, unit) FStar_Tactics_Effect.tac_repr) = fun x -> - let uu___ = FStar_Tactics_Unseal.unseal x.FStar_Reflection_V2_Data.ppname in + let uu___ = + FStar_Tactics_Unseal.unseal x.FStarC_Reflection_V2_Data.ppname in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -21,19 +22,19 @@ let (namedv_to_string : (fun uu___2 -> Prims.strcat uu___1 (Prims.strcat "#" - (Prims.string_of_int x.FStar_Reflection_V2_Data.uniq)))) + (Prims.string_of_int x.FStarC_Reflection_V2_Data.uniq)))) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.Print.namedv_to_string" - (Prims.of_int (2)) + FStarC_Tactics_Native.register_tactic + "FStar.Tactics.Print.namedv_to_string" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.Print.namedv_to_string (plugin)" - (FStar_Tactics_Native.from_tactic_1 namedv_to_string) - FStar_Reflection_V2_Embeddings.e_namedv_view - FStar_Syntax_Embeddings.e_string psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 namedv_to_string) + FStarC_Reflection_V2_Embeddings.e_namedv_view + FStarC_Syntax_Embeddings.e_string psc ncb us args) let (paren : Prims.string -> Prims.string) = fun s -> Prims.strcat "(" (Prims.strcat s ")") let rec print_list_aux : @@ -239,34 +240,34 @@ let rec (universe_to_ast_string : (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> "Uv_Unk")))) uu___ let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.Print.universe_to_ast_string" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.Print.universe_to_ast_string (plugin)" - (FStar_Tactics_Native.from_tactic_1 universe_to_ast_string) - FStar_Reflection_V2_Embeddings.e_universe - FStar_Syntax_Embeddings.e_string psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 universe_to_ast_string) + FStarC_Reflection_V2_Embeddings.e_universe + FStarC_Syntax_Embeddings.e_string psc ncb us args) let (universes_to_ast_string : - FStar_Reflection_V2_Data.universes -> + FStarC_Reflection_V2_Data.universes -> (Prims.string, unit) FStar_Tactics_Effect.tac_repr) = fun us -> print_list universe_to_ast_string us let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.Print.universes_to_ast_string" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.Print.universes_to_ast_string (plugin)" - (FStar_Tactics_Native.from_tactic_1 universes_to_ast_string) - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_universe) - FStar_Syntax_Embeddings.e_string psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 universes_to_ast_string) + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_universe) + FStarC_Syntax_Embeddings.e_string psc ncb us args) let rec (term_to_ast_string : FStar_Tactics_NamedView.term -> (Prims.string, unit) FStar_Tactics_Effect.tac_repr) @@ -1806,7 +1807,7 @@ and (comp_to_ast_string : = fun c -> match FStar_Tactics_NamedView.inspect_comp c with - | FStar_Reflection_V2_Data.C_Total t -> + | FStarC_Reflection_V2_Data.C_Total t -> let uu___ = term_to_ast_string t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1822,7 +1823,7 @@ and (comp_to_ast_string : (fun uu___1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> Prims.strcat "Tot " uu___1)) - | FStar_Reflection_V2_Data.C_GTotal t -> + | FStarC_Reflection_V2_Data.C_GTotal t -> let uu___ = term_to_ast_string t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1838,7 +1839,7 @@ and (comp_to_ast_string : (fun uu___1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> Prims.strcat "GTot " uu___1)) - | FStar_Reflection_V2_Data.C_Lemma (pre, post, uu___) -> + | FStarC_Reflection_V2_Data.C_Lemma (pre, post, uu___) -> let uu___1 = let uu___2 = term_to_ast_string pre in FStar_Tactics_Effect.tac_bind @@ -1903,7 +1904,7 @@ and (comp_to_ast_string : (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> Prims.strcat "Lemma " uu___2)) - | FStar_Reflection_V2_Data.C_Eff (us, eff, res, uu___, uu___1) -> + | FStarC_Reflection_V2_Data.C_Eff (us, eff, res, uu___, uu___1) -> let uu___2 = let uu___3 = let uu___4 = universes_to_ast_string us in @@ -1963,7 +1964,7 @@ and (comp_to_ast_string : FStar_Tactics_Effect.lift_div_tac (fun uu___11 -> Prims.strcat - (FStar_Reflection_V2_Builtins.implode_qn + (FStarC_Reflection_V2_Builtins.implode_qn eff) uu___10)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -2044,7 +2045,7 @@ and (comp_to_ast_string : FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> Prims.strcat "Effect" uu___3)) and (const_to_ast_string : - FStar_Reflection_V2_Data.vconst -> + FStarC_Reflection_V2_Data.vconst -> (Prims.string, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> @@ -2053,103 +2054,103 @@ and (const_to_ast_string : (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> match c with - | FStar_Reflection_V2_Data.C_Unit -> "C_Unit" - | FStar_Reflection_V2_Data.C_Int i -> + | FStarC_Reflection_V2_Data.C_Unit -> "C_Unit" + | FStarC_Reflection_V2_Data.C_Int i -> Prims.strcat "C_Int " (Prims.string_of_int i) - | FStar_Reflection_V2_Data.C_True -> "C_True" - | FStar_Reflection_V2_Data.C_False -> "C_False" - | FStar_Reflection_V2_Data.C_String s -> + | FStarC_Reflection_V2_Data.C_True -> "C_True" + | FStarC_Reflection_V2_Data.C_False -> "C_False" + | FStarC_Reflection_V2_Data.C_String s -> Prims.strcat "C_String " s - | FStar_Reflection_V2_Data.C_Range uu___1 -> "C_Range _" - | FStar_Reflection_V2_Data.C_Reify -> "C_Reify" - | FStar_Reflection_V2_Data.C_Reflect name -> + | FStarC_Reflection_V2_Data.C_Range uu___1 -> "C_Range _" + | FStarC_Reflection_V2_Data.C_Reify -> "C_Reify" + | FStarC_Reflection_V2_Data.C_Reflect name -> Prims.strcat "C_Reflect " - (FStar_Reflection_V2_Builtins.implode_qn name) - | FStar_Reflection_V2_Data.C_Real r -> + (FStarC_Reflection_V2_Builtins.implode_qn name) + | FStarC_Reflection_V2_Data.C_Real r -> Prims.strcat "C_Real \"" (Prims.strcat r "\"")))) uu___ let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.Print.term_to_ast_string" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.Print.term_to_ast_string (plugin)" - (FStar_Tactics_Native.from_tactic_1 term_to_ast_string) - FStar_Reflection_V2_Embeddings.e_term - FStar_Syntax_Embeddings.e_string psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 term_to_ast_string) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Syntax_Embeddings.e_string psc ncb us args) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.Print.match_returns_to_string" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.Print.match_returns_to_string (plugin)" - (FStar_Tactics_Native.from_tactic_1 match_returns_to_string) - (FStar_Syntax_Embeddings.e_option - (FStar_Syntax_Embeddings.e_tuple2 + (FStarC_Tactics_Native.from_tactic_1 match_returns_to_string) + (FStarC_Syntax_Embeddings.e_option + (FStarC_Syntax_Embeddings.e_tuple2 FStar_Tactics_NamedView.e_binder - (FStar_Syntax_Embeddings.e_tuple3 - (FStar_Syntax_Embeddings.e_either - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_comp_view) - (FStar_Syntax_Embeddings.e_option - FStar_Reflection_V2_Embeddings.e_term) - FStar_Syntax_Embeddings.e_bool))) - FStar_Syntax_Embeddings.e_string psc ncb us args) + (FStarC_Syntax_Embeddings.e_tuple3 + (FStarC_Syntax_Embeddings.e_either + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_comp_view) + (FStarC_Syntax_Embeddings.e_option + FStarC_Reflection_V2_Embeddings.e_term) + FStarC_Syntax_Embeddings.e_bool))) + FStarC_Syntax_Embeddings.e_string psc ncb us args) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.Print.branches_to_ast_string" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.Print.branches_to_ast_string (plugin)" - (FStar_Tactics_Native.from_tactic_1 branches_to_ast_string) - (FStar_Syntax_Embeddings.e_list - (FStar_Syntax_Embeddings.e_tuple2 + (FStarC_Tactics_Native.from_tactic_1 branches_to_ast_string) + (FStarC_Syntax_Embeddings.e_list + (FStarC_Syntax_Embeddings.e_tuple2 FStar_Tactics_NamedView.e_pattern - FStar_Reflection_V2_Embeddings.e_term)) - FStar_Syntax_Embeddings.e_string psc ncb us args) + FStarC_Reflection_V2_Embeddings.e_term)) + FStarC_Syntax_Embeddings.e_string psc ncb us args) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.Print.branch_to_ast_string" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.Print.branch_to_ast_string (plugin)" - (FStar_Tactics_Native.from_tactic_1 branch_to_ast_string) - (FStar_Syntax_Embeddings.e_tuple2 + (FStarC_Tactics_Native.from_tactic_1 branch_to_ast_string) + (FStarC_Syntax_Embeddings.e_tuple2 FStar_Tactics_NamedView.e_pattern - FStar_Reflection_V2_Embeddings.e_term) - FStar_Syntax_Embeddings.e_string psc ncb us args) + FStarC_Reflection_V2_Embeddings.e_term) + FStarC_Syntax_Embeddings.e_string psc ncb us args) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.Print.comp_to_ast_string" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.Print.comp_to_ast_string (plugin)" - (FStar_Tactics_Native.from_tactic_1 comp_to_ast_string) - FStar_Reflection_V2_Embeddings.e_comp_view - FStar_Syntax_Embeddings.e_string psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 comp_to_ast_string) + FStarC_Reflection_V2_Embeddings.e_comp_view + FStarC_Syntax_Embeddings.e_string psc ncb us args) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.Print.const_to_ast_string" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.Print.const_to_ast_string (plugin)" - (FStar_Tactics_Native.from_tactic_1 const_to_ast_string) - FStar_Reflection_V2_Embeddings.e_vconst - FStar_Syntax_Embeddings.e_string psc ncb us args) \ No newline at end of file + (FStarC_Tactics_Native.from_tactic_1 const_to_ast_string) + FStarC_Reflection_V2_Embeddings.e_vconst + FStarC_Syntax_Embeddings.e_string psc ncb us args) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_Printing.ml b/ocaml/fstar-lib/generated/FStar_Tactics_Printing.ml deleted file mode 100644 index b08da134550..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Tactics_Printing.ml +++ /dev/null @@ -1,370 +0,0 @@ -open Prims -let (dbg_Imp : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Imp" -let (term_to_string : - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.term -> Prims.string) = - fun e -> - fun t -> - FStar_Syntax_Print.term_to_string' e.FStar_TypeChecker_Env.dsenv t -let (goal_to_string_verbose : FStar_Tactics_Types.goal -> Prims.string) = - fun g -> - let uu___ = - FStar_Class_Show.show FStar_Syntax_Print.showable_ctxu - g.FStar_Tactics_Types.goal_ctx_uvar in - let uu___1 = - let uu___2 = FStar_Tactics_Types.check_goal_solved' g in - match uu___2 with - | FStar_Pervasives_Native.None -> "" - | FStar_Pervasives_Native.Some t -> - let uu___3 = - let uu___4 = FStar_Tactics_Types.goal_env g in - term_to_string uu___4 t in - FStar_Compiler_Util.format1 "\tGOAL ALREADY SOLVED!: %s" uu___3 in - FStar_Compiler_Util.format2 "%s%s\n" uu___ uu___1 -let (unshadow : - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.binders * FStar_Syntax_Syntax.term)) - = - fun bs -> - fun t -> - let sset bv s = - let uu___ = - let uu___1 = FStar_Ident.range_of_id bv.FStar_Syntax_Syntax.ppname in - FStar_Pervasives_Native.Some uu___1 in - FStar_Syntax_Syntax.gen_bv s uu___ bv.FStar_Syntax_Syntax.sort in - let fresh_until b f = - let rec aux i = - let t1 = - let uu___ = - let uu___1 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) i in - Prims.strcat "'" uu___1 in - Prims.strcat b uu___ in - let uu___ = f t1 in if uu___ then t1 else aux (i + Prims.int_one) in - let uu___ = f b in if uu___ then b else aux Prims.int_zero in - let rec go seen subst bs1 bs' t1 = - match bs1 with - | [] -> - let uu___ = FStar_Syntax_Subst.subst subst t1 in - ((FStar_Compiler_List.rev bs'), uu___) - | b::bs2 -> - let b1 = - let uu___ = FStar_Syntax_Subst.subst_binders subst [b] in - match uu___ with - | b2::[] -> b2 - | uu___1 -> failwith "impossible: unshadow subst_binders" in - let uu___ = - ((b1.FStar_Syntax_Syntax.binder_bv), - (b1.FStar_Syntax_Syntax.binder_qual)) in - (match uu___ with - | (bv0, q) -> - let nbs = - let uu___1 = - FStar_Class_Show.show FStar_Ident.showable_ident - bv0.FStar_Syntax_Syntax.ppname in - fresh_until uu___1 - (fun s -> - Prims.op_Negation (FStar_Compiler_List.mem s seen)) in - let bv = sset bv0 nbs in - let b2 = - FStar_Syntax_Syntax.mk_binder_with_attrs bv q - b1.FStar_Syntax_Syntax.binder_positivity - b1.FStar_Syntax_Syntax.binder_attrs in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.bv_to_name bv in - (bv0, uu___5) in - FStar_Syntax_Syntax.NT uu___4 in - [uu___3] in - FStar_Compiler_List.op_At subst uu___2 in - go (nbs :: seen) uu___1 bs2 (b2 :: bs') t1) in - go [] [] bs [] t -let (goal_to_string : - Prims.string -> - (Prims.int * Prims.int) FStar_Pervasives_Native.option -> - FStar_Tactics_Types.proofstate -> - FStar_Tactics_Types.goal -> Prims.string) - = - fun kind -> - fun maybe_num -> - fun ps -> - fun g -> - let w = - let uu___ = FStar_Options.print_implicits () in - if uu___ - then - let uu___1 = FStar_Tactics_Types.goal_env g in - let uu___2 = FStar_Tactics_Types.goal_witness g in - term_to_string uu___1 uu___2 - else - (let uu___2 = FStar_Tactics_Types.check_goal_solved' g in - match uu___2 with - | FStar_Pervasives_Native.None -> "_" - | FStar_Pervasives_Native.Some t -> - let uu___3 = FStar_Tactics_Types.goal_env g in - let uu___4 = FStar_Tactics_Types.goal_witness g in - term_to_string uu___3 uu___4) in - let num = - match maybe_num with - | FStar_Pervasives_Native.None -> "" - | FStar_Pervasives_Native.Some (i, n) -> - let uu___ = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) i in - let uu___1 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) n in - FStar_Compiler_Util.format2 " %s/%s" uu___ uu___1 in - let maybe_label = - match g.FStar_Tactics_Types.label with - | "" -> "" - | l -> Prims.strcat " (" (Prims.strcat l ")") in - let uu___ = - let rename_binders subst bs = - FStar_Compiler_List.map - (fun uu___1 -> - let x = uu___1.FStar_Syntax_Syntax.binder_bv in - let y = - let uu___2 = FStar_Syntax_Syntax.bv_to_name x in - FStar_Syntax_Subst.subst subst uu___2 in - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress y in - uu___3.FStar_Syntax_Syntax.n in - match uu___2 with - | FStar_Syntax_Syntax.Tm_name y1 -> - let uu___3 = - let uu___4 = uu___1.FStar_Syntax_Syntax.binder_bv in - let uu___5 = - FStar_Syntax_Subst.subst subst - x.FStar_Syntax_Syntax.sort in - { - FStar_Syntax_Syntax.ppname = - (uu___4.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (uu___4.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = uu___5 - } in - { - FStar_Syntax_Syntax.binder_bv = uu___3; - FStar_Syntax_Syntax.binder_qual = - (uu___1.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity = - (uu___1.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs = - (uu___1.FStar_Syntax_Syntax.binder_attrs) - } - | uu___3 -> failwith "Not a renaming") bs in - let goal_binders = - (g.FStar_Tactics_Types.goal_ctx_uvar).FStar_Syntax_Syntax.ctx_uvar_binders in - let goal_ty = FStar_Tactics_Types.goal_type g in - let uu___1 = FStar_Options.tactic_raw_binders () in - if uu___1 - then (goal_binders, goal_ty) - else - (let subst = - FStar_TypeChecker_Primops_Base.psc_subst - ps.FStar_Tactics_Types.psc in - let binders = rename_binders subst goal_binders in - let ty = FStar_Syntax_Subst.subst subst goal_ty in - (binders, ty)) in - match uu___ with - | (goal_binders, goal_ty) -> - let uu___1 = unshadow goal_binders goal_ty in - (match uu___1 with - | (goal_binders1, goal_ty1) -> - let actual_goal = - if ps.FStar_Tactics_Types.tac_verb_dbg - then goal_to_string_verbose g - else - (let uu___3 = - let uu___4 = - FStar_Compiler_List.map - FStar_Syntax_Print.binder_to_string_with_type - goal_binders1 in - FStar_Compiler_String.concat ", " uu___4 in - let uu___4 = - let uu___5 = FStar_Tactics_Types.goal_env g in - term_to_string uu___5 goal_ty1 in - FStar_Compiler_Util.format3 "%s |- %s : %s\n" uu___3 - w uu___4) in - FStar_Compiler_Util.format4 "%s%s%s:\n%s\n" kind num - maybe_label actual_goal) -let (ps_to_string : - (Prims.string * FStar_Tactics_Types.proofstate) -> Prims.string) = - fun uu___ -> - match uu___ with - | (msg, ps) -> - let p_imp imp = - FStar_Class_Show.show FStar_Syntax_Print.showable_uvar - (imp.FStar_TypeChecker_Common.imp_uvar).FStar_Syntax_Syntax.ctx_uvar_head in - let n_active = - FStar_Compiler_List.length ps.FStar_Tactics_Types.goals in - let n_smt = - FStar_Compiler_List.length ps.FStar_Tactics_Types.smt_goals in - let n = n_active + n_smt in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - ps.FStar_Tactics_Types.depth in - FStar_Compiler_Util.format2 "State dump @ depth %s (%s):\n" - uu___4 msg in - let uu___4 = - let uu___5 = - if - ps.FStar_Tactics_Types.entry_range <> - FStar_Compiler_Range_Type.dummyRange - then - let uu___6 = - FStar_Compiler_Range_Ops.string_of_def_range - ps.FStar_Tactics_Types.entry_range in - FStar_Compiler_Util.format1 "Location: %s\n" uu___6 - else "" in - let uu___6 = - let uu___7 = - let uu___8 = FStar_Compiler_Effect.op_Bang dbg_Imp in - if uu___8 - then - let uu___9 = - (FStar_Common.string_of_list ()) p_imp - ps.FStar_Tactics_Types.all_implicits in - FStar_Compiler_Util.format1 "Imps: %s\n" uu___9 - else "" in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - let uu___3 = - let uu___4 = - FStar_Compiler_List.mapi - (fun i -> - fun g -> - goal_to_string "Goal" - (FStar_Pervasives_Native.Some ((Prims.int_one + i), n)) - ps g) ps.FStar_Tactics_Types.goals in - let uu___5 = - FStar_Compiler_List.mapi - (fun i -> - fun g -> - goal_to_string "SMT Goal" - (FStar_Pervasives_Native.Some - (((Prims.int_one + n_active) + i), n)) ps g) - ps.FStar_Tactics_Types.smt_goals in - FStar_Compiler_List.op_At uu___4 uu___5 in - FStar_Compiler_List.op_At uu___2 uu___3 in - FStar_Compiler_String.concat "" uu___1 -let (goal_to_json : FStar_Tactics_Types.goal -> FStar_Json.json) = - fun g -> - let g_binders = - (g.FStar_Tactics_Types.goal_ctx_uvar).FStar_Syntax_Syntax.ctx_uvar_binders in - let g_type = FStar_Tactics_Types.goal_type g in - let uu___ = unshadow g_binders g_type in - match uu___ with - | (g_binders1, g_type1) -> - let j_binders = - let uu___1 = - let uu___2 = FStar_Tactics_Types.goal_env g in - FStar_TypeChecker_Env.dsenv uu___2 in - FStar_Syntax_Print.binders_to_json uu___1 g_binders1 in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = FStar_Tactics_Types.goal_env g in - let uu___10 = FStar_Tactics_Types.goal_witness g in - term_to_string uu___9 uu___10 in - FStar_Json.JsonStr uu___8 in - ("witness", uu___7) in - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = FStar_Tactics_Types.goal_env g in - term_to_string uu___11 g_type1 in - FStar_Json.JsonStr uu___10 in - ("type", uu___9) in - [uu___8; - ("label", - (FStar_Json.JsonStr (g.FStar_Tactics_Types.label)))] in - uu___6 :: uu___7 in - FStar_Json.JsonAssoc uu___5 in - ("goal", uu___4) in - [uu___3] in - ("hyps", j_binders) :: uu___2 in - FStar_Json.JsonAssoc uu___1 -let (ps_to_json : - (Prims.string * FStar_Tactics_Types.proofstate) -> FStar_Json.json) = - fun uu___ -> - match uu___ with - | (msg, ps) -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Compiler_List.map goal_to_json - ps.FStar_Tactics_Types.goals in - FStar_Json.JsonList uu___8 in - ("goals", uu___7) in - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Compiler_List.map goal_to_json - ps.FStar_Tactics_Types.smt_goals in - FStar_Json.JsonList uu___10 in - ("smt-goals", uu___9) in - [uu___8] in - uu___6 :: uu___7 in - ("urgency", - (FStar_Json.JsonInt (ps.FStar_Tactics_Types.urgency))) :: - uu___5 in - ("depth", (FStar_Json.JsonInt (ps.FStar_Tactics_Types.depth))) - :: uu___4 in - ("label", (FStar_Json.JsonStr msg)) :: uu___3 in - let uu___3 = - if - ps.FStar_Tactics_Types.entry_range <> - FStar_Compiler_Range_Type.dummyRange - then - let uu___4 = - let uu___5 = - FStar_Compiler_Range_Ops.json_of_def_range - ps.FStar_Tactics_Types.entry_range in - ("location", uu___5) in - [uu___4] - else [] in - FStar_Compiler_List.op_At uu___2 uu___3 in - FStar_Json.JsonAssoc uu___1 -let (do_dump_proofstate : - FStar_Tactics_Types.proofstate -> Prims.string -> unit) = - fun ps -> - fun msg -> - let uu___ = - let uu___1 = FStar_Options.silent () in Prims.op_Negation uu___1 in - if uu___ - then - FStar_Options.with_saved_options - (fun uu___1 -> - FStar_Options.set_option "print_effect_args" - (FStar_Options.Bool true); - FStar_Compiler_Util.print_generic "proof-state" ps_to_string - ps_to_json (msg, ps); - FStar_Compiler_Util.flush_stdout ()) - else () \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_Result.ml b/ocaml/fstar-lib/generated/FStar_Tactics_Result.ml deleted file mode 100644 index b139be5704e..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Tactics_Result.ml +++ /dev/null @@ -1,15 +0,0 @@ -open Prims -type 'a __result = - | Success of ('a * FStar_Tactics_Types.proofstate) - | Failed of (Prims.exn * FStar_Tactics_Types.proofstate) -let uu___is_Success : 'a . 'a __result -> Prims.bool = - fun projectee -> match projectee with | Success _0 -> true | uu___ -> false -let __proj__Success__item___0 : - 'a . 'a __result -> ('a * FStar_Tactics_Types.proofstate) = - fun projectee -> match projectee with | Success _0 -> _0 -let uu___is_Failed : 'a . 'a __result -> Prims.bool = - fun projectee -> match projectee with | Failed _0 -> true | uu___ -> false -let __proj__Failed__item___0 : - 'a . 'a __result -> (Prims.exn * FStar_Tactics_Types.proofstate) = - fun projectee -> match projectee with | Failed _0 -> _0 -type proofstate = FStar_Tactics_Types.proofstate \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_SMT.ml b/ocaml/fstar-lib/generated/FStar_Tactics_SMT.ml index b36e0eedb2d..80afcad9c98 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_SMT.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_SMT.ml @@ -1,7 +1,7 @@ open Prims let (smt_sync : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> - let uu___1 = FStar_Tactics_V2_Builtins.get_vconfig () in + let uu___1 = FStarC_Tactics_V2_Builtins.get_vconfig () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -14,24 +14,24 @@ let (smt_sync : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (Obj.magic uu___1) (fun uu___2 -> (fun uu___2 -> - Obj.magic (FStar_Tactics_V2_Builtins.t_smt_sync uu___2)) uu___2) + Obj.magic (FStarC_Tactics_V2_Builtins.t_smt_sync uu___2)) uu___2) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.SMT.smt_sync" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.SMT.smt_sync" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.SMT.smt_sync (plugin)" - (FStar_Tactics_Native.from_tactic_1 smt_sync) - FStar_Syntax_Embeddings.e_unit FStar_Syntax_Embeddings.e_unit - psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 smt_sync) + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (smt_sync' : Prims.nat -> Prims.nat -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun fuel -> fun ifuel -> - let uu___ = FStar_Tactics_V2_Builtins.get_vconfig () in + let uu___ = FStarC_Tactics_V2_Builtins.get_vconfig () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -50,55 +50,58 @@ let (smt_sync' : (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> { - FStar_VConfig.initial_fuel = fuel; - FStar_VConfig.max_fuel = fuel; - FStar_VConfig.initial_ifuel = ifuel; - FStar_VConfig.max_ifuel = ifuel; - FStar_VConfig.detail_errors = - (vcfg.FStar_VConfig.detail_errors); - FStar_VConfig.detail_hint_replay = - (vcfg.FStar_VConfig.detail_hint_replay); - FStar_VConfig.no_smt = (vcfg.FStar_VConfig.no_smt); - FStar_VConfig.quake_lo = - (vcfg.FStar_VConfig.quake_lo); - FStar_VConfig.quake_hi = - (vcfg.FStar_VConfig.quake_hi); - FStar_VConfig.quake_keep = - (vcfg.FStar_VConfig.quake_keep); - FStar_VConfig.retry = (vcfg.FStar_VConfig.retry); - FStar_VConfig.smtencoding_elim_box = - (vcfg.FStar_VConfig.smtencoding_elim_box); - FStar_VConfig.smtencoding_nl_arith_repr = - (vcfg.FStar_VConfig.smtencoding_nl_arith_repr); - FStar_VConfig.smtencoding_l_arith_repr = - (vcfg.FStar_VConfig.smtencoding_l_arith_repr); - FStar_VConfig.smtencoding_valid_intro = - (vcfg.FStar_VConfig.smtencoding_valid_intro); - FStar_VConfig.smtencoding_valid_elim = - (vcfg.FStar_VConfig.smtencoding_valid_elim); - FStar_VConfig.tcnorm = (vcfg.FStar_VConfig.tcnorm); - FStar_VConfig.no_plugins = - (vcfg.FStar_VConfig.no_plugins); - FStar_VConfig.no_tactics = - (vcfg.FStar_VConfig.no_tactics); - FStar_VConfig.z3cliopt = - (vcfg.FStar_VConfig.z3cliopt); - FStar_VConfig.z3smtopt = - (vcfg.FStar_VConfig.z3smtopt); - FStar_VConfig.z3refresh = - (vcfg.FStar_VConfig.z3refresh); - FStar_VConfig.z3rlimit = - (vcfg.FStar_VConfig.z3rlimit); - FStar_VConfig.z3rlimit_factor = - (vcfg.FStar_VConfig.z3rlimit_factor); - FStar_VConfig.z3seed = (vcfg.FStar_VConfig.z3seed); - FStar_VConfig.z3version = - (vcfg.FStar_VConfig.z3version); - FStar_VConfig.trivial_pre_for_unannotated_effectful_fns + FStarC_VConfig.initial_fuel = fuel; + FStarC_VConfig.max_fuel = fuel; + FStarC_VConfig.initial_ifuel = ifuel; + FStarC_VConfig.max_ifuel = ifuel; + FStarC_VConfig.detail_errors = + (vcfg.FStarC_VConfig.detail_errors); + FStarC_VConfig.detail_hint_replay = + (vcfg.FStarC_VConfig.detail_hint_replay); + FStarC_VConfig.no_smt = + (vcfg.FStarC_VConfig.no_smt); + FStarC_VConfig.quake_lo = + (vcfg.FStarC_VConfig.quake_lo); + FStarC_VConfig.quake_hi = + (vcfg.FStarC_VConfig.quake_hi); + FStarC_VConfig.quake_keep = + (vcfg.FStarC_VConfig.quake_keep); + FStarC_VConfig.retry = (vcfg.FStarC_VConfig.retry); + FStarC_VConfig.smtencoding_elim_box = + (vcfg.FStarC_VConfig.smtencoding_elim_box); + FStarC_VConfig.smtencoding_nl_arith_repr = + (vcfg.FStarC_VConfig.smtencoding_nl_arith_repr); + FStarC_VConfig.smtencoding_l_arith_repr = + (vcfg.FStarC_VConfig.smtencoding_l_arith_repr); + FStarC_VConfig.smtencoding_valid_intro = + (vcfg.FStarC_VConfig.smtencoding_valid_intro); + FStarC_VConfig.smtencoding_valid_elim = + (vcfg.FStarC_VConfig.smtencoding_valid_elim); + FStarC_VConfig.tcnorm = + (vcfg.FStarC_VConfig.tcnorm); + FStarC_VConfig.no_plugins = + (vcfg.FStarC_VConfig.no_plugins); + FStarC_VConfig.no_tactics = + (vcfg.FStarC_VConfig.no_tactics); + FStarC_VConfig.z3cliopt = + (vcfg.FStarC_VConfig.z3cliopt); + FStarC_VConfig.z3smtopt = + (vcfg.FStarC_VConfig.z3smtopt); + FStarC_VConfig.z3refresh = + (vcfg.FStarC_VConfig.z3refresh); + FStarC_VConfig.z3rlimit = + (vcfg.FStarC_VConfig.z3rlimit); + FStarC_VConfig.z3rlimit_factor = + (vcfg.FStarC_VConfig.z3rlimit_factor); + FStarC_VConfig.z3seed = + (vcfg.FStarC_VConfig.z3seed); + FStarC_VConfig.z3version = + (vcfg.FStarC_VConfig.z3version); + FStarC_VConfig.trivial_pre_for_unannotated_effectful_fns = - (vcfg.FStar_VConfig.trivial_pre_for_unannotated_effectful_fns); - FStar_VConfig.reuse_hint_for = - (vcfg.FStar_VConfig.reuse_hint_for) + (vcfg.FStarC_VConfig.trivial_pre_for_unannotated_effectful_fns); + FStarC_VConfig.reuse_hint_for = + (vcfg.FStarC_VConfig.reuse_hint_for) })) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -116,23 +119,23 @@ let (smt_sync' : (fun uu___2 -> (fun vcfg' -> Obj.magic - (FStar_Tactics_V2_Builtins.t_smt_sync vcfg')) + (FStarC_Tactics_V2_Builtins.t_smt_sync vcfg')) uu___2))) uu___1) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.SMT.smt_sync'" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.SMT.smt_sync'" (Prims.of_int (3)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_2 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_2 "FStar.Tactics.SMT.smt_sync' (plugin)" - (FStar_Tactics_Native.from_tactic_2 smt_sync') - FStar_Syntax_Embeddings.e_int FStar_Syntax_Embeddings.e_int - FStar_Syntax_Embeddings.e_unit psc ncb us args) + (FStarC_Tactics_Native.from_tactic_2 smt_sync') + FStarC_Syntax_Embeddings.e_int FStarC_Syntax_Embeddings.e_int + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (get_rlimit : unit -> (Prims.int, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> - let uu___1 = FStar_Tactics_V2_Builtins.get_vconfig () in + let uu___1 = FStarC_Tactics_V2_Builtins.get_vconfig () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -145,23 +148,23 @@ let (get_rlimit : unit -> (Prims.int, unit) FStar_Tactics_Effect.tac_repr) = (Obj.magic uu___1) (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___3 -> uu___2.FStar_VConfig.z3rlimit)) + (fun uu___3 -> uu___2.FStarC_VConfig.z3rlimit)) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.SMT.get_rlimit" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.SMT.get_rlimit" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.SMT.get_rlimit (plugin)" - (FStar_Tactics_Native.from_tactic_1 get_rlimit) - FStar_Syntax_Embeddings.e_unit FStar_Syntax_Embeddings.e_int + (FStarC_Tactics_Native.from_tactic_1 get_rlimit) + FStarC_Syntax_Embeddings.e_unit FStarC_Syntax_Embeddings.e_int psc ncb us args) let (set_rlimit : Prims.int -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun v -> let uu___ = - let uu___1 = FStar_Tactics_V2_Builtins.get_vconfig () in + let uu___1 = FStarC_Tactics_V2_Builtins.get_vconfig () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -177,49 +180,52 @@ let (set_rlimit : Prims.int -> (unit, unit) FStar_Tactics_Effect.tac_repr) = FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> { - FStar_VConfig.initial_fuel = - (uu___2.FStar_VConfig.initial_fuel); - FStar_VConfig.max_fuel = (uu___2.FStar_VConfig.max_fuel); - FStar_VConfig.initial_ifuel = - (uu___2.FStar_VConfig.initial_ifuel); - FStar_VConfig.max_ifuel = (uu___2.FStar_VConfig.max_ifuel); - FStar_VConfig.detail_errors = - (uu___2.FStar_VConfig.detail_errors); - FStar_VConfig.detail_hint_replay = - (uu___2.FStar_VConfig.detail_hint_replay); - FStar_VConfig.no_smt = (uu___2.FStar_VConfig.no_smt); - FStar_VConfig.quake_lo = (uu___2.FStar_VConfig.quake_lo); - FStar_VConfig.quake_hi = (uu___2.FStar_VConfig.quake_hi); - FStar_VConfig.quake_keep = - (uu___2.FStar_VConfig.quake_keep); - FStar_VConfig.retry = (uu___2.FStar_VConfig.retry); - FStar_VConfig.smtencoding_elim_box = - (uu___2.FStar_VConfig.smtencoding_elim_box); - FStar_VConfig.smtencoding_nl_arith_repr = - (uu___2.FStar_VConfig.smtencoding_nl_arith_repr); - FStar_VConfig.smtencoding_l_arith_repr = - (uu___2.FStar_VConfig.smtencoding_l_arith_repr); - FStar_VConfig.smtencoding_valid_intro = - (uu___2.FStar_VConfig.smtencoding_valid_intro); - FStar_VConfig.smtencoding_valid_elim = - (uu___2.FStar_VConfig.smtencoding_valid_elim); - FStar_VConfig.tcnorm = (uu___2.FStar_VConfig.tcnorm); - FStar_VConfig.no_plugins = - (uu___2.FStar_VConfig.no_plugins); - FStar_VConfig.no_tactics = - (uu___2.FStar_VConfig.no_tactics); - FStar_VConfig.z3cliopt = (uu___2.FStar_VConfig.z3cliopt); - FStar_VConfig.z3smtopt = (uu___2.FStar_VConfig.z3smtopt); - FStar_VConfig.z3refresh = (uu___2.FStar_VConfig.z3refresh); - FStar_VConfig.z3rlimit = v; - FStar_VConfig.z3rlimit_factor = - (uu___2.FStar_VConfig.z3rlimit_factor); - FStar_VConfig.z3seed = (uu___2.FStar_VConfig.z3seed); - FStar_VConfig.z3version = (uu___2.FStar_VConfig.z3version); - FStar_VConfig.trivial_pre_for_unannotated_effectful_fns = - (uu___2.FStar_VConfig.trivial_pre_for_unannotated_effectful_fns); - FStar_VConfig.reuse_hint_for = - (uu___2.FStar_VConfig.reuse_hint_for) + FStarC_VConfig.initial_fuel = + (uu___2.FStarC_VConfig.initial_fuel); + FStarC_VConfig.max_fuel = (uu___2.FStarC_VConfig.max_fuel); + FStarC_VConfig.initial_ifuel = + (uu___2.FStarC_VConfig.initial_ifuel); + FStarC_VConfig.max_ifuel = + (uu___2.FStarC_VConfig.max_ifuel); + FStarC_VConfig.detail_errors = + (uu___2.FStarC_VConfig.detail_errors); + FStarC_VConfig.detail_hint_replay = + (uu___2.FStarC_VConfig.detail_hint_replay); + FStarC_VConfig.no_smt = (uu___2.FStarC_VConfig.no_smt); + FStarC_VConfig.quake_lo = (uu___2.FStarC_VConfig.quake_lo); + FStarC_VConfig.quake_hi = (uu___2.FStarC_VConfig.quake_hi); + FStarC_VConfig.quake_keep = + (uu___2.FStarC_VConfig.quake_keep); + FStarC_VConfig.retry = (uu___2.FStarC_VConfig.retry); + FStarC_VConfig.smtencoding_elim_box = + (uu___2.FStarC_VConfig.smtencoding_elim_box); + FStarC_VConfig.smtencoding_nl_arith_repr = + (uu___2.FStarC_VConfig.smtencoding_nl_arith_repr); + FStarC_VConfig.smtencoding_l_arith_repr = + (uu___2.FStarC_VConfig.smtencoding_l_arith_repr); + FStarC_VConfig.smtencoding_valid_intro = + (uu___2.FStarC_VConfig.smtencoding_valid_intro); + FStarC_VConfig.smtencoding_valid_elim = + (uu___2.FStarC_VConfig.smtencoding_valid_elim); + FStarC_VConfig.tcnorm = (uu___2.FStarC_VConfig.tcnorm); + FStarC_VConfig.no_plugins = + (uu___2.FStarC_VConfig.no_plugins); + FStarC_VConfig.no_tactics = + (uu___2.FStarC_VConfig.no_tactics); + FStarC_VConfig.z3cliopt = (uu___2.FStarC_VConfig.z3cliopt); + FStarC_VConfig.z3smtopt = (uu___2.FStarC_VConfig.z3smtopt); + FStarC_VConfig.z3refresh = + (uu___2.FStarC_VConfig.z3refresh); + FStarC_VConfig.z3rlimit = v; + FStarC_VConfig.z3rlimit_factor = + (uu___2.FStarC_VConfig.z3rlimit_factor); + FStarC_VConfig.z3seed = (uu___2.FStarC_VConfig.z3seed); + FStarC_VConfig.z3version = + (uu___2.FStarC_VConfig.z3version); + FStarC_VConfig.trivial_pre_for_unannotated_effectful_fns = + (uu___2.FStarC_VConfig.trivial_pre_for_unannotated_effectful_fns); + FStarC_VConfig.reuse_hint_for = + (uu___2.FStarC_VConfig.reuse_hint_for) })) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -233,23 +239,23 @@ let (set_rlimit : Prims.int -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (Obj.magic uu___) (fun uu___1 -> (fun uu___1 -> - Obj.magic (FStar_Tactics_V2_Builtins.set_vconfig uu___1)) uu___1) + Obj.magic (FStarC_Tactics_V2_Builtins.set_vconfig uu___1)) uu___1) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.SMT.set_rlimit" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.SMT.set_rlimit" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.SMT.set_rlimit (plugin)" - (FStar_Tactics_Native.from_tactic_1 set_rlimit) - FStar_Syntax_Embeddings.e_int FStar_Syntax_Embeddings.e_unit + (FStarC_Tactics_Native.from_tactic_1 set_rlimit) + FStarC_Syntax_Embeddings.e_int FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (get_initial_fuel : unit -> (Prims.int, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> - let uu___1 = FStar_Tactics_V2_Builtins.get_vconfig () in + let uu___1 = FStarC_Tactics_V2_Builtins.get_vconfig () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -262,23 +268,23 @@ let (get_initial_fuel : (Obj.magic uu___1) (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___3 -> uu___2.FStar_VConfig.initial_fuel)) + (fun uu___3 -> uu___2.FStarC_VConfig.initial_fuel)) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.SMT.get_initial_fuel" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.SMT.get_initial_fuel" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.SMT.get_initial_fuel (plugin)" - (FStar_Tactics_Native.from_tactic_1 get_initial_fuel) - FStar_Syntax_Embeddings.e_unit FStar_Syntax_Embeddings.e_int + (FStarC_Tactics_Native.from_tactic_1 get_initial_fuel) + FStarC_Syntax_Embeddings.e_unit FStarC_Syntax_Embeddings.e_int psc ncb us args) let (get_initial_ifuel : unit -> (Prims.int, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> - let uu___1 = FStar_Tactics_V2_Builtins.get_vconfig () in + let uu___1 = FStarC_Tactics_V2_Builtins.get_vconfig () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -291,23 +297,23 @@ let (get_initial_ifuel : (Obj.magic uu___1) (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___3 -> uu___2.FStar_VConfig.initial_ifuel)) + (fun uu___3 -> uu___2.FStarC_VConfig.initial_ifuel)) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.SMT.get_initial_ifuel" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.SMT.get_initial_ifuel" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.SMT.get_initial_ifuel (plugin)" - (FStar_Tactics_Native.from_tactic_1 get_initial_ifuel) - FStar_Syntax_Embeddings.e_unit FStar_Syntax_Embeddings.e_int + (FStarC_Tactics_Native.from_tactic_1 get_initial_ifuel) + FStarC_Syntax_Embeddings.e_unit FStarC_Syntax_Embeddings.e_int psc ncb us args) let (get_max_fuel : unit -> (Prims.int, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> - let uu___1 = FStar_Tactics_V2_Builtins.get_vconfig () in + let uu___1 = FStarC_Tactics_V2_Builtins.get_vconfig () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -320,23 +326,23 @@ let (get_max_fuel : unit -> (Prims.int, unit) FStar_Tactics_Effect.tac_repr) (Obj.magic uu___1) (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___3 -> uu___2.FStar_VConfig.max_fuel)) + (fun uu___3 -> uu___2.FStarC_VConfig.max_fuel)) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.SMT.get_max_fuel" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.SMT.get_max_fuel" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.SMT.get_max_fuel (plugin)" - (FStar_Tactics_Native.from_tactic_1 get_max_fuel) - FStar_Syntax_Embeddings.e_unit FStar_Syntax_Embeddings.e_int + (FStarC_Tactics_Native.from_tactic_1 get_max_fuel) + FStarC_Syntax_Embeddings.e_unit FStarC_Syntax_Embeddings.e_int psc ncb us args) let (get_max_ifuel : unit -> (Prims.int, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> - let uu___1 = FStar_Tactics_V2_Builtins.get_vconfig () in + let uu___1 = FStarC_Tactics_V2_Builtins.get_vconfig () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -349,24 +355,24 @@ let (get_max_ifuel : unit -> (Prims.int, unit) FStar_Tactics_Effect.tac_repr) (Obj.magic uu___1) (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___3 -> uu___2.FStar_VConfig.max_ifuel)) + (fun uu___3 -> uu___2.FStarC_VConfig.max_ifuel)) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.SMT.get_max_ifuel" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.SMT.get_max_ifuel" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.SMT.get_max_ifuel (plugin)" - (FStar_Tactics_Native.from_tactic_1 get_max_ifuel) - FStar_Syntax_Embeddings.e_unit FStar_Syntax_Embeddings.e_int + (FStarC_Tactics_Native.from_tactic_1 get_max_ifuel) + FStarC_Syntax_Embeddings.e_unit FStarC_Syntax_Embeddings.e_int psc ncb us args) let (set_initial_fuel : Prims.int -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun v -> let uu___ = - let uu___1 = FStar_Tactics_V2_Builtins.get_vconfig () in + let uu___1 = FStarC_Tactics_V2_Builtins.get_vconfig () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -382,48 +388,51 @@ let (set_initial_fuel : FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> { - FStar_VConfig.initial_fuel = v; - FStar_VConfig.max_fuel = (uu___2.FStar_VConfig.max_fuel); - FStar_VConfig.initial_ifuel = - (uu___2.FStar_VConfig.initial_ifuel); - FStar_VConfig.max_ifuel = (uu___2.FStar_VConfig.max_ifuel); - FStar_VConfig.detail_errors = - (uu___2.FStar_VConfig.detail_errors); - FStar_VConfig.detail_hint_replay = - (uu___2.FStar_VConfig.detail_hint_replay); - FStar_VConfig.no_smt = (uu___2.FStar_VConfig.no_smt); - FStar_VConfig.quake_lo = (uu___2.FStar_VConfig.quake_lo); - FStar_VConfig.quake_hi = (uu___2.FStar_VConfig.quake_hi); - FStar_VConfig.quake_keep = - (uu___2.FStar_VConfig.quake_keep); - FStar_VConfig.retry = (uu___2.FStar_VConfig.retry); - FStar_VConfig.smtencoding_elim_box = - (uu___2.FStar_VConfig.smtencoding_elim_box); - FStar_VConfig.smtencoding_nl_arith_repr = - (uu___2.FStar_VConfig.smtencoding_nl_arith_repr); - FStar_VConfig.smtencoding_l_arith_repr = - (uu___2.FStar_VConfig.smtencoding_l_arith_repr); - FStar_VConfig.smtencoding_valid_intro = - (uu___2.FStar_VConfig.smtencoding_valid_intro); - FStar_VConfig.smtencoding_valid_elim = - (uu___2.FStar_VConfig.smtencoding_valid_elim); - FStar_VConfig.tcnorm = (uu___2.FStar_VConfig.tcnorm); - FStar_VConfig.no_plugins = - (uu___2.FStar_VConfig.no_plugins); - FStar_VConfig.no_tactics = - (uu___2.FStar_VConfig.no_tactics); - FStar_VConfig.z3cliopt = (uu___2.FStar_VConfig.z3cliopt); - FStar_VConfig.z3smtopt = (uu___2.FStar_VConfig.z3smtopt); - FStar_VConfig.z3refresh = (uu___2.FStar_VConfig.z3refresh); - FStar_VConfig.z3rlimit = (uu___2.FStar_VConfig.z3rlimit); - FStar_VConfig.z3rlimit_factor = - (uu___2.FStar_VConfig.z3rlimit_factor); - FStar_VConfig.z3seed = (uu___2.FStar_VConfig.z3seed); - FStar_VConfig.z3version = (uu___2.FStar_VConfig.z3version); - FStar_VConfig.trivial_pre_for_unannotated_effectful_fns = - (uu___2.FStar_VConfig.trivial_pre_for_unannotated_effectful_fns); - FStar_VConfig.reuse_hint_for = - (uu___2.FStar_VConfig.reuse_hint_for) + FStarC_VConfig.initial_fuel = v; + FStarC_VConfig.max_fuel = (uu___2.FStarC_VConfig.max_fuel); + FStarC_VConfig.initial_ifuel = + (uu___2.FStarC_VConfig.initial_ifuel); + FStarC_VConfig.max_ifuel = + (uu___2.FStarC_VConfig.max_ifuel); + FStarC_VConfig.detail_errors = + (uu___2.FStarC_VConfig.detail_errors); + FStarC_VConfig.detail_hint_replay = + (uu___2.FStarC_VConfig.detail_hint_replay); + FStarC_VConfig.no_smt = (uu___2.FStarC_VConfig.no_smt); + FStarC_VConfig.quake_lo = (uu___2.FStarC_VConfig.quake_lo); + FStarC_VConfig.quake_hi = (uu___2.FStarC_VConfig.quake_hi); + FStarC_VConfig.quake_keep = + (uu___2.FStarC_VConfig.quake_keep); + FStarC_VConfig.retry = (uu___2.FStarC_VConfig.retry); + FStarC_VConfig.smtencoding_elim_box = + (uu___2.FStarC_VConfig.smtencoding_elim_box); + FStarC_VConfig.smtencoding_nl_arith_repr = + (uu___2.FStarC_VConfig.smtencoding_nl_arith_repr); + FStarC_VConfig.smtencoding_l_arith_repr = + (uu___2.FStarC_VConfig.smtencoding_l_arith_repr); + FStarC_VConfig.smtencoding_valid_intro = + (uu___2.FStarC_VConfig.smtencoding_valid_intro); + FStarC_VConfig.smtencoding_valid_elim = + (uu___2.FStarC_VConfig.smtencoding_valid_elim); + FStarC_VConfig.tcnorm = (uu___2.FStarC_VConfig.tcnorm); + FStarC_VConfig.no_plugins = + (uu___2.FStarC_VConfig.no_plugins); + FStarC_VConfig.no_tactics = + (uu___2.FStarC_VConfig.no_tactics); + FStarC_VConfig.z3cliopt = (uu___2.FStarC_VConfig.z3cliopt); + FStarC_VConfig.z3smtopt = (uu___2.FStarC_VConfig.z3smtopt); + FStarC_VConfig.z3refresh = + (uu___2.FStarC_VConfig.z3refresh); + FStarC_VConfig.z3rlimit = (uu___2.FStarC_VConfig.z3rlimit); + FStarC_VConfig.z3rlimit_factor = + (uu___2.FStarC_VConfig.z3rlimit_factor); + FStarC_VConfig.z3seed = (uu___2.FStarC_VConfig.z3seed); + FStarC_VConfig.z3version = + (uu___2.FStarC_VConfig.z3version); + FStarC_VConfig.trivial_pre_for_unannotated_effectful_fns = + (uu___2.FStarC_VConfig.trivial_pre_for_unannotated_effectful_fns); + FStarC_VConfig.reuse_hint_for = + (uu___2.FStarC_VConfig.reuse_hint_for) })) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -437,24 +446,24 @@ let (set_initial_fuel : (Obj.magic uu___) (fun uu___1 -> (fun uu___1 -> - Obj.magic (FStar_Tactics_V2_Builtins.set_vconfig uu___1)) uu___1) + Obj.magic (FStarC_Tactics_V2_Builtins.set_vconfig uu___1)) uu___1) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.SMT.set_initial_fuel" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.SMT.set_initial_fuel" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.SMT.set_initial_fuel (plugin)" - (FStar_Tactics_Native.from_tactic_1 set_initial_fuel) - FStar_Syntax_Embeddings.e_int FStar_Syntax_Embeddings.e_unit + (FStarC_Tactics_Native.from_tactic_1 set_initial_fuel) + FStarC_Syntax_Embeddings.e_int FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (set_initial_ifuel : Prims.int -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun v -> let uu___ = - let uu___1 = FStar_Tactics_V2_Builtins.get_vconfig () in + let uu___1 = FStarC_Tactics_V2_Builtins.get_vconfig () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -470,48 +479,51 @@ let (set_initial_ifuel : FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> { - FStar_VConfig.initial_fuel = - (uu___2.FStar_VConfig.initial_fuel); - FStar_VConfig.max_fuel = (uu___2.FStar_VConfig.max_fuel); - FStar_VConfig.initial_ifuel = v; - FStar_VConfig.max_ifuel = (uu___2.FStar_VConfig.max_ifuel); - FStar_VConfig.detail_errors = - (uu___2.FStar_VConfig.detail_errors); - FStar_VConfig.detail_hint_replay = - (uu___2.FStar_VConfig.detail_hint_replay); - FStar_VConfig.no_smt = (uu___2.FStar_VConfig.no_smt); - FStar_VConfig.quake_lo = (uu___2.FStar_VConfig.quake_lo); - FStar_VConfig.quake_hi = (uu___2.FStar_VConfig.quake_hi); - FStar_VConfig.quake_keep = - (uu___2.FStar_VConfig.quake_keep); - FStar_VConfig.retry = (uu___2.FStar_VConfig.retry); - FStar_VConfig.smtencoding_elim_box = - (uu___2.FStar_VConfig.smtencoding_elim_box); - FStar_VConfig.smtencoding_nl_arith_repr = - (uu___2.FStar_VConfig.smtencoding_nl_arith_repr); - FStar_VConfig.smtencoding_l_arith_repr = - (uu___2.FStar_VConfig.smtencoding_l_arith_repr); - FStar_VConfig.smtencoding_valid_intro = - (uu___2.FStar_VConfig.smtencoding_valid_intro); - FStar_VConfig.smtencoding_valid_elim = - (uu___2.FStar_VConfig.smtencoding_valid_elim); - FStar_VConfig.tcnorm = (uu___2.FStar_VConfig.tcnorm); - FStar_VConfig.no_plugins = - (uu___2.FStar_VConfig.no_plugins); - FStar_VConfig.no_tactics = - (uu___2.FStar_VConfig.no_tactics); - FStar_VConfig.z3cliopt = (uu___2.FStar_VConfig.z3cliopt); - FStar_VConfig.z3smtopt = (uu___2.FStar_VConfig.z3smtopt); - FStar_VConfig.z3refresh = (uu___2.FStar_VConfig.z3refresh); - FStar_VConfig.z3rlimit = (uu___2.FStar_VConfig.z3rlimit); - FStar_VConfig.z3rlimit_factor = - (uu___2.FStar_VConfig.z3rlimit_factor); - FStar_VConfig.z3seed = (uu___2.FStar_VConfig.z3seed); - FStar_VConfig.z3version = (uu___2.FStar_VConfig.z3version); - FStar_VConfig.trivial_pre_for_unannotated_effectful_fns = - (uu___2.FStar_VConfig.trivial_pre_for_unannotated_effectful_fns); - FStar_VConfig.reuse_hint_for = - (uu___2.FStar_VConfig.reuse_hint_for) + FStarC_VConfig.initial_fuel = + (uu___2.FStarC_VConfig.initial_fuel); + FStarC_VConfig.max_fuel = (uu___2.FStarC_VConfig.max_fuel); + FStarC_VConfig.initial_ifuel = v; + FStarC_VConfig.max_ifuel = + (uu___2.FStarC_VConfig.max_ifuel); + FStarC_VConfig.detail_errors = + (uu___2.FStarC_VConfig.detail_errors); + FStarC_VConfig.detail_hint_replay = + (uu___2.FStarC_VConfig.detail_hint_replay); + FStarC_VConfig.no_smt = (uu___2.FStarC_VConfig.no_smt); + FStarC_VConfig.quake_lo = (uu___2.FStarC_VConfig.quake_lo); + FStarC_VConfig.quake_hi = (uu___2.FStarC_VConfig.quake_hi); + FStarC_VConfig.quake_keep = + (uu___2.FStarC_VConfig.quake_keep); + FStarC_VConfig.retry = (uu___2.FStarC_VConfig.retry); + FStarC_VConfig.smtencoding_elim_box = + (uu___2.FStarC_VConfig.smtencoding_elim_box); + FStarC_VConfig.smtencoding_nl_arith_repr = + (uu___2.FStarC_VConfig.smtencoding_nl_arith_repr); + FStarC_VConfig.smtencoding_l_arith_repr = + (uu___2.FStarC_VConfig.smtencoding_l_arith_repr); + FStarC_VConfig.smtencoding_valid_intro = + (uu___2.FStarC_VConfig.smtencoding_valid_intro); + FStarC_VConfig.smtencoding_valid_elim = + (uu___2.FStarC_VConfig.smtencoding_valid_elim); + FStarC_VConfig.tcnorm = (uu___2.FStarC_VConfig.tcnorm); + FStarC_VConfig.no_plugins = + (uu___2.FStarC_VConfig.no_plugins); + FStarC_VConfig.no_tactics = + (uu___2.FStarC_VConfig.no_tactics); + FStarC_VConfig.z3cliopt = (uu___2.FStarC_VConfig.z3cliopt); + FStarC_VConfig.z3smtopt = (uu___2.FStarC_VConfig.z3smtopt); + FStarC_VConfig.z3refresh = + (uu___2.FStarC_VConfig.z3refresh); + FStarC_VConfig.z3rlimit = (uu___2.FStarC_VConfig.z3rlimit); + FStarC_VConfig.z3rlimit_factor = + (uu___2.FStarC_VConfig.z3rlimit_factor); + FStarC_VConfig.z3seed = (uu___2.FStarC_VConfig.z3seed); + FStarC_VConfig.z3version = + (uu___2.FStarC_VConfig.z3version); + FStarC_VConfig.trivial_pre_for_unannotated_effectful_fns = + (uu___2.FStarC_VConfig.trivial_pre_for_unannotated_effectful_fns); + FStarC_VConfig.reuse_hint_for = + (uu___2.FStarC_VConfig.reuse_hint_for) })) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -525,24 +537,24 @@ let (set_initial_ifuel : (Obj.magic uu___) (fun uu___1 -> (fun uu___1 -> - Obj.magic (FStar_Tactics_V2_Builtins.set_vconfig uu___1)) uu___1) + Obj.magic (FStarC_Tactics_V2_Builtins.set_vconfig uu___1)) uu___1) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.SMT.set_initial_ifuel" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.SMT.set_initial_ifuel" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.SMT.set_initial_ifuel (plugin)" - (FStar_Tactics_Native.from_tactic_1 set_initial_ifuel) - FStar_Syntax_Embeddings.e_int FStar_Syntax_Embeddings.e_unit + (FStarC_Tactics_Native.from_tactic_1 set_initial_ifuel) + FStarC_Syntax_Embeddings.e_int FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (set_max_fuel : Prims.int -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun v -> let uu___ = - let uu___1 = FStar_Tactics_V2_Builtins.get_vconfig () in + let uu___1 = FStarC_Tactics_V2_Builtins.get_vconfig () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -558,49 +570,52 @@ let (set_max_fuel : Prims.int -> (unit, unit) FStar_Tactics_Effect.tac_repr) FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> { - FStar_VConfig.initial_fuel = - (uu___2.FStar_VConfig.initial_fuel); - FStar_VConfig.max_fuel = v; - FStar_VConfig.initial_ifuel = - (uu___2.FStar_VConfig.initial_ifuel); - FStar_VConfig.max_ifuel = (uu___2.FStar_VConfig.max_ifuel); - FStar_VConfig.detail_errors = - (uu___2.FStar_VConfig.detail_errors); - FStar_VConfig.detail_hint_replay = - (uu___2.FStar_VConfig.detail_hint_replay); - FStar_VConfig.no_smt = (uu___2.FStar_VConfig.no_smt); - FStar_VConfig.quake_lo = (uu___2.FStar_VConfig.quake_lo); - FStar_VConfig.quake_hi = (uu___2.FStar_VConfig.quake_hi); - FStar_VConfig.quake_keep = - (uu___2.FStar_VConfig.quake_keep); - FStar_VConfig.retry = (uu___2.FStar_VConfig.retry); - FStar_VConfig.smtencoding_elim_box = - (uu___2.FStar_VConfig.smtencoding_elim_box); - FStar_VConfig.smtencoding_nl_arith_repr = - (uu___2.FStar_VConfig.smtencoding_nl_arith_repr); - FStar_VConfig.smtencoding_l_arith_repr = - (uu___2.FStar_VConfig.smtencoding_l_arith_repr); - FStar_VConfig.smtencoding_valid_intro = - (uu___2.FStar_VConfig.smtencoding_valid_intro); - FStar_VConfig.smtencoding_valid_elim = - (uu___2.FStar_VConfig.smtencoding_valid_elim); - FStar_VConfig.tcnorm = (uu___2.FStar_VConfig.tcnorm); - FStar_VConfig.no_plugins = - (uu___2.FStar_VConfig.no_plugins); - FStar_VConfig.no_tactics = - (uu___2.FStar_VConfig.no_tactics); - FStar_VConfig.z3cliopt = (uu___2.FStar_VConfig.z3cliopt); - FStar_VConfig.z3smtopt = (uu___2.FStar_VConfig.z3smtopt); - FStar_VConfig.z3refresh = (uu___2.FStar_VConfig.z3refresh); - FStar_VConfig.z3rlimit = (uu___2.FStar_VConfig.z3rlimit); - FStar_VConfig.z3rlimit_factor = - (uu___2.FStar_VConfig.z3rlimit_factor); - FStar_VConfig.z3seed = (uu___2.FStar_VConfig.z3seed); - FStar_VConfig.z3version = (uu___2.FStar_VConfig.z3version); - FStar_VConfig.trivial_pre_for_unannotated_effectful_fns = - (uu___2.FStar_VConfig.trivial_pre_for_unannotated_effectful_fns); - FStar_VConfig.reuse_hint_for = - (uu___2.FStar_VConfig.reuse_hint_for) + FStarC_VConfig.initial_fuel = + (uu___2.FStarC_VConfig.initial_fuel); + FStarC_VConfig.max_fuel = v; + FStarC_VConfig.initial_ifuel = + (uu___2.FStarC_VConfig.initial_ifuel); + FStarC_VConfig.max_ifuel = + (uu___2.FStarC_VConfig.max_ifuel); + FStarC_VConfig.detail_errors = + (uu___2.FStarC_VConfig.detail_errors); + FStarC_VConfig.detail_hint_replay = + (uu___2.FStarC_VConfig.detail_hint_replay); + FStarC_VConfig.no_smt = (uu___2.FStarC_VConfig.no_smt); + FStarC_VConfig.quake_lo = (uu___2.FStarC_VConfig.quake_lo); + FStarC_VConfig.quake_hi = (uu___2.FStarC_VConfig.quake_hi); + FStarC_VConfig.quake_keep = + (uu___2.FStarC_VConfig.quake_keep); + FStarC_VConfig.retry = (uu___2.FStarC_VConfig.retry); + FStarC_VConfig.smtencoding_elim_box = + (uu___2.FStarC_VConfig.smtencoding_elim_box); + FStarC_VConfig.smtencoding_nl_arith_repr = + (uu___2.FStarC_VConfig.smtencoding_nl_arith_repr); + FStarC_VConfig.smtencoding_l_arith_repr = + (uu___2.FStarC_VConfig.smtencoding_l_arith_repr); + FStarC_VConfig.smtencoding_valid_intro = + (uu___2.FStarC_VConfig.smtencoding_valid_intro); + FStarC_VConfig.smtencoding_valid_elim = + (uu___2.FStarC_VConfig.smtencoding_valid_elim); + FStarC_VConfig.tcnorm = (uu___2.FStarC_VConfig.tcnorm); + FStarC_VConfig.no_plugins = + (uu___2.FStarC_VConfig.no_plugins); + FStarC_VConfig.no_tactics = + (uu___2.FStarC_VConfig.no_tactics); + FStarC_VConfig.z3cliopt = (uu___2.FStarC_VConfig.z3cliopt); + FStarC_VConfig.z3smtopt = (uu___2.FStarC_VConfig.z3smtopt); + FStarC_VConfig.z3refresh = + (uu___2.FStarC_VConfig.z3refresh); + FStarC_VConfig.z3rlimit = (uu___2.FStarC_VConfig.z3rlimit); + FStarC_VConfig.z3rlimit_factor = + (uu___2.FStarC_VConfig.z3rlimit_factor); + FStarC_VConfig.z3seed = (uu___2.FStarC_VConfig.z3seed); + FStarC_VConfig.z3version = + (uu___2.FStarC_VConfig.z3version); + FStarC_VConfig.trivial_pre_for_unannotated_effectful_fns = + (uu___2.FStarC_VConfig.trivial_pre_for_unannotated_effectful_fns); + FStarC_VConfig.reuse_hint_for = + (uu___2.FStarC_VConfig.reuse_hint_for) })) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -614,24 +629,24 @@ let (set_max_fuel : Prims.int -> (unit, unit) FStar_Tactics_Effect.tac_repr) (Obj.magic uu___) (fun uu___1 -> (fun uu___1 -> - Obj.magic (FStar_Tactics_V2_Builtins.set_vconfig uu___1)) uu___1) + Obj.magic (FStarC_Tactics_V2_Builtins.set_vconfig uu___1)) uu___1) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.SMT.set_max_fuel" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.SMT.set_max_fuel" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.SMT.set_max_fuel (plugin)" - (FStar_Tactics_Native.from_tactic_1 set_max_fuel) - FStar_Syntax_Embeddings.e_int FStar_Syntax_Embeddings.e_unit + (FStarC_Tactics_Native.from_tactic_1 set_max_fuel) + FStarC_Syntax_Embeddings.e_int FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (set_max_ifuel : Prims.int -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun v -> let uu___ = - let uu___1 = FStar_Tactics_V2_Builtins.get_vconfig () in + let uu___1 = FStarC_Tactics_V2_Builtins.get_vconfig () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -647,49 +662,51 @@ let (set_max_ifuel : Prims.int -> (unit, unit) FStar_Tactics_Effect.tac_repr) FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> { - FStar_VConfig.initial_fuel = - (uu___2.FStar_VConfig.initial_fuel); - FStar_VConfig.max_fuel = (uu___2.FStar_VConfig.max_fuel); - FStar_VConfig.initial_ifuel = - (uu___2.FStar_VConfig.initial_ifuel); - FStar_VConfig.max_ifuel = v; - FStar_VConfig.detail_errors = - (uu___2.FStar_VConfig.detail_errors); - FStar_VConfig.detail_hint_replay = - (uu___2.FStar_VConfig.detail_hint_replay); - FStar_VConfig.no_smt = (uu___2.FStar_VConfig.no_smt); - FStar_VConfig.quake_lo = (uu___2.FStar_VConfig.quake_lo); - FStar_VConfig.quake_hi = (uu___2.FStar_VConfig.quake_hi); - FStar_VConfig.quake_keep = - (uu___2.FStar_VConfig.quake_keep); - FStar_VConfig.retry = (uu___2.FStar_VConfig.retry); - FStar_VConfig.smtencoding_elim_box = - (uu___2.FStar_VConfig.smtencoding_elim_box); - FStar_VConfig.smtencoding_nl_arith_repr = - (uu___2.FStar_VConfig.smtencoding_nl_arith_repr); - FStar_VConfig.smtencoding_l_arith_repr = - (uu___2.FStar_VConfig.smtencoding_l_arith_repr); - FStar_VConfig.smtencoding_valid_intro = - (uu___2.FStar_VConfig.smtencoding_valid_intro); - FStar_VConfig.smtencoding_valid_elim = - (uu___2.FStar_VConfig.smtencoding_valid_elim); - FStar_VConfig.tcnorm = (uu___2.FStar_VConfig.tcnorm); - FStar_VConfig.no_plugins = - (uu___2.FStar_VConfig.no_plugins); - FStar_VConfig.no_tactics = - (uu___2.FStar_VConfig.no_tactics); - FStar_VConfig.z3cliopt = (uu___2.FStar_VConfig.z3cliopt); - FStar_VConfig.z3smtopt = (uu___2.FStar_VConfig.z3smtopt); - FStar_VConfig.z3refresh = (uu___2.FStar_VConfig.z3refresh); - FStar_VConfig.z3rlimit = (uu___2.FStar_VConfig.z3rlimit); - FStar_VConfig.z3rlimit_factor = - (uu___2.FStar_VConfig.z3rlimit_factor); - FStar_VConfig.z3seed = (uu___2.FStar_VConfig.z3seed); - FStar_VConfig.z3version = (uu___2.FStar_VConfig.z3version); - FStar_VConfig.trivial_pre_for_unannotated_effectful_fns = - (uu___2.FStar_VConfig.trivial_pre_for_unannotated_effectful_fns); - FStar_VConfig.reuse_hint_for = - (uu___2.FStar_VConfig.reuse_hint_for) + FStarC_VConfig.initial_fuel = + (uu___2.FStarC_VConfig.initial_fuel); + FStarC_VConfig.max_fuel = (uu___2.FStarC_VConfig.max_fuel); + FStarC_VConfig.initial_ifuel = + (uu___2.FStarC_VConfig.initial_ifuel); + FStarC_VConfig.max_ifuel = v; + FStarC_VConfig.detail_errors = + (uu___2.FStarC_VConfig.detail_errors); + FStarC_VConfig.detail_hint_replay = + (uu___2.FStarC_VConfig.detail_hint_replay); + FStarC_VConfig.no_smt = (uu___2.FStarC_VConfig.no_smt); + FStarC_VConfig.quake_lo = (uu___2.FStarC_VConfig.quake_lo); + FStarC_VConfig.quake_hi = (uu___2.FStarC_VConfig.quake_hi); + FStarC_VConfig.quake_keep = + (uu___2.FStarC_VConfig.quake_keep); + FStarC_VConfig.retry = (uu___2.FStarC_VConfig.retry); + FStarC_VConfig.smtencoding_elim_box = + (uu___2.FStarC_VConfig.smtencoding_elim_box); + FStarC_VConfig.smtencoding_nl_arith_repr = + (uu___2.FStarC_VConfig.smtencoding_nl_arith_repr); + FStarC_VConfig.smtencoding_l_arith_repr = + (uu___2.FStarC_VConfig.smtencoding_l_arith_repr); + FStarC_VConfig.smtencoding_valid_intro = + (uu___2.FStarC_VConfig.smtencoding_valid_intro); + FStarC_VConfig.smtencoding_valid_elim = + (uu___2.FStarC_VConfig.smtencoding_valid_elim); + FStarC_VConfig.tcnorm = (uu___2.FStarC_VConfig.tcnorm); + FStarC_VConfig.no_plugins = + (uu___2.FStarC_VConfig.no_plugins); + FStarC_VConfig.no_tactics = + (uu___2.FStarC_VConfig.no_tactics); + FStarC_VConfig.z3cliopt = (uu___2.FStarC_VConfig.z3cliopt); + FStarC_VConfig.z3smtopt = (uu___2.FStarC_VConfig.z3smtopt); + FStarC_VConfig.z3refresh = + (uu___2.FStarC_VConfig.z3refresh); + FStarC_VConfig.z3rlimit = (uu___2.FStarC_VConfig.z3rlimit); + FStarC_VConfig.z3rlimit_factor = + (uu___2.FStarC_VConfig.z3rlimit_factor); + FStarC_VConfig.z3seed = (uu___2.FStarC_VConfig.z3seed); + FStarC_VConfig.z3version = + (uu___2.FStarC_VConfig.z3version); + FStarC_VConfig.trivial_pre_for_unannotated_effectful_fns = + (uu___2.FStarC_VConfig.trivial_pre_for_unannotated_effectful_fns); + FStarC_VConfig.reuse_hint_for = + (uu___2.FStarC_VConfig.reuse_hint_for) })) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -703,23 +720,23 @@ let (set_max_ifuel : Prims.int -> (unit, unit) FStar_Tactics_Effect.tac_repr) (Obj.magic uu___) (fun uu___1 -> (fun uu___1 -> - Obj.magic (FStar_Tactics_V2_Builtins.set_vconfig uu___1)) uu___1) + Obj.magic (FStarC_Tactics_V2_Builtins.set_vconfig uu___1)) uu___1) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.SMT.set_max_ifuel" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.SMT.set_max_ifuel" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.SMT.set_max_ifuel (plugin)" - (FStar_Tactics_Native.from_tactic_1 set_max_ifuel) - FStar_Syntax_Embeddings.e_int FStar_Syntax_Embeddings.e_unit + (FStarC_Tactics_Native.from_tactic_1 set_max_ifuel) + FStarC_Syntax_Embeddings.e_int FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (set_fuel : Prims.int -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun v -> let uu___ = - let uu___1 = FStar_Tactics_V2_Builtins.get_vconfig () in + let uu___1 = FStarC_Tactics_V2_Builtins.get_vconfig () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -735,48 +752,51 @@ let (set_fuel : Prims.int -> (unit, unit) FStar_Tactics_Effect.tac_repr) = FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> { - FStar_VConfig.initial_fuel = v; - FStar_VConfig.max_fuel = v; - FStar_VConfig.initial_ifuel = - (uu___2.FStar_VConfig.initial_ifuel); - FStar_VConfig.max_ifuel = (uu___2.FStar_VConfig.max_ifuel); - FStar_VConfig.detail_errors = - (uu___2.FStar_VConfig.detail_errors); - FStar_VConfig.detail_hint_replay = - (uu___2.FStar_VConfig.detail_hint_replay); - FStar_VConfig.no_smt = (uu___2.FStar_VConfig.no_smt); - FStar_VConfig.quake_lo = (uu___2.FStar_VConfig.quake_lo); - FStar_VConfig.quake_hi = (uu___2.FStar_VConfig.quake_hi); - FStar_VConfig.quake_keep = - (uu___2.FStar_VConfig.quake_keep); - FStar_VConfig.retry = (uu___2.FStar_VConfig.retry); - FStar_VConfig.smtencoding_elim_box = - (uu___2.FStar_VConfig.smtencoding_elim_box); - FStar_VConfig.smtencoding_nl_arith_repr = - (uu___2.FStar_VConfig.smtencoding_nl_arith_repr); - FStar_VConfig.smtencoding_l_arith_repr = - (uu___2.FStar_VConfig.smtencoding_l_arith_repr); - FStar_VConfig.smtencoding_valid_intro = - (uu___2.FStar_VConfig.smtencoding_valid_intro); - FStar_VConfig.smtencoding_valid_elim = - (uu___2.FStar_VConfig.smtencoding_valid_elim); - FStar_VConfig.tcnorm = (uu___2.FStar_VConfig.tcnorm); - FStar_VConfig.no_plugins = - (uu___2.FStar_VConfig.no_plugins); - FStar_VConfig.no_tactics = - (uu___2.FStar_VConfig.no_tactics); - FStar_VConfig.z3cliopt = (uu___2.FStar_VConfig.z3cliopt); - FStar_VConfig.z3smtopt = (uu___2.FStar_VConfig.z3smtopt); - FStar_VConfig.z3refresh = (uu___2.FStar_VConfig.z3refresh); - FStar_VConfig.z3rlimit = (uu___2.FStar_VConfig.z3rlimit); - FStar_VConfig.z3rlimit_factor = - (uu___2.FStar_VConfig.z3rlimit_factor); - FStar_VConfig.z3seed = (uu___2.FStar_VConfig.z3seed); - FStar_VConfig.z3version = (uu___2.FStar_VConfig.z3version); - FStar_VConfig.trivial_pre_for_unannotated_effectful_fns = - (uu___2.FStar_VConfig.trivial_pre_for_unannotated_effectful_fns); - FStar_VConfig.reuse_hint_for = - (uu___2.FStar_VConfig.reuse_hint_for) + FStarC_VConfig.initial_fuel = v; + FStarC_VConfig.max_fuel = v; + FStarC_VConfig.initial_ifuel = + (uu___2.FStarC_VConfig.initial_ifuel); + FStarC_VConfig.max_ifuel = + (uu___2.FStarC_VConfig.max_ifuel); + FStarC_VConfig.detail_errors = + (uu___2.FStarC_VConfig.detail_errors); + FStarC_VConfig.detail_hint_replay = + (uu___2.FStarC_VConfig.detail_hint_replay); + FStarC_VConfig.no_smt = (uu___2.FStarC_VConfig.no_smt); + FStarC_VConfig.quake_lo = (uu___2.FStarC_VConfig.quake_lo); + FStarC_VConfig.quake_hi = (uu___2.FStarC_VConfig.quake_hi); + FStarC_VConfig.quake_keep = + (uu___2.FStarC_VConfig.quake_keep); + FStarC_VConfig.retry = (uu___2.FStarC_VConfig.retry); + FStarC_VConfig.smtencoding_elim_box = + (uu___2.FStarC_VConfig.smtencoding_elim_box); + FStarC_VConfig.smtencoding_nl_arith_repr = + (uu___2.FStarC_VConfig.smtencoding_nl_arith_repr); + FStarC_VConfig.smtencoding_l_arith_repr = + (uu___2.FStarC_VConfig.smtencoding_l_arith_repr); + FStarC_VConfig.smtencoding_valid_intro = + (uu___2.FStarC_VConfig.smtencoding_valid_intro); + FStarC_VConfig.smtencoding_valid_elim = + (uu___2.FStarC_VConfig.smtencoding_valid_elim); + FStarC_VConfig.tcnorm = (uu___2.FStarC_VConfig.tcnorm); + FStarC_VConfig.no_plugins = + (uu___2.FStarC_VConfig.no_plugins); + FStarC_VConfig.no_tactics = + (uu___2.FStarC_VConfig.no_tactics); + FStarC_VConfig.z3cliopt = (uu___2.FStarC_VConfig.z3cliopt); + FStarC_VConfig.z3smtopt = (uu___2.FStarC_VConfig.z3smtopt); + FStarC_VConfig.z3refresh = + (uu___2.FStarC_VConfig.z3refresh); + FStarC_VConfig.z3rlimit = (uu___2.FStarC_VConfig.z3rlimit); + FStarC_VConfig.z3rlimit_factor = + (uu___2.FStarC_VConfig.z3rlimit_factor); + FStarC_VConfig.z3seed = (uu___2.FStarC_VConfig.z3seed); + FStarC_VConfig.z3version = + (uu___2.FStarC_VConfig.z3version); + FStarC_VConfig.trivial_pre_for_unannotated_effectful_fns = + (uu___2.FStarC_VConfig.trivial_pre_for_unannotated_effectful_fns); + FStarC_VConfig.reuse_hint_for = + (uu___2.FStarC_VConfig.reuse_hint_for) })) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -790,23 +810,23 @@ let (set_fuel : Prims.int -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (Obj.magic uu___) (fun uu___1 -> (fun uu___1 -> - Obj.magic (FStar_Tactics_V2_Builtins.set_vconfig uu___1)) uu___1) + Obj.magic (FStarC_Tactics_V2_Builtins.set_vconfig uu___1)) uu___1) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.SMT.set_fuel" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.SMT.set_fuel" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.SMT.set_fuel (plugin)" - (FStar_Tactics_Native.from_tactic_1 set_fuel) - FStar_Syntax_Embeddings.e_int FStar_Syntax_Embeddings.e_unit + (FStarC_Tactics_Native.from_tactic_1 set_fuel) + FStarC_Syntax_Embeddings.e_int FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (set_ifuel : Prims.int -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun v -> let uu___ = - let uu___1 = FStar_Tactics_V2_Builtins.get_vconfig () in + let uu___1 = FStarC_Tactics_V2_Builtins.get_vconfig () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -822,48 +842,50 @@ let (set_ifuel : Prims.int -> (unit, unit) FStar_Tactics_Effect.tac_repr) = FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> { - FStar_VConfig.initial_fuel = - (uu___2.FStar_VConfig.initial_fuel); - FStar_VConfig.max_fuel = (uu___2.FStar_VConfig.max_fuel); - FStar_VConfig.initial_ifuel = v; - FStar_VConfig.max_ifuel = v; - FStar_VConfig.detail_errors = - (uu___2.FStar_VConfig.detail_errors); - FStar_VConfig.detail_hint_replay = - (uu___2.FStar_VConfig.detail_hint_replay); - FStar_VConfig.no_smt = (uu___2.FStar_VConfig.no_smt); - FStar_VConfig.quake_lo = (uu___2.FStar_VConfig.quake_lo); - FStar_VConfig.quake_hi = (uu___2.FStar_VConfig.quake_hi); - FStar_VConfig.quake_keep = - (uu___2.FStar_VConfig.quake_keep); - FStar_VConfig.retry = (uu___2.FStar_VConfig.retry); - FStar_VConfig.smtencoding_elim_box = - (uu___2.FStar_VConfig.smtencoding_elim_box); - FStar_VConfig.smtencoding_nl_arith_repr = - (uu___2.FStar_VConfig.smtencoding_nl_arith_repr); - FStar_VConfig.smtencoding_l_arith_repr = - (uu___2.FStar_VConfig.smtencoding_l_arith_repr); - FStar_VConfig.smtencoding_valid_intro = - (uu___2.FStar_VConfig.smtencoding_valid_intro); - FStar_VConfig.smtencoding_valid_elim = - (uu___2.FStar_VConfig.smtencoding_valid_elim); - FStar_VConfig.tcnorm = (uu___2.FStar_VConfig.tcnorm); - FStar_VConfig.no_plugins = - (uu___2.FStar_VConfig.no_plugins); - FStar_VConfig.no_tactics = - (uu___2.FStar_VConfig.no_tactics); - FStar_VConfig.z3cliopt = (uu___2.FStar_VConfig.z3cliopt); - FStar_VConfig.z3smtopt = (uu___2.FStar_VConfig.z3smtopt); - FStar_VConfig.z3refresh = (uu___2.FStar_VConfig.z3refresh); - FStar_VConfig.z3rlimit = (uu___2.FStar_VConfig.z3rlimit); - FStar_VConfig.z3rlimit_factor = - (uu___2.FStar_VConfig.z3rlimit_factor); - FStar_VConfig.z3seed = (uu___2.FStar_VConfig.z3seed); - FStar_VConfig.z3version = (uu___2.FStar_VConfig.z3version); - FStar_VConfig.trivial_pre_for_unannotated_effectful_fns = - (uu___2.FStar_VConfig.trivial_pre_for_unannotated_effectful_fns); - FStar_VConfig.reuse_hint_for = - (uu___2.FStar_VConfig.reuse_hint_for) + FStarC_VConfig.initial_fuel = + (uu___2.FStarC_VConfig.initial_fuel); + FStarC_VConfig.max_fuel = (uu___2.FStarC_VConfig.max_fuel); + FStarC_VConfig.initial_ifuel = v; + FStarC_VConfig.max_ifuel = v; + FStarC_VConfig.detail_errors = + (uu___2.FStarC_VConfig.detail_errors); + FStarC_VConfig.detail_hint_replay = + (uu___2.FStarC_VConfig.detail_hint_replay); + FStarC_VConfig.no_smt = (uu___2.FStarC_VConfig.no_smt); + FStarC_VConfig.quake_lo = (uu___2.FStarC_VConfig.quake_lo); + FStarC_VConfig.quake_hi = (uu___2.FStarC_VConfig.quake_hi); + FStarC_VConfig.quake_keep = + (uu___2.FStarC_VConfig.quake_keep); + FStarC_VConfig.retry = (uu___2.FStarC_VConfig.retry); + FStarC_VConfig.smtencoding_elim_box = + (uu___2.FStarC_VConfig.smtencoding_elim_box); + FStarC_VConfig.smtencoding_nl_arith_repr = + (uu___2.FStarC_VConfig.smtencoding_nl_arith_repr); + FStarC_VConfig.smtencoding_l_arith_repr = + (uu___2.FStarC_VConfig.smtencoding_l_arith_repr); + FStarC_VConfig.smtencoding_valid_intro = + (uu___2.FStarC_VConfig.smtencoding_valid_intro); + FStarC_VConfig.smtencoding_valid_elim = + (uu___2.FStarC_VConfig.smtencoding_valid_elim); + FStarC_VConfig.tcnorm = (uu___2.FStarC_VConfig.tcnorm); + FStarC_VConfig.no_plugins = + (uu___2.FStarC_VConfig.no_plugins); + FStarC_VConfig.no_tactics = + (uu___2.FStarC_VConfig.no_tactics); + FStarC_VConfig.z3cliopt = (uu___2.FStarC_VConfig.z3cliopt); + FStarC_VConfig.z3smtopt = (uu___2.FStarC_VConfig.z3smtopt); + FStarC_VConfig.z3refresh = + (uu___2.FStarC_VConfig.z3refresh); + FStarC_VConfig.z3rlimit = (uu___2.FStarC_VConfig.z3rlimit); + FStarC_VConfig.z3rlimit_factor = + (uu___2.FStarC_VConfig.z3rlimit_factor); + FStarC_VConfig.z3seed = (uu___2.FStarC_VConfig.z3seed); + FStarC_VConfig.z3version = + (uu___2.FStarC_VConfig.z3version); + FStarC_VConfig.trivial_pre_for_unannotated_effectful_fns = + (uu___2.FStarC_VConfig.trivial_pre_for_unannotated_effectful_fns); + FStarC_VConfig.reuse_hint_for = + (uu___2.FStarC_VConfig.reuse_hint_for) })) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -877,16 +899,16 @@ let (set_ifuel : Prims.int -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (Obj.magic uu___) (fun uu___1 -> (fun uu___1 -> - Obj.magic (FStar_Tactics_V2_Builtins.set_vconfig uu___1)) uu___1) + Obj.magic (FStarC_Tactics_V2_Builtins.set_vconfig uu___1)) uu___1) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.SMT.set_ifuel" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.SMT.set_ifuel" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.SMT.set_ifuel (plugin)" - (FStar_Tactics_Native.from_tactic_1 set_ifuel) - FStar_Syntax_Embeddings.e_int FStar_Syntax_Embeddings.e_unit + (FStarC_Tactics_Native.from_tactic_1 set_ifuel) + FStarC_Syntax_Embeddings.e_int FStarC_Syntax_Embeddings.e_unit psc ncb us args) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_Simplifier.ml b/ocaml/fstar-lib/generated/FStar_Tactics_Simplifier.ml index f2c3160269f..149014091ab 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_Simplifier.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_Simplifier.ml @@ -2,16 +2,16 @@ open Prims let (tiff : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Simplifier"; "lem_iff_refl"]))) let (step : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Simplifier"; "lem_iff_trans"]))) let (is_true : FStar_Tactics_NamedView.term -> @@ -295,7 +295,7 @@ let (inhabit : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___5 -> - FStar_Reflection_V2_Builtins.inspect_fv + FStarC_Reflection_V2_Builtins.inspect_fv fv)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -324,9 +324,9 @@ let (inhabit : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = Obj.magic (Obj.repr (FStar_Tactics_V2_Derived.exact - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const - (FStar_Reflection_V2_Data.C_Int + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const + (FStarC_Reflection_V2_Data.C_Int (Prims.of_int (42))))))) else Obj.magic @@ -337,9 +337,9 @@ let (inhabit : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = then Obj.repr (FStar_Tactics_V2_Derived.exact - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const - FStar_Reflection_V2_Data.C_True))) + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const + FStarC_Reflection_V2_Data.C_True))) else Obj.repr (if @@ -348,9 +348,9 @@ let (inhabit : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = then Obj.repr (FStar_Tactics_V2_Derived.exact - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const - FStar_Reflection_V2_Data.C_Unit))) + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const + FStarC_Reflection_V2_Data.C_Unit))) else Obj.repr (FStar_Tactics_V2_Derived.fail @@ -376,7 +376,7 @@ let rec (simplify_point : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) (Prims.of_int (81))))) (Obj.magic uu___1) (fun uu___2 -> (fun uu___2 -> - let uu___3 = FStar_Tactics_V2_Builtins.norm [] in + let uu___3 = FStarC_Tactics_V2_Builtins.norm [] in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -500,9 +500,9 @@ let rec (simplify_point : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) then Obj.magic (FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Simplifier"; @@ -542,9 +542,9 @@ let rec (simplify_point : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) then Obj.magic (FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Simplifier"; @@ -585,9 +585,9 @@ let rec (simplify_point : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) then Obj.magic (FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Simplifier"; @@ -628,9 +628,9 @@ let rec (simplify_point : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) then Obj.magic (FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Simplifier"; @@ -678,9 +678,9 @@ let rec (simplify_point : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) then Obj.magic (FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Simplifier"; @@ -720,9 +720,9 @@ let rec (simplify_point : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) then Obj.magic (FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Simplifier"; @@ -763,9 +763,9 @@ let rec (simplify_point : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) then Obj.magic (FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Simplifier"; @@ -806,9 +806,9 @@ let rec (simplify_point : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) then Obj.magic (FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Simplifier"; @@ -856,9 +856,9 @@ let rec (simplify_point : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) then Obj.magic (FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Simplifier"; @@ -898,9 +898,9 @@ let rec (simplify_point : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) then Obj.magic (FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Simplifier"; @@ -941,9 +941,9 @@ let rec (simplify_point : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) then Obj.magic (FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Simplifier"; @@ -992,9 +992,9 @@ let rec (simplify_point : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) then Obj.magic (FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Simplifier"; @@ -1041,9 +1041,9 @@ let rec (simplify_point : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) let uu___15 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Simplifier"; @@ -1122,9 +1122,9 @@ let rec (simplify_point : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) then Obj.magic (FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Simplifier"; @@ -1170,9 +1170,9 @@ let rec (simplify_point : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) let uu___15 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Simplifier"; @@ -1248,9 +1248,9 @@ let rec (simplify_point : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) then Obj.magic (FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Simplifier"; @@ -1291,9 +1291,9 @@ let rec (simplify_point : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) then Obj.magic (FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Simplifier"; @@ -1369,9 +1369,9 @@ let rec (simplify_point : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) then Obj.magic (FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Simplifier"; @@ -1411,9 +1411,9 @@ let rec (simplify_point : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) then Obj.magic (FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Simplifier"; @@ -1454,9 +1454,9 @@ let rec (simplify_point : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) then Obj.magic (FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Simplifier"; @@ -1497,9 +1497,9 @@ let rec (simplify_point : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) then Obj.magic (FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Simplifier"; @@ -1569,7 +1569,7 @@ and (recurse : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (Prims.of_int (74))))) (Obj.magic uu___1) (fun uu___2 -> (fun uu___2 -> - let uu___3 = FStar_Tactics_V2_Builtins.norm [] in + let uu___3 = FStarC_Tactics_V2_Builtins.norm [] in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1667,9 +1667,9 @@ and (recurse : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = uu___11 -> FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Simplifier"; @@ -1685,9 +1685,9 @@ and (recurse : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = uu___11 -> FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Simplifier"; @@ -1703,9 +1703,9 @@ and (recurse : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = uu___11 -> FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Simplifier"; @@ -1719,9 +1719,9 @@ and (recurse : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = let uu___12 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Simplifier"; @@ -1754,7 +1754,7 @@ and (recurse : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = -> let uu___14 = - FStar_Tactics_V2_Builtins.intro + FStarC_Tactics_V2_Builtins.intro () in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1795,9 +1795,9 @@ and (recurse : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = let uu___12 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Simplifier"; @@ -1830,7 +1830,7 @@ and (recurse : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = -> let uu___14 = - FStar_Tactics_V2_Builtins.intro + FStarC_Tactics_V2_Builtins.intro () in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1868,9 +1868,9 @@ and (recurse : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = let uu___10 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Simplifier"; @@ -1915,9 +1915,9 @@ and (recurse : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = uu___11 -> FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Simplifier"; @@ -1938,9 +1938,9 @@ let (simplify : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> let uu___1 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Simplifier"; "equiv"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_TypeRepr.ml b/ocaml/fstar-lib/generated/FStar_Tactics_TypeRepr.ml index 5d85f7385bb..3b2719a8d7d 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_TypeRepr.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_TypeRepr.ml @@ -4,77 +4,78 @@ let (empty_elim : Prims.empty -> unit -> Obj.t) = fun uu___ -> (fun e -> fun a -> Obj.magic (failwith "unreachable")) uu___1 uu___ let (add_suffix : - Prims.string -> FStar_Reflection_Types.name -> FStar_Reflection_Types.name) + Prims.string -> + FStarC_Reflection_Types.name -> FStarC_Reflection_Types.name) = fun s -> fun nm -> - FStar_Reflection_V2_Builtins.explode_qn - (Prims.strcat (FStar_Reflection_V2_Builtins.implode_qn nm) s) + FStarC_Reflection_V2_Builtins.explode_qn + (Prims.strcat (FStarC_Reflection_V2_Builtins.implode_qn nm) s) let (unitv_ : FStar_Tactics_NamedView.term) = - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const FStar_Reflection_V2_Data.C_Unit) + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const FStarC_Reflection_V2_Data.C_Unit) let (unitt_ : FStar_Tactics_NamedView.term) = - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv ["Prims"; "unit"])) + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "unit"])) let (empty_ : FStar_Tactics_NamedView.term) = - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv ["Prims"; "empty"])) + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "empty"])) let (either_ : FStar_Tactics_NamedView.term -> FStar_Tactics_NamedView.term -> FStar_Tactics_NamedView.term) = fun a -> fun b -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Pervasives"; "either"]))), - (a, FStar_Reflection_V2_Data.Q_Explicit)))), - (b, FStar_Reflection_V2_Data.Q_Explicit))) + (a, FStarC_Reflection_V2_Data.Q_Explicit)))), + (b, FStarC_Reflection_V2_Data.Q_Explicit))) let (tuple2_ : FStar_Tactics_NamedView.term -> FStar_Tactics_NamedView.term -> FStar_Tactics_NamedView.term) = fun a -> fun b -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Pervasives"; "Native"; "tuple2"]))), - (a, FStar_Reflection_V2_Data.Q_Explicit)))), - (b, FStar_Reflection_V2_Data.Q_Explicit))) + (a, FStarC_Reflection_V2_Data.Q_Explicit)))), + (b, FStarC_Reflection_V2_Data.Q_Explicit))) let (mktuple2_ : FStar_Tactics_NamedView.term -> FStar_Tactics_NamedView.term -> FStar_Tactics_NamedView.term) = fun a -> fun b -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Pervasives"; "Native"; "Mktuple2"]))), - (a, FStar_Reflection_V2_Data.Q_Explicit)))), - (b, FStar_Reflection_V2_Data.Q_Explicit))) + (a, FStarC_Reflection_V2_Data.Q_Explicit)))), + (b, FStarC_Reflection_V2_Data.Q_Explicit))) let (get_inductive_typ : Prims.string -> (FStar_Tactics_NamedView.sigelt_view, unit) FStar_Tactics_Effect.tac_repr) = fun nm -> - let uu___ = FStar_Tactics_V2_Builtins.top_env () in + let uu___ = FStarC_Tactics_V2_Builtins.top_env () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -92,8 +93,8 @@ let (get_inductive_typ : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> - FStar_Reflection_V2_Builtins.lookup_typ e - (FStar_Reflection_V2_Builtins.explode_qn nm))) in + FStarC_Reflection_V2_Builtins.lookup_typ e + (FStarC_Reflection_V2_Builtins.explode_qn nm))) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -150,8 +151,8 @@ let (get_inductive_typ : "ctors_of_typ: not an inductive type")))) uu___2))) uu___1) let (alg_ctor : - FStar_Reflection_Types.typ -> - (FStar_Reflection_Types.typ, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.typ -> + (FStarC_Reflection_Types.typ, unit) FStar_Tactics_Effect.tac_repr) = fun ty -> let uu___ = FStar_Tactics_V2_SyntaxHelpers.collect_arr ty in @@ -182,8 +183,8 @@ let (alg_ctor : uu___2) tys unitt_)) uu___1) let (generate_repr_typ : FStar_Tactics_NamedView.binders -> - FStar_Reflection_V2_Data.ctor Prims.list -> - (FStar_Reflection_Types.typ, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_V2_Data.ctor Prims.list -> + (FStarC_Reflection_Types.typ, unit) FStar_Tactics_Effect.tac_repr) = fun params -> fun ctors -> @@ -231,26 +232,26 @@ let (generate_repr_typ : FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> alternative_typ)))) uu___1) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.TypeRepr.generate_repr_typ" (Prims.of_int (3)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_2 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_2 "FStar.Tactics.TypeRepr.generate_repr_typ (plugin)" - (FStar_Tactics_Native.from_tactic_2 generate_repr_typ) - (FStar_Syntax_Embeddings.e_list + (FStarC_Tactics_Native.from_tactic_2 generate_repr_typ) + (FStarC_Syntax_Embeddings.e_list FStar_Tactics_NamedView.e_binder) - (FStar_Syntax_Embeddings.e_list - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_string) - FStar_Reflection_V2_Embeddings.e_term)) - FStar_Reflection_V2_Embeddings.e_term psc ncb us args) + (FStarC_Syntax_Embeddings.e_list + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_string) + FStarC_Reflection_V2_Embeddings.e_term)) + FStarC_Reflection_V2_Embeddings.e_term psc ncb us args) let (generate_down : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> - let uu___1 = FStar_Tactics_V2_Builtins.intro () in + let uu___1 = FStarC_Tactics_V2_Builtins.intro () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -265,7 +266,7 @@ let (generate_down : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___2 -> (fun b -> let uu___2 = - FStar_Tactics_V2_Builtins.t_destruct + FStarC_Tactics_V2_Builtins.t_destruct (FStar_Tactics_V2_SyntaxCoercions.binding_to_term b) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -291,7 +292,7 @@ let (generate_down : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = let uu___4 = FStar_Tactics_Util.repeatn n (fun uu___5 -> - FStar_Tactics_V2_Builtins.intro + FStarC_Tactics_V2_Builtins.intro ()) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -314,7 +315,7 @@ let (generate_down : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___5 -> (fun bs -> let uu___5 = - FStar_Tactics_V2_Builtins.intro + FStarC_Tactics_V2_Builtins.intro () in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -383,9 +384,9 @@ let (generate_down : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___8 -> FStar_Tactics_V2_Derived.apply - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Pervasives"; "Inr"])))) in @@ -416,9 +417,9 @@ let (generate_down : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = let uu___9 = FStar_Tactics_V2_Derived.apply - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Pervasives"; "Inl"]))) in @@ -457,17 +458,17 @@ let (generate_down : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = uu___6))) uu___5)) cases)) uu___3))) uu___2) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.TypeRepr.generate_down" - (Prims.of_int (2)) + FStarC_Tactics_Native.register_tactic + "FStar.Tactics.TypeRepr.generate_down" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.TypeRepr.generate_down (plugin)" - (FStar_Tactics_Native.from_tactic_1 generate_down) - FStar_Syntax_Embeddings.e_unit FStar_Syntax_Embeddings.e_unit - psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 generate_down) + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let rec (get_apply_tuple : FStar_Tactics_NamedView.binding -> (FStar_Tactics_NamedView.binding Prims.list, unit) @@ -476,7 +477,7 @@ let rec (get_apply_tuple : fun b -> let uu___ = FStar_Tactics_V2_SyntaxHelpers.collect_app - b.FStar_Reflection_V2_Data.sort3 in + b.FStarC_Reflection_V2_Data.sort3 in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -530,7 +531,7 @@ let rec (get_apply_tuple : Obj.magic (Obj.repr (if - (FStar_Reflection_V2_Builtins.inspect_fv + (FStarC_Reflection_V2_Builtins.inspect_fv fv) = ["FStar"; @@ -539,7 +540,7 @@ let rec (get_apply_tuple : "tuple2"] then let uu___5 = - FStar_Tactics_V2_Builtins.t_destruct + FStarC_Tactics_V2_Builtins.t_destruct (FStar_Tactics_V2_SyntaxCoercions.binding_to_term b) in FStar_Tactics_Effect.tac_bind @@ -568,7 +569,7 @@ let rec (get_apply_tuple : cases) = Prims.int_one) && - ((FStar_Reflection_V2_Builtins.inspect_fv + ((FStarC_Reflection_V2_Builtins.inspect_fv (FStar_Pervasives_Native.fst (FStar_List_Tot_Base.hd cases))) @@ -604,7 +605,7 @@ let rec (get_apply_tuple : (fun uu___7 -> (fun uu___7 -> let uu___8 = - FStar_Tactics_V2_Builtins.intro + FStarC_Tactics_V2_Builtins.intro () in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -630,7 +631,7 @@ let rec (get_apply_tuple : (fun b11 -> let uu___9 = - FStar_Tactics_V2_Builtins.intro + FStarC_Tactics_V2_Builtins.intro () in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -659,7 +660,7 @@ let rec (get_apply_tuple : -> let uu___10 = - FStar_Tactics_V2_Builtins.intro + FStarC_Tactics_V2_Builtins.intro () in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -725,8 +726,8 @@ let rec (get_apply_tuple : else (let uu___6 = let uu___7 = - FStar_Tactics_V2_Builtins.term_to_string - b.FStar_Reflection_V2_Data.sort3 in + FStarC_Tactics_V2_Builtins.term_to_string + b.FStarC_Reflection_V2_Data.sort3 in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -777,7 +778,7 @@ let rec (get_apply_tuple : Obj.magic (Obj.repr (if - (FStar_Reflection_V2_Builtins.inspect_fv + (FStarC_Reflection_V2_Builtins.inspect_fv fv) = ["FStar"; @@ -786,7 +787,7 @@ let rec (get_apply_tuple : "tuple2"] then let uu___4 = - FStar_Tactics_V2_Builtins.t_destruct + FStarC_Tactics_V2_Builtins.t_destruct (FStar_Tactics_V2_SyntaxCoercions.binding_to_term b) in FStar_Tactics_Effect.tac_bind @@ -815,7 +816,7 @@ let rec (get_apply_tuple : cases) = Prims.int_one) && - ((FStar_Reflection_V2_Builtins.inspect_fv + ((FStarC_Reflection_V2_Builtins.inspect_fv (FStar_Pervasives_Native.fst (FStar_List_Tot_Base.hd cases))) @@ -851,7 +852,7 @@ let rec (get_apply_tuple : (fun uu___6 -> (fun uu___6 -> let uu___7 = - FStar_Tactics_V2_Builtins.intro + FStarC_Tactics_V2_Builtins.intro () in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -877,7 +878,7 @@ let rec (get_apply_tuple : (fun b11 -> let uu___8 = - FStar_Tactics_V2_Builtins.intro + FStarC_Tactics_V2_Builtins.intro () in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -905,7 +906,7 @@ let rec (get_apply_tuple : -> let uu___9 = - FStar_Tactics_V2_Builtins.intro + FStarC_Tactics_V2_Builtins.intro () in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -971,8 +972,8 @@ let rec (get_apply_tuple : else (let uu___5 = let uu___6 = - FStar_Tactics_V2_Builtins.term_to_string - b.FStar_Reflection_V2_Data.sort3 in + FStarC_Tactics_V2_Builtins.term_to_string + b.FStarC_Reflection_V2_Data.sort3 in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1022,7 +1023,7 @@ let rec (get_apply_tuple : Obj.magic (Obj.repr (if - (FStar_Reflection_V2_Builtins.inspect_fv + (FStarC_Reflection_V2_Builtins.inspect_fv fv) = ["Prims"; "unit"] then @@ -1033,8 +1034,8 @@ let rec (get_apply_tuple : Obj.repr (let uu___5 = let uu___6 = - FStar_Tactics_V2_Builtins.term_to_string - b.FStar_Reflection_V2_Data.sort3 in + FStarC_Tactics_V2_Builtins.term_to_string + b.FStarC_Reflection_V2_Data.sort3 in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1085,8 +1086,8 @@ let rec (get_apply_tuple : (Obj.repr (let uu___5 = let uu___6 = - FStar_Tactics_V2_Builtins.term_to_string - b.FStar_Reflection_V2_Data.sort3 in + FStarC_Tactics_V2_Builtins.term_to_string + b.FStarC_Reflection_V2_Data.sort3 in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1133,7 +1134,7 @@ let rec (get_apply_tuple : FStar_Tactics_V2_Derived.fail uu___6)))) uu___3))) uu___1) let rec (generate_up_aux : - FStar_Reflection_V2_Data.ctor Prims.list -> + FStarC_Reflection_V2_Data.ctor Prims.list -> FStar_Tactics_NamedView.binding -> (unit, unit) FStar_Tactics_Effect.tac_repr) = @@ -1143,9 +1144,9 @@ let rec (generate_up_aux : | [] -> let uu___ = FStar_Tactics_V2_Derived.apply - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "TypeRepr"; "empty_elim"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1167,7 +1168,7 @@ let rec (generate_up_aux : uu___1) | c::cs -> let uu___ = - FStar_Tactics_V2_Builtins.t_destruct + FStarC_Tactics_V2_Builtins.t_destruct (FStar_Tactics_V2_SyntaxCoercions.binding_to_term b) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1215,7 +1216,7 @@ let rec (generate_up_aux : FStar_Tactics_V2_Derived.focus (fun uu___4 -> let uu___5 = - FStar_Tactics_V2_Builtins.intro () in + FStarC_Tactics_V2_Builtins.intro () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1237,7 +1238,7 @@ let rec (generate_up_aux : (fun uu___6 -> (fun b' -> let uu___6 = - FStar_Tactics_V2_Builtins.intro + FStarC_Tactics_V2_Builtins.intro () in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1321,7 +1322,7 @@ let rec (generate_up_aux : FStar_Tactics_V2_Derived.apply (FStar_Tactics_NamedView.pack (FStar_Tactics_NamedView.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_fv c_name))) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1413,7 +1414,7 @@ let rec (generate_up_aux : (fun uu___4 -> (fun uu___4 -> let uu___5 = - FStar_Tactics_V2_Builtins.intro () in + FStarC_Tactics_V2_Builtins.intro () in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1436,7 +1437,7 @@ let rec (generate_up_aux : (fun uu___6 -> (fun b1 -> let uu___6 = - FStar_Tactics_V2_Builtins.intro + FStarC_Tactics_V2_Builtins.intro () in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1491,7 +1492,7 @@ let (generate_up : FStar_Tactics_NamedView.typ = uu___6; FStar_Tactics_NamedView.ctors = ctors;_} -> - let uu___7 = FStar_Tactics_V2_Builtins.intro () in + let uu___7 = FStarC_Tactics_V2_Builtins.intro () in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1511,25 +1512,25 @@ let (generate_up : (fun b -> Obj.magic (generate_up_aux ctors b)) uu___8))) uu___2) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.TypeRepr.generate_up" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.TypeRepr.generate_up" (Prims.of_int (3)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_2 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_2 "FStar.Tactics.TypeRepr.generate_up (plugin)" - (FStar_Tactics_Native.from_tactic_2 generate_up) - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_unit FStar_Syntax_Embeddings.e_unit - psc ncb us args) + (FStarC_Tactics_Native.from_tactic_2 generate_up) + FStarC_Syntax_Embeddings.e_string + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (make_implicits : FStar_Tactics_NamedView.binders -> FStar_Tactics_NamedView.binders) = fun bs -> FStar_List_Tot_Base.map (fun b -> match b.FStar_Tactics_NamedView.qual with - | FStar_Reflection_V2_Data.Q_Explicit -> + | FStarC_Reflection_V2_Data.Q_Explicit -> { FStar_Tactics_NamedView.uniq = (b.FStar_Tactics_NamedView.uniq); @@ -1538,21 +1539,21 @@ let (make_implicits : FStar_Tactics_NamedView.sort = (b.FStar_Tactics_NamedView.sort); FStar_Tactics_NamedView.qual = - FStar_Reflection_V2_Data.Q_Implicit; + FStarC_Reflection_V2_Data.Q_Implicit; FStar_Tactics_NamedView.attrs = (b.FStar_Tactics_NamedView.attrs) } | uu___ -> b) bs let (binder_to_argv : - FStar_Tactics_NamedView.binder -> FStar_Reflection_V2_Data.argv) = + FStar_Tactics_NamedView.binder -> FStarC_Reflection_V2_Data.argv) = fun b -> ((FStar_Tactics_V2_SyntaxCoercions.binder_to_term b), (b.FStar_Tactics_NamedView.qual)) let (generate_all : - FStar_Reflection_Types.name -> + FStarC_Reflection_Types.name -> FStar_Tactics_NamedView.binders -> - FStar_Reflection_V2_Data.ctor Prims.list -> - (FStar_Reflection_Types.decls, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_V2_Data.ctor Prims.list -> + (FStarC_Reflection_Types.decls, unit) FStar_Tactics_Effect.tac_repr) = fun nm -> fun params -> @@ -1582,7 +1583,7 @@ let (generate_all : FStar_Reflection_V2_Derived.mk_app (FStar_Tactics_NamedView.pack (FStar_Tactics_NamedView.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv nm))) + (FStarC_Reflection_V2_Builtins.pack_fv nm))) (FStar_List_Tot_Base.map binder_to_argv params))) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1629,11 +1630,11 @@ let (generate_all : let uu___8 = FStar_Tactics_V2_SyntaxHelpers.mk_arr params - (FStar_Reflection_V2_Data.C_Total - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Type - (FStar_Reflection_V2_Builtins.pack_universe - FStar_Reflection_V2_Data.Uv_Unk)))) in + (FStarC_Reflection_V2_Data.C_Total + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Type + (FStarC_Reflection_V2_Builtins.pack_universe + FStarC_Reflection_V2_Data.Uv_Unk)))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1685,7 +1686,7 @@ let (generate_all : { FStar_Tactics_NamedView.lb_fv = - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_fv (add_suffix "_repr" nm)); @@ -1816,48 +1817,48 @@ let (generate_all : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___5 -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln ( - FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Effect"; "synth_by_tactic"]))), - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Abs - ((FStar_Reflection_V2_Builtins.pack_binder + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Abs + ((FStarC_Reflection_V2_Builtins.pack_binder { - FStar_Reflection_V2_Data.sort2 + FStarC_Reflection_V2_Data.sort2 = - (FStar_Reflection_V2_Builtins.pack_ln - FStar_Reflection_V2_Data.Tv_Unknown); - FStar_Reflection_V2_Data.qual + (FStarC_Reflection_V2_Builtins.pack_ln + FStarC_Reflection_V2_Data.Tv_Unknown); + FStarC_Reflection_V2_Data.qual = - FStar_Reflection_V2_Data.Q_Explicit; - FStar_Reflection_V2_Data.attrs + FStarC_Reflection_V2_Data.Q_Explicit; + FStarC_Reflection_V2_Data.attrs = []; - FStar_Reflection_V2_Data.ppname2 + FStarC_Reflection_V2_Data.ppname2 = (FStar_Sealed.seal "uu___") }), - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "TypeRepr"; "generate_down"]))), - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const - FStar_Reflection_V2_Data.C_Unit)), - FStar_Reflection_V2_Data.Q_Explicit))))))), - FStar_Reflection_V2_Data.Q_Explicit))))) in + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const + FStarC_Reflection_V2_Data.C_Unit)), + FStarC_Reflection_V2_Data.Q_Explicit))))))), + FStarC_Reflection_V2_Data.Q_Explicit))))) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1953,7 +1954,7 @@ let (generate_all : (FStar_Tactics_NamedView.pack (FStar_Tactics_NamedView.Tv_Arrow (b, - (FStar_Reflection_V2_Data.C_Total + (FStarC_Reflection_V2_Data.C_Total t_repr)))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1984,7 +1985,7 @@ let (generate_all : { FStar_Tactics_NamedView.lb_fv = - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_fv (add_suffix "_down" nm)); @@ -2143,55 +2144,55 @@ let (generate_all : (FStar_Tactics_Effect.lift_div_tac (fun uu___8 -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Effect"; "synth_by_tactic"]))), - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Abs - ((FStar_Reflection_V2_Builtins.pack_binder + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Abs + ((FStarC_Reflection_V2_Builtins.pack_binder { - FStar_Reflection_V2_Data.sort2 + FStarC_Reflection_V2_Data.sort2 = - (FStar_Reflection_V2_Builtins.pack_ln - FStar_Reflection_V2_Data.Tv_Unknown); - FStar_Reflection_V2_Data.qual + (FStarC_Reflection_V2_Builtins.pack_ln + FStarC_Reflection_V2_Data.Tv_Unknown); + FStarC_Reflection_V2_Data.qual = - FStar_Reflection_V2_Data.Q_Explicit; - FStar_Reflection_V2_Data.attrs + FStarC_Reflection_V2_Data.Q_Explicit; + FStarC_Reflection_V2_Data.attrs = []; - FStar_Reflection_V2_Data.ppname2 + FStarC_Reflection_V2_Data.ppname2 = (FStar_Sealed.seal "uu___") }), - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "TypeRepr"; "generate_up"]))), ((FStar_Tactics_NamedView.pack (FStar_Tactics_NamedView.Tv_Const - (FStar_Reflection_V2_Data.C_String - (FStar_Reflection_V2_Builtins.implode_qn + (FStarC_Reflection_V2_Data.C_String + (FStarC_Reflection_V2_Builtins.implode_qn nm)))), - FStar_Reflection_V2_Data.Q_Explicit)))), - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const - FStar_Reflection_V2_Data.C_Unit)), - FStar_Reflection_V2_Data.Q_Explicit))))))), - FStar_Reflection_V2_Data.Q_Explicit))))) in + FStarC_Reflection_V2_Data.Q_Explicit)))), + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const + FStarC_Reflection_V2_Data.C_Unit)), + FStarC_Reflection_V2_Data.Q_Explicit))))))), + FStarC_Reflection_V2_Data.Q_Explicit))))) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -2290,7 +2291,7 @@ let (generate_all : (FStar_Tactics_NamedView.pack (FStar_Tactics_NamedView.Tv_Arrow (b, - (FStar_Reflection_V2_Data.C_Total + (FStarC_Reflection_V2_Data.C_Total t)))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -2321,7 +2322,7 @@ let (generate_all : { FStar_Tactics_NamedView.lb_fv = - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_fv (add_suffix "_up" nm)); FStar_Tactics_NamedView.lb_us @@ -2486,7 +2487,7 @@ let (generate_all : uu___3))) uu___2))) uu___1) let (entry : Prims.string -> - (FStar_Reflection_Types.decls, unit) FStar_Tactics_Effect.tac_repr) + (FStarC_Reflection_Types.decls, unit) FStar_Tactics_Effect.tac_repr) = fun nm -> let uu___ = get_inductive_typ nm in @@ -2512,15 +2513,15 @@ let (entry : FStar_Tactics_NamedView.ctors = ctors;_} -> Obj.magic (generate_all nm1 params ctors)) uu___1) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.TypeRepr.entry" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.TypeRepr.entry" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.TypeRepr.entry (plugin)" - (FStar_Tactics_Native.from_tactic_1 entry) - FStar_Syntax_Embeddings.e_string - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_sigelt) psc ncb us args) \ No newline at end of file + (FStarC_Tactics_Native.from_tactic_1 entry) + FStarC_Syntax_Embeddings.e_string + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_sigelt) psc ncb us args) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_Typeclasses.ml b/ocaml/fstar-lib/generated/FStar_Tactics_Typeclasses.ml index 68e6c04ba39..20df793a40a 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_Typeclasses.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_Typeclasses.ml @@ -4,7 +4,7 @@ let (debug : (unit, unit) FStar_Tactics_Effect.tac_repr) = fun f -> - let uu___ = FStar_Tactics_V2_Builtins.debugging () in + let uu___ = FStarC_Tactics_V2_Builtins.debugging () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -40,7 +40,7 @@ let (debug : (fun uu___3 -> (fun uu___3 -> Obj.magic - (FStar_Tactics_V2_Builtins.print uu___3)) + (FStarC_Tactics_V2_Builtins.print uu___3)) uu___3))) else Obj.magic @@ -54,35 +54,36 @@ let op_At : type st_t = { seen: FStar_Tactics_NamedView.term Prims.list ; - glb: (FStar_Reflection_Types.sigelt * FStar_Reflection_Types.fv) Prims.list ; + glb: + (FStarC_Reflection_Types.sigelt * FStarC_Reflection_Types.fv) Prims.list ; fuel: Prims.int } let (__proj__Mkst_t__item__seen : st_t -> FStar_Tactics_NamedView.term Prims.list) = fun projectee -> match projectee with | { seen; glb; fuel;_} -> seen let (__proj__Mkst_t__item__glb : st_t -> - (FStar_Reflection_Types.sigelt * FStar_Reflection_Types.fv) Prims.list) + (FStarC_Reflection_Types.sigelt * FStarC_Reflection_Types.fv) Prims.list) = fun projectee -> match projectee with | { seen; glb; fuel;_} -> glb let (__proj__Mkst_t__item__fuel : st_t -> Prims.int) = fun projectee -> match projectee with | { seen; glb; fuel;_} -> fuel type tc_goal = { g: FStar_Tactics_NamedView.term ; - head_fv: FStar_Reflection_Types.fv ; - c_se: FStar_Reflection_Types.sigelt FStar_Pervasives_Native.option ; + head_fv: FStarC_Reflection_Types.fv ; + c_se: FStarC_Reflection_Types.sigelt FStar_Pervasives_Native.option ; fundeps: Prims.int Prims.list FStar_Pervasives_Native.option ; - args_and_uvars: (FStar_Reflection_V2_Data.argv * Prims.bool) Prims.list } + args_and_uvars: (FStarC_Reflection_V2_Data.argv * Prims.bool) Prims.list } let (__proj__Mktc_goal__item__g : tc_goal -> FStar_Tactics_NamedView.term) = fun projectee -> match projectee with | { g; head_fv; c_se; fundeps; args_and_uvars;_} -> g -let (__proj__Mktc_goal__item__head_fv : tc_goal -> FStar_Reflection_Types.fv) - = +let (__proj__Mktc_goal__item__head_fv : + tc_goal -> FStarC_Reflection_Types.fv) = fun projectee -> match projectee with | { g; head_fv; c_se; fundeps; args_and_uvars;_} -> head_fv let (__proj__Mktc_goal__item__c_se : - tc_goal -> FStar_Reflection_Types.sigelt FStar_Pervasives_Native.option) = + tc_goal -> FStarC_Reflection_Types.sigelt FStar_Pervasives_Native.option) = fun projectee -> match projectee with | { g; head_fv; c_se; fundeps; args_and_uvars;_} -> c_se @@ -92,19 +93,19 @@ let (__proj__Mktc_goal__item__fundeps : match projectee with | { g; head_fv; c_se; fundeps; args_and_uvars;_} -> fundeps let (__proj__Mktc_goal__item__args_and_uvars : - tc_goal -> (FStar_Reflection_V2_Data.argv * Prims.bool) Prims.list) = + tc_goal -> (FStarC_Reflection_V2_Data.argv * Prims.bool) Prims.list) = fun projectee -> match projectee with | { g; head_fv; c_se; fundeps; args_and_uvars;_} -> args_and_uvars let (fv_eq : - FStar_Reflection_Types.fv -> FStar_Reflection_Types.fv -> Prims.bool) = + FStarC_Reflection_Types.fv -> FStarC_Reflection_Types.fv -> Prims.bool) = fun fv1 -> fun fv2 -> - let n1 = FStar_Reflection_V2_Builtins.inspect_fv fv1 in - let n2 = FStar_Reflection_V2_Builtins.inspect_fv fv2 in n1 = n2 + let n1 = FStarC_Reflection_V2_Builtins.inspect_fv fv1 in + let n2 = FStarC_Reflection_V2_Builtins.inspect_fv fv2 in n1 = n2 let rec (head_of : FStar_Tactics_NamedView.term -> - (FStar_Reflection_Types.fv FStar_Pervasives_Native.option, unit) + (FStarC_Reflection_Types.fv FStar_Pervasives_Native.option, unit) FStar_Tactics_Effect.tac_repr) = fun t -> @@ -165,7 +166,7 @@ let rec (res_typ : Obj.magic (Obj.repr (match FStar_Tactics_NamedView.inspect_comp c with - | FStar_Reflection_V2_Data.C_Total t1 -> + | FStarC_Reflection_V2_Data.C_Total t1 -> Obj.repr (res_typ t1) | uu___3 -> Obj.repr @@ -233,7 +234,7 @@ let rec (maybe_intros : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (Obj.repr (let uu___6 = let uu___7 = - FStar_Tactics_V2_Builtins.intro () in + FStarC_Tactics_V2_Builtins.intro () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -282,16 +283,16 @@ let rec (maybe_intros : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (FStar_Tactics_Effect.lift_div_tac (fun uu___5 -> ())))) uu___3))) uu___2) let (sigelt_name : - FStar_Reflection_Types.sigelt -> FStar_Reflection_Types.fv Prims.list) = + FStarC_Reflection_Types.sigelt -> FStarC_Reflection_Types.fv Prims.list) = fun se -> - match FStar_Reflection_V2_Builtins.inspect_sigelt se with - | FStar_Reflection_V2_Data.Sg_Let (uu___, lbs) -> + match FStarC_Reflection_V2_Builtins.inspect_sigelt se with + | FStarC_Reflection_V2_Data.Sg_Let (uu___, lbs) -> (match lbs with | lb::[] -> - [(FStar_Reflection_V2_Builtins.inspect_lb lb).FStar_Reflection_V2_Data.lb_fv] + [(FStarC_Reflection_V2_Builtins.inspect_lb lb).FStarC_Reflection_V2_Data.lb_fv] | uu___1 -> []) - | FStar_Reflection_V2_Data.Sg_Val (nm, uu___, uu___1) -> - [FStar_Reflection_V2_Builtins.pack_fv nm] + | FStarC_Reflection_V2_Data.Sg_Val (nm, uu___, uu___1) -> + [FStarC_Reflection_V2_Builtins.pack_fv nm] | uu___ -> [] let (unembed_int : FStar_Tactics_NamedView.term -> @@ -303,9 +304,9 @@ let (unembed_int : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> - match FStar_Reflection_V2_Builtins.inspect_ln t with - | FStar_Reflection_V2_Data.Tv_Const - (FStar_Reflection_V2_Data.C_Int i) -> + match FStarC_Reflection_V2_Builtins.inspect_ln t with + | FStarC_Reflection_V2_Data.Tv_Const + (FStarC_Reflection_V2_Data.C_Int i) -> FStar_Pervasives_Native.Some i | uu___1 -> FStar_Pervasives_Native.None))) uu___ let rec unembed_list : @@ -337,15 +338,15 @@ let rec unembed_list : match uu___1 with | FStar_Pervasives_Native.Some (fv, uu___2, - (ty, FStar_Reflection_V2_Data.Q_Implicit)::(hd, - FStar_Reflection_V2_Data.Q_Explicit):: - (tl, FStar_Reflection_V2_Data.Q_Explicit)::[]) + (ty, FStarC_Reflection_V2_Data.Q_Implicit)::(hd, + FStarC_Reflection_V2_Data.Q_Explicit):: + (tl, FStarC_Reflection_V2_Data.Q_Explicit)::[]) -> Obj.magic (Obj.repr (if - (FStar_Reflection_V2_Builtins.implode_qn - (FStar_Reflection_V2_Builtins.inspect_fv fv)) + (FStarC_Reflection_V2_Builtins.implode_qn + (FStarC_Reflection_V2_Builtins.inspect_fv fv)) = "Prims.Cons" then Obj.repr @@ -430,15 +431,17 @@ let rec unembed_list : (FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> FStar_Pervasives_Native.None)))) | FStar_Pervasives_Native.Some - (fv, uu___2, (ty, FStar_Reflection_V2_Data.Q_Implicit)::[]) + (fv, uu___2, + (ty, FStarC_Reflection_V2_Data.Q_Implicit)::[]) -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> if - (FStar_Reflection_V2_Builtins.implode_qn - (FStar_Reflection_V2_Builtins.inspect_fv fv)) + (FStarC_Reflection_V2_Builtins.implode_qn + (FStarC_Reflection_V2_Builtins.inspect_fv + fv)) = "Prims.Nil" then FStar_Pervasives_Native.Some [] else FStar_Pervasives_Native.None))) @@ -449,7 +452,7 @@ let rec unembed_list : (fun uu___3 -> FStar_Pervasives_Native.None)))) uu___1) let (extract_fundeps : - FStar_Reflection_Types.sigelt -> + FStarC_Reflection_Types.sigelt -> (Prims.int Prims.list FStar_Pervasives_Native.option, unit) FStar_Tactics_Effect.tac_repr) = @@ -457,7 +460,7 @@ let (extract_fundeps : let uu___ = Obj.magic (FStar_Tactics_Effect.lift_div_tac - (fun uu___1 -> FStar_Reflection_V2_Builtins.sigelt_attrs se)) in + (fun uu___1 -> FStarC_Reflection_V2_Builtins.sigelt_attrs se)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -506,14 +509,14 @@ let (extract_fundeps : match uu___2 with | (hd, (a0, - FStar_Reflection_V2_Data.Q_Explicit)::[]) + FStarC_Reflection_V2_Data.Q_Explicit)::[]) -> if FStar_Reflection_TermEq_Simple.term_eq hd - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Typeclasses"; @@ -622,7 +625,7 @@ let (trywith : (fun uu___4 -> let uu___5 = let uu___6 = - FStar_Tactics_V2_Builtins.term_to_string + FStarC_Tactics_V2_Builtins.term_to_string t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -646,7 +649,7 @@ let (trywith : (fun uu___7 -> let uu___8 = let uu___9 = - FStar_Tactics_V2_Builtins.term_to_string + FStarC_Tactics_V2_Builtins.term_to_string typ in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -780,7 +783,7 @@ let (trywith : debug (fun uu___6 -> let uu___7 = - FStar_Tactics_V2_Builtins.term_to_string + FStarC_Tactics_V2_Builtins.term_to_string t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -998,7 +1001,7 @@ let (trywith : uu___9 -> let uu___10 = - FStar_Tactics_V2_Builtins.dump + FStarC_Tactics_V2_Builtins.dump "next" in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1111,7 +1114,7 @@ let (local : let uu___1 = debug (fun uu___2 -> - let uu___3 = FStar_Tactics_V2_Builtins.term_to_string g.g in + let uu___3 = FStarC_Tactics_V2_Builtins.term_to_string g.g in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1161,7 +1164,8 @@ let (local : (fun uu___5 -> FStar_Tactics_Effect.lift_div_tac (fun uu___6 -> - FStar_Reflection_V2_Builtins.vars_of_env uu___5)) in + FStarC_Reflection_V2_Builtins.vars_of_env + uu___5)) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1187,8 +1191,8 @@ let (local : (FStar_Tactics_NamedView.Tv_Var (FStar_Tactics_V2_SyntaxCoercions.binding_to_namedv b))) - b.FStar_Reflection_V2_Data.sort3 k) bs)) - uu___4))) uu___2) + b.FStarC_Reflection_V2_Data.sort3 k) + bs)) uu___4))) uu___2) let (global : st_t -> tc_goal -> @@ -1202,7 +1206,7 @@ let (global : let uu___1 = debug (fun uu___2 -> - let uu___3 = FStar_Tactics_V2_Builtins.term_to_string g.g in + let uu___3 = FStarC_Tactics_V2_Builtins.term_to_string g.g in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1262,7 +1266,7 @@ let (global : (fun uu___6 -> (fun uu___6 -> Obj.magic - (FStar_Tactics_V2_Builtins.tc + (FStarC_Tactics_V2_Builtins.tc uu___6 (FStar_Tactics_NamedView.pack (FStar_Tactics_NamedView.Tv_FVar @@ -1326,15 +1330,15 @@ let (try_trivial : Obj.magic (Obj.repr (if - (FStar_Reflection_V2_Builtins.implode_qn - (FStar_Reflection_V2_Builtins.inspect_fv fv)) + (FStarC_Reflection_V2_Builtins.implode_qn + (FStarC_Reflection_V2_Builtins.inspect_fv fv)) = "Prims.unit" then Obj.repr (FStar_Tactics_V2_Derived.exact - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const - FStar_Reflection_V2_Data.C_Unit))) + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const + FStarC_Reflection_V2_Data.C_Unit))) else Obj.repr (FStar_Tactics_Effect.raise Next))) | uu___3 -> Obj.magic (Obj.repr (FStar_Tactics_Effect.raise Next))) @@ -1608,9 +1612,9 @@ let rec (tcresolve' : st_t -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___14 -> - FStar_Reflection_V2_Builtins.lookup_typ + FStarC_Reflection_V2_Builtins.lookup_typ uu___13 - (FStar_Reflection_V2_Builtins.inspect_fv + (FStarC_Reflection_V2_Builtins.inspect_fv head_fv))) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1698,7 +1702,7 @@ let rec (tcresolve' : st_t -> (unit, unit) FStar_Tactics_Effect.tac_repr) = = let uu___16 = - FStar_Tactics_V2_Builtins.free_uvars + FStarC_Tactics_V2_Builtins.free_uvars a in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1889,7 +1893,7 @@ let (tcresolve : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = let uu___1 = debug (fun uu___2 -> - let uu___3 = FStar_Tactics_V2_Builtins.dump "" in + let uu___3 = FStarC_Tactics_V2_Builtins.dump "" in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1918,7 +1922,7 @@ let (tcresolve : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (Prims.of_int (18))))) (Obj.magic uu___1) (fun uu___2 -> (fun uu___2 -> - let uu___3 = FStar_Tactics_V2_Builtins.norm [] in + let uu___3 = FStarC_Tactics_V2_Builtins.norm [] in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1953,7 +1957,7 @@ let (tcresolve : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___6 -> (fun w -> let uu___6 = - FStar_Tactics_V2_Builtins.set_dump_on_failure + FStarC_Tactics_V2_Builtins.set_dump_on_failure false in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -2025,10 +2029,10 @@ let (tcresolve : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = FStar_Tactics_Effect.lift_div_tac (fun uu___13 -> - FStar_Reflection_V2_Builtins.lookup_attr_ses - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.lookup_attr_ses + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Typeclasses"; @@ -2186,7 +2190,7 @@ let (tcresolve : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = -> let uu___17 = - FStar_Tactics_V2_Builtins.term_to_string + FStarC_Tactics_V2_Builtins.term_to_string w in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -2268,7 +2272,7 @@ let (tcresolve : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = uu___19 -> Obj.magic - (FStar_Tactics_V2_Builtins.term_to_doc + (FStarC_Tactics_V2_Builtins.term_to_doc uu___19)) uu___19) in FStar_Tactics_Effect.tac_bind @@ -2297,7 +2301,7 @@ let (tcresolve : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___19 -> - FStar_Pprint.bquotes + FStarC_Pprint.bquotes uu___18)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -2325,10 +2329,10 @@ let (tcresolve : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___18 -> - FStar_Pprint.prefix + FStarC_Pprint.prefix (Prims.of_int (2)) Prims.int_one - (FStar_Pprint.arbitrary_string + (FStarC_Pprint.arbitrary_string "Could not solve typeclass constraint") uu___17)) in FStar_Tactics_Effect.tac_bind @@ -2383,7 +2387,7 @@ let (tcresolve : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = FStar_Tactics_V2_Derived.fail_doc uu___15))) | - FStar_Tactics_Common.TacticFailure + FStarC_Tactics_Common.TacticFailure (msg, r) -> Obj.magic @@ -2392,7 +2396,7 @@ let (tcresolve : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = ((op_At ()) [ - FStar_Pprint.arbitrary_string + FStarC_Pprint.arbitrary_string "Typeclass resolution failed."] msg) r)) | @@ -2408,17 +2412,17 @@ let (tcresolve : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = uu___9))) uu___7))) uu___6))) uu___4))) uu___2) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.Typeclasses.tcresolve" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.Typeclasses.tcresolve" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.Typeclasses.tcresolve (plugin)" - (FStar_Tactics_Native.from_tactic_1 tcresolve) - FStar_Syntax_Embeddings.e_unit FStar_Syntax_Embeddings.e_unit - psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 tcresolve) + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let rec (mk_abs : FStar_Tactics_NamedView.binder Prims.list -> FStar_Tactics_NamedView.term -> @@ -2491,9 +2495,9 @@ let (filter_no_method_binders : let has_no_method_attr b = FStar_List_Tot_Base.existsb (FStar_Reflection_TermEq_Simple.term_eq - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Typeclasses"; "no_method"])))) b.FStar_Tactics_NamedView.attrs in FStar_List_Tot_Base.filter @@ -2508,18 +2512,18 @@ let (binder_set_meta : FStar_Tactics_NamedView.uniq = (b.FStar_Tactics_NamedView.uniq); FStar_Tactics_NamedView.ppname = (b.FStar_Tactics_NamedView.ppname); FStar_Tactics_NamedView.sort = (b.FStar_Tactics_NamedView.sort); - FStar_Tactics_NamedView.qual = (FStar_Reflection_V2_Data.Q_Meta t); + FStar_Tactics_NamedView.qual = (FStarC_Reflection_V2_Data.Q_Meta t); FStar_Tactics_NamedView.attrs = (b.FStar_Tactics_NamedView.attrs) } let (mk_class : Prims.string -> - (FStar_Reflection_Types.decls, unit) FStar_Tactics_Effect.tac_repr) + (FStarC_Reflection_Types.decls, unit) FStar_Tactics_Effect.tac_repr) = fun nm -> let uu___ = Obj.magic (FStar_Tactics_Effect.lift_div_tac - (fun uu___1 -> FStar_Reflection_V2_Builtins.explode_qn nm)) in + (fun uu___1 -> FStarC_Reflection_V2_Builtins.explode_qn nm)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2534,7 +2538,7 @@ let (mk_class : (fun uu___1 -> (fun ns -> let uu___1 = - let uu___2 = FStar_Tactics_V2_Builtins.top_env () in + let uu___2 = FStarC_Tactics_V2_Builtins.top_env () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2550,7 +2554,7 @@ let (mk_class : (fun uu___3 -> FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> - FStar_Reflection_V2_Builtins.lookup_typ uu___3 ns)) in + FStarC_Reflection_V2_Builtins.lookup_typ uu___3 ns)) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -2622,13 +2626,13 @@ let (mk_class : (fun uu___8 -> match uu___8 with - | FStar_Reflection_V2_Data.Inline_for_extraction + | FStarC_Reflection_V2_Data.Inline_for_extraction -> true - | FStar_Reflection_V2_Data.NoExtract + | FStarC_Reflection_V2_Data.NoExtract -> true | uu___9 -> false) - (FStar_Reflection_V2_Builtins.sigelt_quals + (FStarC_Reflection_V2_Builtins.sigelt_quals se))) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -2840,7 +2844,7 @@ let (mk_class : -> Prims.strcat "got it, name = " - (FStar_Reflection_V2_Builtins.implode_qn + (FStarC_Reflection_V2_Builtins.implode_qn name)))) uu___15) in Obj.magic @@ -2877,7 +2881,7 @@ let (mk_class : -> let uu___18 = - FStar_Tactics_V2_Builtins.term_to_string + FStarC_Tactics_V2_Builtins.term_to_string ity in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -3046,7 +3050,7 @@ let (mk_class : = let uu___27 = - FStar_Tactics_V2_Builtins.term_to_string + FStarC_Tactics_V2_Builtins.term_to_string ty in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -3104,7 +3108,7 @@ let (mk_class : uu___28 -> Prims.strcat - (FStar_Reflection_V2_Builtins.implode_qn + (FStarC_Reflection_V2_Builtins.implode_qn c_name) uu___27)) in FStar_Tactics_Effect.tac_bind @@ -3234,7 +3238,7 @@ let (mk_class : let uu___28 = FStar_Tactics_V2_Derived.guard - (FStar_Reflection_V2_Data.uu___is_C_Total + (FStarC_Reflection_V2_Data.uu___is_C_Total r1) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -3298,7 +3302,7 @@ let (mk_class : match uu___31 with | - FStar_Reflection_V2_Data.C_Total + FStarC_Reflection_V2_Data.C_Total cod1 -> let uu___32 = @@ -3466,7 +3470,7 @@ let (mk_class : -> let uu___40 = - FStar_Tactics_V2_Builtins.term_to_string + FStarC_Tactics_V2_Builtins.term_to_string cod1 in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -3670,7 +3674,7 @@ let (mk_class : (fun uu___46 -> - FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_fv ((op_At ()) ns1 [s]))) in @@ -3735,9 +3739,9 @@ let (mk_class : (fun uu___48 -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "Typeclasses"; @@ -3771,7 +3775,7 @@ let (mk_class : = let uu___49 = - FStar_Tactics_V2_Builtins.fresh + FStarC_Tactics_V2_Builtins.fresh () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -3810,7 +3814,7 @@ let (mk_class : = cod1; FStar_Tactics_NamedView.qual = - (FStar_Reflection_V2_Data.Q_Meta + (FStarC_Reflection_V2_Data.Q_Meta tcr); FStar_Tactics_NamedView.attrs = [] @@ -3912,7 +3916,7 @@ let (mk_class : -> FStar_Tactics_NamedView.pack (FStar_Tactics_NamedView.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_fv proj_name)))) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -3945,7 +3949,7 @@ let (mk_class : = let uu___53 = - FStar_Tactics_V2_Builtins.top_env + FStarC_Tactics_V2_Builtins.top_env () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -3973,7 +3977,7 @@ let (mk_class : (fun uu___55 -> - FStar_Reflection_V2_Builtins.lookup_typ + FStarC_Reflection_V2_Builtins.lookup_typ uu___54 proj_name)) in FStar_Tactics_Effect.tac_bind @@ -4102,7 +4106,7 @@ let (mk_class : -> let uu___54 = - FStar_Tactics_V2_Builtins.term_to_string + FStarC_Tactics_V2_Builtins.term_to_string proj_lb.FStar_Tactics_NamedView.lb_typ in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -4485,7 +4489,7 @@ let (mk_class : -> let uu___58 = - FStar_Tactics_V2_Builtins.term_to_string + FStarC_Tactics_V2_Builtins.term_to_string def in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -4550,7 +4554,7 @@ let (mk_class : -> let uu___60 = - FStar_Tactics_V2_Builtins.term_to_string + FStarC_Tactics_V2_Builtins.term_to_string ty1 in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -4782,9 +4786,9 @@ let (mk_class : (fun uu___65 -> - FStar_Reflection_V2_Builtins.set_sigelt_attrs + FStarC_Reflection_V2_Builtins.set_sigelt_attrs b.FStar_Tactics_NamedView.attrs - (FStar_Reflection_V2_Builtins.set_sigelt_quals + (FStarC_Reflection_V2_Builtins.set_sigelt_quals to_propagate se1))))) uu___64))) @@ -4830,16 +4834,16 @@ let (mk_class : uu___7))) uu___5))) uu___3))) uu___2))) uu___1) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.Typeclasses.mk_class" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.Typeclasses.mk_class" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.Typeclasses.mk_class (plugin)" - (FStar_Tactics_Native.from_tactic_1 mk_class) - FStar_Syntax_Embeddings.e_string - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_sigelt) psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 mk_class) + FStarC_Syntax_Embeddings.e_string + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_sigelt) psc ncb us args) let solve : 'a . 'a -> 'a = fun ev -> ev \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_Types.ml b/ocaml/fstar-lib/generated/FStar_Tactics_Types.ml deleted file mode 100644 index 76359bd9a04..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Tactics_Types.ml +++ /dev/null @@ -1,492 +0,0 @@ -open Prims -type goal = - { - goal_main_env: FStar_TypeChecker_Env.env ; - goal_ctx_uvar: FStar_Syntax_Syntax.ctx_uvar ; - opts: FStar_Options.optionstate ; - is_guard: Prims.bool ; - label: Prims.string } -let (__proj__Mkgoal__item__goal_main_env : goal -> FStar_TypeChecker_Env.env) - = - fun projectee -> - match projectee with - | { goal_main_env; goal_ctx_uvar; opts; is_guard; label;_} -> - goal_main_env -let (__proj__Mkgoal__item__goal_ctx_uvar : - goal -> FStar_Syntax_Syntax.ctx_uvar) = - fun projectee -> - match projectee with - | { goal_main_env; goal_ctx_uvar; opts; is_guard; label;_} -> - goal_ctx_uvar -let (__proj__Mkgoal__item__opts : goal -> FStar_Options.optionstate) = - fun projectee -> - match projectee with - | { goal_main_env; goal_ctx_uvar; opts; is_guard; label;_} -> opts -let (__proj__Mkgoal__item__is_guard : goal -> Prims.bool) = - fun projectee -> - match projectee with - | { goal_main_env; goal_ctx_uvar; opts; is_guard; label;_} -> is_guard -let (__proj__Mkgoal__item__label : goal -> Prims.string) = - fun projectee -> - match projectee with - | { goal_main_env; goal_ctx_uvar; opts; is_guard; label;_} -> label -type guard_policy = - | Goal - | SMT - | SMTSync - | Force - | ForceSMT - | Drop -let (uu___is_Goal : guard_policy -> Prims.bool) = - fun projectee -> match projectee with | Goal -> true | uu___ -> false -let (uu___is_SMT : guard_policy -> Prims.bool) = - fun projectee -> match projectee with | SMT -> true | uu___ -> false -let (uu___is_SMTSync : guard_policy -> Prims.bool) = - fun projectee -> match projectee with | SMTSync -> true | uu___ -> false -let (uu___is_Force : guard_policy -> Prims.bool) = - fun projectee -> match projectee with | Force -> true | uu___ -> false -let (uu___is_ForceSMT : guard_policy -> Prims.bool) = - fun projectee -> match projectee with | ForceSMT -> true | uu___ -> false -let (uu___is_Drop : guard_policy -> Prims.bool) = - fun projectee -> match projectee with | Drop -> true | uu___ -> false -type proofstate = - { - main_context: FStar_TypeChecker_Env.env ; - all_implicits: FStar_TypeChecker_Common.implicits ; - goals: goal Prims.list ; - smt_goals: goal Prims.list ; - depth: Prims.int ; - __dump: proofstate -> Prims.string -> unit ; - psc: FStar_TypeChecker_Primops_Base.psc ; - entry_range: FStar_Compiler_Range_Type.range ; - guard_policy: guard_policy ; - freshness: Prims.int ; - tac_verb_dbg: Prims.bool ; - local_state: FStar_Syntax_Syntax.term FStar_Compiler_Util.psmap ; - urgency: Prims.int ; - dump_on_failure: Prims.bool } -let (__proj__Mkproofstate__item__main_context : - proofstate -> FStar_TypeChecker_Env.env) = - fun projectee -> - match projectee with - | { main_context; all_implicits; goals; smt_goals; depth; __dump; - psc; entry_range; guard_policy = guard_policy1; freshness; - tac_verb_dbg; local_state; urgency; dump_on_failure;_} -> - main_context -let (__proj__Mkproofstate__item__all_implicits : - proofstate -> FStar_TypeChecker_Common.implicits) = - fun projectee -> - match projectee with - | { main_context; all_implicits; goals; smt_goals; depth; __dump; - psc; entry_range; guard_policy = guard_policy1; freshness; - tac_verb_dbg; local_state; urgency; dump_on_failure;_} -> - all_implicits -let (__proj__Mkproofstate__item__goals : proofstate -> goal Prims.list) = - fun projectee -> - match projectee with - | { main_context; all_implicits; goals; smt_goals; depth; __dump; - psc; entry_range; guard_policy = guard_policy1; freshness; - tac_verb_dbg; local_state; urgency; dump_on_failure;_} -> goals -let (__proj__Mkproofstate__item__smt_goals : proofstate -> goal Prims.list) = - fun projectee -> - match projectee with - | { main_context; all_implicits; goals; smt_goals; depth; __dump; - psc; entry_range; guard_policy = guard_policy1; freshness; - tac_verb_dbg; local_state; urgency; dump_on_failure;_} -> smt_goals -let (__proj__Mkproofstate__item__depth : proofstate -> Prims.int) = - fun projectee -> - match projectee with - | { main_context; all_implicits; goals; smt_goals; depth; __dump; - psc; entry_range; guard_policy = guard_policy1; freshness; - tac_verb_dbg; local_state; urgency; dump_on_failure;_} -> depth -let (__proj__Mkproofstate__item____dump : - proofstate -> proofstate -> Prims.string -> unit) = - fun projectee -> - match projectee with - | { main_context; all_implicits; goals; smt_goals; depth; __dump; - psc; entry_range; guard_policy = guard_policy1; freshness; - tac_verb_dbg; local_state; urgency; dump_on_failure;_} -> __dump -let (__proj__Mkproofstate__item__psc : - proofstate -> FStar_TypeChecker_Primops_Base.psc) = - fun projectee -> - match projectee with - | { main_context; all_implicits; goals; smt_goals; depth; __dump; - psc; entry_range; guard_policy = guard_policy1; freshness; - tac_verb_dbg; local_state; urgency; dump_on_failure;_} -> psc -let (__proj__Mkproofstate__item__entry_range : - proofstate -> FStar_Compiler_Range_Type.range) = - fun projectee -> - match projectee with - | { main_context; all_implicits; goals; smt_goals; depth; __dump; - psc; entry_range; guard_policy = guard_policy1; freshness; - tac_verb_dbg; local_state; urgency; dump_on_failure;_} -> entry_range -let (__proj__Mkproofstate__item__guard_policy : proofstate -> guard_policy) = - fun projectee -> - match projectee with - | { main_context; all_implicits; goals; smt_goals; depth; __dump; - psc; entry_range; guard_policy = guard_policy1; freshness; - tac_verb_dbg; local_state; urgency; dump_on_failure;_} -> - guard_policy1 -let (__proj__Mkproofstate__item__freshness : proofstate -> Prims.int) = - fun projectee -> - match projectee with - | { main_context; all_implicits; goals; smt_goals; depth; __dump; - psc; entry_range; guard_policy = guard_policy1; freshness; - tac_verb_dbg; local_state; urgency; dump_on_failure;_} -> freshness -let (__proj__Mkproofstate__item__tac_verb_dbg : proofstate -> Prims.bool) = - fun projectee -> - match projectee with - | { main_context; all_implicits; goals; smt_goals; depth; __dump; - psc; entry_range; guard_policy = guard_policy1; freshness; - tac_verb_dbg; local_state; urgency; dump_on_failure;_} -> - tac_verb_dbg -let (__proj__Mkproofstate__item__local_state : - proofstate -> FStar_Syntax_Syntax.term FStar_Compiler_Util.psmap) = - fun projectee -> - match projectee with - | { main_context; all_implicits; goals; smt_goals; depth; __dump; - psc; entry_range; guard_policy = guard_policy1; freshness; - tac_verb_dbg; local_state; urgency; dump_on_failure;_} -> local_state -let (__proj__Mkproofstate__item__urgency : proofstate -> Prims.int) = - fun projectee -> - match projectee with - | { main_context; all_implicits; goals; smt_goals; depth; __dump; - psc; entry_range; guard_policy = guard_policy1; freshness; - tac_verb_dbg; local_state; urgency; dump_on_failure;_} -> urgency -let (__proj__Mkproofstate__item__dump_on_failure : proofstate -> Prims.bool) - = - fun projectee -> - match projectee with - | { main_context; all_implicits; goals; smt_goals; depth; __dump; - psc; entry_range; guard_policy = guard_policy1; freshness; - tac_verb_dbg; local_state; urgency; dump_on_failure;_} -> - dump_on_failure -let (goal_env : goal -> FStar_TypeChecker_Env.env) = fun g -> g.goal_main_env -let (goal_range : goal -> FStar_Compiler_Range_Type.range) = - fun g -> (g.goal_main_env).FStar_TypeChecker_Env.range -let (goal_witness : goal -> FStar_Syntax_Syntax.term) = - fun g -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_uvar - ((g.goal_ctx_uvar), ([], FStar_Syntax_Syntax.NoUseRange))) - FStar_Compiler_Range_Type.dummyRange -let (goal_type : goal -> FStar_Syntax_Syntax.term) = - fun g -> FStar_Syntax_Util.ctx_uvar_typ g.goal_ctx_uvar -let (goal_opts : goal -> FStar_Options.optionstate) = fun g -> g.opts -let (goal_with_env : goal -> FStar_TypeChecker_Env.env -> goal) = - fun g -> - fun env -> - let c = g.goal_ctx_uvar in - let c' = - let uu___ = FStar_TypeChecker_Env.all_binders env in - { - FStar_Syntax_Syntax.ctx_uvar_head = - (c.FStar_Syntax_Syntax.ctx_uvar_head); - FStar_Syntax_Syntax.ctx_uvar_gamma = - (env.FStar_TypeChecker_Env.gamma); - FStar_Syntax_Syntax.ctx_uvar_binders = uu___; - FStar_Syntax_Syntax.ctx_uvar_reason = - (c.FStar_Syntax_Syntax.ctx_uvar_reason); - FStar_Syntax_Syntax.ctx_uvar_range = - (c.FStar_Syntax_Syntax.ctx_uvar_range); - FStar_Syntax_Syntax.ctx_uvar_meta = - (c.FStar_Syntax_Syntax.ctx_uvar_meta) - } in - { - goal_main_env = env; - goal_ctx_uvar = c'; - opts = (g.opts); - is_guard = (g.is_guard); - label = (g.label) - } -let (goal_of_ctx_uvar : goal -> FStar_Syntax_Syntax.ctx_uvar -> goal) = - fun g -> - fun ctx_u -> - { - goal_main_env = (g.goal_main_env); - goal_ctx_uvar = ctx_u; - opts = (g.opts); - is_guard = (g.is_guard); - label = (g.label) - } -let (mk_goal : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.ctx_uvar -> - FStar_Options.optionstate -> Prims.bool -> Prims.string -> goal) - = - fun env -> - fun u -> - fun o -> - fun b -> - fun l -> - { - goal_main_env = env; - goal_ctx_uvar = u; - opts = o; - is_guard = b; - label = l - } -let (goal_of_goal_ty : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> (goal * FStar_TypeChecker_Common.guard_t)) - = - fun env -> - fun typ -> - let uu___ = - FStar_TypeChecker_Env.new_implicit_var_aux "proofstate_of_goal_ty" - typ.FStar_Syntax_Syntax.pos env typ FStar_Syntax_Syntax.Strict - FStar_Pervasives_Native.None false in - match uu___ with - | (u, (ctx_uvar, uu___1), g_u) -> - let g = - let uu___2 = FStar_Options.peek () in - mk_goal env ctx_uvar uu___2 false "" in - (g, g_u) -let (goal_of_implicit : - FStar_TypeChecker_Env.env -> FStar_TypeChecker_Common.implicit -> goal) = - fun env -> - fun i -> - let uu___ = FStar_Options.peek () in - mk_goal - { - FStar_TypeChecker_Env.solver = (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - ((i.FStar_TypeChecker_Common.imp_uvar).FStar_Syntax_Syntax.ctx_uvar_gamma); - FStar_TypeChecker_Env.gamma_sig = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = (env.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env.FStar_TypeChecker_Env.missing_decl) - } i.FStar_TypeChecker_Common.imp_uvar uu___ false - i.FStar_TypeChecker_Common.imp_reason -let (decr_depth : proofstate -> proofstate) = - fun ps -> - { - main_context = (ps.main_context); - all_implicits = (ps.all_implicits); - goals = (ps.goals); - smt_goals = (ps.smt_goals); - depth = (ps.depth - Prims.int_one); - __dump = (ps.__dump); - psc = (ps.psc); - entry_range = (ps.entry_range); - guard_policy = (ps.guard_policy); - freshness = (ps.freshness); - tac_verb_dbg = (ps.tac_verb_dbg); - local_state = (ps.local_state); - urgency = (ps.urgency); - dump_on_failure = (ps.dump_on_failure) - } -let (incr_depth : proofstate -> proofstate) = - fun ps -> - { - main_context = (ps.main_context); - all_implicits = (ps.all_implicits); - goals = (ps.goals); - smt_goals = (ps.smt_goals); - depth = (ps.depth + Prims.int_one); - __dump = (ps.__dump); - psc = (ps.psc); - entry_range = (ps.entry_range); - guard_policy = (ps.guard_policy); - freshness = (ps.freshness); - tac_verb_dbg = (ps.tac_verb_dbg); - local_state = (ps.local_state); - urgency = (ps.urgency); - dump_on_failure = (ps.dump_on_failure) - } -let (set_ps_psc : - FStar_TypeChecker_Primops_Base.psc -> proofstate -> proofstate) = - fun psc -> - fun ps -> - { - main_context = (ps.main_context); - all_implicits = (ps.all_implicits); - goals = (ps.goals); - smt_goals = (ps.smt_goals); - depth = (ps.depth); - __dump = (ps.__dump); - psc; - entry_range = (ps.entry_range); - guard_policy = (ps.guard_policy); - freshness = (ps.freshness); - tac_verb_dbg = (ps.tac_verb_dbg); - local_state = (ps.local_state); - urgency = (ps.urgency); - dump_on_failure = (ps.dump_on_failure) - } -let (tracepoint_with_psc : - FStar_TypeChecker_Primops_Base.psc -> proofstate -> Prims.bool) = - fun psc -> - fun ps -> - (let uu___1 = - (FStar_Options.tactic_trace ()) || - (let uu___2 = FStar_Options.tactic_trace_d () in - ps.depth <= uu___2) in - if uu___1 - then let ps1 = set_ps_psc psc ps in ps1.__dump ps1 "TRACE" - else ()); - true -let (tracepoint : proofstate -> Prims.bool) = - fun ps -> - (let uu___1 = - (FStar_Options.tactic_trace ()) || - (let uu___2 = FStar_Options.tactic_trace_d () in ps.depth <= uu___2) in - if uu___1 then ps.__dump ps "TRACE" else ()); - true -let (set_proofstate_range : - proofstate -> FStar_Compiler_Range_Type.range -> proofstate) = - fun ps -> - fun r -> - let uu___ = - let uu___1 = FStar_Compiler_Range_Type.def_range r in - FStar_Compiler_Range_Type.set_def_range ps.entry_range uu___1 in - { - main_context = (ps.main_context); - all_implicits = (ps.all_implicits); - goals = (ps.goals); - smt_goals = (ps.smt_goals); - depth = (ps.depth); - __dump = (ps.__dump); - psc = (ps.psc); - entry_range = uu___; - guard_policy = (ps.guard_policy); - freshness = (ps.freshness); - tac_verb_dbg = (ps.tac_verb_dbg); - local_state = (ps.local_state); - urgency = (ps.urgency); - dump_on_failure = (ps.dump_on_failure) - } -let (goals_of : proofstate -> goal Prims.list) = fun ps -> ps.goals -let (smt_goals_of : proofstate -> goal Prims.list) = fun ps -> ps.smt_goals -let (is_guard : goal -> Prims.bool) = fun g -> g.is_guard -let (get_label : goal -> Prims.string) = fun g -> g.label -let (set_label : Prims.string -> goal -> goal) = - fun l -> - fun g -> - { - goal_main_env = (g.goal_main_env); - goal_ctx_uvar = (g.goal_ctx_uvar); - opts = (g.opts); - is_guard = (g.is_guard); - label = l - } -type ctrl_flag = - | Continue - | Skip - | Abort -let (uu___is_Continue : ctrl_flag -> Prims.bool) = - fun projectee -> match projectee with | Continue -> true | uu___ -> false -let (uu___is_Skip : ctrl_flag -> Prims.bool) = - fun projectee -> match projectee with | Skip -> true | uu___ -> false -let (uu___is_Abort : ctrl_flag -> Prims.bool) = - fun projectee -> match projectee with | Abort -> true | uu___ -> false -type direction = - | TopDown - | BottomUp -let (uu___is_TopDown : direction -> Prims.bool) = - fun projectee -> match projectee with | TopDown -> true | uu___ -> false -let (uu___is_BottomUp : direction -> Prims.bool) = - fun projectee -> match projectee with | BottomUp -> true | uu___ -> false -let (check_goal_solved' : - goal -> FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) = - fun goal1 -> - let uu___ = - FStar_Syntax_Unionfind.find - (goal1.goal_ctx_uvar).FStar_Syntax_Syntax.ctx_uvar_head in - match uu___ with - | FStar_Pervasives_Native.Some t -> FStar_Pervasives_Native.Some t - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None -let (check_goal_solved : goal -> Prims.bool) = - fun goal1 -> - let uu___ = check_goal_solved' goal1 in - FStar_Compiler_Option.isSome uu___ -type 'a tref = 'a FStar_Compiler_Effect.ref -type ('g, 't) non_informative_token = unit -type ('g, 't0, 't1) subtyping_token = unit -type ('g, 't0, 't1) equiv_token = unit -type ('g, 'e, 'c) typing_token = unit -type ('g, 'sc, 't, 'pats) match_complete_token = unit \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_V1_Basic.ml b/ocaml/fstar-lib/generated/FStar_Tactics_V1_Basic.ml deleted file mode 100644 index c21415730c6..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Tactics_V1_Basic.ml +++ /dev/null @@ -1,9438 +0,0 @@ -open Prims -let (dbg_2635 : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "2635" -let (dbg_ReflTc : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "ReflTc" -let (dbg_Tac : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Tac" -let (dbg_TacUnify : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "TacUnify" -let ret : 'a . 'a -> 'a FStar_Tactics_Monad.tac = - fun uu___ -> - (fun x -> - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.magic x))) uu___ -let bind : - 'a 'b . - unit -> - 'a FStar_Tactics_Monad.tac -> - ('a -> 'b FStar_Tactics_Monad.tac) -> 'b FStar_Tactics_Monad.tac - = - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun uu___ -> - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - ())) uu___2 uu___1 uu___ -let (idtac : unit FStar_Tactics_Monad.tac) = - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () (Obj.repr ()) -let (get_phi : - FStar_Tactics_Types.goal -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = - fun g -> - let uu___ = - let uu___1 = FStar_Tactics_Types.goal_env g in - let uu___2 = FStar_Tactics_Types.goal_type g in - FStar_TypeChecker_Normalize.unfold_whnf uu___1 uu___2 in - FStar_Syntax_Util.un_squash uu___ -let (is_irrelevant : FStar_Tactics_Types.goal -> Prims.bool) = - fun g -> let uu___ = get_phi g in FStar_Compiler_Option.isSome uu___ -let (core_check : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.typ -> - Prims.bool -> - (FStar_Syntax_Syntax.typ FStar_Pervasives_Native.option, - FStar_TypeChecker_Core.error) FStar_Pervasives.either) - = - fun env -> - fun sol -> - fun t -> - fun must_tot -> - let uu___ = - let uu___1 = FStar_Options.compat_pre_core_should_check () in - Prims.op_Negation uu___1 in - if uu___ - then FStar_Pervasives.Inl FStar_Pervasives_Native.None - else - (let debug f = - let uu___2 = FStar_Compiler_Debug.any () in - if uu___2 then f () else () in - let uu___2 = - FStar_TypeChecker_Core.check_term env sol t must_tot in - match uu___2 with - | FStar_Pervasives.Inl (FStar_Pervasives_Native.None) -> - FStar_Pervasives.Inl FStar_Pervasives_Native.None - | FStar_Pervasives.Inl (FStar_Pervasives_Native.Some g) -> - let uu___3 = FStar_Options.compat_pre_core_set () in - if uu___3 - then FStar_Pervasives.Inl FStar_Pervasives_Native.None - else FStar_Pervasives.Inl (FStar_Pervasives_Native.Some g) - | FStar_Pervasives.Inr err -> - (debug - (fun uu___4 -> - let uu___5 = - let uu___6 = FStar_TypeChecker_Env.get_range env in - FStar_Class_Show.show - FStar_Compiler_Range_Ops.showable_range uu___6 in - let uu___6 = - FStar_TypeChecker_Core.print_error_short err in - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term sol in - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - let uu___9 = FStar_TypeChecker_Core.print_error err in - FStar_Compiler_Util.print5 - "(%s) Core checking failed (%s) on term %s and type %s\n%s\n" - uu___5 uu___6 uu___7 uu___8 uu___9); - FStar_Pervasives.Inr err)) -type name = FStar_Syntax_Syntax.bv -type env = FStar_TypeChecker_Env.env -type implicits = FStar_TypeChecker_Env.implicits -let (rangeof : FStar_Tactics_Types.goal -> FStar_Compiler_Range_Type.range) = - fun g -> - (g.FStar_Tactics_Types.goal_ctx_uvar).FStar_Syntax_Syntax.ctx_uvar_range -let (normalize : - FStar_TypeChecker_Env.steps -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = fun s -> fun e -> fun t -> FStar_TypeChecker_Normalize.normalize s e t -let (bnorm : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = fun e -> fun t -> normalize [] e t -let (whnf : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = fun e -> fun t -> FStar_TypeChecker_Normalize.unfold_whnf e t -let (tts : - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.term -> Prims.string) = - FStar_TypeChecker_Normalize.term_to_string -let (set_uvar_expected_typ : - FStar_Syntax_Syntax.ctx_uvar -> FStar_Syntax_Syntax.typ -> unit) = - fun u -> - fun t -> - let dec = - FStar_Syntax_Unionfind.find_decoration - u.FStar_Syntax_Syntax.ctx_uvar_head in - FStar_Syntax_Unionfind.change_decoration - u.FStar_Syntax_Syntax.ctx_uvar_head - { - FStar_Syntax_Syntax.uvar_decoration_typ = t; - FStar_Syntax_Syntax.uvar_decoration_typedness_depends_on = - (dec.FStar_Syntax_Syntax.uvar_decoration_typedness_depends_on); - FStar_Syntax_Syntax.uvar_decoration_should_check = - (dec.FStar_Syntax_Syntax.uvar_decoration_should_check); - FStar_Syntax_Syntax.uvar_decoration_should_unrefine = - (dec.FStar_Syntax_Syntax.uvar_decoration_should_unrefine) - } -let (mark_uvar_with_should_check_tag : - FStar_Syntax_Syntax.ctx_uvar -> - FStar_Syntax_Syntax.should_check_uvar -> unit) - = - fun u -> - fun sc -> - let dec = - FStar_Syntax_Unionfind.find_decoration - u.FStar_Syntax_Syntax.ctx_uvar_head in - FStar_Syntax_Unionfind.change_decoration - u.FStar_Syntax_Syntax.ctx_uvar_head - { - FStar_Syntax_Syntax.uvar_decoration_typ = - (dec.FStar_Syntax_Syntax.uvar_decoration_typ); - FStar_Syntax_Syntax.uvar_decoration_typedness_depends_on = - (dec.FStar_Syntax_Syntax.uvar_decoration_typedness_depends_on); - FStar_Syntax_Syntax.uvar_decoration_should_check = sc; - FStar_Syntax_Syntax.uvar_decoration_should_unrefine = - (dec.FStar_Syntax_Syntax.uvar_decoration_should_unrefine) - } -let (mark_uvar_as_already_checked : FStar_Syntax_Syntax.ctx_uvar -> unit) = - fun u -> - mark_uvar_with_should_check_tag u FStar_Syntax_Syntax.Already_checked -let (mark_goal_implicit_already_checked : FStar_Tactics_Types.goal -> unit) = - fun g -> mark_uvar_as_already_checked g.FStar_Tactics_Types.goal_ctx_uvar -let (goal_with_type : - FStar_Tactics_Types.goal -> - FStar_Syntax_Syntax.typ -> FStar_Tactics_Types.goal) - = - fun g -> - fun t -> - let u = g.FStar_Tactics_Types.goal_ctx_uvar in - set_uvar_expected_typ u t; g -let (bnorm_goal : FStar_Tactics_Types.goal -> FStar_Tactics_Types.goal) = - fun g -> - let uu___ = - let uu___1 = FStar_Tactics_Types.goal_env g in - let uu___2 = FStar_Tactics_Types.goal_type g in bnorm uu___1 uu___2 in - goal_with_type g uu___ -let (tacprint : Prims.string -> unit) = - fun s -> FStar_Compiler_Util.print1 "TAC>> %s\n" s -let (tacprint1 : Prims.string -> Prims.string -> unit) = - fun s -> - fun x -> - let uu___ = FStar_Compiler_Util.format1 s x in - FStar_Compiler_Util.print1 "TAC>> %s\n" uu___ -let (tacprint2 : Prims.string -> Prims.string -> Prims.string -> unit) = - fun s -> - fun x -> - fun y -> - let uu___ = FStar_Compiler_Util.format2 s x y in - FStar_Compiler_Util.print1 "TAC>> %s\n" uu___ -let (tacprint3 : - Prims.string -> Prims.string -> Prims.string -> Prims.string -> unit) = - fun s -> - fun x -> - fun y -> - fun z -> - let uu___ = FStar_Compiler_Util.format3 s x y z in - FStar_Compiler_Util.print1 "TAC>> %s\n" uu___ -let (print : Prims.string -> unit FStar_Tactics_Monad.tac) = - fun msg -> - (let uu___1 = - let uu___2 = FStar_Options.silent () in Prims.op_Negation uu___2 in - if uu___1 then tacprint msg else ()); - ret () -let (debugging : unit -> Prims.bool FStar_Tactics_Monad.tac) = - fun uu___ -> - let uu___1 = bind () in - uu___1 FStar_Tactics_Monad.get - (fun ps -> - let uu___2 = FStar_Compiler_Effect.op_Bang dbg_Tac in ret uu___2) -let (do_dump_ps : Prims.string -> FStar_Tactics_Types.proofstate -> unit) = - fun msg -> - fun ps -> - let psc = ps.FStar_Tactics_Types.psc in - let subst = FStar_TypeChecker_Primops_Base.psc_subst psc in - FStar_Tactics_Printing.do_dump_proofstate ps msg -let (dump : Prims.string -> unit FStar_Tactics_Monad.tac) = - fun msg -> - FStar_Tactics_Monad.mk_tac - (fun ps -> do_dump_ps msg ps; FStar_Tactics_Result.Success ((), ps)) -let (dump_all : Prims.bool -> Prims.string -> unit FStar_Tactics_Monad.tac) = - fun print_resolved -> - fun msg -> - FStar_Tactics_Monad.mk_tac - (fun ps -> - let gs = - FStar_Compiler_List.map - (fun i -> - FStar_Tactics_Types.goal_of_implicit - ps.FStar_Tactics_Types.main_context i) - ps.FStar_Tactics_Types.all_implicits in - let gs1 = - if print_resolved - then gs - else - FStar_Compiler_List.filter - (fun g -> - let uu___1 = FStar_Tactics_Types.check_goal_solved g in - Prims.op_Negation uu___1) gs in - let ps' = - { - FStar_Tactics_Types.main_context = - (ps.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits = - (ps.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = gs1; - FStar_Tactics_Types.smt_goals = []; - FStar_Tactics_Types.depth = (ps.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = (ps.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = (ps.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (ps.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = - (ps.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness = - (ps.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg = - (ps.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = - (ps.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency = (ps.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure = - (ps.FStar_Tactics_Types.dump_on_failure) - } in - do_dump_ps msg ps'; FStar_Tactics_Result.Success ((), ps)) -let (dump_uvars_of : - FStar_Tactics_Types.goal -> Prims.string -> unit FStar_Tactics_Monad.tac) = - fun g -> - fun msg -> - FStar_Tactics_Monad.mk_tac - (fun ps -> - let uvs = - let uu___ = - let uu___1 = FStar_Tactics_Types.goal_type g in - FStar_Syntax_Free.uvars uu___1 in - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) (Obj.magic uu___) in - let gs = - FStar_Compiler_List.map (FStar_Tactics_Types.goal_of_ctx_uvar g) - uvs in - let gs1 = - FStar_Compiler_List.filter - (fun g1 -> - let uu___ = FStar_Tactics_Types.check_goal_solved g1 in - Prims.op_Negation uu___) gs in - let ps' = - { - FStar_Tactics_Types.main_context = - (ps.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits = - (ps.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = gs1; - FStar_Tactics_Types.smt_goals = []; - FStar_Tactics_Types.depth = (ps.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = (ps.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = (ps.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (ps.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = - (ps.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness = - (ps.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg = - (ps.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = - (ps.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency = (ps.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure = - (ps.FStar_Tactics_Types.dump_on_failure) - } in - do_dump_ps msg ps'; FStar_Tactics_Result.Success ((), ps)) -let fail1 : - 'uuuuu . Prims.string -> Prims.string -> 'uuuuu FStar_Tactics_Monad.tac = - fun msg -> - fun x -> - let uu___ = FStar_Compiler_Util.format1 msg x in - FStar_Tactics_Monad.fail uu___ -let fail2 : - 'uuuuu . - Prims.string -> - Prims.string -> Prims.string -> 'uuuuu FStar_Tactics_Monad.tac - = - fun msg -> - fun x -> - fun y -> - let uu___ = FStar_Compiler_Util.format2 msg x y in - FStar_Tactics_Monad.fail uu___ -let fail3 : - 'uuuuu . - Prims.string -> - Prims.string -> - Prims.string -> Prims.string -> 'uuuuu FStar_Tactics_Monad.tac - = - fun msg -> - fun x -> - fun y -> - fun z -> - let uu___ = FStar_Compiler_Util.format3 msg x y z in - FStar_Tactics_Monad.fail uu___ -let fail4 : - 'uuuuu . - Prims.string -> - Prims.string -> - Prims.string -> - Prims.string -> Prims.string -> 'uuuuu FStar_Tactics_Monad.tac - = - fun msg -> - fun x -> - fun y -> - fun z -> - fun w -> - let uu___ = FStar_Compiler_Util.format4 msg x y z w in - FStar_Tactics_Monad.fail uu___ -let (destruct_eq' : - FStar_Syntax_Syntax.typ -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.term) - FStar_Pervasives_Native.option) - = - fun typ -> - let uu___ = FStar_Syntax_Formula.destruct_typ_as_formula typ in - match uu___ with - | FStar_Pervasives_Native.Some (FStar_Syntax_Formula.BaseConn - (l, - uu___1::(e1, FStar_Pervasives_Native.None)::(e2, - FStar_Pervasives_Native.None)::[])) - when - (FStar_Ident.lid_equals l FStar_Parser_Const.eq2_lid) || - (FStar_Ident.lid_equals l FStar_Parser_Const.c_eq2_lid) - -> FStar_Pervasives_Native.Some (e1, e2) - | uu___1 -> - let uu___2 = FStar_Syntax_Util.unb2t typ in - (match uu___2 with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some t -> - let uu___3 = FStar_Syntax_Util.head_and_args t in - (match uu___3 with - | (hd, args) -> - let uu___4 = - let uu___5 = - let uu___6 = FStar_Syntax_Subst.compress hd in - uu___6.FStar_Syntax_Syntax.n in - (uu___5, args) in - (match uu___4 with - | (FStar_Syntax_Syntax.Tm_fvar fv, - (uu___5, FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = uu___6;_}):: - (e1, FStar_Pervasives_Native.None)::(e2, - FStar_Pervasives_Native.None)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.op_Eq - -> FStar_Pervasives_Native.Some (e1, e2) - | uu___5 -> FStar_Pervasives_Native.None))) -let (destruct_eq : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.term) - FStar_Pervasives_Native.option) - = - fun env1 -> - fun typ -> - let typ1 = whnf env1 typ in - let uu___ = destruct_eq' typ1 in - match uu___ with - | FStar_Pervasives_Native.Some t -> FStar_Pervasives_Native.Some t - | FStar_Pervasives_Native.None -> - let uu___1 = FStar_Syntax_Util.un_squash typ1 in - (match uu___1 with - | FStar_Pervasives_Native.Some typ2 -> - let typ3 = whnf env1 typ2 in destruct_eq' typ3 - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None) -let (get_guard_policy : - unit -> FStar_Tactics_Types.guard_policy FStar_Tactics_Monad.tac) = - fun uu___ -> - let uu___1 = bind () in - uu___1 FStar_Tactics_Monad.get - (fun ps -> ret ps.FStar_Tactics_Types.guard_policy) -let (set_guard_policy : - FStar_Tactics_Types.guard_policy -> unit FStar_Tactics_Monad.tac) = - fun pol -> - let uu___ = bind () in - uu___ FStar_Tactics_Monad.get - (fun ps -> - FStar_Tactics_Monad.set - { - FStar_Tactics_Types.main_context = - (ps.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits = - (ps.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = (ps.FStar_Tactics_Types.goals); - FStar_Tactics_Types.smt_goals = - (ps.FStar_Tactics_Types.smt_goals); - FStar_Tactics_Types.depth = (ps.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = (ps.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = (ps.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (ps.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = pol; - FStar_Tactics_Types.freshness = - (ps.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg = - (ps.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = - (ps.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency = (ps.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure = - (ps.FStar_Tactics_Types.dump_on_failure) - }) -let with_policy : - 'a . - FStar_Tactics_Types.guard_policy -> - 'a FStar_Tactics_Monad.tac -> 'a FStar_Tactics_Monad.tac - = - fun pol -> - fun t -> - let uu___ = get_guard_policy () in - let uu___1 = bind () in - uu___1 uu___ - (fun old_pol -> - let uu___2 = set_guard_policy pol in - let uu___3 = bind () in - uu___3 uu___2 - (fun uu___4 -> - let uu___5 = bind () in - uu___5 t - (fun r -> - let uu___6 = set_guard_policy old_pol in - let uu___7 = bind () in - uu___7 uu___6 (fun uu___8 -> ret r)))) -let (proc_guard' : - Prims.bool -> - Prims.string -> - env -> - FStar_TypeChecker_Common.guard_t -> - FStar_Syntax_Syntax.should_check_uvar - FStar_Pervasives_Native.option -> - FStar_Compiler_Range_Type.range -> unit FStar_Tactics_Monad.tac) - = - fun simplify -> - fun reason -> - fun e -> - fun g -> - fun sc_opt -> - fun rng -> - FStar_Tactics_Monad.mlog - (fun uu___ -> - let uu___1 = FStar_TypeChecker_Rel.guard_to_string e g in - FStar_Compiler_Util.print2 "Processing guard (%s:%s)\n" - reason uu___1) - (fun uu___ -> - let imps = - FStar_Class_Listlike.to_list - (FStar_Compiler_CList.listlike_clist ()) - g.FStar_TypeChecker_Common.implicits in - (match sc_opt with - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Allow_untyped r) -> - FStar_Compiler_List.iter - (fun imp -> - mark_uvar_with_should_check_tag - imp.FStar_TypeChecker_Common.imp_uvar - (FStar_Syntax_Syntax.Allow_untyped r)) imps - | uu___2 -> ()); - (let uu___2 = FStar_Tactics_Monad.add_implicits imps in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () uu___2 - (fun uu___3 -> - (fun uu___3 -> - let uu___3 = Obj.magic uu___3 in - let guard_f = - if simplify - then - let uu___4 = - FStar_TypeChecker_Rel.simplify_guard e g in - uu___4.FStar_TypeChecker_Common.guard_f - else g.FStar_TypeChecker_Common.guard_f in - match guard_f with - | FStar_TypeChecker_Common.Trivial -> - Obj.magic (ret ()) - | FStar_TypeChecker_Common.NonTrivial f -> - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.get) - (fun uu___4 -> - (fun ps -> - let ps = Obj.magic ps in - match ps.FStar_Tactics_Types.guard_policy - with - | FStar_Tactics_Types.Drop -> - ((let uu___5 = - let uu___6 = - FStar_TypeChecker_Rel.guard_to_string - e g in - FStar_Compiler_Util.format1 - "Tactics admitted guard <%s>\n\n" - uu___6 in - FStar_Errors.log_issue - FStar_TypeChecker_Env.hasRange_env - e - FStar_Errors_Codes.Warning_TacAdmit - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___5)); - Obj.magic (ret ())) - | FStar_Tactics_Types.Goal -> - Obj.magic - (FStar_Tactics_Monad.mlog - (fun uu___4 -> - let uu___5 = - FStar_TypeChecker_Rel.guard_to_string - e g in - FStar_Compiler_Util.print2 - "Making guard (%s:%s) into a goal\n" - reason uu___5) - (fun uu___4 -> - let uu___5 = - FStar_Tactics_Monad.goal_of_guard - reason e f sc_opt - rng in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic uu___5) - (fun uu___6 -> - (fun g1 -> - let g1 = - Obj.magic g1 in - Obj.magic - (FStar_Tactics_Monad.push_goals - [g1])) - uu___6))) - | FStar_Tactics_Types.SMT -> - Obj.magic - (FStar_Tactics_Monad.mlog - (fun uu___4 -> - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - f in - FStar_Compiler_Util.print2 - "Pushing guard (%s:%s) as SMT goal\n" - reason uu___5) - (fun uu___4 -> - let uu___5 = - FStar_Tactics_Monad.goal_of_guard - reason e f sc_opt - rng in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic uu___5) - (fun uu___6 -> - (fun g1 -> - let g1 = - Obj.magic g1 in - Obj.magic - (FStar_Tactics_Monad.push_smt_goals - [g1])) - uu___6))) - | FStar_Tactics_Types.SMTSync -> - Obj.magic - (FStar_Tactics_Monad.mlog - (fun uu___4 -> - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - f in - FStar_Compiler_Util.print2 - "Sending guard (%s:%s) to SMT Synchronously\n" - reason uu___5) - (fun uu___4 -> - FStar_TypeChecker_Rel.force_trivial_guard - e g; - ret ())) - | FStar_Tactics_Types.Force -> - Obj.magic - (FStar_Tactics_Monad.mlog - (fun uu___4 -> - let uu___5 = - FStar_TypeChecker_Rel.guard_to_string - e g in - FStar_Compiler_Util.print2 - "Forcing guard (%s:%s)\n" - reason uu___5) - (fun uu___4 -> - try - (fun uu___5 -> - match () with - | () -> - let uu___6 = - let uu___7 - = - let uu___8 - = - FStar_TypeChecker_Rel.discharge_guard_no_smt - e g in - FStar_TypeChecker_Env.is_trivial - uu___8 in - Prims.op_Negation - uu___7 in - if uu___6 - then - FStar_Tactics_Monad.mlog - ( - fun - uu___7 -> - let uu___8 - = - FStar_TypeChecker_Rel.guard_to_string - e g in - FStar_Compiler_Util.print1 - "guard = %s\n" - uu___8) - ( - fun - uu___7 -> - fail1 - "Forcing the guard failed (%s)" - reason) - else ret ()) - () - with - | uu___5 -> - FStar_Tactics_Monad.mlog - (fun uu___6 -> - let uu___7 = - FStar_TypeChecker_Rel.guard_to_string - e g in - FStar_Compiler_Util.print1 - "guard = %s\n" - uu___7) - (fun uu___6 -> - fail1 - "Forcing the guard failed (%s)" - reason)))) - uu___4))) uu___3))) -let (proc_guard : - Prims.string -> - env -> - FStar_TypeChecker_Common.guard_t -> - FStar_Syntax_Syntax.should_check_uvar FStar_Pervasives_Native.option - -> FStar_Compiler_Range_Type.range -> unit FStar_Tactics_Monad.tac) - = proc_guard' true -let (tc_unifier_solved_implicits : - FStar_TypeChecker_Env.env -> - Prims.bool -> - Prims.bool -> - FStar_Syntax_Syntax.ctx_uvar Prims.list -> - unit FStar_Tactics_Monad.tac) - = - fun env1 -> - fun must_tot -> - fun allow_guards -> - fun uvs -> - let aux u = - let dec = - FStar_Syntax_Unionfind.find_decoration - u.FStar_Syntax_Syntax.ctx_uvar_head in - let sc = dec.FStar_Syntax_Syntax.uvar_decoration_should_check in - match sc with - | FStar_Syntax_Syntax.Allow_untyped uu___ -> ret () - | FStar_Syntax_Syntax.Already_checked -> ret () - | uu___ -> - let uu___1 = - FStar_Syntax_Unionfind.find - u.FStar_Syntax_Syntax.ctx_uvar_head in - (match uu___1 with - | FStar_Pervasives_Native.None -> ret () - | FStar_Pervasives_Native.Some sol -> - let env2 = - { - FStar_TypeChecker_Env.solver = - (env1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (u.FStar_Syntax_Syntax.ctx_uvar_gamma); - FStar_TypeChecker_Env.gamma_sig = - (env1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (env1.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env1.FStar_TypeChecker_Env.missing_decl) - } in - let must_tot1 = - must_tot && - (Prims.op_Negation - (FStar_Syntax_Syntax.uu___is_Allow_ghost - dec.FStar_Syntax_Syntax.uvar_decoration_should_check)) in - let uu___2 = - let uu___3 = FStar_Syntax_Util.ctx_uvar_typ u in - core_check env2 sol uu___3 must_tot1 in - (match uu___2 with - | FStar_Pervasives.Inl (FStar_Pervasives_Native.None) - -> (mark_uvar_as_already_checked u; ret ()) - | FStar_Pervasives.Inl (FStar_Pervasives_Native.Some g) - -> - let guard = - { - FStar_TypeChecker_Common.guard_f = - (FStar_TypeChecker_Common.NonTrivial g); - FStar_TypeChecker_Common.deferred_to_tac = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.implicits) - } in - let guard1 = - FStar_TypeChecker_Rel.simplify_guard env2 guard in - let uu___3 = - ((FStar_Options.disallow_unification_guards ()) - && (Prims.op_Negation allow_guards)) - && - (FStar_TypeChecker_Common.uu___is_NonTrivial - guard1.FStar_TypeChecker_Common.guard_f) in - if uu___3 - then - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_uvar - u.FStar_Syntax_Syntax.ctx_uvar_head in - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term sol in - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term g in - fail3 - "Could not typecheck unifier solved implicit %s to %s since it produced a guard and guards were not allowed;guard is\n%s" - uu___4 uu___5 uu___6 - else - (let uu___5 = - proc_guard' false "guard for implicit" env2 - guard1 (FStar_Pervasives_Native.Some sc) - u.FStar_Syntax_Syntax.ctx_uvar_range in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () uu___5 - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = Obj.magic uu___6 in - mark_uvar_as_already_checked u; - Obj.magic (ret ())) uu___6)) - | FStar_Pervasives.Inr failed -> - let uu___3 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_uvar - u.FStar_Syntax_Syntax.ctx_uvar_head in - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term sol in - let uu___5 = - FStar_TypeChecker_Core.print_error failed in - fail3 - "Could not typecheck unifier solved implicit %s to %s because %s" - uu___3 uu___4 uu___5)) in - if env1.FStar_TypeChecker_Env.phase1 - then ret () - else FStar_Tactics_Monad.iter_tac aux uvs -type check_unifier_solved_implicits_side = - | Check_none - | Check_left_only - | Check_right_only - | Check_both -let (uu___is_Check_none : check_unifier_solved_implicits_side -> Prims.bool) - = - fun projectee -> match projectee with | Check_none -> true | uu___ -> false -let (uu___is_Check_left_only : - check_unifier_solved_implicits_side -> Prims.bool) = - fun projectee -> - match projectee with | Check_left_only -> true | uu___ -> false -let (uu___is_Check_right_only : - check_unifier_solved_implicits_side -> Prims.bool) = - fun projectee -> - match projectee with | Check_right_only -> true | uu___ -> false -let (uu___is_Check_both : check_unifier_solved_implicits_side -> Prims.bool) - = - fun projectee -> match projectee with | Check_both -> true | uu___ -> false -let (__do_unify_wflags : - Prims.bool -> - Prims.bool -> - Prims.bool -> - check_unifier_solved_implicits_side -> - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> - FStar_TypeChecker_Common.guard_t - FStar_Pervasives_Native.option FStar_Tactics_Monad.tac) - = - fun uu___6 -> - fun uu___5 -> - fun uu___4 -> - fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun dbg -> - fun allow_guards -> - fun must_tot -> - fun check_side -> - fun env1 -> - fun t1 -> - fun t2 -> - if dbg - then - (let uu___1 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t1 in - let uu___2 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t2 in - FStar_Compiler_Util.print2 - "%%%%%%%%do_unify %s =? %s\n" uu___1 - uu___2) - else (); - (let all_uvars = - let uu___1 = - match check_side with - | Check_none -> - Obj.magic - (Obj.repr - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) - ())) - | Check_left_only -> - Obj.magic - (Obj.repr - (FStar_Syntax_Free.uvars t1)) - | Check_right_only -> - Obj.magic - (Obj.repr - (FStar_Syntax_Free.uvars t2)) - | Check_both -> - Obj.magic - (Obj.repr - (let uu___2 = - FStar_Syntax_Free.uvars t1 in - let uu___3 = - FStar_Syntax_Free.uvars t2 in - FStar_Class_Setlike.union () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) - (Obj.magic uu___2) - (Obj.magic uu___3))) in - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) - (Obj.magic uu___1) in - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Tactics_Monad.trytac - FStar_Tactics_Monad.cur_goal in - let uu___4 = bind () in - uu___4 uu___3 - (fun gopt -> - try - (fun uu___5 -> - (fun uu___5 -> - match () with - | () -> - let res = - if allow_guards - then - FStar_TypeChecker_Rel.try_teq - true env1 t1 t2 - else - FStar_TypeChecker_Rel.teq_nosmt - env1 t1 t2 in - (if dbg - then - (let uu___7 = - FStar_Common.string_of_option - (FStar_TypeChecker_Rel.guard_to_string - env1) res in - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t1 in - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t2 in - FStar_Compiler_Util.print3 - "%%%%%%%%do_unify (RESULT %s) %s =? %s\n" - uu___7 uu___8 - uu___9) - else (); - (match res with - | FStar_Pervasives_Native.None - -> - Obj.magic - (Obj.repr - (ret - FStar_Pervasives_Native.None)) - | FStar_Pervasives_Native.Some - g -> - Obj.magic - (Obj.repr - (let uu___7 = - tc_unifier_solved_implicits - env1 - must_tot - allow_guards - all_uvars in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___7 - (fun - uu___8 -> - (fun - uu___8 -> - let uu___8 - = - Obj.magic - uu___8 in - let uu___9 - = - let uu___10 - = - FStar_Class_Listlike.to_list - (FStar_Compiler_CList.listlike_clist - ()) - g.FStar_TypeChecker_Common.implicits in - FStar_Tactics_Monad.add_implicits - uu___10 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___9 - (fun - uu___10 - -> - (fun - uu___10 - -> - let uu___10 - = - Obj.magic - uu___10 in - Obj.magic - (ret - (FStar_Pervasives_Native.Some - g))) - uu___10))) - uu___8)))))) - uu___5) () - with - | FStar_Errors.Error - (uu___6, msg, r, uu___7) -> - FStar_Tactics_Monad.mlog - (fun uu___8 -> - let uu___9 = - FStar_Errors_Msg.rendermsg - msg in - let uu___10 = - FStar_Class_Show.show - FStar_Compiler_Range_Ops.showable_range - r in - FStar_Compiler_Util.print2 - ">> do_unify error, (%s) at (%s)\n" - uu___9 uu___10) - (fun uu___8 -> - ret - FStar_Pervasives_Native.None)) in - FStar_Tactics_Monad.catch uu___2 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - match uu___2 with - | FStar_Pervasives.Inl exn -> - Obj.magic - (FStar_Tactics_Monad.traise - exn) - | FStar_Pervasives.Inr v -> - Obj.magic (ret v)) uu___2)))) - uu___6 uu___5 uu___4 uu___3 uu___2 uu___1 uu___ -let (__do_unify : - Prims.bool -> - Prims.bool -> - check_unifier_solved_implicits_side -> - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> - FStar_TypeChecker_Common.guard_t FStar_Pervasives_Native.option - FStar_Tactics_Monad.tac) - = - fun allow_guards -> - fun must_tot -> - fun check_side -> - fun env1 -> - fun t1 -> - fun t2 -> - let uu___ = bind () in - uu___ idtac - (fun uu___1 -> - (let uu___3 = FStar_Compiler_Effect.op_Bang dbg_TacUnify in - if uu___3 - then - (FStar_Options.push (); - (let uu___5 = - FStar_Options.set_options "--debug Rel,RelCheck" in - ())) - else ()); - (let uu___3 = - let uu___4 = FStar_Compiler_Effect.op_Bang dbg_TacUnify in - __do_unify_wflags uu___4 allow_guards must_tot - check_side env1 t1 t2 in - let uu___4 = bind () in - uu___4 uu___3 - (fun r -> - (let uu___6 = - FStar_Compiler_Effect.op_Bang dbg_TacUnify in - if uu___6 then FStar_Options.pop () else ()); - ret r))) -let (do_unify_aux : - Prims.bool -> - check_unifier_solved_implicits_side -> - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> Prims.bool FStar_Tactics_Monad.tac) - = - fun must_tot -> - fun check_side -> - fun env1 -> - fun t1 -> - fun t2 -> - let uu___ = __do_unify false must_tot check_side env1 t1 t2 in - let uu___1 = bind () in - uu___1 uu___ - (fun uu___2 -> - match uu___2 with - | FStar_Pervasives_Native.None -> ret false - | FStar_Pervasives_Native.Some g -> - ((let uu___4 = - let uu___5 = - FStar_TypeChecker_Env.is_trivial_guard_formula g in - Prims.op_Negation uu___5 in - if uu___4 - then - failwith - "internal error: do_unify: guard is not trivial" - else ()); - ret true)) -let (do_unify : - Prims.bool -> - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> Prims.bool FStar_Tactics_Monad.tac) - = - fun must_tot -> - fun env1 -> - fun t1 -> fun t2 -> do_unify_aux must_tot Check_both env1 t1 t2 -let (do_unify_maybe_guards : - Prims.bool -> - Prims.bool -> - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> - FStar_TypeChecker_Common.guard_t FStar_Pervasives_Native.option - FStar_Tactics_Monad.tac) - = - fun allow_guards -> - fun must_tot -> - fun env1 -> - fun t1 -> - fun t2 -> __do_unify allow_guards must_tot Check_both env1 t1 t2 -let (do_match : - Prims.bool -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> Prims.bool FStar_Tactics_Monad.tac) - = - fun must_tot -> - fun env1 -> - fun t1 -> - fun t2 -> - let uu___ = - FStar_Tactics_Monad.mk_tac - (fun ps -> - let tx = FStar_Syntax_Unionfind.new_transaction () in - FStar_Tactics_Result.Success (tx, ps)) in - let uu___1 = bind () in - uu___1 uu___ - (fun tx -> - let uvs1 = FStar_Syntax_Free.uvars_uncached t1 in - let uu___2 = do_unify_aux must_tot Check_right_only env1 t1 t2 in - let uu___3 = bind () in - uu___3 uu___2 - (fun r -> - if r - then - let uvs2 = FStar_Syntax_Free.uvars_uncached t1 in - let uu___4 = - let uu___5 = - FStar_Class_Setlike.equal () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) - (Obj.magic uvs1) (Obj.magic uvs2) in - Prims.op_Negation uu___5 in - (if uu___4 - then (FStar_Syntax_Unionfind.rollback tx; ret false) - else ret true) - else ret false)) -let (do_match_on_lhs : - Prims.bool -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> Prims.bool FStar_Tactics_Monad.tac) - = - fun must_tot -> - fun env1 -> - fun t1 -> - fun t2 -> - let uu___ = - FStar_Tactics_Monad.mk_tac - (fun ps -> - let tx = FStar_Syntax_Unionfind.new_transaction () in - FStar_Tactics_Result.Success (tx, ps)) in - let uu___1 = bind () in - uu___1 uu___ - (fun tx -> - let uu___2 = destruct_eq env1 t1 in - match uu___2 with - | FStar_Pervasives_Native.None -> - FStar_Tactics_Monad.fail "do_match_on_lhs: not an eq" - | FStar_Pervasives_Native.Some (lhs, uu___3) -> - let uvs1 = FStar_Syntax_Free.uvars_uncached lhs in - let uu___4 = - do_unify_aux must_tot Check_right_only env1 t1 t2 in - let uu___5 = bind () in - uu___5 uu___4 - (fun r -> - if r - then - let uvs2 = FStar_Syntax_Free.uvars_uncached lhs in - let uu___6 = - let uu___7 = - FStar_Class_Setlike.equal () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) - (Obj.magic uvs1) (Obj.magic uvs2) in - Prims.op_Negation uu___7 in - (if uu___6 - then - (FStar_Syntax_Unionfind.rollback tx; ret false) - else ret true) - else ret false)) -let (set_solution : - FStar_Tactics_Types.goal -> - FStar_Syntax_Syntax.term -> unit FStar_Tactics_Monad.tac) - = - fun goal -> - fun solution -> - let uu___ = - FStar_Syntax_Unionfind.find - (goal.FStar_Tactics_Types.goal_ctx_uvar).FStar_Syntax_Syntax.ctx_uvar_head in - match uu___ with - | FStar_Pervasives_Native.Some uu___1 -> - let uu___2 = - let uu___3 = FStar_Tactics_Printing.goal_to_string_verbose goal in - FStar_Compiler_Util.format1 "Goal %s is already solved" uu___3 in - FStar_Tactics_Monad.fail uu___2 - | FStar_Pervasives_Native.None -> - (FStar_Syntax_Unionfind.change - (goal.FStar_Tactics_Types.goal_ctx_uvar).FStar_Syntax_Syntax.ctx_uvar_head - solution; - mark_goal_implicit_already_checked goal; - ret ()) -let (trysolve : - FStar_Tactics_Types.goal -> - FStar_Syntax_Syntax.term -> Prims.bool FStar_Tactics_Monad.tac) - = - fun goal -> - fun solution -> - let must_tot = true in - let uu___ = FStar_Tactics_Types.goal_env goal in - let uu___1 = FStar_Tactics_Types.goal_witness goal in - do_unify must_tot uu___ solution uu___1 -let (solve : - FStar_Tactics_Types.goal -> - FStar_Syntax_Syntax.term -> unit FStar_Tactics_Monad.tac) - = - fun goal -> - fun solution -> - let e = FStar_Tactics_Types.goal_env goal in - FStar_Tactics_Monad.mlog - (fun uu___ -> - let uu___1 = - let uu___2 = FStar_Tactics_Types.goal_witness goal in - FStar_Class_Show.show FStar_Syntax_Print.showable_term uu___2 in - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term solution in - FStar_Compiler_Util.print2 "solve %s := %s\n" uu___1 uu___2) - (fun uu___ -> - let uu___1 = trysolve goal solution in - let uu___2 = bind () in - uu___2 uu___1 - (fun b -> - if b - then - let uu___3 = bind () in - uu___3 FStar_Tactics_Monad.dismiss - (fun uu___4 -> FStar_Tactics_Monad.remove_solved_goals) - else - (let uu___4 = - let uu___5 = - let uu___6 = FStar_Tactics_Types.goal_env goal in - tts uu___6 solution in - let uu___6 = - let uu___7 = FStar_Tactics_Types.goal_env goal in - let uu___8 = FStar_Tactics_Types.goal_witness goal in - tts uu___7 uu___8 in - let uu___7 = - let uu___8 = FStar_Tactics_Types.goal_env goal in - let uu___9 = FStar_Tactics_Types.goal_type goal in - tts uu___8 uu___9 in - FStar_Compiler_Util.format3 "%s does not solve %s : %s" - uu___5 uu___6 uu___7 in - FStar_Tactics_Monad.fail uu___4))) -let (solve' : - FStar_Tactics_Types.goal -> - FStar_Syntax_Syntax.term -> unit FStar_Tactics_Monad.tac) - = - fun goal -> - fun solution -> - let uu___ = set_solution goal solution in - let uu___1 = bind () in - uu___1 uu___ - (fun uu___2 -> - let uu___3 = bind () in - uu___3 FStar_Tactics_Monad.dismiss - (fun uu___4 -> FStar_Tactics_Monad.remove_solved_goals)) -let (is_true : FStar_Syntax_Syntax.term -> Prims.bool) = - fun t -> - let t1 = FStar_Syntax_Util.unascribe t in - let uu___ = FStar_Syntax_Util.un_squash t1 in - match uu___ with - | FStar_Pervasives_Native.Some t' -> - let t'1 = FStar_Syntax_Util.unascribe t' in - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress t'1 in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.true_lid - | uu___2 -> false) - | uu___1 -> false -let (is_false : FStar_Syntax_Syntax.term -> Prims.bool) = - fun t -> - let uu___ = FStar_Syntax_Util.un_squash t in - match uu___ with - | FStar_Pervasives_Native.Some t' -> - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress t' in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.false_lid - | uu___2 -> false) - | uu___1 -> false -let (tadmit_t : FStar_Syntax_Syntax.term -> unit FStar_Tactics_Monad.tac) = - fun t -> - let uu___ = - let uu___1 = bind () in - uu___1 FStar_Tactics_Monad.get - (fun ps -> - let uu___2 = bind () in - uu___2 FStar_Tactics_Monad.cur_goal - (fun g -> - (let uu___4 = FStar_Tactics_Types.goal_type g in - let uu___5 = - let uu___6 = - FStar_Tactics_Printing.goal_to_string "" - FStar_Pervasives_Native.None ps g in - FStar_Compiler_Util.format1 - "Tactics admitted goal <%s>\n\n" uu___6 in - FStar_Errors.log_issue - (FStar_Syntax_Syntax.has_range_syntax ()) uu___4 - FStar_Errors_Codes.Warning_TacAdmit () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___5)); - solve' g t)) in - FStar_Tactics_Monad.wrap_err "tadmit_t" uu___ -let (fresh : unit -> FStar_BigInt.t FStar_Tactics_Monad.tac) = - fun uu___ -> - let uu___1 = bind () in - uu___1 FStar_Tactics_Monad.get - (fun ps -> - let n = ps.FStar_Tactics_Types.freshness in - let ps1 = - { - FStar_Tactics_Types.main_context = - (ps.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits = - (ps.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = (ps.FStar_Tactics_Types.goals); - FStar_Tactics_Types.smt_goals = - (ps.FStar_Tactics_Types.smt_goals); - FStar_Tactics_Types.depth = (ps.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = (ps.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = (ps.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (ps.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = - (ps.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness = (n + Prims.int_one); - FStar_Tactics_Types.tac_verb_dbg = - (ps.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = - (ps.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency = (ps.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure = - (ps.FStar_Tactics_Types.dump_on_failure) - } in - let uu___2 = FStar_Tactics_Monad.set ps1 in - let uu___3 = bind () in - uu___3 uu___2 - (fun uu___4 -> let uu___5 = FStar_BigInt.of_int_fs n in ret uu___5)) -let (curms : unit -> FStar_BigInt.t FStar_Tactics_Monad.tac) = - fun uu___ -> - let uu___1 = - let uu___2 = FStar_Compiler_Util.now_ms () in - FStar_BigInt.of_int_fs uu___2 in - ret uu___1 -let (__tc : - env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.typ * - FStar_TypeChecker_Common.guard_t) FStar_Tactics_Monad.tac) - = - fun e -> - fun t -> - let uu___ = bind () in - uu___ FStar_Tactics_Monad.get - (fun ps -> - FStar_Tactics_Monad.mlog - (fun uu___1 -> - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.print1 "Tac> __tc(%s)\n" uu___2) - (fun uu___1 -> - let e1 = - { - FStar_TypeChecker_Env.solver = - (e.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (e.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (e.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (e.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (e.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (e.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (e.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (e.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (e.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (e.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (e.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (e.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (e.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (e.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (e.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (e.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (e.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (e.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (e.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (e.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (e.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (e.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (e.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = false; - FStar_TypeChecker_Env.intactics = - (e.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (e.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (e.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (e.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (e.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (e.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (e.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (e.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (e.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (e.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (e.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (e.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (e.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (e.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (e.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (e.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (e.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (e.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (e.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (e.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (e.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (e.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (e.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (e.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (e.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (e.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (e.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (e.FStar_TypeChecker_Env.missing_decl) - } in - try - (fun uu___2 -> - match () with - | () -> - let uu___3 = - FStar_TypeChecker_TcTerm.typeof_tot_or_gtot_term - e1 t true in - ret uu___3) () - with - | FStar_Errors.Error (uu___3, msg, uu___4, uu___5) -> - let uu___6 = tts e1 t in - let uu___7 = - let uu___8 = FStar_TypeChecker_Env.all_binders e1 in - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binder) uu___8 in - let uu___8 = FStar_Errors_Msg.rendermsg msg in - fail3 "Cannot type (1) %s in context (%s). Error = (%s)" - uu___6 uu___7 uu___8)) -let (__tc_ghost : - env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.typ * - FStar_TypeChecker_Common.guard_t) FStar_Tactics_Monad.tac) - = - fun e -> - fun t -> - let uu___ = bind () in - uu___ FStar_Tactics_Monad.get - (fun ps -> - FStar_Tactics_Monad.mlog - (fun uu___1 -> - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.print1 "Tac> __tc_ghost(%s)\n" uu___2) - (fun uu___1 -> - let e1 = - { - FStar_TypeChecker_Env.solver = - (e.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (e.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (e.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (e.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (e.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (e.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (e.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (e.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (e.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (e.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (e.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (e.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (e.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (e.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (e.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (e.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (e.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (e.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (e.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (e.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (e.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (e.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (e.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = false; - FStar_TypeChecker_Env.intactics = - (e.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (e.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (e.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (e.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (e.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (e.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (e.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (e.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (e.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (e.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (e.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (e.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (e.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (e.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (e.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (e.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (e.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (e.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (e.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (e.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (e.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (e.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (e.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (e.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (e.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (e.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (e.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (e.FStar_TypeChecker_Env.missing_decl) - } in - let e2 = - { - FStar_TypeChecker_Env.solver = - (e1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (e1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (e1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (e1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (e1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (e1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (e1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (e1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (e1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (e1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (e1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (e1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (e1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = []; - FStar_TypeChecker_Env.top_level = - (e1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (e1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (e1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (e1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (e1.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (e1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (e1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (e1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (e1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (e1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (e1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (e1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (e1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (e1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (e1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (e1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (e1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (e1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (e1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (e1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (e1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (e1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (e1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (e1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (e1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (e1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (e1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (e1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (e1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (e1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (e1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (e1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (e1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (e1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (e1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (e1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (e1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (e1.FStar_TypeChecker_Env.missing_decl) - } in - try - (fun uu___2 -> - match () with - | () -> - let uu___3 = - FStar_TypeChecker_TcTerm.tc_tot_or_gtot_term e2 t in - (match uu___3 with - | (t1, lc, g) -> - ret - (t1, (lc.FStar_TypeChecker_Common.res_typ), - g))) () - with - | FStar_Errors.Error (uu___3, msg, uu___4, uu___5) -> - let uu___6 = tts e2 t in - let uu___7 = - let uu___8 = FStar_TypeChecker_Env.all_binders e2 in - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binder) uu___8 in - let uu___8 = FStar_Errors_Msg.rendermsg msg in - fail3 "Cannot type (2) %s in context (%s). Error = (%s)" - uu___6 uu___7 uu___8)) -let (__tc_lax : - env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.lcomp * - FStar_TypeChecker_Common.guard_t) FStar_Tactics_Monad.tac) - = - fun e -> - fun t -> - let uu___ = bind () in - uu___ FStar_Tactics_Monad.get - (fun ps -> - FStar_Tactics_Monad.mlog - (fun uu___1 -> - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - let uu___3 = - let uu___4 = FStar_TypeChecker_Env.all_binders e in - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binder) uu___4 in - FStar_Compiler_Util.print2 "Tac> __tc_lax(%s)(Context:%s)\n" - uu___2 uu___3) - (fun uu___1 -> - let e1 = - { - FStar_TypeChecker_Env.solver = - (e.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (e.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (e.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (e.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (e.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (e.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (e.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (e.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (e.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (e.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (e.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (e.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (e.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (e.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (e.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (e.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (e.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (e.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (e.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (e.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (e.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (e.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (e.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = false; - FStar_TypeChecker_Env.intactics = - (e.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (e.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (e.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (e.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (e.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (e.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (e.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (e.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (e.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (e.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (e.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (e.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (e.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (e.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (e.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (e.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (e.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (e.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (e.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (e.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (e.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (e.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (e.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (e.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (e.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (e.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (e.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (e.FStar_TypeChecker_Env.missing_decl) - } in - let e2 = - { - FStar_TypeChecker_Env.solver = - (e1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (e1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (e1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (e1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (e1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (e1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (e1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (e1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (e1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (e1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (e1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (e1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (e1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (e1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (e1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (e1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (e1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (e1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = true; - FStar_TypeChecker_Env.lax_universes = - (e1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (e1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (e1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (e1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (e1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (e1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (e1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (e1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (e1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (e1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (e1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (e1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (e1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (e1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (e1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (e1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (e1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (e1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (e1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (e1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (e1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (e1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (e1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (e1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (e1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (e1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (e1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (e1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (e1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (e1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (e1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (e1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (e1.FStar_TypeChecker_Env.missing_decl) - } in - let e3 = - { - FStar_TypeChecker_Env.solver = - (e2.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (e2.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (e2.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (e2.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (e2.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (e2.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (e2.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (e2.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (e2.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (e2.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (e2.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (e2.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (e2.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = []; - FStar_TypeChecker_Env.top_level = - (e2.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (e2.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (e2.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (e2.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (e2.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (e2.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (e2.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (e2.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (e2.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (e2.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (e2.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (e2.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (e2.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (e2.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (e2.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (e2.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (e2.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (e2.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (e2.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (e2.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (e2.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (e2.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (e2.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (e2.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (e2.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (e2.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (e2.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (e2.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (e2.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (e2.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (e2.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (e2.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (e2.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (e2.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (e2.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (e2.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (e2.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (e2.FStar_TypeChecker_Env.missing_decl) - } in - try - (fun uu___2 -> - match () with - | () -> - let uu___3 = FStar_TypeChecker_TcTerm.tc_term e3 t in - ret uu___3) () - with - | FStar_Errors.Error (uu___3, msg, uu___4, uu___5) -> - let uu___6 = tts e3 t in - let uu___7 = - let uu___8 = FStar_TypeChecker_Env.all_binders e3 in - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binder) uu___8 in - let uu___8 = FStar_Errors_Msg.rendermsg msg in - fail3 "Cannot type (3) %s in context (%s). Error = (%s)" - uu___6 uu___7 uu___8)) -let (tcc : - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.comp FStar_Tactics_Monad.tac) - = - fun e -> - fun t -> - let uu___ = - let uu___1 = __tc_lax e t in - let uu___2 = bind () in - uu___2 uu___1 - (fun uu___3 -> - match uu___3 with - | (uu___4, lc, uu___5) -> - let uu___6 = - let uu___7 = FStar_TypeChecker_Common.lcomp_comp lc in - FStar_Pervasives_Native.fst uu___7 in - ret uu___6) in - FStar_Tactics_Monad.wrap_err "tcc" uu___ -let (tc : - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.typ FStar_Tactics_Monad.tac) - = - fun e -> - fun t -> - let uu___ = - let uu___1 = tcc e t in - let uu___2 = bind () in - uu___2 uu___1 (fun c -> ret (FStar_Syntax_Util.comp_result c)) in - FStar_Tactics_Monad.wrap_err "tc" uu___ -let divide : - 'a 'b . - FStar_BigInt.t -> - 'a FStar_Tactics_Monad.tac -> - 'b FStar_Tactics_Monad.tac -> ('a * 'b) FStar_Tactics_Monad.tac - = - fun n -> - fun l -> - fun r -> - let uu___ = bind () in - uu___ FStar_Tactics_Monad.get - (fun p -> - let uu___1 = - try - (fun uu___2 -> - match () with - | () -> - let uu___3 = - let uu___4 = FStar_BigInt.to_int_fs n in - FStar_Compiler_List.splitAt uu___4 - p.FStar_Tactics_Types.goals in - ret uu___3) () - with - | uu___2 -> - FStar_Tactics_Monad.fail "divide: not enough goals" in - let uu___2 = bind () in - uu___2 uu___1 - (fun uu___3 -> - match uu___3 with - | (lgs, rgs) -> - let lp = - { - FStar_Tactics_Types.main_context = - (p.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits = - (p.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = lgs; - FStar_Tactics_Types.smt_goals = []; - FStar_Tactics_Types.depth = - (p.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = - (p.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = - (p.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (p.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = - (p.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness = - (p.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg = - (p.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = - (p.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency = - (p.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure = - (p.FStar_Tactics_Types.dump_on_failure) - } in - let uu___4 = FStar_Tactics_Monad.set lp in - let uu___5 = bind () in - uu___5 uu___4 - (fun uu___6 -> - let uu___7 = bind () in - uu___7 l - (fun a1 -> - let uu___8 = bind () in - uu___8 FStar_Tactics_Monad.get - (fun lp' -> - let rp = - { - FStar_Tactics_Types.main_context = - (lp'.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits = - (lp'.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = rgs; - FStar_Tactics_Types.smt_goals = []; - FStar_Tactics_Types.depth = - (lp'.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = - (lp'.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = - (lp'.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (lp'.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = - (lp'.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness = - (lp'.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg = - (lp'.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = - (lp'.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency = - (lp'.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure - = - (lp'.FStar_Tactics_Types.dump_on_failure) - } in - let uu___9 = FStar_Tactics_Monad.set rp in - let uu___10 = bind () in - uu___10 uu___9 - (fun uu___11 -> - let uu___12 = bind () in - uu___12 r - (fun b1 -> - let uu___13 = bind () in - uu___13 - FStar_Tactics_Monad.get - (fun rp' -> - let p' = - { - FStar_Tactics_Types.main_context - = - (rp'.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits - = - (rp'.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals - = - (FStar_Compiler_List.op_At - lp'.FStar_Tactics_Types.goals - rp'.FStar_Tactics_Types.goals); - FStar_Tactics_Types.smt_goals - = - (FStar_Compiler_List.op_At - lp'.FStar_Tactics_Types.smt_goals - (FStar_Compiler_List.op_At - rp'.FStar_Tactics_Types.smt_goals - p.FStar_Tactics_Types.smt_goals)); - FStar_Tactics_Types.depth - = - (rp'.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump - = - (rp'.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc - = - (rp'.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range - = - (rp'.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy - = - (rp'.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness - = - (rp'.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg - = - (rp'.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state - = - (rp'.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency - = - (rp'.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure - = - (rp'.FStar_Tactics_Types.dump_on_failure) - } in - let uu___14 = - FStar_Tactics_Monad.set - p' in - let uu___15 = bind () in - uu___15 uu___14 - (fun uu___16 -> - let uu___17 = - bind () in - uu___17 - FStar_Tactics_Monad.remove_solved_goals - (fun uu___18 -> - ret (a1, b1))))))))))) -let focus : 'a . 'a FStar_Tactics_Monad.tac -> 'a FStar_Tactics_Monad.tac = - fun f -> - let uu___ = divide FStar_BigInt.one f idtac in - let uu___1 = bind () in - uu___1 uu___ (fun uu___2 -> match uu___2 with | (a1, ()) -> ret a1) -let rec map : - 'a . 'a FStar_Tactics_Monad.tac -> 'a Prims.list FStar_Tactics_Monad.tac = - fun tau -> - let uu___ = bind () in - uu___ FStar_Tactics_Monad.get - (fun p -> - match p.FStar_Tactics_Types.goals with - | [] -> ret [] - | uu___1::uu___2 -> - let uu___3 = - let uu___4 = map tau in divide FStar_BigInt.one tau uu___4 in - let uu___4 = bind () in - uu___4 uu___3 - (fun uu___5 -> match uu___5 with | (h, t) -> ret (h :: t))) -let (seq : - unit FStar_Tactics_Monad.tac -> - unit FStar_Tactics_Monad.tac -> unit FStar_Tactics_Monad.tac) - = - fun t1 -> - fun t2 -> - let uu___ = - let uu___1 = bind () in - uu___1 t1 - (fun uu___2 -> - let uu___3 = map t2 in - let uu___4 = bind () in uu___4 uu___3 (fun uu___5 -> ret ())) in - focus uu___ -let (should_check_goal_uvar : - FStar_Tactics_Types.goal -> FStar_Syntax_Syntax.should_check_uvar) = - fun g -> - FStar_Syntax_Util.ctx_uvar_should_check - g.FStar_Tactics_Types.goal_ctx_uvar -let (goal_typedness_deps : - FStar_Tactics_Types.goal -> FStar_Syntax_Syntax.ctx_uvar Prims.list) = - fun g -> - FStar_Syntax_Util.ctx_uvar_typedness_deps - g.FStar_Tactics_Types.goal_ctx_uvar -let (bnorm_and_replace : - FStar_Tactics_Types.goal -> unit FStar_Tactics_Monad.tac) = - fun g -> let uu___ = bnorm_goal g in FStar_Tactics_Monad.replace_cur uu___ -let (arrow_one : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - (FStar_TypeChecker_Env.env * FStar_Syntax_Syntax.binder * - FStar_Syntax_Syntax.comp) FStar_Pervasives_Native.option) - = - fun env1 -> - fun t -> - let uu___ = FStar_Syntax_Util.arrow_one_ln t in - match uu___ with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (b, c) -> - let uu___1 = FStar_TypeChecker_Core.open_binders_in_comp env1 [b] c in - (match uu___1 with - | (env2, b1::[], c1) -> - FStar_Pervasives_Native.Some (env2, b1, c1)) -let (intro : unit -> FStar_Syntax_Syntax.binder FStar_Tactics_Monad.tac) = - fun uu___ -> - let uu___1 = - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___2 -> - (fun goal -> - let goal = Obj.magic goal in - let uu___2 = - let uu___3 = FStar_Tactics_Types.goal_env goal in - let uu___4 = - let uu___5 = FStar_Tactics_Types.goal_env goal in - let uu___6 = FStar_Tactics_Types.goal_type goal in - whnf uu___5 uu___6 in - arrow_one uu___3 uu___4 in - match uu___2 with - | FStar_Pervasives_Native.Some (env', b, c) -> - Obj.magic - (Obj.repr - (let uu___3 = - let uu___4 = FStar_Syntax_Util.is_total_comp c in - Prims.op_Negation uu___4 in - if uu___3 - then - Obj.repr - (FStar_Tactics_Monad.fail - "Codomain is effectful") - else - Obj.repr - (let typ' = FStar_Syntax_Util.comp_result c in - let uu___5 = - let uu___6 = - let uu___7 = should_check_goal_uvar goal in - FStar_Pervasives_Native.Some uu___7 in - let uu___7 = goal_typedness_deps goal in - FStar_Tactics_Monad.new_uvar "intro" env' - typ' uu___6 uu___7 (rangeof goal) in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___5) - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = Obj.magic uu___6 in - match uu___6 with - | (body, ctx_uvar) -> - let sol = - let uu___7 = - let uu___8 = - FStar_Syntax_Util.residual_comp_of_comp - c in - FStar_Pervasives_Native.Some - uu___8 in - FStar_Syntax_Util.abs [b] body - uu___7 in - let uu___7 = - set_solution goal sol in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___7 - (fun uu___8 -> - (fun uu___8 -> - let uu___8 = - Obj.magic uu___8 in - let g = - FStar_Tactics_Types.mk_goal - env' ctx_uvar - goal.FStar_Tactics_Types.opts - goal.FStar_Tactics_Types.is_guard - goal.FStar_Tactics_Types.label in - let uu___9 = - bnorm_and_replace g in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___9 - (fun uu___10 -> - (fun uu___10 - -> - let uu___10 - = - Obj.magic - uu___10 in - Obj.magic - ( - ret b)) - uu___10))) - uu___8))) uu___6)))) - | FStar_Pervasives_Native.None -> - Obj.magic - (Obj.repr - (let uu___3 = - let uu___4 = FStar_Tactics_Types.goal_env goal in - let uu___5 = FStar_Tactics_Types.goal_type goal in - tts uu___4 uu___5 in - fail1 "goal is not an arrow (%s)" uu___3))) uu___2)) in - FStar_Tactics_Monad.wrap_err "intro" uu___1 -let (intro_rec : - unit -> - (FStar_Syntax_Syntax.binder * FStar_Syntax_Syntax.binder) - FStar_Tactics_Monad.tac) - = - fun uu___ -> - (fun uu___ -> - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___1 -> - (fun goal -> - let goal = Obj.magic goal in - FStar_Compiler_Util.print_string - "WARNING (intro_rec): calling this is known to cause normalizer loops\n"; - FStar_Compiler_Util.print_string - "WARNING (intro_rec): proceed at your own risk...\n"; - (let uu___3 = - let uu___4 = FStar_Tactics_Types.goal_env goal in - let uu___5 = - let uu___6 = FStar_Tactics_Types.goal_env goal in - let uu___7 = FStar_Tactics_Types.goal_type goal in - whnf uu___6 uu___7 in - arrow_one uu___4 uu___5 in - match uu___3 with - | FStar_Pervasives_Native.Some (env', b, c) -> - Obj.magic - (Obj.repr - (let uu___4 = - let uu___5 = FStar_Syntax_Util.is_total_comp c in - Prims.op_Negation uu___5 in - if uu___4 - then - Obj.repr - (FStar_Tactics_Monad.fail - "Codomain is effectful") - else - Obj.repr - (let bv = - let uu___6 = - FStar_Tactics_Types.goal_type goal in - FStar_Syntax_Syntax.gen_bv "__recf" - FStar_Pervasives_Native.None uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - should_check_goal_uvar goal in - FStar_Pervasives_Native.Some uu___8 in - let uu___8 = goal_typedness_deps goal in - FStar_Tactics_Monad.new_uvar "intro_rec" - env' (FStar_Syntax_Util.comp_result c) - uu___7 uu___8 (rangeof goal) in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___6) - (fun uu___7 -> - (fun uu___7 -> - let uu___7 = Obj.magic uu___7 in - match uu___7 with - | (u, ctx_uvar_u) -> - let lb = - let uu___8 = - FStar_Tactics_Types.goal_type - goal in - let uu___9 = - FStar_Syntax_Util.abs - [b] u - FStar_Pervasives_Native.None in - FStar_Syntax_Util.mk_letbinding - (FStar_Pervasives.Inl bv) - [] uu___8 - FStar_Parser_Const.effect_Tot_lid - uu___9 [] - FStar_Compiler_Range_Type.dummyRange in - let body = - FStar_Syntax_Syntax.bv_to_name - bv in - let uu___8 = - FStar_Syntax_Subst.close_let_rec - [lb] body in - (match uu___8 with - | (lbs, body1) -> - let tm = - let uu___9 = - let uu___10 = - FStar_Tactics_Types.goal_witness - goal in - uu___10.FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs - = (true, lbs); - FStar_Syntax_Syntax.body1 - = body1 - }) uu___9 in - let uu___9 = - set_solution goal tm in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___9 - (fun uu___10 -> - (fun uu___10 -> - let uu___10 = - Obj.magic - uu___10 in - let uu___11 = - bnorm_and_replace - { - FStar_Tactics_Types.goal_main_env - = - (goal.FStar_Tactics_Types.goal_main_env); - FStar_Tactics_Types.goal_ctx_uvar - = - ctx_uvar_u; - FStar_Tactics_Types.opts - = - (goal.FStar_Tactics_Types.opts); - FStar_Tactics_Types.is_guard - = - (goal.FStar_Tactics_Types.is_guard); - FStar_Tactics_Types.label - = - (goal.FStar_Tactics_Types.label) - } in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___11 - (fun - uu___12 - -> - (fun - uu___12 - -> - let uu___12 - = - Obj.magic - uu___12 in - let uu___13 - = - let uu___14 - = - FStar_Syntax_Syntax.mk_binder - bv in - (uu___14, - b) in - Obj.magic - (ret - uu___13)) - uu___12))) - uu___10)))) - uu___7)))) - | FStar_Pervasives_Native.None -> - Obj.magic - (Obj.repr - (let uu___4 = - let uu___5 = FStar_Tactics_Types.goal_env goal in - let uu___6 = - FStar_Tactics_Types.goal_type goal in - tts uu___5 uu___6 in - fail1 "intro_rec: goal is not an arrow (%s)" - uu___4)))) uu___1))) uu___ -let (norm : - FStar_Pervasives.norm_step Prims.list -> unit FStar_Tactics_Monad.tac) = - fun s -> - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___ -> - (fun goal -> - let goal = Obj.magic goal in - let uu___ = - FStar_Tactics_Monad.if_verbose - (fun uu___1 -> - let uu___2 = - let uu___3 = FStar_Tactics_Types.goal_witness goal in - FStar_Class_Show.show FStar_Syntax_Print.showable_term - uu___3 in - FStar_Compiler_Util.print1 "norm: witness = %s\n" uu___2) in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - () uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - let steps = - let uu___2 = - FStar_TypeChecker_Cfg.translate_norm_steps s in - FStar_Compiler_List.op_At - [FStar_TypeChecker_Env.Reify; - FStar_TypeChecker_Env.DontUnfoldAttr - [FStar_Parser_Const.tac_opaque_attr]] uu___2 in - let t = - let uu___2 = FStar_Tactics_Types.goal_env goal in - let uu___3 = FStar_Tactics_Types.goal_type goal in - normalize steps uu___2 uu___3 in - let uu___2 = goal_with_type goal t in - Obj.magic (FStar_Tactics_Monad.replace_cur uu___2)) - uu___1))) uu___) -let (norm_term_env : - env -> - FStar_Pervasives.norm_step Prims.list -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term FStar_Tactics_Monad.tac) - = - fun e -> - fun s -> - fun t -> - let uu___ = - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - () (Obj.magic FStar_Tactics_Monad.get) - (fun uu___1 -> - (fun ps -> - let ps = Obj.magic ps in - let uu___1 = - FStar_Tactics_Monad.if_verbose - (fun uu___2 -> - let uu___3 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.print1 - "norm_term_env: t = %s\n" uu___3) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () uu___1 - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - let uu___3 = __tc_lax e t in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___3) - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - match uu___4 with - | (t1, uu___5, uu___6) -> - let steps = - let uu___7 = - FStar_TypeChecker_Cfg.translate_norm_steps - s in - FStar_Compiler_List.op_At - [FStar_TypeChecker_Env.Reify; - FStar_TypeChecker_Env.DontUnfoldAttr - [FStar_Parser_Const.tac_opaque_attr]] - uu___7 in - let t2 = - normalize steps - ps.FStar_Tactics_Types.main_context - t1 in - let uu___7 = - FStar_Tactics_Monad.if_verbose - (fun uu___8 -> - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t2 in - FStar_Compiler_Util.print1 - "norm_term_env: t' = %s\n" - uu___9) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___7 - (fun uu___8 -> - (fun uu___8 -> - let uu___8 = - Obj.magic uu___8 in - Obj.magic (ret t2)) - uu___8))) uu___4))) - uu___2))) uu___1)) in - FStar_Tactics_Monad.wrap_err "norm_term" uu___ -let (refine_intro : unit -> unit FStar_Tactics_Monad.tac) = - fun uu___ -> - let uu___1 = - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___2 -> - (fun g -> - let g = Obj.magic g in - let uu___2 = - let uu___3 = FStar_Tactics_Types.goal_env g in - let uu___4 = FStar_Tactics_Types.goal_type g in - FStar_TypeChecker_Rel.base_and_refinement uu___3 uu___4 in - match uu___2 with - | (uu___3, FStar_Pervasives_Native.None) -> - Obj.magic (FStar_Tactics_Monad.fail "not a refinement") - | (t, FStar_Pervasives_Native.Some (bv, phi)) -> - (mark_goal_implicit_already_checked g; - (let g1 = goal_with_type g t in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = FStar_Syntax_Syntax.mk_binder bv in - [uu___7] in - FStar_Syntax_Subst.open_term uu___6 phi in - match uu___5 with - | (bvs, phi1) -> - let uu___6 = - let uu___7 = FStar_Compiler_List.hd bvs in - uu___7.FStar_Syntax_Syntax.binder_bv in - (uu___6, phi1) in - match uu___4 with - | (bv1, phi1) -> - let uu___5 = - let uu___6 = FStar_Tactics_Types.goal_env g in - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Tactics_Types.goal_witness g in - (bv1, uu___11) in - FStar_Syntax_Syntax.NT uu___10 in - [uu___9] in - FStar_Syntax_Subst.subst uu___8 phi1 in - let uu___8 = - let uu___9 = should_check_goal_uvar g in - FStar_Pervasives_Native.Some uu___9 in - FStar_Tactics_Monad.mk_irrelevant_goal - "refine_intro refinement" uu___6 uu___7 uu___8 - (rangeof g) g.FStar_Tactics_Types.opts - g.FStar_Tactics_Types.label in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___5) - (fun uu___6 -> - (fun g2 -> - let g2 = Obj.magic g2 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - FStar_Tactics_Monad.dismiss - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = Obj.magic uu___6 in - Obj.magic - (FStar_Tactics_Monad.add_goals - [g1; g2])) uu___6))) - uu___6))))) uu___2) in - FStar_Tactics_Monad.wrap_err "refine_intro" uu___1 -let (__exact_now : - Prims.bool -> FStar_Syntax_Syntax.term -> unit FStar_Tactics_Monad.tac) = - fun set_expected_typ -> - fun t -> - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___ -> - (fun goal -> - let goal = Obj.magic goal in - let env1 = - if set_expected_typ - then - let uu___ = FStar_Tactics_Types.goal_env goal in - let uu___1 = FStar_Tactics_Types.goal_type goal in - FStar_TypeChecker_Env.set_expected_typ uu___ uu___1 - else FStar_Tactics_Types.goal_env goal in - let uu___ = __tc env1 t in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac - () () (Obj.magic uu___) - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - match uu___1 with - | (t1, typ, guard) -> - let uu___2 = - FStar_Tactics_Monad.if_verbose - (fun uu___3 -> - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term typ in - let uu___5 = - let uu___6 = - FStar_Tactics_Types.goal_env goal in - FStar_TypeChecker_Rel.guard_to_string - uu___6 guard in - FStar_Compiler_Util.print2 - "__exact_now: got type %s\n__exact_now: and guard %s\n" - uu___4 uu___5) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () uu___2 - (fun uu___3 -> - (fun uu___3 -> - let uu___3 = Obj.magic uu___3 in - let uu___4 = - let uu___5 = - FStar_Tactics_Types.goal_env goal in - let uu___6 = - let uu___7 = - should_check_goal_uvar goal in - FStar_Pervasives_Native.Some - uu___7 in - proc_guard "__exact typing" uu___5 - guard uu___6 (rangeof goal) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () - () uu___4 - (fun uu___5 -> - (fun uu___5 -> - let uu___5 = - Obj.magic uu___5 in - let uu___6 = - FStar_Tactics_Monad.if_verbose - (fun uu___7 -> - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - typ in - let uu___9 = - let uu___10 = - FStar_Tactics_Types.goal_type - goal in - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - uu___10 in - FStar_Compiler_Util.print2 - "__exact_now: unifying %s and %s\n" - uu___8 uu___9) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___6 - (fun uu___7 -> - (fun uu___7 -> - let uu___7 = - Obj.magic - uu___7 in - let uu___8 = - let uu___9 = - FStar_Tactics_Types.goal_env - goal in - let uu___10 = - FStar_Tactics_Types.goal_type - goal in - do_unify true - uu___9 typ - uu___10 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic - uu___8) - (fun - uu___9 -> - (fun b -> - let b = - Obj.magic - b in - if b - then - (mark_goal_implicit_already_checked - goal; - Obj.magic - (solve - goal t1)) - else - (let uu___10 - = - let uu___11 - = - let uu___12 - = - FStar_Tactics_Types.goal_env - goal in - tts - uu___12 in - let uu___12 - = - FStar_Tactics_Types.goal_type - goal in - FStar_TypeChecker_Err.print_discrepancy - uu___11 - typ - uu___12 in - match uu___10 - with - | - (typ1, - goalt) -> - let uu___11 - = - let uu___12 - = - FStar_Tactics_Types.goal_env - goal in - tts - uu___12 - t1 in - let uu___12 - = - let uu___13 - = - FStar_Tactics_Types.goal_env - goal in - let uu___14 - = - FStar_Tactics_Types.goal_witness - goal in - tts - uu___13 - uu___14 in - Obj.magic - (fail4 - "%s : %s does not exactly solve the goal %s (witness = %s)" - uu___11 - typ1 - goalt - uu___12))) - uu___9))) - uu___7))) uu___5))) - uu___3))) uu___1))) uu___) -let (t_exact : - Prims.bool -> - Prims.bool -> FStar_Syntax_Syntax.term -> unit FStar_Tactics_Monad.tac) - = - fun try_refine -> - fun set_expected_typ -> - fun tm -> - let uu___ = - let uu___1 = - FStar_Tactics_Monad.if_verbose - (fun uu___2 -> - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term tm in - FStar_Compiler_Util.print1 "t_exact: tm = %s\n" uu___3) in - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___1 - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - let uu___3 = - let uu___4 = __exact_now set_expected_typ tm in - FStar_Tactics_Monad.catch uu___4 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () (Obj.magic uu___3) - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - match uu___4 with - | FStar_Pervasives.Inr r -> Obj.magic (ret ()) - | FStar_Pervasives.Inl e when - Prims.op_Negation try_refine -> - Obj.magic (FStar_Tactics_Monad.traise e) - | FStar_Pervasives.Inl e -> - let uu___5 = - FStar_Tactics_Monad.if_verbose - (fun uu___6 -> - FStar_Compiler_Util.print_string - "__exact_now failed, trying refine...\n") in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - uu___5 - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = Obj.magic uu___6 in - let uu___7 = - let uu___8 = - let uu___9 = - norm - [FStar_Pervasives.Delta] in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___9 - (fun uu___10 -> - (fun uu___10 -> - let uu___10 = - Obj.magic uu___10 in - let uu___11 = - refine_intro () in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___11 - (fun uu___12 -> - (fun uu___12 - -> - let uu___12 - = - Obj.magic - uu___12 in - Obj.magic - (__exact_now - set_expected_typ - tm)) - uu___12))) - uu___10) in - FStar_Tactics_Monad.catch - uu___8 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () (Obj.magic uu___7) - (fun uu___8 -> - (fun uu___8 -> - let uu___8 = - Obj.magic uu___8 in - match uu___8 with - | FStar_Pervasives.Inr - r -> - let uu___9 = - FStar_Tactics_Monad.if_verbose - (fun uu___10 - -> - FStar_Compiler_Util.print_string - "__exact_now: failed after refining too\n") in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___9 - (fun uu___10 - -> - (fun - uu___10 - -> - let uu___10 - = - Obj.magic - uu___10 in - Obj.magic - (ret ())) - uu___10)) - | FStar_Pervasives.Inl - uu___9 -> - let uu___10 = - FStar_Tactics_Monad.if_verbose - (fun uu___11 - -> - FStar_Compiler_Util.print_string - "__exact_now: was not a refinement\n") in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___10 - (fun uu___11 - -> - (fun - uu___11 - -> - let uu___11 - = - Obj.magic - uu___11 in - Obj.magic - (FStar_Tactics_Monad.traise - e)) - uu___11))) - uu___8))) uu___6))) - uu___4))) uu___2) in - FStar_Tactics_Monad.wrap_err "exact" uu___ -let (try_unify_by_application : - FStar_Syntax_Syntax.should_check_uvar FStar_Pervasives_Native.option -> - Prims.bool -> - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> - FStar_Compiler_Range_Type.range -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.aqual * - FStar_Syntax_Syntax.ctx_uvar) Prims.list - FStar_Tactics_Monad.tac) - = - fun should_check -> - fun only_match -> - fun e -> - fun ty1 -> - fun ty2 -> - fun rng -> - let f = if only_match then do_match else do_unify in - let must_tot = true in - let rec aux uu___2 uu___1 uu___ = - (fun acc -> - fun typedness_deps -> - fun ty11 -> - let uu___ = f must_tot e ty2 ty11 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___) - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - if uu___1 - then Obj.magic (Obj.repr (ret acc)) - else - Obj.magic - (Obj.repr - (let uu___2 = - FStar_Syntax_Util.arrow_one ty11 in - match uu___2 with - | FStar_Pervasives_Native.None -> - Obj.repr - (let uu___3 = tts e ty11 in - let uu___4 = tts e ty2 in - fail2 - "Could not instantiate, %s to %s" - uu___3 uu___4) - | FStar_Pervasives_Native.Some - (b, c) -> - Obj.repr - (let uu___3 = - let uu___4 = - FStar_Syntax_Util.is_total_comp - c in - Prims.op_Negation uu___4 in - if uu___3 - then - Obj.repr - (FStar_Tactics_Monad.fail - "Codomain is effectful") - else - Obj.repr - (let uu___5 = - FStar_Tactics_Monad.new_uvar - "apply arg" e - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort - should_check - typedness_deps rng in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic uu___5) - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = - Obj.magic - uu___6 in - match uu___6 - with - | (uvt, uv) -> - let uu___7 - = - FStar_Tactics_Monad.if_verbose - (fun - uu___8 -> - let uu___9 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_ctxu - uv in - FStar_Compiler_Util.print1 - "t_apply: generated uvar %s\n" - uu___9) in - Obj.magic - ( - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___7 - (fun - uu___8 -> - (fun - uu___8 -> - let uu___8 - = - Obj.magic - uu___8 in - let typ = - FStar_Syntax_Util.comp_result - c in - let typ' - = - FStar_Syntax_Subst.subst - [ - FStar_Syntax_Syntax.NT - ((b.FStar_Syntax_Syntax.binder_bv), - uvt)] typ in - let uu___9 - = - let uu___10 - = - let uu___11 - = - FStar_Syntax_Util.aqual_of_binder - b in - (uvt, - uu___11, - uv) in - uu___10 - :: acc in - Obj.magic - (aux - uu___9 - (uv :: - typedness_deps) - typ')) - uu___8))) - uu___6)))))) - uu___1))) uu___2 uu___1 uu___ in - aux [] [] ty1 -let (apply_implicits_as_goals : - FStar_TypeChecker_Env.env -> - FStar_Tactics_Types.goal FStar_Pervasives_Native.option -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.ctx_uvar) Prims.list -> - FStar_Tactics_Types.goal Prims.list Prims.list - FStar_Tactics_Monad.tac) - = - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun env1 -> - fun gl -> - fun imps -> - let one_implicit_as_goal uu___ = - match uu___ with - | (term, ctx_uvar) -> - let uu___1 = FStar_Syntax_Util.head_and_args term in - (match uu___1 with - | (hd, uu___2) -> - let uu___3 = - let uu___4 = FStar_Syntax_Subst.compress hd in - uu___4.FStar_Syntax_Syntax.n in - (match uu___3 with - | FStar_Syntax_Syntax.Tm_uvar (ctx_uvar1, uu___4) - -> - let gl1 = - match gl with - | FStar_Pervasives_Native.None -> - let uu___5 = FStar_Options.peek () in - FStar_Tactics_Types.mk_goal env1 - ctx_uvar1 uu___5 true - "goal for unsolved implicit" - | FStar_Pervasives_Native.Some gl2 -> - { - FStar_Tactics_Types.goal_main_env = - (gl2.FStar_Tactics_Types.goal_main_env); - FStar_Tactics_Types.goal_ctx_uvar = - ctx_uvar1; - FStar_Tactics_Types.opts = - (gl2.FStar_Tactics_Types.opts); - FStar_Tactics_Types.is_guard = - (gl2.FStar_Tactics_Types.is_guard); - FStar_Tactics_Types.label = - (gl2.FStar_Tactics_Types.label) - } in - let gl2 = bnorm_goal gl1 in ret [gl2] - | uu___4 -> ret [])) in - Obj.magic - (FStar_Class_Monad.mapM FStar_Tactics_Monad.monad_tac () () - (fun uu___ -> (Obj.magic one_implicit_as_goal) uu___) - (Obj.magic imps))) uu___2 uu___1 uu___ -let (t_apply : - Prims.bool -> - Prims.bool -> - Prims.bool -> FStar_Syntax_Syntax.term -> unit FStar_Tactics_Monad.tac) - = - fun uopt -> - fun only_match -> - fun tc_resolved_uvars -> - fun tm -> - let uu___ = - let tc_resolved_uvars1 = true in - let uu___1 = - FStar_Tactics_Monad.if_verbose - (fun uu___2 -> - let uu___3 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) uopt in - let uu___4 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) only_match in - let uu___5 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - tc_resolved_uvars1 in - let uu___6 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - tm in - FStar_Compiler_Util.print4 - "t_apply: uopt %s, only_match %s, tc_resolved_uvars %s, tm = %s\n" - uu___3 uu___4 uu___5 uu___6) in - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___1 - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.get) - (fun uu___3 -> - (fun ps -> - let ps = Obj.magic ps in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___3 -> - (fun goal -> - let goal = Obj.magic goal in - let e = - FStar_Tactics_Types.goal_env goal in - let should_check = - should_check_goal_uvar goal in - FStar_Tactics_Monad.register_goal - goal; - (let uu___4 = __tc e tm in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () (Obj.magic uu___4) - (fun uu___5 -> - (fun uu___5 -> - let uu___5 = - Obj.magic uu___5 in - match uu___5 with - | (tm1, typ, guard) -> - let uu___6 = - FStar_Tactics_Monad.if_verbose - (fun uu___7 -> - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - tm1 in - let uu___9 = - FStar_Tactics_Printing.goal_to_string_verbose - goal in - let uu___10 - = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binding) - e.FStar_TypeChecker_Env.gamma in - let uu___11 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - typ in - let uu___12 - = - FStar_TypeChecker_Rel.guard_to_string - e guard in - FStar_Compiler_Util.print5 - "t_apply: tm = %s\nt_apply: goal = %s\nenv.gamma=%s\ntyp=%s\nguard=%s\n" - uu___8 - uu___9 - uu___10 - uu___11 - uu___12) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___6 - (fun uu___7 -> - (fun uu___7 - -> - let uu___7 - = - Obj.magic - uu___7 in - let typ1 - = - bnorm e - typ in - let uu___8 - = - let uu___9 - = - FStar_Tactics_Types.goal_type - goal in - try_unify_by_application - (FStar_Pervasives_Native.Some - should_check) - only_match - e typ1 - uu___9 - (rangeof - goal) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic - uu___8) - (fun - uu___9 -> - (fun uvs - -> - let uvs = - Obj.magic - uvs in - let uu___9 - = - FStar_Tactics_Monad.if_verbose - (fun - uu___10 - -> - let uu___11 - = - (FStar_Common.string_of_list - ()) - (fun - uu___12 - -> - match uu___12 - with - | - (t, - uu___13, - uu___14) - -> - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t) uvs in - FStar_Compiler_Util.print1 - "t_apply: found args = %s\n" - uu___11) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___9 - (fun - uu___10 - -> - (fun - uu___10 - -> - let uu___10 - = - Obj.magic - uu___10 in - let w = - FStar_Compiler_List.fold_right - (fun - uu___11 - -> - fun w1 -> - match uu___11 - with - | - (uvt, q, - uu___12) - -> - FStar_Syntax_Util.mk_app - w1 - [ - (uvt, q)]) - uvs tm1 in - let uvset - = - let uu___11 - = - Obj.magic - (FStar_Class_Setlike.empty - () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) - ()) in - FStar_Compiler_List.fold_right - (fun - uu___13 - -> - fun - uu___12 - -> - (fun - uu___12 - -> - fun s -> - match uu___12 - with - | - (uu___13, - uu___14, - uv) -> - let uu___15 - = - let uu___16 - = - FStar_Syntax_Util.ctx_uvar_typ - uv in - FStar_Syntax_Free.uvars - uu___16 in - Obj.magic - (FStar_Class_Setlike.union - () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) - (Obj.magic - s) - (Obj.magic - uu___15))) - uu___13 - uu___12) - uvs - uu___11 in - let free_in_some_goal - uv = - FStar_Class_Setlike.mem - () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) - uv - (Obj.magic - uvset) in - let uu___11 - = - solve' - goal w in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___11 - (fun - uu___12 - -> - (fun - uu___12 - -> - let uu___12 - = - Obj.magic - uu___12 in - let uvt_uv_l - = - FStar_Compiler_List.map - (fun - uu___13 - -> - match uu___13 - with - | - (uvt, _q, - uv) -> - (uvt, uv)) - uvs in - let uu___13 - = - apply_implicits_as_goals - e - (FStar_Pervasives_Native.Some - goal) - uvt_uv_l in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic - uu___13) - (fun - uu___14 - -> - (fun - sub_goals - -> - let sub_goals - = - Obj.magic - sub_goals in - let sub_goals1 - = - let uu___14 - = - let uu___15 - = - FStar_Compiler_List.filter - (fun g -> - let uu___16 - = - uopt && - (free_in_some_goal - g.FStar_Tactics_Types.goal_ctx_uvar) in - Prims.op_Negation - uu___16) - (FStar_Compiler_List.flatten - sub_goals) in - FStar_Compiler_List.map - bnorm_goal - uu___15 in - FStar_Compiler_List.rev - uu___14 in - let uu___14 - = - FStar_Tactics_Monad.add_goals - sub_goals1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___14 - (fun - uu___15 - -> - (fun - uu___15 - -> - let uu___15 - = - Obj.magic - uu___15 in - Obj.magic - (proc_guard - "apply guard" - e guard - (FStar_Pervasives_Native.Some - should_check) - (rangeof - goal))) - uu___15))) - uu___14))) - uu___12))) - uu___10))) - uu___9))) - uu___7))) - uu___5)))) uu___3))) - uu___3))) uu___2) in - FStar_Tactics_Monad.wrap_err "apply" uu___ -let (lemma_or_sq : - FStar_Syntax_Syntax.comp -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.term) - FStar_Pervasives_Native.option) - = - fun c -> - let uu___ = FStar_Syntax_Util.comp_eff_name_res_and_args c in - match uu___ with - | (eff_name, res, args) -> - let uu___1 = - FStar_Ident.lid_equals eff_name FStar_Parser_Const.effect_Lemma_lid in - if uu___1 - then - let uu___2 = - match args with - | pre::post::uu___3 -> - ((FStar_Pervasives_Native.fst pre), - (FStar_Pervasives_Native.fst post)) - | uu___3 -> failwith "apply_lemma: impossible: not a lemma" in - (match uu___2 with - | (pre, post) -> - let post1 = - let uu___3 = - let uu___4 = - FStar_Syntax_Syntax.as_arg FStar_Syntax_Util.exp_unit in - [uu___4] in - FStar_Syntax_Util.mk_app post uu___3 in - FStar_Pervasives_Native.Some (pre, post1)) - else - (let uu___3 = - (FStar_Syntax_Util.is_pure_effect eff_name) || - (FStar_Syntax_Util.is_ghost_effect eff_name) in - if uu___3 - then - let uu___4 = FStar_Syntax_Util.un_squash res in - FStar_Compiler_Util.map_opt uu___4 - (fun post -> (FStar_Syntax_Util.t_true, post)) - else FStar_Pervasives_Native.None) -let rec fold_left : - 'a 'b . - ('a -> 'b -> 'b FStar_Tactics_Monad.tac) -> - 'b -> 'a Prims.list -> 'b FStar_Tactics_Monad.tac - = - fun f -> - fun e -> - fun xs -> - match xs with - | [] -> ret e - | x::xs1 -> - let uu___ = f x e in - let uu___1 = bind () in - uu___1 uu___ (fun e' -> fold_left f e' xs1) -let (t_apply_lemma : - Prims.bool -> - Prims.bool -> FStar_Syntax_Syntax.term -> unit FStar_Tactics_Monad.tac) - = - fun noinst -> - fun noinst_lhs -> - fun tm -> - let uu___ = - let uu___1 = - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.get) - (fun uu___2 -> - (fun ps -> - let ps = Obj.magic ps in - let uu___2 = - FStar_Tactics_Monad.if_verbose - (fun uu___3 -> - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term tm in - FStar_Compiler_Util.print1 - "apply_lemma: tm = %s\n" uu___4) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () uu___2 - (fun uu___3 -> - (fun uu___3 -> - let uu___3 = Obj.magic uu___3 in - let is_unit_t t = - let uu___4 = - let uu___5 = FStar_Syntax_Subst.compress t in - uu___5.FStar_Syntax_Syntax.n in - match uu___4 with - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.unit_lid - -> true - | uu___5 -> false in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___4 -> - (fun goal -> - let goal = Obj.magic goal in - let env1 = - FStar_Tactics_Types.goal_env goal in - FStar_Tactics_Monad.register_goal - goal; - (let uu___5 = __tc env1 tm in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () (Obj.magic uu___5) - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = - Obj.magic uu___6 in - match uu___6 with - | (tm1, t, guard) -> - let uu___7 = - FStar_Syntax_Util.arrow_formals_comp - t in - (match uu___7 with - | (bs, comp) -> - let uu___8 = - lemma_or_sq - comp in - (match uu___8 - with - | FStar_Pervasives_Native.None - -> - Obj.magic - (FStar_Tactics_Monad.fail - "not a lemma or squashed function") - | FStar_Pervasives_Native.Some - (pre, - post) -> - let uu___9 - = - fold_left - (fun - uu___11 - -> - fun - uu___10 - -> - (fun - uu___10 - -> - fun - uu___11 - -> - match - (uu___10, - uu___11) - with - | - ({ - FStar_Syntax_Syntax.binder_bv - = b; - FStar_Syntax_Syntax.binder_qual - = aq; - FStar_Syntax_Syntax.binder_positivity - = uu___12; - FStar_Syntax_Syntax.binder_attrs - = uu___13;_}, - (uvs, - deps, - imps, - subst)) - -> - let b_t = - FStar_Syntax_Subst.subst - subst - b.FStar_Syntax_Syntax.sort in - let uu___14 - = - is_unit_t - b_t in - if - uu___14 - then - Obj.magic - (Obj.repr - (ret - (((FStar_Syntax_Util.exp_unit, - aq) :: - uvs), - deps, - imps, - ((FStar_Syntax_Syntax.NT - (b, - FStar_Syntax_Util.exp_unit)) - :: - subst)))) - else - Obj.magic - (Obj.repr - (let uu___16 - = - let uu___17 - = - let uu___18 - = - let uu___19 - = - should_check_goal_uvar - goal in - match uu___19 - with - | - FStar_Syntax_Syntax.Strict - -> - FStar_Syntax_Syntax.Allow_ghost - "apply lemma uvar" - | - x -> x in - FStar_Pervasives_Native.Some - uu___18 in - FStar_Tactics_Monad.new_uvar - "apply_lemma" - env1 b_t - uu___17 - deps - (rangeof - goal) in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic - uu___16) - (fun - uu___17 - -> - (fun - uu___17 - -> - let uu___17 - = - Obj.magic - uu___17 in - match uu___17 - with - | - (t1, u) - -> - (( - let uu___19 - = - (FStar_Compiler_Debug.medium - ()) || - (FStar_Compiler_Effect.op_Bang - dbg_2635) in - if - uu___19 - then - let uu___20 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_ctxu - u in - let uu___21 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - tm1 in - FStar_Compiler_Util.print2 - "Apply lemma created a new uvar %s while applying %s\n" - uu___20 - uu___21 - else ()); - Obj.magic - (ret - (((t1, - aq) :: - uvs), (u - :: deps), - ((t1, u) - :: imps), - ((FStar_Syntax_Syntax.NT - (b, t1)) - :: - subst))))) - uu___17)))) - uu___11 - uu___10) - ([], [], - [], []) - bs in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic - uu___9) - (fun - uu___10 - -> - (fun - uu___10 - -> - let uu___10 - = - Obj.magic - uu___10 in - match uu___10 - with - | - (uvs, - uu___11, - implicits1, - subst) -> - let implicits2 - = - FStar_Compiler_List.rev - implicits1 in - let uvs1 - = - FStar_Compiler_List.rev - uvs in - let pre1 - = - FStar_Syntax_Subst.subst - subst pre in - let post1 - = - FStar_Syntax_Subst.subst - subst - post in - let post_u - = - env1.FStar_TypeChecker_Env.universe_of - env1 - post1 in - let cmp_func - = - if noinst - then - do_match - else - if - noinst_lhs - then - do_match_on_lhs - else - do_unify in - let uu___12 - = - let must_tot - = false in - let uu___13 - = - FStar_Tactics_Types.goal_type - goal in - let uu___14 - = - FStar_Syntax_Util.mk_squash - post_u - post1 in - cmp_func - must_tot - env1 - uu___13 - uu___14 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic - uu___12) - (fun - uu___13 - -> - (fun b -> - let b = - Obj.magic - b in - if - Prims.op_Negation - b - then - let uu___13 - = - let uu___14 - = - FStar_Syntax_Util.mk_squash - post_u - post1 in - let uu___15 - = - FStar_Tactics_Types.goal_type - goal in - FStar_TypeChecker_Err.print_discrepancy - (tts env1) - uu___14 - uu___15 in - match uu___13 - with - | - (post2, - goalt) -> - let uu___14 - = - tts env1 - tm1 in - Obj.magic - (fail3 - "Cannot instantiate lemma %s (with postcondition: %s) to match goal (%s)" - uu___14 - post2 - goalt) - else - (let goal_sc - = - should_check_goal_uvar - goal in - let uu___14 - = - solve' - goal - FStar_Syntax_Util.exp_unit in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___14 - (fun - uu___15 - -> - (fun - uu___15 - -> - let uu___15 - = - Obj.magic - uu___15 in - let is_free_uvar - uv t1 = - let free_uvars - = - let uu___16 - = - let uu___17 - = - FStar_Syntax_Free.uvars - t1 in - FStar_Class_Setlike.elems - () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) - (Obj.magic - uu___17) in - FStar_Compiler_List.map - (fun x -> - x.FStar_Syntax_Syntax.ctx_uvar_head) - uu___16 in - FStar_Compiler_List.existsML - (fun u -> - FStar_Syntax_Unionfind.equiv - u uv) - free_uvars in - let appears - uv goals - = - FStar_Compiler_List.existsML - (fun g' - -> - let uu___16 - = - FStar_Tactics_Types.goal_type - g' in - is_free_uvar - uv - uu___16) - goals in - let checkone - t1 goals - = - let uu___16 - = - FStar_Syntax_Util.head_and_args - t1 in - match uu___16 - with - | - (hd, - uu___17) - -> - (match - hd.FStar_Syntax_Syntax.n - with - | - FStar_Syntax_Syntax.Tm_uvar - (uv, - uu___18) - -> - appears - uv.FStar_Syntax_Syntax.ctx_uvar_head - goals - | - uu___18 - -> false) in - let must_tot - = false in - let uu___16 - = - apply_implicits_as_goals - env1 - (FStar_Pervasives_Native.Some - goal) - implicits2 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic - uu___16) - (fun - uu___17 - -> - (fun - sub_goals - -> - let sub_goals - = - Obj.magic - sub_goals in - let sub_goals1 - = - FStar_Compiler_List.flatten - sub_goals in - let rec filter' - f xs = - match xs - with - | - [] -> [] - | - x::xs1 -> - let uu___17 - = f x xs1 in - if - uu___17 - then - let uu___18 - = - filter' f - xs1 in x - :: - uu___18 - else - filter' f - xs1 in - let sub_goals2 - = - filter' - (fun g -> - fun goals - -> - let uu___17 - = - let uu___18 - = - FStar_Tactics_Types.goal_witness - g in - checkone - uu___18 - goals in - Prims.op_Negation - uu___17) - sub_goals1 in - let uu___17 - = - proc_guard - "apply_lemma guard" - env1 - guard - (FStar_Pervasives_Native.Some - goal_sc) - (rangeof - goal) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___17 - (fun - uu___18 - -> - (fun - uu___18 - -> - let uu___18 - = - Obj.magic - uu___18 in - let pre_u - = - env1.FStar_TypeChecker_Env.universe_of - env1 pre1 in - let uu___19 - = - let uu___20 - = - let uu___21 - = - let uu___22 - = - FStar_TypeChecker_Env.guard_of_guard_formula - (FStar_TypeChecker_Common.NonTrivial - pre1) in - FStar_TypeChecker_Rel.simplify_guard - env1 - uu___22 in - uu___21.FStar_TypeChecker_Common.guard_f in - match uu___20 - with - | - FStar_TypeChecker_Common.Trivial - -> - ret () - | - FStar_TypeChecker_Common.NonTrivial - uu___21 - -> - FStar_Tactics_Monad.add_irrelevant_goal - goal - "apply_lemma precondition" - env1 pre1 - (FStar_Pervasives_Native.Some - goal_sc) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___19 - (fun - uu___20 - -> - (fun - uu___20 - -> - let uu___20 - = - Obj.magic - uu___20 in - Obj.magic - (FStar_Tactics_Monad.add_goals - sub_goals2)) - uu___20))) - uu___18))) - uu___17))) - uu___15)))) - uu___13))) - uu___10))))) - uu___6)))) uu___4))) - uu___3))) uu___2) in - focus uu___1 in - FStar_Tactics_Monad.wrap_err "apply_lemma" uu___ -let (split_env : - FStar_Syntax_Syntax.bv -> - env -> - (env * FStar_Syntax_Syntax.bv * FStar_Syntax_Syntax.bv Prims.list) - FStar_Pervasives_Native.option) - = - fun bvar -> - fun e -> - let rec aux e1 = - let uu___ = FStar_TypeChecker_Env.pop_bv e1 in - match uu___ with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (bv', e') -> - let uu___1 = FStar_Syntax_Syntax.bv_eq bvar bv' in - if uu___1 - then FStar_Pervasives_Native.Some (e', bv', []) - else - (let uu___3 = aux e' in - FStar_Compiler_Util.map_opt uu___3 - (fun uu___4 -> - match uu___4 with - | (e'', bv, bvs) -> (e'', bv, (bv' :: bvs)))) in - let uu___ = aux e in - FStar_Compiler_Util.map_opt uu___ - (fun uu___1 -> - match uu___1 with - | (e', bv, bvs) -> (e', bv, (FStar_Compiler_List.rev bvs))) -let (subst_goal : - FStar_Syntax_Syntax.bv -> - FStar_Syntax_Syntax.bv -> - FStar_Tactics_Types.goal -> - (FStar_Syntax_Syntax.bv * FStar_Tactics_Types.goal) - FStar_Pervasives_Native.option FStar_Tactics_Monad.tac) - = - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun b1 -> - fun b2 -> - fun g -> - let uu___ = - let uu___1 = FStar_Tactics_Types.goal_env g in - split_env b1 uu___1 in - match uu___ with - | FStar_Pervasives_Native.Some (e0, b11, bvs) -> - Obj.magic - (Obj.repr - (let bs = - FStar_Compiler_List.map - FStar_Syntax_Syntax.mk_binder (b11 :: bvs) in - let t = FStar_Tactics_Types.goal_type g in - let uu___1 = - let uu___2 = FStar_Syntax_Subst.close_binders bs in - let uu___3 = FStar_Syntax_Subst.close bs t in - (uu___2, uu___3) in - match uu___1 with - | (bs', t') -> - let bs'1 = - let uu___2 = FStar_Syntax_Syntax.mk_binder b2 in - let uu___3 = FStar_Compiler_List.tail bs' in - uu___2 :: uu___3 in - let uu___2 = - FStar_TypeChecker_Core.open_binders_in_term e0 - bs'1 t' in - (match uu___2 with - | (new_env, bs'', t'') -> - let b21 = - let uu___3 = FStar_Compiler_List.hd bs'' in - uu___3.FStar_Syntax_Syntax.binder_bv in - let uu___3 = - let uu___4 = - let uu___5 = should_check_goal_uvar g in - FStar_Pervasives_Native.Some uu___5 in - let uu___5 = goal_typedness_deps g in - FStar_Tactics_Monad.new_uvar "subst_goal" - new_env t'' uu___4 uu___5 (rangeof g) in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___3) - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - match uu___4 with - | (uvt, uv) -> - let goal' = - FStar_Tactics_Types.mk_goal - new_env uv - g.FStar_Tactics_Types.opts - g.FStar_Tactics_Types.is_guard - g.FStar_Tactics_Types.label in - let sol = - let uu___5 = - FStar_Syntax_Util.abs bs'' - uvt - FStar_Pervasives_Native.None in - let uu___6 = - FStar_Compiler_List.map - (fun uu___7 -> - match uu___7 with - | { - FStar_Syntax_Syntax.binder_bv - = bv; - FStar_Syntax_Syntax.binder_qual - = q; - FStar_Syntax_Syntax.binder_positivity - = uu___8; - FStar_Syntax_Syntax.binder_attrs - = uu___9;_} - -> - let uu___10 = - FStar_Syntax_Syntax.bv_to_name - bv in - FStar_Syntax_Syntax.as_arg - uu___10) bs in - FStar_Syntax_Util.mk_app - uu___5 uu___6 in - let uu___5 = set_solution g sol in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___5 - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = - Obj.magic uu___6 in - Obj.magic - (ret - (FStar_Pervasives_Native.Some - (b21, goal')))) - uu___6))) uu___4)))) - | FStar_Pervasives_Native.None -> - Obj.magic (Obj.repr (ret FStar_Pervasives_Native.None))) - uu___2 uu___1 uu___ -let (rewrite : FStar_Syntax_Syntax.binder -> unit FStar_Tactics_Monad.tac) = - fun h -> - let uu___ = - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___1 -> - (fun goal -> - let goal = Obj.magic goal in - let bv = h.FStar_Syntax_Syntax.binder_bv in - let uu___1 = - FStar_Tactics_Monad.if_verbose - (fun uu___2 -> - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_bv - bv in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - bv.FStar_Syntax_Syntax.sort in - FStar_Compiler_Util.print2 "+++Rewrite %s : %s\n" uu___3 - uu___4) in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac - () () uu___1 - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - let uu___3 = - let uu___4 = FStar_Tactics_Types.goal_env goal in - split_env bv uu___4 in - match uu___3 with - | FStar_Pervasives_Native.None -> - Obj.magic - (FStar_Tactics_Monad.fail - "binder not found in environment") - | FStar_Pervasives_Native.Some (e0, bv1, bvs) -> - let uu___4 = - destruct_eq e0 bv1.FStar_Syntax_Syntax.sort in - (match uu___4 with - | FStar_Pervasives_Native.Some (x, e) -> - let uu___5 = - let uu___6 = - FStar_Syntax_Subst.compress x in - uu___6.FStar_Syntax_Syntax.n in - (match uu___5 with - | FStar_Syntax_Syntax.Tm_name x1 -> - let s = - [FStar_Syntax_Syntax.NT (x1, e)] in - let t = - FStar_Tactics_Types.goal_type goal in - let bs = - FStar_Compiler_List.map - FStar_Syntax_Syntax.mk_binder bvs in - let uu___6 = - let uu___7 = - FStar_Syntax_Subst.close_binders - bs in - let uu___8 = - FStar_Syntax_Subst.close bs t in - (uu___7, uu___8) in - (match uu___6 with - | (bs', t') -> - let uu___7 = - let uu___8 = - FStar_Syntax_Subst.subst_binders - s bs' in - let uu___9 = - FStar_Syntax_Subst.subst s t' in - (uu___8, uu___9) in - (match uu___7 with - | (bs'1, t'1) -> - let e01 = - FStar_TypeChecker_Env.push_bvs - e0 [bv1] in - let uu___8 = - FStar_TypeChecker_Core.open_binders_in_term - e01 bs'1 t'1 in - (match uu___8 with - | (new_env, bs'', t'') -> - let uu___9 = - let uu___10 = - let uu___11 = - should_check_goal_uvar - goal in - FStar_Pervasives_Native.Some - uu___11 in - let uu___11 = - goal_typedness_deps - goal in - FStar_Tactics_Monad.new_uvar - "rewrite" new_env - t'' uu___10 uu___11 - (rangeof goal) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic uu___9) - (fun uu___10 -> - (fun uu___10 -> - let uu___10 - = - Obj.magic - uu___10 in - match uu___10 - with - | (uvt, uv) - -> - let goal' - = - FStar_Tactics_Types.mk_goal - new_env - uv - goal.FStar_Tactics_Types.opts - goal.FStar_Tactics_Types.is_guard - goal.FStar_Tactics_Types.label in - let sol = - let uu___11 - = - FStar_Syntax_Util.abs - bs'' uvt - FStar_Pervasives_Native.None in - let uu___12 - = - FStar_Compiler_List.map - (fun - uu___13 - -> - match uu___13 - with - | - { - FStar_Syntax_Syntax.binder_bv - = bv2; - FStar_Syntax_Syntax.binder_qual - = uu___14; - FStar_Syntax_Syntax.binder_positivity - = uu___15; - FStar_Syntax_Syntax.binder_attrs - = uu___16;_} - -> - let uu___17 - = - FStar_Syntax_Syntax.bv_to_name - bv2 in - FStar_Syntax_Syntax.as_arg - uu___17) - bs in - FStar_Syntax_Util.mk_app - uu___11 - uu___12 in - let uu___11 - = - set_solution - goal sol in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___11 - (fun - uu___12 - -> - (fun - uu___12 - -> - let uu___12 - = - Obj.magic - uu___12 in - Obj.magic - (FStar_Tactics_Monad.replace_cur - goal')) - uu___12))) - uu___10))))) - | uu___6 -> - Obj.magic - (FStar_Tactics_Monad.fail - "Not an equality hypothesis with a variable on the LHS")) - | uu___5 -> - Obj.magic - (FStar_Tactics_Monad.fail - "Not an equality hypothesis"))) uu___2))) - uu___1) in - FStar_Tactics_Monad.wrap_err "rewrite" uu___ -let (rename_to : - FStar_Syntax_Syntax.binder -> - Prims.string -> FStar_Syntax_Syntax.binder FStar_Tactics_Monad.tac) - = - fun b -> - fun s -> - let uu___ = - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___1 -> - (fun goal -> - let goal = Obj.magic goal in - let bv = b.FStar_Syntax_Syntax.binder_bv in - let bv' = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Ident.range_of_id - bv.FStar_Syntax_Syntax.ppname in - (s, uu___4) in - FStar_Ident.mk_ident uu___3 in - { - FStar_Syntax_Syntax.ppname = uu___2; - FStar_Syntax_Syntax.index = - (bv.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = - (bv.FStar_Syntax_Syntax.sort) - } in - FStar_Syntax_Syntax.freshen_bv uu___1 in - let uu___1 = subst_goal bv bv' goal in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - match uu___2 with - | FStar_Pervasives_Native.None -> - Obj.magic - (Obj.repr - (FStar_Tactics_Monad.fail - "binder not found in environment")) - | FStar_Pervasives_Native.Some (bv'1, goal1) -> - Obj.magic - (Obj.repr - (let uu___3 = - FStar_Tactics_Monad.replace_cur - goal1 in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - uu___3 - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - Obj.magic - (ret - { - FStar_Syntax_Syntax.binder_bv - = bv'1; - FStar_Syntax_Syntax.binder_qual - = - (b.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity - = - (b.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs - = - (b.FStar_Syntax_Syntax.binder_attrs) - })) uu___4)))) uu___2))) - uu___1)) in - FStar_Tactics_Monad.wrap_err "rename_to" uu___ -let (binder_retype : - FStar_Syntax_Syntax.binder -> unit FStar_Tactics_Monad.tac) = - fun b -> - let uu___ = - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___1 -> - (fun goal -> - let goal = Obj.magic goal in - let bv = b.FStar_Syntax_Syntax.binder_bv in - let uu___1 = - let uu___2 = FStar_Tactics_Types.goal_env goal in - split_env bv uu___2 in - match uu___1 with - | FStar_Pervasives_Native.None -> - Obj.magic - (FStar_Tactics_Monad.fail - "binder is not present in environment") - | FStar_Pervasives_Native.Some (e0, bv1, bvs) -> - let uu___2 = FStar_Syntax_Util.type_u () in - (match uu___2 with - | (ty, u) -> - let goal_sc = should_check_goal_uvar goal in - let uu___3 = - let uu___4 = goal_typedness_deps goal in - FStar_Tactics_Monad.new_uvar "binder_retype" e0 ty - (FStar_Pervasives_Native.Some goal_sc) uu___4 - (rangeof goal) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___3) - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - match uu___4 with - | (t', u_t') -> - let bv'' = - { - FStar_Syntax_Syntax.ppname = - (bv1.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (bv1.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = t' - } in - let s = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Syntax_Syntax.bv_to_name - bv'' in - (bv1, uu___7) in - FStar_Syntax_Syntax.NT uu___6 in - [uu___5] in - let bvs1 = - FStar_Compiler_List.map - (fun b1 -> - let uu___5 = - FStar_Syntax_Subst.subst s - b1.FStar_Syntax_Syntax.sort in - { - FStar_Syntax_Syntax.ppname = - (b1.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (b1.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = - uu___5 - }) bvs in - let env' = - FStar_TypeChecker_Env.push_bvs e0 - (bv'' :: bvs1) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () - () FStar_Tactics_Monad.dismiss - (fun uu___5 -> - (fun uu___5 -> - let uu___5 = - Obj.magic uu___5 in - let new_goal = - let uu___6 = - FStar_Tactics_Types.goal_with_env - goal env' in - let uu___7 = - let uu___8 = - FStar_Tactics_Types.goal_type - goal in - FStar_Syntax_Subst.subst - s uu___8 in - goal_with_type uu___6 - uu___7 in - let uu___6 = - FStar_Tactics_Monad.add_goals - [new_goal] in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___6 - (fun uu___7 -> - (fun uu___7 -> - let uu___7 = - Obj.magic - uu___7 in - let uu___8 = - FStar_Syntax_Util.mk_eq2 - (FStar_Syntax_Syntax.U_succ - u) ty - bv1.FStar_Syntax_Syntax.sort - t' in - Obj.magic - (FStar_Tactics_Monad.add_irrelevant_goal - goal - "binder_retype equation" - e0 uu___8 - (FStar_Pervasives_Native.Some - goal_sc))) - uu___7))) uu___5))) - uu___4)))) uu___1) in - FStar_Tactics_Monad.wrap_err "binder_retype" uu___ -let (norm_binder_type : - FStar_Pervasives.norm_step Prims.list -> - FStar_Syntax_Syntax.binder -> unit FStar_Tactics_Monad.tac) - = - fun s -> - fun b -> - let uu___ = - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___1 -> - (fun goal -> - let goal = Obj.magic goal in - let bv = b.FStar_Syntax_Syntax.binder_bv in - let uu___1 = - let uu___2 = FStar_Tactics_Types.goal_env goal in - split_env bv uu___2 in - match uu___1 with - | FStar_Pervasives_Native.None -> - Obj.magic - (FStar_Tactics_Monad.fail - "binder is not present in environment") - | FStar_Pervasives_Native.Some (e0, bv1, bvs) -> - let steps = - let uu___2 = - FStar_TypeChecker_Cfg.translate_norm_steps s in - FStar_Compiler_List.op_At - [FStar_TypeChecker_Env.Reify; - FStar_TypeChecker_Env.DontUnfoldAttr - [FStar_Parser_Const.tac_opaque_attr]] uu___2 in - let sort' = - normalize steps e0 bv1.FStar_Syntax_Syntax.sort in - let bv' = - { - FStar_Syntax_Syntax.ppname = - (bv1.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (bv1.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = sort' - } in - let env' = FStar_TypeChecker_Env.push_bvs e0 (bv' :: bvs) in - let uu___2 = FStar_Tactics_Types.goal_with_env goal env' in - Obj.magic (FStar_Tactics_Monad.replace_cur uu___2)) - uu___1) in - FStar_Tactics_Monad.wrap_err "norm_binder_type" uu___ -let (revert : unit -> unit FStar_Tactics_Monad.tac) = - fun uu___ -> - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___1 -> - (fun goal -> - let goal = Obj.magic goal in - let uu___1 = - let uu___2 = FStar_Tactics_Types.goal_env goal in - FStar_TypeChecker_Env.pop_bv uu___2 in - match uu___1 with - | FStar_Pervasives_Native.None -> - Obj.magic - (FStar_Tactics_Monad.fail "Cannot revert; empty context") - | FStar_Pervasives_Native.Some (x, env') -> - let typ' = - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.mk_binder x in [uu___3] in - let uu___3 = - let uu___4 = FStar_Tactics_Types.goal_type goal in - FStar_Syntax_Syntax.mk_Total uu___4 in - FStar_Syntax_Util.arrow uu___2 uu___3 in - let uu___2 = - let uu___3 = - let uu___4 = should_check_goal_uvar goal in - FStar_Pervasives_Native.Some uu___4 in - let uu___4 = goal_typedness_deps goal in - FStar_Tactics_Monad.new_uvar "revert" env' typ' uu___3 - uu___4 (rangeof goal) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () (Obj.magic uu___2) - (fun uu___3 -> - (fun uu___3 -> - let uu___3 = Obj.magic uu___3 in - match uu___3 with - | (r, u_r) -> - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Syntax_Syntax.bv_to_name x in - FStar_Syntax_Syntax.as_arg uu___8 in - [uu___7] in - let uu___7 = - let uu___8 = - FStar_Tactics_Types.goal_type goal in - uu___8.FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.mk_Tm_app r uu___6 - uu___7 in - set_solution goal uu___5 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - uu___4 - (fun uu___5 -> - (fun uu___5 -> - let uu___5 = Obj.magic uu___5 in - let g = - FStar_Tactics_Types.mk_goal env' - u_r - goal.FStar_Tactics_Types.opts - goal.FStar_Tactics_Types.is_guard - goal.FStar_Tactics_Types.label in - Obj.magic - (FStar_Tactics_Monad.replace_cur - g)) uu___5))) uu___3))) uu___1) -let (free_in : - FStar_Syntax_Syntax.bv -> FStar_Syntax_Syntax.term -> Prims.bool) = - fun bv -> - fun t -> - let uu___ = FStar_Syntax_Free.names t in - FStar_Class_Setlike.mem () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) bv (Obj.magic uu___) -let (clear : FStar_Syntax_Syntax.binder -> unit FStar_Tactics_Monad.tac) = - fun b -> - let bv = b.FStar_Syntax_Syntax.binder_bv in - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___ -> - (fun goal -> - let goal = Obj.magic goal in - let uu___ = - FStar_Tactics_Monad.if_verbose - (fun uu___1 -> - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_binder - b in - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = FStar_Tactics_Types.goal_env goal in - FStar_TypeChecker_Env.all_binders uu___6 in - FStar_Compiler_List.length uu___5 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_nat) uu___4 in - FStar_Compiler_Util.print2 - "Clear of (%s), env has %s binders\n" uu___2 uu___3) in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - () uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - let uu___2 = - let uu___3 = FStar_Tactics_Types.goal_env goal in - split_env bv uu___3 in - match uu___2 with - | FStar_Pervasives_Native.None -> - Obj.magic - (FStar_Tactics_Monad.fail - "Cannot clear; binder not in environment") - | FStar_Pervasives_Native.Some (e', bv1, bvs) -> - let rec check bvs1 = - match bvs1 with - | [] -> ret () - | bv'::bvs2 -> - let uu___3 = - free_in bv1 bv'.FStar_Syntax_Syntax.sort in - if uu___3 - then - let uu___4 = - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_bv bv' in - FStar_Compiler_Util.format1 - "Cannot clear; binder present in the type of %s" - uu___5 in - FStar_Tactics_Monad.fail uu___4 - else check bvs2 in - let uu___3 = - let uu___4 = FStar_Tactics_Types.goal_type goal in - free_in bv1 uu___4 in - if uu___3 - then - Obj.magic - (FStar_Tactics_Monad.fail - "Cannot clear; binder present in goal") - else - (let uu___5 = check bvs in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () uu___5 - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = Obj.magic uu___6 in - let env' = - FStar_TypeChecker_Env.push_bvs e' - bvs in - let uu___7 = - let uu___8 = - FStar_Tactics_Types.goal_type - goal in - let uu___9 = - let uu___10 = - should_check_goal_uvar goal in - FStar_Pervasives_Native.Some - uu___10 in - let uu___10 = - goal_typedness_deps goal in - FStar_Tactics_Monad.new_uvar - "clear.witness" env' uu___8 - uu___9 uu___10 (rangeof goal) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () (Obj.magic uu___7) - (fun uu___8 -> - (fun uu___8 -> - let uu___8 = - Obj.magic uu___8 in - match uu___8 with - | (ut, uvar_ut) -> - let uu___9 = - set_solution goal - ut in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___9 - (fun uu___10 -> - (fun uu___10 - -> - let uu___10 - = - Obj.magic - uu___10 in - let uu___11 - = - FStar_Tactics_Types.mk_goal - env' - uvar_ut - goal.FStar_Tactics_Types.opts - goal.FStar_Tactics_Types.is_guard - goal.FStar_Tactics_Types.label in - Obj.magic - (FStar_Tactics_Monad.replace_cur - uu___11)) - uu___10))) - uu___8))) uu___6)))) - uu___1))) uu___) -let (clear_top : unit -> unit FStar_Tactics_Monad.tac) = - fun uu___ -> - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___1 -> - (fun goal -> - let goal = Obj.magic goal in - let uu___1 = - let uu___2 = FStar_Tactics_Types.goal_env goal in - FStar_TypeChecker_Env.pop_bv uu___2 in - match uu___1 with - | FStar_Pervasives_Native.None -> - Obj.magic - (FStar_Tactics_Monad.fail "Cannot clear; empty context") - | FStar_Pervasives_Native.Some (x, uu___2) -> - let uu___3 = FStar_Syntax_Syntax.mk_binder x in - Obj.magic (clear uu___3)) uu___1) -let (prune : Prims.string -> unit FStar_Tactics_Monad.tac) = - fun s -> - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___ -> - (fun g -> - let g = Obj.magic g in - let ctx = FStar_Tactics_Types.goal_env g in - let ctx' = - let uu___ = FStar_Ident.path_of_text s in - FStar_TypeChecker_Env.rem_proof_ns ctx uu___ in - let g' = FStar_Tactics_Types.goal_with_env g ctx' in - Obj.magic (FStar_Tactics_Monad.replace_cur g')) uu___) -let (addns : Prims.string -> unit FStar_Tactics_Monad.tac) = - fun s -> - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___ -> - (fun g -> - let g = Obj.magic g in - let ctx = FStar_Tactics_Types.goal_env g in - let ctx' = - let uu___ = FStar_Ident.path_of_text s in - FStar_TypeChecker_Env.add_proof_ns ctx uu___ in - let g' = FStar_Tactics_Types.goal_with_env g ctx' in - Obj.magic (FStar_Tactics_Monad.replace_cur g')) uu___) -let (guard_formula : - FStar_TypeChecker_Common.guard_t -> FStar_Syntax_Syntax.term) = - fun g -> - match g.FStar_TypeChecker_Common.guard_f with - | FStar_TypeChecker_Common.Trivial -> FStar_Syntax_Util.t_true - | FStar_TypeChecker_Common.NonTrivial f -> f -let (_t_trefl : - Prims.bool -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> unit FStar_Tactics_Monad.tac) - = - fun allow_guards -> - fun l -> - fun r -> - let should_register_trefl g = - let should_register = true in - let skip_register = false in - let uu___ = - let uu___1 = FStar_Options.compat_pre_core_should_register () in - Prims.op_Negation uu___1 in - if uu___ - then skip_register - else - (let is_uvar_untyped_or_already_checked u = - let dec = - FStar_Syntax_Unionfind.find_decoration - u.FStar_Syntax_Syntax.ctx_uvar_head in - match dec.FStar_Syntax_Syntax.uvar_decoration_should_check - with - | FStar_Syntax_Syntax.Allow_untyped uu___2 -> true - | FStar_Syntax_Syntax.Already_checked -> true - | uu___2 -> false in - let is_uvar t = - let head = FStar_Syntax_Util.leftmost_head t in - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress head in - uu___3.FStar_Syntax_Syntax.n in - match uu___2 with - | FStar_Syntax_Syntax.Tm_uvar (u, uu___3) -> - FStar_Pervasives.Inl (u, head, t) - | uu___3 -> FStar_Pervasives.Inr t in - let is_allow_untyped_uvar t = - let uu___2 = is_uvar t in - match uu___2 with - | FStar_Pervasives.Inr uu___3 -> false - | FStar_Pervasives.Inl (u, uu___3, uu___4) -> - is_uvar_untyped_or_already_checked u in - let t = - FStar_Syntax_Util.ctx_uvar_typ - g.FStar_Tactics_Types.goal_ctx_uvar in - let uvars = - let uu___2 = FStar_Syntax_Free.uvars t in - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) (Obj.magic uu___2) in - let uu___2 = - FStar_Compiler_Util.for_all is_uvar_untyped_or_already_checked - uvars in - if uu___2 - then skip_register - else - (let uu___4 = - let t1 = - let uu___5 = FStar_Syntax_Util.un_squash t in - match uu___5 with - | FStar_Pervasives_Native.None -> t - | FStar_Pervasives_Native.Some t2 -> t2 in - FStar_Syntax_Util.leftmost_head_and_args t1 in - match uu___4 with - | (head, args) -> - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = FStar_Syntax_Util.un_uinst head in - FStar_Syntax_Subst.compress uu___8 in - uu___7.FStar_Syntax_Syntax.n in - (uu___6, args) in - (match uu___5 with - | (FStar_Syntax_Syntax.Tm_fvar fv, - (ty, uu___6)::(t1, uu___7)::(t2, uu___8)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.eq2_lid - -> - let uu___9 = - (is_allow_untyped_uvar t1) || - (is_allow_untyped_uvar t2) in - if uu___9 - then skip_register - else - (let uu___11 = - FStar_Tactics_Monad.is_goal_safe_as_well_typed - g in - if uu___11 - then - let check_uvar_subtype u t3 = - let env1 = - let uu___12 = - FStar_Tactics_Types.goal_env g in - { - FStar_TypeChecker_Env.solver = - (uu___12.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (uu___12.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (uu___12.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - ((g.FStar_Tactics_Types.goal_ctx_uvar).FStar_Syntax_Syntax.ctx_uvar_gamma); - FStar_TypeChecker_Env.gamma_sig = - (uu___12.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (uu___12.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (uu___12.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (uu___12.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (uu___12.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (uu___12.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (uu___12.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (uu___12.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (uu___12.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (uu___12.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (uu___12.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (uu___12.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (uu___12.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (uu___12.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (uu___12.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (uu___12.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (uu___12.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (uu___12.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (uu___12.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (uu___12.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (uu___12.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (uu___12.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (uu___12.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (uu___12.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (uu___12.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (uu___12.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (uu___12.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (uu___12.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (uu___12.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (uu___12.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (uu___12.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (uu___12.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (uu___12.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (uu___12.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (uu___12.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (uu___12.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (uu___12.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (uu___12.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (uu___12.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (uu___12.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (uu___12.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (uu___12.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (uu___12.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (uu___12.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (uu___12.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (uu___12.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (uu___12.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (uu___12.FStar_TypeChecker_Env.missing_decl) - } in - let uu___12 = - FStar_TypeChecker_Core.compute_term_type_handle_guards - env1 t3 - (fun uu___13 -> fun uu___14 -> true) in - match uu___12 with - | FStar_Pervasives.Inr uu___13 -> false - | FStar_Pervasives.Inl (uu___13, t_ty) -> - let uu___14 = - FStar_TypeChecker_Core.check_term_subtyping - true true env1 ty t_ty in - (match uu___14 with - | FStar_Pervasives.Inl - (FStar_Pervasives_Native.None) -> - (mark_uvar_as_already_checked u; - true) - | uu___15 -> false) in - let uu___12 = - let uu___13 = is_uvar t1 in - let uu___14 = is_uvar t2 in - (uu___13, uu___14) in - match uu___12 with - | (FStar_Pervasives.Inl (u, uu___13, tu), - FStar_Pervasives.Inr uu___14) -> - let uu___15 = check_uvar_subtype u tu in - (if uu___15 - then skip_register - else should_register) - | (FStar_Pervasives.Inr uu___13, - FStar_Pervasives.Inl (u, uu___14, tu)) -> - let uu___15 = check_uvar_subtype u tu in - (if uu___15 - then skip_register - else should_register) - | uu___13 -> should_register - else should_register) - | uu___6 -> should_register))) in - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___ -> - (fun g -> - let g = Obj.magic g in - let should_check = should_check_goal_uvar g in - (let uu___1 = should_register_trefl g in - if uu___1 then FStar_Tactics_Monad.register_goal g else ()); - (let must_tot = true in - let attempt uu___2 uu___1 = - (fun l1 -> - fun r1 -> - let uu___1 = - let uu___2 = FStar_Tactics_Types.goal_env g in - do_unify_maybe_guards allow_guards must_tot uu___2 - l1 r1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - match uu___2 with - | FStar_Pervasives_Native.None -> - Obj.magic (Obj.repr (ret false)) - | FStar_Pervasives_Native.Some guard -> - Obj.magic - (Obj.repr - (let uu___3 = - solve' g - FStar_Syntax_Util.exp_unit in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___3 - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = - Obj.magic uu___4 in - if allow_guards - then - Obj.magic - (Obj.repr - (let uu___5 = - let uu___6 = - FStar_Tactics_Types.goal_env - g in - let uu___7 = - guard_formula - guard in - FStar_Tactics_Monad.goal_of_guard - "t_trefl" - uu___6 - uu___7 - (FStar_Pervasives_Native.Some - should_check) - (rangeof g) in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic - uu___5) - (fun uu___6 -> - (fun goal - -> - let goal - = - Obj.magic - goal in - let uu___6 - = - FStar_Tactics_Monad.push_goals - [goal] in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___6 - (fun - uu___7 -> - (fun - uu___7 -> - let uu___7 - = - Obj.magic - uu___7 in - Obj.magic - (ret true)) - uu___7))) - uu___6))) - else - Obj.magic - (Obj.repr - (let uu___6 = - FStar_TypeChecker_Env.is_trivial_guard_formula - guard in - if uu___6 - then ret true - else - failwith - "internal error: _t_refl: guard is not trivial"))) - uu___4)))) uu___2))) - uu___2 uu___1 in - let uu___1 = attempt l r in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - if uu___2 - then Obj.magic (ret ()) - else - (let norm1 = - let uu___3 = FStar_Tactics_Types.goal_env g in - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.DontUnfoldAttr - [FStar_Parser_Const.tac_opaque_attr]] - uu___3 in - let uu___3 = - let uu___4 = norm1 l in - let uu___5 = norm1 r in - attempt uu___4 uu___5 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___3) - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - if uu___4 - then Obj.magic (ret ()) - else - (let uu___5 = - let uu___6 = - let uu___7 = - FStar_Tactics_Types.goal_env - g in - tts uu___7 in - FStar_TypeChecker_Err.print_discrepancy - uu___6 l r in - match uu___5 with - | (ls, rs) -> - Obj.magic - (fail2 - "cannot unify (%s) and (%s)" - ls rs))) uu___4)))) - uu___2)))) uu___) -let (t_trefl : Prims.bool -> unit FStar_Tactics_Monad.tac) = - fun allow_guards -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___3 -> - (fun g -> - let g = Obj.magic g in - let uu___3 = - let uu___4 = FStar_Tactics_Types.goal_env g in - let uu___5 = FStar_Tactics_Types.goal_type g in - destruct_eq uu___4 uu___5 in - match uu___3 with - | FStar_Pervasives_Native.Some (l, r) -> - Obj.magic (_t_trefl allow_guards l r) - | FStar_Pervasives_Native.None -> - let uu___4 = - let uu___5 = FStar_Tactics_Types.goal_env g in - let uu___6 = FStar_Tactics_Types.goal_type g in - tts uu___5 uu___6 in - Obj.magic (fail1 "not an equality (%s)" uu___4)) uu___3) in - FStar_Tactics_Monad.catch uu___2 in - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - match uu___2 with - | FStar_Pervasives.Inr v -> Obj.magic (ret ()) - | FStar_Pervasives.Inl exn -> - Obj.magic (FStar_Tactics_Monad.traise exn)) uu___2) in - FStar_Tactics_Monad.wrap_err "t_trefl" uu___ -let (dup : unit -> unit FStar_Tactics_Monad.tac) = - fun uu___ -> - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___1 -> - (fun g -> - let g = Obj.magic g in - let goal_sc = should_check_goal_uvar g in - let env1 = FStar_Tactics_Types.goal_env g in - let uu___1 = - let uu___2 = FStar_Tactics_Types.goal_type g in - let uu___3 = - let uu___4 = should_check_goal_uvar g in - FStar_Pervasives_Native.Some uu___4 in - let uu___4 = goal_typedness_deps g in - FStar_Tactics_Monad.new_uvar "dup" env1 uu___2 uu___3 uu___4 - (rangeof g) in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - () (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - match uu___2 with - | (u, u_uvar) -> - (mark_uvar_as_already_checked - g.FStar_Tactics_Types.goal_ctx_uvar; - (let g' = - { - FStar_Tactics_Types.goal_main_env = - (g.FStar_Tactics_Types.goal_main_env); - FStar_Tactics_Types.goal_ctx_uvar = u_uvar; - FStar_Tactics_Types.opts = - (g.FStar_Tactics_Types.opts); - FStar_Tactics_Types.is_guard = - (g.FStar_Tactics_Types.is_guard); - FStar_Tactics_Types.label = - (g.FStar_Tactics_Types.label) - } in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - FStar_Tactics_Monad.dismiss - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - let t_eq = - let uu___5 = - let uu___6 = - FStar_Tactics_Types.goal_type g in - env1.FStar_TypeChecker_Env.universe_of - env1 uu___6 in - let uu___6 = - FStar_Tactics_Types.goal_type g in - let uu___7 = - FStar_Tactics_Types.goal_witness - g in - FStar_Syntax_Util.mk_eq2 uu___5 - uu___6 u uu___7 in - let uu___5 = - FStar_Tactics_Monad.add_irrelevant_goal - g "dup equation" env1 t_eq - (FStar_Pervasives_Native.Some - goal_sc) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () - () uu___5 - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = - Obj.magic uu___6 in - Obj.magic - (FStar_Tactics_Monad.add_goals - [g'])) uu___6))) - uu___4))))) uu___2))) uu___1) -let longest_prefix : - 'a . - ('a -> 'a -> Prims.bool) -> - 'a Prims.list -> - 'a Prims.list -> ('a Prims.list * 'a Prims.list * 'a Prims.list) - = - fun f -> - fun l1 -> - fun l2 -> - let rec aux acc l11 l21 = - match (l11, l21) with - | (x::xs, y::ys) -> - let uu___ = f x y in - if uu___ - then aux (x :: acc) xs ys - else (acc, (x :: xs), (y :: ys)) - | uu___ -> (acc, l11, l21) in - let uu___ = aux [] l1 l2 in - match uu___ with - | (pr, t1, t2) -> ((FStar_Compiler_List.rev pr), t1, t2) -let (eq_binding : - FStar_Syntax_Syntax.binding -> FStar_Syntax_Syntax.binding -> Prims.bool) = - fun b1 -> - fun b2 -> - match (b1, b2) with - | (FStar_Syntax_Syntax.Binding_var bv1, FStar_Syntax_Syntax.Binding_var - bv2) -> - (FStar_Syntax_Syntax.bv_eq bv1 bv2) && - (FStar_Syntax_Util.term_eq bv1.FStar_Syntax_Syntax.sort - bv2.FStar_Syntax_Syntax.sort) - | (FStar_Syntax_Syntax.Binding_lid (lid1, uu___), - FStar_Syntax_Syntax.Binding_lid (lid2, uu___1)) -> - FStar_Ident.lid_equals lid1 lid2 - | (FStar_Syntax_Syntax.Binding_univ u1, - FStar_Syntax_Syntax.Binding_univ u2) -> - FStar_Ident.ident_equals u1 u2 - | uu___ -> false -let (join_goals : - FStar_Tactics_Types.goal -> - FStar_Tactics_Types.goal -> - FStar_Tactics_Types.goal FStar_Tactics_Monad.tac) - = - fun uu___1 -> - fun uu___ -> - (fun g1 -> - fun g2 -> - let close_forall_no_univs bs f = - FStar_Compiler_List.fold_right - (fun b -> - fun f1 -> - FStar_Syntax_Util.mk_forall_no_univ - b.FStar_Syntax_Syntax.binder_bv f1) bs f in - let uu___ = get_phi g1 in - match uu___ with - | FStar_Pervasives_Native.None -> - Obj.magic - (Obj.repr - (FStar_Tactics_Monad.fail "goal 1 is not irrelevant")) - | FStar_Pervasives_Native.Some phi1 -> - Obj.magic - (Obj.repr - (let uu___1 = get_phi g2 in - match uu___1 with - | FStar_Pervasives_Native.None -> - Obj.repr - (FStar_Tactics_Monad.fail - "goal 2 is not irrelevant") - | FStar_Pervasives_Native.Some phi2 -> - Obj.repr - (let gamma1 = - (g1.FStar_Tactics_Types.goal_ctx_uvar).FStar_Syntax_Syntax.ctx_uvar_gamma in - let gamma2 = - (g2.FStar_Tactics_Types.goal_ctx_uvar).FStar_Syntax_Syntax.ctx_uvar_gamma in - let uu___2 = - longest_prefix eq_binding - (FStar_Compiler_List.rev gamma1) - (FStar_Compiler_List.rev gamma2) in - match uu___2 with - | (gamma, r1, r2) -> - let t1 = - let uu___3 = - FStar_TypeChecker_Env.binders_of_bindings - (FStar_Compiler_List.rev r1) in - close_forall_no_univs uu___3 phi1 in - let t2 = - let uu___3 = - FStar_TypeChecker_Env.binders_of_bindings - (FStar_Compiler_List.rev r2) in - close_forall_no_univs uu___3 phi2 in - let goal_sc = - let uu___3 = - let uu___4 = should_check_goal_uvar g1 in - let uu___5 = should_check_goal_uvar g2 in - (uu___4, uu___5) in - match uu___3 with - | (FStar_Syntax_Syntax.Allow_untyped - reason1, - FStar_Syntax_Syntax.Allow_untyped - uu___4) -> - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Allow_untyped - reason1) - | uu___4 -> FStar_Pervasives_Native.None in - let uu___3 = - set_solution g1 FStar_Syntax_Util.exp_unit in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () uu___3 - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - let uu___5 = - set_solution g2 - FStar_Syntax_Util.exp_unit in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () - () uu___5 - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = - Obj.magic uu___6 in - let ng = - FStar_Syntax_Util.mk_conj - t1 t2 in - let nenv = - let uu___7 = - FStar_Tactics_Types.goal_env - g1 in - { - FStar_TypeChecker_Env.solver - = - (uu___7.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range - = - (uu___7.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule - = - (uu___7.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma - = - (FStar_Compiler_List.rev - gamma); - FStar_TypeChecker_Env.gamma_sig - = - (uu___7.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache - = - (uu___7.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules - = - (uu___7.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ - = - (uu___7.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab - = - (uu___7.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab - = - (uu___7.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp - = - (uu___7.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects - = - (uu___7.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize - = - (uu___7.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs - = - (uu___7.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level - = - (uu___7.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars - = - (uu___7.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict - = - (uu___7.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface - = - (uu___7.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit - = - (uu___7.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes - = - (uu___7.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 - = - (uu___7.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard - = - (uu___7.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking - = - (uu___7.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping - = - (uu___7.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics - = - (uu___7.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce - = - (uu___7.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term - = - (uu___7.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (uu___7.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of - = - (uu___7.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (uu___7.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force - = - (uu___7.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (uu___7.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (uu___7.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (uu___7.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths - = - (uu___7.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns - = - (uu___7.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook - = - (uu___7.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (uu___7.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice - = - (uu___7.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess - = - (uu___7.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess - = - (uu___7.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info - = - (uu___7.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks - = - (uu___7.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv - = - (uu___7.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe - = - (uu___7.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab - = - (uu___7.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (uu___7.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (uu___7.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (uu___7.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (uu___7.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check - = - (uu___7.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl - = - (uu___7.FStar_TypeChecker_Env.missing_decl) - } in - let uu___7 = - FStar_Tactics_Monad.mk_irrelevant_goal - "joined" nenv ng - goal_sc (rangeof g1) - g1.FStar_Tactics_Types.opts - g1.FStar_Tactics_Types.label in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic uu___7) - (fun uu___8 -> - (fun goal -> - let goal = - Obj.magic - goal in - let uu___8 = - FStar_Tactics_Monad.if_verbose - (fun uu___9 - -> - let uu___10 - = - FStar_Tactics_Printing.goal_to_string_verbose - g1 in - let uu___11 - = - FStar_Tactics_Printing.goal_to_string_verbose - g2 in - let uu___12 - = - FStar_Tactics_Printing.goal_to_string_verbose - goal in - FStar_Compiler_Util.print3 - "join_goals of\n(%s)\nand\n(%s)\n= (%s)\n" - uu___10 - uu___11 - uu___12) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___8 - (fun - uu___9 -> - (fun - uu___9 -> - let uu___9 - = - Obj.magic - uu___9 in - Obj.magic - (ret goal)) - uu___9))) - uu___8))) uu___6))) - uu___4))))) uu___1 uu___ -let (join : unit -> unit FStar_Tactics_Monad.tac) = - fun uu___ -> - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.get) - (fun uu___1 -> - (fun ps -> - let ps = Obj.magic ps in - match ps.FStar_Tactics_Types.goals with - | g1::g2::gs -> - let uu___1 = - FStar_Tactics_Monad.set - { - FStar_Tactics_Types.main_context = - (ps.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits = - (ps.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = gs; - FStar_Tactics_Types.smt_goals = - (ps.FStar_Tactics_Types.smt_goals); - FStar_Tactics_Types.depth = - (ps.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = - (ps.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = (ps.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (ps.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = - (ps.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness = - (ps.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg = - (ps.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = - (ps.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency = - (ps.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure = - (ps.FStar_Tactics_Types.dump_on_failure) - } in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () uu___1 - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - let uu___3 = join_goals g1 g2 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___3) - (fun uu___4 -> - (fun g12 -> - let g12 = Obj.magic g12 in - Obj.magic - (FStar_Tactics_Monad.add_goals [g12])) - uu___4))) uu___2)) - | uu___1 -> - Obj.magic - (FStar_Tactics_Monad.fail "join: less than 2 goals")) - uu___1) -let (set_options : Prims.string -> unit FStar_Tactics_Monad.tac) = - fun s -> - let uu___ = - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___1 -> - (fun g -> - let g = Obj.magic g in - FStar_Options.push (); - FStar_Options.set g.FStar_Tactics_Types.opts; - (let res = FStar_Options.set_options s in - let opts' = FStar_Options.peek () in - FStar_Options.pop (); - (match res with - | FStar_Getopt.Success -> - let g' = - { - FStar_Tactics_Types.goal_main_env = - (g.FStar_Tactics_Types.goal_main_env); - FStar_Tactics_Types.goal_ctx_uvar = - (g.FStar_Tactics_Types.goal_ctx_uvar); - FStar_Tactics_Types.opts = opts'; - FStar_Tactics_Types.is_guard = - (g.FStar_Tactics_Types.is_guard); - FStar_Tactics_Types.label = - (g.FStar_Tactics_Types.label) - } in - Obj.magic (FStar_Tactics_Monad.replace_cur g') - | FStar_Getopt.Error err -> - Obj.magic (fail2 "Setting options `%s` failed: %s" s err) - | FStar_Getopt.Help -> - Obj.magic - (fail1 "Setting options `%s` failed (got `Help`?)" s)))) - uu___1) in - FStar_Tactics_Monad.wrap_err "set_options" uu___ -let (top_env : unit -> env FStar_Tactics_Monad.tac) = - fun uu___ -> - let uu___1 = bind () in - uu___1 FStar_Tactics_Monad.get - (fun ps -> ret ps.FStar_Tactics_Types.main_context) -let (lax_on : unit -> Prims.bool FStar_Tactics_Monad.tac) = - fun uu___ -> - (fun uu___ -> - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___1 -> - (fun g -> - let g = Obj.magic g in - let uu___1 = - (FStar_Options.lax ()) || - (let uu___2 = FStar_Tactics_Types.goal_env g in - uu___2.FStar_TypeChecker_Env.admit) in - Obj.magic (ret uu___1)) uu___1))) uu___ -let (unquote : - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term FStar_Tactics_Monad.tac) - = - fun ty -> - fun tm -> - let uu___ = - let uu___1 = - FStar_Tactics_Monad.if_verbose - (fun uu___2 -> - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term tm in - FStar_Compiler_Util.print1 "unquote: tm = %s\n" uu___3) in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___1 - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___3 -> - (fun goal -> - let goal = Obj.magic goal in - let env1 = - let uu___3 = - FStar_Tactics_Types.goal_env goal in - FStar_TypeChecker_Env.set_expected_typ uu___3 - ty in - let uu___3 = __tc_ghost env1 tm in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___3) - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - match uu___4 with - | (tm1, typ, guard) -> - let uu___5 = - FStar_Tactics_Monad.if_verbose - (fun uu___6 -> - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - tm1 in - FStar_Compiler_Util.print1 - "unquote: tm' = %s\n" - uu___7) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___5 - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = - Obj.magic uu___6 in - let uu___7 = - FStar_Tactics_Monad.if_verbose - (fun uu___8 -> - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - typ in - FStar_Compiler_Util.print1 - "unquote: typ = %s\n" - uu___9) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___7 - (fun uu___8 -> - (fun uu___8 - -> - let uu___8 - = - Obj.magic - uu___8 in - let uu___9 - = - let uu___10 - = - let uu___11 - = - should_check_goal_uvar - goal in - FStar_Pervasives_Native.Some - uu___11 in - proc_guard - "unquote" - env1 - guard - uu___10 - (rangeof - goal) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___9 - (fun - uu___10 - -> - (fun - uu___10 - -> - let uu___10 - = - Obj.magic - uu___10 in - Obj.magic - (ret tm1)) - uu___10))) - uu___8))) - uu___6))) uu___4))) - uu___3))) uu___2)) in - FStar_Tactics_Monad.wrap_err "unquote" uu___ -let (uvar_env : - env -> - FStar_Syntax_Syntax.typ FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.term FStar_Tactics_Monad.tac) - = - fun uu___1 -> - fun uu___ -> - (fun env1 -> - fun ty -> - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - () (Obj.magic FStar_Tactics_Monad.get) - (fun uu___ -> - (fun ps -> - let ps = Obj.magic ps in - let uu___ = - match ty with - | FStar_Pervasives_Native.Some ty1 -> - let env2 = - let uu___1 = - let uu___2 = FStar_Syntax_Util.type_u () in - FStar_Pervasives_Native.fst uu___2 in - FStar_TypeChecker_Env.set_expected_typ env1 - uu___1 in - let uu___1 = __tc_ghost env2 ty1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - match uu___2 with - | (ty2, uu___3, g) -> - Obj.magic - (ret - (ty2, g, - (ty2.FStar_Syntax_Syntax.pos)))) - uu___2)) - | FStar_Pervasives_Native.None -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.type_u () in - FStar_Pervasives_Native.fst uu___3 in - FStar_Tactics_Monad.new_uvar "uvar_env.2" env1 - uu___2 FStar_Pervasives_Native.None [] - ps.FStar_Tactics_Types.entry_range in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - match uu___2 with - | (typ, uvar_typ) -> - Obj.magic - (ret - (typ, - FStar_TypeChecker_Env.trivial_guard, - FStar_Compiler_Range_Type.dummyRange))) - uu___2)) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___) - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - match uu___1 with - | (typ, g, r) -> - let uu___2 = - proc_guard "uvar_env_typ" env1 g - FStar_Pervasives_Native.None r in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - uu___2 - (fun uu___3 -> - (fun uu___3 -> - let uu___3 = Obj.magic uu___3 in - let uu___4 = - FStar_Tactics_Monad.new_uvar - "uvar_env" env1 typ - FStar_Pervasives_Native.None - [] - ps.FStar_Tactics_Types.entry_range in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () (Obj.magic uu___4) - (fun uu___5 -> - (fun uu___5 -> - let uu___5 = - Obj.magic uu___5 in - match uu___5 with - | (t, uvar_t) -> - Obj.magic - (ret t)) - uu___5))) uu___3))) - uu___1))) uu___))) uu___1 uu___ -let (ghost_uvar_env : - env -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.term FStar_Tactics_Monad.tac) - = - fun uu___1 -> - fun uu___ -> - (fun env1 -> - fun ty -> - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - () (Obj.magic FStar_Tactics_Monad.get) - (fun uu___ -> - (fun ps -> - let ps = Obj.magic ps in - let uu___ = __tc_ghost env1 ty in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___) - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - match uu___1 with - | (typ, uu___2, g) -> - let uu___3 = - proc_guard "ghost_uvar_env_typ" env1 g - FStar_Pervasives_Native.None - ty.FStar_Syntax_Syntax.pos in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - uu___3 - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - let uu___5 = - FStar_Tactics_Monad.new_uvar - "uvar_env" env1 typ - (FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Allow_ghost - "User ghost uvar")) - [] - ps.FStar_Tactics_Types.entry_range in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () (Obj.magic uu___5) - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = - Obj.magic uu___6 in - match uu___6 with - | (t, uvar_t) -> - Obj.magic - (ret t)) - uu___6))) uu___4))) - uu___1))) uu___))) uu___1 uu___ -let (fresh_universe_uvar : - unit -> FStar_Syntax_Syntax.term FStar_Tactics_Monad.tac) = - fun uu___ -> - let uu___1 = - let uu___2 = FStar_Syntax_Util.type_u () in - FStar_Pervasives_Native.fst uu___2 in - ret uu___1 -let (unshelve : FStar_Syntax_Syntax.term -> unit FStar_Tactics_Monad.tac) = - fun t -> - let uu___ = - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.get) - (fun uu___1 -> - (fun ps -> - let ps = Obj.magic ps in - let env1 = ps.FStar_Tactics_Types.main_context in - let opts = - match ps.FStar_Tactics_Types.goals with - | g::uu___1 -> g.FStar_Tactics_Types.opts - | uu___1 -> FStar_Options.peek () in - let uu___1 = FStar_Syntax_Util.head_and_args t in - match uu___1 with - | ({ - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_uvar - (ctx_uvar, uu___2); - FStar_Syntax_Syntax.pos = uu___3; - FStar_Syntax_Syntax.vars = uu___4; - FStar_Syntax_Syntax.hash_code = uu___5;_}, - uu___6) -> - let env2 = - { - FStar_TypeChecker_Env.solver = - (env1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (ctx_uvar.FStar_Syntax_Syntax.ctx_uvar_gamma); - FStar_TypeChecker_Env.gamma_sig = - (env1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (env1.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env1.FStar_TypeChecker_Env.missing_decl) - } in - let g = - FStar_Tactics_Types.mk_goal env2 ctx_uvar opts false "" in - let g1 = bnorm_goal g in - Obj.magic (FStar_Tactics_Monad.add_goals [g1]) - | uu___2 -> Obj.magic (FStar_Tactics_Monad.fail "not a uvar")) - uu___1) in - FStar_Tactics_Monad.wrap_err "unshelve" uu___ -let (tac_and : - Prims.bool FStar_Tactics_Monad.tac -> - Prims.bool FStar_Tactics_Monad.tac -> Prims.bool FStar_Tactics_Monad.tac) - = - fun uu___1 -> - fun uu___ -> - (fun t1 -> - fun t2 -> - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - () (Obj.magic t1) - (fun uu___ -> - (fun uu___ -> - let uu___ = Obj.magic uu___ in - if uu___ - then Obj.magic (Obj.repr t2) - else - Obj.magic - (Obj.repr - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic false)))) uu___))) uu___1 uu___ -let default_if_err : - 'a . 'a -> 'a FStar_Tactics_Monad.tac -> 'a FStar_Tactics_Monad.tac = - fun uu___1 -> - fun uu___ -> - (fun def -> - fun t -> - let uu___ = FStar_Tactics_Monad.catch t in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - () (Obj.magic uu___) - (fun uu___1 -> - (fun r -> - let r = Obj.magic r in - match r with - | FStar_Pervasives.Inl uu___1 -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic def)) - | FStar_Pervasives.Inr v -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () (Obj.magic v))) - uu___1))) uu___1 uu___ -let (match_env : - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> Prims.bool FStar_Tactics_Monad.tac) - = - fun e -> - fun t1 -> - fun t2 -> - let uu___ = - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - () (Obj.magic FStar_Tactics_Monad.get) - (fun uu___1 -> - (fun ps -> - let ps = Obj.magic ps in - let uu___1 = __tc e t1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - match uu___2 with - | (t11, ty1, g1) -> - let uu___3 = __tc e t2 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___3) - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - match uu___4 with - | (t21, ty2, g2) -> - let uu___5 = - proc_guard - "match_env g1" e g1 - FStar_Pervasives_Native.None - ps.FStar_Tactics_Types.entry_range in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___5 - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = - Obj.magic - uu___6 in - let uu___7 = - proc_guard - "match_env g2" - e g2 - FStar_Pervasives_Native.None - ps.FStar_Tactics_Types.entry_range in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___7 - (fun - uu___8 -> - (fun - uu___8 -> - let uu___8 - = - Obj.magic - uu___8 in - let must_tot - = true in - let uu___9 - = - let uu___10 - = - do_match - must_tot - e ty1 ty2 in - let uu___11 - = - do_match - must_tot - e t11 t21 in - tac_and - uu___10 - uu___11 in - Obj.magic - (default_if_err - false - uu___9)) - uu___8))) - uu___6))) uu___4))) - uu___2))) uu___1)) in - FStar_Tactics_Monad.wrap_err "match_env" uu___ -let (unify_env : - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> Prims.bool FStar_Tactics_Monad.tac) - = - fun e -> - fun t1 -> - fun t2 -> - let uu___ = - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - () (Obj.magic FStar_Tactics_Monad.get) - (fun uu___1 -> - (fun ps -> - let ps = Obj.magic ps in - let uu___1 = __tc e t1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - match uu___2 with - | (t11, ty1, g1) -> - let uu___3 = __tc e t2 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___3) - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - match uu___4 with - | (t21, ty2, g2) -> - let uu___5 = - proc_guard - "unify_env g1" e g1 - FStar_Pervasives_Native.None - ps.FStar_Tactics_Types.entry_range in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___5 - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = - Obj.magic - uu___6 in - let uu___7 = - proc_guard - "unify_env g2" - e g2 - FStar_Pervasives_Native.None - ps.FStar_Tactics_Types.entry_range in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___7 - (fun - uu___8 -> - (fun - uu___8 -> - let uu___8 - = - Obj.magic - uu___8 in - let must_tot - = true in - let uu___9 - = - let uu___10 - = - do_unify - must_tot - e ty1 ty2 in - let uu___11 - = - do_unify - must_tot - e t11 t21 in - tac_and - uu___10 - uu___11 in - Obj.magic - (default_if_err - false - uu___9)) - uu___8))) - uu___6))) uu___4))) - uu___2))) uu___1)) in - FStar_Tactics_Monad.wrap_err "unify_env" uu___ -let (unify_guard_env : - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> Prims.bool FStar_Tactics_Monad.tac) - = - fun e -> - fun t1 -> - fun t2 -> - let uu___ = - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - () (Obj.magic FStar_Tactics_Monad.get) - (fun uu___1 -> - (fun ps -> - let ps = Obj.magic ps in - let uu___1 = __tc e t1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - match uu___2 with - | (t11, ty1, g1) -> - let uu___3 = __tc e t2 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___3) - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - match uu___4 with - | (t21, ty2, g2) -> - let uu___5 = - proc_guard - "unify_guard_env g1" e - g1 - FStar_Pervasives_Native.None - ps.FStar_Tactics_Types.entry_range in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___5 - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = - Obj.magic - uu___6 in - let uu___7 = - proc_guard - "unify_guard_env g2" - e g2 - FStar_Pervasives_Native.None - ps.FStar_Tactics_Types.entry_range in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___7 - (fun - uu___8 -> - (fun - uu___8 -> - let uu___8 - = - Obj.magic - uu___8 in - let must_tot - = true in - let uu___9 - = - do_unify_maybe_guards - true - must_tot - e ty1 ty2 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic - uu___9) - (fun - uu___10 - -> - (fun - uu___10 - -> - let uu___10 - = - Obj.magic - uu___10 in - match uu___10 - with - | - FStar_Pervasives_Native.None - -> - Obj.magic - (Obj.repr - (ret - false)) - | - FStar_Pervasives_Native.Some - g11 -> - Obj.magic - (Obj.repr - (let uu___11 - = - do_unify_maybe_guards - true - must_tot - e t11 t21 in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic - uu___11) - (fun - uu___12 - -> - (fun - uu___12 - -> - let uu___12 - = - Obj.magic - uu___12 in - match uu___12 - with - | - FStar_Pervasives_Native.None - -> - Obj.magic - (Obj.repr - (ret - false)) - | - FStar_Pervasives_Native.Some - g21 -> - Obj.magic - (Obj.repr - (let formula - = - let uu___13 - = - guard_formula - g11 in - let uu___14 - = - guard_formula - g21 in - FStar_Syntax_Util.mk_conj - uu___13 - uu___14 in - let uu___13 - = - FStar_Tactics_Monad.goal_of_guard - "unify_guard_env.g2" - e formula - FStar_Pervasives_Native.None - ps.FStar_Tactics_Types.entry_range in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic - uu___13) - (fun - uu___14 - -> - (fun goal - -> - let goal - = - Obj.magic - goal in - let uu___14 - = - FStar_Tactics_Monad.push_goals - [goal] in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___14 - (fun - uu___15 - -> - (fun - uu___15 - -> - let uu___15 - = - Obj.magic - uu___15 in - Obj.magic - (ret true)) - uu___15))) - uu___14)))) - uu___12)))) - uu___10))) - uu___8))) - uu___6))) uu___4))) - uu___2))) uu___1)) in - FStar_Tactics_Monad.wrap_err "unify_guard_env" uu___ -let (launch_process : - Prims.string -> - Prims.string Prims.list -> - Prims.string -> Prims.string FStar_Tactics_Monad.tac) - = - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun prog -> - fun args -> - fun input -> - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac - () () idtac - (fun uu___ -> - (fun uu___ -> - let uu___ = Obj.magic uu___ in - let uu___1 = FStar_Options.unsafe_tactic_exec () in - if uu___1 - then - let s = - FStar_Compiler_Util.run_process "tactic_launch" - prog args - (FStar_Pervasives_Native.Some input) in - Obj.magic (ret s) - else - Obj.magic - (FStar_Tactics_Monad.fail - "launch_process: will not run anything unless --unsafe_tactic_exec is provided")) - uu___))) uu___2 uu___1 uu___ -let (fresh_bv_named : - Prims.string -> FStar_Syntax_Syntax.bv FStar_Tactics_Monad.tac) = - fun uu___ -> - (fun nm -> - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - idtac - (fun uu___ -> - (fun uu___ -> - let uu___ = Obj.magic uu___ in - let uu___1 = - FStar_Syntax_Syntax.gen_bv nm - FStar_Pervasives_Native.None FStar_Syntax_Syntax.tun in - Obj.magic (ret uu___1)) uu___))) uu___ -let (change : FStar_Syntax_Syntax.typ -> unit FStar_Tactics_Monad.tac) = - fun ty -> - let uu___ = - let uu___1 = - FStar_Tactics_Monad.if_verbose - (fun uu___2 -> - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term ty in - FStar_Compiler_Util.print1 "change: ty = %s\n" uu___3) in - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___1 - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac - () () (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___3 -> - (fun g -> - let g = Obj.magic g in - let uu___3 = - let uu___4 = FStar_Tactics_Types.goal_env g in - __tc uu___4 ty in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___3) - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - match uu___4 with - | (ty1, uu___5, guard) -> - let uu___6 = - let uu___7 = - FStar_Tactics_Types.goal_env g in - let uu___8 = - let uu___9 = - should_check_goal_uvar g in - FStar_Pervasives_Native.Some - uu___9 in - proc_guard "change" uu___7 guard - uu___8 (rangeof g) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () - () uu___6 - (fun uu___7 -> - (fun uu___7 -> - let uu___7 = - Obj.magic uu___7 in - let must_tot = true in - let uu___8 = - let uu___9 = - FStar_Tactics_Types.goal_env - g in - let uu___10 = - FStar_Tactics_Types.goal_type - g in - do_unify must_tot uu___9 - uu___10 ty1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic uu___8) - (fun uu___9 -> - (fun bb -> - let bb = - Obj.magic bb in - if bb - then - let uu___9 = - goal_with_type - g ty1 in - Obj.magic - (FStar_Tactics_Monad.replace_cur - uu___9) - else - (let steps = - [FStar_TypeChecker_Env.AllowUnboundUniverses; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Primops] in - let ng = - let uu___10 - = - FStar_Tactics_Types.goal_env - g in - let uu___11 - = - FStar_Tactics_Types.goal_type - g in - normalize - steps - uu___10 - uu___11 in - let nty = - let uu___10 - = - FStar_Tactics_Types.goal_env - g in - normalize - steps - uu___10 - ty1 in - let uu___10 - = - let uu___11 - = - FStar_Tactics_Types.goal_env - g in - do_unify - must_tot - uu___11 - ng nty in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic - uu___10) - (fun - uu___11 - -> - (fun b -> - let b = - Obj.magic - b in - if b - then - let uu___11 - = - goal_with_type - g ty1 in - Obj.magic - (FStar_Tactics_Monad.replace_cur - uu___11) - else - Obj.magic - (FStar_Tactics_Monad.fail - "not convertible")) - uu___11)))) - uu___9))) uu___7))) - uu___4))) uu___3))) uu___2) in - FStar_Tactics_Monad.wrap_err "change" uu___ -let (failwhen : Prims.bool -> Prims.string -> unit FStar_Tactics_Monad.tac) = - fun b -> fun msg -> if b then FStar_Tactics_Monad.fail msg else ret () -let (t_destruct : - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.fv * FStar_BigInt.t) Prims.list - FStar_Tactics_Monad.tac) - = - fun s_tm -> - let uu___ = - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___1 -> - (fun g -> - let g = Obj.magic g in - let uu___1 = - let uu___2 = FStar_Tactics_Types.goal_env g in - __tc uu___2 s_tm in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - match uu___2 with - | (s_tm1, s_ty, guard) -> - let uu___3 = - let uu___4 = FStar_Tactics_Types.goal_env g in - let uu___5 = - let uu___6 = should_check_goal_uvar g in - FStar_Pervasives_Native.Some uu___6 in - proc_guard "destruct" uu___4 guard uu___5 - (rangeof g) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - uu___3 - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - let s_ty1 = - let uu___5 = - FStar_Tactics_Types.goal_env g in - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.DontUnfoldAttr - [FStar_Parser_Const.tac_opaque_attr]; - FStar_TypeChecker_Env.Weak; - FStar_TypeChecker_Env.HNF; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant] - uu___5 s_ty in - let uu___5 = - let uu___6 = - FStar_Syntax_Util.unrefine - s_ty1 in - FStar_Syntax_Util.head_and_args_full - uu___6 in - match uu___5 with - | (h, args) -> - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Syntax_Subst.compress - h in - uu___8.FStar_Syntax_Syntax.n in - match uu___7 with - | FStar_Syntax_Syntax.Tm_fvar - fv -> ret (fv, []) - | FStar_Syntax_Syntax.Tm_uinst - (h', us) -> - let uu___8 = - let uu___9 = - FStar_Syntax_Subst.compress - h' in - uu___9.FStar_Syntax_Syntax.n in - (match uu___8 with - | FStar_Syntax_Syntax.Tm_fvar - fv -> ret (fv, us) - | uu___9 -> - failwith - "impossible: uinst over something that's not an fvar") - | uu___8 -> - FStar_Tactics_Monad.fail - "type is not an fv" in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () (Obj.magic uu___6) - (fun uu___7 -> - (fun uu___7 -> - let uu___7 = - Obj.magic uu___7 in - match uu___7 with - | (fv, a_us) -> - let t_lid = - FStar_Syntax_Syntax.lid_of_fv - fv in - let uu___8 = - let uu___9 = - FStar_Tactics_Types.goal_env - g in - FStar_TypeChecker_Env.lookup_sigelt - uu___9 - t_lid in - (match uu___8 - with - | FStar_Pervasives_Native.None - -> - Obj.magic - (Obj.repr - (FStar_Tactics_Monad.fail - "type not found in environment")) - | FStar_Pervasives_Native.Some - se -> - Obj.magic - (Obj.repr - (match - se.FStar_Syntax_Syntax.sigel - with - | - FStar_Syntax_Syntax.Sig_inductive_typ - { - FStar_Syntax_Syntax.lid - = uu___9; - FStar_Syntax_Syntax.us - = t_us; - FStar_Syntax_Syntax.params - = t_ps; - FStar_Syntax_Syntax.num_uniform_params - = uu___10; - FStar_Syntax_Syntax.t - = t_ty; - FStar_Syntax_Syntax.mutuals - = mut; - FStar_Syntax_Syntax.ds - = c_lids; - FStar_Syntax_Syntax.injective_type_params - = uu___11;_} - -> - Obj.repr - (let erasable - = - FStar_Syntax_Util.has_attribute - se.FStar_Syntax_Syntax.sigattrs - FStar_Parser_Const.erasable_attr in - let uu___12 - = - let uu___13 - = - erasable - && - (let uu___14 - = - is_irrelevant - g in - Prims.op_Negation - uu___14) in - failwhen - uu___13 - "cannot destruct erasable type to solve proof-relevant goal" in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___12 - (fun - uu___13 - -> - (fun - uu___13 - -> - let uu___13 - = - Obj.magic - uu___13 in - let uu___14 - = - failwhen - ((FStar_Compiler_List.length - a_us) <> - (FStar_Compiler_List.length - t_us)) - "t_us don't match?" in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___14 - (fun - uu___15 - -> - (fun - uu___15 - -> - let uu___15 - = - Obj.magic - uu___15 in - let uu___16 - = - FStar_Syntax_Subst.open_term - t_ps t_ty in - match uu___16 - with - | - (t_ps1, - t_ty1) -> - let uu___17 - = - Obj.magic - (FStar_Class_Monad.mapM - FStar_Tactics_Monad.monad_tac - () () - (fun - uu___18 - -> - (fun - c_lid -> - let c_lid - = - Obj.magic - c_lid in - let uu___18 - = - let uu___19 - = - FStar_Tactics_Types.goal_env - g in - FStar_TypeChecker_Env.lookup_sigelt - uu___19 - c_lid in - match uu___18 - with - | - FStar_Pervasives_Native.None - -> - Obj.magic - (Obj.repr - (FStar_Tactics_Monad.fail - "ctor not found?")) - | - FStar_Pervasives_Native.Some - se1 -> - Obj.magic - (Obj.repr - (match - se1.FStar_Syntax_Syntax.sigel - with - | - FStar_Syntax_Syntax.Sig_datacon - { - FStar_Syntax_Syntax.lid1 - = uu___19; - FStar_Syntax_Syntax.us1 - = c_us; - FStar_Syntax_Syntax.t1 - = c_ty; - FStar_Syntax_Syntax.ty_lid - = uu___20; - FStar_Syntax_Syntax.num_ty_params - = nparam; - FStar_Syntax_Syntax.mutuals1 - = mut1; - FStar_Syntax_Syntax.injective_type_params1 - = uu___21;_} - -> - Obj.repr - (let fv1 - = - FStar_Syntax_Syntax.lid_as_fv - c_lid - (FStar_Pervasives_Native.Some - FStar_Syntax_Syntax.Data_ctor) in - let uu___22 - = - failwhen - ((FStar_Compiler_List.length - a_us) <> - (FStar_Compiler_List.length - c_us)) - "t_us don't match?" in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___22 - (fun - uu___23 - -> - (fun - uu___23 - -> - let uu___23 - = - Obj.magic - uu___23 in - let s = - FStar_TypeChecker_Env.mk_univ_subst - c_us a_us in - let c_ty1 - = - FStar_Syntax_Subst.subst - s c_ty in - let uu___24 - = - FStar_TypeChecker_Env.inst_tscheme - (c_us, - c_ty1) in - match uu___24 - with - | - (c_us1, - c_ty2) -> - let uu___25 - = - FStar_Syntax_Util.arrow_formals_comp - c_ty2 in - (match uu___25 - with - | - (bs, - comp) -> - let uu___26 - = - let rename_bv - bv = - let ppname - = - bv.FStar_Syntax_Syntax.ppname in - let ppname1 - = - let uu___27 - = - let uu___28 - = - let uu___29 - = - FStar_Class_Show.show - FStar_Ident.showable_ident - ppname in - Prims.strcat - "a" - uu___29 in - let uu___29 - = - FStar_Ident.range_of_id - ppname in - (uu___28, - uu___29) in - FStar_Ident.mk_ident - uu___27 in - FStar_Syntax_Syntax.freshen_bv - { - FStar_Syntax_Syntax.ppname - = ppname1; - FStar_Syntax_Syntax.index - = - (bv.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort - = - (bv.FStar_Syntax_Syntax.sort) - } in - let bs' = - FStar_Compiler_List.map - (fun b -> - let uu___27 - = - rename_bv - b.FStar_Syntax_Syntax.binder_bv in - { - FStar_Syntax_Syntax.binder_bv - = uu___27; - FStar_Syntax_Syntax.binder_qual - = - (b.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity - = - (b.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs - = - (b.FStar_Syntax_Syntax.binder_attrs) - }) bs in - let subst - = - FStar_Compiler_List.map2 - (fun - uu___27 - -> - fun - uu___28 - -> - match - (uu___27, - uu___28) - with - | - ({ - FStar_Syntax_Syntax.binder_bv - = bv; - FStar_Syntax_Syntax.binder_qual - = uu___29; - FStar_Syntax_Syntax.binder_positivity - = uu___30; - FStar_Syntax_Syntax.binder_attrs - = uu___31;_}, - { - FStar_Syntax_Syntax.binder_bv - = bv'; - FStar_Syntax_Syntax.binder_qual - = uu___32; - FStar_Syntax_Syntax.binder_positivity - = uu___33; - FStar_Syntax_Syntax.binder_attrs - = uu___34;_}) - -> - let uu___35 - = - let uu___36 - = - FStar_Syntax_Syntax.bv_to_name - bv' in - (bv, - uu___36) in - FStar_Syntax_Syntax.NT - uu___35) - bs bs' in - let uu___27 - = - FStar_Syntax_Subst.subst_binders - subst bs' in - let uu___28 - = - FStar_Syntax_Subst.subst_comp - subst - comp in - (uu___27, - uu___28) in - (match uu___26 - with - | - (bs1, - comp1) -> - let uu___27 - = - FStar_Compiler_List.splitAt - nparam - bs1 in - (match uu___27 - with - | - (d_ps, - bs2) -> - let uu___28 - = - let uu___29 - = - let uu___30 - = - FStar_Syntax_Util.is_total_comp - comp1 in - Prims.op_Negation - uu___30 in - failwhen - uu___29 - "not total?" in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___28 - (fun - uu___29 - -> - (fun - uu___29 - -> - let uu___29 - = - Obj.magic - uu___29 in - let mk_pat - p = - { - FStar_Syntax_Syntax.v - = p; - FStar_Syntax_Syntax.p - = - (s_tm1.FStar_Syntax_Syntax.pos) - } in - let is_imp - uu___30 = - match uu___30 - with - | - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Implicit - uu___31) - -> true - | - uu___31 - -> false in - let uu___30 - = - FStar_Compiler_List.splitAt - nparam - args in - match uu___30 - with - | - (a_ps, - a_is) -> - let uu___31 - = - failwhen - ((FStar_Compiler_List.length - a_ps) <> - (FStar_Compiler_List.length - d_ps)) - "params not match?" in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___31 - (fun - uu___32 - -> - (fun - uu___32 - -> - let uu___32 - = - Obj.magic - uu___32 in - let d_ps_a_ps - = - FStar_Compiler_List.zip - d_ps a_ps in - let subst - = - FStar_Compiler_List.map - (fun - uu___33 - -> - match uu___33 - with - | - ({ - FStar_Syntax_Syntax.binder_bv - = bv; - FStar_Syntax_Syntax.binder_qual - = uu___34; - FStar_Syntax_Syntax.binder_positivity - = uu___35; - FStar_Syntax_Syntax.binder_attrs - = uu___36;_}, - (t, - uu___37)) - -> - FStar_Syntax_Syntax.NT - (bv, t)) - d_ps_a_ps in - let bs3 = - FStar_Syntax_Subst.subst_binders - subst bs2 in - let subpats_1 - = - FStar_Compiler_List.map - (fun - uu___33 - -> - match uu___33 - with - | - ({ - FStar_Syntax_Syntax.binder_bv - = bv; - FStar_Syntax_Syntax.binder_qual - = uu___34; - FStar_Syntax_Syntax.binder_positivity - = uu___35; - FStar_Syntax_Syntax.binder_attrs - = uu___36;_}, - (t, - uu___37)) - -> - ((mk_pat - (FStar_Syntax_Syntax.Pat_dot_term - (FStar_Pervasives_Native.Some - t))), - true)) - d_ps_a_ps in - let subpats_2 - = - FStar_Compiler_List.map - (fun - uu___33 - -> - match uu___33 - with - | - { - FStar_Syntax_Syntax.binder_bv - = bv; - FStar_Syntax_Syntax.binder_qual - = bq; - FStar_Syntax_Syntax.binder_positivity - = uu___34; - FStar_Syntax_Syntax.binder_attrs - = uu___35;_} - -> - ((mk_pat - (FStar_Syntax_Syntax.Pat_var - bv)), - (is_imp - bq))) bs3 in - let subpats - = - FStar_Compiler_List.op_At - subpats_1 - subpats_2 in - let pat = - mk_pat - (FStar_Syntax_Syntax.Pat_cons - (fv1, - (FStar_Pervasives_Native.Some - a_us), - subpats)) in - let env1 - = - FStar_Tactics_Types.goal_env - g in - let cod = - FStar_Tactics_Types.goal_type - g in - let equ = - env1.FStar_TypeChecker_Env.universe_of - env1 - s_ty1 in - let uu___33 - = - FStar_TypeChecker_TcTerm.tc_pat - { - FStar_TypeChecker_Env.solver - = - (env1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range - = - (env1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule - = - (env1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma - = - (env1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig - = - (env1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache - = - (env1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules - = - (env1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ - = - (env1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab - = - (env1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab - = - (env1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp - = - (env1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects - = - (env1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize - = - (env1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs - = - (env1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level - = - (env1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars - = - (env1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict - = - (env1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface - = - (env1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit - = true; - FStar_TypeChecker_Env.lax_universes - = - (env1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 - = - (env1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard - = - (env1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking - = - (env1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping - = - (env1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics - = - (env1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce - = - (env1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term - = - (env1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (env1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of - = - (env1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force - = - (env1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (env1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (env1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (env1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths - = - (env1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns - = - (env1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook - = - (env1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (env1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice - = - (env1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess - = - (env1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess - = - (env1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info - = - (env1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks - = - (env1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv - = - (env1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe - = - (env1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab - = - (env1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (env1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (env1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (env1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (env1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check - = - (env1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl - = - (env1.FStar_TypeChecker_Env.missing_decl) - } s_ty1 - pat in - match uu___33 - with - | - (uu___34, - uu___35, - uu___36, - uu___37, - pat_t, - uu___38, - _guard_pat, - _erasable) - -> - let eq_b - = - let uu___39 - = - let uu___40 - = - FStar_Syntax_Util.mk_eq2 - equ s_ty1 - s_tm1 - pat_t in - FStar_Syntax_Util.mk_squash - FStar_Syntax_Syntax.U_zero - uu___40 in - FStar_Syntax_Syntax.gen_bv - "breq" - FStar_Pervasives_Native.None - uu___39 in - let cod1 - = - let uu___39 - = - let uu___40 - = - FStar_Syntax_Syntax.mk_binder - eq_b in - [uu___40] in - let uu___40 - = - FStar_Syntax_Syntax.mk_Total - cod in - FStar_Syntax_Util.arrow - uu___39 - uu___40 in - let nty = - let uu___39 - = - FStar_Syntax_Syntax.mk_Total - cod1 in - FStar_Syntax_Util.arrow - bs3 - uu___39 in - let uu___39 - = - let uu___40 - = - goal_typedness_deps - g in - FStar_Tactics_Monad.new_uvar - "destruct branch" - env1 nty - FStar_Pervasives_Native.None - uu___40 - (rangeof - g) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic - uu___39) - (fun - uu___40 - -> - (fun - uu___40 - -> - let uu___40 - = - Obj.magic - uu___40 in - match uu___40 - with - | - (uvt, uv) - -> - let g' = - FStar_Tactics_Types.mk_goal - env1 uv - g.FStar_Tactics_Types.opts - false - g.FStar_Tactics_Types.label in - let brt = - FStar_Syntax_Util.mk_app_binders - uvt bs3 in - let brt1 - = - let uu___41 - = - let uu___42 - = - FStar_Syntax_Syntax.as_arg - FStar_Syntax_Util.exp_unit in - [uu___42] in - FStar_Syntax_Util.mk_app - brt - uu___41 in - let br = - FStar_Syntax_Subst.close_branch - (pat, - FStar_Pervasives_Native.None, - brt1) in - let uu___41 - = - let uu___42 - = - let uu___43 - = - FStar_BigInt.of_int_fs - (FStar_Compiler_List.length - bs3) in - (fv1, - uu___43) in - (g', br, - uu___42) in - Obj.magic - (ret - uu___41)) - uu___40))) - uu___32))) - uu___29)))))) - uu___23)) - | - uu___19 - -> - Obj.repr - (FStar_Tactics_Monad.fail - "impossible: not a ctor")))) - uu___18) - (Obj.magic - c_lids)) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic - uu___17) - (fun - uu___18 - -> - (fun - goal_brs - -> - let goal_brs - = - Obj.magic - goal_brs in - let uu___18 - = - FStar_Compiler_List.unzip3 - goal_brs in - match uu___18 - with - | - (goals, - brs, - infos) -> - let w = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_match - { - FStar_Syntax_Syntax.scrutinee - = s_tm1; - FStar_Syntax_Syntax.ret_opt - = - FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.brs - = brs; - FStar_Syntax_Syntax.rc_opt1 - = - FStar_Pervasives_Native.None - }) - s_tm1.FStar_Syntax_Syntax.pos in - let uu___19 - = - solve' g - w in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___19 - (fun - uu___20 - -> - (fun - uu___20 - -> - let uu___20 - = - Obj.magic - uu___20 in - mark_goal_implicit_already_checked - g; - ( - let uu___22 - = - FStar_Tactics_Monad.add_goals - goals in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___22 - (fun - uu___23 - -> - (fun - uu___23 - -> - let uu___23 - = - Obj.magic - uu___23 in - Obj.magic - (ret - infos)) - uu___23)))) - uu___20))) - uu___18))) - uu___15))) - uu___13)) - | - uu___9 -> - Obj.repr - (FStar_Tactics_Monad.fail - "not an inductive type"))))) - uu___7))) uu___4))) - uu___2))) uu___1)) in - FStar_Tactics_Monad.wrap_err "destruct" uu___ -let (gather_explicit_guards_for_resolved_goals : - unit -> unit FStar_Tactics_Monad.tac) = fun uu___ -> ret () -let rec last : 'a . 'a Prims.list -> 'a = - fun l -> - match l with - | [] -> failwith "last: empty list" - | x::[] -> x - | uu___::xs -> last xs -let rec init : 'a . 'a Prims.list -> 'a Prims.list = - fun l -> - match l with - | [] -> failwith "init: empty list" - | x::[] -> [] - | x::xs -> let uu___ = init xs in x :: uu___ -let rec (inspect : - FStar_Syntax_Syntax.term -> - FStar_Reflection_V1_Data.term_view FStar_Tactics_Monad.tac) - = - fun t -> - let uu___ = - let uu___1 = top_env () in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___1) - (fun uu___2 -> - (fun e -> - let e = Obj.magic e in - let t1 = FStar_Syntax_Util.unlazy_emb t in - let t2 = FStar_Syntax_Subst.compress t1 in - match t2.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t3; - FStar_Syntax_Syntax.meta = uu___2;_} - -> Obj.magic (inspect t3) - | FStar_Syntax_Syntax.Tm_name bv -> - Obj.magic (ret (FStar_Reflection_V1_Data.Tv_Var bv)) - | FStar_Syntax_Syntax.Tm_bvar bv -> - Obj.magic (ret (FStar_Reflection_V1_Data.Tv_BVar bv)) - | FStar_Syntax_Syntax.Tm_fvar fv -> - Obj.magic (ret (FStar_Reflection_V1_Data.Tv_FVar fv)) - | FStar_Syntax_Syntax.Tm_uinst (t3, us) -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Subst.compress t3 in - FStar_Syntax_Util.unascribe uu___4 in - uu___3.FStar_Syntax_Syntax.n in - (match uu___2 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - Obj.magic - (ret (FStar_Reflection_V1_Data.Tv_UInst (fv, us))) - | uu___3 -> - Obj.magic - (failwith - "Tac::inspect: Tm_uinst head not an fvar")) - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t3; - FStar_Syntax_Syntax.asc = - (FStar_Pervasives.Inl ty, tacopt, eq); - FStar_Syntax_Syntax.eff_opt = uu___2;_} - -> - Obj.magic - (ret - (FStar_Reflection_V1_Data.Tv_AscribedT - (t3, ty, tacopt, eq))) - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t3; - FStar_Syntax_Syntax.asc = - (FStar_Pervasives.Inr cty, tacopt, eq); - FStar_Syntax_Syntax.eff_opt = uu___2;_} - -> - Obj.magic - (ret - (FStar_Reflection_V1_Data.Tv_AscribedC - (t3, cty, tacopt, eq))) - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = uu___2; - FStar_Syntax_Syntax.args = [];_} - -> Obj.magic (failwith "empty arguments on Tm_app") - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = hd; - FStar_Syntax_Syntax.args = args;_} - -> - let uu___2 = last args in - (match uu___2 with - | (a, q) -> - let q' = - FStar_Reflection_V1_Builtins.inspect_aqual q in - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = init args in - FStar_Syntax_Syntax.mk_Tm_app hd uu___6 - t2.FStar_Syntax_Syntax.pos in - (uu___5, (a, q')) in - FStar_Reflection_V1_Data.Tv_App uu___4 in - Obj.magic (ret uu___3)) - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = []; - FStar_Syntax_Syntax.body = uu___2; - FStar_Syntax_Syntax.rc_opt = uu___3;_} - -> Obj.magic (failwith "empty arguments on Tm_abs") - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs; - FStar_Syntax_Syntax.body = t3; - FStar_Syntax_Syntax.rc_opt = k;_} - -> - let uu___2 = FStar_Syntax_Subst.open_term bs t3 in - (match uu___2 with - | (bs1, t4) -> - (match bs1 with - | [] -> Obj.magic (failwith "impossible") - | b::bs2 -> - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Syntax_Util.abs bs2 t4 k in - (b, uu___5) in - FStar_Reflection_V1_Data.Tv_Abs uu___4 in - Obj.magic (ret uu___3))) - | FStar_Syntax_Syntax.Tm_type u -> - Obj.magic (ret (FStar_Reflection_V1_Data.Tv_Type u)) - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = []; - FStar_Syntax_Syntax.comp = uu___2;_} - -> Obj.magic (failwith "empty binders on arrow") - | FStar_Syntax_Syntax.Tm_arrow uu___2 -> - let uu___3 = FStar_Syntax_Util.arrow_one t2 in - (match uu___3 with - | FStar_Pervasives_Native.Some (b, c) -> - Obj.magic - (ret (FStar_Reflection_V1_Data.Tv_Arrow (b, c))) - | FStar_Pervasives_Native.None -> - Obj.magic (failwith "impossible")) - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = bv; - FStar_Syntax_Syntax.phi = t3;_} - -> - let b = FStar_Syntax_Syntax.mk_binder bv in - let uu___2 = FStar_Syntax_Subst.open_term [b] t3 in - (match uu___2 with - | (b', t4) -> - let b1 = - match b' with - | b'1::[] -> b'1 - | uu___3 -> failwith "impossible" in - Obj.magic - (ret - (FStar_Reflection_V1_Data.Tv_Refine - ((b1.FStar_Syntax_Syntax.binder_bv), - ((b1.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort), - t4)))) - | FStar_Syntax_Syntax.Tm_constant c -> - let uu___2 = - let uu___3 = - FStar_Reflection_V1_Builtins.inspect_const c in - FStar_Reflection_V1_Data.Tv_Const uu___3 in - Obj.magic (ret uu___2) - | FStar_Syntax_Syntax.Tm_uvar (ctx_u, s) -> - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Syntax_Unionfind.uvar_unique_id - ctx_u.FStar_Syntax_Syntax.ctx_uvar_head in - FStar_BigInt.of_int_fs uu___5 in - (uu___4, (ctx_u, s)) in - FStar_Reflection_V1_Data.Tv_Uvar uu___3 in - Obj.magic (ret uu___2) - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (false, lb::[]); - FStar_Syntax_Syntax.body1 = t21;_} - -> - if lb.FStar_Syntax_Syntax.lbunivs <> [] - then Obj.magic (ret FStar_Reflection_V1_Data.Tv_Unsupp) - else - (match lb.FStar_Syntax_Syntax.lbname with - | FStar_Pervasives.Inr uu___3 -> - Obj.magic - (ret FStar_Reflection_V1_Data.Tv_Unsupp) - | FStar_Pervasives.Inl bv -> - let b = FStar_Syntax_Syntax.mk_binder bv in - let uu___3 = FStar_Syntax_Subst.open_term [b] t21 in - (match uu___3 with - | (bs, t22) -> - let b1 = - match bs with - | b2::[] -> b2 - | uu___4 -> - failwith - "impossible: open_term returned different amount of binders" in - Obj.magic - (ret - (FStar_Reflection_V1_Data.Tv_Let - (false, - (lb.FStar_Syntax_Syntax.lbattrs), - (b1.FStar_Syntax_Syntax.binder_bv), - (bv.FStar_Syntax_Syntax.sort), - (lb.FStar_Syntax_Syntax.lbdef), - t22))))) - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (true, lb::[]); - FStar_Syntax_Syntax.body1 = t21;_} - -> - if lb.FStar_Syntax_Syntax.lbunivs <> [] - then Obj.magic (ret FStar_Reflection_V1_Data.Tv_Unsupp) - else - (match lb.FStar_Syntax_Syntax.lbname with - | FStar_Pervasives.Inr uu___3 -> - Obj.magic - (ret FStar_Reflection_V1_Data.Tv_Unsupp) - | FStar_Pervasives.Inl bv -> - let uu___3 = - FStar_Syntax_Subst.open_let_rec [lb] t21 in - (match uu___3 with - | (lbs, t22) -> - (match lbs with - | lb1::[] -> - (match lb1.FStar_Syntax_Syntax.lbname - with - | FStar_Pervasives.Inr uu___4 -> - Obj.magic - (ret - FStar_Reflection_V1_Data.Tv_Unsupp) - | FStar_Pervasives.Inl bv1 -> - Obj.magic - (ret - (FStar_Reflection_V1_Data.Tv_Let - (true, - (lb1.FStar_Syntax_Syntax.lbattrs), - bv1, - (bv1.FStar_Syntax_Syntax.sort), - (lb1.FStar_Syntax_Syntax.lbdef), - t22)))) - | uu___4 -> - Obj.magic - (failwith - "impossible: open_term returned different amount of binders")))) - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = t3; - FStar_Syntax_Syntax.ret_opt = ret_opt; - FStar_Syntax_Syntax.brs = brs; - FStar_Syntax_Syntax.rc_opt1 = uu___2;_} - -> - let rec inspect_pat p = - match p.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_constant c -> - let uu___3 = - FStar_Reflection_V1_Builtins.inspect_const c in - FStar_Reflection_V1_Data.Pat_Constant uu___3 - | FStar_Syntax_Syntax.Pat_cons (fv, us_opt, ps) -> - let uu___3 = - let uu___4 = - FStar_Compiler_List.map - (fun uu___5 -> - match uu___5 with - | (p1, b) -> - let uu___6 = inspect_pat p1 in - (uu___6, b)) ps in - (fv, us_opt, uu___4) in - FStar_Reflection_V1_Data.Pat_Cons uu___3 - | FStar_Syntax_Syntax.Pat_var bv -> - FStar_Reflection_V1_Data.Pat_Var - (bv, - (FStar_Compiler_Sealed.seal - bv.FStar_Syntax_Syntax.sort)) - | FStar_Syntax_Syntax.Pat_dot_term eopt -> - FStar_Reflection_V1_Data.Pat_Dot_Term eopt in - let brs1 = - FStar_Compiler_List.map FStar_Syntax_Subst.open_branch - brs in - let brs2 = - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with - | (pat, uu___4, t4) -> - let uu___5 = inspect_pat pat in (uu___5, t4)) - brs1 in - Obj.magic - (ret - (FStar_Reflection_V1_Data.Tv_Match - (t3, ret_opt, brs2))) - | FStar_Syntax_Syntax.Tm_unknown -> - Obj.magic (ret FStar_Reflection_V1_Data.Tv_Unknown) - | uu___2 -> - ((let uu___4 = - let uu___5 = - FStar_Class_Tagged.tag_of - FStar_Syntax_Syntax.tagged_term t2 in - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t2 in - FStar_Compiler_Util.format2 - "inspect: outside of expected syntax (%s, %s)\n" - uu___5 uu___6 in - FStar_Errors.log_issue - (FStar_Syntax_Syntax.has_range_syntax ()) t2 - FStar_Errors_Codes.Warning_CantInspect () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4)); - Obj.magic (ret FStar_Reflection_V1_Data.Tv_Unsupp))) - uu___2)) in - FStar_Tactics_Monad.wrap_err "inspect" uu___ -let (pack' : - FStar_Reflection_V1_Data.term_view -> - Prims.bool -> FStar_Syntax_Syntax.term FStar_Tactics_Monad.tac) - = - fun tv -> - fun leave_curried -> - match tv with - | FStar_Reflection_V1_Data.Tv_Var bv -> - let uu___ = FStar_Syntax_Syntax.bv_to_name bv in ret uu___ - | FStar_Reflection_V1_Data.Tv_BVar bv -> - let uu___ = FStar_Syntax_Syntax.bv_to_tm bv in ret uu___ - | FStar_Reflection_V1_Data.Tv_FVar fv -> - let uu___ = FStar_Syntax_Syntax.fv_to_tm fv in ret uu___ - | FStar_Reflection_V1_Data.Tv_UInst (fv, us) -> - let uu___ = - let uu___1 = FStar_Syntax_Syntax.fv_to_tm fv in - FStar_Syntax_Syntax.mk_Tm_uinst uu___1 us in - ret uu___ - | FStar_Reflection_V1_Data.Tv_App (l, (r, q)) -> - let q' = FStar_Reflection_V1_Builtins.pack_aqual q in - let uu___ = FStar_Syntax_Util.mk_app l [(r, q')] in ret uu___ - | FStar_Reflection_V1_Data.Tv_Abs (b, t) -> - let uu___ = - FStar_Syntax_Util.abs [b] t FStar_Pervasives_Native.None in - ret uu___ - | FStar_Reflection_V1_Data.Tv_Arrow (b, c) -> - let uu___ = - if leave_curried - then FStar_Syntax_Util.arrow [b] c - else - (let uu___2 = FStar_Syntax_Util.arrow [b] c in - FStar_Syntax_Util.canon_arrow uu___2) in - ret uu___ - | FStar_Reflection_V1_Data.Tv_Type u -> - let uu___ = - FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_type u) - FStar_Compiler_Range_Type.dummyRange in - ret uu___ - | FStar_Reflection_V1_Data.Tv_Refine (bv, sort, t) -> - let bv1 = - { - FStar_Syntax_Syntax.ppname = (bv.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = (bv.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = sort - } in - let uu___ = FStar_Syntax_Util.refine bv1 t in ret uu___ - | FStar_Reflection_V1_Data.Tv_Const c -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Reflection_V1_Builtins.pack_const c in - FStar_Syntax_Syntax.Tm_constant uu___2 in - FStar_Syntax_Syntax.mk uu___1 - FStar_Compiler_Range_Type.dummyRange in - ret uu___ - | FStar_Reflection_V1_Data.Tv_Uvar (_u, ctx_u_s) -> - let uu___ = - FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_uvar ctx_u_s) - FStar_Compiler_Range_Type.dummyRange in - ret uu___ - | FStar_Reflection_V1_Data.Tv_Let (false, attrs, bv, ty, t1, t2) -> - let bv1 = - { - FStar_Syntax_Syntax.ppname = (bv.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = (bv.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = ty - } in - let lb = - FStar_Syntax_Util.mk_letbinding (FStar_Pervasives.Inl bv1) [] - bv1.FStar_Syntax_Syntax.sort FStar_Parser_Const.effect_Tot_lid - t1 attrs FStar_Compiler_Range_Type.dummyRange in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.mk_binder bv1 in - [uu___5] in - FStar_Syntax_Subst.close uu___4 t2 in - { - FStar_Syntax_Syntax.lbs = (false, [lb]); - FStar_Syntax_Syntax.body1 = uu___3 - } in - FStar_Syntax_Syntax.Tm_let uu___2 in - FStar_Syntax_Syntax.mk uu___1 - FStar_Compiler_Range_Type.dummyRange in - ret uu___ - | FStar_Reflection_V1_Data.Tv_Let (true, attrs, bv, ty, t1, t2) -> - let bv1 = - { - FStar_Syntax_Syntax.ppname = (bv.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = (bv.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = ty - } in - let lb = - FStar_Syntax_Util.mk_letbinding (FStar_Pervasives.Inl bv1) [] - bv1.FStar_Syntax_Syntax.sort FStar_Parser_Const.effect_Tot_lid - t1 attrs FStar_Compiler_Range_Type.dummyRange in - let uu___ = FStar_Syntax_Subst.close_let_rec [lb] t2 in - (match uu___ with - | (lbs, body) -> - let uu___1 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = (true, lbs); - FStar_Syntax_Syntax.body1 = body - }) FStar_Compiler_Range_Type.dummyRange in - ret uu___1) - | FStar_Reflection_V1_Data.Tv_Match (t, ret_opt, brs) -> - let wrap v = - { - FStar_Syntax_Syntax.v = v; - FStar_Syntax_Syntax.p = FStar_Compiler_Range_Type.dummyRange - } in - let rec pack_pat p = - match p with - | FStar_Reflection_V1_Data.Pat_Constant c -> - let uu___ = - let uu___1 = FStar_Reflection_V1_Builtins.pack_const c in - FStar_Syntax_Syntax.Pat_constant uu___1 in - wrap uu___ - | FStar_Reflection_V1_Data.Pat_Cons (fv, us_opt, ps) -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with - | (p1, b) -> - let uu___4 = pack_pat p1 in (uu___4, b)) ps in - (fv, us_opt, uu___2) in - FStar_Syntax_Syntax.Pat_cons uu___1 in - wrap uu___ - | FStar_Reflection_V1_Data.Pat_Var (bv, _sort) -> - wrap (FStar_Syntax_Syntax.Pat_var bv) - | FStar_Reflection_V1_Data.Pat_Dot_Term eopt -> - wrap (FStar_Syntax_Syntax.Pat_dot_term eopt) in - let brs1 = - FStar_Compiler_List.map - (fun uu___ -> - match uu___ with - | (pat, t1) -> - let uu___1 = pack_pat pat in - (uu___1, FStar_Pervasives_Native.None, t1)) brs in - let brs2 = - FStar_Compiler_List.map FStar_Syntax_Subst.close_branch brs1 in - let uu___ = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_match - { - FStar_Syntax_Syntax.scrutinee = t; - FStar_Syntax_Syntax.ret_opt = ret_opt; - FStar_Syntax_Syntax.brs = brs2; - FStar_Syntax_Syntax.rc_opt1 = FStar_Pervasives_Native.None - }) FStar_Compiler_Range_Type.dummyRange in - ret uu___ - | FStar_Reflection_V1_Data.Tv_AscribedT (e, t, tacopt, use_eq) -> - let uu___ = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_ascribed - { - FStar_Syntax_Syntax.tm = e; - FStar_Syntax_Syntax.asc = - ((FStar_Pervasives.Inl t), tacopt, use_eq); - FStar_Syntax_Syntax.eff_opt = FStar_Pervasives_Native.None - }) FStar_Compiler_Range_Type.dummyRange in - ret uu___ - | FStar_Reflection_V1_Data.Tv_AscribedC (e, c, tacopt, use_eq) -> - let uu___ = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_ascribed - { - FStar_Syntax_Syntax.tm = e; - FStar_Syntax_Syntax.asc = - ((FStar_Pervasives.Inr c), tacopt, use_eq); - FStar_Syntax_Syntax.eff_opt = FStar_Pervasives_Native.None - }) FStar_Compiler_Range_Type.dummyRange in - ret uu___ - | FStar_Reflection_V1_Data.Tv_Unknown -> - let uu___ = - FStar_Syntax_Syntax.mk FStar_Syntax_Syntax.Tm_unknown - FStar_Compiler_Range_Type.dummyRange in - ret uu___ - | FStar_Reflection_V1_Data.Tv_Unsupp -> - FStar_Tactics_Monad.fail "cannot pack Tv_Unsupp" -let (pack : - FStar_Reflection_V1_Data.term_view -> - FStar_Syntax_Syntax.term FStar_Tactics_Monad.tac) - = fun tv -> pack' tv false -let (pack_curried : - FStar_Reflection_V1_Data.term_view -> - FStar_Syntax_Syntax.term FStar_Tactics_Monad.tac) - = fun tv -> pack' tv true -let (lget : - FStar_Syntax_Syntax.typ -> - Prims.string -> FStar_Syntax_Syntax.term FStar_Tactics_Monad.tac) - = - fun ty -> - fun k -> - let uu___ = - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.get) - (fun uu___1 -> - (fun ps -> - let ps = Obj.magic ps in - let uu___1 = - FStar_Compiler_Util.psmap_try_find - ps.FStar_Tactics_Types.local_state k in - match uu___1 with - | FStar_Pervasives_Native.None -> - Obj.magic (FStar_Tactics_Monad.fail "not found") - | FStar_Pervasives_Native.Some t -> - Obj.magic (unquote ty t)) uu___1)) in - FStar_Tactics_Monad.wrap_err "lget" uu___ -let (lset : - FStar_Syntax_Syntax.typ -> - Prims.string -> FStar_Syntax_Syntax.term -> unit FStar_Tactics_Monad.tac) - = - fun _ty -> - fun k -> - fun t -> - let uu___ = - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.get) - (fun uu___1 -> - (fun ps -> - let ps = Obj.magic ps in - let ps1 = - let uu___1 = - FStar_Compiler_Util.psmap_add - ps.FStar_Tactics_Types.local_state k t in - { - FStar_Tactics_Types.main_context = - (ps.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits = - (ps.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = - (ps.FStar_Tactics_Types.goals); - FStar_Tactics_Types.smt_goals = - (ps.FStar_Tactics_Types.smt_goals); - FStar_Tactics_Types.depth = - (ps.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = - (ps.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = (ps.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (ps.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = - (ps.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness = - (ps.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg = - (ps.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = uu___1; - FStar_Tactics_Types.urgency = - (ps.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure = - (ps.FStar_Tactics_Types.dump_on_failure) - } in - Obj.magic (FStar_Tactics_Monad.set ps1)) uu___1) in - FStar_Tactics_Monad.wrap_err "lset" uu___ -let (set_urgency : FStar_BigInt.t -> unit FStar_Tactics_Monad.tac) = - fun u -> - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.get) - (fun uu___ -> - (fun ps -> - let ps = Obj.magic ps in - let ps1 = - let uu___ = FStar_BigInt.to_int_fs u in - { - FStar_Tactics_Types.main_context = - (ps.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits = - (ps.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = (ps.FStar_Tactics_Types.goals); - FStar_Tactics_Types.smt_goals = - (ps.FStar_Tactics_Types.smt_goals); - FStar_Tactics_Types.depth = (ps.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = (ps.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = (ps.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (ps.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = - (ps.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness = - (ps.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg = - (ps.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = - (ps.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency = uu___; - FStar_Tactics_Types.dump_on_failure = - (ps.FStar_Tactics_Types.dump_on_failure) - } in - Obj.magic (FStar_Tactics_Monad.set ps1)) uu___) -let (t_commute_applied_match : unit -> unit FStar_Tactics_Monad.tac) = - fun uu___ -> - let uu___1 = - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___2 -> - (fun g -> - let g = Obj.magic g in - let uu___2 = - let uu___3 = FStar_Tactics_Types.goal_env g in - let uu___4 = FStar_Tactics_Types.goal_type g in - destruct_eq uu___3 uu___4 in - match uu___2 with - | FStar_Pervasives_Native.Some (l, r) -> - let uu___3 = FStar_Syntax_Util.head_and_args_full l in - (match uu___3 with - | (lh, las) -> - let uu___4 = - let uu___5 = - let uu___6 = FStar_Syntax_Util.unascribe lh in - FStar_Syntax_Subst.compress uu___6 in - uu___5.FStar_Syntax_Syntax.n in - (match uu___4 with - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = e; - FStar_Syntax_Syntax.ret_opt = asc_opt; - FStar_Syntax_Syntax.brs = brs; - FStar_Syntax_Syntax.rc_opt1 = lopt;_} - -> - let brs' = - FStar_Compiler_List.map - (fun uu___5 -> - match uu___5 with - | (p, w, e1) -> - let uu___6 = - FStar_Syntax_Util.mk_app e1 las in - (p, w, uu___6)) brs in - let lopt' = - FStar_Compiler_Util.map_option - (fun rc -> - let uu___5 = - FStar_Compiler_Util.map_option - (fun t -> - let uu___6 = - let uu___7 = - FStar_Tactics_Types.goal_env g in - FStar_TypeChecker_Normalize.get_n_binders - uu___7 - (FStar_Compiler_List.length las) - t in - match uu___6 with - | (bs, c) -> - let uu___7 = - FStar_Syntax_Subst.open_comp - bs c in - (match uu___7 with - | (bs1, c1) -> - let ss = - FStar_Compiler_List.map2 - (fun b -> - fun a -> - FStar_Syntax_Syntax.NT - ((b.FStar_Syntax_Syntax.binder_bv), - (FStar_Pervasives_Native.fst - a))) bs1 - las in - let c2 = - FStar_Syntax_Subst.subst_comp - ss c1 in - FStar_Syntax_Util.comp_result - c2)) - rc.FStar_Syntax_Syntax.residual_typ in - { - FStar_Syntax_Syntax.residual_effect = - (rc.FStar_Syntax_Syntax.residual_effect); - FStar_Syntax_Syntax.residual_typ = - uu___5; - FStar_Syntax_Syntax.residual_flags = - (rc.FStar_Syntax_Syntax.residual_flags) - }) lopt in - let l' = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_match - { - FStar_Syntax_Syntax.scrutinee = e; - FStar_Syntax_Syntax.ret_opt = asc_opt; - FStar_Syntax_Syntax.brs = brs'; - FStar_Syntax_Syntax.rc_opt1 = lopt' - }) l.FStar_Syntax_Syntax.pos in - let must_tot = true in - let uu___5 = - let uu___6 = FStar_Tactics_Types.goal_env g in - do_unify_maybe_guards false must_tot uu___6 l' - r in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___5) - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = Obj.magic uu___6 in - match uu___6 with - | FStar_Pervasives_Native.None -> - Obj.magic - (FStar_Tactics_Monad.fail - "discharging the equality failed") - | FStar_Pervasives_Native.Some guard - -> - let uu___7 = - FStar_TypeChecker_Env.is_trivial_guard_formula - guard in - if uu___7 - then - (mark_uvar_as_already_checked - g.FStar_Tactics_Types.goal_ctx_uvar; - Obj.magic - (solve g - FStar_Syntax_Util.exp_unit)) - else - Obj.magic - (failwith - "internal error: _t_refl: guard is not trivial")) - uu___6)) - | uu___5 -> - Obj.magic - (FStar_Tactics_Monad.fail "lhs is not a match"))) - | FStar_Pervasives_Native.None -> - Obj.magic (FStar_Tactics_Monad.fail "not an equality")) - uu___2) in - FStar_Tactics_Monad.wrap_err "t_commute_applied_match" uu___1 -let (string_to_term : - env -> Prims.string -> FStar_Syntax_Syntax.term FStar_Tactics_Monad.tac) = - fun e -> - fun s -> - let frag_of_text s1 = - { - FStar_Parser_ParseIt.frag_fname = ""; - FStar_Parser_ParseIt.frag_text = s1; - FStar_Parser_ParseIt.frag_line = Prims.int_one; - FStar_Parser_ParseIt.frag_col = Prims.int_zero - } in - let uu___ = - FStar_Parser_ParseIt.parse FStar_Pervasives_Native.None - (FStar_Parser_ParseIt.Fragment (frag_of_text s)) in - match uu___ with - | FStar_Parser_ParseIt.Term t -> - let dsenv = - let uu___1 = FStar_TypeChecker_Env.current_module e in - FStar_Syntax_DsEnv.set_current_module - e.FStar_TypeChecker_Env.dsenv uu___1 in - (try - (fun uu___1 -> - match () with - | () -> - let uu___2 = FStar_ToSyntax_ToSyntax.desugar_term dsenv t in - ret uu___2) () - with - | FStar_Errors.Error (uu___2, e1, uu___3, uu___4) -> - let uu___5 = - let uu___6 = FStar_Errors_Msg.rendermsg e1 in - Prims.strcat "string_to_term: " uu___6 in - FStar_Tactics_Monad.fail uu___5 - | uu___2 -> - FStar_Tactics_Monad.fail "string_to_term: Unknown error") - | FStar_Parser_ParseIt.ASTFragment uu___1 -> - FStar_Tactics_Monad.fail - "string_to_term: expected a Term as a result, got an ASTFragment" - | FStar_Parser_ParseIt.ParseError (uu___1, err, uu___2) -> - let uu___3 = - let uu___4 = FStar_Errors_Msg.rendermsg err in - Prims.strcat "string_to_term: got error " uu___4 in - FStar_Tactics_Monad.fail uu___3 -let (push_bv_dsenv : - env -> - Prims.string -> (env * FStar_Syntax_Syntax.bv) FStar_Tactics_Monad.tac) - = - fun e -> - fun i -> - let ident = - FStar_Ident.mk_ident (i, FStar_Compiler_Range_Type.dummyRange) in - let uu___ = - FStar_Syntax_DsEnv.push_bv e.FStar_TypeChecker_Env.dsenv ident in - match uu___ with - | (dsenv, bv) -> - ret - ({ - FStar_TypeChecker_Env.solver = - (e.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = (e.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (e.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = (e.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (e.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (e.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (e.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (e.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (e.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (e.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (e.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (e.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (e.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (e.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (e.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (e.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (e.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (e.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = (e.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (e.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (e.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (e.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (e.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (e.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (e.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (e.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (e.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (e.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (e.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (e.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (e.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (e.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (e.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (e.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (e.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (e.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (e.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (e.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (e.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (e.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (e.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (e.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (e.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = dsenv; - FStar_TypeChecker_Env.nbe = (e.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (e.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (e.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (e.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (e.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (e.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (e.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (e.FStar_TypeChecker_Env.missing_decl) - }, bv) -let (term_to_string : - FStar_Syntax_Syntax.term -> Prims.string FStar_Tactics_Monad.tac) = - fun t -> - let s = FStar_Class_Show.show FStar_Syntax_Print.showable_term t in ret s -let (comp_to_string : - FStar_Syntax_Syntax.comp -> Prims.string FStar_Tactics_Monad.tac) = - fun c -> - let s = FStar_Class_Show.show FStar_Syntax_Print.showable_comp c in ret s -let (range_to_string : - FStar_Compiler_Range_Type.range -> Prims.string FStar_Tactics_Monad.tac) = - fun r -> - let uu___ = - FStar_Class_Show.show FStar_Compiler_Range_Ops.showable_range r in - ret uu___ -let (term_eq_old : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> Prims.bool FStar_Tactics_Monad.tac) - = - fun uu___1 -> - fun uu___ -> - (fun t1 -> - fun t2 -> - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - () idtac - (fun uu___ -> - (fun uu___ -> - let uu___ = Obj.magic uu___ in - let uu___1 = FStar_Syntax_Util.term_eq t1 t2 in - Obj.magic (ret uu___1)) uu___))) uu___1 uu___ -let with_compat_pre_core : - 'a . - FStar_BigInt.t -> - 'a FStar_Tactics_Monad.tac -> 'a FStar_Tactics_Monad.tac - = - fun n -> - fun f -> - FStar_Tactics_Monad.mk_tac - (fun ps -> - FStar_Options.with_saved_options - (fun uu___ -> - let _res = FStar_Options.set_options "--compat_pre_core 0" in - FStar_Tactics_Monad.run f ps)) -let (get_vconfig : unit -> FStar_VConfig.vconfig FStar_Tactics_Monad.tac) = - fun uu___ -> - (fun uu___ -> - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___1 -> - (fun g -> - let g = Obj.magic g in - let vcfg = - FStar_Options.with_saved_options - (fun uu___1 -> - FStar_Options.set g.FStar_Tactics_Types.opts; - FStar_Options.get_vconfig ()) in - Obj.magic (ret vcfg)) uu___1))) uu___ -let (set_vconfig : FStar_VConfig.vconfig -> unit FStar_Tactics_Monad.tac) = - fun vcfg -> - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___ -> - (fun g -> - let g = Obj.magic g in - let opts' = - FStar_Options.with_saved_options - (fun uu___ -> - FStar_Options.set g.FStar_Tactics_Types.opts; - FStar_Options.set_vconfig vcfg; - FStar_Options.peek ()) in - let g' = - { - FStar_Tactics_Types.goal_main_env = - (g.FStar_Tactics_Types.goal_main_env); - FStar_Tactics_Types.goal_ctx_uvar = - (g.FStar_Tactics_Types.goal_ctx_uvar); - FStar_Tactics_Types.opts = opts'; - FStar_Tactics_Types.is_guard = - (g.FStar_Tactics_Types.is_guard); - FStar_Tactics_Types.label = (g.FStar_Tactics_Types.label) - } in - Obj.magic (FStar_Tactics_Monad.replace_cur g')) uu___) -let (t_smt_sync : FStar_VConfig.vconfig -> unit FStar_Tactics_Monad.tac) = - fun vcfg -> - let uu___ = - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___1 -> - (fun goal -> - let goal = Obj.magic goal in - let uu___1 = get_phi goal in - match uu___1 with - | FStar_Pervasives_Native.None -> - Obj.magic - (FStar_Tactics_Monad.fail "Goal is not irrelevant") - | FStar_Pervasives_Native.Some phi -> - let e = FStar_Tactics_Types.goal_env goal in - let ans = - FStar_Options.with_saved_options - (fun uu___2 -> - FStar_Options.set_vconfig vcfg; - (e.FStar_TypeChecker_Env.solver).FStar_TypeChecker_Env.solve_sync - FStar_Pervasives_Native.None e phi) in - if ans - then - (mark_uvar_as_already_checked - goal.FStar_Tactics_Types.goal_ctx_uvar; - Obj.magic (solve goal FStar_Syntax_Util.exp_unit)) - else - Obj.magic - (FStar_Tactics_Monad.fail "SMT did not solve this goal")) - uu___1) in - FStar_Tactics_Monad.wrap_err "t_smt_sync" uu___ -let (free_uvars : - FStar_Syntax_Syntax.term -> - FStar_BigInt.t Prims.list FStar_Tactics_Monad.tac) - = - fun uu___ -> - (fun tm -> - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - idtac - (fun uu___ -> - (fun uu___ -> - let uu___ = Obj.magic uu___ in - let uvs = - let uu___1 = - let uu___2 = FStar_Syntax_Free.uvars_uncached tm in - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) - (Obj.magic uu___2) in - FStar_Compiler_List.map - (fun u -> - let uu___2 = - FStar_Syntax_Unionfind.uvar_id - u.FStar_Syntax_Syntax.ctx_uvar_head in - FStar_BigInt.of_int_fs uu___2) uu___1 in - Obj.magic (ret uvs)) uu___))) uu___ -let (dbg_refl : env -> (unit -> Prims.string) -> unit) = - fun g -> - fun msg -> - let uu___ = FStar_Compiler_Effect.op_Bang dbg_ReflTc in - if uu___ - then let uu___1 = msg () in FStar_Compiler_Util.print_string uu___1 - else () -type issues = FStar_Errors.issue Prims.list -let refl_typing_builtin_wrapper : - 'a . - (unit -> 'a) -> - ('a FStar_Pervasives_Native.option * issues) FStar_Tactics_Monad.tac - = - fun f -> - let tx = FStar_Syntax_Unionfind.new_transaction () in - let uu___ = - try - (fun uu___1 -> - match () with | () -> FStar_Errors.catch_errors_and_ignore_rest f) - () - with - | uu___1 -> - let issue = - let uu___2 = - let uu___3 = FStar_Compiler_Util.print_exn uu___1 in - FStar_Errors_Msg.mkmsg uu___3 in - let uu___3 = FStar_Errors.get_ctx () in - { - FStar_Errors.issue_msg = uu___2; - FStar_Errors.issue_level = FStar_Errors.EError; - FStar_Errors.issue_range = FStar_Pervasives_Native.None; - FStar_Errors.issue_number = - (FStar_Pervasives_Native.Some (Prims.of_int (17))); - FStar_Errors.issue_ctx = uu___3 - } in - ([issue], FStar_Pervasives_Native.None) in - match uu___ with - | (errs, r) -> - (FStar_Syntax_Unionfind.rollback tx; - if (FStar_Compiler_List.length errs) > Prims.int_zero - then ret (FStar_Pervasives_Native.None, errs) - else ret (r, errs)) -let (no_uvars_in_term : FStar_Syntax_Syntax.term -> Prims.bool) = - fun t -> - (let uu___ = FStar_Syntax_Free.uvars t in - FStar_Class_Setlike.is_empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) (Obj.magic uu___)) - && - (let uu___ = FStar_Syntax_Free.univs t in - FStar_Class_Setlike.is_empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_univ_uvar)) (Obj.magic uu___)) -let (no_uvars_in_g : env -> Prims.bool) = - fun g -> - FStar_Compiler_Util.for_all - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.Binding_var bv -> - no_uvars_in_term bv.FStar_Syntax_Syntax.sort - | uu___1 -> true) g.FStar_TypeChecker_Env.gamma -type relation = - | Subtyping - | Equality -let (uu___is_Subtyping : relation -> Prims.bool) = - fun projectee -> match projectee with | Subtyping -> true | uu___ -> false -let (uu___is_Equality : relation -> Prims.bool) = - fun projectee -> match projectee with | Equality -> true | uu___ -> false -let (unexpected_uvars_issue : - FStar_Compiler_Range_Type.range -> FStar_Errors.issue) = - fun r -> - let i = - let uu___ = FStar_Errors_Msg.mkmsg "Cannot check relation with uvars" in - let uu___1 = - let uu___2 = - FStar_Errors.errno - FStar_Errors_Codes.Error_UnexpectedUnresolvedUvar in - FStar_Pervasives_Native.Some uu___2 in - { - FStar_Errors.issue_msg = uu___; - FStar_Errors.issue_level = FStar_Errors.EError; - FStar_Errors.issue_range = (FStar_Pervasives_Native.Some r); - FStar_Errors.issue_number = uu___1; - FStar_Errors.issue_ctx = [] - } in - i \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_V1_Derived.ml b/ocaml/fstar-lib/generated/FStar_Tactics_V1_Derived.ml index c6111599643..7edb91e2ac1 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_V1_Derived.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_V1_Derived.ml @@ -4,22 +4,22 @@ let op_At : unit -> 'uuuuu Prims.list -> 'uuuuu Prims.list -> 'uuuuu Prims.list = fun uu___ -> FStar_List_Tot_Base.op_At let (name_of_bv : - FStar_Reflection_Types.bv -> + FStarC_Reflection_Types.bv -> (Prims.string, unit) FStar_Tactics_Effect.tac_repr) = fun bv -> FStar_Tactics_Unseal.unseal - (FStar_Reflection_V1_Builtins.inspect_bv bv).FStar_Reflection_V1_Data.bv_ppname + (FStarC_Reflection_V1_Builtins.inspect_bv bv).FStarC_Reflection_V1_Data.bv_ppname let (bv_to_string : - FStar_Reflection_Types.bv -> + FStarC_Reflection_Types.bv -> (Prims.string, unit) FStar_Tactics_Effect.tac_repr) = fun bv -> name_of_bv bv let (name_of_binder : - FStar_Reflection_Types.binder -> + FStarC_Reflection_Types.binder -> (Prims.string, unit) FStar_Tactics_Effect.tac_repr) = fun b -> name_of_bv (FStar_Reflection_V1_Derived.bv_of_binder b) let (binder_to_string : - FStar_Reflection_Types.binder -> + FStarC_Reflection_Types.binder -> (Prims.string, unit) FStar_Tactics_Effect.tac_repr) = fun b -> bv_to_string (FStar_Reflection_V1_Derived.bv_of_binder b) exception Goal_not_trivial @@ -28,7 +28,8 @@ let (uu___is_Goal_not_trivial : Prims.exn -> Prims.bool) = match projectee with | Goal_not_trivial -> true | uu___ -> false let (goals : unit -> - (FStar_Tactics_Types.goal Prims.list, unit) FStar_Tactics_Effect.tac_repr) + (FStarC_Tactics_Types.goal Prims.list, unit) + FStar_Tactics_Effect.tac_repr) = fun uu___ -> let uu___1 = Obj.magic (FStar_Tactics_Effect.get ()) in @@ -45,10 +46,11 @@ let (goals : (Prims.of_int (50))))) (Obj.magic uu___1) (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___3 -> FStar_Tactics_Types.goals_of uu___2)) + (fun uu___3 -> FStarC_Tactics_Types.goals_of uu___2)) let (smt_goals : unit -> - (FStar_Tactics_Types.goal Prims.list, unit) FStar_Tactics_Effect.tac_repr) + (FStarC_Tactics_Types.goal Prims.list, unit) + FStar_Tactics_Effect.tac_repr) = fun uu___ -> let uu___1 = Obj.magic (FStar_Tactics_Effect.get ()) in @@ -65,16 +67,16 @@ let (smt_goals : (Prims.of_int (58))))) (Obj.magic uu___1) (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___3 -> FStar_Tactics_Types.smt_goals_of uu___2)) + (fun uu___3 -> FStarC_Tactics_Types.smt_goals_of uu___2)) let fail : 'a . Prims.string -> ('a, Obj.t) FStar_Tactics_Effect.tac_repr = fun m -> FStar_Tactics_Effect.raise - (FStar_Tactics_Common.TacticFailure - ((FStar_Errors_Msg.mkmsg m), FStar_Pervasives_Native.None)) + (FStarC_Tactics_Common.TacticFailure + ((FStarC_Errors_Msg.mkmsg m), FStar_Pervasives_Native.None)) let fail_silently : 'a . Prims.string -> ('a, unit) FStar_Tactics_Effect.tac_repr = fun m -> - let uu___ = FStar_Tactics_V1_Builtins.set_urgency Prims.int_zero in + let uu___ = FStarC_Tactics_V1_Builtins.set_urgency Prims.int_zero in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -88,10 +90,10 @@ let fail_silently : (Prims.of_int (44))))) (Obj.magic uu___) (fun uu___1 -> FStar_Tactics_Effect.raise - (FStar_Tactics_Common.TacticFailure - ((FStar_Errors_Msg.mkmsg m), FStar_Pervasives_Native.None))) + (FStarC_Tactics_Common.TacticFailure + ((FStarC_Errors_Msg.mkmsg m), FStar_Pervasives_Native.None))) let (_cur_goal : - unit -> (FStar_Tactics_Types.goal, unit) FStar_Tactics_Effect.tac_repr) = + unit -> (FStarC_Tactics_Types.goal, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> let uu___1 = goals () in FStar_Tactics_Effect.tac_bind @@ -110,7 +112,8 @@ let (_cur_goal : | [] -> fail "no more goals" | g::uu___3 -> FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> g)) let (cur_env : - unit -> (FStar_Reflection_Types.env, unit) FStar_Tactics_Effect.tac_repr) = + unit -> (FStarC_Reflection_Types.env, unit) FStar_Tactics_Effect.tac_repr) + = fun uu___ -> let uu___1 = _cur_goal () in FStar_Tactics_Effect.tac_bind @@ -126,9 +129,10 @@ let (cur_env : (Prims.of_int (50))))) (Obj.magic uu___1) (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___3 -> FStar_Tactics_Types.goal_env uu___2)) + (fun uu___3 -> FStarC_Tactics_Types.goal_env uu___2)) let (cur_goal : - unit -> (FStar_Reflection_Types.typ, unit) FStar_Tactics_Effect.tac_repr) = + unit -> (FStarC_Reflection_Types.typ, unit) FStar_Tactics_Effect.tac_repr) + = fun uu___ -> let uu___1 = _cur_goal () in FStar_Tactics_Effect.tac_bind @@ -144,9 +148,9 @@ let (cur_goal : (Prims.of_int (52))))) (Obj.magic uu___1) (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___3 -> FStar_Tactics_Types.goal_type uu___2)) + (fun uu___3 -> FStarC_Tactics_Types.goal_type uu___2)) let (cur_witness : - unit -> (FStar_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) + unit -> (FStarC_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> let uu___1 = _cur_goal () in @@ -163,9 +167,9 @@ let (cur_witness : (Prims.of_int (59))))) (Obj.magic uu___1) (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___3 -> FStar_Tactics_Types.goal_witness uu___2)) + (fun uu___3 -> FStarC_Tactics_Types.goal_witness uu___2)) let (cur_goal_safe : - unit -> (FStar_Tactics_Types.goal, unit) FStar_Tactics_Effect.tac_repr) = + unit -> (FStarC_Tactics_Types.goal, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> let uu___1 = let uu___2 = Obj.magic (FStar_Tactics_Effect.get ()) in @@ -182,7 +186,7 @@ let (cur_goal_safe : (Prims.of_int (26))))) (Obj.magic uu___2) (fun uu___3 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___4 -> FStar_Tactics_Types.goals_of uu___3)) in + (fun uu___4 -> FStarC_Tactics_Types.goals_of uu___3)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -199,7 +203,7 @@ let (cur_goal_safe : (fun uu___3 -> match uu___2 with | g::uu___4 -> g)) let (cur_binders : unit -> - (FStar_Reflection_Types.binders, unit) FStar_Tactics_Effect.tac_repr) + (FStarC_Reflection_Types.binders, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> let uu___1 = cur_env () in @@ -216,16 +220,16 @@ let (cur_binders : (Prims.of_int (31))))) (Obj.magic uu___1) (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___3 -> FStar_Reflection_V1_Builtins.binders_of_env uu___2)) + (fun uu___3 -> FStarC_Reflection_V1_Builtins.binders_of_env uu___2)) let with_policy : 'a . - FStar_Tactics_Types.guard_policy -> + FStarC_Tactics_Types.guard_policy -> (unit -> ('a, unit) FStar_Tactics_Effect.tac_repr) -> ('a, unit) FStar_Tactics_Effect.tac_repr = fun pol -> fun f -> - let uu___ = FStar_Tactics_V1_Builtins.get_guard_policy () in + let uu___ = FStarC_Tactics_V1_Builtins.get_guard_policy () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -239,7 +243,7 @@ let with_policy : (Prims.of_int (5))))) (Obj.magic uu___) (fun uu___1 -> (fun old_pol -> - let uu___1 = FStar_Tactics_V1_Builtins.set_guard_policy pol in + let uu___1 = FStarC_Tactics_V1_Builtins.set_guard_policy pol in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -276,7 +280,7 @@ let with_policy : (fun uu___4 -> (fun r -> let uu___4 = - FStar_Tactics_V1_Builtins.set_guard_policy + FStarC_Tactics_V1_Builtins.set_guard_policy old_pol in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -302,21 +306,21 @@ let with_policy : (fun uu___6 -> r)))) uu___4))) uu___2))) uu___1) let (exact : - FStar_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun t -> - with_policy FStar_Tactics_Types.SMT - (fun uu___ -> FStar_Tactics_V1_Builtins.t_exact true false t) + with_policy FStarC_Tactics_Types.SMT + (fun uu___ -> FStarC_Tactics_V1_Builtins.t_exact true false t) let (exact_with_ref : - FStar_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun t -> - with_policy FStar_Tactics_Types.SMT - (fun uu___ -> FStar_Tactics_V1_Builtins.t_exact true true t) + with_policy FStarC_Tactics_Types.SMT + (fun uu___ -> FStarC_Tactics_V1_Builtins.t_exact true true t) let (trivial : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> let uu___1 = - FStar_Tactics_V1_Builtins.norm + FStarC_Tactics_V1_Builtins.norm [FStar_Pervasives.iota; FStar_Pervasives.zeta; FStar_Pervasives.reify_; @@ -377,9 +381,9 @@ let (trivial : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = Obj.magic (Obj.repr (exact - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const - FStar_Reflection_V2_Data.C_Unit)))) + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const + FStarC_Reflection_V2_Data.C_Unit)))) | uu___6 -> Obj.magic (Obj.repr @@ -405,7 +409,8 @@ let (dismiss : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = match uu___2 with | [] -> Obj.magic (Obj.repr (fail "dismiss: no more goals")) | uu___3::gs -> - Obj.magic (Obj.repr (FStar_Tactics_V1_Builtins.set_goals gs))) + Obj.magic + (Obj.repr (FStarC_Tactics_V1_Builtins.set_goals gs))) uu___2) let (flip : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> @@ -449,7 +454,7 @@ let (flip : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = | g1::g2::gs1 -> Obj.magic (Obj.repr - (FStar_Tactics_V1_Builtins.set_goals (g2 :: + (FStarC_Tactics_V1_Builtins.set_goals (g2 :: g1 :: gs1)))) uu___3))) uu___2) let (qed : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> @@ -471,7 +476,7 @@ let (qed : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = | uu___3 -> fail "qed: not done!") let (debug : Prims.string -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun m -> - let uu___ = FStar_Tactics_V1_Builtins.debugging () in + let uu___ = FStarC_Tactics_V1_Builtins.debugging () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -486,7 +491,7 @@ let (debug : Prims.string -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___1 -> (fun uu___1 -> if uu___1 - then Obj.magic (Obj.repr (FStar_Tactics_V1_Builtins.print m)) + then Obj.magic (Obj.repr (FStarC_Tactics_V1_Builtins.print m)) else Obj.magic (Obj.repr @@ -546,7 +551,7 @@ let (smt : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = | (g::gs, gs') -> Obj.magic (Obj.repr - (let uu___3 = FStar_Tactics_V1_Builtins.set_goals gs in + (let uu___3 = FStarC_Tactics_V1_Builtins.set_goals gs in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -564,7 +569,7 @@ let (smt : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___4 -> (fun uu___4 -> Obj.magic - (FStar_Tactics_V1_Builtins.set_smt_goals (g + (FStarC_Tactics_V1_Builtins.set_smt_goals (g :: gs'))) uu___4)))) uu___2) let (idtac : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> @@ -591,41 +596,42 @@ let (later : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = | g::gs -> Obj.magic (Obj.repr - (FStar_Tactics_V1_Builtins.set_goals ((op_At ()) gs [g]))) + (FStarC_Tactics_V1_Builtins.set_goals + ((op_At ()) gs [g]))) | uu___3 -> Obj.magic (Obj.repr (fail "later: no goals"))) uu___2) let (apply : - FStar_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) - = fun t -> FStar_Tactics_V1_Builtins.t_apply true false false t + FStarC_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) + = fun t -> FStarC_Tactics_V1_Builtins.t_apply true false false t let (apply_noinst : - FStar_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) - = fun t -> FStar_Tactics_V1_Builtins.t_apply true true false t + FStarC_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) + = fun t -> FStarC_Tactics_V1_Builtins.t_apply true true false t let (apply_lemma : - FStar_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) - = fun t -> FStar_Tactics_V1_Builtins.t_apply_lemma false false t + FStarC_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) + = fun t -> FStarC_Tactics_V1_Builtins.t_apply_lemma false false t let (trefl : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = - fun uu___ -> FStar_Tactics_V1_Builtins.t_trefl false + fun uu___ -> FStarC_Tactics_V1_Builtins.t_trefl false let (trefl_guard : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = - fun uu___ -> FStar_Tactics_V1_Builtins.t_trefl true + fun uu___ -> FStarC_Tactics_V1_Builtins.t_trefl true let (commute_applied_match : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = - fun uu___ -> FStar_Tactics_V1_Builtins.t_commute_applied_match () + fun uu___ -> FStarC_Tactics_V1_Builtins.t_commute_applied_match () let (apply_lemma_noinst : - FStar_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) - = fun t -> FStar_Tactics_V1_Builtins.t_apply_lemma true false t + FStarC_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) + = fun t -> FStarC_Tactics_V1_Builtins.t_apply_lemma true false t let (apply_lemma_rw : - FStar_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) - = fun t -> FStar_Tactics_V1_Builtins.t_apply_lemma false true t + FStarC_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) + = fun t -> FStarC_Tactics_V1_Builtins.t_apply_lemma false true t let (apply_raw : - FStar_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) - = fun t -> FStar_Tactics_V1_Builtins.t_apply false false false t + FStarC_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) + = fun t -> FStarC_Tactics_V1_Builtins.t_apply false false false t let (exact_guard : - FStar_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun t -> - with_policy FStar_Tactics_Types.Goal - (fun uu___ -> FStar_Tactics_V1_Builtins.t_exact true false t) + with_policy FStarC_Tactics_Types.Goal + (fun uu___ -> FStarC_Tactics_V1_Builtins.t_exact true false t) let (t_pointwise : - FStar_Tactics_Types.direction -> + FStarC_Tactics_Types.direction -> (unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) -> (unit, unit) FStar_Tactics_Effect.tac_repr) = @@ -641,8 +647,8 @@ let (t_pointwise : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> - (true, FStar_Tactics_Types.Continue)))) uu___2 - uu___1)) in + (true, FStarC_Tactics_Types.Continue)))) + uu___2 uu___1)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -676,10 +682,10 @@ let (t_pointwise : (fun uu___2 -> (fun rw -> Obj.magic - (FStar_Tactics_V1_Builtins.ctrl_rewrite d ctrl rw)) + (FStarC_Tactics_V1_Builtins.ctrl_rewrite d ctrl rw)) uu___2))) uu___1) let (topdown_rewrite : - (FStar_Reflection_Types.term -> + (FStarC_Reflection_Types.term -> ((Prims.bool * Prims.int), unit) FStar_Tactics_Effect.tac_repr) -> (unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) -> @@ -717,17 +723,17 @@ let (topdown_rewrite : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___6 -> - FStar_Tactics_Types.Continue)) + FStarC_Tactics_Types.Continue)) | uu___5 when uu___5 = Prims.int_one -> Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___6 -> - FStar_Tactics_Types.Skip)) + FStarC_Tactics_Types.Skip)) | uu___5 when uu___5 = (Prims.of_int (2)) -> Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___6 -> - FStar_Tactics_Types.Abort)) + FStarC_Tactics_Types.Abort)) | uu___5 -> Obj.magic (fail @@ -768,21 +774,21 @@ let (topdown_rewrite : (fun uu___1 -> (fun ctrl' -> Obj.magic - (FStar_Tactics_V1_Builtins.ctrl_rewrite - FStar_Tactics_Types.TopDown ctrl' rw)) uu___1) + (FStarC_Tactics_V1_Builtins.ctrl_rewrite + FStarC_Tactics_Types.TopDown ctrl' rw)) uu___1) let (pointwise : (unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) -> (unit, unit) FStar_Tactics_Effect.tac_repr) - = fun tau -> t_pointwise FStar_Tactics_Types.BottomUp tau + = fun tau -> t_pointwise FStarC_Tactics_Types.BottomUp tau let (pointwise' : (unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) -> (unit, unit) FStar_Tactics_Effect.tac_repr) - = fun tau -> t_pointwise FStar_Tactics_Types.TopDown tau + = fun tau -> t_pointwise FStarC_Tactics_Types.TopDown tau let (cur_module : - unit -> (FStar_Reflection_Types.name, unit) FStar_Tactics_Effect.tac_repr) + unit -> (FStarC_Reflection_Types.name, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> - let uu___1 = FStar_Tactics_V1_Builtins.top_env () in + let uu___1 = FStarC_Tactics_V1_Builtins.top_env () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -796,14 +802,14 @@ let (cur_module : (Prims.of_int (25))))) (Obj.magic uu___1) (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___3 -> FStar_Reflection_V1_Builtins.moduleof uu___2)) + (fun uu___3 -> FStarC_Reflection_V1_Builtins.moduleof uu___2)) let (open_modules : unit -> - (FStar_Reflection_Types.name Prims.list, unit) + (FStarC_Reflection_Types.name Prims.list, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> - let uu___1 = FStar_Tactics_V1_Builtins.top_env () in + let uu___1 = FStarC_Tactics_V1_Builtins.top_env () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -818,10 +824,10 @@ let (open_modules : (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> - FStar_Reflection_V1_Builtins.env_open_modules uu___2)) + FStarC_Reflection_V1_Builtins.env_open_modules uu___2)) let (fresh_uvar : - FStar_Reflection_Types.typ FStar_Pervasives_Native.option -> - (FStar_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.typ FStar_Pervasives_Native.option -> + (FStarC_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) = fun o -> let uu___ = cur_env () in @@ -837,10 +843,11 @@ let (fresh_uvar : (Prims.of_int (276)) (Prims.of_int (4)) (Prims.of_int (276)) (Prims.of_int (16))))) (Obj.magic uu___) (fun uu___1 -> - (fun e -> Obj.magic (FStar_Tactics_V1_Builtins.uvar_env e o)) uu___1) + (fun e -> Obj.magic (FStarC_Tactics_V1_Builtins.uvar_env e o)) + uu___1) let (unify : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> (Prims.bool, unit) FStar_Tactics_Effect.tac_repr) = fun t1 -> @@ -858,11 +865,11 @@ let (unify : (Prims.of_int (280)) (Prims.of_int (4)) (Prims.of_int (280)) (Prims.of_int (21))))) (Obj.magic uu___) (fun uu___1 -> - (fun e -> Obj.magic (FStar_Tactics_V1_Builtins.unify_env e t1 t2)) + (fun e -> Obj.magic (FStarC_Tactics_V1_Builtins.unify_env e t1 t2)) uu___1) let (unify_guard : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> (Prims.bool, unit) FStar_Tactics_Effect.tac_repr) = fun t1 -> @@ -881,11 +888,11 @@ let (unify_guard : (Prims.of_int (27))))) (Obj.magic uu___) (fun uu___1 -> (fun e -> - Obj.magic (FStar_Tactics_V1_Builtins.unify_guard_env e t1 t2)) + Obj.magic (FStarC_Tactics_V1_Builtins.unify_guard_env e t1 t2)) uu___1) let (tmatch : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> (Prims.bool, unit) FStar_Tactics_Effect.tac_repr) = fun t1 -> @@ -903,7 +910,7 @@ let (tmatch : (Prims.of_int (288)) (Prims.of_int (4)) (Prims.of_int (288)) (Prims.of_int (21))))) (Obj.magic uu___) (fun uu___1 -> - (fun e -> Obj.magic (FStar_Tactics_V1_Builtins.match_env e t1 t2)) + (fun e -> Obj.magic (FStarC_Tactics_V1_Builtins.match_env e t1 t2)) uu___1) let divide : 'a 'b . @@ -1024,7 +1031,7 @@ let divide : match uu___5 with | (gs1, gs2) -> let uu___6 = - FStar_Tactics_V1_Builtins.set_goals + FStarC_Tactics_V1_Builtins.set_goals gs1 in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1048,7 +1055,7 @@ let divide : (fun uu___7 -> (fun uu___7 -> let uu___8 = - FStar_Tactics_V1_Builtins.set_smt_goals + FStarC_Tactics_V1_Builtins.set_smt_goals [] in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1198,7 +1205,7 @@ let divide : sgsl) -> let uu___13 = - FStar_Tactics_V1_Builtins.set_goals + FStarC_Tactics_V1_Builtins.set_goals gs2 in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1228,7 +1235,7 @@ let divide : -> let uu___15 = - FStar_Tactics_V1_Builtins.set_smt_goals + FStarC_Tactics_V1_Builtins.set_smt_goals [] in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1379,7 +1386,7 @@ let divide : sgsr) -> let uu___20 = - FStar_Tactics_V1_Builtins.set_goals + FStarC_Tactics_V1_Builtins.set_goals ((op_At ()) gsl gsr) in @@ -1411,7 +1418,7 @@ let divide : -> let uu___22 = - FStar_Tactics_V1_Builtins.set_smt_goals + FStarC_Tactics_V1_Builtins.set_smt_goals ((op_At ()) sgs ((op_At @@ -1526,7 +1533,7 @@ let focus : (fun uu___3 -> (fun sgs -> let uu___3 = - FStar_Tactics_V1_Builtins.set_goals [g] in + FStarC_Tactics_V1_Builtins.set_goals [g] in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1549,7 +1556,7 @@ let focus : (fun uu___4 -> (fun uu___4 -> let uu___5 = - FStar_Tactics_V1_Builtins.set_smt_goals + FStarC_Tactics_V1_Builtins.set_smt_goals [] in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1654,7 +1661,7 @@ let focus : uu___10 -> Obj.magic - (FStar_Tactics_V1_Builtins.set_goals + (FStarC_Tactics_V1_Builtins.set_goals uu___10)) uu___10) in Obj.magic @@ -1748,7 +1755,7 @@ let focus : uu___12 -> Obj.magic - (FStar_Tactics_V1_Builtins.set_smt_goals + (FStarC_Tactics_V1_Builtins.set_smt_goals uu___12)) uu___12) in Obj.magic @@ -1783,7 +1790,7 @@ let focus : uu___6))) uu___4))) uu___3)))) uu___1) let (dump1 : Prims.string -> (unit, unit) FStar_Tactics_Effect.tac_repr) = - fun m -> focus (fun uu___ -> FStar_Tactics_V1_Builtins.dump m) + fun m -> focus (fun uu___ -> FStarC_Tactics_V1_Builtins.dump m) let rec mapAll : 'a . (unit -> ('a, unit) FStar_Tactics_Effect.tac_repr) -> @@ -1932,7 +1939,7 @@ let (iterAllSMT : (fun uu___1 -> match uu___1 with | (gs, sgs) -> - let uu___2 = FStar_Tactics_V1_Builtins.set_goals sgs in + let uu___2 = FStarC_Tactics_V1_Builtins.set_goals sgs in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1951,7 +1958,7 @@ let (iterAllSMT : (fun uu___3 -> (fun uu___3 -> let uu___4 = - FStar_Tactics_V1_Builtins.set_smt_goals [] in + FStarC_Tactics_V1_Builtins.set_smt_goals [] in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -2072,7 +2079,7 @@ let (iterAllSMT : match uu___9 with | (gs', sgs') -> let uu___10 = - FStar_Tactics_V1_Builtins.set_goals + FStarC_Tactics_V1_Builtins.set_goals gs in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -2101,7 +2108,7 @@ let (iterAllSMT : uu___11 -> Obj.magic - (FStar_Tactics_V1_Builtins.set_smt_goals + (FStarC_Tactics_V1_Builtins.set_smt_goals ((op_At ()) gs' sgs'))) @@ -2132,8 +2139,9 @@ let (seq : (Obj.magic uu___1) (fun uu___2 -> (fun uu___2 -> Obj.magic (iterAll g)) uu___2)) let (exact_args : - FStar_Reflection_V1_Data.aqualv Prims.list -> - FStar_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_V1_Data.aqualv Prims.list -> + FStarC_Reflection_Types.term -> + (unit, unit) FStar_Tactics_Effect.tac_repr) = fun qs -> fun t -> @@ -2255,7 +2263,7 @@ let (exact_args : then Obj.magic (Obj.repr - (FStar_Tactics_V1_Builtins.unshelve + (FStarC_Tactics_V1_Builtins.unshelve uv)) else Obj.magic @@ -2270,7 +2278,8 @@ let (exact_args : uu___4))) uu___3))) uu___2)) let (exact_n : Prims.int -> - FStar_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> + (unit, unit) FStar_Tactics_Effect.tac_repr) = fun n -> fun t -> @@ -2280,7 +2289,7 @@ let (exact_n : (fun uu___1 -> Obj.magic (FStar_Tactics_Effect.lift_div_tac - (fun uu___2 -> FStar_Reflection_V1_Data.Q_Explicit))) + (fun uu___2 -> FStarC_Reflection_V1_Data.Q_Explicit))) uu___1) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -2329,9 +2338,9 @@ let (ngoals_smt : unit -> (Prims.int, unit) FStar_Tactics_Effect.tac_repr) = FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> FStar_List_Tot_Base.length uu___2)) let (fresh_bv : - unit -> (FStar_Reflection_Types.bv, unit) FStar_Tactics_Effect.tac_repr) = + unit -> (FStarC_Reflection_Types.bv, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> - let uu___1 = FStar_Tactics_V1_Builtins.fresh () in + let uu___1 = FStarC_Tactics_V1_Builtins.fresh () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2346,16 +2355,16 @@ let (fresh_bv : (fun uu___2 -> (fun i -> Obj.magic - (FStar_Tactics_V1_Builtins.fresh_bv_named + (FStarC_Tactics_V1_Builtins.fresh_bv_named (Prims.strcat "x" (Prims.string_of_int i)))) uu___2) let (fresh_binder_named : Prims.string -> - FStar_Reflection_Types.typ -> - (FStar_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.typ -> + (FStarC_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) = fun nm -> fun t -> - let uu___ = FStar_Tactics_V1_Builtins.fresh_bv_named nm in + let uu___ = FStarC_Tactics_V1_Builtins.fresh_bv_named nm in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2371,11 +2380,11 @@ let (fresh_binder_named : FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> FStar_Reflection_V1_Derived.mk_binder uu___1 t)) let (fresh_binder : - FStar_Reflection_Types.typ -> - (FStar_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.typ -> + (FStarC_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) = fun t -> - let uu___ = FStar_Tactics_V1_Builtins.fresh () in + let uu___ = FStarC_Tactics_V1_Builtins.fresh () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2394,12 +2403,12 @@ let (fresh_binder : t)) uu___1) let (fresh_implicit_binder_named : Prims.string -> - FStar_Reflection_Types.typ -> - (FStar_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.typ -> + (FStarC_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) = fun nm -> fun t -> - let uu___ = FStar_Tactics_V1_Builtins.fresh_bv_named nm in + let uu___ = FStarC_Tactics_V1_Builtins.fresh_bv_named nm in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2416,11 +2425,11 @@ let (fresh_implicit_binder_named : (fun uu___2 -> FStar_Reflection_V1_Derived.mk_implicit_binder uu___1 t)) let (fresh_implicit_binder : - FStar_Reflection_Types.typ -> - (FStar_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.typ -> + (FStarC_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) = fun t -> - let uu___ = FStar_Tactics_V1_Builtins.fresh () in + let uu___ = FStarC_Tactics_V1_Builtins.fresh () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2452,7 +2461,7 @@ let try_with : = fun f -> fun h -> - let uu___ = FStar_Tactics_V1_Builtins.catch f in + let uu___ = FStarC_Tactics_V1_Builtins.catch f in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2535,7 +2544,7 @@ let rec repeat : ('a Prims.list, unit) FStar_Tactics_Effect.tac_repr = fun t -> - let uu___ = FStar_Tactics_V1_Builtins.catch t in + let uu___ = FStarC_Tactics_V1_Builtins.catch t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2633,14 +2642,14 @@ let repeat' : (fun uu___1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> ())) let (norm_term : FStar_Pervasives.norm_step Prims.list -> - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) = fun s -> fun t -> let uu___ = try_with (fun uu___1 -> match () with | () -> cur_env ()) - (fun uu___1 -> FStar_Tactics_V1_Builtins.top_env ()) in + (fun uu___1 -> FStarC_Tactics_V1_Builtins.top_env ()) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2654,7 +2663,7 @@ let (norm_term : (Prims.of_int (23))))) (Obj.magic uu___) (fun uu___1 -> (fun e -> - Obj.magic (FStar_Tactics_V1_Builtins.norm_term_env e s t)) + Obj.magic (FStarC_Tactics_V1_Builtins.norm_term_env e s t)) uu___1) let (join_all_smt_goals : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = @@ -2707,7 +2716,7 @@ let (join_all_smt_goals : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) (fun uu___2 -> match uu___2 with | (gs, sgs) -> - let uu___3 = FStar_Tactics_V1_Builtins.set_smt_goals [] in + let uu___3 = FStarC_Tactics_V1_Builtins.set_smt_goals [] in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -2726,7 +2735,7 @@ let (join_all_smt_goals : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) (fun uu___4 -> (fun uu___4 -> let uu___5 = - FStar_Tactics_V1_Builtins.set_goals sgs in + FStarC_Tactics_V1_Builtins.set_goals sgs in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -2750,7 +2759,7 @@ let (join_all_smt_goals : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) (fun uu___6 -> let uu___7 = repeat' - FStar_Tactics_V1_Builtins.join in + FStarC_Tactics_V1_Builtins.join in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -2795,7 +2804,7 @@ let (join_all_smt_goals : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) (fun uu___10 -> (fun sgs' -> let uu___10 = - FStar_Tactics_V1_Builtins.set_goals + FStarC_Tactics_V1_Builtins.set_goals gs in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -2825,7 +2834,7 @@ let (join_all_smt_goals : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) uu___11 -> Obj.magic - (FStar_Tactics_V1_Builtins.set_smt_goals + (FStarC_Tactics_V1_Builtins.set_smt_goals sgs')) uu___11))) uu___10))) uu___8))) @@ -2874,9 +2883,9 @@ let rec repeatseq : (fun uu___1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> ())) let (tadmit : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> - FStar_Tactics_V1_Builtins.tadmit_t - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const FStar_Reflection_V2_Data.C_Unit)) + FStarC_Tactics_V1_Builtins.tadmit_t + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const FStarC_Reflection_V2_Data.C_Unit)) let (admit1 : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> tadmit () let (admit_all : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = @@ -2910,7 +2919,7 @@ let (is_guard : unit -> (Prims.bool, unit) FStar_Tactics_Effect.tac_repr) = (Prims.of_int (47))))) (Obj.magic uu___1) (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___3 -> FStar_Tactics_Types.is_guard uu___2)) + (fun uu___3 -> FStarC_Tactics_Types.is_guard uu___2)) let (skip_guard : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> let uu___1 = is_guard () in @@ -2947,27 +2956,27 @@ let (guards_to_smt : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> ())) let (simpl : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> - FStar_Tactics_V1_Builtins.norm + FStarC_Tactics_V1_Builtins.norm [FStar_Pervasives.simplify; FStar_Pervasives.primops] let (whnf : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> - FStar_Tactics_V1_Builtins.norm + FStarC_Tactics_V1_Builtins.norm [FStar_Pervasives.weak; FStar_Pervasives.hnf; FStar_Pervasives.primops; FStar_Pervasives.delta] let (compute : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> - FStar_Tactics_V1_Builtins.norm + FStarC_Tactics_V1_Builtins.norm [FStar_Pervasives.primops; FStar_Pervasives.iota; FStar_Pervasives.delta; FStar_Pervasives.zeta] let (intros : unit -> - (FStar_Reflection_Types.binder Prims.list, unit) + (FStarC_Reflection_Types.binder Prims.list, unit) FStar_Tactics_Effect.tac_repr) - = fun uu___ -> repeat FStar_Tactics_V1_Builtins.intro + = fun uu___ -> repeat FStarC_Tactics_V1_Builtins.intro let (intros' : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> let uu___1 = intros () in @@ -2984,10 +2993,10 @@ let (intros' : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (Prims.of_int (51))))) (Obj.magic uu___1) (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> ())) let (destruct : - FStar_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun tm -> - let uu___ = FStar_Tactics_V1_Builtins.t_destruct tm in + let uu___ = FStarC_Tactics_V1_Builtins.t_destruct tm in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -3001,12 +3010,12 @@ let (destruct : (Prims.of_int (56))))) (Obj.magic uu___) (fun uu___1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> ())) let (destruct_intros : - FStar_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun tm -> seq (fun uu___ -> - let uu___1 = FStar_Tactics_V1_Builtins.t_destruct tm in + let uu___1 = FStarC_Tactics_V1_Builtins.t_destruct tm in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -3023,8 +3032,8 @@ let (destruct_intros : FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> ()))) intros' let __cut : 'a 'b . ('a -> 'b) -> 'a -> 'b = fun f -> fun x -> f x let (tcut : - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) = fun t -> let uu___ = cur_goal () in @@ -3046,9 +3055,9 @@ let (tcut : (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> FStar_Reflection_V1_Derived.mk_e_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; @@ -3088,18 +3097,18 @@ let (tcut : (fun uu___3 -> (fun uu___3 -> Obj.magic - (FStar_Tactics_V1_Builtins.intro ())) + (FStarC_Tactics_V1_Builtins.intro ())) uu___3))) uu___2))) uu___1) let (pose : - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) = fun t -> let uu___ = apply - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; "Derived"; "__cut"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -3149,14 +3158,14 @@ let (pose : (fun uu___5 -> (fun uu___5 -> Obj.magic - (FStar_Tactics_V1_Builtins.intro ())) + (FStarC_Tactics_V1_Builtins.intro ())) uu___5))) uu___3))) uu___1) let (intro_as : Prims.string -> - (FStar_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) + (FStarC_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) = fun s -> - let uu___ = FStar_Tactics_V1_Builtins.intro () in + let uu___ = FStarC_Tactics_V1_Builtins.intro () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -3169,12 +3178,12 @@ let (intro_as : (Prims.of_int (520)) (Prims.of_int (4)) (Prims.of_int (520)) (Prims.of_int (17))))) (Obj.magic uu___) (fun uu___1 -> - (fun b -> Obj.magic (FStar_Tactics_V1_Builtins.rename_to b s)) + (fun b -> Obj.magic (FStarC_Tactics_V1_Builtins.rename_to b s)) uu___1) let (pose_as : Prims.string -> - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) = fun s -> fun t -> @@ -3191,11 +3200,11 @@ let (pose_as : (Prims.of_int (524)) (Prims.of_int (4)) (Prims.of_int (524)) (Prims.of_int (17))))) (Obj.magic uu___) (fun uu___1 -> - (fun b -> Obj.magic (FStar_Tactics_V1_Builtins.rename_to b s)) + (fun b -> Obj.magic (FStarC_Tactics_V1_Builtins.rename_to b s)) uu___1) let for_each_binder : 'a . - (FStar_Reflection_Types.binder -> + (FStarC_Reflection_Types.binder -> ('a, unit) FStar_Tactics_Effect.tac_repr) -> ('a Prims.list, unit) FStar_Tactics_Effect.tac_repr = @@ -3215,7 +3224,7 @@ let for_each_binder : (fun uu___1 -> (fun uu___1 -> Obj.magic (FStar_Tactics_Util.map f uu___1)) uu___1) let rec (revert_all : - FStar_Reflection_Types.binders -> + FStarC_Reflection_Types.binders -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> @@ -3227,7 +3236,7 @@ let rec (revert_all : | uu___::tl -> Obj.magic (Obj.repr - (let uu___1 = FStar_Tactics_V1_Builtins.revert () in + (let uu___1 = FStarC_Tactics_V1_Builtins.revert () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -3244,20 +3253,20 @@ let rec (revert_all : (fun uu___2 -> Obj.magic (revert_all tl)) uu___2)))) uu___ let (bv_to_term : - FStar_Reflection_Types.bv -> - (FStar_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.bv -> + (FStarC_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) = fun bv -> - FStar_Tactics_V1_Builtins.pack (FStar_Reflection_V1_Data.Tv_Var bv) + FStarC_Tactics_V1_Builtins.pack (FStarC_Reflection_V1_Data.Tv_Var bv) let (binder_to_term : - FStar_Reflection_Types.binder -> - (FStar_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.binder -> + (FStarC_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) = fun b -> let uu___ = Obj.magic (FStar_Tactics_Effect.lift_div_tac - (fun uu___1 -> FStar_Reflection_V1_Builtins.inspect_binder b)) in + (fun uu___1 -> FStarC_Reflection_V1_Builtins.inspect_binder b)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -3271,21 +3280,21 @@ let (binder_to_term : (Prims.of_int (28))))) (Obj.magic uu___) (fun uu___1 -> (fun bview -> - Obj.magic (bv_to_term bview.FStar_Reflection_V1_Data.binder_bv)) + Obj.magic (bv_to_term bview.FStarC_Reflection_V1_Data.binder_bv)) uu___1) let (binder_sort : - FStar_Reflection_Types.binder -> - (FStar_Reflection_Types.typ, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.binder -> + (FStarC_Reflection_Types.typ, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> (fun b -> Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___ -> - (FStar_Reflection_V1_Builtins.inspect_binder b).FStar_Reflection_V1_Data.binder_sort))) + (FStarC_Reflection_V1_Builtins.inspect_binder b).FStarC_Reflection_V1_Data.binder_sort))) uu___ let rec (__assumption_aux : - FStar_Reflection_Types.binders -> + FStarC_Reflection_Types.binders -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> @@ -3320,9 +3329,9 @@ let rec (__assumption_aux : | () -> let uu___3 = apply - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Squash"; "return_squash"]))) in @@ -3366,8 +3375,8 @@ let (assumption : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___2 -> (fun uu___2 -> Obj.magic (__assumption_aux uu___2)) uu___2) let (destruct_equality_implication : - FStar_Reflection_Types.term -> - ((FStar_Reflection_V1_Formula.formula * FStar_Reflection_Types.term) + FStarC_Reflection_Types.term -> + ((FStar_Reflection_V1_Formula.formula * FStarC_Reflection_Types.term) FStar_Pervasives_Native.option, unit) FStar_Tactics_Effect.tac_repr) = @@ -3423,13 +3432,15 @@ let (destruct_equality_implication : (fun uu___3 -> FStar_Pervasives_Native.None)))) uu___1) let (rewrite' : - FStar_Reflection_Types.binder -> (unit, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.binder -> + (unit, unit) FStar_Tactics_Effect.tac_repr) = fun b -> op_Less_Bar_Greater - (op_Less_Bar_Greater (fun uu___ -> FStar_Tactics_V1_Builtins.rewrite b) + (op_Less_Bar_Greater + (fun uu___ -> FStarC_Tactics_V1_Builtins.rewrite b) (fun uu___ -> - let uu___1 = FStar_Tactics_V1_Builtins.binder_retype b in + let uu___1 = FStarC_Tactics_V1_Builtins.binder_retype b in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -3446,9 +3457,9 @@ let (rewrite' : (fun uu___2 -> let uu___3 = apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; @@ -3472,13 +3483,13 @@ let (rewrite' : (fun uu___4 -> (fun uu___4 -> Obj.magic - (FStar_Tactics_V1_Builtins.rewrite b)) + (FStarC_Tactics_V1_Builtins.rewrite b)) uu___4))) uu___2))) (fun uu___ -> (fun uu___ -> Obj.magic (fail "rewrite' failed")) uu___) () let rec (try_rewrite_equality : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.binders -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.binders -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___1 -> @@ -3517,16 +3528,16 @@ let rec (try_rewrite_equality : (FStar_Reflection_V1_Formula.Eq uu___2, y, uu___3) -> - if FStar_Reflection_V1_Builtins.term_eq x y + if FStarC_Reflection_V1_Builtins.term_eq x y then Obj.magic - (FStar_Tactics_V1_Builtins.rewrite x_t) + (FStarC_Tactics_V1_Builtins.rewrite x_t) else Obj.magic (try_rewrite_equality x bs1) | uu___2 -> Obj.magic (try_rewrite_equality x bs1)) uu___1)))) uu___1 uu___ let rec (rewrite_all_context_equalities : - FStar_Reflection_Types.binders -> + FStarC_Reflection_Types.binders -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> @@ -3542,7 +3553,7 @@ let rec (rewrite_all_context_equalities : try_with (fun uu___1 -> match () with - | () -> FStar_Tactics_V1_Builtins.rewrite x_t) + | () -> FStarC_Tactics_V1_Builtins.rewrite x_t) (fun uu___1 -> (fun uu___1 -> Obj.magic @@ -3583,7 +3594,7 @@ let (rewrite_eqs_from_context : (fun uu___2 -> Obj.magic (rewrite_all_context_equalities uu___2)) uu___2) let (rewrite_equality : - FStar_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun t -> let uu___ = cur_binders () in @@ -3601,10 +3612,10 @@ let (rewrite_equality : (fun uu___1 -> (fun uu___1 -> Obj.magic (try_rewrite_equality t uu___1)) uu___1) let (unfold_def : - FStar_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun t -> - let uu___ = FStar_Tactics_V1_Builtins.inspect t in + let uu___ = FStarC_Tactics_V1_Builtins.inspect t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -3619,15 +3630,16 @@ let (unfold_def : (fun uu___1 -> (fun uu___1 -> match uu___1 with - | FStar_Reflection_V1_Data.Tv_FVar fv -> + | FStarC_Reflection_V1_Data.Tv_FVar fv -> Obj.magic (Obj.repr (let uu___2 = Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> - FStar_Reflection_V1_Builtins.implode_qn - (FStar_Reflection_V1_Builtins.inspect_fv fv))) in + FStarC_Reflection_V1_Builtins.implode_qn + (FStarC_Reflection_V1_Builtins.inspect_fv + fv))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -3645,14 +3657,14 @@ let (unfold_def : (fun uu___3 -> (fun n -> Obj.magic - (FStar_Tactics_V1_Builtins.norm + (FStarC_Tactics_V1_Builtins.norm [FStar_Pervasives.delta_fully [n]])) uu___3))) | uu___2 -> Obj.magic (Obj.repr (fail "unfold_def: term is not a fv"))) uu___1) let (l_to_r : - FStar_Reflection_Types.term Prims.list -> + FStarC_Reflection_Types.term Prims.list -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun lems -> @@ -3700,30 +3712,31 @@ let (l_to_r : (Prims.of_int (28))))) (Obj.magic uu___) (fun uu___1 -> (fun first_or_trefl -> Obj.magic (pointwise first_or_trefl)) uu___1) -let (mk_squash : FStar_Reflection_Types.term -> FStar_Reflection_Types.term) - = +let (mk_squash : + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term) = fun t -> let sq = - FStar_Reflection_V1_Builtins.pack_ln - (FStar_Reflection_V1_Data.Tv_FVar - (FStar_Reflection_V1_Builtins.pack_fv + FStarC_Reflection_V1_Builtins.pack_ln + (FStarC_Reflection_V1_Data.Tv_FVar + (FStarC_Reflection_V1_Builtins.pack_fv FStar_Reflection_Const.squash_qn)) in FStar_Reflection_V1_Derived.mk_e_app sq [t] let (mk_sq_eq : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> FStar_Reflection_Types.term) + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term) = fun t1 -> fun t2 -> let eq = - FStar_Reflection_V1_Builtins.pack_ln - (FStar_Reflection_V1_Data.Tv_FVar - (FStar_Reflection_V1_Builtins.pack_fv + FStarC_Reflection_V1_Builtins.pack_ln + (FStarC_Reflection_V1_Data.Tv_FVar + (FStarC_Reflection_V1_Builtins.pack_fv FStar_Reflection_Const.eq2_qn)) in mk_squash (FStar_Reflection_V1_Derived.mk_e_app eq [t1; t2]) let (grewrite : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> + (unit, unit) FStar_Tactics_Effect.tac_repr) = fun t1 -> fun t2 -> @@ -3746,8 +3759,8 @@ let (grewrite : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> - FStar_Reflection_V1_Builtins.pack_ln - (FStar_Reflection_V1_Data.Tv_Var + FStarC_Reflection_V1_Builtins.pack_ln + (FStarC_Reflection_V1_Data.Tv_Var (FStar_Reflection_V1_Derived.bv_of_binder e)))) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -3819,10 +3832,10 @@ let (grewrite : (FStar_Reflection_V1_Formula.Eq uu___7, lhs, rhs) -> - (match FStar_Reflection_V1_Builtins.inspect_ln + (match FStarC_Reflection_V1_Builtins.inspect_ln lhs with - | FStar_Reflection_V1_Data.Tv_Uvar + | FStarC_Reflection_V1_Data.Tv_Uvar (uu___8, uu___9) -> true | uu___8 -> false) @@ -3858,7 +3871,8 @@ let (grewrite : (fun uu___5 -> trefl ()))) uu___4)))) uu___2))) uu___1) let (grewrite_eq : - FStar_Reflection_Types.binder -> (unit, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.binder -> + (unit, unit) FStar_Tactics_Effect.tac_repr) = fun b -> let uu___ = @@ -3979,9 +3993,9 @@ let (grewrite_eq : (fun uu___8 -> let uu___9 = apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; @@ -4050,7 +4064,8 @@ let (grewrite_eq : uu___4))) uu___1) let rec (apply_squash_or_lem : Prims.nat -> - FStar_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> + (unit, unit) FStar_Tactics_Effect.tac_repr) = fun d -> fun t -> @@ -4062,9 +4077,9 @@ let rec (apply_squash_or_lem : | () -> let uu___2 = apply - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Squash"; "return_squash"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -4115,7 +4130,7 @@ let rec (apply_squash_or_lem : (fun uu___6 -> (fun uu___6 -> Obj.magic - (FStar_Tactics_V1_Builtins.tc + (FStarC_Tactics_V1_Builtins.tc uu___6 t)) uu___6) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -4163,10 +4178,10 @@ let rec (apply_squash_or_lem : (fun uu___6 -> match uu___6 with | (tys, c) -> - (match FStar_Reflection_V1_Builtins.inspect_comp + (match FStarC_Reflection_V1_Builtins.inspect_comp c with - | FStar_Reflection_V1_Data.C_Lemma + | FStarC_Reflection_V1_Data.C_Lemma (pre, post, uu___7) -> @@ -4178,13 +4193,13 @@ let rec (apply_squash_or_lem : (FStar_Tactics_Effect.lift_div_tac (fun uu___9 -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App (post, - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const - FStar_Reflection_V2_Data.C_Unit)), - FStar_Reflection_V2_Data.Q_Explicit))))) in + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const + FStarC_Reflection_V2_Data.C_Unit)), + FStarC_Reflection_V2_Data.Q_Explicit))))) in FStar_Tactics_Effect.tac_bind ( FStar_Sealed.seal @@ -4281,9 +4296,9 @@ let rec (apply_squash_or_lem : (let uu___12 = apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; @@ -4330,7 +4345,7 @@ let rec (apply_squash_or_lem : uu___11))) uu___10))) uu___9))) - | FStar_Reflection_V1_Data.C_Total + | FStarC_Reflection_V1_Data.C_Total rt -> Obj.magic (Obj.repr @@ -4405,9 +4420,9 @@ let rec (apply_squash_or_lem : (let uu___10 = apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; @@ -4518,9 +4533,9 @@ let rec (apply_squash_or_lem : let uu___10 = apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; @@ -4564,9 +4579,9 @@ let rec (apply_squash_or_lem : let uu___11 = apply - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Squash"; "return_squash"]))) in @@ -4608,11 +4623,11 @@ let rec (apply_squash_or_lem : "mapply: can't apply (2)")))) uu___6))) uu___5)))) uu___2))) let (mapply : - FStar_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun t -> apply_squash_or_lem (Prims.of_int (10)) t let (admit_dump_t : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> - let uu___1 = FStar_Tactics_V1_Builtins.dump "Admitting" in + let uu___1 = FStarC_Tactics_V1_Builtins.dump "Admitting" in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -4628,14 +4643,14 @@ let (admit_dump_t : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___2 -> Obj.magic (apply - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "admit"]))))) uu___2) let admit_dump : 'a . (unit -> 'a) -> unit -> 'a = fun x -> fun uu___ -> x () let (magic_dump_t : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> - let uu___1 = FStar_Tactics_V1_Builtins.dump "Admitting" in + let uu___1 = FStarC_Tactics_V1_Builtins.dump "Admitting" in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -4651,9 +4666,9 @@ let (magic_dump_t : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___2 -> let uu___3 = apply - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "magic"]))) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -4672,9 +4687,9 @@ let (magic_dump_t : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___4 -> let uu___5 = exact - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const - FStar_Reflection_V2_Data.C_Unit)) in + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const + FStarC_Reflection_V2_Data.C_Unit)) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -4695,8 +4710,9 @@ let (magic_dump_t : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___7 -> ())))) uu___4))) uu___2) let magic_dump : 'a . 'a -> unit -> 'a = fun x -> fun uu___ -> x let (change_with : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> + (unit, unit) FStar_Tactics_Effect.tac_repr) = fun t1 -> fun t2 -> @@ -4718,14 +4734,14 @@ let (change_with : (fun uu___2 -> (fun uu___2 -> Obj.magic (iseq [idtac; trivial])) uu___2)) let (change_sq : - FStar_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun t1 -> - FStar_Tactics_V1_Builtins.change + FStarC_Tactics_V1_Builtins.change (FStar_Reflection_V1_Derived.mk_e_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv ["Prims"; "squash"]))) + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "squash"]))) [t1]) let finish_by : 'a . @@ -4776,7 +4792,7 @@ let solve_then : = fun t1 -> fun t2 -> - let uu___ = FStar_Tactics_V1_Builtins.dup () in + let uu___ = FStarC_Tactics_V1_Builtins.dup () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -4862,9 +4878,9 @@ let add_elem : (fun uu___ -> let uu___1 = apply - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv ["Prims"; "Cons"]))) in + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "Cons"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -4957,7 +4973,7 @@ let specialize : (Obj.magic uu___2) (fun uu___3 -> (fun uu___3 -> Obj.magic (exact uu___3)) uu___3)) (fun uu___1 -> - FStar_Tactics_V1_Builtins.norm + FStarC_Tactics_V1_Builtins.norm [FStar_Pervasives.delta_only l; FStar_Pervasives.iota; FStar_Pervasives.zeta]) @@ -4982,8 +4998,8 @@ let (tlabel : Prims.string -> (unit, unit) FStar_Tactics_Effect.tac_repr) = | h::t -> Obj.magic (Obj.repr - (FStar_Tactics_V1_Builtins.set_goals - ((FStar_Tactics_Types.set_label l h) :: t)))) uu___1) + (FStarC_Tactics_V1_Builtins.set_goals + ((FStarC_Tactics_Types.set_label l h) :: t)))) uu___1) let (tlabel' : Prims.string -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun l -> let uu___ = goals () in @@ -5009,9 +5025,9 @@ let (tlabel' : Prims.string -> (unit, unit) FStar_Tactics_Effect.tac_repr) = Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> - FStar_Tactics_Types.set_label + FStarC_Tactics_Types.set_label (Prims.strcat l - (FStar_Tactics_Types.get_label h)) h)) in + (FStarC_Tactics_Types.get_label h)) h)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -5029,7 +5045,7 @@ let (tlabel' : Prims.string -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___3 -> (fun h1 -> Obj.magic - (FStar_Tactics_V1_Builtins.set_goals (h1 :: + (FStarC_Tactics_V1_Builtins.set_goals (h1 :: t))) uu___3)))) uu___1) let (focus_all : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> @@ -5082,7 +5098,7 @@ let (focus_all : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (Prims.of_int (39))))) (Obj.magic uu___2) (fun uu___3 -> (fun uu___3 -> - Obj.magic (FStar_Tactics_V1_Builtins.set_goals uu___3)) uu___3) in + Obj.magic (FStarC_Tactics_V1_Builtins.set_goals uu___3)) uu___3) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -5096,7 +5112,7 @@ let (focus_all : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (Prims.of_int (20))))) (Obj.magic uu___1) (fun uu___2 -> (fun uu___2 -> - Obj.magic (FStar_Tactics_V1_Builtins.set_smt_goals [])) uu___2) + Obj.magic (FStarC_Tactics_V1_Builtins.set_smt_goals [])) uu___2) let rec extract_nth : 'a . Prims.nat -> @@ -5149,11 +5165,11 @@ let (bump_nth : Prims.pos -> (unit, unit) FStar_Tactics_Effect.tac_repr) = Obj.magic (Obj.repr (fail "bump_nth: not that many goals")) | FStar_Pervasives_Native.Some (h, t) -> Obj.magic - (Obj.repr (FStar_Tactics_V1_Builtins.set_goals (h :: t)))) + (Obj.repr (FStarC_Tactics_V1_Builtins.set_goals (h :: t)))) uu___1) let rec (destruct_list : - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.term Prims.list, unit) + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.term Prims.list, unit) FStar_Tactics_Effect.tac_repr) = fun t -> @@ -5173,16 +5189,17 @@ let rec (destruct_list : (fun uu___1 -> match uu___1 with | (head, args) -> - (match ((FStar_Reflection_V1_Builtins.inspect_ln head), args) + (match ((FStarC_Reflection_V1_Builtins.inspect_ln head), + args) with - | (FStar_Reflection_V1_Data.Tv_FVar fv, - (a1, FStar_Reflection_V1_Data.Q_Explicit)::(a2, - FStar_Reflection_V1_Data.Q_Explicit)::[]) + | (FStarC_Reflection_V1_Data.Tv_FVar fv, + (a1, FStarC_Reflection_V1_Data.Q_Explicit)::(a2, + FStarC_Reflection_V1_Data.Q_Explicit)::[]) -> Obj.magic (Obj.repr (if - (FStar_Reflection_V1_Builtins.inspect_fv fv) = + (FStarC_Reflection_V1_Builtins.inspect_fv fv) = FStar_Reflection_Const.cons_qn then Obj.repr @@ -5211,15 +5228,15 @@ let rec (destruct_list : else Obj.repr (FStar_Tactics_Effect.raise - FStar_Tactics_Common.NotAListLiteral))) - | (FStar_Reflection_V1_Data.Tv_FVar fv, - (uu___2, FStar_Reflection_V1_Data.Q_Implicit)::(a1, - FStar_Reflection_V1_Data.Q_Explicit):: - (a2, FStar_Reflection_V1_Data.Q_Explicit)::[]) -> + FStarC_Tactics_Common.NotAListLiteral))) + | (FStarC_Reflection_V1_Data.Tv_FVar fv, + (uu___2, FStarC_Reflection_V1_Data.Q_Implicit)::(a1, + FStarC_Reflection_V1_Data.Q_Explicit):: + (a2, FStarC_Reflection_V1_Data.Q_Explicit)::[]) -> Obj.magic (Obj.repr (if - (FStar_Reflection_V1_Builtins.inspect_fv fv) = + (FStarC_Reflection_V1_Builtins.inspect_fv fv) = FStar_Reflection_Const.cons_qn then Obj.repr @@ -5248,26 +5265,26 @@ let rec (destruct_list : else Obj.repr (FStar_Tactics_Effect.raise - FStar_Tactics_Common.NotAListLiteral))) - | (FStar_Reflection_V1_Data.Tv_FVar fv, uu___2) -> + FStarC_Tactics_Common.NotAListLiteral))) + | (FStarC_Reflection_V1_Data.Tv_FVar fv, uu___2) -> Obj.magic (Obj.repr (if - (FStar_Reflection_V1_Builtins.inspect_fv fv) = + (FStarC_Reflection_V1_Builtins.inspect_fv fv) = FStar_Reflection_Const.nil_qn then FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> []) else FStar_Tactics_Effect.raise - FStar_Tactics_Common.NotAListLiteral)) + FStarC_Tactics_Common.NotAListLiteral)) | uu___2 -> Obj.magic (Obj.repr (FStar_Tactics_Effect.raise - FStar_Tactics_Common.NotAListLiteral)))) uu___1) + FStarC_Tactics_Common.NotAListLiteral)))) uu___1) let (get_match_body : - unit -> (FStar_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) + unit -> (FStarC_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> let uu___1 = @@ -5322,7 +5339,7 @@ let (get_match_body : (Obj.magic uu___3) (fun uu___4 -> match uu___4 with - | FStar_Reflection_V1_Data.Tv_Match + | FStarC_Reflection_V1_Data.Tv_Match (sc, uu___5, uu___6) -> FStar_Tactics_Effect.lift_div_tac (fun uu___7 -> sc) @@ -5356,7 +5373,7 @@ let (branch_on_match : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (Obj.magic uu___2) (fun uu___3 -> (fun x -> - let uu___3 = FStar_Tactics_V1_Builtins.t_destruct x in + let uu___3 = FStarC_Tactics_V1_Builtins.t_destruct x in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -5378,7 +5395,7 @@ let (branch_on_match : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (iterAll (fun uu___5 -> let uu___6 = - repeat FStar_Tactics_V1_Builtins.intro in + repeat FStarC_Tactics_V1_Builtins.intro in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -5446,14 +5463,14 @@ let (branch_on_match : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___9 -> Obj.magic ( - FStar_Tactics_V1_Builtins.norm + FStarC_Tactics_V1_Builtins.norm [FStar_Pervasives.iota])) uu___9))) uu___8))) uu___7)))) uu___4))) uu___3)) let (nth_binder : Prims.int -> - (FStar_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) + (FStarC_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) = fun i -> let uu___ = cur_binders () in @@ -5522,9 +5539,9 @@ let (nth_binder : FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> b)))) uu___2))) uu___1) let rec (mk_abs : - FStar_Reflection_Types.binder Prims.list -> - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.binder Prims.list -> + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) = fun uu___1 -> fun uu___ -> @@ -5556,14 +5573,14 @@ let rec (mk_abs : (fun uu___1 -> (fun t' -> Obj.magic - (FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Abs (a, t')))) + (FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Abs (a, t')))) uu___1)))) uu___1 uu___ let (string_to_term_with_lb : - (Prims.string * FStar_Reflection_Types.term) Prims.list -> - FStar_Reflection_Types.env -> + (Prims.string * FStarC_Reflection_Types.term) Prims.list -> + FStarC_Reflection_Types.env -> Prims.string -> - (FStar_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) + (FStarC_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) = fun letbindings -> fun e -> @@ -5572,8 +5589,8 @@ let (string_to_term_with_lb : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___1 -> - FStar_Reflection_V2_Builtins.pack_ln - FStar_Reflection_V2_Data.Tv_Unknown)) in + FStarC_Reflection_V2_Builtins.pack_ln + FStarC_Reflection_V2_Data.Tv_Unknown)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -5595,7 +5612,7 @@ let (string_to_term_with_lb : match (uu___2, uu___3) with | ((e1, lb_bvs), (i, v)) -> let uu___4 = - FStar_Tactics_V1_Builtins.push_bv_dsenv e1 i in + FStarC_Tactics_V1_Builtins.push_bv_dsenv e1 i in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -5641,7 +5658,7 @@ let (string_to_term_with_lb : match uu___2 with | (e1, lb_bvs) -> let uu___3 = - FStar_Tactics_V1_Builtins.string_to_term e1 + FStarC_Tactics_V1_Builtins.string_to_term e1 t in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -5670,8 +5687,8 @@ let (string_to_term_with_lb : fun uu___4 -> match uu___4 with | (i, bv) -> - FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Let + FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Let (false, [], bv, unk, i, t2))) t1 lb_bvs)) uu___4))) uu___2))) @@ -5679,7 +5696,7 @@ let (string_to_term_with_lb : let (trans : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; "Derived"; "lem_trans"]))) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_V1_Logic.ml b/ocaml/fstar-lib/generated/FStar_Tactics_V1_Logic.ml index 38d01aeaa26..7a710ca08a4 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_V1_Logic.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_V1_Logic.ml @@ -1,6 +1,7 @@ open Prims let (cur_goal : - unit -> (FStar_Reflection_Types.typ, unit) FStar_Tactics_Effect.tac_repr) = + unit -> (FStarC_Reflection_Types.typ, unit) FStar_Tactics_Effect.tac_repr) + = fun uu___ -> let uu___1 = let uu___2 = Obj.magic (FStar_Tactics_Effect.get ()) in @@ -17,7 +18,7 @@ let (cur_goal : (Prims.of_int (25))))) (Obj.magic uu___2) (fun uu___3 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___4 -> FStar_Tactics_Types.goals_of uu___3)) in + (fun uu___4 -> FStarC_Tactics_Types.goals_of uu___3)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -33,11 +34,11 @@ let (cur_goal : match uu___2 with | g::uu___3 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___4 -> FStar_Tactics_Types.goal_type g) + (fun uu___4 -> FStarC_Tactics_Types.goal_type g) | uu___3 -> FStar_Tactics_Effect.raise - (FStar_Tactics_Common.TacticFailure - ([FStar_Pprint.arbitrary_string "no more goals"], + (FStarC_Tactics_Common.TacticFailure + ([FStarC_Pprint.arbitrary_string "no more goals"], FStar_Pervasives_Native.None))) let (cur_formula : unit -> @@ -62,7 +63,7 @@ let (cur_formula : uu___2) let (l_revert : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> - let uu___1 = FStar_Tactics_V1_Builtins.revert () in + let uu___1 = FStarC_Tactics_V1_Builtins.revert () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -78,28 +79,28 @@ let (l_revert : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___2 -> Obj.magic (FStar_Tactics_V1_Derived.apply - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; "Logic"; "revert_squash"]))))) uu___2) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.l_revert" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.l_revert" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V1.Logic.l_revert (plugin)" - (FStar_Tactics_Native.from_tactic_1 l_revert) - FStar_Syntax_Embeddings.e_unit FStar_Syntax_Embeddings.e_unit - psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 l_revert) + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let rec (l_revert_all : - FStar_Reflection_Types.binders -> + FStarC_Reflection_Types.binders -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> @@ -128,27 +129,28 @@ let rec (l_revert_all : (fun uu___2 -> Obj.magic (l_revert_all tl)) uu___2)))) uu___ let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.l_revert_all" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.l_revert_all" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V1.Logic.l_revert_all (plugin)" - (FStar_Tactics_Native.from_tactic_1 l_revert_all) - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_binder) - FStar_Syntax_Embeddings.e_unit psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 l_revert_all) + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_binder) + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (forall_intro : - unit -> (FStar_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) + unit -> + (FStarC_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> let uu___1 = FStar_Tactics_V1_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; @@ -167,30 +169,30 @@ let (forall_intro : (Prims.of_int (46)) (Prims.of_int (4)) (Prims.of_int (46)) (Prims.of_int (12))))) (Obj.magic uu___1) (fun uu___2 -> - (fun uu___2 -> Obj.magic (FStar_Tactics_V1_Builtins.intro ())) + (fun uu___2 -> Obj.magic (FStarC_Tactics_V1_Builtins.intro ())) uu___2) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.forall_intro" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.forall_intro" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V1.Logic.forall_intro (plugin)" - (FStar_Tactics_Native.from_tactic_1 forall_intro) - FStar_Syntax_Embeddings.e_unit - FStar_Reflection_V2_Embeddings.e_binder psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 forall_intro) + FStarC_Syntax_Embeddings.e_unit + FStarC_Reflection_V2_Embeddings.e_binder psc ncb us args) let (forall_intro_as : Prims.string -> - (FStar_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) + (FStarC_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) = fun s -> let uu___ = FStar_Tactics_V1_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; @@ -212,34 +214,34 @@ let (forall_intro_as : (fun uu___1 -> Obj.magic (FStar_Tactics_V1_Derived.intro_as s)) uu___1) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.forall_intro_as" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V1.Logic.forall_intro_as (plugin)" - (FStar_Tactics_Native.from_tactic_1 forall_intro_as) - FStar_Syntax_Embeddings.e_string - FStar_Reflection_V2_Embeddings.e_binder psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 forall_intro_as) + FStarC_Syntax_Embeddings.e_string + FStarC_Reflection_V2_Embeddings.e_binder psc ncb us args) let (forall_intros : unit -> - (FStar_Reflection_Types.binders, unit) FStar_Tactics_Effect.tac_repr) + (FStarC_Reflection_Types.binders, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> FStar_Tactics_V1_Derived.repeat1 forall_intro let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.forall_intros" - (Prims.of_int (2)) + FStarC_Tactics_Native.register_tactic + "FStar.Tactics.V1.Logic.forall_intros" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V1.Logic.forall_intros (plugin)" - (FStar_Tactics_Native.from_tactic_1 forall_intros) - FStar_Syntax_Embeddings.e_unit - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_binder) psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 forall_intros) + FStarC_Syntax_Embeddings.e_unit + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_binder) psc ncb us args) let (split : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> FStar_Tactics_V1_Derived.try_with @@ -247,9 +249,9 @@ let (split : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = match () with | () -> FStar_Tactics_V1_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; @@ -261,26 +263,27 @@ let (split : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = Obj.magic (FStar_Tactics_V1_Derived.fail "Could not split goal")) uu___1) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.split" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.split" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V1.Logic.split (plugin)" - (FStar_Tactics_Native.from_tactic_1 split) - FStar_Syntax_Embeddings.e_unit FStar_Syntax_Embeddings.e_unit - psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 split) + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (implies_intro : - unit -> (FStar_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) + unit -> + (FStarC_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> let uu___1 = FStar_Tactics_V1_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; @@ -299,30 +302,30 @@ let (implies_intro : (Prims.of_int (64)) (Prims.of_int (4)) (Prims.of_int (64)) (Prims.of_int (12))))) (Obj.magic uu___1) (fun uu___2 -> - (fun uu___2 -> Obj.magic (FStar_Tactics_V1_Builtins.intro ())) + (fun uu___2 -> Obj.magic (FStarC_Tactics_V1_Builtins.intro ())) uu___2) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.implies_intro" - (Prims.of_int (2)) + FStarC_Tactics_Native.register_tactic + "FStar.Tactics.V1.Logic.implies_intro" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V1.Logic.implies_intro (plugin)" - (FStar_Tactics_Native.from_tactic_1 implies_intro) - FStar_Syntax_Embeddings.e_unit - FStar_Reflection_V2_Embeddings.e_binder psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 implies_intro) + FStarC_Syntax_Embeddings.e_unit + FStarC_Reflection_V2_Embeddings.e_binder psc ncb us args) let (implies_intro_as : Prims.string -> - (FStar_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) + (FStarC_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) = fun s -> let uu___ = FStar_Tactics_V1_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; @@ -344,88 +347,89 @@ let (implies_intro_as : (fun uu___1 -> Obj.magic (FStar_Tactics_V1_Derived.intro_as s)) uu___1) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.implies_intro_as" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V1.Logic.implies_intro_as (plugin)" - (FStar_Tactics_Native.from_tactic_1 implies_intro_as) - FStar_Syntax_Embeddings.e_string - FStar_Reflection_V2_Embeddings.e_binder psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 implies_intro_as) + FStarC_Syntax_Embeddings.e_string + FStarC_Reflection_V2_Embeddings.e_binder psc ncb us args) let (implies_intros : unit -> - (FStar_Reflection_Types.binders, unit) FStar_Tactics_Effect.tac_repr) + (FStarC_Reflection_Types.binders, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> FStar_Tactics_V1_Derived.repeat1 implies_intro let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.implies_intros" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V1.Logic.implies_intros (plugin)" - (FStar_Tactics_Native.from_tactic_1 implies_intros) - FStar_Syntax_Embeddings.e_unit - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_binder) psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 implies_intros) + FStarC_Syntax_Embeddings.e_unit + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_binder) psc ncb us args) let (l_intro : - unit -> (FStar_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) + unit -> + (FStarC_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> FStar_Tactics_V1_Derived.or_else forall_intro implies_intro let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.l_intro" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.l_intro" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V1.Logic.l_intro (plugin)" - (FStar_Tactics_Native.from_tactic_1 l_intro) - FStar_Syntax_Embeddings.e_unit - FStar_Reflection_V2_Embeddings.e_binder psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 l_intro) + FStarC_Syntax_Embeddings.e_unit + FStarC_Reflection_V2_Embeddings.e_binder psc ncb us args) let (l_intros : unit -> - (FStar_Reflection_Types.binder Prims.list, unit) + (FStarC_Reflection_Types.binder Prims.list, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> FStar_Tactics_V1_Derived.repeat l_intro let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.l_intros" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.l_intros" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V1.Logic.l_intros (plugin)" - (FStar_Tactics_Native.from_tactic_1 l_intros) - FStar_Syntax_Embeddings.e_unit - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_binder) psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 l_intros) + FStarC_Syntax_Embeddings.e_unit + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_binder) psc ncb us args) let (squash_intro : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> FStar_Tactics_V1_Derived.apply - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Squash"; "return_squash"]))) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.squash_intro" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.squash_intro" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V1.Logic.squash_intro (plugin)" - (FStar_Tactics_Native.from_tactic_1 squash_intro) - FStar_Syntax_Embeddings.e_unit FStar_Syntax_Embeddings.e_unit - psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 squash_intro) + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (l_exact : - FStar_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun t -> FStar_Tactics_V1_Derived.try_with @@ -448,19 +452,20 @@ let (l_exact : (fun uu___2 -> Obj.magic (FStar_Tactics_V1_Derived.exact t)) uu___2)) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.l_exact" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.l_exact" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V1.Logic.l_exact (plugin)" - (FStar_Tactics_Native.from_tactic_1 l_exact) - FStar_Reflection_V2_Embeddings.e_term - FStar_Syntax_Embeddings.e_unit psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 l_exact) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (hyp : - FStar_Reflection_Types.binder -> (unit, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.binder -> + (unit, unit) FStar_Tactics_Effect.tac_repr) = fun b -> let uu___ = FStar_Tactics_V1_Derived.binder_to_term b in @@ -477,20 +482,20 @@ let (hyp : (Prims.of_int (58))))) (Obj.magic uu___) (fun uu___1 -> (fun uu___1 -> Obj.magic (l_exact uu___1)) uu___1) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.hyp" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.hyp" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V1.Logic.hyp (plugin)" - (FStar_Tactics_Native.from_tactic_1 hyp) - FStar_Reflection_V2_Embeddings.e_binder - FStar_Syntax_Embeddings.e_unit psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 hyp) + FStarC_Reflection_V2_Embeddings.e_binder + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (pose_lemma : - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) = fun t -> let uu___ = @@ -507,7 +512,7 @@ let (pose_lemma : (Prims.of_int (89)) (Prims.of_int (10)) (Prims.of_int (89)) (Prims.of_int (28))))) (Obj.magic uu___1) (fun uu___2 -> - (fun uu___2 -> Obj.magic (FStar_Tactics_V1_Builtins.tcc uu___2 t)) + (fun uu___2 -> Obj.magic (FStarC_Tactics_V1_Builtins.tcc uu___2 t)) uu___2) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -523,8 +528,8 @@ let (pose_lemma : (fun uu___1 -> (fun c -> let uu___1 = - match FStar_Reflection_V1_Builtins.inspect_comp c with - | FStar_Reflection_V1_Data.C_Lemma (pre, post, uu___2) -> + match FStarC_Reflection_V1_Builtins.inspect_comp c with + | FStarC_Reflection_V1_Data.C_Lemma (pre, post, uu___2) -> Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> (pre, post))) @@ -550,13 +555,13 @@ let (pose_lemma : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App (post, - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const - FStar_Reflection_V2_Data.C_Unit)), - FStar_Reflection_V2_Data.Q_Explicit))))) in + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const + FStarC_Reflection_V2_Data.C_Unit)), + FStarC_Reflection_V2_Data.Q_Explicit))))) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -631,17 +636,17 @@ let (pose_lemma : -> Obj.magic (FStar_Tactics_V1_Derived.pose - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; @@ -649,48 +654,48 @@ let (pose_lemma : "Lemmas"; "__lemma_to_squash"]))), (pre, - FStar_Reflection_V2_Data.Q_Implicit)))), + FStarC_Reflection_V2_Data.Q_Implicit)))), (post2, - FStar_Reflection_V2_Data.Q_Implicit)))), - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const - FStar_Reflection_V2_Data.C_Unit)), - FStar_Reflection_V2_Data.Q_Explicit)))), - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Abs - ((FStar_Reflection_V2_Builtins.pack_binder + FStarC_Reflection_V2_Data.Q_Implicit)))), + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const + FStarC_Reflection_V2_Data.C_Unit)), + FStarC_Reflection_V2_Data.Q_Explicit)))), + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Abs + ((FStarC_Reflection_V2_Builtins.pack_binder { - FStar_Reflection_V2_Data.sort2 + FStarC_Reflection_V2_Data.sort2 = - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "unit"]))); - FStar_Reflection_V2_Data.qual + FStarC_Reflection_V2_Data.qual = - FStar_Reflection_V2_Data.Q_Explicit; - FStar_Reflection_V2_Data.attrs + FStarC_Reflection_V2_Data.Q_Explicit; + FStarC_Reflection_V2_Data.attrs = []; - FStar_Reflection_V2_Data.ppname2 + FStarC_Reflection_V2_Data.ppname2 = (FStar_Sealed.seal "uu___") }), t))), - FStar_Reflection_V2_Data.Q_Explicit))))) + FStarC_Reflection_V2_Data.Q_Explicit))))) | uu___7 -> let uu___8 = FStar_Tactics_V1_Derived.tcut ( - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "squash"]))), (pre, - FStar_Reflection_V2_Data.Q_Explicit)))) in + FStarC_Reflection_V2_Data.Q_Explicit)))) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -782,17 +787,17 @@ let (pose_lemma : (fun uu___15 -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; @@ -800,34 +805,34 @@ let (pose_lemma : "Lemmas"; "__lemma_to_squash"]))), (pre, - FStar_Reflection_V2_Data.Q_Implicit)))), + FStarC_Reflection_V2_Data.Q_Implicit)))), (post2, - FStar_Reflection_V2_Data.Q_Implicit)))), + FStarC_Reflection_V2_Data.Q_Implicit)))), (uu___14, - FStar_Reflection_V2_Data.Q_Explicit)))), - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Abs - ((FStar_Reflection_V2_Builtins.pack_binder + FStarC_Reflection_V2_Data.Q_Explicit)))), + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Abs + ((FStarC_Reflection_V2_Builtins.pack_binder { - FStar_Reflection_V2_Data.sort2 + FStarC_Reflection_V2_Data.sort2 = - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "unit"]))); - FStar_Reflection_V2_Data.qual + FStarC_Reflection_V2_Data.qual = - FStar_Reflection_V2_Data.Q_Explicit; - FStar_Reflection_V2_Data.attrs + FStarC_Reflection_V2_Data.Q_Explicit; + FStarC_Reflection_V2_Data.attrs = []; - FStar_Reflection_V2_Data.ppname2 + FStarC_Reflection_V2_Data.ppname2 = (FStar_Sealed.seal "uu___") }), uu___12))), - FStar_Reflection_V2_Data.Q_Explicit))))))) + FStarC_Reflection_V2_Data.Q_Explicit))))))) uu___12) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -977,17 +982,17 @@ let (pose_lemma : uu___6))) uu___5))) uu___4))) uu___2))) uu___1) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.pose_lemma" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.pose_lemma" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V1.Logic.pose_lemma (plugin)" - (FStar_Tactics_Native.from_tactic_1 pose_lemma) - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_binder psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 pose_lemma) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_binder psc ncb us args) let (explode : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> let uu___1 = @@ -1039,17 +1044,17 @@ let (explode : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (Prims.of_int (64))))) (Obj.magic uu___1) (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> ())) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.explode" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.explode" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V1.Logic.explode (plugin)" - (FStar_Tactics_Native.from_tactic_1 explode) - FStar_Syntax_Embeddings.e_unit FStar_Syntax_Embeddings.e_unit - psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 explode) + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let rec (visit : (unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) -> (unit, unit) FStar_Tactics_Effect.tac_repr) @@ -1253,7 +1258,7 @@ let rec (simplify_eq_implication : (fun uu___6 -> (fun eq_h -> let uu___6 = - FStar_Tactics_V1_Builtins.rewrite + FStarC_Tactics_V1_Builtins.rewrite eq_h in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1277,7 +1282,7 @@ let rec (simplify_eq_implication : (fun uu___7 -> (fun uu___7 -> let uu___8 = - FStar_Tactics_V1_Builtins.clear_top + FStarC_Tactics_V1_Builtins.clear_top () in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1315,34 +1320,34 @@ let rec (simplify_eq_implication : uu___6)))) uu___4))) uu___3))) uu___2) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.simplify_eq_implication" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V1.Logic.simplify_eq_implication (plugin)" - (FStar_Tactics_Native.from_tactic_1 simplify_eq_implication) - FStar_Syntax_Embeddings.e_unit FStar_Syntax_Embeddings.e_unit - psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 simplify_eq_implication) + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (rewrite_all_equalities : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> visit simplify_eq_implication let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.rewrite_all_equalities" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V1.Logic.rewrite_all_equalities (plugin)" - (FStar_Tactics_Native.from_tactic_1 rewrite_all_equalities) - FStar_Syntax_Embeddings.e_unit FStar_Syntax_Embeddings.e_unit - psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 rewrite_all_equalities) + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let rec (unfold_definition_and_simplify_eq : - FStar_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun tm -> let uu___ = FStar_Tactics_V1_Derived.cur_goal () in @@ -1380,7 +1385,8 @@ let rec (unfold_definition_and_simplify_eq : Obj.magic (Obj.repr (if - FStar_Reflection_V1_Builtins.term_eq hd tm + FStarC_Reflection_V1_Builtins.term_eq hd + tm then Obj.repr (FStar_Tactics_V1_Derived.trivial ()) @@ -1447,7 +1453,7 @@ let rec (unfold_definition_and_simplify_eq : (fun uu___7 -> (fun eq_h -> let uu___7 = - FStar_Tactics_V1_Builtins.rewrite + FStarC_Tactics_V1_Builtins.rewrite eq_h in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1475,7 +1481,7 @@ let rec (unfold_definition_and_simplify_eq : uu___8 -> let uu___9 = - FStar_Tactics_V1_Builtins.clear_top + FStarC_Tactics_V1_Builtins.clear_top () in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1515,31 +1521,31 @@ let rec (unfold_definition_and_simplify_eq : uu___7)))) uu___5)))) uu___2))) uu___1) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.unfold_definition_and_simplify_eq" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V1.Logic.unfold_definition_and_simplify_eq (plugin)" - (FStar_Tactics_Native.from_tactic_1 + (FStarC_Tactics_Native.from_tactic_1 unfold_definition_and_simplify_eq) - FStar_Reflection_V2_Embeddings.e_term - FStar_Syntax_Embeddings.e_unit psc ncb us args) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (unsquash : - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) = fun t -> let uu___ = Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___1 -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; "Logic"; "Lemmas"; "vbind"])))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1572,7 +1578,7 @@ let (unsquash : (Obj.magic uu___1) (fun uu___2 -> (fun uu___2 -> - let uu___3 = FStar_Tactics_V1_Builtins.intro () in + let uu___3 = FStarC_Tactics_V1_Builtins.intro () in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1591,56 +1597,56 @@ let (unsquash : (fun b -> FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> - FStar_Reflection_V1_Builtins.pack_ln - (FStar_Reflection_V1_Data.Tv_Var + FStarC_Reflection_V1_Builtins.pack_ln + (FStarC_Reflection_V1_Data.Tv_Var (FStar_Reflection_V1_Derived.bv_of_binder b)))))) uu___2))) uu___1) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.unsquash" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.unsquash" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V1.Logic.unsquash (plugin)" - (FStar_Tactics_Native.from_tactic_1 unsquash) - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_term psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 unsquash) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_term psc ncb us args) let (cases_or : - FStar_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun o -> FStar_Tactics_V1_Derived.apply_lemma (FStar_Reflection_V1_Derived.mk_e_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; "Logic"; "Lemmas"; "or_ind"]))) [o]) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.cases_or" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.cases_or" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V1.Logic.cases_or (plugin)" - (FStar_Tactics_Native.from_tactic_1 cases_or) - FStar_Reflection_V2_Embeddings.e_term - FStar_Syntax_Embeddings.e_unit psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 cases_or) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (cases_bool : - FStar_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun b -> let uu___ = Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___1 -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; @@ -1691,7 +1697,7 @@ let (cases_bool : (fun uu___5 -> (fun b1 -> let uu___5 = - FStar_Tactics_V1_Builtins.rewrite b1 in + FStarC_Tactics_V1_Builtins.rewrite b1 in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1714,7 +1720,7 @@ let (cases_bool : (fun uu___6 -> (fun uu___6 -> Obj.magic - (FStar_Tactics_V1_Builtins.clear_top + (FStarC_Tactics_V1_Builtins.clear_top ())) uu___6))) uu___5)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1734,57 +1740,57 @@ let (cases_bool : FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> ()))))) uu___1) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.cases_bool" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.cases_bool" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V1.Logic.cases_bool (plugin)" - (FStar_Tactics_Native.from_tactic_1 cases_bool) - FStar_Reflection_V2_Embeddings.e_term - FStar_Syntax_Embeddings.e_unit psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 cases_bool) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (left : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> FStar_Tactics_V1_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; "Logic"; "Lemmas"; "or_intro_1"]))) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.left" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.left" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V1.Logic.left (plugin)" - (FStar_Tactics_Native.from_tactic_1 left) - FStar_Syntax_Embeddings.e_unit FStar_Syntax_Embeddings.e_unit - psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 left) + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (right : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> FStar_Tactics_V1_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; "Logic"; "Lemmas"; "or_intro_2"]))) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.right" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.right" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V1.Logic.right (plugin)" - (FStar_Tactics_Native.from_tactic_1 right) - FStar_Syntax_Embeddings.e_unit FStar_Syntax_Embeddings.e_unit - psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 right) + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (and_elim : - FStar_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun t -> FStar_Tactics_V1_Derived.try_with @@ -1792,47 +1798,47 @@ let (and_elim : match () with | () -> FStar_Tactics_V1_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; "Logic"; "Lemmas"; "__and_elim"]))), - (t, FStar_Reflection_V2_Data.Q_Explicit))))) + (t, FStarC_Reflection_V2_Data.Q_Explicit))))) (fun uu___ -> FStar_Tactics_V1_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; "Logic"; "Lemmas"; "__and_elim'"]))), - (t, FStar_Reflection_V2_Data.Q_Explicit))))) + (t, FStarC_Reflection_V2_Data.Q_Explicit))))) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.and_elim" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.and_elim" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V1.Logic.and_elim (plugin)" - (FStar_Tactics_Native.from_tactic_1 and_elim) - FStar_Reflection_V2_Embeddings.e_term - FStar_Syntax_Embeddings.e_unit psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 and_elim) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (destruct_and : - FStar_Reflection_Types.term -> - ((FStar_Reflection_Types.binder * FStar_Reflection_Types.binder), + FStarC_Reflection_Types.term -> + ((FStarC_Reflection_Types.binder * FStarC_Reflection_Types.binder), unit) FStar_Tactics_Effect.tac_repr) = fun t -> @@ -1887,28 +1893,28 @@ let (destruct_and : (fun uu___6 -> (uu___3, uu___5))))) uu___3))) uu___1) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.destruct_and" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.destruct_and" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V1.Logic.destruct_and (plugin)" - (FStar_Tactics_Native.from_tactic_1 destruct_and) - FStar_Reflection_V2_Embeddings.e_term - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Reflection_V2_Embeddings.e_binder - FStar_Reflection_V2_Embeddings.e_binder) psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 destruct_and) + FStarC_Reflection_V2_Embeddings.e_term + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Reflection_V2_Embeddings.e_binder + FStarC_Reflection_V2_Embeddings.e_binder) psc ncb us args) let (witness : - FStar_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun t -> let uu___ = FStar_Tactics_V1_Derived.apply_raw - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; "Logic"; "__witness"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1924,32 +1930,32 @@ let (witness : (fun uu___1 -> (fun uu___1 -> Obj.magic (FStar_Tactics_V1_Derived.exact t)) uu___1) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.witness" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.witness" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V1.Logic.witness (plugin)" - (FStar_Tactics_Native.from_tactic_1 witness) - FStar_Reflection_V2_Embeddings.e_term - FStar_Syntax_Embeddings.e_unit psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 witness) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (elim_exists : - FStar_Reflection_Types.term -> - ((FStar_Reflection_Types.binder * FStar_Reflection_Types.binder), + FStarC_Reflection_Types.term -> + ((FStarC_Reflection_Types.binder * FStarC_Reflection_Types.binder), unit) FStar_Tactics_Effect.tac_repr) = fun t -> let uu___ = FStar_Tactics_V1_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; "Logic"; "__elim_exists'"]))), - (t, FStar_Reflection_V2_Data.Q_Explicit)))) in + (t, FStarC_Reflection_V2_Data.Q_Explicit)))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1963,7 +1969,7 @@ let (elim_exists : (Prims.of_int (9))))) (Obj.magic uu___) (fun uu___1 -> (fun uu___1 -> - let uu___2 = FStar_Tactics_V1_Builtins.intro () in + let uu___2 = FStarC_Tactics_V1_Builtins.intro () in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1979,7 +1985,7 @@ let (elim_exists : (Obj.magic uu___2) (fun uu___3 -> (fun x -> - let uu___3 = FStar_Tactics_V1_Builtins.intro () in + let uu___3 = FStarC_Tactics_V1_Builtins.intro () in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1999,23 +2005,23 @@ let (elim_exists : FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> (x, pf))))) uu___3))) uu___1) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.elim_exists" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.elim_exists" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V1.Logic.elim_exists (plugin)" - (FStar_Tactics_Native.from_tactic_1 elim_exists) - FStar_Reflection_V2_Embeddings.e_term - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Reflection_V2_Embeddings.e_binder - FStar_Reflection_V2_Embeddings.e_binder) psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 elim_exists) + FStarC_Reflection_V2_Embeddings.e_term + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Reflection_V2_Embeddings.e_binder + FStarC_Reflection_V2_Embeddings.e_binder) psc ncb us args) let (instantiate : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) = fun fa -> fun x -> @@ -2024,64 +2030,64 @@ let (instantiate : match () with | () -> FStar_Tactics_V1_Derived.pose - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; "Logic"; "__forall_inst_sq"]))), - (fa, FStar_Reflection_V2_Data.Q_Explicit)))), - (x, FStar_Reflection_V2_Data.Q_Explicit))))) + (fa, FStarC_Reflection_V2_Data.Q_Explicit)))), + (x, FStarC_Reflection_V2_Data.Q_Explicit))))) (fun uu___ -> FStar_Tactics_V1_Derived.try_with (fun uu___1 -> match () with | () -> FStar_Tactics_V1_Derived.pose - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; "Logic"; "__forall_inst"]))), (fa, - FStar_Reflection_V2_Data.Q_Explicit)))), - (x, FStar_Reflection_V2_Data.Q_Explicit))))) + FStarC_Reflection_V2_Data.Q_Explicit)))), + (x, FStarC_Reflection_V2_Data.Q_Explicit))))) (fun uu___1 -> (fun uu___1 -> Obj.magic (FStar_Tactics_V1_Derived.fail "could not instantiate")) uu___1)) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.instantiate" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.instantiate" (Prims.of_int (3)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_2 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_2 "FStar.Tactics.V1.Logic.instantiate (plugin)" - (FStar_Tactics_Native.from_tactic_2 instantiate) - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_binder psc ncb us args) + (FStarC_Tactics_Native.from_tactic_2 instantiate) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_binder psc ncb us args) let (instantiate_as : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> Prims.string -> - (FStar_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) + (FStarC_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) = fun fa -> fun x -> @@ -2100,26 +2106,26 @@ let (instantiate_as : (Prims.of_int (234)) (Prims.of_int (17))))) (Obj.magic uu___) (fun uu___1 -> - (fun b -> Obj.magic (FStar_Tactics_V1_Builtins.rename_to b s)) + (fun b -> Obj.magic (FStarC_Tactics_V1_Builtins.rename_to b s)) uu___1) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.instantiate_as" (Prims.of_int (4)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_3 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_3 "FStar.Tactics.V1.Logic.instantiate_as (plugin)" - (FStar_Tactics_Native.from_tactic_3 instantiate_as) - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_term - FStar_Syntax_Embeddings.e_string - FStar_Reflection_V2_Embeddings.e_binder psc ncb us args) + (FStarC_Tactics_Native.from_tactic_3 instantiate_as) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Syntax_Embeddings.e_string + FStarC_Reflection_V2_Embeddings.e_binder psc ncb us args) let rec (sk_binder' : - FStar_Reflection_Types.binders -> - FStar_Reflection_Types.binder -> - ((FStar_Reflection_Types.binders * FStar_Reflection_Types.binder), + FStarC_Reflection_Types.binders -> + FStarC_Reflection_Types.binder -> + ((FStarC_Reflection_Types.binders * FStarC_Reflection_Types.binder), unit) FStar_Tactics_Effect.tac_repr) = fun acc -> @@ -2151,11 +2157,11 @@ let rec (sk_binder' : (fun uu___5 -> FStar_Tactics_Effect.lift_div_tac (fun uu___6 -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; @@ -2163,7 +2169,7 @@ let rec (sk_binder' : "Lemmas"; "sklem0"]))), (uu___5, - FStar_Reflection_V2_Data.Q_Explicit))))) in + FStarC_Reflection_V2_Data.Q_Explicit))))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2270,7 +2276,7 @@ let rec (sk_binder' : (fun uu___5 -> (fun uu___5 -> let uu___6 = - FStar_Tactics_V1_Builtins.clear b in + FStarC_Tactics_V1_Builtins.clear b in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -2356,13 +2362,13 @@ let rec (sk_binder' : (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> (acc, b)))) uu___1)) let (sk_binder : - FStar_Reflection_Types.binder -> - ((FStar_Reflection_Types.binders * FStar_Reflection_Types.binder), + FStarC_Reflection_Types.binder -> + ((FStarC_Reflection_Types.binders * FStarC_Reflection_Types.binder), unit) FStar_Tactics_Effect.tac_repr) = fun b -> sk_binder' [] b let (skolem : unit -> - ((FStar_Reflection_Types.binders * FStar_Reflection_Types.binder) + ((FStarC_Reflection_Types.binders * FStarC_Reflection_Types.binder) Prims.list, unit) FStar_Tactics_Effect.tac_repr) = @@ -2384,7 +2390,7 @@ let (skolem : (fun uu___3 -> FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> - FStar_Reflection_V1_Builtins.binders_of_env uu___3)) in + FStarC_Reflection_V1_Builtins.binders_of_env uu___3)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2399,26 +2405,26 @@ let (skolem : (fun uu___2 -> (fun bs -> Obj.magic (FStar_Tactics_Util.map sk_binder bs)) uu___2) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.skolem" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.skolem" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V1.Logic.skolem (plugin)" - (FStar_Tactics_Native.from_tactic_1 skolem) - FStar_Syntax_Embeddings.e_unit - (FStar_Syntax_Embeddings.e_list - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_binder) - FStar_Reflection_V2_Embeddings.e_binder)) psc ncb us + (FStarC_Tactics_Native.from_tactic_1 skolem) + FStarC_Syntax_Embeddings.e_unit + (FStarC_Syntax_Embeddings.e_list + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_binder) + FStarC_Reflection_V2_Embeddings.e_binder)) psc ncb us args) let (easy_fill : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> let uu___1 = - FStar_Tactics_V1_Derived.repeat FStar_Tactics_V1_Builtins.intro in + FStar_Tactics_V1_Derived.repeat FStarC_Tactics_V1_Builtins.intro in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2437,9 +2443,9 @@ let (easy_fill : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___4 -> let uu___5 = FStar_Tactics_V1_Derived.apply - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; @@ -2460,7 +2466,7 @@ let (easy_fill : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (Obj.magic uu___5) (fun uu___6 -> (fun uu___6 -> - Obj.magic (FStar_Tactics_V1_Builtins.intro ())) + Obj.magic (FStarC_Tactics_V1_Builtins.intro ())) uu___6)) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -2480,51 +2486,52 @@ let (easy_fill : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = Obj.magic (FStar_Tactics_V1_Derived.smt ())) uu___4))) uu___2) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.easy_fill" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.easy_fill" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V1.Logic.easy_fill (plugin)" - (FStar_Tactics_Native.from_tactic_1 easy_fill) - FStar_Syntax_Embeddings.e_unit FStar_Syntax_Embeddings.e_unit - psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 easy_fill) + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let easy : 'a . 'a -> 'a = fun x -> x let _ = - FStar_Tactics_Native.register_plugin "FStar.Tactics.V1.Logic.easy" + FStarC_Tactics_Native.register_plugin "FStar.Tactics.V1.Logic.easy" (Prims.of_int (2)) (fun _psc -> fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap "FStar.Tactics.V1.Logic.easy" + FStarC_Syntax_Embeddings.debug_wrap + "FStar.Tactics.V1.Logic.easy" (fun _ -> match args with | (tv_0, _)::args_tail -> - (FStar_Syntax_Embeddings.arrow_as_prim_step_1 - (FStar_Syntax_Embeddings.mk_any_emb tv_0) - (FStar_Syntax_Embeddings.mk_any_emb tv_0) easy - (FStar_Ident.lid_of_str + (FStarC_Syntax_Embeddings.arrow_as_prim_step_1 + (FStarC_Syntax_Embeddings.mk_any_emb tv_0) + (FStarC_Syntax_Embeddings.mk_any_emb tv_0) easy + (FStarC_Ident.lid_of_str "FStar.Tactics.V1.Logic.easy") cb us) args_tail | _ -> failwith "arity mismatch")) (fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap "FStar.Tactics.V1.Logic.easy" + FStarC_Syntax_Embeddings.debug_wrap "FStar.Tactics.V1.Logic.easy" (fun _ -> match args with | (tv_0, _)::args_tail -> - (FStar_TypeChecker_NBETerm.arrow_as_prim_step_1 - (FStar_TypeChecker_NBETerm.mk_any_emb tv_0) - (FStar_TypeChecker_NBETerm.mk_any_emb tv_0) easy - (FStar_Ident.lid_of_str "FStar.Tactics.V1.Logic.easy") + (FStarC_TypeChecker_NBETerm.arrow_as_prim_step_1 + (FStarC_TypeChecker_NBETerm.mk_any_emb tv_0) + (FStarC_TypeChecker_NBETerm.mk_any_emb tv_0) easy + (FStarC_Ident.lid_of_str "FStar.Tactics.V1.Logic.easy") cb us) args_tail | _ -> failwith "arity mismatch")) let (using_lemma : - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) = fun t -> FStar_Tactics_V1_Derived.try_with @@ -2532,68 +2539,68 @@ let (using_lemma : match () with | () -> pose_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; "Logic"; "Lemmas"; "lem1_fa"]))), - (t, FStar_Reflection_V2_Data.Q_Explicit))))) + (t, FStarC_Reflection_V2_Data.Q_Explicit))))) (fun uu___ -> FStar_Tactics_V1_Derived.try_with (fun uu___1 -> match () with | () -> pose_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; "Logic"; "Lemmas"; "lem2_fa"]))), - (t, FStar_Reflection_V2_Data.Q_Explicit))))) + (t, FStarC_Reflection_V2_Data.Q_Explicit))))) (fun uu___1 -> FStar_Tactics_V1_Derived.try_with (fun uu___2 -> match () with | () -> pose_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; "Logic"; "Lemmas"; "lem3_fa"]))), - (t, FStar_Reflection_V2_Data.Q_Explicit))))) + (t, FStarC_Reflection_V2_Data.Q_Explicit))))) (fun uu___2 -> (fun uu___2 -> Obj.magic (FStar_Tactics_V1_Derived.fail "using_lemma: failed to instantiate")) uu___2))) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.using_lemma" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V1.Logic.using_lemma" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V1.Logic.using_lemma (plugin)" - (FStar_Tactics_Native.from_tactic_1 using_lemma) - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_binder psc ncb us args) \ No newline at end of file + (FStarC_Tactics_Native.from_tactic_1 using_lemma) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_binder psc ncb us args) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_V1_Primops.ml b/ocaml/fstar-lib/generated/FStar_Tactics_V1_Primops.ml deleted file mode 100644 index 1a845008108..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Tactics_V1_Primops.ml +++ /dev/null @@ -1,1198 +0,0 @@ -open Prims -let solve : 'a . 'a -> 'a = fun ev -> ev -let (uu___0 : - FStar_Syntax_Syntax.term FStar_Syntax_Embeddings_Base.embedding) = - FStar_Reflection_V1_Embeddings.e_term -let (fix_module : - FStar_TypeChecker_Primops_Base.primitive_step -> - FStar_TypeChecker_Primops_Base.primitive_step) - = - fun ps -> - let p = FStar_Ident.path_of_lid ps.FStar_TypeChecker_Primops_Base.name in - let uu___ = - FStar_Compiler_Path.is_under - (FStar_Class_Ord.ord_eq FStar_Class_Ord.ord_string) p - ["FStar"; "Stubs"; "Tactics"; "V2"; "Builtins"] in - if uu___ - then - let p' = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Compiler_List.tl p in - FStar_Compiler_List.tl uu___5 in - FStar_Compiler_List.tl uu___4 in - FStar_Compiler_List.tl uu___3 in - FStar_Compiler_List.tl uu___2 in - FStar_Compiler_List.op_At - ["FStar"; "Stubs"; "Tactics"; "V1"; "Builtins"] uu___1 in - let uu___1 = - let uu___2 = - FStar_Class_HasRange.pos FStar_Ident.hasrange_lident - ps.FStar_TypeChecker_Primops_Base.name in - FStar_Ident.lid_of_path p' uu___2 in - { - FStar_TypeChecker_Primops_Base.name = uu___1; - FStar_TypeChecker_Primops_Base.arity = - (ps.FStar_TypeChecker_Primops_Base.arity); - FStar_TypeChecker_Primops_Base.univ_arity = - (ps.FStar_TypeChecker_Primops_Base.univ_arity); - FStar_TypeChecker_Primops_Base.auto_reflect = - (ps.FStar_TypeChecker_Primops_Base.auto_reflect); - FStar_TypeChecker_Primops_Base.strong_reduction_ok = - (ps.FStar_TypeChecker_Primops_Base.strong_reduction_ok); - FStar_TypeChecker_Primops_Base.requires_binder_substitution = - (ps.FStar_TypeChecker_Primops_Base.requires_binder_substitution); - FStar_TypeChecker_Primops_Base.renorm_after = - (ps.FStar_TypeChecker_Primops_Base.renorm_after); - FStar_TypeChecker_Primops_Base.interpretation = - (ps.FStar_TypeChecker_Primops_Base.interpretation); - FStar_TypeChecker_Primops_Base.interpretation_nbe = - (ps.FStar_TypeChecker_Primops_Base.interpretation_nbe) - } - else failwith "huh?" -let (ops : FStar_TypeChecker_Primops_Base.primitive_step Prims.list) = - let uu___ = - let uu___1 = - FStar_Tactics_InterpFuns.mk_tac_step_1 Prims.int_zero "set_goals" - (FStar_Syntax_Embeddings.e_list FStar_Tactics_Embedding.e_goal) - FStar_Syntax_Embeddings.e_unit - (FStar_TypeChecker_NBETerm.e_list FStar_Tactics_Embedding.e_goal_nbe) - FStar_TypeChecker_NBETerm.e_unit FStar_Tactics_Monad.set_goals - FStar_Tactics_Monad.set_goals in - let uu___2 = - let uu___3 = - FStar_Tactics_InterpFuns.mk_tac_step_1 Prims.int_zero "set_smt_goals" - (FStar_Syntax_Embeddings.e_list FStar_Tactics_Embedding.e_goal) - FStar_Syntax_Embeddings.e_unit - (FStar_TypeChecker_NBETerm.e_list - FStar_Tactics_Embedding.e_goal_nbe) - FStar_TypeChecker_NBETerm.e_unit FStar_Tactics_Monad.set_smt_goals - FStar_Tactics_Monad.set_smt_goals in - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Tactics_Interpreter.e_tactic_thunk - FStar_Syntax_Embeddings.e_any in - let uu___7 = - FStar_Tactics_Interpreter.e_tactic_nbe_thunk - FStar_TypeChecker_NBETerm.e_any in - FStar_Tactics_InterpFuns.mk_tac_step_2 Prims.int_one "catch" - FStar_Syntax_Embeddings.e_any uu___6 - (FStar_Syntax_Embeddings.e_either FStar_Tactics_Embedding.e_exn - FStar_Syntax_Embeddings.e_any) FStar_TypeChecker_NBETerm.e_any - uu___7 - (FStar_TypeChecker_NBETerm.e_either - FStar_Tactics_Embedding.e_exn_nbe - FStar_TypeChecker_NBETerm.e_any) - (fun uu___8 -> FStar_Tactics_Monad.catch) - (fun uu___8 -> FStar_Tactics_Monad.catch) in - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Tactics_Interpreter.e_tactic_thunk - FStar_Syntax_Embeddings.e_any in - let uu___9 = - FStar_Tactics_Interpreter.e_tactic_nbe_thunk - FStar_TypeChecker_NBETerm.e_any in - FStar_Tactics_InterpFuns.mk_tac_step_2 Prims.int_one "recover" - FStar_Syntax_Embeddings.e_any uu___8 - (FStar_Syntax_Embeddings.e_either FStar_Tactics_Embedding.e_exn - FStar_Syntax_Embeddings.e_any) - FStar_TypeChecker_NBETerm.e_any uu___9 - (FStar_TypeChecker_NBETerm.e_either - FStar_Tactics_Embedding.e_exn_nbe - FStar_TypeChecker_NBETerm.e_any) - (fun uu___10 -> FStar_Tactics_Monad.recover) - (fun uu___10 -> FStar_Tactics_Monad.recover) in - let uu___8 = - let uu___9 = - FStar_Tactics_InterpFuns.mk_tac_step_1 Prims.int_zero "intro" - FStar_Syntax_Embeddings.e_unit - FStar_Reflection_V2_Embeddings.e_binder - FStar_TypeChecker_NBETerm.e_unit - FStar_Reflection_V2_NBEEmbeddings.e_binder - FStar_Tactics_V1_Basic.intro FStar_Tactics_V1_Basic.intro in - let uu___10 = - let uu___11 = - FStar_Tactics_InterpFuns.mk_tac_step_1 Prims.int_zero - "intro_rec" FStar_Syntax_Embeddings.e_unit - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Reflection_V2_Embeddings.e_binder - FStar_Reflection_V2_Embeddings.e_binder) - FStar_TypeChecker_NBETerm.e_unit - (FStar_TypeChecker_NBETerm.e_tuple2 - FStar_Reflection_V2_NBEEmbeddings.e_binder - FStar_Reflection_V2_NBEEmbeddings.e_binder) - FStar_Tactics_V1_Basic.intro_rec - FStar_Tactics_V1_Basic.intro_rec in - let uu___12 = - let uu___13 = - FStar_Tactics_InterpFuns.mk_tac_step_1 Prims.int_zero - "norm" - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_norm_step) - FStar_Syntax_Embeddings.e_unit - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_norm_step) - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V1_Basic.norm FStar_Tactics_V1_Basic.norm in - let uu___14 = - let uu___15 = - FStar_Tactics_InterpFuns.mk_tac_step_3 Prims.int_zero - "norm_term_env" FStar_Reflection_V2_Embeddings.e_env - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_norm_step) uu___0 uu___0 - FStar_Reflection_V2_NBEEmbeddings.e_env - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_norm_step) - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Tactics_V1_Basic.norm_term_env - FStar_Tactics_V1_Basic.norm_term_env in - let uu___16 = - let uu___17 = - FStar_Tactics_InterpFuns.mk_tac_step_2 Prims.int_zero - "norm_binder_type" - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_norm_step) - FStar_Reflection_V2_Embeddings.e_binder - FStar_Syntax_Embeddings.e_unit - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_norm_step) - FStar_Reflection_V2_NBEEmbeddings.e_binder - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V1_Basic.norm_binder_type - FStar_Tactics_V1_Basic.norm_binder_type in - let uu___18 = - let uu___19 = - FStar_Tactics_InterpFuns.mk_tac_step_2 Prims.int_zero - "rename_to" FStar_Reflection_V2_Embeddings.e_binder - FStar_Syntax_Embeddings.e_string - FStar_Reflection_V2_Embeddings.e_binder - FStar_Reflection_V2_NBEEmbeddings.e_binder - FStar_TypeChecker_NBETerm.e_string - FStar_Reflection_V2_NBEEmbeddings.e_binder - FStar_Tactics_V1_Basic.rename_to - FStar_Tactics_V1_Basic.rename_to in - let uu___20 = - let uu___21 = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero "binder_retype" - FStar_Reflection_V2_Embeddings.e_binder - FStar_Syntax_Embeddings.e_unit - FStar_Reflection_V2_NBEEmbeddings.e_binder - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V1_Basic.binder_retype - FStar_Tactics_V1_Basic.binder_retype in - let uu___22 = - let uu___23 = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero "revert" - FStar_Syntax_Embeddings.e_unit - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_unit - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V1_Basic.revert - FStar_Tactics_V1_Basic.revert in - let uu___24 = - let uu___25 = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero "clear_top" - FStar_Syntax_Embeddings.e_unit - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_unit - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V1_Basic.clear_top - FStar_Tactics_V1_Basic.clear_top in - let uu___26 = - let uu___27 = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero "clear" - FStar_Reflection_V2_Embeddings.e_binder - FStar_Syntax_Embeddings.e_unit - FStar_Reflection_V2_NBEEmbeddings.e_binder - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V1_Basic.clear - FStar_Tactics_V1_Basic.clear in - let uu___28 = - let uu___29 = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero "rewrite" - FStar_Reflection_V2_Embeddings.e_binder - FStar_Syntax_Embeddings.e_unit - FStar_Reflection_V2_NBEEmbeddings.e_binder - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V1_Basic.rewrite - FStar_Tactics_V1_Basic.rewrite in - let uu___30 = - let uu___31 = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero "refine_intro" - FStar_Syntax_Embeddings.e_unit - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_unit - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V1_Basic.refine_intro - FStar_Tactics_V1_Basic.refine_intro in - let uu___32 = - let uu___33 = - FStar_Tactics_InterpFuns.mk_tac_step_3 - Prims.int_zero "t_exact" - FStar_Syntax_Embeddings.e_bool - FStar_Syntax_Embeddings.e_bool uu___0 - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_bool - FStar_TypeChecker_NBETerm.e_bool - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V1_Basic.t_exact - FStar_Tactics_V1_Basic.t_exact in - let uu___34 = - let uu___35 = - FStar_Tactics_InterpFuns.mk_tac_step_4 - Prims.int_zero "t_apply" - FStar_Syntax_Embeddings.e_bool - FStar_Syntax_Embeddings.e_bool - FStar_Syntax_Embeddings.e_bool - uu___0 - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_bool - FStar_TypeChecker_NBETerm.e_bool - FStar_TypeChecker_NBETerm.e_bool - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V1_Basic.t_apply - FStar_Tactics_V1_Basic.t_apply in - let uu___36 = - let uu___37 = - FStar_Tactics_InterpFuns.mk_tac_step_3 - Prims.int_zero "t_apply_lemma" - FStar_Syntax_Embeddings.e_bool - FStar_Syntax_Embeddings.e_bool - uu___0 - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_bool - FStar_TypeChecker_NBETerm.e_bool - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V1_Basic.t_apply_lemma - FStar_Tactics_V1_Basic.t_apply_lemma in - let uu___38 = - let uu___39 = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero "set_options" - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V1_Basic.set_options - FStar_Tactics_V1_Basic.set_options in - let uu___40 = - let uu___41 = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_zero "tcc" - FStar_Reflection_V2_Embeddings.e_env - uu___0 - FStar_Reflection_V2_Embeddings.e_comp - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Reflection_V2_NBEEmbeddings.e_comp - FStar_Tactics_V1_Basic.tcc - FStar_Tactics_V1_Basic.tcc in - let uu___42 = - let uu___43 = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_zero "tc" - FStar_Reflection_V2_Embeddings.e_env - uu___0 uu___0 - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Tactics_V1_Basic.tc - FStar_Tactics_V1_Basic.tc in - let uu___44 = - let uu___45 = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero "unshelve" - uu___0 - FStar_Syntax_Embeddings.e_unit - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V1_Basic.unshelve - FStar_Tactics_V1_Basic.unshelve in - let uu___46 = - let uu___47 = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_one "unquote" - FStar_Syntax_Embeddings.e_any - FStar_Reflection_V1_Embeddings.e_term - FStar_Syntax_Embeddings.e_any - FStar_TypeChecker_NBETerm.e_any - FStar_Reflection_V1_NBEEmbeddings.e_term - FStar_TypeChecker_NBETerm.e_any - FStar_Tactics_V1_Basic.unquote - (fun uu___48 -> - fun uu___49 -> - failwith - "NBE unquote") in - let uu___48 = - let uu___49 = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "prune" - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V1_Basic.prune - FStar_Tactics_V1_Basic.prune in - let uu___50 = - let uu___51 = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "addns" - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V1_Basic.addns - FStar_Tactics_V1_Basic.addns in - let uu___52 = - let uu___53 = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "print" - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V1_Basic.print - FStar_Tactics_V1_Basic.print in - let uu___54 = - let uu___55 = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "debugging" - FStar_Syntax_Embeddings.e_unit - FStar_Syntax_Embeddings.e_bool - FStar_TypeChecker_NBETerm.e_unit - FStar_TypeChecker_NBETerm.e_bool - FStar_Tactics_V1_Basic.debugging - FStar_Tactics_V1_Basic.debugging in - let uu___56 = - let uu___57 = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "dump" - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V1_Basic.dump - FStar_Tactics_V1_Basic.dump in - let uu___58 = - let uu___59 = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_zero - "dump_all" - FStar_Syntax_Embeddings.e_bool - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_bool - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V1_Basic.dump_all - FStar_Tactics_V1_Basic.dump_all in - let uu___60 = - let uu___61 = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_zero - "dump_uvars_of" - FStar_Tactics_Embedding.e_goal - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_unit - FStar_Tactics_Embedding.e_goal_nbe - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V1_Basic.dump_uvars_of - FStar_Tactics_V1_Basic.dump_uvars_of in - let uu___62 = - let uu___63 - = - let uu___64 - = - FStar_Tactics_Interpreter.e_tactic_1 - FStar_Reflection_V1_Embeddings.e_term - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Syntax_Embeddings.e_bool - FStar_Tactics_Embedding.e_ctrl_flag) in - let uu___65 - = - FStar_Tactics_Interpreter.e_tactic_thunk - FStar_Syntax_Embeddings.e_unit in - let uu___66 - = - FStar_Tactics_Interpreter.e_tactic_nbe_1 - FStar_Reflection_V1_NBEEmbeddings.e_term - (FStar_TypeChecker_NBETerm.e_tuple2 - FStar_TypeChecker_NBETerm.e_bool - FStar_Tactics_Embedding.e_ctrl_flag_nbe) in - let uu___67 - = - FStar_Tactics_Interpreter.e_tactic_nbe_thunk - FStar_TypeChecker_NBETerm.e_unit in - FStar_Tactics_InterpFuns.mk_tac_step_3 - Prims.int_zero - "ctrl_rewrite" - FStar_Tactics_Embedding.e_direction - uu___64 - uu___65 - FStar_Syntax_Embeddings.e_unit - FStar_Tactics_Embedding.e_direction_nbe - uu___66 - uu___67 - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_CtrlRewrite.ctrl_rewrite - FStar_Tactics_CtrlRewrite.ctrl_rewrite in - let uu___64 - = - let uu___65 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "t_trefl" - FStar_Syntax_Embeddings.e_bool - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_bool - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V1_Basic.t_trefl - FStar_Tactics_V1_Basic.t_trefl in - let uu___66 - = - let uu___67 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "dup" - FStar_Syntax_Embeddings.e_unit - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_unit - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V1_Basic.dup - FStar_Tactics_V1_Basic.dup in - let uu___68 - = - let uu___69 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "tadmit_t" - FStar_Reflection_V1_Embeddings.e_term - FStar_Syntax_Embeddings.e_unit - FStar_Reflection_V1_NBEEmbeddings.e_term - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V1_Basic.tadmit_t - FStar_Tactics_V1_Basic.tadmit_t in - let uu___70 - = - let uu___71 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "join" - FStar_Syntax_Embeddings.e_unit - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_unit - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V1_Basic.join - FStar_Tactics_V1_Basic.join in - let uu___72 - = - let uu___73 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "t_destruct" - FStar_Reflection_V1_Embeddings.e_term - (FStar_Syntax_Embeddings.e_list - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Reflection_V2_Embeddings.e_fv - FStar_Syntax_Embeddings.e_int)) - FStar_Reflection_V1_NBEEmbeddings.e_term - (FStar_TypeChecker_NBETerm.e_list - (FStar_TypeChecker_NBETerm.e_tuple2 - FStar_Reflection_V2_NBEEmbeddings.e_fv - FStar_TypeChecker_NBETerm.e_int)) - FStar_Tactics_V1_Basic.t_destruct - FStar_Tactics_V1_Basic.t_destruct in - let uu___74 - = - let uu___75 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "top_env" - FStar_Syntax_Embeddings.e_unit - FStar_Reflection_V2_Embeddings.e_env - FStar_TypeChecker_NBETerm.e_unit - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_Tactics_V1_Basic.top_env - FStar_Tactics_V1_Basic.top_env in - let uu___76 - = - let uu___77 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "inspect" - FStar_Reflection_V1_Embeddings.e_term - FStar_Reflection_V1_Embeddings.e_term_view - FStar_Reflection_V1_NBEEmbeddings.e_term - FStar_Reflection_V1_NBEEmbeddings.e_term_view - FStar_Tactics_V1_Basic.inspect - FStar_Tactics_V1_Basic.inspect in - let uu___78 - = - let uu___79 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "pack" - FStar_Reflection_V1_Embeddings.e_term_view - FStar_Reflection_V1_Embeddings.e_term - FStar_Reflection_V1_NBEEmbeddings.e_term_view - FStar_Reflection_V1_NBEEmbeddings.e_term - FStar_Tactics_V1_Basic.pack - FStar_Tactics_V1_Basic.pack in - let uu___80 - = - let uu___81 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "pack_curried" - FStar_Reflection_V1_Embeddings.e_term_view - FStar_Reflection_V1_Embeddings.e_term - FStar_Reflection_V1_NBEEmbeddings.e_term_view - FStar_Reflection_V1_NBEEmbeddings.e_term - FStar_Tactics_V1_Basic.pack_curried - FStar_Tactics_V1_Basic.pack_curried in - let uu___82 - = - let uu___83 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "fresh" - FStar_Syntax_Embeddings.e_unit - FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_unit - FStar_TypeChecker_NBETerm.e_int - FStar_Tactics_V1_Basic.fresh - FStar_Tactics_V1_Basic.fresh in - let uu___84 - = - let uu___85 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "curms" - FStar_Syntax_Embeddings.e_unit - FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_unit - FStar_TypeChecker_NBETerm.e_int - FStar_Tactics_V1_Basic.curms - FStar_Tactics_V1_Basic.curms in - let uu___86 - = - let uu___87 - = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_zero - "uvar_env" - FStar_Reflection_V2_Embeddings.e_env - (FStar_Syntax_Embeddings.e_option - FStar_Reflection_V1_Embeddings.e_term) - FStar_Reflection_V1_Embeddings.e_term - FStar_Reflection_V2_NBEEmbeddings.e_env - (FStar_TypeChecker_NBETerm.e_option - FStar_Reflection_V1_NBEEmbeddings.e_term) - FStar_Reflection_V1_NBEEmbeddings.e_term - FStar_Tactics_V1_Basic.uvar_env - FStar_Tactics_V1_Basic.uvar_env in - let uu___88 - = - let uu___89 - = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_zero - "ghost_uvar_env" - FStar_Reflection_V2_Embeddings.e_env - FStar_Reflection_V1_Embeddings.e_term - FStar_Reflection_V1_Embeddings.e_term - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_Reflection_V1_NBEEmbeddings.e_term - FStar_Reflection_V1_NBEEmbeddings.e_term - FStar_Tactics_V1_Basic.ghost_uvar_env - FStar_Tactics_V1_Basic.ghost_uvar_env in - let uu___90 - = - let uu___91 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "fresh_universe_uvar" - FStar_Syntax_Embeddings.e_unit - FStar_Reflection_V1_Embeddings.e_term - FStar_TypeChecker_NBETerm.e_unit - FStar_Reflection_V1_NBEEmbeddings.e_term - FStar_Tactics_V1_Basic.fresh_universe_uvar - FStar_Tactics_V1_Basic.fresh_universe_uvar in - let uu___92 - = - let uu___93 - = - FStar_Tactics_InterpFuns.mk_tac_step_3 - Prims.int_zero - "unify_env" - FStar_Reflection_V1_Embeddings.e_env - FStar_Reflection_V1_Embeddings.e_term - FStar_Reflection_V1_Embeddings.e_term - FStar_Syntax_Embeddings.e_bool - FStar_Reflection_V1_NBEEmbeddings.e_env - FStar_Reflection_V1_NBEEmbeddings.e_term - FStar_Reflection_V1_NBEEmbeddings.e_term - FStar_TypeChecker_NBETerm.e_bool - FStar_Tactics_V1_Basic.unify_env - FStar_Tactics_V1_Basic.unify_env in - let uu___94 - = - let uu___95 - = - FStar_Tactics_InterpFuns.mk_tac_step_3 - Prims.int_zero - "unify_guard_env" - FStar_Reflection_V1_Embeddings.e_env - FStar_Reflection_V1_Embeddings.e_term - FStar_Reflection_V1_Embeddings.e_term - FStar_Syntax_Embeddings.e_bool - FStar_Reflection_V1_NBEEmbeddings.e_env - FStar_Reflection_V1_NBEEmbeddings.e_term - FStar_Reflection_V1_NBEEmbeddings.e_term - FStar_TypeChecker_NBETerm.e_bool - FStar_Tactics_V1_Basic.unify_guard_env - FStar_Tactics_V1_Basic.unify_guard_env in - let uu___96 - = - let uu___97 - = - FStar_Tactics_InterpFuns.mk_tac_step_3 - Prims.int_zero - "match_env" - FStar_Reflection_V1_Embeddings.e_env - FStar_Reflection_V1_Embeddings.e_term - FStar_Reflection_V1_Embeddings.e_term - FStar_Syntax_Embeddings.e_bool - FStar_Reflection_V1_NBEEmbeddings.e_env - FStar_Reflection_V1_NBEEmbeddings.e_term - FStar_Reflection_V1_NBEEmbeddings.e_term - FStar_TypeChecker_NBETerm.e_bool - FStar_Tactics_V1_Basic.match_env - FStar_Tactics_V1_Basic.match_env in - let uu___98 - = - let uu___99 - = - FStar_Tactics_InterpFuns.mk_tac_step_3 - Prims.int_zero - "launch_process" - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_string_list - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_string_list - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_string - FStar_Tactics_V1_Basic.launch_process - FStar_Tactics_V1_Basic.launch_process in - let uu___100 - = - let uu___101 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "fresh_bv_named" - FStar_Syntax_Embeddings.e_string - FStar_Reflection_V1_Embeddings.e_bv - FStar_TypeChecker_NBETerm.e_string - FStar_Reflection_V1_NBEEmbeddings.e_bv - FStar_Tactics_V1_Basic.fresh_bv_named - FStar_Tactics_V1_Basic.fresh_bv_named in - let uu___102 - = - let uu___103 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "change" - FStar_Reflection_V1_Embeddings.e_term - FStar_Syntax_Embeddings.e_unit - FStar_Reflection_V1_NBEEmbeddings.e_term - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V1_Basic.change - FStar_Tactics_V1_Basic.change in - let uu___104 - = - let uu___105 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "get_guard_policy" - FStar_Syntax_Embeddings.e_unit - FStar_Tactics_Embedding.e_guard_policy - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_Embedding.e_guard_policy_nbe - FStar_Tactics_V1_Basic.get_guard_policy - FStar_Tactics_V1_Basic.get_guard_policy in - let uu___106 - = - let uu___107 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "set_guard_policy" - FStar_Tactics_Embedding.e_guard_policy - FStar_Syntax_Embeddings.e_unit - FStar_Tactics_Embedding.e_guard_policy_nbe - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V1_Basic.set_guard_policy - FStar_Tactics_V1_Basic.set_guard_policy in - let uu___108 - = - let uu___109 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "lax_on" - FStar_Syntax_Embeddings.e_unit - FStar_Syntax_Embeddings.e_bool - FStar_TypeChecker_NBETerm.e_unit - FStar_TypeChecker_NBETerm.e_bool - FStar_Tactics_V1_Basic.lax_on - FStar_Tactics_V1_Basic.lax_on in - let uu___110 - = - let uu___111 - = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_one - "lget" - FStar_Syntax_Embeddings.e_any - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_any - FStar_TypeChecker_NBETerm.e_any - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_any - FStar_Tactics_V1_Basic.lget - (fun - uu___112 - -> - fun - uu___113 - -> - FStar_Tactics_Monad.fail - "sorry, `lget` does not work in NBE") in - let uu___112 - = - let uu___113 - = - FStar_Tactics_InterpFuns.mk_tac_step_3 - Prims.int_one - "lset" - FStar_Syntax_Embeddings.e_any - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_any - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_any - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_any - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V1_Basic.lset - (fun - uu___114 - -> - fun - uu___115 - -> - fun - uu___116 - -> - FStar_Tactics_Monad.fail - "sorry, `lset` does not work in NBE") in - let uu___114 - = - let uu___115 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "set_urgency" - FStar_Syntax_Embeddings.e_int - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_int - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V1_Basic.set_urgency - FStar_Tactics_V1_Basic.set_urgency in - let uu___116 - = - let uu___117 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "t_commute_applied_match" - FStar_Syntax_Embeddings.e_unit - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_unit - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V1_Basic.t_commute_applied_match - FStar_Tactics_V1_Basic.t_commute_applied_match in - let uu___118 - = - let uu___119 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "gather_or_solve_explicit_guards_for_resolved_goals" - FStar_Syntax_Embeddings.e_unit - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_unit - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V1_Basic.gather_explicit_guards_for_resolved_goals - FStar_Tactics_V1_Basic.gather_explicit_guards_for_resolved_goals in - let uu___120 - = - let uu___121 - = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_zero - "string_to_term" - FStar_Reflection_V1_Embeddings.e_env - FStar_Syntax_Embeddings.e_string - FStar_Reflection_V1_Embeddings.e_term - FStar_Reflection_V1_NBEEmbeddings.e_env - FStar_TypeChecker_NBETerm.e_string - FStar_Reflection_V1_NBEEmbeddings.e_term - FStar_Tactics_V1_Basic.string_to_term - FStar_Tactics_V1_Basic.string_to_term in - let uu___122 - = - let uu___123 - = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_zero - "push_bv_dsenv" - FStar_Reflection_V1_Embeddings.e_env - FStar_Syntax_Embeddings.e_string - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Reflection_V1_Embeddings.e_env - FStar_Reflection_V1_Embeddings.e_bv) - FStar_Reflection_V1_NBEEmbeddings.e_env - FStar_TypeChecker_NBETerm.e_string - (FStar_TypeChecker_NBETerm.e_tuple2 - FStar_Reflection_V1_NBEEmbeddings.e_env - FStar_Reflection_V1_NBEEmbeddings.e_bv) - FStar_Tactics_V1_Basic.push_bv_dsenv - FStar_Tactics_V1_Basic.push_bv_dsenv in - let uu___124 - = - let uu___125 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "term_to_string" - FStar_Reflection_V1_Embeddings.e_term - FStar_Syntax_Embeddings.e_string - FStar_Reflection_V1_NBEEmbeddings.e_term - FStar_TypeChecker_NBETerm.e_string - FStar_Tactics_V1_Basic.term_to_string - FStar_Tactics_V1_Basic.term_to_string in - let uu___126 - = - let uu___127 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "comp_to_string" - FStar_Reflection_V2_Embeddings.e_comp - FStar_Syntax_Embeddings.e_string - FStar_Reflection_V2_NBEEmbeddings.e_comp - FStar_TypeChecker_NBETerm.e_string - FStar_Tactics_V1_Basic.comp_to_string - FStar_Tactics_V1_Basic.comp_to_string in - let uu___128 - = - let uu___129 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "range_to_string" - FStar_Syntax_Embeddings.e_range - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_range - FStar_TypeChecker_NBETerm.e_string - FStar_Tactics_V1_Basic.range_to_string - FStar_Tactics_V1_Basic.range_to_string in - let uu___130 - = - let uu___131 - = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_zero - "term_eq_old" - FStar_Reflection_V1_Embeddings.e_term - FStar_Reflection_V1_Embeddings.e_term - FStar_Syntax_Embeddings.e_bool - FStar_Reflection_V1_NBEEmbeddings.e_term - FStar_Reflection_V1_NBEEmbeddings.e_term - FStar_TypeChecker_NBETerm.e_bool - FStar_Tactics_V1_Basic.term_eq_old - FStar_Tactics_V1_Basic.term_eq_old in - let uu___132 - = - let uu___133 - = - let uu___134 - = - FStar_Tactics_Interpreter.e_tactic_thunk - FStar_Syntax_Embeddings.e_any in - let uu___135 - = - FStar_Tactics_Interpreter.e_tactic_nbe_thunk - FStar_TypeChecker_NBETerm.e_any in - FStar_Tactics_InterpFuns.mk_tac_step_3 - Prims.int_one - "with_compat_pre_core" - FStar_Syntax_Embeddings.e_any - FStar_Syntax_Embeddings.e_int - uu___134 - FStar_Syntax_Embeddings.e_any - FStar_TypeChecker_NBETerm.e_any - FStar_TypeChecker_NBETerm.e_int - uu___135 - FStar_TypeChecker_NBETerm.e_any - (fun - uu___136 - -> - FStar_Tactics_V1_Basic.with_compat_pre_core) - (fun - uu___136 - -> - FStar_Tactics_V1_Basic.with_compat_pre_core) in - let uu___134 - = - let uu___135 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "get_vconfig" - FStar_Syntax_Embeddings.e_unit - FStar_Syntax_Embeddings.e_vconfig - FStar_TypeChecker_NBETerm.e_unit - FStar_TypeChecker_NBETerm.e_vconfig - FStar_Tactics_V1_Basic.get_vconfig - FStar_Tactics_V1_Basic.get_vconfig in - let uu___136 - = - let uu___137 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "set_vconfig" - FStar_Syntax_Embeddings.e_vconfig - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_vconfig - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V1_Basic.set_vconfig - FStar_Tactics_V1_Basic.set_vconfig in - let uu___138 - = - let uu___139 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "t_smt_sync" - FStar_Syntax_Embeddings.e_vconfig - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_vconfig - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V1_Basic.t_smt_sync - FStar_Tactics_V1_Basic.t_smt_sync in - let uu___140 - = - let uu___141 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "free_uvars" - FStar_Reflection_V1_Embeddings.e_term - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_int) - FStar_Reflection_V1_NBEEmbeddings.e_term - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_int) - FStar_Tactics_V1_Basic.free_uvars - FStar_Tactics_V1_Basic.free_uvars in - [uu___141] in - uu___139 - :: - uu___140 in - uu___137 - :: - uu___138 in - uu___135 - :: - uu___136 in - uu___133 - :: - uu___134 in - uu___131 - :: - uu___132 in - uu___129 - :: - uu___130 in - uu___127 - :: - uu___128 in - uu___125 - :: - uu___126 in - uu___123 - :: - uu___124 in - uu___121 - :: - uu___122 in - uu___119 - :: - uu___120 in - uu___117 - :: - uu___118 in - uu___115 - :: - uu___116 in - uu___113 - :: - uu___114 in - uu___111 - :: - uu___112 in - uu___109 - :: - uu___110 in - uu___107 - :: - uu___108 in - uu___105 - :: - uu___106 in - uu___103 - :: - uu___104 in - uu___101 - :: - uu___102 in - uu___99 - :: - uu___100 in - uu___97 - :: - uu___98 in - uu___95 - :: - uu___96 in - uu___93 - :: - uu___94 in - uu___91 - :: - uu___92 in - uu___89 - :: - uu___90 in - uu___87 - :: - uu___88 in - uu___85 - :: - uu___86 in - uu___83 - :: - uu___84 in - uu___81 - :: - uu___82 in - uu___79 - :: - uu___80 in - uu___77 - :: - uu___78 in - uu___75 - :: - uu___76 in - uu___73 - :: - uu___74 in - uu___71 - :: - uu___72 in - uu___69 - :: - uu___70 in - uu___67 - :: - uu___68 in - uu___65 - :: - uu___66 in - uu___63 :: - uu___64 in - uu___61 :: - uu___62 in - uu___59 :: - uu___60 in - uu___57 :: - uu___58 in - uu___55 :: uu___56 in - uu___53 :: uu___54 in - uu___51 :: uu___52 in - uu___49 :: uu___50 in - uu___47 :: uu___48 in - uu___45 :: uu___46 in - uu___43 :: uu___44 in - uu___41 :: uu___42 in - uu___39 :: uu___40 in - uu___37 :: uu___38 in - uu___35 :: uu___36 in - uu___33 :: uu___34 in - uu___31 :: uu___32 in - uu___29 :: uu___30 in - uu___27 :: uu___28 in - uu___25 :: uu___26 in - uu___23 :: uu___24 in - uu___21 :: uu___22 in - uu___19 :: uu___20 in - uu___17 :: uu___18 in - uu___15 :: uu___16 in - uu___13 :: uu___14 in - uu___11 :: uu___12 in - uu___9 :: uu___10 in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Compiler_List.map fix_module uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_V1_SyntaxHelpers.ml b/ocaml/fstar-lib/generated/FStar_Tactics_V1_SyntaxHelpers.ml index e226a99042b..5864df15e4e 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_V1_SyntaxHelpers.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_V1_SyntaxHelpers.ml @@ -1,20 +1,20 @@ open Prims let rec (collect_arr' : - FStar_Reflection_Types.binder Prims.list -> - FStar_Reflection_Types.comp -> - ((FStar_Reflection_Types.binder Prims.list * - FStar_Reflection_Types.comp), + FStarC_Reflection_Types.binder Prims.list -> + FStarC_Reflection_Types.comp -> + ((FStarC_Reflection_Types.binder Prims.list * + FStarC_Reflection_Types.comp), unit) FStar_Tactics_Effect.tac_repr) = fun uu___1 -> fun uu___ -> (fun bs -> fun c -> - match FStar_Reflection_V1_Builtins.inspect_comp c with - | FStar_Reflection_V1_Data.C_Total t -> + match FStarC_Reflection_V1_Builtins.inspect_comp c with + | FStarC_Reflection_V1_Data.C_Total t -> Obj.magic (Obj.repr - (let uu___ = FStar_Tactics_V1_Builtins.inspect t in + (let uu___ = FStarC_Tactics_V1_Builtins.inspect t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -32,7 +32,7 @@ let rec (collect_arr' : (fun uu___1 -> (fun uu___1 -> match uu___1 with - | FStar_Reflection_V1_Data.Tv_Arrow (b, c1) -> + | FStarC_Reflection_V1_Data.Tv_Arrow (b, c1) -> Obj.magic (Obj.repr (collect_arr' (b :: bs) c1)) | uu___2 -> @@ -46,15 +46,16 @@ let rec (collect_arr' : (FStar_Tactics_Effect.lift_div_tac (fun uu___1 -> (bs, c))))) uu___1 uu___ let (collect_arr_bs : - FStar_Reflection_Types.typ -> - ((FStar_Reflection_Types.binder Prims.list * FStar_Reflection_Types.comp), + FStarC_Reflection_Types.typ -> + ((FStarC_Reflection_Types.binder Prims.list * + FStarC_Reflection_Types.comp), unit) FStar_Tactics_Effect.tac_repr) = fun t -> let uu___ = collect_arr' [] - (FStar_Reflection_V1_Builtins.pack_comp - (FStar_Reflection_V1_Data.C_Total t)) in + (FStarC_Reflection_V1_Builtins.pack_comp + (FStarC_Reflection_V1_Data.C_Total t)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -72,15 +73,15 @@ let (collect_arr_bs : match uu___1 with | (bs, c) -> ((FStar_List_Tot_Base.rev bs), c))) let (collect_arr : - FStar_Reflection_Types.typ -> - ((FStar_Reflection_Types.typ Prims.list * FStar_Reflection_Types.comp), + FStarC_Reflection_Types.typ -> + ((FStarC_Reflection_Types.typ Prims.list * FStarC_Reflection_Types.comp), unit) FStar_Tactics_Effect.tac_repr) = fun t -> let uu___ = collect_arr' [] - (FStar_Reflection_V1_Builtins.pack_comp - (FStar_Reflection_V1_Data.C_Total t)) in + (FStarC_Reflection_V1_Builtins.pack_comp + (FStarC_Reflection_V1_Data.C_Total t)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -101,15 +102,15 @@ let (collect_arr : (FStar_List_Tot_Base.map FStar_Reflection_V1_Derived.type_of_binder bs)), c))) let rec (collect_abs' : - FStar_Reflection_Types.binder Prims.list -> - FStar_Reflection_Types.term -> - ((FStar_Reflection_Types.binder Prims.list * - FStar_Reflection_Types.term), + FStarC_Reflection_Types.binder Prims.list -> + FStarC_Reflection_Types.term -> + ((FStarC_Reflection_Types.binder Prims.list * + FStarC_Reflection_Types.term), unit) FStar_Tactics_Effect.tac_repr) = fun bs -> fun t -> - let uu___ = FStar_Tactics_V1_Builtins.inspect t in + let uu___ = FStarC_Tactics_V1_Builtins.inspect t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -124,7 +125,7 @@ let rec (collect_abs' : (fun uu___1 -> (fun uu___1 -> match uu___1 with - | FStar_Reflection_V1_Data.Tv_Abs (b, t') -> + | FStarC_Reflection_V1_Data.Tv_Abs (b, t') -> Obj.magic (Obj.repr (collect_abs' (b :: bs) t')) | uu___2 -> Obj.magic @@ -132,8 +133,9 @@ let rec (collect_abs' : (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> (bs, t))))) uu___1) let (collect_abs : - FStar_Reflection_Types.term -> - ((FStar_Reflection_Types.binder Prims.list * FStar_Reflection_Types.term), + FStarC_Reflection_Types.term -> + ((FStarC_Reflection_Types.binder Prims.list * + FStarC_Reflection_Types.term), unit) FStar_Tactics_Effect.tac_repr) = fun t -> @@ -159,21 +161,21 @@ let fail : 'a . Prims.string -> ('a, unit) FStar_Tactics_Effect.tac_repr = (fun m -> Obj.magic (FStar_Tactics_Effect.raise - (FStar_Tactics_Common.TacticFailure - ((FStar_Errors_Msg.mkmsg m), FStar_Pervasives_Native.None)))) + (FStarC_Tactics_Common.TacticFailure + ((FStarC_Errors_Msg.mkmsg m), FStar_Pervasives_Native.None)))) uu___ let rec (mk_arr : - FStar_Reflection_Types.binder Prims.list -> - FStar_Reflection_Types.comp -> - (FStar_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.binder Prims.list -> + FStarC_Reflection_Types.comp -> + (FStarC_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) = fun bs -> fun cod -> match bs with | [] -> fail "mk_arr, empty binders" | b::[] -> - FStar_Tactics_V1_Builtins.pack - (FStar_Reflection_V1_Data.Tv_Arrow (b, cod)) + FStarC_Tactics_V1_Builtins.pack + (FStarC_Reflection_V1_Data.Tv_Arrow (b, cod)) | b::bs1 -> let uu___ = let uu___1 = @@ -195,7 +197,8 @@ let rec (mk_arr : (Obj.magic uu___3) (fun uu___4 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___5 -> FStar_Reflection_V1_Data.C_Total uu___4)) in + (fun uu___5 -> + FStarC_Reflection_V1_Data.C_Total uu___4)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -213,7 +216,7 @@ let rec (mk_arr : (fun uu___3 -> FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> - FStar_Reflection_V1_Builtins.pack_comp uu___3)) in + FStarC_Reflection_V1_Builtins.pack_comp uu___3)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -231,7 +234,7 @@ let rec (mk_arr : (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> - FStar_Reflection_V1_Data.Tv_Arrow (b, uu___2))) in + FStarC_Reflection_V1_Data.Tv_Arrow (b, uu___2))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -246,19 +249,19 @@ let rec (mk_arr : (Obj.magic uu___) (fun uu___1 -> (fun uu___1 -> - Obj.magic (FStar_Tactics_V1_Builtins.pack uu___1)) uu___1) + Obj.magic (FStarC_Tactics_V1_Builtins.pack uu___1)) uu___1) let rec (mk_arr_curried : - FStar_Reflection_Types.binder Prims.list -> - FStar_Reflection_Types.comp -> - (FStar_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.binder Prims.list -> + FStarC_Reflection_Types.comp -> + (FStarC_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) = fun bs -> fun cod -> match bs with | [] -> fail "mk_arr, empty binders" | b::[] -> - FStar_Tactics_V1_Builtins.pack_curried - (FStar_Reflection_V1_Data.Tv_Arrow (b, cod)) + FStarC_Tactics_V1_Builtins.pack_curried + (FStarC_Reflection_V1_Data.Tv_Arrow (b, cod)) | b::bs1 -> let uu___ = let uu___1 = @@ -280,7 +283,8 @@ let rec (mk_arr_curried : (Obj.magic uu___3) (fun uu___4 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___5 -> FStar_Reflection_V1_Data.C_Total uu___4)) in + (fun uu___5 -> + FStarC_Reflection_V1_Data.C_Total uu___4)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -298,7 +302,7 @@ let rec (mk_arr_curried : (fun uu___3 -> FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> - FStar_Reflection_V1_Builtins.pack_comp uu___3)) in + FStarC_Reflection_V1_Builtins.pack_comp uu___3)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -316,7 +320,7 @@ let rec (mk_arr_curried : (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> - FStar_Reflection_V1_Data.Tv_Arrow (b, uu___2))) in + FStarC_Reflection_V1_Data.Tv_Arrow (b, uu___2))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -331,12 +335,12 @@ let rec (mk_arr_curried : (Obj.magic uu___) (fun uu___1 -> (fun uu___1 -> - Obj.magic (FStar_Tactics_V1_Builtins.pack_curried uu___1)) + Obj.magic (FStarC_Tactics_V1_Builtins.pack_curried uu___1)) uu___1) let rec (mk_tot_arr : - FStar_Reflection_Types.binder Prims.list -> - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.binder Prims.list -> + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) = fun uu___1 -> fun uu___ -> @@ -371,7 +375,7 @@ let rec (mk_tot_arr : (fun uu___4 -> FStar_Tactics_Effect.lift_div_tac (fun uu___5 -> - FStar_Reflection_V1_Data.C_Total uu___4)) in + FStarC_Reflection_V1_Data.C_Total uu___4)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -389,7 +393,7 @@ let rec (mk_tot_arr : (fun uu___3 -> FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> - FStar_Reflection_V1_Builtins.pack_comp + FStarC_Reflection_V1_Builtins.pack_comp uu___3)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -408,7 +412,7 @@ let rec (mk_tot_arr : (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> - FStar_Reflection_V1_Data.Tv_Arrow + FStarC_Reflection_V1_Data.Tv_Arrow (b, uu___2))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -427,12 +431,12 @@ let rec (mk_tot_arr : (fun uu___1 -> (fun uu___1 -> Obj.magic - (FStar_Tactics_V1_Builtins.pack uu___1)) + (FStarC_Tactics_V1_Builtins.pack uu___1)) uu___1)))) uu___1 uu___ let (lookup_lb_view : - FStar_Reflection_Types.letbinding Prims.list -> - FStar_Reflection_Types.name -> - (FStar_Reflection_V1_Data.lb_view, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.letbinding Prims.list -> + FStarC_Reflection_Types.name -> + (FStarC_Reflection_V1_Data.lb_view, unit) FStar_Tactics_Effect.tac_repr) = fun lbs -> fun nm -> @@ -442,8 +446,8 @@ let (lookup_lb_view : (fun uu___1 -> FStar_List_Tot_Base.find (fun lb -> - (FStar_Reflection_V1_Builtins.inspect_fv - (FStar_Reflection_V1_Builtins.inspect_lb lb).FStar_Reflection_V1_Data.lb_fv) + (FStarC_Reflection_V1_Builtins.inspect_fv + (FStarC_Reflection_V1_Builtins.inspect_lb lb).FStarC_Reflection_V1_Data.lb_fv) = nm) lbs)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -464,17 +468,17 @@ let (lookup_lb_view : (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___1 -> - FStar_Reflection_V1_Builtins.inspect_lb lb))) + FStarC_Reflection_V1_Builtins.inspect_lb lb))) | FStar_Pervasives_Native.None -> Obj.magic (Obj.repr (fail "lookup_lb_view: Name not in let group"))) uu___1) let rec (inspect_unascribe : - FStar_Reflection_Types.term -> - (FStar_Reflection_V1_Data.term_view, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> + (FStarC_Reflection_V1_Data.term_view, unit) FStar_Tactics_Effect.tac_repr) = fun t -> - let uu___ = FStar_Tactics_V1_Builtins.inspect t in + let uu___ = FStarC_Tactics_V1_Builtins.inspect t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -489,10 +493,10 @@ let rec (inspect_unascribe : (fun uu___1 -> (fun uu___1 -> match uu___1 with - | FStar_Reflection_V1_Data.Tv_AscribedT + | FStarC_Reflection_V1_Data.Tv_AscribedT (t1, uu___2, uu___3, uu___4) -> Obj.magic (Obj.repr (inspect_unascribe t1)) - | FStar_Reflection_V1_Data.Tv_AscribedC + | FStarC_Reflection_V1_Data.Tv_AscribedC (t1, uu___2, uu___3, uu___4) -> Obj.magic (Obj.repr (inspect_unascribe t1)) | tv -> @@ -501,9 +505,9 @@ let rec (inspect_unascribe : (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> tv)))) uu___1) let rec (collect_app' : - FStar_Reflection_V1_Data.argv Prims.list -> - FStar_Reflection_Types.term -> - ((FStar_Reflection_Types.term * FStar_Reflection_V1_Data.argv + FStarC_Reflection_V1_Data.argv Prims.list -> + FStarC_Reflection_Types.term -> + ((FStarC_Reflection_Types.term * FStarC_Reflection_V1_Data.argv Prims.list), unit) FStar_Tactics_Effect.tac_repr) = @@ -524,7 +528,7 @@ let rec (collect_app' : (fun uu___1 -> (fun uu___1 -> match uu___1 with - | FStar_Reflection_V1_Data.Tv_App (l, r) -> + | FStarC_Reflection_V1_Data.Tv_App (l, r) -> Obj.magic (Obj.repr (collect_app' (r :: args) l)) | uu___2 -> Obj.magic @@ -532,7 +536,8 @@ let rec (collect_app' : (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> (t, args))))) uu___1) let (collect_app : - FStar_Reflection_Types.term -> - ((FStar_Reflection_Types.term * FStar_Reflection_V1_Data.argv Prims.list), + FStarC_Reflection_Types.term -> + ((FStarC_Reflection_Types.term * FStarC_Reflection_V1_Data.argv + Prims.list), unit) FStar_Tactics_Effect.tac_repr) = collect_app' [] \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_V2_Basic.ml b/ocaml/fstar-lib/generated/FStar_Tactics_V2_Basic.ml deleted file mode 100644 index 4dcd70a1d8e..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Tactics_V2_Basic.ml +++ /dev/null @@ -1,13680 +0,0 @@ -open Prims -let (dbg_Tac : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Tac" -let (dbg_TacUnify : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "TacUnify" -let (dbg_2635 : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "2635" -let (dbg_ReflTc : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "ReflTc" -let (dbg_TacVerbose : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "TacVerbose" -let (compress : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term FStar_Tactics_Monad.tac) - = - fun uu___ -> - (fun t -> - let uu___ = - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.repr ()) in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - let uu___2 = FStar_Syntax_Subst.compress t in - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac - () (Obj.magic uu___2))) uu___1))) uu___ -let (core_check : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.typ -> - Prims.bool -> - (FStar_Syntax_Syntax.typ FStar_Pervasives_Native.option, - FStar_TypeChecker_Core.error) FStar_Pervasives.either) - = - fun env -> - fun sol -> - fun t -> - fun must_tot -> - let uu___ = - let uu___1 = FStar_Options.compat_pre_core_should_check () in - Prims.op_Negation uu___1 in - if uu___ - then FStar_Pervasives.Inl FStar_Pervasives_Native.None - else - (let debug f = - let uu___2 = FStar_Compiler_Debug.any () in - if uu___2 then f () else () in - let uu___2 = - FStar_TypeChecker_Core.check_term env sol t must_tot in - match uu___2 with - | FStar_Pervasives.Inl (FStar_Pervasives_Native.None) -> - FStar_Pervasives.Inl FStar_Pervasives_Native.None - | FStar_Pervasives.Inl (FStar_Pervasives_Native.Some g) -> - let uu___3 = FStar_Options.compat_pre_core_set () in - if uu___3 - then FStar_Pervasives.Inl FStar_Pervasives_Native.None - else FStar_Pervasives.Inl (FStar_Pervasives_Native.Some g) - | FStar_Pervasives.Inr err -> - (debug - (fun uu___4 -> - let uu___5 = - let uu___6 = FStar_TypeChecker_Env.get_range env in - FStar_Class_Show.show - FStar_Compiler_Range_Ops.showable_range uu___6 in - let uu___6 = - FStar_TypeChecker_Core.print_error_short err in - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term sol in - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - let uu___9 = FStar_TypeChecker_Core.print_error err in - FStar_Compiler_Util.print5 - "(%s) Core checking failed (%s) on term %s and type %s\n%s\n" - uu___5 uu___6 uu___7 uu___8 uu___9); - FStar_Pervasives.Inr err)) -type name = FStar_Syntax_Syntax.bv -type env = FStar_TypeChecker_Env.env -type implicits = FStar_TypeChecker_Env.implicits -let (rangeof : FStar_Tactics_Types.goal -> FStar_Compiler_Range_Type.range) = - fun g -> - (g.FStar_Tactics_Types.goal_ctx_uvar).FStar_Syntax_Syntax.ctx_uvar_range -let (normalize : - FStar_TypeChecker_Env.steps -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = fun s -> fun e -> fun t -> FStar_TypeChecker_Normalize.normalize s e t -let (bnorm : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = fun e -> fun t -> normalize [] e t -let (whnf : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = fun e -> fun t -> FStar_TypeChecker_Normalize.unfold_whnf e t -let (tts : - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.term -> Prims.string) = - FStar_TypeChecker_Normalize.term_to_string -let (ttd : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Pprint.document) - = FStar_TypeChecker_Normalize.term_to_doc -let (bnorm_goal : FStar_Tactics_Types.goal -> FStar_Tactics_Types.goal) = - fun g -> - let uu___ = - let uu___1 = FStar_Tactics_Types.goal_env g in - let uu___2 = FStar_Tactics_Types.goal_type g in bnorm uu___1 uu___2 in - FStar_Tactics_Monad.goal_with_type g uu___ -let (tacprint : Prims.string -> unit) = - fun s -> FStar_Compiler_Util.print1 "TAC>> %s\n" s -let (tacprint1 : Prims.string -> Prims.string -> unit) = - fun s -> - fun x -> - let uu___ = FStar_Compiler_Util.format1 s x in - FStar_Compiler_Util.print1 "TAC>> %s\n" uu___ -let (tacprint2 : Prims.string -> Prims.string -> Prims.string -> unit) = - fun s -> - fun x -> - fun y -> - let uu___ = FStar_Compiler_Util.format2 s x y in - FStar_Compiler_Util.print1 "TAC>> %s\n" uu___ -let (tacprint3 : - Prims.string -> Prims.string -> Prims.string -> Prims.string -> unit) = - fun s -> - fun x -> - fun y -> - fun z -> - let uu___ = FStar_Compiler_Util.format3 s x y z in - FStar_Compiler_Util.print1 "TAC>> %s\n" uu___ -let (print : Prims.string -> unit FStar_Tactics_Monad.tac) = - fun msg -> - (let uu___1 = - let uu___2 = FStar_Options.silent () in Prims.op_Negation uu___2 in - if uu___1 then tacprint msg else ()); - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () (Obj.repr ()) -let (debugging : unit -> Prims.bool FStar_Tactics_Monad.tac) = - fun uu___ -> - (fun uu___ -> - let uu___1 = - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.repr ()) in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___1 - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - let uu___3 = FStar_Compiler_Effect.op_Bang dbg_Tac in - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac - () (Obj.magic uu___3))) uu___2))) uu___ -let (ide : unit -> Prims.bool FStar_Tactics_Monad.tac) = - fun uu___ -> - (fun uu___ -> - let uu___1 = - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.repr ()) in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___1 - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - let uu___3 = FStar_Options.ide () in - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac - () (Obj.magic uu___3))) uu___2))) uu___ -let (do_dump_ps : Prims.string -> FStar_Tactics_Types.proofstate -> unit) = - fun msg -> - fun ps -> - let psc = ps.FStar_Tactics_Types.psc in - let subst = FStar_TypeChecker_Primops_Base.psc_subst psc in - FStar_Tactics_Printing.do_dump_proofstate ps msg -let (dump : Prims.string -> unit FStar_Tactics_Monad.tac) = - fun msg -> - FStar_Tactics_Monad.mk_tac - (fun ps -> do_dump_ps msg ps; FStar_Tactics_Result.Success ((), ps)) -let (dump_all : Prims.bool -> Prims.string -> unit FStar_Tactics_Monad.tac) = - fun print_resolved -> - fun msg -> - FStar_Tactics_Monad.mk_tac - (fun ps -> - let gs = - FStar_Compiler_List.map - (fun i -> - FStar_Tactics_Types.goal_of_implicit - ps.FStar_Tactics_Types.main_context i) - ps.FStar_Tactics_Types.all_implicits in - let gs1 = - if print_resolved - then gs - else - FStar_Compiler_List.filter - (fun g -> - let uu___1 = FStar_Tactics_Types.check_goal_solved g in - Prims.op_Negation uu___1) gs in - let ps' = - { - FStar_Tactics_Types.main_context = - (ps.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits = - (ps.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = gs1; - FStar_Tactics_Types.smt_goals = []; - FStar_Tactics_Types.depth = (ps.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = (ps.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = (ps.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (ps.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = - (ps.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness = - (ps.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg = - (ps.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = - (ps.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency = (ps.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure = - (ps.FStar_Tactics_Types.dump_on_failure) - } in - do_dump_ps msg ps'; FStar_Tactics_Result.Success ((), ps)) -let (dump_uvars_of : - FStar_Tactics_Types.goal -> Prims.string -> unit FStar_Tactics_Monad.tac) = - fun g -> - fun msg -> - FStar_Tactics_Monad.mk_tac - (fun ps -> - let uvs = - let uu___ = - let uu___1 = FStar_Tactics_Types.goal_type g in - FStar_Syntax_Free.uvars uu___1 in - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) (Obj.magic uu___) in - let gs = - FStar_Compiler_List.map (FStar_Tactics_Types.goal_of_ctx_uvar g) - uvs in - let gs1 = - FStar_Compiler_List.filter - (fun g1 -> - let uu___ = FStar_Tactics_Types.check_goal_solved g1 in - Prims.op_Negation uu___) gs in - let ps' = - { - FStar_Tactics_Types.main_context = - (ps.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits = - (ps.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = gs1; - FStar_Tactics_Types.smt_goals = []; - FStar_Tactics_Types.depth = (ps.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = (ps.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = (ps.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (ps.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = - (ps.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness = - (ps.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg = - (ps.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = - (ps.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency = (ps.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure = - (ps.FStar_Tactics_Types.dump_on_failure) - } in - do_dump_ps msg ps'; FStar_Tactics_Result.Success ((), ps)) -let fail1 : - 'uuuuu . Prims.string -> Prims.string -> 'uuuuu FStar_Tactics_Monad.tac = - fun msg -> - fun x -> - let uu___ = FStar_Compiler_Util.format1 msg x in - FStar_Tactics_Monad.fail uu___ -let fail2 : - 'uuuuu . - Prims.string -> - Prims.string -> Prims.string -> 'uuuuu FStar_Tactics_Monad.tac - = - fun msg -> - fun x -> - fun y -> - let uu___ = FStar_Compiler_Util.format2 msg x y in - FStar_Tactics_Monad.fail uu___ -let fail3 : - 'uuuuu . - Prims.string -> - Prims.string -> - Prims.string -> Prims.string -> 'uuuuu FStar_Tactics_Monad.tac - = - fun msg -> - fun x -> - fun y -> - fun z -> - let uu___ = FStar_Compiler_Util.format3 msg x y z in - FStar_Tactics_Monad.fail uu___ -let fail4 : - 'uuuuu . - Prims.string -> - Prims.string -> - Prims.string -> - Prims.string -> Prims.string -> 'uuuuu FStar_Tactics_Monad.tac - = - fun msg -> - fun x -> - fun y -> - fun z -> - fun w -> - let uu___ = FStar_Compiler_Util.format4 msg x y z w in - FStar_Tactics_Monad.fail uu___ -let (destruct_eq' : - FStar_Syntax_Syntax.typ -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.term) - FStar_Pervasives_Native.option) - = - fun typ -> - let uu___ = FStar_Syntax_Formula.destruct_typ_as_formula typ in - match uu___ with - | FStar_Pervasives_Native.Some (FStar_Syntax_Formula.BaseConn - (l, - uu___1::(e1, FStar_Pervasives_Native.None)::(e2, - FStar_Pervasives_Native.None)::[])) - when - (FStar_Ident.lid_equals l FStar_Parser_Const.eq2_lid) || - (FStar_Ident.lid_equals l FStar_Parser_Const.c_eq2_lid) - -> FStar_Pervasives_Native.Some (e1, e2) - | uu___1 -> - let uu___2 = FStar_Syntax_Util.unb2t typ in - (match uu___2 with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some t -> - let uu___3 = FStar_Syntax_Util.head_and_args t in - (match uu___3 with - | (hd, args) -> - let uu___4 = - let uu___5 = - let uu___6 = FStar_Syntax_Subst.compress hd in - uu___6.FStar_Syntax_Syntax.n in - (uu___5, args) in - (match uu___4 with - | (FStar_Syntax_Syntax.Tm_fvar fv, - (uu___5, FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = uu___6;_}):: - (e1, FStar_Pervasives_Native.None)::(e2, - FStar_Pervasives_Native.None)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.op_Eq - -> FStar_Pervasives_Native.Some (e1, e2) - | uu___5 -> FStar_Pervasives_Native.None))) -let (destruct_eq : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.term) - FStar_Pervasives_Native.option) - = - fun env1 -> - fun typ -> - let uu___ = destruct_eq' typ in - match uu___ with - | FStar_Pervasives_Native.Some t -> FStar_Pervasives_Native.Some t - | FStar_Pervasives_Native.None -> - let uu___1 = FStar_Syntax_Util.un_squash typ in - (match uu___1 with - | FStar_Pervasives_Native.Some typ1 -> destruct_eq' typ1 - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None) -let (get_guard_policy : - unit -> FStar_Tactics_Types.guard_policy FStar_Tactics_Monad.tac) = - fun uu___ -> - (fun uu___ -> - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.get) - (fun uu___1 -> - (fun ps -> - let ps = Obj.magic ps in - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac - () (Obj.magic ps.FStar_Tactics_Types.guard_policy))) - uu___1))) uu___ -let (set_guard_policy : - FStar_Tactics_Types.guard_policy -> unit FStar_Tactics_Monad.tac) = - fun pol -> - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.get) - (fun uu___ -> - (fun ps -> - let ps = Obj.magic ps in - Obj.magic - (FStar_Tactics_Monad.set - { - FStar_Tactics_Types.main_context = - (ps.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits = - (ps.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = (ps.FStar_Tactics_Types.goals); - FStar_Tactics_Types.smt_goals = - (ps.FStar_Tactics_Types.smt_goals); - FStar_Tactics_Types.depth = (ps.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = - (ps.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = (ps.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (ps.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = pol; - FStar_Tactics_Types.freshness = - (ps.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg = - (ps.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = - (ps.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency = - (ps.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure = - (ps.FStar_Tactics_Types.dump_on_failure) - })) uu___) -let with_policy : - 'a . - FStar_Tactics_Types.guard_policy -> - 'a FStar_Tactics_Monad.tac -> 'a FStar_Tactics_Monad.tac - = - fun uu___1 -> - fun uu___ -> - (fun pol -> - fun t -> - let uu___ = get_guard_policy () in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - () (Obj.magic uu___) - (fun uu___1 -> - (fun old_pol -> - let old_pol = Obj.magic old_pol in - let uu___1 = set_guard_policy pol in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () uu___1 - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic t) - (fun uu___3 -> - (fun r -> - let r = Obj.magic r in - let uu___3 = - set_guard_policy old_pol in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___3 - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = - Obj.magic uu___4 in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () (Obj.magic r))) - uu___4))) uu___3))) - uu___2))) uu___1))) uu___1 uu___ -let (proc_guard_formula : - Prims.string -> - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.should_check_uvar FStar_Pervasives_Native.option - -> FStar_Compiler_Range_Type.range -> unit FStar_Tactics_Monad.tac) - = - fun reason -> - fun e -> - fun f -> - fun sc_opt -> - fun rng -> - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.get) - (fun uu___ -> - (fun ps -> - let ps = Obj.magic ps in - match ps.FStar_Tactics_Types.guard_policy with - | FStar_Tactics_Types.Drop -> - ((let uu___1 = - let uu___2 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term f in - FStar_Compiler_Util.format1 - "Tactics admitted guard <%s>\n\n" uu___2 in - FStar_Errors.log_issue - FStar_TypeChecker_Env.hasRange_env e - FStar_Errors_Codes.Warning_TacAdmit () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1)); - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () (Obj.repr ()))) - | FStar_Tactics_Types.Goal -> - let uu___ = - FStar_Tactics_Monad.log - (fun uu___1 -> - let uu___2 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term f in - FStar_Compiler_Util.print2 - "Making guard (%s:%s) into a goal\n" reason - uu___2) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - let uu___2 = - FStar_Tactics_Monad.goal_of_guard reason - e f sc_opt rng in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___2) - (fun uu___3 -> - (fun g -> - let g = Obj.magic g in - Obj.magic - (FStar_Tactics_Monad.push_goals - [g])) uu___3))) uu___1)) - | FStar_Tactics_Types.SMT -> - let uu___ = - FStar_Tactics_Monad.log - (fun uu___1 -> - let uu___2 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term f in - FStar_Compiler_Util.print2 - "Pushing guard (%s:%s) as SMT goal\n" reason - uu___2) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - let uu___2 = - FStar_Tactics_Monad.goal_of_guard reason - e f sc_opt rng in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___2) - (fun uu___3 -> - (fun g -> - let g = Obj.magic g in - Obj.magic - (FStar_Tactics_Monad.push_smt_goals - [g])) uu___3))) uu___1)) - | FStar_Tactics_Types.SMTSync -> - let uu___ = - FStar_Tactics_Monad.log - (fun uu___1 -> - let uu___2 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term f in - FStar_Compiler_Util.print2 - "Sending guard (%s:%s) to SMT Synchronously\n" - reason uu___2) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - let g = - { - FStar_TypeChecker_Common.guard_f = - (FStar_TypeChecker_Common.NonTrivial - f); - FStar_TypeChecker_Common.deferred_to_tac - = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.implicits) - } in - FStar_TypeChecker_Rel.force_trivial_guard - e g; - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.repr ()))) uu___1)) - | FStar_Tactics_Types.Force -> - let uu___ = - FStar_Tactics_Monad.log - (fun uu___1 -> - let uu___2 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term f in - FStar_Compiler_Util.print2 - "Forcing guard (%s:%s)\n" reason uu___2) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - let g = - { - FStar_TypeChecker_Common.guard_f = - (FStar_TypeChecker_Common.NonTrivial - f); - FStar_TypeChecker_Common.deferred_to_tac - = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.implicits) - } in - Obj.magic - (try - (fun uu___2 -> - match () with - | () -> - let uu___3 = - let uu___4 = - let uu___5 = - FStar_TypeChecker_Rel.discharge_guard_no_smt - e g in - FStar_TypeChecker_Env.is_trivial - uu___5 in - Prims.op_Negation uu___4 in - if uu___3 - then - fail1 - "Forcing the guard failed (%s)" - reason - else - FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () (Obj.repr ())) () - with - | uu___2 -> - let uu___3 = - FStar_Tactics_Monad.log - (fun uu___4 -> - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - f in - FStar_Compiler_Util.print1 - "guard = %s\n" uu___5) in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () - () uu___3 - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = - Obj.magic uu___4 in - Obj.magic - (fail1 - "Forcing the guard failed (%s)" - reason)) uu___4))) - uu___1)) - | FStar_Tactics_Types.ForceSMT -> - let uu___ = - FStar_Tactics_Monad.log - (fun uu___1 -> - let uu___2 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term f in - FStar_Compiler_Util.print2 - "Forcing guard WITH SMT (%s:%s)\n" reason - uu___2) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - let g = - { - FStar_TypeChecker_Common.guard_f = - (FStar_TypeChecker_Common.NonTrivial - f); - FStar_TypeChecker_Common.deferred_to_tac - = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.implicits) - } in - Obj.magic - (try - (fun uu___2 -> - match () with - | () -> - let uu___3 = - let uu___4 = - let uu___5 = - FStar_TypeChecker_Rel.discharge_guard - e g in - FStar_TypeChecker_Env.is_trivial - uu___5 in - Prims.op_Negation uu___4 in - if uu___3 - then - fail1 - "Forcing the guard failed (%s)" - reason - else - FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () (Obj.repr ())) () - with - | uu___2 -> - let uu___3 = - FStar_Tactics_Monad.log - (fun uu___4 -> - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - f in - FStar_Compiler_Util.print1 - "guard = %s\n" uu___5) in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () - () uu___3 - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = - Obj.magic uu___4 in - Obj.magic - (fail1 - "Forcing the guard failed (%s)" - reason)) uu___4))) - uu___1))) uu___) -let (proc_guard' : - Prims.bool -> - Prims.string -> - env -> - FStar_TypeChecker_Common.guard_t -> - FStar_Syntax_Syntax.should_check_uvar - FStar_Pervasives_Native.option -> - FStar_Compiler_Range_Type.range -> unit FStar_Tactics_Monad.tac) - = - fun simplify -> - fun reason -> - fun e -> - fun g -> - fun sc_opt -> - fun rng -> - let uu___ = - FStar_Tactics_Monad.log - (fun uu___1 -> - let uu___2 = FStar_TypeChecker_Rel.guard_to_string e g in - FStar_Compiler_Util.print2 "Processing guard (%s:%s)\n" - reason uu___2) in - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - () uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - let imps = - FStar_Class_Listlike.to_list - (FStar_Compiler_CList.listlike_clist ()) - g.FStar_TypeChecker_Common.implicits in - (match sc_opt with - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Allow_untyped r) -> - FStar_Compiler_List.iter - (fun imp -> - FStar_Tactics_Monad.mark_uvar_with_should_check_tag - imp.FStar_TypeChecker_Common.imp_uvar - (FStar_Syntax_Syntax.Allow_untyped r)) imps - | uu___3 -> ()); - (let uu___3 = FStar_Tactics_Monad.add_implicits imps in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () uu___3 - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - let guard_f = - if simplify - then - let uu___5 = - FStar_TypeChecker_Rel.simplify_guard - e g in - uu___5.FStar_TypeChecker_Common.guard_f - else g.FStar_TypeChecker_Common.guard_f in - match guard_f with - | FStar_TypeChecker_Common.Trivial -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.repr ())) - | FStar_TypeChecker_Common.NonTrivial f -> - Obj.magic - (proc_guard_formula reason e f sc_opt - rng)) uu___4)))) uu___1) -let (proc_guard : - Prims.string -> - env -> - FStar_TypeChecker_Common.guard_t -> - FStar_Syntax_Syntax.should_check_uvar FStar_Pervasives_Native.option - -> FStar_Compiler_Range_Type.range -> unit FStar_Tactics_Monad.tac) - = proc_guard' true -let (tc_unifier_solved_implicits : - FStar_TypeChecker_Env.env -> - Prims.bool -> - Prims.bool -> - FStar_Syntax_Syntax.ctx_uvar Prims.list -> - unit FStar_Tactics_Monad.tac) - = - fun env1 -> - fun must_tot -> - fun allow_guards -> - fun uvs -> - let aux u = - let dec = - FStar_Syntax_Unionfind.find_decoration - u.FStar_Syntax_Syntax.ctx_uvar_head in - let sc = dec.FStar_Syntax_Syntax.uvar_decoration_should_check in - match sc with - | FStar_Syntax_Syntax.Allow_untyped uu___ -> - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.repr ()) - | FStar_Syntax_Syntax.Already_checked -> - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.repr ()) - | uu___ -> - let uu___1 = - FStar_Syntax_Unionfind.find - u.FStar_Syntax_Syntax.ctx_uvar_head in - (match uu___1 with - | FStar_Pervasives_Native.None -> - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac - () (Obj.repr ()) - | FStar_Pervasives_Native.Some sol -> - let env2 = - { - FStar_TypeChecker_Env.solver = - (env1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (u.FStar_Syntax_Syntax.ctx_uvar_gamma); - FStar_TypeChecker_Env.gamma_sig = - (env1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (env1.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env1.FStar_TypeChecker_Env.missing_decl) - } in - let must_tot1 = - must_tot && - (Prims.op_Negation - (FStar_Syntax_Syntax.uu___is_Allow_ghost - dec.FStar_Syntax_Syntax.uvar_decoration_should_check)) in - let uu___2 = - let uu___3 = FStar_Syntax_Util.ctx_uvar_typ u in - core_check env2 sol uu___3 must_tot1 in - (match uu___2 with - | FStar_Pervasives.Inl (FStar_Pervasives_Native.None) - -> - (FStar_Tactics_Monad.mark_uvar_as_already_checked u; - FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () (Obj.repr ())) - | FStar_Pervasives.Inl (FStar_Pervasives_Native.Some g) - -> - let guard = - { - FStar_TypeChecker_Common.guard_f = - (FStar_TypeChecker_Common.NonTrivial g); - FStar_TypeChecker_Common.deferred_to_tac = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.implicits) - } in - let guard1 = - FStar_TypeChecker_Rel.simplify_guard env2 guard in - let uu___3 = - ((FStar_Options.disallow_unification_guards ()) - && (Prims.op_Negation allow_guards)) - && - (FStar_TypeChecker_Common.uu___is_NonTrivial - guard1.FStar_TypeChecker_Common.guard_f) in - if uu___3 - then - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Errors_Msg.text - "Could not typecheck unifier solved implicit" in - let uu___7 = - let uu___8 = - FStar_Class_PP.pp - FStar_Syntax_Print.pretty_uvar - u.FStar_Syntax_Syntax.ctx_uvar_head in - let uu___9 = - let uu___10 = FStar_Errors_Msg.text "to" in - let uu___11 = - let uu___12 = - FStar_Class_PP.pp - FStar_Syntax_Print.pretty_term sol in - let uu___13 = - FStar_Errors_Msg.text - "since it produced a guard and guards were not allowed" in - FStar_Pprint.op_Hat_Slash_Hat uu___12 - uu___13 in - FStar_Pprint.op_Hat_Slash_Hat uu___10 - uu___11 in - FStar_Pprint.op_Hat_Slash_Hat uu___8 uu___9 in - FStar_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Errors_Msg.text "Guard =" in - let uu___9 = - FStar_Class_PP.pp - FStar_Syntax_Print.pretty_term g in - FStar_Pprint.op_Hat_Slash_Hat uu___8 uu___9 in - [uu___7] in - uu___5 :: uu___6 in - FStar_Tactics_Monad.fail_doc uu___4 - else - (let uu___5 = - proc_guard' false "guard for implicit" env2 - guard1 (FStar_Pervasives_Native.Some sc) - u.FStar_Syntax_Syntax.ctx_uvar_range in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () uu___5 - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = Obj.magic uu___6 in - FStar_Tactics_Monad.mark_uvar_as_already_checked - u; - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.repr ()))) uu___6)) - | FStar_Pervasives.Inr failed -> - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Errors_Msg.text - "Could not typecheck unifier solved implicit" in - let uu___6 = - let uu___7 = - FStar_Class_PP.pp - FStar_Syntax_Print.pretty_uvar - u.FStar_Syntax_Syntax.ctx_uvar_head in - let uu___8 = - let uu___9 = FStar_Errors_Msg.text "to" in - let uu___10 = - let uu___11 = - FStar_Class_PP.pp - FStar_Syntax_Print.pretty_term sol in - let uu___12 = - let uu___13 = - FStar_Errors_Msg.text "because" in - let uu___14 = - let uu___15 = - FStar_TypeChecker_Core.print_error - failed in - FStar_Pprint.doc_of_string uu___15 in - FStar_Pprint.op_Hat_Slash_Hat uu___13 - uu___14 in - FStar_Pprint.op_Hat_Slash_Hat uu___11 - uu___12 in - FStar_Pprint.op_Hat_Slash_Hat uu___9 - uu___10 in - FStar_Pprint.op_Hat_Slash_Hat uu___7 uu___8 in - FStar_Pprint.op_Hat_Slash_Hat uu___5 uu___6 in - [uu___4] in - FStar_Tactics_Monad.fail_doc uu___3)) in - if env1.FStar_TypeChecker_Env.phase1 - then - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.repr ()) - else FStar_Tactics_Monad.iter_tac aux uvs -type check_unifier_solved_implicits_side = - | Check_none - | Check_left_only - | Check_right_only - | Check_both -let (uu___is_Check_none : check_unifier_solved_implicits_side -> Prims.bool) - = - fun projectee -> match projectee with | Check_none -> true | uu___ -> false -let (uu___is_Check_left_only : - check_unifier_solved_implicits_side -> Prims.bool) = - fun projectee -> - match projectee with | Check_left_only -> true | uu___ -> false -let (uu___is_Check_right_only : - check_unifier_solved_implicits_side -> Prims.bool) = - fun projectee -> - match projectee with | Check_right_only -> true | uu___ -> false -let (uu___is_Check_both : check_unifier_solved_implicits_side -> Prims.bool) - = - fun projectee -> match projectee with | Check_both -> true | uu___ -> false -let (__do_unify_wflags : - Prims.bool -> - Prims.bool -> - Prims.bool -> - check_unifier_solved_implicits_side -> - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> - FStar_TypeChecker_Common.guard_t - FStar_Pervasives_Native.option FStar_Tactics_Monad.tac) - = - fun uu___6 -> - fun uu___5 -> - fun uu___4 -> - fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun dbg -> - fun allow_guards -> - fun must_tot -> - fun check_side -> - fun env1 -> - fun t1 -> - fun t2 -> - if dbg - then - (let uu___1 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t1 in - let uu___2 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t2 in - FStar_Compiler_Util.print2 - "%%%%%%%%do_unify %s =? %s\n" uu___1 - uu___2) - else (); - (let all_uvars = - let uu___1 = - match check_side with - | Check_none -> - Obj.magic - (Obj.repr - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) - ())) - | Check_left_only -> - Obj.magic - (Obj.repr - (FStar_Syntax_Free.uvars t1)) - | Check_right_only -> - Obj.magic - (Obj.repr - (FStar_Syntax_Free.uvars t2)) - | Check_both -> - Obj.magic - (Obj.repr - (let uu___2 = - FStar_Syntax_Free.uvars t1 in - let uu___3 = - FStar_Syntax_Free.uvars t2 in - FStar_Class_Setlike.union () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) - (Obj.magic uu___2) - (Obj.magic uu___3))) in - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) - (Obj.magic uu___1) in - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Tactics_Monad.trytac - FStar_Tactics_Monad.cur_goal in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___3) - (fun uu___4 -> - (fun gopt -> - let gopt = Obj.magic gopt in - Obj.magic - (try - (fun uu___4 -> - (fun uu___4 -> - match () with - | () -> - let res = - if - allow_guards - then - FStar_TypeChecker_Rel.try_teq - true env1 - t1 t2 - else - FStar_TypeChecker_Rel.teq_nosmt - env1 t1 - t2 in - (if dbg - then - (let uu___6 - = - FStar_Common.string_of_option - (FStar_TypeChecker_Rel.guard_to_string - env1) res in - let uu___7 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t1 in - let uu___8 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t2 in - FStar_Compiler_Util.print3 - "%%%%%%%%do_unify (RESULT %s) %s =? %s\n" - uu___6 - uu___7 - uu___8) - else (); - (match res - with - | FStar_Pervasives_Native.None - -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - FStar_Pervasives_Native.None)) - | FStar_Pervasives_Native.Some - g -> - let uu___6 - = - tc_unifier_solved_implicits - env1 - must_tot - allow_guards - all_uvars in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___6 - (fun - uu___7 -> - (fun - uu___7 -> - let uu___7 - = - Obj.magic - uu___7 in - let uu___8 - = - let uu___9 - = - FStar_Class_Listlike.to_list - (FStar_Compiler_CList.listlike_clist - ()) - g.FStar_TypeChecker_Common.implicits in - FStar_Tactics_Monad.add_implicits - uu___9 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___8 - (fun - uu___9 -> - (fun - uu___9 -> - let uu___9 - = - Obj.magic - uu___9 in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - (FStar_Pervasives_Native.Some - g)))) - uu___9))) - uu___7))))) - uu___4) () - with - | uu___4 -> - ((fun uu___4 -> - match uu___4 with - | FStar_Errors.Error - (uu___5, msg, - r, uu___6) - -> - let uu___7 = - FStar_Tactics_Monad.log - (fun uu___8 - -> - let uu___9 - = - FStar_Errors_Msg.rendermsg - msg in - let uu___10 - = - FStar_Class_Show.show - FStar_Compiler_Range_Ops.showable_range - r in - FStar_Compiler_Util.print2 - ">> do_unify error, (%s) at (%s)\n" - uu___9 - uu___10) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___7 - (fun - uu___8 -> - (fun - uu___8 -> - let uu___8 - = - Obj.magic - uu___8 in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - FStar_Pervasives_Native.None))) - uu___8)))) - uu___4)) uu___4)) in - FStar_Tactics_Monad.catch uu___2 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - match uu___2 with - | FStar_Pervasives.Inl exn -> - Obj.magic - (Obj.repr - (FStar_Tactics_Monad.traise - exn)) - | FStar_Pervasives.Inr v -> - Obj.magic - (Obj.repr - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () (Obj.magic v)))) - uu___2)))) uu___6 uu___5 uu___4 - uu___3 uu___2 uu___1 uu___ -let (__do_unify : - Prims.bool -> - Prims.bool -> - check_unifier_solved_implicits_side -> - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> - FStar_TypeChecker_Common.guard_t FStar_Pervasives_Native.option - FStar_Tactics_Monad.tac) - = - fun uu___5 -> - fun uu___4 -> - fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun allow_guards -> - fun must_tot -> - fun check_side -> - fun env1 -> - fun t1 -> - fun t2 -> - let uu___ = - FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () (Obj.repr ()) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - (let uu___3 = - FStar_Compiler_Effect.op_Bang - dbg_TacUnify in - if uu___3 - then - (FStar_Options.push (); - (let uu___5 = - FStar_Options.set_options - "--debug Rel,RelCheck" in - ())) - else ()); - (let uu___3 = - let uu___4 = - FStar_Compiler_Effect.op_Bang - dbg_TacUnify in - __do_unify_wflags uu___4 - allow_guards must_tot check_side - env1 t1 t2 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () - () (Obj.magic uu___3) - (fun uu___4 -> - (fun r -> - let r = Obj.magic r in - (let uu___5 = - FStar_Compiler_Effect.op_Bang - dbg_TacUnify in - if uu___5 - then FStar_Options.pop () - else ()); - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () (Obj.magic r))) - uu___4)))) uu___1))) uu___5 - uu___4 uu___3 uu___2 uu___1 uu___ -let (do_unify_aux : - Prims.bool -> - check_unifier_solved_implicits_side -> - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> Prims.bool FStar_Tactics_Monad.tac) - = - fun uu___4 -> - fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun must_tot -> - fun check_side -> - fun env1 -> - fun t1 -> - fun t2 -> - let uu___ = - __do_unify false must_tot check_side env1 t1 t2 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___) - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - match uu___1 with - | FStar_Pervasives_Native.None -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic false)) - | FStar_Pervasives_Native.Some g -> - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_Env.is_trivial_guard_formula - g in - Prims.op_Negation uu___4 in - if uu___3 - then - failwith - "internal error: do_unify: guard is not trivial" - else - FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.repr ()) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () - () uu___2 - (fun uu___3 -> - (fun uu___3 -> - let uu___3 = - Obj.magic uu___3 in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () (Obj.magic true))) - uu___3))) uu___1))) uu___4 - uu___3 uu___2 uu___1 uu___ -let (do_unify : - Prims.bool -> - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> Prims.bool FStar_Tactics_Monad.tac) - = - fun must_tot -> - fun env1 -> - fun t1 -> fun t2 -> do_unify_aux must_tot Check_both env1 t1 t2 -let (do_unify_maybe_guards : - Prims.bool -> - Prims.bool -> - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> - FStar_TypeChecker_Common.guard_t FStar_Pervasives_Native.option - FStar_Tactics_Monad.tac) - = - fun allow_guards -> - fun must_tot -> - fun env1 -> - fun t1 -> - fun t2 -> __do_unify allow_guards must_tot Check_both env1 t1 t2 -let (do_match : - Prims.bool -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> Prims.bool FStar_Tactics_Monad.tac) - = - fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun must_tot -> - fun env1 -> - fun t1 -> - fun t2 -> - let uu___ = - FStar_Tactics_Monad.mk_tac - (fun ps -> - let tx = FStar_Syntax_Unionfind.new_transaction () in - FStar_Tactics_Result.Success (tx, ps)) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () (Obj.magic uu___) - (fun uu___1 -> - (fun tx -> - let tx = Obj.magic tx in - let uvs1 = FStar_Syntax_Free.uvars_uncached t1 in - let uu___1 = - do_unify_aux must_tot Check_right_only env1 - t1 t2 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___1) - (fun uu___2 -> - (fun r -> - let r = Obj.magic r in - if r - then - let uvs2 = - FStar_Syntax_Free.uvars_uncached - t1 in - let uu___2 = - let uu___3 = - FStar_Class_Setlike.equal () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) - (Obj.magic uvs1) - (Obj.magic uvs2) in - Prims.op_Negation uu___3 in - (if uu___2 - then - (FStar_Syntax_Unionfind.rollback - tx; - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () (Obj.magic false))) - else - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () (Obj.magic true))) - else - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () (Obj.magic false))) uu___2))) - uu___1))) uu___3 uu___2 uu___1 uu___ -let (do_match_on_lhs : - Prims.bool -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> Prims.bool FStar_Tactics_Monad.tac) - = - fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun must_tot -> - fun env1 -> - fun t1 -> - fun t2 -> - let uu___ = - FStar_Tactics_Monad.mk_tac - (fun ps -> - let tx = FStar_Syntax_Unionfind.new_transaction () in - FStar_Tactics_Result.Success (tx, ps)) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () (Obj.magic uu___) - (fun uu___1 -> - (fun tx -> - let tx = Obj.magic tx in - let uu___1 = destruct_eq env1 t1 in - match uu___1 with - | FStar_Pervasives_Native.None -> - Obj.magic - (Obj.repr - (FStar_Tactics_Monad.fail - "do_match_on_lhs: not an eq")) - | FStar_Pervasives_Native.Some (lhs, uu___2) -> - Obj.magic - (Obj.repr - (let uvs1 = - FStar_Syntax_Free.uvars_uncached - lhs in - let uu___3 = - do_unify_aux must_tot - Check_right_only env1 t1 t2 in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___3) - (fun uu___4 -> - (fun r -> - let r = Obj.magic r in - if r - then - let uvs2 = - FStar_Syntax_Free.uvars_uncached - lhs in - let uu___4 = - let uu___5 = - FStar_Class_Setlike.equal - () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) - (Obj.magic uvs1) - (Obj.magic uvs2) in - Prims.op_Negation uu___5 in - (if uu___4 - then - (FStar_Syntax_Unionfind.rollback - tx; - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic false))) - else - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () (Obj.magic true))) - else - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () (Obj.magic false))) - uu___4)))) uu___1))) uu___3 - uu___2 uu___1 uu___ -let (set_solution : - FStar_Tactics_Types.goal -> - FStar_Syntax_Syntax.term -> unit FStar_Tactics_Monad.tac) - = - fun goal -> - fun solution -> - let uu___ = - FStar_Syntax_Unionfind.find - (goal.FStar_Tactics_Types.goal_ctx_uvar).FStar_Syntax_Syntax.ctx_uvar_head in - match uu___ with - | FStar_Pervasives_Native.Some uu___1 -> - let uu___2 = - let uu___3 = FStar_Tactics_Printing.goal_to_string_verbose goal in - FStar_Compiler_Util.format1 "Goal %s is already solved" uu___3 in - FStar_Tactics_Monad.fail uu___2 - | FStar_Pervasives_Native.None -> - (FStar_Syntax_Unionfind.change - (goal.FStar_Tactics_Types.goal_ctx_uvar).FStar_Syntax_Syntax.ctx_uvar_head - solution; - FStar_Tactics_Monad.mark_goal_implicit_already_checked goal; - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.repr ())) -let (trysolve : - FStar_Tactics_Types.goal -> - FStar_Syntax_Syntax.term -> Prims.bool FStar_Tactics_Monad.tac) - = - fun goal -> - fun solution -> - let must_tot = true in - let uu___ = FStar_Tactics_Types.goal_env goal in - let uu___1 = FStar_Tactics_Types.goal_witness goal in - do_unify must_tot uu___ solution uu___1 -let (solve : - FStar_Tactics_Types.goal -> - FStar_Syntax_Syntax.term -> unit FStar_Tactics_Monad.tac) - = - fun goal -> - fun solution -> - let e = FStar_Tactics_Types.goal_env goal in - let uu___ = - FStar_Tactics_Monad.log - (fun uu___1 -> - let uu___2 = - let uu___3 = FStar_Tactics_Types.goal_witness goal in - FStar_Class_Show.show FStar_Syntax_Print.showable_term uu___3 in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - solution in - FStar_Compiler_Util.print2 "solve %s := %s\n" uu___2 uu___3) in - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - let uu___2 = trysolve goal solution in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac - () () (Obj.magic uu___2) - (fun uu___3 -> - (fun b -> - let b = Obj.magic b in - if b - then - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - FStar_Tactics_Monad.dismiss - (fun uu___3 -> - (fun uu___3 -> - let uu___3 = Obj.magic uu___3 in - Obj.magic - FStar_Tactics_Monad.remove_solved_goals) - uu___3)) - else - (let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Tactics_Types.goal_env goal in - ttd uu___7 solution in - let uu___7 = - let uu___8 = - FStar_Errors_Msg.text "does not solve" in - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Tactics_Types.goal_env goal in - let uu___12 = - FStar_Tactics_Types.goal_witness goal in - ttd uu___11 uu___12 in - let uu___11 = - let uu___12 = FStar_Errors_Msg.text ":" in - let uu___13 = - let uu___14 = - FStar_Tactics_Types.goal_env goal in - let uu___15 = - FStar_Tactics_Types.goal_type goal in - ttd uu___14 uu___15 in - FStar_Pprint.op_Hat_Slash_Hat uu___12 - uu___13 in - FStar_Pprint.op_Hat_Slash_Hat uu___10 - uu___11 in - FStar_Pprint.op_Hat_Slash_Hat uu___8 uu___9 in - FStar_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in - [uu___5] in - Obj.magic (FStar_Tactics_Monad.fail_doc uu___4))) - uu___3))) uu___1) -let (solve' : - FStar_Tactics_Types.goal -> - FStar_Syntax_Syntax.term -> unit FStar_Tactics_Monad.tac) - = - fun goal -> - fun solution -> - let uu___ = set_solution goal solution in - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac - () () FStar_Tactics_Monad.dismiss - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - Obj.magic FStar_Tactics_Monad.remove_solved_goals) - uu___2))) uu___1) -let (is_true : FStar_Syntax_Syntax.term -> Prims.bool) = - fun t -> - let t1 = FStar_Syntax_Util.unascribe t in - let uu___ = FStar_Syntax_Util.un_squash t1 in - match uu___ with - | FStar_Pervasives_Native.Some t' -> - let t'1 = FStar_Syntax_Util.unascribe t' in - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress t'1 in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.true_lid - | uu___2 -> false) - | uu___1 -> false -let (is_false : FStar_Syntax_Syntax.term -> Prims.bool) = - fun t -> - let uu___ = FStar_Syntax_Util.un_squash t in - match uu___ with - | FStar_Pervasives_Native.Some t' -> - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress t' in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.false_lid - | uu___2 -> false) - | uu___1 -> false -let meas : - 'a . - Prims.string -> 'a FStar_Tactics_Monad.tac -> 'a FStar_Tactics_Monad.tac - = - fun s -> - fun f -> - FStar_Tactics_Monad.mk_tac - (fun ps -> - let uu___ = - FStar_Compiler_Util.record_time - (fun uu___1 -> FStar_Tactics_Monad.run f ps) in - match uu___ with - | (r, ms) -> - ((let uu___2 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) ms in - FStar_Compiler_Util.print2 "++ Tactic %s ran in \t\t%sms\n" - s uu___2); - r)) -let (tadmit_t : FStar_Syntax_Syntax.term -> unit FStar_Tactics_Monad.tac) = - fun t -> - let uu___ = - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.get) - (fun uu___1 -> - (fun ps -> - let ps = Obj.magic ps in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac - () () (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___1 -> - (fun g -> - let g = Obj.magic g in - (let uu___2 = - let uu___3 = FStar_Tactics_Types.goal_type g in - FStar_Class_HasRange.pos - (FStar_Syntax_Syntax.has_range_syntax ()) - uu___3 in - let uu___3 = - let uu___4 = - FStar_Errors_Msg.text "Tactics admitted goal." in - let uu___5 = - let uu___6 = - let uu___7 = FStar_Errors_Msg.text "Goal" in - let uu___8 = - let uu___9 = - FStar_Tactics_Printing.goal_to_string "" - FStar_Pervasives_Native.None ps g in - FStar_Pprint.arbitrary_string uu___9 in - FStar_Pprint.prefix (Prims.of_int (2)) - Prims.int_one uu___7 uu___8 in - [uu___6] in - uu___4 :: uu___5 in - FStar_Errors.log_issue - FStar_Class_HasRange.hasRange_range uu___2 - FStar_Errors_Codes.Warning_TacAdmit () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___3)); - Obj.magic (solve' g t)) uu___1))) uu___1) in - FStar_Tactics_Monad.wrap_err "tadmit_t" uu___ -let (fresh : unit -> FStar_BigInt.t FStar_Tactics_Monad.tac) = - fun uu___ -> - (fun uu___ -> - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.get) - (fun uu___1 -> - (fun ps -> - let ps = Obj.magic ps in - let n = ps.FStar_Tactics_Types.freshness in - let ps1 = - { - FStar_Tactics_Types.main_context = - (ps.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits = - (ps.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = - (ps.FStar_Tactics_Types.goals); - FStar_Tactics_Types.smt_goals = - (ps.FStar_Tactics_Types.smt_goals); - FStar_Tactics_Types.depth = - (ps.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = - (ps.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = (ps.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (ps.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = - (ps.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness = (n + Prims.int_one); - FStar_Tactics_Types.tac_verb_dbg = - (ps.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = - (ps.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency = - (ps.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure = - (ps.FStar_Tactics_Types.dump_on_failure) - } in - let uu___1 = FStar_Tactics_Monad.set ps1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () uu___1 - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - let uu___3 = FStar_BigInt.of_int_fs n in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic uu___3))) uu___2))) uu___1))) - uu___ -let (curms : unit -> FStar_BigInt.t FStar_Tactics_Monad.tac) = - fun uu___ -> - (fun uu___ -> - let uu___1 = - let uu___2 = FStar_Compiler_Util.now_ms () in - FStar_BigInt.of_int_fs uu___2 in - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.magic uu___1))) uu___ -let (__tc : - env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.typ * - FStar_TypeChecker_Common.guard_t) FStar_Tactics_Monad.tac) - = - fun uu___1 -> - fun uu___ -> - (fun e -> - fun t -> - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - () (Obj.magic FStar_Tactics_Monad.get) - (fun uu___ -> - (fun ps -> - let ps = Obj.magic ps in - let uu___ = - FStar_Tactics_Monad.log - (fun uu___1 -> - let uu___2 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.print1 "Tac> __tc(%s)\n" - uu___2) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - Obj.magic - (try - (fun uu___2 -> - (fun uu___2 -> - match () with - | () -> - let uu___3 = - FStar_TypeChecker_TcTerm.typeof_tot_or_gtot_term - e t true in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () (Obj.magic uu___3))) - uu___2) () - with - | FStar_Errors.Error - (uu___3, msg, uu___4, uu___5) -> - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Errors_Msg.text - "Cannot type" in - let uu___11 = ttd e t in - FStar_Pprint.prefix - (Prims.of_int (2)) - Prims.int_one uu___10 - uu___11 in - let uu___10 = - let uu___11 = - FStar_Errors_Msg.text - "in context" in - let uu___12 = - let uu___13 = - FStar_TypeChecker_Env.all_binders - e in - FStar_Class_PP.pp - (FStar_Class_PP.pp_list - FStar_Syntax_Print.pretty_binder) - uu___13 in - FStar_Pprint.prefix - (Prims.of_int (2)) - Prims.int_one uu___11 - uu___12 in - FStar_Pprint.op_Hat_Slash_Hat - uu___9 uu___10 in - [uu___8] in - FStar_Compiler_List.op_At uu___7 - msg in - FStar_Tactics_Monad.fail_doc uu___6)) - uu___1))) uu___))) uu___1 uu___ -let (__tc_ghost : - env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.typ * - FStar_TypeChecker_Common.guard_t) FStar_Tactics_Monad.tac) - = - fun uu___1 -> - fun uu___ -> - (fun e -> - fun t -> - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - () (Obj.magic FStar_Tactics_Monad.get) - (fun uu___ -> - (fun ps -> - let ps = Obj.magic ps in - let uu___ = - FStar_Tactics_Monad.log - (fun uu___1 -> - let uu___2 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.print1 - "Tac> __tc_ghost(%s)\n" uu___2) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - let e1 = - { - FStar_TypeChecker_Env.solver = - (e.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (e.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (e.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (e.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (e.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (e.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (e.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (e.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (e.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (e.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (e.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (e.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (e.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = []; - FStar_TypeChecker_Env.top_level = - (e.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (e.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (e.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (e.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (e.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (e.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (e.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (e.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (e.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (e.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (e.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (e.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (e.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (e.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (e.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (e.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (e.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (e.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (e.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (e.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (e.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (e.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (e.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (e.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (e.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (e.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (e.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (e.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (e.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (e.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (e.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (e.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (e.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (e.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (e.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (e.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (e.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (e.FStar_TypeChecker_Env.missing_decl) - } in - Obj.magic - (try - (fun uu___2 -> - (fun uu___2 -> - match () with - | () -> - let uu___3 = - FStar_TypeChecker_TcTerm.tc_tot_or_gtot_term - e1 t in - (match uu___3 with - | (t1, lc, g) -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - (t1, - (lc.FStar_TypeChecker_Common.res_typ), - g))))) uu___2) - () - with - | FStar_Errors.Error - (uu___3, msg, uu___4, uu___5) -> - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Errors_Msg.text - "Cannot type" in - let uu___11 = ttd e1 t in - FStar_Pprint.prefix - (Prims.of_int (2)) - Prims.int_one uu___10 - uu___11 in - let uu___10 = - let uu___11 = - FStar_Errors_Msg.text - "in context" in - let uu___12 = - let uu___13 = - FStar_TypeChecker_Env.all_binders - e1 in - FStar_Class_PP.pp - (FStar_Class_PP.pp_list - FStar_Syntax_Print.pretty_binder) - uu___13 in - FStar_Pprint.prefix - (Prims.of_int (2)) - Prims.int_one uu___11 - uu___12 in - FStar_Pprint.op_Hat_Slash_Hat - uu___9 uu___10 in - [uu___8] in - FStar_Compiler_List.op_At uu___7 - msg in - FStar_Tactics_Monad.fail_doc uu___6)) - uu___1))) uu___))) uu___1 uu___ -let (__tc_lax : - env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.lcomp * - FStar_TypeChecker_Common.guard_t) FStar_Tactics_Monad.tac) - = - fun uu___1 -> - fun uu___ -> - (fun e -> - fun t -> - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - () (Obj.magic FStar_Tactics_Monad.get) - (fun uu___ -> - (fun ps -> - let ps = Obj.magic ps in - let uu___ = - FStar_Tactics_Monad.log - (fun uu___1 -> - let uu___2 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - let uu___3 = - let uu___4 = - FStar_TypeChecker_Env.all_binders e in - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binder) - uu___4 in - FStar_Compiler_Util.print2 - "Tac> __tc_lax(%s)(Context:%s)\n" uu___2 - uu___3) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - let e1 = - { - FStar_TypeChecker_Env.solver = - (e.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (e.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (e.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (e.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (e.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (e.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (e.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (e.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (e.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (e.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (e.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (e.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (e.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (e.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (e.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (e.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (e.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (e.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = true; - FStar_TypeChecker_Env.lax_universes = - (e.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (e.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (e.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (e.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (e.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (e.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (e.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (e.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (e.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (e.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (e.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (e.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (e.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (e.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (e.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (e.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (e.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (e.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (e.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (e.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (e.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (e.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (e.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (e.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (e.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (e.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (e.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (e.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (e.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (e.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (e.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (e.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (e.FStar_TypeChecker_Env.missing_decl) - } in - let e2 = - { - FStar_TypeChecker_Env.solver = - (e1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (e1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (e1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (e1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (e1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (e1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (e1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (e1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (e1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (e1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (e1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (e1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (e1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = []; - FStar_TypeChecker_Env.top_level = - (e1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (e1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (e1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (e1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (e1.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (e1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (e1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (e1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (e1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (e1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (e1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (e1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (e1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (e1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (e1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (e1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (e1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (e1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (e1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (e1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (e1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (e1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (e1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (e1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (e1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (e1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (e1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (e1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (e1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (e1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (e1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (e1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (e1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (e1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (e1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (e1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (e1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (e1.FStar_TypeChecker_Env.missing_decl) - } in - Obj.magic - (try - (fun uu___2 -> - (fun uu___2 -> - match () with - | () -> - let uu___3 = - FStar_TypeChecker_TcTerm.tc_term - e2 t in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () (Obj.magic uu___3))) - uu___2) () - with - | FStar_Errors.Error - (uu___3, msg, uu___4, uu___5) -> - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Errors_Msg.text - "Cannot type" in - let uu___11 = ttd e2 t in - FStar_Pprint.prefix - (Prims.of_int (2)) - Prims.int_one uu___10 - uu___11 in - let uu___10 = - let uu___11 = - FStar_Errors_Msg.text - "in context" in - let uu___12 = - let uu___13 = - FStar_TypeChecker_Env.all_binders - e2 in - FStar_Class_PP.pp - (FStar_Class_PP.pp_list - FStar_Syntax_Print.pretty_binder) - uu___13 in - FStar_Pprint.prefix - (Prims.of_int (2)) - Prims.int_one uu___11 - uu___12 in - FStar_Pprint.op_Hat_Slash_Hat - uu___9 uu___10 in - [uu___8] in - FStar_Compiler_List.op_At uu___7 - msg in - FStar_Tactics_Monad.fail_doc uu___6)) - uu___1))) uu___))) uu___1 uu___ -let (tcc : - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.comp FStar_Tactics_Monad.tac) - = - fun e -> - fun t -> - let uu___ = - let uu___1 = __tc_lax e t in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - match uu___2 with - | (uu___3, lc, uu___4) -> - let uu___5 = - let uu___6 = FStar_TypeChecker_Common.lcomp_comp lc in - FStar_Pervasives_Native.fst uu___6 in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic uu___5))) uu___2)) in - FStar_Tactics_Monad.wrap_err "tcc" uu___ -let (tc : - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.typ FStar_Tactics_Monad.tac) - = - fun e -> - fun t -> - let uu___ = - let uu___1 = tcc e t in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___1) - (fun uu___2 -> - (fun c -> - let c = Obj.magic c in - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac - () (Obj.magic (FStar_Syntax_Util.comp_result c)))) - uu___2)) in - FStar_Tactics_Monad.wrap_err "tc" uu___ -let rec map : - 'a . 'a FStar_Tactics_Monad.tac -> 'a Prims.list FStar_Tactics_Monad.tac = - fun uu___ -> - (fun tau -> - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.get) - (fun uu___ -> - (fun ps -> - let ps = Obj.magic ps in - match ps.FStar_Tactics_Types.goals with - | [] -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () (Obj.magic [])) - | uu___::uu___1 -> - let uu___2 = - let uu___3 = map tau in - FStar_Tactics_Monad.divide FStar_BigInt.one tau - uu___3 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___2) - (fun uu___3 -> - (fun uu___3 -> - let uu___3 = Obj.magic uu___3 in - match uu___3 with - | (h, t) -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic (h :: t)))) uu___3))) - uu___))) uu___ -let (seq : - unit FStar_Tactics_Monad.tac -> - unit FStar_Tactics_Monad.tac -> unit FStar_Tactics_Monad.tac) - = - fun t1 -> - fun t2 -> - let uu___ = - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () t1 - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - let uu___2 = map t2 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () (Obj.magic uu___2) - (fun uu___3 -> - (fun uu___3 -> - let uu___3 = Obj.magic uu___3 in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.repr ()))) uu___3))) uu___1) in - FStar_Tactics_Monad.focus uu___ -let (should_check_goal_uvar : - FStar_Tactics_Types.goal -> FStar_Syntax_Syntax.should_check_uvar) = - fun g -> - FStar_Syntax_Util.ctx_uvar_should_check - g.FStar_Tactics_Types.goal_ctx_uvar -let (bnorm_and_replace : - FStar_Tactics_Types.goal -> unit FStar_Tactics_Monad.tac) = - fun g -> let uu___ = bnorm_goal g in FStar_Tactics_Monad.replace_cur uu___ -let (bv_to_binding : - FStar_Syntax_Syntax.bv -> FStar_Reflection_V2_Data.binding) = - fun bv -> - let uu___ = FStar_BigInt.of_int_fs bv.FStar_Syntax_Syntax.index in - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Ident.showable_ident - bv.FStar_Syntax_Syntax.ppname in - FStar_Compiler_Sealed.seal uu___2 in - { - FStar_Reflection_V2_Data.uniq1 = uu___; - FStar_Reflection_V2_Data.sort3 = (bv.FStar_Syntax_Syntax.sort); - FStar_Reflection_V2_Data.ppname3 = uu___1 - } -let (binder_to_binding : - FStar_Syntax_Syntax.binder -> FStar_Reflection_V2_Data.binding) = - fun b -> bv_to_binding b.FStar_Syntax_Syntax.binder_bv -let (binding_to_string : FStar_Reflection_V2_Data.binding -> Prims.string) = - fun b -> - let uu___ = - let uu___1 = - let uu___2 = FStar_BigInt.to_int_fs b.FStar_Reflection_V2_Data.uniq1 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow FStar_Class_Printable.printable_int) - uu___2 in - Prims.strcat "#" uu___1 in - Prims.strcat - (FStar_Compiler_Sealed.unseal b.FStar_Reflection_V2_Data.ppname3) uu___ -let (binding_to_bv : - FStar_Reflection_V2_Data.binding -> FStar_Syntax_Syntax.bv) = - fun b -> - let uu___ = - FStar_Ident.mk_ident - ((FStar_Compiler_Sealed.unseal b.FStar_Reflection_V2_Data.ppname3), - FStar_Compiler_Range_Type.dummyRange) in - let uu___1 = FStar_BigInt.to_int_fs b.FStar_Reflection_V2_Data.uniq1 in - { - FStar_Syntax_Syntax.ppname = uu___; - FStar_Syntax_Syntax.index = uu___1; - FStar_Syntax_Syntax.sort = (b.FStar_Reflection_V2_Data.sort3) - } -let (binding_to_binder : - FStar_Reflection_V2_Data.binding -> FStar_Syntax_Syntax.binder) = - fun b -> let bv = binding_to_bv b in FStar_Syntax_Syntax.mk_binder bv -let (arrow_one : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - (FStar_TypeChecker_Env.env * FStar_Syntax_Syntax.binder * - FStar_Syntax_Syntax.comp) FStar_Pervasives_Native.option) - = - fun env1 -> - fun t -> - let uu___ = FStar_Syntax_Util.arrow_one_ln t in - match uu___ with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (b, c) -> - let uu___1 = FStar_TypeChecker_Core.open_binders_in_comp env1 [b] c in - (match uu___1 with - | (env2, b1::[], c1) -> - FStar_Pervasives_Native.Some (env2, b1, c1)) -let (arrow_one_whnf : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - (FStar_TypeChecker_Env.env * FStar_Syntax_Syntax.binder * - FStar_Syntax_Syntax.comp) FStar_Pervasives_Native.option) - = - fun env1 -> - fun t -> - let uu___ = arrow_one env1 t in - match uu___ with - | FStar_Pervasives_Native.Some r -> FStar_Pervasives_Native.Some r - | FStar_Pervasives_Native.None -> - let uu___1 = whnf env1 t in arrow_one env1 uu___1 -let (intro : - unit -> FStar_Reflection_V2_Data.binding FStar_Tactics_Monad.tac) = - fun uu___ -> - let uu___1 = - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___2 -> - (fun goal -> - let goal = Obj.magic goal in - let uu___2 = - let uu___3 = FStar_Tactics_Types.goal_env goal in - let uu___4 = FStar_Tactics_Types.goal_type goal in - arrow_one_whnf uu___3 uu___4 in - match uu___2 with - | FStar_Pervasives_Native.Some (uu___3, uu___4, c) when - let uu___5 = FStar_Syntax_Util.is_total_comp c in - Prims.op_Negation uu___5 -> - Obj.magic - (Obj.repr - (FStar_Tactics_Monad.fail "Codomain is effectful")) - | FStar_Pervasives_Native.Some (env', b, c) -> - Obj.magic - (Obj.repr - (let typ' = FStar_Syntax_Util.comp_result c in - let uu___3 = - let uu___4 = - let uu___5 = should_check_goal_uvar goal in - FStar_Pervasives_Native.Some uu___5 in - let uu___5 = - FStar_Tactics_Monad.goal_typedness_deps goal in - FStar_Tactics_Monad.new_uvar "intro" env' typ' - uu___4 uu___5 (rangeof goal) in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___3) - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - match uu___4 with - | (body, ctx_uvar) -> - let sol = - let uu___5 = - let uu___6 = - FStar_Syntax_Util.residual_comp_of_comp - c in - FStar_Pervasives_Native.Some - uu___6 in - FStar_Syntax_Util.abs [b] body - uu___5 in - let uu___5 = set_solution goal sol in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () - () uu___5 - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = - Obj.magic uu___6 in - let g = - FStar_Tactics_Types.mk_goal - env' ctx_uvar - goal.FStar_Tactics_Types.opts - goal.FStar_Tactics_Types.is_guard - goal.FStar_Tactics_Types.label in - let uu___7 = - FStar_Tactics_Monad.replace_cur - g in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___7 - (fun uu___8 -> - (fun uu___8 -> - let uu___8 = - Obj.magic - uu___8 in - let uu___9 = - binder_to_binding - b in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - uu___9))) - uu___8))) uu___6))) - uu___4))) - | FStar_Pervasives_Native.None -> - Obj.magic - (Obj.repr - (let uu___3 = - let uu___4 = FStar_Tactics_Types.goal_env goal in - let uu___5 = FStar_Tactics_Types.goal_type goal in - tts uu___4 uu___5 in - fail1 "goal is not an arrow (%s)" uu___3))) uu___2)) in - FStar_Tactics_Monad.wrap_err "intro" uu___1 -let (intros : - FStar_BigInt.t -> - FStar_Reflection_V2_Data.binding Prims.list FStar_Tactics_Monad.tac) - = - fun max -> - let uu___ = - let max1 = FStar_BigInt.to_int_fs max in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___1 -> - (fun goal -> - let goal = Obj.magic goal in - let uu___1 = - let uu___2 = FStar_Tactics_Types.goal_type goal in - FStar_Syntax_Util.arrow_formals_comp_ln uu___2 in - match uu___1 with - | (bs, c) -> - let uu___2 = - if max1 >= Prims.int_zero - then - let uu___3 = FStar_Compiler_List.splitAt max1 bs in - match uu___3 with - | (bs0, bs1) -> - let c1 = - let uu___4 = FStar_Syntax_Util.arrow_ln bs1 c in - FStar_Syntax_Syntax.mk_Total uu___4 in - (bs0, c1) - else (bs, c) in - (match uu___2 with - | (bs1, c1) -> - let uu___3 = - let uu___4 = FStar_Tactics_Types.goal_env goal in - FStar_TypeChecker_Core.open_binders_in_comp - uu___4 bs1 c1 in - (match uu___3 with - | (env', bs2, c2) -> - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Util.is_pure_comp c2 in - Prims.op_Negation uu___6 in - if uu___5 - then - let uu___6 = - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_comp c2 in - Prims.strcat "Codomain is effectful: " - uu___7 in - FStar_Tactics_Monad.fail uu___6 - else - FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.repr ()) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - uu___4 - (fun uu___5 -> - (fun uu___5 -> - let uu___5 = Obj.magic uu___5 in - let typ' = - FStar_Syntax_Util.comp_result c2 in - let uu___6 = - let uu___7 = - let uu___8 = - should_check_goal_uvar goal in - FStar_Pervasives_Native.Some - uu___8 in - let uu___8 = - FStar_Tactics_Monad.goal_typedness_deps - goal in - FStar_Tactics_Monad.new_uvar - "intros" env' typ' uu___7 - uu___8 (rangeof goal) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () (Obj.magic uu___6) - (fun uu___7 -> - (fun uu___7 -> - let uu___7 = - Obj.magic uu___7 in - match uu___7 with - | (body, ctx_uvar) -> - let sol = - let uu___8 = - let uu___9 = - FStar_Syntax_Util.residual_comp_of_comp - c2 in - FStar_Pervasives_Native.Some - uu___9 in - FStar_Syntax_Util.abs - bs2 body uu___8 in - let uu___8 = - set_solution goal - sol in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___8 - (fun uu___9 -> - (fun uu___9 - -> - let uu___9 - = - Obj.magic - uu___9 in - let g = - FStar_Tactics_Types.mk_goal - env' - ctx_uvar - goal.FStar_Tactics_Types.opts - goal.FStar_Tactics_Types.is_guard - goal.FStar_Tactics_Types.label in - let uu___10 - = - FStar_Tactics_Monad.replace_cur - g in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___10 - (fun - uu___11 - -> - (fun - uu___11 - -> - let uu___11 - = - Obj.magic - uu___11 in - let uu___12 - = - FStar_Compiler_List.map - binder_to_binding - bs2 in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - uu___12))) - uu___11))) - uu___9))) - uu___7))) uu___5))))) - uu___1)) in - FStar_Tactics_Monad.wrap_err "intros" uu___ -let (intro_rec : - unit -> - (FStar_Reflection_V2_Data.binding * FStar_Reflection_V2_Data.binding) - FStar_Tactics_Monad.tac) - = - fun uu___ -> - (fun uu___ -> - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___1 -> - (fun goal -> - let goal = Obj.magic goal in - FStar_Compiler_Util.print_string - "WARNING (intro_rec): calling this is known to cause normalizer loops\n"; - FStar_Compiler_Util.print_string - "WARNING (intro_rec): proceed at your own risk...\n"; - (let uu___3 = - let uu___4 = FStar_Tactics_Types.goal_env goal in - let uu___5 = - let uu___6 = FStar_Tactics_Types.goal_env goal in - let uu___7 = FStar_Tactics_Types.goal_type goal in - whnf uu___6 uu___7 in - arrow_one uu___4 uu___5 in - match uu___3 with - | FStar_Pervasives_Native.Some (env', b, c) -> - Obj.magic - (Obj.repr - (let uu___4 = - let uu___5 = FStar_Syntax_Util.is_total_comp c in - Prims.op_Negation uu___5 in - if uu___4 - then - Obj.repr - (FStar_Tactics_Monad.fail - "Codomain is effectful") - else - Obj.repr - (let bv = - let uu___6 = - FStar_Tactics_Types.goal_type goal in - FStar_Syntax_Syntax.gen_bv "__recf" - FStar_Pervasives_Native.None uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - should_check_goal_uvar goal in - FStar_Pervasives_Native.Some uu___8 in - let uu___8 = - FStar_Tactics_Monad.goal_typedness_deps - goal in - FStar_Tactics_Monad.new_uvar "intro_rec" - env' (FStar_Syntax_Util.comp_result c) - uu___7 uu___8 (rangeof goal) in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___6) - (fun uu___7 -> - (fun uu___7 -> - let uu___7 = Obj.magic uu___7 in - match uu___7 with - | (u, ctx_uvar_u) -> - let lb = - let uu___8 = - FStar_Tactics_Types.goal_type - goal in - let uu___9 = - FStar_Syntax_Util.abs - [b] u - FStar_Pervasives_Native.None in - FStar_Syntax_Util.mk_letbinding - (FStar_Pervasives.Inl bv) - [] uu___8 - FStar_Parser_Const.effect_Tot_lid - uu___9 [] - FStar_Compiler_Range_Type.dummyRange in - let body = - FStar_Syntax_Syntax.bv_to_name - bv in - let uu___8 = - FStar_Syntax_Subst.close_let_rec - [lb] body in - (match uu___8 with - | (lbs, body1) -> - let tm = - let uu___9 = - let uu___10 = - FStar_Tactics_Types.goal_witness - goal in - uu___10.FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs - = (true, lbs); - FStar_Syntax_Syntax.body1 - = body1 - }) uu___9 in - let uu___9 = - set_solution goal tm in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___9 - (fun uu___10 -> - (fun uu___10 -> - let uu___10 = - Obj.magic - uu___10 in - let uu___11 = - bnorm_and_replace - { - FStar_Tactics_Types.goal_main_env - = - (goal.FStar_Tactics_Types.goal_main_env); - FStar_Tactics_Types.goal_ctx_uvar - = - ctx_uvar_u; - FStar_Tactics_Types.opts - = - (goal.FStar_Tactics_Types.opts); - FStar_Tactics_Types.is_guard - = - (goal.FStar_Tactics_Types.is_guard); - FStar_Tactics_Types.label - = - (goal.FStar_Tactics_Types.label) - } in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___11 - (fun - uu___12 - -> - (fun - uu___12 - -> - let uu___12 - = - Obj.magic - uu___12 in - let uu___13 - = - let uu___14 - = - let uu___15 - = - FStar_Syntax_Syntax.mk_binder - bv in - binder_to_binding - uu___15 in - let uu___15 - = - binder_to_binding - b in - (uu___14, - uu___15) in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - uu___13))) - uu___12))) - uu___10)))) - uu___7)))) - | FStar_Pervasives_Native.None -> - Obj.magic - (Obj.repr - (let uu___4 = - let uu___5 = FStar_Tactics_Types.goal_env goal in - let uu___6 = - FStar_Tactics_Types.goal_type goal in - tts uu___5 uu___6 in - fail1 "intro_rec: goal is not an arrow (%s)" - uu___4)))) uu___1))) uu___ -let (norm : - FStar_Pervasives.norm_step Prims.list -> unit FStar_Tactics_Monad.tac) = - fun s -> - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___ -> - (fun goal -> - let goal = Obj.magic goal in - let uu___ = - FStar_Tactics_Monad.if_verbose - (fun uu___1 -> - let uu___2 = - let uu___3 = FStar_Tactics_Types.goal_witness goal in - FStar_Class_Show.show FStar_Syntax_Print.showable_term - uu___3 in - FStar_Compiler_Util.print1 "norm: witness = %s\n" uu___2) in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - () uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - let steps = - let uu___2 = - FStar_TypeChecker_Cfg.translate_norm_steps s in - FStar_Compiler_List.op_At - [FStar_TypeChecker_Env.Reify; - FStar_TypeChecker_Env.DontUnfoldAttr - [FStar_Parser_Const.tac_opaque_attr]] uu___2 in - let t = - let uu___2 = FStar_Tactics_Types.goal_env goal in - let uu___3 = FStar_Tactics_Types.goal_type goal in - normalize steps uu___2 uu___3 in - let uu___2 = FStar_Tactics_Monad.goal_with_type goal t in - Obj.magic (FStar_Tactics_Monad.replace_cur uu___2)) - uu___1))) uu___) -let (__norm_term_env : - Prims.bool -> - env -> - FStar_Pervasives.norm_step Prims.list -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term FStar_Tactics_Monad.tac) - = - fun well_typed -> - fun e -> - fun s -> - fun t -> - let uu___ = - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - () (Obj.magic FStar_Tactics_Monad.get) - (fun uu___1 -> - (fun ps -> - let ps = Obj.magic ps in - let uu___1 = - FStar_Tactics_Monad.if_verbose - (fun uu___2 -> - let uu___3 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.print1 - "norm_term_env: t = %s\n" uu___3) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () uu___1 - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - let uu___3 = - if well_typed - then - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic t)) - else - (let uu___5 = __tc_lax e t in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () - () (Obj.magic uu___5) - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = - Obj.magic uu___6 in - match uu___6 with - | (t1, uu___7, uu___8) -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () (Obj.magic t1))) - uu___6))) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___3) - (fun uu___4 -> - (fun t1 -> - let t1 = Obj.magic t1 in - let steps = - let uu___4 = - FStar_TypeChecker_Cfg.translate_norm_steps - s in - FStar_Compiler_List.op_At - [FStar_TypeChecker_Env.Reify; - FStar_TypeChecker_Env.DontUnfoldAttr - [FStar_Parser_Const.tac_opaque_attr]] - uu___4 in - let t2 = - normalize steps - ps.FStar_Tactics_Types.main_context - t1 in - let uu___4 = - FStar_Tactics_Monad.if_verbose - (fun uu___5 -> - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t2 in - FStar_Compiler_Util.print1 - "norm_term_env: t' = %s\n" - uu___6) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___4 - (fun uu___5 -> - (fun uu___5 -> - let uu___5 = - Obj.magic uu___5 in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic t2))) - uu___5))) uu___4))) - uu___2))) uu___1)) in - FStar_Tactics_Monad.wrap_err "norm_term" uu___ -let (norm_term_env : - env -> - FStar_Pervasives.norm_step Prims.list -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term FStar_Tactics_Monad.tac) - = fun e -> fun s -> fun t -> __norm_term_env false e s t -let (refl_norm_well_typed_term : - env -> - FStar_Pervasives.norm_step Prims.list -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term FStar_Tactics_Monad.tac) - = fun e -> fun s -> fun t -> __norm_term_env true e s t -let (refine_intro : unit -> unit FStar_Tactics_Monad.tac) = - fun uu___ -> - let uu___1 = - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___2 -> - (fun g -> - let g = Obj.magic g in - let uu___2 = - let uu___3 = FStar_Tactics_Types.goal_env g in - let uu___4 = FStar_Tactics_Types.goal_type g in - FStar_TypeChecker_Rel.base_and_refinement uu___3 uu___4 in - match uu___2 with - | (uu___3, FStar_Pervasives_Native.None) -> - Obj.magic (FStar_Tactics_Monad.fail "not a refinement") - | (t, FStar_Pervasives_Native.Some (bv, phi)) -> - (FStar_Tactics_Monad.mark_goal_implicit_already_checked g; - (let g1 = FStar_Tactics_Monad.goal_with_type g t in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = FStar_Syntax_Syntax.mk_binder bv in - [uu___7] in - FStar_Syntax_Subst.open_term uu___6 phi in - match uu___5 with - | (bvs, phi1) -> - let uu___6 = - let uu___7 = FStar_Compiler_List.hd bvs in - uu___7.FStar_Syntax_Syntax.binder_bv in - (uu___6, phi1) in - match uu___4 with - | (bv1, phi1) -> - let uu___5 = - let uu___6 = FStar_Tactics_Types.goal_env g in - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Tactics_Types.goal_witness g in - (bv1, uu___11) in - FStar_Syntax_Syntax.NT uu___10 in - [uu___9] in - FStar_Syntax_Subst.subst uu___8 phi1 in - let uu___8 = - let uu___9 = should_check_goal_uvar g in - FStar_Pervasives_Native.Some uu___9 in - FStar_Tactics_Monad.mk_irrelevant_goal - "refine_intro refinement" uu___6 uu___7 uu___8 - (rangeof g) g.FStar_Tactics_Types.opts - g.FStar_Tactics_Types.label in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___5) - (fun uu___6 -> - (fun g2 -> - let g2 = Obj.magic g2 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - FStar_Tactics_Monad.dismiss - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = Obj.magic uu___6 in - Obj.magic - (FStar_Tactics_Monad.add_goals - [g1; g2])) uu___6))) - uu___6))))) uu___2) in - FStar_Tactics_Monad.wrap_err "refine_intro" uu___1 -let (__exact_now : - Prims.bool -> FStar_Syntax_Syntax.term -> unit FStar_Tactics_Monad.tac) = - fun set_expected_typ -> - fun t -> - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___ -> - (fun goal -> - let goal = Obj.magic goal in - let env1 = - if set_expected_typ - then - let uu___ = FStar_Tactics_Types.goal_env goal in - let uu___1 = FStar_Tactics_Types.goal_type goal in - FStar_TypeChecker_Env.set_expected_typ uu___ uu___1 - else FStar_Tactics_Types.goal_env goal in - let env2 = - { - FStar_TypeChecker_Env.solver = - (env1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (env1.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = false; - FStar_TypeChecker_Env.intactics = - (env1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env1.FStar_TypeChecker_Env.missing_decl) - } in - let uu___ = __tc env2 t in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac - () () (Obj.magic uu___) - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - match uu___1 with - | (t1, typ, guard) -> - let uu___2 = - FStar_Tactics_Monad.if_verbose - (fun uu___3 -> - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term typ in - let uu___5 = - let uu___6 = - FStar_Tactics_Types.goal_env goal in - FStar_TypeChecker_Rel.guard_to_string - uu___6 guard in - FStar_Compiler_Util.print2 - "__exact_now: got type %s\n__exact_now: and guard %s\n" - uu___4 uu___5) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () uu___2 - (fun uu___3 -> - (fun uu___3 -> - let uu___3 = Obj.magic uu___3 in - let uu___4 = - let uu___5 = - FStar_Tactics_Types.goal_env goal in - let uu___6 = - let uu___7 = - should_check_goal_uvar goal in - FStar_Pervasives_Native.Some - uu___7 in - proc_guard "__exact typing" uu___5 - guard uu___6 (rangeof goal) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () - () uu___4 - (fun uu___5 -> - (fun uu___5 -> - let uu___5 = - Obj.magic uu___5 in - let uu___6 = - FStar_Tactics_Monad.if_verbose - (fun uu___7 -> - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - typ in - let uu___9 = - let uu___10 = - FStar_Tactics_Types.goal_type - goal in - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - uu___10 in - FStar_Compiler_Util.print2 - "__exact_now: unifying %s and %s\n" - uu___8 uu___9) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___6 - (fun uu___7 -> - (fun uu___7 -> - let uu___7 = - Obj.magic - uu___7 in - let uu___8 = - let uu___9 = - FStar_Tactics_Types.goal_env - goal in - let uu___10 = - FStar_Tactics_Types.goal_type - goal in - do_unify true - uu___9 typ - uu___10 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic - uu___8) - (fun - uu___9 -> - (fun b -> - let b = - Obj.magic - b in - if b - then - (FStar_Tactics_Monad.mark_goal_implicit_already_checked - goal; - Obj.magic - (solve - goal t1)) - else - (let uu___10 - = - let uu___11 - = - let uu___12 - = - FStar_Tactics_Types.goal_env - goal in - ttd - uu___12 in - let uu___12 - = - FStar_Tactics_Types.goal_type - goal in - FStar_TypeChecker_Err.print_discrepancy - uu___11 - typ - uu___12 in - match uu___10 - with - | - (typ1, - goalt) -> - let uu___11 - = - let uu___12 - = - let uu___13 - = - let uu___14 - = - FStar_Errors_Msg.text - "Term" in - let uu___15 - = - let uu___16 - = - FStar_Tactics_Types.goal_env - goal in - ttd - uu___16 - t1 in - FStar_Pprint.prefix - (Prims.of_int (2)) - Prims.int_one - uu___14 - uu___15 in - let uu___14 - = - let uu___15 - = - let uu___16 - = - FStar_Errors_Msg.text - "of type" in - FStar_Pprint.prefix - (Prims.of_int (2)) - Prims.int_one - uu___16 - typ1 in - let uu___16 - = - let uu___17 - = - FStar_Errors_Msg.text - "does not exactly solve the goal" in - FStar_Pprint.prefix - (Prims.of_int (2)) - Prims.int_one - uu___17 - goalt in - FStar_Pprint.op_Hat_Slash_Hat - uu___15 - uu___16 in - FStar_Pprint.op_Hat_Slash_Hat - uu___13 - uu___14 in - [uu___12] in - Obj.magic - (FStar_Tactics_Monad.fail_doc - uu___11))) - uu___9))) - uu___7))) uu___5))) - uu___3))) uu___1))) uu___) -let (t_exact : - Prims.bool -> - Prims.bool -> FStar_Syntax_Syntax.term -> unit FStar_Tactics_Monad.tac) - = - fun try_refine -> - fun set_expected_typ -> - fun tm -> - let uu___ = - let uu___1 = - FStar_Tactics_Monad.if_verbose - (fun uu___2 -> - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term tm in - FStar_Compiler_Util.print1 "t_exact: tm = %s\n" uu___3) in - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___1 - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - let uu___3 = - let uu___4 = __exact_now set_expected_typ tm in - FStar_Tactics_Monad.catch uu___4 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () (Obj.magic uu___3) - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - match uu___4 with - | FStar_Pervasives.Inr r -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.repr ())) - | FStar_Pervasives.Inl e when - Prims.op_Negation try_refine -> - Obj.magic (FStar_Tactics_Monad.traise e) - | FStar_Pervasives.Inl e -> - let uu___5 = - FStar_Tactics_Monad.if_verbose - (fun uu___6 -> - FStar_Compiler_Util.print_string - "__exact_now failed, trying refine...\n") in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - uu___5 - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = Obj.magic uu___6 in - let uu___7 = - let uu___8 = - let uu___9 = - norm - [FStar_Pervasives.Delta] in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___9 - (fun uu___10 -> - (fun uu___10 -> - let uu___10 = - Obj.magic uu___10 in - let uu___11 = - refine_intro () in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___11 - (fun uu___12 -> - (fun uu___12 - -> - let uu___12 - = - Obj.magic - uu___12 in - Obj.magic - (__exact_now - set_expected_typ - tm)) - uu___12))) - uu___10) in - FStar_Tactics_Monad.catch - uu___8 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () (Obj.magic uu___7) - (fun uu___8 -> - (fun uu___8 -> - let uu___8 = - Obj.magic uu___8 in - match uu___8 with - | FStar_Pervasives.Inr - r -> - let uu___9 = - FStar_Tactics_Monad.if_verbose - (fun uu___10 - -> - FStar_Compiler_Util.print_string - "__exact_now: failed after refining too\n") in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___9 - (fun uu___10 - -> - (fun - uu___10 - -> - let uu___10 - = - Obj.magic - uu___10 in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.repr - ()))) - uu___10)) - | FStar_Pervasives.Inl - uu___9 -> - let uu___10 = - FStar_Tactics_Monad.if_verbose - (fun uu___11 - -> - FStar_Compiler_Util.print_string - "__exact_now: was not a refinement\n") in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___10 - (fun uu___11 - -> - (fun - uu___11 - -> - let uu___11 - = - Obj.magic - uu___11 in - Obj.magic - (FStar_Tactics_Monad.traise - e)) - uu___11))) - uu___8))) uu___6))) - uu___4))) uu___2) in - FStar_Tactics_Monad.wrap_err "exact" uu___ -let (try_unify_by_application : - FStar_Syntax_Syntax.should_check_uvar FStar_Pervasives_Native.option -> - Prims.bool -> - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> - FStar_Compiler_Range_Type.range -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.aqual * - FStar_Syntax_Syntax.ctx_uvar) Prims.list - FStar_Tactics_Monad.tac) - = - fun should_check -> - fun only_match -> - fun e -> - fun ty1 -> - fun ty2 -> - fun rng -> - let f = if only_match then do_match else do_unify in - let must_tot = true in - let rec aux uu___2 uu___1 uu___ = - (fun acc -> - fun typedness_deps -> - fun ty11 -> - let uu___ = f must_tot e ty2 ty11 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___) - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - if uu___1 - then - Obj.magic - (Obj.repr - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic acc))) - else - Obj.magic - (Obj.repr - (let uu___2 = - FStar_Syntax_Util.arrow_one ty11 in - match uu___2 with - | FStar_Pervasives_Native.None -> - Obj.repr - (let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Errors_Msg.text - "Could not instantiate" in - let uu___7 = - ttd e ty11 in - FStar_Pprint.prefix - (Prims.of_int (2)) - Prims.int_one uu___6 - uu___7 in - let uu___6 = - let uu___7 = - FStar_Errors_Msg.text - "to" in - let uu___8 = ttd e ty2 in - FStar_Pprint.prefix - (Prims.of_int (2)) - Prims.int_one uu___7 - uu___8 in - FStar_Pprint.op_Hat_Slash_Hat - uu___5 uu___6 in - [uu___4] in - FStar_Tactics_Monad.fail_doc - uu___3) - | FStar_Pervasives_Native.Some - (b, c) -> - Obj.repr - (let uu___3 = - let uu___4 = - FStar_Syntax_Util.is_total_comp - c in - Prims.op_Negation uu___4 in - if uu___3 - then - Obj.repr - (FStar_Tactics_Monad.fail - "Codomain is effectful") - else - Obj.repr - (let uu___5 = - FStar_Tactics_Monad.new_uvar - "apply arg" e - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort - should_check - typedness_deps rng in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic uu___5) - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = - Obj.magic - uu___6 in - match uu___6 - with - | (uvt, uv) -> - let uu___7 - = - FStar_Tactics_Monad.if_verbose - (fun - uu___8 -> - let uu___9 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_ctxu - uv in - FStar_Compiler_Util.print1 - "t_apply: generated uvar %s\n" - uu___9) in - Obj.magic - ( - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___7 - (fun - uu___8 -> - (fun - uu___8 -> - let uu___8 - = - Obj.magic - uu___8 in - let typ = - FStar_Syntax_Util.comp_result - c in - let typ' - = - FStar_Syntax_Subst.subst - [ - FStar_Syntax_Syntax.NT - ((b.FStar_Syntax_Syntax.binder_bv), - uvt)] typ in - let uu___9 - = - let uu___10 - = - let uu___11 - = - FStar_Syntax_Util.aqual_of_binder - b in - (uvt, - uu___11, - uv) in - uu___10 - :: acc in - Obj.magic - (aux - uu___9 - (uv :: - typedness_deps) - typ')) - uu___8))) - uu___6)))))) - uu___1))) uu___2 uu___1 uu___ in - aux [] [] ty1 -let (apply_implicits_as_goals : - FStar_TypeChecker_Env.env -> - FStar_Tactics_Types.goal FStar_Pervasives_Native.option -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.ctx_uvar) Prims.list -> - FStar_Tactics_Types.goal Prims.list Prims.list - FStar_Tactics_Monad.tac) - = - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun env1 -> - fun gl -> - fun imps -> - let one_implicit_as_goal uu___ = - (fun uu___ -> - match uu___ with - | (term, ctx_uvar) -> - let uu___1 = FStar_Syntax_Util.head_and_args term in - (match uu___1 with - | (hd, uu___2) -> - let uu___3 = - let uu___4 = FStar_Syntax_Subst.compress hd in - uu___4.FStar_Syntax_Syntax.n in - (match uu___3 with - | FStar_Syntax_Syntax.Tm_uvar - (ctx_uvar1, uu___4) -> - let gl1 = - match gl with - | FStar_Pervasives_Native.None -> - let uu___5 = FStar_Options.peek () in - FStar_Tactics_Types.mk_goal env1 - ctx_uvar1 uu___5 true - "goal for unsolved implicit" - | FStar_Pervasives_Native.Some gl2 -> - { - FStar_Tactics_Types.goal_main_env = - (gl2.FStar_Tactics_Types.goal_main_env); - FStar_Tactics_Types.goal_ctx_uvar = - ctx_uvar1; - FStar_Tactics_Types.opts = - (gl2.FStar_Tactics_Types.opts); - FStar_Tactics_Types.is_guard = - (gl2.FStar_Tactics_Types.is_guard); - FStar_Tactics_Types.label = - (gl2.FStar_Tactics_Types.label) - } in - let gl2 = bnorm_goal gl1 in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic [gl2])) - | uu___4 -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic []))))) uu___ in - Obj.magic - (FStar_Class_Monad.mapM FStar_Tactics_Monad.monad_tac () () - (fun uu___ -> (Obj.magic one_implicit_as_goal) uu___) - (Obj.magic imps))) uu___2 uu___1 uu___ -let (t_apply : - Prims.bool -> - Prims.bool -> - Prims.bool -> FStar_Syntax_Syntax.term -> unit FStar_Tactics_Monad.tac) - = - fun uopt -> - fun only_match -> - fun tc_resolved_uvars -> - fun tm -> - let uu___ = - let tc_resolved_uvars1 = true in - let uu___1 = - FStar_Tactics_Monad.if_verbose - (fun uu___2 -> - let uu___3 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) uopt in - let uu___4 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) only_match in - let uu___5 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - tc_resolved_uvars1 in - let uu___6 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - tm in - FStar_Compiler_Util.print4 - "t_apply: uopt %s, only_match %s, tc_resolved_uvars %s, tm = %s\n" - uu___3 uu___4 uu___5 uu___6) in - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___1 - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.get) - (fun uu___3 -> - (fun ps -> - let ps = Obj.magic ps in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___3 -> - (fun goal -> - let goal = Obj.magic goal in - let e = - FStar_Tactics_Types.goal_env goal in - let should_check = - should_check_goal_uvar goal in - FStar_Tactics_Monad.register_goal - goal; - (let uu___4 = __tc e tm in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () (Obj.magic uu___4) - (fun uu___5 -> - (fun uu___5 -> - let uu___5 = - Obj.magic uu___5 in - match uu___5 with - | (tm1, typ, guard) -> - let uu___6 = - FStar_Tactics_Monad.if_verbose - (fun uu___7 -> - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - tm1 in - let uu___9 = - FStar_Tactics_Printing.goal_to_string_verbose - goal in - let uu___10 - = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binding) - e.FStar_TypeChecker_Env.gamma in - let uu___11 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - typ in - let uu___12 - = - FStar_TypeChecker_Rel.guard_to_string - e guard in - FStar_Compiler_Util.print5 - "t_apply: tm = %s\nt_apply: goal = %s\nenv.gamma=%s\ntyp=%s\nguard=%s\n" - uu___8 - uu___9 - uu___10 - uu___11 - uu___12) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___6 - (fun uu___7 -> - (fun uu___7 - -> - let uu___7 - = - Obj.magic - uu___7 in - let typ1 - = - bnorm e - typ in - let uu___8 - = - let uu___9 - = - only_match - && - (let uu___10 - = - let uu___11 - = - FStar_Syntax_Free.uvars_uncached - typ1 in - FStar_Class_Setlike.is_empty - () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) - (Obj.magic - uu___11) in - Prims.op_Negation - uu___10) in - if uu___9 - then - FStar_Tactics_Monad.fail - "t_apply: only_match is on, but the type of the term to apply is not a uvar" - else - FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.repr - ()) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___8 - (fun - uu___9 -> - (fun - uu___9 -> - let uu___9 - = - Obj.magic - uu___9 in - let uu___10 - = - let uu___11 - = - FStar_Tactics_Types.goal_type - goal in - try_unify_by_application - (FStar_Pervasives_Native.Some - should_check) - only_match - e typ1 - uu___11 - (rangeof - goal) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic - uu___10) - (fun - uu___11 - -> - (fun uvs - -> - let uvs = - Obj.magic - uvs in - let uu___11 - = - FStar_Tactics_Monad.if_verbose - (fun - uu___12 - -> - let uu___13 - = - (FStar_Common.string_of_list - ()) - (fun - uu___14 - -> - match uu___14 - with - | - (t, - uu___15, - uu___16) - -> - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t) uvs in - FStar_Compiler_Util.print1 - "t_apply: found args = %s\n" - uu___13) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___11 - (fun - uu___12 - -> - (fun - uu___12 - -> - let uu___12 - = - Obj.magic - uu___12 in - let w = - FStar_Compiler_List.fold_right - (fun - uu___13 - -> - fun w1 -> - match uu___13 - with - | - (uvt, q, - uu___14) - -> - FStar_Syntax_Util.mk_app - w1 - [ - (uvt, q)]) - uvs tm1 in - let uvset - = - let uu___13 - = - Obj.magic - (FStar_Class_Setlike.empty - () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) - ()) in - FStar_Compiler_List.fold_right - (fun - uu___15 - -> - fun - uu___14 - -> - (fun - uu___14 - -> - fun s -> - match uu___14 - with - | - (uu___15, - uu___16, - uv) -> - let uu___17 - = - let uu___18 - = - FStar_Syntax_Util.ctx_uvar_typ - uv in - FStar_Syntax_Free.uvars - uu___18 in - Obj.magic - (FStar_Class_Setlike.union - () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) - (Obj.magic - s) - (Obj.magic - uu___17))) - uu___15 - uu___14) - uvs - uu___13 in - let free_in_some_goal - uv = - FStar_Class_Setlike.mem - () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) - uv - (Obj.magic - uvset) in - let uu___13 - = - solve' - goal w in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___13 - (fun - uu___14 - -> - (fun - uu___14 - -> - let uu___14 - = - Obj.magic - uu___14 in - let uvt_uv_l - = - FStar_Compiler_List.map - (fun - uu___15 - -> - match uu___15 - with - | - (uvt, _q, - uv) -> - (uvt, uv)) - uvs in - let uu___15 - = - apply_implicits_as_goals - e - (FStar_Pervasives_Native.Some - goal) - uvt_uv_l in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic - uu___15) - (fun - uu___16 - -> - (fun - sub_goals - -> - let sub_goals - = - Obj.magic - sub_goals in - let sub_goals1 - = - let uu___16 - = - let uu___17 - = - FStar_Compiler_List.filter - (fun g -> - let uu___18 - = - uopt && - (free_in_some_goal - g.FStar_Tactics_Types.goal_ctx_uvar) in - Prims.op_Negation - uu___18) - (FStar_Compiler_List.flatten - sub_goals) in - FStar_Compiler_List.map - bnorm_goal - uu___17 in - FStar_Compiler_List.rev - uu___16 in - let uu___16 - = - FStar_Tactics_Monad.add_goals - sub_goals1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___16 - (fun - uu___17 - -> - (fun - uu___17 - -> - let uu___17 - = - Obj.magic - uu___17 in - Obj.magic - (proc_guard - "apply guard" - e guard - (FStar_Pervasives_Native.Some - should_check) - (rangeof - goal))) - uu___17))) - uu___16))) - uu___14))) - uu___12))) - uu___11))) - uu___9))) - uu___7))) - uu___5)))) uu___3))) - uu___3))) uu___2) in - FStar_Tactics_Monad.wrap_err "apply" uu___ -let (lemma_or_sq : - FStar_Syntax_Syntax.comp -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.term) - FStar_Pervasives_Native.option) - = - fun c -> - let uu___ = FStar_Syntax_Util.comp_eff_name_res_and_args c in - match uu___ with - | (eff_name, res, args) -> - let uu___1 = - FStar_Ident.lid_equals eff_name FStar_Parser_Const.effect_Lemma_lid in - if uu___1 - then - let uu___2 = - match args with - | pre::post::uu___3 -> - ((FStar_Pervasives_Native.fst pre), - (FStar_Pervasives_Native.fst post)) - | uu___3 -> failwith "apply_lemma: impossible: not a lemma" in - (match uu___2 with - | (pre, post) -> - let post1 = - let uu___3 = - let uu___4 = - FStar_Syntax_Syntax.as_arg FStar_Syntax_Util.exp_unit in - [uu___4] in - FStar_Syntax_Util.mk_app post uu___3 in - FStar_Pervasives_Native.Some (pre, post1)) - else - (let uu___3 = - (FStar_Syntax_Util.is_pure_effect eff_name) || - (FStar_Syntax_Util.is_ghost_effect eff_name) in - if uu___3 - then - let uu___4 = FStar_Syntax_Util.un_squash res in - FStar_Compiler_Util.map_opt uu___4 - (fun post -> (FStar_Syntax_Util.t_true, post)) - else FStar_Pervasives_Native.None) -let (t_apply_lemma : - Prims.bool -> - Prims.bool -> FStar_Syntax_Syntax.term -> unit FStar_Tactics_Monad.tac) - = - fun noinst -> - fun noinst_lhs -> - fun tm -> - let uu___ = - let uu___1 = - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.get) - (fun uu___2 -> - (fun ps -> - let ps = Obj.magic ps in - let uu___2 = - FStar_Tactics_Monad.if_verbose - (fun uu___3 -> - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term tm in - FStar_Compiler_Util.print1 - "apply_lemma: tm = %s\n" uu___4) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () uu___2 - (fun uu___3 -> - (fun uu___3 -> - let uu___3 = Obj.magic uu___3 in - let is_unit_t t = - let uu___4 = - let uu___5 = FStar_Syntax_Subst.compress t in - uu___5.FStar_Syntax_Syntax.n in - match uu___4 with - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.unit_lid - -> true - | uu___5 -> false in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___4 -> - (fun goal -> - let goal = Obj.magic goal in - let env1 = - FStar_Tactics_Types.goal_env goal in - FStar_Tactics_Monad.register_goal - goal; - (let uu___5 = - let env2 = - { - FStar_TypeChecker_Env.solver - = - (env1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range - = - (env1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule - = - (env1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma - = - (env1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig - = - (env1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache - = - (env1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules - = - (env1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ - = - (env1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab - = - (env1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab - = - (env1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp - = - (env1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects - = - (env1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize - = - (env1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs - = - (env1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level - = - (env1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars - = - (env1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict - = - (env1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface - = - (env1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit - = - (env1.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes - = - (env1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 - = - (env1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard - = - (env1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking - = - (env1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping - = false; - FStar_TypeChecker_Env.intactics - = - (env1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce - = - (env1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term - = - (env1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (env1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of - = - (env1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force - = - (env1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (env1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (env1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (env1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths - = - (env1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns - = - (env1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook - = - (env1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (env1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice - = - (env1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess - = - (env1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess - = - (env1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info - = - (env1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks - = - (env1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv - = - (env1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab - = - (env1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (env1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (env1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (env1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (env1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check - = - (env1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl - = - (env1.FStar_TypeChecker_Env.missing_decl) - } in - __tc env2 tm in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () (Obj.magic uu___5) - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = - Obj.magic uu___6 in - match uu___6 with - | (tm1, t, guard) -> - let uu___7 = - FStar_Syntax_Util.arrow_formals_comp - t in - (match uu___7 with - | (bs, comp) -> - let uu___8 = - lemma_or_sq - comp in - (match uu___8 - with - | FStar_Pervasives_Native.None - -> - Obj.magic - (FStar_Tactics_Monad.fail - "not a lemma or squashed function") - | FStar_Pervasives_Native.Some - (pre, - post) -> - let uu___9 - = - Obj.magic - (FStar_Class_Monad.foldM_left - FStar_Tactics_Monad.monad_tac - () () - (fun - uu___11 - -> - fun - uu___10 - -> - (fun - uu___10 - -> - let uu___10 - = - Obj.magic - uu___10 in - fun - uu___11 - -> - let uu___11 - = - Obj.magic - uu___11 in - match - (uu___10, - uu___11) - with - | - ((uvs, - deps, - imps, - subst), - { - FStar_Syntax_Syntax.binder_bv - = b; - FStar_Syntax_Syntax.binder_qual - = aq; - FStar_Syntax_Syntax.binder_positivity - = uu___12; - FStar_Syntax_Syntax.binder_attrs - = uu___13;_}) - -> - let b_t = - FStar_Syntax_Subst.subst - subst - b.FStar_Syntax_Syntax.sort in - let uu___14 - = - is_unit_t - b_t in - if - uu___14 - then - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - (((FStar_Syntax_Util.exp_unit, - aq) :: - uvs), - deps, - imps, - ((FStar_Syntax_Syntax.NT - (b, - FStar_Syntax_Util.exp_unit)) - :: - subst)))) - else - (let uu___16 - = - let uu___17 - = - let uu___18 - = - let uu___19 - = - should_check_goal_uvar - goal in - match uu___19 - with - | - FStar_Syntax_Syntax.Strict - -> - FStar_Syntax_Syntax.Allow_ghost - "apply lemma uvar" - | - x -> x in - FStar_Pervasives_Native.Some - uu___18 in - FStar_Tactics_Monad.new_uvar - "apply_lemma" - env1 b_t - uu___17 - deps - (rangeof - goal) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic - uu___16) - (fun - uu___17 - -> - (fun - uu___17 - -> - let uu___17 - = - Obj.magic - uu___17 in - match uu___17 - with - | - (t1, u) - -> - (( - let uu___19 - = - FStar_Compiler_Effect.op_Bang - dbg_2635 in - if - uu___19 - then - let uu___20 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_ctxu - u in - let uu___21 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - tm1 in - FStar_Compiler_Util.print2 - "Apply lemma created a new uvar %s while applying %s\n" - uu___20 - uu___21 - else ()); - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - (((t1, - aq) :: - uvs), (u - :: deps), - ((t1, u) - :: imps), - ((FStar_Syntax_Syntax.NT - (b, t1)) - :: - subst)))))) - uu___17)))) - uu___11 - uu___10) - (Obj.magic - ([], [], - [], [])) - (Obj.magic - bs)) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic - uu___9) - (fun - uu___10 - -> - (fun - uu___10 - -> - let uu___10 - = - Obj.magic - uu___10 in - match uu___10 - with - | - (uvs, - uu___11, - implicits1, - subst) -> - let implicits2 - = - FStar_Compiler_List.rev - implicits1 in - let uvs1 - = - FStar_Compiler_List.rev - uvs in - let pre1 - = - FStar_Syntax_Subst.subst - subst pre in - let post1 - = - FStar_Syntax_Subst.subst - subst - post in - let post_u - = - env1.FStar_TypeChecker_Env.universe_of - env1 - post1 in - let cmp_func - = - if noinst - then - do_match - else - if - noinst_lhs - then - do_match_on_lhs - else - do_unify in - let uu___12 - = - let must_tot - = false in - let uu___13 - = - FStar_Tactics_Types.goal_type - goal in - let uu___14 - = - FStar_Syntax_Util.mk_squash - post_u - post1 in - cmp_func - must_tot - env1 - uu___13 - uu___14 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic - uu___12) - (fun - uu___13 - -> - (fun b -> - let b = - Obj.magic - b in - if - Prims.op_Negation - b - then - let uu___13 - = - let uu___14 - = - let uu___15 - = - let uu___16 - = - FStar_Errors_Msg.text - "Cannot instantiate lemma:" in - let uu___17 - = - FStar_Class_PP.pp - FStar_Syntax_Print.pretty_term - tm1 in - FStar_Pprint.prefix - (Prims.of_int (2)) - Prims.int_one - uu___16 - uu___17 in - let uu___16 - = - let uu___17 - = - let uu___18 - = - FStar_Errors_Msg.text - "with postcondition:" in - let uu___19 - = - FStar_TypeChecker_Normalize.term_to_doc - env1 - post1 in - FStar_Pprint.prefix - (Prims.of_int (2)) - Prims.int_one - uu___18 - uu___19 in - let uu___18 - = - let uu___19 - = - FStar_Errors_Msg.text - "to match goal:" in - let uu___20 - = - let uu___21 - = - FStar_Tactics_Types.goal_type - goal in - FStar_Class_PP.pp - FStar_Syntax_Print.pretty_term - uu___21 in - FStar_Pprint.prefix - (Prims.of_int (2)) - Prims.int_one - uu___19 - uu___20 in - FStar_Pprint.op_Hat_Slash_Hat - uu___17 - uu___18 in - FStar_Pprint.op_Hat_Slash_Hat - uu___15 - uu___16 in - [uu___14] in - Obj.magic - (FStar_Tactics_Monad.fail_doc - uu___13) - else - (let goal_sc - = - should_check_goal_uvar - goal in - let uu___14 - = - solve' - goal - FStar_Syntax_Util.exp_unit in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___14 - (fun - uu___15 - -> - (fun - uu___15 - -> - let uu___15 - = - Obj.magic - uu___15 in - let is_free_uvar - uv t1 = - let uu___16 - = - FStar_Syntax_Free.uvars - t1 in - FStar_Class_Setlike.for_any - () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) - (fun u -> - FStar_Syntax_Unionfind.equiv - u.FStar_Syntax_Syntax.ctx_uvar_head - uv) - (Obj.magic - uu___16) in - let appears - uv goals - = - FStar_Compiler_List.existsML - (fun g' - -> - let uu___16 - = - FStar_Tactics_Types.goal_type - g' in - is_free_uvar - uv - uu___16) - goals in - let checkone - t1 goals - = - let uu___16 - = - FStar_Syntax_Util.head_and_args - t1 in - match uu___16 - with - | - (hd, - uu___17) - -> - (match - hd.FStar_Syntax_Syntax.n - with - | - FStar_Syntax_Syntax.Tm_uvar - (uv, - uu___18) - -> - appears - uv.FStar_Syntax_Syntax.ctx_uvar_head - goals - | - uu___18 - -> false) in - let must_tot - = false in - let uu___16 - = - apply_implicits_as_goals - env1 - (FStar_Pervasives_Native.Some - goal) - implicits2 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic - uu___16) - (fun - uu___17 - -> - (fun - sub_goals - -> - let sub_goals - = - Obj.magic - sub_goals in - let sub_goals1 - = - FStar_Compiler_List.flatten - sub_goals in - let rec filter' - f xs = - match xs - with - | - [] -> [] - | - x::xs1 -> - let uu___17 - = f x xs1 in - if - uu___17 - then - let uu___18 - = - filter' f - xs1 in x - :: - uu___18 - else - filter' f - xs1 in - let sub_goals2 - = - filter' - (fun g -> - fun goals - -> - let uu___17 - = - let uu___18 - = - FStar_Tactics_Types.goal_witness - g in - checkone - uu___18 - goals in - Prims.op_Negation - uu___17) - sub_goals1 in - let uu___17 - = - proc_guard - "apply_lemma guard" - env1 - guard - (FStar_Pervasives_Native.Some - goal_sc) - (rangeof - goal) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___17 - (fun - uu___18 - -> - (fun - uu___18 - -> - let uu___18 - = - Obj.magic - uu___18 in - let pre_u - = - env1.FStar_TypeChecker_Env.universe_of - env1 pre1 in - let uu___19 - = - let uu___20 - = - let uu___21 - = - let uu___22 - = - FStar_TypeChecker_Env.guard_of_guard_formula - (FStar_TypeChecker_Common.NonTrivial - pre1) in - FStar_TypeChecker_Rel.simplify_guard - env1 - uu___22 in - uu___21.FStar_TypeChecker_Common.guard_f in - match uu___20 - with - | - FStar_TypeChecker_Common.Trivial - -> - FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.repr - ()) - | - FStar_TypeChecker_Common.NonTrivial - uu___21 - -> - FStar_Tactics_Monad.add_irrelevant_goal - goal - "apply_lemma precondition" - env1 pre1 - (FStar_Pervasives_Native.Some - goal_sc) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___19 - (fun - uu___20 - -> - (fun - uu___20 - -> - let uu___20 - = - Obj.magic - uu___20 in - Obj.magic - (FStar_Tactics_Monad.add_goals - sub_goals2)) - uu___20))) - uu___18))) - uu___17))) - uu___15)))) - uu___13))) - uu___10))))) - uu___6)))) uu___4))) - uu___3))) uu___2) in - FStar_Tactics_Monad.focus uu___1 in - FStar_Tactics_Monad.wrap_err "apply_lemma" uu___ -let (split_env : - FStar_Syntax_Syntax.bv -> - env -> - (env * FStar_Syntax_Syntax.bv * FStar_Syntax_Syntax.bv Prims.list) - FStar_Pervasives_Native.option) - = - fun bvar -> - fun e -> - let rec aux e1 = - let uu___ = FStar_TypeChecker_Env.pop_bv e1 in - match uu___ with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (bv', e') -> - let uu___1 = FStar_Syntax_Syntax.bv_eq bvar bv' in - if uu___1 - then FStar_Pervasives_Native.Some (e', bv', []) - else - (let uu___3 = aux e' in - FStar_Compiler_Util.map_opt uu___3 - (fun uu___4 -> - match uu___4 with - | (e'', bv, bvs) -> (e'', bv, (bv' :: bvs)))) in - let uu___ = aux e in - FStar_Compiler_Util.map_opt uu___ - (fun uu___1 -> - match uu___1 with - | (e', bv, bvs) -> (e', bv, (FStar_Compiler_List.rev bvs))) -let (subst_goal : - FStar_Syntax_Syntax.bv -> - FStar_Syntax_Syntax.bv -> - FStar_Tactics_Types.goal -> - (FStar_Syntax_Syntax.bv * FStar_Tactics_Types.goal) - FStar_Pervasives_Native.option FStar_Tactics_Monad.tac) - = - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun b1 -> - fun b2 -> - fun g -> - let uu___ = - let uu___1 = FStar_Tactics_Types.goal_env g in - split_env b1 uu___1 in - match uu___ with - | FStar_Pervasives_Native.Some (e0, b11, bvs) -> - let bs = - FStar_Compiler_List.map FStar_Syntax_Syntax.mk_binder - (b11 :: bvs) in - let t = FStar_Tactics_Types.goal_type g in - let uu___1 = - let uu___2 = FStar_Syntax_Subst.close_binders bs in - let uu___3 = FStar_Syntax_Subst.close bs t in - (uu___2, uu___3) in - (match uu___1 with - | (bs', t') -> - let bs'1 = - let uu___2 = FStar_Syntax_Syntax.mk_binder b2 in - let uu___3 = FStar_Compiler_List.tail bs' in uu___2 - :: uu___3 in - let uu___2 = - FStar_TypeChecker_Core.open_binders_in_term e0 bs'1 - t' in - (match uu___2 with - | (new_env, bs'', t'') -> - let b21 = - let uu___3 = FStar_Compiler_List.hd bs'' in - uu___3.FStar_Syntax_Syntax.binder_bv in - let uu___3 = - let uu___4 = - let uu___5 = should_check_goal_uvar g in - FStar_Pervasives_Native.Some uu___5 in - let uu___5 = - FStar_Tactics_Monad.goal_typedness_deps g in - FStar_Tactics_Monad.new_uvar "subst_goal" - new_env t'' uu___4 uu___5 (rangeof g) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___3) - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - match uu___4 with - | (uvt, uv) -> - let goal' = - FStar_Tactics_Types.mk_goal - new_env uv - g.FStar_Tactics_Types.opts - g.FStar_Tactics_Types.is_guard - g.FStar_Tactics_Types.label in - let sol = - let uu___5 = - FStar_Syntax_Util.abs bs'' - uvt - FStar_Pervasives_Native.None in - let uu___6 = - FStar_Compiler_List.map - (fun uu___7 -> - match uu___7 with - | { - FStar_Syntax_Syntax.binder_bv - = bv; - FStar_Syntax_Syntax.binder_qual - = q; - FStar_Syntax_Syntax.binder_positivity - = uu___8; - FStar_Syntax_Syntax.binder_attrs - = uu___9;_} - -> - let uu___10 = - FStar_Syntax_Syntax.bv_to_name - bv in - FStar_Syntax_Syntax.as_arg - uu___10) bs in - FStar_Syntax_Util.mk_app uu___5 - uu___6 in - let uu___5 = set_solution g sol in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___5 - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = - Obj.magic uu___6 in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - (FStar_Pervasives_Native.Some - (b21, - goal'))))) - uu___6))) uu___4)))) - | FStar_Pervasives_Native.None -> - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac - () (Obj.magic FStar_Pervasives_Native.None))) uu___2 - uu___1 uu___ -let (rewrite : - FStar_Reflection_V2_Data.binding -> unit FStar_Tactics_Monad.tac) = - fun hh -> - let uu___ = - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___1 -> - (fun goal -> - let goal = Obj.magic goal in - let h = binding_to_binder hh in - let bv = h.FStar_Syntax_Syntax.binder_bv in - let uu___1 = - FStar_Tactics_Monad.if_verbose - (fun uu___2 -> - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_bv - bv in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - bv.FStar_Syntax_Syntax.sort in - FStar_Compiler_Util.print2 "+++Rewrite %s : %s\n" uu___3 - uu___4) in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac - () () uu___1 - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - let uu___3 = - let uu___4 = FStar_Tactics_Types.goal_env goal in - split_env bv uu___4 in - match uu___3 with - | FStar_Pervasives_Native.None -> - Obj.magic - (FStar_Tactics_Monad.fail - "binder not found in environment") - | FStar_Pervasives_Native.Some (e0, bv1, bvs) -> - let uu___4 = - destruct_eq e0 bv1.FStar_Syntax_Syntax.sort in - (match uu___4 with - | FStar_Pervasives_Native.Some (x, e) -> - let uu___5 = - let uu___6 = - FStar_Syntax_Subst.compress x in - uu___6.FStar_Syntax_Syntax.n in - (match uu___5 with - | FStar_Syntax_Syntax.Tm_name x1 -> - let s = - [FStar_Syntax_Syntax.NT (x1, e)] in - let t = - FStar_Tactics_Types.goal_type goal in - let bs = - FStar_Compiler_List.map - FStar_Syntax_Syntax.mk_binder bvs in - let uu___6 = - let uu___7 = - FStar_Syntax_Subst.close_binders - bs in - let uu___8 = - FStar_Syntax_Subst.close bs t in - (uu___7, uu___8) in - (match uu___6 with - | (bs', t') -> - let uu___7 = - let uu___8 = - FStar_Syntax_Subst.subst_binders - s bs' in - let uu___9 = - FStar_Syntax_Subst.subst s t' in - (uu___8, uu___9) in - (match uu___7 with - | (bs'1, t'1) -> - let e01 = - FStar_TypeChecker_Env.push_bvs - e0 [bv1] in - let uu___8 = - FStar_TypeChecker_Core.open_binders_in_term - e01 bs'1 t'1 in - (match uu___8 with - | (new_env, bs'', t'') -> - let uu___9 = - let uu___10 = - let uu___11 = - should_check_goal_uvar - goal in - FStar_Pervasives_Native.Some - uu___11 in - let uu___11 = - FStar_Tactics_Monad.goal_typedness_deps - goal in - FStar_Tactics_Monad.new_uvar - "rewrite" new_env - t'' uu___10 uu___11 - (rangeof goal) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic uu___9) - (fun uu___10 -> - (fun uu___10 -> - let uu___10 - = - Obj.magic - uu___10 in - match uu___10 - with - | (uvt, uv) - -> - let goal' - = - FStar_Tactics_Types.mk_goal - new_env - uv - goal.FStar_Tactics_Types.opts - goal.FStar_Tactics_Types.is_guard - goal.FStar_Tactics_Types.label in - let sol = - let uu___11 - = - FStar_Syntax_Util.abs - bs'' uvt - FStar_Pervasives_Native.None in - let uu___12 - = - FStar_Compiler_List.map - (fun - uu___13 - -> - match uu___13 - with - | - { - FStar_Syntax_Syntax.binder_bv - = bv2; - FStar_Syntax_Syntax.binder_qual - = uu___14; - FStar_Syntax_Syntax.binder_positivity - = uu___15; - FStar_Syntax_Syntax.binder_attrs - = uu___16;_} - -> - let uu___17 - = - FStar_Syntax_Syntax.bv_to_name - bv2 in - FStar_Syntax_Syntax.as_arg - uu___17) - bs in - FStar_Syntax_Util.mk_app - uu___11 - uu___12 in - let uu___11 - = - set_solution - goal sol in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___11 - (fun - uu___12 - -> - (fun - uu___12 - -> - let uu___12 - = - Obj.magic - uu___12 in - Obj.magic - (FStar_Tactics_Monad.replace_cur - goal')) - uu___12))) - uu___10))))) - | uu___6 -> - Obj.magic - (FStar_Tactics_Monad.fail - "Not an equality hypothesis with a variable on the LHS")) - | uu___5 -> - Obj.magic - (FStar_Tactics_Monad.fail - "Not an equality hypothesis"))) uu___2))) - uu___1) in - FStar_Tactics_Monad.wrap_err "rewrite" uu___ -let (replace : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun t1 -> - fun t2 -> - fun s -> - FStar_Syntax_Visit.visit_term false - (fun t -> - let uu___ = FStar_Syntax_Util.term_eq t t1 in - if uu___ then t2 else t) s -let (grewrite : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> unit FStar_Tactics_Monad.tac) - = - fun t1 -> - fun t2 -> - let uu___ = - let uu___1 = - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___2 -> - (fun goal -> - let goal = Obj.magic goal in - let goal_t = FStar_Tactics_Types.goal_type goal in - let env1 = FStar_Tactics_Types.goal_env goal in - let uu___2 = __tc env1 t1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () (Obj.magic uu___2) - (fun uu___3 -> - (fun uu___3 -> - let uu___3 = Obj.magic uu___3 in - match uu___3 with - | (t11, typ1, g1) -> - let uu___4 = __tc env1 t2 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___4) - (fun uu___5 -> - (fun uu___5 -> - let uu___5 = Obj.magic uu___5 in - match uu___5 with - | (t21, typ2, g2) -> - let typ1' = - FStar_TypeChecker_Normalize.unfold_whnf' - [FStar_TypeChecker_Env.Unrefine] - env1 typ1 in - let typ2' = - FStar_TypeChecker_Normalize.unfold_whnf' - [FStar_TypeChecker_Env.Unrefine] - env1 typ2 in - let uu___6 = - let uu___7 = - do_unify false env1 typ1' - typ2' in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () (Obj.magic uu___7) - (fun uu___8 -> - (fun uu___8 -> - let uu___8 = - Obj.magic uu___8 in - if uu___8 - then - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.repr ())) - else - (let uu___10 = - let uu___11 = - FStar_Errors_Msg.text - "Types do not match for grewrite" in - let uu___12 = - let uu___13 - = - let uu___14 - = - FStar_Errors_Msg.text - "Type of" in - let uu___15 - = - let uu___16 - = - let uu___17 - = - FStar_Class_PP.pp - FStar_Syntax_Print.pretty_term - t11 in - FStar_Pprint.parens - uu___17 in - let uu___17 - = - let uu___18 - = - FStar_Class_PP.pp - FStar_Syntax_Print.pretty_term - typ1 in - FStar_Pprint.op_Hat_Slash_Hat - FStar_Pprint.equals - uu___18 in - FStar_Pprint.op_Hat_Slash_Hat - uu___16 - uu___17 in - FStar_Pprint.op_Hat_Slash_Hat - uu___14 - uu___15 in - let uu___14 - = - let uu___15 - = - let uu___16 - = - FStar_Errors_Msg.text - "Type of" in - let uu___17 - = - let uu___18 - = - let uu___19 - = - FStar_Class_PP.pp - FStar_Syntax_Print.pretty_term - t21 in - FStar_Pprint.parens - uu___19 in - let uu___19 - = - let uu___20 - = - FStar_Class_PP.pp - FStar_Syntax_Print.pretty_term - typ2 in - FStar_Pprint.op_Hat_Slash_Hat - FStar_Pprint.equals - uu___20 in - FStar_Pprint.op_Hat_Slash_Hat - uu___18 - uu___19 in - FStar_Pprint.op_Hat_Slash_Hat - uu___16 - uu___17 in - [uu___15] in - uu___13 :: - uu___14 in - uu___11 :: - uu___12 in - Obj.magic - (FStar_Tactics_Monad.fail_doc - uu___10))) - uu___8) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___6 - (fun uu___7 -> - (fun uu___7 -> - let uu___7 = - Obj.magic uu___7 in - let u = - env1.FStar_TypeChecker_Env.universe_of - env1 typ1 in - let goal_t' = - replace t11 t21 - goal_t in - let uu___8 = - let uu___9 = - FStar_Syntax_Util.mk_eq2 - u typ1 t11 - t21 in - FStar_Tactics_Monad.mk_irrelevant_goal - "grewrite.eq" - env1 uu___9 - FStar_Pervasives_Native.None - (goal.FStar_Tactics_Types.goal_ctx_uvar).FStar_Syntax_Syntax.ctx_uvar_range - goal.FStar_Tactics_Types.opts - goal.FStar_Tactics_Types.label in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic - uu___8) - (fun uu___9 - -> - (fun g_eq - -> - let g_eq - = - Obj.magic - g_eq in - let uu___9 - = - let uu___10 - = - FStar_Tactics_Monad.goal_with_type - goal - goal_t' in - FStar_Tactics_Monad.replace_cur - uu___10 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___9 - (fun - uu___10 - -> - (fun - uu___10 - -> - let uu___10 - = - Obj.magic - uu___10 in - let uu___11 - = - FStar_Tactics_Monad.push_goals - [g_eq] in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___11 - (fun - uu___12 - -> - (fun - uu___12 - -> - let uu___12 - = - Obj.magic - uu___12 in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.repr - ()))) - uu___12))) - uu___10))) - uu___9))) - uu___7))) uu___5))) - uu___3))) uu___2) in - FStar_Tactics_Monad.focus uu___1 in - FStar_Tactics_Monad.wrap_err "grewrite" uu___ -let (rename_to : - FStar_Reflection_V2_Data.binding -> - Prims.string -> FStar_Reflection_V2_Data.binding FStar_Tactics_Monad.tac) - = - fun b -> - fun s -> - let uu___ = - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___1 -> - (fun goal -> - let goal = Obj.magic goal in - let bv = binding_to_bv b in - let bv' = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Ident.range_of_id - bv.FStar_Syntax_Syntax.ppname in - (s, uu___4) in - FStar_Ident.mk_ident uu___3 in - { - FStar_Syntax_Syntax.ppname = uu___2; - FStar_Syntax_Syntax.index = - (bv.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = - (bv.FStar_Syntax_Syntax.sort) - } in - FStar_Syntax_Syntax.freshen_bv uu___1 in - let uu___1 = subst_goal bv bv' goal in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - match uu___2 with - | FStar_Pervasives_Native.None -> - Obj.magic - (Obj.repr - (FStar_Tactics_Monad.fail - "binder not found in environment")) - | FStar_Pervasives_Native.Some (bv'1, goal1) -> - Obj.magic - (Obj.repr - (let uu___3 = - FStar_Tactics_Monad.replace_cur - goal1 in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - uu___3 - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - let uniq = - FStar_BigInt.of_int_fs - bv'1.FStar_Syntax_Syntax.index in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - { - FStar_Reflection_V2_Data.uniq1 - = uniq; - FStar_Reflection_V2_Data.sort3 - = - (b.FStar_Reflection_V2_Data.sort3); - FStar_Reflection_V2_Data.ppname3 - = - (FStar_Compiler_Sealed.seal - s) - }))) uu___4)))) - uu___2))) uu___1)) in - FStar_Tactics_Monad.wrap_err "rename_to" uu___ -let (var_retype : - FStar_Reflection_V2_Data.binding -> unit FStar_Tactics_Monad.tac) = - fun b -> - let uu___ = - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___1 -> - (fun goal -> - let goal = Obj.magic goal in - let bv = binding_to_bv b in - let uu___1 = - let uu___2 = FStar_Tactics_Types.goal_env goal in - split_env bv uu___2 in - match uu___1 with - | FStar_Pervasives_Native.None -> - Obj.magic - (FStar_Tactics_Monad.fail - "binder is not present in environment") - | FStar_Pervasives_Native.Some (e0, bv1, bvs) -> - let uu___2 = FStar_Syntax_Util.type_u () in - (match uu___2 with - | (ty, u) -> - let goal_sc = should_check_goal_uvar goal in - let uu___3 = - let uu___4 = - FStar_Tactics_Monad.goal_typedness_deps goal in - FStar_Tactics_Monad.new_uvar "binder_retype" e0 ty - (FStar_Pervasives_Native.Some goal_sc) uu___4 - (rangeof goal) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___3) - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - match uu___4 with - | (t', u_t') -> - let bv'' = - { - FStar_Syntax_Syntax.ppname = - (bv1.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (bv1.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = t' - } in - let s = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Syntax_Syntax.bv_to_name - bv'' in - (bv1, uu___7) in - FStar_Syntax_Syntax.NT uu___6 in - [uu___5] in - let bvs1 = - FStar_Compiler_List.map - (fun b1 -> - let uu___5 = - FStar_Syntax_Subst.subst s - b1.FStar_Syntax_Syntax.sort in - { - FStar_Syntax_Syntax.ppname = - (b1.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (b1.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = - uu___5 - }) bvs in - let env' = - FStar_TypeChecker_Env.push_bvs e0 - (bv'' :: bvs1) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () - () FStar_Tactics_Monad.dismiss - (fun uu___5 -> - (fun uu___5 -> - let uu___5 = - Obj.magic uu___5 in - let new_goal = - let uu___6 = - FStar_Tactics_Types.goal_with_env - goal env' in - let uu___7 = - let uu___8 = - FStar_Tactics_Types.goal_type - goal in - FStar_Syntax_Subst.subst - s uu___8 in - FStar_Tactics_Monad.goal_with_type - uu___6 uu___7 in - let uu___6 = - FStar_Tactics_Monad.add_goals - [new_goal] in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___6 - (fun uu___7 -> - (fun uu___7 -> - let uu___7 = - Obj.magic - uu___7 in - let uu___8 = - FStar_Syntax_Util.mk_eq2 - (FStar_Syntax_Syntax.U_succ - u) ty - bv1.FStar_Syntax_Syntax.sort - t' in - Obj.magic - (FStar_Tactics_Monad.add_irrelevant_goal - goal - "binder_retype equation" - e0 uu___8 - (FStar_Pervasives_Native.Some - goal_sc))) - uu___7))) uu___5))) - uu___4)))) uu___1) in - FStar_Tactics_Monad.wrap_err "binder_retype" uu___ -let (norm_binding_type : - FStar_Pervasives.norm_step Prims.list -> - FStar_Reflection_V2_Data.binding -> unit FStar_Tactics_Monad.tac) - = - fun s -> - fun b -> - let uu___ = - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___1 -> - (fun goal -> - let goal = Obj.magic goal in - let bv = binding_to_bv b in - let uu___1 = - let uu___2 = FStar_Tactics_Types.goal_env goal in - split_env bv uu___2 in - match uu___1 with - | FStar_Pervasives_Native.None -> - Obj.magic - (FStar_Tactics_Monad.fail - "binder is not present in environment") - | FStar_Pervasives_Native.Some (e0, bv1, bvs) -> - let steps = - let uu___2 = - FStar_TypeChecker_Cfg.translate_norm_steps s in - FStar_Compiler_List.op_At - [FStar_TypeChecker_Env.Reify; - FStar_TypeChecker_Env.DontUnfoldAttr - [FStar_Parser_Const.tac_opaque_attr]] uu___2 in - let sort' = - normalize steps e0 bv1.FStar_Syntax_Syntax.sort in - let bv' = - { - FStar_Syntax_Syntax.ppname = - (bv1.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (bv1.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = sort' - } in - let env' = FStar_TypeChecker_Env.push_bvs e0 (bv' :: bvs) in - let uu___2 = FStar_Tactics_Types.goal_with_env goal env' in - Obj.magic (FStar_Tactics_Monad.replace_cur uu___2)) - uu___1) in - FStar_Tactics_Monad.wrap_err "norm_binding_type" uu___ -let (revert : unit -> unit FStar_Tactics_Monad.tac) = - fun uu___ -> - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___1 -> - (fun goal -> - let goal = Obj.magic goal in - let uu___1 = - let uu___2 = FStar_Tactics_Types.goal_env goal in - FStar_TypeChecker_Env.pop_bv uu___2 in - match uu___1 with - | FStar_Pervasives_Native.None -> - Obj.magic - (FStar_Tactics_Monad.fail "Cannot revert; empty context") - | FStar_Pervasives_Native.Some (x, env') -> - let typ' = - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.mk_binder x in [uu___3] in - let uu___3 = - let uu___4 = FStar_Tactics_Types.goal_type goal in - FStar_Syntax_Syntax.mk_Total uu___4 in - FStar_Syntax_Util.arrow uu___2 uu___3 in - let uu___2 = - let uu___3 = - let uu___4 = should_check_goal_uvar goal in - FStar_Pervasives_Native.Some uu___4 in - let uu___4 = FStar_Tactics_Monad.goal_typedness_deps goal in - FStar_Tactics_Monad.new_uvar "revert" env' typ' uu___3 - uu___4 (rangeof goal) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () (Obj.magic uu___2) - (fun uu___3 -> - (fun uu___3 -> - let uu___3 = Obj.magic uu___3 in - match uu___3 with - | (r, u_r) -> - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Syntax_Syntax.bv_to_name x in - FStar_Syntax_Syntax.as_arg uu___8 in - [uu___7] in - let uu___7 = - let uu___8 = - FStar_Tactics_Types.goal_type goal in - uu___8.FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.mk_Tm_app r uu___6 - uu___7 in - set_solution goal uu___5 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - uu___4 - (fun uu___5 -> - (fun uu___5 -> - let uu___5 = Obj.magic uu___5 in - let g = - FStar_Tactics_Types.mk_goal env' - u_r - goal.FStar_Tactics_Types.opts - goal.FStar_Tactics_Types.is_guard - goal.FStar_Tactics_Types.label in - Obj.magic - (FStar_Tactics_Monad.replace_cur - g)) uu___5))) uu___3))) uu___1) -let (free_in : - FStar_Syntax_Syntax.bv -> FStar_Syntax_Syntax.term -> Prims.bool) = - fun bv -> - fun t -> - let uu___ = FStar_Syntax_Free.names t in - FStar_Class_Setlike.mem () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) bv (Obj.magic uu___) -let (clear : - FStar_Reflection_V2_Data.binding -> unit FStar_Tactics_Monad.tac) = - fun b -> - let bv = binding_to_bv b in - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___ -> - (fun goal -> - let goal = Obj.magic goal in - let uu___ = - FStar_Tactics_Monad.if_verbose - (fun uu___1 -> - let uu___2 = binding_to_string b in - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = FStar_Tactics_Types.goal_env goal in - FStar_TypeChecker_Env.all_binders uu___6 in - FStar_Compiler_List.length uu___5 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_nat) uu___4 in - FStar_Compiler_Util.print2 - "Clear of (%s), env has %s binders\n" uu___2 uu___3) in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - () uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - let uu___2 = - let uu___3 = FStar_Tactics_Types.goal_env goal in - split_env bv uu___3 in - match uu___2 with - | FStar_Pervasives_Native.None -> - Obj.magic - (FStar_Tactics_Monad.fail - "Cannot clear; binder not in environment") - | FStar_Pervasives_Native.Some (e', bv1, bvs) -> - let rec check bvs1 = - match bvs1 with - | [] -> - FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.repr ()) - | bv'::bvs2 -> - let uu___3 = - free_in bv1 bv'.FStar_Syntax_Syntax.sort in - if uu___3 - then - let uu___4 = - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_bv bv' in - FStar_Compiler_Util.format1 - "Cannot clear; binder present in the type of %s" - uu___5 in - FStar_Tactics_Monad.fail uu___4 - else check bvs2 in - let uu___3 = - let uu___4 = FStar_Tactics_Types.goal_type goal in - free_in bv1 uu___4 in - if uu___3 - then - Obj.magic - (FStar_Tactics_Monad.fail - "Cannot clear; binder present in goal") - else - (let uu___5 = check bvs in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () uu___5 - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = Obj.magic uu___6 in - let env' = - FStar_TypeChecker_Env.push_bvs e' - bvs in - let uu___7 = - let uu___8 = - FStar_Tactics_Types.goal_type - goal in - let uu___9 = - let uu___10 = - should_check_goal_uvar goal in - FStar_Pervasives_Native.Some - uu___10 in - let uu___10 = - FStar_Tactics_Monad.goal_typedness_deps - goal in - FStar_Tactics_Monad.new_uvar - "clear.witness" env' uu___8 - uu___9 uu___10 (rangeof goal) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () (Obj.magic uu___7) - (fun uu___8 -> - (fun uu___8 -> - let uu___8 = - Obj.magic uu___8 in - match uu___8 with - | (ut, uvar_ut) -> - let uu___9 = - set_solution goal - ut in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___9 - (fun uu___10 -> - (fun uu___10 - -> - let uu___10 - = - Obj.magic - uu___10 in - let uu___11 - = - FStar_Tactics_Types.mk_goal - env' - uvar_ut - goal.FStar_Tactics_Types.opts - goal.FStar_Tactics_Types.is_guard - goal.FStar_Tactics_Types.label in - Obj.magic - (FStar_Tactics_Monad.replace_cur - uu___11)) - uu___10))) - uu___8))) uu___6)))) - uu___1))) uu___) -let (clear_top : unit -> unit FStar_Tactics_Monad.tac) = - fun uu___ -> - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___1 -> - (fun goal -> - let goal = Obj.magic goal in - let uu___1 = - let uu___2 = FStar_Tactics_Types.goal_env goal in - FStar_TypeChecker_Env.pop_bv uu___2 in - match uu___1 with - | FStar_Pervasives_Native.None -> - Obj.magic - (FStar_Tactics_Monad.fail "Cannot clear; empty context") - | FStar_Pervasives_Native.Some (x, uu___2) -> - let uu___3 = bv_to_binding x in Obj.magic (clear uu___3)) - uu___1) -let (prune : Prims.string -> unit FStar_Tactics_Monad.tac) = - fun s -> - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___ -> - (fun g -> - let g = Obj.magic g in - let ctx = FStar_Tactics_Types.goal_env g in - let ctx' = - let uu___ = FStar_Ident.path_of_text s in - FStar_TypeChecker_Env.rem_proof_ns ctx uu___ in - let g' = FStar_Tactics_Types.goal_with_env g ctx' in - Obj.magic (FStar_Tactics_Monad.replace_cur g')) uu___) -let (addns : Prims.string -> unit FStar_Tactics_Monad.tac) = - fun s -> - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___ -> - (fun g -> - let g = Obj.magic g in - let ctx = FStar_Tactics_Types.goal_env g in - let ctx' = - let uu___ = FStar_Ident.path_of_text s in - FStar_TypeChecker_Env.add_proof_ns ctx uu___ in - let g' = FStar_Tactics_Types.goal_with_env g ctx' in - Obj.magic (FStar_Tactics_Monad.replace_cur g')) uu___) -let (guard_formula : - FStar_TypeChecker_Common.guard_t -> FStar_Syntax_Syntax.term) = - fun g -> - match g.FStar_TypeChecker_Common.guard_f with - | FStar_TypeChecker_Common.Trivial -> FStar_Syntax_Util.t_true - | FStar_TypeChecker_Common.NonTrivial f -> f -let (_t_trefl : - Prims.bool -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> unit FStar_Tactics_Monad.tac) - = - fun allow_guards -> - fun l -> - fun r -> - let should_register_trefl g = - let should_register = true in - let skip_register = false in - let uu___ = - let uu___1 = FStar_Options.compat_pre_core_should_register () in - Prims.op_Negation uu___1 in - if uu___ - then skip_register - else - (let is_uvar_untyped_or_already_checked u = - let dec = - FStar_Syntax_Unionfind.find_decoration - u.FStar_Syntax_Syntax.ctx_uvar_head in - match dec.FStar_Syntax_Syntax.uvar_decoration_should_check - with - | FStar_Syntax_Syntax.Allow_untyped uu___2 -> true - | FStar_Syntax_Syntax.Already_checked -> true - | uu___2 -> false in - let is_uvar t = - let head = FStar_Syntax_Util.leftmost_head t in - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress head in - uu___3.FStar_Syntax_Syntax.n in - match uu___2 with - | FStar_Syntax_Syntax.Tm_uvar (u, uu___3) -> - FStar_Pervasives.Inl (u, head, t) - | uu___3 -> FStar_Pervasives.Inr t in - let is_allow_untyped_uvar t = - let uu___2 = is_uvar t in - match uu___2 with - | FStar_Pervasives.Inr uu___3 -> false - | FStar_Pervasives.Inl (u, uu___3, uu___4) -> - is_uvar_untyped_or_already_checked u in - let t = - FStar_Syntax_Util.ctx_uvar_typ - g.FStar_Tactics_Types.goal_ctx_uvar in - let uvars = FStar_Syntax_Free.uvars t in - let uu___2 = - FStar_Class_Setlike.for_all () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) - is_uvar_untyped_or_already_checked (Obj.magic uvars) in - if uu___2 - then skip_register - else - (let uu___4 = - let t1 = - let uu___5 = FStar_Syntax_Util.un_squash t in - match uu___5 with - | FStar_Pervasives_Native.None -> t - | FStar_Pervasives_Native.Some t2 -> t2 in - FStar_Syntax_Util.leftmost_head_and_args t1 in - match uu___4 with - | (head, args) -> - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = FStar_Syntax_Util.un_uinst head in - FStar_Syntax_Subst.compress uu___8 in - uu___7.FStar_Syntax_Syntax.n in - (uu___6, args) in - (match uu___5 with - | (FStar_Syntax_Syntax.Tm_fvar fv, - (ty, uu___6)::(t1, uu___7)::(t2, uu___8)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.eq2_lid - -> - let uu___9 = - (is_allow_untyped_uvar t1) || - (is_allow_untyped_uvar t2) in - if uu___9 - then skip_register - else - (let uu___11 = - FStar_Tactics_Monad.is_goal_safe_as_well_typed - g in - if uu___11 - then - let check_uvar_subtype u t3 = - let env1 = - let uu___12 = - FStar_Tactics_Types.goal_env g in - { - FStar_TypeChecker_Env.solver = - (uu___12.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (uu___12.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (uu___12.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - ((g.FStar_Tactics_Types.goal_ctx_uvar).FStar_Syntax_Syntax.ctx_uvar_gamma); - FStar_TypeChecker_Env.gamma_sig = - (uu___12.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (uu___12.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (uu___12.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (uu___12.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (uu___12.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (uu___12.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (uu___12.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (uu___12.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (uu___12.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (uu___12.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (uu___12.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (uu___12.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (uu___12.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (uu___12.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (uu___12.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (uu___12.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (uu___12.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (uu___12.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (uu___12.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (uu___12.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (uu___12.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (uu___12.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (uu___12.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (uu___12.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (uu___12.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (uu___12.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (uu___12.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (uu___12.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (uu___12.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (uu___12.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (uu___12.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (uu___12.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (uu___12.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (uu___12.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (uu___12.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (uu___12.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (uu___12.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (uu___12.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (uu___12.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (uu___12.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (uu___12.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (uu___12.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (uu___12.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (uu___12.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (uu___12.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (uu___12.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (uu___12.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (uu___12.FStar_TypeChecker_Env.missing_decl) - } in - let uu___12 = - FStar_TypeChecker_Core.compute_term_type_handle_guards - env1 t3 - (fun uu___13 -> fun uu___14 -> true) in - match uu___12 with - | FStar_Pervasives.Inr uu___13 -> false - | FStar_Pervasives.Inl (uu___13, t_ty) -> - let uu___14 = - FStar_TypeChecker_Core.check_term_subtyping - true true env1 ty t_ty in - (match uu___14 with - | FStar_Pervasives.Inl - (FStar_Pervasives_Native.None) -> - (FStar_Tactics_Monad.mark_uvar_as_already_checked - u; - true) - | uu___15 -> false) in - let uu___12 = - let uu___13 = is_uvar t1 in - let uu___14 = is_uvar t2 in - (uu___13, uu___14) in - match uu___12 with - | (FStar_Pervasives.Inl (u, uu___13, tu), - FStar_Pervasives.Inr uu___14) -> - let uu___15 = check_uvar_subtype u tu in - (if uu___15 - then skip_register - else should_register) - | (FStar_Pervasives.Inr uu___13, - FStar_Pervasives.Inl (u, uu___14, tu)) -> - let uu___15 = check_uvar_subtype u tu in - (if uu___15 - then skip_register - else should_register) - | uu___13 -> should_register - else should_register) - | uu___6 -> should_register))) in - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___ -> - (fun g -> - let g = Obj.magic g in - let should_check = should_check_goal_uvar g in - (let uu___1 = should_register_trefl g in - if uu___1 then FStar_Tactics_Monad.register_goal g else ()); - (let must_tot = true in - let attempt uu___2 uu___1 = - (fun l1 -> - fun r1 -> - let uu___1 = - let uu___2 = FStar_Tactics_Types.goal_env g in - do_unify_maybe_guards allow_guards must_tot uu___2 - l1 r1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - match uu___2 with - | FStar_Pervasives_Native.None -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic false)) - | FStar_Pervasives_Native.Some guard -> - let uu___3 = - solve' g FStar_Syntax_Util.exp_unit in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () - () uu___3 - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = - Obj.magic uu___4 in - if allow_guards - then - Obj.magic - (Obj.repr - (let uu___5 = - let uu___6 = - FStar_Tactics_Types.goal_env - g in - let uu___7 = - guard_formula - guard in - FStar_Tactics_Monad.goal_of_guard - "t_trefl" - uu___6 uu___7 - (FStar_Pervasives_Native.Some - should_check) - (rangeof g) in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic uu___5) - (fun uu___6 -> - (fun goal -> - let goal = - Obj.magic - goal in - let uu___6 - = - FStar_Tactics_Monad.push_goals - [goal] in - Obj.magic - ( - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___6 - (fun - uu___7 -> - (fun - uu___7 -> - let uu___7 - = - Obj.magic - uu___7 in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - true))) - uu___7))) - uu___6))) - else - Obj.magic - (Obj.repr - (let uu___6 = - FStar_TypeChecker_Env.is_trivial_guard_formula - guard in - if uu___6 - then - Obj.repr - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - true)) - else - Obj.repr - (failwith - "internal error: _t_refl: guard is not trivial")))) - uu___4))) uu___2))) uu___2 - uu___1 in - let uu___1 = attempt l r in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - if uu___2 - then - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.repr ())) - else - (let norm1 = - let uu___3 = FStar_Tactics_Types.goal_env g in - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.DontUnfoldAttr - [FStar_Parser_Const.tac_opaque_attr]] - uu___3 in - let uu___3 = - let uu___4 = norm1 l in - let uu___5 = norm1 r in - attempt uu___4 uu___5 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___3) - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - if uu___4 - then - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () (Obj.repr ())) - else - (let uu___5 = - let uu___6 = - let uu___7 = - FStar_Tactics_Types.goal_env - g in - tts uu___7 in - FStar_TypeChecker_Err.print_discrepancy - uu___6 l r in - match uu___5 with - | (ls, rs) -> - Obj.magic - (fail2 - "cannot unify (%s) and (%s)" - ls rs))) uu___4)))) - uu___2)))) uu___) -let (t_trefl : Prims.bool -> unit FStar_Tactics_Monad.tac) = - fun allow_guards -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___3 -> - (fun g -> - let g = Obj.magic g in - let uu___3 = - let uu___4 = FStar_Tactics_Types.goal_env g in - let uu___5 = FStar_Tactics_Types.goal_type g in - destruct_eq uu___4 uu___5 in - match uu___3 with - | FStar_Pervasives_Native.Some (l, r) -> - Obj.magic (_t_trefl allow_guards l r) - | FStar_Pervasives_Native.None -> - let uu___4 = - let uu___5 = FStar_Tactics_Types.goal_env g in - let uu___6 = FStar_Tactics_Types.goal_type g in - tts uu___5 uu___6 in - Obj.magic (fail1 "not an equality (%s)" uu___4)) uu___3) in - FStar_Tactics_Monad.catch uu___2 in - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - match uu___2 with - | FStar_Pervasives.Inr v -> - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac - () (Obj.repr ())) - | FStar_Pervasives.Inl exn -> - Obj.magic (FStar_Tactics_Monad.traise exn)) uu___2) in - FStar_Tactics_Monad.wrap_err "t_trefl" uu___ -let (dup : unit -> unit FStar_Tactics_Monad.tac) = - fun uu___ -> - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___1 -> - (fun g -> - let g = Obj.magic g in - let goal_sc = should_check_goal_uvar g in - let env1 = FStar_Tactics_Types.goal_env g in - let uu___1 = - let uu___2 = FStar_Tactics_Types.goal_type g in - let uu___3 = - let uu___4 = should_check_goal_uvar g in - FStar_Pervasives_Native.Some uu___4 in - let uu___4 = FStar_Tactics_Monad.goal_typedness_deps g in - FStar_Tactics_Monad.new_uvar "dup" env1 uu___2 uu___3 uu___4 - (rangeof g) in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - () (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - match uu___2 with - | (u, u_uvar) -> - (FStar_Tactics_Monad.mark_uvar_as_already_checked - g.FStar_Tactics_Types.goal_ctx_uvar; - (let g' = - { - FStar_Tactics_Types.goal_main_env = - (g.FStar_Tactics_Types.goal_main_env); - FStar_Tactics_Types.goal_ctx_uvar = u_uvar; - FStar_Tactics_Types.opts = - (g.FStar_Tactics_Types.opts); - FStar_Tactics_Types.is_guard = - (g.FStar_Tactics_Types.is_guard); - FStar_Tactics_Types.label = - (g.FStar_Tactics_Types.label) - } in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - FStar_Tactics_Monad.dismiss - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - let t_eq = - let uu___5 = - let uu___6 = - FStar_Tactics_Types.goal_type g in - env1.FStar_TypeChecker_Env.universe_of - env1 uu___6 in - let uu___6 = - FStar_Tactics_Types.goal_type g in - let uu___7 = - FStar_Tactics_Types.goal_witness - g in - FStar_Syntax_Util.mk_eq2 uu___5 - uu___6 u uu___7 in - let uu___5 = - FStar_Tactics_Monad.add_irrelevant_goal - g "dup equation" env1 t_eq - (FStar_Pervasives_Native.Some - goal_sc) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () - () uu___5 - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = - Obj.magic uu___6 in - Obj.magic - (FStar_Tactics_Monad.add_goals - [g'])) uu___6))) - uu___4))))) uu___2))) uu___1) -let longest_prefix : - 'a . - ('a -> 'a -> Prims.bool) -> - 'a Prims.list -> - 'a Prims.list -> ('a Prims.list * 'a Prims.list * 'a Prims.list) - = - fun f -> - fun l1 -> - fun l2 -> - let rec aux acc l11 l21 = - match (l11, l21) with - | (x::xs, y::ys) -> - let uu___ = f x y in - if uu___ - then aux (x :: acc) xs ys - else (acc, (x :: xs), (y :: ys)) - | uu___ -> (acc, l11, l21) in - let uu___ = aux [] l1 l2 in - match uu___ with - | (pr, t1, t2) -> ((FStar_Compiler_List.rev pr), t1, t2) -let (eq_binding : - FStar_Syntax_Syntax.binding -> FStar_Syntax_Syntax.binding -> Prims.bool) = - fun b1 -> fun b2 -> false -let (join_goals : - FStar_Tactics_Types.goal -> - FStar_Tactics_Types.goal -> - FStar_Tactics_Types.goal FStar_Tactics_Monad.tac) - = - fun uu___1 -> - fun uu___ -> - (fun g1 -> - fun g2 -> - let close_forall_no_univs bs f = - FStar_Compiler_List.fold_right - (fun b -> - fun f1 -> - FStar_Syntax_Util.mk_forall_no_univ - b.FStar_Syntax_Syntax.binder_bv f1) bs f in - let uu___ = FStar_Tactics_Monad.get_phi g1 in - match uu___ with - | FStar_Pervasives_Native.None -> - Obj.magic - (Obj.repr - (FStar_Tactics_Monad.fail "goal 1 is not irrelevant")) - | FStar_Pervasives_Native.Some phi1 -> - Obj.magic - (Obj.repr - (let uu___1 = FStar_Tactics_Monad.get_phi g2 in - match uu___1 with - | FStar_Pervasives_Native.None -> - Obj.repr - (FStar_Tactics_Monad.fail - "goal 2 is not irrelevant") - | FStar_Pervasives_Native.Some phi2 -> - Obj.repr - (let gamma1 = - (g1.FStar_Tactics_Types.goal_ctx_uvar).FStar_Syntax_Syntax.ctx_uvar_gamma in - let gamma2 = - (g2.FStar_Tactics_Types.goal_ctx_uvar).FStar_Syntax_Syntax.ctx_uvar_gamma in - let uu___2 = - longest_prefix eq_binding - (FStar_Compiler_List.rev gamma1) - (FStar_Compiler_List.rev gamma2) in - match uu___2 with - | (gamma, r1, r2) -> - let t1 = - let uu___3 = - FStar_TypeChecker_Env.binders_of_bindings - (FStar_Compiler_List.rev r1) in - close_forall_no_univs uu___3 phi1 in - let t2 = - let uu___3 = - FStar_TypeChecker_Env.binders_of_bindings - (FStar_Compiler_List.rev r2) in - close_forall_no_univs uu___3 phi2 in - let goal_sc = - let uu___3 = - let uu___4 = should_check_goal_uvar g1 in - let uu___5 = should_check_goal_uvar g2 in - (uu___4, uu___5) in - match uu___3 with - | (FStar_Syntax_Syntax.Allow_untyped - reason1, - FStar_Syntax_Syntax.Allow_untyped - uu___4) -> - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Allow_untyped - reason1) - | uu___4 -> FStar_Pervasives_Native.None in - let ng = FStar_Syntax_Util.mk_conj t1 t2 in - let nenv = - let uu___3 = - FStar_Tactics_Types.goal_env g1 in - { - FStar_TypeChecker_Env.solver = - (uu___3.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (uu___3.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (uu___3.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (FStar_Compiler_List.rev gamma); - FStar_TypeChecker_Env.gamma_sig = - (uu___3.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (uu___3.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (uu___3.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (uu___3.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (uu___3.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (uu___3.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (uu___3.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (uu___3.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (uu___3.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (uu___3.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (uu___3.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (uu___3.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (uu___3.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (uu___3.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (uu___3.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (uu___3.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (uu___3.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (uu___3.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (uu___3.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (uu___3.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (uu___3.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (uu___3.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (uu___3.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (uu___3.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (uu___3.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (uu___3.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (uu___3.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (uu___3.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (uu___3.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (uu___3.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (uu___3.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (uu___3.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (uu___3.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (uu___3.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (uu___3.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (uu___3.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (uu___3.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (uu___3.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (uu___3.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (uu___3.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (uu___3.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (uu___3.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (uu___3.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (uu___3.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (uu___3.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (uu___3.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (uu___3.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (uu___3.FStar_TypeChecker_Env.missing_decl) - } in - let uu___3 = - FStar_Tactics_Monad.mk_irrelevant_goal - "joined" nenv ng goal_sc (rangeof g1) - g1.FStar_Tactics_Types.opts - g1.FStar_Tactics_Types.label in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___3) - (fun uu___4 -> - (fun goal -> - let goal = Obj.magic goal in - let uu___4 = - FStar_Tactics_Monad.if_verbose - (fun uu___5 -> - let uu___6 = - FStar_Tactics_Printing.goal_to_string_verbose - g1 in - let uu___7 = - FStar_Tactics_Printing.goal_to_string_verbose - g2 in - let uu___8 = - FStar_Tactics_Printing.goal_to_string_verbose - goal in - FStar_Compiler_Util.print3 - "join_goals of\n(%s)\nand\n(%s)\n= (%s)\n" - uu___6 uu___7 uu___8) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () - () uu___4 - (fun uu___5 -> - (fun uu___5 -> - let uu___5 = - Obj.magic uu___5 in - let uu___6 = - set_solution g1 - FStar_Syntax_Util.exp_unit in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___6 - (fun uu___7 -> - (fun uu___7 -> - let uu___7 = - Obj.magic - uu___7 in - let uu___8 = - set_solution - g2 - FStar_Syntax_Util.exp_unit in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___8 - (fun - uu___9 -> - (fun - uu___9 -> - let uu___9 - = - Obj.magic - uu___9 in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - goal))) - uu___9))) - uu___7))) uu___5))) - uu___4))))) uu___1 uu___ -let (join : unit -> unit FStar_Tactics_Monad.tac) = - fun uu___ -> - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.get) - (fun uu___1 -> - (fun ps -> - let ps = Obj.magic ps in - match ps.FStar_Tactics_Types.goals with - | g1::g2::gs -> - let uu___1 = - FStar_Tactics_Monad.set - { - FStar_Tactics_Types.main_context = - (ps.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits = - (ps.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = gs; - FStar_Tactics_Types.smt_goals = - (ps.FStar_Tactics_Types.smt_goals); - FStar_Tactics_Types.depth = - (ps.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = - (ps.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = (ps.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (ps.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = - (ps.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness = - (ps.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg = - (ps.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = - (ps.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency = - (ps.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure = - (ps.FStar_Tactics_Types.dump_on_failure) - } in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () uu___1 - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - let uu___3 = join_goals g1 g2 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___3) - (fun uu___4 -> - (fun g12 -> - let g12 = Obj.magic g12 in - Obj.magic - (FStar_Tactics_Monad.add_goals [g12])) - uu___4))) uu___2)) - | uu___1 -> - Obj.magic - (FStar_Tactics_Monad.fail "join: less than 2 goals")) - uu___1) -let (set_options : Prims.string -> unit FStar_Tactics_Monad.tac) = - fun s -> - let uu___ = - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___1 -> - (fun g -> - let g = Obj.magic g in - FStar_Options.push (); - FStar_Options.set g.FStar_Tactics_Types.opts; - (let res = FStar_Options.set_options s in - let opts' = FStar_Options.peek () in - FStar_Options.pop (); - (match res with - | FStar_Getopt.Success -> - let g' = - { - FStar_Tactics_Types.goal_main_env = - (g.FStar_Tactics_Types.goal_main_env); - FStar_Tactics_Types.goal_ctx_uvar = - (g.FStar_Tactics_Types.goal_ctx_uvar); - FStar_Tactics_Types.opts = opts'; - FStar_Tactics_Types.is_guard = - (g.FStar_Tactics_Types.is_guard); - FStar_Tactics_Types.label = - (g.FStar_Tactics_Types.label) - } in - Obj.magic (FStar_Tactics_Monad.replace_cur g') - | FStar_Getopt.Error err -> - Obj.magic (fail2 "Setting options `%s` failed: %s" s err) - | FStar_Getopt.Help -> - Obj.magic - (fail1 "Setting options `%s` failed (got `Help`?)" s)))) - uu___1) in - FStar_Tactics_Monad.wrap_err "set_options" uu___ -let (top_env : unit -> env FStar_Tactics_Monad.tac) = - fun uu___ -> - (fun uu___ -> - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.get) - (fun uu___1 -> - (fun ps -> - let ps = Obj.magic ps in - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac - () (Obj.magic ps.FStar_Tactics_Types.main_context))) - uu___1))) uu___ -let (lax_on : unit -> Prims.bool FStar_Tactics_Monad.tac) = - fun uu___ -> - (fun uu___ -> - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.get) - (fun uu___1 -> - (fun ps -> - let ps = Obj.magic ps in - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac - () - (Obj.magic - (ps.FStar_Tactics_Types.main_context).FStar_TypeChecker_Env.admit))) - uu___1))) uu___ -let (unquote : - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term FStar_Tactics_Monad.tac) - = - fun ty -> - fun tm -> - let uu___ = - let uu___1 = - FStar_Tactics_Monad.if_verbose - (fun uu___2 -> - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term tm in - FStar_Compiler_Util.print1 "unquote: tm = %s\n" uu___3) in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___1 - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___3 -> - (fun goal -> - let goal = Obj.magic goal in - let env1 = - let uu___3 = - FStar_Tactics_Types.goal_env goal in - FStar_TypeChecker_Env.set_expected_typ uu___3 - ty in - let uu___3 = __tc_ghost env1 tm in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___3) - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - match uu___4 with - | (tm1, typ, guard) -> - let uu___5 = - FStar_Tactics_Monad.if_verbose - (fun uu___6 -> - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - tm1 in - FStar_Compiler_Util.print1 - "unquote: tm' = %s\n" - uu___7) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___5 - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = - Obj.magic uu___6 in - let uu___7 = - FStar_Tactics_Monad.if_verbose - (fun uu___8 -> - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - typ in - FStar_Compiler_Util.print1 - "unquote: typ = %s\n" - uu___9) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___7 - (fun uu___8 -> - (fun uu___8 - -> - let uu___8 - = - Obj.magic - uu___8 in - let uu___9 - = - let uu___10 - = - let uu___11 - = - should_check_goal_uvar - goal in - FStar_Pervasives_Native.Some - uu___11 in - proc_guard - "unquote" - env1 - guard - uu___10 - (rangeof - goal) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___9 - (fun - uu___10 - -> - (fun - uu___10 - -> - let uu___10 - = - Obj.magic - uu___10 in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - tm1))) - uu___10))) - uu___8))) - uu___6))) uu___4))) - uu___3))) uu___2)) in - FStar_Tactics_Monad.wrap_err "unquote" uu___ -let (uvar_env : - env -> - FStar_Syntax_Syntax.typ FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.term FStar_Tactics_Monad.tac) - = - fun uu___1 -> - fun uu___ -> - (fun env1 -> - fun ty -> - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - () (Obj.magic FStar_Tactics_Monad.get) - (fun uu___ -> - (fun ps -> - let ps = Obj.magic ps in - let uu___ = - match ty with - | FStar_Pervasives_Native.Some ty1 -> - let env2 = - let uu___1 = - let uu___2 = FStar_Syntax_Util.type_u () in - FStar_Pervasives_Native.fst uu___2 in - FStar_TypeChecker_Env.set_expected_typ env1 - uu___1 in - let uu___1 = __tc_ghost env2 ty1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - match uu___2 with - | (ty2, uu___3, g) -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - (ty2, g, - (ty2.FStar_Syntax_Syntax.pos))))) - uu___2)) - | FStar_Pervasives_Native.None -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.type_u () in - FStar_Pervasives_Native.fst uu___3 in - FStar_Tactics_Monad.new_uvar "uvar_env.2" env1 - uu___2 FStar_Pervasives_Native.None [] - ps.FStar_Tactics_Types.entry_range in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - match uu___2 with - | (typ, uvar_typ) -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - (typ, - FStar_TypeChecker_Env.trivial_guard, - FStar_Compiler_Range_Type.dummyRange)))) - uu___2)) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___) - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - match uu___1 with - | (typ, g, r) -> - let uu___2 = - proc_guard "uvar_env_typ" env1 g - FStar_Pervasives_Native.None r in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - uu___2 - (fun uu___3 -> - (fun uu___3 -> - let uu___3 = Obj.magic uu___3 in - let uu___4 = - FStar_Tactics_Monad.new_uvar - "uvar_env" env1 typ - FStar_Pervasives_Native.None - [] - ps.FStar_Tactics_Types.entry_range in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () (Obj.magic uu___4) - (fun uu___5 -> - (fun uu___5 -> - let uu___5 = - Obj.magic uu___5 in - match uu___5 with - | (t, uvar_t) -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - ( - Obj.magic - t))) - uu___5))) uu___3))) - uu___1))) uu___))) uu___1 uu___ -let (ghost_uvar_env : - env -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.term FStar_Tactics_Monad.tac) - = - fun uu___1 -> - fun uu___ -> - (fun env1 -> - fun ty -> - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - () (Obj.magic FStar_Tactics_Monad.get) - (fun uu___ -> - (fun ps -> - let ps = Obj.magic ps in - let uu___ = __tc_ghost env1 ty in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___) - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - match uu___1 with - | (typ, uu___2, g) -> - let uu___3 = - proc_guard "ghost_uvar_env_typ" env1 g - FStar_Pervasives_Native.None - ty.FStar_Syntax_Syntax.pos in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - uu___3 - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - let uu___5 = - FStar_Tactics_Monad.new_uvar - "uvar_env" env1 typ - (FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Allow_ghost - "User ghost uvar")) - [] - ps.FStar_Tactics_Types.entry_range in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () (Obj.magic uu___5) - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = - Obj.magic uu___6 in - match uu___6 with - | (t, uvar_t) -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - ( - Obj.magic - t))) - uu___6))) uu___4))) - uu___1))) uu___))) uu___1 uu___ -let (fresh_universe_uvar : - unit -> FStar_Syntax_Syntax.term FStar_Tactics_Monad.tac) = - fun uu___ -> - (fun uu___ -> - let uu___1 = - let uu___2 = FStar_Syntax_Util.type_u () in - FStar_Pervasives_Native.fst uu___2 in - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.magic uu___1))) uu___ -let (unshelve : FStar_Syntax_Syntax.term -> unit FStar_Tactics_Monad.tac) = - fun t -> - let uu___ = - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.get) - (fun uu___1 -> - (fun ps -> - let ps = Obj.magic ps in - let env1 = ps.FStar_Tactics_Types.main_context in - let opts = - match ps.FStar_Tactics_Types.goals with - | g::uu___1 -> g.FStar_Tactics_Types.opts - | uu___1 -> FStar_Options.peek () in - let uu___1 = FStar_Syntax_Util.head_and_args t in - match uu___1 with - | ({ - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_uvar - (ctx_uvar, uu___2); - FStar_Syntax_Syntax.pos = uu___3; - FStar_Syntax_Syntax.vars = uu___4; - FStar_Syntax_Syntax.hash_code = uu___5;_}, - uu___6) -> - let env2 = - { - FStar_TypeChecker_Env.solver = - (env1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (ctx_uvar.FStar_Syntax_Syntax.ctx_uvar_gamma); - FStar_TypeChecker_Env.gamma_sig = - (env1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (env1.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env1.FStar_TypeChecker_Env.missing_decl) - } in - let g = - FStar_Tactics_Types.mk_goal env2 ctx_uvar opts false "" in - let g1 = bnorm_goal g in - Obj.magic (FStar_Tactics_Monad.add_goals [g1]) - | uu___2 -> Obj.magic (FStar_Tactics_Monad.fail "not a uvar")) - uu___1) in - FStar_Tactics_Monad.wrap_err "unshelve" uu___ -let (tac_and : - Prims.bool FStar_Tactics_Monad.tac -> - Prims.bool FStar_Tactics_Monad.tac -> Prims.bool FStar_Tactics_Monad.tac) - = - fun uu___1 -> - fun uu___ -> - (fun t1 -> - fun t2 -> - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - () (Obj.magic t1) - (fun uu___ -> - (fun uu___ -> - let uu___ = Obj.magic uu___ in - if uu___ - then Obj.magic (Obj.repr t2) - else - Obj.magic - (Obj.repr - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic false)))) uu___))) uu___1 uu___ -let default_if_err : - 'a . 'a -> 'a FStar_Tactics_Monad.tac -> 'a FStar_Tactics_Monad.tac = - fun uu___1 -> - fun uu___ -> - (fun def -> - fun t -> - let uu___ = FStar_Tactics_Monad.catch t in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - () (Obj.magic uu___) - (fun uu___1 -> - (fun r -> - let r = Obj.magic r in - match r with - | FStar_Pervasives.Inl uu___1 -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic def)) - | FStar_Pervasives.Inr v -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () (Obj.magic v))) - uu___1))) uu___1 uu___ -let (match_env : - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> Prims.bool FStar_Tactics_Monad.tac) - = - fun e -> - fun t1 -> - fun t2 -> - let uu___ = - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - () (Obj.magic FStar_Tactics_Monad.get) - (fun uu___1 -> - (fun ps -> - let ps = Obj.magic ps in - let uu___1 = __tc e t1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - match uu___2 with - | (t11, ty1, g1) -> - let uu___3 = __tc e t2 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___3) - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - match uu___4 with - | (t21, ty2, g2) -> - let uu___5 = - proc_guard - "match_env g1" e g1 - FStar_Pervasives_Native.None - ps.FStar_Tactics_Types.entry_range in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___5 - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = - Obj.magic - uu___6 in - let uu___7 = - proc_guard - "match_env g2" - e g2 - FStar_Pervasives_Native.None - ps.FStar_Tactics_Types.entry_range in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___7 - (fun - uu___8 -> - (fun - uu___8 -> - let uu___8 - = - Obj.magic - uu___8 in - let must_tot - = true in - let uu___9 - = - let uu___10 - = - do_match - must_tot - e ty1 ty2 in - let uu___11 - = - do_match - must_tot - e t11 t21 in - tac_and - uu___10 - uu___11 in - Obj.magic - (default_if_err - false - uu___9)) - uu___8))) - uu___6))) uu___4))) - uu___2))) uu___1)) in - FStar_Tactics_Monad.wrap_err "match_env" uu___ -let (unify_env : - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> Prims.bool FStar_Tactics_Monad.tac) - = - fun e -> - fun t1 -> - fun t2 -> - let uu___ = - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - () (Obj.magic FStar_Tactics_Monad.get) - (fun uu___1 -> - (fun ps -> - let ps = Obj.magic ps in - let uu___1 = __tc e t1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - match uu___2 with - | (t11, ty1, g1) -> - let uu___3 = __tc e t2 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___3) - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - match uu___4 with - | (t21, ty2, g2) -> - let uu___5 = - proc_guard - "unify_env g1" e g1 - FStar_Pervasives_Native.None - ps.FStar_Tactics_Types.entry_range in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___5 - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = - Obj.magic - uu___6 in - let uu___7 = - proc_guard - "unify_env g2" - e g2 - FStar_Pervasives_Native.None - ps.FStar_Tactics_Types.entry_range in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___7 - (fun - uu___8 -> - (fun - uu___8 -> - let uu___8 - = - Obj.magic - uu___8 in - let must_tot - = true in - let uu___9 - = - let uu___10 - = - do_unify - must_tot - e ty1 ty2 in - let uu___11 - = - do_unify - must_tot - e t11 t21 in - tac_and - uu___10 - uu___11 in - Obj.magic - (default_if_err - false - uu___9)) - uu___8))) - uu___6))) uu___4))) - uu___2))) uu___1)) in - FStar_Tactics_Monad.wrap_err "unify_env" uu___ -let (unify_guard_env : - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> Prims.bool FStar_Tactics_Monad.tac) - = - fun e -> - fun t1 -> - fun t2 -> - let uu___ = - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - () (Obj.magic FStar_Tactics_Monad.get) - (fun uu___1 -> - (fun ps -> - let ps = Obj.magic ps in - let uu___1 = __tc e t1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - match uu___2 with - | (t11, ty1, g1) -> - let uu___3 = __tc e t2 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___3) - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - match uu___4 with - | (t21, ty2, g2) -> - let uu___5 = - proc_guard - "unify_guard_env g1" e - g1 - FStar_Pervasives_Native.None - ps.FStar_Tactics_Types.entry_range in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () uu___5 - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = - Obj.magic - uu___6 in - let uu___7 = - proc_guard - "unify_guard_env g2" - e g2 - FStar_Pervasives_Native.None - ps.FStar_Tactics_Types.entry_range in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___7 - (fun - uu___8 -> - (fun - uu___8 -> - let uu___8 - = - Obj.magic - uu___8 in - let must_tot - = true in - let uu___9 - = - do_unify_maybe_guards - true - must_tot - e ty1 ty2 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic - uu___9) - (fun - uu___10 - -> - (fun - uu___10 - -> - let uu___10 - = - Obj.magic - uu___10 in - match uu___10 - with - | - FStar_Pervasives_Native.None - -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - false)) - | - FStar_Pervasives_Native.Some - g11 -> - let uu___11 - = - do_unify_maybe_guards - true - must_tot - e t11 t21 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic - uu___11) - (fun - uu___12 - -> - (fun - uu___12 - -> - let uu___12 - = - Obj.magic - uu___12 in - match uu___12 - with - | - FStar_Pervasives_Native.None - -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - false)) - | - FStar_Pervasives_Native.Some - g21 -> - let formula - = - let uu___13 - = - guard_formula - g11 in - let uu___14 - = - guard_formula - g21 in - FStar_Syntax_Util.mk_conj - uu___13 - uu___14 in - let uu___13 - = - FStar_Tactics_Monad.goal_of_guard - "unify_guard_env.g2" - e formula - FStar_Pervasives_Native.None - ps.FStar_Tactics_Types.entry_range in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic - uu___13) - (fun - uu___14 - -> - (fun goal - -> - let goal - = - Obj.magic - goal in - let uu___14 - = - FStar_Tactics_Monad.push_goals - [goal] in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___14 - (fun - uu___15 - -> - (fun - uu___15 - -> - let uu___15 - = - Obj.magic - uu___15 in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - true))) - uu___15))) - uu___14))) - uu___12))) - uu___10))) - uu___8))) - uu___6))) uu___4))) - uu___2))) uu___1)) in - FStar_Tactics_Monad.wrap_err "unify_guard_env" uu___ -let (launch_process : - Prims.string -> - Prims.string Prims.list -> - Prims.string -> Prims.string FStar_Tactics_Monad.tac) - = - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun prog -> - fun args -> - fun input -> - let uu___ = - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.repr ()) in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac - () () uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - let uu___2 = FStar_Options.unsafe_tactic_exec () in - if uu___2 - then - Obj.magic - (Obj.repr - (let s = - FStar_Compiler_Util.run_process - "tactic_launch" prog args - (FStar_Pervasives_Native.Some input) in - FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic s))) - else - Obj.magic - (Obj.repr - (FStar_Tactics_Monad.fail - "launch_process: will not run anything unless --unsafe_tactic_exec is provided"))) - uu___1))) uu___2 uu___1 uu___ -let (fresh_bv_named : - Prims.string -> FStar_Syntax_Syntax.bv FStar_Tactics_Monad.tac) = - fun uu___ -> - (fun nm -> - let uu___ = - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.repr ()) in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - let uu___2 = - FStar_Syntax_Syntax.gen_bv nm - FStar_Pervasives_Native.None FStar_Syntax_Syntax.tun in - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac - () (Obj.magic uu___2))) uu___1))) uu___ -let (change : FStar_Syntax_Syntax.typ -> unit FStar_Tactics_Monad.tac) = - fun ty -> - let uu___ = - let uu___1 = - FStar_Tactics_Monad.if_verbose - (fun uu___2 -> - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term ty in - FStar_Compiler_Util.print1 "change: ty = %s\n" uu___3) in - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___1 - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac - () () (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___3 -> - (fun g -> - let g = Obj.magic g in - let uu___3 = - let uu___4 = FStar_Tactics_Types.goal_env g in - __tc uu___4 ty in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___3) - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - match uu___4 with - | (ty1, uu___5, guard) -> - let uu___6 = - let uu___7 = - FStar_Tactics_Types.goal_env g in - let uu___8 = - let uu___9 = - should_check_goal_uvar g in - FStar_Pervasives_Native.Some - uu___9 in - proc_guard "change" uu___7 guard - uu___8 (rangeof g) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () - () uu___6 - (fun uu___7 -> - (fun uu___7 -> - let uu___7 = - Obj.magic uu___7 in - let must_tot = true in - let uu___8 = - let uu___9 = - FStar_Tactics_Types.goal_env - g in - let uu___10 = - FStar_Tactics_Types.goal_type - g in - do_unify must_tot uu___9 - uu___10 ty1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic uu___8) - (fun uu___9 -> - (fun bb -> - let bb = - Obj.magic bb in - if bb - then - let uu___9 = - FStar_Tactics_Monad.goal_with_type - g ty1 in - Obj.magic - (FStar_Tactics_Monad.replace_cur - uu___9) - else - (let steps = - [FStar_TypeChecker_Env.AllowUnboundUniverses; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Primops] in - let ng = - let uu___10 - = - FStar_Tactics_Types.goal_env - g in - let uu___11 - = - FStar_Tactics_Types.goal_type - g in - normalize - steps - uu___10 - uu___11 in - let nty = - let uu___10 - = - FStar_Tactics_Types.goal_env - g in - normalize - steps - uu___10 - ty1 in - let uu___10 - = - let uu___11 - = - FStar_Tactics_Types.goal_env - g in - do_unify - must_tot - uu___11 - ng nty in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic - uu___10) - (fun - uu___11 - -> - (fun b -> - let b = - Obj.magic - b in - if b - then - let uu___11 - = - FStar_Tactics_Monad.goal_with_type - g ty1 in - Obj.magic - (FStar_Tactics_Monad.replace_cur - uu___11) - else - Obj.magic - (FStar_Tactics_Monad.fail - "not convertible")) - uu___11)))) - uu___9))) uu___7))) - uu___4))) uu___3))) uu___2) in - FStar_Tactics_Monad.wrap_err "change" uu___ -let (failwhen : Prims.bool -> Prims.string -> unit FStar_Tactics_Monad.tac) = - fun b -> - fun msg -> - if b - then FStar_Tactics_Monad.fail msg - else - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.repr ()) -let (t_destruct : - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.fv * FStar_BigInt.t) Prims.list - FStar_Tactics_Monad.tac) - = - fun s_tm -> - let uu___ = - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___1 -> - (fun g -> - let g = Obj.magic g in - let uu___1 = - let uu___2 = FStar_Tactics_Types.goal_env g in - __tc uu___2 s_tm in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - match uu___2 with - | (s_tm1, s_ty, guard) -> - let uu___3 = - let uu___4 = FStar_Tactics_Types.goal_env g in - let uu___5 = - let uu___6 = should_check_goal_uvar g in - FStar_Pervasives_Native.Some uu___6 in - proc_guard "destruct" uu___4 guard uu___5 - (rangeof g) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - uu___3 - (fun uu___4 -> - (fun uu___4 -> - let uu___4 = Obj.magic uu___4 in - let s_ty1 = - let uu___5 = - FStar_Tactics_Types.goal_env g in - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.DontUnfoldAttr - [FStar_Parser_Const.tac_opaque_attr]; - FStar_TypeChecker_Env.Weak; - FStar_TypeChecker_Env.HNF; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant] - uu___5 s_ty in - let uu___5 = - let uu___6 = - FStar_Syntax_Util.unrefine - s_ty1 in - FStar_Syntax_Util.head_and_args_full - uu___6 in - match uu___5 with - | (h, args) -> - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Syntax_Subst.compress - h in - uu___8.FStar_Syntax_Syntax.n in - match uu___7 with - | FStar_Syntax_Syntax.Tm_fvar - fv -> - Obj.magic - (Obj.repr - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - (fv, [])))) - | FStar_Syntax_Syntax.Tm_uinst - (h', us) -> - Obj.magic - (Obj.repr - (let uu___8 = - let uu___9 = - FStar_Syntax_Subst.compress - h' in - uu___9.FStar_Syntax_Syntax.n in - match uu___8 with - | FStar_Syntax_Syntax.Tm_fvar - fv -> - Obj.repr - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - ( - Obj.magic - (fv, us))) - | uu___9 -> - Obj.repr - (failwith - "impossible: uinst over something that's not an fvar"))) - | uu___8 -> - Obj.magic - (Obj.repr - (FStar_Tactics_Monad.fail - "type is not an fv")) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () (Obj.magic uu___6) - (fun uu___7 -> - (fun uu___7 -> - let uu___7 = - Obj.magic uu___7 in - match uu___7 with - | (fv, a_us) -> - let t_lid = - FStar_Syntax_Syntax.lid_of_fv - fv in - let uu___8 = - let uu___9 = - FStar_Tactics_Types.goal_env - g in - FStar_TypeChecker_Env.lookup_sigelt - uu___9 - t_lid in - (match uu___8 - with - | FStar_Pervasives_Native.None - -> - Obj.magic - (Obj.repr - (FStar_Tactics_Monad.fail - "type not found in environment")) - | FStar_Pervasives_Native.Some - se -> - Obj.magic - (Obj.repr - (match - se.FStar_Syntax_Syntax.sigel - with - | - FStar_Syntax_Syntax.Sig_inductive_typ - { - FStar_Syntax_Syntax.lid - = uu___9; - FStar_Syntax_Syntax.us - = t_us; - FStar_Syntax_Syntax.params - = t_ps; - FStar_Syntax_Syntax.num_uniform_params - = uu___10; - FStar_Syntax_Syntax.t - = t_ty; - FStar_Syntax_Syntax.mutuals - = mut; - FStar_Syntax_Syntax.ds - = c_lids; - FStar_Syntax_Syntax.injective_type_params - = uu___11;_} - -> - Obj.repr - (let erasable - = - FStar_Syntax_Util.has_attribute - se.FStar_Syntax_Syntax.sigattrs - FStar_Parser_Const.erasable_attr in - let uu___12 - = - let uu___13 - = - erasable - && - (let uu___14 - = - FStar_Tactics_Monad.is_irrelevant - g in - Prims.op_Negation - uu___14) in - failwhen - uu___13 - "cannot destruct erasable type to solve proof-relevant goal" in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___12 - (fun - uu___13 - -> - (fun - uu___13 - -> - let uu___13 - = - Obj.magic - uu___13 in - let uu___14 - = - failwhen - ((FStar_Compiler_List.length - a_us) <> - (FStar_Compiler_List.length - t_us)) - "t_us don't match?" in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___14 - (fun - uu___15 - -> - (fun - uu___15 - -> - let uu___15 - = - Obj.magic - uu___15 in - let uu___16 - = - FStar_Syntax_Subst.open_term - t_ps t_ty in - match uu___16 - with - | - (t_ps1, - t_ty1) -> - let uu___17 - = - Obj.magic - (FStar_Class_Monad.mapM - FStar_Tactics_Monad.monad_tac - () () - (fun - uu___18 - -> - (fun - c_lid -> - let c_lid - = - Obj.magic - c_lid in - let uu___18 - = - let uu___19 - = - FStar_Tactics_Types.goal_env - g in - FStar_TypeChecker_Env.lookup_sigelt - uu___19 - c_lid in - match uu___18 - with - | - FStar_Pervasives_Native.None - -> - Obj.magic - (Obj.repr - (FStar_Tactics_Monad.fail - "ctor not found?")) - | - FStar_Pervasives_Native.Some - se1 -> - Obj.magic - (Obj.repr - (match - se1.FStar_Syntax_Syntax.sigel - with - | - FStar_Syntax_Syntax.Sig_datacon - { - FStar_Syntax_Syntax.lid1 - = uu___19; - FStar_Syntax_Syntax.us1 - = c_us; - FStar_Syntax_Syntax.t1 - = c_ty; - FStar_Syntax_Syntax.ty_lid - = uu___20; - FStar_Syntax_Syntax.num_ty_params - = nparam; - FStar_Syntax_Syntax.mutuals1 - = mut1; - FStar_Syntax_Syntax.injective_type_params1 - = uu___21;_} - -> - Obj.repr - (let qual - = - let fallback - uu___22 = - FStar_Pervasives_Native.Some - FStar_Syntax_Syntax.Data_ctor in - let qninfo - = - let uu___22 - = - FStar_Tactics_Types.goal_env - g in - FStar_TypeChecker_Env.lookup_qname - uu___22 - c_lid in - match qninfo - with - | - FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr - (se2, - _us), - _rng) -> - FStar_Syntax_DsEnv.fv_qual_of_se - se2 - | - uu___22 - -> - fallback - () in - let fv1 = - FStar_Syntax_Syntax.lid_as_fv - c_lid - qual in - let uu___22 - = - failwhen - ((FStar_Compiler_List.length - a_us) <> - (FStar_Compiler_List.length - c_us)) - "t_us don't match?" in - FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___22 - (fun - uu___23 - -> - (fun - uu___23 - -> - let uu___23 - = - Obj.magic - uu___23 in - let s = - FStar_TypeChecker_Env.mk_univ_subst - c_us a_us in - let c_ty1 - = - FStar_Syntax_Subst.subst - s c_ty in - let uu___24 - = - FStar_TypeChecker_Env.inst_tscheme - (c_us, - c_ty1) in - match uu___24 - with - | - (c_us1, - c_ty2) -> - let uu___25 - = - FStar_Syntax_Util.arrow_formals_comp - c_ty2 in - (match uu___25 - with - | - (bs, - comp) -> - let uu___26 - = - let rename_bv - bv = - let ppname - = - bv.FStar_Syntax_Syntax.ppname in - let ppname1 - = - let uu___27 - = - let uu___28 - = - let uu___29 - = - FStar_Class_Show.show - FStar_Ident.showable_ident - ppname in - Prims.strcat - "a" - uu___29 in - let uu___29 - = - FStar_Ident.range_of_id - ppname in - (uu___28, - uu___29) in - FStar_Ident.mk_ident - uu___27 in - FStar_Syntax_Syntax.freshen_bv - { - FStar_Syntax_Syntax.ppname - = ppname1; - FStar_Syntax_Syntax.index - = - (bv.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort - = - (bv.FStar_Syntax_Syntax.sort) - } in - let bs' = - FStar_Compiler_List.map - (fun b -> - let uu___27 - = - rename_bv - b.FStar_Syntax_Syntax.binder_bv in - { - FStar_Syntax_Syntax.binder_bv - = uu___27; - FStar_Syntax_Syntax.binder_qual - = - (b.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity - = - (b.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs - = - (b.FStar_Syntax_Syntax.binder_attrs) - }) bs in - let subst - = - FStar_Compiler_List.map2 - (fun - uu___27 - -> - fun - uu___28 - -> - match - (uu___27, - uu___28) - with - | - ({ - FStar_Syntax_Syntax.binder_bv - = bv; - FStar_Syntax_Syntax.binder_qual - = uu___29; - FStar_Syntax_Syntax.binder_positivity - = uu___30; - FStar_Syntax_Syntax.binder_attrs - = uu___31;_}, - { - FStar_Syntax_Syntax.binder_bv - = bv'; - FStar_Syntax_Syntax.binder_qual - = uu___32; - FStar_Syntax_Syntax.binder_positivity - = uu___33; - FStar_Syntax_Syntax.binder_attrs - = uu___34;_}) - -> - let uu___35 - = - let uu___36 - = - FStar_Syntax_Syntax.bv_to_name - bv' in - (bv, - uu___36) in - FStar_Syntax_Syntax.NT - uu___35) - bs bs' in - let uu___27 - = - FStar_Syntax_Subst.subst_binders - subst bs' in - let uu___28 - = - FStar_Syntax_Subst.subst_comp - subst - comp in - (uu___27, - uu___28) in - (match uu___26 - with - | - (bs1, - comp1) -> - let uu___27 - = - FStar_Compiler_List.splitAt - nparam - bs1 in - (match uu___27 - with - | - (d_ps, - bs2) -> - let uu___28 - = - let uu___29 - = - let uu___30 - = - FStar_Syntax_Util.is_total_comp - comp1 in - Prims.op_Negation - uu___30 in - failwhen - uu___29 - "not total?" in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___28 - (fun - uu___29 - -> - (fun - uu___29 - -> - let uu___29 - = - Obj.magic - uu___29 in - let mk_pat - p = - { - FStar_Syntax_Syntax.v - = p; - FStar_Syntax_Syntax.p - = - (s_tm1.FStar_Syntax_Syntax.pos) - } in - let is_imp - uu___30 = - match uu___30 - with - | - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Implicit - uu___31) - -> true - | - uu___31 - -> false in - let uu___30 - = - FStar_Compiler_List.splitAt - nparam - args in - match uu___30 - with - | - (a_ps, - a_is) -> - let uu___31 - = - failwhen - ((FStar_Compiler_List.length - a_ps) <> - (FStar_Compiler_List.length - d_ps)) - "params not match?" in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___31 - (fun - uu___32 - -> - (fun - uu___32 - -> - let uu___32 - = - Obj.magic - uu___32 in - let d_ps_a_ps - = - FStar_Compiler_List.zip - d_ps a_ps in - let subst - = - FStar_Compiler_List.map - (fun - uu___33 - -> - match uu___33 - with - | - ({ - FStar_Syntax_Syntax.binder_bv - = bv; - FStar_Syntax_Syntax.binder_qual - = uu___34; - FStar_Syntax_Syntax.binder_positivity - = uu___35; - FStar_Syntax_Syntax.binder_attrs - = uu___36;_}, - (t, - uu___37)) - -> - FStar_Syntax_Syntax.NT - (bv, t)) - d_ps_a_ps in - let bs3 = - FStar_Syntax_Subst.subst_binders - subst bs2 in - let subpats_1 - = - FStar_Compiler_List.map - (fun - uu___33 - -> - match uu___33 - with - | - ({ - FStar_Syntax_Syntax.binder_bv - = bv; - FStar_Syntax_Syntax.binder_qual - = uu___34; - FStar_Syntax_Syntax.binder_positivity - = uu___35; - FStar_Syntax_Syntax.binder_attrs - = uu___36;_}, - (t, - uu___37)) - -> - ((mk_pat - (FStar_Syntax_Syntax.Pat_dot_term - (FStar_Pervasives_Native.Some - t))), - true)) - d_ps_a_ps in - let subpats_2 - = - FStar_Compiler_List.map - (fun - uu___33 - -> - match uu___33 - with - | - { - FStar_Syntax_Syntax.binder_bv - = bv; - FStar_Syntax_Syntax.binder_qual - = bq; - FStar_Syntax_Syntax.binder_positivity - = uu___34; - FStar_Syntax_Syntax.binder_attrs - = uu___35;_} - -> - ((mk_pat - (FStar_Syntax_Syntax.Pat_var - bv)), - (is_imp - bq))) bs3 in - let subpats - = - FStar_Compiler_List.op_At - subpats_1 - subpats_2 in - let pat = - mk_pat - (FStar_Syntax_Syntax.Pat_cons - (fv1, - (FStar_Pervasives_Native.Some - a_us), - subpats)) in - let env1 - = - FStar_Tactics_Types.goal_env - g in - let cod = - FStar_Tactics_Types.goal_type - g in - let equ = - env1.FStar_TypeChecker_Env.universe_of - env1 - s_ty1 in - let uu___33 - = - FStar_TypeChecker_TcTerm.tc_pat - { - FStar_TypeChecker_Env.solver - = - (env1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range - = - (env1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule - = - (env1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma - = - (env1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig - = - (env1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache - = - (env1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules - = - (env1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ - = - (env1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab - = - (env1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab - = - (env1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp - = - (env1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects - = - (env1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize - = - (env1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs - = - (env1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level - = - (env1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars - = - (env1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict - = - (env1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface - = - (env1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit - = true; - FStar_TypeChecker_Env.lax_universes - = - (env1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 - = - (env1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard - = - (env1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking - = - (env1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping - = - (env1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics - = - (env1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce - = - (env1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term - = - (env1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (env1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of - = - (env1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force - = - (env1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (env1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (env1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (env1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths - = - (env1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns - = - (env1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook - = - (env1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (env1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice - = - (env1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess - = - (env1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess - = - (env1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info - = - (env1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks - = - (env1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv - = - (env1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe - = - (env1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab - = - (env1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (env1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (env1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (env1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (env1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check - = - (env1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl - = - (env1.FStar_TypeChecker_Env.missing_decl) - } s_ty1 - pat in - match uu___33 - with - | - (uu___34, - uu___35, - uu___36, - uu___37, - pat_t, - uu___38, - _guard_pat, - _erasable) - -> - let eq_b - = - let uu___39 - = - let uu___40 - = - FStar_Syntax_Util.mk_eq2 - equ s_ty1 - s_tm1 - pat_t in - FStar_Syntax_Util.mk_squash - FStar_Syntax_Syntax.U_zero - uu___40 in - FStar_Syntax_Syntax.gen_bv - "breq" - FStar_Pervasives_Native.None - uu___39 in - let cod1 - = - let uu___39 - = - let uu___40 - = - FStar_Syntax_Syntax.mk_binder - eq_b in - [uu___40] in - let uu___40 - = - FStar_Syntax_Syntax.mk_Total - cod in - FStar_Syntax_Util.arrow - uu___39 - uu___40 in - let nty = - let uu___39 - = - FStar_Syntax_Syntax.mk_Total - cod1 in - FStar_Syntax_Util.arrow - bs3 - uu___39 in - let uu___39 - = - let uu___40 - = - FStar_Tactics_Monad.goal_typedness_deps - g in - FStar_Tactics_Monad.new_uvar - "destruct branch" - env1 nty - FStar_Pervasives_Native.None - uu___40 - (rangeof - g) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic - uu___39) - (fun - uu___40 - -> - (fun - uu___40 - -> - let uu___40 - = - Obj.magic - uu___40 in - match uu___40 - with - | - (uvt, uv) - -> - let g' = - FStar_Tactics_Types.mk_goal - env1 uv - g.FStar_Tactics_Types.opts - false - g.FStar_Tactics_Types.label in - let brt = - FStar_Syntax_Util.mk_app_binders - uvt bs3 in - let brt1 - = - let uu___41 - = - let uu___42 - = - FStar_Syntax_Syntax.as_arg - FStar_Syntax_Util.exp_unit in - [uu___42] in - FStar_Syntax_Util.mk_app - brt - uu___41 in - let br = - FStar_Syntax_Subst.close_branch - (pat, - FStar_Pervasives_Native.None, - brt1) in - let uu___41 - = - let uu___42 - = - let uu___43 - = - FStar_BigInt.of_int_fs - (FStar_Compiler_List.length - bs3) in - (fv1, - uu___43) in - (g', br, - uu___42) in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - uu___41))) - uu___40))) - uu___32))) - uu___29)))))) - uu___23)) - | - uu___19 - -> - Obj.repr - (FStar_Tactics_Monad.fail - "impossible: not a ctor")))) - uu___18) - (Obj.magic - c_lids)) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - (Obj.magic - uu___17) - (fun - uu___18 - -> - (fun - goal_brs - -> - let goal_brs - = - Obj.magic - goal_brs in - let uu___18 - = - FStar_Compiler_List.unzip3 - goal_brs in - match uu___18 - with - | - (goals, - brs, - infos) -> - let w = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_match - { - FStar_Syntax_Syntax.scrutinee - = s_tm1; - FStar_Syntax_Syntax.ret_opt - = - FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.brs - = brs; - FStar_Syntax_Syntax.rc_opt1 - = - FStar_Pervasives_Native.None - }) - s_tm1.FStar_Syntax_Syntax.pos in - let uu___19 - = - solve' g - w in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___19 - (fun - uu___20 - -> - (fun - uu___20 - -> - let uu___20 - = - Obj.magic - uu___20 in - FStar_Tactics_Monad.mark_goal_implicit_already_checked - g; - ( - let uu___22 - = - FStar_Tactics_Monad.add_goals - goals in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac - () () - uu___22 - (fun - uu___23 - -> - (fun - uu___23 - -> - let uu___23 - = - Obj.magic - uu___23 in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - infos))) - uu___23)))) - uu___20))) - uu___18))) - uu___15))) - uu___13)) - | - uu___9 -> - Obj.repr - (FStar_Tactics_Monad.fail - "not an inductive type"))))) - uu___7))) uu___4))) - uu___2))) uu___1)) in - FStar_Tactics_Monad.wrap_err "destruct" uu___ -let (gather_explicit_guards_for_resolved_goals : - unit -> unit FStar_Tactics_Monad.tac) = - fun uu___ -> - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () (Obj.repr ()) -let rec last : 'a . 'a Prims.list -> 'a = - fun l -> - match l with - | [] -> failwith "last: empty list" - | x::[] -> x - | uu___::xs -> last xs -let rec init : 'a . 'a Prims.list -> 'a Prims.list = - fun l -> - match l with - | [] -> failwith "init: empty list" - | x::[] -> [] - | x::xs -> let uu___ = init xs in x :: uu___ -let (lget : - FStar_Syntax_Syntax.typ -> - Prims.string -> FStar_Syntax_Syntax.term FStar_Tactics_Monad.tac) - = - fun ty -> - fun k -> - let uu___ = - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.get) - (fun uu___1 -> - (fun ps -> - let ps = Obj.magic ps in - let uu___1 = - FStar_Compiler_Util.psmap_try_find - ps.FStar_Tactics_Types.local_state k in - match uu___1 with - | FStar_Pervasives_Native.None -> - Obj.magic (FStar_Tactics_Monad.fail "not found") - | FStar_Pervasives_Native.Some t -> - Obj.magic (unquote ty t)) uu___1)) in - FStar_Tactics_Monad.wrap_err "lget" uu___ -let (lset : - FStar_Syntax_Syntax.typ -> - Prims.string -> FStar_Syntax_Syntax.term -> unit FStar_Tactics_Monad.tac) - = - fun _ty -> - fun k -> - fun t -> - let uu___ = - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.get) - (fun uu___1 -> - (fun ps -> - let ps = Obj.magic ps in - let ps1 = - let uu___1 = - FStar_Compiler_Util.psmap_add - ps.FStar_Tactics_Types.local_state k t in - { - FStar_Tactics_Types.main_context = - (ps.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits = - (ps.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = - (ps.FStar_Tactics_Types.goals); - FStar_Tactics_Types.smt_goals = - (ps.FStar_Tactics_Types.smt_goals); - FStar_Tactics_Types.depth = - (ps.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = - (ps.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = (ps.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (ps.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = - (ps.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness = - (ps.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg = - (ps.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = uu___1; - FStar_Tactics_Types.urgency = - (ps.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure = - (ps.FStar_Tactics_Types.dump_on_failure) - } in - Obj.magic (FStar_Tactics_Monad.set ps1)) uu___1) in - FStar_Tactics_Monad.wrap_err "lset" uu___ -let (set_urgency : FStar_BigInt.t -> unit FStar_Tactics_Monad.tac) = - fun u -> - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.get) - (fun uu___ -> - (fun ps -> - let ps = Obj.magic ps in - let ps1 = - let uu___ = FStar_BigInt.to_int_fs u in - { - FStar_Tactics_Types.main_context = - (ps.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits = - (ps.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = (ps.FStar_Tactics_Types.goals); - FStar_Tactics_Types.smt_goals = - (ps.FStar_Tactics_Types.smt_goals); - FStar_Tactics_Types.depth = (ps.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = (ps.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = (ps.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (ps.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = - (ps.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness = - (ps.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg = - (ps.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = - (ps.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency = uu___; - FStar_Tactics_Types.dump_on_failure = - (ps.FStar_Tactics_Types.dump_on_failure) - } in - Obj.magic (FStar_Tactics_Monad.set ps1)) uu___) -let (set_dump_on_failure : Prims.bool -> unit FStar_Tactics_Monad.tac) = - fun b -> - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.get) - (fun uu___ -> - (fun ps -> - let ps = Obj.magic ps in - let ps1 = - { - FStar_Tactics_Types.main_context = - (ps.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits = - (ps.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = (ps.FStar_Tactics_Types.goals); - FStar_Tactics_Types.smt_goals = - (ps.FStar_Tactics_Types.smt_goals); - FStar_Tactics_Types.depth = (ps.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = (ps.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = (ps.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (ps.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = - (ps.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness = - (ps.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg = - (ps.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = - (ps.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency = - (ps.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure = b - } in - Obj.magic (FStar_Tactics_Monad.set ps1)) uu___) -let (t_commute_applied_match : unit -> unit FStar_Tactics_Monad.tac) = - fun uu___ -> - let uu___1 = - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___2 -> - (fun g -> - let g = Obj.magic g in - let uu___2 = - let uu___3 = FStar_Tactics_Types.goal_env g in - let uu___4 = FStar_Tactics_Types.goal_type g in - destruct_eq uu___3 uu___4 in - match uu___2 with - | FStar_Pervasives_Native.Some (l, r) -> - let uu___3 = FStar_Syntax_Util.head_and_args_full l in - (match uu___3 with - | (lh, las) -> - let uu___4 = - let uu___5 = - let uu___6 = FStar_Syntax_Util.unascribe lh in - FStar_Syntax_Subst.compress uu___6 in - uu___5.FStar_Syntax_Syntax.n in - (match uu___4 with - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = e; - FStar_Syntax_Syntax.ret_opt = asc_opt; - FStar_Syntax_Syntax.brs = brs; - FStar_Syntax_Syntax.rc_opt1 = lopt;_} - -> - let brs' = - FStar_Compiler_List.map - (fun uu___5 -> - match uu___5 with - | (p, w, e1) -> - let uu___6 = - FStar_Syntax_Util.mk_app e1 las in - (p, w, uu___6)) brs in - let lopt' = - FStar_Compiler_Util.map_option - (fun rc -> - let uu___5 = - FStar_Compiler_Util.map_option - (fun t -> - let uu___6 = - let uu___7 = - FStar_Tactics_Types.goal_env g in - FStar_TypeChecker_Normalize.get_n_binders - uu___7 - (FStar_Compiler_List.length las) - t in - match uu___6 with - | (bs, c) -> - let uu___7 = - FStar_Syntax_Subst.open_comp - bs c in - (match uu___7 with - | (bs1, c1) -> - let ss = - FStar_Compiler_List.map2 - (fun b -> - fun a -> - FStar_Syntax_Syntax.NT - ((b.FStar_Syntax_Syntax.binder_bv), - (FStar_Pervasives_Native.fst - a))) bs1 - las in - let c2 = - FStar_Syntax_Subst.subst_comp - ss c1 in - FStar_Syntax_Util.comp_result - c2)) - rc.FStar_Syntax_Syntax.residual_typ in - { - FStar_Syntax_Syntax.residual_effect = - (rc.FStar_Syntax_Syntax.residual_effect); - FStar_Syntax_Syntax.residual_typ = - uu___5; - FStar_Syntax_Syntax.residual_flags = - (rc.FStar_Syntax_Syntax.residual_flags) - }) lopt in - let l' = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_match - { - FStar_Syntax_Syntax.scrutinee = e; - FStar_Syntax_Syntax.ret_opt = asc_opt; - FStar_Syntax_Syntax.brs = brs'; - FStar_Syntax_Syntax.rc_opt1 = lopt' - }) l.FStar_Syntax_Syntax.pos in - let must_tot = true in - let uu___5 = - let uu___6 = FStar_Tactics_Types.goal_env g in - do_unify_maybe_guards false must_tot uu___6 l' - r in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___5) - (fun uu___6 -> - (fun uu___6 -> - let uu___6 = Obj.magic uu___6 in - match uu___6 with - | FStar_Pervasives_Native.None -> - Obj.magic - (FStar_Tactics_Monad.fail - "discharging the equality failed") - | FStar_Pervasives_Native.Some guard - -> - let uu___7 = - FStar_TypeChecker_Env.is_trivial_guard_formula - guard in - if uu___7 - then - (FStar_Tactics_Monad.mark_uvar_as_already_checked - g.FStar_Tactics_Types.goal_ctx_uvar; - Obj.magic - (solve g - FStar_Syntax_Util.exp_unit)) - else - Obj.magic - (failwith - "internal error: _t_refl: guard is not trivial")) - uu___6)) - | uu___5 -> - Obj.magic - (FStar_Tactics_Monad.fail "lhs is not a match"))) - | FStar_Pervasives_Native.None -> - Obj.magic (FStar_Tactics_Monad.fail "not an equality")) - uu___2) in - FStar_Tactics_Monad.wrap_err "t_commute_applied_match" uu___1 -let (string_to_term : - env -> Prims.string -> FStar_Syntax_Syntax.term FStar_Tactics_Monad.tac) = - fun e -> - fun s -> - let frag_of_text s1 = - { - FStar_Parser_ParseIt.frag_fname = ""; - FStar_Parser_ParseIt.frag_text = s1; - FStar_Parser_ParseIt.frag_line = Prims.int_one; - FStar_Parser_ParseIt.frag_col = Prims.int_zero - } in - let uu___ = - FStar_Parser_ParseIt.parse FStar_Pervasives_Native.None - (FStar_Parser_ParseIt.Fragment (frag_of_text s)) in - match uu___ with - | FStar_Parser_ParseIt.Term t -> - let dsenv = - let uu___1 = FStar_TypeChecker_Env.current_module e in - FStar_Syntax_DsEnv.set_current_module - e.FStar_TypeChecker_Env.dsenv uu___1 in - (try - (fun uu___1 -> - (fun uu___1 -> - match () with - | () -> - let uu___2 = - FStar_ToSyntax_ToSyntax.desugar_term dsenv t in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic uu___2))) uu___1) () - with - | FStar_Errors.Error (uu___2, e1, uu___3, uu___4) -> - let uu___5 = - let uu___6 = FStar_Errors_Msg.rendermsg e1 in - Prims.strcat "string_to_term: " uu___6 in - FStar_Tactics_Monad.fail uu___5 - | uu___2 -> - FStar_Tactics_Monad.fail "string_to_term: Unknown error") - | FStar_Parser_ParseIt.ASTFragment uu___1 -> - FStar_Tactics_Monad.fail - "string_to_term: expected a Term as a result, got an ASTFragment" - | FStar_Parser_ParseIt.ParseError (uu___1, err, uu___2) -> - let uu___3 = - let uu___4 = FStar_Errors_Msg.rendermsg err in - Prims.strcat "string_to_term: got error " uu___4 in - FStar_Tactics_Monad.fail uu___3 -let (push_bv_dsenv : - env -> - Prims.string -> - (env * FStar_Reflection_V2_Data.binding) FStar_Tactics_Monad.tac) - = - fun uu___1 -> - fun uu___ -> - (fun e -> - fun i -> - let ident = - FStar_Ident.mk_ident (i, FStar_Compiler_Range_Type.dummyRange) in - let uu___ = - FStar_Syntax_DsEnv.push_bv e.FStar_TypeChecker_Env.dsenv ident in - match uu___ with - | (dsenv, bv) -> - let uu___1 = - let uu___2 = bv_to_binding bv in - ({ - FStar_TypeChecker_Env.solver = - (e.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (e.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (e.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (e.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (e.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (e.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (e.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (e.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (e.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (e.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (e.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (e.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (e.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (e.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (e.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (e.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (e.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (e.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (e.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (e.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (e.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (e.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (e.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (e.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (e.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (e.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (e.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (e.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (e.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (e.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (e.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (e.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (e.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (e.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (e.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (e.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (e.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (e.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (e.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (e.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (e.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (e.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (e.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = dsenv; - FStar_TypeChecker_Env.nbe = (e.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (e.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (e.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (e.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (e.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (e.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (e.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (e.FStar_TypeChecker_Env.missing_decl) - }, uu___2) in - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.magic uu___1))) uu___1 uu___ -let (term_to_string : - FStar_Syntax_Syntax.term -> Prims.string FStar_Tactics_Monad.tac) = - fun uu___ -> - (fun t -> - let uu___ = top_env () in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___) - (fun uu___1 -> - (fun g -> - let g = Obj.magic g in - let s = - FStar_Syntax_Print.term_to_string' - g.FStar_TypeChecker_Env.dsenv t in - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac - () (Obj.magic s))) uu___1))) uu___ -let (comp_to_string : - FStar_Syntax_Syntax.comp -> Prims.string FStar_Tactics_Monad.tac) = - fun uu___ -> - (fun c -> - let uu___ = top_env () in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___) - (fun uu___1 -> - (fun g -> - let g = Obj.magic g in - let s = - FStar_Syntax_Print.comp_to_string' - g.FStar_TypeChecker_Env.dsenv c in - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac - () (Obj.magic s))) uu___1))) uu___ -let (term_to_doc : - FStar_Syntax_Syntax.term -> FStar_Pprint.document FStar_Tactics_Monad.tac) - = - fun uu___ -> - (fun t -> - let uu___ = top_env () in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___) - (fun uu___1 -> - (fun g -> - let g = Obj.magic g in - let s = - FStar_Syntax_Print.term_to_doc' - g.FStar_TypeChecker_Env.dsenv t in - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac - () (Obj.magic s))) uu___1))) uu___ -let (comp_to_doc : - FStar_Syntax_Syntax.comp -> FStar_Pprint.document FStar_Tactics_Monad.tac) - = - fun uu___ -> - (fun c -> - let uu___ = top_env () in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___) - (fun uu___1 -> - (fun g -> - let g = Obj.magic g in - let s = - FStar_Syntax_Print.comp_to_doc' - g.FStar_TypeChecker_Env.dsenv c in - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac - () (Obj.magic s))) uu___1))) uu___ -let (range_to_string : - FStar_Compiler_Range_Type.range -> Prims.string FStar_Tactics_Monad.tac) = - fun uu___ -> - (fun r -> - let uu___ = - FStar_Class_Show.show FStar_Compiler_Range_Ops.showable_range r in - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.magic uu___))) uu___ -let (term_eq_old : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> Prims.bool FStar_Tactics_Monad.tac) - = - fun uu___1 -> - fun uu___ -> - (fun t1 -> - fun t2 -> - let uu___ = - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.repr ()) in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - () uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - let uu___2 = FStar_Syntax_Util.term_eq t1 t2 in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic uu___2))) uu___1))) uu___1 uu___ -let with_compat_pre_core : - 'a . - FStar_BigInt.t -> - 'a FStar_Tactics_Monad.tac -> 'a FStar_Tactics_Monad.tac - = - fun n -> - fun f -> - FStar_Tactics_Monad.mk_tac - (fun ps -> - FStar_Options.with_saved_options - (fun uu___ -> - let _res = FStar_Options.set_options "--compat_pre_core 0" in - FStar_Tactics_Monad.run f ps)) -let (get_vconfig : unit -> FStar_VConfig.vconfig FStar_Tactics_Monad.tac) = - fun uu___ -> - (fun uu___ -> - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___1 -> - (fun g -> - let g = Obj.magic g in - let vcfg = - FStar_Options.with_saved_options - (fun uu___1 -> - FStar_Options.set g.FStar_Tactics_Types.opts; - FStar_Options.get_vconfig ()) in - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac - () (Obj.magic vcfg))) uu___1))) uu___ -let (set_vconfig : FStar_VConfig.vconfig -> unit FStar_Tactics_Monad.tac) = - fun vcfg -> - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___ -> - (fun g -> - let g = Obj.magic g in - let opts' = - FStar_Options.with_saved_options - (fun uu___ -> - FStar_Options.set g.FStar_Tactics_Types.opts; - FStar_Options.set_vconfig vcfg; - FStar_Options.peek ()) in - let g' = - { - FStar_Tactics_Types.goal_main_env = - (g.FStar_Tactics_Types.goal_main_env); - FStar_Tactics_Types.goal_ctx_uvar = - (g.FStar_Tactics_Types.goal_ctx_uvar); - FStar_Tactics_Types.opts = opts'; - FStar_Tactics_Types.is_guard = - (g.FStar_Tactics_Types.is_guard); - FStar_Tactics_Types.label = (g.FStar_Tactics_Types.label) - } in - Obj.magic (FStar_Tactics_Monad.replace_cur g')) uu___) -let (t_smt_sync : FStar_VConfig.vconfig -> unit FStar_Tactics_Monad.tac) = - fun vcfg -> - let uu___ = - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.cur_goal) - (fun uu___1 -> - (fun goal -> - let goal = Obj.magic goal in - let uu___1 = FStar_Tactics_Monad.get_phi goal in - match uu___1 with - | FStar_Pervasives_Native.None -> - Obj.magic - (FStar_Tactics_Monad.fail "Goal is not irrelevant") - | FStar_Pervasives_Native.Some phi -> - let e = FStar_Tactics_Types.goal_env goal in - let ans = - FStar_Options.with_saved_options - (fun uu___2 -> - FStar_Options.set_vconfig vcfg; - (e.FStar_TypeChecker_Env.solver).FStar_TypeChecker_Env.solve_sync - FStar_Pervasives_Native.None e phi) in - if ans - then - (FStar_Tactics_Monad.mark_uvar_as_already_checked - goal.FStar_Tactics_Types.goal_ctx_uvar; - Obj.magic (solve goal FStar_Syntax_Util.exp_unit)) - else - Obj.magic - (FStar_Tactics_Monad.fail "SMT did not solve this goal")) - uu___1) in - FStar_Tactics_Monad.wrap_err "t_smt_sync" uu___ -let (free_uvars : - FStar_Syntax_Syntax.term -> - FStar_BigInt.t Prims.list FStar_Tactics_Monad.tac) - = - fun uu___ -> - (fun tm -> - let uu___ = - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.repr ()) in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - let uvs = - let uu___2 = - let uu___3 = FStar_Syntax_Free.uvars_uncached tm in - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) - (Obj.magic uu___3) in - FStar_Compiler_List.map - (fun u -> - let uu___3 = - FStar_Syntax_Unionfind.uvar_id - u.FStar_Syntax_Syntax.ctx_uvar_head in - FStar_BigInt.of_int_fs uu___3) uu___2 in - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac - () (Obj.magic uvs))) uu___1))) uu___ -let (all_ext_options : - unit -> (Prims.string * Prims.string) Prims.list FStar_Tactics_Monad.tac) = - fun uu___ -> - (fun uu___ -> - let uu___1 = - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.repr ()) in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___1 - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - let uu___3 = FStar_Options_Ext.all () in - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac - () (Obj.magic uu___3))) uu___2))) uu___ -let (ext_getv : Prims.string -> Prims.string FStar_Tactics_Monad.tac) = - fun uu___ -> - (fun k -> - let uu___ = - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.repr ()) in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - let uu___2 = FStar_Options_Ext.get k in - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac - () (Obj.magic uu___2))) uu___1))) uu___ -let (ext_getns : - Prims.string -> - (Prims.string * Prims.string) Prims.list FStar_Tactics_Monad.tac) - = - fun uu___ -> - (fun ns -> - let uu___ = - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.repr ()) in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - let uu___2 = FStar_Options_Ext.getns ns in - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac - () (Obj.magic uu___2))) uu___1))) uu___ -let alloc : 'a . 'a -> 'a FStar_Tactics_Types.tref FStar_Tactics_Monad.tac = - fun uu___ -> - (fun x -> - let uu___ = - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.repr ()) in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - let uu___2 = FStar_Compiler_Util.mk_ref x in - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac - () (Obj.magic uu___2))) uu___1))) uu___ -let read : 'a . 'a FStar_Tactics_Types.tref -> 'a FStar_Tactics_Monad.tac = - fun uu___ -> - (fun r -> - let uu___ = - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.repr ()) in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - let uu___2 = FStar_Compiler_Effect.op_Bang r in - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac - () (Obj.magic uu___2))) uu___1))) uu___ -let write : - 'a . 'a FStar_Tactics_Types.tref -> 'a -> unit FStar_Tactics_Monad.tac = - fun r -> - fun x -> - let uu___ = - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.repr ()) in - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - FStar_Compiler_Effect.op_Colon_Equals r x; - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.repr ()))) uu___1) -let (dbg_refl : env -> (unit -> Prims.string) -> unit) = - fun g -> - fun msg -> - let uu___ = FStar_Compiler_Effect.op_Bang dbg_ReflTc in - if uu___ - then let uu___1 = msg () in FStar_Compiler_Util.print_string uu___1 - else () -type issues = FStar_Errors.issue Prims.list -let (refl_typing_guard : - env -> FStar_Syntax_Syntax.typ -> unit FStar_Tactics_Monad.tac) = - fun e -> - fun g -> - let reason = "refl_typing_guard" in - let uu___ = FStar_TypeChecker_Env.get_range e in - proc_guard_formula "refl_typing_guard" e g FStar_Pervasives_Native.None - uu___ -let uncurry : - 'uuuuu 'uuuuu1 'uuuuu2 . - ('uuuuu -> 'uuuuu1 -> 'uuuuu2) -> ('uuuuu * 'uuuuu1) -> 'uuuuu2 - = fun f -> fun uu___ -> match uu___ with | (x, y) -> f x y -let __refl_typing_builtin_wrapper : - 'a . - (unit -> ('a * (env * FStar_Syntax_Syntax.typ) Prims.list)) -> - ('a FStar_Pervasives_Native.option * issues) FStar_Tactics_Monad.tac - = - fun uu___ -> - (fun f -> - let tx = FStar_Syntax_Unionfind.new_transaction () in - let uu___ = - try - (fun uu___1 -> - match () with - | () -> FStar_Errors.catch_errors_and_ignore_rest f) () - with - | uu___1 -> - let issue = - let uu___2 = - let uu___3 = FStar_Compiler_Util.print_exn uu___1 in - FStar_Errors_Msg.mkmsg uu___3 in - let uu___3 = FStar_Errors.get_ctx () in - { - FStar_Errors.issue_msg = uu___2; - FStar_Errors.issue_level = FStar_Errors.EError; - FStar_Errors.issue_range = FStar_Pervasives_Native.None; - FStar_Errors.issue_number = - (FStar_Pervasives_Native.Some (Prims.of_int (17))); - FStar_Errors.issue_ctx = uu___3 - } in - ([issue], FStar_Pervasives_Native.None) in - match uu___ with - | (errs, r) -> - let gs = - if FStar_Pervasives_Native.uu___is_Some r - then - let allow_uvars = false in - let allow_names = true in - FStar_Compiler_List.map - (fun uu___1 -> - match uu___1 with - | (e, g) -> - let uu___2 = - FStar_Syntax_Compress.deep_compress allow_uvars - allow_names g in - (e, uu___2)) - (FStar_Pervasives_Native.snd - (FStar_Pervasives_Native.__proj__Some__item__v r)) - else [] in - let r1 = FStar_Compiler_Util.map_opt r FStar_Pervasives_Native.fst in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - () (Obj.magic FStar_Tactics_Monad.get) - (fun uu___1 -> - (fun ps -> - let ps = Obj.magic ps in - FStar_TypeChecker_Env.promote_id_info - ps.FStar_Tactics_Types.main_context - (FStar_TypeChecker_Tc.compress_and_norm - ps.FStar_Tactics_Types.main_context); - FStar_Syntax_Unionfind.rollback tx; - if (FStar_Compiler_List.length errs) > Prims.int_zero - then - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic (FStar_Pervasives_Native.None, errs))) - else - (let uu___4 = - FStar_Tactics_Monad.iter_tac - (uncurry refl_typing_guard) gs in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () uu___4 - (fun uu___5 -> - (fun uu___5 -> - let uu___5 = Obj.magic uu___5 in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic (r1, errs)))) uu___5)))) - uu___1))) uu___ -let catch_all : - 'a . - 'a FStar_Tactics_Monad.tac -> - (issues, 'a) FStar_Pervasives.either FStar_Tactics_Monad.tac - = - fun f -> - FStar_Tactics_Monad.mk_tac - (fun ps -> - let uu___ = - FStar_Errors.catch_errors_and_ignore_rest - (fun uu___1 -> FStar_Tactics_Monad.run f ps) in - match uu___ with - | ([], FStar_Pervasives_Native.Some (FStar_Tactics_Result.Success - (v, ps'))) -> - FStar_Tactics_Result.Success ((FStar_Pervasives.Inr v), ps') - | (errs, uu___1) -> - FStar_Tactics_Result.Success ((FStar_Pervasives.Inl errs), ps)) -let refl_typing_builtin_wrapper : - 'a . - Prims.string -> - (unit -> ('a * (env * FStar_Syntax_Syntax.typ) Prims.list)) -> - ('a FStar_Pervasives_Native.option * issues) FStar_Tactics_Monad.tac - = - fun uu___1 -> - fun uu___ -> - (fun label -> - fun f -> - let uu___ = - let uu___1 = - let uu___2 = __refl_typing_builtin_wrapper f in - catch_all uu___2 in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac - () () (Obj.magic uu___1) - (fun uu___2 -> - (fun uu___2 -> - let uu___2 = Obj.magic uu___2 in - match uu___2 with - | FStar_Pervasives.Inl errs -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic - (FStar_Pervasives_Native.None, errs))) - | FStar_Pervasives.Inr r -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic r))) uu___2)) in - Obj.magic - (FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () - () (Obj.magic uu___) - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - match uu___1 with - | (o, errs) -> - let errs1 = - FStar_Compiler_List.map - (fun is -> - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Errors_Msg.text - (Prims.strcat - "Raised within Tactics." label) in - [uu___4] in - FStar_Compiler_List.op_At - is.FStar_Errors.issue_msg uu___3 in - { - FStar_Errors.issue_msg = uu___2; - FStar_Errors.issue_level = - (is.FStar_Errors.issue_level); - FStar_Errors.issue_range = - (is.FStar_Errors.issue_range); - FStar_Errors.issue_number = - (is.FStar_Errors.issue_number); - FStar_Errors.issue_ctx = - (is.FStar_Errors.issue_ctx) - }) errs in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic (o, errs1)))) uu___1))) uu___1 - uu___ -let (no_uvars_in_term : FStar_Syntax_Syntax.term -> Prims.bool) = - fun t -> - (let uu___ = FStar_Syntax_Free.uvars t in - FStar_Class_Setlike.is_empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) (Obj.magic uu___)) - && - (let uu___ = FStar_Syntax_Free.univs t in - FStar_Class_Setlike.is_empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_univ_uvar)) (Obj.magic uu___)) -let (no_univ_uvars_in_term : FStar_Syntax_Syntax.term -> Prims.bool) = - fun t -> - let uu___ = FStar_Syntax_Free.univs t in - FStar_Class_Setlike.is_empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_univ_uvar)) (Obj.magic uu___) -let (no_uvars_in_g : env -> Prims.bool) = - fun g -> - FStar_Compiler_Util.for_all - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.Binding_var bv -> - no_uvars_in_term bv.FStar_Syntax_Syntax.sort - | uu___1 -> true) g.FStar_TypeChecker_Env.gamma -type relation = - | Subtyping - | Equality -let (uu___is_Subtyping : relation -> Prims.bool) = - fun projectee -> match projectee with | Subtyping -> true | uu___ -> false -let (uu___is_Equality : relation -> Prims.bool) = - fun projectee -> match projectee with | Equality -> true | uu___ -> false -let (unexpected_uvars_issue : - FStar_Compiler_Range_Type.range -> FStar_Errors.issue) = - fun r -> - let i = - let uu___ = FStar_Errors_Msg.mkmsg "Cannot check relation with uvars" in - let uu___1 = - let uu___2 = - FStar_Errors.errno - FStar_Errors_Codes.Error_UnexpectedUnresolvedUvar in - FStar_Pervasives_Native.Some uu___2 in - { - FStar_Errors.issue_msg = uu___; - FStar_Errors.issue_level = FStar_Errors.EError; - FStar_Errors.issue_range = (FStar_Pervasives_Native.Some r); - FStar_Errors.issue_number = uu___1; - FStar_Errors.issue_ctx = [] - } in - i -let (refl_is_non_informative : - env -> - FStar_Syntax_Syntax.typ -> - (unit FStar_Pervasives_Native.option * issues) FStar_Tactics_Monad.tac) - = - fun uu___1 -> - fun uu___ -> - (fun g -> - fun t -> - let uu___ = (no_uvars_in_g g) && (no_uvars_in_term t) in - if uu___ - then - Obj.magic - (Obj.repr - (refl_typing_builtin_wrapper "refl_is_non_informative" - (fun uu___1 -> - let g1 = - FStar_TypeChecker_Env.set_range g - t.FStar_Syntax_Syntax.pos in - dbg_refl g1 - (fun uu___3 -> - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.format1 - "refl_is_non_informative: %s\n" uu___4); - (let b = - FStar_TypeChecker_Core.is_non_informative g1 t in - dbg_refl g1 - (fun uu___4 -> - let uu___5 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) b in - FStar_Compiler_Util.format1 - "refl_is_non_informative: returned %s" uu___5); - if b - then ((), []) - else - FStar_Errors.raise_error - FStar_TypeChecker_Env.hasRange_env g1 - FStar_Errors_Codes.Fatal_UnexpectedTerm () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic "is_non_informative returned false"))))) - else - Obj.magic - (Obj.repr - (let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_TypeChecker_Env.get_range g in - unexpected_uvars_issue uu___5 in - [uu___4] in - (FStar_Pervasives_Native.None, uu___3) in - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.magic uu___2)))) uu___1 uu___ -let (refl_check_relation : - relation -> - Prims.bool -> - Prims.bool -> - env -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.typ -> - (unit FStar_Pervasives_Native.option * issues) - FStar_Tactics_Monad.tac) - = - fun uu___5 -> - fun uu___4 -> - fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun rel -> - fun smt_ok -> - fun unfolding_ok -> - fun g -> - fun t0 -> - fun t1 -> - let uu___ = - ((no_uvars_in_g g) && (no_uvars_in_term t0)) && - (no_uvars_in_term t1) in - if uu___ - then - Obj.magic - (Obj.repr - (refl_typing_builtin_wrapper - "refl_check_relation" - (fun uu___1 -> - let g1 = - FStar_TypeChecker_Env.set_range g - t0.FStar_Syntax_Syntax.pos in - dbg_refl g1 - (fun uu___3 -> - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t0 in - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t1 in - FStar_Compiler_Util.format3 - "refl_check_relation: %s %s %s\n" - uu___4 - (if rel = Subtyping - then "<:?" - else "=?=") uu___5); - (let f = - if rel = Subtyping - then - FStar_TypeChecker_Core.check_term_subtyping - else - FStar_TypeChecker_Core.check_term_equality in - let uu___3 = - f smt_ok unfolding_ok g1 t0 t1 in - match uu___3 with - | FStar_Pervasives.Inl - (FStar_Pervasives_Native.None) - -> - (dbg_refl g1 - (fun uu___5 -> - "refl_check_relation: succeeded (no guard)\n"); - ((), [])) - | FStar_Pervasives.Inl - (FStar_Pervasives_Native.Some - guard_f) -> - (dbg_refl g1 - (fun uu___5 -> - "refl_check_relation: succeeded\n"); - ((), [(g1, guard_f)])) - | FStar_Pervasives.Inr err -> - (dbg_refl g1 - (fun uu___5 -> - let uu___6 = - FStar_TypeChecker_Core.print_error - err in - FStar_Compiler_Util.format1 - "refl_check_relation failed: %s\n" - uu___6); - (let uu___5 = - let uu___6 = - FStar_TypeChecker_Core.print_error - err in - Prims.strcat - "check_relation failed: " - uu___6 in - FStar_Errors.raise_error - FStar_TypeChecker_Env.hasRange_env - g1 - FStar_Errors_Codes.Fatal_IllTyped - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___5))))))) - else - Obj.magic - (Obj.repr - (let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_TypeChecker_Env.get_range g in - unexpected_uvars_issue uu___5 in - [uu___4] in - (FStar_Pervasives_Native.None, uu___3) in - FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic uu___2)))) uu___5 uu___4 - uu___3 uu___2 uu___1 uu___ -let (refl_check_subtyping : - env -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.typ -> - (unit FStar_Pervasives_Native.option * issues) - FStar_Tactics_Monad.tac) - = - fun g -> - fun t0 -> fun t1 -> refl_check_relation Subtyping true true g t0 t1 -let (t_refl_check_equiv : - Prims.bool -> - Prims.bool -> - env -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.typ -> - (unit FStar_Pervasives_Native.option * issues) - FStar_Tactics_Monad.tac) - = refl_check_relation Equality -let (to_must_tot : FStar_TypeChecker_Core.tot_or_ghost -> Prims.bool) = - fun eff -> - match eff with - | FStar_TypeChecker_Core.E_Total -> true - | FStar_TypeChecker_Core.E_Ghost -> false -let (tot_or_ghost_to_string : - FStar_TypeChecker_Core.tot_or_ghost -> Prims.string) = - fun uu___ -> - match uu___ with - | FStar_TypeChecker_Core.E_Total -> "E_Total" - | FStar_TypeChecker_Core.E_Ghost -> "E_Ghost" -let (refl_norm_type : - env -> FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.typ) = - fun g -> - fun t -> - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Exclude FStar_TypeChecker_Env.Zeta] g t -let (refl_core_compute_term_type : - env -> - FStar_Syntax_Syntax.term -> - ((FStar_TypeChecker_Core.tot_or_ghost * FStar_Syntax_Syntax.typ) - FStar_Pervasives_Native.option * issues) FStar_Tactics_Monad.tac) - = - fun uu___1 -> - fun uu___ -> - (fun g -> - fun e -> - let uu___ = (no_uvars_in_g g) && (no_uvars_in_term e) in - if uu___ - then - Obj.magic - (Obj.repr - (refl_typing_builtin_wrapper "refl_core_compute_term_type" - (fun uu___1 -> - let g1 = - FStar_TypeChecker_Env.set_range g - e.FStar_Syntax_Syntax.pos in - dbg_refl g1 - (fun uu___3 -> - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term e in - FStar_Compiler_Util.format1 - "refl_core_compute_term_type: %s\n" uu___4); - (let guards = FStar_Compiler_Util.mk_ref [] in - let gh g2 guard = - (let uu___4 = - let uu___5 = - FStar_Compiler_Effect.op_Bang guards in - (g2, guard) :: uu___5 in - FStar_Compiler_Effect.op_Colon_Equals guards - uu___4); - true in - let uu___3 = - FStar_TypeChecker_Core.compute_term_type_handle_guards - g1 e gh in - match uu___3 with - | FStar_Pervasives.Inl (eff, t) -> - let t1 = refl_norm_type g1 t in - (dbg_refl g1 - (fun uu___5 -> - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term e in - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.format2 - "refl_core_compute_term_type for %s computed type %s\n" - uu___6 uu___7); - (let uu___5 = - FStar_Compiler_Effect.op_Bang guards in - ((eff, t1), uu___5))) - | FStar_Pervasives.Inr err -> - (dbg_refl g1 - (fun uu___5 -> - let uu___6 = - FStar_TypeChecker_Core.print_error err in - FStar_Compiler_Util.format1 - "refl_core_compute_term_type: %s\n" - uu___6); - (let uu___5 = - let uu___6 = - FStar_TypeChecker_Core.print_error err in - Prims.strcat - "core_compute_term_type failed: " uu___6 in - FStar_Errors.raise_error - FStar_TypeChecker_Env.hasRange_env g1 - FStar_Errors_Codes.Fatal_IllTyped () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___5))))))) - else - Obj.magic - (Obj.repr - (let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_TypeChecker_Env.get_range g in - unexpected_uvars_issue uu___5 in - [uu___4] in - (FStar_Pervasives_Native.None, uu___3) in - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.magic uu___2)))) uu___1 uu___ -let (refl_core_check_term : - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.typ -> - FStar_TypeChecker_Core.tot_or_ghost -> - (unit FStar_Pervasives_Native.option * issues) - FStar_Tactics_Monad.tac) - = - fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun g -> - fun e -> - fun t -> - fun eff -> - let uu___ = - ((no_uvars_in_g g) && (no_uvars_in_term e)) && - (no_uvars_in_term t) in - if uu___ - then - Obj.magic - (Obj.repr - (refl_typing_builtin_wrapper "refl_core_check_term" - (fun uu___1 -> - let g1 = - FStar_TypeChecker_Env.set_range g - e.FStar_Syntax_Syntax.pos in - dbg_refl g1 - (fun uu___3 -> - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term e in - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.format3 - "refl_core_check_term: term: %s, type: %s, eff: %s\n" - uu___4 uu___5 - (tot_or_ghost_to_string eff)); - (let must_tot = to_must_tot eff in - let uu___3 = - FStar_TypeChecker_Core.check_term g1 e t - must_tot in - match uu___3 with - | FStar_Pervasives.Inl - (FStar_Pervasives_Native.None) -> - (dbg_refl g1 - (fun uu___5 -> - "refl_core_check_term: succeeded with no guard\n"); - ((), [])) - | FStar_Pervasives.Inl - (FStar_Pervasives_Native.Some guard) -> - (dbg_refl g1 - (fun uu___5 -> - "refl_core_check_term: succeeded with guard\n"); - ((), [(g1, guard)])) - | FStar_Pervasives.Inr err -> - (dbg_refl g1 - (fun uu___5 -> - let uu___6 = - FStar_TypeChecker_Core.print_error - err in - FStar_Compiler_Util.format1 - "refl_core_check_term failed: %s\n" - uu___6); - (let uu___5 = - let uu___6 = - FStar_TypeChecker_Core.print_error - err in - Prims.strcat - "refl_core_check_term failed: " - uu___6 in - FStar_Errors.raise_error - FStar_TypeChecker_Env.hasRange_env - g1 FStar_Errors_Codes.Fatal_IllTyped - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___5))))))) - else - Obj.magic - (Obj.repr - (let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_TypeChecker_Env.get_range g in - unexpected_uvars_issue uu___5 in - [uu___4] in - (FStar_Pervasives_Native.None, uu___3) in - FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic uu___2)))) uu___3 uu___2 uu___1 uu___ -let (refl_core_check_term_at_type : - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.typ -> - (FStar_TypeChecker_Core.tot_or_ghost FStar_Pervasives_Native.option * - issues) FStar_Tactics_Monad.tac) - = - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun g -> - fun e -> - fun t -> - let uu___ = - ((no_uvars_in_g g) && (no_uvars_in_term e)) && - (no_uvars_in_term t) in - if uu___ - then - Obj.magic - (Obj.repr - (refl_typing_builtin_wrapper - "refl_core_check_term_at_type" - (fun uu___1 -> - let g1 = - FStar_TypeChecker_Env.set_range g - e.FStar_Syntax_Syntax.pos in - dbg_refl g1 - (fun uu___3 -> - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term e in - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.format2 - "refl_core_check_term_at_type: term: %s, type: %s\n" - uu___4 uu___5); - (let uu___3 = - FStar_TypeChecker_Core.check_term_at_type g1 e - t in - match uu___3 with - | FStar_Pervasives.Inl - (eff, FStar_Pervasives_Native.None) -> - (dbg_refl g1 - (fun uu___5 -> - FStar_Compiler_Util.format1 - "refl_core_check_term_at_type: succeeded with eff %s and no guard\n" - (tot_or_ghost_to_string eff)); - (eff, [])) - | FStar_Pervasives.Inl - (eff, FStar_Pervasives_Native.Some guard) -> - (dbg_refl g1 - (fun uu___5 -> - FStar_Compiler_Util.format1 - "refl_core_check_term_at_type: succeeded with eff %s and guard\n" - (tot_or_ghost_to_string eff)); - (eff, [(g1, guard)])) - | FStar_Pervasives.Inr err -> - (dbg_refl g1 - (fun uu___5 -> - let uu___6 = - FStar_TypeChecker_Core.print_error - err in - FStar_Compiler_Util.format1 - "refl_core_check_term_at_type failed: %s\n" - uu___6); - (let uu___5 = - let uu___6 = - FStar_TypeChecker_Core.print_error err in - Prims.strcat - "refl_core_check_term failed: " uu___6 in - FStar_Errors.raise_error - FStar_TypeChecker_Env.hasRange_env g1 - FStar_Errors_Codes.Fatal_IllTyped () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___5))))))) - else - Obj.magic - (Obj.repr - (let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_TypeChecker_Env.get_range g in - unexpected_uvars_issue uu___5 in - [uu___4] in - (FStar_Pervasives_Native.None, uu___3) in - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac - () (Obj.magic uu___2)))) uu___2 uu___1 uu___ -let (refl_tc_term : - env -> - FStar_Syntax_Syntax.term -> - ((FStar_Syntax_Syntax.term * (FStar_TypeChecker_Core.tot_or_ghost * - FStar_Syntax_Syntax.typ)) FStar_Pervasives_Native.option * issues) - FStar_Tactics_Monad.tac) - = - fun uu___1 -> - fun uu___ -> - (fun g -> - fun e -> - let uu___ = (no_uvars_in_g g) && (no_uvars_in_term e) in - if uu___ - then - Obj.magic - (Obj.repr - (refl_typing_builtin_wrapper "refl_tc_term" - (fun uu___1 -> - let g1 = - FStar_TypeChecker_Env.set_range g - e.FStar_Syntax_Syntax.pos in - dbg_refl g1 - (fun uu___3 -> - let uu___4 = - FStar_Class_Show.show - FStar_Compiler_Range_Ops.showable_range - e.FStar_Syntax_Syntax.pos in - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term e in - FStar_Compiler_Util.format2 - "refl_tc_term@%s: %s\n" uu___4 uu___5); - dbg_refl g1 - (fun uu___4 -> "refl_tc_term: starting tc {\n"); - (let g2 = - { - FStar_TypeChecker_Env.solver = - (g1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (g1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (g1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (g1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (g1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (g1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (g1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (g1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (g1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (g1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = false; - FStar_TypeChecker_Env.effects = - (g1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (g1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (g1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (g1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (g1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (g1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (g1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (g1.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (g1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (g1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (g1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (g1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (g1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (g1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (g1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (g1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (g1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (g1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (g1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (g1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (g1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (g1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (g1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (g1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (g1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (g1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (g1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (g1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (g1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (g1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (g1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (g1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (g1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (g1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (g1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (g1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (g1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (g1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (g1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (g1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (g1.FStar_TypeChecker_Env.missing_decl) - } in - let e1 = - let g3 = - { - FStar_TypeChecker_Env.solver = - (g2.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (g2.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (g2.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (g2.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (g2.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (g2.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (g2.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (g2.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (g2.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (g2.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (g2.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (g2.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (g2.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (g2.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (g2.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (g2.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (g2.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (g2.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = true; - FStar_TypeChecker_Env.lax_universes = - (g2.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = true; - FStar_TypeChecker_Env.failhard = - (g2.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (g2.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (g2.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (g2.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (g2.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (g2.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (g2.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (g2.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (g2.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (g2.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (g2.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (g2.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (g2.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (g2.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (g2.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (g2.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (g2.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (g2.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (g2.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (g2.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (g2.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (g2.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (g2.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (g2.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (g2.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (g2.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (g2.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (g2.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (g2.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (g2.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (g2.FStar_TypeChecker_Env.missing_decl) - } in - let must_tot = false in - let uu___4 = - g3.FStar_TypeChecker_Env.typeof_tot_or_gtot_term - g3 e must_tot in - match uu___4 with - | (e2, uu___5, guard) -> - (FStar_TypeChecker_Rel.force_trivial_guard g3 - guard; - e2) in - try - (fun uu___4 -> - match () with - | () -> - let uu___5 = - let uu___6 = no_uvars_in_term e1 in - Prims.op_Negation uu___6 in - if uu___5 - then - let uu___6 = - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term e1 in - FStar_Compiler_Util.format1 - "Elaborated term has unresolved implicits: %s" - uu___7 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax - ()) e1 - FStar_Errors_Codes.Error_UnexpectedUnresolvedUvar - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___6) - else - (let allow_uvars = false in - let allow_names = true in - let e2 = - FStar_Syntax_Compress.deep_compress - allow_uvars allow_names e1 in - dbg_refl g2 - (fun uu___8 -> - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - e2 in - FStar_Compiler_Util.format1 - "} finished tc with e = %s\n" - uu___9); - (let guards = - FStar_Compiler_Util.mk_ref [] in - let gh g3 guard = - dbg_refl g3 - (fun uu___9 -> - let uu___10 = - let uu___11 = - FStar_TypeChecker_Env.get_range - g3 in - FStar_Class_Show.show - FStar_Compiler_Range_Ops.showable_range - uu___11 in - let uu___11 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - guard in - let uu___12 = - FStar_Class_Show.show - FStar_Compiler_Range_Ops.showable_range - guard.FStar_Syntax_Syntax.pos in - FStar_Compiler_Util.format3 - "Got guard in Env@%s |- %s@%s\n" - uu___10 uu___11 uu___12); - (let uu___10 = - let uu___11 = - FStar_Compiler_Effect.op_Bang - guards in - (g3, guard) :: uu___11 in - FStar_Compiler_Effect.op_Colon_Equals - guards uu___10); - true in - let uu___8 = - FStar_TypeChecker_Core.compute_term_type_handle_guards - g2 e2 gh in - match uu___8 with - | FStar_Pervasives.Inl (eff, t) -> - let t1 = refl_norm_type g2 t in - (dbg_refl g2 - (fun uu___10 -> - let uu___11 = - FStar_Class_Show.show - FStar_Compiler_Range_Ops.showable_range - e2.FStar_Syntax_Syntax.pos in - let uu___12 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - e2 in - let uu___13 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t1 in - FStar_Compiler_Util.format3 - "refl_tc_term@%s for %s computed type %s\n" - uu___11 uu___12 uu___13); - (let uu___10 = - FStar_Compiler_Effect.op_Bang - guards in - ((e2, (eff, t1)), uu___10))) - | FStar_Pervasives.Inr err -> - (dbg_refl g2 - (fun uu___10 -> - let uu___11 = - FStar_TypeChecker_Core.print_error - err in - FStar_Compiler_Util.format1 - "refl_tc_term failed: %s\n" - uu___11); - (let uu___10 = - let uu___11 = - FStar_TypeChecker_Core.print_error - err in - Prims.strcat - "tc_term callback failed: " - uu___11 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax - ()) e2 - FStar_Errors_Codes.Fatal_IllTyped - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___10)))))) () - with - | FStar_Errors.Error - (FStar_Errors_Codes.Error_UnexpectedUnresolvedUvar, - uu___5, uu___6, uu___7) - -> - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) e1 - FStar_Errors_Codes.Fatal_IllTyped () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "UVars remaing in term after tc_term callback"))))) - else - Obj.magic - (Obj.repr - (let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_TypeChecker_Env.get_range g in - unexpected_uvars_issue uu___5 in - [uu___4] in - (FStar_Pervasives_Native.None, uu___3) in - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.magic uu___2)))) uu___1 uu___ -let (refl_universe_of : - env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.universe FStar_Pervasives_Native.option * issues) - FStar_Tactics_Monad.tac) - = - fun uu___1 -> - fun uu___ -> - (fun g -> - fun e -> - let check_univ_var_resolved g1 u = - let uu___ = FStar_Syntax_Subst.compress_univ u in - match uu___ with - | FStar_Syntax_Syntax.U_unif uu___1 -> - FStar_Errors.raise_error FStar_TypeChecker_Env.hasRange_env - g1 FStar_Errors_Codes.Fatal_IllTyped () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic "Unresolved variable in universe_of callback") - | u1 -> u1 in - let uu___ = (no_uvars_in_g g) && (no_uvars_in_term e) in - if uu___ - then - Obj.magic - (Obj.repr - (refl_typing_builtin_wrapper "refl_universe_of" - (fun uu___1 -> - let g1 = - FStar_TypeChecker_Env.set_range g - e.FStar_Syntax_Syntax.pos in - let uu___2 = FStar_Syntax_Util.type_u () in - match uu___2 with - | (t, u) -> - let must_tot = false in - let uu___3 = - FStar_TypeChecker_Core.check_term g1 e t - must_tot in - (match uu___3 with - | FStar_Pervasives.Inl - (FStar_Pervasives_Native.None) -> - let uu___4 = check_univ_var_resolved g1 u in - (uu___4, []) - | FStar_Pervasives.Inl - (FStar_Pervasives_Native.Some guard) -> - let uu___4 = check_univ_var_resolved g1 u in - (uu___4, [(g1, guard)]) - | FStar_Pervasives.Inr err -> - (dbg_refl g1 - (fun uu___5 -> - let uu___6 = - FStar_TypeChecker_Core.print_error - err in - FStar_Compiler_Util.format1 - "refl_universe_of failed: %s\n" - uu___6); - (let uu___5 = - let uu___6 = - FStar_TypeChecker_Core.print_error err in - Prims.strcat "universe_of failed: " - uu___6 in - FStar_Errors.raise_error - FStar_TypeChecker_Env.hasRange_env g1 - FStar_Errors_Codes.Fatal_IllTyped () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___5))))))) - else - Obj.magic - (Obj.repr - (let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_TypeChecker_Env.get_range g in - unexpected_uvars_issue uu___5 in - [uu___4] in - (FStar_Pervasives_Native.None, uu___3) in - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.magic uu___2)))) uu___1 uu___ -let (refl_check_prop_validity : - env -> - FStar_Syntax_Syntax.term -> - (unit FStar_Pervasives_Native.option * issues) FStar_Tactics_Monad.tac) - = - fun uu___1 -> - fun uu___ -> - (fun g -> - fun e -> - let uu___ = (no_uvars_in_g g) && (no_uvars_in_term e) in - if uu___ - then - Obj.magic - (Obj.repr - (refl_typing_builtin_wrapper "refl_check_prop_validity" - (fun uu___1 -> - let g1 = - FStar_TypeChecker_Env.set_range g - e.FStar_Syntax_Syntax.pos in - dbg_refl g1 - (fun uu___3 -> - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term e in - FStar_Compiler_Util.format1 - "refl_check_prop_validity: %s\n" uu___4); - (let must_tot = false in - (let uu___4 = - let uu___5 = - FStar_Syntax_Util.fvar_const - FStar_Parser_Const.prop_lid in - FStar_TypeChecker_Core.check_term g1 e uu___5 - must_tot in - match uu___4 with - | FStar_Pervasives.Inl - (FStar_Pervasives_Native.None) -> () - | FStar_Pervasives.Inl - (FStar_Pervasives_Native.Some guard) -> - FStar_TypeChecker_Rel.force_trivial_guard g1 - { - FStar_TypeChecker_Common.guard_f = - (FStar_TypeChecker_Common.NonTrivial - guard); - FStar_TypeChecker_Common.deferred_to_tac = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = - (FStar_TypeChecker_Env.trivial_guard.FStar_TypeChecker_Common.implicits) - } - | FStar_Pervasives.Inr err -> - let msg = - let uu___5 = - FStar_TypeChecker_Core.print_error err in - FStar_Compiler_Util.format1 - "refl_check_prop_validity failed (not a prop): %s\n" - uu___5 in - (dbg_refl g1 (fun uu___6 -> msg); - FStar_Errors.raise_error - FStar_TypeChecker_Env.hasRange_env g1 - FStar_Errors_Codes.Fatal_IllTyped () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic msg))); - ((), [(g1, e)]))))) - else - Obj.magic - (Obj.repr - (let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_TypeChecker_Env.get_range g in - unexpected_uvars_issue uu___5 in - [uu___4] in - (FStar_Pervasives_Native.None, uu___3) in - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.magic uu___2)))) uu___1 uu___ -let (refl_check_match_complete : - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> - FStar_Reflection_V2_Data.pattern Prims.list -> - (FStar_Reflection_V2_Data.pattern Prims.list * - FStar_Reflection_V2_Data.binding Prims.list Prims.list) - FStar_Pervasives_Native.option FStar_Tactics_Monad.tac) - = - fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun g -> - fun sc -> - fun scty -> - fun pats -> - let uu___ = - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac - () (Obj.repr ()) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - let one = FStar_Syntax_Util.exp_int "1" in - let brs = - FStar_Compiler_List.map - (fun p -> - let p1 = - FStar_Reflection_V2_Builtins.pack_pat - p in - (p1, FStar_Pervasives_Native.None, one)) - pats in - let mm = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_match - { - FStar_Syntax_Syntax.scrutinee = sc; - FStar_Syntax_Syntax.ret_opt = - FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.brs = brs; - FStar_Syntax_Syntax.rc_opt1 = - FStar_Pervasives_Native.None - }) sc.FStar_Syntax_Syntax.pos in - let env1 = g in - let env2 = - FStar_TypeChecker_Env.set_expected_typ env1 - FStar_Syntax_Syntax.t_int in - let uu___2 = __tc env2 mm in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () - (Obj.magic uu___2) - (fun uu___3 -> - (fun uu___3 -> - let uu___3 = Obj.magic uu___3 in - match uu___3 with - | (mm1, uu___4, g1) -> - let uu___5 = - FStar_Errors.catch_errors_and_ignore_rest - (fun uu___6 -> - let uu___7 = - FStar_TypeChecker_Rel.discharge_guard - env2 g1 in - FStar_TypeChecker_Env.is_trivial - uu___7) in - (match uu___5 with - | (errs, b) -> - (match (errs, b) with - | ([], - FStar_Pervasives_Native.Some - (true)) -> - let get_pats t = - let uu___6 = - let uu___7 = - FStar_Syntax_Util.unmeta - t in - uu___7.FStar_Syntax_Syntax.n in - match uu___6 with - | FStar_Syntax_Syntax.Tm_match - { - FStar_Syntax_Syntax.scrutinee - = uu___7; - FStar_Syntax_Syntax.ret_opt - = uu___8; - FStar_Syntax_Syntax.brs - = brs1; - FStar_Syntax_Syntax.rc_opt1 - = uu___9;_} - -> - FStar_Compiler_List.map - (fun uu___10 - -> - match uu___10 - with - | (p, - uu___11, - uu___12) - -> p) - brs1 - | uu___7 -> - failwith - "refl_check_match_complete: not a match?" in - let pats1 = - get_pats mm1 in - let rec bnds_for_pat p - = - match p.FStar_Syntax_Syntax.v - with - | FStar_Syntax_Syntax.Pat_constant - uu___6 -> [] - | FStar_Syntax_Syntax.Pat_cons - (fv, uu___6, - pats2) - -> - FStar_Compiler_List.concatMap - (fun uu___7 -> - match uu___7 - with - | (p1, - uu___8) - -> - bnds_for_pat - p1) pats2 - | FStar_Syntax_Syntax.Pat_var - bv -> - let uu___6 = - bv_to_binding - bv in - [uu___6] - | FStar_Syntax_Syntax.Pat_dot_term - uu___6 -> [] in - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Compiler_List.map - FStar_Reflection_V2_Builtins.inspect_pat - pats1 in - let uu___9 = - FStar_Compiler_List.map - bnds_for_pat - pats1 in - (uu___8, uu___9) in - FStar_Pervasives_Native.Some - uu___7 in - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic uu___6)) - | uu___6 -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac - () - (Obj.magic - FStar_Pervasives_Native.None))))) - uu___3))) uu___1))) uu___3 uu___2 - uu___1 uu___ -let (refl_instantiate_implicits : - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option -> - (((FStar_Syntax_Syntax.bv * FStar_Syntax_Syntax.typ) Prims.list * - FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.typ) - FStar_Pervasives_Native.option * issues) FStar_Tactics_Monad.tac) - = - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun g -> - fun e -> - fun expected_typ -> - let uu___ = (no_uvars_in_g g) && (no_uvars_in_term e) in - if uu___ - then - Obj.magic - (Obj.repr - (refl_typing_builtin_wrapper - "refl_instantiate_implicits" - (fun uu___1 -> - let g1 = - FStar_TypeChecker_Env.set_range g - e.FStar_Syntax_Syntax.pos in - dbg_refl g1 - (fun uu___3 -> - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term e in - FStar_Compiler_Util.format1 - "refl_instantiate_implicits: %s\n" uu___4); - dbg_refl g1 - (fun uu___4 -> - "refl_instantiate_implicits: starting tc {\n"); - (let must_tot = false in - let g2 = - match expected_typ with - | FStar_Pervasives_Native.None -> - let uu___4 = - FStar_TypeChecker_Env.clear_expected_typ - g1 in - FStar_Pervasives_Native.fst uu___4 - | FStar_Pervasives_Native.Some typ -> - FStar_TypeChecker_Env.set_expected_typ g1 - typ in - let g3 = - { - FStar_TypeChecker_Env.solver = - (g2.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (g2.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (g2.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (g2.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (g2.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (g2.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (g2.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (g2.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (g2.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (g2.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - false; - FStar_TypeChecker_Env.effects = - (g2.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (g2.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (g2.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (g2.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (g2.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (g2.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (g2.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = true; - FStar_TypeChecker_Env.lax_universes = - (g2.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = true; - FStar_TypeChecker_Env.failhard = - (g2.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (g2.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (g2.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (g2.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (g2.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (g2.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (g2.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (g2.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (g2.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (g2.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (g2.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (g2.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (g2.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (g2.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (g2.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (g2.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (g2.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (g2.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (g2.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (g2.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (g2.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (g2.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (g2.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (g2.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (g2.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (g2.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (g2.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (g2.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (g2.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (g2.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (g2.FStar_TypeChecker_Env.missing_decl) - } in - let uu___4 = - g3.FStar_TypeChecker_Env.typeof_tot_or_gtot_term - g3 e must_tot in - match uu___4 with - | (e1, t, guard) -> - let guard1 = - let uu___5 = - FStar_TypeChecker_Rel.solve_deferred_constraints - g3 guard in - FStar_TypeChecker_Rel.resolve_implicits g3 - uu___5 in - let bvs_and_ts = - let uu___5 = - FStar_Class_Listlike.to_list - (FStar_Compiler_CList.listlike_clist - ()) - guard1.FStar_TypeChecker_Common.implicits in - match uu___5 with - | [] -> [] - | imps -> - let l = - FStar_Compiler_List.map - (fun uu___6 -> - match uu___6 with - | { - FStar_TypeChecker_Common.imp_reason - = uu___7; - FStar_TypeChecker_Common.imp_uvar - = imp_uvar; - FStar_TypeChecker_Common.imp_tm - = uu___8; - FStar_TypeChecker_Common.imp_range - = uu___9;_} - -> - let uu___10 = - FStar_Syntax_Util.ctx_uvar_typ - imp_uvar in - let uu___11 = - let uu___12 = - FStar_Syntax_Syntax.mk - FStar_Syntax_Syntax.Tm_unknown - FStar_Compiler_Range_Type.dummyRange in - FStar_Syntax_Syntax.new_bv - FStar_Pervasives_Native.None - uu___12 in - ((imp_uvar.FStar_Syntax_Syntax.ctx_uvar_head), - uu___10, uu___11)) imps in - (FStar_Compiler_List.iter - (fun uu___7 -> - match uu___7 with - | (uv, uu___8, bv) -> - let uu___9 = - FStar_Syntax_Syntax.bv_to_name - bv in - FStar_Syntax_Util.set_uvar - uv uu___9) l; - FStar_Compiler_List.map - (fun uu___7 -> - match uu___7 with - | (uu___8, t1, bv) -> (bv, t1)) - l) in - (dbg_refl g3 - (fun uu___6 -> - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - e1 in - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.format2 - "refl_instantiate_implicits: inferred %s : %s" - uu___7 uu___8); - (let uu___7 = - let uu___8 = no_univ_uvars_in_term e1 in - Prims.op_Negation uu___8 in - if uu___7 - then - let uu___8 = - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - e1 in - FStar_Compiler_Util.format1 - "Elaborated term has unresolved univ uvars: %s" - uu___9 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax - ()) e1 - FStar_Errors_Codes.Error_UnexpectedUnresolvedUvar - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___8) - else ()); - (let uu___8 = - let uu___9 = no_univ_uvars_in_term t in - Prims.op_Negation uu___9 in - if uu___8 - then - let uu___9 = - let uu___10 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.format1 - "Inferred type has unresolved univ uvars: %s" - uu___10 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax - ()) e1 - FStar_Errors_Codes.Error_UnexpectedUnresolvedUvar - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___9) - else ()); - FStar_Compiler_List.iter - (fun uu___9 -> - match uu___9 with - | (x, t1) -> - let uu___10 = - let uu___11 = - no_univ_uvars_in_term t1 in - Prims.op_Negation uu___11 in - if uu___10 - then - let uu___11 = - let uu___12 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_bv - x in - let uu___13 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t1 in - FStar_Compiler_Util.format2 - "Inferred type has unresolved univ uvars: %s:%s" - uu___12 uu___13 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax - ()) e1 - FStar_Errors_Codes.Error_UnexpectedUnresolvedUvar - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___11) - else ()) bvs_and_ts; - (let g4 = - let uu___9 = - FStar_Compiler_List.map - (fun uu___10 -> - match uu___10 with - | (bv, t1) -> - { - FStar_Syntax_Syntax.ppname - = - (bv.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (bv.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = - t1 - }) bvs_and_ts in - FStar_TypeChecker_Env.push_bvs g3 uu___9 in - let allow_uvars = false in - let allow_names = true in - let e2 = - FStar_Syntax_Compress.deep_compress - allow_uvars allow_names e1 in - let t1 = - let uu___9 = refl_norm_type g4 t in - FStar_Syntax_Compress.deep_compress - allow_uvars allow_names uu___9 in - let bvs_and_ts1 = - FStar_Compiler_List.map - (fun uu___9 -> - match uu___9 with - | (bv, t2) -> - let uu___10 = - FStar_Syntax_Compress.deep_compress - allow_uvars allow_names t2 in - (bv, uu___10)) bvs_and_ts in - dbg_refl g4 - (fun uu___10 -> - let uu___11 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - e2 in - let uu___12 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t1 in - FStar_Compiler_Util.format2 - "} finished tc with e = %s and t = %s\n" - uu___11 uu___12); - ((bvs_and_ts1, e2, t1), []))))))) - else - Obj.magic - (Obj.repr - (let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_TypeChecker_Env.get_range g in - unexpected_uvars_issue uu___5 in - [uu___4] in - (FStar_Pervasives_Native.None, uu___3) in - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac - () (Obj.magic uu___2)))) uu___2 uu___1 uu___ -let (refl_try_unify : - env -> - (FStar_Syntax_Syntax.bv * FStar_Syntax_Syntax.typ) Prims.list -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> - ((FStar_Syntax_Syntax.bv * FStar_Syntax_Syntax.term) Prims.list - FStar_Pervasives_Native.option * issues) FStar_Tactics_Monad.tac) - = - fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun g -> - fun uvs -> - fun t0 -> - fun t1 -> - let uu___ = - (((no_uvars_in_g g) && (no_uvars_in_term t0)) && - (no_uvars_in_term t1)) - && - (let uu___1 = - FStar_Compiler_List.map FStar_Pervasives_Native.snd - uvs in - FStar_Compiler_List.for_all no_uvars_in_term uu___1) in - if uu___ - then - Obj.magic - (Obj.repr - (refl_typing_builtin_wrapper "refl_try_unify" - (fun uu___1 -> - dbg_refl g - (fun uu___3 -> - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t0 in - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t1 in - let uu___6 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - (FStar_Class_Show.show_tuple2 - FStar_Syntax_Print.showable_bv - FStar_Syntax_Print.showable_term)) - uvs in - FStar_Compiler_Util.format3 - "refl_try_unify %s and %s, with uvs: %s {\n" - uu___4 uu___5 uu___6); - (let g1 = - FStar_TypeChecker_Env.set_range g - t0.FStar_Syntax_Syntax.pos in - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Compiler_Util.pimap_empty () in - (FStar_TypeChecker_Env.trivial_guard, - [], uu___5) in - FStar_Compiler_List.fold_left - (fun uu___5 -> - fun uu___6 -> - match (uu___5, uu___6) with - | ((guard_uvs, ss, tbl), (bv, t)) - -> - let t2 = - FStar_Syntax_Subst.subst ss t in - let uu___7 = - let reason = - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_bv - bv in - FStar_Compiler_Util.format1 - "refl_try_unify for %s" - uu___8 in - let should_check_uvar = - FStar_Syntax_Syntax.Allow_untyped - "refl_try_unify" in - FStar_TypeChecker_Env.new_implicit_var_aux - reason - t0.FStar_Syntax_Syntax.pos - g1 t2 should_check_uvar - FStar_Pervasives_Native.None - false in - (match uu___7 with - | (uv_t, (ctx_u, uu___8), - guard_uv) -> - let uv_id = - FStar_Syntax_Unionfind.uvar_unique_id - ctx_u.FStar_Syntax_Syntax.ctx_uvar_head in - let uu___9 = - FStar_TypeChecker_Env.conj_guard - guard_uvs guard_uv in - let uu___10 = - FStar_Compiler_Util.pimap_add - tbl uv_id - ((ctx_u.FStar_Syntax_Syntax.ctx_uvar_head), - bv) in - (uu___9, - ((FStar_Syntax_Syntax.NT - (bv, uv_t)) :: ss), - uu___10))) uu___4 uvs in - match uu___3 with - | (guard_uvs, ss, tbl) -> - let uu___4 = - let uu___5 = - FStar_Syntax_Subst.subst ss t0 in - let uu___6 = - FStar_Syntax_Subst.subst ss t1 in - (uu___5, uu___6) in - (match uu___4 with - | (t01, t11) -> - let g2 = - { - FStar_TypeChecker_Env.solver = - (g1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (g1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule - = - (g1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (g1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig - = - (g1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache - = - (g1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (g1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ - = - (g1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (g1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (g1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp - = - (g1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (g1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize - = - (g1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (g1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level - = - (g1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars - = - (g1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict - = - (g1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface - = - (g1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - true; - FStar_TypeChecker_Env.lax_universes - = - (g1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - true; - FStar_TypeChecker_Env.failhard - = - (g1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking - = - (g1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping - = - (g1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics - = - (g1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce - = - (g1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (g1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (g1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of - = - (g1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (g1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force - = - (g1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (g1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (g1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (g1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths - = - (g1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns - = - (g1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook - = - (g1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (g1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (g1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess - = - (g1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess - = - (g1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info - = - (g1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks - = - (g1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (g1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (g1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab - = - (g1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (g1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (g1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (g1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (g1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check - = - (g1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl - = - (g1.FStar_TypeChecker_Env.missing_decl) - } in - let guard_eq = - let smt_ok = true in - FStar_TypeChecker_Rel.try_teq - smt_ok g2 t01 t11 in - let l = - match guard_eq with - | FStar_Pervasives_Native.None -> - [] - | FStar_Pervasives_Native.Some - guard -> - let guard1 = - FStar_TypeChecker_Env.conj_guard - guard_uvs guard in - let guard2 = - let uu___5 = - FStar_TypeChecker_Rel.solve_deferred_constraints - g2 guard1 in - FStar_TypeChecker_Rel.resolve_implicits - g2 uu___5 in - let b = - let uu___5 = - FStar_Class_Listlike.to_list - (FStar_Compiler_CList.listlike_clist - ()) - guard2.FStar_TypeChecker_Common.implicits in - FStar_Compiler_List.existsb - (fun uu___6 -> - match uu___6 with - | { - FStar_TypeChecker_Common.imp_reason - = uu___7; - FStar_TypeChecker_Common.imp_uvar - = - { - FStar_Syntax_Syntax.ctx_uvar_head - = - (uv, uu___8, - uu___9); - FStar_Syntax_Syntax.ctx_uvar_gamma - = uu___10; - FStar_Syntax_Syntax.ctx_uvar_binders - = uu___11; - FStar_Syntax_Syntax.ctx_uvar_reason - = uu___12; - FStar_Syntax_Syntax.ctx_uvar_range - = uu___13; - FStar_Syntax_Syntax.ctx_uvar_meta - = uu___14;_}; - FStar_TypeChecker_Common.imp_tm - = uu___15; - FStar_TypeChecker_Common.imp_range - = uu___16;_} - -> - let uu___17 = - let uu___18 = - FStar_Unionfind.puf_unique_id - uv in - FStar_Compiler_Util.pimap_try_find - tbl uu___18 in - uu___17 = - FStar_Pervasives_Native.None) - uu___5 in - if b - then [] - else - FStar_Compiler_Util.pimap_fold - tbl - (fun id -> - fun uu___6 -> - fun l1 -> - match uu___6 with - | (uvar, bv) -> - let uu___7 = - FStar_Syntax_Unionfind.find - uvar in - (match uu___7 - with - | FStar_Pervasives_Native.Some - t -> - let allow_uvars - = true in - let allow_names - = true in - let t2 = - FStar_Syntax_Compress.deep_compress - allow_uvars - allow_names - t in - let uu___8 - = - let uu___9 - = - FStar_Syntax_Free.uvars_full - t2 in - FStar_Class_Setlike.is_empty - () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) - (Obj.magic - uu___9) in - if uu___8 - then - (bv, t2) - :: l1 - else l1 - | FStar_Pervasives_Native.None - -> l1)) - [] in - (dbg_refl g2 - (fun uu___6 -> - let uu___7 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - (FStar_Class_Show.show_tuple2 - FStar_Syntax_Print.showable_bv - FStar_Syntax_Print.showable_term)) - l in - FStar_Compiler_Util.format1 - "} refl_try_unify, substitution is: %s\n" - uu___7); - (l, []))))))) - else - Obj.magic - (Obj.repr - (let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_TypeChecker_Env.get_range g in - unexpected_uvars_issue uu___5 in - [uu___4] in - (FStar_Pervasives_Native.None, uu___3) in - FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic uu___2)))) uu___3 uu___2 uu___1 uu___ -let (refl_maybe_relate_after_unfolding : - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> - (FStar_TypeChecker_Core.side FStar_Pervasives_Native.option * issues) - FStar_Tactics_Monad.tac) - = - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun g -> - fun t0 -> - fun t1 -> - let uu___ = - ((no_uvars_in_g g) && (no_uvars_in_term t0)) && - (no_uvars_in_term t1) in - if uu___ - then - Obj.magic - (Obj.repr - (refl_typing_builtin_wrapper - "refl_maybe_relate_after_unfolding" - (fun uu___1 -> - let g1 = - FStar_TypeChecker_Env.set_range g - t0.FStar_Syntax_Syntax.pos in - dbg_refl g1 - (fun uu___3 -> - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t0 in - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.format2 - "refl_maybe_relate_after_unfolding: %s and %s {\n" - uu___4 uu___5); - (let s = - FStar_TypeChecker_Core.maybe_relate_after_unfolding - g1 t0 t1 in - dbg_refl g1 - (fun uu___4 -> - let uu___5 = - FStar_Class_Show.show - FStar_TypeChecker_Core.showable_side s in - FStar_Compiler_Util.format1 - "} returning side: %s\n" uu___5); - (s, []))))) - else - Obj.magic - (Obj.repr - (let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_TypeChecker_Env.get_range g in - unexpected_uvars_issue uu___5 in - [uu___4] in - (FStar_Pervasives_Native.None, uu___3) in - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac - () (Obj.magic uu___2)))) uu___2 uu___1 uu___ -let (refl_maybe_unfold_head : - env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term FStar_Pervasives_Native.option * issues) - FStar_Tactics_Monad.tac) - = - fun uu___1 -> - fun uu___ -> - (fun g -> - fun e -> - let uu___ = (no_uvars_in_g g) && (no_uvars_in_term e) in - if uu___ - then - Obj.magic - (Obj.repr - (refl_typing_builtin_wrapper "refl_maybe_unfold_head" - (fun uu___1 -> - let g1 = - FStar_TypeChecker_Env.set_range g - e.FStar_Syntax_Syntax.pos in - dbg_refl g1 - (fun uu___3 -> - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term e in - FStar_Compiler_Util.format1 - "refl_maybe_unfold_head: %s {\n" uu___4); - (let eopt = - FStar_TypeChecker_Normalize.maybe_unfold_head g1 e in - dbg_refl g1 - (fun uu___4 -> - let uu___5 = - match eopt with - | FStar_Pervasives_Native.None -> "none" - | FStar_Pervasives_Native.Some e1 -> - FStar_Class_Show.show - FStar_Syntax_Print.showable_term e1 in - FStar_Compiler_Util.format1 "} eopt = %s\n" - uu___5); - if eopt = FStar_Pervasives_Native.None - then - (let uu___4 = - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term e in - FStar_Compiler_Util.format1 - "Could not unfold head: %s\n" uu___5 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) e - FStar_Errors_Codes.Fatal_UnexpectedTerm () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4)) - else - (let uu___5 = FStar_Compiler_Util.must eopt in - (uu___5, [])))))) - else - Obj.magic - (Obj.repr - (let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_TypeChecker_Env.get_range g in - unexpected_uvars_issue uu___5 in - [uu___4] in - (FStar_Pervasives_Native.None, uu___3) in - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.magic uu___2)))) uu___1 uu___ -let (push_open_namespace : - env -> Prims.string Prims.list -> env FStar_Tactics_Monad.tac) = - fun uu___1 -> - fun uu___ -> - (fun e -> - fun ns -> - let lid = - FStar_Ident.lid_of_path ns FStar_Compiler_Range_Type.dummyRange in - let uu___ = - let uu___1 = - FStar_Syntax_DsEnv.push_namespace - e.FStar_TypeChecker_Env.dsenv lid - FStar_Syntax_Syntax.Unrestricted in - { - FStar_TypeChecker_Env.solver = - (e.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = (e.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (e.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = (e.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (e.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (e.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (e.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (e.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (e.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (e.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (e.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (e.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (e.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (e.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (e.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (e.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (e.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (e.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = (e.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (e.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (e.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (e.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (e.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (e.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (e.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (e.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (e.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (e.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (e.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (e.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (e.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (e.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (e.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (e.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (e.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (e.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (e.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (e.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (e.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (e.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (e.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (e.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (e.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = uu___1; - FStar_TypeChecker_Env.nbe = (e.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (e.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (e.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (e.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (e.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (e.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (e.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (e.FStar_TypeChecker_Env.missing_decl) - } in - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.magic uu___))) uu___1 uu___ -let (push_module_abbrev : - env -> - Prims.string -> Prims.string Prims.list -> env FStar_Tactics_Monad.tac) - = - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun e -> - fun n -> - fun m -> - let mlid = - FStar_Ident.lid_of_path m - FStar_Compiler_Range_Type.dummyRange in - let ident = FStar_Ident.id_of_text n in - let uu___ = - let uu___1 = - FStar_Syntax_DsEnv.push_module_abbrev - e.FStar_TypeChecker_Env.dsenv ident mlid in - { - FStar_TypeChecker_Env.solver = - (e.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (e.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (e.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (e.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (e.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (e.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (e.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (e.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (e.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (e.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (e.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (e.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (e.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (e.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (e.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (e.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (e.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (e.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (e.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (e.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (e.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (e.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (e.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (e.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (e.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (e.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (e.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (e.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (e.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (e.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (e.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (e.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (e.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (e.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (e.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (e.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (e.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (e.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (e.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (e.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (e.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (e.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (e.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = uu___1; - FStar_TypeChecker_Env.nbe = (e.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (e.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (e.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (e.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (e.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (e.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (e.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (e.FStar_TypeChecker_Env.missing_decl) - } in - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.magic uu___))) uu___2 uu___1 uu___ -let (resolve_name : - env -> - Prims.string Prims.list -> - (FStar_Syntax_Syntax.bv, FStar_Syntax_Syntax.fv) - FStar_Pervasives.either FStar_Pervasives_Native.option - FStar_Tactics_Monad.tac) - = - fun uu___1 -> - fun uu___ -> - (fun e -> - fun n -> - let l = - FStar_Ident.lid_of_path n FStar_Compiler_Range_Type.dummyRange in - let uu___ = - FStar_Syntax_DsEnv.resolve_name e.FStar_TypeChecker_Env.dsenv l in - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.magic uu___))) uu___1 uu___ -let (log_issues : - FStar_Errors.issue Prims.list -> unit FStar_Tactics_Monad.tac) = - fun is -> - FStar_Class_Monad.op_let_Bang FStar_Tactics_Monad.monad_tac () () - (Obj.magic FStar_Tactics_Monad.get) - (fun uu___ -> - (fun ps -> - let ps = Obj.magic ps in - let is1 = - if ps.FStar_Tactics_Types.dump_on_failure - then - FStar_Compiler_List.map - (fun i -> - let uu___ = - let uu___1 = - FStar_Errors_Msg.text "Tactic logged issue:" in - uu___1 :: (i.FStar_Errors.issue_msg) in - { - FStar_Errors.issue_msg = uu___; - FStar_Errors.issue_level = - (i.FStar_Errors.issue_level); - FStar_Errors.issue_range = - (i.FStar_Errors.issue_range); - FStar_Errors.issue_number = - (i.FStar_Errors.issue_number); - FStar_Errors.issue_ctx = (i.FStar_Errors.issue_ctx) - }) is - else is in - FStar_Errors.add_issues is1; - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.repr ()))) uu___) -let (tac_env : FStar_TypeChecker_Env.env -> FStar_TypeChecker_Env.env) = - fun env1 -> - let uu___ = FStar_TypeChecker_Env.clear_expected_typ env1 in - match uu___ with - | (env2, uu___1) -> - let env3 = - { - FStar_TypeChecker_Env.solver = - (env2.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = (env2.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env2.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = (env2.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env2.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env2.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env2.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env2.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env2.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env2.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = false; - FStar_TypeChecker_Env.effects = - (env2.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env2.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env2.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env2.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env2.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env2.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env2.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = (env2.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env2.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env2.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env2.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env2.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env2.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env2.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env2.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env2.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env2.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env2.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env2.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env2.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env2.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env2.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env2.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env2.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env2.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env2.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env2.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env2.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env2.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env2.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env2.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env2.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = (env2.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (env2.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env2.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env2.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env2.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env2.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env2.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env2.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env2.FStar_TypeChecker_Env.missing_decl) - } in - let env4 = - { - FStar_TypeChecker_Env.solver = - (env3.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = (env3.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env3.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = (env3.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env3.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env3.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env3.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env3.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env3.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env3.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env3.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env3.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env3.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env3.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env3.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env3.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env3.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env3.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = (env3.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env3.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env3.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = true; - FStar_TypeChecker_Env.flychecking = - (env3.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env3.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env3.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env3.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env3.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env3.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env3.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env3.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env3.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env3.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env3.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env3.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env3.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env3.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env3.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env3.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env3.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env3.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env3.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env3.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env3.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = (env3.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (env3.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env3.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env3.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env3.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env3.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env3.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env3.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env3.FStar_TypeChecker_Env.missing_decl) - } in - let env5 = - { - FStar_TypeChecker_Env.solver = - (env4.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = (env4.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env4.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = (env4.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env4.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env4.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env4.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env4.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env4.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env4.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env4.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env4.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env4.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env4.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env4.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env4.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env4.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env4.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = (env4.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env4.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env4.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env4.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env4.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env4.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env4.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env4.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env4.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env4.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env4.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env4.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env4.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env4.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env4.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env4.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env4.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env4.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env4.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env4.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env4.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env4.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env4.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env4.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env4.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = (env4.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (env4.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env4.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env4.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = false; - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env4.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env4.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env4.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env4.FStar_TypeChecker_Env.missing_decl) - } in - env5 -let (proofstate_of_goals : - FStar_Compiler_Range_Type.range -> - env -> - FStar_Tactics_Types.goal Prims.list -> - FStar_TypeChecker_Common.implicit Prims.list -> - FStar_Tactics_Types.proofstate) - = - fun rng -> - fun env1 -> - fun goals -> - fun imps -> - let env2 = tac_env env1 in - let ps = - let uu___ = FStar_Compiler_Effect.op_Bang dbg_TacVerbose in - let uu___1 = FStar_Compiler_Util.psmap_empty () in - { - FStar_Tactics_Types.main_context = env2; - FStar_Tactics_Types.all_implicits = imps; - FStar_Tactics_Types.goals = goals; - FStar_Tactics_Types.smt_goals = []; - FStar_Tactics_Types.depth = Prims.int_zero; - FStar_Tactics_Types.__dump = - FStar_Tactics_Printing.do_dump_proofstate; - FStar_Tactics_Types.psc = - FStar_TypeChecker_Primops_Base.null_psc; - FStar_Tactics_Types.entry_range = rng; - FStar_Tactics_Types.guard_policy = FStar_Tactics_Types.SMT; - FStar_Tactics_Types.freshness = Prims.int_zero; - FStar_Tactics_Types.tac_verb_dbg = uu___; - FStar_Tactics_Types.local_state = uu___1; - FStar_Tactics_Types.urgency = Prims.int_one; - FStar_Tactics_Types.dump_on_failure = true - } in - ps -let (proofstate_of_goal_ty : - FStar_Compiler_Range_Type.range -> - env -> - FStar_Syntax_Syntax.typ -> - (FStar_Tactics_Types.proofstate * FStar_Syntax_Syntax.term)) - = - fun rng -> - fun env1 -> - fun typ -> - let env2 = - { - FStar_TypeChecker_Env.solver = - (env1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = rng; - FStar_TypeChecker_Env.curmodule = - (env1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = (env1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = (env1.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = (env1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (env1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env1.FStar_TypeChecker_Env.missing_decl) - } in - let env3 = tac_env env2 in - let uu___ = FStar_Tactics_Types.goal_of_goal_ty env3 typ in - match uu___ with - | (g, g_u) -> - let ps = - let uu___1 = - FStar_Class_Listlike.to_list - (FStar_Compiler_CList.listlike_clist ()) - g_u.FStar_TypeChecker_Common.implicits in - proofstate_of_goals rng env3 [g] uu___1 in - let uu___1 = FStar_Tactics_Types.goal_witness g in (ps, uu___1) -let (proofstate_of_all_implicits : - FStar_Compiler_Range_Type.range -> - env -> - implicits -> - (FStar_Tactics_Types.proofstate * FStar_Syntax_Syntax.term)) - = - fun rng -> - fun env1 -> - fun imps -> - let env2 = tac_env env1 in - let goals = - FStar_Compiler_List.map (FStar_Tactics_Types.goal_of_implicit env2) - imps in - let w = - let uu___ = FStar_Compiler_List.hd goals in - FStar_Tactics_Types.goal_witness uu___ in - let ps = - let uu___ = FStar_Compiler_Effect.op_Bang dbg_TacVerbose in - let uu___1 = FStar_Compiler_Util.psmap_empty () in - { - FStar_Tactics_Types.main_context = env2; - FStar_Tactics_Types.all_implicits = imps; - FStar_Tactics_Types.goals = goals; - FStar_Tactics_Types.smt_goals = []; - FStar_Tactics_Types.depth = Prims.int_zero; - FStar_Tactics_Types.__dump = - FStar_Tactics_Printing.do_dump_proofstate; - FStar_Tactics_Types.psc = FStar_TypeChecker_Primops_Base.null_psc; - FStar_Tactics_Types.entry_range = rng; - FStar_Tactics_Types.guard_policy = FStar_Tactics_Types.SMT; - FStar_Tactics_Types.freshness = Prims.int_zero; - FStar_Tactics_Types.tac_verb_dbg = uu___; - FStar_Tactics_Types.local_state = uu___1; - FStar_Tactics_Types.urgency = Prims.int_one; - FStar_Tactics_Types.dump_on_failure = true - } in - (ps, w) -let (getprop : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = - fun e -> - fun t -> - let tn = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Weak; - FStar_TypeChecker_Env.HNF; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant] e t in - FStar_Syntax_Util.un_squash tn -let run_unembedded_tactic_on_ps_and_solve_remaining : - 'a 'b . - FStar_Compiler_Range_Type.range -> - FStar_Compiler_Range_Type.range -> - Prims.bool -> - 'a -> - ('a -> 'b FStar_Tactics_Monad.tac) -> - FStar_Tactics_Types.proofstate -> 'b - = - fun t_range -> - fun g_range -> - fun background -> - fun t -> - fun f -> - fun ps -> - let uu___ = - FStar_Tactics_Interpreter.run_unembedded_tactic_on_ps t_range - g_range background t f ps in - match uu___ with - | (remaining_goals, r) -> - (FStar_Compiler_List.iter - (fun g -> - let uu___2 = - let uu___3 = FStar_Tactics_Types.goal_env g in - let uu___4 = FStar_Tactics_Types.goal_type g in - getprop uu___3 uu___4 in - match uu___2 with - | FStar_Pervasives_Native.Some vc -> - let guard = - FStar_TypeChecker_Env.guard_of_guard_formula - (FStar_TypeChecker_Common.NonTrivial vc) in - let uu___3 = FStar_Tactics_Types.goal_env g in - FStar_TypeChecker_Rel.force_trivial_guard uu___3 - guard - | FStar_Pervasives_Native.None -> - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range g_range - FStar_Errors_Codes.Fatal_OpenGoalsInSynthesis - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "tactic left a computationally-relevant goal unsolved")) - remaining_goals; - r) -let (call_subtac : - env -> - unit FStar_Tactics_Monad.tac -> - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.typ -> - (FStar_Syntax_Syntax.term FStar_Pervasives_Native.option * issues) - FStar_Tactics_Monad.tac) - = - fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun g -> - fun f -> - fun _u -> - fun goal_ty -> - let uu___ = - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac - () (Obj.repr ()) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - let rng = FStar_TypeChecker_Env.get_range g in - let uu___2 = - proofstate_of_goal_ty rng g goal_ty in - match uu___2 with - | (ps, w) -> - let ps1 = - { - FStar_Tactics_Types.main_context = - (ps.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits = - (ps.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = - (ps.FStar_Tactics_Types.goals); - FStar_Tactics_Types.smt_goals = - (ps.FStar_Tactics_Types.smt_goals); - FStar_Tactics_Types.depth = - (ps.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = - (ps.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = - (ps.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (ps.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = - (ps.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness = - (ps.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg = - (ps.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = - (ps.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency = - (ps.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure = - false - } in - let uu___3 = - FStar_Errors.catch_errors_and_ignore_rest - (fun uu___4 -> - run_unembedded_tactic_on_ps_and_solve_remaining - rng rng false () (fun uu___5 -> f) - ps1) in - (match uu___3 with - | ([], FStar_Pervasives_Native.Some ()) -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic - ((FStar_Pervasives_Native.Some - w), []))) - | (issues1, uu___4) -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic - (FStar_Pervasives_Native.None, - issues1))))) uu___1))) - uu___3 uu___2 uu___1 uu___ -let run_tactic_on_ps_and_solve_remaining : - 'a 'b . - FStar_Compiler_Range_Type.range -> - FStar_Compiler_Range_Type.range -> - Prims.bool -> - 'a -> - FStar_Syntax_Syntax.term -> - FStar_Tactics_Types.proofstate -> unit - = - fun t_range -> - fun g_range -> - fun background -> - fun t -> - fun f_tm -> - fun ps -> - let uu___ = - FStar_Tactics_Interpreter.run_tactic_on_ps t_range g_range - background FStar_Syntax_Embeddings.e_unit () - FStar_Syntax_Embeddings.e_unit f_tm false ps in - match uu___ with - | (remaining_goals, r) -> - FStar_Compiler_List.iter - (fun g -> - let uu___2 = - let uu___3 = FStar_Tactics_Types.goal_env g in - let uu___4 = FStar_Tactics_Types.goal_type g in - getprop uu___3 uu___4 in - match uu___2 with - | FStar_Pervasives_Native.Some vc -> - let guard = - FStar_TypeChecker_Env.guard_of_guard_formula - (FStar_TypeChecker_Common.NonTrivial vc) in - let uu___3 = FStar_Tactics_Types.goal_env g in - FStar_TypeChecker_Rel.force_trivial_guard uu___3 - guard - | FStar_Pervasives_Native.None -> - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range g_range - FStar_Errors_Codes.Fatal_OpenGoalsInSynthesis () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "tactic left a computationally-relevant goal unsolved")) - remaining_goals -let (call_subtac_tm : - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.typ -> - (FStar_Syntax_Syntax.term FStar_Pervasives_Native.option * issues) - FStar_Tactics_Monad.tac) - = - fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun g -> - fun f_tm -> - fun _u -> - fun goal_ty -> - let uu___ = - FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac - () (Obj.repr ()) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Tactics_Monad.monad_tac () () uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - let rng = FStar_TypeChecker_Env.get_range g in - let uu___2 = - proofstate_of_goal_ty rng g goal_ty in - match uu___2 with - | (ps, w) -> - let ps1 = - { - FStar_Tactics_Types.main_context = - (ps.FStar_Tactics_Types.main_context); - FStar_Tactics_Types.all_implicits = - (ps.FStar_Tactics_Types.all_implicits); - FStar_Tactics_Types.goals = - (ps.FStar_Tactics_Types.goals); - FStar_Tactics_Types.smt_goals = - (ps.FStar_Tactics_Types.smt_goals); - FStar_Tactics_Types.depth = - (ps.FStar_Tactics_Types.depth); - FStar_Tactics_Types.__dump = - (ps.FStar_Tactics_Types.__dump); - FStar_Tactics_Types.psc = - (ps.FStar_Tactics_Types.psc); - FStar_Tactics_Types.entry_range = - (ps.FStar_Tactics_Types.entry_range); - FStar_Tactics_Types.guard_policy = - (ps.FStar_Tactics_Types.guard_policy); - FStar_Tactics_Types.freshness = - (ps.FStar_Tactics_Types.freshness); - FStar_Tactics_Types.tac_verb_dbg = - (ps.FStar_Tactics_Types.tac_verb_dbg); - FStar_Tactics_Types.local_state = - (ps.FStar_Tactics_Types.local_state); - FStar_Tactics_Types.urgency = - (ps.FStar_Tactics_Types.urgency); - FStar_Tactics_Types.dump_on_failure = - false - } in - let uu___3 = - FStar_Errors.catch_errors_and_ignore_rest - (fun uu___4 -> - run_tactic_on_ps_and_solve_remaining - rng rng false () f_tm ps1) in - (match uu___3 with - | ([], FStar_Pervasives_Native.Some ()) -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic - ((FStar_Pervasives_Native.Some - w), []))) - | (issues1, uu___4) -> - Obj.magic - (FStar_Class_Monad.return - FStar_Tactics_Monad.monad_tac () - (Obj.magic - (FStar_Pervasives_Native.None, - issues1))))) uu___1))) - uu___3 uu___2 uu___1 uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_V2_Derived.ml b/ocaml/fstar-lib/generated/FStar_Tactics_V2_Derived.ml index 95416a32bd4..376991dbc5e 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_V2_Derived.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_V2_Derived.ml @@ -4,15 +4,15 @@ let op_At : unit -> 'uuuuu Prims.list -> 'uuuuu Prims.list -> 'uuuuu Prims.list = fun uu___ -> FStar_List_Tot_Base.op_At let (term_eq : - FStar_Reflection_Types.term -> FStar_Reflection_Types.term -> Prims.bool) = - FStar_Reflection_TermEq_Simple.term_eq + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term -> Prims.bool) + = FStar_Reflection_TermEq_Simple.term_eq let (name_of_bv : FStar_Tactics_NamedView.bv -> (Prims.string, unit) FStar_Tactics_Effect.tac_repr) = fun bv -> FStar_Tactics_Unseal.unseal - (FStar_Tactics_NamedView.inspect_bv bv).FStar_Reflection_V2_Data.ppname1 + (FStar_Tactics_NamedView.inspect_bv bv).FStarC_Reflection_V2_Data.ppname1 let (bv_to_string : FStar_Tactics_NamedView.bv -> (Prims.string, unit) FStar_Tactics_Effect.tac_repr) @@ -45,7 +45,7 @@ let (binder_to_string : let uu___4 = let uu___5 = let uu___6 = - FStar_Tactics_V2_Builtins.term_to_string + FStarC_Tactics_V2_Builtins.term_to_string b.FStar_Tactics_NamedView.sort in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -129,24 +129,25 @@ let (binder_to_string : let (binding_to_string : FStar_Tactics_NamedView.binding -> (Prims.string, unit) FStar_Tactics_Effect.tac_repr) - = fun b -> FStar_Tactics_Unseal.unseal b.FStar_Reflection_V2_Data.ppname3 + = fun b -> FStar_Tactics_Unseal.unseal b.FStarC_Reflection_V2_Data.ppname3 let (type_of_var : FStar_Tactics_NamedView.namedv -> - (FStar_Reflection_Types.typ, unit) FStar_Tactics_Effect.tac_repr) + (FStarC_Reflection_Types.typ, unit) FStar_Tactics_Effect.tac_repr) = fun x -> FStar_Tactics_Unseal.unseal - (FStar_Tactics_NamedView.inspect_namedv x).FStar_Reflection_V2_Data.sort + (FStar_Tactics_NamedView.inspect_namedv x).FStarC_Reflection_V2_Data.sort let (type_of_binding : - FStar_Tactics_NamedView.binding -> FStar_Reflection_Types.typ) = - fun x -> x.FStar_Reflection_V2_Data.sort3 + FStar_Tactics_NamedView.binding -> FStarC_Reflection_Types.typ) = + fun x -> x.FStarC_Reflection_V2_Data.sort3 exception Goal_not_trivial let (uu___is_Goal_not_trivial : Prims.exn -> Prims.bool) = fun projectee -> match projectee with | Goal_not_trivial -> true | uu___ -> false let (goals : unit -> - (FStar_Tactics_Types.goal Prims.list, unit) FStar_Tactics_Effect.tac_repr) + (FStarC_Tactics_Types.goal Prims.list, unit) + FStar_Tactics_Effect.tac_repr) = fun uu___ -> let uu___1 = Obj.magic (FStar_Tactics_Effect.get ()) in @@ -163,10 +164,11 @@ let (goals : (Prims.of_int (50))))) (Obj.magic uu___1) (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___3 -> FStar_Tactics_Types.goals_of uu___2)) + (fun uu___3 -> FStarC_Tactics_Types.goals_of uu___2)) let (smt_goals : unit -> - (FStar_Tactics_Types.goal Prims.list, unit) FStar_Tactics_Effect.tac_repr) + (FStarC_Tactics_Types.goal Prims.list, unit) + FStar_Tactics_Effect.tac_repr) = fun uu___ -> let uu___1 = Obj.magic (FStar_Tactics_Effect.get ()) in @@ -183,39 +185,39 @@ let (smt_goals : (Prims.of_int (58))))) (Obj.magic uu___1) (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___3 -> FStar_Tactics_Types.smt_goals_of uu___2)) + (fun uu___3 -> FStarC_Tactics_Types.smt_goals_of uu___2)) let fail_doc_at : 'a . - FStar_Errors_Msg.error_message -> + FStarC_Errors_Msg.error_message -> FStar_Range.range FStar_Pervasives_Native.option -> ('a, Obj.t) FStar_Tactics_Effect.tac_repr = fun m -> fun r -> - FStar_Tactics_Effect.raise (FStar_Tactics_Common.TacticFailure (m, r)) + FStar_Tactics_Effect.raise (FStarC_Tactics_Common.TacticFailure (m, r)) let fail_doc : 'a . - FStar_Errors_Msg.error_message -> + FStarC_Errors_Msg.error_message -> ('a, Obj.t) FStar_Tactics_Effect.tac_repr = fun m -> FStar_Tactics_Effect.raise - (FStar_Tactics_Common.TacticFailure (m, FStar_Pervasives_Native.None)) + (FStarC_Tactics_Common.TacticFailure (m, FStar_Pervasives_Native.None)) let fail_at : 'a . Prims.string -> FStar_Range.range FStar_Pervasives_Native.option -> ('a, Obj.t) FStar_Tactics_Effect.tac_repr - = fun m -> fun r -> fail_doc_at (FStar_Errors_Msg.mkmsg m) r + = fun m -> fun r -> fail_doc_at (FStarC_Errors_Msg.mkmsg m) r let fail : 'a . Prims.string -> ('a, Obj.t) FStar_Tactics_Effect.tac_repr = fun m -> fail_at m FStar_Pervasives_Native.None let fail_silently_doc : 'a . - FStar_Errors_Msg.error_message -> + FStarC_Errors_Msg.error_message -> ('a, unit) FStar_Tactics_Effect.tac_repr = fun m -> - let uu___ = FStar_Tactics_V2_Builtins.set_urgency Prims.int_zero in + let uu___ = FStarC_Tactics_V2_Builtins.set_urgency Prims.int_zero in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -229,13 +231,13 @@ let fail_silently_doc : (Prims.of_int (38))))) (Obj.magic uu___) (fun uu___1 -> FStar_Tactics_Effect.raise - (FStar_Tactics_Common.TacticFailure + (FStarC_Tactics_Common.TacticFailure (m, FStar_Pervasives_Native.None))) let fail_silently : 'a . Prims.string -> ('a, unit) FStar_Tactics_Effect.tac_repr = - fun m -> fail_silently_doc (FStar_Errors_Msg.mkmsg m) + fun m -> fail_silently_doc (FStarC_Errors_Msg.mkmsg m) let (_cur_goal : - unit -> (FStar_Tactics_Types.goal, unit) FStar_Tactics_Effect.tac_repr) = + unit -> (FStarC_Tactics_Types.goal, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> let uu___1 = goals () in FStar_Tactics_Effect.tac_bind @@ -254,7 +256,8 @@ let (_cur_goal : | [] -> fail "no more goals" | g::uu___3 -> FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> g)) let (cur_env : - unit -> (FStar_Reflection_Types.env, unit) FStar_Tactics_Effect.tac_repr) = + unit -> (FStarC_Reflection_Types.env, unit) FStar_Tactics_Effect.tac_repr) + = fun uu___ -> let uu___1 = _cur_goal () in FStar_Tactics_Effect.tac_bind @@ -270,9 +273,10 @@ let (cur_env : (Prims.of_int (50))))) (Obj.magic uu___1) (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___3 -> FStar_Tactics_Types.goal_env uu___2)) + (fun uu___3 -> FStarC_Tactics_Types.goal_env uu___2)) let (cur_goal : - unit -> (FStar_Reflection_Types.typ, unit) FStar_Tactics_Effect.tac_repr) = + unit -> (FStarC_Reflection_Types.typ, unit) FStar_Tactics_Effect.tac_repr) + = fun uu___ -> let uu___1 = _cur_goal () in FStar_Tactics_Effect.tac_bind @@ -288,7 +292,7 @@ let (cur_goal : (Prims.of_int (52))))) (Obj.magic uu___1) (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___3 -> FStar_Tactics_Types.goal_type uu___2)) + (fun uu___3 -> FStarC_Tactics_Types.goal_type uu___2)) let (cur_witness : unit -> (FStar_Tactics_NamedView.term, unit) FStar_Tactics_Effect.tac_repr) = @@ -307,9 +311,9 @@ let (cur_witness : (Prims.of_int (59))))) (Obj.magic uu___1) (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___3 -> FStar_Tactics_Types.goal_witness uu___2)) + (fun uu___3 -> FStarC_Tactics_Types.goal_witness uu___2)) let (cur_goal_safe : - unit -> (FStar_Tactics_Types.goal, unit) FStar_Tactics_Effect.tac_repr) = + unit -> (FStarC_Tactics_Types.goal, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> let uu___1 = let uu___2 = Obj.magic (FStar_Tactics_Effect.get ()) in @@ -326,7 +330,7 @@ let (cur_goal_safe : (Prims.of_int (26))))) (Obj.magic uu___2) (fun uu___3 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___4 -> FStar_Tactics_Types.goals_of uu___3)) in + (fun uu___4 -> FStarC_Tactics_Types.goals_of uu___3)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -361,16 +365,16 @@ let (cur_vars : (Prims.of_int (28))))) (Obj.magic uu___1) (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___3 -> FStar_Reflection_V2_Builtins.vars_of_env uu___2)) + (fun uu___3 -> FStarC_Reflection_V2_Builtins.vars_of_env uu___2)) let with_policy : 'a . - FStar_Tactics_Types.guard_policy -> + FStarC_Tactics_Types.guard_policy -> (unit -> ('a, unit) FStar_Tactics_Effect.tac_repr) -> ('a, unit) FStar_Tactics_Effect.tac_repr = fun pol -> fun f -> - let uu___ = FStar_Tactics_V2_Builtins.get_guard_policy () in + let uu___ = FStarC_Tactics_V2_Builtins.get_guard_policy () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -384,7 +388,7 @@ let with_policy : (Prims.of_int (5))))) (Obj.magic uu___) (fun uu___1 -> (fun old_pol -> - let uu___1 = FStar_Tactics_V2_Builtins.set_guard_policy pol in + let uu___1 = FStarC_Tactics_V2_Builtins.set_guard_policy pol in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -423,7 +427,7 @@ let with_policy : (fun uu___4 -> (fun r -> let uu___4 = - FStar_Tactics_V2_Builtins.set_guard_policy + FStarC_Tactics_V2_Builtins.set_guard_policy old_pol in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -452,18 +456,18 @@ let (exact : FStar_Tactics_NamedView.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun t -> - with_policy FStar_Tactics_Types.SMT - (fun uu___ -> FStar_Tactics_V2_Builtins.t_exact true false t) + with_policy FStarC_Tactics_Types.SMT + (fun uu___ -> FStarC_Tactics_V2_Builtins.t_exact true false t) let (exact_with_ref : FStar_Tactics_NamedView.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun t -> - with_policy FStar_Tactics_Types.SMT - (fun uu___ -> FStar_Tactics_V2_Builtins.t_exact true true t) + with_policy FStarC_Tactics_Types.SMT + (fun uu___ -> FStarC_Tactics_V2_Builtins.t_exact true true t) let (trivial : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> let uu___1 = - FStar_Tactics_V2_Builtins.norm + FStarC_Tactics_V2_Builtins.norm [FStar_Pervasives.iota; FStar_Pervasives.zeta; FStar_Pervasives.reify_; @@ -524,9 +528,9 @@ let (trivial : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = Obj.magic (Obj.repr (exact - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const - FStar_Reflection_V2_Data.C_Unit)))) + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const + FStarC_Reflection_V2_Data.C_Unit)))) | uu___6 -> Obj.magic (Obj.repr @@ -552,7 +556,8 @@ let (dismiss : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = match uu___2 with | [] -> Obj.magic (Obj.repr (fail "dismiss: no more goals")) | uu___3::gs -> - Obj.magic (Obj.repr (FStar_Tactics_V2_Builtins.set_goals gs))) + Obj.magic + (Obj.repr (FStarC_Tactics_V2_Builtins.set_goals gs))) uu___2) let (flip : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> @@ -596,7 +601,7 @@ let (flip : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = | g1::g2::gs1 -> Obj.magic (Obj.repr - (FStar_Tactics_V2_Builtins.set_goals (g2 :: + (FStarC_Tactics_V2_Builtins.set_goals (g2 :: g1 :: gs1)))) uu___3))) uu___2) let (qed : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> @@ -618,7 +623,7 @@ let (qed : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = | uu___3 -> fail "qed: not done!") let (debug : Prims.string -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun m -> - let uu___ = FStar_Tactics_V2_Builtins.debugging () in + let uu___ = FStarC_Tactics_V2_Builtins.debugging () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -633,7 +638,7 @@ let (debug : Prims.string -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___1 -> (fun uu___1 -> if uu___1 - then Obj.magic (Obj.repr (FStar_Tactics_V2_Builtins.print m)) + then Obj.magic (Obj.repr (FStarC_Tactics_V2_Builtins.print m)) else Obj.magic (Obj.repr @@ -693,7 +698,7 @@ let (smt : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = | (g::gs, gs') -> Obj.magic (Obj.repr - (let uu___3 = FStar_Tactics_V2_Builtins.set_goals gs in + (let uu___3 = FStarC_Tactics_V2_Builtins.set_goals gs in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -711,7 +716,7 @@ let (smt : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___4 -> (fun uu___4 -> Obj.magic - (FStar_Tactics_V2_Builtins.set_smt_goals (g + (FStarC_Tactics_V2_Builtins.set_smt_goals (g :: gs'))) uu___4)))) uu___2) let (idtac : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> @@ -738,41 +743,42 @@ let (later : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = | g::gs -> Obj.magic (Obj.repr - (FStar_Tactics_V2_Builtins.set_goals ((op_At ()) gs [g]))) + (FStarC_Tactics_V2_Builtins.set_goals + ((op_At ()) gs [g]))) | uu___3 -> Obj.magic (Obj.repr (fail "later: no goals"))) uu___2) let (apply : FStar_Tactics_NamedView.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) - = fun t -> FStar_Tactics_V2_Builtins.t_apply true false false t + = fun t -> FStarC_Tactics_V2_Builtins.t_apply true false false t let (apply_noinst : FStar_Tactics_NamedView.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) - = fun t -> FStar_Tactics_V2_Builtins.t_apply true true false t + = fun t -> FStarC_Tactics_V2_Builtins.t_apply true true false t let (apply_lemma : FStar_Tactics_NamedView.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) - = fun t -> FStar_Tactics_V2_Builtins.t_apply_lemma false false t + = fun t -> FStarC_Tactics_V2_Builtins.t_apply_lemma false false t let (trefl : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = - fun uu___ -> FStar_Tactics_V2_Builtins.t_trefl false + fun uu___ -> FStarC_Tactics_V2_Builtins.t_trefl false let (trefl_guard : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = - fun uu___ -> FStar_Tactics_V2_Builtins.t_trefl true + fun uu___ -> FStarC_Tactics_V2_Builtins.t_trefl true let (commute_applied_match : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = - fun uu___ -> FStar_Tactics_V2_Builtins.t_commute_applied_match () + fun uu___ -> FStarC_Tactics_V2_Builtins.t_commute_applied_match () let (apply_lemma_noinst : FStar_Tactics_NamedView.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) - = fun t -> FStar_Tactics_V2_Builtins.t_apply_lemma true false t + = fun t -> FStarC_Tactics_V2_Builtins.t_apply_lemma true false t let (apply_lemma_rw : FStar_Tactics_NamedView.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) - = fun t -> FStar_Tactics_V2_Builtins.t_apply_lemma false true t + = fun t -> FStarC_Tactics_V2_Builtins.t_apply_lemma false true t let (apply_raw : FStar_Tactics_NamedView.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) - = fun t -> FStar_Tactics_V2_Builtins.t_apply false false false t + = fun t -> FStarC_Tactics_V2_Builtins.t_apply false false false t let (exact_guard : FStar_Tactics_NamedView.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun t -> - with_policy FStar_Tactics_Types.Goal - (fun uu___ -> FStar_Tactics_V2_Builtins.t_exact true false t) + with_policy FStarC_Tactics_Types.Goal + (fun uu___ -> FStarC_Tactics_V2_Builtins.t_exact true false t) let (t_pointwise : - FStar_Tactics_Types.direction -> + FStarC_Tactics_Types.direction -> (unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) -> (unit, unit) FStar_Tactics_Effect.tac_repr) = @@ -788,8 +794,8 @@ let (t_pointwise : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> - (true, FStar_Tactics_Types.Continue)))) uu___2 - uu___1)) in + (true, FStarC_Tactics_Types.Continue)))) + uu___2 uu___1)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -823,7 +829,7 @@ let (t_pointwise : (fun uu___2 -> (fun rw -> Obj.magic - (FStar_Tactics_V2_Builtins.ctrl_rewrite d ctrl rw)) + (FStarC_Tactics_V2_Builtins.ctrl_rewrite d ctrl rw)) uu___2))) uu___1) let (topdown_rewrite : (FStar_Tactics_NamedView.term -> @@ -864,17 +870,17 @@ let (topdown_rewrite : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___6 -> - FStar_Tactics_Types.Continue)) + FStarC_Tactics_Types.Continue)) | uu___5 when uu___5 = Prims.int_one -> Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___6 -> - FStar_Tactics_Types.Skip)) + FStarC_Tactics_Types.Skip)) | uu___5 when uu___5 = (Prims.of_int (2)) -> Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___6 -> - FStar_Tactics_Types.Abort)) + FStarC_Tactics_Types.Abort)) | uu___5 -> Obj.magic (fail @@ -915,21 +921,21 @@ let (topdown_rewrite : (fun uu___1 -> (fun ctrl' -> Obj.magic - (FStar_Tactics_V2_Builtins.ctrl_rewrite - FStar_Tactics_Types.TopDown ctrl' rw)) uu___1) + (FStarC_Tactics_V2_Builtins.ctrl_rewrite + FStarC_Tactics_Types.TopDown ctrl' rw)) uu___1) let (pointwise : (unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) -> (unit, unit) FStar_Tactics_Effect.tac_repr) - = fun tau -> t_pointwise FStar_Tactics_Types.BottomUp tau + = fun tau -> t_pointwise FStarC_Tactics_Types.BottomUp tau let (pointwise' : (unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) -> (unit, unit) FStar_Tactics_Effect.tac_repr) - = fun tau -> t_pointwise FStar_Tactics_Types.TopDown tau + = fun tau -> t_pointwise FStarC_Tactics_Types.TopDown tau let (cur_module : - unit -> (FStar_Reflection_Types.name, unit) FStar_Tactics_Effect.tac_repr) + unit -> (FStarC_Reflection_Types.name, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> - let uu___1 = FStar_Tactics_V2_Builtins.top_env () in + let uu___1 = FStarC_Tactics_V2_Builtins.top_env () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -943,14 +949,14 @@ let (cur_module : (Prims.of_int (25))))) (Obj.magic uu___1) (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___3 -> FStar_Reflection_V2_Builtins.moduleof uu___2)) + (fun uu___3 -> FStarC_Reflection_V2_Builtins.moduleof uu___2)) let (open_modules : unit -> - (FStar_Reflection_Types.name Prims.list, unit) + (FStarC_Reflection_Types.name Prims.list, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> - let uu___1 = FStar_Tactics_V2_Builtins.top_env () in + let uu___1 = FStarC_Tactics_V2_Builtins.top_env () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -965,9 +971,9 @@ let (open_modules : (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> - FStar_Reflection_V2_Builtins.env_open_modules uu___2)) + FStarC_Reflection_V2_Builtins.env_open_modules uu___2)) let (fresh_uvar : - FStar_Reflection_Types.typ FStar_Pervasives_Native.option -> + FStarC_Reflection_Types.typ FStar_Pervasives_Native.option -> (FStar_Tactics_NamedView.term, unit) FStar_Tactics_Effect.tac_repr) = fun o -> @@ -984,7 +990,8 @@ let (fresh_uvar : (Prims.of_int (306)) (Prims.of_int (4)) (Prims.of_int (306)) (Prims.of_int (16))))) (Obj.magic uu___) (fun uu___1 -> - (fun e -> Obj.magic (FStar_Tactics_V2_Builtins.uvar_env e o)) uu___1) + (fun e -> Obj.magic (FStarC_Tactics_V2_Builtins.uvar_env e o)) + uu___1) let (unify : FStar_Tactics_NamedView.term -> FStar_Tactics_NamedView.term -> @@ -1005,7 +1012,7 @@ let (unify : (Prims.of_int (310)) (Prims.of_int (4)) (Prims.of_int (310)) (Prims.of_int (21))))) (Obj.magic uu___) (fun uu___1 -> - (fun e -> Obj.magic (FStar_Tactics_V2_Builtins.unify_env e t1 t2)) + (fun e -> Obj.magic (FStarC_Tactics_V2_Builtins.unify_env e t1 t2)) uu___1) let (unify_guard : FStar_Tactics_NamedView.term -> @@ -1028,7 +1035,7 @@ let (unify_guard : (Prims.of_int (27))))) (Obj.magic uu___) (fun uu___1 -> (fun e -> - Obj.magic (FStar_Tactics_V2_Builtins.unify_guard_env e t1 t2)) + Obj.magic (FStarC_Tactics_V2_Builtins.unify_guard_env e t1 t2)) uu___1) let (tmatch : FStar_Tactics_NamedView.term -> @@ -1050,7 +1057,7 @@ let (tmatch : (Prims.of_int (318)) (Prims.of_int (4)) (Prims.of_int (318)) (Prims.of_int (21))))) (Obj.magic uu___) (fun uu___1 -> - (fun e -> Obj.magic (FStar_Tactics_V2_Builtins.match_env e t1 t2)) + (fun e -> Obj.magic (FStarC_Tactics_V2_Builtins.match_env e t1 t2)) uu___1) let divide : 'a 'b . @@ -1171,7 +1178,7 @@ let divide : match uu___5 with | (gs1, gs2) -> let uu___6 = - FStar_Tactics_V2_Builtins.set_goals + FStarC_Tactics_V2_Builtins.set_goals gs1 in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1195,7 +1202,7 @@ let divide : (fun uu___7 -> (fun uu___7 -> let uu___8 = - FStar_Tactics_V2_Builtins.set_smt_goals + FStarC_Tactics_V2_Builtins.set_smt_goals [] in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1345,7 +1352,7 @@ let divide : sgsl) -> let uu___13 = - FStar_Tactics_V2_Builtins.set_goals + FStarC_Tactics_V2_Builtins.set_goals gs2 in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1375,7 +1382,7 @@ let divide : -> let uu___15 = - FStar_Tactics_V2_Builtins.set_smt_goals + FStarC_Tactics_V2_Builtins.set_smt_goals [] in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1526,7 +1533,7 @@ let divide : sgsr) -> let uu___20 = - FStar_Tactics_V2_Builtins.set_goals + FStarC_Tactics_V2_Builtins.set_goals ((op_At ()) gsl gsr) in @@ -1558,7 +1565,7 @@ let divide : -> let uu___22 = - FStar_Tactics_V2_Builtins.set_smt_goals + FStarC_Tactics_V2_Builtins.set_smt_goals ((op_At ()) sgs ((op_At @@ -1673,7 +1680,7 @@ let focus : (fun uu___3 -> (fun sgs -> let uu___3 = - FStar_Tactics_V2_Builtins.set_goals [g] in + FStarC_Tactics_V2_Builtins.set_goals [g] in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1696,7 +1703,7 @@ let focus : (fun uu___4 -> (fun uu___4 -> let uu___5 = - FStar_Tactics_V2_Builtins.set_smt_goals + FStarC_Tactics_V2_Builtins.set_smt_goals [] in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1801,7 +1808,7 @@ let focus : uu___10 -> Obj.magic - (FStar_Tactics_V2_Builtins.set_goals + (FStarC_Tactics_V2_Builtins.set_goals uu___10)) uu___10) in Obj.magic @@ -1895,7 +1902,7 @@ let focus : uu___12 -> Obj.magic - (FStar_Tactics_V2_Builtins.set_smt_goals + (FStarC_Tactics_V2_Builtins.set_smt_goals uu___12)) uu___12) in Obj.magic @@ -1930,7 +1937,7 @@ let focus : uu___6))) uu___4))) uu___3)))) uu___1) let (dump1 : Prims.string -> (unit, unit) FStar_Tactics_Effect.tac_repr) = - fun m -> focus (fun uu___ -> FStar_Tactics_V2_Builtins.dump m) + fun m -> focus (fun uu___ -> FStarC_Tactics_V2_Builtins.dump m) let rec mapAll : 'a . (unit -> ('a, unit) FStar_Tactics_Effect.tac_repr) -> @@ -2079,7 +2086,7 @@ let (iterAllSMT : (fun uu___1 -> match uu___1 with | (gs, sgs) -> - let uu___2 = FStar_Tactics_V2_Builtins.set_goals sgs in + let uu___2 = FStarC_Tactics_V2_Builtins.set_goals sgs in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -2098,7 +2105,7 @@ let (iterAllSMT : (fun uu___3 -> (fun uu___3 -> let uu___4 = - FStar_Tactics_V2_Builtins.set_smt_goals [] in + FStarC_Tactics_V2_Builtins.set_smt_goals [] in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -2219,7 +2226,7 @@ let (iterAllSMT : match uu___9 with | (gs', sgs') -> let uu___10 = - FStar_Tactics_V2_Builtins.set_goals + FStarC_Tactics_V2_Builtins.set_goals gs in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -2248,7 +2255,7 @@ let (iterAllSMT : uu___11 -> Obj.magic - (FStar_Tactics_V2_Builtins.set_smt_goals + (FStarC_Tactics_V2_Builtins.set_smt_goals ((op_At ()) gs' sgs'))) @@ -2279,7 +2286,7 @@ let (seq : (Obj.magic uu___1) (fun uu___2 -> (fun uu___2 -> Obj.magic (iterAll g)) uu___2)) let (exact_args : - FStar_Reflection_V2_Data.aqualv Prims.list -> + FStarC_Reflection_V2_Data.aqualv Prims.list -> FStar_Tactics_NamedView.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) = @@ -2403,7 +2410,7 @@ let (exact_args : then Obj.magic (Obj.repr - (FStar_Tactics_V2_Builtins.unshelve + (FStarC_Tactics_V2_Builtins.unshelve uv)) else Obj.magic @@ -2429,7 +2436,7 @@ let (exact_n : (fun uu___1 -> Obj.magic (FStar_Tactics_Effect.lift_div_tac - (fun uu___2 -> FStar_Reflection_V2_Data.Q_Explicit))) + (fun uu___2 -> FStarC_Reflection_V2_Data.Q_Explicit))) uu___1) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -2482,7 +2489,7 @@ let (fresh_namedv_named : (FStar_Tactics_NamedView.namedv, unit) FStar_Tactics_Effect.tac_repr) = fun s -> - let uu___ = FStar_Tactics_V2_Builtins.fresh () in + let uu___ = FStarC_Tactics_V2_Builtins.fresh () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2499,19 +2506,19 @@ let (fresh_namedv_named : (fun uu___1 -> FStar_Tactics_NamedView.pack_namedv { - FStar_Reflection_V2_Data.uniq = n; - FStar_Reflection_V2_Data.sort = + FStarC_Reflection_V2_Data.uniq = n; + FStarC_Reflection_V2_Data.sort = (FStar_Sealed.seal - (FStar_Reflection_V2_Builtins.pack_ln - FStar_Reflection_V2_Data.Tv_Unknown)); - FStar_Reflection_V2_Data.ppname = (FStar_Sealed.seal s) + (FStarC_Reflection_V2_Builtins.pack_ln + FStarC_Reflection_V2_Data.Tv_Unknown)); + FStarC_Reflection_V2_Data.ppname = (FStar_Sealed.seal s) })) let (fresh_namedv : unit -> (FStar_Tactics_NamedView.namedv, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> - let uu___1 = FStar_Tactics_V2_Builtins.fresh () in + let uu___1 = FStarC_Tactics_V2_Builtins.fresh () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2528,24 +2535,24 @@ let (fresh_namedv : (fun uu___2 -> FStar_Tactics_NamedView.pack_namedv { - FStar_Reflection_V2_Data.uniq = n; - FStar_Reflection_V2_Data.sort = + FStarC_Reflection_V2_Data.uniq = n; + FStarC_Reflection_V2_Data.sort = (FStar_Sealed.seal - (FStar_Reflection_V2_Builtins.pack_ln - FStar_Reflection_V2_Data.Tv_Unknown)); - FStar_Reflection_V2_Data.ppname = + (FStarC_Reflection_V2_Builtins.pack_ln + FStarC_Reflection_V2_Data.Tv_Unknown)); + FStarC_Reflection_V2_Data.ppname = (FStar_Sealed.seal (Prims.strcat "x" (Prims.string_of_int n))) })) let (fresh_binder_named : Prims.string -> - FStar_Reflection_Types.typ -> + FStarC_Reflection_Types.typ -> (FStar_Tactics_NamedView.simple_binder, unit) FStar_Tactics_Effect.tac_repr) = fun s -> fun t -> - let uu___ = FStar_Tactics_V2_Builtins.fresh () in + let uu___ = FStarC_Tactics_V2_Builtins.fresh () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2565,16 +2572,16 @@ let (fresh_binder_named : FStar_Tactics_NamedView.ppname = (FStar_Sealed.seal s); FStar_Tactics_NamedView.sort = t; FStar_Tactics_NamedView.qual = - FStar_Reflection_V2_Data.Q_Explicit; + FStarC_Reflection_V2_Data.Q_Explicit; FStar_Tactics_NamedView.attrs = [] })) let (fresh_binder : - FStar_Reflection_Types.typ -> + FStarC_Reflection_Types.typ -> (FStar_Tactics_NamedView.simple_binder, unit) FStar_Tactics_Effect.tac_repr) = fun t -> - let uu___ = FStar_Tactics_V2_Builtins.fresh () in + let uu___ = FStarC_Tactics_V2_Builtins.fresh () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2596,15 +2603,15 @@ let (fresh_binder : (Prims.strcat "x" (Prims.string_of_int n))); FStar_Tactics_NamedView.sort = t; FStar_Tactics_NamedView.qual = - FStar_Reflection_V2_Data.Q_Explicit; + FStarC_Reflection_V2_Data.Q_Explicit; FStar_Tactics_NamedView.attrs = [] })) let (fresh_implicit_binder : - FStar_Reflection_Types.typ -> + FStarC_Reflection_Types.typ -> (FStar_Tactics_NamedView.binder, unit) FStar_Tactics_Effect.tac_repr) = fun t -> - let uu___ = FStar_Tactics_V2_Builtins.fresh () in + let uu___ = FStarC_Tactics_V2_Builtins.fresh () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2626,7 +2633,7 @@ let (fresh_implicit_binder : (Prims.strcat "x" (Prims.string_of_int n))); FStar_Tactics_NamedView.sort = t; FStar_Tactics_NamedView.qual = - FStar_Reflection_V2_Data.Q_Implicit; + FStarC_Reflection_V2_Data.Q_Implicit; FStar_Tactics_NamedView.attrs = [] })) let (guard : Prims.bool -> (unit, unit) FStar_Tactics_Effect.tac_repr) = @@ -2644,7 +2651,7 @@ let try_with : = fun f -> fun h -> - let uu___ = FStar_Tactics_V2_Builtins.catch f in + let uu___ = FStarC_Tactics_V2_Builtins.catch f in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2727,7 +2734,7 @@ let rec repeat : ('a Prims.list, unit) FStar_Tactics_Effect.tac_repr = fun t -> - let uu___ = FStar_Tactics_V2_Builtins.catch t in + let uu___ = FStarC_Tactics_V2_Builtins.catch t in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2832,7 +2839,7 @@ let (norm_term : fun t -> let uu___ = try_with (fun uu___1 -> match () with | () -> cur_env ()) - (fun uu___1 -> FStar_Tactics_V2_Builtins.top_env ()) in + (fun uu___1 -> FStarC_Tactics_V2_Builtins.top_env ()) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2846,7 +2853,7 @@ let (norm_term : (Prims.of_int (23))))) (Obj.magic uu___) (fun uu___1 -> (fun e -> - Obj.magic (FStar_Tactics_V2_Builtins.norm_term_env e s t)) + Obj.magic (FStarC_Tactics_V2_Builtins.norm_term_env e s t)) uu___1) let (join_all_smt_goals : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = @@ -2899,7 +2906,7 @@ let (join_all_smt_goals : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) (fun uu___2 -> match uu___2 with | (gs, sgs) -> - let uu___3 = FStar_Tactics_V2_Builtins.set_smt_goals [] in + let uu___3 = FStarC_Tactics_V2_Builtins.set_smt_goals [] in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -2918,7 +2925,7 @@ let (join_all_smt_goals : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) (fun uu___4 -> (fun uu___4 -> let uu___5 = - FStar_Tactics_V2_Builtins.set_goals sgs in + FStarC_Tactics_V2_Builtins.set_goals sgs in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -2942,7 +2949,7 @@ let (join_all_smt_goals : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) (fun uu___6 -> let uu___7 = repeat' - FStar_Tactics_V2_Builtins.join in + FStarC_Tactics_V2_Builtins.join in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -2987,7 +2994,7 @@ let (join_all_smt_goals : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) (fun uu___10 -> (fun sgs' -> let uu___10 = - FStar_Tactics_V2_Builtins.set_goals + FStarC_Tactics_V2_Builtins.set_goals gs in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -3017,7 +3024,7 @@ let (join_all_smt_goals : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) uu___11 -> Obj.magic - (FStar_Tactics_V2_Builtins.set_smt_goals + (FStarC_Tactics_V2_Builtins.set_smt_goals sgs')) uu___11))) uu___10))) uu___8))) @@ -3066,9 +3073,9 @@ let rec repeatseq : (fun uu___1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> ())) let (tadmit : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> - FStar_Tactics_V2_Builtins.tadmit_t - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const FStar_Reflection_V2_Data.C_Unit)) + FStarC_Tactics_V2_Builtins.tadmit_t + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const FStarC_Reflection_V2_Data.C_Unit)) let (admit1 : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> tadmit () let (admit_all : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = @@ -3102,7 +3109,7 @@ let (is_guard : unit -> (Prims.bool, unit) FStar_Tactics_Effect.tac_repr) = (Prims.of_int (47))))) (Obj.magic uu___1) (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___3 -> FStar_Tactics_Types.is_guard uu___2)) + (fun uu___3 -> FStarC_Tactics_Types.is_guard uu___2)) let (skip_guard : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> let uu___1 = is_guard () in @@ -3139,18 +3146,18 @@ let (guards_to_smt : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> ())) let (simpl : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> - FStar_Tactics_V2_Builtins.norm + FStarC_Tactics_V2_Builtins.norm [FStar_Pervasives.simplify; FStar_Pervasives.primops] let (whnf : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> - FStar_Tactics_V2_Builtins.norm + FStarC_Tactics_V2_Builtins.norm [FStar_Pervasives.weak; FStar_Pervasives.hnf; FStar_Pervasives.primops; FStar_Pervasives.delta] let (compute : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> - FStar_Tactics_V2_Builtins.norm + FStarC_Tactics_V2_Builtins.norm [FStar_Pervasives.primops; FStar_Pervasives.iota; FStar_Pervasives.delta; @@ -3159,7 +3166,7 @@ let (intros : unit -> (FStar_Tactics_NamedView.binding Prims.list, unit) FStar_Tactics_Effect.tac_repr) - = fun uu___ -> FStar_Tactics_V2_Builtins.intros (Prims.of_int (-1)) + = fun uu___ -> FStarC_Tactics_V2_Builtins.intros (Prims.of_int (-1)) let (intros' : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> let uu___1 = intros () in @@ -3176,10 +3183,10 @@ let (intros' : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (Prims.of_int (51))))) (Obj.magic uu___1) (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> ())) let (destruct : - FStar_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun tm -> - let uu___ = FStar_Tactics_V2_Builtins.t_destruct tm in + let uu___ = FStarC_Tactics_V2_Builtins.t_destruct tm in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -3193,12 +3200,12 @@ let (destruct : (Prims.of_int (56))))) (Obj.magic uu___) (fun uu___1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> ())) let (destruct_intros : - FStar_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun tm -> seq (fun uu___ -> - let uu___1 = FStar_Tactics_V2_Builtins.t_destruct tm in + let uu___1 = FStarC_Tactics_V2_Builtins.t_destruct tm in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -3238,9 +3245,9 @@ let (tcut : (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> FStar_Reflection_V2_Derived.mk_e_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V2"; @@ -3280,7 +3287,7 @@ let (tcut : (fun uu___3 -> (fun uu___3 -> Obj.magic - (FStar_Tactics_V2_Builtins.intro ())) + (FStarC_Tactics_V2_Builtins.intro ())) uu___3))) uu___2))) uu___1) let (pose : FStar_Tactics_NamedView.term -> @@ -3289,9 +3296,9 @@ let (pose : fun t -> let uu___ = apply - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V2"; "Derived"; "__cut"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -3341,14 +3348,14 @@ let (pose : (fun uu___5 -> (fun uu___5 -> Obj.magic - (FStar_Tactics_V2_Builtins.intro ())) + (FStarC_Tactics_V2_Builtins.intro ())) uu___5))) uu___3))) uu___1) let (intro_as : Prims.string -> (FStar_Tactics_NamedView.binding, unit) FStar_Tactics_Effect.tac_repr) = fun s -> - let uu___ = FStar_Tactics_V2_Builtins.intro () in + let uu___ = FStarC_Tactics_V2_Builtins.intro () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -3361,7 +3368,7 @@ let (intro_as : (Prims.of_int (574)) (Prims.of_int (4)) (Prims.of_int (574)) (Prims.of_int (17))))) (Obj.magic uu___) (fun uu___1 -> - (fun b -> Obj.magic (FStar_Tactics_V2_Builtins.rename_to b s)) + (fun b -> Obj.magic (FStarC_Tactics_V2_Builtins.rename_to b s)) uu___1) let (pose_as : Prims.string -> @@ -3383,7 +3390,7 @@ let (pose_as : (Prims.of_int (578)) (Prims.of_int (4)) (Prims.of_int (578)) (Prims.of_int (17))))) (Obj.magic uu___) (fun uu___1 -> - (fun b -> Obj.magic (FStar_Tactics_V2_Builtins.rename_to b s)) + (fun b -> Obj.magic (FStarC_Tactics_V2_Builtins.rename_to b s)) uu___1) let for_each_binding : 'a . @@ -3419,7 +3426,7 @@ let rec (revert_all : | uu___::tl -> Obj.magic (Obj.repr - (let uu___1 = FStar_Tactics_V2_Builtins.revert () in + (let uu___1 = FStarC_Tactics_V2_Builtins.revert () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -3436,7 +3443,7 @@ let rec (revert_all : (fun uu___2 -> Obj.magic (revert_all tl)) uu___2)))) uu___ let (binder_sort : - FStar_Tactics_NamedView.binder -> FStar_Reflection_Types.typ) = + FStar_Tactics_NamedView.binder -> FStarC_Reflection_Types.typ) = fun b -> b.FStar_Tactics_NamedView.sort let rec (__assumption_aux : FStar_Tactics_NamedView.binding Prims.list -> @@ -3463,9 +3470,9 @@ let rec (__assumption_aux : | () -> let uu___2 = apply - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Squash"; "return_squash"]))) in @@ -3573,9 +3580,10 @@ let (rewrite' : = fun x -> op_Less_Bar_Greater - (op_Less_Bar_Greater (fun uu___ -> FStar_Tactics_V2_Builtins.rewrite x) + (op_Less_Bar_Greater + (fun uu___ -> FStarC_Tactics_V2_Builtins.rewrite x) (fun uu___ -> - let uu___1 = FStar_Tactics_V2_Builtins.var_retype x in + let uu___1 = FStarC_Tactics_V2_Builtins.var_retype x in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -3592,9 +3600,9 @@ let (rewrite' : (fun uu___2 -> let uu___3 = apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V2"; @@ -3618,7 +3626,7 @@ let (rewrite' : (fun uu___4 -> (fun uu___4 -> Obj.magic - (FStar_Tactics_V2_Builtins.rewrite x)) + (FStarC_Tactics_V2_Builtins.rewrite x)) uu___4))) uu___2))) (fun uu___ -> (fun uu___ -> Obj.magic (fail "rewrite' failed")) uu___) () @@ -3666,7 +3674,7 @@ let rec (try_rewrite_equality : if term_eq x y then Obj.magic - (FStar_Tactics_V2_Builtins.rewrite x_t) + (FStarC_Tactics_V2_Builtins.rewrite x_t) else Obj.magic (try_rewrite_equality x bs1) | uu___2 -> Obj.magic (try_rewrite_equality x bs1)) @@ -3688,7 +3696,7 @@ let rec (rewrite_all_context_equalities : try_with (fun uu___1 -> match () with - | () -> FStar_Tactics_V2_Builtins.rewrite x_t) + | () -> FStarC_Tactics_V2_Builtins.rewrite x_t) (fun uu___1 -> (fun uu___1 -> Obj.magic @@ -3772,8 +3780,9 @@ let (unfold_def : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> - FStar_Reflection_V2_Builtins.implode_qn - (FStar_Reflection_V2_Builtins.inspect_fv fv))) in + FStarC_Reflection_V2_Builtins.implode_qn + (FStarC_Reflection_V2_Builtins.inspect_fv + fv))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -3791,7 +3800,7 @@ let (unfold_def : (fun uu___3 -> (fun n -> Obj.magic - (FStar_Tactics_V2_Builtins.norm + (FStarC_Tactics_V2_Builtins.norm [FStar_Pervasives.delta_fully [n]])) uu___3))) | uu___2 -> @@ -3852,7 +3861,7 @@ let (mk_squash : let sq = FStar_Tactics_NamedView.pack (FStar_Tactics_NamedView.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_fv FStar_Reflection_Const.squash_qn)) in FStar_Reflection_V2_Derived.mk_e_app sq [t] let (mk_sq_eq : @@ -3864,7 +3873,7 @@ let (mk_sq_eq : let eq = FStar_Tactics_NamedView.pack (FStar_Tactics_NamedView.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_fv FStar_Reflection_Const.eq2_qn)) in mk_squash (FStar_Reflection_V2_Derived.mk_e_app eq [t1; t2]) let (__grewrite_derived : @@ -3968,7 +3977,7 @@ let (__grewrite_derived : (fun uu___7 -> (lhs, rhs)) | uu___6 -> FStar_Tactics_Effect.raise - FStar_Tactics_Common.SKIP) in + FStarC_Tactics_Common.SKIP) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -4082,7 +4091,7 @@ let (__grewrite_derived : then Obj.repr (FStar_Tactics_Effect.raise - FStar_Tactics_Common.SKIP) + FStarC_Tactics_Common.SKIP) else Obj.repr (try_with @@ -4124,7 +4133,7 @@ let (grewrite_eq : match uu___1 with | FStar_Reflection_V2_Formula.Comp (FStar_Reflection_V2_Formula.Eq uu___2, l, r) -> - let uu___3 = FStar_Tactics_V2_Builtins.grewrite l r in + let uu___3 = FStarC_Tactics_V2_Builtins.grewrite l r in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -4177,7 +4186,8 @@ let (grewrite_eq : Obj.magic (Obj.repr (let uu___6 = - FStar_Tactics_V2_Builtins.grewrite l r in + FStarC_Tactics_V2_Builtins.grewrite l + r in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -4204,9 +4214,9 @@ let (grewrite_eq : (fun uu___8 -> let uu___9 = apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V2"; @@ -4246,7 +4256,7 @@ let (grewrite_eq : uu___4))) uu___1) let (admit_dump_t : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> - let uu___1 = FStar_Tactics_V2_Builtins.dump "Admitting" in + let uu___1 = FStarC_Tactics_V2_Builtins.dump "Admitting" in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -4262,14 +4272,14 @@ let (admit_dump_t : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___2 -> Obj.magic (apply - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "admit"]))))) uu___2) let admit_dump : 'a . (unit -> 'a) -> unit -> 'a = fun x -> fun uu___ -> x () let (magic_dump_t : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> - let uu___1 = FStar_Tactics_V2_Builtins.dump "Admitting" in + let uu___1 = FStarC_Tactics_V2_Builtins.dump "Admitting" in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -4285,9 +4295,9 @@ let (magic_dump_t : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___2 -> let uu___3 = apply - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "magic"]))) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -4306,9 +4316,9 @@ let (magic_dump_t : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___4 -> let uu___5 = exact - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const - FStar_Reflection_V2_Data.C_Unit)) in + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const + FStarC_Reflection_V2_Data.C_Unit)) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -4329,14 +4339,15 @@ let (magic_dump_t : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___7 -> ())))) uu___4))) uu___2) let magic_dump : 'a . 'a -> unit -> 'a = fun x -> fun uu___ -> x let (change_with : - FStar_Reflection_Types.term -> - FStar_Reflection_Types.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> + FStarC_Reflection_Types.term -> + (unit, unit) FStar_Tactics_Effect.tac_repr) = fun t1 -> fun t2 -> focus (fun uu___ -> - let uu___1 = FStar_Tactics_V2_Builtins.grewrite t1 t2 in + let uu___1 = FStarC_Tactics_V2_Builtins.grewrite t1 t2 in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -4355,11 +4366,11 @@ let (change_sq : FStar_Tactics_NamedView.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun t1 -> - FStar_Tactics_V2_Builtins.change + FStarC_Tactics_V2_Builtins.change (FStar_Reflection_V2_Derived.mk_e_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv ["Prims"; "squash"]))) + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "squash"]))) [t1]) let finish_by : 'a . @@ -4410,7 +4421,7 @@ let solve_then : = fun t1 -> fun t2 -> - let uu___ = FStar_Tactics_V2_Builtins.dup () in + let uu___ = FStarC_Tactics_V2_Builtins.dup () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -4496,9 +4507,9 @@ let add_elem : (fun uu___ -> let uu___1 = apply - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv ["Prims"; "Cons"]))) in + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "Cons"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -4591,7 +4602,7 @@ let specialize : (Obj.magic uu___2) (fun uu___3 -> (fun uu___3 -> Obj.magic (exact uu___3)) uu___3)) (fun uu___1 -> - FStar_Tactics_V2_Builtins.norm + FStarC_Tactics_V2_Builtins.norm [FStar_Pervasives.delta_only l; FStar_Pervasives.iota; FStar_Pervasives.zeta]) @@ -4616,8 +4627,8 @@ let (tlabel : Prims.string -> (unit, unit) FStar_Tactics_Effect.tac_repr) = | h::t -> Obj.magic (Obj.repr - (FStar_Tactics_V2_Builtins.set_goals - ((FStar_Tactics_Types.set_label l h) :: t)))) uu___1) + (FStarC_Tactics_V2_Builtins.set_goals + ((FStarC_Tactics_Types.set_label l h) :: t)))) uu___1) let (tlabel' : Prims.string -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun l -> let uu___ = goals () in @@ -4643,9 +4654,9 @@ let (tlabel' : Prims.string -> (unit, unit) FStar_Tactics_Effect.tac_repr) = Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> - FStar_Tactics_Types.set_label + FStarC_Tactics_Types.set_label (Prims.strcat l - (FStar_Tactics_Types.get_label h)) h)) in + (FStarC_Tactics_Types.get_label h)) h)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -4663,7 +4674,7 @@ let (tlabel' : Prims.string -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___3 -> (fun h1 -> Obj.magic - (FStar_Tactics_V2_Builtins.set_goals (h1 :: + (FStarC_Tactics_V2_Builtins.set_goals (h1 :: t))) uu___3)))) uu___1) let (focus_all : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> @@ -4716,7 +4727,7 @@ let (focus_all : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (Prims.of_int (39))))) (Obj.magic uu___2) (fun uu___3 -> (fun uu___3 -> - Obj.magic (FStar_Tactics_V2_Builtins.set_goals uu___3)) uu___3) in + Obj.magic (FStarC_Tactics_V2_Builtins.set_goals uu___3)) uu___3) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -4730,7 +4741,7 @@ let (focus_all : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (Prims.of_int (20))))) (Obj.magic uu___1) (fun uu___2 -> (fun uu___2 -> - Obj.magic (FStar_Tactics_V2_Builtins.set_smt_goals [])) uu___2) + Obj.magic (FStarC_Tactics_V2_Builtins.set_smt_goals [])) uu___2) let rec extract_nth : 'a . Prims.nat -> @@ -4783,7 +4794,7 @@ let (bump_nth : Prims.pos -> (unit, unit) FStar_Tactics_Effect.tac_repr) = Obj.magic (Obj.repr (fail "bump_nth: not that many goals")) | FStar_Pervasives_Native.Some (h, t) -> Obj.magic - (Obj.repr (FStar_Tactics_V2_Builtins.set_goals (h :: t)))) + (Obj.repr (FStarC_Tactics_V2_Builtins.set_goals (h :: t)))) uu___1) let rec (destruct_list : FStar_Tactics_NamedView.term -> @@ -4845,13 +4856,13 @@ let rec (destruct_list : (fun uu___3 -> match uu___3 with | (FStar_Tactics_NamedView.Tv_FVar fv, - (a1, FStar_Reflection_V2_Data.Q_Explicit):: - (a2, FStar_Reflection_V2_Data.Q_Explicit)::[]) + (a1, FStarC_Reflection_V2_Data.Q_Explicit):: + (a2, FStarC_Reflection_V2_Data.Q_Explicit)::[]) -> Obj.magic (Obj.repr (if - (FStar_Reflection_V2_Builtins.inspect_fv + (FStarC_Reflection_V2_Builtins.inspect_fv fv) = FStar_Reflection_Const.cons_qn then @@ -4881,16 +4892,16 @@ let rec (destruct_list : else Obj.repr (FStar_Tactics_Effect.raise - FStar_Tactics_Common.NotAListLiteral))) + FStarC_Tactics_Common.NotAListLiteral))) | (FStar_Tactics_NamedView.Tv_FVar fv, - (uu___4, FStar_Reflection_V2_Data.Q_Implicit):: - (a1, FStar_Reflection_V2_Data.Q_Explicit):: - (a2, FStar_Reflection_V2_Data.Q_Explicit)::[]) + (uu___4, FStarC_Reflection_V2_Data.Q_Implicit):: + (a1, FStarC_Reflection_V2_Data.Q_Explicit):: + (a2, FStarC_Reflection_V2_Data.Q_Explicit)::[]) -> Obj.magic (Obj.repr (if - (FStar_Reflection_V2_Builtins.inspect_fv + (FStarC_Reflection_V2_Builtins.inspect_fv fv) = FStar_Reflection_Const.cons_qn then @@ -4920,12 +4931,12 @@ let rec (destruct_list : else Obj.repr (FStar_Tactics_Effect.raise - FStar_Tactics_Common.NotAListLiteral))) + FStarC_Tactics_Common.NotAListLiteral))) | (FStar_Tactics_NamedView.Tv_FVar fv, uu___4) -> Obj.magic (Obj.repr (if - (FStar_Reflection_V2_Builtins.inspect_fv + (FStarC_Reflection_V2_Builtins.inspect_fv fv) = FStar_Reflection_Const.nil_qn then @@ -4933,12 +4944,12 @@ let rec (destruct_list : (fun uu___5 -> []) else FStar_Tactics_Effect.raise - FStar_Tactics_Common.NotAListLiteral)) + FStarC_Tactics_Common.NotAListLiteral)) | uu___4 -> Obj.magic (Obj.repr (FStar_Tactics_Effect.raise - FStar_Tactics_Common.NotAListLiteral))) + FStarC_Tactics_Common.NotAListLiteral))) uu___3))) uu___1) let (get_match_body : unit -> (FStar_Tactics_NamedView.term, unit) FStar_Tactics_Effect.tac_repr) @@ -5030,7 +5041,7 @@ let (branch_on_match : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (Obj.magic uu___2) (fun uu___3 -> (fun x -> - let uu___3 = FStar_Tactics_V2_Builtins.t_destruct x in + let uu___3 = FStarC_Tactics_V2_Builtins.t_destruct x in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -5052,7 +5063,7 @@ let (branch_on_match : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (iterAll (fun uu___5 -> let uu___6 = - repeat FStar_Tactics_V2_Builtins.intro in + repeat FStarC_Tactics_V2_Builtins.intro in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -5120,7 +5131,7 @@ let (branch_on_match : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___9 -> Obj.magic ( - FStar_Tactics_V2_Builtins.norm + FStarC_Tactics_V2_Builtins.norm [FStar_Pervasives.iota])) uu___9))) uu___8))) uu___7)))) @@ -5255,7 +5266,7 @@ let (namedv_to_simple_binder : (fun uu___1 -> (fun nv -> let uu___1 = - FStar_Tactics_Unseal.unseal nv.FStar_Reflection_V2_Data.sort in + FStar_Tactics_Unseal.unseal nv.FStarC_Reflection_V2_Data.sort in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -5274,27 +5285,27 @@ let (namedv_to_simple_binder : (fun uu___3 -> { FStar_Tactics_NamedView.uniq = - (nv.FStar_Reflection_V2_Data.uniq); + (nv.FStarC_Reflection_V2_Data.uniq); FStar_Tactics_NamedView.ppname = - (nv.FStar_Reflection_V2_Data.ppname); + (nv.FStarC_Reflection_V2_Data.ppname); FStar_Tactics_NamedView.sort = uu___2; FStar_Tactics_NamedView.qual = - FStar_Reflection_V2_Data.Q_Explicit; + FStarC_Reflection_V2_Data.Q_Explicit; FStar_Tactics_NamedView.attrs = [] })))) uu___1) let (binding_to_simple_binder : FStar_Tactics_NamedView.binding -> FStar_Tactics_NamedView.simple_binder) = fun b -> { - FStar_Tactics_NamedView.uniq = (b.FStar_Reflection_V2_Data.uniq1); - FStar_Tactics_NamedView.ppname = (b.FStar_Reflection_V2_Data.ppname3); - FStar_Tactics_NamedView.sort = (b.FStar_Reflection_V2_Data.sort3); - FStar_Tactics_NamedView.qual = FStar_Reflection_V2_Data.Q_Explicit; + FStar_Tactics_NamedView.uniq = (b.FStarC_Reflection_V2_Data.uniq1); + FStar_Tactics_NamedView.ppname = (b.FStarC_Reflection_V2_Data.ppname3); + FStar_Tactics_NamedView.sort = (b.FStarC_Reflection_V2_Data.sort3); + FStar_Tactics_NamedView.qual = FStarC_Reflection_V2_Data.Q_Explicit; FStar_Tactics_NamedView.attrs = [] } let (string_to_term_with_lb : (Prims.string * FStar_Tactics_NamedView.term) Prims.list -> - FStar_Reflection_Types.env -> + FStarC_Reflection_Types.env -> Prims.string -> (FStar_Tactics_NamedView.term, unit) FStar_Tactics_Effect.tac_repr) = @@ -5308,7 +5319,7 @@ let (string_to_term_with_lb : match (uu___1, uu___2) with | ((e1, lb_bvs), (i, v)) -> let uu___3 = - FStar_Tactics_V2_Builtins.push_bv_dsenv e1 i in + FStarC_Tactics_V2_Builtins.push_bv_dsenv e1 i in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -5367,7 +5378,7 @@ let (string_to_term_with_lb : (fun uu___3 -> (fun uu___3 -> let uu___4 = - FStar_Tactics_V2_Builtins.string_to_term e1 + FStarC_Tactics_V2_Builtins.string_to_term e1 t in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -5415,13 +5426,13 @@ let (string_to_term_with_lb : let (trans : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V2"; "Derived"; "lem_trans"]))) let (smt_sync : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> - let uu___1 = FStar_Tactics_V2_Builtins.get_vconfig () in + let uu___1 = FStarC_Tactics_V2_Builtins.get_vconfig () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -5435,12 +5446,12 @@ let (smt_sync : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (Prims.of_int (56))))) (Obj.magic uu___1) (fun uu___2 -> (fun uu___2 -> - Obj.magic (FStar_Tactics_V2_Builtins.t_smt_sync uu___2)) uu___2) + Obj.magic (FStarC_Tactics_V2_Builtins.t_smt_sync uu___2)) uu___2) let (smt_sync' : Prims.nat -> Prims.nat -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun fuel -> fun ifuel -> - let uu___ = FStar_Tactics_V2_Builtins.get_vconfig () in + let uu___ = FStarC_Tactics_V2_Builtins.get_vconfig () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -5460,55 +5471,58 @@ let (smt_sync' : (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> { - FStar_VConfig.initial_fuel = fuel; - FStar_VConfig.max_fuel = fuel; - FStar_VConfig.initial_ifuel = ifuel; - FStar_VConfig.max_ifuel = ifuel; - FStar_VConfig.detail_errors = - (vcfg.FStar_VConfig.detail_errors); - FStar_VConfig.detail_hint_replay = - (vcfg.FStar_VConfig.detail_hint_replay); - FStar_VConfig.no_smt = (vcfg.FStar_VConfig.no_smt); - FStar_VConfig.quake_lo = - (vcfg.FStar_VConfig.quake_lo); - FStar_VConfig.quake_hi = - (vcfg.FStar_VConfig.quake_hi); - FStar_VConfig.quake_keep = - (vcfg.FStar_VConfig.quake_keep); - FStar_VConfig.retry = (vcfg.FStar_VConfig.retry); - FStar_VConfig.smtencoding_elim_box = - (vcfg.FStar_VConfig.smtencoding_elim_box); - FStar_VConfig.smtencoding_nl_arith_repr = - (vcfg.FStar_VConfig.smtencoding_nl_arith_repr); - FStar_VConfig.smtencoding_l_arith_repr = - (vcfg.FStar_VConfig.smtencoding_l_arith_repr); - FStar_VConfig.smtencoding_valid_intro = - (vcfg.FStar_VConfig.smtencoding_valid_intro); - FStar_VConfig.smtencoding_valid_elim = - (vcfg.FStar_VConfig.smtencoding_valid_elim); - FStar_VConfig.tcnorm = (vcfg.FStar_VConfig.tcnorm); - FStar_VConfig.no_plugins = - (vcfg.FStar_VConfig.no_plugins); - FStar_VConfig.no_tactics = - (vcfg.FStar_VConfig.no_tactics); - FStar_VConfig.z3cliopt = - (vcfg.FStar_VConfig.z3cliopt); - FStar_VConfig.z3smtopt = - (vcfg.FStar_VConfig.z3smtopt); - FStar_VConfig.z3refresh = - (vcfg.FStar_VConfig.z3refresh); - FStar_VConfig.z3rlimit = - (vcfg.FStar_VConfig.z3rlimit); - FStar_VConfig.z3rlimit_factor = - (vcfg.FStar_VConfig.z3rlimit_factor); - FStar_VConfig.z3seed = (vcfg.FStar_VConfig.z3seed); - FStar_VConfig.z3version = - (vcfg.FStar_VConfig.z3version); - FStar_VConfig.trivial_pre_for_unannotated_effectful_fns + FStarC_VConfig.initial_fuel = fuel; + FStarC_VConfig.max_fuel = fuel; + FStarC_VConfig.initial_ifuel = ifuel; + FStarC_VConfig.max_ifuel = ifuel; + FStarC_VConfig.detail_errors = + (vcfg.FStarC_VConfig.detail_errors); + FStarC_VConfig.detail_hint_replay = + (vcfg.FStarC_VConfig.detail_hint_replay); + FStarC_VConfig.no_smt = + (vcfg.FStarC_VConfig.no_smt); + FStarC_VConfig.quake_lo = + (vcfg.FStarC_VConfig.quake_lo); + FStarC_VConfig.quake_hi = + (vcfg.FStarC_VConfig.quake_hi); + FStarC_VConfig.quake_keep = + (vcfg.FStarC_VConfig.quake_keep); + FStarC_VConfig.retry = (vcfg.FStarC_VConfig.retry); + FStarC_VConfig.smtencoding_elim_box = + (vcfg.FStarC_VConfig.smtencoding_elim_box); + FStarC_VConfig.smtencoding_nl_arith_repr = + (vcfg.FStarC_VConfig.smtencoding_nl_arith_repr); + FStarC_VConfig.smtencoding_l_arith_repr = + (vcfg.FStarC_VConfig.smtencoding_l_arith_repr); + FStarC_VConfig.smtencoding_valid_intro = + (vcfg.FStarC_VConfig.smtencoding_valid_intro); + FStarC_VConfig.smtencoding_valid_elim = + (vcfg.FStarC_VConfig.smtencoding_valid_elim); + FStarC_VConfig.tcnorm = + (vcfg.FStarC_VConfig.tcnorm); + FStarC_VConfig.no_plugins = + (vcfg.FStarC_VConfig.no_plugins); + FStarC_VConfig.no_tactics = + (vcfg.FStarC_VConfig.no_tactics); + FStarC_VConfig.z3cliopt = + (vcfg.FStarC_VConfig.z3cliopt); + FStarC_VConfig.z3smtopt = + (vcfg.FStarC_VConfig.z3smtopt); + FStarC_VConfig.z3refresh = + (vcfg.FStarC_VConfig.z3refresh); + FStarC_VConfig.z3rlimit = + (vcfg.FStarC_VConfig.z3rlimit); + FStarC_VConfig.z3rlimit_factor = + (vcfg.FStarC_VConfig.z3rlimit_factor); + FStarC_VConfig.z3seed = + (vcfg.FStarC_VConfig.z3seed); + FStarC_VConfig.z3version = + (vcfg.FStarC_VConfig.z3version); + FStarC_VConfig.trivial_pre_for_unannotated_effectful_fns = - (vcfg.FStar_VConfig.trivial_pre_for_unannotated_effectful_fns); - FStar_VConfig.reuse_hint_for = - (vcfg.FStar_VConfig.reuse_hint_for) + (vcfg.FStarC_VConfig.trivial_pre_for_unannotated_effectful_fns); + FStarC_VConfig.reuse_hint_for = + (vcfg.FStarC_VConfig.reuse_hint_for) })) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -5526,27 +5540,27 @@ let (smt_sync' : (fun uu___2 -> (fun vcfg' -> Obj.magic - (FStar_Tactics_V2_Builtins.t_smt_sync vcfg')) + (FStarC_Tactics_V2_Builtins.t_smt_sync vcfg')) uu___2))) uu___1) let (check_equiv : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.typ -> - FStar_Reflection_Types.typ -> - (((unit, unit, unit) FStar_Tactics_Types.equiv_token + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.typ -> + FStarC_Reflection_Types.typ -> + (((unit, unit, unit) FStarC_Tactics_Types.equiv_token FStar_Pervasives_Native.option * FStar_Issue.issue Prims.list), unit) FStar_Tactics_Effect.tac_repr) = fun g -> fun t0 -> - fun t1 -> FStar_Tactics_V2_Builtins.t_check_equiv true true g t0 t1 + fun t1 -> FStarC_Tactics_V2_Builtins.t_check_equiv true true g t0 t1 let (check_equiv_nosmt : - FStar_Reflection_Types.env -> - FStar_Reflection_Types.typ -> - FStar_Reflection_Types.typ -> - (((unit, unit, unit) FStar_Tactics_Types.equiv_token + FStarC_Reflection_Types.env -> + FStarC_Reflection_Types.typ -> + FStarC_Reflection_Types.typ -> + (((unit, unit, unit) FStarC_Tactics_Types.equiv_token FStar_Pervasives_Native.option * FStar_Issue.issue Prims.list), unit) FStar_Tactics_Effect.tac_repr) = fun g -> fun t0 -> - fun t1 -> FStar_Tactics_V2_Builtins.t_check_equiv false false g t0 t1 \ No newline at end of file + fun t1 -> FStarC_Tactics_V2_Builtins.t_check_equiv false false g t0 t1 \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_V2_Logic.ml b/ocaml/fstar-lib/generated/FStar_Tactics_V2_Logic.ml index bf525600f81..0dfe9c4e0ec 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_V2_Logic.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_V2_Logic.ml @@ -1,6 +1,7 @@ open Prims let (cur_goal : - unit -> (FStar_Reflection_Types.typ, unit) FStar_Tactics_Effect.tac_repr) = + unit -> (FStarC_Reflection_Types.typ, unit) FStar_Tactics_Effect.tac_repr) + = fun uu___ -> let uu___1 = let uu___2 = Obj.magic (FStar_Tactics_Effect.get ()) in @@ -17,7 +18,7 @@ let (cur_goal : (Prims.of_int (25))))) (Obj.magic uu___2) (fun uu___3 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___4 -> FStar_Tactics_Types.goals_of uu___3)) in + (fun uu___4 -> FStarC_Tactics_Types.goals_of uu___3)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -33,11 +34,11 @@ let (cur_goal : match uu___2 with | g::uu___3 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___4 -> FStar_Tactics_Types.goal_type g) + (fun uu___4 -> FStarC_Tactics_Types.goal_type g) | uu___3 -> FStar_Tactics_Effect.raise - (FStar_Tactics_Common.TacticFailure - ([FStar_Pprint.arbitrary_string "no more goals"], + (FStarC_Tactics_Common.TacticFailure + ([FStarC_Pprint.arbitrary_string "no more goals"], FStar_Pervasives_Native.None))) let (cur_formula : unit -> @@ -61,11 +62,11 @@ let (cur_formula : Obj.magic (FStar_Reflection_V2_Formula.term_as_formula uu___2)) uu___2) let (term_eq : - FStar_Reflection_Types.term -> FStar_Reflection_Types.term -> Prims.bool) = - FStar_Reflection_TermEq_Simple.term_eq + FStarC_Reflection_Types.term -> FStarC_Reflection_Types.term -> Prims.bool) + = FStar_Reflection_TermEq_Simple.term_eq let (l_revert : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> - let uu___1 = FStar_Tactics_V2_Builtins.revert () in + let uu___1 = FStarC_Tactics_V2_Builtins.revert () in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -81,9 +82,9 @@ let (l_revert : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___2 -> Obj.magic (FStar_Tactics_V2_Derived.apply - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; @@ -91,17 +92,17 @@ let (l_revert : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = "Lemmas"; "revert_squash"]))))) uu___2) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.l_revert" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.l_revert" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.Logic.l_revert (plugin)" - (FStar_Tactics_Native.from_tactic_1 l_revert) - FStar_Syntax_Embeddings.e_unit FStar_Syntax_Embeddings.e_unit - psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 l_revert) + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let rec (l_revert_all : FStar_Tactics_NamedView.binding Prims.list -> (unit, unit) FStar_Tactics_Effect.tac_repr) @@ -132,18 +133,18 @@ let rec (l_revert_all : (fun uu___2 -> Obj.magic (l_revert_all tl)) uu___2)))) uu___ let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.l_revert_all" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.l_revert_all" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.Logic.l_revert_all (plugin)" - (FStar_Tactics_Native.from_tactic_1 l_revert_all) - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_binding) - FStar_Syntax_Embeddings.e_unit psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 l_revert_all) + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_binding) + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (forall_intro : unit -> (FStar_Tactics_NamedView.binding, unit) FStar_Tactics_Effect.tac_repr) @@ -151,9 +152,9 @@ let (forall_intro : fun uu___ -> let uu___1 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; @@ -172,20 +173,20 @@ let (forall_intro : (Prims.of_int (46)) (Prims.of_int (4)) (Prims.of_int (46)) (Prims.of_int (12))))) (Obj.magic uu___1) (fun uu___2 -> - (fun uu___2 -> Obj.magic (FStar_Tactics_V2_Builtins.intro ())) + (fun uu___2 -> Obj.magic (FStarC_Tactics_V2_Builtins.intro ())) uu___2) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.forall_intro" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.forall_intro" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.Logic.forall_intro (plugin)" - (FStar_Tactics_Native.from_tactic_1 forall_intro) - FStar_Syntax_Embeddings.e_unit - FStar_Reflection_V2_Embeddings.e_binding psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 forall_intro) + FStarC_Syntax_Embeddings.e_unit + FStarC_Reflection_V2_Embeddings.e_binding psc ncb us args) let (forall_intro_as : Prims.string -> (FStar_Tactics_NamedView.binding, unit) FStar_Tactics_Effect.tac_repr) @@ -193,9 +194,9 @@ let (forall_intro_as : fun s -> let uu___ = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; @@ -217,35 +218,35 @@ let (forall_intro_as : (fun uu___1 -> Obj.magic (FStar_Tactics_V2_Derived.intro_as s)) uu___1) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.forall_intro_as" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.Logic.forall_intro_as (plugin)" - (FStar_Tactics_Native.from_tactic_1 forall_intro_as) - FStar_Syntax_Embeddings.e_string - FStar_Reflection_V2_Embeddings.e_binding psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 forall_intro_as) + FStarC_Syntax_Embeddings.e_string + FStarC_Reflection_V2_Embeddings.e_binding psc ncb us args) let (forall_intros : unit -> (FStar_Tactics_NamedView.binding Prims.list, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> FStar_Tactics_V2_Derived.repeat1 forall_intro let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.forall_intros" - (Prims.of_int (2)) + FStarC_Tactics_Native.register_tactic + "FStar.Tactics.V2.Logic.forall_intros" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.Logic.forall_intros (plugin)" - (FStar_Tactics_Native.from_tactic_1 forall_intros) - FStar_Syntax_Embeddings.e_unit - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_binding) psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 forall_intros) + FStarC_Syntax_Embeddings.e_unit + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_binding) psc ncb us args) let (split : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> FStar_Tactics_V2_Derived.try_with @@ -253,9 +254,9 @@ let (split : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = match () with | () -> FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; @@ -267,17 +268,17 @@ let (split : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = Obj.magic (FStar_Tactics_V2_Derived.fail "Could not split goal")) uu___1) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.split" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.split" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.Logic.split (plugin)" - (FStar_Tactics_Native.from_tactic_1 split) - FStar_Syntax_Embeddings.e_unit FStar_Syntax_Embeddings.e_unit - psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 split) + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (implies_intro : unit -> (FStar_Tactics_NamedView.binding, unit) FStar_Tactics_Effect.tac_repr) @@ -285,9 +286,9 @@ let (implies_intro : fun uu___ -> let uu___1 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; @@ -306,20 +307,20 @@ let (implies_intro : (Prims.of_int (64)) (Prims.of_int (4)) (Prims.of_int (64)) (Prims.of_int (12))))) (Obj.magic uu___1) (fun uu___2 -> - (fun uu___2 -> Obj.magic (FStar_Tactics_V2_Builtins.intro ())) + (fun uu___2 -> Obj.magic (FStarC_Tactics_V2_Builtins.intro ())) uu___2) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.implies_intro" - (Prims.of_int (2)) + FStarC_Tactics_Native.register_tactic + "FStar.Tactics.V2.Logic.implies_intro" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.Logic.implies_intro (plugin)" - (FStar_Tactics_Native.from_tactic_1 implies_intro) - FStar_Syntax_Embeddings.e_unit - FStar_Reflection_V2_Embeddings.e_binding psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 implies_intro) + FStarC_Syntax_Embeddings.e_unit + FStarC_Reflection_V2_Embeddings.e_binding psc ncb us args) let (implies_intro_as : Prims.string -> (FStar_Tactics_NamedView.binding, unit) FStar_Tactics_Effect.tac_repr) @@ -327,9 +328,9 @@ let (implies_intro_as : fun s -> let uu___ = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; @@ -351,88 +352,88 @@ let (implies_intro_as : (fun uu___1 -> Obj.magic (FStar_Tactics_V2_Derived.intro_as s)) uu___1) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.implies_intro_as" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.Logic.implies_intro_as (plugin)" - (FStar_Tactics_Native.from_tactic_1 implies_intro_as) - FStar_Syntax_Embeddings.e_string - FStar_Reflection_V2_Embeddings.e_binding psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 implies_intro_as) + FStarC_Syntax_Embeddings.e_string + FStarC_Reflection_V2_Embeddings.e_binding psc ncb us args) let (implies_intros : unit -> (FStar_Tactics_NamedView.binding Prims.list, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> FStar_Tactics_V2_Derived.repeat1 implies_intro let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.implies_intros" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.Logic.implies_intros (plugin)" - (FStar_Tactics_Native.from_tactic_1 implies_intros) - FStar_Syntax_Embeddings.e_unit - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_binding) psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 implies_intros) + FStarC_Syntax_Embeddings.e_unit + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_binding) psc ncb us args) let (l_intro : unit -> (FStar_Tactics_NamedView.binding, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> FStar_Tactics_V2_Derived.or_else forall_intro implies_intro let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.l_intro" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.l_intro" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.Logic.l_intro (plugin)" - (FStar_Tactics_Native.from_tactic_1 l_intro) - FStar_Syntax_Embeddings.e_unit - FStar_Reflection_V2_Embeddings.e_binding psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 l_intro) + FStarC_Syntax_Embeddings.e_unit + FStarC_Reflection_V2_Embeddings.e_binding psc ncb us args) let (l_intros : unit -> (FStar_Tactics_NamedView.binding Prims.list, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> FStar_Tactics_V2_Derived.repeat l_intro let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.l_intros" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.l_intros" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.Logic.l_intros (plugin)" - (FStar_Tactics_Native.from_tactic_1 l_intros) - FStar_Syntax_Embeddings.e_unit - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_binding) psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 l_intros) + FStarC_Syntax_Embeddings.e_unit + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_binding) psc ncb us args) let (squash_intro : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> FStar_Tactics_V2_Derived.apply - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Squash"; "return_squash"]))) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.squash_intro" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.squash_intro" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.Logic.squash_intro (plugin)" - (FStar_Tactics_Native.from_tactic_1 squash_intro) - FStar_Syntax_Embeddings.e_unit FStar_Syntax_Embeddings.e_unit - psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 squash_intro) + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (l_exact : FStar_Tactics_NamedView.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) = @@ -457,33 +458,33 @@ let (l_exact : (fun uu___2 -> Obj.magic (FStar_Tactics_V2_Derived.exact t)) uu___2)) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.l_exact" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.l_exact" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.Logic.l_exact (plugin)" - (FStar_Tactics_Native.from_tactic_1 l_exact) - FStar_Reflection_V2_Embeddings.e_term - FStar_Syntax_Embeddings.e_unit psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 l_exact) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (hyp : FStar_Tactics_NamedView.namedv -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun x -> l_exact (FStar_Tactics_V2_SyntaxCoercions.namedv_to_term x) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.hyp" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.hyp" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.Logic.hyp (plugin)" - (FStar_Tactics_Native.from_tactic_1 hyp) - FStar_Reflection_V2_Embeddings.e_namedv_view - FStar_Syntax_Embeddings.e_unit psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 hyp) + FStarC_Reflection_V2_Embeddings.e_namedv_view + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (pose_lemma : FStar_Tactics_NamedView.term -> (FStar_Tactics_NamedView.binding, unit) FStar_Tactics_Effect.tac_repr) @@ -520,7 +521,7 @@ let (pose_lemma : (fun c -> let uu___1 = match c with - | FStar_Reflection_V2_Data.C_Lemma (pre, post, uu___2) -> + | FStarC_Reflection_V2_Data.C_Lemma (pre, post, uu___2) -> Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> (pre, post))) @@ -546,13 +547,13 @@ let (pose_lemma : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App (post, - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const - FStar_Reflection_V2_Data.C_Unit)), - FStar_Reflection_V2_Data.Q_Explicit))))) in + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const + FStarC_Reflection_V2_Data.C_Unit)), + FStarC_Reflection_V2_Data.Q_Explicit))))) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -627,17 +628,17 @@ let (pose_lemma : -> Obj.magic (FStar_Tactics_V2_Derived.pose - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; @@ -645,48 +646,48 @@ let (pose_lemma : "Lemmas"; "__lemma_to_squash"]))), (pre, - FStar_Reflection_V2_Data.Q_Implicit)))), + FStarC_Reflection_V2_Data.Q_Implicit)))), (post2, - FStar_Reflection_V2_Data.Q_Implicit)))), - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Const - FStar_Reflection_V2_Data.C_Unit)), - FStar_Reflection_V2_Data.Q_Explicit)))), - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Abs - ((FStar_Reflection_V2_Builtins.pack_binder + FStarC_Reflection_V2_Data.Q_Implicit)))), + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Const + FStarC_Reflection_V2_Data.C_Unit)), + FStarC_Reflection_V2_Data.Q_Explicit)))), + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Abs + ((FStarC_Reflection_V2_Builtins.pack_binder { - FStar_Reflection_V2_Data.sort2 + FStarC_Reflection_V2_Data.sort2 = - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "unit"]))); - FStar_Reflection_V2_Data.qual + FStarC_Reflection_V2_Data.qual = - FStar_Reflection_V2_Data.Q_Explicit; - FStar_Reflection_V2_Data.attrs + FStarC_Reflection_V2_Data.Q_Explicit; + FStarC_Reflection_V2_Data.attrs = []; - FStar_Reflection_V2_Data.ppname2 + FStarC_Reflection_V2_Data.ppname2 = (FStar_Sealed.seal "uu___") }), t))), - FStar_Reflection_V2_Data.Q_Explicit))))) + FStarC_Reflection_V2_Data.Q_Explicit))))) | uu___7 -> let uu___8 = FStar_Tactics_V2_Derived.tcut ( - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "squash"]))), (pre, - FStar_Reflection_V2_Data.Q_Explicit)))) in + FStarC_Reflection_V2_Data.Q_Explicit)))) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -714,17 +715,17 @@ let (pose_lemma : let uu___9 = FStar_Tactics_V2_Derived.pose - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; @@ -732,34 +733,34 @@ let (pose_lemma : "Lemmas"; "__lemma_to_squash"]))), (pre, - FStar_Reflection_V2_Data.Q_Implicit)))), + FStarC_Reflection_V2_Data.Q_Implicit)))), (post2, - FStar_Reflection_V2_Data.Q_Implicit)))), + FStarC_Reflection_V2_Data.Q_Implicit)))), ((FStar_Tactics_V2_SyntaxCoercions.binding_to_term reqb), - FStar_Reflection_V2_Data.Q_Explicit)))), - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_Abs - ((FStar_Reflection_V2_Builtins.pack_binder + FStarC_Reflection_V2_Data.Q_Explicit)))), + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_Abs + ((FStarC_Reflection_V2_Builtins.pack_binder { - FStar_Reflection_V2_Data.sort2 + FStarC_Reflection_V2_Data.sort2 = - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["Prims"; "unit"]))); - FStar_Reflection_V2_Data.qual + FStarC_Reflection_V2_Data.qual = - FStar_Reflection_V2_Data.Q_Explicit; - FStar_Reflection_V2_Data.attrs + FStarC_Reflection_V2_Data.Q_Explicit; + FStarC_Reflection_V2_Data.attrs = []; - FStar_Reflection_V2_Data.ppname2 + FStarC_Reflection_V2_Data.ppname2 = (FStar_Sealed.seal "uu___") }), t))), - FStar_Reflection_V2_Data.Q_Explicit)))) in + FStarC_Reflection_V2_Data.Q_Explicit)))) in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -879,17 +880,17 @@ let (pose_lemma : uu___6))) uu___5))) uu___4))) uu___2))) uu___1) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.pose_lemma" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.pose_lemma" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.Logic.pose_lemma (plugin)" - (FStar_Tactics_Native.from_tactic_1 pose_lemma) - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_binding psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 pose_lemma) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_binding psc ncb us args) let (explode : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> let uu___1 = @@ -941,17 +942,17 @@ let (explode : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (Prims.of_int (64))))) (Obj.magic uu___1) (fun uu___2 -> FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> ())) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.explode" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.explode" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.Logic.explode (plugin)" - (FStar_Tactics_Native.from_tactic_1 explode) - FStar_Syntax_Embeddings.e_unit FStar_Syntax_Embeddings.e_unit - psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 explode) + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let rec (visit : (unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) -> (unit, unit) FStar_Tactics_Effect.tac_repr) @@ -1155,7 +1156,7 @@ let rec (simplify_eq_implication : (fun uu___6 -> (fun eq_h -> let uu___6 = - FStar_Tactics_V2_Builtins.rewrite + FStarC_Tactics_V2_Builtins.rewrite eq_h in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1179,7 +1180,7 @@ let rec (simplify_eq_implication : (fun uu___7 -> (fun uu___7 -> let uu___8 = - FStar_Tactics_V2_Builtins.clear_top + FStarC_Tactics_V2_Builtins.clear_top () in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1217,32 +1218,32 @@ let rec (simplify_eq_implication : uu___6)))) uu___4))) uu___3))) uu___2) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.simplify_eq_implication" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.Logic.simplify_eq_implication (plugin)" - (FStar_Tactics_Native.from_tactic_1 simplify_eq_implication) - FStar_Syntax_Embeddings.e_unit FStar_Syntax_Embeddings.e_unit - psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 simplify_eq_implication) + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (rewrite_all_equalities : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> visit simplify_eq_implication let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.rewrite_all_equalities" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.Logic.rewrite_all_equalities (plugin)" - (FStar_Tactics_Native.from_tactic_1 rewrite_all_equalities) - FStar_Syntax_Embeddings.e_unit FStar_Syntax_Embeddings.e_unit - psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 rewrite_all_equalities) + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let rec (unfold_definition_and_simplify_eq : FStar_Tactics_NamedView.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) = @@ -1348,7 +1349,7 @@ let rec (unfold_definition_and_simplify_eq : (fun uu___7 -> (fun eq_h -> let uu___7 = - FStar_Tactics_V2_Builtins.rewrite + FStarC_Tactics_V2_Builtins.rewrite eq_h in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1376,7 +1377,7 @@ let rec (unfold_definition_and_simplify_eq : uu___8 -> let uu___9 = - FStar_Tactics_V2_Builtins.clear_top + FStarC_Tactics_V2_Builtins.clear_top () in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -1416,19 +1417,19 @@ let rec (unfold_definition_and_simplify_eq : uu___7)))) uu___5)))) uu___2))) uu___1) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.unfold_definition_and_simplify_eq" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.Logic.unfold_definition_and_simplify_eq (plugin)" - (FStar_Tactics_Native.from_tactic_1 + (FStarC_Tactics_Native.from_tactic_1 unfold_definition_and_simplify_eq) - FStar_Reflection_V2_Embeddings.e_term - FStar_Syntax_Embeddings.e_unit psc ncb us args) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (unsquash : FStar_Tactics_NamedView.term -> (FStar_Tactics_NamedView.term, unit) FStar_Tactics_Effect.tac_repr) @@ -1438,9 +1439,9 @@ let (unsquash : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___1 -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; "Logic"; "Lemmas"; "vbind"])))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1473,7 +1474,7 @@ let (unsquash : (Obj.magic uu___1) (fun uu___2 -> (fun uu___2 -> - let uu___3 = FStar_Tactics_V2_Builtins.intro () in + let uu___3 = FStarC_Tactics_V2_Builtins.intro () in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1496,40 +1497,40 @@ let (unsquash : (FStar_Tactics_V2_SyntaxCoercions.binding_to_namedv b)))))) uu___2))) uu___1) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.unsquash" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.unsquash" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.Logic.unsquash (plugin)" - (FStar_Tactics_Native.from_tactic_1 unsquash) - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_term psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 unsquash) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_term psc ncb us args) let (cases_or : FStar_Tactics_NamedView.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun o -> FStar_Tactics_V2_Derived.apply_lemma (FStar_Reflection_V2_Derived.mk_e_app - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; "Logic"; "Lemmas"; "or_ind"]))) [o]) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.cases_or" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.cases_or" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.Logic.cases_or (plugin)" - (FStar_Tactics_Native.from_tactic_1 cases_or) - FStar_Reflection_V2_Embeddings.e_term - FStar_Syntax_Embeddings.e_unit psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 cases_or) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (cases_bool : FStar_Tactics_NamedView.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) = @@ -1538,9 +1539,9 @@ let (cases_bool : Obj.magic (FStar_Tactics_Effect.lift_div_tac (fun uu___1 -> - FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; @@ -1591,7 +1592,7 @@ let (cases_bool : (fun uu___5 -> (fun b1 -> let uu___5 = - FStar_Tactics_V2_Builtins.rewrite b1 in + FStarC_Tactics_V2_Builtins.rewrite b1 in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1614,7 +1615,7 @@ let (cases_bool : (fun uu___6 -> (fun uu___6 -> Obj.magic - (FStar_Tactics_V2_Builtins.clear_top + (FStarC_Tactics_V2_Builtins.clear_top ())) uu___6))) uu___5)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1634,55 +1635,55 @@ let (cases_bool : FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> ()))))) uu___1) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.cases_bool" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.cases_bool" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.Logic.cases_bool (plugin)" - (FStar_Tactics_Native.from_tactic_1 cases_bool) - FStar_Reflection_V2_Embeddings.e_term - FStar_Syntax_Embeddings.e_unit psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 cases_bool) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (left : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; "Logic"; "Lemmas"; "or_intro_1"]))) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.left" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.left" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.Logic.left (plugin)" - (FStar_Tactics_Native.from_tactic_1 left) - FStar_Syntax_Embeddings.e_unit FStar_Syntax_Embeddings.e_unit - psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 left) + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (right : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; "Logic"; "Lemmas"; "or_intro_2"]))) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.right" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.right" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.Logic.right (plugin)" - (FStar_Tactics_Native.from_tactic_1 right) - FStar_Syntax_Embeddings.e_unit FStar_Syntax_Embeddings.e_unit - psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 right) + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (and_elim : FStar_Tactics_NamedView.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) = @@ -1692,44 +1693,44 @@ let (and_elim : match () with | () -> FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; "Logic"; "Lemmas"; "__and_elim"]))), - (t, FStar_Reflection_V2_Data.Q_Explicit))))) + (t, FStarC_Reflection_V2_Data.Q_Explicit))))) (fun uu___ -> FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; "Logic"; "Lemmas"; "__and_elim'"]))), - (t, FStar_Reflection_V2_Data.Q_Explicit))))) + (t, FStarC_Reflection_V2_Data.Q_Explicit))))) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.and_elim" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.and_elim" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.Logic.and_elim (plugin)" - (FStar_Tactics_Native.from_tactic_1 and_elim) - FStar_Reflection_V2_Embeddings.e_term - FStar_Syntax_Embeddings.e_unit psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 and_elim) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (destruct_and : FStar_Tactics_NamedView.term -> ((FStar_Tactics_NamedView.binding * FStar_Tactics_NamedView.binding), @@ -1787,28 +1788,28 @@ let (destruct_and : (fun uu___6 -> (uu___3, uu___5))))) uu___3))) uu___1) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.destruct_and" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.destruct_and" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.Logic.destruct_and (plugin)" - (FStar_Tactics_Native.from_tactic_1 destruct_and) - FStar_Reflection_V2_Embeddings.e_term - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Reflection_V2_Embeddings.e_binding - FStar_Reflection_V2_Embeddings.e_binding) psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 destruct_and) + FStarC_Reflection_V2_Embeddings.e_term + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Reflection_V2_Embeddings.e_binding + FStarC_Reflection_V2_Embeddings.e_binding) psc ncb us args) let (witness : FStar_Tactics_NamedView.term -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun t -> let uu___ = FStar_Tactics_V2_Derived.apply_raw - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; "Logic"; "Lemmas"; "__witness"]))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1824,17 +1825,17 @@ let (witness : (fun uu___1 -> (fun uu___1 -> Obj.magic (FStar_Tactics_V2_Derived.exact t)) uu___1) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.witness" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.witness" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.Logic.witness (plugin)" - (FStar_Tactics_Native.from_tactic_1 witness) - FStar_Reflection_V2_Embeddings.e_term - FStar_Syntax_Embeddings.e_unit psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 witness) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let (elim_exists : FStar_Tactics_NamedView.term -> ((FStar_Tactics_NamedView.binding * FStar_Tactics_NamedView.binding), @@ -1843,18 +1844,18 @@ let (elim_exists : fun t -> let uu___ = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; "Logic"; "Lemmas"; "__elim_exists'"]))), - (t, FStar_Reflection_V2_Data.Q_Explicit)))) in + (t, FStarC_Reflection_V2_Data.Q_Explicit)))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1868,7 +1869,7 @@ let (elim_exists : (Prims.of_int (9))))) (Obj.magic uu___) (fun uu___1 -> (fun uu___1 -> - let uu___2 = FStar_Tactics_V2_Builtins.intro () in + let uu___2 = FStarC_Tactics_V2_Builtins.intro () in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1884,7 +1885,7 @@ let (elim_exists : (Obj.magic uu___2) (fun uu___3 -> (fun x -> - let uu___3 = FStar_Tactics_V2_Builtins.intro () in + let uu___3 = FStarC_Tactics_V2_Builtins.intro () in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1904,19 +1905,19 @@ let (elim_exists : FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> (x, pf))))) uu___3))) uu___1) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.elim_exists" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.elim_exists" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.Logic.elim_exists (plugin)" - (FStar_Tactics_Native.from_tactic_1 elim_exists) - FStar_Reflection_V2_Embeddings.e_term - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Reflection_V2_Embeddings.e_binding - FStar_Reflection_V2_Embeddings.e_binding) psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 elim_exists) + FStarC_Reflection_V2_Embeddings.e_term + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Reflection_V2_Embeddings.e_binding + FStarC_Reflection_V2_Embeddings.e_binding) psc ncb us args) let (instantiate : FStar_Tactics_NamedView.term -> FStar_Tactics_NamedView.term -> @@ -1929,34 +1930,34 @@ let (instantiate : match () with | () -> FStar_Tactics_V2_Derived.pose - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; "Logic"; "Lemmas"; "__forall_inst_sq"]))), - (fa, FStar_Reflection_V2_Data.Q_Explicit)))), - (x, FStar_Reflection_V2_Data.Q_Explicit))))) + (fa, FStarC_Reflection_V2_Data.Q_Explicit)))), + (x, FStarC_Reflection_V2_Data.Q_Explicit))))) (fun uu___ -> FStar_Tactics_V2_Derived.try_with (fun uu___1 -> match () with | () -> FStar_Tactics_V2_Derived.pose - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; @@ -1964,26 +1965,26 @@ let (instantiate : "Lemmas"; "__forall_inst"]))), (fa, - FStar_Reflection_V2_Data.Q_Explicit)))), - (x, FStar_Reflection_V2_Data.Q_Explicit))))) + FStarC_Reflection_V2_Data.Q_Explicit)))), + (x, FStarC_Reflection_V2_Data.Q_Explicit))))) (fun uu___1 -> (fun uu___1 -> Obj.magic (FStar_Tactics_V2_Derived.fail "could not instantiate")) uu___1)) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.instantiate" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.instantiate" (Prims.of_int (3)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_2 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_2 "FStar.Tactics.V2.Logic.instantiate (plugin)" - (FStar_Tactics_Native.from_tactic_2 instantiate) - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_binding psc ncb us args) + (FStarC_Tactics_Native.from_tactic_2 instantiate) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_binding psc ncb us args) let (instantiate_as : FStar_Tactics_NamedView.term -> FStar_Tactics_NamedView.term -> @@ -2007,22 +2008,22 @@ let (instantiate_as : (Prims.of_int (229)) (Prims.of_int (17))))) (Obj.magic uu___) (fun uu___1 -> - (fun b -> Obj.magic (FStar_Tactics_V2_Builtins.rename_to b s)) + (fun b -> Obj.magic (FStarC_Tactics_V2_Builtins.rename_to b s)) uu___1) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.instantiate_as" (Prims.of_int (4)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_3 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_3 "FStar.Tactics.V2.Logic.instantiate_as (plugin)" - (FStar_Tactics_Native.from_tactic_3 instantiate_as) - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_term - FStar_Syntax_Embeddings.e_string - FStar_Reflection_V2_Embeddings.e_binding psc ncb us args) + (FStarC_Tactics_Native.from_tactic_3 instantiate_as) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Syntax_Embeddings.e_string + FStarC_Reflection_V2_Embeddings.e_binding psc ncb us args) let rec (sk_binder' : FStar_Tactics_NamedView.binding Prims.list -> FStar_Tactics_NamedView.binding -> @@ -2040,11 +2041,11 @@ let rec (sk_binder' : | () -> let uu___2 = FStar_Tactics_V2_Derived.apply_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; @@ -2052,7 +2053,7 @@ let rec (sk_binder' : "Lemmas"; "sklem0"]))), ((FStar_Tactics_V2_SyntaxCoercions.binding_to_term - b), FStar_Reflection_V2_Data.Q_Explicit)))) in + b), FStarC_Reflection_V2_Data.Q_Explicit)))) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2140,7 +2141,7 @@ let rec (sk_binder' : (fun uu___5 -> (fun uu___5 -> let uu___6 = - FStar_Tactics_V2_Builtins.clear b in + FStarC_Tactics_V2_Builtins.clear b in Obj.magic (FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -2254,7 +2255,7 @@ let (skolem : (Obj.magic uu___2) (fun uu___3 -> FStar_Tactics_Effect.lift_div_tac - (fun uu___4 -> FStar_Reflection_V2_Builtins.vars_of_env uu___3)) in + (fun uu___4 -> FStarC_Reflection_V2_Builtins.vars_of_env uu___3)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2269,26 +2270,26 @@ let (skolem : (fun uu___2 -> (fun bs -> Obj.magic (FStar_Tactics_Util.map sk_binder bs)) uu___2) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.skolem" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.skolem" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.Logic.skolem (plugin)" - (FStar_Tactics_Native.from_tactic_1 skolem) - FStar_Syntax_Embeddings.e_unit - (FStar_Syntax_Embeddings.e_list - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_binding) - FStar_Reflection_V2_Embeddings.e_binding)) psc ncb us + (FStarC_Tactics_Native.from_tactic_1 skolem) + FStarC_Syntax_Embeddings.e_unit + (FStarC_Syntax_Embeddings.e_list + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_binding) + FStarC_Reflection_V2_Embeddings.e_binding)) psc ncb us args) let (easy_fill : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = fun uu___ -> let uu___1 = - FStar_Tactics_V2_Derived.repeat FStar_Tactics_V2_Builtins.intro in + FStar_Tactics_V2_Derived.repeat FStarC_Tactics_V2_Builtins.intro in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -2307,9 +2308,9 @@ let (easy_fill : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (fun uu___4 -> let uu___5 = FStar_Tactics_V2_Derived.apply - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; @@ -2330,7 +2331,7 @@ let (easy_fill : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = (Obj.magic uu___5) (fun uu___6 -> (fun uu___6 -> - Obj.magic (FStar_Tactics_V2_Builtins.intro ())) + Obj.magic (FStarC_Tactics_V2_Builtins.intro ())) uu___6)) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -2350,46 +2351,47 @@ let (easy_fill : unit -> (unit, unit) FStar_Tactics_Effect.tac_repr) = Obj.magic (FStar_Tactics_V2_Derived.smt ())) uu___4))) uu___2) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.easy_fill" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.easy_fill" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.Logic.easy_fill (plugin)" - (FStar_Tactics_Native.from_tactic_1 easy_fill) - FStar_Syntax_Embeddings.e_unit FStar_Syntax_Embeddings.e_unit - psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 easy_fill) + FStarC_Syntax_Embeddings.e_unit + FStarC_Syntax_Embeddings.e_unit psc ncb us args) let easy : 'a . 'a -> 'a = fun x -> x let _ = - FStar_Tactics_Native.register_plugin "FStar.Tactics.V2.Logic.easy" + FStarC_Tactics_Native.register_plugin "FStar.Tactics.V2.Logic.easy" (Prims.of_int (2)) (fun _psc -> fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap "FStar.Tactics.V2.Logic.easy" + FStarC_Syntax_Embeddings.debug_wrap + "FStar.Tactics.V2.Logic.easy" (fun _ -> match args with | (tv_0, _)::args_tail -> - (FStar_Syntax_Embeddings.arrow_as_prim_step_1 - (FStar_Syntax_Embeddings.mk_any_emb tv_0) - (FStar_Syntax_Embeddings.mk_any_emb tv_0) easy - (FStar_Ident.lid_of_str + (FStarC_Syntax_Embeddings.arrow_as_prim_step_1 + (FStarC_Syntax_Embeddings.mk_any_emb tv_0) + (FStarC_Syntax_Embeddings.mk_any_emb tv_0) easy + (FStarC_Ident.lid_of_str "FStar.Tactics.V2.Logic.easy") cb us) args_tail | _ -> failwith "arity mismatch")) (fun cb -> fun us -> fun args -> - FStar_Syntax_Embeddings.debug_wrap "FStar.Tactics.V2.Logic.easy" + FStarC_Syntax_Embeddings.debug_wrap "FStar.Tactics.V2.Logic.easy" (fun _ -> match args with | (tv_0, _)::args_tail -> - (FStar_TypeChecker_NBETerm.arrow_as_prim_step_1 - (FStar_TypeChecker_NBETerm.mk_any_emb tv_0) - (FStar_TypeChecker_NBETerm.mk_any_emb tv_0) easy - (FStar_Ident.lid_of_str "FStar.Tactics.V2.Logic.easy") + (FStarC_TypeChecker_NBETerm.arrow_as_prim_step_1 + (FStarC_TypeChecker_NBETerm.mk_any_emb tv_0) + (FStarC_TypeChecker_NBETerm.mk_any_emb tv_0) easy + (FStarC_Ident.lid_of_str "FStar.Tactics.V2.Logic.easy") cb us) args_tail | _ -> failwith "arity mismatch")) let (using_lemma : @@ -2402,68 +2404,68 @@ let (using_lemma : match () with | () -> pose_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; "Logic"; "Lemmas"; "lem1_fa"]))), - (t, FStar_Reflection_V2_Data.Q_Explicit))))) + (t, FStarC_Reflection_V2_Data.Q_Explicit))))) (fun uu___ -> FStar_Tactics_V2_Derived.try_with (fun uu___1 -> match () with | () -> pose_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; "Logic"; "Lemmas"; "lem2_fa"]))), - (t, FStar_Reflection_V2_Data.Q_Explicit))))) + (t, FStarC_Reflection_V2_Data.Q_Explicit))))) (fun uu___1 -> FStar_Tactics_V2_Derived.try_with (fun uu___2 -> match () with | () -> pose_lemma - (FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_App - ((FStar_Reflection_V2_Builtins.pack_ln - (FStar_Reflection_V2_Data.Tv_FVar - (FStar_Reflection_V2_Builtins.pack_fv + (FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_App + ((FStarC_Reflection_V2_Builtins.pack_ln + (FStarC_Reflection_V2_Data.Tv_FVar + (FStarC_Reflection_V2_Builtins.pack_fv ["FStar"; "Tactics"; "V1"; "Logic"; "Lemmas"; "lem3_fa"]))), - (t, FStar_Reflection_V2_Data.Q_Explicit))))) + (t, FStarC_Reflection_V2_Data.Q_Explicit))))) (fun uu___2 -> (fun uu___2 -> Obj.magic (FStar_Tactics_V2_Derived.fail "using_lemma: failed to instantiate")) uu___2))) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.using_lemma" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.Logic.using_lemma" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.Logic.using_lemma (plugin)" - (FStar_Tactics_Native.from_tactic_1 using_lemma) - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_binding psc ncb us args) \ No newline at end of file + (FStarC_Tactics_Native.from_tactic_1 using_lemma) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_binding psc ncb us args) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_V2_Primops.ml b/ocaml/fstar-lib/generated/FStar_Tactics_V2_Primops.ml deleted file mode 100644 index bc9ac60ee20..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Tactics_V2_Primops.ml +++ /dev/null @@ -1,2222 +0,0 @@ -open Prims -let solve : 'a . 'a -> 'a = fun ev -> ev -let (uu___0 : - FStar_Syntax_Syntax.term FStar_Syntax_Embeddings_Base.embedding) = - FStar_Reflection_V2_Embeddings.e_term -let unseal : - 'uuuuu 'a . - 'uuuuu -> 'a FStar_Compiler_Sealed.sealed -> 'a FStar_Tactics_Monad.tac - = - fun uu___1 -> - fun uu___ -> - (fun _typ -> - fun x -> - Obj.magic - (FStar_Class_Monad.return FStar_Tactics_Monad.monad_tac () - (Obj.magic (FStar_Compiler_Sealed.unseal x)))) uu___1 uu___ -let (unseal_step : FStar_TypeChecker_Primops_Base.primitive_step) = - let s = - FStar_Tactics_InterpFuns.mk_tac_step_2 Prims.int_one "unseal" - FStar_Syntax_Embeddings.e_any - (FStar_Syntax_Embeddings.e_sealed FStar_Syntax_Embeddings.e_any) - FStar_Syntax_Embeddings.e_any FStar_TypeChecker_NBETerm.e_any - (FStar_TypeChecker_NBETerm.e_sealed FStar_TypeChecker_NBETerm.e_any) - FStar_TypeChecker_NBETerm.e_any unseal unseal in - { - FStar_TypeChecker_Primops_Base.name = FStar_Parser_Const.unseal_lid; - FStar_TypeChecker_Primops_Base.arity = - (s.FStar_TypeChecker_Primops_Base.arity); - FStar_TypeChecker_Primops_Base.univ_arity = - (s.FStar_TypeChecker_Primops_Base.univ_arity); - FStar_TypeChecker_Primops_Base.auto_reflect = - (s.FStar_TypeChecker_Primops_Base.auto_reflect); - FStar_TypeChecker_Primops_Base.strong_reduction_ok = - (s.FStar_TypeChecker_Primops_Base.strong_reduction_ok); - FStar_TypeChecker_Primops_Base.requires_binder_substitution = - (s.FStar_TypeChecker_Primops_Base.requires_binder_substitution); - FStar_TypeChecker_Primops_Base.renorm_after = - (s.FStar_TypeChecker_Primops_Base.renorm_after); - FStar_TypeChecker_Primops_Base.interpretation = - (s.FStar_TypeChecker_Primops_Base.interpretation); - FStar_TypeChecker_Primops_Base.interpretation_nbe = - (s.FStar_TypeChecker_Primops_Base.interpretation_nbe) - } -let e_ret_t : - 'a . - 'a FStar_Syntax_Embeddings_Base.embedding -> - ('a FStar_Pervasives_Native.option * FStar_Tactics_V2_Basic.issues) - FStar_Syntax_Embeddings_Base.embedding - = - fun d -> - solve - (FStar_Syntax_Embeddings.e_tuple2 (FStar_Syntax_Embeddings.e_option d) - (FStar_Syntax_Embeddings.e_list FStar_Syntax_Embeddings.e_issue)) -let nbe_e_ret_t : - 'a . - 'a FStar_TypeChecker_NBETerm.embedding -> - ('a FStar_Pervasives_Native.option * FStar_Tactics_V2_Basic.issues) - FStar_TypeChecker_NBETerm.embedding - = - fun d -> - solve - (FStar_TypeChecker_NBETerm.e_tuple2 - (FStar_TypeChecker_NBETerm.e_option d) - (FStar_TypeChecker_NBETerm.e_list FStar_TypeChecker_NBETerm.e_issue)) -let (ops : FStar_TypeChecker_Primops_Base.primitive_step Prims.list) = - let uu___ = - FStar_Tactics_InterpFuns.mk_tot_step_1_psc Prims.int_zero "tracepoint" - FStar_Tactics_Embedding.e_proofstate FStar_Syntax_Embeddings.e_bool - FStar_Tactics_Embedding.e_proofstate_nbe - FStar_TypeChecker_NBETerm.e_bool - FStar_Tactics_Types.tracepoint_with_psc - FStar_Tactics_Types.tracepoint_with_psc in - let uu___1 = - let uu___2 = - FStar_Tactics_InterpFuns.mk_tot_step_2 Prims.int_zero - "set_proofstate_range" FStar_Tactics_Embedding.e_proofstate - FStar_Syntax_Embeddings.e_range FStar_Tactics_Embedding.e_proofstate - FStar_Tactics_Embedding.e_proofstate_nbe - FStar_TypeChecker_NBETerm.e_range - FStar_Tactics_Embedding.e_proofstate_nbe - FStar_Tactics_Types.set_proofstate_range - FStar_Tactics_Types.set_proofstate_range in - let uu___3 = - let uu___4 = - FStar_Tactics_InterpFuns.mk_tot_step_1 Prims.int_zero "incr_depth" - FStar_Tactics_Embedding.e_proofstate - FStar_Tactics_Embedding.e_proofstate - FStar_Tactics_Embedding.e_proofstate_nbe - FStar_Tactics_Embedding.e_proofstate_nbe - FStar_Tactics_Types.incr_depth FStar_Tactics_Types.incr_depth in - let uu___5 = - let uu___6 = - FStar_Tactics_InterpFuns.mk_tot_step_1 Prims.int_zero "decr_depth" - FStar_Tactics_Embedding.e_proofstate - FStar_Tactics_Embedding.e_proofstate - FStar_Tactics_Embedding.e_proofstate_nbe - FStar_Tactics_Embedding.e_proofstate_nbe - FStar_Tactics_Types.decr_depth FStar_Tactics_Types.decr_depth in - let uu___7 = - let uu___8 = - FStar_Tactics_InterpFuns.mk_tot_step_1 Prims.int_zero "goals_of" - FStar_Tactics_Embedding.e_proofstate - (FStar_Syntax_Embeddings.e_list FStar_Tactics_Embedding.e_goal) - FStar_Tactics_Embedding.e_proofstate_nbe - (FStar_TypeChecker_NBETerm.e_list - FStar_Tactics_Embedding.e_goal_nbe) - FStar_Tactics_Types.goals_of FStar_Tactics_Types.goals_of in - let uu___9 = - let uu___10 = - FStar_Tactics_InterpFuns.mk_tot_step_1 Prims.int_zero - "smt_goals_of" FStar_Tactics_Embedding.e_proofstate - (FStar_Syntax_Embeddings.e_list - FStar_Tactics_Embedding.e_goal) - FStar_Tactics_Embedding.e_proofstate_nbe - (FStar_TypeChecker_NBETerm.e_list - FStar_Tactics_Embedding.e_goal_nbe) - FStar_Tactics_Types.smt_goals_of - FStar_Tactics_Types.smt_goals_of in - let uu___11 = - let uu___12 = - FStar_Tactics_InterpFuns.mk_tot_step_1 Prims.int_zero - "goal_env" FStar_Tactics_Embedding.e_goal - FStar_Reflection_V2_Embeddings.e_env - FStar_Tactics_Embedding.e_goal_nbe - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_Tactics_Types.goal_env FStar_Tactics_Types.goal_env in - let uu___13 = - let uu___14 = - FStar_Tactics_InterpFuns.mk_tot_step_1 Prims.int_zero - "goal_type" FStar_Tactics_Embedding.e_goal uu___0 - FStar_Tactics_Embedding.e_goal_nbe - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Tactics_Types.goal_type - FStar_Tactics_Types.goal_type in - let uu___15 = - let uu___16 = - FStar_Tactics_InterpFuns.mk_tot_step_1 Prims.int_zero - "goal_witness" FStar_Tactics_Embedding.e_goal uu___0 - FStar_Tactics_Embedding.e_goal_nbe - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Tactics_Types.goal_witness - FStar_Tactics_Types.goal_witness in - let uu___17 = - let uu___18 = - FStar_Tactics_InterpFuns.mk_tot_step_1 Prims.int_zero - "is_guard" FStar_Tactics_Embedding.e_goal - FStar_Syntax_Embeddings.e_bool - FStar_Tactics_Embedding.e_goal_nbe - FStar_TypeChecker_NBETerm.e_bool - FStar_Tactics_Types.is_guard - FStar_Tactics_Types.is_guard in - let uu___19 = - let uu___20 = - FStar_Tactics_InterpFuns.mk_tot_step_1 Prims.int_zero - "get_label" FStar_Tactics_Embedding.e_goal - FStar_Syntax_Embeddings.e_string - FStar_Tactics_Embedding.e_goal_nbe - FStar_TypeChecker_NBETerm.e_string - FStar_Tactics_Types.get_label - FStar_Tactics_Types.get_label in - let uu___21 = - let uu___22 = - FStar_Tactics_InterpFuns.mk_tot_step_2 - Prims.int_zero "set_label" - FStar_Syntax_Embeddings.e_string - FStar_Tactics_Embedding.e_goal - FStar_Tactics_Embedding.e_goal - FStar_TypeChecker_NBETerm.e_string - FStar_Tactics_Embedding.e_goal_nbe - FStar_Tactics_Embedding.e_goal_nbe - FStar_Tactics_Types.set_label - FStar_Tactics_Types.set_label in - let uu___23 = - let uu___24 = - let uu___25 = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero "compress" uu___0 uu___0 - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Tactics_V2_Basic.compress - FStar_Tactics_V2_Basic.compress in - let uu___26 = - let uu___27 = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero "set_goals" - (FStar_Syntax_Embeddings.e_list - FStar_Tactics_Embedding.e_goal) - FStar_Syntax_Embeddings.e_unit - (FStar_TypeChecker_NBETerm.e_list - FStar_Tactics_Embedding.e_goal_nbe) - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_Monad.set_goals - FStar_Tactics_Monad.set_goals in - let uu___28 = - let uu___29 = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero "set_smt_goals" - (FStar_Syntax_Embeddings.e_list - FStar_Tactics_Embedding.e_goal) - FStar_Syntax_Embeddings.e_unit - (FStar_TypeChecker_NBETerm.e_list - FStar_Tactics_Embedding.e_goal_nbe) - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_Monad.set_smt_goals - FStar_Tactics_Monad.set_smt_goals in - let uu___30 = - let uu___31 = - let uu___32 = - FStar_Tactics_Interpreter.e_tactic_thunk - FStar_Syntax_Embeddings.e_any in - let uu___33 = - FStar_Tactics_Interpreter.e_tactic_nbe_thunk - FStar_TypeChecker_NBETerm.e_any in - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_one "catch" - FStar_Syntax_Embeddings.e_any uu___32 - (FStar_Syntax_Embeddings.e_either - FStar_Tactics_Embedding.e_exn - FStar_Syntax_Embeddings.e_any) - FStar_TypeChecker_NBETerm.e_any uu___33 - (FStar_TypeChecker_NBETerm.e_either - FStar_Tactics_Embedding.e_exn_nbe - FStar_TypeChecker_NBETerm.e_any) - (fun uu___34 -> - FStar_Tactics_Monad.catch) - (fun uu___34 -> - FStar_Tactics_Monad.catch) in - let uu___32 = - let uu___33 = - let uu___34 = - FStar_Tactics_Interpreter.e_tactic_thunk - FStar_Syntax_Embeddings.e_any in - let uu___35 = - FStar_Tactics_Interpreter.e_tactic_nbe_thunk - FStar_TypeChecker_NBETerm.e_any in - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_one "recover" - FStar_Syntax_Embeddings.e_any uu___34 - (FStar_Syntax_Embeddings.e_either - FStar_Tactics_Embedding.e_exn - FStar_Syntax_Embeddings.e_any) - FStar_TypeChecker_NBETerm.e_any - uu___35 - (FStar_TypeChecker_NBETerm.e_either - FStar_Tactics_Embedding.e_exn_nbe - FStar_TypeChecker_NBETerm.e_any) - (fun uu___36 -> - FStar_Tactics_Monad.recover) - (fun uu___36 -> - FStar_Tactics_Monad.recover) in - let uu___34 = - let uu___35 = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero "intro" - FStar_Syntax_Embeddings.e_unit - FStar_Reflection_V2_Embeddings.e_binding - FStar_TypeChecker_NBETerm.e_unit - FStar_Reflection_V2_NBEEmbeddings.e_binding - FStar_Tactics_V2_Basic.intro - FStar_Tactics_V2_Basic.intro in - let uu___36 = - let uu___37 = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero "intros" - FStar_Syntax_Embeddings.e_int - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_binding) - FStar_TypeChecker_NBETerm.e_int - (FStar_TypeChecker_NBETerm.e_list - FStar_Reflection_V2_NBEEmbeddings.e_binding) - FStar_Tactics_V2_Basic.intros - FStar_Tactics_V2_Basic.intros in - let uu___38 = - let uu___39 = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero "intro_rec" - FStar_Syntax_Embeddings.e_unit - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Reflection_V2_Embeddings.e_binding - FStar_Reflection_V2_Embeddings.e_binding) - FStar_TypeChecker_NBETerm.e_unit - (FStar_TypeChecker_NBETerm.e_tuple2 - FStar_Reflection_V2_NBEEmbeddings.e_binding - FStar_Reflection_V2_NBEEmbeddings.e_binding) - FStar_Tactics_V2_Basic.intro_rec - FStar_Tactics_V2_Basic.intro_rec in - let uu___40 = - let uu___41 = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero "norm" - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_norm_step) - FStar_Syntax_Embeddings.e_unit - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_norm_step) - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.norm - FStar_Tactics_V2_Basic.norm in - let uu___42 = - let uu___43 = - FStar_Tactics_InterpFuns.mk_tac_step_3 - Prims.int_zero - "norm_term_env" - FStar_Reflection_V2_Embeddings.e_env - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_norm_step) - uu___0 uu___0 - FStar_Reflection_V2_NBEEmbeddings.e_env - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_norm_step) - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Tactics_V2_Basic.norm_term_env - FStar_Tactics_V2_Basic.norm_term_env in - let uu___44 = - let uu___45 = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_zero - "norm_binding_type" - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_norm_step) - FStar_Reflection_V2_Embeddings.e_binding - FStar_Syntax_Embeddings.e_unit - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_norm_step) - FStar_Reflection_V2_NBEEmbeddings.e_binding - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.norm_binding_type - FStar_Tactics_V2_Basic.norm_binding_type in - let uu___46 = - let uu___47 = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_zero - "rename_to" - FStar_Reflection_V2_Embeddings.e_binding - FStar_Syntax_Embeddings.e_string - FStar_Reflection_V2_Embeddings.e_binding - FStar_Reflection_V2_NBEEmbeddings.e_binding - FStar_TypeChecker_NBETerm.e_string - FStar_Reflection_V2_NBEEmbeddings.e_binding - FStar_Tactics_V2_Basic.rename_to - FStar_Tactics_V2_Basic.rename_to in - let uu___48 = - let uu___49 = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "var_retype" - FStar_Reflection_V2_Embeddings.e_binding - FStar_Syntax_Embeddings.e_unit - FStar_Reflection_V2_NBEEmbeddings.e_binding - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.var_retype - FStar_Tactics_V2_Basic.var_retype in - let uu___50 = - let uu___51 = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "revert" - FStar_Syntax_Embeddings.e_unit - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_unit - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.revert - FStar_Tactics_V2_Basic.revert in - let uu___52 = - let uu___53 = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "clear_top" - FStar_Syntax_Embeddings.e_unit - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_unit - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.clear_top - FStar_Tactics_V2_Basic.clear_top in - let uu___54 = - let uu___55 = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "clear" - FStar_Reflection_V2_Embeddings.e_binding - FStar_Syntax_Embeddings.e_unit - FStar_Reflection_V2_NBEEmbeddings.e_binding - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.clear - FStar_Tactics_V2_Basic.clear in - let uu___56 = - let uu___57 = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "rewrite" - FStar_Reflection_V2_Embeddings.e_binding - FStar_Syntax_Embeddings.e_unit - FStar_Reflection_V2_NBEEmbeddings.e_binding - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.rewrite - FStar_Tactics_V2_Basic.rewrite in - let uu___58 = - let uu___59 = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_zero - "grewrite" - uu___0 - uu___0 - FStar_Syntax_Embeddings.e_unit - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.grewrite - FStar_Tactics_V2_Basic.grewrite in - let uu___60 = - let uu___61 = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "refine_intro" - FStar_Syntax_Embeddings.e_unit - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_unit - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.refine_intro - FStar_Tactics_V2_Basic.refine_intro in - let uu___62 = - let uu___63 - = - FStar_Tactics_InterpFuns.mk_tac_step_3 - Prims.int_zero - "t_exact" - FStar_Syntax_Embeddings.e_bool - FStar_Syntax_Embeddings.e_bool - uu___0 - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_bool - FStar_TypeChecker_NBETerm.e_bool - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.t_exact - FStar_Tactics_V2_Basic.t_exact in - let uu___64 - = - let uu___65 - = - FStar_Tactics_InterpFuns.mk_tac_step_4 - Prims.int_zero - "t_apply" - FStar_Syntax_Embeddings.e_bool - FStar_Syntax_Embeddings.e_bool - FStar_Syntax_Embeddings.e_bool - uu___0 - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_bool - FStar_TypeChecker_NBETerm.e_bool - FStar_TypeChecker_NBETerm.e_bool - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.t_apply - FStar_Tactics_V2_Basic.t_apply in - let uu___66 - = - let uu___67 - = - FStar_Tactics_InterpFuns.mk_tac_step_3 - Prims.int_zero - "t_apply_lemma" - FStar_Syntax_Embeddings.e_bool - FStar_Syntax_Embeddings.e_bool - uu___0 - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_bool - FStar_TypeChecker_NBETerm.e_bool - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.t_apply_lemma - FStar_Tactics_V2_Basic.t_apply_lemma in - let uu___68 - = - let uu___69 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "set_options" - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.set_options - FStar_Tactics_V2_Basic.set_options in - let uu___70 - = - let uu___71 - = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_zero - "tcc" - FStar_Reflection_V2_Embeddings.e_env - uu___0 - FStar_Reflection_V2_Embeddings.e_comp - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Reflection_V2_NBEEmbeddings.e_comp - FStar_Tactics_V2_Basic.tcc - FStar_Tactics_V2_Basic.tcc in - let uu___72 - = - let uu___73 - = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_zero - "tc" - FStar_Reflection_V2_Embeddings.e_env - uu___0 - uu___0 - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Tactics_V2_Basic.tc - FStar_Tactics_V2_Basic.tc in - let uu___74 - = - let uu___75 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "unshelve" - uu___0 - FStar_Syntax_Embeddings.e_unit - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.unshelve - FStar_Tactics_V2_Basic.unshelve in - let uu___76 - = - let uu___77 - = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_one - "unquote" - FStar_Syntax_Embeddings.e_any - FStar_Reflection_V2_Embeddings.e_term - FStar_Syntax_Embeddings.e_any - FStar_TypeChecker_NBETerm.e_any - FStar_Reflection_V2_NBEEmbeddings.e_term - FStar_TypeChecker_NBETerm.e_any - FStar_Tactics_V2_Basic.unquote - (fun - uu___78 - -> - fun - uu___79 - -> - failwith - "NBE unquote") in - let uu___78 - = - let uu___79 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "prune" - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.prune - FStar_Tactics_V2_Basic.prune in - let uu___80 - = - let uu___81 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "addns" - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.addns - FStar_Tactics_V2_Basic.addns in - let uu___82 - = - let uu___83 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "print" - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.print - FStar_Tactics_V2_Basic.print in - let uu___84 - = - let uu___85 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "debugging" - FStar_Syntax_Embeddings.e_unit - FStar_Syntax_Embeddings.e_bool - FStar_TypeChecker_NBETerm.e_unit - FStar_TypeChecker_NBETerm.e_bool - FStar_Tactics_V2_Basic.debugging - FStar_Tactics_V2_Basic.debugging in - let uu___86 - = - let uu___87 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "ide" - FStar_Syntax_Embeddings.e_unit - FStar_Syntax_Embeddings.e_bool - FStar_TypeChecker_NBETerm.e_unit - FStar_TypeChecker_NBETerm.e_bool - FStar_Tactics_V2_Basic.ide - FStar_Tactics_V2_Basic.ide in - let uu___88 - = - let uu___89 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "dump" - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.dump - FStar_Tactics_V2_Basic.dump in - let uu___90 - = - let uu___91 - = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_zero - "dump_all" - FStar_Syntax_Embeddings.e_bool - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_bool - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.dump_all - FStar_Tactics_V2_Basic.dump_all in - let uu___92 - = - let uu___93 - = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_zero - "dump_uvars_of" - FStar_Tactics_Embedding.e_goal - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_unit - FStar_Tactics_Embedding.e_goal_nbe - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.dump_uvars_of - FStar_Tactics_V2_Basic.dump_uvars_of in - let uu___94 - = - let uu___95 - = - let uu___96 - = - FStar_Tactics_Interpreter.e_tactic_1 - FStar_Reflection_V2_Embeddings.e_term - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Syntax_Embeddings.e_bool - FStar_Tactics_Embedding.e_ctrl_flag) in - let uu___97 - = - FStar_Tactics_Interpreter.e_tactic_thunk - FStar_Syntax_Embeddings.e_unit in - let uu___98 - = - FStar_Tactics_Interpreter.e_tactic_nbe_1 - FStar_Reflection_V2_NBEEmbeddings.e_term - (FStar_TypeChecker_NBETerm.e_tuple2 - FStar_TypeChecker_NBETerm.e_bool - FStar_Tactics_Embedding.e_ctrl_flag_nbe) in - let uu___99 - = - FStar_Tactics_Interpreter.e_tactic_nbe_thunk - FStar_TypeChecker_NBETerm.e_unit in - FStar_Tactics_InterpFuns.mk_tac_step_3 - Prims.int_zero - "ctrl_rewrite" - FStar_Tactics_Embedding.e_direction - uu___96 - uu___97 - FStar_Syntax_Embeddings.e_unit - FStar_Tactics_Embedding.e_direction_nbe - uu___98 - uu___99 - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_CtrlRewrite.ctrl_rewrite - FStar_Tactics_CtrlRewrite.ctrl_rewrite in - let uu___96 - = - let uu___97 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "t_trefl" - FStar_Syntax_Embeddings.e_bool - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_bool - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.t_trefl - FStar_Tactics_V2_Basic.t_trefl in - let uu___98 - = - let uu___99 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "dup" - FStar_Syntax_Embeddings.e_unit - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_unit - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.dup - FStar_Tactics_V2_Basic.dup in - let uu___100 - = - let uu___101 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "tadmit_t" - uu___0 - FStar_Syntax_Embeddings.e_unit - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.tadmit_t - FStar_Tactics_V2_Basic.tadmit_t in - let uu___102 - = - let uu___103 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "join" - FStar_Syntax_Embeddings.e_unit - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_unit - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.join - FStar_Tactics_V2_Basic.join in - let uu___104 - = - let uu___105 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "t_destruct" - uu___0 - (FStar_Syntax_Embeddings.e_list - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Reflection_V2_Embeddings.e_fv - FStar_Syntax_Embeddings.e_int)) - FStar_Reflection_V2_NBEEmbeddings.e_attribute - (FStar_TypeChecker_NBETerm.e_list - (FStar_TypeChecker_NBETerm.e_tuple2 - FStar_Reflection_V2_NBEEmbeddings.e_fv - FStar_TypeChecker_NBETerm.e_int)) - FStar_Tactics_V2_Basic.t_destruct - FStar_Tactics_V2_Basic.t_destruct in - let uu___106 - = - let uu___107 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "top_env" - FStar_Syntax_Embeddings.e_unit - FStar_Reflection_V2_Embeddings.e_env - FStar_TypeChecker_NBETerm.e_unit - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_Tactics_V2_Basic.top_env - FStar_Tactics_V2_Basic.top_env in - let uu___108 - = - let uu___109 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "fresh" - FStar_Syntax_Embeddings.e_unit - FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_unit - FStar_TypeChecker_NBETerm.e_int - FStar_Tactics_V2_Basic.fresh - FStar_Tactics_V2_Basic.fresh in - let uu___110 - = - let uu___111 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "curms" - FStar_Syntax_Embeddings.e_unit - FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_unit - FStar_TypeChecker_NBETerm.e_int - FStar_Tactics_V2_Basic.curms - FStar_Tactics_V2_Basic.curms in - let uu___112 - = - let uu___113 - = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_zero - "uvar_env" - FStar_Reflection_V2_Embeddings.e_env - (FStar_Syntax_Embeddings.e_option - uu___0) - uu___0 - FStar_Reflection_V2_NBEEmbeddings.e_env - (FStar_TypeChecker_NBETerm.e_option - FStar_Reflection_V2_NBEEmbeddings.e_attribute) - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Tactics_V2_Basic.uvar_env - FStar_Tactics_V2_Basic.uvar_env in - let uu___114 - = - let uu___115 - = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_zero - "ghost_uvar_env" - FStar_Reflection_V2_Embeddings.e_env - uu___0 - uu___0 - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Tactics_V2_Basic.ghost_uvar_env - FStar_Tactics_V2_Basic.ghost_uvar_env in - let uu___116 - = - let uu___117 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "fresh_universe_uvar" - FStar_Syntax_Embeddings.e_unit - uu___0 - FStar_TypeChecker_NBETerm.e_unit - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Tactics_V2_Basic.fresh_universe_uvar - FStar_Tactics_V2_Basic.fresh_universe_uvar in - let uu___118 - = - let uu___119 - = - FStar_Tactics_InterpFuns.mk_tac_step_3 - Prims.int_zero - "unify_env" - FStar_Reflection_V2_Embeddings.e_env - uu___0 - uu___0 - FStar_Syntax_Embeddings.e_bool - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_TypeChecker_NBETerm.e_bool - FStar_Tactics_V2_Basic.unify_env - FStar_Tactics_V2_Basic.unify_env in - let uu___120 - = - let uu___121 - = - FStar_Tactics_InterpFuns.mk_tac_step_3 - Prims.int_zero - "unify_guard_env" - FStar_Reflection_V2_Embeddings.e_env - uu___0 - uu___0 - FStar_Syntax_Embeddings.e_bool - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_TypeChecker_NBETerm.e_bool - FStar_Tactics_V2_Basic.unify_guard_env - FStar_Tactics_V2_Basic.unify_guard_env in - let uu___122 - = - let uu___123 - = - FStar_Tactics_InterpFuns.mk_tac_step_3 - Prims.int_zero - "match_env" - FStar_Reflection_V2_Embeddings.e_env - uu___0 - uu___0 - FStar_Syntax_Embeddings.e_bool - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_TypeChecker_NBETerm.e_bool - FStar_Tactics_V2_Basic.match_env - FStar_Tactics_V2_Basic.match_env in - let uu___124 - = - let uu___125 - = - FStar_Tactics_InterpFuns.mk_tac_step_3 - Prims.int_zero - "launch_process" - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_string_list - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_string_list - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_string - FStar_Tactics_V2_Basic.launch_process - FStar_Tactics_V2_Basic.launch_process in - let uu___126 - = - let uu___127 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "change" - uu___0 - FStar_Syntax_Embeddings.e_unit - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.change - FStar_Tactics_V2_Basic.change in - let uu___128 - = - let uu___129 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "get_guard_policy" - FStar_Syntax_Embeddings.e_unit - FStar_Tactics_Embedding.e_guard_policy - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_Embedding.e_guard_policy_nbe - FStar_Tactics_V2_Basic.get_guard_policy - FStar_Tactics_V2_Basic.get_guard_policy in - let uu___130 - = - let uu___131 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "set_guard_policy" - FStar_Tactics_Embedding.e_guard_policy - FStar_Syntax_Embeddings.e_unit - FStar_Tactics_Embedding.e_guard_policy_nbe - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.set_guard_policy - FStar_Tactics_V2_Basic.set_guard_policy in - let uu___132 - = - let uu___133 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "lax_on" - FStar_Syntax_Embeddings.e_unit - FStar_Syntax_Embeddings.e_bool - FStar_TypeChecker_NBETerm.e_unit - FStar_TypeChecker_NBETerm.e_bool - FStar_Tactics_V2_Basic.lax_on - FStar_Tactics_V2_Basic.lax_on in - let uu___134 - = - let uu___135 - = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_one - "lget" - FStar_Syntax_Embeddings.e_any - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_any - FStar_TypeChecker_NBETerm.e_any - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_any - FStar_Tactics_V2_Basic.lget - (fun - uu___136 - -> - fun - uu___137 - -> - FStar_Tactics_Monad.fail - "sorry, `lget` does not work in NBE") in - let uu___136 - = - let uu___137 - = - FStar_Tactics_InterpFuns.mk_tac_step_3 - Prims.int_one - "lset" - FStar_Syntax_Embeddings.e_any - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_any - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_any - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_any - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.lset - (fun - uu___138 - -> - fun - uu___139 - -> - fun - uu___140 - -> - FStar_Tactics_Monad.fail - "sorry, `lset` does not work in NBE") in - let uu___138 - = - let uu___139 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_one - "set_urgency" - FStar_Syntax_Embeddings.e_int - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_int - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.set_urgency - FStar_Tactics_V2_Basic.set_urgency in - let uu___140 - = - let uu___141 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_one - "set_dump_on_failure" - FStar_Syntax_Embeddings.e_bool - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_bool - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.set_dump_on_failure - FStar_Tactics_V2_Basic.set_dump_on_failure in - let uu___142 - = - let uu___143 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_one - "t_commute_applied_match" - FStar_Syntax_Embeddings.e_unit - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_unit - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.t_commute_applied_match - FStar_Tactics_V2_Basic.t_commute_applied_match in - let uu___144 - = - let uu___145 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "gather_or_solve_explicit_guards_for_resolved_goals" - FStar_Syntax_Embeddings.e_unit - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_unit - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.gather_explicit_guards_for_resolved_goals - FStar_Tactics_V2_Basic.gather_explicit_guards_for_resolved_goals in - let uu___146 - = - let uu___147 - = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_zero - "string_to_term" - FStar_Reflection_V2_Embeddings.e_env - FStar_Syntax_Embeddings.e_string - uu___0 - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_TypeChecker_NBETerm.e_string - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Tactics_V2_Basic.string_to_term - FStar_Tactics_V2_Basic.string_to_term in - let uu___148 - = - let uu___149 - = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_zero - "push_bv_dsenv" - FStar_Reflection_V2_Embeddings.e_env - FStar_Syntax_Embeddings.e_string - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Reflection_V2_Embeddings.e_env - FStar_Reflection_V2_Embeddings.e_binding) - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_TypeChecker_NBETerm.e_string - (FStar_TypeChecker_NBETerm.e_tuple2 - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_Reflection_V2_NBEEmbeddings.e_binding) - FStar_Tactics_V2_Basic.push_bv_dsenv - FStar_Tactics_V2_Basic.push_bv_dsenv in - let uu___150 - = - let uu___151 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "term_to_string" - uu___0 - FStar_Syntax_Embeddings.e_string - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_TypeChecker_NBETerm.e_string - FStar_Tactics_V2_Basic.term_to_string - FStar_Tactics_V2_Basic.term_to_string in - let uu___152 - = - let uu___153 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "comp_to_string" - FStar_Reflection_V2_Embeddings.e_comp - FStar_Syntax_Embeddings.e_string - FStar_Reflection_V2_NBEEmbeddings.e_comp - FStar_TypeChecker_NBETerm.e_string - FStar_Tactics_V2_Basic.comp_to_string - FStar_Tactics_V2_Basic.comp_to_string in - let uu___154 - = - let uu___155 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "term_to_doc" - uu___0 - FStar_Syntax_Embeddings.e_document - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_TypeChecker_NBETerm.e_document - FStar_Tactics_V2_Basic.term_to_doc - FStar_Tactics_V2_Basic.term_to_doc in - let uu___156 - = - let uu___157 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "comp_to_doc" - FStar_Reflection_V2_Embeddings.e_comp - FStar_Syntax_Embeddings.e_document - FStar_Reflection_V2_NBEEmbeddings.e_comp - FStar_TypeChecker_NBETerm.e_document - FStar_Tactics_V2_Basic.comp_to_doc - FStar_Tactics_V2_Basic.comp_to_doc in - let uu___158 - = - let uu___159 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "range_to_string" - FStar_Syntax_Embeddings.e_range - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_range - FStar_TypeChecker_NBETerm.e_string - FStar_Tactics_V2_Basic.range_to_string - FStar_Tactics_V2_Basic.range_to_string in - let uu___160 - = - let uu___161 - = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_zero - "term_eq_old" - uu___0 - uu___0 - FStar_Syntax_Embeddings.e_bool - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_TypeChecker_NBETerm.e_bool - FStar_Tactics_V2_Basic.term_eq_old - FStar_Tactics_V2_Basic.term_eq_old in - let uu___162 - = - let uu___163 - = - let uu___164 - = - FStar_Tactics_Interpreter.e_tactic_thunk - FStar_Syntax_Embeddings.e_any in - let uu___165 - = - FStar_Tactics_Interpreter.e_tactic_nbe_thunk - FStar_TypeChecker_NBETerm.e_any in - FStar_Tactics_InterpFuns.mk_tac_step_3 - Prims.int_one - "with_compat_pre_core" - FStar_Syntax_Embeddings.e_any - FStar_Syntax_Embeddings.e_int - uu___164 - FStar_Syntax_Embeddings.e_any - FStar_TypeChecker_NBETerm.e_any - FStar_TypeChecker_NBETerm.e_int - uu___165 - FStar_TypeChecker_NBETerm.e_any - (fun - uu___166 - -> - FStar_Tactics_V2_Basic.with_compat_pre_core) - (fun - uu___166 - -> - FStar_Tactics_V2_Basic.with_compat_pre_core) in - let uu___164 - = - let uu___165 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "get_vconfig" - FStar_Syntax_Embeddings.e_unit - FStar_Syntax_Embeddings.e_vconfig - FStar_TypeChecker_NBETerm.e_unit - FStar_TypeChecker_NBETerm.e_vconfig - FStar_Tactics_V2_Basic.get_vconfig - FStar_Tactics_V2_Basic.get_vconfig in - let uu___166 - = - let uu___167 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "set_vconfig" - FStar_Syntax_Embeddings.e_vconfig - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_vconfig - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.set_vconfig - FStar_Tactics_V2_Basic.set_vconfig in - let uu___168 - = - let uu___169 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "t_smt_sync" - FStar_Syntax_Embeddings.e_vconfig - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_vconfig - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.t_smt_sync - FStar_Tactics_V2_Basic.t_smt_sync in - let uu___170 - = - let uu___171 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "free_uvars" - uu___0 - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_int) - FStar_Reflection_V2_NBEEmbeddings.e_attribute - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_int) - FStar_Tactics_V2_Basic.free_uvars - FStar_Tactics_V2_Basic.free_uvars in - let uu___172 - = - let uu___173 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "all_ext_options" - FStar_Syntax_Embeddings.e_unit - (FStar_Syntax_Embeddings.e_list - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_string)) - FStar_TypeChecker_NBETerm.e_unit - (FStar_TypeChecker_NBETerm.e_list - (FStar_TypeChecker_NBETerm.e_tuple2 - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_string)) - FStar_Tactics_V2_Basic.all_ext_options - FStar_Tactics_V2_Basic.all_ext_options in - let uu___174 - = - let uu___175 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "ext_getv" - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_string - FStar_Tactics_V2_Basic.ext_getv - FStar_Tactics_V2_Basic.ext_getv in - let uu___176 - = - let uu___177 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "ext_getns" - FStar_Syntax_Embeddings.e_string - (FStar_Syntax_Embeddings.e_list - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_string)) - FStar_TypeChecker_NBETerm.e_string - (FStar_TypeChecker_NBETerm.e_list - (FStar_TypeChecker_NBETerm.e_tuple2 - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_string)) - FStar_Tactics_V2_Basic.ext_getns - FStar_Tactics_V2_Basic.ext_getns in - let uu___178 - = - let uu___179 - = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_one - "alloc" - FStar_Syntax_Embeddings.e_any - FStar_Syntax_Embeddings.e_any - (FStar_Tactics_Embedding.e_tref - ()) - FStar_TypeChecker_NBETerm.e_any - FStar_TypeChecker_NBETerm.e_any - (FStar_Tactics_Embedding.e_tref_nbe - ()) - (fun - uu___180 - -> - FStar_Tactics_V2_Basic.alloc) - (fun - uu___180 - -> - FStar_Tactics_V2_Basic.alloc) in - let uu___180 - = - let uu___181 - = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_one - "read" - FStar_Syntax_Embeddings.e_any - (FStar_Tactics_Embedding.e_tref - ()) - FStar_Syntax_Embeddings.e_any - FStar_TypeChecker_NBETerm.e_any - (FStar_Tactics_Embedding.e_tref_nbe - ()) - FStar_TypeChecker_NBETerm.e_any - (fun - uu___182 - -> - FStar_Tactics_V2_Basic.read) - (fun - uu___182 - -> - FStar_Tactics_V2_Basic.read) in - let uu___182 - = - let uu___183 - = - FStar_Tactics_InterpFuns.mk_tac_step_3 - Prims.int_one - "write" - FStar_Syntax_Embeddings.e_any - (FStar_Tactics_Embedding.e_tref - ()) - FStar_Syntax_Embeddings.e_any - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_any - (FStar_Tactics_Embedding.e_tref_nbe - ()) - FStar_TypeChecker_NBETerm.e_any - FStar_TypeChecker_NBETerm.e_unit - (fun - uu___184 - -> - FStar_Tactics_V2_Basic.write) - (fun - uu___184 - -> - FStar_Tactics_V2_Basic.write) in - let uu___184 - = - let uu___185 - = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_zero - "is_non_informative" - FStar_Reflection_V2_Embeddings.e_env - uu___0 - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_option - FStar_Syntax_Embeddings.e_unit) - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_issue)) - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_Reflection_V2_NBEEmbeddings.e_attribute - (FStar_TypeChecker_NBETerm.e_tuple2 - (FStar_TypeChecker_NBETerm.e_option - FStar_TypeChecker_NBETerm.e_unit) - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_issue)) - FStar_Tactics_V2_Basic.refl_is_non_informative - FStar_Tactics_V2_Basic.refl_is_non_informative in - let uu___186 - = - let uu___187 - = - FStar_Tactics_InterpFuns.mk_tac_step_3 - Prims.int_zero - "check_subtyping" - FStar_Reflection_V2_Embeddings.e_env - uu___0 - uu___0 - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_option - FStar_Syntax_Embeddings.e_unit) - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_issue)) - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Reflection_V2_NBEEmbeddings.e_attribute - (FStar_TypeChecker_NBETerm.e_tuple2 - (FStar_TypeChecker_NBETerm.e_option - FStar_TypeChecker_NBETerm.e_unit) - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_issue)) - FStar_Tactics_V2_Basic.refl_check_subtyping - FStar_Tactics_V2_Basic.refl_check_subtyping in - let uu___188 - = - let uu___189 - = - FStar_Tactics_InterpFuns.mk_tac_step_5 - Prims.int_zero - "t_check_equiv" - FStar_Syntax_Embeddings.e_bool - FStar_Syntax_Embeddings.e_bool - FStar_Reflection_V2_Embeddings.e_env - uu___0 - uu___0 - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_option - FStar_Syntax_Embeddings.e_unit) - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_issue)) - FStar_TypeChecker_NBETerm.e_bool - FStar_TypeChecker_NBETerm.e_bool - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Reflection_V2_NBEEmbeddings.e_attribute - (FStar_TypeChecker_NBETerm.e_tuple2 - (FStar_TypeChecker_NBETerm.e_option - FStar_TypeChecker_NBETerm.e_unit) - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_issue)) - FStar_Tactics_V2_Basic.t_refl_check_equiv - FStar_Tactics_V2_Basic.t_refl_check_equiv in - let uu___190 - = - let uu___191 - = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_zero - "core_compute_term_type" - FStar_Reflection_V2_Embeddings.e_env - uu___0 - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_option - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Tactics_Embedding.e_tot_or_ghost - uu___0)) - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_issue)) - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_Reflection_V2_NBEEmbeddings.e_attribute - (FStar_TypeChecker_NBETerm.e_tuple2 - (FStar_TypeChecker_NBETerm.e_option - (FStar_TypeChecker_NBETerm.e_tuple2 - FStar_Tactics_Embedding.e_tot_or_ghost_nbe - FStar_Reflection_V2_NBEEmbeddings.e_attribute)) - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_issue)) - FStar_Tactics_V2_Basic.refl_core_compute_term_type - FStar_Tactics_V2_Basic.refl_core_compute_term_type in - let uu___192 - = - let uu___193 - = - FStar_Tactics_InterpFuns.mk_tac_step_4 - Prims.int_zero - "core_check_term" - FStar_Reflection_V2_Embeddings.e_env - uu___0 - uu___0 - FStar_Tactics_Embedding.e_tot_or_ghost - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_option - FStar_Syntax_Embeddings.e_unit) - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_issue)) - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Tactics_Embedding.e_tot_or_ghost_nbe - (FStar_TypeChecker_NBETerm.e_tuple2 - (FStar_TypeChecker_NBETerm.e_option - FStar_TypeChecker_NBETerm.e_unit) - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_issue)) - FStar_Tactics_V2_Basic.refl_core_check_term - FStar_Tactics_V2_Basic.refl_core_check_term in - let uu___194 - = - let uu___195 - = - FStar_Tactics_InterpFuns.mk_tac_step_3 - Prims.int_zero - "core_check_term_at_type" - FStar_Reflection_V2_Embeddings.e_env - uu___0 - uu___0 - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_option - FStar_Tactics_Embedding.e_tot_or_ghost) - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_issue)) - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Reflection_V2_NBEEmbeddings.e_attribute - (FStar_TypeChecker_NBETerm.e_tuple2 - (FStar_TypeChecker_NBETerm.e_option - FStar_Tactics_Embedding.e_tot_or_ghost_nbe) - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_issue)) - FStar_Tactics_V2_Basic.refl_core_check_term_at_type - FStar_Tactics_V2_Basic.refl_core_check_term_at_type in - let uu___196 - = - let uu___197 - = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_zero - "tc_term" - FStar_Reflection_V2_Embeddings.e_env - uu___0 - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_option - (FStar_Syntax_Embeddings.e_tuple2 - uu___0 - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Tactics_Embedding.e_tot_or_ghost - uu___0))) - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_issue)) - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_Reflection_V2_NBEEmbeddings.e_attribute - (FStar_TypeChecker_NBETerm.e_tuple2 - (FStar_TypeChecker_NBETerm.e_option - (FStar_TypeChecker_NBETerm.e_tuple2 - FStar_Reflection_V2_NBEEmbeddings.e_attribute - (FStar_TypeChecker_NBETerm.e_tuple2 - FStar_Tactics_Embedding.e_tot_or_ghost_nbe - FStar_Reflection_V2_NBEEmbeddings.e_attribute))) - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_issue)) - FStar_Tactics_V2_Basic.refl_tc_term - FStar_Tactics_V2_Basic.refl_tc_term in - let uu___198 - = - let uu___199 - = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_zero - "universe_of" - FStar_Reflection_V2_Embeddings.e_env - uu___0 - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_option - FStar_Reflection_V2_Embeddings.e_universe) - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_issue)) - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_Reflection_V2_NBEEmbeddings.e_attribute - (FStar_TypeChecker_NBETerm.e_tuple2 - (FStar_TypeChecker_NBETerm.e_option - FStar_Reflection_V2_NBEEmbeddings.e_universe) - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_issue)) - FStar_Tactics_V2_Basic.refl_universe_of - FStar_Tactics_V2_Basic.refl_universe_of in - let uu___200 - = - let uu___201 - = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_zero - "check_prop_validity" - FStar_Reflection_V2_Embeddings.e_env - uu___0 - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_option - FStar_Syntax_Embeddings.e_unit) - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_issue)) - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_Reflection_V2_NBEEmbeddings.e_attribute - (FStar_TypeChecker_NBETerm.e_tuple2 - (FStar_TypeChecker_NBETerm.e_option - FStar_TypeChecker_NBETerm.e_unit) - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_issue)) - FStar_Tactics_V2_Basic.refl_check_prop_validity - FStar_Tactics_V2_Basic.refl_check_prop_validity in - let uu___202 - = - let uu___203 - = - FStar_Tactics_InterpFuns.mk_tac_step_4 - Prims.int_zero - "check_match_complete" - FStar_Reflection_V2_Embeddings.e_env - uu___0 - uu___0 - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_pattern) - (FStar_Syntax_Embeddings.e_option - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_pattern) - (FStar_Syntax_Embeddings.e_list - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_binding)))) - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Reflection_V2_NBEEmbeddings.e_attribute - (FStar_TypeChecker_NBETerm.e_list - FStar_Reflection_V2_NBEEmbeddings.e_pattern) - (FStar_TypeChecker_NBETerm.e_option - (FStar_TypeChecker_NBETerm.e_tuple2 - (FStar_TypeChecker_NBETerm.e_list - FStar_Reflection_V2_NBEEmbeddings.e_pattern) - (FStar_TypeChecker_NBETerm.e_list - (FStar_TypeChecker_NBETerm.e_list - FStar_Reflection_V2_NBEEmbeddings.e_binding)))) - FStar_Tactics_V2_Basic.refl_check_match_complete - FStar_Tactics_V2_Basic.refl_check_match_complete in - let uu___204 - = - let uu___205 - = - let uu___206 - = - e_ret_t - (FStar_Syntax_Embeddings.e_tuple3 - (FStar_Syntax_Embeddings.e_list - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Reflection_V2_Embeddings.e_namedv - (solve - uu___0))) - (solve - uu___0) - (solve - uu___0)) in - let uu___207 - = - nbe_e_ret_t - (FStar_TypeChecker_NBETerm.e_tuple3 - (FStar_TypeChecker_NBETerm.e_list - (FStar_TypeChecker_NBETerm.e_tuple2 - FStar_Reflection_V2_NBEEmbeddings.e_namedv - (solve - FStar_Reflection_V2_NBEEmbeddings.e_attribute))) - (solve - FStar_Reflection_V2_NBEEmbeddings.e_attribute) - (solve - FStar_Reflection_V2_NBEEmbeddings.e_attribute)) in - FStar_Tactics_InterpFuns.mk_tac_step_3 - Prims.int_zero - "instantiate_implicits" - FStar_Reflection_V2_Embeddings.e_env - uu___0 - (FStar_Syntax_Embeddings.e_option - uu___0) - uu___206 - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_Reflection_V2_NBEEmbeddings.e_attribute - (FStar_TypeChecker_NBETerm.e_option - FStar_Reflection_V2_NBEEmbeddings.e_attribute) - uu___207 - FStar_Tactics_V2_Basic.refl_instantiate_implicits - FStar_Tactics_V2_Basic.refl_instantiate_implicits in - let uu___206 - = - let uu___207 - = - let uu___208 - = - e_ret_t - (FStar_Syntax_Embeddings.e_list - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Reflection_V2_Embeddings.e_namedv - FStar_Reflection_V2_Embeddings.e_term)) in - let uu___209 - = - nbe_e_ret_t - (FStar_TypeChecker_NBETerm.e_list - (FStar_TypeChecker_NBETerm.e_tuple2 - FStar_Reflection_V2_NBEEmbeddings.e_namedv - FStar_Reflection_V2_NBEEmbeddings.e_term)) in - FStar_Tactics_InterpFuns.mk_tac_step_4 - Prims.int_zero - "try_unify" - FStar_Reflection_V2_Embeddings.e_env - (FStar_Syntax_Embeddings.e_list - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Reflection_V2_Embeddings.e_namedv - FStar_Reflection_V2_Embeddings.e_term)) - uu___0 - uu___0 - uu___208 - FStar_Reflection_V2_NBEEmbeddings.e_env - (FStar_TypeChecker_NBETerm.e_list - (FStar_TypeChecker_NBETerm.e_tuple2 - FStar_Reflection_V2_NBEEmbeddings.e_namedv - FStar_Reflection_V2_NBEEmbeddings.e_term)) - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Reflection_V2_NBEEmbeddings.e_attribute - uu___209 - FStar_Tactics_V2_Basic.refl_try_unify - FStar_Tactics_V2_Basic.refl_try_unify in - let uu___208 - = - let uu___209 - = - FStar_Tactics_InterpFuns.mk_tac_step_3 - Prims.int_zero - "maybe_relate_after_unfolding" - FStar_Reflection_V2_Embeddings.e_env - uu___0 - uu___0 - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_option - FStar_Tactics_Embedding.e_unfold_side) - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_issue)) - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Reflection_V2_NBEEmbeddings.e_attribute - (FStar_TypeChecker_NBETerm.e_tuple2 - (FStar_TypeChecker_NBETerm.e_option - FStar_Tactics_Embedding.e_unfold_side_nbe) - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_issue)) - FStar_Tactics_V2_Basic.refl_maybe_relate_after_unfolding - FStar_Tactics_V2_Basic.refl_maybe_relate_after_unfolding in - let uu___210 - = - let uu___211 - = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_zero - "maybe_unfold_head" - FStar_Reflection_V2_Embeddings.e_env - uu___0 - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_option - uu___0) - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_issue)) - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_Reflection_V2_NBEEmbeddings.e_attribute - (FStar_TypeChecker_NBETerm.e_tuple2 - (FStar_TypeChecker_NBETerm.e_option - FStar_Reflection_V2_NBEEmbeddings.e_attribute) - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_issue)) - FStar_Tactics_V2_Basic.refl_maybe_unfold_head - FStar_Tactics_V2_Basic.refl_maybe_unfold_head in - let uu___212 - = - let uu___213 - = - FStar_Tactics_InterpFuns.mk_tac_step_3 - Prims.int_zero - "norm_well_typed_term" - FStar_Reflection_V2_Embeddings.e_env - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_norm_step) - uu___0 - uu___0 - FStar_Reflection_V2_NBEEmbeddings.e_env - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_norm_step) - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Tactics_V2_Basic.refl_norm_well_typed_term - FStar_Tactics_V2_Basic.refl_norm_well_typed_term in - let uu___214 - = - let uu___215 - = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_zero - "push_open_namespace" - FStar_Reflection_V2_Embeddings.e_env - FStar_Syntax_Embeddings.e_string_list - FStar_Reflection_V2_Embeddings.e_env - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_TypeChecker_NBETerm.e_string_list - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_Tactics_V2_Basic.push_open_namespace - FStar_Tactics_V2_Basic.push_open_namespace in - let uu___216 - = - let uu___217 - = - FStar_Tactics_InterpFuns.mk_tac_step_3 - Prims.int_zero - "push_module_abbrev" - FStar_Reflection_V2_Embeddings.e_env - FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_string_list - FStar_Reflection_V2_Embeddings.e_env - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_string_list - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_Tactics_V2_Basic.push_module_abbrev - FStar_Tactics_V2_Basic.push_module_abbrev in - let uu___218 - = - let uu___219 - = - FStar_Tactics_InterpFuns.mk_tac_step_2 - Prims.int_zero - "resolve_name" - FStar_Reflection_V2_Embeddings.e_env - FStar_Syntax_Embeddings.e_string_list - (FStar_Syntax_Embeddings.e_option - (FStar_Syntax_Embeddings.e_either - FStar_Reflection_V2_Embeddings.e_bv - (solve - FStar_Reflection_V2_Embeddings.e_fv))) - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_TypeChecker_NBETerm.e_string_list - (FStar_TypeChecker_NBETerm.e_option - (FStar_TypeChecker_NBETerm.e_either - FStar_Reflection_V2_NBEEmbeddings.e_bv - (solve - FStar_Reflection_V2_NBEEmbeddings.e_fv))) - FStar_Tactics_V2_Basic.resolve_name - FStar_Tactics_V2_Basic.resolve_name in - let uu___220 - = - let uu___221 - = - FStar_Tactics_InterpFuns.mk_tac_step_1 - Prims.int_zero - "log_issues" - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_issue) - FStar_Syntax_Embeddings.e_unit - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_issue) - FStar_TypeChecker_NBETerm.e_unit - FStar_Tactics_V2_Basic.log_issues - FStar_Tactics_V2_Basic.log_issues in - let uu___222 - = - let uu___223 - = - let uu___224 - = - FStar_Tactics_Interpreter.e_tactic_thunk - FStar_Syntax_Embeddings.e_unit in - let uu___225 - = - FStar_Tactics_Interpreter.e_tactic_nbe_thunk - FStar_TypeChecker_NBETerm.e_unit in - FStar_Tactics_InterpFuns.mk_tac_step_4 - Prims.int_zero - "call_subtac" - FStar_Reflection_V2_Embeddings.e_env - uu___224 - FStar_Reflection_V2_Embeddings.e_universe - uu___0 - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_option - uu___0) - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_issue)) - FStar_Reflection_V2_NBEEmbeddings.e_env - uu___225 - FStar_Reflection_V2_NBEEmbeddings.e_universe - FStar_Reflection_V2_NBEEmbeddings.e_attribute - (FStar_TypeChecker_NBETerm.e_tuple2 - (FStar_TypeChecker_NBETerm.e_option - FStar_Reflection_V2_NBEEmbeddings.e_attribute) - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_issue)) - FStar_Tactics_V2_Basic.call_subtac - FStar_Tactics_V2_Basic.call_subtac in - let uu___224 - = - let uu___225 - = - FStar_Tactics_InterpFuns.mk_tac_step_4 - Prims.int_zero - "call_subtac_tm" - FStar_Reflection_V2_Embeddings.e_env - uu___0 - FStar_Reflection_V2_Embeddings.e_universe - uu___0 - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_option - uu___0) - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_issue)) - FStar_Reflection_V2_NBEEmbeddings.e_env - FStar_Reflection_V2_NBEEmbeddings.e_attribute - FStar_Reflection_V2_NBEEmbeddings.e_universe - FStar_Reflection_V2_NBEEmbeddings.e_attribute - (FStar_TypeChecker_NBETerm.e_tuple2 - (FStar_TypeChecker_NBETerm.e_option - FStar_Reflection_V2_NBEEmbeddings.e_attribute) - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_issue)) - FStar_Tactics_V2_Basic.call_subtac_tm - FStar_Tactics_V2_Basic.call_subtac_tm in - [uu___225] in - uu___223 - :: - uu___224 in - uu___221 - :: - uu___222 in - uu___219 - :: - uu___220 in - uu___217 - :: - uu___218 in - uu___215 - :: - uu___216 in - uu___213 - :: - uu___214 in - uu___211 - :: - uu___212 in - uu___209 - :: - uu___210 in - uu___207 - :: - uu___208 in - uu___205 - :: - uu___206 in - uu___203 - :: - uu___204 in - uu___201 - :: - uu___202 in - uu___199 - :: - uu___200 in - uu___197 - :: - uu___198 in - uu___195 - :: - uu___196 in - uu___193 - :: - uu___194 in - uu___191 - :: - uu___192 in - uu___189 - :: - uu___190 in - uu___187 - :: - uu___188 in - uu___185 - :: - uu___186 in - uu___183 - :: - uu___184 in - uu___181 - :: - uu___182 in - uu___179 - :: - uu___180 in - uu___177 - :: - uu___178 in - uu___175 - :: - uu___176 in - uu___173 - :: - uu___174 in - uu___171 - :: - uu___172 in - uu___169 - :: - uu___170 in - uu___167 - :: - uu___168 in - uu___165 - :: - uu___166 in - uu___163 - :: - uu___164 in - uu___161 - :: - uu___162 in - uu___159 - :: - uu___160 in - uu___157 - :: - uu___158 in - uu___155 - :: - uu___156 in - uu___153 - :: - uu___154 in - uu___151 - :: - uu___152 in - uu___149 - :: - uu___150 in - uu___147 - :: - uu___148 in - uu___145 - :: - uu___146 in - uu___143 - :: - uu___144 in - uu___141 - :: - uu___142 in - uu___139 - :: - uu___140 in - uu___137 - :: - uu___138 in - uu___135 - :: - uu___136 in - uu___133 - :: - uu___134 in - uu___131 - :: - uu___132 in - uu___129 - :: - uu___130 in - uu___127 - :: - uu___128 in - uu___125 - :: - uu___126 in - uu___123 - :: - uu___124 in - uu___121 - :: - uu___122 in - uu___119 - :: - uu___120 in - uu___117 - :: - uu___118 in - uu___115 - :: - uu___116 in - uu___113 - :: - uu___114 in - uu___111 - :: - uu___112 in - uu___109 - :: - uu___110 in - uu___107 - :: - uu___108 in - uu___105 - :: - uu___106 in - uu___103 - :: - uu___104 in - uu___101 - :: - uu___102 in - uu___99 - :: - uu___100 in - uu___97 - :: - uu___98 in - uu___95 - :: - uu___96 in - uu___93 - :: - uu___94 in - uu___91 - :: - uu___92 in - uu___89 - :: - uu___90 in - uu___87 - :: - uu___88 in - uu___85 - :: - uu___86 in - uu___83 - :: - uu___84 in - uu___81 - :: - uu___82 in - uu___79 - :: - uu___80 in - uu___77 - :: - uu___78 in - uu___75 - :: - uu___76 in - uu___73 - :: - uu___74 in - uu___71 - :: - uu___72 in - uu___69 - :: - uu___70 in - uu___67 - :: - uu___68 in - uu___65 - :: - uu___66 in - uu___63 :: - uu___64 in - uu___61 :: - uu___62 in - uu___59 :: - uu___60 in - uu___57 :: - uu___58 in - uu___55 :: uu___56 in - uu___53 :: uu___54 in - uu___51 :: uu___52 in - uu___49 :: uu___50 in - uu___47 :: uu___48 in - uu___45 :: uu___46 in - uu___43 :: uu___44 in - uu___41 :: uu___42 in - uu___39 :: uu___40 in - uu___37 :: uu___38 in - uu___35 :: uu___36 in - uu___33 :: uu___34 in - uu___31 :: uu___32 in - uu___29 :: uu___30 in - uu___27 :: uu___28 in - uu___25 :: uu___26 in - unseal_step :: uu___24 in - uu___22 :: uu___23 in - uu___20 :: uu___21 in - uu___18 :: uu___19 in - uu___16 :: uu___17 in - uu___14 :: uu___15 in - uu___12 :: uu___13 in - uu___10 :: uu___11 in - uu___8 :: uu___9 in - uu___6 :: uu___7 in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - uu___ :: uu___1 \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_V2_SyntaxCoercions.ml b/ocaml/fstar-lib/generated/FStar_Tactics_V2_SyntaxCoercions.ml index 360a884bedf..4b8b9c1077b 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_V2_SyntaxCoercions.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_V2_SyntaxCoercions.ml @@ -6,10 +6,10 @@ let (binder_to_namedv : FStar_Tactics_NamedView.binder -> FStar_Tactics_NamedView.namedv) = fun b -> { - FStar_Reflection_V2_Data.uniq = (b.FStar_Tactics_NamedView.uniq); - FStar_Reflection_V2_Data.sort = + FStarC_Reflection_V2_Data.uniq = (b.FStar_Tactics_NamedView.uniq); + FStarC_Reflection_V2_Data.sort = (FStar_Sealed.seal b.FStar_Tactics_NamedView.sort); - FStar_Reflection_V2_Data.ppname = (b.FStar_Tactics_NamedView.ppname) + FStarC_Reflection_V2_Data.ppname = (b.FStar_Tactics_NamedView.ppname) } let (binder_to_term : FStar_Tactics_NamedView.binder -> FStar_Tactics_NamedView.term) = @@ -20,10 +20,11 @@ let (binding_to_namedv : FStar_Tactics_NamedView.binding -> FStar_Tactics_NamedView.namedv) = fun b -> { - FStar_Reflection_V2_Data.uniq = (b.FStar_Reflection_V2_Data.uniq1); - FStar_Reflection_V2_Data.sort = - (FStar_Sealed.seal b.FStar_Reflection_V2_Data.sort3); - FStar_Reflection_V2_Data.ppname = (b.FStar_Reflection_V2_Data.ppname3) + FStarC_Reflection_V2_Data.uniq = (b.FStarC_Reflection_V2_Data.uniq1); + FStarC_Reflection_V2_Data.sort = + (FStar_Sealed.seal b.FStarC_Reflection_V2_Data.sort3); + FStarC_Reflection_V2_Data.ppname = + (b.FStarC_Reflection_V2_Data.ppname3) } let (binding_to_term : FStar_Tactics_NamedView.binding -> FStar_Tactics_NamedView.term) = diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_V2_SyntaxHelpers.ml b/ocaml/fstar-lib/generated/FStar_Tactics_V2_SyntaxHelpers.ml index 5ac08771b55..d449deef000 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_V2_SyntaxHelpers.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_V2_SyntaxHelpers.ml @@ -11,7 +11,7 @@ let rec (collect_arr' : (fun bs -> fun c -> match c with - | FStar_Reflection_V2_Data.C_Total t -> + | FStarC_Reflection_V2_Data.C_Total t -> Obj.magic (Obj.repr (let uu___ = FStar_Tactics_NamedView.inspect t in @@ -46,13 +46,13 @@ let rec (collect_arr' : (FStar_Tactics_Effect.lift_div_tac (fun uu___1 -> (bs, c))))) uu___1 uu___ let (collect_arr_bs : - FStar_Reflection_Types.typ -> + FStarC_Reflection_Types.typ -> ((FStar_Tactics_NamedView.binder Prims.list * FStar_Tactics_NamedView.comp), unit) FStar_Tactics_Effect.tac_repr) = fun t -> - let uu___ = collect_arr' [] (FStar_Reflection_V2_Data.C_Total t) in + let uu___ = collect_arr' [] (FStarC_Reflection_V2_Data.C_Total t) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -70,27 +70,28 @@ let (collect_arr_bs : match uu___1 with | (bs, c) -> ((FStar_List_Tot_Base.rev bs), c))) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.SyntaxHelpers.collect_arr_bs" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.SyntaxHelpers.collect_arr_bs (plugin)" - (FStar_Tactics_Native.from_tactic_1 collect_arr_bs) - FStar_Reflection_V2_Embeddings.e_term - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_list + (FStarC_Tactics_Native.from_tactic_1 collect_arr_bs) + FStarC_Reflection_V2_Embeddings.e_term + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_list FStar_Tactics_NamedView.e_binder) - FStar_Reflection_V2_Embeddings.e_comp_view) psc ncb us args) + FStarC_Reflection_V2_Embeddings.e_comp_view) psc ncb us + args) let (collect_arr : - FStar_Reflection_Types.typ -> - ((FStar_Reflection_Types.typ Prims.list * FStar_Tactics_NamedView.comp), + FStarC_Reflection_Types.typ -> + ((FStarC_Reflection_Types.typ Prims.list * FStar_Tactics_NamedView.comp), unit) FStar_Tactics_Effect.tac_repr) = fun t -> - let uu___ = collect_arr' [] (FStar_Reflection_V2_Data.C_Total t) in + let uu___ = collect_arr' [] (FStarC_Reflection_V2_Data.C_Total t) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -111,20 +112,21 @@ let (collect_arr : (FStar_List_Tot_Base.map (fun b -> b.FStar_Tactics_NamedView.sort) bs)), c))) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.SyntaxHelpers.collect_arr" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.SyntaxHelpers.collect_arr (plugin)" - (FStar_Tactics_Native.from_tactic_1 collect_arr) - FStar_Reflection_V2_Embeddings.e_term - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_term) - FStar_Reflection_V2_Embeddings.e_comp_view) psc ncb us args) + (FStarC_Tactics_Native.from_tactic_1 collect_arr) + FStarC_Reflection_V2_Embeddings.e_term + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_term) + FStarC_Reflection_V2_Embeddings.e_comp_view) psc ncb us + args) let rec (collect_abs' : FStar_Tactics_NamedView.binder Prims.list -> FStar_Tactics_NamedView.term -> @@ -181,27 +183,27 @@ let (collect_abs : match uu___1 with | (bs, t') -> ((FStar_List_Tot_Base.rev bs), t'))) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.SyntaxHelpers.collect_abs" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.SyntaxHelpers.collect_abs (plugin)" - (FStar_Tactics_Native.from_tactic_1 collect_abs) - FStar_Reflection_V2_Embeddings.e_term - (FStar_Syntax_Embeddings.e_tuple2 - (FStar_Syntax_Embeddings.e_list + (FStarC_Tactics_Native.from_tactic_1 collect_abs) + FStarC_Reflection_V2_Embeddings.e_term + (FStarC_Syntax_Embeddings.e_tuple2 + (FStarC_Syntax_Embeddings.e_list FStar_Tactics_NamedView.e_binder) - FStar_Reflection_V2_Embeddings.e_term) psc ncb us args) + FStarC_Reflection_V2_Embeddings.e_term) psc ncb us args) let fail : 'a . Prims.string -> ('a, unit) FStar_Tactics_Effect.tac_repr = fun uu___ -> (fun m -> Obj.magic (FStar_Tactics_Effect.raise - (FStar_Tactics_Common.TacticFailure - ((FStar_Errors_Msg.mkmsg m), FStar_Pervasives_Native.None)))) + (FStarC_Tactics_Common.TacticFailure + ((FStarC_Errors_Msg.mkmsg m), FStar_Pervasives_Native.None)))) uu___ let rec (mk_arr : FStar_Tactics_NamedView.binder Prims.list -> @@ -244,7 +246,7 @@ let rec (mk_arr : (fun uu___3 -> FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> - FStar_Reflection_V2_Data.C_Total uu___3)) in + FStarC_Reflection_V2_Data.C_Total uu___3)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -281,19 +283,19 @@ let rec (mk_arr : FStar_Tactics_NamedView.pack uu___1))))) uu___1 uu___ let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.SyntaxHelpers.mk_arr" (Prims.of_int (3)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_2 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_2 "FStar.Tactics.V2.SyntaxHelpers.mk_arr (plugin)" - (FStar_Tactics_Native.from_tactic_2 mk_arr) - (FStar_Syntax_Embeddings.e_list + (FStarC_Tactics_Native.from_tactic_2 mk_arr) + (FStarC_Syntax_Embeddings.e_list FStar_Tactics_NamedView.e_binder) - FStar_Reflection_V2_Embeddings.e_comp_view - FStar_Reflection_V2_Embeddings.e_term psc ncb us args) + FStarC_Reflection_V2_Embeddings.e_comp_view + FStarC_Reflection_V2_Embeddings.e_term psc ncb us args) let rec (mk_tot_arr : FStar_Tactics_NamedView.binder Prims.list -> FStar_Tactics_NamedView.term -> @@ -331,7 +333,7 @@ let rec (mk_tot_arr : (fun uu___3 -> FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> - FStar_Reflection_V2_Data.C_Total uu___3)) in + FStarC_Reflection_V2_Data.C_Total uu___3)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -368,22 +370,22 @@ let rec (mk_tot_arr : FStar_Tactics_NamedView.pack uu___1))))) uu___1 uu___ let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.SyntaxHelpers.mk_tot_arr" (Prims.of_int (3)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_2 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_2 "FStar.Tactics.V2.SyntaxHelpers.mk_tot_arr (plugin)" - (FStar_Tactics_Native.from_tactic_2 mk_tot_arr) - (FStar_Syntax_Embeddings.e_list + (FStarC_Tactics_Native.from_tactic_2 mk_tot_arr) + (FStarC_Syntax_Embeddings.e_list FStar_Tactics_NamedView.e_binder) - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_term psc ncb us args) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_term psc ncb us args) let (lookup_lb : FStar_Tactics_NamedView.letbinding Prims.list -> - FStar_Reflection_Types.name -> + FStarC_Reflection_Types.name -> (FStar_Tactics_NamedView.letbinding, unit) FStar_Tactics_Effect.tac_repr) = @@ -395,7 +397,7 @@ let (lookup_lb : (fun uu___1 -> FStar_List_Tot_Base.find (fun lb -> - (FStar_Reflection_V2_Builtins.inspect_fv + (FStarC_Reflection_V2_Builtins.inspect_fv lb.FStar_Tactics_NamedView.lb_fv) = nm) lbs)) in FStar_Tactics_Effect.tac_bind @@ -422,19 +424,19 @@ let (lookup_lb : (fail "lookup_letbinding: Name not in let group"))) uu___1) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.SyntaxHelpers.lookup_lb" (Prims.of_int (3)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_2 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_2 "FStar.Tactics.V2.SyntaxHelpers.lookup_lb (plugin)" - (FStar_Tactics_Native.from_tactic_2 lookup_lb) - (FStar_Syntax_Embeddings.e_list + (FStarC_Tactics_Native.from_tactic_2 lookup_lb) + (FStarC_Syntax_Embeddings.e_list FStar_Tactics_NamedView.e_letbinding) - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_string) + (FStarC_Syntax_Embeddings.e_list + FStarC_Syntax_Embeddings.e_string) FStar_Tactics_NamedView.e_letbinding psc ncb us args) let rec (inspect_unascribe : FStar_Tactics_NamedView.term -> @@ -468,21 +470,21 @@ let rec (inspect_unascribe : (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> tv)))) uu___1) let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.SyntaxHelpers.inspect_unascribe" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.SyntaxHelpers.inspect_unascribe (plugin)" - (FStar_Tactics_Native.from_tactic_1 inspect_unascribe) - FStar_Reflection_V2_Embeddings.e_term + (FStarC_Tactics_Native.from_tactic_1 inspect_unascribe) + FStarC_Reflection_V2_Embeddings.e_term FStar_Tactics_NamedView.e_named_term_view psc ncb us args) let rec (collect_app' : - FStar_Reflection_V2_Data.argv Prims.list -> + FStarC_Reflection_V2_Data.argv Prims.list -> FStar_Tactics_NamedView.term -> - ((FStar_Tactics_NamedView.term * FStar_Reflection_V2_Data.argv + ((FStar_Tactics_NamedView.term * FStarC_Reflection_V2_Data.argv Prims.list), unit) FStar_Tactics_Effect.tac_repr) = @@ -512,32 +514,32 @@ let rec (collect_app' : (fun uu___3 -> (t, args))))) uu___1) let (collect_app : FStar_Tactics_NamedView.term -> - ((FStar_Tactics_NamedView.term * FStar_Reflection_V2_Data.argv + ((FStar_Tactics_NamedView.term * FStarC_Reflection_V2_Data.argv Prims.list), unit) FStar_Tactics_Effect.tac_repr) = collect_app' [] let _ = - FStar_Tactics_Native.register_tactic + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.SyntaxHelpers.collect_app" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.SyntaxHelpers.collect_app (plugin)" - (FStar_Tactics_Native.from_tactic_1 collect_app) - FStar_Reflection_V2_Embeddings.e_term - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Reflection_V2_Embeddings.e_term - (FStar_Syntax_Embeddings.e_list - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_aqualv))) psc ncb us - args) + (FStarC_Tactics_Native.from_tactic_1 collect_app) + FStarC_Reflection_V2_Embeddings.e_term + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Reflection_V2_Embeddings.e_term + (FStarC_Syntax_Embeddings.e_list + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_aqualv))) psc ncb + us args) let (hua : FStar_Tactics_NamedView.term -> - ((FStar_Reflection_Types.fv * FStar_Reflection_V2_Data.universes * - FStar_Reflection_V2_Data.argv Prims.list) + ((FStarC_Reflection_Types.fv * FStarC_Reflection_V2_Data.universes * + FStarC_Reflection_V2_Data.argv Prims.list) FStar_Pervasives_Native.option, unit) FStar_Tactics_Effect.tac_repr) = @@ -585,23 +587,23 @@ let (hua : | uu___5 -> FStar_Pervasives_Native.None)))) uu___1) let _ = - FStar_Tactics_Native.register_tactic "FStar.Tactics.V2.SyntaxHelpers.hua" + FStarC_Tactics_Native.register_tactic "FStar.Tactics.V2.SyntaxHelpers.hua" (Prims.of_int (2)) (fun psc -> fun ncb -> fun us -> fun args -> - FStar_Tactics_InterpFuns.mk_tactic_interpretation_1 + FStarC_Tactics_InterpFuns.mk_tactic_interpretation_1 "FStar.Tactics.V2.SyntaxHelpers.hua (plugin)" - (FStar_Tactics_Native.from_tactic_1 hua) - FStar_Reflection_V2_Embeddings.e_term - (FStar_Syntax_Embeddings.e_option - (FStar_Syntax_Embeddings.e_tuple3 - FStar_Reflection_V2_Embeddings.e_fv - (FStar_Syntax_Embeddings.e_list - FStar_Reflection_V2_Embeddings.e_universe) - (FStar_Syntax_Embeddings.e_list - (FStar_Syntax_Embeddings.e_tuple2 - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_aqualv)))) psc + (FStarC_Tactics_Native.from_tactic_1 hua) + FStarC_Reflection_V2_Embeddings.e_term + (FStarC_Syntax_Embeddings.e_option + (FStarC_Syntax_Embeddings.e_tuple3 + FStarC_Reflection_V2_Embeddings.e_fv + (FStarC_Syntax_Embeddings.e_list + FStarC_Reflection_V2_Embeddings.e_universe) + (FStarC_Syntax_Embeddings.e_list + (FStarC_Syntax_Embeddings.e_tuple2 + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_aqualv)))) psc ncb us args) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Tactics_Visit.ml b/ocaml/fstar-lib/generated/FStar_Tactics_Visit.ml index 90202f0a354..0210307bd5c 100644 --- a/ocaml/fstar-lib/generated/FStar_Tactics_Visit.ml +++ b/ocaml/fstar-lib/generated/FStar_Tactics_Visit.ml @@ -1,17 +1,17 @@ open Prims let (on_sort_binder : - (FStar_Reflection_Types.term -> - (FStar_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) + (FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) -> - FStar_Reflection_Types.binder -> - (FStar_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.binder -> + (FStarC_Reflection_Types.binder, unit) FStar_Tactics_Effect.tac_repr) = fun f -> fun b -> let uu___ = Obj.magic (FStar_Tactics_Effect.lift_div_tac - (fun uu___1 -> FStar_Reflection_V2_Builtins.inspect_binder b)) in + (fun uu___1 -> FStarC_Reflection_V2_Builtins.inspect_binder b)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -26,7 +26,7 @@ let (on_sort_binder : (fun uu___1 -> (fun bview -> let uu___1 = - let uu___2 = f bview.FStar_Reflection_V2_Data.sort2 in + let uu___2 = f bview.FStarC_Reflection_V2_Data.sort2 in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -43,13 +43,13 @@ let (on_sort_binder : FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> { - FStar_Reflection_V2_Data.sort2 = uu___3; - FStar_Reflection_V2_Data.qual = - (bview.FStar_Reflection_V2_Data.qual); - FStar_Reflection_V2_Data.attrs = - (bview.FStar_Reflection_V2_Data.attrs); - FStar_Reflection_V2_Data.ppname2 = - (bview.FStar_Reflection_V2_Data.ppname2) + FStarC_Reflection_V2_Data.sort2 = uu___3; + FStarC_Reflection_V2_Data.qual = + (bview.FStarC_Reflection_V2_Data.qual); + FStarC_Reflection_V2_Data.attrs = + (bview.FStarC_Reflection_V2_Data.attrs); + FStarC_Reflection_V2_Data.ppname2 = + (bview.FStarC_Reflection_V2_Data.ppname2) })) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -67,14 +67,14 @@ let (on_sort_binder : (fun bview1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> - FStar_Reflection_V2_Builtins.pack_binder bview1)))) + FStarC_Reflection_V2_Builtins.pack_binder bview1)))) uu___1) let (on_sort_simple_binder : - (FStar_Reflection_Types.term -> - (FStar_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) + (FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) -> - FStar_Reflection_V2_Data.simple_binder -> - (FStar_Reflection_V2_Data.simple_binder, unit) + FStarC_Reflection_V2_Data.simple_binder -> + (FStarC_Reflection_V2_Data.simple_binder, unit) FStar_Tactics_Effect.tac_repr) = fun f -> @@ -82,7 +82,7 @@ let (on_sort_simple_binder : let uu___ = Obj.magic (FStar_Tactics_Effect.lift_div_tac - (fun uu___1 -> FStar_Reflection_V2_Builtins.inspect_binder b)) in + (fun uu___1 -> FStarC_Reflection_V2_Builtins.inspect_binder b)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -97,7 +97,7 @@ let (on_sort_simple_binder : (fun uu___1 -> (fun bview -> let uu___1 = - let uu___2 = f bview.FStar_Reflection_V2_Data.sort2 in + let uu___2 = f bview.FStarC_Reflection_V2_Data.sort2 in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -114,13 +114,13 @@ let (on_sort_simple_binder : FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> { - FStar_Reflection_V2_Data.sort2 = uu___3; - FStar_Reflection_V2_Data.qual = - (bview.FStar_Reflection_V2_Data.qual); - FStar_Reflection_V2_Data.attrs = - (bview.FStar_Reflection_V2_Data.attrs); - FStar_Reflection_V2_Data.ppname2 = - (bview.FStar_Reflection_V2_Data.ppname2) + FStarC_Reflection_V2_Data.sort2 = uu___3; + FStarC_Reflection_V2_Data.qual = + (bview.FStarC_Reflection_V2_Data.qual); + FStarC_Reflection_V2_Data.attrs = + (bview.FStarC_Reflection_V2_Data.attrs); + FStarC_Reflection_V2_Data.ppname2 = + (bview.FStarC_Reflection_V2_Data.ppname2) })) in Obj.magic (FStar_Tactics_Effect.tac_bind @@ -138,21 +138,21 @@ let (on_sort_simple_binder : (fun bview1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> - FStar_Reflection_V2_Builtins.pack_binder bview1)))) + FStarC_Reflection_V2_Builtins.pack_binder bview1)))) uu___1) let rec (visit_tm : - (FStar_Reflection_Types.term -> - (FStar_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) + (FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) -> - FStar_Reflection_Types.term -> - (FStar_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) = fun ff -> fun t -> let uu___ = Obj.magic (FStar_Tactics_Effect.lift_div_tac - (fun uu___1 -> FStar_Reflection_V2_Builtins.inspect_ln t)) in + (fun uu___1 -> FStarC_Reflection_V2_Builtins.inspect_ln t)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -168,55 +168,57 @@ let rec (visit_tm : (fun tv -> let uu___1 = match tv with - | FStar_Reflection_V2_Data.Tv_FVar uu___2 -> + | FStarC_Reflection_V2_Data.Tv_FVar uu___2 -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> tv))) - | FStar_Reflection_V2_Data.Tv_Var uu___2 -> + | FStarC_Reflection_V2_Data.Tv_Var uu___2 -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> tv))) - | FStar_Reflection_V2_Data.Tv_BVar uu___2 -> + | FStarC_Reflection_V2_Data.Tv_BVar uu___2 -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> tv))) - | FStar_Reflection_V2_Data.Tv_UInst (uu___2, uu___3) -> + | FStarC_Reflection_V2_Data.Tv_UInst (uu___2, uu___3) -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> tv))) - | FStar_Reflection_V2_Data.Tv_Type u -> + | FStarC_Reflection_V2_Data.Tv_Type u -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac - (fun uu___2 -> FStar_Reflection_V2_Data.Tv_Type u))) - | FStar_Reflection_V2_Data.Tv_Const c -> + (fun uu___2 -> + FStarC_Reflection_V2_Data.Tv_Type u))) + | FStarC_Reflection_V2_Data.Tv_Const c -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> - FStar_Reflection_V2_Data.Tv_Const c))) - | FStar_Reflection_V2_Data.Tv_Uvar (i, u) -> + FStarC_Reflection_V2_Data.Tv_Const c))) + | FStarC_Reflection_V2_Data.Tv_Uvar (i, u) -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> - FStar_Reflection_V2_Data.Tv_Uvar (i, u)))) - | FStar_Reflection_V2_Data.Tv_Unknown -> + FStarC_Reflection_V2_Data.Tv_Uvar (i, u)))) + | FStarC_Reflection_V2_Data.Tv_Unknown -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> - FStar_Reflection_V2_Data.Tv_Unknown))) - | FStar_Reflection_V2_Data.Tv_Unsupp -> + FStarC_Reflection_V2_Data.Tv_Unknown))) + | FStarC_Reflection_V2_Data.Tv_Unsupp -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac - (fun uu___2 -> FStar_Reflection_V2_Data.Tv_Unsupp))) - | FStar_Reflection_V2_Data.Tv_Arrow (b, c) -> + (fun uu___2 -> + FStarC_Reflection_V2_Data.Tv_Unsupp))) + | FStarC_Reflection_V2_Data.Tv_Arrow (b, c) -> Obj.magic (Obj.repr (let uu___2 = on_sort_binder (visit_tm ff) b in @@ -259,9 +261,9 @@ let rec (visit_tm : (fun c1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> - FStar_Reflection_V2_Data.Tv_Arrow + FStarC_Reflection_V2_Data.Tv_Arrow (b1, c1))))) uu___3))) - | FStar_Reflection_V2_Data.Tv_Abs (b, t1) -> + | FStarC_Reflection_V2_Data.Tv_Abs (b, t1) -> Obj.magic (Obj.repr (let uu___2 = on_sort_binder (visit_tm ff) b in @@ -304,9 +306,9 @@ let rec (visit_tm : (fun t2 -> FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> - FStar_Reflection_V2_Data.Tv_Abs + FStarC_Reflection_V2_Data.Tv_Abs (b1, t2))))) uu___3))) - | FStar_Reflection_V2_Data.Tv_App (l, (r, q)) -> + | FStarC_Reflection_V2_Data.Tv_App (l, (r, q)) -> Obj.magic (Obj.repr (let uu___2 = visit_tm ff l in @@ -349,9 +351,9 @@ let rec (visit_tm : (fun r1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> - FStar_Reflection_V2_Data.Tv_App + FStarC_Reflection_V2_Data.Tv_App (l1, (r1, q)))))) uu___3))) - | FStar_Reflection_V2_Data.Tv_Refine (b, r) -> + | FStarC_Reflection_V2_Data.Tv_Refine (b, r) -> Obj.magic (Obj.repr (let uu___2 = on_sort_simple_binder (visit_tm ff) b in @@ -394,9 +396,9 @@ let rec (visit_tm : (fun r1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> - FStar_Reflection_V2_Data.Tv_Refine + FStarC_Reflection_V2_Data.Tv_Refine (b1, r1))))) uu___3))) - | FStar_Reflection_V2_Data.Tv_Let (r, attrs, b, def, t1) -> + | FStarC_Reflection_V2_Data.Tv_Let (r, attrs, b, def, t1) -> Obj.magic (Obj.repr (let uu___2 = on_sort_simple_binder (visit_tm ff) b in @@ -461,11 +463,11 @@ let rec (visit_tm : (fun t2 -> FStar_Tactics_Effect.lift_div_tac (fun uu___5 -> - FStar_Reflection_V2_Data.Tv_Let + FStarC_Reflection_V2_Data.Tv_Let (r, attrs, b1, def1, t2))))) uu___4))) uu___3))) - | FStar_Reflection_V2_Data.Tv_Match (sc, ret_opt, brs) -> + | FStarC_Reflection_V2_Data.Tv_Match (sc, ret_opt, brs) -> Obj.magic (Obj.repr (let uu___2 = visit_tm ff sc in @@ -769,12 +771,12 @@ let rec (visit_tm : (fun brs1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___5 -> - FStar_Reflection_V2_Data.Tv_Match + FStarC_Reflection_V2_Data.Tv_Match (sc1, ret_opt1, brs1))))) uu___4))) uu___3))) - | FStar_Reflection_V2_Data.Tv_AscribedT (e, t1, topt, use_eq) - -> + | FStarC_Reflection_V2_Data.Tv_AscribedT + (e, t1, topt, use_eq) -> Obj.magic (Obj.repr (let uu___2 = visit_tm ff e in @@ -817,10 +819,10 @@ let rec (visit_tm : (fun t2 -> FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> - FStar_Reflection_V2_Data.Tv_AscribedT + FStarC_Reflection_V2_Data.Tv_AscribedT (e1, t2, topt, use_eq))))) uu___3))) - | FStar_Reflection_V2_Data.Tv_AscribedC (e, c, topt, use_eq) + | FStarC_Reflection_V2_Data.Tv_AscribedC (e, c, topt, use_eq) -> Obj.magic (Obj.repr @@ -864,7 +866,7 @@ let rec (visit_tm : (fun c1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___4 -> - FStar_Reflection_V2_Data.Tv_AscribedC + FStarC_Reflection_V2_Data.Tv_AscribedC (e1, c1, topt, use_eq))))) uu___3))) in Obj.magic @@ -883,14 +885,14 @@ let rec (visit_tm : (fun uu___2 -> (fun tv' -> Obj.magic - (ff (FStar_Reflection_V2_Builtins.pack_ln tv'))) + (ff (FStarC_Reflection_V2_Builtins.pack_ln tv'))) uu___2))) uu___1) and (visit_br : - (FStar_Reflection_Types.term -> - (FStar_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) + (FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) -> - FStar_Reflection_V2_Data.branch -> - (FStar_Reflection_V2_Data.branch, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_V2_Data.branch -> + (FStarC_Reflection_V2_Data.branch, unit) FStar_Tactics_Effect.tac_repr) = fun ff -> fun b -> @@ -952,27 +954,27 @@ and (visit_br : (fun uu___4 -> (p1, t1))))) uu___3))) uu___1) and (visit_pat : - (FStar_Reflection_Types.term -> - (FStar_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) + (FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) -> - FStar_Reflection_V2_Data.pattern -> - (FStar_Reflection_V2_Data.pattern, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_V2_Data.pattern -> + (FStarC_Reflection_V2_Data.pattern, unit) FStar_Tactics_Effect.tac_repr) = fun uu___1 -> fun uu___ -> (fun ff -> fun p -> match p with - | FStar_Reflection_V2_Data.Pat_Constant uu___ -> + | FStarC_Reflection_V2_Data.Pat_Constant uu___ -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac (fun uu___1 -> p))) - | FStar_Reflection_V2_Data.Pat_Var (v, s) -> + | FStarC_Reflection_V2_Data.Pat_Var (v, s) -> Obj.magic (Obj.repr (FStar_Tactics_Effect.lift_div_tac - (fun uu___ -> FStar_Reflection_V2_Data.Pat_Var (v, s)))) - | FStar_Reflection_V2_Data.Pat_Cons (head, univs, subpats) -> + (fun uu___ -> FStarC_Reflection_V2_Data.Pat_Var (v, s)))) + | FStarC_Reflection_V2_Data.Pat_Cons (head, univs, subpats) -> Obj.magic (Obj.repr (let uu___ = @@ -1017,9 +1019,9 @@ and (visit_pat : (fun subpats1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___1 -> - FStar_Reflection_V2_Data.Pat_Cons + FStarC_Reflection_V2_Data.Pat_Cons (head, univs, subpats1))))) - | FStar_Reflection_V2_Data.Pat_Dot_Term t -> + | FStarC_Reflection_V2_Data.Pat_Dot_Term t -> Obj.magic (Obj.repr (let uu___ = FStar_Tactics_Util.map_opt (visit_tm ff) t in @@ -1038,21 +1040,21 @@ and (visit_pat : (fun t1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___1 -> - FStar_Reflection_V2_Data.Pat_Dot_Term t1))))) + FStarC_Reflection_V2_Data.Pat_Dot_Term t1))))) uu___1 uu___ and (visit_comp : - (FStar_Reflection_Types.term -> - (FStar_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) + (FStarC_Reflection_Types.term -> + (FStarC_Reflection_Types.term, unit) FStar_Tactics_Effect.tac_repr) -> - FStar_Reflection_Types.comp -> - (FStar_Reflection_Types.comp, unit) FStar_Tactics_Effect.tac_repr) + FStarC_Reflection_Types.comp -> + (FStarC_Reflection_Types.comp, unit) FStar_Tactics_Effect.tac_repr) = fun ff -> fun c -> let uu___ = Obj.magic (FStar_Tactics_Effect.lift_div_tac - (fun uu___1 -> FStar_Reflection_V2_Builtins.inspect_comp c)) in + (fun uu___1 -> FStarC_Reflection_V2_Builtins.inspect_comp c)) in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal (Obj.magic @@ -1069,7 +1071,7 @@ and (visit_comp : (fun cv -> let uu___1 = match cv with - | FStar_Reflection_V2_Data.C_Total ret -> + | FStarC_Reflection_V2_Data.C_Total ret -> let uu___2 = visit_tm ff ret in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1086,8 +1088,8 @@ and (visit_comp : (fun ret1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> - FStar_Reflection_V2_Data.C_Total ret1)) - | FStar_Reflection_V2_Data.C_GTotal ret -> + FStarC_Reflection_V2_Data.C_Total ret1)) + | FStarC_Reflection_V2_Data.C_GTotal ret -> let uu___2 = visit_tm ff ret in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1104,8 +1106,8 @@ and (visit_comp : (fun ret1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___3 -> - FStar_Reflection_V2_Data.C_GTotal ret1)) - | FStar_Reflection_V2_Data.C_Lemma (pre, post, pats) -> + FStarC_Reflection_V2_Data.C_GTotal ret1)) + | FStarC_Reflection_V2_Data.C_Lemma (pre, post, pats) -> let uu___2 = visit_tm ff pre in FStar_Tactics_Effect.tac_bind (FStar_Sealed.seal @@ -1166,10 +1168,10 @@ and (visit_comp : (fun pats1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___5 -> - FStar_Reflection_V2_Data.C_Lemma + FStarC_Reflection_V2_Data.C_Lemma (pre1, post1, pats1))))) uu___4))) uu___3) - | FStar_Reflection_V2_Data.C_Eff (us, eff, res, args, decrs) + | FStarC_Reflection_V2_Data.C_Eff (us, eff, res, args, decrs) -> let uu___2 = visit_tm ff res in FStar_Tactics_Effect.tac_bind @@ -1260,7 +1262,7 @@ and (visit_comp : (fun decrs1 -> FStar_Tactics_Effect.lift_div_tac (fun uu___5 -> - FStar_Reflection_V2_Data.C_Eff + FStarC_Reflection_V2_Data.C_Eff (us, eff, res1, args1, decrs1))))) uu___4))) uu___3) in @@ -1280,5 +1282,5 @@ and (visit_comp : (fun cv' -> FStar_Tactics_Effect.lift_div_tac (fun uu___2 -> - FStar_Reflection_V2_Builtins.pack_comp cv')))) + FStarC_Reflection_V2_Builtins.pack_comp cv')))) uu___1) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Thunk.ml b/ocaml/fstar-lib/generated/FStar_Thunk.ml deleted file mode 100644 index aa8c96b3a03..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Thunk.ml +++ /dev/null @@ -1,19 +0,0 @@ -open Prims -type 'a thunk = - (unit -> 'a, 'a) FStar_Pervasives.either FStar_Compiler_Effect.ref -type 'a t = 'a thunk -let mk : 'a . (unit -> 'a) -> 'a thunk = - fun f -> FStar_Compiler_Effect.alloc (FStar_Pervasives.Inl f) -let mkv : 'a . 'a -> 'a thunk = - fun v -> FStar_Compiler_Effect.alloc (FStar_Pervasives.Inr v) -let force : 'a . 'a thunk -> 'a = - fun t1 -> - let uu___ = FStar_Compiler_Effect.op_Bang t1 in - match uu___ with - | FStar_Pervasives.Inr a1 -> a1 - | FStar_Pervasives.Inl f -> - let a1 = f () in - (FStar_Compiler_Effect.op_Colon_Equals t1 (FStar_Pervasives.Inr a1); - a1) -let map : 'a 'b . ('a -> 'b) -> 'a thunk -> 'b thunk = - fun f -> fun t1 -> mk (fun uu___ -> let uu___1 = force t1 in f uu___1) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_ToSyntax_Interleave.ml b/ocaml/fstar-lib/generated/FStar_ToSyntax_Interleave.ml deleted file mode 100644 index 5b9d9c9d4b1..00000000000 --- a/ocaml/fstar-lib/generated/FStar_ToSyntax_Interleave.ml +++ /dev/null @@ -1,773 +0,0 @@ -open Prims -let (id_eq_lid : FStar_Ident.ident -> FStar_Ident.lident -> Prims.bool) = - fun i -> - fun l -> - let uu___ = FStar_Ident.string_of_id i in - let uu___1 = - let uu___2 = FStar_Ident.ident_of_lid l in - FStar_Ident.string_of_id uu___2 in - uu___ = uu___1 -let (is_val : FStar_Ident.ident -> FStar_Parser_AST.decl -> Prims.bool) = - fun x -> - fun d -> - match d.FStar_Parser_AST.d with - | FStar_Parser_AST.Val (y, uu___) -> - let uu___1 = FStar_Ident.string_of_id x in - let uu___2 = FStar_Ident.string_of_id y in uu___1 = uu___2 - | uu___ -> false -let (is_type : FStar_Ident.ident -> FStar_Parser_AST.decl -> Prims.bool) = - fun x -> - fun d -> - match d.FStar_Parser_AST.d with - | FStar_Parser_AST.Tycon (uu___, uu___1, tys) -> - FStar_Compiler_Util.for_some - (fun t -> - let uu___2 = FStar_Parser_AST.id_of_tycon t in - let uu___3 = FStar_Ident.string_of_id x in uu___2 = uu___3) - tys - | uu___ -> false -let (definition_lids : - FStar_Parser_AST.decl -> FStar_Ident.lident Prims.list) = - fun d -> - match d.FStar_Parser_AST.d with - | FStar_Parser_AST.TopLevelLet (uu___, defs) -> - FStar_Parser_AST.lids_of_let defs - | FStar_Parser_AST.Tycon (uu___, uu___1, tys) -> - FStar_Compiler_List.collect - (fun uu___2 -> - match uu___2 with - | FStar_Parser_AST.TyconAbbrev (id, uu___3, uu___4, uu___5) -> - let uu___6 = FStar_Ident.lid_of_ids [id] in [uu___6] - | FStar_Parser_AST.TyconRecord - (id, uu___3, uu___4, uu___5, uu___6) -> - let uu___7 = FStar_Ident.lid_of_ids [id] in [uu___7] - | FStar_Parser_AST.TyconVariant (id, uu___3, uu___4, uu___5) -> - let uu___6 = FStar_Ident.lid_of_ids [id] in [uu___6] - | uu___3 -> []) tys - | FStar_Parser_AST.Splice (uu___, ids, uu___1) -> - FStar_Compiler_List.map (fun id -> FStar_Ident.lid_of_ids [id]) ids - | FStar_Parser_AST.DeclToBeDesugared - { FStar_Parser_AST.lang_name = uu___; FStar_Parser_AST.blob = uu___1; - FStar_Parser_AST.idents = ids; FStar_Parser_AST.to_string = uu___2; - FStar_Parser_AST.eq = uu___3; FStar_Parser_AST.dep_scan = uu___4;_} - -> - FStar_Compiler_List.map (fun id -> FStar_Ident.lid_of_ids [id]) ids - | FStar_Parser_AST.DeclSyntaxExtension - (extension_name, code, uu___, range) -> - let ext_parser = - FStar_Parser_AST_Util.lookup_extension_parser extension_name in - (match ext_parser with - | FStar_Pervasives_Native.None -> - let uu___1 = - FStar_Compiler_Util.format1 "Unknown syntax extension %s" - extension_name in - FStar_Errors.raise_error FStar_Parser_AST.hasRange_decl d - FStar_Errors_Codes.Fatal_SyntaxError () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) - | FStar_Pervasives_Native.Some parser -> - let uu___1 = - parser.FStar_Parser_AST_Util.parse_decl_name code range in - (match uu___1 with - | FStar_Pervasives.Inl error -> - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - error.FStar_Parser_AST_Util.range - FStar_Errors_Codes.Fatal_SyntaxError () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic error.FStar_Parser_AST_Util.message) - | FStar_Pervasives.Inr id -> - let uu___2 = FStar_Ident.lid_of_ids [id] in [uu___2])) - | uu___ -> [] -let (is_definition_of : - FStar_Ident.ident -> FStar_Parser_AST.decl -> Prims.bool) = - fun x -> - fun d -> - let uu___ = definition_lids d in - FStar_Compiler_Util.for_some (id_eq_lid x) uu___ -let rec (prefix_with_iface_decls : - FStar_Parser_AST.decl Prims.list -> - FStar_Parser_AST.decl -> - (FStar_Parser_AST.decl Prims.list * FStar_Parser_AST.decl Prims.list)) - = - fun iface -> - fun impl -> - let qualify_karamel_private impl1 = - let karamel_private = - FStar_Parser_AST.mk_term - (FStar_Parser_AST.Const - (FStar_Const.Const_string - ("KrmlPrivate", (impl1.FStar_Parser_AST.drange)))) - impl1.FStar_Parser_AST.drange FStar_Parser_AST.Expr in - { - FStar_Parser_AST.d = (impl1.FStar_Parser_AST.d); - FStar_Parser_AST.drange = (impl1.FStar_Parser_AST.drange); - FStar_Parser_AST.quals = (impl1.FStar_Parser_AST.quals); - FStar_Parser_AST.attrs = (karamel_private :: - (impl1.FStar_Parser_AST.attrs)); - FStar_Parser_AST.interleaved = (impl1.FStar_Parser_AST.interleaved) - } in - match iface with - | [] -> - let uu___ = let uu___1 = qualify_karamel_private impl in [uu___1] in - ([], uu___) - | iface_hd::iface_tl -> - (match iface_hd.FStar_Parser_AST.d with - | FStar_Parser_AST.Tycon (uu___, uu___1, tys) when - FStar_Compiler_Util.for_some - (fun uu___2 -> - match uu___2 with - | FStar_Parser_AST.TyconAbstract uu___3 -> true - | uu___3 -> false) tys - -> - let uu___2 = - let uu___3 = - FStar_Errors_Msg.text - "Interface contains an abstract 'type' declaration; use 'val' instead." in - [uu___3] in - FStar_Errors.raise_error FStar_Parser_AST.hasRange_decl impl - FStar_Errors_Codes.Fatal_AbstractTypeDeclarationInInterface - () (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___2) - | FStar_Parser_AST.Splice (uu___, x::[], uu___1) -> - let def_ids = definition_lids impl in - let defines_x = - FStar_Compiler_Util.for_some (id_eq_lid x) def_ids in - if Prims.op_Negation defines_x - then - ((let uu___3 = - FStar_Compiler_Util.for_some - (fun y -> - let uu___4 = - let uu___5 = FStar_Ident.ident_of_lid y in - is_val uu___5 in - FStar_Compiler_Util.for_some uu___4 iface_tl) - def_ids in - if uu___3 - then - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Errors_Msg.text "Expected the definition of" in - let uu___7 = - let uu___8 = - FStar_Class_PP.pp FStar_Ident.pretty_ident x in - let uu___9 = - let uu___10 = FStar_Errors_Msg.text "to precede" in - let uu___11 = - FStar_Class_PP.pp - (FStar_Class_PP.pp_list - FStar_Ident.pretty_lident) def_ids in - FStar_Pprint.op_Hat_Slash_Hat uu___10 uu___11 in - FStar_Pprint.op_Hat_Slash_Hat uu___8 uu___9 in - FStar_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in - [uu___5] in - FStar_Errors.raise_error FStar_Parser_AST.hasRange_decl - impl FStar_Errors_Codes.Fatal_WrongDefinitionOrder () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___4) - else ()); - (let uu___3 = - let uu___4 = qualify_karamel_private impl in [uu___4] in - (iface, uu___3))) - else - (let mutually_defined_with_x = - FStar_Compiler_List.filter - (fun y -> - let uu___3 = id_eq_lid x y in - Prims.op_Negation uu___3) def_ids in - let rec aux mutuals iface1 = - match (mutuals, iface1) with - | ([], uu___3) -> ([], iface1) - | (uu___3::uu___4, []) -> ([], []) - | (y::ys, iface_hd1::iface_tl1) when - let uu___3 = FStar_Ident.ident_of_lid y in - is_val uu___3 iface_hd1 -> - let uu___3 = aux ys iface_tl1 in - (match uu___3 with - | (val_ys, iface2) -> - ((iface_hd1 :: val_ys), iface2)) - | (y::ys, iface_hd1::iface_tl1) when - let uu___3 = - let uu___4 = - let uu___5 = FStar_Ident.ident_of_lid y in - is_val uu___5 in - FStar_Compiler_List.tryFind uu___4 iface_tl1 in - FStar_Compiler_Option.isSome uu___3 -> - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Class_Show.show - FStar_Parser_AST.showable_decl iface_hd1 in - let uu___7 = FStar_Ident.string_of_lid y in - FStar_Compiler_Util.format2 - "%s is out of order with the definition of %s" - uu___6 uu___7 in - FStar_Errors_Msg.text uu___5 in - [uu___4] in - FStar_Errors.raise_error - FStar_Parser_AST.hasRange_decl iface_hd1 - FStar_Errors_Codes.Fatal_WrongDefinitionOrder () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___3) - | (y::ys, iface_hd1::iface_tl1) -> aux ys iface1 in - let uu___3 = aux mutually_defined_with_x iface_tl in - match uu___3 with - | (take_iface, rest_iface) -> - (rest_iface, - (FStar_Compiler_List.op_At (iface_hd :: take_iface) - [impl]))) - | FStar_Parser_AST.Val (x, uu___) -> - let def_ids = definition_lids impl in - let defines_x = - FStar_Compiler_Util.for_some (id_eq_lid x) def_ids in - if Prims.op_Negation defines_x - then - ((let uu___2 = - FStar_Compiler_Util.for_some - (fun y -> - let uu___3 = - let uu___4 = FStar_Ident.ident_of_lid y in - is_val uu___4 in - FStar_Compiler_Util.for_some uu___3 iface_tl) - def_ids in - if uu___2 - then - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Errors_Msg.text "Expected the definition of" in - let uu___6 = - let uu___7 = - FStar_Class_PP.pp FStar_Ident.pretty_ident x in - let uu___8 = - let uu___9 = FStar_Errors_Msg.text "to precede" in - let uu___10 = - FStar_Class_PP.pp - (FStar_Class_PP.pp_list - FStar_Ident.pretty_lident) def_ids in - FStar_Pprint.op_Hat_Slash_Hat uu___9 uu___10 in - FStar_Pprint.op_Hat_Slash_Hat uu___7 uu___8 in - FStar_Pprint.op_Hat_Slash_Hat uu___5 uu___6 in - [uu___4] in - FStar_Errors.raise_error FStar_Parser_AST.hasRange_decl - impl FStar_Errors_Codes.Fatal_WrongDefinitionOrder () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___3) - else ()); - (let uu___2 = - let uu___3 = qualify_karamel_private impl in [uu___3] in - (iface, uu___2))) - else - (let mutually_defined_with_x = - FStar_Compiler_List.filter - (fun y -> - let uu___2 = id_eq_lid x y in - Prims.op_Negation uu___2) def_ids in - let rec aux mutuals iface1 = - match (mutuals, iface1) with - | ([], uu___2) -> ([], iface1) - | (uu___2::uu___3, []) -> ([], []) - | (y::ys, iface_hd1::iface_tl1) when - let uu___2 = FStar_Ident.ident_of_lid y in - is_val uu___2 iface_hd1 -> - let uu___2 = aux ys iface_tl1 in - (match uu___2 with - | (val_ys, iface2) -> - ((iface_hd1 :: val_ys), iface2)) - | (y::ys, iface_hd1::iface_tl1) when - let uu___2 = - let uu___3 = - let uu___4 = FStar_Ident.ident_of_lid y in - is_val uu___4 in - FStar_Compiler_List.tryFind uu___3 iface_tl1 in - FStar_Compiler_Option.isSome uu___2 -> - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Class_Show.show - FStar_Parser_AST.showable_decl iface_hd1 in - let uu___6 = FStar_Ident.string_of_lid y in - FStar_Compiler_Util.format2 - "%s is out of order with the definition of %s" - uu___5 uu___6 in - FStar_Errors_Msg.text uu___4 in - [uu___3] in - FStar_Errors.raise_error - FStar_Parser_AST.hasRange_decl iface_hd1 - FStar_Errors_Codes.Fatal_WrongDefinitionOrder () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___2) - | (y::ys, iface_hd1::iface_tl1) -> aux ys iface1 in - let uu___2 = aux mutually_defined_with_x iface_tl in - match uu___2 with - | (take_iface, rest_iface) -> - (rest_iface, - (FStar_Compiler_List.op_At (iface_hd :: take_iface) - [impl]))) - | FStar_Parser_AST.Pragma uu___ -> - prefix_with_iface_decls iface_tl impl - | uu___ -> - let uu___1 = prefix_with_iface_decls iface_tl impl in - (match uu___1 with - | (iface1, ds) -> (iface1, (iface_hd :: ds)))) -let (check_initial_interface : - FStar_Parser_AST.decl Prims.list -> FStar_Parser_AST.decl Prims.list) = - fun iface -> - let rec aux iface1 = - match iface1 with - | [] -> () - | hd::tl -> - (match hd.FStar_Parser_AST.d with - | FStar_Parser_AST.Tycon (uu___, uu___1, tys) when - FStar_Compiler_Util.for_some - (fun uu___2 -> - match uu___2 with - | FStar_Parser_AST.TyconAbstract uu___3 -> true - | uu___3 -> false) tys - -> - FStar_Errors.raise_error FStar_Parser_AST.hasRange_decl hd - FStar_Errors_Codes.Fatal_AbstractTypeDeclarationInInterface - () (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Interface contains an abstract 'type' declaration; use 'val' instead") - | FStar_Parser_AST.Val (x, t) -> - let uu___ = - FStar_Compiler_Util.for_some (is_definition_of x) tl in - if uu___ - then - let uu___1 = - let uu___2 = FStar_Ident.string_of_id x in - let uu___3 = FStar_Ident.string_of_id x in - FStar_Compiler_Util.format2 - "'val %s' and 'let %s' cannot both be provided in an interface" - uu___2 uu___3 in - FStar_Errors.raise_error FStar_Parser_AST.hasRange_decl hd - FStar_Errors_Codes.Fatal_BothValAndLetInInterface () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) - else - if - FStar_Compiler_List.contains FStar_Parser_AST.Assumption - hd.FStar_Parser_AST.quals - then - FStar_Errors.raise_error FStar_Parser_AST.hasRange_decl hd - FStar_Errors_Codes.Fatal_AssumeValInInterface () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Interfaces cannot use `assume val x : t`; just write `val x : t` instead") - else () - | uu___ -> ()) in - aux iface; - FStar_Compiler_List.filter - (fun d -> - match d.FStar_Parser_AST.d with - | FStar_Parser_AST.TopLevelModule uu___1 -> false - | uu___1 -> true) iface -let (ml_mode_prefix_with_iface_decls : - FStar_Parser_AST.decl Prims.list -> - FStar_Parser_AST.decl -> - (FStar_Parser_AST.decl Prims.list * FStar_Parser_AST.decl Prims.list)) - = - fun iface -> - fun impl -> - match impl.FStar_Parser_AST.d with - | FStar_Parser_AST.TopLevelModule uu___ -> - let uu___1 = - FStar_Compiler_List.span - (fun d -> - match d.FStar_Parser_AST.d with - | FStar_Parser_AST.Open uu___2 -> true - | FStar_Parser_AST.ModuleAbbrev uu___2 -> true - | uu___2 -> false) iface in - (match uu___1 with - | (iface_prefix_opens, iface1) -> - let iface2 = - FStar_Compiler_List.filter - (fun d -> - match d.FStar_Parser_AST.d with - | FStar_Parser_AST.Val uu___2 -> true - | FStar_Parser_AST.Tycon uu___2 -> true - | uu___2 -> false) iface1 in - (iface2, - (FStar_Compiler_List.op_At [impl] iface_prefix_opens))) - | FStar_Parser_AST.Open uu___ -> - let uu___1 = - FStar_Compiler_List.span - (fun d -> - match d.FStar_Parser_AST.d with - | FStar_Parser_AST.Open uu___2 -> true - | FStar_Parser_AST.ModuleAbbrev uu___2 -> true - | uu___2 -> false) iface in - (match uu___1 with - | (iface_prefix_opens, iface1) -> - let iface2 = - FStar_Compiler_List.filter - (fun d -> - match d.FStar_Parser_AST.d with - | FStar_Parser_AST.Val uu___2 -> true - | FStar_Parser_AST.Tycon uu___2 -> true - | uu___2 -> false) iface1 in - (iface2, - (FStar_Compiler_List.op_At [impl] iface_prefix_opens))) - | FStar_Parser_AST.Friend uu___ -> - let uu___1 = - FStar_Compiler_List.span - (fun d -> - match d.FStar_Parser_AST.d with - | FStar_Parser_AST.Open uu___2 -> true - | FStar_Parser_AST.ModuleAbbrev uu___2 -> true - | uu___2 -> false) iface in - (match uu___1 with - | (iface_prefix_opens, iface1) -> - let iface2 = - FStar_Compiler_List.filter - (fun d -> - match d.FStar_Parser_AST.d with - | FStar_Parser_AST.Val uu___2 -> true - | FStar_Parser_AST.Tycon uu___2 -> true - | uu___2 -> false) iface1 in - (iface2, - (FStar_Compiler_List.op_At [impl] iface_prefix_opens))) - | FStar_Parser_AST.Include uu___ -> - let uu___1 = - FStar_Compiler_List.span - (fun d -> - match d.FStar_Parser_AST.d with - | FStar_Parser_AST.Open uu___2 -> true - | FStar_Parser_AST.ModuleAbbrev uu___2 -> true - | uu___2 -> false) iface in - (match uu___1 with - | (iface_prefix_opens, iface1) -> - let iface2 = - FStar_Compiler_List.filter - (fun d -> - match d.FStar_Parser_AST.d with - | FStar_Parser_AST.Val uu___2 -> true - | FStar_Parser_AST.Tycon uu___2 -> true - | uu___2 -> false) iface1 in - (iface2, - (FStar_Compiler_List.op_At [impl] iface_prefix_opens))) - | FStar_Parser_AST.ModuleAbbrev uu___ -> - let uu___1 = - FStar_Compiler_List.span - (fun d -> - match d.FStar_Parser_AST.d with - | FStar_Parser_AST.Open uu___2 -> true - | FStar_Parser_AST.ModuleAbbrev uu___2 -> true - | uu___2 -> false) iface in - (match uu___1 with - | (iface_prefix_opens, iface1) -> - let iface2 = - FStar_Compiler_List.filter - (fun d -> - match d.FStar_Parser_AST.d with - | FStar_Parser_AST.Val uu___2 -> true - | FStar_Parser_AST.Tycon uu___2 -> true - | uu___2 -> false) iface1 in - (iface2, - (FStar_Compiler_List.op_At [impl] iface_prefix_opens))) - | uu___ -> - let uu___1 = - FStar_Compiler_List.span - (fun d -> - match d.FStar_Parser_AST.d with - | FStar_Parser_AST.Tycon uu___2 -> true - | uu___2 -> false) iface in - (match uu___1 with - | (iface_prefix_tycons, iface1) -> - let maybe_get_iface_vals lids iface2 = - FStar_Compiler_List.partition - (fun d -> - FStar_Compiler_Util.for_some - (fun x -> - let uu___2 = FStar_Ident.ident_of_lid x in - is_val uu___2 d) lids) iface2 in - (match impl.FStar_Parser_AST.d with - | FStar_Parser_AST.TopLevelLet uu___2 -> - let xs = definition_lids impl in - let uu___3 = maybe_get_iface_vals xs iface1 in - (match uu___3 with - | (val_xs, rest_iface) -> - (rest_iface, - (FStar_Compiler_List.op_At iface_prefix_tycons - (FStar_Compiler_List.op_At val_xs [impl])))) - | FStar_Parser_AST.Tycon uu___2 -> - let xs = definition_lids impl in - let uu___3 = maybe_get_iface_vals xs iface1 in - (match uu___3 with - | (val_xs, rest_iface) -> - (rest_iface, - (FStar_Compiler_List.op_At iface_prefix_tycons - (FStar_Compiler_List.op_At val_xs [impl])))) - | uu___2 -> - (iface1, - (FStar_Compiler_List.op_At iface_prefix_tycons [impl])))) -let ml_mode_check_initial_interface : - 'uuuuu . - 'uuuuu -> - FStar_Parser_AST.decl Prims.list -> FStar_Parser_AST.decl Prims.list - = - fun mname -> - fun iface -> - FStar_Compiler_List.filter - (fun d -> - match d.FStar_Parser_AST.d with - | FStar_Parser_AST.Tycon (uu___, uu___1, tys) when - FStar_Compiler_Util.for_some - (fun uu___2 -> - match uu___2 with - | FStar_Parser_AST.TyconAbstract uu___3 -> true - | uu___3 -> false) tys - -> - FStar_Errors.raise_error FStar_Parser_AST.hasRange_decl d - FStar_Errors_Codes.Fatal_AbstractTypeDeclarationInInterface - () (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Interface contains an abstract 'type' declaration; use 'val' instead") - | FStar_Parser_AST.Tycon uu___ -> true - | FStar_Parser_AST.Val uu___ -> true - | FStar_Parser_AST.Open uu___ -> true - | FStar_Parser_AST.ModuleAbbrev uu___ -> true - | uu___ -> false) iface -let (ulib_modules : Prims.string Prims.list) = - ["FStar.Calc"; - "FStar.TSet"; - "FStar.Seq.Base"; - "FStar.Seq.Properties"; - "FStar.UInt"; - "FStar.UInt8"; - "FStar.UInt16"; - "FStar.UInt32"; - "FStar.UInt64"; - "FStar.Int"; - "FStar.Int8"; - "FStar.Int16"; - "FStar.Int32"; - "FStar.Int64"] -let (apply_ml_mode_optimizations : FStar_Ident.lident -> Prims.bool) = - fun mname -> - ((FStar_Options.ml_ish ()) && - (let uu___ = - let uu___1 = FStar_Ident.string_of_lid mname in - let uu___2 = FStar_Parser_Dep.core_modules () in - FStar_Compiler_List.contains uu___1 uu___2 in - Prims.op_Negation uu___)) - && - (let uu___ = - let uu___1 = FStar_Ident.string_of_lid mname in - FStar_Compiler_List.contains uu___1 ulib_modules in - Prims.op_Negation uu___) -let (prefix_one_decl : - FStar_Ident.lident -> - FStar_Parser_AST.decl Prims.list -> - FStar_Parser_AST.decl -> - (FStar_Parser_AST.decl Prims.list * FStar_Parser_AST.decl Prims.list)) - = - fun mname -> - fun iface -> - fun impl -> - match impl.FStar_Parser_AST.d with - | FStar_Parser_AST.TopLevelModule uu___ -> (iface, [impl]) - | uu___ -> - let uu___1 = apply_ml_mode_optimizations mname in - if uu___1 - then ml_mode_prefix_with_iface_decls iface impl - else prefix_with_iface_decls iface impl -let (initialize_interface : - FStar_Ident.lident -> - FStar_Parser_AST.decl Prims.list -> unit FStar_Syntax_DsEnv.withenv) - = - fun mname -> - fun l -> - fun env -> - let decls = - let uu___ = apply_ml_mode_optimizations mname in - if uu___ - then ml_mode_check_initial_interface mname l - else check_initial_interface l in - let uu___ = FStar_Syntax_DsEnv.iface_decls env mname in - match uu___ with - | FStar_Pervasives_Native.Some uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Ident.showable_lident mname in - FStar_Compiler_Util.format1 - "Interface %s has already been processed" uu___3 in - FStar_Errors.raise_error FStar_Ident.hasrange_lident mname - FStar_Errors_Codes.Fatal_InterfaceAlreadyProcessed () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2) - | FStar_Pervasives_Native.None -> - let uu___1 = FStar_Syntax_DsEnv.set_iface_decls env mname decls in - ((), uu___1) -let (fixup_interleaved_decls : - FStar_Parser_AST.decl Prims.list -> FStar_Parser_AST.decl Prims.list) = - fun iface -> - let fix1 d = - let d1 = - { - FStar_Parser_AST.d = (d.FStar_Parser_AST.d); - FStar_Parser_AST.drange = (d.FStar_Parser_AST.drange); - FStar_Parser_AST.quals = (d.FStar_Parser_AST.quals); - FStar_Parser_AST.attrs = (d.FStar_Parser_AST.attrs); - FStar_Parser_AST.interleaved = true - } in - d1 in - FStar_Compiler_List.map fix1 iface -let (prefix_with_interface_decls : - FStar_Ident.lident -> - FStar_Parser_AST.decl -> - FStar_Parser_AST.decl Prims.list FStar_Syntax_DsEnv.withenv) - = - fun mname -> - fun impl -> - fun env -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Syntax_DsEnv.current_module env in - FStar_Syntax_DsEnv.iface_decls env uu___2 in - match uu___1 with - | FStar_Pervasives_Native.None -> ([impl], env) - | FStar_Pervasives_Native.Some iface -> - let iface1 = fixup_interleaved_decls iface in - let uu___2 = prefix_one_decl mname iface1 impl in - (match uu___2 with - | (iface2, impl1) -> - let env1 = - let uu___3 = FStar_Syntax_DsEnv.current_module env in - FStar_Syntax_DsEnv.set_iface_decls env uu___3 iface2 in - (impl1, env1)) in - match uu___ with - | (decls, env1) -> - ((let uu___2 = - let uu___3 = FStar_Ident.string_of_lid mname in - FStar_Options.dump_module uu___3 in - if uu___2 - then - let uu___3 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Parser_AST.showable_decl) decls in - FStar_Compiler_Util.print1 "Interleaved decls:\n%s\n" uu___3 - else ()); - (decls, env1)) -let (interleave_module : - FStar_Parser_AST.modul -> - Prims.bool -> FStar_Parser_AST.modul FStar_Syntax_DsEnv.withenv) - = - fun a -> - fun expect_complete_modul -> - fun env -> - match a with - | FStar_Parser_AST.Interface uu___ -> (a, env) - | FStar_Parser_AST.Module (l, impls) -> - let uu___ = FStar_Syntax_DsEnv.iface_decls env l in - (match uu___ with - | FStar_Pervasives_Native.None -> (a, env) - | FStar_Pervasives_Native.Some iface -> - let iface1 = fixup_interleaved_decls iface in - let uu___1 = - FStar_Compiler_List.fold_left - (fun uu___2 -> - fun impl -> - match uu___2 with - | (iface2, impls1) -> - let uu___3 = prefix_one_decl l iface2 impl in - (match uu___3 with - | (iface3, impls') -> - (iface3, - (FStar_Compiler_List.op_At impls1 impls')))) - (iface1, []) impls in - (match uu___1 with - | (iface2, impls1) -> - let uu___2 = - let uu___3 = - FStar_Compiler_Util.prefix_until - (fun uu___4 -> - match uu___4 with - | { - FStar_Parser_AST.d = FStar_Parser_AST.Val - uu___5; - FStar_Parser_AST.drange = uu___6; - FStar_Parser_AST.quals = uu___7; - FStar_Parser_AST.attrs = uu___8; - FStar_Parser_AST.interleaved = uu___9;_} - -> true - | { - FStar_Parser_AST.d = - FStar_Parser_AST.Splice uu___5; - FStar_Parser_AST.drange = uu___6; - FStar_Parser_AST.quals = uu___7; - FStar_Parser_AST.attrs = uu___8; - FStar_Parser_AST.interleaved = uu___9;_} - -> true - | uu___5 -> false) iface2 in - match uu___3 with - | FStar_Pervasives_Native.None -> (iface2, []) - | FStar_Pervasives_Native.Some (lets, one_val, rest) - -> (lets, (one_val :: rest)) in - (match uu___2 with - | (iface_lets, remaining_iface_vals) -> - let impls2 = - FStar_Compiler_List.op_At impls1 iface_lets in - let env1 = - let uu___3 = FStar_Options.interactive () in - if uu___3 - then - FStar_Syntax_DsEnv.set_iface_decls env l - remaining_iface_vals - else env in - let a1 = FStar_Parser_AST.Module (l, impls2) in - (match remaining_iface_vals with - | uu___3::uu___4 when expect_complete_modul -> - ((let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Class_Show.show - FStar_Ident.showable_lident l in - FStar_Compiler_Util.format1 - "Some interface elements were not implemented by module %s:" - uu___10 in - FStar_Errors_Msg.text uu___9 in - let uu___9 = - let uu___10 = - FStar_Compiler_List.map - (fun d -> - let uu___11 = - FStar_Class_Show.show - FStar_Parser_AST.showable_decl - d in - FStar_Pprint.doc_of_string - uu___11) - remaining_iface_vals in - FStar_Errors_Msg.sublist - FStar_Pprint.empty uu___10 in - FStar_Pprint.op_Hat_Hat uu___8 uu___9 in - [uu___7] in - FStar_Errors.log_issue - FStar_Ident.hasrange_lident l - FStar_Errors_Codes.Fatal_InterfaceNotImplementedByModule - () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___6)); - (a1, env1)) - | uu___3 -> - ((let uu___5 = - let uu___6 = FStar_Ident.string_of_lid l in - FStar_Options.dump_module uu___6 in - if uu___5 - then - let uu___6 = - FStar_Parser_AST.modul_to_string a1 in - FStar_Compiler_Util.print1 - "Interleaved module is:\n%s\n" uu___6 - else ()); - (a1, env1)))))) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_ToSyntax_ToSyntax.ml b/ocaml/fstar-lib/generated/FStar_ToSyntax_ToSyntax.ml deleted file mode 100644 index 868a04e82bc..00000000000 --- a/ocaml/fstar-lib/generated/FStar_ToSyntax_ToSyntax.ml +++ /dev/null @@ -1,10820 +0,0 @@ -open Prims -type extension_tosyntax_decl_t = - FStar_Syntax_DsEnv.env -> - FStar_Dyn.dyn -> - FStar_Ident.lident Prims.list -> - FStar_Compiler_Range_Type.range -> - FStar_Syntax_Syntax.sigelt' Prims.list -let (extension_tosyntax_table : - extension_tosyntax_decl_t FStar_Compiler_Util.smap) = - FStar_Compiler_Util.smap_create (Prims.of_int (20)) -let (register_extension_tosyntax : - Prims.string -> extension_tosyntax_decl_t -> unit) = - fun lang_name -> - fun cb -> - FStar_Compiler_Util.smap_add extension_tosyntax_table lang_name cb -let (lookup_extension_tosyntax : - Prims.string -> extension_tosyntax_decl_t FStar_Pervasives_Native.option) = - fun lang_name -> - FStar_Compiler_Util.smap_try_find extension_tosyntax_table lang_name -let (dbg_attrs : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "attrs" -let (dbg_ToSyntax : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "ToSyntax" -type antiquotations_temp = - (FStar_Syntax_Syntax.bv * FStar_Syntax_Syntax.term) Prims.list -let (tun_r : FStar_Compiler_Range_Type.range -> FStar_Syntax_Syntax.term) = - fun r -> - { - FStar_Syntax_Syntax.n = (FStar_Syntax_Syntax.tun.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = r; - FStar_Syntax_Syntax.vars = - (FStar_Syntax_Syntax.tun.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (FStar_Syntax_Syntax.tun.FStar_Syntax_Syntax.hash_code) - } -type annotated_pat = - (FStar_Syntax_Syntax.pat * (FStar_Syntax_Syntax.bv * - FStar_Syntax_Syntax.typ * FStar_Syntax_Syntax.term Prims.list) - Prims.list) -let (mk_thunk : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun e -> - let b = - let uu___ = - FStar_Syntax_Syntax.new_bv FStar_Pervasives_Native.None - FStar_Syntax_Syntax.tun in - FStar_Syntax_Syntax.mk_binder uu___ in - FStar_Syntax_Util.abs [b] e FStar_Pervasives_Native.None -let (mk_binder_with_attrs : - FStar_Syntax_Syntax.bv -> - FStar_Syntax_Syntax.bqual -> - FStar_Syntax_Syntax.attribute Prims.list -> FStar_Syntax_Syntax.binder) - = - fun bv -> - fun aq -> - fun attrs -> - let uu___ = FStar_Syntax_Util.parse_positivity_attributes attrs in - match uu___ with - | (pqual, attrs1) -> - FStar_Syntax_Syntax.mk_binder_with_attrs bv aq pqual attrs1 -let (qualify_field_names : - FStar_Ident.lident -> - FStar_Ident.lident Prims.list -> FStar_Ident.lident Prims.list) - = - fun record_or_dc_lid -> - fun field_names -> - let qualify_to_record l = - let ns = FStar_Ident.ns_of_lid record_or_dc_lid in - let uu___ = FStar_Ident.ident_of_lid l in - FStar_Ident.lid_of_ns_and_id ns uu___ in - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun l -> - match uu___1 with - | (ns_opt, out) -> - let uu___2 = FStar_Ident.nsstr l in - (match uu___2 with - | "" -> - if FStar_Compiler_Option.isSome ns_opt - then - let uu___3 = - let uu___4 = qualify_to_record l in uu___4 :: out in - (ns_opt, uu___3) - else (ns_opt, (l :: out)) - | ns -> - (match ns_opt with - | FStar_Pervasives_Native.Some ns' -> - if ns <> ns' - then - let uu___3 = - let uu___4 = - FStar_Class_Show.show - FStar_Ident.showable_lident l in - FStar_Compiler_Util.format2 - "Field %s of record type was expected to be scoped to namespace %s" - uu___4 ns' in - FStar_Errors.raise_error - FStar_Ident.hasrange_lident l - FStar_Errors_Codes.Fatal_MissingFieldInRecord - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___3) - else - (let uu___4 = - let uu___5 = qualify_to_record l in uu___5 - :: out in - (ns_opt, uu___4)) - | FStar_Pervasives_Native.None -> - let uu___3 = - let uu___4 = qualify_to_record l in uu___4 :: - out in - ((FStar_Pervasives_Native.Some ns), uu___3)))) - (FStar_Pervasives_Native.None, []) field_names in - match uu___ with - | (uu___1, field_names_rev) -> FStar_Compiler_List.rev field_names_rev -let desugar_disjunctive_pattern : - 'uuuuu . - (FStar_Syntax_Syntax.pat' FStar_Syntax_Syntax.withinfo_t * - (FStar_Syntax_Syntax.bv * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax * 'uuuuu) Prims.list) Prims.list -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.branch Prims.list - = - fun annotated_pats -> - fun when_opt -> - fun branch -> - FStar_Compiler_List.map - (fun uu___ -> - match uu___ with - | (pat, annots) -> - let branch1 = - FStar_Compiler_List.fold_left - (fun br -> - fun uu___1 -> - match uu___1 with - | (bv, ty, uu___2) -> - let lb = - let uu___3 = - FStar_Syntax_Syntax.bv_to_name bv in - FStar_Syntax_Util.mk_letbinding - (FStar_Pervasives.Inl bv) [] ty - FStar_Parser_Const.effect_Tot_lid uu___3 [] - br.FStar_Syntax_Syntax.pos in - let branch2 = - let uu___3 = - let uu___4 = - FStar_Syntax_Syntax.mk_binder bv in - [uu___4] in - FStar_Syntax_Subst.close uu___3 branch in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = (false, [lb]); - FStar_Syntax_Syntax.body1 = branch2 - }) br.FStar_Syntax_Syntax.pos) branch - annots in - FStar_Syntax_Util.branch (pat, when_opt, branch1)) - annotated_pats -let (trans_qual : - FStar_Compiler_Range_Type.range -> - FStar_Ident.lident FStar_Pervasives_Native.option -> - FStar_Parser_AST.qualifier -> FStar_Syntax_Syntax.qualifier) - = - fun r -> - fun maybe_effect_id -> - fun uu___ -> - match uu___ with - | FStar_Parser_AST.Private -> FStar_Syntax_Syntax.Private - | FStar_Parser_AST.Assumption -> FStar_Syntax_Syntax.Assumption - | FStar_Parser_AST.Unfold_for_unification_and_vcgen -> - FStar_Syntax_Syntax.Unfold_for_unification_and_vcgen - | FStar_Parser_AST.Inline_for_extraction -> - FStar_Syntax_Syntax.Inline_for_extraction - | FStar_Parser_AST.NoExtract -> FStar_Syntax_Syntax.NoExtract - | FStar_Parser_AST.Irreducible -> FStar_Syntax_Syntax.Irreducible - | FStar_Parser_AST.Logic -> FStar_Syntax_Syntax.Logic - | FStar_Parser_AST.TotalEffect -> FStar_Syntax_Syntax.TotalEffect - | FStar_Parser_AST.Effect_qual -> FStar_Syntax_Syntax.Effect - | FStar_Parser_AST.New -> FStar_Syntax_Syntax.New - | FStar_Parser_AST.Opaque -> - ((let uu___2 = - let uu___3 = - FStar_Errors_Msg.text - "The 'opaque' qualifier is deprecated since its use was strangely schizophrenic." in - let uu___4 = - let uu___5 = - FStar_Errors_Msg.text - "There were two overloaded uses: (1) Given 'opaque val f : t', the behavior was to exclude the definition of 'f' to the SMT solver. This corresponds roughly to the new 'irreducible' qualifier. (2) Given 'opaque type t = t'', the behavior was to provide the definition of 't' to the SMT solver, but not to inline it, unless absolutely required for unification. This corresponds roughly to the behavior of 'unfoldable' (which is currently the default)." in - [uu___5] in - uu___3 :: uu___4 in - FStar_Errors.log_issue FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Warning_DeprecatedOpaqueQualifier () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___2)); - FStar_Syntax_Syntax.Visible_default) - | FStar_Parser_AST.Reflectable -> - (match maybe_effect_id with - | FStar_Pervasives_Native.None -> - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range - r FStar_Errors_Codes.Fatal_ReflectOnlySupportedOnEffects - () (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic "Qualifier reflect only supported on effects") - | FStar_Pervasives_Native.Some effect_id -> - FStar_Syntax_Syntax.Reflectable effect_id) - | FStar_Parser_AST.Reifiable -> FStar_Syntax_Syntax.Reifiable - | FStar_Parser_AST.Noeq -> FStar_Syntax_Syntax.Noeq - | FStar_Parser_AST.Unopteq -> FStar_Syntax_Syntax.Unopteq - | FStar_Parser_AST.DefaultEffect -> - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_DefaultQualifierNotAllowedOnEffects () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "The 'default' qualifier on effects is no longer supported") - | FStar_Parser_AST.Inline -> - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_UnsupportedQualifier () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic "Unsupported qualifier") - | FStar_Parser_AST.Visible -> - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_UnsupportedQualifier () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic "Unsupported qualifier") -let (trans_pragma : FStar_Parser_AST.pragma -> FStar_Syntax_Syntax.pragma) = - fun uu___ -> - match uu___ with - | FStar_Parser_AST.ShowOptions -> FStar_Syntax_Syntax.ShowOptions - | FStar_Parser_AST.SetOptions s -> FStar_Syntax_Syntax.SetOptions s - | FStar_Parser_AST.ResetOptions sopt -> - FStar_Syntax_Syntax.ResetOptions sopt - | FStar_Parser_AST.PushOptions sopt -> - FStar_Syntax_Syntax.PushOptions sopt - | FStar_Parser_AST.PopOptions -> FStar_Syntax_Syntax.PopOptions - | FStar_Parser_AST.RestartSolver -> FStar_Syntax_Syntax.RestartSolver - | FStar_Parser_AST.PrintEffectsGraph -> - FStar_Syntax_Syntax.PrintEffectsGraph -let (as_imp : - FStar_Parser_AST.imp -> - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) - = - fun uu___ -> - match uu___ with - | FStar_Parser_AST.Hash -> FStar_Syntax_Syntax.as_aqual_implicit true - | uu___1 -> FStar_Pervasives_Native.None -let arg_withimp_t : - 'uuuuu . - FStar_Parser_AST.imp -> - 'uuuuu -> - ('uuuuu * FStar_Syntax_Syntax.arg_qualifier - FStar_Pervasives_Native.option) - = fun imp -> fun t -> let uu___ = as_imp imp in (t, uu___) -let (contains_binder : FStar_Parser_AST.binder Prims.list -> Prims.bool) = - fun binders -> - FStar_Compiler_Util.for_some - (fun b -> - match b.FStar_Parser_AST.b with - | FStar_Parser_AST.Annotated uu___ -> true - | uu___ -> false) binders -let rec (unparen : FStar_Parser_AST.term -> FStar_Parser_AST.term) = - fun t -> - match t.FStar_Parser_AST.tm with - | FStar_Parser_AST.Paren t1 -> unparen t1 - | uu___ -> t -let (tm_type_z : FStar_Compiler_Range_Type.range -> FStar_Parser_AST.term) = - fun r -> - let uu___ = - let uu___1 = FStar_Ident.lid_of_path ["Type0"] r in - FStar_Parser_AST.Name uu___1 in - FStar_Parser_AST.mk_term uu___ r FStar_Parser_AST.Kind -let (tm_type : FStar_Compiler_Range_Type.range -> FStar_Parser_AST.term) = - fun r -> - let uu___ = - let uu___1 = FStar_Ident.lid_of_path ["Type"] r in - FStar_Parser_AST.Name uu___1 in - FStar_Parser_AST.mk_term uu___ r FStar_Parser_AST.Kind -let rec (is_comp_type : - FStar_Syntax_DsEnv.env -> FStar_Parser_AST.term -> Prims.bool) = - fun env -> - fun t -> - let uu___ = let uu___1 = unparen t in uu___1.FStar_Parser_AST.tm in - match uu___ with - | FStar_Parser_AST.Name l when - (let uu___1 = FStar_Syntax_DsEnv.current_module env in - FStar_Ident.lid_equals uu___1 FStar_Parser_Const.prims_lid) && - (let s = - let uu___1 = FStar_Ident.ident_of_lid l in - FStar_Ident.string_of_id uu___1 in - (s = "Tot") || (s = "GTot")) - -> true - | FStar_Parser_AST.Name l -> - let uu___1 = FStar_Syntax_DsEnv.try_lookup_effect_name env l in - FStar_Compiler_Option.isSome uu___1 - | FStar_Parser_AST.Construct (l, uu___1) -> - let uu___2 = FStar_Syntax_DsEnv.try_lookup_effect_name env l in - FStar_Compiler_Option.isSome uu___2 - | FStar_Parser_AST.App (head, uu___1, uu___2) -> is_comp_type env head - | FStar_Parser_AST.Paren t1 -> failwith "impossible" - | FStar_Parser_AST.Ascribed (t1, uu___1, uu___2, uu___3) -> - is_comp_type env t1 - | FStar_Parser_AST.LetOpen (uu___1, t1) -> is_comp_type env t1 - | uu___1 -> false -let (unit_ty : FStar_Compiler_Range_Type.range -> FStar_Parser_AST.term) = - fun rng -> - FStar_Parser_AST.mk_term - (FStar_Parser_AST.Name FStar_Parser_Const.unit_lid) rng - FStar_Parser_AST.Type_level -type env_t = FStar_Syntax_DsEnv.env -type lenv_t = FStar_Syntax_Syntax.bv Prims.list -let (desugar_name' : - (FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) -> - env_t -> - Prims.bool -> - FStar_Ident.lid -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = - fun setpos -> - fun env -> - fun resolve -> - fun l -> - let tm_attrs_opt = - if resolve - then FStar_Syntax_DsEnv.try_lookup_lid_with_attributes env l - else - FStar_Syntax_DsEnv.try_lookup_lid_with_attributes_no_resolve - env l in - match tm_attrs_opt with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (tm, attrs) -> - let tm1 = setpos tm in FStar_Pervasives_Native.Some tm1 -let desugar_name : - 'uuuuu . - 'uuuuu -> - (FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) -> - env_t -> Prims.bool -> FStar_Ident.lident -> FStar_Syntax_Syntax.term - = - fun mk -> - fun setpos -> - fun env -> - fun resolve -> - fun l -> - FStar_Syntax_DsEnv.fail_or env (desugar_name' setpos env resolve) - l -let (compile_op_lid : - Prims.int -> - Prims.string -> FStar_Compiler_Range_Type.range -> FStar_Ident.lident) - = - fun n -> - fun s -> - fun r -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Parser_AST.compile_op n s r in (uu___3, r) in - FStar_Ident.mk_ident uu___2 in - [uu___1] in - FStar_Ident.lid_of_ids uu___ -let (op_as_term : - env_t -> - Prims.int -> - FStar_Ident.ident -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = - fun env -> - fun arity -> - fun op -> - let r l = - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Ident.range_of_id op in - FStar_Ident.set_lid_range l uu___3 in - FStar_Syntax_Syntax.lid_and_dd_as_fv uu___2 - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___1 in - FStar_Pervasives_Native.Some uu___ in - let fallback uu___ = - let uu___1 = FStar_Ident.string_of_id op in - match uu___1 with - | "=" -> r FStar_Parser_Const.op_Eq - | "<" -> r FStar_Parser_Const.op_LT - | "<=" -> r FStar_Parser_Const.op_LTE - | ">" -> r FStar_Parser_Const.op_GT - | ">=" -> r FStar_Parser_Const.op_GTE - | "&&" -> r FStar_Parser_Const.op_And - | "||" -> r FStar_Parser_Const.op_Or - | "+" -> r FStar_Parser_Const.op_Addition - | "-" when arity = Prims.int_one -> r FStar_Parser_Const.op_Minus - | "-" -> r FStar_Parser_Const.op_Subtraction - | "/" -> r FStar_Parser_Const.op_Division - | "%" -> r FStar_Parser_Const.op_Modulus - | "@" -> - ((let uu___3 = - let uu___4 = - FStar_Errors_Msg.text - "The operator '@' has been resolved to FStar.List.Tot.append even though FStar.List.Tot is not in scope. Please add an 'open FStar.List.Tot' to stop relying on this deprecated, special treatment of '@'." in - [uu___4] in - FStar_Errors.log_issue FStar_Ident.hasrange_ident op - FStar_Errors_Codes.Warning_DeprecatedGeneric () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___3)); - r FStar_Parser_Const.list_tot_append_lid) - | "<>" -> r FStar_Parser_Const.op_notEq - | "~" -> r FStar_Parser_Const.not_lid - | "==" -> r FStar_Parser_Const.eq2_lid - | "<<" -> r FStar_Parser_Const.precedes_lid - | "/\\" -> r FStar_Parser_Const.and_lid - | "\\/" -> r FStar_Parser_Const.or_lid - | "==>" -> r FStar_Parser_Const.imp_lid - | "<==>" -> r FStar_Parser_Const.iff_lid - | uu___2 -> FStar_Pervasives_Native.None in - let uu___ = - let uu___1 = - let uu___2 = FStar_Ident.string_of_id op in - let uu___3 = FStar_Ident.range_of_id op in - compile_op_lid arity uu___2 uu___3 in - desugar_name' - (fun t -> - let uu___2 = FStar_Ident.range_of_id op in - { - FStar_Syntax_Syntax.n = (t.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = uu___2; - FStar_Syntax_Syntax.vars = (t.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (t.FStar_Syntax_Syntax.hash_code) - }) env true uu___1 in - match uu___ with - | FStar_Pervasives_Native.Some t -> FStar_Pervasives_Native.Some t - | uu___1 -> fallback () -let (sort_ftv : FStar_Ident.ident Prims.list -> FStar_Ident.ident Prims.list) - = - fun ftv -> - let uu___ = - FStar_Compiler_Util.remove_dups - (fun x -> - fun y -> - let uu___1 = FStar_Ident.string_of_id x in - let uu___2 = FStar_Ident.string_of_id y in uu___1 = uu___2) ftv in - FStar_Compiler_Util.sort_with - (fun x -> - fun y -> - let uu___1 = FStar_Ident.string_of_id x in - let uu___2 = FStar_Ident.string_of_id y in - FStar_Compiler_String.compare uu___1 uu___2) uu___ -let rec (free_vars_b : - Prims.bool -> - FStar_Syntax_DsEnv.env -> - FStar_Parser_AST.binder -> - (FStar_Syntax_DsEnv.env * FStar_Ident.ident Prims.list)) - = - fun tvars_only -> - fun env -> - fun binder -> - match binder.FStar_Parser_AST.b with - | FStar_Parser_AST.Variable x -> - if tvars_only - then (env, []) - else - (let uu___1 = FStar_Syntax_DsEnv.push_bv env x in - match uu___1 with | (env1, uu___2) -> (env1, [])) - | FStar_Parser_AST.TVariable x -> - let uu___ = FStar_Syntax_DsEnv.push_bv env x in - (match uu___ with | (env1, uu___1) -> (env1, [x])) - | FStar_Parser_AST.Annotated (x, term) -> - if tvars_only - then let uu___ = free_vars tvars_only env term in (env, uu___) - else - (let uu___1 = FStar_Syntax_DsEnv.push_bv env x in - match uu___1 with - | (env', uu___2) -> - let uu___3 = free_vars tvars_only env term in - (env', uu___3)) - | FStar_Parser_AST.TAnnotated (id, term) -> - let uu___ = FStar_Syntax_DsEnv.push_bv env id in - (match uu___ with - | (env', uu___1) -> - let uu___2 = free_vars tvars_only env term in (env', uu___2)) - | FStar_Parser_AST.NoName t -> - let uu___ = free_vars tvars_only env t in (env, uu___) -and (free_vars_bs : - Prims.bool -> - FStar_Syntax_DsEnv.env -> - FStar_Parser_AST.binder Prims.list -> - (FStar_Syntax_DsEnv.env * FStar_Ident.ident Prims.list)) - = - fun tvars_only -> - fun env -> - fun binders -> - FStar_Compiler_List.fold_left - (fun uu___ -> - fun binder -> - match uu___ with - | (env1, free) -> - let uu___1 = free_vars_b tvars_only env1 binder in - (match uu___1 with - | (env2, f) -> (env2, (FStar_Compiler_List.op_At f free)))) - (env, []) binders -and (free_vars : - Prims.bool -> - FStar_Syntax_DsEnv.env -> - FStar_Parser_AST.term -> FStar_Ident.ident Prims.list) - = - fun tvars_only -> - fun env -> - fun t -> - let uu___ = let uu___1 = unparen t in uu___1.FStar_Parser_AST.tm in - match uu___ with - | FStar_Parser_AST.Labeled uu___1 -> - failwith "Impossible --- labeled source term" - | FStar_Parser_AST.Tvar a -> - let uu___1 = FStar_Syntax_DsEnv.try_lookup_id env a in - (match uu___1 with - | FStar_Pervasives_Native.None -> [a] - | uu___2 -> []) - | FStar_Parser_AST.Var x -> - if tvars_only - then [] - else - (let ids = FStar_Ident.ids_of_lid x in - match ids with - | id::[] -> - let uu___2 = - (let uu___3 = FStar_Syntax_DsEnv.try_lookup_id env id in - FStar_Pervasives_Native.uu___is_None uu___3) && - (let uu___3 = FStar_Syntax_DsEnv.try_lookup_lid env x in - FStar_Pervasives_Native.uu___is_None uu___3) in - if uu___2 then [id] else [] - | uu___2 -> []) - | FStar_Parser_AST.Wild -> [] - | FStar_Parser_AST.Const uu___1 -> [] - | FStar_Parser_AST.Uvar uu___1 -> [] - | FStar_Parser_AST.Projector uu___1 -> [] - | FStar_Parser_AST.Discrim uu___1 -> [] - | FStar_Parser_AST.Name uu___1 -> [] - | FStar_Parser_AST.Requires (t1, uu___1) -> - free_vars tvars_only env t1 - | FStar_Parser_AST.Ensures (t1, uu___1) -> - free_vars tvars_only env t1 - | FStar_Parser_AST.Decreases (t1, uu___1) -> - free_vars tvars_only env t1 - | FStar_Parser_AST.NamedTyp (uu___1, t1) -> - free_vars tvars_only env t1 - | FStar_Parser_AST.LexList l -> - FStar_Compiler_List.collect (free_vars tvars_only env) l - | FStar_Parser_AST.WFOrder (rel, e) -> - let uu___1 = free_vars tvars_only env rel in - let uu___2 = free_vars tvars_only env e in - FStar_Compiler_List.op_At uu___1 uu___2 - | FStar_Parser_AST.Paren t1 -> failwith "impossible" - | FStar_Parser_AST.Ascribed (t1, t', tacopt, uu___1) -> - let ts = t1 :: t' :: - (match tacopt with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some t2 -> [t2]) in - FStar_Compiler_List.collect (free_vars tvars_only env) ts - | FStar_Parser_AST.Construct (uu___1, ts) -> - FStar_Compiler_List.collect - (fun uu___2 -> - match uu___2 with - | (t1, uu___3) -> free_vars tvars_only env t1) ts - | FStar_Parser_AST.Op (uu___1, ts) -> - FStar_Compiler_List.collect (free_vars tvars_only env) ts - | FStar_Parser_AST.App (t1, t2, uu___1) -> - let uu___2 = free_vars tvars_only env t1 in - let uu___3 = free_vars tvars_only env t2 in - FStar_Compiler_List.op_At uu___2 uu___3 - | FStar_Parser_AST.Refine (b, t1) -> - let uu___1 = free_vars_b tvars_only env b in - (match uu___1 with - | (env1, f) -> - let uu___2 = free_vars tvars_only env1 t1 in - FStar_Compiler_List.op_At f uu___2) - | FStar_Parser_AST.Sum (binders, body) -> - let uu___1 = - FStar_Compiler_List.fold_left - (fun uu___2 -> - fun bt -> - match uu___2 with - | (env1, free) -> - let uu___3 = - match bt with - | FStar_Pervasives.Inl binder -> - free_vars_b tvars_only env1 binder - | FStar_Pervasives.Inr t1 -> - let uu___4 = free_vars tvars_only env1 t1 in - (env1, uu___4) in - (match uu___3 with - | (env2, f) -> - (env2, (FStar_Compiler_List.op_At f free)))) - (env, []) binders in - (match uu___1 with - | (env1, free) -> - let uu___2 = free_vars tvars_only env1 body in - FStar_Compiler_List.op_At free uu___2) - | FStar_Parser_AST.Product (binders, body) -> - let uu___1 = free_vars_bs tvars_only env binders in - (match uu___1 with - | (env1, free) -> - let uu___2 = free_vars tvars_only env1 body in - FStar_Compiler_List.op_At free uu___2) - | FStar_Parser_AST.Project (t1, uu___1) -> - free_vars tvars_only env t1 - | FStar_Parser_AST.Attributes cattributes -> - FStar_Compiler_List.collect (free_vars tvars_only env) - cattributes - | FStar_Parser_AST.CalcProof (rel, init, steps) -> - let uu___1 = free_vars tvars_only env rel in - let uu___2 = - let uu___3 = free_vars tvars_only env init in - let uu___4 = - FStar_Compiler_List.collect - (fun uu___5 -> - match uu___5 with - | FStar_Parser_AST.CalcStep (rel1, just, next) -> - let uu___6 = free_vars tvars_only env rel1 in - let uu___7 = - let uu___8 = free_vars tvars_only env just in - let uu___9 = free_vars tvars_only env next in - FStar_Compiler_List.op_At uu___8 uu___9 in - FStar_Compiler_List.op_At uu___6 uu___7) steps in - FStar_Compiler_List.op_At uu___3 uu___4 in - FStar_Compiler_List.op_At uu___1 uu___2 - | FStar_Parser_AST.ElimForall (bs, t1, ts) -> - let uu___1 = free_vars_bs tvars_only env bs in - (match uu___1 with - | (env', free) -> - let uu___2 = - let uu___3 = free_vars tvars_only env' t1 in - let uu___4 = - FStar_Compiler_List.collect (free_vars tvars_only env') - ts in - FStar_Compiler_List.op_At uu___3 uu___4 in - FStar_Compiler_List.op_At free uu___2) - | FStar_Parser_AST.ElimExists (binders, p, q, y, e) -> - let uu___1 = free_vars_bs tvars_only env binders in - (match uu___1 with - | (env', free) -> - let uu___2 = free_vars_b tvars_only env' y in - (match uu___2 with - | (env'', free') -> - let uu___3 = - let uu___4 = free_vars tvars_only env' p in - let uu___5 = - let uu___6 = free_vars tvars_only env q in - let uu___7 = - let uu___8 = free_vars tvars_only env'' e in - FStar_Compiler_List.op_At free' uu___8 in - FStar_Compiler_List.op_At uu___6 uu___7 in - FStar_Compiler_List.op_At uu___4 uu___5 in - FStar_Compiler_List.op_At free uu___3)) - | FStar_Parser_AST.ElimImplies (p, q, e) -> - let uu___1 = free_vars tvars_only env p in - let uu___2 = - let uu___3 = free_vars tvars_only env q in - let uu___4 = free_vars tvars_only env e in - FStar_Compiler_List.op_At uu___3 uu___4 in - FStar_Compiler_List.op_At uu___1 uu___2 - | FStar_Parser_AST.ElimOr (p, q, r, x, e, x', e') -> - let uu___1 = free_vars tvars_only env p in - let uu___2 = - let uu___3 = free_vars tvars_only env q in - let uu___4 = - let uu___5 = free_vars tvars_only env r in - let uu___6 = - let uu___7 = - let uu___8 = free_vars_b tvars_only env x in - match uu___8 with - | (env', free) -> - let uu___9 = free_vars tvars_only env' e in - FStar_Compiler_List.op_At free uu___9 in - let uu___8 = - let uu___9 = free_vars_b tvars_only env x' in - match uu___9 with - | (env', free) -> - let uu___10 = free_vars tvars_only env' e' in - FStar_Compiler_List.op_At free uu___10 in - FStar_Compiler_List.op_At uu___7 uu___8 in - FStar_Compiler_List.op_At uu___5 uu___6 in - FStar_Compiler_List.op_At uu___3 uu___4 in - FStar_Compiler_List.op_At uu___1 uu___2 - | FStar_Parser_AST.ElimAnd (p, q, r, x, y, e) -> - let uu___1 = free_vars tvars_only env p in - let uu___2 = - let uu___3 = free_vars tvars_only env q in - let uu___4 = - let uu___5 = free_vars tvars_only env r in - let uu___6 = - let uu___7 = free_vars_bs tvars_only env [x; y] in - match uu___7 with - | (env', free) -> - let uu___8 = free_vars tvars_only env' e in - FStar_Compiler_List.op_At free uu___8 in - FStar_Compiler_List.op_At uu___5 uu___6 in - FStar_Compiler_List.op_At uu___3 uu___4 in - FStar_Compiler_List.op_At uu___1 uu___2 - | FStar_Parser_AST.ListLiteral ts -> - FStar_Compiler_List.collect (free_vars tvars_only env) ts - | FStar_Parser_AST.SeqLiteral ts -> - FStar_Compiler_List.collect (free_vars tvars_only env) ts - | FStar_Parser_AST.Abs uu___1 -> [] - | FStar_Parser_AST.Function uu___1 -> [] - | FStar_Parser_AST.Let uu___1 -> [] - | FStar_Parser_AST.LetOpen uu___1 -> [] - | FStar_Parser_AST.If uu___1 -> [] - | FStar_Parser_AST.QForall uu___1 -> [] - | FStar_Parser_AST.QExists uu___1 -> [] - | FStar_Parser_AST.QuantOp uu___1 -> [] - | FStar_Parser_AST.Record uu___1 -> [] - | FStar_Parser_AST.Match uu___1 -> [] - | FStar_Parser_AST.TryWith uu___1 -> [] - | FStar_Parser_AST.Bind uu___1 -> [] - | FStar_Parser_AST.Quote uu___1 -> [] - | FStar_Parser_AST.VQuote uu___1 -> [] - | FStar_Parser_AST.Antiquote uu___1 -> [] - | FStar_Parser_AST.Seq uu___1 -> [] -let (free_type_vars : - FStar_Syntax_DsEnv.env -> - FStar_Parser_AST.term -> FStar_Ident.ident Prims.list) - = free_vars true -let (head_and_args : - FStar_Parser_AST.term -> - (FStar_Parser_AST.term * (FStar_Parser_AST.term * FStar_Parser_AST.imp) - Prims.list)) - = - fun t -> - let rec aux args t1 = - let uu___ = let uu___1 = unparen t1 in uu___1.FStar_Parser_AST.tm in - match uu___ with - | FStar_Parser_AST.App (t2, arg, imp) -> aux ((arg, imp) :: args) t2 - | FStar_Parser_AST.Construct (l, args') -> - ({ - FStar_Parser_AST.tm = (FStar_Parser_AST.Name l); - FStar_Parser_AST.range = (t1.FStar_Parser_AST.range); - FStar_Parser_AST.level = (t1.FStar_Parser_AST.level) - }, (FStar_Compiler_List.op_At args' args)) - | uu___1 -> (t1, args) in - aux [] t -let (close : - FStar_Syntax_DsEnv.env -> FStar_Parser_AST.term -> FStar_Parser_AST.term) = - fun env -> - fun t -> - let ftv = let uu___ = free_type_vars env t in sort_ftv uu___ in - if (FStar_Compiler_List.length ftv) = Prims.int_zero - then t - else - (let binders = - FStar_Compiler_List.map - (fun x -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Ident.range_of_id x in - tm_type uu___4 in - (x, uu___3) in - FStar_Parser_AST.TAnnotated uu___2 in - let uu___2 = FStar_Ident.range_of_id x in - FStar_Parser_AST.mk_binder uu___1 uu___2 - FStar_Parser_AST.Type_level - (FStar_Pervasives_Native.Some FStar_Parser_AST.Implicit)) - ftv in - let result = - FStar_Parser_AST.mk_term (FStar_Parser_AST.Product (binders, t)) - t.FStar_Parser_AST.range t.FStar_Parser_AST.level in - result) -let (close_fun : - FStar_Syntax_DsEnv.env -> FStar_Parser_AST.term -> FStar_Parser_AST.term) = - fun env -> - fun t -> - let ftv = let uu___ = free_type_vars env t in sort_ftv uu___ in - if (FStar_Compiler_List.length ftv) = Prims.int_zero - then t - else - (let binders = - FStar_Compiler_List.map - (fun x -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Ident.range_of_id x in - tm_type uu___4 in - (x, uu___3) in - FStar_Parser_AST.TAnnotated uu___2 in - let uu___2 = FStar_Ident.range_of_id x in - FStar_Parser_AST.mk_binder uu___1 uu___2 - FStar_Parser_AST.Type_level - (FStar_Pervasives_Native.Some FStar_Parser_AST.Implicit)) - ftv in - let t1 = - let uu___1 = let uu___2 = unparen t in uu___2.FStar_Parser_AST.tm in - match uu___1 with - | FStar_Parser_AST.Product uu___2 -> t - | uu___2 -> - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Parser_AST.mk_term - (FStar_Parser_AST.Name - FStar_Parser_Const.effect_Tot_lid) - t.FStar_Parser_AST.range t.FStar_Parser_AST.level in - (uu___5, t, FStar_Parser_AST.Nothing) in - FStar_Parser_AST.App uu___4 in - FStar_Parser_AST.mk_term uu___3 t.FStar_Parser_AST.range - t.FStar_Parser_AST.level in - let result = - FStar_Parser_AST.mk_term (FStar_Parser_AST.Product (binders, t1)) - t1.FStar_Parser_AST.range t1.FStar_Parser_AST.level in - result) -let rec (uncurry : - FStar_Parser_AST.binder Prims.list -> - FStar_Parser_AST.term -> - (FStar_Parser_AST.binder Prims.list * FStar_Parser_AST.term)) - = - fun bs -> - fun t -> - match t.FStar_Parser_AST.tm with - | FStar_Parser_AST.Product (binders, t1) -> - uncurry (FStar_Compiler_List.op_At bs binders) t1 - | uu___ -> (bs, t) -let rec (is_var_pattern : FStar_Parser_AST.pattern -> Prims.bool) = - fun p -> - match p.FStar_Parser_AST.pat with - | FStar_Parser_AST.PatWild uu___ -> true - | FStar_Parser_AST.PatTvar uu___ -> true - | FStar_Parser_AST.PatVar uu___ -> true - | FStar_Parser_AST.PatAscribed (p1, uu___) -> is_var_pattern p1 - | uu___ -> false -let rec (is_app_pattern : FStar_Parser_AST.pattern -> Prims.bool) = - fun p -> - match p.FStar_Parser_AST.pat with - | FStar_Parser_AST.PatAscribed (p1, uu___) -> is_app_pattern p1 - | FStar_Parser_AST.PatApp - ({ FStar_Parser_AST.pat = FStar_Parser_AST.PatVar uu___; - FStar_Parser_AST.prange = uu___1;_}, - uu___2) - -> true - | uu___ -> false -let (replace_unit_pattern : - FStar_Parser_AST.pattern -> FStar_Parser_AST.pattern) = - fun p -> - match p.FStar_Parser_AST.pat with - | FStar_Parser_AST.PatConst (FStar_Const.Const_unit) -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Parser_AST.mk_pattern - (FStar_Parser_AST.PatWild (FStar_Pervasives_Native.None, [])) - p.FStar_Parser_AST.prange in - let uu___3 = - let uu___4 = unit_ty p.FStar_Parser_AST.prange in - (uu___4, FStar_Pervasives_Native.None) in - (uu___2, uu___3) in - FStar_Parser_AST.PatAscribed uu___1 in - FStar_Parser_AST.mk_pattern uu___ p.FStar_Parser_AST.prange - | uu___ -> p -let rec (destruct_app_pattern : - env_t -> - Prims.bool -> - FStar_Parser_AST.pattern -> - ((FStar_Ident.ident, FStar_Ident.lid) FStar_Pervasives.either * - FStar_Parser_AST.pattern Prims.list * (FStar_Parser_AST.term * - FStar_Parser_AST.term FStar_Pervasives_Native.option) - FStar_Pervasives_Native.option)) - = - fun env -> - fun is_top_level -> - fun p -> - match p.FStar_Parser_AST.pat with - | FStar_Parser_AST.PatAscribed (p1, t) -> - let uu___ = destruct_app_pattern env is_top_level p1 in - (match uu___ with - | (name, args, uu___1) -> - (name, args, (FStar_Pervasives_Native.Some t))) - | FStar_Parser_AST.PatApp - ({ - FStar_Parser_AST.pat = FStar_Parser_AST.PatVar - (id, uu___, uu___1); - FStar_Parser_AST.prange = uu___2;_}, - args) - when is_top_level -> - let uu___3 = - let uu___4 = FStar_Syntax_DsEnv.qualify env id in - FStar_Pervasives.Inr uu___4 in - (uu___3, args, FStar_Pervasives_Native.None) - | FStar_Parser_AST.PatApp - ({ - FStar_Parser_AST.pat = FStar_Parser_AST.PatVar - (id, uu___, uu___1); - FStar_Parser_AST.prange = uu___2;_}, - args) - -> - ((FStar_Pervasives.Inl id), args, FStar_Pervasives_Native.None) - | uu___ -> failwith "Not an app pattern" -let rec (gather_pattern_bound_vars_maybe_top : - FStar_Ident.ident FStar_Compiler_FlatSet.t -> - FStar_Parser_AST.pattern -> FStar_Ident.ident FStar_Compiler_FlatSet.t) - = - fun uu___1 -> - fun uu___ -> - (fun acc -> - fun p -> - let gather_pattern_bound_vars_from_list = - FStar_Compiler_List.fold_left - gather_pattern_bound_vars_maybe_top acc in - match p.FStar_Parser_AST.pat with - | FStar_Parser_AST.PatWild uu___ -> Obj.magic (Obj.repr acc) - | FStar_Parser_AST.PatConst uu___ -> Obj.magic (Obj.repr acc) - | FStar_Parser_AST.PatVQuote uu___ -> Obj.magic (Obj.repr acc) - | FStar_Parser_AST.PatName uu___ -> Obj.magic (Obj.repr acc) - | FStar_Parser_AST.PatOp uu___ -> Obj.magic (Obj.repr acc) - | FStar_Parser_AST.PatApp (phead, pats) -> - Obj.magic - (Obj.repr - (gather_pattern_bound_vars_from_list (phead :: pats))) - | FStar_Parser_AST.PatTvar (x, uu___, uu___1) -> - Obj.magic - (Obj.repr - (FStar_Class_Setlike.add () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_ident)) x - (Obj.magic acc))) - | FStar_Parser_AST.PatVar (x, uu___, uu___1) -> - Obj.magic - (Obj.repr - (FStar_Class_Setlike.add () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_ident)) x - (Obj.magic acc))) - | FStar_Parser_AST.PatList pats -> - Obj.magic - (Obj.repr (gather_pattern_bound_vars_from_list pats)) - | FStar_Parser_AST.PatTuple (pats, uu___) -> - Obj.magic - (Obj.repr (gather_pattern_bound_vars_from_list pats)) - | FStar_Parser_AST.PatOr pats -> - Obj.magic - (Obj.repr (gather_pattern_bound_vars_from_list pats)) - | FStar_Parser_AST.PatRecord guarded_pats -> - Obj.magic - (Obj.repr - (let uu___ = - FStar_Compiler_List.map FStar_Pervasives_Native.snd - guarded_pats in - gather_pattern_bound_vars_from_list uu___)) - | FStar_Parser_AST.PatAscribed (pat, uu___) -> - Obj.magic - (Obj.repr (gather_pattern_bound_vars_maybe_top acc pat))) - uu___1 uu___ -let (gather_pattern_bound_vars : - FStar_Parser_AST.pattern -> FStar_Ident.ident FStar_Compiler_FlatSet.t) = - let acc = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_ident)) ()) in - fun p -> gather_pattern_bound_vars_maybe_top acc p -type bnd = - | LocalBinder of (FStar_Syntax_Syntax.bv * FStar_Syntax_Syntax.bqual * - FStar_Syntax_Syntax.term Prims.list) - | LetBinder of (FStar_Ident.lident * (FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option)) -let (uu___is_LocalBinder : bnd -> Prims.bool) = - fun projectee -> - match projectee with | LocalBinder _0 -> true | uu___ -> false -let (__proj__LocalBinder__item___0 : - bnd -> - (FStar_Syntax_Syntax.bv * FStar_Syntax_Syntax.bqual * - FStar_Syntax_Syntax.term Prims.list)) - = fun projectee -> match projectee with | LocalBinder _0 -> _0 -let (uu___is_LetBinder : bnd -> Prims.bool) = - fun projectee -> - match projectee with | LetBinder _0 -> true | uu___ -> false -let (__proj__LetBinder__item___0 : - bnd -> - (FStar_Ident.lident * (FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option))) - = fun projectee -> match projectee with | LetBinder _0 -> _0 -let (is_implicit : bnd -> Prims.bool) = - fun b -> - match b with - | LocalBinder - (uu___, FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit - uu___1), uu___2) - -> true - | uu___ -> false -let (binder_of_bnd : - bnd -> - (FStar_Syntax_Syntax.bv * FStar_Syntax_Syntax.bqual * - FStar_Syntax_Syntax.term Prims.list)) - = - fun uu___ -> - match uu___ with - | LocalBinder (a, aq, attrs) -> (a, aq, attrs) - | uu___1 -> failwith "Impossible" -let (mk_lb : - (FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax Prims.list * - (FStar_Syntax_Syntax.bv, FStar_Syntax_Syntax.fv) FStar_Pervasives.either - * FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * - FStar_Compiler_Range_Type.range) -> FStar_Syntax_Syntax.letbinding) - = - fun uu___ -> - match uu___ with - | (attrs, n, t, e, pos) -> - let uu___1 = FStar_Parser_Const.effect_ALL_lid () in - { - FStar_Syntax_Syntax.lbname = n; - FStar_Syntax_Syntax.lbunivs = []; - FStar_Syntax_Syntax.lbtyp = t; - FStar_Syntax_Syntax.lbeff = uu___1; - FStar_Syntax_Syntax.lbdef = e; - FStar_Syntax_Syntax.lbattrs = attrs; - FStar_Syntax_Syntax.lbpos = pos - } -let (no_annot_abs : - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun bs -> fun t -> FStar_Syntax_Util.abs bs t FStar_Pervasives_Native.None -let rec (generalize_annotated_univs : - FStar_Syntax_Syntax.sigelt -> FStar_Syntax_Syntax.sigelt) = - fun s -> - let vars = FStar_Compiler_Util.mk_ref [] in - let seen = - let uu___ = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Syntax.ord_ident)) ()) in - FStar_Compiler_Util.mk_ref uu___ in - let reg u = - let uu___ = - let uu___1 = - let uu___2 = FStar_Compiler_Effect.op_Bang seen in - FStar_Class_Setlike.mem () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Syntax.ord_ident)) u (Obj.magic uu___2) in - Prims.op_Negation uu___1 in - if uu___ - then - ((let uu___2 = - let uu___3 = FStar_Compiler_Effect.op_Bang seen in - Obj.magic - (FStar_Class_Setlike.add () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Syntax.ord_ident)) u (Obj.magic uu___3)) in - FStar_Compiler_Effect.op_Colon_Equals seen uu___2); - (let uu___2 = - let uu___3 = FStar_Compiler_Effect.op_Bang vars in u :: uu___3 in - FStar_Compiler_Effect.op_Colon_Equals vars uu___2)) - else () in - let get uu___ = - let uu___1 = FStar_Compiler_Effect.op_Bang vars in - FStar_Compiler_List.rev uu___1 in - let uu___ = - FStar_Syntax_Visit.visit_sigelt false (fun t -> t) - (fun u -> - (match u with - | FStar_Syntax_Syntax.U_name nm -> reg nm - | uu___3 -> ()); - u) s in - let unames = get () in - match s.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ uu___1 -> - failwith - "Impossible: collect_annotated_universes: bare data/type constructor" - | FStar_Syntax_Syntax.Sig_datacon uu___1 -> - failwith - "Impossible: collect_annotated_universes: bare data/type constructor" - | FStar_Syntax_Syntax.Sig_bundle - { FStar_Syntax_Syntax.ses = sigs; FStar_Syntax_Syntax.lids = lids;_} - -> - let usubst = FStar_Syntax_Subst.univ_var_closing unames in - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Compiler_List.map - (fun se -> - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = lid; - FStar_Syntax_Syntax.us = uu___4; - FStar_Syntax_Syntax.params = bs; - FStar_Syntax_Syntax.num_uniform_params = num_uniform; - FStar_Syntax_Syntax.t = t; - FStar_Syntax_Syntax.mutuals = lids1; - FStar_Syntax_Syntax.ds = lids2; - FStar_Syntax_Syntax.injective_type_params = uu___5;_} - -> - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Syntax_Subst.subst_binders usubst bs in - let uu___9 = - let uu___10 = - FStar_Syntax_Subst.shift_subst - (FStar_Compiler_List.length bs) usubst in - FStar_Syntax_Subst.subst uu___10 t in - { - FStar_Syntax_Syntax.lid = lid; - FStar_Syntax_Syntax.us = unames; - FStar_Syntax_Syntax.params = uu___8; - FStar_Syntax_Syntax.num_uniform_params = - num_uniform; - FStar_Syntax_Syntax.t = uu___9; - FStar_Syntax_Syntax.mutuals = lids1; - FStar_Syntax_Syntax.ds = lids2; - FStar_Syntax_Syntax.injective_type_params = - false - } in - FStar_Syntax_Syntax.Sig_inductive_typ uu___7 in - { - FStar_Syntax_Syntax.sigel = uu___6; - FStar_Syntax_Syntax.sigrng = - (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se.FStar_Syntax_Syntax.sigopts) - } - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = lid; - FStar_Syntax_Syntax.us1 = uu___4; - FStar_Syntax_Syntax.t1 = t; - FStar_Syntax_Syntax.ty_lid = tlid; - FStar_Syntax_Syntax.num_ty_params = n; - FStar_Syntax_Syntax.mutuals1 = lids1; - FStar_Syntax_Syntax.injective_type_params1 = uu___5;_} - -> - let uu___6 = - let uu___7 = - let uu___8 = FStar_Syntax_Subst.subst usubst t in - { - FStar_Syntax_Syntax.lid1 = lid; - FStar_Syntax_Syntax.us1 = unames; - FStar_Syntax_Syntax.t1 = uu___8; - FStar_Syntax_Syntax.ty_lid = tlid; - FStar_Syntax_Syntax.num_ty_params = n; - FStar_Syntax_Syntax.mutuals1 = lids1; - FStar_Syntax_Syntax.injective_type_params1 = - false - } in - FStar_Syntax_Syntax.Sig_datacon uu___7 in - { - FStar_Syntax_Syntax.sigel = uu___6; - FStar_Syntax_Syntax.sigrng = - (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se.FStar_Syntax_Syntax.sigopts) - } - | uu___4 -> - failwith - "Impossible: collect_annotated_universes: Sig_bundle should not have a non data/type sigelt") - sigs in - { - FStar_Syntax_Syntax.ses = uu___3; - FStar_Syntax_Syntax.lids = lids - } in - FStar_Syntax_Syntax.Sig_bundle uu___2 in - { - FStar_Syntax_Syntax.sigel = uu___1; - FStar_Syntax_Syntax.sigrng = (s.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = (s.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = (s.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = (s.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (s.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = (s.FStar_Syntax_Syntax.sigopts) - } - | FStar_Syntax_Syntax.Sig_declare_typ - { FStar_Syntax_Syntax.lid2 = lid; FStar_Syntax_Syntax.us2 = uu___1; - FStar_Syntax_Syntax.t2 = t;_} - -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Subst.close_univ_vars unames t in - { - FStar_Syntax_Syntax.lid2 = lid; - FStar_Syntax_Syntax.us2 = unames; - FStar_Syntax_Syntax.t2 = uu___4 - } in - FStar_Syntax_Syntax.Sig_declare_typ uu___3 in - { - FStar_Syntax_Syntax.sigel = uu___2; - FStar_Syntax_Syntax.sigrng = (s.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = (s.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = (s.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = (s.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (s.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = (s.FStar_Syntax_Syntax.sigopts) - } - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (b, lbs); - FStar_Syntax_Syntax.lids1 = lids;_} - -> - let usubst = FStar_Syntax_Subst.univ_var_closing unames in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Compiler_List.map - (fun lb -> - let uu___5 = - FStar_Syntax_Subst.subst usubst - lb.FStar_Syntax_Syntax.lbtyp in - let uu___6 = - FStar_Syntax_Subst.subst usubst - lb.FStar_Syntax_Syntax.lbdef in - { - FStar_Syntax_Syntax.lbname = - (lb.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs = unames; - FStar_Syntax_Syntax.lbtyp = uu___5; - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = uu___6; - FStar_Syntax_Syntax.lbattrs = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - }) lbs in - (b, uu___4) in - { - FStar_Syntax_Syntax.lbs1 = uu___3; - FStar_Syntax_Syntax.lids1 = lids - } in - FStar_Syntax_Syntax.Sig_let uu___2 in - { - FStar_Syntax_Syntax.sigel = uu___1; - FStar_Syntax_Syntax.sigrng = (s.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = (s.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = (s.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = (s.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (s.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = (s.FStar_Syntax_Syntax.sigopts) - } - | FStar_Syntax_Syntax.Sig_assume - { FStar_Syntax_Syntax.lid3 = lid; FStar_Syntax_Syntax.us3 = uu___1; - FStar_Syntax_Syntax.phi1 = fml;_} - -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Subst.close_univ_vars unames fml in - { - FStar_Syntax_Syntax.lid3 = lid; - FStar_Syntax_Syntax.us3 = unames; - FStar_Syntax_Syntax.phi1 = uu___4 - } in - FStar_Syntax_Syntax.Sig_assume uu___3 in - { - FStar_Syntax_Syntax.sigel = uu___2; - FStar_Syntax_Syntax.sigrng = (s.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = (s.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = (s.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = (s.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (s.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = (s.FStar_Syntax_Syntax.sigopts) - } - | FStar_Syntax_Syntax.Sig_effect_abbrev - { FStar_Syntax_Syntax.lid4 = lid; FStar_Syntax_Syntax.us4 = uu___1; - FStar_Syntax_Syntax.bs2 = bs; FStar_Syntax_Syntax.comp1 = c; - FStar_Syntax_Syntax.cflags = flags;_} - -> - let usubst = FStar_Syntax_Subst.univ_var_closing unames in - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Subst.subst_binders usubst bs in - let uu___5 = FStar_Syntax_Subst.subst_comp usubst c in - { - FStar_Syntax_Syntax.lid4 = lid; - FStar_Syntax_Syntax.us4 = unames; - FStar_Syntax_Syntax.bs2 = uu___4; - FStar_Syntax_Syntax.comp1 = uu___5; - FStar_Syntax_Syntax.cflags = flags - } in - FStar_Syntax_Syntax.Sig_effect_abbrev uu___3 in - { - FStar_Syntax_Syntax.sigel = uu___2; - FStar_Syntax_Syntax.sigrng = (s.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = (s.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = (s.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = (s.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (s.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = (s.FStar_Syntax_Syntax.sigopts) - } - | FStar_Syntax_Syntax.Sig_fail - { FStar_Syntax_Syntax.errs = errs; - FStar_Syntax_Syntax.fail_in_lax = lax; - FStar_Syntax_Syntax.ses1 = ses;_} - -> - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Compiler_List.map generalize_annotated_univs ses in - { - FStar_Syntax_Syntax.errs = errs; - FStar_Syntax_Syntax.fail_in_lax = lax; - FStar_Syntax_Syntax.ses1 = uu___3 - } in - FStar_Syntax_Syntax.Sig_fail uu___2 in - { - FStar_Syntax_Syntax.sigel = uu___1; - FStar_Syntax_Syntax.sigrng = (s.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = (s.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = (s.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = (s.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (s.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = (s.FStar_Syntax_Syntax.sigopts) - } - | FStar_Syntax_Syntax.Sig_new_effect ed -> - let generalize_annotated_univs_signature s1 = - match s1 with - | FStar_Syntax_Syntax.Layered_eff_sig (n, (uu___1, t)) -> - let uvs = - let uu___2 = FStar_Syntax_Free.univnames t in - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_ident)) (Obj.magic uu___2) in - let usubst = FStar_Syntax_Subst.univ_var_closing uvs in - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Subst.subst usubst t in - (uvs, uu___4) in - (n, uu___3) in - FStar_Syntax_Syntax.Layered_eff_sig uu___2 - | FStar_Syntax_Syntax.WP_eff_sig (uu___1, t) -> - let uvs = - let uu___2 = FStar_Syntax_Free.univnames t in - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_ident)) (Obj.magic uu___2) in - let usubst = FStar_Syntax_Subst.univ_var_closing uvs in - let uu___2 = - let uu___3 = FStar_Syntax_Subst.subst usubst t in - (uvs, uu___3) in - FStar_Syntax_Syntax.WP_eff_sig uu___2 in - let uu___1 = - let uu___2 = - let uu___3 = - generalize_annotated_univs_signature - ed.FStar_Syntax_Syntax.signature in - { - FStar_Syntax_Syntax.mname = (ed.FStar_Syntax_Syntax.mname); - FStar_Syntax_Syntax.cattributes = - (ed.FStar_Syntax_Syntax.cattributes); - FStar_Syntax_Syntax.univs = (ed.FStar_Syntax_Syntax.univs); - FStar_Syntax_Syntax.binders = (ed.FStar_Syntax_Syntax.binders); - FStar_Syntax_Syntax.signature = uu___3; - FStar_Syntax_Syntax.combinators = - (ed.FStar_Syntax_Syntax.combinators); - FStar_Syntax_Syntax.actions = (ed.FStar_Syntax_Syntax.actions); - FStar_Syntax_Syntax.eff_attrs = - (ed.FStar_Syntax_Syntax.eff_attrs); - FStar_Syntax_Syntax.extraction_mode = - (ed.FStar_Syntax_Syntax.extraction_mode) - } in - FStar_Syntax_Syntax.Sig_new_effect uu___2 in - { - FStar_Syntax_Syntax.sigel = uu___1; - FStar_Syntax_Syntax.sigrng = (s.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = (s.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = (s.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = (s.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (s.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = (s.FStar_Syntax_Syntax.sigopts) - } - | FStar_Syntax_Syntax.Sig_sub_effect uu___1 -> s - | FStar_Syntax_Syntax.Sig_polymonadic_bind uu___1 -> s - | FStar_Syntax_Syntax.Sig_polymonadic_subcomp uu___1 -> s - | FStar_Syntax_Syntax.Sig_splice uu___1 -> s - | FStar_Syntax_Syntax.Sig_pragma uu___1 -> s -let (is_special_effect_combinator : Prims.string -> Prims.bool) = - fun uu___ -> - match uu___ with - | "lift1" -> true - | "lift2" -> true - | "pure" -> true - | "app" -> true - | "push" -> true - | "wp_if_then_else" -> true - | "wp_assert" -> true - | "wp_assume" -> true - | "wp_close" -> true - | "stronger" -> true - | "ite_wp" -> true - | "wp_trivial" -> true - | "ctx" -> true - | "gctx" -> true - | "lift_from_pure" -> true - | "return_wp" -> true - | "return_elab" -> true - | "bind_wp" -> true - | "bind_elab" -> true - | "repr" -> true - | "post" -> true - | "pre" -> true - | "wp" -> true - | uu___1 -> false -let rec (sum_to_universe : - FStar_Syntax_Syntax.universe -> Prims.int -> FStar_Syntax_Syntax.universe) - = - fun u -> - fun n -> - if n = Prims.int_zero - then u - else - (let uu___1 = sum_to_universe u (n - Prims.int_one) in - FStar_Syntax_Syntax.U_succ uu___1) -let (int_to_universe : Prims.int -> FStar_Syntax_Syntax.universe) = - fun n -> sum_to_universe FStar_Syntax_Syntax.U_zero n -let rec (desugar_maybe_non_constant_universe : - FStar_Parser_AST.term -> - (Prims.int, FStar_Syntax_Syntax.universe) FStar_Pervasives.either) - = - fun t -> - let uu___ = let uu___1 = unparen t in uu___1.FStar_Parser_AST.tm in - match uu___ with - | FStar_Parser_AST.Wild -> - FStar_Pervasives.Inr FStar_Syntax_Syntax.U_unknown - | FStar_Parser_AST.Uvar u -> - FStar_Pervasives.Inr (FStar_Syntax_Syntax.U_name u) - | FStar_Parser_AST.Const (FStar_Const.Const_int (repr, uu___1)) -> - let n = FStar_Compiler_Util.int_of_string repr in - (if n < Prims.int_zero - then - FStar_Errors.raise_error FStar_Parser_AST.hasRange_term t - FStar_Errors_Codes.Fatal_NegativeUniverseConstFatal_NotSupported - () (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - (Prims.strcat - "Negative universe constant are not supported : " repr)) - else (); - FStar_Pervasives.Inl n) - | FStar_Parser_AST.Op (op_plus, t1::t2::[]) -> - let u1 = desugar_maybe_non_constant_universe t1 in - let u2 = desugar_maybe_non_constant_universe t2 in - (match (u1, u2) with - | (FStar_Pervasives.Inl n1, FStar_Pervasives.Inl n2) -> - FStar_Pervasives.Inl (n1 + n2) - | (FStar_Pervasives.Inl n, FStar_Pervasives.Inr u) -> - let uu___2 = sum_to_universe u n in FStar_Pervasives.Inr uu___2 - | (FStar_Pervasives.Inr u, FStar_Pervasives.Inl n) -> - let uu___2 = sum_to_universe u n in FStar_Pervasives.Inr uu___2 - | (FStar_Pervasives.Inr u11, FStar_Pervasives.Inr u21) -> - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Parser_AST.showable_term t in - Prims.strcat - "This universe might contain a sum of two universe variables " - uu___3 in - FStar_Errors.raise_error FStar_Parser_AST.hasRange_term t - FStar_Errors_Codes.Fatal_UniverseMightContainSumOfTwoUnivVars - () (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)) - | FStar_Parser_AST.App uu___1 -> - let rec aux t1 univargs = - let uu___2 = let uu___3 = unparen t1 in uu___3.FStar_Parser_AST.tm in - match uu___2 with - | FStar_Parser_AST.App (t2, targ, uu___3) -> - let uarg = desugar_maybe_non_constant_universe targ in - aux t2 (uarg :: univargs) - | FStar_Parser_AST.Var max_lid -> - let uu___4 = - FStar_Compiler_List.existsb - (fun uu___5 -> - match uu___5 with - | FStar_Pervasives.Inr uu___6 -> true - | uu___6 -> false) univargs in - if uu___4 - then - let uu___5 = - let uu___6 = - FStar_Compiler_List.map - (fun uu___7 -> - match uu___7 with - | FStar_Pervasives.Inl n -> int_to_universe n - | FStar_Pervasives.Inr u -> u) univargs in - FStar_Syntax_Syntax.U_max uu___6 in - FStar_Pervasives.Inr uu___5 - else - (let nargs = - FStar_Compiler_List.map - (fun uu___6 -> - match uu___6 with - | FStar_Pervasives.Inl n -> n - | FStar_Pervasives.Inr uu___7 -> - failwith "impossible") univargs in - let uu___6 = - FStar_Compiler_List.fold_left - (fun m -> fun n -> if m > n then m else n) - Prims.int_zero nargs in - FStar_Pervasives.Inl uu___6) - | uu___3 -> - let uu___4 = - let uu___5 = - let uu___6 = FStar_Parser_AST.term_to_string t1 in - Prims.strcat uu___6 " in universe context" in - Prims.strcat "Unexpected term " uu___5 in - FStar_Errors.raise_error FStar_Parser_AST.hasRange_term t1 - FStar_Errors_Codes.Fatal_UnexpectedTermInUniverse () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4) in - aux t [] - | uu___1 -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_Parser_AST.term_to_string t in - Prims.strcat uu___4 " in universe context" in - Prims.strcat "Unexpected term " uu___3 in - FStar_Errors.raise_error FStar_Parser_AST.hasRange_term t - FStar_Errors_Codes.Fatal_UnexpectedTermInUniverse () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2) -let (desugar_universe : - FStar_Parser_AST.term -> FStar_Syntax_Syntax.universe) = - fun t -> - let u = desugar_maybe_non_constant_universe t in - match u with - | FStar_Pervasives.Inl n -> int_to_universe n - | FStar_Pervasives.Inr u1 -> u1 -let (check_no_aq : antiquotations_temp -> unit) = - fun aq -> - match aq with - | [] -> () - | (bv, - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_quoted - (e, - { FStar_Syntax_Syntax.qkind = FStar_Syntax_Syntax.Quote_dynamic; - FStar_Syntax_Syntax.antiquotations = uu___;_}); - FStar_Syntax_Syntax.pos = uu___1; FStar_Syntax_Syntax.vars = uu___2; - FStar_Syntax_Syntax.hash_code = uu___3;_})::uu___4 - -> - let uu___5 = - let uu___6 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - FStar_Compiler_Util.format1 "Unexpected antiquotation: `@(%s)" - uu___6 in - FStar_Errors.raise_error (FStar_Syntax_Syntax.has_range_syntax ()) e - FStar_Errors_Codes.Fatal_UnexpectedAntiquotation () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___5) - | (bv, e)::uu___ -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - FStar_Compiler_Util.format1 "Unexpected antiquotation: `#(%s)" - uu___2 in - FStar_Errors.raise_error (FStar_Syntax_Syntax.has_range_syntax ()) e - FStar_Errors_Codes.Fatal_UnexpectedAntiquotation () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) -let (check_linear_pattern_variables : - FStar_Syntax_Syntax.pat' FStar_Syntax_Syntax.withinfo_t Prims.list -> - FStar_Compiler_Range_Type.range -> unit) - = - fun pats -> - fun r -> - let rec pat_vars uu___ = - (fun p -> - match p.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_dot_term uu___ -> - Obj.magic - (Obj.repr - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Syntax.ord_bv)) ())) - | FStar_Syntax_Syntax.Pat_constant uu___ -> - Obj.magic - (Obj.repr - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Syntax.ord_bv)) ())) - | FStar_Syntax_Syntax.Pat_var x -> - Obj.magic - (Obj.repr - (let uu___ = - let uu___1 = - FStar_Ident.string_of_id - x.FStar_Syntax_Syntax.ppname in - uu___1 = FStar_Ident.reserved_prefix in - if uu___ - then - FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Syntax.ord_bv)) () - else - FStar_Class_Setlike.singleton () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Syntax.ord_bv)) x)) - | FStar_Syntax_Syntax.Pat_cons (uu___, uu___1, pats1) -> - Obj.magic - (Obj.repr - (let aux uu___3 uu___2 = - (fun out -> - fun uu___2 -> - match uu___2 with - | (p1, uu___3) -> - let p_vars = pat_vars p1 in - let intersection = - Obj.magic - (FStar_Class_Setlike.inter () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Syntax.ord_bv)) - (Obj.magic p_vars) (Obj.magic out)) in - let uu___4 = - FStar_Class_Setlike.is_empty () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Syntax.ord_bv)) - (Obj.magic intersection) in - if uu___4 - then - Obj.magic - (Obj.repr - (FStar_Class_Setlike.union () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Syntax.ord_bv)) - (Obj.magic out) (Obj.magic p_vars))) - else - Obj.magic - (Obj.repr - (let duplicate_bv = - let uu___6 = - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Syntax.ord_bv)) - (Obj.magic intersection) in - FStar_Compiler_List.hd uu___6 in - let uu___6 = - let uu___7 = - FStar_Class_Show.show - FStar_Ident.showable_ident - duplicate_bv.FStar_Syntax_Syntax.ppname in - FStar_Compiler_Util.format1 - "Non-linear patterns are not permitted: `%s` appears more than once in this pattern." - uu___7 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - r - FStar_Errors_Codes.Fatal_NonLinearPatternNotPermitted - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___6)))) uu___3 uu___2 in - let uu___2 = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Syntax.ord_bv)) ()) in - FStar_Compiler_List.fold_left aux uu___2 pats1))) uu___ in - match pats with - | [] -> () - | p::[] -> let uu___ = pat_vars p in () - | p::ps -> - let pvars = pat_vars p in - let aux p1 = - let uu___ = - let uu___1 = pat_vars p1 in - FStar_Class_Setlike.equal () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Syntax.ord_bv)) (Obj.magic pvars) - (Obj.magic uu___1) in - if uu___ - then () - else - (let symdiff uu___3 uu___2 = - (fun s1 -> - fun s2 -> - let uu___2 = - Obj.magic - (FStar_Class_Setlike.diff () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Syntax.ord_bv)) - (Obj.magic s1) (Obj.magic s2)) in - let uu___3 = - Obj.magic - (FStar_Class_Setlike.diff () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Syntax.ord_bv)) - (Obj.magic s2) (Obj.magic s1)) in - Obj.magic - (FStar_Class_Setlike.union () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Syntax.ord_bv)) - (Obj.magic uu___2) (Obj.magic uu___3))) uu___3 - uu___2 in - let nonlinear_vars = - let uu___2 = pat_vars p1 in symdiff pvars uu___2 in - let first_nonlinear_var = - let uu___2 = - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Syntax.ord_bv)) - (Obj.magic nonlinear_vars) in - FStar_Compiler_List.hd uu___2 in - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Ident.showable_ident - first_nonlinear_var.FStar_Syntax_Syntax.ppname in - FStar_Compiler_Util.format1 - "Patterns in this match are incoherent, variable %s is bound in some but not all patterns." - uu___3 in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_IncoherentPatterns () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)) in - FStar_Compiler_List.iter aux ps -let (smt_pat_lid : FStar_Compiler_Range_Type.range -> FStar_Ident.lident) = - fun r -> FStar_Ident.set_lid_range FStar_Parser_Const.smtpat_lid r -let (smt_pat_or_lid : FStar_Compiler_Range_Type.range -> FStar_Ident.lident) - = fun r -> FStar_Ident.set_lid_range FStar_Parser_Const.smtpatOr_lid r -let rec (hoist_pat_ascription' : - FStar_Parser_AST.pattern -> - (FStar_Parser_AST.pattern * FStar_Parser_AST.term - FStar_Pervasives_Native.option)) - = - fun pat -> - let mk tm = - FStar_Parser_AST.mk_term tm pat.FStar_Parser_AST.prange - FStar_Parser_AST.Type_level in - let handle_list type_lid pat_cons pats = - let uu___ = - let uu___1 = FStar_Compiler_List.map hoist_pat_ascription' pats in - FStar_Compiler_List.unzip uu___1 in - match uu___ with - | (pats1, terms) -> - let uu___1 = - FStar_Compiler_List.for_all FStar_Pervasives_Native.uu___is_None - terms in - if uu___1 - then (pat, FStar_Pervasives_Native.None) - else - (let terms1 = - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with - | FStar_Pervasives_Native.Some t -> t - | FStar_Pervasives_Native.None -> - mk FStar_Parser_AST.Wild) terms in - let uu___3 = - let uu___4 = pat_cons pats1 in - { - FStar_Parser_AST.pat = uu___4; - FStar_Parser_AST.prange = (pat.FStar_Parser_AST.prange) - } in - let uu___4 = - let uu___5 = - let uu___6 = mk type_lid in - let uu___7 = - FStar_Compiler_List.map - (fun t -> (t, FStar_Parser_AST.Nothing)) terms1 in - FStar_Parser_AST.mkApp uu___6 uu___7 - pat.FStar_Parser_AST.prange in - FStar_Pervasives_Native.Some uu___5 in - (uu___3, uu___4)) in - match pat.FStar_Parser_AST.pat with - | FStar_Parser_AST.PatList pats -> - handle_list (FStar_Parser_AST.Var FStar_Parser_Const.list_lid) - (fun uu___ -> FStar_Parser_AST.PatList uu___) pats - | FStar_Parser_AST.PatTuple (pats, dep) -> - let uu___ = - let uu___1 = - (if dep - then FStar_Parser_Const.mk_dtuple_lid - else FStar_Parser_Const.mk_tuple_lid) - (FStar_Compiler_List.length pats) pat.FStar_Parser_AST.prange in - FStar_Parser_AST.Var uu___1 in - handle_list uu___ - (fun pats1 -> FStar_Parser_AST.PatTuple (pats1, dep)) pats - | FStar_Parser_AST.PatAscribed - (pat1, (typ, FStar_Pervasives_Native.None)) -> - (pat1, (FStar_Pervasives_Native.Some typ)) - | uu___ -> (pat, FStar_Pervasives_Native.None) -let (hoist_pat_ascription : - FStar_Parser_AST.pattern -> FStar_Parser_AST.pattern) = - fun pat -> - let uu___ = hoist_pat_ascription' pat in - match uu___ with - | (pat1, typ) -> - (match typ with - | FStar_Pervasives_Native.Some typ1 -> - { - FStar_Parser_AST.pat = - (FStar_Parser_AST.PatAscribed - (pat1, (typ1, FStar_Pervasives_Native.None))); - FStar_Parser_AST.prange = (pat1.FStar_Parser_AST.prange) - } - | FStar_Pervasives_Native.None -> pat1) -let rec (desugar_data_pat : - Prims.bool -> - env_t -> - FStar_Parser_AST.pattern -> - ((env_t * bnd * annotated_pat Prims.list) * antiquotations_temp)) - = - fun top_level_ascr_allowed -> - fun env -> - fun p -> - let resolvex l e x = - let uu___ = - FStar_Compiler_Util.find_opt - (fun y -> - let uu___1 = - FStar_Ident.string_of_id y.FStar_Syntax_Syntax.ppname in - let uu___2 = FStar_Ident.string_of_id x in uu___1 = uu___2) - l in - match uu___ with - | FStar_Pervasives_Native.Some y -> (l, e, y) - | uu___1 -> - let uu___2 = FStar_Syntax_DsEnv.push_bv e x in - (match uu___2 with | (e1, xbv) -> ((xbv :: l), e1, xbv)) in - let rec aux' top loc aqs env1 p1 = - let pos q = - FStar_Syntax_Syntax.withinfo q p1.FStar_Parser_AST.prange in - let pos_r r q = FStar_Syntax_Syntax.withinfo q r in - let orig = p1 in - match p1.FStar_Parser_AST.pat with - | FStar_Parser_AST.PatOr uu___ -> - failwith "impossible: PatOr handled below" - | FStar_Parser_AST.PatOp op -> - let id_op = - let uu___ = - let uu___1 = - let uu___2 = FStar_Ident.string_of_id op in - let uu___3 = FStar_Ident.range_of_id op in - FStar_Parser_AST.compile_op Prims.int_zero uu___2 uu___3 in - let uu___2 = FStar_Ident.range_of_id op in (uu___1, uu___2) in - FStar_Ident.mk_ident uu___ in - let p2 = - { - FStar_Parser_AST.pat = - (FStar_Parser_AST.PatVar - (id_op, FStar_Pervasives_Native.None, [])); - FStar_Parser_AST.prange = (p1.FStar_Parser_AST.prange) - } in - aux loc aqs env1 p2 - | FStar_Parser_AST.PatAscribed (p2, (t, tacopt)) -> - ((match tacopt with - | FStar_Pervasives_Native.None -> () - | FStar_Pervasives_Native.Some uu___1 -> - FStar_Errors.raise_error - FStar_Parser_AST.hasRange_pattern orig - FStar_Errors_Codes.Fatal_TypeWithinPatternsAllowedOnVariablesOnly - () (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Type ascriptions within patterns cannot be associated with a tactic")); - (let uu___1 = aux loc aqs env1 p2 in - match uu___1 with - | (loc1, aqs1, env', binder, p3, annots) -> - let uu___2 = - match binder with - | LetBinder uu___3 -> failwith "impossible" - | LocalBinder (x, aq, attrs) -> - let uu___3 = - let uu___4 = close_fun env1 t in - desugar_term_aq env1 uu___4 in - (match uu___3 with - | (t1, aqs') -> - let x1 = - { - FStar_Syntax_Syntax.ppname = - (x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (x.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = t1 - } in - ([(x1, t1, attrs)], - (LocalBinder (x1, aq, attrs)), - (FStar_Compiler_List.op_At aqs' aqs1))) in - (match uu___2 with - | (annots', binder1, aqs2) -> - ((match p3.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_var uu___4 -> () - | uu___4 when top && top_level_ascr_allowed -> () - | uu___4 -> - FStar_Errors.raise_error - FStar_Parser_AST.hasRange_pattern orig - FStar_Errors_Codes.Fatal_TypeWithinPatternsAllowedOnVariablesOnly - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Type ascriptions within patterns are only allowed on variables")); - (loc1, aqs2, env', binder1, p3, - (FStar_Compiler_List.op_At annots' annots)))))) - | FStar_Parser_AST.PatWild (aq, attrs) -> - let aq1 = trans_bqual env1 aq in - let attrs1 = FStar_Compiler_List.map (desugar_term env1) attrs in - let x = - let uu___ = tun_r p1.FStar_Parser_AST.prange in - FStar_Syntax_Syntax.new_bv - (FStar_Pervasives_Native.Some (p1.FStar_Parser_AST.prange)) - uu___ in - let uu___ = pos (FStar_Syntax_Syntax.Pat_var x) in - (loc, aqs, env1, (LocalBinder (x, aq1, attrs1)), uu___, []) - | FStar_Parser_AST.PatConst c -> - let x = - let uu___ = tun_r p1.FStar_Parser_AST.prange in - FStar_Syntax_Syntax.new_bv - (FStar_Pervasives_Native.Some (p1.FStar_Parser_AST.prange)) - uu___ in - let uu___ = pos (FStar_Syntax_Syntax.Pat_constant c) in - (loc, aqs, env1, - (LocalBinder (x, FStar_Pervasives_Native.None, [])), uu___, - []) - | FStar_Parser_AST.PatVQuote e -> - let pat = - let uu___ = - let uu___1 = - let uu___2 = - desugar_vquote env1 e p1.FStar_Parser_AST.prange in - (uu___2, (p1.FStar_Parser_AST.prange)) in - FStar_Const.Const_string uu___1 in - FStar_Parser_AST.PatConst uu___ in - aux' top loc aqs env1 - { - FStar_Parser_AST.pat = pat; - FStar_Parser_AST.prange = (p1.FStar_Parser_AST.prange) - } - | FStar_Parser_AST.PatTvar (x, aq, attrs) -> - let aq1 = trans_bqual env1 aq in - let attrs1 = FStar_Compiler_List.map (desugar_term env1) attrs in - let uu___ = resolvex loc env1 x in - (match uu___ with - | (loc1, env2, xbv) -> - let uu___1 = pos (FStar_Syntax_Syntax.Pat_var xbv) in - (loc1, aqs, env2, (LocalBinder (xbv, aq1, attrs1)), - uu___1, [])) - | FStar_Parser_AST.PatVar (x, aq, attrs) -> - let aq1 = trans_bqual env1 aq in - let attrs1 = FStar_Compiler_List.map (desugar_term env1) attrs in - let uu___ = resolvex loc env1 x in - (match uu___ with - | (loc1, env2, xbv) -> - let uu___1 = pos (FStar_Syntax_Syntax.Pat_var xbv) in - (loc1, aqs, env2, (LocalBinder (xbv, aq1, attrs1)), - uu___1, [])) - | FStar_Parser_AST.PatName l -> - let l1 = - FStar_Syntax_DsEnv.fail_or env1 - (FStar_Syntax_DsEnv.try_lookup_datacon env1) l in - let x = - let uu___ = tun_r p1.FStar_Parser_AST.prange in - FStar_Syntax_Syntax.new_bv - (FStar_Pervasives_Native.Some (p1.FStar_Parser_AST.prange)) - uu___ in - let uu___ = - pos - (FStar_Syntax_Syntax.Pat_cons - (l1, FStar_Pervasives_Native.None, [])) in - (loc, aqs, env1, - (LocalBinder (x, FStar_Pervasives_Native.None, [])), uu___, - []) - | FStar_Parser_AST.PatApp - ({ FStar_Parser_AST.pat = FStar_Parser_AST.PatName l; - FStar_Parser_AST.prange = uu___;_}, - args) - -> - let uu___1 = - FStar_Compiler_List.fold_right - (fun arg -> - fun uu___2 -> - match uu___2 with - | (loc1, aqs1, env2, annots, args1) -> - let uu___3 = aux loc1 aqs1 env2 arg in - (match uu___3 with - | (loc2, aqs2, env3, b, arg1, ans) -> - let imp = is_implicit b in - (loc2, aqs2, env3, - (FStar_Compiler_List.op_At ans annots), - ((arg1, imp) :: args1)))) args - (loc, aqs, env1, [], []) in - (match uu___1 with - | (loc1, aqs1, env2, annots, args1) -> - let l1 = - FStar_Syntax_DsEnv.fail_or env2 - (FStar_Syntax_DsEnv.try_lookup_datacon env2) l in - let x = - let uu___2 = tun_r p1.FStar_Parser_AST.prange in - FStar_Syntax_Syntax.new_bv - (FStar_Pervasives_Native.Some - (p1.FStar_Parser_AST.prange)) uu___2 in - let uu___2 = - pos - (FStar_Syntax_Syntax.Pat_cons - (l1, FStar_Pervasives_Native.None, args1)) in - (loc1, aqs1, env2, - (LocalBinder (x, FStar_Pervasives_Native.None, [])), - uu___2, annots)) - | FStar_Parser_AST.PatApp uu___ -> - FStar_Errors.raise_error FStar_Parser_AST.hasRange_pattern p1 - FStar_Errors_Codes.Fatal_UnexpectedPattern () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic "Unexpected pattern") - | FStar_Parser_AST.PatList pats -> - let uu___ = - FStar_Compiler_List.fold_right - (fun pat -> - fun uu___1 -> - match uu___1 with - | (loc1, aqs1, env2, annots, pats1) -> - let uu___2 = aux loc1 aqs1 env2 pat in - (match uu___2 with - | (loc2, aqs2, env3, uu___3, pat1, ans) -> - (loc2, aqs2, env3, - (FStar_Compiler_List.op_At ans annots), - (pat1 :: pats1)))) pats - (loc, aqs, env1, [], []) in - (match uu___ with - | (loc1, aqs1, env2, annots, pats1) -> - let pat = - let uu___1 = - let uu___2 = - FStar_Compiler_Range_Ops.end_range - p1.FStar_Parser_AST.prange in - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Syntax_Syntax.lid_and_dd_as_fv - FStar_Parser_Const.nil_lid - (FStar_Pervasives_Native.Some - FStar_Syntax_Syntax.Data_ctor) in - (uu___5, FStar_Pervasives_Native.None, []) in - FStar_Syntax_Syntax.Pat_cons uu___4 in - pos_r uu___2 uu___3 in - FStar_Compiler_List.fold_right - (fun hd -> - fun tl -> - let r = - FStar_Compiler_Range_Ops.union_ranges - hd.FStar_Syntax_Syntax.p - tl.FStar_Syntax_Syntax.p in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Syntax_Syntax.lid_and_dd_as_fv - FStar_Parser_Const.cons_lid - (FStar_Pervasives_Native.Some - FStar_Syntax_Syntax.Data_ctor) in - (uu___4, FStar_Pervasives_Native.None, - [(hd, false); (tl, false)]) in - FStar_Syntax_Syntax.Pat_cons uu___3 in - pos_r r uu___2) pats1 uu___1 in - let x = - let uu___1 = tun_r p1.FStar_Parser_AST.prange in - FStar_Syntax_Syntax.new_bv - (FStar_Pervasives_Native.Some - (p1.FStar_Parser_AST.prange)) uu___1 in - (loc1, aqs1, env2, - (LocalBinder (x, FStar_Pervasives_Native.None, [])), - pat, annots)) - | FStar_Parser_AST.PatTuple (args, dep) -> - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun p2 -> - match uu___1 with - | (loc1, aqs1, env2, annots, pats) -> - let uu___2 = aux loc1 aqs1 env2 p2 in - (match uu___2 with - | (loc2, aqs2, env3, uu___3, pat, ans) -> - (loc2, aqs2, env3, - (FStar_Compiler_List.op_At ans annots), - ((pat, false) :: pats)))) - (loc, aqs, env1, [], []) args in - (match uu___ with - | (loc1, aqs1, env2, annots, args1) -> - let args2 = FStar_Compiler_List.rev args1 in - let l = - if dep - then - FStar_Parser_Const.mk_dtuple_data_lid - (FStar_Compiler_List.length args2) - p1.FStar_Parser_AST.prange - else - FStar_Parser_Const.mk_tuple_data_lid - (FStar_Compiler_List.length args2) - p1.FStar_Parser_AST.prange in - let constr = - FStar_Syntax_DsEnv.fail_or env2 - (FStar_Syntax_DsEnv.try_lookup_lid env2) l in - let l1 = - match constr.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_fvar fv -> fv - | uu___1 -> failwith "impossible" in - let x = - let uu___1 = tun_r p1.FStar_Parser_AST.prange in - FStar_Syntax_Syntax.new_bv - (FStar_Pervasives_Native.Some - (p1.FStar_Parser_AST.prange)) uu___1 in - let uu___1 = - pos - (FStar_Syntax_Syntax.Pat_cons - (l1, FStar_Pervasives_Native.None, args2)) in - (loc1, aqs1, env2, - (LocalBinder (x, FStar_Pervasives_Native.None, [])), - uu___1, annots)) - | FStar_Parser_AST.PatRecord fields -> - let uu___ = FStar_Compiler_List.unzip fields in - (match uu___ with - | (field_names, pats) -> - let uu___1 = - match fields with - | [] -> (FStar_Pervasives_Native.None, field_names) - | (f, uu___2)::uu___3 -> - let uu___4 = - FStar_Syntax_DsEnv.try_lookup_record_by_field_name - env1 f in - (match uu___4 with - | FStar_Pervasives_Native.None -> - (FStar_Pervasives_Native.None, field_names) - | FStar_Pervasives_Native.Some r -> - let uu___5 = - qualify_field_names - r.FStar_Syntax_DsEnv.typename field_names in - ((FStar_Pervasives_Native.Some - (r.FStar_Syntax_DsEnv.typename)), uu___5)) in - (match uu___1 with - | (typename, field_names1) -> - let candidate_constructor = - let lid = - FStar_Ident.lid_of_path ["__dummy__"] - p1.FStar_Parser_AST.prange in - FStar_Syntax_Syntax.lid_and_dd_as_fv lid - (FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Unresolved_constructor - { - FStar_Syntax_Syntax.uc_base_term = false; - FStar_Syntax_Syntax.uc_typename = - typename; - FStar_Syntax_Syntax.uc_fields = - field_names1 - })) in - let uu___2 = - FStar_Compiler_List.fold_left - (fun uu___3 -> - fun p2 -> - match uu___3 with - | (loc1, aqs1, env2, annots, pats1) -> - let uu___4 = aux loc1 aqs1 env2 p2 in - (match uu___4 with - | (loc2, aqs2, env3, uu___5, pat, ann) - -> - (loc2, aqs2, env3, - (FStar_Compiler_List.op_At ann - annots), ((pat, false) :: - pats1)))) - (loc, aqs, env1, [], []) pats in - (match uu___2 with - | (loc1, aqs1, env2, annots, pats1) -> - let pats2 = FStar_Compiler_List.rev pats1 in - let pat = - pos - (FStar_Syntax_Syntax.Pat_cons - (candidate_constructor, - FStar_Pervasives_Native.None, pats2)) in - let x = - let uu___3 = tun_r p1.FStar_Parser_AST.prange in - FStar_Syntax_Syntax.new_bv - (FStar_Pervasives_Native.Some - (p1.FStar_Parser_AST.prange)) uu___3 in - (loc1, aqs1, env2, - (LocalBinder - (x, FStar_Pervasives_Native.None, [])), - pat, annots)))) - and aux loc aqs env1 p1 = aux' false loc aqs env1 p1 in - let aux_maybe_or env1 p1 = - let loc = [] in - match p1.FStar_Parser_AST.pat with - | FStar_Parser_AST.PatOr [] -> failwith "impossible" - | FStar_Parser_AST.PatOr (p2::ps) -> - let uu___ = aux' true loc [] env1 p2 in - (match uu___ with - | (loc1, aqs, env2, var, p3, ans) -> - let uu___1 = - FStar_Compiler_List.fold_left - (fun uu___2 -> - fun p4 -> - match uu___2 with - | (loc2, aqs1, env3, ps1) -> - let uu___3 = aux' true loc2 aqs1 env3 p4 in - (match uu___3 with - | (loc3, aqs2, env4, uu___4, p5, ans1) -> - (loc3, aqs2, env4, ((p5, ans1) :: ps1)))) - (loc1, aqs, env2, []) ps in - (match uu___1 with - | (loc2, aqs1, env3, ps1) -> - let pats = (p3, ans) :: (FStar_Compiler_List.rev ps1) in - ((env3, var, pats), aqs1))) - | uu___ -> - let uu___1 = aux' true loc [] env1 p1 in - (match uu___1 with - | (loc1, aqs, env2, var, pat, ans) -> - ((env2, var, [(pat, ans)]), aqs)) in - let uu___ = aux_maybe_or env p in - match uu___ with - | ((env1, b, pats), aqs) -> - ((let uu___2 = - FStar_Compiler_List.map FStar_Pervasives_Native.fst pats in - check_linear_pattern_variables uu___2 p.FStar_Parser_AST.prange); - ((env1, b, pats), aqs)) -and (desugar_binding_pat_maybe_top : - Prims.bool -> - FStar_Syntax_DsEnv.env -> - FStar_Parser_AST.pattern -> - ((env_t * bnd * annotated_pat Prims.list) * antiquotations_temp)) - = - fun top -> - fun env -> - fun p -> - if top - then - let mklet x ty tacopt = - let uu___ = - let uu___1 = - let uu___2 = FStar_Syntax_DsEnv.qualify env x in - (uu___2, (ty, tacopt)) in - LetBinder uu___1 in - (env, uu___, []) in - let op_to_ident x = - let uu___ = - let uu___1 = - let uu___2 = FStar_Ident.string_of_id x in - let uu___3 = FStar_Ident.range_of_id x in - FStar_Parser_AST.compile_op Prims.int_zero uu___2 uu___3 in - let uu___2 = FStar_Ident.range_of_id x in (uu___1, uu___2) in - FStar_Ident.mk_ident uu___ in - match p.FStar_Parser_AST.pat with - | FStar_Parser_AST.PatOp x -> - let uu___ = - let uu___1 = op_to_ident x in - let uu___2 = - let uu___3 = FStar_Ident.range_of_id x in tun_r uu___3 in - mklet uu___1 uu___2 FStar_Pervasives_Native.None in - (uu___, []) - | FStar_Parser_AST.PatVar (x, uu___, uu___1) -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_Ident.range_of_id x in tun_r uu___4 in - mklet x uu___3 FStar_Pervasives_Native.None in - (uu___2, []) - | FStar_Parser_AST.PatAscribed - ({ FStar_Parser_AST.pat = FStar_Parser_AST.PatOp x; - FStar_Parser_AST.prange = uu___;_}, - (t, tacopt)) - -> - let tacopt1 = - FStar_Compiler_Util.map_opt tacopt (desugar_term env) in - let uu___1 = desugar_term_aq env t in - (match uu___1 with - | (t1, aq) -> - let uu___2 = - let uu___3 = op_to_ident x in mklet uu___3 t1 tacopt1 in - (uu___2, aq)) - | FStar_Parser_AST.PatAscribed - ({ - FStar_Parser_AST.pat = FStar_Parser_AST.PatVar - (x, uu___, uu___1); - FStar_Parser_AST.prange = uu___2;_}, - (t, tacopt)) - -> - let tacopt1 = - FStar_Compiler_Util.map_opt tacopt (desugar_term env) in - let uu___3 = desugar_term_aq env t in - (match uu___3 with - | (t1, aq) -> let uu___4 = mklet x t1 tacopt1 in (uu___4, aq)) - | uu___ -> - FStar_Errors.raise_error FStar_Parser_AST.hasRange_pattern p - FStar_Errors_Codes.Fatal_UnexpectedPattern () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic "Unexpected pattern at the top-level") - else - (let uu___1 = desugar_data_pat true env p in - match uu___1 with - | ((env1, binder, p1), aq) -> - let p2 = - match p1 with - | ({ - FStar_Syntax_Syntax.v = FStar_Syntax_Syntax.Pat_var - uu___2; - FStar_Syntax_Syntax.p = uu___3;_}, - uu___4)::[] -> [] - | uu___2 -> p1 in - ((env1, binder, p2), aq)) -and (desugar_binding_pat_aq : - FStar_Syntax_DsEnv.env -> - FStar_Parser_AST.pattern -> - ((env_t * bnd * annotated_pat Prims.list) * antiquotations_temp)) - = fun env -> fun p -> desugar_binding_pat_maybe_top false env p -and (desugar_match_pat_maybe_top : - Prims.bool -> - env_t -> - FStar_Parser_AST.pattern -> - ((env_t * annotated_pat Prims.list) * antiquotations_temp)) - = - fun uu___ -> - fun env -> - fun pat -> - let uu___1 = desugar_data_pat false env pat in - match uu___1 with - | ((env1, uu___2, pat1), aqs) -> ((env1, pat1), aqs) -and (desugar_match_pat : - env_t -> - FStar_Parser_AST.pattern -> - ((env_t * annotated_pat Prims.list) * antiquotations_temp)) - = fun env -> fun p -> desugar_match_pat_maybe_top false env p -and (desugar_term_aq : - env_t -> - FStar_Parser_AST.term -> (FStar_Syntax_Syntax.term * antiquotations_temp)) - = - fun env -> - fun e -> - let env1 = FStar_Syntax_DsEnv.set_expect_typ env false in - desugar_term_maybe_top false env1 e -and (desugar_term : - FStar_Syntax_DsEnv.env -> FStar_Parser_AST.term -> FStar_Syntax_Syntax.term) - = - fun env -> - fun e -> - let uu___ = desugar_term_aq env e in - match uu___ with | (t, aq) -> (check_no_aq aq; t) -and (desugar_typ_aq : - FStar_Syntax_DsEnv.env -> - FStar_Parser_AST.term -> (FStar_Syntax_Syntax.term * antiquotations_temp)) - = - fun env -> - fun e -> - let env1 = FStar_Syntax_DsEnv.set_expect_typ env true in - desugar_term_maybe_top false env1 e -and (desugar_typ : - FStar_Syntax_DsEnv.env -> FStar_Parser_AST.term -> FStar_Syntax_Syntax.term) - = - fun env -> - fun e -> - let uu___ = desugar_typ_aq env e in - match uu___ with | (t, aq) -> (check_no_aq aq; t) -and (desugar_machine_integer : - FStar_Syntax_DsEnv.env -> - Prims.string -> - (FStar_Const.signedness * FStar_Const.width) -> - FStar_Compiler_Range_Type.range -> FStar_Syntax_Syntax.term) - = - fun env -> - fun repr -> - fun uu___ -> - fun range -> - match uu___ with - | (signedness, width) -> - let tnm = - if width = FStar_Const.Sizet - then "FStar.SizeT" - else - Prims.strcat "FStar." - (Prims.strcat - (match signedness with - | FStar_Const.Unsigned -> "U" - | FStar_Const.Signed -> "") - (Prims.strcat "Int" - (match width with - | FStar_Const.Int8 -> "8" - | FStar_Const.Int16 -> "16" - | FStar_Const.Int32 -> "32" - | FStar_Const.Int64 -> "64"))) in - ((let uu___2 = - let uu___3 = - FStar_Const.within_bounds repr signedness width in - Prims.op_Negation uu___3 in - if uu___2 - then - let uu___3 = - FStar_Compiler_Util.format2 - "%s is not in the expected range for %s" repr tnm in - FStar_Errors.log_issue FStar_Class_HasRange.hasRange_range - range FStar_Errors_Codes.Error_OutOfRange () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___3) - else ()); - (let private_intro_nm = - Prims.strcat tnm - (Prims.strcat ".__" - (Prims.strcat - (match signedness with - | FStar_Const.Unsigned -> "u" - | FStar_Const.Signed -> "") "int_to_t")) in - let intro_nm = - Prims.strcat tnm - (Prims.strcat "." - (Prims.strcat - (match signedness with - | FStar_Const.Unsigned -> "u" - | FStar_Const.Signed -> "") "int_to_t")) in - let lid = - let uu___2 = FStar_Ident.path_of_text intro_nm in - FStar_Ident.lid_of_path uu___2 range in - let lid1 = - let uu___2 = FStar_Syntax_DsEnv.try_lookup_lid env lid in - match uu___2 with - | FStar_Pervasives_Native.Some intro_term -> - (match intro_term.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_fvar fv -> - let private_lid = - let uu___3 = - FStar_Ident.path_of_text private_intro_nm in - FStar_Ident.lid_of_path uu___3 range in - let private_fv = - FStar_Syntax_Syntax.lid_and_dd_as_fv private_lid - fv.FStar_Syntax_Syntax.fv_qual in - { - FStar_Syntax_Syntax.n = - (FStar_Syntax_Syntax.Tm_fvar private_fv); - FStar_Syntax_Syntax.pos = - (intro_term.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = - (intro_term.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (intro_term.FStar_Syntax_Syntax.hash_code) - } - | uu___3 -> - failwith - (Prims.strcat "Unexpected non-fvar for " - intro_nm)) - | FStar_Pervasives_Native.None -> - let uu___3 = - FStar_Compiler_Util.format1 - "Unexpected numeric literal. Restart F* to load %s." - tnm in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range range - FStar_Errors_Codes.Fatal_UnexpectedNumericLiteral () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___3) in - let repr' = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_int - (repr, FStar_Pervasives_Native.None))) range in - let app = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Syntax.as_aqual_implicit false in - (repr', uu___6) in - [uu___5] in - { - FStar_Syntax_Syntax.hd = lid1; - FStar_Syntax_Syntax.args = uu___4 - } in - FStar_Syntax_Syntax.Tm_app uu___3 in - FStar_Syntax_Syntax.mk uu___2 range in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 = app; - FStar_Syntax_Syntax.meta = - (FStar_Syntax_Syntax.Meta_desugared - (FStar_Syntax_Syntax.Machine_integer - (signedness, width))) - }) range)) -and (desugar_term_maybe_top : - Prims.bool -> - env_t -> - FStar_Parser_AST.term -> - (FStar_Syntax_Syntax.term * antiquotations_temp)) - = - fun top_level -> - fun env -> - fun top -> - let mk e = FStar_Syntax_Syntax.mk e top.FStar_Parser_AST.range in - let noaqs = [] in - let join_aqs aqs = FStar_Compiler_List.flatten aqs in - let setpos e = - { - FStar_Syntax_Syntax.n = (e.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = (top.FStar_Parser_AST.range); - FStar_Syntax_Syntax.vars = (e.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = (e.FStar_Syntax_Syntax.hash_code) - } in - let desugar_binders env1 binders = - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun b -> - match uu___1 with - | (env2, bs) -> - let bb = desugar_binder env2 b in - let uu___2 = - as_binder env2 b.FStar_Parser_AST.aqual bb in - (match uu___2 with | (b1, env3) -> (env3, (b1 :: bs)))) - (env1, []) binders in - match uu___ with - | (env2, bs_rev) -> (env2, (FStar_Compiler_List.rev bs_rev)) in - let unqual_bv_of_binder b = - match b with - | { FStar_Syntax_Syntax.binder_bv = x; - FStar_Syntax_Syntax.binder_qual = FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.binder_positivity = uu___; - FStar_Syntax_Syntax.binder_attrs = [];_} -> x - | uu___ -> - FStar_Errors.raise_error FStar_Syntax_Syntax.hasRange_binder b - FStar_Errors_Codes.Fatal_UnexpectedTerm () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic "Unexpected qualified binder in ELIM_EXISTS") in - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_ToSyntax in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show FStar_Parser_AST.showable_term top in - FStar_Compiler_Util.print1 "desugaring (%s)\n\n" uu___2 - else ()); - (let uu___1 = let uu___2 = unparen top in uu___2.FStar_Parser_AST.tm in - match uu___1 with - | FStar_Parser_AST.Wild -> ((setpos FStar_Syntax_Syntax.tun), noaqs) - | FStar_Parser_AST.Labeled uu___2 -> - let uu___3 = desugar_formula env top in (uu___3, noaqs) - | FStar_Parser_AST.Requires (t, lopt) -> - let uu___2 = desugar_formula env t in (uu___2, noaqs) - | FStar_Parser_AST.Ensures (t, lopt) -> - let uu___2 = desugar_formula env t in (uu___2, noaqs) - | FStar_Parser_AST.Attributes ts -> - failwith - "Attributes should not be desugared by desugar_term_maybe_top" - | FStar_Parser_AST.Const (FStar_Const.Const_int - (i, FStar_Pervasives_Native.Some size)) -> - let uu___2 = - desugar_machine_integer env i size top.FStar_Parser_AST.range in - (uu___2, noaqs) - | FStar_Parser_AST.Const c -> - let uu___2 = mk (FStar_Syntax_Syntax.Tm_constant c) in - (uu___2, noaqs) - | FStar_Parser_AST.Op (id, args) when - let uu___2 = FStar_Ident.string_of_id id in uu___2 = "=!=" -> - let r = FStar_Ident.range_of_id id in - let e = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Ident.mk_ident ("==", r) in - (uu___4, args) in - FStar_Parser_AST.Op uu___3 in - FStar_Parser_AST.mk_term uu___2 top.FStar_Parser_AST.range - top.FStar_Parser_AST.level in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Ident.mk_ident ("~", r) in - (uu___5, [e]) in - FStar_Parser_AST.Op uu___4 in - FStar_Parser_AST.mk_term uu___3 top.FStar_Parser_AST.range - top.FStar_Parser_AST.level in - desugar_term_aq env uu___2 - | FStar_Parser_AST.Op (op_star, lhs::rhs::[]) when - (let uu___2 = FStar_Ident.string_of_id op_star in uu___2 = "*") - && - (let uu___2 = op_as_term env (Prims.of_int (2)) op_star in - FStar_Compiler_Option.isNone uu___2) - -> - let rec flatten t = - match t.FStar_Parser_AST.tm with - | FStar_Parser_AST.Op (id, t1::t2::[]) when - (let uu___2 = FStar_Ident.string_of_id id in uu___2 = "*") - && - (let uu___2 = op_as_term env (Prims.of_int (2)) op_star in - FStar_Compiler_Option.isNone uu___2) - -> - let uu___2 = flatten t1 in - FStar_Compiler_List.op_At uu___2 [t2] - | uu___2 -> [t] in - let terms = flatten lhs in - let t = - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Compiler_List.map - (fun uu___5 -> FStar_Pervasives.Inr uu___5) terms in - (uu___4, rhs) in - FStar_Parser_AST.Sum uu___3 in - { - FStar_Parser_AST.tm = uu___2; - FStar_Parser_AST.range = (top.FStar_Parser_AST.range); - FStar_Parser_AST.level = (top.FStar_Parser_AST.level) - } in - desugar_term_maybe_top top_level env t - | FStar_Parser_AST.Tvar a -> - let uu___2 = - let uu___3 = - FStar_Syntax_DsEnv.fail_or2 - (FStar_Syntax_DsEnv.try_lookup_id env) a in - setpos uu___3 in - (uu___2, noaqs) - | FStar_Parser_AST.Uvar u -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_Ident.string_of_id u in - Prims.strcat uu___4 " in non-universe context" in - Prims.strcat "Unexpected universe variable " uu___3 in - FStar_Errors.raise_error FStar_Parser_AST.hasRange_term top - FStar_Errors_Codes.Fatal_UnexpectedUniverseVariable () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2) - | FStar_Parser_AST.Op (s, f::e::[]) when - let uu___2 = FStar_Ident.string_of_id s in uu___2 = "<|" -> - let uu___2 = - FStar_Parser_AST.mkApp f [(e, FStar_Parser_AST.Nothing)] - top.FStar_Parser_AST.range in - desugar_term_maybe_top top_level env uu___2 - | FStar_Parser_AST.Op (s, e::f::[]) when - let uu___2 = FStar_Ident.string_of_id s in uu___2 = "|>" -> - let uu___2 = - FStar_Parser_AST.mkApp f [(e, FStar_Parser_AST.Nothing)] - top.FStar_Parser_AST.range in - desugar_term_maybe_top top_level env uu___2 - | FStar_Parser_AST.Op (s, args) -> - let uu___2 = op_as_term env (FStar_Compiler_List.length args) s in - (match uu___2 with - | FStar_Pervasives_Native.None -> - let uu___3 = - let uu___4 = FStar_Ident.string_of_id s in - Prims.strcat "Unexpected or unbound operator: " uu___4 in - FStar_Errors.raise_error FStar_Ident.hasrange_ident s - FStar_Errors_Codes.Fatal_UnepxectedOrUnboundOperator () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___3) - | FStar_Pervasives_Native.Some op -> - if (FStar_Compiler_List.length args) > Prims.int_zero - then - let uu___3 = - let uu___4 = - FStar_Compiler_List.map - (fun t -> - let uu___5 = desugar_term_aq env t in - match uu___5 with - | (t', s1) -> - ((t', FStar_Pervasives_Native.None), s1)) - args in - FStar_Compiler_List.unzip uu___4 in - (match uu___3 with - | (args1, aqs) -> - let uu___4 = - mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = op; - FStar_Syntax_Syntax.args = args1 - }) in - (uu___4, (join_aqs aqs))) - else (op, noaqs)) - | FStar_Parser_AST.Construct (n, (a, uu___2)::[]) when - let uu___3 = FStar_Ident.string_of_lid n in uu___3 = "SMTPat" -> - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = smt_pat_lid top.FStar_Parser_AST.range in - FStar_Parser_AST.Var uu___8 in - { - FStar_Parser_AST.tm = uu___7; - FStar_Parser_AST.range = (top.FStar_Parser_AST.range); - FStar_Parser_AST.level = (top.FStar_Parser_AST.level) - } in - (uu___6, a, FStar_Parser_AST.Nothing) in - FStar_Parser_AST.App uu___5 in - { - FStar_Parser_AST.tm = uu___4; - FStar_Parser_AST.range = (top.FStar_Parser_AST.range); - FStar_Parser_AST.level = (top.FStar_Parser_AST.level) - } in - desugar_term_maybe_top top_level env uu___3 - | FStar_Parser_AST.Construct (n, (a, uu___2)::[]) when - let uu___3 = FStar_Ident.string_of_lid n in uu___3 = "SMTPatT" - -> - (FStar_Errors.log_issue FStar_Parser_AST.hasRange_term top - FStar_Errors_Codes.Warning_SMTPatTDeprecated () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic "SMTPatT is deprecated; please just use SMTPat"); - (let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = smt_pat_lid top.FStar_Parser_AST.range in - FStar_Parser_AST.Var uu___9 in - { - FStar_Parser_AST.tm = uu___8; - FStar_Parser_AST.range = - (top.FStar_Parser_AST.range); - FStar_Parser_AST.level = - (top.FStar_Parser_AST.level) - } in - (uu___7, a, FStar_Parser_AST.Nothing) in - FStar_Parser_AST.App uu___6 in - { - FStar_Parser_AST.tm = uu___5; - FStar_Parser_AST.range = (top.FStar_Parser_AST.range); - FStar_Parser_AST.level = (top.FStar_Parser_AST.level) - } in - desugar_term_maybe_top top_level env uu___4)) - | FStar_Parser_AST.Construct (n, (a, uu___2)::[]) when - let uu___3 = FStar_Ident.string_of_lid n in uu___3 = "SMTPatOr" - -> - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = smt_pat_or_lid top.FStar_Parser_AST.range in - FStar_Parser_AST.Var uu___8 in - { - FStar_Parser_AST.tm = uu___7; - FStar_Parser_AST.range = (top.FStar_Parser_AST.range); - FStar_Parser_AST.level = (top.FStar_Parser_AST.level) - } in - (uu___6, a, FStar_Parser_AST.Nothing) in - FStar_Parser_AST.App uu___5 in - { - FStar_Parser_AST.tm = uu___4; - FStar_Parser_AST.range = (top.FStar_Parser_AST.range); - FStar_Parser_AST.level = (top.FStar_Parser_AST.level) - } in - desugar_term_maybe_top top_level env uu___3 - | FStar_Parser_AST.Name lid when - let uu___2 = FStar_Ident.string_of_lid lid in uu___2 = "Type0" - -> - let uu___2 = - mk (FStar_Syntax_Syntax.Tm_type FStar_Syntax_Syntax.U_zero) in - (uu___2, noaqs) - | FStar_Parser_AST.Name lid when - let uu___2 = FStar_Ident.string_of_lid lid in uu___2 = "Type" -> - let uu___2 = - mk (FStar_Syntax_Syntax.Tm_type FStar_Syntax_Syntax.U_unknown) in - (uu___2, noaqs) - | FStar_Parser_AST.Construct - (lid, (t, FStar_Parser_AST.UnivApp)::[]) when - let uu___2 = FStar_Ident.string_of_lid lid in uu___2 = "Type" -> - let uu___2 = - let uu___3 = - let uu___4 = desugar_universe t in - FStar_Syntax_Syntax.Tm_type uu___4 in - mk uu___3 in - (uu___2, noaqs) - | FStar_Parser_AST.Name lid when - let uu___2 = FStar_Ident.string_of_lid lid in uu___2 = "Effect" - -> - let uu___2 = - mk (FStar_Syntax_Syntax.Tm_constant FStar_Const.Const_effect) in - (uu___2, noaqs) - | FStar_Parser_AST.Name lid when - let uu___2 = FStar_Ident.string_of_lid lid in uu___2 = "True" -> - let uu___2 = - let uu___3 = - FStar_Ident.set_lid_range FStar_Parser_Const.true_lid - top.FStar_Parser_AST.range in - FStar_Syntax_Syntax.fvar_with_dd uu___3 - FStar_Pervasives_Native.None in - (uu___2, noaqs) - | FStar_Parser_AST.Name lid when - let uu___2 = FStar_Ident.string_of_lid lid in uu___2 = "False" - -> - let uu___2 = - let uu___3 = - FStar_Ident.set_lid_range FStar_Parser_Const.false_lid - top.FStar_Parser_AST.range in - FStar_Syntax_Syntax.fvar_with_dd uu___3 - FStar_Pervasives_Native.None in - (uu___2, noaqs) - | FStar_Parser_AST.Projector (eff_name, id) when - (let uu___2 = FStar_Ident.string_of_id id in - is_special_effect_combinator uu___2) && - (FStar_Syntax_DsEnv.is_effect_name env eff_name) - -> - let txt = FStar_Ident.string_of_id id in - let uu___2 = - FStar_Syntax_DsEnv.try_lookup_effect_defn env eff_name in - (match uu___2 with - | FStar_Pervasives_Native.Some ed -> - let lid = FStar_Syntax_Util.dm4f_lid ed txt in - let uu___3 = - FStar_Syntax_Syntax.fvar_with_dd lid - FStar_Pervasives_Native.None in - (uu___3, noaqs) - | FStar_Pervasives_Native.None -> - let uu___3 = - let uu___4 = FStar_Ident.string_of_lid eff_name in - FStar_Compiler_Util.format2 - "Member %s of effect %s is not accessible (using an effect abbreviation instead of the original effect ?)" - uu___4 txt in - failwith uu___3) - | FStar_Parser_AST.Var l -> - let uu___2 = desugar_name mk setpos env true l in - (uu___2, noaqs) - | FStar_Parser_AST.Name l -> - let uu___2 = desugar_name mk setpos env true l in - (uu___2, noaqs) - | FStar_Parser_AST.Projector (l, i) -> - let name = - let uu___2 = FStar_Syntax_DsEnv.try_lookup_datacon env l in - match uu___2 with - | FStar_Pervasives_Native.Some uu___3 -> - FStar_Pervasives_Native.Some (true, l) - | FStar_Pervasives_Native.None -> - let uu___3 = - FStar_Syntax_DsEnv.try_lookup_root_effect_name env l in - (match uu___3 with - | FStar_Pervasives_Native.Some new_name -> - FStar_Pervasives_Native.Some (false, new_name) - | uu___4 -> FStar_Pervasives_Native.None) in - (match name with - | FStar_Pervasives_Native.Some (resolve, new_name) -> - let uu___2 = - let uu___3 = - FStar_Syntax_Util.mk_field_projector_name_from_ident - new_name i in - desugar_name mk setpos env resolve uu___3 in - (uu___2, noaqs) - | uu___2 -> - let uu___3 = - let uu___4 = FStar_Ident.string_of_lid l in - FStar_Compiler_Util.format1 - "Data constructor or effect %s not found" uu___4 in - FStar_Errors.raise_error FStar_Parser_AST.hasRange_term top - FStar_Errors_Codes.Fatal_EffectNotFound () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___3)) - | FStar_Parser_AST.Discrim lid -> - let uu___2 = FStar_Syntax_DsEnv.try_lookup_datacon env lid in - (match uu___2 with - | FStar_Pervasives_Native.None -> - let uu___3 = - let uu___4 = FStar_Ident.string_of_lid lid in - FStar_Compiler_Util.format1 - "Data constructor %s not found" uu___4 in - FStar_Errors.raise_error FStar_Parser_AST.hasRange_term top - FStar_Errors_Codes.Fatal_DataContructorNotFound () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___3) - | uu___3 -> - let lid' = FStar_Syntax_Util.mk_discriminator lid in - let uu___4 = desugar_name mk setpos env true lid' in - (uu___4, noaqs)) - | FStar_Parser_AST.Construct (l, args) -> - let uu___2 = FStar_Syntax_DsEnv.try_lookup_datacon env l in - (match uu___2 with - | FStar_Pervasives_Native.Some head -> - let head1 = mk (FStar_Syntax_Syntax.Tm_fvar head) in - (match args with - | [] -> (head1, noaqs) - | uu___3 -> - let uu___4 = - FStar_Compiler_Util.take - (fun uu___5 -> - match uu___5 with - | (uu___6, imp) -> - imp = FStar_Parser_AST.UnivApp) args in - (match uu___4 with - | (universes, args1) -> - let universes1 = - FStar_Compiler_List.map - (fun x -> - desugar_universe - (FStar_Pervasives_Native.fst x)) - universes in - let uu___5 = - let uu___6 = - FStar_Compiler_List.map - (fun uu___7 -> - match uu___7 with - | (t, imp) -> - let uu___8 = desugar_term_aq env t in - (match uu___8 with - | (te, aq) -> - let uu___9 = - arg_withimp_t imp te in - (uu___9, aq))) args1 in - FStar_Compiler_List.unzip uu___6 in - (match uu___5 with - | (args2, aqs) -> - let head2 = - if universes1 = [] - then head1 - else - mk - (FStar_Syntax_Syntax.Tm_uinst - (head1, universes1)) in - let tm = - if - (FStar_Compiler_List.length args2) = - Prims.int_zero - then head2 - else - mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = head2; - FStar_Syntax_Syntax.args = args2 - }) in - (tm, (join_aqs aqs))))) - | FStar_Pervasives_Native.None -> - let uu___3 = - FStar_Syntax_DsEnv.try_lookup_effect_name env l in - (match uu___3 with - | FStar_Pervasives_Native.None -> - let uu___4 = - let uu___5 = - let uu___6 = FStar_Ident.string_of_lid l in - Prims.strcat uu___6 " not found" in - Prims.strcat "Constructor " uu___5 in - FStar_Errors.raise_error FStar_Ident.hasrange_lident l - FStar_Errors_Codes.Fatal_ConstructorNotFound () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4) - | FStar_Pervasives_Native.Some uu___4 -> - let uu___5 = - let uu___6 = - let uu___7 = FStar_Ident.string_of_lid l in - Prims.strcat uu___7 - " used at an unexpected position" in - Prims.strcat "Effect " uu___6 in - FStar_Errors.raise_error FStar_Ident.hasrange_lident l - FStar_Errors_Codes.Fatal_UnexpectedEffect () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___5))) - | FStar_Parser_AST.Sum (binders, t) when - FStar_Compiler_Util.for_all - (fun uu___2 -> - match uu___2 with - | FStar_Pervasives.Inr uu___3 -> true - | uu___3 -> false) binders - -> - let terms = - let uu___2 = - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with - | FStar_Pervasives.Inr x -> x - | FStar_Pervasives.Inl uu___4 -> failwith "Impossible") - binders in - FStar_Compiler_List.op_At uu___2 [t] in - let uu___2 = - let uu___3 = - FStar_Compiler_List.map - (fun t1 -> - let uu___4 = desugar_typ_aq env t1 in - match uu___4 with - | (t', aq) -> - let uu___5 = FStar_Syntax_Syntax.as_arg t' in - (uu___5, aq)) terms in - FStar_Compiler_List.unzip uu___3 in - (match uu___2 with - | (targs, aqs) -> - let tup = - let uu___3 = - FStar_Parser_Const.mk_tuple_lid - (FStar_Compiler_List.length targs) - top.FStar_Parser_AST.range in - FStar_Syntax_DsEnv.fail_or env - (FStar_Syntax_DsEnv.try_lookup_lid env) uu___3 in - let uu___3 = - mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = tup; - FStar_Syntax_Syntax.args = targs - }) in - (uu___3, (join_aqs aqs))) - | FStar_Parser_AST.Sum (binders, t) -> - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Parser_AST.mk_binder (FStar_Parser_AST.NoName t) - t.FStar_Parser_AST.range FStar_Parser_AST.Type_level - FStar_Pervasives_Native.None in - FStar_Pervasives.Inl uu___6 in - [uu___5] in - FStar_Compiler_List.op_At binders uu___4 in - FStar_Compiler_List.fold_left - (fun uu___4 -> - fun b -> - match uu___4 with - | (env1, tparams, typs) -> - let uu___5 = - match b with - | FStar_Pervasives.Inl b1 -> - desugar_binder env1 b1 - | FStar_Pervasives.Inr t1 -> - let uu___6 = desugar_typ env1 t1 in - (FStar_Pervasives_Native.None, uu___6, []) in - (match uu___5 with - | (xopt, t1, attrs) -> - let uu___6 = - match xopt with - | FStar_Pervasives_Native.None -> - let uu___7 = - FStar_Syntax_Syntax.new_bv - (FStar_Pervasives_Native.Some - (top.FStar_Parser_AST.range)) - (setpos FStar_Syntax_Syntax.tun) in - (env1, uu___7) - | FStar_Pervasives_Native.Some x -> - FStar_Syntax_DsEnv.push_bv env1 x in - (match uu___6 with - | (env2, x) -> - let uu___7 = - let uu___8 = - let uu___9 = - mk_binder_with_attrs - { - FStar_Syntax_Syntax.ppname = - (x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (x.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = t1 - } FStar_Pervasives_Native.None - attrs in - [uu___9] in - FStar_Compiler_List.op_At tparams - uu___8 in - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - no_annot_abs tparams t1 in - FStar_Syntax_Syntax.as_arg uu___11 in - [uu___10] in - FStar_Compiler_List.op_At typs uu___9 in - (env2, uu___7, uu___8)))) (env, [], []) - uu___3 in - (match uu___2 with - | (env1, uu___3, targs) -> - let tup = - let uu___4 = - FStar_Parser_Const.mk_dtuple_lid - (FStar_Compiler_List.length targs) - top.FStar_Parser_AST.range in - FStar_Syntax_DsEnv.fail_or env1 - (FStar_Syntax_DsEnv.try_lookup_lid env1) uu___4 in - let uu___4 = - mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = tup; - FStar_Syntax_Syntax.args = targs - }) in - (uu___4, noaqs)) - | FStar_Parser_AST.Product (binders, t) -> - let uu___2 = uncurry binders t in - (match uu___2 with - | (bs, t1) -> - let rec aux env1 aqs bs1 uu___3 = - match uu___3 with - | [] -> - let cod = - desugar_comp top.FStar_Parser_AST.range true env1 - t1 in - let uu___4 = - let uu___5 = - FStar_Syntax_Util.arrow - (FStar_Compiler_List.rev bs1) cod in - setpos uu___5 in - (uu___4, aqs) - | hd::tl -> - let uu___4 = desugar_binder_aq env1 hd in - (match uu___4 with - | (bb, aqs') -> - let uu___5 = - as_binder env1 hd.FStar_Parser_AST.aqual bb in - (match uu___5 with - | (b, env2) -> - aux env2 - (FStar_Compiler_List.op_At aqs' aqs) (b - :: bs1) tl)) in - aux env [] [] bs) - | FStar_Parser_AST.Refine (b, f) -> - let uu___2 = desugar_binder env b in - (match uu___2 with - | (FStar_Pervasives_Native.None, uu___3, uu___4) -> - failwith "Missing binder in refinement" - | b1 -> - let uu___3 = as_binder env FStar_Pervasives_Native.None b1 in - (match uu___3 with - | (b2, env1) -> - let f1 = desugar_formula env1 f in - let uu___4 = - let uu___5 = - FStar_Syntax_Util.refine - b2.FStar_Syntax_Syntax.binder_bv f1 in - setpos uu___5 in - (uu___4, noaqs))) - | FStar_Parser_AST.Function (branches, r1) -> - let x = FStar_Ident.gen r1 in - let t' = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Parser_AST.mk_pattern - (FStar_Parser_AST.PatVar - (x, FStar_Pervasives_Native.None, [])) r1 in - [uu___5] in - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = FStar_Ident.lid_of_ids [x] in - FStar_Parser_AST.Var uu___10 in - FStar_Parser_AST.mk_term uu___9 r1 - FStar_Parser_AST.Expr in - (uu___8, FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None, branches) in - FStar_Parser_AST.Match uu___7 in - FStar_Parser_AST.mk_term uu___6 - top.FStar_Parser_AST.range FStar_Parser_AST.Expr in - (uu___4, uu___5) in - FStar_Parser_AST.Abs uu___3 in - FStar_Parser_AST.mk_term uu___2 top.FStar_Parser_AST.range - FStar_Parser_AST.Expr in - desugar_term_maybe_top top_level env t' - | FStar_Parser_AST.Abs (binders, body) -> - let bvss = - FStar_Compiler_List.map gather_pattern_bound_vars binders in - let check_disjoint sets = - let rec aux acc sets1 = - match sets1 with - | [] -> FStar_Pervasives_Native.None - | set::sets2 -> - let i = - Obj.magic - (FStar_Class_Setlike.inter () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_ident)) - (Obj.magic acc) (Obj.magic set)) in - let uu___2 = - FStar_Class_Setlike.is_empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_ident)) (Obj.magic i) in - if uu___2 - then - let uu___3 = - Obj.magic - (FStar_Class_Setlike.union () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_ident)) - (Obj.magic acc) (Obj.magic set)) in - aux uu___3 sets2 - else - (let uu___4 = - let uu___5 = - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_ident)) - (Obj.magic i) in - FStar_Compiler_List.hd uu___5 in - FStar_Pervasives_Native.Some uu___4) in - let uu___2 = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_ident)) ()) in - aux uu___2 sets in - ((let uu___3 = check_disjoint bvss in - match uu___3 with - | FStar_Pervasives_Native.None -> () - | FStar_Pervasives_Native.Some id -> - let uu___4 = - let uu___5 = - FStar_Errors_Msg.text - "Non-linear patterns are not permitted." in - let uu___6 = - let uu___7 = - let uu___8 = FStar_Errors_Msg.text "The variable " in - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Class_PP.pp FStar_Ident.pretty_ident id in - FStar_Pprint.squotes uu___11 in - let uu___11 = - FStar_Errors_Msg.text - " appears more than once in this function definition." in - FStar_Pprint.op_Hat_Slash_Hat uu___10 uu___11 in - FStar_Pprint.op_Hat_Slash_Hat uu___8 uu___9 in - [uu___7] in - uu___5 :: uu___6 in - FStar_Errors.raise_error FStar_Ident.hasrange_ident id - FStar_Errors_Codes.Fatal_NonLinearPatternNotPermitted () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___4)); - (let binders1 = - FStar_Compiler_List.map replace_unit_pattern binders in - let uu___3 = - FStar_Compiler_List.fold_left - (fun uu___4 -> - fun pat -> - match uu___4 with - | (env1, ftvs) -> - (match pat.FStar_Parser_AST.pat with - | FStar_Parser_AST.PatAscribed - (uu___5, (t, FStar_Pervasives_Native.None)) - -> - let uu___6 = - let uu___7 = free_type_vars env1 t in - FStar_Compiler_List.op_At uu___7 ftvs in - (env1, uu___6) - | FStar_Parser_AST.PatAscribed - (uu___5, - (t, FStar_Pervasives_Native.Some tac)) - -> - let uu___6 = - let uu___7 = free_type_vars env1 t in - let uu___8 = - let uu___9 = free_type_vars env1 tac in - FStar_Compiler_List.op_At uu___9 ftvs in - FStar_Compiler_List.op_At uu___7 uu___8 in - (env1, uu___6) - | uu___5 -> (env1, ftvs))) (env, []) binders1 in - match uu___3 with - | (uu___4, ftv) -> - let ftv1 = sort_ftv ftv in - let binders2 = - let uu___5 = - FStar_Compiler_List.map - (fun a -> - FStar_Parser_AST.mk_pattern - (FStar_Parser_AST.PatTvar - (a, - (FStar_Pervasives_Native.Some - FStar_Parser_AST.Implicit), [])) - top.FStar_Parser_AST.range) ftv1 in - FStar_Compiler_List.op_At uu___5 binders1 in - let rec aux aqs env1 bs sc_pat_opt pats = - match pats with - | [] -> - let uu___5 = desugar_term_aq env1 body in - (match uu___5 with - | (body1, aq) -> - let body2 = - match sc_pat_opt with - | FStar_Pervasives_Native.Some (sc, pat) -> - let body3 = - let uu___6 = - let uu___7 = - FStar_Syntax_Syntax.pat_bvs pat in - FStar_Compiler_List.map - FStar_Syntax_Syntax.mk_binder - uu___7 in - FStar_Syntax_Subst.close uu___6 body1 in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_match - { - FStar_Syntax_Syntax.scrutinee = sc; - FStar_Syntax_Syntax.ret_opt = - FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.brs = - [(pat, - FStar_Pervasives_Native.None, - body3)]; - FStar_Syntax_Syntax.rc_opt1 = - FStar_Pervasives_Native.None - }) body3.FStar_Syntax_Syntax.pos - | FStar_Pervasives_Native.None -> body1 in - let uu___6 = - let uu___7 = - no_annot_abs (FStar_Compiler_List.rev bs) - body2 in - setpos uu___7 in - (uu___6, (FStar_Compiler_List.op_At aq aqs))) - | p::rest -> - let uu___5 = desugar_binding_pat_aq env1 p in - (match uu___5 with - | ((env2, b, pat), aq) -> - let pat1 = - match pat with - | [] -> FStar_Pervasives_Native.None - | (p1, uu___6)::[] -> - FStar_Pervasives_Native.Some p1 - | uu___6 -> - FStar_Errors.raise_error - FStar_Parser_AST.hasRange_pattern p - FStar_Errors_Codes.Fatal_UnsupportedDisjuctivePatterns - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Disjunctive patterns are not supported in abstractions") in - let uu___6 = - match b with - | LetBinder uu___7 -> failwith "Impossible" - | LocalBinder (x, aq1, attrs) -> - let sc_pat_opt1 = - match (pat1, sc_pat_opt) with - | (FStar_Pervasives_Native.None, - uu___7) -> sc_pat_opt - | (FStar_Pervasives_Native.Some p1, - FStar_Pervasives_Native.None) -> - let uu___7 = - let uu___8 = - FStar_Syntax_Syntax.bv_to_name - x in - (uu___8, p1) in - FStar_Pervasives_Native.Some uu___7 - | (FStar_Pervasives_Native.Some p1, - FStar_Pervasives_Native.Some - (sc, p')) -> - (match ((sc.FStar_Syntax_Syntax.n), - (p'.FStar_Syntax_Syntax.v)) - with - | (FStar_Syntax_Syntax.Tm_name - uu___7, uu___8) -> - let tup2 = - let uu___9 = - FStar_Parser_Const.mk_tuple_data_lid - (Prims.of_int (2)) - top.FStar_Parser_AST.range in - FStar_Syntax_Syntax.lid_and_dd_as_fv - uu___9 - (FStar_Pervasives_Native.Some - FStar_Syntax_Syntax.Data_ctor) in - let sc1 = - let uu___9 = - let uu___10 = - let uu___11 = - mk - (FStar_Syntax_Syntax.Tm_fvar - tup2) in - let uu___12 = - let uu___13 = - FStar_Syntax_Syntax.as_arg - sc in - let uu___14 = - let uu___15 = - let uu___16 = - FStar_Syntax_Syntax.bv_to_name - x in - FStar_Syntax_Syntax.as_arg - uu___16 in - [uu___15] in - uu___13 :: uu___14 in - { - FStar_Syntax_Syntax.hd - = uu___11; - FStar_Syntax_Syntax.args - = uu___12 - } in - FStar_Syntax_Syntax.Tm_app - uu___10 in - FStar_Syntax_Syntax.mk - uu___9 - top.FStar_Parser_AST.range in - let p2 = - let uu___9 = - FStar_Compiler_Range_Ops.union_ranges - p'.FStar_Syntax_Syntax.p - p1.FStar_Syntax_Syntax.p in - FStar_Syntax_Syntax.withinfo - (FStar_Syntax_Syntax.Pat_cons - (tup2, - FStar_Pervasives_Native.None, - [(p', false); - (p1, false)])) uu___9 in - FStar_Pervasives_Native.Some - (sc1, p2) - | (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - uu___7; - FStar_Syntax_Syntax.args = - args;_}, - FStar_Syntax_Syntax.Pat_cons - (uu___8, uu___9, pats1)) -> - let tupn = - let uu___10 = - FStar_Parser_Const.mk_tuple_data_lid - (Prims.int_one + - (FStar_Compiler_List.length - args)) - top.FStar_Parser_AST.range in - FStar_Syntax_Syntax.lid_and_dd_as_fv - uu___10 - (FStar_Pervasives_Native.Some - FStar_Syntax_Syntax.Data_ctor) in - let sc1 = - let uu___10 = - let uu___11 = - let uu___12 = - mk - (FStar_Syntax_Syntax.Tm_fvar - tupn) in - let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = - FStar_Syntax_Syntax.bv_to_name - x in - FStar_Syntax_Syntax.as_arg - uu___16 in - [uu___15] in - FStar_Compiler_List.op_At - args uu___14 in - { - FStar_Syntax_Syntax.hd - = uu___12; - FStar_Syntax_Syntax.args - = uu___13 - } in - FStar_Syntax_Syntax.Tm_app - uu___11 in - mk uu___10 in - let p2 = - let uu___10 = - FStar_Compiler_Range_Ops.union_ranges - p'.FStar_Syntax_Syntax.p - p1.FStar_Syntax_Syntax.p in - FStar_Syntax_Syntax.withinfo - (FStar_Syntax_Syntax.Pat_cons - (tupn, - FStar_Pervasives_Native.None, - (FStar_Compiler_List.op_At - pats1 - [(p1, false)]))) - uu___10 in - FStar_Pervasives_Native.Some - (sc1, p2) - | uu___7 -> failwith "Impossible") in - let uu___7 = - mk_binder_with_attrs x aq1 attrs in - (uu___7, sc_pat_opt1) in - (match uu___6 with - | (b1, sc_pat_opt1) -> - aux (FStar_Compiler_List.op_At aq aqs) - env2 (b1 :: bs) sc_pat_opt1 rest)) in - aux [] env [] FStar_Pervasives_Native.None binders2)) - | FStar_Parser_AST.App (uu___2, uu___3, FStar_Parser_AST.UnivApp) -> - let rec aux universes e = - let uu___4 = - let uu___5 = unparen e in uu___5.FStar_Parser_AST.tm in - match uu___4 with - | FStar_Parser_AST.App (e1, t, FStar_Parser_AST.UnivApp) -> - let univ_arg = desugar_universe t in - aux (univ_arg :: universes) e1 - | uu___5 -> - let uu___6 = desugar_term_aq env e in - (match uu___6 with - | (head, aq) -> - let uu___7 = - mk (FStar_Syntax_Syntax.Tm_uinst (head, universes)) in - (uu___7, aq)) in - aux [] top - | FStar_Parser_AST.App (e, t, imp) -> - let uu___2 = desugar_term_aq env e in - (match uu___2 with - | (head, aq1) -> - let uu___3 = desugar_term_aq env t in - (match uu___3 with - | (t1, aq2) -> - let arg = arg_withimp_t imp t1 in - let uu___4 = - FStar_Syntax_Syntax.extend_app head arg - top.FStar_Parser_AST.range in - (uu___4, (FStar_Compiler_List.op_At aq1 aq2)))) - | FStar_Parser_AST.Bind (x, t1, t2) -> - let xpat = - let uu___2 = FStar_Ident.range_of_id x in - FStar_Parser_AST.mk_pattern - (FStar_Parser_AST.PatVar - (x, FStar_Pervasives_Native.None, [])) uu___2 in - let k = - FStar_Parser_AST.mk_term (FStar_Parser_AST.Abs ([xpat], t2)) - t2.FStar_Parser_AST.range t2.FStar_Parser_AST.level in - let bind_lid = - let uu___2 = FStar_Ident.range_of_id x in - FStar_Ident.lid_of_path ["bind"] uu___2 in - let bind = - let uu___2 = FStar_Ident.range_of_id x in - FStar_Parser_AST.mk_term (FStar_Parser_AST.Var bind_lid) - uu___2 FStar_Parser_AST.Expr in - let uu___2 = - FStar_Parser_AST.mkExplicitApp bind [t1; k] - top.FStar_Parser_AST.range in - desugar_term_aq env uu___2 - | FStar_Parser_AST.Seq (t1, t2) -> - let p = - FStar_Parser_AST.mk_pattern - (FStar_Parser_AST.PatWild (FStar_Pervasives_Native.None, [])) - t1.FStar_Parser_AST.range in - let p1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = unit_ty p.FStar_Parser_AST.prange in - (uu___5, FStar_Pervasives_Native.None) in - (p, uu___4) in - FStar_Parser_AST.PatAscribed uu___3 in - FStar_Parser_AST.mk_pattern uu___2 p.FStar_Parser_AST.prange in - let t = - FStar_Parser_AST.mk_term - (FStar_Parser_AST.Let - (FStar_Parser_AST.NoLetQualifier, - [(FStar_Pervasives_Native.None, (p1, t1))], t2)) - top.FStar_Parser_AST.range FStar_Parser_AST.Expr in - let uu___2 = desugar_term_aq env t in - (match uu___2 with - | (tm, s) -> - let uu___3 = - mk - (FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 = tm; - FStar_Syntax_Syntax.meta = - (FStar_Syntax_Syntax.Meta_desugared - FStar_Syntax_Syntax.Sequence) - }) in - (uu___3, s)) - | FStar_Parser_AST.LetOpen (lid, e) -> - let env1 = - FStar_Syntax_DsEnv.push_namespace env lid - FStar_Syntax_Syntax.Unrestricted in - let uu___2 = - let uu___3 = FStar_Syntax_DsEnv.expect_typ env1 in - if uu___3 then desugar_typ_aq else desugar_term_aq in - uu___2 env1 e - | FStar_Parser_AST.LetOpenRecord (r, rty, e) -> - let rec head_of t = - match t.FStar_Parser_AST.tm with - | FStar_Parser_AST.App (t1, uu___2, uu___3) -> head_of t1 - | uu___2 -> t in - let tycon = head_of rty in - let tycon_name = - match tycon.FStar_Parser_AST.tm with - | FStar_Parser_AST.Var l -> l - | uu___2 -> - let uu___3 = - let uu___4 = FStar_Parser_AST.term_to_string rty in - FStar_Compiler_Util.format1 - "This type must be a (possibly applied) record name" - uu___4 in - FStar_Errors.raise_error FStar_Parser_AST.hasRange_term - rty FStar_Errors_Codes.Error_BadLetOpenRecord () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___3) in - let record = - let uu___2 = - FStar_Syntax_DsEnv.try_lookup_record_type env tycon_name in - match uu___2 with - | FStar_Pervasives_Native.Some r1 -> r1 - | FStar_Pervasives_Native.None -> - let uu___3 = - let uu___4 = FStar_Parser_AST.term_to_string rty in - FStar_Compiler_Util.format1 "Not a record type: `%s`" - uu___4 in - FStar_Errors.raise_error FStar_Parser_AST.hasRange_term - rty FStar_Errors_Codes.Error_BadLetOpenRecord () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___3) in - let constrname = - let uu___2 = - FStar_Ident.ns_of_lid record.FStar_Syntax_DsEnv.typename in - FStar_Ident.lid_of_ns_and_id uu___2 - record.FStar_Syntax_DsEnv.constrname in - let mk_pattern p = - FStar_Parser_AST.mk_pattern p r.FStar_Parser_AST.range in - let elab = - let pat = - let uu___2 = - let uu___3 = - let uu___4 = - mk_pattern (FStar_Parser_AST.PatName constrname) in - let uu___5 = - FStar_Compiler_List.map - (fun uu___6 -> - match uu___6 with - | (field, uu___7) -> - mk_pattern - (FStar_Parser_AST.PatVar - (field, FStar_Pervasives_Native.None, - []))) record.FStar_Syntax_DsEnv.fields in - (uu___4, uu___5) in - FStar_Parser_AST.PatApp uu___3 in - mk_pattern uu___2 in - let branch = (pat, FStar_Pervasives_Native.None, e) in - let r1 = - FStar_Parser_AST.mk_term - (FStar_Parser_AST.Ascribed - (r, rty, FStar_Pervasives_Native.None, false)) - r.FStar_Parser_AST.range FStar_Parser_AST.Expr in - { - FStar_Parser_AST.tm = - (FStar_Parser_AST.Match - (r1, FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None, [branch])); - FStar_Parser_AST.range = (top.FStar_Parser_AST.range); - FStar_Parser_AST.level = (top.FStar_Parser_AST.level) - } in - desugar_term_maybe_top top_level env elab - | FStar_Parser_AST.LetOperator (lets, body) -> - (match lets with - | [] -> - failwith - "Impossible: a LetOperator (e.g. let+, let*...) cannot contain zero let binding" - | (letOp, letPat, letDef)::tl -> - let term_of_op op = - let uu___2 = FStar_Ident.range_of_id op in - FStar_Parser_AST.mk_term (FStar_Parser_AST.Op (op, [])) - uu___2 FStar_Parser_AST.Expr in - let mproduct_def = - FStar_Compiler_List.fold_left - (fun def -> - fun uu___2 -> - match uu___2 with - | (andOp, andPat, andDef) -> - let uu___3 = term_of_op andOp in - FStar_Parser_AST.mkExplicitApp uu___3 - [def; andDef] top.FStar_Parser_AST.range) - letDef tl in - let mproduct_pat = - FStar_Compiler_List.fold_left - (fun pat -> - fun uu___2 -> - match uu___2 with - | (andOp, andPat, andDef) -> - FStar_Parser_AST.mk_pattern - (FStar_Parser_AST.PatTuple - ([pat; andPat], false)) - andPat.FStar_Parser_AST.prange) letPat tl in - let fn = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = hoist_pat_ascription mproduct_pat in - [uu___5] in - (uu___4, body) in - FStar_Parser_AST.Abs uu___3 in - FStar_Parser_AST.mk_term uu___2 - body.FStar_Parser_AST.range body.FStar_Parser_AST.level in - let let_op = term_of_op letOp in - let t = - FStar_Parser_AST.mkExplicitApp let_op [mproduct_def; fn] - top.FStar_Parser_AST.range in - desugar_term_aq env t) - | FStar_Parser_AST.Let (qual, lbs, body) -> - let is_rec = qual = FStar_Parser_AST.Rec in - let ds_let_rec_or_app uu___2 = - let bindings = lbs in - let funs = - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with - | (attr_opt, (p, def)) -> - let uu___4 = is_app_pattern p in - if uu___4 - then - let uu___5 = destruct_app_pattern env top_level p in - (attr_opt, uu___5, def) - else - (let uu___6 = FStar_Parser_AST.un_function p def in - match uu___6 with - | FStar_Pervasives_Native.Some (p1, def1) -> - let uu___7 = - destruct_app_pattern env top_level p1 in - (attr_opt, uu___7, def1) - | uu___7 -> - (match p.FStar_Parser_AST.pat with - | FStar_Parser_AST.PatAscribed - ({ - FStar_Parser_AST.pat = - FStar_Parser_AST.PatVar - (id, uu___8, uu___9); - FStar_Parser_AST.prange = uu___10;_}, - t) - -> - if top_level - then - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Syntax_DsEnv.qualify env - id in - FStar_Pervasives.Inr uu___13 in - (uu___12, [], - (FStar_Pervasives_Native.Some t)) in - (attr_opt, uu___11, def) - else - (attr_opt, - ((FStar_Pervasives.Inl id), [], - (FStar_Pervasives_Native.Some t)), - def) - | FStar_Parser_AST.PatVar - (id, uu___8, uu___9) -> - if top_level - then - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Syntax_DsEnv.qualify env - id in - FStar_Pervasives.Inr uu___12 in - (uu___11, [], - FStar_Pervasives_Native.None) in - (attr_opt, uu___10, def) - else - (attr_opt, - ((FStar_Pervasives.Inl id), [], - FStar_Pervasives_Native.None), - def) - | uu___8 -> - FStar_Errors.raise_error - FStar_Parser_AST.hasRange_pattern p - FStar_Errors_Codes.Fatal_UnexpectedLetBinding - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic "Unexpected let binding")))) - bindings in - let uu___3 = - FStar_Compiler_List.fold_left - (fun uu___4 -> - fun uu___5 -> - match (uu___4, uu___5) with - | ((env1, fnames, rec_bindings, used_markers), - (_attr_opt, (f, uu___6, uu___7), uu___8)) -> - let uu___9 = - match f with - | FStar_Pervasives.Inl x -> - let uu___10 = - FStar_Syntax_DsEnv.push_bv' env1 x in - (match uu___10 with - | (env2, xx, used_marker) -> - let dummy_ref = - FStar_Compiler_Util.mk_ref true in - let uu___11 = - let uu___12 = - FStar_Syntax_Syntax.mk_binder xx in - uu___12 :: rec_bindings in - (env2, (FStar_Pervasives.Inl xx), - uu___11, (used_marker :: - used_markers))) - | FStar_Pervasives.Inr l -> - let uu___10 = - let uu___11 = FStar_Ident.ident_of_lid l in - FStar_Syntax_DsEnv.push_top_level_rec_binding - env1 uu___11 in - (match uu___10 with - | (env2, used_marker) -> - (env2, (FStar_Pervasives.Inr l), - rec_bindings, (used_marker :: - used_markers))) in - (match uu___9 with - | (env2, lbname, rec_bindings1, used_markers1) - -> - (env2, (lbname :: fnames), rec_bindings1, - used_markers1))) (env, [], [], []) funs in - match uu___3 with - | (env', fnames, rec_bindings, used_markers) -> - let fnames1 = FStar_Compiler_List.rev fnames in - let rec_bindings1 = FStar_Compiler_List.rev rec_bindings in - let used_markers1 = FStar_Compiler_List.rev used_markers in - let desugar_one_def env1 lbname uu___4 = - match uu___4 with - | (attrs_opt, (uu___5, args, result_t), def) -> - let args1 = - FStar_Compiler_List.map replace_unit_pattern args in - let pos = def.FStar_Parser_AST.range in - let def1 = - match result_t with - | FStar_Pervasives_Native.None -> def - | FStar_Pervasives_Native.Some (t, tacopt) -> - let t1 = - let uu___6 = is_comp_type env1 t in - if uu___6 - then - ((let uu___8 = - FStar_Compiler_List.tryFind - (fun x -> - let uu___9 = is_var_pattern x in - Prims.op_Negation uu___9) args1 in - match uu___8 with - | FStar_Pervasives_Native.None -> () - | FStar_Pervasives_Native.Some p -> - FStar_Errors.raise_error - FStar_Parser_AST.hasRange_pattern - p - FStar_Errors_Codes.Fatal_ComputationTypeNotAllowed - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Computation type annotations are only permitted on let-bindings without inlined patterns; replace this pattern with a variable")); - t) - else - (let uu___8 = - ((FStar_Options.ml_ish ()) && - (let uu___9 = - let uu___10 = - FStar_Parser_Const.effect_ML_lid - () in - FStar_Syntax_DsEnv.try_lookup_effect_name - env1 uu___10 in - FStar_Compiler_Option.isSome uu___9)) - && - ((Prims.op_Negation is_rec) || - ((FStar_Compiler_List.length args1) - <> Prims.int_zero)) in - if uu___8 - then FStar_Parser_AST.ml_comp t - else FStar_Parser_AST.tot_comp t) in - FStar_Parser_AST.mk_term - (FStar_Parser_AST.Ascribed - (def, t1, tacopt, false)) - def.FStar_Parser_AST.range - FStar_Parser_AST.Expr in - let def2 = - match args1 with - | [] -> def1 - | uu___6 -> - let uu___7 = - FStar_Parser_AST.un_curry_abs args1 def1 in - FStar_Parser_AST.mk_term uu___7 - top.FStar_Parser_AST.range - top.FStar_Parser_AST.level in - let uu___6 = desugar_term_aq env1 def2 in - (match uu___6 with - | (body1, aq) -> - let lbname1 = - match lbname with - | FStar_Pervasives.Inl x -> - FStar_Pervasives.Inl x - | FStar_Pervasives.Inr l -> - let uu___7 = - FStar_Syntax_Syntax.lid_and_dd_as_fv l - FStar_Pervasives_Native.None in - FStar_Pervasives.Inr uu___7 in - let body2 = - if is_rec - then - FStar_Syntax_Subst.close rec_bindings1 - body1 - else body1 in - let attrs = - match attrs_opt with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some l -> - FStar_Compiler_List.map - (desugar_term env1) l in - let uu___7 = - mk_lb - (attrs, lbname1, - (setpos FStar_Syntax_Syntax.tun), body2, - pos) in - (uu___7, aq)) in - let uu___4 = - let uu___5 = - FStar_Compiler_List.map2 - (desugar_one_def (if is_rec then env' else env)) - fnames1 funs in - FStar_Compiler_List.unzip uu___5 in - (match uu___4 with - | (lbs1, aqss) -> - let uu___5 = desugar_term_aq env' body in - (match uu___5 with - | (body1, aq) -> - (if is_rec - then - FStar_Compiler_List.iter2 - (fun uu___7 -> - fun used_marker -> - match uu___7 with - | (_attr_opt, (f, uu___8, uu___9), - uu___10) -> - let uu___11 = - let uu___12 = - FStar_Compiler_Effect.op_Bang - used_marker in - Prims.op_Negation uu___12 in - if uu___11 - then - let uu___12 = - match f with - | FStar_Pervasives.Inl x -> - let uu___13 = - FStar_Ident.string_of_id - x in - let uu___14 = - FStar_Ident.range_of_id - x in - (uu___13, "Local binding", - uu___14) - | FStar_Pervasives.Inr l -> - let uu___13 = - FStar_Ident.string_of_lid - l in - let uu___14 = - FStar_Ident.range_of_lid - l in - (uu___13, - "Global binding", - uu___14) in - (match uu___12 with - | (nm, gl, rng) -> - let uu___13 = - let uu___14 = - let uu___15 = - FStar_Errors_Msg.text - gl in - let uu___16 = - let uu___17 = - FStar_Pprint.doc_of_string - nm in - FStar_Pprint.squotes - uu___17 in - let uu___17 = - FStar_Errors_Msg.text - "is recursive but not used in its body" in - FStar_Pprint.surround - (Prims.of_int (4)) - Prims.int_one uu___15 - uu___16 uu___17 in - [uu___14] in - FStar_Errors.log_issue - FStar_Class_HasRange.hasRange_range - rng - FStar_Errors_Codes.Warning_UnusedLetRec - () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___13)) - else ()) funs used_markers1 - else (); - (let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Syntax_Subst.close rec_bindings1 - body1 in - { - FStar_Syntax_Syntax.lbs = - (is_rec, lbs1); - FStar_Syntax_Syntax.body1 = uu___10 - } in - FStar_Syntax_Syntax.Tm_let uu___9 in - mk uu___8 in - (uu___7, - (FStar_Compiler_List.op_At aq - (FStar_Compiler_List.flatten aqss))))))) in - let ds_non_rec attrs_opt pat t1 t2 = - let attrs = - match attrs_opt with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some l -> - FStar_Compiler_List.map (desugar_term env) l in - let uu___2 = desugar_term_aq env t1 in - match uu___2 with - | (t11, aq0) -> - let uu___3 = - desugar_binding_pat_maybe_top top_level env pat in - (match uu___3 with - | ((env1, binder, pat1), aqs) -> - (check_no_aq aqs; - (let uu___5 = - match binder with - | LetBinder (l, (t, tacopt)) -> - (if FStar_Compiler_Util.is_some tacopt - then - (let uu___7 = - FStar_Compiler_Util.must tacopt in - FStar_Errors.log_issue - (FStar_Syntax_Syntax.has_range_syntax - ()) uu___7 - FStar_Errors_Codes.Warning_DefinitionNotTranslated - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Tactic annotation with a value type is not supported yet, try annotating with a computation type; this tactic annotation will be ignored")) - else (); - (let uu___7 = desugar_term_aq env1 t2 in - match uu___7 with - | (body1, aq) -> - let fv = - FStar_Syntax_Syntax.lid_and_dd_as_fv - l FStar_Pervasives_Native.None in - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - mk_lb - (attrs, - (FStar_Pervasives.Inr - fv), t, t11, - (t11.FStar_Syntax_Syntax.pos)) in - [uu___13] in - (false, uu___12) in - { - FStar_Syntax_Syntax.lbs = - uu___11; - FStar_Syntax_Syntax.body1 = - body1 - } in - FStar_Syntax_Syntax.Tm_let uu___10 in - mk uu___9 in - (uu___8, aq))) - | LocalBinder (x, uu___6, uu___7) -> - let uu___8 = desugar_term_aq env1 t2 in - (match uu___8 with - | (body1, aq) -> - let body2 = - match pat1 with - | [] -> body1 - | uu___9 -> - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Syntax_Syntax.bv_to_name - x in - let uu___13 = - desugar_disjunctive_pattern - pat1 - FStar_Pervasives_Native.None - body1 in - { - FStar_Syntax_Syntax.scrutinee - = uu___12; - FStar_Syntax_Syntax.ret_opt - = - FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.brs = - uu___13; - FStar_Syntax_Syntax.rc_opt1 - = - FStar_Pervasives_Native.None - } in - FStar_Syntax_Syntax.Tm_match - uu___11 in - FStar_Syntax_Syntax.mk uu___10 - top.FStar_Parser_AST.range in - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - mk_lb - (attrs, - (FStar_Pervasives.Inl x), - (x.FStar_Syntax_Syntax.sort), - t11, - (t11.FStar_Syntax_Syntax.pos)) in - [uu___14] in - (false, uu___13) in - let uu___13 = - let uu___14 = - let uu___15 = - FStar_Syntax_Syntax.mk_binder - x in - [uu___15] in - FStar_Syntax_Subst.close uu___14 - body2 in - { - FStar_Syntax_Syntax.lbs = - uu___12; - FStar_Syntax_Syntax.body1 = - uu___13 - } in - FStar_Syntax_Syntax.Tm_let uu___11 in - mk uu___10 in - (uu___9, aq)) in - match uu___5 with - | (tm, aq1) -> - (tm, (FStar_Compiler_List.op_At aq0 aq1))))) in - let uu___2 = FStar_Compiler_List.hd lbs in - (match uu___2 with - | (attrs, (head_pat, defn)) -> - let uu___3 = is_rec || (is_app_pattern head_pat) in - if uu___3 - then ds_let_rec_or_app () - else ds_non_rec attrs head_pat defn body) - | FStar_Parser_AST.If - (e, FStar_Pervasives_Native.Some op, asc_opt, t2, t3) -> - let var_id = - FStar_Ident.mk_ident - ((Prims.strcat FStar_Ident.reserved_prefix "if_op_head"), - (e.FStar_Parser_AST.range)) in - let var = - let uu___2 = - let uu___3 = FStar_Ident.lid_of_ids [var_id] in - FStar_Parser_AST.Var uu___3 in - FStar_Parser_AST.mk_term uu___2 e.FStar_Parser_AST.range - FStar_Parser_AST.Expr in - let pat = - FStar_Parser_AST.mk_pattern - (FStar_Parser_AST.PatVar - (var_id, FStar_Pervasives_Native.None, [])) - e.FStar_Parser_AST.range in - let if_ = - FStar_Parser_AST.mk_term - (FStar_Parser_AST.If - (var, FStar_Pervasives_Native.None, asc_opt, t2, t3)) - top.FStar_Parser_AST.range FStar_Parser_AST.Expr in - let t = - FStar_Parser_AST.mk_term - (FStar_Parser_AST.LetOperator ([(op, pat, e)], if_)) - e.FStar_Parser_AST.range FStar_Parser_AST.Expr in - desugar_term_aq env t - | FStar_Parser_AST.If - (t1, FStar_Pervasives_Native.None, asc_opt, t2, t3) -> - let x = - let uu___2 = tun_r t3.FStar_Parser_AST.range in - FStar_Syntax_Syntax.new_bv - (FStar_Pervasives_Native.Some (t3.FStar_Parser_AST.range)) - uu___2 in - let t_bool = - let uu___2 = - let uu___3 = - FStar_Syntax_Syntax.lid_and_dd_as_fv - FStar_Parser_Const.bool_lid FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.Tm_fvar uu___3 in - mk uu___2 in - let uu___2 = desugar_term_aq env t1 in - (match uu___2 with - | (t1', aq1) -> - let t1'1 = - FStar_Syntax_Util.ascribe t1' - ((FStar_Pervasives.Inl t_bool), - FStar_Pervasives_Native.None, false) in - let uu___3 = desugar_match_returns env t1'1 asc_opt in - (match uu___3 with - | (asc_opt1, aq0) -> - let uu___4 = desugar_term_aq env t2 in - (match uu___4 with - | (t2', aq2) -> - let uu___5 = desugar_term_aq env t3 in - (match uu___5 with - | (t3', aq3) -> - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Syntax_Syntax.withinfo - (FStar_Syntax_Syntax.Pat_constant - (FStar_Const.Const_bool - true)) - t1.FStar_Parser_AST.range in - (uu___11, - FStar_Pervasives_Native.None, - t2') in - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Syntax_Syntax.withinfo - (FStar_Syntax_Syntax.Pat_var - x) - t1.FStar_Parser_AST.range in - (uu___13, - FStar_Pervasives_Native.None, - t3') in - [uu___12] in - uu___10 :: uu___11 in - { - FStar_Syntax_Syntax.scrutinee = t1'1; - FStar_Syntax_Syntax.ret_opt = - asc_opt1; - FStar_Syntax_Syntax.brs = uu___9; - FStar_Syntax_Syntax.rc_opt1 = - FStar_Pervasives_Native.None - } in - FStar_Syntax_Syntax.Tm_match uu___8 in - mk uu___7 in - (uu___6, (join_aqs [aq1; aq0; aq2; aq3])))))) - | FStar_Parser_AST.TryWith (e, branches) -> - let r = top.FStar_Parser_AST.range in - let handler = FStar_Parser_AST.mk_function branches r r in - let body = - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Parser_AST.mk_pattern - (FStar_Parser_AST.PatConst FStar_Const.Const_unit) r in - (uu___4, FStar_Pervasives_Native.None, e) in - [uu___3] in - FStar_Parser_AST.mk_function uu___2 r r in - let try_with_lid = FStar_Ident.lid_of_path ["try_with"] r in - let try_with = - FStar_Parser_AST.mk_term (FStar_Parser_AST.Var try_with_lid) r - FStar_Parser_AST.Expr in - let a1 = - FStar_Parser_AST.mk_term - (FStar_Parser_AST.App - (try_with, body, FStar_Parser_AST.Nothing)) r - top.FStar_Parser_AST.level in - let a2 = - FStar_Parser_AST.mk_term - (FStar_Parser_AST.App - (a1, handler, FStar_Parser_AST.Nothing)) r - top.FStar_Parser_AST.level in - desugar_term_aq env a2 - | FStar_Parser_AST.Match - (e, FStar_Pervasives_Native.Some op, topt, branches) -> - let var_id = - FStar_Ident.mk_ident - ((Prims.strcat FStar_Ident.reserved_prefix "match_op_head"), - (e.FStar_Parser_AST.range)) in - let var = - let uu___2 = - let uu___3 = FStar_Ident.lid_of_ids [var_id] in - FStar_Parser_AST.Var uu___3 in - FStar_Parser_AST.mk_term uu___2 e.FStar_Parser_AST.range - FStar_Parser_AST.Expr in - let pat = - FStar_Parser_AST.mk_pattern - (FStar_Parser_AST.PatVar - (var_id, FStar_Pervasives_Native.None, [])) - e.FStar_Parser_AST.range in - let mt = - FStar_Parser_AST.mk_term - (FStar_Parser_AST.Match - (var, FStar_Pervasives_Native.None, topt, branches)) - top.FStar_Parser_AST.range FStar_Parser_AST.Expr in - let t = - FStar_Parser_AST.mk_term - (FStar_Parser_AST.LetOperator ([(op, pat, e)], mt)) - e.FStar_Parser_AST.range FStar_Parser_AST.Expr in - desugar_term_aq env t - | FStar_Parser_AST.Match - (e, FStar_Pervasives_Native.None, topt, branches) -> - let desugar_branch uu___2 = - match uu___2 with - | (pat, wopt, b) -> - let uu___3 = desugar_match_pat env pat in - (match uu___3 with - | ((env1, pat1), aqP) -> - let wopt1 = - match wopt with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some e1 -> - let uu___4 = desugar_term env1 e1 in - FStar_Pervasives_Native.Some uu___4 in - let uu___4 = desugar_term_aq env1 b in - (match uu___4 with - | (b1, aqB) -> - let uu___5 = - desugar_disjunctive_pattern pat1 wopt1 b1 in - (uu___5, (FStar_Compiler_List.op_At aqP aqB)))) in - let uu___2 = desugar_term_aq env e in - (match uu___2 with - | (e1, aq) -> - let uu___3 = desugar_match_returns env e1 topt in - (match uu___3 with - | (asc_opt, aq0) -> - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Compiler_List.map desugar_branch branches in - FStar_Compiler_List.unzip uu___6 in - match uu___5 with - | (x, y) -> ((FStar_Compiler_List.flatten x), y) in - (match uu___4 with - | (brs, aqs) -> - let uu___5 = - mk - (FStar_Syntax_Syntax.Tm_match - { - FStar_Syntax_Syntax.scrutinee = e1; - FStar_Syntax_Syntax.ret_opt = asc_opt; - FStar_Syntax_Syntax.brs = brs; - FStar_Syntax_Syntax.rc_opt1 = - FStar_Pervasives_Native.None - }) in - (uu___5, (join_aqs (aq :: aq0 :: aqs)))))) - | FStar_Parser_AST.Ascribed (e, t, tac_opt, use_eq) -> - let uu___2 = desugar_ascription env t tac_opt use_eq in - (match uu___2 with - | (asc, aq0) -> - let uu___3 = desugar_term_aq env e in - (match uu___3 with - | (e1, aq) -> - let uu___4 = - mk - (FStar_Syntax_Syntax.Tm_ascribed - { - FStar_Syntax_Syntax.tm = e1; - FStar_Syntax_Syntax.asc = asc; - FStar_Syntax_Syntax.eff_opt = - FStar_Pervasives_Native.None - }) in - (uu___4, (FStar_Compiler_List.op_At aq0 aq)))) - | FStar_Parser_AST.Record (uu___2, []) -> - FStar_Errors.raise_error FStar_Parser_AST.hasRange_term top - FStar_Errors_Codes.Fatal_UnexpectedEmptyRecord () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic "Unexpected empty record") - | FStar_Parser_AST.Record (eopt, fields) -> - let record_opt = - let uu___2 = FStar_Compiler_List.hd fields in - match uu___2 with - | (f, uu___3) -> - FStar_Syntax_DsEnv.try_lookup_record_by_field_name env f in - let uu___2 = - let uu___3 = - FStar_Compiler_List.map - (fun uu___4 -> - match uu___4 with - | (fn, fval) -> - let uu___5 = desugar_term_aq env fval in - (match uu___5 with - | (fval1, aq) -> ((fn, fval1), aq))) fields in - FStar_Compiler_List.unzip uu___3 in - (match uu___2 with - | (fields1, aqs) -> - let uu___3 = FStar_Compiler_List.unzip fields1 in - (match uu___3 with - | (field_names, assignments) -> - let args = - FStar_Compiler_List.map - (fun f -> (f, FStar_Pervasives_Native.None)) - assignments in - let aqs1 = FStar_Compiler_List.flatten aqs in - let uc = - match record_opt with - | FStar_Pervasives_Native.None -> - { - FStar_Syntax_Syntax.uc_base_term = - (FStar_Compiler_Option.isSome eopt); - FStar_Syntax_Syntax.uc_typename = - FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.uc_fields = field_names - } - | FStar_Pervasives_Native.Some record -> - let uu___4 = - qualify_field_names - record.FStar_Syntax_DsEnv.typename - field_names in - { - FStar_Syntax_Syntax.uc_base_term = - (FStar_Compiler_Option.isSome eopt); - FStar_Syntax_Syntax.uc_typename = - (FStar_Pervasives_Native.Some - (record.FStar_Syntax_DsEnv.typename)); - FStar_Syntax_Syntax.uc_fields = uu___4 - } in - let head = - let lid = - FStar_Ident.lid_of_path ["__dummy__"] - top.FStar_Parser_AST.range in - FStar_Syntax_Syntax.fvar_with_dd lid - (FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Unresolved_constructor uc)) in - let mk_result args1 = - FStar_Syntax_Syntax.mk_Tm_app head args1 - top.FStar_Parser_AST.range in - (match eopt with - | FStar_Pervasives_Native.None -> - let uu___4 = mk_result args in (uu___4, aqs1) - | FStar_Pervasives_Native.Some e -> - let uu___4 = desugar_term_aq env e in - (match uu___4 with - | (e1, aq) -> - let tm = - let uu___5 = - let uu___6 = - FStar_Syntax_Subst.compress e1 in - uu___6.FStar_Syntax_Syntax.n in - match uu___5 with - | FStar_Syntax_Syntax.Tm_name uu___6 -> - mk_result - ((e1, FStar_Pervasives_Native.None) - :: args) - | FStar_Syntax_Syntax.Tm_fvar uu___6 -> - mk_result - ((e1, FStar_Pervasives_Native.None) - :: args) - | uu___6 -> - let x = - FStar_Ident.gen - e1.FStar_Syntax_Syntax.pos in - let uu___7 = - FStar_Syntax_DsEnv.push_bv env x in - (match uu___7 with - | (env', bv_x) -> - let nm = - FStar_Syntax_Syntax.bv_to_name - bv_x in - let body = - mk_result - ((nm, - FStar_Pervasives_Native.None) - :: args) in - let body1 = - let uu___8 = - let uu___9 = - FStar_Syntax_Syntax.mk_binder - bv_x in - [uu___9] in - FStar_Syntax_Subst.close uu___8 - body in - let lb = - mk_lb - ([], - (FStar_Pervasives.Inl bv_x), - FStar_Syntax_Syntax.tun, - e1, - (e1.FStar_Syntax_Syntax.pos)) in - mk - (FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = - (false, [lb]); - FStar_Syntax_Syntax.body1 - = body1 - })) in - (tm, (FStar_Compiler_List.op_At aq aqs1)))))) - | FStar_Parser_AST.Project (e, f) -> - let uu___2 = desugar_term_aq env e in - (match uu___2 with - | (e1, s) -> - let head = - let uu___3 = - FStar_Syntax_DsEnv.try_lookup_dc_by_field_name env f in - match uu___3 with - | FStar_Pervasives_Native.None -> - FStar_Syntax_Syntax.fvar_with_dd f - (FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Unresolved_projector - FStar_Pervasives_Native.None)) - | FStar_Pervasives_Native.Some (constrname, is_rec) -> - let projname = - let uu___4 = FStar_Ident.ident_of_lid f in - FStar_Syntax_Util.mk_field_projector_name_from_ident - constrname uu___4 in - let qual = - if is_rec - then - let uu___4 = - let uu___5 = - let uu___6 = FStar_Ident.ident_of_lid f in - (constrname, uu___6) in - FStar_Syntax_Syntax.Record_projector uu___5 in - FStar_Pervasives_Native.Some uu___4 - else FStar_Pervasives_Native.None in - let candidate_projector = - let uu___4 = - FStar_Ident.set_lid_range projname - top.FStar_Parser_AST.range in - FStar_Syntax_Syntax.lid_and_dd_as_fv uu___4 qual in - let qual1 = - FStar_Syntax_Syntax.Unresolved_projector - (FStar_Pervasives_Native.Some candidate_projector) in - let f1 = - let uu___4 = qualify_field_names constrname [f] in - FStar_Compiler_List.hd uu___4 in - FStar_Syntax_Syntax.fvar_with_dd f1 - (FStar_Pervasives_Native.Some qual1) in - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = FStar_Syntax_Syntax.as_arg e1 in - [uu___7] in - { - FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = uu___6 - } in - FStar_Syntax_Syntax.Tm_app uu___5 in - mk uu___4 in - (uu___3, s)) - | FStar_Parser_AST.NamedTyp (n, e) -> - (FStar_Errors.log_issue FStar_Ident.hasrange_ident n - FStar_Errors_Codes.Warning_IgnoredBinding () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic "This name is being ignored"); - desugar_term_aq env e) - | FStar_Parser_AST.Paren e -> failwith "impossible" - | FStar_Parser_AST.VQuote e -> - let uu___2 = - let uu___3 = - let uu___4 = desugar_vquote env e top.FStar_Parser_AST.range in - FStar_Syntax_Util.exp_string uu___4 in - { - FStar_Syntax_Syntax.n = (uu___3.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = (e.FStar_Parser_AST.range); - FStar_Syntax_Syntax.vars = (uu___3.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (uu___3.FStar_Syntax_Syntax.hash_code) - } in - (uu___2, noaqs) - | FStar_Parser_AST.Quote (e, FStar_Parser_AST.Static) -> - let uu___2 = desugar_term_aq env e in - (match uu___2 with - | (tm, vts) -> - let vt_binders = - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with - | (bv, _tm) -> FStar_Syntax_Syntax.mk_binder bv) vts in - let vt_tms = - FStar_Compiler_List.map FStar_Pervasives_Native.snd vts in - let tm1 = FStar_Syntax_Subst.close vt_binders tm in - ((let fvs = FStar_Syntax_Free.names tm1 in - let uu___4 = - let uu___5 = - FStar_Class_Setlike.is_empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) (Obj.magic fvs) in - Prims.op_Negation uu___5 in - if uu___4 - then - let uu___5 = - let uu___6 = - FStar_Class_Show.show - (FStar_Compiler_FlatSet.showable_set - FStar_Syntax_Syntax.ord_bv - FStar_Syntax_Print.showable_bv) fvs in - FStar_Compiler_Util.format1 - "Static quotation refers to external variables: %s" - uu___6 in - FStar_Errors.raise_error FStar_Parser_AST.hasRange_term - e FStar_Errors_Codes.Fatal_MissingFieldInRecord () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___5) - else ()); - (match () with - | () -> - let qi = - { - FStar_Syntax_Syntax.qkind = - FStar_Syntax_Syntax.Quote_static; - FStar_Syntax_Syntax.antiquotations = - (Prims.int_zero, vt_tms) - } in - let uu___4 = - mk (FStar_Syntax_Syntax.Tm_quoted (tm1, qi)) in - (uu___4, noaqs)))) - | FStar_Parser_AST.Antiquote e -> - let bv = - FStar_Syntax_Syntax.new_bv - (FStar_Pervasives_Native.Some (e.FStar_Parser_AST.range)) - FStar_Syntax_Syntax.tun in - let tm = desugar_term env e in - let uu___2 = FStar_Syntax_Syntax.bv_to_name bv in - (uu___2, [(bv, tm)]) - | FStar_Parser_AST.Quote (e, FStar_Parser_AST.Dynamic) -> - let qi = - { - FStar_Syntax_Syntax.qkind = - FStar_Syntax_Syntax.Quote_dynamic; - FStar_Syntax_Syntax.antiquotations = (Prims.int_zero, []) - } in - let uu___2 = - let uu___3 = - let uu___4 = let uu___5 = desugar_term env e in (uu___5, qi) in - FStar_Syntax_Syntax.Tm_quoted uu___4 in - mk uu___3 in - (uu___2, noaqs) - | FStar_Parser_AST.CalcProof (rel, init_expr, steps) -> - let is_impl rel1 = - let is_impl_t t = - match t.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_fvar fv -> - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.imp_lid - | uu___2 -> false in - let uu___2 = - let uu___3 = unparen rel1 in uu___3.FStar_Parser_AST.tm in - match uu___2 with - | FStar_Parser_AST.Op (id, uu___3) -> - let uu___4 = op_as_term env (Prims.of_int (2)) id in - (match uu___4 with - | FStar_Pervasives_Native.Some t -> is_impl_t t - | FStar_Pervasives_Native.None -> false) - | FStar_Parser_AST.Var lid -> - let uu___3 = desugar_name' (fun x -> x) env true lid in - (match uu___3 with - | FStar_Pervasives_Native.Some t -> is_impl_t t - | FStar_Pervasives_Native.None -> false) - | FStar_Parser_AST.Tvar id -> - let uu___3 = FStar_Syntax_DsEnv.try_lookup_id env id in - (match uu___3 with - | FStar_Pervasives_Native.Some t -> is_impl_t t - | FStar_Pervasives_Native.None -> false) - | uu___3 -> false in - let eta_and_annot rel1 = - let x = FStar_Ident.gen' "x" rel1.FStar_Parser_AST.range in - let y = FStar_Ident.gen' "y" rel1.FStar_Parser_AST.range in - let xt = - FStar_Parser_AST.mk_term (FStar_Parser_AST.Tvar x) - rel1.FStar_Parser_AST.range FStar_Parser_AST.Expr in - let yt = - FStar_Parser_AST.mk_term (FStar_Parser_AST.Tvar y) - rel1.FStar_Parser_AST.range FStar_Parser_AST.Expr in - let pats = - let uu___2 = - FStar_Parser_AST.mk_pattern - (FStar_Parser_AST.PatVar - (x, FStar_Pervasives_Native.None, [])) - rel1.FStar_Parser_AST.range in - let uu___3 = - let uu___4 = - FStar_Parser_AST.mk_pattern - (FStar_Parser_AST.PatVar - (y, FStar_Pervasives_Native.None, [])) - rel1.FStar_Parser_AST.range in - [uu___4] in - uu___2 :: uu___3 in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Parser_AST.mkApp rel1 - [(xt, FStar_Parser_AST.Nothing); - (yt, FStar_Parser_AST.Nothing)] - rel1.FStar_Parser_AST.range in - let uu___8 = - let uu___9 = - let uu___10 = FStar_Ident.lid_of_str "Type0" in - FStar_Parser_AST.Name uu___10 in - FStar_Parser_AST.mk_term uu___9 - rel1.FStar_Parser_AST.range - FStar_Parser_AST.Expr in - (uu___7, uu___8, FStar_Pervasives_Native.None, - false) in - FStar_Parser_AST.Ascribed uu___6 in - FStar_Parser_AST.mk_term uu___5 - rel1.FStar_Parser_AST.range FStar_Parser_AST.Expr in - (pats, uu___4) in - FStar_Parser_AST.Abs uu___3 in - FStar_Parser_AST.mk_term uu___2 rel1.FStar_Parser_AST.range - FStar_Parser_AST.Expr in - let rel1 = eta_and_annot rel in - let wild r = - FStar_Parser_AST.mk_term FStar_Parser_AST.Wild r - FStar_Parser_AST.Expr in - let init = - FStar_Parser_AST.mk_term - (FStar_Parser_AST.Var FStar_Parser_Const.calc_init_lid) - init_expr.FStar_Parser_AST.range FStar_Parser_AST.Expr in - let push_impl r = - FStar_Parser_AST.mk_term - (FStar_Parser_AST.Var FStar_Parser_Const.calc_push_impl_lid) - r FStar_Parser_AST.Expr in - let last_expr = - let uu___2 = FStar_Compiler_List.last_opt steps in - match uu___2 with - | FStar_Pervasives_Native.Some (FStar_Parser_AST.CalcStep - (uu___3, uu___4, last_expr1)) -> last_expr1 - | FStar_Pervasives_Native.None -> init_expr in - let step r = - FStar_Parser_AST.mk_term - (FStar_Parser_AST.Var FStar_Parser_Const.calc_step_lid) r - FStar_Parser_AST.Expr in - let finish = - let uu___2 = - FStar_Parser_AST.mk_term - (FStar_Parser_AST.Var FStar_Parser_Const.calc_finish_lid) - top.FStar_Parser_AST.range FStar_Parser_AST.Expr in - FStar_Parser_AST.mkApp uu___2 - [(rel1, FStar_Parser_AST.Nothing)] - top.FStar_Parser_AST.range in - let e = - FStar_Parser_AST.mkApp init - [(init_expr, FStar_Parser_AST.Nothing)] - init_expr.FStar_Parser_AST.range in - let uu___2 = - FStar_Compiler_List.fold_left - (fun uu___3 -> - fun uu___4 -> - match (uu___3, uu___4) with - | ((e1, prev), FStar_Parser_AST.CalcStep - (rel2, just, next_expr)) -> - let just1 = - let uu___5 = is_impl rel2 in - if uu___5 - then - let uu___6 = - push_impl just.FStar_Parser_AST.range in - let uu___7 = - let uu___8 = - let uu___9 = FStar_Parser_AST.thunk just in - (uu___9, FStar_Parser_AST.Nothing) in - [uu___8] in - FStar_Parser_AST.mkApp uu___6 uu___7 - just.FStar_Parser_AST.range - else just in - let pf = - let uu___5 = step rel2.FStar_Parser_AST.range in - let uu___6 = - let uu___7 = - let uu___8 = wild rel2.FStar_Parser_AST.range in - (uu___8, FStar_Parser_AST.Hash) in - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = eta_and_annot rel2 in - (uu___12, FStar_Parser_AST.Nothing) in - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - FStar_Parser_AST.thunk e1 in - (uu___15, FStar_Parser_AST.Nothing) in - let uu___15 = - let uu___16 = - let uu___17 = - FStar_Parser_AST.thunk just1 in - (uu___17, - FStar_Parser_AST.Nothing) in - [uu___16] in - uu___14 :: uu___15 in - (next_expr, FStar_Parser_AST.Nothing) - :: uu___13 in - uu___11 :: uu___12 in - (prev, FStar_Parser_AST.Hash) :: uu___10 in - (init_expr, FStar_Parser_AST.Hash) :: uu___9 in - uu___7 :: uu___8 in - FStar_Parser_AST.mkApp uu___5 uu___6 - FStar_Compiler_Range_Type.dummyRange in - (pf, next_expr)) (e, init_expr) steps in - (match uu___2 with - | (e1, uu___3) -> - let e2 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = FStar_Parser_AST.thunk e1 in - (uu___8, FStar_Parser_AST.Nothing) in - [uu___7] in - (last_expr, FStar_Parser_AST.Hash) :: uu___6 in - (init_expr, FStar_Parser_AST.Hash) :: uu___5 in - FStar_Parser_AST.mkApp finish uu___4 - top.FStar_Parser_AST.range in - desugar_term_maybe_top top_level env e2) - | FStar_Parser_AST.IntroForall (bs, p, e) -> - let uu___2 = desugar_binders env bs in - (match uu___2 with - | (env', bs1) -> - let p1 = desugar_term env' p in - let e1 = desugar_term env' e in - let mk_forall_intro t p2 pf = - let head = - let uu___3 = - FStar_Syntax_Syntax.lid_and_dd_as_fv - FStar_Parser_Const.forall_intro_lid - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___3 in - let args = - [(t, FStar_Pervasives_Native.None); - (p2, FStar_Pervasives_Native.None); - (pf, FStar_Pervasives_Native.None)] in - FStar_Syntax_Syntax.mk_Tm_app head args - top.FStar_Parser_AST.range in - let rec aux bs2 = - match bs2 with - | [] -> - let sq_p = - FStar_Syntax_Util.mk_squash - FStar_Syntax_Syntax.U_unknown p1 in - FStar_Syntax_Util.ascribe e1 - ((FStar_Pervasives.Inl sq_p), - FStar_Pervasives_Native.None, false) - | b::bs3 -> - let tail = aux bs3 in - let x = unqual_bv_of_binder b in - let uu___3 = - let uu___4 = - FStar_Syntax_Util.close_forall_no_univs bs3 p1 in - FStar_Syntax_Util.abs [b] uu___4 - FStar_Pervasives_Native.None in - let uu___4 = - FStar_Syntax_Util.abs [b] tail - FStar_Pervasives_Native.None in - mk_forall_intro x.FStar_Syntax_Syntax.sort uu___3 - uu___4 in - let uu___3 = aux bs1 in (uu___3, noaqs)) - | FStar_Parser_AST.IntroExists (bs, p, vs, e) -> - let uu___2 = desugar_binders env bs in - (match uu___2 with - | (env', bs1) -> - let p1 = desugar_term env' p in - let vs1 = FStar_Compiler_List.map (desugar_term env) vs in - let e1 = desugar_term env e in - let mk_exists_intro t p2 v e2 = - let head = - let uu___3 = - FStar_Syntax_Syntax.lid_and_dd_as_fv - FStar_Parser_Const.exists_intro_lid - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___3 in - let args = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = mk_thunk e2 in - (uu___7, FStar_Pervasives_Native.None) in - [uu___6] in - (v, FStar_Pervasives_Native.None) :: uu___5 in - (p2, FStar_Pervasives_Native.None) :: uu___4 in - (t, FStar_Pervasives_Native.None) :: uu___3 in - FStar_Syntax_Syntax.mk_Tm_app head args - top.FStar_Parser_AST.range in - let rec aux bs2 vs2 sub token = - match (bs2, vs2) with - | ([], []) -> token - | (b::bs3, v::vs3) -> - let x = unqual_bv_of_binder b in - let token1 = - let uu___3 = - FStar_Syntax_Subst.subst_binders - ((FStar_Syntax_Syntax.NT (x, v)) :: sub) bs3 in - aux uu___3 vs3 ((FStar_Syntax_Syntax.NT (x, v)) :: - sub) token in - let token2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Subst.subst sub p1 in - FStar_Syntax_Util.close_exists_no_univs bs3 - uu___5 in - FStar_Syntax_Util.abs [b] uu___4 - FStar_Pervasives_Native.None in - mk_exists_intro x.FStar_Syntax_Syntax.sort uu___3 v - token1 in - token2 - | uu___3 -> - FStar_Errors.raise_error - FStar_Parser_AST.hasRange_term top - FStar_Errors_Codes.Fatal_UnexpectedTerm () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Unexpected number of instantiations in _intro_ exists") in - let uu___3 = aux bs1 vs1 [] e1 in (uu___3, noaqs)) - | FStar_Parser_AST.IntroImplies (p, q, x, e) -> - let p1 = desugar_term env p in - let q1 = desugar_term env q in - let uu___2 = desugar_binders env [x] in - (match uu___2 with - | (env', x1::[]) -> - let e1 = desugar_term env' e in - let head = - let uu___3 = - FStar_Syntax_Syntax.lid_and_dd_as_fv - FStar_Parser_Const.implies_intro_lid - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___3 in - let args = - let uu___3 = - let uu___4 = - let uu___5 = mk_thunk q1 in - (uu___5, FStar_Pervasives_Native.None) in - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Syntax_Util.abs [x1] e1 - FStar_Pervasives_Native.None in - (uu___7, FStar_Pervasives_Native.None) in - [uu___6] in - uu___4 :: uu___5 in - (p1, FStar_Pervasives_Native.None) :: uu___3 in - let uu___3 = - FStar_Syntax_Syntax.mk_Tm_app head args - top.FStar_Parser_AST.range in - (uu___3, noaqs)) - | FStar_Parser_AST.IntroOr (lr, p, q, e) -> - let p1 = desugar_term env p in - let q1 = desugar_term env q in - let e1 = desugar_term env e in - let lid = - if lr - then FStar_Parser_Const.or_intro_left_lid - else FStar_Parser_Const.or_intro_right_lid in - let head = - let uu___2 = - FStar_Syntax_Syntax.lid_and_dd_as_fv lid - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___2 in - let args = - let uu___2 = - let uu___3 = - let uu___4 = mk_thunk q1 in - (uu___4, FStar_Pervasives_Native.None) in - let uu___4 = - let uu___5 = - let uu___6 = mk_thunk e1 in - (uu___6, FStar_Pervasives_Native.None) in - [uu___5] in - uu___3 :: uu___4 in - (p1, FStar_Pervasives_Native.None) :: uu___2 in - let uu___2 = - FStar_Syntax_Syntax.mk_Tm_app head args - top.FStar_Parser_AST.range in - (uu___2, noaqs) - | FStar_Parser_AST.IntroAnd (p, q, e1, e2) -> - let p1 = desugar_term env p in - let q1 = desugar_term env q in - let e11 = desugar_term env e1 in - let e21 = desugar_term env e2 in - let head = - let uu___2 = - FStar_Syntax_Syntax.lid_and_dd_as_fv - FStar_Parser_Const.and_intro_lid - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___2 in - let args = - let uu___2 = - let uu___3 = - let uu___4 = mk_thunk q1 in - (uu___4, FStar_Pervasives_Native.None) in - let uu___4 = - let uu___5 = - let uu___6 = mk_thunk e11 in - (uu___6, FStar_Pervasives_Native.None) in - let uu___6 = - let uu___7 = - let uu___8 = mk_thunk e21 in - (uu___8, FStar_Pervasives_Native.None) in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - (p1, FStar_Pervasives_Native.None) :: uu___2 in - let uu___2 = - FStar_Syntax_Syntax.mk_Tm_app head args - top.FStar_Parser_AST.range in - (uu___2, noaqs) - | FStar_Parser_AST.ElimForall (bs, p, vs) -> - let uu___2 = desugar_binders env bs in - (match uu___2 with - | (env', bs1) -> - let p1 = desugar_term env' p in - let vs1 = FStar_Compiler_List.map (desugar_term env) vs in - let mk_forall_elim a p2 v tok = - let head = - let uu___3 = - FStar_Syntax_Syntax.lid_and_dd_as_fv - FStar_Parser_Const.forall_elim_lid - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___3 in - let args = - let uu___3 = - let uu___4 = - FStar_Syntax_Syntax.as_aqual_implicit true in - (a, uu___4) in - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Syntax.as_aqual_implicit true in - (p2, uu___6) in - [uu___5; - (v, FStar_Pervasives_Native.None); - (tok, FStar_Pervasives_Native.None)] in - uu___3 :: uu___4 in - FStar_Syntax_Syntax.mk_Tm_app head args - tok.FStar_Syntax_Syntax.pos in - let rec aux bs2 vs2 sub token = - match (bs2, vs2) with - | ([], []) -> token - | (b::bs3, v::vs3) -> - let x = unqual_bv_of_binder b in - let token1 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Subst.subst sub p1 in - FStar_Syntax_Util.close_forall_no_univs bs3 - uu___5 in - FStar_Syntax_Util.abs [b] uu___4 - FStar_Pervasives_Native.None in - mk_forall_elim x.FStar_Syntax_Syntax.sort uu___3 v - token in - let sub1 = (FStar_Syntax_Syntax.NT (x, v)) :: sub in - let uu___3 = - FStar_Syntax_Subst.subst_binders sub1 bs3 in - aux uu___3 vs3 sub1 token1 - | uu___3 -> - FStar_Errors.raise_error - FStar_Parser_AST.hasRange_term top - FStar_Errors_Codes.Fatal_UnexpectedTerm () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Unexpected number of instantiations in _elim_forall_") in - let range = - FStar_Compiler_List.fold_right - (fun bs2 -> - fun r -> - let uu___3 = - FStar_Syntax_Syntax.range_of_bv - bs2.FStar_Syntax_Syntax.binder_bv in - FStar_Compiler_Range_Ops.union_ranges uu___3 r) - bs1 p1.FStar_Syntax_Syntax.pos in - let uu___3 = - aux bs1 vs1 [] - { - FStar_Syntax_Syntax.n = - (FStar_Syntax_Util.exp_unit.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = range; - FStar_Syntax_Syntax.vars = - (FStar_Syntax_Util.exp_unit.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (FStar_Syntax_Util.exp_unit.FStar_Syntax_Syntax.hash_code) - } in - (uu___3, noaqs)) - | FStar_Parser_AST.ElimExists (binders, p, q, binder, e) -> - let uu___2 = desugar_binders env binders in - (match uu___2 with - | (env', bs) -> - let p1 = desugar_term env' p in - let q1 = desugar_term env q in - let sq_q = - FStar_Syntax_Util.mk_squash FStar_Syntax_Syntax.U_unknown - q1 in - let uu___3 = desugar_binders env' [binder] in - (match uu___3 with - | (env'', b_pf_p::[]) -> - let e1 = desugar_term env'' e in - let rec mk_exists bs1 p2 = - match bs1 with - | [] -> failwith "Impossible" - | b::[] -> - let x = b.FStar_Syntax_Syntax.binder_bv in - let head = - let uu___4 = - FStar_Syntax_Syntax.lid_and_dd_as_fv - FStar_Parser_Const.exists_lid - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___4 in - let args = - let uu___4 = - let uu___5 = - FStar_Syntax_Syntax.as_aqual_implicit true in - ((x.FStar_Syntax_Syntax.sort), uu___5) in - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Compiler_List.hd bs1 in - [uu___9] in - FStar_Syntax_Util.abs uu___8 p2 - FStar_Pervasives_Native.None in - (uu___7, FStar_Pervasives_Native.None) in - [uu___6] in - uu___4 :: uu___5 in - FStar_Syntax_Syntax.mk_Tm_app head args - p2.FStar_Syntax_Syntax.pos - | b::bs2 -> - let body = mk_exists bs2 p2 in - mk_exists [b] body in - let mk_exists_elim t x_p s_ex_p f r = - let head = - let uu___4 = - FStar_Syntax_Syntax.lid_and_dd_as_fv - FStar_Parser_Const.exists_elim_lid - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___4 in - let args = - let uu___4 = - let uu___5 = - FStar_Syntax_Syntax.as_aqual_implicit true in - (t, uu___5) in - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Syntax_Syntax.as_aqual_implicit true in - (x_p, uu___7) in - [uu___6; - (s_ex_p, FStar_Pervasives_Native.None); - (f, FStar_Pervasives_Native.None)] in - uu___4 :: uu___5 in - FStar_Syntax_Syntax.mk_Tm_app head args r in - let rec aux binders1 squash_token = - match binders1 with - | [] -> - FStar_Errors.raise_error - FStar_Parser_AST.hasRange_term top - FStar_Errors_Codes.Fatal_UnexpectedTerm () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic "Empty binders in ELIM_EXISTS") - | b::[] -> - let x = unqual_bv_of_binder b in - let uu___4 = - FStar_Syntax_Util.abs [b] p1 - FStar_Pervasives_Native.None in - let uu___5 = - let uu___6 = - FStar_Syntax_Util.ascribe e1 - ((FStar_Pervasives.Inl sq_q), - FStar_Pervasives_Native.None, false) in - FStar_Syntax_Util.abs [b; b_pf_p] uu___6 - FStar_Pervasives_Native.None in - mk_exists_elim x.FStar_Syntax_Syntax.sort uu___4 - squash_token uu___5 - squash_token.FStar_Syntax_Syntax.pos - | b::bs1 -> - let pf_i = - let uu___4 = - let uu___5 = - FStar_Syntax_Syntax.range_of_bv - b.FStar_Syntax_Syntax.binder_bv in - FStar_Pervasives_Native.Some uu___5 in - FStar_Syntax_Syntax.gen_bv "pf" uu___4 - FStar_Syntax_Syntax.tun in - let k = - let uu___4 = - FStar_Syntax_Syntax.bv_to_name pf_i in - aux bs1 uu___4 in - let x = unqual_bv_of_binder b in - let uu___4 = - let uu___5 = mk_exists bs1 p1 in - FStar_Syntax_Util.abs [b] uu___5 - FStar_Pervasives_Native.None in - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Syntax_Syntax.mk_binder pf_i in - [uu___8] in - b :: uu___7 in - FStar_Syntax_Util.abs uu___6 k - FStar_Pervasives_Native.None in - mk_exists_elim x.FStar_Syntax_Syntax.sort uu___4 - squash_token uu___5 - squash_token.FStar_Syntax_Syntax.pos in - let range = - FStar_Compiler_List.fold_right - (fun bs1 -> - fun r -> - let uu___4 = - FStar_Syntax_Syntax.range_of_bv - bs1.FStar_Syntax_Syntax.binder_bv in - FStar_Compiler_Range_Ops.union_ranges uu___4 - r) bs p1.FStar_Syntax_Syntax.pos in - let uu___4 = - aux bs - { - FStar_Syntax_Syntax.n = - (FStar_Syntax_Util.exp_unit.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = range; - FStar_Syntax_Syntax.vars = - (FStar_Syntax_Util.exp_unit.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (FStar_Syntax_Util.exp_unit.FStar_Syntax_Syntax.hash_code) - } in - (uu___4, noaqs))) - | FStar_Parser_AST.ElimImplies (p, q, e) -> - let p1 = desugar_term env p in - let q1 = desugar_term env q in - let e1 = desugar_term env e in - let head = - let uu___2 = - FStar_Syntax_Syntax.lid_and_dd_as_fv - FStar_Parser_Const.implies_elim_lid - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___2 in - let args = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Compiler_Range_Ops.union_ranges - p1.FStar_Syntax_Syntax.pos - q1.FStar_Syntax_Syntax.pos in - { - FStar_Syntax_Syntax.n = - (FStar_Syntax_Util.exp_unit.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = uu___6; - FStar_Syntax_Syntax.vars = - (FStar_Syntax_Util.exp_unit.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (FStar_Syntax_Util.exp_unit.FStar_Syntax_Syntax.hash_code) - } in - (uu___5, FStar_Pervasives_Native.None) in - let uu___5 = - let uu___6 = - let uu___7 = mk_thunk e1 in - (uu___7, FStar_Pervasives_Native.None) in - [uu___6] in - uu___4 :: uu___5 in - (q1, FStar_Pervasives_Native.None) :: uu___3 in - (p1, FStar_Pervasives_Native.None) :: uu___2 in - let uu___2 = - FStar_Syntax_Syntax.mk_Tm_app head args - top.FStar_Parser_AST.range in - (uu___2, noaqs) - | FStar_Parser_AST.ElimOr (p, q, r, x, e1, y, e2) -> - let p1 = desugar_term env p in - let q1 = desugar_term env q in - let r1 = desugar_term env r in - let uu___2 = desugar_binders env [x] in - (match uu___2 with - | (env_x, x1::[]) -> - let e11 = desugar_term env_x e1 in - let uu___3 = desugar_binders env [y] in - (match uu___3 with - | (env_y, y1::[]) -> - let e21 = desugar_term env_y e2 in - let head = - let uu___4 = - FStar_Syntax_Syntax.lid_and_dd_as_fv - FStar_Parser_Const.or_elim_lid - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___4 in - let extra_binder = - let uu___4 = - FStar_Syntax_Syntax.new_bv - FStar_Pervasives_Native.None - FStar_Syntax_Syntax.tun in - FStar_Syntax_Syntax.mk_binder uu___4 in - let args = - let uu___4 = - let uu___5 = - let uu___6 = mk_thunk q1 in - (uu___6, FStar_Pervasives_Native.None) in - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Compiler_Range_Ops.union_ranges - p1.FStar_Syntax_Syntax.pos - q1.FStar_Syntax_Syntax.pos in - { - FStar_Syntax_Syntax.n = - (FStar_Syntax_Util.exp_unit.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = uu___10; - FStar_Syntax_Syntax.vars = - (FStar_Syntax_Util.exp_unit.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (FStar_Syntax_Util.exp_unit.FStar_Syntax_Syntax.hash_code) - } in - (uu___9, FStar_Pervasives_Native.None) in - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Syntax_Util.abs [x1] e11 - FStar_Pervasives_Native.None in - (uu___11, FStar_Pervasives_Native.None) in - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Syntax_Util.abs - [extra_binder; y1] e21 - FStar_Pervasives_Native.None in - (uu___13, FStar_Pervasives_Native.None) in - [uu___12] in - uu___10 :: uu___11 in - uu___8 :: uu___9 in - (r1, FStar_Pervasives_Native.None) :: uu___7 in - uu___5 :: uu___6 in - (p1, FStar_Pervasives_Native.None) :: uu___4 in - let uu___4 = - FStar_Syntax_Syntax.mk_Tm_app head args - top.FStar_Parser_AST.range in - (uu___4, noaqs))) - | FStar_Parser_AST.ElimAnd (p, q, r, x, y, e) -> - let p1 = desugar_term env p in - let q1 = desugar_term env q in - let r1 = desugar_term env r in - let uu___2 = desugar_binders env [x; y] in - (match uu___2 with - | (env', x1::y1::[]) -> - let e1 = desugar_term env' e in - let head = - let uu___3 = - FStar_Syntax_Syntax.lid_and_dd_as_fv - FStar_Parser_Const.and_elim_lid - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___3 in - let args = - let uu___3 = - let uu___4 = - let uu___5 = mk_thunk q1 in - (uu___5, FStar_Pervasives_Native.None) in - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Compiler_Range_Ops.union_ranges - p1.FStar_Syntax_Syntax.pos - q1.FStar_Syntax_Syntax.pos in - { - FStar_Syntax_Syntax.n = - (FStar_Syntax_Util.exp_unit.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = uu___9; - FStar_Syntax_Syntax.vars = - (FStar_Syntax_Util.exp_unit.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (FStar_Syntax_Util.exp_unit.FStar_Syntax_Syntax.hash_code) - } in - (uu___8, FStar_Pervasives_Native.None) in - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Syntax_Util.abs [x1; y1] e1 - FStar_Pervasives_Native.None in - (uu___10, FStar_Pervasives_Native.None) in - [uu___9] in - uu___7 :: uu___8 in - (r1, FStar_Pervasives_Native.None) :: uu___6 in - uu___4 :: uu___5 in - (p1, FStar_Pervasives_Native.None) :: uu___3 in - let uu___3 = - FStar_Syntax_Syntax.mk_Tm_app head args - top.FStar_Parser_AST.range in - (uu___3, noaqs)) - | FStar_Parser_AST.ListLiteral ts -> - let nil r = - FStar_Parser_AST.mk_term - (FStar_Parser_AST.Construct (FStar_Parser_Const.nil_lid, [])) - r FStar_Parser_AST.Expr in - let cons r hd tl = - FStar_Parser_AST.mk_term - (FStar_Parser_AST.Construct - (FStar_Parser_Const.cons_lid, - [(hd, FStar_Parser_AST.Nothing); - (tl, FStar_Parser_AST.Nothing)])) r - FStar_Parser_AST.Expr in - let t' = - let uu___2 = nil top.FStar_Parser_AST.range in - FStar_Compiler_List.fold_right - (cons top.FStar_Parser_AST.range) ts uu___2 in - desugar_term_aq env t' - | FStar_Parser_AST.SeqLiteral ts -> - let nil r = - FStar_Parser_AST.mk_term - (FStar_Parser_AST.Var FStar_Parser_Const.seq_empty_lid) r - FStar_Parser_AST.Expr in - let cons r hd tl = - let uu___2 = - FStar_Parser_AST.mk_term - (FStar_Parser_AST.Var FStar_Parser_Const.seq_cons_lid) r - FStar_Parser_AST.Expr in - FStar_Parser_AST.mkApp uu___2 - [(hd, FStar_Parser_AST.Nothing); - (tl, FStar_Parser_AST.Nothing)] r in - let t' = - let uu___2 = nil top.FStar_Parser_AST.range in - FStar_Compiler_List.fold_right - (cons top.FStar_Parser_AST.range) ts uu___2 in - desugar_term_aq env t' - | uu___2 when top.FStar_Parser_AST.level = FStar_Parser_AST.Formula - -> let uu___3 = desugar_formula env top in (uu___3, noaqs) - | uu___2 -> - let uu___3 = - let uu___4 = FStar_Parser_AST.term_to_string top in - Prims.strcat "Unexpected term: " uu___4 in - FStar_Errors.raise_error FStar_Parser_AST.hasRange_term top - FStar_Errors_Codes.Fatal_UnexpectedTerm () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___3)) -and (desugar_match_returns : - env_t -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - (FStar_Ident.ident FStar_Pervasives_Native.option * - FStar_Parser_AST.term * Prims.bool) FStar_Pervasives_Native.option -> - ((FStar_Syntax_Syntax.binder * - ((FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax, - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax) - FStar_Pervasives.either * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax FStar_Pervasives_Native.option * - Prims.bool)) FStar_Pervasives_Native.option * - (FStar_Syntax_Syntax.bv * FStar_Syntax_Syntax.term) Prims.list)) - = - fun env -> - fun scrutinee -> - fun asc_opt -> - match asc_opt with - | FStar_Pervasives_Native.None -> (FStar_Pervasives_Native.None, []) - | FStar_Pervasives_Native.Some asc -> - let uu___ = asc in - (match uu___ with - | (asc_b, asc_tc, asc_use_eq) -> - let uu___1 = - match asc_b with - | FStar_Pervasives_Native.None -> - let bv = - FStar_Syntax_Syntax.gen_bv - FStar_Parser_Const.match_returns_def_name - (FStar_Pervasives_Native.Some - (scrutinee.FStar_Syntax_Syntax.pos)) - FStar_Syntax_Syntax.tun in - let uu___2 = FStar_Syntax_Syntax.mk_binder bv in - (env, uu___2) - | FStar_Pervasives_Native.Some b -> - let uu___2 = FStar_Syntax_DsEnv.push_bv env b in - (match uu___2 with - | (env1, bv) -> - let uu___3 = FStar_Syntax_Syntax.mk_binder bv in - (env1, uu___3)) in - (match uu___1 with - | (env_asc, b) -> - let uu___2 = - desugar_ascription env_asc asc_tc - FStar_Pervasives_Native.None asc_use_eq in - (match uu___2 with - | (asc1, aq) -> - let asc2 = - let uu___3 = - let uu___4 = - FStar_Syntax_Util.unascribe scrutinee in - uu___4.FStar_Syntax_Syntax.n in - match uu___3 with - | FStar_Syntax_Syntax.Tm_name sbv -> - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Syntax_Syntax.bv_to_name - b.FStar_Syntax_Syntax.binder_bv in - (sbv, uu___7) in - FStar_Syntax_Syntax.NT uu___6 in - [uu___5] in - FStar_Syntax_Subst.subst_ascription uu___4 - asc1 - | uu___4 -> asc1 in - let asc3 = - FStar_Syntax_Subst.close_ascription [b] asc2 in - let b1 = - let uu___3 = - FStar_Syntax_Subst.close_binders [b] in - FStar_Compiler_List.hd uu___3 in - ((FStar_Pervasives_Native.Some (b1, asc3)), aq)))) -and (desugar_ascription : - env_t -> - FStar_Parser_AST.term -> - FStar_Parser_AST.term FStar_Pervasives_Native.option -> - Prims.bool -> (FStar_Syntax_Syntax.ascription * antiquotations_temp)) - = - fun env -> - fun t -> - fun tac_opt -> - fun use_eq -> - let uu___ = - let uu___1 = is_comp_type env t in - if uu___1 - then - (if use_eq - then - FStar_Errors.raise_error FStar_Parser_AST.hasRange_term t - FStar_Errors_Codes.Fatal_NotSupported () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Equality ascription with computation types is not supported yet") - else - (let comp = desugar_comp t.FStar_Parser_AST.range true env t in - ((FStar_Pervasives.Inr comp), []))) - else - (let uu___3 = desugar_term_aq env t in - match uu___3 with - | (tm, aq) -> ((FStar_Pervasives.Inl tm), aq)) in - match uu___ with - | (annot, aq0) -> - let uu___1 = - let uu___2 = - FStar_Compiler_Util.map_opt tac_opt (desugar_term env) in - (annot, uu___2, use_eq) in - (uu___1, aq0) -and (desugar_args : - FStar_Syntax_DsEnv.env -> - (FStar_Parser_AST.term * FStar_Parser_AST.imp) Prims.list -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.arg_qualifier - FStar_Pervasives_Native.option) Prims.list) - = - fun env -> - fun args -> - FStar_Compiler_List.map - (fun uu___ -> - match uu___ with - | (a, imp) -> - let uu___1 = desugar_term env a in arg_withimp_t imp uu___1) - args -and (desugar_comp : - FStar_Compiler_Range_Type.range -> - Prims.bool -> - FStar_Syntax_DsEnv.env -> - FStar_Parser_AST.term -> FStar_Syntax_Syntax.comp) - = - fun r -> - fun allow_type_promotion -> - fun env -> - fun t -> - let fail code msg = - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r - code () (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic msg) in - let is_requires uu___ = - match uu___ with - | (t1, uu___1) -> - let uu___2 = - let uu___3 = unparen t1 in uu___3.FStar_Parser_AST.tm in - (match uu___2 with - | FStar_Parser_AST.Requires uu___3 -> true - | uu___3 -> false) in - let is_ensures uu___ = - match uu___ with - | (t1, uu___1) -> - let uu___2 = - let uu___3 = unparen t1 in uu___3.FStar_Parser_AST.tm in - (match uu___2 with - | FStar_Parser_AST.Ensures uu___3 -> true - | uu___3 -> false) in - let is_decreases uu___ = - match uu___ with - | (t1, uu___1) -> - let uu___2 = - let uu___3 = unparen t1 in uu___3.FStar_Parser_AST.tm in - (match uu___2 with - | FStar_Parser_AST.Decreases uu___3 -> true - | uu___3 -> false) in - let is_smt_pat1 t1 = - let uu___ = let uu___1 = unparen t1 in uu___1.FStar_Parser_AST.tm in - match uu___ with - | FStar_Parser_AST.Construct (smtpat, uu___1) -> - FStar_Compiler_Util.for_some - (fun s -> - let uu___2 = FStar_Ident.string_of_lid smtpat in - uu___2 = s) ["SMTPat"; "SMTPatT"; "SMTPatOr"] - | FStar_Parser_AST.Var smtpat -> - FStar_Compiler_Util.for_some - (fun s -> - let uu___1 = FStar_Ident.string_of_lid smtpat in - uu___1 = s) ["smt_pat"; "smt_pat_or"] - | uu___1 -> false in - let is_smt_pat uu___ = - match uu___ with - | (t1, uu___1) -> - let uu___2 = - let uu___3 = unparen t1 in uu___3.FStar_Parser_AST.tm in - (match uu___2 with - | FStar_Parser_AST.ListLiteral ts -> - FStar_Compiler_Util.for_all is_smt_pat1 ts - | uu___3 -> false) in - let pre_process_comp_typ t1 = - let uu___ = head_and_args t1 in - match uu___ with - | (head, args) -> - (match head.FStar_Parser_AST.tm with - | FStar_Parser_AST.Name lemma when - let uu___1 = - let uu___2 = FStar_Ident.ident_of_lid lemma in - FStar_Ident.string_of_id uu___2 in - uu___1 = "Lemma" -> - let unit_tm = - let uu___1 = - FStar_Parser_AST.mk_term - (FStar_Parser_AST.Name FStar_Parser_Const.unit_lid) - t1.FStar_Parser_AST.range - FStar_Parser_AST.Type_level in - (uu___1, FStar_Parser_AST.Nothing) in - let nil_pat = - let uu___1 = - FStar_Parser_AST.mk_term - (FStar_Parser_AST.Name FStar_Parser_Const.nil_lid) - t1.FStar_Parser_AST.range FStar_Parser_AST.Expr in - (uu___1, FStar_Parser_AST.Nothing) in - let req_true = - let req = - let uu___1 = - let uu___2 = - FStar_Parser_AST.mk_term - (FStar_Parser_AST.Name - FStar_Parser_Const.true_lid) - t1.FStar_Parser_AST.range - FStar_Parser_AST.Formula in - (uu___2, FStar_Pervasives_Native.None) in - FStar_Parser_AST.Requires uu___1 in - let uu___1 = - FStar_Parser_AST.mk_term req - t1.FStar_Parser_AST.range - FStar_Parser_AST.Type_level in - (uu___1, FStar_Parser_AST.Nothing) in - let thunk_ens uu___1 = - match uu___1 with - | (e, i) -> - let uu___2 = FStar_Parser_AST.thunk e in - (uu___2, i) in - let fail_lemma uu___1 = - let expected_one_of = - ["Lemma post"; - "Lemma (ensures post)"; - "Lemma (requires pre) (ensures post)"; - "Lemma post [SMTPat ...]"; - "Lemma (ensures post) [SMTPat ...]"; - "Lemma (ensures post) (decreases d)"; - "Lemma (ensures post) (decreases d) [SMTPat ...]"; - "Lemma (requires pre) (ensures post) (decreases d)"; - "Lemma (requires pre) (ensures post) [SMTPat ...]"; - "Lemma (requires pre) (ensures post) (decreases d) [SMTPat ...]"] in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Errors_Msg.text - "Invalid arguments to 'Lemma'; expected one of the following" in - let uu___5 = - let uu___6 = - FStar_Compiler_List.map - FStar_Pprint.doc_of_string expected_one_of in - FStar_Errors_Msg.sublist FStar_Pprint.empty - uu___6 in - FStar_Pprint.op_Hat_Hat uu___4 uu___5 in - [uu___3] in - FStar_Errors.raise_error - FStar_Parser_AST.hasRange_term t1 - FStar_Errors_Codes.Fatal_InvalidLemmaArgument () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___2) in - let args1 = - match args with - | [] -> fail_lemma () - | req::[] when is_requires req -> fail_lemma () - | smtpat::[] when is_smt_pat smtpat -> fail_lemma () - | dec::[] when is_decreases dec -> fail_lemma () - | ens::[] -> - let uu___1 = - let uu___2 = - let uu___3 = thunk_ens ens in - [uu___3; nil_pat] in - req_true :: uu___2 in - unit_tm :: uu___1 - | req::ens::[] when - (is_requires req) && (is_ensures ens) -> - let uu___1 = - let uu___2 = - let uu___3 = thunk_ens ens in - [uu___3; nil_pat] in - req :: uu___2 in - unit_tm :: uu___1 - | ens::smtpat::[] when - (((let uu___1 = is_requires ens in - Prims.op_Negation uu___1) && - (let uu___1 = is_smt_pat ens in - Prims.op_Negation uu___1)) - && - (let uu___1 = is_decreases ens in - Prims.op_Negation uu___1)) - && (is_smt_pat smtpat) - -> - let uu___1 = - let uu___2 = - let uu___3 = thunk_ens ens in [uu___3; smtpat] in - req_true :: uu___2 in - unit_tm :: uu___1 - | ens::dec::[] when - (is_ensures ens) && (is_decreases dec) -> - let uu___1 = - let uu___2 = - let uu___3 = thunk_ens ens in - [uu___3; nil_pat; dec] in - req_true :: uu___2 in - unit_tm :: uu___1 - | ens::dec::smtpat::[] when - ((is_ensures ens) && (is_decreases dec)) && - (is_smt_pat smtpat) - -> - let uu___1 = - let uu___2 = - let uu___3 = thunk_ens ens in - [uu___3; smtpat; dec] in - req_true :: uu___2 in - unit_tm :: uu___1 - | req::ens::dec::[] when - ((is_requires req) && (is_ensures ens)) && - (is_decreases dec) - -> - let uu___1 = - let uu___2 = - let uu___3 = thunk_ens ens in - [uu___3; nil_pat; dec] in - req :: uu___2 in - unit_tm :: uu___1 - | req::ens::smtpat::[] when - ((is_requires req) && (is_ensures ens)) && - (is_smt_pat smtpat) - -> - let uu___1 = - let uu___2 = - let uu___3 = thunk_ens ens in [uu___3; smtpat] in - req :: uu___2 in - unit_tm :: uu___1 - | req::ens::dec::smtpat::[] when - (((is_requires req) && (is_ensures ens)) && - (is_smt_pat smtpat)) - && (is_decreases dec) - -> - let uu___1 = - let uu___2 = - let uu___3 = thunk_ens ens in - [uu___3; dec; smtpat] in - req :: uu___2 in - unit_tm :: uu___1 - | _other -> fail_lemma () in - let head_and_attributes = - FStar_Syntax_DsEnv.fail_or env - (FStar_Syntax_DsEnv.try_lookup_effect_name_and_attributes - env) lemma in - (head_and_attributes, args1) - | FStar_Parser_AST.Name l when - FStar_Syntax_DsEnv.is_effect_name env l -> - let uu___1 = - FStar_Syntax_DsEnv.fail_or env - (FStar_Syntax_DsEnv.try_lookup_effect_name_and_attributes - env) l in - (uu___1, args) - | FStar_Parser_AST.Name l when - (let uu___1 = FStar_Syntax_DsEnv.current_module env in - FStar_Ident.lid_equals uu___1 - FStar_Parser_Const.prims_lid) - && - (let uu___1 = - let uu___2 = FStar_Ident.ident_of_lid l in - FStar_Ident.string_of_id uu___2 in - uu___1 = "Tot") - -> - let uu___1 = - let uu___2 = - FStar_Ident.set_lid_range - FStar_Parser_Const.effect_Tot_lid - head.FStar_Parser_AST.range in - (uu___2, []) in - (uu___1, args) - | FStar_Parser_AST.Name l when - (let uu___1 = FStar_Syntax_DsEnv.current_module env in - FStar_Ident.lid_equals uu___1 - FStar_Parser_Const.prims_lid) - && - (let uu___1 = - let uu___2 = FStar_Ident.ident_of_lid l in - FStar_Ident.string_of_id uu___2 in - uu___1 = "GTot") - -> - let uu___1 = - let uu___2 = - FStar_Ident.set_lid_range - FStar_Parser_Const.effect_GTot_lid - head.FStar_Parser_AST.range in - (uu___2, []) in - (uu___1, args) - | FStar_Parser_AST.Name l when - ((let uu___1 = - let uu___2 = FStar_Ident.ident_of_lid l in - FStar_Ident.string_of_id uu___2 in - uu___1 = "Type") || - (let uu___1 = - let uu___2 = FStar_Ident.ident_of_lid l in - FStar_Ident.string_of_id uu___2 in - uu___1 = "Type0")) - || - (let uu___1 = - let uu___2 = FStar_Ident.ident_of_lid l in - FStar_Ident.string_of_id uu___2 in - uu___1 = "Effect") - -> - let uu___1 = - let uu___2 = - FStar_Ident.set_lid_range - FStar_Parser_Const.effect_Tot_lid - head.FStar_Parser_AST.range in - (uu___2, []) in - (uu___1, [(t1, FStar_Parser_AST.Nothing)]) - | uu___1 when allow_type_promotion -> - let default_effect = - let uu___2 = FStar_Options.ml_ish () in - if uu___2 - then FStar_Parser_Const.effect_ML_lid () - else - ((let uu___5 = FStar_Options.warn_default_effects () in - if uu___5 - then - FStar_Errors.log_issue - FStar_Parser_AST.hasRange_term head - FStar_Errors_Codes.Warning_UseDefaultEffect () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic "Using default effect Tot") - else ()); - FStar_Parser_Const.effect_Tot_lid) in - let uu___2 = - let uu___3 = - FStar_Ident.set_lid_range default_effect - head.FStar_Parser_AST.range in - (uu___3, []) in - (uu___2, [(t1, FStar_Parser_AST.Nothing)]) - | uu___1 -> - FStar_Errors.raise_error FStar_Parser_AST.hasRange_term - t1 FStar_Errors_Codes.Fatal_EffectNotFound () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic "Expected an effect constructor")) in - let uu___ = pre_process_comp_typ t in - match uu___ with - | ((eff, cattributes), args) -> - (if (FStar_Compiler_List.length args) = Prims.int_zero - then - (let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Ident.showable_lident eff in - FStar_Compiler_Util.format1 - "Not enough args to effect %s" uu___3 in - fail FStar_Errors_Codes.Fatal_NotEnoughArgsToEffect uu___2) - else (); - (let is_universe uu___2 = - match uu___2 with - | (uu___3, imp) -> imp = FStar_Parser_AST.UnivApp in - let uu___2 = FStar_Compiler_Util.take is_universe args in - match uu___2 with - | (universes, args1) -> - let universes1 = - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with | (u, imp) -> desugar_universe u) - universes in - let uu___3 = - let uu___4 = FStar_Compiler_List.hd args1 in - let uu___5 = FStar_Compiler_List.tl args1 in - (uu___4, uu___5) in - (match uu___3 with - | (result_arg, rest) -> - let result_typ = - desugar_typ env - (FStar_Pervasives_Native.fst result_arg) in - let uu___4 = - let is_decrease t1 = - let uu___5 = - let uu___6 = - unparen (FStar_Pervasives_Native.fst t1) in - uu___6.FStar_Parser_AST.tm in - match uu___5 with - | FStar_Parser_AST.Decreases uu___6 -> true - | uu___6 -> false in - FStar_Compiler_List.partition is_decrease rest in - (match uu___4 with - | (dec, rest1) -> - let rest2 = desugar_args env rest1 in - let decreases_clause = - FStar_Compiler_List.map - (fun t1 -> - let uu___5 = - let uu___6 = - unparen - (FStar_Pervasives_Native.fst t1) in - uu___6.FStar_Parser_AST.tm in - match uu___5 with - | FStar_Parser_AST.Decreases - (t2, uu___6) -> - let dec_order = - let t3 = unparen t2 in - match t3.FStar_Parser_AST.tm with - | FStar_Parser_AST.LexList l -> - let uu___7 = - FStar_Compiler_List.map - (desugar_term env) l in - FStar_Syntax_Syntax.Decreases_lex - uu___7 - | FStar_Parser_AST.WFOrder - (t11, t21) -> - let uu___7 = - let uu___8 = - desugar_term env t11 in - let uu___9 = - desugar_term env t21 in - (uu___8, uu___9) in - FStar_Syntax_Syntax.Decreases_wf - uu___7 - | uu___7 -> - let uu___8 = - let uu___9 = - desugar_term env t3 in - [uu___9] in - FStar_Syntax_Syntax.Decreases_lex - uu___8 in - FStar_Syntax_Syntax.DECREASES - dec_order - | uu___6 -> - fail - FStar_Errors_Codes.Fatal_UnexpectedComputationTypeForLetRec - "Unexpected decreases clause") dec in - let no_additional_args = - let is_empty l = - match l with | [] -> true | uu___5 -> false in - (((is_empty decreases_clause) && - (is_empty rest2)) - && (is_empty cattributes)) - && (is_empty universes1) in - let uu___5 = - no_additional_args && - (FStar_Ident.lid_equals eff - FStar_Parser_Const.effect_Tot_lid) in - if uu___5 - then FStar_Syntax_Syntax.mk_Total result_typ - else - (let uu___7 = - no_additional_args && - (FStar_Ident.lid_equals eff - FStar_Parser_Const.effect_GTot_lid) in - if uu___7 - then - FStar_Syntax_Syntax.mk_GTotal result_typ - else - (let flags = - let uu___9 = - FStar_Ident.lid_equals eff - FStar_Parser_Const.effect_Lemma_lid in - if uu___9 - then [FStar_Syntax_Syntax.LEMMA] - else - (let uu___11 = - FStar_Ident.lid_equals eff - FStar_Parser_Const.effect_Tot_lid in - if uu___11 - then [FStar_Syntax_Syntax.TOTAL] - else - (let uu___13 = - let uu___14 = - FStar_Parser_Const.effect_ML_lid - () in - FStar_Ident.lid_equals eff - uu___14 in - if uu___13 - then - [FStar_Syntax_Syntax.MLEFFECT] - else - (let uu___15 = - FStar_Ident.lid_equals eff - FStar_Parser_Const.effect_GTot_lid in - if uu___15 - then - [FStar_Syntax_Syntax.SOMETRIVIAL] - else []))) in - let flags1 = - FStar_Compiler_List.op_At flags - cattributes in - let rest3 = - let uu___9 = - FStar_Ident.lid_equals eff - FStar_Parser_Const.effect_Lemma_lid in - if uu___9 - then - match rest2 with - | req::ens::(pat, aq)::[] -> - let pat1 = - match pat.FStar_Syntax_Syntax.n - with - | FStar_Syntax_Syntax.Tm_fvar - fv when - FStar_Syntax_Syntax.fv_eq_lid - fv - FStar_Parser_Const.nil_lid - -> - let nil = - FStar_Syntax_Syntax.mk_Tm_uinst - pat - [FStar_Syntax_Syntax.U_zero] in - let pattern = - let uu___10 = - FStar_Ident.set_lid_range - FStar_Parser_Const.pattern_lid - pat.FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.fvar_with_dd - uu___10 - FStar_Pervasives_Native.None in - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Syntax_Syntax.as_aqual_implicit - true in - (pattern, uu___12) in - [uu___11] in - FStar_Syntax_Syntax.mk_Tm_app - nil uu___10 - pat.FStar_Syntax_Syntax.pos - | uu___10 -> pat in - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 - = pat1; - FStar_Syntax_Syntax.meta - = - (FStar_Syntax_Syntax.Meta_desugared - FStar_Syntax_Syntax.Meta_smt_pat) - }) - pat1.FStar_Syntax_Syntax.pos in - (uu___13, aq) in - [uu___12] in - ens :: uu___11 in - req :: uu___10 - | uu___10 -> rest2 - else rest2 in - FStar_Syntax_Syntax.mk_Comp - { - FStar_Syntax_Syntax.comp_univs = - universes1; - FStar_Syntax_Syntax.effect_name = eff; - FStar_Syntax_Syntax.result_typ = - result_typ; - FStar_Syntax_Syntax.effect_args = - rest3; - FStar_Syntax_Syntax.flags = - (FStar_Compiler_List.op_At flags1 - decreases_clause) - })))))) -and (desugar_formula : - FStar_Syntax_DsEnv.env -> FStar_Parser_AST.term -> FStar_Syntax_Syntax.term) - = - fun env -> - fun f -> - let mk t = FStar_Syntax_Syntax.mk t f.FStar_Parser_AST.range in - let setpos t = - { - FStar_Syntax_Syntax.n = (t.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = (f.FStar_Parser_AST.range); - FStar_Syntax_Syntax.vars = (t.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = (t.FStar_Syntax_Syntax.hash_code) - } in - let desugar_quant q_head b pats should_wrap_with_pat body = - let tk = - desugar_binder env - { - FStar_Parser_AST.b = (b.FStar_Parser_AST.b); - FStar_Parser_AST.brange = (b.FStar_Parser_AST.brange); - FStar_Parser_AST.blevel = FStar_Parser_AST.Formula; - FStar_Parser_AST.aqual = (b.FStar_Parser_AST.aqual); - FStar_Parser_AST.battributes = (b.FStar_Parser_AST.battributes) - } in - let with_pats env1 uu___ body1 = - match uu___ with - | (names, pats1) -> - (match (names, pats1) with - | ([], []) -> body1 - | ([], uu___1::uu___2) -> - failwith - "Impossible: Annotated pattern without binders in scope" - | uu___1 -> - let names1 = - FStar_Compiler_List.map - (fun i -> - let uu___2 = - FStar_Syntax_DsEnv.fail_or2 - (FStar_Syntax_DsEnv.try_lookup_id env1) i in - let uu___3 = FStar_Ident.range_of_id i in - { - FStar_Syntax_Syntax.n = - (uu___2.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = uu___3; - FStar_Syntax_Syntax.vars = - (uu___2.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (uu___2.FStar_Syntax_Syntax.hash_code) - }) names in - let pats2 = - FStar_Compiler_List.map - (fun es -> - FStar_Compiler_List.map - (fun e -> - let uu___2 = desugar_term env1 e in - arg_withimp_t FStar_Parser_AST.Nothing uu___2) - es) pats1 in - (match pats2 with - | [] when Prims.op_Negation should_wrap_with_pat -> body1 - | uu___2 -> - mk - (FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 = body1; - FStar_Syntax_Syntax.meta = - (FStar_Syntax_Syntax.Meta_pattern - (names1, pats2)) - }))) in - match tk with - | (FStar_Pervasives_Native.Some a, k, uu___) -> - let uu___1 = FStar_Syntax_DsEnv.push_bv env a in - (match uu___1 with - | (env1, a1) -> - let a2 = - { - FStar_Syntax_Syntax.ppname = - (a1.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (a1.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = k - } in - let body1 = desugar_formula env1 body in - let body2 = with_pats env1 pats body1 in - let body3 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Syntax.mk_binder a2 in - [uu___4] in - no_annot_abs uu___3 body2 in - setpos uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.as_arg body3 in - [uu___5] in - { - FStar_Syntax_Syntax.hd = q_head; - FStar_Syntax_Syntax.args = uu___4 - } in - FStar_Syntax_Syntax.Tm_app uu___3 in - mk uu___2) - | uu___ -> failwith "impossible" in - let push_quant q binders pats body = - match binders with - | b::b'::_rest -> - let rest = b' :: _rest in - let body1 = - let uu___ = q (rest, pats, body) in - let uu___1 = - FStar_Compiler_Range_Ops.union_ranges - b'.FStar_Parser_AST.brange body.FStar_Parser_AST.range in - FStar_Parser_AST.mk_term uu___ uu___1 FStar_Parser_AST.Formula in - let uu___ = q ([b], ([], []), body1) in - FStar_Parser_AST.mk_term uu___ f.FStar_Parser_AST.range - FStar_Parser_AST.Formula - | uu___ -> failwith "impossible" in - let uu___ = let uu___1 = unparen f in uu___1.FStar_Parser_AST.tm in - match uu___ with - | FStar_Parser_AST.Labeled (f1, l, p) -> - let f2 = desugar_formula env f1 in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Errors_Msg.mkmsg l in - (uu___5, (f2.FStar_Syntax_Syntax.pos), p) in - FStar_Syntax_Syntax.Meta_labeled uu___4 in - { - FStar_Syntax_Syntax.tm2 = f2; - FStar_Syntax_Syntax.meta = uu___3 - } in - FStar_Syntax_Syntax.Tm_meta uu___2 in - mk uu___1 - | FStar_Parser_AST.QForall ([], uu___1, uu___2) -> - failwith "Impossible: Quantifier without binders" - | FStar_Parser_AST.QExists ([], uu___1, uu___2) -> - failwith "Impossible: Quantifier without binders" - | FStar_Parser_AST.QuantOp (uu___1, [], uu___2, uu___3) -> - failwith "Impossible: Quantifier without binders" - | FStar_Parser_AST.QForall (_1::_2::_3, pats, body) -> - let binders = _1 :: _2 :: _3 in - let uu___1 = - push_quant (fun x -> FStar_Parser_AST.QForall x) binders pats - body in - desugar_formula env uu___1 - | FStar_Parser_AST.QExists (_1::_2::_3, pats, body) -> - let binders = _1 :: _2 :: _3 in - let uu___1 = - push_quant (fun x -> FStar_Parser_AST.QExists x) binders pats - body in - desugar_formula env uu___1 - | FStar_Parser_AST.QuantOp (i, _1::_2::_3, pats, body) -> - let binders = _1 :: _2 :: _3 in - let uu___1 = - push_quant - (fun uu___2 -> - match uu___2 with - | (x, y, z) -> FStar_Parser_AST.QuantOp (i, x, y, z)) - binders pats body in - desugar_formula env uu___1 - | FStar_Parser_AST.QForall (b::[], pats, body) -> - let q = FStar_Parser_Const.forall_lid in - let q_head = - let uu___1 = - FStar_Ident.set_lid_range q b.FStar_Parser_AST.brange in - FStar_Syntax_Syntax.fvar_with_dd uu___1 - FStar_Pervasives_Native.None in - desugar_quant q_head b pats true body - | FStar_Parser_AST.QExists (b::[], pats, body) -> - let q = FStar_Parser_Const.exists_lid in - let q_head = - let uu___1 = - FStar_Ident.set_lid_range q b.FStar_Parser_AST.brange in - FStar_Syntax_Syntax.fvar_with_dd uu___1 - FStar_Pervasives_Native.None in - desugar_quant q_head b pats true body - | FStar_Parser_AST.QuantOp (i, b::[], pats, body) -> - let q_head = - let uu___1 = op_as_term env Prims.int_zero i in - match uu___1 with - | FStar_Pervasives_Native.None -> - let uu___2 = - let uu___3 = FStar_Ident.string_of_id i in - FStar_Compiler_Util.format1 - "quantifier operator %s not found" uu___3 in - FStar_Errors.raise_error FStar_Ident.hasrange_ident i - FStar_Errors_Codes.Fatal_VariableNotFound () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2) - | FStar_Pervasives_Native.Some t -> t in - desugar_quant q_head b pats false body - | FStar_Parser_AST.Paren f1 -> failwith "impossible" - | uu___1 -> desugar_term env f -and (desugar_binder_aq : - FStar_Syntax_DsEnv.env -> - FStar_Parser_AST.binder -> - ((FStar_Ident.ident FStar_Pervasives_Native.option * - FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.attribute Prims.list) - * antiquotations_temp)) - = - fun env -> - fun b -> - let attrs = - FStar_Compiler_List.map (desugar_term env) - b.FStar_Parser_AST.battributes in - match b.FStar_Parser_AST.b with - | FStar_Parser_AST.TAnnotated (x, t) -> - let uu___ = desugar_typ_aq env t in - (match uu___ with - | (ty, aqs) -> - (((FStar_Pervasives_Native.Some x), ty, attrs), aqs)) - | FStar_Parser_AST.Annotated (x, t) -> - let uu___ = desugar_typ_aq env t in - (match uu___ with - | (ty, aqs) -> - (((FStar_Pervasives_Native.Some x), ty, attrs), aqs)) - | FStar_Parser_AST.NoName t -> - let uu___ = desugar_typ_aq env t in - (match uu___ with - | (ty, aqs) -> ((FStar_Pervasives_Native.None, ty, attrs), aqs)) - | FStar_Parser_AST.TVariable x -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Ident.range_of_id x in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_type FStar_Syntax_Syntax.U_unknown) - uu___2 in - ((FStar_Pervasives_Native.Some x), uu___1, attrs) in - (uu___, []) - | FStar_Parser_AST.Variable x -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Ident.range_of_id x in tun_r uu___2 in - ((FStar_Pervasives_Native.Some x), uu___1, attrs) in - (uu___, []) -and (desugar_binder : - FStar_Syntax_DsEnv.env -> - FStar_Parser_AST.binder -> - (FStar_Ident.ident FStar_Pervasives_Native.option * - FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.attribute Prims.list)) - = - fun env -> - fun b -> - let uu___ = desugar_binder_aq env b in - match uu___ with | (r, aqs) -> (check_no_aq aqs; r) -and (desugar_vquote : - env_t -> - FStar_Parser_AST.term -> FStar_Compiler_Range_Type.range -> Prims.string) - = - fun env -> - fun e -> - fun r -> - let tm = desugar_term env e in - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress tm in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_fvar fv -> - let uu___1 = FStar_Syntax_Syntax.lid_of_fv fv in - FStar_Ident.string_of_lid uu___1 - | uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term tm in - Prims.strcat "VQuote, expected an fvar, got: " uu___3 in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_UnexpectedTermVQuote () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2) -and (as_binder : - FStar_Syntax_DsEnv.env -> - FStar_Parser_AST.arg_qualifier FStar_Pervasives_Native.option -> - (FStar_Ident.ident FStar_Pervasives_Native.option * - FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.attribute Prims.list) - -> (FStar_Syntax_Syntax.binder * FStar_Syntax_DsEnv.env)) - = - fun env -> - fun imp -> - fun uu___ -> - match uu___ with - | (FStar_Pervasives_Native.None, k, attrs) -> - let uu___1 = - let uu___2 = FStar_Syntax_Syntax.null_bv k in - let uu___3 = trans_bqual env imp in - mk_binder_with_attrs uu___2 uu___3 attrs in - (uu___1, env) - | (FStar_Pervasives_Native.Some a, k, attrs) -> - let uu___1 = FStar_Syntax_DsEnv.push_bv env a in - (match uu___1 with - | (env1, a1) -> - let uu___2 = - let uu___3 = trans_bqual env1 imp in - mk_binder_with_attrs - { - FStar_Syntax_Syntax.ppname = - (a1.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (a1.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = k - } uu___3 attrs in - (uu___2, env1)) -and (trans_bqual : - env_t -> - FStar_Parser_AST.arg_qualifier FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.bqual) - = - fun env -> - fun uu___ -> - match uu___ with - | FStar_Pervasives_Native.Some (FStar_Parser_AST.Implicit) -> - FStar_Pervasives_Native.Some FStar_Syntax_Syntax.imp_tag - | FStar_Pervasives_Native.Some (FStar_Parser_AST.Equality) -> - FStar_Pervasives_Native.Some FStar_Syntax_Syntax.Equality - | FStar_Pervasives_Native.Some (FStar_Parser_AST.Meta t) -> - let uu___1 = - let uu___2 = desugar_term env t in - FStar_Syntax_Syntax.Meta uu___2 in - FStar_Pervasives_Native.Some uu___1 - | FStar_Pervasives_Native.Some (FStar_Parser_AST.TypeClassArg) -> - let tcresolve = - let uu___1 = - FStar_Parser_AST.mk_term - (FStar_Parser_AST.Var FStar_Parser_Const.tcresolve_lid) - FStar_Compiler_Range_Type.dummyRange FStar_Parser_AST.Expr in - desugar_term env uu___1 in - FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta tcresolve) - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None -let (typars_of_binders : - FStar_Syntax_DsEnv.env -> - FStar_Parser_AST.binder Prims.list -> - (FStar_Syntax_DsEnv.env * FStar_Syntax_Syntax.binders)) - = - fun env -> - fun bs -> - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun b -> - match uu___1 with - | (env1, out) -> - let tk = - desugar_binder env1 - { - FStar_Parser_AST.b = (b.FStar_Parser_AST.b); - FStar_Parser_AST.brange = - (b.FStar_Parser_AST.brange); - FStar_Parser_AST.blevel = FStar_Parser_AST.Formula; - FStar_Parser_AST.aqual = (b.FStar_Parser_AST.aqual); - FStar_Parser_AST.battributes = - (b.FStar_Parser_AST.battributes) - } in - (match tk with - | (FStar_Pervasives_Native.Some a, k, attrs) -> - let uu___2 = FStar_Syntax_DsEnv.push_bv env1 a in - (match uu___2 with - | (env2, a1) -> - let a2 = - { - FStar_Syntax_Syntax.ppname = - (a1.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (a1.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = k - } in - let uu___3 = - let uu___4 = - let uu___5 = - trans_bqual env2 b.FStar_Parser_AST.aqual in - mk_binder_with_attrs a2 uu___5 attrs in - uu___4 :: out in - (env2, uu___3)) - | uu___2 -> - FStar_Errors.raise_error - FStar_Parser_AST.hasRange_binder b - FStar_Errors_Codes.Fatal_UnexpectedBinder () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic "Unexpected binder"))) (env, []) bs in - match uu___ with - | (env1, tpars) -> (env1, (FStar_Compiler_List.rev tpars)) -let (desugar_attributes : - env_t -> - FStar_Parser_AST.term Prims.list -> FStar_Syntax_Syntax.cflag Prims.list) - = - fun env -> - fun cattributes -> - let desugar_attribute t = - let uu___ = let uu___1 = unparen t in uu___1.FStar_Parser_AST.tm in - match uu___ with - | FStar_Parser_AST.Var lid when - let uu___1 = FStar_Ident.string_of_lid lid in uu___1 = "cps" -> - FStar_Syntax_Syntax.CPS - | uu___1 -> - let uu___2 = - let uu___3 = FStar_Parser_AST.term_to_string t in - Prims.strcat "Unknown attribute " uu___3 in - FStar_Errors.raise_error FStar_Parser_AST.hasRange_term t - FStar_Errors_Codes.Fatal_UnknownAttribute () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2) in - FStar_Compiler_List.map desugar_attribute cattributes -let (binder_ident : - FStar_Parser_AST.binder -> FStar_Ident.ident FStar_Pervasives_Native.option) - = - fun b -> - match b.FStar_Parser_AST.b with - | FStar_Parser_AST.TAnnotated (x, uu___) -> - FStar_Pervasives_Native.Some x - | FStar_Parser_AST.Annotated (x, uu___) -> FStar_Pervasives_Native.Some x - | FStar_Parser_AST.TVariable x -> FStar_Pervasives_Native.Some x - | FStar_Parser_AST.Variable x -> FStar_Pervasives_Native.Some x - | FStar_Parser_AST.NoName uu___ -> FStar_Pervasives_Native.None -let (binder_idents : - FStar_Parser_AST.binder Prims.list -> FStar_Ident.ident Prims.list) = - fun bs -> - FStar_Compiler_List.collect - (fun b -> - let uu___ = binder_ident b in FStar_Common.list_of_option uu___) bs -let (mk_data_discriminators : - FStar_Syntax_Syntax.qualifier Prims.list -> - FStar_Syntax_DsEnv.env -> - FStar_Ident.lident Prims.list -> - FStar_Syntax_Syntax.attribute Prims.list -> - FStar_Syntax_Syntax.sigelt Prims.list) - = - fun quals -> - fun env -> - fun datas -> - fun attrs -> - let quals1 = - FStar_Compiler_List.filter - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.NoExtract -> true - | FStar_Syntax_Syntax.Private -> true - | uu___1 -> false) quals in - let quals2 q = - let uu___ = - (let uu___1 = FStar_Syntax_DsEnv.iface env in - Prims.op_Negation uu___1) || - (FStar_Syntax_DsEnv.admitted_iface env) in - if uu___ - then - FStar_Compiler_List.op_At (FStar_Syntax_Syntax.Assumption :: q) - quals1 - else FStar_Compiler_List.op_At q quals1 in - FStar_Compiler_List.map - (fun d -> - let disc_name = FStar_Syntax_Util.mk_discriminator d in - let uu___ = FStar_Ident.range_of_lid disc_name in - let uu___1 = - quals2 - [FStar_Syntax_Syntax.OnlyName; - FStar_Syntax_Syntax.Discriminator d] in - let uu___2 = FStar_Syntax_DsEnv.opens_and_abbrevs env in - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_declare_typ - { - FStar_Syntax_Syntax.lid2 = disc_name; - FStar_Syntax_Syntax.us2 = []; - FStar_Syntax_Syntax.t2 = FStar_Syntax_Syntax.tun - }); - FStar_Syntax_Syntax.sigrng = uu___; - FStar_Syntax_Syntax.sigquals = uu___1; - FStar_Syntax_Syntax.sigmeta = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs = attrs; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___2; - FStar_Syntax_Syntax.sigopts = FStar_Pervasives_Native.None - }) datas -let (mk_indexed_projector_names : - FStar_Syntax_Syntax.qualifier Prims.list -> - FStar_Syntax_Syntax.fv_qual -> - FStar_Syntax_Syntax.attribute Prims.list -> - FStar_Syntax_DsEnv.env -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.binder Prims.list -> - FStar_Syntax_Syntax.sigelt Prims.list) - = - fun iquals -> - fun fvq -> - fun attrs -> - fun env -> - fun lid -> - fun fields -> - let p = FStar_Ident.range_of_lid lid in - let uu___ = - FStar_Compiler_List.mapi - (fun i -> - fun fld -> - let x = fld.FStar_Syntax_Syntax.binder_bv in - let field_name = - FStar_Syntax_Util.mk_field_projector_name lid x i in - let only_decl = - ((let uu___1 = FStar_Syntax_DsEnv.current_module env in - FStar_Ident.lid_equals - FStar_Parser_Const.prims_lid uu___1) - || (fvq <> FStar_Syntax_Syntax.Data_ctor)) - || - (FStar_Syntax_Util.has_attribute attrs - FStar_Parser_Const.no_auto_projectors_attr) in - let no_decl = - FStar_Syntax_Syntax.is_type - x.FStar_Syntax_Syntax.sort in - let quals q = - if only_decl - then FStar_Syntax_Syntax.Assumption :: q - else q in - let quals1 = - let iquals1 = - FStar_Compiler_List.filter - (fun uu___1 -> - match uu___1 with - | FStar_Syntax_Syntax.NoExtract -> true - | FStar_Syntax_Syntax.Private -> true - | uu___2 -> false) iquals in - quals (FStar_Syntax_Syntax.OnlyName :: - (FStar_Syntax_Syntax.Projector - (lid, (x.FStar_Syntax_Syntax.ppname))) :: - iquals1) in - let decl = - let uu___1 = FStar_Ident.range_of_lid field_name in - let uu___2 = - FStar_Syntax_DsEnv.opens_and_abbrevs env in - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_declare_typ - { - FStar_Syntax_Syntax.lid2 = field_name; - FStar_Syntax_Syntax.us2 = []; - FStar_Syntax_Syntax.t2 = - FStar_Syntax_Syntax.tun - }); - FStar_Syntax_Syntax.sigrng = uu___1; - FStar_Syntax_Syntax.sigquals = quals1; - FStar_Syntax_Syntax.sigmeta = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs = attrs; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___2; - FStar_Syntax_Syntax.sigopts = - FStar_Pervasives_Native.None - } in - if only_decl - then [decl] - else - (let lb = - let uu___2 = - let uu___3 = - FStar_Syntax_Syntax.lid_and_dd_as_fv - field_name FStar_Pervasives_Native.None in - FStar_Pervasives.Inr uu___3 in - { - FStar_Syntax_Syntax.lbname = uu___2; - FStar_Syntax_Syntax.lbunivs = []; - FStar_Syntax_Syntax.lbtyp = - FStar_Syntax_Syntax.tun; - FStar_Syntax_Syntax.lbeff = - FStar_Parser_Const.effect_Tot_lid; - FStar_Syntax_Syntax.lbdef = - FStar_Syntax_Syntax.tun; - FStar_Syntax_Syntax.lbattrs = []; - FStar_Syntax_Syntax.lbpos = - FStar_Compiler_Range_Type.dummyRange - } in - let impl = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Compiler_Util.right - lb.FStar_Syntax_Syntax.lbname in - (uu___6.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - [uu___5] in - { - FStar_Syntax_Syntax.lbs1 = (false, [lb]); - FStar_Syntax_Syntax.lids1 = uu___4 - } in - FStar_Syntax_Syntax.Sig_let uu___3 in - let uu___3 = - FStar_Syntax_DsEnv.opens_and_abbrevs env in - { - FStar_Syntax_Syntax.sigel = uu___2; - FStar_Syntax_Syntax.sigrng = p; - FStar_Syntax_Syntax.sigquals = quals1; - FStar_Syntax_Syntax.sigmeta = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs = attrs; - FStar_Syntax_Syntax.sigopens_and_abbrevs = - uu___3; - FStar_Syntax_Syntax.sigopts = - FStar_Pervasives_Native.None - } in - if no_decl then [impl] else [decl; impl])) fields in - FStar_Compiler_List.flatten uu___ -let (mk_data_projector_names : - FStar_Syntax_Syntax.qualifier Prims.list -> - FStar_Syntax_DsEnv.env -> - FStar_Syntax_Syntax.sigelt -> FStar_Syntax_Syntax.sigelt Prims.list) - = - fun iquals -> - fun env -> - fun se -> - if - (FStar_Syntax_Util.has_attribute se.FStar_Syntax_Syntax.sigattrs - FStar_Parser_Const.no_auto_projectors_decls_attr) - || - (FStar_Syntax_Util.has_attribute se.FStar_Syntax_Syntax.sigattrs - FStar_Parser_Const.meta_projectors_attr) - then [] - else - (match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = lid; - FStar_Syntax_Syntax.us1 = uu___; FStar_Syntax_Syntax.t1 = t; - FStar_Syntax_Syntax.ty_lid = uu___1; - FStar_Syntax_Syntax.num_ty_params = n; - FStar_Syntax_Syntax.mutuals1 = uu___2; - FStar_Syntax_Syntax.injective_type_params1 = uu___3;_} - -> - let uu___4 = FStar_Syntax_Util.arrow_formals t in - (match uu___4 with - | (formals, uu___5) -> - (match formals with - | [] -> [] - | uu___6 -> - let filter_records uu___7 = - match uu___7 with - | FStar_Syntax_Syntax.RecordConstructor - (uu___8, fns) -> - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Record_ctor (lid, fns)) - | uu___8 -> FStar_Pervasives_Native.None in - let fv_qual = - let uu___7 = - FStar_Compiler_Util.find_map - se.FStar_Syntax_Syntax.sigquals filter_records in - match uu___7 with - | FStar_Pervasives_Native.None -> - FStar_Syntax_Syntax.Data_ctor - | FStar_Pervasives_Native.Some q -> q in - let uu___7 = FStar_Compiler_Util.first_N n formals in - (match uu___7 with - | (uu___8, rest) -> - mk_indexed_projector_names iquals fv_qual - se.FStar_Syntax_Syntax.sigattrs env lid rest))) - | uu___ -> []) -let (mk_typ_abbrev : - FStar_Syntax_DsEnv.env -> - FStar_Parser_AST.decl -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.univ_name Prims.list -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.typ FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Ident.lident Prims.list -> - FStar_Syntax_Syntax.qualifier Prims.list -> - FStar_Compiler_Range_Type.range -> - FStar_Syntax_Syntax.sigelt) - = - fun env -> - fun d -> - fun lid -> - fun uvs -> - fun typars -> - fun kopt -> - fun t -> - fun lids -> - fun quals -> - fun rng -> - let attrs = - let uu___ = - FStar_Compiler_List.map (desugar_term env) - d.FStar_Parser_AST.attrs in - FStar_Syntax_Util.deduplicate_terms uu___ in - let val_attrs = - let uu___ = - FStar_Syntax_DsEnv.lookup_letbinding_quals_and_attrs - env lid in - FStar_Pervasives_Native.snd uu___ in - let lb = - let uu___ = - let uu___1 = - FStar_Syntax_Syntax.lid_and_dd_as_fv lid - FStar_Pervasives_Native.None in - FStar_Pervasives.Inr uu___1 in - let uu___1 = - if FStar_Compiler_Util.is_some kopt - then - let uu___2 = - let uu___3 = FStar_Compiler_Util.must kopt in - FStar_Syntax_Syntax.mk_Total uu___3 in - FStar_Syntax_Util.arrow typars uu___2 - else FStar_Syntax_Syntax.tun in - let uu___2 = no_annot_abs typars t in - { - FStar_Syntax_Syntax.lbname = uu___; - FStar_Syntax_Syntax.lbunivs = uvs; - FStar_Syntax_Syntax.lbtyp = uu___1; - FStar_Syntax_Syntax.lbeff = - FStar_Parser_Const.effect_Tot_lid; - FStar_Syntax_Syntax.lbdef = uu___2; - FStar_Syntax_Syntax.lbattrs = []; - FStar_Syntax_Syntax.lbpos = rng - } in - let uu___ = - FStar_Syntax_Util.deduplicate_terms - (FStar_Compiler_List.op_At val_attrs attrs) in - let uu___1 = FStar_Syntax_DsEnv.opens_and_abbrevs env in - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_let - { - FStar_Syntax_Syntax.lbs1 = (false, [lb]); - FStar_Syntax_Syntax.lids1 = lids - }); - FStar_Syntax_Syntax.sigrng = rng; - FStar_Syntax_Syntax.sigquals = quals; - FStar_Syntax_Syntax.sigmeta = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs = uu___; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___1; - FStar_Syntax_Syntax.sigopts = - FStar_Pervasives_Native.None - } -let rec (desugar_tycon : - FStar_Syntax_DsEnv.env -> - FStar_Parser_AST.decl -> - FStar_Syntax_Syntax.term Prims.list -> - FStar_Syntax_Syntax.qualifier Prims.list -> - FStar_Parser_AST.tycon Prims.list -> - (env_t * FStar_Syntax_Syntax.sigelts)) - = - fun env -> - fun d -> - fun d_attrs_initial -> - fun quals -> - fun tcs -> - let rng = d.FStar_Parser_AST.drange in - let tycon_id uu___ = - match uu___ with - | FStar_Parser_AST.TyconAbstract (id, uu___1, uu___2) -> id - | FStar_Parser_AST.TyconAbbrev (id, uu___1, uu___2, uu___3) -> - id - | FStar_Parser_AST.TyconRecord - (id, uu___1, uu___2, uu___3, uu___4) -> id - | FStar_Parser_AST.TyconVariant (id, uu___1, uu___2, uu___3) -> - id in - let binder_to_term b = - match b.FStar_Parser_AST.b with - | FStar_Parser_AST.Annotated (x, uu___) -> - let uu___1 = - let uu___2 = FStar_Ident.lid_of_ids [x] in - FStar_Parser_AST.Var uu___2 in - let uu___2 = FStar_Ident.range_of_id x in - FStar_Parser_AST.mk_term uu___1 uu___2 - FStar_Parser_AST.Expr - | FStar_Parser_AST.Variable x -> - let uu___ = - let uu___1 = FStar_Ident.lid_of_ids [x] in - FStar_Parser_AST.Var uu___1 in - let uu___1 = FStar_Ident.range_of_id x in - FStar_Parser_AST.mk_term uu___ uu___1 FStar_Parser_AST.Expr - | FStar_Parser_AST.TAnnotated (a, uu___) -> - let uu___1 = FStar_Ident.range_of_id a in - FStar_Parser_AST.mk_term (FStar_Parser_AST.Tvar a) uu___1 - FStar_Parser_AST.Type_level - | FStar_Parser_AST.TVariable a -> - let uu___ = FStar_Ident.range_of_id a in - FStar_Parser_AST.mk_term (FStar_Parser_AST.Tvar a) uu___ - FStar_Parser_AST.Type_level - | FStar_Parser_AST.NoName t -> t in - let desugar_tycon_variant_record uu___ = - match uu___ with - | FStar_Parser_AST.TyconVariant (id, bds, k, variants) -> - let uu___1 = - let uu___2 = - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with - | (cid, payload, attrs) -> - (match payload with - | FStar_Pervasives_Native.Some - (FStar_Parser_AST.VpRecord (r, k1)) -> - let record_id = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Ident.string_of_id id in - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Ident.string_of_id cid in - Prims.strcat uu___9 "__payload" in - Prims.strcat "__" uu___8 in - Prims.strcat uu___6 uu___7 in - let uu___6 = - FStar_Ident.range_of_id cid in - (uu___5, uu___6) in - FStar_Ident.mk_ident uu___4 in - let record_id_t = - let uu___4 = - let uu___5 = - FStar_Ident.lid_of_ns_and_id [] - record_id in - FStar_Parser_AST.Var uu___5 in - let uu___5 = - FStar_Ident.range_of_id cid in - { - FStar_Parser_AST.tm = uu___4; - FStar_Parser_AST.range = uu___5; - FStar_Parser_AST.level = - FStar_Parser_AST.Type_level - } in - let payload_typ = - let uu___4 = - FStar_Compiler_List.map - (fun bd -> - let uu___5 = binder_to_term bd in - (uu___5, - FStar_Parser_AST.Nothing)) bds in - let uu___5 = - FStar_Ident.range_of_id record_id in - FStar_Parser_AST.mkApp record_id_t - uu___4 uu___5 in - let desugar_marker = - let range = - FStar_Ident.range_of_id record_id in - let desugar_attr_fv = - { - FStar_Syntax_Syntax.fv_name = - { - FStar_Syntax_Syntax.v = - FStar_Parser_Const.desugar_of_variant_record_lid; - FStar_Syntax_Syntax.p = range - }; - FStar_Syntax_Syntax.fv_qual = - FStar_Pervasives_Native.None - } in - let desugar_attr = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_fvar - desugar_attr_fv) range in - let cid_as_constant = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_DsEnv.qualify env - cid in - FStar_Ident.string_of_lid uu___6 in - FStar_Syntax_Embeddings_Base.embed - FStar_Syntax_Embeddings.e_string - uu___5 in - uu___4 range - FStar_Pervasives_Native.None - FStar_Syntax_Embeddings_Base.id_norm_cb in - FStar_Syntax_Syntax.mk_Tm_app - desugar_attr - [(cid_as_constant, - FStar_Pervasives_Native.None)] - range in - let uu___4 = - let uu___5 = - let uu___6 = - match k1 with - | FStar_Pervasives_Native.None -> - FStar_Parser_AST.VpOfNotation - payload_typ - | FStar_Pervasives_Native.Some k2 - -> - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Ident.range_of_id - record_id in - FStar_Parser_AST.mk_binder - (FStar_Parser_AST.NoName - payload_typ) - uu___12 - FStar_Parser_AST.Type_level - FStar_Pervasives_Native.None in - [uu___11] in - (uu___10, k2) in - FStar_Parser_AST.Product - uu___9 in - { - FStar_Parser_AST.tm = - uu___8; - FStar_Parser_AST.range = - (payload_typ.FStar_Parser_AST.range); - FStar_Parser_AST.level = - FStar_Parser_AST.Type_level - } in - FStar_Parser_AST.VpArbitrary - uu___7 in - FStar_Pervasives_Native.Some uu___6 in - (cid, uu___5, attrs) in - ((FStar_Pervasives_Native.Some - ((FStar_Parser_AST.TyconRecord - (record_id, bds, - FStar_Pervasives_Native.None, - attrs, r)), (desugar_marker :: - d_attrs_initial))), uu___4) - | uu___4 -> - (FStar_Pervasives_Native.None, - (cid, payload, attrs)))) variants in - FStar_Compiler_List.unzip uu___2 in - (match uu___1 with - | (additional_records, variants1) -> - let concat_options = - FStar_Compiler_List.filter_map (fun r -> r) in - let uu___2 = concat_options additional_records in - FStar_Compiler_List.op_At uu___2 - [((FStar_Parser_AST.TyconVariant - (id, bds, k, variants1)), d_attrs_initial)]) - | tycon -> [(tycon, d_attrs_initial)] in - let tcs1 = - FStar_Compiler_List.concatMap desugar_tycon_variant_record tcs in - let tot rng1 = - FStar_Parser_AST.mk_term - (FStar_Parser_AST.Name FStar_Parser_Const.effect_Tot_lid) - rng1 FStar_Parser_AST.Expr in - let with_constructor_effect t = - let uu___ = - let uu___1 = - let uu___2 = tot t.FStar_Parser_AST.range in - (uu___2, t, FStar_Parser_AST.Nothing) in - FStar_Parser_AST.App uu___1 in - FStar_Parser_AST.mk_term uu___ t.FStar_Parser_AST.range - t.FStar_Parser_AST.level in - let apply_binders t binders = - let imp_of_aqual b = - match b.FStar_Parser_AST.aqual with - | FStar_Pervasives_Native.Some (FStar_Parser_AST.Implicit) -> - FStar_Parser_AST.Hash - | FStar_Pervasives_Native.Some (FStar_Parser_AST.Meta uu___) - -> FStar_Parser_AST.Hash - | FStar_Pervasives_Native.Some - (FStar_Parser_AST.TypeClassArg) -> FStar_Parser_AST.Hash - | uu___ -> FStar_Parser_AST.Nothing in - FStar_Compiler_List.fold_left - (fun out -> - fun b -> - let uu___ = - let uu___1 = - let uu___2 = binder_to_term b in - (out, uu___2, (imp_of_aqual b)) in - FStar_Parser_AST.App uu___1 in - FStar_Parser_AST.mk_term uu___ - out.FStar_Parser_AST.range out.FStar_Parser_AST.level) - t binders in - let tycon_record_as_variant uu___ = - match uu___ with - | FStar_Parser_AST.TyconRecord (id, parms, kopt, attrs, fields) - -> - let constrName = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Ident.string_of_id id in - Prims.strcat "Mk" uu___3 in - let uu___3 = FStar_Ident.range_of_id id in - (uu___2, uu___3) in - FStar_Ident.mk_ident uu___1 in - let mfields = - FStar_Compiler_List.map - (fun uu___1 -> - match uu___1 with - | (x, q, attrs1, t) -> - let uu___2 = FStar_Ident.range_of_id x in - FStar_Parser_AST.mk_binder_with_attrs - (FStar_Parser_AST.Annotated (x, t)) uu___2 - FStar_Parser_AST.Expr q attrs1) fields in - let result = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Ident.lid_of_ids [id] in - FStar_Parser_AST.Var uu___3 in - let uu___3 = FStar_Ident.range_of_id id in - FStar_Parser_AST.mk_term uu___2 uu___3 - FStar_Parser_AST.Type_level in - apply_binders uu___1 parms in - let constrTyp = - let uu___1 = - let uu___2 = - let uu___3 = with_constructor_effect result in - (mfields, uu___3) in - FStar_Parser_AST.Product uu___2 in - let uu___2 = FStar_Ident.range_of_id id in - FStar_Parser_AST.mk_term uu___1 uu___2 - FStar_Parser_AST.Type_level in - let names = - let uu___1 = binder_idents parms in id :: uu___1 in - (FStar_Compiler_List.iter - (fun uu___2 -> - match uu___2 with - | (f, uu___3, uu___4, uu___5) -> - let uu___6 = - FStar_Compiler_Util.for_some - (fun i -> FStar_Ident.ident_equals f i) names in - if uu___6 - then - let uu___7 = - let uu___8 = FStar_Ident.string_of_id f in - FStar_Compiler_Util.format1 - "Field %s shadows the record's name or a parameter of it, please rename it" - uu___8 in - FStar_Errors.raise_error - FStar_Ident.hasrange_ident f - FStar_Errors_Codes.Error_FieldShadow () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___7) - else ()) fields; - (let uu___2 = - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with - | (f, uu___4, uu___5, uu___6) -> f) fields in - ((FStar_Parser_AST.TyconVariant - (id, parms, kopt, - [(constrName, - (FStar_Pervasives_Native.Some - (FStar_Parser_AST.VpArbitrary constrTyp)), - attrs)])), uu___2))) - | uu___1 -> failwith "impossible" in - let desugar_abstract_tc quals1 _env mutuals d_attrs uu___ = - match uu___ with - | FStar_Parser_AST.TyconAbstract (id, binders, kopt) -> - let uu___1 = typars_of_binders _env binders in - (match uu___1 with - | (_env', typars) -> - let k = - match kopt with - | FStar_Pervasives_Native.None -> - FStar_Syntax_Util.ktype - | FStar_Pervasives_Native.Some k1 -> - desugar_term _env' k1 in - let tconstr = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Ident.lid_of_ids [id] in - FStar_Parser_AST.Var uu___4 in - let uu___4 = FStar_Ident.range_of_id id in - FStar_Parser_AST.mk_term uu___3 uu___4 - FStar_Parser_AST.Type_level in - apply_binders uu___2 binders in - let qlid = FStar_Syntax_DsEnv.qualify _env id in - let typars1 = FStar_Syntax_Subst.close_binders typars in - let k1 = FStar_Syntax_Subst.close typars1 k in - let se = - let uu___2 = FStar_Ident.range_of_id id in - let uu___3 = - FStar_Syntax_DsEnv.opens_and_abbrevs env in - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_inductive_typ - { - FStar_Syntax_Syntax.lid = qlid; - FStar_Syntax_Syntax.us = []; - FStar_Syntax_Syntax.params = typars1; - FStar_Syntax_Syntax.num_uniform_params = - FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.t = k1; - FStar_Syntax_Syntax.mutuals = mutuals; - FStar_Syntax_Syntax.ds = []; - FStar_Syntax_Syntax.injective_type_params = - false - }); - FStar_Syntax_Syntax.sigrng = uu___2; - FStar_Syntax_Syntax.sigquals = quals1; - FStar_Syntax_Syntax.sigmeta = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs = d_attrs; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___3; - FStar_Syntax_Syntax.sigopts = - FStar_Pervasives_Native.None - } in - let uu___2 = - FStar_Syntax_DsEnv.push_top_level_rec_binding _env - id in - (match uu___2 with - | (_env1, uu___3) -> - let uu___4 = - FStar_Syntax_DsEnv.push_top_level_rec_binding - _env' id in - (match uu___4 with - | (_env2, uu___5) -> (_env1, _env2, se, tconstr)))) - | uu___1 -> failwith "Unexpected tycon" in - let push_tparams env1 bs = - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun b -> - match uu___1 with - | (env2, tps) -> - let uu___2 = - FStar_Syntax_DsEnv.push_bv env2 - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.ppname in - (match uu___2 with - | (env3, y) -> - let uu___3 = - let uu___4 = - mk_binder_with_attrs y - b.FStar_Syntax_Syntax.binder_qual - b.FStar_Syntax_Syntax.binder_attrs in - uu___4 :: tps in - (env3, uu___3))) (env1, []) bs in - match uu___ with - | (env2, bs1) -> (env2, (FStar_Compiler_List.rev bs1)) in - match tcs1 with - | (FStar_Parser_AST.TyconAbstract (id, bs, kopt), d_attrs)::[] -> - let kopt1 = - match kopt with - | FStar_Pervasives_Native.None -> - let uu___ = - let uu___1 = FStar_Ident.range_of_id id in - tm_type_z uu___1 in - FStar_Pervasives_Native.Some uu___ - | uu___ -> kopt in - let tc = FStar_Parser_AST.TyconAbstract (id, bs, kopt1) in - let uu___ = desugar_abstract_tc quals env [] d_attrs tc in - (match uu___ with - | (uu___1, uu___2, se, uu___3) -> - let se1 = - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = l; - FStar_Syntax_Syntax.us = uu___4; - FStar_Syntax_Syntax.params = typars; - FStar_Syntax_Syntax.num_uniform_params = uu___5; - FStar_Syntax_Syntax.t = k; - FStar_Syntax_Syntax.mutuals = []; - FStar_Syntax_Syntax.ds = []; - FStar_Syntax_Syntax.injective_type_params = - uu___6;_} - -> - let quals1 = se.FStar_Syntax_Syntax.sigquals in - let quals2 = - if - FStar_Compiler_List.contains - FStar_Syntax_Syntax.Assumption quals1 - then quals1 - else - ((let uu___9 = - let uu___10 = FStar_Options.ml_ish () in - Prims.op_Negation uu___10 in - if uu___9 - then - let uu___10 = - let uu___11 = - FStar_Class_Show.show - FStar_Ident.showable_lident l in - FStar_Compiler_Util.format1 - "Adding an implicit 'assume new' qualifier on %s" - uu___11 in - FStar_Errors.log_issue - FStar_Syntax_Syntax.has_range_sigelt se - FStar_Errors_Codes.Warning_AddImplicitAssumeNewQualifier - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___10) - else ()); - FStar_Syntax_Syntax.Assumption - :: - FStar_Syntax_Syntax.New - :: - quals1) in - let t = - match typars with - | [] -> k - | uu___7 -> - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Syntax_Syntax.mk_Total k in - { - FStar_Syntax_Syntax.bs1 = typars; - FStar_Syntax_Syntax.comp = uu___10 - } in - FStar_Syntax_Syntax.Tm_arrow uu___9 in - FStar_Syntax_Syntax.mk uu___8 - se.FStar_Syntax_Syntax.sigrng in - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_declare_typ - { - FStar_Syntax_Syntax.lid2 = l; - FStar_Syntax_Syntax.us2 = []; - FStar_Syntax_Syntax.t2 = t - }); - FStar_Syntax_Syntax.sigrng = - (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = quals2; - FStar_Syntax_Syntax.sigmeta = - (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se.FStar_Syntax_Syntax.sigopts) - } - | uu___4 -> failwith "Impossible" in - let env1 = FStar_Syntax_DsEnv.push_sigelt env se1 in - (env1, [se1])) - | (FStar_Parser_AST.TyconAbbrev (id, binders, kopt, t), _d_attrs)::[] - -> - let uu___ = typars_of_binders env binders in - (match uu___ with - | (env', typars) -> - let kopt1 = - match kopt with - | FStar_Pervasives_Native.None -> - let uu___1 = - FStar_Compiler_Util.for_some - (fun uu___2 -> - match uu___2 with - | FStar_Syntax_Syntax.Effect -> true - | uu___3 -> false) quals in - if uu___1 - then - FStar_Pervasives_Native.Some - FStar_Syntax_Syntax.teff - else FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some k -> - let uu___1 = desugar_term env' k in - FStar_Pervasives_Native.Some uu___1 in - let t0 = t in - let quals1 = - let uu___1 = - FStar_Compiler_Util.for_some - (fun uu___2 -> - match uu___2 with - | FStar_Syntax_Syntax.Logic -> true - | uu___3 -> false) quals in - if uu___1 - then quals - else - if - t0.FStar_Parser_AST.level = - FStar_Parser_AST.Formula - then FStar_Syntax_Syntax.Logic :: quals - else quals in - let qlid = FStar_Syntax_DsEnv.qualify env id in - let se = - if - FStar_Compiler_List.contains - FStar_Syntax_Syntax.Effect quals1 - then - let uu___1 = - let uu___2 = - let uu___3 = unparen t in - uu___3.FStar_Parser_AST.tm in - match uu___2 with - | FStar_Parser_AST.Construct (head, args) -> - let uu___3 = - match FStar_Compiler_List.rev args with - | (last_arg, uu___4)::args_rev -> - let uu___5 = - let uu___6 = unparen last_arg in - uu___6.FStar_Parser_AST.tm in - (match uu___5 with - | FStar_Parser_AST.Attributes ts -> - (ts, - (FStar_Compiler_List.rev args_rev)) - | uu___6 -> ([], args)) - | uu___4 -> ([], args) in - (match uu___3 with - | (cattributes, args1) -> - let uu___4 = - FStar_Parser_AST.mk_term - (FStar_Parser_AST.Construct - (head, args1)) - t.FStar_Parser_AST.range - t.FStar_Parser_AST.level in - let uu___5 = - desugar_attributes env cattributes in - (uu___4, uu___5)) - | uu___3 -> (t, []) in - match uu___1 with - | (t1, cattributes) -> - let c = - desugar_comp t1.FStar_Parser_AST.range false - env' t1 in - let typars1 = - FStar_Syntax_Subst.close_binders typars in - let c1 = FStar_Syntax_Subst.close_comp typars1 c in - let quals2 = - FStar_Compiler_List.filter - (fun uu___2 -> - match uu___2 with - | FStar_Syntax_Syntax.Effect -> false - | uu___3 -> true) quals1 in - let uu___2 = FStar_Ident.range_of_id id in - let uu___3 = - FStar_Syntax_DsEnv.opens_and_abbrevs env in - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_effect_abbrev - { - FStar_Syntax_Syntax.lid4 = qlid; - FStar_Syntax_Syntax.us4 = []; - FStar_Syntax_Syntax.bs2 = typars1; - FStar_Syntax_Syntax.comp1 = c1; - FStar_Syntax_Syntax.cflags = - (FStar_Compiler_List.op_At - cattributes - (FStar_Syntax_Util.comp_flags c1)) - }); - FStar_Syntax_Syntax.sigrng = uu___2; - FStar_Syntax_Syntax.sigquals = quals2; - FStar_Syntax_Syntax.sigmeta = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs = []; - FStar_Syntax_Syntax.sigopens_and_abbrevs = - uu___3; - FStar_Syntax_Syntax.sigopts = - FStar_Pervasives_Native.None - } - else - (let t1 = desugar_typ env' t in - let uu___2 = FStar_Ident.range_of_id id in - mk_typ_abbrev env d qlid [] typars kopt1 t1 - [qlid] quals1 uu___2) in - let env1 = FStar_Syntax_DsEnv.push_sigelt env se in - (env1, [se])) - | (FStar_Parser_AST.TyconRecord payload, d_attrs)::[] -> - let trec = FStar_Parser_AST.TyconRecord payload in - let uu___ = tycon_record_as_variant trec in - (match uu___ with - | (t, fs) -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Syntax_DsEnv.current_module env in - FStar_Ident.ids_of_lid uu___5 in - (uu___4, fs) in - FStar_Syntax_Syntax.RecordType uu___3 in - uu___2 :: quals in - desugar_tycon env d d_attrs uu___1 [t]) - | uu___::uu___1 -> - let env0 = env in - let mutuals = - FStar_Compiler_List.map - (fun uu___2 -> - match uu___2 with - | (x, uu___3) -> - FStar_Syntax_DsEnv.qualify env (tycon_id x)) tcs1 in - let rec collect_tcs quals1 et uu___2 = - match uu___2 with - | (tc, d_attrs) -> - let uu___3 = et in - (match uu___3 with - | (env1, tcs2) -> - (match tc with - | FStar_Parser_AST.TyconRecord uu___4 -> - let trec = tc in - let uu___5 = tycon_record_as_variant trec in - (match uu___5 with - | (t, fs) -> - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Syntax_DsEnv.current_module - env1 in - FStar_Ident.ids_of_lid uu___10 in - (uu___9, fs) in - FStar_Syntax_Syntax.RecordType - uu___8 in - uu___7 :: quals1 in - collect_tcs uu___6 (env1, tcs2) - (t, d_attrs)) - | FStar_Parser_AST.TyconVariant - (id, binders, kopt, constructors) -> - let uu___4 = - desugar_abstract_tc quals1 env1 mutuals - d_attrs - (FStar_Parser_AST.TyconAbstract - (id, binders, kopt)) in - (match uu___4 with - | (env2, uu___5, se, tconstr) -> - (env2, - (((FStar_Pervasives.Inl - (se, constructors, tconstr, - quals1)), d_attrs) :: tcs2))) - | FStar_Parser_AST.TyconAbbrev - (id, binders, kopt, t) -> - let uu___4 = - desugar_abstract_tc quals1 env1 mutuals - d_attrs - (FStar_Parser_AST.TyconAbstract - (id, binders, kopt)) in - (match uu___4 with - | (env2, uu___5, se, tconstr) -> - (env2, - (((FStar_Pervasives.Inr - (se, binders, t, quals1)), - d_attrs) :: tcs2))) - | uu___4 -> - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range rng - FStar_Errors_Codes.Fatal_NonInductiveInMutuallyDefinedType - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Mutually defined type contains a non-inductive element"))) in - let uu___2 = - FStar_Compiler_List.fold_left (collect_tcs quals) (env, []) - tcs1 in - (match uu___2 with - | (env1, tcs2) -> - let tcs3 = FStar_Compiler_List.rev tcs2 in - let tps_sigelts = - FStar_Compiler_List.collect - (fun uu___3 -> - match uu___3 with - | (tc, d_attrs) -> - (match tc with - | FStar_Pervasives.Inr - ({ - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = id; - FStar_Syntax_Syntax.us = uvs; - FStar_Syntax_Syntax.params = - tpars; - FStar_Syntax_Syntax.num_uniform_params - = uu___4; - FStar_Syntax_Syntax.t = k; - FStar_Syntax_Syntax.mutuals = - uu___5; - FStar_Syntax_Syntax.ds = uu___6; - FStar_Syntax_Syntax.injective_type_params - = uu___7;_}; - FStar_Syntax_Syntax.sigrng = uu___8; - FStar_Syntax_Syntax.sigquals = uu___9; - FStar_Syntax_Syntax.sigmeta = uu___10; - FStar_Syntax_Syntax.sigattrs = - uu___11; - FStar_Syntax_Syntax.sigopens_and_abbrevs - = uu___12; - FStar_Syntax_Syntax.sigopts = uu___13;_}, - binders, t, quals1) - -> - let t1 = - let uu___14 = - typars_of_binders env1 binders in - match uu___14 with - | (env2, tpars1) -> - let uu___15 = - push_tparams env2 tpars1 in - (match uu___15 with - | (env_tps, tpars2) -> - let t2 = - desugar_typ env_tps t in - let tpars3 = - FStar_Syntax_Subst.close_binders - tpars2 in - FStar_Syntax_Subst.close - tpars3 t2) in - let uu___14 = - let uu___15 = - let uu___16 = - FStar_Ident.range_of_lid id in - mk_typ_abbrev env1 d id uvs tpars - (FStar_Pervasives_Native.Some k) - t1 [id] quals1 uu___16 in - ([], uu___15) in - [uu___14] - | FStar_Pervasives.Inl - ({ - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = tname; - FStar_Syntax_Syntax.us = univs; - FStar_Syntax_Syntax.params = - tpars; - FStar_Syntax_Syntax.num_uniform_params - = num_uniform; - FStar_Syntax_Syntax.t = k; - FStar_Syntax_Syntax.mutuals = - mutuals1; - FStar_Syntax_Syntax.ds = uu___4; - FStar_Syntax_Syntax.injective_type_params - = injective_type_params;_}; - FStar_Syntax_Syntax.sigrng = uu___5; - FStar_Syntax_Syntax.sigquals = - tname_quals; - FStar_Syntax_Syntax.sigmeta = uu___6; - FStar_Syntax_Syntax.sigattrs = uu___7; - FStar_Syntax_Syntax.sigopens_and_abbrevs - = uu___8; - FStar_Syntax_Syntax.sigopts = uu___9;_}, - constrs, tconstr, quals1) - -> - let mk_tot t = - let tot1 = - FStar_Parser_AST.mk_term - (FStar_Parser_AST.Name - FStar_Parser_Const.effect_Tot_lid) - t.FStar_Parser_AST.range - t.FStar_Parser_AST.level in - FStar_Parser_AST.mk_term - (FStar_Parser_AST.App - (tot1, t, - FStar_Parser_AST.Nothing)) - t.FStar_Parser_AST.range - t.FStar_Parser_AST.level in - let tycon = (tname, tpars, k) in - let uu___10 = push_tparams env1 tpars in - (match uu___10 with - | (env_tps, tps) -> - let data_tpars = - FStar_Compiler_List.map - (fun tp -> - { - FStar_Syntax_Syntax.binder_bv - = - (tp.FStar_Syntax_Syntax.binder_bv); - FStar_Syntax_Syntax.binder_qual - = - (FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Implicit - true)); - FStar_Syntax_Syntax.binder_positivity - = - (tp.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs - = - (tp.FStar_Syntax_Syntax.binder_attrs) - }) tps in - let tot_tconstr = mk_tot tconstr in - let val_attrs = - let uu___11 = - FStar_Syntax_DsEnv.lookup_letbinding_quals_and_attrs - env0 tname in - FStar_Pervasives_Native.snd - uu___11 in - let uu___11 = - let uu___12 = - FStar_Compiler_List.map - (fun uu___13 -> - match uu___13 with - | (id, payload, - cons_attrs) -> - let t = - match payload with - | FStar_Pervasives_Native.Some - (FStar_Parser_AST.VpArbitrary - t1) -> t1 - | FStar_Pervasives_Native.Some - (FStar_Parser_AST.VpOfNotation - t1) -> - let uu___14 = - let uu___15 = - let uu___16 - = - let uu___17 - = - FStar_Parser_AST.mk_binder - (FStar_Parser_AST.NoName - t1) - t1.FStar_Parser_AST.range - t1.FStar_Parser_AST.level - FStar_Pervasives_Native.None in - [uu___17] in - (uu___16, - tot_tconstr) in - FStar_Parser_AST.Product - uu___15 in - FStar_Parser_AST.mk_term - uu___14 - t1.FStar_Parser_AST.range - t1.FStar_Parser_AST.level - | FStar_Pervasives_Native.Some - (FStar_Parser_AST.VpRecord - uu___14) -> - failwith - "Impossible: [VpRecord _] should have disappeared after [desugar_tycon_variant_record]" - | FStar_Pervasives_Native.None - -> - let uu___14 = - FStar_Ident.range_of_id - id in - { - FStar_Parser_AST.tm - = - (tconstr.FStar_Parser_AST.tm); - FStar_Parser_AST.range - = uu___14; - FStar_Parser_AST.level - = - (tconstr.FStar_Parser_AST.level) - } in - let t1 = - let uu___14 = - close env_tps t in - desugar_term env_tps - uu___14 in - let name = - FStar_Syntax_DsEnv.qualify - env1 id in - let quals2 = - FStar_Compiler_List.collect - (fun uu___14 -> - match uu___14 - with - | FStar_Syntax_Syntax.RecordType - fns -> - [FStar_Syntax_Syntax.RecordConstructor - fns] - | uu___15 -> []) - tname_quals in - let ntps = - FStar_Compiler_List.length - data_tpars in - let uu___14 = - let uu___15 = - let uu___16 = - let uu___17 = - let uu___18 = - let uu___19 - = - let uu___20 - = - FStar_Syntax_Util.name_function_binders - t1 in - FStar_Syntax_Syntax.mk_Total - uu___20 in - FStar_Syntax_Util.arrow - data_tpars - uu___19 in - { - FStar_Syntax_Syntax.lid1 - = name; - FStar_Syntax_Syntax.us1 - = univs; - FStar_Syntax_Syntax.t1 - = uu___18; - FStar_Syntax_Syntax.ty_lid - = tname; - FStar_Syntax_Syntax.num_ty_params - = ntps; - FStar_Syntax_Syntax.mutuals1 - = mutuals1; - FStar_Syntax_Syntax.injective_type_params1 - = - injective_type_params - } in - FStar_Syntax_Syntax.Sig_datacon - uu___17 in - let uu___17 = - FStar_Ident.range_of_lid - name in - let uu___18 = - let uu___19 = - let uu___20 = - let uu___21 - = - FStar_Compiler_List.map - (desugar_term - env1) - cons_attrs in - FStar_Compiler_List.op_At - d_attrs - uu___21 in - FStar_Compiler_List.op_At - val_attrs - uu___20 in - FStar_Syntax_Util.deduplicate_terms - uu___19 in - let uu___19 = - FStar_Syntax_DsEnv.opens_and_abbrevs - env1 in - { - FStar_Syntax_Syntax.sigel - = uu___16; - FStar_Syntax_Syntax.sigrng - = uu___17; - FStar_Syntax_Syntax.sigquals - = quals2; - FStar_Syntax_Syntax.sigmeta - = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs - = uu___18; - FStar_Syntax_Syntax.sigopens_and_abbrevs - = uu___19; - FStar_Syntax_Syntax.sigopts - = - FStar_Pervasives_Native.None - } in - (tps, uu___15) in - (name, uu___14)) - constrs in - FStar_Compiler_List.split uu___12 in - (match uu___11 with - | (constrNames, constrs1) -> - ((let uu___13 = - FStar_Compiler_Effect.op_Bang - dbg_attrs in - if uu___13 - then - let uu___14 = - FStar_Class_Show.show - FStar_Ident.showable_lident - tname in - let uu___15 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_term) - val_attrs in - let uu___16 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_term) - d_attrs in - FStar_Compiler_Util.print3 - "Adding attributes to type %s: val_attrs=[@@%s] attrs=[@@%s]\n" - uu___14 uu___15 uu___16 - else ()); - (let uu___13 = - let uu___14 = - let uu___15 = - FStar_Ident.range_of_lid - tname in - let uu___16 = - FStar_Syntax_Util.deduplicate_terms - (FStar_Compiler_List.op_At - val_attrs d_attrs) in - let uu___17 = - FStar_Syntax_DsEnv.opens_and_abbrevs - env1 in - { - FStar_Syntax_Syntax.sigel - = - (FStar_Syntax_Syntax.Sig_inductive_typ - { - FStar_Syntax_Syntax.lid - = tname; - FStar_Syntax_Syntax.us - = univs; - FStar_Syntax_Syntax.params - = tpars; - FStar_Syntax_Syntax.num_uniform_params - = num_uniform; - FStar_Syntax_Syntax.t - = k; - FStar_Syntax_Syntax.mutuals - = mutuals1; - FStar_Syntax_Syntax.ds - = constrNames; - FStar_Syntax_Syntax.injective_type_params - = - injective_type_params - }); - FStar_Syntax_Syntax.sigrng - = uu___15; - FStar_Syntax_Syntax.sigquals - = tname_quals; - FStar_Syntax_Syntax.sigmeta - = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs - = uu___16; - FStar_Syntax_Syntax.sigopens_and_abbrevs - = uu___17; - FStar_Syntax_Syntax.sigopts - = - FStar_Pervasives_Native.None - } in - ([], uu___14) in - uu___13 :: constrs1)))) - | uu___4 -> failwith "impossible")) tcs3 in - let sigelts = - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with | (uu___4, se) -> se) - tps_sigelts in - let uu___3 = - let uu___4 = - FStar_Compiler_List.collect - FStar_Syntax_Util.lids_of_sigelt sigelts in - FStar_Syntax_MutRecTy.disentangle_abbrevs_from_bundle - sigelts quals uu___4 rng in - (match uu___3 with - | (bundle, abbrevs) -> - ((let uu___5 = - FStar_Compiler_Effect.op_Bang dbg_attrs in - if uu___5 - then - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_sigelt bundle in - FStar_Compiler_Util.print1 - "After disentangling: %s\n" uu___6 - else ()); - (let env2 = - FStar_Syntax_DsEnv.push_sigelt env0 bundle in - let env3 = - FStar_Compiler_List.fold_left - FStar_Syntax_DsEnv.push_sigelt env2 abbrevs in - let data_ops = - FStar_Compiler_List.collect - (fun uu___5 -> - match uu___5 with - | (tps, se) -> - mk_data_projector_names quals env3 se) - tps_sigelts in - let discs = - FStar_Compiler_List.collect - (fun se -> - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = tname; - FStar_Syntax_Syntax.us = uu___5; - FStar_Syntax_Syntax.params = tps; - FStar_Syntax_Syntax.num_uniform_params - = uu___6; - FStar_Syntax_Syntax.t = k; - FStar_Syntax_Syntax.mutuals = uu___7; - FStar_Syntax_Syntax.ds = constrs; - FStar_Syntax_Syntax.injective_type_params - = uu___8;_} - -> - let quals1 = - se.FStar_Syntax_Syntax.sigquals in - let uu___9 = - FStar_Compiler_List.filter - (fun data_lid -> - let data_quals = - let data_se = - let uu___10 = - FStar_Compiler_List.find - (fun se1 -> - match se1.FStar_Syntax_Syntax.sigel - with - | FStar_Syntax_Syntax.Sig_datacon - { - FStar_Syntax_Syntax.lid1 - = name; - FStar_Syntax_Syntax.us1 - = uu___11; - FStar_Syntax_Syntax.t1 - = uu___12; - FStar_Syntax_Syntax.ty_lid - = uu___13; - FStar_Syntax_Syntax.num_ty_params - = uu___14; - FStar_Syntax_Syntax.mutuals1 - = uu___15; - FStar_Syntax_Syntax.injective_type_params1 - = uu___16;_} - -> - FStar_Ident.lid_equals - name data_lid - | uu___11 -> false) - sigelts in - FStar_Compiler_Util.must - uu___10 in - data_se.FStar_Syntax_Syntax.sigquals in - let uu___10 = - FStar_Compiler_List.existsb - (fun uu___11 -> - match uu___11 with - | FStar_Syntax_Syntax.RecordConstructor - uu___12 -> true - | uu___12 -> false) - data_quals in - Prims.op_Negation uu___10) - constrs in - mk_data_discriminators quals1 env3 - uu___9 - se.FStar_Syntax_Syntax.sigattrs - | uu___5 -> []) sigelts in - let ops = - FStar_Compiler_List.op_At discs data_ops in - let env4 = - FStar_Compiler_List.fold_left - FStar_Syntax_DsEnv.push_sigelt env3 ops in - (env4, - (FStar_Compiler_List.op_At [bundle] - (FStar_Compiler_List.op_At abbrevs ops))))))) - | [] -> failwith "impossible" -let (desugar_binders : - FStar_Syntax_DsEnv.env -> - FStar_Parser_AST.binder Prims.list -> - (FStar_Syntax_DsEnv.env * FStar_Syntax_Syntax.binder Prims.list)) - = - fun env -> - fun binders -> - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun b -> - match uu___1 with - | (env1, binders1) -> - let uu___2 = desugar_binder env1 b in - (match uu___2 with - | (FStar_Pervasives_Native.Some a, k, attrs) -> - let uu___3 = - as_binder env1 b.FStar_Parser_AST.aqual - ((FStar_Pervasives_Native.Some a), k, attrs) in - (match uu___3 with - | (binder, env2) -> (env2, (binder :: binders1))) - | uu___3 -> - FStar_Errors.raise_error - FStar_Parser_AST.hasRange_binder b - FStar_Errors_Codes.Fatal_MissingNameInBinder () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic "Missing name in binder"))) (env, []) - binders in - match uu___ with - | (env1, binders1) -> (env1, (FStar_Compiler_List.rev binders1)) -let (push_reflect_effect : - FStar_Syntax_DsEnv.env -> - FStar_Syntax_Syntax.qualifier Prims.list -> - FStar_Ident.lid -> - FStar_Compiler_Range_Type.range -> FStar_Syntax_DsEnv.env) - = - fun env -> - fun quals -> - fun effect_name -> - fun range -> - let uu___ = - FStar_Compiler_Util.for_some - (fun uu___1 -> - match uu___1 with - | FStar_Syntax_Syntax.Reflectable uu___2 -> true - | uu___2 -> false) quals in - if uu___ - then - let monad_env = - let uu___1 = FStar_Ident.ident_of_lid effect_name in - FStar_Syntax_DsEnv.enter_monad_scope env uu___1 in - let reflect_lid = - let uu___1 = FStar_Ident.id_of_text "reflect" in - FStar_Syntax_DsEnv.qualify monad_env uu___1 in - let quals1 = - [FStar_Syntax_Syntax.Assumption; - FStar_Syntax_Syntax.Reflectable effect_name] in - let refl_decl = - let uu___1 = FStar_Syntax_DsEnv.opens_and_abbrevs env in - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_declare_typ - { - FStar_Syntax_Syntax.lid2 = reflect_lid; - FStar_Syntax_Syntax.us2 = []; - FStar_Syntax_Syntax.t2 = FStar_Syntax_Syntax.tun - }); - FStar_Syntax_Syntax.sigrng = range; - FStar_Syntax_Syntax.sigquals = quals1; - FStar_Syntax_Syntax.sigmeta = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs = []; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___1; - FStar_Syntax_Syntax.sigopts = FStar_Pervasives_Native.None - } in - FStar_Syntax_DsEnv.push_sigelt env refl_decl - else env -let (parse_attr_with_list : - Prims.bool -> - FStar_Syntax_Syntax.term -> - FStar_Ident.lident -> - (Prims.int Prims.list FStar_Pervasives_Native.option * Prims.bool)) - = - fun warn -> - fun at -> - fun head -> - let warn1 uu___ = - if warn - then - let uu___1 = - let uu___2 = FStar_Ident.string_of_lid head in - FStar_Compiler_Util.format1 - "Found ill-applied '%s', argument should be a non-empty list of integer literals" - uu___2 in - FStar_Errors.log_issue (FStar_Syntax_Syntax.has_range_syntax ()) - at FStar_Errors_Codes.Warning_UnappliedFail () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) - else () in - let uu___ = FStar_Syntax_Util.head_and_args at in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress hd in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv head -> - (match args with - | [] -> ((FStar_Pervasives_Native.Some []), true) - | (a1, uu___2)::[] -> - let uu___3 = - FStar_Syntax_Embeddings_Base.unembed - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_int) a1 - FStar_Syntax_Embeddings_Base.id_norm_cb in - (match uu___3 with - | FStar_Pervasives_Native.Some es -> - let uu___4 = - let uu___5 = - FStar_Compiler_List.map FStar_BigInt.to_int_fs - es in - FStar_Pervasives_Native.Some uu___5 in - (uu___4, true) - | uu___4 -> - (warn1 (); (FStar_Pervasives_Native.None, true))) - | uu___2 -> - (warn1 (); (FStar_Pervasives_Native.None, true))) - | uu___2 -> (FStar_Pervasives_Native.None, false)) -let (get_fail_attr1 : - Prims.bool -> - FStar_Syntax_Syntax.term -> - (Prims.int Prims.list * Prims.bool) FStar_Pervasives_Native.option) - = - fun warn -> - fun at -> - let rebind res b = - match res with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some l -> - FStar_Pervasives_Native.Some (l, b) in - let uu___ = parse_attr_with_list warn at FStar_Parser_Const.fail_attr in - match uu___ with - | (res, matched) -> - if matched - then rebind res false - else - (let uu___2 = - parse_attr_with_list warn at FStar_Parser_Const.fail_lax_attr in - match uu___2 with | (res1, uu___3) -> rebind res1 true) -let (get_fail_attr : - Prims.bool -> - FStar_Syntax_Syntax.term Prims.list -> - (Prims.int Prims.list * Prims.bool) FStar_Pervasives_Native.option) - = - fun warn -> - fun ats -> - let comb f1 f2 = - match (f1, f2) with - | (FStar_Pervasives_Native.Some (e1, l1), - FStar_Pervasives_Native.Some (e2, l2)) -> - FStar_Pervasives_Native.Some - ((FStar_Compiler_List.op_At e1 e2), (l1 || l2)) - | (FStar_Pervasives_Native.Some (e, l), FStar_Pervasives_Native.None) - -> FStar_Pervasives_Native.Some (e, l) - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.Some (e, l)) - -> FStar_Pervasives_Native.Some (e, l) - | uu___ -> FStar_Pervasives_Native.None in - FStar_Compiler_List.fold_right - (fun at -> - fun acc -> let uu___ = get_fail_attr1 warn at in comb uu___ acc) - ats FStar_Pervasives_Native.None -let (lookup_effect_lid : - FStar_Syntax_DsEnv.env -> - FStar_Ident.lident -> - FStar_Compiler_Range_Type.range -> FStar_Syntax_Syntax.eff_decl) - = - fun env -> - fun l -> - fun r -> - let uu___ = FStar_Syntax_DsEnv.try_lookup_effect_defn env l in - match uu___ with - | FStar_Pervasives_Native.None -> - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Ident.showable_lident l in - Prims.strcat uu___3 " not found" in - Prims.strcat "Effect name " uu___2 in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_EffectNotFound () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) - | FStar_Pervasives_Native.Some l1 -> l1 -let rec (desugar_effect : - FStar_Syntax_DsEnv.env -> - FStar_Parser_AST.decl -> - FStar_Syntax_Syntax.term Prims.list -> - FStar_Parser_AST.qualifiers -> - Prims.bool -> - FStar_Ident.ident -> - FStar_Parser_AST.binder Prims.list -> - FStar_Parser_AST.term -> - FStar_Parser_AST.decl Prims.list -> - (FStar_Syntax_DsEnv.env * FStar_Syntax_Syntax.sigelt - Prims.list)) - = - fun env -> - fun d -> - fun d_attrs -> - fun quals -> - fun is_layered -> - fun eff_name -> - fun eff_binders -> - fun eff_typ -> - fun eff_decls -> - let env0 = env in - let monad_env = - FStar_Syntax_DsEnv.enter_monad_scope env eff_name in - let uu___ = desugar_binders monad_env eff_binders in - match uu___ with - | (env1, binders) -> - let eff_t = desugar_term env1 eff_typ in - let num_indices = - let uu___1 = - let uu___2 = - FStar_Syntax_Util.arrow_formals eff_t in - FStar_Pervasives_Native.fst uu___2 in - FStar_Compiler_List.length uu___1 in - let for_free = - (num_indices = Prims.int_one) && - (Prims.op_Negation is_layered) in - (if for_free - then - (let uu___2 = - let uu___3 = FStar_Ident.string_of_id eff_name in - FStar_Compiler_Util.format1 - "DM4Free feature is deprecated and will be removed soon, use layered effects to define %s" - uu___3 in - FStar_Errors.log_issue - FStar_Parser_AST.hasRange_decl d - FStar_Errors_Codes.Warning_DeprecatedGeneric () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)) - else (); - (let mandatory_members = - let rr_members = ["repr"; "return"; "bind"] in - if for_free - then rr_members - else - if is_layered - then - FStar_Compiler_List.op_At rr_members - ["subcomp"; "if_then_else"; "close"] - else - FStar_Compiler_List.op_At rr_members - ["return_wp"; - "bind_wp"; - "if_then_else"; - "ite_wp"; - "stronger"; - "close_wp"; - "trivial"] in - let name_of_eff_decl decl = - match decl.FStar_Parser_AST.d with - | FStar_Parser_AST.Tycon - (uu___2, uu___3, - (FStar_Parser_AST.TyconAbbrev - (name, uu___4, uu___5, uu___6))::[]) - -> FStar_Ident.string_of_id name - | uu___2 -> - failwith - "Malformed effect member declaration." in - let uu___2 = - FStar_Compiler_List.partition - (fun decl -> - let uu___3 = name_of_eff_decl decl in - FStar_Compiler_List.mem uu___3 - mandatory_members) eff_decls in - match uu___2 with - | (mandatory_members_decls, actions) -> - let uu___3 = - FStar_Compiler_List.fold_left - (fun uu___4 -> - fun decl -> - match uu___4 with - | (env2, out) -> - let uu___5 = - desugar_decl env2 decl in - (match uu___5 with - | (env3, ses) -> - let uu___6 = - let uu___7 = - FStar_Compiler_List.hd - ses in - uu___7 :: out in - (env3, uu___6))) (env1, []) - mandatory_members_decls in - (match uu___3 with - | (env2, decls) -> - let binders1 = - FStar_Syntax_Subst.close_binders binders in - let actions1 = - FStar_Compiler_List.map - (fun d1 -> - match d1.FStar_Parser_AST.d with - | FStar_Parser_AST.Tycon - (uu___4, uu___5, - (FStar_Parser_AST.TyconAbbrev - (name, action_params, uu___6, - { - FStar_Parser_AST.tm = - FStar_Parser_AST.Construct - (uu___7, - (def, uu___8)::(cps_type, - uu___9)::[]); - FStar_Parser_AST.range = - uu___10; - FStar_Parser_AST.level = - uu___11;_}))::[]) - when Prims.op_Negation for_free - -> - let uu___12 = - desugar_binders env2 - action_params in - (match uu___12 with - | (env3, action_params1) -> - let action_params2 = - FStar_Syntax_Subst.close_binders - action_params1 in - let uu___13 = - FStar_Syntax_DsEnv.qualify - env3 name in - let uu___14 = - let uu___15 = - desugar_term env3 def in - FStar_Syntax_Subst.close - (FStar_Compiler_List.op_At - binders1 - action_params2) - uu___15 in - let uu___15 = - let uu___16 = - desugar_typ env3 - cps_type in - FStar_Syntax_Subst.close - (FStar_Compiler_List.op_At - binders1 - action_params2) - uu___16 in - { - FStar_Syntax_Syntax.action_name - = uu___13; - FStar_Syntax_Syntax.action_unqualified_name - = name; - FStar_Syntax_Syntax.action_univs - = []; - FStar_Syntax_Syntax.action_params - = action_params2; - FStar_Syntax_Syntax.action_defn - = uu___14; - FStar_Syntax_Syntax.action_typ - = uu___15 - }) - | FStar_Parser_AST.Tycon - (uu___4, uu___5, - (FStar_Parser_AST.TyconAbbrev - (name, action_params, uu___6, - defn))::[]) - when for_free || is_layered -> - let uu___7 = - desugar_binders env2 - action_params in - (match uu___7 with - | (env3, action_params1) -> - let action_params2 = - FStar_Syntax_Subst.close_binders - action_params1 in - let uu___8 = - FStar_Syntax_DsEnv.qualify - env3 name in - let uu___9 = - let uu___10 = - desugar_term env3 defn in - FStar_Syntax_Subst.close - (FStar_Compiler_List.op_At - binders1 - action_params2) - uu___10 in - { - FStar_Syntax_Syntax.action_name - = uu___8; - FStar_Syntax_Syntax.action_unqualified_name - = name; - FStar_Syntax_Syntax.action_univs - = []; - FStar_Syntax_Syntax.action_params - = action_params2; - FStar_Syntax_Syntax.action_defn - = uu___9; - FStar_Syntax_Syntax.action_typ - = - FStar_Syntax_Syntax.tun - }) - | uu___4 -> - FStar_Errors.raise_error - FStar_Parser_AST.hasRange_decl - d1 - FStar_Errors_Codes.Fatal_MalformedActionDeclaration - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Malformed action declaration; if this is an \"effect for free\", just provide the direct-style declaration. If this is not an \"effect for free\", please provide a pair of the definition and its cps-type with arrows inserted in the right place (see examples).")) - actions in - let eff_t1 = - FStar_Syntax_Subst.close binders1 eff_t in - let lookup s = - let l = - let uu___4 = - FStar_Ident.mk_ident - (s, (d.FStar_Parser_AST.drange)) in - FStar_Syntax_DsEnv.qualify env2 uu___4 in - let uu___4 = - let uu___5 = - FStar_Syntax_DsEnv.fail_or env2 - (FStar_Syntax_DsEnv.try_lookup_definition - env2) l in - FStar_Syntax_Subst.close binders1 - uu___5 in - ([], uu___4) in - let mname = - FStar_Syntax_DsEnv.qualify env0 eff_name in - let qualifiers = - FStar_Compiler_List.map - (trans_qual d.FStar_Parser_AST.drange - (FStar_Pervasives_Native.Some mname)) - quals in - let dummy_tscheme = - ([], FStar_Syntax_Syntax.tun) in - let uu___4 = - if for_free - then - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = lookup "repr" in - FStar_Pervasives_Native.Some - uu___8 in - let uu___8 = - let uu___9 = lookup "return" in - FStar_Pervasives_Native.Some - uu___9 in - let uu___9 = - let uu___10 = lookup "bind" in - FStar_Pervasives_Native.Some - uu___10 in - { - FStar_Syntax_Syntax.ret_wp = - dummy_tscheme; - FStar_Syntax_Syntax.bind_wp = - dummy_tscheme; - FStar_Syntax_Syntax.stronger = - dummy_tscheme; - FStar_Syntax_Syntax.if_then_else - = dummy_tscheme; - FStar_Syntax_Syntax.ite_wp = - dummy_tscheme; - FStar_Syntax_Syntax.close_wp = - dummy_tscheme; - FStar_Syntax_Syntax.trivial = - dummy_tscheme; - FStar_Syntax_Syntax.repr = - uu___7; - FStar_Syntax_Syntax.return_repr - = uu___8; - FStar_Syntax_Syntax.bind_repr = - uu___9 - } in - FStar_Syntax_Syntax.DM4F_eff uu___6 in - ((FStar_Syntax_Syntax.WP_eff_sig - ([], eff_t1)), uu___5) - else - if is_layered - then - (let has_subcomp = - FStar_Compiler_List.existsb - (fun decl -> - let uu___6 = - name_of_eff_decl decl in - uu___6 = "subcomp") - eff_decls in - let has_if_then_else = - FStar_Compiler_List.existsb - (fun decl -> - let uu___6 = - name_of_eff_decl decl in - uu___6 = "if_then_else") - eff_decls in - let has_close = - FStar_Compiler_List.existsb - (fun decl -> - let uu___6 = - name_of_eff_decl decl in - uu___6 = "close") eff_decls in - let to_comb uu___6 = - match uu___6 with - | (us, t) -> - ((us, t), dummy_tscheme, - FStar_Pervasives_Native.None) in - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Syntax_Subst.compress - eff_t1 in - uu___8.FStar_Syntax_Syntax.n in - match uu___7 with - | FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 = - bs; - FStar_Syntax_Syntax.comp = - c;_} - -> - let uu___8 = bs in - (match uu___8 with - | a::bs1 -> - let uu___9 = - FStar_Compiler_List.fold_left - (fun uu___10 -> - fun b -> - match uu___10 - with - | (n, - allow_param, - bs2) -> - let b_attrs - = - b.FStar_Syntax_Syntax.binder_attrs in - let is_param - = - FStar_Syntax_Util.has_attribute - b_attrs - FStar_Parser_Const.effect_parameter_attr in - (if - is_param - && - (Prims.op_Negation - allow_param) - then - FStar_Errors.raise_error - FStar_Parser_AST.hasRange_decl - d - FStar_Errors_Codes.Fatal_UnexpectedEffect - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Effect parameters must all be upfront") - else (); - (let b_attrs1 - = - FStar_Syntax_Util.remove_attr - FStar_Parser_Const.effect_parameter_attr - b_attrs in - ((if - is_param - then - n + - Prims.int_one - else n), - (allow_param - && - is_param), - (FStar_Compiler_List.op_At - bs2 - [ - { - FStar_Syntax_Syntax.binder_bv - = - (b.FStar_Syntax_Syntax.binder_bv); - FStar_Syntax_Syntax.binder_qual - = - (b.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity - = - (b.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs - = - b_attrs1 - }]))))) - (Prims.int_zero, - true, []) bs1 in - (match uu___9 with - | (n, uu___10, bs2) -> - ({ - FStar_Syntax_Syntax.n - = - (FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 - = (a :: - bs2); - FStar_Syntax_Syntax.comp - = c - }); - FStar_Syntax_Syntax.pos - = - (eff_t1.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars - = - (eff_t1.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code - = - (eff_t1.FStar_Syntax_Syntax.hash_code) - }, n))) - | uu___8 -> - failwith - "desugaring indexed effect: effect type not an arrow" in - match uu___6 with - | (eff_t2, num_effect_params) -> - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - lookup "repr" in - (uu___10, dummy_tscheme) in - let uu___10 = - let uu___11 = - lookup "return" in - (uu___11, dummy_tscheme) in - let uu___11 = - let uu___12 = - lookup "bind" in - to_comb uu___12 in - let uu___12 = - if has_subcomp - then - let uu___13 = - lookup "subcomp" in - to_comb uu___13 - else - (dummy_tscheme, - dummy_tscheme, - FStar_Pervasives_Native.None) in - let uu___13 = - if has_if_then_else - then - let uu___14 = - lookup "if_then_else" in - to_comb uu___14 - else - (dummy_tscheme, - dummy_tscheme, - FStar_Pervasives_Native.None) in - let uu___14 = - if has_close - then - let uu___15 = - let uu___16 = - lookup "close" in - (uu___16, - dummy_tscheme) in - FStar_Pervasives_Native.Some - uu___15 - else - FStar_Pervasives_Native.None in - { - FStar_Syntax_Syntax.l_repr - = uu___9; - FStar_Syntax_Syntax.l_return - = uu___10; - FStar_Syntax_Syntax.l_bind - = uu___11; - FStar_Syntax_Syntax.l_subcomp - = uu___12; - FStar_Syntax_Syntax.l_if_then_else - = uu___13; - FStar_Syntax_Syntax.l_close - = uu___14 - } in - FStar_Syntax_Syntax.Layered_eff - uu___8 in - ((FStar_Syntax_Syntax.Layered_eff_sig - (num_effect_params, - ([], eff_t2))), uu___7)) - else - (let rr = - FStar_Compiler_Util.for_some - (fun uu___7 -> - match uu___7 with - | FStar_Syntax_Syntax.Reifiable - -> true - | FStar_Syntax_Syntax.Reflectable - uu___8 -> true - | uu___8 -> false) - qualifiers in - let uu___7 = - let uu___8 = - let uu___9 = lookup "return_wp" in - let uu___10 = lookup "bind_wp" in - let uu___11 = lookup "stronger" in - let uu___12 = - lookup "if_then_else" in - let uu___13 = lookup "ite_wp" in - let uu___14 = lookup "close_wp" in - let uu___15 = lookup "trivial" in - let uu___16 = - if rr - then - let uu___17 = lookup "repr" in - FStar_Pervasives_Native.Some - uu___17 - else - FStar_Pervasives_Native.None in - let uu___17 = - if rr - then - let uu___18 = - lookup "return" in - FStar_Pervasives_Native.Some - uu___18 - else - FStar_Pervasives_Native.None in - let uu___18 = - if rr - then - let uu___19 = lookup "bind" in - FStar_Pervasives_Native.Some - uu___19 - else - FStar_Pervasives_Native.None in - { - FStar_Syntax_Syntax.ret_wp = - uu___9; - FStar_Syntax_Syntax.bind_wp = - uu___10; - FStar_Syntax_Syntax.stronger - = uu___11; - FStar_Syntax_Syntax.if_then_else - = uu___12; - FStar_Syntax_Syntax.ite_wp = - uu___13; - FStar_Syntax_Syntax.close_wp - = uu___14; - FStar_Syntax_Syntax.trivial = - uu___15; - FStar_Syntax_Syntax.repr = - uu___16; - FStar_Syntax_Syntax.return_repr - = uu___17; - FStar_Syntax_Syntax.bind_repr - = uu___18 - } in - FStar_Syntax_Syntax.Primitive_eff - uu___8 in - ((FStar_Syntax_Syntax.WP_eff_sig - ([], eff_t1)), uu___7)) in - (match uu___4 with - | (eff_sig, combinators) -> - let extraction_mode = - if is_layered - then - FStar_Syntax_Syntax.Extract_none - "" - else - if for_free - then - (let uu___6 = - FStar_Compiler_Util.for_some - (fun uu___7 -> - match uu___7 with - | FStar_Syntax_Syntax.Reifiable - -> true - | uu___8 -> false) - qualifiers in - if uu___6 - then - FStar_Syntax_Syntax.Extract_reify - else - FStar_Syntax_Syntax.Extract_primitive) - else - FStar_Syntax_Syntax.Extract_primitive in - let sigel = - FStar_Syntax_Syntax.Sig_new_effect - { - FStar_Syntax_Syntax.mname = - mname; - FStar_Syntax_Syntax.cattributes - = []; - FStar_Syntax_Syntax.univs = []; - FStar_Syntax_Syntax.binders = - binders1; - FStar_Syntax_Syntax.signature = - eff_sig; - FStar_Syntax_Syntax.combinators - = combinators; - FStar_Syntax_Syntax.actions = - actions1; - FStar_Syntax_Syntax.eff_attrs = - d_attrs; - FStar_Syntax_Syntax.extraction_mode - = extraction_mode - } in - let se = - let uu___5 = - FStar_Syntax_DsEnv.opens_and_abbrevs - env2 in - { - FStar_Syntax_Syntax.sigel = sigel; - FStar_Syntax_Syntax.sigrng = - (d.FStar_Parser_AST.drange); - FStar_Syntax_Syntax.sigquals = - qualifiers; - FStar_Syntax_Syntax.sigmeta = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs = - d_attrs; - FStar_Syntax_Syntax.sigopens_and_abbrevs - = uu___5; - FStar_Syntax_Syntax.sigopts = - FStar_Pervasives_Native.None - } in - let env3 = - FStar_Syntax_DsEnv.push_sigelt env0 - se in - let env4 = - FStar_Compiler_List.fold_left - (fun env5 -> - fun a -> - let uu___5 = - FStar_Syntax_Util.action_as_lb - mname a - (a.FStar_Syntax_Syntax.action_defn).FStar_Syntax_Syntax.pos in - FStar_Syntax_DsEnv.push_sigelt - env5 uu___5) env3 actions1 in - let env5 = - push_reflect_effect env4 qualifiers - mname d.FStar_Parser_AST.drange in - (env5, [se]))))) -and (desugar_redefine_effect : - FStar_Syntax_DsEnv.env -> - FStar_Parser_AST.decl -> - FStar_Syntax_Syntax.attribute Prims.list -> - (FStar_Ident.lident FStar_Pervasives_Native.option -> - FStar_Parser_AST.qualifier -> FStar_Syntax_Syntax.qualifier) - -> - FStar_Parser_AST.qualifier Prims.list -> - FStar_Ident.ident -> - FStar_Parser_AST.binder Prims.list -> - FStar_Parser_AST.term -> - (FStar_Syntax_DsEnv.env * FStar_Syntax_Syntax.sigelt - Prims.list)) - = - fun env -> - fun d -> - fun d_attrs -> - fun trans_qual1 -> - fun quals -> - fun eff_name -> - fun eff_binders -> - fun defn -> - let env0 = env in - let env1 = - FStar_Syntax_DsEnv.enter_monad_scope env eff_name in - let uu___ = desugar_binders env1 eff_binders in - match uu___ with - | (env2, binders) -> - let uu___1 = - let uu___2 = head_and_args defn in - match uu___2 with - | (head, args) -> - let lid = - match head.FStar_Parser_AST.tm with - | FStar_Parser_AST.Name l -> l - | uu___3 -> - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Parser_AST.term_to_string head in - Prims.strcat uu___6 " not found" in - Prims.strcat "Effect " uu___5 in - FStar_Errors.raise_error - FStar_Parser_AST.hasRange_decl d - FStar_Errors_Codes.Fatal_EffectNotFound - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4) in - let ed = - FStar_Syntax_DsEnv.fail_or env2 - (FStar_Syntax_DsEnv.try_lookup_effect_defn - env2) lid in - let uu___3 = - match FStar_Compiler_List.rev args with - | (last_arg, uu___4)::args_rev -> - let uu___5 = - let uu___6 = unparen last_arg in - uu___6.FStar_Parser_AST.tm in - (match uu___5 with - | FStar_Parser_AST.Attributes ts -> - (ts, - (FStar_Compiler_List.rev args_rev)) - | uu___6 -> ([], args)) - | uu___4 -> ([], args) in - (match uu___3 with - | (cattributes, args1) -> - let uu___4 = desugar_args env2 args1 in - let uu___5 = - desugar_attributes env2 cattributes in - (lid, ed, uu___4, uu___5)) in - (match uu___1 with - | (ed_lid, ed, args, cattributes) -> - let binders1 = - FStar_Syntax_Subst.close_binders binders in - (if - (FStar_Compiler_List.length args) <> - (FStar_Compiler_List.length - ed.FStar_Syntax_Syntax.binders) - then - FStar_Errors.raise_error - FStar_Parser_AST.hasRange_term defn - FStar_Errors_Codes.Fatal_ArgumentLengthMismatch - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Unexpected number of arguments to effect constructor") - else (); - (let uu___3 = - FStar_Syntax_Subst.open_term' - ed.FStar_Syntax_Syntax.binders - FStar_Syntax_Syntax.t_unit in - match uu___3 with - | (ed_binders, uu___4, ed_binders_opening) -> - let sub' shift_n uu___5 = - match uu___5 with - | (us, x) -> - let x1 = - let uu___6 = - FStar_Syntax_Subst.shift_subst - (shift_n + - (FStar_Compiler_List.length - us)) ed_binders_opening in - FStar_Syntax_Subst.subst uu___6 x in - let s = - FStar_Syntax_Util.subst_of_list - ed_binders args in - let uu___6 = - let uu___7 = - FStar_Syntax_Subst.subst s x1 in - (us, uu___7) in - FStar_Syntax_Subst.close_tscheme - binders1 uu___6 in - let sub = sub' Prims.int_zero in - let mname = - FStar_Syntax_DsEnv.qualify env0 eff_name in - let ed1 = - let uu___5 = - FStar_Syntax_Util.apply_eff_sig sub - ed.FStar_Syntax_Syntax.signature in - let uu___6 = - FStar_Syntax_Util.apply_eff_combinators - sub ed.FStar_Syntax_Syntax.combinators in - let uu___7 = - FStar_Compiler_List.map - (fun action -> - let nparam = - FStar_Compiler_List.length - action.FStar_Syntax_Syntax.action_params in - let uu___8 = - FStar_Syntax_DsEnv.qualify env2 - action.FStar_Syntax_Syntax.action_unqualified_name in - let uu___9 = - let uu___10 = - sub' nparam - ([], - (action.FStar_Syntax_Syntax.action_defn)) in - FStar_Pervasives_Native.snd - uu___10 in - let uu___10 = - let uu___11 = - sub' nparam - ([], - (action.FStar_Syntax_Syntax.action_typ)) in - FStar_Pervasives_Native.snd - uu___11 in - { - FStar_Syntax_Syntax.action_name = - uu___8; - FStar_Syntax_Syntax.action_unqualified_name - = - (action.FStar_Syntax_Syntax.action_unqualified_name); - FStar_Syntax_Syntax.action_univs - = - (action.FStar_Syntax_Syntax.action_univs); - FStar_Syntax_Syntax.action_params - = - (action.FStar_Syntax_Syntax.action_params); - FStar_Syntax_Syntax.action_defn = - uu___9; - FStar_Syntax_Syntax.action_typ = - uu___10 - }) ed.FStar_Syntax_Syntax.actions in - { - FStar_Syntax_Syntax.mname = mname; - FStar_Syntax_Syntax.cattributes = - cattributes; - FStar_Syntax_Syntax.univs = - (ed.FStar_Syntax_Syntax.univs); - FStar_Syntax_Syntax.binders = binders1; - FStar_Syntax_Syntax.signature = uu___5; - FStar_Syntax_Syntax.combinators = uu___6; - FStar_Syntax_Syntax.actions = uu___7; - FStar_Syntax_Syntax.eff_attrs = - (ed.FStar_Syntax_Syntax.eff_attrs); - FStar_Syntax_Syntax.extraction_mode = - (ed.FStar_Syntax_Syntax.extraction_mode) - } in - let se = - let uu___5 = - let uu___6 = - trans_qual1 - (FStar_Pervasives_Native.Some mname) in - FStar_Compiler_List.map uu___6 quals in - let uu___6 = - FStar_Syntax_DsEnv.opens_and_abbrevs - env2 in - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_new_effect - ed1); - FStar_Syntax_Syntax.sigrng = - (d.FStar_Parser_AST.drange); - FStar_Syntax_Syntax.sigquals = uu___5; - FStar_Syntax_Syntax.sigmeta = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs = d_attrs; - FStar_Syntax_Syntax.sigopens_and_abbrevs - = uu___6; - FStar_Syntax_Syntax.sigopts = - FStar_Pervasives_Native.None - } in - let monad_env = env2 in - let env3 = - FStar_Syntax_DsEnv.push_sigelt env0 se in - let env4 = - FStar_Compiler_List.fold_left - (fun env5 -> - fun a -> - let uu___5 = - FStar_Syntax_Util.action_as_lb - mname a - (a.FStar_Syntax_Syntax.action_defn).FStar_Syntax_Syntax.pos in - FStar_Syntax_DsEnv.push_sigelt env5 - uu___5) env3 - ed1.FStar_Syntax_Syntax.actions in - let env5 = - if - FStar_Compiler_List.contains - FStar_Parser_AST.Reflectable quals - then - let reflect_lid = - let uu___5 = - FStar_Ident.id_of_text "reflect" in - FStar_Syntax_DsEnv.qualify monad_env - uu___5 in - let quals1 = - [FStar_Syntax_Syntax.Assumption; - FStar_Syntax_Syntax.Reflectable mname] in - let refl_decl = - let uu___5 = - FStar_Syntax_DsEnv.opens_and_abbrevs - env4 in - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_declare_typ - { - FStar_Syntax_Syntax.lid2 = - reflect_lid; - FStar_Syntax_Syntax.us2 = []; - FStar_Syntax_Syntax.t2 = - FStar_Syntax_Syntax.tun - }); - FStar_Syntax_Syntax.sigrng = - (d.FStar_Parser_AST.drange); - FStar_Syntax_Syntax.sigquals = - quals1; - FStar_Syntax_Syntax.sigmeta = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs = []; - FStar_Syntax_Syntax.sigopens_and_abbrevs - = uu___5; - FStar_Syntax_Syntax.sigopts = - FStar_Pervasives_Native.None - } in - FStar_Syntax_DsEnv.push_sigelt env4 - refl_decl - else env4 in - (env5, [se])))) -and (desugar_decl_maybe_fail_attr : - FStar_Syntax_DsEnv.env -> - FStar_Parser_AST.decl -> (env_t * FStar_Syntax_Syntax.sigelts)) - = - fun env -> - fun d -> - let no_fail_attrs ats = - FStar_Compiler_List.filter - (fun at -> - let uu___ = get_fail_attr1 false at in - FStar_Compiler_Option.isNone uu___) ats in - let env0 = - let uu___ = FStar_Syntax_DsEnv.snapshot env in - FStar_Pervasives_Native.snd uu___ in - let uu___ = - let attrs = - let uu___1 = - FStar_Compiler_List.map (desugar_term env) - d.FStar_Parser_AST.attrs in - FStar_Syntax_Util.deduplicate_terms uu___1 in - let uu___1 = get_fail_attr false attrs in - match uu___1 with - | FStar_Pervasives_Native.Some (expected_errs, lax) -> - let d1 = - { - FStar_Parser_AST.d = (d.FStar_Parser_AST.d); - FStar_Parser_AST.drange = (d.FStar_Parser_AST.drange); - FStar_Parser_AST.quals = (d.FStar_Parser_AST.quals); - FStar_Parser_AST.attrs = []; - FStar_Parser_AST.interleaved = - (d.FStar_Parser_AST.interleaved) - } in - let uu___2 = - FStar_Errors.catch_errors - (fun uu___3 -> - FStar_Options.with_saved_options - (fun uu___4 -> desugar_decl_core env attrs d1)) in - (match uu___2 with - | (errs, r) -> - (match (errs, r) with - | ([], FStar_Pervasives_Native.Some (env1, ses)) -> - let ses1 = - FStar_Compiler_List.map - (fun se -> - let uu___3 = no_fail_attrs attrs in - { - FStar_Syntax_Syntax.sigel = - (se.FStar_Syntax_Syntax.sigel); - FStar_Syntax_Syntax.sigrng = - (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = uu___3; - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se.FStar_Syntax_Syntax.sigopts) - }) ses in - let se = - let uu___3 = - FStar_Syntax_DsEnv.opens_and_abbrevs env1 in - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_fail - { - FStar_Syntax_Syntax.errs = expected_errs; - FStar_Syntax_Syntax.fail_in_lax = lax; - FStar_Syntax_Syntax.ses1 = ses1 - }); - FStar_Syntax_Syntax.sigrng = - (d1.FStar_Parser_AST.drange); - FStar_Syntax_Syntax.sigquals = []; - FStar_Syntax_Syntax.sigmeta = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs = attrs; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___3; - FStar_Syntax_Syntax.sigopts = - FStar_Pervasives_Native.None - } in - (env0, [se]) - | (errs1, ropt) -> - let errnos = - FStar_Compiler_List.concatMap - (fun i -> - FStar_Common.list_of_option - i.FStar_Errors.issue_number) errs1 in - ((let uu___4 = FStar_Options.print_expected_failures () in - if uu___4 - then - (FStar_Compiler_Util.print_string - ">> Got issues: [\n"; - FStar_Compiler_List.iter FStar_Errors.print_issue - errs1; - FStar_Compiler_Util.print_string ">>]\n") - else ()); - if expected_errs = [] - then (env0, []) - else - (let uu___5 = - FStar_Errors.find_multiset_discrepancy - expected_errs errnos in - match uu___5 with - | FStar_Pervasives_Native.None -> (env0, []) - | FStar_Pervasives_Native.Some (e, n1, n2) -> - (FStar_Compiler_List.iter - FStar_Errors.print_issue errs1; - (let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Errors_Msg.text - "This top-level definition was expected to raise error codes" in - let uu___12 = - FStar_Class_PP.pp - (FStar_Class_PP.pp_list - FStar_Class_PP.pp_int) - expected_errs in - FStar_Pprint.prefix (Prims.of_int (2)) - Prims.int_one uu___11 uu___12 in - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Errors_Msg.text - "but it raised" in - let uu___14 = - FStar_Class_PP.pp - (FStar_Class_PP.pp_list - FStar_Class_PP.pp_int) errnos in - FStar_Pprint.prefix - (Prims.of_int (2)) Prims.int_one - uu___13 uu___14 in - let uu___13 = - let uu___14 = - FStar_Errors_Msg.text - "(at desugaring time)" in - FStar_Pprint.op_Hat_Hat uu___14 - FStar_Pprint.dot in - FStar_Pprint.op_Hat_Hat uu___12 uu___13 in - FStar_Pprint.op_Hat_Slash_Hat uu___10 - uu___11 in - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - e in - let uu___14 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - n2 in - let uu___15 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - n1 in - FStar_Compiler_Util.format3 - "Error #%s was raised %s times, instead of %s." - uu___13 uu___14 uu___15 in - FStar_Errors_Msg.text uu___12 in - [uu___11] in - uu___9 :: uu___10 in - FStar_Errors.log_issue - FStar_Parser_AST.hasRange_decl d1 - FStar_Errors_Codes.Error_DidNotFail () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___8)); - (env0, [])))))) - | FStar_Pervasives_Native.None -> desugar_decl_core env attrs d in - match uu___ with | (env1, sigelts) -> (env1, sigelts) -and (desugar_decl : - env_t -> FStar_Parser_AST.decl -> (env_t * FStar_Syntax_Syntax.sigelts)) = - fun env -> - fun d -> - FStar_GenSym.reset_gensym (); - (let uu___1 = desugar_decl_maybe_fail_attr env d in - match uu___1 with - | (env1, ses) -> - let uu___2 = - FStar_Compiler_List.map generalize_annotated_univs ses in - (env1, uu___2)) -and (desugar_decl_core : - FStar_Syntax_DsEnv.env -> - FStar_Syntax_Syntax.term Prims.list -> - FStar_Parser_AST.decl -> (env_t * FStar_Syntax_Syntax.sigelts)) - = - fun env -> - fun d_attrs -> - fun d -> - let trans_qual1 = trans_qual d.FStar_Parser_AST.drange in - match d.FStar_Parser_AST.d with - | FStar_Parser_AST.Pragma p -> - let p1 = trans_pragma p in - (FStar_Syntax_Util.process_pragma p1 d.FStar_Parser_AST.drange; - (let se = - let uu___1 = FStar_Syntax_DsEnv.opens_and_abbrevs env in - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_pragma p1); - FStar_Syntax_Syntax.sigrng = (d.FStar_Parser_AST.drange); - FStar_Syntax_Syntax.sigquals = []; - FStar_Syntax_Syntax.sigmeta = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs = d_attrs; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___1; - FStar_Syntax_Syntax.sigopts = FStar_Pervasives_Native.None - } in - (env, [se]))) - | FStar_Parser_AST.TopLevelModule id -> (env, []) - | FStar_Parser_AST.Open (lid, restriction) -> - let env1 = FStar_Syntax_DsEnv.push_namespace env lid restriction in - (env1, []) - | FStar_Parser_AST.Friend lid -> - let uu___ = FStar_Syntax_DsEnv.iface env in - if uu___ - then - FStar_Errors.raise_error FStar_Parser_AST.hasRange_decl d - FStar_Errors_Codes.Fatal_FriendInterface () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "'friend' declarations are not allowed in interfaces") - else - (let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_DsEnv.dep_graph env in - let uu___5 = FStar_Syntax_DsEnv.current_module env in - FStar_Parser_Dep.module_has_interface uu___4 uu___5 in - Prims.op_Negation uu___3 in - if uu___2 - then - FStar_Errors.raise_error FStar_Parser_AST.hasRange_decl d - FStar_Errors_Codes.Fatal_FriendInterface () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "'friend' declarations are not allowed in modules that lack interfaces") - else - (let uu___4 = - let uu___5 = - let uu___6 = FStar_Syntax_DsEnv.dep_graph env in - FStar_Parser_Dep.module_has_interface uu___6 lid in - Prims.op_Negation uu___5 in - if uu___4 - then - FStar_Errors.raise_error FStar_Parser_AST.hasRange_decl d - FStar_Errors_Codes.Fatal_FriendInterface () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "'friend' declarations cannot refer to modules that lack interfaces") - else - (let uu___6 = - let uu___7 = - let uu___8 = FStar_Syntax_DsEnv.dep_graph env in - FStar_Parser_Dep.deps_has_implementation uu___8 lid in - Prims.op_Negation uu___7 in - if uu___6 - then - FStar_Errors.raise_error - FStar_Parser_AST.hasRange_decl d - FStar_Errors_Codes.Fatal_FriendInterface () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "'friend' module has not been loaded; recompute dependences (C-c C-r) if in interactive mode") - else (env, [])))) - | FStar_Parser_AST.Include (lid, restriction) -> - let env1 = FStar_Syntax_DsEnv.push_include env lid restriction in - (env1, []) - | FStar_Parser_AST.ModuleAbbrev (x, l) -> - let uu___ = FStar_Syntax_DsEnv.push_module_abbrev env x l in - (uu___, []) - | FStar_Parser_AST.Tycon (is_effect, typeclass, tcs) -> - let quals = d.FStar_Parser_AST.quals in - let quals1 = - if is_effect - then FStar_Parser_AST.Effect_qual :: quals - else quals in - let quals2 = - if typeclass - then - match tcs with - | (FStar_Parser_AST.TyconRecord uu___)::[] -> - FStar_Parser_AST.Noeq :: quals1 - | uu___ -> - FStar_Errors.raise_error FStar_Parser_AST.hasRange_decl d - FStar_Errors_Codes.Error_BadClassDecl () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Ill-formed `class` declaration: definition must be a record type") - else quals1 in - let uu___ = - let uu___1 = - FStar_Compiler_List.map - (trans_qual1 FStar_Pervasives_Native.None) quals2 in - desugar_tycon env d d_attrs uu___1 tcs in - (match uu___ with - | (env1, ses) -> - ((let uu___2 = FStar_Compiler_Effect.op_Bang dbg_attrs in - if uu___2 - then - let uu___3 = - FStar_Class_Show.show FStar_Parser_AST.showable_decl d in - let uu___4 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_sigelt) ses in - FStar_Compiler_Util.print2 - "Desugared tycon from {%s} to {%s}\n" uu___3 uu___4 - else ()); - (let mkclass lid = - let r = FStar_Ident.range_of_lid lid in - let body = - let uu___2 = - FStar_Syntax_Util.has_attribute d_attrs - FStar_Parser_Const.meta_projectors_attr in - if uu___2 - then - let uu___3 = - FStar_Syntax_Syntax.tabbrev - FStar_Parser_Const.mk_projs_lid in - let uu___4 = - let uu___5 = - let uu___6 = FStar_Syntax_Util.exp_bool true in - FStar_Syntax_Syntax.as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = FStar_Ident.string_of_lid lid in - FStar_Syntax_Util.exp_string uu___9 in - FStar_Syntax_Syntax.as_arg uu___8 in - [uu___7] in - uu___5 :: uu___6 in - FStar_Syntax_Util.mk_app uu___3 uu___4 - else - (let uu___4 = - FStar_Syntax_Syntax.tabbrev - FStar_Parser_Const.mk_class_lid in - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = FStar_Ident.string_of_lid lid in - FStar_Syntax_Util.exp_string uu___8 in - FStar_Syntax_Syntax.as_arg uu___7 in - [uu___6] in - FStar_Syntax_Util.mk_app uu___4 uu___5) in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = tun_r r in - FStar_Syntax_Syntax.new_bv - (FStar_Pervasives_Native.Some r) uu___5 in - FStar_Syntax_Syntax.mk_binder uu___4 in - [uu___3] in - FStar_Syntax_Util.abs uu___2 body - FStar_Pervasives_Native.None in - let get_meths se = - let rec get_fname quals3 = - match quals3 with - | (FStar_Syntax_Syntax.Projector (uu___2, id))::uu___3 - -> FStar_Pervasives_Native.Some id - | uu___2::quals4 -> get_fname quals4 - | [] -> FStar_Pervasives_Native.None in - let uu___2 = get_fname se.FStar_Syntax_Syntax.sigquals in - match uu___2 with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some id -> - let uu___3 = FStar_Syntax_DsEnv.qualify env1 id in - [uu___3] in - let formals = - let bndl = - FStar_Compiler_Util.try_find - (fun uu___2 -> - match uu___2 with - | { - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_bundle uu___3; - FStar_Syntax_Syntax.sigrng = uu___4; - FStar_Syntax_Syntax.sigquals = uu___5; - FStar_Syntax_Syntax.sigmeta = uu___6; - FStar_Syntax_Syntax.sigattrs = uu___7; - FStar_Syntax_Syntax.sigopens_and_abbrevs = - uu___8; - FStar_Syntax_Syntax.sigopts = uu___9;_} -> - true - | uu___3 -> false) ses in - match bndl with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some bndl1 -> - (match bndl1.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_bundle - { FStar_Syntax_Syntax.ses = ses1; - FStar_Syntax_Syntax.lids = uu___2;_} - -> - FStar_Compiler_Util.find_map ses1 - (fun se -> - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = uu___3; - FStar_Syntax_Syntax.us1 = uu___4; - FStar_Syntax_Syntax.t1 = t; - FStar_Syntax_Syntax.ty_lid = uu___5; - FStar_Syntax_Syntax.num_ty_params = - uu___6; - FStar_Syntax_Syntax.mutuals1 = - uu___7; - FStar_Syntax_Syntax.injective_type_params1 - = uu___8;_} - -> - let uu___9 = - FStar_Syntax_Util.arrow_formals t in - (match uu___9 with - | (formals1, uu___10) -> - FStar_Pervasives_Native.Some - formals1) - | uu___3 -> FStar_Pervasives_Native.None) - | uu___2 -> FStar_Pervasives_Native.None) in - let rec splice_decl meths se = - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_bundle - { FStar_Syntax_Syntax.ses = ses1; - FStar_Syntax_Syntax.lids = uu___2;_} - -> - FStar_Compiler_List.concatMap (splice_decl meths) - ses1 - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = lid; - FStar_Syntax_Syntax.us = uu___2; - FStar_Syntax_Syntax.params = uu___3; - FStar_Syntax_Syntax.num_uniform_params = uu___4; - FStar_Syntax_Syntax.t = ty; - FStar_Syntax_Syntax.mutuals = uu___5; - FStar_Syntax_Syntax.ds = uu___6; - FStar_Syntax_Syntax.injective_type_params = uu___7;_} - -> - let formals1 = - match formals with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some formals2 -> - formals2 in - let has_no_method_attr meth = - let i = FStar_Ident.ident_of_lid meth in - FStar_Compiler_Util.for_some - (fun formal -> - let uu___8 = - FStar_Ident.ident_equals i - (formal.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.ppname in - if uu___8 - then - FStar_Compiler_Util.for_some - (fun attr -> - let uu___9 = - let uu___10 = - FStar_Syntax_Subst.compress attr in - uu___10.FStar_Syntax_Syntax.n in - match uu___9 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.no_method_lid - | uu___10 -> false) - formal.FStar_Syntax_Syntax.binder_attrs - else false) formals1 in - let meths1 = - FStar_Compiler_List.filter - (fun x -> - let uu___8 = has_no_method_attr x in - Prims.op_Negation uu___8) meths in - let is_typed = false in - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = mkclass lid in - { - FStar_Syntax_Syntax.is_typed = is_typed; - FStar_Syntax_Syntax.lids2 = meths1; - FStar_Syntax_Syntax.tac = uu___11 - } in - FStar_Syntax_Syntax.Sig_splice uu___10 in - let uu___10 = - FStar_Syntax_DsEnv.opens_and_abbrevs env1 in - { - FStar_Syntax_Syntax.sigel = uu___9; - FStar_Syntax_Syntax.sigrng = - (d.FStar_Parser_AST.drange); - FStar_Syntax_Syntax.sigquals = []; - FStar_Syntax_Syntax.sigmeta = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs = []; - FStar_Syntax_Syntax.sigopens_and_abbrevs = - uu___10; - FStar_Syntax_Syntax.sigopts = - FStar_Pervasives_Native.None - } in - [uu___8] - | uu___2 -> [] in - let uu___2 = - if typeclass - then - let meths = - FStar_Compiler_List.concatMap get_meths ses in - let rec add_class_attr se = - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_bundle - { FStar_Syntax_Syntax.ses = ses1; - FStar_Syntax_Syntax.lids = lids;_} - -> - let ses2 = - FStar_Compiler_List.map add_class_attr ses1 in - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Syntax_Syntax.fvar_with_dd - FStar_Parser_Const.tcclass_lid - FStar_Pervasives_Native.None in - uu___5 :: (se.FStar_Syntax_Syntax.sigattrs) in - FStar_Syntax_Util.deduplicate_terms uu___4 in - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_bundle - { - FStar_Syntax_Syntax.ses = ses2; - FStar_Syntax_Syntax.lids = lids - }); - FStar_Syntax_Syntax.sigrng = - (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = uu___3; - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se.FStar_Syntax_Syntax.sigopts) - } - | FStar_Syntax_Syntax.Sig_inductive_typ uu___3 -> - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Syntax.fvar_with_dd - FStar_Parser_Const.tcclass_lid - FStar_Pervasives_Native.None in - uu___6 :: (se.FStar_Syntax_Syntax.sigattrs) in - FStar_Syntax_Util.deduplicate_terms uu___5 in - { - FStar_Syntax_Syntax.sigel = - (se.FStar_Syntax_Syntax.sigel); - FStar_Syntax_Syntax.sigrng = - (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = uu___4; - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se.FStar_Syntax_Syntax.sigopts) - } - | uu___3 -> se in - let uu___3 = - FStar_Compiler_List.map add_class_attr ses in - let uu___4 = - FStar_Compiler_List.concatMap (splice_decl meths) - ses in - (uu___3, uu___4) - else (ses, []) in - match uu___2 with - | (ses1, extra) -> - let env2 = - FStar_Compiler_List.fold_left - FStar_Syntax_DsEnv.push_sigelt env1 extra in - (env2, (FStar_Compiler_List.op_At ses1 extra))))) - | FStar_Parser_AST.TopLevelLet (isrec, lets) -> - let quals = d.FStar_Parser_AST.quals in - let expand_toplevel_pattern = - (isrec = FStar_Parser_AST.NoLetQualifier) && - (match lets with - | ({ FStar_Parser_AST.pat = FStar_Parser_AST.PatOp uu___; - FStar_Parser_AST.prange = uu___1;_}, - uu___2)::[] -> false - | ({ FStar_Parser_AST.pat = FStar_Parser_AST.PatVar uu___; - FStar_Parser_AST.prange = uu___1;_}, - uu___2)::[] -> false - | ({ - FStar_Parser_AST.pat = FStar_Parser_AST.PatAscribed - ({ - FStar_Parser_AST.pat = FStar_Parser_AST.PatOp - uu___; - FStar_Parser_AST.prange = uu___1;_}, - uu___2); - FStar_Parser_AST.prange = uu___3;_}, - uu___4)::[] -> false - | ({ - FStar_Parser_AST.pat = FStar_Parser_AST.PatAscribed - ({ - FStar_Parser_AST.pat = FStar_Parser_AST.PatVar - uu___; - FStar_Parser_AST.prange = uu___1;_}, - uu___2); - FStar_Parser_AST.prange = uu___3;_}, - uu___4)::[] -> false - | (p, uu___)::[] -> - let uu___1 = is_app_pattern p in - Prims.op_Negation uu___1 - | uu___ -> false) in - if Prims.op_Negation expand_toplevel_pattern - then - let lets1 = - FStar_Compiler_List.map - (fun x -> (FStar_Pervasives_Native.None, x)) lets in - let as_inner_let = - let uu___ = - let uu___1 = - let uu___2 = - FStar_Parser_AST.mk_term - (FStar_Parser_AST.Const FStar_Const.Const_unit) - d.FStar_Parser_AST.drange FStar_Parser_AST.Expr in - (isrec, lets1, uu___2) in - FStar_Parser_AST.Let uu___1 in - FStar_Parser_AST.mk_term uu___ d.FStar_Parser_AST.drange - FStar_Parser_AST.Expr in - let uu___ = desugar_term_maybe_top true env as_inner_let in - (match uu___ with - | (ds_lets, aq) -> - (check_no_aq aq; - (let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress ds_lets in - uu___3.FStar_Syntax_Syntax.n in - match uu___2 with - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = lbs; - FStar_Syntax_Syntax.body1 = uu___3;_} - -> - let fvs = - FStar_Compiler_List.map - (fun lb -> - FStar_Compiler_Util.right - lb.FStar_Syntax_Syntax.lbname) - (FStar_Pervasives_Native.snd lbs) in - let uu___4 = - FStar_Compiler_List.fold_right - (fun fv -> - fun uu___5 -> - match uu___5 with - | (qs, ats) -> - let uu___6 = - FStar_Syntax_DsEnv.lookup_letbinding_quals_and_attrs - env - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - (match uu___6 with - | (qs', ats') -> - ((FStar_Compiler_List.op_At qs' qs), - (FStar_Compiler_List.op_At ats' - ats)))) fvs ([], []) in - (match uu___4 with - | (val_quals, val_attrs) -> - let top_attrs = d_attrs in - let lbs1 = - let uu___5 = lbs in - match uu___5 with - | (isrec1, lbs0) -> - let lbs01 = - FStar_Compiler_List.map - (fun lb -> - let uu___6 = - FStar_Syntax_Util.deduplicate_terms - (FStar_Compiler_List.op_At - lb.FStar_Syntax_Syntax.lbattrs - (FStar_Compiler_List.op_At - val_attrs top_attrs)) in - { - FStar_Syntax_Syntax.lbname = - (lb.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = - (lb.FStar_Syntax_Syntax.lbtyp); - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = - (lb.FStar_Syntax_Syntax.lbdef); - FStar_Syntax_Syntax.lbattrs = - uu___6; - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - }) lbs0 in - (isrec1, lbs01) in - let quals1 = - match quals with - | uu___5::uu___6 -> - FStar_Compiler_List.map - (trans_qual1 - FStar_Pervasives_Native.None) quals - | uu___5 -> val_quals in - let quals2 = - let uu___5 = - FStar_Compiler_Util.for_some - (fun uu___6 -> - match uu___6 with - | (uu___7, (uu___8, t)) -> - t.FStar_Parser_AST.level = - FStar_Parser_AST.Formula) lets1 in - if uu___5 - then FStar_Syntax_Syntax.Logic :: quals1 - else quals1 in - let names = - FStar_Compiler_List.map - (fun fv -> - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v) - fvs in - let s = - let uu___5 = - FStar_Syntax_Util.deduplicate_terms - (FStar_Compiler_List.op_At val_attrs - top_attrs) in - let uu___6 = - FStar_Syntax_DsEnv.opens_and_abbrevs env in - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_let - { - FStar_Syntax_Syntax.lbs1 = lbs1; - FStar_Syntax_Syntax.lids1 = names - }); - FStar_Syntax_Syntax.sigrng = - (d.FStar_Parser_AST.drange); - FStar_Syntax_Syntax.sigquals = quals2; - FStar_Syntax_Syntax.sigmeta = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs = uu___5; - FStar_Syntax_Syntax.sigopens_and_abbrevs = - uu___6; - FStar_Syntax_Syntax.sigopts = - FStar_Pervasives_Native.None - } in - let env1 = FStar_Syntax_DsEnv.push_sigelt env s in - (env1, [s])) - | uu___3 -> - failwith "Desugaring a let did not produce a let"))) - else - (let uu___1 = - match lets with - | (pat, body)::[] -> (pat, body) - | uu___2 -> - failwith - "expand_toplevel_pattern should only allow single definition lets" in - match uu___1 with - | (pat, body) -> - let rec gen_fresh_toplevel_name uu___2 = - let nm = - FStar_Ident.gen FStar_Compiler_Range_Type.dummyRange in - let uu___3 = - let uu___4 = - let uu___5 = FStar_Ident.lid_of_ids [nm] in - FStar_Syntax_DsEnv.resolve_name env uu___5 in - FStar_Pervasives_Native.uu___is_Some uu___4 in - if uu___3 then gen_fresh_toplevel_name () else nm in - let fresh_toplevel_name = gen_fresh_toplevel_name () in - let fresh_pat = - let var_pat = - FStar_Parser_AST.mk_pattern - (FStar_Parser_AST.PatVar - (fresh_toplevel_name, - FStar_Pervasives_Native.None, [])) - FStar_Compiler_Range_Type.dummyRange in - match pat.FStar_Parser_AST.pat with - | FStar_Parser_AST.PatAscribed (pat1, ty) -> - { - FStar_Parser_AST.pat = - (FStar_Parser_AST.PatAscribed (var_pat, ty)); - FStar_Parser_AST.prange = - (pat1.FStar_Parser_AST.prange) - } - | uu___2 -> var_pat in - let main_let = - let quals1 = - if - FStar_Compiler_List.mem FStar_Parser_AST.Private - d.FStar_Parser_AST.quals - then d.FStar_Parser_AST.quals - else FStar_Parser_AST.Private :: - (d.FStar_Parser_AST.quals) in - desugar_decl env - { - FStar_Parser_AST.d = - (FStar_Parser_AST.TopLevelLet - (isrec, [(fresh_pat, body)])); - FStar_Parser_AST.drange = - (d.FStar_Parser_AST.drange); - FStar_Parser_AST.quals = quals1; - FStar_Parser_AST.attrs = (d.FStar_Parser_AST.attrs); - FStar_Parser_AST.interleaved = - (d.FStar_Parser_AST.interleaved) - } in - let main = - let uu___2 = - let uu___3 = - FStar_Ident.lid_of_ids [fresh_toplevel_name] in - FStar_Parser_AST.Var uu___3 in - FStar_Parser_AST.mk_term uu___2 - pat.FStar_Parser_AST.prange FStar_Parser_AST.Expr in - let build_generic_projection uu___2 id_opt = - match uu___2 with - | (env1, ses) -> - let uu___3 = - match id_opt with - | FStar_Pervasives_Native.Some id -> - let lid = FStar_Ident.lid_of_ids [id] in - let branch = - let uu___4 = FStar_Ident.range_of_lid lid in - FStar_Parser_AST.mk_term - (FStar_Parser_AST.Var lid) uu___4 - FStar_Parser_AST.Expr in - let bv_pat = - let uu___4 = FStar_Ident.range_of_id id in - FStar_Parser_AST.mk_pattern - (FStar_Parser_AST.PatVar - (id, FStar_Pervasives_Native.None, [])) - uu___4 in - (bv_pat, branch) - | FStar_Pervasives_Native.None -> - let id = gen_fresh_toplevel_name () in - let branch = - FStar_Parser_AST.mk_term - (FStar_Parser_AST.Const - FStar_Const.Const_unit) - FStar_Compiler_Range_Type.dummyRange - FStar_Parser_AST.Expr in - let bv_pat = - let uu___4 = FStar_Ident.range_of_id id in - FStar_Parser_AST.mk_pattern - (FStar_Parser_AST.PatVar - (id, FStar_Pervasives_Native.None, [])) - uu___4 in - let bv_pat1 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Ident.range_of_id id in - unit_ty uu___8 in - (uu___7, FStar_Pervasives_Native.None) in - (bv_pat, uu___6) in - FStar_Parser_AST.PatAscribed uu___5 in - let uu___5 = FStar_Ident.range_of_id id in - FStar_Parser_AST.mk_pattern uu___4 uu___5 in - (bv_pat1, branch) in - (match uu___3 with - | (bv_pat, branch) -> - let body1 = - FStar_Parser_AST.mk_term - (FStar_Parser_AST.Match - (main, FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None, - [(pat, FStar_Pervasives_Native.None, - branch)])) - main.FStar_Parser_AST.range - FStar_Parser_AST.Expr in - let id_decl = - FStar_Parser_AST.mk_decl - (FStar_Parser_AST.TopLevelLet - (FStar_Parser_AST.NoLetQualifier, - [(bv_pat, body1)])) - FStar_Compiler_Range_Type.dummyRange [] in - let id_decl1 = - { - FStar_Parser_AST.d = - (id_decl.FStar_Parser_AST.d); - FStar_Parser_AST.drange = - (id_decl.FStar_Parser_AST.drange); - FStar_Parser_AST.quals = - (d.FStar_Parser_AST.quals); - FStar_Parser_AST.attrs = - (id_decl.FStar_Parser_AST.attrs); - FStar_Parser_AST.interleaved = - (id_decl.FStar_Parser_AST.interleaved) - } in - let uu___4 = desugar_decl env1 id_decl1 in - (match uu___4 with - | (env2, ses') -> - (env2, - (FStar_Compiler_List.op_At ses ses')))) in - let build_projection uu___2 id = - match uu___2 with - | (env1, ses) -> - build_generic_projection (env1, ses) - (FStar_Pervasives_Native.Some id) in - let build_coverage_check uu___2 = - match uu___2 with - | (env1, ses) -> - build_generic_projection (env1, ses) - FStar_Pervasives_Native.None in - let bvs = - let uu___2 = gather_pattern_bound_vars pat in - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_ident)) - (Obj.magic uu___2) in - let uu___2 = - (FStar_Compiler_List.isEmpty bvs) && - (let uu___3 = is_var_pattern pat in - Prims.op_Negation uu___3) in - if uu___2 - then build_coverage_check main_let - else - FStar_Compiler_List.fold_left build_projection main_let - bvs) - | FStar_Parser_AST.Assume (id, t) -> - let f = desugar_formula env t in - let lid = FStar_Syntax_DsEnv.qualify env id in - let uu___ = - let uu___1 = - let uu___2 = FStar_Syntax_DsEnv.opens_and_abbrevs env in - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_assume - { - FStar_Syntax_Syntax.lid3 = lid; - FStar_Syntax_Syntax.us3 = []; - FStar_Syntax_Syntax.phi1 = f - }); - FStar_Syntax_Syntax.sigrng = (d.FStar_Parser_AST.drange); - FStar_Syntax_Syntax.sigquals = - [FStar_Syntax_Syntax.Assumption]; - FStar_Syntax_Syntax.sigmeta = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs = d_attrs; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___2; - FStar_Syntax_Syntax.sigopts = FStar_Pervasives_Native.None - } in - [uu___1] in - (env, uu___) - | FStar_Parser_AST.Val (id, t) -> - let quals = d.FStar_Parser_AST.quals in - let t1 = let uu___ = close_fun env t in desugar_term env uu___ in - let quals1 = - let uu___ = - (FStar_Syntax_DsEnv.iface env) && - (FStar_Syntax_DsEnv.admitted_iface env) in - if uu___ then FStar_Parser_AST.Assumption :: quals else quals in - let lid = FStar_Syntax_DsEnv.qualify env id in - let se = - let uu___ = - FStar_Compiler_List.map - (trans_qual1 FStar_Pervasives_Native.None) quals1 in - let uu___1 = FStar_Syntax_DsEnv.opens_and_abbrevs env in - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_declare_typ - { - FStar_Syntax_Syntax.lid2 = lid; - FStar_Syntax_Syntax.us2 = []; - FStar_Syntax_Syntax.t2 = t1 - }); - FStar_Syntax_Syntax.sigrng = (d.FStar_Parser_AST.drange); - FStar_Syntax_Syntax.sigquals = uu___; - FStar_Syntax_Syntax.sigmeta = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs = d_attrs; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___1; - FStar_Syntax_Syntax.sigopts = FStar_Pervasives_Native.None - } in - let env1 = FStar_Syntax_DsEnv.push_sigelt env se in (env1, [se]) - | FStar_Parser_AST.Exception (id, t_opt) -> - let t = - match t_opt with - | FStar_Pervasives_Native.None -> - FStar_Syntax_DsEnv.fail_or env - (FStar_Syntax_DsEnv.try_lookup_lid env) - FStar_Parser_Const.exn_lid - | FStar_Pervasives_Native.Some term -> - let t1 = desugar_term env term in - let uu___ = - let uu___1 = FStar_Syntax_Syntax.null_binder t1 in - [uu___1] in - let uu___1 = - let uu___2 = - FStar_Syntax_DsEnv.fail_or env - (FStar_Syntax_DsEnv.try_lookup_lid env) - FStar_Parser_Const.exn_lid in - FStar_Syntax_Syntax.mk_Total uu___2 in - FStar_Syntax_Util.arrow uu___ uu___1 in - let l = FStar_Syntax_DsEnv.qualify env id in - let qual = [FStar_Syntax_Syntax.ExceptionConstructor] in - let top_attrs = d_attrs in - let se = - let uu___ = FStar_Syntax_DsEnv.opens_and_abbrevs env in - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_datacon - { - FStar_Syntax_Syntax.lid1 = l; - FStar_Syntax_Syntax.us1 = []; - FStar_Syntax_Syntax.t1 = t; - FStar_Syntax_Syntax.ty_lid = - FStar_Parser_Const.exn_lid; - FStar_Syntax_Syntax.num_ty_params = Prims.int_zero; - FStar_Syntax_Syntax.mutuals1 = - [FStar_Parser_Const.exn_lid]; - FStar_Syntax_Syntax.injective_type_params1 = false - }); - FStar_Syntax_Syntax.sigrng = (d.FStar_Parser_AST.drange); - FStar_Syntax_Syntax.sigquals = qual; - FStar_Syntax_Syntax.sigmeta = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs = top_attrs; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___; - FStar_Syntax_Syntax.sigopts = FStar_Pervasives_Native.None - } in - let se' = - let uu___ = FStar_Syntax_DsEnv.opens_and_abbrevs env in - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_bundle - { - FStar_Syntax_Syntax.ses = [se]; - FStar_Syntax_Syntax.lids = [l] - }); - FStar_Syntax_Syntax.sigrng = (d.FStar_Parser_AST.drange); - FStar_Syntax_Syntax.sigquals = qual; - FStar_Syntax_Syntax.sigmeta = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs = top_attrs; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___; - FStar_Syntax_Syntax.sigopts = FStar_Pervasives_Native.None - } in - let env1 = FStar_Syntax_DsEnv.push_sigelt env se' in - let data_ops = mk_data_projector_names [] env1 se in - let discs = mk_data_discriminators [] env1 [l] top_attrs in - let env2 = - FStar_Compiler_List.fold_left FStar_Syntax_DsEnv.push_sigelt - env1 (FStar_Compiler_List.op_At discs data_ops) in - (env2, (FStar_Compiler_List.op_At (se' :: discs) data_ops)) - | FStar_Parser_AST.NewEffect (FStar_Parser_AST.RedefineEffect - (eff_name, eff_binders, defn)) -> - let quals = d.FStar_Parser_AST.quals in - desugar_redefine_effect env d d_attrs trans_qual1 quals eff_name - eff_binders defn - | FStar_Parser_AST.NewEffect (FStar_Parser_AST.DefineEffect - (eff_name, eff_binders, eff_typ, eff_decls)) -> - let quals = d.FStar_Parser_AST.quals in - desugar_effect env d d_attrs quals false eff_name eff_binders - eff_typ eff_decls - | FStar_Parser_AST.LayeredEffect (FStar_Parser_AST.DefineEffect - (eff_name, eff_binders, eff_typ, eff_decls)) -> - let quals = d.FStar_Parser_AST.quals in - desugar_effect env d d_attrs quals true eff_name eff_binders - eff_typ eff_decls - | FStar_Parser_AST.LayeredEffect (FStar_Parser_AST.RedefineEffect - uu___) -> - failwith - "Impossible: LayeredEffect (RedefineEffect _) (should not be parseable)" - | FStar_Parser_AST.SubEffect l -> - let src_ed = - lookup_effect_lid env l.FStar_Parser_AST.msource - d.FStar_Parser_AST.drange in - let dst_ed = - lookup_effect_lid env l.FStar_Parser_AST.mdest - d.FStar_Parser_AST.drange in - let top_attrs = d_attrs in - let uu___ = - let uu___1 = - (FStar_Syntax_Util.is_layered src_ed) || - (FStar_Syntax_Util.is_layered dst_ed) in - Prims.op_Negation uu___1 in - if uu___ - then - let uu___1 = - match l.FStar_Parser_AST.lift_op with - | FStar_Parser_AST.NonReifiableLift t -> - let uu___2 = - let uu___3 = - let uu___4 = desugar_term env t in ([], uu___4) in - FStar_Pervasives_Native.Some uu___3 in - (uu___2, FStar_Pervasives_Native.None) - | FStar_Parser_AST.ReifiableLift (wp, t) -> - let uu___2 = - let uu___3 = - let uu___4 = desugar_term env wp in ([], uu___4) in - FStar_Pervasives_Native.Some uu___3 in - let uu___3 = - let uu___4 = - let uu___5 = desugar_term env t in ([], uu___5) in - FStar_Pervasives_Native.Some uu___4 in - (uu___2, uu___3) - | FStar_Parser_AST.LiftForFree t -> - let uu___2 = - let uu___3 = - let uu___4 = desugar_term env t in ([], uu___4) in - FStar_Pervasives_Native.Some uu___3 in - (FStar_Pervasives_Native.None, uu___2) in - (match uu___1 with - | (lift_wp, lift) -> - let se = - let uu___2 = FStar_Syntax_DsEnv.opens_and_abbrevs env in - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_sub_effect - { - FStar_Syntax_Syntax.source = - (src_ed.FStar_Syntax_Syntax.mname); - FStar_Syntax_Syntax.target = - (dst_ed.FStar_Syntax_Syntax.mname); - FStar_Syntax_Syntax.lift_wp = lift_wp; - FStar_Syntax_Syntax.lift = lift; - FStar_Syntax_Syntax.kind = - FStar_Pervasives_Native.None - }); - FStar_Syntax_Syntax.sigrng = - (d.FStar_Parser_AST.drange); - FStar_Syntax_Syntax.sigquals = []; - FStar_Syntax_Syntax.sigmeta = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs = top_attrs; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___2; - FStar_Syntax_Syntax.sigopts = - FStar_Pervasives_Native.None - } in - (env, [se])) - else - (match l.FStar_Parser_AST.lift_op with - | FStar_Parser_AST.NonReifiableLift t -> - let sub_eff = - let uu___2 = - let uu___3 = - let uu___4 = desugar_term env t in ([], uu___4) in - FStar_Pervasives_Native.Some uu___3 in - { - FStar_Syntax_Syntax.source = - (src_ed.FStar_Syntax_Syntax.mname); - FStar_Syntax_Syntax.target = - (dst_ed.FStar_Syntax_Syntax.mname); - FStar_Syntax_Syntax.lift_wp = - FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.lift = uu___2; - FStar_Syntax_Syntax.kind = - FStar_Pervasives_Native.None - } in - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_DsEnv.opens_and_abbrevs env in - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_sub_effect sub_eff); - FStar_Syntax_Syntax.sigrng = - (d.FStar_Parser_AST.drange); - FStar_Syntax_Syntax.sigquals = []; - FStar_Syntax_Syntax.sigmeta = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs = top_attrs; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___4; - FStar_Syntax_Syntax.sigopts = - FStar_Pervasives_Native.None - } in - [uu___3] in - (env, uu___2) - | uu___2 -> - failwith - "Impossible! unexpected lift_op for lift to a layered effect") - | FStar_Parser_AST.Polymonadic_bind (m_eff, n_eff, p_eff, bind) -> - let m = lookup_effect_lid env m_eff d.FStar_Parser_AST.drange in - let n = lookup_effect_lid env n_eff d.FStar_Parser_AST.drange in - let p = lookup_effect_lid env p_eff d.FStar_Parser_AST.drange in - let top_attrs = d_attrs in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = desugar_term env bind in ([], uu___5) in - { - FStar_Syntax_Syntax.m_lid = - (m.FStar_Syntax_Syntax.mname); - FStar_Syntax_Syntax.n_lid = - (n.FStar_Syntax_Syntax.mname); - FStar_Syntax_Syntax.p_lid = - (p.FStar_Syntax_Syntax.mname); - FStar_Syntax_Syntax.tm3 = uu___4; - FStar_Syntax_Syntax.typ = ([], FStar_Syntax_Syntax.tun); - FStar_Syntax_Syntax.kind1 = - FStar_Pervasives_Native.None - } in - FStar_Syntax_Syntax.Sig_polymonadic_bind uu___3 in - let uu___3 = FStar_Syntax_DsEnv.opens_and_abbrevs env in - { - FStar_Syntax_Syntax.sigel = uu___2; - FStar_Syntax_Syntax.sigrng = (d.FStar_Parser_AST.drange); - FStar_Syntax_Syntax.sigquals = []; - FStar_Syntax_Syntax.sigmeta = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs = top_attrs; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___3; - FStar_Syntax_Syntax.sigopts = FStar_Pervasives_Native.None - } in - [uu___1] in - (env, uu___) - | FStar_Parser_AST.Polymonadic_subcomp (m_eff, n_eff, subcomp) -> - let m = lookup_effect_lid env m_eff d.FStar_Parser_AST.drange in - let n = lookup_effect_lid env n_eff d.FStar_Parser_AST.drange in - let top_attrs = d_attrs in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = desugar_term env subcomp in ([], uu___5) in - { - FStar_Syntax_Syntax.m_lid1 = - (m.FStar_Syntax_Syntax.mname); - FStar_Syntax_Syntax.n_lid1 = - (n.FStar_Syntax_Syntax.mname); - FStar_Syntax_Syntax.tm4 = uu___4; - FStar_Syntax_Syntax.typ1 = - ([], FStar_Syntax_Syntax.tun); - FStar_Syntax_Syntax.kind2 = - FStar_Pervasives_Native.None - } in - FStar_Syntax_Syntax.Sig_polymonadic_subcomp uu___3 in - let uu___3 = FStar_Syntax_DsEnv.opens_and_abbrevs env in - { - FStar_Syntax_Syntax.sigel = uu___2; - FStar_Syntax_Syntax.sigrng = (d.FStar_Parser_AST.drange); - FStar_Syntax_Syntax.sigquals = []; - FStar_Syntax_Syntax.sigmeta = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs = top_attrs; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___3; - FStar_Syntax_Syntax.sigopts = FStar_Pervasives_Native.None - } in - [uu___1] in - (env, uu___) - | FStar_Parser_AST.Splice (is_typed, ids, t) -> - let ids1 = if d.FStar_Parser_AST.interleaved then [] else ids in - let t1 = desugar_term env t in - let top_attrs = d_attrs in - let se = - let uu___ = - let uu___1 = - let uu___2 = - FStar_Compiler_List.map (FStar_Syntax_DsEnv.qualify env) - ids1 in - { - FStar_Syntax_Syntax.is_typed = is_typed; - FStar_Syntax_Syntax.lids2 = uu___2; - FStar_Syntax_Syntax.tac = t1 - } in - FStar_Syntax_Syntax.Sig_splice uu___1 in - let uu___1 = - FStar_Compiler_List.map - (trans_qual1 FStar_Pervasives_Native.None) - d.FStar_Parser_AST.quals in - let uu___2 = FStar_Syntax_DsEnv.opens_and_abbrevs env in - { - FStar_Syntax_Syntax.sigel = uu___; - FStar_Syntax_Syntax.sigrng = (d.FStar_Parser_AST.drange); - FStar_Syntax_Syntax.sigquals = uu___1; - FStar_Syntax_Syntax.sigmeta = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs = top_attrs; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___2; - FStar_Syntax_Syntax.sigopts = FStar_Pervasives_Native.None - } in - let env1 = FStar_Syntax_DsEnv.push_sigelt env se in (env1, [se]) - | FStar_Parser_AST.UseLangDecls uu___ -> (env, []) - | FStar_Parser_AST.Unparseable -> - FStar_Errors.raise_error FStar_Parser_AST.hasRange_decl d - FStar_Errors_Codes.Fatal_SyntaxError () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic "Syntax error") - | FStar_Parser_AST.DeclSyntaxExtension - (extension_name, code, uu___, range) -> - let extension_parser = - FStar_Parser_AST_Util.lookup_extension_parser extension_name in - (match extension_parser with - | FStar_Pervasives_Native.None -> - let uu___1 = - FStar_Compiler_Util.format1 "Unknown syntax extension %s" - extension_name in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range - range FStar_Errors_Codes.Fatal_SyntaxError () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) - | FStar_Pervasives_Native.Some parser -> - let opens = - let uu___1 = - FStar_Syntax_DsEnv.open_modules_and_namespaces env in - let uu___2 = FStar_Syntax_DsEnv.module_abbrevs env in - { - FStar_Parser_AST_Util.open_namespaces = uu___1; - FStar_Parser_AST_Util.module_abbreviations = uu___2 - } in - let uu___1 = - parser.FStar_Parser_AST_Util.parse_decl opens code range in - (match uu___1 with - | FStar_Pervasives.Inl error -> - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - error.FStar_Parser_AST_Util.range - FStar_Errors_Codes.Fatal_SyntaxError () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic error.FStar_Parser_AST_Util.message) - | FStar_Pervasives.Inr d' -> - let quals = - FStar_Compiler_List.op_At d'.FStar_Parser_AST.quals - d.FStar_Parser_AST.quals in - let attrs = - FStar_Compiler_List.op_At d'.FStar_Parser_AST.attrs - d.FStar_Parser_AST.attrs in - desugar_decl_maybe_fail_attr env - { - FStar_Parser_AST.d = (d'.FStar_Parser_AST.d); - FStar_Parser_AST.drange = - (d.FStar_Parser_AST.drange); - FStar_Parser_AST.quals = quals; - FStar_Parser_AST.attrs = attrs; - FStar_Parser_AST.interleaved = - (d.FStar_Parser_AST.interleaved) - })) - | FStar_Parser_AST.DeclToBeDesugared tbs -> - let uu___ = - lookup_extension_tosyntax tbs.FStar_Parser_AST.lang_name in - (match uu___ with - | FStar_Pervasives_Native.None -> - let uu___1 = - FStar_Compiler_Util.format1 - "Could not find desugaring callback for extension %s" - tbs.FStar_Parser_AST.lang_name in - FStar_Errors.raise_error FStar_Parser_AST.hasRange_decl d - FStar_Errors_Codes.Fatal_SyntaxError () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) - | FStar_Pervasives_Native.Some desugar -> - let mk_sig sigel = - let top_attrs = d_attrs in - let sigel1 = - if d.FStar_Parser_AST.interleaved - then - match sigel with - | FStar_Syntax_Syntax.Sig_splice s -> - FStar_Syntax_Syntax.Sig_splice - { - FStar_Syntax_Syntax.is_typed = - (s.FStar_Syntax_Syntax.is_typed); - FStar_Syntax_Syntax.lids2 = []; - FStar_Syntax_Syntax.tac = - (s.FStar_Syntax_Syntax.tac) - } - | uu___1 -> sigel - else sigel in - let se = - let uu___1 = - FStar_Compiler_List.map - (trans_qual1 FStar_Pervasives_Native.None) - d.FStar_Parser_AST.quals in - let uu___2 = FStar_Syntax_DsEnv.opens_and_abbrevs env in - { - FStar_Syntax_Syntax.sigel = sigel1; - FStar_Syntax_Syntax.sigrng = - (d.FStar_Parser_AST.drange); - FStar_Syntax_Syntax.sigquals = uu___1; - FStar_Syntax_Syntax.sigmeta = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs = top_attrs; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___2; - FStar_Syntax_Syntax.sigopts = - FStar_Pervasives_Native.None - } in - se in - let lids = - FStar_Compiler_List.map (FStar_Syntax_DsEnv.qualify env) - tbs.FStar_Parser_AST.idents in - let sigelts' = - desugar env tbs.FStar_Parser_AST.blob lids - d.FStar_Parser_AST.drange in - let sigelts = FStar_Compiler_List.map mk_sig sigelts' in - let env1 = - FStar_Compiler_List.fold_left - FStar_Syntax_DsEnv.push_sigelt env sigelts in - (env1, sigelts)) -let (desugar_decls : - env_t -> - FStar_Parser_AST.decl Prims.list -> - (env_t * FStar_Syntax_Syntax.sigelt Prims.list)) - = - fun env -> - fun decls -> - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun d -> - match uu___1 with - | (env1, sigelts) -> - let uu___2 = desugar_decl env1 d in - (match uu___2 with - | (env2, se) -> - (env2, (FStar_Compiler_List.op_At sigelts se)))) - (env, []) decls in - match uu___ with | (env1, sigelts) -> (env1, sigelts) -let (desugar_modul_common : - FStar_Syntax_Syntax.modul FStar_Pervasives_Native.option -> - FStar_Syntax_DsEnv.env -> - FStar_Parser_AST.modul -> - (env_t * FStar_Syntax_Syntax.modul * Prims.bool)) - = - fun curmod -> - fun env -> - fun m -> - let env1 = - match (curmod, m) with - | (FStar_Pervasives_Native.None, uu___) -> env - | (FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.name = prev_lid; - FStar_Syntax_Syntax.declarations = uu___; - FStar_Syntax_Syntax.is_interface = uu___1;_}, - FStar_Parser_AST.Module (current_lid, uu___2)) when - (FStar_Ident.lid_equals prev_lid current_lid) && - (FStar_Options.interactive ()) - -> env - | (FStar_Pervasives_Native.Some prev_mod, uu___) -> - let uu___1 = - FStar_Syntax_DsEnv.finish_module_or_interface env prev_mod in - FStar_Pervasives_Native.fst uu___1 in - let uu___ = - match m with - | FStar_Parser_AST.Interface (mname, decls, admitted) -> - let uu___1 = - FStar_Syntax_DsEnv.prepare_module_or_interface true admitted - env1 mname FStar_Syntax_DsEnv.default_mii in - (uu___1, mname, decls, true) - | FStar_Parser_AST.Module (mname, decls) -> - let uu___1 = - FStar_Syntax_DsEnv.prepare_module_or_interface false false - env1 mname FStar_Syntax_DsEnv.default_mii in - (uu___1, mname, decls, false) in - match uu___ with - | ((env2, pop_when_done), mname, decls, intf) -> - let uu___1 = desugar_decls env2 decls in - (match uu___1 with - | (env3, sigelts) -> - let modul = - { - FStar_Syntax_Syntax.name = mname; - FStar_Syntax_Syntax.declarations = sigelts; - FStar_Syntax_Syntax.is_interface = intf - } in - (env3, modul, pop_when_done)) -let (as_interface : FStar_Parser_AST.modul -> FStar_Parser_AST.modul) = - fun m -> - match m with - | FStar_Parser_AST.Module (mname, decls) -> - FStar_Parser_AST.Interface (mname, decls, true) - | i -> i -let (desugar_partial_modul : - FStar_Syntax_Syntax.modul FStar_Pervasives_Native.option -> - env_t -> FStar_Parser_AST.modul -> (env_t * FStar_Syntax_Syntax.modul)) - = - fun curmod -> - fun env -> - fun m -> - let m1 = - let uu___ = - (FStar_Options.interactive ()) && - (let uu___1 = - let uu___2 = - let uu___3 = FStar_Options.file_list () in - FStar_Compiler_List.hd uu___3 in - FStar_Compiler_Util.get_file_extension uu___2 in - FStar_Compiler_List.mem uu___1 ["fsti"; "fsi"]) in - if uu___ then as_interface m else m in - let uu___ = desugar_modul_common curmod env m1 in - match uu___ with - | (env1, modul, pop_when_done) -> - if pop_when_done - then let uu___1 = FStar_Syntax_DsEnv.pop () in (uu___1, modul) - else (env1, modul) -let (desugar_modul : - FStar_Syntax_DsEnv.env -> - FStar_Parser_AST.modul -> (env_t * FStar_Syntax_Syntax.modul)) - = - fun env -> - fun m -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Parser_AST.lid_of_modul m in - FStar_Class_Show.show FStar_Ident.showable_lident uu___2 in - Prims.strcat "While desugaring module " uu___1 in - FStar_Errors.with_ctx uu___ - (fun uu___1 -> - let uu___2 = - desugar_modul_common FStar_Pervasives_Native.None env m in - match uu___2 with - | (env1, modul, pop_when_done) -> - let uu___3 = - FStar_Syntax_DsEnv.finish_module_or_interface env1 modul in - (match uu___3 with - | (env2, modul1) -> - ((let uu___5 = - let uu___6 = - FStar_Ident.string_of_lid - modul1.FStar_Syntax_Syntax.name in - FStar_Options.dump_module uu___6 in - if uu___5 - then - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_modul modul1 in - FStar_Compiler_Util.print1 - "Module after desugaring:\n%s\n" uu___6 - else ()); - (let uu___5 = - if pop_when_done - then - FStar_Syntax_DsEnv.export_interface - modul1.FStar_Syntax_Syntax.name env2 - else env2 in - (uu___5, modul1))))) -let with_options : 'a . (unit -> 'a) -> 'a = - fun f -> - let uu___ = - FStar_Options.with_saved_options - (fun uu___1 -> - let r = f () in let light = FStar_Options.ml_ish () in (light, r)) in - match uu___ with - | (light, r) -> (if light then FStar_Options.set_ml_ish () else (); r) -let (ast_modul_to_modul : - FStar_Parser_AST.modul -> - FStar_Syntax_Syntax.modul FStar_Syntax_DsEnv.withenv) - = - fun modul -> - fun env -> - with_options - (fun uu___ -> - let uu___1 = desugar_modul env modul in - match uu___1 with | (e, m) -> (m, e)) -let (decls_to_sigelts : - FStar_Parser_AST.decl Prims.list -> - FStar_Syntax_Syntax.sigelts FStar_Syntax_DsEnv.withenv) - = - fun decls -> - fun env -> - with_options - (fun uu___ -> - let uu___1 = desugar_decls env decls in - match uu___1 with | (env1, sigelts) -> (sigelts, env1)) -let (partial_ast_modul_to_modul : - FStar_Syntax_Syntax.modul FStar_Pervasives_Native.option -> - FStar_Parser_AST.modul -> - FStar_Syntax_Syntax.modul FStar_Syntax_DsEnv.withenv) - = - fun modul -> - fun a_modul -> - fun env -> - with_options - (fun uu___ -> - let uu___1 = desugar_partial_modul modul env a_modul in - match uu___1 with | (env1, modul1) -> (modul1, env1)) -let (add_modul_to_env_core : - Prims.bool -> - FStar_Syntax_Syntax.modul -> - FStar_Syntax_DsEnv.module_inclusion_info -> - (FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) -> - unit FStar_Syntax_DsEnv.withenv) - = - fun finish -> - fun m -> - fun mii -> - fun erase_univs -> - fun en -> - let erase_univs_ed ed = - let erase_binders bs = - match bs with - | [] -> [] - | uu___ -> - let t = - let uu___1 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = bs; - FStar_Syntax_Syntax.body = - FStar_Syntax_Syntax.t_unit; - FStar_Syntax_Syntax.rc_opt = - FStar_Pervasives_Native.None - }) FStar_Compiler_Range_Type.dummyRange in - erase_univs uu___1 in - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress t in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs1; - FStar_Syntax_Syntax.body = uu___2; - FStar_Syntax_Syntax.rc_opt = uu___3;_} - -> bs1 - | uu___2 -> failwith "Impossible") in - let uu___ = - let uu___1 = erase_binders ed.FStar_Syntax_Syntax.binders in - FStar_Syntax_Subst.open_term' uu___1 - FStar_Syntax_Syntax.t_unit in - match uu___ with - | (binders, uu___1, binders_opening) -> - let erase_term t = - let uu___2 = - let uu___3 = FStar_Syntax_Subst.subst binders_opening t in - erase_univs uu___3 in - FStar_Syntax_Subst.close binders uu___2 in - let erase_tscheme uu___2 = - match uu___2 with - | (us, t) -> - let t1 = - let uu___3 = - FStar_Syntax_Subst.shift_subst - (FStar_Compiler_List.length us) binders_opening in - FStar_Syntax_Subst.subst uu___3 t in - let uu___3 = - let uu___4 = erase_univs t1 in - FStar_Syntax_Subst.close binders uu___4 in - ([], uu___3) in - let erase_action action = - let opening = - FStar_Syntax_Subst.shift_subst - (FStar_Compiler_List.length - action.FStar_Syntax_Syntax.action_univs) - binders_opening in - let erased_action_params = - match action.FStar_Syntax_Syntax.action_params with - | [] -> [] - | uu___2 -> - let bs = - let uu___3 = - FStar_Syntax_Subst.subst_binders opening - action.FStar_Syntax_Syntax.action_params in - erase_binders uu___3 in - let t = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = bs; - FStar_Syntax_Syntax.body = - FStar_Syntax_Syntax.t_unit; - FStar_Syntax_Syntax.rc_opt = - FStar_Pervasives_Native.None - }) FStar_Compiler_Range_Type.dummyRange in - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Subst.close binders t in - FStar_Syntax_Subst.compress uu___5 in - uu___4.FStar_Syntax_Syntax.n in - (match uu___3 with - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs1; - FStar_Syntax_Syntax.body = uu___4; - FStar_Syntax_Syntax.rc_opt = uu___5;_} - -> bs1 - | uu___4 -> failwith "Impossible") in - let erase_term1 t = - let uu___2 = - let uu___3 = FStar_Syntax_Subst.subst opening t in - erase_univs uu___3 in - FStar_Syntax_Subst.close binders uu___2 in - let uu___2 = - erase_term1 action.FStar_Syntax_Syntax.action_defn in - let uu___3 = - erase_term1 action.FStar_Syntax_Syntax.action_typ in - { - FStar_Syntax_Syntax.action_name = - (action.FStar_Syntax_Syntax.action_name); - FStar_Syntax_Syntax.action_unqualified_name = - (action.FStar_Syntax_Syntax.action_unqualified_name); - FStar_Syntax_Syntax.action_univs = []; - FStar_Syntax_Syntax.action_params = - erased_action_params; - FStar_Syntax_Syntax.action_defn = uu___2; - FStar_Syntax_Syntax.action_typ = uu___3 - } in - let uu___2 = FStar_Syntax_Subst.close_binders binders in - let uu___3 = - FStar_Syntax_Util.apply_eff_sig erase_tscheme - ed.FStar_Syntax_Syntax.signature in - let uu___4 = - FStar_Syntax_Util.apply_eff_combinators erase_tscheme - ed.FStar_Syntax_Syntax.combinators in - let uu___5 = - FStar_Compiler_List.map erase_action - ed.FStar_Syntax_Syntax.actions in - { - FStar_Syntax_Syntax.mname = - (ed.FStar_Syntax_Syntax.mname); - FStar_Syntax_Syntax.cattributes = - (ed.FStar_Syntax_Syntax.cattributes); - FStar_Syntax_Syntax.univs = []; - FStar_Syntax_Syntax.binders = uu___2; - FStar_Syntax_Syntax.signature = uu___3; - FStar_Syntax_Syntax.combinators = uu___4; - FStar_Syntax_Syntax.actions = uu___5; - FStar_Syntax_Syntax.eff_attrs = - (ed.FStar_Syntax_Syntax.eff_attrs); - FStar_Syntax_Syntax.extraction_mode = - (ed.FStar_Syntax_Syntax.extraction_mode) - } in - let push_sigelt env se = - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_new_effect ed -> - let se' = - let uu___ = - let uu___1 = erase_univs_ed ed in - FStar_Syntax_Syntax.Sig_new_effect uu___1 in - { - FStar_Syntax_Syntax.sigel = uu___; - FStar_Syntax_Syntax.sigrng = - (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se.FStar_Syntax_Syntax.sigopts) - } in - let env1 = FStar_Syntax_DsEnv.push_sigelt env se' in - push_reflect_effect env1 se.FStar_Syntax_Syntax.sigquals - ed.FStar_Syntax_Syntax.mname - se.FStar_Syntax_Syntax.sigrng - | uu___ -> FStar_Syntax_DsEnv.push_sigelt env se in - let uu___ = - FStar_Syntax_DsEnv.prepare_module_or_interface false false en - m.FStar_Syntax_Syntax.name mii in - match uu___ with - | (en1, pop_when_done) -> - let en2 = - let uu___1 = - FStar_Syntax_DsEnv.set_current_module en1 - m.FStar_Syntax_Syntax.name in - FStar_Compiler_List.fold_left push_sigelt uu___1 - m.FStar_Syntax_Syntax.declarations in - let en3 = - if finish then FStar_Syntax_DsEnv.finish en2 m else en2 in - let uu___1 = - if pop_when_done - then - FStar_Syntax_DsEnv.export_interface - m.FStar_Syntax_Syntax.name en3 - else en3 in - ((), uu___1) -let (add_partial_modul_to_env : - FStar_Syntax_Syntax.modul -> - FStar_Syntax_DsEnv.module_inclusion_info -> - (FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) -> - unit FStar_Syntax_DsEnv.withenv) - = add_modul_to_env_core false -let (add_modul_to_env : - FStar_Syntax_Syntax.modul -> - FStar_Syntax_DsEnv.module_inclusion_info -> - (FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) -> - unit FStar_Syntax_DsEnv.withenv) - = add_modul_to_env_core true \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Cfg.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Cfg.ml deleted file mode 100644 index d1fd27e8149..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Cfg.ml +++ /dev/null @@ -1,2718 +0,0 @@ -open Prims -type fsteps = - { - beta: Prims.bool ; - iota: Prims.bool ; - zeta: Prims.bool ; - zeta_full: Prims.bool ; - weak: Prims.bool ; - hnf: Prims.bool ; - primops: Prims.bool ; - do_not_unfold_pure_lets: Prims.bool ; - unfold_until: - FStar_Syntax_Syntax.delta_depth FStar_Pervasives_Native.option ; - unfold_only: FStar_Ident.lid Prims.list FStar_Pervasives_Native.option ; - unfold_fully: FStar_Ident.lid Prims.list FStar_Pervasives_Native.option ; - unfold_attr: FStar_Ident.lid Prims.list FStar_Pervasives_Native.option ; - unfold_qual: Prims.string Prims.list FStar_Pervasives_Native.option ; - unfold_namespace: - (Prims.string, Prims.bool) FStar_Compiler_Path.forest - FStar_Pervasives_Native.option - ; - dont_unfold_attr: FStar_Ident.lid Prims.list FStar_Pervasives_Native.option ; - pure_subterms_within_computations: Prims.bool ; - simplify: Prims.bool ; - erase_universes: Prims.bool ; - allow_unbound_universes: Prims.bool ; - reify_: Prims.bool ; - compress_uvars: Prims.bool ; - no_full_norm: Prims.bool ; - check_no_uvars: Prims.bool ; - unmeta: Prims.bool ; - unascribe: Prims.bool ; - in_full_norm_request: Prims.bool ; - weakly_reduce_scrutinee: Prims.bool ; - nbe_step: Prims.bool ; - for_extraction: Prims.bool ; - unrefine: Prims.bool ; - default_univs_to_zero: Prims.bool ; - tactics: Prims.bool } -let (__proj__Mkfsteps__item__beta : fsteps -> Prims.bool) = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> beta -let (__proj__Mkfsteps__item__iota : fsteps -> Prims.bool) = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> iota -let (__proj__Mkfsteps__item__zeta : fsteps -> Prims.bool) = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> zeta -let (__proj__Mkfsteps__item__zeta_full : fsteps -> Prims.bool) = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> zeta_full -let (__proj__Mkfsteps__item__weak : fsteps -> Prims.bool) = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> weak -let (__proj__Mkfsteps__item__hnf : fsteps -> Prims.bool) = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> hnf -let (__proj__Mkfsteps__item__primops : fsteps -> Prims.bool) = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> primops -let (__proj__Mkfsteps__item__do_not_unfold_pure_lets : fsteps -> Prims.bool) - = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> do_not_unfold_pure_lets -let (__proj__Mkfsteps__item__unfold_until : - fsteps -> FStar_Syntax_Syntax.delta_depth FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> unfold_until -let (__proj__Mkfsteps__item__unfold_only : - fsteps -> FStar_Ident.lid Prims.list FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> unfold_only -let (__proj__Mkfsteps__item__unfold_fully : - fsteps -> FStar_Ident.lid Prims.list FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> unfold_fully -let (__proj__Mkfsteps__item__unfold_attr : - fsteps -> FStar_Ident.lid Prims.list FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> unfold_attr -let (__proj__Mkfsteps__item__unfold_qual : - fsteps -> Prims.string Prims.list FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> unfold_qual -let (__proj__Mkfsteps__item__unfold_namespace : - fsteps -> - (Prims.string, Prims.bool) FStar_Compiler_Path.forest - FStar_Pervasives_Native.option) - = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> unfold_namespace -let (__proj__Mkfsteps__item__dont_unfold_attr : - fsteps -> FStar_Ident.lid Prims.list FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> dont_unfold_attr -let (__proj__Mkfsteps__item__pure_subterms_within_computations : - fsteps -> Prims.bool) = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> - pure_subterms_within_computations -let (__proj__Mkfsteps__item__simplify : fsteps -> Prims.bool) = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> simplify -let (__proj__Mkfsteps__item__erase_universes : fsteps -> Prims.bool) = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> erase_universes -let (__proj__Mkfsteps__item__allow_unbound_universes : fsteps -> Prims.bool) - = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> allow_unbound_universes -let (__proj__Mkfsteps__item__reify_ : fsteps -> Prims.bool) = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> reify_ -let (__proj__Mkfsteps__item__compress_uvars : fsteps -> Prims.bool) = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> compress_uvars -let (__proj__Mkfsteps__item__no_full_norm : fsteps -> Prims.bool) = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> no_full_norm -let (__proj__Mkfsteps__item__check_no_uvars : fsteps -> Prims.bool) = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> check_no_uvars -let (__proj__Mkfsteps__item__unmeta : fsteps -> Prims.bool) = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> unmeta -let (__proj__Mkfsteps__item__unascribe : fsteps -> Prims.bool) = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> unascribe -let (__proj__Mkfsteps__item__in_full_norm_request : fsteps -> Prims.bool) = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> in_full_norm_request -let (__proj__Mkfsteps__item__weakly_reduce_scrutinee : fsteps -> Prims.bool) - = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> weakly_reduce_scrutinee -let (__proj__Mkfsteps__item__nbe_step : fsteps -> Prims.bool) = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> nbe_step -let (__proj__Mkfsteps__item__for_extraction : fsteps -> Prims.bool) = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> for_extraction -let (__proj__Mkfsteps__item__unrefine : fsteps -> Prims.bool) = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> unrefine -let (__proj__Mkfsteps__item__default_univs_to_zero : fsteps -> Prims.bool) = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> default_univs_to_zero -let (__proj__Mkfsteps__item__tactics : fsteps -> Prims.bool) = - fun projectee -> - match projectee with - | { beta; iota; zeta; zeta_full; weak; hnf; primops; - do_not_unfold_pure_lets; unfold_until; unfold_only; unfold_fully; - unfold_attr; unfold_qual; unfold_namespace; dont_unfold_attr; - pure_subterms_within_computations; simplify; erase_universes; - allow_unbound_universes; reify_; compress_uvars; no_full_norm; - check_no_uvars; unmeta; unascribe; in_full_norm_request; - weakly_reduce_scrutinee; nbe_step; for_extraction; unrefine; - default_univs_to_zero; tactics;_} -> tactics -let (steps_to_string : fsteps -> Prims.string) = - fun f -> - let format_opt f1 o = - match o with - | FStar_Pervasives_Native.None -> "None" - | FStar_Pervasives_Native.Some x -> - let uu___ = - let uu___1 = f1 x in FStar_Compiler_String.op_Hat uu___1 ")" in - FStar_Compiler_String.op_Hat "Some (" uu___ in - let b = FStar_Compiler_Util.string_of_bool in - let uu___ = - let uu___1 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) f.beta in - let uu___2 = - let uu___3 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) f.iota in - let uu___4 = - let uu___5 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) f.zeta in - let uu___6 = - let uu___7 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) f.zeta_full in - let uu___8 = - let uu___9 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) f.weak in - let uu___10 = - let uu___11 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) f.hnf in - let uu___12 = - let uu___13 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) f.primops in - let uu___14 = - let uu___15 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - f.do_not_unfold_pure_lets in - let uu___16 = - let uu___17 = - FStar_Class_Show.show - (FStar_Class_Show.show_option - FStar_Syntax_Syntax.showable_delta_depth) - f.unfold_until in - let uu___18 = - let uu___19 = - FStar_Class_Show.show - (FStar_Class_Show.show_option - (FStar_Class_Show.show_list - FStar_Ident.showable_lident)) f.unfold_only in - let uu___20 = - let uu___21 = - FStar_Class_Show.show - (FStar_Class_Show.show_option - (FStar_Class_Show.show_list - FStar_Ident.showable_lident)) - f.unfold_fully in - let uu___22 = - let uu___23 = - FStar_Class_Show.show - (FStar_Class_Show.show_option - (FStar_Class_Show.show_list - FStar_Ident.showable_lident)) - f.unfold_attr in - let uu___24 = - let uu___25 = - FStar_Class_Show.show - (FStar_Class_Show.show_option - (FStar_Class_Show.show_list - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_string))) - f.unfold_qual in - let uu___26 = - let uu___27 = - FStar_Class_Show.show - (FStar_Class_Show.show_option - (FStar_Class_Show.show_tuple2 - (FStar_Class_Show.show_list - (FStar_Class_Show.show_tuple2 - (FStar_Class_Show.show_list - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_string)) - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool))) - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool))) - f.unfold_namespace in - let uu___28 = - let uu___29 = - FStar_Class_Show.show - (FStar_Class_Show.show_option - (FStar_Class_Show.show_list - FStar_Ident.showable_lident)) - f.dont_unfold_attr in - let uu___30 = - let uu___31 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - f.pure_subterms_within_computations in - let uu___32 = - let uu___33 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - f.simplify in - let uu___34 = - let uu___35 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - f.erase_universes in - let uu___36 = - let uu___37 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - f.allow_unbound_universes in - let uu___38 = - let uu___39 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - f.reify_ in - let uu___40 = - let uu___41 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - f.compress_uvars in - let uu___42 = - let uu___43 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - f.no_full_norm in - let uu___44 = - let uu___45 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - f.check_no_uvars in - let uu___46 = - let uu___47 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - f.unmeta in - let uu___48 = - let uu___49 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - f.unascribe in - let uu___50 = - let uu___51 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - f.in_full_norm_request in - let uu___52 = - let uu___53 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - f.weakly_reduce_scrutinee in - let uu___54 = - let uu___55 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - f.for_extraction in - let uu___56 = - let uu___57 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - f.unrefine in - let uu___58 = - let uu___59 = - FStar_Class_Show.show - ( - FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - f.default_univs_to_zero in - let uu___60 = - let uu___61 - = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - f.tactics in - [uu___61] in - uu___59 :: - uu___60 in - uu___57 :: - uu___58 in - uu___55 :: - uu___56 in - uu___53 :: uu___54 in - uu___51 :: uu___52 in - uu___49 :: uu___50 in - uu___47 :: uu___48 in - uu___45 :: uu___46 in - uu___43 :: uu___44 in - uu___41 :: uu___42 in - uu___39 :: uu___40 in - uu___37 :: uu___38 in - uu___35 :: uu___36 in - uu___33 :: uu___34 in - uu___31 :: uu___32 in - uu___29 :: uu___30 in - uu___27 :: uu___28 in - uu___25 :: uu___26 in - uu___23 :: uu___24 in - uu___21 :: uu___22 in - uu___19 :: uu___20 in - uu___17 :: uu___18 in - uu___15 :: uu___16 in - uu___13 :: uu___14 in - uu___11 :: uu___12 in - uu___9 :: uu___10 in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Compiler_Util.format - "{\nbeta = %s;\niota = %s;\nzeta = %s;\nzeta_full = %s;\nweak = %s;\nhnf = %s;\nprimops = %s;\ndo_not_unfold_pure_lets = %s;\nunfold_until = %s;\nunfold_only = %s;\nunfold_fully = %s;\nunfold_attr = %s;\nunfold_qual = %s;\nunfold_namespace = %s;\ndont_unfold_attr = %s;\npure_subterms_within_computations = %s;\nsimplify = %s;\nerase_universes = %s;\nallow_unbound_universes = %s;\nreify_ = %s;\ncompress_uvars = %s;\nno_full_norm = %s;\ncheck_no_uvars = %s;\nunmeta = %s;\nunascribe = %s;\nin_full_norm_request = %s;\nweakly_reduce_scrutinee = %s;\nfor_extraction = %s;\nunrefine = %s;\ndefault_univs_to_zero = %s;\ntactics = %s;\n}" - uu___ -let (deq_fsteps : fsteps FStar_Class_Deq.deq) = - { - FStar_Class_Deq.op_Equals_Question = - (fun f1 -> - fun f2 -> - (((((((((((((((((((((((((((((((FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq - FStar_Class_Ord.ord_bool) - f1.beta f2.beta) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq - FStar_Class_Ord.ord_bool) - f1.iota f2.iota)) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq - FStar_Class_Ord.ord_bool) - f1.zeta f2.zeta)) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq - FStar_Class_Ord.ord_bool) - f1.zeta_full f2.zeta_full)) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq - FStar_Class_Ord.ord_bool) - f1.weak f2.weak)) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq - FStar_Class_Ord.ord_bool) - f1.hnf f2.hnf)) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq - FStar_Class_Ord.ord_bool) - f1.primops f2.primops)) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq - FStar_Class_Ord.ord_bool) - f1.do_not_unfold_pure_lets - f2.do_not_unfold_pure_lets)) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Deq.deq_option - FStar_Syntax_Syntax.deq_delta_depth) - f1.unfold_until f2.unfold_until)) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq - (FStar_Class_Ord.ord_option - (FStar_Class_Ord.ord_list - FStar_Syntax_Syntax.ord_fv))) - f1.unfold_only f2.unfold_only)) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq - (FStar_Class_Ord.ord_option - (FStar_Class_Ord.ord_list - FStar_Syntax_Syntax.ord_fv))) - f1.unfold_fully f2.unfold_fully)) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq - (FStar_Class_Ord.ord_option - (FStar_Class_Ord.ord_list - FStar_Syntax_Syntax.ord_fv))) - f1.unfold_attr f2.unfold_attr)) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq - (FStar_Class_Ord.ord_option - (FStar_Class_Ord.ord_list - FStar_Class_Ord.ord_string))) - f1.unfold_qual f2.unfold_qual)) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq - (FStar_Class_Ord.ord_option - (FStar_Class_Ord.ord_tuple2 - (FStar_Class_Ord.ord_list - (FStar_Class_Ord.ord_tuple2 - (FStar_Class_Ord.ord_list - FStar_Class_Ord.ord_string) - FStar_Class_Ord.ord_bool)) - FStar_Class_Ord.ord_bool))) - f1.unfold_namespace f2.unfold_namespace)) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq - (FStar_Class_Ord.ord_option - (FStar_Class_Ord.ord_list - FStar_Syntax_Syntax.ord_fv))) - f1.dont_unfold_attr f2.dont_unfold_attr)) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq - FStar_Class_Ord.ord_bool) - f1.pure_subterms_within_computations - f2.pure_subterms_within_computations)) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq - FStar_Class_Ord.ord_bool) f1.simplify - f2.simplify)) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq - FStar_Class_Ord.ord_bool) f1.erase_universes - f2.erase_universes)) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq FStar_Class_Ord.ord_bool) - f1.allow_unbound_universes - f2.allow_unbound_universes)) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq FStar_Class_Ord.ord_bool) - f1.reify_ f2.reify_)) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq FStar_Class_Ord.ord_bool) - f1.compress_uvars f2.compress_uvars)) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq FStar_Class_Ord.ord_bool) - f1.no_full_norm f2.no_full_norm)) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq FStar_Class_Ord.ord_bool) - f1.check_no_uvars f2.check_no_uvars)) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq FStar_Class_Ord.ord_bool) - f1.unmeta f2.unmeta)) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq FStar_Class_Ord.ord_bool) - f1.unascribe f2.unascribe)) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq FStar_Class_Ord.ord_bool) - f1.in_full_norm_request f2.in_full_norm_request)) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq FStar_Class_Ord.ord_bool) - f1.weakly_reduce_scrutinee f2.weakly_reduce_scrutinee)) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq FStar_Class_Ord.ord_bool) - f1.nbe_step f2.nbe_step)) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq FStar_Class_Ord.ord_bool) - f1.for_extraction f2.for_extraction)) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq FStar_Class_Ord.ord_bool) - f1.unrefine f2.unrefine)) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq FStar_Class_Ord.ord_bool) - f1.default_univs_to_zero f2.default_univs_to_zero)) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq FStar_Class_Ord.ord_bool) f1.tactics - f2.tactics)) - } -let (default_steps : fsteps) = - { - beta = true; - iota = true; - zeta = true; - zeta_full = false; - weak = false; - hnf = false; - primops = false; - do_not_unfold_pure_lets = false; - unfold_until = FStar_Pervasives_Native.None; - unfold_only = FStar_Pervasives_Native.None; - unfold_fully = FStar_Pervasives_Native.None; - unfold_attr = FStar_Pervasives_Native.None; - unfold_qual = FStar_Pervasives_Native.None; - unfold_namespace = FStar_Pervasives_Native.None; - dont_unfold_attr = FStar_Pervasives_Native.None; - pure_subterms_within_computations = false; - simplify = false; - erase_universes = false; - allow_unbound_universes = false; - reify_ = false; - compress_uvars = false; - no_full_norm = false; - check_no_uvars = false; - unmeta = false; - unascribe = false; - in_full_norm_request = false; - weakly_reduce_scrutinee = true; - nbe_step = false; - for_extraction = false; - unrefine = false; - default_univs_to_zero = false; - tactics = false - } -let (fstep_add_one : FStar_TypeChecker_Env.step -> fsteps -> fsteps) = - fun s -> - fun fs -> - match s with - | FStar_TypeChecker_Env.Beta -> - { - beta = true; - iota = (fs.iota); - zeta = (fs.zeta); - zeta_full = (fs.zeta_full); - weak = (fs.weak); - hnf = (fs.hnf); - primops = (fs.primops); - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (fs.unfold_until); - unfold_only = (fs.unfold_only); - unfold_fully = (fs.unfold_fully); - unfold_attr = (fs.unfold_attr); - unfold_qual = (fs.unfold_qual); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = (fs.simplify); - erase_universes = (fs.erase_universes); - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = (fs.reify_); - compress_uvars = (fs.compress_uvars); - no_full_norm = (fs.no_full_norm); - check_no_uvars = (fs.check_no_uvars); - unmeta = (fs.unmeta); - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = (fs.for_extraction); - unrefine = (fs.unrefine); - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = (fs.tactics) - } - | FStar_TypeChecker_Env.Iota -> - { - beta = (fs.beta); - iota = true; - zeta = (fs.zeta); - zeta_full = (fs.zeta_full); - weak = (fs.weak); - hnf = (fs.hnf); - primops = (fs.primops); - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (fs.unfold_until); - unfold_only = (fs.unfold_only); - unfold_fully = (fs.unfold_fully); - unfold_attr = (fs.unfold_attr); - unfold_qual = (fs.unfold_qual); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = (fs.simplify); - erase_universes = (fs.erase_universes); - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = (fs.reify_); - compress_uvars = (fs.compress_uvars); - no_full_norm = (fs.no_full_norm); - check_no_uvars = (fs.check_no_uvars); - unmeta = (fs.unmeta); - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = (fs.for_extraction); - unrefine = (fs.unrefine); - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = (fs.tactics) - } - | FStar_TypeChecker_Env.Zeta -> - { - beta = (fs.beta); - iota = (fs.iota); - zeta = true; - zeta_full = (fs.zeta_full); - weak = (fs.weak); - hnf = (fs.hnf); - primops = (fs.primops); - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (fs.unfold_until); - unfold_only = (fs.unfold_only); - unfold_fully = (fs.unfold_fully); - unfold_attr = (fs.unfold_attr); - unfold_qual = (fs.unfold_qual); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = (fs.simplify); - erase_universes = (fs.erase_universes); - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = (fs.reify_); - compress_uvars = (fs.compress_uvars); - no_full_norm = (fs.no_full_norm); - check_no_uvars = (fs.check_no_uvars); - unmeta = (fs.unmeta); - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = (fs.for_extraction); - unrefine = (fs.unrefine); - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = (fs.tactics) - } - | FStar_TypeChecker_Env.ZetaFull -> - { - beta = (fs.beta); - iota = (fs.iota); - zeta = (fs.zeta); - zeta_full = true; - weak = (fs.weak); - hnf = (fs.hnf); - primops = (fs.primops); - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (fs.unfold_until); - unfold_only = (fs.unfold_only); - unfold_fully = (fs.unfold_fully); - unfold_attr = (fs.unfold_attr); - unfold_qual = (fs.unfold_qual); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = (fs.simplify); - erase_universes = (fs.erase_universes); - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = (fs.reify_); - compress_uvars = (fs.compress_uvars); - no_full_norm = (fs.no_full_norm); - check_no_uvars = (fs.check_no_uvars); - unmeta = (fs.unmeta); - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = (fs.for_extraction); - unrefine = (fs.unrefine); - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = (fs.tactics) - } - | FStar_TypeChecker_Env.Exclude (FStar_TypeChecker_Env.Beta) -> - { - beta = false; - iota = (fs.iota); - zeta = (fs.zeta); - zeta_full = (fs.zeta_full); - weak = (fs.weak); - hnf = (fs.hnf); - primops = (fs.primops); - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (fs.unfold_until); - unfold_only = (fs.unfold_only); - unfold_fully = (fs.unfold_fully); - unfold_attr = (fs.unfold_attr); - unfold_qual = (fs.unfold_qual); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = (fs.simplify); - erase_universes = (fs.erase_universes); - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = (fs.reify_); - compress_uvars = (fs.compress_uvars); - no_full_norm = (fs.no_full_norm); - check_no_uvars = (fs.check_no_uvars); - unmeta = (fs.unmeta); - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = (fs.for_extraction); - unrefine = (fs.unrefine); - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = (fs.tactics) - } - | FStar_TypeChecker_Env.Exclude (FStar_TypeChecker_Env.Iota) -> - { - beta = (fs.beta); - iota = false; - zeta = (fs.zeta); - zeta_full = (fs.zeta_full); - weak = (fs.weak); - hnf = (fs.hnf); - primops = (fs.primops); - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (fs.unfold_until); - unfold_only = (fs.unfold_only); - unfold_fully = (fs.unfold_fully); - unfold_attr = (fs.unfold_attr); - unfold_qual = (fs.unfold_qual); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = (fs.simplify); - erase_universes = (fs.erase_universes); - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = (fs.reify_); - compress_uvars = (fs.compress_uvars); - no_full_norm = (fs.no_full_norm); - check_no_uvars = (fs.check_no_uvars); - unmeta = (fs.unmeta); - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = (fs.for_extraction); - unrefine = (fs.unrefine); - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = (fs.tactics) - } - | FStar_TypeChecker_Env.Exclude (FStar_TypeChecker_Env.Zeta) -> - { - beta = (fs.beta); - iota = (fs.iota); - zeta = false; - zeta_full = (fs.zeta_full); - weak = (fs.weak); - hnf = (fs.hnf); - primops = (fs.primops); - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (fs.unfold_until); - unfold_only = (fs.unfold_only); - unfold_fully = (fs.unfold_fully); - unfold_attr = (fs.unfold_attr); - unfold_qual = (fs.unfold_qual); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = (fs.simplify); - erase_universes = (fs.erase_universes); - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = (fs.reify_); - compress_uvars = (fs.compress_uvars); - no_full_norm = (fs.no_full_norm); - check_no_uvars = (fs.check_no_uvars); - unmeta = (fs.unmeta); - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = (fs.for_extraction); - unrefine = (fs.unrefine); - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = (fs.tactics) - } - | FStar_TypeChecker_Env.Exclude uu___ -> failwith "Bad exclude" - | FStar_TypeChecker_Env.Weak -> - { - beta = (fs.beta); - iota = (fs.iota); - zeta = (fs.zeta); - zeta_full = (fs.zeta_full); - weak = true; - hnf = (fs.hnf); - primops = (fs.primops); - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (fs.unfold_until); - unfold_only = (fs.unfold_only); - unfold_fully = (fs.unfold_fully); - unfold_attr = (fs.unfold_attr); - unfold_qual = (fs.unfold_qual); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = (fs.simplify); - erase_universes = (fs.erase_universes); - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = (fs.reify_); - compress_uvars = (fs.compress_uvars); - no_full_norm = (fs.no_full_norm); - check_no_uvars = (fs.check_no_uvars); - unmeta = (fs.unmeta); - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = (fs.for_extraction); - unrefine = (fs.unrefine); - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = (fs.tactics) - } - | FStar_TypeChecker_Env.HNF -> - { - beta = (fs.beta); - iota = (fs.iota); - zeta = (fs.zeta); - zeta_full = (fs.zeta_full); - weak = (fs.weak); - hnf = true; - primops = (fs.primops); - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (fs.unfold_until); - unfold_only = (fs.unfold_only); - unfold_fully = (fs.unfold_fully); - unfold_attr = (fs.unfold_attr); - unfold_qual = (fs.unfold_qual); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = (fs.simplify); - erase_universes = (fs.erase_universes); - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = (fs.reify_); - compress_uvars = (fs.compress_uvars); - no_full_norm = (fs.no_full_norm); - check_no_uvars = (fs.check_no_uvars); - unmeta = (fs.unmeta); - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = (fs.for_extraction); - unrefine = (fs.unrefine); - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = (fs.tactics) - } - | FStar_TypeChecker_Env.Primops -> - { - beta = (fs.beta); - iota = (fs.iota); - zeta = (fs.zeta); - zeta_full = (fs.zeta_full); - weak = (fs.weak); - hnf = (fs.hnf); - primops = true; - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (fs.unfold_until); - unfold_only = (fs.unfold_only); - unfold_fully = (fs.unfold_fully); - unfold_attr = (fs.unfold_attr); - unfold_qual = (fs.unfold_qual); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = (fs.simplify); - erase_universes = (fs.erase_universes); - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = (fs.reify_); - compress_uvars = (fs.compress_uvars); - no_full_norm = (fs.no_full_norm); - check_no_uvars = (fs.check_no_uvars); - unmeta = (fs.unmeta); - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = (fs.for_extraction); - unrefine = (fs.unrefine); - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = (fs.tactics) - } - | FStar_TypeChecker_Env.Eager_unfolding -> fs - | FStar_TypeChecker_Env.Inlining -> fs - | FStar_TypeChecker_Env.DoNotUnfoldPureLets -> - { - beta = (fs.beta); - iota = (fs.iota); - zeta = (fs.zeta); - zeta_full = (fs.zeta_full); - weak = (fs.weak); - hnf = (fs.hnf); - primops = (fs.primops); - do_not_unfold_pure_lets = true; - unfold_until = (fs.unfold_until); - unfold_only = (fs.unfold_only); - unfold_fully = (fs.unfold_fully); - unfold_attr = (fs.unfold_attr); - unfold_qual = (fs.unfold_qual); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = (fs.simplify); - erase_universes = (fs.erase_universes); - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = (fs.reify_); - compress_uvars = (fs.compress_uvars); - no_full_norm = (fs.no_full_norm); - check_no_uvars = (fs.check_no_uvars); - unmeta = (fs.unmeta); - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = (fs.for_extraction); - unrefine = (fs.unrefine); - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = (fs.tactics) - } - | FStar_TypeChecker_Env.UnfoldUntil d -> - { - beta = (fs.beta); - iota = (fs.iota); - zeta = (fs.zeta); - zeta_full = (fs.zeta_full); - weak = (fs.weak); - hnf = (fs.hnf); - primops = (fs.primops); - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (FStar_Pervasives_Native.Some d); - unfold_only = (fs.unfold_only); - unfold_fully = (fs.unfold_fully); - unfold_attr = (fs.unfold_attr); - unfold_qual = (fs.unfold_qual); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = (fs.simplify); - erase_universes = (fs.erase_universes); - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = (fs.reify_); - compress_uvars = (fs.compress_uvars); - no_full_norm = (fs.no_full_norm); - check_no_uvars = (fs.check_no_uvars); - unmeta = (fs.unmeta); - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = (fs.for_extraction); - unrefine = (fs.unrefine); - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = (fs.tactics) - } - | FStar_TypeChecker_Env.UnfoldOnly lids -> - { - beta = (fs.beta); - iota = (fs.iota); - zeta = (fs.zeta); - zeta_full = (fs.zeta_full); - weak = (fs.weak); - hnf = (fs.hnf); - primops = (fs.primops); - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (fs.unfold_until); - unfold_only = (FStar_Pervasives_Native.Some lids); - unfold_fully = (fs.unfold_fully); - unfold_attr = (fs.unfold_attr); - unfold_qual = (fs.unfold_qual); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = (fs.simplify); - erase_universes = (fs.erase_universes); - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = (fs.reify_); - compress_uvars = (fs.compress_uvars); - no_full_norm = (fs.no_full_norm); - check_no_uvars = (fs.check_no_uvars); - unmeta = (fs.unmeta); - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = (fs.for_extraction); - unrefine = (fs.unrefine); - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = (fs.tactics) - } - | FStar_TypeChecker_Env.UnfoldFully lids -> - { - beta = (fs.beta); - iota = (fs.iota); - zeta = (fs.zeta); - zeta_full = (fs.zeta_full); - weak = (fs.weak); - hnf = (fs.hnf); - primops = (fs.primops); - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (fs.unfold_until); - unfold_only = (fs.unfold_only); - unfold_fully = (FStar_Pervasives_Native.Some lids); - unfold_attr = (fs.unfold_attr); - unfold_qual = (fs.unfold_qual); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = (fs.simplify); - erase_universes = (fs.erase_universes); - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = (fs.reify_); - compress_uvars = (fs.compress_uvars); - no_full_norm = (fs.no_full_norm); - check_no_uvars = (fs.check_no_uvars); - unmeta = (fs.unmeta); - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = (fs.for_extraction); - unrefine = (fs.unrefine); - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = (fs.tactics) - } - | FStar_TypeChecker_Env.UnfoldAttr lids -> - { - beta = (fs.beta); - iota = (fs.iota); - zeta = (fs.zeta); - zeta_full = (fs.zeta_full); - weak = (fs.weak); - hnf = (fs.hnf); - primops = (fs.primops); - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (fs.unfold_until); - unfold_only = (fs.unfold_only); - unfold_fully = (fs.unfold_fully); - unfold_attr = (FStar_Pervasives_Native.Some lids); - unfold_qual = (fs.unfold_qual); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = (fs.simplify); - erase_universes = (fs.erase_universes); - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = (fs.reify_); - compress_uvars = (fs.compress_uvars); - no_full_norm = (fs.no_full_norm); - check_no_uvars = (fs.check_no_uvars); - unmeta = (fs.unmeta); - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = (fs.for_extraction); - unrefine = (fs.unrefine); - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = (fs.tactics) - } - | FStar_TypeChecker_Env.UnfoldQual strs -> - let fs1 = - { - beta = (fs.beta); - iota = (fs.iota); - zeta = (fs.zeta); - zeta_full = (fs.zeta_full); - weak = (fs.weak); - hnf = (fs.hnf); - primops = (fs.primops); - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (fs.unfold_until); - unfold_only = (fs.unfold_only); - unfold_fully = (fs.unfold_fully); - unfold_attr = (fs.unfold_attr); - unfold_qual = (FStar_Pervasives_Native.Some strs); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = (fs.simplify); - erase_universes = (fs.erase_universes); - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = (fs.reify_); - compress_uvars = (fs.compress_uvars); - no_full_norm = (fs.no_full_norm); - check_no_uvars = (fs.check_no_uvars); - unmeta = (fs.unmeta); - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = (fs.for_extraction); - unrefine = (fs.unrefine); - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = (fs.tactics) - } in - if - FStar_Compiler_List.contains "pure_subterms_within_computations" - strs - then - { - beta = (fs1.beta); - iota = (fs1.iota); - zeta = (fs1.zeta); - zeta_full = (fs1.zeta_full); - weak = (fs1.weak); - hnf = (fs1.hnf); - primops = (fs1.primops); - do_not_unfold_pure_lets = (fs1.do_not_unfold_pure_lets); - unfold_until = (fs1.unfold_until); - unfold_only = (fs1.unfold_only); - unfold_fully = (fs1.unfold_fully); - unfold_attr = (fs1.unfold_attr); - unfold_qual = (fs1.unfold_qual); - unfold_namespace = (fs1.unfold_namespace); - dont_unfold_attr = (fs1.dont_unfold_attr); - pure_subterms_within_computations = true; - simplify = (fs1.simplify); - erase_universes = (fs1.erase_universes); - allow_unbound_universes = (fs1.allow_unbound_universes); - reify_ = (fs1.reify_); - compress_uvars = (fs1.compress_uvars); - no_full_norm = (fs1.no_full_norm); - check_no_uvars = (fs1.check_no_uvars); - unmeta = (fs1.unmeta); - unascribe = (fs1.unascribe); - in_full_norm_request = (fs1.in_full_norm_request); - weakly_reduce_scrutinee = (fs1.weakly_reduce_scrutinee); - nbe_step = (fs1.nbe_step); - for_extraction = (fs1.for_extraction); - unrefine = (fs1.unrefine); - default_univs_to_zero = (fs1.default_univs_to_zero); - tactics = (fs1.tactics) - } - else fs1 - | FStar_TypeChecker_Env.UnfoldNamespace strs -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Compiler_List.map - (fun s1 -> - let uu___3 = FStar_Ident.path_of_text s1 in - (uu___3, true)) strs in - (uu___2, false) in - FStar_Pervasives_Native.Some uu___1 in - { - beta = (fs.beta); - iota = (fs.iota); - zeta = (fs.zeta); - zeta_full = (fs.zeta_full); - weak = (fs.weak); - hnf = (fs.hnf); - primops = (fs.primops); - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (fs.unfold_until); - unfold_only = (fs.unfold_only); - unfold_fully = (fs.unfold_fully); - unfold_attr = (fs.unfold_attr); - unfold_qual = (fs.unfold_qual); - unfold_namespace = uu___; - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = (fs.simplify); - erase_universes = (fs.erase_universes); - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = (fs.reify_); - compress_uvars = (fs.compress_uvars); - no_full_norm = (fs.no_full_norm); - check_no_uvars = (fs.check_no_uvars); - unmeta = (fs.unmeta); - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = (fs.for_extraction); - unrefine = (fs.unrefine); - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = (fs.tactics) - } - | FStar_TypeChecker_Env.DontUnfoldAttr lids -> - { - beta = (fs.beta); - iota = (fs.iota); - zeta = (fs.zeta); - zeta_full = (fs.zeta_full); - weak = (fs.weak); - hnf = (fs.hnf); - primops = (fs.primops); - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (fs.unfold_until); - unfold_only = (fs.unfold_only); - unfold_fully = (fs.unfold_fully); - unfold_attr = (fs.unfold_attr); - unfold_qual = (fs.unfold_qual); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (FStar_Pervasives_Native.Some lids); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = (fs.simplify); - erase_universes = (fs.erase_universes); - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = (fs.reify_); - compress_uvars = (fs.compress_uvars); - no_full_norm = (fs.no_full_norm); - check_no_uvars = (fs.check_no_uvars); - unmeta = (fs.unmeta); - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = (fs.for_extraction); - unrefine = (fs.unrefine); - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = (fs.tactics) - } - | FStar_TypeChecker_Env.PureSubtermsWithinComputations -> - { - beta = (fs.beta); - iota = (fs.iota); - zeta = (fs.zeta); - zeta_full = (fs.zeta_full); - weak = (fs.weak); - hnf = (fs.hnf); - primops = (fs.primops); - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (fs.unfold_until); - unfold_only = (fs.unfold_only); - unfold_fully = (fs.unfold_fully); - unfold_attr = (fs.unfold_attr); - unfold_qual = (fs.unfold_qual); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = true; - simplify = (fs.simplify); - erase_universes = (fs.erase_universes); - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = (fs.reify_); - compress_uvars = (fs.compress_uvars); - no_full_norm = (fs.no_full_norm); - check_no_uvars = (fs.check_no_uvars); - unmeta = (fs.unmeta); - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = (fs.for_extraction); - unrefine = (fs.unrefine); - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = (fs.tactics) - } - | FStar_TypeChecker_Env.Simplify -> - { - beta = (fs.beta); - iota = (fs.iota); - zeta = (fs.zeta); - zeta_full = (fs.zeta_full); - weak = (fs.weak); - hnf = (fs.hnf); - primops = (fs.primops); - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (fs.unfold_until); - unfold_only = (fs.unfold_only); - unfold_fully = (fs.unfold_fully); - unfold_attr = (fs.unfold_attr); - unfold_qual = (fs.unfold_qual); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = true; - erase_universes = (fs.erase_universes); - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = (fs.reify_); - compress_uvars = (fs.compress_uvars); - no_full_norm = (fs.no_full_norm); - check_no_uvars = (fs.check_no_uvars); - unmeta = (fs.unmeta); - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = (fs.for_extraction); - unrefine = (fs.unrefine); - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = (fs.tactics) - } - | FStar_TypeChecker_Env.EraseUniverses -> - { - beta = (fs.beta); - iota = (fs.iota); - zeta = (fs.zeta); - zeta_full = (fs.zeta_full); - weak = (fs.weak); - hnf = (fs.hnf); - primops = (fs.primops); - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (fs.unfold_until); - unfold_only = (fs.unfold_only); - unfold_fully = (fs.unfold_fully); - unfold_attr = (fs.unfold_attr); - unfold_qual = (fs.unfold_qual); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = (fs.simplify); - erase_universes = true; - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = (fs.reify_); - compress_uvars = (fs.compress_uvars); - no_full_norm = (fs.no_full_norm); - check_no_uvars = (fs.check_no_uvars); - unmeta = (fs.unmeta); - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = (fs.for_extraction); - unrefine = (fs.unrefine); - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = (fs.tactics) - } - | FStar_TypeChecker_Env.AllowUnboundUniverses -> - { - beta = (fs.beta); - iota = (fs.iota); - zeta = (fs.zeta); - zeta_full = (fs.zeta_full); - weak = (fs.weak); - hnf = (fs.hnf); - primops = (fs.primops); - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (fs.unfold_until); - unfold_only = (fs.unfold_only); - unfold_fully = (fs.unfold_fully); - unfold_attr = (fs.unfold_attr); - unfold_qual = (fs.unfold_qual); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = (fs.simplify); - erase_universes = (fs.erase_universes); - allow_unbound_universes = true; - reify_ = (fs.reify_); - compress_uvars = (fs.compress_uvars); - no_full_norm = (fs.no_full_norm); - check_no_uvars = (fs.check_no_uvars); - unmeta = (fs.unmeta); - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = (fs.for_extraction); - unrefine = (fs.unrefine); - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = (fs.tactics) - } - | FStar_TypeChecker_Env.Reify -> - { - beta = (fs.beta); - iota = (fs.iota); - zeta = (fs.zeta); - zeta_full = (fs.zeta_full); - weak = (fs.weak); - hnf = (fs.hnf); - primops = (fs.primops); - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (fs.unfold_until); - unfold_only = (fs.unfold_only); - unfold_fully = (fs.unfold_fully); - unfold_attr = (fs.unfold_attr); - unfold_qual = (fs.unfold_qual); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = (fs.simplify); - erase_universes = (fs.erase_universes); - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = true; - compress_uvars = (fs.compress_uvars); - no_full_norm = (fs.no_full_norm); - check_no_uvars = (fs.check_no_uvars); - unmeta = (fs.unmeta); - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = (fs.for_extraction); - unrefine = (fs.unrefine); - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = (fs.tactics) - } - | FStar_TypeChecker_Env.CompressUvars -> - { - beta = (fs.beta); - iota = (fs.iota); - zeta = (fs.zeta); - zeta_full = (fs.zeta_full); - weak = (fs.weak); - hnf = (fs.hnf); - primops = (fs.primops); - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (fs.unfold_until); - unfold_only = (fs.unfold_only); - unfold_fully = (fs.unfold_fully); - unfold_attr = (fs.unfold_attr); - unfold_qual = (fs.unfold_qual); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = (fs.simplify); - erase_universes = (fs.erase_universes); - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = (fs.reify_); - compress_uvars = true; - no_full_norm = (fs.no_full_norm); - check_no_uvars = (fs.check_no_uvars); - unmeta = (fs.unmeta); - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = (fs.for_extraction); - unrefine = (fs.unrefine); - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = (fs.tactics) - } - | FStar_TypeChecker_Env.NoFullNorm -> - { - beta = (fs.beta); - iota = (fs.iota); - zeta = (fs.zeta); - zeta_full = (fs.zeta_full); - weak = (fs.weak); - hnf = (fs.hnf); - primops = (fs.primops); - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (fs.unfold_until); - unfold_only = (fs.unfold_only); - unfold_fully = (fs.unfold_fully); - unfold_attr = (fs.unfold_attr); - unfold_qual = (fs.unfold_qual); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = (fs.simplify); - erase_universes = (fs.erase_universes); - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = (fs.reify_); - compress_uvars = (fs.compress_uvars); - no_full_norm = true; - check_no_uvars = (fs.check_no_uvars); - unmeta = (fs.unmeta); - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = (fs.for_extraction); - unrefine = (fs.unrefine); - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = (fs.tactics) - } - | FStar_TypeChecker_Env.CheckNoUvars -> - { - beta = (fs.beta); - iota = (fs.iota); - zeta = (fs.zeta); - zeta_full = (fs.zeta_full); - weak = (fs.weak); - hnf = (fs.hnf); - primops = (fs.primops); - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (fs.unfold_until); - unfold_only = (fs.unfold_only); - unfold_fully = (fs.unfold_fully); - unfold_attr = (fs.unfold_attr); - unfold_qual = (fs.unfold_qual); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = (fs.simplify); - erase_universes = (fs.erase_universes); - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = (fs.reify_); - compress_uvars = (fs.compress_uvars); - no_full_norm = (fs.no_full_norm); - check_no_uvars = true; - unmeta = (fs.unmeta); - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = (fs.for_extraction); - unrefine = (fs.unrefine); - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = (fs.tactics) - } - | FStar_TypeChecker_Env.Unmeta -> - { - beta = (fs.beta); - iota = (fs.iota); - zeta = (fs.zeta); - zeta_full = (fs.zeta_full); - weak = (fs.weak); - hnf = (fs.hnf); - primops = (fs.primops); - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (fs.unfold_until); - unfold_only = (fs.unfold_only); - unfold_fully = (fs.unfold_fully); - unfold_attr = (fs.unfold_attr); - unfold_qual = (fs.unfold_qual); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = (fs.simplify); - erase_universes = (fs.erase_universes); - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = (fs.reify_); - compress_uvars = (fs.compress_uvars); - no_full_norm = (fs.no_full_norm); - check_no_uvars = (fs.check_no_uvars); - unmeta = true; - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = (fs.for_extraction); - unrefine = (fs.unrefine); - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = (fs.tactics) - } - | FStar_TypeChecker_Env.Unascribe -> - { - beta = (fs.beta); - iota = (fs.iota); - zeta = (fs.zeta); - zeta_full = (fs.zeta_full); - weak = (fs.weak); - hnf = (fs.hnf); - primops = (fs.primops); - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (fs.unfold_until); - unfold_only = (fs.unfold_only); - unfold_fully = (fs.unfold_fully); - unfold_attr = (fs.unfold_attr); - unfold_qual = (fs.unfold_qual); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = (fs.simplify); - erase_universes = (fs.erase_universes); - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = (fs.reify_); - compress_uvars = (fs.compress_uvars); - no_full_norm = (fs.no_full_norm); - check_no_uvars = (fs.check_no_uvars); - unmeta = (fs.unmeta); - unascribe = true; - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = (fs.for_extraction); - unrefine = (fs.unrefine); - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = (fs.tactics) - } - | FStar_TypeChecker_Env.NBE -> - { - beta = (fs.beta); - iota = (fs.iota); - zeta = (fs.zeta); - zeta_full = (fs.zeta_full); - weak = (fs.weak); - hnf = (fs.hnf); - primops = (fs.primops); - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (fs.unfold_until); - unfold_only = (fs.unfold_only); - unfold_fully = (fs.unfold_fully); - unfold_attr = (fs.unfold_attr); - unfold_qual = (fs.unfold_qual); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = (fs.simplify); - erase_universes = (fs.erase_universes); - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = (fs.reify_); - compress_uvars = (fs.compress_uvars); - no_full_norm = (fs.no_full_norm); - check_no_uvars = (fs.check_no_uvars); - unmeta = (fs.unmeta); - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = true; - for_extraction = (fs.for_extraction); - unrefine = (fs.unrefine); - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = (fs.tactics) - } - | FStar_TypeChecker_Env.ForExtraction -> - { - beta = (fs.beta); - iota = (fs.iota); - zeta = (fs.zeta); - zeta_full = (fs.zeta_full); - weak = (fs.weak); - hnf = (fs.hnf); - primops = (fs.primops); - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (fs.unfold_until); - unfold_only = (fs.unfold_only); - unfold_fully = (fs.unfold_fully); - unfold_attr = (fs.unfold_attr); - unfold_qual = (fs.unfold_qual); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = (fs.simplify); - erase_universes = (fs.erase_universes); - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = (fs.reify_); - compress_uvars = (fs.compress_uvars); - no_full_norm = (fs.no_full_norm); - check_no_uvars = (fs.check_no_uvars); - unmeta = (fs.unmeta); - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = true; - unrefine = (fs.unrefine); - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = (fs.tactics) - } - | FStar_TypeChecker_Env.Unrefine -> - { - beta = (fs.beta); - iota = (fs.iota); - zeta = (fs.zeta); - zeta_full = (fs.zeta_full); - weak = (fs.weak); - hnf = (fs.hnf); - primops = (fs.primops); - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (fs.unfold_until); - unfold_only = (fs.unfold_only); - unfold_fully = (fs.unfold_fully); - unfold_attr = (fs.unfold_attr); - unfold_qual = (fs.unfold_qual); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = (fs.simplify); - erase_universes = (fs.erase_universes); - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = (fs.reify_); - compress_uvars = (fs.compress_uvars); - no_full_norm = (fs.no_full_norm); - check_no_uvars = (fs.check_no_uvars); - unmeta = (fs.unmeta); - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = (fs.for_extraction); - unrefine = true; - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = (fs.tactics) - } - | FStar_TypeChecker_Env.NormDebug -> fs - | FStar_TypeChecker_Env.DefaultUnivsToZero -> - { - beta = (fs.beta); - iota = (fs.iota); - zeta = (fs.zeta); - zeta_full = (fs.zeta_full); - weak = (fs.weak); - hnf = (fs.hnf); - primops = (fs.primops); - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (fs.unfold_until); - unfold_only = (fs.unfold_only); - unfold_fully = (fs.unfold_fully); - unfold_attr = (fs.unfold_attr); - unfold_qual = (fs.unfold_qual); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = (fs.simplify); - erase_universes = (fs.erase_universes); - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = (fs.reify_); - compress_uvars = (fs.compress_uvars); - no_full_norm = (fs.no_full_norm); - check_no_uvars = (fs.check_no_uvars); - unmeta = (fs.unmeta); - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = (fs.for_extraction); - unrefine = (fs.unrefine); - default_univs_to_zero = true; - tactics = (fs.tactics) - } - | FStar_TypeChecker_Env.Tactics -> - { - beta = (fs.beta); - iota = (fs.iota); - zeta = (fs.zeta); - zeta_full = (fs.zeta_full); - weak = (fs.weak); - hnf = (fs.hnf); - primops = (fs.primops); - do_not_unfold_pure_lets = (fs.do_not_unfold_pure_lets); - unfold_until = (fs.unfold_until); - unfold_only = (fs.unfold_only); - unfold_fully = (fs.unfold_fully); - unfold_attr = (fs.unfold_attr); - unfold_qual = (fs.unfold_qual); - unfold_namespace = (fs.unfold_namespace); - dont_unfold_attr = (fs.dont_unfold_attr); - pure_subterms_within_computations = - (fs.pure_subterms_within_computations); - simplify = (fs.simplify); - erase_universes = (fs.erase_universes); - allow_unbound_universes = (fs.allow_unbound_universes); - reify_ = (fs.reify_); - compress_uvars = (fs.compress_uvars); - no_full_norm = (fs.no_full_norm); - check_no_uvars = (fs.check_no_uvars); - unmeta = (fs.unmeta); - unascribe = (fs.unascribe); - in_full_norm_request = (fs.in_full_norm_request); - weakly_reduce_scrutinee = (fs.weakly_reduce_scrutinee); - nbe_step = (fs.nbe_step); - for_extraction = (fs.for_extraction); - unrefine = (fs.unrefine); - default_univs_to_zero = (fs.default_univs_to_zero); - tactics = true - } -let (to_fsteps : FStar_TypeChecker_Env.step Prims.list -> fsteps) = - fun s -> FStar_Compiler_List.fold_right fstep_add_one s default_steps -type debug_switches = - { - gen: Prims.bool ; - top: Prims.bool ; - cfg: Prims.bool ; - primop: Prims.bool ; - unfolding: Prims.bool ; - b380: Prims.bool ; - wpe: Prims.bool ; - norm_delayed: Prims.bool ; - print_normalized: Prims.bool ; - debug_nbe: Prims.bool ; - erase_erasable_args: Prims.bool } -let (__proj__Mkdebug_switches__item__gen : debug_switches -> Prims.bool) = - fun projectee -> - match projectee with - | { gen; top; cfg; primop; unfolding; b380; wpe; norm_delayed; - print_normalized; debug_nbe; erase_erasable_args;_} -> gen -let (__proj__Mkdebug_switches__item__top : debug_switches -> Prims.bool) = - fun projectee -> - match projectee with - | { gen; top; cfg; primop; unfolding; b380; wpe; norm_delayed; - print_normalized; debug_nbe; erase_erasable_args;_} -> top -let (__proj__Mkdebug_switches__item__cfg : debug_switches -> Prims.bool) = - fun projectee -> - match projectee with - | { gen; top; cfg; primop; unfolding; b380; wpe; norm_delayed; - print_normalized; debug_nbe; erase_erasable_args;_} -> cfg -let (__proj__Mkdebug_switches__item__primop : debug_switches -> Prims.bool) = - fun projectee -> - match projectee with - | { gen; top; cfg; primop; unfolding; b380; wpe; norm_delayed; - print_normalized; debug_nbe; erase_erasable_args;_} -> primop -let (__proj__Mkdebug_switches__item__unfolding : - debug_switches -> Prims.bool) = - fun projectee -> - match projectee with - | { gen; top; cfg; primop; unfolding; b380; wpe; norm_delayed; - print_normalized; debug_nbe; erase_erasable_args;_} -> unfolding -let (__proj__Mkdebug_switches__item__b380 : debug_switches -> Prims.bool) = - fun projectee -> - match projectee with - | { gen; top; cfg; primop; unfolding; b380; wpe; norm_delayed; - print_normalized; debug_nbe; erase_erasable_args;_} -> b380 -let (__proj__Mkdebug_switches__item__wpe : debug_switches -> Prims.bool) = - fun projectee -> - match projectee with - | { gen; top; cfg; primop; unfolding; b380; wpe; norm_delayed; - print_normalized; debug_nbe; erase_erasable_args;_} -> wpe -let (__proj__Mkdebug_switches__item__norm_delayed : - debug_switches -> Prims.bool) = - fun projectee -> - match projectee with - | { gen; top; cfg; primop; unfolding; b380; wpe; norm_delayed; - print_normalized; debug_nbe; erase_erasable_args;_} -> norm_delayed -let (__proj__Mkdebug_switches__item__print_normalized : - debug_switches -> Prims.bool) = - fun projectee -> - match projectee with - | { gen; top; cfg; primop; unfolding; b380; wpe; norm_delayed; - print_normalized; debug_nbe; erase_erasable_args;_} -> - print_normalized -let (__proj__Mkdebug_switches__item__debug_nbe : - debug_switches -> Prims.bool) = - fun projectee -> - match projectee with - | { gen; top; cfg; primop; unfolding; b380; wpe; norm_delayed; - print_normalized; debug_nbe; erase_erasable_args;_} -> debug_nbe -let (__proj__Mkdebug_switches__item__erase_erasable_args : - debug_switches -> Prims.bool) = - fun projectee -> - match projectee with - | { gen; top; cfg; primop; unfolding; b380; wpe; norm_delayed; - print_normalized; debug_nbe; erase_erasable_args;_} -> - erase_erasable_args -let (no_debug_switches : debug_switches) = - { - gen = false; - top = false; - cfg = false; - primop = false; - unfolding = false; - b380 = false; - wpe = false; - norm_delayed = false; - print_normalized = false; - debug_nbe = false; - erase_erasable_args = false - } -type cfg = - { - steps: fsteps ; - tcenv: FStar_TypeChecker_Env.env ; - debug: debug_switches ; - delta_level: FStar_TypeChecker_Env.delta_level Prims.list ; - primitive_steps: - FStar_TypeChecker_Primops_Base.primitive_step FStar_Compiler_Util.psmap ; - strong: Prims.bool ; - memoize_lazy: Prims.bool ; - normalize_pure_lets: Prims.bool ; - reifying: Prims.bool ; - compat_memo_ignore_cfg: Prims.bool } -let (__proj__Mkcfg__item__steps : cfg -> fsteps) = - fun projectee -> - match projectee with - | { steps; tcenv; debug; delta_level; primitive_steps; strong; - memoize_lazy; normalize_pure_lets; reifying; - compat_memo_ignore_cfg;_} -> steps -let (__proj__Mkcfg__item__tcenv : cfg -> FStar_TypeChecker_Env.env) = - fun projectee -> - match projectee with - | { steps; tcenv; debug; delta_level; primitive_steps; strong; - memoize_lazy; normalize_pure_lets; reifying; - compat_memo_ignore_cfg;_} -> tcenv -let (__proj__Mkcfg__item__debug : cfg -> debug_switches) = - fun projectee -> - match projectee with - | { steps; tcenv; debug; delta_level; primitive_steps; strong; - memoize_lazy; normalize_pure_lets; reifying; - compat_memo_ignore_cfg;_} -> debug -let (__proj__Mkcfg__item__delta_level : - cfg -> FStar_TypeChecker_Env.delta_level Prims.list) = - fun projectee -> - match projectee with - | { steps; tcenv; debug; delta_level; primitive_steps; strong; - memoize_lazy; normalize_pure_lets; reifying; - compat_memo_ignore_cfg;_} -> delta_level -let (__proj__Mkcfg__item__primitive_steps : - cfg -> - FStar_TypeChecker_Primops_Base.primitive_step FStar_Compiler_Util.psmap) - = - fun projectee -> - match projectee with - | { steps; tcenv; debug; delta_level; primitive_steps; strong; - memoize_lazy; normalize_pure_lets; reifying; - compat_memo_ignore_cfg;_} -> primitive_steps -let (__proj__Mkcfg__item__strong : cfg -> Prims.bool) = - fun projectee -> - match projectee with - | { steps; tcenv; debug; delta_level; primitive_steps; strong; - memoize_lazy; normalize_pure_lets; reifying; - compat_memo_ignore_cfg;_} -> strong -let (__proj__Mkcfg__item__memoize_lazy : cfg -> Prims.bool) = - fun projectee -> - match projectee with - | { steps; tcenv; debug; delta_level; primitive_steps; strong; - memoize_lazy; normalize_pure_lets; reifying; - compat_memo_ignore_cfg;_} -> memoize_lazy -let (__proj__Mkcfg__item__normalize_pure_lets : cfg -> Prims.bool) = - fun projectee -> - match projectee with - | { steps; tcenv; debug; delta_level; primitive_steps; strong; - memoize_lazy; normalize_pure_lets; reifying; - compat_memo_ignore_cfg;_} -> normalize_pure_lets -let (__proj__Mkcfg__item__reifying : cfg -> Prims.bool) = - fun projectee -> - match projectee with - | { steps; tcenv; debug; delta_level; primitive_steps; strong; - memoize_lazy; normalize_pure_lets; reifying; - compat_memo_ignore_cfg;_} -> reifying -let (__proj__Mkcfg__item__compat_memo_ignore_cfg : cfg -> Prims.bool) = - fun projectee -> - match projectee with - | { steps; tcenv; debug; delta_level; primitive_steps; strong; - memoize_lazy; normalize_pure_lets; reifying; - compat_memo_ignore_cfg;_} -> compat_memo_ignore_cfg -type prim_step_set = - FStar_TypeChecker_Primops_Base.primitive_step FStar_Compiler_Util.psmap -let (empty_prim_steps : unit -> prim_step_set) = - fun uu___ -> FStar_Compiler_Util.psmap_empty () -let (add_step : - FStar_TypeChecker_Primops_Base.primitive_step -> - prim_step_set -> - FStar_TypeChecker_Primops_Base.primitive_step FStar_Compiler_Util.psmap) - = - fun s -> - fun ss -> - let uu___ = - FStar_Ident.string_of_lid s.FStar_TypeChecker_Primops_Base.name in - FStar_Compiler_Util.psmap_add ss uu___ s -let (merge_steps : prim_step_set -> prim_step_set -> prim_step_set) = - fun s1 -> fun s2 -> FStar_Compiler_Util.psmap_merge s1 s2 -let (add_steps : - prim_step_set -> - FStar_TypeChecker_Primops_Base.primitive_step Prims.list -> prim_step_set) - = fun m -> fun l -> FStar_Compiler_List.fold_right add_step l m -let (prim_from_list : - FStar_TypeChecker_Primops_Base.primitive_step Prims.list -> prim_step_set) - = fun l -> let uu___ = empty_prim_steps () in add_steps uu___ l -let (built_in_primitive_steps : - FStar_TypeChecker_Primops_Base.primitive_step FStar_Compiler_Util.psmap) = - prim_from_list FStar_TypeChecker_Primops.built_in_primitive_steps_list -let (env_dependent_ops : FStar_TypeChecker_Env.env_t -> prim_step_set) = - fun env -> - let uu___ = FStar_TypeChecker_Primops.env_dependent_ops env in - prim_from_list uu___ -let (simplification_steps : - FStar_TypeChecker_Env.env_t -> - FStar_TypeChecker_Primops_Base.primitive_step FStar_Compiler_Util.psmap) - = - fun env -> - let uu___ = FStar_TypeChecker_Primops.simplification_ops_list env in - prim_from_list uu___ -let (showable_cfg : cfg FStar_Class_Show.showable) = - { - FStar_Class_Show.show = - (fun cfg1 -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = steps_to_string cfg1.steps in - FStar_Compiler_Util.format1 " steps = %s;" uu___3 in - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_TypeChecker_Env.showable_delta_level) - cfg1.delta_level in - FStar_Compiler_Util.format1 " delta_level = %s;" uu___5 in - [uu___4; "}"] in - uu___2 :: uu___3 in - "{" :: uu___1 in - FStar_Compiler_String.concat "\n" uu___) - } -let (cfg_env : cfg -> FStar_TypeChecker_Env.env) = fun cfg1 -> cfg1.tcenv -let (find_prim_step : - cfg -> - FStar_Syntax_Syntax.fv -> - FStar_TypeChecker_Primops_Base.primitive_step - FStar_Pervasives_Native.option) - = - fun cfg1 -> - fun fv -> - let uu___ = - FStar_Ident.string_of_lid - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - FStar_Compiler_Util.psmap_try_find cfg1.primitive_steps uu___ -let (is_prim_step : cfg -> FStar_Syntax_Syntax.fv -> Prims.bool) = - fun cfg1 -> - fun fv -> - let uu___ = - let uu___1 = - FStar_Ident.string_of_lid - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - FStar_Compiler_Util.psmap_try_find cfg1.primitive_steps uu___1 in - FStar_Compiler_Util.is_some uu___ -let (log : cfg -> (unit -> unit) -> unit) = - fun cfg1 -> fun f -> if (cfg1.debug).gen then f () else () -let (log_top : cfg -> (unit -> unit) -> unit) = - fun cfg1 -> fun f -> if (cfg1.debug).top then f () else () -let (log_cfg : cfg -> (unit -> unit) -> unit) = - fun cfg1 -> fun f -> if (cfg1.debug).cfg then f () else () -let (log_primops : cfg -> (unit -> unit) -> unit) = - fun cfg1 -> fun f -> if (cfg1.debug).primop then f () else () -let (dbg_unfolding : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Unfolding" -let (log_unfolding : cfg -> (unit -> unit) -> unit) = - fun cfg1 -> - fun f -> - let uu___ = FStar_Compiler_Effect.op_Bang dbg_unfolding in - if uu___ then f () else () -let (log_nbe : cfg -> (unit -> unit) -> unit) = - fun cfg1 -> fun f -> if (cfg1.debug).debug_nbe then f () else () -let (primop_time_map : Prims.int FStar_Compiler_Util.smap) = - FStar_Compiler_Util.smap_create (Prims.of_int (50)) -let (primop_time_reset : unit -> unit) = - fun uu___ -> FStar_Compiler_Util.smap_clear primop_time_map -let (primop_time_count : Prims.string -> Prims.int -> unit) = - fun nm -> - fun ms -> - let uu___ = FStar_Compiler_Util.smap_try_find primop_time_map nm in - match uu___ with - | FStar_Pervasives_Native.None -> - FStar_Compiler_Util.smap_add primop_time_map nm ms - | FStar_Pervasives_Native.Some ms0 -> - FStar_Compiler_Util.smap_add primop_time_map nm (ms0 + ms) -let (fixto : Prims.int -> Prims.string -> Prims.string) = - fun n -> - fun s -> - if (FStar_Compiler_String.length s) < n - then - let uu___ = - FStar_Compiler_String.make (n - (FStar_Compiler_String.length s)) - 32 in - FStar_Compiler_String.op_Hat uu___ s - else s -let (primop_time_report : unit -> Prims.string) = - fun uu___ -> - let pairs = - FStar_Compiler_Util.smap_fold primop_time_map - (fun nm -> fun ms -> fun rest -> (nm, ms) :: rest) [] in - let pairs1 = - FStar_Compiler_Util.sort_with - (fun uu___1 -> - fun uu___2 -> - match (uu___1, uu___2) with - | ((uu___3, t1), (uu___4, t2)) -> t1 - t2) pairs in - FStar_Compiler_List.fold_right - (fun uu___1 -> - fun rest -> - match uu___1 with - | (nm, ms) -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_Compiler_Util.string_of_int ms in - fixto (Prims.of_int (10)) uu___4 in - FStar_Compiler_Util.format2 "%sms --- %s\n" uu___3 nm in - FStar_Compiler_String.op_Hat uu___2 rest) pairs1 "" -let (extendable_primops_dirty : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref true -type register_prim_step_t = - FStar_TypeChecker_Primops_Base.primitive_step -> unit -type retrieve_prim_step_t = unit -> prim_step_set -let (mk_extendable_primop_set : - unit -> (register_prim_step_t * retrieve_prim_step_t)) = - fun uu___ -> - let steps = - let uu___1 = empty_prim_steps () in FStar_Compiler_Util.mk_ref uu___1 in - let register p = - FStar_Compiler_Effect.op_Colon_Equals extendable_primops_dirty true; - (let uu___2 = - let uu___3 = FStar_Compiler_Effect.op_Bang steps in - add_step p uu___3 in - FStar_Compiler_Effect.op_Colon_Equals steps uu___2) in - let retrieve uu___1 = FStar_Compiler_Effect.op_Bang steps in - (register, retrieve) -let (plugins : (register_prim_step_t * retrieve_prim_step_t)) = - mk_extendable_primop_set () -let (extra_steps : (register_prim_step_t * retrieve_prim_step_t)) = - mk_extendable_primop_set () -let (register_plugin : FStar_TypeChecker_Primops_Base.primitive_step -> unit) - = fun p -> FStar_Pervasives_Native.fst plugins p -let (retrieve_plugins : unit -> prim_step_set) = - fun uu___ -> - let uu___1 = FStar_Options.no_plugins () in - if uu___1 - then empty_prim_steps () - else FStar_Pervasives_Native.snd plugins () -let (register_extra_step : - FStar_TypeChecker_Primops_Base.primitive_step -> unit) = - fun p -> FStar_Pervasives_Native.fst extra_steps p -let (retrieve_extra_steps : unit -> prim_step_set) = - fun uu___ -> FStar_Pervasives_Native.snd extra_steps () -let (list_plugins : - unit -> FStar_TypeChecker_Primops_Base.primitive_step Prims.list) = - fun uu___ -> - let uu___1 = retrieve_plugins () in FStar_Common.psmap_values uu___1 -let (list_extra_steps : - unit -> FStar_TypeChecker_Primops_Base.primitive_step Prims.list) = - fun uu___ -> - let uu___1 = retrieve_extra_steps () in FStar_Common.psmap_values uu___1 -let (cached_steps : unit -> prim_step_set) = - let memo = - let uu___ = empty_prim_steps () in FStar_Compiler_Util.mk_ref uu___ in - fun uu___ -> - let uu___1 = FStar_Compiler_Effect.op_Bang extendable_primops_dirty in - if uu___1 - then - let steps = - let uu___2 = - let uu___3 = retrieve_plugins () in - let uu___4 = retrieve_extra_steps () in merge_steps uu___3 uu___4 in - merge_steps built_in_primitive_steps uu___2 in - (FStar_Compiler_Effect.op_Colon_Equals memo steps; - FStar_Compiler_Effect.op_Colon_Equals extendable_primops_dirty false; - steps) - else FStar_Compiler_Effect.op_Bang memo -let (add_nbe : fsteps -> fsteps) = - fun s -> - let uu___ = FStar_Options.use_nbe () in - if uu___ - then - { - beta = (s.beta); - iota = (s.iota); - zeta = (s.zeta); - zeta_full = (s.zeta_full); - weak = (s.weak); - hnf = (s.hnf); - primops = (s.primops); - do_not_unfold_pure_lets = (s.do_not_unfold_pure_lets); - unfold_until = (s.unfold_until); - unfold_only = (s.unfold_only); - unfold_fully = (s.unfold_fully); - unfold_attr = (s.unfold_attr); - unfold_qual = (s.unfold_qual); - unfold_namespace = (s.unfold_namespace); - dont_unfold_attr = (s.dont_unfold_attr); - pure_subterms_within_computations = - (s.pure_subterms_within_computations); - simplify = (s.simplify); - erase_universes = (s.erase_universes); - allow_unbound_universes = (s.allow_unbound_universes); - reify_ = (s.reify_); - compress_uvars = (s.compress_uvars); - no_full_norm = (s.no_full_norm); - check_no_uvars = (s.check_no_uvars); - unmeta = (s.unmeta); - unascribe = (s.unascribe); - in_full_norm_request = (s.in_full_norm_request); - weakly_reduce_scrutinee = (s.weakly_reduce_scrutinee); - nbe_step = true; - for_extraction = (s.for_extraction); - unrefine = (s.unrefine); - default_univs_to_zero = (s.default_univs_to_zero); - tactics = (s.tactics) - } - else s -let (dbg_Norm : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Norm" -let (dbg_NormTop : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "NormTop" -let (dbg_NormCfg : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "NormCfg" -let (dbg_Primops : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Primops" -let (dbg_Unfolding : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Unfolding" -let (dbg_380 : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "380" -let (dbg_WPE : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "WPE" -let (dbg_NormDelayed : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "NormDelayed" -let (dbg_print_normalized : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "print_normalized_terms" -let (dbg_NBE : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "NBE" -let (dbg_UNSOUND_EraseErasableArgs : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "UNSOUND_EraseErasableArgs" -let (config' : - FStar_TypeChecker_Primops_Base.primitive_step Prims.list -> - FStar_TypeChecker_Env.step Prims.list -> FStar_TypeChecker_Env.env -> cfg) - = - fun psteps -> - fun s -> - fun e -> - let d = - let uu___ = - FStar_Compiler_List.collect - (fun uu___1 -> - match uu___1 with - | FStar_TypeChecker_Env.UnfoldUntil k -> - [FStar_TypeChecker_Env.Unfold k] - | FStar_TypeChecker_Env.Eager_unfolding -> - [FStar_TypeChecker_Env.Eager_unfolding_only] - | FStar_TypeChecker_Env.UnfoldQual l when - FStar_Compiler_List.contains "unfold" l -> - [FStar_TypeChecker_Env.Eager_unfolding_only] - | FStar_TypeChecker_Env.Inlining -> - [FStar_TypeChecker_Env.InliningDelta] - | FStar_TypeChecker_Env.UnfoldQual l when - FStar_Compiler_List.contains "inline_for_extraction" l - -> [FStar_TypeChecker_Env.InliningDelta] - | uu___2 -> []) s in - FStar_Compiler_List.unique uu___ in - let d1 = - match d with | [] -> [FStar_TypeChecker_Env.NoDelta] | uu___ -> d in - let steps = let uu___ = to_fsteps s in add_nbe uu___ in - let psteps1 = - let uu___ = - let uu___1 = env_dependent_ops e in - let uu___2 = cached_steps () in merge_steps uu___1 uu___2 in - add_steps uu___ psteps in - let dbg_flag = - FStar_Compiler_List.contains FStar_TypeChecker_Env.NormDebug s in - let uu___ = - let uu___1 = (FStar_Compiler_Effect.op_Bang dbg_Norm) || dbg_flag in - let uu___2 = - (FStar_Compiler_Effect.op_Bang dbg_NormTop) || dbg_flag in - let uu___3 = FStar_Compiler_Effect.op_Bang dbg_NormCfg in - let uu___4 = FStar_Compiler_Effect.op_Bang dbg_Primops in - let uu___5 = FStar_Compiler_Effect.op_Bang dbg_Unfolding in - let uu___6 = FStar_Compiler_Effect.op_Bang dbg_380 in - let uu___7 = FStar_Compiler_Effect.op_Bang dbg_WPE in - let uu___8 = FStar_Compiler_Effect.op_Bang dbg_NormDelayed in - let uu___9 = FStar_Compiler_Effect.op_Bang dbg_print_normalized in - let uu___10 = FStar_Compiler_Effect.op_Bang dbg_NBE in - let uu___11 = - (let uu___13 = - FStar_Compiler_Effect.op_Bang dbg_UNSOUND_EraseErasableArgs in - if uu___13 - then - FStar_Errors.log_issue FStar_TypeChecker_Env.hasRange_env e - FStar_Errors_Codes.Warning_WarnOnUse () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "The 'UNSOUND_EraseErasableArgs' setting is for debugging only; it is not sound") - else ()); - FStar_Compiler_Effect.op_Bang dbg_UNSOUND_EraseErasableArgs in - { - gen = uu___1; - top = uu___2; - cfg = uu___3; - primop = uu___4; - unfolding = uu___5; - b380 = uu___6; - wpe = uu___7; - norm_delayed = uu___8; - print_normalized = uu___9; - debug_nbe = uu___10; - erase_erasable_args = uu___11 - } in - let uu___1 = - (Prims.op_Negation steps.pure_subterms_within_computations) || - (FStar_Options.normalize_pure_terms_for_extraction ()) in - let uu___2 = - let uu___3 = - FStar_Options_Ext.get "compat:normalizer_memo_ignore_cfg" in - uu___3 <> "" in - { - steps; - tcenv = e; - debug = uu___; - delta_level = d1; - primitive_steps = psteps1; - strong = false; - memoize_lazy = true; - normalize_pure_lets = uu___1; - reifying = false; - compat_memo_ignore_cfg = uu___2 - } -let (config : - FStar_TypeChecker_Env.step Prims.list -> FStar_TypeChecker_Env.env -> cfg) - = fun s -> fun e -> config' [] s e -let (should_reduce_local_let : - cfg -> FStar_Syntax_Syntax.letbinding -> Prims.bool) = - fun cfg1 -> - fun lb -> - if (cfg1.steps).do_not_unfold_pure_lets - then false - else - (let uu___1 = - (cfg1.steps).pure_subterms_within_computations && - (FStar_Syntax_Util.has_attribute lb.FStar_Syntax_Syntax.lbattrs - FStar_Parser_Const.inline_let_attr) in - if uu___1 - then true - else - (let n = - FStar_TypeChecker_Env.norm_eff_name cfg1.tcenv - lb.FStar_Syntax_Syntax.lbeff in - let uu___3 = - (FStar_Syntax_Util.is_pure_effect n) && - (cfg1.normalize_pure_lets || - (FStar_Syntax_Util.has_attribute - lb.FStar_Syntax_Syntax.lbattrs - FStar_Parser_Const.inline_let_attr)) in - if uu___3 - then true - else - (FStar_Syntax_Util.is_ghost_effect n) && - (Prims.op_Negation - (cfg1.steps).pure_subterms_within_computations))) -let (translate_norm_step : - FStar_Pervasives.norm_step -> FStar_TypeChecker_Env.step Prims.list) = - fun uu___ -> - match uu___ with - | FStar_Pervasives.Zeta -> [FStar_TypeChecker_Env.Zeta] - | FStar_Pervasives.ZetaFull -> [FStar_TypeChecker_Env.ZetaFull] - | FStar_Pervasives.Iota -> [FStar_TypeChecker_Env.Iota] - | FStar_Pervasives.Delta -> - [FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant] - | FStar_Pervasives.Simpl -> [FStar_TypeChecker_Env.Simplify] - | FStar_Pervasives.Weak -> [FStar_TypeChecker_Env.Weak] - | FStar_Pervasives.HNF -> [FStar_TypeChecker_Env.HNF] - | FStar_Pervasives.Primops -> [FStar_TypeChecker_Env.Primops] - | FStar_Pervasives.Reify -> [FStar_TypeChecker_Env.Reify] - | FStar_Pervasives.NormDebug -> [FStar_TypeChecker_Env.NormDebug] - | FStar_Pervasives.UnfoldOnly names -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Compiler_List.map FStar_Ident.lid_of_str names in - FStar_TypeChecker_Env.UnfoldOnly uu___3 in - [uu___2] in - (FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant) - :: uu___1 - | FStar_Pervasives.UnfoldFully names -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Compiler_List.map FStar_Ident.lid_of_str names in - FStar_TypeChecker_Env.UnfoldFully uu___3 in - [uu___2] in - (FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant) - :: uu___1 - | FStar_Pervasives.UnfoldAttr names -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Compiler_List.map FStar_Ident.lid_of_str names in - FStar_TypeChecker_Env.UnfoldAttr uu___3 in - [uu___2] in - (FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant) - :: uu___1 - | FStar_Pervasives.UnfoldQual names -> - [FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.UnfoldQual names] - | FStar_Pervasives.UnfoldNamespace names -> - [FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.UnfoldNamespace names] - | FStar_Pervasives.Unascribe -> [FStar_TypeChecker_Env.Unascribe] - | FStar_Pervasives.NBE -> [FStar_TypeChecker_Env.NBE] - | FStar_Pervasives.Unmeta -> [FStar_TypeChecker_Env.Unmeta] -let (translate_norm_steps : - FStar_Pervasives.norm_step Prims.list -> - FStar_TypeChecker_Env.step Prims.list) - = - fun s -> - let s1 = FStar_Compiler_List.concatMap translate_norm_step s in - let add_exclude s2 z = - let uu___ = - FStar_Compiler_Util.for_some - (FStar_Class_Deq.op_Equals_Question FStar_TypeChecker_Env.deq_step - z) s2 in - if uu___ then s2 else (FStar_TypeChecker_Env.Exclude z) :: s2 in - let s2 = FStar_TypeChecker_Env.Beta :: s1 in - let s3 = add_exclude s2 FStar_TypeChecker_Env.Zeta in - let s4 = add_exclude s3 FStar_TypeChecker_Env.Iota in s4 \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Common.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Common.ml deleted file mode 100644 index 3b1907648da..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Common.ml +++ /dev/null @@ -1,994 +0,0 @@ -open Prims -type rel = - | EQ - | SUB - | SUBINV -let (uu___is_EQ : rel -> Prims.bool) = - fun projectee -> match projectee with | EQ -> true | uu___ -> false -let (uu___is_SUB : rel -> Prims.bool) = - fun projectee -> match projectee with | SUB -> true | uu___ -> false -let (uu___is_SUBINV : rel -> Prims.bool) = - fun projectee -> match projectee with | SUBINV -> true | uu___ -> false -type rank_t = - | Rigid_rigid - | Flex_rigid_eq - | Flex_flex_pattern_eq - | Flex_rigid - | Rigid_flex - | Flex_flex -let (uu___is_Rigid_rigid : rank_t -> Prims.bool) = - fun projectee -> - match projectee with | Rigid_rigid -> true | uu___ -> false -let (uu___is_Flex_rigid_eq : rank_t -> Prims.bool) = - fun projectee -> - match projectee with | Flex_rigid_eq -> true | uu___ -> false -let (uu___is_Flex_flex_pattern_eq : rank_t -> Prims.bool) = - fun projectee -> - match projectee with | Flex_flex_pattern_eq -> true | uu___ -> false -let (uu___is_Flex_rigid : rank_t -> Prims.bool) = - fun projectee -> match projectee with | Flex_rigid -> true | uu___ -> false -let (uu___is_Rigid_flex : rank_t -> Prims.bool) = - fun projectee -> match projectee with | Rigid_flex -> true | uu___ -> false -let (uu___is_Flex_flex : rank_t -> Prims.bool) = - fun projectee -> match projectee with | Flex_flex -> true | uu___ -> false -type 'a problem = - { - pid: Prims.int ; - lhs: 'a ; - relation: rel ; - rhs: 'a ; - element: FStar_Syntax_Syntax.bv FStar_Pervasives_Native.option ; - logical_guard: FStar_Syntax_Syntax.term ; - logical_guard_uvar: FStar_Syntax_Syntax.ctx_uvar ; - reason: Prims.string Prims.list ; - loc: FStar_Compiler_Range_Type.range ; - rank: rank_t FStar_Pervasives_Native.option ; - logical: Prims.bool } -let __proj__Mkproblem__item__pid : 'a . 'a problem -> Prims.int = - fun projectee -> - match projectee with - | { pid; lhs; relation; rhs; element; logical_guard; logical_guard_uvar; - reason; loc; rank; logical;_} -> pid -let __proj__Mkproblem__item__lhs : 'a . 'a problem -> 'a = - fun projectee -> - match projectee with - | { pid; lhs; relation; rhs; element; logical_guard; logical_guard_uvar; - reason; loc; rank; logical;_} -> lhs -let __proj__Mkproblem__item__relation : 'a . 'a problem -> rel = - fun projectee -> - match projectee with - | { pid; lhs; relation; rhs; element; logical_guard; logical_guard_uvar; - reason; loc; rank; logical;_} -> relation -let __proj__Mkproblem__item__rhs : 'a . 'a problem -> 'a = - fun projectee -> - match projectee with - | { pid; lhs; relation; rhs; element; logical_guard; logical_guard_uvar; - reason; loc; rank; logical;_} -> rhs -let __proj__Mkproblem__item__element : - 'a . 'a problem -> FStar_Syntax_Syntax.bv FStar_Pervasives_Native.option = - fun projectee -> - match projectee with - | { pid; lhs; relation; rhs; element; logical_guard; logical_guard_uvar; - reason; loc; rank; logical;_} -> element -let __proj__Mkproblem__item__logical_guard : - 'a . 'a problem -> FStar_Syntax_Syntax.term = - fun projectee -> - match projectee with - | { pid; lhs; relation; rhs; element; logical_guard; logical_guard_uvar; - reason; loc; rank; logical;_} -> logical_guard -let __proj__Mkproblem__item__logical_guard_uvar : - 'a . 'a problem -> FStar_Syntax_Syntax.ctx_uvar = - fun projectee -> - match projectee with - | { pid; lhs; relation; rhs; element; logical_guard; logical_guard_uvar; - reason; loc; rank; logical;_} -> logical_guard_uvar -let __proj__Mkproblem__item__reason : - 'a . 'a problem -> Prims.string Prims.list = - fun projectee -> - match projectee with - | { pid; lhs; relation; rhs; element; logical_guard; logical_guard_uvar; - reason; loc; rank; logical;_} -> reason -let __proj__Mkproblem__item__loc : - 'a . 'a problem -> FStar_Compiler_Range_Type.range = - fun projectee -> - match projectee with - | { pid; lhs; relation; rhs; element; logical_guard; logical_guard_uvar; - reason; loc; rank; logical;_} -> loc -let __proj__Mkproblem__item__rank : - 'a . 'a problem -> rank_t FStar_Pervasives_Native.option = - fun projectee -> - match projectee with - | { pid; lhs; relation; rhs; element; logical_guard; logical_guard_uvar; - reason; loc; rank; logical;_} -> rank -let __proj__Mkproblem__item__logical : 'a . 'a problem -> Prims.bool = - fun projectee -> - match projectee with - | { pid; lhs; relation; rhs; element; logical_guard; logical_guard_uvar; - reason; loc; rank; logical;_} -> logical -type prob = - | TProb of FStar_Syntax_Syntax.typ problem - | CProb of FStar_Syntax_Syntax.comp problem -let (uu___is_TProb : prob -> Prims.bool) = - fun projectee -> match projectee with | TProb _0 -> true | uu___ -> false -let (__proj__TProb__item___0 : prob -> FStar_Syntax_Syntax.typ problem) = - fun projectee -> match projectee with | TProb _0 -> _0 -let (uu___is_CProb : prob -> Prims.bool) = - fun projectee -> match projectee with | CProb _0 -> true | uu___ -> false -let (__proj__CProb__item___0 : prob -> FStar_Syntax_Syntax.comp problem) = - fun projectee -> match projectee with | CProb _0 -> _0 -type prob_t = prob -let (as_tprob : prob -> FStar_Syntax_Syntax.typ problem) = - fun uu___ -> - match uu___ with | TProb p -> p | uu___1 -> failwith "Expected a TProb" -type probs = prob Prims.list -type guard_formula = - | Trivial - | NonTrivial of FStar_Syntax_Syntax.formula -let (uu___is_Trivial : guard_formula -> Prims.bool) = - fun projectee -> match projectee with | Trivial -> true | uu___ -> false -let (uu___is_NonTrivial : guard_formula -> Prims.bool) = - fun projectee -> - match projectee with | NonTrivial _0 -> true | uu___ -> false -let (__proj__NonTrivial__item___0 : - guard_formula -> FStar_Syntax_Syntax.formula) = - fun projectee -> match projectee with | NonTrivial _0 -> _0 -let (mk_by_tactic : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun tac -> - fun f -> - let t_by_tactic = - let uu___ = - FStar_Syntax_Syntax.tabbrev FStar_Parser_Const.by_tactic_lid in - FStar_Syntax_Syntax.mk_Tm_uinst uu___ [FStar_Syntax_Syntax.U_zero] in - let uu___ = - let uu___1 = FStar_Syntax_Syntax.as_arg tac in - let uu___2 = let uu___3 = FStar_Syntax_Syntax.as_arg f in [uu___3] in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app t_by_tactic uu___ - FStar_Compiler_Range_Type.dummyRange -let rec (delta_depth_greater_than : - FStar_Syntax_Syntax.delta_depth -> - FStar_Syntax_Syntax.delta_depth -> Prims.bool) - = - fun l -> - fun m -> - match (l, m) with - | (FStar_Syntax_Syntax.Delta_equational_at_level i, - FStar_Syntax_Syntax.Delta_equational_at_level j) -> i > j - | (FStar_Syntax_Syntax.Delta_constant_at_level i, - FStar_Syntax_Syntax.Delta_constant_at_level j) -> i > j - | (FStar_Syntax_Syntax.Delta_abstract d, uu___) -> - delta_depth_greater_than d m - | (uu___, FStar_Syntax_Syntax.Delta_abstract d) -> - delta_depth_greater_than l d - | (FStar_Syntax_Syntax.Delta_equational_at_level uu___, uu___1) -> true - | (uu___, FStar_Syntax_Syntax.Delta_equational_at_level uu___1) -> - false -let rec (decr_delta_depth : - FStar_Syntax_Syntax.delta_depth -> - FStar_Syntax_Syntax.delta_depth FStar_Pervasives_Native.option) - = - fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.Delta_constant_at_level uu___1 when - uu___1 = Prims.int_zero -> FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Delta_equational_at_level uu___1 when - uu___1 = Prims.int_zero -> FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Delta_constant_at_level i -> - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Delta_constant_at_level (i - Prims.int_one)) - | FStar_Syntax_Syntax.Delta_equational_at_level i -> - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Delta_equational_at_level (i - Prims.int_one)) - | FStar_Syntax_Syntax.Delta_abstract d -> decr_delta_depth d -let (showable_guard_formula : guard_formula FStar_Class_Show.showable) = - { - FStar_Class_Show.show = - (fun uu___ -> - match uu___ with - | Trivial -> "Trivial" - | NonTrivial f -> - let uu___1 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term f in - Prims.strcat "NonTrivial " uu___1) - } -type deferred_reason = - | Deferred_univ_constraint - | Deferred_occur_check_failed - | Deferred_first_order_heuristic_failed - | Deferred_flex - | Deferred_free_names_check_failed - | Deferred_not_a_pattern - | Deferred_flex_flex_nonpattern - | Deferred_delay_match_heuristic - | Deferred_to_user_tac -let (uu___is_Deferred_univ_constraint : deferred_reason -> Prims.bool) = - fun projectee -> - match projectee with | Deferred_univ_constraint -> true | uu___ -> false -let (uu___is_Deferred_occur_check_failed : deferred_reason -> Prims.bool) = - fun projectee -> - match projectee with - | Deferred_occur_check_failed -> true - | uu___ -> false -let (uu___is_Deferred_first_order_heuristic_failed : - deferred_reason -> Prims.bool) = - fun projectee -> - match projectee with - | Deferred_first_order_heuristic_failed -> true - | uu___ -> false -let (uu___is_Deferred_flex : deferred_reason -> Prims.bool) = - fun projectee -> - match projectee with | Deferred_flex -> true | uu___ -> false -let (uu___is_Deferred_free_names_check_failed : - deferred_reason -> Prims.bool) = - fun projectee -> - match projectee with - | Deferred_free_names_check_failed -> true - | uu___ -> false -let (uu___is_Deferred_not_a_pattern : deferred_reason -> Prims.bool) = - fun projectee -> - match projectee with | Deferred_not_a_pattern -> true | uu___ -> false -let (uu___is_Deferred_flex_flex_nonpattern : deferred_reason -> Prims.bool) = - fun projectee -> - match projectee with - | Deferred_flex_flex_nonpattern -> true - | uu___ -> false -let (uu___is_Deferred_delay_match_heuristic : deferred_reason -> Prims.bool) - = - fun projectee -> - match projectee with - | Deferred_delay_match_heuristic -> true - | uu___ -> false -let (uu___is_Deferred_to_user_tac : deferred_reason -> Prims.bool) = - fun projectee -> - match projectee with | Deferred_to_user_tac -> true | uu___ -> false -let (showable_deferred_reason : deferred_reason FStar_Class_Show.showable) = - { - FStar_Class_Show.show = - (fun uu___ -> - match uu___ with - | Deferred_univ_constraint -> "Deferred_univ_constraint" - | Deferred_occur_check_failed -> "Deferred_occur_check_failed" - | Deferred_first_order_heuristic_failed -> - "Deferred_first_order_heuristic_failed" - | Deferred_flex -> "Deferred_flex" - | Deferred_free_names_check_failed -> - "Deferred_free_names_check_failed" - | Deferred_not_a_pattern -> "Deferred_not_a_pattern" - | Deferred_flex_flex_nonpattern -> "Deferred_flex_flex_nonpattern" - | Deferred_delay_match_heuristic -> "Deferred_delay_match_heuristic" - | Deferred_to_user_tac -> "Deferred_to_user_tac") - } -type deferred = - (deferred_reason * Prims.string * prob) FStar_Compiler_CList.clist -type univ_ineq = - (FStar_Syntax_Syntax.universe * FStar_Syntax_Syntax.universe) -type identifier_info = - { - identifier: - (FStar_Syntax_Syntax.bv, FStar_Syntax_Syntax.fv) FStar_Pervasives.either ; - identifier_ty: FStar_Syntax_Syntax.typ ; - identifier_range: FStar_Compiler_Range_Type.range } -let (__proj__Mkidentifier_info__item__identifier : - identifier_info -> - (FStar_Syntax_Syntax.bv, FStar_Syntax_Syntax.fv) FStar_Pervasives.either) - = - fun projectee -> - match projectee with - | { identifier; identifier_ty; identifier_range;_} -> identifier -let (__proj__Mkidentifier_info__item__identifier_ty : - identifier_info -> FStar_Syntax_Syntax.typ) = - fun projectee -> - match projectee with - | { identifier; identifier_ty; identifier_range;_} -> identifier_ty -let (__proj__Mkidentifier_info__item__identifier_range : - identifier_info -> FStar_Compiler_Range_Type.range) = - fun projectee -> - match projectee with - | { identifier; identifier_ty; identifier_range;_} -> identifier_range -type id_info_by_col = (Prims.int * identifier_info) Prims.list -type col_info_by_row = id_info_by_col FStar_Compiler_Util.pimap -type row_info_by_file = col_info_by_row FStar_Compiler_Util.psmap -type id_info_table = - { - id_info_enabled: Prims.bool ; - id_info_db: row_info_by_file ; - id_info_buffer: identifier_info Prims.list } -let (__proj__Mkid_info_table__item__id_info_enabled : - id_info_table -> Prims.bool) = - fun projectee -> - match projectee with - | { id_info_enabled; id_info_db; id_info_buffer;_} -> id_info_enabled -let (__proj__Mkid_info_table__item__id_info_db : - id_info_table -> row_info_by_file) = - fun projectee -> - match projectee with - | { id_info_enabled; id_info_db; id_info_buffer;_} -> id_info_db -let (__proj__Mkid_info_table__item__id_info_buffer : - id_info_table -> identifier_info Prims.list) = - fun projectee -> - match projectee with - | { id_info_enabled; id_info_db; id_info_buffer;_} -> id_info_buffer -let (insert_col_info : - Prims.int -> - identifier_info -> - (Prims.int * identifier_info) Prims.list -> - (Prims.int * identifier_info) Prims.list) - = - fun col -> - fun info -> - fun col_infos -> - let rec __insert aux rest = - match rest with - | [] -> (aux, [(col, info)]) - | (c, i)::rest' -> - if col < c - then (aux, ((col, info) :: rest)) - else __insert ((c, i) :: aux) rest' in - let uu___ = __insert [] col_infos in - match uu___ with - | (l, r) -> FStar_Compiler_List.op_At (FStar_Compiler_List.rev l) r -let (find_nearest_preceding_col_info : - Prims.int -> - (Prims.int * identifier_info) Prims.list -> - identifier_info FStar_Pervasives_Native.option) - = - fun col -> - fun col_infos -> - let rec aux out uu___ = - match uu___ with - | [] -> out - | (c, i)::rest -> - if c > col - then out - else aux (FStar_Pervasives_Native.Some i) rest in - aux FStar_Pervasives_Native.None col_infos -let (id_info_table_empty : id_info_table) = - let uu___ = FStar_Compiler_Util.psmap_empty () in - { id_info_enabled = false; id_info_db = uu___; id_info_buffer = [] } -let (print_identifier_info : identifier_info -> Prims.string) = - fun info -> - let uu___ = - FStar_Compiler_Range_Ops.string_of_range info.identifier_range in - let uu___1 = - match info.identifier with - | FStar_Pervasives.Inl x -> - FStar_Class_Show.show FStar_Syntax_Print.showable_bv x - | FStar_Pervasives.Inr fv -> - FStar_Class_Show.show FStar_Syntax_Print.showable_fv fv in - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - info.identifier_ty in - FStar_Compiler_Util.format3 "id info { %s, %s : %s}" uu___ uu___1 uu___2 -let (id_info__insert : - (FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.typ FStar_Pervasives_Native.option) - -> - (Prims.int * identifier_info) Prims.list FStar_Compiler_Util.pimap - FStar_Compiler_Util.psmap -> - identifier_info -> - (Prims.int * identifier_info) Prims.list FStar_Compiler_Util.pimap - FStar_Compiler_Util.psmap) - = - fun ty_map -> - fun db -> - fun info -> - let range = info.identifier_range in - let use_range = - let uu___ = FStar_Compiler_Range_Type.use_range range in - FStar_Compiler_Range_Type.set_def_range range uu___ in - let id_ty = - match info.identifier with - | FStar_Pervasives.Inr uu___ -> ty_map info.identifier_ty - | FStar_Pervasives.Inl x -> ty_map info.identifier_ty in - match id_ty with - | FStar_Pervasives_Native.None -> db - | FStar_Pervasives_Native.Some id_ty1 -> - let info1 = - { - identifier = (info.identifier); - identifier_ty = id_ty1; - identifier_range = use_range - } in - let fn = FStar_Compiler_Range_Ops.file_of_range use_range in - let start = FStar_Compiler_Range_Ops.start_of_range use_range in - let uu___ = - let uu___1 = FStar_Compiler_Range_Ops.line_of_pos start in - let uu___2 = FStar_Compiler_Range_Ops.col_of_pos start in - (uu___1, uu___2) in - (match uu___ with - | (row, col) -> - let rows = - let uu___1 = FStar_Compiler_Util.pimap_empty () in - FStar_Compiler_Util.psmap_find_default db fn uu___1 in - let cols = - FStar_Compiler_Util.pimap_find_default rows row [] in - let uu___1 = - let uu___2 = insert_col_info col info1 cols in - FStar_Compiler_Util.pimap_add rows row uu___2 in - FStar_Compiler_Util.psmap_add db fn uu___1) -let (id_info_insert : - id_info_table -> - (FStar_Syntax_Syntax.bv, FStar_Syntax_Syntax.fv) FStar_Pervasives.either - -> - FStar_Syntax_Syntax.typ -> - FStar_Compiler_Range_Type.range -> id_info_table) - = - fun table -> - fun id -> - fun ty -> - fun range -> - let info = - { identifier = id; identifier_ty = ty; identifier_range = range } in - { - id_info_enabled = (table.id_info_enabled); - id_info_db = (table.id_info_db); - id_info_buffer = (info :: (table.id_info_buffer)) - } -let (id_info_insert_bv : - id_info_table -> - FStar_Syntax_Syntax.bv -> FStar_Syntax_Syntax.typ -> id_info_table) - = - fun table -> - fun bv -> - fun ty -> - if table.id_info_enabled - then - let uu___ = FStar_Syntax_Syntax.range_of_bv bv in - id_info_insert table (FStar_Pervasives.Inl bv) ty uu___ - else table -let (id_info_insert_fv : - id_info_table -> - FStar_Syntax_Syntax.fv -> FStar_Syntax_Syntax.typ -> id_info_table) - = - fun table -> - fun fv -> - fun ty -> - if table.id_info_enabled - then - let uu___ = FStar_Syntax_Syntax.range_of_fv fv in - id_info_insert table (FStar_Pervasives.Inr fv) ty uu___ - else table -let (id_info_toggle : id_info_table -> Prims.bool -> id_info_table) = - fun table -> - fun enabled -> - { - id_info_enabled = enabled; - id_info_db = (table.id_info_db); - id_info_buffer = (table.id_info_buffer) - } -let (id_info_promote : - id_info_table -> - (FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.typ FStar_Pervasives_Native.option) - -> id_info_table) - = - fun table -> - fun ty_map -> - let uu___ = - FStar_Compiler_List.fold_left (id_info__insert ty_map) - table.id_info_db table.id_info_buffer in - { - id_info_enabled = (table.id_info_enabled); - id_info_db = uu___; - id_info_buffer = [] - } -let (id_info_at_pos : - id_info_table -> - Prims.string -> - Prims.int -> - Prims.int -> identifier_info FStar_Pervasives_Native.option) - = - fun table -> - fun fn -> - fun row -> - fun col -> - let rows = - let uu___ = FStar_Compiler_Util.pimap_empty () in - FStar_Compiler_Util.psmap_find_default table.id_info_db fn uu___ in - let cols = FStar_Compiler_Util.pimap_find_default rows row [] in - let uu___ = find_nearest_preceding_col_info col cols in - match uu___ with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some info -> - let last_col = - let uu___1 = - FStar_Compiler_Range_Ops.end_of_range info.identifier_range in - FStar_Compiler_Range_Ops.col_of_pos uu___1 in - if col <= last_col - then FStar_Pervasives_Native.Some info - else FStar_Pervasives_Native.None -let (check_uvar_ctx_invariant : - Prims.string -> - FStar_Compiler_Range_Type.range -> - Prims.bool -> - FStar_Syntax_Syntax.gamma -> FStar_Syntax_Syntax.binders -> unit) - = - fun reason -> - fun r -> - fun should_check -> - fun g -> - fun bs -> - let fail uu___ = - let uu___1 = - let uu___2 = FStar_Compiler_Range_Ops.string_of_range r in - let uu___3 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binding) g in - let uu___4 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binder) bs in - FStar_Compiler_Util.format5 - "Invariant violation: gamma and binders are out of sync\n\treason=%s, range=%s, should_check=%s\n\t\n gamma=%s\n\tbinders=%s\n" - reason uu___2 (if should_check then "true" else "false") - uu___3 uu___4 in - failwith uu___1 in - if Prims.op_Negation should_check - then () - else - (let uu___1 = - let uu___2 = - FStar_Compiler_Util.prefix_until - (fun uu___3 -> - match uu___3 with - | FStar_Syntax_Syntax.Binding_var uu___4 -> true - | uu___4 -> false) g in - (uu___2, bs) in - match uu___1 with - | (FStar_Pervasives_Native.None, []) -> () - | (FStar_Pervasives_Native.Some (uu___2, hd, gamma_tail), - uu___3::uu___4) -> - let uu___5 = FStar_Compiler_Util.prefix bs in - (match uu___5 with - | (uu___6, x) -> - (match hd with - | FStar_Syntax_Syntax.Binding_var x' when - FStar_Syntax_Syntax.bv_eq - x.FStar_Syntax_Syntax.binder_bv x' - -> () - | uu___7 -> fail ())) - | uu___2 -> fail ()) -type implicit = - { - imp_reason: Prims.string ; - imp_uvar: FStar_Syntax_Syntax.ctx_uvar ; - imp_tm: FStar_Syntax_Syntax.term ; - imp_range: FStar_Compiler_Range_Type.range } -let (__proj__Mkimplicit__item__imp_reason : implicit -> Prims.string) = - fun projectee -> - match projectee with - | { imp_reason; imp_uvar; imp_tm; imp_range;_} -> imp_reason -let (__proj__Mkimplicit__item__imp_uvar : - implicit -> FStar_Syntax_Syntax.ctx_uvar) = - fun projectee -> - match projectee with - | { imp_reason; imp_uvar; imp_tm; imp_range;_} -> imp_uvar -let (__proj__Mkimplicit__item__imp_tm : implicit -> FStar_Syntax_Syntax.term) - = - fun projectee -> - match projectee with - | { imp_reason; imp_uvar; imp_tm; imp_range;_} -> imp_tm -let (__proj__Mkimplicit__item__imp_range : - implicit -> FStar_Compiler_Range_Type.range) = - fun projectee -> - match projectee with - | { imp_reason; imp_uvar; imp_tm; imp_range;_} -> imp_range -let (showable_implicit : implicit FStar_Class_Show.showable) = - { - FStar_Class_Show.show = - (fun i -> - FStar_Class_Show.show FStar_Syntax_Print.showable_uvar - (i.imp_uvar).FStar_Syntax_Syntax.ctx_uvar_head) - } -type implicits = implicit Prims.list -let (implicits_to_string : implicits -> Prims.string) = - fun imps -> - let imp_to_string i = - FStar_Class_Show.show FStar_Syntax_Print.showable_uvar - (i.imp_uvar).FStar_Syntax_Syntax.ctx_uvar_head in - (FStar_Common.string_of_list ()) imp_to_string imps -type implicits_t = implicit FStar_Compiler_CList.t -type guard_t = - { - guard_f: guard_formula ; - deferred_to_tac: deferred ; - deferred: deferred ; - univ_ineqs: - (FStar_Syntax_Syntax.universe FStar_Compiler_CList.clist * univ_ineq - FStar_Compiler_CList.clist) - ; - implicits: implicits_t } -let (__proj__Mkguard_t__item__guard_f : guard_t -> guard_formula) = - fun projectee -> - match projectee with - | { guard_f; deferred_to_tac; deferred = deferred1; univ_ineqs; - implicits = implicits1;_} -> guard_f -let (__proj__Mkguard_t__item__deferred_to_tac : guard_t -> deferred) = - fun projectee -> - match projectee with - | { guard_f; deferred_to_tac; deferred = deferred1; univ_ineqs; - implicits = implicits1;_} -> deferred_to_tac -let (__proj__Mkguard_t__item__deferred : guard_t -> deferred) = - fun projectee -> - match projectee with - | { guard_f; deferred_to_tac; deferred = deferred1; univ_ineqs; - implicits = implicits1;_} -> deferred1 -let (__proj__Mkguard_t__item__univ_ineqs : - guard_t -> - (FStar_Syntax_Syntax.universe FStar_Compiler_CList.clist * univ_ineq - FStar_Compiler_CList.clist)) - = - fun projectee -> - match projectee with - | { guard_f; deferred_to_tac; deferred = deferred1; univ_ineqs; - implicits = implicits1;_} -> univ_ineqs -let (__proj__Mkguard_t__item__implicits : guard_t -> implicits_t) = - fun projectee -> - match projectee with - | { guard_f; deferred_to_tac; deferred = deferred1; univ_ineqs; - implicits = implicits1;_} -> implicits1 -let (trivial_guard : guard_t) = - { - guard_f = Trivial; - deferred_to_tac = - (Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic (FStar_Compiler_CList.listlike_clist ())))); - deferred = - (Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic (FStar_Compiler_CList.listlike_clist ())))); - univ_ineqs = - ((Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic (FStar_Compiler_CList.listlike_clist ())))), - (Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic (FStar_Compiler_CList.listlike_clist ()))))); - implicits = - (Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic (FStar_Compiler_CList.listlike_clist ())))) - } -let (conj_guard_f : guard_formula -> guard_formula -> guard_formula) = - fun g1 -> - fun g2 -> - match (g1, g2) with - | (Trivial, g) -> g - | (g, Trivial) -> g - | (NonTrivial f1, NonTrivial f2) -> - let uu___ = FStar_Syntax_Util.mk_conj f1 f2 in NonTrivial uu___ -let (binop_guard : - (guard_formula -> guard_formula -> guard_formula) -> - guard_t -> guard_t -> guard_t) - = - fun f -> - fun g1 -> - fun g2 -> - let uu___ = f g1.guard_f g2.guard_f in - let uu___1 = - FStar_Class_Monoid.op_Plus_Plus - (FStar_Compiler_CList.monoid_clist ()) g1.deferred_to_tac - g2.deferred_to_tac in - let uu___2 = - FStar_Class_Monoid.op_Plus_Plus - (FStar_Compiler_CList.monoid_clist ()) g1.deferred g2.deferred in - let uu___3 = - let uu___4 = - FStar_Class_Monoid.op_Plus_Plus - (FStar_Compiler_CList.monoid_clist ()) - (FStar_Pervasives_Native.fst g1.univ_ineqs) - (FStar_Pervasives_Native.fst g2.univ_ineqs) in - let uu___5 = - FStar_Class_Monoid.op_Plus_Plus - (FStar_Compiler_CList.monoid_clist ()) - (FStar_Pervasives_Native.snd g1.univ_ineqs) - (FStar_Pervasives_Native.snd g2.univ_ineqs) in - (uu___4, uu___5) in - let uu___4 = - FStar_Class_Monoid.op_Plus_Plus - (FStar_Compiler_CList.monoid_clist ()) g1.implicits g2.implicits in - { - guard_f = uu___; - deferred_to_tac = uu___1; - deferred = uu___2; - univ_ineqs = uu___3; - implicits = uu___4 - } -let (conj_guard : guard_t -> guard_t -> guard_t) = - fun g1 -> fun g2 -> binop_guard conj_guard_f g1 g2 -let (monoid_guard_t : guard_t FStar_Class_Monoid.monoid) = - { - FStar_Class_Monoid.mzero = trivial_guard; - FStar_Class_Monoid.mplus = conj_guard - } -let rec (check_trivial : FStar_Syntax_Syntax.term -> guard_formula) = - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Util.unmeta t in - FStar_Syntax_Util.head_and_args uu___1 in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Util.unmeta hd in - FStar_Syntax_Util.un_uinst uu___4 in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar tc, []) when - FStar_Syntax_Syntax.fv_eq_lid tc FStar_Parser_Const.true_lid -> - Trivial - | (FStar_Syntax_Syntax.Tm_fvar sq, (v, uu___2)::[]) when - (FStar_Syntax_Syntax.fv_eq_lid sq FStar_Parser_Const.squash_lid) - || - (FStar_Syntax_Syntax.fv_eq_lid sq - FStar_Parser_Const.auto_squash_lid) - -> - let uu___3 = check_trivial v in - (match uu___3 with | Trivial -> Trivial | uu___4 -> NonTrivial t) - | uu___2 -> NonTrivial t) -let (imp_guard_f : guard_formula -> guard_formula -> guard_formula) = - fun g1 -> - fun g2 -> - match (g1, g2) with - | (Trivial, g) -> g - | (g, Trivial) -> Trivial - | (NonTrivial f1, NonTrivial f2) -> - let imp = FStar_Syntax_Util.mk_imp f1 f2 in check_trivial imp -let (imp_guard : guard_t -> guard_t -> guard_t) = - fun g1 -> fun g2 -> binop_guard imp_guard_f g1 g2 -let (conj_guards : guard_t Prims.list -> guard_t) = - fun gs -> FStar_Compiler_List.fold_left conj_guard trivial_guard gs -let (split_guard : guard_t -> (guard_t * guard_t)) = - fun g -> - ({ - guard_f = Trivial; - deferred_to_tac = (g.deferred_to_tac); - deferred = (g.deferred); - univ_ineqs = (g.univ_ineqs); - implicits = (g.implicits) - }, - { - guard_f = (g.guard_f); - deferred_to_tac = (trivial_guard.deferred_to_tac); - deferred = (trivial_guard.deferred); - univ_ineqs = (trivial_guard.univ_ineqs); - implicits = (trivial_guard.implicits) - }) -let (weaken_guard_formula : guard_t -> FStar_Syntax_Syntax.typ -> guard_t) = - fun g -> - fun fml -> - match g.guard_f with - | Trivial -> g - | NonTrivial f -> - let uu___ = - let uu___1 = FStar_Syntax_Util.mk_imp fml f in - check_trivial uu___1 in - { - guard_f = uu___; - deferred_to_tac = (g.deferred_to_tac); - deferred = (g.deferred); - univ_ineqs = (g.univ_ineqs); - implicits = (g.implicits) - } -type lcomp = - { - eff_name: FStar_Ident.lident ; - res_typ: FStar_Syntax_Syntax.typ ; - cflags: FStar_Syntax_Syntax.cflag Prims.list ; - comp_thunk: - (unit -> (FStar_Syntax_Syntax.comp * guard_t), FStar_Syntax_Syntax.comp) - FStar_Pervasives.either FStar_Compiler_Effect.ref - } -let (__proj__Mklcomp__item__eff_name : lcomp -> FStar_Ident.lident) = - fun projectee -> - match projectee with - | { eff_name; res_typ; cflags; comp_thunk;_} -> eff_name -let (__proj__Mklcomp__item__res_typ : lcomp -> FStar_Syntax_Syntax.typ) = - fun projectee -> - match projectee with - | { eff_name; res_typ; cflags; comp_thunk;_} -> res_typ -let (__proj__Mklcomp__item__cflags : - lcomp -> FStar_Syntax_Syntax.cflag Prims.list) = - fun projectee -> - match projectee with - | { eff_name; res_typ; cflags; comp_thunk;_} -> cflags -let (__proj__Mklcomp__item__comp_thunk : - lcomp -> - (unit -> (FStar_Syntax_Syntax.comp * guard_t), FStar_Syntax_Syntax.comp) - FStar_Pervasives.either FStar_Compiler_Effect.ref) - = - fun projectee -> - match projectee with - | { eff_name; res_typ; cflags; comp_thunk;_} -> comp_thunk -let (mk_lcomp : - FStar_Ident.lident -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.cflag Prims.list -> - (unit -> (FStar_Syntax_Syntax.comp * guard_t)) -> lcomp) - = - fun eff_name -> - fun res_typ -> - fun cflags -> - fun comp_thunk -> - let uu___ = - FStar_Compiler_Util.mk_ref (FStar_Pervasives.Inl comp_thunk) in - { eff_name; res_typ; cflags; comp_thunk = uu___ } -let (lcomp_comp : lcomp -> (FStar_Syntax_Syntax.comp * guard_t)) = - fun lc -> - let uu___ = FStar_Compiler_Effect.op_Bang lc.comp_thunk in - match uu___ with - | FStar_Pervasives.Inl thunk -> - let uu___1 = thunk () in - (match uu___1 with - | (c, g) -> - (FStar_Compiler_Effect.op_Colon_Equals lc.comp_thunk - (FStar_Pervasives.Inr c); - (c, g))) - | FStar_Pervasives.Inr c -> (c, trivial_guard) -let (apply_lcomp : - (FStar_Syntax_Syntax.comp -> FStar_Syntax_Syntax.comp) -> - (guard_t -> guard_t) -> lcomp -> lcomp) - = - fun fc -> - fun fg -> - fun lc -> - mk_lcomp lc.eff_name lc.res_typ lc.cflags - (fun uu___ -> - let uu___1 = lcomp_comp lc in - match uu___1 with - | (c, g) -> - let uu___2 = fc c in let uu___3 = fg g in (uu___2, uu___3)) -let (lcomp_to_string : lcomp -> Prims.string) = - fun lc -> - let uu___ = FStar_Options.print_effect_args () in - if uu___ - then - let uu___1 = - let uu___2 = lcomp_comp lc in FStar_Pervasives_Native.fst uu___2 in - FStar_Class_Show.show FStar_Syntax_Print.showable_comp uu___1 - else - (let uu___2 = - FStar_Class_Show.show FStar_Ident.showable_lident lc.eff_name in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term lc.res_typ in - FStar_Compiler_Util.format2 "%s %s" uu___2 uu___3) -let (lcomp_set_flags : - lcomp -> FStar_Syntax_Syntax.cflag Prims.list -> lcomp) = - fun lc -> - fun fs -> - let comp_typ_set_flags c = - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total uu___ -> c - | FStar_Syntax_Syntax.GTotal uu___ -> c - | FStar_Syntax_Syntax.Comp ct -> - let ct1 = - { - FStar_Syntax_Syntax.comp_univs = - (ct.FStar_Syntax_Syntax.comp_univs); - FStar_Syntax_Syntax.effect_name = - (ct.FStar_Syntax_Syntax.effect_name); - FStar_Syntax_Syntax.result_typ = - (ct.FStar_Syntax_Syntax.result_typ); - FStar_Syntax_Syntax.effect_args = - (ct.FStar_Syntax_Syntax.effect_args); - FStar_Syntax_Syntax.flags = fs - } in - { - FStar_Syntax_Syntax.n = (FStar_Syntax_Syntax.Comp ct1); - FStar_Syntax_Syntax.pos = (c.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = (c.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (c.FStar_Syntax_Syntax.hash_code) - } in - mk_lcomp lc.eff_name lc.res_typ fs - (fun uu___ -> - let uu___1 = lcomp_comp lc in - match uu___1 with | (c, g) -> ((comp_typ_set_flags c), g)) -let (is_total_lcomp : lcomp -> Prims.bool) = - fun c -> - (FStar_Ident.lid_equals c.eff_name FStar_Parser_Const.effect_Tot_lid) || - (FStar_Compiler_Util.for_some - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.TOTAL -> true - | FStar_Syntax_Syntax.RETURN -> true - | uu___1 -> false) c.cflags) -let (is_tot_or_gtot_lcomp : lcomp -> Prims.bool) = - fun c -> - ((FStar_Ident.lid_equals c.eff_name FStar_Parser_Const.effect_Tot_lid) || - (FStar_Ident.lid_equals c.eff_name FStar_Parser_Const.effect_GTot_lid)) - || - (FStar_Compiler_Util.for_some - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.TOTAL -> true - | FStar_Syntax_Syntax.RETURN -> true - | uu___1 -> false) c.cflags) -let (is_lcomp_partial_return : lcomp -> Prims.bool) = - fun c -> - FStar_Compiler_Util.for_some - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.RETURN -> true - | FStar_Syntax_Syntax.PARTIAL_RETURN -> true - | uu___1 -> false) c.cflags -let (is_pure_lcomp : lcomp -> Prims.bool) = - fun lc -> - ((is_total_lcomp lc) || (FStar_Syntax_Util.is_pure_effect lc.eff_name)) - || - (FStar_Compiler_Util.for_some - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.LEMMA -> true - | uu___1 -> false) lc.cflags) -let (is_pure_or_ghost_lcomp : lcomp -> Prims.bool) = - fun lc -> - (is_pure_lcomp lc) || (FStar_Syntax_Util.is_ghost_effect lc.eff_name) -let (set_result_typ_lc : lcomp -> FStar_Syntax_Syntax.typ -> lcomp) = - fun lc -> - fun t -> - mk_lcomp lc.eff_name t lc.cflags - (fun uu___ -> - let uu___1 = lcomp_comp lc in - match uu___1 with - | (c, g) -> - let uu___2 = FStar_Syntax_Util.set_result_typ c t in - (uu___2, g)) -let (residual_comp_of_lcomp : lcomp -> FStar_Syntax_Syntax.residual_comp) = - fun lc -> - { - FStar_Syntax_Syntax.residual_effect = (lc.eff_name); - FStar_Syntax_Syntax.residual_typ = - (FStar_Pervasives_Native.Some (lc.res_typ)); - FStar_Syntax_Syntax.residual_flags = (lc.cflags) - } -let (lcomp_of_comp_guard : FStar_Syntax_Syntax.comp -> guard_t -> lcomp) = - fun c0 -> - fun g -> - let uu___ = - match c0.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total uu___1 -> - (FStar_Parser_Const.effect_Tot_lid, [FStar_Syntax_Syntax.TOTAL]) - | FStar_Syntax_Syntax.GTotal uu___1 -> - (FStar_Parser_Const.effect_GTot_lid, - [FStar_Syntax_Syntax.SOMETRIVIAL]) - | FStar_Syntax_Syntax.Comp c -> - ((c.FStar_Syntax_Syntax.effect_name), - (c.FStar_Syntax_Syntax.flags)) in - match uu___ with - | (eff_name, flags) -> - mk_lcomp eff_name (FStar_Syntax_Util.comp_result c0) flags - (fun uu___1 -> (c0, g)) -let (lcomp_of_comp : FStar_Syntax_Syntax.comp -> lcomp) = - fun c0 -> lcomp_of_comp_guard c0 trivial_guard -let (check_positivity_qual : - Prims.bool -> - FStar_Syntax_Syntax.positivity_qualifier FStar_Pervasives_Native.option - -> - FStar_Syntax_Syntax.positivity_qualifier FStar_Pervasives_Native.option - -> Prims.bool) - = - fun subtyping -> - fun p0 -> - fun p1 -> - if p0 = p1 - then true - else - if subtyping - then - (match (p0, p1) with - | (FStar_Pervasives_Native.Some uu___1, - FStar_Pervasives_Native.None) -> true - | (FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.BinderUnused), - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.BinderStrictlyPositive)) -> true - | uu___1 -> false) - else false \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Core.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Core.ml deleted file mode 100644 index 6e795063f0f..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Core.ml +++ /dev/null @@ -1,8238 +0,0 @@ -open Prims -type tot_or_ghost = - | E_Total - | E_Ghost -let (uu___is_E_Total : tot_or_ghost -> Prims.bool) = - fun projectee -> match projectee with | E_Total -> true | uu___ -> false -let (uu___is_E_Ghost : tot_or_ghost -> Prims.bool) = - fun projectee -> match projectee with | E_Ghost -> true | uu___ -> false -let (dbg : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Core" -let (dbg_Eq : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "CoreEq" -let (dbg_Top : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "CoreTop" -let (dbg_Exit : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "CoreExit" -let (goal_ctr : Prims.int FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref Prims.int_zero -let (get_goal_ctr : unit -> Prims.int) = - fun uu___ -> FStar_Compiler_Effect.op_Bang goal_ctr -let (incr_goal_ctr : unit -> Prims.int) = - fun uu___ -> - let v = FStar_Compiler_Effect.op_Bang goal_ctr in - FStar_Compiler_Effect.op_Colon_Equals goal_ctr (v + Prims.int_one); - v + Prims.int_one -type guard_handler_t = - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.typ -> Prims.bool -type env = - { - tcenv: FStar_TypeChecker_Env.env ; - allow_universe_instantiation: Prims.bool ; - max_binder_index: Prims.int ; - guard_handler: guard_handler_t FStar_Pervasives_Native.option ; - should_read_cache: Prims.bool } -let (__proj__Mkenv__item__tcenv : env -> FStar_TypeChecker_Env.env) = - fun projectee -> - match projectee with - | { tcenv; allow_universe_instantiation; max_binder_index; guard_handler; - should_read_cache;_} -> tcenv -let (__proj__Mkenv__item__allow_universe_instantiation : env -> Prims.bool) = - fun projectee -> - match projectee with - | { tcenv; allow_universe_instantiation; max_binder_index; guard_handler; - should_read_cache;_} -> allow_universe_instantiation -let (__proj__Mkenv__item__max_binder_index : env -> Prims.int) = - fun projectee -> - match projectee with - | { tcenv; allow_universe_instantiation; max_binder_index; guard_handler; - should_read_cache;_} -> max_binder_index -let (__proj__Mkenv__item__guard_handler : - env -> guard_handler_t FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { tcenv; allow_universe_instantiation; max_binder_index; guard_handler; - should_read_cache;_} -> guard_handler -let (__proj__Mkenv__item__should_read_cache : env -> Prims.bool) = - fun projectee -> - match projectee with - | { tcenv; allow_universe_instantiation; max_binder_index; guard_handler; - should_read_cache;_} -> should_read_cache -let (push_binder : env -> FStar_Syntax_Syntax.binder -> env) = - fun g -> - fun b -> - if - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.index <= - g.max_binder_index - then - failwith - "Assertion failed: unexpected shadowing in the core environment" - else - (let uu___1 = FStar_TypeChecker_Env.push_binders g.tcenv [b] in - { - tcenv = uu___1; - allow_universe_instantiation = (g.allow_universe_instantiation); - max_binder_index = - ((b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.index); - guard_handler = (g.guard_handler); - should_read_cache = (g.should_read_cache) - }) -let (push_binders : env -> FStar_Syntax_Syntax.binder Prims.list -> env) = - FStar_Compiler_List.fold_left push_binder -let (fresh_binder : - env -> FStar_Syntax_Syntax.binder -> (env * FStar_Syntax_Syntax.binder)) = - fun g -> - fun old -> - let ctr = g.max_binder_index + Prims.int_one in - let bv = - let uu___ = old.FStar_Syntax_Syntax.binder_bv in - { - FStar_Syntax_Syntax.ppname = (uu___.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = ctr; - FStar_Syntax_Syntax.sort = (uu___.FStar_Syntax_Syntax.sort) - } in - let b = - FStar_Syntax_Syntax.mk_binder_with_attrs bv - old.FStar_Syntax_Syntax.binder_qual - old.FStar_Syntax_Syntax.binder_positivity - old.FStar_Syntax_Syntax.binder_attrs in - let uu___ = push_binder g b in (uu___, b) -let (open_binders : - env -> - FStar_Syntax_Syntax.binders -> - (env * FStar_Syntax_Syntax.binder Prims.list * - FStar_Syntax_Syntax.subst_elt Prims.list)) - = - fun g -> - fun bs -> - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun b -> - match uu___1 with - | (g1, bs1, subst) -> - let bv = - let uu___2 = b.FStar_Syntax_Syntax.binder_bv in - let uu___3 = - FStar_Syntax_Subst.subst subst - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - { - FStar_Syntax_Syntax.ppname = - (uu___2.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (uu___2.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = uu___3 - } in - let b1 = - let uu___2 = - FStar_Syntax_Subst.subst_bqual subst - b.FStar_Syntax_Syntax.binder_qual in - let uu___3 = - FStar_Compiler_List.map - (FStar_Syntax_Subst.subst subst) - b.FStar_Syntax_Syntax.binder_attrs in - { - FStar_Syntax_Syntax.binder_bv = bv; - FStar_Syntax_Syntax.binder_qual = uu___2; - FStar_Syntax_Syntax.binder_positivity = - (b.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs = uu___3 - } in - let uu___2 = fresh_binder g1 b1 in - (match uu___2 with - | (g2, b') -> - let uu___3 = - let uu___4 = - FStar_Syntax_Subst.shift_subst Prims.int_one - subst in - (FStar_Syntax_Syntax.DB - (Prims.int_zero, - (b'.FStar_Syntax_Syntax.binder_bv))) - :: uu___4 in - (g2, (b' :: bs1), uu___3))) (g, [], []) bs in - match uu___ with - | (g1, bs_rev, subst) -> (g1, (FStar_Compiler_List.rev bs_rev), subst) -let (open_pat : - env -> - FStar_Syntax_Syntax.pat -> - (env * FStar_Syntax_Syntax.pat * FStar_Syntax_Syntax.subst_t)) - = - fun g -> - fun p -> - let rec open_pat_aux g1 p1 sub = - match p1.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_constant uu___ -> (g1, p1, sub) - | FStar_Syntax_Syntax.Pat_cons (fv, us_opt, pats) -> - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun uu___2 -> - match (uu___1, uu___2) with - | ((g2, pats1, sub1), (p2, imp)) -> - let uu___3 = open_pat_aux g2 p2 sub1 in - (match uu___3 with - | (g3, p3, sub2) -> - (g3, ((p3, imp) :: pats1), sub2))) - (g1, [], sub) pats in - (match uu___ with - | (g2, pats1, sub1) -> - (g2, - { - FStar_Syntax_Syntax.v = - (FStar_Syntax_Syntax.Pat_cons - (fv, us_opt, (FStar_Compiler_List.rev pats1))); - FStar_Syntax_Syntax.p = (p1.FStar_Syntax_Syntax.p) - }, sub1)) - | FStar_Syntax_Syntax.Pat_var x -> - let bx = - let uu___ = - let uu___1 = - FStar_Syntax_Subst.subst sub x.FStar_Syntax_Syntax.sort in - { - FStar_Syntax_Syntax.ppname = (x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = (x.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = uu___1 - } in - FStar_Syntax_Syntax.mk_binder uu___ in - let uu___ = fresh_binder g1 bx in - (match uu___ with - | (g2, bx') -> - let sub1 = - let uu___1 = - FStar_Syntax_Subst.shift_subst Prims.int_one sub in - (FStar_Syntax_Syntax.DB - (Prims.int_zero, (bx'.FStar_Syntax_Syntax.binder_bv))) - :: uu___1 in - (g2, - { - FStar_Syntax_Syntax.v = - (FStar_Syntax_Syntax.Pat_var - (bx'.FStar_Syntax_Syntax.binder_bv)); - FStar_Syntax_Syntax.p = (p1.FStar_Syntax_Syntax.p) - }, sub1)) - | FStar_Syntax_Syntax.Pat_dot_term eopt -> - let eopt1 = - FStar_Compiler_Util.map_option (FStar_Syntax_Subst.subst sub) - eopt in - (g1, - { - FStar_Syntax_Syntax.v = - (FStar_Syntax_Syntax.Pat_dot_term eopt1); - FStar_Syntax_Syntax.p = (p1.FStar_Syntax_Syntax.p) - }, sub) in - open_pat_aux g p [] -let (open_term : - env -> - FStar_Syntax_Syntax.binder -> - FStar_Syntax_Syntax.term -> - (env * FStar_Syntax_Syntax.binder * FStar_Syntax_Syntax.term)) - = - fun g -> - fun b -> - fun t -> - let uu___ = fresh_binder g b in - match uu___ with - | (g1, b') -> - let t1 = - FStar_Syntax_Subst.subst - [FStar_Syntax_Syntax.DB - (Prims.int_zero, (b'.FStar_Syntax_Syntax.binder_bv))] t in - (g1, b', t1) -let (open_term_binders : - env -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.term -> - (env * FStar_Syntax_Syntax.binders * FStar_Syntax_Syntax.term)) - = - fun g -> - fun bs -> - fun t -> - let uu___ = open_binders g bs in - match uu___ with - | (g1, bs1, subst) -> - let uu___1 = FStar_Syntax_Subst.subst subst t in - (g1, bs1, uu___1) -let (open_comp : - env -> - FStar_Syntax_Syntax.binder -> - FStar_Syntax_Syntax.comp -> - (env * FStar_Syntax_Syntax.binder * FStar_Syntax_Syntax.comp)) - = - fun g -> - fun b -> - fun c -> - let uu___ = fresh_binder g b in - match uu___ with - | (g1, bx) -> - let c1 = - FStar_Syntax_Subst.subst_comp - [FStar_Syntax_Syntax.DB - (Prims.int_zero, (bx.FStar_Syntax_Syntax.binder_bv))] c in - (g1, bx, c1) -let (open_comp_binders : - env -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.comp -> - (env * FStar_Syntax_Syntax.binders * FStar_Syntax_Syntax.comp)) - = - fun g -> - fun bs -> - fun c -> - let uu___ = open_binders g bs in - match uu___ with - | (g1, bs1, s) -> - let c1 = FStar_Syntax_Subst.subst_comp s c in (g1, bs1, c1) -let (arrow_formals_comp : - env -> - FStar_Syntax_Syntax.term -> - (env * FStar_Syntax_Syntax.binder Prims.list * - FStar_Syntax_Syntax.comp)) - = - fun g -> - fun c -> - let uu___ = FStar_Syntax_Util.arrow_formals_comp_ln c in - match uu___ with - | (bs, c1) -> - let uu___1 = open_binders g bs in - (match uu___1 with - | (g1, bs1, subst) -> - let uu___2 = FStar_Syntax_Subst.subst_comp subst c1 in - (g1, bs1, uu___2)) -let (open_branch : - env -> FStar_Syntax_Syntax.branch -> (env * FStar_Syntax_Syntax.branch)) = - fun g -> - fun br -> - let uu___ = br in - match uu___ with - | (p, wopt, e) -> - let uu___1 = open_pat g p in - (match uu___1 with - | (g1, p1, s) -> - let uu___2 = - let uu___3 = - FStar_Compiler_Util.map_option - (FStar_Syntax_Subst.subst s) wopt in - let uu___4 = FStar_Syntax_Subst.subst s e in - (p1, uu___3, uu___4) in - (g1, uu___2)) -let (open_branches_eq_pat : - env -> - FStar_Syntax_Syntax.branch -> - FStar_Syntax_Syntax.branch -> - (env * (FStar_Syntax_Syntax.pat * FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option * FStar_Syntax_Syntax.term) * - (FStar_Syntax_Syntax.pat * FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option * FStar_Syntax_Syntax.term))) - = - fun g -> - fun br0 -> - fun br1 -> - let uu___ = br0 in - match uu___ with - | (p0, wopt0, e0) -> - let uu___1 = br1 in - (match uu___1 with - | (uu___2, wopt1, e1) -> - let uu___3 = open_pat g p0 in - (match uu___3 with - | (g1, p01, s) -> - let uu___4 = - let uu___5 = - FStar_Compiler_Util.map_option - (FStar_Syntax_Subst.subst s) wopt0 in - let uu___6 = FStar_Syntax_Subst.subst s e0 in - (p01, uu___5, uu___6) in - let uu___5 = - let uu___6 = - FStar_Compiler_Util.map_option - (FStar_Syntax_Subst.subst s) wopt1 in - let uu___7 = FStar_Syntax_Subst.subst s e1 in - (p01, uu___6, uu___7) in - (g1, uu___4, uu___5))) -type precondition = FStar_Syntax_Syntax.typ FStar_Pervasives_Native.option -type 'a success = ('a * precondition) -type relation = - | EQUALITY - | SUBTYPING of FStar_Syntax_Syntax.term FStar_Pervasives_Native.option -let (uu___is_EQUALITY : relation -> Prims.bool) = - fun projectee -> match projectee with | EQUALITY -> true | uu___ -> false -let (uu___is_SUBTYPING : relation -> Prims.bool) = - fun projectee -> - match projectee with | SUBTYPING _0 -> true | uu___ -> false -let (__proj__SUBTYPING__item___0 : - relation -> FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) = - fun projectee -> match projectee with | SUBTYPING _0 -> _0 -let (relation_to_string : relation -> Prims.string) = - fun uu___ -> - match uu___ with - | EQUALITY -> "=?=" - | SUBTYPING (FStar_Pervasives_Native.None) -> "<:?" - | SUBTYPING (FStar_Pervasives_Native.Some tm) -> - let uu___1 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term tm in - FStar_Compiler_Util.format1 "( <:? %s)" uu___1 -type context_term = - | CtxTerm of FStar_Syntax_Syntax.term - | CtxRel of FStar_Syntax_Syntax.term * relation * FStar_Syntax_Syntax.term -let (uu___is_CtxTerm : context_term -> Prims.bool) = - fun projectee -> match projectee with | CtxTerm _0 -> true | uu___ -> false -let (__proj__CtxTerm__item___0 : context_term -> FStar_Syntax_Syntax.term) = - fun projectee -> match projectee with | CtxTerm _0 -> _0 -let (uu___is_CtxRel : context_term -> Prims.bool) = - fun projectee -> - match projectee with | CtxRel (_0, _1, _2) -> true | uu___ -> false -let (__proj__CtxRel__item___0 : context_term -> FStar_Syntax_Syntax.term) = - fun projectee -> match projectee with | CtxRel (_0, _1, _2) -> _0 -let (__proj__CtxRel__item___1 : context_term -> relation) = - fun projectee -> match projectee with | CtxRel (_0, _1, _2) -> _1 -let (__proj__CtxRel__item___2 : context_term -> FStar_Syntax_Syntax.term) = - fun projectee -> match projectee with | CtxRel (_0, _1, _2) -> _2 -let (context_term_to_string : context_term -> Prims.string) = - fun c -> - match c with - | CtxTerm term -> - FStar_Class_Show.show FStar_Syntax_Print.showable_term term - | CtxRel (t0, r, t1) -> - let uu___ = FStar_Class_Show.show FStar_Syntax_Print.showable_term t0 in - let uu___1 = relation_to_string r in - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.format3 "%s %s %s" uu___ uu___1 uu___2 -type context = - { - no_guard: Prims.bool ; - unfolding_ok: Prims.bool ; - error_context: - (Prims.string * context_term FStar_Pervasives_Native.option) Prims.list } -let (__proj__Mkcontext__item__no_guard : context -> Prims.bool) = - fun projectee -> - match projectee with - | { no_guard; unfolding_ok; error_context;_} -> no_guard -let (__proj__Mkcontext__item__unfolding_ok : context -> Prims.bool) = - fun projectee -> - match projectee with - | { no_guard; unfolding_ok; error_context;_} -> unfolding_ok -let (__proj__Mkcontext__item__error_context : - context -> - (Prims.string * context_term FStar_Pervasives_Native.option) Prims.list) - = - fun projectee -> - match projectee with - | { no_guard; unfolding_ok; error_context;_} -> error_context -let (showable_context : context FStar_Class_Show.showable) = - { - FStar_Class_Show.show = - (fun context1 -> - let uu___ = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) context1.no_guard in - let uu___1 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) context1.unfolding_ok in - let uu___2 = - let uu___3 = - FStar_Compiler_List.map FStar_Pervasives_Native.fst - context1.error_context in - FStar_Class_Show.show - (FStar_Class_Show.show_list - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_string)) uu___3 in - FStar_Compiler_Util.format3 - "{no_guard=%s; unfolding_ok=%s; error_context=%s}" uu___ uu___1 - uu___2) - } -let (print_context : context -> Prims.string) = - fun ctx -> - let rec aux depth ctx1 = - match ctx1 with - | [] -> "" - | (msg, ctx_term)::tl -> - let hd = - let uu___ = - match ctx_term with - | FStar_Pervasives_Native.None -> "" - | FStar_Pervasives_Native.Some ctx_term1 -> - context_term_to_string ctx_term1 in - FStar_Compiler_Util.format3 "%s %s (%s)\n" depth msg uu___ in - let tl1 = aux (Prims.strcat depth ">") tl in Prims.strcat hd tl1 in - aux "" (FStar_Compiler_List.rev ctx.error_context) -type error = (context * Prims.string) -let (print_error : error -> Prims.string) = - fun err -> - let uu___ = err in - match uu___ with - | (ctx, msg) -> - let uu___1 = print_context ctx in - FStar_Compiler_Util.format2 "%s%s" uu___1 msg -let (print_error_short : error -> Prims.string) = - fun err -> FStar_Pervasives_Native.snd err -type 'a __result = - | Success of 'a - | Error of error -let uu___is_Success : 'a . 'a __result -> Prims.bool = - fun projectee -> match projectee with | Success _0 -> true | uu___ -> false -let __proj__Success__item___0 : 'a . 'a __result -> 'a = - fun projectee -> match projectee with | Success _0 -> _0 -let uu___is_Error : 'a . 'a __result -> Prims.bool = - fun projectee -> match projectee with | Error _0 -> true | uu___ -> false -let __proj__Error__item___0 : 'a . 'a __result -> error = - fun projectee -> match projectee with | Error _0 -> _0 -let showable_result : - 'a . 'a FStar_Class_Show.showable -> 'a __result FStar_Class_Show.showable - = - fun uu___ -> - { - FStar_Class_Show.show = - (fun uu___1 -> - match uu___1 with - | Success a1 -> - let uu___2 = FStar_Class_Show.show uu___ a1 in - Prims.strcat "Success " uu___2 - | Error e -> - let uu___2 = print_error_short e in - Prims.strcat "Error " uu___2) - } -type 'a result = context -> 'a success __result -type hash_entry = - { - he_term: FStar_Syntax_Syntax.term ; - he_gamma: FStar_Syntax_Syntax.binding Prims.list ; - he_res: (tot_or_ghost * FStar_Syntax_Syntax.typ) success } -let (__proj__Mkhash_entry__item__he_term : - hash_entry -> FStar_Syntax_Syntax.term) = - fun projectee -> - match projectee with | { he_term; he_gamma; he_res;_} -> he_term -let (__proj__Mkhash_entry__item__he_gamma : - hash_entry -> FStar_Syntax_Syntax.binding Prims.list) = - fun projectee -> - match projectee with | { he_term; he_gamma; he_res;_} -> he_gamma -let (__proj__Mkhash_entry__item__he_res : - hash_entry -> (tot_or_ghost * FStar_Syntax_Syntax.typ) success) = - fun projectee -> - match projectee with | { he_term; he_gamma; he_res;_} -> he_res -type tc_table = hash_entry FStar_Syntax_TermHashTable.hashtable -let (equal_term_for_hash : - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term -> Prims.bool) = - fun t1 -> - fun t2 -> - FStar_Profiling.profile - (fun uu___ -> FStar_Syntax_Hash.equal_term t1 t2) - FStar_Pervasives_Native.None - "FStar.TypeChecker.Core.equal_term_for_hash" -let (equal_term : - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term -> Prims.bool) = - fun t1 -> - fun t2 -> - FStar_Profiling.profile - (fun uu___ -> FStar_Syntax_Hash.equal_term t1 t2) - FStar_Pervasives_Native.None "FStar.TypeChecker.Core.equal_term" -let (table : tc_table) = - FStar_Syntax_TermHashTable.create (Prims.parse_int "1048576") -type cache_stats_t = { - hits: Prims.int ; - misses: Prims.int } -let (__proj__Mkcache_stats_t__item__hits : cache_stats_t -> Prims.int) = - fun projectee -> match projectee with | { hits; misses;_} -> hits -let (__proj__Mkcache_stats_t__item__misses : cache_stats_t -> Prims.int) = - fun projectee -> match projectee with | { hits; misses;_} -> misses -let (cache_stats : cache_stats_t FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref - { hits = Prims.int_zero; misses = Prims.int_zero } -let (record_cache_hit : unit -> unit) = - fun uu___ -> - let cs = FStar_Compiler_Effect.op_Bang cache_stats in - FStar_Compiler_Effect.op_Colon_Equals cache_stats - { hits = (cs.hits + Prims.int_one); misses = (cs.misses) } -let (record_cache_miss : unit -> unit) = - fun uu___ -> - let cs = FStar_Compiler_Effect.op_Bang cache_stats in - FStar_Compiler_Effect.op_Colon_Equals cache_stats - { hits = (cs.hits); misses = (cs.misses + Prims.int_one) } -let (reset_cache_stats : unit -> unit) = - fun uu___ -> - FStar_Compiler_Effect.op_Colon_Equals cache_stats - { hits = Prims.int_zero; misses = Prims.int_zero } -let (report_cache_stats : unit -> cache_stats_t) = - fun uu___ -> FStar_Compiler_Effect.op_Bang cache_stats -let (clear_memo_table : unit -> unit) = - fun uu___ -> FStar_Syntax_TermHashTable.clear table -type side = - | Left - | Right - | Both - | Neither -let (uu___is_Left : side -> Prims.bool) = - fun projectee -> match projectee with | Left -> true | uu___ -> false -let (uu___is_Right : side -> Prims.bool) = - fun projectee -> match projectee with | Right -> true | uu___ -> false -let (uu___is_Both : side -> Prims.bool) = - fun projectee -> match projectee with | Both -> true | uu___ -> false -let (uu___is_Neither : side -> Prims.bool) = - fun projectee -> match projectee with | Neither -> true | uu___ -> false -let (insert : - env -> - FStar_Syntax_Syntax.term -> - (tot_or_ghost * FStar_Syntax_Syntax.typ) success -> unit) - = - fun g -> - fun e -> - fun res -> - let entry = - { - he_term = e; - he_gamma = ((g.tcenv).FStar_TypeChecker_Env.gamma); - he_res = res - } in - FStar_Syntax_TermHashTable.insert e entry table -let return : 'a . 'a -> 'a result = - fun x -> fun uu___ -> Success (x, FStar_Pervasives_Native.None) -let (and_pre : - precondition -> - precondition -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - FStar_Pervasives_Native.option) - = - fun p1 -> - fun p2 -> - match (p1, p2) with - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> - FStar_Pervasives_Native.None - | (FStar_Pervasives_Native.Some p, FStar_Pervasives_Native.None) -> - FStar_Pervasives_Native.Some p - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.Some p) -> - FStar_Pervasives_Native.Some p - | (FStar_Pervasives_Native.Some p11, FStar_Pervasives_Native.Some p21) - -> - let uu___ = FStar_Syntax_Util.mk_conj p11 p21 in - FStar_Pervasives_Native.Some uu___ -let op_let_Bang : 'a 'b . 'a result -> ('a -> 'b result) -> 'b result = - fun x -> - fun y -> - fun ctx0 -> - let uu___ = x ctx0 in - match uu___ with - | Success (x1, g1) -> - let uu___1 = let uu___2 = y x1 in uu___2 ctx0 in - (match uu___1 with - | Success (y1, g2) -> - let uu___2 = let uu___3 = and_pre g1 g2 in (y1, uu___3) in - Success uu___2 - | err -> err) - | Error err -> Error err -let op_and_Bang : 'a 'b . 'a result -> 'b result -> ('a * 'b) result = - fun x -> - fun y -> - fun ctx0 -> - let uu___ = x ctx0 in - match uu___ with - | Success (x1, g1) -> - let uu___1 = - let uu___2 ctx01 = - let uu___3 = y ctx01 in - match uu___3 with - | Success (x2, g11) -> - let uu___4 = - let uu___5 uu___6 = - Success ((x1, x2), FStar_Pervasives_Native.None) in - uu___5 ctx01 in - (match uu___4 with - | Success (y1, g2) -> - let uu___5 = - let uu___6 = and_pre g11 g2 in (y1, uu___6) in - Success uu___5 - | err -> err) - | Error err -> Error err in - uu___2 ctx0 in - (match uu___1 with - | Success (y1, g2) -> - let uu___2 = let uu___3 = and_pre g1 g2 in (y1, uu___3) in - Success uu___2 - | err -> err) - | Error err -> Error err -let op_let_Question : - 'a 'b . - 'a FStar_Pervasives_Native.option -> - ('a -> 'b FStar_Pervasives_Native.option) -> - 'b FStar_Pervasives_Native.option - = - fun x -> - fun f -> - match x with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some x1 -> f x1 -let fail : 'a . Prims.string -> 'a result = - fun msg -> fun ctx -> Error (ctx, msg) -let (dump_context : unit result) = - fun ctx -> - (let uu___1 = print_context ctx in - FStar_Compiler_Util.print_string uu___1); - (let uu___1 uu___2 = Success ((), FStar_Pervasives_Native.None) in - uu___1 ctx) -let handle_with : 'a . 'a result -> (unit -> 'a result) -> 'a result = - fun x -> - fun h -> - fun ctx -> - let uu___ = x ctx in - match uu___ with - | Error uu___1 -> let uu___2 = h () in uu___2 ctx - | res -> res -let with_context : - 'a . - Prims.string -> - context_term FStar_Pervasives_Native.option -> - (unit -> 'a result) -> 'a result - = - fun msg -> - fun t -> - fun x -> - fun ctx -> - let ctx1 = - { - no_guard = (ctx.no_guard); - unfolding_ok = (ctx.unfolding_ok); - error_context = ((msg, t) :: (ctx.error_context)) - } in - let uu___ = x () in uu___ ctx1 -let (mk_type : - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun u -> - FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_type u) - FStar_Compiler_Range_Type.dummyRange -let (is_type : - env -> FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.universe result) = - fun g -> - fun t -> - let aux t1 = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t1 in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_type u -> - (fun uu___1 -> Success (u, FStar_Pervasives_Native.None)) - | uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.format1 "Expected a type; got %s" uu___3 in - fail uu___2 in - fun ctx -> - let ctx1 = - { - no_guard = (ctx.no_guard); - unfolding_ok = (ctx.unfolding_ok); - error_context = - (("is_type", (FStar_Pervasives_Native.Some (CtxTerm t))) :: - (ctx.error_context)) - } in - let uu___ = - let uu___1 = aux t in - fun ctx2 -> - let uu___2 = uu___1 ctx2 in - match uu___2 with - | Error uu___3 -> - let uu___4 = - let uu___5 = - let uu___6 = - FStar_TypeChecker_Normalize.unfold_whnf g.tcenv t in - FStar_Syntax_Util.unrefine uu___6 in - aux uu___5 in - uu___4 ctx2 - | res -> res in - uu___ ctx1 -let rec (is_arrow : - env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.binder * tot_or_ghost * FStar_Syntax_Syntax.typ) - result) - = - fun g -> - fun t -> - let rec aux t1 = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t1 in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = x::[]; - FStar_Syntax_Syntax.comp = c;_} - -> - let uu___1 = FStar_Syntax_Util.is_tot_or_gtot_comp c in - if uu___1 - then - let uu___2 = open_comp g x c in - (match uu___2 with - | (g1, x1, c1) -> - let eff = - let uu___3 = FStar_Syntax_Util.is_total_comp c1 in - if uu___3 then E_Total else E_Ghost in - (fun uu___3 -> - Success - ((x1, eff, (FStar_Syntax_Util.comp_result c1)), - FStar_Pervasives_Native.None))) - else - (let e_tag = - let uu___3 = c.FStar_Syntax_Syntax.n in - match uu___3 with - | FStar_Syntax_Syntax.Comp ct -> - let uu___4 = - (FStar_Ident.lid_equals - ct.FStar_Syntax_Syntax.effect_name - FStar_Parser_Const.effect_Pure_lid) - || - (FStar_Ident.lid_equals - ct.FStar_Syntax_Syntax.effect_name - FStar_Parser_Const.effect_Lemma_lid) in - if uu___4 - then FStar_Pervasives_Native.Some E_Total - else - (let uu___6 = - FStar_Ident.lid_equals - ct.FStar_Syntax_Syntax.effect_name - FStar_Parser_Const.effect_Ghost_lid in - if uu___6 - then FStar_Pervasives_Native.Some E_Ghost - else FStar_Pervasives_Native.None) in - match e_tag with - | FStar_Pervasives_Native.None -> - let uu___3 = - let uu___4 = - FStar_Ident.string_of_lid - (FStar_Syntax_Util.comp_effect_name c) in - FStar_Compiler_Util.format1 - "Expected total or gtot arrow, got %s" uu___4 in - fail uu___3 - | FStar_Pervasives_Native.Some e_tag1 -> - let uu___3 = arrow_formals_comp g t1 in - (match uu___3 with - | (g1, x1::[], c1) -> - let uu___4 = FStar_Syntax_Util.comp_effect_args c1 in - (match uu___4 with - | (pre, uu___5)::(post, uu___6)::uu___7 -> - let arg_typ = - FStar_Syntax_Util.refine - x1.FStar_Syntax_Syntax.binder_bv pre in - let res_typ = - let r = - FStar_Syntax_Syntax.new_bv - FStar_Pervasives_Native.None - (FStar_Syntax_Util.comp_result c1) in - let post1 = - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Syntax_Syntax.bv_to_name r in - (uu___10, FStar_Pervasives_Native.None) in - [uu___9] in - FStar_Syntax_Syntax.mk_Tm_app post uu___8 - post.FStar_Syntax_Syntax.pos in - FStar_Syntax_Util.refine r post1 in - let xbv = - let uu___8 = x1.FStar_Syntax_Syntax.binder_bv in - { - FStar_Syntax_Syntax.ppname = - (uu___8.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (uu___8.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = arg_typ - } in - let x2 = - { - FStar_Syntax_Syntax.binder_bv = xbv; - FStar_Syntax_Syntax.binder_qual = - (x1.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity = - (x1.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs = - (x1.FStar_Syntax_Syntax.binder_attrs) - } in - (fun uu___8 -> - Success - ((x2, e_tag1, res_typ), - FStar_Pervasives_Native.None))))) - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = x::xs; - FStar_Syntax_Syntax.comp = c;_} - -> - let t2 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 = xs; - FStar_Syntax_Syntax.comp = c - }) t1.FStar_Syntax_Syntax.pos in - let uu___1 = open_term g x t2 in - (match uu___1 with - | (g1, x1, t3) -> - (fun uu___2 -> - Success ((x1, E_Total, t3), FStar_Pervasives_Native.None))) - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x; FStar_Syntax_Syntax.phi = uu___1;_} - -> is_arrow g x.FStar_Syntax_Syntax.sort - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t2; - FStar_Syntax_Syntax.meta = uu___1;_} - -> aux t2 - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t2; FStar_Syntax_Syntax.asc = uu___1; - FStar_Syntax_Syntax.eff_opt = uu___2;_} - -> aux t2 - | uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t1 in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.format2 "Expected an arrow, got (%s) %s" - uu___3 uu___4 in - fail uu___2 in - fun ctx -> - let ctx1 = - { - no_guard = (ctx.no_guard); - unfolding_ok = (ctx.unfolding_ok); - error_context = (("is_arrow", FStar_Pervasives_Native.None) :: - (ctx.error_context)) - } in - let uu___ = - let uu___1 = aux t in - fun ctx2 -> - let uu___2 = uu___1 ctx2 in - match uu___2 with - | Error uu___3 -> - let uu___4 = - let uu___5 = - FStar_TypeChecker_Normalize.unfold_whnf g.tcenv t in - aux uu___5 in - uu___4 ctx2 - | res -> res in - uu___ ctx1 -let (check_arg_qual : - FStar_Syntax_Syntax.aqual -> FStar_Syntax_Syntax.bqual -> unit result) = - fun a -> - fun b -> - match b with - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit uu___) -> - (match a with - | FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = uu___1;_} - -> (fun uu___2 -> Success ((), FStar_Pervasives_Native.None)) - | uu___1 -> fail "missing arg qualifier implicit") - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta uu___) -> - (match a with - | FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = uu___1;_} - -> (fun uu___2 -> Success ((), FStar_Pervasives_Native.None)) - | uu___1 -> fail "missing arg qualifier implicit") - | uu___ -> - (match a with - | FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = uu___1;_} - -> fail "extra arg qualifier implicit" - | uu___1 -> - (fun uu___2 -> Success ((), FStar_Pervasives_Native.None))) -let (check_bqual : - FStar_Syntax_Syntax.bqual -> FStar_Syntax_Syntax.bqual -> unit result) = - fun b0 -> - fun b1 -> - match (b0, b1) with - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> - (fun uu___ -> Success ((), FStar_Pervasives_Native.None)) - | (FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit b01), - FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit b11)) -> - (fun uu___ -> Success ((), FStar_Pervasives_Native.None)) - | (FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Equality), - FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Equality)) -> - (fun uu___ -> Success ((), FStar_Pervasives_Native.None)) - | (FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta t1), - FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta t2)) -> - let uu___ = equal_term t1 t2 in - if uu___ - then (fun uu___1 -> Success ((), FStar_Pervasives_Native.None)) - else fail "Binder qualifier mismatch" - | uu___ -> fail "Binder qualifier mismatch" -let (check_aqual : - FStar_Syntax_Syntax.aqual -> FStar_Syntax_Syntax.aqual -> unit result) = - fun a0 -> - fun a1 -> - match (a0, a1) with - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> - (fun uu___ -> Success ((), FStar_Pervasives_Native.None)) - | (FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = b0; - FStar_Syntax_Syntax.aqual_attributes = uu___;_}, - FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = b1; - FStar_Syntax_Syntax.aqual_attributes = uu___1;_}) - -> - if b0 = b1 - then (fun uu___2 -> Success ((), FStar_Pervasives_Native.None)) - else - (let uu___3 = - let uu___4 = FStar_Compiler_Util.string_of_bool b0 in - let uu___5 = FStar_Compiler_Util.string_of_bool b1 in - FStar_Compiler_Util.format2 - "Unequal arg qualifiers: lhs implicit=%s and rhs implicit=%s" - uu___4 uu___5 in - fail uu___3) - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = false; - FStar_Syntax_Syntax.aqual_attributes = uu___;_}) - -> (fun uu___1 -> Success ((), FStar_Pervasives_Native.None)) - | (FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = false; - FStar_Syntax_Syntax.aqual_attributes = uu___;_}, - FStar_Pervasives_Native.None) -> - (fun uu___1 -> Success ((), FStar_Pervasives_Native.None)) - | uu___ -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_aqual a0 in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_aqual a1 in - FStar_Compiler_Util.format2 - "Unequal arg qualifiers: lhs %s and rhs %s" uu___2 uu___3 in - fail uu___1 -let (check_positivity_qual : - relation -> - FStar_Syntax_Syntax.positivity_qualifier FStar_Pervasives_Native.option - -> - FStar_Syntax_Syntax.positivity_qualifier FStar_Pervasives_Native.option - -> unit result) - = - fun rel -> - fun p0 -> - fun p1 -> - let uu___ = - FStar_TypeChecker_Common.check_positivity_qual - (uu___is_SUBTYPING rel) p0 p1 in - if uu___ - then fun uu___1 -> Success ((), FStar_Pervasives_Native.None) - else fail "Unequal positivity qualifiers" -let (mk_forall_l : - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun us -> - fun xs -> - fun t -> - FStar_Compiler_List.fold_right2 - (fun u -> - fun x -> - fun t1 -> - FStar_Syntax_Util.mk_forall u - x.FStar_Syntax_Syntax.binder_bv t1) us xs t -let (close_guard : - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.universes -> precondition -> precondition) - = - fun xs -> - fun us -> - fun g -> - match g with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some t -> - let uu___ = mk_forall_l us xs t in - FStar_Pervasives_Native.Some uu___ -let (close_guard_with_definition : - FStar_Syntax_Syntax.binder -> - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.term -> precondition -> precondition) - = - fun x -> - fun u -> - fun t -> - fun g -> - match g with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some t1 -> - let uu___ = - let t2 = - let uu___1 = - let uu___2 = - FStar_Syntax_Syntax.bv_to_name - x.FStar_Syntax_Syntax.binder_bv in - FStar_Syntax_Util.mk_eq2 u - (x.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort - uu___2 t1 in - FStar_Syntax_Util.mk_imp uu___1 t1 in - FStar_Syntax_Util.mk_forall u x.FStar_Syntax_Syntax.binder_bv - t2 in - FStar_Pervasives_Native.Some uu___ -let with_binders : - 'a . - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.universes -> 'a result -> 'a result - = - fun xs -> - fun us -> - fun f -> - fun ctx -> - let uu___ = f ctx in - match uu___ with - | Success (t, g) -> - let uu___1 = let uu___2 = close_guard xs us g in (t, uu___2) in - Success uu___1 - | err -> err -let with_definition : - 'a . - FStar_Syntax_Syntax.binder -> - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.term -> 'a result -> 'a result - = - fun x -> - fun u -> - fun t -> - fun f -> - fun ctx -> - let uu___ = f ctx in - match uu___ with - | Success (a1, g) -> - let uu___1 = - let uu___2 = close_guard_with_definition x u t g in - (a1, uu___2) in - Success uu___1 - | err -> err -let (guard : FStar_Syntax_Syntax.typ -> unit result) = - fun t -> fun uu___ -> Success ((), (FStar_Pervasives_Native.Some t)) -let (abs : - FStar_Syntax_Syntax.typ -> - (FStar_Syntax_Syntax.binder -> FStar_Syntax_Syntax.term) -> - FStar_Syntax_Syntax.term) - = - fun a -> - fun f -> - let x = FStar_Syntax_Syntax.new_bv FStar_Pervasives_Native.None a in - let xb = FStar_Syntax_Syntax.mk_binder x in - let uu___ = f xb in - FStar_Syntax_Util.abs [xb] uu___ FStar_Pervasives_Native.None -let (weaken_subtyping_guard : - FStar_Syntax_Syntax.term -> precondition -> precondition) = - fun p -> - fun g -> - FStar_Compiler_Util.map_opt g (fun q -> FStar_Syntax_Util.mk_imp p q) -let (strengthen_subtyping_guard : - FStar_Syntax_Syntax.term -> precondition -> precondition) = - fun p -> - fun g -> - let uu___ = - let uu___1 = - FStar_Compiler_Util.map_opt g - (fun q -> FStar_Syntax_Util.mk_conj p q) in - FStar_Compiler_Util.dflt p uu___1 in - FStar_Pervasives_Native.Some uu___ -let weaken : - 'a . - FStar_Syntax_Syntax.term -> 'a result -> context -> 'a success __result - = - fun p -> - fun g -> - fun ctx -> - let uu___ = g ctx in - match uu___ with - | Success (x, q) -> - let uu___1 = - let uu___2 = weaken_subtyping_guard p q in (x, uu___2) in - Success uu___1 - | err -> err -let weaken_with_guard_formula : - 'a . - FStar_TypeChecker_Common.guard_formula -> - 'a result -> context -> 'a success __result - = - fun p -> - fun g -> - match p with - | FStar_TypeChecker_Common.Trivial -> g - | FStar_TypeChecker_Common.NonTrivial p1 -> weaken p1 g -let (push_hypothesis : env -> FStar_Syntax_Syntax.term -> env) = - fun g -> - fun h -> - let bv = - FStar_Syntax_Syntax.new_bv - (FStar_Pervasives_Native.Some (h.FStar_Syntax_Syntax.pos)) h in - let b = FStar_Syntax_Syntax.mk_binder bv in - let uu___ = fresh_binder g b in FStar_Pervasives_Native.fst uu___ -let strengthen : - 'a . - FStar_Syntax_Syntax.term -> 'a result -> context -> 'a success __result - = - fun p -> - fun g -> - fun ctx -> - let uu___ = g ctx in - match uu___ with - | Success (x, q) -> - let uu___1 = - let uu___2 = strengthen_subtyping_guard p q in (x, uu___2) in - Success uu___1 - | err -> err -let no_guard : 'a . 'a result -> 'a result = - fun g -> - fun ctx -> - let uu___ = - g - { - no_guard = true; - unfolding_ok = (ctx.unfolding_ok); - error_context = (ctx.error_context) - } in - match uu___ with - | Success (x, FStar_Pervasives_Native.None) -> - Success (x, FStar_Pervasives_Native.None) - | Success (x, FStar_Pervasives_Native.Some g1) -> - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term g1 in - FStar_Compiler_Util.format1 "Unexpected guard: %s" uu___3 in - fail uu___2 in - uu___1 ctx - | err -> err -let (equatable : env -> FStar_Syntax_Syntax.term -> Prims.bool) = - fun g -> - fun t -> - let uu___ = FStar_Syntax_Util.leftmost_head t in - FStar_TypeChecker_Rel.may_relate_with_logical_guard g.tcenv true uu___ -let (apply_predicate : - FStar_Syntax_Syntax.binder -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term) - = - fun x -> - fun p -> - fun e -> - FStar_Syntax_Subst.subst - [FStar_Syntax_Syntax.NT ((x.FStar_Syntax_Syntax.binder_bv), e)] p -let (curry_arrow : - FStar_Syntax_Syntax.binder -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.comp -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun x -> - fun xs -> - fun c -> - let tail = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = xs; FStar_Syntax_Syntax.comp = c }) - FStar_Compiler_Range_Type.dummyRange in - let uu___ = - let uu___1 = - let uu___2 = FStar_Syntax_Syntax.mk_Total tail in - { - FStar_Syntax_Syntax.bs1 = [x]; - FStar_Syntax_Syntax.comp = uu___2 - } in - FStar_Syntax_Syntax.Tm_arrow uu___1 in - FStar_Syntax_Syntax.mk uu___ FStar_Compiler_Range_Type.dummyRange -let (curry_abs : - FStar_Syntax_Syntax.binder -> - FStar_Syntax_Syntax.binder -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun b0 -> - fun b1 -> - fun bs -> - fun body -> - fun ropt -> - let tail = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = (b1 :: bs); - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = ropt - }) body.FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = [b0]; - FStar_Syntax_Syntax.body = tail; - FStar_Syntax_Syntax.rc_opt = FStar_Pervasives_Native.None - }) body.FStar_Syntax_Syntax.pos -let (is_gtot_comp : - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> Prims.bool) = - fun c -> - (FStar_Syntax_Util.is_tot_or_gtot_comp c) && - (let uu___ = FStar_Syntax_Util.is_total_comp c in - Prims.op_Negation uu___) -let rec (context_included : - FStar_Syntax_Syntax.binding Prims.list -> - FStar_Syntax_Syntax.binding Prims.list -> Prims.bool) - = - fun g0 -> - fun g1 -> - let uu___ = FStar_Compiler_Util.physical_equality g0 g1 in - if uu___ - then true - else - (match (g0, g1) with - | ([], uu___2) -> true - | (b0::g0', b1::g1') -> - (match (b0, b1) with - | (FStar_Syntax_Syntax.Binding_var x0, - FStar_Syntax_Syntax.Binding_var x1) -> - if - x0.FStar_Syntax_Syntax.index = - x1.FStar_Syntax_Syntax.index - then - (equal_term x0.FStar_Syntax_Syntax.sort - x1.FStar_Syntax_Syntax.sort) - && (context_included g0' g1') - else context_included g0 g1' - | (FStar_Syntax_Syntax.Binding_lid uu___2, - FStar_Syntax_Syntax.Binding_lid uu___3) -> true - | (FStar_Syntax_Syntax.Binding_univ uu___2, - FStar_Syntax_Syntax.Binding_univ uu___3) -> true - | uu___2 -> false) - | uu___2 -> false) -let (curry_application : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - (FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) -> - (FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) - Prims.list -> - FStar_Compiler_Range_Type.range -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun hd -> - fun arg -> - fun args -> - fun p -> - let head = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = hd; - FStar_Syntax_Syntax.args = [arg] - }) p in - let t = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = args - }) p in - t -let (lookup : - env -> - FStar_Syntax_Syntax.term -> - (tot_or_ghost * FStar_Syntax_Syntax.typ) result) - = - fun g -> - fun e -> - let uu___ = FStar_Syntax_TermHashTable.lookup e table in - match uu___ with - | FStar_Pervasives_Native.None -> - (record_cache_miss (); fail "not in cache") - | FStar_Pervasives_Native.Some he -> - let uu___1 = - context_included he.he_gamma - (g.tcenv).FStar_TypeChecker_Env.gamma in - if uu___1 - then - (record_cache_hit (); - (let uu___4 = FStar_Compiler_Effect.op_Bang dbg in - if uu___4 - then - let uu___5 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binding) - (g.tcenv).FStar_TypeChecker_Env.gamma in - let uu___6 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - let uu___7 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - (FStar_Pervasives_Native.snd - (FStar_Pervasives_Native.fst he.he_res)) in - let uu___8 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binding) he.he_gamma in - FStar_Compiler_Util.print4 - "cache hit\n %s |- %s : %s\nmatching env %s\n" uu___5 - uu___6 uu___7 uu___8 - else ()); - (fun uu___4 -> Success (he.he_res))) - else fail "not in cache" -let (check_no_escape : - FStar_Syntax_Syntax.binders -> FStar_Syntax_Syntax.term -> unit result) = - fun bs -> - fun t -> - let xs = FStar_Syntax_Free.names t in - let uu___ = - FStar_Compiler_Util.for_all - (fun b -> - let uu___1 = - FStar_Class_Setlike.mem () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) - b.FStar_Syntax_Syntax.binder_bv (Obj.magic xs) in - Prims.op_Negation uu___1) bs in - if uu___ - then fun uu___1 -> Success ((), FStar_Pervasives_Native.None) - else fail "Name escapes its scope" -let rec map : - 'a 'b . ('a -> 'b result) -> 'a Prims.list -> 'b Prims.list result = - fun f -> - fun l -> - match l with - | [] -> (fun uu___ -> Success ([], FStar_Pervasives_Native.None)) - | hd::tl -> - let uu___ = f hd in - (fun ctx0 -> - let uu___1 = uu___ ctx0 in - match uu___1 with - | Success (x, g1) -> - let uu___2 = - let uu___3 = - let uu___4 = map f tl in - fun ctx01 -> - let uu___5 = uu___4 ctx01 in - match uu___5 with - | Success (x1, g11) -> - let uu___6 = - let uu___7 uu___8 = - Success - ((x :: x1), FStar_Pervasives_Native.None) in - uu___7 ctx01 in - (match uu___6 with - | Success (y, g2) -> - let uu___7 = - let uu___8 = and_pre g11 g2 in (y, uu___8) in - Success uu___7 - | err -> err) - | Error err -> Error err in - uu___3 ctx0 in - (match uu___2 with - | Success (y, g2) -> - let uu___3 = let uu___4 = and_pre g1 g2 in (y, uu___4) in - Success uu___3 - | err -> err) - | Error err -> Error err) -let mapi : - 'a 'b . - (Prims.int -> 'a -> 'b result) -> 'a Prims.list -> 'b Prims.list result - = - fun f -> - fun l -> - let rec aux i l1 = - match l1 with - | [] -> (fun uu___ -> Success ([], FStar_Pervasives_Native.None)) - | hd::tl -> - let uu___ = f i hd in - (fun ctx0 -> - let uu___1 = uu___ ctx0 in - match uu___1 with - | Success (x, g1) -> - let uu___2 = - let uu___3 = - let uu___4 = aux (i + Prims.int_one) tl in - fun ctx01 -> - let uu___5 = uu___4 ctx01 in - match uu___5 with - | Success (x1, g11) -> - let uu___6 = - let uu___7 uu___8 = - Success - ((x :: x1), FStar_Pervasives_Native.None) in - uu___7 ctx01 in - (match uu___6 with - | Success (y, g2) -> - let uu___7 = - let uu___8 = and_pre g11 g2 in - (y, uu___8) in - Success uu___7 - | err -> err) - | Error err -> Error err in - uu___3 ctx0 in - (match uu___2 with - | Success (y, g2) -> - let uu___3 = - let uu___4 = and_pre g1 g2 in (y, uu___4) in - Success uu___3 - | err -> err) - | Error err -> Error err) in - aux Prims.int_zero l -let rec map2 : - 'a 'b 'c . - ('a -> 'b -> 'c result) -> - 'a Prims.list -> 'b Prims.list -> 'c Prims.list result - = - fun f -> - fun l1 -> - fun l2 -> - match (l1, l2) with - | ([], []) -> - (fun uu___ -> Success ([], FStar_Pervasives_Native.None)) - | (hd1::tl1, hd2::tl2) -> - let uu___ = f hd1 hd2 in - (fun ctx0 -> - let uu___1 = uu___ ctx0 in - match uu___1 with - | Success (x, g1) -> - let uu___2 = - let uu___3 = - let uu___4 = map2 f tl1 tl2 in - fun ctx01 -> - let uu___5 = uu___4 ctx01 in - match uu___5 with - | Success (x1, g11) -> - let uu___6 = - let uu___7 uu___8 = - Success - ((x :: x1), FStar_Pervasives_Native.None) in - uu___7 ctx01 in - (match uu___6 with - | Success (y, g2) -> - let uu___7 = - let uu___8 = and_pre g11 g2 in - (y, uu___8) in - Success uu___7 - | err -> err) - | Error err -> Error err in - uu___3 ctx0 in - (match uu___2 with - | Success (y, g2) -> - let uu___3 = - let uu___4 = and_pre g1 g2 in (y, uu___4) in - Success uu___3 - | err -> err) - | Error err -> Error err) -let rec fold : - 'a 'b . ('a -> 'b -> 'a result) -> 'a -> 'b Prims.list -> 'a result = - fun f -> - fun x -> - fun l -> - match l with - | [] -> (fun uu___ -> Success (x, FStar_Pervasives_Native.None)) - | hd::tl -> - let uu___ = f x hd in - (fun ctx0 -> - let uu___1 = uu___ ctx0 in - match uu___1 with - | Success (x1, g1) -> - let uu___2 = let uu___3 = fold f x1 tl in uu___3 ctx0 in - (match uu___2 with - | Success (y, g2) -> - let uu___3 = - let uu___4 = and_pre g1 g2 in (y, uu___4) in - Success uu___3 - | err -> err) - | Error err -> Error err) -let rec fold2 : - 'a 'b 'c . - ('a -> 'b -> 'c -> 'a result) -> - 'a -> 'b Prims.list -> 'c Prims.list -> 'a result - = - fun f -> - fun x -> - fun l1 -> - fun l2 -> - match (l1, l2) with - | ([], []) -> - (fun uu___ -> Success (x, FStar_Pervasives_Native.None)) - | (hd1::tl1, hd2::tl2) -> - let uu___ = f x hd1 hd2 in - (fun ctx0 -> - let uu___1 = uu___ ctx0 in - match uu___1 with - | Success (x1, g1) -> - let uu___2 = - let uu___3 = fold2 f x1 tl1 tl2 in uu___3 ctx0 in - (match uu___2 with - | Success (y, g2) -> - let uu___3 = - let uu___4 = and_pre g1 g2 in (y, uu___4) in - Success uu___3 - | err -> err) - | Error err -> Error err) -let rec iter2 : - 'a 'b . - 'a Prims.list -> - 'a Prims.list -> ('a -> 'a -> 'b -> 'b result) -> 'b -> 'b result - = - fun xs -> - fun ys -> - fun f -> - fun b1 -> - match (xs, ys) with - | ([], []) -> - (fun uu___ -> Success (b1, FStar_Pervasives_Native.None)) - | (x::xs1, y::ys1) -> - let uu___ = f x y b1 in - (fun ctx0 -> - let uu___1 = uu___ ctx0 in - match uu___1 with - | Success (x1, g1) -> - let uu___2 = - let uu___3 = iter2 xs1 ys1 f x1 in uu___3 ctx0 in - (match uu___2 with - | Success (y1, g2) -> - let uu___3 = - let uu___4 = and_pre g1 g2 in (y1, uu___4) in - Success uu___3 - | err -> err) - | Error err -> Error err) - | uu___ -> fail "Lists of differing length" -let (is_non_informative : - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.typ -> Prims.bool) = - fun g -> fun t -> FStar_TypeChecker_Normalize.non_info_norm g t -let (non_informative : env -> FStar_Syntax_Syntax.typ -> Prims.bool) = - fun g -> fun t -> is_non_informative g.tcenv t -let (as_comp : - env -> (tot_or_ghost * FStar_Syntax_Syntax.typ) -> FStar_Syntax_Syntax.comp) - = - fun g -> - fun et -> - match et with - | (E_Total, t) -> FStar_Syntax_Syntax.mk_Total t - | (E_Ghost, t) -> - let uu___ = non_informative g t in - if uu___ - then FStar_Syntax_Syntax.mk_Total t - else FStar_Syntax_Syntax.mk_GTotal t -let (comp_as_tot_or_ghost_and_type : - FStar_Syntax_Syntax.comp -> - (tot_or_ghost * FStar_Syntax_Syntax.typ) FStar_Pervasives_Native.option) - = - fun c -> - let uu___ = FStar_Syntax_Util.is_total_comp c in - if uu___ - then - FStar_Pervasives_Native.Some - (E_Total, (FStar_Syntax_Util.comp_result c)) - else - (let uu___2 = FStar_Syntax_Util.is_tot_or_gtot_comp c in - if uu___2 - then - FStar_Pervasives_Native.Some - (E_Ghost, (FStar_Syntax_Util.comp_result c)) - else FStar_Pervasives_Native.None) -let (join_eff : tot_or_ghost -> tot_or_ghost -> tot_or_ghost) = - fun e0 -> - fun e1 -> - match (e0, e1) with - | (E_Ghost, uu___) -> E_Ghost - | (uu___, E_Ghost) -> E_Ghost - | uu___ -> E_Total -let (join_eff_l : tot_or_ghost Prims.list -> tot_or_ghost) = - fun es -> FStar_List_Tot_Base.fold_right join_eff es E_Total -let (guard_not_allowed : Prims.bool result) = - fun ctx -> Success ((ctx.no_guard), FStar_Pervasives_Native.None) -let (unfolding_ok : Prims.bool result) = - fun ctx -> Success ((ctx.unfolding_ok), FStar_Pervasives_Native.None) -let debug : 'uuuuu . 'uuuuu -> (unit -> unit) -> unit = - fun g -> - fun f -> - let uu___ = FStar_Compiler_Effect.op_Bang dbg in - if uu___ then f () else () -let (showable_side : side FStar_Class_Show.showable) = - { - FStar_Class_Show.show = - (fun uu___ -> - match uu___ with - | Left -> "Left" - | Right -> "Right" - | Both -> "Both" - | Neither -> "Neither") - } -let (boolean_negation_simp : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - FStar_Pervasives_Native.option) - = - fun b -> - let uu___ = - FStar_Syntax_Hash.equal_term b FStar_Syntax_Util.exp_false_bool in - if uu___ - then FStar_Pervasives_Native.None - else - (let uu___2 = FStar_Syntax_Util.mk_boolean_negation b in - FStar_Pervasives_Native.Some uu___2) -let (combine_path_and_branch_condition : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.term)) - = - fun path_condition -> - fun branch_condition -> - fun branch_equality -> - let this_path_condition = - let bc = - match branch_condition with - | FStar_Pervasives_Native.None -> branch_equality - | FStar_Pervasives_Native.Some bc1 -> - let uu___ = - let uu___1 = FStar_Syntax_Util.b2t bc1 in - [uu___1; branch_equality] in - FStar_Syntax_Util.mk_conj_l uu___ in - let uu___ = FStar_Syntax_Util.b2t path_condition in - FStar_Syntax_Util.mk_conj uu___ bc in - let next_path_condition = - match branch_condition with - | FStar_Pervasives_Native.None -> FStar_Syntax_Util.exp_false_bool - | FStar_Pervasives_Native.Some bc -> - let uu___ = - FStar_Syntax_Hash.equal_term path_condition - FStar_Syntax_Util.exp_true_bool in - if uu___ - then FStar_Syntax_Util.mk_boolean_negation bc - else - (let uu___2 = FStar_Syntax_Util.mk_boolean_negation bc in - FStar_Syntax_Util.mk_and path_condition uu___2) in - (this_path_condition, next_path_condition) -let (maybe_relate_after_unfolding : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term -> side) - = - fun g -> - fun t0 -> - fun t1 -> - let dd0 = FStar_TypeChecker_Env.delta_depth_of_term g t0 in - let dd1 = FStar_TypeChecker_Env.delta_depth_of_term g t1 in - if dd0 = dd1 - then Both - else - (let uu___1 = - FStar_TypeChecker_Common.delta_depth_greater_than dd0 dd1 in - if uu___1 then Left else Right) -let rec (check_relation : - env -> - relation -> - FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.typ -> unit result) - = - fun g -> - fun rel -> - fun t0 -> - fun t1 -> - let err uu___ = - match rel with - | EQUALITY -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t0 in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.format2 "not equal terms: %s <> %s" - uu___2 uu___3 in - fail uu___1 - | uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t0 in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.format2 "%s is not a subtype of %s" - uu___3 uu___4 in - fail uu___2 in - let rel_to_string rel1 = - match rel1 with | EQUALITY -> "=?=" | SUBTYPING uu___ -> "<:?" in - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg in - if uu___1 - then - let uu___2 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t0 in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t0 in - let uu___4 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t1 in - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.print5 "check_relation (%s) %s %s (%s) %s\n" - uu___2 uu___3 (rel_to_string rel) uu___4 uu___5 - else ()); - (fun ctx0 -> - let uu___1 = guard_not_allowed ctx0 in - match uu___1 with - | Success (x, g1) -> - let uu___2 = - let uu___3 = - let guard_ok = Prims.op_Negation x in - let head_matches t01 t11 = - let head0 = FStar_Syntax_Util.leftmost_head t01 in - let head1 = FStar_Syntax_Util.leftmost_head t11 in - let uu___4 = - let uu___5 = - let uu___6 = FStar_Syntax_Util.un_uinst head0 in - uu___6.FStar_Syntax_Syntax.n in - let uu___6 = - let uu___7 = FStar_Syntax_Util.un_uinst head1 in - uu___7.FStar_Syntax_Syntax.n in - (uu___5, uu___6) in - match uu___4 with - | (FStar_Syntax_Syntax.Tm_fvar fv0, - FStar_Syntax_Syntax.Tm_fvar fv1) -> - FStar_Syntax_Syntax.fv_eq fv0 fv1 - | (FStar_Syntax_Syntax.Tm_name x0, - FStar_Syntax_Syntax.Tm_name x1) -> - FStar_Syntax_Syntax.bv_eq x0 x1 - | (FStar_Syntax_Syntax.Tm_constant c0, - FStar_Syntax_Syntax.Tm_constant c1) -> - equal_term head0 head1 - | (FStar_Syntax_Syntax.Tm_type uu___5, - FStar_Syntax_Syntax.Tm_type uu___6) -> true - | (FStar_Syntax_Syntax.Tm_arrow uu___5, - FStar_Syntax_Syntax.Tm_arrow uu___6) -> true - | (FStar_Syntax_Syntax.Tm_match uu___5, - FStar_Syntax_Syntax.Tm_match uu___6) -> true - | uu___5 -> false in - let which_side_to_unfold t01 t11 = - maybe_relate_after_unfolding g.tcenv t01 t11 in - let maybe_unfold_side side1 t01 t11 = - FStar_Profiling.profile - (fun uu___4 -> - match side1 with - | Neither -> FStar_Pervasives_Native.None - | Both -> - let uu___5 = - let uu___6 = - FStar_TypeChecker_Normalize.maybe_unfold_head - g.tcenv t01 in - let uu___7 = - FStar_TypeChecker_Normalize.maybe_unfold_head - g.tcenv t11 in - (uu___6, uu___7) in - (match uu___5 with - | (FStar_Pervasives_Native.Some t02, - FStar_Pervasives_Native.Some t12) -> - FStar_Pervasives_Native.Some (t02, t12) - | (FStar_Pervasives_Native.Some t02, - FStar_Pervasives_Native.None) -> - FStar_Pervasives_Native.Some (t02, t11) - | (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.Some t12) -> - FStar_Pervasives_Native.Some (t01, t12) - | uu___6 -> FStar_Pervasives_Native.None) - | Left -> - let uu___5 = - FStar_TypeChecker_Normalize.maybe_unfold_head - g.tcenv t01 in - (match uu___5 with - | FStar_Pervasives_Native.Some t02 -> - FStar_Pervasives_Native.Some (t02, t11) - | uu___6 -> FStar_Pervasives_Native.None) - | Right -> - let uu___5 = - FStar_TypeChecker_Normalize.maybe_unfold_head - g.tcenv t11 in - (match uu___5 with - | FStar_Pervasives_Native.Some t12 -> - FStar_Pervasives_Native.Some (t01, t12) - | uu___6 -> FStar_Pervasives_Native.None)) - FStar_Pervasives_Native.None - "FStar.TypeChecker.Core.maybe_unfold_side" in - let maybe_unfold t01 t11 ctx01 = - let uu___4 = unfolding_ok ctx01 in - match uu___4 with - | Success (x1, g11) -> - let uu___5 = - let uu___6 = - if x1 - then - let uu___7 = - let uu___8 = which_side_to_unfold t01 t11 in - maybe_unfold_side uu___8 t01 t11 in - fun uu___8 -> - Success - (uu___7, FStar_Pervasives_Native.None) - else - (fun uu___8 -> - Success - (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None)) in - uu___6 ctx01 in - (match uu___5 with - | Success (y, g2) -> - let uu___6 = - let uu___7 = and_pre g11 g2 in (y, uu___7) in - Success uu___6 - | err1 -> err1) - | Error err1 -> Error err1 in - let emit_guard t01 t11 = - let uu___4 ctx = - let ctx1 = - { - no_guard = (ctx.no_guard); - unfolding_ok = (ctx.unfolding_ok); - error_context = - (("checking lhs while emitting guard", - FStar_Pervasives_Native.None) :: - (ctx.error_context)) - } in - let uu___5 = do_check g t01 in uu___5 ctx1 in - fun ctx01 -> - let uu___5 = uu___4 ctx01 in - match uu___5 with - | Success (x1, g11) -> - let uu___6 = - let uu___7 = - match x1 with - | (uu___8, t_typ) -> - let uu___9 = universe_of g t_typ in - (fun ctx02 -> - let uu___10 = uu___9 ctx02 in - match uu___10 with - | Success (x2, g12) -> - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Syntax_Util.mk_eq2 x2 - t_typ t01 t11 in - guard uu___13 in - uu___12 ctx02 in - (match uu___11 with - | Success (y, g2) -> - let uu___12 = - let uu___13 = - and_pre g12 g2 in - ((), uu___13) in - Success uu___12 - | err1 -> err1) - | Error err1 -> Error err1) in - uu___7 ctx01 in - (match uu___6 with - | Success (y, g2) -> - let uu___7 = - let uu___8 = and_pre g11 g2 in - ((), uu___8) in - Success uu___7 - | err1 -> err1) - | Error err1 -> Error err1 in - let fallback t01 t11 = - if guard_ok - then - let uu___4 = (equatable g t01) || (equatable g t11) in - (if uu___4 then emit_guard t01 t11 else err ()) - else err () in - let maybe_unfold_side_and_retry side1 t01 t11 ctx01 = - let uu___4 = unfolding_ok ctx01 in - match uu___4 with - | Success (x1, g11) -> - let uu___5 = - let uu___6 = - if x1 - then - let uu___7 = maybe_unfold_side side1 t01 t11 in - match uu___7 with - | FStar_Pervasives_Native.None -> - fallback t01 t11 - | FStar_Pervasives_Native.Some (t02, t12) -> - check_relation g rel t02 t12 - else fallback t01 t11 in - uu___6 ctx01 in - (match uu___5 with - | Success (y, g2) -> - let uu___6 = - let uu___7 = and_pre g11 g2 in ((), uu___7) in - Success uu___6 - | err1 -> err1) - | Error err1 -> Error err1 in - let maybe_unfold_and_retry t01 t11 = - let uu___4 = which_side_to_unfold t01 t11 in - maybe_unfold_side_and_retry uu___4 t01 t11 in - let beta_iota_reduce t = - let t2 = FStar_Syntax_Subst.compress t in - let t3 = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.HNF; - FStar_TypeChecker_Env.Weak; - FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Iota; - FStar_TypeChecker_Env.Primops] g.tcenv t2 in - match t3.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_refine uu___4 -> - FStar_Syntax_Util.flatten_refinement t3 - | uu___4 -> t3 in - let beta_iota_reduce1 t = - FStar_Profiling.profile - (fun uu___4 -> beta_iota_reduce t) - FStar_Pervasives_Native.None - "FStar.TypeChecker.Core.beta_iota_reduce" in - let t01 = - let uu___4 = - let uu___5 = beta_iota_reduce1 t0 in - FStar_Syntax_Subst.compress uu___5 in - FStar_Syntax_Util.unlazy_emb uu___4 in - let t11 = - let uu___4 = - let uu___5 = beta_iota_reduce1 t1 in - FStar_Syntax_Subst.compress uu___5 in - FStar_Syntax_Util.unlazy_emb uu___4 in - let check_relation1 g2 rel1 t02 t12 ctx = - let ctx1 = - { - no_guard = (ctx.no_guard); - unfolding_ok = (ctx.unfolding_ok); - error_context = - (("check_relation", - (FStar_Pervasives_Native.Some - (CtxRel (t02, rel1, t12)))) :: - (ctx.error_context)) - } in - let uu___4 = check_relation g2 rel1 t02 t12 in - uu___4 ctx1 in - let uu___4 = equal_term t01 t11 in - if uu___4 - then - fun uu___5 -> - Success ((), FStar_Pervasives_Native.None) - else - (match ((t01.FStar_Syntax_Syntax.n), - (t11.FStar_Syntax_Syntax.n)) - with - | (FStar_Syntax_Syntax.Tm_type u0, - FStar_Syntax_Syntax.Tm_type u1) -> - let uu___6 = - FStar_TypeChecker_Rel.teq_nosmt_force g.tcenv - t01 t11 in - if uu___6 - then - (fun uu___7 -> - Success ((), FStar_Pervasives_Native.None)) - else err () - | (FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t02; - FStar_Syntax_Syntax.meta = - FStar_Syntax_Syntax.Meta_pattern uu___6;_}, - uu___7) -> check_relation1 g rel t02 t11 - | (FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t02; - FStar_Syntax_Syntax.meta = - FStar_Syntax_Syntax.Meta_named uu___6;_}, - uu___7) -> check_relation1 g rel t02 t11 - | (FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t02; - FStar_Syntax_Syntax.meta = - FStar_Syntax_Syntax.Meta_labeled uu___6;_}, - uu___7) -> check_relation1 g rel t02 t11 - | (FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t02; - FStar_Syntax_Syntax.meta = - FStar_Syntax_Syntax.Meta_desugared uu___6;_}, - uu___7) -> check_relation1 g rel t02 t11 - | (FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t02; - FStar_Syntax_Syntax.asc = uu___6; - FStar_Syntax_Syntax.eff_opt = uu___7;_}, - uu___8) -> check_relation1 g rel t02 t11 - | (uu___6, FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t12; - FStar_Syntax_Syntax.meta = - FStar_Syntax_Syntax.Meta_pattern uu___7;_}) - -> check_relation1 g rel t01 t12 - | (uu___6, FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t12; - FStar_Syntax_Syntax.meta = - FStar_Syntax_Syntax.Meta_named uu___7;_}) - -> check_relation1 g rel t01 t12 - | (uu___6, FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t12; - FStar_Syntax_Syntax.meta = - FStar_Syntax_Syntax.Meta_labeled uu___7;_}) - -> check_relation1 g rel t01 t12 - | (uu___6, FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t12; - FStar_Syntax_Syntax.meta = - FStar_Syntax_Syntax.Meta_desugared uu___7;_}) - -> check_relation1 g rel t01 t12 - | (uu___6, FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t12; - FStar_Syntax_Syntax.asc = uu___7; - FStar_Syntax_Syntax.eff_opt = uu___8;_}) - -> check_relation1 g rel t01 t12 - | (FStar_Syntax_Syntax.Tm_uinst (f0, us0), - FStar_Syntax_Syntax.Tm_uinst (f1, us1)) -> - let uu___6 = equal_term f0 f1 in - if uu___6 - then - let uu___7 = - FStar_TypeChecker_Rel.teq_nosmt_force - g.tcenv t01 t11 in - (if uu___7 - then - fun uu___8 -> - Success ((), FStar_Pervasives_Native.None) - else err ()) - else maybe_unfold_and_retry t01 t11 - | (FStar_Syntax_Syntax.Tm_fvar uu___6, - FStar_Syntax_Syntax.Tm_fvar uu___7) -> - maybe_unfold_and_retry t01 t11 - | (FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x0; - FStar_Syntax_Syntax.phi = f0;_}, - FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x1; - FStar_Syntax_Syntax.phi = f1;_}) - -> - let uu___6 = - head_matches x0.FStar_Syntax_Syntax.sort - x1.FStar_Syntax_Syntax.sort in - if uu___6 - then - let uu___7 = - check_relation1 g EQUALITY - x0.FStar_Syntax_Syntax.sort - x1.FStar_Syntax_Syntax.sort in - (fun ctx01 -> - let uu___8 = uu___7 ctx01 in - match uu___8 with - | Success (x2, g11) -> - let uu___9 = - let uu___10 = - let uu___11 = - universe_of g - x0.FStar_Syntax_Syntax.sort in - fun ctx02 -> - let uu___12 = uu___11 ctx02 in - match uu___12 with - | Success (x3, g12) -> - let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = - FStar_Syntax_Syntax.mk_binder - x0 in - open_term g uu___16 f0 in - match uu___15 with - | (g2, b, f01) -> - let f11 = - FStar_Syntax_Subst.subst - [FStar_Syntax_Syntax.DB - (Prims.int_zero, - (b.FStar_Syntax_Syntax.binder_bv))] - f1 in - (fun ctx03 -> - let uu___16 = - guard_not_allowed - ctx03 in - match uu___16 with - | Success (x4, g13) - -> - let uu___17 = - let uu___18 = - if x4 - then - let uu___19 - = - check_relation1 - g2 - EQUALITY - f01 f11 in - with_binders - [b] - [x3] - uu___19 - else - ( - match rel - with - | - EQUALITY - -> - let uu___20 - = - let uu___21 - = - check_relation1 - g2 - EQUALITY - f01 f11 in - fun ctx - -> - let uu___22 - = - uu___21 - ctx in - match uu___22 - with - | - Error - uu___23 - -> - let uu___24 - = - let uu___25 - = - FStar_Syntax_Util.mk_iff - f01 f11 in - guard - uu___25 in - uu___24 - ctx - | - res -> - res in - with_binders - [b] - [x3] - uu___20 - | - SUBTYPING - (FStar_Pervasives_Native.Some - tm) -> - let uu___20 - = - let uu___21 - = - FStar_Syntax_Util.mk_imp - f01 f11 in - FStar_Syntax_Subst.subst - [ - FStar_Syntax_Syntax.NT - ((b.FStar_Syntax_Syntax.binder_bv), - tm)] - uu___21 in - guard - uu___20 - | - SUBTYPING - (FStar_Pervasives_Native.None) - -> - let uu___20 - = - let uu___21 - = - FStar_Syntax_Util.mk_imp - f01 f11 in - FStar_Syntax_Util.mk_forall - x3 - b.FStar_Syntax_Syntax.binder_bv - uu___21 in - guard - uu___20) in - uu___18 ctx03 in - (match uu___17 - with - | Success - (y, g21) - -> - let uu___18 - = - let uu___19 - = - and_pre - g13 g21 in - ((), - uu___19) in - Success - uu___18 - | err1 -> err1) - | Error err1 -> - Error err1) in - uu___14 ctx02 in - (match uu___13 with - | Success (y, g2) -> - let uu___14 = - let uu___15 = - and_pre g12 g2 in - ((), uu___15) in - Success uu___14 - | err1 -> err1) - | Error err1 -> Error err1 in - uu___10 ctx01 in - (match uu___9 with - | Success (y, g2) -> - let uu___10 = - let uu___11 = and_pre g11 g2 in - ((), uu___11) in - Success uu___10 - | err1 -> err1) - | Error err1 -> Error err1) - else - (let uu___8 = - maybe_unfold x0.FStar_Syntax_Syntax.sort - x1.FStar_Syntax_Syntax.sort in - fun ctx01 -> - let uu___9 = uu___8 ctx01 in - match uu___9 with - | Success (x2, g11) -> - let uu___10 = - let uu___11 = - match x2 with - | FStar_Pervasives_Native.None -> - ((let uu___13 = - FStar_Compiler_Effect.op_Bang - dbg in - if uu___13 - then - let uu___14 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - x0.FStar_Syntax_Syntax.sort in - let uu___15 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - x1.FStar_Syntax_Syntax.sort in - FStar_Compiler_Util.print2 - "Cannot match ref heads %s and %s\n" - uu___14 uu___15 - else ()); - fallback t01 t11) - | FStar_Pervasives_Native.Some - (t02, t12) -> - let lhs = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_refine - { - FStar_Syntax_Syntax.b = - { - FStar_Syntax_Syntax.ppname - = - (x0.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index - = - (x0.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort - = t02 - }; - FStar_Syntax_Syntax.phi - = f0 - }) - t02.FStar_Syntax_Syntax.pos in - let rhs = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_refine - { - FStar_Syntax_Syntax.b = - { - FStar_Syntax_Syntax.ppname - = - (x1.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index - = - (x1.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort - = t12 - }; - FStar_Syntax_Syntax.phi - = f1 - }) - t12.FStar_Syntax_Syntax.pos in - let uu___12 = - FStar_Syntax_Util.flatten_refinement - lhs in - let uu___13 = - FStar_Syntax_Util.flatten_refinement - rhs in - check_relation1 g rel uu___12 - uu___13 in - uu___11 ctx01 in - (match uu___10 with - | Success (y, g2) -> - let uu___11 = - let uu___12 = and_pre g11 g2 in - ((), uu___12) in - Success uu___11 - | err1 -> err1) - | Error err1 -> Error err1) - | (FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x0; - FStar_Syntax_Syntax.phi = f0;_}, - uu___6) -> - let uu___7 = - head_matches x0.FStar_Syntax_Syntax.sort t11 in - if uu___7 - then - let uu___8 = - if rel = EQUALITY - then - let uu___9 = - universe_of g x0.FStar_Syntax_Syntax.sort in - fun ctx01 -> - let uu___10 = uu___9 ctx01 in - match uu___10 with - | Success (x1, g11) -> - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - FStar_Syntax_Syntax.mk_binder - x0 in - open_term g uu___14 f0 in - match uu___13 with - | (g2, b0, f01) -> - (fun ctx02 -> - let uu___14 = - guard_not_allowed ctx02 in - match uu___14 with - | Success (x2, g12) -> - let uu___15 = - let uu___16 = - if x2 - then - let uu___17 = - check_relation1 - g2 EQUALITY - FStar_Syntax_Util.t_true - f01 in - with_binders - [b0] [x1] - uu___17 - else - (let uu___18 = - let uu___19 = - check_relation1 - g2 - EQUALITY - FStar_Syntax_Util.t_true - f01 in - fun ctx -> - let uu___20 - = - uu___19 - ctx in - match uu___20 - with - | Error - uu___21 - -> - let uu___22 - = - guard f01 in - uu___22 - ctx - | res -> - res in - with_binders - [b0] - [x1] uu___18) in - uu___16 ctx02 in - (match uu___15 with - | Success (y, g21) -> - let uu___16 = - let uu___17 = - and_pre g12 - g21 in - ((), uu___17) in - Success uu___16 - | err1 -> err1) - | Error err1 -> Error err1) in - uu___12 ctx01 in - (match uu___11 with - | Success (y, g2) -> - let uu___12 = - let uu___13 = and_pre g11 g2 in - ((), uu___13) in - Success uu___12 - | err1 -> err1) - | Error err1 -> Error err1 - else - (fun uu___10 -> - Success - ((), FStar_Pervasives_Native.None)) in - (fun ctx01 -> - let uu___9 = uu___8 ctx01 in - match uu___9 with - | Success (x1, g11) -> - let uu___10 = - let uu___11 = - check_relation1 g rel - x0.FStar_Syntax_Syntax.sort t11 in - uu___11 ctx01 in - (match uu___10 with - | Success (y, g2) -> - let uu___11 = - let uu___12 = and_pre g11 g2 in - ((), uu___12) in - Success uu___11 - | err1 -> err1) - | Error err1 -> Error err1) - else - (let uu___9 = - maybe_unfold x0.FStar_Syntax_Syntax.sort t11 in - fun ctx01 -> - let uu___10 = uu___9 ctx01 in - match uu___10 with - | Success (x1, g11) -> - let uu___11 = - let uu___12 = - match x1 with - | FStar_Pervasives_Native.None -> - fallback t01 t11 - | FStar_Pervasives_Native.Some - (t02, t12) -> - let lhs = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_refine - { - FStar_Syntax_Syntax.b = - { - FStar_Syntax_Syntax.ppname - = - (x0.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index - = - (x0.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort - = t02 - }; - FStar_Syntax_Syntax.phi - = f0 - }) - t02.FStar_Syntax_Syntax.pos in - let uu___13 = - FStar_Syntax_Util.flatten_refinement - lhs in - check_relation1 g rel uu___13 - t12 in - uu___12 ctx01 in - (match uu___11 with - | Success (y, g2) -> - let uu___12 = - let uu___13 = and_pre g11 g2 in - ((), uu___13) in - Success uu___12 - | err1 -> err1) - | Error err1 -> Error err1) - | (uu___6, FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x1; - FStar_Syntax_Syntax.phi = f1;_}) - -> - let uu___7 = - head_matches t01 x1.FStar_Syntax_Syntax.sort in - if uu___7 - then - let uu___8 = - universe_of g x1.FStar_Syntax_Syntax.sort in - (fun ctx01 -> - let uu___9 = uu___8 ctx01 in - match uu___9 with - | Success (x2, g11) -> - let uu___10 = - let uu___11 = - let uu___12 = - check_relation1 g EQUALITY t01 - x1.FStar_Syntax_Syntax.sort in - fun ctx02 -> - let uu___13 = uu___12 ctx02 in - match uu___13 with - | Success (x3, g12) -> - let uu___14 = - let uu___15 = - let uu___16 = - let uu___17 = - FStar_Syntax_Syntax.mk_binder - x1 in - open_term g uu___17 f1 in - match uu___16 with - | (g2, b1, f11) -> - (fun ctx03 -> - let uu___17 = - guard_not_allowed - ctx03 in - match uu___17 with - | Success (x4, g13) - -> - let uu___18 = - let uu___19 = - if x4 - then - let uu___20 - = - check_relation1 - g2 - EQUALITY - FStar_Syntax_Util.t_true - f11 in - with_binders - [b1] - [x2] - uu___20 - else - ( - match rel - with - | - EQUALITY - -> - let uu___21 - = - let uu___22 - = - check_relation1 - g2 - EQUALITY - FStar_Syntax_Util.t_true - f11 in - fun ctx - -> - let uu___23 - = - uu___22 - ctx in - match uu___23 - with - | - Error - uu___24 - -> - let uu___25 - = - guard f11 in - uu___25 - ctx - | - res -> - res in - with_binders - [b1] - [x2] - uu___21 - | - SUBTYPING - (FStar_Pervasives_Native.Some - tm) -> - let uu___21 - = - FStar_Syntax_Subst.subst - [ - FStar_Syntax_Syntax.NT - ((b1.FStar_Syntax_Syntax.binder_bv), - tm)] f11 in - guard - uu___21 - | - SUBTYPING - (FStar_Pervasives_Native.None) - -> - let uu___21 - = - FStar_Syntax_Util.mk_forall - x2 - b1.FStar_Syntax_Syntax.binder_bv - f11 in - guard - uu___21) in - uu___19 ctx03 in - (match uu___18 - with - | Success - (y, g21) - -> - let uu___19 - = - let uu___20 - = - and_pre - g13 g21 in - ((), - uu___20) in - Success - uu___19 - | err1 -> err1) - | Error err1 -> - Error err1) in - uu___15 ctx02 in - (match uu___14 with - | Success (y, g2) -> - let uu___15 = - let uu___16 = - and_pre g12 g2 in - ((), uu___16) in - Success uu___15 - | err1 -> err1) - | Error err1 -> Error err1 in - uu___11 ctx01 in - (match uu___10 with - | Success (y, g2) -> - let uu___11 = - let uu___12 = and_pre g11 g2 in - ((), uu___12) in - Success uu___11 - | err1 -> err1) - | Error err1 -> Error err1) - else - (let uu___9 = - maybe_unfold t01 x1.FStar_Syntax_Syntax.sort in - fun ctx01 -> - let uu___10 = uu___9 ctx01 in - match uu___10 with - | Success (x2, g11) -> - let uu___11 = - let uu___12 = - match x2 with - | FStar_Pervasives_Native.None -> - fallback t01 t11 - | FStar_Pervasives_Native.Some - (t02, t12) -> - let rhs = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_refine - { - FStar_Syntax_Syntax.b = - { - FStar_Syntax_Syntax.ppname - = - (x1.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index - = - (x1.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort - = t12 - }; - FStar_Syntax_Syntax.phi - = f1 - }) - t12.FStar_Syntax_Syntax.pos in - let uu___13 = - FStar_Syntax_Util.flatten_refinement - rhs in - check_relation1 g rel t02 - uu___13 in - uu___12 ctx01 in - (match uu___11 with - | Success (y, g2) -> - let uu___12 = - let uu___13 = and_pre g11 g2 in - ((), uu___13) in - Success uu___12 - | err1 -> err1) - | Error err1 -> Error err1) - | (FStar_Syntax_Syntax.Tm_uinst uu___6, uu___7) -> - let head_matches1 = head_matches t01 t11 in - let uu___8 = - FStar_Syntax_Util.leftmost_head_and_args t01 in - (match uu___8 with - | (head0, args0) -> - let uu___9 = - FStar_Syntax_Util.leftmost_head_and_args - t11 in - (match uu___9 with - | (head1, args1) -> - if - Prims.op_Negation - (head_matches1 && - ((FStar_Compiler_List.length - args0) - = - (FStar_Compiler_List.length - args1))) - then maybe_unfold_and_retry t01 t11 - else - (let compare_head_and_args uu___11 = - let uu___12 = - let uu___13 = - check_relation1 g EQUALITY - head0 head1 in - fun ctx01 -> - let uu___14 = uu___13 ctx01 in - match uu___14 with - | Success (x1, g11) -> - let uu___15 = - let uu___16 = - check_relation_args g - EQUALITY args0 args1 in - uu___16 ctx01 in - (match uu___15 with - | Success (y, g2) -> - let uu___16 = - let uu___17 = - and_pre g11 g2 in - ((), uu___17) in - Success uu___16 - | err1 -> err1) - | Error err1 -> Error err1 in - fun ctx -> - let uu___13 = uu___12 ctx in - match uu___13 with - | Error uu___14 -> - let uu___15 = - maybe_unfold_side_and_retry - Both t01 t11 in - uu___15 ctx - | res -> res in - let uu___11 = - (guard_ok && (rel = EQUALITY)) && - ((equatable g t01) || - (equatable g t11)) in - if uu___11 - then - let uu___12 = - let uu___13 = - compare_head_and_args () in - no_guard uu___13 in - fun ctx -> - let uu___13 = uu___12 ctx in - match uu___13 with - | Error uu___14 -> - let uu___15 = - emit_guard t01 t11 in - uu___15 ctx - | res -> res - else compare_head_and_args ()))) - | (FStar_Syntax_Syntax.Tm_fvar uu___6, uu___7) -> - let head_matches1 = head_matches t01 t11 in - let uu___8 = - FStar_Syntax_Util.leftmost_head_and_args t01 in - (match uu___8 with - | (head0, args0) -> - let uu___9 = - FStar_Syntax_Util.leftmost_head_and_args - t11 in - (match uu___9 with - | (head1, args1) -> - if - Prims.op_Negation - (head_matches1 && - ((FStar_Compiler_List.length - args0) - = - (FStar_Compiler_List.length - args1))) - then maybe_unfold_and_retry t01 t11 - else - (let compare_head_and_args uu___11 = - let uu___12 = - let uu___13 = - check_relation1 g EQUALITY - head0 head1 in - fun ctx01 -> - let uu___14 = uu___13 ctx01 in - match uu___14 with - | Success (x1, g11) -> - let uu___15 = - let uu___16 = - check_relation_args g - EQUALITY args0 args1 in - uu___16 ctx01 in - (match uu___15 with - | Success (y, g2) -> - let uu___16 = - let uu___17 = - and_pre g11 g2 in - ((), uu___17) in - Success uu___16 - | err1 -> err1) - | Error err1 -> Error err1 in - fun ctx -> - let uu___13 = uu___12 ctx in - match uu___13 with - | Error uu___14 -> - let uu___15 = - maybe_unfold_side_and_retry - Both t01 t11 in - uu___15 ctx - | res -> res in - let uu___11 = - (guard_ok && (rel = EQUALITY)) && - ((equatable g t01) || - (equatable g t11)) in - if uu___11 - then - let uu___12 = - let uu___13 = - compare_head_and_args () in - no_guard uu___13 in - fun ctx -> - let uu___13 = uu___12 ctx in - match uu___13 with - | Error uu___14 -> - let uu___15 = - emit_guard t01 t11 in - uu___15 ctx - | res -> res - else compare_head_and_args ()))) - | (FStar_Syntax_Syntax.Tm_app uu___6, uu___7) -> - let head_matches1 = head_matches t01 t11 in - let uu___8 = - FStar_Syntax_Util.leftmost_head_and_args t01 in - (match uu___8 with - | (head0, args0) -> - let uu___9 = - FStar_Syntax_Util.leftmost_head_and_args - t11 in - (match uu___9 with - | (head1, args1) -> - if - Prims.op_Negation - (head_matches1 && - ((FStar_Compiler_List.length - args0) - = - (FStar_Compiler_List.length - args1))) - then maybe_unfold_and_retry t01 t11 - else - (let compare_head_and_args uu___11 = - let uu___12 = - let uu___13 = - check_relation1 g EQUALITY - head0 head1 in - fun ctx01 -> - let uu___14 = uu___13 ctx01 in - match uu___14 with - | Success (x1, g11) -> - let uu___15 = - let uu___16 = - check_relation_args g - EQUALITY args0 args1 in - uu___16 ctx01 in - (match uu___15 with - | Success (y, g2) -> - let uu___16 = - let uu___17 = - and_pre g11 g2 in - ((), uu___17) in - Success uu___16 - | err1 -> err1) - | Error err1 -> Error err1 in - fun ctx -> - let uu___13 = uu___12 ctx in - match uu___13 with - | Error uu___14 -> - let uu___15 = - maybe_unfold_side_and_retry - Both t01 t11 in - uu___15 ctx - | res -> res in - let uu___11 = - (guard_ok && (rel = EQUALITY)) && - ((equatable g t01) || - (equatable g t11)) in - if uu___11 - then - let uu___12 = - let uu___13 = - compare_head_and_args () in - no_guard uu___13 in - fun ctx -> - let uu___13 = uu___12 ctx in - match uu___13 with - | Error uu___14 -> - let uu___15 = - emit_guard t01 t11 in - uu___15 ctx - | res -> res - else compare_head_and_args ()))) - | (uu___6, FStar_Syntax_Syntax.Tm_uinst uu___7) -> - let head_matches1 = head_matches t01 t11 in - let uu___8 = - FStar_Syntax_Util.leftmost_head_and_args t01 in - (match uu___8 with - | (head0, args0) -> - let uu___9 = - FStar_Syntax_Util.leftmost_head_and_args - t11 in - (match uu___9 with - | (head1, args1) -> - if - Prims.op_Negation - (head_matches1 && - ((FStar_Compiler_List.length - args0) - = - (FStar_Compiler_List.length - args1))) - then maybe_unfold_and_retry t01 t11 - else - (let compare_head_and_args uu___11 = - let uu___12 = - let uu___13 = - check_relation1 g EQUALITY - head0 head1 in - fun ctx01 -> - let uu___14 = uu___13 ctx01 in - match uu___14 with - | Success (x1, g11) -> - let uu___15 = - let uu___16 = - check_relation_args g - EQUALITY args0 args1 in - uu___16 ctx01 in - (match uu___15 with - | Success (y, g2) -> - let uu___16 = - let uu___17 = - and_pre g11 g2 in - ((), uu___17) in - Success uu___16 - | err1 -> err1) - | Error err1 -> Error err1 in - fun ctx -> - let uu___13 = uu___12 ctx in - match uu___13 with - | Error uu___14 -> - let uu___15 = - maybe_unfold_side_and_retry - Both t01 t11 in - uu___15 ctx - | res -> res in - let uu___11 = - (guard_ok && (rel = EQUALITY)) && - ((equatable g t01) || - (equatable g t11)) in - if uu___11 - then - let uu___12 = - let uu___13 = - compare_head_and_args () in - no_guard uu___13 in - fun ctx -> - let uu___13 = uu___12 ctx in - match uu___13 with - | Error uu___14 -> - let uu___15 = - emit_guard t01 t11 in - uu___15 ctx - | res -> res - else compare_head_and_args ()))) - | (uu___6, FStar_Syntax_Syntax.Tm_fvar uu___7) -> - let head_matches1 = head_matches t01 t11 in - let uu___8 = - FStar_Syntax_Util.leftmost_head_and_args t01 in - (match uu___8 with - | (head0, args0) -> - let uu___9 = - FStar_Syntax_Util.leftmost_head_and_args - t11 in - (match uu___9 with - | (head1, args1) -> - if - Prims.op_Negation - (head_matches1 && - ((FStar_Compiler_List.length - args0) - = - (FStar_Compiler_List.length - args1))) - then maybe_unfold_and_retry t01 t11 - else - (let compare_head_and_args uu___11 = - let uu___12 = - let uu___13 = - check_relation1 g EQUALITY - head0 head1 in - fun ctx01 -> - let uu___14 = uu___13 ctx01 in - match uu___14 with - | Success (x1, g11) -> - let uu___15 = - let uu___16 = - check_relation_args g - EQUALITY args0 args1 in - uu___16 ctx01 in - (match uu___15 with - | Success (y, g2) -> - let uu___16 = - let uu___17 = - and_pre g11 g2 in - ((), uu___17) in - Success uu___16 - | err1 -> err1) - | Error err1 -> Error err1 in - fun ctx -> - let uu___13 = uu___12 ctx in - match uu___13 with - | Error uu___14 -> - let uu___15 = - maybe_unfold_side_and_retry - Both t01 t11 in - uu___15 ctx - | res -> res in - let uu___11 = - (guard_ok && (rel = EQUALITY)) && - ((equatable g t01) || - (equatable g t11)) in - if uu___11 - then - let uu___12 = - let uu___13 = - compare_head_and_args () in - no_guard uu___13 in - fun ctx -> - let uu___13 = uu___12 ctx in - match uu___13 with - | Error uu___14 -> - let uu___15 = - emit_guard t01 t11 in - uu___15 ctx - | res -> res - else compare_head_and_args ()))) - | (uu___6, FStar_Syntax_Syntax.Tm_app uu___7) -> - let head_matches1 = head_matches t01 t11 in - let uu___8 = - FStar_Syntax_Util.leftmost_head_and_args t01 in - (match uu___8 with - | (head0, args0) -> - let uu___9 = - FStar_Syntax_Util.leftmost_head_and_args - t11 in - (match uu___9 with - | (head1, args1) -> - if - Prims.op_Negation - (head_matches1 && - ((FStar_Compiler_List.length - args0) - = - (FStar_Compiler_List.length - args1))) - then maybe_unfold_and_retry t01 t11 - else - (let compare_head_and_args uu___11 = - let uu___12 = - let uu___13 = - check_relation1 g EQUALITY - head0 head1 in - fun ctx01 -> - let uu___14 = uu___13 ctx01 in - match uu___14 with - | Success (x1, g11) -> - let uu___15 = - let uu___16 = - check_relation_args g - EQUALITY args0 args1 in - uu___16 ctx01 in - (match uu___15 with - | Success (y, g2) -> - let uu___16 = - let uu___17 = - and_pre g11 g2 in - ((), uu___17) in - Success uu___16 - | err1 -> err1) - | Error err1 -> Error err1 in - fun ctx -> - let uu___13 = uu___12 ctx in - match uu___13 with - | Error uu___14 -> - let uu___15 = - maybe_unfold_side_and_retry - Both t01 t11 in - uu___15 ctx - | res -> res in - let uu___11 = - (guard_ok && (rel = EQUALITY)) && - ((equatable g t01) || - (equatable g t11)) in - if uu___11 - then - let uu___12 = - let uu___13 = - compare_head_and_args () in - no_guard uu___13 in - fun ctx -> - let uu___13 = uu___12 ctx in - match uu___13 with - | Error uu___14 -> - let uu___15 = - emit_guard t01 t11 in - uu___15 ctx - | res -> res - else compare_head_and_args ()))) - | (FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = b0::b1::bs; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = ropt;_}, - uu___6) -> - let t02 = curry_abs b0 b1 bs body ropt in - check_relation1 g rel t02 t11 - | (uu___6, FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = b0::b1::bs; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = ropt;_}) - -> - let t12 = curry_abs b0 b1 bs body ropt in - check_relation1 g rel t01 t12 - | (FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = b0::[]; - FStar_Syntax_Syntax.body = body0; - FStar_Syntax_Syntax.rc_opt = uu___6;_}, - FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = b1::[]; - FStar_Syntax_Syntax.body = body1; - FStar_Syntax_Syntax.rc_opt = uu___7;_}) - -> - let uu___8 = - check_relation1 g EQUALITY - (b0.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort - (b1.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - (fun ctx01 -> - let uu___9 = uu___8 ctx01 in - match uu___9 with - | Success (x1, g11) -> - let uu___10 = - let uu___11 = - let uu___12 = - check_bqual - b0.FStar_Syntax_Syntax.binder_qual - b1.FStar_Syntax_Syntax.binder_qual in - fun ctx02 -> - let uu___13 = uu___12 ctx02 in - match uu___13 with - | Success (x2, g12) -> - let uu___14 = - let uu___15 = - let uu___16 = - check_positivity_qual - EQUALITY - b0.FStar_Syntax_Syntax.binder_positivity - b1.FStar_Syntax_Syntax.binder_positivity in - fun ctx03 -> - let uu___17 = - uu___16 ctx03 in - match uu___17 with - | Success (x3, g13) -> - let uu___18 = - let uu___19 = - let uu___20 = - universe_of g - (b0.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - fun ctx04 -> - let uu___21 = - uu___20 ctx04 in - match uu___21 - with - | Success - (x4, g14) -> - let uu___22 - = - let uu___23 - = - let uu___24 - = - open_term - g b0 - body0 in - match uu___24 - with - | - (g2, b01, - body01) - -> - let body11 - = - FStar_Syntax_Subst.subst - [ - FStar_Syntax_Syntax.DB - (Prims.int_zero, - (b01.FStar_Syntax_Syntax.binder_bv))] - body1 in - let uu___25 - = - check_relation1 - g2 - EQUALITY - body01 - body11 in - with_binders - [b01] - [x4] - uu___25 in - uu___23 - ctx04 in - (match uu___22 - with - | Success - (y, g2) - -> - let uu___23 - = - let uu___24 - = - and_pre - g14 g2 in - ((), - uu___24) in - Success - uu___23 - | err1 -> - err1) - | Error err1 -> - Error err1 in - uu___19 ctx03 in - (match uu___18 with - | Success (y, g2) -> - let uu___19 = - let uu___20 = - and_pre g13 - g2 in - ((), uu___20) in - Success uu___19 - | err1 -> err1) - | Error err1 -> Error err1 in - uu___15 ctx02 in - (match uu___14 with - | Success (y, g2) -> - let uu___15 = - let uu___16 = - and_pre g12 g2 in - ((), uu___16) in - Success uu___15 - | err1 -> err1) - | Error err1 -> Error err1 in - uu___11 ctx01 in - (match uu___10 with - | Success (y, g2) -> - let uu___11 = - let uu___12 = and_pre g11 g2 in - ((), uu___12) in - Success uu___11 - | err1 -> err1) - | Error err1 -> Error err1) - | (FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = x0::x1::xs; - FStar_Syntax_Syntax.comp = c0;_}, - uu___6) -> - let uu___7 = curry_arrow x0 (x1 :: xs) c0 in - check_relation1 g rel uu___7 t11 - | (uu___6, FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = x0::x1::xs; - FStar_Syntax_Syntax.comp = c1;_}) - -> - let uu___7 = curry_arrow x0 (x1 :: xs) c1 in - check_relation1 g rel t01 uu___7 - | (FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = x0::[]; - FStar_Syntax_Syntax.comp = c0;_}, - FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = x1::[]; - FStar_Syntax_Syntax.comp = c1;_}) - -> - (fun ctx -> - let ctx1 = - { - no_guard = (ctx.no_guard); - unfolding_ok = (ctx.unfolding_ok); - error_context = - (("subtype arrow", - FStar_Pervasives_Native.None) :: - (ctx.error_context)) - } in - let uu___6 = - let uu___7 = - check_bqual - x0.FStar_Syntax_Syntax.binder_qual - x1.FStar_Syntax_Syntax.binder_qual in - fun ctx01 -> - let uu___8 = uu___7 ctx01 in - match uu___8 with - | Success (x2, g11) -> - let uu___9 = - let uu___10 = - let uu___11 = - check_positivity_qual rel - x0.FStar_Syntax_Syntax.binder_positivity - x1.FStar_Syntax_Syntax.binder_positivity in - fun ctx02 -> - let uu___12 = uu___11 ctx02 in - match uu___12 with - | Success (x3, g12) -> - let uu___13 = - let uu___14 = - let uu___15 = - universe_of g - (x1.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - fun ctx03 -> - let uu___16 = - uu___15 ctx03 in - match uu___16 with - | Success (x4, g13) -> - let uu___17 = - let uu___18 = - let uu___19 = - open_comp g - x1 c1 in - match uu___19 - with - | (g_x1, x11, - c11) -> - let c01 = - FStar_Syntax_Subst.subst_comp - [ - FStar_Syntax_Syntax.DB - (Prims.int_zero, - (x11.FStar_Syntax_Syntax.binder_bv))] - c0 in - let uu___20 - = - let rel_arg - = - match rel - with - | - EQUALITY - -> - EQUALITY - | - uu___21 - -> - let uu___22 - = - let uu___23 - = - FStar_Syntax_Syntax.bv_to_name - x11.FStar_Syntax_Syntax.binder_bv in - FStar_Pervasives_Native.Some - uu___23 in - SUBTYPING - uu___22 in - let rel_comp - = - match rel - with - | - EQUALITY - -> - EQUALITY - | - SUBTYPING - e -> - let uu___21 - = - let uu___22 - = - FStar_Syntax_Util.is_pure_or_ghost_comp - c01 in - if - uu___22 - then - op_let_Question - e - (fun e1 - -> - let uu___23 - = - let uu___24 - = - let uu___25 - = - FStar_Syntax_Util.args_of_binders - [x11] in - FStar_Pervasives_Native.snd - uu___25 in - FStar_Syntax_Syntax.mk_Tm_app - e1 - uu___24 - FStar_Compiler_Range_Type.dummyRange in - FStar_Pervasives_Native.Some - uu___23) - else - FStar_Pervasives_Native.None in - SUBTYPING - uu___21 in - let uu___21 - = - check_relation1 - g rel - (x11.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort - (x0.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - fun ctx04 - -> - let uu___22 - = - uu___21 - ctx04 in - match uu___22 - with - | - Success - (x5, g14) - -> - let uu___23 - = - let uu___24 - ctx2 = - let ctx3 - = - { - no_guard - = - (ctx2.no_guard); - unfolding_ok - = - (ctx2.unfolding_ok); - error_context - = - (("check_subcomp", - FStar_Pervasives_Native.None) - :: - (ctx2.error_context)) - } in - let uu___25 - = - check_relation_comp - g_x1 - rel_comp - c01 c11 in - uu___25 - ctx3 in - uu___24 - ctx04 in - (match uu___23 - with - | - Success - (y, g2) - -> - let uu___24 - = - let uu___25 - = - and_pre - g14 g2 in - ((), - uu___25) in - Success - uu___24 - | - err1 -> - err1) - | - Error - err1 -> - Error - err1 in - with_binders - [x11] - [x4] - uu___20 in - uu___18 ctx03 in - (match uu___17 - with - | Success - (y, g2) -> - let uu___18 = - let uu___19 - = - and_pre - g13 g2 in - ((), - uu___19) in - Success - uu___18 - | err1 -> err1) - | Error err1 -> - Error err1 in - uu___14 ctx02 in - (match uu___13 with - | Success (y, g2) -> - let uu___14 = - let uu___15 = - and_pre g12 g2 in - ((), uu___15) in - Success uu___14 - | err1 -> err1) - | Error err1 -> Error err1 in - uu___10 ctx01 in - (match uu___9 with - | Success (y, g2) -> - let uu___10 = - let uu___11 = and_pre g11 g2 in - ((), uu___11) in - Success uu___10 - | err1 -> err1) - | Error err1 -> Error err1 in - uu___6 ctx1) - | (FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = e0; - FStar_Syntax_Syntax.ret_opt = uu___6; - FStar_Syntax_Syntax.brs = brs0; - FStar_Syntax_Syntax.rc_opt1 = uu___7;_}, - FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = e1; - FStar_Syntax_Syntax.ret_opt = uu___8; - FStar_Syntax_Syntax.brs = brs1; - FStar_Syntax_Syntax.rc_opt1 = uu___9;_}) - -> - let relate_branch br0 br1 uu___10 = - match (br0, br1) with - | ((p0, FStar_Pervasives_Native.None, body0), - (p1, FStar_Pervasives_Native.None, body1)) - -> - let uu___11 = - let uu___12 = - FStar_Syntax_Syntax.eq_pat p0 p1 in - Prims.op_Negation uu___12 in - if uu___11 - then fail "patterns not equal" - else - (let uu___13 = - open_branches_eq_pat g - (p0, FStar_Pervasives_Native.None, - body0) - (p1, FStar_Pervasives_Native.None, - body1) in - match uu___13 with - | (g', (p01, uu___14, body01), - (p11, uu___15, body11)) -> - let uu___16 = - FStar_TypeChecker_PatternUtils.raw_pat_as_exp - g.tcenv p01 in - (match uu___16 with - | FStar_Pervasives_Native.Some - (uu___17, bvs0) -> - let bs0 = - FStar_Compiler_List.map - FStar_Syntax_Syntax.mk_binder - bvs0 in - let uu___18 = - check_binders g bs0 in - (fun ctx01 -> - let uu___19 = uu___18 ctx01 in - match uu___19 with - | Success (x1, g11) -> - let uu___20 = - let uu___21 ctx = - let ctx1 = - { - no_guard = - (ctx.no_guard); - unfolding_ok = - (ctx.unfolding_ok); - error_context = - (("relate_branch", - FStar_Pervasives_Native.None) - :: - (ctx.error_context)) - } in - let uu___22 = - let uu___23 = - check_relation1 - g' rel body01 - body11 in - with_binders bs0 - x1 uu___23 in - uu___22 ctx1 in - uu___21 ctx01 in - (match uu___20 with - | Success (y, g2) -> - let uu___21 = - let uu___22 = - and_pre g11 g2 in - ((), uu___22) in - Success uu___21 - | err1 -> err1) - | Error err1 -> Error err1) - | uu___17 -> - fail - "raw_pat_as_exp failed in check_equality match rule")) - | uu___11 -> - fail - "Core does not support branches with when" in - let uu___10 = - let uu___11 = check_relation1 g EQUALITY e0 e1 in - fun ctx01 -> - let uu___12 = uu___11 ctx01 in - match uu___12 with - | Success (x1, g11) -> - let uu___13 = - let uu___14 = - iter2 brs0 brs1 relate_branch () in - uu___14 ctx01 in - (match uu___13 with - | Success (y, g2) -> - let uu___14 = - let uu___15 = and_pre g11 g2 in - ((), uu___15) in - Success uu___14 - | err1 -> err1) - | Error err1 -> Error err1 in - (fun ctx -> - let uu___11 = uu___10 ctx in - match uu___11 with - | Error uu___12 -> - let uu___13 = fallback t01 t11 in - uu___13 ctx - | res -> res) - | uu___6 -> fallback t01 t11) in - uu___3 ctx0 in - (match uu___2 with - | Success (y, g2) -> - let uu___3 = let uu___4 = and_pre g1 g2 in ((), uu___4) in - Success uu___3 - | err1 -> err1) - | Error err1 -> Error err1) -and (check_relation_args : - env -> - relation -> - FStar_Syntax_Syntax.args -> FStar_Syntax_Syntax.args -> unit result) - = - fun g -> - fun rel -> - fun a0 -> - fun a1 -> - if - (FStar_Compiler_List.length a0) = (FStar_Compiler_List.length a1) - then - iter2 a0 a1 - (fun uu___ -> - fun uu___1 -> - fun uu___2 -> - match (uu___, uu___1) with - | ((t0, q0), (t1, q1)) -> - let uu___3 = check_aqual q0 q1 in - (fun ctx0 -> - let uu___4 = uu___3 ctx0 in - match uu___4 with - | Success (x, g1) -> - let uu___5 = - let uu___6 = check_relation g rel t0 t1 in - uu___6 ctx0 in - (match uu___5 with - | Success (y, g2) -> - let uu___6 = - let uu___7 = and_pre g1 g2 in - ((), uu___7) in - Success uu___6 - | err -> err) - | Error err -> Error err)) () - else fail "Unequal number of arguments" -and (check_relation_comp : - env -> - relation -> - FStar_Syntax_Syntax.comp -> FStar_Syntax_Syntax.comp -> unit result) - = - fun g -> - fun rel -> - fun c0 -> - fun c1 -> - let destruct_comp c = - let uu___ = FStar_Syntax_Util.is_total_comp c in - if uu___ - then - FStar_Pervasives_Native.Some - (E_Total, (FStar_Syntax_Util.comp_result c)) - else - (let uu___2 = FStar_Syntax_Util.is_tot_or_gtot_comp c in - if uu___2 - then - FStar_Pervasives_Native.Some - (E_Ghost, (FStar_Syntax_Util.comp_result c)) - else FStar_Pervasives_Native.None) in - let uu___ = - let uu___1 = destruct_comp c0 in - let uu___2 = destruct_comp c1 in (uu___1, uu___2) in - match uu___ with - | (FStar_Pervasives_Native.None, uu___1) -> - let uu___2 = - let uu___3 = - FStar_TypeChecker_TermEqAndSimplify.eq_comp g.tcenv c0 c1 in - uu___3 = FStar_TypeChecker_TermEqAndSimplify.Equal in - if uu___2 - then (fun uu___3 -> Success ((), FStar_Pervasives_Native.None)) - else - (let ct_eq res0 args0 res1 args1 = - let uu___4 = check_relation g EQUALITY res0 res1 in - fun ctx0 -> - let uu___5 = uu___4 ctx0 in - match uu___5 with - | Success (x, g1) -> - let uu___6 = - let uu___7 = - check_relation_args g EQUALITY args0 args1 in - uu___7 ctx0 in - (match uu___6 with - | Success (y, g2) -> - let uu___7 = - let uu___8 = and_pre g1 g2 in ((), uu___8) in - Success uu___7 - | err -> err) - | Error err -> Error err in - let uu___4 = FStar_Syntax_Util.comp_eff_name_res_and_args c0 in - match uu___4 with - | (eff0, res0, args0) -> - let uu___5 = - FStar_Syntax_Util.comp_eff_name_res_and_args c1 in - (match uu___5 with - | (eff1, res1, args1) -> - let uu___6 = FStar_Ident.lid_equals eff0 eff1 in - if uu___6 - then ct_eq res0 args0 res1 args1 - else - (let ct0 = - FStar_TypeChecker_Env.unfold_effect_abbrev - g.tcenv c0 in - let ct1 = - FStar_TypeChecker_Env.unfold_effect_abbrev - g.tcenv c1 in - let uu___8 = - FStar_Ident.lid_equals - ct0.FStar_Syntax_Syntax.effect_name - ct1.FStar_Syntax_Syntax.effect_name in - if uu___8 - then - ct_eq ct0.FStar_Syntax_Syntax.result_typ - ct0.FStar_Syntax_Syntax.effect_args - ct1.FStar_Syntax_Syntax.result_typ - ct1.FStar_Syntax_Syntax.effect_args - else - (let uu___10 = - let uu___11 = - FStar_Ident.string_of_lid - ct0.FStar_Syntax_Syntax.effect_name in - let uu___12 = - FStar_Ident.string_of_lid - ct1.FStar_Syntax_Syntax.effect_name in - FStar_Compiler_Util.format2 - "Subcomp failed: Unequal computation types %s and %s" - uu___11 uu___12 in - fail uu___10)))) - | (uu___1, FStar_Pervasives_Native.None) -> - let uu___2 = - let uu___3 = - FStar_TypeChecker_TermEqAndSimplify.eq_comp g.tcenv c0 c1 in - uu___3 = FStar_TypeChecker_TermEqAndSimplify.Equal in - if uu___2 - then (fun uu___3 -> Success ((), FStar_Pervasives_Native.None)) - else - (let ct_eq res0 args0 res1 args1 = - let uu___4 = check_relation g EQUALITY res0 res1 in - fun ctx0 -> - let uu___5 = uu___4 ctx0 in - match uu___5 with - | Success (x, g1) -> - let uu___6 = - let uu___7 = - check_relation_args g EQUALITY args0 args1 in - uu___7 ctx0 in - (match uu___6 with - | Success (y, g2) -> - let uu___7 = - let uu___8 = and_pre g1 g2 in ((), uu___8) in - Success uu___7 - | err -> err) - | Error err -> Error err in - let uu___4 = FStar_Syntax_Util.comp_eff_name_res_and_args c0 in - match uu___4 with - | (eff0, res0, args0) -> - let uu___5 = - FStar_Syntax_Util.comp_eff_name_res_and_args c1 in - (match uu___5 with - | (eff1, res1, args1) -> - let uu___6 = FStar_Ident.lid_equals eff0 eff1 in - if uu___6 - then ct_eq res0 args0 res1 args1 - else - (let ct0 = - FStar_TypeChecker_Env.unfold_effect_abbrev - g.tcenv c0 in - let ct1 = - FStar_TypeChecker_Env.unfold_effect_abbrev - g.tcenv c1 in - let uu___8 = - FStar_Ident.lid_equals - ct0.FStar_Syntax_Syntax.effect_name - ct1.FStar_Syntax_Syntax.effect_name in - if uu___8 - then - ct_eq ct0.FStar_Syntax_Syntax.result_typ - ct0.FStar_Syntax_Syntax.effect_args - ct1.FStar_Syntax_Syntax.result_typ - ct1.FStar_Syntax_Syntax.effect_args - else - (let uu___10 = - let uu___11 = - FStar_Ident.string_of_lid - ct0.FStar_Syntax_Syntax.effect_name in - let uu___12 = - FStar_Ident.string_of_lid - ct1.FStar_Syntax_Syntax.effect_name in - FStar_Compiler_Util.format2 - "Subcomp failed: Unequal computation types %s and %s" - uu___11 uu___12 in - fail uu___10)))) - | (FStar_Pervasives_Native.Some (E_Total, t0), - FStar_Pervasives_Native.Some (uu___1, t1)) -> - check_relation g rel t0 t1 - | (FStar_Pervasives_Native.Some (E_Ghost, t0), - FStar_Pervasives_Native.Some (E_Ghost, t1)) -> - check_relation g rel t0 t1 - | (FStar_Pervasives_Native.Some (E_Ghost, t0), - FStar_Pervasives_Native.Some (E_Total, t1)) -> - let uu___1 = non_informative g t1 in - if uu___1 - then check_relation g rel t0 t1 - else fail "Expected a Total computation, but got Ghost" -and (check_subtype : - env -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.typ -> context -> unit success __result) - = - fun g -> - fun e -> - fun t0 -> - fun t1 -> - fun ctx -> - FStar_Profiling.profile - (fun uu___ -> - let rel = SUBTYPING e in - let uu___1 ctx1 = - let ctx2 = - { - no_guard = (ctx1.no_guard); - unfolding_ok = (ctx1.unfolding_ok); - error_context = - (((if ctx.no_guard - then "check_subtype(no_guard)" - else "check_subtype"), - (FStar_Pervasives_Native.Some - (CtxRel (t0, rel, t1)))) :: - (ctx1.error_context)) - } in - let uu___2 = check_relation g rel t0 t1 in uu___2 ctx2 in - uu___1 ctx) FStar_Pervasives_Native.None - "FStar.TypeChecker.Core.check_subtype" -and (memo_check : - env -> - FStar_Syntax_Syntax.term -> - (tot_or_ghost * FStar_Syntax_Syntax.typ) result) - = - fun g -> - fun e -> - let check_then_memo g1 e1 ctx = - let r = let uu___ = do_check_and_promote g1 e1 in uu___ ctx in - match r with - | Success (res, FStar_Pervasives_Native.None) -> - (insert g1 e1 (res, FStar_Pervasives_Native.None); r) - | Success (res, FStar_Pervasives_Native.Some guard1) -> - (match g1.guard_handler with - | FStar_Pervasives_Native.None -> - (insert g1 e1 (res, (FStar_Pervasives_Native.Some guard1)); - r) - | FStar_Pervasives_Native.Some gh -> - let uu___ = gh g1.tcenv guard1 in - if uu___ - then - let r1 = (res, FStar_Pervasives_Native.None) in - (insert g1 e1 r1; Success r1) - else - (let uu___2 = fail "guard handler failed" in uu___2 ctx)) - | uu___ -> r in - fun ctx -> - if Prims.op_Negation g.should_read_cache - then check_then_memo g e ctx - else - (let uu___1 = let uu___2 = lookup g e in uu___2 ctx in - match uu___1 with - | Error uu___2 -> check_then_memo g e ctx - | Success (et, FStar_Pervasives_Native.None) -> - Success (et, FStar_Pervasives_Native.None) - | Success (et, FStar_Pervasives_Native.Some pre) -> - (match g.guard_handler with - | FStar_Pervasives_Native.None -> - Success (et, (FStar_Pervasives_Native.Some pre)) - | FStar_Pervasives_Native.Some uu___2 -> - check_then_memo - { - tcenv = (g.tcenv); - allow_universe_instantiation = - (g.allow_universe_instantiation); - max_binder_index = (g.max_binder_index); - guard_handler = (g.guard_handler); - should_read_cache = false - } e ctx)) -and (check : - Prims.string -> - env -> - FStar_Syntax_Syntax.term -> - (tot_or_ghost * FStar_Syntax_Syntax.typ) result) - = - fun msg -> - fun g -> - fun e -> - fun ctx -> - let ctx1 = - { - no_guard = (ctx.no_guard); - unfolding_ok = (ctx.unfolding_ok); - error_context = - ((msg, (FStar_Pervasives_Native.Some (CtxTerm e))) :: - (ctx.error_context)) - } in - let uu___ = memo_check g e in uu___ ctx1 -and (do_check_and_promote : - env -> - FStar_Syntax_Syntax.term -> - (tot_or_ghost * FStar_Syntax_Syntax.typ) result) - = - fun g -> - fun e -> - let uu___ = do_check g e in - fun ctx0 -> - let uu___1 = uu___ ctx0 in - match uu___1 with - | Success (x, g1) -> - let uu___2 = - let uu___3 = - match x with - | (eff, t) -> - let eff1 = - match eff with - | E_Total -> E_Total - | E_Ghost -> - let uu___4 = non_informative g t in - if uu___4 then E_Total else E_Ghost in - (fun uu___4 -> - Success ((eff1, t), FStar_Pervasives_Native.None)) in - uu___3 ctx0 in - (match uu___2 with - | Success (y, g2) -> - let uu___3 = let uu___4 = and_pre g1 g2 in (y, uu___4) in - Success uu___3 - | err -> err) - | Error err -> Error err -and (do_check : - env -> - FStar_Syntax_Syntax.term -> - (tot_or_ghost * FStar_Syntax_Syntax.typ) result) - = - fun g -> - fun e -> - let e1 = FStar_Syntax_Subst.compress e in - match e1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_lazy - { FStar_Syntax_Syntax.blob = uu___; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_embedding - uu___1; - FStar_Syntax_Syntax.ltyp = uu___2; - FStar_Syntax_Syntax.rng = uu___3;_} - -> let uu___4 = FStar_Syntax_Util.unlazy e1 in do_check g uu___4 - | FStar_Syntax_Syntax.Tm_lazy i -> - (fun uu___ -> - Success - ((E_Total, (i.FStar_Syntax_Syntax.ltyp)), - FStar_Pervasives_Native.None)) - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t; FStar_Syntax_Syntax.meta = uu___;_} - -> memo_check g t - | FStar_Syntax_Syntax.Tm_uvar (uv, s) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Syntax_Util.ctx_uvar_typ uv in - FStar_Syntax_Subst.subst' s uu___2 in - (E_Total, uu___1) in - (fun uu___1 -> Success (uu___, FStar_Pervasives_Native.None)) - | FStar_Syntax_Syntax.Tm_name x -> - let uu___ = FStar_TypeChecker_Env.try_lookup_bv g.tcenv x in - (match uu___ with - | FStar_Pervasives_Native.None -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_bv x in - FStar_Compiler_Util.format1 "Variable not found: %s" uu___2 in - fail uu___1 - | FStar_Pervasives_Native.Some (t, uu___1) -> - (fun uu___2 -> - Success ((E_Total, t), FStar_Pervasives_Native.None))) - | FStar_Syntax_Syntax.Tm_fvar f -> - let uu___ = - FStar_TypeChecker_Env.try_lookup_lid g.tcenv - (f.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - (match uu___ with - | FStar_Pervasives_Native.Some (([], t), uu___1) -> - (fun uu___2 -> - Success ((E_Total, t), FStar_Pervasives_Native.None)) - | uu___1 -> fail "Missing universes instantiation") - | FStar_Syntax_Syntax.Tm_uinst - ({ FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar f; - FStar_Syntax_Syntax.pos = uu___; - FStar_Syntax_Syntax.vars = uu___1; - FStar_Syntax_Syntax.hash_code = uu___2;_}, - us) - -> - let uu___3 = - FStar_TypeChecker_Env.try_lookup_and_inst_lid g.tcenv us - (f.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - (match uu___3 with - | FStar_Pervasives_Native.None -> - let uu___4 = - let uu___5 = - FStar_Ident.string_of_lid - (f.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - FStar_Compiler_Util.format1 "Top-level name not found: %s" - uu___5 in - fail uu___4 - | FStar_Pervasives_Native.Some (t, uu___4) -> - (fun uu___5 -> - Success ((E_Total, t), FStar_Pervasives_Native.None))) - | FStar_Syntax_Syntax.Tm_constant c -> - (match c with - | FStar_Const.Const_range_of -> fail "Unhandled constant" - | FStar_Const.Const_set_range_of -> fail "Unhandled constant" - | FStar_Const.Const_reify uu___ -> fail "Unhandled constant" - | FStar_Const.Const_reflect uu___ -> fail "Unhandled constant" - | uu___ -> - let t = - FStar_TypeChecker_TcTerm.tc_constant g.tcenv - e1.FStar_Syntax_Syntax.pos c in - (fun uu___1 -> - Success ((E_Total, t), FStar_Pervasives_Native.None))) - | FStar_Syntax_Syntax.Tm_type u -> - let uu___ = - let uu___1 = mk_type (FStar_Syntax_Syntax.U_succ u) in - (E_Total, uu___1) in - (fun uu___1 -> Success (uu___, FStar_Pervasives_Native.None)) - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x; FStar_Syntax_Syntax.phi = phi;_} -> - let uu___ = check "refinement head" g x.FStar_Syntax_Syntax.sort in - (fun ctx0 -> - let uu___1 = uu___ ctx0 in - match uu___1 with - | Success (x1, g1) -> - let uu___2 = - let uu___3 = - match x1 with - | (uu___4, t) -> - let uu___5 = is_type g t in - (fun ctx01 -> - let uu___6 = uu___5 ctx01 in - match uu___6 with - | Success (x2, g11) -> - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Syntax_Syntax.mk_binder x in - open_term g uu___10 phi in - match uu___9 with - | (g', x3, phi1) -> - let uu___10 = - let uu___11 = - check "refinement formula" g' - phi1 in - fun ctx02 -> - let uu___12 = uu___11 ctx02 in - match uu___12 with - | Success (x4, g12) -> - let uu___13 = - let uu___14 = - match x4 with - | (uu___15, t') -> - let uu___16 = - is_type g' t' in - (fun ctx03 -> - let uu___17 = - uu___16 ctx03 in - match uu___17 with - | Success - (x5, g13) -> - let uu___18 = - let uu___19 - uu___20 = - Success - ((E_Total, - t), - FStar_Pervasives_Native.None) in - uu___19 - ctx03 in - (match uu___18 - with - | Success - (y, g2) - -> - let uu___19 - = - let uu___20 - = - and_pre - g13 g2 in - (y, - uu___20) in - Success - uu___19 - | err -> err) - | Error err -> - Error err) in - uu___14 ctx02 in - (match uu___13 with - | Success (y, g2) -> - let uu___14 = - let uu___15 = - and_pre g12 g2 in - (y, uu___15) in - Success uu___14 - | err -> err) - | Error err -> Error err in - with_binders [x3] [x2] uu___10 in - uu___8 ctx01 in - (match uu___7 with - | Success (y, g2) -> - let uu___8 = - let uu___9 = and_pre g11 g2 in - (y, uu___9) in - Success uu___8 - | err -> err) - | Error err -> Error err) in - uu___3 ctx0 in - (match uu___2 with - | Success (y, g2) -> - let uu___3 = let uu___4 = and_pre g1 g2 in (y, uu___4) in - Success uu___3 - | err -> err) - | Error err -> Error err) - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = xs; FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = uu___;_} - -> - let uu___1 = open_term_binders g xs body in - (match uu___1 with - | (g', xs1, body1) -> - let uu___2 ctx = - let ctx1 = - { - no_guard = (ctx.no_guard); - unfolding_ok = (ctx.unfolding_ok); - error_context = - (("abs binders", FStar_Pervasives_Native.None) :: - (ctx.error_context)) - } in - let uu___3 = check_binders g xs1 in uu___3 ctx1 in - (fun ctx0 -> - let uu___3 = uu___2 ctx0 in - match uu___3 with - | Success (x, g1) -> - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = check "abs body" g' body1 in - fun ctx01 -> - let uu___8 = uu___7 ctx01 in - match uu___8 with - | Success (x1, g11) -> - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = as_comp g x1 in - FStar_Syntax_Util.arrow xs1 uu___13 in - (E_Total, uu___12) in - fun uu___12 -> - Success - (uu___11, - FStar_Pervasives_Native.None) in - uu___10 ctx01 in - (match uu___9 with - | Success (y, g2) -> - let uu___10 = - let uu___11 = and_pre g11 g2 in - (y, uu___11) in - Success uu___10 - | err -> err) - | Error err -> Error err in - with_binders xs1 x uu___6 in - uu___5 ctx0 in - (match uu___4 with - | Success (y, g2) -> - let uu___5 = - let uu___6 = and_pre g1 g2 in (y, uu___6) in - Success uu___5 - | err -> err) - | Error err -> Error err)) - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = xs; FStar_Syntax_Syntax.comp = c;_} -> - let uu___ = open_comp_binders g xs c in - (match uu___ with - | (g', xs1, c1) -> - let uu___1 ctx = - let ctx1 = - { - no_guard = (ctx.no_guard); - unfolding_ok = (ctx.unfolding_ok); - error_context = - (("arrow binders", FStar_Pervasives_Native.None) :: - (ctx.error_context)) - } in - let uu___2 = check_binders g xs1 in uu___2 ctx1 in - (fun ctx0 -> - let uu___2 = uu___1 ctx0 in - match uu___2 with - | Success (x, g1) -> - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 ctx = - let ctx1 = - { - no_guard = (ctx.no_guard); - unfolding_ok = (ctx.unfolding_ok); - error_context = - (("arrow comp", - FStar_Pervasives_Native.None) :: - (ctx.error_context)) - } in - let uu___7 = check_comp g' c1 in uu___7 ctx1 in - fun ctx01 -> - let uu___7 = uu___6 ctx01 in - match uu___7 with - | Success (x1, g11) -> - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - mk_type - (FStar_Syntax_Syntax.U_max (x1 :: - x)) in - (E_Total, uu___11) in - fun uu___11 -> - Success - (uu___10, - FStar_Pervasives_Native.None) in - uu___9 ctx01 in - (match uu___8 with - | Success (y, g2) -> - let uu___9 = - let uu___10 = and_pre g11 g2 in - (y, uu___10) in - Success uu___9 - | err -> err) - | Error err -> Error err in - with_binders xs1 x uu___5 in - uu___4 ctx0 in - (match uu___3 with - | Success (y, g2) -> - let uu___4 = - let uu___5 = and_pre g1 g2 in (y, uu___5) in - Success uu___4 - | err -> err) - | Error err -> Error err)) - | FStar_Syntax_Syntax.Tm_app uu___ -> - let rec check_app_arg uu___1 uu___2 = - match (uu___1, uu___2) with - | ((eff_hd, t_hd), (arg, arg_qual)) -> - let uu___3 = is_arrow g t_hd in - (fun ctx0 -> - let uu___4 = uu___3 ctx0 in - match uu___4 with - | Success (x, g1) -> - let uu___5 = - let uu___6 = - match x with - | (x1, eff_arr, t') -> - let uu___7 = check "app arg" g arg in - (fun ctx01 -> - let uu___8 = uu___7 ctx01 in - match uu___8 with - | Success (x2, g11) -> - let uu___9 = - let uu___10 = - match x2 with - | (eff_arg, t_arg) -> - let uu___11 ctx = - let ctx1 = - { - no_guard = (ctx.no_guard); - unfolding_ok = - (ctx.unfolding_ok); - error_context = - (("app subtyping", - FStar_Pervasives_Native.None) - :: (ctx.error_context)) - } in - let uu___12 = - check_subtype g - (FStar_Pervasives_Native.Some - arg) t_arg - (x1.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - uu___12 ctx1 in - (fun ctx02 -> - let uu___12 = uu___11 ctx02 in - match uu___12 with - | Success (x3, g12) -> - let uu___13 = - let uu___14 = - let uu___15 ctx = - let ctx1 = - { - no_guard = - (ctx.no_guard); - unfolding_ok = - (ctx.unfolding_ok); - error_context - = - (("app arg qual", - FStar_Pervasives_Native.None) - :: - (ctx.error_context)) - } in - let uu___16 = - check_arg_qual - arg_qual - x1.FStar_Syntax_Syntax.binder_qual in - uu___16 ctx1 in - fun ctx03 -> - let uu___16 = - uu___15 ctx03 in - match uu___16 with - | Success - (x4, g13) -> - let uu___17 = - let uu___18 - = - let uu___19 - = - let uu___20 - = - FStar_Syntax_Subst.subst - [ - FStar_Syntax_Syntax.NT - ((x1.FStar_Syntax_Syntax.binder_bv), - arg)] t' in - ((join_eff - eff_hd - (join_eff - eff_arr - eff_arg)), - uu___20) in - fun - uu___20 - -> - Success - (uu___19, - FStar_Pervasives_Native.None) in - uu___18 - ctx03 in - (match uu___17 - with - | Success - (y, g2) - -> - let uu___18 - = - let uu___19 - = - and_pre - g13 g2 in - (y, - uu___19) in - Success - uu___18 - | err -> err) - | Error err -> - Error err in - uu___14 ctx02 in - (match uu___13 with - | Success (y, g2) -> - let uu___14 = - let uu___15 = - and_pre g12 g2 in - (y, uu___15) in - Success uu___14 - | err -> err) - | Error err -> Error err) in - uu___10 ctx01 in - (match uu___9 with - | Success (y, g2) -> - let uu___10 = - let uu___11 = and_pre g11 g2 in - (y, uu___11) in - Success uu___10 - | err -> err) - | Error err -> Error err) in - uu___6 ctx0 in - (match uu___5 with - | Success (y, g2) -> - let uu___6 = - let uu___7 = and_pre g1 g2 in (y, uu___7) in - Success uu___6 - | err -> err) - | Error err -> Error err) in - let check_app hd args = - let uu___1 = check "app head" g hd in - fun ctx0 -> - let uu___2 = uu___1 ctx0 in - match uu___2 with - | Success (x, g1) -> - let uu___3 = - let uu___4 = - match x with - | (eff_hd, t) -> fold check_app_arg (eff_hd, t) args in - uu___4 ctx0 in - (match uu___3 with - | Success (y, g2) -> - let uu___4 = let uu___5 = and_pre g1 g2 in (y, uu___5) in - Success uu___4 - | err -> err) - | Error err -> Error err in - let uu___1 = FStar_Syntax_Util.head_and_args_full e1 in - (match uu___1 with - | (hd, args) -> - (match args with - | (t1, FStar_Pervasives_Native.None)::(t2, - FStar_Pervasives_Native.None)::[] - when FStar_TypeChecker_Util.short_circuit_head hd -> - let uu___2 = check "app head" g hd in - (fun ctx0 -> - let uu___3 = uu___2 ctx0 in - match uu___3 with - | Success (x, g1) -> - let uu___4 = - let uu___5 = - match x with - | (eff_hd, t_hd) -> - let uu___6 = is_arrow g t_hd in - (fun ctx01 -> - let uu___7 = uu___6 ctx01 in - match uu___7 with - | Success (x1, g11) -> - let uu___8 = - let uu___9 = - match x1 with - | (x2, eff_arr1, s1) -> - let uu___10 = - check "app arg" g t1 in - (fun ctx02 -> - let uu___11 = - uu___10 ctx02 in - match uu___11 with - | Success (x3, g12) -> - let uu___12 = - let uu___13 = - match x3 with - | (eff_arg1, - t_t1) -> - let uu___14 - ctx = - let ctx1 = - { - no_guard - = - (ctx.no_guard); - unfolding_ok - = - (ctx.unfolding_ok); - error_context - = - (("operator arg1", - FStar_Pervasives_Native.None) - :: - (ctx.error_context)) - } in - let uu___15 - = - check_subtype - g - (FStar_Pervasives_Native.Some - t1) t_t1 - (x2.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - uu___15 - ctx1 in - (fun ctx03 - -> - let uu___15 - = - uu___14 - ctx03 in - match uu___15 - with - | - Success - (x4, g13) - -> - let uu___16 - = - let uu___17 - = - let s11 = - FStar_Syntax_Subst.subst - [ - FStar_Syntax_Syntax.NT - ((x2.FStar_Syntax_Syntax.binder_bv), - t1)] s1 in - let uu___18 - = - is_arrow - g s11 in - fun ctx04 - -> - let uu___19 - = - uu___18 - ctx04 in - match uu___19 - with - | - Success - (x5, g14) - -> - let uu___20 - = - let uu___21 - = - match x5 - with - | - (y, - eff_arr2, - s2) -> - let guard_formula - = - FStar_TypeChecker_Util.short_circuit - hd - [ - (t1, - FStar_Pervasives_Native.None)] in - let g' = - match guard_formula - with - | - FStar_TypeChecker_Common.Trivial - -> g - | - FStar_TypeChecker_Common.NonTrivial - gf -> - push_hypothesis - g gf in - let uu___22 - = - let uu___23 - = - check - "app arg" - g' t2 in - weaken_with_guard_formula - guard_formula - uu___23 in - (fun - ctx05 -> - let uu___23 - = - uu___22 - ctx05 in - match uu___23 - with - | - Success - (x6, g15) - -> - let uu___24 - = - let uu___25 - = - match x6 - with - | - (eff_arg2, - t_t2) -> - let uu___26 - ctx = - let ctx1 - = - { - no_guard - = - (ctx.no_guard); - unfolding_ok - = - (ctx.unfolding_ok); - error_context - = - (("operator arg2", - FStar_Pervasives_Native.None) - :: - (ctx.error_context)) - } in - let uu___27 - = - check_subtype - g' - (FStar_Pervasives_Native.Some - t2) t_t2 - (y.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - uu___27 - ctx1 in - (fun - ctx06 -> - let uu___27 - = - uu___26 - ctx06 in - match uu___27 - with - | - Success - (x7, g16) - -> - let uu___28 - = - let uu___29 - = - let uu___30 - = - let uu___31 - = - FStar_Syntax_Subst.subst - [ - FStar_Syntax_Syntax.NT - ((y.FStar_Syntax_Syntax.binder_bv), - t2)] s2 in - ((join_eff_l - [eff_hd; - eff_arr1; - eff_arr2; - eff_arg1; - eff_arg2]), - uu___31) in - fun - uu___31 - -> - Success - (uu___30, - FStar_Pervasives_Native.None) in - uu___29 - ctx06 in - (match uu___28 - with - | - Success - (y1, g2) - -> - let uu___29 - = - let uu___30 - = - and_pre - g16 g2 in - (y1, - uu___30) in - Success - uu___29 - | - err -> - err) - | - Error err - -> - Error err) in - uu___25 - ctx05 in - (match uu___24 - with - | - Success - (y1, g2) - -> - let uu___25 - = - let uu___26 - = - and_pre - g15 g2 in - (y1, - uu___26) in - Success - uu___25 - | - err -> - err) - | - Error err - -> - Error err) in - uu___21 - ctx04 in - (match uu___20 - with - | - Success - (y, g2) - -> - let uu___21 - = - let uu___22 - = - and_pre - g14 g2 in - (y, - uu___22) in - Success - uu___21 - | - err -> - err) - | - Error err - -> - Error err in - uu___17 - ctx03 in - (match uu___16 - with - | - Success - (y, g2) - -> - let uu___17 - = - let uu___18 - = - and_pre - g13 g2 in - (y, - uu___18) in - Success - uu___17 - | - err -> - err) - | - Error err - -> - Error err) in - uu___13 ctx02 in - (match uu___12 with - | Success (y, g2) - -> - let uu___13 = - let uu___14 = - and_pre g12 - g2 in - (y, uu___14) in - Success uu___13 - | err -> err) - | Error err -> Error err) in - uu___9 ctx01 in - (match uu___8 with - | Success (y, g2) -> - let uu___9 = - let uu___10 = and_pre g11 g2 in - (y, uu___10) in - Success uu___9 - | err -> err) - | Error err -> Error err) in - uu___5 ctx0 in - (match uu___4 with - | Success (y, g2) -> - let uu___5 = - let uu___6 = and_pre g1 g2 in (y, uu___6) in - Success uu___5 - | err -> err) - | Error err -> Error err) - | uu___2 -> check_app hd args)) - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = e2; - FStar_Syntax_Syntax.asc = (FStar_Pervasives.Inl t, uu___, eq); - FStar_Syntax_Syntax.eff_opt = uu___1;_} - -> - let uu___2 = check "ascription head" g e2 in - (fun ctx0 -> - let uu___3 = uu___2 ctx0 in - match uu___3 with - | Success (x, g1) -> - let uu___4 = - let uu___5 = - match x with - | (eff, te) -> - let uu___6 = check "ascription type" g t in - (fun ctx01 -> - let uu___7 = uu___6 ctx01 in - match uu___7 with - | Success (x1, g11) -> - let uu___8 = - let uu___9 = - match x1 with - | (uu___10, t') -> - let uu___11 = is_type g t' in - (fun ctx02 -> - let uu___12 = uu___11 ctx02 in - match uu___12 with - | Success (x2, g12) -> - let uu___13 = - let uu___14 = - let uu___15 ctx = - let ctx1 = - { - no_guard = - (ctx.no_guard); - unfolding_ok = - (ctx.unfolding_ok); - error_context = - (("ascription subtyping", - FStar_Pervasives_Native.None) - :: - (ctx.error_context)) - } in - let uu___16 = - check_subtype g - (FStar_Pervasives_Native.Some - e2) te t in - uu___16 ctx1 in - fun ctx03 -> - let uu___16 = - uu___15 ctx03 in - match uu___16 with - | Success (x3, g13) -> - let uu___17 = - let uu___18 - uu___19 = - Success - ((eff, t), - FStar_Pervasives_Native.None) in - uu___18 ctx03 in - (match uu___17 with - | Success (y, g2) - -> - let uu___18 = - let uu___19 = - and_pre g13 - g2 in - (y, uu___19) in - Success uu___18 - | err -> err) - | Error err -> Error err in - uu___14 ctx02 in - (match uu___13 with - | Success (y, g2) -> - let uu___14 = - let uu___15 = - and_pre g12 g2 in - (y, uu___15) in - Success uu___14 - | err -> err) - | Error err -> Error err) in - uu___9 ctx01 in - (match uu___8 with - | Success (y, g2) -> - let uu___9 = - let uu___10 = and_pre g11 g2 in - (y, uu___10) in - Success uu___9 - | err -> err) - | Error err -> Error err) in - uu___5 ctx0 in - (match uu___4 with - | Success (y, g2) -> - let uu___5 = let uu___6 = and_pre g1 g2 in (y, uu___6) in - Success uu___5 - | err -> err) - | Error err -> Error err) - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = e2; - FStar_Syntax_Syntax.asc = (FStar_Pervasives.Inr c, uu___, uu___1); - FStar_Syntax_Syntax.eff_opt = uu___2;_} - -> - let uu___3 = FStar_Syntax_Util.is_tot_or_gtot_comp c in - if uu___3 - then - let uu___4 = check "ascription head" g e2 in - (fun ctx0 -> - let uu___5 = uu___4 ctx0 in - match uu___5 with - | Success (x, g1) -> - let uu___6 = - let uu___7 = - match x with - | (eff, te) -> - let uu___8 ctx = - let ctx1 = - { - no_guard = (ctx.no_guard); - unfolding_ok = (ctx.unfolding_ok); - error_context = - (("ascription comp", - FStar_Pervasives_Native.None) :: - (ctx.error_context)) - } in - let uu___9 = check_comp g c in uu___9 ctx1 in - (fun ctx01 -> - let uu___9 = uu___8 ctx01 in - match uu___9 with - | Success (x1, g11) -> - let uu___10 = - let uu___11 = - let c_e = as_comp g (eff, te) in - let uu___12 ctx = - let ctx1 = - { - no_guard = (ctx.no_guard); - unfolding_ok = (ctx.unfolding_ok); - error_context = - (("ascription subtyping (comp)", - FStar_Pervasives_Native.None) - :: (ctx.error_context)) - } in - let uu___13 = - check_relation_comp g - (SUBTYPING - (FStar_Pervasives_Native.Some - e2)) c_e c in - uu___13 ctx1 in - fun ctx02 -> - let uu___13 = uu___12 ctx02 in - match uu___13 with - | Success (x2, g12) -> - let uu___14 = - let uu___15 = - let uu___16 = - comp_as_tot_or_ghost_and_type - c in - match uu___16 with - | FStar_Pervasives_Native.Some - (eff1, t) -> - (fun uu___17 -> - Success - ((eff1, t), - FStar_Pervasives_Native.None)) in - uu___15 ctx02 in - (match uu___14 with - | Success (y, g2) -> - let uu___15 = - let uu___16 = - and_pre g12 g2 in - (y, uu___16) in - Success uu___15 - | err -> err) - | Error err -> Error err in - uu___11 ctx01 in - (match uu___10 with - | Success (y, g2) -> - let uu___11 = - let uu___12 = and_pre g11 g2 in - (y, uu___12) in - Success uu___11 - | err -> err) - | Error err -> Error err) in - uu___7 ctx0 in - (match uu___6 with - | Success (y, g2) -> - let uu___7 = - let uu___8 = and_pre g1 g2 in (y, uu___8) in - Success uu___7 - | err -> err) - | Error err -> Error err) - else - (let uu___5 = - let uu___6 = - FStar_Class_Show.show FStar_Syntax_Print.showable_comp c in - FStar_Compiler_Util.format1 - "Effect ascriptions are not fully handled yet: %s" uu___6 in - fail uu___5) - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (false, lb::[]); - FStar_Syntax_Syntax.body1 = body;_} - -> - let uu___ = lb.FStar_Syntax_Syntax.lbname in - (match uu___ with - | FStar_Pervasives.Inl x -> - let uu___1 = - let uu___2 = FStar_Syntax_Syntax.mk_binder x in - open_term g uu___2 body in - (match uu___1 with - | (g', x1, body1) -> - let uu___2 = - FStar_Syntax_Util.is_pure_or_ghost_effect - lb.FStar_Syntax_Syntax.lbeff in - if uu___2 - then - let uu___3 = - check "let definition" g lb.FStar_Syntax_Syntax.lbdef in - (fun ctx0 -> - let uu___4 = uu___3 ctx0 in - match uu___4 with - | Success (x2, g1) -> - let uu___5 = - let uu___6 = - match x2 with - | (eff_def, tdef) -> - let uu___7 = - check "let type" g - lb.FStar_Syntax_Syntax.lbtyp in - (fun ctx01 -> - let uu___8 = uu___7 ctx01 in - match uu___8 with - | Success (x3, g11) -> - let uu___9 = - let uu___10 = - match x3 with - | (uu___11, ttyp) -> - let uu___12 = - is_type g ttyp in - (fun ctx02 -> - let uu___13 = - uu___12 ctx02 in - match uu___13 with - | Success (x4, g12) -> - let uu___14 = - let uu___15 = - let uu___16 - ctx = - let ctx1 = - { - no_guard - = - (ctx.no_guard); - unfolding_ok - = - (ctx.unfolding_ok); - error_context - = - (("let subtyping", - FStar_Pervasives_Native.None) - :: - (ctx.error_context)) - } in - let uu___17 - = - check_subtype - g - (FStar_Pervasives_Native.Some - (lb.FStar_Syntax_Syntax.lbdef)) - tdef - lb.FStar_Syntax_Syntax.lbtyp in - uu___17 ctx1 in - fun ctx03 -> - let uu___17 - = - uu___16 - ctx03 in - match uu___17 - with - | Success - (x5, g13) - -> - let uu___18 - = - let uu___19 - = - let uu___20 - = - let uu___21 - = - check - "let body" - g' body1 in - fun ctx04 - -> - let uu___22 - = - uu___21 - ctx04 in - match uu___22 - with - | - Success - (x6, g14) - -> - let uu___23 - = - let uu___24 - = - match x6 - with - | - (eff_body, - t) -> - let uu___25 - = - check_no_escape - [x1] t in - (fun - ctx05 -> - let uu___26 - = - uu___25 - ctx05 in - match uu___26 - with - | - Success - (x7, g15) - -> - let uu___27 - = - let uu___28 - uu___29 = - Success - (((join_eff - eff_def - eff_body), - t), - FStar_Pervasives_Native.None) in - uu___28 - ctx05 in - (match uu___27 - with - | - Success - (y, g2) - -> - let uu___28 - = - let uu___29 - = - and_pre - g15 g2 in - (y, - uu___29) in - Success - uu___28 - | - err -> - err) - | - Error err - -> - Error err) in - uu___24 - ctx04 in - (match uu___23 - with - | - Success - (y, g2) - -> - let uu___24 - = - let uu___25 - = - and_pre - g14 g2 in - (y, - uu___25) in - Success - uu___24 - | - err -> - err) - | - Error err - -> - Error err in - with_definition - x1 x4 - lb.FStar_Syntax_Syntax.lbdef - uu___20 in - uu___19 - ctx03 in - (match uu___18 - with - | - Success - (y, g2) - -> - let uu___19 - = - let uu___20 - = - and_pre - g13 g2 in - (y, - uu___20) in - Success - uu___19 - | - err -> - err) - | Error err - -> - Error err in - uu___15 ctx02 in - (match uu___14 - with - | Success - (y, g2) -> - let uu___15 = - let uu___16 - = - and_pre - g12 g2 in - (y, - uu___16) in - Success - uu___15 - | err -> err) - | Error err -> - Error err) in - uu___10 ctx01 in - (match uu___9 with - | Success (y, g2) -> - let uu___10 = - let uu___11 = - and_pre g11 g2 in - (y, uu___11) in - Success uu___10 - | err -> err) - | Error err -> Error err) in - uu___6 ctx0 in - (match uu___5 with - | Success (y, g2) -> - let uu___6 = - let uu___7 = and_pre g1 g2 in (y, uu___7) in - Success uu___6 - | err -> err) - | Error err -> Error err) - else - (let uu___4 = - let uu___5 = - FStar_Class_Show.show FStar_Ident.showable_lident - lb.FStar_Syntax_Syntax.lbeff in - FStar_Compiler_Util.format1 - "Let binding is effectful (lbeff = %s)" uu___5 in - fail uu___4))) - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = sc; - FStar_Syntax_Syntax.ret_opt = FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.brs = branches; - FStar_Syntax_Syntax.rc_opt1 = rc_opt;_} - -> - let uu___ = check "scrutinee" g sc in - (fun ctx0 -> - let uu___1 = uu___ ctx0 in - match uu___1 with - | Success (x, g1) -> - let uu___2 = - let uu___3 = - match x with - | (eff_sc, t_sc) -> - let uu___4 ctx = - let ctx1 = - { - no_guard = (ctx.no_guard); - unfolding_ok = (ctx.unfolding_ok); - error_context = - (("universe_of", - (FStar_Pervasives_Native.Some - (CtxTerm t_sc))) :: - (ctx.error_context)) - } in - let uu___5 = universe_of g t_sc in uu___5 ctx1 in - (fun ctx01 -> - let uu___5 = uu___4 ctx01 in - match uu___5 with - | Success (x1, g11) -> - let uu___6 = - let uu___7 = - let rec check_branches path_condition - branch_typ_opt branches1 = - match branches1 with - | [] -> - (match branch_typ_opt with - | FStar_Pervasives_Native.None -> - fail - "could not compute a type for the match" - | FStar_Pervasives_Native.Some et - -> - let uu___8 = - boolean_negation_simp - path_condition in - (match uu___8 with - | FStar_Pervasives_Native.None - -> - (fun uu___9 -> - Success - (et, - FStar_Pervasives_Native.None)) - | FStar_Pervasives_Native.Some - g2 -> - let uu___9 = - let uu___10 = - FStar_Syntax_Util.b2t - g2 in - guard uu___10 in - (fun ctx02 -> - let uu___10 = - uu___9 ctx02 in - match uu___10 with - | Success (x2, g12) -> - let uu___11 = - let uu___12 - uu___13 = - Success - (et, - FStar_Pervasives_Native.None) in - uu___12 ctx02 in - (match uu___11 - with - | Success - (y, g21) -> - let uu___12 = - let uu___13 - = - and_pre - g12 g21 in - (y, - uu___13) in - Success - uu___12 - | err -> err) - | Error err -> - Error err))) - | (p, FStar_Pervasives_Native.None, b)::rest - -> - let uu___8 = - open_branch g - (p, - FStar_Pervasives_Native.None, - b) in - (match uu___8 with - | (uu___9, (p1, uu___10, b1)) -> - let uu___11 ctx = - let ctx1 = - { - no_guard = - (ctx.no_guard); - unfolding_ok = - (ctx.unfolding_ok); - error_context = - (("check_pat", - FStar_Pervasives_Native.None) - :: - (ctx.error_context)) - } in - let uu___12 = - check_pat g p1 t_sc in - uu___12 ctx1 in - (fun ctx02 -> - let uu___12 = uu___11 ctx02 in - match uu___12 with - | Success (x2, g12) -> - let uu___13 = - let uu___14 = - match x2 with - | (bs, us) -> - let uu___15 = - pattern_branch_condition - g sc p1 in - (fun ctx03 -> - let uu___16 - = - uu___15 - ctx03 in - match uu___16 - with - | Success - (x3, g13) - -> - let uu___17 - = - let uu___18 - = - let pat_sc_eq - = - let uu___19 - = - let uu___20 - = - let uu___21 - = - FStar_TypeChecker_PatternUtils.raw_pat_as_exp - g.tcenv - p1 in - FStar_Compiler_Util.must - uu___21 in - FStar_Pervasives_Native.fst - uu___20 in - FStar_Syntax_Util.mk_eq2 - x1 t_sc - sc - uu___19 in - let uu___19 - = - combine_path_and_branch_condition - path_condition - x3 - pat_sc_eq in - match uu___19 - with - | - (this_path_condition, - next_path_condition) - -> - let g' = - push_binders - g bs in - let g'1 = - push_hypothesis - g' - this_path_condition in - let uu___20 - = - let uu___21 - = - let uu___22 - = - let uu___23 - ctx = - let ctx1 - = - { - no_guard - = - (ctx.no_guard); - unfolding_ok - = - (ctx.unfolding_ok); - error_context - = - (("branch", - (FStar_Pervasives_Native.Some - (CtxTerm - b1))) :: - (ctx.error_context)) - } in - let uu___24 - = - check - "branch" - g'1 b1 in - uu___24 - ctx1 in - fun ctx04 - -> - let uu___24 - = - uu___23 - ctx04 in - match uu___24 - with - | - Success - (x4, g14) - -> - let uu___25 - = - let uu___26 - = - match x4 - with - | - (eff_br, - tbr) -> - (match branch_typ_opt - with - | - FStar_Pervasives_Native.None - -> - let uu___27 - = - check_no_escape - bs tbr in - (fun - ctx05 -> - let uu___28 - = - uu___27 - ctx05 in - match uu___28 - with - | - Success - (x5, g15) - -> - let uu___29 - = - let uu___30 - uu___31 = - Success - ((eff_br, - tbr), - FStar_Pervasives_Native.None) in - uu___30 - ctx05 in - (match uu___29 - with - | - Success - (y, g2) - -> - let uu___30 - = - let uu___31 - = - and_pre - g15 g2 in - (y, - uu___31) in - Success - uu___30 - | - err -> - err) - | - Error err - -> - Error err) - | - FStar_Pervasives_Native.Some - (acc_eff, - expect_tbr) - -> - let uu___27 - ctx = - let ctx1 - = - { - no_guard - = - (ctx.no_guard); - unfolding_ok - = - (ctx.unfolding_ok); - error_context - = - (("check_branch_subtype", - (FStar_Pervasives_Native.Some - (CtxRel - (tbr, - (SUBTYPING - (FStar_Pervasives_Native.Some - b1)), - expect_tbr)))) - :: - (ctx.error_context)) - } in - let uu___28 - = - check_subtype - g'1 - (FStar_Pervasives_Native.Some - b1) tbr - expect_tbr in - uu___28 - ctx1 in - (fun - ctx05 -> - let uu___28 - = - uu___27 - ctx05 in - match uu___28 - with - | - Success - (x5, g15) - -> - let uu___29 - = - let uu___30 - uu___31 = - Success - (((join_eff - eff_br - acc_eff), - expect_tbr), - FStar_Pervasives_Native.None) in - uu___30 - ctx05 in - (match uu___29 - with - | - Success - (y, g2) - -> - let uu___30 - = - let uu___31 - = - and_pre - g15 g2 in - (y, - uu___31) in - Success - uu___30 - | - err -> - err) - | - Error err - -> - Error err)) in - uu___26 - ctx04 in - (match uu___25 - with - | - Success - (y, g2) - -> - let uu___26 - = - let uu___27 - = - and_pre - g14 g2 in - (y, - uu___27) in - Success - uu___26 - | - err -> - err) - | - Error err - -> - Error err in - weaken - this_path_condition - uu___22 in - with_binders - bs us - uu___21 in - (fun - ctx04 -> - let uu___21 - = - uu___20 - ctx04 in - match uu___21 - with - | - Success - (x4, g14) - -> - let uu___22 - = - let uu___23 - = - match x4 - with - | - (eff_br, - tbr) -> - (match - p1.FStar_Syntax_Syntax.v - with - | - FStar_Syntax_Syntax.Pat_var - uu___24 - -> - (match rest - with - | - uu___25::uu___26 - -> - fail - "Redundant branches after wildcard" - | - uu___25 - -> - (fun - uu___26 - -> - Success - ((eff_br, - tbr), - FStar_Pervasives_Native.None))) - | - uu___24 - -> - check_branches - next_path_condition - (FStar_Pervasives_Native.Some - (eff_br, - tbr)) - rest) in - uu___23 - ctx04 in - (match uu___22 - with - | - Success - (y, g2) - -> - let uu___23 - = - let uu___24 - = - and_pre - g14 g2 in - (y, - uu___24) in - Success - uu___23 - | - err -> - err) - | - Error err - -> - Error err) in - uu___18 - ctx03 in - (match uu___17 - with - | - Success - (y, g2) - -> - let uu___18 - = - let uu___19 - = - and_pre - g13 g2 in - (y, - uu___19) in - Success - uu___18 - | - err -> - err) - | Error err - -> - Error err) in - uu___14 ctx02 in - (match uu___13 with - | Success (y, g2) -> - let uu___14 = - let uu___15 = - and_pre g12 g2 in - (y, uu___15) in - Success uu___14 - | err -> err) - | Error err -> Error err)) in - let uu___8 = - match rc_opt with - | FStar_Pervasives_Native.Some - { - FStar_Syntax_Syntax.residual_effect - = uu___9; - FStar_Syntax_Syntax.residual_typ - = FStar_Pervasives_Native.Some - t; - FStar_Syntax_Syntax.residual_flags - = uu___10;_} - -> - let uu___11 ctx = - let ctx1 = - { - no_guard = (ctx.no_guard); - unfolding_ok = - (ctx.unfolding_ok); - error_context = - (("residual type", - (FStar_Pervasives_Native.Some - (CtxTerm t))) :: - (ctx.error_context)) - } in - let uu___12 = universe_of g t in - uu___12 ctx1 in - (fun ctx02 -> - let uu___12 = uu___11 ctx02 in - match uu___12 with - | Success (x2, g12) -> - let uu___13 = - let uu___14 uu___15 = - Success - ((FStar_Pervasives_Native.Some - (E_Total, t)), - FStar_Pervasives_Native.None) in - uu___14 ctx02 in - (match uu___13 with - | Success (y, g2) -> - let uu___14 = - let uu___15 = - and_pre g12 g2 in - (y, uu___15) in - Success uu___14 - | err -> err) - | Error err -> Error err) - | uu___9 -> - (fun uu___10 -> - Success - (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None)) in - fun ctx02 -> - let uu___9 = uu___8 ctx02 in - match uu___9 with - | Success (x2, g12) -> - let uu___10 = - let uu___11 = - let uu___12 = - let ctx = - match x2 with - | FStar_Pervasives_Native.None - -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some - (uu___13, t) -> - FStar_Pervasives_Native.Some - (CtxTerm t) in - fun ctx1 -> - let ctx2 = - { - no_guard = - (ctx1.no_guard); - unfolding_ok = - (ctx1.unfolding_ok); - error_context = - (("check_branches", - ctx) :: - (ctx1.error_context)) - } in - let uu___13 = - check_branches - FStar_Syntax_Util.exp_true_bool - x2 branches in - uu___13 ctx2 in - fun ctx03 -> - let uu___13 = uu___12 ctx03 in - match uu___13 with - | Success (x3, g13) -> - let uu___14 = - let uu___15 = - match x3 with - | (eff_br, t_br) -> - (fun uu___16 -> - Success - (((join_eff - eff_sc - eff_br), - t_br), - FStar_Pervasives_Native.None)) in - uu___15 ctx03 in - (match uu___14 with - | Success (y, g2) -> - let uu___15 = - let uu___16 = - and_pre g13 g2 in - (y, uu___16) in - Success uu___15 - | err -> err) - | Error err -> Error err in - uu___11 ctx02 in - (match uu___10 with - | Success (y, g2) -> - let uu___11 = - let uu___12 = and_pre g12 g2 in - (y, uu___12) in - Success uu___11 - | err -> err) - | Error err -> Error err in - uu___7 ctx01 in - (match uu___6 with - | Success (y, g2) -> - let uu___7 = - let uu___8 = and_pre g11 g2 in - (y, uu___8) in - Success uu___7 - | err -> err) - | Error err -> Error err) in - uu___3 ctx0 in - (match uu___2 with - | Success (y, g2) -> - let uu___3 = let uu___4 = and_pre g1 g2 in (y, uu___4) in - Success uu___3 - | err -> err) - | Error err -> Error err) - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = sc; - FStar_Syntax_Syntax.ret_opt = FStar_Pervasives_Native.Some - (as_x, - (FStar_Pervasives.Inl returns_ty, - FStar_Pervasives_Native.None, eq)); - FStar_Syntax_Syntax.brs = branches; - FStar_Syntax_Syntax.rc_opt1 = rc_opt;_} - -> - let uu___ = check "scrutinee" g sc in - (fun ctx0 -> - let uu___1 = uu___ ctx0 in - match uu___1 with - | Success (x, g1) -> - let uu___2 = - let uu___3 = - match x with - | (eff_sc, t_sc) -> - let uu___4 ctx = - let ctx1 = - { - no_guard = (ctx.no_guard); - unfolding_ok = (ctx.unfolding_ok); - error_context = - (("universe_of", - (FStar_Pervasives_Native.Some - (CtxTerm t_sc))) :: - (ctx.error_context)) - } in - let uu___5 = universe_of g t_sc in uu___5 ctx1 in - (fun ctx01 -> - let uu___5 = uu___4 ctx01 in - match uu___5 with - | Success (x1, g11) -> - let uu___6 = - let uu___7 = - let as_x1 = - { - FStar_Syntax_Syntax.binder_bv = - (let uu___8 = - as_x.FStar_Syntax_Syntax.binder_bv in - { - FStar_Syntax_Syntax.ppname = - (uu___8.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (uu___8.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = t_sc - }); - FStar_Syntax_Syntax.binder_qual = - (as_x.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity - = - (as_x.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs = - (as_x.FStar_Syntax_Syntax.binder_attrs) - } in - let uu___8 = open_term g as_x1 returns_ty in - match uu___8 with - | (g_as_x, as_x2, returns_ty1) -> - let uu___9 = - let uu___10 = - check "return type" g_as_x - returns_ty1 in - with_binders [as_x2] [x1] uu___10 in - (fun ctx02 -> - let uu___10 = uu___9 ctx02 in - match uu___10 with - | Success (x2, g12) -> - let uu___11 = - let uu___12 = - match x2 with - | (_eff_t, returns_ty_t) - -> - let uu___13 = - is_type g_as_x - returns_ty_t in - (fun ctx03 -> - let uu___14 = - uu___13 ctx03 in - match uu___14 with - | Success (x3, g13) - -> - let uu___15 = - let uu___16 = - let rec check_branches - path_condition - branches1 - acc_eff = - match branches1 - with - | - [] -> - let uu___17 - = - boolean_negation_simp - path_condition in - (match uu___17 - with - | - FStar_Pervasives_Native.None - -> - (fun - uu___18 - -> - Success - (acc_eff, - FStar_Pervasives_Native.None)) - | - FStar_Pervasives_Native.Some - g2 -> - let uu___18 - = - let uu___19 - = - FStar_Syntax_Util.b2t - g2 in - guard - uu___19 in - (fun - ctx04 -> - let uu___19 - = - uu___18 - ctx04 in - match uu___19 - with - | - Success - (x4, g14) - -> - let uu___20 - = - let uu___21 - uu___22 = - Success - (acc_eff, - FStar_Pervasives_Native.None) in - uu___21 - ctx04 in - (match uu___20 - with - | - Success - (y, g21) - -> - let uu___21 - = - let uu___22 - = - and_pre - g14 g21 in - (y, - uu___22) in - Success - uu___21 - | - err -> - err) - | - Error err - -> - Error err)) - | - (p, - FStar_Pervasives_Native.None, - b)::rest - -> - let uu___17 - = - open_branch - g - (p, - FStar_Pervasives_Native.None, - b) in - (match uu___17 - with - | - (uu___18, - (p1, - uu___19, - b1)) -> - let uu___20 - ctx = - let ctx1 - = - { - no_guard - = - (ctx.no_guard); - unfolding_ok - = - (ctx.unfolding_ok); - error_context - = - (("check_pat", - FStar_Pervasives_Native.None) - :: - (ctx.error_context)) - } in - let uu___21 - = - check_pat - g p1 t_sc in - uu___21 - ctx1 in - (fun - ctx04 -> - let uu___21 - = - uu___20 - ctx04 in - match uu___21 - with - | - Success - (x4, g14) - -> - let uu___22 - = - let uu___23 - = - match x4 - with - | - (bs, us) - -> - let uu___24 - = - pattern_branch_condition - g sc p1 in - (fun - ctx05 -> - let uu___25 - = - uu___24 - ctx05 in - match uu___25 - with - | - Success - (x5, g15) - -> - let uu___26 - = - let uu___27 - = - let pat_sc_eq - = - let uu___28 - = - let uu___29 - = - let uu___30 - = - FStar_TypeChecker_PatternUtils.raw_pat_as_exp - g.tcenv - p1 in - FStar_Compiler_Util.must - uu___30 in - FStar_Pervasives_Native.fst - uu___29 in - FStar_Syntax_Util.mk_eq2 - x1 t_sc - sc - uu___28 in - let uu___28 - = - combine_path_and_branch_condition - path_condition - x5 - pat_sc_eq in - match uu___28 - with - | - (this_path_condition, - next_path_condition) - -> - let g' = - push_binders - g bs in - let g'1 = - push_hypothesis - g' - this_path_condition in - let uu___29 - = - let uu___30 - = - let uu___31 - = - let uu___32 - = - check - "branch" - g'1 b1 in - fun ctx06 - -> - let uu___33 - = - uu___32 - ctx06 in - match uu___33 - with - | - Success - (x6, g16) - -> - let uu___34 - = - let uu___35 - = - match x6 - with - | - (eff_br, - tbr) -> - let expect_tbr - = - FStar_Syntax_Subst.subst - [ - FStar_Syntax_Syntax.NT - ((as_x2.FStar_Syntax_Syntax.binder_bv), - sc)] - returns_ty1 in - let rel = - if eq - then - EQUALITY - else - SUBTYPING - (FStar_Pervasives_Native.Some - b1) in - let uu___36 - ctx = - let ctx1 - = - { - no_guard - = - (ctx.no_guard); - unfolding_ok - = - (ctx.unfolding_ok); - error_context - = - (("branch check relation", - FStar_Pervasives_Native.None) - :: - (ctx.error_context)) - } in - let uu___37 - = - check_relation - g'1 rel - tbr - expect_tbr in - uu___37 - ctx1 in - (fun - ctx07 -> - let uu___37 - = - uu___36 - ctx07 in - match uu___37 - with - | - Success - (x7, g17) - -> - let uu___38 - = - let uu___39 - uu___40 = - Success - (((join_eff - eff_br - acc_eff), - expect_tbr), - FStar_Pervasives_Native.None) in - uu___39 - ctx07 in - (match uu___38 - with - | - Success - (y, g2) - -> - let uu___39 - = - let uu___40 - = - and_pre - g17 g2 in - (y, - uu___40) in - Success - uu___39 - | - err -> - err) - | - Error err - -> - Error err) in - uu___35 - ctx06 in - (match uu___34 - with - | - Success - (y, g2) - -> - let uu___35 - = - let uu___36 - = - and_pre - g16 g2 in - (y, - uu___36) in - Success - uu___35 - | - err -> - err) - | - Error err - -> - Error err in - weaken - this_path_condition - uu___31 in - with_binders - bs us - uu___30 in - (fun - ctx06 -> - let uu___30 - = - uu___29 - ctx06 in - match uu___30 - with - | - Success - (x6, g16) - -> - let uu___31 - = - let uu___32 - = - match x6 - with - | - (eff_br, - tbr) -> - (match - p1.FStar_Syntax_Syntax.v - with - | - FStar_Syntax_Syntax.Pat_var - uu___33 - -> - (match rest - with - | - uu___34::uu___35 - -> - fail - "Redundant branches after wildcard" - | - uu___34 - -> - (fun - uu___35 - -> - Success - (eff_br, - FStar_Pervasives_Native.None))) - | - uu___33 - -> - check_branches - next_path_condition - rest - eff_br) in - uu___32 - ctx06 in - (match uu___31 - with - | - Success - (y, g2) - -> - let uu___32 - = - let uu___33 - = - and_pre - g16 g2 in - (y, - uu___33) in - Success - uu___32 - | - err -> - err) - | - Error err - -> - Error err) in - uu___27 - ctx05 in - (match uu___26 - with - | - Success - (y, g2) - -> - let uu___27 - = - let uu___28 - = - and_pre - g15 g2 in - (y, - uu___28) in - Success - uu___27 - | - err -> - err) - | - Error err - -> - Error err) in - uu___23 - ctx04 in - (match uu___22 - with - | - Success - (y, g2) - -> - let uu___23 - = - let uu___24 - = - and_pre - g14 g2 in - (y, - uu___24) in - Success - uu___23 - | - err -> - err) - | - Error err - -> - Error err)) in - let uu___17 - = - check_branches - FStar_Syntax_Util.exp_true_bool - branches - E_Total in - fun ctx04 - -> - let uu___18 - = - uu___17 - ctx04 in - match uu___18 - with - | - Success - (x4, g14) - -> - let uu___19 - = - let uu___20 - = - let ty = - FStar_Syntax_Subst.subst - [ - FStar_Syntax_Syntax.NT - ((as_x2.FStar_Syntax_Syntax.binder_bv), - sc)] - returns_ty1 in - fun - uu___21 - -> - Success - ((x4, ty), - FStar_Pervasives_Native.None) in - uu___20 - ctx04 in - (match uu___19 - with - | - Success - (y, g2) - -> - let uu___20 - = - let uu___21 - = - and_pre - g14 g2 in - (y, - uu___21) in - Success - uu___20 - | - err -> - err) - | - Error err - -> - Error err in - uu___16 ctx03 in - (match uu___15 - with - | Success - (y, g2) -> - let uu___16 - = - let uu___17 - = - and_pre - g13 g2 in - (y, - uu___17) in - Success - uu___16 - | err -> err) - | Error err -> - Error err) in - uu___12 ctx02 in - (match uu___11 with - | Success (y, g2) -> - let uu___12 = - let uu___13 = - and_pre g12 g2 in - (y, uu___13) in - Success uu___12 - | err -> err) - | Error err -> Error err) in - uu___7 ctx01 in - (match uu___6 with - | Success (y, g2) -> - let uu___7 = - let uu___8 = and_pre g11 g2 in - (y, uu___8) in - Success uu___7 - | err -> err) - | Error err -> Error err) in - uu___3 ctx0 in - (match uu___2 with - | Success (y, g2) -> - let uu___3 = let uu___4 = and_pre g1 g2 in (y, uu___4) in - Success uu___3 - | err -> err) - | Error err -> Error err) - | FStar_Syntax_Syntax.Tm_match uu___ -> - fail "Match with effect returns ascription, or tactic handler" - | uu___ -> - let uu___1 = - let uu___2 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term e1 in - FStar_Compiler_Util.format1 "Unexpected term: %s" uu___2 in - fail uu___1 -and (check_binders : - env -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.universe Prims.list result) - = - fun g_initial -> - fun xs -> - let rec aux g xs1 = - match xs1 with - | [] -> (fun uu___ -> Success ([], FStar_Pervasives_Native.None)) - | x::xs2 -> - let uu___ = - check "binder sort" g - (x.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - (fun ctx0 -> - let uu___1 = uu___ ctx0 in - match uu___1 with - | Success (x1, g1) -> - let uu___2 = - let uu___3 = - match x1 with - | (uu___4, t) -> - let uu___5 = is_type g t in - (fun ctx01 -> - let uu___6 = uu___5 ctx01 in - match uu___6 with - | Success (x2, g11) -> - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = push_binder g x in - aux uu___11 xs2 in - fun ctx02 -> - let uu___11 = uu___10 ctx02 in - match uu___11 with - | Success (x3, g12) -> - let uu___12 = - let uu___13 uu___14 = - Success - ((x2 :: x3), - FStar_Pervasives_Native.None) in - uu___13 ctx02 in - (match uu___12 with - | Success (y, g2) -> - let uu___13 = - let uu___14 = - and_pre g12 g2 in - (y, uu___14) in - Success uu___13 - | err -> err) - | Error err -> Error err in - with_binders [x] [x2] uu___9 in - uu___8 ctx01 in - (match uu___7 with - | Success (y, g2) -> - let uu___8 = - let uu___9 = and_pre g11 g2 in - (y, uu___9) in - Success uu___8 - | err -> err) - | Error err -> Error err) in - uu___3 ctx0 in - (match uu___2 with - | Success (y, g2) -> - let uu___3 = - let uu___4 = and_pre g1 g2 in (y, uu___4) in - Success uu___3 - | err -> err) - | Error err -> Error err) in - aux g_initial xs -and (check_comp : - env -> FStar_Syntax_Syntax.comp -> FStar_Syntax_Syntax.universe result) = - fun g -> - fun c -> - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total t -> - let uu___ = - check "(G)Tot comp result" g (FStar_Syntax_Util.comp_result c) in - (fun ctx0 -> - let uu___1 = uu___ ctx0 in - match uu___1 with - | Success (x, g1) -> - let uu___2 = - let uu___3 = match x with | (uu___4, t1) -> is_type g t1 in - uu___3 ctx0 in - (match uu___2 with - | Success (y, g2) -> - let uu___3 = let uu___4 = and_pre g1 g2 in (y, uu___4) in - Success uu___3 - | err -> err) - | Error err -> Error err) - | FStar_Syntax_Syntax.GTotal t -> - let uu___ = - check "(G)Tot comp result" g (FStar_Syntax_Util.comp_result c) in - (fun ctx0 -> - let uu___1 = uu___ ctx0 in - match uu___1 with - | Success (x, g1) -> - let uu___2 = - let uu___3 = match x with | (uu___4, t1) -> is_type g t1 in - uu___3 ctx0 in - (match uu___2 with - | Success (y, g2) -> - let uu___3 = let uu___4 = and_pre g1 g2 in (y, uu___4) in - Success uu___3 - | err -> err) - | Error err -> Error err) - | FStar_Syntax_Syntax.Comp ct -> - if - (FStar_Compiler_List.length ct.FStar_Syntax_Syntax.comp_univs) <> - Prims.int_one - then fail "Unexpected/missing universe instantitation in comp" - else - (let u = FStar_Compiler_List.hd ct.FStar_Syntax_Syntax.comp_univs in - let effect_app_tm = - let head = - let uu___1 = - FStar_Syntax_Syntax.fvar - ct.FStar_Syntax_Syntax.effect_name - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.mk_Tm_uinst uu___1 [u] in - let uu___1 = - let uu___2 = - FStar_Syntax_Syntax.as_arg - ct.FStar_Syntax_Syntax.result_typ in - uu___2 :: (ct.FStar_Syntax_Syntax.effect_args) in - FStar_Syntax_Syntax.mk_Tm_app head uu___1 - (ct.FStar_Syntax_Syntax.result_typ).FStar_Syntax_Syntax.pos in - let uu___1 = check "effectful comp" g effect_app_tm in - fun ctx0 -> - let uu___2 = uu___1 ctx0 in - match uu___2 with - | Success (x, g1) -> - let uu___3 = - let uu___4 = - match x with - | (uu___5, t) -> - let uu___6 ctx = - let ctx1 = - { - no_guard = (ctx.no_guard); - unfolding_ok = (ctx.unfolding_ok); - error_context = - (("comp fully applied", - FStar_Pervasives_Native.None) :: - (ctx.error_context)) - } in - let uu___7 = - check_subtype g FStar_Pervasives_Native.None t - FStar_Syntax_Syntax.teff in - uu___7 ctx1 in - (fun ctx01 -> - let uu___7 = uu___6 ctx01 in - match uu___7 with - | Success (x1, g11) -> - let uu___8 = - let uu___9 = - let c_lid = - FStar_TypeChecker_Env.norm_eff_name - g.tcenv - ct.FStar_Syntax_Syntax.effect_name in - let is_total = - let uu___10 = - FStar_TypeChecker_Env.lookup_effect_quals - g.tcenv c_lid in - FStar_Compiler_List.existsb - (fun q -> - q = - FStar_Syntax_Syntax.TotalEffect) - uu___10 in - if Prims.op_Negation is_total - then - fun uu___10 -> - Success - (FStar_Syntax_Syntax.U_zero, - FStar_Pervasives_Native.None) - else - (let uu___11 = - FStar_Syntax_Util.is_pure_or_ghost_effect - c_lid in - if uu___11 - then - fun uu___12 -> - Success - (u, - FStar_Pervasives_Native.None) - else - (let uu___13 = - FStar_TypeChecker_Env.effect_repr - g.tcenv c u in - match uu___13 with - | FStar_Pervasives_Native.None -> - let uu___14 = - let uu___15 = - FStar_Ident.string_of_lid - (FStar_Syntax_Util.comp_effect_name - c) in - let uu___16 = - FStar_Ident.string_of_lid - c_lid in - FStar_Compiler_Util.format2 - "Total effect %s (normalized to %s) does not have a representation" - uu___15 uu___16 in - fail uu___14 - | FStar_Pervasives_Native.Some tm - -> universe_of g tm)) in - uu___9 ctx01 in - (match uu___8 with - | Success (y, g2) -> - let uu___9 = - let uu___10 = and_pre g11 g2 in - (y, uu___10) in - Success uu___9 - | err -> err) - | Error err -> Error err) in - uu___4 ctx0 in - (match uu___3 with - | Success (y, g2) -> - let uu___4 = - let uu___5 = and_pre g1 g2 in (y, uu___5) in - Success uu___4 - | err -> err) - | Error err -> Error err) -and (universe_of : - env -> FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.universe result) = - fun g -> - fun t -> - let uu___ = check "universe of" g t in - fun ctx0 -> - let uu___1 = uu___ ctx0 in - match uu___1 with - | Success (x, g1) -> - let uu___2 = - let uu___3 = match x with | (uu___4, t1) -> is_type g t1 in - uu___3 ctx0 in - (match uu___2 with - | Success (y, g2) -> - let uu___3 = let uu___4 = and_pre g1 g2 in (y, uu___4) in - Success uu___3 - | err -> err) - | Error err -> Error err -and (check_pat : - env -> - FStar_Syntax_Syntax.pat -> - FStar_Syntax_Syntax.typ -> - (FStar_Syntax_Syntax.binders * FStar_Syntax_Syntax.universes) result) - = - fun g -> - fun p -> - fun t_sc -> - let unrefine_tsc t_sc1 = - let uu___ = - FStar_TypeChecker_Normalize.normalize_refinement - FStar_TypeChecker_Normalize.whnf_steps g.tcenv t_sc1 in - FStar_Syntax_Util.unrefine uu___ in - match p.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_constant c -> - let e = - match c with - | FStar_Const.Const_int (repr, FStar_Pervasives_Native.Some sw) - -> - FStar_ToSyntax_ToSyntax.desugar_machine_integer - (g.tcenv).FStar_TypeChecker_Env.dsenv repr sw - p.FStar_Syntax_Syntax.p - | uu___ -> - FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_constant c) - p.FStar_Syntax_Syntax.p in - let uu___ = check "pat_const" g e in - (fun ctx0 -> - let uu___1 = uu___ ctx0 in - match uu___1 with - | Success (x, g1) -> - let uu___2 = - let uu___3 = - match x with - | (uu___4, t_const) -> - let uu___5 ctx = - let ctx1 = - { - no_guard = (ctx.no_guard); - unfolding_ok = (ctx.unfolding_ok); - error_context = - (("check_pat constant", - FStar_Pervasives_Native.None) :: - (ctx.error_context)) - } in - let uu___6 = - let uu___7 = unrefine_tsc t_sc in - check_subtype g - (FStar_Pervasives_Native.Some e) t_const - uu___7 in - uu___6 ctx1 in - (fun ctx01 -> - let uu___6 = uu___5 ctx01 in - match uu___6 with - | Success (x1, g11) -> - let uu___7 = - let uu___8 uu___9 = - Success - (([], []), - FStar_Pervasives_Native.None) in - uu___8 ctx01 in - (match uu___7 with - | Success (y, g2) -> - let uu___8 = - let uu___9 = and_pre g11 g2 in - (y, uu___9) in - Success uu___8 - | err -> err) - | Error err -> Error err) in - uu___3 ctx0 in - (match uu___2 with - | Success (y, g2) -> - let uu___3 = - let uu___4 = and_pre g1 g2 in (y, uu___4) in - Success uu___3 - | err -> err) - | Error err -> Error err) - | FStar_Syntax_Syntax.Pat_var bv -> - let b = - FStar_Syntax_Syntax.mk_binder - { - FStar_Syntax_Syntax.ppname = - (bv.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = (bv.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = t_sc - } in - let uu___ ctx = - let ctx1 = - { - no_guard = (ctx.no_guard); - unfolding_ok = (ctx.unfolding_ok); - error_context = - (("check_pat_binder", FStar_Pervasives_Native.None) :: - (ctx.error_context)) - } in - let uu___1 = check_binders g [b] in uu___1 ctx1 in - (fun ctx0 -> - let uu___1 = uu___ ctx0 in - match uu___1 with - | Success (x, g1) -> - let uu___2 = - let uu___3 = - match x with - | u::[] -> - (fun uu___4 -> - Success - (([b], [u]), FStar_Pervasives_Native.None)) in - uu___3 ctx0 in - (match uu___2 with - | Success (y, g2) -> - let uu___3 = - let uu___4 = and_pre g1 g2 in (y, uu___4) in - Success uu___3 - | err -> err) - | Error err -> Error err) - | FStar_Syntax_Syntax.Pat_cons (fv, usopt, pats) -> - let us = - if FStar_Compiler_Util.is_none usopt - then [] - else FStar_Compiler_Util.must usopt in - let uu___ = - let uu___1 = - let uu___2 = FStar_Syntax_Syntax.lid_of_fv fv in - FStar_TypeChecker_Env.lookup_and_inst_datacon g.tcenv us - uu___2 in - FStar_Syntax_Util.arrow_formals uu___1 in - (match uu___ with - | (formals, t_pat) -> - let uu___1 = - let pats1 = - FStar_Compiler_List.map FStar_Pervasives_Native.fst pats in - let uu___2 = - let uu___3 = - FStar_Compiler_Util.prefix_until - (fun p1 -> - match p1.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_dot_term uu___4 -> - false - | uu___4 -> true) pats1 in - FStar_Compiler_Util.map_option - (fun uu___4 -> - match uu___4 with - | (dot_pats, pat, rest_pats) -> - (dot_pats, (pat :: rest_pats))) uu___3 in - FStar_Compiler_Util.dflt (pats1, []) uu___2 in - (match uu___1 with - | (dot_pats, rest_pats) -> - let uu___2 = - FStar_Compiler_List.splitAt - (FStar_Compiler_List.length dot_pats) formals in - (match uu___2 with - | (dot_formals, rest_formals) -> - let uu___3 = - fold2 - (fun ss -> - fun uu___4 -> - fun p1 -> - match uu___4 with - | { FStar_Syntax_Syntax.binder_bv = f; - FStar_Syntax_Syntax.binder_qual = - uu___5; - FStar_Syntax_Syntax.binder_positivity - = uu___6; - FStar_Syntax_Syntax.binder_attrs = - uu___7;_} - -> - let expected_t = - FStar_Syntax_Subst.subst ss - f.FStar_Syntax_Syntax.sort in - let uu___8 = - match p1.FStar_Syntax_Syntax.v - with - | FStar_Syntax_Syntax.Pat_dot_term - (FStar_Pervasives_Native.Some - t) -> - (fun uu___9 -> - Success - (t, - FStar_Pervasives_Native.None)) - | uu___9 -> - fail - "check_pat in core has unset dot pattern" in - (fun ctx0 -> - let uu___9 = uu___8 ctx0 in - match uu___9 with - | Success (x, g1) -> - let uu___10 = - let uu___11 = - let uu___12 = - check "pat dot term" g - x in - fun ctx01 -> - let uu___13 = - uu___12 ctx01 in - match uu___13 with - | Success (x1, g11) -> - let uu___14 = - let uu___15 = - match x1 with - | (uu___16, - p_t) -> - let uu___17 - ctx = - let ctx1 - = - { - no_guard - = - (ctx.no_guard); - unfolding_ok - = - (ctx.unfolding_ok); - error_context - = - (("check_pat cons", - FStar_Pervasives_Native.None) - :: - (ctx.error_context)) - } in - let uu___18 - = - check_subtype - g - (FStar_Pervasives_Native.Some - x) p_t - expected_t in - uu___18 - ctx1 in - (fun ctx02 - -> - let uu___18 - = - uu___17 - ctx02 in - match uu___18 - with - | - Success - (x2, g12) - -> - let uu___19 - = - let uu___20 - uu___21 = - Success - ((FStar_List_Tot_Base.op_At - ss - [ - FStar_Syntax_Syntax.NT - (f, x)]), - FStar_Pervasives_Native.None) in - uu___20 - ctx02 in - (match uu___19 - with - | - Success - (y, g2) - -> - let uu___20 - = - let uu___21 - = - and_pre - g12 g2 in - (y, - uu___21) in - Success - uu___20 - | - err -> - err) - | - Error err - -> - Error err) in - uu___15 ctx01 in - (match uu___14 - with - | Success - (y, g2) -> - let uu___15 = - let uu___16 - = - and_pre - g11 g2 in - (y, - uu___16) in - Success - uu___15 - | err -> err) - | Error err -> - Error err in - uu___11 ctx0 in - (match uu___10 with - | Success (y, g2) -> - let uu___11 = - let uu___12 = - and_pre g1 g2 in - (y, uu___12) in - Success uu___11 - | err -> err) - | Error err -> Error err)) [] - dot_formals dot_pats in - (fun ctx0 -> - let uu___4 = uu___3 ctx0 in - match uu___4 with - | Success (x, g1) -> - let uu___5 = - let uu___6 = - let uu___7 = - fold2 - (fun uu___8 -> - fun uu___9 -> - fun p1 -> - match (uu___8, uu___9) with - | ((g2, ss, bs, us1), - { - FStar_Syntax_Syntax.binder_bv - = f; - FStar_Syntax_Syntax.binder_qual - = uu___10; - FStar_Syntax_Syntax.binder_positivity - = uu___11; - FStar_Syntax_Syntax.binder_attrs - = uu___12;_}) - -> - let expected_t = - FStar_Syntax_Subst.subst - ss - f.FStar_Syntax_Syntax.sort in - let uu___13 = - let uu___14 = - check_pat g2 p1 - expected_t in - with_binders bs us1 - uu___14 in - (fun ctx01 -> - let uu___14 = - uu___13 ctx01 in - match uu___14 with - | Success (x1, g11) - -> - let uu___15 = - let uu___16 = - match x1 with - | (bs_p, - us_p) -> - let p_e = - let uu___17 - = - let uu___18 - = - FStar_TypeChecker_PatternUtils.raw_pat_as_exp - g2.tcenv - p1 in - FStar_Compiler_Util.must - uu___18 in - FStar_Pervasives_Native.fst - uu___17 in - let uu___17 - = - let uu___18 - = - push_binders - g2 bs_p in - (uu___18, - (FStar_List_Tot_Base.op_At - ss - [ - FStar_Syntax_Syntax.NT - (f, p_e)]), - (FStar_List_Tot_Base.op_At - bs bs_p), - (FStar_List_Tot_Base.op_At - us1 us_p)) in - (fun - uu___18 - -> - Success - (uu___17, - FStar_Pervasives_Native.None)) in - uu___16 ctx01 in - (match uu___15 - with - | Success - (y, g21) -> - let uu___16 - = - let uu___17 - = - and_pre - g11 g21 in - (y, - uu___17) in - Success - uu___16 - | err -> err) - | Error err -> - Error err)) - (g, x, [], []) rest_formals - rest_pats in - fun ctx01 -> - let uu___8 = uu___7 ctx01 in - match uu___8 with - | Success (x1, g11) -> - let uu___9 = - let uu___10 = - match x1 with - | (uu___11, ss, bs, us1) -> - let t_pat1 = - FStar_Syntax_Subst.subst - ss t_pat in - let uu___12 = - let uu___13 = - let uu___14 = - unrefine_tsc t_sc in - check_scrutinee_pattern_type_compatible - g uu___14 t_pat1 in - no_guard uu___13 in - (fun ctx02 -> - let uu___13 = - uu___12 ctx02 in - match uu___13 with - | Success (x2, g12) -> - let uu___14 = - let uu___15 - uu___16 = - Success - ((bs, us1), - FStar_Pervasives_Native.None) in - uu___15 ctx02 in - (match uu___14 - with - | Success - (y, g2) -> - let uu___15 = - let uu___16 - = - and_pre - g12 g2 in - (y, - uu___16) in - Success - uu___15 - | err -> err) - | Error err -> - Error err) in - uu___10 ctx01 in - (match uu___9 with - | Success (y, g2) -> - let uu___10 = - let uu___11 = - and_pre g11 g2 in - (y, uu___11) in - Success uu___10 - | err -> err) - | Error err -> Error err in - uu___6 ctx0 in - (match uu___5 with - | Success (y, g2) -> - let uu___6 = - let uu___7 = and_pre g1 g2 in - (y, uu___7) in - Success uu___6 - | err -> err) - | Error err -> Error err)))) - | uu___ -> fail "check_pat called with a dot pattern" -and (check_scrutinee_pattern_type_compatible : - env -> - FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.typ -> precondition result) - = - fun g -> - fun t_sc -> - fun t_pat -> - let err s = - let uu___ = - let uu___1 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t_sc in - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t_pat in - FStar_Compiler_Util.format3 - "Scrutinee type %s and Pattern type %s are not compatible because %s" - uu___1 uu___2 s in - fail uu___ in - let uu___ = FStar_Syntax_Util.head_and_args t_sc in - match uu___ with - | (head_sc, args_sc) -> - let uu___1 = FStar_Syntax_Util.head_and_args t_pat in - (match uu___1 with - | (head_pat, args_pat) -> - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Subst.compress head_sc in - uu___5.FStar_Syntax_Syntax.n in - let uu___5 = - let uu___6 = FStar_Syntax_Subst.compress head_pat in - uu___6.FStar_Syntax_Syntax.n in - (uu___4, uu___5) in - match uu___3 with - | (FStar_Syntax_Syntax.Tm_fvar fv_head, - FStar_Syntax_Syntax.Tm_fvar fv_pat) when - let uu___4 = FStar_Syntax_Syntax.lid_of_fv fv_head in - let uu___5 = FStar_Syntax_Syntax.lid_of_fv fv_pat in - FStar_Ident.lid_equals uu___4 uu___5 -> - (fun uu___4 -> - Success (fv_head, FStar_Pervasives_Native.None)) - | (FStar_Syntax_Syntax.Tm_uinst - ({ - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar - fv_head; - FStar_Syntax_Syntax.pos = uu___4; - FStar_Syntax_Syntax.vars = uu___5; - FStar_Syntax_Syntax.hash_code = uu___6;_}, - us_head), - FStar_Syntax_Syntax.Tm_uinst - ({ - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar - fv_pat; - FStar_Syntax_Syntax.pos = uu___7; - FStar_Syntax_Syntax.vars = uu___8; - FStar_Syntax_Syntax.hash_code = uu___9;_}, - us_pat)) when - let uu___10 = FStar_Syntax_Syntax.lid_of_fv fv_head in - let uu___11 = FStar_Syntax_Syntax.lid_of_fv fv_pat in - FStar_Ident.lid_equals uu___10 uu___11 -> - let uu___10 = - FStar_TypeChecker_Rel.teq_nosmt_force g.tcenv - head_sc head_pat in - if uu___10 - then - (fun uu___11 -> - Success (fv_head, FStar_Pervasives_Native.None)) - else err "Incompatible universe instantiations" - | (uu___4, uu___5) -> - let uu___6 = - let uu___7 = - FStar_Class_Tagged.tag_of - FStar_Syntax_Syntax.tagged_term head_sc in - let uu___8 = - FStar_Class_Tagged.tag_of - FStar_Syntax_Syntax.tagged_term head_pat in - FStar_Compiler_Util.format2 - "Head constructors(%s and %s) not fvar" uu___7 - uu___8 in - err uu___6 in - (fun ctx0 -> - let uu___3 = uu___2 ctx0 in - match uu___3 with - | Success (x, g1) -> - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = FStar_Syntax_Syntax.lid_of_fv x in - FStar_TypeChecker_Env.is_type_constructor - g.tcenv uu___8 in - if uu___7 - then - fun uu___8 -> - Success (x, FStar_Pervasives_Native.None) - else - (let uu___9 = - let uu___10 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_fv x in - FStar_Compiler_Util.format1 - "%s is not a type constructor" uu___10 in - err uu___9) in - fun ctx01 -> - let uu___7 = uu___6 ctx01 in - match uu___7 with - | Success (x1, g11) -> - let uu___8 = - let uu___9 = - let uu___10 = - if - (FStar_Compiler_List.length args_sc) - = - (FStar_Compiler_List.length - args_pat) - then - fun uu___11 -> - Success - (x, - FStar_Pervasives_Native.None) - else - (let uu___12 = - let uu___13 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length - args_sc) in - let uu___14 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length - args_pat) in - FStar_Compiler_Util.format2 - "Number of arguments don't match (%s and %s)" - uu___13 uu___14 in - err uu___12) in - fun ctx02 -> - let uu___11 = uu___10 ctx02 in - match uu___11 with - | Success (x2, g12) -> - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = - FStar_Syntax_Syntax.lid_of_fv - x in - FStar_TypeChecker_Env.num_inductive_ty_params - g.tcenv uu___16 in - match uu___15 with - | FStar_Pervasives_Native.None - -> (args_sc, args_pat) - | FStar_Pervasives_Native.Some - n -> - let uu___16 = - let uu___17 = - FStar_Compiler_Util.first_N - n args_sc in - FStar_Pervasives_Native.fst - uu___17 in - let uu___17 = - let uu___18 = - FStar_Compiler_Util.first_N - n args_pat in - FStar_Pervasives_Native.fst - uu___18 in - (uu___16, uu___17) in - match uu___14 with - | (params_sc, params_pat) -> - let uu___15 = - iter2 params_sc - params_pat - (fun uu___16 -> - fun uu___17 -> - fun uu___18 -> - match - (uu___16, - uu___17) - with - | ((t_sc1, - uu___19), - (t_pat1, - uu___20)) - -> - check_relation - g - EQUALITY - t_sc1 - t_pat1) - () in - (fun ctx03 -> - let uu___16 = - uu___15 ctx03 in - match uu___16 with - | Success (x3, g13) -> - let uu___17 = - let uu___18 - uu___19 = - Success - (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None) in - uu___18 ctx03 in - (match uu___17 - with - | Success - (y, g2) -> - let uu___18 = - let uu___19 - = - and_pre - g13 g2 in - (y, - uu___19) in - Success - uu___18 - | err1 -> err1) - | Error err1 -> - Error err1) in - uu___13 ctx02 in - (match uu___12 with - | Success (y, g2) -> - let uu___13 = - let uu___14 = - and_pre g12 g2 in - (y, uu___14) in - Success uu___13 - | err1 -> err1) - | Error err1 -> Error err1 in - uu___9 ctx01 in - (match uu___8 with - | Success (y, g2) -> - let uu___9 = - let uu___10 = and_pre g11 g2 in - (y, uu___10) in - Success uu___9 - | err1 -> err1) - | Error err1 -> Error err1 in - uu___5 ctx0 in - (match uu___4 with - | Success (y, g2) -> - let uu___5 = - let uu___6 = and_pre g1 g2 in (y, uu___6) in - Success uu___5 - | err1 -> err1) - | Error err1 -> Error err1)) -and (pattern_branch_condition : - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.pat -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option result) - = - fun g -> - fun scrutinee -> - fun pat -> - match pat.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_var uu___ -> - (fun uu___1 -> - Success - (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None)) - | FStar_Syntax_Syntax.Pat_constant c -> - let const_exp = - let uu___ = - FStar_TypeChecker_PatternUtils.raw_pat_as_exp g.tcenv pat in - match uu___ with - | FStar_Pervasives_Native.None -> failwith "Impossible" - | FStar_Pervasives_Native.Some (e, uu___1) -> e in - let uu___ = check "constant pattern" g const_exp in - (fun ctx0 -> - let uu___1 = uu___ ctx0 in - match uu___1 with - | Success (x, g1) -> - let uu___2 = - let uu___3 = - match x with - | (uu___4, t_const) -> - let uu___5 = - let uu___6 = - FStar_Syntax_Util.mk_decidable_eq t_const - scrutinee const_exp in - FStar_Pervasives_Native.Some uu___6 in - (fun uu___6 -> - Success (uu___5, FStar_Pervasives_Native.None)) in - uu___3 ctx0 in - (match uu___2 with - | Success (y, g2) -> - let uu___3 = - let uu___4 = and_pre g1 g2 in (y, uu___4) in - Success uu___3 - | err -> err) - | Error err -> Error err) - | FStar_Syntax_Syntax.Pat_cons (fv, us_opt, sub_pats) -> - let wild_pat pos = - let uu___ = - let uu___1 = - FStar_Syntax_Syntax.new_bv FStar_Pervasives_Native.None - FStar_Syntax_Syntax.tun in - FStar_Syntax_Syntax.Pat_var uu___1 in - FStar_Syntax_Syntax.withinfo uu___ pos in - let mk_head_discriminator uu___ = - let pat1 = - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Compiler_List.map - (fun uu___4 -> - match uu___4 with - | (s, b) -> - let uu___5 = wild_pat s.FStar_Syntax_Syntax.p in - (uu___5, b)) sub_pats in - (fv, us_opt, uu___3) in - FStar_Syntax_Syntax.Pat_cons uu___2 in - FStar_Syntax_Syntax.withinfo uu___1 pat.FStar_Syntax_Syntax.p in - let branch1 = - (pat1, FStar_Pervasives_Native.None, - FStar_Syntax_Util.exp_true_bool) in - let branch2 = - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Syntax_Syntax.new_bv FStar_Pervasives_Native.None - FStar_Syntax_Syntax.tun in - FStar_Syntax_Syntax.Pat_var uu___3 in - FStar_Syntax_Syntax.withinfo uu___2 - pat1.FStar_Syntax_Syntax.p in - (uu___1, FStar_Pervasives_Native.None, - FStar_Syntax_Util.exp_false_bool) in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_match - { - FStar_Syntax_Syntax.scrutinee = scrutinee; - FStar_Syntax_Syntax.ret_opt = - FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.brs = [branch1; branch2]; - FStar_Syntax_Syntax.rc_opt1 = - FStar_Pervasives_Native.None - }) scrutinee.FStar_Syntax_Syntax.pos in - let mk_ith_projector i = - let uu___ = - let bv = - FStar_Syntax_Syntax.new_bv FStar_Pervasives_Native.None - FStar_Syntax_Syntax.tun in - let uu___1 = - FStar_Syntax_Syntax.withinfo - (FStar_Syntax_Syntax.Pat_var bv) - scrutinee.FStar_Syntax_Syntax.pos in - (bv, uu___1) in - match uu___ with - | (ith_pat_var, ith_pat) -> - let sub_pats1 = - FStar_Compiler_List.mapi - (fun j -> - fun uu___1 -> - match uu___1 with - | (s, b) -> - if i <> j - then - let uu___2 = - wild_pat s.FStar_Syntax_Syntax.p in - (uu___2, b) - else (ith_pat, b)) sub_pats in - let pat1 = - FStar_Syntax_Syntax.withinfo - (FStar_Syntax_Syntax.Pat_cons (fv, us_opt, sub_pats1)) - pat.FStar_Syntax_Syntax.p in - let branch = FStar_Syntax_Syntax.bv_to_name ith_pat_var in - let eqn = - FStar_Syntax_Subst.close_branch - (pat1, FStar_Pervasives_Native.None, branch) in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_match - { - FStar_Syntax_Syntax.scrutinee = scrutinee; - FStar_Syntax_Syntax.ret_opt = - FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.brs = [eqn]; - FStar_Syntax_Syntax.rc_opt1 = - FStar_Pervasives_Native.None - }) scrutinee.FStar_Syntax_Syntax.pos in - let discrimination = - let uu___ = - let uu___1 = - FStar_TypeChecker_Env.typ_of_datacon g.tcenv - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - FStar_TypeChecker_Env.datacons_of_typ g.tcenv uu___1 in - match uu___ with - | (is_induc, datacons) -> - if - (Prims.op_Negation is_induc) || - ((FStar_Compiler_List.length datacons) > Prims.int_one) - then - let discriminator = - FStar_Syntax_Util.mk_discriminator - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - let uu___1 = - FStar_TypeChecker_Env.try_lookup_lid g.tcenv - discriminator in - (match uu___1 with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | uu___2 -> - let uu___3 = mk_head_discriminator () in - FStar_Pervasives_Native.Some uu___3) - else FStar_Pervasives_Native.None in - let uu___ = - mapi - (fun i -> - fun uu___1 -> - match uu___1 with - | (pi, uu___2) -> - (match pi.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_dot_term uu___3 -> - (fun uu___4 -> - Success - (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None)) - | FStar_Syntax_Syntax.Pat_var uu___3 -> - (fun uu___4 -> - Success - (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None)) - | uu___3 -> - let scrutinee_sub_term = mk_ith_projector i in - let uu___4 = mk_ith_projector i in - pattern_branch_condition g uu___4 pi)) sub_pats in - (fun ctx0 -> - let uu___1 = uu___ ctx0 in - match uu___1 with - | Success (x, g1) -> - let uu___2 = - let uu___3 = - let guards = - FStar_Compiler_List.collect - (fun uu___4 -> - match uu___4 with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some t -> [t]) - (discrimination :: x) in - match guards with - | [] -> - (fun uu___4 -> - Success - (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None)) - | guards1 -> - let uu___4 = - let uu___5 = FStar_Syntax_Util.mk_and_l guards1 in - FStar_Pervasives_Native.Some uu___5 in - (fun uu___5 -> - Success (uu___4, FStar_Pervasives_Native.None)) in - uu___3 ctx0 in - (match uu___2 with - | Success (y, g2) -> - let uu___3 = - let uu___4 = and_pre g1 g2 in (y, uu___4) in - Success uu___3 - | err -> err) - | Error err -> Error err) -let (initial_env : - FStar_TypeChecker_Env.env -> - guard_handler_t FStar_Pervasives_Native.option -> env) - = - fun g -> - fun gh -> - let max_index = - FStar_Compiler_List.fold_left - (fun index -> - fun b -> - match b with - | FStar_Syntax_Syntax.Binding_var x -> - if x.FStar_Syntax_Syntax.index > index - then x.FStar_Syntax_Syntax.index - else index - | uu___ -> index) Prims.int_zero g.FStar_TypeChecker_Env.gamma in - { - tcenv = g; - allow_universe_instantiation = false; - max_binder_index = max_index; - guard_handler = gh; - should_read_cache = true - } -let (check_term_top : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.typ FStar_Pervasives_Native.option -> - Prims.bool -> - guard_handler_t FStar_Pervasives_Native.option -> - (tot_or_ghost * FStar_Syntax_Syntax.typ) result) - = - fun g -> - fun e -> - fun topt -> - fun must_tot -> - fun gh -> - let g1 = initial_env g gh in - let uu___ = check "top" g1 e in - fun ctx0 -> - let uu___1 = uu___ ctx0 in - match uu___1 with - | Success (x, g11) -> - let uu___2 = - let uu___3 = - match topt with - | FStar_Pervasives_Native.None -> - if must_tot - then - let uu___4 = x in - (match uu___4 with - | (eff, t) -> - let uu___5 = - (eff = E_Ghost) && - (let uu___6 = non_informative g1 t in - Prims.op_Negation uu___6) in - if uu___5 - then - fail "expected total effect, found ghost" - else - (fun uu___7 -> - Success - ((E_Total, t), - FStar_Pervasives_Native.None))) - else - (fun uu___5 -> - Success (x, FStar_Pervasives_Native.None)) - | FStar_Pervasives_Native.Some t -> - let uu___4 = - if - must_tot || - ((FStar_Pervasives_Native.fst x) = E_Total) - then - let uu___5 = FStar_Syntax_Syntax.mk_Total t in - (uu___5, E_Total) - else - (let uu___6 = FStar_Syntax_Syntax.mk_GTotal t in - (uu___6, E_Ghost)) in - (match uu___4 with - | (target_comp, eff) -> - let uu___5 ctx = - let ctx1 = - { - no_guard = (ctx.no_guard); - unfolding_ok = (ctx.unfolding_ok); - error_context = - (("top-level subtyping", - FStar_Pervasives_Native.None) :: - (ctx.error_context)) - } in - let uu___6 = - let uu___7 = as_comp g1 x in - check_relation_comp - { - tcenv = (g1.tcenv); - allow_universe_instantiation = true; - max_binder_index = - (g1.max_binder_index); - guard_handler = (g1.guard_handler); - should_read_cache = - (g1.should_read_cache) - } - (SUBTYPING - (FStar_Pervasives_Native.Some e)) - uu___7 target_comp in - uu___6 ctx1 in - (fun ctx01 -> - let uu___6 = uu___5 ctx01 in - match uu___6 with - | Success (x1, g12) -> - let uu___7 = - let uu___8 uu___9 = - Success - ((eff, t), - FStar_Pervasives_Native.None) in - uu___8 ctx01 in - (match uu___7 with - | Success (y, g2) -> - let uu___8 = - let uu___9 = and_pre g12 g2 in - (y, uu___9) in - Success uu___8 - | err -> err) - | Error err -> Error err)) in - uu___3 ctx0 in - (match uu___2 with - | Success (y, g2) -> - let uu___3 = - let uu___4 = and_pre g11 g2 in (y, uu___4) in - Success uu___3 - | err -> err) - | Error err -> Error err -let (simplify_steps : FStar_TypeChecker_Env.step Prims.list) = - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.UnfoldQual ["unfold"]; - FStar_TypeChecker_Env.UnfoldOnly - [FStar_Parser_Const.pure_wp_monotonic_lid; - FStar_Parser_Const.pure_wp_monotonic0_lid]; - FStar_TypeChecker_Env.Simplify; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.NoFullNorm] -let (check_term_top_gh : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.typ FStar_Pervasives_Native.option -> - Prims.bool -> - guard_handler_t FStar_Pervasives_Native.option -> - ((tot_or_ghost * FStar_Syntax_Syntax.typ) * precondition) - __result) - = - fun g -> - fun e -> - fun topt -> - fun must_tot -> - fun gh -> - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_Eq in - if uu___1 - then - let uu___2 = - let uu___3 = get_goal_ctr () in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) uu___3 in - FStar_Compiler_Util.print1 "(%s) Entering core ... \n" uu___2 - else ()); - (let uu___2 = - (FStar_Compiler_Effect.op_Bang dbg) || - (FStar_Compiler_Effect.op_Bang dbg_Top) in - if uu___2 - then - let uu___3 = - let uu___4 = get_goal_ctr () in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) uu___4 in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - let uu___5 = - FStar_Class_Show.show - (FStar_Class_Show.show_option - FStar_Syntax_Print.showable_term) topt in - FStar_Compiler_Util.print3 - "(%s) Entering core with %s <: %s\n" uu___3 uu___4 uu___5 - else ()); - FStar_Syntax_TermHashTable.reset_counters table; - reset_cache_stats (); - (let ctx = - { - no_guard = false; - unfolding_ok = true; - error_context = [("Top", FStar_Pervasives_Native.None)] - } in - let res = - FStar_Profiling.profile - (fun uu___4 -> - let uu___5 = - let uu___6 = check_term_top g e topt must_tot gh in - uu___6 ctx in - match uu___5 with - | Success (et, g1) -> Success (et, g1) - | Error err -> Error err) FStar_Pervasives_Native.None - "FStar.TypeChecker.Core.check_term_top" in - let res1 = - match res with - | Success (et, FStar_Pervasives_Native.Some guard0) -> - let guard1 = - FStar_TypeChecker_Normalize.normalize simplify_steps g - guard0 in - ((let uu___5 = - ((FStar_Compiler_Effect.op_Bang dbg) || - (FStar_Compiler_Effect.op_Bang dbg_Top)) - || (FStar_Compiler_Effect.op_Bang dbg_Exit) in - if uu___5 - then - ((let uu___7 = - let uu___8 = get_goal_ctr () in - FStar_Compiler_Util.string_of_int uu___8 in - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term guard0 in - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term guard1 in - FStar_Compiler_Util.print3 - "(%s) Exiting core: Simplified guard from {{%s}} to {{%s}}\n" - uu___7 uu___8 uu___9); - (let guard_names = - let uu___7 = FStar_Syntax_Free.names guard1 in - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) - (Obj.magic uu___7) in - let uu___7 = - FStar_Compiler_List.tryFind - (fun bv -> - FStar_Compiler_List.for_all - (fun binding_env -> - match binding_env with - | FStar_Syntax_Syntax.Binding_var bv_env - -> - let uu___8 = - FStar_Syntax_Syntax.bv_eq bv_env - bv in - Prims.op_Negation uu___8 - | uu___8 -> true) - g.FStar_TypeChecker_Env.gamma) guard_names in - match uu___7 with - | FStar_Pervasives_Native.Some bv -> - let uu___8 = - let uu___9 = FStar_Syntax_Syntax.bv_to_name bv in - FStar_Class_Show.show - FStar_Syntax_Print.showable_term uu___9 in - FStar_Compiler_Util.print1 - "WARNING: %s is free in the core generated guard\n" - uu___8 - | uu___8 -> ())) - else ()); - Success (et, (FStar_Pervasives_Native.Some guard1))) - | Success uu___4 -> - ((let uu___6 = - (FStar_Compiler_Effect.op_Bang dbg) || - (FStar_Compiler_Effect.op_Bang dbg_Top) in - if uu___6 - then - let uu___7 = - let uu___8 = get_goal_ctr () in - FStar_Compiler_Util.string_of_int uu___8 in - FStar_Compiler_Util.print1 "(%s) Exiting core (ok)\n" - uu___7 - else ()); - res) - | Error uu___4 -> - ((let uu___6 = - (FStar_Compiler_Effect.op_Bang dbg) || - (FStar_Compiler_Effect.op_Bang dbg_Top) in - if uu___6 - then - let uu___7 = - let uu___8 = get_goal_ctr () in - FStar_Compiler_Util.string_of_int uu___8 in - FStar_Compiler_Util.print1 - "(%s) Exiting core (failed)\n" uu___7 - else ()); - res) in - (let uu___5 = FStar_Compiler_Effect.op_Bang dbg_Eq in - if uu___5 - then - (FStar_Syntax_TermHashTable.print_stats table; - (let cs = report_cache_stats () in - let uu___7 = FStar_Compiler_Util.string_of_int cs.hits in - let uu___8 = FStar_Compiler_Util.string_of_int cs.misses in - FStar_Compiler_Util.print2 - "Cache_stats { hits = %s; misses = %s }\n" uu___7 uu___8)) - else ()); - res1) -let (check_term : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.typ -> - Prims.bool -> - (FStar_Syntax_Syntax.typ FStar_Pervasives_Native.option, error) - FStar_Pervasives.either) - = - fun g -> - fun e -> - fun t -> - fun must_tot -> - let uu___ = - check_term_top_gh g e (FStar_Pervasives_Native.Some t) must_tot - FStar_Pervasives_Native.None in - match uu___ with - | Success (uu___1, g1) -> FStar_Pervasives.Inl g1 - | Error err -> FStar_Pervasives.Inr err -let (check_term_at_type : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.typ -> - ((tot_or_ghost * FStar_Syntax_Syntax.typ - FStar_Pervasives_Native.option), - error) FStar_Pervasives.either) - = - fun g -> - fun e -> - fun t -> - let must_tot = false in - let uu___ = - check_term_top_gh g e (FStar_Pervasives_Native.Some t) must_tot - FStar_Pervasives_Native.None in - match uu___ with - | Success ((eff, uu___1), g1) -> FStar_Pervasives.Inl (eff, g1) - | Error err -> FStar_Pervasives.Inr err -let (compute_term_type_handle_guards : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - (FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.typ -> Prims.bool) -> - ((tot_or_ghost * FStar_Syntax_Syntax.typ), error) - FStar_Pervasives.either) - = - fun g -> - fun e -> - fun gh -> - let e1 = FStar_Syntax_Compress.deep_compress true true e in - let must_tot = false in - let uu___ = - check_term_top_gh g e1 FStar_Pervasives_Native.None must_tot - (FStar_Pervasives_Native.Some gh) in - match uu___ with - | Success (r, FStar_Pervasives_Native.None) -> FStar_Pervasives.Inl r - | Success (uu___1, FStar_Pervasives_Native.Some uu___2) -> - failwith - "Impossible: All guards should have been handled already" - | Error err -> FStar_Pervasives.Inr err -let (open_binders_in_term : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.term -> - (FStar_TypeChecker_Env.env * FStar_Syntax_Syntax.binders * - FStar_Syntax_Syntax.term)) - = - fun env1 -> - fun bs -> - fun t -> - let g = initial_env env1 FStar_Pervasives_Native.None in - let uu___ = open_term_binders g bs t in - match uu___ with | (g', bs1, t1) -> ((g'.tcenv), bs1, t1) -let (open_binders_in_comp : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.comp -> - (FStar_TypeChecker_Env.env * FStar_Syntax_Syntax.binders * - FStar_Syntax_Syntax.comp)) - = - fun env1 -> - fun bs -> - fun c -> - let g = initial_env env1 FStar_Pervasives_Native.None in - let uu___ = open_comp_binders g bs c in - match uu___ with | (g', bs1, c1) -> ((g'.tcenv), bs1, c1) -let (check_term_equality : - Prims.bool -> - Prims.bool -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.typ -> - (FStar_Syntax_Syntax.typ FStar_Pervasives_Native.option, - error) FStar_Pervasives.either) - = - fun guard_ok -> - fun unfolding_ok1 -> - fun g -> - fun t0 -> - fun t1 -> - let g1 = initial_env g FStar_Pervasives_Native.None in - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_Top in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t0 in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - let uu___4 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) guard_ok in - let uu___5 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) unfolding_ok1 in - FStar_Compiler_Util.print4 - "Entering check_term_equality with %s and %s (guard_ok=%s; unfolding_ok=%s) {\n" - uu___2 uu___3 uu___4 uu___5 - else ()); - (let ctx = - { - no_guard = (Prims.op_Negation guard_ok); - unfolding_ok = unfolding_ok1; - error_context = [("Eq", FStar_Pervasives_Native.None)] - } in - let r = - let uu___1 = check_relation g1 EQUALITY t0 t1 in uu___1 ctx in - (let uu___2 = FStar_Compiler_Effect.op_Bang dbg_Top in - if uu___2 - then - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t0 in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - let uu___5 = - FStar_Class_Show.show - (showable_result - (FStar_Class_Show.show_tuple2 - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_unit) - (FStar_Class_Show.show_option - FStar_Syntax_Print.showable_term))) r in - FStar_Compiler_Util.print3 - "} Exiting check_term_equality (%s, %s). Result = %s.\n" - uu___3 uu___4 uu___5 - else ()); - (let r1 = - match r with - | Success (uu___2, g2) -> FStar_Pervasives.Inl g2 - | Error err -> FStar_Pervasives.Inr err in - r1)) -let (check_term_subtyping : - Prims.bool -> - Prims.bool -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.typ -> - (FStar_Syntax_Syntax.typ FStar_Pervasives_Native.option, - error) FStar_Pervasives.either) - = - fun guard_ok -> - fun unfolding_ok1 -> - fun g -> - fun t0 -> - fun t1 -> - let g1 = initial_env g FStar_Pervasives_Native.None in - let ctx = - { - no_guard = (Prims.op_Negation guard_ok); - unfolding_ok = unfolding_ok1; - error_context = [("Subtyping", FStar_Pervasives_Native.None)] - } in - let uu___ = - let uu___1 = - check_relation g1 (SUBTYPING FStar_Pervasives_Native.None) t0 - t1 in - uu___1 ctx in - match uu___ with - | Success (uu___1, g2) -> FStar_Pervasives.Inl g2 - | Error err -> FStar_Pervasives.Inr err \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_DMFF.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_DMFF.ml deleted file mode 100644 index f181f8b1a14..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_DMFF.ml +++ /dev/null @@ -1,5313 +0,0 @@ -open Prims -type env = - { - tcenv: FStar_TypeChecker_Env.env ; - subst: FStar_Syntax_Syntax.subst_elt Prims.list ; - tc_const: FStar_Const.sconst -> FStar_Syntax_Syntax.typ } -let (__proj__Mkenv__item__tcenv : env -> FStar_TypeChecker_Env.env) = - fun projectee -> - match projectee with | { tcenv; subst; tc_const;_} -> tcenv -let (__proj__Mkenv__item__subst : - env -> FStar_Syntax_Syntax.subst_elt Prims.list) = - fun projectee -> - match projectee with | { tcenv; subst; tc_const;_} -> subst -let (__proj__Mkenv__item__tc_const : - env -> FStar_Const.sconst -> FStar_Syntax_Syntax.typ) = - fun projectee -> - match projectee with | { tcenv; subst; tc_const;_} -> tc_const -let (dbg : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "ED" -let (d : Prims.string -> unit) = - fun s -> FStar_Compiler_Util.print1 "\027[01;36m%s\027[00m\n" s -let (mk_toplevel_definition : - FStar_TypeChecker_Env.env_t -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.sigelt * FStar_Syntax_Syntax.term)) - = - fun env1 -> - fun lident -> - fun def -> - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg in - if uu___1 - then - ((let uu___3 = FStar_Ident.string_of_lid lident in d uu___3); - (let uu___3 = - FStar_Class_Show.show FStar_Ident.showable_lident lident in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term def in - FStar_Compiler_Util.print2 - "Registering top-level definition: %s\n%s\n" uu___3 uu___4)) - else ()); - (let fv = - FStar_Syntax_Syntax.lid_and_dd_as_fv lident - FStar_Pervasives_Native.None in - let lbname = FStar_Pervasives.Inr fv in - let lb = - (false, - [FStar_Syntax_Util.mk_letbinding lbname [] - FStar_Syntax_Syntax.tun FStar_Parser_Const.effect_Tot_lid def - [] FStar_Compiler_Range_Type.dummyRange]) in - let sig_ctx = - FStar_Syntax_Syntax.mk_sigelt - (FStar_Syntax_Syntax.Sig_let - { - FStar_Syntax_Syntax.lbs1 = lb; - FStar_Syntax_Syntax.lids1 = [lident] - }) in - let uu___1 = - FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_fvar fv) - FStar_Compiler_Range_Type.dummyRange in - ({ - FStar_Syntax_Syntax.sigel = (sig_ctx.FStar_Syntax_Syntax.sigel); - FStar_Syntax_Syntax.sigrng = (sig_ctx.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - [FStar_Syntax_Syntax.Unfold_for_unification_and_vcgen]; - FStar_Syntax_Syntax.sigmeta = - (sig_ctx.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (sig_ctx.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (sig_ctx.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (sig_ctx.FStar_Syntax_Syntax.sigopts) - }, uu___1)) -let (empty : - FStar_TypeChecker_Env.env -> - (FStar_Const.sconst -> FStar_Syntax_Syntax.typ) -> env) - = fun env1 -> fun tc_const -> { tcenv = env1; subst = []; tc_const } -let (gen_wps_for_free : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.bv -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.eff_decl -> - (FStar_Syntax_Syntax.sigelts * FStar_Syntax_Syntax.eff_decl)) - = - fun env1 -> - fun binders -> - fun a -> - fun wp_a -> - fun ed -> - let wp_a1 = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.EraseUniverses] env1 wp_a in - let a1 = - let uu___ = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.EraseUniverses] env1 - a.FStar_Syntax_Syntax.sort in - { - FStar_Syntax_Syntax.ppname = (a.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = (a.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = uu___ - } in - let d1 s = FStar_Compiler_Util.print1 "\027[01;36m%s\027[00m\n" s in - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg in - if uu___1 - then - (d1 "Elaborating extra WP combinators"; - (let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - wp_a1 in - FStar_Compiler_Util.print1 "wp_a is: %s\n" uu___3)) - else ()); - (let rec collect_binders t = - let t1 = FStar_Syntax_Util.unascribe t in - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress t1 in - uu___2.FStar_Syntax_Syntax.n in - match uu___1 with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; - FStar_Syntax_Syntax.comp = comp;_} - -> - let rest = - match comp.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total t2 -> t2 - | uu___2 -> - let uu___3 = - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_comp comp in - FStar_Compiler_Util.format1 - "wp_a contains non-Tot arrow: %s" uu___4 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) comp - FStar_Errors_Codes.Error_UnexpectedDM4FType () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___3) in - let uu___2 = collect_binders rest in - FStar_Compiler_List.op_At bs uu___2 - | FStar_Syntax_Syntax.Tm_type uu___2 -> [] - | uu___2 -> - let uu___3 = - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - t1 in - FStar_Compiler_Util.format1 - "wp_a doesn't end in Type0, but rather in %s" uu___4 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) t1 - FStar_Errors_Codes.Error_UnexpectedDM4FType () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___3) in - let mk_lid name = FStar_Syntax_Util.dm4f_lid ed name in - let gamma = - let uu___1 = collect_binders wp_a1 in - FStar_Syntax_Util.name_binders uu___1 in - (let uu___2 = FStar_Compiler_Effect.op_Bang dbg in - if uu___2 - then - let uu___3 = - let uu___4 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binder) gamma in - FStar_Compiler_Util.format1 "Gamma is %s\n" uu___4 in - d1 uu___3 - else ()); - (let unknown = FStar_Syntax_Syntax.tun in - let mk x = - FStar_Syntax_Syntax.mk x FStar_Compiler_Range_Type.dummyRange in - let sigelts = FStar_Compiler_Util.mk_ref [] in - let register env2 lident def = - let uu___2 = mk_toplevel_definition env2 lident def in - match uu___2 with - | (sigelt, fv) -> - let sigelt1 = - { - FStar_Syntax_Syntax.sigel = - (sigelt.FStar_Syntax_Syntax.sigel); - FStar_Syntax_Syntax.sigrng = - (sigelt.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (sigelt.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (let uu___3 = sigelt.FStar_Syntax_Syntax.sigmeta in - { - FStar_Syntax_Syntax.sigmeta_active = - (uu___3.FStar_Syntax_Syntax.sigmeta_active); - FStar_Syntax_Syntax.sigmeta_fact_db_ids = - (uu___3.FStar_Syntax_Syntax.sigmeta_fact_db_ids); - FStar_Syntax_Syntax.sigmeta_admit = true; - FStar_Syntax_Syntax.sigmeta_spliced = - (uu___3.FStar_Syntax_Syntax.sigmeta_spliced); - FStar_Syntax_Syntax.sigmeta_already_checked = - (uu___3.FStar_Syntax_Syntax.sigmeta_already_checked); - FStar_Syntax_Syntax.sigmeta_extension_data = - (uu___3.FStar_Syntax_Syntax.sigmeta_extension_data) - }); - FStar_Syntax_Syntax.sigattrs = - (sigelt.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (sigelt.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (sigelt.FStar_Syntax_Syntax.sigopts) - } in - ((let uu___4 = - let uu___5 = FStar_Compiler_Effect.op_Bang sigelts in - sigelt1 :: uu___5 in - FStar_Compiler_Effect.op_Colon_Equals sigelts uu___4); - fv) in - let binders_of_list = - FStar_Compiler_List.map - (fun uu___2 -> - match uu___2 with - | (t, b) -> - let uu___3 = FStar_Syntax_Syntax.as_bqual_implicit b in - FStar_Syntax_Syntax.mk_binder_with_attrs t uu___3 - FStar_Pervasives_Native.None []) in - let mk_all_implicit = - FStar_Compiler_List.map - (fun t -> - let uu___2 = FStar_Syntax_Syntax.as_bqual_implicit true in - { - FStar_Syntax_Syntax.binder_bv = - (t.FStar_Syntax_Syntax.binder_bv); - FStar_Syntax_Syntax.binder_qual = uu___2; - FStar_Syntax_Syntax.binder_positivity = - (t.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs = - (t.FStar_Syntax_Syntax.binder_attrs) - }) in - let args_of_binders = - FStar_Compiler_List.map - (fun bv -> - let uu___2 = - FStar_Syntax_Syntax.bv_to_name - bv.FStar_Syntax_Syntax.binder_bv in - FStar_Syntax_Syntax.as_arg uu___2) in - let uu___2 = - let uu___3 = - let mk1 f = - let t = - FStar_Syntax_Syntax.gen_bv "t" - FStar_Pervasives_Native.None FStar_Syntax_Util.ktype in - let body = - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.bv_to_name t in - f uu___5 in - FStar_Syntax_Util.arrow gamma uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = FStar_Syntax_Syntax.mk_binder a1 in - let uu___7 = - let uu___8 = FStar_Syntax_Syntax.mk_binder t in - [uu___8] in - uu___6 :: uu___7 in - FStar_Compiler_List.op_At binders uu___5 in - FStar_Syntax_Util.abs uu___4 body - FStar_Pervasives_Native.None in - let uu___4 = mk1 FStar_Syntax_Syntax.mk_Total in - let uu___5 = mk1 FStar_Syntax_Syntax.mk_GTotal in - (uu___4, uu___5) in - match uu___3 with - | (ctx_def, gctx_def) -> - let ctx_lid = mk_lid "ctx" in - let ctx_fv = register env1 ctx_lid ctx_def in - let gctx_lid = mk_lid "gctx" in - let gctx_fv = register env1 gctx_lid gctx_def in - let mk_app fv t = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Compiler_List.map - (fun uu___8 -> - match uu___8 with - | { FStar_Syntax_Syntax.binder_bv = bv; - FStar_Syntax_Syntax.binder_qual = - uu___9; - FStar_Syntax_Syntax.binder_positivity - = uu___10; - FStar_Syntax_Syntax.binder_attrs = - uu___11;_} - -> - let uu___12 = - FStar_Syntax_Syntax.bv_to_name bv in - let uu___13 = - FStar_Syntax_Syntax.as_aqual_implicit - false in - (uu___12, uu___13)) binders in - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Syntax_Syntax.bv_to_name a1 in - let uu___11 = - FStar_Syntax_Syntax.as_aqual_implicit false in - (uu___10, uu___11) in - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Syntax_Syntax.as_aqual_implicit - false in - (t, uu___12) in - [uu___11] in - uu___9 :: uu___10 in - FStar_Compiler_List.op_At uu___7 uu___8 in - { - FStar_Syntax_Syntax.hd = fv; - FStar_Syntax_Syntax.args = uu___6 - } in - FStar_Syntax_Syntax.Tm_app uu___5 in - mk uu___4 in - (env1, (mk_app ctx_fv), (mk_app gctx_fv)) in - match uu___2 with - | (env2, mk_ctx, mk_gctx) -> - let c_pure = - let t = - FStar_Syntax_Syntax.gen_bv "t" - FStar_Pervasives_Native.None FStar_Syntax_Util.ktype in - let x = - let uu___3 = FStar_Syntax_Syntax.bv_to_name t in - FStar_Syntax_Syntax.gen_bv "x" - FStar_Pervasives_Native.None uu___3 in - let ret = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.bv_to_name t in - mk_ctx uu___5 in - FStar_Syntax_Util.residual_tot uu___4 in - FStar_Pervasives_Native.Some uu___3 in - let body = - let uu___3 = FStar_Syntax_Syntax.bv_to_name x in - FStar_Syntax_Util.abs gamma uu___3 ret in - let uu___3 = - let uu___4 = mk_all_implicit binders in - let uu___5 = - binders_of_list [(a1, true); (t, true); (x, false)] in - FStar_Compiler_List.op_At uu___4 uu___5 in - FStar_Syntax_Util.abs uu___3 body ret in - let c_pure1 = - let uu___3 = mk_lid "pure" in register env2 uu___3 c_pure in - let c_app = - let t1 = - FStar_Syntax_Syntax.gen_bv "t1" - FStar_Pervasives_Native.None FStar_Syntax_Util.ktype in - let t2 = - FStar_Syntax_Syntax.gen_bv "t2" - FStar_Pervasives_Native.None FStar_Syntax_Util.ktype in - let l = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Syntax_Syntax.bv_to_name t1 in - FStar_Syntax_Syntax.new_bv - FStar_Pervasives_Native.None uu___8 in - FStar_Syntax_Syntax.mk_binder uu___7 in - [uu___6] in - let uu___6 = - let uu___7 = FStar_Syntax_Syntax.bv_to_name t2 in - FStar_Syntax_Syntax.mk_GTotal uu___7 in - FStar_Syntax_Util.arrow uu___5 uu___6 in - mk_gctx uu___4 in - FStar_Syntax_Syntax.gen_bv "l" - FStar_Pervasives_Native.None uu___3 in - let r = - let uu___3 = - let uu___4 = FStar_Syntax_Syntax.bv_to_name t1 in - mk_gctx uu___4 in - FStar_Syntax_Syntax.gen_bv "r" - FStar_Pervasives_Native.None uu___3 in - let ret = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.bv_to_name t2 in - mk_gctx uu___5 in - FStar_Syntax_Util.residual_tot uu___4 in - FStar_Pervasives_Native.Some uu___3 in - let outer_body = - let gamma_as_args = args_of_binders gamma in - let inner_body = - let uu___3 = FStar_Syntax_Syntax.bv_to_name l in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = FStar_Syntax_Syntax.bv_to_name r in - FStar_Syntax_Util.mk_app uu___8 gamma_as_args in - FStar_Syntax_Syntax.as_arg uu___7 in - [uu___6] in - FStar_Compiler_List.op_At gamma_as_args uu___5 in - FStar_Syntax_Util.mk_app uu___3 uu___4 in - FStar_Syntax_Util.abs gamma inner_body ret in - let uu___3 = - let uu___4 = mk_all_implicit binders in - let uu___5 = - binders_of_list - [(a1, true); - (t1, true); - (t2, true); - (l, false); - (r, false)] in - FStar_Compiler_List.op_At uu___4 uu___5 in - FStar_Syntax_Util.abs uu___3 outer_body ret in - let c_app1 = - let uu___3 = mk_lid "app" in register env2 uu___3 c_app in - let c_lift1 = - let t1 = - FStar_Syntax_Syntax.gen_bv "t1" - FStar_Pervasives_Native.None FStar_Syntax_Util.ktype in - let t2 = - FStar_Syntax_Syntax.gen_bv "t2" - FStar_Pervasives_Native.None FStar_Syntax_Util.ktype in - let t_f = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.bv_to_name t1 in - FStar_Syntax_Syntax.null_binder uu___5 in - [uu___4] in - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.bv_to_name t2 in - FStar_Syntax_Syntax.mk_GTotal uu___5 in - FStar_Syntax_Util.arrow uu___3 uu___4 in - let f = - FStar_Syntax_Syntax.gen_bv "f" - FStar_Pervasives_Native.None t_f in - let a11 = - let uu___3 = - let uu___4 = FStar_Syntax_Syntax.bv_to_name t1 in - mk_gctx uu___4 in - FStar_Syntax_Syntax.gen_bv "a1" - FStar_Pervasives_Native.None uu___3 in - let ret = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.bv_to_name t2 in - mk_gctx uu___5 in - FStar_Syntax_Util.residual_tot uu___4 in - FStar_Pervasives_Native.Some uu___3 in - let uu___3 = - let uu___4 = mk_all_implicit binders in - let uu___5 = - binders_of_list - [(a1, true); - (t1, true); - (t2, true); - (f, false); - (a11, false)] in - FStar_Compiler_List.op_At uu___4 uu___5 in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Syntax_Syntax.bv_to_name f in - [uu___10] in - FStar_Compiler_List.map - FStar_Syntax_Syntax.as_arg uu___9 in - FStar_Syntax_Util.mk_app c_pure1 uu___8 in - let uu___8 = - let uu___9 = FStar_Syntax_Syntax.bv_to_name a11 in - [uu___9] in - uu___7 :: uu___8 in - FStar_Compiler_List.map FStar_Syntax_Syntax.as_arg - uu___6 in - FStar_Syntax_Util.mk_app c_app1 uu___5 in - FStar_Syntax_Util.abs uu___3 uu___4 ret in - let c_lift11 = - let uu___3 = mk_lid "lift1" in - register env2 uu___3 c_lift1 in - let c_lift2 = - let t1 = - FStar_Syntax_Syntax.gen_bv "t1" - FStar_Pervasives_Native.None FStar_Syntax_Util.ktype in - let t2 = - FStar_Syntax_Syntax.gen_bv "t2" - FStar_Pervasives_Native.None FStar_Syntax_Util.ktype in - let t3 = - FStar_Syntax_Syntax.gen_bv "t3" - FStar_Pervasives_Native.None FStar_Syntax_Util.ktype in - let t_f = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.bv_to_name t1 in - FStar_Syntax_Syntax.null_binder uu___5 in - let uu___5 = - let uu___6 = - let uu___7 = FStar_Syntax_Syntax.bv_to_name t2 in - FStar_Syntax_Syntax.null_binder uu___7 in - [uu___6] in - uu___4 :: uu___5 in - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.bv_to_name t3 in - FStar_Syntax_Syntax.mk_GTotal uu___5 in - FStar_Syntax_Util.arrow uu___3 uu___4 in - let f = - FStar_Syntax_Syntax.gen_bv "f" - FStar_Pervasives_Native.None t_f in - let a11 = - let uu___3 = - let uu___4 = FStar_Syntax_Syntax.bv_to_name t1 in - mk_gctx uu___4 in - FStar_Syntax_Syntax.gen_bv "a1" - FStar_Pervasives_Native.None uu___3 in - let a2 = - let uu___3 = - let uu___4 = FStar_Syntax_Syntax.bv_to_name t2 in - mk_gctx uu___4 in - FStar_Syntax_Syntax.gen_bv "a2" - FStar_Pervasives_Native.None uu___3 in - let ret = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.bv_to_name t3 in - mk_gctx uu___5 in - FStar_Syntax_Util.residual_tot uu___4 in - FStar_Pervasives_Native.Some uu___3 in - let uu___3 = - let uu___4 = mk_all_implicit binders in - let uu___5 = - binders_of_list - [(a1, true); - (t1, true); - (t2, true); - (t3, true); - (f, false); - (a11, false); - (a2, false)] in - FStar_Compiler_List.op_At uu___4 uu___5 in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Syntax_Syntax.bv_to_name f in - [uu___13] in - FStar_Compiler_List.map - FStar_Syntax_Syntax.as_arg uu___12 in - FStar_Syntax_Util.mk_app c_pure1 uu___11 in - let uu___11 = - let uu___12 = - FStar_Syntax_Syntax.bv_to_name a11 in - [uu___12] in - uu___10 :: uu___11 in - FStar_Compiler_List.map - FStar_Syntax_Syntax.as_arg uu___9 in - FStar_Syntax_Util.mk_app c_app1 uu___8 in - let uu___8 = - let uu___9 = FStar_Syntax_Syntax.bv_to_name a2 in - [uu___9] in - uu___7 :: uu___8 in - FStar_Compiler_List.map FStar_Syntax_Syntax.as_arg - uu___6 in - FStar_Syntax_Util.mk_app c_app1 uu___5 in - FStar_Syntax_Util.abs uu___3 uu___4 ret in - let c_lift21 = - let uu___3 = mk_lid "lift2" in - register env2 uu___3 c_lift2 in - let c_push = - let t1 = - FStar_Syntax_Syntax.gen_bv "t1" - FStar_Pervasives_Native.None FStar_Syntax_Util.ktype in - let t2 = - FStar_Syntax_Syntax.gen_bv "t2" - FStar_Pervasives_Native.None FStar_Syntax_Util.ktype in - let t_f = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.bv_to_name t1 in - FStar_Syntax_Syntax.null_binder uu___5 in - [uu___4] in - let uu___4 = - let uu___5 = - let uu___6 = FStar_Syntax_Syntax.bv_to_name t2 in - mk_gctx uu___6 in - FStar_Syntax_Syntax.mk_Total uu___5 in - FStar_Syntax_Util.arrow uu___3 uu___4 in - let f = - FStar_Syntax_Syntax.gen_bv "f" - FStar_Pervasives_Native.None t_f in - let ret = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Syntax_Syntax.bv_to_name t1 in - FStar_Syntax_Syntax.null_binder uu___8 in - [uu___7] in - let uu___7 = - let uu___8 = FStar_Syntax_Syntax.bv_to_name t2 in - FStar_Syntax_Syntax.mk_GTotal uu___8 in - FStar_Syntax_Util.arrow uu___6 uu___7 in - mk_ctx uu___5 in - FStar_Syntax_Util.residual_tot uu___4 in - FStar_Pervasives_Native.Some uu___3 in - let e1 = - let uu___3 = FStar_Syntax_Syntax.bv_to_name t1 in - FStar_Syntax_Syntax.gen_bv "e1" - FStar_Pervasives_Native.None uu___3 in - let body = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.mk_binder e1 in - [uu___5] in - FStar_Compiler_List.op_At gamma uu___4 in - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.bv_to_name f in - let uu___6 = - let uu___7 = - let uu___8 = FStar_Syntax_Syntax.bv_to_name e1 in - FStar_Syntax_Syntax.as_arg uu___8 in - let uu___8 = args_of_binders gamma in uu___7 :: - uu___8 in - FStar_Syntax_Util.mk_app uu___5 uu___6 in - FStar_Syntax_Util.abs uu___3 uu___4 ret in - let uu___3 = - let uu___4 = mk_all_implicit binders in - let uu___5 = - binders_of_list - [(a1, true); (t1, true); (t2, true); (f, false)] in - FStar_Compiler_List.op_At uu___4 uu___5 in - FStar_Syntax_Util.abs uu___3 body ret in - let c_push1 = - let uu___3 = mk_lid "push" in register env2 uu___3 c_push in - let ret_tot_wp_a = - FStar_Pervasives_Native.Some - (FStar_Syntax_Util.residual_tot wp_a1) in - let mk_generic_app c = - if (FStar_Compiler_List.length binders) > Prims.int_zero - then - let uu___3 = - let uu___4 = - let uu___5 = args_of_binders binders in - { - FStar_Syntax_Syntax.hd = c; - FStar_Syntax_Syntax.args = uu___5 - } in - FStar_Syntax_Syntax.Tm_app uu___4 in - mk uu___3 - else c in - let wp_if_then_else = - let result_comp = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.null_binder wp_a1 in - let uu___6 = - let uu___7 = - FStar_Syntax_Syntax.null_binder wp_a1 in - [uu___7] in - uu___5 :: uu___6 in - let uu___5 = FStar_Syntax_Syntax.mk_Total wp_a1 in - FStar_Syntax_Util.arrow uu___4 uu___5 in - FStar_Syntax_Syntax.mk_Total uu___3 in - let c = - FStar_Syntax_Syntax.gen_bv "c" - FStar_Pervasives_Native.None FStar_Syntax_Util.ktype in - let uu___3 = - let uu___4 = - FStar_Syntax_Syntax.binders_of_list [a1; c] in - FStar_Compiler_List.op_At binders uu___4 in - let uu___4 = - let l_ite = - FStar_Syntax_Syntax.fvar_with_dd - FStar_Parser_Const.ite_lid - FStar_Pervasives_Native.None in - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Syntax_Syntax.bv_to_name c in - FStar_Syntax_Syntax.as_arg uu___11 in - [uu___10] in - FStar_Syntax_Util.mk_app l_ite uu___9 in - [uu___8] in - FStar_Compiler_List.map FStar_Syntax_Syntax.as_arg - uu___7 in - FStar_Syntax_Util.mk_app c_lift21 uu___6 in - FStar_Syntax_Util.ascribe uu___5 - ((FStar_Pervasives.Inr result_comp), - FStar_Pervasives_Native.None, false) in - let uu___5 = - let uu___6 = - FStar_Syntax_Util.residual_comp_of_comp result_comp in - FStar_Pervasives_Native.Some uu___6 in - FStar_Syntax_Util.abs uu___3 uu___4 uu___5 in - let wp_if_then_else1 = - let uu___3 = mk_lid "wp_if_then_else" in - register env2 uu___3 wp_if_then_else in - let wp_if_then_else2 = mk_generic_app wp_if_then_else1 in - let wp_close = - let b = - FStar_Syntax_Syntax.gen_bv "b" - FStar_Pervasives_Native.None FStar_Syntax_Util.ktype in - let t_f = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.bv_to_name b in - FStar_Syntax_Syntax.null_binder uu___5 in - [uu___4] in - let uu___4 = FStar_Syntax_Syntax.mk_Total wp_a1 in - FStar_Syntax_Util.arrow uu___3 uu___4 in - let f = - FStar_Syntax_Syntax.gen_bv "f" - FStar_Pervasives_Native.None t_f in - let body = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Compiler_List.map - FStar_Syntax_Syntax.as_arg - [FStar_Syntax_Util.tforall] in - FStar_Syntax_Util.mk_app c_pure1 uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Syntax_Syntax.bv_to_name f in - [uu___10] in - FStar_Compiler_List.map - FStar_Syntax_Syntax.as_arg uu___9 in - FStar_Syntax_Util.mk_app c_push1 uu___8 in - [uu___7] in - uu___5 :: uu___6 in - FStar_Compiler_List.map FStar_Syntax_Syntax.as_arg - uu___4 in - FStar_Syntax_Util.mk_app c_app1 uu___3 in - let uu___3 = - let uu___4 = - FStar_Syntax_Syntax.binders_of_list [a1; b; f] in - FStar_Compiler_List.op_At binders uu___4 in - FStar_Syntax_Util.abs uu___3 body ret_tot_wp_a in - let wp_close1 = - let uu___3 = mk_lid "wp_close" in - register env2 uu___3 wp_close in - let wp_close2 = mk_generic_app wp_close1 in - let ret_tot_type = - FStar_Pervasives_Native.Some - (FStar_Syntax_Util.residual_tot FStar_Syntax_Util.ktype) in - let ret_gtot_type = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Syntax_Syntax.mk_GTotal - FStar_Syntax_Util.ktype in - FStar_TypeChecker_Common.lcomp_of_comp uu___5 in - FStar_TypeChecker_Common.residual_comp_of_lcomp uu___4 in - FStar_Pervasives_Native.Some uu___3 in - let mk_forall x body = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = FStar_Syntax_Syntax.mk_binder x in - [uu___9] in - FStar_Syntax_Util.abs uu___8 body ret_tot_type in - FStar_Syntax_Syntax.as_arg uu___7 in - [uu___6] in - { - FStar_Syntax_Syntax.hd = FStar_Syntax_Util.tforall; - FStar_Syntax_Syntax.args = uu___5 - } in - FStar_Syntax_Syntax.Tm_app uu___4 in - FStar_Syntax_Syntax.mk uu___3 - FStar_Compiler_Range_Type.dummyRange in - let rec is_discrete t = - let uu___3 = - let uu___4 = FStar_Syntax_Subst.compress t in - uu___4.FStar_Syntax_Syntax.n in - match uu___3 with - | FStar_Syntax_Syntax.Tm_type uu___4 -> false - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; - FStar_Syntax_Syntax.comp = c;_} - -> - (FStar_Compiler_List.for_all - (fun uu___4 -> - match uu___4 with - | { FStar_Syntax_Syntax.binder_bv = b; - FStar_Syntax_Syntax.binder_qual = uu___5; - FStar_Syntax_Syntax.binder_positivity = - uu___6; - FStar_Syntax_Syntax.binder_attrs = uu___7;_} - -> is_discrete b.FStar_Syntax_Syntax.sort) - bs) - && (is_discrete (FStar_Syntax_Util.comp_result c)) - | uu___4 -> true in - let rec is_monotonic t = - let uu___3 = - let uu___4 = FStar_Syntax_Subst.compress t in - uu___4.FStar_Syntax_Syntax.n in - match uu___3 with - | FStar_Syntax_Syntax.Tm_type uu___4 -> true - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; - FStar_Syntax_Syntax.comp = c;_} - -> - (FStar_Compiler_List.for_all - (fun uu___4 -> - match uu___4 with - | { FStar_Syntax_Syntax.binder_bv = b; - FStar_Syntax_Syntax.binder_qual = uu___5; - FStar_Syntax_Syntax.binder_positivity = - uu___6; - FStar_Syntax_Syntax.binder_attrs = uu___7;_} - -> is_discrete b.FStar_Syntax_Syntax.sort) - bs) - && (is_monotonic (FStar_Syntax_Util.comp_result c)) - | uu___4 -> is_discrete t in - let rec mk_rel rel t x y = - let mk_rel1 = mk_rel rel in - let t1 = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.DontUnfoldAttr - [FStar_Parser_Const.tac_opaque_attr]; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant] env2 t in - let uu___3 = - let uu___4 = FStar_Syntax_Subst.compress t1 in - uu___4.FStar_Syntax_Syntax.n in - match uu___3 with - | FStar_Syntax_Syntax.Tm_type uu___4 -> rel x y - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = binder::[]; - FStar_Syntax_Syntax.comp = - { - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.GTotal b; - FStar_Syntax_Syntax.pos = uu___4; - FStar_Syntax_Syntax.vars = uu___5; - FStar_Syntax_Syntax.hash_code = uu___6;_};_} - -> - let a2 = - (binder.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - let uu___7 = (is_monotonic a2) || (is_monotonic b) in - if uu___7 - then - let a11 = - FStar_Syntax_Syntax.gen_bv "a1" - FStar_Pervasives_Native.None a2 in - let body = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Syntax_Syntax.bv_to_name a11 in - FStar_Syntax_Syntax.as_arg uu___11 in - [uu___10] in - FStar_Syntax_Util.mk_app x uu___9 in - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Syntax_Syntax.bv_to_name a11 in - FStar_Syntax_Syntax.as_arg uu___12 in - [uu___11] in - FStar_Syntax_Util.mk_app y uu___10 in - mk_rel1 b uu___8 uu___9 in - mk_forall a11 body - else - (let a11 = - FStar_Syntax_Syntax.gen_bv "a1" - FStar_Pervasives_Native.None a2 in - let a21 = - FStar_Syntax_Syntax.gen_bv "a2" - FStar_Pervasives_Native.None a2 in - let body = - let uu___9 = - let uu___10 = - FStar_Syntax_Syntax.bv_to_name a11 in - let uu___11 = - FStar_Syntax_Syntax.bv_to_name a21 in - mk_rel1 a2 uu___10 uu___11 in - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - FStar_Syntax_Syntax.bv_to_name a11 in - FStar_Syntax_Syntax.as_arg uu___14 in - [uu___13] in - FStar_Syntax_Util.mk_app x uu___12 in - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - FStar_Syntax_Syntax.bv_to_name a21 in - FStar_Syntax_Syntax.as_arg uu___15 in - [uu___14] in - FStar_Syntax_Util.mk_app y uu___13 in - mk_rel1 b uu___11 uu___12 in - FStar_Syntax_Util.mk_imp uu___9 uu___10 in - let uu___9 = mk_forall a21 body in - mk_forall a11 uu___9) - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = binder::[]; - FStar_Syntax_Syntax.comp = - { - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Total b; - FStar_Syntax_Syntax.pos = uu___4; - FStar_Syntax_Syntax.vars = uu___5; - FStar_Syntax_Syntax.hash_code = uu___6;_};_} - -> - let a2 = - (binder.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - let uu___7 = (is_monotonic a2) || (is_monotonic b) in - if uu___7 - then - let a11 = - FStar_Syntax_Syntax.gen_bv "a1" - FStar_Pervasives_Native.None a2 in - let body = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Syntax_Syntax.bv_to_name a11 in - FStar_Syntax_Syntax.as_arg uu___11 in - [uu___10] in - FStar_Syntax_Util.mk_app x uu___9 in - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Syntax_Syntax.bv_to_name a11 in - FStar_Syntax_Syntax.as_arg uu___12 in - [uu___11] in - FStar_Syntax_Util.mk_app y uu___10 in - mk_rel1 b uu___8 uu___9 in - mk_forall a11 body - else - (let a11 = - FStar_Syntax_Syntax.gen_bv "a1" - FStar_Pervasives_Native.None a2 in - let a21 = - FStar_Syntax_Syntax.gen_bv "a2" - FStar_Pervasives_Native.None a2 in - let body = - let uu___9 = - let uu___10 = - FStar_Syntax_Syntax.bv_to_name a11 in - let uu___11 = - FStar_Syntax_Syntax.bv_to_name a21 in - mk_rel1 a2 uu___10 uu___11 in - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - FStar_Syntax_Syntax.bv_to_name a11 in - FStar_Syntax_Syntax.as_arg uu___14 in - [uu___13] in - FStar_Syntax_Util.mk_app x uu___12 in - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - FStar_Syntax_Syntax.bv_to_name a21 in - FStar_Syntax_Syntax.as_arg uu___15 in - [uu___14] in - FStar_Syntax_Util.mk_app y uu___13 in - mk_rel1 b uu___11 uu___12 in - FStar_Syntax_Util.mk_imp uu___9 uu___10 in - let uu___9 = mk_forall a21 body in - mk_forall a11 uu___9) - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = binder::binders1; - FStar_Syntax_Syntax.comp = comp;_} - -> - let t2 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Syntax_Util.arrow binders1 comp in - FStar_Syntax_Syntax.mk_Total uu___7 in - { - FStar_Syntax_Syntax.bs1 = [binder]; - FStar_Syntax_Syntax.comp = uu___6 - } in - FStar_Syntax_Syntax.Tm_arrow uu___5 in - { - FStar_Syntax_Syntax.n = uu___4; - FStar_Syntax_Syntax.pos = - (t1.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = - (t1.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (t1.FStar_Syntax_Syntax.hash_code) - } in - mk_rel1 t2 x y - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = []; - FStar_Syntax_Syntax.comp = uu___4;_} - -> failwith "impossible: arrow with empty binders" - | uu___4 -> FStar_Syntax_Util.mk_untyped_eq2 x y in - let stronger = - let wp1 = - FStar_Syntax_Syntax.gen_bv "wp1" - FStar_Pervasives_Native.None wp_a1 in - let wp2 = - FStar_Syntax_Syntax.gen_bv "wp2" - FStar_Pervasives_Native.None wp_a1 in - let rec mk_stronger t x y = - let t1 = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.DontUnfoldAttr - [FStar_Parser_Const.tac_opaque_attr]; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant] env2 t in - let uu___3 = - let uu___4 = FStar_Syntax_Subst.compress t1 in - uu___4.FStar_Syntax_Syntax.n in - match uu___3 with - | FStar_Syntax_Syntax.Tm_type uu___4 -> - FStar_Syntax_Util.mk_imp x y - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = args;_} - when - let uu___4 = FStar_Syntax_Subst.compress head in - FStar_Syntax_Util.is_tuple_constructor uu___4 -> - let project i tuple = - let projector = - let uu___4 = - let uu___5 = - FStar_Parser_Const.mk_tuple_data_lid - (FStar_Compiler_List.length args) - FStar_Compiler_Range_Type.dummyRange in - FStar_TypeChecker_Env.lookup_projector env2 - uu___5 i in - FStar_Syntax_Syntax.fvar_with_dd uu___4 - FStar_Pervasives_Native.None in - FStar_Syntax_Util.mk_app projector - [(tuple, FStar_Pervasives_Native.None)] in - let uu___4 = - let uu___5 = - FStar_Compiler_List.mapi - (fun i -> - fun uu___6 -> - match uu___6 with - | (t2, q) -> - let uu___7 = project i x in - let uu___8 = project i y in - mk_stronger t2 uu___7 uu___8) args in - match uu___5 with - | [] -> - failwith - "Impossible: empty application when creating stronger relation in DM4F" - | rel0::rels -> (rel0, rels) in - (match uu___4 with - | (rel0, rels) -> - FStar_Compiler_List.fold_left - FStar_Syntax_Util.mk_conj rel0 rels) - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = binders1; - FStar_Syntax_Syntax.comp = - { - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.GTotal b; - FStar_Syntax_Syntax.pos = uu___4; - FStar_Syntax_Syntax.vars = uu___5; - FStar_Syntax_Syntax.hash_code = uu___6;_};_} - -> - let bvs = - FStar_Compiler_List.mapi - (fun i -> - fun uu___7 -> - match uu___7 with - | { FStar_Syntax_Syntax.binder_bv = bv; - FStar_Syntax_Syntax.binder_qual = q; - FStar_Syntax_Syntax.binder_positivity - = uu___8; - FStar_Syntax_Syntax.binder_attrs = - uu___9;_} - -> - let uu___10 = - let uu___11 = - FStar_Compiler_Util.string_of_int - i in - Prims.strcat "a" uu___11 in - FStar_Syntax_Syntax.gen_bv uu___10 - FStar_Pervasives_Native.None - bv.FStar_Syntax_Syntax.sort) - binders1 in - let args = - FStar_Compiler_List.map - (fun ai -> - let uu___7 = - FStar_Syntax_Syntax.bv_to_name ai in - FStar_Syntax_Syntax.as_arg uu___7) bvs in - let body = - let uu___7 = FStar_Syntax_Util.mk_app x args in - let uu___8 = FStar_Syntax_Util.mk_app y args in - mk_stronger b uu___7 uu___8 in - FStar_Compiler_List.fold_right - (fun bv -> fun body1 -> mk_forall bv body1) bvs - body - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = binders1; - FStar_Syntax_Syntax.comp = - { - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Total b; - FStar_Syntax_Syntax.pos = uu___4; - FStar_Syntax_Syntax.vars = uu___5; - FStar_Syntax_Syntax.hash_code = uu___6;_};_} - -> - let bvs = - FStar_Compiler_List.mapi - (fun i -> - fun uu___7 -> - match uu___7 with - | { FStar_Syntax_Syntax.binder_bv = bv; - FStar_Syntax_Syntax.binder_qual = q; - FStar_Syntax_Syntax.binder_positivity - = uu___8; - FStar_Syntax_Syntax.binder_attrs = - uu___9;_} - -> - let uu___10 = - let uu___11 = - FStar_Compiler_Util.string_of_int - i in - Prims.strcat "a" uu___11 in - FStar_Syntax_Syntax.gen_bv uu___10 - FStar_Pervasives_Native.None - bv.FStar_Syntax_Syntax.sort) - binders1 in - let args = - FStar_Compiler_List.map - (fun ai -> - let uu___7 = - FStar_Syntax_Syntax.bv_to_name ai in - FStar_Syntax_Syntax.as_arg uu___7) bvs in - let body = - let uu___7 = FStar_Syntax_Util.mk_app x args in - let uu___8 = FStar_Syntax_Util.mk_app y args in - mk_stronger b uu___7 uu___8 in - FStar_Compiler_List.fold_right - (fun bv -> fun body1 -> mk_forall bv body1) bvs - body - | uu___4 -> failwith "Not a DM elaborated type" in - let body = - let uu___3 = FStar_Syntax_Util.unascribe wp_a1 in - let uu___4 = FStar_Syntax_Syntax.bv_to_name wp1 in - let uu___5 = FStar_Syntax_Syntax.bv_to_name wp2 in - mk_stronger uu___3 uu___4 uu___5 in - let uu___3 = - let uu___4 = - binders_of_list - [(a1, false); (wp1, false); (wp2, false)] in - FStar_Compiler_List.op_At binders uu___4 in - FStar_Syntax_Util.abs uu___3 body ret_tot_type in - let stronger1 = - let uu___3 = mk_lid "stronger" in - register env2 uu___3 stronger in - let stronger2 = mk_generic_app stronger1 in - let ite_wp = - let wp = - FStar_Syntax_Syntax.gen_bv "wp" - FStar_Pervasives_Native.None wp_a1 in - let uu___3 = FStar_Compiler_Util.prefix gamma in - match uu___3 with - | (wp_args, post) -> - let k = - FStar_Syntax_Syntax.gen_bv "k" - FStar_Pervasives_Native.None - (post.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - let equiv = - let k_tm = FStar_Syntax_Syntax.bv_to_name k in - let eq = - let uu___4 = - FStar_Syntax_Syntax.bv_to_name - post.FStar_Syntax_Syntax.binder_bv in - mk_rel FStar_Syntax_Util.mk_iff - k.FStar_Syntax_Syntax.sort k_tm uu___4 in - let uu___4 = - FStar_Syntax_Formula.destruct_typ_as_formula eq in - match uu___4 with - | FStar_Pervasives_Native.Some - (FStar_Syntax_Formula.QAll - (binders1, [], body)) -> - let k_app = - let uu___5 = args_of_binders binders1 in - FStar_Syntax_Util.mk_app k_tm uu___5 in - let guard_free = - let uu___5 = - FStar_Syntax_Syntax.lid_and_dd_as_fv - FStar_Parser_Const.guard_free - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___5 in - let pat = - let uu___5 = - let uu___6 = - FStar_Syntax_Syntax.as_arg k_app in - [uu___6] in - FStar_Syntax_Util.mk_app guard_free uu___5 in - let pattern_guarded_body = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Syntax_Syntax.binders_to_names - binders1 in - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Syntax_Syntax.as_arg pat in - [uu___12] in - [uu___11] in - (uu___9, uu___10) in - FStar_Syntax_Syntax.Meta_pattern uu___8 in - { - FStar_Syntax_Syntax.tm2 = body; - FStar_Syntax_Syntax.meta = uu___7 - } in - FStar_Syntax_Syntax.Tm_meta uu___6 in - mk uu___5 in - FStar_Syntax_Util.close_forall_no_univs - binders1 pattern_guarded_body - | uu___5 -> - failwith - "Impossible: Expected the equivalence to be a quantified formula" in - let body = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Syntax_Syntax.bv_to_name wp in - let uu___8 = - let uu___9 = args_of_binders wp_args in - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Syntax_Syntax.bv_to_name k in - FStar_Syntax_Syntax.as_arg uu___12 in - [uu___11] in - FStar_Compiler_List.op_At uu___9 uu___10 in - FStar_Syntax_Util.mk_app uu___7 uu___8 in - FStar_Syntax_Util.mk_imp equiv uu___6 in - FStar_Syntax_Util.mk_forall_no_univ k uu___5 in - FStar_Syntax_Util.abs gamma uu___4 ret_gtot_type in - let uu___4 = - let uu___5 = - FStar_Syntax_Syntax.binders_of_list [a1; wp] in - FStar_Compiler_List.op_At binders uu___5 in - FStar_Syntax_Util.abs uu___4 body ret_gtot_type in - let ite_wp1 = - let uu___3 = mk_lid "ite_wp" in - register env2 uu___3 ite_wp in - let ite_wp2 = mk_generic_app ite_wp1 in - let null_wp = - let wp = - FStar_Syntax_Syntax.gen_bv "wp" - FStar_Pervasives_Native.None wp_a1 in - let uu___3 = FStar_Compiler_Util.prefix gamma in - match uu___3 with - | (wp_args, post) -> - let x = - FStar_Syntax_Syntax.gen_bv "x" - FStar_Pervasives_Native.None - FStar_Syntax_Syntax.tun in - let body = - let uu___4 = - let uu___5 = - FStar_Syntax_Syntax.bv_to_name - post.FStar_Syntax_Syntax.binder_bv in - let uu___6 = - let uu___7 = - let uu___8 = FStar_Syntax_Syntax.bv_to_name x in - FStar_Syntax_Syntax.as_arg uu___8 in - [uu___7] in - FStar_Syntax_Util.mk_app uu___5 uu___6 in - FStar_Syntax_Util.mk_forall_no_univ x uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Syntax.binders_of_list [a1] in - FStar_Compiler_List.op_At uu___6 gamma in - FStar_Compiler_List.op_At binders uu___5 in - FStar_Syntax_Util.abs uu___4 body ret_gtot_type in - let null_wp1 = - let uu___3 = mk_lid "null_wp" in - register env2 uu___3 null_wp in - let null_wp2 = mk_generic_app null_wp1 in - let wp_trivial = - let wp = - FStar_Syntax_Syntax.gen_bv "wp" - FStar_Pervasives_Native.None wp_a1 in - let body = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.bv_to_name a1 in - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Syntax_Syntax.bv_to_name a1 in - FStar_Syntax_Syntax.as_arg uu___10 in - [uu___9] in - FStar_Syntax_Util.mk_app null_wp2 uu___8 in - let uu___8 = - let uu___9 = FStar_Syntax_Syntax.bv_to_name wp in - [uu___9] in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - FStar_Compiler_List.map FStar_Syntax_Syntax.as_arg - uu___4 in - FStar_Syntax_Util.mk_app stronger2 uu___3 in - let uu___3 = - let uu___4 = - FStar_Syntax_Syntax.binders_of_list [a1; wp] in - FStar_Compiler_List.op_At binders uu___4 in - FStar_Syntax_Util.abs uu___3 body ret_tot_type in - let wp_trivial1 = - let uu___3 = mk_lid "wp_trivial" in - register env2 uu___3 wp_trivial in - let wp_trivial2 = mk_generic_app wp_trivial1 in - ((let uu___4 = FStar_Compiler_Effect.op_Bang dbg in - if uu___4 then d1 "End Dijkstra monads for free" else ()); - (let c = FStar_Syntax_Subst.close binders in - let ed_combs = - match ed.FStar_Syntax_Syntax.combinators with - | FStar_Syntax_Syntax.DM4F_eff combs -> - let uu___4 = - let uu___5 = - let uu___6 = c stronger2 in ([], uu___6) in - let uu___6 = - let uu___7 = c wp_if_then_else2 in ([], uu___7) in - let uu___7 = - let uu___8 = c ite_wp2 in ([], uu___8) in - let uu___8 = - let uu___9 = c wp_close2 in ([], uu___9) in - let uu___9 = - let uu___10 = c wp_trivial2 in ([], uu___10) in - { - FStar_Syntax_Syntax.ret_wp = - (combs.FStar_Syntax_Syntax.ret_wp); - FStar_Syntax_Syntax.bind_wp = - (combs.FStar_Syntax_Syntax.bind_wp); - FStar_Syntax_Syntax.stronger = uu___5; - FStar_Syntax_Syntax.if_then_else = uu___6; - FStar_Syntax_Syntax.ite_wp = uu___7; - FStar_Syntax_Syntax.close_wp = uu___8; - FStar_Syntax_Syntax.trivial = uu___9; - FStar_Syntax_Syntax.repr = - (combs.FStar_Syntax_Syntax.repr); - FStar_Syntax_Syntax.return_repr = - (combs.FStar_Syntax_Syntax.return_repr); - FStar_Syntax_Syntax.bind_repr = - (combs.FStar_Syntax_Syntax.bind_repr) - } in - FStar_Syntax_Syntax.DM4F_eff uu___4 - | uu___4 -> - failwith - "Impossible! For a DM4F effect combinators must be in DM4f_eff" in - let uu___4 = - let uu___5 = FStar_Compiler_Effect.op_Bang sigelts in - FStar_Compiler_List.rev uu___5 in - (uu___4, - { - FStar_Syntax_Syntax.mname = - (ed.FStar_Syntax_Syntax.mname); - FStar_Syntax_Syntax.cattributes = - (ed.FStar_Syntax_Syntax.cattributes); - FStar_Syntax_Syntax.univs = - (ed.FStar_Syntax_Syntax.univs); - FStar_Syntax_Syntax.binders = - (ed.FStar_Syntax_Syntax.binders); - FStar_Syntax_Syntax.signature = - (ed.FStar_Syntax_Syntax.signature); - FStar_Syntax_Syntax.combinators = ed_combs; - FStar_Syntax_Syntax.actions = - (ed.FStar_Syntax_Syntax.actions); - FStar_Syntax_Syntax.eff_attrs = - (ed.FStar_Syntax_Syntax.eff_attrs); - FStar_Syntax_Syntax.extraction_mode = - (ed.FStar_Syntax_Syntax.extraction_mode) - }))))) -type env_ = env -let (get_env : env -> FStar_TypeChecker_Env.env) = fun env1 -> env1.tcenv -let (set_env : env -> FStar_TypeChecker_Env.env -> env) = - fun dmff_env -> - fun env' -> - { - tcenv = env'; - subst = (dmff_env.subst); - tc_const = (dmff_env.tc_const) - } -type nm = - | N of FStar_Syntax_Syntax.typ - | M of FStar_Syntax_Syntax.typ -let (uu___is_N : nm -> Prims.bool) = - fun projectee -> match projectee with | N _0 -> true | uu___ -> false -let (__proj__N__item___0 : nm -> FStar_Syntax_Syntax.typ) = - fun projectee -> match projectee with | N _0 -> _0 -let (uu___is_M : nm -> Prims.bool) = - fun projectee -> match projectee with | M _0 -> true | uu___ -> false -let (__proj__M__item___0 : nm -> FStar_Syntax_Syntax.typ) = - fun projectee -> match projectee with | M _0 -> _0 -type nm_ = nm -let (nm_of_comp : FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> nm) - = - fun c -> - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total t -> N t - | FStar_Syntax_Syntax.Comp c1 when - FStar_Compiler_Util.for_some - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.CPS -> true - | uu___1 -> false) c1.FStar_Syntax_Syntax.flags - -> M (c1.FStar_Syntax_Syntax.result_typ) - | uu___ -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_comp c in - FStar_Compiler_Util.format1 - "[nm_of_comp]: unexpected computation type %s" uu___2 in - FStar_Errors.raise_error (FStar_Syntax_Syntax.has_range_syntax ()) c - FStar_Errors_Codes.Error_UnexpectedDM4FType () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) -let (string_of_nm : nm -> Prims.string) = - fun uu___ -> - match uu___ with - | N t -> - let uu___1 = FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.format1 "N[%s]" uu___1 - | M t -> - let uu___1 = FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.format1 "M[%s]" uu___1 -let (is_monadic_arrow : FStar_Syntax_Syntax.term' -> nm) = - fun n -> - match n with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = uu___; FStar_Syntax_Syntax.comp = c;_} -> - nm_of_comp c - | uu___ -> failwith "unexpected_argument: [is_monadic_arrow]" -let (is_monadic_comp : - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> Prims.bool) = - fun c -> - let uu___ = nm_of_comp c in - match uu___ with | M uu___1 -> true | N uu___1 -> false -exception Not_found -let (uu___is_Not_found : Prims.exn -> Prims.bool) = - fun projectee -> match projectee with | Not_found -> true | uu___ -> false -let (double_star : FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.typ) = - fun typ -> - let star_once typ1 = - let uu___ = - let uu___1 = - let uu___2 = - FStar_Syntax_Syntax.new_bv FStar_Pervasives_Native.None typ1 in - FStar_Syntax_Syntax.mk_binder uu___2 in - [uu___1] in - let uu___1 = FStar_Syntax_Syntax.mk_Total FStar_Syntax_Util.ktype0 in - FStar_Syntax_Util.arrow uu___ uu___1 in - let uu___ = star_once typ in star_once uu___ -let rec (mk_star_to_type : - (FStar_Syntax_Syntax.term' -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - -> - env -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun mk -> - fun env1 -> - fun a -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = star_type' env1 a in - FStar_Syntax_Syntax.null_bv uu___5 in - let uu___5 = FStar_Syntax_Syntax.as_bqual_implicit false in - FStar_Syntax_Syntax.mk_binder_with_attrs uu___4 uu___5 - FStar_Pervasives_Native.None [] in - [uu___3] in - let uu___3 = - FStar_Syntax_Syntax.mk_Total FStar_Syntax_Util.ktype0 in - { - FStar_Syntax_Syntax.bs1 = uu___2; - FStar_Syntax_Syntax.comp = uu___3 - } in - FStar_Syntax_Syntax.Tm_arrow uu___1 in - mk uu___ -and (star_type' : - env -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term) - = - fun env1 -> - fun t -> - let mk x = FStar_Syntax_Syntax.mk x t.FStar_Syntax_Syntax.pos in - let mk_star_to_type1 = mk_star_to_type mk in - let t1 = FStar_Syntax_Subst.compress t in - match t1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = binders; - FStar_Syntax_Syntax.comp = uu___;_} - -> - let binders1 = - FStar_Compiler_List.map - (fun b -> - let uu___1 = - let uu___2 = b.FStar_Syntax_Syntax.binder_bv in - let uu___3 = - star_type' env1 - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - { - FStar_Syntax_Syntax.ppname = - (uu___2.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (uu___2.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = uu___3 - } in - { - FStar_Syntax_Syntax.binder_bv = uu___1; - FStar_Syntax_Syntax.binder_qual = - (b.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity = - (b.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs = - (b.FStar_Syntax_Syntax.binder_attrs) - }) binders in - (match t1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = uu___1; - FStar_Syntax_Syntax.comp = - { FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.GTotal hn; - FStar_Syntax_Syntax.pos = uu___2; - FStar_Syntax_Syntax.vars = uu___3; - FStar_Syntax_Syntax.hash_code = uu___4;_};_} - -> - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = star_type' env1 hn in - FStar_Syntax_Syntax.mk_GTotal uu___8 in - { - FStar_Syntax_Syntax.bs1 = binders1; - FStar_Syntax_Syntax.comp = uu___7 - } in - FStar_Syntax_Syntax.Tm_arrow uu___6 in - mk uu___5 - | uu___1 -> - let uu___2 = is_monadic_arrow t1.FStar_Syntax_Syntax.n in - (match uu___2 with - | N hn -> - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = star_type' env1 hn in - FStar_Syntax_Syntax.mk_Total uu___6 in - { - FStar_Syntax_Syntax.bs1 = binders1; - FStar_Syntax_Syntax.comp = uu___5 - } in - FStar_Syntax_Syntax.Tm_arrow uu___4 in - mk uu___3 - | M a -> - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = mk_star_to_type1 env1 a in - FStar_Syntax_Syntax.null_bv uu___9 in - let uu___9 = - FStar_Syntax_Syntax.as_bqual_implicit false in - FStar_Syntax_Syntax.mk_binder_with_attrs uu___8 - uu___9 FStar_Pervasives_Native.None [] in - [uu___7] in - FStar_Compiler_List.op_At binders1 uu___6 in - let uu___6 = - FStar_Syntax_Syntax.mk_Total - FStar_Syntax_Util.ktype0 in - { - FStar_Syntax_Syntax.bs1 = uu___5; - FStar_Syntax_Syntax.comp = uu___6 - } in - FStar_Syntax_Syntax.Tm_arrow uu___4 in - mk uu___3)) - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head; FStar_Syntax_Syntax.args = args;_} - -> - let debug t2 s = - let uu___ = - let uu___1 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t2 in - let uu___2 = - FStar_Class_Show.show - (FStar_Compiler_FlatSet.showable_set - FStar_Syntax_Syntax.ord_bv - FStar_Syntax_Print.showable_bv) s in - FStar_Compiler_Util.format2 "Dependency found in term %s : %s" - uu___1 uu___2 in - FStar_Errors.log_issue (FStar_Syntax_Syntax.has_range_syntax ()) - t2 FStar_Errors_Codes.Warning_DependencyFound () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___) in - let rec is_non_dependent_arrow ty n = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress ty in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = binders; - FStar_Syntax_Syntax.comp = c;_} - -> - let uu___1 = - let uu___2 = FStar_Syntax_Util.is_tot_or_gtot_comp c in - Prims.op_Negation uu___2 in - if uu___1 - then false - else - (try - (fun uu___3 -> - match () with - | () -> - let non_dependent_or_raise s ty1 = - let sinter = - let uu___4 = FStar_Syntax_Free.names ty1 in - Obj.magic - (FStar_Class_Setlike.inter () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) - (Obj.magic uu___4) (Obj.magic s)) in - let uu___4 = - let uu___5 = - FStar_Class_Setlike.is_empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) - (Obj.magic sinter) in - Prims.op_Negation uu___5 in - if uu___4 - then - (debug ty1 sinter; - FStar_Compiler_Effect.raise Not_found) - else () in - let uu___4 = - FStar_Syntax_Subst.open_comp binders c in - (match uu___4 with - | (binders1, c1) -> - let s = - let uu___5 = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) - ()) in - FStar_Compiler_List.fold_left - (fun uu___7 -> - fun uu___6 -> - (fun s1 -> - fun uu___6 -> - match uu___6 with - | { - FStar_Syntax_Syntax.binder_bv - = bv; - FStar_Syntax_Syntax.binder_qual - = uu___7; - FStar_Syntax_Syntax.binder_positivity - = uu___8; - FStar_Syntax_Syntax.binder_attrs - = uu___9;_} - -> - (non_dependent_or_raise s1 - bv.FStar_Syntax_Syntax.sort; - Obj.magic - (FStar_Class_Setlike.add - () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) - bv (Obj.magic s1)))) - uu___7 uu___6) uu___5 binders1 in - let ct = FStar_Syntax_Util.comp_result c1 in - (non_dependent_or_raise s ct; - (let k = - n - - (FStar_Compiler_List.length binders1) in - if k > Prims.int_zero - then is_non_dependent_arrow ct k - else true)))) () - with | Not_found -> false) - | uu___1 -> - ((let uu___3 = - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - ty in - FStar_Compiler_Util.format1 "Not a dependent arrow : %s" - uu___4 in - FStar_Errors.log_issue - (FStar_Syntax_Syntax.has_range_syntax ()) ty - FStar_Errors_Codes.Warning_NotDependentArrow () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___3)); - false) in - let rec is_valid_application head1 = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress head1 in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_fvar fv when - (((FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.option_lid) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.either_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.eq2_lid)) - || - (let uu___1 = FStar_Syntax_Subst.compress head1 in - FStar_Syntax_Util.is_tuple_constructor uu___1) - -> true - | FStar_Syntax_Syntax.Tm_fvar fv -> - let uu___1 = - FStar_TypeChecker_Env.lookup_lid env1.tcenv - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - (match uu___1 with - | ((uu___2, ty), uu___3) -> - let uu___4 = - is_non_dependent_arrow ty - (FStar_Compiler_List.length args) in - if uu___4 - then - let res = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.EraseUniverses; - FStar_TypeChecker_Env.Inlining; - FStar_TypeChecker_Env.DontUnfoldAttr - [FStar_Parser_Const.tac_opaque_attr]; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant] env1.tcenv - t1 in - let uu___5 = - let uu___6 = FStar_Syntax_Subst.compress res in - uu___6.FStar_Syntax_Syntax.n in - (match uu___5 with - | FStar_Syntax_Syntax.Tm_app uu___6 -> true - | uu___6 -> - ((let uu___8 = - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head1 in - FStar_Compiler_Util.format1 - "Got a term which might be a non-dependent user-defined data-type %s\n" - uu___9 in - FStar_Errors.log_issue - (FStar_Syntax_Syntax.has_range_syntax ()) - head1 - FStar_Errors_Codes.Warning_NondependentUserDefinedDataType - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___8)); - false)) - else false) - | FStar_Syntax_Syntax.Tm_bvar uu___1 -> true - | FStar_Syntax_Syntax.Tm_name uu___1 -> true - | FStar_Syntax_Syntax.Tm_uinst (t2, uu___1) -> - is_valid_application t2 - | uu___1 -> false in - let uu___ = is_valid_application head in - if uu___ - then - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Compiler_List.map - (fun uu___4 -> - match uu___4 with - | (t2, qual) -> - let uu___5 = star_type' env1 t2 in (uu___5, qual)) - args in - { - FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = uu___3 - } in - FStar_Syntax_Syntax.Tm_app uu___2 in - mk uu___1 - else - (let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.format1 - "For now, only [either], [option] and [eq2] are supported in the definition language (got: %s)" - uu___3 in - FStar_Errors.raise_error0 FStar_Errors_Codes.Fatal_WrongTerm () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)) - | FStar_Syntax_Syntax.Tm_bvar uu___ -> t1 - | FStar_Syntax_Syntax.Tm_name uu___ -> t1 - | FStar_Syntax_Syntax.Tm_type uu___ -> t1 - | FStar_Syntax_Syntax.Tm_fvar uu___ -> t1 - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = binders; - FStar_Syntax_Syntax.body = repr; - FStar_Syntax_Syntax.rc_opt = something;_} - -> - let uu___ = FStar_Syntax_Subst.open_term binders repr in - (match uu___ with - | (binders1, repr1) -> - let env2 = - let uu___1 = - FStar_TypeChecker_Env.push_binders env1.tcenv binders1 in - { - tcenv = uu___1; - subst = (env1.subst); - tc_const = (env1.tc_const) - } in - let repr2 = star_type' env2 repr1 in - FStar_Syntax_Util.abs binders1 repr2 something) - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x; FStar_Syntax_Syntax.phi = t2;_} when - false -> - let x1 = FStar_Syntax_Syntax.freshen_bv x in - let sort = star_type' env1 x1.FStar_Syntax_Syntax.sort in - let subst = [FStar_Syntax_Syntax.DB (Prims.int_zero, x1)] in - let t3 = FStar_Syntax_Subst.subst subst t2 in - let t4 = star_type' env1 t3 in - let subst1 = [FStar_Syntax_Syntax.NM (x1, Prims.int_zero)] in - let t5 = FStar_Syntax_Subst.subst subst1 t4 in - mk - (FStar_Syntax_Syntax.Tm_refine - { - FStar_Syntax_Syntax.b = - { - FStar_Syntax_Syntax.ppname = - (x1.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (x1.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = sort - }; - FStar_Syntax_Syntax.phi = t5 - }) - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t2; FStar_Syntax_Syntax.meta = m;_} -> - let uu___ = - let uu___1 = - let uu___2 = star_type' env1 t2 in - { - FStar_Syntax_Syntax.tm2 = uu___2; - FStar_Syntax_Syntax.meta = m - } in - FStar_Syntax_Syntax.Tm_meta uu___1 in - mk uu___ - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = e; - FStar_Syntax_Syntax.asc = - (FStar_Pervasives.Inl t2, FStar_Pervasives_Native.None, use_eq); - FStar_Syntax_Syntax.eff_opt = something;_} - -> - let uu___ = - let uu___1 = - let uu___2 = star_type' env1 e in - let uu___3 = - let uu___4 = - let uu___5 = star_type' env1 t2 in - FStar_Pervasives.Inl uu___5 in - (uu___4, FStar_Pervasives_Native.None, use_eq) in - { - FStar_Syntax_Syntax.tm = uu___2; - FStar_Syntax_Syntax.asc = uu___3; - FStar_Syntax_Syntax.eff_opt = something - } in - FStar_Syntax_Syntax.Tm_ascribed uu___1 in - mk uu___ - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = e; - FStar_Syntax_Syntax.asc = - (FStar_Pervasives.Inr c, FStar_Pervasives_Native.None, use_eq); - FStar_Syntax_Syntax.eff_opt = something;_} - -> - let uu___ = - let uu___1 = - let uu___2 = star_type' env1 e in - let uu___3 = - let uu___4 = - let uu___5 = - star_type' env1 (FStar_Syntax_Util.comp_result c) in - FStar_Pervasives.Inl uu___5 in - (uu___4, FStar_Pervasives_Native.None, use_eq) in - { - FStar_Syntax_Syntax.tm = uu___2; - FStar_Syntax_Syntax.asc = uu___3; - FStar_Syntax_Syntax.eff_opt = something - } in - FStar_Syntax_Syntax.Tm_ascribed uu___1 in - mk uu___ - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = uu___; - FStar_Syntax_Syntax.asc = - (uu___1, FStar_Pervasives_Native.Some uu___2, uu___3); - FStar_Syntax_Syntax.eff_opt = uu___4;_} - -> - let uu___5 = - let uu___6 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.format1 - "Ascriptions with tactics are outside of the definition language: %s" - uu___6 in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_TermOutsideOfDefLanguage () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___5) - | FStar_Syntax_Syntax.Tm_refine uu___ -> - let uu___1 = - let uu___2 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t1 in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.format2 - "%s is outside of the definition language: %s" uu___2 uu___3 in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_TermOutsideOfDefLanguage () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) - | FStar_Syntax_Syntax.Tm_uinst uu___ -> - let uu___1 = - let uu___2 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t1 in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.format2 - "%s is outside of the definition language: %s" uu___2 uu___3 in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_TermOutsideOfDefLanguage () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) - | FStar_Syntax_Syntax.Tm_quoted uu___ -> - let uu___1 = - let uu___2 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t1 in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.format2 - "%s is outside of the definition language: %s" uu___2 uu___3 in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_TermOutsideOfDefLanguage () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) - | FStar_Syntax_Syntax.Tm_constant uu___ -> - let uu___1 = - let uu___2 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t1 in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.format2 - "%s is outside of the definition language: %s" uu___2 uu___3 in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_TermOutsideOfDefLanguage () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) - | FStar_Syntax_Syntax.Tm_match uu___ -> - let uu___1 = - let uu___2 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t1 in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.format2 - "%s is outside of the definition language: %s" uu___2 uu___3 in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_TermOutsideOfDefLanguage () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) - | FStar_Syntax_Syntax.Tm_let uu___ -> - let uu___1 = - let uu___2 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t1 in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.format2 - "%s is outside of the definition language: %s" uu___2 uu___3 in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_TermOutsideOfDefLanguage () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) - | FStar_Syntax_Syntax.Tm_uvar uu___ -> - let uu___1 = - let uu___2 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t1 in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.format2 - "%s is outside of the definition language: %s" uu___2 uu___3 in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_TermOutsideOfDefLanguage () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) - | FStar_Syntax_Syntax.Tm_unknown -> - let uu___ = - let uu___1 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t1 in - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.format2 - "%s is outside of the definition language: %s" uu___1 uu___2 in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_TermOutsideOfDefLanguage () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___) - | FStar_Syntax_Syntax.Tm_lazy i -> - let uu___ = FStar_Syntax_Util.unfold_lazy i in - star_type' env1 uu___ - | FStar_Syntax_Syntax.Tm_delayed uu___ -> failwith "impossible" -let (is_monadic : - FStar_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option -> - Prims.bool) - = - fun uu___ -> - match uu___ with - | FStar_Pervasives_Native.None -> failwith "un-annotated lambda?!" - | FStar_Pervasives_Native.Some rc -> - FStar_Compiler_Util.for_some - (fun uu___1 -> - match uu___1 with - | FStar_Syntax_Syntax.CPS -> true - | uu___2 -> false) rc.FStar_Syntax_Syntax.residual_flags -let rec (is_C : FStar_Syntax_Syntax.typ -> Prims.bool) = - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head; FStar_Syntax_Syntax.args = args;_} - when FStar_Syntax_Util.is_tuple_constructor head -> - let r = - let uu___1 = - let uu___2 = FStar_Compiler_List.hd args in - FStar_Pervasives_Native.fst uu___2 in - is_C uu___1 in - if r - then - ((let uu___2 = - let uu___3 = - FStar_Compiler_List.for_all - (fun uu___4 -> match uu___4 with | (h, uu___5) -> is_C h) - args in - Prims.op_Negation uu___3 in - if uu___2 - then - let uu___3 = - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.format1 "Not a C-type (A * C): %s" uu___4 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) t - FStar_Errors_Codes.Error_UnexpectedDM4FType () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___3) - else ()); - true) - else - ((let uu___3 = - let uu___4 = - FStar_Compiler_List.for_all - (fun uu___5 -> - match uu___5 with - | (h, uu___6) -> - let uu___7 = is_C h in Prims.op_Negation uu___7) - args in - Prims.op_Negation uu___4 in - if uu___3 - then - let uu___4 = - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.format1 "Not a C-type (C * A): %s" uu___5 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) t - FStar_Errors_Codes.Error_UnexpectedDM4FType () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4) - else ()); - false) - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = binders; - FStar_Syntax_Syntax.comp = comp;_} - -> - let uu___1 = nm_of_comp comp in - (match uu___1 with - | M t1 -> - ((let uu___3 = is_C t1 in - if uu___3 - then - let uu___4 = - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - t1 in - FStar_Compiler_Util.format1 "Not a C-type (C -> C): %s" - uu___5 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) t1 - FStar_Errors_Codes.Error_UnexpectedDM4FType () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4) - else ()); - true) - | N t1 -> is_C t1) - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t1; FStar_Syntax_Syntax.meta = uu___1;_} - -> is_C t1 - | FStar_Syntax_Syntax.Tm_uinst (t1, uu___1) -> is_C t1 - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t1; FStar_Syntax_Syntax.asc = uu___1; - FStar_Syntax_Syntax.eff_opt = uu___2;_} - -> is_C t1 - | uu___1 -> false -let (mk_return : - env -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun env1 -> - fun t -> - fun e -> - let mk x = FStar_Syntax_Syntax.mk x e.FStar_Syntax_Syntax.pos in - let p_type = mk_star_to_type mk env1 t in - let p = - FStar_Syntax_Syntax.gen_bv "p'" FStar_Pervasives_Native.None p_type in - let body = - let uu___ = - let uu___1 = - let uu___2 = FStar_Syntax_Syntax.bv_to_name p in - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.as_aqual_implicit false in - (e, uu___5) in - [uu___4] in - { - FStar_Syntax_Syntax.hd = uu___2; - FStar_Syntax_Syntax.args = uu___3 - } in - FStar_Syntax_Syntax.Tm_app uu___1 in - mk uu___ in - let uu___ = let uu___1 = FStar_Syntax_Syntax.mk_binder p in [uu___1] in - FStar_Syntax_Util.abs uu___ body - (FStar_Pervasives_Native.Some - (FStar_Syntax_Util.residual_tot FStar_Syntax_Util.ktype0)) -let (is_unknown : FStar_Syntax_Syntax.term' -> Prims.bool) = - fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.Tm_unknown -> true - | uu___1 -> false -let rec (check : - env -> - FStar_Syntax_Syntax.term -> - nm -> (nm * FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.term)) - = - fun env1 -> - fun e -> - fun context_nm -> - let return_if uu___ = - match uu___ with - | (rec_nm, s_e, u_e) -> - let check1 t1 t2 = - let uu___1 = - (Prims.op_Negation (is_unknown t2.FStar_Syntax_Syntax.n)) - && - (let uu___2 = - let uu___3 = - FStar_TypeChecker_Rel.teq env1.tcenv t1 t2 in - FStar_TypeChecker_Env.is_trivial uu___3 in - Prims.op_Negation uu___2) in - if uu___1 - then - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - e in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - t1 in - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - t2 in - FStar_Compiler_Util.format3 - "[check]: the expression [%s] has type [%s] but should have type [%s]" - uu___3 uu___4 uu___5 in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_TypeMismatch () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2) - else () in - (match (rec_nm, context_nm) with - | (N t1, N t2) -> (check1 t1 t2; (rec_nm, s_e, u_e)) - | (M t1, M t2) -> (check1 t1 t2; (rec_nm, s_e, u_e)) - | (N t1, M t2) -> - (check1 t1 t2; - (let uu___2 = mk_return env1 t1 s_e in - ((M t1), uu___2, u_e))) - | (M t1, N t2) -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - e in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - t1 in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - t2 in - FStar_Compiler_Util.format3 - "[check %s]: got an effectful computation [%s] in lieu of a pure computation [%s]" - uu___2 uu___3 uu___4 in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_EffectfulAndPureComputationMismatch - () (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1)) in - let ensure_m env2 e2 = - let strip_m uu___ = - match uu___ with - | (M t, s_e, u_e) -> (t, s_e, u_e) - | uu___1 -> failwith "impossible" in - match context_nm with - | N t -> - let uu___ = - let uu___1 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - Prims.strcat - "let-bound monadic body has a non-monadic continuation or a branch of a match is monadic and the others aren't : " - uu___1 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) e2 - FStar_Errors_Codes.Fatal_LetBoundMonadicMismatch () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___) - | M uu___ -> - let uu___1 = check env2 e2 context_nm in strip_m uu___1 in - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress e in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_bvar uu___1 -> - let uu___2 = infer env1 e in return_if uu___2 - | FStar_Syntax_Syntax.Tm_name uu___1 -> - let uu___2 = infer env1 e in return_if uu___2 - | FStar_Syntax_Syntax.Tm_fvar uu___1 -> - let uu___2 = infer env1 e in return_if uu___2 - | FStar_Syntax_Syntax.Tm_abs uu___1 -> - let uu___2 = infer env1 e in return_if uu___2 - | FStar_Syntax_Syntax.Tm_constant uu___1 -> - let uu___2 = infer env1 e in return_if uu___2 - | FStar_Syntax_Syntax.Tm_quoted uu___1 -> - let uu___2 = infer env1 e in return_if uu___2 - | FStar_Syntax_Syntax.Tm_app uu___1 -> - let uu___2 = infer env1 e in return_if uu___2 - | FStar_Syntax_Syntax.Tm_lazy i -> - let uu___1 = FStar_Syntax_Util.unfold_lazy i in - check env1 uu___1 context_nm - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (false, binding::[]); - FStar_Syntax_Syntax.body1 = e2;_} - -> - mk_let env1 binding e2 - (fun env2 -> fun e21 -> check env2 e21 context_nm) ensure_m - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = e0; - FStar_Syntax_Syntax.ret_opt = uu___1; - FStar_Syntax_Syntax.brs = branches; - FStar_Syntax_Syntax.rc_opt1 = uu___2;_} - -> - mk_match env1 e0 branches - (fun env2 -> fun body -> check env2 body context_nm) - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = e1; - FStar_Syntax_Syntax.meta = uu___1;_} - -> check env1 e1 context_nm - | FStar_Syntax_Syntax.Tm_uinst (e1, uu___1) -> - check env1 e1 context_nm - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = e1; FStar_Syntax_Syntax.asc = uu___1; - FStar_Syntax_Syntax.eff_opt = uu___2;_} - -> check env1 e1 context_nm - | FStar_Syntax_Syntax.Tm_let uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - FStar_Compiler_Util.format1 "[check]: Tm_let %s" uu___3 in - failwith uu___2 - | FStar_Syntax_Syntax.Tm_type uu___1 -> - failwith "impossible (DM stratification)" - | FStar_Syntax_Syntax.Tm_arrow uu___1 -> - failwith "impossible (DM stratification)" - | FStar_Syntax_Syntax.Tm_refine uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - FStar_Compiler_Util.format1 "[check]: Tm_refine %s" uu___3 in - failwith uu___2 - | FStar_Syntax_Syntax.Tm_uvar uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - FStar_Compiler_Util.format1 "[check]: Tm_uvar %s" uu___3 in - failwith uu___2 - | FStar_Syntax_Syntax.Tm_delayed uu___1 -> - failwith "impossible (compressed)" - | FStar_Syntax_Syntax.Tm_unknown -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - FStar_Compiler_Util.format1 "[check]: Tm_unknown %s" uu___2 in - failwith uu___1 -and (infer : - env -> - FStar_Syntax_Syntax.term -> - (nm * FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.term)) - = - fun env1 -> - fun e -> - let mk x = FStar_Syntax_Syntax.mk x e.FStar_Syntax_Syntax.pos in - let normalize = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.DontUnfoldAttr - [FStar_Parser_Const.tac_opaque_attr]; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.EraseUniverses] env1.tcenv in - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress e in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_bvar bv -> - failwith "I failed to open a binder... boo" - | FStar_Syntax_Syntax.Tm_name bv -> - ((N (bv.FStar_Syntax_Syntax.sort)), e, e) - | FStar_Syntax_Syntax.Tm_lazy i -> - let uu___1 = FStar_Syntax_Util.unfold_lazy i in infer env1 uu___1 - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = binders; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = rc_opt;_} - -> - let subst_rc_opt subst rc_opt1 = - match rc_opt1 with - | FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.residual_effect = uu___1; - FStar_Syntax_Syntax.residual_typ = - FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.residual_flags = uu___2;_} - -> rc_opt1 - | FStar_Pervasives_Native.None -> rc_opt1 - | FStar_Pervasives_Native.Some rc -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Compiler_Util.must - rc.FStar_Syntax_Syntax.residual_typ in - FStar_Syntax_Subst.subst subst uu___4 in - FStar_Pervasives_Native.Some uu___3 in - { - FStar_Syntax_Syntax.residual_effect = - (rc.FStar_Syntax_Syntax.residual_effect); - FStar_Syntax_Syntax.residual_typ = uu___2; - FStar_Syntax_Syntax.residual_flags = - (rc.FStar_Syntax_Syntax.residual_flags) - } in - FStar_Pervasives_Native.Some uu___1 in - let binders1 = FStar_Syntax_Subst.open_binders binders in - let subst = FStar_Syntax_Subst.opening_of_binders binders1 in - let body1 = FStar_Syntax_Subst.subst subst body in - let rc_opt1 = subst_rc_opt subst rc_opt in - let env2 = - let uu___1 = - FStar_TypeChecker_Env.push_binders env1.tcenv binders1 in - { - tcenv = uu___1; - subst = (env1.subst); - tc_const = (env1.tc_const) - } in - let s_binders = - FStar_Compiler_List.map - (fun b -> - let sort = - star_type' env2 - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - { - FStar_Syntax_Syntax.binder_bv = - (let uu___1 = b.FStar_Syntax_Syntax.binder_bv in - { - FStar_Syntax_Syntax.ppname = - (uu___1.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (uu___1.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = sort - }); - FStar_Syntax_Syntax.binder_qual = - (b.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity = - (b.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs = - (b.FStar_Syntax_Syntax.binder_attrs) - }) binders1 in - let uu___1 = - FStar_Compiler_List.fold_left - (fun uu___2 -> - fun uu___3 -> - match (uu___2, uu___3) with - | ((env3, acc), - { FStar_Syntax_Syntax.binder_bv = bv; - FStar_Syntax_Syntax.binder_qual = uu___4; - FStar_Syntax_Syntax.binder_positivity = uu___5; - FStar_Syntax_Syntax.binder_attrs = uu___6;_}) - -> - let c = bv.FStar_Syntax_Syntax.sort in - let uu___7 = is_C c in - if uu___7 - then - let xw = - let uu___8 = - let uu___9 = - FStar_Ident.string_of_id - bv.FStar_Syntax_Syntax.ppname in - Prims.strcat uu___9 "__w" in - let uu___9 = star_type' env3 c in - FStar_Syntax_Syntax.gen_bv uu___8 - FStar_Pervasives_Native.None uu___9 in - let x = - let uu___8 = - let uu___9 = FStar_Syntax_Syntax.bv_to_name xw in - trans_F_ env3 c uu___9 in - { - FStar_Syntax_Syntax.ppname = - (bv.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (bv.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = uu___8 - } in - let env4 = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Syntax_Syntax.bv_to_name xw in - (bv, uu___11) in - FStar_Syntax_Syntax.NT uu___10 in - uu___9 :: (env3.subst) in - { - tcenv = (env3.tcenv); - subst = uu___8; - tc_const = (env3.tc_const) - } in - let uu___8 = - let uu___9 = FStar_Syntax_Syntax.mk_binder x in - let uu___10 = - let uu___11 = FStar_Syntax_Syntax.mk_binder xw in - uu___11 :: acc in - uu___9 :: uu___10 in - (env4, uu___8) - else - (let x = - let uu___9 = - star_type' env3 bv.FStar_Syntax_Syntax.sort in - { - FStar_Syntax_Syntax.ppname = - (bv.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (bv.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = uu___9 - } in - let uu___9 = - let uu___10 = FStar_Syntax_Syntax.mk_binder x in - uu___10 :: acc in - (env3, uu___9))) (env2, []) binders1 in - (match uu___1 with - | (env3, u_binders) -> - let u_binders1 = FStar_Compiler_List.rev u_binders in - let uu___2 = - let check_what = - let uu___3 = is_monadic rc_opt1 in - if uu___3 then check_m else check_n in - let uu___3 = check_what env3 body1 in - match uu___3 with - | (t, s_body, u_body) -> - let uu___4 = - let uu___5 = - let uu___6 = is_monadic rc_opt1 in - if uu___6 then M t else N t in - comp_of_nm uu___5 in - (uu___4, s_body, u_body) in - (match uu___2 with - | (comp, s_body, u_body) -> - let t = FStar_Syntax_Util.arrow binders1 comp in - let s_rc_opt = - match rc_opt1 with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some rc -> - (match rc.FStar_Syntax_Syntax.residual_typ with - | FStar_Pervasives_Native.None -> - let rc1 = - let uu___3 = - FStar_Compiler_Util.for_some - (fun uu___4 -> - match uu___4 with - | FStar_Syntax_Syntax.CPS -> true - | uu___5 -> false) - rc.FStar_Syntax_Syntax.residual_flags in - if uu___3 - then - let uu___4 = - FStar_Compiler_List.filter - (fun uu___5 -> - match uu___5 with - | FStar_Syntax_Syntax.CPS -> false - | uu___6 -> true) - rc.FStar_Syntax_Syntax.residual_flags in - FStar_Syntax_Util.mk_residual_comp - FStar_Parser_Const.effect_Tot_lid - FStar_Pervasives_Native.None uu___4 - else rc in - FStar_Pervasives_Native.Some rc1 - | FStar_Pervasives_Native.Some rt -> - let rt1 = - let uu___3 = get_env env3 in - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.DontUnfoldAttr - [FStar_Parser_Const.tac_opaque_attr]; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.EraseUniverses] - uu___3 rt in - let uu___3 = - FStar_Compiler_Util.for_some - (fun uu___4 -> - match uu___4 with - | FStar_Syntax_Syntax.CPS -> true - | uu___5 -> false) - rc.FStar_Syntax_Syntax.residual_flags in - if uu___3 - then - let flags = - FStar_Compiler_List.filter - (fun uu___4 -> - match uu___4 with - | FStar_Syntax_Syntax.CPS -> false - | uu___5 -> true) - rc.FStar_Syntax_Syntax.residual_flags in - let uu___4 = - let uu___5 = - let uu___6 = double_star rt1 in - FStar_Pervasives_Native.Some uu___6 in - FStar_Syntax_Util.mk_residual_comp - FStar_Parser_Const.effect_Tot_lid uu___5 - flags in - FStar_Pervasives_Native.Some uu___4 - else - (let uu___5 = - let uu___6 = - let uu___7 = star_type' env3 rt1 in - FStar_Pervasives_Native.Some uu___7 in - { - FStar_Syntax_Syntax.residual_effect = - (rc.FStar_Syntax_Syntax.residual_effect); - FStar_Syntax_Syntax.residual_typ = - uu___6; - FStar_Syntax_Syntax.residual_flags = - (rc.FStar_Syntax_Syntax.residual_flags) - } in - FStar_Pervasives_Native.Some uu___5)) in - let uu___3 = - let comp1 = - let uu___4 = is_monadic rc_opt1 in - let uu___5 = - FStar_Syntax_Subst.subst env3.subst s_body in - trans_G env3 (FStar_Syntax_Util.comp_result comp) - uu___4 uu___5 in - let uu___4 = - FStar_Syntax_Util.ascribe u_body - ((FStar_Pervasives.Inr comp1), - FStar_Pervasives_Native.None, false) in - let uu___5 = - let uu___6 = - FStar_Syntax_Util.residual_comp_of_comp comp1 in - FStar_Pervasives_Native.Some uu___6 in - (uu___4, uu___5) in - (match uu___3 with - | (u_body1, u_rc_opt) -> - let s_body1 = - FStar_Syntax_Subst.close s_binders s_body in - let s_binders1 = - FStar_Syntax_Subst.close_binders s_binders in - let s_term = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Syntax_Subst.closing_of_binders - s_binders1 in - subst_rc_opt uu___7 s_rc_opt in - { - FStar_Syntax_Syntax.bs = s_binders1; - FStar_Syntax_Syntax.body = s_body1; - FStar_Syntax_Syntax.rc_opt = uu___6 - } in - FStar_Syntax_Syntax.Tm_abs uu___5 in - mk uu___4 in - let u_body2 = - FStar_Syntax_Subst.close u_binders1 u_body1 in - let u_binders2 = - FStar_Syntax_Subst.close_binders u_binders1 in - let u_term = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Syntax_Subst.closing_of_binders - u_binders2 in - subst_rc_opt uu___7 u_rc_opt in - { - FStar_Syntax_Syntax.bs = u_binders2; - FStar_Syntax_Syntax.body = u_body2; - FStar_Syntax_Syntax.rc_opt = uu___6 - } in - FStar_Syntax_Syntax.Tm_abs uu___5 in - mk uu___4 in - ((N t), s_term, u_term)))) - | FStar_Syntax_Syntax.Tm_fvar - { - FStar_Syntax_Syntax.fv_name = - { FStar_Syntax_Syntax.v = lid; - FStar_Syntax_Syntax.p = uu___1;_}; - FStar_Syntax_Syntax.fv_qual = uu___2;_} - -> - let uu___3 = - let uu___4 = FStar_TypeChecker_Env.lookup_lid env1.tcenv lid in - FStar_Pervasives_Native.fst uu___4 in - (match uu___3 with - | (uu___4, t) -> - let uu___5 = let uu___6 = normalize t in N uu___6 in - (uu___5, e, e)) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_range_of); - FStar_Syntax_Syntax.pos = uu___1; - FStar_Syntax_Syntax.vars = uu___2; - FStar_Syntax_Syntax.hash_code = uu___3;_}; - FStar_Syntax_Syntax.args = a::hd::rest;_} - -> - let rest1 = hd :: rest in - let uu___4 = FStar_Syntax_Util.head_and_args e in - (match uu___4 with - | (unary_op, uu___5) -> - let head = - mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = unary_op; - FStar_Syntax_Syntax.args = [a] - }) in - let t = - mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = rest1 - }) in - infer env1 t) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_set_range_of); - FStar_Syntax_Syntax.pos = uu___1; - FStar_Syntax_Syntax.vars = uu___2; - FStar_Syntax_Syntax.hash_code = uu___3;_}; - FStar_Syntax_Syntax.args = a1::a2::hd::rest;_} - -> - let rest1 = hd :: rest in - let uu___4 = FStar_Syntax_Util.head_and_args e in - (match uu___4 with - | (unary_op, uu___5) -> - let head = - mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = unary_op; - FStar_Syntax_Syntax.args = [a1; a2] - }) in - let t = - mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = rest1 - }) in - infer env1 t) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_range_of); - FStar_Syntax_Syntax.pos = uu___1; - FStar_Syntax_Syntax.vars = uu___2; - FStar_Syntax_Syntax.hash_code = uu___3;_}; - FStar_Syntax_Syntax.args = (a, FStar_Pervasives_Native.None)::[];_} - -> - let uu___4 = infer env1 a in - (match uu___4 with - | (t, s, u) -> - let uu___5 = FStar_Syntax_Util.head_and_args e in - (match uu___5 with - | (head, uu___6) -> - let uu___7 = - let uu___8 = - FStar_Syntax_Syntax.tabbrev - FStar_Parser_Const.range_lid in - N uu___8 in - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = FStar_Syntax_Syntax.as_arg s in - [uu___12] in - { - FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = uu___11 - } in - FStar_Syntax_Syntax.Tm_app uu___10 in - mk uu___9 in - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = FStar_Syntax_Syntax.as_arg u in - [uu___13] in - { - FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = uu___12 - } in - FStar_Syntax_Syntax.Tm_app uu___11 in - mk uu___10 in - (uu___7, uu___8, uu___9))) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_set_range_of); - FStar_Syntax_Syntax.pos = uu___1; - FStar_Syntax_Syntax.vars = uu___2; - FStar_Syntax_Syntax.hash_code = uu___3;_}; - FStar_Syntax_Syntax.args = (a1, uu___4)::a2::[];_} - -> - let uu___5 = infer env1 a1 in - (match uu___5 with - | (t, s, u) -> - let uu___6 = FStar_Syntax_Util.head_and_args e in - (match uu___6 with - | (head, uu___7) -> - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = FStar_Syntax_Syntax.as_arg s in - [uu___12; a2] in - { - FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = uu___11 - } in - FStar_Syntax_Syntax.Tm_app uu___10 in - mk uu___9 in - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = FStar_Syntax_Syntax.as_arg u in - [uu___13; a2] in - { - FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = uu___12 - } in - FStar_Syntax_Syntax.Tm_app uu___11 in - mk uu___10 in - (t, uu___8, uu___9))) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_range_of); - FStar_Syntax_Syntax.pos = uu___1; - FStar_Syntax_Syntax.vars = uu___2; - FStar_Syntax_Syntax.hash_code = uu___3;_}; - FStar_Syntax_Syntax.args = uu___4;_} - -> - let uu___5 = - let uu___6 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - FStar_Compiler_Util.format1 "DMFF: Ill-applied constant %s" - uu___6 in - FStar_Errors.raise_error (FStar_Syntax_Syntax.has_range_syntax ()) - e FStar_Errors_Codes.Fatal_IllAppliedConstant () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___5) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_set_range_of); - FStar_Syntax_Syntax.pos = uu___1; - FStar_Syntax_Syntax.vars = uu___2; - FStar_Syntax_Syntax.hash_code = uu___3;_}; - FStar_Syntax_Syntax.args = uu___4;_} - -> - let uu___5 = - let uu___6 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - FStar_Compiler_Util.format1 "DMFF: Ill-applied constant %s" - uu___6 in - FStar_Errors.raise_error (FStar_Syntax_Syntax.has_range_syntax ()) - e FStar_Errors_Codes.Fatal_IllAppliedConstant () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___5) - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head; FStar_Syntax_Syntax.args = args;_} - -> - let uu___1 = check_n env1 head in - (match uu___1 with - | (t_head, s_head, u_head) -> - let is_arrow t = - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress t in - uu___3.FStar_Syntax_Syntax.n in - match uu___2 with - | FStar_Syntax_Syntax.Tm_arrow uu___3 -> true - | uu___3 -> false in - let rec flatten t = - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress t in - uu___3.FStar_Syntax_Syntax.n in - match uu___2 with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = binders; - FStar_Syntax_Syntax.comp = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Total - t1; - FStar_Syntax_Syntax.pos = uu___3; - FStar_Syntax_Syntax.vars = uu___4; - FStar_Syntax_Syntax.hash_code = uu___5;_};_} - when is_arrow t1 -> - let uu___6 = flatten t1 in - (match uu___6 with - | (binders', comp) -> - ((FStar_Compiler_List.op_At binders binders'), - comp)) - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = binders; - FStar_Syntax_Syntax.comp = comp;_} - -> (binders, comp) - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = e1; - FStar_Syntax_Syntax.asc = uu___3; - FStar_Syntax_Syntax.eff_opt = uu___4;_} - -> flatten e1 - | uu___3 -> - let uu___4 = - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t_head in - FStar_Compiler_Util.format1 "%s: not a function type" - uu___5 in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_NotFunctionType () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4) in - let uu___2 = flatten t_head in - (match uu___2 with - | (binders, comp) -> - let n = FStar_Compiler_List.length binders in - let n' = FStar_Compiler_List.length args in - (if - (FStar_Compiler_List.length binders) < - (FStar_Compiler_List.length args) - then - (let uu___4 = - let uu___5 = FStar_Compiler_Util.string_of_int n in - let uu___6 = - FStar_Compiler_Util.string_of_int (n' - n) in - let uu___7 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_nat) n in - FStar_Compiler_Util.format3 - "The head of this application, after being applied to %s arguments, is an effectful computation (leaving %s arguments to be applied). Please let-bind the head applied to the %s first arguments." - uu___5 uu___6 uu___7 in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_BinderAndArgsLengthMismatch - () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4)) - else (); - (let uu___4 = FStar_Syntax_Subst.open_comp binders comp in - match uu___4 with - | (binders1, comp1) -> - let rec final_type subst uu___5 args1 = - match uu___5 with - | (binders2, comp2) -> - (match (binders2, args1) with - | ([], []) -> - let uu___6 = - FStar_Syntax_Subst.subst_comp subst - comp2 in - nm_of_comp uu___6 - | (binders3, []) -> - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - mk - (FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 = - binders3; - FStar_Syntax_Syntax.comp - = comp2 - }) in - FStar_Syntax_Subst.subst subst - uu___9 in - FStar_Syntax_Subst.compress uu___8 in - uu___7.FStar_Syntax_Syntax.n in - (match uu___6 with - | FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 = - binders4; - FStar_Syntax_Syntax.comp = comp3;_} - -> - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Syntax_Subst.close_comp - binders4 comp3 in - { - FStar_Syntax_Syntax.bs1 = - binders4; - FStar_Syntax_Syntax.comp = - uu___10 - } in - FStar_Syntax_Syntax.Tm_arrow - uu___9 in - mk uu___8 in - N uu___7 - | uu___7 -> failwith "wat?") - | ([], uu___6::uu___7) -> - failwith "just checked that?!" - | ({ FStar_Syntax_Syntax.binder_bv = bv; - FStar_Syntax_Syntax.binder_qual = - uu___6; - FStar_Syntax_Syntax.binder_positivity = - uu___7; - FStar_Syntax_Syntax.binder_attrs = - uu___8;_}::binders3, - (arg, uu___9)::args2) -> - final_type - ((FStar_Syntax_Syntax.NT (bv, arg)) :: - subst) (binders3, comp2) args2) in - let final_type1 = - final_type [] (binders1, comp1) args in - let uu___5 = - FStar_Compiler_List.splitAt n' binders1 in - (match uu___5 with - | (binders2, uu___6) -> - let uu___7 = - let uu___8 = - FStar_Compiler_List.map2 - (fun uu___9 -> - fun uu___10 -> - match (uu___9, uu___10) with - | ({ - FStar_Syntax_Syntax.binder_bv - = bv; - FStar_Syntax_Syntax.binder_qual - = uu___11; - FStar_Syntax_Syntax.binder_positivity - = uu___12; - FStar_Syntax_Syntax.binder_attrs - = uu___13;_}, - (arg, q)) -> - let uu___14 = - let uu___15 = - FStar_Syntax_Subst.compress - bv.FStar_Syntax_Syntax.sort in - uu___15.FStar_Syntax_Syntax.n in - (match uu___14 with - | FStar_Syntax_Syntax.Tm_type - uu___15 -> - let uu___16 = - let uu___17 = - star_type' env1 arg in - (uu___17, q) in - (uu___16, [(arg, q)]) - | uu___15 -> - let uu___16 = - check_n env1 arg in - (match uu___16 with - | (uu___17, s_arg, u_arg) - -> - let uu___18 = - let uu___19 = - is_C - bv.FStar_Syntax_Syntax.sort in - if uu___19 - then - let uu___20 = - let uu___21 = - FStar_Syntax_Subst.subst - env1.subst - s_arg in - (uu___21, q) in - [uu___20; - (u_arg, q)] - else [(u_arg, q)] in - ((s_arg, q), uu___18)))) - binders2 args in - FStar_Compiler_List.split uu___8 in - (match uu___7 with - | (s_args, u_args) -> - let u_args1 = - FStar_Compiler_List.flatten u_args in - let uu___8 = - mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = s_head; - FStar_Syntax_Syntax.args = - s_args - }) in - let uu___9 = - mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = u_head; - FStar_Syntax_Syntax.args = - u_args1 - }) in - (final_type1, uu___8, uu___9))))))) - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (false, binding::[]); - FStar_Syntax_Syntax.body1 = e2;_} - -> mk_let env1 binding e2 infer check_m - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = e0; - FStar_Syntax_Syntax.ret_opt = uu___1; - FStar_Syntax_Syntax.brs = branches; - FStar_Syntax_Syntax.rc_opt1 = uu___2;_} - -> mk_match env1 e0 branches infer - | FStar_Syntax_Syntax.Tm_uinst (e1, uu___1) -> infer env1 e1 - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = e1; - FStar_Syntax_Syntax.meta = uu___1;_} - -> infer env1 e1 - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = e1; FStar_Syntax_Syntax.asc = uu___1; - FStar_Syntax_Syntax.eff_opt = uu___2;_} - -> infer env1 e1 - | FStar_Syntax_Syntax.Tm_constant c -> - let uu___1 = let uu___2 = env1.tc_const c in N uu___2 in - (uu___1, e, e) - | FStar_Syntax_Syntax.Tm_quoted (tm, qt) -> - ((N FStar_Syntax_Syntax.t_term), e, e) - | FStar_Syntax_Syntax.Tm_let uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - FStar_Compiler_Util.format1 "[infer]: Tm_let %s" uu___3 in - failwith uu___2 - | FStar_Syntax_Syntax.Tm_type uu___1 -> - failwith "impossible (DM stratification)" - | FStar_Syntax_Syntax.Tm_arrow uu___1 -> - failwith "impossible (DM stratification)" - | FStar_Syntax_Syntax.Tm_refine uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - FStar_Compiler_Util.format1 "[infer]: Tm_refine %s" uu___3 in - failwith uu___2 - | FStar_Syntax_Syntax.Tm_uvar uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - FStar_Compiler_Util.format1 "[infer]: Tm_uvar %s" uu___3 in - failwith uu___2 - | FStar_Syntax_Syntax.Tm_delayed uu___1 -> - failwith "impossible (compressed)" - | FStar_Syntax_Syntax.Tm_unknown -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - FStar_Compiler_Util.format1 "[infer]: Tm_unknown %s" uu___2 in - failwith uu___1 -and (mk_match : - env -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - (FStar_Syntax_Syntax.pat' FStar_Syntax_Syntax.withinfo_t * - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - FStar_Pervasives_Native.option * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax) Prims.list -> - (env -> - FStar_Syntax_Syntax.term -> - (nm * FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.term)) - -> (nm * FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.term)) - = - fun env1 -> - fun e0 -> - fun branches -> - fun f -> - let mk x = FStar_Syntax_Syntax.mk x e0.FStar_Syntax_Syntax.pos in - let uu___ = check_n env1 e0 in - match uu___ with - | (uu___1, s_e0, u_e0) -> - let uu___2 = - let uu___3 = - FStar_Compiler_List.map - (fun b -> - let uu___4 = FStar_Syntax_Subst.open_branch b in - match uu___4 with - | (pat, FStar_Pervasives_Native.None, body) -> - let env2 = - let uu___5 = - let uu___6 = FStar_Syntax_Syntax.pat_bvs pat in - FStar_Compiler_List.fold_left - FStar_TypeChecker_Env.push_bv env1.tcenv - uu___6 in - { - tcenv = uu___5; - subst = (env1.subst); - tc_const = (env1.tc_const) - } in - let uu___5 = f env2 body in - (match uu___5 with - | (nm1, s_body, u_body) -> - (nm1, - (pat, FStar_Pervasives_Native.None, - (s_body, u_body, body)))) - | uu___5 -> - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_WhenClauseNotSupported - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "No when clauses in the definition language")) - branches in - FStar_Compiler_List.split uu___3 in - (match uu___2 with - | (nms, branches1) -> - let t1 = - let uu___3 = FStar_Compiler_List.hd nms in - match uu___3 with | M t11 -> t11 | N t11 -> t11 in - let has_m = - FStar_Compiler_List.existsb - (fun uu___3 -> - match uu___3 with - | M uu___4 -> true - | uu___4 -> false) nms in - let uu___3 = - let uu___4 = - FStar_Compiler_List.map2 - (fun nm1 -> - fun uu___5 -> - match uu___5 with - | (pat, guard, (s_body, u_body, original_body)) - -> - (match (nm1, has_m) with - | (N t2, false) -> - (nm1, (pat, guard, s_body), - (pat, guard, u_body)) - | (M t2, true) -> - (nm1, (pat, guard, s_body), - (pat, guard, u_body)) - | (N t2, true) -> - let uu___6 = - check env1 original_body (M t2) in - (match uu___6 with - | (uu___7, s_body1, u_body1) -> - ((M t2), (pat, guard, s_body1), - (pat, guard, u_body1))) - | (M uu___6, false) -> - failwith "impossible")) nms branches1 in - FStar_Compiler_List.unzip3 uu___4 in - (match uu___3 with - | (nms1, s_branches, u_branches) -> - if has_m - then - let p_type = mk_star_to_type mk env1 t1 in - let p = - FStar_Syntax_Syntax.gen_bv "p''" - FStar_Pervasives_Native.None p_type in - let s_branches1 = - FStar_Compiler_List.map - (fun uu___4 -> - match uu___4 with - | (pat, guard, s_body) -> - let s_body1 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Syntax_Syntax.bv_to_name - p in - let uu___10 = - FStar_Syntax_Syntax.as_aqual_implicit - false in - (uu___9, uu___10) in - [uu___8] in - { - FStar_Syntax_Syntax.hd = s_body; - FStar_Syntax_Syntax.args = - uu___7 - } in - FStar_Syntax_Syntax.Tm_app uu___6 in - mk uu___5 in - (pat, guard, s_body1)) s_branches in - let s_branches2 = - FStar_Compiler_List.map - FStar_Syntax_Subst.close_branch s_branches1 in - let u_branches1 = - FStar_Compiler_List.map - FStar_Syntax_Subst.close_branch u_branches in - let s_e = - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.mk_binder p in - [uu___5] in - let uu___5 = - mk - (FStar_Syntax_Syntax.Tm_match - { - FStar_Syntax_Syntax.scrutinee = s_e0; - FStar_Syntax_Syntax.ret_opt = - FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.brs = s_branches2; - FStar_Syntax_Syntax.rc_opt1 = - FStar_Pervasives_Native.None - }) in - FStar_Syntax_Util.abs uu___4 uu___5 - (FStar_Pervasives_Native.Some - (FStar_Syntax_Util.residual_tot - FStar_Syntax_Util.ktype0)) in - let t1_star = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Syntax.new_bv - FStar_Pervasives_Native.None p_type in - FStar_Syntax_Syntax.mk_binder uu___6 in - [uu___5] in - let uu___5 = - FStar_Syntax_Syntax.mk_Total - FStar_Syntax_Util.ktype0 in - FStar_Syntax_Util.arrow uu___4 uu___5 in - let uu___4 = - mk - (FStar_Syntax_Syntax.Tm_ascribed - { - FStar_Syntax_Syntax.tm = s_e; - FStar_Syntax_Syntax.asc = - ((FStar_Pervasives.Inl t1_star), - FStar_Pervasives_Native.None, false); - FStar_Syntax_Syntax.eff_opt = - FStar_Pervasives_Native.None - }) in - let uu___5 = - mk - (FStar_Syntax_Syntax.Tm_match - { - FStar_Syntax_Syntax.scrutinee = u_e0; - FStar_Syntax_Syntax.ret_opt = - FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.brs = u_branches1; - FStar_Syntax_Syntax.rc_opt1 = - FStar_Pervasives_Native.None - }) in - ((M t1), uu___4, uu___5) - else - (let s_branches1 = - FStar_Compiler_List.map - FStar_Syntax_Subst.close_branch s_branches in - let u_branches1 = - FStar_Compiler_List.map - FStar_Syntax_Subst.close_branch u_branches in - let t1_star = t1 in - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - mk - (FStar_Syntax_Syntax.Tm_match - { - FStar_Syntax_Syntax.scrutinee = - s_e0; - FStar_Syntax_Syntax.ret_opt = - FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.brs = - s_branches1; - FStar_Syntax_Syntax.rc_opt1 = - FStar_Pervasives_Native.None - }) in - { - FStar_Syntax_Syntax.tm = uu___8; - FStar_Syntax_Syntax.asc = - ((FStar_Pervasives.Inl t1_star), - FStar_Pervasives_Native.None, false); - FStar_Syntax_Syntax.eff_opt = - FStar_Pervasives_Native.None - } in - FStar_Syntax_Syntax.Tm_ascribed uu___7 in - mk uu___6 in - let uu___6 = - mk - (FStar_Syntax_Syntax.Tm_match - { - FStar_Syntax_Syntax.scrutinee = u_e0; - FStar_Syntax_Syntax.ret_opt = - FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.brs = u_branches1; - FStar_Syntax_Syntax.rc_opt1 = - FStar_Pervasives_Native.None - }) in - ((N t1), uu___5, uu___6)))) -and (mk_let : - env_ -> - FStar_Syntax_Syntax.letbinding -> - FStar_Syntax_Syntax.term -> - (env_ -> - FStar_Syntax_Syntax.term -> - (nm * FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.term)) - -> - (env_ -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.term)) - -> (nm * FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.term)) - = - fun env1 -> - fun binding -> - fun e2 -> - fun proceed -> - fun ensure_m -> - let mk x = FStar_Syntax_Syntax.mk x e2.FStar_Syntax_Syntax.pos in - let e1 = binding.FStar_Syntax_Syntax.lbdef in - let x = - FStar_Compiler_Util.left binding.FStar_Syntax_Syntax.lbname in - let x_binders = - let uu___ = FStar_Syntax_Syntax.mk_binder x in [uu___] in - let uu___ = FStar_Syntax_Subst.open_term x_binders e2 in - match uu___ with - | (x_binders1, e21) -> - let uu___1 = infer env1 e1 in - (match uu___1 with - | (N t1, s_e1, u_e1) -> - let u_binding = - let uu___2 = is_C t1 in - if uu___2 - then - let uu___3 = - let uu___4 = - FStar_Syntax_Subst.subst env1.subst s_e1 in - trans_F_ env1 t1 uu___4 in - { - FStar_Syntax_Syntax.lbname = - (binding.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs = - (binding.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = uu___3; - FStar_Syntax_Syntax.lbeff = - (binding.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = - (binding.FStar_Syntax_Syntax.lbdef); - FStar_Syntax_Syntax.lbattrs = - (binding.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (binding.FStar_Syntax_Syntax.lbpos) - } - else binding in - let env2 = - let uu___2 = - FStar_TypeChecker_Env.push_bv env1.tcenv - { - FStar_Syntax_Syntax.ppname = - (x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (x.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = t1 - } in - { - tcenv = uu___2; - subst = (env1.subst); - tc_const = (env1.tc_const) - } in - let uu___2 = proceed env2 e21 in - (match uu___2 with - | (nm_rec, s_e2, u_e2) -> - let s_binding = - let uu___3 = - star_type' env2 - binding.FStar_Syntax_Syntax.lbtyp in - { - FStar_Syntax_Syntax.lbname = - (binding.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs = - (binding.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = uu___3; - FStar_Syntax_Syntax.lbeff = - (binding.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = - (binding.FStar_Syntax_Syntax.lbdef); - FStar_Syntax_Syntax.lbattrs = - (binding.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (binding.FStar_Syntax_Syntax.lbpos) - } in - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Subst.close x_binders1 s_e2 in - { - FStar_Syntax_Syntax.lbs = - (false, - [{ - FStar_Syntax_Syntax.lbname = - (s_binding.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs = - (s_binding.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = - (s_binding.FStar_Syntax_Syntax.lbtyp); - FStar_Syntax_Syntax.lbeff = - (s_binding.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = s_e1; - FStar_Syntax_Syntax.lbattrs = - (s_binding.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (s_binding.FStar_Syntax_Syntax.lbpos) - }]); - FStar_Syntax_Syntax.body1 = uu___6 - } in - FStar_Syntax_Syntax.Tm_let uu___5 in - mk uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Syntax_Subst.close x_binders1 u_e2 in - { - FStar_Syntax_Syntax.lbs = - (false, - [{ - FStar_Syntax_Syntax.lbname = - (u_binding.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs = - (u_binding.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = - (u_binding.FStar_Syntax_Syntax.lbtyp); - FStar_Syntax_Syntax.lbeff = - (u_binding.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = u_e1; - FStar_Syntax_Syntax.lbattrs = - (u_binding.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (u_binding.FStar_Syntax_Syntax.lbpos) - }]); - FStar_Syntax_Syntax.body1 = uu___7 - } in - FStar_Syntax_Syntax.Tm_let uu___6 in - mk uu___5 in - (nm_rec, uu___3, uu___4)) - | (M t1, s_e1, u_e1) -> - let u_binding = - { - FStar_Syntax_Syntax.lbname = - (binding.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs = - (binding.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = t1; - FStar_Syntax_Syntax.lbeff = - FStar_Parser_Const.effect_PURE_lid; - FStar_Syntax_Syntax.lbdef = - (binding.FStar_Syntax_Syntax.lbdef); - FStar_Syntax_Syntax.lbattrs = - (binding.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (binding.FStar_Syntax_Syntax.lbpos) - } in - let env2 = - let uu___2 = - FStar_TypeChecker_Env.push_bv env1.tcenv - { - FStar_Syntax_Syntax.ppname = - (x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (x.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = t1 - } in - { - tcenv = uu___2; - subst = (env1.subst); - tc_const = (env1.tc_const) - } in - let uu___2 = ensure_m env2 e21 in - (match uu___2 with - | (t2, s_e2, u_e2) -> - let p_type = mk_star_to_type mk env2 t2 in - let p = - FStar_Syntax_Syntax.gen_bv "p''" - FStar_Pervasives_Native.None p_type in - let s_e21 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Syntax_Syntax.bv_to_name p in - let uu___8 = - FStar_Syntax_Syntax.as_aqual_implicit - false in - (uu___7, uu___8) in - [uu___6] in - { - FStar_Syntax_Syntax.hd = s_e2; - FStar_Syntax_Syntax.args = uu___5 - } in - FStar_Syntax_Syntax.Tm_app uu___4 in - mk uu___3 in - let s_e22 = - FStar_Syntax_Util.abs x_binders1 s_e21 - (FStar_Pervasives_Native.Some - (FStar_Syntax_Util.residual_tot - FStar_Syntax_Util.ktype0)) in - let body = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Syntax_Syntax.as_aqual_implicit - false in - (s_e22, uu___7) in - [uu___6] in - { - FStar_Syntax_Syntax.hd = s_e1; - FStar_Syntax_Syntax.args = uu___5 - } in - FStar_Syntax_Syntax.Tm_app uu___4 in - mk uu___3 in - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.mk_binder p in - [uu___5] in - FStar_Syntax_Util.abs uu___4 body - (FStar_Pervasives_Native.Some - (FStar_Syntax_Util.residual_tot - FStar_Syntax_Util.ktype0)) in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Syntax_Subst.close x_binders1 u_e2 in - { - FStar_Syntax_Syntax.lbs = - (false, - [{ - FStar_Syntax_Syntax.lbname = - (u_binding.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs = - (u_binding.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = - (u_binding.FStar_Syntax_Syntax.lbtyp); - FStar_Syntax_Syntax.lbeff = - (u_binding.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = u_e1; - FStar_Syntax_Syntax.lbattrs = - (u_binding.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (u_binding.FStar_Syntax_Syntax.lbpos) - }]); - FStar_Syntax_Syntax.body1 = uu___7 - } in - FStar_Syntax_Syntax.Tm_let uu___6 in - mk uu___5 in - ((M t2), uu___3, uu___4))) -and (check_n : - env_ -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.typ * FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.term)) - = - fun env1 -> - fun e -> - let mn = - let uu___ = - FStar_Syntax_Syntax.mk FStar_Syntax_Syntax.Tm_unknown - e.FStar_Syntax_Syntax.pos in - N uu___ in - let uu___ = check env1 e mn in - match uu___ with - | (N t, s_e, u_e) -> (t, s_e, u_e) - | uu___1 -> failwith "[check_n]: impossible" -and (check_m : - env_ -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.typ * FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.term)) - = - fun env1 -> - fun e -> - let mn = - let uu___ = - FStar_Syntax_Syntax.mk FStar_Syntax_Syntax.Tm_unknown - e.FStar_Syntax_Syntax.pos in - M uu___ in - let uu___ = check env1 e mn in - match uu___ with - | (M t, s_e, u_e) -> (t, s_e, u_e) - | uu___1 -> failwith "[check_m]: impossible" -and (comp_of_nm : nm_ -> FStar_Syntax_Syntax.comp) = - fun nm1 -> - match nm1 with | N t -> FStar_Syntax_Syntax.mk_Total t | M t -> mk_M t -and (mk_M : FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.comp) = - fun t -> - FStar_Syntax_Syntax.mk_Comp - { - FStar_Syntax_Syntax.comp_univs = [FStar_Syntax_Syntax.U_unknown]; - FStar_Syntax_Syntax.effect_name = FStar_Parser_Const.monadic_lid; - FStar_Syntax_Syntax.result_typ = t; - FStar_Syntax_Syntax.effect_args = []; - FStar_Syntax_Syntax.flags = - [FStar_Syntax_Syntax.CPS; FStar_Syntax_Syntax.TOTAL] - } -and (type_of_comp : - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = fun t -> FStar_Syntax_Util.comp_result t -and (trans_F_ : - env_ -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun env1 -> - fun c -> - fun wp -> - (let uu___1 = let uu___2 = is_C c in Prims.op_Negation uu___2 in - if uu___1 - then - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term c in - FStar_Compiler_Util.format1 "Not a DM4F C-type: %s" uu___3 in - FStar_Errors.raise_error (FStar_Syntax_Syntax.has_range_syntax ()) - c FStar_Errors_Codes.Error_UnexpectedDM4FType () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2) - else ()); - (let mk x = FStar_Syntax_Syntax.mk x c.FStar_Syntax_Syntax.pos in - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress c in - uu___2.FStar_Syntax_Syntax.n in - match uu___1 with - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = args;_} - -> - let uu___2 = FStar_Syntax_Util.head_and_args wp in - (match uu___2 with - | (wp_head, wp_args) -> - ((let uu___4 = - (Prims.op_Negation - ((FStar_Compiler_List.length wp_args) = - (FStar_Compiler_List.length args))) - || - (let uu___5 = - let uu___6 = - FStar_Parser_Const.mk_tuple_data_lid - (FStar_Compiler_List.length wp_args) - FStar_Compiler_Range_Type.dummyRange in - FStar_Syntax_Util.is_constructor wp_head uu___6 in - Prims.op_Negation uu___5) in - if uu___4 then failwith "mismatch" else ()); - (let uu___4 = - let uu___5 = - let uu___6 = - FStar_Compiler_List.map2 - (fun uu___7 -> - fun uu___8 -> - match (uu___7, uu___8) with - | ((arg, q), (wp_arg, q')) -> - let print_implicit q1 = - let uu___9 = - FStar_Syntax_Syntax.is_aqual_implicit - q1 in - if uu___9 - then "implicit" - else "explicit" in - ((let uu___10 = - let uu___11 = - FStar_Syntax_Util.eq_aqual q q' in - Prims.op_Negation uu___11 in - if uu___10 - then - let uu___11 = - let uu___12 = print_implicit q in - let uu___13 = print_implicit q' in - FStar_Compiler_Util.format2 - "Incoherent implicit qualifiers %s %s\n" - uu___12 uu___13 in - FStar_Errors.log_issue - FStar_Class_HasRange.hasRange_range - head.FStar_Syntax_Syntax.pos - FStar_Errors_Codes.Warning_IncoherentImplicitQualifier - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___11) - else ()); - (let uu___10 = trans_F_ env1 arg wp_arg in - (uu___10, q)))) args wp_args in - { - FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = uu___6 - } in - FStar_Syntax_Syntax.Tm_app uu___5 in - mk uu___4))) - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = binders; - FStar_Syntax_Syntax.comp = comp;_} - -> - let binders1 = FStar_Syntax_Util.name_binders binders in - let uu___2 = FStar_Syntax_Subst.open_comp binders1 comp in - (match uu___2 with - | (binders_orig, comp1) -> - let uu___3 = - let uu___4 = - FStar_Compiler_List.map - (fun b -> - let uu___5 = - ((b.FStar_Syntax_Syntax.binder_bv), - (b.FStar_Syntax_Syntax.binder_qual)) in - match uu___5 with - | (bv, q) -> - let h = bv.FStar_Syntax_Syntax.sort in - let uu___6 = is_C h in - if uu___6 - then - let w' = - let uu___7 = - let uu___8 = - FStar_Ident.string_of_id - bv.FStar_Syntax_Syntax.ppname in - Prims.strcat uu___8 "__w'" in - let uu___8 = star_type' env1 h in - FStar_Syntax_Syntax.gen_bv uu___7 - FStar_Pervasives_Native.None uu___8 in - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Syntax_Syntax.bv_to_name - w' in - trans_F_ env1 h uu___12 in - FStar_Syntax_Syntax.null_bv uu___11 in - { - FStar_Syntax_Syntax.binder_bv = - uu___10; - FStar_Syntax_Syntax.binder_qual = - (b.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity - = - (b.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs = - (b.FStar_Syntax_Syntax.binder_attrs) - } in - [uu___9] in - { - FStar_Syntax_Syntax.binder_bv = w'; - FStar_Syntax_Syntax.binder_qual = - (b.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity = - (b.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs = - (b.FStar_Syntax_Syntax.binder_attrs) - } :: uu___8 in - (w', uu___7) - else - (let x = - let uu___8 = - let uu___9 = - FStar_Ident.string_of_id - bv.FStar_Syntax_Syntax.ppname in - Prims.strcat uu___9 "__x" in - let uu___9 = star_type' env1 h in - FStar_Syntax_Syntax.gen_bv uu___8 - FStar_Pervasives_Native.None uu___9 in - (x, - [{ - FStar_Syntax_Syntax.binder_bv = x; - FStar_Syntax_Syntax.binder_qual = - (b.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity - = - (b.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs = - (b.FStar_Syntax_Syntax.binder_attrs) - }]))) binders_orig in - FStar_Compiler_List.split uu___4 in - (match uu___3 with - | (bvs, binders2) -> - let binders3 = FStar_Compiler_List.flatten binders2 in - let comp2 = - let uu___4 = - let uu___5 = - FStar_Syntax_Syntax.binders_of_list bvs in - FStar_Syntax_Util.rename_binders binders_orig - uu___5 in - FStar_Syntax_Subst.subst_comp uu___4 comp1 in - let app = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Compiler_List.map - (fun bv -> - let uu___7 = - FStar_Syntax_Syntax.bv_to_name bv in - let uu___8 = - FStar_Syntax_Syntax.as_aqual_implicit - false in - (uu___7, uu___8)) bvs in - { - FStar_Syntax_Syntax.hd = wp; - FStar_Syntax_Syntax.args = uu___6 - } in - FStar_Syntax_Syntax.Tm_app uu___5 in - mk uu___4 in - let comp3 = - let uu___4 = type_of_comp comp2 in - let uu___5 = is_monadic_comp comp2 in - trans_G env1 uu___4 uu___5 app in - FStar_Syntax_Util.arrow binders3 comp3)) - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = e; FStar_Syntax_Syntax.asc = uu___2; - FStar_Syntax_Syntax.eff_opt = uu___3;_} - -> trans_F_ env1 e wp - | uu___2 -> failwith "impossible trans_F_") -and (trans_G : - env_ -> - FStar_Syntax_Syntax.typ -> - Prims.bool -> FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.comp) - = - fun env1 -> - fun h -> - fun is_monadic1 -> - fun wp -> - if is_monadic1 - then - let uu___ = - let uu___1 = star_type' env1 h in - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Syntax.as_aqual_implicit false in - (wp, uu___4) in - [uu___3] in - { - FStar_Syntax_Syntax.comp_univs = - [FStar_Syntax_Syntax.U_unknown]; - FStar_Syntax_Syntax.effect_name = - FStar_Parser_Const.effect_PURE_lid; - FStar_Syntax_Syntax.result_typ = uu___1; - FStar_Syntax_Syntax.effect_args = uu___2; - FStar_Syntax_Syntax.flags = [] - } in - FStar_Syntax_Syntax.mk_Comp uu___ - else - (let uu___1 = trans_F_ env1 h wp in - FStar_Syntax_Syntax.mk_Total uu___1) -let (n : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.DontUnfoldAttr - [FStar_Parser_Const.tac_opaque_attr]; - FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.DoNotUnfoldPureLets; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.EraseUniverses] -let (star_type : env -> FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.typ) = - fun env1 -> fun t -> let uu___ = n env1.tcenv t in star_type' env1 uu___ -let (star_expr : - env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.typ * FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.term)) - = fun env1 -> fun t -> let uu___ = n env1.tcenv t in check_n env1 uu___ -let (trans_F : - env -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun env1 -> - fun c -> - fun wp -> - let uu___ = n env1.tcenv c in - let uu___1 = n env1.tcenv wp in trans_F_ env1 uu___ uu___1 -let (recheck_debug : - Prims.string -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun s -> - fun env1 -> - fun t -> - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.print2 - "Term has been %s-transformed to:\n%s\n----------\n" s uu___2 - else ()); - (let uu___1 = FStar_TypeChecker_TcTerm.tc_term env1 t in - match uu___1 with - | (t', uu___2, uu___3) -> - ((let uu___5 = FStar_Compiler_Effect.op_Bang dbg in - if uu___5 - then - let uu___6 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t' in - FStar_Compiler_Util.print1 - "Re-checked; got:\n%s\n----------\n" uu___6 - else ()); - t')) -let (cps_and_elaborate : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.eff_decl -> - (FStar_Syntax_Syntax.sigelt Prims.list * FStar_Syntax_Syntax.eff_decl * - FStar_Syntax_Syntax.sigelt FStar_Pervasives_Native.option)) - = - fun env1 -> - fun ed -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Syntax_Util.effect_sig_ts ed.FStar_Syntax_Syntax.signature in - FStar_Pervasives_Native.snd uu___2 in - FStar_Syntax_Subst.open_term ed.FStar_Syntax_Syntax.binders uu___1 in - match uu___ with - | (effect_binders_un, signature_un) -> - let uu___1 = - FStar_TypeChecker_TcTerm.tc_tparams env1 effect_binders_un in - (match uu___1 with - | (effect_binders, env2, uu___2) -> - let uu___3 = - FStar_TypeChecker_TcTerm.tc_trivial_guard env2 signature_un in - (match uu___3 with - | (signature, uu___4) -> - let raise_error code msg = - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - signature.FStar_Syntax_Syntax.pos code () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic msg) in - let effect_binders1 = - FStar_Compiler_List.map - (fun b -> - let uu___5 = - let uu___6 = b.FStar_Syntax_Syntax.binder_bv in - let uu___7 = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.EraseUniverses] env2 - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - { - FStar_Syntax_Syntax.ppname = - (uu___6.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (uu___6.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = uu___7 - } in - { - FStar_Syntax_Syntax.binder_bv = uu___5; - FStar_Syntax_Syntax.binder_qual = - (b.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity = - (b.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs = - (b.FStar_Syntax_Syntax.binder_attrs) - }) effect_binders in - let uu___5 = - let uu___6 = - let uu___7 = FStar_Syntax_Subst.compress signature_un in - uu___7.FStar_Syntax_Syntax.n in - match uu___6 with - | FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 = - { FStar_Syntax_Syntax.binder_bv = a; - FStar_Syntax_Syntax.binder_qual = uu___7; - FStar_Syntax_Syntax.binder_positivity = - uu___8; - FStar_Syntax_Syntax.binder_attrs = uu___9;_}::[]; - FStar_Syntax_Syntax.comp = effect_marker;_} - -> (a, effect_marker) - | uu___7 -> - raise_error - FStar_Errors_Codes.Fatal_BadSignatureShape - "bad shape for effect-for-free signature" in - (match uu___5 with - | (a, effect_marker) -> - let a1 = - let uu___6 = FStar_Syntax_Syntax.is_null_bv a in - if uu___6 - then - let uu___7 = - let uu___8 = FStar_Syntax_Syntax.range_of_bv a in - FStar_Pervasives_Native.Some uu___8 in - FStar_Syntax_Syntax.gen_bv "a" uu___7 - a.FStar_Syntax_Syntax.sort - else a in - let open_and_check env3 other_binders t = - let subst = - FStar_Syntax_Subst.opening_of_binders - (FStar_Compiler_List.op_At effect_binders1 - other_binders) in - let t1 = FStar_Syntax_Subst.subst subst t in - let uu___6 = - FStar_TypeChecker_TcTerm.tc_term env3 t1 in - match uu___6 with - | (t2, comp, uu___7) -> (t2, comp) in - let mk x = - FStar_Syntax_Syntax.mk x - signature.FStar_Syntax_Syntax.pos in - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = FStar_Syntax_Util.get_eff_repr ed in - FStar_Compiler_Util.must uu___9 in - FStar_Pervasives_Native.snd uu___8 in - open_and_check env2 [] uu___7 in - (match uu___6 with - | (repr, _comp) -> - ((let uu___8 = - FStar_Compiler_Effect.op_Bang dbg in - if uu___8 - then - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term repr in - FStar_Compiler_Util.print1 - "Representation is: %s\n" uu___9 - else ()); - (let ed_range = - FStar_TypeChecker_Env.get_range env2 in - let dmff_env = - empty env2 - (FStar_TypeChecker_TcTerm.tc_constant - env2 - FStar_Compiler_Range_Type.dummyRange) in - let wp_type = star_type dmff_env repr in - let uu___8 = recheck_debug "*" env2 wp_type in - let wp_a = - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - FStar_Syntax_Syntax.bv_to_name - a1 in - let uu___15 = - FStar_Syntax_Syntax.as_aqual_implicit - false in - (uu___14, uu___15) in - [uu___13] in - { - FStar_Syntax_Syntax.hd = wp_type; - FStar_Syntax_Syntax.args = uu___12 - } in - FStar_Syntax_Syntax.Tm_app uu___11 in - mk uu___10 in - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Beta] env2 uu___9 in - let effect_signature = - let binders = - let uu___9 = - let uu___10 = - FStar_Syntax_Syntax.as_bqual_implicit - false in - FStar_Syntax_Syntax.mk_binder_with_attrs - a1 uu___10 - FStar_Pervasives_Native.None [] in - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Syntax_Syntax.gen_bv - "dijkstra_wp" - FStar_Pervasives_Native.None wp_a in - FStar_Syntax_Syntax.mk_binder uu___12 in - [uu___11] in - uu___9 :: uu___10 in - let binders1 = - FStar_Syntax_Subst.close_binders binders in - mk - (FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 = binders1; - FStar_Syntax_Syntax.comp = - effect_marker - }) in - let uu___9 = - recheck_debug - "turned into the effect signature" env2 - effect_signature in - let sigelts = FStar_Compiler_Util.mk_ref [] in - let mk_lid name = - FStar_Syntax_Util.dm4f_lid ed name in - let elaborate_and_star dmff_env1 - other_binders item = - let env3 = get_env dmff_env1 in - let uu___10 = item in - match uu___10 with - | (u_item, item1) -> - let uu___11 = - open_and_check env3 other_binders - item1 in - (match uu___11 with - | (item2, item_comp) -> - ((let uu___13 = - let uu___14 = - FStar_TypeChecker_Common.is_total_lcomp - item_comp in - Prims.op_Negation uu___14 in - if uu___13 - then - let uu___14 = - let uu___15 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - item2 in - let uu___16 = - FStar_TypeChecker_Common.lcomp_to_string - item_comp in - FStar_Compiler_Util.format2 - "Computation for [%s] is not total : %s !" - uu___15 uu___16 in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_ComputationNotTotal - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___14) - else ()); - (let uu___13 = - star_expr dmff_env1 item2 in - match uu___13 with - | (item_t, item_wp, item_elab) - -> - let uu___14 = - recheck_debug "*" env3 - item_wp in - let uu___15 = - recheck_debug "_" env3 - item_elab in - (dmff_env1, item_t, item_wp, - item_elab)))) in - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Syntax_Util.get_bind_repr ed in - FStar_Compiler_Util.must uu___12 in - elaborate_and_star dmff_env [] uu___11 in - match uu___10 with - | (dmff_env1, uu___11, bind_wp, bind_elab) -> - let uu___12 = - let uu___13 = - let uu___14 = - FStar_Syntax_Util.get_return_repr - ed in - FStar_Compiler_Util.must uu___14 in - elaborate_and_star dmff_env1 [] uu___13 in - (match uu___12 with - | (dmff_env2, uu___13, return_wp, - return_elab) -> - let rc_gtot = - { - FStar_Syntax_Syntax.residual_effect - = - FStar_Parser_Const.effect_GTot_lid; - FStar_Syntax_Syntax.residual_typ - = FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.residual_flags - = [] - } in - let lift_from_pure_wp = - let uu___14 = - let uu___15 = - FStar_Syntax_Subst.compress - return_wp in - uu___15.FStar_Syntax_Syntax.n in - match uu___14 with - | FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = - b1::b2::bs; - FStar_Syntax_Syntax.body = - body; - FStar_Syntax_Syntax.rc_opt = - what;_} - -> - let uu___15 = - let uu___16 = - let uu___17 = - FStar_Syntax_Util.abs bs - body - FStar_Pervasives_Native.None in - FStar_Syntax_Subst.open_term - [b1; b2] uu___17 in - match uu___16 with - | (b11::b21::[], body1) -> - (b11, b21, body1) - | uu___17 -> - failwith - "Impossible : open_term not preserving binders arity" in - (match uu___15 with - | (b11, b21, body1) -> - let env0 = - let uu___16 = - get_env dmff_env2 in - FStar_TypeChecker_Env.push_binders - uu___16 [b11; b21] in - let wp_b1 = - let raw_wp_b1 = - let uu___16 = - let uu___17 = - let uu___18 = - let uu___19 = - let uu___20 = - FStar_Syntax_Syntax.bv_to_name - b11.FStar_Syntax_Syntax.binder_bv in - let uu___21 = - FStar_Syntax_Syntax.as_aqual_implicit - false in - (uu___20, - uu___21) in - [uu___19] in - { - FStar_Syntax_Syntax.hd - = wp_type; - FStar_Syntax_Syntax.args - = uu___18 - } in - FStar_Syntax_Syntax.Tm_app - uu___17 in - mk uu___16 in - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Beta] - env0 raw_wp_b1 in - let uu___16 = - let uu___17 = - let uu___18 = - FStar_Syntax_Util.unascribe - wp_b1 in - FStar_TypeChecker_Normalize.eta_expand_with_type - env0 body1 uu___18 in - FStar_Syntax_Util.abs_formals - uu___17 in - (match uu___16 with - | (bs1, body2, what') -> - let fail uu___17 = - let error_msg = - let uu___18 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - body2 in - let uu___19 = - match what' - with - | FStar_Pervasives_Native.None - -> "None" - | FStar_Pervasives_Native.Some - rc -> - FStar_Ident.string_of_lid - rc.FStar_Syntax_Syntax.residual_effect in - FStar_Compiler_Util.format2 - "The body of return_wp (%s) should be of type Type0 but is of type %s" - uu___18 - uu___19 in - raise_error - FStar_Errors_Codes.Fatal_WrongBodyTypeForReturnWP - error_msg in - ((match what' with - | FStar_Pervasives_Native.None - -> fail () - | FStar_Pervasives_Native.Some - rc -> - ((let uu___19 - = - let uu___20 - = - FStar_Syntax_Util.is_pure_effect - rc.FStar_Syntax_Syntax.residual_effect in - Prims.op_Negation - uu___20 in - if uu___19 - then fail () - else ()); - (let uu___19 - = - FStar_Compiler_Util.map_opt - rc.FStar_Syntax_Syntax.residual_typ - (fun rt - -> - let g_opt - = - FStar_TypeChecker_Rel.try_teq - true env2 - rt - FStar_Syntax_Util.ktype0 in - match g_opt - with - | - FStar_Pervasives_Native.Some - g' -> - FStar_TypeChecker_Rel.force_trivial_guard - env2 g' - | - FStar_Pervasives_Native.None - -> - fail ()) in - ()))); - (let wp = - let t2 = - (b21.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - let pure_wp_type - = - double_star t2 in - FStar_Syntax_Syntax.gen_bv - "wp" - FStar_Pervasives_Native.None - pure_wp_type in - let body3 = - let uu___18 = - FStar_Syntax_Syntax.bv_to_name - wp in - let uu___19 = - let uu___20 = - let uu___21 - = - FStar_Syntax_Util.abs - [b21] - body2 - what' in - (uu___21, - FStar_Pervasives_Native.None) in - [uu___20] in - FStar_Syntax_Syntax.mk_Tm_app - uu___18 - uu___19 - ed_range in - let uu___18 = - let uu___19 = - let uu___20 = - FStar_Syntax_Syntax.mk_binder - wp in - [uu___20] in - b11 :: uu___19 in - let uu___19 = - FStar_Syntax_Util.abs - bs1 body3 what in - FStar_Syntax_Util.abs - uu___18 uu___19 - (FStar_Pervasives_Native.Some - rc_gtot))))) - | uu___15 -> - raise_error - FStar_Errors_Codes.Fatal_UnexpectedReturnShape - "unexpected shape for return" in - let return_wp1 = - let uu___14 = - let uu___15 = - FStar_Syntax_Subst.compress - return_wp in - uu___15.FStar_Syntax_Syntax.n in - match uu___14 with - | FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = - b1::b2::bs; - FStar_Syntax_Syntax.body = - body; - FStar_Syntax_Syntax.rc_opt = - what;_} - -> - let uu___15 = - FStar_Syntax_Util.abs bs - body what in - FStar_Syntax_Util.abs - [b1; b2] uu___15 - (FStar_Pervasives_Native.Some - rc_gtot) - | uu___15 -> - raise_error - FStar_Errors_Codes.Fatal_UnexpectedReturnShape - "unexpected shape for return" in - let bind_wp1 = - let uu___14 = - let uu___15 = - FStar_Syntax_Subst.compress - bind_wp in - uu___15.FStar_Syntax_Syntax.n in - match uu___14 with - | FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = - binders; - FStar_Syntax_Syntax.body = - body; - FStar_Syntax_Syntax.rc_opt = - what;_} - -> - FStar_Syntax_Util.abs binders - body what - | uu___15 -> - raise_error - FStar_Errors_Codes.Fatal_UnexpectedBindShape - "unexpected shape for bind" in - let apply_close t = - if - (FStar_Compiler_List.length - effect_binders1) - = Prims.int_zero - then t - else - (let uu___15 = - let uu___16 = - let uu___17 = - let uu___18 = - let uu___19 = - FStar_Syntax_Util.args_of_binders - effect_binders1 in - FStar_Pervasives_Native.snd - uu___19 in - { - FStar_Syntax_Syntax.hd - = t; - FStar_Syntax_Syntax.args - = uu___18 - } in - FStar_Syntax_Syntax.Tm_app - uu___17 in - mk uu___16 in - FStar_Syntax_Subst.close - effect_binders1 uu___15) in - let rec apply_last f l = - match l with - | [] -> - failwith - "impossible: empty path.." - | a2::[] -> - let uu___14 = f a2 in - [uu___14] - | x::xs -> - let uu___14 = apply_last f xs in - x :: uu___14 in - let register maybe_admit name item = - let maybe_admit1 = true in - let p = - FStar_Ident.path_of_lid - ed.FStar_Syntax_Syntax.mname in - let p' = - apply_last - (fun s -> - Prims.strcat "__" - (Prims.strcat s - (Prims.strcat - "_eff_override_" - name))) p in - let l' = - FStar_Ident.lid_of_path p' - ed_range in - let uu___14 = - FStar_TypeChecker_Env.try_lookup_lid - env2 l' in - match uu___14 with - | FStar_Pervasives_Native.Some - (_us, _t) -> - ((let uu___16 = - FStar_Compiler_Debug.any - () in - if uu___16 - then - let uu___17 = - FStar_Ident.string_of_lid - l' in - FStar_Compiler_Util.print1 - "DM4F: Applying override %s\n" - uu___17 - else ()); - (let uu___16 = - FStar_Syntax_Syntax.lid_and_dd_as_fv - l' - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm - uu___16)) - | FStar_Pervasives_Native.None -> - let uu___15 = - let uu___16 = mk_lid name in - let uu___17 = - FStar_Syntax_Util.abs - effect_binders1 item - FStar_Pervasives_Native.None in - mk_toplevel_definition env2 - uu___16 uu___17 in - (match uu___15 with - | (sigelt, fv) -> - let sigelt1 = - if maybe_admit1 - then - { - FStar_Syntax_Syntax.sigel - = - (sigelt.FStar_Syntax_Syntax.sigel); - FStar_Syntax_Syntax.sigrng - = - (sigelt.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals - = - (sigelt.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta - = - (let uu___16 = - sigelt.FStar_Syntax_Syntax.sigmeta in - { - FStar_Syntax_Syntax.sigmeta_active - = - (uu___16.FStar_Syntax_Syntax.sigmeta_active); - FStar_Syntax_Syntax.sigmeta_fact_db_ids - = - (uu___16.FStar_Syntax_Syntax.sigmeta_fact_db_ids); - FStar_Syntax_Syntax.sigmeta_admit - = true; - FStar_Syntax_Syntax.sigmeta_spliced - = - (uu___16.FStar_Syntax_Syntax.sigmeta_spliced); - FStar_Syntax_Syntax.sigmeta_already_checked - = - (uu___16.FStar_Syntax_Syntax.sigmeta_already_checked); - FStar_Syntax_Syntax.sigmeta_extension_data - = - (uu___16.FStar_Syntax_Syntax.sigmeta_extension_data) - }); - FStar_Syntax_Syntax.sigattrs - = - (sigelt.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs - = - (sigelt.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts - = - (sigelt.FStar_Syntax_Syntax.sigopts) - } - else sigelt in - ((let uu___17 = - let uu___18 = - FStar_Compiler_Effect.op_Bang - sigelts in - sigelt1 :: uu___18 in - FStar_Compiler_Effect.op_Colon_Equals - sigelts uu___17); - fv)) in - let register_admit = register true in - let register1 = register false in - let lift_from_pure_wp1 = - register1 "lift_from_pure" - lift_from_pure_wp in - let mk_sigelt se = - let uu___14 = - FStar_Syntax_Syntax.mk_sigelt se in - { - FStar_Syntax_Syntax.sigel = - (uu___14.FStar_Syntax_Syntax.sigel); - FStar_Syntax_Syntax.sigrng = - ed_range; - FStar_Syntax_Syntax.sigquals = - (uu___14.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (uu___14.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (uu___14.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs - = - (uu___14.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (uu___14.FStar_Syntax_Syntax.sigopts) - } in - let return_wp2 = - register1 "return_wp" return_wp1 in - let return_elab1 = - register_admit "return_elab" - return_elab in - let bind_wp2 = - register1 "bind_wp" bind_wp1 in - let bind_elab1 = - register_admit "bind_elab" - bind_elab in - let uu___14 = - FStar_Compiler_List.fold_left - (fun uu___15 -> - fun action -> - match uu___15 with - | (dmff_env3, actions) -> - let params_un = - FStar_Syntax_Subst.open_binders - action.FStar_Syntax_Syntax.action_params in - let uu___16 = - let uu___17 = - get_env dmff_env3 in - FStar_TypeChecker_TcTerm.tc_tparams - uu___17 params_un in - (match uu___16 with - | (action_params, - env', uu___17) -> - let action_params1 - = - FStar_Compiler_List.map - (fun b -> - let uu___18 - = - let uu___19 - = - b.FStar_Syntax_Syntax.binder_bv in - let uu___20 - = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.EraseUniverses] - env' - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - { - FStar_Syntax_Syntax.ppname - = - (uu___19.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index - = - (uu___19.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort - = uu___20 - } in - { - FStar_Syntax_Syntax.binder_bv - = uu___18; - FStar_Syntax_Syntax.binder_qual - = - (b.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity - = - (b.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs - = - (b.FStar_Syntax_Syntax.binder_attrs) - }) - action_params in - let dmff_env' = - set_env - dmff_env3 env' in - let uu___18 = - elaborate_and_star - dmff_env' - action_params1 - ((action.FStar_Syntax_Syntax.action_univs), - (action.FStar_Syntax_Syntax.action_defn)) in - (match uu___18 - with - | (dmff_env4, - action_t, - action_wp, - action_elab) - -> - let name = - let uu___19 - = - FStar_Ident.ident_of_lid - action.FStar_Syntax_Syntax.action_name in - FStar_Ident.string_of_id - uu___19 in - let action_typ_with_wp - = - trans_F - dmff_env' - action_t - action_wp in - let action_params2 - = - FStar_Syntax_Subst.close_binders - action_params1 in - let action_elab1 - = - FStar_Syntax_Subst.close - action_params2 - action_elab in - let action_typ_with_wp1 - = - FStar_Syntax_Subst.close - action_params2 - action_typ_with_wp in - let action_elab2 - = - FStar_Syntax_Util.abs - action_params2 - action_elab1 - FStar_Pervasives_Native.None in - let action_typ_with_wp2 - = - match action_params2 - with - | [] -> - action_typ_with_wp1 - | uu___19 - -> - let uu___20 - = - FStar_Syntax_Syntax.mk_Total - action_typ_with_wp1 in - FStar_Syntax_Util.flat_arrow - action_params2 - uu___20 in - ((let uu___20 - = - FStar_Compiler_Effect.op_Bang - dbg in - if uu___20 - then - let uu___21 - = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binder) - params_un in - let uu___22 - = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binder) - action_params2 in - let uu___23 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - action_typ_with_wp2 in - let uu___24 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - action_elab2 in - FStar_Compiler_Util.print4 - "original action_params %s, end action_params %s, type %s, term %s\n" - uu___21 - uu___22 - uu___23 - uu___24 - else ()); - (let action_elab3 - = - register1 - (Prims.strcat - name - "_elab") - action_elab2 in - let action_typ_with_wp3 - = - register1 - (Prims.strcat - name - "_complete_type") - action_typ_with_wp2 in - let uu___20 - = - let uu___21 - = - let uu___22 - = - apply_close - action_elab3 in - let uu___23 - = - apply_close - action_typ_with_wp3 in - { - FStar_Syntax_Syntax.action_name - = - (action.FStar_Syntax_Syntax.action_name); - FStar_Syntax_Syntax.action_unqualified_name - = - (action.FStar_Syntax_Syntax.action_unqualified_name); - FStar_Syntax_Syntax.action_univs - = - (action.FStar_Syntax_Syntax.action_univs); - FStar_Syntax_Syntax.action_params - = []; - FStar_Syntax_Syntax.action_defn - = uu___22; - FStar_Syntax_Syntax.action_typ - = uu___23 - } in - uu___21 - :: - actions in - (dmff_env4, - uu___20)))))) - (dmff_env2, []) - ed.FStar_Syntax_Syntax.actions in - (match uu___14 with - | (dmff_env3, actions) -> - let actions1 = - FStar_Compiler_List.rev - actions in - let repr1 = - let wp = - FStar_Syntax_Syntax.gen_bv - "wp_a" - FStar_Pervasives_Native.None - wp_a in - let binders = - let uu___15 = - FStar_Syntax_Syntax.mk_binder - a1 in - let uu___16 = - let uu___17 = - FStar_Syntax_Syntax.mk_binder - wp in - [uu___17] in - uu___15 :: uu___16 in - let uu___15 = - let uu___16 = - let uu___17 = - let uu___18 = - let uu___19 = - let uu___20 = - let uu___21 = - FStar_Syntax_Syntax.bv_to_name - a1 in - let uu___22 = - FStar_Syntax_Syntax.as_aqual_implicit - false in - (uu___21, - uu___22) in - [uu___20] in - { - FStar_Syntax_Syntax.hd - = repr; - FStar_Syntax_Syntax.args - = uu___19 - } in - FStar_Syntax_Syntax.Tm_app - uu___18 in - mk uu___17 in - let uu___17 = - FStar_Syntax_Syntax.bv_to_name - wp in - trans_F dmff_env3 uu___16 - uu___17 in - FStar_Syntax_Util.abs binders - uu___15 - FStar_Pervasives_Native.None in - let uu___15 = - recheck_debug "FC" env2 repr1 in - let repr2 = - register1 "repr" repr1 in - let uu___16 = - let uu___17 = - let uu___18 = - let uu___19 = - FStar_Syntax_Subst.compress - wp_type in - FStar_Syntax_Util.unascribe - uu___19 in - uu___18.FStar_Syntax_Syntax.n in - match uu___17 with - | FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs - = - type_param::effect_param; - FStar_Syntax_Syntax.body - = arrow; - FStar_Syntax_Syntax.rc_opt - = uu___18;_} - -> - let uu___19 = - let uu___20 = - FStar_Syntax_Subst.open_term - (type_param :: - effect_param) arrow in - match uu___20 with - | (b::bs, body) -> - (b, bs, body) - | uu___21 -> - failwith - "Impossible : open_term nt preserving binders arity" in - (match uu___19 with - | (type_param1, - effect_param1, - arrow1) -> - let uu___20 = - let uu___21 = - let uu___22 = - FStar_Syntax_Subst.compress - arrow1 in - FStar_Syntax_Util.unascribe - uu___22 in - uu___21.FStar_Syntax_Syntax.n in - (match uu___20 with - | FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 - = - wp_binders; - FStar_Syntax_Syntax.comp - = c;_} - -> - let uu___21 = - FStar_Syntax_Subst.open_comp - wp_binders - c in - (match uu___21 - with - | (wp_binders1, - c1) -> - let uu___22 - = - FStar_Compiler_List.partition - (fun - uu___23 - -> - match uu___23 - with - | - { - FStar_Syntax_Syntax.binder_bv - = bv; - FStar_Syntax_Syntax.binder_qual - = uu___24; - FStar_Syntax_Syntax.binder_positivity - = uu___25; - FStar_Syntax_Syntax.binder_attrs - = uu___26;_} - -> - let uu___27 - = - let uu___28 - = - FStar_Syntax_Free.names - bv.FStar_Syntax_Syntax.sort in - FStar_Class_Setlike.mem - () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) - type_param1.FStar_Syntax_Syntax.binder_bv - (Obj.magic - uu___28) in - Prims.op_Negation - uu___27) - wp_binders1 in - (match uu___22 - with - | - (pre_args, - post_args) - -> - let post - = - match post_args - with - | - post1::[] - -> post1 - | - [] -> - let err_msg - = - let uu___23 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - arrow1 in - FStar_Compiler_Util.format1 - "Impossible to generate DM effect: no post candidate %s (Type variable does not appear)" - uu___23 in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_ImpossibleToGenerateDMEffect - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - err_msg) - | - uu___23 - -> - let err_msg - = - let uu___24 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - arrow1 in - FStar_Compiler_Util.format1 - "Impossible to generate DM effect: multiple post candidates %s" - uu___24 in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_ImpossibleToGenerateDMEffect - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - err_msg) in - let uu___23 - = - FStar_Syntax_Util.arrow - pre_args - c1 in - let uu___24 - = - FStar_Syntax_Util.abs - (type_param1 - :: - effect_param1) - (post.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort - FStar_Pervasives_Native.None in - (uu___23, - uu___24))) - | uu___21 -> - let uu___22 = - let uu___23 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - arrow1 in - FStar_Compiler_Util.format1 - "Impossible: pre/post arrow %s" - uu___23 in - raise_error - FStar_Errors_Codes.Fatal_ImpossiblePrePostArrow - uu___22)) - | uu___18 -> - let uu___19 = - let uu___20 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - wp_type in - FStar_Compiler_Util.format1 - "Impossible: pre/post abs %s" - uu___20 in - raise_error - FStar_Errors_Codes.Fatal_ImpossiblePrePostAbs - uu___19 in - (match uu___16 with - | (pre, post) -> - ((let uu___18 = - register1 "pre" pre in - ()); - (let uu___19 = - register1 "post" post in - ()); - (let uu___20 = - register1 "wp" wp_type in - ()); - (let ed_combs = - match ed.FStar_Syntax_Syntax.combinators - with - | FStar_Syntax_Syntax.DM4F_eff - combs -> - let uu___20 = - let uu___21 = - let uu___22 = - apply_close - return_wp2 in - ([], uu___22) in - let uu___22 = - let uu___23 = - apply_close - bind_wp2 in - ([], uu___23) in - let uu___23 = - let uu___24 = - let uu___25 - = - apply_close - repr2 in - ([], - uu___25) in - FStar_Pervasives_Native.Some - uu___24 in - let uu___24 = - let uu___25 = - let uu___26 - = - apply_close - return_elab1 in - ([], - uu___26) in - FStar_Pervasives_Native.Some - uu___25 in - let uu___25 = - let uu___26 = - let uu___27 - = - apply_close - bind_elab1 in - ([], - uu___27) in - FStar_Pervasives_Native.Some - uu___26 in - { - FStar_Syntax_Syntax.ret_wp - = uu___21; - FStar_Syntax_Syntax.bind_wp - = uu___22; - FStar_Syntax_Syntax.stronger - = - (combs.FStar_Syntax_Syntax.stronger); - FStar_Syntax_Syntax.if_then_else - = - (combs.FStar_Syntax_Syntax.if_then_else); - FStar_Syntax_Syntax.ite_wp - = - (combs.FStar_Syntax_Syntax.ite_wp); - FStar_Syntax_Syntax.close_wp - = - (combs.FStar_Syntax_Syntax.close_wp); - FStar_Syntax_Syntax.trivial - = - (combs.FStar_Syntax_Syntax.trivial); - FStar_Syntax_Syntax.repr - = uu___23; - FStar_Syntax_Syntax.return_repr - = uu___24; - FStar_Syntax_Syntax.bind_repr - = uu___25 - } in - FStar_Syntax_Syntax.DM4F_eff - uu___20 - | uu___20 -> - failwith - "Impossible! For a DM4F effect combinators must be in DM4f_eff" in - let ed1 = - let uu___20 = - FStar_Syntax_Subst.close_binders - effect_binders1 in - let uu___21 = - let uu___22 = - let uu___23 = - FStar_Syntax_Subst.close - effect_binders1 - effect_signature in - ([], uu___23) in - FStar_Syntax_Syntax.WP_eff_sig - uu___22 in - { - FStar_Syntax_Syntax.mname - = - (ed.FStar_Syntax_Syntax.mname); - FStar_Syntax_Syntax.cattributes - = - (ed.FStar_Syntax_Syntax.cattributes); - FStar_Syntax_Syntax.univs - = - (ed.FStar_Syntax_Syntax.univs); - FStar_Syntax_Syntax.binders - = uu___20; - FStar_Syntax_Syntax.signature - = uu___21; - FStar_Syntax_Syntax.combinators - = ed_combs; - FStar_Syntax_Syntax.actions - = actions1; - FStar_Syntax_Syntax.eff_attrs - = - (ed.FStar_Syntax_Syntax.eff_attrs); - FStar_Syntax_Syntax.extraction_mode - = - (ed.FStar_Syntax_Syntax.extraction_mode) - } in - let uu___20 = - gen_wps_for_free env2 - effect_binders1 a1 - wp_a ed1 in - match uu___20 with - | (sigelts', ed2) -> - ((let uu___22 = - FStar_Compiler_Effect.op_Bang - dbg in - if uu___22 - then - let uu___23 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_eff_decl - ed2 in - FStar_Compiler_Util.print_string - uu___23 - else ()); - (let lift_from_pure_opt - = - if - (FStar_Compiler_List.length - effect_binders1) - = - Prims.int_zero - then - let lift_from_pure - = - let uu___22 - = - let uu___23 - = - let uu___24 - = - apply_close - lift_from_pure_wp1 in - ([], - uu___24) in - FStar_Pervasives_Native.Some - uu___23 in - { - FStar_Syntax_Syntax.source - = - FStar_Parser_Const.effect_PURE_lid; - FStar_Syntax_Syntax.target - = - (ed2.FStar_Syntax_Syntax.mname); - FStar_Syntax_Syntax.lift_wp - = uu___22; - FStar_Syntax_Syntax.lift - = - FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.kind - = - FStar_Pervasives_Native.None - } in - let uu___22 = - mk_sigelt - (FStar_Syntax_Syntax.Sig_sub_effect - lift_from_pure) in - FStar_Pervasives_Native.Some - uu___22 - else - FStar_Pervasives_Native.None in - let uu___22 = - let uu___23 = - let uu___24 = - FStar_Compiler_Effect.op_Bang - sigelts in - FStar_Compiler_List.rev - uu___24 in - FStar_Compiler_List.op_At - uu___23 - sigelts' in - (uu___22, ed2, - lift_from_pure_opt)))))))))))))) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_DeferredImplicits.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_DeferredImplicits.ml deleted file mode 100644 index 6d592485521..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_DeferredImplicits.ml +++ /dev/null @@ -1,769 +0,0 @@ -open Prims -let (is_flex : FStar_Syntax_Syntax.term -> Prims.bool) = - fun t -> - let uu___ = FStar_Syntax_Util.head_and_args_full t in - match uu___ with - | (head, _args) -> - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress head in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_uvar uu___2 -> true - | uu___2 -> false) -let (flex_uvar_head : - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.ctx_uvar) = - fun t -> - let uu___ = FStar_Syntax_Util.head_and_args_full t in - match uu___ with - | (head, _args) -> - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress head in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_uvar (u, uu___2) -> u - | uu___2 -> failwith "Not a flex-uvar") -type goal_type = - | FlexRigid of (FStar_Syntax_Syntax.ctx_uvar * FStar_Syntax_Syntax.term) - | FlexFlex of (FStar_Syntax_Syntax.ctx_uvar * FStar_Syntax_Syntax.ctx_uvar) - - | Can_be_split_into of (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.term - * FStar_Syntax_Syntax.ctx_uvar) - | Imp of FStar_Syntax_Syntax.ctx_uvar -let (uu___is_FlexRigid : goal_type -> Prims.bool) = - fun projectee -> - match projectee with | FlexRigid _0 -> true | uu___ -> false -let (__proj__FlexRigid__item___0 : - goal_type -> (FStar_Syntax_Syntax.ctx_uvar * FStar_Syntax_Syntax.term)) = - fun projectee -> match projectee with | FlexRigid _0 -> _0 -let (uu___is_FlexFlex : goal_type -> Prims.bool) = - fun projectee -> - match projectee with | FlexFlex _0 -> true | uu___ -> false -let (__proj__FlexFlex__item___0 : - goal_type -> (FStar_Syntax_Syntax.ctx_uvar * FStar_Syntax_Syntax.ctx_uvar)) - = fun projectee -> match projectee with | FlexFlex _0 -> _0 -let (uu___is_Can_be_split_into : goal_type -> Prims.bool) = - fun projectee -> - match projectee with | Can_be_split_into _0 -> true | uu___ -> false -let (__proj__Can_be_split_into__item___0 : - goal_type -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.ctx_uvar)) - = fun projectee -> match projectee with | Can_be_split_into _0 -> _0 -let (uu___is_Imp : goal_type -> Prims.bool) = - fun projectee -> match projectee with | Imp _0 -> true | uu___ -> false -let (__proj__Imp__item___0 : goal_type -> FStar_Syntax_Syntax.ctx_uvar) = - fun projectee -> match projectee with | Imp _0 -> _0 -let (find_user_tac_for_uvar : - FStar_TypeChecker_Env.env_t -> - FStar_Syntax_Syntax.ctx_uvar -> - FStar_Syntax_Syntax.sigelt FStar_Pervasives_Native.option) - = - fun env -> - fun u -> - let rec attr_list_elements e = - let uu___ = - let uu___1 = FStar_Syntax_Util.unmeta e in - FStar_Syntax_Util.head_and_args uu___1 in - match uu___ with - | (head, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst head in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, uu___2) when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.nil_lid - -> FStar_Pervasives_Native.Some [] - | (FStar_Syntax_Syntax.Tm_fvar fv, - uu___2::(hd, uu___3)::(tl, uu___4)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.cons_lid - -> - (match hd.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_string - (s, uu___5)) -> - let uu___6 = attr_list_elements tl in - (match uu___6 with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some tl1 -> - FStar_Pervasives_Native.Some (s :: tl1)) - | uu___5 -> FStar_Pervasives_Native.None) - | (FStar_Syntax_Syntax.Tm_fvar fv, - (hd, uu___2)::(tl, uu___3)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.cons_lid - -> - (match hd.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_string - (s, uu___4)) -> - let uu___5 = attr_list_elements tl in - (match uu___5 with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some tl1 -> - FStar_Pervasives_Native.Some (s :: tl1)) - | uu___4 -> FStar_Pervasives_Native.None) - | uu___2 -> FStar_Pervasives_Native.None) in - let candidate_names candidates = - let uu___ = - let uu___1 = - FStar_Compiler_List.collect FStar_Syntax_Util.lids_of_sigelt - candidates in - FStar_Compiler_List.map FStar_Ident.string_of_lid uu___1 in - FStar_Compiler_String.concat ", " uu___ in - match u.FStar_Syntax_Syntax.ctx_uvar_meta with - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Ctx_uvar_meta_attr - a) -> - let hooks = - FStar_TypeChecker_Env.lookup_attr env - FStar_Parser_Const.resolve_implicits_attr_string in - let candidates = - FStar_Compiler_List.filter - (fun hook -> - FStar_Compiler_Util.for_some - (FStar_TypeChecker_TermEqAndSimplify.eq_tm_bool env a) - hook.FStar_Syntax_Syntax.sigattrs) hooks in - let candidates1 = - FStar_Compiler_Util.remove_dups - (fun s0 -> - fun s1 -> - let l0 = FStar_Syntax_Util.lids_of_sigelt s0 in - let l1 = FStar_Syntax_Util.lids_of_sigelt s1 in - if - (FStar_Compiler_List.length l0) = - (FStar_Compiler_List.length l1) - then - FStar_Compiler_List.forall2 - (fun l01 -> fun l11 -> FStar_Ident.lid_equals l01 l11) - l0 l1 - else false) candidates in - let is_overridden candidate = - let candidate_lids = FStar_Syntax_Util.lids_of_sigelt candidate in - FStar_Compiler_Util.for_some - (fun other -> - FStar_Compiler_Util.for_some - (fun attr -> - let uu___ = FStar_Syntax_Util.head_and_args attr in - match uu___ with - | (head, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst head in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, - uu___2::(a', uu___3)::(overrides, uu___4)::[]) - when - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.override_resolve_implicits_handler_lid) - && - (FStar_TypeChecker_TermEqAndSimplify.eq_tm_bool - env a a') - -> - let uu___5 = attr_list_elements overrides in - (match uu___5 with - | FStar_Pervasives_Native.None -> false - | FStar_Pervasives_Native.Some names -> - FStar_Compiler_Util.for_some - (fun n -> - FStar_Compiler_Util.for_some - (fun l -> - let uu___6 = - FStar_Ident.string_of_lid l in - uu___6 = n) candidate_lids) - names) - | (FStar_Syntax_Syntax.Tm_fvar fv, - (a', uu___2)::(overrides, uu___3)::[]) when - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.override_resolve_implicits_handler_lid) - && - (FStar_TypeChecker_TermEqAndSimplify.eq_tm_bool - env a a') - -> - let uu___4 = attr_list_elements overrides in - (match uu___4 with - | FStar_Pervasives_Native.None -> false - | FStar_Pervasives_Native.Some names -> - FStar_Compiler_Util.for_some - (fun n -> - FStar_Compiler_Util.for_some - (fun l -> - let uu___5 = - FStar_Ident.string_of_lid l in - uu___5 = n) candidate_lids) - names) - | uu___2 -> false)) - other.FStar_Syntax_Syntax.sigattrs) candidates1 in - let candidates2 = - FStar_Compiler_List.filter - (fun c -> - let uu___ = is_overridden c in Prims.op_Negation uu___) - candidates1 in - (match candidates2 with - | [] -> FStar_Pervasives_Native.None - | c::[] -> FStar_Pervasives_Native.Some c - | uu___ -> - let candidates3 = candidate_names candidates2 in - let attr = - FStar_Class_Show.show FStar_Syntax_Print.showable_term a in - ((let uu___2 = - FStar_Compiler_Util.format2 - "Multiple resolve_implicits hooks are eligible for attribute %s; \nplease resolve the ambiguity by using the `override_resolve_implicits_handler` attribute to choose among these candidates {%s}" - attr candidates3 in - FStar_Errors.log_issue FStar_Class_HasRange.hasRange_range - u.FStar_Syntax_Syntax.ctx_uvar_range - FStar_Errors_Codes.Warning_AmbiguousResolveImplicitsHook - () (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None)) - | uu___ -> FStar_Pervasives_Native.None -let (should_defer_uvar_to_user_tac : - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.ctx_uvar -> Prims.bool) = - fun env -> - fun u -> - if Prims.op_Negation env.FStar_TypeChecker_Env.enable_defer_to_tac - then false - else - (let uu___1 = find_user_tac_for_uvar env u in - FStar_Pervasives_Native.uu___is_Some uu___1) -let solve_goals_with_tac : - 'uuuuu . - FStar_TypeChecker_Env.env -> - 'uuuuu -> - FStar_TypeChecker_Common.implicits -> - FStar_Syntax_Syntax.sigelt -> unit - = - fun env -> - fun g -> - fun deferred_goals -> - fun tac -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_Env.current_module env in - FStar_Ident.string_of_lid uu___2 in - FStar_Pervasives_Native.Some uu___1 in - FStar_Profiling.profile - (fun uu___1 -> - let resolve_tac = - match tac.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = uu___2; - FStar_Syntax_Syntax.lids1 = lid::[];_} - -> - let qn = FStar_TypeChecker_Env.lookup_qname env lid in - let fv = - FStar_Syntax_Syntax.lid_as_fv lid - FStar_Pervasives_Native.None in - let term = - let uu___3 = - FStar_Syntax_Syntax.lid_as_fv lid - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___3 in - term - | uu___2 -> failwith "Resolve_tac not found" in - let env1 = - { - FStar_TypeChecker_Env.solver = - (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (env.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = false; - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env.FStar_TypeChecker_Env.missing_decl) - } in - env1.FStar_TypeChecker_Env.try_solve_implicits_hook env1 - resolve_tac deferred_goals) uu___ - "FStar.TypeChecker.DeferredImplicits.solve_goals_with_tac" -let (solve_deferred_to_tactic_goals : - FStar_TypeChecker_Env.env -> - FStar_TypeChecker_Common.guard_t -> FStar_TypeChecker_Common.guard_t) - = - fun env -> - fun g -> - if Prims.op_Negation env.FStar_TypeChecker_Env.enable_defer_to_tac - then g - else - (let deferred = g.FStar_TypeChecker_Common.deferred_to_tac in - let prob_as_implicit uu___1 = - match uu___1 with - | (uu___2, reason, prob) -> - (match prob with - | FStar_TypeChecker_Common.TProb tp when - tp.FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.EQ - -> - let uu___3 = FStar_TypeChecker_Env.clear_expected_typ env in - (match uu___3 with - | (env1, uu___4) -> - let env2 = - { - FStar_TypeChecker_Env.solver = - (env1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - ((tp.FStar_TypeChecker_Common.logical_guard_uvar).FStar_Syntax_Syntax.ctx_uvar_gamma); - FStar_TypeChecker_Env.gamma_sig = - (env1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (env1.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env1.FStar_TypeChecker_Env.missing_decl) - } in - let env_lax = - { - FStar_TypeChecker_Env.solver = - (env2.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env2.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env2.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env2.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env2.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env2.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env2.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env2.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env2.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env2.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env2.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env2.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env2.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env2.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env2.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env2.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env2.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env2.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = true; - FStar_TypeChecker_Env.lax_universes = - (env2.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env2.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env2.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env2.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env2.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env2.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env2.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env2.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env2.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env2.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env2.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env2.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env2.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env2.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env2.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env2.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env2.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env2.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env2.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env2.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env2.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env2.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env2.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env2.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env2.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env2.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env2.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env2.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - false; - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env2.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env2.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env2.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env2.FStar_TypeChecker_Env.missing_decl) - } in - let uu___5 = - let t = - let uu___6 = - is_flex tp.FStar_TypeChecker_Common.lhs in - if uu___6 - then tp.FStar_TypeChecker_Common.lhs - else tp.FStar_TypeChecker_Common.rhs in - env2.FStar_TypeChecker_Env.typeof_tot_or_gtot_term - env_lax t true in - (match uu___5 with - | (uu___6, t_eq, uu___7) -> - let goal_ty = - let uu___8 = - env2.FStar_TypeChecker_Env.universe_of - env_lax t_eq in - FStar_Syntax_Util.mk_eq2 uu___8 t_eq - tp.FStar_TypeChecker_Common.lhs - tp.FStar_TypeChecker_Common.rhs in - let uu___8 = - FStar_TypeChecker_Env.new_implicit_var_aux - reason - (tp.FStar_TypeChecker_Common.lhs).FStar_Syntax_Syntax.pos - env2 goal_ty FStar_Syntax_Syntax.Strict - FStar_Pervasives_Native.None false in - (match uu___8 with - | (goal, ctx_uvar, uu___9) -> - let imp = - { - FStar_TypeChecker_Common.imp_reason = - ""; - FStar_TypeChecker_Common.imp_uvar = - (FStar_Pervasives_Native.fst - ctx_uvar); - FStar_TypeChecker_Common.imp_tm = goal; - FStar_TypeChecker_Common.imp_range = - ((tp.FStar_TypeChecker_Common.lhs).FStar_Syntax_Syntax.pos) - } in - let sigelt = - let uu___10 = - is_flex - tp.FStar_TypeChecker_Common.lhs in - if uu___10 - then - let uu___11 = - let uu___12 = - flex_uvar_head - tp.FStar_TypeChecker_Common.lhs in - find_user_tac_for_uvar env2 uu___12 in - match uu___11 with - | FStar_Pervasives_Native.None -> - let uu___12 = - is_flex - tp.FStar_TypeChecker_Common.rhs in - (if uu___12 - then - let uu___13 = - flex_uvar_head - tp.FStar_TypeChecker_Common.rhs in - find_user_tac_for_uvar env2 - uu___13 - else FStar_Pervasives_Native.None) - | v -> v - else - (let uu___12 = - is_flex - tp.FStar_TypeChecker_Common.rhs in - if uu___12 - then - let uu___13 = - flex_uvar_head - tp.FStar_TypeChecker_Common.rhs in - find_user_tac_for_uvar env2 uu___13 - else FStar_Pervasives_Native.None) in - (match sigelt with - | FStar_Pervasives_Native.None -> - failwith - "Impossible: No tactic associated with deferred problem" - | FStar_Pervasives_Native.Some se -> - (imp, se))))) - | uu___3 -> failwith "Unexpected problem deferred to tactic") in - let eqs = - let uu___1 = - FStar_Class_Listlike.to_list - (FStar_Compiler_CList.listlike_clist ()) - g.FStar_TypeChecker_Common.deferred_to_tac in - FStar_Compiler_List.map prob_as_implicit uu___1 in - let uu___1 = - let uu___2 = - FStar_Class_Listlike.to_list - (FStar_Compiler_CList.listlike_clist ()) - g.FStar_TypeChecker_Common.implicits in - FStar_Compiler_List.fold_right - (fun imp -> - fun uu___3 -> - match uu___3 with - | (more, imps) -> - let uu___4 = - FStar_Syntax_Unionfind.find - (imp.FStar_TypeChecker_Common.imp_uvar).FStar_Syntax_Syntax.ctx_uvar_head in - (match uu___4 with - | FStar_Pervasives_Native.Some uu___5 -> - (more, (imp :: imps)) - | FStar_Pervasives_Native.None -> - let se = - find_user_tac_for_uvar env - imp.FStar_TypeChecker_Common.imp_uvar in - (match se with - | FStar_Pervasives_Native.None -> - (more, (imp :: imps)) - | FStar_Pervasives_Native.Some se1 -> - (((imp, se1) :: more), imps)))) uu___2 - ([], []) in - match uu___1 with - | (more, imps) -> - let bucketize is = - let map = FStar_Compiler_Util.smap_create (Prims.of_int (17)) in - FStar_Compiler_List.iter - (fun uu___3 -> - match uu___3 with - | (i, s) -> - let uu___4 = FStar_Syntax_Util.lid_of_sigelt s in - (match uu___4 with - | FStar_Pervasives_Native.None -> - failwith "Unexpected: tactic without a name" - | FStar_Pervasives_Native.Some l -> - let lstr = FStar_Ident.string_of_lid l in - let uu___5 = - FStar_Compiler_Util.smap_try_find map lstr in - (match uu___5 with - | FStar_Pervasives_Native.None -> - FStar_Compiler_Util.smap_add map lstr - ([i], s) - | FStar_Pervasives_Native.Some (is1, s1) -> - (FStar_Compiler_Util.smap_remove map lstr; - FStar_Compiler_Util.smap_add map lstr - ((i :: is1), s1))))) is; - FStar_Compiler_Util.smap_fold map - (fun uu___3 -> fun is1 -> fun out -> is1 :: out) [] in - let buckets = bucketize (FStar_Compiler_List.op_At eqs more) in - (FStar_Compiler_List.iter - (fun uu___3 -> - match uu___3 with - | (imps1, sigel) -> solve_goals_with_tac env g imps1 sigel) - buckets; - (let uu___3 = - FStar_Class_Listlike.from_list - (FStar_Compiler_CList.listlike_clist ()) imps in - { - FStar_TypeChecker_Common.guard_f = - (g.FStar_TypeChecker_Common.guard_f); - FStar_TypeChecker_Common.deferred_to_tac = - (Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic (FStar_Compiler_CList.listlike_clist ())))); - FStar_TypeChecker_Common.deferred = - (g.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (g.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = uu___3 - }))) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Env.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Env.ml deleted file mode 100644 index bf7fc3c97e0..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Env.ml +++ /dev/null @@ -1,7438 +0,0 @@ -open Prims -type step = - | Beta - | Iota - | Zeta - | ZetaFull - | Exclude of step - | Weak - | HNF - | Primops - | Eager_unfolding - | Inlining - | DoNotUnfoldPureLets - | UnfoldUntil of FStar_Syntax_Syntax.delta_depth - | UnfoldOnly of FStar_Ident.lid Prims.list - | UnfoldFully of FStar_Ident.lid Prims.list - | UnfoldAttr of FStar_Ident.lid Prims.list - | UnfoldQual of Prims.string Prims.list - | UnfoldNamespace of Prims.string Prims.list - | DontUnfoldAttr of FStar_Ident.lid Prims.list - | PureSubtermsWithinComputations - | Simplify - | EraseUniverses - | AllowUnboundUniverses - | Reify - | CompressUvars - | NoFullNorm - | CheckNoUvars - | Unmeta - | Unascribe - | NBE - | ForExtraction - | Unrefine - | NormDebug - | DefaultUnivsToZero - | Tactics -let (uu___is_Beta : step -> Prims.bool) = - fun projectee -> match projectee with | Beta -> true | uu___ -> false -let (uu___is_Iota : step -> Prims.bool) = - fun projectee -> match projectee with | Iota -> true | uu___ -> false -let (uu___is_Zeta : step -> Prims.bool) = - fun projectee -> match projectee with | Zeta -> true | uu___ -> false -let (uu___is_ZetaFull : step -> Prims.bool) = - fun projectee -> match projectee with | ZetaFull -> true | uu___ -> false -let (uu___is_Exclude : step -> Prims.bool) = - fun projectee -> match projectee with | Exclude _0 -> true | uu___ -> false -let (__proj__Exclude__item___0 : step -> step) = - fun projectee -> match projectee with | Exclude _0 -> _0 -let (uu___is_Weak : step -> Prims.bool) = - fun projectee -> match projectee with | Weak -> true | uu___ -> false -let (uu___is_HNF : step -> Prims.bool) = - fun projectee -> match projectee with | HNF -> true | uu___ -> false -let (uu___is_Primops : step -> Prims.bool) = - fun projectee -> match projectee with | Primops -> true | uu___ -> false -let (uu___is_Eager_unfolding : step -> Prims.bool) = - fun projectee -> - match projectee with | Eager_unfolding -> true | uu___ -> false -let (uu___is_Inlining : step -> Prims.bool) = - fun projectee -> match projectee with | Inlining -> true | uu___ -> false -let (uu___is_DoNotUnfoldPureLets : step -> Prims.bool) = - fun projectee -> - match projectee with | DoNotUnfoldPureLets -> true | uu___ -> false -let (uu___is_UnfoldUntil : step -> Prims.bool) = - fun projectee -> - match projectee with | UnfoldUntil _0 -> true | uu___ -> false -let (__proj__UnfoldUntil__item___0 : step -> FStar_Syntax_Syntax.delta_depth) - = fun projectee -> match projectee with | UnfoldUntil _0 -> _0 -let (uu___is_UnfoldOnly : step -> Prims.bool) = - fun projectee -> - match projectee with | UnfoldOnly _0 -> true | uu___ -> false -let (__proj__UnfoldOnly__item___0 : step -> FStar_Ident.lid Prims.list) = - fun projectee -> match projectee with | UnfoldOnly _0 -> _0 -let (uu___is_UnfoldFully : step -> Prims.bool) = - fun projectee -> - match projectee with | UnfoldFully _0 -> true | uu___ -> false -let (__proj__UnfoldFully__item___0 : step -> FStar_Ident.lid Prims.list) = - fun projectee -> match projectee with | UnfoldFully _0 -> _0 -let (uu___is_UnfoldAttr : step -> Prims.bool) = - fun projectee -> - match projectee with | UnfoldAttr _0 -> true | uu___ -> false -let (__proj__UnfoldAttr__item___0 : step -> FStar_Ident.lid Prims.list) = - fun projectee -> match projectee with | UnfoldAttr _0 -> _0 -let (uu___is_UnfoldQual : step -> Prims.bool) = - fun projectee -> - match projectee with | UnfoldQual _0 -> true | uu___ -> false -let (__proj__UnfoldQual__item___0 : step -> Prims.string Prims.list) = - fun projectee -> match projectee with | UnfoldQual _0 -> _0 -let (uu___is_UnfoldNamespace : step -> Prims.bool) = - fun projectee -> - match projectee with | UnfoldNamespace _0 -> true | uu___ -> false -let (__proj__UnfoldNamespace__item___0 : step -> Prims.string Prims.list) = - fun projectee -> match projectee with | UnfoldNamespace _0 -> _0 -let (uu___is_DontUnfoldAttr : step -> Prims.bool) = - fun projectee -> - match projectee with | DontUnfoldAttr _0 -> true | uu___ -> false -let (__proj__DontUnfoldAttr__item___0 : step -> FStar_Ident.lid Prims.list) = - fun projectee -> match projectee with | DontUnfoldAttr _0 -> _0 -let (uu___is_PureSubtermsWithinComputations : step -> Prims.bool) = - fun projectee -> - match projectee with - | PureSubtermsWithinComputations -> true - | uu___ -> false -let (uu___is_Simplify : step -> Prims.bool) = - fun projectee -> match projectee with | Simplify -> true | uu___ -> false -let (uu___is_EraseUniverses : step -> Prims.bool) = - fun projectee -> - match projectee with | EraseUniverses -> true | uu___ -> false -let (uu___is_AllowUnboundUniverses : step -> Prims.bool) = - fun projectee -> - match projectee with | AllowUnboundUniverses -> true | uu___ -> false -let (uu___is_Reify : step -> Prims.bool) = - fun projectee -> match projectee with | Reify -> true | uu___ -> false -let (uu___is_CompressUvars : step -> Prims.bool) = - fun projectee -> - match projectee with | CompressUvars -> true | uu___ -> false -let (uu___is_NoFullNorm : step -> Prims.bool) = - fun projectee -> match projectee with | NoFullNorm -> true | uu___ -> false -let (uu___is_CheckNoUvars : step -> Prims.bool) = - fun projectee -> - match projectee with | CheckNoUvars -> true | uu___ -> false -let (uu___is_Unmeta : step -> Prims.bool) = - fun projectee -> match projectee with | Unmeta -> true | uu___ -> false -let (uu___is_Unascribe : step -> Prims.bool) = - fun projectee -> match projectee with | Unascribe -> true | uu___ -> false -let (uu___is_NBE : step -> Prims.bool) = - fun projectee -> match projectee with | NBE -> true | uu___ -> false -let (uu___is_ForExtraction : step -> Prims.bool) = - fun projectee -> - match projectee with | ForExtraction -> true | uu___ -> false -let (uu___is_Unrefine : step -> Prims.bool) = - fun projectee -> match projectee with | Unrefine -> true | uu___ -> false -let (uu___is_NormDebug : step -> Prims.bool) = - fun projectee -> match projectee with | NormDebug -> true | uu___ -> false -let (uu___is_DefaultUnivsToZero : step -> Prims.bool) = - fun projectee -> - match projectee with | DefaultUnivsToZero -> true | uu___ -> false -let (uu___is_Tactics : step -> Prims.bool) = - fun projectee -> match projectee with | Tactics -> true | uu___ -> false -type steps = step Prims.list -let (dbg_ImplicitTrace : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "ImplicitTrace" -let (dbg_LayeredEffectsEqns : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "LayeredEffectsEqns" -let rec (eq_step : step -> step -> Prims.bool) = - fun s1 -> - fun s2 -> - match (s1, s2) with - | (Beta, Beta) -> true - | (Iota, Iota) -> true - | (Zeta, Zeta) -> true - | (ZetaFull, ZetaFull) -> true - | (Weak, Weak) -> true - | (HNF, HNF) -> true - | (Primops, Primops) -> true - | (Eager_unfolding, Eager_unfolding) -> true - | (Inlining, Inlining) -> true - | (DoNotUnfoldPureLets, DoNotUnfoldPureLets) -> true - | (PureSubtermsWithinComputations, PureSubtermsWithinComputations) -> - true - | (Simplify, Simplify) -> true - | (EraseUniverses, EraseUniverses) -> true - | (AllowUnboundUniverses, AllowUnboundUniverses) -> true - | (Reify, Reify) -> true - | (CompressUvars, CompressUvars) -> true - | (NoFullNorm, NoFullNorm) -> true - | (CheckNoUvars, CheckNoUvars) -> true - | (Unmeta, Unmeta) -> true - | (Unascribe, Unascribe) -> true - | (NBE, NBE) -> true - | (Unrefine, Unrefine) -> true - | (Exclude s11, Exclude s21) -> eq_step s11 s21 - | (UnfoldUntil s11, UnfoldUntil s21) -> s11 = s21 - | (UnfoldOnly lids1, UnfoldOnly lids2) -> - FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq - (FStar_Class_Ord.ord_list FStar_Syntax_Syntax.ord_fv)) lids1 - lids2 - | (UnfoldFully lids1, UnfoldFully lids2) -> - FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq - (FStar_Class_Ord.ord_list FStar_Syntax_Syntax.ord_fv)) lids1 - lids2 - | (UnfoldAttr lids1, UnfoldAttr lids2) -> - FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq - (FStar_Class_Ord.ord_list FStar_Syntax_Syntax.ord_fv)) lids1 - lids2 - | (UnfoldQual strs1, UnfoldQual strs2) -> - FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq - (FStar_Class_Ord.ord_list FStar_Class_Ord.ord_string)) strs1 - strs2 - | (UnfoldNamespace strs1, UnfoldNamespace strs2) -> - FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq - (FStar_Class_Ord.ord_list FStar_Class_Ord.ord_string)) strs1 - strs2 - | (DontUnfoldAttr lids1, DontUnfoldAttr lids2) -> - FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq - (FStar_Class_Ord.ord_list FStar_Syntax_Syntax.ord_fv)) lids1 - lids2 - | uu___ -> false -let (deq_step : step FStar_Class_Deq.deq) = - { FStar_Class_Deq.op_Equals_Question = eq_step } -let rec (step_to_string : step -> Prims.string) = - fun s -> - match s with - | Beta -> "Beta" - | Iota -> "Iota" - | Zeta -> "Zeta" - | ZetaFull -> "ZetaFull" - | Exclude s1 -> - let uu___ = step_to_string s1 in Prims.strcat "Exclude " uu___ - | Weak -> "Weak" - | HNF -> "HNF" - | Primops -> "Primops" - | Eager_unfolding -> "Eager_unfolding" - | Inlining -> "Inlining" - | DoNotUnfoldPureLets -> "DoNotUnfoldPureLets" - | UnfoldUntil s1 -> - let uu___ = - FStar_Class_Show.show FStar_Syntax_Syntax.showable_delta_depth s1 in - Prims.strcat "UnfoldUntil " uu___ - | UnfoldOnly lids1 -> - let uu___ = - FStar_Class_Show.show - (FStar_Class_Show.show_list FStar_Ident.showable_lident) lids1 in - Prims.strcat "UnfoldOnly " uu___ - | UnfoldFully lids1 -> - let uu___ = - FStar_Class_Show.show - (FStar_Class_Show.show_list FStar_Ident.showable_lident) lids1 in - Prims.strcat "UnfoldFully " uu___ - | UnfoldAttr lids1 -> - let uu___ = - FStar_Class_Show.show - (FStar_Class_Show.show_list FStar_Ident.showable_lident) lids1 in - Prims.strcat "UnfoldAttr " uu___ - | UnfoldQual strs1 -> - let uu___ = - FStar_Class_Show.show - (FStar_Class_Show.show_list - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_string)) strs1 in - Prims.strcat "UnfoldQual " uu___ - | UnfoldNamespace strs1 -> - let uu___ = - FStar_Class_Show.show - (FStar_Class_Show.show_list - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_string)) strs1 in - Prims.strcat "UnfoldNamespace " uu___ - | DontUnfoldAttr lids1 -> - let uu___ = - FStar_Class_Show.show - (FStar_Class_Show.show_list FStar_Ident.showable_lident) lids1 in - Prims.strcat "DontUnfoldAttr " uu___ - | PureSubtermsWithinComputations -> "PureSubtermsWithinComputations" - | Simplify -> "Simplify" - | EraseUniverses -> "EraseUniverses" - | AllowUnboundUniverses -> "AllowUnboundUniverses" - | Reify -> "Reify" - | CompressUvars -> "CompressUvars" - | NoFullNorm -> "NoFullNorm" - | CheckNoUvars -> "CheckNoUvars" - | Unmeta -> "Unmeta" - | Unascribe -> "Unascribe" - | NBE -> "NBE" - | ForExtraction -> "ForExtraction" - | Unrefine -> "Unrefine" - | NormDebug -> "NormDebug" - | DefaultUnivsToZero -> "DefaultUnivsToZero" - | Tactics -> "Tactics" -let (showable_step : step FStar_Class_Show.showable) = - { FStar_Class_Show.show = step_to_string } -type sig_binding = - (FStar_Ident.lident Prims.list * FStar_Syntax_Syntax.sigelt) -type delta_level = - | NoDelta - | InliningDelta - | Eager_unfolding_only - | Unfold of FStar_Syntax_Syntax.delta_depth -let (uu___is_NoDelta : delta_level -> Prims.bool) = - fun projectee -> match projectee with | NoDelta -> true | uu___ -> false -let (uu___is_InliningDelta : delta_level -> Prims.bool) = - fun projectee -> - match projectee with | InliningDelta -> true | uu___ -> false -let (uu___is_Eager_unfolding_only : delta_level -> Prims.bool) = - fun projectee -> - match projectee with | Eager_unfolding_only -> true | uu___ -> false -let (uu___is_Unfold : delta_level -> Prims.bool) = - fun projectee -> match projectee with | Unfold _0 -> true | uu___ -> false -let (__proj__Unfold__item___0 : - delta_level -> FStar_Syntax_Syntax.delta_depth) = - fun projectee -> match projectee with | Unfold _0 -> _0 -let (deq_delta_level : delta_level FStar_Class_Deq.deq) = - { - FStar_Class_Deq.op_Equals_Question = - (fun x -> - fun y -> - match (x, y) with - | (NoDelta, NoDelta) -> true - | (InliningDelta, InliningDelta) -> true - | (Eager_unfolding_only, Eager_unfolding_only) -> true - | (Unfold x1, Unfold y1) -> - FStar_Class_Deq.op_Equals_Question - FStar_Syntax_Syntax.deq_delta_depth x1 y1 - | uu___ -> false) - } -let (showable_delta_level : delta_level FStar_Class_Show.showable) = - { - FStar_Class_Show.show = - (fun uu___ -> - match uu___ with - | NoDelta -> "NoDelta" - | InliningDelta -> "Inlining" - | Eager_unfolding_only -> "Eager_unfolding_only" - | Unfold d -> - let uu___1 = - FStar_Class_Show.show FStar_Syntax_Syntax.showable_delta_depth - d in - Prims.strcat "Unfold " uu___1) - } -type name_prefix = FStar_Ident.path -type proof_namespace = (name_prefix * Prims.bool) Prims.list -type cached_elt = - (((FStar_Syntax_Syntax.universes * FStar_Syntax_Syntax.typ), - (FStar_Syntax_Syntax.sigelt * FStar_Syntax_Syntax.universes - FStar_Pervasives_Native.option)) - FStar_Pervasives.either * FStar_Compiler_Range_Type.range) -type goal = FStar_Syntax_Syntax.term -type must_tot = Prims.bool -type mlift = - { - mlift_wp: - env -> - FStar_Syntax_Syntax.comp -> - (FStar_Syntax_Syntax.comp * FStar_TypeChecker_Common.guard_t) - ; - mlift_term: - (FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - FStar_Pervasives_Native.option - } -and edge = - { - msource: FStar_Ident.lident ; - mtarget: FStar_Ident.lident ; - mlift: mlift ; - mpath: FStar_Ident.lident Prims.list } -and effects = - { - decls: - (FStar_Syntax_Syntax.eff_decl * FStar_Syntax_Syntax.qualifier Prims.list) - Prims.list - ; - order: edge Prims.list ; - joins: - (FStar_Ident.lident * FStar_Ident.lident * FStar_Ident.lident * mlift * - mlift) Prims.list - ; - polymonadic_binds: - (FStar_Ident.lident * FStar_Ident.lident * FStar_Ident.lident * - (env -> - FStar_Syntax_Syntax.comp_typ -> - FStar_Syntax_Syntax.bv FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.comp_typ -> - FStar_Syntax_Syntax.cflag Prims.list -> - FStar_Compiler_Range_Type.range -> - (FStar_Syntax_Syntax.comp * - FStar_TypeChecker_Common.guard_t))) - Prims.list - ; - polymonadic_subcomps: - (FStar_Ident.lident * FStar_Ident.lident * FStar_Syntax_Syntax.tscheme * - FStar_Syntax_Syntax.indexed_effect_combinator_kind) Prims.list - } -and env = - { - solver: solver_t ; - range: FStar_Compiler_Range_Type.range ; - curmodule: FStar_Ident.lident ; - gamma: FStar_Syntax_Syntax.binding Prims.list ; - gamma_sig: sig_binding Prims.list ; - gamma_cache: cached_elt FStar_Compiler_Util.smap ; - modules: FStar_Syntax_Syntax.modul Prims.list ; - expected_typ: - (FStar_Syntax_Syntax.typ * Prims.bool) FStar_Pervasives_Native.option ; - sigtab: FStar_Syntax_Syntax.sigelt FStar_Compiler_Util.smap ; - attrtab: FStar_Syntax_Syntax.sigelt Prims.list FStar_Compiler_Util.smap ; - instantiate_imp: Prims.bool ; - effects: effects ; - generalize: Prims.bool ; - letrecs: - (FStar_Syntax_Syntax.lbname * Prims.int * FStar_Syntax_Syntax.typ * - FStar_Syntax_Syntax.univ_names) Prims.list - ; - top_level: Prims.bool ; - check_uvars: Prims.bool ; - use_eq_strict: Prims.bool ; - is_iface: Prims.bool ; - admit: Prims.bool ; - lax_universes: Prims.bool ; - phase1: Prims.bool ; - failhard: Prims.bool ; - flychecking: Prims.bool ; - uvar_subtyping: Prims.bool ; - intactics: Prims.bool ; - nocoerce: Prims.bool ; - tc_term: - env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.lcomp * - FStar_TypeChecker_Common.guard_t) - ; - typeof_tot_or_gtot_term: - env -> - FStar_Syntax_Syntax.term -> - must_tot -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.typ * - FStar_TypeChecker_Common.guard_t) - ; - universe_of: - env -> FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.universe ; - typeof_well_typed_tot_or_gtot_term: - env -> - FStar_Syntax_Syntax.term -> - must_tot -> - (FStar_Syntax_Syntax.typ * FStar_TypeChecker_Common.guard_t) - ; - teq_nosmt_force: - env -> FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term -> Prims.bool ; - subtype_nosmt_force: - env -> FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term -> Prims.bool ; - qtbl_name_and_index: - ((FStar_Ident.lident * FStar_Syntax_Syntax.typ * Prims.int) - FStar_Pervasives_Native.option * Prims.int FStar_Compiler_Util.smap) - ; - normalized_eff_names: FStar_Ident.lident FStar_Compiler_Util.smap ; - fv_delta_depths: FStar_Syntax_Syntax.delta_depth FStar_Compiler_Util.smap ; - proof_ns: proof_namespace ; - synth_hook: - env -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term - ; - try_solve_implicits_hook: - env -> - FStar_Syntax_Syntax.term -> FStar_TypeChecker_Common.implicits -> unit - ; - splice: - env -> - Prims.bool -> - FStar_Ident.lident Prims.list -> - FStar_Syntax_Syntax.term -> - FStar_Compiler_Range_Type.range -> - FStar_Syntax_Syntax.sigelt Prims.list - ; - mpreprocess: - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term - ; - postprocess: - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term - ; - identifier_info: - FStar_TypeChecker_Common.id_info_table FStar_Compiler_Effect.ref ; - tc_hooks: tcenv_hooks ; - dsenv: FStar_Syntax_DsEnv.env ; - nbe: - step Prims.list -> - env -> FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term - ; - strict_args_tab: - Prims.int Prims.list FStar_Pervasives_Native.option - FStar_Compiler_Util.smap - ; - erasable_types_tab: Prims.bool FStar_Compiler_Util.smap ; - enable_defer_to_tac: Prims.bool ; - unif_allow_ref_guards: Prims.bool ; - erase_erasable_args: Prims.bool ; - core_check: - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.typ -> - Prims.bool -> - (FStar_Syntax_Syntax.typ FStar_Pervasives_Native.option, - Prims.bool -> Prims.string) FStar_Pervasives.either - ; - missing_decl: FStar_Ident.lident FStar_Compiler_RBSet.t } -and solver_t = - { - init: env -> unit ; - snapshot: Prims.string -> ((Prims.int * Prims.int * Prims.int) * unit) ; - rollback: - Prims.string -> - (Prims.int * Prims.int * Prims.int) FStar_Pervasives_Native.option -> - unit - ; - encode_sig: env -> FStar_Syntax_Syntax.sigelt -> unit ; - preprocess: - env -> - goal -> - (Prims.bool * (env * goal * FStar_Options.optionstate) Prims.list) - ; - spinoff_strictly_positive_goals: - (env -> goal -> (env * goal) Prims.list) FStar_Pervasives_Native.option ; - handle_smt_goal: env -> goal -> (env * goal) Prims.list ; - solve: - (unit -> Prims.string) FStar_Pervasives_Native.option -> - env -> goal -> unit - ; - solve_sync: - (unit -> Prims.string) FStar_Pervasives_Native.option -> - env -> goal -> Prims.bool - ; - finish: unit -> unit ; - refresh: proof_namespace FStar_Pervasives_Native.option -> unit } -and tcenv_hooks = - { - tc_push_in_gamma_hook: - env -> - (FStar_Syntax_Syntax.binding, sig_binding) FStar_Pervasives.either -> - unit - } -let (__proj__Mkmlift__item__mlift_wp : - mlift -> - env -> - FStar_Syntax_Syntax.comp -> - (FStar_Syntax_Syntax.comp * FStar_TypeChecker_Common.guard_t)) - = - fun projectee -> - match projectee with | { mlift_wp; mlift_term;_} -> mlift_wp -let (__proj__Mkmlift__item__mlift_term : - mlift -> - (FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - FStar_Pervasives_Native.option) - = - fun projectee -> - match projectee with | { mlift_wp; mlift_term;_} -> mlift_term -let (__proj__Mkedge__item__msource : edge -> FStar_Ident.lident) = - fun projectee -> - match projectee with - | { msource; mtarget; mlift = mlift1; mpath;_} -> msource -let (__proj__Mkedge__item__mtarget : edge -> FStar_Ident.lident) = - fun projectee -> - match projectee with - | { msource; mtarget; mlift = mlift1; mpath;_} -> mtarget -let (__proj__Mkedge__item__mlift : edge -> mlift) = - fun projectee -> - match projectee with - | { msource; mtarget; mlift = mlift1; mpath;_} -> mlift1 -let (__proj__Mkedge__item__mpath : edge -> FStar_Ident.lident Prims.list) = - fun projectee -> - match projectee with - | { msource; mtarget; mlift = mlift1; mpath;_} -> mpath -let (__proj__Mkeffects__item__decls : - effects -> - (FStar_Syntax_Syntax.eff_decl * FStar_Syntax_Syntax.qualifier Prims.list) - Prims.list) - = - fun projectee -> - match projectee with - | { decls; order; joins; polymonadic_binds; polymonadic_subcomps;_} -> - decls -let (__proj__Mkeffects__item__order : effects -> edge Prims.list) = - fun projectee -> - match projectee with - | { decls; order; joins; polymonadic_binds; polymonadic_subcomps;_} -> - order -let (__proj__Mkeffects__item__joins : - effects -> - (FStar_Ident.lident * FStar_Ident.lident * FStar_Ident.lident * mlift * - mlift) Prims.list) - = - fun projectee -> - match projectee with - | { decls; order; joins; polymonadic_binds; polymonadic_subcomps;_} -> - joins -let (__proj__Mkeffects__item__polymonadic_binds : - effects -> - (FStar_Ident.lident * FStar_Ident.lident * FStar_Ident.lident * - (env -> - FStar_Syntax_Syntax.comp_typ -> - FStar_Syntax_Syntax.bv FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.comp_typ -> - FStar_Syntax_Syntax.cflag Prims.list -> - FStar_Compiler_Range_Type.range -> - (FStar_Syntax_Syntax.comp * - FStar_TypeChecker_Common.guard_t))) - Prims.list) - = - fun projectee -> - match projectee with - | { decls; order; joins; polymonadic_binds; polymonadic_subcomps;_} -> - polymonadic_binds -let (__proj__Mkeffects__item__polymonadic_subcomps : - effects -> - (FStar_Ident.lident * FStar_Ident.lident * FStar_Syntax_Syntax.tscheme * - FStar_Syntax_Syntax.indexed_effect_combinator_kind) Prims.list) - = - fun projectee -> - match projectee with - | { decls; order; joins; polymonadic_binds; polymonadic_subcomps;_} -> - polymonadic_subcomps -let (__proj__Mkenv__item__solver : env -> solver_t) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> solver -let (__proj__Mkenv__item__range : env -> FStar_Compiler_Range_Type.range) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> range -let (__proj__Mkenv__item__curmodule : env -> FStar_Ident.lident) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> curmodule -let (__proj__Mkenv__item__gamma : - env -> FStar_Syntax_Syntax.binding Prims.list) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> gamma -let (__proj__Mkenv__item__gamma_sig : env -> sig_binding Prims.list) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> gamma_sig -let (__proj__Mkenv__item__gamma_cache : - env -> cached_elt FStar_Compiler_Util.smap) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> gamma_cache -let (__proj__Mkenv__item__modules : - env -> FStar_Syntax_Syntax.modul Prims.list) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> modules -let (__proj__Mkenv__item__expected_typ : - env -> - (FStar_Syntax_Syntax.typ * Prims.bool) FStar_Pervasives_Native.option) - = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> expected_typ -let (__proj__Mkenv__item__sigtab : - env -> FStar_Syntax_Syntax.sigelt FStar_Compiler_Util.smap) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> sigtab -let (__proj__Mkenv__item__attrtab : - env -> FStar_Syntax_Syntax.sigelt Prims.list FStar_Compiler_Util.smap) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> attrtab -let (__proj__Mkenv__item__instantiate_imp : env -> Prims.bool) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> instantiate_imp -let (__proj__Mkenv__item__effects : env -> effects) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> effects1 -let (__proj__Mkenv__item__generalize : env -> Prims.bool) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> generalize -let (__proj__Mkenv__item__letrecs : - env -> - (FStar_Syntax_Syntax.lbname * Prims.int * FStar_Syntax_Syntax.typ * - FStar_Syntax_Syntax.univ_names) Prims.list) - = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> letrecs -let (__proj__Mkenv__item__top_level : env -> Prims.bool) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> top_level -let (__proj__Mkenv__item__check_uvars : env -> Prims.bool) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> check_uvars -let (__proj__Mkenv__item__use_eq_strict : env -> Prims.bool) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> use_eq_strict -let (__proj__Mkenv__item__is_iface : env -> Prims.bool) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> is_iface -let (__proj__Mkenv__item__admit : env -> Prims.bool) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> admit -let (__proj__Mkenv__item__lax_universes : env -> Prims.bool) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> lax_universes -let (__proj__Mkenv__item__phase1 : env -> Prims.bool) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> phase1 -let (__proj__Mkenv__item__failhard : env -> Prims.bool) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> failhard -let (__proj__Mkenv__item__flychecking : env -> Prims.bool) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> flychecking -let (__proj__Mkenv__item__uvar_subtyping : env -> Prims.bool) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> uvar_subtyping -let (__proj__Mkenv__item__intactics : env -> Prims.bool) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> intactics -let (__proj__Mkenv__item__nocoerce : env -> Prims.bool) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> nocoerce -let (__proj__Mkenv__item__tc_term : - env -> - env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.lcomp * - FStar_TypeChecker_Common.guard_t)) - = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> tc_term -let (__proj__Mkenv__item__typeof_tot_or_gtot_term : - env -> - env -> - FStar_Syntax_Syntax.term -> - must_tot -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.typ * - FStar_TypeChecker_Common.guard_t)) - = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> typeof_tot_or_gtot_term -let (__proj__Mkenv__item__universe_of : - env -> env -> FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.universe) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> universe_of -let (__proj__Mkenv__item__typeof_well_typed_tot_or_gtot_term : - env -> - env -> - FStar_Syntax_Syntax.term -> - must_tot -> - (FStar_Syntax_Syntax.typ * FStar_TypeChecker_Common.guard_t)) - = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> typeof_well_typed_tot_or_gtot_term -let (__proj__Mkenv__item__teq_nosmt_force : - env -> - env -> FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term -> Prims.bool) - = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> teq_nosmt_force -let (__proj__Mkenv__item__subtype_nosmt_force : - env -> - env -> FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term -> Prims.bool) - = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> subtype_nosmt_force -let (__proj__Mkenv__item__qtbl_name_and_index : - env -> - ((FStar_Ident.lident * FStar_Syntax_Syntax.typ * Prims.int) - FStar_Pervasives_Native.option * Prims.int FStar_Compiler_Util.smap)) - = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> qtbl_name_and_index -let (__proj__Mkenv__item__normalized_eff_names : - env -> FStar_Ident.lident FStar_Compiler_Util.smap) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> normalized_eff_names -let (__proj__Mkenv__item__fv_delta_depths : - env -> FStar_Syntax_Syntax.delta_depth FStar_Compiler_Util.smap) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> fv_delta_depths -let (__proj__Mkenv__item__proof_ns : env -> proof_namespace) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> proof_ns -let (__proj__Mkenv__item__synth_hook : - env -> - env -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> synth_hook -let (__proj__Mkenv__item__try_solve_implicits_hook : - env -> - env -> - FStar_Syntax_Syntax.term -> FStar_TypeChecker_Common.implicits -> unit) - = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> try_solve_implicits_hook -let (__proj__Mkenv__item__splice : - env -> - env -> - Prims.bool -> - FStar_Ident.lident Prims.list -> - FStar_Syntax_Syntax.term -> - FStar_Compiler_Range_Type.range -> - FStar_Syntax_Syntax.sigelt Prims.list) - = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> splice -let (__proj__Mkenv__item__mpreprocess : - env -> - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> mpreprocess -let (__proj__Mkenv__item__postprocess : - env -> - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> postprocess -let (__proj__Mkenv__item__identifier_info : - env -> FStar_TypeChecker_Common.id_info_table FStar_Compiler_Effect.ref) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> identifier_info -let (__proj__Mkenv__item__tc_hooks : env -> tcenv_hooks) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> tc_hooks -let (__proj__Mkenv__item__dsenv : env -> FStar_Syntax_DsEnv.env) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> dsenv -let (__proj__Mkenv__item__nbe : - env -> - step Prims.list -> - env -> FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> nbe -let (__proj__Mkenv__item__strict_args_tab : - env -> - Prims.int Prims.list FStar_Pervasives_Native.option - FStar_Compiler_Util.smap) - = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> strict_args_tab -let (__proj__Mkenv__item__erasable_types_tab : - env -> Prims.bool FStar_Compiler_Util.smap) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> erasable_types_tab -let (__proj__Mkenv__item__enable_defer_to_tac : env -> Prims.bool) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> enable_defer_to_tac -let (__proj__Mkenv__item__unif_allow_ref_guards : env -> Prims.bool) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> unif_allow_ref_guards -let (__proj__Mkenv__item__erase_erasable_args : env -> Prims.bool) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> erase_erasable_args -let (__proj__Mkenv__item__core_check : - env -> - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.typ -> - Prims.bool -> - (FStar_Syntax_Syntax.typ FStar_Pervasives_Native.option, - Prims.bool -> Prims.string) FStar_Pervasives.either) - = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> core_check -let (__proj__Mkenv__item__missing_decl : - env -> FStar_Ident.lident FStar_Compiler_RBSet.t) = - fun projectee -> - match projectee with - | { solver; range; curmodule; gamma; gamma_sig; gamma_cache; modules; - expected_typ; sigtab; attrtab; instantiate_imp; effects = effects1; - generalize; letrecs; top_level; check_uvars; use_eq_strict; is_iface; - admit; lax_universes; phase1; failhard; flychecking; uvar_subtyping; - intactics; nocoerce; tc_term; typeof_tot_or_gtot_term; universe_of; - typeof_well_typed_tot_or_gtot_term; teq_nosmt_force; - subtype_nosmt_force; qtbl_name_and_index; normalized_eff_names; - fv_delta_depths; proof_ns; synth_hook; try_solve_implicits_hook; - splice; mpreprocess; postprocess; identifier_info; tc_hooks; - dsenv; nbe; strict_args_tab; erasable_types_tab; enable_defer_to_tac; - unif_allow_ref_guards; erase_erasable_args; core_check; - missing_decl;_} -> missing_decl -let (__proj__Mksolver_t__item__init : solver_t -> env -> unit) = - fun projectee -> - match projectee with - | { init; snapshot; rollback; encode_sig; preprocess; - spinoff_strictly_positive_goals; handle_smt_goal; solve; solve_sync; - finish; refresh;_} -> init -let (__proj__Mksolver_t__item__snapshot : - solver_t -> Prims.string -> ((Prims.int * Prims.int * Prims.int) * unit)) = - fun projectee -> - match projectee with - | { init; snapshot; rollback; encode_sig; preprocess; - spinoff_strictly_positive_goals; handle_smt_goal; solve; solve_sync; - finish; refresh;_} -> snapshot -let (__proj__Mksolver_t__item__rollback : - solver_t -> - Prims.string -> - (Prims.int * Prims.int * Prims.int) FStar_Pervasives_Native.option -> - unit) - = - fun projectee -> - match projectee with - | { init; snapshot; rollback; encode_sig; preprocess; - spinoff_strictly_positive_goals; handle_smt_goal; solve; solve_sync; - finish; refresh;_} -> rollback -let (__proj__Mksolver_t__item__encode_sig : - solver_t -> env -> FStar_Syntax_Syntax.sigelt -> unit) = - fun projectee -> - match projectee with - | { init; snapshot; rollback; encode_sig; preprocess; - spinoff_strictly_positive_goals; handle_smt_goal; solve; solve_sync; - finish; refresh;_} -> encode_sig -let (__proj__Mksolver_t__item__preprocess : - solver_t -> - env -> - goal -> - (Prims.bool * (env * goal * FStar_Options.optionstate) Prims.list)) - = - fun projectee -> - match projectee with - | { init; snapshot; rollback; encode_sig; preprocess; - spinoff_strictly_positive_goals; handle_smt_goal; solve; solve_sync; - finish; refresh;_} -> preprocess -let (__proj__Mksolver_t__item__spinoff_strictly_positive_goals : - solver_t -> - (env -> goal -> (env * goal) Prims.list) FStar_Pervasives_Native.option) - = - fun projectee -> - match projectee with - | { init; snapshot; rollback; encode_sig; preprocess; - spinoff_strictly_positive_goals; handle_smt_goal; solve; solve_sync; - finish; refresh;_} -> spinoff_strictly_positive_goals -let (__proj__Mksolver_t__item__handle_smt_goal : - solver_t -> env -> goal -> (env * goal) Prims.list) = - fun projectee -> - match projectee with - | { init; snapshot; rollback; encode_sig; preprocess; - spinoff_strictly_positive_goals; handle_smt_goal; solve; solve_sync; - finish; refresh;_} -> handle_smt_goal -let (__proj__Mksolver_t__item__solve : - solver_t -> - (unit -> Prims.string) FStar_Pervasives_Native.option -> - env -> goal -> unit) - = - fun projectee -> - match projectee with - | { init; snapshot; rollback; encode_sig; preprocess; - spinoff_strictly_positive_goals; handle_smt_goal; solve; solve_sync; - finish; refresh;_} -> solve -let (__proj__Mksolver_t__item__solve_sync : - solver_t -> - (unit -> Prims.string) FStar_Pervasives_Native.option -> - env -> goal -> Prims.bool) - = - fun projectee -> - match projectee with - | { init; snapshot; rollback; encode_sig; preprocess; - spinoff_strictly_positive_goals; handle_smt_goal; solve; solve_sync; - finish; refresh;_} -> solve_sync -let (__proj__Mksolver_t__item__finish : solver_t -> unit -> unit) = - fun projectee -> - match projectee with - | { init; snapshot; rollback; encode_sig; preprocess; - spinoff_strictly_positive_goals; handle_smt_goal; solve; solve_sync; - finish; refresh;_} -> finish -let (__proj__Mksolver_t__item__refresh : - solver_t -> proof_namespace FStar_Pervasives_Native.option -> unit) = - fun projectee -> - match projectee with - | { init; snapshot; rollback; encode_sig; preprocess; - spinoff_strictly_positive_goals; handle_smt_goal; solve; solve_sync; - finish; refresh;_} -> refresh -let (__proj__Mktcenv_hooks__item__tc_push_in_gamma_hook : - tcenv_hooks -> - env -> - (FStar_Syntax_Syntax.binding, sig_binding) FStar_Pervasives.either -> - unit) - = - fun projectee -> - match projectee with - | { tc_push_in_gamma_hook;_} -> tc_push_in_gamma_hook -type lift_comp_t = - env -> - FStar_Syntax_Syntax.comp -> - (FStar_Syntax_Syntax.comp * FStar_TypeChecker_Common.guard_t) -type polymonadic_bind_t = - env -> - FStar_Syntax_Syntax.comp_typ -> - FStar_Syntax_Syntax.bv FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.comp_typ -> - FStar_Syntax_Syntax.cflag Prims.list -> - FStar_Compiler_Range_Type.range -> - (FStar_Syntax_Syntax.comp * FStar_TypeChecker_Common.guard_t) -type solver_depth_t = (Prims.int * Prims.int * Prims.int) -type core_check_t = - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.typ -> - Prims.bool -> - (FStar_Syntax_Syntax.typ FStar_Pervasives_Native.option, - Prims.bool -> Prims.string) FStar_Pervasives.either -let (preprocess : - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = fun env1 -> fun tau -> fun tm -> env1.mpreprocess env1 tau tm -let (postprocess : - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun env1 -> fun tau -> fun ty -> fun tm -> env1.postprocess env1 tau ty tm -let (rename_gamma : - FStar_Syntax_Syntax.subst_t -> - FStar_Syntax_Syntax.gamma -> FStar_Syntax_Syntax.gamma) - = - fun subst -> - fun gamma -> - FStar_Compiler_List.map - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.Binding_var x -> - let y = - let uu___1 = FStar_Syntax_Syntax.bv_to_name x in - FStar_Syntax_Subst.subst subst uu___1 in - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress y in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_name y1 -> - let uu___2 = - let uu___3 = - FStar_Syntax_Subst.subst subst - x.FStar_Syntax_Syntax.sort in - { - FStar_Syntax_Syntax.ppname = - (y1.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (y1.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = uu___3 - } in - FStar_Syntax_Syntax.Binding_var uu___2 - | uu___2 -> failwith "Not a renaming") - | b -> b) gamma -let (rename_env : FStar_Syntax_Syntax.subst_t -> env -> env) = - fun subst -> - fun env1 -> - let uu___ = rename_gamma subst env1.gamma in - { - solver = (env1.solver); - range = (env1.range); - curmodule = (env1.curmodule); - gamma = uu___; - gamma_sig = (env1.gamma_sig); - gamma_cache = (env1.gamma_cache); - modules = (env1.modules); - expected_typ = (env1.expected_typ); - sigtab = (env1.sigtab); - attrtab = (env1.attrtab); - instantiate_imp = (env1.instantiate_imp); - effects = (env1.effects); - generalize = (env1.generalize); - letrecs = (env1.letrecs); - top_level = (env1.top_level); - check_uvars = (env1.check_uvars); - use_eq_strict = (env1.use_eq_strict); - is_iface = (env1.is_iface); - admit = (env1.admit); - lax_universes = (env1.lax_universes); - phase1 = (env1.phase1); - failhard = (env1.failhard); - flychecking = (env1.flychecking); - uvar_subtyping = (env1.uvar_subtyping); - intactics = (env1.intactics); - nocoerce = (env1.nocoerce); - tc_term = (env1.tc_term); - typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); - universe_of = (env1.universe_of); - typeof_well_typed_tot_or_gtot_term = - (env1.typeof_well_typed_tot_or_gtot_term); - teq_nosmt_force = (env1.teq_nosmt_force); - subtype_nosmt_force = (env1.subtype_nosmt_force); - qtbl_name_and_index = (env1.qtbl_name_and_index); - normalized_eff_names = (env1.normalized_eff_names); - fv_delta_depths = (env1.fv_delta_depths); - proof_ns = (env1.proof_ns); - synth_hook = (env1.synth_hook); - try_solve_implicits_hook = (env1.try_solve_implicits_hook); - splice = (env1.splice); - mpreprocess = (env1.mpreprocess); - postprocess = (env1.postprocess); - identifier_info = (env1.identifier_info); - tc_hooks = (env1.tc_hooks); - dsenv = (env1.dsenv); - nbe = (env1.nbe); - strict_args_tab = (env1.strict_args_tab); - erasable_types_tab = (env1.erasable_types_tab); - enable_defer_to_tac = (env1.enable_defer_to_tac); - unif_allow_ref_guards = (env1.unif_allow_ref_guards); - erase_erasable_args = (env1.erase_erasable_args); - core_check = (env1.core_check); - missing_decl = (env1.missing_decl) - } -let (default_tc_hooks : tcenv_hooks) = - { tc_push_in_gamma_hook = (fun uu___ -> fun uu___1 -> ()) } -let (tc_hooks : env -> tcenv_hooks) = fun env1 -> env1.tc_hooks -let (set_tc_hooks : env -> tcenv_hooks -> env) = - fun env1 -> - fun hooks -> - { - solver = (env1.solver); - range = (env1.range); - curmodule = (env1.curmodule); - gamma = (env1.gamma); - gamma_sig = (env1.gamma_sig); - gamma_cache = (env1.gamma_cache); - modules = (env1.modules); - expected_typ = (env1.expected_typ); - sigtab = (env1.sigtab); - attrtab = (env1.attrtab); - instantiate_imp = (env1.instantiate_imp); - effects = (env1.effects); - generalize = (env1.generalize); - letrecs = (env1.letrecs); - top_level = (env1.top_level); - check_uvars = (env1.check_uvars); - use_eq_strict = (env1.use_eq_strict); - is_iface = (env1.is_iface); - admit = (env1.admit); - lax_universes = (env1.lax_universes); - phase1 = (env1.phase1); - failhard = (env1.failhard); - flychecking = (env1.flychecking); - uvar_subtyping = (env1.uvar_subtyping); - intactics = (env1.intactics); - nocoerce = (env1.nocoerce); - tc_term = (env1.tc_term); - typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); - universe_of = (env1.universe_of); - typeof_well_typed_tot_or_gtot_term = - (env1.typeof_well_typed_tot_or_gtot_term); - teq_nosmt_force = (env1.teq_nosmt_force); - subtype_nosmt_force = (env1.subtype_nosmt_force); - qtbl_name_and_index = (env1.qtbl_name_and_index); - normalized_eff_names = (env1.normalized_eff_names); - fv_delta_depths = (env1.fv_delta_depths); - proof_ns = (env1.proof_ns); - synth_hook = (env1.synth_hook); - try_solve_implicits_hook = (env1.try_solve_implicits_hook); - splice = (env1.splice); - mpreprocess = (env1.mpreprocess); - postprocess = (env1.postprocess); - identifier_info = (env1.identifier_info); - tc_hooks = hooks; - dsenv = (env1.dsenv); - nbe = (env1.nbe); - strict_args_tab = (env1.strict_args_tab); - erasable_types_tab = (env1.erasable_types_tab); - enable_defer_to_tac = (env1.enable_defer_to_tac); - unif_allow_ref_guards = (env1.unif_allow_ref_guards); - erase_erasable_args = (env1.erase_erasable_args); - core_check = (env1.core_check); - missing_decl = (env1.missing_decl) - } -let (set_dep_graph : env -> FStar_Parser_Dep.deps -> env) = - fun e -> - fun g -> - let uu___ = FStar_Syntax_DsEnv.set_dep_graph e.dsenv g in - { - solver = (e.solver); - range = (e.range); - curmodule = (e.curmodule); - gamma = (e.gamma); - gamma_sig = (e.gamma_sig); - gamma_cache = (e.gamma_cache); - modules = (e.modules); - expected_typ = (e.expected_typ); - sigtab = (e.sigtab); - attrtab = (e.attrtab); - instantiate_imp = (e.instantiate_imp); - effects = (e.effects); - generalize = (e.generalize); - letrecs = (e.letrecs); - top_level = (e.top_level); - check_uvars = (e.check_uvars); - use_eq_strict = (e.use_eq_strict); - is_iface = (e.is_iface); - admit = (e.admit); - lax_universes = (e.lax_universes); - phase1 = (e.phase1); - failhard = (e.failhard); - flychecking = (e.flychecking); - uvar_subtyping = (e.uvar_subtyping); - intactics = (e.intactics); - nocoerce = (e.nocoerce); - tc_term = (e.tc_term); - typeof_tot_or_gtot_term = (e.typeof_tot_or_gtot_term); - universe_of = (e.universe_of); - typeof_well_typed_tot_or_gtot_term = - (e.typeof_well_typed_tot_or_gtot_term); - teq_nosmt_force = (e.teq_nosmt_force); - subtype_nosmt_force = (e.subtype_nosmt_force); - qtbl_name_and_index = (e.qtbl_name_and_index); - normalized_eff_names = (e.normalized_eff_names); - fv_delta_depths = (e.fv_delta_depths); - proof_ns = (e.proof_ns); - synth_hook = (e.synth_hook); - try_solve_implicits_hook = (e.try_solve_implicits_hook); - splice = (e.splice); - mpreprocess = (e.mpreprocess); - postprocess = (e.postprocess); - identifier_info = (e.identifier_info); - tc_hooks = (e.tc_hooks); - dsenv = uu___; - nbe = (e.nbe); - strict_args_tab = (e.strict_args_tab); - erasable_types_tab = (e.erasable_types_tab); - enable_defer_to_tac = (e.enable_defer_to_tac); - unif_allow_ref_guards = (e.unif_allow_ref_guards); - erase_erasable_args = (e.erase_erasable_args); - core_check = (e.core_check); - missing_decl = (e.missing_decl) - } -let (dep_graph : env -> FStar_Parser_Dep.deps) = - fun e -> FStar_Syntax_DsEnv.dep_graph e.dsenv -let (record_val_for : env -> FStar_Ident.lident -> env) = - fun e -> - fun l -> - let uu___ = - Obj.magic - (FStar_Class_Setlike.add () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Syntax.ord_fv)) l (Obj.magic e.missing_decl)) in - { - solver = (e.solver); - range = (e.range); - curmodule = (e.curmodule); - gamma = (e.gamma); - gamma_sig = (e.gamma_sig); - gamma_cache = (e.gamma_cache); - modules = (e.modules); - expected_typ = (e.expected_typ); - sigtab = (e.sigtab); - attrtab = (e.attrtab); - instantiate_imp = (e.instantiate_imp); - effects = (e.effects); - generalize = (e.generalize); - letrecs = (e.letrecs); - top_level = (e.top_level); - check_uvars = (e.check_uvars); - use_eq_strict = (e.use_eq_strict); - is_iface = (e.is_iface); - admit = (e.admit); - lax_universes = (e.lax_universes); - phase1 = (e.phase1); - failhard = (e.failhard); - flychecking = (e.flychecking); - uvar_subtyping = (e.uvar_subtyping); - intactics = (e.intactics); - nocoerce = (e.nocoerce); - tc_term = (e.tc_term); - typeof_tot_or_gtot_term = (e.typeof_tot_or_gtot_term); - universe_of = (e.universe_of); - typeof_well_typed_tot_or_gtot_term = - (e.typeof_well_typed_tot_or_gtot_term); - teq_nosmt_force = (e.teq_nosmt_force); - subtype_nosmt_force = (e.subtype_nosmt_force); - qtbl_name_and_index = (e.qtbl_name_and_index); - normalized_eff_names = (e.normalized_eff_names); - fv_delta_depths = (e.fv_delta_depths); - proof_ns = (e.proof_ns); - synth_hook = (e.synth_hook); - try_solve_implicits_hook = (e.try_solve_implicits_hook); - splice = (e.splice); - mpreprocess = (e.mpreprocess); - postprocess = (e.postprocess); - identifier_info = (e.identifier_info); - tc_hooks = (e.tc_hooks); - dsenv = (e.dsenv); - nbe = (e.nbe); - strict_args_tab = (e.strict_args_tab); - erasable_types_tab = (e.erasable_types_tab); - enable_defer_to_tac = (e.enable_defer_to_tac); - unif_allow_ref_guards = (e.unif_allow_ref_guards); - erase_erasable_args = (e.erase_erasable_args); - core_check = (e.core_check); - missing_decl = uu___ - } -let (record_definition_for : env -> FStar_Ident.lident -> env) = - fun e -> - fun l -> - let uu___ = - Obj.magic - (FStar_Class_Setlike.remove () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Syntax.ord_fv)) l (Obj.magic e.missing_decl)) in - { - solver = (e.solver); - range = (e.range); - curmodule = (e.curmodule); - gamma = (e.gamma); - gamma_sig = (e.gamma_sig); - gamma_cache = (e.gamma_cache); - modules = (e.modules); - expected_typ = (e.expected_typ); - sigtab = (e.sigtab); - attrtab = (e.attrtab); - instantiate_imp = (e.instantiate_imp); - effects = (e.effects); - generalize = (e.generalize); - letrecs = (e.letrecs); - top_level = (e.top_level); - check_uvars = (e.check_uvars); - use_eq_strict = (e.use_eq_strict); - is_iface = (e.is_iface); - admit = (e.admit); - lax_universes = (e.lax_universes); - phase1 = (e.phase1); - failhard = (e.failhard); - flychecking = (e.flychecking); - uvar_subtyping = (e.uvar_subtyping); - intactics = (e.intactics); - nocoerce = (e.nocoerce); - tc_term = (e.tc_term); - typeof_tot_or_gtot_term = (e.typeof_tot_or_gtot_term); - universe_of = (e.universe_of); - typeof_well_typed_tot_or_gtot_term = - (e.typeof_well_typed_tot_or_gtot_term); - teq_nosmt_force = (e.teq_nosmt_force); - subtype_nosmt_force = (e.subtype_nosmt_force); - qtbl_name_and_index = (e.qtbl_name_and_index); - normalized_eff_names = (e.normalized_eff_names); - fv_delta_depths = (e.fv_delta_depths); - proof_ns = (e.proof_ns); - synth_hook = (e.synth_hook); - try_solve_implicits_hook = (e.try_solve_implicits_hook); - splice = (e.splice); - mpreprocess = (e.mpreprocess); - postprocess = (e.postprocess); - identifier_info = (e.identifier_info); - tc_hooks = (e.tc_hooks); - dsenv = (e.dsenv); - nbe = (e.nbe); - strict_args_tab = (e.strict_args_tab); - erasable_types_tab = (e.erasable_types_tab); - enable_defer_to_tac = (e.enable_defer_to_tac); - unif_allow_ref_guards = (e.unif_allow_ref_guards); - erase_erasable_args = (e.erase_erasable_args); - core_check = (e.core_check); - missing_decl = uu___ - } -let (missing_definition_list : env -> FStar_Ident.lident Prims.list) = - fun e -> - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset FStar_Syntax_Syntax.ord_fv)) - (Obj.magic e.missing_decl) -type implicit = FStar_TypeChecker_Common.implicit -type implicits = FStar_TypeChecker_Common.implicits -type guard_t = FStar_TypeChecker_Common.guard_t -type tcenv_depth_t = (Prims.int * Prims.int * solver_depth_t * Prims.int) -type qninfo = - (((FStar_Syntax_Syntax.universes * FStar_Syntax_Syntax.typ), - (FStar_Syntax_Syntax.sigelt * FStar_Syntax_Syntax.universes - FStar_Pervasives_Native.option)) - FStar_Pervasives.either * FStar_Compiler_Range_Type.range) - FStar_Pervasives_Native.option -type env_t = env -type sigtable = FStar_Syntax_Syntax.sigelt FStar_Compiler_Util.smap -let (should_verify : env -> Prims.bool) = - fun env1 -> - ((let uu___ = FStar_Options.lax () in Prims.op_Negation uu___) && - (Prims.op_Negation env1.admit)) - && - (let uu___ = FStar_Ident.string_of_lid env1.curmodule in - FStar_Options.should_verify uu___) -let (visible_at : delta_level -> FStar_Syntax_Syntax.qualifier -> Prims.bool) - = - fun d -> - fun q -> - match (d, q) with - | (NoDelta, uu___) -> true - | (Eager_unfolding_only, - FStar_Syntax_Syntax.Unfold_for_unification_and_vcgen) -> true - | (Unfold uu___, FStar_Syntax_Syntax.Unfold_for_unification_and_vcgen) - -> true - | (Unfold uu___, FStar_Syntax_Syntax.Visible_default) -> true - | (InliningDelta, FStar_Syntax_Syntax.Inline_for_extraction) -> true - | uu___ -> false -let (default_table_size : Prims.int) = (Prims.of_int (200)) -let new_sigtab : 'uuuuu . unit -> 'uuuuu FStar_Compiler_Util.smap = - fun uu___ -> FStar_Compiler_Util.smap_create default_table_size -let new_gamma_cache : 'uuuuu . unit -> 'uuuuu FStar_Compiler_Util.smap = - fun uu___ -> FStar_Compiler_Util.smap_create (Prims.of_int (100)) -let (initial_env : - FStar_Parser_Dep.deps -> - (env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.lcomp * - guard_t)) - -> - (env -> - FStar_Syntax_Syntax.term -> - must_tot -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.typ * guard_t)) - -> - (env -> - FStar_Syntax_Syntax.term -> - must_tot -> - FStar_Syntax_Syntax.typ FStar_Pervasives_Native.option) - -> - (env -> FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.universe) - -> - (env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> Prims.bool) - -> - (env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> Prims.bool) - -> - solver_t -> - FStar_Ident.lident -> - (step Prims.list -> - env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - -> core_check_t -> env) - = - fun deps -> - fun tc_term -> - fun typeof_tot_or_gtot_term -> - fun typeof_tot_or_gtot_term_fastpath -> - fun universe_of -> - fun teq_nosmt_force -> - fun subtype_nosmt_force -> - fun solver -> - fun module_lid -> - fun nbe -> - fun core_check -> - let uu___ = new_gamma_cache () in - let uu___1 = new_sigtab () in - let uu___2 = new_sigtab () in - let uu___3 = - let uu___4 = - FStar_Compiler_Util.smap_create - (Prims.of_int (10)) in - (FStar_Pervasives_Native.None, uu___4) in - let uu___4 = - FStar_Compiler_Util.smap_create (Prims.of_int (20)) in - let uu___5 = - FStar_Compiler_Util.smap_create (Prims.of_int (50)) in - let uu___6 = FStar_Options.using_facts_from () in - let uu___7 = - FStar_Compiler_Util.mk_ref - FStar_TypeChecker_Common.id_info_table_empty in - let uu___8 = FStar_Syntax_DsEnv.empty_env deps in - let uu___9 = - FStar_Compiler_Util.smap_create (Prims.of_int (20)) in - let uu___10 = - FStar_Compiler_Util.smap_create (Prims.of_int (20)) in - let uu___11 = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Syntax.ord_fv)) ()) in - { - solver; - range = FStar_Compiler_Range_Type.dummyRange; - curmodule = module_lid; - gamma = []; - gamma_sig = []; - gamma_cache = uu___; - modules = []; - expected_typ = FStar_Pervasives_Native.None; - sigtab = uu___1; - attrtab = uu___2; - instantiate_imp = true; - effects = - { - decls = []; - order = []; - joins = []; - polymonadic_binds = []; - polymonadic_subcomps = [] - }; - generalize = true; - letrecs = []; - top_level = false; - check_uvars = false; - use_eq_strict = false; - is_iface = false; - admit = false; - lax_universes = false; - phase1 = false; - failhard = false; - flychecking = false; - uvar_subtyping = true; - intactics = false; - nocoerce = false; - tc_term; - typeof_tot_or_gtot_term; - universe_of; - typeof_well_typed_tot_or_gtot_term = - (fun env1 -> - fun t -> - fun must_tot1 -> - let uu___12 = - typeof_tot_or_gtot_term_fastpath env1 t - must_tot1 in - match uu___12 with - | FStar_Pervasives_Native.Some k -> - (k, - FStar_TypeChecker_Common.trivial_guard) - | FStar_Pervasives_Native.None -> - let uu___13 = - typeof_tot_or_gtot_term env1 t - must_tot1 in - (match uu___13 with - | (t', k, g) -> (k, g))); - teq_nosmt_force; - subtype_nosmt_force; - qtbl_name_and_index = uu___3; - normalized_eff_names = uu___4; - fv_delta_depths = uu___5; - proof_ns = uu___6; - synth_hook = - (fun e -> - fun g -> - fun tau -> - failwith "no synthesizer available"); - try_solve_implicits_hook = - (fun e -> - fun tau -> - fun imps -> - failwith "no implicit hook available"); - splice = - (fun e -> - fun is_typed -> - fun lids -> - fun tau -> - fun range -> - failwith "no splicer available"); - mpreprocess = - (fun e -> - fun tau -> - fun tm -> - failwith "no preprocessor available"); - postprocess = - (fun e -> - fun tau -> - fun typ -> - fun tm -> - failwith "no postprocessor available"); - identifier_info = uu___7; - tc_hooks = default_tc_hooks; - dsenv = uu___8; - nbe; - strict_args_tab = uu___9; - erasable_types_tab = uu___10; - enable_defer_to_tac = true; - unif_allow_ref_guards = false; - erase_erasable_args = false; - core_check; - missing_decl = uu___11 - } -let (dsenv : env -> FStar_Syntax_DsEnv.env) = fun env1 -> env1.dsenv -let (sigtab : env -> FStar_Syntax_Syntax.sigelt FStar_Compiler_Util.smap) = - fun env1 -> env1.sigtab -let (attrtab : - env -> FStar_Syntax_Syntax.sigelt Prims.list FStar_Compiler_Util.smap) = - fun env1 -> env1.attrtab -let (gamma_cache : env -> cached_elt FStar_Compiler_Util.smap) = - fun env1 -> env1.gamma_cache -let (query_indices : - (FStar_Ident.lident * Prims.int) Prims.list Prims.list - FStar_Compiler_Effect.ref) - = FStar_Compiler_Util.mk_ref [[]] -let (push_query_indices : unit -> unit) = - fun uu___ -> - let uu___1 = FStar_Compiler_Effect.op_Bang query_indices in - match uu___1 with - | [] -> failwith "Empty query indices!" - | uu___2 -> - let uu___3 = - let uu___4 = - let uu___5 = FStar_Compiler_Effect.op_Bang query_indices in - FStar_Compiler_List.hd uu___5 in - let uu___5 = FStar_Compiler_Effect.op_Bang query_indices in uu___4 - :: uu___5 in - FStar_Compiler_Effect.op_Colon_Equals query_indices uu___3 -let (pop_query_indices : unit -> unit) = - fun uu___ -> - let uu___1 = FStar_Compiler_Effect.op_Bang query_indices in - match uu___1 with - | [] -> failwith "Empty query indices!" - | hd::tl -> FStar_Compiler_Effect.op_Colon_Equals query_indices tl -let (snapshot_query_indices : unit -> (Prims.int * unit)) = - fun uu___ -> FStar_Common.snapshot push_query_indices query_indices () -let (rollback_query_indices : - Prims.int FStar_Pervasives_Native.option -> unit) = - fun depth -> FStar_Common.rollback pop_query_indices query_indices depth -let (add_query_index : (FStar_Ident.lident * Prims.int) -> unit) = - fun uu___ -> - match uu___ with - | (l, n) -> - let uu___1 = FStar_Compiler_Effect.op_Bang query_indices in - (match uu___1 with - | hd::tl -> - FStar_Compiler_Effect.op_Colon_Equals query_indices (((l, n) :: - hd) :: tl) - | uu___2 -> failwith "Empty query indices") -let (peek_query_indices : - unit -> (FStar_Ident.lident * Prims.int) Prims.list) = - fun uu___ -> - let uu___1 = FStar_Compiler_Effect.op_Bang query_indices in - FStar_Compiler_List.hd uu___1 -let (stack : env Prims.list FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref [] -let (push_stack : env -> env) = - fun env1 -> - (let uu___1 = - let uu___2 = FStar_Compiler_Effect.op_Bang stack in env1 :: uu___2 in - FStar_Compiler_Effect.op_Colon_Equals stack uu___1); - (let uu___1 = FStar_Compiler_Util.smap_copy (gamma_cache env1) in - let uu___2 = FStar_Compiler_Util.smap_copy (sigtab env1) in - let uu___3 = FStar_Compiler_Util.smap_copy (attrtab env1) in - let uu___4 = - let uu___5 = - FStar_Compiler_Util.smap_copy - (FStar_Pervasives_Native.snd env1.qtbl_name_and_index) in - ((FStar_Pervasives_Native.fst env1.qtbl_name_and_index), uu___5) in - let uu___5 = FStar_Compiler_Util.smap_copy env1.normalized_eff_names in - let uu___6 = FStar_Compiler_Util.smap_copy env1.fv_delta_depths in - let uu___7 = - let uu___8 = FStar_Compiler_Effect.op_Bang env1.identifier_info in - FStar_Compiler_Util.mk_ref uu___8 in - let uu___8 = FStar_Compiler_Util.smap_copy env1.strict_args_tab in - let uu___9 = FStar_Compiler_Util.smap_copy env1.erasable_types_tab in - { - solver = (env1.solver); - range = (env1.range); - curmodule = (env1.curmodule); - gamma = (env1.gamma); - gamma_sig = (env1.gamma_sig); - gamma_cache = uu___1; - modules = (env1.modules); - expected_typ = (env1.expected_typ); - sigtab = uu___2; - attrtab = uu___3; - instantiate_imp = (env1.instantiate_imp); - effects = (env1.effects); - generalize = (env1.generalize); - letrecs = (env1.letrecs); - top_level = (env1.top_level); - check_uvars = (env1.check_uvars); - use_eq_strict = (env1.use_eq_strict); - is_iface = (env1.is_iface); - admit = (env1.admit); - lax_universes = (env1.lax_universes); - phase1 = (env1.phase1); - failhard = (env1.failhard); - flychecking = (env1.flychecking); - uvar_subtyping = (env1.uvar_subtyping); - intactics = (env1.intactics); - nocoerce = (env1.nocoerce); - tc_term = (env1.tc_term); - typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); - universe_of = (env1.universe_of); - typeof_well_typed_tot_or_gtot_term = - (env1.typeof_well_typed_tot_or_gtot_term); - teq_nosmt_force = (env1.teq_nosmt_force); - subtype_nosmt_force = (env1.subtype_nosmt_force); - qtbl_name_and_index = uu___4; - normalized_eff_names = uu___5; - fv_delta_depths = uu___6; - proof_ns = (env1.proof_ns); - synth_hook = (env1.synth_hook); - try_solve_implicits_hook = (env1.try_solve_implicits_hook); - splice = (env1.splice); - mpreprocess = (env1.mpreprocess); - postprocess = (env1.postprocess); - identifier_info = uu___7; - tc_hooks = (env1.tc_hooks); - dsenv = (env1.dsenv); - nbe = (env1.nbe); - strict_args_tab = uu___8; - erasable_types_tab = uu___9; - enable_defer_to_tac = (env1.enable_defer_to_tac); - unif_allow_ref_guards = (env1.unif_allow_ref_guards); - erase_erasable_args = (env1.erase_erasable_args); - core_check = (env1.core_check); - missing_decl = (env1.missing_decl) - }) -let (pop_stack : unit -> env) = - fun uu___ -> - let uu___1 = FStar_Compiler_Effect.op_Bang stack in - match uu___1 with - | env1::tl -> (FStar_Compiler_Effect.op_Colon_Equals stack tl; env1) - | uu___2 -> failwith "Impossible: Too many pops" -let (snapshot_stack : env -> (Prims.int * env)) = - fun env1 -> FStar_Common.snapshot push_stack stack env1 -let (rollback_stack : Prims.int FStar_Pervasives_Native.option -> env) = - fun depth -> FStar_Common.rollback pop_stack stack depth -let (snapshot : env -> Prims.string -> (tcenv_depth_t * env)) = - fun env1 -> - fun msg -> - FStar_Compiler_Util.atomically - (fun uu___ -> - let uu___1 = snapshot_stack env1 in - match uu___1 with - | (stack_depth, env2) -> - let uu___2 = snapshot_query_indices () in - (match uu___2 with - | (query_indices_depth, ()) -> - let uu___3 = (env2.solver).snapshot msg in - (match uu___3 with - | (solver_depth, ()) -> - let uu___4 = FStar_Syntax_DsEnv.snapshot env2.dsenv in - (match uu___4 with - | (dsenv_depth, dsenv1) -> - ((stack_depth, query_indices_depth, - solver_depth, dsenv_depth), - { - solver = (env2.solver); - range = (env2.range); - curmodule = (env2.curmodule); - gamma = (env2.gamma); - gamma_sig = (env2.gamma_sig); - gamma_cache = (env2.gamma_cache); - modules = (env2.modules); - expected_typ = (env2.expected_typ); - sigtab = (env2.sigtab); - attrtab = (env2.attrtab); - instantiate_imp = (env2.instantiate_imp); - effects = (env2.effects); - generalize = (env2.generalize); - letrecs = (env2.letrecs); - top_level = (env2.top_level); - check_uvars = (env2.check_uvars); - use_eq_strict = (env2.use_eq_strict); - is_iface = (env2.is_iface); - admit = (env2.admit); - lax_universes = (env2.lax_universes); - phase1 = (env2.phase1); - failhard = (env2.failhard); - flychecking = (env2.flychecking); - uvar_subtyping = (env2.uvar_subtyping); - intactics = (env2.intactics); - nocoerce = (env2.nocoerce); - tc_term = (env2.tc_term); - typeof_tot_or_gtot_term = - (env2.typeof_tot_or_gtot_term); - universe_of = (env2.universe_of); - typeof_well_typed_tot_or_gtot_term = - (env2.typeof_well_typed_tot_or_gtot_term); - teq_nosmt_force = (env2.teq_nosmt_force); - subtype_nosmt_force = - (env2.subtype_nosmt_force); - qtbl_name_and_index = - (env2.qtbl_name_and_index); - normalized_eff_names = - (env2.normalized_eff_names); - fv_delta_depths = (env2.fv_delta_depths); - proof_ns = (env2.proof_ns); - synth_hook = (env2.synth_hook); - try_solve_implicits_hook = - (env2.try_solve_implicits_hook); - splice = (env2.splice); - mpreprocess = (env2.mpreprocess); - postprocess = (env2.postprocess); - identifier_info = (env2.identifier_info); - tc_hooks = (env2.tc_hooks); - dsenv = dsenv1; - nbe = (env2.nbe); - strict_args_tab = (env2.strict_args_tab); - erasable_types_tab = - (env2.erasable_types_tab); - enable_defer_to_tac = - (env2.enable_defer_to_tac); - unif_allow_ref_guards = - (env2.unif_allow_ref_guards); - erase_erasable_args = - (env2.erase_erasable_args); - core_check = (env2.core_check); - missing_decl = (env2.missing_decl) - }))))) -let (rollback : - solver_t -> - Prims.string -> tcenv_depth_t FStar_Pervasives_Native.option -> env) - = - fun solver -> - fun msg -> - fun depth -> - FStar_Compiler_Util.atomically - (fun uu___ -> - let uu___1 = - match depth with - | FStar_Pervasives_Native.Some (s1, s2, s3, s4) -> - ((FStar_Pervasives_Native.Some s1), - (FStar_Pervasives_Native.Some s2), - (FStar_Pervasives_Native.Some s3), - (FStar_Pervasives_Native.Some s4)) - | FStar_Pervasives_Native.None -> - (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None) in - match uu___1 with - | (stack_depth, query_indices_depth, solver_depth, dsenv_depth) - -> - (solver.rollback msg solver_depth; - (match () with - | () -> - (rollback_query_indices query_indices_depth; - (match () with - | () -> - let tcenv = rollback_stack stack_depth in - let dsenv1 = - FStar_Syntax_DsEnv.rollback dsenv_depth in - ((let uu___5 = - FStar_Compiler_Util.physical_equality - tcenv.dsenv dsenv1 in - FStar_Common.runtime_assert uu___5 - "Inconsistent stack state"); - tcenv)))))) -let (push : env -> Prims.string -> env) = - fun env1 -> - fun msg -> - let uu___ = snapshot env1 msg in FStar_Pervasives_Native.snd uu___ -let (pop : env -> Prims.string -> env) = - fun env1 -> - fun msg -> rollback env1.solver msg FStar_Pervasives_Native.None -let (incr_query_index : env -> env) = - fun env1 -> - let qix = peek_query_indices () in - match env1.qtbl_name_and_index with - | (FStar_Pervasives_Native.None, uu___) -> env1 - | (FStar_Pervasives_Native.Some (l, typ, n), tbl) -> - let uu___ = - FStar_Compiler_List.tryFind - (fun uu___1 -> - match uu___1 with | (m, uu___2) -> FStar_Ident.lid_equals l m) - qix in - (match uu___ with - | FStar_Pervasives_Native.None -> - let next = n + Prims.int_one in - (add_query_index (l, next); - (let uu___3 = FStar_Ident.string_of_lid l in - FStar_Compiler_Util.smap_add tbl uu___3 next); - { - solver = (env1.solver); - range = (env1.range); - curmodule = (env1.curmodule); - gamma = (env1.gamma); - gamma_sig = (env1.gamma_sig); - gamma_cache = (env1.gamma_cache); - modules = (env1.modules); - expected_typ = (env1.expected_typ); - sigtab = (env1.sigtab); - attrtab = (env1.attrtab); - instantiate_imp = (env1.instantiate_imp); - effects = (env1.effects); - generalize = (env1.generalize); - letrecs = (env1.letrecs); - top_level = (env1.top_level); - check_uvars = (env1.check_uvars); - use_eq_strict = (env1.use_eq_strict); - is_iface = (env1.is_iface); - admit = (env1.admit); - lax_universes = (env1.lax_universes); - phase1 = (env1.phase1); - failhard = (env1.failhard); - flychecking = (env1.flychecking); - uvar_subtyping = (env1.uvar_subtyping); - intactics = (env1.intactics); - nocoerce = (env1.nocoerce); - tc_term = (env1.tc_term); - typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); - universe_of = (env1.universe_of); - typeof_well_typed_tot_or_gtot_term = - (env1.typeof_well_typed_tot_or_gtot_term); - teq_nosmt_force = (env1.teq_nosmt_force); - subtype_nosmt_force = (env1.subtype_nosmt_force); - qtbl_name_and_index = - ((FStar_Pervasives_Native.Some (l, typ, next)), tbl); - normalized_eff_names = (env1.normalized_eff_names); - fv_delta_depths = (env1.fv_delta_depths); - proof_ns = (env1.proof_ns); - synth_hook = (env1.synth_hook); - try_solve_implicits_hook = (env1.try_solve_implicits_hook); - splice = (env1.splice); - mpreprocess = (env1.mpreprocess); - postprocess = (env1.postprocess); - identifier_info = (env1.identifier_info); - tc_hooks = (env1.tc_hooks); - dsenv = (env1.dsenv); - nbe = (env1.nbe); - strict_args_tab = (env1.strict_args_tab); - erasable_types_tab = (env1.erasable_types_tab); - enable_defer_to_tac = (env1.enable_defer_to_tac); - unif_allow_ref_guards = (env1.unif_allow_ref_guards); - erase_erasable_args = (env1.erase_erasable_args); - core_check = (env1.core_check); - missing_decl = (env1.missing_decl) - }) - | FStar_Pervasives_Native.Some (uu___1, m) -> - let next = m + Prims.int_one in - (add_query_index (l, next); - (let uu___4 = FStar_Ident.string_of_lid l in - FStar_Compiler_Util.smap_add tbl uu___4 next); - { - solver = (env1.solver); - range = (env1.range); - curmodule = (env1.curmodule); - gamma = (env1.gamma); - gamma_sig = (env1.gamma_sig); - gamma_cache = (env1.gamma_cache); - modules = (env1.modules); - expected_typ = (env1.expected_typ); - sigtab = (env1.sigtab); - attrtab = (env1.attrtab); - instantiate_imp = (env1.instantiate_imp); - effects = (env1.effects); - generalize = (env1.generalize); - letrecs = (env1.letrecs); - top_level = (env1.top_level); - check_uvars = (env1.check_uvars); - use_eq_strict = (env1.use_eq_strict); - is_iface = (env1.is_iface); - admit = (env1.admit); - lax_universes = (env1.lax_universes); - phase1 = (env1.phase1); - failhard = (env1.failhard); - flychecking = (env1.flychecking); - uvar_subtyping = (env1.uvar_subtyping); - intactics = (env1.intactics); - nocoerce = (env1.nocoerce); - tc_term = (env1.tc_term); - typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); - universe_of = (env1.universe_of); - typeof_well_typed_tot_or_gtot_term = - (env1.typeof_well_typed_tot_or_gtot_term); - teq_nosmt_force = (env1.teq_nosmt_force); - subtype_nosmt_force = (env1.subtype_nosmt_force); - qtbl_name_and_index = - ((FStar_Pervasives_Native.Some (l, typ, next)), tbl); - normalized_eff_names = (env1.normalized_eff_names); - fv_delta_depths = (env1.fv_delta_depths); - proof_ns = (env1.proof_ns); - synth_hook = (env1.synth_hook); - try_solve_implicits_hook = (env1.try_solve_implicits_hook); - splice = (env1.splice); - mpreprocess = (env1.mpreprocess); - postprocess = (env1.postprocess); - identifier_info = (env1.identifier_info); - tc_hooks = (env1.tc_hooks); - dsenv = (env1.dsenv); - nbe = (env1.nbe); - strict_args_tab = (env1.strict_args_tab); - erasable_types_tab = (env1.erasable_types_tab); - enable_defer_to_tac = (env1.enable_defer_to_tac); - unif_allow_ref_guards = (env1.unif_allow_ref_guards); - erase_erasable_args = (env1.erase_erasable_args); - core_check = (env1.core_check); - missing_decl = (env1.missing_decl) - })) -let (set_range : env -> FStar_Compiler_Range_Type.range -> env) = - fun e -> - fun r -> - if r = FStar_Compiler_Range_Type.dummyRange - then e - else - { - solver = (e.solver); - range = r; - curmodule = (e.curmodule); - gamma = (e.gamma); - gamma_sig = (e.gamma_sig); - gamma_cache = (e.gamma_cache); - modules = (e.modules); - expected_typ = (e.expected_typ); - sigtab = (e.sigtab); - attrtab = (e.attrtab); - instantiate_imp = (e.instantiate_imp); - effects = (e.effects); - generalize = (e.generalize); - letrecs = (e.letrecs); - top_level = (e.top_level); - check_uvars = (e.check_uvars); - use_eq_strict = (e.use_eq_strict); - is_iface = (e.is_iface); - admit = (e.admit); - lax_universes = (e.lax_universes); - phase1 = (e.phase1); - failhard = (e.failhard); - flychecking = (e.flychecking); - uvar_subtyping = (e.uvar_subtyping); - intactics = (e.intactics); - nocoerce = (e.nocoerce); - tc_term = (e.tc_term); - typeof_tot_or_gtot_term = (e.typeof_tot_or_gtot_term); - universe_of = (e.universe_of); - typeof_well_typed_tot_or_gtot_term = - (e.typeof_well_typed_tot_or_gtot_term); - teq_nosmt_force = (e.teq_nosmt_force); - subtype_nosmt_force = (e.subtype_nosmt_force); - qtbl_name_and_index = (e.qtbl_name_and_index); - normalized_eff_names = (e.normalized_eff_names); - fv_delta_depths = (e.fv_delta_depths); - proof_ns = (e.proof_ns); - synth_hook = (e.synth_hook); - try_solve_implicits_hook = (e.try_solve_implicits_hook); - splice = (e.splice); - mpreprocess = (e.mpreprocess); - postprocess = (e.postprocess); - identifier_info = (e.identifier_info); - tc_hooks = (e.tc_hooks); - dsenv = (e.dsenv); - nbe = (e.nbe); - strict_args_tab = (e.strict_args_tab); - erasable_types_tab = (e.erasable_types_tab); - enable_defer_to_tac = (e.enable_defer_to_tac); - unif_allow_ref_guards = (e.unif_allow_ref_guards); - erase_erasable_args = (e.erase_erasable_args); - core_check = (e.core_check); - missing_decl = (e.missing_decl) - } -let (get_range : env -> FStar_Compiler_Range_Type.range) = fun e -> e.range -let (hasRange_env : env FStar_Class_HasRange.hasRange) = - { - FStar_Class_HasRange.pos = get_range; - FStar_Class_HasRange.setPos = (fun r -> fun e -> set_range e r) - } -let (toggle_id_info : env -> Prims.bool -> unit) = - fun env1 -> - fun enabled -> - let uu___ = - let uu___1 = FStar_Compiler_Effect.op_Bang env1.identifier_info in - FStar_TypeChecker_Common.id_info_toggle uu___1 enabled in - FStar_Compiler_Effect.op_Colon_Equals env1.identifier_info uu___ -let (insert_bv_info : - env -> FStar_Syntax_Syntax.bv -> FStar_Syntax_Syntax.typ -> unit) = - fun env1 -> - fun bv -> - fun ty -> - let uu___ = - let uu___1 = FStar_Compiler_Effect.op_Bang env1.identifier_info in - FStar_TypeChecker_Common.id_info_insert_bv uu___1 bv ty in - FStar_Compiler_Effect.op_Colon_Equals env1.identifier_info uu___ -let (insert_fv_info : - env -> FStar_Syntax_Syntax.fv -> FStar_Syntax_Syntax.typ -> unit) = - fun env1 -> - fun fv -> - fun ty -> - let uu___ = - let uu___1 = FStar_Compiler_Effect.op_Bang env1.identifier_info in - FStar_TypeChecker_Common.id_info_insert_fv uu___1 fv ty in - FStar_Compiler_Effect.op_Colon_Equals env1.identifier_info uu___ -let (promote_id_info : - env -> - (FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.typ FStar_Pervasives_Native.option) - -> unit) - = - fun env1 -> - fun ty_map -> - let uu___ = - let uu___1 = FStar_Compiler_Effect.op_Bang env1.identifier_info in - FStar_TypeChecker_Common.id_info_promote uu___1 ty_map in - FStar_Compiler_Effect.op_Colon_Equals env1.identifier_info uu___ -let (modules : env -> FStar_Syntax_Syntax.modul Prims.list) = - fun env1 -> env1.modules -let (current_module : env -> FStar_Ident.lident) = fun env1 -> env1.curmodule -let (set_current_module : env -> FStar_Ident.lident -> env) = - fun env1 -> - fun lid -> - { - solver = (env1.solver); - range = (env1.range); - curmodule = lid; - gamma = (env1.gamma); - gamma_sig = (env1.gamma_sig); - gamma_cache = (env1.gamma_cache); - modules = (env1.modules); - expected_typ = (env1.expected_typ); - sigtab = (env1.sigtab); - attrtab = (env1.attrtab); - instantiate_imp = (env1.instantiate_imp); - effects = (env1.effects); - generalize = (env1.generalize); - letrecs = (env1.letrecs); - top_level = (env1.top_level); - check_uvars = (env1.check_uvars); - use_eq_strict = (env1.use_eq_strict); - is_iface = (env1.is_iface); - admit = (env1.admit); - lax_universes = (env1.lax_universes); - phase1 = (env1.phase1); - failhard = (env1.failhard); - flychecking = (env1.flychecking); - uvar_subtyping = (env1.uvar_subtyping); - intactics = (env1.intactics); - nocoerce = (env1.nocoerce); - tc_term = (env1.tc_term); - typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); - universe_of = (env1.universe_of); - typeof_well_typed_tot_or_gtot_term = - (env1.typeof_well_typed_tot_or_gtot_term); - teq_nosmt_force = (env1.teq_nosmt_force); - subtype_nosmt_force = (env1.subtype_nosmt_force); - qtbl_name_and_index = (env1.qtbl_name_and_index); - normalized_eff_names = (env1.normalized_eff_names); - fv_delta_depths = (env1.fv_delta_depths); - proof_ns = (env1.proof_ns); - synth_hook = (env1.synth_hook); - try_solve_implicits_hook = (env1.try_solve_implicits_hook); - splice = (env1.splice); - mpreprocess = (env1.mpreprocess); - postprocess = (env1.postprocess); - identifier_info = (env1.identifier_info); - tc_hooks = (env1.tc_hooks); - dsenv = (env1.dsenv); - nbe = (env1.nbe); - strict_args_tab = (env1.strict_args_tab); - erasable_types_tab = (env1.erasable_types_tab); - enable_defer_to_tac = (env1.enable_defer_to_tac); - unif_allow_ref_guards = (env1.unif_allow_ref_guards); - erase_erasable_args = (env1.erase_erasable_args); - core_check = (env1.core_check); - missing_decl = (env1.missing_decl) - } -let (has_interface : env -> FStar_Ident.lident -> Prims.bool) = - fun env1 -> - fun l -> - FStar_Compiler_Util.for_some - (fun m -> - m.FStar_Syntax_Syntax.is_interface && - (FStar_Ident.lid_equals m.FStar_Syntax_Syntax.name l)) - env1.modules -let (find_in_sigtab : - env -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.sigelt FStar_Pervasives_Native.option) - = - fun env1 -> - fun lid -> - let uu___ = FStar_Ident.string_of_lid lid in - FStar_Compiler_Util.smap_try_find (sigtab env1) uu___ -let (new_u_univ : unit -> FStar_Syntax_Syntax.universe) = - fun uu___ -> - let uu___1 = - FStar_Syntax_Unionfind.univ_fresh FStar_Compiler_Range_Type.dummyRange in - FStar_Syntax_Syntax.U_unif uu___1 -let (mk_univ_subst : - FStar_Syntax_Syntax.univ_name Prims.list -> - FStar_Syntax_Syntax.universes -> FStar_Syntax_Syntax.subst_elt Prims.list) - = - fun formals -> - fun us -> - let n = (FStar_Compiler_List.length formals) - Prims.int_one in - FStar_Compiler_List.mapi - (fun i -> fun u -> FStar_Syntax_Syntax.UN ((n - i), u)) us -let (inst_tscheme_with : - FStar_Syntax_Syntax.tscheme -> - FStar_Syntax_Syntax.universes -> - (FStar_Syntax_Syntax.universes * FStar_Syntax_Syntax.term)) - = - fun ts -> - fun us -> - match (ts, us) with - | (([], t), []) -> ([], t) - | ((formals, t), uu___) -> - let vs = mk_univ_subst formals us in - let uu___1 = FStar_Syntax_Subst.subst vs t in (us, uu___1) -let (inst_tscheme : - FStar_Syntax_Syntax.tscheme -> - (FStar_Syntax_Syntax.universes * FStar_Syntax_Syntax.term)) - = - fun uu___ -> - match uu___ with - | ([], t) -> ([], t) - | (us, t) -> - let us' = FStar_Compiler_List.map (fun uu___1 -> new_u_univ ()) us in - inst_tscheme_with (us, t) us' -let (inst_tscheme_with_range : - FStar_Compiler_Range_Type.range -> - FStar_Syntax_Syntax.tscheme -> - (FStar_Syntax_Syntax.universes * FStar_Syntax_Syntax.term)) - = - fun r -> - fun t -> - let uu___ = inst_tscheme t in - match uu___ with - | (us, t1) -> - let uu___1 = FStar_Syntax_Subst.set_use_range r t1 in (us, uu___1) -let (check_effect_is_not_a_template : - FStar_Syntax_Syntax.eff_decl -> FStar_Compiler_Range_Type.range -> unit) = - fun ed -> - fun rng -> - if - ((FStar_Compiler_List.length ed.FStar_Syntax_Syntax.univs) <> - Prims.int_zero) - || - ((FStar_Compiler_List.length ed.FStar_Syntax_Syntax.binders) <> - Prims.int_zero) - then - let msg = - let uu___ = - FStar_Class_Show.show FStar_Ident.showable_lident - ed.FStar_Syntax_Syntax.mname in - let uu___1 = - let uu___2 = - FStar_Compiler_List.map - FStar_Syntax_Print.binder_to_string_with_type - ed.FStar_Syntax_Syntax.binders in - FStar_Compiler_String.concat "," uu___2 in - FStar_Compiler_Util.format2 - "Effect template %s should be applied to arguments for its binders (%s) before it can be used at an effect position" - uu___ uu___1 in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range rng - FStar_Errors_Codes.Fatal_NotEnoughArgumentsForEffect () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic msg) - else () -let (inst_effect_fun_with : - FStar_Syntax_Syntax.universes -> - env -> - FStar_Syntax_Syntax.eff_decl -> - FStar_Syntax_Syntax.tscheme -> FStar_Syntax_Syntax.term) - = - fun insts -> - fun env1 -> - fun ed -> - fun uu___ -> - match uu___ with - | (us, t) -> - (check_effect_is_not_a_template ed env1.range; - if - (FStar_Compiler_List.length insts) <> - (FStar_Compiler_List.length us) - then - (let uu___3 = - let uu___4 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length us) in - let uu___5 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length insts) in - let uu___6 = - FStar_Class_Show.show FStar_Ident.showable_lident - ed.FStar_Syntax_Syntax.mname in - let uu___7 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - t in - FStar_Compiler_Util.format4 - "Expected %s instantiations; got %s; failed universe instantiation in effect %s\n\t%s\n" - uu___4 uu___5 uu___6 uu___7 in - failwith uu___3) - else (); - (let uu___3 = inst_tscheme_with (us, t) insts in - FStar_Pervasives_Native.snd uu___3)) -type tri = - | Yes - | No - | Maybe -let (uu___is_Yes : tri -> Prims.bool) = - fun projectee -> match projectee with | Yes -> true | uu___ -> false -let (uu___is_No : tri -> Prims.bool) = - fun projectee -> match projectee with | No -> true | uu___ -> false -let (uu___is_Maybe : tri -> Prims.bool) = - fun projectee -> match projectee with | Maybe -> true | uu___ -> false -let (in_cur_mod : env -> FStar_Ident.lident -> tri) = - fun env1 -> - fun l -> - let cur = current_module env1 in - let uu___ = - let uu___1 = FStar_Ident.nsstr l in - let uu___2 = FStar_Ident.string_of_lid cur in uu___1 = uu___2 in - if uu___ - then Yes - else - (let uu___2 = - let uu___3 = FStar_Ident.nsstr l in - let uu___4 = FStar_Ident.string_of_lid cur in - FStar_Compiler_Util.starts_with uu___3 uu___4 in - if uu___2 - then - let lns = - let uu___3 = FStar_Ident.ns_of_lid l in - let uu___4 = let uu___5 = FStar_Ident.ident_of_lid l in [uu___5] in - FStar_Compiler_List.op_At uu___3 uu___4 in - let cur1 = - let uu___3 = FStar_Ident.ns_of_lid cur in - let uu___4 = - let uu___5 = FStar_Ident.ident_of_lid cur in [uu___5] in - FStar_Compiler_List.op_At uu___3 uu___4 in - let rec aux c l1 = - match (c, l1) with - | ([], uu___3) -> Maybe - | (uu___3, []) -> No - | (hd::tl, hd'::tl') when - let uu___3 = FStar_Ident.string_of_id hd in - let uu___4 = FStar_Ident.string_of_id hd' in uu___3 = uu___4 - -> aux tl tl' - | uu___3 -> No in - aux cur1 lns - else No) -let (lookup_qname : env -> FStar_Ident.lident -> qninfo) = - fun env1 -> - fun lid -> - let cur_mod = in_cur_mod env1 lid in - let cache t = - (let uu___1 = FStar_Ident.string_of_lid lid in - FStar_Compiler_Util.smap_add (gamma_cache env1) uu___1 t); - FStar_Pervasives_Native.Some t in - let found = - if cur_mod <> No - then - let uu___ = - let uu___1 = FStar_Ident.string_of_lid lid in - FStar_Compiler_Util.smap_try_find (gamma_cache env1) uu___1 in - match uu___ with - | FStar_Pervasives_Native.None -> - let uu___1 = - FStar_Compiler_Util.find_map env1.gamma - (fun uu___2 -> - match uu___2 with - | FStar_Syntax_Syntax.Binding_lid (l, (us_names, t)) - when FStar_Ident.lid_equals lid l -> - let us = - FStar_Compiler_List.map - (fun uu___3 -> FStar_Syntax_Syntax.U_name uu___3) - us_names in - let uu___3 = - let uu___4 = FStar_Ident.range_of_lid l in - ((FStar_Pervasives.Inl (us, t)), uu___4) in - FStar_Pervasives_Native.Some uu___3 - | uu___3 -> FStar_Pervasives_Native.None) in - FStar_Compiler_Util.catch_opt uu___1 - (fun uu___2 -> - FStar_Compiler_Util.find_map env1.gamma_sig - (fun uu___3 -> - match uu___3 with - | (uu___4, - { - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_bundle - { FStar_Syntax_Syntax.ses = ses; - FStar_Syntax_Syntax.lids = uu___5;_}; - FStar_Syntax_Syntax.sigrng = uu___6; - FStar_Syntax_Syntax.sigquals = uu___7; - FStar_Syntax_Syntax.sigmeta = uu___8; - FStar_Syntax_Syntax.sigattrs = uu___9; - FStar_Syntax_Syntax.sigopens_and_abbrevs = - uu___10; - FStar_Syntax_Syntax.sigopts = uu___11;_}) - -> - FStar_Compiler_Util.find_map ses - (fun se -> - let uu___12 = - FStar_Compiler_Util.for_some - (FStar_Ident.lid_equals lid) - (FStar_Syntax_Util.lids_of_sigelt se) in - if uu___12 - then - cache - ((FStar_Pervasives.Inr - (se, FStar_Pervasives_Native.None)), - (FStar_Syntax_Util.range_of_sigelt se)) - else FStar_Pervasives_Native.None) - | (lids, s) -> - let maybe_cache t = - match s.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_declare_typ uu___4 -> - FStar_Pervasives_Native.Some t - | uu___4 -> cache t in - let uu___4 = - FStar_Compiler_List.tryFind - (FStar_Ident.lid_equals lid) lids in - (match uu___4 with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some l -> - let uu___5 = - let uu___6 = FStar_Ident.range_of_lid l in - ((FStar_Pervasives.Inr - (s, FStar_Pervasives_Native.None)), - uu___6) in - maybe_cache uu___5))) - | se -> se - else FStar_Pervasives_Native.None in - if FStar_Compiler_Util.is_some found - then found - else - (let uu___1 = find_in_sigtab env1 lid in - match uu___1 with - | FStar_Pervasives_Native.Some se -> - FStar_Pervasives_Native.Some - ((FStar_Pervasives.Inr (se, FStar_Pervasives_Native.None)), - (FStar_Syntax_Util.range_of_sigelt se)) - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None) -let (lookup_sigelt : - env -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.sigelt FStar_Pervasives_Native.option) - = - fun env1 -> - fun lid -> - let uu___ = lookup_qname env1 lid in - match uu___ with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (FStar_Pervasives.Inl uu___1, rng) -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (FStar_Pervasives.Inr (se, us), rng) -> - FStar_Pervasives_Native.Some se -let (lookup_attr : - env -> Prims.string -> FStar_Syntax_Syntax.sigelt Prims.list) = - fun env1 -> - fun attr -> - let uu___ = FStar_Compiler_Util.smap_try_find (attrtab env1) attr in - match uu___ with - | FStar_Pervasives_Native.Some ses -> ses - | FStar_Pervasives_Native.None -> [] -let (add_se_to_attrtab : env -> FStar_Syntax_Syntax.sigelt -> unit) = - fun env1 -> - fun se -> - let add_one env2 se1 attr = - let uu___ = let uu___1 = lookup_attr env2 attr in se1 :: uu___1 in - FStar_Compiler_Util.smap_add (attrtab env2) attr uu___ in - FStar_Compiler_List.iter - (fun attr -> - let uu___ = FStar_Syntax_Util.head_and_args attr in - match uu___ with - | (hd, uu___1) -> - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress hd in - uu___3.FStar_Syntax_Syntax.n in - (match uu___2 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - let uu___3 = - let uu___4 = FStar_Syntax_Syntax.lid_of_fv fv in - FStar_Ident.string_of_lid uu___4 in - add_one env1 se uu___3 - | uu___3 -> ())) se.FStar_Syntax_Syntax.sigattrs -let (try_add_sigelt : - Prims.bool -> - env -> FStar_Syntax_Syntax.sigelt -> FStar_Ident.lident -> unit) - = - fun force -> - fun env1 -> - fun se -> - fun l -> - let s = FStar_Ident.string_of_lid l in - (let uu___1 = - (Prims.op_Negation force) && - (let uu___2 = - FStar_Compiler_Util.smap_try_find (sigtab env1) s in - FStar_Pervasives_Native.uu___is_Some uu___2) in - if uu___1 - then - let old_se = - let uu___2 = FStar_Compiler_Util.smap_try_find (sigtab env1) s in - FStar_Pervasives_Native.__proj__Some__item__v uu___2 in - (if - (FStar_Syntax_Syntax.uu___is_Sig_declare_typ - old_se.FStar_Syntax_Syntax.sigel) - && - (((FStar_Syntax_Syntax.uu___is_Sig_let - se.FStar_Syntax_Syntax.sigel) - || - (FStar_Syntax_Syntax.uu___is_Sig_inductive_typ - se.FStar_Syntax_Syntax.sigel)) - || - (FStar_Syntax_Syntax.uu___is_Sig_datacon - se.FStar_Syntax_Syntax.sigel)) - then () - else - (let uu___3 = - let uu___4 = - let uu___5 = - FStar_Errors_Msg.text "Duplicate top-level names" in - let uu___6 = FStar_Pprint.arbitrary_string s in - FStar_Pprint.op_Hat_Slash_Hat uu___5 uu___6 in - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Errors_Msg.text "Previously declared at" in - let uu___8 = - let uu___9 = - let uu___10 = FStar_Ident.range_of_lid l in - FStar_Compiler_Range_Ops.string_of_range uu___10 in - FStar_Pprint.arbitrary_string uu___9 in - FStar_Pprint.op_Hat_Slash_Hat uu___7 uu___8 in - [uu___6] in - uu___4 :: uu___5 in - FStar_Errors.raise_error FStar_Ident.hasrange_lident l - FStar_Errors_Codes.Fatal_DuplicateTopLevelNames () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___3))) - else ()); - FStar_Compiler_Util.smap_add (sigtab env1) s se -let rec (add_sigelt : - Prims.bool -> env -> FStar_Syntax_Syntax.sigelt -> unit) = - fun force -> - fun env1 -> - fun se -> - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_bundle - { FStar_Syntax_Syntax.ses = ses; - FStar_Syntax_Syntax.lids = uu___;_} - -> add_sigelts force env1 ses - | uu___ -> - let lids = FStar_Syntax_Util.lids_of_sigelt se in - (FStar_Compiler_List.iter (try_add_sigelt force env1 se) lids; - add_se_to_attrtab env1 se) -and (add_sigelts : - Prims.bool -> env -> FStar_Syntax_Syntax.sigelt Prims.list -> unit) = - fun force -> - fun env1 -> - fun ses -> FStar_Compiler_List.iter (add_sigelt force env1) ses -let (try_lookup_bv : - env -> - FStar_Syntax_Syntax.bv -> - (FStar_Syntax_Syntax.typ * FStar_Compiler_Range_Type.range) - FStar_Pervasives_Native.option) - = - fun env1 -> - fun bv -> - FStar_Compiler_Util.find_map env1.gamma - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.Binding_var id when - FStar_Syntax_Syntax.bv_eq id bv -> - let uu___1 = - let uu___2 = - FStar_Ident.range_of_id id.FStar_Syntax_Syntax.ppname in - ((id.FStar_Syntax_Syntax.sort), uu___2) in - FStar_Pervasives_Native.Some uu___1 - | uu___1 -> FStar_Pervasives_Native.None) -let (lookup_type_of_let : - FStar_Syntax_Syntax.universes FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.sigelt -> - FStar_Ident.lident -> - ((FStar_Syntax_Syntax.universes * FStar_Syntax_Syntax.term) * - FStar_Compiler_Range_Type.range) FStar_Pervasives_Native.option) - = - fun us_opt -> - fun se -> - fun lid -> - let inst_tscheme1 ts = - match us_opt with - | FStar_Pervasives_Native.None -> inst_tscheme ts - | FStar_Pervasives_Native.Some us -> inst_tscheme_with ts us in - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (uu___, lb::[]); - FStar_Syntax_Syntax.lids1 = uu___1;_} - -> - let uu___2 = - let uu___3 = - inst_tscheme1 - ((lb.FStar_Syntax_Syntax.lbunivs), - (lb.FStar_Syntax_Syntax.lbtyp)) in - let uu___4 = - FStar_Syntax_Syntax.range_of_lbname - lb.FStar_Syntax_Syntax.lbname in - (uu___3, uu___4) in - FStar_Pervasives_Native.Some uu___2 - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (uu___, lbs); - FStar_Syntax_Syntax.lids1 = uu___1;_} - -> - FStar_Compiler_Util.find_map lbs - (fun lb -> - match lb.FStar_Syntax_Syntax.lbname with - | FStar_Pervasives.Inl uu___2 -> failwith "impossible" - | FStar_Pervasives.Inr fv -> - let uu___2 = FStar_Syntax_Syntax.fv_eq_lid fv lid in - if uu___2 - then - let uu___3 = - let uu___4 = - inst_tscheme1 - ((lb.FStar_Syntax_Syntax.lbunivs), - (lb.FStar_Syntax_Syntax.lbtyp)) in - let uu___5 = FStar_Syntax_Syntax.range_of_fv fv in - (uu___4, uu___5) in - FStar_Pervasives_Native.Some uu___3 - else FStar_Pervasives_Native.None) - | uu___ -> FStar_Pervasives_Native.None -let (effect_signature : - FStar_Syntax_Syntax.universes FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.sigelt -> - FStar_Compiler_Range_Type.range -> - ((FStar_Syntax_Syntax.universes * FStar_Syntax_Syntax.typ) * - FStar_Compiler_Range_Type.range) FStar_Pervasives_Native.option) - = - fun us_opt -> - fun se -> - fun rng -> - let inst_ts us_opt1 ts = - match us_opt1 with - | FStar_Pervasives_Native.None -> inst_tscheme ts - | FStar_Pervasives_Native.Some us -> inst_tscheme_with ts us in - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_new_effect ne -> - let sig_ts = - FStar_Syntax_Util.effect_sig_ts - ne.FStar_Syntax_Syntax.signature in - (check_effect_is_not_a_template ne rng; - (match us_opt with - | FStar_Pervasives_Native.None -> () - | FStar_Pervasives_Native.Some us -> - if - (FStar_Compiler_List.length us) <> - (FStar_Compiler_List.length - (FStar_Pervasives_Native.fst sig_ts)) - then - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Ident.string_of_lid - ne.FStar_Syntax_Syntax.mname in - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length - (FStar_Pervasives_Native.fst sig_ts)) in - let uu___8 = - let uu___9 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length us) in - Prims.strcat ", got " uu___9 in - Prims.strcat uu___7 uu___8 in - Prims.strcat ", expected " uu___6 in - Prims.strcat uu___4 uu___5 in - Prims.strcat - "effect_signature: incorrect number of universes for the signature of " - uu___3 in - failwith uu___2 - else ()); - (let uu___2 = - let uu___3 = inst_ts us_opt sig_ts in - (uu___3, (se.FStar_Syntax_Syntax.sigrng)) in - FStar_Pervasives_Native.Some uu___2)) - | FStar_Syntax_Syntax.Sig_effect_abbrev - { FStar_Syntax_Syntax.lid4 = lid; FStar_Syntax_Syntax.us4 = us; - FStar_Syntax_Syntax.bs2 = binders; - FStar_Syntax_Syntax.comp1 = uu___; - FStar_Syntax_Syntax.cflags = uu___1;_} - -> - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Syntax.mk_Total FStar_Syntax_Syntax.teff in - FStar_Syntax_Util.arrow binders uu___6 in - (us, uu___5) in - inst_ts us_opt uu___4 in - (uu___3, (se.FStar_Syntax_Syntax.sigrng)) in - FStar_Pervasives_Native.Some uu___2 - | uu___ -> FStar_Pervasives_Native.None -let (try_lookup_lid_aux : - FStar_Syntax_Syntax.universes FStar_Pervasives_Native.option -> - env -> - FStar_Ident.lident -> - ((FStar_Syntax_Syntax.universes * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax) * FStar_Compiler_Range_Type.range) - FStar_Pervasives_Native.option) - = - fun us_opt -> - fun env1 -> - fun lid -> - let inst_tscheme1 ts = - match us_opt with - | FStar_Pervasives_Native.None -> inst_tscheme ts - | FStar_Pervasives_Native.Some us -> inst_tscheme_with ts us in - let mapper uu___ = - match uu___ with - | (lr, rng) -> - (match lr with - | FStar_Pervasives.Inl t -> - FStar_Pervasives_Native.Some (t, rng) - | FStar_Pervasives.Inr - ({ - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = uu___1; - FStar_Syntax_Syntax.us1 = uvs; - FStar_Syntax_Syntax.t1 = t; - FStar_Syntax_Syntax.ty_lid = uu___2; - FStar_Syntax_Syntax.num_ty_params = uu___3; - FStar_Syntax_Syntax.mutuals1 = uu___4; - FStar_Syntax_Syntax.injective_type_params1 = uu___5;_}; - FStar_Syntax_Syntax.sigrng = uu___6; - FStar_Syntax_Syntax.sigquals = uu___7; - FStar_Syntax_Syntax.sigmeta = uu___8; - FStar_Syntax_Syntax.sigattrs = uu___9; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___10; - FStar_Syntax_Syntax.sigopts = uu___11;_}, - FStar_Pervasives_Native.None) - -> - let uu___12 = - let uu___13 = inst_tscheme1 (uvs, t) in (uu___13, rng) in - FStar_Pervasives_Native.Some uu___12 - | FStar_Pervasives.Inr - ({ - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_declare_typ - { FStar_Syntax_Syntax.lid2 = l; - FStar_Syntax_Syntax.us2 = uvs; - FStar_Syntax_Syntax.t2 = t;_}; - FStar_Syntax_Syntax.sigrng = uu___1; - FStar_Syntax_Syntax.sigquals = qs; - FStar_Syntax_Syntax.sigmeta = uu___2; - FStar_Syntax_Syntax.sigattrs = uu___3; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___4; - FStar_Syntax_Syntax.sigopts = uu___5;_}, - FStar_Pervasives_Native.None) - -> - let uu___6 = - let uu___7 = in_cur_mod env1 l in uu___7 = Yes in - if uu___6 - then - (if - (FStar_Compiler_List.contains - FStar_Syntax_Syntax.Assumption qs) - || env1.is_iface - then - let uu___7 = - let uu___8 = inst_tscheme1 (uvs, t) in - (uu___8, rng) in - FStar_Pervasives_Native.Some uu___7 - else FStar_Pervasives_Native.None) - else - (let uu___8 = - let uu___9 = inst_tscheme1 (uvs, t) in (uu___9, rng) in - FStar_Pervasives_Native.Some uu___8) - | FStar_Pervasives.Inr - ({ - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = lid1; - FStar_Syntax_Syntax.us = uvs; - FStar_Syntax_Syntax.params = tps; - FStar_Syntax_Syntax.num_uniform_params = uu___1; - FStar_Syntax_Syntax.t = k; - FStar_Syntax_Syntax.mutuals = uu___2; - FStar_Syntax_Syntax.ds = uu___3; - FStar_Syntax_Syntax.injective_type_params = uu___4;_}; - FStar_Syntax_Syntax.sigrng = uu___5; - FStar_Syntax_Syntax.sigquals = uu___6; - FStar_Syntax_Syntax.sigmeta = uu___7; - FStar_Syntax_Syntax.sigattrs = uu___8; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___9; - FStar_Syntax_Syntax.sigopts = uu___10;_}, - FStar_Pervasives_Native.None) - -> - (match tps with - | [] -> - let uu___11 = - let uu___12 = inst_tscheme1 (uvs, k) in - (uu___12, rng) in - FStar_Pervasives_Native.Some uu___11 - | uu___11 -> - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = FStar_Syntax_Syntax.mk_Total k in - FStar_Syntax_Util.flat_arrow tps uu___16 in - (uvs, uu___15) in - inst_tscheme1 uu___14 in - (uu___13, rng) in - FStar_Pervasives_Native.Some uu___12) - | FStar_Pervasives.Inr - ({ - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = lid1; - FStar_Syntax_Syntax.us = uvs; - FStar_Syntax_Syntax.params = tps; - FStar_Syntax_Syntax.num_uniform_params = uu___1; - FStar_Syntax_Syntax.t = k; - FStar_Syntax_Syntax.mutuals = uu___2; - FStar_Syntax_Syntax.ds = uu___3; - FStar_Syntax_Syntax.injective_type_params = uu___4;_}; - FStar_Syntax_Syntax.sigrng = uu___5; - FStar_Syntax_Syntax.sigquals = uu___6; - FStar_Syntax_Syntax.sigmeta = uu___7; - FStar_Syntax_Syntax.sigattrs = uu___8; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___9; - FStar_Syntax_Syntax.sigopts = uu___10;_}, - FStar_Pervasives_Native.Some us) - -> - (match tps with - | [] -> - let uu___11 = - let uu___12 = inst_tscheme_with (uvs, k) us in - (uu___12, rng) in - FStar_Pervasives_Native.Some uu___11 - | uu___11 -> - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = FStar_Syntax_Syntax.mk_Total k in - FStar_Syntax_Util.flat_arrow tps uu___16 in - (uvs, uu___15) in - inst_tscheme_with uu___14 us in - (uu___13, rng) in - FStar_Pervasives_Native.Some uu___12) - | FStar_Pervasives.Inr se -> - let uu___1 = - match se with - | ({ - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_let uu___2; - FStar_Syntax_Syntax.sigrng = uu___3; - FStar_Syntax_Syntax.sigquals = uu___4; - FStar_Syntax_Syntax.sigmeta = uu___5; - FStar_Syntax_Syntax.sigattrs = uu___6; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___7; - FStar_Syntax_Syntax.sigopts = uu___8;_}, - FStar_Pervasives_Native.None) -> - lookup_type_of_let us_opt - (FStar_Pervasives_Native.fst se) lid - | uu___2 -> - effect_signature us_opt - (FStar_Pervasives_Native.fst se) env1.range in - FStar_Compiler_Util.map_option - (fun uu___2 -> - match uu___2 with | (us_t, rng1) -> (us_t, rng1)) - uu___1) in - let uu___ = - let uu___1 = lookup_qname env1 lid in - FStar_Compiler_Util.bind_opt uu___1 mapper in - match uu___ with - | FStar_Pervasives_Native.Some ((us, t), r) -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Ident.range_of_lid lid in - { - FStar_Syntax_Syntax.n = (t.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = uu___4; - FStar_Syntax_Syntax.vars = (t.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (t.FStar_Syntax_Syntax.hash_code) - } in - (us, uu___3) in - (uu___2, r) in - FStar_Pervasives_Native.Some uu___1 - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None -let (lid_exists : env -> FStar_Ident.lident -> Prims.bool) = - fun env1 -> - fun l -> - let uu___ = lookup_qname env1 l in - match uu___ with - | FStar_Pervasives_Native.None -> false - | FStar_Pervasives_Native.Some uu___1 -> true -let (lookup_bv : - env -> - FStar_Syntax_Syntax.bv -> - (FStar_Syntax_Syntax.typ * FStar_Compiler_Range_Type.range)) - = - fun env1 -> - fun bv -> - let bvr = FStar_Syntax_Syntax.range_of_bv bv in - let uu___ = try_lookup_bv env1 bv in - match uu___ with - | FStar_Pervasives_Native.None -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_bv bv in - FStar_Compiler_Util.format1 "Variable \"%s\" not found" uu___2 in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range bvr - FStar_Errors_Codes.Fatal_VariableNotFound () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) - | FStar_Pervasives_Native.Some (t, r) -> - let uu___1 = FStar_Syntax_Subst.set_use_range bvr t in - let uu___2 = - let uu___3 = FStar_Compiler_Range_Type.use_range bvr in - FStar_Compiler_Range_Type.set_use_range r uu___3 in - (uu___1, uu___2) -let (try_lookup_lid : - env -> - FStar_Ident.lident -> - ((FStar_Syntax_Syntax.universes * FStar_Syntax_Syntax.typ) * - FStar_Compiler_Range_Type.range) FStar_Pervasives_Native.option) - = - fun env1 -> - fun l -> - let uu___ = try_lookup_lid_aux FStar_Pervasives_Native.None env1 l in - match uu___ with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some ((us, t), r) -> - let use_range = FStar_Ident.range_of_lid l in - let r1 = - let uu___1 = FStar_Compiler_Range_Type.use_range use_range in - FStar_Compiler_Range_Type.set_use_range r uu___1 in - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Subst.set_use_range use_range t in - (us, uu___3) in - (uu___2, r1) in - FStar_Pervasives_Native.Some uu___1 -let (try_lookup_and_inst_lid : - env -> - FStar_Syntax_Syntax.universes -> - FStar_Ident.lident -> - (FStar_Syntax_Syntax.typ * FStar_Compiler_Range_Type.range) - FStar_Pervasives_Native.option) - = - fun env1 -> - fun us -> - fun l -> - let uu___ = - try_lookup_lid_aux (FStar_Pervasives_Native.Some us) env1 l in - match uu___ with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some ((uu___1, t), r) -> - let use_range = FStar_Ident.range_of_lid l in - let r1 = - let uu___2 = FStar_Compiler_Range_Type.use_range use_range in - FStar_Compiler_Range_Type.set_use_range r uu___2 in - let uu___2 = - let uu___3 = FStar_Syntax_Subst.set_use_range use_range t in - (uu___3, r1) in - FStar_Pervasives_Native.Some uu___2 -let name_not_found : 'a . FStar_Ident.lid -> 'a = - fun l -> - let uu___ = - let uu___1 = FStar_Ident.string_of_lid l in - FStar_Compiler_Util.format1 "Name \"%s\" not found" uu___1 in - FStar_Errors.raise_error FStar_Ident.hasrange_lident l - FStar_Errors_Codes.Fatal_NameNotFound () - (Obj.magic FStar_Errors_Msg.is_error_message_string) (Obj.magic uu___) -let (lookup_lid : - env -> - FStar_Ident.lident -> - ((FStar_Syntax_Syntax.universes * FStar_Syntax_Syntax.typ) * - FStar_Compiler_Range_Type.range)) - = - fun env1 -> - fun l -> - let uu___ = try_lookup_lid env1 l in - match uu___ with - | FStar_Pervasives_Native.Some v -> v - | FStar_Pervasives_Native.None -> name_not_found l -let (lookup_univ : env -> FStar_Syntax_Syntax.univ_name -> Prims.bool) = - fun env1 -> - fun x -> - let uu___ = - FStar_Compiler_List.find - (fun uu___1 -> - match uu___1 with - | FStar_Syntax_Syntax.Binding_univ y -> - let uu___2 = FStar_Ident.string_of_id x in - let uu___3 = FStar_Ident.string_of_id y in uu___2 = uu___3 - | uu___2 -> false) env1.gamma in - FStar_Compiler_Option.isSome uu___ -let (try_lookup_val_decl : - env -> - FStar_Ident.lident -> - (FStar_Syntax_Syntax.tscheme * FStar_Syntax_Syntax.qualifier - Prims.list) FStar_Pervasives_Native.option) - = - fun env1 -> - fun lid -> - let uu___ = lookup_qname env1 lid in - match uu___ with - | FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr - ({ - FStar_Syntax_Syntax.sigel = FStar_Syntax_Syntax.Sig_declare_typ - { FStar_Syntax_Syntax.lid2 = uu___1; - FStar_Syntax_Syntax.us2 = uvs; - FStar_Syntax_Syntax.t2 = t;_}; - FStar_Syntax_Syntax.sigrng = uu___2; - FStar_Syntax_Syntax.sigquals = q; - FStar_Syntax_Syntax.sigmeta = uu___3; - FStar_Syntax_Syntax.sigattrs = uu___4; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___5; - FStar_Syntax_Syntax.sigopts = uu___6;_}, - FStar_Pervasives_Native.None), - uu___7) - -> - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = FStar_Ident.range_of_lid lid in - FStar_Syntax_Subst.set_use_range uu___11 t in - (uvs, uu___10) in - (uu___9, q) in - FStar_Pervasives_Native.Some uu___8 - | uu___1 -> FStar_Pervasives_Native.None -let (lookup_val_decl : - env -> - FStar_Ident.lident -> - (FStar_Syntax_Syntax.universes * FStar_Syntax_Syntax.typ)) - = - fun env1 -> - fun lid -> - let uu___ = lookup_qname env1 lid in - match uu___ with - | FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr - ({ - FStar_Syntax_Syntax.sigel = FStar_Syntax_Syntax.Sig_declare_typ - { FStar_Syntax_Syntax.lid2 = uu___1; - FStar_Syntax_Syntax.us2 = uvs; - FStar_Syntax_Syntax.t2 = t;_}; - FStar_Syntax_Syntax.sigrng = uu___2; - FStar_Syntax_Syntax.sigquals = uu___3; - FStar_Syntax_Syntax.sigmeta = uu___4; - FStar_Syntax_Syntax.sigattrs = uu___5; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___6; - FStar_Syntax_Syntax.sigopts = uu___7;_}, - FStar_Pervasives_Native.None), - uu___8) - -> - let uu___9 = FStar_Ident.range_of_lid lid in - inst_tscheme_with_range uu___9 (uvs, t) - | uu___1 -> name_not_found lid -let (lookup_datacon : - env -> - FStar_Ident.lident -> - (FStar_Syntax_Syntax.universes * FStar_Syntax_Syntax.typ)) - = - fun env1 -> - fun lid -> - let uu___ = lookup_qname env1 lid in - match uu___ with - | FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr - ({ - FStar_Syntax_Syntax.sigel = FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = uu___1; - FStar_Syntax_Syntax.us1 = uvs; FStar_Syntax_Syntax.t1 = t; - FStar_Syntax_Syntax.ty_lid = uu___2; - FStar_Syntax_Syntax.num_ty_params = uu___3; - FStar_Syntax_Syntax.mutuals1 = uu___4; - FStar_Syntax_Syntax.injective_type_params1 = uu___5;_}; - FStar_Syntax_Syntax.sigrng = uu___6; - FStar_Syntax_Syntax.sigquals = uu___7; - FStar_Syntax_Syntax.sigmeta = uu___8; - FStar_Syntax_Syntax.sigattrs = uu___9; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___10; - FStar_Syntax_Syntax.sigopts = uu___11;_}, - FStar_Pervasives_Native.None), - uu___12) - -> - let uu___13 = FStar_Ident.range_of_lid lid in - inst_tscheme_with_range uu___13 (uvs, t) - | uu___1 -> name_not_found lid -let (lookup_and_inst_datacon : - env -> - FStar_Syntax_Syntax.universes -> - FStar_Ident.lident -> FStar_Syntax_Syntax.typ) - = - fun env1 -> - fun us -> - fun lid -> - let uu___ = lookup_qname env1 lid in - match uu___ with - | FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr - ({ - FStar_Syntax_Syntax.sigel = FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = uu___1; - FStar_Syntax_Syntax.us1 = uvs; - FStar_Syntax_Syntax.t1 = t; - FStar_Syntax_Syntax.ty_lid = uu___2; - FStar_Syntax_Syntax.num_ty_params = uu___3; - FStar_Syntax_Syntax.mutuals1 = uu___4; - FStar_Syntax_Syntax.injective_type_params1 = uu___5;_}; - FStar_Syntax_Syntax.sigrng = uu___6; - FStar_Syntax_Syntax.sigquals = uu___7; - FStar_Syntax_Syntax.sigmeta = uu___8; - FStar_Syntax_Syntax.sigattrs = uu___9; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___10; - FStar_Syntax_Syntax.sigopts = uu___11;_}, - FStar_Pervasives_Native.None), - uu___12) - -> - let uu___13 = inst_tscheme_with (uvs, t) us in - FStar_Pervasives_Native.snd uu___13 - | uu___1 -> name_not_found lid -let (datacons_of_typ : - env -> FStar_Ident.lident -> (Prims.bool * FStar_Ident.lident Prims.list)) - = - fun env1 -> - fun lid -> - let uu___ = lookup_qname env1 lid in - match uu___ with - | FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr - ({ - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = uu___1; - FStar_Syntax_Syntax.us = uu___2; - FStar_Syntax_Syntax.params = uu___3; - FStar_Syntax_Syntax.num_uniform_params = uu___4; - FStar_Syntax_Syntax.t = uu___5; - FStar_Syntax_Syntax.mutuals = uu___6; - FStar_Syntax_Syntax.ds = dcs; - FStar_Syntax_Syntax.injective_type_params = uu___7;_}; - FStar_Syntax_Syntax.sigrng = uu___8; - FStar_Syntax_Syntax.sigquals = uu___9; - FStar_Syntax_Syntax.sigmeta = uu___10; - FStar_Syntax_Syntax.sigattrs = uu___11; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___12; - FStar_Syntax_Syntax.sigopts = uu___13;_}, - uu___14), - uu___15) - -> (true, dcs) - | uu___1 -> (false, []) -let (typ_of_datacon : env -> FStar_Ident.lident -> FStar_Ident.lident) = - fun env1 -> - fun lid -> - let uu___ = lookup_qname env1 lid in - match uu___ with - | FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr - ({ - FStar_Syntax_Syntax.sigel = FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = uu___1; - FStar_Syntax_Syntax.us1 = uu___2; - FStar_Syntax_Syntax.t1 = uu___3; - FStar_Syntax_Syntax.ty_lid = l; - FStar_Syntax_Syntax.num_ty_params = uu___4; - FStar_Syntax_Syntax.mutuals1 = uu___5; - FStar_Syntax_Syntax.injective_type_params1 = uu___6;_}; - FStar_Syntax_Syntax.sigrng = uu___7; - FStar_Syntax_Syntax.sigquals = uu___8; - FStar_Syntax_Syntax.sigmeta = uu___9; - FStar_Syntax_Syntax.sigattrs = uu___10; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___11; - FStar_Syntax_Syntax.sigopts = uu___12;_}, - uu___13), - uu___14) - -> l - | uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Ident.showable_lident lid in - FStar_Compiler_Util.format1 "Not a datacon: %s" uu___3 in - failwith uu___2 -let (num_datacon_non_injective_ty_params : - env -> FStar_Ident.lident -> Prims.int FStar_Pervasives_Native.option) = - fun env1 -> - fun lid -> - let uu___ = lookup_qname env1 lid in - match uu___ with - | FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr - ({ - FStar_Syntax_Syntax.sigel = FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = uu___1; - FStar_Syntax_Syntax.us1 = uu___2; - FStar_Syntax_Syntax.t1 = uu___3; - FStar_Syntax_Syntax.ty_lid = uu___4; - FStar_Syntax_Syntax.num_ty_params = num_ty_params; - FStar_Syntax_Syntax.mutuals1 = uu___5; - FStar_Syntax_Syntax.injective_type_params1 = - injective_type_params;_}; - FStar_Syntax_Syntax.sigrng = uu___6; - FStar_Syntax_Syntax.sigquals = uu___7; - FStar_Syntax_Syntax.sigmeta = uu___8; - FStar_Syntax_Syntax.sigattrs = uu___9; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___10; - FStar_Syntax_Syntax.sigopts = uu___11;_}, - uu___12), - uu___13) - -> - if injective_type_params - then FStar_Pervasives_Native.Some Prims.int_zero - else FStar_Pervasives_Native.Some num_ty_params - | uu___1 -> FStar_Pervasives_Native.None -let (visible_with : - delta_level Prims.list -> - FStar_Syntax_Syntax.qualifier Prims.list -> Prims.bool) - = - fun delta_levels -> - fun quals -> - FStar_Compiler_Util.for_some - (fun dl -> FStar_Compiler_Util.for_some (visible_at dl) quals) - delta_levels -let (lookup_definition_qninfo_aux : - Prims.bool -> - delta_level Prims.list -> - FStar_Ident.lident -> - qninfo -> - (FStar_Syntax_Syntax.univ_name Prims.list * - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - FStar_Pervasives_Native.option) - = - fun rec_ok -> - fun delta_levels -> - fun lid -> - fun qninfo1 -> - match qninfo1 with - | FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr (se, FStar_Pervasives_Native.None), - uu___) - -> - (match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (is_rec, lbs); - FStar_Syntax_Syntax.lids1 = uu___1;_} - when - (visible_with delta_levels se.FStar_Syntax_Syntax.sigquals) - && ((Prims.op_Negation is_rec) || rec_ok) - -> - FStar_Compiler_Util.find_map lbs - (fun lb -> - let fv = - FStar_Compiler_Util.right - lb.FStar_Syntax_Syntax.lbname in - let uu___2 = FStar_Syntax_Syntax.fv_eq_lid fv lid in - if uu___2 - then - FStar_Pervasives_Native.Some - ((lb.FStar_Syntax_Syntax.lbunivs), - (lb.FStar_Syntax_Syntax.lbdef)) - else FStar_Pervasives_Native.None) - | uu___1 -> FStar_Pervasives_Native.None) - | uu___ -> FStar_Pervasives_Native.None -let (lookup_definition_qninfo : - delta_level Prims.list -> - FStar_Ident.lident -> - qninfo -> - (FStar_Syntax_Syntax.univ_names * FStar_Syntax_Syntax.term) - FStar_Pervasives_Native.option) - = - fun delta_levels -> - fun lid -> - fun qninfo1 -> - lookup_definition_qninfo_aux true delta_levels lid qninfo1 -let (lookup_definition : - delta_level Prims.list -> - env -> - FStar_Ident.lident -> - (FStar_Syntax_Syntax.univ_names * FStar_Syntax_Syntax.term) - FStar_Pervasives_Native.option) - = - fun delta_levels -> - fun env1 -> - fun lid -> - let uu___ = lookup_qname env1 lid in - lookup_definition_qninfo delta_levels lid uu___ -let (lookup_nonrec_definition : - delta_level Prims.list -> - env -> - FStar_Ident.lident -> - (FStar_Syntax_Syntax.univ_names * FStar_Syntax_Syntax.term) - FStar_Pervasives_Native.option) - = - fun delta_levels -> - fun env1 -> - fun lid -> - let uu___ = lookup_qname env1 lid in - lookup_definition_qninfo_aux false delta_levels lid uu___ -let rec (delta_depth_of_qninfo_lid : - env -> FStar_Ident.lident -> qninfo -> FStar_Syntax_Syntax.delta_depth) = - fun env1 -> - fun lid -> - fun qn -> - match qn with - | FStar_Pervasives_Native.None -> FStar_Syntax_Syntax.delta_constant - | FStar_Pervasives_Native.Some (FStar_Pervasives.Inl uu___, uu___1) - -> FStar_Syntax_Syntax.delta_constant - | FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr (se, uu___), uu___1) -> - (match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ uu___2 -> - FStar_Syntax_Syntax.delta_constant - | FStar_Syntax_Syntax.Sig_bundle uu___2 -> - FStar_Syntax_Syntax.delta_constant - | FStar_Syntax_Syntax.Sig_datacon uu___2 -> - FStar_Syntax_Syntax.delta_constant - | FStar_Syntax_Syntax.Sig_declare_typ uu___2 -> - let d0 = - let uu___3 = FStar_Syntax_Util.is_primop_lid lid in - if uu___3 - then FStar_Syntax_Syntax.delta_equational - else FStar_Syntax_Syntax.delta_constant in - let uu___3 = - (FStar_Compiler_Util.for_some - FStar_Syntax_Syntax.uu___is_Assumption - se.FStar_Syntax_Syntax.sigquals) - && - (let uu___4 = - FStar_Compiler_Util.for_some - FStar_Syntax_Syntax.uu___is_New - se.FStar_Syntax_Syntax.sigquals in - Prims.op_Negation uu___4) in - if uu___3 then FStar_Syntax_Syntax.Delta_abstract d0 else d0 - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (uu___2, lbs); - FStar_Syntax_Syntax.lids1 = uu___3;_} - -> - let uu___4 = - FStar_Compiler_Util.find_map lbs - (fun lb -> - let fv = - FStar_Compiler_Util.right - lb.FStar_Syntax_Syntax.lbname in - let uu___5 = FStar_Syntax_Syntax.fv_eq_lid fv lid in - if uu___5 - then - let uu___6 = - let uu___7 = - delta_depth_of_term env1 - lb.FStar_Syntax_Syntax.lbdef in - FStar_Syntax_Util.incr_delta_depth uu___7 in - FStar_Pervasives_Native.Some uu___6 - else FStar_Pervasives_Native.None) in - FStar_Compiler_Util.must uu___4 - | FStar_Syntax_Syntax.Sig_fail uu___2 -> - failwith "impossible: delta_depth_of_qninfo" - | FStar_Syntax_Syntax.Sig_splice uu___2 -> - failwith "impossible: delta_depth_of_qninfo" - | FStar_Syntax_Syntax.Sig_assume uu___2 -> - FStar_Syntax_Syntax.delta_constant - | FStar_Syntax_Syntax.Sig_new_effect uu___2 -> - FStar_Syntax_Syntax.delta_constant - | FStar_Syntax_Syntax.Sig_sub_effect uu___2 -> - FStar_Syntax_Syntax.delta_constant - | FStar_Syntax_Syntax.Sig_effect_abbrev uu___2 -> - FStar_Syntax_Syntax.delta_constant - | FStar_Syntax_Syntax.Sig_pragma uu___2 -> - FStar_Syntax_Syntax.delta_constant - | FStar_Syntax_Syntax.Sig_polymonadic_bind uu___2 -> - FStar_Syntax_Syntax.delta_constant - | FStar_Syntax_Syntax.Sig_polymonadic_subcomp uu___2 -> - FStar_Syntax_Syntax.delta_constant) -and (delta_depth_of_qninfo : - env -> FStar_Syntax_Syntax.fv -> qninfo -> FStar_Syntax_Syntax.delta_depth) - = - fun env1 -> - fun fv -> - fun qn -> - delta_depth_of_qninfo_lid env1 - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v qn -and (delta_depth_of_fv : - env -> FStar_Syntax_Syntax.fv -> FStar_Syntax_Syntax.delta_depth) = - fun env1 -> - fun fv -> - let lid = (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - let uu___ = - let uu___1 = FStar_Ident.string_of_lid lid in - FStar_Compiler_Util.smap_try_find env1.fv_delta_depths uu___1 in - match uu___ with - | FStar_Pervasives_Native.Some dd -> dd - | FStar_Pervasives_Native.None -> - ((let uu___2 = FStar_Ident.string_of_lid lid in - FStar_Compiler_Util.smap_add env1.fv_delta_depths uu___2 - FStar_Syntax_Syntax.delta_equational); - (let d = - let uu___2 = - lookup_qname env1 - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - delta_depth_of_qninfo env1 fv uu___2 in - (let uu___3 = FStar_Ident.string_of_lid lid in - FStar_Compiler_Util.smap_add env1.fv_delta_depths uu___3 d); - d)) -and (fv_delta_depth : - env -> FStar_Syntax_Syntax.fv -> FStar_Syntax_Syntax.delta_depth) = - fun env1 -> - fun fv -> - let d = delta_depth_of_fv env1 fv in - match d with - | FStar_Syntax_Syntax.Delta_abstract - (FStar_Syntax_Syntax.Delta_constant_at_level l) -> - let uu___ = - (let uu___1 = FStar_Ident.string_of_lid env1.curmodule in - let uu___2 = - FStar_Ident.nsstr - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - uu___1 = uu___2) && (Prims.op_Negation env1.is_iface) in - if uu___ - then FStar_Syntax_Syntax.Delta_constant_at_level l - else FStar_Syntax_Syntax.delta_constant - | d1 -> d1 -and (delta_depth_of_term : - env -> FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.delta_depth) = - fun env1 -> - fun t -> - let t1 = FStar_Syntax_Util.unmeta t in - match t1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_meta uu___ -> - failwith "Impossible (delta depth of term)" - | FStar_Syntax_Syntax.Tm_delayed uu___ -> - failwith "Impossible (delta depth of term)" - | FStar_Syntax_Syntax.Tm_lazy i -> - let uu___ = FStar_Syntax_Util.unfold_lazy i in - delta_depth_of_term env1 uu___ - | FStar_Syntax_Syntax.Tm_fvar fv -> fv_delta_depth env1 fv - | FStar_Syntax_Syntax.Tm_bvar uu___ -> - FStar_Syntax_Syntax.delta_equational - | FStar_Syntax_Syntax.Tm_name uu___ -> - FStar_Syntax_Syntax.delta_equational - | FStar_Syntax_Syntax.Tm_match uu___ -> - FStar_Syntax_Syntax.delta_equational - | FStar_Syntax_Syntax.Tm_uvar uu___ -> - FStar_Syntax_Syntax.delta_equational - | FStar_Syntax_Syntax.Tm_unknown -> - FStar_Syntax_Syntax.delta_equational - | FStar_Syntax_Syntax.Tm_type uu___ -> - FStar_Syntax_Syntax.delta_constant - | FStar_Syntax_Syntax.Tm_quoted uu___ -> - FStar_Syntax_Syntax.delta_constant - | FStar_Syntax_Syntax.Tm_constant uu___ -> - FStar_Syntax_Syntax.delta_constant - | FStar_Syntax_Syntax.Tm_arrow uu___ -> - FStar_Syntax_Syntax.delta_constant - | FStar_Syntax_Syntax.Tm_uinst (t2, uu___) -> - delta_depth_of_term env1 t2 - | FStar_Syntax_Syntax.Tm_refine - { - FStar_Syntax_Syntax.b = - { FStar_Syntax_Syntax.ppname = uu___; - FStar_Syntax_Syntax.index = uu___1; - FStar_Syntax_Syntax.sort = t2;_}; - FStar_Syntax_Syntax.phi = uu___2;_} - -> delta_depth_of_term env1 t2 - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t2; FStar_Syntax_Syntax.asc = uu___; - FStar_Syntax_Syntax.eff_opt = uu___1;_} - -> delta_depth_of_term env1 t2 - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = t2; FStar_Syntax_Syntax.args = uu___;_} - -> delta_depth_of_term env1 t2 - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = uu___; FStar_Syntax_Syntax.body = t2; - FStar_Syntax_Syntax.rc_opt = uu___1;_} - -> delta_depth_of_term env1 t2 - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = uu___; - FStar_Syntax_Syntax.body1 = t2;_} - -> delta_depth_of_term env1 t2 -let (quals_of_qninfo : - qninfo -> - FStar_Syntax_Syntax.qualifier Prims.list FStar_Pervasives_Native.option) - = - fun qninfo1 -> - match qninfo1 with - | FStar_Pervasives_Native.Some (FStar_Pervasives.Inr (se, uu___), uu___1) - -> FStar_Pervasives_Native.Some (se.FStar_Syntax_Syntax.sigquals) - | uu___ -> FStar_Pervasives_Native.None -let (attrs_of_qninfo : - qninfo -> - FStar_Syntax_Syntax.attribute Prims.list FStar_Pervasives_Native.option) - = - fun qninfo1 -> - match qninfo1 with - | FStar_Pervasives_Native.Some (FStar_Pervasives.Inr (se, uu___), uu___1) - -> FStar_Pervasives_Native.Some (se.FStar_Syntax_Syntax.sigattrs) - | uu___ -> FStar_Pervasives_Native.None -let (lookup_attrs_of_lid : - env -> - FStar_Ident.lid -> - FStar_Syntax_Syntax.attribute Prims.list FStar_Pervasives_Native.option) - = - fun env1 -> - fun lid -> let uu___ = lookup_qname env1 lid in attrs_of_qninfo uu___ -let (fv_exists_and_has_attr : - env -> FStar_Ident.lid -> FStar_Ident.lident -> (Prims.bool * Prims.bool)) - = - fun env1 -> - fun fv_lid -> - fun attr_lid -> - let uu___ = lookup_attrs_of_lid env1 fv_lid in - match uu___ with - | FStar_Pervasives_Native.None -> (false, false) - | FStar_Pervasives_Native.Some attrs -> - let uu___1 = - FStar_Compiler_Util.for_some - (fun tm -> - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst tm in - uu___3.FStar_Syntax_Syntax.n in - match uu___2 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - FStar_Syntax_Syntax.fv_eq_lid fv attr_lid - | uu___3 -> false) attrs in - (true, uu___1) -let (fv_with_lid_has_attr : - env -> FStar_Ident.lid -> FStar_Ident.lid -> Prims.bool) = - fun env1 -> - fun fv_lid -> - fun attr_lid -> - let uu___ = fv_exists_and_has_attr env1 fv_lid attr_lid in - FStar_Pervasives_Native.snd uu___ -let (fv_has_attr : - env -> FStar_Syntax_Syntax.fv -> FStar_Ident.lid -> Prims.bool) = - fun env1 -> - fun fv -> - fun attr_lid -> - fv_with_lid_has_attr env1 - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v attr_lid -let cache_in_fv_tab : - 'a . - 'a FStar_Compiler_Util.smap -> - FStar_Syntax_Syntax.fv -> (unit -> (Prims.bool * 'a)) -> 'a - = - fun tab -> - fun fv -> - fun f -> - let s = - let uu___ = FStar_Syntax_Syntax.lid_of_fv fv in - FStar_Ident.string_of_lid uu___ in - let uu___ = FStar_Compiler_Util.smap_try_find tab s in - match uu___ with - | FStar_Pervasives_Native.None -> - let uu___1 = f () in - (match uu___1 with - | (should_cache, res) -> - (if should_cache - then FStar_Compiler_Util.smap_add tab s res - else (); - res)) - | FStar_Pervasives_Native.Some r -> r -let (fv_has_erasable_attr : env -> FStar_Syntax_Syntax.fv -> Prims.bool) = - fun env1 -> - fun fv -> - let f uu___ = - let uu___1 = - fv_exists_and_has_attr env1 - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - FStar_Parser_Const.erasable_attr in - match uu___1 with | (ex, erasable) -> (ex, erasable) in - cache_in_fv_tab env1.erasable_types_tab fv f -let (fv_has_strict_args : - env -> - FStar_Syntax_Syntax.fv -> - Prims.int Prims.list FStar_Pervasives_Native.option) - = - fun env1 -> - fun fv -> - let f uu___ = - let attrs = - let uu___1 = FStar_Syntax_Syntax.lid_of_fv fv in - lookup_attrs_of_lid env1 uu___1 in - match attrs with - | FStar_Pervasives_Native.None -> - (false, FStar_Pervasives_Native.None) - | FStar_Pervasives_Native.Some attrs1 -> - let res = - FStar_Compiler_Util.find_map attrs1 - (fun x -> - let uu___1 = - FStar_ToSyntax_ToSyntax.parse_attr_with_list false x - FStar_Parser_Const.strict_on_arguments_attr in - FStar_Pervasives_Native.fst uu___1) in - (true, res) in - cache_in_fv_tab env1.strict_args_tab fv f -let (try_lookup_effect_lid : - env -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = - fun env1 -> - fun ftv -> - let uu___ = lookup_qname env1 ftv in - match uu___ with - | FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr (se, FStar_Pervasives_Native.None), uu___1) - -> - let uu___2 = - effect_signature FStar_Pervasives_Native.None se env1.range in - (match uu___2 with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some ((uu___3, t), r) -> - let uu___4 = - let uu___5 = FStar_Ident.range_of_lid ftv in - FStar_Syntax_Subst.set_use_range uu___5 t in - FStar_Pervasives_Native.Some uu___4) - | uu___1 -> FStar_Pervasives_Native.None -let (lookup_effect_lid : - env -> FStar_Ident.lident -> FStar_Syntax_Syntax.term) = - fun env1 -> - fun ftv -> - let uu___ = try_lookup_effect_lid env1 ftv in - match uu___ with - | FStar_Pervasives_Native.None -> name_not_found ftv - | FStar_Pervasives_Native.Some k -> k -let (lookup_effect_abbrev : - env -> - FStar_Syntax_Syntax.universes -> - FStar_Ident.lident -> - (FStar_Syntax_Syntax.binders * FStar_Syntax_Syntax.comp) - FStar_Pervasives_Native.option) - = - fun env1 -> - fun univ_insts -> - fun lid0 -> - let uu___ = lookup_qname env1 lid0 in - match uu___ with - | FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr - ({ - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_effect_abbrev - { FStar_Syntax_Syntax.lid4 = lid; - FStar_Syntax_Syntax.us4 = univs; - FStar_Syntax_Syntax.bs2 = binders; - FStar_Syntax_Syntax.comp1 = c; - FStar_Syntax_Syntax.cflags = uu___1;_}; - FStar_Syntax_Syntax.sigrng = uu___2; - FStar_Syntax_Syntax.sigquals = quals; - FStar_Syntax_Syntax.sigmeta = uu___3; - FStar_Syntax_Syntax.sigattrs = uu___4; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___5; - FStar_Syntax_Syntax.sigopts = uu___6;_}, - FStar_Pervasives_Native.None), - uu___7) - -> - let lid1 = - let uu___8 = - let uu___9 = FStar_Ident.range_of_lid lid in - let uu___10 = - let uu___11 = FStar_Ident.range_of_lid lid0 in - FStar_Compiler_Range_Type.use_range uu___11 in - FStar_Compiler_Range_Type.set_use_range uu___9 uu___10 in - FStar_Ident.set_lid_range lid uu___8 in - let uu___8 = - FStar_Compiler_Util.for_some - (fun uu___9 -> - match uu___9 with - | FStar_Syntax_Syntax.Irreducible -> true - | uu___10 -> false) quals in - if uu___8 - then FStar_Pervasives_Native.None - else - (let insts = - if - (FStar_Compiler_List.length univ_insts) = - (FStar_Compiler_List.length univs) - then univ_insts - else - (let uu___11 = - let uu___12 = - let uu___13 = get_range env1 in - FStar_Compiler_Range_Ops.string_of_range uu___13 in - let uu___13 = - FStar_Class_Show.show FStar_Ident.showable_lident - lid1 in - let uu___14 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length univ_insts) in - FStar_Compiler_Util.format3 - "(%s) Unexpected instantiation of effect %s with %s universes" - uu___12 uu___13 uu___14 in - failwith uu___11) in - match (binders, univs) with - | ([], uu___10) -> - failwith - "Unexpected effect abbreviation with no arguments" - | (uu___10, uu___11::uu___12::uu___13) -> - let uu___14 = - let uu___15 = - FStar_Class_Show.show FStar_Ident.showable_lident lid1 in - let uu___16 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length univs) in - FStar_Compiler_Util.format2 - "Unexpected effect abbreviation %s; polymorphic in %s universes" - uu___15 uu___16 in - failwith uu___14 - | uu___10 -> - let uu___11 = - let uu___12 = - let uu___13 = FStar_Syntax_Util.arrow binders c in - (univs, uu___13) in - inst_tscheme_with uu___12 insts in - (match uu___11 with - | (uu___12, t) -> - let t1 = - let uu___13 = FStar_Ident.range_of_lid lid1 in - FStar_Syntax_Subst.set_use_range uu___13 t in - let uu___13 = - let uu___14 = FStar_Syntax_Subst.compress t1 in - uu___14.FStar_Syntax_Syntax.n in - (match uu___13 with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = binders1; - FStar_Syntax_Syntax.comp = c1;_} - -> FStar_Pervasives_Native.Some (binders1, c1) - | uu___14 -> failwith "Impossible"))) - | uu___1 -> FStar_Pervasives_Native.None -let (norm_eff_name : env -> FStar_Ident.lident -> FStar_Ident.lident) = - fun env1 -> - fun l -> - let rec find l1 = - let uu___ = - lookup_effect_abbrev env1 [FStar_Syntax_Syntax.U_unknown] l1 in - match uu___ with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (uu___1, c) -> - let l2 = FStar_Syntax_Util.comp_effect_name c in - let uu___2 = find l2 in - (match uu___2 with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.Some l2 - | FStar_Pervasives_Native.Some l' -> - FStar_Pervasives_Native.Some l') in - let res = - let uu___ = - let uu___1 = FStar_Ident.string_of_lid l in - FStar_Compiler_Util.smap_try_find env1.normalized_eff_names uu___1 in - match uu___ with - | FStar_Pervasives_Native.Some l1 -> l1 - | FStar_Pervasives_Native.None -> - let uu___1 = find l in - (match uu___1 with - | FStar_Pervasives_Native.None -> l - | FStar_Pervasives_Native.Some m -> - ((let uu___3 = FStar_Ident.string_of_lid l in - FStar_Compiler_Util.smap_add env1.normalized_eff_names - uu___3 m); - m)) in - let uu___ = FStar_Ident.range_of_lid l in - FStar_Ident.set_lid_range res uu___ -let (is_erasable_effect : env -> FStar_Ident.lident -> Prims.bool) = - fun env1 -> - fun l -> - let uu___ = norm_eff_name env1 l in - (FStar_Ident.lid_equals uu___ FStar_Parser_Const.effect_GHOST_lid) || - (let uu___1 = - FStar_Syntax_Syntax.lid_as_fv uu___ FStar_Pervasives_Native.None in - fv_has_erasable_attr env1 uu___1) -let rec (non_informative : env -> FStar_Syntax_Syntax.typ -> Prims.bool) = - fun env1 -> - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Util.unrefine t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_type uu___1 -> true - | FStar_Syntax_Syntax.Tm_fvar fv -> - (((FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.unit_lid) || - (FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.squash_lid)) - || - (FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.erased_lid)) - || (fv_has_erasable_attr env1 fv) - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = uu___1;_} - -> non_informative env1 head - | FStar_Syntax_Syntax.Tm_uinst (t1, uu___1) -> non_informative env1 t1 - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = uu___1; FStar_Syntax_Syntax.comp = c;_} - -> - ((FStar_Syntax_Util.is_pure_or_ghost_comp c) && - (non_informative env1 (FStar_Syntax_Util.comp_result c))) - || - (is_erasable_effect env1 (FStar_Syntax_Util.comp_effect_name c)) - | uu___1 -> false -let (num_effect_indices : - env -> FStar_Ident.lident -> FStar_Compiler_Range_Type.range -> Prims.int) - = - fun env1 -> - fun name -> - fun r -> - let sig_t = - let uu___ = lookup_effect_lid env1 name in - FStar_Syntax_Subst.compress uu___ in - match sig_t.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = _a::bs; - FStar_Syntax_Syntax.comp = uu___;_} - -> FStar_Compiler_List.length bs - | uu___ -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Ident.showable_lident name in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term sig_t in - FStar_Compiler_Util.format2 - "Signature for %s not an arrow (%s)" uu___2 uu___3 in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_UnexpectedSignatureForMonad () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) -let (lookup_effect_quals : - env -> FStar_Ident.lident -> FStar_Syntax_Syntax.qualifier Prims.list) = - fun env1 -> - fun l -> - let l1 = norm_eff_name env1 l in - let uu___ = lookup_qname env1 l1 in - match uu___ with - | FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr - ({ - FStar_Syntax_Syntax.sigel = FStar_Syntax_Syntax.Sig_new_effect - uu___1; - FStar_Syntax_Syntax.sigrng = uu___2; - FStar_Syntax_Syntax.sigquals = q; - FStar_Syntax_Syntax.sigmeta = uu___3; - FStar_Syntax_Syntax.sigattrs = uu___4; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___5; - FStar_Syntax_Syntax.sigopts = uu___6;_}, - uu___7), - uu___8) - -> q - | uu___1 -> [] -let (lookup_projector : - env -> FStar_Ident.lident -> Prims.int -> FStar_Ident.lident) = - fun env1 -> - fun lid -> - fun i -> - let fail uu___ = - let uu___1 = - let uu___2 = FStar_Compiler_Util.string_of_int i in - let uu___3 = - FStar_Class_Show.show FStar_Ident.showable_lident lid in - FStar_Compiler_Util.format2 - "Impossible: projecting field #%s from constructor %s is undefined" - uu___2 uu___3 in - failwith uu___1 in - let uu___ = lookup_datacon env1 lid in - match uu___ with - | (uu___1, t) -> - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress t in - uu___3.FStar_Syntax_Syntax.n in - (match uu___2 with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = binders; - FStar_Syntax_Syntax.comp = uu___3;_} - -> - if - (i < Prims.int_zero) || - (i >= (FStar_Compiler_List.length binders)) - then fail () - else - (let b = FStar_Compiler_List.nth binders i in - FStar_Syntax_Util.mk_field_projector_name lid - b.FStar_Syntax_Syntax.binder_bv i) - | uu___3 -> fail ()) -let (is_projector : env -> FStar_Ident.lident -> Prims.bool) = - fun env1 -> - fun l -> - let uu___ = lookup_qname env1 l in - match uu___ with - | FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr - ({ - FStar_Syntax_Syntax.sigel = FStar_Syntax_Syntax.Sig_declare_typ - uu___1; - FStar_Syntax_Syntax.sigrng = uu___2; - FStar_Syntax_Syntax.sigquals = quals; - FStar_Syntax_Syntax.sigmeta = uu___3; - FStar_Syntax_Syntax.sigattrs = uu___4; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___5; - FStar_Syntax_Syntax.sigopts = uu___6;_}, - uu___7), - uu___8) - -> - FStar_Compiler_Util.for_some - (fun uu___9 -> - match uu___9 with - | FStar_Syntax_Syntax.Projector uu___10 -> true - | uu___10 -> false) quals - | uu___1 -> false -let (is_datacon : env -> FStar_Ident.lident -> Prims.bool) = - fun env1 -> - fun lid -> - let uu___ = lookup_qname env1 lid in - match uu___ with - | FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr - ({ - FStar_Syntax_Syntax.sigel = FStar_Syntax_Syntax.Sig_datacon - uu___1; - FStar_Syntax_Syntax.sigrng = uu___2; - FStar_Syntax_Syntax.sigquals = uu___3; - FStar_Syntax_Syntax.sigmeta = uu___4; - FStar_Syntax_Syntax.sigattrs = uu___5; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___6; - FStar_Syntax_Syntax.sigopts = uu___7;_}, - uu___8), - uu___9) - -> true - | uu___1 -> false -let (is_record : env -> FStar_Ident.lident -> Prims.bool) = - fun env1 -> - fun lid -> - let uu___ = lookup_qname env1 lid in - match uu___ with - | FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr - ({ - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_inductive_typ uu___1; - FStar_Syntax_Syntax.sigrng = uu___2; - FStar_Syntax_Syntax.sigquals = quals; - FStar_Syntax_Syntax.sigmeta = uu___3; - FStar_Syntax_Syntax.sigattrs = uu___4; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___5; - FStar_Syntax_Syntax.sigopts = uu___6;_}, - uu___7), - uu___8) - -> - FStar_Compiler_Util.for_some - (fun uu___9 -> - match uu___9 with - | FStar_Syntax_Syntax.RecordType uu___10 -> true - | FStar_Syntax_Syntax.RecordConstructor uu___10 -> true - | uu___10 -> false) quals - | uu___1 -> false -let (qninfo_is_action : qninfo -> Prims.bool) = - fun qninfo1 -> - match qninfo1 with - | FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr - ({ FStar_Syntax_Syntax.sigel = FStar_Syntax_Syntax.Sig_let uu___; - FStar_Syntax_Syntax.sigrng = uu___1; - FStar_Syntax_Syntax.sigquals = quals; - FStar_Syntax_Syntax.sigmeta = uu___2; - FStar_Syntax_Syntax.sigattrs = uu___3; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___4; - FStar_Syntax_Syntax.sigopts = uu___5;_}, - uu___6), - uu___7) - -> - FStar_Compiler_Util.for_some - (fun uu___8 -> - match uu___8 with - | FStar_Syntax_Syntax.Action uu___9 -> true - | uu___9 -> false) quals - | uu___ -> false -let (is_action : env -> FStar_Ident.lident -> Prims.bool) = - fun env1 -> - fun lid -> let uu___ = lookup_qname env1 lid in qninfo_is_action uu___ -let (is_interpreted : env -> FStar_Syntax_Syntax.term -> Prims.bool) = - let interpreted_symbols = - [FStar_Parser_Const.op_Eq; - FStar_Parser_Const.op_notEq; - FStar_Parser_Const.op_LT; - FStar_Parser_Const.op_LTE; - FStar_Parser_Const.op_GT; - FStar_Parser_Const.op_GTE; - FStar_Parser_Const.op_Subtraction; - FStar_Parser_Const.op_Minus; - FStar_Parser_Const.op_Addition; - FStar_Parser_Const.op_Multiply; - FStar_Parser_Const.op_Division; - FStar_Parser_Const.op_Modulus; - FStar_Parser_Const.op_And; - FStar_Parser_Const.op_Or; - FStar_Parser_Const.op_Negation] in - fun env1 -> - fun head -> - let uu___ = - let uu___1 = FStar_Syntax_Util.un_uinst head in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_fvar fv -> - (FStar_Compiler_Util.for_some - (FStar_Ident.lid_equals - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v) - interpreted_symbols) - || - (let uu___1 = delta_depth_of_fv env1 fv in - (match uu___1 with - | FStar_Syntax_Syntax.Delta_equational_at_level uu___2 -> true - | uu___2 -> false)) - | uu___1 -> false -let (is_irreducible : env -> FStar_Ident.lident -> Prims.bool) = - fun env1 -> - fun l -> - let uu___ = lookup_qname env1 l in - match uu___ with - | FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr (se, uu___1), uu___2) -> - FStar_Compiler_Util.for_some - (fun uu___3 -> - match uu___3 with - | FStar_Syntax_Syntax.Irreducible -> true - | uu___4 -> false) se.FStar_Syntax_Syntax.sigquals - | uu___1 -> false -let (is_type_constructor : env -> FStar_Ident.lident -> Prims.bool) = - fun env1 -> - fun lid -> - let mapper x = - match FStar_Pervasives_Native.fst x with - | FStar_Pervasives.Inl uu___ -> FStar_Pervasives_Native.Some false - | FStar_Pervasives.Inr (se, uu___) -> - (match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_declare_typ uu___1 -> - FStar_Pervasives_Native.Some - (FStar_Compiler_List.contains FStar_Syntax_Syntax.New - se.FStar_Syntax_Syntax.sigquals) - | FStar_Syntax_Syntax.Sig_inductive_typ uu___1 -> - FStar_Pervasives_Native.Some true - | uu___1 -> FStar_Pervasives_Native.Some false) in - let uu___ = - let uu___1 = lookup_qname env1 lid in - FStar_Compiler_Util.bind_opt uu___1 mapper in - match uu___ with - | FStar_Pervasives_Native.Some b -> b - | FStar_Pervasives_Native.None -> false -let (num_inductive_ty_params : - env -> FStar_Ident.lident -> Prims.int FStar_Pervasives_Native.option) = - fun env1 -> - fun lid -> - let uu___ = lookup_qname env1 lid in - match uu___ with - | FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr - ({ - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = uu___1; - FStar_Syntax_Syntax.us = uu___2; - FStar_Syntax_Syntax.params = tps; - FStar_Syntax_Syntax.num_uniform_params = uu___3; - FStar_Syntax_Syntax.t = uu___4; - FStar_Syntax_Syntax.mutuals = uu___5; - FStar_Syntax_Syntax.ds = uu___6; - FStar_Syntax_Syntax.injective_type_params = uu___7;_}; - FStar_Syntax_Syntax.sigrng = uu___8; - FStar_Syntax_Syntax.sigquals = uu___9; - FStar_Syntax_Syntax.sigmeta = uu___10; - FStar_Syntax_Syntax.sigattrs = uu___11; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___12; - FStar_Syntax_Syntax.sigopts = uu___13;_}, - uu___14), - uu___15) - -> FStar_Pervasives_Native.Some (FStar_Compiler_List.length tps) - | uu___1 -> FStar_Pervasives_Native.None -let (num_inductive_uniform_ty_params : - env -> FStar_Ident.lident -> Prims.int FStar_Pervasives_Native.option) = - fun env1 -> - fun lid -> - let uu___ = lookup_qname env1 lid in - match uu___ with - | FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr - ({ - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = uu___1; - FStar_Syntax_Syntax.us = uu___2; - FStar_Syntax_Syntax.params = uu___3; - FStar_Syntax_Syntax.num_uniform_params = num_uniform; - FStar_Syntax_Syntax.t = uu___4; - FStar_Syntax_Syntax.mutuals = uu___5; - FStar_Syntax_Syntax.ds = uu___6; - FStar_Syntax_Syntax.injective_type_params = uu___7;_}; - FStar_Syntax_Syntax.sigrng = uu___8; - FStar_Syntax_Syntax.sigquals = uu___9; - FStar_Syntax_Syntax.sigmeta = uu___10; - FStar_Syntax_Syntax.sigattrs = uu___11; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___12; - FStar_Syntax_Syntax.sigopts = uu___13;_}, - uu___14), - uu___15) - -> - (match num_uniform with - | FStar_Pervasives_Native.None -> - let uu___16 = - let uu___17 = - FStar_Class_Show.show FStar_Ident.showable_lident lid in - FStar_Compiler_Util.format1 - "Internal error: Inductive %s is not decorated with its uniform type parameters" - uu___17 in - FStar_Errors.raise_error FStar_Ident.hasrange_lident lid - FStar_Errors_Codes.Fatal_UnexpectedInductivetype () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___16) - | FStar_Pervasives_Native.Some n -> FStar_Pervasives_Native.Some n) - | uu___1 -> FStar_Pervasives_Native.None -let (effect_decl_opt : - env -> - FStar_Ident.lident -> - (FStar_Syntax_Syntax.eff_decl * FStar_Syntax_Syntax.qualifier - Prims.list) FStar_Pervasives_Native.option) - = - fun env1 -> - fun l -> - FStar_Compiler_Util.find_opt - (fun uu___ -> - match uu___ with - | (d, uu___1) -> - FStar_Ident.lid_equals d.FStar_Syntax_Syntax.mname l) - (env1.effects).decls -let (get_effect_decl : - env -> FStar_Ident.lident -> FStar_Syntax_Syntax.eff_decl) = - fun env1 -> - fun l -> - let uu___ = effect_decl_opt env1 l in - match uu___ with - | FStar_Pervasives_Native.None -> name_not_found l - | FStar_Pervasives_Native.Some md -> FStar_Pervasives_Native.fst md -let (get_lid_valued_effect_attr : - env -> - FStar_Ident.lident -> - FStar_Ident.lident -> - FStar_Ident.lident FStar_Pervasives_Native.option -> - FStar_Ident.lident FStar_Pervasives_Native.option) - = - fun env1 -> - fun eff_lid -> - fun attr_name_lid -> - fun default_if_attr_has_no_arg -> - let attr_args = - let uu___ = - let uu___1 = - let uu___2 = norm_eff_name env1 eff_lid in - lookup_attrs_of_lid env1 uu___2 in - FStar_Compiler_Util.dflt [] uu___1 in - FStar_Syntax_Util.get_attribute attr_name_lid uu___ in - match attr_args with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some args -> - if (FStar_Compiler_List.length args) = Prims.int_zero - then default_if_attr_has_no_arg - else - (let uu___1 = FStar_Compiler_List.hd args in - match uu___1 with - | (t, uu___2) -> - let uu___3 = - let uu___4 = FStar_Syntax_Subst.compress t in - uu___4.FStar_Syntax_Syntax.n in - (match uu___3 with - | FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_string (s, uu___4)) -> - let uu___5 = FStar_Ident.lid_of_str s in - FStar_Pervasives_Native.Some uu___5 - | uu___4 -> - let uu___5 = - let uu___6 = - FStar_Class_Show.show - FStar_Ident.showable_lident eff_lid in - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.format2 - "The argument for the effect attribute for %s is not a constant string, it is %s\n" - uu___6 uu___7 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) t - FStar_Errors_Codes.Fatal_UnexpectedEffect () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___5))) -let (get_default_effect : - env -> - FStar_Ident.lident -> FStar_Ident.lident FStar_Pervasives_Native.option) - = - fun env1 -> - fun lid -> - get_lid_valued_effect_attr env1 lid - FStar_Parser_Const.default_effect_attr FStar_Pervasives_Native.None -let (get_top_level_effect : - env -> - FStar_Ident.lident -> FStar_Ident.lident FStar_Pervasives_Native.option) - = - fun env1 -> - fun lid -> - get_lid_valued_effect_attr env1 lid - FStar_Parser_Const.top_level_effect_attr - (FStar_Pervasives_Native.Some lid) -let (is_layered_effect : env -> FStar_Ident.lident -> Prims.bool) = - fun env1 -> - fun l -> - let uu___ = get_effect_decl env1 l in - FStar_Syntax_Util.is_layered uu___ -let (identity_mlift : mlift) = - { - mlift_wp = - (fun uu___ -> fun c -> (c, FStar_TypeChecker_Common.trivial_guard)); - mlift_term = - (FStar_Pervasives_Native.Some - (fun uu___ -> - fun uu___1 -> fun e -> FStar_Compiler_Util.return_all e)) - } -let (join_opt : - env -> - FStar_Ident.lident -> - FStar_Ident.lident -> - (FStar_Ident.lident * mlift * mlift) FStar_Pervasives_Native.option) - = - fun env1 -> - fun l1 -> - fun l2 -> - let uu___ = FStar_Ident.lid_equals l1 l2 in - if uu___ - then - FStar_Pervasives_Native.Some (l1, identity_mlift, identity_mlift) - else - (let uu___2 = - ((FStar_Ident.lid_equals l1 FStar_Parser_Const.effect_GTot_lid) - && - (FStar_Ident.lid_equals l2 FStar_Parser_Const.effect_Tot_lid)) - || - ((FStar_Ident.lid_equals l2 FStar_Parser_Const.effect_GTot_lid) - && - (FStar_Ident.lid_equals l1 - FStar_Parser_Const.effect_Tot_lid)) in - if uu___2 - then - FStar_Pervasives_Native.Some - (FStar_Parser_Const.effect_GTot_lid, identity_mlift, - identity_mlift) - else - (let uu___4 = - FStar_Compiler_Util.find_opt - (fun uu___5 -> - match uu___5 with - | (m1, m2, uu___6, uu___7, uu___8) -> - (FStar_Ident.lid_equals l1 m1) && - (FStar_Ident.lid_equals l2 m2)) - (env1.effects).joins in - match uu___4 with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (uu___5, uu___6, m3, j1, j2) -> - FStar_Pervasives_Native.Some (m3, j1, j2))) -let (join : - env -> - FStar_Ident.lident -> - FStar_Ident.lident -> (FStar_Ident.lident * mlift * mlift)) - = - fun env1 -> - fun l1 -> - fun l2 -> - let uu___ = join_opt env1 l1 l2 in - match uu___ with - | FStar_Pervasives_Native.None -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Ident.showable_lident l1 in - let uu___3 = - FStar_Class_Show.show FStar_Ident.showable_lident l2 in - FStar_Compiler_Util.format2 - "Effects %s and %s cannot be composed" uu___2 uu___3 in - FStar_Errors.raise_error hasRange_env env1 - FStar_Errors_Codes.Fatal_EffectsCannotBeComposed () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) - | FStar_Pervasives_Native.Some t -> t -let (monad_leq : - env -> - FStar_Ident.lident -> - FStar_Ident.lident -> edge FStar_Pervasives_Native.option) - = - fun env1 -> - fun l1 -> - fun l2 -> - let uu___ = - (FStar_Ident.lid_equals l1 l2) || - ((FStar_Ident.lid_equals l1 FStar_Parser_Const.effect_Tot_lid) && - (FStar_Ident.lid_equals l2 FStar_Parser_Const.effect_GTot_lid)) in - if uu___ - then - FStar_Pervasives_Native.Some - { msource = l1; mtarget = l2; mlift = identity_mlift; mpath = [] - } - else - FStar_Compiler_Util.find_opt - (fun e -> - (FStar_Ident.lid_equals l1 e.msource) && - (FStar_Ident.lid_equals l2 e.mtarget)) (env1.effects).order -let wp_sig_aux : - 'uuuuu . - (FStar_Syntax_Syntax.eff_decl * 'uuuuu) Prims.list -> - FStar_Ident.lident -> - (FStar_Syntax_Syntax.bv * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax) - = - fun decls -> - fun m -> - let uu___ = - FStar_Compiler_Util.find_opt - (fun uu___1 -> - match uu___1 with - | (d, uu___2) -> - FStar_Ident.lid_equals d.FStar_Syntax_Syntax.mname m) decls in - match uu___ with - | FStar_Pervasives_Native.None -> - let uu___1 = - let uu___2 = FStar_Ident.string_of_lid m in - FStar_Compiler_Util.format1 - "Impossible: declaration for monad %s not found" uu___2 in - failwith uu___1 - | FStar_Pervasives_Native.Some (md, _q) -> - let uu___1 = - let uu___2 = - FStar_Syntax_Util.effect_sig_ts - md.FStar_Syntax_Syntax.signature in - inst_tscheme uu___2 in - (match uu___1 with - | (uu___2, s) -> - let s1 = FStar_Syntax_Subst.compress s in - (match ((md.FStar_Syntax_Syntax.binders), - (s1.FStar_Syntax_Syntax.n)) - with - | ([], FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = b::wp_b::[]; - FStar_Syntax_Syntax.comp = c;_}) - when - FStar_Syntax_Syntax.is_teff - (FStar_Syntax_Util.comp_result c) - -> - ((b.FStar_Syntax_Syntax.binder_bv), - ((wp_b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort)) - | uu___3 -> failwith "Impossible")) -let (wp_signature : - env -> - FStar_Ident.lident -> (FStar_Syntax_Syntax.bv * FStar_Syntax_Syntax.term)) - = fun env1 -> fun m -> wp_sig_aux (env1.effects).decls m -let (bound_vars_of_bindings : - FStar_Syntax_Syntax.binding Prims.list -> FStar_Syntax_Syntax.bv Prims.list) - = - fun bs -> - FStar_Compiler_List.collect - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.Binding_var x -> [x] - | FStar_Syntax_Syntax.Binding_lid uu___1 -> [] - | FStar_Syntax_Syntax.Binding_univ uu___1 -> []) bs -let (binders_of_bindings : - FStar_Syntax_Syntax.binding Prims.list -> FStar_Syntax_Syntax.binders) = - fun bs -> - let uu___ = - let uu___1 = bound_vars_of_bindings bs in - FStar_Compiler_List.map FStar_Syntax_Syntax.mk_binder uu___1 in - FStar_Compiler_List.rev uu___ -let (all_binders : env -> FStar_Syntax_Syntax.binders) = - fun env1 -> binders_of_bindings env1.gamma -let (bound_vars : env -> FStar_Syntax_Syntax.bv Prims.list) = - fun env1 -> bound_vars_of_bindings env1.gamma -let (hasBinders_env : env FStar_Class_Binders.hasBinders) = - { - FStar_Class_Binders.boundNames = - (fun uu___ -> - (fun e -> - let uu___ = bound_vars e in - Obj.magic - (FStar_Class_Setlike.from_list () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) uu___)) uu___) - } -let (hasNames_lcomp : - FStar_TypeChecker_Common.lcomp FStar_Class_Binders.hasNames) = - { - FStar_Class_Binders.freeNames = - (fun lc -> - let uu___ = - let uu___1 = FStar_TypeChecker_Common.lcomp_comp lc in - FStar_Pervasives_Native.fst uu___1 in - FStar_Class_Binders.freeNames FStar_Class_Binders.hasNames_comp - uu___) - } -let (pretty_lcomp : FStar_TypeChecker_Common.lcomp FStar_Class_PP.pretty) = - { FStar_Class_PP.pp = (fun lc -> FStar_Pprint.empty) } -let (hasNames_guard : guard_t FStar_Class_Binders.hasNames) = - { - FStar_Class_Binders.freeNames = - (fun uu___ -> - (fun g -> - match g.FStar_TypeChecker_Common.guard_f with - | FStar_TypeChecker_Common.Trivial -> - Obj.magic - (Obj.repr - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) ())) - | FStar_TypeChecker_Common.NonTrivial f -> - Obj.magic - (Obj.repr - (FStar_Class_Binders.freeNames - FStar_Class_Binders.hasNames_term f))) uu___) - } -let (pretty_guard : guard_t FStar_Class_PP.pretty) = - { - FStar_Class_PP.pp = - (fun g -> - match g.FStar_TypeChecker_Common.guard_f with - | FStar_TypeChecker_Common.Trivial -> - FStar_Pprint.doc_of_string "Trivial" - | FStar_TypeChecker_Common.NonTrivial f -> - let uu___ = FStar_Pprint.doc_of_string "NonTrivial" in - let uu___1 = FStar_Class_PP.pp FStar_Syntax_Print.pretty_term f in - FStar_Pprint.op_Hat_Slash_Hat uu___ uu___1) - } -let (comp_to_comp_typ : - env -> FStar_Syntax_Syntax.comp -> FStar_Syntax_Syntax.comp_typ) = - fun env1 -> - fun c -> - FStar_Defensive.def_check_scoped hasBinders_env - FStar_Class_Binders.hasNames_comp FStar_Syntax_Print.pretty_comp - c.FStar_Syntax_Syntax.pos "comp_to_comp_typ" env1 c; - (match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Comp ct -> ct - | uu___1 -> - let uu___2 = - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total t -> - (FStar_Parser_Const.effect_Tot_lid, t) - | FStar_Syntax_Syntax.GTotal t -> - (FStar_Parser_Const.effect_GTot_lid, t) in - (match uu___2 with - | (effect_name, result_typ) -> - let uu___3 = - let uu___4 = env1.universe_of env1 result_typ in [uu___4] in - { - FStar_Syntax_Syntax.comp_univs = uu___3; - FStar_Syntax_Syntax.effect_name = effect_name; - FStar_Syntax_Syntax.result_typ = result_typ; - FStar_Syntax_Syntax.effect_args = []; - FStar_Syntax_Syntax.flags = - (FStar_Syntax_Util.comp_flags c) - })) -let (comp_set_flags : - env -> - FStar_Syntax_Syntax.comp -> - FStar_Syntax_Syntax.cflag Prims.list -> FStar_Syntax_Syntax.comp) - = - fun env1 -> - fun c -> - fun f -> - FStar_Defensive.def_check_scoped hasBinders_env - FStar_Class_Binders.hasNames_comp FStar_Syntax_Print.pretty_comp - c.FStar_Syntax_Syntax.pos "comp_set_flags.IN" env1 c; - (let r = - let uu___1 = - let uu___2 = - let uu___3 = comp_to_comp_typ env1 c in - { - FStar_Syntax_Syntax.comp_univs = - (uu___3.FStar_Syntax_Syntax.comp_univs); - FStar_Syntax_Syntax.effect_name = - (uu___3.FStar_Syntax_Syntax.effect_name); - FStar_Syntax_Syntax.result_typ = - (uu___3.FStar_Syntax_Syntax.result_typ); - FStar_Syntax_Syntax.effect_args = - (uu___3.FStar_Syntax_Syntax.effect_args); - FStar_Syntax_Syntax.flags = f - } in - FStar_Syntax_Syntax.Comp uu___2 in - { - FStar_Syntax_Syntax.n = uu___1; - FStar_Syntax_Syntax.pos = (c.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = (c.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (c.FStar_Syntax_Syntax.hash_code) - } in - FStar_Defensive.def_check_scoped hasBinders_env - FStar_Class_Binders.hasNames_comp FStar_Syntax_Print.pretty_comp - c.FStar_Syntax_Syntax.pos "comp_set_flags.OUT" env1 r; - r) -let rec (unfold_effect_abbrev : - env -> FStar_Syntax_Syntax.comp -> FStar_Syntax_Syntax.comp_typ) = - fun env1 -> - fun comp -> - FStar_Defensive.def_check_scoped hasBinders_env - FStar_Class_Binders.hasNames_comp FStar_Syntax_Print.pretty_comp - comp.FStar_Syntax_Syntax.pos "unfold_effect_abbrev" env1 comp; - (let c = comp_to_comp_typ env1 comp in - let uu___1 = - lookup_effect_abbrev env1 c.FStar_Syntax_Syntax.comp_univs - c.FStar_Syntax_Syntax.effect_name in - match uu___1 with - | FStar_Pervasives_Native.None -> c - | FStar_Pervasives_Native.Some (binders, cdef) -> - let uu___2 = FStar_Syntax_Subst.open_comp binders cdef in - (match uu___2 with - | (binders1, cdef1) -> - (if - (FStar_Compiler_List.length binders1) <> - ((FStar_Compiler_List.length - c.FStar_Syntax_Syntax.effect_args) - + Prims.int_one) - then - (let uu___4 = - let uu___5 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_nat) - (FStar_Compiler_List.length binders1) in - let uu___6 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - ((FStar_Compiler_List.length - c.FStar_Syntax_Syntax.effect_args) - + Prims.int_one) in - let uu___7 = - let uu___8 = FStar_Syntax_Syntax.mk_Comp c in - FStar_Class_Show.show - FStar_Syntax_Print.showable_comp uu___8 in - FStar_Compiler_Util.format3 - "Effect constructor is not fully applied; expected %s args, got %s args, i.e., %s" - uu___5 uu___6 uu___7 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) comp - FStar_Errors_Codes.Fatal_ConstructorArgLengthMismatch - () (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4)) - else (); - (let inst = - let uu___4 = - let uu___5 = - FStar_Syntax_Syntax.as_arg - c.FStar_Syntax_Syntax.result_typ in - uu___5 :: (c.FStar_Syntax_Syntax.effect_args) in - FStar_Compiler_List.map2 - (fun b -> - fun uu___5 -> - match uu___5 with - | (t, uu___6) -> - FStar_Syntax_Syntax.NT - ((b.FStar_Syntax_Syntax.binder_bv), t)) - binders1 uu___4 in - let c1 = FStar_Syntax_Subst.subst_comp inst cdef1 in - let c2 = - let uu___4 = - let uu___5 = comp_to_comp_typ env1 c1 in - { - FStar_Syntax_Syntax.comp_univs = - (uu___5.FStar_Syntax_Syntax.comp_univs); - FStar_Syntax_Syntax.effect_name = - (uu___5.FStar_Syntax_Syntax.effect_name); - FStar_Syntax_Syntax.result_typ = - (uu___5.FStar_Syntax_Syntax.result_typ); - FStar_Syntax_Syntax.effect_args = - (uu___5.FStar_Syntax_Syntax.effect_args); - FStar_Syntax_Syntax.flags = - (c.FStar_Syntax_Syntax.flags) - } in - FStar_Syntax_Syntax.mk_Comp uu___4 in - unfold_effect_abbrev env1 c2)))) -let effect_repr_aux : - 'uuuuu . - 'uuuuu -> - env -> - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - FStar_Pervasives_Native.option - = - fun only_reifiable -> - fun env1 -> - fun c -> - fun u_res -> - let check_partial_application eff_name args = - let r = get_range env1 in - let uu___ = - let uu___1 = num_effect_indices env1 eff_name r in - ((FStar_Compiler_List.length args), uu___1) in - match uu___ with - | (given, expected) -> - if given = expected - then () - else - (let message = - let uu___2 = FStar_Ident.string_of_lid eff_name in - let uu___3 = FStar_Compiler_Util.string_of_int given in - let uu___4 = FStar_Compiler_Util.string_of_int expected in - FStar_Compiler_Util.format3 - "Not enough arguments for effect %s, This usually happens when you use a partially applied DM4F effect, like [TAC int] instead of [Tac int] (given:%s, expected:%s)." - uu___2 uu___3 uu___4 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_NotEnoughArgumentsForEffect () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic message)) in - let effect_name = - norm_eff_name env1 (FStar_Syntax_Util.comp_effect_name c) in - let uu___ = effect_decl_opt env1 effect_name in - match uu___ with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (ed, uu___1) -> - let uu___2 = FStar_Syntax_Util.get_eff_repr ed in - (match uu___2 with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some ts -> - let c1 = unfold_effect_abbrev env1 c in - let res_typ = c1.FStar_Syntax_Syntax.result_typ in - let repr = inst_effect_fun_with [u_res] env1 ed ts in - (check_partial_application effect_name - c1.FStar_Syntax_Syntax.effect_args; - (let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = FStar_Syntax_Syntax.as_arg res_typ in - uu___8 :: (c1.FStar_Syntax_Syntax.effect_args) in - { - FStar_Syntax_Syntax.hd = repr; - FStar_Syntax_Syntax.args = uu___7 - } in - FStar_Syntax_Syntax.Tm_app uu___6 in - let uu___6 = get_range env1 in - FStar_Syntax_Syntax.mk uu___5 uu___6 in - FStar_Pervasives_Native.Some uu___4))) -let (effect_repr : - env -> - FStar_Syntax_Syntax.comp -> - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = fun env1 -> fun c -> fun u_res -> effect_repr_aux false env1 c u_res -let (is_user_reifiable_effect : env -> FStar_Ident.lident -> Prims.bool) = - fun env1 -> - fun effect_lid -> - let effect_lid1 = norm_eff_name env1 effect_lid in - let quals = lookup_effect_quals env1 effect_lid1 in - FStar_Compiler_List.contains FStar_Syntax_Syntax.Reifiable quals -let (is_user_reflectable_effect : env -> FStar_Ident.lident -> Prims.bool) = - fun env1 -> - fun effect_lid -> - let effect_lid1 = norm_eff_name env1 effect_lid in - let quals = lookup_effect_quals env1 effect_lid1 in - FStar_Compiler_List.existsb - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.Reflectable uu___1 -> true - | uu___1 -> false) quals -let (is_total_effect : env -> FStar_Ident.lident -> Prims.bool) = - fun env1 -> - fun effect_lid -> - let effect_lid1 = norm_eff_name env1 effect_lid in - let quals = lookup_effect_quals env1 effect_lid1 in - FStar_Compiler_List.contains FStar_Syntax_Syntax.TotalEffect quals -let (is_reifiable_effect : env -> FStar_Ident.lident -> Prims.bool) = - fun env1 -> - fun effect_lid -> - let effect_lid1 = norm_eff_name env1 effect_lid in - (is_user_reifiable_effect env1 effect_lid1) || - (FStar_Ident.lid_equals effect_lid1 FStar_Parser_Const.effect_TAC_lid) -let (is_reifiable_rc : - env -> FStar_Syntax_Syntax.residual_comp -> Prims.bool) = - fun env1 -> - fun c -> is_reifiable_effect env1 c.FStar_Syntax_Syntax.residual_effect -let (is_reifiable_comp : env -> FStar_Syntax_Syntax.comp -> Prims.bool) = - fun env1 -> - fun c -> - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Comp ct -> - is_reifiable_effect env1 ct.FStar_Syntax_Syntax.effect_name - | uu___ -> false -let (is_reifiable_function : env -> FStar_Syntax_Syntax.term -> Prims.bool) = - fun env1 -> - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = uu___1; FStar_Syntax_Syntax.comp = c;_} - -> is_reifiable_comp env1 c - | uu___1 -> false -let (reify_comp : - env -> - FStar_Syntax_Syntax.comp -> - FStar_Syntax_Syntax.universe -> FStar_Syntax_Syntax.term) - = - fun env1 -> - fun c -> - fun u_c -> - let l = FStar_Syntax_Util.comp_effect_name c in - (let uu___1 = - let uu___2 = is_reifiable_effect env1 l in - Prims.op_Negation uu___2 in - if uu___1 - then - let uu___2 = - let uu___3 = FStar_Ident.string_of_lid l in - FStar_Compiler_Util.format1 "Effect %s cannot be reified" uu___3 in - FStar_Errors.raise_error hasRange_env env1 - FStar_Errors_Codes.Fatal_EffectCannotBeReified () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2) - else ()); - (let uu___1 = effect_repr_aux true env1 c u_c in - match uu___1 with - | FStar_Pervasives_Native.None -> - failwith "internal error: reifiable effect has no repr?" - | FStar_Pervasives_Native.Some tm -> tm) -let rec (record_vals_and_defns : env -> FStar_Syntax_Syntax.sigelt -> env) = - fun g -> - fun se -> - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_declare_typ uu___ when - FStar_Compiler_Util.for_some - (fun uu___1 -> - match uu___1 with - | FStar_Syntax_Syntax.OnlyName -> true - | uu___2 -> false) se.FStar_Syntax_Syntax.sigquals - -> g - | FStar_Syntax_Syntax.Sig_let uu___ when - FStar_Compiler_Util.for_some - (fun uu___1 -> - match uu___1 with - | FStar_Syntax_Syntax.OnlyName -> true - | uu___2 -> false) se.FStar_Syntax_Syntax.sigquals - -> g - | FStar_Syntax_Syntax.Sig_declare_typ - { FStar_Syntax_Syntax.lid2 = lid; FStar_Syntax_Syntax.us2 = uu___; - FStar_Syntax_Syntax.t2 = uu___1;_} - -> - if - (FStar_Compiler_List.contains FStar_Syntax_Syntax.Assumption - se.FStar_Syntax_Syntax.sigquals) - || g.is_iface - then g - else record_val_for g lid - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = uu___; - FStar_Syntax_Syntax.lids1 = lids;_} - -> FStar_Compiler_List.fold_left record_definition_for g lids - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = lid; FStar_Syntax_Syntax.us1 = uu___; - FStar_Syntax_Syntax.t1 = uu___1; - FStar_Syntax_Syntax.ty_lid = uu___2; - FStar_Syntax_Syntax.num_ty_params = uu___3; - FStar_Syntax_Syntax.mutuals1 = uu___4; - FStar_Syntax_Syntax.injective_type_params1 = uu___5;_} - -> record_definition_for g lid - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = lid; FStar_Syntax_Syntax.us = uu___; - FStar_Syntax_Syntax.params = uu___1; - FStar_Syntax_Syntax.num_uniform_params = uu___2; - FStar_Syntax_Syntax.t = uu___3; - FStar_Syntax_Syntax.mutuals = uu___4; - FStar_Syntax_Syntax.ds = uu___5; - FStar_Syntax_Syntax.injective_type_params = uu___6;_} - -> record_definition_for g lid - | FStar_Syntax_Syntax.Sig_bundle - { FStar_Syntax_Syntax.ses = ses; - FStar_Syntax_Syntax.lids = uu___;_} - -> FStar_Compiler_List.fold_left record_vals_and_defns g ses - | uu___ -> g -let (push_sigelt' : Prims.bool -> env -> FStar_Syntax_Syntax.sigelt -> env) = - fun force -> - fun env1 -> - fun s -> - let sb = ((FStar_Syntax_Util.lids_of_sigelt s), s) in - let env2 = - { - solver = (env1.solver); - range = (env1.range); - curmodule = (env1.curmodule); - gamma = (env1.gamma); - gamma_sig = (sb :: (env1.gamma_sig)); - gamma_cache = (env1.gamma_cache); - modules = (env1.modules); - expected_typ = (env1.expected_typ); - sigtab = (env1.sigtab); - attrtab = (env1.attrtab); - instantiate_imp = (env1.instantiate_imp); - effects = (env1.effects); - generalize = (env1.generalize); - letrecs = (env1.letrecs); - top_level = (env1.top_level); - check_uvars = (env1.check_uvars); - use_eq_strict = (env1.use_eq_strict); - is_iface = (env1.is_iface); - admit = (env1.admit); - lax_universes = (env1.lax_universes); - phase1 = (env1.phase1); - failhard = (env1.failhard); - flychecking = (env1.flychecking); - uvar_subtyping = (env1.uvar_subtyping); - intactics = (env1.intactics); - nocoerce = (env1.nocoerce); - tc_term = (env1.tc_term); - typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); - universe_of = (env1.universe_of); - typeof_well_typed_tot_or_gtot_term = - (env1.typeof_well_typed_tot_or_gtot_term); - teq_nosmt_force = (env1.teq_nosmt_force); - subtype_nosmt_force = (env1.subtype_nosmt_force); - qtbl_name_and_index = (env1.qtbl_name_and_index); - normalized_eff_names = (env1.normalized_eff_names); - fv_delta_depths = (env1.fv_delta_depths); - proof_ns = (env1.proof_ns); - synth_hook = (env1.synth_hook); - try_solve_implicits_hook = (env1.try_solve_implicits_hook); - splice = (env1.splice); - mpreprocess = (env1.mpreprocess); - postprocess = (env1.postprocess); - identifier_info = (env1.identifier_info); - tc_hooks = (env1.tc_hooks); - dsenv = (env1.dsenv); - nbe = (env1.nbe); - strict_args_tab = (env1.strict_args_tab); - erasable_types_tab = (env1.erasable_types_tab); - enable_defer_to_tac = (env1.enable_defer_to_tac); - unif_allow_ref_guards = (env1.unif_allow_ref_guards); - erase_erasable_args = (env1.erase_erasable_args); - core_check = (env1.core_check); - missing_decl = (env1.missing_decl) - } in - add_sigelt force env2 s; - (env2.tc_hooks).tc_push_in_gamma_hook env2 (FStar_Pervasives.Inr sb); - (let env3 = record_vals_and_defns env2 s in env3) -let (push_sigelt : env -> FStar_Syntax_Syntax.sigelt -> env) = - push_sigelt' false -let (push_sigelt_force : env -> FStar_Syntax_Syntax.sigelt -> env) = - push_sigelt' true -let (push_new_effect : - env -> - (FStar_Syntax_Syntax.eff_decl * FStar_Syntax_Syntax.qualifier Prims.list) - -> env) - = - fun env1 -> - fun uu___ -> - match uu___ with - | (ed, quals) -> - let effects1 = - let uu___1 = env1.effects in - { - decls = - (FStar_Compiler_List.op_At (env1.effects).decls [(ed, quals)]); - order = (uu___1.order); - joins = (uu___1.joins); - polymonadic_binds = (uu___1.polymonadic_binds); - polymonadic_subcomps = (uu___1.polymonadic_subcomps) - } in - { - solver = (env1.solver); - range = (env1.range); - curmodule = (env1.curmodule); - gamma = (env1.gamma); - gamma_sig = (env1.gamma_sig); - gamma_cache = (env1.gamma_cache); - modules = (env1.modules); - expected_typ = (env1.expected_typ); - sigtab = (env1.sigtab); - attrtab = (env1.attrtab); - instantiate_imp = (env1.instantiate_imp); - effects = effects1; - generalize = (env1.generalize); - letrecs = (env1.letrecs); - top_level = (env1.top_level); - check_uvars = (env1.check_uvars); - use_eq_strict = (env1.use_eq_strict); - is_iface = (env1.is_iface); - admit = (env1.admit); - lax_universes = (env1.lax_universes); - phase1 = (env1.phase1); - failhard = (env1.failhard); - flychecking = (env1.flychecking); - uvar_subtyping = (env1.uvar_subtyping); - intactics = (env1.intactics); - nocoerce = (env1.nocoerce); - tc_term = (env1.tc_term); - typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); - universe_of = (env1.universe_of); - typeof_well_typed_tot_or_gtot_term = - (env1.typeof_well_typed_tot_or_gtot_term); - teq_nosmt_force = (env1.teq_nosmt_force); - subtype_nosmt_force = (env1.subtype_nosmt_force); - qtbl_name_and_index = (env1.qtbl_name_and_index); - normalized_eff_names = (env1.normalized_eff_names); - fv_delta_depths = (env1.fv_delta_depths); - proof_ns = (env1.proof_ns); - synth_hook = (env1.synth_hook); - try_solve_implicits_hook = (env1.try_solve_implicits_hook); - splice = (env1.splice); - mpreprocess = (env1.mpreprocess); - postprocess = (env1.postprocess); - identifier_info = (env1.identifier_info); - tc_hooks = (env1.tc_hooks); - dsenv = (env1.dsenv); - nbe = (env1.nbe); - strict_args_tab = (env1.strict_args_tab); - erasable_types_tab = (env1.erasable_types_tab); - enable_defer_to_tac = (env1.enable_defer_to_tac); - unif_allow_ref_guards = (env1.unif_allow_ref_guards); - erase_erasable_args = (env1.erase_erasable_args); - core_check = (env1.core_check); - missing_decl = (env1.missing_decl) - } -let (exists_polymonadic_bind : - env -> - FStar_Ident.lident -> - FStar_Ident.lident -> - (FStar_Ident.lident * polymonadic_bind_t) - FStar_Pervasives_Native.option) - = - fun env1 -> - fun m -> - fun n -> - let uu___ = - FStar_Compiler_Util.find_opt - (fun uu___1 -> - match uu___1 with - | (m1, n1, uu___2, uu___3) -> - (FStar_Ident.lid_equals m m1) && - (FStar_Ident.lid_equals n n1)) - (env1.effects).polymonadic_binds in - match uu___ with - | FStar_Pervasives_Native.Some (uu___1, uu___2, p, t) -> - FStar_Pervasives_Native.Some (p, t) - | uu___1 -> FStar_Pervasives_Native.None -let (exists_polymonadic_subcomp : - env -> - FStar_Ident.lident -> - FStar_Ident.lident -> - (FStar_Syntax_Syntax.tscheme * - FStar_Syntax_Syntax.indexed_effect_combinator_kind) - FStar_Pervasives_Native.option) - = - fun env1 -> - fun m -> - fun n -> - let uu___ = - FStar_Compiler_Util.find_opt - (fun uu___1 -> - match uu___1 with - | (m1, n1, uu___2, uu___3) -> - (FStar_Ident.lid_equals m m1) && - (FStar_Ident.lid_equals n n1)) - (env1.effects).polymonadic_subcomps in - match uu___ with - | FStar_Pervasives_Native.Some (uu___1, uu___2, ts, k) -> - FStar_Pervasives_Native.Some (ts, k) - | uu___1 -> FStar_Pervasives_Native.None -let (print_effects_graph : env -> Prims.string) = - fun env1 -> - let eff_name lid = - let uu___ = FStar_Ident.ident_of_lid lid in - FStar_Ident.string_of_id uu___ in - let path_str path = - let uu___ = FStar_Compiler_List.map eff_name path in - FStar_Compiler_String.concat ";" uu___ in - let pbinds = FStar_Compiler_Util.smap_create (Prims.of_int (10)) in - let lifts = FStar_Compiler_Util.smap_create (Prims.of_int (20)) in - let psubcomps = FStar_Compiler_Util.smap_create (Prims.of_int (10)) in - FStar_Compiler_List.iter - (fun uu___1 -> - match uu___1 with - | { msource = src; mtarget = tgt; mlift = uu___2; mpath = path;_} -> - let key = eff_name src in - let m = - let uu___3 = FStar_Compiler_Util.smap_try_find lifts key in - match uu___3 with - | FStar_Pervasives_Native.None -> - let m1 = - FStar_Compiler_Util.smap_create (Prims.of_int (10)) in - (FStar_Compiler_Util.smap_add lifts key m1; m1) - | FStar_Pervasives_Native.Some m1 -> m1 in - let uu___3 = - let uu___4 = eff_name tgt in - FStar_Compiler_Util.smap_try_find m uu___4 in - (match uu___3 with - | FStar_Pervasives_Native.Some uu___4 -> () - | FStar_Pervasives_Native.None -> - let uu___4 = eff_name tgt in - let uu___5 = path_str path in - FStar_Compiler_Util.smap_add m uu___4 uu___5)) - (env1.effects).order; - FStar_Compiler_List.iter - (fun uu___2 -> - match uu___2 with - | (m, n, p, uu___3) -> - let key = - let uu___4 = eff_name m in - let uu___5 = eff_name n in - let uu___6 = eff_name p in - FStar_Compiler_Util.format3 "%s, %s |> %s" uu___4 uu___5 - uu___6 in - FStar_Compiler_Util.smap_add pbinds key "") - (env1.effects).polymonadic_binds; - FStar_Compiler_List.iter - (fun uu___3 -> - match uu___3 with - | (m, n, uu___4, uu___5) -> - let key = - let uu___6 = eff_name m in - let uu___7 = eff_name n in - FStar_Compiler_Util.format2 "%s <: %s" uu___6 uu___7 in - FStar_Compiler_Util.smap_add psubcomps key "") - (env1.effects).polymonadic_subcomps; - (let uu___3 = - let uu___4 = - FStar_Compiler_Util.smap_fold lifts - (fun src -> - fun m -> - fun s -> - FStar_Compiler_Util.smap_fold m - (fun tgt -> - fun path -> - fun s1 -> - let uu___5 = - FStar_Compiler_Util.format3 - "%s -> %s [label=\"%s\"]" src tgt path in - uu___5 :: s1) s) [] in - FStar_Compiler_String.concat "\n" uu___4 in - let uu___4 = - let uu___5 = - FStar_Compiler_Util.smap_fold pbinds - (fun k -> - fun uu___6 -> - fun s -> - let uu___7 = - FStar_Compiler_Util.format1 - "\"%s\" [shape=\"plaintext\"]" k in - uu___7 :: s) [] in - FStar_Compiler_String.concat "\n" uu___5 in - let uu___5 = - let uu___6 = - FStar_Compiler_Util.smap_fold psubcomps - (fun k -> - fun uu___7 -> - fun s -> - let uu___8 = - FStar_Compiler_Util.format1 - "\"%s\" [shape=\"plaintext\"]" k in - uu___8 :: s) [] in - FStar_Compiler_String.concat "\n" uu___6 in - FStar_Compiler_Util.format3 - "digraph {\nlabel=\"Effects ordering\"\nsubgraph cluster_lifts {\nlabel = \"Lifts\"\n\n %s\n}\nsubgraph cluster_polymonadic_binds {\nlabel = \"Polymonadic binds\"\n%s\n}\nsubgraph cluster_polymonadic_subcomps {\nlabel = \"Polymonadic subcomps\"\n%s\n}}\n" - uu___3 uu___4 uu___5) -let (update_effect_lattice : - env -> FStar_Ident.lident -> FStar_Ident.lident -> mlift -> env) = - fun env1 -> - fun src -> - fun tgt -> - fun st_mlift -> - let compose_edges e1 e2 = - let composed_lift = - let mlift_wp env2 c = - let uu___ = (e1.mlift).mlift_wp env2 c in - match uu___ with - | (c1, g1) -> - let uu___1 = (e2.mlift).mlift_wp env2 c1 in - (match uu___1 with - | (c2, g2) -> - let uu___2 = - FStar_TypeChecker_Common.conj_guard g1 g2 in - (c2, uu___2)) in - let mlift_term = - match (((e1.mlift).mlift_term), ((e2.mlift).mlift_term)) with - | (FStar_Pervasives_Native.Some l1, - FStar_Pervasives_Native.Some l2) -> - FStar_Pervasives_Native.Some - ((fun u -> - fun t -> - fun e -> let uu___ = l1 u t e in l2 u t uu___)) - | uu___ -> FStar_Pervasives_Native.None in - { mlift_wp; mlift_term } in - { - msource = (e1.msource); - mtarget = (e2.mtarget); - mlift = composed_lift; - mpath = - (FStar_Compiler_List.op_At e1.mpath - (FStar_Compiler_List.op_At [e1.mtarget] e2.mpath)) - } in - let edge1 = - { msource = src; mtarget = tgt; mlift = st_mlift; mpath = [] } in - let id_edge l = - { - msource = src; - mtarget = tgt; - mlift = identity_mlift; - mpath = [] - } in - let find_edge order uu___ = - match uu___ with - | (i, j) -> - let uu___1 = FStar_Ident.lid_equals i j in - if uu___1 - then FStar_Pervasives_Native.Some (id_edge i) - else - FStar_Compiler_Util.find_opt - (fun e -> - (FStar_Ident.lid_equals e.msource i) && - (FStar_Ident.lid_equals e.mtarget j)) order in - let ms = - FStar_Compiler_List.map - (fun uu___ -> - match uu___ with - | (e, uu___1) -> e.FStar_Syntax_Syntax.mname) - (env1.effects).decls in - let all_i_src = - FStar_Compiler_List.fold_left - (fun edges -> - fun i -> - let uu___ = FStar_Ident.lid_equals i edge1.msource in - if uu___ - then edges - else - (let uu___2 = - find_edge (env1.effects).order (i, (edge1.msource)) in - match uu___2 with - | FStar_Pervasives_Native.Some e -> e :: edges - | FStar_Pervasives_Native.None -> edges)) [] ms in - let all_tgt_j = - FStar_Compiler_List.fold_left - (fun edges -> - fun j -> - let uu___ = FStar_Ident.lid_equals edge1.mtarget j in - if uu___ - then edges - else - (let uu___2 = - find_edge (env1.effects).order ((edge1.mtarget), j) in - match uu___2 with - | FStar_Pervasives_Native.Some e -> e :: edges - | FStar_Pervasives_Native.None -> edges)) [] ms in - let check_cycle src1 tgt1 = - let uu___ = FStar_Ident.lid_equals src1 tgt1 in - if uu___ - then - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Ident.showable_lident - edge1.msource in - let uu___3 = - FStar_Class_Show.show FStar_Ident.showable_lident - edge1.mtarget in - let uu___4 = - FStar_Class_Show.show FStar_Ident.showable_lident src1 in - FStar_Compiler_Util.format3 - "Adding an edge %s~>%s induces a cycle %s" uu___2 uu___3 - uu___4 in - FStar_Errors.raise_error hasRange_env env1 - FStar_Errors_Codes.Fatal_Effects_Ordering_Coherence () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) - else () in - let new_i_edge_target = - FStar_Compiler_List.fold_left - (fun edges -> - fun i_src -> - check_cycle i_src.msource edge1.mtarget; - (let uu___1 = compose_edges i_src edge1 in uu___1 :: edges)) - [] all_i_src in - let new_edge_source_j = - FStar_Compiler_List.fold_left - (fun edges -> - fun tgt_j -> - check_cycle edge1.msource tgt_j.mtarget; - (let uu___1 = compose_edges edge1 tgt_j in uu___1 :: edges)) - [] all_tgt_j in - let new_i_j = - FStar_Compiler_List.fold_left - (fun edges -> - fun i_src -> - FStar_Compiler_List.fold_left - (fun edges1 -> - fun tgt_j -> - check_cycle i_src.msource tgt_j.mtarget; - (let uu___1 = - let uu___2 = compose_edges i_src edge1 in - compose_edges uu___2 tgt_j in - uu___1 :: edges1)) edges all_tgt_j) [] all_i_src in - let new_edges = edge1 :: - (FStar_Compiler_List.op_At new_i_edge_target - (FStar_Compiler_List.op_At new_edge_source_j new_i_j)) in - let order = - FStar_Compiler_List.op_At new_edges (env1.effects).order in - FStar_Compiler_List.iter - (fun edge2 -> - let uu___1 = - (FStar_Ident.lid_equals edge2.msource - FStar_Parser_Const.effect_DIV_lid) - && - (let uu___2 = lookup_effect_quals env1 edge2.mtarget in - FStar_Compiler_List.contains - FStar_Syntax_Syntax.TotalEffect uu___2) in - if uu___1 - then - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Ident.showable_lident - edge2.mtarget in - FStar_Compiler_Util.format1 - "Divergent computations cannot be included in an effect %s marked 'total'" - uu___3 in - FStar_Errors.raise_error hasRange_env env1 - FStar_Errors_Codes.Fatal_DivergentComputationCannotBeIncludedInTotal - () (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2) - else ()) order; - (let joins = - let ubs = FStar_Compiler_Util.smap_create (Prims.of_int (10)) in - let add_ub i j k ik jk = - let key = - let uu___1 = FStar_Ident.string_of_lid i in - let uu___2 = - let uu___3 = FStar_Ident.string_of_lid j in - Prims.strcat ":" uu___3 in - Prims.strcat uu___1 uu___2 in - let v = - let uu___1 = FStar_Compiler_Util.smap_try_find ubs key in - match uu___1 with - | FStar_Pervasives_Native.Some ubs1 -> (i, j, k, ik, jk) :: - ubs1 - | FStar_Pervasives_Native.None -> [(i, j, k, ik, jk)] in - FStar_Compiler_Util.smap_add ubs key v in - FStar_Compiler_List.iter - (fun i -> - FStar_Compiler_List.iter - (fun j -> - let uu___2 = FStar_Ident.lid_equals i j in - if uu___2 - then () - else - FStar_Compiler_List.iter - (fun k -> - let uu___4 = - let uu___5 = find_edge order (i, k) in - let uu___6 = find_edge order (j, k) in - (uu___5, uu___6) in - match uu___4 with - | (FStar_Pervasives_Native.Some ik, - FStar_Pervasives_Native.Some jk) -> - add_ub i j k ik.mlift jk.mlift - | uu___5 -> ()) ms) ms) ms; - FStar_Compiler_Util.smap_fold ubs - (fun s -> - fun l -> - fun joins1 -> - let lubs = - FStar_Compiler_List.filter - (fun uu___2 -> - match uu___2 with - | (i, j, k, ik, jk) -> - FStar_Compiler_List.for_all - (fun uu___3 -> - match uu___3 with - | (uu___4, uu___5, k', uu___6, uu___7) - -> - let uu___8 = - find_edge order (k, k') in - FStar_Compiler_Util.is_some uu___8) - l) l in - if (FStar_Compiler_List.length lubs) <> Prims.int_one - then - let uu___2 = - FStar_Compiler_Util.format1 - "Effects %s have incomparable upper bounds" s in - FStar_Errors.raise_error hasRange_env env1 - FStar_Errors_Codes.Fatal_Effects_Ordering_Coherence - () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2) - else FStar_Compiler_List.op_At lubs joins1) [] in - let effects1 = - let uu___1 = env1.effects in - { - decls = (uu___1.decls); - order; - joins; - polymonadic_binds = (uu___1.polymonadic_binds); - polymonadic_subcomps = (uu___1.polymonadic_subcomps) - } in - { - solver = (env1.solver); - range = (env1.range); - curmodule = (env1.curmodule); - gamma = (env1.gamma); - gamma_sig = (env1.gamma_sig); - gamma_cache = (env1.gamma_cache); - modules = (env1.modules); - expected_typ = (env1.expected_typ); - sigtab = (env1.sigtab); - attrtab = (env1.attrtab); - instantiate_imp = (env1.instantiate_imp); - effects = effects1; - generalize = (env1.generalize); - letrecs = (env1.letrecs); - top_level = (env1.top_level); - check_uvars = (env1.check_uvars); - use_eq_strict = (env1.use_eq_strict); - is_iface = (env1.is_iface); - admit = (env1.admit); - lax_universes = (env1.lax_universes); - phase1 = (env1.phase1); - failhard = (env1.failhard); - flychecking = (env1.flychecking); - uvar_subtyping = (env1.uvar_subtyping); - intactics = (env1.intactics); - nocoerce = (env1.nocoerce); - tc_term = (env1.tc_term); - typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); - universe_of = (env1.universe_of); - typeof_well_typed_tot_or_gtot_term = - (env1.typeof_well_typed_tot_or_gtot_term); - teq_nosmt_force = (env1.teq_nosmt_force); - subtype_nosmt_force = (env1.subtype_nosmt_force); - qtbl_name_and_index = (env1.qtbl_name_and_index); - normalized_eff_names = (env1.normalized_eff_names); - fv_delta_depths = (env1.fv_delta_depths); - proof_ns = (env1.proof_ns); - synth_hook = (env1.synth_hook); - try_solve_implicits_hook = (env1.try_solve_implicits_hook); - splice = (env1.splice); - mpreprocess = (env1.mpreprocess); - postprocess = (env1.postprocess); - identifier_info = (env1.identifier_info); - tc_hooks = (env1.tc_hooks); - dsenv = (env1.dsenv); - nbe = (env1.nbe); - strict_args_tab = (env1.strict_args_tab); - erasable_types_tab = (env1.erasable_types_tab); - enable_defer_to_tac = (env1.enable_defer_to_tac); - unif_allow_ref_guards = (env1.unif_allow_ref_guards); - erase_erasable_args = (env1.erase_erasable_args); - core_check = (env1.core_check); - missing_decl = (env1.missing_decl) - }) -let (add_polymonadic_bind : - env -> - FStar_Ident.lident -> - FStar_Ident.lident -> FStar_Ident.lident -> polymonadic_bind_t -> env) - = - fun env1 -> - fun m -> - fun n -> - fun p -> - fun ty -> - { - solver = (env1.solver); - range = (env1.range); - curmodule = (env1.curmodule); - gamma = (env1.gamma); - gamma_sig = (env1.gamma_sig); - gamma_cache = (env1.gamma_cache); - modules = (env1.modules); - expected_typ = (env1.expected_typ); - sigtab = (env1.sigtab); - attrtab = (env1.attrtab); - instantiate_imp = (env1.instantiate_imp); - effects = - (let uu___ = env1.effects in - { - decls = (uu___.decls); - order = (uu___.order); - joins = (uu___.joins); - polymonadic_binds = ((m, n, p, ty) :: - ((env1.effects).polymonadic_binds)); - polymonadic_subcomps = (uu___.polymonadic_subcomps) - }); - generalize = (env1.generalize); - letrecs = (env1.letrecs); - top_level = (env1.top_level); - check_uvars = (env1.check_uvars); - use_eq_strict = (env1.use_eq_strict); - is_iface = (env1.is_iface); - admit = (env1.admit); - lax_universes = (env1.lax_universes); - phase1 = (env1.phase1); - failhard = (env1.failhard); - flychecking = (env1.flychecking); - uvar_subtyping = (env1.uvar_subtyping); - intactics = (env1.intactics); - nocoerce = (env1.nocoerce); - tc_term = (env1.tc_term); - typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); - universe_of = (env1.universe_of); - typeof_well_typed_tot_or_gtot_term = - (env1.typeof_well_typed_tot_or_gtot_term); - teq_nosmt_force = (env1.teq_nosmt_force); - subtype_nosmt_force = (env1.subtype_nosmt_force); - qtbl_name_and_index = (env1.qtbl_name_and_index); - normalized_eff_names = (env1.normalized_eff_names); - fv_delta_depths = (env1.fv_delta_depths); - proof_ns = (env1.proof_ns); - synth_hook = (env1.synth_hook); - try_solve_implicits_hook = (env1.try_solve_implicits_hook); - splice = (env1.splice); - mpreprocess = (env1.mpreprocess); - postprocess = (env1.postprocess); - identifier_info = (env1.identifier_info); - tc_hooks = (env1.tc_hooks); - dsenv = (env1.dsenv); - nbe = (env1.nbe); - strict_args_tab = (env1.strict_args_tab); - erasable_types_tab = (env1.erasable_types_tab); - enable_defer_to_tac = (env1.enable_defer_to_tac); - unif_allow_ref_guards = (env1.unif_allow_ref_guards); - erase_erasable_args = (env1.erase_erasable_args); - core_check = (env1.core_check); - missing_decl = (env1.missing_decl) - } -let (add_polymonadic_subcomp : - env -> - FStar_Ident.lident -> - FStar_Ident.lident -> - (FStar_Syntax_Syntax.tscheme * - FStar_Syntax_Syntax.indexed_effect_combinator_kind) -> env) - = - fun env1 -> - fun m -> - fun n -> - fun uu___ -> - match uu___ with - | (ts, k) -> - { - solver = (env1.solver); - range = (env1.range); - curmodule = (env1.curmodule); - gamma = (env1.gamma); - gamma_sig = (env1.gamma_sig); - gamma_cache = (env1.gamma_cache); - modules = (env1.modules); - expected_typ = (env1.expected_typ); - sigtab = (env1.sigtab); - attrtab = (env1.attrtab); - instantiate_imp = (env1.instantiate_imp); - effects = - (let uu___1 = env1.effects in - { - decls = (uu___1.decls); - order = (uu___1.order); - joins = (uu___1.joins); - polymonadic_binds = (uu___1.polymonadic_binds); - polymonadic_subcomps = ((m, n, ts, k) :: - ((env1.effects).polymonadic_subcomps)) - }); - generalize = (env1.generalize); - letrecs = (env1.letrecs); - top_level = (env1.top_level); - check_uvars = (env1.check_uvars); - use_eq_strict = (env1.use_eq_strict); - is_iface = (env1.is_iface); - admit = (env1.admit); - lax_universes = (env1.lax_universes); - phase1 = (env1.phase1); - failhard = (env1.failhard); - flychecking = (env1.flychecking); - uvar_subtyping = (env1.uvar_subtyping); - intactics = (env1.intactics); - nocoerce = (env1.nocoerce); - tc_term = (env1.tc_term); - typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); - universe_of = (env1.universe_of); - typeof_well_typed_tot_or_gtot_term = - (env1.typeof_well_typed_tot_or_gtot_term); - teq_nosmt_force = (env1.teq_nosmt_force); - subtype_nosmt_force = (env1.subtype_nosmt_force); - qtbl_name_and_index = (env1.qtbl_name_and_index); - normalized_eff_names = (env1.normalized_eff_names); - fv_delta_depths = (env1.fv_delta_depths); - proof_ns = (env1.proof_ns); - synth_hook = (env1.synth_hook); - try_solve_implicits_hook = (env1.try_solve_implicits_hook); - splice = (env1.splice); - mpreprocess = (env1.mpreprocess); - postprocess = (env1.postprocess); - identifier_info = (env1.identifier_info); - tc_hooks = (env1.tc_hooks); - dsenv = (env1.dsenv); - nbe = (env1.nbe); - strict_args_tab = (env1.strict_args_tab); - erasable_types_tab = (env1.erasable_types_tab); - enable_defer_to_tac = (env1.enable_defer_to_tac); - unif_allow_ref_guards = (env1.unif_allow_ref_guards); - erase_erasable_args = (env1.erase_erasable_args); - core_check = (env1.core_check); - missing_decl = (env1.missing_decl) - } -let (push_local_binding : env -> FStar_Syntax_Syntax.binding -> env) = - fun env1 -> - fun b -> - { - solver = (env1.solver); - range = (env1.range); - curmodule = (env1.curmodule); - gamma = (b :: (env1.gamma)); - gamma_sig = (env1.gamma_sig); - gamma_cache = (env1.gamma_cache); - modules = (env1.modules); - expected_typ = (env1.expected_typ); - sigtab = (env1.sigtab); - attrtab = (env1.attrtab); - instantiate_imp = (env1.instantiate_imp); - effects = (env1.effects); - generalize = (env1.generalize); - letrecs = (env1.letrecs); - top_level = (env1.top_level); - check_uvars = (env1.check_uvars); - use_eq_strict = (env1.use_eq_strict); - is_iface = (env1.is_iface); - admit = (env1.admit); - lax_universes = (env1.lax_universes); - phase1 = (env1.phase1); - failhard = (env1.failhard); - flychecking = (env1.flychecking); - uvar_subtyping = (env1.uvar_subtyping); - intactics = (env1.intactics); - nocoerce = (env1.nocoerce); - tc_term = (env1.tc_term); - typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); - universe_of = (env1.universe_of); - typeof_well_typed_tot_or_gtot_term = - (env1.typeof_well_typed_tot_or_gtot_term); - teq_nosmt_force = (env1.teq_nosmt_force); - subtype_nosmt_force = (env1.subtype_nosmt_force); - qtbl_name_and_index = (env1.qtbl_name_and_index); - normalized_eff_names = (env1.normalized_eff_names); - fv_delta_depths = (env1.fv_delta_depths); - proof_ns = (env1.proof_ns); - synth_hook = (env1.synth_hook); - try_solve_implicits_hook = (env1.try_solve_implicits_hook); - splice = (env1.splice); - mpreprocess = (env1.mpreprocess); - postprocess = (env1.postprocess); - identifier_info = (env1.identifier_info); - tc_hooks = (env1.tc_hooks); - dsenv = (env1.dsenv); - nbe = (env1.nbe); - strict_args_tab = (env1.strict_args_tab); - erasable_types_tab = (env1.erasable_types_tab); - enable_defer_to_tac = (env1.enable_defer_to_tac); - unif_allow_ref_guards = (env1.unif_allow_ref_guards); - erase_erasable_args = (env1.erase_erasable_args); - core_check = (env1.core_check); - missing_decl = (env1.missing_decl) - } -let (push_bv : env -> FStar_Syntax_Syntax.bv -> env) = - fun env1 -> - fun x -> push_local_binding env1 (FStar_Syntax_Syntax.Binding_var x) -let (push_bvs : env -> FStar_Syntax_Syntax.bv Prims.list -> env) = - fun env1 -> - fun bvs -> - FStar_Compiler_List.fold_left (fun env2 -> fun bv -> push_bv env2 bv) - env1 bvs -let (pop_bv : - env -> (FStar_Syntax_Syntax.bv * env) FStar_Pervasives_Native.option) = - fun env1 -> - match env1.gamma with - | (FStar_Syntax_Syntax.Binding_var x)::rest -> - FStar_Pervasives_Native.Some - (x, - { - solver = (env1.solver); - range = (env1.range); - curmodule = (env1.curmodule); - gamma = rest; - gamma_sig = (env1.gamma_sig); - gamma_cache = (env1.gamma_cache); - modules = (env1.modules); - expected_typ = (env1.expected_typ); - sigtab = (env1.sigtab); - attrtab = (env1.attrtab); - instantiate_imp = (env1.instantiate_imp); - effects = (env1.effects); - generalize = (env1.generalize); - letrecs = (env1.letrecs); - top_level = (env1.top_level); - check_uvars = (env1.check_uvars); - use_eq_strict = (env1.use_eq_strict); - is_iface = (env1.is_iface); - admit = (env1.admit); - lax_universes = (env1.lax_universes); - phase1 = (env1.phase1); - failhard = (env1.failhard); - flychecking = (env1.flychecking); - uvar_subtyping = (env1.uvar_subtyping); - intactics = (env1.intactics); - nocoerce = (env1.nocoerce); - tc_term = (env1.tc_term); - typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); - universe_of = (env1.universe_of); - typeof_well_typed_tot_or_gtot_term = - (env1.typeof_well_typed_tot_or_gtot_term); - teq_nosmt_force = (env1.teq_nosmt_force); - subtype_nosmt_force = (env1.subtype_nosmt_force); - qtbl_name_and_index = (env1.qtbl_name_and_index); - normalized_eff_names = (env1.normalized_eff_names); - fv_delta_depths = (env1.fv_delta_depths); - proof_ns = (env1.proof_ns); - synth_hook = (env1.synth_hook); - try_solve_implicits_hook = (env1.try_solve_implicits_hook); - splice = (env1.splice); - mpreprocess = (env1.mpreprocess); - postprocess = (env1.postprocess); - identifier_info = (env1.identifier_info); - tc_hooks = (env1.tc_hooks); - dsenv = (env1.dsenv); - nbe = (env1.nbe); - strict_args_tab = (env1.strict_args_tab); - erasable_types_tab = (env1.erasable_types_tab); - enable_defer_to_tac = (env1.enable_defer_to_tac); - unif_allow_ref_guards = (env1.unif_allow_ref_guards); - erase_erasable_args = (env1.erase_erasable_args); - core_check = (env1.core_check); - missing_decl = (env1.missing_decl) - }) - | uu___ -> FStar_Pervasives_Native.None -let (push_binders : env -> FStar_Syntax_Syntax.binders -> env) = - fun env1 -> - fun bs -> - FStar_Compiler_List.fold_left - (fun env2 -> fun b -> push_bv env2 b.FStar_Syntax_Syntax.binder_bv) - env1 bs -let (binding_of_lb : - FStar_Syntax_Syntax.lbname -> - (FStar_Syntax_Syntax.univ_names * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax) -> FStar_Syntax_Syntax.binding) - = - fun x -> - fun t -> - match x with - | FStar_Pervasives.Inl x1 -> - let x2 = - { - FStar_Syntax_Syntax.ppname = (x1.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = (x1.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = (FStar_Pervasives_Native.snd t) - } in - FStar_Syntax_Syntax.Binding_var x2 - | FStar_Pervasives.Inr fv -> - FStar_Syntax_Syntax.Binding_lid - (((fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v), t) -let (push_let_binding : - env -> FStar_Syntax_Syntax.lbname -> FStar_Syntax_Syntax.tscheme -> env) = - fun env1 -> - fun lb -> fun ts -> push_local_binding env1 (binding_of_lb lb ts) -let (push_univ_vars : env -> FStar_Syntax_Syntax.univ_names -> env) = - fun env1 -> - fun xs -> - FStar_Compiler_List.fold_left - (fun env2 -> - fun x -> - push_local_binding env2 (FStar_Syntax_Syntax.Binding_univ x)) - env1 xs -let (open_universes_in : - env -> - FStar_Syntax_Syntax.univ_names -> - FStar_Syntax_Syntax.term Prims.list -> - (env * FStar_Syntax_Syntax.univ_names * FStar_Syntax_Syntax.term - Prims.list)) - = - fun env1 -> - fun uvs -> - fun terms -> - let uu___ = FStar_Syntax_Subst.univ_var_opening uvs in - match uu___ with - | (univ_subst, univ_vars) -> - let env' = push_univ_vars env1 univ_vars in - let uu___1 = - FStar_Compiler_List.map (FStar_Syntax_Subst.subst univ_subst) - terms in - (env', univ_vars, uu___1) -let (set_expected_typ : env -> FStar_Syntax_Syntax.typ -> env) = - fun env1 -> - fun t -> - { - solver = (env1.solver); - range = (env1.range); - curmodule = (env1.curmodule); - gamma = (env1.gamma); - gamma_sig = (env1.gamma_sig); - gamma_cache = (env1.gamma_cache); - modules = (env1.modules); - expected_typ = (FStar_Pervasives_Native.Some (t, false)); - sigtab = (env1.sigtab); - attrtab = (env1.attrtab); - instantiate_imp = (env1.instantiate_imp); - effects = (env1.effects); - generalize = (env1.generalize); - letrecs = (env1.letrecs); - top_level = (env1.top_level); - check_uvars = (env1.check_uvars); - use_eq_strict = (env1.use_eq_strict); - is_iface = (env1.is_iface); - admit = (env1.admit); - lax_universes = (env1.lax_universes); - phase1 = (env1.phase1); - failhard = (env1.failhard); - flychecking = (env1.flychecking); - uvar_subtyping = (env1.uvar_subtyping); - intactics = (env1.intactics); - nocoerce = (env1.nocoerce); - tc_term = (env1.tc_term); - typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); - universe_of = (env1.universe_of); - typeof_well_typed_tot_or_gtot_term = - (env1.typeof_well_typed_tot_or_gtot_term); - teq_nosmt_force = (env1.teq_nosmt_force); - subtype_nosmt_force = (env1.subtype_nosmt_force); - qtbl_name_and_index = (env1.qtbl_name_and_index); - normalized_eff_names = (env1.normalized_eff_names); - fv_delta_depths = (env1.fv_delta_depths); - proof_ns = (env1.proof_ns); - synth_hook = (env1.synth_hook); - try_solve_implicits_hook = (env1.try_solve_implicits_hook); - splice = (env1.splice); - mpreprocess = (env1.mpreprocess); - postprocess = (env1.postprocess); - identifier_info = (env1.identifier_info); - tc_hooks = (env1.tc_hooks); - dsenv = (env1.dsenv); - nbe = (env1.nbe); - strict_args_tab = (env1.strict_args_tab); - erasable_types_tab = (env1.erasable_types_tab); - enable_defer_to_tac = (env1.enable_defer_to_tac); - unif_allow_ref_guards = (env1.unif_allow_ref_guards); - erase_erasable_args = (env1.erase_erasable_args); - core_check = (env1.core_check); - missing_decl = (env1.missing_decl) - } -let (set_expected_typ_maybe_eq : - env -> FStar_Syntax_Syntax.typ -> Prims.bool -> env) = - fun env1 -> - fun t -> - fun use_eq -> - { - solver = (env1.solver); - range = (env1.range); - curmodule = (env1.curmodule); - gamma = (env1.gamma); - gamma_sig = (env1.gamma_sig); - gamma_cache = (env1.gamma_cache); - modules = (env1.modules); - expected_typ = (FStar_Pervasives_Native.Some (t, use_eq)); - sigtab = (env1.sigtab); - attrtab = (env1.attrtab); - instantiate_imp = (env1.instantiate_imp); - effects = (env1.effects); - generalize = (env1.generalize); - letrecs = (env1.letrecs); - top_level = (env1.top_level); - check_uvars = (env1.check_uvars); - use_eq_strict = (env1.use_eq_strict); - is_iface = (env1.is_iface); - admit = (env1.admit); - lax_universes = (env1.lax_universes); - phase1 = (env1.phase1); - failhard = (env1.failhard); - flychecking = (env1.flychecking); - uvar_subtyping = (env1.uvar_subtyping); - intactics = (env1.intactics); - nocoerce = (env1.nocoerce); - tc_term = (env1.tc_term); - typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); - universe_of = (env1.universe_of); - typeof_well_typed_tot_or_gtot_term = - (env1.typeof_well_typed_tot_or_gtot_term); - teq_nosmt_force = (env1.teq_nosmt_force); - subtype_nosmt_force = (env1.subtype_nosmt_force); - qtbl_name_and_index = (env1.qtbl_name_and_index); - normalized_eff_names = (env1.normalized_eff_names); - fv_delta_depths = (env1.fv_delta_depths); - proof_ns = (env1.proof_ns); - synth_hook = (env1.synth_hook); - try_solve_implicits_hook = (env1.try_solve_implicits_hook); - splice = (env1.splice); - mpreprocess = (env1.mpreprocess); - postprocess = (env1.postprocess); - identifier_info = (env1.identifier_info); - tc_hooks = (env1.tc_hooks); - dsenv = (env1.dsenv); - nbe = (env1.nbe); - strict_args_tab = (env1.strict_args_tab); - erasable_types_tab = (env1.erasable_types_tab); - enable_defer_to_tac = (env1.enable_defer_to_tac); - unif_allow_ref_guards = (env1.unif_allow_ref_guards); - erase_erasable_args = (env1.erase_erasable_args); - core_check = (env1.core_check); - missing_decl = (env1.missing_decl) - } -let (expected_typ : - env -> - (FStar_Syntax_Syntax.typ * Prims.bool) FStar_Pervasives_Native.option) - = - fun env1 -> - match env1.expected_typ with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some t -> FStar_Pervasives_Native.Some t -let (clear_expected_typ : - env -> - (env * (FStar_Syntax_Syntax.typ * Prims.bool) - FStar_Pervasives_Native.option)) - = - fun env_ -> - let uu___ = expected_typ env_ in - ({ - solver = (env_.solver); - range = (env_.range); - curmodule = (env_.curmodule); - gamma = (env_.gamma); - gamma_sig = (env_.gamma_sig); - gamma_cache = (env_.gamma_cache); - modules = (env_.modules); - expected_typ = FStar_Pervasives_Native.None; - sigtab = (env_.sigtab); - attrtab = (env_.attrtab); - instantiate_imp = (env_.instantiate_imp); - effects = (env_.effects); - generalize = (env_.generalize); - letrecs = (env_.letrecs); - top_level = (env_.top_level); - check_uvars = (env_.check_uvars); - use_eq_strict = (env_.use_eq_strict); - is_iface = (env_.is_iface); - admit = (env_.admit); - lax_universes = (env_.lax_universes); - phase1 = (env_.phase1); - failhard = (env_.failhard); - flychecking = (env_.flychecking); - uvar_subtyping = (env_.uvar_subtyping); - intactics = (env_.intactics); - nocoerce = (env_.nocoerce); - tc_term = (env_.tc_term); - typeof_tot_or_gtot_term = (env_.typeof_tot_or_gtot_term); - universe_of = (env_.universe_of); - typeof_well_typed_tot_or_gtot_term = - (env_.typeof_well_typed_tot_or_gtot_term); - teq_nosmt_force = (env_.teq_nosmt_force); - subtype_nosmt_force = (env_.subtype_nosmt_force); - qtbl_name_and_index = (env_.qtbl_name_and_index); - normalized_eff_names = (env_.normalized_eff_names); - fv_delta_depths = (env_.fv_delta_depths); - proof_ns = (env_.proof_ns); - synth_hook = (env_.synth_hook); - try_solve_implicits_hook = (env_.try_solve_implicits_hook); - splice = (env_.splice); - mpreprocess = (env_.mpreprocess); - postprocess = (env_.postprocess); - identifier_info = (env_.identifier_info); - tc_hooks = (env_.tc_hooks); - dsenv = (env_.dsenv); - nbe = (env_.nbe); - strict_args_tab = (env_.strict_args_tab); - erasable_types_tab = (env_.erasable_types_tab); - enable_defer_to_tac = (env_.enable_defer_to_tac); - unif_allow_ref_guards = (env_.unif_allow_ref_guards); - erase_erasable_args = (env_.erase_erasable_args); - core_check = (env_.core_check); - missing_decl = (env_.missing_decl) - }, uu___) -let (finish_module : env -> FStar_Syntax_Syntax.modul -> env) = - let empty_lid = - let uu___ = let uu___1 = FStar_Ident.id_of_text "" in [uu___1] in - FStar_Ident.lid_of_ids uu___ in - fun env1 -> - fun m -> - let sigs = - let uu___ = - FStar_Ident.lid_equals m.FStar_Syntax_Syntax.name - FStar_Parser_Const.prims_lid in - if uu___ - then - let uu___1 = - FStar_Compiler_List.map FStar_Pervasives_Native.snd - env1.gamma_sig in - FStar_Compiler_List.rev uu___1 - else m.FStar_Syntax_Syntax.declarations in - { - solver = (env1.solver); - range = (env1.range); - curmodule = empty_lid; - gamma = []; - gamma_sig = []; - gamma_cache = (env1.gamma_cache); - modules = (m :: (env1.modules)); - expected_typ = (env1.expected_typ); - sigtab = (env1.sigtab); - attrtab = (env1.attrtab); - instantiate_imp = (env1.instantiate_imp); - effects = (env1.effects); - generalize = (env1.generalize); - letrecs = (env1.letrecs); - top_level = (env1.top_level); - check_uvars = (env1.check_uvars); - use_eq_strict = (env1.use_eq_strict); - is_iface = (env1.is_iface); - admit = (env1.admit); - lax_universes = (env1.lax_universes); - phase1 = (env1.phase1); - failhard = (env1.failhard); - flychecking = (env1.flychecking); - uvar_subtyping = (env1.uvar_subtyping); - intactics = (env1.intactics); - nocoerce = (env1.nocoerce); - tc_term = (env1.tc_term); - typeof_tot_or_gtot_term = (env1.typeof_tot_or_gtot_term); - universe_of = (env1.universe_of); - typeof_well_typed_tot_or_gtot_term = - (env1.typeof_well_typed_tot_or_gtot_term); - teq_nosmt_force = (env1.teq_nosmt_force); - subtype_nosmt_force = (env1.subtype_nosmt_force); - qtbl_name_and_index = (env1.qtbl_name_and_index); - normalized_eff_names = (env1.normalized_eff_names); - fv_delta_depths = (env1.fv_delta_depths); - proof_ns = (env1.proof_ns); - synth_hook = (env1.synth_hook); - try_solve_implicits_hook = (env1.try_solve_implicits_hook); - splice = (env1.splice); - mpreprocess = (env1.mpreprocess); - postprocess = (env1.postprocess); - identifier_info = (env1.identifier_info); - tc_hooks = (env1.tc_hooks); - dsenv = (env1.dsenv); - nbe = (env1.nbe); - strict_args_tab = (env1.strict_args_tab); - erasable_types_tab = (env1.erasable_types_tab); - enable_defer_to_tac = (env1.enable_defer_to_tac); - unif_allow_ref_guards = (env1.unif_allow_ref_guards); - erase_erasable_args = (env1.erase_erasable_args); - core_check = (env1.core_check); - missing_decl = (env1.missing_decl) - } -let (uvars_in_env : env -> FStar_Syntax_Syntax.uvars) = - fun env1 -> - let no_uvs = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) ()) in - let rec aux out g = - match g with - | [] -> out - | (FStar_Syntax_Syntax.Binding_univ uu___)::tl -> aux out tl - | (FStar_Syntax_Syntax.Binding_lid (uu___, (uu___1, t)))::tl -> - let uu___2 = - let uu___3 = FStar_Syntax_Free.uvars t in - Obj.magic - (FStar_Class_Setlike.union () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) (Obj.magic out) - (Obj.magic uu___3)) in - aux uu___2 tl - | (FStar_Syntax_Syntax.Binding_var - { FStar_Syntax_Syntax.ppname = uu___; - FStar_Syntax_Syntax.index = uu___1; - FStar_Syntax_Syntax.sort = t;_})::tl - -> - let uu___2 = - let uu___3 = FStar_Syntax_Free.uvars t in - Obj.magic - (FStar_Class_Setlike.union () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) (Obj.magic out) - (Obj.magic uu___3)) in - aux uu___2 tl in - aux no_uvs env1.gamma -let (univ_vars : - env -> FStar_Syntax_Syntax.universe_uvar FStar_Compiler_FlatSet.t) = - fun env1 -> - let no_univs = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_univ_uvar)) ()) in - let rec aux out g = - match g with - | [] -> out - | (FStar_Syntax_Syntax.Binding_univ uu___)::tl -> aux out tl - | (FStar_Syntax_Syntax.Binding_lid (uu___, (uu___1, t)))::tl -> - let uu___2 = - let uu___3 = FStar_Syntax_Free.univs t in - Obj.magic - (FStar_Class_Setlike.union () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_univ_uvar)) (Obj.magic out) - (Obj.magic uu___3)) in - aux uu___2 tl - | (FStar_Syntax_Syntax.Binding_var - { FStar_Syntax_Syntax.ppname = uu___; - FStar_Syntax_Syntax.index = uu___1; - FStar_Syntax_Syntax.sort = t;_})::tl - -> - let uu___2 = - let uu___3 = FStar_Syntax_Free.univs t in - Obj.magic - (FStar_Class_Setlike.union () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_univ_uvar)) (Obj.magic out) - (Obj.magic uu___3)) in - aux uu___2 tl in - aux no_univs env1.gamma -let (univnames : - env -> FStar_Syntax_Syntax.univ_name FStar_Compiler_FlatSet.t) = - fun env1 -> - let no_univ_names = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_ident)) ()) in - let rec aux out g = - match g with - | [] -> out - | (FStar_Syntax_Syntax.Binding_univ uname)::tl -> - let uu___ = - Obj.magic - (FStar_Class_Setlike.add () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_ident)) uname (Obj.magic out)) in - aux uu___ tl - | (FStar_Syntax_Syntax.Binding_lid (uu___, (uu___1, t)))::tl -> - let uu___2 = - let uu___3 = FStar_Syntax_Free.univnames t in - Obj.magic - (FStar_Class_Setlike.union () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_ident)) (Obj.magic out) - (Obj.magic uu___3)) in - aux uu___2 tl - | (FStar_Syntax_Syntax.Binding_var - { FStar_Syntax_Syntax.ppname = uu___; - FStar_Syntax_Syntax.index = uu___1; - FStar_Syntax_Syntax.sort = t;_})::tl - -> - let uu___2 = - let uu___3 = FStar_Syntax_Free.univnames t in - Obj.magic - (FStar_Class_Setlike.union () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_ident)) (Obj.magic out) - (Obj.magic uu___3)) in - aux uu___2 tl in - aux no_univ_names env1.gamma -let (lidents : env -> FStar_Ident.lident Prims.list) = - fun env1 -> - let keys = - FStar_Compiler_List.collect FStar_Pervasives_Native.fst env1.gamma_sig in - FStar_Compiler_Util.smap_fold (sigtab env1) - (fun uu___ -> - fun v -> - fun keys1 -> - FStar_Compiler_List.op_At (FStar_Syntax_Util.lids_of_sigelt v) - keys1) keys -let (should_enc_path : - (Prims.string Prims.list * Prims.bool) Prims.list -> - Prims.string Prims.list -> Prims.bool) - = - fun proof_ns -> - fun path -> - let rec str_i_prefix xs ys = - match (xs, ys) with - | ([], uu___) -> true - | (x::xs1, y::ys1) -> - ((FStar_Compiler_String.lowercase x) = - (FStar_Compiler_String.lowercase y)) - && (str_i_prefix xs1 ys1) - | (uu___, uu___1) -> false in - let uu___ = - FStar_Compiler_List.tryFind - (fun uu___1 -> - match uu___1 with | (p, uu___2) -> str_i_prefix p path) proof_ns in - match uu___ with - | FStar_Pervasives_Native.None -> false - | FStar_Pervasives_Native.Some (uu___1, b) -> b -let (should_enc_lid : proof_namespace -> FStar_Ident.lident -> Prims.bool) = - fun proof_ns -> - fun lid -> - let uu___ = FStar_Ident.path_of_lid lid in - should_enc_path proof_ns uu___ -let (cons_proof_ns : Prims.bool -> env -> name_prefix -> env) = - fun b -> - fun e -> - fun path -> - { - solver = (e.solver); - range = (e.range); - curmodule = (e.curmodule); - gamma = (e.gamma); - gamma_sig = (e.gamma_sig); - gamma_cache = (e.gamma_cache); - modules = (e.modules); - expected_typ = (e.expected_typ); - sigtab = (e.sigtab); - attrtab = (e.attrtab); - instantiate_imp = (e.instantiate_imp); - effects = (e.effects); - generalize = (e.generalize); - letrecs = (e.letrecs); - top_level = (e.top_level); - check_uvars = (e.check_uvars); - use_eq_strict = (e.use_eq_strict); - is_iface = (e.is_iface); - admit = (e.admit); - lax_universes = (e.lax_universes); - phase1 = (e.phase1); - failhard = (e.failhard); - flychecking = (e.flychecking); - uvar_subtyping = (e.uvar_subtyping); - intactics = (e.intactics); - nocoerce = (e.nocoerce); - tc_term = (e.tc_term); - typeof_tot_or_gtot_term = (e.typeof_tot_or_gtot_term); - universe_of = (e.universe_of); - typeof_well_typed_tot_or_gtot_term = - (e.typeof_well_typed_tot_or_gtot_term); - teq_nosmt_force = (e.teq_nosmt_force); - subtype_nosmt_force = (e.subtype_nosmt_force); - qtbl_name_and_index = (e.qtbl_name_and_index); - normalized_eff_names = (e.normalized_eff_names); - fv_delta_depths = (e.fv_delta_depths); - proof_ns = ((path, b) :: (e.proof_ns)); - synth_hook = (e.synth_hook); - try_solve_implicits_hook = (e.try_solve_implicits_hook); - splice = (e.splice); - mpreprocess = (e.mpreprocess); - postprocess = (e.postprocess); - identifier_info = (e.identifier_info); - tc_hooks = (e.tc_hooks); - dsenv = (e.dsenv); - nbe = (e.nbe); - strict_args_tab = (e.strict_args_tab); - erasable_types_tab = (e.erasable_types_tab); - enable_defer_to_tac = (e.enable_defer_to_tac); - unif_allow_ref_guards = (e.unif_allow_ref_guards); - erase_erasable_args = (e.erase_erasable_args); - core_check = (e.core_check); - missing_decl = (e.missing_decl) - } -let (add_proof_ns : env -> name_prefix -> env) = - fun e -> fun path -> cons_proof_ns true e path -let (rem_proof_ns : env -> name_prefix -> env) = - fun e -> fun path -> cons_proof_ns false e path -let (get_proof_ns : env -> proof_namespace) = fun e -> e.proof_ns -let (set_proof_ns : proof_namespace -> env -> env) = - fun ns -> - fun e -> - { - solver = (e.solver); - range = (e.range); - curmodule = (e.curmodule); - gamma = (e.gamma); - gamma_sig = (e.gamma_sig); - gamma_cache = (e.gamma_cache); - modules = (e.modules); - expected_typ = (e.expected_typ); - sigtab = (e.sigtab); - attrtab = (e.attrtab); - instantiate_imp = (e.instantiate_imp); - effects = (e.effects); - generalize = (e.generalize); - letrecs = (e.letrecs); - top_level = (e.top_level); - check_uvars = (e.check_uvars); - use_eq_strict = (e.use_eq_strict); - is_iface = (e.is_iface); - admit = (e.admit); - lax_universes = (e.lax_universes); - phase1 = (e.phase1); - failhard = (e.failhard); - flychecking = (e.flychecking); - uvar_subtyping = (e.uvar_subtyping); - intactics = (e.intactics); - nocoerce = (e.nocoerce); - tc_term = (e.tc_term); - typeof_tot_or_gtot_term = (e.typeof_tot_or_gtot_term); - universe_of = (e.universe_of); - typeof_well_typed_tot_or_gtot_term = - (e.typeof_well_typed_tot_or_gtot_term); - teq_nosmt_force = (e.teq_nosmt_force); - subtype_nosmt_force = (e.subtype_nosmt_force); - qtbl_name_and_index = (e.qtbl_name_and_index); - normalized_eff_names = (e.normalized_eff_names); - fv_delta_depths = (e.fv_delta_depths); - proof_ns = ns; - synth_hook = (e.synth_hook); - try_solve_implicits_hook = (e.try_solve_implicits_hook); - splice = (e.splice); - mpreprocess = (e.mpreprocess); - postprocess = (e.postprocess); - identifier_info = (e.identifier_info); - tc_hooks = (e.tc_hooks); - dsenv = (e.dsenv); - nbe = (e.nbe); - strict_args_tab = (e.strict_args_tab); - erasable_types_tab = (e.erasable_types_tab); - enable_defer_to_tac = (e.enable_defer_to_tac); - unif_allow_ref_guards = (e.unif_allow_ref_guards); - erase_erasable_args = (e.erase_erasable_args); - core_check = (e.core_check); - missing_decl = (e.missing_decl) - } -let (unbound_vars : - env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.bv FStar_Compiler_FlatSet.t) - = - fun e -> - fun t -> - let uu___ = FStar_Syntax_Free.names t in - let uu___1 = bound_vars e in - FStar_Compiler_List.fold_left - (fun uu___3 -> - fun uu___2 -> - (fun s -> - fun bv -> - Obj.magic - (FStar_Class_Setlike.remove () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) bv (Obj.magic s))) - uu___3 uu___2) uu___ uu___1 -let (closed : env -> FStar_Syntax_Syntax.term -> Prims.bool) = - fun e -> - fun t -> - let uu___ = unbound_vars e t in - FStar_Class_Setlike.is_empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) (Obj.magic uu___) -let (closed' : FStar_Syntax_Syntax.term -> Prims.bool) = - fun t -> - let uu___ = FStar_Syntax_Free.names t in - FStar_Class_Setlike.is_empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set FStar_Syntax_Syntax.ord_bv)) - (Obj.magic uu___) -let (string_of_proof_ns : env -> Prims.string) = - fun env1 -> - let aux uu___ = - match uu___ with - | (p, b) -> - if (p = []) && b - then "*" - else - (let uu___2 = FStar_Ident.text_of_path p in - Prims.strcat (if b then "+" else "-") uu___2) in - let uu___ = - let uu___1 = FStar_Compiler_List.map aux env1.proof_ns in - FStar_Compiler_List.rev uu___1 in - FStar_Compiler_String.concat " " uu___ -let (guard_of_guard_formula : - FStar_TypeChecker_Common.guard_formula -> guard_t) = - fun g -> - { - FStar_TypeChecker_Common.guard_f = g; - FStar_TypeChecker_Common.deferred_to_tac = - (Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic (FStar_Compiler_CList.listlike_clist ())))); - FStar_TypeChecker_Common.deferred = - (Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic (FStar_Compiler_CList.listlike_clist ())))); - FStar_TypeChecker_Common.univ_ineqs = - ((Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic (FStar_Compiler_CList.listlike_clist ())))), - (Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic (FStar_Compiler_CList.listlike_clist ()))))); - FStar_TypeChecker_Common.implicits = - (Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic (FStar_Compiler_CList.listlike_clist ())))) - } -let (guard_form : guard_t -> FStar_TypeChecker_Common.guard_formula) = - fun g -> g.FStar_TypeChecker_Common.guard_f -let (is_trivial : guard_t -> Prims.bool) = - fun g -> - let uu___ = - (((FStar_TypeChecker_Common.uu___is_Trivial - g.FStar_TypeChecker_Common.guard_f) - && - (FStar_Class_Listlike.is_empty - (FStar_Compiler_CList.listlike_clist ()) - g.FStar_TypeChecker_Common.deferred)) - && - (FStar_Class_Listlike.is_empty - (FStar_Compiler_CList.listlike_clist ()) - (FStar_Pervasives_Native.fst - g.FStar_TypeChecker_Common.univ_ineqs))) - && - (FStar_Class_Listlike.is_empty - (FStar_Compiler_CList.listlike_clist ()) - (FStar_Pervasives_Native.snd g.FStar_TypeChecker_Common.univ_ineqs)) in - if uu___ - then - FStar_Compiler_CList.for_all - (fun imp -> - (let uu___1 = - FStar_Syntax_Util.ctx_uvar_should_check - imp.FStar_TypeChecker_Common.imp_uvar in - FStar_Syntax_Syntax.uu___is_Allow_unresolved uu___1) || - (let uu___1 = - FStar_Syntax_Unionfind.find - (imp.FStar_TypeChecker_Common.imp_uvar).FStar_Syntax_Syntax.ctx_uvar_head in - match uu___1 with - | FStar_Pervasives_Native.Some uu___2 -> true - | FStar_Pervasives_Native.None -> false)) - g.FStar_TypeChecker_Common.implicits - else false -let (is_trivial_guard_formula : guard_t -> Prims.bool) = - fun g -> - match g with - | { FStar_TypeChecker_Common.guard_f = FStar_TypeChecker_Common.Trivial; - FStar_TypeChecker_Common.deferred_to_tac = uu___; - FStar_TypeChecker_Common.deferred = uu___1; - FStar_TypeChecker_Common.univ_ineqs = uu___2; - FStar_TypeChecker_Common.implicits = uu___3;_} -> true - | uu___ -> false -let (trivial_guard : guard_t) = FStar_TypeChecker_Common.trivial_guard -let (abstract_guard_n : - FStar_Syntax_Syntax.binder Prims.list -> guard_t -> guard_t) = - fun bs -> - fun g -> - match g.FStar_TypeChecker_Common.guard_f with - | FStar_TypeChecker_Common.Trivial -> g - | FStar_TypeChecker_Common.NonTrivial f -> - let f' = - FStar_Syntax_Util.abs bs f - (FStar_Pervasives_Native.Some - (FStar_Syntax_Util.residual_tot FStar_Syntax_Util.ktype0)) in - { - FStar_TypeChecker_Common.guard_f = - (FStar_TypeChecker_Common.NonTrivial f'); - FStar_TypeChecker_Common.deferred_to_tac = - (g.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (g.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (g.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = - (g.FStar_TypeChecker_Common.implicits) - } -let (abstract_guard : FStar_Syntax_Syntax.binder -> guard_t -> guard_t) = - fun b -> fun g -> abstract_guard_n [b] g -let (too_early_in_prims : env -> Prims.bool) = - fun env1 -> - let uu___ = lid_exists env1 FStar_Parser_Const.effect_GTot_lid in - Prims.op_Negation uu___ -let (apply_guard : guard_t -> FStar_Syntax_Syntax.term -> guard_t) = - fun g -> - fun e -> - match g.FStar_TypeChecker_Common.guard_f with - | FStar_TypeChecker_Common.Trivial -> g - | FStar_TypeChecker_Common.NonTrivial f -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.as_arg e in [uu___5] in - { - FStar_Syntax_Syntax.hd = f; - FStar_Syntax_Syntax.args = uu___4 - } in - FStar_Syntax_Syntax.Tm_app uu___3 in - FStar_Syntax_Syntax.mk uu___2 f.FStar_Syntax_Syntax.pos in - FStar_TypeChecker_Common.NonTrivial uu___1 in - { - FStar_TypeChecker_Common.guard_f = uu___; - FStar_TypeChecker_Common.deferred_to_tac = - (g.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (g.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (g.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = - (g.FStar_TypeChecker_Common.implicits) - } -let (map_guard : - guard_t -> - (FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) -> guard_t) - = - fun g -> - fun map -> - match g.FStar_TypeChecker_Common.guard_f with - | FStar_TypeChecker_Common.Trivial -> g - | FStar_TypeChecker_Common.NonTrivial f -> - let uu___ = - let uu___1 = map f in FStar_TypeChecker_Common.NonTrivial uu___1 in - { - FStar_TypeChecker_Common.guard_f = uu___; - FStar_TypeChecker_Common.deferred_to_tac = - (g.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (g.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (g.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = - (g.FStar_TypeChecker_Common.implicits) - } -let (always_map_guard : - guard_t -> - (FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) -> guard_t) - = - fun g -> - fun map -> - match g.FStar_TypeChecker_Common.guard_f with - | FStar_TypeChecker_Common.Trivial -> - let uu___ = - let uu___1 = map FStar_Syntax_Util.t_true in - FStar_TypeChecker_Common.NonTrivial uu___1 in - { - FStar_TypeChecker_Common.guard_f = uu___; - FStar_TypeChecker_Common.deferred_to_tac = - (g.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (g.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (g.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = - (g.FStar_TypeChecker_Common.implicits) - } - | FStar_TypeChecker_Common.NonTrivial f -> - let uu___ = - let uu___1 = map f in FStar_TypeChecker_Common.NonTrivial uu___1 in - { - FStar_TypeChecker_Common.guard_f = uu___; - FStar_TypeChecker_Common.deferred_to_tac = - (g.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (g.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (g.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = - (g.FStar_TypeChecker_Common.implicits) - } -let (trivial : FStar_TypeChecker_Common.guard_formula -> unit) = - fun t -> - match t with - | FStar_TypeChecker_Common.Trivial -> () - | FStar_TypeChecker_Common.NonTrivial uu___ -> failwith "impossible" -let (check_trivial : - FStar_Syntax_Syntax.term -> FStar_TypeChecker_Common.guard_formula) = - fun t -> FStar_TypeChecker_Common.check_trivial t -let (conj_guard : guard_t -> guard_t -> guard_t) = - fun g1 -> fun g2 -> FStar_TypeChecker_Common.conj_guard g1 g2 -let (conj_guards : guard_t Prims.list -> guard_t) = - fun gs -> FStar_TypeChecker_Common.conj_guards gs -let (imp_guard : guard_t -> guard_t -> guard_t) = - fun g1 -> fun g2 -> FStar_TypeChecker_Common.imp_guard g1 g2 -let (close_guard_univs : - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.binders -> guard_t -> guard_t) - = - fun us -> - fun bs -> - fun g -> - match g.FStar_TypeChecker_Common.guard_f with - | FStar_TypeChecker_Common.Trivial -> g - | FStar_TypeChecker_Common.NonTrivial f -> - let f1 = - FStar_Compiler_List.fold_right2 - (fun u -> - fun b -> - fun f2 -> - let uu___ = FStar_Syntax_Syntax.is_null_binder b in - if uu___ - then f2 - else - FStar_Syntax_Util.mk_forall u - b.FStar_Syntax_Syntax.binder_bv f2) us bs f in - { - FStar_TypeChecker_Common.guard_f = - (FStar_TypeChecker_Common.NonTrivial f1); - FStar_TypeChecker_Common.deferred_to_tac = - (g.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (g.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (g.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = - (g.FStar_TypeChecker_Common.implicits) - } -let (close_forall : - env -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun env1 -> - fun bs -> - fun f -> - FStar_Errors.with_ctx "While closing a formula" - (fun uu___ -> - (let uu___2 = - let uu___3 = FStar_Syntax_Syntax.mk_Total f in - FStar_Syntax_Util.arrow bs uu___3 in - FStar_Defensive.def_check_scoped hasBinders_env - FStar_Class_Binders.hasNames_term - FStar_Syntax_Print.pretty_term f.FStar_Syntax_Syntax.pos - "close_forall" env1 uu___2); - (let bvs = - FStar_Compiler_List.map - (fun b -> b.FStar_Syntax_Syntax.binder_bv) bs in - let env_full = push_bvs env1 bvs in - let uu___2 = - FStar_Compiler_List.fold_right - (fun bv -> - fun uu___3 -> - match uu___3 with - | (f1, e) -> - let e' = - let uu___4 = - let uu___5 = pop_bv e in - FStar_Compiler_Util.must uu___5 in - FStar_Pervasives_Native.snd uu___4 in - (FStar_Defensive.def_check_scoped hasBinders_env - FStar_Class_Binders.hasNames_term - FStar_Syntax_Print.pretty_term - FStar_Compiler_Range_Type.dummyRange - "close_forall.sort" e' - bv.FStar_Syntax_Syntax.sort; - (let f' = - let uu___5 = FStar_Syntax_Syntax.is_null_bv bv in - if uu___5 - then f1 - else - (let u = - e'.universe_of e' - bv.FStar_Syntax_Syntax.sort in - FStar_Syntax_Util.mk_forall u bv f1) in - (f', e')))) bvs (f, env_full) in - match uu___2 with | (f', e) -> f')) -let (close_guard : env -> FStar_Syntax_Syntax.binders -> guard_t -> guard_t) - = - fun env1 -> - fun binders -> - fun g -> - match g.FStar_TypeChecker_Common.guard_f with - | FStar_TypeChecker_Common.Trivial -> g - | FStar_TypeChecker_Common.NonTrivial f -> - let uu___ = - let uu___1 = close_forall env1 binders f in - FStar_TypeChecker_Common.NonTrivial uu___1 in - { - FStar_TypeChecker_Common.guard_f = uu___; - FStar_TypeChecker_Common.deferred_to_tac = - (g.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (g.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (g.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = - (g.FStar_TypeChecker_Common.implicits) - } -let (new_tac_implicit_var : - Prims.string -> - FStar_Compiler_Range_Type.range -> - env -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.should_check_uvar -> - FStar_Syntax_Syntax.ctx_uvar Prims.list -> - FStar_Syntax_Syntax.ctx_uvar_meta_t - FStar_Pervasives_Native.option -> - Prims.bool -> - (FStar_Syntax_Syntax.term * (FStar_Syntax_Syntax.ctx_uvar * - FStar_Compiler_Range_Type.range) * guard_t)) - = - fun reason -> - fun r -> - fun env1 -> - fun uvar_typ -> - fun should_check -> - fun uvar_typedness_deps -> - fun meta -> - fun unrefine -> - let binders = all_binders env1 in - let gamma = env1.gamma in - let decoration = - { - FStar_Syntax_Syntax.uvar_decoration_typ = uvar_typ; - FStar_Syntax_Syntax.uvar_decoration_typedness_depends_on - = uvar_typedness_deps; - FStar_Syntax_Syntax.uvar_decoration_should_check = - should_check; - FStar_Syntax_Syntax.uvar_decoration_should_unrefine = - unrefine - } in - let ctx_uvar = - let uu___ = FStar_Syntax_Unionfind.fresh decoration r in - { - FStar_Syntax_Syntax.ctx_uvar_head = uu___; - FStar_Syntax_Syntax.ctx_uvar_gamma = gamma; - FStar_Syntax_Syntax.ctx_uvar_binders = binders; - FStar_Syntax_Syntax.ctx_uvar_reason = reason; - FStar_Syntax_Syntax.ctx_uvar_range = r; - FStar_Syntax_Syntax.ctx_uvar_meta = meta - } in - FStar_TypeChecker_Common.check_uvar_ctx_invariant reason r - true gamma binders; - (let t = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_uvar - (ctx_uvar, ([], FStar_Syntax_Syntax.NoUseRange))) r in - let imp = - { - FStar_TypeChecker_Common.imp_reason = reason; - FStar_TypeChecker_Common.imp_uvar = ctx_uvar; - FStar_TypeChecker_Common.imp_tm = t; - FStar_TypeChecker_Common.imp_range = r - } in - (let uu___2 = - FStar_Compiler_Effect.op_Bang dbg_ImplicitTrace in - if uu___2 - then - let uu___3 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_uvar - ctx_uvar.FStar_Syntax_Syntax.ctx_uvar_head in - FStar_Compiler_Util.print1 - "Just created uvar for implicit {%s}\n" uu___3 - else ()); - (let g = - let uu___2 = - Obj.magic - (FStar_Class_Listlike.cons () - (Obj.magic - (FStar_Compiler_CList.listlike_clist ())) imp - (FStar_Class_Listlike.empty () - (Obj.magic - (FStar_Compiler_CList.listlike_clist ())))) in - { - FStar_TypeChecker_Common.guard_f = - (trivial_guard.FStar_TypeChecker_Common.guard_f); - FStar_TypeChecker_Common.deferred_to_tac = - (trivial_guard.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (trivial_guard.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (trivial_guard.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = uu___2 - } in - (t, (ctx_uvar, r), g))) -let (new_implicit_var_aux : - Prims.string -> - FStar_Compiler_Range_Type.range -> - env -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.should_check_uvar -> - FStar_Syntax_Syntax.ctx_uvar_meta_t - FStar_Pervasives_Native.option -> - Prims.bool -> - (FStar_Syntax_Syntax.term * (FStar_Syntax_Syntax.ctx_uvar * - FStar_Compiler_Range_Type.range) * guard_t)) - = - fun reason -> - fun r -> - fun env1 -> - fun k -> - fun should_check -> - fun meta -> - fun unrefine -> - new_tac_implicit_var reason r env1 k should_check [] meta - unrefine -let (uvar_meta_for_binder : - FStar_Syntax_Syntax.binder -> - (FStar_Syntax_Syntax.ctx_uvar_meta_t FStar_Pervasives_Native.option * - Prims.bool)) - = - fun b -> - let should_unrefine = - FStar_Syntax_Util.has_attribute b.FStar_Syntax_Syntax.binder_attrs - FStar_Parser_Const.unrefine_binder_attr in - let meta = - match b.FStar_Syntax_Syntax.binder_qual with - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta tau) -> - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Ctx_uvar_meta_tac tau) - | uu___ -> - let is_unification_tag t = - let uu___1 = FStar_Syntax_Util.head_and_args t in - match uu___1 with - | (hd, args) -> - let hd1 = FStar_Syntax_Util.un_uinst hd in - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Subst.compress hd1 in - uu___4.FStar_Syntax_Syntax.n in - (uu___3, args) in - (match uu___2 with - | (FStar_Syntax_Syntax.Tm_fvar fv, - (uu___3, FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = uu___4;_}):: - (a, FStar_Pervasives_Native.None)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.unification_tag_lid - -> FStar_Pervasives_Native.Some a - | uu___3 -> FStar_Pervasives_Native.None) in - let uu___1 = - FStar_Compiler_List.tryPick is_unification_tag - b.FStar_Syntax_Syntax.binder_attrs in - (match uu___1 with - | FStar_Pervasives_Native.Some tag -> - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Ctx_uvar_meta_attr tag) - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None) in - (meta, should_unrefine) -let (uvars_for_binders : - env -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.subst_t -> - (FStar_Syntax_Syntax.binder -> Prims.string) -> - FStar_Compiler_Range_Type.range -> - (FStar_Syntax_Syntax.term Prims.list * guard_t)) - = - fun env1 -> - fun bs -> - fun substs -> - fun reason -> - fun r -> - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun b -> - match uu___1 with - | (substs1, uvars, g) -> - let sort = - FStar_Syntax_Subst.subst substs1 - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - let uu___2 = uvar_meta_for_binder b in - (match uu___2 with - | (ctx_uvar_meta, should_unrefine) -> - let uu___3 = - let uu___4 = reason b in - let uu___5 = - let uu___6 = - FStar_Options.compat_pre_typed_indexed_effects - () in - if uu___6 - then - FStar_Syntax_Syntax.Allow_untyped - "indexed effect uvar in compat mode" - else FStar_Syntax_Syntax.Strict in - new_implicit_var_aux uu___4 r env1 sort - uu___5 ctx_uvar_meta should_unrefine in - (match uu___3 with - | (t, l_ctx_uvars, g_t) -> - ((let uu___5 = - FStar_Compiler_Effect.op_Bang - dbg_LayeredEffectsEqns in - if uu___5 - then - let uu___6 = - FStar_Class_Show.show - (FStar_Class_Show.show_tuple2 - FStar_Syntax_Print.showable_ctxu - FStar_Compiler_Range_Ops.showable_range) - l_ctx_uvars in - FStar_Compiler_Util.print1 - "Layered Effect uvar: %s\n" uu___6 - else ()); - (let uu___5 = conj_guards [g; g_t] in - ((FStar_Compiler_List.op_At substs1 - [FStar_Syntax_Syntax.NT - ((b.FStar_Syntax_Syntax.binder_bv), - t)]), - (FStar_Compiler_List.op_At uvars [t]), - uu___5)))))) - (substs, [], trivial_guard) bs in - match uu___ with | (uu___1, uvars, g) -> (uvars, g) -let (pure_precondition_for_trivial_post : - env -> - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.typ -> - FStar_Compiler_Range_Type.range -> FStar_Syntax_Syntax.typ) - = - fun env1 -> - fun u -> - fun t -> - fun wp -> - fun r -> - let trivial_post = - let post_ts = - let uu___ = - lookup_definition [NoDelta] env1 - FStar_Parser_Const.trivial_pure_post_lid in - FStar_Compiler_Util.must uu___ in - let uu___ = inst_tscheme_with post_ts [u] in - match uu___ with - | (uu___1, post) -> - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.as_arg t in [uu___3] in - FStar_Syntax_Syntax.mk_Tm_app post uu___2 r in - let uu___ = - let uu___1 = FStar_Syntax_Syntax.as_arg trivial_post in - [uu___1] in - FStar_Syntax_Syntax.mk_Tm_app wp uu___ r -let (get_letrec_arity : - env -> - FStar_Syntax_Syntax.lbname -> Prims.int FStar_Pervasives_Native.option) - = - fun env1 -> - fun lbname -> - let compare_either f1 f2 e1 e2 = - match (e1, e2) with - | (FStar_Pervasives.Inl v1, FStar_Pervasives.Inl v2) -> f1 v1 v2 - | (FStar_Pervasives.Inr v1, FStar_Pervasives.Inr v2) -> f2 v1 v2 - | uu___ -> false in - let uu___ = - FStar_Compiler_Util.find_opt - (fun uu___1 -> - match uu___1 with - | (lbname', uu___2, uu___3, uu___4) -> - compare_either FStar_Syntax_Syntax.bv_eq - FStar_Syntax_Syntax.fv_eq lbname lbname') env1.letrecs in - match uu___ with - | FStar_Pervasives_Native.Some (uu___1, arity, uu___2, uu___3) -> - FStar_Pervasives_Native.Some arity - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None -let (fvar_of_nonqual_lid : - env -> FStar_Ident.lident -> FStar_Syntax_Syntax.term) = - fun env1 -> - fun lid -> - let qn = lookup_qname env1 lid in - FStar_Syntax_Syntax.fvar lid FStar_Pervasives_Native.None -let (split_smt_query : - env -> - FStar_Syntax_Syntax.term -> - (env * FStar_Syntax_Syntax.term) Prims.list - FStar_Pervasives_Native.option) - = - fun e -> - fun q -> - match (e.solver).spinoff_strictly_positive_goals with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some p -> - let uu___ = p e q in FStar_Pervasives_Native.Some uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Err.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Err.ml deleted file mode 100644 index 6db6fdc1b06..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Err.ml +++ /dev/null @@ -1,815 +0,0 @@ -open Prims -let (info_at_pos : - FStar_TypeChecker_Env.env -> - Prims.string -> - Prims.int -> - Prims.int -> - ((Prims.string, FStar_Ident.lident) FStar_Pervasives.either * - FStar_Syntax_Syntax.typ * FStar_Compiler_Range_Type.range) - FStar_Pervasives_Native.option) - = - fun env -> - fun file -> - fun row -> - fun col -> - let uu___ = - let uu___1 = - FStar_Compiler_Effect.op_Bang - env.FStar_TypeChecker_Env.identifier_info in - FStar_TypeChecker_Common.id_info_at_pos uu___1 file row col in - match uu___ with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some info -> - (match info.FStar_TypeChecker_Common.identifier with - | FStar_Pervasives.Inl bv -> - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Ident.showable_ident - bv.FStar_Syntax_Syntax.ppname in - FStar_Pervasives.Inl uu___3 in - let uu___3 = FStar_Syntax_Syntax.range_of_bv bv in - (uu___2, (info.FStar_TypeChecker_Common.identifier_ty), - uu___3) in - FStar_Pervasives_Native.Some uu___1 - | FStar_Pervasives.Inr fv -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.lid_of_fv fv in - FStar_Pervasives.Inr uu___3 in - let uu___3 = FStar_Syntax_Syntax.range_of_fv fv in - (uu___2, (info.FStar_TypeChecker_Common.identifier_ty), - uu___3) in - FStar_Pervasives_Native.Some uu___1) -let print_discrepancy : 'a 'b . ('a -> 'b) -> 'a -> 'a -> ('b * 'b) = - fun f -> - fun x -> - fun y -> - let print uu___ = - let xs = f x in let ys = f y in (xs, ys, (xs <> ys)) in - let rec blist_leq l1 l2 = - match (l1, l2) with - | (h1::t1, h2::t2) -> - ((Prims.op_Negation h1) || h2) && (blist_leq t1 t2) - | ([], []) -> true - | uu___ -> failwith "print_discrepancy: bad lists" in - let rec succ l = - match l with - | (false)::t -> true :: t - | (true)::t -> let uu___ = succ t in false :: uu___ - | [] -> failwith "" in - let full l = FStar_Compiler_List.for_all (fun b1 -> b1) l in - let get_bool_option s = - let uu___ = FStar_Options.get_option s in - match uu___ with - | FStar_Options.Bool b1 -> b1 - | uu___1 -> failwith "print_discrepancy: impossible" in - let set_bool_option s b1 = - FStar_Options.set_option s (FStar_Options.Bool b1) in - let get uu___ = - let pi = get_bool_option "print_implicits" in - let pu = get_bool_option "print_universes" in - let pea = get_bool_option "print_effect_args" in - let pf = get_bool_option "print_full_names" in [pi; pu; pea; pf] in - let set l = - match l with - | pi::pu::pea::pf::[] -> - (set_bool_option "print_implicits" pi; - set_bool_option "print_universes" pu; - set_bool_option "print_effect_args" pea; - set_bool_option "print_full_names " pf) - | uu___ -> failwith "impossible: print_discrepancy" in - let bas = get () in - let rec go cur = - if full cur - then - let uu___ = print () in - match uu___ with | (xs, ys, uu___1) -> (xs, ys) - else - if (let uu___ = blist_leq bas cur in Prims.op_Negation uu___) - then (let uu___ = succ cur in go uu___) - else - (set cur; - (let uu___1 = print () in - match uu___1 with - | (xs, ys, true) -> (xs, ys) - | uu___2 -> let uu___3 = succ cur in go uu___3)) in - FStar_Options.with_saved_options (fun uu___ -> go bas) -let (errors_smt_detail : - FStar_TypeChecker_Env.env -> - FStar_Errors.error Prims.list -> - FStar_Errors_Msg.error_message -> FStar_Errors.error Prims.list) - = - fun env -> - fun errs -> - fun smt_detail -> - let errs1 = - FStar_Compiler_List.map - (fun uu___ -> - match uu___ with - | (e, msg, r, ctx) -> - let uu___1 = - let msg1 = FStar_Compiler_List.op_At msg smt_detail in - if r = FStar_Compiler_Range_Type.dummyRange - then - let uu___2 = FStar_TypeChecker_Env.get_range env in - (e, msg1, uu___2, ctx) - else - (let r' = - let uu___3 = FStar_Compiler_Range_Type.use_range r in - FStar_Compiler_Range_Type.set_def_range r uu___3 in - let uu___3 = - let uu___4 = - FStar_Compiler_Range_Ops.file_of_range r' in - let uu___5 = - let uu___6 = FStar_TypeChecker_Env.get_range env in - FStar_Compiler_Range_Ops.file_of_range uu___6 in - uu___4 <> uu___5 in - if uu___3 - then - let msg2 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Compiler_Range_Ops.string_of_use_range - r in - Prims.strcat "Also see: " uu___7 in - FStar_Pprint.doc_of_string uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Compiler_Range_Type.use_range r in - let uu___10 = - FStar_Compiler_Range_Type.def_range r in - uu___9 <> uu___10 in - if uu___8 - then - let uu___9 = - let uu___10 = - FStar_Compiler_Range_Ops.string_of_def_range - r in - Prims.strcat - "Other related locations: " uu___10 in - FStar_Pprint.doc_of_string uu___9 - else FStar_Pprint.empty in - [uu___7] in - uu___5 :: uu___6 in - FStar_Compiler_List.op_At msg1 uu___4 in - let uu___4 = FStar_TypeChecker_Env.get_range env in - (e, msg2, uu___4, ctx) - else (e, msg1, r, ctx)) in - (match uu___1 with - | (e1, msg1, r1, ctx1) -> (e1, msg1, r1, ctx1))) errs in - errs1 -let (add_errors : - FStar_TypeChecker_Env.env -> FStar_Errors.error Prims.list -> unit) = - fun env -> - fun errs -> - let uu___ = errors_smt_detail env errs [] in - FStar_Errors.add_errors uu___ -let (log_issue : - FStar_TypeChecker_Env.env -> - FStar_Compiler_Range_Type.range -> - (FStar_Errors_Codes.error_code * FStar_Errors_Msg.error_message) -> - unit) - = - fun env -> - fun r -> - fun uu___ -> - match uu___ with - | (e, m) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Errors.get_ctx () in (e, m, r, uu___3) in - [uu___2] in - add_errors env uu___1 -let (log_issue_text : - FStar_TypeChecker_Env.env -> - FStar_Compiler_Range_Type.range -> - (FStar_Errors_Codes.error_code * Prims.string) -> unit) - = - fun env -> - fun r -> - fun uu___ -> - match uu___ with - | (e, m) -> - let uu___1 = - let uu___2 = let uu___3 = FStar_Errors_Msg.text m in [uu___3] in - (e, uu___2) in - log_issue env r uu___1 -let (err_msg_type_strings : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> (Prims.string * Prims.string)) - = - fun env -> - fun t1 -> - fun t2 -> - print_discrepancy (FStar_TypeChecker_Normalize.term_to_string env) t1 - t2 -let (err_msg_comp_strings : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.comp -> - FStar_Syntax_Syntax.comp -> (Prims.string * Prims.string)) - = - fun env -> - fun c1 -> - fun c2 -> - print_discrepancy (FStar_TypeChecker_Normalize.comp_to_string env) c1 - c2 -let (exhaustiveness_check : FStar_Pprint.document Prims.list) = - let uu___ = FStar_Errors_Msg.text "Patterns are incomplete" in [uu___] -let (subtyping_failed : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.typ -> unit -> FStar_Errors_Msg.error_message) - = - fun env -> - fun t1 -> - fun t2 -> - fun uu___ -> - let ppt = FStar_TypeChecker_Normalize.term_to_doc env in - let uu___1 = FStar_Errors_Msg.text "Subtyping check failed" in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Errors_Msg.text "Expected type" in - let uu___6 = ppt t2 in - FStar_Pprint.prefix (Prims.of_int (2)) Prims.int_one uu___5 - uu___6 in - let uu___5 = - let uu___6 = FStar_Errors_Msg.text "got type" in - let uu___7 = ppt t1 in - FStar_Pprint.prefix (Prims.of_int (2)) Prims.int_one uu___6 - uu___7 in - FStar_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in - [uu___3] in - uu___1 :: uu___2 -let (ill_kinded_type : FStar_Errors_Msg.error_message) = - FStar_Errors_Msg.mkmsg "Ill-kinded type" -let unexpected_signature_for_monad : - 'a . - FStar_TypeChecker_Env.env -> - FStar_Compiler_Range_Type.range -> - FStar_Ident.lident -> FStar_Syntax_Syntax.term -> 'a - = - fun env -> - fun rng -> - fun m -> - fun k -> - let uu___ = - let uu___1 = FStar_Class_Show.show FStar_Ident.showable_lident m in - let uu___2 = FStar_TypeChecker_Normalize.term_to_string env k in - FStar_Compiler_Util.format2 - "Unexpected signature for monad \"%s\". Expected a signature of the form (a:Type -> WP a -> Effect); got %s" - uu___1 uu___2 in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range rng - FStar_Errors_Codes.Fatal_UnexpectedSignatureForMonad () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___) -let expected_a_term_of_type_t_got_a_function : - 'uuuuu . - FStar_TypeChecker_Env.env -> - FStar_Compiler_Range_Type.range -> - Prims.string -> - FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.term -> 'uuuuu - = - fun env -> - fun rng -> - fun msg -> - fun t -> - fun e -> - let uu___ = - let uu___1 = FStar_TypeChecker_Normalize.term_to_string env t in - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - FStar_Compiler_Util.format3 - "Expected a term of type \"%s\"; got a function \"%s\" (%s)" - uu___1 uu___2 msg in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range rng - FStar_Errors_Codes.Fatal_ExpectTermGotFunction () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___) -let (unexpected_implicit_argument : - (FStar_Errors_Codes.error_code * Prims.string)) = - (FStar_Errors_Codes.Fatal_UnexpectedImplicitArgument, - "Unexpected instantiation of an implicit argument to a function that only expects explicit arguments") -let expected_expression_of_type : - 'a . - FStar_TypeChecker_Env.env -> - FStar_Compiler_Range_Type.range -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term -> 'a - = - fun env -> - fun rng -> - fun t1 -> - fun e -> - fun t2 -> - let d1 = FStar_TypeChecker_Normalize.term_to_doc env t1 in - let d2 = FStar_TypeChecker_Normalize.term_to_doc env t2 in - let ed = FStar_TypeChecker_Normalize.term_to_doc env e in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Errors_Msg.text "Expected expression of type" in - FStar_Pprint.prefix (Prims.of_int (4)) Prims.int_one uu___3 - d1 in - let uu___3 = - let uu___4 = - let uu___5 = FStar_Errors_Msg.text "got expression" in - FStar_Pprint.prefix (Prims.of_int (4)) Prims.int_one - uu___5 ed in - let uu___5 = - let uu___6 = FStar_Errors_Msg.text "of type" in - FStar_Pprint.prefix (Prims.of_int (4)) Prims.int_one - uu___6 d2 in - FStar_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in - FStar_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in - [uu___1] in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range rng - FStar_Errors_Codes.Fatal_UnexpectedExpressionType () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___) -let (expected_pattern_of_type : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> - (FStar_Errors_Codes.error_code * Prims.string)) - = - fun env -> - fun t1 -> - fun e -> - fun t2 -> - let uu___ = err_msg_type_strings env t1 t2 in - match uu___ with - | (s1, s2) -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - FStar_Compiler_Util.format3 - "Expected pattern of type \"%s\"; got pattern \"%s\" of type \"%s\"" - s1 uu___2 s2 in - (FStar_Errors_Codes.Fatal_UnexpectedPattern, uu___1) -let (basic_type_error : - FStar_TypeChecker_Env.env -> - FStar_Compiler_Range_Type.range -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term -> unit) - = - fun env -> - fun rng -> - fun eopt -> - fun t1 -> - fun t2 -> - let uu___ = err_msg_type_strings env t1 t2 in - match uu___ with - | (s1, s2) -> - let msg = - match eopt with - | FStar_Pervasives_Native.None -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Errors_Msg.text "Expected type" in - let uu___4 = - FStar_TypeChecker_Normalize.term_to_doc env t1 in - FStar_Pprint.prefix (Prims.of_int (4)) - Prims.int_one uu___3 uu___4 in - let uu___3 = - let uu___4 = FStar_Errors_Msg.text "got type" in - let uu___5 = - FStar_TypeChecker_Normalize.term_to_doc env t2 in - FStar_Pprint.prefix (Prims.of_int (4)) - Prims.int_one uu___4 uu___5 in - FStar_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in - [uu___1] - | FStar_Pervasives_Native.Some e -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Errors_Msg.text "Expected type" in - let uu___4 = - FStar_TypeChecker_Normalize.term_to_doc env t1 in - FStar_Pprint.prefix (Prims.of_int (4)) - Prims.int_one uu___3 uu___4 in - let uu___3 = - let uu___4 = - let uu___5 = FStar_Errors_Msg.text "but" in - let uu___6 = - FStar_TypeChecker_Normalize.term_to_doc env e in - FStar_Pprint.prefix (Prims.of_int (4)) - Prims.int_one uu___5 uu___6 in - let uu___5 = - let uu___6 = FStar_Errors_Msg.text "has type" in - let uu___7 = - FStar_TypeChecker_Normalize.term_to_doc env t2 in - FStar_Pprint.prefix (Prims.of_int (4)) - Prims.int_one uu___6 uu___7 in - FStar_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in - FStar_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in - [uu___1] in - FStar_Errors.log_issue FStar_Class_HasRange.hasRange_range - rng FStar_Errors_Codes.Error_TypeError () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic msg) -let raise_basic_type_error : - 'a . - FStar_TypeChecker_Env.env -> - FStar_Compiler_Range_Type.range -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term -> 'a - = - fun env -> - fun rng -> - fun eopt -> - fun t1 -> - fun t2 -> - let uu___ = err_msg_type_strings env t1 t2 in - match uu___ with - | (s1, s2) -> - let msg = - match eopt with - | FStar_Pervasives_Native.None -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Errors_Msg.text "Expected type" in - let uu___4 = - FStar_TypeChecker_Normalize.term_to_doc env t1 in - FStar_Pprint.prefix (Prims.of_int (4)) - Prims.int_one uu___3 uu___4 in - let uu___3 = - let uu___4 = FStar_Errors_Msg.text "got type" in - let uu___5 = - FStar_TypeChecker_Normalize.term_to_doc env t2 in - FStar_Pprint.prefix (Prims.of_int (4)) - Prims.int_one uu___4 uu___5 in - FStar_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in - [uu___1] - | FStar_Pervasives_Native.Some e -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Errors_Msg.text "Expected type" in - let uu___4 = - FStar_TypeChecker_Normalize.term_to_doc env t1 in - FStar_Pprint.prefix (Prims.of_int (4)) - Prims.int_one uu___3 uu___4 in - let uu___3 = - let uu___4 = - let uu___5 = FStar_Errors_Msg.text "but" in - let uu___6 = - FStar_TypeChecker_Normalize.term_to_doc env e in - FStar_Pprint.prefix (Prims.of_int (4)) - Prims.int_one uu___5 uu___6 in - let uu___5 = - let uu___6 = FStar_Errors_Msg.text "has type" in - let uu___7 = - FStar_TypeChecker_Normalize.term_to_doc env t2 in - FStar_Pprint.prefix (Prims.of_int (4)) - Prims.int_one uu___6 uu___7 in - FStar_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in - FStar_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in - [uu___1] in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range - rng FStar_Errors_Codes.Error_TypeError () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic msg) -let (occurs_check : (FStar_Errors_Codes.error_code * Prims.string)) = - (FStar_Errors_Codes.Fatal_PossibleInfiniteTyp, - "Possibly infinite typ (occurs check failed)") -let constructor_fails_the_positivity_check : - 'uuuuu . - 'uuuuu -> - FStar_Syntax_Syntax.term -> - FStar_Ident.lid -> (FStar_Errors_Codes.error_code * Prims.string) - = - fun env -> - fun d -> - fun l -> - let uu___ = - let uu___1 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term d in - let uu___2 = FStar_Class_Show.show FStar_Ident.showable_lident l in - FStar_Compiler_Util.format2 - "Constructor \"%s\" fails the strict positivity check; the constructed type \"%s\" occurs to the left of a pure function type" - uu___1 uu___2 in - (FStar_Errors_Codes.Fatal_ConstructorFailedCheck, uu___) -let (inline_type_annotation_and_val_decl : - FStar_Ident.lid -> (FStar_Errors_Codes.error_code * Prims.string)) = - fun l -> - let uu___ = - let uu___1 = FStar_Class_Show.show FStar_Ident.showable_lident l in - FStar_Compiler_Util.format1 - "\"%s\" has a val declaration as well as an inlined type annotation; remove one" - uu___1 in - (FStar_Errors_Codes.Fatal_DuplicateTypeAnnotationAndValDecl, uu___) -let (inferred_type_causes_variable_to_escape : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.bv -> - (FStar_Errors_Codes.error_code * Prims.string)) - = - fun env -> - fun t -> - fun x -> - let uu___ = - let uu___1 = FStar_TypeChecker_Normalize.term_to_string env t in - let uu___2 = FStar_Class_Show.show FStar_Syntax_Print.showable_bv x in - FStar_Compiler_Util.format2 - "Inferred type \"%s\" causes variable \"%s\" to escape its scope" - uu___1 uu___2 in - (FStar_Errors_Codes.Fatal_InferredTypeCauseVarEscape, uu___) -let expected_function_typ : - 'a . - FStar_TypeChecker_Env.env -> - FStar_Compiler_Range_Type.range -> FStar_Syntax_Syntax.term -> 'a - = - fun env -> - fun rng -> - fun t -> - let uu___ = - let uu___1 = FStar_Errors_Msg.text "Expected a function." in - let uu___2 = - let uu___3 = - let uu___4 = FStar_Errors_Msg.text "Got an expression of type:" in - let uu___5 = FStar_TypeChecker_Normalize.term_to_doc env t in - FStar_Pprint.prefix (Prims.of_int (2)) Prims.int_one uu___4 - uu___5 in - [uu___3] in - uu___1 :: uu___2 in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range rng - FStar_Errors_Codes.Fatal_FunctionTypeExpected () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___) -let (expected_poly_typ : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> - (FStar_Errors_Codes.error_code * Prims.string)) - = - fun env -> - fun f -> - fun t -> - fun targ -> - let uu___ = - let uu___1 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term f in - let uu___2 = FStar_TypeChecker_Normalize.term_to_string env t in - let uu___3 = FStar_TypeChecker_Normalize.term_to_string env targ in - FStar_Compiler_Util.format3 - "Expected a polymorphic function; got an expression \"%s\" of type \"%s\" applied to a type \"%s\"" - uu___1 uu___2 uu___3 in - (FStar_Errors_Codes.Fatal_PolyTypeExpected, uu___) -let (disjunctive_pattern_vars : - FStar_Syntax_Syntax.bv Prims.list -> - FStar_Syntax_Syntax.bv Prims.list -> - (FStar_Errors_Codes.error_code * Prims.string)) - = - fun v1 -> - fun v2 -> - let vars v = - let uu___ = - FStar_Compiler_List.map - (FStar_Class_Show.show FStar_Syntax_Print.showable_bv) v in - FStar_Compiler_String.concat ", " uu___ in - let uu___ = - let uu___1 = vars v1 in - let uu___2 = vars v2 in - FStar_Compiler_Util.format2 - "Every alternative of an 'or' pattern must bind the same variables; here one branch binds (\"%s\") and another (\"%s\")" - uu___1 uu___2 in - (FStar_Errors_Codes.Fatal_DisjuctivePatternVarsMismatch, uu___) -let (name_and_result : - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> - (Prims.string * FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax)) - = - fun c -> - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total t -> ("Tot", t) - | FStar_Syntax_Syntax.GTotal t -> ("GTot", t) - | FStar_Syntax_Syntax.Comp ct -> - let uu___ = - FStar_Class_Show.show FStar_Ident.showable_lident - ct.FStar_Syntax_Syntax.effect_name in - (uu___, (ct.FStar_Syntax_Syntax.result_typ)) -let computed_computation_type_does_not_match_annotation : - 'uuuuu 'a . - FStar_TypeChecker_Env.env -> - FStar_Compiler_Range_Type.range -> - 'uuuuu -> - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> 'a - = - fun env -> - fun r -> - fun e -> - fun c -> - fun c' -> - let ppt = FStar_TypeChecker_Normalize.term_to_doc env in - let uu___ = name_and_result c in - match uu___ with - | (f1, r1) -> - let uu___1 = name_and_result c' in - (match uu___1 with - | (f2, r2) -> - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Errors_Msg.text "Computed type" in - let uu___6 = ppt r1 in - FStar_Pprint.prefix (Prims.of_int (2)) - Prims.int_one uu___5 uu___6 in - let uu___5 = - let uu___6 = - let uu___7 = FStar_Errors_Msg.text "and effect" in - let uu___8 = FStar_Errors_Msg.text f1 in - FStar_Pprint.prefix (Prims.of_int (2)) - Prims.int_one uu___7 uu___8 in - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Errors_Msg.text - "is not compatible with the annotated type" in - let uu___10 = ppt r2 in - FStar_Pprint.prefix (Prims.of_int (2)) - Prims.int_one uu___9 uu___10 in - let uu___9 = - let uu___10 = - FStar_Errors_Msg.text "and effect" in - let uu___11 = FStar_Errors_Msg.text f2 in - FStar_Pprint.prefix (Prims.of_int (2)) - Prims.int_one uu___10 uu___11 in - FStar_Pprint.op_Hat_Slash_Hat uu___8 uu___9 in - FStar_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in - FStar_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in - [uu___3] in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_ComputedTypeNotMatchAnnotation - () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___2)) -let computed_computation_type_does_not_match_annotation_eq : - 'uuuuu 'a . - FStar_TypeChecker_Env.env -> - FStar_Compiler_Range_Type.range -> - 'uuuuu -> FStar_Syntax_Syntax.comp -> FStar_Syntax_Syntax.comp -> 'a - = - fun env -> - fun r -> - fun e -> - fun c -> - fun c' -> - let ppc = FStar_TypeChecker_Normalize.comp_to_doc env in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Errors_Msg.text "Computed type" in - let uu___4 = ppc c in - FStar_Pprint.prefix (Prims.of_int (2)) Prims.int_one uu___3 - uu___4 in - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Errors_Msg.text "does not match annotated type" in - let uu___6 = ppc c' in - FStar_Pprint.prefix (Prims.of_int (2)) Prims.int_one - uu___5 uu___6 in - let uu___5 = - FStar_Errors_Msg.text "and no subtyping was allowed" in - FStar_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in - FStar_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in - [uu___1] in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_ComputedTypeNotMatchAnnotation () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___) -let unexpected_non_trivial_precondition_on_term : - 'a . FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.term -> 'a = - fun env -> - fun f -> - let uu___ = - let uu___1 = FStar_TypeChecker_Normalize.term_to_string env f in - FStar_Compiler_Util.format1 - "Term has an unexpected non-trivial pre-condition: %s" uu___1 in - FStar_Errors.raise_error FStar_TypeChecker_Env.hasRange_env env - FStar_Errors_Codes.Fatal_UnExpectedPreCondition () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___) -let __expected_eff_expression : - 'uuuuu . - Prims.string -> - FStar_Compiler_Range_Type.range -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.comp -> - Prims.string FStar_Pervasives_Native.option -> 'uuuuu - = - fun effname -> - fun rng -> - fun e -> - fun c -> - fun reason -> - let uu___ = - let uu___1 = - FStar_Errors_Msg.text - (Prims.strcat "Expected a " - (Prims.strcat effname " expression.")) in - let uu___2 = - let uu___3 = - match reason with - | FStar_Pervasives_Native.None -> FStar_Pprint.empty - | FStar_Pervasives_Native.Some msg -> - let uu___4 = FStar_Pprint.break_ Prims.int_one in - let uu___5 = - let uu___6 = FStar_Pprint.doc_of_string "Because:" in - let uu___7 = - FStar_Pprint.words (Prims.strcat msg ".") in - uu___6 :: uu___7 in - FStar_Pprint.flow uu___4 uu___5 in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = FStar_Errors_Msg.text "Got an expression" in - let uu___8 = - FStar_Class_PP.pp FStar_Syntax_Print.pretty_term e in - FStar_Pprint.prefix (Prims.of_int (2)) Prims.int_one - uu___7 uu___8 in - let uu___7 = - let uu___8 = - let uu___9 = FStar_Errors_Msg.text "with effect" in - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = name_and_result c in - FStar_Pervasives_Native.fst uu___13 in - FStar_Pprint.doc_of_string uu___12 in - FStar_Pprint.squotes uu___11 in - FStar_Pprint.prefix (Prims.of_int (2)) Prims.int_one - uu___9 uu___10 in - FStar_Pprint.op_Hat_Hat uu___8 FStar_Pprint.dot in - FStar_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in - [uu___5] in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range rng - FStar_Errors_Codes.Fatal_ExpectedGhostExpression () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___) -let expected_pure_expression : - 'uuuuu . - FStar_Compiler_Range_Type.range -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.comp -> - Prims.string FStar_Pervasives_Native.option -> 'uuuuu - = - fun rng -> - fun e -> - fun c -> fun reason -> __expected_eff_expression "pure" rng e c reason -let expected_ghost_expression : - 'uuuuu . - FStar_Compiler_Range_Type.range -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.comp -> - Prims.string FStar_Pervasives_Native.option -> 'uuuuu - = - fun rng -> - fun e -> - fun c -> fun reason -> __expected_eff_expression "ghost" rng e c reason -let (expected_effect_1_got_effect_2 : - FStar_Ident.lident -> - FStar_Ident.lident -> (FStar_Errors_Codes.error_code * Prims.string)) - = - fun c1 -> - fun c2 -> - let uu___ = - let uu___1 = FStar_Class_Show.show FStar_Ident.showable_lident c1 in - let uu___2 = FStar_Class_Show.show FStar_Ident.showable_lident c2 in - FStar_Compiler_Util.format2 - "Expected a computation with effect %s; but it has effect %s" - uu___1 uu___2 in - (FStar_Errors_Codes.Fatal_UnexpectedEffect, uu___) -let (failed_to_prove_specification_of : - FStar_Syntax_Syntax.lbname -> - Prims.string Prims.list -> (FStar_Errors_Codes.error_code * Prims.string)) - = - fun l -> - fun lbls -> - let uu___ = - let uu___1 = - FStar_Class_Show.show - (FStar_Class_Show.show_either FStar_Syntax_Print.showable_bv - FStar_Syntax_Print.showable_fv) l in - FStar_Compiler_Util.format2 - "Failed to prove specification of %s; assertions at [%s] may fail" - uu___1 (FStar_Compiler_String.concat ", " lbls) in - (FStar_Errors_Codes.Error_TypeCheckerFailToProve, uu___) -let (warn_top_level_effect : FStar_Compiler_Range_Type.range -> unit) = - fun rng -> - FStar_Errors.log_issue FStar_Class_HasRange.hasRange_range rng - FStar_Errors_Codes.Warning_TopLevelEffect () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Top-level let-bindings must be total; this term may have effects") \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Generalize.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Generalize.ml deleted file mode 100644 index 3954153b498..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Generalize.ml +++ /dev/null @@ -1,708 +0,0 @@ -open Prims -let (dbg_Gen : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Gen" -let (showable_univ_var : - FStar_Syntax_Syntax.universe_uvar FStar_Class_Show.showable) = - { - FStar_Class_Show.show = - (fun u -> - FStar_Class_Show.show FStar_Syntax_Print.showable_univ - (FStar_Syntax_Syntax.U_unif u)) - } -let (gen_univs : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.universe_uvar FStar_Compiler_FlatSet.t -> - FStar_Syntax_Syntax.univ_name Prims.list) - = - fun env -> - fun x -> - let uu___ = - FStar_Class_Setlike.is_empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_univ_uvar)) (Obj.magic x) in - if uu___ - then [] - else - (let s = - let uu___2 = - let uu___3 = FStar_TypeChecker_Env.univ_vars env in - Obj.magic - (FStar_Class_Setlike.diff () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_univ_uvar)) (Obj.magic x) - (Obj.magic uu___3)) in - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_univ_uvar)) (Obj.magic uu___2) in - (let uu___3 = FStar_Compiler_Effect.op_Bang dbg_Gen in - if uu___3 - then - let uu___4 = - let uu___5 = FStar_TypeChecker_Env.univ_vars env in - FStar_Class_Show.show - (FStar_Compiler_FlatSet.showable_set - FStar_Syntax_Free.ord_univ_uvar showable_univ_var) uu___5 in - FStar_Compiler_Util.print1 "univ_vars in env: %s\n" uu___4 - else ()); - (let r = - let uu___3 = FStar_TypeChecker_Env.get_range env in - FStar_Pervasives_Native.Some uu___3 in - let u_names = - FStar_Compiler_List.map - (fun u -> - let u_name = FStar_Syntax_Syntax.new_univ_name r in - (let uu___4 = FStar_Compiler_Effect.op_Bang dbg_Gen in - if uu___4 - then - let uu___5 = - let uu___6 = FStar_Syntax_Unionfind.univ_uvar_id u in - FStar_Compiler_Util.string_of_int uu___6 in - let uu___6 = - FStar_Class_Show.show FStar_Syntax_Print.showable_univ - (FStar_Syntax_Syntax.U_unif u) in - let uu___7 = - FStar_Class_Show.show FStar_Syntax_Print.showable_univ - (FStar_Syntax_Syntax.U_name u_name) in - FStar_Compiler_Util.print3 "Setting ?%s (%s) to %s\n" - uu___5 uu___6 uu___7 - else ()); - FStar_Syntax_Unionfind.univ_change u - (FStar_Syntax_Syntax.U_name u_name); - u_name) s in - u_names)) -let (gather_free_univnames : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.univ_name FStar_Compiler_FlatSet.t) - = - fun env -> - fun t -> - let ctx_univnames = FStar_TypeChecker_Env.univnames env in - let tm_univnames = FStar_Syntax_Free.univnames t in - let univnames = - Obj.magic - (FStar_Class_Setlike.diff () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_ident)) (Obj.magic tm_univnames) - (Obj.magic ctx_univnames)) in - univnames -let (check_universe_generalization : - FStar_Syntax_Syntax.univ_name Prims.list -> - FStar_Syntax_Syntax.univ_name Prims.list -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.univ_name Prims.list) - = - fun explicit_univ_names -> - fun generalized_univ_names -> - fun t -> - match (explicit_univ_names, generalized_univ_names) with - | ([], uu___) -> generalized_univ_names - | (uu___, []) -> explicit_univ_names - | uu___ -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - Prims.strcat - "Generalized universe in a term containing explicit universe annotation : " - uu___2 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) t - FStar_Errors_Codes.Fatal_UnexpectedGeneralizedUniverse () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) -let (generalize_universes : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.tscheme) - = - fun env -> - fun t0 -> - FStar_Errors.with_ctx "While generalizing universes" - (fun uu___ -> - let t = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.NoFullNorm; - FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.DoNotUnfoldPureLets] env t0 in - let univnames = - let uu___1 = gather_free_univnames env t in - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_ident)) (Obj.magic uu___1) in - (let uu___2 = FStar_Compiler_Effect.op_Bang dbg_Gen in - if uu___2 - then - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - let uu___4 = - FStar_Class_Show.show - (FStar_Class_Show.show_list FStar_Ident.showable_ident) - univnames in - FStar_Compiler_Util.print2 - "generalizing universes in the term (post norm): %s with univnames: %s\n" - uu___3 uu___4 - else ()); - (let univs = FStar_Syntax_Free.univs t in - (let uu___3 = FStar_Compiler_Effect.op_Bang dbg_Gen in - if uu___3 - then - let uu___4 = - FStar_Class_Show.show - (FStar_Compiler_FlatSet.showable_set - FStar_Syntax_Free.ord_univ_uvar showable_univ_var) - univs in - FStar_Compiler_Util.print1 "univs to gen : %s\n" uu___4 - else ()); - (let gen = gen_univs env univs in - (let uu___4 = FStar_Compiler_Effect.op_Bang dbg_Gen in - if uu___4 - then - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - let uu___6 = - FStar_Class_Show.show - (FStar_Class_Show.show_list FStar_Ident.showable_ident) - gen in - FStar_Compiler_Util.print2 - "After generalization, t: %s and univs: %s\n" uu___5 uu___6 - else ()); - (let univs1 = check_universe_generalization univnames gen t0 in - let t1 = - FStar_TypeChecker_Normalize.reduce_uvar_solutions env t in - let ts = FStar_Syntax_Subst.close_univ_vars univs1 t1 in - (univs1, ts))))) -let (gen : - FStar_TypeChecker_Env.env -> - Prims.bool -> - (FStar_Syntax_Syntax.lbname * FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.comp) Prims.list -> - (FStar_Syntax_Syntax.lbname * FStar_Syntax_Syntax.univ_name - Prims.list * FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.comp * - FStar_Syntax_Syntax.binder Prims.list) Prims.list - FStar_Pervasives_Native.option) - = - fun env -> - fun is_rec -> - fun lecs -> - let uu___ = - let uu___1 = - FStar_Compiler_Util.for_all - (fun uu___2 -> - match uu___2 with - | (uu___3, uu___4, c) -> - FStar_Syntax_Util.is_pure_or_ghost_comp c) lecs in - Prims.op_Negation uu___1 in - if uu___ - then FStar_Pervasives_Native.None - else - (let norm c = - (let uu___3 = FStar_Compiler_Debug.medium () in - if uu___3 - then - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_comp c in - FStar_Compiler_Util.print1 - "Normalizing before generalizing:\n\t %s\n" uu___4 - else ()); - (let c1 = - FStar_TypeChecker_Normalize.normalize_comp - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Exclude FStar_TypeChecker_Env.Zeta; - FStar_TypeChecker_Env.NoFullNorm; - FStar_TypeChecker_Env.DoNotUnfoldPureLets] env c in - (let uu___4 = FStar_Compiler_Debug.medium () in - if uu___4 - then - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_comp c1 in - FStar_Compiler_Util.print1 "Normalized to:\n\t %s\n" uu___5 - else ()); - c1) in - let env_uvars = FStar_TypeChecker_Env.uvars_in_env env in - let gen_uvars uvs = - let uu___2 = - Obj.magic - (FStar_Class_Setlike.diff () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) (Obj.magic uvs) - (Obj.magic env_uvars)) in - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) (Obj.magic uu___2) in - let univs_and_uvars_of_lec uu___2 = - match uu___2 with - | (lbname, e, c) -> - let c1 = norm c in - let t = FStar_Syntax_Util.comp_result c1 in - let univs = FStar_Syntax_Free.univs t in - let uvt = FStar_Syntax_Free.uvars t in - ((let uu___4 = FStar_Compiler_Effect.op_Bang dbg_Gen in - if uu___4 - then - let uu___5 = - FStar_Class_Show.show - (FStar_Compiler_FlatSet.showable_set - FStar_Syntax_Free.ord_univ_uvar showable_univ_var) - univs in - let uu___6 = - FStar_Class_Show.show - (FStar_Compiler_FlatSet.showable_set - FStar_Syntax_Free.ord_ctx_uvar - FStar_Syntax_Print.showable_ctxu) uvt in - FStar_Compiler_Util.print2 - "^^^^\n\tFree univs = %s\n\tFree uvt=%s\n" uu___5 - uu___6 - else ()); - (let univs1 = - let uu___4 = - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) - (Obj.magic uvt) in - FStar_Compiler_List.fold_left - (fun uu___6 -> - fun uu___5 -> - (fun univs2 -> - fun uv -> - let uu___5 = - let uu___6 = - FStar_Syntax_Util.ctx_uvar_typ uv in - FStar_Syntax_Free.univs uu___6 in - Obj.magic - (FStar_Class_Setlike.union () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_univ_uvar)) - (Obj.magic univs2) (Obj.magic uu___5))) - uu___6 uu___5) univs uu___4 in - let uvs = gen_uvars uvt in - (let uu___5 = FStar_Compiler_Effect.op_Bang dbg_Gen in - if uu___5 - then - let uu___6 = - FStar_Class_Show.show - (FStar_Compiler_FlatSet.showable_set - FStar_Syntax_Free.ord_univ_uvar - showable_univ_var) univs1 in - let uu___7 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_ctxu) uvs in - FStar_Compiler_Util.print2 - "^^^^\n\tFree univs = %s\n\tgen_uvars = %s\n" uu___6 - uu___7 - else ()); - (univs1, uvs, (lbname, e, c1)))) in - let uu___2 = - let uu___3 = FStar_Compiler_List.hd lecs in - univs_and_uvars_of_lec uu___3 in - match uu___2 with - | (univs, uvs, lec_hd) -> - let force_univs_eq lec2 u1 u2 = - let uu___3 = - FStar_Class_Setlike.equal () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_univ_uvar)) (Obj.magic u1) - (Obj.magic u2) in - if uu___3 - then () - else - (let uu___5 = lec_hd in - match uu___5 with - | (lb1, uu___6, uu___7) -> - let uu___8 = lec2 in - (match uu___8 with - | (lb2, uu___9, uu___10) -> - let msg = - let uu___11 = - FStar_Class_Show.show - (FStar_Class_Show.show_either - FStar_Syntax_Print.showable_bv - FStar_Syntax_Print.showable_fv) lb1 in - let uu___12 = - FStar_Class_Show.show - (FStar_Class_Show.show_either - FStar_Syntax_Print.showable_bv - FStar_Syntax_Print.showable_fv) lb2 in - FStar_Compiler_Util.format2 - "Generalizing the types of these mutually recursive definitions requires an incompatible set of universes for %s and %s" - uu___11 uu___12 in - FStar_Errors.raise_error - FStar_TypeChecker_Env.hasRange_env env - FStar_Errors_Codes.Fatal_IncompatibleSetOfUniverse - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic msg))) in - let force_uvars_eq lec2 u1 u2 = - let uvars_subseteq u11 u21 = - FStar_Compiler_Util.for_all - (fun u -> - FStar_Compiler_Util.for_some - (fun u' -> - FStar_Syntax_Unionfind.equiv - u.FStar_Syntax_Syntax.ctx_uvar_head - u'.FStar_Syntax_Syntax.ctx_uvar_head) u21) u11 in - let uu___3 = - (uvars_subseteq u1 u2) && (uvars_subseteq u2 u1) in - if uu___3 - then () - else - (let uu___5 = lec_hd in - match uu___5 with - | (lb1, uu___6, uu___7) -> - let uu___8 = lec2 in - (match uu___8 with - | (lb2, uu___9, uu___10) -> - let msg = - let uu___11 = - FStar_Class_Show.show - (FStar_Class_Show.show_either - FStar_Syntax_Print.showable_bv - FStar_Syntax_Print.showable_fv) lb1 in - let uu___12 = - FStar_Class_Show.show - (FStar_Class_Show.show_either - FStar_Syntax_Print.showable_bv - FStar_Syntax_Print.showable_fv) lb2 in - FStar_Compiler_Util.format2 - "Generalizing the types of these mutually recursive definitions requires an incompatible number of types for %s and %s" - uu___11 uu___12 in - FStar_Errors.raise_error - FStar_TypeChecker_Env.hasRange_env env - FStar_Errors_Codes.Fatal_IncompatibleNumberOfTypes - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic msg))) in - let lecs1 = - let uu___3 = FStar_Compiler_List.tl lecs in - FStar_Compiler_List.fold_right - (fun this_lec -> - fun lecs2 -> - let uu___4 = univs_and_uvars_of_lec this_lec in - match uu___4 with - | (this_univs, this_uvs, this_lec1) -> - (force_univs_eq this_lec1 univs this_univs; - force_uvars_eq this_lec1 uvs this_uvs; - this_lec1 - :: - lecs2)) uu___3 [] in - let lecs2 = lec_hd :: lecs1 in - let gen_types uvs1 = - FStar_Compiler_List.concatMap - (fun u -> - if - FStar_Pervasives_Native.uu___is_Some - u.FStar_Syntax_Syntax.ctx_uvar_meta - then [] - else - (let uu___4 = - FStar_Syntax_Unionfind.find - u.FStar_Syntax_Syntax.ctx_uvar_head in - match uu___4 with - | FStar_Pervasives_Native.Some uu___5 -> - failwith - "Unexpected instantiation of mutually recursive uvar" - | uu___5 -> - let k = - let uu___6 = FStar_Syntax_Util.ctx_uvar_typ u in - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Exclude - FStar_TypeChecker_Env.Zeta] env uu___6 in - let uu___6 = FStar_Syntax_Util.arrow_formals k in - (match uu___6 with - | (bs, kres) -> - let uu___7 = - let uu___8 = - let uu___9 = - FStar_TypeChecker_Normalize.unfold_whnf - env kres in - FStar_Syntax_Util.unrefine uu___9 in - uu___8.FStar_Syntax_Syntax.n in - (match uu___7 with - | FStar_Syntax_Syntax.Tm_type uu___8 -> - let free = - FStar_Syntax_Free.names kres in - let uu___9 = - let uu___10 = - FStar_Class_Setlike.is_empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) - (Obj.magic free) in - Prims.op_Negation uu___10 in - if uu___9 - then [] - else - (let a = - let uu___11 = - let uu___12 = - FStar_TypeChecker_Env.get_range - env in - FStar_Pervasives_Native.Some - uu___12 in - FStar_Syntax_Syntax.new_bv - uu___11 kres in - let t = - match bs with - | [] -> - FStar_Syntax_Syntax.bv_to_name - a - | uu___11 -> - let uu___12 = - FStar_Syntax_Syntax.bv_to_name - a in - FStar_Syntax_Util.abs bs - uu___12 - (FStar_Pervasives_Native.Some - (FStar_Syntax_Util.residual_tot - kres)) in - FStar_Syntax_Util.set_uvar - u.FStar_Syntax_Syntax.ctx_uvar_head - t; - (let uu___12 = - let uu___13 = - FStar_Syntax_Syntax.as_bqual_implicit - true in - (a, uu___13) in - [uu___12])) - | uu___8 -> [])))) uvs1 in - let gen_univs1 = gen_univs env univs in - let gen_tvars = gen_types uvs in - let ecs = - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with - | (lbname, e, c) -> - let uu___4 = - match (gen_tvars, gen_univs1) with - | ([], []) -> (e, c, []) - | uu___5 -> - let uu___6 = (e, c) in - (match uu___6 with - | (e0, c0) -> - let c1 = - FStar_TypeChecker_Normalize.normalize_comp - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.DoNotUnfoldPureLets; - FStar_TypeChecker_Env.CompressUvars; - FStar_TypeChecker_Env.NoFullNorm; - FStar_TypeChecker_Env.Exclude - FStar_TypeChecker_Env.Zeta] env c in - let e1 = - FStar_TypeChecker_Normalize.reduce_uvar_solutions - env e in - let e2 = - if is_rec - then - let tvar_args = - FStar_Compiler_List.map - (fun uu___7 -> - match uu___7 with - | (x, uu___8) -> - let uu___9 = - FStar_Syntax_Syntax.bv_to_name - x in - FStar_Syntax_Syntax.iarg - uu___9) gen_tvars in - let instantiate_lbname_with_app tm - fv = - let uu___7 = - let uu___8 = - FStar_Compiler_Util.right - lbname in - FStar_Syntax_Syntax.fv_eq fv - uu___8 in - if uu___7 - then - FStar_Syntax_Syntax.mk_Tm_app tm - tvar_args - tm.FStar_Syntax_Syntax.pos - else tm in - FStar_Syntax_InstFV.inst - instantiate_lbname_with_app e1 - else e1 in - let tvars_bs = - FStar_Compiler_List.map - (fun uu___7 -> - match uu___7 with - | (x, q) -> - FStar_Syntax_Syntax.mk_binder_with_attrs - x q - FStar_Pervasives_Native.None - []) gen_tvars in - let t = - let uu___7 = - let uu___8 = - FStar_Syntax_Subst.compress - (FStar_Syntax_Util.comp_result - c1) in - uu___8.FStar_Syntax_Syntax.n in - match uu___7 with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; - FStar_Syntax_Syntax.comp = cod;_} - -> - let uu___8 = - FStar_Syntax_Subst.open_comp bs - cod in - (match uu___8 with - | (bs1, cod1) -> - FStar_Syntax_Util.arrow - (FStar_Compiler_List.op_At - tvars_bs bs1) cod1) - | uu___8 -> - FStar_Syntax_Util.arrow tvars_bs - c1 in - let e' = - let uu___7 = - let uu___8 = - FStar_Syntax_Util.residual_comp_of_comp - c1 in - FStar_Pervasives_Native.Some uu___8 in - FStar_Syntax_Util.abs tvars_bs e2 - uu___7 in - let uu___7 = - FStar_Syntax_Syntax.mk_Total t in - (e', uu___7, tvars_bs)) in - (match uu___4 with - | (e1, c1, gvs) -> - (lbname, gen_univs1, e1, c1, gvs))) lecs2 in - FStar_Pervasives_Native.Some ecs) -let (generalize' : - FStar_TypeChecker_Env.env -> - Prims.bool -> - (FStar_Syntax_Syntax.lbname * FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.comp) Prims.list -> - (FStar_Syntax_Syntax.lbname * FStar_Syntax_Syntax.univ_names * - FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.comp * - FStar_Syntax_Syntax.binder Prims.list) Prims.list) - = - fun env -> - fun is_rec -> - fun lecs -> - (let uu___2 = FStar_Compiler_Debug.low () in - if uu___2 - then - let uu___3 = - let uu___4 = - FStar_Compiler_List.map - (fun uu___5 -> - match uu___5 with - | (lb, uu___6, uu___7) -> - FStar_Class_Show.show - (FStar_Class_Show.show_either - FStar_Syntax_Print.showable_bv - FStar_Syntax_Print.showable_fv) lb) lecs in - FStar_Class_Show.show - (FStar_Class_Show.show_list - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_string)) uu___4 in - FStar_Compiler_Util.print1 "Generalizing: %s\n" uu___3 - else ()); - (let univnames_lecs = - let empty = - Obj.magic - (FStar_Class_Setlike.from_list () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_ident)) []) in - FStar_Compiler_List.fold_left - (fun uu___3 -> - fun uu___2 -> - (fun out -> - fun uu___2 -> - match uu___2 with - | (l, t, c) -> - let uu___3 = gather_free_univnames env t in - Obj.magic - (FStar_Class_Setlike.union () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_ident)) - (Obj.magic out) (Obj.magic uu___3))) uu___3 - uu___2) empty lecs in - let univnames_lecs1 = - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_ident)) (Obj.magic univnames_lecs) in - let generalized_lecs = - let uu___2 = gen env is_rec lecs in - match uu___2 with - | FStar_Pervasives_Native.None -> - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with | (l, t, c) -> (l, [], t, c, [])) lecs - | FStar_Pervasives_Native.Some luecs -> - ((let uu___4 = FStar_Compiler_Debug.medium () in - if uu___4 - then - FStar_Compiler_List.iter - (fun uu___5 -> - match uu___5 with - | (l, us, e, c, gvs) -> - let uu___6 = - FStar_Class_Show.show - FStar_Compiler_Range_Ops.showable_range - e.FStar_Syntax_Syntax.pos in - let uu___7 = - FStar_Class_Show.show - (FStar_Class_Show.show_either - FStar_Syntax_Print.showable_bv - FStar_Syntax_Print.showable_fv) l in - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - (FStar_Syntax_Util.comp_result c) in - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term e in - let uu___10 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binder) gvs in - FStar_Compiler_Util.print5 - "(%s) Generalized %s at type %s\n%s\nVars = (%s)\n" - uu___6 uu___7 uu___8 uu___9 uu___10) luecs - else ()); - luecs) in - FStar_Compiler_List.map - (fun uu___2 -> - match uu___2 with - | (l, generalized_univs, t, c, gvs) -> - let uu___3 = - check_universe_generalization univnames_lecs1 - generalized_univs t in - (l, uu___3, t, c, gvs)) generalized_lecs) -let (generalize : - FStar_TypeChecker_Env.env -> - Prims.bool -> - (FStar_Syntax_Syntax.lbname * FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.comp) Prims.list -> - (FStar_Syntax_Syntax.lbname * FStar_Syntax_Syntax.univ_names * - FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.comp * - FStar_Syntax_Syntax.binder Prims.list) Prims.list) - = - fun env -> - fun is_rec -> - fun lecs -> - FStar_Errors.with_ctx "While generalizing" - (fun uu___ -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_TypeChecker_Env.current_module env in - FStar_Ident.string_of_lid uu___3 in - FStar_Pervasives_Native.Some uu___2 in - FStar_Profiling.profile - (fun uu___2 -> generalize' env is_rec lecs) uu___1 - "FStar.TypeChecker.Util.generalize") \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_NBE.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_NBE.ml deleted file mode 100644 index c256711dd82..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_NBE.ml +++ /dev/null @@ -1,3529 +0,0 @@ -open Prims -let (dbg_NBE : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "NBE" -let (dbg_NBETop : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "NBETop" -let (max : Prims.int -> Prims.int -> Prims.int) = - fun a -> fun b -> if a > b then a else b -let map_rev : 'a 'b . ('a -> 'b) -> 'a Prims.list -> 'b Prims.list = - fun f -> - fun l -> - let rec aux l1 acc = - match l1 with - | [] -> acc - | x::xs -> - let uu___ = let uu___1 = f x in uu___1 :: acc in aux xs uu___ in - aux l [] -let map_rev_append : - 'a 'b . ('a -> 'b) -> 'a Prims.list -> 'b Prims.list -> 'b Prims.list = - fun f -> - fun l1 -> - fun l2 -> - let rec aux l acc = - match l with - | [] -> l2 - | x::xs -> - let uu___ = let uu___1 = f x in uu___1 :: acc in aux xs uu___ in - aux l1 l2 -let rec map_append : - 'a 'b . ('a -> 'b) -> 'a Prims.list -> 'b Prims.list -> 'b Prims.list = - fun f -> - fun l1 -> - fun l2 -> - match l1 with - | [] -> l2 - | x::xs -> - let uu___ = f x in - let uu___1 = map_append f xs l2 in uu___ :: uu___1 -let rec drop : 'a . ('a -> Prims.bool) -> 'a Prims.list -> 'a Prims.list = - fun p -> - fun l -> - match l with - | [] -> [] - | x::xs -> let uu___ = p x in if uu___ then x :: xs else drop p xs -let fmap_opt : - 'a 'b . - ('a -> 'b) -> - 'a FStar_Pervasives_Native.option -> 'b FStar_Pervasives_Native.option - = - fun f -> - fun x -> - FStar_Compiler_Util.bind_opt x - (fun x1 -> let uu___ = f x1 in FStar_Pervasives_Native.Some uu___) -let drop_until : 'a . ('a -> Prims.bool) -> 'a Prims.list -> 'a Prims.list = - fun f -> - fun l -> - let rec aux l1 = - match l1 with - | [] -> [] - | x::xs -> let uu___ = f x in if uu___ then l1 else aux xs in - aux l -let (trim : Prims.bool Prims.list -> Prims.bool Prims.list) = - fun l -> - let uu___ = drop_until (fun x -> x) (FStar_Compiler_List.rev l) in - FStar_Compiler_List.rev uu___ -let (implies : Prims.bool -> Prims.bool -> Prims.bool) = - fun b1 -> - fun b2 -> - match (b1, b2) with | (false, uu___) -> true | (true, b21) -> b21 -let (let_rec_arity : - FStar_Syntax_Syntax.letbinding -> (Prims.int * Prims.bool Prims.list)) = - fun b -> - let uu___ = FStar_Syntax_Util.let_rec_arity b in - match uu___ with - | (ar, maybe_lst) -> - (match maybe_lst with - | FStar_Pervasives_Native.None -> - let uu___1 = FStar_Common.tabulate ar (fun uu___2 -> true) in - (ar, uu___1) - | FStar_Pervasives_Native.Some lst -> (ar, lst)) -let (debug_term : FStar_Syntax_Syntax.term -> unit) = - fun t -> - let uu___ = FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.print1 "%s\n" uu___ -let (debug_sigmap : - FStar_Syntax_Syntax.sigelt FStar_Compiler_Util.smap -> unit) = - fun m -> - FStar_Compiler_Util.smap_fold m - (fun k -> - fun v -> - fun u -> - let uu___ = FStar_Syntax_Print.sigelt_to_string_short v in - FStar_Compiler_Util.print2 "%s -> %%s\n" k uu___) () -type config = - { - core_cfg: FStar_TypeChecker_Cfg.cfg ; - fv_cache: FStar_TypeChecker_NBETerm.t FStar_Compiler_Util.smap } -let (__proj__Mkconfig__item__core_cfg : config -> FStar_TypeChecker_Cfg.cfg) - = - fun projectee -> match projectee with | { core_cfg; fv_cache;_} -> core_cfg -let (__proj__Mkconfig__item__fv_cache : - config -> FStar_TypeChecker_NBETerm.t FStar_Compiler_Util.smap) = - fun projectee -> match projectee with | { core_cfg; fv_cache;_} -> fv_cache -let (new_config : FStar_TypeChecker_Cfg.cfg -> config) = - fun cfg -> - let uu___ = FStar_Compiler_Util.smap_create (Prims.of_int (51)) in - { core_cfg = cfg; fv_cache = uu___ } -let (reifying_false : config -> config) = - fun cfg -> - if (cfg.core_cfg).FStar_TypeChecker_Cfg.reifying - then - new_config - (let uu___ = cfg.core_cfg in - { - FStar_TypeChecker_Cfg.steps = (uu___.FStar_TypeChecker_Cfg.steps); - FStar_TypeChecker_Cfg.tcenv = (uu___.FStar_TypeChecker_Cfg.tcenv); - FStar_TypeChecker_Cfg.debug = (uu___.FStar_TypeChecker_Cfg.debug); - FStar_TypeChecker_Cfg.delta_level = - (uu___.FStar_TypeChecker_Cfg.delta_level); - FStar_TypeChecker_Cfg.primitive_steps = - (uu___.FStar_TypeChecker_Cfg.primitive_steps); - FStar_TypeChecker_Cfg.strong = - (uu___.FStar_TypeChecker_Cfg.strong); - FStar_TypeChecker_Cfg.memoize_lazy = - (uu___.FStar_TypeChecker_Cfg.memoize_lazy); - FStar_TypeChecker_Cfg.normalize_pure_lets = - (uu___.FStar_TypeChecker_Cfg.normalize_pure_lets); - FStar_TypeChecker_Cfg.reifying = false; - FStar_TypeChecker_Cfg.compat_memo_ignore_cfg = - (uu___.FStar_TypeChecker_Cfg.compat_memo_ignore_cfg) - }) - else cfg -let (reifying_true : config -> config) = - fun cfg -> - if Prims.op_Negation (cfg.core_cfg).FStar_TypeChecker_Cfg.reifying - then - new_config - (let uu___ = cfg.core_cfg in - { - FStar_TypeChecker_Cfg.steps = (uu___.FStar_TypeChecker_Cfg.steps); - FStar_TypeChecker_Cfg.tcenv = (uu___.FStar_TypeChecker_Cfg.tcenv); - FStar_TypeChecker_Cfg.debug = (uu___.FStar_TypeChecker_Cfg.debug); - FStar_TypeChecker_Cfg.delta_level = - (uu___.FStar_TypeChecker_Cfg.delta_level); - FStar_TypeChecker_Cfg.primitive_steps = - (uu___.FStar_TypeChecker_Cfg.primitive_steps); - FStar_TypeChecker_Cfg.strong = - (uu___.FStar_TypeChecker_Cfg.strong); - FStar_TypeChecker_Cfg.memoize_lazy = - (uu___.FStar_TypeChecker_Cfg.memoize_lazy); - FStar_TypeChecker_Cfg.normalize_pure_lets = - (uu___.FStar_TypeChecker_Cfg.normalize_pure_lets); - FStar_TypeChecker_Cfg.reifying = true; - FStar_TypeChecker_Cfg.compat_memo_ignore_cfg = - (uu___.FStar_TypeChecker_Cfg.compat_memo_ignore_cfg) - }) - else cfg -let (zeta_false : config -> config) = - fun cfg -> - let cfg_core = cfg.core_cfg in - if (cfg_core.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.zeta - then - let cfg_core' = - { - FStar_TypeChecker_Cfg.steps = - (let uu___ = cfg_core.FStar_TypeChecker_Cfg.steps in - { - FStar_TypeChecker_Cfg.beta = - (uu___.FStar_TypeChecker_Cfg.beta); - FStar_TypeChecker_Cfg.iota = - (uu___.FStar_TypeChecker_Cfg.iota); - FStar_TypeChecker_Cfg.zeta = false; - FStar_TypeChecker_Cfg.zeta_full = - (uu___.FStar_TypeChecker_Cfg.zeta_full); - FStar_TypeChecker_Cfg.weak = - (uu___.FStar_TypeChecker_Cfg.weak); - FStar_TypeChecker_Cfg.hnf = (uu___.FStar_TypeChecker_Cfg.hnf); - FStar_TypeChecker_Cfg.primops = - (uu___.FStar_TypeChecker_Cfg.primops); - FStar_TypeChecker_Cfg.do_not_unfold_pure_lets = - (uu___.FStar_TypeChecker_Cfg.do_not_unfold_pure_lets); - FStar_TypeChecker_Cfg.unfold_until = - (uu___.FStar_TypeChecker_Cfg.unfold_until); - FStar_TypeChecker_Cfg.unfold_only = - (uu___.FStar_TypeChecker_Cfg.unfold_only); - FStar_TypeChecker_Cfg.unfold_fully = - (uu___.FStar_TypeChecker_Cfg.unfold_fully); - FStar_TypeChecker_Cfg.unfold_attr = - (uu___.FStar_TypeChecker_Cfg.unfold_attr); - FStar_TypeChecker_Cfg.unfold_qual = - (uu___.FStar_TypeChecker_Cfg.unfold_qual); - FStar_TypeChecker_Cfg.unfold_namespace = - (uu___.FStar_TypeChecker_Cfg.unfold_namespace); - FStar_TypeChecker_Cfg.dont_unfold_attr = - (uu___.FStar_TypeChecker_Cfg.dont_unfold_attr); - FStar_TypeChecker_Cfg.pure_subterms_within_computations = - (uu___.FStar_TypeChecker_Cfg.pure_subterms_within_computations); - FStar_TypeChecker_Cfg.simplify = - (uu___.FStar_TypeChecker_Cfg.simplify); - FStar_TypeChecker_Cfg.erase_universes = - (uu___.FStar_TypeChecker_Cfg.erase_universes); - FStar_TypeChecker_Cfg.allow_unbound_universes = - (uu___.FStar_TypeChecker_Cfg.allow_unbound_universes); - FStar_TypeChecker_Cfg.reify_ = - (uu___.FStar_TypeChecker_Cfg.reify_); - FStar_TypeChecker_Cfg.compress_uvars = - (uu___.FStar_TypeChecker_Cfg.compress_uvars); - FStar_TypeChecker_Cfg.no_full_norm = - (uu___.FStar_TypeChecker_Cfg.no_full_norm); - FStar_TypeChecker_Cfg.check_no_uvars = - (uu___.FStar_TypeChecker_Cfg.check_no_uvars); - FStar_TypeChecker_Cfg.unmeta = - (uu___.FStar_TypeChecker_Cfg.unmeta); - FStar_TypeChecker_Cfg.unascribe = - (uu___.FStar_TypeChecker_Cfg.unascribe); - FStar_TypeChecker_Cfg.in_full_norm_request = - (uu___.FStar_TypeChecker_Cfg.in_full_norm_request); - FStar_TypeChecker_Cfg.weakly_reduce_scrutinee = - (uu___.FStar_TypeChecker_Cfg.weakly_reduce_scrutinee); - FStar_TypeChecker_Cfg.nbe_step = - (uu___.FStar_TypeChecker_Cfg.nbe_step); - FStar_TypeChecker_Cfg.for_extraction = - (uu___.FStar_TypeChecker_Cfg.for_extraction); - FStar_TypeChecker_Cfg.unrefine = - (uu___.FStar_TypeChecker_Cfg.unrefine); - FStar_TypeChecker_Cfg.default_univs_to_zero = - (uu___.FStar_TypeChecker_Cfg.default_univs_to_zero); - FStar_TypeChecker_Cfg.tactics = - (uu___.FStar_TypeChecker_Cfg.tactics) - }); - FStar_TypeChecker_Cfg.tcenv = - (cfg_core.FStar_TypeChecker_Cfg.tcenv); - FStar_TypeChecker_Cfg.debug = - (cfg_core.FStar_TypeChecker_Cfg.debug); - FStar_TypeChecker_Cfg.delta_level = - (cfg_core.FStar_TypeChecker_Cfg.delta_level); - FStar_TypeChecker_Cfg.primitive_steps = - (cfg_core.FStar_TypeChecker_Cfg.primitive_steps); - FStar_TypeChecker_Cfg.strong = - (cfg_core.FStar_TypeChecker_Cfg.strong); - FStar_TypeChecker_Cfg.memoize_lazy = - (cfg_core.FStar_TypeChecker_Cfg.memoize_lazy); - FStar_TypeChecker_Cfg.normalize_pure_lets = - (cfg_core.FStar_TypeChecker_Cfg.normalize_pure_lets); - FStar_TypeChecker_Cfg.reifying = - (cfg_core.FStar_TypeChecker_Cfg.reifying); - FStar_TypeChecker_Cfg.compat_memo_ignore_cfg = - (cfg_core.FStar_TypeChecker_Cfg.compat_memo_ignore_cfg) - } in - new_config cfg_core' - else cfg -let (cache_add : - config -> FStar_Syntax_Syntax.fv -> FStar_TypeChecker_NBETerm.t -> unit) = - fun cfg -> - fun fv -> - fun v -> - let lid = (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - let uu___ = FStar_Ident.string_of_lid lid in - FStar_Compiler_Util.smap_add cfg.fv_cache uu___ v -let (try_in_cache : - config -> - FStar_Syntax_Syntax.fv -> - FStar_TypeChecker_NBETerm.t FStar_Pervasives_Native.option) - = - fun cfg -> - fun fv -> - let lid = (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - let uu___ = FStar_Ident.string_of_lid lid in - FStar_Compiler_Util.smap_try_find cfg.fv_cache uu___ -let (debug : config -> (unit -> unit) -> unit) = - fun cfg -> fun f -> FStar_TypeChecker_Cfg.log_nbe cfg.core_cfg f -let rec (unlazy_unmeta : - FStar_TypeChecker_NBETerm.t -> FStar_TypeChecker_NBETerm.t) = - fun t -> - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Lazy (uu___, t1) -> - let uu___1 = FStar_Thunk.force t1 in unlazy_unmeta uu___1 - | FStar_TypeChecker_NBETerm.Meta (t0, m) -> - let uu___ = FStar_Thunk.force m in - (match uu___ with - | FStar_Syntax_Syntax.Meta_monadic (uu___1, uu___2) -> t - | FStar_Syntax_Syntax.Meta_monadic_lift (uu___1, uu___2, uu___3) -> - t - | uu___1 -> unlazy_unmeta t0) - | uu___ -> t -let (pickBranch : - config -> - FStar_TypeChecker_NBETerm.t -> - FStar_Syntax_Syntax.branch Prims.list -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_NBETerm.t Prims.list) - FStar_Pervasives_Native.option) - = - fun cfg -> - fun scrut -> - fun branches -> - let all_branches = branches in - let rec pickBranch_aux scrut1 branches1 branches0 = - let rec matches_pat scrutinee0 p = - debug cfg - (fun uu___1 -> - let uu___2 = - FStar_TypeChecker_NBETerm.t_to_string scrutinee0 in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_pat p in - FStar_Compiler_Util.print2 "matches_pat (%s, %s)\n" uu___2 - uu___3); - (let scrutinee = unlazy_unmeta scrutinee0 in - let r = - match p.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_var bv -> - FStar_Pervasives.Inl [scrutinee0] - | FStar_Syntax_Syntax.Pat_dot_term uu___1 -> - FStar_Pervasives.Inl [] - | FStar_Syntax_Syntax.Pat_constant s -> - let matches_const c s1 = - debug cfg - (fun uu___2 -> - let uu___3 = - FStar_TypeChecker_NBETerm.t_to_string c in - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_const s1 in - FStar_Compiler_Util.print2 - "Testing term %s against pattern %s\n" uu___3 - uu___4); - (match c.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Constant - (FStar_TypeChecker_NBETerm.Unit) -> - s1 = FStar_Const.Const_unit - | FStar_TypeChecker_NBETerm.Constant - (FStar_TypeChecker_NBETerm.Bool b) -> - (match s1 with - | FStar_Const.Const_bool p1 -> b = p1 - | uu___2 -> false) - | FStar_TypeChecker_NBETerm.Constant - (FStar_TypeChecker_NBETerm.Int i) -> - (match s1 with - | FStar_Const.Const_int - (p1, FStar_Pervasives_Native.None) -> - let uu___2 = FStar_BigInt.big_int_of_string p1 in - i = uu___2 - | uu___2 -> false) - | FStar_TypeChecker_NBETerm.Constant - (FStar_TypeChecker_NBETerm.String (st, uu___2)) -> - (match s1 with - | FStar_Const.Const_string (p1, uu___3) -> st = p1 - | uu___3 -> false) - | FStar_TypeChecker_NBETerm.Constant - (FStar_TypeChecker_NBETerm.Char c1) -> - (match s1 with - | FStar_Const.Const_char p1 -> c1 = p1 - | uu___2 -> false) - | uu___2 -> false) in - let uu___1 = matches_const scrutinee s in - if uu___1 - then FStar_Pervasives.Inl [] - else FStar_Pervasives.Inr false - | FStar_Syntax_Syntax.Pat_cons (fv, _us_opt, arg_pats) -> - let rec matches_args out a p1 = - match (a, p1) with - | ([], []) -> FStar_Pervasives.Inl out - | ((t, uu___1)::rest_a, (p2, uu___2)::rest_p) -> - let uu___3 = matches_pat t p2 in - (match uu___3 with - | FStar_Pervasives.Inl s -> - matches_args (FStar_Compiler_List.op_At out s) - rest_a rest_p - | m -> m) - | uu___1 -> FStar_Pervasives.Inr false in - (match scrutinee.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Construct - (fv', _us, args_rev) -> - let uu___1 = FStar_Syntax_Syntax.fv_eq fv fv' in - if uu___1 - then - matches_args [] (FStar_Compiler_List.rev args_rev) - arg_pats - else FStar_Pervasives.Inr false - | uu___1 -> FStar_Pervasives.Inr true) in - let res_to_string uu___1 = - match uu___1 with - | FStar_Pervasives.Inr b -> - let uu___2 = FStar_Compiler_Util.string_of_bool b in - Prims.strcat "Inr " uu___2 - | FStar_Pervasives.Inl bs -> - let uu___2 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length bs) in - Prims.strcat "Inl " uu___2 in - debug cfg - (fun uu___2 -> - let uu___3 = - FStar_TypeChecker_NBETerm.t_to_string scrutinee in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_pat p in - let uu___5 = res_to_string r in - FStar_Compiler_Util.print3 "matches_pat (%s, %s) = %s\n" - uu___3 uu___4 uu___5); - r) in - match branches1 with - | [] -> FStar_Pervasives_Native.None - | (p, _wopt, e)::branches2 -> - let uu___ = matches_pat scrut1 p in - (match uu___ with - | FStar_Pervasives.Inl matches -> - (debug cfg - (fun uu___2 -> - let uu___3 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_pat p in - FStar_Compiler_Util.print1 "Pattern %s matches\n" - uu___3); - FStar_Pervasives_Native.Some (e, matches)) - | FStar_Pervasives.Inr (false) -> - pickBranch_aux scrut1 branches2 branches0 - | FStar_Pervasives.Inr (true) -> FStar_Pervasives_Native.None) in - pickBranch_aux scrut branches branches -let (should_reduce_recursive_definition : - FStar_TypeChecker_NBETerm.args -> - Prims.bool Prims.list -> - (Prims.bool * FStar_TypeChecker_NBETerm.args * - FStar_TypeChecker_NBETerm.args)) - = - fun arguments -> - fun formals_in_decreases -> - let rec aux ts ar_list acc = - match (ts, ar_list) with - | (uu___, []) -> (true, acc, ts) - | ([], uu___::uu___1) -> (false, acc, []) - | (t::ts1, in_decreases_clause::bs) -> - let uu___ = - in_decreases_clause && - (FStar_TypeChecker_NBETerm.isAccu - (FStar_Pervasives_Native.fst t)) in - if uu___ - then (false, (FStar_Compiler_List.rev_append ts1 acc), []) - else aux ts1 bs (t :: acc) in - aux arguments formals_in_decreases [] -let (find_sigelt_in_gamma : - config -> - FStar_TypeChecker_Env.env -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.sigelt FStar_Pervasives_Native.option) - = - fun cfg -> - fun env -> - fun lid -> - let mapper uu___ = - match uu___ with - | (lr, rng) -> - (match lr with - | FStar_Pervasives.Inr (elt, FStar_Pervasives_Native.None) -> - FStar_Pervasives_Native.Some elt - | FStar_Pervasives.Inr (elt, FStar_Pervasives_Native.Some us) - -> - (debug cfg - (fun uu___2 -> - let uu___3 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_univ) us in - FStar_Compiler_Util.print1 - "Universes in local declaration: %s\n" uu___3); - FStar_Pervasives_Native.Some elt) - | uu___1 -> FStar_Pervasives_Native.None) in - let uu___ = FStar_TypeChecker_Env.lookup_qname env lid in - FStar_Compiler_Util.bind_opt uu___ mapper -let (is_univ : FStar_TypeChecker_NBETerm.t -> Prims.bool) = - fun tm -> - match tm.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Univ uu___ -> true - | uu___ -> false -let (un_univ : FStar_TypeChecker_NBETerm.t -> FStar_Syntax_Syntax.universe) = - fun tm -> - match tm.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Univ u -> u - | uu___ -> - let uu___1 = - let uu___2 = FStar_TypeChecker_NBETerm.t_to_string tm in - Prims.strcat "Not a universe: " uu___2 in - failwith uu___1 -let (is_constr_fv : FStar_Syntax_Syntax.fv -> Prims.bool) = - fun fvar -> - fvar.FStar_Syntax_Syntax.fv_qual = - (FStar_Pervasives_Native.Some FStar_Syntax_Syntax.Data_ctor) -let (is_constr : FStar_TypeChecker_Env.qninfo -> Prims.bool) = - fun q -> - match q with - | FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr - ({ - FStar_Syntax_Syntax.sigel = FStar_Syntax_Syntax.Sig_datacon uu___; - FStar_Syntax_Syntax.sigrng = uu___1; - FStar_Syntax_Syntax.sigquals = uu___2; - FStar_Syntax_Syntax.sigmeta = uu___3; - FStar_Syntax_Syntax.sigattrs = uu___4; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___5; - FStar_Syntax_Syntax.sigopts = uu___6;_}, - uu___7), - uu___8) - -> true - | uu___ -> false -let (translate_univ : - config -> - FStar_TypeChecker_NBETerm.t Prims.list -> - FStar_Syntax_Syntax.universe -> FStar_Syntax_Syntax.universe) - = - fun cfg -> - fun bs -> - fun u -> - let rec aux u1 = - let u2 = FStar_Syntax_Subst.compress_univ u1 in - match u2 with - | FStar_Syntax_Syntax.U_bvar i -> - if i < (FStar_Compiler_List.length bs) - then let u' = FStar_Compiler_List.nth bs i in un_univ u' - else - if - ((cfg.core_cfg).FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.allow_unbound_universes - then FStar_Syntax_Syntax.U_zero - else failwith "Universe index out of bounds" - | FStar_Syntax_Syntax.U_succ u3 -> - let uu___ = aux u3 in FStar_Syntax_Syntax.U_succ uu___ - | FStar_Syntax_Syntax.U_max us -> - let uu___ = FStar_Compiler_List.map aux us in - FStar_Syntax_Syntax.U_max uu___ - | FStar_Syntax_Syntax.U_unknown -> u2 - | FStar_Syntax_Syntax.U_name uu___ -> u2 - | FStar_Syntax_Syntax.U_unif uu___ -> u2 - | FStar_Syntax_Syntax.U_zero -> u2 in - aux u -let (find_let : - FStar_Syntax_Syntax.letbinding Prims.list -> - FStar_Syntax_Syntax.fv -> - FStar_Syntax_Syntax.letbinding FStar_Pervasives_Native.option) - = - fun lbs -> - fun fvar -> - FStar_Compiler_Util.find_map lbs - (fun lb -> - match lb.FStar_Syntax_Syntax.lbname with - | FStar_Pervasives.Inl uu___ -> failwith "find_let : impossible" - | FStar_Pervasives.Inr name -> - let uu___ = FStar_Syntax_Syntax.fv_eq name fvar in - if uu___ - then FStar_Pervasives_Native.Some lb - else FStar_Pervasives_Native.None) -let (mk_rt : - FStar_Compiler_Range_Type.range -> - FStar_TypeChecker_NBETerm.t' -> FStar_TypeChecker_NBETerm.t) - = - fun r -> - fun t -> - { - FStar_TypeChecker_NBETerm.nbe_t = t; - FStar_TypeChecker_NBETerm.nbe_r = r - } -let (mk_t : FStar_TypeChecker_NBETerm.t' -> FStar_TypeChecker_NBETerm.t) = - fun t -> - { - FStar_TypeChecker_NBETerm.nbe_t = t; - FStar_TypeChecker_NBETerm.nbe_r = FStar_Compiler_Range_Type.dummyRange - } -let rec (translate : - config -> - FStar_TypeChecker_NBETerm.t Prims.list -> - FStar_Syntax_Syntax.term -> FStar_TypeChecker_NBETerm.t) - = - fun cfg -> - fun bs -> - fun e -> - let debug1 = debug cfg in - let mk_t1 t = mk_rt e.FStar_Syntax_Syntax.pos t in - debug1 - (fun uu___1 -> - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress e in - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term - uu___3 in - let uu___3 = - let uu___4 = FStar_Syntax_Subst.compress e in - FStar_Class_Show.show FStar_Syntax_Print.showable_term uu___4 in - FStar_Compiler_Util.print2 "Term: %s - %s\n" uu___2 uu___3); - (let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress e in - uu___2.FStar_Syntax_Syntax.n in - match uu___1 with - | FStar_Syntax_Syntax.Tm_delayed uu___2 -> - failwith "Tm_delayed: Impossible" - | FStar_Syntax_Syntax.Tm_unknown -> - mk_t1 FStar_TypeChecker_NBETerm.Unknown - | FStar_Syntax_Syntax.Tm_constant c -> - let uu___2 = - let uu___3 = translate_constant c in - FStar_TypeChecker_NBETerm.Constant uu___3 in - mk_t1 uu___2 - | FStar_Syntax_Syntax.Tm_bvar db -> - if - db.FStar_Syntax_Syntax.index < (FStar_Compiler_List.length bs) - then - let t = - FStar_Compiler_List.nth bs db.FStar_Syntax_Syntax.index in - (debug1 - (fun uu___3 -> - let uu___4 = FStar_TypeChecker_NBETerm.t_to_string t in - let uu___5 = - let uu___6 = - FStar_Compiler_List.map - FStar_TypeChecker_NBETerm.t_to_string bs in - FStar_Compiler_String.concat "; " uu___6 in - FStar_Compiler_Util.print2 - "Resolved bvar to %s\n\tcontext is [%s]\n" uu___4 - uu___5); - t) - else failwith "de Bruijn index out of bounds" - | FStar_Syntax_Syntax.Tm_uinst (t, us) -> - (debug1 - (fun uu___3 -> - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - let uu___5 = - let uu___6 = - FStar_Compiler_List.map - (FStar_Class_Show.show - FStar_Syntax_Print.showable_univ) us in - FStar_Compiler_String.concat ", " uu___6 in - FStar_Compiler_Util.print2 "Uinst term : %s\nUnivs : %s\n" - uu___4 uu___5); - (let uu___3 = translate cfg bs t in - let uu___4 = - FStar_Compiler_List.map - (fun x -> - let uu___5 = - let uu___6 = - let uu___7 = translate_univ cfg bs x in - FStar_TypeChecker_NBETerm.Univ uu___7 in - mk_t1 uu___6 in - FStar_TypeChecker_NBETerm.as_arg uu___5) us in - iapp cfg uu___3 uu___4)) - | FStar_Syntax_Syntax.Tm_type u -> - let uu___2 = - let uu___3 = translate_univ cfg bs u in - FStar_TypeChecker_NBETerm.Type_t uu___3 in - mk_t1 uu___2 - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = xs; FStar_Syntax_Syntax.comp = c;_} - -> - let norm uu___2 = - let uu___3 = - FStar_Compiler_List.fold_left - (fun uu___4 -> - fun b -> - match uu___4 with - | (ctx, binders_rev) -> - let x = b.FStar_Syntax_Syntax.binder_bv in - let t = - let uu___5 = - translate cfg ctx x.FStar_Syntax_Syntax.sort in - readback cfg uu___5 in - let x1 = - let uu___5 = FStar_Syntax_Syntax.freshen_bv x in - { - FStar_Syntax_Syntax.ppname = - (uu___5.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (uu___5.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = t - } in - let ctx1 = - let uu___5 = - FStar_TypeChecker_NBETerm.mkAccuVar x1 in - uu___5 :: ctx in - (ctx1, - ({ - FStar_Syntax_Syntax.binder_bv = x1; - FStar_Syntax_Syntax.binder_qual = - (b.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity = - (b.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs = - (b.FStar_Syntax_Syntax.binder_attrs) - } :: binders_rev))) (bs, []) xs in - match uu___3 with - | (ctx, binders_rev) -> - let c1 = - let uu___4 = translate_comp cfg ctx c in - readback_comp cfg uu___4 in - FStar_Syntax_Util.arrow - (FStar_Compiler_List.rev binders_rev) c1 in - let uu___2 = - let uu___3 = - let uu___4 = FStar_Thunk.mk norm in - FStar_Pervasives.Inl uu___4 in - FStar_TypeChecker_NBETerm.Arrow uu___3 in - mk_t1 uu___2 - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = bv; FStar_Syntax_Syntax.phi = tm;_} -> - if - ((cfg.core_cfg).FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.for_extraction - || - ((cfg.core_cfg).FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unrefine - then translate cfg bs bv.FStar_Syntax_Syntax.sort - else - mk_t1 - (FStar_TypeChecker_NBETerm.Refinement - ((fun y -> translate cfg (y :: bs) tm), - (fun uu___3 -> - let uu___4 = - translate cfg bs bv.FStar_Syntax_Syntax.sort in - FStar_TypeChecker_NBETerm.as_arg uu___4))) - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t; FStar_Syntax_Syntax.asc = uu___2; - FStar_Syntax_Syntax.eff_opt = uu___3;_} - -> translate cfg bs t - | FStar_Syntax_Syntax.Tm_uvar (u, (subst, set_use_range)) -> - let norm_uvar uu___2 = - let norm_subst_elt uu___3 = - match uu___3 with - | FStar_Syntax_Syntax.NT (x, t) -> - let uu___4 = - let uu___5 = - let uu___6 = translate cfg bs t in - readback cfg uu___6 in - (x, uu___5) in - FStar_Syntax_Syntax.NT uu___4 - | FStar_Syntax_Syntax.NM (x, i) -> - let x_i = - FStar_Syntax_Syntax.bv_to_tm - { - FStar_Syntax_Syntax.ppname = - (x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = i; - FStar_Syntax_Syntax.sort = - (x.FStar_Syntax_Syntax.sort) - } in - let t = - let uu___4 = translate cfg bs x_i in - readback cfg uu___4 in - (match t.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_bvar x_j -> - FStar_Syntax_Syntax.NM - (x, (x_j.FStar_Syntax_Syntax.index)) - | uu___4 -> FStar_Syntax_Syntax.NT (x, t)) - | uu___4 -> - failwith "Impossible: subst invariant of uvar nodes" in - let subst1 = - FStar_Compiler_List.map - (FStar_Compiler_List.map norm_subst_elt) subst in - { - FStar_Syntax_Syntax.n = - (FStar_Syntax_Syntax.Tm_uvar (u, (subst1, set_use_range))); - FStar_Syntax_Syntax.pos = (e.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = (e.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (e.FStar_Syntax_Syntax.hash_code) - } in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Thunk.mk norm_uvar in - FStar_TypeChecker_NBETerm.UVar uu___5 in - (uu___4, []) in - FStar_TypeChecker_NBETerm.Accu uu___3 in - mk_t1 uu___2 - | FStar_Syntax_Syntax.Tm_name x -> - FStar_TypeChecker_NBETerm.mkAccuVar x - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = []; - FStar_Syntax_Syntax.body = uu___2; - FStar_Syntax_Syntax.rc_opt = uu___3;_} - -> failwith "Impossible: abstraction with no binders" - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = xs; FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = resc;_} - -> - mk_t1 - (FStar_TypeChecker_NBETerm.Lam - { - FStar_TypeChecker_NBETerm.interp = - (fun ys -> - let uu___2 = - let uu___3 = - FStar_Compiler_List.map - FStar_Pervasives_Native.fst ys in - FStar_Compiler_List.append uu___3 bs in - translate cfg uu___2 body); - FStar_TypeChecker_NBETerm.shape = - (FStar_TypeChecker_NBETerm.Lam_bs (bs, xs, resc)); - FStar_TypeChecker_NBETerm.arity = - (FStar_Compiler_List.length xs) - }) - | FStar_Syntax_Syntax.Tm_fvar fvar -> - let uu___2 = try_in_cache cfg fvar in - (match uu___2 with - | FStar_Pervasives_Native.Some t -> t - | uu___3 -> - let uu___4 = - FStar_Syntax_Syntax.set_range_of_fv fvar - e.FStar_Syntax_Syntax.pos in - translate_fv cfg bs uu___4) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_reify uu___2); - FStar_Syntax_Syntax.pos = uu___3; - FStar_Syntax_Syntax.vars = uu___4; - FStar_Syntax_Syntax.hash_code = uu___5;_}; - FStar_Syntax_Syntax.args = arg::more::args;_} - -> - let uu___6 = FStar_Syntax_Util.head_and_args e in - (match uu___6 with - | (head, uu___7) -> - let head1 = - FStar_Syntax_Syntax.mk_Tm_app head [arg] - e.FStar_Syntax_Syntax.pos in - let uu___8 = - FStar_Syntax_Syntax.mk_Tm_app head1 (more :: args) - e.FStar_Syntax_Syntax.pos in - translate cfg bs uu___8) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_reflect uu___2); - FStar_Syntax_Syntax.pos = uu___3; - FStar_Syntax_Syntax.vars = uu___4; - FStar_Syntax_Syntax.hash_code = uu___5;_}; - FStar_Syntax_Syntax.args = arg::more::args;_} - -> - let uu___6 = FStar_Syntax_Util.head_and_args e in - (match uu___6 with - | (head, uu___7) -> - let head1 = - FStar_Syntax_Syntax.mk_Tm_app head [arg] - e.FStar_Syntax_Syntax.pos in - let uu___8 = - FStar_Syntax_Syntax.mk_Tm_app head1 (more :: args) - e.FStar_Syntax_Syntax.pos in - translate cfg bs uu___8) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_reflect uu___2); - FStar_Syntax_Syntax.pos = uu___3; - FStar_Syntax_Syntax.vars = uu___4; - FStar_Syntax_Syntax.hash_code = uu___5;_}; - FStar_Syntax_Syntax.args = arg::[];_} - when (cfg.core_cfg).FStar_TypeChecker_Cfg.reifying -> - let cfg1 = reifying_false cfg in - translate cfg1 bs (FStar_Pervasives_Native.fst arg) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_reflect uu___2); - FStar_Syntax_Syntax.pos = uu___3; - FStar_Syntax_Syntax.vars = uu___4; - FStar_Syntax_Syntax.hash_code = uu___5;_}; - FStar_Syntax_Syntax.args = arg::[];_} - -> - let uu___6 = - let uu___7 = - translate cfg bs (FStar_Pervasives_Native.fst arg) in - FStar_TypeChecker_NBETerm.Reflect uu___7 in - mk_t1 uu___6 - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_reify uu___2); - FStar_Syntax_Syntax.pos = uu___3; - FStar_Syntax_Syntax.vars = uu___4; - FStar_Syntax_Syntax.hash_code = uu___5;_}; - FStar_Syntax_Syntax.args = arg::[];_} - when - ((cfg.core_cfg).FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.reify_ - -> - let cfg1 = reifying_true cfg in - translate cfg1 bs (FStar_Pervasives_Native.fst arg) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_reflect uu___2); - FStar_Syntax_Syntax.pos = uu___3; - FStar_Syntax_Syntax.vars = uu___4; - FStar_Syntax_Syntax.hash_code = uu___5;_}; - FStar_Syntax_Syntax.args = arg::[];_} - -> - let uu___6 = - let uu___7 = - translate cfg bs (FStar_Pervasives_Native.fst arg) in - FStar_TypeChecker_NBETerm.Reflect uu___7 in - mk_t1 uu___6 - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___2; - FStar_Syntax_Syntax.vars = uu___3; - FStar_Syntax_Syntax.hash_code = uu___4;_}; - FStar_Syntax_Syntax.args = uu___5::[];_} - when - (FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.assert_lid) - || - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.assert_norm_lid) - -> - (debug1 - (fun uu___7 -> - FStar_Compiler_Util.print_string "Eliminated assertion\n"); - mk_t1 - (FStar_TypeChecker_NBETerm.Constant - FStar_TypeChecker_NBETerm.Unit)) - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = args;_} - when - ((let uu___2 = FStar_TypeChecker_Cfg.cfg_env cfg.core_cfg in - uu___2.FStar_TypeChecker_Env.erase_erasable_args) || - ((cfg.core_cfg).FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.for_extraction) - || - ((cfg.core_cfg).FStar_TypeChecker_Cfg.debug).FStar_TypeChecker_Cfg.erase_erasable_args - -> - let uu___2 = translate cfg bs head in - let uu___3 = - FStar_Compiler_List.map - (fun x -> - let uu___4 = - FStar_Syntax_Util.aqual_is_erasable - (FStar_Pervasives_Native.snd x) in - if uu___4 - then - (debug1 - (fun uu___6 -> - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - (FStar_Pervasives_Native.fst x) in - FStar_Compiler_Util.print1 "Erasing %s\n" uu___7); - ((mk_t1 - (FStar_TypeChecker_NBETerm.Constant - FStar_TypeChecker_NBETerm.Unit)), - (FStar_Pervasives_Native.snd x))) - else - (let uu___6 = - translate cfg bs (FStar_Pervasives_Native.fst x) in - (uu___6, (FStar_Pervasives_Native.snd x)))) args in - iapp cfg uu___2 uu___3 - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = args;_} - -> - (debug1 - (fun uu___3 -> - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - head in - let uu___5 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - (FStar_Class_Show.show_tuple2 - FStar_Syntax_Print.showable_term - FStar_Syntax_Print.showable_aqual)) args in - FStar_Compiler_Util.print2 "Application: %s @ %s\n" uu___4 - uu___5); - (let uu___3 = translate cfg bs head in - let uu___4 = - FStar_Compiler_List.map - (fun x -> - let uu___5 = - translate cfg bs (FStar_Pervasives_Native.fst x) in - (uu___5, (FStar_Pervasives_Native.snd x))) args in - iapp cfg uu___3 uu___4)) - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = scrut; - FStar_Syntax_Syntax.ret_opt = ret_opt; - FStar_Syntax_Syntax.brs = branches; - FStar_Syntax_Syntax.rc_opt1 = rc;_} - -> - let make_returns uu___2 = - match ret_opt with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (b, asc) -> - let uu___3 = - let x = - let uu___4 = - let uu___5 = - translate cfg bs - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - readback cfg uu___5 in - FStar_Syntax_Syntax.gen_bv' - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.ppname - FStar_Pervasives_Native.None uu___4 in - let uu___4 = FStar_Syntax_Syntax.mk_binder x in - let uu___5 = - let uu___6 = FStar_TypeChecker_NBETerm.mkAccuVar x in - uu___6 :: bs in - (uu___4, uu___5) in - (match uu___3 with - | (b1, bs1) -> - let asc1 = - match asc with - | (FStar_Pervasives.Inl t, tacopt, use_eq) -> - let uu___4 = - let uu___5 = - let uu___6 = translate cfg bs1 t in - readback cfg uu___6 in - FStar_Pervasives.Inl uu___5 in - (uu___4, tacopt, use_eq) - | (FStar_Pervasives.Inr c, tacopt, use_eq) -> - let uu___4 = - let uu___5 = - let uu___6 = translate_comp cfg bs1 c in - readback_comp cfg uu___6 in - FStar_Pervasives.Inr uu___5 in - (uu___4, tacopt, use_eq) in - let asc2 = - FStar_Syntax_Subst.close_ascription [b1] asc1 in - let b2 = - let uu___4 = FStar_Syntax_Subst.close_binders [b1] in - FStar_Compiler_List.hd uu___4 in - FStar_Pervasives_Native.Some (b2, asc2)) in - let make_rc uu___2 = - match rc with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some rc1 -> - let uu___3 = - let uu___4 = translate_residual_comp cfg bs rc1 in - readback_residual_comp cfg uu___4 in - FStar_Pervasives_Native.Some uu___3 in - let make_branches uu___2 = - let cfg1 = zeta_false cfg in - let rec process_pattern bs1 p = - let uu___3 = - match p.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_constant c -> - (bs1, (FStar_Syntax_Syntax.Pat_constant c)) - | FStar_Syntax_Syntax.Pat_cons (fvar, us_opt, args) -> - let uu___4 = - FStar_Compiler_List.fold_left - (fun uu___5 -> - fun uu___6 -> - match (uu___5, uu___6) with - | ((bs2, args1), (arg, b)) -> - let uu___7 = process_pattern bs2 arg in - (match uu___7 with - | (bs', arg') -> - (bs', ((arg', b) :: args1)))) - (bs1, []) args in - (match uu___4 with - | (bs', args') -> - let us_opt1 = - match us_opt with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some us -> - let uu___5 = - FStar_Compiler_List.map - (translate_univ cfg1 bs1) us in - FStar_Pervasives_Native.Some uu___5 in - (bs', - (FStar_Syntax_Syntax.Pat_cons - (fvar, us_opt1, - (FStar_Compiler_List.rev args'))))) - | FStar_Syntax_Syntax.Pat_var bvar -> - let x = - let uu___4 = - let uu___5 = - translate cfg1 bs1 bvar.FStar_Syntax_Syntax.sort in - readback cfg1 uu___5 in - FStar_Syntax_Syntax.gen_bv' - bvar.FStar_Syntax_Syntax.ppname - FStar_Pervasives_Native.None uu___4 in - let uu___4 = - let uu___5 = FStar_TypeChecker_NBETerm.mkAccuVar x in - uu___5 :: bs1 in - (uu___4, (FStar_Syntax_Syntax.Pat_var x)) - | FStar_Syntax_Syntax.Pat_dot_term eopt -> - let uu___4 = - let uu___5 = - FStar_Compiler_Util.map_option - (fun e1 -> - let uu___6 = translate cfg1 bs1 e1 in - readback cfg1 uu___6) eopt in - FStar_Syntax_Syntax.Pat_dot_term uu___5 in - (bs1, uu___4) in - match uu___3 with - | (bs2, p_new) -> - (bs2, - { - FStar_Syntax_Syntax.v = p_new; - FStar_Syntax_Syntax.p = (p.FStar_Syntax_Syntax.p) - }) in - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with - | (pat, when_clause, e1) -> - let uu___4 = process_pattern bs pat in - (match uu___4 with - | (bs', pat') -> - let uu___5 = - let uu___6 = - let uu___7 = translate cfg1 bs' e1 in - readback cfg1 uu___7 in - (pat', when_clause, uu___6) in - FStar_Syntax_Util.branch uu___5)) branches in - let scrut1 = translate cfg bs scrut in - (debug1 - (fun uu___3 -> - let uu___4 = - FStar_Compiler_Range_Ops.string_of_range - e.FStar_Syntax_Syntax.pos in - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - FStar_Compiler_Util.print2 "%s: Translating match %s\n" - uu___4 uu___5); - (let scrut2 = unlazy_unmeta scrut1 in - match scrut2.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Construct (c, us, args) -> - (debug1 - (fun uu___4 -> - let uu___5 = - let uu___6 = - FStar_Compiler_List.map - (fun uu___7 -> - match uu___7 with - | (x, q) -> - let uu___8 = - FStar_TypeChecker_NBETerm.t_to_string - x in - Prims.strcat - (if FStar_Compiler_Util.is_some q - then "#" - else "") uu___8) args in - FStar_Compiler_String.concat "; " uu___6 in - FStar_Compiler_Util.print1 "Match args: %s\n" uu___5); - (let uu___4 = pickBranch cfg scrut2 branches in - match uu___4 with - | FStar_Pervasives_Native.Some (branch, args1) -> - let uu___5 = - FStar_Compiler_List.fold_left - (fun bs1 -> fun x -> x :: bs1) bs args1 in - translate cfg uu___5 branch - | FStar_Pervasives_Native.None -> - FStar_TypeChecker_NBETerm.mkAccuMatch scrut2 - make_returns make_branches make_rc)) - | FStar_TypeChecker_NBETerm.Constant c -> - (debug1 - (fun uu___4 -> - let uu___5 = - FStar_TypeChecker_NBETerm.t_to_string scrut2 in - FStar_Compiler_Util.print1 "Match constant : %s\n" - uu___5); - (let uu___4 = pickBranch cfg scrut2 branches in - match uu___4 with - | FStar_Pervasives_Native.Some (branch, []) -> - translate cfg bs branch - | FStar_Pervasives_Native.Some (branch, arg::[]) -> - translate cfg (arg :: bs) branch - | FStar_Pervasives_Native.None -> - FStar_TypeChecker_NBETerm.mkAccuMatch scrut2 - make_returns make_branches make_rc - | FStar_Pervasives_Native.Some (uu___5, hd::tl) -> - failwith - "Impossible: Matching on constants cannot bind more than one variable")) - | uu___3 -> - FStar_TypeChecker_NBETerm.mkAccuMatch scrut2 make_returns - make_branches make_rc)) - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = e1; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_monadic - (m, t);_} - when (cfg.core_cfg).FStar_TypeChecker_Cfg.reifying -> - translate_monadic (m, t) cfg bs e1 - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = e1; - FStar_Syntax_Syntax.meta = - FStar_Syntax_Syntax.Meta_monadic_lift (m, m', t);_} - when (cfg.core_cfg).FStar_TypeChecker_Cfg.reifying -> - translate_monadic_lift (m, m', t) cfg bs e1 - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = e1; - FStar_Syntax_Syntax.meta = meta;_} - -> - let norm_meta uu___2 = - let norm t = - let uu___3 = translate cfg bs t in readback cfg uu___3 in - match meta with - | FStar_Syntax_Syntax.Meta_named uu___3 -> meta - | FStar_Syntax_Syntax.Meta_labeled uu___3 -> meta - | FStar_Syntax_Syntax.Meta_desugared uu___3 -> meta - | FStar_Syntax_Syntax.Meta_pattern (ts, args) -> - let uu___3 = - let uu___4 = FStar_Compiler_List.map norm ts in - let uu___5 = - FStar_Compiler_List.map - (FStar_Compiler_List.map - (fun uu___6 -> - match uu___6 with - | (t, a) -> let uu___7 = norm t in (uu___7, a))) - args in - (uu___4, uu___5) in - FStar_Syntax_Syntax.Meta_pattern uu___3 - | FStar_Syntax_Syntax.Meta_monadic (m, t) -> - let uu___3 = let uu___4 = norm t in (m, uu___4) in - FStar_Syntax_Syntax.Meta_monadic uu___3 - | FStar_Syntax_Syntax.Meta_monadic_lift (m0, m1, t) -> - let uu___3 = let uu___4 = norm t in (m0, m1, uu___4) in - FStar_Syntax_Syntax.Meta_monadic_lift uu___3 in - let uu___2 = - let uu___3 = - let uu___4 = translate cfg bs e1 in - let uu___5 = FStar_Thunk.mk norm_meta in (uu___4, uu___5) in - FStar_TypeChecker_NBETerm.Meta uu___3 in - mk_t1 uu___2 - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (false, lb::[]); - FStar_Syntax_Syntax.body1 = body;_} - -> - let uu___2 = - FStar_TypeChecker_Cfg.should_reduce_local_let cfg.core_cfg lb in - if uu___2 - then - let uu___3 = - (((cfg.core_cfg).FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.for_extraction - && - (FStar_Syntax_Util.is_unit lb.FStar_Syntax_Syntax.lbtyp)) - && - (FStar_Syntax_Util.is_pure_or_ghost_effect - lb.FStar_Syntax_Syntax.lbeff) in - (if uu___3 - then - let bs1 = - let uu___4 = - let uu___5 = - FStar_Syntax_Syntax.range_of_lbname - lb.FStar_Syntax_Syntax.lbname in - mk_rt uu___5 - (FStar_TypeChecker_NBETerm.Constant - FStar_TypeChecker_NBETerm.Unit) in - uu___4 :: bs in - translate cfg bs1 body - else - (let bs1 = - let uu___5 = translate_letbinding cfg bs lb in uu___5 :: - bs in - translate cfg bs1 body)) - else - (let def uu___4 = - let uu___5 = - (((cfg.core_cfg).FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.for_extraction - && - (FStar_Syntax_Util.is_unit - lb.FStar_Syntax_Syntax.lbtyp)) - && - (FStar_Syntax_Util.is_pure_or_ghost_effect - lb.FStar_Syntax_Syntax.lbeff) in - if uu___5 - then - mk_t1 - (FStar_TypeChecker_NBETerm.Constant - FStar_TypeChecker_NBETerm.Unit) - else translate cfg bs lb.FStar_Syntax_Syntax.lbdef in - let typ uu___4 = - translate cfg bs lb.FStar_Syntax_Syntax.lbtyp in - let name = - let uu___4 = - FStar_Compiler_Util.left lb.FStar_Syntax_Syntax.lbname in - FStar_Syntax_Syntax.freshen_bv uu___4 in - let bs1 = - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.range_of_bv name in - mk_rt uu___5 - (FStar_TypeChecker_NBETerm.Accu - ((FStar_TypeChecker_NBETerm.Var name), [])) in - uu___4 :: bs in - let body1 uu___4 = translate cfg bs1 body in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = FStar_Thunk.mk typ in - let uu___9 = FStar_Thunk.mk def in - let uu___10 = FStar_Thunk.mk body1 in - (name, uu___8, uu___9, uu___10, lb) in - FStar_TypeChecker_NBETerm.UnreducedLet uu___7 in - (uu___6, []) in - FStar_TypeChecker_NBETerm.Accu uu___5 in - mk_t1 uu___4) - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (_rec, lbs); - FStar_Syntax_Syntax.body1 = body;_} - -> - if - (Prims.op_Negation - ((cfg.core_cfg).FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.zeta) - && - ((cfg.core_cfg).FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.pure_subterms_within_computations - then - let vars = - FStar_Compiler_List.map - (fun lb -> - let uu___2 = - FStar_Compiler_Util.left - lb.FStar_Syntax_Syntax.lbname in - FStar_Syntax_Syntax.freshen_bv uu___2) lbs in - let typs = - FStar_Compiler_List.map - (fun lb -> translate cfg bs lb.FStar_Syntax_Syntax.lbtyp) - lbs in - let rec_bs = - let uu___2 = - FStar_Compiler_List.map - (fun v -> - let uu___3 = FStar_Syntax_Syntax.range_of_bv v in - mk_rt uu___3 - (FStar_TypeChecker_NBETerm.Accu - ((FStar_TypeChecker_NBETerm.Var v), []))) vars in - FStar_Compiler_List.op_At uu___2 bs in - let defs = - FStar_Compiler_List.map - (fun lb -> - translate cfg rec_bs lb.FStar_Syntax_Syntax.lbdef) lbs in - let body1 = translate cfg rec_bs body in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = FStar_Compiler_List.zip3 vars typs defs in - (uu___6, body1, lbs) in - FStar_TypeChecker_NBETerm.UnreducedLetRec uu___5 in - (uu___4, []) in - FStar_TypeChecker_NBETerm.Accu uu___3 in - mk_t1 uu___2 - else - (let uu___3 = make_rec_env lbs bs in translate cfg uu___3 body) - | FStar_Syntax_Syntax.Tm_quoted (qt, qi) -> - let close t = - let bvs = - FStar_Compiler_List.map - (fun uu___2 -> - FStar_Syntax_Syntax.new_bv FStar_Pervasives_Native.None - FStar_Syntax_Syntax.tun) bs in - let s1 = - FStar_Compiler_List.mapi - (fun i -> fun bv -> FStar_Syntax_Syntax.DB (i, bv)) bvs in - let s2 = - let uu___2 = FStar_Compiler_List.zip bvs bs in - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with - | (bv, t1) -> - let uu___4 = - let uu___5 = readback cfg t1 in (bv, uu___5) in - FStar_Syntax_Syntax.NT uu___4) uu___2 in - let uu___2 = FStar_Syntax_Subst.subst s1 t in - FStar_Syntax_Subst.subst s2 uu___2 in - (match qi.FStar_Syntax_Syntax.qkind with - | FStar_Syntax_Syntax.Quote_dynamic -> - let qt1 = close qt in - mk_t1 (FStar_TypeChecker_NBETerm.Quote (qt1, qi)) - | FStar_Syntax_Syntax.Quote_static -> - let qi1 = FStar_Syntax_Syntax.on_antiquoted close qi in - mk_t1 (FStar_TypeChecker_NBETerm.Quote (qt, qi1))) - | FStar_Syntax_Syntax.Tm_lazy li -> - let f uu___2 = - let t = FStar_Syntax_Util.unfold_lazy li in - debug1 - (fun uu___4 -> - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - t in - FStar_Compiler_Util.print1 ">> Unfolding Tm_lazy to %s\n" - uu___5); - translate cfg bs t in - let uu___2 = - let uu___3 = - let uu___4 = FStar_Thunk.mk f in - ((FStar_Pervasives.Inl li), uu___4) in - FStar_TypeChecker_NBETerm.Lazy uu___3 in - mk_t1 uu___2) -and (translate_comp : - config -> - FStar_TypeChecker_NBETerm.t Prims.list -> - FStar_Syntax_Syntax.comp -> FStar_TypeChecker_NBETerm.comp) - = - fun cfg -> - fun bs -> - fun c -> - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total typ -> - let uu___ = translate cfg bs typ in - FStar_TypeChecker_NBETerm.Tot uu___ - | FStar_Syntax_Syntax.GTotal typ -> - let uu___ = translate cfg bs typ in - FStar_TypeChecker_NBETerm.GTot uu___ - | FStar_Syntax_Syntax.Comp ctyp -> - let uu___ = translate_comp_typ cfg bs ctyp in - FStar_TypeChecker_NBETerm.Comp uu___ -and (iapp : - config -> - FStar_TypeChecker_NBETerm.t -> - FStar_TypeChecker_NBETerm.args -> FStar_TypeChecker_NBETerm.t) - = - fun cfg -> - fun f -> - fun args -> - let mk t = mk_rt f.FStar_TypeChecker_NBETerm.nbe_r t in - let uu___ = - let uu___1 = unlazy_unmeta f in - uu___1.FStar_TypeChecker_NBETerm.nbe_t in - match uu___ with - | FStar_TypeChecker_NBETerm.Lam - { FStar_TypeChecker_NBETerm.interp = f1; - FStar_TypeChecker_NBETerm.shape = shape; - FStar_TypeChecker_NBETerm.arity = n;_} - -> - let m = FStar_Compiler_List.length args in - if m < n - then - let arg_values_rev = FStar_Compiler_List.rev args in - let shape1 = - match shape with - | FStar_TypeChecker_NBETerm.Lam_args raw_args -> - let uu___1 = FStar_Compiler_List.splitAt m raw_args in - (match uu___1 with - | (uu___2, raw_args1) -> - FStar_TypeChecker_NBETerm.Lam_args raw_args1) - | FStar_TypeChecker_NBETerm.Lam_bs (ctx, xs, rc) -> - let uu___1 = FStar_Compiler_List.splitAt m xs in - (match uu___1 with - | (uu___2, xs1) -> - let ctx1 = - let uu___3 = - FStar_Compiler_List.map - FStar_Pervasives_Native.fst arg_values_rev in - FStar_Compiler_List.append uu___3 ctx in - FStar_TypeChecker_NBETerm.Lam_bs (ctx1, xs1, rc)) - | FStar_TypeChecker_NBETerm.Lam_primop (f2, args_acc) -> - FStar_TypeChecker_NBETerm.Lam_primop - (f2, (FStar_Compiler_List.op_At args_acc args)) in - mk - (FStar_TypeChecker_NBETerm.Lam - { - FStar_TypeChecker_NBETerm.interp = - (fun l -> - f1 (FStar_Compiler_List.append l arg_values_rev)); - FStar_TypeChecker_NBETerm.shape = shape1; - FStar_TypeChecker_NBETerm.arity = (n - m) - }) - else - if m = n - then - (let arg_values_rev = FStar_Compiler_List.rev args in - f1 arg_values_rev) - else - (let uu___3 = FStar_Compiler_List.splitAt n args in - match uu___3 with - | (args1, args') -> - let uu___4 = f1 (FStar_Compiler_List.rev args1) in - iapp cfg uu___4 args') - | FStar_TypeChecker_NBETerm.Accu (a, ts) -> - mk - (FStar_TypeChecker_NBETerm.Accu - (a, (FStar_Compiler_List.rev_append args ts))) - | FStar_TypeChecker_NBETerm.Construct (i, us, ts) -> - let rec aux args1 us1 ts1 = - match args1 with - | ({ - FStar_TypeChecker_NBETerm.nbe_t = - FStar_TypeChecker_NBETerm.Univ u; - FStar_TypeChecker_NBETerm.nbe_r = uu___1;_}, - uu___2)::args2 -> aux args2 (u :: us1) ts1 - | a::args2 -> aux args2 us1 (a :: ts1) - | [] -> (us1, ts1) in - let uu___1 = aux args us ts in - (match uu___1 with - | (us', ts') -> - mk (FStar_TypeChecker_NBETerm.Construct (i, us', ts'))) - | FStar_TypeChecker_NBETerm.FV (i, us, ts) -> - let rec aux args1 us1 ts1 = - match args1 with - | ({ - FStar_TypeChecker_NBETerm.nbe_t = - FStar_TypeChecker_NBETerm.Univ u; - FStar_TypeChecker_NBETerm.nbe_r = uu___1;_}, - uu___2)::args2 -> aux args2 (u :: us1) ts1 - | a::args2 -> aux args2 us1 (a :: ts1) - | [] -> (us1, ts1) in - let uu___1 = aux args us ts in - (match uu___1 with - | (us', ts') -> mk (FStar_TypeChecker_NBETerm.FV (i, us', ts'))) - | FStar_TypeChecker_NBETerm.TopLevelLet (lb, arity, args_rev) -> - let args_rev1 = FStar_Compiler_List.rev_append args args_rev in - let n_args_rev = FStar_Compiler_List.length args_rev1 in - let n_univs = - FStar_Compiler_List.length lb.FStar_Syntax_Syntax.lbunivs in - (debug cfg - (fun uu___2 -> - let uu___3 = - FStar_Class_Show.show - (FStar_Class_Show.show_either - FStar_Syntax_Print.showable_bv - FStar_Syntax_Print.showable_fv) - lb.FStar_Syntax_Syntax.lbname in - let uu___4 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) arity in - let uu___5 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_nat) n_args_rev in - FStar_Compiler_Util.print3 - "Reached iapp for %s with arity %s and n_args = %s\n" - uu___3 uu___4 uu___5); - if n_args_rev >= arity - then - (let uu___2 = - let uu___3 = - let uu___4 = - FStar_Syntax_Util.unascribe - lb.FStar_Syntax_Syntax.lbdef in - uu___4.FStar_Syntax_Syntax.n in - match uu___3 with - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = uu___4;_} - -> (bs, body) - | uu___4 -> ([], (lb.FStar_Syntax_Syntax.lbdef)) in - match uu___2 with - | (bs, body) -> - if (n_univs + (FStar_Compiler_List.length bs)) = arity - then - let uu___3 = - FStar_Compiler_Util.first_N (n_args_rev - arity) - args_rev1 in - (match uu___3 with - | (extra, args_rev2) -> - (debug cfg - (fun uu___5 -> - let uu___6 = - FStar_Class_Show.show - (FStar_Class_Show.show_either - FStar_Syntax_Print.showable_bv - FStar_Syntax_Print.showable_fv) - lb.FStar_Syntax_Syntax.lbname in - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term body in - let uu___8 = - FStar_Class_Show.show - FStar_TypeChecker_NBETerm.showable_args - args_rev2 in - FStar_Compiler_Util.print3 - "Reducing body of %s = %s,\n\twith args = %s\n" - uu___6 uu___7 uu___8); - (let t = - let uu___5 = - FStar_Compiler_List.map - FStar_Pervasives_Native.fst args_rev2 in - translate cfg uu___5 body in - match extra with - | [] -> t - | uu___5 -> - iapp cfg t (FStar_Compiler_List.rev extra)))) - else - (let uu___4 = - FStar_Compiler_Util.first_N (n_args_rev - n_univs) - args_rev1 in - match uu___4 with - | (extra, univs) -> - let uu___5 = - let uu___6 = - FStar_Compiler_List.map - FStar_Pervasives_Native.fst univs in - translate cfg uu___6 - lb.FStar_Syntax_Syntax.lbdef in - iapp cfg uu___5 (FStar_Compiler_List.rev extra))) - else - mk - (FStar_TypeChecker_NBETerm.TopLevelLet - (lb, arity, args_rev1))) - | FStar_TypeChecker_NBETerm.TopLevelRec - (lb, arity, decreases_list, args') -> - let args1 = FStar_Compiler_List.append args' args in - if (FStar_Compiler_List.length args1) >= arity - then - let uu___1 = - should_reduce_recursive_definition args1 decreases_list in - (match uu___1 with - | (should_reduce, uu___2, uu___3) -> - if Prims.op_Negation should_reduce - then - let fv = - FStar_Compiler_Util.right - lb.FStar_Syntax_Syntax.lbname in - (debug cfg - (fun uu___5 -> - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_fv fv in - FStar_Compiler_Util.print1 - "Decided to not unfold recursive definition %s\n" - uu___6); - (let uu___5 = - let uu___6 = FStar_Syntax_Syntax.range_of_fv fv in - mk_rt uu___6 - (FStar_TypeChecker_NBETerm.FV (fv, [], [])) in - iapp cfg uu___5 args1)) - else - (debug cfg - (fun uu___6 -> - let uu___7 = - let uu___8 = - FStar_Compiler_Util.right - lb.FStar_Syntax_Syntax.lbname in - FStar_Class_Show.show - FStar_Syntax_Print.showable_fv uu___8 in - FStar_Compiler_Util.print1 - "Yes, Decided to unfold recursive definition %s\n" - uu___7); - (let uu___6 = - FStar_Compiler_Util.first_N - (FStar_Compiler_List.length - lb.FStar_Syntax_Syntax.lbunivs) args1 in - match uu___6 with - | (univs, rest) -> - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Compiler_List.map - FStar_Pervasives_Native.fst univs in - FStar_Compiler_List.rev uu___9 in - translate cfg uu___8 - lb.FStar_Syntax_Syntax.lbdef in - iapp cfg uu___7 rest))) - else - mk - (FStar_TypeChecker_NBETerm.TopLevelRec - (lb, arity, decreases_list, args1)) - | FStar_TypeChecker_NBETerm.LocalLetRec - (i, lb, mutual_lbs, local_env, acc_args, remaining_arity, - decreases_list) - -> - if remaining_arity = Prims.int_zero - then - mk - (FStar_TypeChecker_NBETerm.LocalLetRec - (i, lb, mutual_lbs, local_env, - (FStar_Compiler_List.op_At acc_args args), - remaining_arity, decreases_list)) - else - (let n_args = FStar_Compiler_List.length args in - if n_args < remaining_arity - then - mk - (FStar_TypeChecker_NBETerm.LocalLetRec - (i, lb, mutual_lbs, local_env, - (FStar_Compiler_List.op_At acc_args args), - (remaining_arity - n_args), decreases_list)) - else - (let args1 = FStar_Compiler_List.op_At acc_args args in - let uu___3 = - should_reduce_recursive_definition args1 decreases_list in - match uu___3 with - | (should_reduce, uu___4, uu___5) -> - if Prims.op_Negation should_reduce - then - mk - (FStar_TypeChecker_NBETerm.LocalLetRec - (i, lb, mutual_lbs, local_env, args1, - Prims.int_zero, decreases_list)) - else - (let env = make_rec_env mutual_lbs local_env in - debug cfg - (fun uu___8 -> - (let uu___10 = - let uu___11 = - FStar_Compiler_List.map - FStar_TypeChecker_NBETerm.t_to_string - env in - FStar_Compiler_String.concat ",\n\t " - uu___11 in - FStar_Compiler_Util.print1 - "LocalLetRec Env = {\n\t%s\n}\n" uu___10); - (let uu___10 = - let uu___11 = - FStar_Compiler_List.map - (fun uu___12 -> - match uu___12 with - | (t, uu___13) -> - FStar_TypeChecker_NBETerm.t_to_string - t) args1 in - FStar_Compiler_String.concat ",\n\t " - uu___11 in - FStar_Compiler_Util.print1 - "LocalLetRec Args = {\n\t%s\n}\n" uu___10)); - (let uu___8 = - translate cfg env lb.FStar_Syntax_Syntax.lbdef in - iapp cfg uu___8 args1)))) - | FStar_TypeChecker_NBETerm.Constant - (FStar_TypeChecker_NBETerm.SConst (FStar_Const.Const_range_of)) - -> - let callbacks = - { - FStar_TypeChecker_NBETerm.iapp = (iapp cfg); - FStar_TypeChecker_NBETerm.translate = (translate cfg []) - } in - (match args with - | (a, uu___1)::[] -> - FStar_TypeChecker_NBETerm.embed - FStar_TypeChecker_NBETerm.e_range callbacks - a.FStar_TypeChecker_NBETerm.nbe_r - | uu___1 -> - let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string f in - Prims.strcat "NBE ill-typed application Const_range_of: " - uu___3 in - failwith uu___2) - | FStar_TypeChecker_NBETerm.Constant - (FStar_TypeChecker_NBETerm.SConst - (FStar_Const.Const_set_range_of)) -> - let callbacks = - { - FStar_TypeChecker_NBETerm.iapp = (iapp cfg); - FStar_TypeChecker_NBETerm.translate = (translate cfg []) - } in - (match args with - | (t, uu___1)::(r, uu___2)::[] -> - let uu___3 = - FStar_TypeChecker_NBETerm.unembed - FStar_TypeChecker_NBETerm.e_range callbacks r in - (match uu___3 with - | FStar_Pervasives_Native.Some rr -> - { - FStar_TypeChecker_NBETerm.nbe_t = - (t.FStar_TypeChecker_NBETerm.nbe_t); - FStar_TypeChecker_NBETerm.nbe_r = rr - } - | FStar_Pervasives_Native.None -> Prims.magic ()) - | uu___1 -> - let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string f in - Prims.strcat - "NBE ill-typed application Const_set_range_of: " uu___3 in - failwith uu___2) - | uu___1 -> - let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string f in - Prims.strcat "NBE ill-typed application: " uu___3 in - failwith uu___2 -and (translate_fv : - config -> - FStar_TypeChecker_NBETerm.t Prims.list -> - FStar_Syntax_Syntax.fv -> FStar_TypeChecker_NBETerm.t) - = - fun cfg -> - fun bs -> - fun fvar -> - let debug1 = debug cfg in - let qninfo = - let uu___ = FStar_TypeChecker_Cfg.cfg_env cfg.core_cfg in - let uu___1 = FStar_Syntax_Syntax.lid_of_fv fvar in - FStar_TypeChecker_Env.lookup_qname uu___ uu___1 in - let uu___ = (is_constr qninfo) || (is_constr_fv fvar) in - if uu___ - then FStar_TypeChecker_NBETerm.mkConstruct fvar [] [] - else - (let uu___2 = - FStar_TypeChecker_Normalize_Unfolding.should_unfold cfg.core_cfg - (fun uu___3 -> (cfg.core_cfg).FStar_TypeChecker_Cfg.reifying) - fvar qninfo in - match uu___2 with - | FStar_TypeChecker_Normalize_Unfolding.Should_unfold_fully -> - failwith "Not yet handled" - | FStar_TypeChecker_Normalize_Unfolding.Should_unfold_no -> - (debug1 - (fun uu___4 -> - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_fv - fvar in - FStar_Compiler_Util.print1 - "(1) Decided to not unfold %s\n" uu___5); - (let uu___4 = - FStar_TypeChecker_Cfg.find_prim_step cfg.core_cfg fvar in - match uu___4 with - | FStar_Pervasives_Native.Some prim_step when - prim_step.FStar_TypeChecker_Primops_Base.strong_reduction_ok - -> - let arity = - prim_step.FStar_TypeChecker_Primops_Base.arity + - prim_step.FStar_TypeChecker_Primops_Base.univ_arity in - (debug1 - (fun uu___6 -> - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_fv fvar in - FStar_Compiler_Util.print1 "Found a primop %s\n" - uu___7); - mk_t - (FStar_TypeChecker_NBETerm.Lam - { - FStar_TypeChecker_NBETerm.interp = - (fun args_rev -> - let args' = - FStar_Compiler_List.rev args_rev in - let callbacks = - { - FStar_TypeChecker_NBETerm.iapp = - (iapp cfg); - FStar_TypeChecker_NBETerm.translate = - (translate cfg bs) - } in - debug1 - (fun uu___7 -> - let uu___8 = - FStar_Class_Show.show - FStar_TypeChecker_NBETerm.showable_args - args' in - FStar_Compiler_Util.print1 - "Caling primop with args = [%s]\n" - uu___8); - (let uu___7 = - FStar_Compiler_List.span - (fun uu___8 -> - match uu___8 with - | ({ - FStar_TypeChecker_NBETerm.nbe_t - = - FStar_TypeChecker_NBETerm.Univ - uu___9; - FStar_TypeChecker_NBETerm.nbe_r - = uu___10;_}, - uu___11) -> true - | uu___9 -> false) args' in - match uu___7 with - | (univs, rest) -> - let univs1 = - FStar_Compiler_List.map - (fun uu___8 -> - match uu___8 with - | ({ - FStar_TypeChecker_NBETerm.nbe_t - = - FStar_TypeChecker_NBETerm.Univ - u; - FStar_TypeChecker_NBETerm.nbe_r - = uu___9;_}, - uu___10) -> u - | uu___9 -> - failwith "Impossible") - univs in - let uu___8 = - prim_step.FStar_TypeChecker_Primops_Base.interpretation_nbe - callbacks univs1 rest in - (match uu___8 with - | FStar_Pervasives_Native.Some x -> - (debug1 - (fun uu___10 -> - let uu___11 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_fv - fvar in - let uu___12 = - FStar_TypeChecker_NBETerm.t_to_string - x in - FStar_Compiler_Util.print2 - "Primitive operator %s returned %s\n" - uu___11 uu___12); - x) - | FStar_Pervasives_Native.None -> - (debug1 - (fun uu___10 -> - let uu___11 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_fv - fvar in - FStar_Compiler_Util.print1 - "Primitive operator %s failed\n" - uu___11); - (let uu___10 = - FStar_TypeChecker_NBETerm.mkFV - fvar [] [] in - iapp cfg uu___10 args'))))); - FStar_TypeChecker_NBETerm.shape = - (FStar_TypeChecker_NBETerm.Lam_primop - (fvar, [])); - FStar_TypeChecker_NBETerm.arity = arity - })) - | FStar_Pervasives_Native.Some uu___5 -> - (debug1 - (fun uu___7 -> - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_fv fvar in - FStar_Compiler_Util.print1 - "(2) Decided to not unfold %s\n" uu___8); - FStar_TypeChecker_NBETerm.mkFV fvar [] []) - | uu___5 -> - (debug1 - (fun uu___7 -> - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_fv fvar in - FStar_Compiler_Util.print1 - "(3) Decided to not unfold %s\n" uu___8); - FStar_TypeChecker_NBETerm.mkFV fvar [] []))) - | FStar_TypeChecker_Normalize_Unfolding.Should_unfold_reify -> - let t = - let is_qninfo_visible = - let uu___3 = - FStar_TypeChecker_Env.lookup_definition_qninfo - (cfg.core_cfg).FStar_TypeChecker_Cfg.delta_level - (fvar.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - qninfo in - FStar_Compiler_Option.isSome uu___3 in - if is_qninfo_visible - then - match qninfo with - | FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr - ({ - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (is_rec, lbs); - FStar_Syntax_Syntax.lids1 = names;_}; - FStar_Syntax_Syntax.sigrng = uu___3; - FStar_Syntax_Syntax.sigquals = uu___4; - FStar_Syntax_Syntax.sigmeta = uu___5; - FStar_Syntax_Syntax.sigattrs = uu___6; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___7; - FStar_Syntax_Syntax.sigopts = uu___8;_}, - _us_opt), - _rng) - -> - (debug1 - (fun uu___10 -> - let uu___11 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_fv fvar in - FStar_Compiler_Util.print1 - "(1) Decided to unfold %s\n" uu___11); - (let lbm = find_let lbs fvar in - match lbm with - | FStar_Pervasives_Native.Some lb -> - if - is_rec && - ((cfg.core_cfg).FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.zeta - then - let uu___10 = let_rec_arity lb in - (match uu___10 with - | (ar, lst) -> - let uu___11 = - FStar_Syntax_Syntax.range_of_fv fvar in - mk_rt uu___11 - (FStar_TypeChecker_NBETerm.TopLevelRec - (lb, ar, lst, []))) - else translate_letbinding cfg bs lb - | FStar_Pervasives_Native.None -> - failwith "Could not find let binding")) - | uu___3 -> - (debug1 - (fun uu___5 -> - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_fv fvar in - FStar_Compiler_Util.print1 - "(1) qninfo is None for (%s)\n" uu___6); - FStar_TypeChecker_NBETerm.mkFV fvar [] []) - else - (debug1 - (fun uu___5 -> - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_fv fvar in - FStar_Compiler_Util.print1 - "(1) qninfo is not visible at this level (%s)\n" - uu___6); - FStar_TypeChecker_NBETerm.mkFV fvar [] []) in - (cache_add cfg fvar t; t) - | FStar_TypeChecker_Normalize_Unfolding.Should_unfold_yes -> - let t = - let is_qninfo_visible = - let uu___3 = - FStar_TypeChecker_Env.lookup_definition_qninfo - (cfg.core_cfg).FStar_TypeChecker_Cfg.delta_level - (fvar.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - qninfo in - FStar_Compiler_Option.isSome uu___3 in - if is_qninfo_visible - then - match qninfo with - | FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr - ({ - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (is_rec, lbs); - FStar_Syntax_Syntax.lids1 = names;_}; - FStar_Syntax_Syntax.sigrng = uu___3; - FStar_Syntax_Syntax.sigquals = uu___4; - FStar_Syntax_Syntax.sigmeta = uu___5; - FStar_Syntax_Syntax.sigattrs = uu___6; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___7; - FStar_Syntax_Syntax.sigopts = uu___8;_}, - _us_opt), - _rng) - -> - (debug1 - (fun uu___10 -> - let uu___11 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_fv fvar in - FStar_Compiler_Util.print1 - "(1) Decided to unfold %s\n" uu___11); - (let lbm = find_let lbs fvar in - match lbm with - | FStar_Pervasives_Native.Some lb -> - if - is_rec && - ((cfg.core_cfg).FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.zeta - then - let uu___10 = let_rec_arity lb in - (match uu___10 with - | (ar, lst) -> - let uu___11 = - FStar_Syntax_Syntax.range_of_fv fvar in - mk_rt uu___11 - (FStar_TypeChecker_NBETerm.TopLevelRec - (lb, ar, lst, []))) - else translate_letbinding cfg bs lb - | FStar_Pervasives_Native.None -> - failwith "Could not find let binding")) - | uu___3 -> - (debug1 - (fun uu___5 -> - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_fv fvar in - FStar_Compiler_Util.print1 - "(1) qninfo is None for (%s)\n" uu___6); - FStar_TypeChecker_NBETerm.mkFV fvar [] []) - else - (debug1 - (fun uu___5 -> - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_fv fvar in - FStar_Compiler_Util.print1 - "(1) qninfo is not visible at this level (%s)\n" - uu___6); - FStar_TypeChecker_NBETerm.mkFV fvar [] []) in - (cache_add cfg fvar t; t)) -and (translate_letbinding : - config -> - FStar_TypeChecker_NBETerm.t Prims.list -> - FStar_Syntax_Syntax.letbinding -> FStar_TypeChecker_NBETerm.t) - = - fun cfg -> - fun bs -> - fun lb -> - let debug1 = debug cfg in - let us = lb.FStar_Syntax_Syntax.lbunivs in - let uu___ = - FStar_Syntax_Util.arrow_formals lb.FStar_Syntax_Syntax.lbtyp in - match uu___ with - | (formals, uu___1) -> - let arity = - (FStar_Compiler_List.length us) + - (FStar_Compiler_List.length formals) in - if arity = Prims.int_zero - then translate cfg bs lb.FStar_Syntax_Syntax.lbdef - else - (let uu___3 = - FStar_Compiler_Util.is_right lb.FStar_Syntax_Syntax.lbname in - if uu___3 - then - (debug1 - (fun uu___5 -> - let uu___6 = - FStar_Class_Show.show - (FStar_Class_Show.show_either - FStar_Syntax_Print.showable_bv - FStar_Syntax_Print.showable_fv) - lb.FStar_Syntax_Syntax.lbname in - let uu___7 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) arity in - FStar_Compiler_Util.print2 - "Making TopLevelLet for %s with arity %s\n" uu___6 - uu___7); - (let uu___5 = - FStar_Syntax_Syntax.range_of_lbname - lb.FStar_Syntax_Syntax.lbname in - mk_rt uu___5 - (FStar_TypeChecker_NBETerm.TopLevelLet (lb, arity, [])))) - else translate cfg bs lb.FStar_Syntax_Syntax.lbdef) -and (mkRec : - Prims.int -> - FStar_Syntax_Syntax.letbinding -> - FStar_Syntax_Syntax.letbinding Prims.list -> - FStar_TypeChecker_NBETerm.t Prims.list -> FStar_TypeChecker_NBETerm.t) - = - fun i -> - fun b -> - fun bs -> - fun env -> - let uu___ = let_rec_arity b in - match uu___ with - | (ar, ar_lst) -> - mk_t - (FStar_TypeChecker_NBETerm.LocalLetRec - (i, b, bs, env, [], ar, ar_lst)) -and (make_rec_env : - FStar_Syntax_Syntax.letbinding Prims.list -> - FStar_TypeChecker_NBETerm.t Prims.list -> - FStar_TypeChecker_NBETerm.t Prims.list) - = - fun all_lbs -> - fun all_outer_bs -> - let rec_bindings = - FStar_Compiler_List.mapi - (fun i -> fun lb -> mkRec i lb all_lbs all_outer_bs) all_lbs in - FStar_Compiler_List.rev_append rec_bindings all_outer_bs -and (translate_constant : - FStar_Syntax_Syntax.sconst -> FStar_TypeChecker_NBETerm.constant) = - fun c -> - match c with - | FStar_Const.Const_unit -> FStar_TypeChecker_NBETerm.Unit - | FStar_Const.Const_bool b -> FStar_TypeChecker_NBETerm.Bool b - | FStar_Const.Const_int (s, FStar_Pervasives_Native.None) -> - let uu___ = FStar_BigInt.big_int_of_string s in - FStar_TypeChecker_NBETerm.Int uu___ - | FStar_Const.Const_string (s, r) -> - FStar_TypeChecker_NBETerm.String (s, r) - | FStar_Const.Const_char c1 -> FStar_TypeChecker_NBETerm.Char c1 - | FStar_Const.Const_range r -> FStar_TypeChecker_NBETerm.Range r - | FStar_Const.Const_real r -> FStar_TypeChecker_NBETerm.Real r - | uu___ -> FStar_TypeChecker_NBETerm.SConst c -and (readback_comp : - config -> FStar_TypeChecker_NBETerm.comp -> FStar_Syntax_Syntax.comp) = - fun cfg -> - fun c -> - let c' = - match c with - | FStar_TypeChecker_NBETerm.Tot typ -> - let uu___ = readback cfg typ in FStar_Syntax_Syntax.Total uu___ - | FStar_TypeChecker_NBETerm.GTot typ -> - let uu___ = readback cfg typ in FStar_Syntax_Syntax.GTotal uu___ - | FStar_TypeChecker_NBETerm.Comp ctyp -> - let uu___ = readback_comp_typ cfg ctyp in - FStar_Syntax_Syntax.Comp uu___ in - FStar_Syntax_Syntax.mk c' FStar_Compiler_Range_Type.dummyRange -and (translate_comp_typ : - config -> - FStar_TypeChecker_NBETerm.t Prims.list -> - FStar_Syntax_Syntax.comp_typ -> FStar_TypeChecker_NBETerm.comp_typ) - = - fun cfg -> - fun bs -> - fun c -> - let uu___ = c in - match uu___ with - | { FStar_Syntax_Syntax.comp_univs = comp_univs; - FStar_Syntax_Syntax.effect_name = effect_name; - FStar_Syntax_Syntax.result_typ = result_typ; - FStar_Syntax_Syntax.effect_args = effect_args; - FStar_Syntax_Syntax.flags = flags;_} -> - let uu___1 = - FStar_Compiler_List.map (translate_univ cfg bs) comp_univs in - let uu___2 = translate cfg bs result_typ in - let uu___3 = - FStar_Compiler_List.map - (fun x -> - let uu___4 = - translate cfg bs (FStar_Pervasives_Native.fst x) in - (uu___4, (FStar_Pervasives_Native.snd x))) effect_args in - let uu___4 = - FStar_Compiler_List.map (translate_flag cfg bs) flags in - { - FStar_TypeChecker_NBETerm.comp_univs = uu___1; - FStar_TypeChecker_NBETerm.effect_name = effect_name; - FStar_TypeChecker_NBETerm.result_typ = uu___2; - FStar_TypeChecker_NBETerm.effect_args = uu___3; - FStar_TypeChecker_NBETerm.flags = uu___4 - } -and (readback_comp_typ : - config -> - FStar_TypeChecker_NBETerm.comp_typ -> FStar_Syntax_Syntax.comp_typ) - = - fun cfg -> - fun c -> - let uu___ = readback cfg c.FStar_TypeChecker_NBETerm.result_typ in - let uu___1 = - FStar_Compiler_List.map - (fun x -> - let uu___2 = readback cfg (FStar_Pervasives_Native.fst x) in - (uu___2, (FStar_Pervasives_Native.snd x))) - c.FStar_TypeChecker_NBETerm.effect_args in - let uu___2 = - FStar_Compiler_List.map (readback_flag cfg) - c.FStar_TypeChecker_NBETerm.flags in - { - FStar_Syntax_Syntax.comp_univs = - (c.FStar_TypeChecker_NBETerm.comp_univs); - FStar_Syntax_Syntax.effect_name = - (c.FStar_TypeChecker_NBETerm.effect_name); - FStar_Syntax_Syntax.result_typ = uu___; - FStar_Syntax_Syntax.effect_args = uu___1; - FStar_Syntax_Syntax.flags = uu___2 - } -and (translate_residual_comp : - config -> - FStar_TypeChecker_NBETerm.t Prims.list -> - FStar_Syntax_Syntax.residual_comp -> - FStar_TypeChecker_NBETerm.residual_comp) - = - fun cfg -> - fun bs -> - fun c -> - let uu___ = c in - match uu___ with - | { FStar_Syntax_Syntax.residual_effect = residual_effect; - FStar_Syntax_Syntax.residual_typ = residual_typ; - FStar_Syntax_Syntax.residual_flags = residual_flags;_} -> - let uu___1 = - if - ((cfg.core_cfg).FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.for_extraction - then FStar_Pervasives_Native.None - else - FStar_Compiler_Util.map_opt residual_typ (translate cfg bs) in - let uu___2 = - FStar_Compiler_List.map (translate_flag cfg bs) residual_flags in - { - FStar_TypeChecker_NBETerm.residual_effect = residual_effect; - FStar_TypeChecker_NBETerm.residual_typ = uu___1; - FStar_TypeChecker_NBETerm.residual_flags = uu___2 - } -and (readback_residual_comp : - config -> - FStar_TypeChecker_NBETerm.residual_comp -> - FStar_Syntax_Syntax.residual_comp) - = - fun cfg -> - fun c -> - let uu___ = - FStar_Compiler_Util.map_opt c.FStar_TypeChecker_NBETerm.residual_typ - (fun x -> - debug cfg - (fun uu___2 -> - let uu___3 = FStar_TypeChecker_NBETerm.t_to_string x in - FStar_Compiler_Util.print1 "Reading back residualtype %s\n" - uu___3); - readback cfg x) in - let uu___1 = - FStar_Compiler_List.map (readback_flag cfg) - c.FStar_TypeChecker_NBETerm.residual_flags in - { - FStar_Syntax_Syntax.residual_effect = - (c.FStar_TypeChecker_NBETerm.residual_effect); - FStar_Syntax_Syntax.residual_typ = uu___; - FStar_Syntax_Syntax.residual_flags = uu___1 - } -and (translate_flag : - config -> - FStar_TypeChecker_NBETerm.t Prims.list -> - FStar_Syntax_Syntax.cflag -> FStar_TypeChecker_NBETerm.cflag) - = - fun cfg -> - fun bs -> - fun f -> - match f with - | FStar_Syntax_Syntax.TOTAL -> FStar_TypeChecker_NBETerm.TOTAL - | FStar_Syntax_Syntax.MLEFFECT -> FStar_TypeChecker_NBETerm.MLEFFECT - | FStar_Syntax_Syntax.RETURN -> FStar_TypeChecker_NBETerm.RETURN - | FStar_Syntax_Syntax.PARTIAL_RETURN -> - FStar_TypeChecker_NBETerm.PARTIAL_RETURN - | FStar_Syntax_Syntax.SOMETRIVIAL -> - FStar_TypeChecker_NBETerm.SOMETRIVIAL - | FStar_Syntax_Syntax.TRIVIAL_POSTCONDITION -> - FStar_TypeChecker_NBETerm.TRIVIAL_POSTCONDITION - | FStar_Syntax_Syntax.SHOULD_NOT_INLINE -> - FStar_TypeChecker_NBETerm.SHOULD_NOT_INLINE - | FStar_Syntax_Syntax.LEMMA -> FStar_TypeChecker_NBETerm.LEMMA - | FStar_Syntax_Syntax.CPS -> FStar_TypeChecker_NBETerm.CPS - | FStar_Syntax_Syntax.DECREASES (FStar_Syntax_Syntax.Decreases_lex l) - -> - let uu___ = FStar_Compiler_List.map (translate cfg bs) l in - FStar_TypeChecker_NBETerm.DECREASES_lex uu___ - | FStar_Syntax_Syntax.DECREASES (FStar_Syntax_Syntax.Decreases_wf - (rel, e)) -> - let uu___ = - let uu___1 = translate cfg bs rel in - let uu___2 = translate cfg bs e in (uu___1, uu___2) in - FStar_TypeChecker_NBETerm.DECREASES_wf uu___ -and (readback_flag : - config -> FStar_TypeChecker_NBETerm.cflag -> FStar_Syntax_Syntax.cflag) = - fun cfg -> - fun f -> - match f with - | FStar_TypeChecker_NBETerm.TOTAL -> FStar_Syntax_Syntax.TOTAL - | FStar_TypeChecker_NBETerm.MLEFFECT -> FStar_Syntax_Syntax.MLEFFECT - | FStar_TypeChecker_NBETerm.RETURN -> FStar_Syntax_Syntax.RETURN - | FStar_TypeChecker_NBETerm.PARTIAL_RETURN -> - FStar_Syntax_Syntax.PARTIAL_RETURN - | FStar_TypeChecker_NBETerm.SOMETRIVIAL -> - FStar_Syntax_Syntax.SOMETRIVIAL - | FStar_TypeChecker_NBETerm.TRIVIAL_POSTCONDITION -> - FStar_Syntax_Syntax.TRIVIAL_POSTCONDITION - | FStar_TypeChecker_NBETerm.SHOULD_NOT_INLINE -> - FStar_Syntax_Syntax.SHOULD_NOT_INLINE - | FStar_TypeChecker_NBETerm.LEMMA -> FStar_Syntax_Syntax.LEMMA - | FStar_TypeChecker_NBETerm.CPS -> FStar_Syntax_Syntax.CPS - | FStar_TypeChecker_NBETerm.DECREASES_lex l -> - let uu___ = - let uu___1 = FStar_Compiler_List.map (readback cfg) l in - FStar_Syntax_Syntax.Decreases_lex uu___1 in - FStar_Syntax_Syntax.DECREASES uu___ - | FStar_TypeChecker_NBETerm.DECREASES_wf (rel, e) -> - let uu___ = - let uu___1 = - let uu___2 = readback cfg rel in - let uu___3 = readback cfg e in (uu___2, uu___3) in - FStar_Syntax_Syntax.Decreases_wf uu___1 in - FStar_Syntax_Syntax.DECREASES uu___ -and (translate_monadic : - (FStar_Syntax_Syntax.monad_name * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax) -> - config -> - FStar_TypeChecker_NBETerm.t Prims.list -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_TypeChecker_NBETerm.t) - = - fun uu___ -> - fun cfg -> - fun bs -> - fun e -> - match uu___ with - | (m, ty) -> - let e1 = FStar_Syntax_Util.unascribe e in - (match e1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (false, lb::[]); - FStar_Syntax_Syntax.body1 = body;_} - -> - let uu___1 = - let uu___2 = - FStar_TypeChecker_Env.norm_eff_name - (cfg.core_cfg).FStar_TypeChecker_Cfg.tcenv m in - FStar_TypeChecker_Env.effect_decl_opt - (cfg.core_cfg).FStar_TypeChecker_Cfg.tcenv uu___2 in - (match uu___1 with - | FStar_Pervasives_Native.None -> - let uu___2 = - let uu___3 = FStar_Ident.string_of_lid m in - FStar_Compiler_Util.format1 - "Effect declaration not found: %s" uu___3 in - failwith uu___2 - | FStar_Pervasives_Native.Some (ed, q) -> - let cfg' = reifying_false cfg in - let body_lam = - let body_rc = - { - FStar_Syntax_Syntax.residual_effect = m; - FStar_Syntax_Syntax.residual_typ = - (FStar_Pervasives_Native.Some ty); - FStar_Syntax_Syntax.residual_flags = [] - } in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Compiler_Util.left - lb.FStar_Syntax_Syntax.lbname in - FStar_Syntax_Syntax.mk_binder uu___6 in - [uu___5] in - { - FStar_Syntax_Syntax.bs = uu___4; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = - (FStar_Pervasives_Native.Some body_rc) - } in - FStar_Syntax_Syntax.Tm_abs uu___3 in - FStar_Syntax_Syntax.mk uu___2 - body.FStar_Syntax_Syntax.pos in - let maybe_range_arg = - let uu___2 = - FStar_Compiler_Util.for_some - (FStar_TypeChecker_TermEqAndSimplify.eq_tm_bool - (cfg.core_cfg).FStar_TypeChecker_Cfg.tcenv - FStar_Syntax_Util.dm4f_bind_range_attr) - ed.FStar_Syntax_Syntax.eff_attrs in - if uu___2 - then - let uu___3 = - let uu___4 = - let uu___5 = - FStar_TypeChecker_Primops_Base.embed_simple - FStar_Syntax_Embeddings.e_range - lb.FStar_Syntax_Syntax.lbpos - lb.FStar_Syntax_Syntax.lbpos in - translate cfg [] uu___5 in - (uu___4, FStar_Pervasives_Native.None) in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_TypeChecker_Primops_Base.embed_simple - FStar_Syntax_Embeddings.e_range - body.FStar_Syntax_Syntax.pos - body.FStar_Syntax_Syntax.pos in - translate cfg [] uu___7 in - (uu___6, FStar_Pervasives_Native.None) in - [uu___5] in - uu___3 :: uu___4 - else [] in - let t = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Syntax_Util.get_bind_repr ed in - FStar_Compiler_Util.must uu___7 in - FStar_Pervasives_Native.snd uu___6 in - FStar_Syntax_Util.un_uinst uu___5 in - translate cfg' [] uu___4 in - iapp cfg uu___3 - [((mk_t - (FStar_TypeChecker_NBETerm.Univ - FStar_Syntax_Syntax.U_unknown)), - FStar_Pervasives_Native.None); - ((mk_t - (FStar_TypeChecker_NBETerm.Univ - FStar_Syntax_Syntax.U_unknown)), - FStar_Pervasives_Native.None)] in - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - translate cfg' bs - lb.FStar_Syntax_Syntax.lbtyp in - (uu___6, FStar_Pervasives_Native.None) in - let uu___6 = - let uu___7 = - let uu___8 = translate cfg' bs ty in - (uu___8, FStar_Pervasives_Native.None) in - [uu___7] in - uu___5 :: uu___6 in - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - translate cfg bs - lb.FStar_Syntax_Syntax.lbdef in - (uu___9, FStar_Pervasives_Native.None) in - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - translate cfg bs body_lam in - (uu___12, - FStar_Pervasives_Native.None) in - [uu___11] in - ((mk_t FStar_TypeChecker_NBETerm.Unknown), - FStar_Pervasives_Native.None) :: - uu___10 in - uu___8 :: uu___9 in - ((mk_t FStar_TypeChecker_NBETerm.Unknown), - FStar_Pervasives_Native.None) :: uu___7 in - FStar_Compiler_List.op_At maybe_range_arg - uu___6 in - FStar_Compiler_List.op_At uu___4 uu___5 in - iapp cfg uu___2 uu___3 in - (debug cfg - (fun uu___3 -> - let uu___4 = - FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.print1 - "translate_monadic: %s\n" uu___4); - t)) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_reflect uu___1); - FStar_Syntax_Syntax.pos = uu___2; - FStar_Syntax_Syntax.vars = uu___3; - FStar_Syntax_Syntax.hash_code = uu___4;_}; - FStar_Syntax_Syntax.args = (e2, uu___5)::[];_} - -> - let uu___6 = reifying_false cfg in translate uu___6 bs e2 - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = args;_} - -> - (debug cfg - (fun uu___2 -> - let uu___3 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head in - let uu___4 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - (FStar_Class_Show.show_tuple2 - FStar_Syntax_Print.showable_term - FStar_Syntax_Print.showable_aqual)) args in - FStar_Compiler_Util.print2 - "translate_monadic app (%s) @ (%s)\n" uu___3 - uu___4); - (let fallback1 uu___2 = translate cfg bs e1 in - let fallback2 uu___2 = - let uu___3 = reifying_false cfg in - let uu___4 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 = e1; - FStar_Syntax_Syntax.meta = - (FStar_Syntax_Syntax.Meta_monadic (m, ty)) - }) e1.FStar_Syntax_Syntax.pos in - translate uu___3 bs uu___4 in - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst head in - uu___3.FStar_Syntax_Syntax.n in - match uu___2 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - let lid = FStar_Syntax_Syntax.lid_of_fv fv in - let qninfo = - FStar_TypeChecker_Env.lookup_qname - (cfg.core_cfg).FStar_TypeChecker_Cfg.tcenv lid in - let uu___3 = - let uu___4 = - FStar_TypeChecker_Env.is_action - (cfg.core_cfg).FStar_TypeChecker_Cfg.tcenv lid in - Prims.op_Negation uu___4 in - if uu___3 - then fallback1 () - else - (let uu___5 = - let uu___6 = - FStar_TypeChecker_Env.lookup_definition_qninfo - (cfg.core_cfg).FStar_TypeChecker_Cfg.delta_level - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - qninfo in - FStar_Compiler_Option.isNone uu___6 in - if uu___5 - then fallback2 () - else - (let e2 = - let uu___7 = - FStar_Syntax_Util.mk_reify head - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.mk_Tm_app uu___7 args - e1.FStar_Syntax_Syntax.pos in - let uu___7 = reifying_false cfg in - translate uu___7 bs e2)) - | uu___3 -> fallback1 ())) - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = sc; - FStar_Syntax_Syntax.ret_opt = asc_opt; - FStar_Syntax_Syntax.brs = branches; - FStar_Syntax_Syntax.rc_opt1 = lopt;_} - -> - let branches1 = - FStar_Compiler_List.map - (fun uu___1 -> - match uu___1 with - | (pat, wopt, tm) -> - let uu___2 = - FStar_Syntax_Util.mk_reify tm - (FStar_Pervasives_Native.Some m) in - (pat, wopt, uu___2)) branches in - let tm = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_match - { - FStar_Syntax_Syntax.scrutinee = sc; - FStar_Syntax_Syntax.ret_opt = asc_opt; - FStar_Syntax_Syntax.brs = branches1; - FStar_Syntax_Syntax.rc_opt1 = lopt - }) e1.FStar_Syntax_Syntax.pos in - let uu___1 = reifying_false cfg in translate uu___1 bs tm - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t; - FStar_Syntax_Syntax.meta = - FStar_Syntax_Syntax.Meta_monadic uu___1;_} - -> translate_monadic (m, ty) cfg bs e1 - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t; - FStar_Syntax_Syntax.meta = - FStar_Syntax_Syntax.Meta_monadic_lift - (msrc, mtgt, ty');_} - -> translate_monadic_lift (msrc, mtgt, ty') cfg bs e1 - | uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Tagged.tag_of - FStar_Syntax_Syntax.tagged_term e1 in - FStar_Compiler_Util.format1 - "Unexpected case in translate_monadic: %s" uu___3 in - failwith uu___2) -and (translate_monadic_lift : - (FStar_Syntax_Syntax.monad_name * FStar_Syntax_Syntax.monad_name * - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) -> - config -> - FStar_TypeChecker_NBETerm.t Prims.list -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_TypeChecker_NBETerm.t) - = - fun uu___ -> - fun cfg -> - fun bs -> - fun e -> - match uu___ with - | (msrc, mtgt, ty) -> - let e1 = FStar_Syntax_Util.unascribe e in - let uu___1 = - (FStar_Syntax_Util.is_pure_effect msrc) || - (FStar_Syntax_Util.is_div_effect msrc) in - if uu___1 - then - let ed = - let uu___2 = - FStar_TypeChecker_Env.norm_eff_name - (cfg.core_cfg).FStar_TypeChecker_Cfg.tcenv mtgt in - FStar_TypeChecker_Env.get_effect_decl - (cfg.core_cfg).FStar_TypeChecker_Cfg.tcenv uu___2 in - let ret = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = FStar_Syntax_Util.get_return_repr ed in - FStar_Compiler_Util.must uu___6 in - FStar_Pervasives_Native.snd uu___5 in - FStar_Syntax_Subst.compress uu___4 in - uu___3.FStar_Syntax_Syntax.n in - match uu___2 with - | FStar_Syntax_Syntax.Tm_uinst (ret1, uu___3::[]) -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_uinst - (ret1, [FStar_Syntax_Syntax.U_unknown])) - e1.FStar_Syntax_Syntax.pos - | uu___3 -> - failwith "NYI: Reification of indexed effect (NBE)" in - let cfg' = reifying_false cfg in - let t = - let uu___2 = - let uu___3 = translate cfg' [] ret in - iapp cfg' uu___3 - [((mk_t - (FStar_TypeChecker_NBETerm.Univ - FStar_Syntax_Syntax.U_unknown)), - FStar_Pervasives_Native.None)] in - let uu___3 = - let uu___4 = - let uu___5 = translate cfg' bs ty in - (uu___5, FStar_Pervasives_Native.None) in - let uu___5 = - let uu___6 = - let uu___7 = translate cfg' bs e1 in - (uu___7, FStar_Pervasives_Native.None) in - [uu___6] in - uu___4 :: uu___5 in - iapp cfg' uu___2 uu___3 in - (debug cfg - (fun uu___3 -> - let uu___4 = FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.print1 - "translate_monadic_lift(1): %s\n" uu___4); - t) - else - (let uu___3 = - FStar_TypeChecker_Env.monad_leq - (cfg.core_cfg).FStar_TypeChecker_Cfg.tcenv msrc mtgt in - match uu___3 with - | FStar_Pervasives_Native.None -> - let uu___4 = - let uu___5 = FStar_Ident.string_of_lid msrc in - let uu___6 = FStar_Ident.string_of_lid mtgt in - FStar_Compiler_Util.format2 - "Impossible : trying to reify a lift between unrelated effects (%s and %s)" - uu___5 uu___6 in - failwith uu___4 - | FStar_Pervasives_Native.Some - { FStar_TypeChecker_Env.msource = uu___4; - FStar_TypeChecker_Env.mtarget = uu___5; - FStar_TypeChecker_Env.mlift = - { FStar_TypeChecker_Env.mlift_wp = uu___6; - FStar_TypeChecker_Env.mlift_term = - FStar_Pervasives_Native.None;_}; - FStar_TypeChecker_Env.mpath = uu___7;_} - -> - let uu___8 = - let uu___9 = FStar_Ident.string_of_lid msrc in - let uu___10 = FStar_Ident.string_of_lid mtgt in - FStar_Compiler_Util.format2 - "Impossible : trying to reify a non-reifiable lift (from %s to %s)" - uu___9 uu___10 in - failwith uu___8 - | FStar_Pervasives_Native.Some - { FStar_TypeChecker_Env.msource = uu___4; - FStar_TypeChecker_Env.mtarget = uu___5; - FStar_TypeChecker_Env.mlift = - { FStar_TypeChecker_Env.mlift_wp = uu___6; - FStar_TypeChecker_Env.mlift_term = - FStar_Pervasives_Native.Some lift;_}; - FStar_TypeChecker_Env.mpath = uu___7;_} - -> - let lift_lam = - let x = - FStar_Syntax_Syntax.new_bv - FStar_Pervasives_Native.None - FStar_Syntax_Syntax.tun in - let uu___8 = - let uu___9 = FStar_Syntax_Syntax.mk_binder x in - [uu___9] in - let uu___9 = - let uu___10 = FStar_Syntax_Syntax.bv_to_name x in - lift FStar_Syntax_Syntax.U_unknown ty uu___10 in - FStar_Syntax_Util.abs uu___8 uu___9 - FStar_Pervasives_Native.None in - let cfg' = reifying_false cfg in - let t = - let uu___8 = translate cfg' [] lift_lam in - let uu___9 = - let uu___10 = - let uu___11 = translate cfg bs e1 in - (uu___11, FStar_Pervasives_Native.None) in - [uu___10] in - iapp cfg uu___8 uu___9 in - (debug cfg - (fun uu___9 -> - let uu___10 = - FStar_TypeChecker_NBETerm.t_to_string t in - FStar_Compiler_Util.print1 - "translate_monadic_lift(2): %s\n" uu___10); - t)) -and (readback : - config -> FStar_TypeChecker_NBETerm.t -> FStar_Syntax_Syntax.term) = - fun cfg -> - fun x -> - let debug1 = debug cfg in - let readback_args cfg1 args = - map_rev - (fun uu___ -> - match uu___ with - | (x1, q) -> let uu___1 = readback cfg1 x1 in (uu___1, q)) args in - let with_range t = - { - FStar_Syntax_Syntax.n = (t.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = (x.FStar_TypeChecker_NBETerm.nbe_r); - FStar_Syntax_Syntax.vars = (t.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = (t.FStar_Syntax_Syntax.hash_code) - } in - let mk t = FStar_Syntax_Syntax.mk t x.FStar_TypeChecker_NBETerm.nbe_r in - debug1 - (fun uu___1 -> - let uu___2 = FStar_TypeChecker_NBETerm.t_to_string x in - FStar_Compiler_Util.print1 "Readback: %s\n" uu___2); - (match x.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.Univ u -> - failwith "Readback of universes should not occur" - | FStar_TypeChecker_NBETerm.Unknown -> - FStar_Syntax_Syntax.mk FStar_Syntax_Syntax.Tm_unknown - x.FStar_TypeChecker_NBETerm.nbe_r - | FStar_TypeChecker_NBETerm.Constant (FStar_TypeChecker_NBETerm.Unit) - -> with_range FStar_Syntax_Syntax.unit_const - | FStar_TypeChecker_NBETerm.Constant (FStar_TypeChecker_NBETerm.Bool - (true)) -> with_range FStar_Syntax_Util.exp_true_bool - | FStar_TypeChecker_NBETerm.Constant (FStar_TypeChecker_NBETerm.Bool - (false)) -> with_range FStar_Syntax_Util.exp_false_bool - | FStar_TypeChecker_NBETerm.Constant (FStar_TypeChecker_NBETerm.Int i) - -> - let uu___1 = - let uu___2 = FStar_BigInt.string_of_big_int i in - FStar_Syntax_Util.exp_int uu___2 in - with_range uu___1 - | FStar_TypeChecker_NBETerm.Constant (FStar_TypeChecker_NBETerm.String - (s, r)) -> - mk - (FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_string (s, r))) - | FStar_TypeChecker_NBETerm.Constant (FStar_TypeChecker_NBETerm.Char - c) -> - let uu___1 = FStar_Syntax_Util.exp_char c in with_range uu___1 - | FStar_TypeChecker_NBETerm.Constant (FStar_TypeChecker_NBETerm.Range - r) -> - FStar_TypeChecker_Primops_Base.embed_simple - FStar_Syntax_Embeddings.e___range - x.FStar_TypeChecker_NBETerm.nbe_r r - | FStar_TypeChecker_NBETerm.Constant (FStar_TypeChecker_NBETerm.Real - r) -> - FStar_TypeChecker_Primops_Base.embed_simple - FStar_Syntax_Embeddings.e_real x.FStar_TypeChecker_NBETerm.nbe_r - (FStar_Compiler_Real.Real r) - | FStar_TypeChecker_NBETerm.Constant (FStar_TypeChecker_NBETerm.SConst - c) -> mk (FStar_Syntax_Syntax.Tm_constant c) - | FStar_TypeChecker_NBETerm.Meta (t, m) -> - let uu___1 = - let uu___2 = - let uu___3 = readback cfg t in - let uu___4 = FStar_Thunk.force m in - { - FStar_Syntax_Syntax.tm2 = uu___3; - FStar_Syntax_Syntax.meta = uu___4 - } in - FStar_Syntax_Syntax.Tm_meta uu___2 in - mk uu___1 - | FStar_TypeChecker_NBETerm.Type_t u -> - mk (FStar_Syntax_Syntax.Tm_type u) - | FStar_TypeChecker_NBETerm.Lam - { FStar_TypeChecker_NBETerm.interp = f; - FStar_TypeChecker_NBETerm.shape = shape; - FStar_TypeChecker_NBETerm.arity = arity;_} - -> - (match shape with - | FStar_TypeChecker_NBETerm.Lam_bs (ctx, binders, rc) -> - let uu___1 = - FStar_Compiler_List.fold_left - (fun uu___2 -> - fun b -> - match uu___2 with - | (ctx1, binders_rev, accus_rev) -> - let x1 = b.FStar_Syntax_Syntax.binder_bv in - let tnorm = - let uu___3 = - translate cfg ctx1 - x1.FStar_Syntax_Syntax.sort in - readback cfg uu___3 in - let x2 = - let uu___3 = FStar_Syntax_Syntax.freshen_bv x1 in - { - FStar_Syntax_Syntax.ppname = - (uu___3.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (uu___3.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = tnorm - } in - let ax = FStar_TypeChecker_NBETerm.mkAccuVar x2 in - let ctx2 = ax :: ctx1 in - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Syntax_Util.aqual_of_binder b in - (ax, uu___5) in - uu___4 :: accus_rev in - (ctx2, - ({ - FStar_Syntax_Syntax.binder_bv = x2; - FStar_Syntax_Syntax.binder_qual = - (b.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity = - (b.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs = - (b.FStar_Syntax_Syntax.binder_attrs) - } :: binders_rev), uu___3)) (ctx, [], []) - binders in - (match uu___1 with - | (ctx1, binders_rev, accus_rev) -> - let rc1 = - match rc with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some rc2 -> - let uu___2 = - let uu___3 = - translate_residual_comp cfg ctx1 rc2 in - readback_residual_comp cfg uu___3 in - FStar_Pervasives_Native.Some uu___2 in - let binders1 = FStar_Compiler_List.rev binders_rev in - let body = - let uu___2 = f accus_rev in readback cfg uu___2 in - let uu___2 = FStar_Syntax_Util.abs binders1 body rc1 in - with_range uu___2) - | FStar_TypeChecker_NBETerm.Lam_args args -> - let uu___1 = - FStar_Compiler_List.fold_right - (fun uu___2 -> - fun uu___3 -> - match (uu___2, uu___3) with - | ((t, aq), (binders, accus)) -> - let uu___4 = - FStar_Syntax_Util.bqual_and_attrs_of_aqual aq in - (match uu___4 with - | (bqual, battrs) -> - let uu___5 = - FStar_Syntax_Util.parse_positivity_attributes - battrs in - (match uu___5 with - | (pqual, battrs1) -> - let x1 = - let uu___6 = readback cfg t in - FStar_Syntax_Syntax.new_bv - FStar_Pervasives_Native.None - uu___6 in - let uu___6 = - let uu___7 = - FStar_Syntax_Syntax.mk_binder_with_attrs - x1 bqual pqual battrs1 in - uu___7 :: binders in - let uu___7 = - let uu___8 = - let uu___9 = - FStar_TypeChecker_NBETerm.mkAccuVar - x1 in - (uu___9, aq) in - uu___8 :: accus in - (uu___6, uu___7)))) args ([], []) in - (match uu___1 with - | (binders, accus_rev) -> - let accus = FStar_Compiler_List.rev accus_rev in - let rc = FStar_Pervasives_Native.None in - let body = - let uu___2 = f accus_rev in readback cfg uu___2 in - let uu___2 = FStar_Syntax_Util.abs binders body rc in - with_range uu___2) - | FStar_TypeChecker_NBETerm.Lam_primop (fv, args) -> - let body = - let uu___1 = - let uu___2 = FStar_Syntax_Syntax.range_of_fv fv in - FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_fvar fv) - uu___2 in - let uu___2 = readback_args cfg args in - FStar_Syntax_Util.mk_app uu___1 uu___2 in - with_range body) - | FStar_TypeChecker_NBETerm.Refinement (f, targ) -> - if - ((cfg.core_cfg).FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.for_extraction - then - let uu___1 = - let uu___2 = targ () in FStar_Pervasives_Native.fst uu___2 in - readback cfg uu___1 - else - (let x1 = - let uu___2 = - let uu___3 = - let uu___4 = targ () in - FStar_Pervasives_Native.fst uu___4 in - readback cfg uu___3 in - FStar_Syntax_Syntax.new_bv FStar_Pervasives_Native.None - uu___2 in - let body = - let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.mkAccuVar x1 in - f uu___3 in - readback cfg uu___2 in - let refinement = FStar_Syntax_Util.refine x1 body in - let uu___2 = - if - ((cfg.core_cfg).FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.simplify - then - FStar_TypeChecker_TermEqAndSimplify.simplify - ((cfg.core_cfg).FStar_TypeChecker_Cfg.debug).FStar_TypeChecker_Cfg.wpe - (cfg.core_cfg).FStar_TypeChecker_Cfg.tcenv refinement - else refinement in - with_range uu___2) - | FStar_TypeChecker_NBETerm.Reflect t -> - let tm = readback cfg t in - let uu___1 = FStar_Syntax_Util.mk_reflect tm in with_range uu___1 - | FStar_TypeChecker_NBETerm.Arrow (FStar_Pervasives.Inl f) -> - let uu___1 = FStar_Thunk.force f in with_range uu___1 - | FStar_TypeChecker_NBETerm.Arrow (FStar_Pervasives.Inr (args, c)) -> - let binders = - FStar_Compiler_List.map - (fun uu___1 -> - match uu___1 with - | (t, q) -> - let t1 = readback cfg t in - let x1 = - FStar_Syntax_Syntax.new_bv - FStar_Pervasives_Native.None t1 in - let uu___2 = - FStar_Syntax_Util.bqual_and_attrs_of_aqual q in - (match uu___2 with - | (q1, attrs) -> - let uu___3 = - FStar_Syntax_Util.parse_positivity_attributes - attrs in - (match uu___3 with - | (pqual, attrs1) -> - FStar_Syntax_Syntax.mk_binder_with_attrs x1 - q1 pqual attrs1))) args in - let c1 = readback_comp cfg c in - let uu___1 = FStar_Syntax_Util.arrow binders c1 in - with_range uu___1 - | FStar_TypeChecker_NBETerm.Construct (fv, us, args) -> - let args1 = - map_rev - (fun uu___1 -> - match uu___1 with - | (x1, q) -> let uu___2 = readback cfg x1 in (uu___2, q)) - args in - let fv1 = - let uu___1 = FStar_Syntax_Syntax.range_of_fv fv in - FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_fvar fv) uu___1 in - let app = - let uu___1 = - FStar_Syntax_Syntax.mk_Tm_uinst fv1 - (FStar_Compiler_List.rev us) in - FStar_Syntax_Util.mk_app uu___1 args1 in - with_range app - | FStar_TypeChecker_NBETerm.FV (fv, us, args) -> - let args1 = - map_rev - (fun uu___1 -> - match uu___1 with - | (x1, q) -> let uu___2 = readback cfg x1 in (uu___2, q)) - args in - let fv1 = - FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_fvar fv) - FStar_Compiler_Range_Type.dummyRange in - let app = - let uu___1 = - FStar_Syntax_Syntax.mk_Tm_uinst fv1 - (FStar_Compiler_List.rev us) in - FStar_Syntax_Util.mk_app uu___1 args1 in - let uu___1 = - if - ((cfg.core_cfg).FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.simplify - then - FStar_TypeChecker_TermEqAndSimplify.simplify - ((cfg.core_cfg).FStar_TypeChecker_Cfg.debug).FStar_TypeChecker_Cfg.wpe - (cfg.core_cfg).FStar_TypeChecker_Cfg.tcenv app - else app in - with_range uu___1 - | FStar_TypeChecker_NBETerm.Accu - (FStar_TypeChecker_NBETerm.Var bv, []) -> - let uu___1 = FStar_Syntax_Syntax.bv_to_name bv in - with_range uu___1 - | FStar_TypeChecker_NBETerm.Accu - (FStar_TypeChecker_NBETerm.Var bv, args) -> - let args1 = readback_args cfg args in - let app = - let uu___1 = FStar_Syntax_Syntax.bv_to_name bv in - FStar_Syntax_Util.mk_app uu___1 args1 in - let uu___1 = - if - ((cfg.core_cfg).FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.simplify - then - FStar_TypeChecker_TermEqAndSimplify.simplify - ((cfg.core_cfg).FStar_TypeChecker_Cfg.debug).FStar_TypeChecker_Cfg.wpe - (cfg.core_cfg).FStar_TypeChecker_Cfg.tcenv app - else app in - with_range uu___1 - | FStar_TypeChecker_NBETerm.Accu - (FStar_TypeChecker_NBETerm.Match - (scrut, make_returns, make_branches, make_rc), args) - -> - let args1 = readback_args cfg args in - let head = - let scrut_new = readback cfg scrut in - let returns_new = make_returns () in - let branches_new = make_branches () in - let rc_new = make_rc () in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_match - { - FStar_Syntax_Syntax.scrutinee = scrut_new; - FStar_Syntax_Syntax.ret_opt = returns_new; - FStar_Syntax_Syntax.brs = branches_new; - FStar_Syntax_Syntax.rc_opt1 = rc_new - }) scrut.FStar_TypeChecker_NBETerm.nbe_r in - let app = FStar_Syntax_Util.mk_app head args1 in - let uu___1 = - if - ((cfg.core_cfg).FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.simplify - then - FStar_TypeChecker_TermEqAndSimplify.simplify - ((cfg.core_cfg).FStar_TypeChecker_Cfg.debug).FStar_TypeChecker_Cfg.wpe - (cfg.core_cfg).FStar_TypeChecker_Cfg.tcenv app - else app in - with_range uu___1 - | FStar_TypeChecker_NBETerm.Accu - (FStar_TypeChecker_NBETerm.UnreducedLet - (var, typ, defn, body, lb), args) - -> - let typ1 = - let uu___1 = FStar_Thunk.force typ in readback cfg uu___1 in - let defn1 = - let uu___1 = FStar_Thunk.force defn in readback cfg uu___1 in - let body1 = - let uu___1 = - let uu___2 = FStar_Syntax_Syntax.mk_binder var in [uu___2] in - let uu___2 = - let uu___3 = FStar_Thunk.force body in readback cfg uu___3 in - FStar_Syntax_Subst.close uu___1 uu___2 in - let lbname = - let uu___1 = - let uu___2 = - FStar_Compiler_Util.left lb.FStar_Syntax_Syntax.lbname in - { - FStar_Syntax_Syntax.ppname = - (uu___2.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (uu___2.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = typ1 - } in - FStar_Pervasives.Inl uu___1 in - let lb1 = - { - FStar_Syntax_Syntax.lbname = lbname; - FStar_Syntax_Syntax.lbunivs = (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = typ1; - FStar_Syntax_Syntax.lbeff = (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = defn1; - FStar_Syntax_Syntax.lbattrs = (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = (lb.FStar_Syntax_Syntax.lbpos) - } in - let hd = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = (false, [lb1]); - FStar_Syntax_Syntax.body1 = body1 - }) FStar_Compiler_Range_Type.dummyRange in - let args1 = readback_args cfg args in - let uu___1 = FStar_Syntax_Util.mk_app hd args1 in - with_range uu___1 - | FStar_TypeChecker_NBETerm.Accu - (FStar_TypeChecker_NBETerm.UnreducedLetRec - (vars_typs_defns, body, lbs), args) - -> - let lbs1 = - FStar_Compiler_List.map2 - (fun uu___1 -> - fun lb -> - match uu___1 with - | (v, t, d) -> - let t1 = readback cfg t in - let def = readback cfg d in - let v1 = - { - FStar_Syntax_Syntax.ppname = - (v.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (v.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = t1 - } in - { - FStar_Syntax_Syntax.lbname = - (FStar_Pervasives.Inl v1); - FStar_Syntax_Syntax.lbunivs = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = t1; - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = def; - FStar_Syntax_Syntax.lbattrs = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - }) vars_typs_defns lbs in - let body1 = readback cfg body in - let uu___1 = FStar_Syntax_Subst.close_let_rec lbs1 body1 in - (match uu___1 with - | (lbs2, body2) -> - let hd = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = (true, lbs2); - FStar_Syntax_Syntax.body1 = body2 - }) FStar_Compiler_Range_Type.dummyRange in - let args1 = readback_args cfg args in - let uu___2 = FStar_Syntax_Util.mk_app hd args1 in - with_range uu___2) - | FStar_TypeChecker_NBETerm.Accu - (FStar_TypeChecker_NBETerm.UVar f, args) -> - let hd = FStar_Thunk.force f in - let args1 = readback_args cfg args in - let uu___1 = FStar_Syntax_Util.mk_app hd args1 in - with_range uu___1 - | FStar_TypeChecker_NBETerm.TopLevelLet (lb, arity, args_rev) -> - let n_univs = - FStar_Compiler_List.length lb.FStar_Syntax_Syntax.lbunivs in - let n_args = FStar_Compiler_List.length args_rev in - let uu___1 = - FStar_Compiler_Util.first_N (n_args - n_univs) args_rev in - (match uu___1 with - | (args_rev1, univs) -> - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Compiler_List.map FStar_Pervasives_Native.fst - univs in - translate cfg uu___4 lb.FStar_Syntax_Syntax.lbdef in - iapp cfg uu___3 (FStar_Compiler_List.rev args_rev1) in - readback cfg uu___2) - | FStar_TypeChecker_NBETerm.TopLevelRec (lb, uu___1, uu___2, args) -> - let fv = FStar_Compiler_Util.right lb.FStar_Syntax_Syntax.lbname in - let head = - FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_fvar fv) - FStar_Compiler_Range_Type.dummyRange in - let args1 = - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with - | (t, q) -> let uu___4 = readback cfg t in (uu___4, q)) - args in - let uu___3 = FStar_Syntax_Util.mk_app head args1 in - with_range uu___3 - | FStar_TypeChecker_NBETerm.LocalLetRec - (i, uu___1, lbs, bs, args, _ar, _ar_lst) -> - let lbnames = - FStar_Compiler_List.map - (fun lb -> - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Compiler_Util.left - lb.FStar_Syntax_Syntax.lbname in - uu___4.FStar_Syntax_Syntax.ppname in - FStar_Ident.string_of_id uu___3 in - FStar_Syntax_Syntax.gen_bv uu___2 - FStar_Pervasives_Native.None lb.FStar_Syntax_Syntax.lbtyp) - lbs in - let let_rec_env = - let uu___2 = - FStar_Compiler_List.map - (fun x1 -> - let uu___3 = FStar_Syntax_Syntax.range_of_bv x1 in - mk_rt uu___3 - (FStar_TypeChecker_NBETerm.Accu - ((FStar_TypeChecker_NBETerm.Var x1), []))) lbnames in - FStar_Compiler_List.rev_append uu___2 bs in - let lbs1 = - FStar_Compiler_List.map2 - (fun lb -> - fun lbname -> - let lbdef = - let uu___2 = - translate cfg let_rec_env - lb.FStar_Syntax_Syntax.lbdef in - readback cfg uu___2 in - let lbtyp = - let uu___2 = - translate cfg bs lb.FStar_Syntax_Syntax.lbtyp in - readback cfg uu___2 in - { - FStar_Syntax_Syntax.lbname = - (FStar_Pervasives.Inl lbname); - FStar_Syntax_Syntax.lbunivs = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = lbtyp; - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = lbdef; - FStar_Syntax_Syntax.lbattrs = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - }) lbs lbnames in - let body = - let uu___2 = FStar_Compiler_List.nth lbnames i in - FStar_Syntax_Syntax.bv_to_name uu___2 in - let uu___2 = FStar_Syntax_Subst.close_let_rec lbs1 body in - (match uu___2 with - | (lbs2, body1) -> - let head = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = (true, lbs2); - FStar_Syntax_Syntax.body1 = body1 - }) FStar_Compiler_Range_Type.dummyRange in - let args1 = - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with - | (x1, q) -> - let uu___4 = readback cfg x1 in (uu___4, q)) args in - let uu___3 = FStar_Syntax_Util.mk_app head args1 in - with_range uu___3) - | FStar_TypeChecker_NBETerm.Quote (qt, qi) -> - mk (FStar_Syntax_Syntax.Tm_quoted (qt, qi)) - | FStar_TypeChecker_NBETerm.Lazy (FStar_Pervasives.Inl li, uu___1) -> - mk (FStar_Syntax_Syntax.Tm_lazy li) - | FStar_TypeChecker_NBETerm.Lazy (uu___1, thunk) -> - let uu___2 = FStar_Thunk.force thunk in readback cfg uu___2) -let (reduce_application : - FStar_TypeChecker_Cfg.cfg -> - FStar_TypeChecker_NBETerm.t -> - FStar_TypeChecker_NBETerm.args -> FStar_TypeChecker_NBETerm.t) - = - fun cfg -> - fun t -> fun args -> let uu___ = new_config cfg in iapp uu___ t args -let (normalize : - FStar_TypeChecker_Primops_Base.primitive_step Prims.list -> - FStar_TypeChecker_Env.step Prims.list -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun psteps -> - fun steps -> - fun env -> - fun e -> - let cfg = FStar_TypeChecker_Cfg.config' psteps steps env in - let cfg1 = - { - FStar_TypeChecker_Cfg.steps = - (let uu___ = cfg.FStar_TypeChecker_Cfg.steps in - { - FStar_TypeChecker_Cfg.beta = - (uu___.FStar_TypeChecker_Cfg.beta); - FStar_TypeChecker_Cfg.iota = - (uu___.FStar_TypeChecker_Cfg.iota); - FStar_TypeChecker_Cfg.zeta = - (uu___.FStar_TypeChecker_Cfg.zeta); - FStar_TypeChecker_Cfg.zeta_full = - (uu___.FStar_TypeChecker_Cfg.zeta_full); - FStar_TypeChecker_Cfg.weak = - (uu___.FStar_TypeChecker_Cfg.weak); - FStar_TypeChecker_Cfg.hnf = - (uu___.FStar_TypeChecker_Cfg.hnf); - FStar_TypeChecker_Cfg.primops = - (uu___.FStar_TypeChecker_Cfg.primops); - FStar_TypeChecker_Cfg.do_not_unfold_pure_lets = - (uu___.FStar_TypeChecker_Cfg.do_not_unfold_pure_lets); - FStar_TypeChecker_Cfg.unfold_until = - (uu___.FStar_TypeChecker_Cfg.unfold_until); - FStar_TypeChecker_Cfg.unfold_only = - (uu___.FStar_TypeChecker_Cfg.unfold_only); - FStar_TypeChecker_Cfg.unfold_fully = - (uu___.FStar_TypeChecker_Cfg.unfold_fully); - FStar_TypeChecker_Cfg.unfold_attr = - (uu___.FStar_TypeChecker_Cfg.unfold_attr); - FStar_TypeChecker_Cfg.unfold_qual = - (uu___.FStar_TypeChecker_Cfg.unfold_qual); - FStar_TypeChecker_Cfg.unfold_namespace = - (uu___.FStar_TypeChecker_Cfg.unfold_namespace); - FStar_TypeChecker_Cfg.dont_unfold_attr = - (uu___.FStar_TypeChecker_Cfg.dont_unfold_attr); - FStar_TypeChecker_Cfg.pure_subterms_within_computations = - (uu___.FStar_TypeChecker_Cfg.pure_subterms_within_computations); - FStar_TypeChecker_Cfg.simplify = - (uu___.FStar_TypeChecker_Cfg.simplify); - FStar_TypeChecker_Cfg.erase_universes = - (uu___.FStar_TypeChecker_Cfg.erase_universes); - FStar_TypeChecker_Cfg.allow_unbound_universes = - (uu___.FStar_TypeChecker_Cfg.allow_unbound_universes); - FStar_TypeChecker_Cfg.reify_ = true; - FStar_TypeChecker_Cfg.compress_uvars = - (uu___.FStar_TypeChecker_Cfg.compress_uvars); - FStar_TypeChecker_Cfg.no_full_norm = - (uu___.FStar_TypeChecker_Cfg.no_full_norm); - FStar_TypeChecker_Cfg.check_no_uvars = - (uu___.FStar_TypeChecker_Cfg.check_no_uvars); - FStar_TypeChecker_Cfg.unmeta = - (uu___.FStar_TypeChecker_Cfg.unmeta); - FStar_TypeChecker_Cfg.unascribe = - (uu___.FStar_TypeChecker_Cfg.unascribe); - FStar_TypeChecker_Cfg.in_full_norm_request = - (uu___.FStar_TypeChecker_Cfg.in_full_norm_request); - FStar_TypeChecker_Cfg.weakly_reduce_scrutinee = - (uu___.FStar_TypeChecker_Cfg.weakly_reduce_scrutinee); - FStar_TypeChecker_Cfg.nbe_step = - (uu___.FStar_TypeChecker_Cfg.nbe_step); - FStar_TypeChecker_Cfg.for_extraction = - (uu___.FStar_TypeChecker_Cfg.for_extraction); - FStar_TypeChecker_Cfg.unrefine = - (uu___.FStar_TypeChecker_Cfg.unrefine); - FStar_TypeChecker_Cfg.default_univs_to_zero = - (uu___.FStar_TypeChecker_Cfg.default_univs_to_zero); - FStar_TypeChecker_Cfg.tactics = - (uu___.FStar_TypeChecker_Cfg.tactics) - }); - FStar_TypeChecker_Cfg.tcenv = (cfg.FStar_TypeChecker_Cfg.tcenv); - FStar_TypeChecker_Cfg.debug = (cfg.FStar_TypeChecker_Cfg.debug); - FStar_TypeChecker_Cfg.delta_level = - (cfg.FStar_TypeChecker_Cfg.delta_level); - FStar_TypeChecker_Cfg.primitive_steps = - (cfg.FStar_TypeChecker_Cfg.primitive_steps); - FStar_TypeChecker_Cfg.strong = - (cfg.FStar_TypeChecker_Cfg.strong); - FStar_TypeChecker_Cfg.memoize_lazy = - (cfg.FStar_TypeChecker_Cfg.memoize_lazy); - FStar_TypeChecker_Cfg.normalize_pure_lets = - (cfg.FStar_TypeChecker_Cfg.normalize_pure_lets); - FStar_TypeChecker_Cfg.reifying = - (cfg.FStar_TypeChecker_Cfg.reifying); - FStar_TypeChecker_Cfg.compat_memo_ignore_cfg = - (cfg.FStar_TypeChecker_Cfg.compat_memo_ignore_cfg) - } in - (let uu___1 = - (FStar_Compiler_Effect.op_Bang dbg_NBETop) || - (FStar_Compiler_Effect.op_Bang dbg_NBE) in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - FStar_Compiler_Util.print1 "Calling NBE with (%s) {\n" uu___2 - else ()); - (let cfg2 = new_config cfg1 in - let r = let uu___1 = translate cfg2 [] e in readback cfg2 uu___1 in - (let uu___2 = - (FStar_Compiler_Effect.op_Bang dbg_NBETop) || - (FStar_Compiler_Effect.op_Bang dbg_NBE) in - if uu___2 - then - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term r in - FStar_Compiler_Util.print1 "}\nNBE returned (%s)\n" uu___3 - else ()); - r) -let (normalize_for_unit_test : - FStar_TypeChecker_Env.step Prims.list -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun steps -> - fun env -> - fun e -> - let cfg = FStar_TypeChecker_Cfg.config steps env in - let cfg1 = - { - FStar_TypeChecker_Cfg.steps = - (let uu___ = cfg.FStar_TypeChecker_Cfg.steps in - { - FStar_TypeChecker_Cfg.beta = - (uu___.FStar_TypeChecker_Cfg.beta); - FStar_TypeChecker_Cfg.iota = - (uu___.FStar_TypeChecker_Cfg.iota); - FStar_TypeChecker_Cfg.zeta = - (uu___.FStar_TypeChecker_Cfg.zeta); - FStar_TypeChecker_Cfg.zeta_full = - (uu___.FStar_TypeChecker_Cfg.zeta_full); - FStar_TypeChecker_Cfg.weak = - (uu___.FStar_TypeChecker_Cfg.weak); - FStar_TypeChecker_Cfg.hnf = - (uu___.FStar_TypeChecker_Cfg.hnf); - FStar_TypeChecker_Cfg.primops = - (uu___.FStar_TypeChecker_Cfg.primops); - FStar_TypeChecker_Cfg.do_not_unfold_pure_lets = - (uu___.FStar_TypeChecker_Cfg.do_not_unfold_pure_lets); - FStar_TypeChecker_Cfg.unfold_until = - (uu___.FStar_TypeChecker_Cfg.unfold_until); - FStar_TypeChecker_Cfg.unfold_only = - (uu___.FStar_TypeChecker_Cfg.unfold_only); - FStar_TypeChecker_Cfg.unfold_fully = - (uu___.FStar_TypeChecker_Cfg.unfold_fully); - FStar_TypeChecker_Cfg.unfold_attr = - (uu___.FStar_TypeChecker_Cfg.unfold_attr); - FStar_TypeChecker_Cfg.unfold_qual = - (uu___.FStar_TypeChecker_Cfg.unfold_qual); - FStar_TypeChecker_Cfg.unfold_namespace = - (uu___.FStar_TypeChecker_Cfg.unfold_namespace); - FStar_TypeChecker_Cfg.dont_unfold_attr = - (uu___.FStar_TypeChecker_Cfg.dont_unfold_attr); - FStar_TypeChecker_Cfg.pure_subterms_within_computations = - (uu___.FStar_TypeChecker_Cfg.pure_subterms_within_computations); - FStar_TypeChecker_Cfg.simplify = - (uu___.FStar_TypeChecker_Cfg.simplify); - FStar_TypeChecker_Cfg.erase_universes = - (uu___.FStar_TypeChecker_Cfg.erase_universes); - FStar_TypeChecker_Cfg.allow_unbound_universes = - (uu___.FStar_TypeChecker_Cfg.allow_unbound_universes); - FStar_TypeChecker_Cfg.reify_ = true; - FStar_TypeChecker_Cfg.compress_uvars = - (uu___.FStar_TypeChecker_Cfg.compress_uvars); - FStar_TypeChecker_Cfg.no_full_norm = - (uu___.FStar_TypeChecker_Cfg.no_full_norm); - FStar_TypeChecker_Cfg.check_no_uvars = - (uu___.FStar_TypeChecker_Cfg.check_no_uvars); - FStar_TypeChecker_Cfg.unmeta = - (uu___.FStar_TypeChecker_Cfg.unmeta); - FStar_TypeChecker_Cfg.unascribe = - (uu___.FStar_TypeChecker_Cfg.unascribe); - FStar_TypeChecker_Cfg.in_full_norm_request = - (uu___.FStar_TypeChecker_Cfg.in_full_norm_request); - FStar_TypeChecker_Cfg.weakly_reduce_scrutinee = - (uu___.FStar_TypeChecker_Cfg.weakly_reduce_scrutinee); - FStar_TypeChecker_Cfg.nbe_step = - (uu___.FStar_TypeChecker_Cfg.nbe_step); - FStar_TypeChecker_Cfg.for_extraction = - (uu___.FStar_TypeChecker_Cfg.for_extraction); - FStar_TypeChecker_Cfg.unrefine = - (uu___.FStar_TypeChecker_Cfg.unrefine); - FStar_TypeChecker_Cfg.default_univs_to_zero = - (uu___.FStar_TypeChecker_Cfg.default_univs_to_zero); - FStar_TypeChecker_Cfg.tactics = - (uu___.FStar_TypeChecker_Cfg.tactics) - }); - FStar_TypeChecker_Cfg.tcenv = (cfg.FStar_TypeChecker_Cfg.tcenv); - FStar_TypeChecker_Cfg.debug = (cfg.FStar_TypeChecker_Cfg.debug); - FStar_TypeChecker_Cfg.delta_level = - (cfg.FStar_TypeChecker_Cfg.delta_level); - FStar_TypeChecker_Cfg.primitive_steps = - (cfg.FStar_TypeChecker_Cfg.primitive_steps); - FStar_TypeChecker_Cfg.strong = (cfg.FStar_TypeChecker_Cfg.strong); - FStar_TypeChecker_Cfg.memoize_lazy = - (cfg.FStar_TypeChecker_Cfg.memoize_lazy); - FStar_TypeChecker_Cfg.normalize_pure_lets = - (cfg.FStar_TypeChecker_Cfg.normalize_pure_lets); - FStar_TypeChecker_Cfg.reifying = - (cfg.FStar_TypeChecker_Cfg.reifying); - FStar_TypeChecker_Cfg.compat_memo_ignore_cfg = - (cfg.FStar_TypeChecker_Cfg.compat_memo_ignore_cfg) - } in - let cfg2 = new_config cfg1 in - debug cfg2 - (fun uu___1 -> - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - FStar_Compiler_Util.print1 "Calling NBE with (%s) {\n" uu___2); - (let r = let uu___1 = translate cfg2 [] e in readback cfg2 uu___1 in - debug cfg2 - (fun uu___2 -> - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term r in - FStar_Compiler_Util.print1 "}\nNBE returned (%s)\n" uu___3); - r) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_NBETerm.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_NBETerm.ml deleted file mode 100644 index 911d7791743..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_NBETerm.ml +++ /dev/null @@ -1,2528 +0,0 @@ -open Prims -let (interleave_hack : Prims.int) = (Prims.of_int (123)) -type var = FStar_Syntax_Syntax.bv -type sort = Prims.int -type constant = - | Unit - | Bool of Prims.bool - | Int of FStar_BigInt.t - | String of (Prims.string * FStar_Compiler_Range_Type.range) - | Char of FStar_Char.char - | Range of FStar_Compiler_Range_Type.range - | SConst of FStar_Const.sconst - | Real of Prims.string -let (uu___is_Unit : constant -> Prims.bool) = - fun projectee -> match projectee with | Unit -> true | uu___ -> false -let (uu___is_Bool : constant -> Prims.bool) = - fun projectee -> match projectee with | Bool _0 -> true | uu___ -> false -let (__proj__Bool__item___0 : constant -> Prims.bool) = - fun projectee -> match projectee with | Bool _0 -> _0 -let (uu___is_Int : constant -> Prims.bool) = - fun projectee -> match projectee with | Int _0 -> true | uu___ -> false -let (__proj__Int__item___0 : constant -> FStar_BigInt.t) = - fun projectee -> match projectee with | Int _0 -> _0 -let (uu___is_String : constant -> Prims.bool) = - fun projectee -> match projectee with | String _0 -> true | uu___ -> false -let (__proj__String__item___0 : - constant -> (Prims.string * FStar_Compiler_Range_Type.range)) = - fun projectee -> match projectee with | String _0 -> _0 -let (uu___is_Char : constant -> Prims.bool) = - fun projectee -> match projectee with | Char _0 -> true | uu___ -> false -let (__proj__Char__item___0 : constant -> FStar_Char.char) = - fun projectee -> match projectee with | Char _0 -> _0 -let (uu___is_Range : constant -> Prims.bool) = - fun projectee -> match projectee with | Range _0 -> true | uu___ -> false -let (__proj__Range__item___0 : constant -> FStar_Compiler_Range_Type.range) = - fun projectee -> match projectee with | Range _0 -> _0 -let (uu___is_SConst : constant -> Prims.bool) = - fun projectee -> match projectee with | SConst _0 -> true | uu___ -> false -let (__proj__SConst__item___0 : constant -> FStar_Const.sconst) = - fun projectee -> match projectee with | SConst _0 -> _0 -let (uu___is_Real : constant -> Prims.bool) = - fun projectee -> match projectee with | Real _0 -> true | uu___ -> false -let (__proj__Real__item___0 : constant -> Prims.string) = - fun projectee -> match projectee with | Real _0 -> _0 -type atom = - | Var of var - | Match of (t * - (unit -> - FStar_Syntax_Syntax.match_returns_ascription - FStar_Pervasives_Native.option) - * (unit -> FStar_Syntax_Syntax.branch Prims.list) * - (unit -> FStar_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option)) - - | UnreducedLet of (var * t FStar_Thunk.t * t FStar_Thunk.t * t - FStar_Thunk.t * FStar_Syntax_Syntax.letbinding) - | UnreducedLetRec of ((var * t * t) Prims.list * t * - FStar_Syntax_Syntax.letbinding Prims.list) - | UVar of FStar_Syntax_Syntax.term FStar_Thunk.t -and lam_shape = - | Lam_bs of (t Prims.list * FStar_Syntax_Syntax.binders * - FStar_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option) - | Lam_args of (t * FStar_Syntax_Syntax.aqual) Prims.list - | Lam_primop of (FStar_Syntax_Syntax.fv * (t * FStar_Syntax_Syntax.aqual) - Prims.list) -and t'__Lam__payload = - { - interp: (t * FStar_Syntax_Syntax.aqual) Prims.list -> t ; - shape: lam_shape ; - arity: Prims.int } -and t' = - | Lam of t'__Lam__payload - | Accu of (atom * (t * FStar_Syntax_Syntax.aqual) Prims.list) - | Construct of (FStar_Syntax_Syntax.fv * FStar_Syntax_Syntax.universe - Prims.list * (t * FStar_Syntax_Syntax.aqual) Prims.list) - | FV of (FStar_Syntax_Syntax.fv * FStar_Syntax_Syntax.universe Prims.list * - (t * FStar_Syntax_Syntax.aqual) Prims.list) - | Constant of constant - | Type_t of FStar_Syntax_Syntax.universe - | Univ of FStar_Syntax_Syntax.universe - | Unknown - | Arrow of (FStar_Syntax_Syntax.term FStar_Thunk.t, - ((t * FStar_Syntax_Syntax.aqual) Prims.list * comp)) - FStar_Pervasives.either - | Refinement of ((t -> t) * (unit -> (t * FStar_Syntax_Syntax.aqual))) - | Reflect of t - | Quote of (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.quoteinfo) - | Lazy of ((FStar_Syntax_Syntax.lazyinfo, - (FStar_Dyn.dyn * FStar_Syntax_Syntax.emb_typ)) FStar_Pervasives.either * t - FStar_Thunk.t) - | Meta of (t * FStar_Syntax_Syntax.metadata FStar_Thunk.t) - | TopLevelLet of (FStar_Syntax_Syntax.letbinding * Prims.int * (t * - FStar_Syntax_Syntax.aqual) Prims.list) - | TopLevelRec of (FStar_Syntax_Syntax.letbinding * Prims.int * Prims.bool - Prims.list * (t * FStar_Syntax_Syntax.aqual) Prims.list) - | LocalLetRec of (Prims.int * FStar_Syntax_Syntax.letbinding * - FStar_Syntax_Syntax.letbinding Prims.list * t Prims.list * (t * - FStar_Syntax_Syntax.aqual) Prims.list * Prims.int * Prims.bool Prims.list) -and t = { - nbe_t: t' ; - nbe_r: FStar_Compiler_Range_Type.range } -and comp = - | Tot of t - | GTot of t - | Comp of comp_typ -and comp_typ = - { - comp_univs: FStar_Syntax_Syntax.universes ; - effect_name: FStar_Ident.lident ; - result_typ: t ; - effect_args: (t * FStar_Syntax_Syntax.aqual) Prims.list ; - flags: cflag Prims.list } -and residual_comp = - { - residual_effect: FStar_Ident.lident ; - residual_typ: t FStar_Pervasives_Native.option ; - residual_flags: cflag Prims.list } -and cflag = - | TOTAL - | MLEFFECT - | RETURN - | PARTIAL_RETURN - | SOMETRIVIAL - | TRIVIAL_POSTCONDITION - | SHOULD_NOT_INLINE - | LEMMA - | CPS - | DECREASES_lex of t Prims.list - | DECREASES_wf of (t * t) -let (uu___is_Var : atom -> Prims.bool) = - fun projectee -> match projectee with | Var _0 -> true | uu___ -> false -let (__proj__Var__item___0 : atom -> var) = - fun projectee -> match projectee with | Var _0 -> _0 -let (uu___is_Match : atom -> Prims.bool) = - fun projectee -> match projectee with | Match _0 -> true | uu___ -> false -let (__proj__Match__item___0 : - atom -> - (t * - (unit -> - FStar_Syntax_Syntax.match_returns_ascription - FStar_Pervasives_Native.option) - * (unit -> FStar_Syntax_Syntax.branch Prims.list) * - (unit -> - FStar_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option))) - = fun projectee -> match projectee with | Match _0 -> _0 -let (uu___is_UnreducedLet : atom -> Prims.bool) = - fun projectee -> - match projectee with | UnreducedLet _0 -> true | uu___ -> false -let (__proj__UnreducedLet__item___0 : - atom -> - (var * t FStar_Thunk.t * t FStar_Thunk.t * t FStar_Thunk.t * - FStar_Syntax_Syntax.letbinding)) - = fun projectee -> match projectee with | UnreducedLet _0 -> _0 -let (uu___is_UnreducedLetRec : atom -> Prims.bool) = - fun projectee -> - match projectee with | UnreducedLetRec _0 -> true | uu___ -> false -let (__proj__UnreducedLetRec__item___0 : - atom -> - ((var * t * t) Prims.list * t * FStar_Syntax_Syntax.letbinding - Prims.list)) - = fun projectee -> match projectee with | UnreducedLetRec _0 -> _0 -let (uu___is_UVar : atom -> Prims.bool) = - fun projectee -> match projectee with | UVar _0 -> true | uu___ -> false -let (__proj__UVar__item___0 : atom -> FStar_Syntax_Syntax.term FStar_Thunk.t) - = fun projectee -> match projectee with | UVar _0 -> _0 -let (uu___is_Lam_bs : lam_shape -> Prims.bool) = - fun projectee -> match projectee with | Lam_bs _0 -> true | uu___ -> false -let (__proj__Lam_bs__item___0 : - lam_shape -> - (t Prims.list * FStar_Syntax_Syntax.binders * - FStar_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option)) - = fun projectee -> match projectee with | Lam_bs _0 -> _0 -let (uu___is_Lam_args : lam_shape -> Prims.bool) = - fun projectee -> - match projectee with | Lam_args _0 -> true | uu___ -> false -let (__proj__Lam_args__item___0 : - lam_shape -> (t * FStar_Syntax_Syntax.aqual) Prims.list) = - fun projectee -> match projectee with | Lam_args _0 -> _0 -let (uu___is_Lam_primop : lam_shape -> Prims.bool) = - fun projectee -> - match projectee with | Lam_primop _0 -> true | uu___ -> false -let (__proj__Lam_primop__item___0 : - lam_shape -> - (FStar_Syntax_Syntax.fv * (t * FStar_Syntax_Syntax.aqual) Prims.list)) - = fun projectee -> match projectee with | Lam_primop _0 -> _0 -let (__proj__Mkt'__Lam__payload__item__interp : - t'__Lam__payload -> (t * FStar_Syntax_Syntax.aqual) Prims.list -> t) = - fun projectee -> match projectee with | { interp; shape; arity;_} -> interp -let (__proj__Mkt'__Lam__payload__item__shape : t'__Lam__payload -> lam_shape) - = - fun projectee -> match projectee with | { interp; shape; arity;_} -> shape -let (__proj__Mkt'__Lam__payload__item__arity : t'__Lam__payload -> Prims.int) - = - fun projectee -> match projectee with | { interp; shape; arity;_} -> arity -let (uu___is_Lam : t' -> Prims.bool) = - fun projectee -> match projectee with | Lam _0 -> true | uu___ -> false -let (__proj__Lam__item___0 : t' -> t'__Lam__payload) = - fun projectee -> match projectee with | Lam _0 -> _0 -let (uu___is_Accu : t' -> Prims.bool) = - fun projectee -> match projectee with | Accu _0 -> true | uu___ -> false -let (__proj__Accu__item___0 : - t' -> (atom * (t * FStar_Syntax_Syntax.aqual) Prims.list)) = - fun projectee -> match projectee with | Accu _0 -> _0 -let (uu___is_Construct : t' -> Prims.bool) = - fun projectee -> - match projectee with | Construct _0 -> true | uu___ -> false -let (__proj__Construct__item___0 : - t' -> - (FStar_Syntax_Syntax.fv * FStar_Syntax_Syntax.universe Prims.list * (t * - FStar_Syntax_Syntax.aqual) Prims.list)) - = fun projectee -> match projectee with | Construct _0 -> _0 -let (uu___is_FV : t' -> Prims.bool) = - fun projectee -> match projectee with | FV _0 -> true | uu___ -> false -let (__proj__FV__item___0 : - t' -> - (FStar_Syntax_Syntax.fv * FStar_Syntax_Syntax.universe Prims.list * (t * - FStar_Syntax_Syntax.aqual) Prims.list)) - = fun projectee -> match projectee with | FV _0 -> _0 -let (uu___is_Constant : t' -> Prims.bool) = - fun projectee -> - match projectee with | Constant _0 -> true | uu___ -> false -let (__proj__Constant__item___0 : t' -> constant) = - fun projectee -> match projectee with | Constant _0 -> _0 -let (uu___is_Type_t : t' -> Prims.bool) = - fun projectee -> match projectee with | Type_t _0 -> true | uu___ -> false -let (__proj__Type_t__item___0 : t' -> FStar_Syntax_Syntax.universe) = - fun projectee -> match projectee with | Type_t _0 -> _0 -let (uu___is_Univ : t' -> Prims.bool) = - fun projectee -> match projectee with | Univ _0 -> true | uu___ -> false -let (__proj__Univ__item___0 : t' -> FStar_Syntax_Syntax.universe) = - fun projectee -> match projectee with | Univ _0 -> _0 -let (uu___is_Unknown : t' -> Prims.bool) = - fun projectee -> match projectee with | Unknown -> true | uu___ -> false -let (uu___is_Arrow : t' -> Prims.bool) = - fun projectee -> match projectee with | Arrow _0 -> true | uu___ -> false -let (__proj__Arrow__item___0 : - t' -> - (FStar_Syntax_Syntax.term FStar_Thunk.t, - ((t * FStar_Syntax_Syntax.aqual) Prims.list * comp)) - FStar_Pervasives.either) - = fun projectee -> match projectee with | Arrow _0 -> _0 -let (uu___is_Refinement : t' -> Prims.bool) = - fun projectee -> - match projectee with | Refinement _0 -> true | uu___ -> false -let (__proj__Refinement__item___0 : - t' -> ((t -> t) * (unit -> (t * FStar_Syntax_Syntax.aqual)))) = - fun projectee -> match projectee with | Refinement _0 -> _0 -let (uu___is_Reflect : t' -> Prims.bool) = - fun projectee -> match projectee with | Reflect _0 -> true | uu___ -> false -let (__proj__Reflect__item___0 : t' -> t) = - fun projectee -> match projectee with | Reflect _0 -> _0 -let (uu___is_Quote : t' -> Prims.bool) = - fun projectee -> match projectee with | Quote _0 -> true | uu___ -> false -let (__proj__Quote__item___0 : - t' -> (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.quoteinfo)) = - fun projectee -> match projectee with | Quote _0 -> _0 -let (uu___is_Lazy : t' -> Prims.bool) = - fun projectee -> match projectee with | Lazy _0 -> true | uu___ -> false -let (__proj__Lazy__item___0 : - t' -> - ((FStar_Syntax_Syntax.lazyinfo, - (FStar_Dyn.dyn * FStar_Syntax_Syntax.emb_typ)) FStar_Pervasives.either - * t FStar_Thunk.t)) - = fun projectee -> match projectee with | Lazy _0 -> _0 -let (uu___is_Meta : t' -> Prims.bool) = - fun projectee -> match projectee with | Meta _0 -> true | uu___ -> false -let (__proj__Meta__item___0 : - t' -> (t * FStar_Syntax_Syntax.metadata FStar_Thunk.t)) = - fun projectee -> match projectee with | Meta _0 -> _0 -let (uu___is_TopLevelLet : t' -> Prims.bool) = - fun projectee -> - match projectee with | TopLevelLet _0 -> true | uu___ -> false -let (__proj__TopLevelLet__item___0 : - t' -> - (FStar_Syntax_Syntax.letbinding * Prims.int * (t * - FStar_Syntax_Syntax.aqual) Prims.list)) - = fun projectee -> match projectee with | TopLevelLet _0 -> _0 -let (uu___is_TopLevelRec : t' -> Prims.bool) = - fun projectee -> - match projectee with | TopLevelRec _0 -> true | uu___ -> false -let (__proj__TopLevelRec__item___0 : - t' -> - (FStar_Syntax_Syntax.letbinding * Prims.int * Prims.bool Prims.list * (t - * FStar_Syntax_Syntax.aqual) Prims.list)) - = fun projectee -> match projectee with | TopLevelRec _0 -> _0 -let (uu___is_LocalLetRec : t' -> Prims.bool) = - fun projectee -> - match projectee with | LocalLetRec _0 -> true | uu___ -> false -let (__proj__LocalLetRec__item___0 : - t' -> - (Prims.int * FStar_Syntax_Syntax.letbinding * - FStar_Syntax_Syntax.letbinding Prims.list * t Prims.list * (t * - FStar_Syntax_Syntax.aqual) Prims.list * Prims.int * Prims.bool - Prims.list)) - = fun projectee -> match projectee with | LocalLetRec _0 -> _0 -let (__proj__Mkt__item__nbe_t : t -> t') = - fun projectee -> match projectee with | { nbe_t; nbe_r;_} -> nbe_t -let (__proj__Mkt__item__nbe_r : t -> FStar_Compiler_Range_Type.range) = - fun projectee -> match projectee with | { nbe_t; nbe_r;_} -> nbe_r -let (uu___is_Tot : comp -> Prims.bool) = - fun projectee -> match projectee with | Tot _0 -> true | uu___ -> false -let (__proj__Tot__item___0 : comp -> t) = - fun projectee -> match projectee with | Tot _0 -> _0 -let (uu___is_GTot : comp -> Prims.bool) = - fun projectee -> match projectee with | GTot _0 -> true | uu___ -> false -let (__proj__GTot__item___0 : comp -> t) = - fun projectee -> match projectee with | GTot _0 -> _0 -let (uu___is_Comp : comp -> Prims.bool) = - fun projectee -> match projectee with | Comp _0 -> true | uu___ -> false -let (__proj__Comp__item___0 : comp -> comp_typ) = - fun projectee -> match projectee with | Comp _0 -> _0 -let (__proj__Mkcomp_typ__item__comp_univs : - comp_typ -> FStar_Syntax_Syntax.universes) = - fun projectee -> - match projectee with - | { comp_univs; effect_name; result_typ; effect_args; flags;_} -> - comp_univs -let (__proj__Mkcomp_typ__item__effect_name : comp_typ -> FStar_Ident.lident) - = - fun projectee -> - match projectee with - | { comp_univs; effect_name; result_typ; effect_args; flags;_} -> - effect_name -let (__proj__Mkcomp_typ__item__result_typ : comp_typ -> t) = - fun projectee -> - match projectee with - | { comp_univs; effect_name; result_typ; effect_args; flags;_} -> - result_typ -let (__proj__Mkcomp_typ__item__effect_args : - comp_typ -> (t * FStar_Syntax_Syntax.aqual) Prims.list) = - fun projectee -> - match projectee with - | { comp_univs; effect_name; result_typ; effect_args; flags;_} -> - effect_args -let (__proj__Mkcomp_typ__item__flags : comp_typ -> cflag Prims.list) = - fun projectee -> - match projectee with - | { comp_univs; effect_name; result_typ; effect_args; flags;_} -> flags -let (__proj__Mkresidual_comp__item__residual_effect : - residual_comp -> FStar_Ident.lident) = - fun projectee -> - match projectee with - | { residual_effect; residual_typ; residual_flags;_} -> residual_effect -let (__proj__Mkresidual_comp__item__residual_typ : - residual_comp -> t FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { residual_effect; residual_typ; residual_flags;_} -> residual_typ -let (__proj__Mkresidual_comp__item__residual_flags : - residual_comp -> cflag Prims.list) = - fun projectee -> - match projectee with - | { residual_effect; residual_typ; residual_flags;_} -> residual_flags -let (uu___is_TOTAL : cflag -> Prims.bool) = - fun projectee -> match projectee with | TOTAL -> true | uu___ -> false -let (uu___is_MLEFFECT : cflag -> Prims.bool) = - fun projectee -> match projectee with | MLEFFECT -> true | uu___ -> false -let (uu___is_RETURN : cflag -> Prims.bool) = - fun projectee -> match projectee with | RETURN -> true | uu___ -> false -let (uu___is_PARTIAL_RETURN : cflag -> Prims.bool) = - fun projectee -> - match projectee with | PARTIAL_RETURN -> true | uu___ -> false -let (uu___is_SOMETRIVIAL : cflag -> Prims.bool) = - fun projectee -> - match projectee with | SOMETRIVIAL -> true | uu___ -> false -let (uu___is_TRIVIAL_POSTCONDITION : cflag -> Prims.bool) = - fun projectee -> - match projectee with | TRIVIAL_POSTCONDITION -> true | uu___ -> false -let (uu___is_SHOULD_NOT_INLINE : cflag -> Prims.bool) = - fun projectee -> - match projectee with | SHOULD_NOT_INLINE -> true | uu___ -> false -let (uu___is_LEMMA : cflag -> Prims.bool) = - fun projectee -> match projectee with | LEMMA -> true | uu___ -> false -let (uu___is_CPS : cflag -> Prims.bool) = - fun projectee -> match projectee with | CPS -> true | uu___ -> false -let (uu___is_DECREASES_lex : cflag -> Prims.bool) = - fun projectee -> - match projectee with | DECREASES_lex _0 -> true | uu___ -> false -let (__proj__DECREASES_lex__item___0 : cflag -> t Prims.list) = - fun projectee -> match projectee with | DECREASES_lex _0 -> _0 -let (uu___is_DECREASES_wf : cflag -> Prims.bool) = - fun projectee -> - match projectee with | DECREASES_wf _0 -> true | uu___ -> false -let (__proj__DECREASES_wf__item___0 : cflag -> (t * t)) = - fun projectee -> match projectee with | DECREASES_wf _0 -> _0 -type arg = (t * FStar_Syntax_Syntax.aqual) -type args = (t * FStar_Syntax_Syntax.aqual) Prims.list -let (isAccu : t -> Prims.bool) = - fun trm -> match trm.nbe_t with | Accu uu___ -> true | uu___ -> false -let (isNotAccu : t -> Prims.bool) = - fun x -> match x.nbe_t with | Accu (uu___, uu___1) -> false | uu___ -> true -let (mk_rt : FStar_Compiler_Range_Type.range -> t' -> t) = - fun r -> fun t1 -> { nbe_t = t1; nbe_r = r } -let (mk_t : t' -> t) = - fun t1 -> mk_rt FStar_Compiler_Range_Type.dummyRange t1 -let (nbe_t_of_t : t -> t') = fun t1 -> t1.nbe_t -let (mkConstruct : - FStar_Syntax_Syntax.fv -> - FStar_Syntax_Syntax.universe Prims.list -> args -> t) - = fun i -> fun us -> fun ts -> mk_t (Construct (i, us, ts)) -let (mkFV : - FStar_Syntax_Syntax.fv -> - FStar_Syntax_Syntax.universe Prims.list -> args -> t) - = - fun i -> - fun us -> - fun ts -> - let uu___ = FStar_Syntax_Syntax.range_of_fv i in - mk_rt uu___ (FV (i, us, ts)) -let (mkAccuVar : var -> t) = - fun v -> - let uu___ = FStar_Syntax_Syntax.range_of_bv v in - mk_rt uu___ (Accu ((Var v), [])) -let (mkAccuMatch : - t -> - (unit -> - FStar_Syntax_Syntax.match_returns_ascription - FStar_Pervasives_Native.option) - -> - (unit -> FStar_Syntax_Syntax.branch Prims.list) -> - (unit -> - FStar_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option) - -> t) - = - fun s -> - fun ret -> fun bs -> fun rc -> mk_t (Accu ((Match (s, ret, bs, rc)), [])) -let (equal_if : Prims.bool -> FStar_TypeChecker_TermEqAndSimplify.eq_result) - = - fun uu___ -> - if uu___ - then FStar_TypeChecker_TermEqAndSimplify.Equal - else FStar_TypeChecker_TermEqAndSimplify.Unknown -let (equal_iff : Prims.bool -> FStar_TypeChecker_TermEqAndSimplify.eq_result) - = - fun uu___ -> - if uu___ - then FStar_TypeChecker_TermEqAndSimplify.Equal - else FStar_TypeChecker_TermEqAndSimplify.NotEqual -let (eq_inj : - FStar_TypeChecker_TermEqAndSimplify.eq_result -> - FStar_TypeChecker_TermEqAndSimplify.eq_result -> - FStar_TypeChecker_TermEqAndSimplify.eq_result) - = - fun r1 -> - fun r2 -> - match (r1, r2) with - | (FStar_TypeChecker_TermEqAndSimplify.Equal, - FStar_TypeChecker_TermEqAndSimplify.Equal) -> - FStar_TypeChecker_TermEqAndSimplify.Equal - | (FStar_TypeChecker_TermEqAndSimplify.NotEqual, uu___) -> - FStar_TypeChecker_TermEqAndSimplify.NotEqual - | (uu___, FStar_TypeChecker_TermEqAndSimplify.NotEqual) -> - FStar_TypeChecker_TermEqAndSimplify.NotEqual - | (FStar_TypeChecker_TermEqAndSimplify.Unknown, uu___) -> - FStar_TypeChecker_TermEqAndSimplify.Unknown - | (uu___, FStar_TypeChecker_TermEqAndSimplify.Unknown) -> - FStar_TypeChecker_TermEqAndSimplify.Unknown -let (eq_and : - FStar_TypeChecker_TermEqAndSimplify.eq_result -> - (unit -> FStar_TypeChecker_TermEqAndSimplify.eq_result) -> - FStar_TypeChecker_TermEqAndSimplify.eq_result) - = - fun f -> - fun g -> - match f with - | FStar_TypeChecker_TermEqAndSimplify.Equal -> g () - | uu___ -> FStar_TypeChecker_TermEqAndSimplify.Unknown -let (eq_constant : - constant -> constant -> FStar_TypeChecker_TermEqAndSimplify.eq_result) = - fun c1 -> - fun c2 -> - match (c1, c2) with - | (Unit, Unit) -> FStar_TypeChecker_TermEqAndSimplify.Equal - | (Bool b1, Bool b2) -> equal_iff (b1 = b2) - | (Int i1, Int i2) -> equal_iff (i1 = i2) - | (String (s1, uu___), String (s2, uu___1)) -> equal_iff (s1 = s2) - | (Char c11, Char c21) -> equal_iff (c11 = c21) - | (Range r1, Range r2) -> FStar_TypeChecker_TermEqAndSimplify.Unknown - | (Real r1, Real r2) -> equal_if (r1 = r2) - | (uu___, uu___1) -> FStar_TypeChecker_TermEqAndSimplify.NotEqual -let rec (eq_t : - FStar_TypeChecker_Env.env_t -> - t -> t -> FStar_TypeChecker_TermEqAndSimplify.eq_result) - = - fun env -> - fun t1 -> - fun t2 -> - match ((t1.nbe_t), (t2.nbe_t)) with - | (Lam uu___, Lam uu___1) -> - FStar_TypeChecker_TermEqAndSimplify.Unknown - | (Accu (a1, as1), Accu (a2, as2)) -> - let uu___ = eq_atom a1 a2 in - eq_and uu___ (fun uu___1 -> eq_args env as1 as2) - | (Construct (v1, us1, args1), Construct (v2, us2, args2)) -> - let uu___ = FStar_Syntax_Syntax.fv_eq v1 v2 in - if uu___ - then - (if - (FStar_Compiler_List.length args1) <> - (FStar_Compiler_List.length args2) - then failwith "eq_t, different number of args on Construct" - else (); - (let uu___2 = - let uu___3 = FStar_Syntax_Syntax.lid_of_fv v1 in - FStar_TypeChecker_Env.num_datacon_non_injective_ty_params - env uu___3 in - match uu___2 with - | FStar_Pervasives_Native.None -> - FStar_TypeChecker_TermEqAndSimplify.Unknown - | FStar_Pervasives_Native.Some n -> - if n <= (FStar_Compiler_List.length args1) - then - let eq_args1 as1 as2 = - FStar_Compiler_List.fold_left2 - (fun acc -> - fun uu___3 -> - fun uu___4 -> - match (uu___3, uu___4) with - | ((a1, uu___5), (a2, uu___6)) -> - let uu___7 = eq_t env a1 a2 in - eq_inj acc uu___7) - FStar_TypeChecker_TermEqAndSimplify.Equal as1 as2 in - let uu___3 = FStar_Compiler_List.splitAt n args1 in - (match uu___3 with - | (parms1, args11) -> - let uu___4 = FStar_Compiler_List.splitAt n args2 in - (match uu___4 with - | (parms2, args21) -> eq_args1 args11 args21)) - else FStar_TypeChecker_TermEqAndSimplify.Unknown)) - else FStar_TypeChecker_TermEqAndSimplify.NotEqual - | (FV (v1, us1, args1), FV (v2, us2, args2)) -> - let uu___ = FStar_Syntax_Syntax.fv_eq v1 v2 in - if uu___ - then - let uu___1 = - let uu___2 = FStar_Syntax_Util.eq_univs_list us1 us2 in - equal_iff uu___2 in - eq_and uu___1 (fun uu___2 -> eq_args env args1 args2) - else FStar_TypeChecker_TermEqAndSimplify.Unknown - | (Constant c1, Constant c2) -> eq_constant c1 c2 - | (Type_t u1, Type_t u2) -> - let uu___ = FStar_Syntax_Util.eq_univs u1 u2 in equal_iff uu___ - | (Univ u1, Univ u2) -> - let uu___ = FStar_Syntax_Util.eq_univs u1 u2 in equal_iff uu___ - | (Refinement (r1, t11), Refinement (r2, t21)) -> - let x = - FStar_Syntax_Syntax.new_bv FStar_Pervasives_Native.None - FStar_Syntax_Syntax.t_unit in - let uu___ = - let uu___1 = - let uu___2 = t11 () in FStar_Pervasives_Native.fst uu___2 in - let uu___2 = - let uu___3 = t21 () in FStar_Pervasives_Native.fst uu___3 in - eq_t env uu___1 uu___2 in - eq_and uu___ - (fun uu___1 -> - let uu___2 = let uu___3 = mkAccuVar x in r1 uu___3 in - let uu___3 = let uu___4 = mkAccuVar x in r2 uu___4 in - eq_t env uu___2 uu___3) - | (Unknown, Unknown) -> FStar_TypeChecker_TermEqAndSimplify.Equal - | (uu___, uu___1) -> FStar_TypeChecker_TermEqAndSimplify.Unknown -and (eq_atom : atom -> atom -> FStar_TypeChecker_TermEqAndSimplify.eq_result) - = - fun a1 -> - fun a2 -> - match (a1, a2) with - | (Var bv1, Var bv2) -> - let uu___ = FStar_Syntax_Syntax.bv_eq bv1 bv2 in equal_if uu___ - | (uu___, uu___1) -> FStar_TypeChecker_TermEqAndSimplify.Unknown -and (eq_arg : - FStar_TypeChecker_Env.env_t -> - arg -> arg -> FStar_TypeChecker_TermEqAndSimplify.eq_result) - = - fun env -> - fun a1 -> - fun a2 -> - eq_t env (FStar_Pervasives_Native.fst a1) - (FStar_Pervasives_Native.fst a2) -and (eq_args : - FStar_TypeChecker_Env.env_t -> - args -> args -> FStar_TypeChecker_TermEqAndSimplify.eq_result) - = - fun env -> - fun as1 -> - fun as2 -> - match (as1, as2) with - | ([], []) -> FStar_TypeChecker_TermEqAndSimplify.Equal - | (x::xs, y::ys) -> - let uu___ = eq_arg env x y in - eq_and uu___ (fun uu___1 -> eq_args env xs ys) - | (uu___, uu___1) -> FStar_TypeChecker_TermEqAndSimplify.Unknown -let (constant_to_string : constant -> Prims.string) = - fun c -> - match c with - | Unit -> "Unit" - | Bool b -> if b then "Bool true" else "Bool false" - | Int i -> FStar_BigInt.string_of_big_int i - | Char c1 -> - FStar_Compiler_Util.format1 "'%s'" - (FStar_Compiler_Util.string_of_char c1) - | String (s, uu___) -> FStar_Compiler_Util.format1 "\"%s\"" s - | Range r -> - let uu___ = FStar_Compiler_Range_Ops.string_of_range r in - FStar_Compiler_Util.format1 "Range %s" uu___ - | SConst s -> FStar_Class_Show.show FStar_Syntax_Print.showable_const s - | Real s -> FStar_Compiler_Util.format1 "Real %s" s -let rec (t_to_string : t -> Prims.string) = - fun x -> - match x.nbe_t with - | Lam { interp = b; shape = uu___; arity;_} -> - let uu___1 = FStar_Compiler_Util.string_of_int arity in - FStar_Compiler_Util.format1 "Lam (_, %s args)" uu___1 - | Accu (a, l) -> - let uu___ = - let uu___1 = atom_to_string a in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Compiler_List.map - (fun x1 -> t_to_string (FStar_Pervasives_Native.fst x1)) - l in - FStar_Compiler_String.concat "; " uu___5 in - Prims.strcat uu___4 ")" in - Prims.strcat ") (" uu___3 in - Prims.strcat uu___1 uu___2 in - Prims.strcat "Accu (" uu___ - | Construct (fv, us, l) -> - let uu___ = - let uu___1 = - FStar_Class_Show.show FStar_Syntax_Print.showable_fv fv in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Compiler_List.map - (FStar_Class_Show.show FStar_Syntax_Print.showable_univ) - us in - FStar_Compiler_String.concat "; " uu___5 in - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Compiler_List.map - (fun x1 -> - t_to_string (FStar_Pervasives_Native.fst x1)) l in - FStar_Compiler_String.concat "; " uu___8 in - Prims.strcat uu___7 "]" in - Prims.strcat "] [" uu___6 in - Prims.strcat uu___4 uu___5 in - Prims.strcat ") [" uu___3 in - Prims.strcat uu___1 uu___2 in - Prims.strcat "Construct (" uu___ - | FV (fv, us, l) -> - let uu___ = - let uu___1 = - FStar_Class_Show.show FStar_Syntax_Print.showable_fv fv in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Compiler_List.map - (FStar_Class_Show.show FStar_Syntax_Print.showable_univ) - us in - FStar_Compiler_String.concat "; " uu___5 in - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Compiler_List.map - (fun x1 -> - t_to_string (FStar_Pervasives_Native.fst x1)) l in - FStar_Compiler_String.concat "; " uu___8 in - Prims.strcat uu___7 "]" in - Prims.strcat "] [" uu___6 in - Prims.strcat uu___4 uu___5 in - Prims.strcat ") [" uu___3 in - Prims.strcat uu___1 uu___2 in - Prims.strcat "FV (" uu___ - | Constant c -> constant_to_string c - | Univ u -> - let uu___ = FStar_Class_Show.show FStar_Syntax_Print.showable_univ u in - Prims.strcat "Universe " uu___ - | Type_t u -> - let uu___ = FStar_Class_Show.show FStar_Syntax_Print.showable_univ u in - Prims.strcat "Type_t " uu___ - | Arrow uu___ -> "Arrow" - | Refinement (f, t1) -> - let x1 = - FStar_Syntax_Syntax.new_bv FStar_Pervasives_Native.None - FStar_Syntax_Syntax.t_unit in - let t2 = let uu___ = t1 () in FStar_Pervasives_Native.fst uu___ in - let uu___ = - let uu___1 = - FStar_Class_Show.show FStar_Syntax_Print.showable_bv x1 in - let uu___2 = - let uu___3 = - let uu___4 = t_to_string t2 in - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = let uu___9 = mkAccuVar x1 in f uu___9 in - t_to_string uu___8 in - Prims.strcat uu___7 "}" in - Prims.strcat "{" uu___6 in - Prims.strcat uu___4 uu___5 in - Prims.strcat ":" uu___3 in - Prims.strcat uu___1 uu___2 in - Prims.strcat "Refinement " uu___ - | Unknown -> "Unknown" - | Reflect t1 -> - let uu___ = t_to_string t1 in Prims.strcat "Reflect " uu___ - | Quote uu___ -> "Quote _" - | Lazy (FStar_Pervasives.Inl li, uu___) -> - let uu___1 = - let uu___2 = FStar_Syntax_Util.unfold_lazy li in - FStar_Class_Show.show FStar_Syntax_Print.showable_term uu___2 in - FStar_Compiler_Util.format1 "Lazy (Inl {%s})" uu___1 - | Lazy (FStar_Pervasives.Inr (uu___, et), uu___1) -> - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Syntax.showable_emb_typ et in - FStar_Compiler_Util.format1 "Lazy (Inr (?, %s))" uu___2 - | LocalLetRec (uu___, l, uu___1, uu___2, uu___3, uu___4, uu___5) -> - let uu___6 = - let uu___7 = - FStar_Class_Show.show - (FStar_Class_Show.show_tuple2 - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_letbinding)) (true, [l]) in - Prims.strcat uu___7 ")" in - Prims.strcat "LocalLetRec (" uu___6 - | TopLevelLet (lb, uu___, uu___1) -> - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Compiler_Util.right lb.FStar_Syntax_Syntax.lbname in - FStar_Class_Show.show FStar_Syntax_Print.showable_fv uu___4 in - Prims.strcat uu___3 ")" in - Prims.strcat "TopLevelLet (" uu___2 - | TopLevelRec (lb, uu___, uu___1, uu___2) -> - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Compiler_Util.right lb.FStar_Syntax_Syntax.lbname in - FStar_Class_Show.show FStar_Syntax_Print.showable_fv uu___5 in - Prims.strcat uu___4 ")" in - Prims.strcat "TopLevelRec (" uu___3 - | Meta (t1, uu___) -> - let uu___1 = t_to_string t1 in Prims.strcat "Meta " uu___1 -and (atom_to_string : atom -> Prims.string) = - fun a -> - match a with - | Var v -> - let uu___ = FStar_Class_Show.show FStar_Syntax_Print.showable_bv v in - Prims.strcat "Var " uu___ - | Match (t1, uu___, uu___1, uu___2) -> - let uu___3 = t_to_string t1 in Prims.strcat "Match " uu___3 - | UnreducedLet (var1, typ, def, body, lb) -> - let uu___ = - let uu___1 = - FStar_Class_Show.show - (FStar_Class_Show.show_tuple2 - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_letbinding)) (false, [lb]) in - Prims.strcat uu___1 " in ...)" in - Prims.strcat "UnreducedLet(" uu___ - | UnreducedLetRec (uu___, body, lbs) -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show - (FStar_Class_Show.show_tuple2 - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_letbinding)) (true, lbs) in - let uu___3 = - let uu___4 = - let uu___5 = t_to_string body in Prims.strcat uu___5 ")" in - Prims.strcat " in " uu___4 in - Prims.strcat uu___2 uu___3 in - Prims.strcat "UnreducedLetRec(" uu___1 - | UVar uu___ -> "UVar" -let (arg_to_string : arg -> Prims.string) = - fun a -> t_to_string (FStar_Pervasives_Native.fst a) -let (args_to_string : args -> Prims.string) = - fun args1 -> - let uu___ = FStar_Compiler_List.map arg_to_string args1 in - FStar_Compiler_String.concat " " uu___ -let (showable_t : t FStar_Class_Show.showable) = - { FStar_Class_Show.show = t_to_string } -let (showable_args : args FStar_Class_Show.showable) = - { FStar_Class_Show.show = args_to_string } -type head = t -type annot = t FStar_Pervasives_Native.option -type nbe_cbs = - { - iapp: t -> args -> t ; - translate: FStar_Syntax_Syntax.term -> t } -let (__proj__Mknbe_cbs__item__iapp : nbe_cbs -> t -> args -> t) = - fun projectee -> match projectee with | { iapp; translate;_} -> iapp -let (__proj__Mknbe_cbs__item__translate : - nbe_cbs -> FStar_Syntax_Syntax.term -> t) = - fun projectee -> match projectee with | { iapp; translate;_} -> translate -type 'a embedding = - { - em: nbe_cbs -> 'a -> t ; - un: nbe_cbs -> t -> 'a FStar_Pervasives_Native.option ; - typ: unit -> t ; - e_typ: unit -> FStar_Syntax_Syntax.emb_typ } -let __proj__Mkembedding__item__em : 'a . 'a embedding -> nbe_cbs -> 'a -> t = - fun projectee -> match projectee with | { em; un; typ; e_typ;_} -> em -let __proj__Mkembedding__item__un : - 'a . 'a embedding -> nbe_cbs -> t -> 'a FStar_Pervasives_Native.option = - fun projectee -> match projectee with | { em; un; typ; e_typ;_} -> un -let __proj__Mkembedding__item__typ : 'a . 'a embedding -> unit -> t = - fun projectee -> match projectee with | { em; un; typ; e_typ;_} -> typ -let __proj__Mkembedding__item__e_typ : - 'a . 'a embedding -> unit -> FStar_Syntax_Syntax.emb_typ = - fun projectee -> match projectee with | { em; un; typ; e_typ;_} -> e_typ -let em : 'a . 'a embedding -> nbe_cbs -> 'a -> t = - fun projectee -> - match projectee with | { em = em1; un; typ; e_typ;_} -> em1 -let un : - 'a . 'a embedding -> nbe_cbs -> t -> 'a FStar_Pervasives_Native.option = - fun projectee -> - match projectee with | { em = em1; un = un1; typ; e_typ;_} -> un1 -let typ : 'a . 'a embedding -> unit -> t = - fun projectee -> - match projectee with | { em = em1; un = un1; typ = typ1; e_typ;_} -> typ1 -let e_typ : 'a . 'a embedding -> unit -> FStar_Syntax_Syntax.emb_typ = - fun projectee -> - match projectee with - | { em = em1; un = un1; typ = typ1; e_typ = e_typ1;_} -> e_typ1 -let (iapp_cb : nbe_cbs -> t -> args -> t) = - fun cbs -> fun h -> fun a -> cbs.iapp h a -let (translate_cb : nbe_cbs -> FStar_Syntax_Syntax.term -> t) = - fun cbs -> fun t1 -> cbs.translate t1 -let embed : 'a . 'a embedding -> nbe_cbs -> 'a -> t = - fun e -> fun cb -> fun x -> e.em cb x -let unembed : - 'a . 'a embedding -> nbe_cbs -> t -> 'a FStar_Pervasives_Native.option = - fun e -> fun cb -> fun trm -> e.un cb trm -let type_of : 'a . 'a embedding -> t = fun e -> e.typ () -let set_type : 'a . t -> 'a embedding -> 'a embedding = - fun ty -> - fun e -> - { em = (e.em); un = (e.un); typ = (fun uu___ -> ty); e_typ = (e.e_typ) - } -let mk_emb : - 'a . - (nbe_cbs -> 'a -> t) -> - (nbe_cbs -> t -> 'a FStar_Pervasives_Native.option) -> - (unit -> t) -> (unit -> FStar_Syntax_Syntax.emb_typ) -> 'a embedding - = - fun em1 -> - fun un1 -> - fun typ1 -> fun et -> { em = em1; un = un1; typ = typ1; e_typ = et } -let mk_emb' : - 'uuuuu . - (nbe_cbs -> 'uuuuu -> t') -> - (nbe_cbs -> t' -> 'uuuuu FStar_Pervasives_Native.option) -> - (unit -> t) -> - (unit -> FStar_Syntax_Syntax.emb_typ) -> 'uuuuu embedding - = - fun em1 -> - fun un1 -> - mk_emb (fun cbs -> fun t1 -> let uu___ = em1 cbs t1 in mk_t uu___) - (fun cbs -> fun t1 -> un1 cbs t1.nbe_t) -let embed_as : - 'a 'b . - 'a embedding -> - ('a -> 'b) -> - ('b -> 'a) -> t FStar_Pervasives_Native.option -> 'b embedding - = - fun ea -> - fun ab -> - fun ba -> - fun ot -> - mk_emb (fun cbs -> fun x -> let uu___ = ba x in embed ea cbs uu___) - (fun cbs -> - fun t1 -> - let uu___ = unembed ea cbs t1 in - FStar_Compiler_Util.map_opt uu___ ab) - (fun uu___ -> - match ot with - | FStar_Pervasives_Native.Some t1 -> t1 - | FStar_Pervasives_Native.None -> ea.typ ()) ea.e_typ -let (lid_as_constr : - FStar_Ident.lident -> FStar_Syntax_Syntax.universe Prims.list -> args -> t) - = - fun l -> - fun us -> - fun args1 -> - let uu___ = - FStar_Syntax_Syntax.lid_as_fv l - (FStar_Pervasives_Native.Some FStar_Syntax_Syntax.Data_ctor) in - mkConstruct uu___ us args1 -let (lid_as_typ : - FStar_Ident.lident -> FStar_Syntax_Syntax.universe Prims.list -> args -> t) - = - fun l -> - fun us -> - fun args1 -> - let uu___ = - FStar_Syntax_Syntax.lid_as_fv l FStar_Pervasives_Native.None in - mkFV uu___ us args1 -let (as_iarg : t -> arg) = - fun a -> - let uu___ = FStar_Syntax_Syntax.as_aqual_implicit true in (a, uu___) -let (as_arg : t -> arg) = fun a -> (a, FStar_Pervasives_Native.None) -let (make_arrow1 : t -> arg -> t) = - fun t1 -> fun a -> mk_t (Arrow (FStar_Pervasives.Inr ([a], (Tot t1)))) -let lazy_embed : - 'a . (unit -> FStar_Syntax_Syntax.emb_typ) -> 'a -> (unit -> t) -> t = - fun et -> - fun x -> - fun f -> - (let uu___1 = - FStar_Compiler_Effect.op_Bang FStar_Options.debug_embedding in - if uu___1 - then - let uu___2 = - let uu___3 = et () in - FStar_Class_Show.show FStar_Syntax_Syntax.showable_emb_typ - uu___3 in - FStar_Compiler_Util.print1 "Embedding\n\temb_typ=%s\n" uu___2 - else ()); - (let uu___1 = - FStar_Compiler_Effect.op_Bang FStar_Options.eager_embedding in - if uu___1 - then f () - else - (let thunk = FStar_Thunk.mk f in - let li = let uu___3 = et () in ((FStar_Dyn.mkdyn x), uu___3) in - mk_t (Lazy ((FStar_Pervasives.Inr li), thunk)))) -let lazy_unembed : - 'a . - (unit -> FStar_Syntax_Syntax.emb_typ) -> - t -> - (t -> 'a FStar_Pervasives_Native.option) -> - 'a FStar_Pervasives_Native.option - = - fun et -> - fun x -> - fun f -> - match x.nbe_t with - | Lazy (FStar_Pervasives.Inl li, thunk) -> - let uu___ = FStar_Thunk.force thunk in f uu___ - | Lazy (FStar_Pervasives.Inr (b, et'), thunk) -> - let uu___ = - (let uu___1 = et () in uu___1 <> et') || - (FStar_Compiler_Effect.op_Bang FStar_Options.eager_embedding) in - if uu___ - then - let res = let uu___1 = FStar_Thunk.force thunk in f uu___1 in - ((let uu___2 = - FStar_Compiler_Effect.op_Bang FStar_Options.debug_embedding in - if uu___2 - then - let uu___3 = - let uu___4 = et () in - FStar_Class_Show.show - FStar_Syntax_Syntax.showable_emb_typ uu___4 in - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Syntax.showable_emb_typ et' in - FStar_Compiler_Util.print2 - "Unembed cancellation failed\n\t%s <> %s\n" uu___3 uu___4 - else ()); - res) - else - (let a1 = FStar_Dyn.undyn b in - (let uu___3 = - FStar_Compiler_Effect.op_Bang FStar_Options.debug_embedding in - if uu___3 - then - let uu___4 = - let uu___5 = et () in - FStar_Class_Show.show - FStar_Syntax_Syntax.showable_emb_typ uu___5 in - FStar_Compiler_Util.print1 "Unembed cancelled for %s\n" - uu___4 - else ()); - FStar_Pervasives_Native.Some a1) - | uu___ -> - let aopt = f x in - ((let uu___2 = - FStar_Compiler_Effect.op_Bang FStar_Options.debug_embedding in - if uu___2 - then - let uu___3 = - let uu___4 = et () in - FStar_Class_Show.show FStar_Syntax_Syntax.showable_emb_typ - uu___4 in - FStar_Compiler_Util.print1 "Unembedding:\n\temb_typ=%s\n" - uu___3 - else ()); - aopt) -let lazy_unembed_lazy_kind : - 'a . - FStar_Syntax_Syntax.lazy_kind -> t -> 'a FStar_Pervasives_Native.option - = - fun k -> - fun x -> - match x.nbe_t with - | Lazy (FStar_Pervasives.Inl li, uu___) -> - if li.FStar_Syntax_Syntax.lkind = k - then - let uu___1 = FStar_Dyn.undyn li.FStar_Syntax_Syntax.blob in - FStar_Pervasives_Native.Some uu___1 - else FStar_Pervasives_Native.None - | uu___ -> FStar_Pervasives_Native.None -type abstract_nbe_term = - | AbstractNBE of t -let (uu___is_AbstractNBE : abstract_nbe_term -> Prims.bool) = - fun projectee -> true -let (__proj__AbstractNBE__item__t : abstract_nbe_term -> t) = - fun projectee -> match projectee with | AbstractNBE t1 -> t1 -let (mk_any_emb : t -> t embedding) = - fun ty -> - let em1 _cb a = a in - let un1 _cb t1 = FStar_Pervasives_Native.Some t1 in - mk_emb em1 un1 (fun uu___ -> ty) - (fun uu___ -> FStar_Syntax_Syntax.ET_abstract) -let (e_any : t embedding) = - let em1 _cb a = a in - let un1 _cb t1 = FStar_Pervasives_Native.Some t1 in - mk_emb em1 un1 (fun uu___ -> lid_as_typ FStar_Parser_Const.term_lid [] []) - (fun uu___ -> FStar_Syntax_Syntax.ET_abstract) -let (e_unit : unit embedding) = - let em1 _cb a = Constant Unit in - let un1 _cb t1 = FStar_Pervasives_Native.Some () in - mk_emb' em1 un1 (fun uu___ -> lid_as_typ FStar_Parser_Const.unit_lid [] []) - (FStar_Syntax_Embeddings_Base.emb_typ_of FStar_Syntax_Embeddings.e_unit) -let (e_bool : Prims.bool embedding) = - let em1 _cb a = Constant (Bool a) in - let un1 _cb t1 = - match t1 with - | Constant (Bool a) -> FStar_Pervasives_Native.Some a - | uu___ -> FStar_Pervasives_Native.None in - mk_emb' em1 un1 (fun uu___ -> lid_as_typ FStar_Parser_Const.bool_lid [] []) - (FStar_Syntax_Embeddings_Base.emb_typ_of FStar_Syntax_Embeddings.e_bool) -let (e_char : FStar_String.char embedding) = - let em1 _cb c = Constant (Char c) in - let un1 _cb c = - match c with - | Constant (Char a) -> FStar_Pervasives_Native.Some a - | uu___ -> FStar_Pervasives_Native.None in - mk_emb' em1 un1 (fun uu___ -> lid_as_typ FStar_Parser_Const.char_lid [] []) - (FStar_Syntax_Embeddings_Base.emb_typ_of FStar_Syntax_Embeddings.e_char) -let (e_string : Prims.string embedding) = - let em1 _cb s = Constant (String (s, FStar_Compiler_Range_Type.dummyRange)) in - let un1 _cb s = - match s with - | Constant (String (s1, uu___)) -> FStar_Pervasives_Native.Some s1 - | uu___ -> FStar_Pervasives_Native.None in - mk_emb' em1 un1 - (fun uu___ -> lid_as_typ FStar_Parser_Const.string_lid [] []) - (FStar_Syntax_Embeddings_Base.emb_typ_of FStar_Syntax_Embeddings.e_string) -let (e_int : FStar_BigInt.t embedding) = - let em1 _cb c = Constant (Int c) in - let un1 _cb c = - match c with - | Constant (Int a) -> FStar_Pervasives_Native.Some a - | uu___ -> FStar_Pervasives_Native.None in - mk_emb' em1 un1 (fun uu___ -> lid_as_typ FStar_Parser_Const.int_lid [] []) - (FStar_Syntax_Embeddings_Base.emb_typ_of FStar_Syntax_Embeddings.e_fsint) -let (e_real : FStar_Compiler_Real.real embedding) = - let em1 _cb uu___ = - match uu___ with | FStar_Compiler_Real.Real c -> Constant (Real c) in - let un1 _cb c = - match c with - | Constant (Real a) -> - FStar_Pervasives_Native.Some (FStar_Compiler_Real.Real a) - | uu___ -> FStar_Pervasives_Native.None in - mk_emb' em1 un1 (fun uu___ -> lid_as_typ FStar_Parser_Const.real_lid [] []) - (FStar_Syntax_Embeddings_Base.emb_typ_of FStar_Syntax_Embeddings.e_real) -let (e_fsint : Prims.int embedding) = - embed_as e_int FStar_BigInt.to_int_fs FStar_BigInt.of_int_fs - FStar_Pervasives_Native.None -let e_option : - 'a . 'a embedding -> 'a FStar_Pervasives_Native.option embedding = - fun ea -> - let etyp uu___ = - let uu___1 = - let uu___2 = FStar_Ident.string_of_lid FStar_Parser_Const.option_lid in - let uu___3 = let uu___4 = ea.e_typ () in [uu___4] in (uu___2, uu___3) in - FStar_Syntax_Syntax.ET_app uu___1 in - let em1 cb o = - lazy_embed etyp o - (fun uu___ -> - match o with - | FStar_Pervasives_Native.None -> - let uu___1 = - let uu___2 = let uu___3 = type_of ea in as_iarg uu___3 in - [uu___2] in - lid_as_constr FStar_Parser_Const.none_lid - [FStar_Syntax_Syntax.U_zero] uu___1 - | FStar_Pervasives_Native.Some x -> - let uu___1 = - let uu___2 = let uu___3 = embed ea cb x in as_arg uu___3 in - let uu___3 = - let uu___4 = let uu___5 = type_of ea in as_iarg uu___5 in - [uu___4] in - uu___2 :: uu___3 in - lid_as_constr FStar_Parser_Const.some_lid - [FStar_Syntax_Syntax.U_zero] uu___1) in - let un1 cb trm = - lazy_unembed etyp trm - (fun trm1 -> - match trm1.nbe_t with - | Construct (fvar, us, args1) when - FStar_Syntax_Syntax.fv_eq_lid fvar FStar_Parser_Const.none_lid - -> FStar_Pervasives_Native.Some FStar_Pervasives_Native.None - | Construct (fvar, us, (a1, uu___)::uu___1::[]) when - FStar_Syntax_Syntax.fv_eq_lid fvar FStar_Parser_Const.some_lid - -> - let uu___2 = unembed ea cb a1 in - FStar_Compiler_Util.bind_opt uu___2 - (fun a2 -> - FStar_Pervasives_Native.Some - (FStar_Pervasives_Native.Some a2)) - | uu___ -> FStar_Pervasives_Native.None) in - mk_emb em1 un1 - (fun uu___ -> - let uu___1 = - let uu___2 = let uu___3 = type_of ea in as_arg uu___3 in [uu___2] in - lid_as_typ FStar_Parser_Const.option_lid - [FStar_Syntax_Syntax.U_zero] uu___1) etyp -let e_tuple2 : 'a 'b . 'a embedding -> 'b embedding -> ('a * 'b) embedding = - fun ea -> - fun eb -> - let etyp uu___ = - let uu___1 = - let uu___2 = - FStar_Ident.string_of_lid FStar_Parser_Const.lid_tuple2 in - let uu___3 = - let uu___4 = ea.e_typ () in - let uu___5 = let uu___6 = eb.e_typ () in [uu___6] in uu___4 :: - uu___5 in - (uu___2, uu___3) in - FStar_Syntax_Syntax.ET_app uu___1 in - let em1 cb x = - lazy_embed etyp x - (fun uu___ -> - let uu___1 = - let uu___2 = - let uu___3 = embed eb cb (FStar_Pervasives_Native.snd x) in - as_arg uu___3 in - let uu___3 = - let uu___4 = - let uu___5 = embed ea cb (FStar_Pervasives_Native.fst x) in - as_arg uu___5 in - let uu___5 = - let uu___6 = let uu___7 = type_of eb in as_iarg uu___7 in - let uu___7 = - let uu___8 = let uu___9 = type_of ea in as_iarg uu___9 in - [uu___8] in - uu___6 :: uu___7 in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - lid_as_constr FStar_Parser_Const.lid_Mktuple2 - [FStar_Syntax_Syntax.U_zero; FStar_Syntax_Syntax.U_zero] - uu___1) in - let un1 cb trm = - lazy_unembed etyp trm - (fun uu___ -> - (fun trm1 -> - match trm1.nbe_t with - | Construct - (fvar, us, (b1, uu___)::(a1, uu___1)::uu___2::uu___3::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fvar - FStar_Parser_Const.lid_Mktuple2 - -> - Obj.magic - (Obj.repr - (let uu___4 = unembed ea cb a1 in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic uu___4) - (fun uu___5 -> - (fun a2 -> - let a2 = Obj.magic a2 in - let uu___5 = unembed eb cb b1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic uu___5) - (fun uu___6 -> - (fun b2 -> - let b2 = Obj.magic b2 in - Obj.magic - (FStar_Pervasives_Native.Some - (a2, b2))) uu___6))) uu___5))) - | uu___ -> Obj.magic (Obj.repr FStar_Pervasives_Native.None)) - uu___) in - mk_emb em1 un1 - (fun uu___ -> - let uu___1 = - let uu___2 = let uu___3 = type_of eb in as_arg uu___3 in - let uu___3 = - let uu___4 = let uu___5 = type_of ea in as_arg uu___5 in - [uu___4] in - uu___2 :: uu___3 in - lid_as_typ FStar_Parser_Const.lid_tuple2 - [FStar_Syntax_Syntax.U_zero; FStar_Syntax_Syntax.U_zero] uu___1) - etyp -let e_tuple3 : - 'a 'b 'c . - 'a embedding -> 'b embedding -> 'c embedding -> ('a * 'b * 'c) embedding - = - fun ea -> - fun eb -> - fun ec -> - let etyp uu___ = - let uu___1 = - let uu___2 = - FStar_Ident.string_of_lid FStar_Parser_Const.lid_tuple3 in - let uu___3 = - let uu___4 = ea.e_typ () in - let uu___5 = - let uu___6 = eb.e_typ () in - let uu___7 = let uu___8 = ec.e_typ () in [uu___8] in uu___6 - :: uu___7 in - uu___4 :: uu___5 in - (uu___2, uu___3) in - FStar_Syntax_Syntax.ET_app uu___1 in - let em1 cb uu___ = - match uu___ with - | (x1, x2, x3) -> - lazy_embed etyp (x1, x2, x3) - (fun uu___1 -> - let uu___2 = - let uu___3 = - let uu___4 = embed ec cb x3 in as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = embed eb cb x2 in as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = embed ea cb x1 in as_arg uu___8 in - let uu___8 = - let uu___9 = - let uu___10 = type_of ec in as_iarg uu___10 in - let uu___10 = - let uu___11 = - let uu___12 = type_of eb in as_iarg uu___12 in - let uu___12 = - let uu___13 = - let uu___14 = type_of ea in as_iarg uu___14 in - [uu___13] in - uu___11 :: uu___12 in - uu___9 :: uu___10 in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - lid_as_constr FStar_Parser_Const.lid_Mktuple3 - [FStar_Syntax_Syntax.U_zero; - FStar_Syntax_Syntax.U_zero; - FStar_Syntax_Syntax.U_zero] uu___2) in - let un1 cb trm = - lazy_unembed etyp trm - (fun uu___ -> - (fun trm1 -> - match trm1.nbe_t with - | Construct - (fvar, us, - (c1, uu___)::(b1, uu___1)::(a1, uu___2)::uu___3::uu___4::uu___5::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fvar - FStar_Parser_Const.lid_Mktuple3 - -> - Obj.magic - (Obj.repr - (let uu___6 = unembed ea cb a1 in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic uu___6) - (fun uu___7 -> - (fun a2 -> - let a2 = Obj.magic a2 in - let uu___7 = unembed eb cb b1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic uu___7) - (fun uu___8 -> - (fun b2 -> - let b2 = Obj.magic b2 in - let uu___8 = unembed ec cb c1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () (Obj.magic uu___8) - (fun uu___9 -> - (fun c2 -> - let c2 = - Obj.magic c2 in - Obj.magic - (FStar_Pervasives_Native.Some - (a2, b2, c2))) - uu___9))) uu___8))) - uu___7))) - | uu___ -> - Obj.magic (Obj.repr FStar_Pervasives_Native.None)) - uu___) in - mk_emb em1 un1 - (fun uu___ -> - let uu___1 = - let uu___2 = let uu___3 = type_of ec in as_arg uu___3 in - let uu___3 = - let uu___4 = let uu___5 = type_of eb in as_arg uu___5 in - let uu___5 = - let uu___6 = let uu___7 = type_of ea in as_arg uu___7 in - [uu___6] in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - lid_as_typ FStar_Parser_Const.lid_tuple3 - [FStar_Syntax_Syntax.U_zero; - FStar_Syntax_Syntax.U_zero; - FStar_Syntax_Syntax.U_zero] uu___1) etyp -let e_tuple4 : - 'a 'b 'c 'd . - 'a embedding -> - 'b embedding -> - 'c embedding -> 'd embedding -> ('a * 'b * 'c * 'd) embedding - = - fun ea -> - fun eb -> - fun ec -> - fun ed -> - let etyp uu___ = - let uu___1 = - let uu___2 = - FStar_Ident.string_of_lid FStar_Parser_Const.lid_tuple4 in - let uu___3 = - let uu___4 = ea.e_typ () in - let uu___5 = - let uu___6 = eb.e_typ () in - let uu___7 = - let uu___8 = ec.e_typ () in - let uu___9 = let uu___10 = ed.e_typ () in [uu___10] in - uu___8 :: uu___9 in - uu___6 :: uu___7 in - uu___4 :: uu___5 in - (uu___2, uu___3) in - FStar_Syntax_Syntax.ET_app uu___1 in - let em1 cb uu___ = - match uu___ with - | (x1, x2, x3, x4) -> - lazy_embed etyp (x1, x2, x3, x4) - (fun uu___1 -> - let uu___2 = - let uu___3 = - let uu___4 = embed ed cb x4 in as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = embed ec cb x3 in as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = embed eb cb x2 in as_arg uu___8 in - let uu___8 = - let uu___9 = - let uu___10 = embed ea cb x1 in as_arg uu___10 in - let uu___10 = - let uu___11 = - let uu___12 = type_of ed in as_iarg uu___12 in - let uu___12 = - let uu___13 = - let uu___14 = type_of ec in - as_iarg uu___14 in - let uu___14 = - let uu___15 = - let uu___16 = type_of eb in - as_iarg uu___16 in - let uu___16 = - let uu___17 = - let uu___18 = type_of ea in - as_iarg uu___18 in - [uu___17] in - uu___15 :: uu___16 in - uu___13 :: uu___14 in - uu___11 :: uu___12 in - uu___9 :: uu___10 in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - lid_as_constr FStar_Parser_Const.lid_Mktuple4 - [FStar_Syntax_Syntax.U_zero; - FStar_Syntax_Syntax.U_zero; - FStar_Syntax_Syntax.U_zero; - FStar_Syntax_Syntax.U_zero] uu___2) in - let un1 cb trm = - lazy_unembed etyp trm - (fun uu___ -> - (fun trm1 -> - match trm1.nbe_t with - | Construct - (fvar, us, - (d1, uu___)::(c1, uu___1)::(b1, uu___2)::(a1, - uu___3)::uu___4::uu___5::uu___6::uu___7::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fvar - FStar_Parser_Const.lid_Mktuple4 - -> - Obj.magic - (Obj.repr - (let uu___8 = unembed ea cb a1 in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic uu___8) - (fun uu___9 -> - (fun a2 -> - let a2 = Obj.magic a2 in - let uu___9 = unembed eb cb b1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () - () (Obj.magic uu___9) - (fun uu___10 -> - (fun b2 -> - let b2 = Obj.magic b2 in - let uu___10 = - unembed ec cb c1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () - (Obj.magic uu___10) - (fun uu___11 -> - (fun c2 -> - let c2 = - Obj.magic c2 in - let uu___11 = - unembed ed cb - d1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () - (Obj.magic - uu___11) - (fun uu___12 - -> - (fun d2 - -> - let d2 = - Obj.magic - d2 in - Obj.magic - (FStar_Pervasives_Native.Some - (a2, b2, - c2, d2))) - uu___12))) - uu___11))) uu___10))) - uu___9))) - | uu___ -> - Obj.magic (Obj.repr FStar_Pervasives_Native.None)) - uu___) in - mk_emb em1 un1 - (fun uu___ -> - let uu___1 = - let uu___2 = let uu___3 = type_of ed in as_arg uu___3 in - let uu___3 = - let uu___4 = let uu___5 = type_of ec in as_arg uu___5 in - let uu___5 = - let uu___6 = let uu___7 = type_of eb in as_arg uu___7 in - let uu___7 = - let uu___8 = let uu___9 = type_of ea in as_arg uu___9 in - [uu___8] in - uu___6 :: uu___7 in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - lid_as_typ FStar_Parser_Const.lid_tuple4 - [FStar_Syntax_Syntax.U_zero; - FStar_Syntax_Syntax.U_zero; - FStar_Syntax_Syntax.U_zero; - FStar_Syntax_Syntax.U_zero] uu___1) etyp -let e_tuple5 : - 'a 'b 'c 'd 'e . - 'a embedding -> - 'b embedding -> - 'c embedding -> - 'd embedding -> 'e embedding -> ('a * 'b * 'c * 'd * 'e) embedding - = - fun ea -> - fun eb -> - fun ec -> - fun ed -> - fun ee -> - let etyp uu___ = - let uu___1 = - let uu___2 = - FStar_Ident.string_of_lid FStar_Parser_Const.lid_tuple5 in - let uu___3 = - let uu___4 = ea.e_typ () in - let uu___5 = - let uu___6 = eb.e_typ () in - let uu___7 = - let uu___8 = ec.e_typ () in - let uu___9 = - let uu___10 = ed.e_typ () in - let uu___11 = let uu___12 = ee.e_typ () in [uu___12] in - uu___10 :: uu___11 in - uu___8 :: uu___9 in - uu___6 :: uu___7 in - uu___4 :: uu___5 in - (uu___2, uu___3) in - FStar_Syntax_Syntax.ET_app uu___1 in - let em1 cb uu___ = - match uu___ with - | (x1, x2, x3, x4, x5) -> - lazy_embed etyp (x1, x2, x3, x4, x5) - (fun uu___1 -> - let uu___2 = - let uu___3 = - let uu___4 = embed ee cb x5 in as_arg uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = embed ed cb x4 in as_arg uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = embed ec cb x3 in as_arg uu___8 in - let uu___8 = - let uu___9 = - let uu___10 = embed eb cb x2 in - as_arg uu___10 in - let uu___10 = - let uu___11 = - let uu___12 = embed ea cb x1 in - as_arg uu___12 in - let uu___12 = - let uu___13 = - let uu___14 = type_of ee in - as_iarg uu___14 in - let uu___14 = - let uu___15 = - let uu___16 = type_of ed in - as_iarg uu___16 in - let uu___16 = - let uu___17 = - let uu___18 = type_of ec in - as_iarg uu___18 in - let uu___18 = - let uu___19 = - let uu___20 = type_of eb in - as_iarg uu___20 in - let uu___20 = - let uu___21 = - let uu___22 = type_of ea in - as_iarg uu___22 in - [uu___21] in - uu___19 :: uu___20 in - uu___17 :: uu___18 in - uu___15 :: uu___16 in - uu___13 :: uu___14 in - uu___11 :: uu___12 in - uu___9 :: uu___10 in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - lid_as_constr FStar_Parser_Const.lid_Mktuple5 - [FStar_Syntax_Syntax.U_zero; - FStar_Syntax_Syntax.U_zero; - FStar_Syntax_Syntax.U_zero; - FStar_Syntax_Syntax.U_zero; - FStar_Syntax_Syntax.U_zero] uu___2) in - let un1 cb trm = - lazy_unembed etyp trm - (fun uu___ -> - (fun trm1 -> - match trm1.nbe_t with - | Construct - (fvar, us, - (e1, uu___)::(d1, uu___1)::(c1, uu___2)::(b1, - uu___3):: - (a1, uu___4)::uu___5::uu___6::uu___7::uu___8::uu___9::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fvar - FStar_Parser_Const.lid_Mktuple5 - -> - Obj.magic - (Obj.repr - (let uu___10 = unembed ea cb a1 in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic uu___10) - (fun uu___11 -> - (fun a2 -> - let a2 = Obj.magic a2 in - let uu___11 = unembed eb cb b1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () (Obj.magic uu___11) - (fun uu___12 -> - (fun b2 -> - let b2 = Obj.magic b2 in - let uu___12 = - unembed ec cb c1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () - (Obj.magic uu___12) - (fun uu___13 -> - (fun c2 -> - let c2 = - Obj.magic c2 in - let uu___13 = - unembed ed cb - d1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () - (Obj.magic - uu___13) - (fun - uu___14 - -> - (fun d2 - -> - let d2 = - Obj.magic - d2 in - let uu___14 - = - unembed - ee cb e1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () - (Obj.magic - uu___14) - (fun - uu___15 - -> - (fun e2 - -> - let e2 = - Obj.magic - e2 in - Obj.magic - (FStar_Pervasives_Native.Some - (a2, b2, - c2, d2, - e2))) - uu___15))) - uu___14))) - uu___13))) - uu___12))) uu___11))) - | uu___ -> - Obj.magic (Obj.repr FStar_Pervasives_Native.None)) - uu___) in - mk_emb em1 un1 - (fun uu___ -> - let uu___1 = - let uu___2 = let uu___3 = type_of ee in as_arg uu___3 in - let uu___3 = - let uu___4 = let uu___5 = type_of ed in as_arg uu___5 in - let uu___5 = - let uu___6 = let uu___7 = type_of ec in as_arg uu___7 in - let uu___7 = - let uu___8 = - let uu___9 = type_of eb in as_arg uu___9 in - let uu___9 = - let uu___10 = - let uu___11 = type_of ea in as_arg uu___11 in - [uu___10] in - uu___8 :: uu___9 in - uu___6 :: uu___7 in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - lid_as_typ FStar_Parser_Const.lid_tuple5 - [FStar_Syntax_Syntax.U_zero; - FStar_Syntax_Syntax.U_zero; - FStar_Syntax_Syntax.U_zero; - FStar_Syntax_Syntax.U_zero; - FStar_Syntax_Syntax.U_zero] uu___1) etyp -let e_either : - 'a 'b . - 'a embedding -> - 'b embedding -> ('a, 'b) FStar_Pervasives.either embedding - = - fun ea -> - fun eb -> - let etyp uu___ = - let uu___1 = - let uu___2 = - FStar_Ident.string_of_lid FStar_Parser_Const.either_lid in - let uu___3 = - let uu___4 = ea.e_typ () in - let uu___5 = let uu___6 = eb.e_typ () in [uu___6] in uu___4 :: - uu___5 in - (uu___2, uu___3) in - FStar_Syntax_Syntax.ET_app uu___1 in - let em1 cb s = - lazy_embed etyp s - (fun uu___ -> - match s with - | FStar_Pervasives.Inl a1 -> - let uu___1 = - let uu___2 = let uu___3 = embed ea cb a1 in as_arg uu___3 in - let uu___3 = - let uu___4 = let uu___5 = type_of eb in as_iarg uu___5 in - let uu___5 = - let uu___6 = let uu___7 = type_of ea in as_iarg uu___7 in - [uu___6] in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - lid_as_constr FStar_Parser_Const.inl_lid - [FStar_Syntax_Syntax.U_zero; FStar_Syntax_Syntax.U_zero] - uu___1 - | FStar_Pervasives.Inr b1 -> - let uu___1 = - let uu___2 = let uu___3 = embed eb cb b1 in as_arg uu___3 in - let uu___3 = - let uu___4 = let uu___5 = type_of eb in as_iarg uu___5 in - let uu___5 = - let uu___6 = let uu___7 = type_of ea in as_iarg uu___7 in - [uu___6] in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - lid_as_constr FStar_Parser_Const.inr_lid - [FStar_Syntax_Syntax.U_zero; FStar_Syntax_Syntax.U_zero] - uu___1) in - let un1 cb trm = - lazy_unembed etyp trm - (fun trm1 -> - match trm1.nbe_t with - | Construct (fvar, us, (a1, uu___)::uu___1::uu___2::[]) when - FStar_Syntax_Syntax.fv_eq_lid fvar - FStar_Parser_Const.inl_lid - -> - let uu___3 = unembed ea cb a1 in - FStar_Compiler_Util.bind_opt uu___3 - (fun a2 -> - FStar_Pervasives_Native.Some (FStar_Pervasives.Inl a2)) - | Construct (fvar, us, (b1, uu___)::uu___1::uu___2::[]) when - FStar_Syntax_Syntax.fv_eq_lid fvar - FStar_Parser_Const.inr_lid - -> - let uu___3 = unembed eb cb b1 in - FStar_Compiler_Util.bind_opt uu___3 - (fun b2 -> - FStar_Pervasives_Native.Some (FStar_Pervasives.Inr b2)) - | uu___ -> FStar_Pervasives_Native.None) in - mk_emb em1 un1 - (fun uu___ -> - let uu___1 = - let uu___2 = let uu___3 = type_of eb in as_arg uu___3 in - let uu___3 = - let uu___4 = let uu___5 = type_of ea in as_arg uu___5 in - [uu___4] in - uu___2 :: uu___3 in - lid_as_typ FStar_Parser_Const.either_lid - [FStar_Syntax_Syntax.U_zero; FStar_Syntax_Syntax.U_zero] uu___1) - etyp -let (e___range : FStar_Compiler_Range_Type.range embedding) = - let em1 cb r = Constant (Range r) in - let un1 cb t1 = - match t1 with - | Constant (Range r) -> FStar_Pervasives_Native.Some r - | uu___ -> FStar_Pervasives_Native.None in - mk_emb' em1 un1 - (fun uu___ -> lid_as_typ FStar_Parser_Const.__range_lid [] []) - (FStar_Syntax_Embeddings_Base.emb_typ_of FStar_Syntax_Embeddings.e_range) -let e_sealed : 'a . 'a embedding -> 'a FStar_Compiler_Sealed.sealed embedding - = - fun ea -> - let etyp uu___ = - let uu___1 = - let uu___2 = FStar_Ident.string_of_lid FStar_Parser_Const.sealed_lid in - let uu___3 = let uu___4 = ea.e_typ () in [uu___4] in (uu___2, uu___3) in - FStar_Syntax_Syntax.ET_app uu___1 in - let em1 cb x = - lazy_embed etyp x - (fun uu___ -> - let uu___1 = - let uu___2 = - let uu___3 = embed ea cb (FStar_Compiler_Sealed.unseal x) in - as_arg uu___3 in - let uu___3 = - let uu___4 = let uu___5 = type_of ea in as_iarg uu___5 in - [uu___4] in - uu___2 :: uu___3 in - lid_as_constr FStar_Parser_Const.seal_lid - [FStar_Syntax_Syntax.U_zero] uu___1) in - let un1 cb trm = - lazy_unembed etyp trm - (fun uu___ -> - (fun trm1 -> - match trm1.nbe_t with - | Construct (fvar, us, (a1, uu___)::uu___1::[]) when - FStar_Syntax_Syntax.fv_eq_lid fvar - FStar_Parser_Const.seal_lid - -> - Obj.magic - (Obj.repr - (let uu___2 = unembed ea cb a1 in - FStar_Class_Monad.fmap FStar_Class_Monad.monad_option - () () - (fun uu___3 -> - (Obj.magic FStar_Compiler_Sealed.seal) uu___3) - (Obj.magic uu___2))) - | uu___ -> Obj.magic (Obj.repr FStar_Pervasives_Native.None)) - uu___) in - mk_emb em1 un1 - (fun uu___ -> - let uu___1 = - let uu___2 = let uu___3 = type_of ea in as_arg uu___3 in [uu___2] in - lid_as_typ FStar_Parser_Const.sealed_lid - [FStar_Syntax_Syntax.U_zero] uu___1) etyp -let (e_range : FStar_Compiler_Range_Type.range embedding) = - embed_as (e_sealed e___range) FStar_Compiler_Sealed.unseal - FStar_Compiler_Sealed.seal FStar_Pervasives_Native.None -let (e_issue : FStar_Errors.issue embedding) = - let t_issue = - FStar_Syntax_Embeddings_Base.type_of FStar_Syntax_Embeddings.e_issue in - let li blob rng = - { - FStar_Syntax_Syntax.blob = (FStar_Dyn.mkdyn blob); - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_issue; - FStar_Syntax_Syntax.ltyp = t_issue; - FStar_Syntax_Syntax.rng = rng - } in - let em1 cb iss = - let uu___ = - let uu___1 = - FStar_Thunk.mk (fun uu___2 -> failwith "Cannot unembed issue") in - ((FStar_Pervasives.Inl (li iss FStar_Compiler_Range_Type.dummyRange)), - uu___1) in - Lazy uu___ in - let un1 cb t1 = - match t1 with - | Lazy - (FStar_Pervasives.Inl - { FStar_Syntax_Syntax.blob = blob; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_issue; - FStar_Syntax_Syntax.ltyp = uu___; - FStar_Syntax_Syntax.rng = uu___1;_}, - uu___2) - -> - let uu___3 = FStar_Dyn.undyn blob in - FStar_Pervasives_Native.Some uu___3 - | uu___ -> FStar_Pervasives_Native.None in - mk_emb' em1 un1 - (fun uu___ -> lid_as_typ FStar_Parser_Const.issue_lid [] []) - (FStar_Syntax_Embeddings_Base.emb_typ_of FStar_Syntax_Embeddings.e_issue) -let (e_document : FStar_Pprint.document embedding) = - let t_document = - FStar_Syntax_Embeddings_Base.type_of FStar_Syntax_Embeddings.e_document in - let li blob rng = - { - FStar_Syntax_Syntax.blob = (FStar_Dyn.mkdyn blob); - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_doc; - FStar_Syntax_Syntax.ltyp = t_document; - FStar_Syntax_Syntax.rng = rng - } in - let em1 cb doc = - let uu___ = - let uu___1 = - FStar_Thunk.mk (fun uu___2 -> failwith "Cannot unembed document") in - ((FStar_Pervasives.Inl (li doc FStar_Compiler_Range_Type.dummyRange)), - uu___1) in - Lazy uu___ in - let un1 cb t1 = - match t1 with - | Lazy - (FStar_Pervasives.Inl - { FStar_Syntax_Syntax.blob = blob; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_doc; - FStar_Syntax_Syntax.ltyp = uu___; - FStar_Syntax_Syntax.rng = uu___1;_}, - uu___2) - -> - let uu___3 = FStar_Dyn.undyn blob in - FStar_Pervasives_Native.Some uu___3 - | uu___ -> FStar_Pervasives_Native.None in - mk_emb' em1 un1 - (fun uu___ -> lid_as_typ FStar_Parser_Const.document_lid [] []) - (FStar_Syntax_Embeddings_Base.emb_typ_of - FStar_Syntax_Embeddings.e_document) -let (e_vconfig : FStar_VConfig.vconfig embedding) = - let em1 cb r = failwith "e_vconfig NBE" in - let un1 cb t1 = failwith "e_vconfig NBE" in - mk_emb' em1 un1 - (fun uu___ -> lid_as_typ FStar_Parser_Const.vconfig_lid [] []) - (FStar_Syntax_Embeddings_Base.emb_typ_of - FStar_Syntax_Embeddings.e_vconfig) -let e_list : 'a . 'a embedding -> 'a Prims.list embedding = - fun ea -> - let etyp uu___ = - let uu___1 = - let uu___2 = FStar_Ident.string_of_lid FStar_Parser_Const.list_lid in - let uu___3 = let uu___4 = ea.e_typ () in [uu___4] in (uu___2, uu___3) in - FStar_Syntax_Syntax.ET_app uu___1 in - let em1 cb l = - lazy_embed etyp l - (fun uu___ -> - let typ1 = let uu___1 = type_of ea in as_iarg uu___1 in - let nil = - lid_as_constr FStar_Parser_Const.nil_lid - [FStar_Syntax_Syntax.U_zero] [typ1] in - let cons hd tl = - let uu___1 = - let uu___2 = as_arg tl in - let uu___3 = - let uu___4 = let uu___5 = embed ea cb hd in as_arg uu___5 in - [uu___4; typ1] in - uu___2 :: uu___3 in - lid_as_constr FStar_Parser_Const.cons_lid - [FStar_Syntax_Syntax.U_zero] uu___1 in - FStar_Compiler_List.fold_right cons l nil) in - let rec un1 cb trm = - lazy_unembed etyp trm - (fun trm1 -> - match trm1.nbe_t with - | Construct (fv, uu___, uu___1) when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.nil_lid -> - FStar_Pervasives_Native.Some [] - | Construct - (fv, uu___, - (tl, FStar_Pervasives_Native.None)::(hd, - FStar_Pervasives_Native.None):: - (uu___1, FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = uu___2;_})::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.cons_lid - -> - let uu___3 = unembed ea cb hd in - FStar_Compiler_Util.bind_opt uu___3 - (fun hd1 -> - let uu___4 = un1 cb tl in - FStar_Compiler_Util.bind_opt uu___4 - (fun tl1 -> FStar_Pervasives_Native.Some (hd1 :: tl1))) - | Construct - (fv, uu___, - (tl, FStar_Pervasives_Native.None)::(hd, - FStar_Pervasives_Native.None)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.cons_lid - -> - let uu___1 = unembed ea cb hd in - FStar_Compiler_Util.bind_opt uu___1 - (fun hd1 -> - let uu___2 = un1 cb tl in - FStar_Compiler_Util.bind_opt uu___2 - (fun tl1 -> FStar_Pervasives_Native.Some (hd1 :: tl1))) - | uu___ -> FStar_Pervasives_Native.None) in - mk_emb em1 un1 - (fun uu___ -> - let uu___1 = - let uu___2 = let uu___3 = type_of ea in as_arg uu___3 in [uu___2] in - lid_as_typ FStar_Parser_Const.list_lid [FStar_Syntax_Syntax.U_zero] - uu___1) etyp -let (e_string_list : Prims.string Prims.list embedding) = e_list e_string -let e_arrow : 'a 'b . 'a embedding -> 'b embedding -> ('a -> 'b) embedding = - fun ea -> - fun eb -> - let etyp uu___ = - let uu___1 = - let uu___2 = ea.e_typ () in - let uu___3 = eb.e_typ () in (uu___2, uu___3) in - FStar_Syntax_Syntax.ET_fun uu___1 in - let em1 cb f = - lazy_embed etyp f - (fun uu___ -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = let uu___6 = type_of eb in as_arg uu___6 in - [uu___5] in - Lam_args uu___4 in - { - interp = - (fun tas -> - let uu___4 = - let uu___5 = - let uu___6 = FStar_Compiler_List.hd tas in - FStar_Pervasives_Native.fst uu___6 in - unembed ea cb uu___5 in - match uu___4 with - | FStar_Pervasives_Native.Some a1 -> - let uu___5 = f a1 in embed eb cb uu___5 - | FStar_Pervasives_Native.None -> - failwith "cannot unembed function argument"); - shape = uu___3; - arity = Prims.int_one - } in - Lam uu___2 in - mk_t uu___1) in - let un1 cb lam = - let k lam1 = - FStar_Pervasives_Native.Some - (fun x -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = let uu___4 = embed ea cb x in as_arg uu___4 in - [uu___3] in - cb.iapp lam1 uu___2 in - unembed eb cb uu___1 in - match uu___ with - | FStar_Pervasives_Native.Some y -> y - | FStar_Pervasives_Native.None -> - failwith "cannot unembed function result") in - lazy_unembed etyp lam k in - mk_emb em1 un1 - (fun uu___ -> - let uu___1 = type_of ea in - let uu___2 = let uu___3 = type_of eb in as_iarg uu___3 in - make_arrow1 uu___1 uu___2) etyp -let (e_abstract_nbe_term : abstract_nbe_term embedding) = - embed_as e_any (fun x -> AbstractNBE x) - (fun x -> match x with | AbstractNBE x1 -> x1) - FStar_Pervasives_Native.None -let e_unsupported : 'a . unit -> 'a embedding = - fun uu___ -> - let em1 _cb a1 = failwith "Unsupported NBE embedding" in - let un1 _cb t1 = failwith "Unsupported NBE embedding" in - mk_emb em1 un1 - (fun uu___1 -> lid_as_typ FStar_Parser_Const.term_lid [] []) - (fun uu___1 -> FStar_Syntax_Syntax.ET_abstract) -let (e_norm_step : FStar_Pervasives.norm_step embedding) = - let em1 cb n = - match n with - | FStar_Pervasives.Simpl -> - let uu___ = - FStar_Syntax_Syntax.lid_as_fv FStar_Parser_Const.steps_simpl - FStar_Pervasives_Native.None in - mkFV uu___ [] [] - | FStar_Pervasives.Weak -> - let uu___ = - FStar_Syntax_Syntax.lid_as_fv FStar_Parser_Const.steps_weak - FStar_Pervasives_Native.None in - mkFV uu___ [] [] - | FStar_Pervasives.HNF -> - let uu___ = - FStar_Syntax_Syntax.lid_as_fv FStar_Parser_Const.steps_hnf - FStar_Pervasives_Native.None in - mkFV uu___ [] [] - | FStar_Pervasives.Primops -> - let uu___ = - FStar_Syntax_Syntax.lid_as_fv FStar_Parser_Const.steps_primops - FStar_Pervasives_Native.None in - mkFV uu___ [] [] - | FStar_Pervasives.Delta -> - let uu___ = - FStar_Syntax_Syntax.lid_as_fv FStar_Parser_Const.steps_delta - FStar_Pervasives_Native.None in - mkFV uu___ [] [] - | FStar_Pervasives.Zeta -> - let uu___ = - FStar_Syntax_Syntax.lid_as_fv FStar_Parser_Const.steps_zeta - FStar_Pervasives_Native.None in - mkFV uu___ [] [] - | FStar_Pervasives.Iota -> - let uu___ = - FStar_Syntax_Syntax.lid_as_fv FStar_Parser_Const.steps_iota - FStar_Pervasives_Native.None in - mkFV uu___ [] [] - | FStar_Pervasives.Reify -> - let uu___ = - FStar_Syntax_Syntax.lid_as_fv FStar_Parser_Const.steps_reify - FStar_Pervasives_Native.None in - mkFV uu___ [] [] - | FStar_Pervasives.NBE -> - let uu___ = - FStar_Syntax_Syntax.lid_as_fv FStar_Parser_Const.steps_nbe - FStar_Pervasives_Native.None in - mkFV uu___ [] [] - | FStar_Pervasives.UnfoldOnly l -> - let uu___ = - FStar_Syntax_Syntax.lid_as_fv FStar_Parser_Const.steps_unfoldonly - FStar_Pervasives_Native.None in - let uu___1 = - let uu___2 = - let uu___3 = embed (e_list e_string) cb l in as_arg uu___3 in - [uu___2] in - mkFV uu___ [] uu___1 - | FStar_Pervasives.UnfoldFully l -> - let uu___ = - FStar_Syntax_Syntax.lid_as_fv FStar_Parser_Const.steps_unfoldfully - FStar_Pervasives_Native.None in - let uu___1 = - let uu___2 = - let uu___3 = embed (e_list e_string) cb l in as_arg uu___3 in - [uu___2] in - mkFV uu___ [] uu___1 - | FStar_Pervasives.UnfoldAttr l -> - let uu___ = - FStar_Syntax_Syntax.lid_as_fv FStar_Parser_Const.steps_unfoldattr - FStar_Pervasives_Native.None in - let uu___1 = - let uu___2 = - let uu___3 = embed (e_list e_string) cb l in as_arg uu___3 in - [uu___2] in - mkFV uu___ [] uu___1 - | FStar_Pervasives.UnfoldQual l -> - let uu___ = - FStar_Syntax_Syntax.lid_as_fv FStar_Parser_Const.steps_unfoldqual - FStar_Pervasives_Native.None in - let uu___1 = - let uu___2 = - let uu___3 = embed (e_list e_string) cb l in as_arg uu___3 in - [uu___2] in - mkFV uu___ [] uu___1 - | FStar_Pervasives.UnfoldNamespace l -> - let uu___ = - FStar_Syntax_Syntax.lid_as_fv - FStar_Parser_Const.steps_unfoldnamespace - FStar_Pervasives_Native.None in - let uu___1 = - let uu___2 = - let uu___3 = embed (e_list e_string) cb l in as_arg uu___3 in - [uu___2] in - mkFV uu___ [] uu___1 - | FStar_Pervasives.ZetaFull -> - let uu___ = - FStar_Syntax_Syntax.lid_as_fv FStar_Parser_Const.steps_zeta_full - FStar_Pervasives_Native.None in - mkFV uu___ [] [] - | FStar_Pervasives.Unascribe -> - let uu___ = - FStar_Syntax_Syntax.lid_as_fv FStar_Parser_Const.steps_unascribe - FStar_Pervasives_Native.None in - mkFV uu___ [] [] in - let un1 cb t0 = - match t0.nbe_t with - | FV (fv, uu___, []) when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.steps_simpl -> - FStar_Pervasives_Native.Some FStar_Pervasives.Simpl - | FV (fv, uu___, []) when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.steps_weak -> - FStar_Pervasives_Native.Some FStar_Pervasives.Weak - | FV (fv, uu___, []) when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.steps_hnf -> - FStar_Pervasives_Native.Some FStar_Pervasives.HNF - | FV (fv, uu___, []) when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.steps_primops -> - FStar_Pervasives_Native.Some FStar_Pervasives.Primops - | FV (fv, uu___, []) when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.steps_delta -> - FStar_Pervasives_Native.Some FStar_Pervasives.Delta - | FV (fv, uu___, []) when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.steps_zeta -> - FStar_Pervasives_Native.Some FStar_Pervasives.Zeta - | FV (fv, uu___, []) when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.steps_iota -> - FStar_Pervasives_Native.Some FStar_Pervasives.Iota - | FV (fv, uu___, []) when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.steps_nbe -> - FStar_Pervasives_Native.Some FStar_Pervasives.NBE - | FV (fv, uu___, []) when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.steps_reify -> - FStar_Pervasives_Native.Some FStar_Pervasives.Reify - | FV (fv, uu___, []) when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.steps_zeta_full - -> FStar_Pervasives_Native.Some FStar_Pervasives.ZetaFull - | FV (fv, uu___, []) when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.steps_unascribe - -> FStar_Pervasives_Native.Some FStar_Pervasives.Unascribe - | FV (fv, uu___, (l, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.steps_unfoldonly - -> - let uu___2 = unembed (e_list e_string) cb l in - FStar_Compiler_Util.bind_opt uu___2 - (fun ss -> - FStar_Pervasives_Native.Some (FStar_Pervasives.UnfoldOnly ss)) - | FV (fv, uu___, (l, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.steps_unfoldfully - -> - let uu___2 = unembed (e_list e_string) cb l in - FStar_Compiler_Util.bind_opt uu___2 - (fun ss -> - FStar_Pervasives_Native.Some (FStar_Pervasives.UnfoldFully ss)) - | FV (fv, uu___, (l, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.steps_unfoldattr - -> - let uu___2 = unembed (e_list e_string) cb l in - FStar_Compiler_Util.bind_opt uu___2 - (fun ss -> - FStar_Pervasives_Native.Some (FStar_Pervasives.UnfoldAttr ss)) - | FV (fv, uu___, (l, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.steps_unfoldqual - -> - let uu___2 = unembed (e_list e_string) cb l in - FStar_Compiler_Util.bind_opt uu___2 - (fun ss -> - FStar_Pervasives_Native.Some (FStar_Pervasives.UnfoldQual ss)) - | FV (fv, uu___, (l, uu___1)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.steps_unfoldnamespace - -> - let uu___2 = unembed (e_list e_string) cb l in - FStar_Compiler_Util.bind_opt uu___2 - (fun ss -> - FStar_Pervasives_Native.Some - (FStar_Pervasives.UnfoldNamespace ss)) - | uu___ -> - ((let uu___2 = - let uu___3 = t_to_string t0 in - FStar_Compiler_Util.format1 "Not an embedded norm_step: %s" - uu___3 in - FStar_Errors.log_issue0 FStar_Errors_Codes.Warning_NotEmbedded () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - FStar_Pervasives_Native.None) in - mk_emb em1 un1 - (fun uu___ -> - let uu___1 = - FStar_Syntax_Syntax.lid_as_fv FStar_Parser_Const.norm_step_lid - FStar_Pervasives_Native.None in - mkFV uu___1 [] []) - (FStar_Syntax_Embeddings_Base.emb_typ_of - FStar_Syntax_Embeddings.e_norm_step) -let (bogus_cbs : nbe_cbs) = - { - iapp = (fun h -> fun _args -> h); - translate = (fun uu___ -> failwith "bogus_cbs translate") - } -let (arg_as_int : arg -> FStar_BigInt.t FStar_Pervasives_Native.option) = - fun a -> unembed e_int bogus_cbs (FStar_Pervasives_Native.fst a) -let (arg_as_bool : arg -> Prims.bool FStar_Pervasives_Native.option) = - fun a -> unembed e_bool bogus_cbs (FStar_Pervasives_Native.fst a) -let arg_as_list : - 'a . 'a embedding -> arg -> 'a Prims.list FStar_Pervasives_Native.option = - fun e -> - fun a1 -> unembed (e_list e) bogus_cbs (FStar_Pervasives_Native.fst a1) -let lift_unary : - 'a 'b . - ('a -> 'b) -> - 'a FStar_Pervasives_Native.option Prims.list -> - 'b FStar_Pervasives_Native.option - = - fun f -> - fun aopts -> - match aopts with - | (FStar_Pervasives_Native.Some a1)::[] -> - let uu___ = f a1 in FStar_Pervasives_Native.Some uu___ - | uu___ -> FStar_Pervasives_Native.None -let lift_binary : - 'a 'b . - ('a -> 'a -> 'b) -> - 'a FStar_Pervasives_Native.option Prims.list -> - 'b FStar_Pervasives_Native.option - = - fun f -> - fun aopts -> - match aopts with - | (FStar_Pervasives_Native.Some a0)::(FStar_Pervasives_Native.Some - a1)::[] -> - let uu___ = f a0 a1 in FStar_Pervasives_Native.Some uu___ - | uu___ -> FStar_Pervasives_Native.None -let mixed_binary_op : - 'a 'b 'c . - (arg -> 'a FStar_Pervasives_Native.option) -> - (arg -> 'b FStar_Pervasives_Native.option) -> - ('c -> t) -> - (FStar_Syntax_Syntax.universes -> - 'a -> 'b -> 'c FStar_Pervasives_Native.option) - -> - FStar_Syntax_Syntax.universes -> - args -> t FStar_Pervasives_Native.option - = - fun as_a -> - fun as_b -> - fun embed_c -> - fun f -> - fun us -> - fun args1 -> - match args1 with - | a1::b1::[] -> - let uu___ = - let uu___1 = as_a a1 in - let uu___2 = as_b b1 in (uu___1, uu___2) in - (match uu___ with - | (FStar_Pervasives_Native.Some a2, - FStar_Pervasives_Native.Some b2) -> - let uu___1 = f us a2 b2 in - (match uu___1 with - | FStar_Pervasives_Native.Some c1 -> - let uu___2 = embed_c c1 in - FStar_Pervasives_Native.Some uu___2 - | uu___2 -> FStar_Pervasives_Native.None) - | uu___1 -> FStar_Pervasives_Native.None) - | uu___ -> FStar_Pervasives_Native.None -let mixed_ternary_op : - 'a 'b 'c 'd . - (arg -> 'a FStar_Pervasives_Native.option) -> - (arg -> 'b FStar_Pervasives_Native.option) -> - (arg -> 'c FStar_Pervasives_Native.option) -> - ('d -> t) -> - (FStar_Syntax_Syntax.universes -> - 'a -> 'b -> 'c -> 'd FStar_Pervasives_Native.option) - -> - FStar_Syntax_Syntax.universes -> - args -> t FStar_Pervasives_Native.option - = - fun as_a -> - fun as_b -> - fun as_c -> - fun embed_d -> - fun f -> - fun us -> - fun args1 -> - match args1 with - | a1::b1::c1::[] -> - let uu___ = - let uu___1 = as_a a1 in - let uu___2 = as_b b1 in - let uu___3 = as_c c1 in (uu___1, uu___2, uu___3) in - (match uu___ with - | (FStar_Pervasives_Native.Some a2, - FStar_Pervasives_Native.Some b2, - FStar_Pervasives_Native.Some c2) -> - let uu___1 = f us a2 b2 c2 in - (match uu___1 with - | FStar_Pervasives_Native.Some d1 -> - let uu___2 = embed_d d1 in - FStar_Pervasives_Native.Some uu___2 - | uu___2 -> FStar_Pervasives_Native.None) - | uu___1 -> FStar_Pervasives_Native.None) - | uu___ -> FStar_Pervasives_Native.None -let (dummy_interp : - FStar_Ident.lid -> args -> t FStar_Pervasives_Native.option) = - fun lid -> - fun args1 -> - let uu___ = - let uu___1 = FStar_Ident.string_of_lid lid in - Prims.strcat "No interpretation for " uu___1 in - failwith uu___ -let (and_op : args -> t FStar_Pervasives_Native.option) = - fun args1 -> - match args1 with - | a1::a2::[] -> - let uu___ = arg_as_bool a1 in - (match uu___ with - | FStar_Pervasives_Native.Some (false) -> - let uu___1 = embed e_bool bogus_cbs false in - FStar_Pervasives_Native.Some uu___1 - | FStar_Pervasives_Native.Some (true) -> - FStar_Pervasives_Native.Some (FStar_Pervasives_Native.fst a2) - | uu___1 -> FStar_Pervasives_Native.None) - | uu___ -> failwith "Unexpected number of arguments" -let (or_op : args -> t FStar_Pervasives_Native.option) = - fun args1 -> - match args1 with - | a1::a2::[] -> - let uu___ = arg_as_bool a1 in - (match uu___ with - | FStar_Pervasives_Native.Some (true) -> - let uu___1 = embed e_bool bogus_cbs true in - FStar_Pervasives_Native.Some uu___1 - | FStar_Pervasives_Native.Some (false) -> - FStar_Pervasives_Native.Some (FStar_Pervasives_Native.fst a2) - | uu___1 -> FStar_Pervasives_Native.None) - | uu___ -> failwith "Unexpected number of arguments" -let arrow_as_prim_step_1 : - 'a 'b . - 'a embedding -> - 'b embedding -> - ('a -> 'b) -> - FStar_Ident.lid -> - nbe_cbs -> - FStar_Syntax_Syntax.universes -> - args -> t FStar_Pervasives_Native.option - = - fun ea -> - fun eb -> - fun f -> - fun _fv_lid -> - fun cb -> - let f_wrapped _us args1 = - let uu___ = FStar_Compiler_List.hd args1 in - match uu___ with - | (x, uu___1) -> - let uu___2 = unembed ea cb x in - FStar_Compiler_Util.map_opt uu___2 - (fun x1 -> let uu___3 = f x1 in embed eb cb uu___3) in - f_wrapped -let arrow_as_prim_step_2 : - 'a 'b 'c . - 'a embedding -> - 'b embedding -> - 'c embedding -> - ('a -> 'b -> 'c) -> - FStar_Ident.lid -> - nbe_cbs -> - FStar_Syntax_Syntax.universes -> - args -> t FStar_Pervasives_Native.option - = - fun ea -> - fun eb -> - fun ec -> - fun f -> - fun _fv_lid -> - fun cb -> - let f_wrapped _us args1 = - let uu___ = FStar_Compiler_List.hd args1 in - match uu___ with - | (x, uu___1) -> - let uu___2 = - let uu___3 = FStar_Compiler_List.tl args1 in - FStar_Compiler_List.hd uu___3 in - (match uu___2 with - | (y, uu___3) -> - let uu___4 = unembed ea cb x in - FStar_Compiler_Util.bind_opt uu___4 - (fun x1 -> - let uu___5 = unembed eb cb y in - FStar_Compiler_Util.bind_opt uu___5 - (fun y1 -> - let uu___6 = - let uu___7 = f x1 y1 in - embed ec cb uu___7 in - FStar_Pervasives_Native.Some uu___6))) in - f_wrapped -let arrow_as_prim_step_3 : - 'a 'b 'c 'd . - 'a embedding -> - 'b embedding -> - 'c embedding -> - 'd embedding -> - ('a -> 'b -> 'c -> 'd) -> - FStar_Ident.lid -> - nbe_cbs -> - FStar_Syntax_Syntax.universes -> - args -> t FStar_Pervasives_Native.option - = - fun ea -> - fun eb -> - fun ec -> - fun ed -> - fun f -> - fun _fv_lid -> - fun cb -> - let f_wrapped _us args1 = - let uu___ = FStar_Compiler_List.hd args1 in - match uu___ with - | (x, uu___1) -> - let uu___2 = - let uu___3 = FStar_Compiler_List.tl args1 in - FStar_Compiler_List.hd uu___3 in - (match uu___2 with - | (y, uu___3) -> - let uu___4 = - let uu___5 = - let uu___6 = FStar_Compiler_List.tl args1 in - FStar_Compiler_List.tl uu___6 in - FStar_Compiler_List.hd uu___5 in - (match uu___4 with - | (z, uu___5) -> - let uu___6 = unembed ea cb x in - FStar_Compiler_Util.bind_opt uu___6 - (fun x1 -> - let uu___7 = unembed eb cb y in - FStar_Compiler_Util.bind_opt uu___7 - (fun y1 -> - let uu___8 = unembed ec cb z in - FStar_Compiler_Util.bind_opt uu___8 - (fun z1 -> - let uu___9 = - let uu___10 = f x1 y1 z1 in - embed ed cb uu___10 in - FStar_Pervasives_Native.Some - uu___9))))) in - f_wrapped -let (e_order : FStar_Order.order embedding) = - let ord_Lt_lid = - FStar_Ident.lid_of_path ["FStar"; "Order"; "Lt"] - FStar_Compiler_Range_Type.dummyRange in - let ord_Eq_lid = - FStar_Ident.lid_of_path ["FStar"; "Order"; "Eq"] - FStar_Compiler_Range_Type.dummyRange in - let ord_Gt_lid = - FStar_Ident.lid_of_path ["FStar"; "Order"; "Gt"] - FStar_Compiler_Range_Type.dummyRange in - let ord_Lt = FStar_Syntax_Syntax.tdataconstr ord_Lt_lid in - let ord_Eq = FStar_Syntax_Syntax.tdataconstr ord_Eq_lid in - let ord_Gt = FStar_Syntax_Syntax.tdataconstr ord_Gt_lid in - let ord_Lt_fv = - FStar_Syntax_Syntax.lid_as_fv ord_Lt_lid - (FStar_Pervasives_Native.Some FStar_Syntax_Syntax.Data_ctor) in - let ord_Eq_fv = - FStar_Syntax_Syntax.lid_as_fv ord_Eq_lid - (FStar_Pervasives_Native.Some FStar_Syntax_Syntax.Data_ctor) in - let ord_Gt_fv = - FStar_Syntax_Syntax.lid_as_fv ord_Gt_lid - (FStar_Pervasives_Native.Some FStar_Syntax_Syntax.Data_ctor) in - let embed_order cb o = - match o with - | FStar_Order.Lt -> mkConstruct ord_Lt_fv [] [] - | FStar_Order.Eq -> mkConstruct ord_Eq_fv [] [] - | FStar_Order.Gt -> mkConstruct ord_Gt_fv [] [] in - let unembed_order cb t1 = - match t1.nbe_t with - | Construct (fv, uu___, []) when - FStar_Syntax_Syntax.fv_eq_lid fv ord_Lt_lid -> - FStar_Pervasives_Native.Some FStar_Order.Lt - | Construct (fv, uu___, []) when - FStar_Syntax_Syntax.fv_eq_lid fv ord_Eq_lid -> - FStar_Pervasives_Native.Some FStar_Order.Eq - | Construct (fv, uu___, []) when - FStar_Syntax_Syntax.fv_eq_lid fv ord_Gt_lid -> - FStar_Pervasives_Native.Some FStar_Order.Gt - | uu___ -> FStar_Pervasives_Native.None in - let fv_as_emb_typ fv = - let uu___ = - let uu___1 = - FStar_Ident.string_of_lid - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - (uu___1, []) in - FStar_Syntax_Syntax.ET_app uu___ in - let fv = - FStar_Syntax_Syntax.lid_as_fv FStar_Parser_Const.order_lid - FStar_Pervasives_Native.None in - mk_emb embed_order unembed_order (fun uu___ -> mkFV fv [] []) - (fun uu___ -> fv_as_emb_typ fv) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Normalize.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Normalize.ml deleted file mode 100644 index f6c3b8b4cff..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Normalize.ml +++ /dev/null @@ -1,9302 +0,0 @@ -open Prims -let (dbg_univ_norm : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "univ_norm" -let (dbg_NormRebuild : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "NormRebuild" -let (maybe_debug : - FStar_TypeChecker_Cfg.cfg -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * FStar_Compiler_Util.time) - FStar_Pervasives_Native.option -> unit) - = - fun cfg -> - fun t -> - fun dbg -> - if - (cfg.FStar_TypeChecker_Cfg.debug).FStar_TypeChecker_Cfg.print_normalized - then - match dbg with - | FStar_Pervasives_Native.Some (tm, time_then) -> - let time_now = FStar_Compiler_Util.now () in - let uu___ = - let uu___1 = - let uu___2 = - FStar_Compiler_Util.time_diff time_then time_now in - FStar_Pervasives_Native.snd uu___2 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) uu___1 in - let uu___1 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term tm in - let uu___2 = - FStar_Class_Show.show FStar_TypeChecker_Cfg.showable_cfg cfg in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.print4 - "Normalizer result timing (%s ms){\nOn term {\n%s\n}\nwith steps {%s}\nresult is{\n\n%s\n}\n}\n" - uu___ uu___1 uu___2 uu___3 - | uu___ -> () - else () -let cases : - 'uuuuu 'uuuuu1 . - ('uuuuu -> 'uuuuu1) -> - 'uuuuu1 -> 'uuuuu FStar_Pervasives_Native.option -> 'uuuuu1 - = - fun f -> - fun d -> - fun uu___ -> - match uu___ with - | FStar_Pervasives_Native.Some x -> f x - | FStar_Pervasives_Native.None -> d -type 'a cfg_memo = (FStar_TypeChecker_Cfg.cfg * 'a) FStar_Syntax_Syntax.memo -let fresh_memo : 'a . unit -> 'a FStar_Syntax_Syntax.memo = - fun uu___ -> FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None -type closure = - | Clos of ((FStar_Syntax_Syntax.binder FStar_Pervasives_Native.option * - closure * FStar_Syntax_Syntax.subst_t FStar_Syntax_Syntax.memo) Prims.list - * FStar_Syntax_Syntax.term * ((FStar_Syntax_Syntax.binder - FStar_Pervasives_Native.option * closure * FStar_Syntax_Syntax.subst_t - FStar_Syntax_Syntax.memo) Prims.list * FStar_Syntax_Syntax.term) cfg_memo * - Prims.bool) - | Univ of FStar_Syntax_Syntax.universe - | Dummy -let (uu___is_Clos : closure -> Prims.bool) = - fun projectee -> match projectee with | Clos _0 -> true | uu___ -> false -let (__proj__Clos__item___0 : - closure -> - ((FStar_Syntax_Syntax.binder FStar_Pervasives_Native.option * closure * - FStar_Syntax_Syntax.subst_t FStar_Syntax_Syntax.memo) Prims.list * - FStar_Syntax_Syntax.term * ((FStar_Syntax_Syntax.binder - FStar_Pervasives_Native.option * closure * FStar_Syntax_Syntax.subst_t - FStar_Syntax_Syntax.memo) Prims.list * FStar_Syntax_Syntax.term) - cfg_memo * Prims.bool)) - = fun projectee -> match projectee with | Clos _0 -> _0 -let (uu___is_Univ : closure -> Prims.bool) = - fun projectee -> match projectee with | Univ _0 -> true | uu___ -> false -let (__proj__Univ__item___0 : closure -> FStar_Syntax_Syntax.universe) = - fun projectee -> match projectee with | Univ _0 -> _0 -let (uu___is_Dummy : closure -> Prims.bool) = - fun projectee -> match projectee with | Dummy -> true | uu___ -> false -type env = - (FStar_Syntax_Syntax.binder FStar_Pervasives_Native.option * closure * - FStar_Syntax_Syntax.subst_t FStar_Syntax_Syntax.memo) Prims.list -let showable_memo : - 'a . - 'a FStar_Class_Show.showable -> - 'a FStar_Syntax_Syntax.memo FStar_Class_Show.showable - = - fun uu___ -> - { - FStar_Class_Show.show = - (fun m -> - let uu___1 = FStar_Compiler_Effect.op_Bang m in - match uu___1 with - | FStar_Pervasives_Native.None -> "no_memo" - | FStar_Pervasives_Native.Some x -> - let uu___2 = FStar_Class_Show.show uu___ x in - Prims.strcat "memo=" uu___2) - } -let (empty_env : env) = [] -let (dummy : - unit -> - (FStar_Syntax_Syntax.binder FStar_Pervasives_Native.option * closure * - FStar_Syntax_Syntax.subst_t FStar_Syntax_Syntax.memo)) - = - fun uu___ -> - let uu___1 = fresh_memo () in - (FStar_Pervasives_Native.None, Dummy, uu___1) -type branches = - (FStar_Syntax_Syntax.pat * FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option * FStar_Syntax_Syntax.term) Prims.list -type stack_elt = - | Arg of (closure * FStar_Syntax_Syntax.aqual * - FStar_Compiler_Range_Type.range) - | UnivArgs of (FStar_Syntax_Syntax.universe Prims.list * - FStar_Compiler_Range_Type.range) - | MemoLazy of (env * FStar_Syntax_Syntax.term) cfg_memo - | Match of (env * FStar_Syntax_Syntax.match_returns_ascription - FStar_Pervasives_Native.option * branches * - FStar_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option * - FStar_TypeChecker_Cfg.cfg * FStar_Compiler_Range_Type.range) - | Abs of (env * FStar_Syntax_Syntax.binders * env * - FStar_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option * - FStar_Compiler_Range_Type.range) - | App of (env * FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.aqual * - FStar_Compiler_Range_Type.range) - | CBVApp of (env * FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.aqual * - FStar_Compiler_Range_Type.range) - | Meta of (env * FStar_Syntax_Syntax.metadata * - FStar_Compiler_Range_Type.range) - | Let of (env * FStar_Syntax_Syntax.binders * - FStar_Syntax_Syntax.letbinding * FStar_Compiler_Range_Type.range) -let (uu___is_Arg : stack_elt -> Prims.bool) = - fun projectee -> match projectee with | Arg _0 -> true | uu___ -> false -let (__proj__Arg__item___0 : - stack_elt -> - (closure * FStar_Syntax_Syntax.aqual * FStar_Compiler_Range_Type.range)) - = fun projectee -> match projectee with | Arg _0 -> _0 -let (uu___is_UnivArgs : stack_elt -> Prims.bool) = - fun projectee -> - match projectee with | UnivArgs _0 -> true | uu___ -> false -let (__proj__UnivArgs__item___0 : - stack_elt -> - (FStar_Syntax_Syntax.universe Prims.list * - FStar_Compiler_Range_Type.range)) - = fun projectee -> match projectee with | UnivArgs _0 -> _0 -let (uu___is_MemoLazy : stack_elt -> Prims.bool) = - fun projectee -> - match projectee with | MemoLazy _0 -> true | uu___ -> false -let (__proj__MemoLazy__item___0 : - stack_elt -> (env * FStar_Syntax_Syntax.term) cfg_memo) = - fun projectee -> match projectee with | MemoLazy _0 -> _0 -let (uu___is_Match : stack_elt -> Prims.bool) = - fun projectee -> match projectee with | Match _0 -> true | uu___ -> false -let (__proj__Match__item___0 : - stack_elt -> - (env * FStar_Syntax_Syntax.match_returns_ascription - FStar_Pervasives_Native.option * branches * - FStar_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option * - FStar_TypeChecker_Cfg.cfg * FStar_Compiler_Range_Type.range)) - = fun projectee -> match projectee with | Match _0 -> _0 -let (uu___is_Abs : stack_elt -> Prims.bool) = - fun projectee -> match projectee with | Abs _0 -> true | uu___ -> false -let (__proj__Abs__item___0 : - stack_elt -> - (env * FStar_Syntax_Syntax.binders * env * - FStar_Syntax_Syntax.residual_comp FStar_Pervasives_Native.option * - FStar_Compiler_Range_Type.range)) - = fun projectee -> match projectee with | Abs _0 -> _0 -let (uu___is_App : stack_elt -> Prims.bool) = - fun projectee -> match projectee with | App _0 -> true | uu___ -> false -let (__proj__App__item___0 : - stack_elt -> - (env * FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.aqual * - FStar_Compiler_Range_Type.range)) - = fun projectee -> match projectee with | App _0 -> _0 -let (uu___is_CBVApp : stack_elt -> Prims.bool) = - fun projectee -> match projectee with | CBVApp _0 -> true | uu___ -> false -let (__proj__CBVApp__item___0 : - stack_elt -> - (env * FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.aqual * - FStar_Compiler_Range_Type.range)) - = fun projectee -> match projectee with | CBVApp _0 -> _0 -let (uu___is_Meta : stack_elt -> Prims.bool) = - fun projectee -> match projectee with | Meta _0 -> true | uu___ -> false -let (__proj__Meta__item___0 : - stack_elt -> - (env * FStar_Syntax_Syntax.metadata * FStar_Compiler_Range_Type.range)) - = fun projectee -> match projectee with | Meta _0 -> _0 -let (uu___is_Let : stack_elt -> Prims.bool) = - fun projectee -> match projectee with | Let _0 -> true | uu___ -> false -let (__proj__Let__item___0 : - stack_elt -> - (env * FStar_Syntax_Syntax.binders * FStar_Syntax_Syntax.letbinding * - FStar_Compiler_Range_Type.range)) - = fun projectee -> match projectee with | Let _0 -> _0 -type stack = stack_elt Prims.list -let (head_of : FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = - fun t -> - let uu___ = FStar_Syntax_Util.head_and_args_full t in - match uu___ with | (hd, uu___1) -> hd -let (cfg_equivalent : - FStar_TypeChecker_Cfg.cfg -> FStar_TypeChecker_Cfg.cfg -> Prims.bool) = - fun c1 -> - fun c2 -> - ((FStar_Class_Deq.op_Equals_Question FStar_TypeChecker_Cfg.deq_fsteps - c1.FStar_TypeChecker_Cfg.steps c2.FStar_TypeChecker_Cfg.steps) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Deq.deq_list FStar_TypeChecker_Env.deq_delta_level) - c1.FStar_TypeChecker_Cfg.delta_level - c2.FStar_TypeChecker_Cfg.delta_level)) - && - (FStar_Class_Deq.op_Equals_Question - (FStar_Class_Ord.ord_eq FStar_Class_Ord.ord_bool) - c1.FStar_TypeChecker_Cfg.normalize_pure_lets - c2.FStar_TypeChecker_Cfg.normalize_pure_lets) -let read_memo : - 'a . - FStar_TypeChecker_Cfg.cfg -> - (FStar_TypeChecker_Cfg.cfg * 'a) FStar_Syntax_Syntax.memo -> - 'a FStar_Pervasives_Native.option - = - fun cfg -> - fun r -> - let uu___ = FStar_Compiler_Effect.op_Bang r in - match uu___ with - | FStar_Pervasives_Native.Some (cfg', a1) when - (cfg.FStar_TypeChecker_Cfg.compat_memo_ignore_cfg || - (FStar_Compiler_Util.physical_equality cfg cfg')) - || (cfg_equivalent cfg' cfg) - -> FStar_Pervasives_Native.Some a1 - | uu___1 -> FStar_Pervasives_Native.None -let set_memo : - 'a . - FStar_TypeChecker_Cfg.cfg -> - (FStar_TypeChecker_Cfg.cfg * 'a) FStar_Syntax_Syntax.memo -> 'a -> unit - = - fun cfg -> - fun r -> - fun t -> - if cfg.FStar_TypeChecker_Cfg.memoize_lazy - then - ((let uu___1 = - let uu___2 = read_memo cfg r in - FStar_Compiler_Option.isSome uu___2 in - if uu___1 - then failwith "Unexpected set_memo: thunk already evaluated" - else ()); - FStar_Compiler_Effect.op_Colon_Equals r - (FStar_Pervasives_Native.Some (cfg, t))) - else () -let (closure_to_string : closure -> Prims.string) = - fun uu___ -> - match uu___ with - | Clos (env1, t, uu___1, uu___2) -> - let uu___3 = - FStar_Compiler_Util.string_of_int (FStar_Compiler_List.length env1) in - let uu___4 = FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.format2 "(env=%s elts; %s)" uu___3 uu___4 - | Univ uu___1 -> "Univ" - | Dummy -> "dummy" -let (showable_closure : closure FStar_Class_Show.showable) = - { FStar_Class_Show.show = closure_to_string } -let (showable_stack_elt : stack_elt FStar_Class_Show.showable) = - { - FStar_Class_Show.show = - (fun uu___ -> - match uu___ with - | Arg (c, uu___1, uu___2) -> - let uu___3 = FStar_Class_Show.show showable_closure c in - FStar_Compiler_Util.format1 "Closure %s" uu___3 - | MemoLazy uu___1 -> "MemoLazy" - | Abs (uu___1, bs, uu___2, uu___3, uu___4) -> - let uu___5 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_nat) - (FStar_Compiler_List.length bs) in - FStar_Compiler_Util.format1 "Abs %s" uu___5 - | UnivArgs uu___1 -> "UnivArgs" - | Match uu___1 -> "Match" - | App (uu___1, t, uu___2, uu___3) -> - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.format1 "App %s" uu___4 - | CBVApp (uu___1, t, uu___2, uu___3) -> - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.format1 "CBVApp %s" uu___4 - | Meta (uu___1, m, uu___2) -> "Meta" - | Let uu___1 -> "Let") - } -let is_empty : 'uuuuu . 'uuuuu Prims.list -> Prims.bool = - fun uu___ -> match uu___ with | [] -> true | uu___1 -> false -let (lookup_bvar : env -> FStar_Syntax_Syntax.bv -> closure) = - fun env1 -> - fun x -> - try - (fun uu___ -> - match () with - | () -> - let uu___1 = - FStar_Compiler_List.nth env1 x.FStar_Syntax_Syntax.index in - FStar_Pervasives_Native.__proj__Mktuple3__item___2 uu___1) () - with - | uu___ -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_bv x in - let uu___3 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - (FStar_Class_Show.show_tuple3 - (FStar_Class_Show.show_option - FStar_Syntax_Print.showable_binder) showable_closure - (showable_memo - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_subst_elt)))) env1 in - FStar_Compiler_Util.format2 "Failed to find %s\nEnv is %s\n" - uu___2 uu___3 in - failwith uu___1 -let (downgrade_ghost_effect_name : - FStar_Ident.lident -> FStar_Ident.lident FStar_Pervasives_Native.option) = - fun l -> - let uu___ = FStar_Ident.lid_equals l FStar_Parser_Const.effect_Ghost_lid in - if uu___ - then FStar_Pervasives_Native.Some FStar_Parser_Const.effect_Pure_lid - else - (let uu___2 = - FStar_Ident.lid_equals l FStar_Parser_Const.effect_GTot_lid in - if uu___2 - then FStar_Pervasives_Native.Some FStar_Parser_Const.effect_Tot_lid - else - (let uu___4 = - FStar_Ident.lid_equals l FStar_Parser_Const.effect_GHOST_lid in - if uu___4 - then - FStar_Pervasives_Native.Some FStar_Parser_Const.effect_PURE_lid - else FStar_Pervasives_Native.None)) -let (norm_universe : - FStar_TypeChecker_Cfg.cfg -> - env -> FStar_Syntax_Syntax.universe -> FStar_Syntax_Syntax.universe) - = - fun cfg -> - fun env1 -> - fun u -> - let norm_univs_for_max us = - let us1 = - FStar_Compiler_Util.sort_with FStar_Syntax_Util.compare_univs us in - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun u1 -> - match uu___1 with - | (cur_kernel, cur_max, out) -> - let uu___2 = FStar_Syntax_Util.univ_kernel u1 in - (match uu___2 with - | (k_u, n) -> - let uu___3 = - FStar_Syntax_Util.eq_univs cur_kernel k_u in - if uu___3 - then (cur_kernel, u1, out) - else (k_u, u1, (cur_max :: out)))) - (FStar_Syntax_Syntax.U_zero, FStar_Syntax_Syntax.U_zero, []) - us1 in - match uu___ with - | (uu___1, u1, out) -> FStar_Compiler_List.rev (u1 :: out) in - let rec aux u1 = - let u2 = FStar_Syntax_Subst.compress_univ u1 in - match u2 with - | FStar_Syntax_Syntax.U_bvar x -> - (try - (fun uu___ -> - match () with - | () -> - let uu___1 = - let uu___2 = FStar_Compiler_List.nth env1 x in - FStar_Pervasives_Native.__proj__Mktuple3__item___2 - uu___2 in - (match uu___1 with - | Univ u3 -> - ((let uu___3 = - FStar_Compiler_Effect.op_Bang dbg_univ_norm in - if uu___3 - then - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_univ u3 in - FStar_Compiler_Util.print1 - "Univ (in norm_universe): %s\n" uu___4 - else ()); - aux u3) - | Dummy -> [u2] - | uu___2 -> - let uu___3 = - let uu___4 = - FStar_Compiler_Util.string_of_int x in - FStar_Compiler_Util.format1 - "Impossible: universe variable u@%s bound to a term" - uu___4 in - failwith uu___3)) () - with - | uu___ -> - if - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.allow_unbound_universes - then [FStar_Syntax_Syntax.U_unknown] - else - (let uu___2 = - let uu___3 = FStar_Compiler_Util.string_of_int x in - Prims.strcat "Universe variable not found: u@" uu___3 in - failwith uu___2)) - | FStar_Syntax_Syntax.U_unif uu___ when - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.default_univs_to_zero - -> [FStar_Syntax_Syntax.U_zero] - | FStar_Syntax_Syntax.U_unif uu___ when - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.check_no_uvars - -> - let uu___1 = - let uu___2 = - let uu___3 = - FStar_TypeChecker_Env.get_range - cfg.FStar_TypeChecker_Cfg.tcenv in - FStar_Compiler_Range_Ops.string_of_range uu___3 in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_univ u2 in - FStar_Compiler_Util.format2 - "(%s) CheckNoUvars: unexpected universes variable remains: %s" - uu___2 uu___3 in - failwith uu___1 - | FStar_Syntax_Syntax.U_zero -> [u2] - | FStar_Syntax_Syntax.U_unif uu___ -> [u2] - | FStar_Syntax_Syntax.U_name uu___ -> [u2] - | FStar_Syntax_Syntax.U_unknown -> [u2] - | FStar_Syntax_Syntax.U_max [] -> [FStar_Syntax_Syntax.U_zero] - | FStar_Syntax_Syntax.U_max us -> - let us1 = - let uu___ = FStar_Compiler_List.collect aux us in - norm_univs_for_max uu___ in - (match us1 with - | u_k::hd::rest -> - let rest1 = hd :: rest in - let uu___ = FStar_Syntax_Util.univ_kernel u_k in - (match uu___ with - | (FStar_Syntax_Syntax.U_zero, n) -> - let uu___1 = - FStar_Compiler_List.for_all - (fun u3 -> - let uu___2 = FStar_Syntax_Util.univ_kernel u3 in - match uu___2 with | (uu___3, m) -> n <= m) - rest1 in - if uu___1 then rest1 else us1 - | uu___1 -> us1) - | uu___ -> us1) - | FStar_Syntax_Syntax.U_succ u3 -> - let uu___ = aux u3 in - FStar_Compiler_List.map - (fun uu___1 -> FStar_Syntax_Syntax.U_succ uu___1) uu___ in - if - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.erase_universes - then FStar_Syntax_Syntax.U_unknown - else - (let uu___1 = aux u in - match uu___1 with - | [] -> FStar_Syntax_Syntax.U_zero - | (FStar_Syntax_Syntax.U_zero)::[] -> FStar_Syntax_Syntax.U_zero - | (FStar_Syntax_Syntax.U_zero)::u1::[] -> u1 - | (FStar_Syntax_Syntax.U_zero)::us -> FStar_Syntax_Syntax.U_max us - | u1::[] -> u1 - | us -> FStar_Syntax_Syntax.U_max us) -let memo_or : 'a . 'a FStar_Syntax_Syntax.memo -> (unit -> 'a) -> 'a = - fun m -> - fun f -> - let uu___ = FStar_Compiler_Effect.op_Bang m in - match uu___ with - | FStar_Pervasives_Native.Some v -> v - | FStar_Pervasives_Native.None -> - let v = f () in - (FStar_Compiler_Effect.op_Colon_Equals m - (FStar_Pervasives_Native.Some v); - v) -let rec (env_subst : env -> FStar_Syntax_Syntax.subst_t) = - fun env1 -> - let compute uu___ = - let uu___1 = - FStar_Compiler_List.fold_left - (fun uu___2 -> - fun uu___3 -> - match (uu___2, uu___3) with - | ((s, i), (uu___4, c, uu___5)) -> - (match c with - | Clos (e, t, memo, fix) -> - let es = env_subst e in - let t1 = - let uu___6 = FStar_Syntax_Subst.subst es t in - FStar_Syntax_Subst.compress uu___6 in - (((FStar_Syntax_Syntax.DT (i, t1)) :: s), - (i + Prims.int_one)) - | Univ u -> - (((FStar_Syntax_Syntax.UN (i, u)) :: s), - (i + Prims.int_one)) - | Dummy -> (s, (i + Prims.int_one)))) - ([], Prims.int_zero) env1 in - match uu___1 with | (s, uu___2) -> s in - match env1 with - | [] -> [] - | (uu___, uu___1, memo)::uu___2 -> - let uu___3 = FStar_Compiler_Effect.op_Bang memo in - (match uu___3 with - | FStar_Pervasives_Native.Some s -> s - | FStar_Pervasives_Native.None -> - let s = compute () in - (FStar_Compiler_Effect.op_Colon_Equals memo - (FStar_Pervasives_Native.Some s); - s)) -let (filter_out_lcomp_cflags : - FStar_Syntax_Syntax.cflag Prims.list -> - FStar_Syntax_Syntax.cflag Prims.list) - = - fun flags -> - FStar_Compiler_List.filter - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.DECREASES uu___1 -> false - | uu___1 -> true) flags -let (default_univ_uvars_to_zero : - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = - fun t -> - FStar_Syntax_Visit.visit_term_univs false (fun t1 -> t1) - (fun u -> - match u with - | FStar_Syntax_Syntax.U_unif uu___ -> FStar_Syntax_Syntax.U_zero - | uu___ -> u) t -let (_erase_universes : FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun t -> - FStar_Syntax_Visit.visit_term_univs false (fun t1 -> t1) - (fun u -> FStar_Syntax_Syntax.U_unknown) t -let (closure_as_term : - FStar_TypeChecker_Cfg.cfg -> - env -> FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun cfg -> - fun env1 -> - fun t -> - FStar_TypeChecker_Cfg.log cfg - (fun uu___1 -> - let uu___2 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t in - let uu___3 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - (FStar_Class_Show.show_tuple3 - (FStar_Class_Show.show_option - FStar_Syntax_Print.showable_binder) - showable_closure - (showable_memo - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_subst_elt)))) env1 in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.print3 - ">>> %s (env=%s)\nClosure_as_term %s\n" uu___2 uu___3 uu___4); - (let es = env_subst env1 in - let t1 = FStar_Syntax_Subst.subst es t in - let t2 = - if - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.erase_universes - then _erase_universes t1 - else - if - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.default_univs_to_zero - then default_univ_uvars_to_zero t1 - else t1 in - let t3 = FStar_Syntax_Subst.compress t2 in - FStar_TypeChecker_Cfg.log cfg - (fun uu___2 -> - let uu___3 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t3 in - let uu___4 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - (FStar_Class_Show.show_tuple3 - (FStar_Class_Show.show_option - FStar_Syntax_Print.showable_binder) - showable_closure - (showable_memo - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_subst_elt)))) env1 in - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t3 in - FStar_Compiler_Util.print3 - ">>> %s (env=%s)\nClosure_as_term RESULT %s\n" uu___3 uu___4 - uu___5); - t3) -let (unembed_binder_knot : - FStar_Syntax_Syntax.binder FStar_Syntax_Embeddings_Base.embedding - FStar_Pervasives_Native.option FStar_Compiler_Effect.ref) - = FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None -let (unembed_binder : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.binder FStar_Pervasives_Native.option) - = - fun t -> - let uu___ = FStar_Compiler_Effect.op_Bang unembed_binder_knot in - match uu___ with - | FStar_Pervasives_Native.Some e -> - FStar_Syntax_Embeddings_Base.try_unembed e t - FStar_Syntax_Embeddings_Base.id_norm_cb - | FStar_Pervasives_Native.None -> - (FStar_Errors.log_issue (FStar_Syntax_Syntax.has_range_syntax ()) t - FStar_Errors_Codes.Warning_UnembedBinderKnot () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic "unembed_binder_knot is unset!"); - FStar_Pervasives_Native.None) -let (mk_psc_subst : - FStar_TypeChecker_Cfg.cfg -> - env -> FStar_Syntax_Syntax.subst_elt Prims.list) - = - fun cfg -> - fun env1 -> - FStar_Compiler_List.fold_right - (fun uu___ -> - fun subst -> - match uu___ with - | (binder_opt, closure1, uu___1) -> - (match (binder_opt, closure1) with - | (FStar_Pervasives_Native.Some b, Clos - (env2, term, uu___2, uu___3)) -> - let bv = b.FStar_Syntax_Syntax.binder_bv in - let uu___4 = - let uu___5 = - FStar_Syntax_Util.is_constructed_typ - bv.FStar_Syntax_Syntax.sort - FStar_Parser_Const.binder_lid in - Prims.op_Negation uu___5 in - if uu___4 - then subst - else - (let term1 = closure_as_term cfg env2 term in - let uu___6 = unembed_binder term1 in - match uu___6 with - | FStar_Pervasives_Native.None -> subst - | FStar_Pervasives_Native.Some x -> - let b1 = - let uu___7 = - let uu___8 = - FStar_Syntax_Subst.subst subst - (x.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - { - FStar_Syntax_Syntax.ppname = - (bv.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (bv.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = uu___8 - } in - FStar_Syntax_Syntax.freshen_bv uu___7 in - let b_for_x = - let uu___7 = - let uu___8 = - FStar_Syntax_Syntax.bv_to_name b1 in - ((x.FStar_Syntax_Syntax.binder_bv), uu___8) in - FStar_Syntax_Syntax.NT uu___7 in - let subst1 = - FStar_Compiler_List.filter - (fun uu___7 -> - match uu___7 with - | FStar_Syntax_Syntax.NT - (uu___8, - { - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_name b'; - FStar_Syntax_Syntax.pos = uu___9; - FStar_Syntax_Syntax.vars = uu___10; - FStar_Syntax_Syntax.hash_code = - uu___11;_}) - -> - let uu___12 = - FStar_Ident.ident_equals - b1.FStar_Syntax_Syntax.ppname - b'.FStar_Syntax_Syntax.ppname in - Prims.op_Negation uu___12 - | uu___8 -> true) subst in - b_for_x :: subst1) - | uu___2 -> subst)) env1 [] -let (reduce_primops : - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_TypeChecker_Cfg.cfg -> - env -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - (FStar_Syntax_Syntax.term * Prims.bool)) - = - fun norm_cb -> - fun cfg -> - fun env1 -> - fun tm -> - if - Prims.op_Negation - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.primops - then (tm, false) - else - (let uu___1 = FStar_Syntax_Util.head_and_args_full tm in - match uu___1 with - | (head, args) -> - let uu___2 = - let head1 = - let uu___3 = FStar_Syntax_Util.unmeta head in - FStar_Syntax_Subst.compress uu___3 in - match head1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_uinst (fv, us) -> (fv, us) - | uu___3 -> (head1, []) in - (match uu___2 with - | (head_term, universes) -> - (match head_term.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_fvar fv -> - let uu___3 = - FStar_TypeChecker_Cfg.find_prim_step cfg fv in - (match uu___3 with - | FStar_Pervasives_Native.Some prim_step when - prim_step.FStar_TypeChecker_Primops_Base.strong_reduction_ok - || - (Prims.op_Negation - cfg.FStar_TypeChecker_Cfg.strong) - -> - let l = FStar_Compiler_List.length args in - if - l < - prim_step.FStar_TypeChecker_Primops_Base.arity - then - (FStar_TypeChecker_Cfg.log_primops cfg - (fun uu___5 -> - let uu___6 = - FStar_Class_Show.show - FStar_Ident.showable_lident - prim_step.FStar_TypeChecker_Primops_Base.name in - let uu___7 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_nat) - l in - let uu___8 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - prim_step.FStar_TypeChecker_Primops_Base.arity in - FStar_Compiler_Util.print3 - "primop: found partially applied %s (%s/%s args)\n" - uu___6 uu___7 uu___8); - (tm, false)) - else - (let uu___5 = - if - l = - prim_step.FStar_TypeChecker_Primops_Base.arity - then (args, []) - else - FStar_Compiler_List.splitAt - prim_step.FStar_TypeChecker_Primops_Base.arity - args in - match uu___5 with - | (args_1, args_2) -> - (FStar_TypeChecker_Cfg.log_primops cfg - (fun uu___7 -> - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - tm in - FStar_Compiler_Util.print1 - "primop: trying to reduce <%s>\n" - uu___8); - (let psc = - { - FStar_TypeChecker_Primops_Base.psc_range - = - (head.FStar_Syntax_Syntax.pos); - FStar_TypeChecker_Primops_Base.psc_subst - = - (fun uu___7 -> - if - prim_step.FStar_TypeChecker_Primops_Base.requires_binder_substitution - then mk_psc_subst cfg env1 - else []) - } in - let r = - prim_step.FStar_TypeChecker_Primops_Base.interpretation - psc norm_cb universes args_1 in - match r with - | FStar_Pervasives_Native.None -> - (FStar_TypeChecker_Cfg.log_primops - cfg - (fun uu___8 -> - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - tm in - FStar_Compiler_Util.print1 - "primop: <%s> did not reduce\n" - uu___9); - (tm, false)) - | FStar_Pervasives_Native.Some - reduced -> - (FStar_TypeChecker_Cfg.log_primops - cfg - (fun uu___8 -> - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - tm in - let uu___10 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - reduced in - FStar_Compiler_Util.print2 - "primop: <%s> reduced to %s\n" - uu___9 uu___10); - (let uu___8 = - FStar_Syntax_Util.mk_app - reduced args_2 in - (uu___8, - (prim_step.FStar_TypeChecker_Primops_Base.renorm_after))))))) - | FStar_Pervasives_Native.Some uu___4 -> - (FStar_TypeChecker_Cfg.log_primops cfg - (fun uu___6 -> - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term tm in - FStar_Compiler_Util.print1 - "primop: not reducing <%s> since we're doing strong reduction\n" - uu___7); - (tm, false)) - | FStar_Pervasives_Native.None -> (tm, false)) - | FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_range_of) when - Prims.op_Negation cfg.FStar_TypeChecker_Cfg.strong - -> - (FStar_TypeChecker_Cfg.log_primops cfg - (fun uu___4 -> - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term tm in - FStar_Compiler_Util.print1 - "primop: reducing <%s>\n" uu___5); - (match args with - | (a1, uu___4)::[] -> - let uu___5 = - FStar_TypeChecker_Primops_Base.embed_simple - FStar_Syntax_Embeddings.e_range - a1.FStar_Syntax_Syntax.pos - tm.FStar_Syntax_Syntax.pos in - (uu___5, false) - | uu___4 -> (tm, false))) - | FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_set_range_of) when - Prims.op_Negation cfg.FStar_TypeChecker_Cfg.strong - -> - (FStar_TypeChecker_Cfg.log_primops cfg - (fun uu___4 -> - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term tm in - FStar_Compiler_Util.print1 - "primop: reducing <%s>\n" uu___5); - (match args with - | (t, uu___4)::(r, uu___5)::[] -> - let uu___6 = - FStar_TypeChecker_Primops_Base.try_unembed_simple - FStar_Syntax_Embeddings.e_range r in - (match uu___6 with - | FStar_Pervasives_Native.Some rng -> - let uu___7 = - FStar_Syntax_Subst.set_use_range rng - t in - (uu___7, false) - | FStar_Pervasives_Native.None -> - (tm, false)) - | uu___4 -> (tm, false))) - | uu___3 -> (tm, false)))) -let (reduce_equality : - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_TypeChecker_Cfg.cfg -> - env -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - (FStar_Syntax_Syntax.term * Prims.bool)) - = - fun norm_cb -> - fun cfg -> - fun tm -> - let uu___ = - let uu___1 = - FStar_TypeChecker_Cfg.simplification_steps - cfg.FStar_TypeChecker_Cfg.tcenv in - { - FStar_TypeChecker_Cfg.steps = - { - FStar_TypeChecker_Cfg.beta = - (FStar_TypeChecker_Cfg.default_steps.FStar_TypeChecker_Cfg.beta); - FStar_TypeChecker_Cfg.iota = - (FStar_TypeChecker_Cfg.default_steps.FStar_TypeChecker_Cfg.iota); - FStar_TypeChecker_Cfg.zeta = - (FStar_TypeChecker_Cfg.default_steps.FStar_TypeChecker_Cfg.zeta); - FStar_TypeChecker_Cfg.zeta_full = - (FStar_TypeChecker_Cfg.default_steps.FStar_TypeChecker_Cfg.zeta_full); - FStar_TypeChecker_Cfg.weak = - (FStar_TypeChecker_Cfg.default_steps.FStar_TypeChecker_Cfg.weak); - FStar_TypeChecker_Cfg.hnf = - (FStar_TypeChecker_Cfg.default_steps.FStar_TypeChecker_Cfg.hnf); - FStar_TypeChecker_Cfg.primops = true; - FStar_TypeChecker_Cfg.do_not_unfold_pure_lets = - (FStar_TypeChecker_Cfg.default_steps.FStar_TypeChecker_Cfg.do_not_unfold_pure_lets); - FStar_TypeChecker_Cfg.unfold_until = - (FStar_TypeChecker_Cfg.default_steps.FStar_TypeChecker_Cfg.unfold_until); - FStar_TypeChecker_Cfg.unfold_only = - (FStar_TypeChecker_Cfg.default_steps.FStar_TypeChecker_Cfg.unfold_only); - FStar_TypeChecker_Cfg.unfold_fully = - (FStar_TypeChecker_Cfg.default_steps.FStar_TypeChecker_Cfg.unfold_fully); - FStar_TypeChecker_Cfg.unfold_attr = - (FStar_TypeChecker_Cfg.default_steps.FStar_TypeChecker_Cfg.unfold_attr); - FStar_TypeChecker_Cfg.unfold_qual = - (FStar_TypeChecker_Cfg.default_steps.FStar_TypeChecker_Cfg.unfold_qual); - FStar_TypeChecker_Cfg.unfold_namespace = - (FStar_TypeChecker_Cfg.default_steps.FStar_TypeChecker_Cfg.unfold_namespace); - FStar_TypeChecker_Cfg.dont_unfold_attr = - (FStar_TypeChecker_Cfg.default_steps.FStar_TypeChecker_Cfg.dont_unfold_attr); - FStar_TypeChecker_Cfg.pure_subterms_within_computations = - (FStar_TypeChecker_Cfg.default_steps.FStar_TypeChecker_Cfg.pure_subterms_within_computations); - FStar_TypeChecker_Cfg.simplify = - (FStar_TypeChecker_Cfg.default_steps.FStar_TypeChecker_Cfg.simplify); - FStar_TypeChecker_Cfg.erase_universes = - (FStar_TypeChecker_Cfg.default_steps.FStar_TypeChecker_Cfg.erase_universes); - FStar_TypeChecker_Cfg.allow_unbound_universes = - (FStar_TypeChecker_Cfg.default_steps.FStar_TypeChecker_Cfg.allow_unbound_universes); - FStar_TypeChecker_Cfg.reify_ = - (FStar_TypeChecker_Cfg.default_steps.FStar_TypeChecker_Cfg.reify_); - FStar_TypeChecker_Cfg.compress_uvars = - (FStar_TypeChecker_Cfg.default_steps.FStar_TypeChecker_Cfg.compress_uvars); - FStar_TypeChecker_Cfg.no_full_norm = - (FStar_TypeChecker_Cfg.default_steps.FStar_TypeChecker_Cfg.no_full_norm); - FStar_TypeChecker_Cfg.check_no_uvars = - (FStar_TypeChecker_Cfg.default_steps.FStar_TypeChecker_Cfg.check_no_uvars); - FStar_TypeChecker_Cfg.unmeta = - (FStar_TypeChecker_Cfg.default_steps.FStar_TypeChecker_Cfg.unmeta); - FStar_TypeChecker_Cfg.unascribe = - (FStar_TypeChecker_Cfg.default_steps.FStar_TypeChecker_Cfg.unascribe); - FStar_TypeChecker_Cfg.in_full_norm_request = - (FStar_TypeChecker_Cfg.default_steps.FStar_TypeChecker_Cfg.in_full_norm_request); - FStar_TypeChecker_Cfg.weakly_reduce_scrutinee = - (FStar_TypeChecker_Cfg.default_steps.FStar_TypeChecker_Cfg.weakly_reduce_scrutinee); - FStar_TypeChecker_Cfg.nbe_step = - (FStar_TypeChecker_Cfg.default_steps.FStar_TypeChecker_Cfg.nbe_step); - FStar_TypeChecker_Cfg.for_extraction = - (FStar_TypeChecker_Cfg.default_steps.FStar_TypeChecker_Cfg.for_extraction); - FStar_TypeChecker_Cfg.unrefine = - (FStar_TypeChecker_Cfg.default_steps.FStar_TypeChecker_Cfg.unrefine); - FStar_TypeChecker_Cfg.default_univs_to_zero = - (FStar_TypeChecker_Cfg.default_steps.FStar_TypeChecker_Cfg.default_univs_to_zero); - FStar_TypeChecker_Cfg.tactics = - (FStar_TypeChecker_Cfg.default_steps.FStar_TypeChecker_Cfg.tactics) - }; - FStar_TypeChecker_Cfg.tcenv = (cfg.FStar_TypeChecker_Cfg.tcenv); - FStar_TypeChecker_Cfg.debug = (cfg.FStar_TypeChecker_Cfg.debug); - FStar_TypeChecker_Cfg.delta_level = - (cfg.FStar_TypeChecker_Cfg.delta_level); - FStar_TypeChecker_Cfg.primitive_steps = uu___1; - FStar_TypeChecker_Cfg.strong = (cfg.FStar_TypeChecker_Cfg.strong); - FStar_TypeChecker_Cfg.memoize_lazy = - (cfg.FStar_TypeChecker_Cfg.memoize_lazy); - FStar_TypeChecker_Cfg.normalize_pure_lets = - (cfg.FStar_TypeChecker_Cfg.normalize_pure_lets); - FStar_TypeChecker_Cfg.reifying = - (cfg.FStar_TypeChecker_Cfg.reifying); - FStar_TypeChecker_Cfg.compat_memo_ignore_cfg = - (cfg.FStar_TypeChecker_Cfg.compat_memo_ignore_cfg) - } in - reduce_primops norm_cb uu___ tm -type norm_request_t = - | Norm_request_none - | Norm_request_ready - | Norm_request_requires_rejig -let (uu___is_Norm_request_none : norm_request_t -> Prims.bool) = - fun projectee -> - match projectee with | Norm_request_none -> true | uu___ -> false -let (uu___is_Norm_request_ready : norm_request_t -> Prims.bool) = - fun projectee -> - match projectee with | Norm_request_ready -> true | uu___ -> false -let (uu___is_Norm_request_requires_rejig : norm_request_t -> Prims.bool) = - fun projectee -> - match projectee with - | Norm_request_requires_rejig -> true - | uu___ -> false -let (is_norm_request : - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.args -> norm_request_t) = - fun hd -> - fun args -> - let aux min_args = - if (FStar_Compiler_List.length args) < min_args - then Norm_request_none - else - if (FStar_Compiler_List.length args) = min_args - then Norm_request_ready - else Norm_request_requires_rejig in - let uu___ = - let uu___1 = FStar_Syntax_Util.un_uinst hd in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.normalize_term - -> aux (Prims.of_int (2)) - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.normalize -> - aux Prims.int_one - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.norm -> - aux (Prims.of_int (3)) - | uu___1 -> Norm_request_none -let (should_consider_norm_requests : FStar_TypeChecker_Cfg.cfg -> Prims.bool) - = - fun cfg -> - (Prims.op_Negation - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.no_full_norm) - && - (let uu___ = - FStar_Ident.lid_equals - (cfg.FStar_TypeChecker_Cfg.tcenv).FStar_TypeChecker_Env.curmodule - FStar_Parser_Const.prims_lid in - Prims.op_Negation uu___) -let (rejig_norm_request : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.args -> FStar_Syntax_Syntax.term) - = - fun hd -> - fun args -> - let uu___ = - let uu___1 = FStar_Syntax_Util.un_uinst hd in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.normalize_term - -> - (match args with - | t1::t2::rest when - (FStar_Compiler_List.length rest) > Prims.int_zero -> - let uu___1 = FStar_Syntax_Util.mk_app hd [t1; t2] in - FStar_Syntax_Util.mk_app uu___1 rest - | uu___1 -> - failwith - "Impossible! invalid rejig_norm_request for normalize_term") - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.normalize -> - (match args with - | t::rest when (FStar_Compiler_List.length rest) > Prims.int_zero - -> - let uu___1 = FStar_Syntax_Util.mk_app hd [t] in - FStar_Syntax_Util.mk_app uu___1 rest - | uu___1 -> - failwith - "Impossible! invalid rejig_norm_request for normalize") - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.norm -> - (match args with - | t1::t2::t3::rest when - (FStar_Compiler_List.length rest) > Prims.int_zero -> - let uu___1 = FStar_Syntax_Util.mk_app hd [t1; t2; t3] in - FStar_Syntax_Util.mk_app uu___1 rest - | uu___1 -> - failwith "Impossible! invalid rejig_norm_request for norm") - | uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term hd in - Prims.strcat "Impossible! invalid rejig_norm_request for: %s" - uu___3 in - failwith uu___2 -let (is_nbe_request : FStar_TypeChecker_Env.step Prims.list -> Prims.bool) = - fun s -> - FStar_Compiler_Util.for_some - (FStar_Class_Deq.op_Equals_Question FStar_TypeChecker_Env.deq_step - FStar_TypeChecker_Env.NBE) s -let get_norm_request : - 'uuuuu . - FStar_TypeChecker_Cfg.cfg -> - (FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) -> - (FStar_Syntax_Syntax.term * 'uuuuu) Prims.list -> - (FStar_TypeChecker_Env.step Prims.list * FStar_Syntax_Syntax.term) - FStar_Pervasives_Native.option - = - fun cfg -> - fun full_norm -> - fun args -> - let parse_steps s = - let uu___ = - FStar_TypeChecker_Primops_Base.try_unembed_simple - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_norm_step) s in - match uu___ with - | FStar_Pervasives_Native.Some steps -> - let uu___1 = FStar_TypeChecker_Cfg.translate_norm_steps steps in - FStar_Pervasives_Native.Some uu___1 - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None in - let inherited_steps = - FStar_Compiler_List.op_At - (if - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.erase_universes - then [FStar_TypeChecker_Env.EraseUniverses] - else []) - (FStar_Compiler_List.op_At - (if - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.allow_unbound_universes - then [FStar_TypeChecker_Env.AllowUnboundUniverses] - else []) - (if - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.nbe_step - then [FStar_TypeChecker_Env.NBE] - else [])) in - match args with - | uu___::(tm, uu___1)::[] -> - let s = - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Zeta; - FStar_TypeChecker_Env.Iota; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Reify] in - FStar_Pervasives_Native.Some - ((FStar_Compiler_List.op_At - ((FStar_TypeChecker_Env.DontUnfoldAttr - [FStar_Parser_Const.tac_opaque_attr]) :: - inherited_steps) s), tm) - | (tm, uu___)::[] -> - let s = - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Zeta; - FStar_TypeChecker_Env.Iota; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Reify] in - FStar_Pervasives_Native.Some - ((FStar_Compiler_List.op_At - ((FStar_TypeChecker_Env.DontUnfoldAttr - [FStar_Parser_Const.tac_opaque_attr]) :: - inherited_steps) s), tm) - | (steps, uu___)::uu___1::(tm, uu___2)::[] -> - let uu___3 = let uu___4 = full_norm steps in parse_steps uu___4 in - (match uu___3 with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some s -> - FStar_Pervasives_Native.Some - ((FStar_Compiler_List.op_At - ((FStar_TypeChecker_Env.DontUnfoldAttr - [FStar_Parser_Const.tac_opaque_attr]) :: - inherited_steps) s), tm)) - | uu___ -> FStar_Pervasives_Native.None -let (nbe_eval : - FStar_TypeChecker_Cfg.cfg -> - FStar_TypeChecker_Env.steps -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun cfg -> - fun s -> - fun tm -> - let delta_level = - let uu___ = - FStar_Compiler_Util.for_some - (fun uu___1 -> - match uu___1 with - | FStar_TypeChecker_Env.UnfoldUntil uu___2 -> true - | FStar_TypeChecker_Env.UnfoldOnly uu___2 -> true - | FStar_TypeChecker_Env.UnfoldFully uu___2 -> true - | uu___2 -> false) s in - if uu___ - then - [FStar_TypeChecker_Env.Unfold FStar_Syntax_Syntax.delta_constant] - else [FStar_TypeChecker_Env.NoDelta] in - FStar_TypeChecker_Cfg.log_nbe cfg - (fun uu___1 -> - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term tm in - FStar_Compiler_Util.print1 "Invoking NBE with %s\n" uu___2); - (let tm_norm = - let uu___1 = FStar_TypeChecker_Cfg.cfg_env cfg in - uu___1.FStar_TypeChecker_Env.nbe s cfg.FStar_TypeChecker_Cfg.tcenv - tm in - FStar_TypeChecker_Cfg.log_nbe cfg - (fun uu___2 -> - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - tm_norm in - FStar_Compiler_Util.print1 "Result of NBE is %s\n" uu___3); - tm_norm) -let firstn : - 'uuuuu . - Prims.int -> 'uuuuu Prims.list -> ('uuuuu Prims.list * 'uuuuu Prims.list) - = - fun k -> - fun l -> - if (FStar_Compiler_List.length l) < k - then (l, []) - else FStar_Compiler_Util.first_N k l -let (should_reify : - FStar_TypeChecker_Cfg.cfg -> stack_elt Prims.list -> Prims.bool) = - fun cfg -> - fun stack1 -> - let rec drop_irrel uu___ = - match uu___ with - | (MemoLazy uu___1)::s -> drop_irrel s - | (UnivArgs uu___1)::s -> drop_irrel s - | s -> s in - let uu___ = drop_irrel stack1 in - match uu___ with - | (App - (uu___1, - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_reify uu___2); - FStar_Syntax_Syntax.pos = uu___3; - FStar_Syntax_Syntax.vars = uu___4; - FStar_Syntax_Syntax.hash_code = uu___5;_}, - uu___6, uu___7))::uu___8 - -> (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.reify_ - | uu___1 -> false -let rec (maybe_weakly_reduced : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> Prims.bool) = - fun tm -> - let aux_comp c = - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.GTotal t -> maybe_weakly_reduced t - | FStar_Syntax_Syntax.Total t -> maybe_weakly_reduced t - | FStar_Syntax_Syntax.Comp ct -> - (maybe_weakly_reduced ct.FStar_Syntax_Syntax.result_typ) || - (FStar_Compiler_Util.for_some - (fun uu___ -> - match uu___ with | (a, uu___1) -> maybe_weakly_reduced a) - ct.FStar_Syntax_Syntax.effect_args) in - let t = FStar_Syntax_Subst.compress tm in - match t.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_delayed uu___ -> failwith "Impossible" - | FStar_Syntax_Syntax.Tm_name uu___ -> false - | FStar_Syntax_Syntax.Tm_uvar uu___ -> false - | FStar_Syntax_Syntax.Tm_type uu___ -> false - | FStar_Syntax_Syntax.Tm_bvar uu___ -> false - | FStar_Syntax_Syntax.Tm_fvar uu___ -> false - | FStar_Syntax_Syntax.Tm_constant uu___ -> false - | FStar_Syntax_Syntax.Tm_lazy uu___ -> false - | FStar_Syntax_Syntax.Tm_unknown -> false - | FStar_Syntax_Syntax.Tm_uinst uu___ -> false - | FStar_Syntax_Syntax.Tm_quoted uu___ -> false - | FStar_Syntax_Syntax.Tm_let uu___ -> true - | FStar_Syntax_Syntax.Tm_abs uu___ -> true - | FStar_Syntax_Syntax.Tm_arrow uu___ -> true - | FStar_Syntax_Syntax.Tm_refine uu___ -> true - | FStar_Syntax_Syntax.Tm_match uu___ -> true - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = t1; FStar_Syntax_Syntax.args = args;_} -> - (maybe_weakly_reduced t1) || - (FStar_Compiler_Util.for_some - (fun uu___ -> - match uu___ with | (a, uu___1) -> maybe_weakly_reduced a) - args) - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t1; FStar_Syntax_Syntax.asc = asc; - FStar_Syntax_Syntax.eff_opt = uu___;_} - -> - (maybe_weakly_reduced t1) || - (let uu___1 = asc in - (match uu___1 with - | (asc_tc, asc_tac, uu___2) -> - (match asc_tc with - | FStar_Pervasives.Inl t2 -> maybe_weakly_reduced t2 - | FStar_Pervasives.Inr c2 -> aux_comp c2) || - ((match asc_tac with - | FStar_Pervasives_Native.None -> false - | FStar_Pervasives_Native.Some tac -> - maybe_weakly_reduced tac)))) - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t1; FStar_Syntax_Syntax.meta = m;_} -> - (maybe_weakly_reduced t1) || - ((match m with - | FStar_Syntax_Syntax.Meta_pattern (uu___, args) -> - FStar_Compiler_Util.for_some - (FStar_Compiler_Util.for_some - (fun uu___1 -> - match uu___1 with - | (a, uu___2) -> maybe_weakly_reduced a)) args - | FStar_Syntax_Syntax.Meta_monadic_lift (uu___, uu___1, t') -> - maybe_weakly_reduced t' - | FStar_Syntax_Syntax.Meta_monadic (uu___, t') -> - maybe_weakly_reduced t' - | FStar_Syntax_Syntax.Meta_labeled uu___ -> false - | FStar_Syntax_Syntax.Meta_desugared uu___ -> false - | FStar_Syntax_Syntax.Meta_named uu___ -> false)) -let (decide_unfolding : - FStar_TypeChecker_Cfg.cfg -> - stack_elt Prims.list -> - FStar_Syntax_Syntax.fv -> - FStar_TypeChecker_Env.qninfo -> - (FStar_TypeChecker_Cfg.cfg FStar_Pervasives_Native.option * - stack_elt Prims.list) FStar_Pervasives_Native.option) - = - fun cfg -> - fun stack1 -> - fun fv -> - fun qninfo -> - let res = - FStar_TypeChecker_Normalize_Unfolding.should_unfold cfg - (fun cfg1 -> should_reify cfg1 stack1) fv qninfo in - match res with - | FStar_TypeChecker_Normalize_Unfolding.Should_unfold_no -> - FStar_Pervasives_Native.None - | FStar_TypeChecker_Normalize_Unfolding.Should_unfold_yes -> - FStar_Pervasives_Native.Some - (FStar_Pervasives_Native.None, stack1) - | FStar_TypeChecker_Normalize_Unfolding.Should_unfold_fully -> - let cfg' = - { - FStar_TypeChecker_Cfg.steps = - (let uu___ = cfg.FStar_TypeChecker_Cfg.steps in - { - FStar_TypeChecker_Cfg.beta = - (uu___.FStar_TypeChecker_Cfg.beta); - FStar_TypeChecker_Cfg.iota = - (uu___.FStar_TypeChecker_Cfg.iota); - FStar_TypeChecker_Cfg.zeta = - (uu___.FStar_TypeChecker_Cfg.zeta); - FStar_TypeChecker_Cfg.zeta_full = - (uu___.FStar_TypeChecker_Cfg.zeta_full); - FStar_TypeChecker_Cfg.weak = - (uu___.FStar_TypeChecker_Cfg.weak); - FStar_TypeChecker_Cfg.hnf = - (uu___.FStar_TypeChecker_Cfg.hnf); - FStar_TypeChecker_Cfg.primops = - (uu___.FStar_TypeChecker_Cfg.primops); - FStar_TypeChecker_Cfg.do_not_unfold_pure_lets = - (uu___.FStar_TypeChecker_Cfg.do_not_unfold_pure_lets); - FStar_TypeChecker_Cfg.unfold_until = - (FStar_Pervasives_Native.Some - FStar_Syntax_Syntax.delta_constant); - FStar_TypeChecker_Cfg.unfold_only = - FStar_Pervasives_Native.None; - FStar_TypeChecker_Cfg.unfold_fully = - FStar_Pervasives_Native.None; - FStar_TypeChecker_Cfg.unfold_attr = - FStar_Pervasives_Native.None; - FStar_TypeChecker_Cfg.unfold_qual = - FStar_Pervasives_Native.None; - FStar_TypeChecker_Cfg.unfold_namespace = - FStar_Pervasives_Native.None; - FStar_TypeChecker_Cfg.dont_unfold_attr = - (uu___.FStar_TypeChecker_Cfg.dont_unfold_attr); - FStar_TypeChecker_Cfg.pure_subterms_within_computations - = - (uu___.FStar_TypeChecker_Cfg.pure_subterms_within_computations); - FStar_TypeChecker_Cfg.simplify = - (uu___.FStar_TypeChecker_Cfg.simplify); - FStar_TypeChecker_Cfg.erase_universes = - (uu___.FStar_TypeChecker_Cfg.erase_universes); - FStar_TypeChecker_Cfg.allow_unbound_universes = - (uu___.FStar_TypeChecker_Cfg.allow_unbound_universes); - FStar_TypeChecker_Cfg.reify_ = - (uu___.FStar_TypeChecker_Cfg.reify_); - FStar_TypeChecker_Cfg.compress_uvars = - (uu___.FStar_TypeChecker_Cfg.compress_uvars); - FStar_TypeChecker_Cfg.no_full_norm = - (uu___.FStar_TypeChecker_Cfg.no_full_norm); - FStar_TypeChecker_Cfg.check_no_uvars = - (uu___.FStar_TypeChecker_Cfg.check_no_uvars); - FStar_TypeChecker_Cfg.unmeta = - (uu___.FStar_TypeChecker_Cfg.unmeta); - FStar_TypeChecker_Cfg.unascribe = - (uu___.FStar_TypeChecker_Cfg.unascribe); - FStar_TypeChecker_Cfg.in_full_norm_request = - (uu___.FStar_TypeChecker_Cfg.in_full_norm_request); - FStar_TypeChecker_Cfg.weakly_reduce_scrutinee = - (uu___.FStar_TypeChecker_Cfg.weakly_reduce_scrutinee); - FStar_TypeChecker_Cfg.nbe_step = - (uu___.FStar_TypeChecker_Cfg.nbe_step); - FStar_TypeChecker_Cfg.for_extraction = - (uu___.FStar_TypeChecker_Cfg.for_extraction); - FStar_TypeChecker_Cfg.unrefine = - (uu___.FStar_TypeChecker_Cfg.unrefine); - FStar_TypeChecker_Cfg.default_univs_to_zero = - (uu___.FStar_TypeChecker_Cfg.default_univs_to_zero); - FStar_TypeChecker_Cfg.tactics = - (uu___.FStar_TypeChecker_Cfg.tactics) - }); - FStar_TypeChecker_Cfg.tcenv = - (cfg.FStar_TypeChecker_Cfg.tcenv); - FStar_TypeChecker_Cfg.debug = - (cfg.FStar_TypeChecker_Cfg.debug); - FStar_TypeChecker_Cfg.delta_level = - (cfg.FStar_TypeChecker_Cfg.delta_level); - FStar_TypeChecker_Cfg.primitive_steps = - (cfg.FStar_TypeChecker_Cfg.primitive_steps); - FStar_TypeChecker_Cfg.strong = - (cfg.FStar_TypeChecker_Cfg.strong); - FStar_TypeChecker_Cfg.memoize_lazy = - (cfg.FStar_TypeChecker_Cfg.memoize_lazy); - FStar_TypeChecker_Cfg.normalize_pure_lets = - (cfg.FStar_TypeChecker_Cfg.normalize_pure_lets); - FStar_TypeChecker_Cfg.reifying = - (cfg.FStar_TypeChecker_Cfg.reifying); - FStar_TypeChecker_Cfg.compat_memo_ignore_cfg = - (cfg.FStar_TypeChecker_Cfg.compat_memo_ignore_cfg) - } in - FStar_Pervasives_Native.Some - ((FStar_Pervasives_Native.Some cfg'), stack1) - | FStar_TypeChecker_Normalize_Unfolding.Should_unfold_reify -> - let rec push e s = - match s with - | [] -> [e] - | (UnivArgs (us, r))::t -> - let uu___ = push e t in (UnivArgs (us, r)) :: uu___ - | h::t -> e :: h :: t in - let ref = - let uu___ = - let uu___1 = - let uu___2 = FStar_Syntax_Syntax.lid_of_fv fv in - FStar_Const.Const_reflect uu___2 in - FStar_Syntax_Syntax.Tm_constant uu___1 in - FStar_Syntax_Syntax.mk uu___ - FStar_Compiler_Range_Type.dummyRange in - let stack2 = - push - (App - (empty_env, ref, FStar_Pervasives_Native.None, - FStar_Compiler_Range_Type.dummyRange)) stack1 in - FStar_Pervasives_Native.Some - (FStar_Pervasives_Native.None, stack2) -let (on_domain_lids : FStar_Ident.lident Prims.list) = - [FStar_Parser_Const.fext_on_domain_lid; - FStar_Parser_Const.fext_on_dom_lid; - FStar_Parser_Const.fext_on_domain_g_lid; - FStar_Parser_Const.fext_on_dom_g_lid] -let (is_fext_on_domain : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = - fun t -> - let is_on_dom fv = - FStar_Compiler_List.existsb - (fun l -> FStar_Syntax_Syntax.fv_eq_lid fv l) on_domain_lids in - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = hd; FStar_Syntax_Syntax.args = args;_} -> - let uu___1 = - let uu___2 = FStar_Syntax_Util.un_uinst hd in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_fvar fv when - (is_on_dom fv) && - ((FStar_Compiler_List.length args) = (Prims.of_int (3))) - -> - let f = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Compiler_List.tl args in - FStar_Compiler_List.tl uu___4 in - FStar_Compiler_List.hd uu___3 in - FStar_Pervasives_Native.fst uu___2 in - FStar_Pervasives_Native.Some f - | uu___2 -> FStar_Pervasives_Native.None) - | uu___1 -> FStar_Pervasives_Native.None -let (__get_n_binders : - (FStar_TypeChecker_Env.env -> - FStar_TypeChecker_Env.step Prims.list -> - Prims.int -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.binder Prims.list * FStar_Syntax_Syntax.comp)) - FStar_Compiler_Effect.ref) - = - FStar_Compiler_Util.mk_ref - (fun e -> - fun s -> - fun n -> fun t -> failwith "Impossible: __get_n_binders unset") -let (is_partial_primop_app : - FStar_TypeChecker_Cfg.cfg -> FStar_Syntax_Syntax.term -> Prims.bool) = - fun cfg -> - fun t -> - let uu___ = FStar_Syntax_Util.head_and_args t in - match uu___ with - | (hd, args) -> - let uu___1 = - let uu___2 = FStar_Syntax_Util.un_uinst hd in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - let uu___2 = FStar_TypeChecker_Cfg.find_prim_step cfg fv in - (match uu___2 with - | FStar_Pervasives_Native.Some prim_step -> - prim_step.FStar_TypeChecker_Primops_Base.arity > - (FStar_Compiler_List.length args) - | FStar_Pervasives_Native.None -> false) - | uu___2 -> false) -let (maybe_drop_rc_typ : - FStar_TypeChecker_Cfg.cfg -> - FStar_Syntax_Syntax.residual_comp -> FStar_Syntax_Syntax.residual_comp) - = - fun cfg -> - fun rc -> - if - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.for_extraction - then - { - FStar_Syntax_Syntax.residual_effect = - (rc.FStar_Syntax_Syntax.residual_effect); - FStar_Syntax_Syntax.residual_typ = FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.residual_flags = - (rc.FStar_Syntax_Syntax.residual_flags) - } - else rc -let (get_extraction_mode : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident -> FStar_Syntax_Syntax.eff_extraction_mode) - = - fun env1 -> - fun m -> - let norm_m = FStar_TypeChecker_Env.norm_eff_name env1 m in - let uu___ = FStar_TypeChecker_Env.get_effect_decl env1 norm_m in - uu___.FStar_Syntax_Syntax.extraction_mode -let (can_reify_for_extraction : - FStar_TypeChecker_Env.env -> FStar_Ident.lident -> Prims.bool) = - fun env1 -> - fun m -> - let uu___ = get_extraction_mode env1 m in - uu___ = FStar_Syntax_Syntax.Extract_reify -let rec args_are_binders : - 'uuuuu . - (FStar_Syntax_Syntax.term * 'uuuuu) Prims.list -> - FStar_Syntax_Syntax.binder Prims.list -> Prims.bool - = - fun args -> - fun bs -> - match (args, bs) with - | ((t, uu___)::args1, b::bs1) -> - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress t in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_name bv' -> - (FStar_Syntax_Syntax.bv_eq b.FStar_Syntax_Syntax.binder_bv bv') - && (args_are_binders args1 bs1) - | uu___2 -> false) - | ([], []) -> true - | (uu___, uu___1) -> false -let (is_applied : - FStar_TypeChecker_Cfg.cfg -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.bv FStar_Pervasives_Native.option) - = - fun cfg -> - fun bs -> - fun t -> - if (cfg.FStar_TypeChecker_Cfg.debug).FStar_TypeChecker_Cfg.wpe - then - (let uu___1 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - let uu___2 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t in - FStar_Compiler_Util.print2 "WPE> is_applied %s -- %s\n" uu___1 - uu___2) - else (); - (let uu___1 = FStar_Syntax_Util.head_and_args_full t in - match uu___1 with - | (hd, args) -> - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress hd in - uu___3.FStar_Syntax_Syntax.n in - (match uu___2 with - | FStar_Syntax_Syntax.Tm_name bv when args_are_binders args bs - -> - (if - (cfg.FStar_TypeChecker_Cfg.debug).FStar_TypeChecker_Cfg.wpe - then - (let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_bv - bv in - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term hd in - FStar_Compiler_Util.print3 - "WPE> got it\n>>>>top = %s\n>>>>b = %s\n>>>>hd = %s\n" - uu___4 uu___5 uu___6) - else (); - FStar_Pervasives_Native.Some bv) - | uu___3 -> FStar_Pervasives_Native.None)) -let (is_applied_maybe_squashed : - FStar_TypeChecker_Cfg.cfg -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.bv FStar_Pervasives_Native.option) - = - fun cfg -> - fun bs -> - fun t -> - if (cfg.FStar_TypeChecker_Cfg.debug).FStar_TypeChecker_Cfg.wpe - then - (let uu___1 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - let uu___2 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t in - FStar_Compiler_Util.print2 - "WPE> is_applied_maybe_squashed %s -- %s\n" uu___1 uu___2) - else (); - (let uu___1 = FStar_Syntax_Util.is_squash t in - match uu___1 with - | FStar_Pervasives_Native.Some (uu___2, t') -> is_applied cfg bs t' - | uu___2 -> - let uu___3 = FStar_Syntax_Util.is_auto_squash t in - (match uu___3 with - | FStar_Pervasives_Native.Some (uu___4, t') -> - is_applied cfg bs t' - | uu___4 -> is_applied cfg bs t)) -let (is_quantified_const : - FStar_TypeChecker_Cfg.cfg -> - FStar_Syntax_Syntax.bv -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun cfg -> - fun bv -> - fun phi -> - let guard b = - if b - then FStar_Pervasives_Native.Some () - else FStar_Pervasives_Native.None in - let phi0 = phi in - let types_match bs = - let uu___ = - let uu___1 = FStar_Compiler_Effect.op_Bang __get_n_binders in - uu___1 cfg.FStar_TypeChecker_Cfg.tcenv - [FStar_TypeChecker_Env.AllowUnboundUniverses] - (FStar_Compiler_List.length bs) - bv.FStar_Syntax_Syntax.sort in - match uu___ with - | (bs_q, uu___1) -> - let rec unrefine_true t = - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress t in - uu___3.FStar_Syntax_Syntax.n in - match uu___2 with - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = b; - FStar_Syntax_Syntax.phi = phi1;_} - when - FStar_Syntax_Util.term_eq phi1 - FStar_Syntax_Util.t_true - -> unrefine_true b.FStar_Syntax_Syntax.sort - | uu___3 -> t in - ((FStar_Compiler_List.length bs) = - (FStar_Compiler_List.length bs_q)) - && - (FStar_Compiler_List.forall2 - (fun b1 -> - fun b2 -> - let s1 = - unrefine_true - (b1.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - let s2 = - unrefine_true - (b2.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - FStar_Syntax_Util.term_eq s1 s2) bs bs_q) in - let is_bv bv1 t = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_name bv' -> - FStar_Syntax_Syntax.bv_eq bv1 bv' - | uu___1 -> false in - let replace_full_applications_with bv1 arity s t = - let chgd = FStar_Compiler_Util.mk_ref false in - let t' = - FStar_Syntax_Visit.visit_term false - (fun t1 -> - let uu___ = FStar_Syntax_Util.head_and_args t1 in - match uu___ with - | (hd, args) -> - let uu___1 = - ((FStar_Compiler_List.length args) = arity) && - (is_bv bv1 hd) in - if uu___1 - then - (FStar_Compiler_Effect.op_Colon_Equals chgd - true; - s) - else t1) t in - let uu___ = FStar_Compiler_Effect.op_Bang chgd in - (t', uu___) in - let uu___ = FStar_Syntax_Formula.destruct_typ_as_formula phi in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () (Obj.magic uu___) - (fun uu___1 -> - (fun form -> - let form = Obj.magic form in - match form with - | FStar_Syntax_Formula.BaseConn - (lid, (p, uu___1)::(q, uu___2)::[]) when - FStar_Ident.lid_equals lid - FStar_Parser_Const.imp_lid - -> - Obj.magic - (Obj.repr - (if - (cfg.FStar_TypeChecker_Cfg.debug).FStar_TypeChecker_Cfg.wpe - then - (let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term p in - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term q in - FStar_Compiler_Util.print2 - "WPE> p = (%s); q = (%s)\n" uu___4 - uu___5) - else (); - (let uu___4 = - let uu___5 = - FStar_Syntax_Formula.destruct_typ_as_formula - p in - match uu___5 with - | FStar_Pervasives_Native.None -> - Obj.magic - (Obj.repr - (let uu___6 = - let uu___7 = - FStar_Syntax_Subst.compress - p in - uu___7.FStar_Syntax_Syntax.n in - match uu___6 with - | FStar_Syntax_Syntax.Tm_bvar - bv' when - FStar_Syntax_Syntax.bv_eq - bv bv' - -> - (if - (cfg.FStar_TypeChecker_Cfg.debug).FStar_TypeChecker_Cfg.wpe - then - FStar_Compiler_Util.print_string - "WPE> Case 1\n" - else (); - (let q' = - FStar_Syntax_Subst.subst - [FStar_Syntax_Syntax.NT - (bv, - FStar_Syntax_Util.t_true)] - q in - FStar_Pervasives_Native.Some - q')) - | uu___7 -> - FStar_Pervasives_Native.None)) - | FStar_Pervasives_Native.Some - (FStar_Syntax_Formula.BaseConn - (lid1, (p1, uu___6)::[])) when - FStar_Ident.lid_equals lid1 - FStar_Parser_Const.not_lid - -> - Obj.magic - (Obj.repr - (let uu___7 = - let uu___8 = - FStar_Syntax_Subst.compress - p1 in - uu___8.FStar_Syntax_Syntax.n in - match uu___7 with - | FStar_Syntax_Syntax.Tm_bvar - bv' when - FStar_Syntax_Syntax.bv_eq - bv bv' - -> - (if - (cfg.FStar_TypeChecker_Cfg.debug).FStar_TypeChecker_Cfg.wpe - then - FStar_Compiler_Util.print_string - "WPE> Case 2\n" - else (); - (let q' = - FStar_Syntax_Subst.subst - [FStar_Syntax_Syntax.NT - (bv, - FStar_Syntax_Util.t_false)] - q in - FStar_Pervasives_Native.Some - q')) - | uu___8 -> - FStar_Pervasives_Native.None)) - | FStar_Pervasives_Native.Some - (FStar_Syntax_Formula.QAll - (bs, pats, phi1)) when - types_match bs -> - Obj.magic - (Obj.repr - (let uu___6 = - FStar_Syntax_Formula.destruct_typ_as_formula - phi1 in - match uu___6 with - | FStar_Pervasives_Native.None - -> - Obj.repr - (let uu___7 = - is_applied_maybe_squashed - cfg bs phi1 in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () - (Obj.magic uu___7) - (fun uu___8 -> - (fun bv' -> - let bv' = - Obj.magic - bv' in - let uu___8 = - let uu___9 - = - FStar_Syntax_Syntax.bv_eq - bv bv' in - guard - uu___9 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () - uu___8 - (fun - uu___9 -> - (fun - uu___9 -> - let uu___9 - = - Obj.magic - uu___9 in - if - (cfg.FStar_TypeChecker_Cfg.debug).FStar_TypeChecker_Cfg.wpe - then - FStar_Compiler_Util.print_string - "WPE> Case 3\n" - else (); - ( - let uu___11 - = - replace_full_applications_with - bv - (FStar_Compiler_List.length - bs) - FStar_Syntax_Util.t_true - q in - match uu___11 - with - | - (q', - chgd) -> - let uu___12 - = - guard - chgd in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () - uu___12 - (fun - uu___13 - -> - (fun - uu___13 - -> - let uu___13 - = - Obj.magic - uu___13 in - Obj.magic - (FStar_Pervasives_Native.Some - q')) - uu___13)))) - uu___9))) - uu___8)) - | FStar_Pervasives_Native.Some - (FStar_Syntax_Formula.BaseConn - (lid1, (p1, uu___7)::[])) - when - FStar_Ident.lid_equals - lid1 - FStar_Parser_Const.not_lid - -> - Obj.repr - (let uu___8 = - is_applied_maybe_squashed - cfg bs p1 in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () - (Obj.magic uu___8) - (fun uu___9 -> - (fun bv' -> - let bv' = - Obj.magic - bv' in - let uu___9 = - let uu___10 - = - FStar_Syntax_Syntax.bv_eq - bv bv' in - guard - uu___10 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () - uu___9 - (fun - uu___10 - -> - (fun - uu___10 - -> - let uu___10 - = - Obj.magic - uu___10 in - if - (cfg.FStar_TypeChecker_Cfg.debug).FStar_TypeChecker_Cfg.wpe - then - FStar_Compiler_Util.print_string - "WPE> Case 4\n" - else (); - ( - let uu___12 - = - replace_full_applications_with - bv - (FStar_Compiler_List.length - bs) - FStar_Syntax_Util.t_false - q in - match uu___12 - with - | - (q', - chgd) -> - let uu___13 - = - guard - chgd in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () - uu___13 - (fun - uu___14 - -> - (fun - uu___14 - -> - let uu___14 - = - Obj.magic - uu___14 in - Obj.magic - (FStar_Pervasives_Native.Some - q')) - uu___14)))) - uu___10))) - uu___9)) - | uu___7 -> - Obj.repr - FStar_Pervasives_Native.None)) - | uu___6 -> - Obj.magic - (Obj.repr - FStar_Pervasives_Native.None) in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic uu___4) - (fun uu___5 -> - (fun q' -> - let q' = Obj.magic q' in - let phi' = - let uu___5 = - FStar_Syntax_Syntax.fvar - FStar_Parser_Const.imp_lid - FStar_Pervasives_Native.None in - let uu___6 = - let uu___7 = - FStar_Syntax_Syntax.as_arg - p in - let uu___8 = - let uu___9 = - FStar_Syntax_Syntax.as_arg - q' in - [uu___9] in - uu___7 :: uu___8 in - FStar_Syntax_Util.mk_app - uu___5 uu___6 in - Obj.magic - (FStar_Pervasives_Native.Some - phi')) uu___5)))) - | uu___1 -> - Obj.magic - (Obj.repr FStar_Pervasives_Native.None)) - uu___1))) uu___2 uu___1 uu___ -let (is_forall_const : - FStar_TypeChecker_Cfg.cfg -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = - fun uu___1 -> - fun uu___ -> - (fun cfg -> - fun phi -> - let uu___ = FStar_Syntax_Formula.destruct_typ_as_formula phi in - match uu___ with - | FStar_Pervasives_Native.Some (FStar_Syntax_Formula.QAll - (b::[], uu___1, phi')) -> - Obj.magic - (Obj.repr - (if - (cfg.FStar_TypeChecker_Cfg.debug).FStar_TypeChecker_Cfg.wpe - then - (let uu___3 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_bv - b.FStar_Syntax_Syntax.binder_bv in - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term phi' in - FStar_Compiler_Util.print2 "WPE> QAll [%s] %s\n" - uu___3 uu___4) - else (); - (let uu___3 = - is_quantified_const cfg - b.FStar_Syntax_Syntax.binder_bv phi' in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic uu___3) - (fun uu___4 -> - (fun phi'1 -> - let phi'1 = Obj.magic phi'1 in - let uu___4 = - let uu___5 = - (cfg.FStar_TypeChecker_Cfg.tcenv).FStar_TypeChecker_Env.universe_of - cfg.FStar_TypeChecker_Cfg.tcenv - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - FStar_Syntax_Util.mk_forall uu___5 - b.FStar_Syntax_Syntax.binder_bv phi'1 in - Obj.magic (FStar_Pervasives_Native.Some uu___4)) - uu___4)))) - | uu___1 -> Obj.magic (Obj.repr FStar_Pervasives_Native.None)) - uu___1 uu___ -let (is_extract_as_attr : - FStar_Syntax_Syntax.attribute -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = - fun attr -> - let uu___ = FStar_Syntax_Util.head_and_args attr in - match uu___ with - | (head, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress head in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, (t, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.extract_as_lid - -> - let uu___3 = - let uu___4 = FStar_Syntax_Subst.compress t in - uu___4.FStar_Syntax_Syntax.n in - (match uu___3 with - | FStar_Syntax_Syntax.Tm_quoted (impl, uu___4) -> - FStar_Pervasives_Native.Some impl - | uu___4 -> FStar_Pervasives_Native.None) - | uu___2 -> FStar_Pervasives_Native.None) -let (has_extract_as_attr : - FStar_TypeChecker_Env.env -> - FStar_Ident.lid -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = - fun g -> - fun lid -> - let uu___ = FStar_TypeChecker_Env.lookup_attrs_of_lid g lid in - match uu___ with - | FStar_Pervasives_Native.Some attrs -> - FStar_Compiler_Util.find_map attrs is_extract_as_attr - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None -let rec (norm : - FStar_TypeChecker_Cfg.cfg -> - env -> stack -> FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun cfg -> - fun env1 -> - fun stack1 -> - fun t -> - let rec collapse_metas st = - match st with - | (Meta - (uu___, FStar_Syntax_Syntax.Meta_monadic uu___1, uu___2))::(Meta - (e, FStar_Syntax_Syntax.Meta_monadic m, r))::st' -> - collapse_metas - ((Meta (e, (FStar_Syntax_Syntax.Meta_monadic m), r)) :: - st') - | uu___ -> st in - let stack2 = collapse_metas stack1 in - let t1 = - if - (cfg.FStar_TypeChecker_Cfg.debug).FStar_TypeChecker_Cfg.norm_delayed - then - (match t.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_delayed uu___1 -> - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.print1 "NORM delayed: %s\n" uu___2 - | uu___1 -> ()) - else (); - FStar_Syntax_Subst.compress t in - FStar_TypeChecker_Cfg.log cfg - (fun uu___1 -> - let uu___2 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t1 in - let uu___3 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.no_full_norm in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - let uu___5 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_nat) - (FStar_Compiler_List.length env1) in - let uu___6 = - let uu___7 = - let uu___8 = firstn (Prims.of_int (4)) stack2 in - FStar_Pervasives_Native.fst uu___8 in - FStar_Class_Show.show - (FStar_Class_Show.show_list showable_stack_elt) uu___7 in - FStar_Compiler_Util.print5 - ">>> %s (no_full_norm=%s)\nNorm %s with %s env elements; top of the stack = %s\n" - uu___2 uu___3 uu___4 uu___5 uu___6); - FStar_TypeChecker_Cfg.log_cfg cfg - (fun uu___2 -> - let uu___3 = - FStar_Class_Show.show FStar_TypeChecker_Cfg.showable_cfg cfg in - FStar_Compiler_Util.print1 ">>> cfg = %s\n" uu___3); - (match t1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_unknown -> - rebuild cfg empty_env stack2 t1 - | FStar_Syntax_Syntax.Tm_constant uu___2 -> - rebuild cfg empty_env stack2 t1 - | FStar_Syntax_Syntax.Tm_name uu___2 -> - rebuild cfg empty_env stack2 t1 - | FStar_Syntax_Syntax.Tm_lazy uu___2 -> - rebuild cfg empty_env stack2 t1 - | FStar_Syntax_Syntax.Tm_fvar - { FStar_Syntax_Syntax.fv_name = uu___2; - FStar_Syntax_Syntax.fv_qual = FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Data_ctor);_} - -> - (FStar_TypeChecker_Cfg.log_unfolding cfg - (fun uu___4 -> - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - t1 in - FStar_Compiler_Util.print1 - " >> This is a constructor: %s\n" uu___5); - rebuild cfg empty_env stack2 t1) - | FStar_Syntax_Syntax.Tm_fvar - { FStar_Syntax_Syntax.fv_name = uu___2; - FStar_Syntax_Syntax.fv_qual = FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Record_ctor uu___3);_} - -> - (FStar_TypeChecker_Cfg.log_unfolding cfg - (fun uu___5 -> - let uu___6 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - t1 in - FStar_Compiler_Util.print1 - " >> This is a constructor: %s\n" uu___6); - rebuild cfg empty_env stack2 t1) - | FStar_Syntax_Syntax.Tm_fvar fv -> - let lid = FStar_Syntax_Syntax.lid_of_fv fv in - let qninfo = - FStar_TypeChecker_Env.lookup_qname - cfg.FStar_TypeChecker_Cfg.tcenv lid in - let uu___2 = - FStar_TypeChecker_Env.delta_depth_of_qninfo - cfg.FStar_TypeChecker_Cfg.tcenv fv qninfo in - (match uu___2 with - | FStar_Syntax_Syntax.Delta_constant_at_level uu___3 when - uu___3 = Prims.int_zero -> - (FStar_TypeChecker_Cfg.log_unfolding cfg - (fun uu___5 -> - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.print1 - " >> This is a constant: %s\n" uu___6); - rebuild cfg empty_env stack2 t1) - | uu___3 -> - let uu___4 = decide_unfolding cfg stack2 fv qninfo in - (match uu___4 with - | FStar_Pervasives_Native.Some - (FStar_Pervasives_Native.None, stack3) -> - do_unfold_fv cfg stack3 t1 qninfo fv - | FStar_Pervasives_Native.Some - (FStar_Pervasives_Native.Some cfg1, stack3) -> - let uu___5 = do_unfold_fv cfg1 [] t1 qninfo fv in - rebuild cfg1 empty_env stack3 uu___5 - | FStar_Pervasives_Native.None -> - rebuild cfg empty_env stack2 t1)) - | FStar_Syntax_Syntax.Tm_quoted (qt, qi) -> - let qi1 = - FStar_Syntax_Syntax.on_antiquoted (norm cfg env1 []) qi in - let t2 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_quoted (qt, qi1)) - t1.FStar_Syntax_Syntax.pos in - let uu___2 = closure_as_term cfg env1 t2 in - rebuild cfg env1 stack2 uu___2 - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = hd; - FStar_Syntax_Syntax.args = args;_} - when - (should_consider_norm_requests cfg) && - (let uu___2 = is_norm_request hd args in - uu___2 = Norm_request_requires_rejig) - -> - (if - (cfg.FStar_TypeChecker_Cfg.debug).FStar_TypeChecker_Cfg.print_normalized - then - FStar_Compiler_Util.print_string - "Rejigging norm request ... \n" - else (); - (let uu___3 = rejig_norm_request hd args in - norm cfg env1 stack2 uu___3)) - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = hd; - FStar_Syntax_Syntax.args = args;_} - when - (should_consider_norm_requests cfg) && - (let uu___2 = is_norm_request hd args in - uu___2 = Norm_request_ready) - -> - (if - (cfg.FStar_TypeChecker_Cfg.debug).FStar_TypeChecker_Cfg.print_normalized - then - (let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - hd in - let uu___4 = FStar_Syntax_Print.args_to_string args in - FStar_Compiler_Util.print2 - "Potential norm request with hd = %s and args = %s ... \n" - uu___3 uu___4) - else (); - (let cfg' = - { - FStar_TypeChecker_Cfg.steps = - (let uu___3 = cfg.FStar_TypeChecker_Cfg.steps in - { - FStar_TypeChecker_Cfg.beta = - (uu___3.FStar_TypeChecker_Cfg.beta); - FStar_TypeChecker_Cfg.iota = - (uu___3.FStar_TypeChecker_Cfg.iota); - FStar_TypeChecker_Cfg.zeta = - (uu___3.FStar_TypeChecker_Cfg.zeta); - FStar_TypeChecker_Cfg.zeta_full = - (uu___3.FStar_TypeChecker_Cfg.zeta_full); - FStar_TypeChecker_Cfg.weak = - (uu___3.FStar_TypeChecker_Cfg.weak); - FStar_TypeChecker_Cfg.hnf = - (uu___3.FStar_TypeChecker_Cfg.hnf); - FStar_TypeChecker_Cfg.primops = - (uu___3.FStar_TypeChecker_Cfg.primops); - FStar_TypeChecker_Cfg.do_not_unfold_pure_lets = - false; - FStar_TypeChecker_Cfg.unfold_until = - (uu___3.FStar_TypeChecker_Cfg.unfold_until); - FStar_TypeChecker_Cfg.unfold_only = - FStar_Pervasives_Native.None; - FStar_TypeChecker_Cfg.unfold_fully = - FStar_Pervasives_Native.None; - FStar_TypeChecker_Cfg.unfold_attr = - (uu___3.FStar_TypeChecker_Cfg.unfold_attr); - FStar_TypeChecker_Cfg.unfold_qual = - (uu___3.FStar_TypeChecker_Cfg.unfold_qual); - FStar_TypeChecker_Cfg.unfold_namespace = - (uu___3.FStar_TypeChecker_Cfg.unfold_namespace); - FStar_TypeChecker_Cfg.dont_unfold_attr = - (uu___3.FStar_TypeChecker_Cfg.dont_unfold_attr); - FStar_TypeChecker_Cfg.pure_subterms_within_computations - = - (uu___3.FStar_TypeChecker_Cfg.pure_subterms_within_computations); - FStar_TypeChecker_Cfg.simplify = - (uu___3.FStar_TypeChecker_Cfg.simplify); - FStar_TypeChecker_Cfg.erase_universes = - (uu___3.FStar_TypeChecker_Cfg.erase_universes); - FStar_TypeChecker_Cfg.allow_unbound_universes = - (uu___3.FStar_TypeChecker_Cfg.allow_unbound_universes); - FStar_TypeChecker_Cfg.reify_ = - (uu___3.FStar_TypeChecker_Cfg.reify_); - FStar_TypeChecker_Cfg.compress_uvars = - (uu___3.FStar_TypeChecker_Cfg.compress_uvars); - FStar_TypeChecker_Cfg.no_full_norm = - (uu___3.FStar_TypeChecker_Cfg.no_full_norm); - FStar_TypeChecker_Cfg.check_no_uvars = - (uu___3.FStar_TypeChecker_Cfg.check_no_uvars); - FStar_TypeChecker_Cfg.unmeta = - (uu___3.FStar_TypeChecker_Cfg.unmeta); - FStar_TypeChecker_Cfg.unascribe = - (uu___3.FStar_TypeChecker_Cfg.unascribe); - FStar_TypeChecker_Cfg.in_full_norm_request = - (uu___3.FStar_TypeChecker_Cfg.in_full_norm_request); - FStar_TypeChecker_Cfg.weakly_reduce_scrutinee = - (uu___3.FStar_TypeChecker_Cfg.weakly_reduce_scrutinee); - FStar_TypeChecker_Cfg.nbe_step = - (uu___3.FStar_TypeChecker_Cfg.nbe_step); - FStar_TypeChecker_Cfg.for_extraction = - (uu___3.FStar_TypeChecker_Cfg.for_extraction); - FStar_TypeChecker_Cfg.unrefine = - (uu___3.FStar_TypeChecker_Cfg.unrefine); - FStar_TypeChecker_Cfg.default_univs_to_zero = - (uu___3.FStar_TypeChecker_Cfg.default_univs_to_zero); - FStar_TypeChecker_Cfg.tactics = - (uu___3.FStar_TypeChecker_Cfg.tactics) - }); - FStar_TypeChecker_Cfg.tcenv = - (cfg.FStar_TypeChecker_Cfg.tcenv); - FStar_TypeChecker_Cfg.debug = - (cfg.FStar_TypeChecker_Cfg.debug); - FStar_TypeChecker_Cfg.delta_level = - [FStar_TypeChecker_Env.Unfold - FStar_Syntax_Syntax.delta_constant]; - FStar_TypeChecker_Cfg.primitive_steps = - (cfg.FStar_TypeChecker_Cfg.primitive_steps); - FStar_TypeChecker_Cfg.strong = - (cfg.FStar_TypeChecker_Cfg.strong); - FStar_TypeChecker_Cfg.memoize_lazy = - (cfg.FStar_TypeChecker_Cfg.memoize_lazy); - FStar_TypeChecker_Cfg.normalize_pure_lets = true; - FStar_TypeChecker_Cfg.reifying = - (cfg.FStar_TypeChecker_Cfg.reifying); - FStar_TypeChecker_Cfg.compat_memo_ignore_cfg = - (cfg.FStar_TypeChecker_Cfg.compat_memo_ignore_cfg) - } in - let uu___3 = get_norm_request cfg (norm cfg' env1 []) args in - match uu___3 with - | FStar_Pervasives_Native.None -> - (if - (cfg.FStar_TypeChecker_Cfg.debug).FStar_TypeChecker_Cfg.print_normalized - then - FStar_Compiler_Util.print_string - "Norm request None ... \n" - else (); - (let stack3 = - FStar_Compiler_List.fold_right - (fun uu___5 -> - fun stack4 -> - match uu___5 with - | (a, aq) -> - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = fresh_memo () in - (env1, a, uu___10, false) in - Clos uu___9 in - (uu___8, aq, - (t1.FStar_Syntax_Syntax.pos)) in - Arg uu___7 in - uu___6 :: stack4) args stack2 in - FStar_TypeChecker_Cfg.log cfg - (fun uu___6 -> - let uu___7 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length args) in - FStar_Compiler_Util.print1 - "\tPushed %s arguments\n" uu___7); - norm cfg env1 stack3 hd)) - | FStar_Pervasives_Native.Some (s, tm) when is_nbe_request s - -> - let tm' = closure_as_term cfg env1 tm in - let start = FStar_Compiler_Util.now () in - let tm_norm = nbe_eval cfg s tm' in - let fin = FStar_Compiler_Util.now () in - (if - (cfg.FStar_TypeChecker_Cfg.debug).FStar_TypeChecker_Cfg.print_normalized - then - (let cfg'1 = - FStar_TypeChecker_Cfg.config s - cfg.FStar_TypeChecker_Cfg.tcenv in - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Compiler_Util.time_diff start fin in - FStar_Pervasives_Native.snd uu___7 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) uu___6 in - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term tm' in - let uu___7 = - FStar_Class_Show.show - FStar_TypeChecker_Cfg.showable_cfg cfg'1 in - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term tm_norm in - FStar_Compiler_Util.print4 - "NBE result timing (%s ms){\nOn term {\n%s\n}\nwith steps {%s}\nresult is{\n\n%s\n}\n}\n" - uu___5 uu___6 uu___7 uu___8) - else (); - rebuild cfg env1 stack2 tm_norm) - | FStar_Pervasives_Native.Some (s, tm) -> - (if - (cfg.FStar_TypeChecker_Cfg.debug).FStar_TypeChecker_Cfg.print_normalized - then - (let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term tm in - FStar_Compiler_Util.format1 - "Starting norm request on `%s`." uu___8 in - FStar_Errors_Msg.text uu___7 in - let uu___7 = - let uu___8 = - let uu___9 = FStar_Errors_Msg.text "Steps =" in - let uu___10 = - let uu___11 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_TypeChecker_Env.showable_step) - s in - FStar_Errors_Msg.text uu___11 in - FStar_Pprint.op_Hat_Slash_Hat uu___9 uu___10 in - [uu___8] in - uu___6 :: uu___7 in - FStar_Errors.diag - FStar_Class_HasRange.hasRange_range - tm.FStar_Syntax_Syntax.pos () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___5)) - else (); - (let delta_level = - let uu___5 = - FStar_Compiler_Util.for_some - (fun uu___6 -> - match uu___6 with - | FStar_TypeChecker_Env.UnfoldUntil uu___7 -> - true - | FStar_TypeChecker_Env.UnfoldOnly uu___7 -> - true - | FStar_TypeChecker_Env.UnfoldFully uu___7 -> - true - | uu___7 -> false) s in - if uu___5 - then - [FStar_TypeChecker_Env.Unfold - FStar_Syntax_Syntax.delta_constant] - else - if - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.for_extraction - then - [FStar_TypeChecker_Env.Eager_unfolding_only; - FStar_TypeChecker_Env.InliningDelta] - else [FStar_TypeChecker_Env.NoDelta] in - let cfg'1 = - let uu___5 = - let uu___6 = FStar_TypeChecker_Cfg.to_fsteps s in - { - FStar_TypeChecker_Cfg.beta = - (uu___6.FStar_TypeChecker_Cfg.beta); - FStar_TypeChecker_Cfg.iota = - (uu___6.FStar_TypeChecker_Cfg.iota); - FStar_TypeChecker_Cfg.zeta = - (uu___6.FStar_TypeChecker_Cfg.zeta); - FStar_TypeChecker_Cfg.zeta_full = - (uu___6.FStar_TypeChecker_Cfg.zeta_full); - FStar_TypeChecker_Cfg.weak = - (uu___6.FStar_TypeChecker_Cfg.weak); - FStar_TypeChecker_Cfg.hnf = - (uu___6.FStar_TypeChecker_Cfg.hnf); - FStar_TypeChecker_Cfg.primops = - (uu___6.FStar_TypeChecker_Cfg.primops); - FStar_TypeChecker_Cfg.do_not_unfold_pure_lets = - (uu___6.FStar_TypeChecker_Cfg.do_not_unfold_pure_lets); - FStar_TypeChecker_Cfg.unfold_until = - (uu___6.FStar_TypeChecker_Cfg.unfold_until); - FStar_TypeChecker_Cfg.unfold_only = - (uu___6.FStar_TypeChecker_Cfg.unfold_only); - FStar_TypeChecker_Cfg.unfold_fully = - (uu___6.FStar_TypeChecker_Cfg.unfold_fully); - FStar_TypeChecker_Cfg.unfold_attr = - (uu___6.FStar_TypeChecker_Cfg.unfold_attr); - FStar_TypeChecker_Cfg.unfold_qual = - (uu___6.FStar_TypeChecker_Cfg.unfold_qual); - FStar_TypeChecker_Cfg.unfold_namespace = - (uu___6.FStar_TypeChecker_Cfg.unfold_namespace); - FStar_TypeChecker_Cfg.dont_unfold_attr = - (uu___6.FStar_TypeChecker_Cfg.dont_unfold_attr); - FStar_TypeChecker_Cfg.pure_subterms_within_computations - = - (uu___6.FStar_TypeChecker_Cfg.pure_subterms_within_computations); - FStar_TypeChecker_Cfg.simplify = - (uu___6.FStar_TypeChecker_Cfg.simplify); - FStar_TypeChecker_Cfg.erase_universes = - (uu___6.FStar_TypeChecker_Cfg.erase_universes); - FStar_TypeChecker_Cfg.allow_unbound_universes = - (uu___6.FStar_TypeChecker_Cfg.allow_unbound_universes); - FStar_TypeChecker_Cfg.reify_ = - (uu___6.FStar_TypeChecker_Cfg.reify_); - FStar_TypeChecker_Cfg.compress_uvars = - (uu___6.FStar_TypeChecker_Cfg.compress_uvars); - FStar_TypeChecker_Cfg.no_full_norm = - (uu___6.FStar_TypeChecker_Cfg.no_full_norm); - FStar_TypeChecker_Cfg.check_no_uvars = - (uu___6.FStar_TypeChecker_Cfg.check_no_uvars); - FStar_TypeChecker_Cfg.unmeta = - (uu___6.FStar_TypeChecker_Cfg.unmeta); - FStar_TypeChecker_Cfg.unascribe = - (uu___6.FStar_TypeChecker_Cfg.unascribe); - FStar_TypeChecker_Cfg.in_full_norm_request = - true; - FStar_TypeChecker_Cfg.weakly_reduce_scrutinee = - (uu___6.FStar_TypeChecker_Cfg.weakly_reduce_scrutinee); - FStar_TypeChecker_Cfg.nbe_step = - (uu___6.FStar_TypeChecker_Cfg.nbe_step); - FStar_TypeChecker_Cfg.for_extraction = - ((cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.for_extraction); - FStar_TypeChecker_Cfg.unrefine = - (uu___6.FStar_TypeChecker_Cfg.unrefine); - FStar_TypeChecker_Cfg.default_univs_to_zero = - (uu___6.FStar_TypeChecker_Cfg.default_univs_to_zero); - FStar_TypeChecker_Cfg.tactics = - (uu___6.FStar_TypeChecker_Cfg.tactics) - } in - { - FStar_TypeChecker_Cfg.steps = uu___5; - FStar_TypeChecker_Cfg.tcenv = - (cfg.FStar_TypeChecker_Cfg.tcenv); - FStar_TypeChecker_Cfg.debug = - (cfg.FStar_TypeChecker_Cfg.debug); - FStar_TypeChecker_Cfg.delta_level = delta_level; - FStar_TypeChecker_Cfg.primitive_steps = - (cfg.FStar_TypeChecker_Cfg.primitive_steps); - FStar_TypeChecker_Cfg.strong = - (cfg.FStar_TypeChecker_Cfg.strong); - FStar_TypeChecker_Cfg.memoize_lazy = - (cfg.FStar_TypeChecker_Cfg.memoize_lazy); - FStar_TypeChecker_Cfg.normalize_pure_lets = true; - FStar_TypeChecker_Cfg.reifying = - (cfg.FStar_TypeChecker_Cfg.reifying); - FStar_TypeChecker_Cfg.compat_memo_ignore_cfg = - (cfg.FStar_TypeChecker_Cfg.compat_memo_ignore_cfg) - } in - let t0 = FStar_Compiler_Util.now () in - let uu___5 = - FStar_Compiler_Util.record_time - (fun uu___6 -> norm cfg'1 env1 [] tm) in - match uu___5 with - | (tm_normed, ms) -> - (maybe_debug cfg tm_normed - (FStar_Pervasives_Native.Some (tm, t0)); - rebuild cfg env1 stack2 tm_normed))))) - | FStar_Syntax_Syntax.Tm_type u -> - let u1 = norm_universe cfg env1 u in - let uu___2 = - FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_type u1) - t1.FStar_Syntax_Syntax.pos in - rebuild cfg env1 stack2 uu___2 - | FStar_Syntax_Syntax.Tm_uinst (t', us) -> - if - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.erase_universes - then norm cfg env1 stack2 t' - else - (let us1 = - let uu___3 = - let uu___4 = - FStar_Compiler_List.map (norm_universe cfg env1) us in - (uu___4, (t1.FStar_Syntax_Syntax.pos)) in - UnivArgs uu___3 in - let stack3 = us1 :: stack2 in norm cfg env1 stack3 t') - | FStar_Syntax_Syntax.Tm_bvar x -> - let uu___2 = lookup_bvar env1 x in - (match uu___2 with - | Univ uu___3 -> - failwith - "Impossible: term variable is bound to a universe" - | Dummy -> failwith "Term variable not found" - | Clos (env2, t0, r, fix) -> - if - ((Prims.op_Negation fix) || - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.zeta) - || - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.zeta_full - then - let uu___3 = read_memo cfg r in - (match uu___3 with - | FStar_Pervasives_Native.Some (env3, t') -> - (FStar_TypeChecker_Cfg.log cfg - (fun uu___5 -> - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t1 in - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t' in - FStar_Compiler_Util.print2 - "Lazy hit: %s cached to %s\n" uu___6 - uu___7); - (let uu___5 = maybe_weakly_reduced t' in - if uu___5 - then - match stack2 with - | [] when - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.weak - || - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.compress_uvars - -> rebuild cfg env3 stack2 t' - | uu___6 -> norm cfg env3 stack2 t' - else rebuild cfg env3 stack2 t')) - | FStar_Pervasives_Native.None -> - norm cfg env2 ((MemoLazy r) :: stack2) t0) - else norm cfg env2 stack2 t0) - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = rc_opt;_} - -> - let rec maybe_strip_meta_divs stack3 = - match stack3 with - | [] -> FStar_Pervasives_Native.None - | (Meta - (uu___2, FStar_Syntax_Syntax.Meta_monadic (m, uu___3), - uu___4))::tl - when - FStar_Ident.lid_equals m - FStar_Parser_Const.effect_DIV_lid - -> maybe_strip_meta_divs tl - | (Meta - (uu___2, FStar_Syntax_Syntax.Meta_monadic_lift - (src, tgt, uu___3), uu___4))::tl - when - (FStar_Ident.lid_equals src - FStar_Parser_Const.effect_PURE_lid) - && - (FStar_Ident.lid_equals tgt - FStar_Parser_Const.effect_DIV_lid) - -> maybe_strip_meta_divs tl - | (Arg uu___2)::uu___3 -> - FStar_Pervasives_Native.Some stack3 - | uu___2 -> FStar_Pervasives_Native.None in - let fallback uu___2 = - if - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.weak - then - let t2 = closure_as_term cfg env1 t1 in - rebuild cfg env1 stack2 t2 - else - (let uu___4 = FStar_Syntax_Subst.open_term' bs body in - match uu___4 with - | (bs1, body1, opening) -> - let env' = - FStar_Compiler_List.fold_left - (fun env2 -> - fun uu___5 -> - let uu___6 = dummy () in uu___6 :: env2) - env1 bs1 in - let rc_opt1 = - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic rc_opt) - (fun uu___5 -> - (fun rc -> - let rc = Obj.magic rc in - let rc1 = maybe_drop_rc_typ cfg rc in - let uu___5 = - let uu___6 = - FStar_Compiler_Util.map_option - (FStar_Syntax_Subst.subst opening) - rc1.FStar_Syntax_Syntax.residual_typ in - { - FStar_Syntax_Syntax.residual_effect - = - (rc1.FStar_Syntax_Syntax.residual_effect); - FStar_Syntax_Syntax.residual_typ = - uu___6; - FStar_Syntax_Syntax.residual_flags = - (rc1.FStar_Syntax_Syntax.residual_flags) - } in - Obj.magic - (FStar_Pervasives_Native.Some uu___5)) - uu___5)) in - (FStar_TypeChecker_Cfg.log cfg - (fun uu___6 -> - let uu___7 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length bs1) in - FStar_Compiler_Util.print1 - "\tShifted %s dummies\n" uu___7); - (let cfg' = - { - FStar_TypeChecker_Cfg.steps = - (cfg.FStar_TypeChecker_Cfg.steps); - FStar_TypeChecker_Cfg.tcenv = - (cfg.FStar_TypeChecker_Cfg.tcenv); - FStar_TypeChecker_Cfg.debug = - (cfg.FStar_TypeChecker_Cfg.debug); - FStar_TypeChecker_Cfg.delta_level = - (cfg.FStar_TypeChecker_Cfg.delta_level); - FStar_TypeChecker_Cfg.primitive_steps = - (cfg.FStar_TypeChecker_Cfg.primitive_steps); - FStar_TypeChecker_Cfg.strong = true; - FStar_TypeChecker_Cfg.memoize_lazy = - (cfg.FStar_TypeChecker_Cfg.memoize_lazy); - FStar_TypeChecker_Cfg.normalize_pure_lets = - (cfg.FStar_TypeChecker_Cfg.normalize_pure_lets); - FStar_TypeChecker_Cfg.reifying = - (cfg.FStar_TypeChecker_Cfg.reifying); - FStar_TypeChecker_Cfg.compat_memo_ignore_cfg = - (cfg.FStar_TypeChecker_Cfg.compat_memo_ignore_cfg) - } in - let body_norm = - norm cfg env' - [Abs - (env1, bs1, env', rc_opt1, - (t1.FStar_Syntax_Syntax.pos))] body1 in - rebuild cfg env1 stack2 body_norm))) in - (match stack2 with - | (UnivArgs uu___2)::uu___3 -> - failwith - "Ill-typed term: universes cannot be applied to term abstraction" - | (Arg (Univ u, uu___2, uu___3))::stack_rest -> - let uu___4 = - let uu___5 = - let uu___6 = fresh_memo () in - (FStar_Pervasives_Native.None, (Univ u), uu___6) in - uu___5 :: env1 in - norm cfg uu___4 stack_rest t1 - | (Arg (c, uu___2, uu___3))::stack_rest -> - (match bs with - | [] -> failwith "Impossible" - | b::[] -> - (FStar_TypeChecker_Cfg.log cfg - (fun uu___5 -> - let uu___6 = - FStar_Class_Show.show showable_closure c in - FStar_Compiler_Util.print1 "\tShifted %s\n" - uu___6); - (let uu___5 = - let uu___6 = - let uu___7 = fresh_memo () in - ((FStar_Pervasives_Native.Some b), c, uu___7) in - uu___6 :: env1 in - norm cfg uu___5 stack_rest body)) - | b::tl -> - (FStar_TypeChecker_Cfg.log cfg - (fun uu___5 -> - let uu___6 = - FStar_Class_Show.show showable_closure c in - FStar_Compiler_Util.print1 "\tShifted %s\n" - uu___6); - (let body1 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = tl; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = rc_opt - }) t1.FStar_Syntax_Syntax.pos in - let uu___5 = - let uu___6 = - let uu___7 = fresh_memo () in - ((FStar_Pervasives_Native.Some b), c, uu___7) in - uu___6 :: env1 in - norm cfg uu___5 stack_rest body1))) - | (MemoLazy r)::stack3 -> - (set_memo cfg r (env1, t1); - FStar_TypeChecker_Cfg.log cfg - (fun uu___4 -> - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.print1 "\tSet memo %s\n" uu___5); - norm cfg env1 stack3 t1) - | (Meta uu___2)::uu___3 -> - let uu___4 = maybe_strip_meta_divs stack2 in - (match uu___4 with - | FStar_Pervasives_Native.None -> fallback () - | FStar_Pervasives_Native.Some stack3 -> - norm cfg env1 stack3 t1) - | (Match uu___2)::uu___3 -> fallback () - | (Let uu___2)::uu___3 -> fallback () - | (App uu___2)::uu___3 -> fallback () - | (CBVApp uu___2)::uu___3 -> fallback () - | (Abs uu___2)::uu___3 -> fallback () - | [] -> fallback ()) - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = args;_} - -> - let strict_args = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Util.unascribe head in - FStar_Syntax_Util.un_uinst uu___4 in - uu___3.FStar_Syntax_Syntax.n in - match uu___2 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - FStar_TypeChecker_Env.fv_has_strict_args - cfg.FStar_TypeChecker_Cfg.tcenv fv - | uu___3 -> FStar_Pervasives_Native.None in - (match strict_args with - | FStar_Pervasives_Native.None -> - let stack3 = - FStar_Compiler_List.fold_right - (fun uu___2 -> - fun stack4 -> - match uu___2 with - | (a, aq) -> - let a1 = - let uu___3 = - (((let uu___4 = - FStar_TypeChecker_Cfg.cfg_env cfg in - uu___4.FStar_TypeChecker_Env.erase_erasable_args) - || - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.for_extraction) - || - (cfg.FStar_TypeChecker_Cfg.debug).FStar_TypeChecker_Cfg.erase_erasable_args) - && - (FStar_Syntax_Util.aqual_is_erasable - aq) in - if uu___3 - then FStar_Syntax_Util.exp_unit - else a in - let env2 = - let uu___3 = - let uu___4 = - FStar_Syntax_Subst.compress a1 in - uu___4.FStar_Syntax_Syntax.n in - match uu___3 with - | FStar_Syntax_Syntax.Tm_name uu___4 -> - empty_env - | FStar_Syntax_Syntax.Tm_constant uu___4 - -> empty_env - | FStar_Syntax_Syntax.Tm_lazy uu___4 -> - empty_env - | FStar_Syntax_Syntax.Tm_fvar uu___4 -> - empty_env - | uu___4 -> env1 in - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = fresh_memo () in - (env2, a1, uu___7, false) in - Clos uu___6 in - (uu___5, aq, - (t1.FStar_Syntax_Syntax.pos)) in - Arg uu___4 in - uu___3 :: stack4) args stack2 in - (FStar_TypeChecker_Cfg.log cfg - (fun uu___3 -> - let uu___4 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length args) in - FStar_Compiler_Util.print1 - "\tPushed %s arguments\n" uu___4); - norm cfg env1 stack3 head) - | FStar_Pervasives_Native.Some strict_args1 -> - let norm_args = - FStar_Compiler_List.map - (fun uu___2 -> - match uu___2 with - | (a, i) -> - let uu___3 = norm cfg env1 [] a in (uu___3, i)) - args in - let norm_args_len = FStar_Compiler_List.length norm_args in - let uu___2 = - FStar_Compiler_List.for_all - (fun i -> - if i >= norm_args_len - then false - else - (let uu___4 = - FStar_Compiler_List.nth norm_args i in - match uu___4 with - | (arg_i, uu___5) -> - let uu___6 = - let uu___7 = - FStar_Syntax_Util.unmeta_safe arg_i in - FStar_Syntax_Util.head_and_args uu___7 in - (match uu___6 with - | (head1, uu___7) -> - let uu___8 = - let uu___9 = - FStar_Syntax_Util.un_uinst head1 in - uu___9.FStar_Syntax_Syntax.n in - (match uu___8 with - | FStar_Syntax_Syntax.Tm_constant - uu___9 -> true - | FStar_Syntax_Syntax.Tm_fvar fv -> - let uu___9 = - FStar_Syntax_Syntax.lid_of_fv - fv in - FStar_TypeChecker_Env.is_datacon - cfg.FStar_TypeChecker_Cfg.tcenv - uu___9 - | uu___9 -> false)))) strict_args1 in - if uu___2 - then - let stack3 = - FStar_Compiler_List.fold_right - (fun uu___3 -> - fun stack4 -> - match uu___3 with - | (a, aq) -> - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Compiler_Util.mk_ref - (FStar_Pervasives_Native.Some - (cfg, ([], a))) in - (env1, a, uu___8, false) in - Clos uu___7 in - (uu___6, aq, - (t1.FStar_Syntax_Syntax.pos)) in - Arg uu___5 in - uu___4 :: stack4) norm_args stack2 in - (FStar_TypeChecker_Cfg.log cfg - (fun uu___4 -> - let uu___5 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length args) in - FStar_Compiler_Util.print1 - "\tPushed %s arguments\n" uu___5); - norm cfg env1 stack3 head) - else - (let head1 = closure_as_term cfg env1 head in - let term = - FStar_Syntax_Syntax.mk_Tm_app head1 norm_args - t1.FStar_Syntax_Syntax.pos in - rebuild cfg env1 stack2 term)) - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x; - FStar_Syntax_Syntax.phi = uu___2;_} - when - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.for_extraction - || - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unrefine - -> norm cfg env1 stack2 x.FStar_Syntax_Syntax.sort - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x; FStar_Syntax_Syntax.phi = f;_} -> - if - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.weak - then - (match (env1, stack2) with - | ([], []) -> - let t_x = norm cfg env1 [] x.FStar_Syntax_Syntax.sort in - let t2 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_refine - { - FStar_Syntax_Syntax.b = - { - FStar_Syntax_Syntax.ppname = - (x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (x.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = t_x - }; - FStar_Syntax_Syntax.phi = f - }) t1.FStar_Syntax_Syntax.pos in - rebuild cfg env1 stack2 t2 - | uu___2 -> - let uu___3 = closure_as_term cfg env1 t1 in - rebuild cfg env1 stack2 uu___3) - else - (let t_x = norm cfg env1 [] x.FStar_Syntax_Syntax.sort in - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.mk_binder x in - [uu___5] in - FStar_Syntax_Subst.open_term uu___4 f in - match uu___3 with - | (closing, f1) -> - let f2 = - let uu___4 = let uu___5 = dummy () in uu___5 :: env1 in - norm cfg uu___4 [] f1 in - let t2 = - let uu___4 = - let uu___5 = - let uu___6 = FStar_Syntax_Subst.close closing f2 in - { - FStar_Syntax_Syntax.b = - { - FStar_Syntax_Syntax.ppname = - (x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (x.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = t_x - }; - FStar_Syntax_Syntax.phi = uu___6 - } in - FStar_Syntax_Syntax.Tm_refine uu___5 in - FStar_Syntax_Syntax.mk uu___4 - t1.FStar_Syntax_Syntax.pos in - rebuild cfg env1 stack2 t2) - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; - FStar_Syntax_Syntax.comp = c;_} - -> - if - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.weak - then - let uu___2 = closure_as_term cfg env1 t1 in - rebuild cfg env1 stack2 uu___2 - else - (let uu___3 = FStar_Syntax_Subst.open_comp bs c in - match uu___3 with - | (bs1, c1) -> - let c2 = - let uu___4 = - FStar_Compiler_List.fold_left - (fun env2 -> - fun uu___5 -> - let uu___6 = dummy () in uu___6 :: env2) - env1 bs1 in - norm_comp cfg uu___4 c1 in - let close_binders env2 bs2 = - let uu___4 = env_subst env2 in - FStar_Syntax_Subst.subst_binders uu___4 bs2 in - let bs2 = - if - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.hnf - then close_binders env1 bs1 - else norm_binders cfg env1 bs1 in - let t2 = FStar_Syntax_Util.arrow bs2 c2 in - rebuild cfg env1 stack2 t2) - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t11; - FStar_Syntax_Syntax.asc = uu___2; - FStar_Syntax_Syntax.eff_opt = l;_} - when - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unascribe - -> norm cfg env1 stack2 t11 - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t11; FStar_Syntax_Syntax.asc = asc; - FStar_Syntax_Syntax.eff_opt = l;_} - -> - let rec stack_may_reduce s = - match s with - | (Match uu___2)::uu___3 when - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.beta - -> true - | (Arg uu___2)::uu___3 when - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.beta - -> true - | (App - (uu___2, - { - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_reify uu___3); - FStar_Syntax_Syntax.pos = uu___4; - FStar_Syntax_Syntax.vars = uu___5; - FStar_Syntax_Syntax.hash_code = uu___6;_}, - uu___7, uu___8))::uu___9 - when - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.beta - -> true - | (MemoLazy uu___2)::uu___3 when - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.beta - -> true - | uu___2 -> false in - let uu___2 = stack_may_reduce stack2 in - if uu___2 - then - (FStar_TypeChecker_Cfg.log cfg - (fun uu___4 -> - FStar_Compiler_Util.print_string - "+++ Dropping ascription \n"); - norm cfg env1 stack2 t11) - else - (FStar_TypeChecker_Cfg.log cfg - (fun uu___5 -> - FStar_Compiler_Util.print_string - "+++ Keeping ascription \n"); - (let t12 = norm cfg env1 [] t11 in - FStar_TypeChecker_Cfg.log cfg - (fun uu___6 -> - FStar_Compiler_Util.print_string - "+++ Normalizing ascription \n"); - (let asc1 = norm_ascription cfg env1 asc in - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = FStar_Syntax_Util.unascribe t12 in - { - FStar_Syntax_Syntax.tm = uu___9; - FStar_Syntax_Syntax.asc = asc1; - FStar_Syntax_Syntax.eff_opt = l - } in - FStar_Syntax_Syntax.Tm_ascribed uu___8 in - FStar_Syntax_Syntax.mk uu___7 - t1.FStar_Syntax_Syntax.pos in - rebuild cfg env1 stack2 uu___6))) - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = head; - FStar_Syntax_Syntax.ret_opt = asc_opt; - FStar_Syntax_Syntax.brs = branches1; - FStar_Syntax_Syntax.rc_opt1 = lopt;_} - -> - let lopt1 = - FStar_Compiler_Util.map_option (maybe_drop_rc_typ cfg) lopt in - let stack3 = - (Match - (env1, asc_opt, branches1, lopt1, cfg, - (t1.FStar_Syntax_Syntax.pos))) - :: stack2 in - if - ((cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.iota - && - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.weakly_reduce_scrutinee) - && - (Prims.op_Negation - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.weak) - then - let cfg' = - { - FStar_TypeChecker_Cfg.steps = - (let uu___2 = cfg.FStar_TypeChecker_Cfg.steps in - { - FStar_TypeChecker_Cfg.beta = - (uu___2.FStar_TypeChecker_Cfg.beta); - FStar_TypeChecker_Cfg.iota = - (uu___2.FStar_TypeChecker_Cfg.iota); - FStar_TypeChecker_Cfg.zeta = - (uu___2.FStar_TypeChecker_Cfg.zeta); - FStar_TypeChecker_Cfg.zeta_full = - (uu___2.FStar_TypeChecker_Cfg.zeta_full); - FStar_TypeChecker_Cfg.weak = true; - FStar_TypeChecker_Cfg.hnf = - (uu___2.FStar_TypeChecker_Cfg.hnf); - FStar_TypeChecker_Cfg.primops = - (uu___2.FStar_TypeChecker_Cfg.primops); - FStar_TypeChecker_Cfg.do_not_unfold_pure_lets = - (uu___2.FStar_TypeChecker_Cfg.do_not_unfold_pure_lets); - FStar_TypeChecker_Cfg.unfold_until = - (uu___2.FStar_TypeChecker_Cfg.unfold_until); - FStar_TypeChecker_Cfg.unfold_only = - (uu___2.FStar_TypeChecker_Cfg.unfold_only); - FStar_TypeChecker_Cfg.unfold_fully = - (uu___2.FStar_TypeChecker_Cfg.unfold_fully); - FStar_TypeChecker_Cfg.unfold_attr = - (uu___2.FStar_TypeChecker_Cfg.unfold_attr); - FStar_TypeChecker_Cfg.unfold_qual = - (uu___2.FStar_TypeChecker_Cfg.unfold_qual); - FStar_TypeChecker_Cfg.unfold_namespace = - (uu___2.FStar_TypeChecker_Cfg.unfold_namespace); - FStar_TypeChecker_Cfg.dont_unfold_attr = - (uu___2.FStar_TypeChecker_Cfg.dont_unfold_attr); - FStar_TypeChecker_Cfg.pure_subterms_within_computations - = - (uu___2.FStar_TypeChecker_Cfg.pure_subterms_within_computations); - FStar_TypeChecker_Cfg.simplify = - (uu___2.FStar_TypeChecker_Cfg.simplify); - FStar_TypeChecker_Cfg.erase_universes = - (uu___2.FStar_TypeChecker_Cfg.erase_universes); - FStar_TypeChecker_Cfg.allow_unbound_universes = - (uu___2.FStar_TypeChecker_Cfg.allow_unbound_universes); - FStar_TypeChecker_Cfg.reify_ = - (uu___2.FStar_TypeChecker_Cfg.reify_); - FStar_TypeChecker_Cfg.compress_uvars = - (uu___2.FStar_TypeChecker_Cfg.compress_uvars); - FStar_TypeChecker_Cfg.no_full_norm = - (uu___2.FStar_TypeChecker_Cfg.no_full_norm); - FStar_TypeChecker_Cfg.check_no_uvars = - (uu___2.FStar_TypeChecker_Cfg.check_no_uvars); - FStar_TypeChecker_Cfg.unmeta = - (uu___2.FStar_TypeChecker_Cfg.unmeta); - FStar_TypeChecker_Cfg.unascribe = - (uu___2.FStar_TypeChecker_Cfg.unascribe); - FStar_TypeChecker_Cfg.in_full_norm_request = - (uu___2.FStar_TypeChecker_Cfg.in_full_norm_request); - FStar_TypeChecker_Cfg.weakly_reduce_scrutinee = - (uu___2.FStar_TypeChecker_Cfg.weakly_reduce_scrutinee); - FStar_TypeChecker_Cfg.nbe_step = - (uu___2.FStar_TypeChecker_Cfg.nbe_step); - FStar_TypeChecker_Cfg.for_extraction = - (uu___2.FStar_TypeChecker_Cfg.for_extraction); - FStar_TypeChecker_Cfg.unrefine = - (uu___2.FStar_TypeChecker_Cfg.unrefine); - FStar_TypeChecker_Cfg.default_univs_to_zero = - (uu___2.FStar_TypeChecker_Cfg.default_univs_to_zero); - FStar_TypeChecker_Cfg.tactics = - (uu___2.FStar_TypeChecker_Cfg.tactics) - }); - FStar_TypeChecker_Cfg.tcenv = - (cfg.FStar_TypeChecker_Cfg.tcenv); - FStar_TypeChecker_Cfg.debug = - (cfg.FStar_TypeChecker_Cfg.debug); - FStar_TypeChecker_Cfg.delta_level = - (cfg.FStar_TypeChecker_Cfg.delta_level); - FStar_TypeChecker_Cfg.primitive_steps = - (cfg.FStar_TypeChecker_Cfg.primitive_steps); - FStar_TypeChecker_Cfg.strong = - (cfg.FStar_TypeChecker_Cfg.strong); - FStar_TypeChecker_Cfg.memoize_lazy = - (cfg.FStar_TypeChecker_Cfg.memoize_lazy); - FStar_TypeChecker_Cfg.normalize_pure_lets = - (cfg.FStar_TypeChecker_Cfg.normalize_pure_lets); - FStar_TypeChecker_Cfg.reifying = - (cfg.FStar_TypeChecker_Cfg.reifying); - FStar_TypeChecker_Cfg.compat_memo_ignore_cfg = - (cfg.FStar_TypeChecker_Cfg.compat_memo_ignore_cfg) - } in - let head_norm = norm cfg' env1 [] head in - rebuild cfg env1 stack3 head_norm - else norm cfg env1 stack3 head - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (b, lbs); - FStar_Syntax_Syntax.body1 = lbody;_} - when - (FStar_Syntax_Syntax.is_top_level lbs) && - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.compress_uvars - -> - let lbs1 = - FStar_Compiler_List.map - (fun lb -> - let uu___2 = - FStar_Syntax_Subst.univ_var_opening - lb.FStar_Syntax_Syntax.lbunivs in - match uu___2 with - | (openings, lbunivs) -> - let cfg1 = - let uu___3 = - FStar_TypeChecker_Env.push_univ_vars - cfg.FStar_TypeChecker_Cfg.tcenv lbunivs in - { - FStar_TypeChecker_Cfg.steps = - (cfg.FStar_TypeChecker_Cfg.steps); - FStar_TypeChecker_Cfg.tcenv = uu___3; - FStar_TypeChecker_Cfg.debug = - (cfg.FStar_TypeChecker_Cfg.debug); - FStar_TypeChecker_Cfg.delta_level = - (cfg.FStar_TypeChecker_Cfg.delta_level); - FStar_TypeChecker_Cfg.primitive_steps = - (cfg.FStar_TypeChecker_Cfg.primitive_steps); - FStar_TypeChecker_Cfg.strong = - (cfg.FStar_TypeChecker_Cfg.strong); - FStar_TypeChecker_Cfg.memoize_lazy = - (cfg.FStar_TypeChecker_Cfg.memoize_lazy); - FStar_TypeChecker_Cfg.normalize_pure_lets = - (cfg.FStar_TypeChecker_Cfg.normalize_pure_lets); - FStar_TypeChecker_Cfg.reifying = - (cfg.FStar_TypeChecker_Cfg.reifying); - FStar_TypeChecker_Cfg.compat_memo_ignore_cfg = - (cfg.FStar_TypeChecker_Cfg.compat_memo_ignore_cfg) - } in - let norm1 t2 = - let uu___3 = - let uu___4 = - FStar_Syntax_Subst.subst openings t2 in - norm cfg1 env1 [] uu___4 in - FStar_Syntax_Subst.close_univ_vars lbunivs uu___3 in - let lbtyp = norm1 lb.FStar_Syntax_Syntax.lbtyp in - let lbdef = norm1 lb.FStar_Syntax_Syntax.lbdef in - { - FStar_Syntax_Syntax.lbname = - (lb.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs = lbunivs; - FStar_Syntax_Syntax.lbtyp = lbtyp; - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = lbdef; - FStar_Syntax_Syntax.lbattrs = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - }) lbs in - let uu___2 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = (b, lbs1); - FStar_Syntax_Syntax.body1 = lbody - }) t1.FStar_Syntax_Syntax.pos in - rebuild cfg env1 stack2 uu___2 - | FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = - (uu___2, - { - FStar_Syntax_Syntax.lbname = FStar_Pervasives.Inr - uu___3; - FStar_Syntax_Syntax.lbunivs = uu___4; - FStar_Syntax_Syntax.lbtyp = uu___5; - FStar_Syntax_Syntax.lbeff = uu___6; - FStar_Syntax_Syntax.lbdef = uu___7; - FStar_Syntax_Syntax.lbattrs = uu___8; - FStar_Syntax_Syntax.lbpos = uu___9;_}::uu___10); - FStar_Syntax_Syntax.body1 = uu___11;_} - -> rebuild cfg env1 stack2 t1 - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (false, lb::[]); - FStar_Syntax_Syntax.body1 = body;_} - -> - let uu___2 = - FStar_TypeChecker_Cfg.should_reduce_local_let cfg lb in - if uu___2 - then - let binder = - let uu___3 = - FStar_Compiler_Util.left lb.FStar_Syntax_Syntax.lbname in - FStar_Syntax_Syntax.mk_binder uu___3 in - let def = - FStar_Syntax_Util.unmeta_lift lb.FStar_Syntax_Syntax.lbdef in - let env2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = fresh_memo () in - (env1, def, uu___6, false) in - Clos uu___5 in - let uu___5 = fresh_memo () in - ((FStar_Pervasives_Native.Some binder), uu___4, uu___5) in - uu___3 :: env1 in - (FStar_TypeChecker_Cfg.log cfg - (fun uu___4 -> - FStar_Compiler_Util.print_string - "+++ Reducing Tm_let\n"); - norm cfg env2 stack2 body) - else - (let uu___4 = - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.tactics - && - (let uu___5 = - FStar_TypeChecker_Env.norm_eff_name - cfg.FStar_TypeChecker_Cfg.tcenv - lb.FStar_Syntax_Syntax.lbeff in - FStar_Syntax_Util.is_div_effect uu___5) in - if uu___4 - then - let ffun = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Compiler_Util.left - lb.FStar_Syntax_Syntax.lbname in - FStar_Syntax_Syntax.mk_binder uu___9 in - [uu___8] in - { - FStar_Syntax_Syntax.bs = uu___7; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = - FStar_Pervasives_Native.None - } in - FStar_Syntax_Syntax.Tm_abs uu___6 in - FStar_Syntax_Syntax.mk uu___5 - t1.FStar_Syntax_Syntax.pos in - let stack3 = - (CBVApp - (env1, ffun, FStar_Pervasives_Native.None, - (t1.FStar_Syntax_Syntax.pos))) - :: stack2 in - (FStar_TypeChecker_Cfg.log cfg - (fun uu___6 -> - FStar_Compiler_Util.print_string - "+++ Evaluating DIV Tm_let\n"); - norm cfg env1 stack3 lb.FStar_Syntax_Syntax.lbdef) - else - if - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.weak - then - (FStar_TypeChecker_Cfg.log cfg - (fun uu___7 -> - FStar_Compiler_Util.print_string - "+++ Not touching Tm_let\n"); - (let uu___7 = closure_as_term cfg env1 t1 in - rebuild cfg env1 stack2 uu___7)) - else - (let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Compiler_Util.left - lb.FStar_Syntax_Syntax.lbname in - FStar_Syntax_Syntax.mk_binder uu___10 in - [uu___9] in - FStar_Syntax_Subst.open_term uu___8 body in - match uu___7 with - | (bs, body1) -> - (FStar_TypeChecker_Cfg.log cfg - (fun uu___9 -> - FStar_Compiler_Util.print_string - "+++ Normalizing Tm_let -- type"); - (let ty = - norm cfg env1 [] lb.FStar_Syntax_Syntax.lbtyp in - let lbname = - let x = - let uu___9 = FStar_Compiler_List.hd bs in - uu___9.FStar_Syntax_Syntax.binder_bv in - FStar_Pervasives.Inl - { - FStar_Syntax_Syntax.ppname = - (x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (x.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = ty - } in - FStar_TypeChecker_Cfg.log cfg - (fun uu___10 -> - FStar_Compiler_Util.print_string - "+++ Normalizing Tm_let -- definiens\n"); - (let lb1 = - let uu___10 = - norm cfg env1 [] - lb.FStar_Syntax_Syntax.lbdef in - let uu___11 = - FStar_Compiler_List.map (norm cfg env1 []) - lb.FStar_Syntax_Syntax.lbattrs in - { - FStar_Syntax_Syntax.lbname = lbname; - FStar_Syntax_Syntax.lbunivs = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = ty; - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = uu___10; - FStar_Syntax_Syntax.lbattrs = uu___11; - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - } in - let env' = - FStar_Compiler_List.fold_left - (fun env2 -> - fun uu___10 -> - let uu___11 = dummy () in uu___11 :: - env2) env1 bs in - FStar_TypeChecker_Cfg.log cfg - (fun uu___11 -> - FStar_Compiler_Util.print_string - "+++ Normalizing Tm_let -- body\n"); - (let cfg' = - { - FStar_TypeChecker_Cfg.steps = - (cfg.FStar_TypeChecker_Cfg.steps); - FStar_TypeChecker_Cfg.tcenv = - (cfg.FStar_TypeChecker_Cfg.tcenv); - FStar_TypeChecker_Cfg.debug = - (cfg.FStar_TypeChecker_Cfg.debug); - FStar_TypeChecker_Cfg.delta_level = - (cfg.FStar_TypeChecker_Cfg.delta_level); - FStar_TypeChecker_Cfg.primitive_steps = - (cfg.FStar_TypeChecker_Cfg.primitive_steps); - FStar_TypeChecker_Cfg.strong = true; - FStar_TypeChecker_Cfg.memoize_lazy = - (cfg.FStar_TypeChecker_Cfg.memoize_lazy); - FStar_TypeChecker_Cfg.normalize_pure_lets - = - (cfg.FStar_TypeChecker_Cfg.normalize_pure_lets); - FStar_TypeChecker_Cfg.reifying = - (cfg.FStar_TypeChecker_Cfg.reifying); - FStar_TypeChecker_Cfg.compat_memo_ignore_cfg - = - (cfg.FStar_TypeChecker_Cfg.compat_memo_ignore_cfg) - } in - let body_norm = - norm cfg' env' - [Let - (env1, bs, lb1, - (t1.FStar_Syntax_Syntax.pos))] body1 in - rebuild cfg env1 stack2 body_norm)))))) - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (true, lbs); - FStar_Syntax_Syntax.body1 = body;_} - when - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.compress_uvars - || - (((Prims.op_Negation - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.zeta) - && - (Prims.op_Negation - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.zeta_full)) - && - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.pure_subterms_within_computations) - -> - let uu___2 = FStar_Syntax_Subst.open_let_rec lbs body in - (match uu___2 with - | (lbs1, body1) -> - let lbs2 = - FStar_Compiler_List.map - (fun lb -> - let ty = - norm cfg env1 [] lb.FStar_Syntax_Syntax.lbtyp in - let lbname = - let uu___3 = - let uu___4 = - FStar_Compiler_Util.left - lb.FStar_Syntax_Syntax.lbname in - { - FStar_Syntax_Syntax.ppname = - (uu___4.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (uu___4.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = ty - } in - FStar_Pervasives.Inl uu___3 in - let uu___3 = - FStar_Syntax_Util.abs_formals - lb.FStar_Syntax_Syntax.lbdef in - match uu___3 with - | (xs, def_body, lopt) -> - let xs1 = norm_binders cfg env1 xs in - let env2 = - let uu___4 = - FStar_Compiler_List.map - (fun uu___5 -> dummy ()) xs1 in - let uu___5 = - let uu___6 = - FStar_Compiler_List.map - (fun uu___7 -> dummy ()) lbs1 in - FStar_Compiler_List.op_At uu___6 env1 in - FStar_Compiler_List.op_At uu___4 uu___5 in - let def_body1 = norm cfg env2 [] def_body in - let lopt1 = - match lopt with - | FStar_Pervasives_Native.Some rc -> - let uu___4 = - let uu___5 = - FStar_Compiler_Util.map_opt - rc.FStar_Syntax_Syntax.residual_typ - (norm cfg env2 []) in - { - FStar_Syntax_Syntax.residual_effect - = - (rc.FStar_Syntax_Syntax.residual_effect); - FStar_Syntax_Syntax.residual_typ = - uu___5; - FStar_Syntax_Syntax.residual_flags = - (rc.FStar_Syntax_Syntax.residual_flags) - } in - FStar_Pervasives_Native.Some uu___4 - | uu___4 -> lopt in - let def = - FStar_Syntax_Util.abs xs1 def_body1 lopt1 in - { - FStar_Syntax_Syntax.lbname = lbname; - FStar_Syntax_Syntax.lbunivs = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = ty; - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = def; - FStar_Syntax_Syntax.lbattrs = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - }) lbs1 in - let env' = - let uu___3 = - FStar_Compiler_List.map (fun uu___4 -> dummy ()) lbs2 in - FStar_Compiler_List.op_At uu___3 env1 in - let body2 = norm cfg env' [] body1 in - let uu___3 = FStar_Syntax_Subst.close_let_rec lbs2 body2 in - (match uu___3 with - | (lbs3, body3) -> - let t2 = - { - FStar_Syntax_Syntax.n = - (FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = (true, lbs3); - FStar_Syntax_Syntax.body1 = body3 - }); - FStar_Syntax_Syntax.pos = - (t1.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = - (t1.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (t1.FStar_Syntax_Syntax.hash_code) - } in - rebuild cfg env1 stack2 t2)) - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = lbs; - FStar_Syntax_Syntax.body1 = body;_} - when - (Prims.op_Negation - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.zeta) - && - (Prims.op_Negation - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.zeta_full) - -> - let uu___2 = closure_as_term cfg env1 t1 in - rebuild cfg env1 stack2 uu___2 - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = lbs; - FStar_Syntax_Syntax.body1 = body;_} - -> - let uu___2 = - FStar_Compiler_List.fold_right - (fun lb -> - fun uu___3 -> - match uu___3 with - | (rec_env, memos, i) -> - let bv = - let uu___4 = - FStar_Compiler_Util.left - lb.FStar_Syntax_Syntax.lbname in - { - FStar_Syntax_Syntax.ppname = - (uu___4.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = i; - FStar_Syntax_Syntax.sort = - (uu___4.FStar_Syntax_Syntax.sort) - } in - let f_i = FStar_Syntax_Syntax.bv_to_tm bv in - let fix_f_i = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = lbs; - FStar_Syntax_Syntax.body1 = f_i - }) t1.FStar_Syntax_Syntax.pos in - let memo = fresh_memo () in - let rec_env1 = - let uu___4 = - let uu___5 = fresh_memo () in - (FStar_Pervasives_Native.None, - (Clos (env1, fix_f_i, memo, true)), uu___5) in - uu___4 :: rec_env in - (rec_env1, (memo :: memos), (i + Prims.int_one))) - (FStar_Pervasives_Native.snd lbs) - (env1, [], Prims.int_zero) in - (match uu___2 with - | (rec_env, memos, uu___3) -> - let uu___4 = - FStar_Compiler_List.map2 - (fun lb -> - fun memo -> - FStar_Compiler_Effect.op_Colon_Equals memo - (FStar_Pervasives_Native.Some - (cfg, - (rec_env, (lb.FStar_Syntax_Syntax.lbdef))))) - (FStar_Pervasives_Native.snd lbs) memos in - let body_env = - FStar_Compiler_List.fold_left - (fun env2 -> - fun lb -> - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = fresh_memo () in - (rec_env, (lb.FStar_Syntax_Syntax.lbdef), - uu___8, false) in - Clos uu___7 in - let uu___7 = fresh_memo () in - (FStar_Pervasives_Native.None, uu___6, uu___7) in - uu___5 :: env2) env1 - (FStar_Pervasives_Native.snd lbs) in - (FStar_TypeChecker_Cfg.log cfg - (fun uu___6 -> - FStar_Compiler_Util.print1 - "reducing with knot %s\n" ""); - norm cfg body_env stack2 body)) - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = head; - FStar_Syntax_Syntax.meta = m;_} - -> - (FStar_TypeChecker_Cfg.log cfg - (fun uu___3 -> - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_metadata m in - FStar_Compiler_Util.print1 ">> metadata = %s\n" uu___4); - (match m with - | FStar_Syntax_Syntax.Meta_monadic (m_from, ty) -> - if - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.for_extraction - then - let uu___3 = - (FStar_TypeChecker_Env.is_erasable_effect - cfg.FStar_TypeChecker_Cfg.tcenv m_from) - || - ((FStar_Syntax_Util.is_pure_effect m_from) && - (FStar_TypeChecker_Env.non_informative - cfg.FStar_TypeChecker_Cfg.tcenv ty)) in - (if uu___3 - then - let uu___4 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 = - FStar_Syntax_Util.exp_unit; - FStar_Syntax_Syntax.meta = m - }) t1.FStar_Syntax_Syntax.pos in - rebuild cfg env1 stack2 uu___4 - else - reduce_impure_comp cfg env1 stack2 head - (FStar_Pervasives.Inl m_from) ty) - else - reduce_impure_comp cfg env1 stack2 head - (FStar_Pervasives.Inl m_from) ty - | FStar_Syntax_Syntax.Meta_monadic_lift (m_from, m_to, ty) - -> - if - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.for_extraction - then - let uu___3 = - ((FStar_TypeChecker_Env.is_erasable_effect - cfg.FStar_TypeChecker_Cfg.tcenv m_from) - || - (FStar_TypeChecker_Env.is_erasable_effect - cfg.FStar_TypeChecker_Cfg.tcenv m_to)) - || - ((FStar_Syntax_Util.is_pure_effect m_from) && - (FStar_TypeChecker_Env.non_informative - cfg.FStar_TypeChecker_Cfg.tcenv ty)) in - (if uu___3 - then - let uu___4 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 = - FStar_Syntax_Util.exp_unit; - FStar_Syntax_Syntax.meta = m - }) t1.FStar_Syntax_Syntax.pos in - rebuild cfg env1 stack2 uu___4 - else - reduce_impure_comp cfg env1 stack2 head - (FStar_Pervasives.Inr (m_from, m_to)) ty) - else - reduce_impure_comp cfg env1 stack2 head - (FStar_Pervasives.Inr (m_from, m_to)) ty - | uu___3 -> - if - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unmeta - then norm cfg env1 stack2 head - else - (match stack2 with - | uu___5::uu___6 -> - (match m with - | FStar_Syntax_Syntax.Meta_labeled - (l, r, uu___7) -> - norm cfg env1 ((Meta (env1, m, r)) :: - stack2) head - | FStar_Syntax_Syntax.Meta_pattern (names, args) - -> - let args1 = norm_pattern_args cfg env1 args in - let names1 = - FStar_Compiler_List.map (norm cfg env1 []) - names in - norm cfg env1 - ((Meta - (env1, - (FStar_Syntax_Syntax.Meta_pattern - (names1, args1)), - (t1.FStar_Syntax_Syntax.pos))) :: - stack2) head - | FStar_Syntax_Syntax.Meta_desugared - (FStar_Syntax_Syntax.Sequence) when - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.do_not_unfold_pure_lets - -> - norm cfg env1 - ((Meta - (env1, m, - (t1.FStar_Syntax_Syntax.pos))) :: - stack2) head - | FStar_Syntax_Syntax.Meta_desugared - (FStar_Syntax_Syntax.Machine_integer - (uu___7, uu___8)) -> - norm cfg env1 - ((Meta - (env1, m, - (t1.FStar_Syntax_Syntax.pos))) :: - stack2) head - | uu___7 -> norm cfg env1 stack2 head) - | [] -> - let head1 = norm cfg env1 [] head in - let m1 = - match m with - | FStar_Syntax_Syntax.Meta_pattern - (names, args) -> - let names1 = - FStar_Compiler_List.map - (norm cfg env1 []) names in - let uu___5 = - let uu___6 = - norm_pattern_args cfg env1 args in - (names1, uu___6) in - FStar_Syntax_Syntax.Meta_pattern uu___5 - | uu___5 -> m in - let t2 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 = head1; - FStar_Syntax_Syntax.meta = m1 - }) t1.FStar_Syntax_Syntax.pos in - rebuild cfg env1 stack2 t2))) - | FStar_Syntax_Syntax.Tm_delayed uu___2 -> - failwith "impossible: Tm_delayed on norm" - | FStar_Syntax_Syntax.Tm_uvar uu___2 -> - (if - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.check_no_uvars - then - (let uu___4 = - let uu___5 = - FStar_Class_Show.show - FStar_Compiler_Range_Ops.showable_range - t1.FStar_Syntax_Syntax.pos in - let uu___6 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - t1 in - FStar_Compiler_Util.format2 - "(%s) CheckNoUvars: Unexpected unification variable remains: %s" - uu___5 uu___6 in - failwith uu___4) - else (); - (let t2 = - FStar_Errors.with_ctx "inlining" - (fun uu___4 -> closure_as_term cfg env1 t1) in - rebuild cfg env1 stack2 t2))) -and (do_unfold_fv : - FStar_TypeChecker_Cfg.cfg -> - stack_elt Prims.list -> - FStar_Syntax_Syntax.term -> - FStar_TypeChecker_Env.qninfo -> - FStar_Syntax_Syntax.fv -> FStar_Syntax_Syntax.term) - = - fun cfg -> - fun stack1 -> - fun t0 -> - fun qninfo -> - fun f -> - let defn uu___ = - FStar_TypeChecker_Env.lookup_definition_qninfo - cfg.FStar_TypeChecker_Cfg.delta_level - (f.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v qninfo in - let defn1 uu___ = - if - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.for_extraction - then - match qninfo with - | FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr (se, FStar_Pervasives_Native.None), - uu___1) - when - FStar_TypeChecker_Env.visible_with - cfg.FStar_TypeChecker_Cfg.delta_level - se.FStar_Syntax_Syntax.sigquals - -> - let uu___2 = - FStar_Compiler_Util.find_map - se.FStar_Syntax_Syntax.sigattrs is_extract_as_attr in - (match uu___2 with - | FStar_Pervasives_Native.Some impl -> - FStar_Pervasives_Native.Some ([], impl) - | FStar_Pervasives_Native.None -> defn ()) - | uu___1 -> defn () - else defn () in - let uu___ = defn1 () in - match uu___ with - | FStar_Pervasives_Native.None -> - (FStar_TypeChecker_Cfg.log_unfolding cfg - (fun uu___2 -> - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_fv - f in - let uu___4 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_TypeChecker_Env.showable_delta_level) - cfg.FStar_TypeChecker_Cfg.delta_level in - FStar_Compiler_Util.print2 - " >> No definition found for %s (delta_level = %s)\n" - uu___3 uu___4); - rebuild cfg empty_env stack1 t0) - | FStar_Pervasives_Native.Some (us, t) -> - (FStar_TypeChecker_Cfg.log_unfolding cfg - (fun uu___2 -> - let uu___3 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t0 in - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.print2 " >> Unfolded %s to %s\n" - uu___3 uu___4); - (let t1 = - if - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_until - = - (FStar_Pervasives_Native.Some - FStar_Syntax_Syntax.delta_constant) - then t - else - FStar_Syntax_Subst.set_use_range - t0.FStar_Syntax_Syntax.pos t in - let n = FStar_Compiler_List.length us in - if n > Prims.int_zero - then - match stack1 with - | (UnivArgs (us', uu___2))::stack2 -> - ((let uu___4 = - FStar_Compiler_Effect.op_Bang dbg_univ_norm in - if uu___4 - then - FStar_Compiler_List.iter - (fun x -> - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_univ x in - FStar_Compiler_Util.print1 - "Univ (normalizer) %s\n" uu___5) us' - else ()); - (let env1 = - FStar_Compiler_List.fold_left - (fun env2 -> - fun u -> - let uu___4 = - let uu___5 = fresh_memo () in - (FStar_Pervasives_Native.None, ( - Univ u), uu___5) in - uu___4 :: env2) empty_env us' in - norm cfg env1 stack2 t1)) - | uu___2 when - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.erase_universes - || - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.allow_unbound_universes - -> norm cfg empty_env stack1 t1 - | uu___2 -> - let uu___3 = - let uu___4 = - FStar_Class_Show.show FStar_Ident.showable_lident - (f.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - FStar_Compiler_Util.format1 - "Impossible: missing universe instantiation on %s" - uu___4 in - failwith uu___3 - else norm cfg empty_env stack1 t1)) -and (reduce_impure_comp : - FStar_TypeChecker_Cfg.cfg -> - env -> - stack_elt Prims.list -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.monad_name, - (FStar_Syntax_Syntax.monad_name * FStar_Syntax_Syntax.monad_name)) - FStar_Pervasives.either -> - FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.term) - = - fun cfg -> - fun env1 -> - fun stack1 -> - fun head -> - fun m -> - fun t -> - let t1 = norm cfg env1 [] t in - let metadata = - match m with - | FStar_Pervasives.Inl m1 -> - FStar_Syntax_Syntax.Meta_monadic (m1, t1) - | FStar_Pervasives.Inr (m1, m') -> - FStar_Syntax_Syntax.Meta_monadic_lift (m1, m', t1) in - norm cfg env1 - ((Meta (env1, metadata, (head.FStar_Syntax_Syntax.pos))) :: - stack1) head -and (do_reify_monadic : - (unit -> FStar_Syntax_Syntax.term) -> - FStar_TypeChecker_Cfg.cfg -> - env -> - stack_elt Prims.list -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.monad_name -> - FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.term) - = - fun fallback -> - fun cfg -> - fun env1 -> - fun stack1 -> - fun top -> - fun m -> - fun t -> - (match stack1 with - | (App - (uu___1, - { - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_reify uu___2); - FStar_Syntax_Syntax.pos = uu___3; - FStar_Syntax_Syntax.vars = uu___4; - FStar_Syntax_Syntax.hash_code = uu___5;_}, - uu___6, uu___7))::uu___8 - -> () - | uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Show.show - (FStar_Class_Show.show_list showable_stack_elt) - stack1 in - FStar_Compiler_Util.format1 - "INTERNAL ERROR: do_reify_monadic: bad stack: %s" - uu___3 in - failwith uu___2); - (let top0 = top in - let top1 = FStar_Syntax_Util.unascribe top in - FStar_TypeChecker_Cfg.log cfg - (fun uu___2 -> - let uu___3 = - FStar_Class_Tagged.tag_of - FStar_Syntax_Syntax.tagged_term top1 in - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term top1 in - FStar_Compiler_Util.print2 "Reifying: (%s) %s\n" uu___3 - uu___4); - (let top2 = FStar_Syntax_Util.unmeta_safe top1 in - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress top2 in - uu___3.FStar_Syntax_Syntax.n in - match uu___2 with - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (false, lb::[]); - FStar_Syntax_Syntax.body1 = body;_} - -> - let eff_name = - FStar_TypeChecker_Env.norm_eff_name - cfg.FStar_TypeChecker_Cfg.tcenv m in - let ed = - FStar_TypeChecker_Env.get_effect_decl - cfg.FStar_TypeChecker_Cfg.tcenv eff_name in - let uu___3 = - let uu___4 = FStar_Syntax_Util.get_eff_repr ed in - FStar_Compiler_Util.must uu___4 in - (match uu___3 with - | (uu___4, repr) -> - let uu___5 = - let uu___6 = FStar_Syntax_Util.get_bind_repr ed in - FStar_Compiler_Util.must uu___6 in - (match uu___5 with - | (uu___6, bind_repr) -> - (match lb.FStar_Syntax_Syntax.lbname with - | FStar_Pervasives.Inr uu___7 -> - failwith - "Cannot reify a top-level let binding" - | FStar_Pervasives.Inl x -> - let is_return e = - let uu___7 = - let uu___8 = - FStar_Syntax_Subst.compress e in - uu___8.FStar_Syntax_Syntax.n in - match uu___7 with - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = e1; - FStar_Syntax_Syntax.meta = - FStar_Syntax_Syntax.Meta_monadic - (uu___8, uu___9);_} - -> - let uu___10 = - let uu___11 = - FStar_Syntax_Subst.compress e1 in - uu___11.FStar_Syntax_Syntax.n in - (match uu___10 with - | FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 = - e2; - FStar_Syntax_Syntax.meta = - FStar_Syntax_Syntax.Meta_monadic_lift - (uu___11, msrc, uu___12);_} - when - FStar_Syntax_Util.is_pure_effect - msrc - -> - let uu___13 = - FStar_Syntax_Subst.compress - e2 in - FStar_Pervasives_Native.Some - uu___13 - | uu___11 -> - FStar_Pervasives_Native.None) - | uu___8 -> - FStar_Pervasives_Native.None in - let uu___7 = - is_return lb.FStar_Syntax_Syntax.lbdef in - (match uu___7 with - | FStar_Pervasives_Native.Some e -> - let lb1 = - { - FStar_Syntax_Syntax.lbname = - (lb.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = - (lb.FStar_Syntax_Syntax.lbtyp); - FStar_Syntax_Syntax.lbeff = - FStar_Parser_Const.effect_PURE_lid; - FStar_Syntax_Syntax.lbdef = e; - FStar_Syntax_Syntax.lbattrs = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - } in - let uu___8 = - FStar_Compiler_List.tl stack1 in - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Syntax_Util.mk_reify - body - (FStar_Pervasives_Native.Some - m) in - { - FStar_Syntax_Syntax.lbs = - (false, [lb1]); - FStar_Syntax_Syntax.body1 = - uu___12 - } in - FStar_Syntax_Syntax.Tm_let - uu___11 in - FStar_Syntax_Syntax.mk uu___10 - top2.FStar_Syntax_Syntax.pos in - norm cfg env1 uu___8 uu___9 - | FStar_Pervasives_Native.None -> - let uu___8 = - let uu___9 = is_return body in - match uu___9 with - | FStar_Pervasives_Native.Some - { - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_bvar - y; - FStar_Syntax_Syntax.pos = - uu___10; - FStar_Syntax_Syntax.vars = - uu___11; - FStar_Syntax_Syntax.hash_code - = uu___12;_} - -> - FStar_Syntax_Syntax.bv_eq x y - | uu___10 -> false in - if uu___8 - then - norm cfg env1 stack1 - lb.FStar_Syntax_Syntax.lbdef - else - (let rng = - top2.FStar_Syntax_Syntax.pos in - let head = - FStar_Syntax_Util.mk_reify - lb.FStar_Syntax_Syntax.lbdef - (FStar_Pervasives_Native.Some - m) in - let body1 = - FStar_Syntax_Util.mk_reify - body - (FStar_Pervasives_Native.Some - m) in - let body_rc = - { - FStar_Syntax_Syntax.residual_effect - = m; - FStar_Syntax_Syntax.residual_typ - = - (FStar_Pervasives_Native.Some - t); - FStar_Syntax_Syntax.residual_flags - = [] - } in - let body2 = - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Syntax_Syntax.mk_binder - x in - [uu___13] in - { - FStar_Syntax_Syntax.bs = - uu___12; - FStar_Syntax_Syntax.body - = body1; - FStar_Syntax_Syntax.rc_opt - = - (FStar_Pervasives_Native.Some - body_rc) - } in - FStar_Syntax_Syntax.Tm_abs - uu___11 in - FStar_Syntax_Syntax.mk uu___10 - body1.FStar_Syntax_Syntax.pos in - let close = - closure_as_term cfg env1 in - let bind_inst = - let uu___10 = - let uu___11 = - FStar_Syntax_Subst.compress - bind_repr in - uu___11.FStar_Syntax_Syntax.n in - match uu___10 with - | FStar_Syntax_Syntax.Tm_uinst - (bind, - uu___11::uu___12::[]) - -> - let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = - let uu___17 = - close - lb.FStar_Syntax_Syntax.lbtyp in - (cfg.FStar_TypeChecker_Cfg.tcenv).FStar_TypeChecker_Env.universe_of - cfg.FStar_TypeChecker_Cfg.tcenv - uu___17 in - let uu___17 = - let uu___18 = - let uu___19 = - close t in - (cfg.FStar_TypeChecker_Cfg.tcenv).FStar_TypeChecker_Env.universe_of - cfg.FStar_TypeChecker_Cfg.tcenv - uu___19 in - [uu___18] in - uu___16 :: uu___17 in - (bind, uu___15) in - FStar_Syntax_Syntax.Tm_uinst - uu___14 in - FStar_Syntax_Syntax.mk - uu___13 rng - | uu___11 -> - failwith - "NIY : Reification of indexed effects" in - let bind_inst_args f_arg = - let uu___10 = - FStar_Syntax_Util.is_layered - ed in - if uu___10 - then - let bind_has_range_args = - FStar_Syntax_Util.has_attribute - ed.FStar_Syntax_Syntax.eff_attrs - FStar_Parser_Const.bind_has_range_args_attr in - let num_fixed_binders = - if bind_has_range_args - then (Prims.of_int (4)) - else (Prims.of_int (2)) in - let unit_args = - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - FStar_Syntax_Util.get_bind_vc_combinator - ed in - FStar_Pervasives_Native.fst - uu___15 in - FStar_Pervasives_Native.snd - uu___14 in - FStar_Syntax_Subst.compress - uu___13 in - uu___12.FStar_Syntax_Syntax.n in - match uu___11 with - | FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 - = - uu___12::uu___13::bs; - FStar_Syntax_Syntax.comp - = uu___14;_} - when - (FStar_Compiler_List.length - bs) - >= num_fixed_binders - -> - let uu___15 = - let uu___16 = - FStar_Compiler_List.splitAt - ((FStar_Compiler_List.length - bs) - - - num_fixed_binders) - bs in - FStar_Pervasives_Native.fst - uu___16 in - FStar_Compiler_List.map - (fun uu___16 -> - FStar_Syntax_Syntax.as_arg - FStar_Syntax_Syntax.unit_const) - uu___15 - | uu___12 -> - let uu___13 = - let uu___14 = - FStar_Class_Show.show - FStar_Ident.showable_lident - ed.FStar_Syntax_Syntax.mname in - let uu___15 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - num_fixed_binders in - let uu___16 = - let uu___17 = - let uu___18 = - let uu___19 = - FStar_Syntax_Util.get_bind_vc_combinator - ed in - FStar_Pervasives_Native.fst - uu___19 in - FStar_Pervasives_Native.snd - uu___18 in - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - uu___17 in - FStar_Compiler_Util.format3 - "bind_wp for layered effect %s is not an arrow with >= %s arguments (%s)" - uu___14 uu___15 - uu___16 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - rng - FStar_Errors_Codes.Fatal_UnexpectedEffect - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___13) in - let range_args = - if bind_has_range_args - then - let uu___11 = - let uu___12 = - FStar_TypeChecker_Primops_Base.embed_simple - FStar_Syntax_Embeddings.e_range - lb.FStar_Syntax_Syntax.lbpos - lb.FStar_Syntax_Syntax.lbpos in - FStar_Syntax_Syntax.as_arg - uu___12 in - let uu___12 = - let uu___13 = - let uu___14 = - FStar_TypeChecker_Primops_Base.embed_simple - FStar_Syntax_Embeddings.e_range - body2.FStar_Syntax_Syntax.pos - body2.FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.as_arg - uu___14 in - [uu___13] in - uu___11 :: uu___12 - else [] in - let uu___11 = - FStar_Syntax_Syntax.as_arg - lb.FStar_Syntax_Syntax.lbtyp in - let uu___12 = - let uu___13 = - FStar_Syntax_Syntax.as_arg - t in - let uu___14 = - let uu___15 = - let uu___16 = - let uu___17 = - FStar_Syntax_Syntax.as_arg - f_arg in - let uu___18 = - let uu___19 = - FStar_Syntax_Syntax.as_arg - body2 in - [uu___19] in - uu___17 :: uu___18 in - FStar_Compiler_List.op_At - range_args uu___16 in - FStar_Compiler_List.op_At - unit_args uu___15 in - uu___13 :: uu___14 in - uu___11 :: uu___12 - else - (let maybe_range_arg = - let uu___12 = - FStar_Compiler_Util.for_some - (FStar_TypeChecker_TermEqAndSimplify.eq_tm_bool - cfg.FStar_TypeChecker_Cfg.tcenv - FStar_Syntax_Util.dm4f_bind_range_attr) - ed.FStar_Syntax_Syntax.eff_attrs in - if uu___12 - then - let uu___13 = - let uu___14 = - FStar_TypeChecker_Primops_Base.embed_simple - FStar_Syntax_Embeddings.e_range - lb.FStar_Syntax_Syntax.lbpos - lb.FStar_Syntax_Syntax.lbpos in - FStar_Syntax_Syntax.as_arg - uu___14 in - let uu___14 = - let uu___15 = - let uu___16 = - FStar_TypeChecker_Primops_Base.embed_simple - FStar_Syntax_Embeddings.e_range - body2.FStar_Syntax_Syntax.pos - body2.FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.as_arg - uu___16 in - [uu___15] in - uu___13 :: uu___14 - else [] in - let uu___12 = - let uu___13 = - FStar_Syntax_Syntax.as_arg - lb.FStar_Syntax_Syntax.lbtyp in - let uu___14 = - let uu___15 = - FStar_Syntax_Syntax.as_arg - t in - [uu___15] in - uu___13 :: uu___14 in - let uu___13 = - let uu___14 = - let uu___15 = - FStar_Syntax_Syntax.as_arg - FStar_Syntax_Syntax.tun in - let uu___16 = - let uu___17 = - FStar_Syntax_Syntax.as_arg - f_arg in - let uu___18 = - let uu___19 = - FStar_Syntax_Syntax.as_arg - FStar_Syntax_Syntax.tun in - let uu___20 = - let uu___21 = - FStar_Syntax_Syntax.as_arg - body2 in - [uu___21] in - uu___19 :: uu___20 in - uu___17 :: uu___18 in - uu___15 :: uu___16 in - FStar_Compiler_List.op_At - maybe_range_arg uu___14 in - FStar_Compiler_List.op_At - uu___12 uu___13) in - let reified = - let is_total_effect = - FStar_TypeChecker_Env.is_total_effect - cfg.FStar_TypeChecker_Cfg.tcenv - eff_name in - if is_total_effect - then - let uu___10 = - let uu___11 = - let uu___12 = - bind_inst_args head in - { - FStar_Syntax_Syntax.hd - = bind_inst; - FStar_Syntax_Syntax.args - = uu___12 - } in - FStar_Syntax_Syntax.Tm_app - uu___11 in - FStar_Syntax_Syntax.mk - uu___10 rng - else - (let uu___11 = - let bv = - FStar_Syntax_Syntax.new_bv - FStar_Pervasives_Native.None - x.FStar_Syntax_Syntax.sort in - let lb1 = - let uu___12 = - let uu___13 = - let uu___14 = - FStar_Syntax_Syntax.as_arg - x.FStar_Syntax_Syntax.sort in - [uu___14] in - FStar_Syntax_Util.mk_app - repr uu___13 in - { - FStar_Syntax_Syntax.lbname - = - (FStar_Pervasives.Inl - bv); - FStar_Syntax_Syntax.lbunivs - = []; - FStar_Syntax_Syntax.lbtyp - = uu___12; - FStar_Syntax_Syntax.lbeff - = - (if is_total_effect - then - FStar_Parser_Const.effect_Tot_lid - else - FStar_Parser_Const.effect_Dv_lid); - FStar_Syntax_Syntax.lbdef - = head; - FStar_Syntax_Syntax.lbattrs - = []; - FStar_Syntax_Syntax.lbpos - = - (head.FStar_Syntax_Syntax.pos) - } in - let uu___12 = - FStar_Syntax_Syntax.bv_to_name - bv in - (lb1, bv, uu___12) in - match uu___11 with - | (lb_head, head_bv, head1) - -> - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = - FStar_Syntax_Syntax.mk_binder - head_bv in - [uu___16] in - let uu___16 = - let uu___17 = - let uu___18 = - let uu___19 - = - bind_inst_args - head1 in - { - FStar_Syntax_Syntax.hd - = - bind_inst; - FStar_Syntax_Syntax.args - = uu___19 - } in - FStar_Syntax_Syntax.Tm_app - uu___18 in - FStar_Syntax_Syntax.mk - uu___17 rng in - FStar_Syntax_Subst.close - uu___15 uu___16 in - { - FStar_Syntax_Syntax.lbs - = - (false, - [lb_head]); - FStar_Syntax_Syntax.body1 - = uu___14 - } in - FStar_Syntax_Syntax.Tm_let - uu___13 in - FStar_Syntax_Syntax.mk - uu___12 rng) in - FStar_TypeChecker_Cfg.log cfg - (fun uu___11 -> - let uu___12 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - top0 in - let uu___13 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - reified in - FStar_Compiler_Util.print2 - "Reified (1) <%s> to %s\n" - uu___12 uu___13); - (let uu___11 = - FStar_Compiler_List.tl stack1 in - norm cfg env1 uu___11 reified)))))) - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = args;_} - -> - ((let uu___4 = FStar_Options.defensive () in - if uu___4 - then - let is_arg_impure uu___5 = - match uu___5 with - | (e, q) -> - let uu___6 = - let uu___7 = FStar_Syntax_Subst.compress e in - uu___7.FStar_Syntax_Syntax.n in - (match uu___6 with - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = e0; - FStar_Syntax_Syntax.meta = - FStar_Syntax_Syntax.Meta_monadic_lift - (m1, m2, t');_} - -> - let uu___7 = - FStar_Syntax_Util.is_pure_effect m1 in - Prims.op_Negation uu___7 - | uu___7 -> false) in - let uu___5 = - let uu___6 = - let uu___7 = FStar_Syntax_Syntax.as_arg head in - uu___7 :: args in - FStar_Compiler_Util.for_some is_arg_impure uu___6 in - (if uu___5 - then - let uu___6 = - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term top2 in - FStar_Compiler_Util.format1 - "Incompatibility between typechecker and normalizer; this monadic application contains impure terms %s\n" - uu___7 in - FStar_Errors.log_issue - (FStar_Syntax_Syntax.has_range_syntax ()) top2 - FStar_Errors_Codes.Warning_Defensive () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___6) - else ()) - else ()); - (let fallback1 uu___4 = - FStar_TypeChecker_Cfg.log cfg - (fun uu___6 -> - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term top0 in - FStar_Compiler_Util.print2 - "Reified (2) <%s> to %s\n" uu___7 ""); - (let uu___6 = FStar_Compiler_List.tl stack1 in - let uu___7 = - FStar_Syntax_Util.mk_reify top2 - (FStar_Pervasives_Native.Some m) in - norm cfg env1 uu___6 uu___7) in - let fallback2 uu___4 = - FStar_TypeChecker_Cfg.log cfg - (fun uu___6 -> - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term top0 in - FStar_Compiler_Util.print2 - "Reified (3) <%s> to %s\n" uu___7 ""); - (let uu___6 = FStar_Compiler_List.tl stack1 in - let uu___7 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 = top2; - FStar_Syntax_Syntax.meta = - (FStar_Syntax_Syntax.Meta_monadic - (m, t)) - }) top0.FStar_Syntax_Syntax.pos in - norm cfg env1 uu___6 uu___7) in - let uu___4 = - let uu___5 = FStar_Syntax_Util.un_uinst head in - uu___5.FStar_Syntax_Syntax.n in - match uu___4 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - let lid = FStar_Syntax_Syntax.lid_of_fv fv in - let qninfo = - FStar_TypeChecker_Env.lookup_qname - cfg.FStar_TypeChecker_Cfg.tcenv lid in - let uu___5 = - let uu___6 = - FStar_TypeChecker_Env.is_action - cfg.FStar_TypeChecker_Cfg.tcenv lid in - Prims.op_Negation uu___6 in - if uu___5 - then fallback1 () - else - (let uu___7 = - let uu___8 = - FStar_TypeChecker_Env.lookup_definition_qninfo - cfg.FStar_TypeChecker_Cfg.delta_level - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - qninfo in - FStar_Compiler_Option.isNone uu___8 in - if uu___7 - then fallback2 () - else - (let t1 = - let uu___9 = - FStar_Syntax_Util.mk_reify head - (FStar_Pervasives_Native.Some m) in - FStar_Syntax_Syntax.mk_Tm_app uu___9 args - t.FStar_Syntax_Syntax.pos in - let uu___9 = FStar_Compiler_List.tl stack1 in - norm cfg env1 uu___9 t1)) - | uu___5 -> fallback1 ())) - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = e; - FStar_Syntax_Syntax.meta = - FStar_Syntax_Syntax.Meta_monadic uu___3;_} - -> do_reify_monadic fallback cfg env1 stack1 e m t - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = e; - FStar_Syntax_Syntax.meta = - FStar_Syntax_Syntax.Meta_monadic_lift - (msrc, mtgt, t');_} - -> - let lifted = - let uu___3 = closure_as_term cfg env1 t' in - reify_lift cfg e msrc mtgt uu___3 in - (FStar_TypeChecker_Cfg.log cfg - (fun uu___4 -> - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term lifted in - FStar_Compiler_Util.print1 - "Reified lift to (2): %s\n" uu___5); - (let uu___4 = FStar_Compiler_List.tl stack1 in - norm cfg env1 uu___4 lifted)) - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = e; - FStar_Syntax_Syntax.ret_opt = asc_opt; - FStar_Syntax_Syntax.brs = branches1; - FStar_Syntax_Syntax.rc_opt1 = lopt;_} - -> - let branches2 = - FStar_Compiler_List.map - (fun uu___3 -> - match uu___3 with - | (pat, wopt, tm) -> - let uu___4 = - FStar_Syntax_Util.mk_reify tm - (FStar_Pervasives_Native.Some m) in - (pat, wopt, uu___4)) branches1 in - let tm = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_match - { - FStar_Syntax_Syntax.scrutinee = e; - FStar_Syntax_Syntax.ret_opt = asc_opt; - FStar_Syntax_Syntax.brs = branches2; - FStar_Syntax_Syntax.rc_opt1 = lopt - }) top2.FStar_Syntax_Syntax.pos in - let uu___3 = FStar_Compiler_List.tl stack1 in - norm cfg env1 uu___3 tm - | uu___3 -> fallback ())) -and (reify_lift : - FStar_TypeChecker_Cfg.cfg -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.monad_name -> - FStar_Syntax_Syntax.monad_name -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun cfg -> - fun e -> - fun msrc -> - fun mtgt -> - fun t -> - let env1 = cfg.FStar_TypeChecker_Cfg.tcenv in - FStar_TypeChecker_Cfg.log cfg - (fun uu___1 -> - let uu___2 = FStar_Ident.string_of_lid msrc in - let uu___3 = FStar_Ident.string_of_lid mtgt in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - FStar_Compiler_Util.print3 "Reifying lift %s -> %s: %s\n" - uu___2 uu___3 uu___4); - (let uu___1 = - ((FStar_Syntax_Util.is_pure_effect msrc) || - (FStar_Syntax_Util.is_div_effect msrc)) - && - (let uu___2 = - FStar_TypeChecker_Env.is_layered_effect env1 mtgt in - Prims.op_Negation uu___2) in - if uu___1 - then - let ed = - let uu___2 = - FStar_TypeChecker_Env.norm_eff_name - cfg.FStar_TypeChecker_Cfg.tcenv mtgt in - FStar_TypeChecker_Env.get_effect_decl env1 uu___2 in - let uu___2 = - let uu___3 = FStar_Syntax_Util.get_eff_repr ed in - FStar_Compiler_Util.must uu___3 in - match uu___2 with - | (uu___3, repr) -> - let uu___4 = - let uu___5 = FStar_Syntax_Util.get_return_repr ed in - FStar_Compiler_Util.must uu___5 in - (match uu___4 with - | (uu___5, return_repr) -> - let return_inst = - let uu___6 = - let uu___7 = - FStar_Syntax_Subst.compress return_repr in - uu___7.FStar_Syntax_Syntax.n in - match uu___6 with - | FStar_Syntax_Syntax.Tm_uinst - (return_tm, uu___7::[]) -> - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - env1.FStar_TypeChecker_Env.universe_of - env1 t in - [uu___11] in - (return_tm, uu___10) in - FStar_Syntax_Syntax.Tm_uinst uu___9 in - FStar_Syntax_Syntax.mk uu___8 - e.FStar_Syntax_Syntax.pos - | uu___7 -> - failwith "NIY : Reification of indexed effects" in - let uu___6 = - let bv = - FStar_Syntax_Syntax.new_bv - FStar_Pervasives_Native.None t in - let lb = - let uu___7 = - let uu___8 = - let uu___9 = FStar_Syntax_Syntax.as_arg t in - [uu___9] in - FStar_Syntax_Util.mk_app repr uu___8 in - { - FStar_Syntax_Syntax.lbname = - (FStar_Pervasives.Inl bv); - FStar_Syntax_Syntax.lbunivs = []; - FStar_Syntax_Syntax.lbtyp = uu___7; - FStar_Syntax_Syntax.lbeff = msrc; - FStar_Syntax_Syntax.lbdef = e; - FStar_Syntax_Syntax.lbattrs = []; - FStar_Syntax_Syntax.lbpos = - (e.FStar_Syntax_Syntax.pos) - } in - let uu___7 = FStar_Syntax_Syntax.bv_to_name bv in - (lb, bv, uu___7) in - (match uu___6 with - | (lb_e, e_bv, e1) -> - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Syntax_Syntax.mk_binder e_bv in - [uu___11] in - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - FStar_Syntax_Syntax.as_arg t in - let uu___16 = - let uu___17 = - FStar_Syntax_Syntax.as_arg e1 in - [uu___17] in - uu___15 :: uu___16 in - { - FStar_Syntax_Syntax.hd = - return_inst; - FStar_Syntax_Syntax.args = uu___14 - } in - FStar_Syntax_Syntax.Tm_app uu___13 in - FStar_Syntax_Syntax.mk uu___12 - e1.FStar_Syntax_Syntax.pos in - FStar_Syntax_Subst.close uu___10 uu___11 in - { - FStar_Syntax_Syntax.lbs = (false, [lb_e]); - FStar_Syntax_Syntax.body1 = uu___9 - } in - FStar_Syntax_Syntax.Tm_let uu___8 in - FStar_Syntax_Syntax.mk uu___7 - e1.FStar_Syntax_Syntax.pos)) - else - (let uu___3 = FStar_TypeChecker_Env.monad_leq env1 msrc mtgt in - match uu___3 with - | FStar_Pervasives_Native.None -> - let uu___4 = - let uu___5 = FStar_Ident.string_of_lid msrc in - let uu___6 = FStar_Ident.string_of_lid mtgt in - FStar_Compiler_Util.format2 - "Impossible : trying to reify a lift between unrelated effects (%s and %s)" - uu___5 uu___6 in - failwith uu___4 - | FStar_Pervasives_Native.Some - { FStar_TypeChecker_Env.msource = uu___4; - FStar_TypeChecker_Env.mtarget = uu___5; - FStar_TypeChecker_Env.mlift = - { FStar_TypeChecker_Env.mlift_wp = uu___6; - FStar_TypeChecker_Env.mlift_term = - FStar_Pervasives_Native.None;_}; - FStar_TypeChecker_Env.mpath = uu___7;_} - -> - let uu___8 = - let uu___9 = FStar_Ident.string_of_lid msrc in - let uu___10 = FStar_Ident.string_of_lid mtgt in - FStar_Compiler_Util.format2 - "Impossible : trying to reify a non-reifiable lift (from %s to %s)" - uu___9 uu___10 in - failwith uu___8 - | FStar_Pervasives_Native.Some - { FStar_TypeChecker_Env.msource = uu___4; - FStar_TypeChecker_Env.mtarget = uu___5; - FStar_TypeChecker_Env.mlift = - { FStar_TypeChecker_Env.mlift_wp = uu___6; - FStar_TypeChecker_Env.mlift_term = - FStar_Pervasives_Native.Some lift;_}; - FStar_TypeChecker_Env.mpath = uu___7;_} - -> - let e1 = - let uu___8 = - FStar_TypeChecker_Env.is_reifiable_effect env1 msrc in - if uu___8 - then - FStar_Syntax_Util.mk_reify e - (FStar_Pervasives_Native.Some msrc) - else - (let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Syntax_Syntax.null_binder - FStar_Syntax_Syntax.t_unit in - [uu___13] in - { - FStar_Syntax_Syntax.bs = uu___12; - FStar_Syntax_Syntax.body = e; - FStar_Syntax_Syntax.rc_opt = - (FStar_Pervasives_Native.Some - { - FStar_Syntax_Syntax.residual_effect = - msrc; - FStar_Syntax_Syntax.residual_typ = - (FStar_Pervasives_Native.Some t); - FStar_Syntax_Syntax.residual_flags = [] - }) - } in - FStar_Syntax_Syntax.Tm_abs uu___11 in - FStar_Syntax_Syntax.mk uu___10 - e.FStar_Syntax_Syntax.pos) in - let uu___8 = - env1.FStar_TypeChecker_Env.universe_of env1 t in - lift uu___8 t e1)) -and (norm_pattern_args : - FStar_TypeChecker_Cfg.cfg -> - env -> - (FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) - Prims.list Prims.list -> - (FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) - Prims.list Prims.list) - = - fun cfg -> - fun env1 -> - fun args -> - FStar_Compiler_List.map - (FStar_Compiler_List.map - (fun uu___ -> - match uu___ with - | (a, imp) -> - let uu___1 = norm cfg env1 [] a in (uu___1, imp))) args -and (norm_comp : - FStar_TypeChecker_Cfg.cfg -> - env -> FStar_Syntax_Syntax.comp -> FStar_Syntax_Syntax.comp) - = - fun cfg -> - fun env1 -> - fun comp -> - FStar_TypeChecker_Cfg.log cfg - (fun uu___1 -> - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_comp comp in - let uu___3 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_nat) - (FStar_Compiler_List.length env1) in - FStar_Compiler_Util.print2 - ">>> %s\nNormComp with with %s env elements\n" uu___2 uu___3); - (match comp.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total t -> - let t1 = norm cfg env1 [] t in - let uu___1 = FStar_Syntax_Syntax.mk_Total t1 in - { - FStar_Syntax_Syntax.n = (uu___1.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = (comp.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = (uu___1.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (uu___1.FStar_Syntax_Syntax.hash_code) - } - | FStar_Syntax_Syntax.GTotal t -> - let t1 = norm cfg env1 [] t in - let uu___1 = FStar_Syntax_Syntax.mk_GTotal t1 in - { - FStar_Syntax_Syntax.n = (uu___1.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = (comp.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = (uu___1.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (uu___1.FStar_Syntax_Syntax.hash_code) - } - | FStar_Syntax_Syntax.Comp ct -> - let effect_args = - let uu___1 = - let uu___2 = - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.for_extraction - && - (let uu___3 = - let uu___4 = - get_extraction_mode cfg.FStar_TypeChecker_Cfg.tcenv - ct.FStar_Syntax_Syntax.effect_name in - uu___4 = FStar_Syntax_Syntax.Extract_reify in - Prims.op_Negation uu___3) in - if uu___2 - then - FStar_Compiler_List.map - (fun uu___3 -> - FStar_Syntax_Syntax.as_arg - FStar_Syntax_Syntax.unit_const) - else - FStar_Compiler_List.mapi - (fun idx -> - fun uu___4 -> - match uu___4 with - | (a, i) -> - let uu___5 = norm cfg env1 [] a in (uu___5, i)) in - uu___1 ct.FStar_Syntax_Syntax.effect_args in - let flags = - FStar_Compiler_List.map - (fun uu___1 -> - match uu___1 with - | FStar_Syntax_Syntax.DECREASES - (FStar_Syntax_Syntax.Decreases_lex l) -> - let uu___2 = - let uu___3 = - FStar_Compiler_List.map (norm cfg env1 []) l in - FStar_Syntax_Syntax.Decreases_lex uu___3 in - FStar_Syntax_Syntax.DECREASES uu___2 - | FStar_Syntax_Syntax.DECREASES - (FStar_Syntax_Syntax.Decreases_wf (rel, e)) -> - let uu___2 = - let uu___3 = - let uu___4 = norm cfg env1 [] rel in - let uu___5 = norm cfg env1 [] e in - (uu___4, uu___5) in - FStar_Syntax_Syntax.Decreases_wf uu___3 in - FStar_Syntax_Syntax.DECREASES uu___2 - | f -> f) ct.FStar_Syntax_Syntax.flags in - let comp_univs = - FStar_Compiler_List.map (norm_universe cfg env1) - ct.FStar_Syntax_Syntax.comp_univs in - let result_typ = - norm cfg env1 [] ct.FStar_Syntax_Syntax.result_typ in - let uu___1 = - FStar_Syntax_Syntax.mk_Comp - { - FStar_Syntax_Syntax.comp_univs = comp_univs; - FStar_Syntax_Syntax.effect_name = - (ct.FStar_Syntax_Syntax.effect_name); - FStar_Syntax_Syntax.result_typ = result_typ; - FStar_Syntax_Syntax.effect_args = effect_args; - FStar_Syntax_Syntax.flags = flags - } in - { - FStar_Syntax_Syntax.n = (uu___1.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = (comp.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = (uu___1.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (uu___1.FStar_Syntax_Syntax.hash_code) - }) -and (norm_binder : - FStar_TypeChecker_Cfg.cfg -> - env -> FStar_Syntax_Syntax.binder -> FStar_Syntax_Syntax.binder) - = - fun cfg -> - fun env1 -> - fun b -> - let x = - let uu___ = b.FStar_Syntax_Syntax.binder_bv in - let uu___1 = - norm cfg env1 [] - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - { - FStar_Syntax_Syntax.ppname = (uu___.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = (uu___.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = uu___1 - } in - let imp = - match b.FStar_Syntax_Syntax.binder_qual with - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta t) -> - let uu___ = - let uu___1 = closure_as_term cfg env1 t in - FStar_Syntax_Syntax.Meta uu___1 in - FStar_Pervasives_Native.Some uu___ - | i -> i in - let attrs = - FStar_Compiler_List.map (norm cfg env1 []) - b.FStar_Syntax_Syntax.binder_attrs in - FStar_Syntax_Syntax.mk_binder_with_attrs x imp - b.FStar_Syntax_Syntax.binder_positivity attrs -and (norm_binders : - FStar_TypeChecker_Cfg.cfg -> - env -> FStar_Syntax_Syntax.binders -> FStar_Syntax_Syntax.binders) - = - fun cfg -> - fun env1 -> - fun bs -> - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun b -> - match uu___1 with - | (nbs', env2) -> - let b1 = norm_binder cfg env2 b in - let uu___2 = let uu___3 = dummy () in uu___3 :: env2 in - ((b1 :: nbs'), uu___2)) ([], env1) bs in - match uu___ with | (nbs, uu___1) -> FStar_Compiler_List.rev nbs -and (maybe_simplify : - FStar_TypeChecker_Cfg.cfg -> - env -> - stack -> - FStar_Syntax_Syntax.term -> (FStar_Syntax_Syntax.term * Prims.bool)) - = - fun cfg -> - fun env1 -> - fun stack1 -> - fun tm -> - let uu___ = maybe_simplify_aux cfg env1 stack1 tm in - match uu___ with - | (tm', renorm) -> - (if - (cfg.FStar_TypeChecker_Cfg.debug).FStar_TypeChecker_Cfg.b380 - then - (let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term tm in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - tm' in - let uu___4 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) renorm in - FStar_Compiler_Util.print4 - "%sSimplified\n\t%s to\n\t%s\nrenorm = %s\n" - (if - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.simplify - then "" - else "NOT ") uu___2 uu___3 uu___4) - else (); - (tm', renorm)) -and (norm_cb : - FStar_TypeChecker_Cfg.cfg -> FStar_Syntax_Embeddings_Base.norm_cb) = - fun cfg -> - fun uu___ -> - match uu___ with - | FStar_Pervasives.Inr x -> norm cfg [] [] x - | FStar_Pervasives.Inl l -> - let uu___1 = - FStar_Syntax_DsEnv.try_lookup_lid - (cfg.FStar_TypeChecker_Cfg.tcenv).FStar_TypeChecker_Env.dsenv l in - (match uu___1 with - | FStar_Pervasives_Native.Some t -> t - | FStar_Pervasives_Native.None -> - let uu___2 = - FStar_Syntax_Syntax.lid_as_fv l FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___2) -and (maybe_simplify_aux : - FStar_TypeChecker_Cfg.cfg -> - env -> - stack -> - FStar_Syntax_Syntax.term -> (FStar_Syntax_Syntax.term * Prims.bool)) - = - fun cfg -> - fun env1 -> - fun stack1 -> - fun tm -> - let uu___ = - let uu___1 = norm_cb cfg in reduce_primops uu___1 cfg env1 tm in - match uu___ with - | (tm1, renorm) -> - if - Prims.op_Negation - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.simplify - then (tm1, renorm) - else - (let w t = - { - FStar_Syntax_Syntax.n = (t.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = (tm1.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = (t.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (t.FStar_Syntax_Syntax.hash_code) - } in - let simp_t t = - let uu___2 = - let uu___3 = FStar_Syntax_Util.unmeta t in - uu___3.FStar_Syntax_Syntax.n in - match uu___2 with - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.true_lid - -> FStar_Pervasives_Native.Some true - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.false_lid - -> FStar_Pervasives_Native.Some false - | uu___3 -> FStar_Pervasives_Native.None in - let is_const_match phi = - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress phi in - uu___3.FStar_Syntax_Syntax.n in - match uu___2 with - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = uu___3; - FStar_Syntax_Syntax.ret_opt = uu___4; - FStar_Syntax_Syntax.brs = br::brs; - FStar_Syntax_Syntax.rc_opt1 = uu___5;_} - -> - let uu___6 = br in - (match uu___6 with - | (uu___7, uu___8, e) -> - let r = - let uu___9 = simp_t e in - match uu___9 with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some b -> - let uu___10 = - FStar_Compiler_List.for_all - (fun uu___11 -> - match uu___11 with - | (uu___12, uu___13, e') -> - let uu___14 = simp_t e' in - uu___14 = - (FStar_Pervasives_Native.Some - b)) brs in - if uu___10 - then FStar_Pervasives_Native.Some b - else FStar_Pervasives_Native.None in - r) - | uu___3 -> FStar_Pervasives_Native.None in - let maybe_auto_squash t = - let uu___2 = FStar_Syntax_Util.is_sub_singleton t in - if uu___2 - then t - else - FStar_Syntax_Util.mk_auto_squash - FStar_Syntax_Syntax.U_zero t in - let squashed_head_un_auto_squash_args t = - let maybe_un_auto_squash_arg uu___2 = - match uu___2 with - | (t1, q) -> - let uu___3 = FStar_Syntax_Util.is_auto_squash t1 in - (match uu___3 with - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.U_zero, t2) -> (t2, q) - | uu___4 -> (t1, q)) in - let uu___2 = FStar_Syntax_Util.head_and_args t in - match uu___2 with - | (head, args) -> - let args1 = - FStar_Compiler_List.map maybe_un_auto_squash_arg - args in - let uu___3 = - FStar_Syntax_Syntax.mk_Tm_app head args1 - t.FStar_Syntax_Syntax.pos in - (uu___3, false) in - let rec clearly_inhabited ty = - let uu___2 = - let uu___3 = FStar_Syntax_Util.unmeta ty in - uu___3.FStar_Syntax_Syntax.n in - match uu___2 with - | FStar_Syntax_Syntax.Tm_uinst (t, uu___3) -> - clearly_inhabited t - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = uu___3; - FStar_Syntax_Syntax.comp = c;_} - -> clearly_inhabited (FStar_Syntax_Util.comp_result c) - | FStar_Syntax_Syntax.Tm_fvar fv -> - let l = FStar_Syntax_Syntax.lid_of_fv fv in - (((FStar_Ident.lid_equals l FStar_Parser_Const.int_lid) - || - (FStar_Ident.lid_equals l - FStar_Parser_Const.bool_lid)) - || - (FStar_Ident.lid_equals l - FStar_Parser_Const.string_lid)) - || - (FStar_Ident.lid_equals l FStar_Parser_Const.exn_lid) - | uu___3 -> false in - let simplify arg = - let uu___2 = simp_t (FStar_Pervasives_Native.fst arg) in - (uu___2, arg) in - let uu___2 = is_forall_const cfg tm1 in - match uu___2 with - | FStar_Pervasives_Native.Some tm' -> - (if - (cfg.FStar_TypeChecker_Cfg.debug).FStar_TypeChecker_Cfg.wpe - then - (let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term tm1 in - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term tm' in - FStar_Compiler_Util.print2 "WPE> %s ~> %s\n" uu___4 - uu___5) - else (); - (let uu___4 = norm cfg env1 [] tm' in - maybe_simplify_aux cfg env1 stack1 uu___4)) - | FStar_Pervasives_Native.None -> - let uu___3 = - let uu___4 = FStar_Syntax_Subst.compress tm1 in - uu___4.FStar_Syntax_Syntax.n in - (match uu___3 with - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_uinst - ({ - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___4; - FStar_Syntax_Syntax.vars = uu___5; - FStar_Syntax_Syntax.hash_code = uu___6;_}, - uu___7); - FStar_Syntax_Syntax.pos = uu___8; - FStar_Syntax_Syntax.vars = uu___9; - FStar_Syntax_Syntax.hash_code = uu___10;_}; - FStar_Syntax_Syntax.args = args;_} - -> - let uu___11 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.squash_lid in - if uu___11 - then squashed_head_un_auto_squash_args tm1 - else - (let uu___13 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.and_lid in - if uu___13 - then - let uu___14 = - FStar_Compiler_List.map simplify args in - match uu___14 with - | (FStar_Pervasives_Native.Some (true), - uu___15)::(uu___16, (arg, uu___17))::[] -> - let uu___18 = maybe_auto_squash arg in - (uu___18, false) - | (uu___15, (arg, uu___16))::(FStar_Pervasives_Native.Some - (true), uu___17)::[] - -> - let uu___18 = maybe_auto_squash arg in - (uu___18, false) - | (FStar_Pervasives_Native.Some (false), - uu___15)::uu___16::[] -> - ((w FStar_Syntax_Util.t_false), false) - | uu___15::(FStar_Pervasives_Native.Some - (false), uu___16)::[] - -> ((w FStar_Syntax_Util.t_false), false) - | uu___15 -> - squashed_head_un_auto_squash_args tm1 - else - (let uu___15 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.or_lid in - if uu___15 - then - let uu___16 = - FStar_Compiler_List.map simplify args in - match uu___16 with - | (FStar_Pervasives_Native.Some (true), - uu___17)::uu___18::[] -> - ((w FStar_Syntax_Util.t_true), false) - | uu___17::(FStar_Pervasives_Native.Some - (true), uu___18)::[] - -> - ((w FStar_Syntax_Util.t_true), false) - | (FStar_Pervasives_Native.Some (false), - uu___17)::(uu___18, (arg, uu___19))::[] - -> - let uu___20 = maybe_auto_squash arg in - (uu___20, false) - | (uu___17, (arg, uu___18))::(FStar_Pervasives_Native.Some - (false), - uu___19)::[] - -> - let uu___20 = maybe_auto_squash arg in - (uu___20, false) - | uu___17 -> - squashed_head_un_auto_squash_args tm1 - else - (let uu___17 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.imp_lid in - if uu___17 - then - let uu___18 = - FStar_Compiler_List.map simplify args in - match uu___18 with - | uu___19::(FStar_Pervasives_Native.Some - (true), uu___20)::[] - -> - ((w FStar_Syntax_Util.t_true), - false) - | (FStar_Pervasives_Native.Some (false), - uu___19)::uu___20::[] -> - ((w FStar_Syntax_Util.t_true), - false) - | (FStar_Pervasives_Native.Some (true), - uu___19)::(uu___20, (arg, uu___21))::[] - -> - let uu___22 = maybe_auto_squash arg in - (uu___22, false) - | (uu___19, (p, uu___20))::(uu___21, - (q, uu___22))::[] - -> - let uu___23 = - FStar_Syntax_Util.term_eq p q in - (if uu___23 - then - ((w FStar_Syntax_Util.t_true), - false) - else - squashed_head_un_auto_squash_args - tm1) - | uu___19 -> - squashed_head_un_auto_squash_args - tm1 - else - (let uu___19 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.iff_lid in - if uu___19 - then - let uu___20 = - FStar_Compiler_List.map simplify - args in - match uu___20 with - | (FStar_Pervasives_Native.Some - (true), uu___21)::(FStar_Pervasives_Native.Some - (true), - uu___22)::[] - -> - ((w FStar_Syntax_Util.t_true), - false) - | (FStar_Pervasives_Native.Some - (false), uu___21)::(FStar_Pervasives_Native.Some - (false), - uu___22)::[] - -> - ((w FStar_Syntax_Util.t_true), - false) - | (FStar_Pervasives_Native.Some - (true), uu___21)::(FStar_Pervasives_Native.Some - (false), - uu___22)::[] - -> - ((w FStar_Syntax_Util.t_false), - false) - | (FStar_Pervasives_Native.Some - (false), uu___21)::(FStar_Pervasives_Native.Some - (true), - uu___22)::[] - -> - ((w FStar_Syntax_Util.t_false), - false) - | (uu___21, (arg, uu___22)):: - (FStar_Pervasives_Native.Some - (true), uu___23)::[] - -> - let uu___24 = - maybe_auto_squash arg in - (uu___24, false) - | (FStar_Pervasives_Native.Some - (true), uu___21)::(uu___22, - (arg, uu___23))::[] - -> - let uu___24 = - maybe_auto_squash arg in - (uu___24, false) - | (uu___21, (arg, uu___22)):: - (FStar_Pervasives_Native.Some - (false), uu___23)::[] - -> - let uu___24 = - let uu___25 = - FStar_Syntax_Util.mk_neg arg in - maybe_auto_squash uu___25 in - (uu___24, false) - | (FStar_Pervasives_Native.Some - (false), uu___21)::(uu___22, - (arg, uu___23))::[] - -> - let uu___24 = - let uu___25 = - FStar_Syntax_Util.mk_neg arg in - maybe_auto_squash uu___25 in - (uu___24, false) - | (uu___21, (p, uu___22))::(uu___23, - (q, - uu___24))::[] - -> - let uu___25 = - FStar_Syntax_Util.term_eq p q in - (if uu___25 - then - ((w FStar_Syntax_Util.t_true), - false) - else - squashed_head_un_auto_squash_args - tm1) - | uu___21 -> - squashed_head_un_auto_squash_args - tm1 - else - (let uu___21 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.not_lid in - if uu___21 - then - let uu___22 = - FStar_Compiler_List.map simplify - args in - match uu___22 with - | (FStar_Pervasives_Native.Some - (true), uu___23)::[] -> - ((w FStar_Syntax_Util.t_false), - false) - | (FStar_Pervasives_Native.Some - (false), uu___23)::[] -> - ((w FStar_Syntax_Util.t_true), - false) - | uu___23 -> - squashed_head_un_auto_squash_args - tm1 - else - (let uu___23 = - FStar_Syntax_Syntax.fv_eq_lid - fv - FStar_Parser_Const.forall_lid in - if uu___23 - then - match args with - | (t, uu___24)::[] -> - let uu___25 = - let uu___26 = - FStar_Syntax_Subst.compress - t in - uu___26.FStar_Syntax_Syntax.n in - (match uu___25 with - | FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs - = uu___26::[]; - FStar_Syntax_Syntax.body - = body; - FStar_Syntax_Syntax.rc_opt - = uu___27;_} - -> - let uu___28 = - simp_t body in - (match uu___28 with - | FStar_Pervasives_Native.Some - (true) -> - ((w - FStar_Syntax_Util.t_true), - false) - | uu___29 -> - (tm1, false)) - | uu___26 -> (tm1, false)) - | (ty, - FStar_Pervasives_Native.Some - { - FStar_Syntax_Syntax.aqual_implicit - = true; - FStar_Syntax_Syntax.aqual_attributes - = uu___24;_})::(t, - uu___25)::[] - -> - let uu___26 = - let uu___27 = - FStar_Syntax_Subst.compress - t in - uu___27.FStar_Syntax_Syntax.n in - (match uu___26 with - | FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs - = uu___27::[]; - FStar_Syntax_Syntax.body - = body; - FStar_Syntax_Syntax.rc_opt - = uu___28;_} - -> - let uu___29 = - simp_t body in - (match uu___29 with - | FStar_Pervasives_Native.Some - (true) -> - ((w - FStar_Syntax_Util.t_true), - false) - | FStar_Pervasives_Native.Some - (false) when - clearly_inhabited - ty - -> - ((w - FStar_Syntax_Util.t_false), - false) - | uu___30 -> - (tm1, false)) - | uu___27 -> (tm1, false)) - | uu___24 -> (tm1, false) - else - (let uu___25 = - FStar_Syntax_Syntax.fv_eq_lid - fv - FStar_Parser_Const.exists_lid in - if uu___25 - then - match args with - | (t, uu___26)::[] -> - let uu___27 = - let uu___28 = - FStar_Syntax_Subst.compress - t in - uu___28.FStar_Syntax_Syntax.n in - (match uu___27 with - | FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs - = uu___28::[]; - FStar_Syntax_Syntax.body - = body; - FStar_Syntax_Syntax.rc_opt - = uu___29;_} - -> - let uu___30 = - simp_t body in - (match uu___30 with - | FStar_Pervasives_Native.Some - (false) -> - ((w - FStar_Syntax_Util.t_false), - false) - | uu___31 -> - (tm1, false)) - | uu___28 -> - (tm1, false)) - | (ty, - FStar_Pervasives_Native.Some - { - FStar_Syntax_Syntax.aqual_implicit - = true; - FStar_Syntax_Syntax.aqual_attributes - = uu___26;_}):: - (t, uu___27)::[] -> - let uu___28 = - let uu___29 = - FStar_Syntax_Subst.compress - t in - uu___29.FStar_Syntax_Syntax.n in - (match uu___28 with - | FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs - = uu___29::[]; - FStar_Syntax_Syntax.body - = body; - FStar_Syntax_Syntax.rc_opt - = uu___30;_} - -> - let uu___31 = - simp_t body in - (match uu___31 with - | FStar_Pervasives_Native.Some - (false) -> - ((w - FStar_Syntax_Util.t_false), - false) - | FStar_Pervasives_Native.Some - (true) when - clearly_inhabited - ty - -> - ((w - FStar_Syntax_Util.t_true), - false) - | uu___32 -> - (tm1, false)) - | uu___29 -> - (tm1, false)) - | uu___26 -> (tm1, false) - else - (let uu___27 = - FStar_Syntax_Syntax.fv_eq_lid - fv - FStar_Parser_Const.b2t_lid in - if uu___27 - then - match args with - | ({ - FStar_Syntax_Syntax.n - = - FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_bool - (true)); - FStar_Syntax_Syntax.pos - = uu___28; - FStar_Syntax_Syntax.vars - = uu___29; - FStar_Syntax_Syntax.hash_code - = uu___30;_}, - uu___31)::[] -> - ((w - FStar_Syntax_Util.t_true), - false) - | ({ - FStar_Syntax_Syntax.n - = - FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_bool - (false)); - FStar_Syntax_Syntax.pos - = uu___28; - FStar_Syntax_Syntax.vars - = uu___29; - FStar_Syntax_Syntax.hash_code - = uu___30;_}, - uu___31)::[] -> - ((w - FStar_Syntax_Util.t_false), - false) - | uu___28 -> (tm1, false) - else - (let uu___29 = - FStar_Syntax_Syntax.fv_eq_lid - fv - FStar_Parser_Const.haseq_lid in - if uu___29 - then - let t_has_eq_for_sure - t = - let haseq_lids = - [FStar_Parser_Const.int_lid; - FStar_Parser_Const.bool_lid; - FStar_Parser_Const.unit_lid; - FStar_Parser_Const.string_lid] in - let uu___30 = - let uu___31 = - FStar_Syntax_Subst.compress - t in - uu___31.FStar_Syntax_Syntax.n in - match uu___30 with - | FStar_Syntax_Syntax.Tm_fvar - fv1 when - FStar_Compiler_List.existsb - (fun l -> - FStar_Syntax_Syntax.fv_eq_lid - fv1 l) - haseq_lids - -> true - | uu___31 -> false in - (if - (FStar_Compiler_List.length - args) - = Prims.int_one - then - let t = - let uu___30 = - FStar_Compiler_List.hd - args in - FStar_Pervasives_Native.fst - uu___30 in - let uu___30 = - t_has_eq_for_sure - t in - (if uu___30 - then - ((w - FStar_Syntax_Util.t_true), - false) - else - (let uu___32 = - let uu___33 = - FStar_Syntax_Subst.compress - t in - uu___33.FStar_Syntax_Syntax.n in - match uu___32 - with - | FStar_Syntax_Syntax.Tm_refine - uu___33 -> - let t1 = - FStar_Syntax_Util.unrefine - t in - let uu___34 - = - t_has_eq_for_sure - t1 in - if uu___34 - then - ((w - FStar_Syntax_Util.t_true), - false) - else - ( - let haseq_tm - = - let uu___36 - = - let uu___37 - = - FStar_Syntax_Subst.compress - tm1 in - uu___37.FStar_Syntax_Syntax.n in - match uu___36 - with - | - FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd - = hd; - FStar_Syntax_Syntax.args - = uu___37;_} - -> hd - | - uu___37 - -> - failwith - "Impossible! We have already checked that this is a Tm_app" in - let uu___36 - = - let uu___37 - = - let uu___38 - = - FStar_Syntax_Syntax.as_arg - t1 in - [uu___38] in - FStar_Syntax_Util.mk_app - haseq_tm - uu___37 in - (uu___36, - false)) - | uu___33 -> - (tm1, - false))) - else (tm1, false)) - else - (let uu___31 = - FStar_Syntax_Syntax.fv_eq_lid - fv - FStar_Parser_Const.subtype_of_lid in - if uu___31 - then - let is_unit ty = - let uu___32 = - let uu___33 = - FStar_Syntax_Subst.compress - ty in - uu___33.FStar_Syntax_Syntax.n in - match uu___32 - with - | FStar_Syntax_Syntax.Tm_fvar - fv1 -> - FStar_Syntax_Syntax.fv_eq_lid - fv1 - FStar_Parser_Const.unit_lid - | uu___33 -> - false in - match args with - | (t, uu___32):: - (ty, uu___33)::[] - when - (is_unit ty) && - (FStar_Syntax_Util.is_sub_singleton - t) - -> - ((w - FStar_Syntax_Util.t_true), - false) - | uu___32 -> - (tm1, false) - else - (let uu___33 = - FStar_Syntax_Util.is_auto_squash - tm1 in - match uu___33 with - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.U_zero, - t) - when - FStar_Syntax_Util.is_sub_singleton - t - -> (t, false) - | uu___34 -> - let uu___35 = - let uu___36 - = - norm_cb - cfg in - reduce_equality - uu___36 - cfg env1 in - uu___35 tm1))))))))))) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___4; - FStar_Syntax_Syntax.vars = uu___5; - FStar_Syntax_Syntax.hash_code = uu___6;_}; - FStar_Syntax_Syntax.args = args;_} - -> - let uu___7 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.squash_lid in - if uu___7 - then squashed_head_un_auto_squash_args tm1 - else - (let uu___9 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.and_lid in - if uu___9 - then - let uu___10 = - FStar_Compiler_List.map simplify args in - match uu___10 with - | (FStar_Pervasives_Native.Some (true), - uu___11)::(uu___12, (arg, uu___13))::[] -> - let uu___14 = maybe_auto_squash arg in - (uu___14, false) - | (uu___11, (arg, uu___12))::(FStar_Pervasives_Native.Some - (true), uu___13)::[] - -> - let uu___14 = maybe_auto_squash arg in - (uu___14, false) - | (FStar_Pervasives_Native.Some (false), - uu___11)::uu___12::[] -> - ((w FStar_Syntax_Util.t_false), false) - | uu___11::(FStar_Pervasives_Native.Some - (false), uu___12)::[] - -> ((w FStar_Syntax_Util.t_false), false) - | uu___11 -> - squashed_head_un_auto_squash_args tm1 - else - (let uu___11 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.or_lid in - if uu___11 - then - let uu___12 = - FStar_Compiler_List.map simplify args in - match uu___12 with - | (FStar_Pervasives_Native.Some (true), - uu___13)::uu___14::[] -> - ((w FStar_Syntax_Util.t_true), false) - | uu___13::(FStar_Pervasives_Native.Some - (true), uu___14)::[] - -> - ((w FStar_Syntax_Util.t_true), false) - | (FStar_Pervasives_Native.Some (false), - uu___13)::(uu___14, (arg, uu___15))::[] - -> - let uu___16 = maybe_auto_squash arg in - (uu___16, false) - | (uu___13, (arg, uu___14))::(FStar_Pervasives_Native.Some - (false), - uu___15)::[] - -> - let uu___16 = maybe_auto_squash arg in - (uu___16, false) - | uu___13 -> - squashed_head_un_auto_squash_args tm1 - else - (let uu___13 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.imp_lid in - if uu___13 - then - let uu___14 = - FStar_Compiler_List.map simplify args in - match uu___14 with - | uu___15::(FStar_Pervasives_Native.Some - (true), uu___16)::[] - -> - ((w FStar_Syntax_Util.t_true), - false) - | (FStar_Pervasives_Native.Some (false), - uu___15)::uu___16::[] -> - ((w FStar_Syntax_Util.t_true), - false) - | (FStar_Pervasives_Native.Some (true), - uu___15)::(uu___16, (arg, uu___17))::[] - -> - let uu___18 = maybe_auto_squash arg in - (uu___18, false) - | (uu___15, (p, uu___16))::(uu___17, - (q, uu___18))::[] - -> - let uu___19 = - FStar_Syntax_Util.term_eq p q in - (if uu___19 - then - ((w FStar_Syntax_Util.t_true), - false) - else - squashed_head_un_auto_squash_args - tm1) - | uu___15 -> - squashed_head_un_auto_squash_args - tm1 - else - (let uu___15 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.iff_lid in - if uu___15 - then - let uu___16 = - FStar_Compiler_List.map simplify - args in - match uu___16 with - | (FStar_Pervasives_Native.Some - (true), uu___17)::(FStar_Pervasives_Native.Some - (true), - uu___18)::[] - -> - ((w FStar_Syntax_Util.t_true), - false) - | (FStar_Pervasives_Native.Some - (false), uu___17)::(FStar_Pervasives_Native.Some - (false), - uu___18)::[] - -> - ((w FStar_Syntax_Util.t_true), - false) - | (FStar_Pervasives_Native.Some - (true), uu___17)::(FStar_Pervasives_Native.Some - (false), - uu___18)::[] - -> - ((w FStar_Syntax_Util.t_false), - false) - | (FStar_Pervasives_Native.Some - (false), uu___17)::(FStar_Pervasives_Native.Some - (true), - uu___18)::[] - -> - ((w FStar_Syntax_Util.t_false), - false) - | (uu___17, (arg, uu___18)):: - (FStar_Pervasives_Native.Some - (true), uu___19)::[] - -> - let uu___20 = - maybe_auto_squash arg in - (uu___20, false) - | (FStar_Pervasives_Native.Some - (true), uu___17)::(uu___18, - (arg, uu___19))::[] - -> - let uu___20 = - maybe_auto_squash arg in - (uu___20, false) - | (uu___17, (arg, uu___18)):: - (FStar_Pervasives_Native.Some - (false), uu___19)::[] - -> - let uu___20 = - let uu___21 = - FStar_Syntax_Util.mk_neg arg in - maybe_auto_squash uu___21 in - (uu___20, false) - | (FStar_Pervasives_Native.Some - (false), uu___17)::(uu___18, - (arg, uu___19))::[] - -> - let uu___20 = - let uu___21 = - FStar_Syntax_Util.mk_neg arg in - maybe_auto_squash uu___21 in - (uu___20, false) - | (uu___17, (p, uu___18))::(uu___19, - (q, - uu___20))::[] - -> - let uu___21 = - FStar_Syntax_Util.term_eq p q in - (if uu___21 - then - ((w FStar_Syntax_Util.t_true), - false) - else - squashed_head_un_auto_squash_args - tm1) - | uu___17 -> - squashed_head_un_auto_squash_args - tm1 - else - (let uu___17 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.not_lid in - if uu___17 - then - let uu___18 = - FStar_Compiler_List.map simplify - args in - match uu___18 with - | (FStar_Pervasives_Native.Some - (true), uu___19)::[] -> - ((w FStar_Syntax_Util.t_false), - false) - | (FStar_Pervasives_Native.Some - (false), uu___19)::[] -> - ((w FStar_Syntax_Util.t_true), - false) - | uu___19 -> - squashed_head_un_auto_squash_args - tm1 - else - (let uu___19 = - FStar_Syntax_Syntax.fv_eq_lid - fv - FStar_Parser_Const.forall_lid in - if uu___19 - then - match args with - | (t, uu___20)::[] -> - let uu___21 = - let uu___22 = - FStar_Syntax_Subst.compress - t in - uu___22.FStar_Syntax_Syntax.n in - (match uu___21 with - | FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs - = uu___22::[]; - FStar_Syntax_Syntax.body - = body; - FStar_Syntax_Syntax.rc_opt - = uu___23;_} - -> - let uu___24 = - simp_t body in - (match uu___24 with - | FStar_Pervasives_Native.Some - (true) -> - ((w - FStar_Syntax_Util.t_true), - false) - | uu___25 -> - (tm1, false)) - | uu___22 -> (tm1, false)) - | (ty, - FStar_Pervasives_Native.Some - { - FStar_Syntax_Syntax.aqual_implicit - = true; - FStar_Syntax_Syntax.aqual_attributes - = uu___20;_})::(t, - uu___21)::[] - -> - let uu___22 = - let uu___23 = - FStar_Syntax_Subst.compress - t in - uu___23.FStar_Syntax_Syntax.n in - (match uu___22 with - | FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs - = uu___23::[]; - FStar_Syntax_Syntax.body - = body; - FStar_Syntax_Syntax.rc_opt - = uu___24;_} - -> - let uu___25 = - simp_t body in - (match uu___25 with - | FStar_Pervasives_Native.Some - (true) -> - ((w - FStar_Syntax_Util.t_true), - false) - | FStar_Pervasives_Native.Some - (false) when - clearly_inhabited - ty - -> - ((w - FStar_Syntax_Util.t_false), - false) - | uu___26 -> - (tm1, false)) - | uu___23 -> (tm1, false)) - | uu___20 -> (tm1, false) - else - (let uu___21 = - FStar_Syntax_Syntax.fv_eq_lid - fv - FStar_Parser_Const.exists_lid in - if uu___21 - then - match args with - | (t, uu___22)::[] -> - let uu___23 = - let uu___24 = - FStar_Syntax_Subst.compress - t in - uu___24.FStar_Syntax_Syntax.n in - (match uu___23 with - | FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs - = uu___24::[]; - FStar_Syntax_Syntax.body - = body; - FStar_Syntax_Syntax.rc_opt - = uu___25;_} - -> - let uu___26 = - simp_t body in - (match uu___26 with - | FStar_Pervasives_Native.Some - (false) -> - ((w - FStar_Syntax_Util.t_false), - false) - | uu___27 -> - (tm1, false)) - | uu___24 -> - (tm1, false)) - | (ty, - FStar_Pervasives_Native.Some - { - FStar_Syntax_Syntax.aqual_implicit - = true; - FStar_Syntax_Syntax.aqual_attributes - = uu___22;_}):: - (t, uu___23)::[] -> - let uu___24 = - let uu___25 = - FStar_Syntax_Subst.compress - t in - uu___25.FStar_Syntax_Syntax.n in - (match uu___24 with - | FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs - = uu___25::[]; - FStar_Syntax_Syntax.body - = body; - FStar_Syntax_Syntax.rc_opt - = uu___26;_} - -> - let uu___27 = - simp_t body in - (match uu___27 with - | FStar_Pervasives_Native.Some - (false) -> - ((w - FStar_Syntax_Util.t_false), - false) - | FStar_Pervasives_Native.Some - (true) when - clearly_inhabited - ty - -> - ((w - FStar_Syntax_Util.t_true), - false) - | uu___28 -> - (tm1, false)) - | uu___25 -> - (tm1, false)) - | uu___22 -> (tm1, false) - else - (let uu___23 = - FStar_Syntax_Syntax.fv_eq_lid - fv - FStar_Parser_Const.b2t_lid in - if uu___23 - then - match args with - | ({ - FStar_Syntax_Syntax.n - = - FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_bool - (true)); - FStar_Syntax_Syntax.pos - = uu___24; - FStar_Syntax_Syntax.vars - = uu___25; - FStar_Syntax_Syntax.hash_code - = uu___26;_}, - uu___27)::[] -> - ((w - FStar_Syntax_Util.t_true), - false) - | ({ - FStar_Syntax_Syntax.n - = - FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_bool - (false)); - FStar_Syntax_Syntax.pos - = uu___24; - FStar_Syntax_Syntax.vars - = uu___25; - FStar_Syntax_Syntax.hash_code - = uu___26;_}, - uu___27)::[] -> - ((w - FStar_Syntax_Util.t_false), - false) - | uu___24 -> (tm1, false) - else - (let uu___25 = - FStar_Syntax_Syntax.fv_eq_lid - fv - FStar_Parser_Const.haseq_lid in - if uu___25 - then - let t_has_eq_for_sure - t = - let haseq_lids = - [FStar_Parser_Const.int_lid; - FStar_Parser_Const.bool_lid; - FStar_Parser_Const.unit_lid; - FStar_Parser_Const.string_lid] in - let uu___26 = - let uu___27 = - FStar_Syntax_Subst.compress - t in - uu___27.FStar_Syntax_Syntax.n in - match uu___26 with - | FStar_Syntax_Syntax.Tm_fvar - fv1 when - FStar_Compiler_List.existsb - (fun l -> - FStar_Syntax_Syntax.fv_eq_lid - fv1 l) - haseq_lids - -> true - | uu___27 -> false in - (if - (FStar_Compiler_List.length - args) - = Prims.int_one - then - let t = - let uu___26 = - FStar_Compiler_List.hd - args in - FStar_Pervasives_Native.fst - uu___26 in - let uu___26 = - t_has_eq_for_sure - t in - (if uu___26 - then - ((w - FStar_Syntax_Util.t_true), - false) - else - (let uu___28 = - let uu___29 = - FStar_Syntax_Subst.compress - t in - uu___29.FStar_Syntax_Syntax.n in - match uu___28 - with - | FStar_Syntax_Syntax.Tm_refine - uu___29 -> - let t1 = - FStar_Syntax_Util.unrefine - t in - let uu___30 - = - t_has_eq_for_sure - t1 in - if uu___30 - then - ((w - FStar_Syntax_Util.t_true), - false) - else - ( - let haseq_tm - = - let uu___32 - = - let uu___33 - = - FStar_Syntax_Subst.compress - tm1 in - uu___33.FStar_Syntax_Syntax.n in - match uu___32 - with - | - FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd - = hd; - FStar_Syntax_Syntax.args - = uu___33;_} - -> hd - | - uu___33 - -> - failwith - "Impossible! We have already checked that this is a Tm_app" in - let uu___32 - = - let uu___33 - = - let uu___34 - = - FStar_Syntax_Syntax.as_arg - t1 in - [uu___34] in - FStar_Syntax_Util.mk_app - haseq_tm - uu___33 in - (uu___32, - false)) - | uu___29 -> - (tm1, - false))) - else (tm1, false)) - else - (let uu___27 = - FStar_Syntax_Syntax.fv_eq_lid - fv - FStar_Parser_Const.subtype_of_lid in - if uu___27 - then - let is_unit ty = - let uu___28 = - let uu___29 = - FStar_Syntax_Subst.compress - ty in - uu___29.FStar_Syntax_Syntax.n in - match uu___28 - with - | FStar_Syntax_Syntax.Tm_fvar - fv1 -> - FStar_Syntax_Syntax.fv_eq_lid - fv1 - FStar_Parser_Const.unit_lid - | uu___29 -> - false in - match args with - | (t, uu___28):: - (ty, uu___29)::[] - when - (is_unit ty) && - (FStar_Syntax_Util.is_sub_singleton - t) - -> - ((w - FStar_Syntax_Util.t_true), - false) - | uu___28 -> - (tm1, false) - else - (let uu___29 = - FStar_Syntax_Util.is_auto_squash - tm1 in - match uu___29 with - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.U_zero, - t) - when - FStar_Syntax_Util.is_sub_singleton - t - -> (t, false) - | uu___30 -> - let uu___31 = - let uu___32 - = - norm_cb - cfg in - reduce_equality - uu___32 - cfg env1 in - uu___31 tm1))))))))))) - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = bv; - FStar_Syntax_Syntax.phi = t;_} - -> - let uu___4 = simp_t t in - (match uu___4 with - | FStar_Pervasives_Native.Some (true) -> - ((bv.FStar_Syntax_Syntax.sort), false) - | FStar_Pervasives_Native.Some (false) -> - (tm1, false) - | FStar_Pervasives_Native.None -> (tm1, false)) - | FStar_Syntax_Syntax.Tm_match uu___4 -> - let uu___5 = is_const_match tm1 in - (match uu___5 with - | FStar_Pervasives_Native.Some (true) -> - ((w FStar_Syntax_Util.t_true), false) - | FStar_Pervasives_Native.Some (false) -> - ((w FStar_Syntax_Util.t_false), false) - | FStar_Pervasives_Native.None -> (tm1, false)) - | uu___4 -> (tm1, false))) -and (rebuild : - FStar_TypeChecker_Cfg.cfg -> - env -> stack -> FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun cfg -> - fun env1 -> - fun stack1 -> - fun t -> - FStar_TypeChecker_Cfg.log cfg - (fun uu___1 -> - (let uu___3 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - let uu___5 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_nat) - (FStar_Compiler_List.length env1) in - let uu___6 = - let uu___7 = - let uu___8 = firstn (Prims.of_int (4)) stack1 in - FStar_Pervasives_Native.fst uu___8 in - FStar_Class_Show.show - (FStar_Class_Show.show_list showable_stack_elt) uu___7 in - FStar_Compiler_Util.print4 - ">>> %s\nRebuild %s with %s env elements and top of the stack %s\n" - uu___3 uu___4 uu___5 uu___6); - (let uu___3 = FStar_Compiler_Effect.op_Bang dbg_NormRebuild in - if uu___3 - then - let uu___4 = FStar_Syntax_Util.unbound_variables t in - match uu___4 with - | [] -> () - | bvs -> - ((let uu___6 = - FStar_Class_Tagged.tag_of - FStar_Syntax_Syntax.tagged_term t in - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - let uu___8 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_bv) bvs in - FStar_Compiler_Util.print3 - "!!! Rebuild (%s) %s, free vars=%s\n" uu___6 uu___7 - uu___8); - failwith "DIE!") - else ())); - (let f_opt = is_fext_on_domain t in - if - (FStar_Compiler_Util.is_some f_opt) && - (match stack1 with - | (Arg uu___1)::uu___2 -> true - | uu___1 -> false) - then - let uu___1 = FStar_Compiler_Util.must f_opt in - norm cfg env1 stack1 uu___1 - else - (let uu___2 = maybe_simplify cfg env1 stack1 t in - match uu___2 with - | (t1, renorm) -> - if renorm - then norm cfg env1 stack1 t1 - else do_rebuild cfg env1 stack1 t1)) -and (do_rebuild : - FStar_TypeChecker_Cfg.cfg -> - env -> stack -> FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun cfg -> - fun env1 -> - fun stack1 -> - fun t -> - match stack1 with - | [] -> t - | (Meta (uu___, m, r))::stack2 -> - let t1 = - match m with - | FStar_Syntax_Syntax.Meta_monadic uu___1 -> - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress t in - uu___3.FStar_Syntax_Syntax.n in - (match uu___2 with - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t'; - FStar_Syntax_Syntax.meta = - FStar_Syntax_Syntax.Meta_monadic uu___3;_} - -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 = t'; - FStar_Syntax_Syntax.meta = m - }) r - | uu___3 -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 = t; - FStar_Syntax_Syntax.meta = m - }) r) - | uu___1 -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 = t; - FStar_Syntax_Syntax.meta = m - }) r in - rebuild cfg env1 stack2 t1 - | (MemoLazy r)::stack2 -> - (set_memo cfg r (env1, t); - FStar_TypeChecker_Cfg.log cfg - (fun uu___2 -> - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - t in - FStar_Compiler_Util.print1 "\tSet memo %s\n" uu___3); - rebuild cfg env1 stack2 t) - | (Let (env', bs, lb, r))::stack2 -> - let body = FStar_Syntax_Subst.close bs t in - let t1 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = (false, [lb]); - FStar_Syntax_Syntax.body1 = body - }) r in - rebuild cfg env' stack2 t1 - | (Abs (env', bs, env'', lopt, r))::stack2 -> - let bs1 = norm_binders cfg env' bs in - let lopt1 = - FStar_Compiler_Util.map_option (norm_residual_comp cfg env'') - lopt in - let uu___ = - let uu___1 = FStar_Syntax_Util.abs bs1 t lopt1 in - { - FStar_Syntax_Syntax.n = (uu___1.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = r; - FStar_Syntax_Syntax.vars = - (uu___1.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (uu___1.FStar_Syntax_Syntax.hash_code) - } in - rebuild cfg env1 stack2 uu___ - | (Arg (Univ uu___, uu___1, uu___2))::uu___3 -> - failwith "Impossible" - | (Arg (Dummy, uu___, uu___1))::uu___2 -> failwith "Impossible" - | (UnivArgs (us, r))::stack2 -> - let t1 = FStar_Syntax_Syntax.mk_Tm_uinst t us in - rebuild cfg env1 stack2 t1 - | (Arg (Clos (env_arg, tm, uu___, uu___1), aq, r))::stack2 when - let uu___2 = head_of t in - FStar_Syntax_Util.is_fstar_tactics_by_tactic uu___2 -> - let t1 = - let uu___2 = - let uu___3 = closure_as_term cfg env_arg tm in (uu___3, aq) in - FStar_Syntax_Syntax.extend_app t uu___2 r in - rebuild cfg env1 stack2 t1 - | (Arg (Clos (env_arg, tm, m, uu___), aq, r))::stack2 -> - (FStar_TypeChecker_Cfg.log cfg - (fun uu___2 -> - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - tm in - FStar_Compiler_Util.print1 "Rebuilding with arg %s\n" - uu___3); - (let uu___2 = - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.hnf - && - (let uu___3 = is_partial_primop_app cfg t in - Prims.op_Negation uu___3) in - if uu___2 - then - let arg = closure_as_term cfg env_arg tm in - let t1 = FStar_Syntax_Syntax.extend_app t (arg, aq) r in - rebuild cfg env_arg stack2 t1 - else - (let uu___4 = read_memo cfg m in - match uu___4 with - | FStar_Pervasives_Native.Some (uu___5, a) -> - let t1 = FStar_Syntax_Syntax.extend_app t (a, aq) r in - rebuild cfg env_arg stack2 t1 - | FStar_Pervasives_Native.None when - Prims.op_Negation - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.iota - -> - let stack3 = (App (env1, t, aq, r)) :: stack2 in - norm cfg env_arg stack3 tm - | FStar_Pervasives_Native.None -> - let stack3 = (MemoLazy m) :: (App (env1, t, aq, r)) :: - stack2 in - norm cfg env_arg stack3 tm))) - | (App (env2, head, aq, r))::stack' when should_reify cfg stack1 -> - let t0 = t in - let fallback msg uu___ = - FStar_TypeChecker_Cfg.log cfg - (fun uu___2 -> - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - t in - FStar_Compiler_Util.print2 "Not reifying%s: %s\n" msg - uu___3); - (let t1 = FStar_Syntax_Syntax.extend_app head (t, aq) r in - rebuild cfg env2 stack' t1) in - let is_non_tac_layered_effect m = - let norm_m = - FStar_TypeChecker_Env.norm_eff_name - cfg.FStar_TypeChecker_Cfg.tcenv m in - (let uu___ = - FStar_Ident.lid_equals norm_m - FStar_Parser_Const.effect_TAC_lid in - Prims.op_Negation uu___) && - (FStar_TypeChecker_Env.is_layered_effect - cfg.FStar_TypeChecker_Cfg.tcenv norm_m) in - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - (match uu___ with - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = uu___1; - FStar_Syntax_Syntax.meta = - FStar_Syntax_Syntax.Meta_monadic (m, uu___2);_} - when - (is_non_tac_layered_effect m) && - (Prims.op_Negation - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.for_extraction) - -> - let uu___3 = - let uu___4 = FStar_Ident.string_of_lid m in - FStar_Compiler_Util.format1 - "Meta_monadic for a non-TAC layered effect %s in non-extraction mode" - uu___4 in - fallback uu___3 () - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = uu___1; - FStar_Syntax_Syntax.meta = - FStar_Syntax_Syntax.Meta_monadic (m, uu___2);_} - when - ((is_non_tac_layered_effect m) && - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.for_extraction) - && - (let uu___3 = - get_extraction_mode cfg.FStar_TypeChecker_Cfg.tcenv m in - FStar_Syntax_Syntax.uu___is_Extract_none uu___3) - -> - let uu___3 = - get_extraction_mode cfg.FStar_TypeChecker_Cfg.tcenv m in - (match uu___3 with - | FStar_Syntax_Syntax.Extract_none msg -> - let uu___4 = - let uu___5 = FStar_Ident.string_of_lid m in - FStar_Compiler_Util.format2 - "Normalizer cannot reify effect %s for extraction since %s" - uu___5 msg in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) t - FStar_Errors_Codes.Fatal_UnexpectedEffect () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4)) - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = uu___1; - FStar_Syntax_Syntax.meta = - FStar_Syntax_Syntax.Meta_monadic (m, uu___2);_} - when - ((is_non_tac_layered_effect m) && - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.for_extraction) - && - (let uu___3 = - get_extraction_mode cfg.FStar_TypeChecker_Cfg.tcenv m in - uu___3 = FStar_Syntax_Syntax.Extract_primitive) - -> - let uu___3 = - let uu___4 = FStar_Ident.string_of_lid m in - FStar_Compiler_Util.format1 - "Meta_monadic for a non-TAC layered effect %s which is Extract_primtiive" - uu___4 in - fallback uu___3 () - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = uu___1; - FStar_Syntax_Syntax.meta = - FStar_Syntax_Syntax.Meta_monadic_lift - (msrc, mtgt, uu___2);_} - when - ((is_non_tac_layered_effect msrc) || - (is_non_tac_layered_effect mtgt)) - && - (Prims.op_Negation - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.for_extraction) - -> - let uu___3 = - let uu___4 = FStar_Ident.string_of_lid msrc in - let uu___5 = FStar_Ident.string_of_lid mtgt in - FStar_Compiler_Util.format2 - "Meta_monadic_lift for a non-TAC layered effect %s ~> %s in non extraction mode" - uu___4 uu___5 in - fallback uu___3 () - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = uu___1; - FStar_Syntax_Syntax.meta = - FStar_Syntax_Syntax.Meta_monadic_lift - (msrc, mtgt, uu___2);_} - when - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.for_extraction - && - (((is_non_tac_layered_effect msrc) && - (let uu___3 = - get_extraction_mode - cfg.FStar_TypeChecker_Cfg.tcenv msrc in - FStar_Syntax_Syntax.uu___is_Extract_none uu___3)) - || - ((is_non_tac_layered_effect mtgt) && - (let uu___3 = - get_extraction_mode - cfg.FStar_TypeChecker_Cfg.tcenv mtgt in - FStar_Syntax_Syntax.uu___is_Extract_none uu___3))) - -> - let uu___3 = - let uu___4 = FStar_Ident.string_of_lid msrc in - let uu___5 = FStar_Ident.string_of_lid mtgt in - FStar_Compiler_Util.format2 - "Normalizer cannot reify %s ~> %s for extraction" - uu___4 uu___5 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) t - FStar_Errors_Codes.Fatal_UnexpectedEffect () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___3) - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t1; - FStar_Syntax_Syntax.meta = - FStar_Syntax_Syntax.Meta_monadic (m, ty);_} - -> - do_reify_monadic (fallback " (1)") cfg env2 stack1 t1 m ty - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t1; - FStar_Syntax_Syntax.meta = - FStar_Syntax_Syntax.Meta_monadic_lift (msrc, mtgt, ty);_} - -> - let lifted = - let uu___1 = closure_as_term cfg env2 ty in - reify_lift cfg t1 msrc mtgt uu___1 in - (FStar_TypeChecker_Cfg.log cfg - (fun uu___2 -> - let uu___3 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term lifted in - FStar_Compiler_Util.print1 - "Reified lift to (1): %s\n" uu___3); - (let uu___2 = FStar_Compiler_List.tl stack1 in - norm cfg env2 uu___2 lifted)) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_reflect uu___1); - FStar_Syntax_Syntax.pos = uu___2; - FStar_Syntax_Syntax.vars = uu___3; - FStar_Syntax_Syntax.hash_code = uu___4;_}; - FStar_Syntax_Syntax.args = (e, uu___5)::[];_} - -> norm cfg env2 stack' e - | FStar_Syntax_Syntax.Tm_app uu___1 when - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.primops - -> - let uu___2 = FStar_Syntax_Util.head_and_args_full_unmeta t in - (match uu___2 with - | (hd, args) -> - let uu___3 = - let uu___4 = FStar_Syntax_Util.un_uinst hd in - uu___4.FStar_Syntax_Syntax.n in - (match uu___3 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - let uu___4 = - FStar_TypeChecker_Cfg.find_prim_step cfg fv in - (match uu___4 with - | FStar_Pervasives_Native.Some - { - FStar_TypeChecker_Primops_Base.name = - uu___5; - FStar_TypeChecker_Primops_Base.arity = - uu___6; - FStar_TypeChecker_Primops_Base.univ_arity - = uu___7; - FStar_TypeChecker_Primops_Base.auto_reflect - = FStar_Pervasives_Native.Some n; - FStar_TypeChecker_Primops_Base.strong_reduction_ok - = uu___8; - FStar_TypeChecker_Primops_Base.requires_binder_substitution - = uu___9; - FStar_TypeChecker_Primops_Base.renorm_after - = uu___10; - FStar_TypeChecker_Primops_Base.interpretation - = uu___11; - FStar_TypeChecker_Primops_Base.interpretation_nbe - = uu___12;_} - when (FStar_Compiler_List.length args) = n - -> norm cfg env2 stack' t - | uu___5 -> fallback " (3)" ()) - | uu___4 -> fallback " (4)" ())) - | uu___1 -> fallback " (2)" ()) - | (App (env2, head, aq, r))::stack2 -> - let t1 = FStar_Syntax_Syntax.extend_app head (t, aq) r in - rebuild cfg env2 stack2 t1 - | (CBVApp (env', head, aq, r))::stack2 -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = fresh_memo () in - (env1, t, uu___5, false) in - Clos uu___4 in - (uu___3, aq, (t.FStar_Syntax_Syntax.pos)) in - Arg uu___2 in - uu___1 :: stack2 in - norm cfg env' uu___ head - | (Match (env', asc_opt, branches1, lopt, cfg1, r))::stack2 -> - let lopt1 = - FStar_Compiler_Util.map_option (norm_residual_comp cfg1 env') - lopt in - (FStar_TypeChecker_Cfg.log cfg1 - (fun uu___1 -> - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - t in - FStar_Compiler_Util.print1 - "Rebuilding with match, scrutinee is %s ...\n" uu___2); - (let scrutinee_env = env1 in - let env2 = env' in - let scrutinee = t in - let norm_and_rebuild_match uu___1 = - FStar_TypeChecker_Cfg.log cfg1 - (fun uu___3 -> - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term scrutinee in - let uu___5 = - let uu___6 = - FStar_Compiler_List.map - (fun uu___7 -> - match uu___7 with - | (p, uu___8, uu___9) -> - FStar_Class_Show.show - FStar_Syntax_Print.showable_pat p) - branches1 in - FStar_Compiler_String.concat "\n\t" uu___6 in - FStar_Compiler_Util.print2 - "match is irreducible: scrutinee=%s\nbranches=%s\n" - uu___4 uu___5); - (let whnf = - (cfg1.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.weak - || - (cfg1.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.hnf in - let cfg_exclude_zeta = - if - (cfg1.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.zeta_full - then cfg1 - else - (let new_delta = - FStar_Compiler_List.filter - (fun uu___4 -> - match uu___4 with - | FStar_TypeChecker_Env.InliningDelta -> true - | FStar_TypeChecker_Env.Eager_unfolding_only - -> true - | uu___5 -> false) - cfg1.FStar_TypeChecker_Cfg.delta_level in - let steps = - let uu___4 = cfg1.FStar_TypeChecker_Cfg.steps in - { - FStar_TypeChecker_Cfg.beta = - (uu___4.FStar_TypeChecker_Cfg.beta); - FStar_TypeChecker_Cfg.iota = - (uu___4.FStar_TypeChecker_Cfg.iota); - FStar_TypeChecker_Cfg.zeta = false; - FStar_TypeChecker_Cfg.zeta_full = - (uu___4.FStar_TypeChecker_Cfg.zeta_full); - FStar_TypeChecker_Cfg.weak = - (uu___4.FStar_TypeChecker_Cfg.weak); - FStar_TypeChecker_Cfg.hnf = - (uu___4.FStar_TypeChecker_Cfg.hnf); - FStar_TypeChecker_Cfg.primops = - (uu___4.FStar_TypeChecker_Cfg.primops); - FStar_TypeChecker_Cfg.do_not_unfold_pure_lets = - (uu___4.FStar_TypeChecker_Cfg.do_not_unfold_pure_lets); - FStar_TypeChecker_Cfg.unfold_until = - FStar_Pervasives_Native.None; - FStar_TypeChecker_Cfg.unfold_only = - FStar_Pervasives_Native.None; - FStar_TypeChecker_Cfg.unfold_fully = - (uu___4.FStar_TypeChecker_Cfg.unfold_fully); - FStar_TypeChecker_Cfg.unfold_attr = - FStar_Pervasives_Native.None; - FStar_TypeChecker_Cfg.unfold_qual = - FStar_Pervasives_Native.None; - FStar_TypeChecker_Cfg.unfold_namespace = - FStar_Pervasives_Native.None; - FStar_TypeChecker_Cfg.dont_unfold_attr = - FStar_Pervasives_Native.None; - FStar_TypeChecker_Cfg.pure_subterms_within_computations - = - (uu___4.FStar_TypeChecker_Cfg.pure_subterms_within_computations); - FStar_TypeChecker_Cfg.simplify = - (uu___4.FStar_TypeChecker_Cfg.simplify); - FStar_TypeChecker_Cfg.erase_universes = - (uu___4.FStar_TypeChecker_Cfg.erase_universes); - FStar_TypeChecker_Cfg.allow_unbound_universes = - (uu___4.FStar_TypeChecker_Cfg.allow_unbound_universes); - FStar_TypeChecker_Cfg.reify_ = - (uu___4.FStar_TypeChecker_Cfg.reify_); - FStar_TypeChecker_Cfg.compress_uvars = - (uu___4.FStar_TypeChecker_Cfg.compress_uvars); - FStar_TypeChecker_Cfg.no_full_norm = - (uu___4.FStar_TypeChecker_Cfg.no_full_norm); - FStar_TypeChecker_Cfg.check_no_uvars = - (uu___4.FStar_TypeChecker_Cfg.check_no_uvars); - FStar_TypeChecker_Cfg.unmeta = - (uu___4.FStar_TypeChecker_Cfg.unmeta); - FStar_TypeChecker_Cfg.unascribe = - (uu___4.FStar_TypeChecker_Cfg.unascribe); - FStar_TypeChecker_Cfg.in_full_norm_request = - (uu___4.FStar_TypeChecker_Cfg.in_full_norm_request); - FStar_TypeChecker_Cfg.weakly_reduce_scrutinee = - (uu___4.FStar_TypeChecker_Cfg.weakly_reduce_scrutinee); - FStar_TypeChecker_Cfg.nbe_step = - (uu___4.FStar_TypeChecker_Cfg.nbe_step); - FStar_TypeChecker_Cfg.for_extraction = - (uu___4.FStar_TypeChecker_Cfg.for_extraction); - FStar_TypeChecker_Cfg.unrefine = - (uu___4.FStar_TypeChecker_Cfg.unrefine); - FStar_TypeChecker_Cfg.default_univs_to_zero = - (uu___4.FStar_TypeChecker_Cfg.default_univs_to_zero); - FStar_TypeChecker_Cfg.tactics = - (uu___4.FStar_TypeChecker_Cfg.tactics) - } in - { - FStar_TypeChecker_Cfg.steps = steps; - FStar_TypeChecker_Cfg.tcenv = - (cfg1.FStar_TypeChecker_Cfg.tcenv); - FStar_TypeChecker_Cfg.debug = - (cfg1.FStar_TypeChecker_Cfg.debug); - FStar_TypeChecker_Cfg.delta_level = new_delta; - FStar_TypeChecker_Cfg.primitive_steps = - (cfg1.FStar_TypeChecker_Cfg.primitive_steps); - FStar_TypeChecker_Cfg.strong = true; - FStar_TypeChecker_Cfg.memoize_lazy = - (cfg1.FStar_TypeChecker_Cfg.memoize_lazy); - FStar_TypeChecker_Cfg.normalize_pure_lets = - (cfg1.FStar_TypeChecker_Cfg.normalize_pure_lets); - FStar_TypeChecker_Cfg.reifying = - (cfg1.FStar_TypeChecker_Cfg.reifying); - FStar_TypeChecker_Cfg.compat_memo_ignore_cfg = - (cfg1.FStar_TypeChecker_Cfg.compat_memo_ignore_cfg) - }) in - let norm_or_whnf env3 t1 = - if whnf - then closure_as_term cfg_exclude_zeta env3 t1 - else norm cfg_exclude_zeta env3 [] t1 in - let rec norm_pat env3 p = - match p.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_constant uu___3 -> (p, env3) - | FStar_Syntax_Syntax.Pat_cons (fv, us_opt, pats) -> - let us_opt1 = - if - (cfg1.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.erase_universes - then FStar_Pervasives_Native.None - else - (match us_opt with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some us -> - let uu___4 = - FStar_Compiler_List.map - (norm_universe cfg1 env3) us in - FStar_Pervasives_Native.Some uu___4) in - let uu___3 = - FStar_Compiler_List.fold_left - (fun uu___4 -> - fun uu___5 -> - match (uu___4, uu___5) with - | ((pats1, env4), (p1, b)) -> - let uu___6 = norm_pat env4 p1 in - (match uu___6 with - | (p2, env5) -> - (((p2, b) :: pats1), env5))) - ([], env3) pats in - (match uu___3 with - | (pats1, env4) -> - ({ - FStar_Syntax_Syntax.v = - (FStar_Syntax_Syntax.Pat_cons - (fv, us_opt1, - (FStar_Compiler_List.rev pats1))); - FStar_Syntax_Syntax.p = - (p.FStar_Syntax_Syntax.p) - }, env4)) - | FStar_Syntax_Syntax.Pat_var x -> - let x1 = - let uu___3 = - norm_or_whnf env3 x.FStar_Syntax_Syntax.sort in - { - FStar_Syntax_Syntax.ppname = - (x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (x.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = uu___3 - } in - let uu___3 = let uu___4 = dummy () in uu___4 :: env3 in - ({ - FStar_Syntax_Syntax.v = - (FStar_Syntax_Syntax.Pat_var x1); - FStar_Syntax_Syntax.p = (p.FStar_Syntax_Syntax.p) - }, uu___3) - | FStar_Syntax_Syntax.Pat_dot_term eopt -> - let eopt1 = - FStar_Compiler_Util.map_option (norm_or_whnf env3) - eopt in - ({ - FStar_Syntax_Syntax.v = - (FStar_Syntax_Syntax.Pat_dot_term eopt1); - FStar_Syntax_Syntax.p = (p.FStar_Syntax_Syntax.p) - }, env3) in - let norm_branches uu___3 = - match env2 with - | [] when whnf -> branches1 - | uu___4 -> - FStar_Compiler_List.map - (fun branch -> - let uu___5 = - FStar_Syntax_Subst.open_branch branch in - match uu___5 with - | (p, wopt, e) -> - let uu___6 = norm_pat env2 p in - (match uu___6 with - | (p1, env3) -> - let wopt1 = - match wopt with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some w -> - let uu___7 = norm_or_whnf env3 w in - FStar_Pervasives_Native.Some - uu___7 in - let e1 = norm_or_whnf env3 e in - FStar_Syntax_Util.branch - (p1, wopt1, e1))) branches1 in - let maybe_commute_matches uu___3 = - let can_commute = - match branches1 with - | ({ - FStar_Syntax_Syntax.v = - FStar_Syntax_Syntax.Pat_cons - (fv, uu___4, uu___5); - FStar_Syntax_Syntax.p = uu___6;_}, - uu___7, uu___8)::uu___9 -> - FStar_TypeChecker_Env.fv_has_attr - cfg1.FStar_TypeChecker_Cfg.tcenv fv - FStar_Parser_Const.commute_nested_matches_lid - | uu___4 -> false in - let uu___4 = - let uu___5 = FStar_Syntax_Util.unascribe scrutinee in - uu___5.FStar_Syntax_Syntax.n in - match uu___4 with - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = sc0; - FStar_Syntax_Syntax.ret_opt = asc_opt0; - FStar_Syntax_Syntax.brs = branches0; - FStar_Syntax_Syntax.rc_opt1 = lopt0;_} - when can_commute -> - let reduce_branch b = - let stack3 = - [Match - (env', asc_opt, branches1, lopt1, cfg1, r)] in - let uu___5 = FStar_Syntax_Subst.open_branch b in - match uu___5 with - | (p, wopt, e) -> - let uu___6 = norm_pat scrutinee_env p in - (match uu___6 with - | (p1, branch_env) -> - let wopt1 = - match wopt with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some w -> - let uu___7 = - norm_or_whnf branch_env w in - FStar_Pervasives_Native.Some uu___7 in - let e1 = norm cfg1 branch_env stack3 e in - FStar_Syntax_Util.branch (p1, wopt1, e1)) in - let branches01 = - FStar_Compiler_List.map reduce_branch branches0 in - let uu___5 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_match - { - FStar_Syntax_Syntax.scrutinee = sc0; - FStar_Syntax_Syntax.ret_opt = asc_opt0; - FStar_Syntax_Syntax.brs = branches01; - FStar_Syntax_Syntax.rc_opt1 = lopt0 - }) r in - rebuild cfg1 env2 stack2 uu___5 - | uu___5 -> - let scrutinee1 = - let uu___6 = - ((((cfg1.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.iota - && - (Prims.op_Negation - (cfg1.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.weak)) - && - (Prims.op_Negation - (cfg1.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.compress_uvars)) - && - (cfg1.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.weakly_reduce_scrutinee) - && (maybe_weakly_reduced scrutinee) in - if uu___6 - then - norm - { - FStar_TypeChecker_Cfg.steps = - (let uu___7 = - cfg1.FStar_TypeChecker_Cfg.steps in - { - FStar_TypeChecker_Cfg.beta = - (uu___7.FStar_TypeChecker_Cfg.beta); - FStar_TypeChecker_Cfg.iota = - (uu___7.FStar_TypeChecker_Cfg.iota); - FStar_TypeChecker_Cfg.zeta = - (uu___7.FStar_TypeChecker_Cfg.zeta); - FStar_TypeChecker_Cfg.zeta_full = - (uu___7.FStar_TypeChecker_Cfg.zeta_full); - FStar_TypeChecker_Cfg.weak = - (uu___7.FStar_TypeChecker_Cfg.weak); - FStar_TypeChecker_Cfg.hnf = - (uu___7.FStar_TypeChecker_Cfg.hnf); - FStar_TypeChecker_Cfg.primops = - (uu___7.FStar_TypeChecker_Cfg.primops); - FStar_TypeChecker_Cfg.do_not_unfold_pure_lets - = - (uu___7.FStar_TypeChecker_Cfg.do_not_unfold_pure_lets); - FStar_TypeChecker_Cfg.unfold_until = - (uu___7.FStar_TypeChecker_Cfg.unfold_until); - FStar_TypeChecker_Cfg.unfold_only = - (uu___7.FStar_TypeChecker_Cfg.unfold_only); - FStar_TypeChecker_Cfg.unfold_fully = - (uu___7.FStar_TypeChecker_Cfg.unfold_fully); - FStar_TypeChecker_Cfg.unfold_attr = - (uu___7.FStar_TypeChecker_Cfg.unfold_attr); - FStar_TypeChecker_Cfg.unfold_qual = - (uu___7.FStar_TypeChecker_Cfg.unfold_qual); - FStar_TypeChecker_Cfg.unfold_namespace - = - (uu___7.FStar_TypeChecker_Cfg.unfold_namespace); - FStar_TypeChecker_Cfg.dont_unfold_attr - = - (uu___7.FStar_TypeChecker_Cfg.dont_unfold_attr); - FStar_TypeChecker_Cfg.pure_subterms_within_computations - = - (uu___7.FStar_TypeChecker_Cfg.pure_subterms_within_computations); - FStar_TypeChecker_Cfg.simplify = - (uu___7.FStar_TypeChecker_Cfg.simplify); - FStar_TypeChecker_Cfg.erase_universes = - (uu___7.FStar_TypeChecker_Cfg.erase_universes); - FStar_TypeChecker_Cfg.allow_unbound_universes - = - (uu___7.FStar_TypeChecker_Cfg.allow_unbound_universes); - FStar_TypeChecker_Cfg.reify_ = - (uu___7.FStar_TypeChecker_Cfg.reify_); - FStar_TypeChecker_Cfg.compress_uvars = - (uu___7.FStar_TypeChecker_Cfg.compress_uvars); - FStar_TypeChecker_Cfg.no_full_norm = - (uu___7.FStar_TypeChecker_Cfg.no_full_norm); - FStar_TypeChecker_Cfg.check_no_uvars = - (uu___7.FStar_TypeChecker_Cfg.check_no_uvars); - FStar_TypeChecker_Cfg.unmeta = - (uu___7.FStar_TypeChecker_Cfg.unmeta); - FStar_TypeChecker_Cfg.unascribe = - (uu___7.FStar_TypeChecker_Cfg.unascribe); - FStar_TypeChecker_Cfg.in_full_norm_request - = - (uu___7.FStar_TypeChecker_Cfg.in_full_norm_request); - FStar_TypeChecker_Cfg.weakly_reduce_scrutinee - = false; - FStar_TypeChecker_Cfg.nbe_step = - (uu___7.FStar_TypeChecker_Cfg.nbe_step); - FStar_TypeChecker_Cfg.for_extraction = - (uu___7.FStar_TypeChecker_Cfg.for_extraction); - FStar_TypeChecker_Cfg.unrefine = - (uu___7.FStar_TypeChecker_Cfg.unrefine); - FStar_TypeChecker_Cfg.default_univs_to_zero - = - (uu___7.FStar_TypeChecker_Cfg.default_univs_to_zero); - FStar_TypeChecker_Cfg.tactics = - (uu___7.FStar_TypeChecker_Cfg.tactics) - }); - FStar_TypeChecker_Cfg.tcenv = - (cfg1.FStar_TypeChecker_Cfg.tcenv); - FStar_TypeChecker_Cfg.debug = - (cfg1.FStar_TypeChecker_Cfg.debug); - FStar_TypeChecker_Cfg.delta_level = - (cfg1.FStar_TypeChecker_Cfg.delta_level); - FStar_TypeChecker_Cfg.primitive_steps = - (cfg1.FStar_TypeChecker_Cfg.primitive_steps); - FStar_TypeChecker_Cfg.strong = - (cfg1.FStar_TypeChecker_Cfg.strong); - FStar_TypeChecker_Cfg.memoize_lazy = - (cfg1.FStar_TypeChecker_Cfg.memoize_lazy); - FStar_TypeChecker_Cfg.normalize_pure_lets = - (cfg1.FStar_TypeChecker_Cfg.normalize_pure_lets); - FStar_TypeChecker_Cfg.reifying = - (cfg1.FStar_TypeChecker_Cfg.reifying); - FStar_TypeChecker_Cfg.compat_memo_ignore_cfg - = - (cfg1.FStar_TypeChecker_Cfg.compat_memo_ignore_cfg) - } scrutinee_env [] scrutinee - else scrutinee in - let asc_opt1 = norm_match_returns cfg1 env2 asc_opt in - let branches2 = norm_branches () in - let uu___6 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_match - { - FStar_Syntax_Syntax.scrutinee = scrutinee1; - FStar_Syntax_Syntax.ret_opt = asc_opt1; - FStar_Syntax_Syntax.brs = branches2; - FStar_Syntax_Syntax.rc_opt1 = lopt1 - }) r in - rebuild cfg1 env2 stack2 uu___6 in - maybe_commute_matches ()) in - let rec is_cons head = - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress head in - uu___2.FStar_Syntax_Syntax.n in - match uu___1 with - | FStar_Syntax_Syntax.Tm_uinst (h, uu___2) -> is_cons h - | FStar_Syntax_Syntax.Tm_constant uu___2 -> true - | FStar_Syntax_Syntax.Tm_fvar - { FStar_Syntax_Syntax.fv_name = uu___2; - FStar_Syntax_Syntax.fv_qual = - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Data_ctor);_} - -> true - | FStar_Syntax_Syntax.Tm_fvar - { FStar_Syntax_Syntax.fv_name = uu___2; - FStar_Syntax_Syntax.fv_qual = - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Record_ctor uu___3);_} - -> true - | uu___2 -> false in - let guard_when_clause wopt b rest = - match wopt with - | FStar_Pervasives_Native.None -> b - | FStar_Pervasives_Native.Some w -> - let then_branch = b in - let else_branch = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_match - { - FStar_Syntax_Syntax.scrutinee = scrutinee; - FStar_Syntax_Syntax.ret_opt = asc_opt; - FStar_Syntax_Syntax.brs = rest; - FStar_Syntax_Syntax.rc_opt1 = lopt1 - }) r in - FStar_Syntax_Util.if_then_else w then_branch - else_branch in - let rec matches_pat scrutinee_orig p = - let scrutinee1 = FStar_Syntax_Util.unmeta scrutinee_orig in - let scrutinee2 = FStar_Syntax_Util.unlazy scrutinee1 in - let uu___1 = FStar_Syntax_Util.head_and_args scrutinee2 in - match uu___1 with - | (head, args) -> - (match p.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_var bv -> - FStar_Pervasives.Inl [(bv, scrutinee_orig)] - | FStar_Syntax_Syntax.Pat_dot_term uu___2 -> - FStar_Pervasives.Inl [] - | FStar_Syntax_Syntax.Pat_constant s -> - (match scrutinee2.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_constant s' when - FStar_Const.eq_const s s' -> - FStar_Pervasives.Inl [] - | uu___2 -> - let uu___3 = - let uu___4 = is_cons head in - Prims.op_Negation uu___4 in - FStar_Pervasives.Inr uu___3) - | FStar_Syntax_Syntax.Pat_cons (fv, uu___2, arg_pats) - -> - let uu___3 = - let uu___4 = FStar_Syntax_Util.un_uinst head in - uu___4.FStar_Syntax_Syntax.n in - (match uu___3 with - | FStar_Syntax_Syntax.Tm_fvar fv' when - FStar_Syntax_Syntax.fv_eq fv fv' -> - matches_args [] args arg_pats - | uu___4 -> - let uu___5 = - let uu___6 = is_cons head in - Prims.op_Negation uu___6 in - FStar_Pervasives.Inr uu___5)) - and matches_args out a p = - match (a, p) with - | ([], []) -> FStar_Pervasives.Inl out - | ((t1, uu___1)::rest_a, (p1, uu___2)::rest_p) -> - let uu___3 = matches_pat t1 p1 in - (match uu___3 with - | FStar_Pervasives.Inl s -> - matches_args (FStar_Compiler_List.op_At out s) - rest_a rest_p - | m -> m) - | uu___1 -> FStar_Pervasives.Inr false in - let rec matches scrutinee1 p = - match p with - | [] -> norm_and_rebuild_match () - | (p1, wopt, b)::rest -> - let uu___1 = matches_pat scrutinee1 p1 in - (match uu___1 with - | FStar_Pervasives.Inr (false) -> - matches scrutinee1 rest - | FStar_Pervasives.Inr (true) -> - norm_and_rebuild_match () - | FStar_Pervasives.Inl s -> - (FStar_TypeChecker_Cfg.log cfg1 - (fun uu___3 -> - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_pat p1 in - let uu___5 = - let uu___6 = - FStar_Compiler_List.map - (fun uu___7 -> - match uu___7 with - | (uu___8, t1) -> - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t1) s in - FStar_Compiler_String.concat "; " uu___6 in - FStar_Compiler_Util.print2 - "Matches pattern %s with subst = %s\n" - uu___4 uu___5); - (let env0 = env2 in - let env3 = - FStar_Compiler_List.fold_left - (fun env4 -> - fun uu___3 -> - match uu___3 with - | (bv, t1) -> - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Syntax.mk_binder - bv in - FStar_Pervasives_Native.Some - uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Compiler_Util.mk_ref - (if - (cfg1.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.hnf - then - FStar_Pervasives_Native.None - else - FStar_Pervasives_Native.Some - (cfg1, ([], t1))) in - ([], t1, uu___8, false) in - Clos uu___7 in - let uu___7 = fresh_memo () in - (uu___5, uu___6, uu___7) in - uu___4 :: env4) env2 s in - let uu___3 = guard_when_clause wopt b rest in - norm cfg1 env3 stack2 uu___3))) in - if - (cfg1.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.iota - then matches scrutinee branches1 - else norm_and_rebuild_match ())) -and (norm_match_returns : - FStar_TypeChecker_Cfg.cfg -> - env -> - FStar_Syntax_Syntax.match_returns_ascription - FStar_Pervasives_Native.option -> - (FStar_Syntax_Syntax.binder * - ((FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax, - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax) - FStar_Pervasives.either * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax FStar_Pervasives_Native.option * - Prims.bool)) FStar_Pervasives_Native.option) - = - fun cfg -> - fun env1 -> - fun ret_opt -> - match ret_opt with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (b, asc) -> - let b1 = norm_binder cfg env1 b in - let uu___ = FStar_Syntax_Subst.open_ascription [b1] asc in - (match uu___ with - | (subst, asc1) -> - let asc2 = - let uu___1 = let uu___2 = dummy () in uu___2 :: env1 in - norm_ascription cfg uu___1 asc1 in - let uu___1 = - let uu___2 = - FStar_Syntax_Subst.close_ascription subst asc2 in - (b1, uu___2) in - FStar_Pervasives_Native.Some uu___1) -and (norm_ascription : - FStar_TypeChecker_Cfg.cfg -> - env -> - ((FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax, - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax) - FStar_Pervasives.either * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax FStar_Pervasives_Native.option * - Prims.bool) -> - ((FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax, - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax) - FStar_Pervasives.either * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax FStar_Pervasives_Native.option * - Prims.bool)) - = - fun cfg -> - fun env1 -> - fun uu___ -> - match uu___ with - | (tc, tacopt, use_eq) -> - let uu___1 = - match tc with - | FStar_Pervasives.Inl t -> - let uu___2 = norm cfg env1 [] t in - FStar_Pervasives.Inl uu___2 - | FStar_Pervasives.Inr c -> - let uu___2 = norm_comp cfg env1 c in - FStar_Pervasives.Inr uu___2 in - let uu___2 = - FStar_Compiler_Util.map_opt tacopt (norm cfg env1 []) in - (uu___1, uu___2, use_eq) -and (norm_residual_comp : - FStar_TypeChecker_Cfg.cfg -> - env -> - FStar_Syntax_Syntax.residual_comp -> FStar_Syntax_Syntax.residual_comp) - = - fun cfg -> - fun env1 -> - fun rc -> - let uu___ = - FStar_Compiler_Util.map_option (closure_as_term cfg env1) - rc.FStar_Syntax_Syntax.residual_typ in - { - FStar_Syntax_Syntax.residual_effect = - (rc.FStar_Syntax_Syntax.residual_effect); - FStar_Syntax_Syntax.residual_typ = uu___; - FStar_Syntax_Syntax.residual_flags = - (rc.FStar_Syntax_Syntax.residual_flags) - } -let (reflection_env_hook : - FStar_TypeChecker_Env.env FStar_Pervasives_Native.option - FStar_Compiler_Effect.ref) - = FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None -let (normalize_with_primitive_steps : - FStar_TypeChecker_Primops_Base.primitive_step Prims.list -> - FStar_TypeChecker_Env.steps -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun ps -> - fun s -> - fun e -> - fun t -> - let is_nbe = is_nbe_request s in - let maybe_nbe = if is_nbe then " (NBE)" else "" in - FStar_Errors.with_ctx - (Prims.strcat "While normalizing a term" maybe_nbe) - (fun uu___ -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_TypeChecker_Env.current_module e in - FStar_Ident.string_of_lid uu___3 in - FStar_Pervasives_Native.Some uu___2 in - FStar_Profiling.profile - (fun uu___2 -> - let c = FStar_TypeChecker_Cfg.config' ps s e in - FStar_Compiler_Effect.op_Colon_Equals reflection_env_hook - (FStar_Pervasives_Native.Some e); - FStar_Compiler_Effect.op_Colon_Equals - FStar_TypeChecker_Normalize_Unfolding.plugin_unfold_warn_ctr - (Prims.of_int (10)); - FStar_TypeChecker_Cfg.log_top c - (fun uu___6 -> - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.print2 - "\nStarting normalizer%s for (%s) {\n" maybe_nbe - uu___7); - FStar_TypeChecker_Cfg.log_top c - (fun uu___7 -> - let uu___8 = - FStar_Class_Show.show - FStar_TypeChecker_Cfg.showable_cfg c in - FStar_Compiler_Util.print1 ">>> cfg = %s\n" uu___8); - FStar_Defensive.def_check_scoped - FStar_TypeChecker_Env.hasBinders_env - FStar_Class_Binders.hasNames_term - FStar_Syntax_Print.pretty_term - t.FStar_Syntax_Syntax.pos - "normalize_with_primitive_steps call" e t; - (let uu___8 = - FStar_Compiler_Util.record_time - (fun uu___9 -> - if is_nbe then nbe_eval c s t else norm c [] [] t) in - match uu___8 with - | (r, ms) -> - (FStar_TypeChecker_Cfg.log_top c - (fun uu___10 -> - let uu___11 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term r in - let uu___12 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) ms in - FStar_Compiler_Util.print3 - "}\nNormalization%s result = (%s) in %s ms\n" - maybe_nbe uu___11 uu___12); - r))) uu___1 - "FStar.TypeChecker.Normalize.normalize_with_primitive_steps") -let (normalize : - FStar_TypeChecker_Env.steps -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun s -> - fun e -> - fun t -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_Env.current_module e in - FStar_Ident.string_of_lid uu___2 in - FStar_Pervasives_Native.Some uu___1 in - FStar_Profiling.profile - (fun uu___1 -> normalize_with_primitive_steps [] s e t) uu___ - "FStar.TypeChecker.Normalize.normalize" -let (normalize_comp : - FStar_TypeChecker_Env.steps -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.comp -> FStar_Syntax_Syntax.comp) - = - fun s -> - fun e -> - fun c -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_Env.current_module e in - FStar_Ident.string_of_lid uu___2 in - FStar_Pervasives_Native.Some uu___1 in - FStar_Profiling.profile - (fun uu___1 -> - let cfg = FStar_TypeChecker_Cfg.config s e in - FStar_Compiler_Effect.op_Colon_Equals reflection_env_hook - (FStar_Pervasives_Native.Some e); - FStar_Compiler_Effect.op_Colon_Equals - FStar_TypeChecker_Normalize_Unfolding.plugin_unfold_warn_ctr - (Prims.of_int (10)); - FStar_TypeChecker_Cfg.log_top cfg - (fun uu___5 -> - let uu___6 = - FStar_Class_Show.show FStar_Syntax_Print.showable_comp c in - FStar_Compiler_Util.print1 - "Starting normalizer for computation (%s) {\n" uu___6); - FStar_TypeChecker_Cfg.log_top cfg - (fun uu___6 -> - let uu___7 = - FStar_Class_Show.show FStar_TypeChecker_Cfg.showable_cfg - cfg in - FStar_Compiler_Util.print1 ">>> cfg = %s\n" uu___7); - FStar_Defensive.def_check_scoped - FStar_TypeChecker_Env.hasBinders_env - FStar_Class_Binders.hasNames_comp - FStar_Syntax_Print.pretty_comp c.FStar_Syntax_Syntax.pos - "normalize_comp call" e c; - (let uu___7 = - FStar_Errors.with_ctx "While normalizing a computation type" - (fun uu___8 -> - FStar_Compiler_Util.record_time - (fun uu___9 -> norm_comp cfg [] c)) in - match uu___7 with - | (c1, ms) -> - (FStar_TypeChecker_Cfg.log_top cfg - (fun uu___9 -> - let uu___10 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_comp c1 in - let uu___11 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) ms in - FStar_Compiler_Util.print2 - "}\nNormalization result = (%s) in %s ms\n" uu___10 - uu___11); - c1))) uu___ "FStar.TypeChecker.Normalize.normalize_comp" -let (normalize_universe : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.universe -> FStar_Syntax_Syntax.universe) - = - fun env1 -> - fun u -> - FStar_Errors.with_ctx "While normalizing a universe level" - (fun uu___ -> - let uu___1 = FStar_TypeChecker_Cfg.config [] env1 in - norm_universe uu___1 [] u) -let (non_info_norm : - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.term -> Prims.bool) = - fun env1 -> - fun t -> - let steps = - [FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.AllowUnboundUniverses; - FStar_TypeChecker_Env.EraseUniverses; - FStar_TypeChecker_Env.HNF; - FStar_TypeChecker_Env.Unascribe; - FStar_TypeChecker_Env.ForExtraction] in - let uu___ = normalize steps env1 t in - FStar_TypeChecker_Env.non_informative env1 uu___ -let (maybe_promote_t : - FStar_TypeChecker_Env.env -> - Prims.bool -> FStar_Syntax_Syntax.term -> Prims.bool) - = - fun env1 -> - fun non_informative_only -> - fun t -> - (Prims.op_Negation non_informative_only) || (non_info_norm env1 t) -let (ghost_to_pure_aux : - FStar_TypeChecker_Env.env -> - Prims.bool -> - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax) - = - fun env1 -> - fun non_informative_only -> - fun c -> - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total uu___ -> c - | FStar_Syntax_Syntax.GTotal t -> - let uu___ = maybe_promote_t env1 non_informative_only t in - if uu___ - then - { - FStar_Syntax_Syntax.n = (FStar_Syntax_Syntax.Total t); - FStar_Syntax_Syntax.pos = (c.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = (c.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (c.FStar_Syntax_Syntax.hash_code) - } - else c - | FStar_Syntax_Syntax.Comp ct -> - let l = - FStar_TypeChecker_Env.norm_eff_name env1 - ct.FStar_Syntax_Syntax.effect_name in - let uu___ = - (FStar_Syntax_Util.is_ghost_effect l) && - (maybe_promote_t env1 non_informative_only - ct.FStar_Syntax_Syntax.result_typ) in - if uu___ - then - let ct1 = - let uu___1 = - downgrade_ghost_effect_name - ct.FStar_Syntax_Syntax.effect_name in - match uu___1 with - | FStar_Pervasives_Native.Some pure_eff -> - let flags = - let uu___2 = - FStar_Ident.lid_equals pure_eff - FStar_Parser_Const.effect_Tot_lid in - if uu___2 - then FStar_Syntax_Syntax.TOTAL :: - (ct.FStar_Syntax_Syntax.flags) - else ct.FStar_Syntax_Syntax.flags in - { - FStar_Syntax_Syntax.comp_univs = - (ct.FStar_Syntax_Syntax.comp_univs); - FStar_Syntax_Syntax.effect_name = pure_eff; - FStar_Syntax_Syntax.result_typ = - (ct.FStar_Syntax_Syntax.result_typ); - FStar_Syntax_Syntax.effect_args = - (ct.FStar_Syntax_Syntax.effect_args); - FStar_Syntax_Syntax.flags = flags - } - | FStar_Pervasives_Native.None -> - let ct2 = - FStar_TypeChecker_Env.unfold_effect_abbrev env1 c in - { - FStar_Syntax_Syntax.comp_univs = - (ct2.FStar_Syntax_Syntax.comp_univs); - FStar_Syntax_Syntax.effect_name = - FStar_Parser_Const.effect_PURE_lid; - FStar_Syntax_Syntax.result_typ = - (ct2.FStar_Syntax_Syntax.result_typ); - FStar_Syntax_Syntax.effect_args = - (ct2.FStar_Syntax_Syntax.effect_args); - FStar_Syntax_Syntax.flags = - (ct2.FStar_Syntax_Syntax.flags) - } in - { - FStar_Syntax_Syntax.n = (FStar_Syntax_Syntax.Comp ct1); - FStar_Syntax_Syntax.pos = (c.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = (c.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (c.FStar_Syntax_Syntax.hash_code) - } - else c - | uu___ -> c -let (ghost_to_pure_lcomp_aux : - FStar_TypeChecker_Env.env -> - Prims.bool -> - FStar_TypeChecker_Common.lcomp -> FStar_TypeChecker_Common.lcomp) - = - fun env1 -> - fun non_informative_only -> - fun lc -> - let uu___ = - (FStar_Syntax_Util.is_ghost_effect - lc.FStar_TypeChecker_Common.eff_name) - && - (maybe_promote_t env1 non_informative_only - lc.FStar_TypeChecker_Common.res_typ) in - if uu___ - then - let uu___1 = - downgrade_ghost_effect_name lc.FStar_TypeChecker_Common.eff_name in - match uu___1 with - | FStar_Pervasives_Native.Some pure_eff -> - let uu___2 = - FStar_TypeChecker_Common.apply_lcomp - (ghost_to_pure_aux env1 non_informative_only) (fun g -> g) - lc in - { - FStar_TypeChecker_Common.eff_name = pure_eff; - FStar_TypeChecker_Common.res_typ = - (uu___2.FStar_TypeChecker_Common.res_typ); - FStar_TypeChecker_Common.cflags = - (uu___2.FStar_TypeChecker_Common.cflags); - FStar_TypeChecker_Common.comp_thunk = - (uu___2.FStar_TypeChecker_Common.comp_thunk) - } - | FStar_Pervasives_Native.None -> lc - else lc -let (maybe_ghost_to_pure : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.comp -> FStar_Syntax_Syntax.comp) - = fun env1 -> fun c -> ghost_to_pure_aux env1 true c -let (maybe_ghost_to_pure_lcomp : - FStar_TypeChecker_Env.env -> - FStar_TypeChecker_Common.lcomp -> FStar_TypeChecker_Common.lcomp) - = fun env1 -> fun lc -> ghost_to_pure_lcomp_aux env1 true lc -let (ghost_to_pure : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax) - = fun env1 -> fun c -> ghost_to_pure_aux env1 false c -let (ghost_to_pure_lcomp : - FStar_TypeChecker_Env.env -> - FStar_TypeChecker_Common.lcomp -> FStar_TypeChecker_Common.lcomp) - = fun env1 -> fun lc -> ghost_to_pure_lcomp_aux env1 false lc -let (ghost_to_pure2 : - FStar_TypeChecker_Env.env -> - (FStar_Syntax_Syntax.comp * FStar_Syntax_Syntax.comp) -> - (FStar_Syntax_Syntax.comp * FStar_Syntax_Syntax.comp)) - = - fun env1 -> - fun uu___ -> - match uu___ with - | (c1, c2) -> - let uu___1 = - let uu___2 = maybe_ghost_to_pure env1 c1 in - let uu___3 = maybe_ghost_to_pure env1 c2 in (uu___2, uu___3) in - (match uu___1 with - | (c11, c21) -> - let c1_eff = - FStar_TypeChecker_Env.norm_eff_name env1 - (FStar_Syntax_Util.comp_effect_name c11) in - let c2_eff = - FStar_TypeChecker_Env.norm_eff_name env1 - (FStar_Syntax_Util.comp_effect_name c21) in - let uu___2 = FStar_Ident.lid_equals c1_eff c2_eff in - if uu___2 - then (c11, c21) - else - (let c1_erasable = - FStar_TypeChecker_Env.is_erasable_effect env1 c1_eff in - let c2_erasable = - FStar_TypeChecker_Env.is_erasable_effect env1 c2_eff in - let uu___4 = - c1_erasable && - (FStar_Ident.lid_equals c2_eff - FStar_Parser_Const.effect_GHOST_lid) in - if uu___4 - then let uu___5 = ghost_to_pure env1 c21 in (c11, uu___5) - else - (let uu___6 = - c2_erasable && - (FStar_Ident.lid_equals c1_eff - FStar_Parser_Const.effect_GHOST_lid) in - if uu___6 - then - let uu___7 = ghost_to_pure env1 c11 in (uu___7, c21) - else (c11, c21)))) -let (ghost_to_pure_lcomp2 : - FStar_TypeChecker_Env.env -> - (FStar_TypeChecker_Common.lcomp * FStar_TypeChecker_Common.lcomp) -> - (FStar_TypeChecker_Common.lcomp * FStar_TypeChecker_Common.lcomp)) - = - fun env1 -> - fun uu___ -> - match uu___ with - | (lc1, lc2) -> - let uu___1 = - let uu___2 = maybe_ghost_to_pure_lcomp env1 lc1 in - let uu___3 = maybe_ghost_to_pure_lcomp env1 lc2 in - (uu___2, uu___3) in - (match uu___1 with - | (lc11, lc21) -> - let lc1_eff = - FStar_TypeChecker_Env.norm_eff_name env1 - lc11.FStar_TypeChecker_Common.eff_name in - let lc2_eff = - FStar_TypeChecker_Env.norm_eff_name env1 - lc21.FStar_TypeChecker_Common.eff_name in - let uu___2 = FStar_Ident.lid_equals lc1_eff lc2_eff in - if uu___2 - then (lc11, lc21) - else - (let lc1_erasable = - FStar_TypeChecker_Env.is_erasable_effect env1 lc1_eff in - let lc2_erasable = - FStar_TypeChecker_Env.is_erasable_effect env1 lc2_eff in - let uu___4 = - lc1_erasable && - (FStar_Ident.lid_equals lc2_eff - FStar_Parser_Const.effect_GHOST_lid) in - if uu___4 - then - let uu___5 = ghost_to_pure_lcomp env1 lc21 in - (lc11, uu___5) - else - (let uu___6 = - lc2_erasable && - (FStar_Ident.lid_equals lc1_eff - FStar_Parser_Const.effect_GHOST_lid) in - if uu___6 - then - let uu___7 = ghost_to_pure_lcomp env1 lc11 in - (uu___7, lc21) - else (lc11, lc21)))) -let (warn_norm_failure : - FStar_Compiler_Range_Type.range -> Prims.exn -> unit) = - fun r -> - fun e -> - let uu___ = - let uu___1 = FStar_Compiler_Util.message_of_exn e in - FStar_Compiler_Util.format1 "Normalization failed with error %s\n" - uu___1 in - FStar_Errors.log_issue FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Warning_NormalizationFailure () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___) -let (term_to_doc : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Pprint.document) - = - fun env1 -> - fun t -> - let t1 = - try - (fun uu___ -> - match () with - | () -> - normalize [FStar_TypeChecker_Env.AllowUnboundUniverses] env1 - t) () - with - | uu___ -> (warn_norm_failure t.FStar_Syntax_Syntax.pos uu___; t) in - let uu___ = - FStar_Syntax_DsEnv.set_current_module - env1.FStar_TypeChecker_Env.dsenv - env1.FStar_TypeChecker_Env.curmodule in - FStar_Syntax_Print.term_to_doc' uu___ t1 -let (term_to_string : - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.term -> Prims.string) = - fun env1 -> - fun t -> - FStar_GenSym.with_frozen_gensym - (fun uu___ -> - let t1 = - try - (fun uu___1 -> - match () with - | () -> - normalize [FStar_TypeChecker_Env.AllowUnboundUniverses] - env1 t) () - with - | uu___1 -> - (warn_norm_failure t.FStar_Syntax_Syntax.pos uu___1; t) in - let uu___1 = - FStar_Syntax_DsEnv.set_current_module - env1.FStar_TypeChecker_Env.dsenv - env1.FStar_TypeChecker_Env.curmodule in - FStar_Syntax_Print.term_to_string' uu___1 t1) -let (comp_to_string : - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.comp -> Prims.string) = - fun env1 -> - fun c -> - FStar_GenSym.with_frozen_gensym - (fun uu___ -> - let c1 = - try - (fun uu___1 -> - match () with - | () -> - let uu___2 = - FStar_TypeChecker_Cfg.config - [FStar_TypeChecker_Env.AllowUnboundUniverses] env1 in - norm_comp uu___2 [] c) () - with - | uu___1 -> - (warn_norm_failure c.FStar_Syntax_Syntax.pos uu___1; c) in - let uu___1 = - FStar_Syntax_DsEnv.set_current_module - env1.FStar_TypeChecker_Env.dsenv - env1.FStar_TypeChecker_Env.curmodule in - FStar_Syntax_Print.comp_to_string' uu___1 c1) -let (comp_to_doc : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.comp -> FStar_Pprint.document) - = - fun env1 -> - fun c -> - FStar_GenSym.with_frozen_gensym - (fun uu___ -> - let c1 = - try - (fun uu___1 -> - match () with - | () -> - let uu___2 = - FStar_TypeChecker_Cfg.config - [FStar_TypeChecker_Env.AllowUnboundUniverses] env1 in - norm_comp uu___2 [] c) () - with - | uu___1 -> - (warn_norm_failure c.FStar_Syntax_Syntax.pos uu___1; c) in - let uu___1 = - FStar_Syntax_DsEnv.set_current_module - env1.FStar_TypeChecker_Env.dsenv - env1.FStar_TypeChecker_Env.curmodule in - FStar_Syntax_Print.comp_to_doc' uu___1 c1) -let (normalize_refinement : - FStar_TypeChecker_Env.steps -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.typ) - = - fun steps -> - fun env1 -> - fun t0 -> - let t = - normalize - (FStar_Compiler_List.op_At steps [FStar_TypeChecker_Env.Beta]) - env1 t0 in - FStar_Syntax_Util.flatten_refinement t -let (whnf_steps : FStar_TypeChecker_Env.step Prims.list) = - [FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.Weak; - FStar_TypeChecker_Env.HNF; - FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Beta] -let (unfold_whnf' : - FStar_TypeChecker_Env.steps -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun steps -> - fun env1 -> - fun t -> normalize (FStar_Compiler_List.op_At steps whnf_steps) env1 t -let (unfold_whnf : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = fun env1 -> fun t -> unfold_whnf' [] env1 t -let (reduce_or_remove_uvar_solutions : - Prims.bool -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun remove -> - fun env1 -> - fun t -> - normalize - (FStar_Compiler_List.op_At - (if remove - then - [FStar_TypeChecker_Env.DefaultUnivsToZero; - FStar_TypeChecker_Env.CheckNoUvars] - else []) - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.DoNotUnfoldPureLets; - FStar_TypeChecker_Env.CompressUvars; - FStar_TypeChecker_Env.Exclude FStar_TypeChecker_Env.Zeta; - FStar_TypeChecker_Env.Exclude FStar_TypeChecker_Env.Iota; - FStar_TypeChecker_Env.NoFullNorm]) env1 t -let (reduce_uvar_solutions : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = fun env1 -> fun t -> reduce_or_remove_uvar_solutions false env1 t -let (remove_uvar_solutions : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = fun env1 -> fun t -> reduce_or_remove_uvar_solutions true env1 t -let (eta_expand_with_type : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.term) - = - fun env1 -> - fun e -> - fun t_e -> - let uu___ = FStar_Syntax_Util.arrow_formals_comp t_e in - match uu___ with - | (formals, c) -> - (match formals with - | [] -> e - | uu___1 -> - let uu___2 = FStar_Syntax_Util.abs_formals e in - (match uu___2 with - | (actuals, uu___3, uu___4) -> - if - (FStar_Compiler_List.length actuals) = - (FStar_Compiler_List.length formals) - then e - else - (let uu___6 = - FStar_Syntax_Util.args_of_binders formals in - match uu___6 with - | (binders, args) -> - let uu___7 = - FStar_Syntax_Syntax.mk_Tm_app e args - e.FStar_Syntax_Syntax.pos in - let uu___8 = - let uu___9 = - FStar_Syntax_Util.residual_comp_of_comp c in - FStar_Pervasives_Native.Some uu___9 in - FStar_Syntax_Util.abs binders uu___7 uu___8))) -let (eta_expand : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun env1 -> - fun t -> - match t.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_name x -> - eta_expand_with_type env1 t x.FStar_Syntax_Syntax.sort - | uu___ -> - let uu___1 = FStar_Syntax_Util.head_and_args t in - (match uu___1 with - | (head, args) -> - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress head in - uu___3.FStar_Syntax_Syntax.n in - (match uu___2 with - | FStar_Syntax_Syntax.Tm_uvar (u, s) -> - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Util.ctx_uvar_typ u in - FStar_Syntax_Subst.subst' s uu___5 in - FStar_Syntax_Util.arrow_formals uu___4 in - (match uu___3 with - | (formals, _tres) -> - if - (FStar_Compiler_List.length formals) = - (FStar_Compiler_List.length args) - then t - else - (let uu___5 = - env1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term - { - FStar_TypeChecker_Env.solver = - (env1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - FStar_Pervasives_Native.None; - FStar_TypeChecker_Env.sigtab = - (env1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = true; - FStar_TypeChecker_Env.lax_universes = - (env1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (env1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (env1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (env1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (env1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env1.FStar_TypeChecker_Env.missing_decl) - } t true in - match uu___5 with - | (uu___6, ty, uu___7) -> - eta_expand_with_type env1 t ty)) - | uu___3 -> - let uu___4 = - env1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term - { - FStar_TypeChecker_Env.solver = - (env1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - FStar_Pervasives_Native.None; - FStar_TypeChecker_Env.sigtab = - (env1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = true; - FStar_TypeChecker_Env.lax_universes = - (env1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env1.FStar_TypeChecker_Env.missing_decl) - } t true in - (match uu___4 with - | (uu___5, ty, uu___6) -> eta_expand_with_type env1 t ty))) -let (elim_uvars_aux_tc : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.univ_names -> - FStar_Syntax_Syntax.binders -> - (FStar_Syntax_Syntax.typ, FStar_Syntax_Syntax.comp) - FStar_Pervasives.either -> - (FStar_Syntax_Syntax.univ_names * FStar_Syntax_Syntax.binder - Prims.list * - (FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax, - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax) - FStar_Pervasives.either)) - = - fun env1 -> - fun univ_names -> - fun binders -> - fun tc -> - let t = - match (binders, tc) with - | ([], FStar_Pervasives.Inl t1) -> t1 - | ([], FStar_Pervasives.Inr c) -> - failwith "Impossible: empty bindes with a comp" - | (uu___, FStar_Pervasives.Inr c) -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 = binders; - FStar_Syntax_Syntax.comp = c - }) c.FStar_Syntax_Syntax.pos - | (uu___, FStar_Pervasives.Inl t1) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.mk_Total t1 in - { - FStar_Syntax_Syntax.bs1 = binders; - FStar_Syntax_Syntax.comp = uu___3 - } in - FStar_Syntax_Syntax.Tm_arrow uu___2 in - FStar_Syntax_Syntax.mk uu___1 t1.FStar_Syntax_Syntax.pos in - let uu___ = FStar_Syntax_Subst.open_univ_vars univ_names t in - match uu___ with - | (univ_names1, t1) -> - let t2 = remove_uvar_solutions env1 t1 in - let t3 = FStar_Syntax_Subst.close_univ_vars univ_names1 t2 in - let uu___1 = - match binders with - | [] -> ([], (FStar_Pervasives.Inl t3)) - | uu___2 -> - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Subst.compress t3 in - uu___5.FStar_Syntax_Syntax.n in - (uu___4, tc) in - (match uu___3 with - | (FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = binders1; - FStar_Syntax_Syntax.comp = c;_}, - FStar_Pervasives.Inr uu___4) -> - (binders1, (FStar_Pervasives.Inr c)) - | (FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = binders1; - FStar_Syntax_Syntax.comp = c;_}, - FStar_Pervasives.Inl uu___4) -> - (binders1, - (FStar_Pervasives.Inl - (FStar_Syntax_Util.comp_result c))) - | (uu___4, FStar_Pervasives.Inl uu___5) -> - ([], (FStar_Pervasives.Inl t3)) - | uu___4 -> failwith "Impossible") in - (match uu___1 with - | (binders1, tc1) -> (univ_names1, binders1, tc1)) -let (elim_uvars_aux_t : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.univ_names -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.typ -> - (FStar_Syntax_Syntax.univ_names * FStar_Syntax_Syntax.binder - Prims.list * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax)) - = - fun env1 -> - fun univ_names -> - fun binders -> - fun t -> - let uu___ = - elim_uvars_aux_tc env1 univ_names binders - (FStar_Pervasives.Inl t) in - match uu___ with - | (univ_names1, binders1, tc) -> - let uu___1 = FStar_Compiler_Util.left tc in - (univ_names1, binders1, uu___1) -let (elim_uvars_aux_c : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.univ_names -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.comp -> - (FStar_Syntax_Syntax.univ_names * FStar_Syntax_Syntax.binder - Prims.list * FStar_Syntax_Syntax.comp' - FStar_Syntax_Syntax.syntax)) - = - fun env1 -> - fun univ_names -> - fun binders -> - fun c -> - let uu___ = - elim_uvars_aux_tc env1 univ_names binders - (FStar_Pervasives.Inr c) in - match uu___ with - | (univ_names1, binders1, tc) -> - let uu___1 = FStar_Compiler_Util.right tc in - (univ_names1, binders1, uu___1) -let rec (elim_uvars : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.sigelt -> FStar_Syntax_Syntax.sigelt) - = - fun env1 -> - fun s -> - let sigattrs = - let uu___ = - FStar_Compiler_List.map (elim_uvars_aux_t env1 [] []) - s.FStar_Syntax_Syntax.sigattrs in - FStar_Compiler_List.map - FStar_Pervasives_Native.__proj__Mktuple3__item___3 uu___ in - let s1 = - { - FStar_Syntax_Syntax.sigel = (s.FStar_Syntax_Syntax.sigel); - FStar_Syntax_Syntax.sigrng = (s.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = (s.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = (s.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = sigattrs; - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (s.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = (s.FStar_Syntax_Syntax.sigopts) - } in - match s1.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = lid; - FStar_Syntax_Syntax.us = univ_names; - FStar_Syntax_Syntax.params = binders; - FStar_Syntax_Syntax.num_uniform_params = num_uniform; - FStar_Syntax_Syntax.t = typ; FStar_Syntax_Syntax.mutuals = lids; - FStar_Syntax_Syntax.ds = lids'; - FStar_Syntax_Syntax.injective_type_params = injective_type_params;_} - -> - let uu___ = elim_uvars_aux_t env1 univ_names binders typ in - (match uu___ with - | (univ_names1, binders1, typ1) -> - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_inductive_typ - { - FStar_Syntax_Syntax.lid = lid; - FStar_Syntax_Syntax.us = univ_names1; - FStar_Syntax_Syntax.params = binders1; - FStar_Syntax_Syntax.num_uniform_params = num_uniform; - FStar_Syntax_Syntax.t = typ1; - FStar_Syntax_Syntax.mutuals = lids; - FStar_Syntax_Syntax.ds = lids'; - FStar_Syntax_Syntax.injective_type_params = - injective_type_params - }); - FStar_Syntax_Syntax.sigrng = (s1.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (s1.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (s1.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (s1.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (s1.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (s1.FStar_Syntax_Syntax.sigopts) - }) - | FStar_Syntax_Syntax.Sig_bundle - { FStar_Syntax_Syntax.ses = sigs; - FStar_Syntax_Syntax.lids = lids;_} - -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Compiler_List.map (elim_uvars env1) sigs in - { - FStar_Syntax_Syntax.ses = uu___2; - FStar_Syntax_Syntax.lids = lids - } in - FStar_Syntax_Syntax.Sig_bundle uu___1 in - { - FStar_Syntax_Syntax.sigel = uu___; - FStar_Syntax_Syntax.sigrng = (s1.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = (s1.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = (s1.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = (s1.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (s1.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = (s1.FStar_Syntax_Syntax.sigopts) - } - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = lid; - FStar_Syntax_Syntax.us1 = univ_names; - FStar_Syntax_Syntax.t1 = typ; - FStar_Syntax_Syntax.ty_lid = lident; - FStar_Syntax_Syntax.num_ty_params = i; - FStar_Syntax_Syntax.mutuals1 = lids; - FStar_Syntax_Syntax.injective_type_params1 = - injective_type_params;_} - -> - let uu___ = elim_uvars_aux_t env1 univ_names [] typ in - (match uu___ with - | (univ_names1, uu___1, typ1) -> - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_datacon - { - FStar_Syntax_Syntax.lid1 = lid; - FStar_Syntax_Syntax.us1 = univ_names1; - FStar_Syntax_Syntax.t1 = typ1; - FStar_Syntax_Syntax.ty_lid = lident; - FStar_Syntax_Syntax.num_ty_params = i; - FStar_Syntax_Syntax.mutuals1 = lids; - FStar_Syntax_Syntax.injective_type_params1 = - injective_type_params - }); - FStar_Syntax_Syntax.sigrng = (s1.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (s1.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (s1.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (s1.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (s1.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (s1.FStar_Syntax_Syntax.sigopts) - }) - | FStar_Syntax_Syntax.Sig_declare_typ - { FStar_Syntax_Syntax.lid2 = lid; - FStar_Syntax_Syntax.us2 = univ_names; - FStar_Syntax_Syntax.t2 = typ;_} - -> - let uu___ = elim_uvars_aux_t env1 univ_names [] typ in - (match uu___ with - | (univ_names1, uu___1, typ1) -> - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_declare_typ - { - FStar_Syntax_Syntax.lid2 = lid; - FStar_Syntax_Syntax.us2 = univ_names1; - FStar_Syntax_Syntax.t2 = typ1 - }); - FStar_Syntax_Syntax.sigrng = (s1.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (s1.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (s1.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (s1.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (s1.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (s1.FStar_Syntax_Syntax.sigopts) - }) - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (b, lbs); - FStar_Syntax_Syntax.lids1 = lids;_} - -> - let lbs1 = - FStar_Compiler_List.map - (fun lb -> - let uu___ = - FStar_Syntax_Subst.univ_var_opening - lb.FStar_Syntax_Syntax.lbunivs in - match uu___ with - | (opening, lbunivs) -> - let elim t = - let uu___1 = - let uu___2 = FStar_Syntax_Subst.subst opening t in - remove_uvar_solutions env1 uu___2 in - FStar_Syntax_Subst.close_univ_vars lbunivs uu___1 in - let lbtyp = elim lb.FStar_Syntax_Syntax.lbtyp in - let lbdef = elim lb.FStar_Syntax_Syntax.lbdef in - { - FStar_Syntax_Syntax.lbname = - (lb.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs = lbunivs; - FStar_Syntax_Syntax.lbtyp = lbtyp; - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = lbdef; - FStar_Syntax_Syntax.lbattrs = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - }) lbs in - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_let - { - FStar_Syntax_Syntax.lbs1 = (b, lbs1); - FStar_Syntax_Syntax.lids1 = lids - }); - FStar_Syntax_Syntax.sigrng = (s1.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = (s1.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = (s1.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = (s1.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (s1.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = (s1.FStar_Syntax_Syntax.sigopts) - } - | FStar_Syntax_Syntax.Sig_assume - { FStar_Syntax_Syntax.lid3 = l; FStar_Syntax_Syntax.us3 = us; - FStar_Syntax_Syntax.phi1 = t;_} - -> - let uu___ = elim_uvars_aux_t env1 us [] t in - (match uu___ with - | (us1, uu___1, t1) -> - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_assume - { - FStar_Syntax_Syntax.lid3 = l; - FStar_Syntax_Syntax.us3 = us1; - FStar_Syntax_Syntax.phi1 = t1 - }); - FStar_Syntax_Syntax.sigrng = (s1.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (s1.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (s1.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (s1.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (s1.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (s1.FStar_Syntax_Syntax.sigopts) - }) - | FStar_Syntax_Syntax.Sig_new_effect ed -> - let uu___ = - elim_uvars_aux_t env1 ed.FStar_Syntax_Syntax.univs - ed.FStar_Syntax_Syntax.binders FStar_Syntax_Syntax.t_unit in - (match uu___ with - | (univs, binders, uu___1) -> - let uu___2 = - let uu___3 = FStar_Syntax_Subst.univ_var_opening univs in - match uu___3 with - | (univs_opening, univs1) -> - let uu___4 = FStar_Syntax_Subst.univ_var_closing univs1 in - (univs_opening, uu___4) in - (match uu___2 with - | (univs_opening, univs_closing) -> - let uu___3 = - let binders1 = FStar_Syntax_Subst.open_binders binders in - let uu___4 = - FStar_Syntax_Subst.opening_of_binders binders1 in - let uu___5 = - FStar_Syntax_Subst.closing_of_binders binders1 in - (uu___4, uu___5) in - (match uu___3 with - | (b_opening, b_closing) -> - let n = FStar_Compiler_List.length univs in - let n_binders = FStar_Compiler_List.length binders in - let elim_tscheme uu___4 = - match uu___4 with - | (us, t) -> - let n_us = FStar_Compiler_List.length us in - let uu___5 = - FStar_Syntax_Subst.open_univ_vars us t in - (match uu___5 with - | (us1, t1) -> - let uu___6 = - let uu___7 = - FStar_Syntax_Subst.shift_subst n_us - b_opening in - let uu___8 = - FStar_Syntax_Subst.shift_subst n_us - b_closing in - (uu___7, uu___8) in - (match uu___6 with - | (b_opening1, b_closing1) -> - let uu___7 = - let uu___8 = - FStar_Syntax_Subst.shift_subst - (n_us + n_binders) - univs_opening in - let uu___9 = - FStar_Syntax_Subst.shift_subst - (n_us + n_binders) - univs_closing in - (uu___8, uu___9) in - (match uu___7 with - | (univs_opening1, univs_closing1) - -> - let t2 = - let uu___8 = - FStar_Syntax_Subst.subst - b_opening1 t1 in - FStar_Syntax_Subst.subst - univs_opening1 uu___8 in - let uu___8 = - elim_uvars_aux_t env1 [] [] - t2 in - (match uu___8 with - | (uu___9, uu___10, t3) -> - let t4 = - let uu___11 = - let uu___12 = - FStar_Syntax_Subst.close_univ_vars - us1 t3 in - FStar_Syntax_Subst.subst - b_closing1 uu___12 in - FStar_Syntax_Subst.subst - univs_closing1 uu___11 in - (us1, t4))))) in - let elim_term t = - let uu___4 = elim_uvars_aux_t env1 univs binders t in - match uu___4 with | (uu___5, uu___6, t1) -> t1 in - let elim_action a = - let action_typ_templ = - let body = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_ascribed - { - FStar_Syntax_Syntax.tm = - (a.FStar_Syntax_Syntax.action_defn); - FStar_Syntax_Syntax.asc = - ((FStar_Pervasives.Inl - (a.FStar_Syntax_Syntax.action_typ)), - FStar_Pervasives_Native.None, - false); - FStar_Syntax_Syntax.eff_opt = - FStar_Pervasives_Native.None - }) - (a.FStar_Syntax_Syntax.action_defn).FStar_Syntax_Syntax.pos in - match a.FStar_Syntax_Syntax.action_params with - | [] -> body - | uu___4 -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = - (a.FStar_Syntax_Syntax.action_params); - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = - FStar_Pervasives_Native.None - }) - (a.FStar_Syntax_Syntax.action_defn).FStar_Syntax_Syntax.pos in - let destruct_action_body body = - let uu___4 = - let uu___5 = FStar_Syntax_Subst.compress body in - uu___5.FStar_Syntax_Syntax.n in - match uu___4 with - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = defn; - FStar_Syntax_Syntax.asc = - (FStar_Pervasives.Inl typ, - FStar_Pervasives_Native.None, uu___5); - FStar_Syntax_Syntax.eff_opt = - FStar_Pervasives_Native.None;_} - -> (defn, typ) - | uu___5 -> failwith "Impossible" in - let destruct_action_typ_templ t = - let uu___4 = - let uu___5 = FStar_Syntax_Subst.compress t in - uu___5.FStar_Syntax_Syntax.n in - match uu___4 with - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = pars; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = uu___5;_} - -> - let uu___6 = destruct_action_body body in - (match uu___6 with - | (defn, typ) -> (pars, defn, typ)) - | uu___5 -> - let uu___6 = destruct_action_body t in - (match uu___6 with - | (defn, typ) -> ([], defn, typ)) in - let uu___4 = - elim_tscheme - ((a.FStar_Syntax_Syntax.action_univs), - action_typ_templ) in - match uu___4 with - | (action_univs, t) -> - let uu___5 = destruct_action_typ_templ t in - (match uu___5 with - | (action_params, action_defn, action_typ) -> - let a' = - { - FStar_Syntax_Syntax.action_name = - (a.FStar_Syntax_Syntax.action_name); - FStar_Syntax_Syntax.action_unqualified_name - = - (a.FStar_Syntax_Syntax.action_unqualified_name); - FStar_Syntax_Syntax.action_univs = - action_univs; - FStar_Syntax_Syntax.action_params = - action_params; - FStar_Syntax_Syntax.action_defn = - action_defn; - FStar_Syntax_Syntax.action_typ = - action_typ - } in - a') in - let ed1 = - let uu___4 = - FStar_Syntax_Util.apply_eff_sig elim_tscheme - ed.FStar_Syntax_Syntax.signature in - let uu___5 = - FStar_Syntax_Util.apply_eff_combinators - elim_tscheme - ed.FStar_Syntax_Syntax.combinators in - let uu___6 = - FStar_Compiler_List.map elim_action - ed.FStar_Syntax_Syntax.actions in - { - FStar_Syntax_Syntax.mname = - (ed.FStar_Syntax_Syntax.mname); - FStar_Syntax_Syntax.cattributes = - (ed.FStar_Syntax_Syntax.cattributes); - FStar_Syntax_Syntax.univs = univs; - FStar_Syntax_Syntax.binders = binders; - FStar_Syntax_Syntax.signature = uu___4; - FStar_Syntax_Syntax.combinators = uu___5; - FStar_Syntax_Syntax.actions = uu___6; - FStar_Syntax_Syntax.eff_attrs = - (ed.FStar_Syntax_Syntax.eff_attrs); - FStar_Syntax_Syntax.extraction_mode = - (ed.FStar_Syntax_Syntax.extraction_mode) - } in - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_new_effect ed1); - FStar_Syntax_Syntax.sigrng = - (s1.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (s1.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (s1.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (s1.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (s1.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (s1.FStar_Syntax_Syntax.sigopts) - }))) - | FStar_Syntax_Syntax.Sig_sub_effect sub_eff -> - let elim_tscheme_opt uu___ = - match uu___ with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (us, t) -> - let uu___1 = elim_uvars_aux_t env1 us [] t in - (match uu___1 with - | (us1, uu___2, t1) -> - FStar_Pervasives_Native.Some (us1, t1)) in - let sub_eff1 = - let uu___ = elim_tscheme_opt sub_eff.FStar_Syntax_Syntax.lift_wp in - let uu___1 = elim_tscheme_opt sub_eff.FStar_Syntax_Syntax.lift in - { - FStar_Syntax_Syntax.source = - (sub_eff.FStar_Syntax_Syntax.source); - FStar_Syntax_Syntax.target = - (sub_eff.FStar_Syntax_Syntax.target); - FStar_Syntax_Syntax.lift_wp = uu___; - FStar_Syntax_Syntax.lift = uu___1; - FStar_Syntax_Syntax.kind = (sub_eff.FStar_Syntax_Syntax.kind) - } in - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_sub_effect sub_eff1); - FStar_Syntax_Syntax.sigrng = (s1.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = (s1.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = (s1.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = (s1.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (s1.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = (s1.FStar_Syntax_Syntax.sigopts) - } - | FStar_Syntax_Syntax.Sig_effect_abbrev - { FStar_Syntax_Syntax.lid4 = lid; - FStar_Syntax_Syntax.us4 = univ_names; - FStar_Syntax_Syntax.bs2 = binders; - FStar_Syntax_Syntax.comp1 = comp; - FStar_Syntax_Syntax.cflags = flags;_} - -> - let uu___ = elim_uvars_aux_c env1 univ_names binders comp in - (match uu___ with - | (univ_names1, binders1, comp1) -> - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_effect_abbrev - { - FStar_Syntax_Syntax.lid4 = lid; - FStar_Syntax_Syntax.us4 = univ_names1; - FStar_Syntax_Syntax.bs2 = binders1; - FStar_Syntax_Syntax.comp1 = comp1; - FStar_Syntax_Syntax.cflags = flags - }); - FStar_Syntax_Syntax.sigrng = (s1.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (s1.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (s1.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (s1.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (s1.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (s1.FStar_Syntax_Syntax.sigopts) - }) - | FStar_Syntax_Syntax.Sig_pragma uu___ -> s1 - | FStar_Syntax_Syntax.Sig_fail uu___ -> s1 - | FStar_Syntax_Syntax.Sig_splice uu___ -> s1 - | FStar_Syntax_Syntax.Sig_polymonadic_bind - { FStar_Syntax_Syntax.m_lid = m; FStar_Syntax_Syntax.n_lid = n; - FStar_Syntax_Syntax.p_lid = p; - FStar_Syntax_Syntax.tm3 = (us_t, t); - FStar_Syntax_Syntax.typ = (us_ty, ty); - FStar_Syntax_Syntax.kind1 = k;_} - -> - let uu___ = elim_uvars_aux_t env1 us_t [] t in - (match uu___ with - | (us_t1, uu___1, t1) -> - let uu___2 = elim_uvars_aux_t env1 us_ty [] ty in - (match uu___2 with - | (us_ty1, uu___3, ty1) -> - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_polymonadic_bind - { - FStar_Syntax_Syntax.m_lid = m; - FStar_Syntax_Syntax.n_lid = n; - FStar_Syntax_Syntax.p_lid = p; - FStar_Syntax_Syntax.tm3 = (us_t1, t1); - FStar_Syntax_Syntax.typ = (us_ty1, ty1); - FStar_Syntax_Syntax.kind1 = k - }); - FStar_Syntax_Syntax.sigrng = - (s1.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (s1.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (s1.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (s1.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (s1.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (s1.FStar_Syntax_Syntax.sigopts) - })) - | FStar_Syntax_Syntax.Sig_polymonadic_subcomp - { FStar_Syntax_Syntax.m_lid1 = m; FStar_Syntax_Syntax.n_lid1 = n; - FStar_Syntax_Syntax.tm4 = (us_t, t); - FStar_Syntax_Syntax.typ1 = (us_ty, ty); - FStar_Syntax_Syntax.kind2 = k;_} - -> - let uu___ = elim_uvars_aux_t env1 us_t [] t in - (match uu___ with - | (us_t1, uu___1, t1) -> - let uu___2 = elim_uvars_aux_t env1 us_ty [] ty in - (match uu___2 with - | (us_ty1, uu___3, ty1) -> - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_polymonadic_subcomp - { - FStar_Syntax_Syntax.m_lid1 = m; - FStar_Syntax_Syntax.n_lid1 = n; - FStar_Syntax_Syntax.tm4 = (us_t1, t1); - FStar_Syntax_Syntax.typ1 = (us_ty1, ty1); - FStar_Syntax_Syntax.kind2 = k - }); - FStar_Syntax_Syntax.sigrng = - (s1.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (s1.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (s1.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (s1.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (s1.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (s1.FStar_Syntax_Syntax.sigopts) - })) -let (erase_universes : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun env1 -> - fun t -> - normalize - [FStar_TypeChecker_Env.EraseUniverses; - FStar_TypeChecker_Env.AllowUnboundUniverses] env1 t -let (unfold_head_once : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = - fun env1 -> - fun t -> - let aux f us args = - let uu___ = - FStar_TypeChecker_Env.lookup_nonrec_definition - [FStar_TypeChecker_Env.Unfold FStar_Syntax_Syntax.delta_constant] - env1 (f.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - match uu___ with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some head_def_ts -> - let uu___1 = - FStar_TypeChecker_Env.inst_tscheme_with head_def_ts us in - (match uu___1 with - | (uu___2, head_def) -> - let t' = - FStar_Syntax_Syntax.mk_Tm_app head_def args - t.FStar_Syntax_Syntax.pos in - let t'1 = - normalize - [FStar_TypeChecker_Env.Beta; FStar_TypeChecker_Env.Iota] - env1 t' in - FStar_Pervasives_Native.Some t'1) in - let uu___ = FStar_Syntax_Util.head_and_args t in - match uu___ with - | (head, args) -> - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress head in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_fvar fv -> aux fv [] args - | FStar_Syntax_Syntax.Tm_uinst - ({ FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___2; - FStar_Syntax_Syntax.vars = uu___3; - FStar_Syntax_Syntax.hash_code = uu___4;_}, - us) - -> aux fv us args - | uu___2 -> FStar_Pervasives_Native.None) -let (get_n_binders' : - FStar_TypeChecker_Env.env -> - FStar_TypeChecker_Env.step Prims.list -> - Prims.int -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.binder Prims.list * FStar_Syntax_Syntax.comp)) - = - fun env1 -> - fun steps -> - fun n -> - fun t -> - let rec aux retry n1 t1 = - let uu___ = FStar_Syntax_Util.arrow_formals_comp t1 in - match uu___ with - | (bs, c) -> - let len = FStar_Compiler_List.length bs in - (match (bs, c) with - | ([], uu___1) when retry -> - let uu___2 = unfold_whnf' steps env1 t1 in - aux false n1 uu___2 - | ([], uu___1) when Prims.op_Negation retry -> (bs, c) - | (bs1, c1) when len = n1 -> (bs1, c1) - | (bs1, c1) when len > n1 -> - let uu___1 = FStar_Compiler_List.splitAt n1 bs1 in - (match uu___1 with - | (bs_l, bs_r) -> - let uu___2 = - let uu___3 = FStar_Syntax_Util.arrow bs_r c1 in - FStar_Syntax_Syntax.mk_Total uu___3 in - (bs_l, uu___2)) - | (bs1, c1) when - ((len < n1) && (FStar_Syntax_Util.is_total_comp c1)) && - (let uu___1 = FStar_Syntax_Util.has_decreases c1 in - Prims.op_Negation uu___1) - -> - let uu___1 = - aux true (n1 - len) (FStar_Syntax_Util.comp_result c1) in - (match uu___1 with - | (bs', c') -> - ((FStar_Compiler_List.op_At bs1 bs'), c')) - | (bs1, c1) -> (bs1, c1)) in - aux true n t -let (get_n_binders : - FStar_TypeChecker_Env.env -> - Prims.int -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.binder Prims.list * FStar_Syntax_Syntax.comp)) - = fun env1 -> fun n -> fun t -> get_n_binders' env1 [] n t -let (uu___0 : unit) = - FStar_Compiler_Effect.op_Colon_Equals __get_n_binders get_n_binders' -let (maybe_unfold_head_fv : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = - fun env1 -> - fun head -> - let fv_us_opt = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress head in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_uinst - ({ FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___1; - FStar_Syntax_Syntax.vars = uu___2; - FStar_Syntax_Syntax.hash_code = uu___3;_}, - us) - -> FStar_Pervasives_Native.Some (fv, us) - | FStar_Syntax_Syntax.Tm_fvar fv -> - FStar_Pervasives_Native.Some (fv, []) - | uu___1 -> FStar_Pervasives_Native.None in - match fv_us_opt with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (fv, us) -> - let uu___ = - FStar_TypeChecker_Env.lookup_nonrec_definition - [FStar_TypeChecker_Env.Unfold - FStar_Syntax_Syntax.delta_constant] env1 - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - (match uu___ with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (us_formals, defn) -> - let subst = FStar_TypeChecker_Env.mk_univ_subst us_formals us in - let uu___1 = FStar_Syntax_Subst.subst subst defn in - FStar_Pervasives_Native.Some uu___1) -let rec (maybe_unfold_aux : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = - fun env1 -> - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = t0; - FStar_Syntax_Syntax.ret_opt = ret_opt; - FStar_Syntax_Syntax.brs = brs; - FStar_Syntax_Syntax.rc_opt1 = rc_opt;_} - -> - let uu___1 = maybe_unfold_aux env1 t0 in - FStar_Compiler_Util.map_option - (fun t01 -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_match - { - FStar_Syntax_Syntax.scrutinee = t01; - FStar_Syntax_Syntax.ret_opt = ret_opt; - FStar_Syntax_Syntax.brs = brs; - FStar_Syntax_Syntax.rc_opt1 = rc_opt - }) t.FStar_Syntax_Syntax.pos) uu___1 - | FStar_Syntax_Syntax.Tm_fvar uu___1 -> maybe_unfold_head_fv env1 t - | FStar_Syntax_Syntax.Tm_uinst uu___1 -> maybe_unfold_head_fv env1 t - | uu___1 -> - let uu___2 = FStar_Syntax_Util.leftmost_head_and_args t in - (match uu___2 with - | (head, args) -> - if args = [] - then maybe_unfold_head_fv env1 head - else - (let uu___4 = maybe_unfold_aux env1 head in - match uu___4 with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some head1 -> - let uu___5 = - FStar_Syntax_Syntax.mk_Tm_app head1 args - t.FStar_Syntax_Syntax.pos in - FStar_Pervasives_Native.Some uu___5)) -let (maybe_unfold_head : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = - fun env1 -> - fun t -> - let uu___ = maybe_unfold_aux env1 t in - FStar_Compiler_Util.map_option - (normalize - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Iota; - FStar_TypeChecker_Env.Weak; - FStar_TypeChecker_Env.HNF] env1) uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Normalize_Unfolding.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Normalize_Unfolding.ml deleted file mode 100644 index feb25393c05..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Normalize_Unfolding.ml +++ /dev/null @@ -1,787 +0,0 @@ -open Prims -let (plugin_unfold_warn_ctr : Prims.int FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref Prims.int_zero -type should_unfold_res = - | Should_unfold_no - | Should_unfold_yes - | Should_unfold_fully - | Should_unfold_reify -let (uu___is_Should_unfold_no : should_unfold_res -> Prims.bool) = - fun projectee -> - match projectee with | Should_unfold_no -> true | uu___ -> false -let (uu___is_Should_unfold_yes : should_unfold_res -> Prims.bool) = - fun projectee -> - match projectee with | Should_unfold_yes -> true | uu___ -> false -let (uu___is_Should_unfold_fully : should_unfold_res -> Prims.bool) = - fun projectee -> - match projectee with | Should_unfold_fully -> true | uu___ -> false -let (uu___is_Should_unfold_reify : should_unfold_res -> Prims.bool) = - fun projectee -> - match projectee with | Should_unfold_reify -> true | uu___ -> false -let (should_unfold : - FStar_TypeChecker_Cfg.cfg -> - (FStar_TypeChecker_Cfg.cfg -> Prims.bool) -> - FStar_Syntax_Syntax.fv -> - FStar_TypeChecker_Env.qninfo -> should_unfold_res) - = - fun cfg -> - fun should_reify -> - fun fv -> - fun qninfo -> - let attrs = - let uu___ = FStar_TypeChecker_Env.attrs_of_qninfo qninfo in - match uu___ with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some ats -> ats in - let quals = - let uu___ = FStar_TypeChecker_Env.quals_of_qninfo qninfo in - match uu___ with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some quals1 -> quals1 in - let yes = (true, false, false) in - let no = (false, false, false) in - let fully = (true, true, false) in - let reif = (true, false, true) in - let yesno b = if b then yes else no in - let fullyno b = if b then fully else no in - let comb_or l = - FStar_Compiler_List.fold_right - (fun uu___ -> - fun uu___1 -> - match (uu___, uu___1) with - | ((a, b, c), (x, y, z)) -> ((a || x), (b || y), (c || z))) - l (false, false, false) in - let default_unfolding uu___ = - FStar_TypeChecker_Cfg.log_unfolding cfg - (fun uu___2 -> - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_fv fv in - let uu___4 = - let uu___5 = - FStar_TypeChecker_Env.delta_depth_of_fv - cfg.FStar_TypeChecker_Cfg.tcenv fv in - FStar_Class_Show.show - FStar_Syntax_Syntax.showable_delta_depth uu___5 in - let uu___5 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_TypeChecker_Env.showable_delta_level) - cfg.FStar_TypeChecker_Cfg.delta_level in - FStar_Compiler_Util.print3 - "should_unfold: Reached a %s with delta_depth = %s\n >> Our delta_level is %s\n" - uu___3 uu___4 uu___5); - (let uu___2 = - FStar_Compiler_Util.for_some - (fun uu___3 -> - match uu___3 with - | FStar_TypeChecker_Env.NoDelta -> false - | FStar_TypeChecker_Env.InliningDelta -> true - | FStar_TypeChecker_Env.Eager_unfolding_only -> true - | FStar_TypeChecker_Env.Unfold l -> - let uu___4 = - FStar_TypeChecker_Env.delta_depth_of_fv - cfg.FStar_TypeChecker_Cfg.tcenv fv in - FStar_TypeChecker_Common.delta_depth_greater_than - uu___4 l) cfg.FStar_TypeChecker_Cfg.delta_level in - yesno uu___2) in - let res = - if FStar_TypeChecker_Env.qninfo_is_action qninfo - then - let b = should_reify cfg in - (FStar_TypeChecker_Cfg.log_unfolding cfg - (fun uu___1 -> - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_fv fv in - let uu___3 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) b in - FStar_Compiler_Util.print2 - "should_unfold: For DM4F action %s, should_reify = %s\n" - uu___2 uu___3); - if b then reif else no) - else - if - (let uu___ = FStar_TypeChecker_Cfg.find_prim_step cfg fv in - FStar_Compiler_Option.isSome uu___) - then - (FStar_TypeChecker_Cfg.log_unfolding cfg - (fun uu___1 -> - FStar_Compiler_Util.print_string - " >> It's a primop, not unfolding\n"); - no) - else - (match (qninfo, - ((cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_only), - ((cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_fully), - ((cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_attr), - ((cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_qual), - ((cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_namespace)) - with - | (FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr - ({ - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (is_rec, uu___); - FStar_Syntax_Syntax.lids1 = uu___1;_}; - FStar_Syntax_Syntax.sigrng = uu___2; - FStar_Syntax_Syntax.sigquals = qs; - FStar_Syntax_Syntax.sigmeta = uu___3; - FStar_Syntax_Syntax.sigattrs = uu___4; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___5; - FStar_Syntax_Syntax.sigopts = uu___6;_}, - uu___7), - uu___8), - uu___9, uu___10, uu___11, uu___12, uu___13) when - FStar_Compiler_List.contains - FStar_Syntax_Syntax.HasMaskedEffect qs - -> - (FStar_TypeChecker_Cfg.log_unfolding cfg - (fun uu___15 -> - FStar_Compiler_Util.print_string - " >> HasMaskedEffect, not unfolding\n"); - no) - | (FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr - ({ - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (is_rec, uu___); - FStar_Syntax_Syntax.lids1 = uu___1;_}; - FStar_Syntax_Syntax.sigrng = uu___2; - FStar_Syntax_Syntax.sigquals = qs; - FStar_Syntax_Syntax.sigmeta = uu___3; - FStar_Syntax_Syntax.sigattrs = uu___4; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___5; - FStar_Syntax_Syntax.sigopts = uu___6;_}, - uu___7), - uu___8), - uu___9, uu___10, uu___11, uu___12, uu___13) when - (is_rec && - (Prims.op_Negation - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.zeta)) - && - (Prims.op_Negation - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.zeta_full) - -> - (FStar_TypeChecker_Cfg.log_unfolding cfg - (fun uu___15 -> - FStar_Compiler_Util.print_string - " >> It's a recursive definition but we're not doing Zeta, not unfolding\n"); - no) - | (uu___, FStar_Pervasives_Native.Some uu___1, uu___2, - uu___3, uu___4, uu___5) -> - (FStar_TypeChecker_Cfg.log_unfolding cfg - (fun uu___7 -> - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_fv fv in - FStar_Compiler_Util.print1 - "should_unfold: Reached a %s with selective unfolding\n" - uu___8); - (let meets_some_criterion = - let uu___7 = - let uu___8 = - if - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.for_extraction - then - let uu___9 = - let uu___10 = - FStar_TypeChecker_Env.lookup_definition_qninfo - [FStar_TypeChecker_Env.Eager_unfolding_only; - FStar_TypeChecker_Env.InliningDelta] - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - qninfo in - FStar_Compiler_Option.isSome uu___10 in - yesno uu___9 - else no in - let uu___9 = - let uu___10 = - match (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_only - with - | FStar_Pervasives_Native.None -> no - | FStar_Pervasives_Native.Some lids -> - let uu___11 = - FStar_Compiler_Util.for_some - (FStar_Syntax_Syntax.fv_eq_lid fv) - lids in - yesno uu___11 in - let uu___11 = - let uu___12 = - match (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_attr - with - | FStar_Pervasives_Native.None -> no - | FStar_Pervasives_Native.Some lids -> - let uu___13 = - FStar_Compiler_Util.for_some - (fun at -> - FStar_Compiler_Util.for_some - (fun lid -> - FStar_Syntax_Util.is_fvar - lid at) lids) attrs in - yesno uu___13 in - let uu___13 = - let uu___14 = - match (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_fully - with - | FStar_Pervasives_Native.None -> no - | FStar_Pervasives_Native.Some lids -> - let uu___15 = - FStar_Compiler_Util.for_some - (FStar_Syntax_Syntax.fv_eq_lid fv) - lids in - fullyno uu___15 in - let uu___15 = - let uu___16 = - match (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_qual - with - | FStar_Pervasives_Native.None -> no - | FStar_Pervasives_Native.Some qs -> - let uu___17 = - FStar_Compiler_Util.for_some - (fun q -> - FStar_Compiler_Util.for_some - (fun qual -> - let uu___18 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_qualifier - qual in - uu___18 = q) quals) qs in - yesno uu___17 in - let uu___17 = - let uu___18 = - match (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_namespace - with - | FStar_Pervasives_Native.None -> no - | FStar_Pervasives_Native.Some - namespaces -> - let p = - let uu___19 = - FStar_Syntax_Syntax.lid_of_fv - fv in - FStar_Ident.path_of_lid uu___19 in - let r = - FStar_Compiler_Path.search_forest - (FStar_Class_Ord.ord_eq - FStar_Class_Ord.ord_string) - p namespaces in - yesno r in - [uu___18] in - uu___16 :: uu___17 in - uu___14 :: uu___15 in - uu___12 :: uu___13 in - uu___10 :: uu___11 in - uu___8 :: uu___9 in - comb_or uu___7 in - meets_some_criterion)) - | (uu___, uu___1, FStar_Pervasives_Native.Some uu___2, - uu___3, uu___4, uu___5) -> - (FStar_TypeChecker_Cfg.log_unfolding cfg - (fun uu___7 -> - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_fv fv in - FStar_Compiler_Util.print1 - "should_unfold: Reached a %s with selective unfolding\n" - uu___8); - (let meets_some_criterion = - let uu___7 = - let uu___8 = - if - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.for_extraction - then - let uu___9 = - let uu___10 = - FStar_TypeChecker_Env.lookup_definition_qninfo - [FStar_TypeChecker_Env.Eager_unfolding_only; - FStar_TypeChecker_Env.InliningDelta] - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - qninfo in - FStar_Compiler_Option.isSome uu___10 in - yesno uu___9 - else no in - let uu___9 = - let uu___10 = - match (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_only - with - | FStar_Pervasives_Native.None -> no - | FStar_Pervasives_Native.Some lids -> - let uu___11 = - FStar_Compiler_Util.for_some - (FStar_Syntax_Syntax.fv_eq_lid fv) - lids in - yesno uu___11 in - let uu___11 = - let uu___12 = - match (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_attr - with - | FStar_Pervasives_Native.None -> no - | FStar_Pervasives_Native.Some lids -> - let uu___13 = - FStar_Compiler_Util.for_some - (fun at -> - FStar_Compiler_Util.for_some - (fun lid -> - FStar_Syntax_Util.is_fvar - lid at) lids) attrs in - yesno uu___13 in - let uu___13 = - let uu___14 = - match (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_fully - with - | FStar_Pervasives_Native.None -> no - | FStar_Pervasives_Native.Some lids -> - let uu___15 = - FStar_Compiler_Util.for_some - (FStar_Syntax_Syntax.fv_eq_lid fv) - lids in - fullyno uu___15 in - let uu___15 = - let uu___16 = - match (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_qual - with - | FStar_Pervasives_Native.None -> no - | FStar_Pervasives_Native.Some qs -> - let uu___17 = - FStar_Compiler_Util.for_some - (fun q -> - FStar_Compiler_Util.for_some - (fun qual -> - let uu___18 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_qualifier - qual in - uu___18 = q) quals) qs in - yesno uu___17 in - let uu___17 = - let uu___18 = - match (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_namespace - with - | FStar_Pervasives_Native.None -> no - | FStar_Pervasives_Native.Some - namespaces -> - let p = - let uu___19 = - FStar_Syntax_Syntax.lid_of_fv - fv in - FStar_Ident.path_of_lid uu___19 in - let r = - FStar_Compiler_Path.search_forest - (FStar_Class_Ord.ord_eq - FStar_Class_Ord.ord_string) - p namespaces in - yesno r in - [uu___18] in - uu___16 :: uu___17 in - uu___14 :: uu___15 in - uu___12 :: uu___13 in - uu___10 :: uu___11 in - uu___8 :: uu___9 in - comb_or uu___7 in - meets_some_criterion)) - | (uu___, uu___1, uu___2, FStar_Pervasives_Native.Some - uu___3, uu___4, uu___5) -> - (FStar_TypeChecker_Cfg.log_unfolding cfg - (fun uu___7 -> - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_fv fv in - FStar_Compiler_Util.print1 - "should_unfold: Reached a %s with selective unfolding\n" - uu___8); - (let meets_some_criterion = - let uu___7 = - let uu___8 = - if - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.for_extraction - then - let uu___9 = - let uu___10 = - FStar_TypeChecker_Env.lookup_definition_qninfo - [FStar_TypeChecker_Env.Eager_unfolding_only; - FStar_TypeChecker_Env.InliningDelta] - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - qninfo in - FStar_Compiler_Option.isSome uu___10 in - yesno uu___9 - else no in - let uu___9 = - let uu___10 = - match (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_only - with - | FStar_Pervasives_Native.None -> no - | FStar_Pervasives_Native.Some lids -> - let uu___11 = - FStar_Compiler_Util.for_some - (FStar_Syntax_Syntax.fv_eq_lid fv) - lids in - yesno uu___11 in - let uu___11 = - let uu___12 = - match (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_attr - with - | FStar_Pervasives_Native.None -> no - | FStar_Pervasives_Native.Some lids -> - let uu___13 = - FStar_Compiler_Util.for_some - (fun at -> - FStar_Compiler_Util.for_some - (fun lid -> - FStar_Syntax_Util.is_fvar - lid at) lids) attrs in - yesno uu___13 in - let uu___13 = - let uu___14 = - match (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_fully - with - | FStar_Pervasives_Native.None -> no - | FStar_Pervasives_Native.Some lids -> - let uu___15 = - FStar_Compiler_Util.for_some - (FStar_Syntax_Syntax.fv_eq_lid fv) - lids in - fullyno uu___15 in - let uu___15 = - let uu___16 = - match (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_qual - with - | FStar_Pervasives_Native.None -> no - | FStar_Pervasives_Native.Some qs -> - let uu___17 = - FStar_Compiler_Util.for_some - (fun q -> - FStar_Compiler_Util.for_some - (fun qual -> - let uu___18 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_qualifier - qual in - uu___18 = q) quals) qs in - yesno uu___17 in - let uu___17 = - let uu___18 = - match (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_namespace - with - | FStar_Pervasives_Native.None -> no - | FStar_Pervasives_Native.Some - namespaces -> - let p = - let uu___19 = - FStar_Syntax_Syntax.lid_of_fv - fv in - FStar_Ident.path_of_lid uu___19 in - let r = - FStar_Compiler_Path.search_forest - (FStar_Class_Ord.ord_eq - FStar_Class_Ord.ord_string) - p namespaces in - yesno r in - [uu___18] in - uu___16 :: uu___17 in - uu___14 :: uu___15 in - uu___12 :: uu___13 in - uu___10 :: uu___11 in - uu___8 :: uu___9 in - comb_or uu___7 in - meets_some_criterion)) - | (uu___, uu___1, uu___2, uu___3, - FStar_Pervasives_Native.Some uu___4, uu___5) -> - (FStar_TypeChecker_Cfg.log_unfolding cfg - (fun uu___7 -> - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_fv fv in - FStar_Compiler_Util.print1 - "should_unfold: Reached a %s with selective unfolding\n" - uu___8); - (let meets_some_criterion = - let uu___7 = - let uu___8 = - if - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.for_extraction - then - let uu___9 = - let uu___10 = - FStar_TypeChecker_Env.lookup_definition_qninfo - [FStar_TypeChecker_Env.Eager_unfolding_only; - FStar_TypeChecker_Env.InliningDelta] - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - qninfo in - FStar_Compiler_Option.isSome uu___10 in - yesno uu___9 - else no in - let uu___9 = - let uu___10 = - match (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_only - with - | FStar_Pervasives_Native.None -> no - | FStar_Pervasives_Native.Some lids -> - let uu___11 = - FStar_Compiler_Util.for_some - (FStar_Syntax_Syntax.fv_eq_lid fv) - lids in - yesno uu___11 in - let uu___11 = - let uu___12 = - match (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_attr - with - | FStar_Pervasives_Native.None -> no - | FStar_Pervasives_Native.Some lids -> - let uu___13 = - FStar_Compiler_Util.for_some - (fun at -> - FStar_Compiler_Util.for_some - (fun lid -> - FStar_Syntax_Util.is_fvar - lid at) lids) attrs in - yesno uu___13 in - let uu___13 = - let uu___14 = - match (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_fully - with - | FStar_Pervasives_Native.None -> no - | FStar_Pervasives_Native.Some lids -> - let uu___15 = - FStar_Compiler_Util.for_some - (FStar_Syntax_Syntax.fv_eq_lid fv) - lids in - fullyno uu___15 in - let uu___15 = - let uu___16 = - match (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_qual - with - | FStar_Pervasives_Native.None -> no - | FStar_Pervasives_Native.Some qs -> - let uu___17 = - FStar_Compiler_Util.for_some - (fun q -> - FStar_Compiler_Util.for_some - (fun qual -> - let uu___18 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_qualifier - qual in - uu___18 = q) quals) qs in - yesno uu___17 in - let uu___17 = - let uu___18 = - match (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_namespace - with - | FStar_Pervasives_Native.None -> no - | FStar_Pervasives_Native.Some - namespaces -> - let p = - let uu___19 = - FStar_Syntax_Syntax.lid_of_fv - fv in - FStar_Ident.path_of_lid uu___19 in - let r = - FStar_Compiler_Path.search_forest - (FStar_Class_Ord.ord_eq - FStar_Class_Ord.ord_string) - p namespaces in - yesno r in - [uu___18] in - uu___16 :: uu___17 in - uu___14 :: uu___15 in - uu___12 :: uu___13 in - uu___10 :: uu___11 in - uu___8 :: uu___9 in - comb_or uu___7 in - meets_some_criterion)) - | (uu___, uu___1, uu___2, uu___3, uu___4, - FStar_Pervasives_Native.Some uu___5) -> - (FStar_TypeChecker_Cfg.log_unfolding cfg - (fun uu___7 -> - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_fv fv in - FStar_Compiler_Util.print1 - "should_unfold: Reached a %s with selective unfolding\n" - uu___8); - (let meets_some_criterion = - let uu___7 = - let uu___8 = - if - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.for_extraction - then - let uu___9 = - let uu___10 = - FStar_TypeChecker_Env.lookup_definition_qninfo - [FStar_TypeChecker_Env.Eager_unfolding_only; - FStar_TypeChecker_Env.InliningDelta] - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - qninfo in - FStar_Compiler_Option.isSome uu___10 in - yesno uu___9 - else no in - let uu___9 = - let uu___10 = - match (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_only - with - | FStar_Pervasives_Native.None -> no - | FStar_Pervasives_Native.Some lids -> - let uu___11 = - FStar_Compiler_Util.for_some - (FStar_Syntax_Syntax.fv_eq_lid fv) - lids in - yesno uu___11 in - let uu___11 = - let uu___12 = - match (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_attr - with - | FStar_Pervasives_Native.None -> no - | FStar_Pervasives_Native.Some lids -> - let uu___13 = - FStar_Compiler_Util.for_some - (fun at -> - FStar_Compiler_Util.for_some - (fun lid -> - FStar_Syntax_Util.is_fvar - lid at) lids) attrs in - yesno uu___13 in - let uu___13 = - let uu___14 = - match (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_fully - with - | FStar_Pervasives_Native.None -> no - | FStar_Pervasives_Native.Some lids -> - let uu___15 = - FStar_Compiler_Util.for_some - (FStar_Syntax_Syntax.fv_eq_lid fv) - lids in - fullyno uu___15 in - let uu___15 = - let uu___16 = - match (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_qual - with - | FStar_Pervasives_Native.None -> no - | FStar_Pervasives_Native.Some qs -> - let uu___17 = - FStar_Compiler_Util.for_some - (fun q -> - FStar_Compiler_Util.for_some - (fun qual -> - let uu___18 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_qualifier - qual in - uu___18 = q) quals) qs in - yesno uu___17 in - let uu___17 = - let uu___18 = - match (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.unfold_namespace - with - | FStar_Pervasives_Native.None -> no - | FStar_Pervasives_Native.Some - namespaces -> - let p = - let uu___19 = - FStar_Syntax_Syntax.lid_of_fv - fv in - FStar_Ident.path_of_lid uu___19 in - let r = - FStar_Compiler_Path.search_forest - (FStar_Class_Ord.ord_eq - FStar_Class_Ord.ord_string) - p namespaces in - yesno r in - [uu___18] in - uu___16 :: uu___17 in - uu___14 :: uu___15 in - uu___12 :: uu___13 in - uu___10 :: uu___11 in - uu___8 :: uu___9 in - comb_or uu___7 in - meets_some_criterion)) - | (uu___, uu___1, uu___2, uu___3, uu___4, uu___5) when - (FStar_Pervasives_Native.uu___is_Some - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.dont_unfold_attr) - && - (FStar_Compiler_List.existsb - (fun fa -> FStar_Syntax_Util.has_attribute attrs fa) - (FStar_Pervasives_Native.__proj__Some__item__v - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.dont_unfold_attr)) - -> - (FStar_TypeChecker_Cfg.log_unfolding cfg - (fun uu___7 -> - FStar_Compiler_Util.print_string - " >> forbidden by attribute, not unfolding\n"); - no) - | uu___ -> default_unfolding ()) in - FStar_TypeChecker_Cfg.log_unfolding cfg - (fun uu___1 -> - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_fv fv in - let uu___3 = - let uu___4 = FStar_Syntax_Syntax.range_of_fv fv in - FStar_Class_Show.show - FStar_Compiler_Range_Ops.showable_range uu___4 in - let uu___4 = - FStar_Class_Show.show - (FStar_Class_Show.show_tuple3 - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool)) res in - FStar_Compiler_Util.print3 - "should_unfold: For %s (%s), unfolding res = %s\n" uu___2 - uu___3 uu___4); - (let r = - match res with - | (false, uu___1, uu___2) -> Should_unfold_no - | (true, false, false) -> Should_unfold_yes - | (true, true, false) -> Should_unfold_fully - | (true, false, true) -> Should_unfold_reify - | uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Show.show - (FStar_Class_Show.show_tuple3 - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool)) res in - FStar_Compiler_Util.format1 - "Unexpected unfolding result: %s" uu___3 in - failwith uu___2 in - (let uu___2 = - ((((FStar_Pervasives_Native.uu___is_Some - (cfg.FStar_TypeChecker_Cfg.steps).FStar_TypeChecker_Cfg.dont_unfold_attr) - && - (let uu___3 = FStar_Options.no_plugins () in - Prims.op_Negation uu___3)) - && (r <> Should_unfold_no)) - && - (FStar_Compiler_Util.for_some - (FStar_Syntax_Util.is_fvar FStar_Parser_Const.plugin_attr) - attrs)) - && - (let uu___3 = - FStar_Compiler_Effect.op_Bang plugin_unfold_warn_ctr in - uu___3 > Prims.int_zero) in - if uu___2 - then - let msg = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_fv fv in - FStar_Compiler_Util.format1 - "Unfolding name which is marked as a plugin: %s" uu___3 in - (FStar_Errors.log_issue FStar_Class_HasRange.hasRange_range - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.p - FStar_Errors_Codes.Warning_UnfoldPlugin () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic msg); - (let uu___4 = - let uu___5 = - FStar_Compiler_Effect.op_Bang plugin_unfold_warn_ctr in - uu___5 - Prims.int_one in - FStar_Compiler_Effect.op_Colon_Equals plugin_unfold_warn_ctr - uu___4)) - else ()); - r) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_PatternUtils.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_PatternUtils.ml deleted file mode 100644 index 62aebe3cdb7..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_PatternUtils.ml +++ /dev/null @@ -1,468 +0,0 @@ -open Prims -type lcomp_with_binder = - (FStar_Syntax_Syntax.bv FStar_Pervasives_Native.option * - FStar_TypeChecker_Common.lcomp) -let (dbg_Patterns : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Patterns" -let rec (elaborate_pat : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.pat -> FStar_Syntax_Syntax.pat) - = - fun env -> - fun p -> - let maybe_dot inaccessible a r = - if inaccessible - then - FStar_Syntax_Syntax.withinfo - (FStar_Syntax_Syntax.Pat_dot_term FStar_Pervasives_Native.None) r - else FStar_Syntax_Syntax.withinfo (FStar_Syntax_Syntax.Pat_var a) r in - match p.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_cons - ({ FStar_Syntax_Syntax.fv_name = uu___; - FStar_Syntax_Syntax.fv_qual = FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Unresolved_constructor uu___1);_}, - uu___2, uu___3) - -> p - | FStar_Syntax_Syntax.Pat_cons (fv, us_opt, pats) -> - let pats1 = - FStar_Compiler_List.map - (fun uu___ -> - match uu___ with - | (p1, imp) -> - let uu___1 = elaborate_pat env p1 in (uu___1, imp)) pats in - let uu___ = - FStar_TypeChecker_Env.lookup_datacon env - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - (match uu___ with - | (uu___1, t) -> - let uu___2 = FStar_Syntax_Util.arrow_formals t in - (match uu___2 with - | (f, uu___3) -> - let rec aux formals pats2 = - match (formals, pats2) with - | ([], []) -> [] - | ([], uu___4::uu___5) -> - FStar_Errors.raise_error - FStar_Ident.hasrange_lident - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - FStar_Errors_Codes.Fatal_TooManyPatternArguments - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic "Too many pattern arguments") - | (uu___4::uu___5, []) -> - FStar_Compiler_List.map - (fun fml -> - let uu___6 = - ((fml.FStar_Syntax_Syntax.binder_bv), - (fml.FStar_Syntax_Syntax.binder_qual)) in - match uu___6 with - | (t1, imp) -> - (match imp with - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Implicit - inaccessible) -> - let a = - let uu___7 = - let uu___8 = - FStar_Syntax_Syntax.range_of_bv - t1 in - FStar_Pervasives_Native.Some - uu___8 in - FStar_Syntax_Syntax.new_bv uu___7 - FStar_Syntax_Syntax.tun in - let r = - FStar_Ident.range_of_lid - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - let uu___7 = - maybe_dot inaccessible a r in - (uu___7, true) - | uu___7 -> - let uu___8 = - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_pat - p in - FStar_Compiler_Util.format1 - "Insufficient pattern arguments (%s)" - uu___9 in - FStar_Errors.raise_error - FStar_Ident.hasrange_lident - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - FStar_Errors_Codes.Fatal_InsufficientPatternArguments - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___8))) formals - | (f1::formals', (p1, p_imp)::pats') -> - (match ((f1.FStar_Syntax_Syntax.binder_bv), - (f1.FStar_Syntax_Syntax.binder_qual)) - with - | (uu___4, FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Implicit inaccessible)) - when inaccessible && p_imp -> - (match p1.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_dot_term uu___5 -> - let uu___6 = aux formals' pats' in - (p1, true) :: uu___6 - | FStar_Syntax_Syntax.Pat_var v when - let uu___5 = - FStar_Ident.string_of_id - v.FStar_Syntax_Syntax.ppname in - uu___5 = FStar_Ident.reserved_prefix -> - let a = - FStar_Syntax_Syntax.new_bv - (FStar_Pervasives_Native.Some - (p1.FStar_Syntax_Syntax.p)) - FStar_Syntax_Syntax.tun in - let p2 = - let uu___5 = - FStar_Ident.range_of_lid - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - maybe_dot inaccessible a uu___5 in - let uu___5 = aux formals' pats' in - (p2, true) :: uu___5 - | uu___5 -> - let uu___6 = - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_pat p1 in - FStar_Compiler_Util.format1 - "This pattern (%s) binds an inaccesible argument; use a wildcard ('_') pattern" - uu___7 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - p1.FStar_Syntax_Syntax.p - FStar_Errors_Codes.Fatal_InsufficientPatternArguments - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___6)) - | (uu___4, FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Implicit uu___5)) when - p_imp -> - let uu___6 = aux formals' pats' in (p1, true) - :: uu___6 - | (uu___4, FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Implicit inaccessible)) -> - let a = - FStar_Syntax_Syntax.new_bv - (FStar_Pervasives_Native.Some - (p1.FStar_Syntax_Syntax.p)) - FStar_Syntax_Syntax.tun in - let p2 = - let uu___5 = - FStar_Ident.range_of_lid - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - maybe_dot inaccessible a uu___5 in - let uu___5 = aux formals' pats2 in (p2, true) - :: uu___5 - | (uu___4, imp) -> - let uu___5 = - let uu___6 = - FStar_Syntax_Syntax.is_bqual_implicit imp in - (p1, uu___6) in - let uu___6 = aux formals' pats' in uu___5 :: - uu___6) in - let uu___4 = - let uu___5 = - let uu___6 = aux f pats1 in (fv, us_opt, uu___6) in - FStar_Syntax_Syntax.Pat_cons uu___5 in - { - FStar_Syntax_Syntax.v = uu___4; - FStar_Syntax_Syntax.p = (p.FStar_Syntax_Syntax.p) - })) - | uu___ -> p -exception Raw_pat_cannot_be_translated -let (uu___is_Raw_pat_cannot_be_translated : Prims.exn -> Prims.bool) = - fun projectee -> - match projectee with - | Raw_pat_cannot_be_translated -> true - | uu___ -> false -let (raw_pat_as_exp : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.pat -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.bv Prims.list) - FStar_Pervasives_Native.option) - = - fun env -> - fun p -> - let rec aux bs p1 = - match p1.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_constant c -> - let e = - match c with - | FStar_Const.Const_int (repr, FStar_Pervasives_Native.Some sw) - -> - FStar_ToSyntax_ToSyntax.desugar_machine_integer - env.FStar_TypeChecker_Env.dsenv repr sw - p1.FStar_Syntax_Syntax.p - | uu___ -> - FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_constant c) - p1.FStar_Syntax_Syntax.p in - (e, bs) - | FStar_Syntax_Syntax.Pat_dot_term eopt -> - (match eopt with - | FStar_Pervasives_Native.None -> - FStar_Compiler_Effect.raise Raw_pat_cannot_be_translated - | FStar_Pervasives_Native.Some e -> - let uu___ = FStar_Syntax_Subst.compress e in (uu___, bs)) - | FStar_Syntax_Syntax.Pat_var x -> - let uu___ = - FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_name x) - p1.FStar_Syntax_Syntax.p in - (uu___, (x :: bs)) - | FStar_Syntax_Syntax.Pat_cons (fv, us_opt, pats) -> - let uu___ = - FStar_Compiler_List.fold_right - (fun uu___1 -> - fun uu___2 -> - match (uu___1, uu___2) with - | ((p2, i), (args, bs1)) -> - let uu___3 = aux bs1 p2 in - (match uu___3 with - | (ep, bs2) -> - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Syntax.as_aqual_implicit i in - (ep, uu___6) in - uu___5 :: args in - (uu___4, bs2))) pats ([], bs) in - (match uu___ with - | (args, bs1) -> - let hd = FStar_Syntax_Syntax.fv_to_tm fv in - let hd1 = - match us_opt with - | FStar_Pervasives_Native.None -> hd - | FStar_Pervasives_Native.Some us -> - FStar_Syntax_Syntax.mk_Tm_uinst hd us in - let e = - FStar_Syntax_Syntax.mk_Tm_app hd1 args - p1.FStar_Syntax_Syntax.p in - (e, bs1)) in - try - (fun uu___ -> - match () with - | () -> - let uu___1 = aux [] p in FStar_Pervasives_Native.Some uu___1) - () - with | Raw_pat_cannot_be_translated -> FStar_Pervasives_Native.None -let (pat_as_exp : - Prims.bool -> - Prims.bool -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.pat -> - (FStar_Syntax_Syntax.bv Prims.list * FStar_Syntax_Syntax.term * - FStar_TypeChecker_Common.guard_t * FStar_Syntax_Syntax.pat)) - = - fun introduce_bv_uvars -> - fun inst_pat_cons_univs -> - fun env -> - fun p -> - let intro_bv env1 x = - if Prims.op_Negation introduce_bv_uvars - then - ({ - FStar_Syntax_Syntax.ppname = (x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = (x.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = FStar_Syntax_Syntax.tun - }, FStar_TypeChecker_Env.trivial_guard, env1) - else - (let uu___1 = FStar_Syntax_Util.type_u () in - match uu___1 with - | (t, uu___2) -> - let uu___3 = - let uu___4 = FStar_Syntax_Syntax.range_of_bv x in - FStar_TypeChecker_Env.new_implicit_var_aux - "pattern bv type" uu___4 env1 t - (FStar_Syntax_Syntax.Allow_untyped "pattern bv type") - FStar_Pervasives_Native.None false in - (match uu___3 with - | (t_x, uu___4, guard) -> - let x1 = - { - FStar_Syntax_Syntax.ppname = - (x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (x.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = t_x - } in - let uu___5 = FStar_TypeChecker_Env.push_bv env1 x1 in - (x1, guard, uu___5))) in - let rec pat_as_arg_with_env env1 p1 = - match p1.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_constant c -> - let e = - match c with - | FStar_Const.Const_int - (repr, FStar_Pervasives_Native.Some sw) -> - FStar_ToSyntax_ToSyntax.desugar_machine_integer - env1.FStar_TypeChecker_Env.dsenv repr sw - p1.FStar_Syntax_Syntax.p - | uu___ -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_constant c) - p1.FStar_Syntax_Syntax.p in - ([], [], [], env1, e, FStar_TypeChecker_Common.trivial_guard, - p1) - | FStar_Syntax_Syntax.Pat_dot_term eopt -> - (match eopt with - | FStar_Pervasives_Native.None -> - ((let uu___1 = - FStar_Compiler_Effect.op_Bang dbg_Patterns in - if uu___1 - then - (if - Prims.op_Negation - env1.FStar_TypeChecker_Env.phase1 - then - let uu___2 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_pat p1 in - FStar_Compiler_Util.print1 - "Found a non-instantiated dot pattern in phase2 (%s)\n" - uu___2 - else ()) - else ()); - (let uu___1 = FStar_Syntax_Util.type_u () in - match uu___1 with - | (k, uu___2) -> - let uu___3 = - FStar_TypeChecker_Env.new_implicit_var_aux - "pat_dot_term type" p1.FStar_Syntax_Syntax.p - env1 k - (FStar_Syntax_Syntax.Allow_ghost - "pat dot term type") - FStar_Pervasives_Native.None false in - (match uu___3 with - | (t, uu___4, g) -> - let uu___5 = - FStar_TypeChecker_Env.new_implicit_var_aux - "pat_dot_term" p1.FStar_Syntax_Syntax.p - env1 t - (FStar_Syntax_Syntax.Allow_ghost - "pat dot term") - FStar_Pervasives_Native.None false in - (match uu___5 with - | (e, uu___6, g') -> - let p2 = - { - FStar_Syntax_Syntax.v = - (FStar_Syntax_Syntax.Pat_dot_term - (FStar_Pervasives_Native.Some e)); - FStar_Syntax_Syntax.p = - (p1.FStar_Syntax_Syntax.p) - } in - let uu___7 = - FStar_TypeChecker_Common.conj_guard g - g' in - ([], [], [], env1, e, uu___7, p2))))) - | FStar_Pervasives_Native.Some e -> - ([], [], [], env1, e, - FStar_TypeChecker_Env.trivial_guard, p1)) - | FStar_Syntax_Syntax.Pat_var x -> - let uu___ = intro_bv env1 x in - (match uu___ with - | (x1, g, env2) -> - let e = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_name x1) - p1.FStar_Syntax_Syntax.p in - ([x1], [x1], [], env2, e, g, p1)) - | FStar_Syntax_Syntax.Pat_cons (fv, us_opt, pats) -> - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun uu___2 -> - match (uu___1, uu___2) with - | ((b, a, w, env2, args, guard, pats1), (p2, imp)) - -> - let uu___3 = pat_as_arg_with_env env2 p2 in - (match uu___3 with - | (b', a', w', env3, te, guard', pat) -> - let arg = - if imp - then FStar_Syntax_Syntax.iarg te - else FStar_Syntax_Syntax.as_arg te in - let uu___4 = - FStar_TypeChecker_Common.conj_guard guard - guard' in - ((b' :: b), (a' :: a), (w' :: w), env3, - (arg :: args), uu___4, ((pat, imp) :: - pats1)))) - ([], [], [], env1, [], - FStar_TypeChecker_Common.trivial_guard, []) pats in - (match uu___ with - | (b, a, w, env2, args, guard, pats1) -> - let inst_head hd us_opt1 = - match us_opt1 with - | FStar_Pervasives_Native.None -> hd - | FStar_Pervasives_Native.Some us -> - FStar_Syntax_Syntax.mk_Tm_uinst hd us in - let uu___1 = - let hd = FStar_Syntax_Syntax.fv_to_tm fv in - if - (Prims.op_Negation inst_pat_cons_univs) || - (FStar_Pervasives_Native.uu___is_Some us_opt) - then - let uu___2 = inst_head hd us_opt in (uu___2, us_opt) - else - (let uu___3 = - let uu___4 = FStar_Syntax_Syntax.lid_of_fv fv in - FStar_TypeChecker_Env.lookup_datacon env2 uu___4 in - match uu___3 with - | (us, uu___4) -> - if - (FStar_Compiler_List.length us) = - Prims.int_zero - then (hd, (FStar_Pervasives_Native.Some [])) - else - (let uu___6 = - FStar_Syntax_Syntax.mk_Tm_uinst hd us in - (uu___6, (FStar_Pervasives_Native.Some us)))) in - (match uu___1 with - | (hd, us_opt1) -> - let e = - FStar_Syntax_Syntax.mk_Tm_app hd - (FStar_Compiler_List.rev args) - p1.FStar_Syntax_Syntax.p in - ((FStar_Compiler_List.flatten - (FStar_Compiler_List.rev b)), - (FStar_Compiler_List.flatten - (FStar_Compiler_List.rev a)), - (FStar_Compiler_List.flatten - (FStar_Compiler_List.rev w)), env2, e, guard, - { - FStar_Syntax_Syntax.v = - (FStar_Syntax_Syntax.Pat_cons - (fv, us_opt1, - (FStar_Compiler_List.rev pats1))); - FStar_Syntax_Syntax.p = - (p1.FStar_Syntax_Syntax.p) - }))) in - let one_pat env1 p1 = - let p2 = elaborate_pat env1 p1 in - let uu___ = pat_as_arg_with_env env1 p2 in - match uu___ with - | (b, a, w, env2, arg, guard, p3) -> - let uu___1 = - FStar_Compiler_Util.find_dup FStar_Syntax_Syntax.bv_eq b in - (match uu___1 with - | FStar_Pervasives_Native.Some x -> - let m = - FStar_Class_Show.show FStar_Syntax_Print.showable_bv x in - let uu___2 = - FStar_Compiler_Util.format1 - "The pattern variable \"%s\" was used more than once" - m in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - p3.FStar_Syntax_Syntax.p - FStar_Errors_Codes.Fatal_NonLinearPatternVars () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2) - | uu___2 -> (b, a, w, arg, guard, p3)) in - let uu___ = one_pat env p in - match uu___ with - | (b, uu___1, uu___2, tm, guard, p1) -> (b, tm, guard, p1) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Positivity.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Positivity.ml deleted file mode 100644 index 1e3a1eb7f89..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Positivity.ml +++ /dev/null @@ -1,1717 +0,0 @@ -open Prims -let (dbg_Positivity : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Positivity" -let (debug_positivity : - FStar_TypeChecker_Env.env_t -> (unit -> Prims.string) -> unit) = - fun env -> - fun msg -> - let uu___ = FStar_Compiler_Effect.op_Bang dbg_Positivity in - if uu___ - then - let uu___1 = - let uu___2 = let uu___3 = msg () in Prims.strcat uu___3 "\n" in - Prims.strcat "Positivity::" uu___2 in - FStar_Compiler_Util.print_string uu___1 - else () -let (string_of_lids : FStar_Ident.lident Prims.list -> Prims.string) = - fun lids -> - let uu___ = FStar_Compiler_List.map FStar_Ident.string_of_lid lids in - FStar_Compiler_String.concat ", " uu___ -let (normalize : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun env -> - fun t -> - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.HNF; - FStar_TypeChecker_Env.Weak; - FStar_TypeChecker_Env.Iota; - FStar_TypeChecker_Env.Exclude FStar_TypeChecker_Env.Zeta; - FStar_TypeChecker_Env.UnfoldUntil FStar_Syntax_Syntax.delta_constant] - env t -let (apply_constr_arrow : - FStar_Ident.lident -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.arg Prims.list -> FStar_Syntax_Syntax.term) - = - fun dlid -> - fun dt -> - fun all_params -> - let rec aux t args = - let uu___ = - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress t in - uu___2.FStar_Syntax_Syntax.n in - (uu___1, args) in - match uu___ with - | (uu___1, []) -> FStar_Syntax_Util.canon_arrow t - | (FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = b::bs; - FStar_Syntax_Syntax.comp = c;_}, - a::args1) -> - let tail = - match bs with - | [] -> FStar_Syntax_Util.comp_result c - | uu___1 -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 = bs; - FStar_Syntax_Syntax.comp = c - }) t.FStar_Syntax_Syntax.pos in - let uu___1 = FStar_Syntax_Subst.open_term_1 b tail in - (match uu___1 with - | (b1, tail1) -> - let tail2 = - FStar_Syntax_Subst.subst - [FStar_Syntax_Syntax.NT - ((b1.FStar_Syntax_Syntax.binder_bv), - (FStar_Pervasives_Native.fst a))] tail1 in - aux tail2 args1) - | uu___1 -> - let uu___2 = FStar_Ident.range_of_lid dlid in - let uu___3 = - let uu___4 = FStar_Syntax_Print.args_to_string all_params in - let uu___5 = - FStar_Class_Show.show FStar_Ident.showable_lident dlid in - let uu___6 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term dt in - FStar_Compiler_Util.format3 - "Unexpected application of type parameters %s to a data constructor %s : %s" - uu___4 uu___5 uu___6 in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range - uu___2 - FStar_Errors_Codes.Error_InductiveTypeNotSatisfyPositivityCondition - () (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___3) in - aux dt all_params -let (ty_occurs_in : - FStar_Ident.lident -> FStar_Syntax_Syntax.term -> Prims.bool) = - fun ty_lid -> - fun t -> - let uu___ = FStar_Syntax_Free.fvars t in - FStar_Class_Setlike.mem () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset FStar_Syntax_Syntax.ord_fv)) - ty_lid (Obj.magic uu___) -let rec (term_as_fv_or_name : - FStar_Syntax_Syntax.term -> - ((FStar_Syntax_Syntax.fv * FStar_Syntax_Syntax.universes), - FStar_Syntax_Syntax.bv) FStar_Pervasives.either - FStar_Pervasives_Native.option) - = - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_name x -> - FStar_Pervasives_Native.Some (FStar_Pervasives.Inr x) - | FStar_Syntax_Syntax.Tm_fvar fv -> - FStar_Pervasives_Native.Some (FStar_Pervasives.Inl (fv, [])) - | FStar_Syntax_Syntax.Tm_uinst (t1, us) -> - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress t1 in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - FStar_Pervasives_Native.Some (FStar_Pervasives.Inl (fv, us)) - | uu___2 -> - failwith "term_as_fv_or_name: impossible non fvar in uinst") - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t1; FStar_Syntax_Syntax.asc = uu___1; - FStar_Syntax_Syntax.eff_opt = uu___2;_} - -> term_as_fv_or_name t1 - | uu___1 -> FStar_Pervasives_Native.None -let (open_sig_inductive_typ : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.sigelt -> - (FStar_TypeChecker_Env.env * (FStar_Ident.lident * - FStar_Syntax_Syntax.univ_name Prims.list * - FStar_Syntax_Syntax.binders))) - = - fun env -> - fun se -> - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = lid; FStar_Syntax_Syntax.us = ty_us; - FStar_Syntax_Syntax.params = ty_params; - FStar_Syntax_Syntax.num_uniform_params = uu___; - FStar_Syntax_Syntax.t = uu___1; - FStar_Syntax_Syntax.mutuals = uu___2; - FStar_Syntax_Syntax.ds = uu___3; - FStar_Syntax_Syntax.injective_type_params = uu___4;_} - -> - let uu___5 = FStar_Syntax_Subst.univ_var_opening ty_us in - (match uu___5 with - | (ty_usubst, ty_us1) -> - let env1 = FStar_TypeChecker_Env.push_univ_vars env ty_us1 in - let ty_params1 = - FStar_Syntax_Subst.subst_binders ty_usubst ty_params in - let ty_params2 = FStar_Syntax_Subst.open_binders ty_params1 in - let env2 = FStar_TypeChecker_Env.push_binders env1 ty_params2 in - (env2, (lid, ty_us1, ty_params2))) - | uu___ -> failwith "Impossible!" -let (name_as_fv_in_t : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.bv -> (FStar_Syntax_Syntax.term * FStar_Ident.lident)) - = - fun t -> - fun bv -> - let fv_lid = - let uu___ = - let uu___1 = FStar_Ident.string_of_id bv.FStar_Syntax_Syntax.ppname in - FStar_Ident.lid_of_str uu___1 in - let uu___1 = FStar_Syntax_Syntax.range_of_bv bv in - FStar_Ident.set_lid_range uu___ uu___1 in - let fv = FStar_Syntax_Syntax.tconst fv_lid in - let t1 = FStar_Syntax_Subst.subst [FStar_Syntax_Syntax.NT (bv, fv)] t in - (t1, fv_lid) -let rec min_l : - 'a . Prims.int -> 'a Prims.list -> ('a -> Prims.int) -> Prims.int = - fun def -> - fun l -> - fun f -> - match l with - | [] -> def - | hd::tl -> - let uu___ = f hd in - let uu___1 = min_l def tl f in Prims.min uu___ uu___1 -let (max_uniformly_recursive_parameters : - FStar_TypeChecker_Env.env_t -> - FStar_Ident.lident Prims.list -> - FStar_Syntax_Syntax.bv Prims.list -> - FStar_Syntax_Syntax.term -> Prims.int) - = - fun env -> - fun mutuals -> - fun params -> - fun ty -> - let max_matching_prefix longer shorter f = - let rec aux n ls ms = - match (ls, ms) with - | (uu___, []) -> FStar_Pervasives_Native.Some n - | (l::ls1, m::ms1) -> - let uu___ = f l m in - if uu___ - then aux (n + Prims.int_one) ls1 ms1 - else FStar_Pervasives_Native.Some n - | uu___ -> FStar_Pervasives_Native.None in - aux Prims.int_zero longer shorter in - let ty1 = normalize env ty in - let n_params = FStar_Compiler_List.length params in - let compare_name_bv x y = - let uu___ = - let uu___1 = - FStar_Syntax_Subst.compress (FStar_Pervasives_Native.fst x) in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_name x1 -> - FStar_Syntax_Syntax.bv_eq x1 y - | uu___1 -> false in - let min_l1 f l = min_l n_params f l in - let params_to_string uu___ = - let uu___1 = - FStar_Compiler_List.map - (FStar_Class_Show.show FStar_Syntax_Print.showable_bv) params in - FStar_Compiler_String.concat ", " uu___1 in - debug_positivity env - (fun uu___1 -> - let uu___2 = params_to_string () in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term ty1 in - FStar_Compiler_Util.format2 - "max_uniformly_recursive_parameters? params=%s in %s" uu___2 - uu___3); - (let rec aux ty2 = - debug_positivity env - (fun uu___2 -> - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - ty2 in - FStar_Compiler_Util.format1 - "max_uniformly_recursive_parameters.aux? %s" uu___3); - (let uu___2 = - FStar_Compiler_List.for_all - (fun mutual -> - let uu___3 = ty_occurs_in mutual ty2 in - Prims.op_Negation uu___3) mutuals in - if uu___2 - then n_params - else - (let uu___4 = - let uu___5 = FStar_Syntax_Subst.compress ty2 in - uu___5.FStar_Syntax_Syntax.n in - match uu___4 with - | FStar_Syntax_Syntax.Tm_name uu___5 -> n_params - | FStar_Syntax_Syntax.Tm_fvar uu___5 -> n_params - | FStar_Syntax_Syntax.Tm_uinst uu___5 -> n_params - | FStar_Syntax_Syntax.Tm_type uu___5 -> n_params - | FStar_Syntax_Syntax.Tm_constant uu___5 -> n_params - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x; - FStar_Syntax_Syntax.phi = f;_} - -> - let uu___5 = aux x.FStar_Syntax_Syntax.sort in - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = FStar_Syntax_Syntax.mk_binder x in - [uu___9] in - FStar_Syntax_Subst.open_term uu___8 f in - match uu___7 with | (uu___8, f1) -> aux f1 in - Prims.min uu___5 uu___6 - | FStar_Syntax_Syntax.Tm_app uu___5 -> - let uu___6 = FStar_Syntax_Util.head_and_args ty2 in - (match uu___6 with - | (head, args) -> - let uu___7 = - let uu___8 = FStar_Syntax_Util.un_uinst head in - uu___8.FStar_Syntax_Syntax.n in - (match uu___7 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - let uu___8 = - FStar_Compiler_List.existsML - (FStar_Syntax_Syntax.fv_eq_lid fv) mutuals in - if uu___8 - then - (debug_positivity env - (fun uu___10 -> - let uu___11 = params_to_string () in - let uu___12 = - FStar_Syntax_Print.args_to_string - args in - FStar_Compiler_Util.format2 - "Searching for max matching prefix of params=%s in args=%s" - uu___11 uu___12); - (let uu___10 = - max_matching_prefix args params - compare_name_bv in - match uu___10 with - | FStar_Pervasives_Native.None -> - Prims.int_zero - | FStar_Pervasives_Native.Some n -> n)) - else - min_l1 args - (fun uu___10 -> - match uu___10 with - | (arg, uu___11) -> aux arg) - | uu___8 -> - let uu___9 = aux head in - let uu___10 = - min_l1 args - (fun uu___11 -> - match uu___11 with - | (arg, uu___12) -> aux arg) in - Prims.min uu___9 uu___10)) - | FStar_Syntax_Syntax.Tm_abs uu___5 -> - let uu___6 = FStar_Syntax_Util.abs_formals ty2 in - (match uu___6 with - | (bs, body, uu___7) -> - let uu___8 = - min_l1 bs - (fun b -> - aux - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort) in - let uu___9 = aux body in Prims.min uu___8 uu___9) - | FStar_Syntax_Syntax.Tm_arrow uu___5 -> - let uu___6 = FStar_Syntax_Util.arrow_formals ty2 in - (match uu___6 with - | (bs, r) -> - let uu___7 = - min_l1 bs - (fun b -> - aux - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort) in - let uu___8 = aux r in Prims.min uu___7 uu___8) - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = scrutinee; - FStar_Syntax_Syntax.ret_opt = uu___5; - FStar_Syntax_Syntax.brs = branches; - FStar_Syntax_Syntax.rc_opt1 = uu___6;_} - -> - let uu___7 = aux scrutinee in - let uu___8 = - min_l1 branches - (fun uu___9 -> - match uu___9 with - | (p, uu___10, t) -> - let bs = - let uu___11 = FStar_Syntax_Syntax.pat_bvs p in - FStar_Compiler_List.map - FStar_Syntax_Syntax.mk_binder uu___11 in - let uu___11 = - FStar_Syntax_Subst.open_term bs t in - (match uu___11 with | (bs1, t1) -> aux t1)) in - Prims.min uu___7 uu___8 - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t; - FStar_Syntax_Syntax.meta = uu___5;_} - -> aux t - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t; - FStar_Syntax_Syntax.asc = uu___5; - FStar_Syntax_Syntax.eff_opt = uu___6;_} - -> aux t - | uu___5 -> Prims.int_zero)) in - let res = aux ty1 in - debug_positivity env - (fun uu___2 -> - let uu___3 = params_to_string () in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term ty1 in - FStar_Compiler_Util.format3 - "result: max_uniformly_recursive_parameters(params=%s in %s) = %s" - uu___3 uu___4 (Prims.string_of_int res)); - res) -let (mark_uniform_type_parameters : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.sigelt -> FStar_Syntax_Syntax.sigelt) - = - fun env -> - fun sig1 -> - let mark_tycon_parameters tc datas = - let uu___ = tc.FStar_Syntax_Syntax.sigel in - match uu___ with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = tc_lid; FStar_Syntax_Syntax.us = us; - FStar_Syntax_Syntax.params = ty_param_binders; - FStar_Syntax_Syntax.num_uniform_params = uu___1; - FStar_Syntax_Syntax.t = t; - FStar_Syntax_Syntax.mutuals = mutuals; - FStar_Syntax_Syntax.ds = data_lids; - FStar_Syntax_Syntax.injective_type_params = - injective_type_params;_} - -> - let uu___2 = open_sig_inductive_typ env tc in - (match uu___2 with - | (env1, (tc_lid1, us1, ty_params)) -> - let uu___3 = FStar_Syntax_Util.args_of_binders ty_params in - (match uu___3 with - | (uu___4, ty_param_args) -> - let datacon_fields = - FStar_Compiler_List.filter_map - (fun data -> - match data.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = d_lid; - FStar_Syntax_Syntax.us1 = d_us; - FStar_Syntax_Syntax.t1 = dt; - FStar_Syntax_Syntax.ty_lid = tc_lid'; - FStar_Syntax_Syntax.num_ty_params = uu___5; - FStar_Syntax_Syntax.mutuals1 = uu___6; - FStar_Syntax_Syntax.injective_type_params1 - = uu___7;_} - -> - let uu___8 = - FStar_Ident.lid_equals tc_lid1 tc_lid' in - if uu___8 - then - let dt1 = - let uu___9 = - let uu___10 = - FStar_Compiler_List.map - (fun uu___11 -> - FStar_Syntax_Syntax.U_name - uu___11) us1 in - FStar_TypeChecker_Env.mk_univ_subst - d_us uu___10 in - FStar_Syntax_Subst.subst uu___9 dt in - let uu___9 = - let uu___10 = - let uu___11 = - apply_constr_arrow d_lid dt1 - ty_param_args in - FStar_Syntax_Util.arrow_formals - uu___11 in - FStar_Pervasives_Native.fst uu___10 in - FStar_Pervasives_Native.Some uu___9 - else FStar_Pervasives_Native.None - | uu___5 -> FStar_Pervasives_Native.None) datas in - let ty_param_bvs = - FStar_Compiler_List.map - (fun b -> b.FStar_Syntax_Syntax.binder_bv) - ty_params in - let n_params = FStar_Compiler_List.length ty_params in - let min_l1 f l = min_l n_params f l in - let max_uniform_prefix = - min_l1 datacon_fields - (fun fields_of_one_datacon -> - min_l1 fields_of_one_datacon - (fun field -> - max_uniformly_recursive_parameters env1 - mutuals ty_param_bvs - (field.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort)) in - (if max_uniform_prefix < n_params - then - (let uu___6 = - FStar_Compiler_List.splitAt max_uniform_prefix - ty_param_binders in - match uu___6 with - | (uu___7, non_uniform_params) -> - FStar_Compiler_List.iter - (fun param -> - if - param.FStar_Syntax_Syntax.binder_positivity - = - (FStar_Pervasives_Native.Some - FStar_Syntax_Syntax.BinderStrictlyPositive) - then - let uu___8 = - FStar_Syntax_Syntax.range_of_bv - param.FStar_Syntax_Syntax.binder_bv in - let uu___9 = - let uu___10 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_binder - param in - FStar_Compiler_Util.format1 - "Binder %s is marked strictly positive, but it is not uniformly recursive" - uu___10 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - uu___8 - FStar_Errors_Codes.Error_InductiveTypeNotSatisfyPositivityCondition - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___9) - else ()) non_uniform_params) - else (); - (let sigel = - FStar_Syntax_Syntax.Sig_inductive_typ - { - FStar_Syntax_Syntax.lid = tc_lid1; - FStar_Syntax_Syntax.us = us1; - FStar_Syntax_Syntax.params = ty_param_binders; - FStar_Syntax_Syntax.num_uniform_params = - (FStar_Pervasives_Native.Some - max_uniform_prefix); - FStar_Syntax_Syntax.t = t; - FStar_Syntax_Syntax.mutuals = mutuals; - FStar_Syntax_Syntax.ds = data_lids; - FStar_Syntax_Syntax.injective_type_params = - injective_type_params - } in - { - FStar_Syntax_Syntax.sigel = sigel; - FStar_Syntax_Syntax.sigrng = - (tc.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (tc.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (tc.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (tc.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (tc.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (tc.FStar_Syntax_Syntax.sigopts) - })))) in - match sig1.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_bundle - { FStar_Syntax_Syntax.ses = ses; FStar_Syntax_Syntax.lids = lids;_} - -> - let uu___ = - FStar_Compiler_List.partition - (fun se -> - FStar_Syntax_Syntax.uu___is_Sig_inductive_typ - se.FStar_Syntax_Syntax.sigel) ses in - (match uu___ with - | (tcs, datas) -> - let tcs1 = - FStar_Compiler_List.map - (fun tc -> mark_tycon_parameters tc datas) tcs in - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_bundle - { - FStar_Syntax_Syntax.ses = - (FStar_List_Tot_Base.op_At tcs1 datas); - FStar_Syntax_Syntax.lids = lids - }); - FStar_Syntax_Syntax.sigrng = - (sig1.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (sig1.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (sig1.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (sig1.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (sig1.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (sig1.FStar_Syntax_Syntax.sigopts) - }) - | uu___ -> sig1 -let (may_be_an_arity : - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.term -> Prims.bool) = - fun env -> - fun t -> - let t1 = normalize env t in - let rec aux t2 = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t2 in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_name uu___1 -> false - | FStar_Syntax_Syntax.Tm_constant uu___1 -> false - | FStar_Syntax_Syntax.Tm_abs uu___1 -> false - | FStar_Syntax_Syntax.Tm_lazy uu___1 -> false - | FStar_Syntax_Syntax.Tm_quoted uu___1 -> false - | FStar_Syntax_Syntax.Tm_fvar uu___1 -> - let uu___2 = FStar_Syntax_Util.head_and_args t2 in - (match uu___2 with - | (head, args) -> - let uu___3 = - let uu___4 = FStar_Syntax_Util.un_uinst head in - uu___4.FStar_Syntax_Syntax.n in - (match uu___3 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - let uu___4 = - FStar_TypeChecker_Env.lookup_sigelt env - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - (match uu___4 with - | FStar_Pervasives_Native.None -> true - | FStar_Pervasives_Native.Some se -> - (match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_let uu___5 -> true - | uu___5 -> false)) - | uu___4 -> true)) - | FStar_Syntax_Syntax.Tm_uinst uu___1 -> - let uu___2 = FStar_Syntax_Util.head_and_args t2 in - (match uu___2 with - | (head, args) -> - let uu___3 = - let uu___4 = FStar_Syntax_Util.un_uinst head in - uu___4.FStar_Syntax_Syntax.n in - (match uu___3 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - let uu___4 = - FStar_TypeChecker_Env.lookup_sigelt env - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - (match uu___4 with - | FStar_Pervasives_Native.None -> true - | FStar_Pervasives_Native.Some se -> - (match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_let uu___5 -> true - | uu___5 -> false)) - | uu___4 -> true)) - | FStar_Syntax_Syntax.Tm_app uu___1 -> - let uu___2 = FStar_Syntax_Util.head_and_args t2 in - (match uu___2 with - | (head, args) -> - let uu___3 = - let uu___4 = FStar_Syntax_Util.un_uinst head in - uu___4.FStar_Syntax_Syntax.n in - (match uu___3 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - let uu___4 = - FStar_TypeChecker_Env.lookup_sigelt env - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - (match uu___4 with - | FStar_Pervasives_Native.None -> true - | FStar_Pervasives_Native.Some se -> - (match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_let uu___5 -> true - | uu___5 -> false)) - | uu___4 -> true)) - | FStar_Syntax_Syntax.Tm_type uu___1 -> true - | FStar_Syntax_Syntax.Tm_arrow uu___1 -> - let uu___2 = FStar_Syntax_Util.arrow_formals t2 in - (match uu___2 with | (uu___3, t3) -> aux t3) - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x; FStar_Syntax_Syntax.phi = uu___1;_} - -> aux x.FStar_Syntax_Syntax.sort - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = uu___1; - FStar_Syntax_Syntax.ret_opt = uu___2; - FStar_Syntax_Syntax.brs = branches; - FStar_Syntax_Syntax.rc_opt1 = uu___3;_} - -> - FStar_Compiler_List.existsML - (fun uu___4 -> - match uu___4 with - | (p, uu___5, t3) -> - let bs = - let uu___6 = FStar_Syntax_Syntax.pat_bvs p in - FStar_Compiler_List.map FStar_Syntax_Syntax.mk_binder - uu___6 in - let uu___6 = FStar_Syntax_Subst.open_term bs t3 in - (match uu___6 with | (bs1, t4) -> aux t4)) branches - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t3; - FStar_Syntax_Syntax.meta = uu___1;_} - -> aux t3 - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t3; FStar_Syntax_Syntax.asc = uu___1; - FStar_Syntax_Syntax.eff_opt = uu___2;_} - -> aux t3 - | FStar_Syntax_Syntax.Tm_uvar uu___1 -> true - | FStar_Syntax_Syntax.Tm_let uu___1 -> true - | FStar_Syntax_Syntax.Tm_delayed uu___1 -> failwith "Impossible" - | FStar_Syntax_Syntax.Tm_bvar uu___1 -> failwith "Impossible" - | FStar_Syntax_Syntax.Tm_unknown -> failwith "Impossible" in - aux t1 -let (check_no_index_occurrences_in_arities : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident Prims.list -> FStar_Syntax_Syntax.term -> unit) - = - fun env -> - fun mutuals -> - fun t -> - debug_positivity env - (fun uu___1 -> - let uu___2 = string_of_lids mutuals in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.format2 - "check_no_index_occurrences of (mutuals %s) in arities of %s" - uu___2 uu___3); - (let no_occurrence_in_index fv mutuals1 index = - let fext_on_domain_index_sub_term index1 = - let uu___1 = FStar_Syntax_Util.head_and_args index1 in - match uu___1 with - | (head, args) -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Util.un_uinst head in - uu___4.FStar_Syntax_Syntax.n in - (uu___3, args) in - (match uu___2 with - | (FStar_Syntax_Syntax.Tm_fvar fv1, - _td::_tr::(f, uu___3)::[]) -> - let uu___4 = - (FStar_Syntax_Syntax.fv_eq_lid fv1 - FStar_Parser_Const.fext_on_domain_lid) - || - (FStar_Syntax_Syntax.fv_eq_lid fv1 - FStar_Parser_Const.fext_on_domain_g_lid) in - if uu___4 then f else index1 - | uu___3 -> index1) in - let uu___1 = index in - match uu___1 with - | (index1, uu___2) -> - FStar_Compiler_List.iter - (fun mutual -> - let uu___3 = - let uu___4 = fext_on_domain_index_sub_term index1 in - ty_occurs_in mutual uu___4 in - if uu___3 - then - let uu___4 = - let uu___5 = FStar_Ident.string_of_lid mutual in - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term index1 in - let uu___7 = FStar_Ident.string_of_lid fv in - FStar_Compiler_Util.format3 - "Type %s is not strictly positive since it instantiates a non-uniformly recursive parameter or index %s of %s" - uu___5 uu___6 uu___7 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) index1 - FStar_Errors_Codes.Error_InductiveTypeNotSatisfyPositivityCondition - () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4) - else ()) mutuals1 in - let no_occurrence_in_indexes fv mutuals1 indexes = - FStar_Compiler_List.iter (no_occurrence_in_index fv mutuals1) - indexes in - let uu___1 = FStar_Syntax_Util.head_and_args t in - match uu___1 with - | (head, args) -> - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst head in - uu___3.FStar_Syntax_Syntax.n in - (match uu___2 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - let uu___3 = - FStar_TypeChecker_Env.num_inductive_uniform_ty_params env - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - (match uu___3 with - | FStar_Pervasives_Native.None -> () - | FStar_Pervasives_Native.Some n -> - if (FStar_Compiler_List.length args) <= n - then () - else - (let uu___5 = - FStar_TypeChecker_Env.try_lookup_lid env - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - match uu___5 with - | FStar_Pervasives_Native.None -> - no_occurrence_in_indexes - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - mutuals args - | FStar_Pervasives_Native.Some - ((_us, i_typ), uu___6) -> - (debug_positivity env - (fun uu___8 -> - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.format2 - "Checking arity indexes of %s (num uniform params = %s)" - uu___9 (Prims.string_of_int n)); - (let uu___8 = - FStar_Compiler_List.splitAt n args in - match uu___8 with - | (params, indices) -> - let inst_i_typ = - apply_constr_arrow - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - i_typ params in - let uu___9 = - FStar_Syntax_Util.arrow_formals - inst_i_typ in - (match uu___9 with - | (formals, _sort) -> - let rec aux subst formals1 indices1 - = - match (formals1, indices1) with - | (uu___10, []) -> () - | (f::formals2, i::indices2) -> - let f_t = - FStar_Syntax_Subst.subst - subst - (f.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - ((let uu___11 = - may_be_an_arity env f_t in - if uu___11 - then - (debug_positivity env - (fun uu___13 -> - let uu___14 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - (FStar_Pervasives_Native.fst - i) in - let uu___15 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - f_t in - FStar_Compiler_Util.format2 - "Checking %s : %s (arity)" - uu___14 uu___15); - no_occurrence_in_index - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - mutuals i) - else - debug_positivity env - (fun uu___13 -> - let uu___14 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - (FStar_Pervasives_Native.fst - i) in - let uu___15 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - f_t in - FStar_Compiler_Util.format2 - "Skipping %s : %s (non-arity)" - uu___14 uu___15)); - (let subst1 = - (FStar_Syntax_Syntax.NT - ((f.FStar_Syntax_Syntax.binder_bv), - (FStar_Pervasives_Native.fst - i))) - :: subst in - aux subst1 formals2 indices2)) - | ([], uu___10) -> - no_occurrence_in_indexes - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - mutuals indices1 in - aux [] formals indices))))) - | uu___3 -> ())) -let (mutuals_unused_in_type : - FStar_Ident.lident Prims.list -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> Prims.bool) - = - fun mutuals -> - fun t -> - let mutuals_occur_in t1 = - FStar_Compiler_Util.for_some (fun lid -> ty_occurs_in lid t1) mutuals in - let rec ok t1 = - let uu___ = - let uu___1 = mutuals_occur_in t1 in Prims.op_Negation uu___1 in - if uu___ - then true - else - (let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress t1 in - uu___3.FStar_Syntax_Syntax.n in - match uu___2 with - | FStar_Syntax_Syntax.Tm_bvar uu___3 -> true - | FStar_Syntax_Syntax.Tm_name uu___3 -> true - | FStar_Syntax_Syntax.Tm_constant uu___3 -> true - | FStar_Syntax_Syntax.Tm_type uu___3 -> true - | FStar_Syntax_Syntax.Tm_fvar uu___3 -> false - | FStar_Syntax_Syntax.Tm_uinst uu___3 -> false - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs; FStar_Syntax_Syntax.body = t2; - FStar_Syntax_Syntax.rc_opt = uu___3;_} - -> (binders_ok bs) && (ok t2) - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; - FStar_Syntax_Syntax.comp = c;_} - -> (binders_ok bs) && (ok_comp c) - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = bv; FStar_Syntax_Syntax.phi = t2;_} - -> (ok bv.FStar_Syntax_Syntax.sort) && (ok t2) - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = args;_} - -> - let uu___3 = mutuals_occur_in head in - if uu___3 - then false - else - FStar_Compiler_List.for_all - (fun uu___5 -> - match uu___5 with - | (a, qual) -> - (match qual with - | FStar_Pervasives_Native.None -> false - | FStar_Pervasives_Native.Some q -> - FStar_Syntax_Util.contains_unused_attribute - q.FStar_Syntax_Syntax.aqual_attributes) - || (ok a)) args - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = t2; - FStar_Syntax_Syntax.ret_opt = uu___3; - FStar_Syntax_Syntax.brs = branches; - FStar_Syntax_Syntax.rc_opt1 = uu___4;_} - -> - (ok t2) && - (FStar_Compiler_List.for_all - (fun uu___5 -> - match uu___5 with | (uu___6, uu___7, br) -> ok br) - branches) - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t2; FStar_Syntax_Syntax.asc = asc; - FStar_Syntax_Syntax.eff_opt = uu___3;_} - -> ok t2 - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (uu___3, lbs); - FStar_Syntax_Syntax.body1 = t2;_} - -> - (FStar_Compiler_List.for_all - (fun lb -> - (ok lb.FStar_Syntax_Syntax.lbtyp) && - (ok lb.FStar_Syntax_Syntax.lbdef)) lbs) - && (ok t2) - | FStar_Syntax_Syntax.Tm_uvar uu___3 -> false - | FStar_Syntax_Syntax.Tm_delayed uu___3 -> false - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t2; - FStar_Syntax_Syntax.meta = uu___3;_} - -> ok t2 - | uu___3 -> false) - and binders_ok bs = - FStar_Compiler_List.for_all - (fun b -> - ok (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort) - bs - and ok_comp c = - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total t1 -> ok t1 - | FStar_Syntax_Syntax.GTotal t1 -> ok t1 - | FStar_Syntax_Syntax.Comp c1 -> - (ok c1.FStar_Syntax_Syntax.result_typ) && - (FStar_Compiler_List.for_all - (fun uu___ -> match uu___ with | (a, uu___1) -> ok a) - c1.FStar_Syntax_Syntax.effect_args) in - ok t -type unfolded_memo_elt = - (FStar_Ident.lident * FStar_Syntax_Syntax.args * Prims.int) Prims.list -type unfolded_memo_t = unfolded_memo_elt FStar_Compiler_Effect.ref -let (already_unfolded : - FStar_Ident.lident -> - FStar_Syntax_Syntax.args -> - unfolded_memo_t -> FStar_TypeChecker_Env.env_t -> Prims.bool) - = - fun ilid -> - fun args -> - fun unfolded -> - fun env -> - let uu___ = FStar_Compiler_Effect.op_Bang unfolded in - FStar_Compiler_List.existsML - (fun uu___1 -> - match uu___1 with - | (lid, l, n) -> - ((FStar_Ident.lid_equals lid ilid) && - ((FStar_Compiler_List.length args) >= n)) - && - (let args1 = - let uu___2 = FStar_Compiler_List.splitAt n args in - FStar_Pervasives_Native.fst uu___2 in - FStar_Compiler_List.fold_left2 - (fun b -> - fun a -> - fun a' -> - b && - (FStar_TypeChecker_Rel.teq_nosmt_force env - (FStar_Pervasives_Native.fst a) - (FStar_Pervasives_Native.fst a'))) true - args1 l)) uu___ -let rec (ty_strictly_positive_in_type : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident Prims.list -> - FStar_Syntax_Syntax.term -> unfolded_memo_t -> Prims.bool) - = - fun env -> - fun mutuals -> - fun in_type -> - fun unfolded -> - let in_type1 = normalize env in_type in - debug_positivity env - (fun uu___1 -> - let uu___2 = string_of_lids mutuals in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - in_type1 in - FStar_Compiler_Util.format2 - "Checking strict positivity of {%s} in type, after normalization %s " - uu___2 uu___3); - (let uu___1 = - FStar_Compiler_List.for_all - (fun mutual -> - let uu___2 = ty_occurs_in mutual in_type1 in - Prims.op_Negation uu___2) mutuals in - if uu___1 - then true - else - (debug_positivity env - (fun uu___4 -> "ty does occur in this type"); - (let uu___4 = - let uu___5 = FStar_Syntax_Subst.compress in_type1 in - uu___5.FStar_Syntax_Syntax.n in - match uu___4 with - | FStar_Syntax_Syntax.Tm_fvar uu___5 -> - (debug_positivity env - (fun uu___7 -> - "Checking strict positivity in an fvar/Tm_uinst/Tm_type, return true"); - true) - | FStar_Syntax_Syntax.Tm_uinst uu___5 -> - (debug_positivity env - (fun uu___7 -> - "Checking strict positivity in an fvar/Tm_uinst/Tm_type, return true"); - true) - | FStar_Syntax_Syntax.Tm_type uu___5 -> - (debug_positivity env - (fun uu___7 -> - "Checking strict positivity in an fvar/Tm_uinst/Tm_type, return true"); - true) - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t; - FStar_Syntax_Syntax.asc = uu___5; - FStar_Syntax_Syntax.eff_opt = uu___6;_} - -> ty_strictly_positive_in_type env mutuals t unfolded - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t; - FStar_Syntax_Syntax.meta = uu___5;_} - -> ty_strictly_positive_in_type env mutuals t unfolded - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = t; - FStar_Syntax_Syntax.args = args;_} - -> - let fv_or_name_opt = term_as_fv_or_name t in - (match fv_or_name_opt with - | FStar_Pervasives_Native.None -> - (debug_positivity env - (fun uu___6 -> - let uu___7 = string_of_lids mutuals in - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.format2 - "Failed to check positivity of %s in a term with head %s" - uu___7 uu___8); - false) - | FStar_Pervasives_Native.Some (FStar_Pervasives.Inr x) - -> - let uu___5 = FStar_TypeChecker_Env.lookup_bv env x in - (match uu___5 with - | (head_ty, _pos) -> - (debug_positivity env - (fun uu___7 -> - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - in_type1 in - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_bv x in - let uu___10 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - head_ty in - FStar_Compiler_Util.format3 - "Tm_app, head bv, in_type=%s, head_bv=%s, head_ty=%s" - uu___8 uu___9 uu___10); - ty_strictly_positive_in_args env mutuals - head_ty args unfolded)) - | FStar_Pervasives_Native.Some (FStar_Pervasives.Inl - (fv, us)) -> - let uu___5 = - FStar_Compiler_List.existsML - (FStar_Ident.lid_equals - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v) - mutuals in - if uu___5 - then - (debug_positivity env - (fun uu___7 -> - let uu___8 = - FStar_Ident.string_of_lid - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - FStar_Compiler_Util.format1 - "Checking strict positivity in the Tm_app node where head lid is %s itself, checking that ty does not occur in the arguments" - uu___8); - FStar_Compiler_List.for_all - (fun uu___7 -> - match uu___7 with - | (t1, uu___8) -> - mutuals_unused_in_type mutuals t1) args) - else - (debug_positivity env - (fun uu___8 -> - let uu___9 = string_of_lids mutuals in - FStar_Compiler_Util.format1 - "Checking strict positivity in the Tm_app node, head lid is not in %s, so checking nested positivity" - uu___9); - ty_strictly_positive_in_arguments_to_fvar env - mutuals in_type1 - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - us args unfolded)) - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = uu___5; - FStar_Syntax_Syntax.comp = c;_} - -> - (debug_positivity env - (fun uu___7 -> "Checking strict positivity in Tm_arrow"); - (let check_comp = - (FStar_Syntax_Util.is_pure_or_ghost_comp c) || - (let uu___7 = - let uu___8 = - FStar_TypeChecker_Env.norm_eff_name env - (FStar_Syntax_Util.comp_effect_name c) in - FStar_TypeChecker_Env.lookup_effect_quals env - uu___8 in - FStar_Compiler_List.contains - FStar_Syntax_Syntax.TotalEffect uu___7) in - if Prims.op_Negation check_comp - then - (debug_positivity env - (fun uu___8 -> - "Checking strict positivity , the arrow is impure, so return true"); - true) - else - (debug_positivity env - (fun uu___9 -> - "Checking strict positivity for an arrow, checking that ty does not occur in the binders, and that it is strictly positive in the return type"); - (let uu___9 = - FStar_Syntax_Util.arrow_formals_comp in_type1 in - match uu___9 with - | (sbs, c1) -> - let return_type = - FStar_Syntax_Util.comp_result c1 in - let ty_lid_not_to_left_of_arrow = - FStar_Compiler_List.for_all - (fun uu___10 -> - match uu___10 with - | { FStar_Syntax_Syntax.binder_bv = b; - FStar_Syntax_Syntax.binder_qual = - uu___11; - FStar_Syntax_Syntax.binder_positivity - = uu___12; - FStar_Syntax_Syntax.binder_attrs = - uu___13;_} - -> - mutuals_unused_in_type mutuals - b.FStar_Syntax_Syntax.sort) sbs in - if ty_lid_not_to_left_of_arrow - then - let uu___10 = - FStar_TypeChecker_Env.push_binders env sbs in - ty_strictly_positive_in_type uu___10 mutuals - return_type unfolded - else false)))) - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = bv; - FStar_Syntax_Syntax.phi = f;_} - -> - (debug_positivity env - (fun uu___6 -> - "Checking strict positivity in an Tm_refine, recur in the bv sort)"); - (let uu___6 = - let uu___7 = - let uu___8 = FStar_Syntax_Syntax.mk_binder bv in - [uu___8] in - FStar_Syntax_Subst.open_term uu___7 f in - match uu___6 with - | (b::[], f1) -> - let uu___7 = - ty_strictly_positive_in_type env mutuals - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort - unfolded in - if uu___7 - then - let env1 = - FStar_TypeChecker_Env.push_binders env [b] in - ty_strictly_positive_in_type env1 mutuals f1 - unfolded - else false)) - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = scrutinee; - FStar_Syntax_Syntax.ret_opt = uu___5; - FStar_Syntax_Syntax.brs = branches; - FStar_Syntax_Syntax.rc_opt1 = uu___6;_} - -> - (debug_positivity env - (fun uu___8 -> - "Checking strict positivity in an Tm_match, recur in the branches)"); - (let uu___8 = - FStar_Compiler_List.existsML - (fun mutual -> ty_occurs_in mutual scrutinee) - mutuals in - if uu___8 - then - FStar_Compiler_List.for_all - (fun uu___9 -> - match uu___9 with - | (p, uu___10, t) -> - let bs = - let uu___11 = FStar_Syntax_Syntax.pat_bvs p in - FStar_Compiler_List.map - FStar_Syntax_Syntax.mk_binder uu___11 in - let uu___11 = - FStar_Syntax_Subst.open_term bs t in - (match uu___11 with - | (bs1, t1) -> - let uu___12 = - FStar_Compiler_List.fold_left - (fun uu___13 -> - fun b -> - match uu___13 with - | (t2, lids) -> - let uu___14 = - name_as_fv_in_t t2 - b.FStar_Syntax_Syntax.binder_bv in - (match uu___14 with - | (t3, lid) -> - (t3, (lid :: lids)))) - (t1, mutuals) bs1 in - (match uu___12 with - | (t2, mutuals1) -> - ty_strictly_positive_in_type env - mutuals1 t2 unfolded))) branches - else - FStar_Compiler_List.for_all - (fun uu___10 -> - match uu___10 with - | (p, uu___11, t) -> - let bs = - let uu___12 = FStar_Syntax_Syntax.pat_bvs p in - FStar_Compiler_List.map - FStar_Syntax_Syntax.mk_binder uu___12 in - let uu___12 = - FStar_Syntax_Subst.open_term bs t in - (match uu___12 with - | (bs1, t1) -> - let uu___13 = - FStar_TypeChecker_Env.push_binders env - bs1 in - ty_strictly_positive_in_type uu___13 - mutuals t1 unfolded)) branches)) - | FStar_Syntax_Syntax.Tm_abs uu___5 -> - let uu___6 = FStar_Syntax_Util.abs_formals in_type1 in - (match uu___6 with - | (bs, body, uu___7) -> - let rec aux env1 bs1 = - match bs1 with - | [] -> - ty_strictly_positive_in_type env1 mutuals body - unfolded - | b::bs2 -> - let uu___8 = - ty_strictly_positive_in_type env1 mutuals - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort - unfolded in - if uu___8 - then - let env2 = - FStar_TypeChecker_Env.push_binders env1 [b] in - aux env2 bs2 - else false in - aux env bs) - | uu___5 -> - (debug_positivity env - (fun uu___7 -> - let uu___8 = - FStar_Class_Tagged.tag_of - FStar_Syntax_Syntax.tagged_term in_type1 in - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term in_type1 in - FStar_Compiler_Util.format2 - "Checking strict positivity, unexpected tag: %s and term %s" - uu___8 uu___9); - false)))) -and (ty_strictly_positive_in_args : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident Prims.list -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.args -> unfolded_memo_t -> Prims.bool) - = - fun env -> - fun mutuals -> - fun head_t -> - fun args -> - fun unfolded -> - let uu___ = FStar_Syntax_Util.arrow_formals head_t in - match uu___ with - | (bs, uu___1) -> - let rec aux bs1 args1 = - match (bs1, args1) with - | (uu___2, []) -> true - | ([], uu___2) -> - FStar_Compiler_List.for_all - (fun uu___3 -> - match uu___3 with - | (arg, uu___4) -> - mutuals_unused_in_type mutuals arg) args1 - | (b::bs2, (arg, uu___2)::args2) -> - (debug_positivity env - (fun uu___4 -> - let uu___5 = string_of_lids mutuals in - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term arg in - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_binder b in - FStar_Compiler_Util.format3 - "Checking positivity of %s in argument %s and binder %s" - uu___5 uu___6 uu___7); - (let this_occurrence_ok = - ((mutuals_unused_in_type mutuals arg) || - (FStar_Syntax_Util.is_binder_unused b)) - || - ((FStar_Syntax_Util.is_binder_strictly_positive b) - && - (ty_strictly_positive_in_type env mutuals arg - unfolded)) in - if Prims.op_Negation this_occurrence_ok - then - (debug_positivity env - (fun uu___5 -> - let uu___6 = string_of_lids mutuals in - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term arg in - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_binder b in - FStar_Compiler_Util.format3 - "Failed checking positivity of %s in argument %s and binder %s" - uu___6 uu___7 uu___8); - false) - else aux bs2 args2)) in - aux bs args -and (ty_strictly_positive_in_arguments_to_fvar : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident Prims.list -> - FStar_Syntax_Syntax.term -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> unfolded_memo_t -> Prims.bool) - = - fun env -> - fun mutuals -> - fun t -> - fun fv -> - fun us -> - fun args -> - fun unfolded -> - debug_positivity env - (fun uu___1 -> - let uu___2 = string_of_lids mutuals in - let uu___3 = FStar_Ident.string_of_lid fv in - let uu___4 = FStar_Syntax_Print.args_to_string args in - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - t in - FStar_Compiler_Util.format4 - "Checking positivity of %s in application of fv %s to %s (t=%s)" - uu___2 uu___3 uu___4 uu___5); - (let uu___1 = FStar_TypeChecker_Env.is_datacon env fv in - if uu___1 - then - FStar_Compiler_List.for_all - (fun uu___2 -> - match uu___2 with - | (a, uu___3) -> - ty_strictly_positive_in_type env mutuals a - unfolded) args - else - (let fv_ty = - let uu___3 = - FStar_TypeChecker_Env.try_lookup_lid env fv in - match uu___3 with - | FStar_Pervasives_Native.Some - ((uu___4, fv_ty1), uu___5) -> fv_ty1 - | uu___4 -> - let uu___5 = - let uu___6 = FStar_Ident.string_of_lid fv in - FStar_Compiler_Util.format1 - "Type of %s not found when checking positivity" - uu___6 in - FStar_Errors.raise_error - FStar_Ident.hasrange_lident fv - FStar_Errors_Codes.Error_InductiveTypeNotSatisfyPositivityCondition - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___5) in - let uu___3 = FStar_TypeChecker_Env.datacons_of_typ env fv in - match uu___3 with - | (b, idatas) -> - if Prims.op_Negation b - then - ty_strictly_positive_in_args env mutuals fv_ty args - unfolded - else - (check_no_index_occurrences_in_arities env mutuals - t; - (let ilid = fv in - let num_uniform_params = - let uu___6 = - FStar_TypeChecker_Env.num_inductive_uniform_ty_params - env ilid in - match uu___6 with - | FStar_Pervasives_Native.None -> - failwith "Unexpected type" - | FStar_Pervasives_Native.Some n -> n in - let uu___6 = - FStar_Compiler_List.splitAt num_uniform_params - args in - match uu___6 with - | (params, _rest) -> - let uu___7 = - already_unfolded ilid args unfolded env in - if uu___7 - then - (debug_positivity env - (fun uu___9 -> - "Checking nested positivity, we have already unfolded this inductive with these args"); - true) - else - (debug_positivity env - (fun uu___10 -> - let uu___11 = - FStar_Ident.string_of_lid ilid in - let uu___12 = - FStar_Syntax_Print.args_to_string - params in - FStar_Compiler_Util.format3 - "Checking positivity in datacon, number of type parameters is %s, adding %s %s to the memo table" - (Prims.string_of_int - num_uniform_params) uu___11 - uu___12); - (let uu___11 = - let uu___12 = - FStar_Compiler_Effect.op_Bang - unfolded in - FStar_List_Tot_Base.op_At uu___12 - [(ilid, params, num_uniform_params)] in - FStar_Compiler_Effect.op_Colon_Equals - unfolded uu___11); - FStar_Compiler_List.for_all - (fun d -> - ty_strictly_positive_in_datacon_of_applied_inductive - env mutuals d ilid us args - num_uniform_params unfolded) idatas))))) -and (ty_strictly_positive_in_datacon_of_applied_inductive : - FStar_TypeChecker_Env.env_t -> - FStar_Ident.lident Prims.list -> - FStar_Ident.lident -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - Prims.int -> unfolded_memo_t -> Prims.bool) - = - fun env -> - fun mutuals -> - fun dlid -> - fun ilid -> - fun us -> - fun args -> - fun num_ibs -> - fun unfolded -> - debug_positivity env - (fun uu___1 -> - let uu___2 = string_of_lids mutuals in - let uu___3 = FStar_Ident.string_of_lid dlid in - let uu___4 = FStar_Ident.string_of_lid ilid in - FStar_Compiler_Util.format3 - "Checking positivity of %s in data constructor %s : %s" - uu___2 uu___3 uu___4); - (let dt = - let uu___1 = - FStar_TypeChecker_Env.try_lookup_and_inst_lid env us - dlid in - match uu___1 with - | FStar_Pervasives_Native.Some (t, uu___2) -> t - | FStar_Pervasives_Native.None -> - let uu___2 = FStar_Ident.range_of_lid dlid in - let uu___3 = - let uu___4 = FStar_Ident.string_of_lid dlid in - FStar_Compiler_Util.format1 - "Data constructor %s not found when checking positivity" - uu___4 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range uu___2 - FStar_Errors_Codes.Error_InductiveTypeNotSatisfyPositivityCondition - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___3) in - debug_positivity env - (fun uu___2 -> - let uu___3 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term dt in - let uu___4 = FStar_Syntax_Print.args_to_string args in - FStar_Compiler_Util.format3 - "Checking positivity in the data constructor type: %s\n\tnum_ibs=%s, args=%s," - uu___3 (Prims.string_of_int num_ibs) uu___4); - (let uu___2 = FStar_Compiler_List.splitAt num_ibs args in - match uu___2 with - | (args1, rest) -> - let applied_dt = apply_constr_arrow dlid dt args1 in - (debug_positivity env - (fun uu___4 -> - let uu___5 = FStar_Ident.string_of_lid dlid in - let uu___6 = - FStar_Syntax_Print.args_to_string args1 in - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term applied_dt in - FStar_Compiler_Util.format3 - "Applied data constructor type: %s %s : %s" - uu___5 uu___6 uu___7); - (let uu___4 = - FStar_Syntax_Util.arrow_formals applied_dt in - match uu___4 with - | (fields, t) -> - (check_no_index_occurrences_in_arities env - mutuals t; - (let rec strictly_positive_in_all_fields env1 - fields1 = - match fields1 with - | [] -> true - | f::fields2 -> - (debug_positivity env1 - (fun uu___7 -> - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_bv - f.FStar_Syntax_Syntax.binder_bv in - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - (f.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - FStar_Compiler_Util.format2 - "Checking field %s : %s for indexes and positivity" - uu___8 uu___9); - check_no_index_occurrences_in_arities - env1 mutuals - (f.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort; - (let uu___8 = - ty_strictly_positive_in_type env1 - mutuals - (f.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort - unfolded in - if uu___8 - then - let env2 = - FStar_TypeChecker_Env.push_binders - env1 [f] in - strictly_positive_in_all_fields - env2 fields2 - else false)) in - strictly_positive_in_all_fields env fields)))))) -let (name_strictly_positive_in_type : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.bv -> FStar_Syntax_Syntax.term -> Prims.bool) - = - fun env -> - fun bv -> - fun t -> - let uu___ = name_as_fv_in_t t bv in - match uu___ with - | (t1, fv_lid) -> - let uu___1 = FStar_Compiler_Util.mk_ref [] in - ty_strictly_positive_in_type env [fv_lid] t1 uu___1 -let (name_unused_in_type : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.bv -> FStar_Syntax_Syntax.term -> Prims.bool) - = - fun env -> - fun bv -> - fun t -> - let uu___ = name_as_fv_in_t t bv in - match uu___ with - | (t1, fv_lid) -> - (let uu___1 = ty_occurs_in fv_lid t1 in Prims.op_Negation uu___1) - || - (let uu___1 = normalize env t1 in - mutuals_unused_in_type [fv_lid] uu___1) -let (ty_strictly_positive_in_datacon_decl : - FStar_TypeChecker_Env.env_t -> - FStar_Ident.lident Prims.list -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.universes -> unfolded_memo_t -> Prims.bool) - = - fun env -> - fun mutuals -> - fun dlid -> - fun ty_bs -> - fun us -> - fun unfolded -> - let dt = - let uu___ = - FStar_TypeChecker_Env.try_lookup_and_inst_lid env us dlid in - match uu___ with - | FStar_Pervasives_Native.Some (t, uu___1) -> t - | FStar_Pervasives_Native.None -> - let uu___1 = - let uu___2 = FStar_Ident.string_of_lid dlid in - FStar_Compiler_Util.format1 - "Error looking up data constructor %s when checking positivity" - uu___2 in - FStar_Errors.raise_error FStar_Ident.hasrange_lident dlid - FStar_Errors_Codes.Error_InductiveTypeNotSatisfyPositivityCondition - () (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) in - debug_positivity env - (fun uu___1 -> - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - dt in - Prims.strcat "Checking data constructor type: " uu___2); - (let uu___1 = FStar_Syntax_Util.args_of_binders ty_bs in - match uu___1 with - | (ty_bs1, args) -> - let dt1 = apply_constr_arrow dlid dt args in - let uu___2 = FStar_Syntax_Util.arrow_formals dt1 in - (match uu___2 with - | (fields, return_type) -> - (check_no_index_occurrences_in_arities env mutuals - return_type; - (let check_annotated_binders_are_strictly_positive_in_field - f = - let incorrectly_annotated_binder = - FStar_Compiler_List.tryFind - (fun b -> - ((FStar_Syntax_Util.is_binder_unused b) && - (let uu___4 = - name_unused_in_type env - b.FStar_Syntax_Syntax.binder_bv - (f.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - Prims.op_Negation uu___4)) - || - ((FStar_Syntax_Util.is_binder_strictly_positive - b) - && - (let uu___4 = - name_strictly_positive_in_type env - b.FStar_Syntax_Syntax.binder_bv - (f.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - Prims.op_Negation uu___4))) ty_bs1 in - match incorrectly_annotated_binder with - | FStar_Pervasives_Native.None -> () - | FStar_Pervasives_Native.Some b -> - let uu___4 = - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_binder b in - FStar_Compiler_Util.format2 - "Binder %s is marked %s, but its use in the definition is not" - uu___5 - (if - FStar_Syntax_Util.is_binder_strictly_positive - b - then "strictly_positive" - else "unused") in - FStar_Errors.raise_error - FStar_Syntax_Syntax.hasRange_binder b - FStar_Errors_Codes.Error_InductiveTypeNotSatisfyPositivityCondition - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4) in - let rec check_all_fields env1 fields1 = - match fields1 with - | [] -> true - | field::fields2 -> - (check_annotated_binders_are_strictly_positive_in_field - field; - (let uu___5 = - let uu___6 = - ty_strictly_positive_in_type env1 - mutuals - (field.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort - unfolded in - Prims.op_Negation uu___6 in - if uu___5 - then false - else - (let env2 = - FStar_TypeChecker_Env.push_binders - env1 [field] in - check_all_fields env2 fields2))) in - check_all_fields env fields)))) -let (check_strict_positivity : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident Prims.list -> FStar_Syntax_Syntax.sigelt -> Prims.bool) - = - fun env -> - fun mutuals -> - fun ty -> - let unfolded_inductives = FStar_Compiler_Util.mk_ref [] in - let uu___ = open_sig_inductive_typ env ty in - match uu___ with - | (env1, (ty_lid, ty_us, ty_params)) -> - let mutuals1 = - FStar_Compiler_List.filter - (fun m -> - let uu___1 = FStar_TypeChecker_Env.is_datacon env1 m in - Prims.op_Negation uu___1) mutuals in - let mutuals2 = - let uu___1 = - FStar_Compiler_List.existsML (FStar_Ident.lid_equals ty_lid) - mutuals1 in - if uu___1 then mutuals1 else ty_lid :: mutuals1 in - let datacons = - let uu___1 = FStar_TypeChecker_Env.datacons_of_typ env1 ty_lid in - FStar_Pervasives_Native.snd uu___1 in - let us = - FStar_Compiler_List.map - (fun uu___1 -> FStar_Syntax_Syntax.U_name uu___1) ty_us in - FStar_Compiler_List.for_all - (fun d -> - ty_strictly_positive_in_datacon_decl env1 mutuals2 d - ty_params us unfolded_inductives) datacons -let (check_exn_strict_positivity : - FStar_TypeChecker_Env.env -> FStar_Ident.lident -> Prims.bool) = - fun env -> - fun data_ctor_lid -> - let unfolded_inductives = FStar_Compiler_Util.mk_ref [] in - ty_strictly_positive_in_datacon_decl env [FStar_Parser_Const.exn_lid] - data_ctor_lid [] [] unfolded_inductives \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops.ml deleted file mode 100644 index 3969af2a36e..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops.ml +++ /dev/null @@ -1,472 +0,0 @@ -open Prims -let (as_primitive_step : - Prims.bool -> - (FStar_Ident.lident * Prims.int * Prims.int * - FStar_TypeChecker_Primops_Base.interp_t * - (FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t FStar_Pervasives_Native.option)) - -> FStar_TypeChecker_Primops_Base.primitive_step) - = - fun is_strong -> - fun uu___ -> - match uu___ with - | (l, arity, u_arity, f, f_nbe) -> - FStar_TypeChecker_Primops_Base.as_primitive_step_nbecbs is_strong - (l, arity, u_arity, f, - (fun cb -> fun univs -> fun args -> f_nbe univs args)) -let (and_op : - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = - fun psc -> - fun _norm_cb -> - fun _us -> - fun args -> - match args with - | (a1, FStar_Pervasives_Native.None)::(a2, - FStar_Pervasives_Native.None)::[] - -> - let uu___ = - FStar_TypeChecker_Primops_Base.try_unembed_simple - FStar_Syntax_Embeddings.e_bool a1 in - (match uu___ with - | FStar_Pervasives_Native.Some (false) -> - let uu___1 = - FStar_TypeChecker_Primops_Base.embed_simple - FStar_Syntax_Embeddings.e_bool - psc.FStar_TypeChecker_Primops_Base.psc_range false in - FStar_Pervasives_Native.Some uu___1 - | FStar_Pervasives_Native.Some (true) -> - FStar_Pervasives_Native.Some a2 - | uu___1 -> FStar_Pervasives_Native.None) - | uu___ -> failwith "Unexpected number of arguments" -let (or_op : - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = - fun psc -> - fun _norm_cb -> - fun _us -> - fun args -> - match args with - | (a1, FStar_Pervasives_Native.None)::(a2, - FStar_Pervasives_Native.None)::[] - -> - let uu___ = - FStar_TypeChecker_Primops_Base.try_unembed_simple - FStar_Syntax_Embeddings.e_bool a1 in - (match uu___ with - | FStar_Pervasives_Native.Some (true) -> - let uu___1 = - FStar_TypeChecker_Primops_Base.embed_simple - FStar_Syntax_Embeddings.e_bool - psc.FStar_TypeChecker_Primops_Base.psc_range true in - FStar_Pervasives_Native.Some uu___1 - | FStar_Pervasives_Native.Some (false) -> - FStar_Pervasives_Native.Some a2 - | uu___1 -> FStar_Pervasives_Native.None) - | uu___ -> failwith "Unexpected number of arguments" -let (division_modulus_op : - (FStar_BigInt.t -> FStar_BigInt.t -> FStar_BigInt.t) -> - FStar_BigInt.t -> - FStar_BigInt.t -> FStar_BigInt.t FStar_Pervasives_Native.option) - = - fun f -> - fun x -> - fun y -> - let uu___ = - let uu___1 = FStar_BigInt.to_int_fs y in uu___1 <> Prims.int_zero in - if uu___ - then let uu___1 = f x y in FStar_Pervasives_Native.Some uu___1 - else FStar_Pervasives_Native.None -let (simple_ops : FStar_TypeChecker_Primops_Base.primitive_step Prims.list) = - let uu___ = - FStar_TypeChecker_Primops_Base.mk1 Prims.int_zero - FStar_Parser_Const.string_of_int_lid FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string - (fun z -> - let uu___1 = FStar_BigInt.to_int_fs z in Prims.string_of_int uu___1) in - let uu___1 = - let uu___2 = - FStar_TypeChecker_Primops_Base.mk1 Prims.int_zero - FStar_Parser_Const.int_of_string_lid FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string - (FStar_Syntax_Embeddings.e_option FStar_Syntax_Embeddings.e_int) - (FStar_TypeChecker_NBETerm.e_option FStar_TypeChecker_NBETerm.e_int) - (fun uu___3 -> - (fun s -> - let uu___3 = FStar_Compiler_Util.safe_int_of_string s in - Obj.magic - (FStar_Class_Monad.fmap FStar_Class_Monad.monad_option () () - (fun uu___4 -> (Obj.magic FStar_BigInt.of_int_fs) uu___4) - (Obj.magic uu___3))) uu___3) in - let uu___3 = - let uu___4 = - FStar_TypeChecker_Primops_Base.mk1 Prims.int_zero - FStar_Parser_Const.string_of_bool_lid - FStar_Syntax_Embeddings.e_bool FStar_TypeChecker_NBETerm.e_bool - FStar_Syntax_Embeddings.e_string FStar_TypeChecker_NBETerm.e_string - Prims.string_of_bool in - let uu___5 = - let uu___6 = - FStar_TypeChecker_Primops_Base.mk1 Prims.int_zero - FStar_Parser_Const.bool_of_string_lid - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string - (FStar_Syntax_Embeddings.e_option FStar_Syntax_Embeddings.e_bool) - (FStar_TypeChecker_NBETerm.e_option - FStar_TypeChecker_NBETerm.e_bool) - (fun uu___7 -> - match uu___7 with - | "true" -> FStar_Pervasives_Native.Some true - | "false" -> FStar_Pervasives_Native.Some false - | uu___8 -> FStar_Pervasives_Native.None) in - let uu___7 = - let uu___8 = - FStar_TypeChecker_Primops_Base.mk1 Prims.int_zero - FStar_Parser_Const.op_Minus FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int FStar_BigInt.minus_big_int in - let uu___9 = - let uu___10 = - FStar_TypeChecker_Primops_Base.mk2 Prims.int_zero - FStar_Parser_Const.op_Addition FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int FStar_BigInt.add_big_int in - let uu___11 = - let uu___12 = - FStar_TypeChecker_Primops_Base.mk2 Prims.int_zero - FStar_Parser_Const.op_Subtraction - FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int - FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int - FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int FStar_BigInt.sub_big_int in - let uu___13 = - let uu___14 = - FStar_TypeChecker_Primops_Base.mk2 Prims.int_zero - FStar_Parser_Const.op_Multiply - FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int - FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int - FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int FStar_BigInt.mult_big_int in - let uu___15 = - let uu___16 = - FStar_TypeChecker_Primops_Base.mk2 Prims.int_zero - FStar_Parser_Const.op_LT FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int - FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int - FStar_Syntax_Embeddings.e_bool - FStar_TypeChecker_NBETerm.e_bool - FStar_BigInt.lt_big_int in - let uu___17 = - let uu___18 = - FStar_TypeChecker_Primops_Base.mk2 Prims.int_zero - FStar_Parser_Const.op_LTE - FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int - FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int - FStar_Syntax_Embeddings.e_bool - FStar_TypeChecker_NBETerm.e_bool - FStar_BigInt.le_big_int in - let uu___19 = - let uu___20 = - FStar_TypeChecker_Primops_Base.mk2 Prims.int_zero - FStar_Parser_Const.op_GT - FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int - FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int - FStar_Syntax_Embeddings.e_bool - FStar_TypeChecker_NBETerm.e_bool - FStar_BigInt.gt_big_int in - let uu___21 = - let uu___22 = - FStar_TypeChecker_Primops_Base.mk2 Prims.int_zero - FStar_Parser_Const.op_GTE - FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int - FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int - FStar_Syntax_Embeddings.e_bool - FStar_TypeChecker_NBETerm.e_bool - FStar_BigInt.ge_big_int in - let uu___23 = - let uu___24 = - FStar_TypeChecker_Primops_Base.mk2' - Prims.int_zero FStar_Parser_Const.op_Division - FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int - FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int - FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int - (division_modulus_op FStar_BigInt.div_big_int) - (division_modulus_op FStar_BigInt.div_big_int) in - let uu___25 = - let uu___26 = - FStar_TypeChecker_Primops_Base.mk2' - Prims.int_zero FStar_Parser_Const.op_Modulus - FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int - FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int - FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int - (division_modulus_op FStar_BigInt.mod_big_int) - (division_modulus_op FStar_BigInt.mod_big_int) in - let uu___27 = - let uu___28 = - FStar_TypeChecker_Primops_Base.mk1 - Prims.int_zero - FStar_Parser_Const.op_Negation - FStar_Syntax_Embeddings.e_bool - FStar_TypeChecker_NBETerm.e_bool - FStar_Syntax_Embeddings.e_bool - FStar_TypeChecker_NBETerm.e_bool - Prims.op_Negation in - let uu___29 = - let uu___30 = - FStar_TypeChecker_Primops_Base.mk2 - Prims.int_zero - FStar_Parser_Const.string_concat_lid - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string - FStar_Syntax_Embeddings.e_string_list - FStar_TypeChecker_NBETerm.e_string_list - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string - FStar_Compiler_String.concat in - let uu___31 = - let uu___32 = - FStar_TypeChecker_Primops_Base.mk2 - Prims.int_zero - FStar_Parser_Const.string_split_lid - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_char) - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_char) - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string - FStar_Syntax_Embeddings.e_string_list - FStar_TypeChecker_NBETerm.e_string_list - FStar_Compiler_String.split in - let uu___33 = - let uu___34 = - FStar_TypeChecker_Primops_Base.mk2 - Prims.int_zero - FStar_Parser_Const.prims_strcat_lid - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string - (fun s1 -> - fun s2 -> Prims.strcat s1 s2) in - let uu___35 = - let uu___36 = - FStar_TypeChecker_Primops_Base.mk2 - Prims.int_zero - FStar_Parser_Const.string_compare_lid - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string - FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int - (fun s1 -> - fun s2 -> - FStar_BigInt.of_int_fs - (FStar_Compiler_String.compare - s1 s2)) in - let uu___37 = - let uu___38 = - FStar_TypeChecker_Primops_Base.mk1 - Prims.int_zero - FStar_Parser_Const.string_string_of_list_lid - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_char) - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_char) - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string - FStar_String.string_of_list in - let uu___39 = - let uu___40 = - FStar_TypeChecker_Primops_Base.mk2 - Prims.int_zero - FStar_Parser_Const.string_make_lid - FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int - FStar_Syntax_Embeddings.e_char - FStar_TypeChecker_NBETerm.e_char - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string - (fun x -> - fun y -> - let uu___41 = - FStar_BigInt.to_int_fs x in - FStar_Compiler_String.make - uu___41 y) in - let uu___41 = - let uu___42 = - FStar_TypeChecker_Primops_Base.mk1 - Prims.int_zero - FStar_Parser_Const.string_list_of_string_lid - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_char) - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_char) - FStar_String.list_of_string in - let uu___43 = - let uu___44 = - FStar_TypeChecker_Primops_Base.mk1 - Prims.int_zero - FStar_Parser_Const.string_lowercase_lid - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string - FStar_Compiler_String.lowercase in - let uu___45 = - let uu___46 = - FStar_TypeChecker_Primops_Base.mk1 - Prims.int_zero - FStar_Parser_Const.string_uppercase_lid - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string - FStar_Compiler_String.uppercase in - let uu___47 = - let uu___48 = - FStar_TypeChecker_Primops_Base.mk2 - Prims.int_zero - FStar_Parser_Const.string_index_lid - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string - FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int - FStar_Syntax_Embeddings.e_char - FStar_TypeChecker_NBETerm.e_char - FStar_Compiler_String.index in - let uu___49 = - let uu___50 = - FStar_TypeChecker_Primops_Base.mk2 - Prims.int_zero - FStar_Parser_Const.string_index_of_lid - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string - FStar_Syntax_Embeddings.e_char - FStar_TypeChecker_NBETerm.e_char - FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int - FStar_Compiler_String.index_of in - let uu___51 = - let uu___52 = - FStar_TypeChecker_Primops_Base.mk3 - Prims.int_zero - FStar_Parser_Const.string_sub_lid - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string - FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int - FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string - (fun s -> - fun o -> - fun l -> - let uu___53 - = - FStar_BigInt.to_int_fs - o in - let uu___54 - = - FStar_BigInt.to_int_fs - l in - FStar_Compiler_String.substring - s uu___53 - uu___54) in - [uu___52] in - uu___50 :: uu___51 in - uu___48 :: uu___49 in - uu___46 :: uu___47 in - uu___44 :: uu___45 in - uu___42 :: uu___43 in - uu___40 :: uu___41 in - uu___38 :: uu___39 in - uu___36 :: uu___37 in - uu___34 :: uu___35 in - uu___32 :: uu___33 in - uu___30 :: uu___31 in - uu___28 :: uu___29 in - uu___26 :: uu___27 in - uu___24 :: uu___25 in - uu___22 :: uu___23 in - uu___20 :: uu___21 in - uu___18 :: uu___19 in - uu___16 :: uu___17 in - uu___14 :: uu___15 in - uu___12 :: uu___13 in - uu___10 :: uu___11 in - uu___8 :: uu___9 in - uu___6 :: uu___7 in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - uu___ :: uu___1 -let (short_circuit_ops : - FStar_TypeChecker_Primops_Base.primitive_step Prims.list) = - FStar_Compiler_List.map (as_primitive_step true) - [(FStar_Parser_Const.op_And, (Prims.of_int (2)), Prims.int_zero, and_op, - ((fun _us -> FStar_TypeChecker_NBETerm.and_op))); - (FStar_Parser_Const.op_Or, (Prims.of_int (2)), Prims.int_zero, or_op, - ((fun _us -> FStar_TypeChecker_NBETerm.or_op)))] -let (built_in_primitive_steps_list : - FStar_TypeChecker_Primops_Base.primitive_step Prims.list) = - FStar_Compiler_List.op_At simple_ops - (FStar_Compiler_List.op_At short_circuit_ops - (FStar_Compiler_List.op_At FStar_TypeChecker_Primops_Issue.ops - (FStar_Compiler_List.op_At FStar_TypeChecker_Primops_Array.ops - (FStar_Compiler_List.op_At FStar_TypeChecker_Primops_Sealed.ops - (FStar_Compiler_List.op_At - FStar_TypeChecker_Primops_Erased.ops - (FStar_Compiler_List.op_At - FStar_TypeChecker_Primops_Docs.ops - (FStar_Compiler_List.op_At - FStar_TypeChecker_Primops_MachineInts.ops - (FStar_Compiler_List.op_At - FStar_TypeChecker_Primops_Errors_Msg.ops - (FStar_Compiler_List.op_At - FStar_TypeChecker_Primops_Range.ops - FStar_TypeChecker_Primops_Real.ops))))))))) -let (env_dependent_ops : - FStar_TypeChecker_Env.env_t -> - FStar_TypeChecker_Primops_Base.primitive_step Prims.list) - = fun env -> FStar_TypeChecker_Primops_Eq.dec_eq_ops env -let (simplification_ops_list : - FStar_TypeChecker_Env.env_t -> - FStar_TypeChecker_Primops_Base.primitive_step Prims.list) - = - fun env -> - let uu___ = FStar_TypeChecker_Primops_Eq.prop_eq_ops env in - FStar_Compiler_List.op_At uu___ - FStar_TypeChecker_Primops_Real.simplify_ops \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Array.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Array.ml deleted file mode 100644 index 6bff76c0d1b..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Array.ml +++ /dev/null @@ -1,346 +0,0 @@ -open Prims -let (as_primitive_step : - Prims.bool -> - (FStar_Ident.lident * Prims.int * Prims.int * - FStar_TypeChecker_Primops_Base.interp_t * - (FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t FStar_Pervasives_Native.option)) - -> FStar_TypeChecker_Primops_Base.primitive_step) - = - fun is_strong -> - fun uu___ -> - match uu___ with - | (l, arity, u_arity, f, f_nbe) -> - FStar_TypeChecker_Primops_Base.as_primitive_step_nbecbs is_strong - (l, arity, u_arity, f, - (fun cb -> fun univs -> fun args -> f_nbe univs args)) -let (arg_as_int : - FStar_Syntax_Syntax.arg -> FStar_BigInt.t FStar_Pervasives_Native.option) = - fun a -> - FStar_TypeChecker_Primops_Base.try_unembed_simple - FStar_Syntax_Embeddings.e_int (FStar_Pervasives_Native.fst a) -let arg_as_list : - 'a . - 'a FStar_Syntax_Embeddings_Base.embedding -> - FStar_Syntax_Syntax.arg -> 'a Prims.list FStar_Pervasives_Native.option - = - fun e -> - fun a1 -> - FStar_TypeChecker_Primops_Base.try_unembed_simple - (FStar_Syntax_Embeddings.e_list e) (FStar_Pervasives_Native.fst a1) -let mixed_binary_op : - 'a 'b 'c . - (FStar_Syntax_Syntax.arg -> 'a FStar_Pervasives_Native.option) -> - (FStar_Syntax_Syntax.arg -> 'b FStar_Pervasives_Native.option) -> - (FStar_Compiler_Range_Type.range -> 'c -> FStar_Syntax_Syntax.term) - -> - (FStar_Compiler_Range_Type.range -> - FStar_Syntax_Syntax.universes -> - 'a -> 'b -> 'c FStar_Pervasives_Native.option) - -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option - = - fun as_a -> - fun as_b -> - fun embed_c -> - fun f -> - fun psc -> - fun norm_cb -> - fun univs -> - fun args -> - match args with - | a1::b1::[] -> - let uu___ = - let uu___1 = as_a a1 in - let uu___2 = as_b b1 in (uu___1, uu___2) in - (match uu___ with - | (FStar_Pervasives_Native.Some a2, - FStar_Pervasives_Native.Some b2) -> - let uu___1 = - f psc.FStar_TypeChecker_Primops_Base.psc_range - univs a2 b2 in - (match uu___1 with - | FStar_Pervasives_Native.Some c1 -> - let uu___2 = - embed_c - psc.FStar_TypeChecker_Primops_Base.psc_range - c1 in - FStar_Pervasives_Native.Some uu___2 - | uu___2 -> FStar_Pervasives_Native.None) - | uu___1 -> FStar_Pervasives_Native.None) - | uu___ -> FStar_Pervasives_Native.None -let mixed_ternary_op : - 'a 'b 'c 'd . - (FStar_Syntax_Syntax.arg -> 'a FStar_Pervasives_Native.option) -> - (FStar_Syntax_Syntax.arg -> 'b FStar_Pervasives_Native.option) -> - (FStar_Syntax_Syntax.arg -> 'c FStar_Pervasives_Native.option) -> - (FStar_Compiler_Range_Type.range -> 'd -> FStar_Syntax_Syntax.term) - -> - (FStar_Compiler_Range_Type.range -> - FStar_Syntax_Syntax.universes -> - 'a -> 'b -> 'c -> 'd FStar_Pervasives_Native.option) - -> - FStar_TypeChecker_Primops_Base.psc -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option - = - fun as_a -> - fun as_b -> - fun as_c -> - fun embed_d -> - fun f -> - fun psc -> - fun norm_cb -> - fun univs -> - fun args -> - match args with - | a1::b1::c1::[] -> - let uu___ = - let uu___1 = as_a a1 in - let uu___2 = as_b b1 in - let uu___3 = as_c c1 in (uu___1, uu___2, uu___3) in - (match uu___ with - | (FStar_Pervasives_Native.Some a2, - FStar_Pervasives_Native.Some b2, - FStar_Pervasives_Native.Some c2) -> - let uu___1 = - f psc.FStar_TypeChecker_Primops_Base.psc_range - univs a2 b2 c2 in - (match uu___1 with - | FStar_Pervasives_Native.Some d1 -> - let uu___2 = - embed_d - psc.FStar_TypeChecker_Primops_Base.psc_range - d1 in - FStar_Pervasives_Native.Some uu___2 - | uu___2 -> FStar_Pervasives_Native.None) - | uu___1 -> FStar_Pervasives_Native.None) - | uu___ -> FStar_Pervasives_Native.None -let (bogus_cbs : FStar_TypeChecker_NBETerm.nbe_cbs) = - { - FStar_TypeChecker_NBETerm.iapp = (fun h -> fun _args -> h); - FStar_TypeChecker_NBETerm.translate = - (fun uu___ -> failwith "bogus_cbs translate") - } -let (ops : FStar_TypeChecker_Primops_Base.primitive_step Prims.list) = - let of_list_op = - let emb_typ t = - let uu___ = - let uu___1 = - FStar_Ident.string_of_lid FStar_Parser_Const.immutable_array_t_lid in - (uu___1, [t]) in - FStar_Syntax_Syntax.ET_app uu___ in - let un_lazy universes t l r = - let uu___ = - let uu___1 = - FStar_Syntax_Util.fvar_const - FStar_Parser_Const.immutable_array_of_list_lid in - FStar_Syntax_Syntax.mk_Tm_uinst uu___1 universes in - let uu___1 = - let uu___2 = FStar_Syntax_Syntax.iarg t in - let uu___3 = let uu___4 = FStar_Syntax_Syntax.as_arg l in [uu___4] in - uu___2 :: uu___3 in - FStar_Syntax_Syntax.mk_Tm_app uu___ uu___1 r in - (FStar_Parser_Const.immutable_array_of_list_lid, (Prims.of_int (2)), - Prims.int_one, - (mixed_binary_op - (fun uu___ -> - match uu___ with - | (elt_t, uu___1) -> FStar_Pervasives_Native.Some elt_t) - (fun uu___ -> - match uu___ with - | (l, q) -> - let uu___1 = arg_as_list FStar_Syntax_Embeddings.e_any (l, q) in - (match uu___1 with - | FStar_Pervasives_Native.Some lst -> - FStar_Pervasives_Native.Some (l, lst) - | uu___2 -> FStar_Pervasives_Native.None)) - (fun r -> - fun uu___ -> - match uu___ with - | (universes, elt_t, (l, blob)) -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Embeddings_Base.emb_typ_of - FStar_Syntax_Embeddings.e_any () in - emb_typ uu___6 in - let uu___6 = - FStar_Thunk.mk - (fun uu___7 -> un_lazy universes elt_t l r) in - (uu___5, uu___6) in - FStar_Syntax_Syntax.Lazy_embedding uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Util.fvar_const - FStar_Parser_Const.immutable_array_t_lid in - FStar_Syntax_Syntax.mk_Tm_uinst uu___6 universes in - let uu___6 = - let uu___7 = FStar_Syntax_Syntax.as_arg elt_t in - [uu___7] in - FStar_Syntax_Syntax.mk_Tm_app uu___5 uu___6 r in - { - FStar_Syntax_Syntax.blob = blob; - FStar_Syntax_Syntax.lkind = uu___3; - FStar_Syntax_Syntax.ltyp = uu___4; - FStar_Syntax_Syntax.rng = r - } in - FStar_Syntax_Syntax.Tm_lazy uu___2 in - FStar_Syntax_Syntax.mk uu___1 r) - (fun r -> - fun universes -> - fun elt_t -> - fun uu___ -> - match uu___ with - | (l, lst) -> - let blob = FStar_ImmutableArray_Base.of_list lst in - FStar_Pervasives_Native.Some - (universes, elt_t, (l, (FStar_Dyn.mkdyn blob))))), - (FStar_TypeChecker_NBETerm.mixed_binary_op - (fun uu___ -> - match uu___ with - | (elt_t, uu___1) -> FStar_Pervasives_Native.Some elt_t) - (fun uu___ -> - match uu___ with - | (l, q) -> - let uu___1 = - FStar_TypeChecker_NBETerm.arg_as_list - FStar_TypeChecker_NBETerm.e_any (l, q) in - (match uu___1 with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some lst -> - FStar_Pervasives_Native.Some (l, lst))) - (fun uu___ -> - match uu___ with - | (universes, elt_t, (l, blob)) -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Embeddings_Base.emb_typ_of - FStar_Syntax_Embeddings.e_any () in - emb_typ uu___6 in - (blob, uu___5) in - FStar_Pervasives.Inr uu___4 in - let uu___4 = - FStar_Thunk.mk - (fun uu___5 -> - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Syntax_Syntax.lid_as_fv - FStar_Parser_Const.immutable_array_of_list_lid - FStar_Pervasives_Native.None in - let uu___9 = - let uu___10 = - FStar_TypeChecker_NBETerm.as_arg l in - [uu___10] in - (uu___8, universes, uu___9) in - FStar_TypeChecker_NBETerm.FV uu___7 in - FStar_TypeChecker_NBETerm.mk_t uu___6) in - (uu___3, uu___4) in - FStar_TypeChecker_NBETerm.Lazy uu___2 in - FStar_TypeChecker_NBETerm.mk_t uu___1) - (fun universes -> - fun elt_t -> - fun uu___ -> - match uu___ with - | (l, lst) -> - let blob = FStar_ImmutableArray_Base.of_list lst in - FStar_Pervasives_Native.Some - (universes, elt_t, (l, (FStar_Dyn.mkdyn blob)))))) in - let arg1_as_elt_t x = - FStar_Pervasives_Native.Some (FStar_Pervasives_Native.fst x) in - let arg2_as_blob x = - let uu___ = - let uu___1 = - FStar_Syntax_Subst.compress (FStar_Pervasives_Native.fst x) in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_lazy - { FStar_Syntax_Syntax.blob = blob; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_embedding - (FStar_Syntax_Syntax.ET_app (head, uu___1), uu___2); - FStar_Syntax_Syntax.ltyp = uu___3; - FStar_Syntax_Syntax.rng = uu___4;_} - when - let uu___5 = - FStar_Ident.string_of_lid FStar_Parser_Const.immutable_array_t_lid in - head = uu___5 -> FStar_Pervasives_Native.Some blob - | uu___1 -> FStar_Pervasives_Native.None in - let arg2_as_blob_nbe x = - match (FStar_Pervasives_Native.fst x).FStar_TypeChecker_NBETerm.nbe_t - with - | FStar_TypeChecker_NBETerm.Lazy - (FStar_Pervasives.Inr - (blob, FStar_Syntax_Syntax.ET_app (head, uu___)), uu___1) - when - let uu___2 = - FStar_Ident.string_of_lid FStar_Parser_Const.immutable_array_t_lid in - head = uu___2 -> FStar_Pervasives_Native.Some blob - | uu___ -> FStar_Pervasives_Native.None in - let length_op = - let embed_int r i = - FStar_TypeChecker_Primops_Base.embed_simple - FStar_Syntax_Embeddings.e_int r i in - let run_op blob = - let uu___ = - let uu___1 = FStar_Dyn.undyn blob in - FStar_Compiler_Util.array_length uu___1 in - FStar_Pervasives_Native.Some uu___ in - (FStar_Parser_Const.immutable_array_length_lid, (Prims.of_int (2)), - Prims.int_one, - (mixed_binary_op arg1_as_elt_t arg2_as_blob embed_int - (fun _r -> fun _universes -> fun uu___ -> fun blob -> run_op blob)), - (FStar_TypeChecker_NBETerm.mixed_binary_op - (fun uu___ -> - match uu___ with - | (elt_t, uu___1) -> FStar_Pervasives_Native.Some elt_t) - arg2_as_blob_nbe - (fun i -> - FStar_TypeChecker_NBETerm.embed FStar_TypeChecker_NBETerm.e_int - bogus_cbs i) - (fun _universes -> fun uu___ -> fun blob -> run_op blob))) in - let index_op = - (FStar_Parser_Const.immutable_array_index_lid, (Prims.of_int (3)), - Prims.int_one, - (mixed_ternary_op arg1_as_elt_t arg2_as_blob arg_as_int - (fun r -> fun tm -> tm) - (fun r -> - fun _universes -> - fun _t -> - fun blob -> - fun i -> - let uu___ = - let uu___1 = FStar_Dyn.undyn blob in - FStar_Compiler_Util.array_index uu___1 i in - FStar_Pervasives_Native.Some uu___)), - (FStar_TypeChecker_NBETerm.mixed_ternary_op - (fun uu___ -> - match uu___ with - | (elt_t, uu___1) -> FStar_Pervasives_Native.Some elt_t) - arg2_as_blob_nbe FStar_TypeChecker_NBETerm.arg_as_int (fun tm -> tm) - (fun _universes -> - fun _t -> - fun blob -> - fun i -> - let uu___ = - let uu___1 = FStar_Dyn.undyn blob in - FStar_Compiler_Util.array_index uu___1 i in - FStar_Pervasives_Native.Some uu___))) in - FStar_Compiler_List.map (as_primitive_step true) - [of_list_op; length_op; index_op] \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Base.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Base.ml deleted file mode 100644 index 46402583533..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Base.ml +++ /dev/null @@ -1,2239 +0,0 @@ -open Prims -type psc = - { - psc_range: FStar_Compiler_Range_Type.range ; - psc_subst: unit -> FStar_Syntax_Syntax.subst_t } -let (__proj__Mkpsc__item__psc_range : psc -> FStar_Compiler_Range_Type.range) - = - fun projectee -> - match projectee with | { psc_range; psc_subst;_} -> psc_range -let (__proj__Mkpsc__item__psc_subst : - psc -> unit -> FStar_Syntax_Syntax.subst_t) = - fun projectee -> - match projectee with | { psc_range; psc_subst;_} -> psc_subst -let (null_psc : psc) = - { - psc_range = FStar_Compiler_Range_Type.dummyRange; - psc_subst = (fun uu___ -> []) - } -let (psc_range : psc -> FStar_Compiler_Range_Type.range) = - fun psc1 -> psc1.psc_range -let (psc_subst : psc -> FStar_Syntax_Syntax.subst_t) = - fun psc1 -> psc1.psc_subst () -type interp_t = - psc -> - FStar_Syntax_Embeddings_Base.norm_cb -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option -type nbe_interp_t = - FStar_TypeChecker_NBETerm.nbe_cbs -> - FStar_Syntax_Syntax.universes -> - FStar_TypeChecker_NBETerm.args -> - FStar_TypeChecker_NBETerm.t FStar_Pervasives_Native.option -type primitive_step = - { - name: FStar_Ident.lid ; - arity: Prims.int ; - univ_arity: Prims.int ; - auto_reflect: Prims.int FStar_Pervasives_Native.option ; - strong_reduction_ok: Prims.bool ; - requires_binder_substitution: Prims.bool ; - renorm_after: Prims.bool ; - interpretation: interp_t ; - interpretation_nbe: nbe_interp_t } -let (__proj__Mkprimitive_step__item__name : - primitive_step -> FStar_Ident.lid) = - fun projectee -> - match projectee with - | { name; arity; univ_arity; auto_reflect; strong_reduction_ok; - requires_binder_substitution; renorm_after; interpretation; - interpretation_nbe;_} -> name -let (__proj__Mkprimitive_step__item__arity : primitive_step -> Prims.int) = - fun projectee -> - match projectee with - | { name; arity; univ_arity; auto_reflect; strong_reduction_ok; - requires_binder_substitution; renorm_after; interpretation; - interpretation_nbe;_} -> arity -let (__proj__Mkprimitive_step__item__univ_arity : - primitive_step -> Prims.int) = - fun projectee -> - match projectee with - | { name; arity; univ_arity; auto_reflect; strong_reduction_ok; - requires_binder_substitution; renorm_after; interpretation; - interpretation_nbe;_} -> univ_arity -let (__proj__Mkprimitive_step__item__auto_reflect : - primitive_step -> Prims.int FStar_Pervasives_Native.option) = - fun projectee -> - match projectee with - | { name; arity; univ_arity; auto_reflect; strong_reduction_ok; - requires_binder_substitution; renorm_after; interpretation; - interpretation_nbe;_} -> auto_reflect -let (__proj__Mkprimitive_step__item__strong_reduction_ok : - primitive_step -> Prims.bool) = - fun projectee -> - match projectee with - | { name; arity; univ_arity; auto_reflect; strong_reduction_ok; - requires_binder_substitution; renorm_after; interpretation; - interpretation_nbe;_} -> strong_reduction_ok -let (__proj__Mkprimitive_step__item__requires_binder_substitution : - primitive_step -> Prims.bool) = - fun projectee -> - match projectee with - | { name; arity; univ_arity; auto_reflect; strong_reduction_ok; - requires_binder_substitution; renorm_after; interpretation; - interpretation_nbe;_} -> requires_binder_substitution -let (__proj__Mkprimitive_step__item__renorm_after : - primitive_step -> Prims.bool) = - fun projectee -> - match projectee with - | { name; arity; univ_arity; auto_reflect; strong_reduction_ok; - requires_binder_substitution; renorm_after; interpretation; - interpretation_nbe;_} -> renorm_after -let (__proj__Mkprimitive_step__item__interpretation : - primitive_step -> interp_t) = - fun projectee -> - match projectee with - | { name; arity; univ_arity; auto_reflect; strong_reduction_ok; - requires_binder_substitution; renorm_after; interpretation; - interpretation_nbe;_} -> interpretation -let (__proj__Mkprimitive_step__item__interpretation_nbe : - primitive_step -> nbe_interp_t) = - fun projectee -> - match projectee with - | { name; arity; univ_arity; auto_reflect; strong_reduction_ok; - requires_binder_substitution; renorm_after; interpretation; - interpretation_nbe;_} -> interpretation_nbe -let embed_simple : - 'a . - 'a FStar_Syntax_Embeddings_Base.embedding -> - FStar_Compiler_Range_Type.range -> 'a -> FStar_Syntax_Syntax.term - = - fun uu___ -> - fun r -> - fun x -> - let uu___1 = FStar_Syntax_Embeddings_Base.embed uu___ x in - uu___1 r FStar_Pervasives_Native.None - FStar_Syntax_Embeddings_Base.id_norm_cb -let try_unembed_simple : - 'a . - 'a FStar_Syntax_Embeddings_Base.embedding -> - FStar_Syntax_Syntax.term -> 'a FStar_Pervasives_Native.option - = - fun uu___ -> - fun x -> - FStar_Syntax_Embeddings_Base.try_unembed uu___ x - FStar_Syntax_Embeddings_Base.id_norm_cb -let solve : 'a . 'a -> 'a = fun ev -> ev -let (as_primitive_step_nbecbs : - Prims.bool -> - (FStar_Ident.lident * Prims.int * Prims.int * interp_t * nbe_interp_t) -> - primitive_step) - = - fun is_strong -> - fun uu___ -> - match uu___ with - | (l, arity, u_arity, f, f_nbe) -> - { - name = l; - arity; - univ_arity = u_arity; - auto_reflect = FStar_Pervasives_Native.None; - strong_reduction_ok = is_strong; - requires_binder_substitution = false; - renorm_after = false; - interpretation = f; - interpretation_nbe = f_nbe - } -let mk_interp1 : - 'a 'r . - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> ('a -> 'r) -> interp_t - = - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun uu___ -> - fun uu___1 -> - fun f -> - fun psc1 -> - fun cb -> - fun us -> - fun args -> - match args with - | (a1, uu___2)::[] -> - Obj.magic - (Obj.repr - (let uu___3 = try_unembed_simple uu___ a1 in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic uu___3) - (fun uu___4 -> - (fun a2 -> - let a2 = Obj.magic a2 in - let uu___4 = - let uu___5 = f a2 in - embed_simple uu___1 psc1.psc_range - uu___5 in - Obj.magic - (FStar_Class_Monad.return - FStar_Class_Monad.monad_option - () (Obj.magic uu___4))) uu___4))) - | uu___2 -> Obj.magic (Obj.repr (failwith "arity"))) - uu___2 uu___1 uu___ -let mk_nbe_interp1 : - 'a 'r . - 'a FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> ('a -> 'r) -> nbe_interp_t - = - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun uu___ -> - fun uu___1 -> - fun f -> - fun cbs -> - fun us -> - fun args -> - match args with - | (a1, uu___2)::[] -> - Obj.magic - (Obj.repr - (let uu___3 = - let uu___4 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___) cbs a1 in - Obj.magic - (FStar_Class_Monad.op_Less_Dollar_Greater - FStar_Class_Monad.monad_option () () - (fun uu___5 -> (Obj.magic f) uu___5) - (Obj.magic uu___4)) in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic uu___3) - (fun uu___4 -> - (fun r1 -> - let r1 = Obj.magic r1 in - let uu___4 = - FStar_TypeChecker_NBETerm.embed - (solve uu___1) cbs r1 in - Obj.magic - (FStar_Class_Monad.return - FStar_Class_Monad.monad_option () - (Obj.magic uu___4))) uu___4))) - | uu___2 -> - Obj.magic (Obj.repr FStar_Pervasives_Native.None)) - uu___2 uu___1 uu___ -let mk_interp2 : - 'a 'b 'r . - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'b FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - ('a -> 'b -> 'r) -> interp_t - = - fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun f -> - fun psc1 -> - fun cb -> - fun us -> - fun args -> - match args with - | (a1, uu___3)::(b1, uu___4)::[] -> - Obj.magic - (Obj.repr - (let uu___5 = - let uu___6 = - let uu___7 = - try_unembed_simple uu___ a1 in - Obj.magic - (FStar_Class_Monad.op_Less_Dollar_Greater - FStar_Class_Monad.monad_option - () () - (fun uu___8 -> - (Obj.magic f) uu___8) - (Obj.magic uu___7)) in - let uu___7 = - try_unembed_simple uu___1 b1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option () - () (Obj.magic uu___6) - (Obj.magic uu___7)) in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic uu___5) - (fun uu___6 -> - (fun r1 -> - let r1 = Obj.magic r1 in - let uu___6 = - embed_simple uu___2 - psc1.psc_range r1 in - Obj.magic - (FStar_Class_Monad.return - FStar_Class_Monad.monad_option - () (Obj.magic uu___6))) - uu___6))) - | uu___3 -> - Obj.magic (Obj.repr (failwith "arity"))) - uu___3 uu___2 uu___1 uu___ -let mk_nbe_interp2 : - 'a 'b 'r . - 'a FStar_TypeChecker_NBETerm.embedding -> - 'b FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - ('a -> 'b -> 'r) -> nbe_interp_t - = - fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun f -> - fun cbs -> - fun us -> - fun args -> - match args with - | (a1, uu___3)::(b1, uu___4)::[] -> - Obj.magic - (Obj.repr - (let uu___5 = - let uu___6 = - let uu___7 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___) cbs a1 in - Obj.magic - (FStar_Class_Monad.op_Less_Dollar_Greater - FStar_Class_Monad.monad_option () - () - (fun uu___8 -> - (Obj.magic f) uu___8) - (Obj.magic uu___7)) in - let uu___7 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___1) cbs b1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option () - () (Obj.magic uu___6) - (Obj.magic uu___7)) in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic uu___5) - (fun uu___6 -> - (fun r1 -> - let r1 = Obj.magic r1 in - let uu___6 = - FStar_TypeChecker_NBETerm.embed - (solve uu___2) cbs r1 in - Obj.magic - (FStar_Class_Monad.return - FStar_Class_Monad.monad_option - () (Obj.magic uu___6))) - uu___6))) - | uu___3 -> - Obj.magic - (Obj.repr FStar_Pervasives_Native.None)) - uu___3 uu___2 uu___1 uu___ -let mk_interp3 : - 'a 'b 'c 'r . - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'b FStar_Syntax_Embeddings_Base.embedding -> - 'c FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - ('a -> 'b -> 'c -> 'r) -> interp_t - = - fun uu___4 -> - fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun f -> - fun psc1 -> - fun cb -> - fun us -> - fun args -> - match args with - | (a1, uu___4)::(b1, uu___5)::(c1, uu___6)::[] - -> - Obj.magic - (Obj.repr - (let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - try_unembed_simple uu___ a1 in - Obj.magic - (FStar_Class_Monad.op_Less_Dollar_Greater - FStar_Class_Monad.monad_option - () () - (fun uu___11 -> - (Obj.magic f) uu___11) - (Obj.magic uu___10)) in - let uu___10 = - try_unembed_simple uu___1 b1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () (Obj.magic uu___9) - (Obj.magic uu___10)) in - let uu___9 = - try_unembed_simple uu___2 c1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () (Obj.magic uu___8) - (Obj.magic uu___9)) in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () - () (Obj.magic uu___7) - (fun uu___8 -> - (fun r1 -> - let r1 = Obj.magic r1 in - let uu___8 = - embed_simple uu___3 - psc1.psc_range r1 in - Obj.magic - (FStar_Class_Monad.return - FStar_Class_Monad.monad_option - () (Obj.magic uu___8))) - uu___8))) - | uu___4 -> - Obj.magic (Obj.repr (failwith "arity"))) - uu___4 uu___3 uu___2 uu___1 uu___ -let mk_nbe_interp3 : - 'a 'b 'c 'r . - 'a FStar_TypeChecker_NBETerm.embedding -> - 'b FStar_TypeChecker_NBETerm.embedding -> - 'c FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - ('a -> 'b -> 'c -> 'r) -> nbe_interp_t - = - fun uu___4 -> - fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun f -> - fun cbs -> - fun us -> - fun args -> - match args with - | (a1, uu___4)::(b1, uu___5)::(c1, uu___6)::[] - -> - Obj.magic - (Obj.repr - (let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___) cbs a1 in - Obj.magic - (FStar_Class_Monad.op_Less_Dollar_Greater - FStar_Class_Monad.monad_option - () () - (fun uu___11 -> - (Obj.magic f) uu___11) - (Obj.magic uu___10)) in - let uu___10 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___1) cbs b1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () (Obj.magic uu___9) - (Obj.magic uu___10)) in - let uu___9 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___2) cbs c1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () (Obj.magic uu___8) - (Obj.magic uu___9)) in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic uu___7) - (fun uu___8 -> - (fun r1 -> - let r1 = Obj.magic r1 in - let uu___8 = - FStar_TypeChecker_NBETerm.embed - (solve uu___3) cbs r1 in - Obj.magic - (FStar_Class_Monad.return - FStar_Class_Monad.monad_option - () (Obj.magic uu___8))) - uu___8))) - | uu___4 -> - Obj.magic - (Obj.repr FStar_Pervasives_Native.None)) - uu___4 uu___3 uu___2 uu___1 uu___ -let mk_interp4 : - 'a 'b 'c 'd 'r . - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'b FStar_Syntax_Embeddings_Base.embedding -> - 'c FStar_Syntax_Embeddings_Base.embedding -> - 'd FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - ('a -> 'b -> 'c -> 'd -> 'r) -> interp_t - = - fun uu___5 -> - fun uu___4 -> - fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun uu___4 -> - fun f -> - fun psc1 -> - fun cb -> - fun us -> - fun args -> - match args with - | (a1, uu___5)::(b1, uu___6)::(c1, uu___7):: - (d1, uu___8)::[] -> - Obj.magic - (Obj.repr - (let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - try_unembed_simple - uu___ a1 in - Obj.magic - (FStar_Class_Monad.op_Less_Dollar_Greater - FStar_Class_Monad.monad_option - () () - (fun uu___14 -> - (Obj.magic f) - uu___14) - (Obj.magic uu___13)) in - let uu___13 = - try_unembed_simple - uu___1 b1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () - (Obj.magic uu___12) - (Obj.magic uu___13)) in - let uu___12 = - try_unembed_simple uu___2 - c1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () - (Obj.magic uu___11) - (Obj.magic uu___12)) in - let uu___11 = - try_unembed_simple uu___3 d1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () (Obj.magic uu___10) - (Obj.magic uu___11)) in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () (Obj.magic uu___9) - (fun uu___10 -> - (fun r1 -> - let r1 = Obj.magic r1 in - let uu___10 = - embed_simple uu___4 - psc1.psc_range r1 in - Obj.magic - (FStar_Class_Monad.return - FStar_Class_Monad.monad_option - () - (Obj.magic uu___10))) - uu___10))) - | uu___5 -> - Obj.magic - (Obj.repr (failwith "arity"))) - uu___5 uu___4 uu___3 uu___2 uu___1 uu___ -let mk_nbe_interp4 : - 'a 'b 'c 'd 'r . - 'a FStar_TypeChecker_NBETerm.embedding -> - 'b FStar_TypeChecker_NBETerm.embedding -> - 'c FStar_TypeChecker_NBETerm.embedding -> - 'd FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - ('a -> 'b -> 'c -> 'd -> 'r) -> nbe_interp_t - = - fun uu___5 -> - fun uu___4 -> - fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun uu___4 -> - fun f -> - fun cbs -> - fun us -> - fun args -> - match args with - | (a1, uu___5)::(b1, uu___6)::(c1, uu___7):: - (d1, uu___8)::[] -> - Obj.magic - (Obj.repr - (let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___) cbs a1 in - Obj.magic - (FStar_Class_Monad.op_Less_Dollar_Greater - FStar_Class_Monad.monad_option - () () - (fun uu___14 -> - (Obj.magic f) - uu___14) - (Obj.magic uu___13)) in - let uu___13 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___1) cbs b1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () - (Obj.magic uu___12) - (Obj.magic uu___13)) in - let uu___12 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___2) cbs c1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () (Obj.magic uu___11) - (Obj.magic uu___12)) in - let uu___11 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___3) cbs d1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () (Obj.magic uu___10) - (Obj.magic uu___11)) in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () (Obj.magic uu___9) - (fun uu___10 -> - (fun r1 -> - let r1 = Obj.magic r1 in - let uu___10 = - FStar_TypeChecker_NBETerm.embed - (solve uu___4) cbs r1 in - Obj.magic - (FStar_Class_Monad.return - FStar_Class_Monad.monad_option - () - (Obj.magic uu___10))) - uu___10))) - | uu___5 -> - Obj.magic - (Obj.repr FStar_Pervasives_Native.None)) - uu___5 uu___4 uu___3 uu___2 uu___1 uu___ -let mk_interp5 : - 'a 'b 'c 'd 'e 'r . - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'b FStar_Syntax_Embeddings_Base.embedding -> - 'c FStar_Syntax_Embeddings_Base.embedding -> - 'd FStar_Syntax_Embeddings_Base.embedding -> - 'e FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - ('a -> 'b -> 'c -> 'd -> 'e -> 'r) -> interp_t - = - fun uu___6 -> - fun uu___5 -> - fun uu___4 -> - fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun uu___4 -> - fun uu___5 -> - fun f -> - fun psc1 -> - fun cb -> - fun us -> - fun args -> - match args with - | (a1, uu___6)::(b1, uu___7):: - (c1, uu___8)::(d1, uu___9):: - (e1, uu___10)::[] -> - Obj.magic - (Obj.repr - (let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = - try_unembed_simple - uu___ a1 in - Obj.magic - (FStar_Class_Monad.op_Less_Dollar_Greater - FStar_Class_Monad.monad_option - () () - (fun uu___17 - -> - (Obj.magic - f) - uu___17) - (Obj.magic - uu___16)) in - let uu___16 = - try_unembed_simple - uu___1 b1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () - (Obj.magic - uu___15) - (Obj.magic - uu___16)) in - let uu___15 = - try_unembed_simple - uu___2 c1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () - (Obj.magic - uu___14) - (Obj.magic - uu___15)) in - let uu___14 = - try_unembed_simple - uu___3 d1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () - (Obj.magic uu___13) - (Obj.magic uu___14)) in - let uu___13 = - try_unembed_simple - uu___4 e1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () - (Obj.magic uu___12) - (Obj.magic uu___13)) in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () (Obj.magic uu___11) - (fun uu___12 -> - (fun r1 -> - let r1 = - Obj.magic r1 in - let uu___12 = - embed_simple - uu___5 - psc1.psc_range - r1 in - Obj.magic - (FStar_Class_Monad.return - FStar_Class_Monad.monad_option - () - (Obj.magic - uu___12))) - uu___12))) - | uu___6 -> - Obj.magic - (Obj.repr (failwith "arity"))) - uu___6 uu___5 uu___4 uu___3 uu___2 uu___1 uu___ -let mk_nbe_interp5 : - 'a 'b 'c 'd 'e 'r . - 'a FStar_TypeChecker_NBETerm.embedding -> - 'b FStar_TypeChecker_NBETerm.embedding -> - 'c FStar_TypeChecker_NBETerm.embedding -> - 'd FStar_TypeChecker_NBETerm.embedding -> - 'e FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - ('a -> 'b -> 'c -> 'd -> 'e -> 'r) -> nbe_interp_t - = - fun uu___6 -> - fun uu___5 -> - fun uu___4 -> - fun uu___3 -> - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun uu___4 -> - fun uu___5 -> - fun f -> - fun cbs -> - fun us -> - fun args -> - match args with - | (a1, uu___6)::(b1, uu___7)::(c1, - uu___8):: - (d1, uu___9)::(e1, uu___10)::[] -> - Obj.magic - (Obj.repr - (let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___) - cbs a1 in - Obj.magic - (FStar_Class_Monad.op_Less_Dollar_Greater - FStar_Class_Monad.monad_option - () () - (fun uu___17 -> - (Obj.magic f) - uu___17) - (Obj.magic - uu___16)) in - let uu___16 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___1) cbs - b1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () - (Obj.magic - uu___15) - (Obj.magic - uu___16)) in - let uu___15 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___2) cbs - c1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () - (Obj.magic uu___14) - (Obj.magic uu___15)) in - let uu___14 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___3) cbs d1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () - (Obj.magic uu___13) - (Obj.magic uu___14)) in - let uu___13 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___4) cbs e1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () - (Obj.magic uu___12) - (Obj.magic uu___13)) in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () (Obj.magic uu___11) - (fun uu___12 -> - (fun r1 -> - let r1 = Obj.magic r1 in - let uu___12 = - FStar_TypeChecker_NBETerm.embed - (solve uu___5) cbs - r1 in - Obj.magic - (FStar_Class_Monad.return - FStar_Class_Monad.monad_option - () - (Obj.magic - uu___12))) - uu___12))) - | uu___6 -> - Obj.magic - (Obj.repr - FStar_Pervasives_Native.None)) - uu___6 uu___5 uu___4 uu___3 uu___2 uu___1 uu___ -let mk1 : - 'a 'r . - Prims.int -> - FStar_Ident.lid -> - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'a FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - ('a -> 'r) -> primitive_step - = - fun u_arity -> - fun name -> - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun f -> - let interp = mk_interp1 uu___ uu___2 f in - let nbe_interp = mk_nbe_interp1 uu___1 uu___3 f in - as_primitive_step_nbecbs true - (name, Prims.int_one, u_arity, interp, nbe_interp) -let mk2 : - 'a 'b 'r . - Prims.int -> - FStar_Ident.lid -> - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'a FStar_TypeChecker_NBETerm.embedding -> - 'b FStar_Syntax_Embeddings_Base.embedding -> - 'b FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - ('a -> 'b -> 'r) -> primitive_step - = - fun u_arity -> - fun name -> - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun uu___4 -> - fun uu___5 -> - fun f -> - let interp = mk_interp2 uu___ uu___2 uu___4 f in - let nbe_interp = mk_nbe_interp2 uu___1 uu___3 uu___5 f in - as_primitive_step_nbecbs true - (name, (Prims.of_int (2)), u_arity, interp, nbe_interp) -let mk3 : - 'a 'b 'c 'r . - Prims.int -> - FStar_Ident.lid -> - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'a FStar_TypeChecker_NBETerm.embedding -> - 'b FStar_Syntax_Embeddings_Base.embedding -> - 'b FStar_TypeChecker_NBETerm.embedding -> - 'c FStar_Syntax_Embeddings_Base.embedding -> - 'c FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - ('a -> 'b -> 'c -> 'r) -> primitive_step - = - fun u_arity -> - fun name -> - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun uu___4 -> - fun uu___5 -> - fun uu___6 -> - fun uu___7 -> - fun f -> - let interp = mk_interp3 uu___ uu___2 uu___4 uu___6 f in - let nbe_interp = - mk_nbe_interp3 uu___1 uu___3 uu___5 uu___7 f in - as_primitive_step_nbecbs true - (name, (Prims.of_int (3)), u_arity, interp, - nbe_interp) -let mk4 : - 'a 'b 'c 'd 'r . - Prims.int -> - FStar_Ident.lid -> - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'a FStar_TypeChecker_NBETerm.embedding -> - 'b FStar_Syntax_Embeddings_Base.embedding -> - 'b FStar_TypeChecker_NBETerm.embedding -> - 'c FStar_Syntax_Embeddings_Base.embedding -> - 'c FStar_TypeChecker_NBETerm.embedding -> - 'd FStar_Syntax_Embeddings_Base.embedding -> - 'd FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - ('a -> 'b -> 'c -> 'd -> 'r) -> primitive_step - = - fun u_arity -> - fun name -> - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun uu___4 -> - fun uu___5 -> - fun uu___6 -> - fun uu___7 -> - fun uu___8 -> - fun uu___9 -> - fun f -> - let interp = - mk_interp4 uu___ uu___2 uu___4 uu___6 uu___8 f in - let nbe_interp = - mk_nbe_interp4 uu___1 uu___3 uu___5 uu___7 - uu___9 f in - as_primitive_step_nbecbs true - (name, (Prims.of_int (4)), u_arity, interp, - nbe_interp) -let mk5 : - 'a 'b 'c 'd 'e 'r . - Prims.int -> - FStar_Ident.lid -> - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'a FStar_TypeChecker_NBETerm.embedding -> - 'b FStar_Syntax_Embeddings_Base.embedding -> - 'b FStar_TypeChecker_NBETerm.embedding -> - 'c FStar_Syntax_Embeddings_Base.embedding -> - 'c FStar_TypeChecker_NBETerm.embedding -> - 'd FStar_Syntax_Embeddings_Base.embedding -> - 'd FStar_TypeChecker_NBETerm.embedding -> - 'e FStar_Syntax_Embeddings_Base.embedding -> - 'e FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - 'r FStar_TypeChecker_NBETerm.embedding -> - ('a -> 'b -> 'c -> 'd -> 'e -> 'r) -> - primitive_step - = - fun u_arity -> - fun name -> - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun uu___4 -> - fun uu___5 -> - fun uu___6 -> - fun uu___7 -> - fun uu___8 -> - fun uu___9 -> - fun uu___10 -> - fun uu___11 -> - fun f -> - let interp = - mk_interp5 uu___ uu___2 uu___4 uu___6 - uu___8 uu___10 f in - let nbe_interp = - mk_nbe_interp5 uu___1 uu___3 uu___5 uu___7 - uu___9 uu___11 f in - as_primitive_step_nbecbs true - (name, (Prims.of_int (5)), u_arity, interp, - nbe_interp) -let mk1' : - 'a 'r 'na 'nr . - Prims.int -> - FStar_Ident.lid -> - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'na FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - 'nr FStar_TypeChecker_NBETerm.embedding -> - ('a -> 'r FStar_Pervasives_Native.option) -> - ('na -> 'nr FStar_Pervasives_Native.option) -> - primitive_step - = - fun u_arity -> - fun name -> - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun f -> - fun nbe_f -> - let interp psc1 cb us args = - match args with - | (a1, uu___4)::[] -> - Obj.magic - (Obj.repr - (let uu___5 = - let uu___6 = try_unembed_simple uu___ a1 in - Obj.magic - (FStar_Class_Monad.op_Less_Dollar_Greater - FStar_Class_Monad.monad_option () () - (fun uu___7 -> (Obj.magic f) uu___7) - (Obj.magic uu___6)) in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic uu___5) - (fun uu___6 -> - (fun r1 -> - let r1 = Obj.magic r1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () - () (Obj.magic r1) - (fun uu___6 -> - (fun r2 -> - let r2 = Obj.magic r2 in - let uu___6 = - embed_simple uu___2 - psc1.psc_range r2 in - Obj.magic - (FStar_Class_Monad.return - FStar_Class_Monad.monad_option - () (Obj.magic uu___6))) - uu___6))) uu___6))) - | uu___4 -> Obj.magic (Obj.repr (failwith "arity")) in - let nbe_interp cbs us args = - match args with - | (a1, uu___4)::[] -> - Obj.magic - (Obj.repr - (let uu___5 = - let uu___6 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___1) cbs a1 in - Obj.magic - (FStar_Class_Monad.op_Less_Dollar_Greater - FStar_Class_Monad.monad_option () () - (fun uu___7 -> (Obj.magic nbe_f) uu___7) - (Obj.magic uu___6)) in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic uu___5) - (fun uu___6 -> - (fun r1 -> - let r1 = Obj.magic r1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () - () (Obj.magic r1) - (fun uu___6 -> - (fun r2 -> - let r2 = Obj.magic r2 in - let uu___6 = - FStar_TypeChecker_NBETerm.embed - (solve uu___3) cbs r2 in - Obj.magic - (FStar_Class_Monad.return - FStar_Class_Monad.monad_option - () (Obj.magic uu___6))) - uu___6))) uu___6))) - | uu___4 -> Obj.magic (Obj.repr (failwith "arity")) in - as_primitive_step_nbecbs true - (name, Prims.int_one, u_arity, interp, nbe_interp) -let mk1_psc' : - 'a 'r 'na 'nr . - Prims.int -> - FStar_Ident.lid -> - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'na FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - 'nr FStar_TypeChecker_NBETerm.embedding -> - (psc -> 'a -> 'r FStar_Pervasives_Native.option) -> - (psc -> 'na -> 'nr FStar_Pervasives_Native.option) -> - primitive_step - = - fun u_arity -> - fun name -> - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun f -> - fun nbe_f -> - let interp psc1 cb us args = - match args with - | (a1, uu___4)::[] -> - Obj.magic - (Obj.repr - (let uu___5 = - let uu___6 = try_unembed_simple uu___ a1 in - Obj.magic - (FStar_Class_Monad.op_Less_Dollar_Greater - FStar_Class_Monad.monad_option () () - (fun uu___7 -> - (Obj.magic (f psc1)) uu___7) - (Obj.magic uu___6)) in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic uu___5) - (fun uu___6 -> - (fun r1 -> - let r1 = Obj.magic r1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () - () (Obj.magic r1) - (fun uu___6 -> - (fun r2 -> - let r2 = Obj.magic r2 in - let uu___6 = - embed_simple uu___2 - psc1.psc_range r2 in - Obj.magic - (FStar_Class_Monad.return - FStar_Class_Monad.monad_option - () (Obj.magic uu___6))) - uu___6))) uu___6))) - | uu___4 -> Obj.magic (Obj.repr (failwith "arity")) in - let nbe_interp cbs us args = - match args with - | (a1, uu___4)::[] -> - Obj.magic - (Obj.repr - (let uu___5 = - let uu___6 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___1) cbs a1 in - Obj.magic - (FStar_Class_Monad.op_Less_Dollar_Greater - FStar_Class_Monad.monad_option () () - (fun uu___7 -> - (Obj.magic (nbe_f null_psc)) uu___7) - (Obj.magic uu___6)) in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic uu___5) - (fun uu___6 -> - (fun r1 -> - let r1 = Obj.magic r1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () - () (Obj.magic r1) - (fun uu___6 -> - (fun r2 -> - let r2 = Obj.magic r2 in - let uu___6 = - FStar_TypeChecker_NBETerm.embed - (solve uu___3) cbs r2 in - Obj.magic - (FStar_Class_Monad.return - FStar_Class_Monad.monad_option - () (Obj.magic uu___6))) - uu___6))) uu___6))) - | uu___4 -> Obj.magic (Obj.repr (failwith "arity")) in - as_primitive_step_nbecbs true - (name, Prims.int_one, u_arity, interp, nbe_interp) -let mk2' : - 'a 'b 'r 'na 'nb 'nr . - Prims.int -> - FStar_Ident.lid -> - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'na FStar_TypeChecker_NBETerm.embedding -> - 'b FStar_Syntax_Embeddings_Base.embedding -> - 'nb FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - 'nr FStar_TypeChecker_NBETerm.embedding -> - ('a -> 'b -> 'r FStar_Pervasives_Native.option) -> - ('na -> 'nb -> 'nr FStar_Pervasives_Native.option) -> - primitive_step - = - fun u_arity -> - fun name -> - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun uu___4 -> - fun uu___5 -> - fun f -> - fun nbe_f -> - let interp psc1 cb us args = - match args with - | (a1, uu___6)::(b1, uu___7)::[] -> - Obj.magic - (Obj.repr - (let uu___8 = - let uu___9 = - let uu___10 = - try_unembed_simple uu___ a1 in - Obj.magic - (FStar_Class_Monad.op_Less_Dollar_Greater - FStar_Class_Monad.monad_option () - () - (fun uu___11 -> - (Obj.magic f) uu___11) - (Obj.magic uu___10)) in - let uu___10 = - try_unembed_simple uu___2 b1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option () () - (Obj.magic uu___9) - (Obj.magic uu___10)) in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic uu___8) - (fun uu___9 -> - (fun r1 -> - let r1 = Obj.magic r1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () (Obj.magic r1) - (fun uu___9 -> - (fun r2 -> - let r2 = Obj.magic r2 in - let uu___9 = - embed_simple uu___4 - psc1.psc_range r2 in - Obj.magic - (FStar_Class_Monad.return - FStar_Class_Monad.monad_option - () - (Obj.magic uu___9))) - uu___9))) uu___9))) - | uu___6 -> Obj.magic (Obj.repr (failwith "arity")) in - let nbe_interp cbs us args = - match args with - | (a1, uu___6)::(b1, uu___7)::[] -> - Obj.magic - (Obj.repr - (let uu___8 = - let uu___9 = - let uu___10 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___1) cbs a1 in - Obj.magic - (FStar_Class_Monad.op_Less_Dollar_Greater - FStar_Class_Monad.monad_option () - () - (fun uu___11 -> - (Obj.magic nbe_f) uu___11) - (Obj.magic uu___10)) in - let uu___10 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___3) cbs b1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option () () - (Obj.magic uu___9) - (Obj.magic uu___10)) in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic uu___8) - (fun uu___9 -> - (fun r1 -> - let r1 = Obj.magic r1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () (Obj.magic r1) - (fun uu___9 -> - (fun r2 -> - let r2 = Obj.magic r2 in - let uu___9 = - FStar_TypeChecker_NBETerm.embed - (solve uu___5) cbs - r2 in - Obj.magic - (FStar_Class_Monad.return - FStar_Class_Monad.monad_option - () - (Obj.magic uu___9))) - uu___9))) uu___9))) - | uu___6 -> Obj.magic (Obj.repr (failwith "arity")) in - as_primitive_step_nbecbs true - (name, (Prims.of_int (2)), u_arity, interp, - nbe_interp) -let mk3' : - 'a 'b 'c 'r 'na 'nb 'nc 'nr . - Prims.int -> - FStar_Ident.lid -> - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'na FStar_TypeChecker_NBETerm.embedding -> - 'b FStar_Syntax_Embeddings_Base.embedding -> - 'nb FStar_TypeChecker_NBETerm.embedding -> - 'c FStar_Syntax_Embeddings_Base.embedding -> - 'nc FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - 'nr FStar_TypeChecker_NBETerm.embedding -> - ('a -> 'b -> 'c -> 'r FStar_Pervasives_Native.option) - -> - ('na -> - 'nb -> 'nc -> 'nr FStar_Pervasives_Native.option) - -> primitive_step - = - fun u_arity -> - fun name -> - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun uu___4 -> - fun uu___5 -> - fun uu___6 -> - fun uu___7 -> - fun f -> - fun nbe_f -> - let interp psc1 cb us args = - match args with - | (a1, uu___8)::(b1, uu___9)::(c1, uu___10)::[] - -> - Obj.magic - (Obj.repr - (let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - try_unembed_simple uu___ a1 in - Obj.magic - (FStar_Class_Monad.op_Less_Dollar_Greater - FStar_Class_Monad.monad_option - () () - (fun uu___15 -> - (Obj.magic f) uu___15) - (Obj.magic uu___14)) in - let uu___14 = - try_unembed_simple uu___2 b1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () (Obj.magic uu___13) - (Obj.magic uu___14)) in - let uu___13 = - try_unembed_simple uu___4 c1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () (Obj.magic uu___12) - (Obj.magic uu___13)) in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic uu___11) - (fun uu___12 -> - (fun r1 -> - let r1 = Obj.magic r1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () (Obj.magic r1) - (fun uu___12 -> - (fun r2 -> - let r2 = - Obj.magic r2 in - let uu___12 = - embed_simple - uu___6 - psc1.psc_range - r2 in - Obj.magic - (FStar_Class_Monad.return - FStar_Class_Monad.monad_option - () - (Obj.magic - uu___12))) - uu___12))) uu___12))) - | uu___8 -> - Obj.magic (Obj.repr (failwith "arity")) in - let nbe_interp cbs us args = - match args with - | (a1, uu___8)::(b1, uu___9)::(c1, uu___10)::[] - -> - Obj.magic - (Obj.repr - (let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___1) cbs a1 in - Obj.magic - (FStar_Class_Monad.op_Less_Dollar_Greater - FStar_Class_Monad.monad_option - () () - (fun uu___15 -> - (Obj.magic nbe_f) uu___15) - (Obj.magic uu___14)) in - let uu___14 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___3) cbs b1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () (Obj.magic uu___13) - (Obj.magic uu___14)) in - let uu___13 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___5) cbs c1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () (Obj.magic uu___12) - (Obj.magic uu___13)) in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic uu___11) - (fun uu___12 -> - (fun r1 -> - let r1 = Obj.magic r1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () (Obj.magic r1) - (fun uu___12 -> - (fun r2 -> - let r2 = - Obj.magic r2 in - let uu___12 = - FStar_TypeChecker_NBETerm.embed - (solve uu___7) - cbs r2 in - Obj.magic - (FStar_Class_Monad.return - FStar_Class_Monad.monad_option - () - (Obj.magic - uu___12))) - uu___12))) uu___12))) - | uu___8 -> - Obj.magic (Obj.repr (failwith "arity")) in - as_primitive_step_nbecbs true - (name, (Prims.of_int (3)), u_arity, interp, - nbe_interp) -let mk4' : - 'a 'b 'c 'd 'r 'na 'nb 'nc 'nd 'nr . - Prims.int -> - FStar_Ident.lid -> - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'na FStar_TypeChecker_NBETerm.embedding -> - 'b FStar_Syntax_Embeddings_Base.embedding -> - 'nb FStar_TypeChecker_NBETerm.embedding -> - 'c FStar_Syntax_Embeddings_Base.embedding -> - 'nc FStar_TypeChecker_NBETerm.embedding -> - 'd FStar_Syntax_Embeddings_Base.embedding -> - 'nd FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - 'nr FStar_TypeChecker_NBETerm.embedding -> - ('a -> - 'b -> - 'c -> - 'd -> 'r FStar_Pervasives_Native.option) - -> - ('na -> - 'nb -> - 'nc -> - 'nd -> - 'nr FStar_Pervasives_Native.option) - -> primitive_step - = - fun u_arity -> - fun name -> - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun uu___4 -> - fun uu___5 -> - fun uu___6 -> - fun uu___7 -> - fun uu___8 -> - fun uu___9 -> - fun f -> - fun nbe_f -> - let interp psc1 cb us args = - match args with - | (a1, uu___10)::(b1, uu___11)::(c1, uu___12):: - (d1, uu___13)::[] -> - Obj.magic - (Obj.repr - (let uu___14 = - let uu___15 = - let uu___16 = - let uu___17 = - let uu___18 = - try_unembed_simple uu___ - a1 in - Obj.magic - (FStar_Class_Monad.op_Less_Dollar_Greater - FStar_Class_Monad.monad_option - () () - (fun uu___19 -> - (Obj.magic f) - uu___19) - (Obj.magic uu___18)) in - let uu___18 = - try_unembed_simple uu___2 - b1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () - (Obj.magic uu___17) - (Obj.magic uu___18)) in - let uu___17 = - try_unembed_simple uu___4 c1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () (Obj.magic uu___16) - (Obj.magic uu___17)) in - let uu___16 = - try_unembed_simple uu___6 d1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () (Obj.magic uu___15) - (Obj.magic uu___16)) in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () - () (Obj.magic uu___14) - (fun uu___15 -> - (fun r1 -> - let r1 = Obj.magic r1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () (Obj.magic r1) - (fun uu___15 -> - (fun r2 -> - let r2 = - Obj.magic r2 in - let uu___15 = - embed_simple - uu___8 - psc1.psc_range - r2 in - Obj.magic - (FStar_Class_Monad.return - FStar_Class_Monad.monad_option - () - (Obj.magic - uu___15))) - uu___15))) - uu___15))) - | uu___10 -> - Obj.magic (Obj.repr (failwith "arity")) in - let nbe_interp cbs us args = - match args with - | (a1, uu___10)::(b1, uu___11)::(c1, uu___12):: - (d1, uu___13)::[] -> - Obj.magic - (Obj.repr - (let uu___14 = - let uu___15 = - let uu___16 = - let uu___17 = - let uu___18 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___1) cbs a1 in - Obj.magic - (FStar_Class_Monad.op_Less_Dollar_Greater - FStar_Class_Monad.monad_option - () () - (fun uu___19 -> - (Obj.magic nbe_f) - uu___19) - (Obj.magic uu___18)) in - let uu___18 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___3) cbs b1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () - (Obj.magic uu___17) - (Obj.magic uu___18)) in - let uu___17 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___5) cbs c1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () (Obj.magic uu___16) - (Obj.magic uu___17)) in - let uu___16 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___7) cbs d1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () (Obj.magic uu___15) - (Obj.magic uu___16)) in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () - () (Obj.magic uu___14) - (fun uu___15 -> - (fun r1 -> - let r1 = Obj.magic r1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () (Obj.magic r1) - (fun uu___15 -> - (fun r2 -> - let r2 = - Obj.magic r2 in - let uu___15 = - FStar_TypeChecker_NBETerm.embed - (solve - uu___9) - cbs r2 in - Obj.magic - (FStar_Class_Monad.return - FStar_Class_Monad.monad_option - () - (Obj.magic - uu___15))) - uu___15))) - uu___15))) - | uu___10 -> - Obj.magic (Obj.repr (failwith "arity")) in - as_primitive_step_nbecbs true - (name, (Prims.of_int (4)), u_arity, interp, - nbe_interp) -let mk5' : - 'a 'b 'c 'd 'e 'r 'na 'nb 'nc 'nd 'ne 'nr . - Prims.int -> - FStar_Ident.lid -> - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'na FStar_TypeChecker_NBETerm.embedding -> - 'b FStar_Syntax_Embeddings_Base.embedding -> - 'nb FStar_TypeChecker_NBETerm.embedding -> - 'c FStar_Syntax_Embeddings_Base.embedding -> - 'nc FStar_TypeChecker_NBETerm.embedding -> - 'd FStar_Syntax_Embeddings_Base.embedding -> - 'nd FStar_TypeChecker_NBETerm.embedding -> - 'e FStar_Syntax_Embeddings_Base.embedding -> - 'ne FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - 'nr FStar_TypeChecker_NBETerm.embedding -> - ('a -> - 'b -> - 'c -> - 'd -> - 'e -> - 'r FStar_Pervasives_Native.option) - -> - ('na -> - 'nb -> - 'nc -> - 'nd -> - 'ne -> - 'nr - FStar_Pervasives_Native.option) - -> primitive_step - = - fun u_arity -> - fun name -> - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun uu___4 -> - fun uu___5 -> - fun uu___6 -> - fun uu___7 -> - fun uu___8 -> - fun uu___9 -> - fun uu___10 -> - fun uu___11 -> - fun f -> - fun nbe_f -> - let interp psc1 cb us args = - match args with - | (a1, uu___12)::(b1, uu___13)::(c1, - uu___14):: - (d1, uu___15)::(e1, uu___16)::[] -> - Obj.magic - (Obj.repr - (let uu___17 = - let uu___18 = - let uu___19 = - let uu___20 = - let uu___21 = - let uu___22 = - try_unembed_simple - uu___ a1 in - Obj.magic - (FStar_Class_Monad.op_Less_Dollar_Greater - FStar_Class_Monad.monad_option - () () - (fun uu___23 -> - (Obj.magic f) - uu___23) - (Obj.magic - uu___22)) in - let uu___22 = - try_unembed_simple - uu___2 b1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () - (Obj.magic uu___21) - (Obj.magic uu___22)) in - let uu___21 = - try_unembed_simple - uu___4 c1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () - (Obj.magic uu___20) - (Obj.magic uu___21)) in - let uu___20 = - try_unembed_simple uu___6 - d1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () - (Obj.magic uu___19) - (Obj.magic uu___20)) in - let uu___19 = - try_unembed_simple uu___8 - e1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () - (Obj.magic uu___18) - (Obj.magic uu___19)) in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () (Obj.magic uu___17) - (fun uu___18 -> - (fun r1 -> - let r1 = Obj.magic r1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () - (Obj.magic r1) - (fun uu___18 -> - (fun r2 -> - let r2 = - Obj.magic - r2 in - let uu___18 - = - embed_simple - uu___10 - psc1.psc_range - r2 in - Obj.magic - (FStar_Class_Monad.return - FStar_Class_Monad.monad_option - () - (Obj.magic - uu___18))) - uu___18))) - uu___18))) - | uu___12 -> - Obj.magic - (Obj.repr (failwith "arity")) in - let nbe_interp cbs us args = - match args with - | (a1, uu___12)::(b1, uu___13)::(c1, - uu___14):: - (d1, uu___15)::(e1, uu___16)::[] -> - Obj.magic - (Obj.repr - (let uu___17 = - let uu___18 = - let uu___19 = - let uu___20 = - let uu___21 = - let uu___22 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___1) - cbs a1 in - Obj.magic - (FStar_Class_Monad.op_Less_Dollar_Greater - FStar_Class_Monad.monad_option - () () - (fun uu___23 -> - (Obj.magic - nbe_f) - uu___23) - (Obj.magic - uu___22)) in - let uu___22 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___3) cbs - b1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () - (Obj.magic uu___21) - (Obj.magic uu___22)) in - let uu___21 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___5) cbs c1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () - (Obj.magic uu___20) - (Obj.magic uu___21)) in - let uu___20 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___7) cbs d1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () - (Obj.magic uu___19) - (Obj.magic uu___20)) in - let uu___19 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___9) cbs e1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () - (Obj.magic uu___18) - (Obj.magic uu___19)) in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () (Obj.magic uu___17) - (fun uu___18 -> - (fun r1 -> - let r1 = Obj.magic r1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () - (Obj.magic r1) - (fun uu___18 -> - (fun r2 -> - let r2 = - Obj.magic - r2 in - let uu___18 - = - FStar_TypeChecker_NBETerm.embed - (solve - uu___11) - cbs r2 in - Obj.magic - (FStar_Class_Monad.return - FStar_Class_Monad.monad_option - () - (Obj.magic - uu___18))) - uu___18))) - uu___18))) - | uu___12 -> - Obj.magic - (Obj.repr (failwith "arity")) in - as_primitive_step_nbecbs true - (name, (Prims.of_int (5)), u_arity, - interp, nbe_interp) -let mk6' : - 'a 'b 'c 'd 'e 'f 'r 'na 'nb 'nc 'nd 'ne 'nf 'nr . - Prims.int -> - FStar_Ident.lid -> - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'na FStar_TypeChecker_NBETerm.embedding -> - 'b FStar_Syntax_Embeddings_Base.embedding -> - 'nb FStar_TypeChecker_NBETerm.embedding -> - 'c FStar_Syntax_Embeddings_Base.embedding -> - 'nc FStar_TypeChecker_NBETerm.embedding -> - 'd FStar_Syntax_Embeddings_Base.embedding -> - 'nd FStar_TypeChecker_NBETerm.embedding -> - 'e FStar_Syntax_Embeddings_Base.embedding -> - 'ne FStar_TypeChecker_NBETerm.embedding -> - 'f FStar_Syntax_Embeddings_Base.embedding -> - 'nf FStar_TypeChecker_NBETerm.embedding -> - 'r FStar_Syntax_Embeddings_Base.embedding -> - 'nr FStar_TypeChecker_NBETerm.embedding -> - ('a -> - 'b -> - 'c -> - 'd -> - 'e -> - 'f -> - 'r - FStar_Pervasives_Native.option) - -> - ('na -> - 'nb -> - 'nc -> - 'nd -> - 'ne -> - 'nf -> - 'nr - FStar_Pervasives_Native.option) - -> primitive_step - = - fun u_arity -> - fun name -> - fun uu___ -> - fun uu___1 -> - fun uu___2 -> - fun uu___3 -> - fun uu___4 -> - fun uu___5 -> - fun uu___6 -> - fun uu___7 -> - fun uu___8 -> - fun uu___9 -> - fun uu___10 -> - fun uu___11 -> - fun uu___12 -> - fun uu___13 -> - fun ff -> - fun nbe_ff -> - let interp psc1 cb us args = - match args with - | (a1, uu___14)::(b1, uu___15):: - (c1, uu___16)::(d1, uu___17):: - (e1, uu___18)::(f1, uu___19)::[] - -> - Obj.magic - (Obj.repr - (let uu___20 = - let uu___21 = - let uu___22 = - let uu___23 = - let uu___24 = - let uu___25 = - let uu___26 = - try_unembed_simple - uu___ a1 in - Obj.magic - (FStar_Class_Monad.op_Less_Dollar_Greater - FStar_Class_Monad.monad_option - () () - (fun - uu___27 - -> - (Obj.magic - ff) - uu___27) - (Obj.magic - uu___26)) in - let uu___26 = - try_unembed_simple - uu___2 b1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () - (Obj.magic - uu___25) - (Obj.magic - uu___26)) in - let uu___25 = - try_unembed_simple - uu___4 c1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () - (Obj.magic - uu___24) - (Obj.magic - uu___25)) in - let uu___24 = - try_unembed_simple - uu___6 d1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () - (Obj.magic - uu___23) - (Obj.magic - uu___24)) in - let uu___23 = - try_unembed_simple - uu___8 e1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () - (Obj.magic uu___22) - (Obj.magic uu___23)) in - let uu___22 = - try_unembed_simple - uu___10 f1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () - (Obj.magic uu___21) - (Obj.magic uu___22)) in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () (Obj.magic uu___20) - (fun uu___21 -> - (fun r1 -> - let r1 = - Obj.magic r1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () - (Obj.magic r1) - (fun uu___21 - -> - (fun r2 -> - let r2 = - Obj.magic - r2 in - let uu___21 - = - embed_simple - uu___12 - psc1.psc_range - r2 in - Obj.magic - (FStar_Class_Monad.return - FStar_Class_Monad.monad_option - () - (Obj.magic - uu___21))) - uu___21))) - uu___21))) - | uu___14 -> - Obj.magic - (Obj.repr (failwith "arity")) in - let nbe_interp cbs us args = - match args with - | (a1, uu___14)::(b1, uu___15):: - (c1, uu___16)::(d1, uu___17):: - (e1, uu___18)::(f1, uu___19)::[] - -> - Obj.magic - (Obj.repr - (let uu___20 = - let uu___21 = - let uu___22 = - let uu___23 = - let uu___24 = - let uu___25 = - let uu___26 = - FStar_TypeChecker_NBETerm.unembed - (solve - uu___1) - cbs a1 in - Obj.magic - (FStar_Class_Monad.op_Less_Dollar_Greater - FStar_Class_Monad.monad_option - () () - (fun - uu___27 - -> - (Obj.magic - nbe_ff) - uu___27) - (Obj.magic - uu___26)) in - let uu___26 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___3) - cbs b1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () - (Obj.magic - uu___25) - (Obj.magic - uu___26)) in - let uu___25 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___5) - cbs c1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () - (Obj.magic - uu___24) - (Obj.magic - uu___25)) in - let uu___24 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___7) - cbs d1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () - (Obj.magic - uu___23) - (Obj.magic - uu___24)) in - let uu___23 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___9) cbs - e1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () - (Obj.magic uu___22) - (Obj.magic uu___23)) in - let uu___22 = - FStar_TypeChecker_NBETerm.unembed - (solve uu___11) cbs - f1 in - Obj.magic - (FStar_Class_Monad.op_Less_Star_Greater - FStar_Class_Monad.monad_option - () () - (Obj.magic uu___21) - (Obj.magic uu___22)) in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () (Obj.magic uu___20) - (fun uu___21 -> - (fun r1 -> - let r1 = - Obj.magic r1 in - Obj.magic - (FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option - () () - (Obj.magic r1) - (fun uu___21 - -> - (fun r2 -> - let r2 = - Obj.magic - r2 in - let uu___21 - = - FStar_TypeChecker_NBETerm.embed - (solve - uu___13) - cbs r2 in - Obj.magic - (FStar_Class_Monad.return - FStar_Class_Monad.monad_option - () - (Obj.magic - uu___21))) - uu___21))) - uu___21))) - | uu___14 -> - Obj.magic - (Obj.repr (failwith "arity")) in - as_primitive_step_nbecbs true - (name, (Prims.of_int (6)), u_arity, - interp, nbe_interp) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Docs.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Docs.ml deleted file mode 100644 index 4e04fea11af..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Docs.ml +++ /dev/null @@ -1,18 +0,0 @@ -open Prims -let (ops : FStar_TypeChecker_Primops_Base.primitive_step Prims.list) = - let nm l = FStar_Parser_Const.p2l ["FStar"; "Stubs"; "Pprint"; l] in - let uu___ = - let uu___1 = nm "arbitrary_string" in - FStar_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___1 - FStar_Syntax_Embeddings.e_string FStar_TypeChecker_NBETerm.e_string - FStar_Syntax_Embeddings.e_document FStar_TypeChecker_NBETerm.e_document - FStar_Pprint.arbitrary_string in - let uu___1 = - let uu___2 = - let uu___3 = nm "render" in - FStar_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___3 - FStar_Syntax_Embeddings.e_document - FStar_TypeChecker_NBETerm.e_document FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string FStar_Pprint.render in - [uu___2] in - uu___ :: uu___1 \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Eq.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Eq.ml deleted file mode 100644 index 257be3a2c80..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Eq.ml +++ /dev/null @@ -1,282 +0,0 @@ -open Prims -let (s_eq : - FStar_TypeChecker_Env.env_t -> - FStar_Syntax_Embeddings.abstract_term -> - FStar_Syntax_Embeddings.abstract_term -> - FStar_Syntax_Embeddings.abstract_term -> - Prims.bool FStar_Pervasives_Native.option) - = - fun env -> - fun _typ -> - fun x -> - fun y -> - let uu___ = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env - (FStar_Syntax_Embeddings.__proj__Abstract__item__t x) - (FStar_Syntax_Embeddings.__proj__Abstract__item__t y) in - match uu___ with - | FStar_TypeChecker_TermEqAndSimplify.Equal -> - FStar_Pervasives_Native.Some true - | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> - FStar_Pervasives_Native.Some false - | uu___1 -> FStar_Pervasives_Native.None -let (nbe_eq : - FStar_TypeChecker_Env.env_t -> - FStar_TypeChecker_NBETerm.abstract_nbe_term -> - FStar_TypeChecker_NBETerm.abstract_nbe_term -> - FStar_TypeChecker_NBETerm.abstract_nbe_term -> - Prims.bool FStar_Pervasives_Native.option) - = - fun env -> - fun _typ -> - fun x -> - fun y -> - let uu___ = - FStar_TypeChecker_NBETerm.eq_t env - (FStar_TypeChecker_NBETerm.__proj__AbstractNBE__item__t x) - (FStar_TypeChecker_NBETerm.__proj__AbstractNBE__item__t y) in - match uu___ with - | FStar_TypeChecker_TermEqAndSimplify.Equal -> - FStar_Pervasives_Native.Some true - | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> - FStar_Pervasives_Native.Some false - | uu___1 -> FStar_Pervasives_Native.None -let push3 : - 'uuuuu 'uuuuu1 'uuuuu2 'uuuuu3 'uuuuu4 . - ('uuuuu -> 'uuuuu1) -> - ('uuuuu2 -> 'uuuuu3 -> 'uuuuu4 -> 'uuuuu) -> - 'uuuuu2 -> 'uuuuu3 -> 'uuuuu4 -> 'uuuuu1 - = - fun f -> fun g -> fun x -> fun y -> fun z -> let uu___ = g x y z in f uu___ -let negopt3 : - 'uuuuu 'uuuuu1 'uuuuu2 . - unit -> - ('uuuuu -> - 'uuuuu1 -> 'uuuuu2 -> Prims.bool FStar_Pervasives_Native.option) - -> - 'uuuuu -> - 'uuuuu1 -> 'uuuuu2 -> Prims.bool FStar_Pervasives_Native.option - = - fun uu___ -> - push3 - (fun uu___1 -> - (Obj.magic - (FStar_Class_Monad.fmap FStar_Class_Monad.monad_option () () - (fun uu___1 -> (Obj.magic Prims.op_Negation) uu___1))) uu___1) -let (dec_eq_ops : - FStar_TypeChecker_Env.env_t -> - FStar_TypeChecker_Primops_Base.primitive_step Prims.list) - = - fun env -> - let uu___ = - FStar_TypeChecker_Primops_Base.mk3' Prims.int_zero - FStar_Parser_Const.op_Eq FStar_Syntax_Embeddings.e_abstract_term - FStar_TypeChecker_NBETerm.e_abstract_nbe_term - FStar_Syntax_Embeddings.e_abstract_term - FStar_TypeChecker_NBETerm.e_abstract_nbe_term - FStar_Syntax_Embeddings.e_abstract_term - FStar_TypeChecker_NBETerm.e_abstract_nbe_term - FStar_Syntax_Embeddings.e_bool FStar_TypeChecker_NBETerm.e_bool - (s_eq env) (nbe_eq env) in - let uu___1 = - let uu___2 = - FStar_TypeChecker_Primops_Base.mk3' Prims.int_zero - FStar_Parser_Const.op_notEq FStar_Syntax_Embeddings.e_abstract_term - FStar_TypeChecker_NBETerm.e_abstract_nbe_term - FStar_Syntax_Embeddings.e_abstract_term - FStar_TypeChecker_NBETerm.e_abstract_nbe_term - FStar_Syntax_Embeddings.e_abstract_term - FStar_TypeChecker_NBETerm.e_abstract_nbe_term - FStar_Syntax_Embeddings.e_bool FStar_TypeChecker_NBETerm.e_bool - ((negopt3 ()) (s_eq env)) ((negopt3 ()) (nbe_eq env)) in - [uu___2] in - uu___ :: uu___1 -let (s_eq2 : - FStar_TypeChecker_Env.env_t -> - FStar_Syntax_Embeddings.abstract_term -> - FStar_Syntax_Embeddings.abstract_term -> - FStar_Syntax_Embeddings.abstract_term -> - FStar_Syntax_Embeddings.abstract_term - FStar_Pervasives_Native.option) - = - fun env -> - fun _typ -> - fun x -> - fun y -> - let uu___ = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env - (FStar_Syntax_Embeddings.__proj__Abstract__item__t x) - (FStar_Syntax_Embeddings.__proj__Abstract__item__t y) in - match uu___ with - | FStar_TypeChecker_TermEqAndSimplify.Equal -> - FStar_Pervasives_Native.Some - (FStar_Syntax_Embeddings.Abstract FStar_Syntax_Util.t_true) - | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> - FStar_Pervasives_Native.Some - (FStar_Syntax_Embeddings.Abstract FStar_Syntax_Util.t_false) - | uu___1 -> FStar_Pervasives_Native.None -let (nbe_eq2 : - FStar_TypeChecker_Env.env_t -> - FStar_TypeChecker_NBETerm.abstract_nbe_term -> - FStar_TypeChecker_NBETerm.abstract_nbe_term -> - FStar_TypeChecker_NBETerm.abstract_nbe_term -> - FStar_TypeChecker_NBETerm.abstract_nbe_term - FStar_Pervasives_Native.option) - = - fun env -> - fun _typ -> - fun x -> - fun y -> - let uu___ = - FStar_TypeChecker_NBETerm.eq_t env - (FStar_TypeChecker_NBETerm.__proj__AbstractNBE__item__t x) - (FStar_TypeChecker_NBETerm.__proj__AbstractNBE__item__t y) in - match uu___ with - | FStar_TypeChecker_TermEqAndSimplify.Equal -> - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Syntax_Syntax.lid_as_fv FStar_Parser_Const.true_lid - FStar_Pervasives_Native.None in - FStar_TypeChecker_NBETerm.mkFV uu___3 [] [] in - FStar_TypeChecker_NBETerm.AbstractNBE uu___2 in - FStar_Pervasives_Native.Some uu___1 - | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Syntax_Syntax.lid_as_fv - FStar_Parser_Const.false_lid - FStar_Pervasives_Native.None in - FStar_TypeChecker_NBETerm.mkFV uu___3 [] [] in - FStar_TypeChecker_NBETerm.AbstractNBE uu___2 in - FStar_Pervasives_Native.Some uu___1 - | FStar_TypeChecker_TermEqAndSimplify.Unknown -> - FStar_Pervasives_Native.None -let (s_eq3 : - FStar_TypeChecker_Env.env_t -> - FStar_Syntax_Embeddings.abstract_term -> - FStar_Syntax_Embeddings.abstract_term -> - FStar_Syntax_Embeddings.abstract_term -> - FStar_Syntax_Embeddings.abstract_term -> - FStar_Syntax_Embeddings.abstract_term - FStar_Pervasives_Native.option) - = - fun env -> - fun typ1 -> - fun typ2 -> - fun x -> - fun y -> - let uu___ = - let uu___1 = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env - (FStar_Syntax_Embeddings.__proj__Abstract__item__t typ1) - (FStar_Syntax_Embeddings.__proj__Abstract__item__t typ2) in - let uu___2 = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env - (FStar_Syntax_Embeddings.__proj__Abstract__item__t x) - (FStar_Syntax_Embeddings.__proj__Abstract__item__t y) in - (uu___1, uu___2) in - match uu___ with - | (FStar_TypeChecker_TermEqAndSimplify.Equal, - FStar_TypeChecker_TermEqAndSimplify.Equal) -> - FStar_Pervasives_Native.Some - (FStar_Syntax_Embeddings.Abstract FStar_Syntax_Util.t_true) - | (FStar_TypeChecker_TermEqAndSimplify.NotEqual, uu___1) -> - FStar_Pervasives_Native.Some - (FStar_Syntax_Embeddings.Abstract FStar_Syntax_Util.t_false) - | (uu___1, FStar_TypeChecker_TermEqAndSimplify.NotEqual) -> - FStar_Pervasives_Native.Some - (FStar_Syntax_Embeddings.Abstract FStar_Syntax_Util.t_false) - | uu___1 -> FStar_Pervasives_Native.None -let (nbe_eq3 : - FStar_TypeChecker_Env.env_t -> - FStar_TypeChecker_NBETerm.abstract_nbe_term -> - FStar_TypeChecker_NBETerm.abstract_nbe_term -> - FStar_TypeChecker_NBETerm.abstract_nbe_term -> - FStar_TypeChecker_NBETerm.abstract_nbe_term -> - FStar_TypeChecker_NBETerm.abstract_nbe_term - FStar_Pervasives_Native.option) - = - fun env -> - fun typ1 -> - fun typ2 -> - fun x -> - fun y -> - let uu___ = - let uu___1 = - FStar_TypeChecker_NBETerm.eq_t env - (FStar_TypeChecker_NBETerm.__proj__AbstractNBE__item__t - typ1) - (FStar_TypeChecker_NBETerm.__proj__AbstractNBE__item__t - typ2) in - let uu___2 = - FStar_TypeChecker_NBETerm.eq_t env - (FStar_TypeChecker_NBETerm.__proj__AbstractNBE__item__t x) - (FStar_TypeChecker_NBETerm.__proj__AbstractNBE__item__t y) in - (uu___1, uu___2) in - match uu___ with - | (FStar_TypeChecker_TermEqAndSimplify.Equal, - FStar_TypeChecker_TermEqAndSimplify.Equal) -> - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Syntax_Syntax.lid_as_fv - FStar_Parser_Const.true_lid - FStar_Pervasives_Native.None in - FStar_TypeChecker_NBETerm.mkFV uu___3 [] [] in - FStar_TypeChecker_NBETerm.AbstractNBE uu___2 in - FStar_Pervasives_Native.Some uu___1 - | (FStar_TypeChecker_TermEqAndSimplify.NotEqual, uu___1) -> - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Syntax_Syntax.lid_as_fv - FStar_Parser_Const.false_lid - FStar_Pervasives_Native.None in - FStar_TypeChecker_NBETerm.mkFV uu___4 [] [] in - FStar_TypeChecker_NBETerm.AbstractNBE uu___3 in - FStar_Pervasives_Native.Some uu___2 - | (uu___1, FStar_TypeChecker_TermEqAndSimplify.NotEqual) -> - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Syntax_Syntax.lid_as_fv - FStar_Parser_Const.false_lid - FStar_Pervasives_Native.None in - FStar_TypeChecker_NBETerm.mkFV uu___4 [] [] in - FStar_TypeChecker_NBETerm.AbstractNBE uu___3 in - FStar_Pervasives_Native.Some uu___2 - | uu___1 -> FStar_Pervasives_Native.None -let (prop_eq_ops : - FStar_TypeChecker_Env.env_t -> - FStar_TypeChecker_Primops_Base.primitive_step Prims.list) - = - fun env -> - let uu___ = - FStar_TypeChecker_Primops_Base.mk3' Prims.int_one - FStar_Parser_Const.eq2_lid FStar_Syntax_Embeddings.e_abstract_term - FStar_TypeChecker_NBETerm.e_abstract_nbe_term - FStar_Syntax_Embeddings.e_abstract_term - FStar_TypeChecker_NBETerm.e_abstract_nbe_term - FStar_Syntax_Embeddings.e_abstract_term - FStar_TypeChecker_NBETerm.e_abstract_nbe_term - FStar_Syntax_Embeddings.e_abstract_term - FStar_TypeChecker_NBETerm.e_abstract_nbe_term (s_eq2 env) - (nbe_eq2 env) in - let uu___1 = - let uu___2 = - FStar_TypeChecker_Primops_Base.mk4' (Prims.of_int (2)) - FStar_Parser_Const.eq3_lid FStar_Syntax_Embeddings.e_abstract_term - FStar_TypeChecker_NBETerm.e_abstract_nbe_term - FStar_Syntax_Embeddings.e_abstract_term - FStar_TypeChecker_NBETerm.e_abstract_nbe_term - FStar_Syntax_Embeddings.e_abstract_term - FStar_TypeChecker_NBETerm.e_abstract_nbe_term - FStar_Syntax_Embeddings.e_abstract_term - FStar_TypeChecker_NBETerm.e_abstract_nbe_term - FStar_Syntax_Embeddings.e_abstract_term - FStar_TypeChecker_NBETerm.e_abstract_nbe_term (s_eq3 env) - (nbe_eq3 env) in - [uu___2] in - uu___ :: uu___1 \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Erased.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Erased.ml deleted file mode 100644 index 251ff3b54fd..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Erased.ml +++ /dev/null @@ -1,150 +0,0 @@ -open Prims -type 'a emb_erased = - | Hide of 'a -let uu___is_Hide : 'a . 'a emb_erased -> Prims.bool = fun projectee -> true -let __proj__Hide__item__x : 'a . 'a emb_erased -> 'a = - fun projectee -> match projectee with | Hide x -> x -let e_erased : - 'a . - 'a FStar_Syntax_Embeddings_Base.embedding -> - 'a emb_erased FStar_Syntax_Embeddings_Base.embedding - = - fun d -> - let em x rng shadow cbs = - let uu___ = x in - match uu___ with - | Hide x1 -> - let h = - FStar_Syntax_Syntax.fvar FStar_Parser_Const.hide - FStar_Pervasives_Native.None in - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Embeddings_Base.type_of d in - FStar_Syntax_Syntax.iarg uu___3 in - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = FStar_Syntax_Embeddings_Base.embed d x1 in - uu___6 rng shadow cbs in - FStar_Syntax_Syntax.as_arg uu___5 in - [uu___4] in - uu___2 :: uu___3 in - FStar_Syntax_Util.mk_app h uu___1 in - let un uu___1 uu___ = - (fun t -> - fun cbs -> - let uu___ = FStar_Syntax_Util.head_and_args t in - match uu___ with - | (head, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst head in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, - _t::(a1, FStar_Pervasives_Native.None)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.hide - -> - Obj.magic - (Obj.repr - (let uu___2 = - FStar_Syntax_Embeddings_Base.unembed d a1 cbs in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic uu___2) - (fun uu___3 -> - (fun v -> - let v = Obj.magic v in - Obj.magic - (FStar_Class_Monad.return - FStar_Class_Monad.monad_option () - (Obj.magic (Hide v)))) uu___3))) - | uu___2 -> Obj.magic (Obj.repr FStar_Pervasives_Native.None))) - uu___1 uu___ in - FStar_Syntax_Embeddings_Base.mk_emb_full em un - (fun uu___ -> - let uu___1 = FStar_Syntax_Embeddings_Base.type_of d in - FStar_Syntax_Syntax.t_erased_of uu___1) - (fun uu___ -> - match uu___ with - | Hide x -> - let uu___1 = - let uu___2 = FStar_Syntax_Embeddings_Base.printer_of d in - uu___2 x in - Prims.strcat "Hide " uu___1) - (fun uu___ -> FStar_Syntax_Syntax.ET_abstract) -let nbe_e_erased : - 'a . - 'a FStar_TypeChecker_NBETerm.embedding -> - 'a emb_erased FStar_TypeChecker_NBETerm.embedding - = - fun d -> - let em cbs x = - let uu___ = x in - match uu___ with - | Hide x1 -> - let fv = - FStar_Syntax_Syntax.lid_as_fv FStar_Parser_Const.hide - FStar_Pervasives_Native.None in - let uu___1 = - let uu___2 = - let uu___3 = FStar_TypeChecker_NBETerm.embed d cbs x1 in - FStar_TypeChecker_NBETerm.as_arg uu___3 in - [uu___2] in - FStar_TypeChecker_NBETerm.mkFV fv [] uu___1 in - let un uu___1 uu___ = - (fun cbs -> - fun t -> - let uu___ = FStar_TypeChecker_NBETerm.nbe_t_of_t t in - match uu___ with - | FStar_TypeChecker_NBETerm.FV - (fv, uu___1, (_t, uu___2)::(body, uu___3)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.hide -> - Obj.magic - (Obj.repr - (let uu___4 = - FStar_TypeChecker_NBETerm.unembed d cbs body in - FStar_Class_Monad.op_let_Bang - FStar_Class_Monad.monad_option () () - (Obj.magic uu___4) - (fun uu___5 -> - (fun v -> - let v = Obj.magic v in - Obj.magic - (FStar_Class_Monad.return - FStar_Class_Monad.monad_option () - (Obj.magic (Hide v)))) uu___5))) - | uu___1 -> Obj.magic (Obj.repr FStar_Pervasives_Native.None)) - uu___1 uu___ in - FStar_TypeChecker_NBETerm.mk_emb em un (fun uu___ -> Prims.magic ()) - (fun uu___ -> FStar_Syntax_Syntax.ET_abstract) -let (s_reveal : - FStar_Syntax_Embeddings.abstract_term -> - FStar_Syntax_Embeddings.abstract_term emb_erased -> - FStar_Syntax_Embeddings.abstract_term FStar_Pervasives_Native.option) - = - fun a -> - fun e -> - let uu___ = e in - match uu___ with | Hide x -> FStar_Pervasives_Native.Some x -let (nbe_reveal : - FStar_TypeChecker_NBETerm.abstract_nbe_term -> - FStar_TypeChecker_NBETerm.abstract_nbe_term emb_erased -> - FStar_TypeChecker_NBETerm.abstract_nbe_term - FStar_Pervasives_Native.option) - = - fun a -> - fun e -> - let uu___ = e in - match uu___ with | Hide x -> FStar_Pervasives_Native.Some x -let (ops : FStar_TypeChecker_Primops_Base.primitive_step Prims.list) = - let uu___ = - FStar_TypeChecker_Primops_Base.mk2' Prims.int_one - FStar_Parser_Const.reveal FStar_Syntax_Embeddings.e_abstract_term - FStar_TypeChecker_NBETerm.e_abstract_nbe_term - (e_erased FStar_Syntax_Embeddings.e_abstract_term) - (nbe_e_erased FStar_TypeChecker_NBETerm.e_abstract_nbe_term) - FStar_Syntax_Embeddings.e_abstract_term - FStar_TypeChecker_NBETerm.e_abstract_nbe_term s_reveal nbe_reveal in - [uu___] \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Errors_Msg.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Errors_Msg.ml deleted file mode 100644 index b661d215c27..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Errors_Msg.ml +++ /dev/null @@ -1,83 +0,0 @@ -open Prims -let (ops : FStar_TypeChecker_Primops_Base.primitive_step Prims.list) = - let nm l = FStar_Parser_Const.p2l ["FStar"; "Stubs"; "Errors"; "Msg"; l] in - let uu___ = - let uu___1 = nm "text" in - FStar_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___1 - FStar_Syntax_Embeddings.e_string FStar_TypeChecker_NBETerm.e_string - FStar_Syntax_Embeddings.e_document FStar_TypeChecker_NBETerm.e_document - FStar_Errors_Msg.text in - let uu___1 = - let uu___2 = - let uu___3 = nm "sublist" in - FStar_TypeChecker_Primops_Base.mk2 Prims.int_zero uu___3 - FStar_Syntax_Embeddings.e_document - FStar_TypeChecker_NBETerm.e_document - (FStar_Syntax_Embeddings.e_list FStar_Syntax_Embeddings.e_document) - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_document) - FStar_Syntax_Embeddings.e_document - FStar_TypeChecker_NBETerm.e_document FStar_Errors_Msg.sublist in - let uu___3 = - let uu___4 = - let uu___5 = nm "bulleted" in - FStar_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___5 - (FStar_Syntax_Embeddings.e_list FStar_Syntax_Embeddings.e_document) - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_document) - FStar_Syntax_Embeddings.e_document - FStar_TypeChecker_NBETerm.e_document FStar_Errors_Msg.bulleted in - let uu___5 = - let uu___6 = - let uu___7 = nm "mkmsg" in - FStar_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___7 - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_document) - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_document) FStar_Errors_Msg.mkmsg in - let uu___7 = - let uu___8 = - let uu___9 = nm "subdoc" in - FStar_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___9 - FStar_Syntax_Embeddings.e_document - FStar_TypeChecker_NBETerm.e_document - FStar_Syntax_Embeddings.e_document - FStar_TypeChecker_NBETerm.e_document FStar_Errors_Msg.subdoc in - let uu___9 = - let uu___10 = - let uu___11 = nm "renderdoc" in - FStar_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___11 - FStar_Syntax_Embeddings.e_document - FStar_TypeChecker_NBETerm.e_document - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string FStar_Errors_Msg.renderdoc in - let uu___11 = - let uu___12 = - let uu___13 = nm "backtrace_doc" in - FStar_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___13 - FStar_Syntax_Embeddings.e_unit - FStar_TypeChecker_NBETerm.e_unit - FStar_Syntax_Embeddings.e_document - FStar_TypeChecker_NBETerm.e_document - FStar_Errors_Msg.backtrace_doc in - let uu___13 = - let uu___14 = - let uu___15 = nm "rendermsg" in - FStar_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___15 - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_document) - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_document) - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string - FStar_Errors_Msg.rendermsg in - [uu___14] in - uu___12 :: uu___13 in - uu___10 :: uu___11 in - uu___8 :: uu___9 in - uu___6 :: uu___7 in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - uu___ :: uu___1 \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Issue.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Issue.ml deleted file mode 100644 index 85e367274c4..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Issue.ml +++ /dev/null @@ -1,108 +0,0 @@ -open Prims -let (ops : FStar_TypeChecker_Primops_Base.primitive_step Prims.list) = - let mk_lid l = FStar_Parser_Const.p2l ["FStar"; "Issue"; l] in - let uu___ = - let uu___1 = mk_lid "message_of_issue" in - FStar_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___1 - FStar_Syntax_Embeddings.e_issue FStar_TypeChecker_NBETerm.e_issue - (FStar_Syntax_Embeddings.e_list FStar_Syntax_Embeddings.e_document) - (FStar_TypeChecker_NBETerm.e_list FStar_TypeChecker_NBETerm.e_document) - FStar_Errors.__proj__Mkissue__item__issue_msg in - let uu___1 = - let uu___2 = - let uu___3 = mk_lid "level_of_issue" in - FStar_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___3 - FStar_Syntax_Embeddings.e_issue FStar_TypeChecker_NBETerm.e_issue - FStar_Syntax_Embeddings.e_string FStar_TypeChecker_NBETerm.e_string - (fun i -> - FStar_Errors.string_of_issue_level i.FStar_Errors.issue_level) in - let uu___3 = - let uu___4 = - let uu___5 = mk_lid "number_of_issue" in - FStar_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___5 - FStar_Syntax_Embeddings.e_issue FStar_TypeChecker_NBETerm.e_issue - (FStar_Syntax_Embeddings.e_option FStar_Syntax_Embeddings.e_int) - (FStar_TypeChecker_NBETerm.e_option FStar_TypeChecker_NBETerm.e_int) - (fun uu___6 -> - (fun i -> - Obj.magic - (FStar_Class_Monad.fmap FStar_Class_Monad.monad_option () - () - (fun uu___6 -> (Obj.magic FStar_BigInt.of_int_fs) uu___6) - (Obj.magic i.FStar_Errors.issue_number))) uu___6) in - let uu___5 = - let uu___6 = - let uu___7 = mk_lid "range_of_issue" in - FStar_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___7 - FStar_Syntax_Embeddings.e_issue FStar_TypeChecker_NBETerm.e_issue - (FStar_Syntax_Embeddings.e_option FStar_Syntax_Embeddings.e_range) - (FStar_TypeChecker_NBETerm.e_option - FStar_TypeChecker_NBETerm.e_range) - FStar_Errors.__proj__Mkissue__item__issue_range in - let uu___7 = - let uu___8 = - let uu___9 = mk_lid "context_of_issue" in - FStar_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___9 - FStar_Syntax_Embeddings.e_issue - FStar_TypeChecker_NBETerm.e_issue - FStar_Syntax_Embeddings.e_string_list - FStar_TypeChecker_NBETerm.e_string_list - FStar_Errors.__proj__Mkissue__item__issue_ctx in - let uu___9 = - let uu___10 = - let uu___11 = mk_lid "render_issue" in - FStar_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___11 - FStar_Syntax_Embeddings.e_issue - FStar_TypeChecker_NBETerm.e_issue - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string FStar_Errors.format_issue in - let uu___11 = - let uu___12 = - let uu___13 = mk_lid "mk_issue_doc" in - FStar_TypeChecker_Primops_Base.mk5 Prims.int_zero uu___13 - FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string - (FStar_Syntax_Embeddings.e_list - FStar_Syntax_Embeddings.e_document) - (FStar_TypeChecker_NBETerm.e_list - FStar_TypeChecker_NBETerm.e_document) - (FStar_Syntax_Embeddings.e_option - FStar_Syntax_Embeddings.e_range) - (FStar_TypeChecker_NBETerm.e_option - FStar_TypeChecker_NBETerm.e_range) - (FStar_Syntax_Embeddings.e_option - FStar_Syntax_Embeddings.e_int) - (FStar_TypeChecker_NBETerm.e_option - FStar_TypeChecker_NBETerm.e_int) - FStar_Syntax_Embeddings.e_string_list - FStar_TypeChecker_NBETerm.e_string_list - FStar_Syntax_Embeddings.e_issue - FStar_TypeChecker_NBETerm.e_issue - (fun level -> - fun msg -> - fun range -> - fun number -> - fun context -> - let uu___14 = - FStar_Errors.issue_level_of_string level in - let uu___15 = - Obj.magic - (FStar_Class_Monad.fmap - FStar_Class_Monad.monad_option () () - (fun uu___16 -> - (Obj.magic FStar_BigInt.to_int_fs) - uu___16) (Obj.magic number)) in - { - FStar_Errors.issue_msg = msg; - FStar_Errors.issue_level = uu___14; - FStar_Errors.issue_range = range; - FStar_Errors.issue_number = uu___15; - FStar_Errors.issue_ctx = context - }) in - [uu___12] in - uu___10 :: uu___11 in - uu___8 :: uu___9 in - uu___6 :: uu___7 in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - uu___ :: uu___1 \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_MachineInts.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_MachineInts.ml deleted file mode 100644 index 05fff5eef5a..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_MachineInts.ml +++ /dev/null @@ -1,636 +0,0 @@ -open Prims -type 'a mymon = - (FStar_TypeChecker_Primops_Base.primitive_step Prims.list, unit, 'a) - FStar_Compiler_Writer.writer -let (bounded_arith_ops_for : - FStar_Compiler_MachineInts.machint_kind -> unit mymon) = - fun k -> - let mod_name = FStar_Compiler_MachineInts.module_name_for k in - let nm s = - let uu___ = - let uu___1 = - let uu___2 = FStar_Compiler_MachineInts.module_name_for k in - [uu___2; s] in - "FStar" :: uu___1 in - FStar_Parser_Const.p2l uu___ in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = nm "v" in - FStar_TypeChecker_Primops_Base.mk1 Prims.int_zero uu___3 - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - FStar_Syntax_Embeddings.e_int FStar_TypeChecker_NBETerm.e_int - (FStar_Compiler_MachineInts.v k) in - let uu___3 = - let uu___4 = - let uu___5 = nm "add" in - FStar_TypeChecker_Primops_Base.mk2 Prims.int_zero uu___5 - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (fun x -> - fun y -> - let uu___6 = - let uu___7 = FStar_Compiler_MachineInts.v k x in - let uu___8 = FStar_Compiler_MachineInts.v k y in - FStar_BigInt.add_big_int uu___7 uu___8 in - FStar_Compiler_MachineInts.make_as k x uu___6) in - let uu___5 = - let uu___6 = - let uu___7 = nm "sub" in - FStar_TypeChecker_Primops_Base.mk2 Prims.int_zero uu___7 - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (fun x -> - fun y -> - let uu___8 = - let uu___9 = FStar_Compiler_MachineInts.v k x in - let uu___10 = FStar_Compiler_MachineInts.v k y in - FStar_BigInt.sub_big_int uu___9 uu___10 in - FStar_Compiler_MachineInts.make_as k x uu___8) in - let uu___7 = - let uu___8 = - let uu___9 = nm "mul" in - FStar_TypeChecker_Primops_Base.mk2 Prims.int_zero uu___9 - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (fun x -> - fun y -> - let uu___10 = - let uu___11 = FStar_Compiler_MachineInts.v k x in - let uu___12 = FStar_Compiler_MachineInts.v k y in - FStar_BigInt.mult_big_int uu___11 uu___12 in - FStar_Compiler_MachineInts.make_as k x uu___10) in - let uu___9 = - let uu___10 = - let uu___11 = nm "gt" in - FStar_TypeChecker_Primops_Base.mk2 Prims.int_zero uu___11 - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - FStar_Syntax_Embeddings.e_bool - FStar_TypeChecker_NBETerm.e_bool - (fun x -> - fun y -> - let uu___12 = FStar_Compiler_MachineInts.v k x in - let uu___13 = FStar_Compiler_MachineInts.v k y in - FStar_BigInt.gt_big_int uu___12 uu___13) in - let uu___11 = - let uu___12 = - let uu___13 = nm "gte" in - FStar_TypeChecker_Primops_Base.mk2 Prims.int_zero uu___13 - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - FStar_Syntax_Embeddings.e_bool - FStar_TypeChecker_NBETerm.e_bool - (fun x -> - fun y -> - let uu___14 = FStar_Compiler_MachineInts.v k x in - let uu___15 = FStar_Compiler_MachineInts.v k y in - FStar_BigInt.ge_big_int uu___14 uu___15) in - let uu___13 = - let uu___14 = - let uu___15 = nm "lt" in - FStar_TypeChecker_Primops_Base.mk2 Prims.int_zero - uu___15 (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - FStar_Syntax_Embeddings.e_bool - FStar_TypeChecker_NBETerm.e_bool - (fun x -> - fun y -> - let uu___16 = FStar_Compiler_MachineInts.v k x in - let uu___17 = FStar_Compiler_MachineInts.v k y in - FStar_BigInt.lt_big_int uu___16 uu___17) in - let uu___15 = - let uu___16 = - let uu___17 = nm "lte" in - FStar_TypeChecker_Primops_Base.mk2 Prims.int_zero - uu___17 (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - FStar_Syntax_Embeddings.e_bool - FStar_TypeChecker_NBETerm.e_bool - (fun x -> - fun y -> - let uu___18 = FStar_Compiler_MachineInts.v k x in - let uu___19 = FStar_Compiler_MachineInts.v k y in - FStar_BigInt.le_big_int uu___18 uu___19) in - [uu___16] in - uu___14 :: uu___15 in - uu___12 :: uu___13 in - uu___10 :: uu___11 in - uu___8 :: uu___9 in - uu___6 :: uu___7 in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - FStar_Compiler_Writer.emit (FStar_Class_Monoid.monoid_list ()) uu___1 in - FStar_Class_Monad.op_let_Bang - (FStar_Compiler_Writer.monad_writer (FStar_Class_Monoid.monoid_list ())) - () () uu___ - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - let sz = FStar_Compiler_MachineInts.width k in - let modulus = - let uu___2 = FStar_BigInt.of_int_fs sz in - FStar_BigInt.shift_left_big_int FStar_BigInt.one uu___2 in - let mod1 x = FStar_BigInt.mod_big_int x modulus in - let uu___2 = - let uu___3 = FStar_Compiler_MachineInts.is_unsigned k in - if uu___3 - then - let uu___4 = - let uu___5 = - let uu___6 = nm "add_mod" in - FStar_TypeChecker_Primops_Base.mk2 Prims.int_zero uu___6 - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (fun x -> - fun y -> - let uu___7 = - let uu___8 = - let uu___9 = FStar_Compiler_MachineInts.v k x in - let uu___10 = FStar_Compiler_MachineInts.v k y in - FStar_BigInt.add_big_int uu___9 uu___10 in - mod1 uu___8 in - FStar_Compiler_MachineInts.make_as k x uu___7) in - let uu___6 = - let uu___7 = - let uu___8 = nm "sub_mod" in - FStar_TypeChecker_Primops_Base.mk2 Prims.int_zero - uu___8 (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (fun x -> - fun y -> - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Compiler_MachineInts.v k x in - let uu___12 = - FStar_Compiler_MachineInts.v k y in - FStar_BigInt.sub_big_int uu___11 uu___12 in - mod1 uu___10 in - FStar_Compiler_MachineInts.make_as k x uu___9) in - let uu___8 = - let uu___9 = - let uu___10 = nm "div" in - FStar_TypeChecker_Primops_Base.mk2 Prims.int_zero - uu___10 (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (fun x -> - fun y -> - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Compiler_MachineInts.v k x in - let uu___14 = - FStar_Compiler_MachineInts.v k y in - FStar_BigInt.div_big_int uu___13 uu___14 in - mod1 uu___12 in - FStar_Compiler_MachineInts.make_as k x uu___11) in - let uu___10 = - let uu___11 = - let uu___12 = nm "rem" in - FStar_TypeChecker_Primops_Base.mk2 Prims.int_zero - uu___12 (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (fun x -> - fun y -> - let uu___13 = - let uu___14 = - let uu___15 = - FStar_Compiler_MachineInts.v k x in - let uu___16 = - FStar_Compiler_MachineInts.v k y in - FStar_BigInt.mod_big_int uu___15 uu___16 in - mod1 uu___14 in - FStar_Compiler_MachineInts.make_as k x - uu___13) in - let uu___12 = - let uu___13 = - let uu___14 = nm "logor" in - FStar_TypeChecker_Primops_Base.mk2 Prims.int_zero - uu___14 - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (fun x -> - fun y -> - let uu___15 = - let uu___16 = - FStar_Compiler_MachineInts.v k x in - let uu___17 = - FStar_Compiler_MachineInts.v k y in - FStar_BigInt.logor_big_int uu___16 - uu___17 in - FStar_Compiler_MachineInts.make_as k x - uu___15) in - let uu___14 = - let uu___15 = - let uu___16 = nm "logand" in - FStar_TypeChecker_Primops_Base.mk2 - Prims.int_zero uu___16 - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (fun x -> - fun y -> - let uu___17 = - let uu___18 = - FStar_Compiler_MachineInts.v k x in - let uu___19 = - FStar_Compiler_MachineInts.v k y in - FStar_BigInt.logand_big_int uu___18 - uu___19 in - FStar_Compiler_MachineInts.make_as k x - uu___17) in - let uu___16 = - let uu___17 = - let uu___18 = nm "logxor" in - FStar_TypeChecker_Primops_Base.mk2 - Prims.int_zero uu___18 - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (fun x -> - fun y -> - let uu___19 = - let uu___20 = - FStar_Compiler_MachineInts.v k x in - let uu___21 = - FStar_Compiler_MachineInts.v k y in - FStar_BigInt.logxor_big_int uu___20 - uu___21 in - FStar_Compiler_MachineInts.make_as k x - uu___19) in - let uu___18 = - let uu___19 = - let uu___20 = nm "lognot" in - FStar_TypeChecker_Primops_Base.mk1 - Prims.int_zero uu___20 - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (fun x -> - let uu___21 = - let uu___22 = - let uu___23 = - FStar_Compiler_MachineInts.v k x in - FStar_BigInt.lognot_big_int - uu___23 in - let uu___23 = - FStar_Compiler_MachineInts.mask k in - FStar_BigInt.logand_big_int uu___22 - uu___23 in - FStar_Compiler_MachineInts.make_as k x - uu___21) in - let uu___20 = - let uu___21 = - let uu___22 = nm "shift_left" in - FStar_TypeChecker_Primops_Base.mk2 - Prims.int_zero uu___22 - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint - k) - (FStar_Compiler_MachineInts.e_machint - FStar_Compiler_MachineInts.UInt32) - (FStar_Compiler_MachineInts.nbe_machint - FStar_Compiler_MachineInts.UInt32) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint - k) - (fun x -> - fun y -> - let uu___23 = - let uu___24 = - let uu___25 = - FStar_Compiler_MachineInts.v - k x in - let uu___26 = - FStar_Compiler_MachineInts.v - FStar_Compiler_MachineInts.UInt32 - y in - FStar_BigInt.shift_left_big_int - uu___25 uu___26 in - let uu___25 = - FStar_Compiler_MachineInts.mask - k in - FStar_BigInt.logand_big_int - uu___24 uu___25 in - FStar_Compiler_MachineInts.make_as - k x uu___23) in - let uu___22 = - let uu___23 = - let uu___24 = nm "shift_right" in - FStar_TypeChecker_Primops_Base.mk2 - Prims.int_zero uu___24 - (FStar_Compiler_MachineInts.e_machint - k) - (FStar_Compiler_MachineInts.nbe_machint - k) - (FStar_Compiler_MachineInts.e_machint - FStar_Compiler_MachineInts.UInt32) - (FStar_Compiler_MachineInts.nbe_machint - FStar_Compiler_MachineInts.UInt32) - (FStar_Compiler_MachineInts.e_machint - k) - (FStar_Compiler_MachineInts.nbe_machint - k) - (fun x -> - fun y -> - let uu___25 = - let uu___26 = - let uu___27 = - FStar_Compiler_MachineInts.v - k x in - let uu___28 = - FStar_Compiler_MachineInts.v - FStar_Compiler_MachineInts.UInt32 - y in - FStar_BigInt.shift_right_big_int - uu___27 uu___28 in - let uu___27 = - FStar_Compiler_MachineInts.mask - k in - FStar_BigInt.logand_big_int - uu___26 uu___27 in - FStar_Compiler_MachineInts.make_as - k x uu___25) in - [uu___23] in - uu___21 :: uu___22 in - uu___19 :: uu___20 in - uu___17 :: uu___18 in - uu___15 :: uu___16 in - uu___13 :: uu___14 in - uu___11 :: uu___12 in - uu___9 :: uu___10 in - uu___7 :: uu___8 in - uu___5 :: uu___6 in - FStar_Compiler_Writer.emit - (FStar_Class_Monoid.monoid_list ()) uu___4 - else - FStar_Class_Monad.return - (FStar_Compiler_Writer.monad_writer - (FStar_Class_Monoid.monoid_list ())) () (Obj.repr ()) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - (FStar_Compiler_Writer.monad_writer - (FStar_Class_Monoid.monoid_list ())) () () uu___2 - (fun uu___3 -> - (fun uu___3 -> - let uu___3 = Obj.magic uu___3 in - let uu___4 = - let uu___5 = - (FStar_Compiler_MachineInts.is_unsigned k) && - (k <> FStar_Compiler_MachineInts.SizeT) in - if uu___5 - then - let uu___6 = - let uu___7 = - let uu___8 = nm "add_underspec" in - FStar_TypeChecker_Primops_Base.mk2 - Prims.int_zero uu___8 - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (fun x -> - fun y -> - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Compiler_MachineInts.v k x in - let uu___12 = - FStar_Compiler_MachineInts.v k y in - FStar_BigInt.add_big_int uu___11 - uu___12 in - mod1 uu___10 in - FStar_Compiler_MachineInts.make_as k x - uu___9) in - let uu___8 = - let uu___9 = - let uu___10 = nm "sub_underspec" in - FStar_TypeChecker_Primops_Base.mk2 - Prims.int_zero uu___10 - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint k) - (fun x -> - fun y -> - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Compiler_MachineInts.v k - x in - let uu___14 = - FStar_Compiler_MachineInts.v k - y in - FStar_BigInt.sub_big_int uu___13 - uu___14 in - mod1 uu___12 in - FStar_Compiler_MachineInts.make_as k - x uu___11) in - let uu___10 = - let uu___11 = - let uu___12 = nm "mul_underspec" in - FStar_TypeChecker_Primops_Base.mk2 - Prims.int_zero uu___12 - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint - k) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint - k) - (FStar_Compiler_MachineInts.e_machint k) - (FStar_Compiler_MachineInts.nbe_machint - k) - (fun x -> - fun y -> - let uu___13 = - let uu___14 = - let uu___15 = - FStar_Compiler_MachineInts.v - k x in - let uu___16 = - FStar_Compiler_MachineInts.v - k y in - FStar_BigInt.mult_big_int - uu___15 uu___16 in - mod1 uu___14 in - FStar_Compiler_MachineInts.make_as - k x uu___13) in - [uu___11] in - uu___9 :: uu___10 in - uu___7 :: uu___8 in - FStar_Compiler_Writer.emit - (FStar_Class_Monoid.monoid_list ()) uu___6 - else - FStar_Class_Monad.return - (FStar_Compiler_Writer.monad_writer - (FStar_Class_Monoid.monoid_list ())) () - (Obj.repr ()) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - (FStar_Compiler_Writer.monad_writer - (FStar_Class_Monoid.monoid_list ())) () () - uu___4 - (fun uu___5 -> - (fun uu___5 -> - let uu___5 = Obj.magic uu___5 in - let uu___6 = - let uu___7 = - (FStar_Compiler_MachineInts.is_unsigned - k) - && - ((k <> - FStar_Compiler_MachineInts.SizeT) - && - (k <> - FStar_Compiler_MachineInts.UInt128)) in - if uu___7 - then - let uu___8 = - let uu___9 = - let uu___10 = nm "mul_mod" in - FStar_TypeChecker_Primops_Base.mk2 - Prims.int_zero uu___10 - (FStar_Compiler_MachineInts.e_machint - k) - (FStar_Compiler_MachineInts.nbe_machint - k) - (FStar_Compiler_MachineInts.e_machint - k) - (FStar_Compiler_MachineInts.nbe_machint - k) - (FStar_Compiler_MachineInts.e_machint - k) - (FStar_Compiler_MachineInts.nbe_machint - k) - (fun x -> - fun y -> - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Compiler_MachineInts.v - k x in - let uu___14 = - FStar_Compiler_MachineInts.v - k y in - FStar_BigInt.mult_big_int - uu___13 uu___14 in - mod1 uu___12 in - FStar_Compiler_MachineInts.make_as - k x uu___11) in - [uu___9] in - FStar_Compiler_Writer.emit - (FStar_Class_Monoid.monoid_list ()) - uu___8 - else - FStar_Class_Monad.return - (FStar_Compiler_Writer.monad_writer - (FStar_Class_Monoid.monoid_list ())) - () (Obj.repr ()) in - Obj.magic - (FStar_Class_Monad.op_let_Bang - (FStar_Compiler_Writer.monad_writer - (FStar_Class_Monoid.monoid_list ())) - () () uu___6 - (fun uu___7 -> - (fun uu___7 -> - let uu___7 = Obj.magic uu___7 in - Obj.magic - (FStar_Class_Monad.return - (FStar_Compiler_Writer.monad_writer - (FStar_Class_Monoid.monoid_list - ())) () (Obj.repr ()))) - uu___7))) uu___5))) uu___3))) - uu___1) -let (ops : FStar_TypeChecker_Primops_Base.primitive_step Prims.list) = - let uu___ = - let uu___1 = - let uu___2 = - FStar_Class_Monad.iterM - (FStar_Compiler_Writer.monad_writer - (FStar_Class_Monoid.monoid_list ())) () - (fun uu___3 -> (Obj.magic bounded_arith_ops_for) uu___3) - (Obj.magic FStar_Compiler_MachineInts.all_machint_kinds) in - FStar_Class_Monad.op_let_Bang - (FStar_Compiler_Writer.monad_writer - (FStar_Class_Monoid.monoid_list ())) () () uu___2 - (fun uu___3 -> - (fun uu___3 -> - let uu___3 = Obj.magic uu___3 in - let uu___4 = - let uu___5 = - FStar_TypeChecker_Primops_Base.mk1 Prims.int_zero - FStar_Parser_Const.char_u32_of_char - FStar_Syntax_Embeddings.e_char - FStar_TypeChecker_NBETerm.e_char - (FStar_Compiler_MachineInts.e_machint - FStar_Compiler_MachineInts.UInt32) - (FStar_Compiler_MachineInts.nbe_machint - FStar_Compiler_MachineInts.UInt32) - (fun c -> - let n = - FStar_BigInt.of_int_fs - (FStar_Compiler_Util.int_of_char c) in - FStar_Compiler_MachineInts.mk - FStar_Compiler_MachineInts.UInt32 n - FStar_Pervasives_Native.None) in - [uu___5] in - Obj.magic - (FStar_Compiler_Writer.emit - (FStar_Class_Monoid.monoid_list ()) uu___4)) uu___3) in - Obj.magic - (FStar_Compiler_Writer.run_writer (FStar_Class_Monoid.monoid_list ()) - () (Obj.magic uu___1)) in - FStar_Pervasives_Native.fst uu___ \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Range.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Range.ml deleted file mode 100644 index c00d5be9c3d..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Range.ml +++ /dev/null @@ -1,122 +0,0 @@ -open Prims -type unsealedRange = - | U of FStar_Compiler_Range_Type.range -let (uu___is_U : unsealedRange -> Prims.bool) = fun projectee -> true -let (__proj__U__item___0 : unsealedRange -> FStar_Compiler_Range_Type.range) - = fun projectee -> match projectee with | U _0 -> _0 -let (mk_range : - Prims.string -> - FStar_BigInt.t -> - FStar_BigInt.t -> - FStar_BigInt.t -> FStar_BigInt.t -> FStar_Compiler_Range_Type.range) - = - fun fn -> - fun from_l -> - fun from_c -> - fun to_l -> - fun to_c -> - let uu___ = - let uu___1 = FStar_BigInt.to_int_fs from_l in - let uu___2 = FStar_BigInt.to_int_fs from_c in - FStar_Compiler_Range_Type.mk_pos uu___1 uu___2 in - let uu___1 = - let uu___2 = FStar_BigInt.to_int_fs to_l in - let uu___3 = FStar_BigInt.to_int_fs to_c in - FStar_Compiler_Range_Type.mk_pos uu___2 uu___3 in - FStar_Compiler_Range_Type.mk_range fn uu___ uu___1 -let (__mk_range : - Prims.string -> - FStar_BigInt.t -> - FStar_BigInt.t -> FStar_BigInt.t -> FStar_BigInt.t -> unsealedRange) - = - fun fn -> - fun from_l -> - fun from_c -> - fun to_l -> - fun to_c -> - let uu___ = mk_range fn from_l from_c to_l to_c in U uu___ -let (explode : - unsealedRange -> - (Prims.string * FStar_BigInt.t * FStar_BigInt.t * FStar_BigInt.t * - FStar_BigInt.t)) - = - fun r -> - match r with - | U r1 -> - let uu___ = FStar_Compiler_Range_Ops.file_of_range r1 in - let uu___1 = - let uu___2 = - let uu___3 = FStar_Compiler_Range_Ops.start_of_range r1 in - FStar_Compiler_Range_Ops.line_of_pos uu___3 in - FStar_BigInt.of_int_fs uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = FStar_Compiler_Range_Ops.start_of_range r1 in - FStar_Compiler_Range_Ops.col_of_pos uu___4 in - FStar_BigInt.of_int_fs uu___3 in - let uu___3 = - let uu___4 = - let uu___5 = FStar_Compiler_Range_Ops.end_of_range r1 in - FStar_Compiler_Range_Ops.line_of_pos uu___5 in - FStar_BigInt.of_int_fs uu___4 in - let uu___4 = - let uu___5 = - let uu___6 = FStar_Compiler_Range_Ops.end_of_range r1 in - FStar_Compiler_Range_Ops.col_of_pos uu___6 in - FStar_BigInt.of_int_fs uu___5 in - (uu___, uu___1, uu___2, uu___3, uu___4) -let (e_unsealedRange : unsealedRange FStar_Syntax_Embeddings_Base.embedding) - = - FStar_Syntax_Embeddings_Base.embed_as FStar_Syntax_Embeddings.e___range - (fun r -> U r) (fun uu___ -> match uu___ with | U r -> r) - FStar_Pervasives_Native.None -let (nbe_e_unsealedRange : unsealedRange FStar_TypeChecker_NBETerm.embedding) - = - FStar_TypeChecker_NBETerm.embed_as FStar_TypeChecker_NBETerm.e___range - (fun r -> U r) (fun uu___ -> match uu___ with | U r -> r) - FStar_Pervasives_Native.None -let (ops : FStar_TypeChecker_Primops_Base.primitive_step Prims.list) = - let uu___ = - FStar_TypeChecker_Primops_Base.mk5 Prims.int_zero - FStar_Parser_Const.__mk_range_lid FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int e_unsealedRange nbe_e_unsealedRange - __mk_range in - let uu___1 = - let uu___2 = - FStar_TypeChecker_Primops_Base.mk5 Prims.int_zero - FStar_Parser_Const.mk_range_lid FStar_Syntax_Embeddings.e_string - FStar_TypeChecker_NBETerm.e_string FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int FStar_Syntax_Embeddings.e_range - FStar_TypeChecker_NBETerm.e_range mk_range in - let uu___3 = - let uu___4 = - FStar_TypeChecker_Primops_Base.mk1 Prims.int_zero - FStar_Parser_Const.__explode_range_lid e_unsealedRange - nbe_e_unsealedRange - (FStar_Syntax_Embeddings.e_tuple5 FStar_Syntax_Embeddings.e_string - FStar_Syntax_Embeddings.e_int FStar_Syntax_Embeddings.e_int - FStar_Syntax_Embeddings.e_int FStar_Syntax_Embeddings.e_int) - (FStar_TypeChecker_NBETerm.e_tuple5 - FStar_TypeChecker_NBETerm.e_string - FStar_TypeChecker_NBETerm.e_int FStar_TypeChecker_NBETerm.e_int - FStar_TypeChecker_NBETerm.e_int FStar_TypeChecker_NBETerm.e_int) - explode in - let uu___5 = - let uu___6 = - FStar_TypeChecker_Primops_Base.mk2 Prims.int_zero - FStar_Parser_Const.join_range_lid FStar_Syntax_Embeddings.e_range - FStar_TypeChecker_NBETerm.e_range FStar_Syntax_Embeddings.e_range - FStar_TypeChecker_NBETerm.e_range FStar_Syntax_Embeddings.e_range - FStar_TypeChecker_NBETerm.e_range - FStar_Compiler_Range_Ops.union_ranges in - [uu___6] in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - uu___ :: uu___1 \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Real.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Real.ml deleted file mode 100644 index deecfee41dc..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Real.ml +++ /dev/null @@ -1,200 +0,0 @@ -open Prims -type tf = - | T - | F -let (uu___is_T : tf -> Prims.bool) = - fun projectee -> match projectee with | T -> true | uu___ -> false -let (uu___is_F : tf -> Prims.bool) = - fun projectee -> match projectee with | F -> true | uu___ -> false -let (e_tf : tf FStar_Syntax_Embeddings_Base.embedding) = - let ty = FStar_Syntax_Util.fvar_const FStar_Parser_Const.prop_lid in - let emb_t_prop = - let uu___ = - let uu___1 = FStar_Ident.string_of_lid FStar_Parser_Const.prop_lid in - (uu___1, []) in - FStar_Syntax_Syntax.ET_app uu___ in - let em p rng _shadow _norm = - match p with - | T -> FStar_Syntax_Util.t_true - | F -> FStar_Syntax_Util.t_false in - let un t _norm = - let uu___ = - let uu___1 = FStar_Syntax_Embeddings_Base.unmeta_div_results t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.true_lid -> - FStar_Pervasives_Native.Some T - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.false_lid -> - FStar_Pervasives_Native.Some F - | uu___1 -> FStar_Pervasives_Native.None in - FStar_Syntax_Embeddings_Base.mk_emb_full em un (fun uu___ -> ty) - (fun uu___ -> match uu___ with | T -> "T" | F -> "F") - (fun uu___ -> emb_t_prop) -let (nbe_e_tf : tf FStar_TypeChecker_NBETerm.embedding) = - let lid_as_typ l us args = - let uu___ = FStar_Syntax_Syntax.lid_as_fv l FStar_Pervasives_Native.None in - FStar_TypeChecker_NBETerm.mkFV uu___ us args in - let em _cb a = - match a with - | T -> lid_as_typ FStar_Parser_Const.true_lid [] [] - | F -> lid_as_typ FStar_Parser_Const.false_lid [] [] in - let un _cb t = - match t.FStar_TypeChecker_NBETerm.nbe_t with - | FStar_TypeChecker_NBETerm.FV (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.true_lid -> - FStar_Pervasives_Native.Some T - | FStar_TypeChecker_NBETerm.FV (fv, [], []) when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.false_lid -> - FStar_Pervasives_Native.Some F - | uu___ -> FStar_Pervasives_Native.None in - FStar_TypeChecker_NBETerm.mk_emb em un - (fun uu___ -> lid_as_typ FStar_Parser_Const.bool_lid [] []) - (FStar_Syntax_Embeddings_Base.emb_typ_of e_tf) -let (cmp : - FStar_Compiler_Real.real -> - FStar_Compiler_Real.real -> - FStar_Compiler_Order.order FStar_Pervasives_Native.option) - = - fun r1 -> - fun r2 -> - match ((FStar_Compiler_Real.__proj__Real__item___0 r1), - (FStar_Compiler_Real.__proj__Real__item___0 r2)) - with - | ("0.0", "0.0") -> - FStar_Pervasives_Native.Some FStar_Compiler_Order.Eq - | ("0.0", "0.5") -> - FStar_Pervasives_Native.Some FStar_Compiler_Order.Lt - | ("0.0", "1.0") -> - FStar_Pervasives_Native.Some FStar_Compiler_Order.Lt - | ("0.5", "0.0") -> - FStar_Pervasives_Native.Some FStar_Compiler_Order.Gt - | ("0.5", "0.5") -> - FStar_Pervasives_Native.Some FStar_Compiler_Order.Eq - | ("0.5", "1.0") -> - FStar_Pervasives_Native.Some FStar_Compiler_Order.Lt - | ("1.0", "0.0") -> - FStar_Pervasives_Native.Some FStar_Compiler_Order.Gt - | ("1.0", "0.5") -> - FStar_Pervasives_Native.Some FStar_Compiler_Order.Gt - | ("1.0", "1.0") -> - FStar_Pervasives_Native.Some FStar_Compiler_Order.Eq - | uu___ -> FStar_Pervasives_Native.None -let (lt : - FStar_Compiler_Real.real -> - FStar_Compiler_Real.real -> tf FStar_Pervasives_Native.option) - = - fun uu___1 -> - fun uu___ -> - (fun r1 -> - fun r2 -> - let uu___ = cmp r1 r2 in - Obj.magic - (FStar_Class_Monad.fmap FStar_Class_Monad.monad_option () () - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - match uu___1 with - | FStar_Compiler_Order.Lt -> Obj.magic T - | uu___2 -> Obj.magic F) uu___1) (Obj.magic uu___))) - uu___1 uu___ -let (le : - FStar_Compiler_Real.real -> - FStar_Compiler_Real.real -> tf FStar_Pervasives_Native.option) - = - fun uu___1 -> - fun uu___ -> - (fun r1 -> - fun r2 -> - let uu___ = cmp r1 r2 in - Obj.magic - (FStar_Class_Monad.fmap FStar_Class_Monad.monad_option () () - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - match uu___1 with - | FStar_Compiler_Order.Lt -> Obj.magic T - | FStar_Compiler_Order.Eq -> Obj.magic T - | uu___2 -> Obj.magic F) uu___1) (Obj.magic uu___))) - uu___1 uu___ -let (gt : - FStar_Compiler_Real.real -> - FStar_Compiler_Real.real -> tf FStar_Pervasives_Native.option) - = - fun uu___1 -> - fun uu___ -> - (fun r1 -> - fun r2 -> - let uu___ = cmp r1 r2 in - Obj.magic - (FStar_Class_Monad.fmap FStar_Class_Monad.monad_option () () - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - match uu___1 with - | FStar_Compiler_Order.Gt -> Obj.magic T - | uu___2 -> Obj.magic F) uu___1) (Obj.magic uu___))) - uu___1 uu___ -let (ge : - FStar_Compiler_Real.real -> - FStar_Compiler_Real.real -> tf FStar_Pervasives_Native.option) - = - fun uu___1 -> - fun uu___ -> - (fun r1 -> - fun r2 -> - let uu___ = cmp r1 r2 in - Obj.magic - (FStar_Class_Monad.fmap FStar_Class_Monad.monad_option () () - (fun uu___1 -> - (fun uu___1 -> - let uu___1 = Obj.magic uu___1 in - match uu___1 with - | FStar_Compiler_Order.Gt -> Obj.magic T - | FStar_Compiler_Order.Eq -> Obj.magic T - | uu___2 -> Obj.magic F) uu___1) (Obj.magic uu___))) - uu___1 uu___ -let (of_int : FStar_BigInt.t -> FStar_Compiler_Real.real) = - fun i -> - let uu___ = - let uu___1 = - let uu___2 = FStar_BigInt.to_int_fs i in Prims.string_of_int uu___2 in - Prims.strcat uu___1 ".0" in - FStar_Compiler_Real.Real uu___ -let (ops : FStar_TypeChecker_Primops_Base.primitive_step Prims.list) = - let uu___ = - FStar_TypeChecker_Primops_Base.mk1 Prims.int_zero - FStar_Parser_Const.real_of_int FStar_Syntax_Embeddings.e_int - FStar_TypeChecker_NBETerm.e_int FStar_Syntax_Embeddings.e_real - FStar_TypeChecker_NBETerm.e_real of_int in - [uu___] -let (simplify_ops : FStar_TypeChecker_Primops_Base.primitive_step Prims.list) - = - let uu___ = - FStar_TypeChecker_Primops_Base.mk2' Prims.int_zero - FStar_Parser_Const.real_op_LT FStar_Syntax_Embeddings.e_real - FStar_TypeChecker_NBETerm.e_real FStar_Syntax_Embeddings.e_real - FStar_TypeChecker_NBETerm.e_real e_tf nbe_e_tf lt lt in - let uu___1 = - let uu___2 = - FStar_TypeChecker_Primops_Base.mk2' Prims.int_zero - FStar_Parser_Const.real_op_LTE FStar_Syntax_Embeddings.e_real - FStar_TypeChecker_NBETerm.e_real FStar_Syntax_Embeddings.e_real - FStar_TypeChecker_NBETerm.e_real e_tf nbe_e_tf le le in - let uu___3 = - let uu___4 = - FStar_TypeChecker_Primops_Base.mk2' Prims.int_zero - FStar_Parser_Const.real_op_GT FStar_Syntax_Embeddings.e_real - FStar_TypeChecker_NBETerm.e_real FStar_Syntax_Embeddings.e_real - FStar_TypeChecker_NBETerm.e_real e_tf nbe_e_tf gt gt in - let uu___5 = - let uu___6 = - FStar_TypeChecker_Primops_Base.mk2' Prims.int_zero - FStar_Parser_Const.real_op_GTE FStar_Syntax_Embeddings.e_real - FStar_TypeChecker_NBETerm.e_real FStar_Syntax_Embeddings.e_real - FStar_TypeChecker_NBETerm.e_real e_tf nbe_e_tf ge ge in - [uu___6] in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - uu___ :: uu___1 \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Sealed.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Sealed.ml deleted file mode 100644 index 20bffc8fbcd..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Primops_Sealed.ml +++ /dev/null @@ -1,198 +0,0 @@ -open Prims -let (bogus_cbs : FStar_TypeChecker_NBETerm.nbe_cbs) = - { - FStar_TypeChecker_NBETerm.iapp = (fun h -> fun _args -> h); - FStar_TypeChecker_NBETerm.translate = - (fun uu___ -> failwith "bogus_cbs translate") - } -let (ops : FStar_TypeChecker_Primops_Base.primitive_step Prims.list) = - FStar_Compiler_List.map - (fun p -> - let uu___ = - FStar_TypeChecker_Primops_Base.as_primitive_step_nbecbs true p in - { - FStar_TypeChecker_Primops_Base.name = - (uu___.FStar_TypeChecker_Primops_Base.name); - FStar_TypeChecker_Primops_Base.arity = - (uu___.FStar_TypeChecker_Primops_Base.arity); - FStar_TypeChecker_Primops_Base.univ_arity = - (uu___.FStar_TypeChecker_Primops_Base.univ_arity); - FStar_TypeChecker_Primops_Base.auto_reflect = - (uu___.FStar_TypeChecker_Primops_Base.auto_reflect); - FStar_TypeChecker_Primops_Base.strong_reduction_ok = - (uu___.FStar_TypeChecker_Primops_Base.strong_reduction_ok); - FStar_TypeChecker_Primops_Base.requires_binder_substitution = - (uu___.FStar_TypeChecker_Primops_Base.requires_binder_substitution); - FStar_TypeChecker_Primops_Base.renorm_after = true; - FStar_TypeChecker_Primops_Base.interpretation = - (uu___.FStar_TypeChecker_Primops_Base.interpretation); - FStar_TypeChecker_Primops_Base.interpretation_nbe = - (uu___.FStar_TypeChecker_Primops_Base.interpretation_nbe) - }) - [(FStar_Parser_Const.map_seal_lid, (Prims.of_int (4)), - (Prims.of_int (2)), - ((fun psc -> - fun univs -> - fun cbs -> - fun args -> - match args with - | (ta, uu___)::(tb, uu___1)::(s, uu___2)::(f, uu___3)::[] -> - let try_unembed e x = - FStar_Syntax_Embeddings_Base.try_unembed e x - FStar_Syntax_Embeddings_Base.id_norm_cb in - let uu___4 = - let uu___5 = - try_unembed FStar_Syntax_Embeddings.e_any ta in - let uu___6 = - try_unembed FStar_Syntax_Embeddings.e_any tb in - let uu___7 = - try_unembed - (FStar_Syntax_Embeddings.e_sealed - FStar_Syntax_Embeddings.e_any) s in - let uu___8 = - try_unembed FStar_Syntax_Embeddings.e_any f in - (uu___5, uu___6, uu___7, uu___8) in - (match uu___4 with - | (FStar_Pervasives_Native.Some ta1, - FStar_Pervasives_Native.Some tb1, - FStar_Pervasives_Native.Some s1, - FStar_Pervasives_Native.Some f1) -> - let r = - let uu___5 = - let uu___6 = - FStar_Syntax_Syntax.as_arg - (FStar_Compiler_Sealed.unseal s1) in - [uu___6] in - FStar_Syntax_Util.mk_app f1 uu___5 in - let emb = - FStar_Syntax_Embeddings_Base.set_type ta1 - FStar_Syntax_Embeddings.e_any in - let uu___5 = - FStar_TypeChecker_Primops_Base.embed_simple - (FStar_Syntax_Embeddings.e_sealed emb) - psc.FStar_TypeChecker_Primops_Base.psc_range - (FStar_Compiler_Sealed.seal r) in - FStar_Pervasives_Native.Some uu___5 - | uu___5 -> FStar_Pervasives_Native.None) - | uu___ -> FStar_Pervasives_Native.None)), - ((fun cb -> - fun univs -> - fun args -> - match args with - | (ta, uu___)::(tb, uu___1)::(s, uu___2)::(f, uu___3)::[] -> - let try_unembed e x = - FStar_TypeChecker_NBETerm.unembed e bogus_cbs x in - let uu___4 = - let uu___5 = - try_unembed FStar_TypeChecker_NBETerm.e_any ta in - let uu___6 = - try_unembed FStar_TypeChecker_NBETerm.e_any tb in - let uu___7 = - try_unembed - (FStar_TypeChecker_NBETerm.e_sealed - FStar_TypeChecker_NBETerm.e_any) s in - let uu___8 = - try_unembed FStar_TypeChecker_NBETerm.e_any f in - (uu___5, uu___6, uu___7, uu___8) in - (match uu___4 with - | (FStar_Pervasives_Native.Some ta1, - FStar_Pervasives_Native.Some tb1, - FStar_Pervasives_Native.Some s1, - FStar_Pervasives_Native.Some f1) -> - let r = - let uu___5 = - let uu___6 = - FStar_TypeChecker_NBETerm.as_arg - (FStar_Compiler_Sealed.unseal s1) in - [uu___6] in - cb.FStar_TypeChecker_NBETerm.iapp f1 uu___5 in - let emb = - FStar_TypeChecker_NBETerm.set_type ta1 - FStar_TypeChecker_NBETerm.e_any in - let uu___5 = - FStar_TypeChecker_NBETerm.embed - (FStar_TypeChecker_NBETerm.e_sealed emb) cb - (FStar_Compiler_Sealed.seal r) in - FStar_Pervasives_Native.Some uu___5 - | uu___5 -> FStar_Pervasives_Native.None) - | uu___ -> FStar_Pervasives_Native.None))); - (FStar_Parser_Const.bind_seal_lid, (Prims.of_int (4)), - (Prims.of_int (2)), - ((fun psc -> - fun univs -> - fun cbs -> - fun args -> - match args with - | (ta, uu___)::(tb, uu___1)::(s, uu___2)::(f, uu___3)::[] -> - let try_unembed e x = - FStar_Syntax_Embeddings_Base.try_unembed e x - FStar_Syntax_Embeddings_Base.id_norm_cb in - let uu___4 = - let uu___5 = - try_unembed FStar_Syntax_Embeddings.e_any ta in - let uu___6 = - try_unembed FStar_Syntax_Embeddings.e_any tb in - let uu___7 = - try_unembed - (FStar_Syntax_Embeddings.e_sealed - FStar_Syntax_Embeddings.e_any) s in - let uu___8 = - try_unembed FStar_Syntax_Embeddings.e_any f in - (uu___5, uu___6, uu___7, uu___8) in - (match uu___4 with - | (FStar_Pervasives_Native.Some ta1, - FStar_Pervasives_Native.Some tb1, - FStar_Pervasives_Native.Some s1, - FStar_Pervasives_Native.Some f1) -> - let r = - let uu___5 = - let uu___6 = - FStar_Syntax_Syntax.as_arg - (FStar_Compiler_Sealed.unseal s1) in - [uu___6] in - FStar_Syntax_Util.mk_app f1 uu___5 in - let uu___5 = - FStar_TypeChecker_Primops_Base.embed_simple - FStar_Syntax_Embeddings.e_any - psc.FStar_TypeChecker_Primops_Base.psc_range r in - FStar_Pervasives_Native.Some uu___5 - | uu___5 -> FStar_Pervasives_Native.None) - | uu___ -> FStar_Pervasives_Native.None)), - ((fun cb -> - fun univs -> - fun args -> - match args with - | (ta, uu___)::(tb, uu___1)::(s, uu___2)::(f, uu___3)::[] -> - let try_unembed e x = - FStar_TypeChecker_NBETerm.unembed e bogus_cbs x in - let uu___4 = - let uu___5 = - try_unembed FStar_TypeChecker_NBETerm.e_any ta in - let uu___6 = - try_unembed FStar_TypeChecker_NBETerm.e_any tb in - let uu___7 = - try_unembed - (FStar_TypeChecker_NBETerm.e_sealed - FStar_TypeChecker_NBETerm.e_any) s in - let uu___8 = - try_unembed FStar_TypeChecker_NBETerm.e_any f in - (uu___5, uu___6, uu___7, uu___8) in - (match uu___4 with - | (FStar_Pervasives_Native.Some ta1, - FStar_Pervasives_Native.Some tb1, - FStar_Pervasives_Native.Some s1, - FStar_Pervasives_Native.Some f1) -> - let r = - let uu___5 = - let uu___6 = - FStar_TypeChecker_NBETerm.as_arg - (FStar_Compiler_Sealed.unseal s1) in - [uu___6] in - cb.FStar_TypeChecker_NBETerm.iapp f1 uu___5 in - let emb = - FStar_TypeChecker_NBETerm.set_type ta1 - FStar_TypeChecker_NBETerm.e_any in - let uu___5 = FStar_TypeChecker_NBETerm.embed emb cb r in - FStar_Pervasives_Native.Some uu___5 - | uu___5 -> FStar_Pervasives_Native.None) - | uu___ -> FStar_Pervasives_Native.None)))] \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Quals.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Quals.ml deleted file mode 100644 index b4cf1502a43..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Quals.ml +++ /dev/null @@ -1,725 +0,0 @@ -open Prims -let (check_sigelt_quals_pre : - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.sigelt -> unit) = - fun env -> - fun se -> - let visibility uu___ = - match uu___ with - | FStar_Syntax_Syntax.Private -> true - | uu___1 -> false in - let reducibility uu___ = - match uu___ with - | FStar_Syntax_Syntax.Irreducible -> true - | FStar_Syntax_Syntax.Unfold_for_unification_and_vcgen -> true - | FStar_Syntax_Syntax.Visible_default -> true - | FStar_Syntax_Syntax.Inline_for_extraction -> true - | uu___1 -> false in - let assumption uu___ = - match uu___ with - | FStar_Syntax_Syntax.Assumption -> true - | FStar_Syntax_Syntax.New -> true - | uu___1 -> false in - let reification uu___ = - match uu___ with - | FStar_Syntax_Syntax.Reifiable -> true - | FStar_Syntax_Syntax.Reflectable uu___1 -> true - | uu___1 -> false in - let inferred uu___ = - match uu___ with - | FStar_Syntax_Syntax.Discriminator uu___1 -> true - | FStar_Syntax_Syntax.Projector uu___1 -> true - | FStar_Syntax_Syntax.RecordType uu___1 -> true - | FStar_Syntax_Syntax.RecordConstructor uu___1 -> true - | FStar_Syntax_Syntax.ExceptionConstructor -> true - | FStar_Syntax_Syntax.HasMaskedEffect -> true - | FStar_Syntax_Syntax.Effect -> true - | uu___1 -> false in - let has_eq uu___ = - match uu___ with - | FStar_Syntax_Syntax.Noeq -> true - | FStar_Syntax_Syntax.Unopteq -> true - | uu___1 -> false in - let quals_combo_ok quals q = - match q with - | FStar_Syntax_Syntax.Assumption -> - FStar_Compiler_List.for_all - (fun x -> - ((((((x = q) || (x = FStar_Syntax_Syntax.Logic)) || - (inferred x)) - || (visibility x)) - || (assumption x)) - || - (env.FStar_TypeChecker_Env.is_iface && - (x = FStar_Syntax_Syntax.Inline_for_extraction))) - || (x = FStar_Syntax_Syntax.NoExtract)) quals - | FStar_Syntax_Syntax.New -> - FStar_Compiler_List.for_all - (fun x -> - (((x = q) || (inferred x)) || (visibility x)) || - (assumption x)) quals - | FStar_Syntax_Syntax.Inline_for_extraction -> - FStar_Compiler_List.for_all - (fun x -> - ((((((((x = q) || (x = FStar_Syntax_Syntax.Logic)) || - (visibility x)) - || (reducibility x)) - || (reification x)) - || (inferred x)) - || (has_eq x)) - || - (env.FStar_TypeChecker_Env.is_iface && - (x = FStar_Syntax_Syntax.Assumption))) - || (x = FStar_Syntax_Syntax.NoExtract)) quals - | FStar_Syntax_Syntax.Unfold_for_unification_and_vcgen -> - FStar_Compiler_List.for_all - (fun x -> - (((((((x = q) || (x = FStar_Syntax_Syntax.Logic)) || - (x = FStar_Syntax_Syntax.Inline_for_extraction)) - || (x = FStar_Syntax_Syntax.NoExtract)) - || (has_eq x)) - || (inferred x)) - || (visibility x)) - || (reification x)) quals - | FStar_Syntax_Syntax.Visible_default -> - FStar_Compiler_List.for_all - (fun x -> - (((((((x = q) || (x = FStar_Syntax_Syntax.Logic)) || - (x = FStar_Syntax_Syntax.Inline_for_extraction)) - || (x = FStar_Syntax_Syntax.NoExtract)) - || (has_eq x)) - || (inferred x)) - || (visibility x)) - || (reification x)) quals - | FStar_Syntax_Syntax.Irreducible -> - FStar_Compiler_List.for_all - (fun x -> - (((((((x = q) || (x = FStar_Syntax_Syntax.Logic)) || - (x = FStar_Syntax_Syntax.Inline_for_extraction)) - || (x = FStar_Syntax_Syntax.NoExtract)) - || (has_eq x)) - || (inferred x)) - || (visibility x)) - || (reification x)) quals - | FStar_Syntax_Syntax.Noeq -> - FStar_Compiler_List.for_all - (fun x -> - (((((((x = q) || (x = FStar_Syntax_Syntax.Logic)) || - (x = FStar_Syntax_Syntax.Inline_for_extraction)) - || (x = FStar_Syntax_Syntax.NoExtract)) - || (has_eq x)) - || (inferred x)) - || (visibility x)) - || (reification x)) quals - | FStar_Syntax_Syntax.Unopteq -> - FStar_Compiler_List.for_all - (fun x -> - (((((((x = q) || (x = FStar_Syntax_Syntax.Logic)) || - (x = FStar_Syntax_Syntax.Inline_for_extraction)) - || (x = FStar_Syntax_Syntax.NoExtract)) - || (has_eq x)) - || (inferred x)) - || (visibility x)) - || (reification x)) quals - | FStar_Syntax_Syntax.TotalEffect -> - FStar_Compiler_List.for_all - (fun x -> - (((x = q) || (inferred x)) || (visibility x)) || - (reification x)) quals - | FStar_Syntax_Syntax.Logic -> - FStar_Compiler_List.for_all - (fun x -> - ((((x = q) || (x = FStar_Syntax_Syntax.Assumption)) || - (inferred x)) - || (visibility x)) - || (reducibility x)) quals - | FStar_Syntax_Syntax.Reifiable -> - FStar_Compiler_List.for_all - (fun x -> - ((((reification x) || (inferred x)) || (visibility x)) || - (x = FStar_Syntax_Syntax.TotalEffect)) - || (x = FStar_Syntax_Syntax.Visible_default)) quals - | FStar_Syntax_Syntax.Reflectable uu___ -> - FStar_Compiler_List.for_all - (fun x -> - ((((reification x) || (inferred x)) || (visibility x)) || - (x = FStar_Syntax_Syntax.TotalEffect)) - || (x = FStar_Syntax_Syntax.Visible_default)) quals - | FStar_Syntax_Syntax.Private -> true - | uu___ -> true in - let check_no_subtyping_attribute se1 = - let uu___ = - (FStar_Syntax_Util.has_attribute se1.FStar_Syntax_Syntax.sigattrs - FStar_Parser_Const.no_subtping_attr_lid) - && - (match se1.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_let uu___1 -> false - | uu___1 -> true) in - if uu___ - then - let uu___1 = - let uu___2 = - FStar_Errors_Msg.text - "Illegal attribute: the `no_subtyping` attribute is allowed only on let-bindings." in - [uu___2] in - FStar_Errors.raise_error FStar_Syntax_Syntax.has_range_sigelt se1 - FStar_Errors_Codes.Fatal_InconsistentQualifierAnnotation () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___1) - else () in - check_no_subtyping_attribute se; - (let quals = - FStar_Compiler_List.filter - (fun x -> Prims.op_Negation (x = FStar_Syntax_Syntax.Logic)) - (FStar_Syntax_Util.quals_of_sigelt se) in - let uu___1 = - let uu___2 = - FStar_Compiler_Util.for_some - (fun uu___3 -> - match uu___3 with - | FStar_Syntax_Syntax.OnlyName -> true - | uu___4 -> false) quals in - Prims.op_Negation uu___2 in - if uu___1 - then - let r = FStar_Syntax_Util.range_of_sigelt se in - let no_dup_quals = - FStar_Compiler_Util.remove_dups (fun x -> fun y -> x = y) quals in - let err msg = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Errors_Msg.text "The qualifier list" in - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_qualifier) quals in - FStar_Pprint.doc_of_string uu___8 in - let uu___8 = - FStar_Errors_Msg.text - "is not permissible for this element" in - FStar_Pprint.op_Hat_Slash_Hat uu___7 uu___8 in - FStar_Pprint.op_Hat_Slash_Hat uu___5 uu___6 in - [uu___4] in - FStar_List_Tot_Base.append uu___3 msg in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_QulifierListNotPermitted () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___2) in - (if - (FStar_Compiler_List.length quals) <> - (FStar_Compiler_List.length no_dup_quals) - then - (let uu___3 = - let uu___4 = FStar_Errors_Msg.text "Duplicate qualifiers." in - [uu___4] in - err uu___3) - else (); - (let uu___4 = - let uu___5 = - FStar_Compiler_List.for_all (quals_combo_ok quals) quals in - Prims.op_Negation uu___5 in - if uu___4 - then - let uu___5 = - let uu___6 = FStar_Errors_Msg.text "Ill-formed combination." in - [uu___6] in - err uu___5 - else ()); - (match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (is_rec, uu___4); - FStar_Syntax_Syntax.lids1 = uu___5;_} - -> - (if - is_rec && - (FStar_Compiler_List.contains - FStar_Syntax_Syntax.Unfold_for_unification_and_vcgen - quals) - then - (let uu___7 = - let uu___8 = - FStar_Errors_Msg.text - "Recursive definitions cannot be marked inline." in - [uu___8] in - err uu___7) - else (); - (let uu___7 = - FStar_Compiler_Util.for_some - (fun x -> (assumption x) || (has_eq x)) quals in - if uu___7 - then - let uu___8 = - let uu___9 = - FStar_Errors_Msg.text - "Definitions cannot be assumed or marked with equality qualifiers." in - [uu___9] in - err uu___8 - else ())) - | FStar_Syntax_Syntax.Sig_bundle uu___4 -> - ((let uu___6 = - let uu___7 = - FStar_Compiler_Util.for_all - (fun x -> - ((((x = FStar_Syntax_Syntax.Inline_for_extraction) - || (x = FStar_Syntax_Syntax.NoExtract)) - || (inferred x)) - || (visibility x)) - || (has_eq x)) quals in - Prims.op_Negation uu___7 in - if uu___6 then err [] else ()); - (let uu___6 = - (FStar_Compiler_List.existsb - (fun uu___7 -> - match uu___7 with - | FStar_Syntax_Syntax.Unopteq -> true - | uu___8 -> false) quals) - && - (FStar_Syntax_Util.has_attribute - se.FStar_Syntax_Syntax.sigattrs - FStar_Parser_Const.erasable_attr) in - if uu___6 - then - let uu___7 = - let uu___8 = - FStar_Errors_Msg.text - "The `unopteq` qualifier is not allowed on erasable inductives since they don't have decidable equality." in - [uu___8] in - err uu___7 - else ())) - | FStar_Syntax_Syntax.Sig_declare_typ uu___4 -> - let uu___5 = FStar_Compiler_Util.for_some has_eq quals in - if uu___5 then err [] else () - | FStar_Syntax_Syntax.Sig_assume uu___4 -> - let uu___5 = - let uu___6 = - FStar_Compiler_Util.for_all - (fun x -> - ((visibility x) || - (x = FStar_Syntax_Syntax.Assumption)) - || (x = FStar_Syntax_Syntax.InternalAssumption)) - quals in - Prims.op_Negation uu___6 in - if uu___5 then err [] else () - | FStar_Syntax_Syntax.Sig_new_effect uu___4 -> - let uu___5 = - let uu___6 = - FStar_Compiler_Util.for_all - (fun x -> - (((x = FStar_Syntax_Syntax.TotalEffect) || - (inferred x)) - || (visibility x)) - || (reification x)) quals in - Prims.op_Negation uu___6 in - if uu___5 then err [] else () - | FStar_Syntax_Syntax.Sig_effect_abbrev uu___4 -> - let uu___5 = - let uu___6 = - FStar_Compiler_Util.for_all - (fun x -> (inferred x) || (visibility x)) quals in - Prims.op_Negation uu___6 in - if uu___5 then err [] else () - | uu___4 -> ())) - else ()) -let (check_erasable : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.qualifier Prims.list -> - FStar_Compiler_Range_Type.range -> FStar_Syntax_Syntax.sigelt -> unit) - = - fun env -> - fun quals -> - fun r -> - fun se -> - let lids = FStar_Syntax_Util.lids_of_sigelt se in - let val_exists = - FStar_Compiler_Util.for_some - (fun l -> - let uu___ = FStar_TypeChecker_Env.try_lookup_val_decl env l in - FStar_Compiler_Option.isSome uu___) lids in - let val_has_erasable_attr = - FStar_Compiler_Util.for_some - (fun l -> - let attrs_opt = - FStar_TypeChecker_Env.lookup_attrs_of_lid env l in - (FStar_Compiler_Option.isSome attrs_opt) && - (let uu___ = FStar_Compiler_Option.get attrs_opt in - FStar_Syntax_Util.has_attribute uu___ - FStar_Parser_Const.erasable_attr)) lids in - let se_has_erasable_attr = - FStar_Syntax_Util.has_attribute se.FStar_Syntax_Syntax.sigattrs - FStar_Parser_Const.erasable_attr in - if - (val_exists && val_has_erasable_attr) && - (Prims.op_Negation se_has_erasable_attr) - then - (let uu___1 = - let uu___2 = - FStar_Errors_Msg.text - "Mismatch of attributes between declaration and definition." in - let uu___3 = - let uu___4 = - FStar_Errors_Msg.text - "Declaration is marked `erasable` but the definition is not." in - [uu___4] in - uu___2 :: uu___3 in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_QulifierListNotPermitted () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___1)) - else (); - if - (val_exists && (Prims.op_Negation val_has_erasable_attr)) && - se_has_erasable_attr - then - (let uu___2 = - let uu___3 = - FStar_Errors_Msg.text - "Mismatch of attributes between declaration and definition." in - let uu___4 = - let uu___5 = - FStar_Errors_Msg.text - "Definition is marked `erasable` but the declaration is not." in - [uu___5] in - uu___3 :: uu___4 in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_QulifierListNotPermitted () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___2)) - else (); - if se_has_erasable_attr - then - (match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_bundle uu___2 -> - let uu___3 = - let uu___4 = - FStar_Compiler_Util.for_some - (fun uu___5 -> - match uu___5 with - | FStar_Syntax_Syntax.Noeq -> true - | uu___6 -> false) quals in - Prims.op_Negation uu___4 in - if uu___3 - then - let uu___4 = - let uu___5 = - FStar_Errors_Msg.text - "Incompatible attributes and qualifiers: erasable types do not support decidable equality and must be marked `noeq`." in - [uu___5] in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_QulifierListNotPermitted () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___4) - else () - | FStar_Syntax_Syntax.Sig_declare_typ uu___2 -> () - | FStar_Syntax_Syntax.Sig_fail uu___2 -> () - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (false, lb::[]); - FStar_Syntax_Syntax.lids1 = uu___2;_} - -> - let uu___3 = - FStar_Syntax_Util.abs_formals lb.FStar_Syntax_Syntax.lbdef in - (match uu___3 with - | (uu___4, body, uu___5) -> - let uu___6 = - let uu___7 = - FStar_TypeChecker_Normalize.non_info_norm env body in - Prims.op_Negation uu___7 in - if uu___6 - then - let uu___7 = - let uu___8 = - FStar_Errors_Msg.text - "Illegal attribute: the `erasable` attribute is only permitted on inductive type definitions and abbreviations for non-informative types." in - let uu___9 = - let uu___10 = - let uu___11 = FStar_Errors_Msg.text "The term" in - let uu___12 = - let uu___13 = - FStar_Class_PP.pp - FStar_Syntax_Print.pretty_term body in - let uu___14 = - FStar_Errors_Msg.text - "is considered informative." in - FStar_Pprint.op_Hat_Slash_Hat uu___13 uu___14 in - FStar_Pprint.op_Hat_Slash_Hat uu___11 uu___12 in - [uu___10] in - uu___8 :: uu___9 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) body - FStar_Errors_Codes.Fatal_QulifierListNotPermitted - () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___7) - else ()) - | FStar_Syntax_Syntax.Sig_new_effect - { FStar_Syntax_Syntax.mname = eff_name; - FStar_Syntax_Syntax.cattributes = uu___2; - FStar_Syntax_Syntax.univs = uu___3; - FStar_Syntax_Syntax.binders = uu___4; - FStar_Syntax_Syntax.signature = uu___5; - FStar_Syntax_Syntax.combinators = uu___6; - FStar_Syntax_Syntax.actions = uu___7; - FStar_Syntax_Syntax.eff_attrs = uu___8; - FStar_Syntax_Syntax.extraction_mode = uu___9;_} - -> - if - Prims.op_Negation - (FStar_Compiler_List.contains - FStar_Syntax_Syntax.TotalEffect quals) - then - let uu___10 = - let uu___11 = - let uu___12 = FStar_Errors_Msg.text "Effect" in - let uu___13 = - let uu___14 = - FStar_Class_PP.pp FStar_Ident.pretty_lident - eff_name in - let uu___15 = - FStar_Errors_Msg.text - "is marked erasable but only total effects are allowed to be erasable." in - FStar_Pprint.op_Hat_Slash_Hat uu___14 uu___15 in - FStar_Pprint.op_Hat_Slash_Hat uu___12 uu___13 in - [uu___11] in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_QulifierListNotPermitted () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___10) - else () - | uu___2 -> - let uu___3 = - let uu___4 = - FStar_Errors_Msg.text - "Illegal attribute: the `erasable` attribute is only permitted on inductive type definitions and abbreviations for non-informative types." in - [uu___4] in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range - r FStar_Errors_Codes.Fatal_QulifierListNotPermitted () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___3)) - else () -let (check_must_erase_attribute : - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.sigelt -> unit) = - fun env -> - fun se -> - let uu___ = FStar_Options.ide () in - if uu___ - then () - else - (match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = lbs; - FStar_Syntax_Syntax.lids1 = l;_} - -> - let uu___2 = - let uu___3 = FStar_TypeChecker_Env.dsenv env in - let uu___4 = FStar_TypeChecker_Env.current_module env in - FStar_Syntax_DsEnv.iface_decls uu___3 uu___4 in - (match uu___2 with - | FStar_Pervasives_Native.None -> () - | FStar_Pervasives_Native.Some iface_decls -> - FStar_Compiler_List.iter - (fun lb -> - let lbname = - FStar_Compiler_Util.right - lb.FStar_Syntax_Syntax.lbname in - let has_iface_val = - let uu___3 = - let uu___4 = - FStar_Ident.ident_of_lid - (lbname.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - FStar_Parser_AST.decl_is_val uu___4 in - FStar_Compiler_Util.for_some uu___3 iface_decls in - if has_iface_val - then - let must_erase = - FStar_TypeChecker_Util.must_erase_for_extraction - env lb.FStar_Syntax_Syntax.lbdef in - let has_attr = - FStar_TypeChecker_Env.fv_has_attr env lbname - FStar_Parser_Const.must_erase_for_extraction_attr in - (if must_erase && (Prims.op_Negation has_attr) - then - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_fv lbname in - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_fv lbname in - FStar_Compiler_Util.format2 - "Values of type `%s` will be erased during extraction, but its interface hides this fact. Add the `must_erase_for_extraction` attribute to the `val %s` declaration for this symbol in the interface" - uu___6 uu___7 in - FStar_Errors_Msg.text uu___5 in - [uu___4] in - FStar_Errors.log_issue - FStar_Syntax_Syntax.hasRange_fv lbname - FStar_Errors_Codes.Error_MustEraseMissing () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___3) - else - if has_attr && (Prims.op_Negation must_erase) - then - (let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_fv - lbname in - FStar_Compiler_Util.format1 - "Values of type `%s` cannot be erased during extraction, but the `must_erase_for_extraction` attribute claims that it can. Please remove the attribute." - uu___7 in - FStar_Errors_Msg.text uu___6 in - [uu___5] in - FStar_Errors.log_issue - FStar_Syntax_Syntax.hasRange_fv lbname - FStar_Errors_Codes.Error_MustEraseMissing () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___4)) - else ()) - else ()) (FStar_Pervasives_Native.snd lbs)) - | uu___2 -> ()) -let (check_typeclass_instance_attribute : - FStar_TypeChecker_Env.env -> - FStar_Compiler_Range_Type.range -> FStar_Syntax_Syntax.sigelt -> unit) - = - fun env -> - fun rng -> - fun se -> - let is_tc_instance = - FStar_Compiler_Util.for_some - (fun t -> - match t.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_fvar fv -> - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.tcinstance_lid - | uu___ -> false) se.FStar_Syntax_Syntax.sigattrs in - let check_instance_typ ty = - let uu___ = FStar_Syntax_Util.arrow_formals_comp ty in - match uu___ with - | (uu___1, res) -> - ((let uu___3 = - let uu___4 = FStar_Syntax_Util.is_total_comp res in - Prims.op_Negation uu___4 in - if uu___3 - then - let uu___4 = - let uu___5 = - FStar_Errors_Msg.text - "Instances are expected to be total." in - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Errors_Msg.text "This instance has effect" in - let uu___9 = - FStar_Class_PP.pp FStar_Ident.pretty_lident - (FStar_Syntax_Util.comp_effect_name res) in - FStar_Pprint.op_Hat_Hat uu___8 uu___9 in - [uu___7] in - uu___5 :: uu___6 in - FStar_Errors.log_issue FStar_Class_HasRange.hasRange_range - rng FStar_Errors_Codes.Error_UnexpectedTypeclassInstance - () (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___4) - else ()); - (let t = FStar_Syntax_Util.comp_result res in - let uu___3 = FStar_Syntax_Util.head_and_args t in - match uu___3 with - | (head, uu___4) -> - let err uu___5 = - let uu___6 = - let uu___7 = - FStar_Errors_Msg.text - "Instances must define instances of `class` types." in - let uu___8 = - let uu___9 = - let uu___10 = FStar_Errors_Msg.text "Type" in - let uu___11 = - let uu___12 = - FStar_Class_PP.pp - FStar_Syntax_Print.pretty_term t in - let uu___13 = - FStar_Errors_Msg.text "is not a class." in - FStar_Pprint.op_Hat_Slash_Hat uu___12 uu___13 in - FStar_Pprint.op_Hat_Slash_Hat uu___10 uu___11 in - [uu___9] in - uu___7 :: uu___8 in - FStar_Errors.log_issue - FStar_Class_HasRange.hasRange_range rng - FStar_Errors_Codes.Error_UnexpectedTypeclassInstance - () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___6) in - let uu___5 = - let uu___6 = FStar_Syntax_Util.un_uinst head in - uu___6.FStar_Syntax_Syntax.n in - (match uu___5 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - let uu___6 = - let uu___7 = - FStar_TypeChecker_Env.fv_has_attr env fv - FStar_Parser_Const.tcclass_lid in - Prims.op_Negation uu___7 in - if uu___6 then err () else () - | uu___6 -> err ()))) in - if is_tc_instance - then - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (false, lb::[]); - FStar_Syntax_Syntax.lids1 = uu___;_} - -> check_instance_typ lb.FStar_Syntax_Syntax.lbtyp - | FStar_Syntax_Syntax.Sig_let uu___ -> - let uu___1 = - let uu___2 = - FStar_Errors_Msg.text - "An `instance` definition is expected to be non-recursive and of a type that is a `class`." in - [uu___2] in - FStar_Errors.log_issue FStar_Class_HasRange.hasRange_range rng - FStar_Errors_Codes.Error_UnexpectedTypeclassInstance () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___1) - | FStar_Syntax_Syntax.Sig_declare_typ - { FStar_Syntax_Syntax.lid2 = uu___; - FStar_Syntax_Syntax.us2 = uu___1; - FStar_Syntax_Syntax.t2 = t;_} - -> check_instance_typ t - | uu___ -> - let uu___1 = - let uu___2 = - FStar_Errors_Msg.text - "The `instance` attribute is only allowed on `let` and `val` declarations." in - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Errors_Msg.text "It is not allowed for" in - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Syntax_Print.sigelt_to_string_short se in - FStar_Pprint.arbitrary_string uu___8 in - FStar_Pprint.squotes uu___7 in - FStar_Pprint.op_Hat_Slash_Hat uu___5 uu___6 in - [uu___4] in - uu___2 :: uu___3 in - FStar_Errors.log_issue FStar_Class_HasRange.hasRange_range rng - FStar_Errors_Codes.Error_UnexpectedTypeclassInstance () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___1) - else () -let (check_sigelt_quals_post : - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.sigelt -> unit) = - fun env -> - fun se -> - let quals = se.FStar_Syntax_Syntax.sigquals in - let r = se.FStar_Syntax_Syntax.sigrng in - check_erasable env quals r se; - check_must_erase_attribute env se; - check_typeclass_instance_attribute env r se \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Rel.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Rel.ml deleted file mode 100644 index 48d980bc980..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Rel.ml +++ /dev/null @@ -1,17028 +0,0 @@ -open Prims -type match_result = - | MisMatch of (FStar_Syntax_Syntax.delta_depth - FStar_Pervasives_Native.option * FStar_Syntax_Syntax.delta_depth - FStar_Pervasives_Native.option) - | HeadMatch of Prims.bool - | FullMatch -let (uu___is_MisMatch : match_result -> Prims.bool) = - fun projectee -> - match projectee with | MisMatch _0 -> true | uu___ -> false -let (__proj__MisMatch__item___0 : - match_result -> - (FStar_Syntax_Syntax.delta_depth FStar_Pervasives_Native.option * - FStar_Syntax_Syntax.delta_depth FStar_Pervasives_Native.option)) - = fun projectee -> match projectee with | MisMatch _0 -> _0 -let (uu___is_HeadMatch : match_result -> Prims.bool) = - fun projectee -> - match projectee with | HeadMatch _0 -> true | uu___ -> false -let (__proj__HeadMatch__item___0 : match_result -> Prims.bool) = - fun projectee -> match projectee with | HeadMatch _0 -> _0 -let (uu___is_FullMatch : match_result -> Prims.bool) = - fun projectee -> match projectee with | FullMatch -> true | uu___ -> false -type implicit_checking_status = - | Implicit_unresolved - | Implicit_checking_defers_univ_constraint - | Implicit_has_typing_guard of (FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.typ) -let (uu___is_Implicit_unresolved : implicit_checking_status -> Prims.bool) = - fun projectee -> - match projectee with | Implicit_unresolved -> true | uu___ -> false -let (uu___is_Implicit_checking_defers_univ_constraint : - implicit_checking_status -> Prims.bool) = - fun projectee -> - match projectee with - | Implicit_checking_defers_univ_constraint -> true - | uu___ -> false -let (uu___is_Implicit_has_typing_guard : - implicit_checking_status -> Prims.bool) = - fun projectee -> - match projectee with - | Implicit_has_typing_guard _0 -> true - | uu___ -> false -let (__proj__Implicit_has_typing_guard__item___0 : - implicit_checking_status -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.typ)) - = - fun projectee -> match projectee with | Implicit_has_typing_guard _0 -> _0 -let (dbg_Disch : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Disch" -let (dbg_Discharge : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Discharge" -let (dbg_EQ : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "EQ" -let (dbg_ExplainRel : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "ExplainRel" -let (dbg_GenUniverses : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "GenUniverses" -let (dbg_ImplicitTrace : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "ImplicitTrace" -let (dbg_Imps : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Imps" -let (dbg_LayeredEffectsApp : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "LayeredEffectsApp" -let (dbg_LayeredEffectsEqns : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "LayeredEffectsEqns" -let (dbg_Rel : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Rel" -let (dbg_RelBench : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "RelBench" -let (dbg_RelDelta : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "RelDelta" -let (dbg_RelTop : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "RelTop" -let (dbg_ResolveImplicitsHook : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "ResolveImplicitsHook" -let (dbg_Simplification : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Simplification" -let (dbg_SMTQuery : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "SMTQuery" -let (dbg_Tac : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Tac" -let (showable_implicit_checking_status : - implicit_checking_status FStar_Class_Show.showable) = - { - FStar_Class_Show.show = - (fun uu___ -> - match uu___ with - | Implicit_unresolved -> "Implicit_unresolved" - | Implicit_checking_defers_univ_constraint -> - "Implicit_checking_defers_univ_constraint" - | Implicit_has_typing_guard (tm, typ) -> "Implicit_has_typing_guard") - } -type tagged_implicits = - (FStar_TypeChecker_Common.implicit * implicit_checking_status) Prims.list -let (is_base_type : - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.typ -> Prims.bool) = - fun env -> - fun typ -> - let t = FStar_TypeChecker_Normalize.unfold_whnf env typ in - let uu___ = FStar_Syntax_Util.head_and_args t in - match uu___ with - | (head, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst head in - FStar_Syntax_Util.unascribe uu___3 in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_name uu___2 -> true - | FStar_Syntax_Syntax.Tm_fvar uu___2 -> true - | FStar_Syntax_Syntax.Tm_type uu___2 -> true - | uu___2 -> false) -let (term_is_uvar : - FStar_Syntax_Syntax.ctx_uvar -> FStar_Syntax_Syntax.term -> Prims.bool) = - fun uv -> - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Util.unascribe t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_uvar (uv', uu___1) -> - FStar_Syntax_Unionfind.equiv uv.FStar_Syntax_Syntax.ctx_uvar_head - uv'.FStar_Syntax_Syntax.ctx_uvar_head - | uu___1 -> false -let (binders_as_bv_set : - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.bv FStar_Compiler_FlatSet.t) - = - fun uu___ -> - (fun bs -> - let uu___ = - FStar_Compiler_List.map (fun b -> b.FStar_Syntax_Syntax.binder_bv) - bs in - Obj.magic - (FStar_Class_Setlike.from_list () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) uu___)) uu___ -type lstring = Prims.string FStar_Thunk.t -let (mklstr : (unit -> Prims.string) -> Prims.string FStar_Thunk.thunk) = - fun f -> - let uf = FStar_Syntax_Unionfind.get () in - FStar_Thunk.mk - (fun uu___ -> - let tx = FStar_Syntax_Unionfind.new_transaction () in - FStar_Syntax_Unionfind.set uf; - (let r = f () in FStar_Syntax_Unionfind.rollback tx; r)) -type uvi = - | TERM of (FStar_Syntax_Syntax.ctx_uvar * FStar_Syntax_Syntax.term) - | UNIV of (FStar_Syntax_Syntax.universe_uvar * - FStar_Syntax_Syntax.universe) -let (uu___is_TERM : uvi -> Prims.bool) = - fun projectee -> match projectee with | TERM _0 -> true | uu___ -> false -let (__proj__TERM__item___0 : - uvi -> (FStar_Syntax_Syntax.ctx_uvar * FStar_Syntax_Syntax.term)) = - fun projectee -> match projectee with | TERM _0 -> _0 -let (uu___is_UNIV : uvi -> Prims.bool) = - fun projectee -> match projectee with | UNIV _0 -> true | uu___ -> false -let (__proj__UNIV__item___0 : - uvi -> (FStar_Syntax_Syntax.universe_uvar * FStar_Syntax_Syntax.universe)) - = fun projectee -> match projectee with | UNIV _0 -> _0 -type defer_ok_t = - | NoDefer - | DeferAny - | DeferFlexFlexOnly -let (uu___is_NoDefer : defer_ok_t -> Prims.bool) = - fun projectee -> match projectee with | NoDefer -> true | uu___ -> false -let (uu___is_DeferAny : defer_ok_t -> Prims.bool) = - fun projectee -> match projectee with | DeferAny -> true | uu___ -> false -let (uu___is_DeferFlexFlexOnly : defer_ok_t -> Prims.bool) = - fun projectee -> - match projectee with | DeferFlexFlexOnly -> true | uu___ -> false -let (uu___0 : defer_ok_t FStar_Class_Show.showable) = - { - FStar_Class_Show.show = - (fun uu___ -> - match uu___ with - | NoDefer -> "NoDefer" - | DeferAny -> "DeferAny" - | DeferFlexFlexOnly -> "DeferFlexFlexOnly") - } -type worklist = - { - attempting: FStar_TypeChecker_Common.probs ; - wl_deferred: - (Prims.int * FStar_TypeChecker_Common.deferred_reason * lstring * - FStar_TypeChecker_Common.prob) FStar_Compiler_CList.clist - ; - wl_deferred_to_tac: - (Prims.int * FStar_TypeChecker_Common.deferred_reason * lstring * - FStar_TypeChecker_Common.prob) FStar_Compiler_CList.clist - ; - ctr: Prims.int ; - defer_ok: defer_ok_t ; - smt_ok: Prims.bool ; - umax_heuristic_ok: Prims.bool ; - tcenv: FStar_TypeChecker_Env.env ; - wl_implicits: FStar_TypeChecker_Common.implicits_t ; - repr_subcomp_allowed: Prims.bool ; - typeclass_variables: FStar_Syntax_Syntax.ctx_uvar FStar_Compiler_RBSet.t } -let (__proj__Mkworklist__item__attempting : - worklist -> FStar_TypeChecker_Common.probs) = - fun projectee -> - match projectee with - | { attempting; wl_deferred; wl_deferred_to_tac; ctr; defer_ok; smt_ok; - umax_heuristic_ok; tcenv; wl_implicits; repr_subcomp_allowed; - typeclass_variables;_} -> attempting -let (__proj__Mkworklist__item__wl_deferred : - worklist -> - (Prims.int * FStar_TypeChecker_Common.deferred_reason * lstring * - FStar_TypeChecker_Common.prob) FStar_Compiler_CList.clist) - = - fun projectee -> - match projectee with - | { attempting; wl_deferred; wl_deferred_to_tac; ctr; defer_ok; smt_ok; - umax_heuristic_ok; tcenv; wl_implicits; repr_subcomp_allowed; - typeclass_variables;_} -> wl_deferred -let (__proj__Mkworklist__item__wl_deferred_to_tac : - worklist -> - (Prims.int * FStar_TypeChecker_Common.deferred_reason * lstring * - FStar_TypeChecker_Common.prob) FStar_Compiler_CList.clist) - = - fun projectee -> - match projectee with - | { attempting; wl_deferred; wl_deferred_to_tac; ctr; defer_ok; smt_ok; - umax_heuristic_ok; tcenv; wl_implicits; repr_subcomp_allowed; - typeclass_variables;_} -> wl_deferred_to_tac -let (__proj__Mkworklist__item__ctr : worklist -> Prims.int) = - fun projectee -> - match projectee with - | { attempting; wl_deferred; wl_deferred_to_tac; ctr; defer_ok; smt_ok; - umax_heuristic_ok; tcenv; wl_implicits; repr_subcomp_allowed; - typeclass_variables;_} -> ctr -let (__proj__Mkworklist__item__defer_ok : worklist -> defer_ok_t) = - fun projectee -> - match projectee with - | { attempting; wl_deferred; wl_deferred_to_tac; ctr; defer_ok; smt_ok; - umax_heuristic_ok; tcenv; wl_implicits; repr_subcomp_allowed; - typeclass_variables;_} -> defer_ok -let (__proj__Mkworklist__item__smt_ok : worklist -> Prims.bool) = - fun projectee -> - match projectee with - | { attempting; wl_deferred; wl_deferred_to_tac; ctr; defer_ok; smt_ok; - umax_heuristic_ok; tcenv; wl_implicits; repr_subcomp_allowed; - typeclass_variables;_} -> smt_ok -let (__proj__Mkworklist__item__umax_heuristic_ok : worklist -> Prims.bool) = - fun projectee -> - match projectee with - | { attempting; wl_deferred; wl_deferred_to_tac; ctr; defer_ok; smt_ok; - umax_heuristic_ok; tcenv; wl_implicits; repr_subcomp_allowed; - typeclass_variables;_} -> umax_heuristic_ok -let (__proj__Mkworklist__item__tcenv : worklist -> FStar_TypeChecker_Env.env) - = - fun projectee -> - match projectee with - | { attempting; wl_deferred; wl_deferred_to_tac; ctr; defer_ok; smt_ok; - umax_heuristic_ok; tcenv; wl_implicits; repr_subcomp_allowed; - typeclass_variables;_} -> tcenv -let (__proj__Mkworklist__item__wl_implicits : - worklist -> FStar_TypeChecker_Common.implicits_t) = - fun projectee -> - match projectee with - | { attempting; wl_deferred; wl_deferred_to_tac; ctr; defer_ok; smt_ok; - umax_heuristic_ok; tcenv; wl_implicits; repr_subcomp_allowed; - typeclass_variables;_} -> wl_implicits -let (__proj__Mkworklist__item__repr_subcomp_allowed : worklist -> Prims.bool) - = - fun projectee -> - match projectee with - | { attempting; wl_deferred; wl_deferred_to_tac; ctr; defer_ok; smt_ok; - umax_heuristic_ok; tcenv; wl_implicits; repr_subcomp_allowed; - typeclass_variables;_} -> repr_subcomp_allowed -let (__proj__Mkworklist__item__typeclass_variables : - worklist -> FStar_Syntax_Syntax.ctx_uvar FStar_Compiler_RBSet.t) = - fun projectee -> - match projectee with - | { attempting; wl_deferred; wl_deferred_to_tac; ctr; defer_ok; smt_ok; - umax_heuristic_ok; tcenv; wl_implicits; repr_subcomp_allowed; - typeclass_variables;_} -> typeclass_variables -let (as_deferred : - (Prims.int * FStar_TypeChecker_Common.deferred_reason * lstring * - FStar_TypeChecker_Common.prob) FStar_Compiler_CList.clist -> - FStar_TypeChecker_Common.deferred) - = - fun wl_def -> - FStar_Compiler_CList.map - (fun uu___ -> - match uu___ with - | (uu___1, reason, m, p) -> - let uu___2 = FStar_Thunk.force m in (reason, uu___2, p)) wl_def -let (as_wl_deferred : - worklist -> - FStar_TypeChecker_Common.deferred -> - (Prims.int * FStar_TypeChecker_Common.deferred_reason * lstring * - FStar_TypeChecker_Common.prob) FStar_Compiler_CList.clist) - = - fun wl -> - fun d -> - FStar_Compiler_CList.map - (fun uu___ -> - match uu___ with - | (reason, m, p) -> - let uu___1 = FStar_Thunk.mkv m in - ((wl.ctr), reason, uu___1, p)) d -let (new_uvar : - Prims.string -> - worklist -> - FStar_Compiler_Range_Type.range -> - FStar_Syntax_Syntax.binding Prims.list -> - FStar_Syntax_Syntax.binder Prims.list -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.should_check_uvar -> - FStar_Syntax_Syntax.ctx_uvar_meta_t - FStar_Pervasives_Native.option -> - (FStar_Syntax_Syntax.ctx_uvar * FStar_Syntax_Syntax.term * - worklist)) - = - fun reason -> - fun wl -> - fun r -> - fun gamma -> - fun binders -> - fun k -> - fun should_check -> - fun meta -> - let decoration = - { - FStar_Syntax_Syntax.uvar_decoration_typ = k; - FStar_Syntax_Syntax.uvar_decoration_typedness_depends_on - = []; - FStar_Syntax_Syntax.uvar_decoration_should_check = - should_check; - FStar_Syntax_Syntax.uvar_decoration_should_unrefine = - false - } in - let ctx_uvar = - let uu___ = FStar_Syntax_Unionfind.fresh decoration r in - { - FStar_Syntax_Syntax.ctx_uvar_head = uu___; - FStar_Syntax_Syntax.ctx_uvar_gamma = gamma; - FStar_Syntax_Syntax.ctx_uvar_binders = binders; - FStar_Syntax_Syntax.ctx_uvar_reason = reason; - FStar_Syntax_Syntax.ctx_uvar_range = r; - FStar_Syntax_Syntax.ctx_uvar_meta = meta - } in - FStar_TypeChecker_Common.check_uvar_ctx_invariant reason r - true gamma binders; - (let t = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_uvar - (ctx_uvar, ([], FStar_Syntax_Syntax.NoUseRange))) r in - let imp = - { - FStar_TypeChecker_Common.imp_reason = reason; - FStar_TypeChecker_Common.imp_uvar = ctx_uvar; - FStar_TypeChecker_Common.imp_tm = t; - FStar_TypeChecker_Common.imp_range = r - } in - (let uu___2 = - FStar_Compiler_Effect.op_Bang dbg_ImplicitTrace in - if uu___2 - then - let uu___3 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_uvar - ctx_uvar.FStar_Syntax_Syntax.ctx_uvar_head in - FStar_Compiler_Util.print1 - "Just created uvar (Rel) {%s}\n" uu___3 - else ()); - (let uu___2 = - let uu___3 = - Obj.magic - (FStar_Class_Listlike.cons () - (Obj.magic - (FStar_Compiler_CList.listlike_clist ())) imp - (Obj.magic wl.wl_implicits)) in - { - attempting = (wl.attempting); - wl_deferred = (wl.wl_deferred); - wl_deferred_to_tac = (wl.wl_deferred_to_tac); - ctr = (wl.ctr); - defer_ok = (wl.defer_ok); - smt_ok = (wl.smt_ok); - umax_heuristic_ok = (wl.umax_heuristic_ok); - tcenv = (wl.tcenv); - wl_implicits = uu___3; - repr_subcomp_allowed = (wl.repr_subcomp_allowed); - typeclass_variables = (wl.typeclass_variables) - } in - (ctx_uvar, t, uu___2))) -let (copy_uvar : - FStar_Syntax_Syntax.ctx_uvar -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - worklist -> - (FStar_Syntax_Syntax.ctx_uvar * FStar_Syntax_Syntax.term * - worklist)) - = - fun u -> - fun bs -> - fun t -> - fun wl -> - let env = - let uu___ = wl.tcenv in - { - FStar_TypeChecker_Env.solver = - (uu___.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (uu___.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (uu___.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (u.FStar_Syntax_Syntax.ctx_uvar_gamma); - FStar_TypeChecker_Env.gamma_sig = - (uu___.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (uu___.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (uu___.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (uu___.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (uu___.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (uu___.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (uu___.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (uu___.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (uu___.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (uu___.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (uu___.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (uu___.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (uu___.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (uu___.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (uu___.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (uu___.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (uu___.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (uu___.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (uu___.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (uu___.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (uu___.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (uu___.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (uu___.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (uu___.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (uu___.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (uu___.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (uu___.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (uu___.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (uu___.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (uu___.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (uu___.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (uu___.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (uu___.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (uu___.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (uu___.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (uu___.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (uu___.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (uu___.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (uu___.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (uu___.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (uu___.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (uu___.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (uu___.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (uu___.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (uu___.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (uu___.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (uu___.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (uu___.FStar_TypeChecker_Env.missing_decl) - } in - let env1 = FStar_TypeChecker_Env.push_binders env bs in - let uu___ = FStar_TypeChecker_Env.all_binders env1 in - let uu___1 = FStar_Syntax_Util.ctx_uvar_should_check u in - new_uvar - (Prims.strcat "copy:" u.FStar_Syntax_Syntax.ctx_uvar_reason) wl - u.FStar_Syntax_Syntax.ctx_uvar_range - env1.FStar_TypeChecker_Env.gamma uu___ t uu___1 - u.FStar_Syntax_Syntax.ctx_uvar_meta -type solution = - | Success of (FStar_TypeChecker_Common.deferred * - FStar_TypeChecker_Common.deferred * FStar_TypeChecker_Common.implicits_t) - | Failed of (FStar_TypeChecker_Common.prob * lstring) -let (uu___is_Success : solution -> Prims.bool) = - fun projectee -> match projectee with | Success _0 -> true | uu___ -> false -let (__proj__Success__item___0 : - solution -> - (FStar_TypeChecker_Common.deferred * FStar_TypeChecker_Common.deferred * - FStar_TypeChecker_Common.implicits_t)) - = fun projectee -> match projectee with | Success _0 -> _0 -let (uu___is_Failed : solution -> Prims.bool) = - fun projectee -> match projectee with | Failed _0 -> true | uu___ -> false -let (__proj__Failed__item___0 : - solution -> (FStar_TypeChecker_Common.prob * lstring)) = - fun projectee -> match projectee with | Failed _0 -> _0 -let (extend_wl : - worklist -> - FStar_TypeChecker_Common.deferred -> - FStar_TypeChecker_Common.deferred -> - FStar_TypeChecker_Common.implicits_t -> worklist) - = - fun wl -> - fun defers -> - fun defer_to_tac -> - fun imps -> - let uu___ = - let uu___1 = as_wl_deferred wl defers in - FStar_Class_Monoid.op_Plus_Plus - (FStar_Compiler_CList.monoid_clist ()) wl.wl_deferred uu___1 in - let uu___1 = - let uu___2 = as_wl_deferred wl defer_to_tac in - FStar_Class_Monoid.op_Plus_Plus - (FStar_Compiler_CList.monoid_clist ()) wl.wl_deferred_to_tac - uu___2 in - let uu___2 = - FStar_Class_Monoid.op_Plus_Plus - (FStar_Compiler_CList.monoid_clist ()) wl.wl_implicits imps in - { - attempting = (wl.attempting); - wl_deferred = uu___; - wl_deferred_to_tac = uu___1; - ctr = (wl.ctr); - defer_ok = (wl.defer_ok); - smt_ok = (wl.smt_ok); - umax_heuristic_ok = (wl.umax_heuristic_ok); - tcenv = (wl.tcenv); - wl_implicits = uu___2; - repr_subcomp_allowed = (wl.repr_subcomp_allowed); - typeclass_variables = (wl.typeclass_variables) - } -type variance = - | COVARIANT - | CONTRAVARIANT - | INVARIANT -let (uu___is_COVARIANT : variance -> Prims.bool) = - fun projectee -> match projectee with | COVARIANT -> true | uu___ -> false -let (uu___is_CONTRAVARIANT : variance -> Prims.bool) = - fun projectee -> - match projectee with | CONTRAVARIANT -> true | uu___ -> false -let (uu___is_INVARIANT : variance -> Prims.bool) = - fun projectee -> match projectee with | INVARIANT -> true | uu___ -> false -type tprob = FStar_Syntax_Syntax.typ FStar_TypeChecker_Common.problem -type cprob = FStar_Syntax_Syntax.comp FStar_TypeChecker_Common.problem -type 'a problem_t = 'a FStar_TypeChecker_Common.problem -let (invert_rel : - FStar_TypeChecker_Common.rel -> FStar_TypeChecker_Common.rel) = - fun uu___ -> - match uu___ with - | FStar_TypeChecker_Common.EQ -> FStar_TypeChecker_Common.EQ - | FStar_TypeChecker_Common.SUB -> FStar_TypeChecker_Common.SUBINV - | FStar_TypeChecker_Common.SUBINV -> FStar_TypeChecker_Common.SUB -let invert : - 'uuuuu . - 'uuuuu FStar_TypeChecker_Common.problem -> - 'uuuuu FStar_TypeChecker_Common.problem - = - fun p -> - { - FStar_TypeChecker_Common.pid = (p.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = (p.FStar_TypeChecker_Common.rhs); - FStar_TypeChecker_Common.relation = - (invert_rel p.FStar_TypeChecker_Common.relation); - FStar_TypeChecker_Common.rhs = (p.FStar_TypeChecker_Common.lhs); - FStar_TypeChecker_Common.element = (p.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (p.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (p.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = (p.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = (p.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = (p.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = (p.FStar_TypeChecker_Common.logical) - } -let maybe_invert : - 'uuuuu . - 'uuuuu FStar_TypeChecker_Common.problem -> - 'uuuuu FStar_TypeChecker_Common.problem - = - fun p -> - if p.FStar_TypeChecker_Common.relation = FStar_TypeChecker_Common.SUBINV - then invert p - else p -let (maybe_invert_p : - FStar_TypeChecker_Common.prob -> FStar_TypeChecker_Common.prob) = - fun uu___ -> - match uu___ with - | FStar_TypeChecker_Common.TProb p -> - FStar_TypeChecker_Common.TProb (maybe_invert p) - | FStar_TypeChecker_Common.CProb p -> - FStar_TypeChecker_Common.CProb (maybe_invert p) -let (make_prob_eq : - FStar_TypeChecker_Common.prob -> FStar_TypeChecker_Common.prob) = - fun uu___ -> - match uu___ with - | FStar_TypeChecker_Common.TProb p -> - FStar_TypeChecker_Common.TProb - { - FStar_TypeChecker_Common.pid = (p.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = (p.FStar_TypeChecker_Common.lhs); - FStar_TypeChecker_Common.relation = FStar_TypeChecker_Common.EQ; - FStar_TypeChecker_Common.rhs = (p.FStar_TypeChecker_Common.rhs); - FStar_TypeChecker_Common.element = - (p.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (p.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (p.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (p.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = (p.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = (p.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = - (p.FStar_TypeChecker_Common.logical) - } - | FStar_TypeChecker_Common.CProb p -> - FStar_TypeChecker_Common.CProb - { - FStar_TypeChecker_Common.pid = (p.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = (p.FStar_TypeChecker_Common.lhs); - FStar_TypeChecker_Common.relation = FStar_TypeChecker_Common.EQ; - FStar_TypeChecker_Common.rhs = (p.FStar_TypeChecker_Common.rhs); - FStar_TypeChecker_Common.element = - (p.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (p.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (p.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (p.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = (p.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = (p.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = - (p.FStar_TypeChecker_Common.logical) - } -let (vary_rel : - FStar_TypeChecker_Common.rel -> variance -> FStar_TypeChecker_Common.rel) = - fun rel -> - fun uu___ -> - match uu___ with - | INVARIANT -> FStar_TypeChecker_Common.EQ - | CONTRAVARIANT -> invert_rel rel - | COVARIANT -> rel -let (p_pid : FStar_TypeChecker_Common.prob -> Prims.int) = - fun uu___ -> - match uu___ with - | FStar_TypeChecker_Common.TProb p -> p.FStar_TypeChecker_Common.pid - | FStar_TypeChecker_Common.CProb p -> p.FStar_TypeChecker_Common.pid -let (p_rel : FStar_TypeChecker_Common.prob -> FStar_TypeChecker_Common.rel) = - fun uu___ -> - match uu___ with - | FStar_TypeChecker_Common.TProb p -> p.FStar_TypeChecker_Common.relation - | FStar_TypeChecker_Common.CProb p -> p.FStar_TypeChecker_Common.relation -let (p_reason : FStar_TypeChecker_Common.prob -> Prims.string Prims.list) = - fun uu___ -> - match uu___ with - | FStar_TypeChecker_Common.TProb p -> p.FStar_TypeChecker_Common.reason - | FStar_TypeChecker_Common.CProb p -> p.FStar_TypeChecker_Common.reason -let (p_loc : - FStar_TypeChecker_Common.prob -> FStar_Compiler_Range_Type.range) = - fun uu___ -> - match uu___ with - | FStar_TypeChecker_Common.TProb p -> p.FStar_TypeChecker_Common.loc - | FStar_TypeChecker_Common.CProb p -> p.FStar_TypeChecker_Common.loc -let (p_element : - FStar_TypeChecker_Common.prob -> - FStar_Syntax_Syntax.bv FStar_Pervasives_Native.option) - = - fun uu___ -> - match uu___ with - | FStar_TypeChecker_Common.TProb p -> p.FStar_TypeChecker_Common.element - | FStar_TypeChecker_Common.CProb p -> p.FStar_TypeChecker_Common.element -let (p_guard : FStar_TypeChecker_Common.prob -> FStar_Syntax_Syntax.term) = - fun uu___ -> - match uu___ with - | FStar_TypeChecker_Common.TProb p -> - p.FStar_TypeChecker_Common.logical_guard - | FStar_TypeChecker_Common.CProb p -> - p.FStar_TypeChecker_Common.logical_guard -let (p_scope : - FStar_TypeChecker_Common.prob -> FStar_Syntax_Syntax.binder Prims.list) = - fun prob -> - let r = - match prob with - | FStar_TypeChecker_Common.TProb p -> - let uu___ = - match p_element prob with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some x -> - let uu___1 = FStar_Syntax_Syntax.mk_binder x in [uu___1] in - FStar_Compiler_List.op_At - (p.FStar_TypeChecker_Common.logical_guard_uvar).FStar_Syntax_Syntax.ctx_uvar_binders - uu___ - | FStar_TypeChecker_Common.CProb p -> - let uu___ = - match p_element prob with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some x -> - let uu___1 = FStar_Syntax_Syntax.mk_binder x in [uu___1] in - FStar_Compiler_List.op_At - (p.FStar_TypeChecker_Common.logical_guard_uvar).FStar_Syntax_Syntax.ctx_uvar_binders - uu___ in - r -let (p_guard_uvar : - FStar_TypeChecker_Common.prob -> FStar_Syntax_Syntax.ctx_uvar) = - fun uu___ -> - match uu___ with - | FStar_TypeChecker_Common.TProb p -> - p.FStar_TypeChecker_Common.logical_guard_uvar - | FStar_TypeChecker_Common.CProb p -> - p.FStar_TypeChecker_Common.logical_guard_uvar -let (p_env : - worklist -> FStar_TypeChecker_Common.prob -> FStar_TypeChecker_Env.env) = - fun wl -> - fun prob -> - let uu___ = wl.tcenv in - { - FStar_TypeChecker_Env.solver = (uu___.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = (uu___.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (uu___.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - ((p_guard_uvar prob).FStar_Syntax_Syntax.ctx_uvar_gamma); - FStar_TypeChecker_Env.gamma_sig = - (uu___.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (uu___.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = (uu___.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (uu___.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = (uu___.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = (uu___.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (uu___.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = (uu___.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (uu___.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = (uu___.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (uu___.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (uu___.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (uu___.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (uu___.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = (uu___.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (uu___.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = (uu___.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (uu___.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (uu___.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (uu___.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (uu___.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (uu___.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = (uu___.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (uu___.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (uu___.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (uu___.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (uu___.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (uu___.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (uu___.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (uu___.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (uu___.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (uu___.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (uu___.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (uu___.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = (uu___.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (uu___.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (uu___.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (uu___.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (uu___.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = (uu___.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (uu___.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (uu___.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (uu___.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (uu___.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (uu___.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (uu___.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (uu___.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (uu___.FStar_TypeChecker_Env.missing_decl) - } -let (p_guard_env : - worklist -> FStar_TypeChecker_Common.prob -> FStar_TypeChecker_Env.env) = - fun wl -> - fun prob -> - let uu___ = wl.tcenv in - { - FStar_TypeChecker_Env.solver = (uu___.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = (uu___.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (uu___.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (FStar_Compiler_List.op_At - (match p_element prob with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some x -> - [FStar_Syntax_Syntax.Binding_var x]) - (p_guard_uvar prob).FStar_Syntax_Syntax.ctx_uvar_gamma); - FStar_TypeChecker_Env.gamma_sig = - (uu___.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (uu___.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = (uu___.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (uu___.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = (uu___.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = (uu___.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (uu___.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = (uu___.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (uu___.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = (uu___.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (uu___.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (uu___.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (uu___.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (uu___.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = (uu___.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (uu___.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = (uu___.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (uu___.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (uu___.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (uu___.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (uu___.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (uu___.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = (uu___.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (uu___.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (uu___.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (uu___.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (uu___.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (uu___.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (uu___.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (uu___.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (uu___.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (uu___.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (uu___.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (uu___.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = (uu___.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (uu___.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (uu___.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (uu___.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (uu___.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = (uu___.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (uu___.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (uu___.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (uu___.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (uu___.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (uu___.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (uu___.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (uu___.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (uu___.FStar_TypeChecker_Env.missing_decl) - } -let (def_scope_wf : - Prims.string -> - FStar_Compiler_Range_Type.range -> - FStar_Syntax_Syntax.binder Prims.list -> unit) - = - fun msg -> - fun rng -> - fun r -> - let uu___ = - let uu___1 = FStar_Options.defensive () in Prims.op_Negation uu___1 in - if uu___ - then () - else - (let rec aux prev next = - match next with - | [] -> () - | { FStar_Syntax_Syntax.binder_bv = bv; - FStar_Syntax_Syntax.binder_qual = uu___2; - FStar_Syntax_Syntax.binder_positivity = uu___3; - FStar_Syntax_Syntax.binder_attrs = uu___4;_}::bs -> - (FStar_Defensive.def_check_scoped - FStar_Class_Binders.hasBinders_list_bv - FStar_Class_Binders.hasNames_term - FStar_Syntax_Print.pretty_term rng msg prev - bv.FStar_Syntax_Syntax.sort; - aux (FStar_Compiler_List.op_At prev [bv]) bs) in - aux [] r) -let (hasBinders_prob : - FStar_TypeChecker_Common.prob FStar_Class_Binders.hasBinders) = - { - FStar_Class_Binders.boundNames = - (fun uu___ -> - (fun prob -> - let uu___ = - let uu___1 = p_scope prob in - FStar_Compiler_List.map - (fun b -> b.FStar_Syntax_Syntax.binder_bv) uu___1 in - Obj.magic - (FStar_Class_Setlike.from_list () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) uu___)) uu___) - } -let (def_check_term_scoped_in_prob : - Prims.string -> - FStar_TypeChecker_Common.prob -> FStar_Syntax_Syntax.term -> unit) - = - fun msg -> - fun prob -> - fun phi -> - FStar_Defensive.def_check_scoped hasBinders_prob - FStar_Class_Binders.hasNames_term FStar_Syntax_Print.pretty_term - (p_loc prob) msg prob phi -let (def_check_comp_scoped_in_prob : - Prims.string -> - FStar_TypeChecker_Common.prob -> FStar_Syntax_Syntax.comp -> unit) - = - fun msg -> - fun prob -> - fun phi -> - FStar_Defensive.def_check_scoped hasBinders_prob - FStar_Class_Binders.hasNames_comp FStar_Syntax_Print.pretty_comp - (p_loc prob) msg prob phi -let (def_check_prob : Prims.string -> FStar_TypeChecker_Common.prob -> unit) - = - fun msg -> - fun prob -> - let uu___ = - let uu___1 = FStar_Options.defensive () in Prims.op_Negation uu___1 in - if uu___ - then () - else - (let msgf m = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Compiler_Util.string_of_int (p_pid prob) in - Prims.strcat uu___4 (Prims.strcat "." m) in - Prims.strcat "." uu___3 in - Prims.strcat msg uu___2 in - (let uu___3 = msgf "scope" in - let uu___4 = p_scope prob in - def_scope_wf uu___3 (p_loc prob) uu___4); - (let uu___4 = msgf "guard" in - def_check_term_scoped_in_prob uu___4 prob (p_guard prob)); - (match prob with - | FStar_TypeChecker_Common.TProb p -> - ((let uu___5 = msgf "lhs" in - def_check_term_scoped_in_prob uu___5 prob - p.FStar_TypeChecker_Common.lhs); - (let uu___5 = msgf "rhs" in - def_check_term_scoped_in_prob uu___5 prob - p.FStar_TypeChecker_Common.rhs)) - | FStar_TypeChecker_Common.CProb p -> - ((let uu___5 = msgf "lhs" in - def_check_comp_scoped_in_prob uu___5 prob - p.FStar_TypeChecker_Common.lhs); - (let uu___5 = msgf "rhs" in - def_check_comp_scoped_in_prob uu___5 prob - p.FStar_TypeChecker_Common.rhs)))) -let (rel_to_string : FStar_TypeChecker_Common.rel -> Prims.string) = - fun uu___ -> - match uu___ with - | FStar_TypeChecker_Common.EQ -> "=" - | FStar_TypeChecker_Common.SUB -> "<:" - | FStar_TypeChecker_Common.SUBINV -> ":>" -let (term_to_string : FStar_Syntax_Syntax.term -> Prims.string) = - fun t -> - let uu___ = FStar_Syntax_Util.head_and_args t in - match uu___ with - | (head, args) -> - (match head.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_uvar (u, s) -> - let uu___1 = - FStar_Class_Show.show FStar_Syntax_Print.showable_ctxu u in - let uu___2 = - let uu___3 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_subst_elt)) - (FStar_Pervasives_Native.fst s) in - Prims.strcat "@" uu___3 in - let uu___3 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - (FStar_Class_Show.show_tuple2 - FStar_Syntax_Print.showable_term - FStar_Syntax_Print.showable_aqual)) args in - FStar_Compiler_Util.format3 "%s%s %s" uu___1 uu___2 uu___3 - | uu___1 -> FStar_Class_Show.show FStar_Syntax_Print.showable_term t) -let (prob_to_string : - FStar_TypeChecker_Env.env -> FStar_TypeChecker_Common.prob -> Prims.string) - = - fun env -> - fun prob -> - match prob with - | FStar_TypeChecker_Common.TProb p -> - let uu___ = - let uu___1 = - FStar_Compiler_Util.string_of_int - p.FStar_TypeChecker_Common.pid in - let uu___2 = - let uu___3 = term_to_string p.FStar_TypeChecker_Common.lhs in - let uu___4 = - let uu___5 = - let uu___6 = term_to_string p.FStar_TypeChecker_Common.rhs in - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - p.FStar_TypeChecker_Common.logical in - [uu___9] in - (match p.FStar_TypeChecker_Common.reason with - | [] -> "" - | r::uu___9 -> r) :: uu___8 in - uu___6 :: uu___7 in - (rel_to_string p.FStar_TypeChecker_Common.relation) :: uu___5 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - FStar_Compiler_Util.format - "\n%s:\t%s \n\t\t%s\n\t%s\n\t(reason:%s) (logical:%s)\n" uu___ - | FStar_TypeChecker_Common.CProb p -> - let uu___ = - FStar_Compiler_Util.string_of_int p.FStar_TypeChecker_Common.pid in - let uu___1 = - FStar_TypeChecker_Normalize.comp_to_string env - p.FStar_TypeChecker_Common.lhs in - let uu___2 = - FStar_TypeChecker_Normalize.comp_to_string env - p.FStar_TypeChecker_Common.rhs in - FStar_Compiler_Util.format4 "\n%s:\t%s \n\t\t%s\n\t%s" uu___ uu___1 - (rel_to_string p.FStar_TypeChecker_Common.relation) uu___2 -let (prob_to_string' : - worklist -> FStar_TypeChecker_Common.prob -> Prims.string) = - fun wl -> fun prob -> let env = p_env wl prob in prob_to_string env prob -let (uvi_to_string : FStar_TypeChecker_Env.env -> uvi -> Prims.string) = - fun env -> - fun uu___ -> - match uu___ with - | UNIV (u, t) -> - let x = - let uu___1 = FStar_Options.hide_uvar_nums () in - if uu___1 - then "?" - else - (let uu___3 = FStar_Syntax_Unionfind.univ_uvar_id u in - FStar_Compiler_Util.string_of_int uu___3) in - let uu___1 = - FStar_Class_Show.show FStar_Syntax_Print.showable_univ t in - FStar_Compiler_Util.format2 "UNIV %s <- %s" x uu___1 - | TERM (u, t) -> - let x = - let uu___1 = FStar_Options.hide_uvar_nums () in - if uu___1 - then "?" - else - (let uu___3 = - FStar_Syntax_Unionfind.uvar_id - u.FStar_Syntax_Syntax.ctx_uvar_head in - FStar_Compiler_Util.string_of_int uu___3) in - let uu___1 = FStar_TypeChecker_Normalize.term_to_string env t in - FStar_Compiler_Util.format2 "TERM %s <- %s" x uu___1 -let (uvis_to_string : - FStar_TypeChecker_Env.env -> uvi Prims.list -> Prims.string) = - fun env -> - fun uvis -> (FStar_Common.string_of_list ()) (uvi_to_string env) uvis -let (empty_worklist : FStar_TypeChecker_Env.env -> worklist) = - fun env -> - let uu___ = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Free.ord_ctx_uvar)) ()) in - { - attempting = []; - wl_deferred = - (Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic (FStar_Compiler_CList.listlike_clist ())))); - wl_deferred_to_tac = - (Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic (FStar_Compiler_CList.listlike_clist ())))); - ctr = Prims.int_zero; - defer_ok = DeferAny; - smt_ok = true; - umax_heuristic_ok = true; - tcenv = env; - wl_implicits = - (Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic (FStar_Compiler_CList.listlike_clist ())))); - repr_subcomp_allowed = false; - typeclass_variables = uu___ - } -let (giveup : - worklist -> lstring -> FStar_TypeChecker_Common.prob -> solution) = - fun wl -> - fun reason -> - fun prob -> - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___1 - then - let uu___2 = FStar_Thunk.force reason in - let uu___3 = prob_to_string' wl prob in - FStar_Compiler_Util.print2 "Failed %s:\n%s\n" uu___2 uu___3 - else ()); - Failed (prob, reason) -let (giveup_lit : - worklist -> Prims.string -> FStar_TypeChecker_Common.prob -> solution) = - fun wl -> - fun reason -> - fun prob -> - let uu___ = mklstr (fun uu___1 -> reason) in giveup wl uu___ prob -let (singleton : - worklist -> FStar_TypeChecker_Common.prob -> Prims.bool -> worklist) = - fun wl -> - fun prob -> - fun smt_ok -> - { - attempting = [prob]; - wl_deferred = (wl.wl_deferred); - wl_deferred_to_tac = (wl.wl_deferred_to_tac); - ctr = (wl.ctr); - defer_ok = (wl.defer_ok); - smt_ok; - umax_heuristic_ok = (wl.umax_heuristic_ok); - tcenv = (wl.tcenv); - wl_implicits = (wl.wl_implicits); - repr_subcomp_allowed = (wl.repr_subcomp_allowed); - typeclass_variables = (wl.typeclass_variables) - } -let wl_of_guard : - 'uuuuu 'uuuuu1 . - FStar_TypeChecker_Env.env -> - ('uuuuu * 'uuuuu1 * FStar_TypeChecker_Common.prob) Prims.list -> - worklist - = - fun env -> - fun g -> - let uu___ = empty_worklist env in - let uu___1 = - FStar_Compiler_List.map - (fun uu___2 -> match uu___2 with | (uu___3, uu___4, p) -> p) g in - { - attempting = uu___1; - wl_deferred = (uu___.wl_deferred); - wl_deferred_to_tac = (uu___.wl_deferred_to_tac); - ctr = (uu___.ctr); - defer_ok = (uu___.defer_ok); - smt_ok = (uu___.smt_ok); - umax_heuristic_ok = (uu___.umax_heuristic_ok); - tcenv = (uu___.tcenv); - wl_implicits = (uu___.wl_implicits); - repr_subcomp_allowed = (uu___.repr_subcomp_allowed); - typeclass_variables = (uu___.typeclass_variables) - } -let (defer : - FStar_TypeChecker_Common.deferred_reason -> - lstring -> FStar_TypeChecker_Common.prob -> worklist -> worklist) - = - fun reason -> - fun msg -> - fun prob -> - fun wl -> - let uu___ = - Obj.magic - (FStar_Class_Listlike.cons () - (Obj.magic (FStar_Compiler_CList.listlike_clist ())) - ((wl.ctr), reason, msg, prob) (Obj.magic wl.wl_deferred)) in - { - attempting = (wl.attempting); - wl_deferred = uu___; - wl_deferred_to_tac = (wl.wl_deferred_to_tac); - ctr = (wl.ctr); - defer_ok = (wl.defer_ok); - smt_ok = (wl.smt_ok); - umax_heuristic_ok = (wl.umax_heuristic_ok); - tcenv = (wl.tcenv); - wl_implicits = (wl.wl_implicits); - repr_subcomp_allowed = (wl.repr_subcomp_allowed); - typeclass_variables = (wl.typeclass_variables) - } -let (defer_lit : - FStar_TypeChecker_Common.deferred_reason -> - Prims.string -> FStar_TypeChecker_Common.prob -> worklist -> worklist) - = - fun reason -> - fun msg -> - fun prob -> - fun wl -> - let uu___ = FStar_Thunk.mkv msg in defer reason uu___ prob wl -let (attempt : - FStar_TypeChecker_Common.prob Prims.list -> worklist -> worklist) = - fun probs -> - fun wl -> - FStar_Compiler_List.iter (def_check_prob "attempt") probs; - { - attempting = (FStar_Compiler_List.op_At probs wl.attempting); - wl_deferred = (wl.wl_deferred); - wl_deferred_to_tac = (wl.wl_deferred_to_tac); - ctr = (wl.ctr); - defer_ok = (wl.defer_ok); - smt_ok = (wl.smt_ok); - umax_heuristic_ok = (wl.umax_heuristic_ok); - tcenv = (wl.tcenv); - wl_implicits = (wl.wl_implicits); - repr_subcomp_allowed = (wl.repr_subcomp_allowed); - typeclass_variables = (wl.typeclass_variables) - } -let (mk_eq2 : - worklist -> - FStar_TypeChecker_Common.prob -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - (FStar_Syntax_Syntax.term * worklist)) - = - fun wl -> - fun prob -> - fun t1 -> - fun t2 -> - let env = p_env wl prob in - FStar_Defensive.def_check_scoped - FStar_TypeChecker_Env.hasBinders_env - FStar_Class_Binders.hasNames_term FStar_Syntax_Print.pretty_term - t1.FStar_Syntax_Syntax.pos "mk_eq2.t1" env t1; - FStar_Defensive.def_check_scoped - FStar_TypeChecker_Env.hasBinders_env - FStar_Class_Binders.hasNames_term FStar_Syntax_Print.pretty_term - t2.FStar_Syntax_Syntax.pos "mk_eq2.t2" env t2; - (let uu___2 = - env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term env - t1 false in - match uu___2 with - | (tt, uu___3) -> - let u = env.FStar_TypeChecker_Env.universe_of env tt in - let uu___4 = FStar_Syntax_Util.mk_eq2 u tt t1 t2 in - (uu___4, wl)) -let (p_invert : - FStar_TypeChecker_Common.prob -> FStar_TypeChecker_Common.prob) = - fun uu___ -> - match uu___ with - | FStar_TypeChecker_Common.TProb p -> - FStar_TypeChecker_Common.TProb (invert p) - | FStar_TypeChecker_Common.CProb p -> - FStar_TypeChecker_Common.CProb (invert p) -let (p_logical : FStar_TypeChecker_Common.prob -> Prims.bool) = - fun uu___ -> - match uu___ with - | FStar_TypeChecker_Common.TProb p -> p.FStar_TypeChecker_Common.logical - | FStar_TypeChecker_Common.CProb p -> p.FStar_TypeChecker_Common.logical -let (set_logical : - Prims.bool -> - FStar_TypeChecker_Common.prob -> FStar_TypeChecker_Common.prob) - = - fun b -> - fun uu___ -> - match uu___ with - | FStar_TypeChecker_Common.TProb p -> - FStar_TypeChecker_Common.TProb - { - FStar_TypeChecker_Common.pid = (p.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = (p.FStar_TypeChecker_Common.lhs); - FStar_TypeChecker_Common.relation = - (p.FStar_TypeChecker_Common.relation); - FStar_TypeChecker_Common.rhs = (p.FStar_TypeChecker_Common.rhs); - FStar_TypeChecker_Common.element = - (p.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (p.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (p.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (p.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = (p.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = - (p.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = b - } - | FStar_TypeChecker_Common.CProb p -> - FStar_TypeChecker_Common.CProb - { - FStar_TypeChecker_Common.pid = (p.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = (p.FStar_TypeChecker_Common.lhs); - FStar_TypeChecker_Common.relation = - (p.FStar_TypeChecker_Common.relation); - FStar_TypeChecker_Common.rhs = (p.FStar_TypeChecker_Common.rhs); - FStar_TypeChecker_Common.element = - (p.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (p.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (p.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (p.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = (p.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = - (p.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = b - } -let (is_top_level_prob : FStar_TypeChecker_Common.prob -> Prims.bool) = - fun p -> (FStar_Compiler_List.length (p_reason p)) = Prims.int_one -let (next_pid : unit -> Prims.int) = - let ctr = FStar_Compiler_Util.mk_ref Prims.int_zero in - fun uu___ -> - FStar_Compiler_Util.incr ctr; FStar_Compiler_Effect.op_Bang ctr -let mk_problem : - 'uuuuu . - worklist -> - FStar_Syntax_Syntax.binder Prims.list -> - FStar_TypeChecker_Common.prob -> - 'uuuuu -> - FStar_TypeChecker_Common.rel -> - 'uuuuu -> - FStar_Syntax_Syntax.bv FStar_Pervasives_Native.option -> - Prims.string -> - ('uuuuu FStar_TypeChecker_Common.problem * worklist) - = - fun wl -> - fun scope -> - fun orig -> - fun lhs -> - fun rel -> - fun rhs -> - fun elt -> - fun reason -> - let scope1 = - match elt with - | FStar_Pervasives_Native.None -> scope - | FStar_Pervasives_Native.Some x -> - let uu___ = - let uu___1 = FStar_Syntax_Syntax.mk_binder x in - [uu___1] in - FStar_Compiler_List.op_At scope uu___ in - let bs = - FStar_Compiler_List.op_At - (p_guard_uvar orig).FStar_Syntax_Syntax.ctx_uvar_binders - scope1 in - let gamma = - let uu___ = - let uu___1 = - FStar_Compiler_List.map - (fun b -> - FStar_Syntax_Syntax.Binding_var - (b.FStar_Syntax_Syntax.binder_bv)) scope1 in - FStar_Compiler_List.rev uu___1 in - FStar_Compiler_List.op_At uu___ - (p_guard_uvar orig).FStar_Syntax_Syntax.ctx_uvar_gamma in - let uu___ = - new_uvar - (Prims.strcat "mk_problem: logical guard for " reason) - wl FStar_Compiler_Range_Type.dummyRange gamma bs - FStar_Syntax_Util.ktype0 - (FStar_Syntax_Syntax.Allow_untyped "logical guard") - FStar_Pervasives_Native.None in - match uu___ with - | (ctx_uvar, lg, wl1) -> - let prob = - let uu___1 = next_pid () in - { - FStar_TypeChecker_Common.pid = uu___1; - FStar_TypeChecker_Common.lhs = lhs; - FStar_TypeChecker_Common.relation = rel; - FStar_TypeChecker_Common.rhs = rhs; - FStar_TypeChecker_Common.element = elt; - FStar_TypeChecker_Common.logical_guard = lg; - FStar_TypeChecker_Common.logical_guard_uvar = - ctx_uvar; - FStar_TypeChecker_Common.reason = (reason :: - (p_reason orig)); - FStar_TypeChecker_Common.loc = (p_loc orig); - FStar_TypeChecker_Common.rank = - FStar_Pervasives_Native.None; - FStar_TypeChecker_Common.logical = (p_logical orig) - } in - (prob, wl1) -let (mk_t_problem : - worklist -> - FStar_Syntax_Syntax.binder Prims.list -> - FStar_TypeChecker_Common.prob -> - FStar_Syntax_Syntax.typ -> - FStar_TypeChecker_Common.rel -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.bv FStar_Pervasives_Native.option -> - Prims.string -> (FStar_TypeChecker_Common.prob * worklist)) - = - fun wl -> - fun scope -> - fun orig -> - fun lhs -> - fun rel -> - fun rhs -> - fun elt -> - fun reason -> - def_check_prob (Prims.strcat reason ".mk_t.arg") orig; - (let uu___1 = - mk_problem wl scope orig lhs rel rhs elt reason in - match uu___1 with - | (p, wl1) -> - (def_check_prob (Prims.strcat reason ".mk_t") - (FStar_TypeChecker_Common.TProb p); - ((FStar_TypeChecker_Common.TProb p), wl1))) -let (mk_c_problem : - worklist -> - FStar_Syntax_Syntax.binder Prims.list -> - FStar_TypeChecker_Common.prob -> - FStar_Syntax_Syntax.comp -> - FStar_TypeChecker_Common.rel -> - FStar_Syntax_Syntax.comp -> - FStar_Syntax_Syntax.bv FStar_Pervasives_Native.option -> - Prims.string -> (FStar_TypeChecker_Common.prob * worklist)) - = - fun wl -> - fun scope -> - fun orig -> - fun lhs -> - fun rel -> - fun rhs -> - fun elt -> - fun reason -> - def_check_prob (Prims.strcat reason ".mk_c.arg") orig; - (let uu___1 = - mk_problem wl scope orig lhs rel rhs elt reason in - match uu___1 with - | (p, wl1) -> - (def_check_prob (Prims.strcat reason ".mk_c") - (FStar_TypeChecker_Common.CProb p); - ((FStar_TypeChecker_Common.CProb p), wl1))) -let new_problem : - 'uuuuu . - worklist -> - FStar_TypeChecker_Env.env -> - 'uuuuu -> - FStar_TypeChecker_Common.rel -> - 'uuuuu -> - FStar_Syntax_Syntax.bv FStar_Pervasives_Native.option -> - FStar_Compiler_Range_Type.range -> - Prims.string -> - ('uuuuu FStar_TypeChecker_Common.problem * worklist) - = - fun wl -> - fun env -> - fun lhs -> - fun rel -> - fun rhs -> - fun subject -> - fun loc -> - fun reason -> - let lg_ty = - match subject with - | FStar_Pervasives_Native.None -> - FStar_Syntax_Util.ktype0 - | FStar_Pervasives_Native.Some x -> - let bs = - let uu___ = FStar_Syntax_Syntax.mk_binder x in - [uu___] in - let uu___ = - FStar_Syntax_Syntax.mk_Total - FStar_Syntax_Util.ktype0 in - FStar_Syntax_Util.arrow bs uu___ in - let uu___ = - let uu___1 = FStar_TypeChecker_Env.all_binders env in - new_uvar - (Prims.strcat "new_problem: logical guard for " reason) - { - attempting = (wl.attempting); - wl_deferred = (wl.wl_deferred); - wl_deferred_to_tac = (wl.wl_deferred_to_tac); - ctr = (wl.ctr); - defer_ok = (wl.defer_ok); - smt_ok = (wl.smt_ok); - umax_heuristic_ok = (wl.umax_heuristic_ok); - tcenv = env; - wl_implicits = (wl.wl_implicits); - repr_subcomp_allowed = (wl.repr_subcomp_allowed); - typeclass_variables = (wl.typeclass_variables) - } loc env.FStar_TypeChecker_Env.gamma uu___1 lg_ty - (FStar_Syntax_Syntax.Allow_untyped "logical guard") - FStar_Pervasives_Native.None in - match uu___ with - | (ctx_uvar, lg, wl1) -> - let lg1 = - match subject with - | FStar_Pervasives_Native.None -> lg - | FStar_Pervasives_Native.Some x -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.bv_to_name x in - FStar_Syntax_Syntax.as_arg uu___3 in - [uu___2] in - FStar_Syntax_Syntax.mk_Tm_app lg uu___1 loc in - let prob = - let uu___1 = next_pid () in - { - FStar_TypeChecker_Common.pid = uu___1; - FStar_TypeChecker_Common.lhs = lhs; - FStar_TypeChecker_Common.relation = rel; - FStar_TypeChecker_Common.rhs = rhs; - FStar_TypeChecker_Common.element = subject; - FStar_TypeChecker_Common.logical_guard = lg1; - FStar_TypeChecker_Common.logical_guard_uvar = - ctx_uvar; - FStar_TypeChecker_Common.reason = [reason]; - FStar_TypeChecker_Common.loc = loc; - FStar_TypeChecker_Common.rank = - FStar_Pervasives_Native.None; - FStar_TypeChecker_Common.logical = false - } in - (prob, wl1) -let (problem_using_guard : - FStar_TypeChecker_Common.prob -> - FStar_Syntax_Syntax.typ -> - FStar_TypeChecker_Common.rel -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.bv FStar_Pervasives_Native.option -> - Prims.string -> - FStar_Syntax_Syntax.typ FStar_TypeChecker_Common.problem) - = - fun orig -> - fun lhs -> - fun rel -> - fun rhs -> - fun elt -> - fun reason -> - let p = - let uu___ = next_pid () in - { - FStar_TypeChecker_Common.pid = uu___; - FStar_TypeChecker_Common.lhs = lhs; - FStar_TypeChecker_Common.relation = rel; - FStar_TypeChecker_Common.rhs = rhs; - FStar_TypeChecker_Common.element = elt; - FStar_TypeChecker_Common.logical_guard = (p_guard orig); - FStar_TypeChecker_Common.logical_guard_uvar = - (p_guard_uvar orig); - FStar_TypeChecker_Common.reason = (reason :: - (p_reason orig)); - FStar_TypeChecker_Common.loc = (p_loc orig); - FStar_TypeChecker_Common.rank = - FStar_Pervasives_Native.None; - FStar_TypeChecker_Common.logical = (p_logical orig) - } in - def_check_prob reason (FStar_TypeChecker_Common.TProb p); p -let (guard_on_element : - worklist -> - FStar_Syntax_Syntax.typ FStar_TypeChecker_Common.problem -> - FStar_Syntax_Syntax.bv -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term) - = - fun wl -> - fun problem -> - fun x -> - fun phi -> - match problem.FStar_TypeChecker_Common.element with - | FStar_Pervasives_Native.None -> - let tcenv = p_env wl (FStar_TypeChecker_Common.TProb problem) in - let u = - tcenv.FStar_TypeChecker_Env.universe_of tcenv - x.FStar_Syntax_Syntax.sort in - FStar_Syntax_Util.mk_forall u x phi - | FStar_Pervasives_Native.Some e -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.bv_to_name e in - (x, uu___3) in - FStar_Syntax_Syntax.NT uu___2 in - [uu___1] in - FStar_Syntax_Subst.subst uu___ phi -let (explain : - worklist -> FStar_TypeChecker_Common.prob -> lstring -> Prims.string) = - fun wl -> - fun d -> - fun s -> - let uu___ = - (FStar_Compiler_Effect.op_Bang dbg_ExplainRel) || - (FStar_Compiler_Effect.op_Bang dbg_Rel) in - if uu___ - then - let uu___1 = FStar_Compiler_Range_Ops.string_of_range (p_loc d) in - let uu___2 = prob_to_string' wl d in - let uu___3 = FStar_Thunk.force s in - FStar_Compiler_Util.format4 - "(%s) Failed to solve the sub-problem\n%s\nWhich arose because:\n\t%s\nFailed because:%s\n" - uu___1 uu___2 (FStar_Compiler_String.concat "\n\t>" (p_reason d)) - uu___3 - else - (let d1 = maybe_invert_p d in - let rel = - match p_rel d1 with - | FStar_TypeChecker_Common.EQ -> "equal to" - | FStar_TypeChecker_Common.SUB -> "a subtype of" - | uu___2 -> failwith "impossible" in - let uu___2 = - match d1 with - | FStar_TypeChecker_Common.TProb tp -> - FStar_TypeChecker_Err.print_discrepancy - (FStar_TypeChecker_Normalize.term_to_string (p_env wl d1)) - tp.FStar_TypeChecker_Common.lhs - tp.FStar_TypeChecker_Common.rhs - | FStar_TypeChecker_Common.CProb cp -> - FStar_TypeChecker_Err.print_discrepancy - (FStar_TypeChecker_Normalize.comp_to_string (p_env wl d1)) - cp.FStar_TypeChecker_Common.lhs - cp.FStar_TypeChecker_Common.rhs in - match uu___2 with - | (lhs, rhs) -> - FStar_Compiler_Util.format3 - "%s is not %s the expected type %s" lhs rel rhs) -let (occurs : - FStar_Syntax_Syntax.ctx_uvar -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.ctx_uvar Prims.list * Prims.bool)) - = - fun uk -> - fun t -> - let uvars = - let uu___ = FStar_Syntax_Free.uvars t in - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) (Obj.magic uu___) in - let occurs1 = - FStar_Compiler_Util.for_some - (fun uv -> - FStar_Syntax_Unionfind.equiv - uv.FStar_Syntax_Syntax.ctx_uvar_head - uk.FStar_Syntax_Syntax.ctx_uvar_head) uvars in - (uvars, occurs1) -let (occurs_check : - FStar_Syntax_Syntax.ctx_uvar -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.ctx_uvar Prims.list * Prims.bool * Prims.string - FStar_Pervasives_Native.option)) - = - fun uk -> - fun t -> - let uu___ = occurs uk t in - match uu___ with - | (uvars, occurs1) -> - let msg = - if Prims.op_Negation occurs1 - then FStar_Pervasives_Native.None - else - (let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_uvar - uk.FStar_Syntax_Syntax.ctx_uvar_head in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.format2 - "occurs-check failed (%s occurs in %s)" uu___3 uu___4 in - FStar_Pervasives_Native.Some uu___2) in - (uvars, (Prims.op_Negation occurs1), msg) -let (occurs_full : - FStar_Syntax_Syntax.ctx_uvar -> FStar_Syntax_Syntax.term -> Prims.bool) = - fun uk -> - fun t -> - let uvars = - let uu___ = FStar_Syntax_Free.uvars_full t in - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) (Obj.magic uu___) in - let occurs1 = - FStar_Compiler_Util.for_some - (fun uv -> - FStar_Syntax_Unionfind.equiv - uv.FStar_Syntax_Syntax.ctx_uvar_head - uk.FStar_Syntax_Syntax.ctx_uvar_head) uvars in - occurs1 -let set_uvar : - 'uuuuu . - 'uuuuu -> - FStar_Syntax_Syntax.ctx_uvar -> - FStar_Syntax_Syntax.should_check_uvar FStar_Pervasives_Native.option - -> FStar_Syntax_Syntax.term -> unit - = - fun env -> - fun u -> - fun should_check_opt -> - fun t -> - (match should_check_opt with - | FStar_Pervasives_Native.None -> () - | FStar_Pervasives_Native.Some should_check -> - let uu___1 = - let uu___2 = - FStar_Syntax_Unionfind.find_decoration - u.FStar_Syntax_Syntax.ctx_uvar_head in - { - FStar_Syntax_Syntax.uvar_decoration_typ = - (uu___2.FStar_Syntax_Syntax.uvar_decoration_typ); - FStar_Syntax_Syntax.uvar_decoration_typedness_depends_on = - (uu___2.FStar_Syntax_Syntax.uvar_decoration_typedness_depends_on); - FStar_Syntax_Syntax.uvar_decoration_should_check = - should_check; - FStar_Syntax_Syntax.uvar_decoration_should_unrefine = - (uu___2.FStar_Syntax_Syntax.uvar_decoration_should_unrefine) - } in - FStar_Syntax_Unionfind.change_decoration - u.FStar_Syntax_Syntax.ctx_uvar_head uu___1); - (let uu___2 = FStar_Options.defensive () in - if uu___2 - then - let uu___3 = - let uu___4 = occurs u t in FStar_Pervasives_Native.snd uu___4 in - (if uu___3 then failwith "OCCURS BUG!" else ()) - else ()); - FStar_Syntax_Util.set_uvar u.FStar_Syntax_Syntax.ctx_uvar_head t -let (commit : FStar_TypeChecker_Env.env_t -> uvi Prims.list -> unit) = - fun env -> - fun uvis -> - FStar_Compiler_List.iter - (fun uu___ -> - match uu___ with - | UNIV (u, t) -> - (match t with - | FStar_Syntax_Syntax.U_unif u' -> - FStar_Syntax_Unionfind.univ_union u u' - | uu___1 -> FStar_Syntax_Unionfind.univ_change u t) - | TERM (u, t) -> - ((let uu___2 = - FStar_Compiler_List.map - (fun b -> b.FStar_Syntax_Syntax.binder_bv) - u.FStar_Syntax_Syntax.ctx_uvar_binders in - FStar_Defensive.def_check_scoped - FStar_Class_Binders.hasBinders_list_bv - FStar_Class_Binders.hasNames_term - FStar_Syntax_Print.pretty_term t.FStar_Syntax_Syntax.pos - "commit" uu___2 t); - set_uvar env u FStar_Pervasives_Native.None t)) uvis -let (find_term_uvar : - FStar_Syntax_Syntax.uvar -> - uvi Prims.list -> FStar_Syntax_Syntax.term FStar_Pervasives_Native.option) - = - fun uv -> - fun s -> - FStar_Compiler_Util.find_map s - (fun uu___ -> - match uu___ with - | UNIV uu___1 -> FStar_Pervasives_Native.None - | TERM (u, t) -> - let uu___1 = - FStar_Syntax_Unionfind.equiv uv - u.FStar_Syntax_Syntax.ctx_uvar_head in - if uu___1 - then FStar_Pervasives_Native.Some t - else FStar_Pervasives_Native.None) -let (find_univ_uvar : - FStar_Syntax_Syntax.universe_uvar -> - uvi Prims.list -> - FStar_Syntax_Syntax.universe FStar_Pervasives_Native.option) - = - fun u -> - fun s -> - FStar_Compiler_Util.find_map s - (fun uu___ -> - match uu___ with - | UNIV (u', t) -> - let uu___1 = FStar_Syntax_Unionfind.univ_equiv u u' in - if uu___1 - then FStar_Pervasives_Native.Some t - else FStar_Pervasives_Native.None - | uu___1 -> FStar_Pervasives_Native.None) -let (sn' : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun env -> - fun t -> - let uu___ = - let uu___1 = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Beta; FStar_TypeChecker_Env.Reify] env t in - FStar_Syntax_Subst.compress uu___1 in - FStar_Syntax_Util.unlazy_emb uu___ -let (sn : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun env -> - fun t -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_Env.current_module env in - FStar_Ident.string_of_lid uu___2 in - FStar_Pervasives_Native.Some uu___1 in - FStar_Profiling.profile (fun uu___1 -> sn' env t) uu___ - "FStar.TypeChecker.Rel.sn" -let (norm_with_steps : - Prims.string -> - FStar_TypeChecker_Env.steps -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun profiling_tag -> - fun steps -> - fun env -> - fun t -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_Env.current_module env in - FStar_Ident.string_of_lid uu___2 in - FStar_Pervasives_Native.Some uu___1 in - FStar_Profiling.profile - (fun uu___1 -> FStar_TypeChecker_Normalize.normalize steps env t) - uu___ profiling_tag -let (should_strongly_reduce : FStar_Syntax_Syntax.term -> Prims.bool) = - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Util.unascribe t in - FStar_Syntax_Util.head_and_args uu___1 in - match uu___ with - | (h, uu___1) -> - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress h in - uu___3.FStar_Syntax_Syntax.n in - (match uu___2 with - | FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_reify uu___3) - -> true - | uu___3 -> false) -let (whnf : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun env -> - fun t -> - let norm steps t1 = - let uu___ = - let uu___1 = - let uu___2 = FStar_Syntax_Util.unmeta t1 in - FStar_TypeChecker_Normalize.normalize steps env uu___2 in - FStar_Syntax_Subst.compress uu___1 in - FStar_Syntax_Util.unlazy_emb uu___ in - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_Env.current_module env in - FStar_Ident.string_of_lid uu___2 in - FStar_Pervasives_Native.Some uu___1 in - FStar_Profiling.profile - (fun uu___1 -> - let steps = - let uu___2 = - let uu___3 = should_strongly_reduce t in - if uu___3 - then - [FStar_TypeChecker_Env.Exclude FStar_TypeChecker_Env.Zeta; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant] - else [FStar_TypeChecker_Env.Weak; FStar_TypeChecker_Env.HNF] in - FStar_Compiler_List.op_At uu___2 - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Reify; - FStar_TypeChecker_Env.Primops] in - norm steps t) uu___ "FStar.TypeChecker.Rel.whnf" -let norm_arg : - 'uuuuu . - FStar_TypeChecker_Env.env -> - (FStar_Syntax_Syntax.term * 'uuuuu) -> - (FStar_Syntax_Syntax.term * 'uuuuu) - = - fun env -> - fun t -> - let uu___ = sn env (FStar_Pervasives_Native.fst t) in - (uu___, (FStar_Pervasives_Native.snd t)) -let (sn_binders : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.binders -> FStar_Syntax_Syntax.binder Prims.list) - = - fun env -> - fun binders -> - FStar_Compiler_List.map - (fun b -> - let uu___ = - let uu___1 = b.FStar_Syntax_Syntax.binder_bv in - let uu___2 = - sn env - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - { - FStar_Syntax_Syntax.ppname = - (uu___1.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = (uu___1.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = uu___2 - } in - { - FStar_Syntax_Syntax.binder_bv = uu___; - FStar_Syntax_Syntax.binder_qual = - (b.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity = - (b.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs = - (b.FStar_Syntax_Syntax.binder_attrs) - }) binders -let (norm_univ : - worklist -> FStar_Syntax_Syntax.universe -> FStar_Syntax_Syntax.universe) = - fun wl -> - fun u -> - let rec aux u1 = - let u2 = FStar_Syntax_Subst.compress_univ u1 in - match u2 with - | FStar_Syntax_Syntax.U_succ u3 -> - let uu___ = aux u3 in FStar_Syntax_Syntax.U_succ uu___ - | FStar_Syntax_Syntax.U_max us -> - let uu___ = FStar_Compiler_List.map aux us in - FStar_Syntax_Syntax.U_max uu___ - | uu___ -> u2 in - let uu___ = aux u in - FStar_TypeChecker_Normalize.normalize_universe wl.tcenv uu___ -let (normalize_refinement : - FStar_TypeChecker_Env.steps -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.term) - = - fun steps -> - fun env -> - fun t0 -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_Env.current_module env in - FStar_Ident.string_of_lid uu___2 in - FStar_Pervasives_Native.Some uu___1 in - FStar_Profiling.profile - (fun uu___1 -> - FStar_TypeChecker_Normalize.normalize_refinement steps env t0) - uu___ "FStar.TypeChecker.Rel.normalize_refinement" -let (base_and_refinement_maybe_delta : - Prims.bool -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * (FStar_Syntax_Syntax.bv * - FStar_Syntax_Syntax.term) FStar_Pervasives_Native.option)) - = - fun should_delta -> - fun env -> - fun t1 -> - let norm_refinement env1 t = - let steps = - if should_delta - then - [FStar_TypeChecker_Env.Weak; - FStar_TypeChecker_Env.HNF; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant] - else [FStar_TypeChecker_Env.Weak; FStar_TypeChecker_Env.HNF] in - normalize_refinement steps env1 t in - let rec aux norm t11 = - let t12 = FStar_Syntax_Util.unmeta t11 in - match t12.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x; FStar_Syntax_Syntax.phi = phi;_} - -> - if norm - then - ((x.FStar_Syntax_Syntax.sort), - (FStar_Pervasives_Native.Some (x, phi))) - else - (let uu___1 = norm_refinement env t12 in - match uu___1 with - | { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x1; - FStar_Syntax_Syntax.phi = phi1;_}; - FStar_Syntax_Syntax.pos = uu___2; - FStar_Syntax_Syntax.vars = uu___3; - FStar_Syntax_Syntax.hash_code = uu___4;_} -> - ((x1.FStar_Syntax_Syntax.sort), - (FStar_Pervasives_Native.Some (x1, phi1))) - | tt -> - let uu___2 = - let uu___3 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term tt in - let uu___4 = - FStar_Class_Tagged.tag_of - FStar_Syntax_Syntax.tagged_term tt in - FStar_Compiler_Util.format2 - "impossible: Got %s ... %s\n" uu___3 uu___4 in - failwith uu___2) - | FStar_Syntax_Syntax.Tm_lazy i -> - let uu___ = FStar_Syntax_Util.unfold_lazy i in aux norm uu___ - | FStar_Syntax_Syntax.Tm_uinst uu___ -> - if norm - then (t12, FStar_Pervasives_Native.None) - else - (let t1' = norm_refinement env t12 in - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress t1' in - uu___3.FStar_Syntax_Syntax.n in - match uu___2 with - | FStar_Syntax_Syntax.Tm_refine uu___3 -> aux true t1' - | uu___3 -> (t12, FStar_Pervasives_Native.None)) - | FStar_Syntax_Syntax.Tm_fvar uu___ -> - if norm - then (t12, FStar_Pervasives_Native.None) - else - (let t1' = norm_refinement env t12 in - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress t1' in - uu___3.FStar_Syntax_Syntax.n in - match uu___2 with - | FStar_Syntax_Syntax.Tm_refine uu___3 -> aux true t1' - | uu___3 -> (t12, FStar_Pervasives_Native.None)) - | FStar_Syntax_Syntax.Tm_app uu___ -> - if norm - then (t12, FStar_Pervasives_Native.None) - else - (let t1' = norm_refinement env t12 in - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress t1' in - uu___3.FStar_Syntax_Syntax.n in - match uu___2 with - | FStar_Syntax_Syntax.Tm_refine uu___3 -> aux true t1' - | uu___3 -> (t12, FStar_Pervasives_Native.None)) - | FStar_Syntax_Syntax.Tm_type uu___ -> - (t12, FStar_Pervasives_Native.None) - | FStar_Syntax_Syntax.Tm_constant uu___ -> - (t12, FStar_Pervasives_Native.None) - | FStar_Syntax_Syntax.Tm_name uu___ -> - (t12, FStar_Pervasives_Native.None) - | FStar_Syntax_Syntax.Tm_bvar uu___ -> - (t12, FStar_Pervasives_Native.None) - | FStar_Syntax_Syntax.Tm_arrow uu___ -> - (t12, FStar_Pervasives_Native.None) - | FStar_Syntax_Syntax.Tm_abs uu___ -> - (t12, FStar_Pervasives_Native.None) - | FStar_Syntax_Syntax.Tm_quoted uu___ -> - (t12, FStar_Pervasives_Native.None) - | FStar_Syntax_Syntax.Tm_uvar uu___ -> - (t12, FStar_Pervasives_Native.None) - | FStar_Syntax_Syntax.Tm_let uu___ -> - (t12, FStar_Pervasives_Native.None) - | FStar_Syntax_Syntax.Tm_match uu___ -> - (t12, FStar_Pervasives_Native.None) - | FStar_Syntax_Syntax.Tm_meta uu___ -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t12 in - let uu___3 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term - t12 in - FStar_Compiler_Util.format2 - "impossible (outer): Got %s ... %s\n" uu___2 uu___3 in - failwith uu___1 - | FStar_Syntax_Syntax.Tm_ascribed uu___ -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t12 in - let uu___3 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term - t12 in - FStar_Compiler_Util.format2 - "impossible (outer): Got %s ... %s\n" uu___2 uu___3 in - failwith uu___1 - | FStar_Syntax_Syntax.Tm_delayed uu___ -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t12 in - let uu___3 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term - t12 in - FStar_Compiler_Util.format2 - "impossible (outer): Got %s ... %s\n" uu___2 uu___3 in - failwith uu___1 - | FStar_Syntax_Syntax.Tm_unknown -> - let uu___ = - let uu___1 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t12 in - let uu___2 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term - t12 in - FStar_Compiler_Util.format2 - "impossible (outer): Got %s ... %s\n" uu___1 uu___2 in - failwith uu___ in - let uu___ = whnf env t1 in aux false uu___ -let (base_and_refinement : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * (FStar_Syntax_Syntax.bv * - FStar_Syntax_Syntax.term) FStar_Pervasives_Native.option)) - = fun env -> fun t -> base_and_refinement_maybe_delta false env t -let (unrefine : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.typ) - = - fun env -> - fun t -> - let uu___ = base_and_refinement env t in - FStar_Pervasives_Native.fst uu___ -let (trivial_refinement : - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.bv * FStar_Syntax_Syntax.term)) - = - fun t -> - let uu___ = FStar_Syntax_Syntax.null_bv t in - (uu___, FStar_Syntax_Util.t_true) -let (as_refinement : - Prims.bool -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.bv * FStar_Syntax_Syntax.term)) - = - fun delta -> - fun env -> - fun t -> - let uu___ = base_and_refinement_maybe_delta delta env t in - match uu___ with - | (t_base, refinement) -> - (match refinement with - | FStar_Pervasives_Native.None -> trivial_refinement t_base - | FStar_Pervasives_Native.Some (x, phi) -> (x, phi)) -let (force_refinement : - (FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * - (FStar_Syntax_Syntax.bv * FStar_Syntax_Syntax.term) - FStar_Pervasives_Native.option) -> FStar_Syntax_Syntax.term) - = - fun uu___ -> - match uu___ with - | (t_base, refopt) -> - let uu___1 = - match refopt with - | FStar_Pervasives_Native.Some (y, phi) -> (y, phi) - | FStar_Pervasives_Native.None -> trivial_refinement t_base in - (match uu___1 with - | (y, phi) -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = y; FStar_Syntax_Syntax.phi = phi - }) t_base.FStar_Syntax_Syntax.pos) -let (wl_to_string : worklist -> Prims.string) = - fun wl -> - let probs_to_string ps = - let uu___ = FStar_Compiler_List.map (prob_to_string' wl) ps in - FStar_Compiler_String.concat "\n\t" uu___ in - let cprobs_to_string ps = - let uu___ = - let uu___1 = FStar_Compiler_CList.map (prob_to_string' wl) ps in - FStar_Class_Listlike.to_list (FStar_Compiler_CList.listlike_clist ()) - uu___1 in - FStar_Compiler_String.concat "\n\t" uu___ in - let uu___ = probs_to_string wl.attempting in - let uu___1 = - let uu___2 = - FStar_Compiler_CList.map - (fun uu___3 -> match uu___3 with | (uu___4, uu___5, uu___6, x) -> x) - wl.wl_deferred in - cprobs_to_string uu___2 in - FStar_Compiler_Util.format2 - "{ attempting = [ %s ];\ndeferred = [ %s ] }\n" uu___ uu___1 -let (showable_wl : worklist FStar_Class_Show.showable) = - { FStar_Class_Show.show = wl_to_string } -type flex_t = - | Flex of (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.ctx_uvar * - FStar_Syntax_Syntax.args) -let (uu___is_Flex : flex_t -> Prims.bool) = fun projectee -> true -let (__proj__Flex__item___0 : - flex_t -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.ctx_uvar * - FStar_Syntax_Syntax.args)) - = fun projectee -> match projectee with | Flex _0 -> _0 -let (flex_reason : flex_t -> Prims.string) = - fun uu___ -> - match uu___ with - | Flex (uu___1, u, uu___2) -> u.FStar_Syntax_Syntax.ctx_uvar_reason -let (flex_uvar : flex_t -> FStar_Syntax_Syntax.ctx_uvar) = - fun uu___ -> match uu___ with | Flex (uu___1, u, uu___2) -> u -let (flex_uvar_has_meta_tac : FStar_Syntax_Syntax.ctx_uvar -> Prims.bool) = - fun u -> - match u.FStar_Syntax_Syntax.ctx_uvar_meta with - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Ctx_uvar_meta_tac - uu___) -> true - | uu___ -> false -let (flex_t_to_string : flex_t -> Prims.string) = - fun uu___ -> - match uu___ with - | Flex (uu___1, c, args) -> - let uu___2 = FStar_Class_Show.show FStar_Syntax_Print.showable_ctxu c in - let uu___3 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - (FStar_Class_Show.show_tuple2 FStar_Syntax_Print.showable_term - FStar_Syntax_Print.showable_aqual)) args in - FStar_Compiler_Util.format2 "%s [%s]" uu___2 uu___3 -let (is_flex : FStar_Syntax_Syntax.term -> Prims.bool) = - fun t -> - let uu___ = FStar_Syntax_Util.head_and_args t in - match uu___ with - | (head, _args) -> - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress head in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_uvar uu___2 -> true - | uu___2 -> false) -let (flex_uvar_head : - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.ctx_uvar) = - fun t -> - let uu___ = FStar_Syntax_Util.head_and_args t in - match uu___ with - | (head, _args) -> - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress head in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_uvar (u, uu___2) -> u - | uu___2 -> failwith "Not a flex-uvar") -let ensure_no_uvar_subst : - 'uuuuu . - 'uuuuu -> - FStar_Syntax_Syntax.term -> - worklist -> (FStar_Syntax_Syntax.term * worklist) - = - fun env -> - fun t0 -> - fun wl -> - let bv_not_affected_by s x = - let t_x = FStar_Syntax_Syntax.bv_to_name x in - let t_x' = FStar_Syntax_Subst.subst' s t_x in - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t_x' in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_name y -> FStar_Syntax_Syntax.bv_eq x y - | uu___1 -> false in - let binding_not_affected_by s b = - match b with - | FStar_Syntax_Syntax.Binding_var x -> bv_not_affected_by s x - | uu___ -> true in - let uu___ = FStar_Syntax_Util.head_and_args t0 in - match uu___ with - | (head, args) -> - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress head in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_uvar (uv, ([], uu___2)) -> (t0, wl) - | FStar_Syntax_Syntax.Tm_uvar (uv, uu___2) when - FStar_Compiler_List.isEmpty - uv.FStar_Syntax_Syntax.ctx_uvar_binders - -> (t0, wl) - | FStar_Syntax_Syntax.Tm_uvar (uv, s) -> - let uu___2 = - FStar_Common.max_suffix (binding_not_affected_by s) - uv.FStar_Syntax_Syntax.ctx_uvar_gamma in - (match uu___2 with - | (gamma_aff, new_gamma) -> - (match gamma_aff with - | [] -> (t0, wl) - | uu___3 -> - let dom_binders = - FStar_TypeChecker_Env.binders_of_bindings - gamma_aff in - let uu___4 = - let uu___5 = - FStar_TypeChecker_Env.binders_of_bindings - new_gamma in - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Syntax_Util.ctx_uvar_typ uv in - FStar_Syntax_Syntax.mk_Total uu___8 in - FStar_Syntax_Util.arrow dom_binders uu___7 in - let uu___7 = - FStar_Syntax_Util.ctx_uvar_should_check uv in - new_uvar - (Prims.strcat - uv.FStar_Syntax_Syntax.ctx_uvar_reason - "; force delayed") wl - t0.FStar_Syntax_Syntax.pos new_gamma uu___5 - uu___6 uu___7 - uv.FStar_Syntax_Syntax.ctx_uvar_meta in - (match uu___4 with - | (v, t_v, wl1) -> - let args_sol = - FStar_Compiler_List.map - FStar_Syntax_Util.arg_of_non_null_binder - dom_binders in - let sol = - FStar_Syntax_Syntax.mk_Tm_app t_v args_sol - t0.FStar_Syntax_Syntax.pos in - ((let uu___6 = - FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___6 - then - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_ctxu uv in - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term sol in - FStar_Compiler_Util.print2 - "ensure_no_uvar_subst solving %s with %s\n" - uu___7 uu___8 - else ()); - set_uvar env uv - (FStar_Pervasives_Native.Some - FStar_Syntax_Syntax.Already_checked) - sol; - (let args_sol_s = - FStar_Compiler_List.map - (fun uu___7 -> - match uu___7 with - | (a, i) -> - let uu___8 = - FStar_Syntax_Subst.subst' s a in - (uu___8, i)) args_sol in - let t = - FStar_Syntax_Syntax.mk_Tm_app t_v - (FStar_Compiler_List.op_At args_sol_s - args) t0.FStar_Syntax_Syntax.pos in - (t, wl1)))))) - | uu___2 -> - let uu___3 = - let uu___4 = - FStar_Class_Tagged.tag_of - FStar_Syntax_Syntax.tagged_term t0 in - let uu___5 = - FStar_Class_Tagged.tag_of - FStar_Syntax_Syntax.tagged_term head in - let uu___6 = - let uu___7 = FStar_Syntax_Subst.compress head in - FStar_Class_Tagged.tag_of - FStar_Syntax_Syntax.tagged_term uu___7 in - FStar_Compiler_Util.format3 - "ensure_no_uvar_subst: expected a uvar at the head (%s-%s-%s)" - uu___4 uu___5 uu___6 in - failwith uu___3) -let (no_free_uvars : FStar_Syntax_Syntax.term -> Prims.bool) = - fun t -> - (let uu___ = FStar_Syntax_Free.uvars t in - FStar_Class_Setlike.is_empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) (Obj.magic uu___)) - && - (let uu___ = FStar_Syntax_Free.univs t in - FStar_Class_Setlike.is_empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_univ_uvar)) (Obj.magic uu___)) -let rec (may_relate_with_logical_guard : - FStar_TypeChecker_Env.env -> - Prims.bool -> FStar_Syntax_Syntax.typ -> Prims.bool) - = - fun env -> - fun is_eq -> - fun head -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress head in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_name uu___1 -> true - | FStar_Syntax_Syntax.Tm_match uu___1 -> true - | FStar_Syntax_Syntax.Tm_fvar fv -> - let uu___1 = FStar_TypeChecker_Env.delta_depth_of_fv env fv in - (match uu___1 with - | FStar_Syntax_Syntax.Delta_equational_at_level uu___2 -> true - | FStar_Syntax_Syntax.Delta_abstract uu___2 -> is_eq - | uu___2 -> false) - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t; FStar_Syntax_Syntax.asc = uu___1; - FStar_Syntax_Syntax.eff_opt = uu___2;_} - -> may_relate_with_logical_guard env is_eq t - | FStar_Syntax_Syntax.Tm_uinst (t, uu___1) -> - may_relate_with_logical_guard env is_eq t - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t; - FStar_Syntax_Syntax.meta = uu___1;_} - -> may_relate_with_logical_guard env is_eq t - | uu___1 -> false -let (may_relate : - FStar_TypeChecker_Env.env -> - FStar_TypeChecker_Common.rel -> FStar_Syntax_Syntax.typ -> Prims.bool) - = - fun env -> - fun prel -> - fun head -> - may_relate_with_logical_guard env - (FStar_TypeChecker_Common.uu___is_EQ prel) head -let (destruct_flex_t' : FStar_Syntax_Syntax.term -> flex_t) = - fun t -> - let uu___ = FStar_Syntax_Util.head_and_args t in - match uu___ with - | (head, args) -> - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress head in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_uvar (uv, s) -> Flex (t, uv, args) - | uu___2 -> failwith "Not a flex-uvar") -let (destruct_flex_t : - FStar_Syntax_Syntax.term -> worklist -> (flex_t * worklist)) = - fun t -> - fun wl -> - let uu___ = ensure_no_uvar_subst wl.tcenv t wl in - match uu___ with - | (t1, wl1) -> let uu___1 = destruct_flex_t' t1 in (uu___1, wl1) -let (u_abs : - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun k -> - fun ys -> - fun t -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress k in - uu___2.FStar_Syntax_Syntax.n in - match uu___1 with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; FStar_Syntax_Syntax.comp = c;_} - -> - if - (FStar_Compiler_List.length bs) = - (FStar_Compiler_List.length ys) - then - let uu___2 = FStar_Syntax_Subst.open_comp bs c in - ((ys, t), uu___2) - else - (let uu___3 = FStar_Syntax_Util.abs_formals t in - match uu___3 with - | (ys', t1, uu___4) -> - let uu___5 = FStar_Syntax_Util.arrow_formals_comp k in - (((FStar_Compiler_List.op_At ys ys'), t1), uu___5)) - | uu___2 -> - let uu___3 = - let uu___4 = FStar_Syntax_Syntax.mk_Total k in ([], uu___4) in - ((ys, t), uu___3) in - match uu___ with - | ((ys1, t1), (xs, c)) -> - if - (FStar_Compiler_List.length xs) <> - (FStar_Compiler_List.length ys1) - then - FStar_Syntax_Util.abs ys1 t1 - (FStar_Pervasives_Native.Some - (FStar_Syntax_Util.mk_residual_comp - FStar_Parser_Const.effect_Tot_lid - FStar_Pervasives_Native.None [])) - else - (let c1 = - let uu___2 = FStar_Syntax_Util.rename_binders xs ys1 in - FStar_Syntax_Subst.subst_comp uu___2 c in - let uu___2 = - let uu___3 = FStar_Syntax_Util.residual_comp_of_comp c1 in - FStar_Pervasives_Native.Some uu___3 in - FStar_Syntax_Util.abs ys1 t1 uu___2) -let (solve_prob' : - Prims.bool -> - FStar_TypeChecker_Common.prob -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - FStar_Pervasives_Native.option -> - uvi Prims.list -> worklist -> worklist) - = - fun resolve_ok -> - fun prob -> - fun logical_guard -> - fun uvis -> - fun wl -> - def_check_prob "solve_prob'" prob; - (let phi = - match logical_guard with - | FStar_Pervasives_Native.None -> FStar_Syntax_Util.t_true - | FStar_Pervasives_Native.Some phi1 -> phi1 in - let assign_solution xs uv phi1 = - (let uu___2 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___2 - then - let uu___3 = FStar_Compiler_Util.string_of_int (p_pid prob) in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_ctxu uv in - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - phi1 in - FStar_Compiler_Util.print3 - "Solving %s (%s) with formula %s\n" uu___3 uu___4 uu___5 - else ()); - (let phi2 = - FStar_Syntax_Util.abs xs phi1 - (FStar_Pervasives_Native.Some - (FStar_Syntax_Util.residual_tot - FStar_Syntax_Util.ktype0)) in - (let uu___3 = - let uu___4 = - FStar_Compiler_Util.string_of_int (p_pid prob) in - Prims.strcat "solve_prob'.sol." uu___4 in - let uu___4 = - let uu___5 = p_scope prob in - FStar_Compiler_List.map - (fun b -> b.FStar_Syntax_Syntax.binder_bv) uu___5 in - FStar_Defensive.def_check_scoped - FStar_Class_Binders.hasBinders_list_bv - FStar_Class_Binders.hasNames_term - FStar_Syntax_Print.pretty_term (p_loc prob) uu___3 uu___4 - phi2); - set_uvar wl.tcenv uv FStar_Pervasives_Native.None phi2) in - let uv = p_guard_uvar prob in - let fail uu___1 = - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_ctxu uv in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - (p_guard prob) in - FStar_Compiler_Util.format2 - "Impossible: this instance %s has already been assigned a solution\n%s\n" - uu___3 uu___4 in - failwith uu___2 in - let args_as_binders args = - FStar_Compiler_List.collect - (fun uu___1 -> - match uu___1 with - | (a, i) -> - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress a in - uu___3.FStar_Syntax_Syntax.n in - (match uu___2 with - | FStar_Syntax_Syntax.Tm_name x -> - let uu___3 = - FStar_Syntax_Util.bqual_and_attrs_of_aqual i in - (match uu___3 with - | (q, attrs) -> - let uu___4 = - FStar_Syntax_Util.parse_positivity_attributes - attrs in - (match uu___4 with - | (pq, attrs1) -> - let uu___5 = - FStar_Syntax_Syntax.mk_binder_with_attrs - x q pq attrs1 in - [uu___5])) - | uu___3 -> (fail (); []))) args in - let wl1 = - let g = whnf (p_guard_env wl prob) (p_guard prob) in - let uu___1 = - let uu___2 = is_flex g in Prims.op_Negation uu___2 in - if uu___1 - then (if resolve_ok then wl else (fail (); wl)) - else - (let uu___3 = destruct_flex_t g wl in - match uu___3 with - | (Flex (uu___4, uv1, args), wl2) -> - ((let uu___6 = args_as_binders args in - assign_solution uu___6 uv1 phi); - wl2)) in - commit wl1.tcenv uvis; - { - attempting = (wl1.attempting); - wl_deferred = (wl1.wl_deferred); - wl_deferred_to_tac = (wl1.wl_deferred_to_tac); - ctr = (wl1.ctr + Prims.int_one); - defer_ok = (wl1.defer_ok); - smt_ok = (wl1.smt_ok); - umax_heuristic_ok = (wl1.umax_heuristic_ok); - tcenv = (wl1.tcenv); - wl_implicits = (wl1.wl_implicits); - repr_subcomp_allowed = (wl1.repr_subcomp_allowed); - typeclass_variables = (wl1.typeclass_variables) - }) -let (extend_universe_solution : - Prims.int -> uvi Prims.list -> worklist -> worklist) = - fun pid -> - fun sol -> - fun wl -> - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___1 - then - let uu___2 = FStar_Compiler_Util.string_of_int pid in - let uu___3 = uvis_to_string wl.tcenv sol in - FStar_Compiler_Util.print2 "Solving %s: with [%s]\n" uu___2 uu___3 - else ()); - commit wl.tcenv sol; - { - attempting = (wl.attempting); - wl_deferred = (wl.wl_deferred); - wl_deferred_to_tac = (wl.wl_deferred_to_tac); - ctr = (wl.ctr + Prims.int_one); - defer_ok = (wl.defer_ok); - smt_ok = (wl.smt_ok); - umax_heuristic_ok = (wl.umax_heuristic_ok); - tcenv = (wl.tcenv); - wl_implicits = (wl.wl_implicits); - repr_subcomp_allowed = (wl.repr_subcomp_allowed); - typeclass_variables = (wl.typeclass_variables) - } -let (solve_prob : - FStar_TypeChecker_Common.prob -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option -> - uvi Prims.list -> worklist -> worklist) - = - fun prob -> - fun logical_guard -> - fun uvis -> - fun wl -> - def_check_prob "solve_prob.prob" prob; - FStar_Compiler_Util.iter_opt logical_guard - (def_check_term_scoped_in_prob "solve_prob.guard" prob); - (let uu___3 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___3 - then - let uu___4 = FStar_Compiler_Util.string_of_int (p_pid prob) in - let uu___5 = uvis_to_string wl.tcenv uvis in - FStar_Compiler_Util.print2 "Solving %s: with %s\n" uu___4 uu___5 - else ()); - solve_prob' false prob logical_guard uvis wl -let rec (maximal_prefix : - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.binders -> - (FStar_Syntax_Syntax.binders * (FStar_Syntax_Syntax.binders * - FStar_Syntax_Syntax.binders))) - = - fun bs -> - fun bs' -> - match (bs, bs') with - | (binder1::bs_tail, - { FStar_Syntax_Syntax.binder_bv = b'; - FStar_Syntax_Syntax.binder_qual = i'; - FStar_Syntax_Syntax.binder_positivity = uu___; - FStar_Syntax_Syntax.binder_attrs = uu___1;_}::bs'_tail) - -> - let uu___2 = - FStar_Syntax_Syntax.bv_eq binder1.FStar_Syntax_Syntax.binder_bv - b' in - if uu___2 - then - let uu___3 = maximal_prefix bs_tail bs'_tail in - (match uu___3 with | (pfx, rest) -> ((binder1 :: pfx), rest)) - else ([], (bs, bs')) - | uu___ -> ([], (bs, bs')) -let (extend_gamma : - FStar_Syntax_Syntax.gamma -> - FStar_Syntax_Syntax.binders -> FStar_Syntax_Syntax.binding Prims.list) - = - fun g -> - fun bs -> - FStar_Compiler_List.fold_left - (fun g1 -> - fun uu___ -> - match uu___ with - | { FStar_Syntax_Syntax.binder_bv = x; - FStar_Syntax_Syntax.binder_qual = uu___1; - FStar_Syntax_Syntax.binder_positivity = uu___2; - FStar_Syntax_Syntax.binder_attrs = uu___3;_} -> - (FStar_Syntax_Syntax.Binding_var x) :: g1) g bs -let (gamma_until : - FStar_Syntax_Syntax.gamma -> - FStar_Syntax_Syntax.binders -> FStar_Syntax_Syntax.binding Prims.list) - = - fun g -> - fun bs -> - let uu___ = FStar_Compiler_List.last_opt bs in - match uu___ with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.binder_bv = x; - FStar_Syntax_Syntax.binder_qual = uu___1; - FStar_Syntax_Syntax.binder_positivity = uu___2; - FStar_Syntax_Syntax.binder_attrs = uu___3;_} - -> - let uu___4 = - FStar_Compiler_Util.prefix_until - (fun uu___5 -> - match uu___5 with - | FStar_Syntax_Syntax.Binding_var x' -> - FStar_Syntax_Syntax.bv_eq x x' - | uu___6 -> false) g in - (match uu___4 with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some (uu___5, bx, rest) -> bx :: rest) -let restrict_ctx : - 'uuuuu . - 'uuuuu -> - FStar_Syntax_Syntax.ctx_uvar -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.ctx_uvar -> worklist -> worklist - = - fun env -> - fun tgt -> - fun bs -> - fun src -> - fun wl -> - let uu___ = - maximal_prefix tgt.FStar_Syntax_Syntax.ctx_uvar_binders - src.FStar_Syntax_Syntax.ctx_uvar_binders in - match uu___ with - | (pfx, uu___1) -> - let g = - gamma_until src.FStar_Syntax_Syntax.ctx_uvar_gamma pfx in - let aux t f = - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_uvar - src.FStar_Syntax_Syntax.ctx_uvar_head in - Prims.strcat "restricted " uu___4 in - let uu___4 = FStar_Syntax_Util.ctx_uvar_should_check src in - new_uvar uu___3 wl src.FStar_Syntax_Syntax.ctx_uvar_range - g pfx t uu___4 src.FStar_Syntax_Syntax.ctx_uvar_meta in - match uu___2 with - | (uu___3, src', wl1) -> - ((let uu___5 = f src' in - set_uvar env src - (FStar_Pervasives_Native.Some - FStar_Syntax_Syntax.Already_checked) uu___5); - wl1) in - let bs1 = - FStar_Compiler_List.filter - (fun uu___2 -> - match uu___2 with - | { FStar_Syntax_Syntax.binder_bv = bv1; - FStar_Syntax_Syntax.binder_qual = uu___3; - FStar_Syntax_Syntax.binder_positivity = uu___4; - FStar_Syntax_Syntax.binder_attrs = uu___5;_} -> - (FStar_Compiler_List.existsb - (fun uu___6 -> - match uu___6 with - | { FStar_Syntax_Syntax.binder_bv = bv2; - FStar_Syntax_Syntax.binder_qual = uu___7; - FStar_Syntax_Syntax.binder_positivity = - uu___8; - FStar_Syntax_Syntax.binder_attrs = - uu___9;_} - -> FStar_Syntax_Syntax.bv_eq bv1 bv2) - src.FStar_Syntax_Syntax.ctx_uvar_binders) - && - (let uu___6 = - FStar_Compiler_List.existsb - (fun uu___7 -> - match uu___7 with - | { FStar_Syntax_Syntax.binder_bv = bv2; - FStar_Syntax_Syntax.binder_qual = - uu___8; - FStar_Syntax_Syntax.binder_positivity - = uu___9; - FStar_Syntax_Syntax.binder_attrs = - uu___10;_} - -> FStar_Syntax_Syntax.bv_eq bv1 bv2) - pfx in - Prims.op_Negation uu___6)) bs in - if (FStar_Compiler_List.length bs1) = Prims.int_zero - then - let uu___2 = FStar_Syntax_Util.ctx_uvar_typ src in - aux uu___2 (fun src' -> src') - else - (let uu___3 = - let t = FStar_Syntax_Util.ctx_uvar_typ src in - let uu___4 = FStar_Syntax_Syntax.mk_Total t in - FStar_Syntax_Util.arrow bs1 uu___4 in - aux uu___3 - (fun src' -> - let uu___4 = - let uu___5 = - FStar_Syntax_Syntax.binders_to_names bs1 in - FStar_Compiler_List.map FStar_Syntax_Syntax.as_arg - uu___5 in - FStar_Syntax_Syntax.mk_Tm_app src' uu___4 - src.FStar_Syntax_Syntax.ctx_uvar_range)) -let restrict_all_uvars : - 'uuuuu . - 'uuuuu -> - FStar_Syntax_Syntax.ctx_uvar -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.ctx_uvar Prims.list -> worklist -> worklist - = - fun env -> - fun tgt -> - fun bs -> - fun sources -> - fun wl -> - match bs with - | [] -> - let ctx_tgt = - binders_as_bv_set tgt.FStar_Syntax_Syntax.ctx_uvar_binders in - FStar_Compiler_List.fold_right - (fun src -> - fun wl1 -> - let ctx_src = - binders_as_bv_set - src.FStar_Syntax_Syntax.ctx_uvar_binders in - let uu___ = - FStar_Class_Setlike.subset () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) - (Obj.magic ctx_src) (Obj.magic ctx_tgt) in - if uu___ then wl1 else restrict_ctx env tgt [] src wl1) - sources wl - | uu___ -> - FStar_Compiler_List.fold_right (restrict_ctx env tgt bs) - sources wl -let (intersect_binders : - FStar_Syntax_Syntax.gamma -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.binders -> FStar_Syntax_Syntax.binders) - = - fun g -> - fun v1 -> - fun v2 -> - let as_set v = - let uu___ = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Syntax.ord_bv)) ()) in - FStar_Compiler_List.fold_left - (fun uu___2 -> - fun uu___1 -> - (fun out -> - fun x -> - Obj.magic - (FStar_Class_Setlike.add () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Syntax.ord_bv)) - x.FStar_Syntax_Syntax.binder_bv (Obj.magic out))) - uu___2 uu___1) uu___ v in - let v1_set = as_set v1 in - let ctx_binders = - let uu___ = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) ()) in - FStar_Compiler_List.fold_left - (fun uu___2 -> - fun uu___1 -> - (fun out -> - fun b -> - match b with - | FStar_Syntax_Syntax.Binding_var x -> - Obj.magic - (Obj.repr - (FStar_Class_Setlike.add () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) x - (Obj.magic out))) - | uu___1 -> Obj.magic (Obj.repr out)) uu___2 uu___1) - uu___ g in - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun b -> - match uu___1 with - | (isect, isect_set) -> - let uu___2 = - ((b.FStar_Syntax_Syntax.binder_bv), - (b.FStar_Syntax_Syntax.binder_qual)) in - (match uu___2 with - | (x, imp) -> - let uu___3 = - let uu___4 = - FStar_Class_Setlike.mem () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Syntax.ord_bv)) x - (Obj.magic v1_set) in - Prims.op_Negation uu___4 in - if uu___3 - then (isect, isect_set) - else - (let fvs = - FStar_Syntax_Free.names - x.FStar_Syntax_Syntax.sort in - let uu___5 = - FStar_Class_Setlike.subset () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) - (Obj.magic fvs) (Obj.magic isect_set) in - if uu___5 - then - let uu___6 = - Obj.magic - (FStar_Class_Setlike.add () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) x - (Obj.magic isect_set)) in - ((b :: isect), uu___6) - else (isect, isect_set)))) ([], ctx_binders) v2 in - match uu___ with | (isect, uu___1) -> FStar_Compiler_List.rev isect -let (binders_eq : - FStar_Syntax_Syntax.binder Prims.list -> - FStar_Syntax_Syntax.binder Prims.list -> Prims.bool) - = - fun v1 -> - fun v2 -> - ((FStar_Compiler_List.length v1) = (FStar_Compiler_List.length v2)) && - (FStar_Compiler_List.forall2 - (fun uu___ -> - fun uu___1 -> - match (uu___, uu___1) with - | ({ FStar_Syntax_Syntax.binder_bv = a; - FStar_Syntax_Syntax.binder_qual = uu___2; - FStar_Syntax_Syntax.binder_positivity = uu___3; - FStar_Syntax_Syntax.binder_attrs = uu___4;_}, - { FStar_Syntax_Syntax.binder_bv = b; - FStar_Syntax_Syntax.binder_qual = uu___5; - FStar_Syntax_Syntax.binder_positivity = uu___6; - FStar_Syntax_Syntax.binder_attrs = uu___7;_}) - -> FStar_Syntax_Syntax.bv_eq a b) v1 v2) -let (name_exists_in_binders : - FStar_Syntax_Syntax.bv -> - FStar_Syntax_Syntax.binder Prims.list -> Prims.bool) - = - fun x -> - fun bs -> - FStar_Compiler_Util.for_some - (fun uu___ -> - match uu___ with - | { FStar_Syntax_Syntax.binder_bv = y; - FStar_Syntax_Syntax.binder_qual = uu___1; - FStar_Syntax_Syntax.binder_positivity = uu___2; - FStar_Syntax_Syntax.binder_attrs = uu___3;_} -> - FStar_Syntax_Syntax.bv_eq x y) bs -let (pat_vars : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.binder Prims.list -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.aqual) Prims.list -> - FStar_Syntax_Syntax.binders FStar_Pervasives_Native.option) - = - fun env -> - fun ctx -> - fun args -> - let rec aux seen args1 = - match args1 with - | [] -> FStar_Pervasives_Native.Some (FStar_Compiler_List.rev seen) - | (arg, i)::args2 -> - let hd = sn env arg in - (match hd.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_name a -> - let uu___ = - (name_exists_in_binders a seen) || - (name_exists_in_binders a ctx) in - if uu___ - then FStar_Pervasives_Native.None - else - (let uu___2 = - FStar_Syntax_Util.bqual_and_attrs_of_aqual i in - match uu___2 with - | (bq, attrs) -> - let uu___3 = - FStar_Syntax_Util.parse_positivity_attributes - attrs in - (match uu___3 with - | (pq, attrs1) -> - let uu___4 = - let uu___5 = - FStar_Syntax_Syntax.mk_binder_with_attrs a - bq pq attrs1 in - uu___5 :: seen in - aux uu___4 args2)) - | uu___ -> FStar_Pervasives_Native.None) in - aux [] args -let (string_of_match_result : match_result -> Prims.string) = - fun uu___ -> - match uu___ with - | MisMatch (d1, d2) -> - let uu___1 = - FStar_Class_Show.show - (FStar_Class_Show.show_tuple2 - (FStar_Class_Show.show_option - FStar_Syntax_Syntax.showable_delta_depth) - (FStar_Class_Show.show_option - FStar_Syntax_Syntax.showable_delta_depth)) (d1, d2) in - Prims.strcat "MisMatch " uu___1 - | HeadMatch u -> - let uu___1 = FStar_Compiler_Util.string_of_bool u in - Prims.strcat "HeadMatch " uu___1 - | FullMatch -> "FullMatch" -let (showable_match_result : match_result FStar_Class_Show.showable) = - { FStar_Class_Show.show = string_of_match_result } -let (head_match : match_result -> match_result) = - fun uu___ -> - match uu___ with - | MisMatch (i, j) -> MisMatch (i, j) - | HeadMatch (true) -> HeadMatch true - | uu___1 -> HeadMatch false -let (universe_has_max : - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.universe -> Prims.bool) = - fun env -> - fun u -> - let u1 = FStar_TypeChecker_Normalize.normalize_universe env u in - match u1 with - | FStar_Syntax_Syntax.U_max uu___ -> true - | uu___ -> false -let rec (head_matches : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term -> match_result) - = - fun env -> - fun t1 -> - fun t2 -> - let t11 = FStar_Syntax_Util.unmeta t1 in - let t21 = FStar_Syntax_Util.unmeta t2 in - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_RelDelta in - if uu___1 - then - ((let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t11 in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t21 in - FStar_Compiler_Util.print2 "head_matches %s %s\n" uu___3 uu___4); - (let uu___4 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t11 in - let uu___5 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t21 in - FStar_Compiler_Util.print2 " %s -- %s\n" uu___4 - uu___5)) - else ()); - (match ((t11.FStar_Syntax_Syntax.n), (t21.FStar_Syntax_Syntax.n)) - with - | (FStar_Syntax_Syntax.Tm_lazy - { FStar_Syntax_Syntax.blob = uu___1; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_embedding - uu___2; - FStar_Syntax_Syntax.ltyp = uu___3; - FStar_Syntax_Syntax.rng = uu___4;_}, - uu___5) -> - let uu___6 = FStar_Syntax_Util.unlazy t11 in - head_matches env uu___6 t21 - | (uu___1, FStar_Syntax_Syntax.Tm_lazy - { FStar_Syntax_Syntax.blob = uu___2; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_embedding - uu___3; - FStar_Syntax_Syntax.ltyp = uu___4; - FStar_Syntax_Syntax.rng = uu___5;_}) - -> - let uu___6 = FStar_Syntax_Util.unlazy t21 in - head_matches env t11 uu___6 - | (FStar_Syntax_Syntax.Tm_lazy li1, FStar_Syntax_Syntax.Tm_lazy li2) - -> - let uu___1 = - FStar_Class_Deq.op_Equals_Question - FStar_Syntax_Syntax.deq_lazy_kind - li1.FStar_Syntax_Syntax.lkind li2.FStar_Syntax_Syntax.lkind in - if uu___1 - then HeadMatch false - else - MisMatch - (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) - | (FStar_Syntax_Syntax.Tm_name x, FStar_Syntax_Syntax.Tm_name y) -> - let uu___1 = FStar_Syntax_Syntax.bv_eq x y in - if uu___1 - then FullMatch - else - MisMatch - (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) - | (FStar_Syntax_Syntax.Tm_fvar f, FStar_Syntax_Syntax.Tm_fvar g) -> - let uu___1 = FStar_Syntax_Syntax.fv_eq f g in - if uu___1 - then FullMatch - else - (let uu___3 = - let uu___4 = - let uu___5 = FStar_TypeChecker_Env.fv_delta_depth env f in - FStar_Pervasives_Native.Some uu___5 in - let uu___5 = - let uu___6 = FStar_TypeChecker_Env.fv_delta_depth env g in - FStar_Pervasives_Native.Some uu___6 in - (uu___4, uu___5) in - MisMatch uu___3) - | (FStar_Syntax_Syntax.Tm_uinst (f, uu___1), - FStar_Syntax_Syntax.Tm_uinst (g, uu___2)) -> - let uu___3 = head_matches env f g in head_match uu___3 - | (FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_reify uu___1), - FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_reify uu___2)) - -> FullMatch - | (FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_reify uu___1), - uu___2) -> HeadMatch true - | (uu___1, FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_reify - uu___2)) -> HeadMatch true - | (FStar_Syntax_Syntax.Tm_constant c, - FStar_Syntax_Syntax.Tm_constant d) -> - let uu___1 = FStar_Const.eq_const c d in - if uu___1 - then FullMatch - else - MisMatch - (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) - | (FStar_Syntax_Syntax.Tm_uvar (uv, uu___1), - FStar_Syntax_Syntax.Tm_uvar (uv', uu___2)) -> - let uu___3 = - FStar_Syntax_Unionfind.equiv - uv.FStar_Syntax_Syntax.ctx_uvar_head - uv'.FStar_Syntax_Syntax.ctx_uvar_head in - if uu___3 - then FullMatch - else - MisMatch - (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) - | (FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x; FStar_Syntax_Syntax.phi = uu___1;_}, - FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = y; FStar_Syntax_Syntax.phi = uu___2;_}) - -> - let uu___3 = - head_matches env x.FStar_Syntax_Syntax.sort - y.FStar_Syntax_Syntax.sort in - head_match uu___3 - | (FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x; FStar_Syntax_Syntax.phi = uu___1;_}, - uu___2) -> - let uu___3 = head_matches env x.FStar_Syntax_Syntax.sort t21 in - head_match uu___3 - | (uu___1, FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x; FStar_Syntax_Syntax.phi = uu___2;_}) - -> - let uu___3 = head_matches env t11 x.FStar_Syntax_Syntax.sort in - head_match uu___3 - | (FStar_Syntax_Syntax.Tm_type uu___1, FStar_Syntax_Syntax.Tm_type - uu___2) -> HeadMatch false - | (FStar_Syntax_Syntax.Tm_arrow uu___1, FStar_Syntax_Syntax.Tm_arrow - uu___2) -> HeadMatch false - | (FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = uu___1;_}, - FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head'; - FStar_Syntax_Syntax.args = uu___2;_}) - -> let uu___3 = head_matches env head head' in head_match uu___3 - | (FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = uu___1;_}, - uu___2) -> - let uu___3 = head_matches env head t21 in head_match uu___3 - | (uu___1, FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = uu___2;_}) - -> let uu___3 = head_matches env t11 head in head_match uu___3 - | (FStar_Syntax_Syntax.Tm_let uu___1, FStar_Syntax_Syntax.Tm_let - uu___2) -> HeadMatch true - | (FStar_Syntax_Syntax.Tm_match uu___1, FStar_Syntax_Syntax.Tm_match - uu___2) -> HeadMatch true - | (FStar_Syntax_Syntax.Tm_quoted uu___1, - FStar_Syntax_Syntax.Tm_quoted uu___2) -> HeadMatch true - | (FStar_Syntax_Syntax.Tm_abs uu___1, FStar_Syntax_Syntax.Tm_abs - uu___2) -> HeadMatch true - | uu___1 -> - let maybe_dd t = - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress t in - uu___3.FStar_Syntax_Syntax.n in - match uu___2 with - | FStar_Syntax_Syntax.Tm_unknown -> - FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Tm_bvar uu___3 -> - FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Tm_name uu___3 -> - FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Tm_uvar uu___3 -> - FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Tm_let uu___3 -> - FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Tm_match uu___3 -> - FStar_Pervasives_Native.None - | uu___3 -> - let uu___4 = - FStar_TypeChecker_Env.delta_depth_of_term env t in - FStar_Pervasives_Native.Some uu___4 in - let uu___2 = - let uu___3 = maybe_dd t11 in - let uu___4 = maybe_dd t21 in (uu___3, uu___4) in - MisMatch uu___2) -let (head_matches_delta : - FStar_TypeChecker_Env.env -> - Prims.bool -> - Prims.bool -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.typ -> - (match_result * (FStar_Syntax_Syntax.typ * - FStar_Syntax_Syntax.typ) FStar_Pervasives_Native.option)) - = - fun env -> - fun logical -> - fun smt_ok -> - fun t1 -> - fun t2 -> - let base_steps = - FStar_Compiler_List.op_At - (if logical - then - [FStar_TypeChecker_Env.DontUnfoldAttr - [FStar_Parser_Const.tac_opaque_attr]] - else []) - [FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.Weak; - FStar_TypeChecker_Env.HNF] in - let maybe_inline t = - let head = - let uu___ = unrefine env t in FStar_Syntax_Util.head_of uu___ in - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_RelDelta in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - head in - FStar_Compiler_Util.print2 "Head of %s is %s\n" uu___2 - uu___3 - else ()); - (let uu___1 = - let uu___2 = FStar_Syntax_Util.un_uinst head in - uu___2.FStar_Syntax_Syntax.n in - match uu___1 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - let uu___2 = - FStar_TypeChecker_Env.lookup_definition - [FStar_TypeChecker_Env.Unfold - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Eager_unfolding_only] env - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - (match uu___2 with - | FStar_Pervasives_Native.None -> - ((let uu___4 = - FStar_Compiler_Effect.op_Bang dbg_RelDelta in - if uu___4 - then - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head in - FStar_Compiler_Util.print1 - "No definition found for %s\n" uu___5 - else ()); - FStar_Pervasives_Native.None) - | FStar_Pervasives_Native.Some uu___3 -> - let basic_steps = - FStar_Compiler_List.op_At - (if logical - then - [FStar_TypeChecker_Env.DontUnfoldAttr - [FStar_Parser_Const.tac_opaque_attr]] - else []) - [FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Weak; - FStar_TypeChecker_Env.HNF; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.Iota] in - let steps = - if smt_ok - then basic_steps - else - (FStar_TypeChecker_Env.Exclude - FStar_TypeChecker_Env.Zeta) - :: basic_steps in - let t' = - norm_with_steps - "FStar.TypeChecker.Rel.norm_with_steps.1" steps - env t in - let uu___4 = - let uu___5 = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env t - t' in - uu___5 = FStar_TypeChecker_TermEqAndSimplify.Equal in - if uu___4 - then FStar_Pervasives_Native.None - else - ((let uu___7 = - FStar_Compiler_Effect.op_Bang dbg_RelDelta in - if uu___7 - then - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t' in - FStar_Compiler_Util.print2 "Inlined %s to %s\n" - uu___8 uu___9 - else ()); - FStar_Pervasives_Native.Some t')) - | uu___2 -> FStar_Pervasives_Native.None) in - let success d r t11 t21 = - (r, - (if d > Prims.int_zero - then FStar_Pervasives_Native.Some (t11, t21) - else FStar_Pervasives_Native.None)) in - let fail d r t11 t21 = - (r, - (if d > Prims.int_zero - then FStar_Pervasives_Native.Some (t11, t21) - else FStar_Pervasives_Native.None)) in - let made_progress t t' = - let head = - let uu___ = FStar_Syntax_Util.head_and_args t in - FStar_Pervasives_Native.fst uu___ in - let head' = - let uu___ = FStar_Syntax_Util.head_and_args t' in - FStar_Pervasives_Native.fst uu___ in - let uu___ = FStar_Syntax_Util.term_eq head head' in - Prims.op_Negation uu___ in - let rec aux retry n_delta t11 t21 = - let r = head_matches env t11 t21 in - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_RelDelta in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t11 in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t21 in - let uu___4 = string_of_match_result r in - FStar_Compiler_Util.print3 "head_matches (%s, %s) = %s\n" - uu___2 uu___3 uu___4 - else ()); - (let reduce_one_and_try_again d1 d2 = - let d1_greater_than_d2 = - FStar_TypeChecker_Common.delta_depth_greater_than d1 d2 in - let uu___1 = - if d1_greater_than_d2 - then - let t1' = - normalize_refinement - ((FStar_TypeChecker_Env.UnfoldUntil d2) :: - base_steps) env t11 in - let uu___2 = made_progress t11 t1' in (t1', t21, uu___2) - else - (let t2' = - normalize_refinement - ((FStar_TypeChecker_Env.UnfoldUntil d1) :: - base_steps) env t21 in - let uu___3 = made_progress t21 t2' in - (t11, t2', uu___3)) in - match uu___1 with - | (t12, t22, made_progress1) -> - if made_progress1 - then aux retry (n_delta + Prims.int_one) t12 t22 - else fail n_delta r t12 t22 in - let reduce_both_and_try_again d r1 = - let uu___1 = FStar_TypeChecker_Common.decr_delta_depth d in - match uu___1 with - | FStar_Pervasives_Native.None -> fail n_delta r1 t11 t21 - | FStar_Pervasives_Native.Some d1 -> - let t1' = - normalize_refinement - ((FStar_TypeChecker_Env.UnfoldUntil d1) :: - base_steps) env t11 in - let t2' = - normalize_refinement - ((FStar_TypeChecker_Env.UnfoldUntil d1) :: - base_steps) env t21 in - let uu___2 = - (made_progress t11 t1') && (made_progress t21 t2') in - if uu___2 - then aux retry (n_delta + Prims.int_one) t1' t2' - else fail n_delta r1 t11 t21 in - match r with - | MisMatch - (FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Delta_equational_at_level i), - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Delta_equational_at_level j)) - when - ((i > Prims.int_zero) || (j > Prims.int_zero)) && (i <> j) - -> - reduce_one_and_try_again - (FStar_Syntax_Syntax.Delta_equational_at_level i) - (FStar_Syntax_Syntax.Delta_equational_at_level j) - | MisMatch - (FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Delta_equational_at_level uu___1), - uu___2) - -> - if Prims.op_Negation retry - then fail n_delta r t11 t21 - else - (let uu___4 = - let uu___5 = maybe_inline t11 in - let uu___6 = maybe_inline t21 in (uu___5, uu___6) in - match uu___4 with - | (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None) -> - fail n_delta r t11 t21 - | (FStar_Pervasives_Native.Some t12, - FStar_Pervasives_Native.None) -> - aux false (n_delta + Prims.int_one) t12 t21 - | (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.Some t22) -> - aux false (n_delta + Prims.int_one) t11 t22 - | (FStar_Pervasives_Native.Some t12, - FStar_Pervasives_Native.Some t22) -> - aux false (n_delta + Prims.int_one) t12 t22) - | MisMatch - (uu___1, FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Delta_equational_at_level uu___2)) - -> - if Prims.op_Negation retry - then fail n_delta r t11 t21 - else - (let uu___4 = - let uu___5 = maybe_inline t11 in - let uu___6 = maybe_inline t21 in (uu___5, uu___6) in - match uu___4 with - | (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None) -> - fail n_delta r t11 t21 - | (FStar_Pervasives_Native.Some t12, - FStar_Pervasives_Native.None) -> - aux false (n_delta + Prims.int_one) t12 t21 - | (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.Some t22) -> - aux false (n_delta + Prims.int_one) t11 t22 - | (FStar_Pervasives_Native.Some t12, - FStar_Pervasives_Native.Some t22) -> - aux false (n_delta + Prims.int_one) t12 t22) - | MisMatch - (FStar_Pervasives_Native.Some d1, - FStar_Pervasives_Native.Some d2) - when d1 = d2 -> reduce_both_and_try_again d1 r - | MisMatch - (FStar_Pervasives_Native.Some d1, - FStar_Pervasives_Native.Some d2) - -> reduce_one_and_try_again d1 d2 - | MisMatch uu___1 -> fail n_delta r t11 t21 - | uu___1 -> success n_delta r t11 t21) in - let r = aux true Prims.int_zero t1 t2 in - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_RelDelta in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t2 in - let uu___4 = - FStar_Class_Show.show - (FStar_Class_Show.show_tuple2 showable_match_result - (FStar_Class_Show.show_option - (FStar_Class_Show.show_tuple2 - FStar_Syntax_Print.showable_term - FStar_Syntax_Print.showable_term))) r in - FStar_Compiler_Util.print3 - "head_matches_delta (%s, %s) = %s\n" uu___2 uu___3 uu___4 - else ()); - r -let (kind_type : - FStar_Syntax_Syntax.binders -> - FStar_Compiler_Range_Type.range -> FStar_Syntax_Syntax.typ) - = - fun binders -> - fun r -> - let uu___ = FStar_Syntax_Util.type_u () in - FStar_Pervasives_Native.fst uu___ -let (rank_t_num : FStar_TypeChecker_Common.rank_t -> Prims.int) = - fun uu___ -> - match uu___ with - | FStar_TypeChecker_Common.Rigid_rigid -> Prims.int_zero - | FStar_TypeChecker_Common.Flex_rigid_eq -> Prims.int_one - | FStar_TypeChecker_Common.Flex_flex_pattern_eq -> (Prims.of_int (2)) - | FStar_TypeChecker_Common.Flex_rigid -> (Prims.of_int (3)) - | FStar_TypeChecker_Common.Rigid_flex -> (Prims.of_int (4)) - | FStar_TypeChecker_Common.Flex_flex -> (Prims.of_int (5)) -let (rank_leq : - FStar_TypeChecker_Common.rank_t -> - FStar_TypeChecker_Common.rank_t -> Prims.bool) - = fun r1 -> fun r2 -> (rank_t_num r1) <= (rank_t_num r2) -let (rank_less_than : - FStar_TypeChecker_Common.rank_t -> - FStar_TypeChecker_Common.rank_t -> Prims.bool) - = fun r1 -> fun r2 -> (r1 <> r2) && ((rank_t_num r1) <= (rank_t_num r2)) -let (compress_tprob : - worklist -> - FStar_Syntax_Syntax.typ FStar_TypeChecker_Common.problem -> - FStar_Syntax_Syntax.term FStar_TypeChecker_Common.problem) - = - fun wl -> - fun p -> - let env = p_env wl (FStar_TypeChecker_Common.TProb p) in - let uu___ = whnf env p.FStar_TypeChecker_Common.lhs in - let uu___1 = whnf env p.FStar_TypeChecker_Common.rhs in - { - FStar_TypeChecker_Common.pid = (p.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = uu___; - FStar_TypeChecker_Common.relation = - (p.FStar_TypeChecker_Common.relation); - FStar_TypeChecker_Common.rhs = uu___1; - FStar_TypeChecker_Common.element = - (p.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (p.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (p.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = (p.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = (p.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = (p.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = - (p.FStar_TypeChecker_Common.logical) - } -let (compress_cprob : - worklist -> - FStar_Syntax_Syntax.comp FStar_TypeChecker_Common.problem -> - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax - FStar_TypeChecker_Common.problem) - = - fun wl -> - fun p -> - let whnf_c env c = - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total ty -> - let uu___ = whnf env ty in FStar_Syntax_Syntax.mk_Total uu___ - | uu___ -> c in - let env = p_env wl (FStar_TypeChecker_Common.CProb p) in - let uu___ = whnf_c env p.FStar_TypeChecker_Common.lhs in - let uu___1 = whnf_c env p.FStar_TypeChecker_Common.rhs in - { - FStar_TypeChecker_Common.pid = (p.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = uu___; - FStar_TypeChecker_Common.relation = - (p.FStar_TypeChecker_Common.relation); - FStar_TypeChecker_Common.rhs = uu___1; - FStar_TypeChecker_Common.element = - (p.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (p.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (p.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = (p.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = (p.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = (p.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = - (p.FStar_TypeChecker_Common.logical) - } -let (compress_prob : - worklist -> FStar_TypeChecker_Common.prob -> FStar_TypeChecker_Common.prob) - = - fun wl -> - fun p -> - match p with - | FStar_TypeChecker_Common.TProb p1 -> - let uu___ = compress_tprob wl p1 in - FStar_TypeChecker_Common.TProb uu___ - | FStar_TypeChecker_Common.CProb p1 -> - let uu___ = compress_cprob wl p1 in - FStar_TypeChecker_Common.CProb uu___ -let (rank : - worklist -> - FStar_TypeChecker_Common.prob -> - (FStar_TypeChecker_Common.rank_t * FStar_TypeChecker_Common.prob)) - = - fun wl -> - fun pr -> - let prob = let uu___ = compress_prob wl pr in maybe_invert_p uu___ in - match prob with - | FStar_TypeChecker_Common.TProb tp -> - let uu___ = - FStar_Syntax_Util.head_and_args tp.FStar_TypeChecker_Common.lhs in - (match uu___ with - | (lh, lhs_args) -> - let uu___1 = - FStar_Syntax_Util.head_and_args - tp.FStar_TypeChecker_Common.rhs in - (match uu___1 with - | (rh, rhs_args) -> - let uu___2 = - match ((lh.FStar_Syntax_Syntax.n), - (rh.FStar_Syntax_Syntax.n)) - with - | (FStar_Syntax_Syntax.Tm_uvar uu___3, - FStar_Syntax_Syntax.Tm_uvar uu___4) -> - (match (lhs_args, rhs_args) with - | ([], []) when - tp.FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.EQ - -> - (FStar_TypeChecker_Common.Flex_flex_pattern_eq, - tp) - | uu___5 -> - (FStar_TypeChecker_Common.Flex_flex, tp)) - | (FStar_Syntax_Syntax.Tm_uvar uu___3, uu___4) when - tp.FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.EQ - -> (FStar_TypeChecker_Common.Flex_rigid_eq, tp) - | (uu___3, FStar_Syntax_Syntax.Tm_uvar uu___4) when - tp.FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.EQ - -> (FStar_TypeChecker_Common.Flex_rigid_eq, tp) - | (FStar_Syntax_Syntax.Tm_uvar uu___3, - FStar_Syntax_Syntax.Tm_arrow uu___4) -> - (FStar_TypeChecker_Common.Flex_rigid_eq, - { - FStar_TypeChecker_Common.pid = - (tp.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = - (tp.FStar_TypeChecker_Common.lhs); - FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.EQ; - FStar_TypeChecker_Common.rhs = - (tp.FStar_TypeChecker_Common.rhs); - FStar_TypeChecker_Common.element = - (tp.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (tp.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (tp.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (tp.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = - (tp.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = - (tp.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = - (tp.FStar_TypeChecker_Common.logical) - }) - | (FStar_Syntax_Syntax.Tm_uvar uu___3, - FStar_Syntax_Syntax.Tm_type uu___4) -> - (FStar_TypeChecker_Common.Flex_rigid_eq, - { - FStar_TypeChecker_Common.pid = - (tp.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = - (tp.FStar_TypeChecker_Common.lhs); - FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.EQ; - FStar_TypeChecker_Common.rhs = - (tp.FStar_TypeChecker_Common.rhs); - FStar_TypeChecker_Common.element = - (tp.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (tp.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (tp.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (tp.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = - (tp.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = - (tp.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = - (tp.FStar_TypeChecker_Common.logical) - }) - | (FStar_Syntax_Syntax.Tm_type uu___3, - FStar_Syntax_Syntax.Tm_uvar uu___4) -> - (FStar_TypeChecker_Common.Flex_rigid_eq, - { - FStar_TypeChecker_Common.pid = - (tp.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = - (tp.FStar_TypeChecker_Common.lhs); - FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.EQ; - FStar_TypeChecker_Common.rhs = - (tp.FStar_TypeChecker_Common.rhs); - FStar_TypeChecker_Common.element = - (tp.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (tp.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (tp.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (tp.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = - (tp.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = - (tp.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = - (tp.FStar_TypeChecker_Common.logical) - }) - | (uu___3, FStar_Syntax_Syntax.Tm_uvar uu___4) -> - (FStar_TypeChecker_Common.Rigid_flex, tp) - | (FStar_Syntax_Syntax.Tm_uvar uu___3, uu___4) -> - (FStar_TypeChecker_Common.Flex_rigid, tp) - | (uu___3, FStar_Syntax_Syntax.Tm_uvar uu___4) -> - (FStar_TypeChecker_Common.Rigid_flex, tp) - | (uu___3, uu___4) -> - (FStar_TypeChecker_Common.Rigid_rigid, tp) in - (match uu___2 with - | (rank1, tp1) -> - (rank1, - (FStar_TypeChecker_Common.TProb - { - FStar_TypeChecker_Common.pid = - (tp1.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = - (tp1.FStar_TypeChecker_Common.lhs); - FStar_TypeChecker_Common.relation = - (tp1.FStar_TypeChecker_Common.relation); - FStar_TypeChecker_Common.rhs = - (tp1.FStar_TypeChecker_Common.rhs); - FStar_TypeChecker_Common.element = - (tp1.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (tp1.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (tp1.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (tp1.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = - (tp1.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = - (FStar_Pervasives_Native.Some rank1); - FStar_TypeChecker_Common.logical = - (tp1.FStar_TypeChecker_Common.logical) - }))))) - | FStar_TypeChecker_Common.CProb cp -> - (FStar_TypeChecker_Common.Rigid_rigid, - (FStar_TypeChecker_Common.CProb - { - FStar_TypeChecker_Common.pid = - (cp.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = - (cp.FStar_TypeChecker_Common.lhs); - FStar_TypeChecker_Common.relation = - (cp.FStar_TypeChecker_Common.relation); - FStar_TypeChecker_Common.rhs = - (cp.FStar_TypeChecker_Common.rhs); - FStar_TypeChecker_Common.element = - (cp.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (cp.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (cp.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (cp.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = - (cp.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = - (FStar_Pervasives_Native.Some - FStar_TypeChecker_Common.Rigid_rigid); - FStar_TypeChecker_Common.logical = - (cp.FStar_TypeChecker_Common.logical) - })) -let (next_prob : - worklist -> - (FStar_TypeChecker_Common.prob * FStar_TypeChecker_Common.prob Prims.list - * FStar_TypeChecker_Common.rank_t) FStar_Pervasives_Native.option) - = - fun wl -> - let rec aux uu___ probs = - match uu___ with - | (min_rank, min, out) -> - (match probs with - | [] -> - (match (min, min_rank) with - | (FStar_Pervasives_Native.Some p, - FStar_Pervasives_Native.Some r) -> - FStar_Pervasives_Native.Some (p, out, r) - | uu___1 -> FStar_Pervasives_Native.None) - | hd::tl -> - let uu___1 = rank wl hd in - (match uu___1 with - | (rank1, hd1) -> - if rank_leq rank1 FStar_TypeChecker_Common.Flex_rigid_eq - then - (match min with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.Some - (hd1, (FStar_Compiler_List.op_At out tl), rank1) - | FStar_Pervasives_Native.Some m -> - FStar_Pervasives_Native.Some - (hd1, (FStar_Compiler_List.op_At out (m :: tl)), - rank1)) - else - (let uu___3 = - (min_rank = FStar_Pervasives_Native.None) || - (let uu___4 = FStar_Compiler_Option.get min_rank in - rank_less_than rank1 uu___4) in - if uu___3 - then - match min with - | FStar_Pervasives_Native.None -> - aux - ((FStar_Pervasives_Native.Some rank1), - (FStar_Pervasives_Native.Some hd1), out) tl - | FStar_Pervasives_Native.Some m -> - aux - ((FStar_Pervasives_Native.Some rank1), - (FStar_Pervasives_Native.Some hd1), (m :: - out)) tl - else aux (min_rank, min, (hd1 :: out)) tl))) in - aux (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None, []) - wl.attempting -let (flex_prob_closing : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.binders -> - FStar_TypeChecker_Common.prob -> Prims.bool) - = - fun tcenv -> - fun bs -> - fun p -> - let flex_will_be_closed t = - let uu___ = FStar_Syntax_Util.head_and_args t in - match uu___ with - | (hd, uu___1) -> - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress hd in - uu___3.FStar_Syntax_Syntax.n in - (match uu___2 with - | FStar_Syntax_Syntax.Tm_uvar (u, uu___3) -> - FStar_Compiler_Util.for_some - (fun uu___4 -> - match uu___4 with - | { FStar_Syntax_Syntax.binder_bv = y; - FStar_Syntax_Syntax.binder_qual = uu___5; - FStar_Syntax_Syntax.binder_positivity = uu___6; - FStar_Syntax_Syntax.binder_attrs = uu___7;_} -> - FStar_Compiler_Util.for_some - (fun uu___8 -> - match uu___8 with - | { FStar_Syntax_Syntax.binder_bv = x; - FStar_Syntax_Syntax.binder_qual = uu___9; - FStar_Syntax_Syntax.binder_positivity = - uu___10; - FStar_Syntax_Syntax.binder_attrs = - uu___11;_} - -> FStar_Syntax_Syntax.bv_eq x y) bs) - u.FStar_Syntax_Syntax.ctx_uvar_binders - | uu___3 -> false) in - let wl = empty_worklist tcenv in - let uu___ = rank wl p in - match uu___ with - | (r, p1) -> - (match p1 with - | FStar_TypeChecker_Common.CProb uu___1 -> true - | FStar_TypeChecker_Common.TProb p2 -> - (match r with - | FStar_TypeChecker_Common.Rigid_rigid -> true - | FStar_TypeChecker_Common.Flex_rigid_eq -> true - | FStar_TypeChecker_Common.Flex_flex_pattern_eq -> true - | FStar_TypeChecker_Common.Flex_rigid -> - flex_will_be_closed p2.FStar_TypeChecker_Common.lhs - | FStar_TypeChecker_Common.Rigid_flex -> - flex_will_be_closed p2.FStar_TypeChecker_Common.rhs - | FStar_TypeChecker_Common.Flex_flex -> - (p2.FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.EQ) - && - ((flex_will_be_closed p2.FStar_TypeChecker_Common.lhs) - || - (flex_will_be_closed - p2.FStar_TypeChecker_Common.rhs)))) -type univ_eq_sol = - | UDeferred of worklist - | USolved of worklist - | UFailed of lstring -let (uu___is_UDeferred : univ_eq_sol -> Prims.bool) = - fun projectee -> - match projectee with | UDeferred _0 -> true | uu___ -> false -let (__proj__UDeferred__item___0 : univ_eq_sol -> worklist) = - fun projectee -> match projectee with | UDeferred _0 -> _0 -let (uu___is_USolved : univ_eq_sol -> Prims.bool) = - fun projectee -> match projectee with | USolved _0 -> true | uu___ -> false -let (__proj__USolved__item___0 : univ_eq_sol -> worklist) = - fun projectee -> match projectee with | USolved _0 -> _0 -let (uu___is_UFailed : univ_eq_sol -> Prims.bool) = - fun projectee -> match projectee with | UFailed _0 -> true | uu___ -> false -let (__proj__UFailed__item___0 : univ_eq_sol -> lstring) = - fun projectee -> match projectee with | UFailed _0 -> _0 -let (ufailed_simple : Prims.string -> univ_eq_sol) = - fun s -> let uu___ = FStar_Thunk.mkv s in UFailed uu___ -let (ufailed_thunk : (unit -> Prims.string) -> univ_eq_sol) = - fun s -> let uu___ = mklstr s in UFailed uu___ -let rec (really_solve_universe_eq : - Prims.int -> - worklist -> - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.universe -> univ_eq_sol) - = - fun pid_orig -> - fun wl -> - fun u1 -> - fun u2 -> - let u11 = - FStar_TypeChecker_Normalize.normalize_universe wl.tcenv u1 in - let u21 = - FStar_TypeChecker_Normalize.normalize_universe wl.tcenv u2 in - let rec occurs_univ v1 u = - match u with - | FStar_Syntax_Syntax.U_max us -> - FStar_Compiler_Util.for_some - (fun u3 -> - let uu___ = FStar_Syntax_Util.univ_kernel u3 in - match uu___ with - | (k, uu___1) -> - (match k with - | FStar_Syntax_Syntax.U_unif v2 -> - FStar_Syntax_Unionfind.univ_equiv v1 v2 - | uu___2 -> false)) us - | uu___ -> occurs_univ v1 (FStar_Syntax_Syntax.U_max [u]) in - let rec filter_out_common_univs u12 u22 = - let common_elts = - FStar_Compiler_List.fold_left - (fun uvs -> - fun uv1 -> - let uu___ = - FStar_Compiler_List.existsML - (fun uv2 -> FStar_Syntax_Util.eq_univs uv1 uv2) u22 in - if uu___ then uv1 :: uvs else uvs) [] u12 in - let filter = - FStar_Compiler_List.filter - (fun u -> - let uu___ = - FStar_Compiler_List.existsML - (fun u' -> FStar_Syntax_Util.eq_univs u u') - common_elts in - Prims.op_Negation uu___) in - let uu___ = filter u12 in - let uu___1 = filter u22 in (uu___, uu___1) in - let try_umax_components u12 u22 msg = - if Prims.op_Negation wl.umax_heuristic_ok - then ufailed_simple "Unable to unify universe terms with umax" - else - (match (u12, u22) with - | (FStar_Syntax_Syntax.U_max us1, FStar_Syntax_Syntax.U_max - us2) -> - let uu___1 = filter_out_common_univs us1 us2 in - (match uu___1 with - | (us11, us21) -> - if - (FStar_Compiler_List.length us11) = - (FStar_Compiler_List.length us21) - then - let rec aux wl1 us12 us22 = - match (us12, us22) with - | (u13::us13, u23::us23) -> - let uu___2 = - really_solve_universe_eq pid_orig wl1 u13 - u23 in - (match uu___2 with - | USolved wl2 -> aux wl2 us13 us23 - | failed -> failed) - | uu___2 -> USolved wl1 in - aux wl us11 us21 - else - ufailed_thunk - (fun uu___3 -> - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_univ u12 in - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_univ u22 in - FStar_Compiler_Util.format2 - "Unable to unify universes: %s and %s" - uu___4 uu___5)) - | (FStar_Syntax_Syntax.U_max us, u') -> - let rec aux wl1 us1 = - match us1 with - | [] -> USolved wl1 - | u::us2 -> - let uu___1 = - really_solve_universe_eq pid_orig wl1 u u' in - (match uu___1 with - | USolved wl2 -> aux wl2 us2 - | failed -> failed) in - aux wl us - | (u', FStar_Syntax_Syntax.U_max us) -> - let rec aux wl1 us1 = - match us1 with - | [] -> USolved wl1 - | u::us2 -> - let uu___1 = - really_solve_universe_eq pid_orig wl1 u u' in - (match uu___1 with - | USolved wl2 -> aux wl2 us2 - | failed -> failed) in - aux wl us - | uu___1 -> - ufailed_thunk - (fun uu___2 -> - let uu___3 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_univ u12 in - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_univ u22 in - FStar_Compiler_Util.format3 - "Unable to unify universes: %s and %s (%s)" uu___3 - uu___4 msg)) in - match (u11, u21) with - | (FStar_Syntax_Syntax.U_bvar uu___, uu___1) -> - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_univ u11 in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_univ u21 in - FStar_Compiler_Util.format2 - "Impossible: found an de Bruijn universe variable or unknown universe: %s, %s" - uu___3 uu___4 in - failwith uu___2 - | (FStar_Syntax_Syntax.U_unknown, uu___) -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_univ u11 in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_univ u21 in - FStar_Compiler_Util.format2 - "Impossible: found an de Bruijn universe variable or unknown universe: %s, %s" - uu___2 uu___3 in - failwith uu___1 - | (uu___, FStar_Syntax_Syntax.U_bvar uu___1) -> - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_univ u11 in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_univ u21 in - FStar_Compiler_Util.format2 - "Impossible: found an de Bruijn universe variable or unknown universe: %s, %s" - uu___3 uu___4 in - failwith uu___2 - | (uu___, FStar_Syntax_Syntax.U_unknown) -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_univ u11 in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_univ u21 in - FStar_Compiler_Util.format2 - "Impossible: found an de Bruijn universe variable or unknown universe: %s, %s" - uu___2 uu___3 in - failwith uu___1 - | (FStar_Syntax_Syntax.U_name x, FStar_Syntax_Syntax.U_name y) -> - let uu___ = - let uu___1 = FStar_Ident.string_of_id x in - let uu___2 = FStar_Ident.string_of_id y in uu___1 = uu___2 in - if uu___ - then USolved wl - else ufailed_simple "Incompatible universes" - | (FStar_Syntax_Syntax.U_zero, FStar_Syntax_Syntax.U_zero) -> - USolved wl - | (FStar_Syntax_Syntax.U_succ u12, FStar_Syntax_Syntax.U_succ u22) - -> really_solve_universe_eq pid_orig wl u12 u22 - | (FStar_Syntax_Syntax.U_unif v1, FStar_Syntax_Syntax.U_unif v2) -> - let uu___ = FStar_Syntax_Unionfind.univ_equiv v1 v2 in - if uu___ - then USolved wl - else - (let wl1 = - extend_universe_solution pid_orig [UNIV (v1, u21)] wl in - USolved wl1) - | (FStar_Syntax_Syntax.U_unif v1, u) -> - let u3 = norm_univ wl u in - let uu___ = occurs_univ v1 u3 in - if uu___ - then - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_univ - (FStar_Syntax_Syntax.U_unif v1) in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_univ u3 in - FStar_Compiler_Util.format2 - "Failed occurs check: %s occurs in %s" uu___2 uu___3 in - try_umax_components u11 u21 uu___1 - else - (let uu___2 = - extend_universe_solution pid_orig [UNIV (v1, u3)] wl in - USolved uu___2) - | (u, FStar_Syntax_Syntax.U_unif v1) -> - let u3 = norm_univ wl u in - let uu___ = occurs_univ v1 u3 in - if uu___ - then - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_univ - (FStar_Syntax_Syntax.U_unif v1) in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_univ u3 in - FStar_Compiler_Util.format2 - "Failed occurs check: %s occurs in %s" uu___2 uu___3 in - try_umax_components u11 u21 uu___1 - else - (let uu___2 = - extend_universe_solution pid_orig [UNIV (v1, u3)] wl in - USolved uu___2) - | (FStar_Syntax_Syntax.U_max uu___, uu___1) -> - if wl.defer_ok = DeferAny - then UDeferred wl - else - (let u12 = norm_univ wl u11 in - let u22 = norm_univ wl u21 in - let uu___3 = FStar_Syntax_Util.eq_univs u12 u22 in - if uu___3 - then USolved wl - else try_umax_components u12 u22 "") - | (uu___, FStar_Syntax_Syntax.U_max uu___1) -> - if wl.defer_ok = DeferAny - then UDeferred wl - else - (let u12 = norm_univ wl u11 in - let u22 = norm_univ wl u21 in - let uu___3 = FStar_Syntax_Util.eq_univs u12 u22 in - if uu___3 - then USolved wl - else try_umax_components u12 u22 "") - | (FStar_Syntax_Syntax.U_succ uu___, FStar_Syntax_Syntax.U_zero) -> - ufailed_simple "Incompatible universes" - | (FStar_Syntax_Syntax.U_succ uu___, FStar_Syntax_Syntax.U_name - uu___1) -> ufailed_simple "Incompatible universes" - | (FStar_Syntax_Syntax.U_zero, FStar_Syntax_Syntax.U_succ uu___) -> - ufailed_simple "Incompatible universes" - | (FStar_Syntax_Syntax.U_zero, FStar_Syntax_Syntax.U_name uu___) -> - ufailed_simple "Incompatible universes" - | (FStar_Syntax_Syntax.U_name uu___, FStar_Syntax_Syntax.U_succ - uu___1) -> ufailed_simple "Incompatible universes" - | (FStar_Syntax_Syntax.U_name uu___, FStar_Syntax_Syntax.U_zero) -> - ufailed_simple "Incompatible universes" -let (solve_universe_eq : - Prims.int -> - worklist -> - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.universe -> univ_eq_sol) - = - fun orig -> - fun wl -> - fun u1 -> - fun u2 -> - if (wl.tcenv).FStar_TypeChecker_Env.lax_universes - then USolved wl - else really_solve_universe_eq orig wl u1 u2 -let match_num_binders : - 'a 'b . - ('a Prims.list * ('a Prims.list -> 'b)) -> - ('a Prims.list * ('a Prims.list -> 'b)) -> - (('a Prims.list * 'b) * ('a Prims.list * 'b)) - = - fun bc1 -> - fun bc2 -> - let uu___ = bc1 in - match uu___ with - | (bs1, mk_cod1) -> - let uu___1 = bc2 in - (match uu___1 with - | (bs2, mk_cod2) -> - let rec aux bs11 bs21 = - match (bs11, bs21) with - | (x::xs, y::ys) -> - let uu___2 = aux xs ys in - (match uu___2 with - | ((xs1, xr), (ys1, yr)) -> - (((x :: xs1), xr), ((y :: ys1), yr))) - | (xs, ys) -> - let uu___2 = let uu___3 = mk_cod1 xs in ([], uu___3) in - let uu___3 = let uu___4 = mk_cod2 ys in ([], uu___4) in - (uu___2, uu___3) in - aux bs1 bs2) -let (guard_of_prob : - worklist -> - tprob -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> (FStar_Syntax_Syntax.term * worklist)) - = - fun wl -> - fun problem -> - fun t1 -> - fun t2 -> - def_check_prob "guard_of_prob" - (FStar_TypeChecker_Common.TProb problem); - (let env = p_env wl (FStar_TypeChecker_Common.TProb problem) in - let has_type_guard t11 t21 = - match problem.FStar_TypeChecker_Common.element with - | FStar_Pervasives_Native.Some t -> - let uu___1 = FStar_Syntax_Syntax.bv_to_name t in - FStar_Syntax_Util.mk_has_type t11 uu___1 t21 - | FStar_Pervasives_Native.None -> - let x = - FStar_Syntax_Syntax.new_bv FStar_Pervasives_Native.None - t11 in - (FStar_Defensive.def_check_scoped - FStar_TypeChecker_Env.hasBinders_env - FStar_Class_Binders.hasNames_term - FStar_Syntax_Print.pretty_term - t11.FStar_Syntax_Syntax.pos "guard_of_prob.universe_of" - env t11; - (let u_x = env.FStar_TypeChecker_Env.universe_of env t11 in - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.bv_to_name x in - FStar_Syntax_Util.mk_has_type t11 uu___3 t21 in - FStar_Syntax_Util.mk_forall u_x x uu___2)) in - match problem.FStar_TypeChecker_Common.relation with - | FStar_TypeChecker_Common.EQ -> - mk_eq2 wl (FStar_TypeChecker_Common.TProb problem) t1 t2 - | FStar_TypeChecker_Common.SUB -> - let uu___1 = has_type_guard t1 t2 in (uu___1, wl) - | FStar_TypeChecker_Common.SUBINV -> - let uu___1 = has_type_guard t2 t1 in (uu___1, wl)) -let (is_flex_pat : flex_t -> Prims.bool) = - fun uu___ -> - match uu___ with | Flex (uu___1, uu___2, []) -> true | uu___1 -> false -let (should_defer_flex_to_user_tac : worklist -> flex_t -> Prims.bool) = - fun wl -> - fun f -> - let uu___ = f in - match uu___ with - | Flex (uu___1, u, uu___2) -> - let b = - FStar_TypeChecker_DeferredImplicits.should_defer_uvar_to_user_tac - wl.tcenv u in - ((let uu___4 = - FStar_Compiler_Effect.op_Bang dbg_ResolveImplicitsHook in - if uu___4 - then - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_ctxu u in - let uu___6 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) b in - let uu___7 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - (wl.tcenv).FStar_TypeChecker_Env.enable_defer_to_tac in - FStar_Compiler_Util.print3 - "Rel.should_defer_flex_to_user_tac for %s returning %s (env.enable_defer_to_tac: %s)\n" - uu___5 uu___6 uu___7 - else ()); - b) -let (quasi_pattern : - FStar_TypeChecker_Env.env -> - flex_t -> - (FStar_Syntax_Syntax.binders * FStar_Syntax_Syntax.typ) - FStar_Pervasives_Native.option) - = - fun env -> - fun f -> - let uu___ = f in - match uu___ with - | Flex (uu___1, ctx_uvar, args) -> - let t_hd = FStar_Syntax_Util.ctx_uvar_typ ctx_uvar in - let ctx = ctx_uvar.FStar_Syntax_Syntax.ctx_uvar_binders in - let name_exists_in x bs = - FStar_Compiler_Util.for_some - (fun uu___2 -> - match uu___2 with - | { FStar_Syntax_Syntax.binder_bv = y; - FStar_Syntax_Syntax.binder_qual = uu___3; - FStar_Syntax_Syntax.binder_positivity = uu___4; - FStar_Syntax_Syntax.binder_attrs = uu___5;_} -> - FStar_Syntax_Syntax.bv_eq x y) bs in - let rec aux pat_binders formals t_res args1 = - match (formals, args1) with - | ([], []) -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Syntax.mk_Total t_res in - FStar_Syntax_Util.arrow formals uu___4 in - ((FStar_Compiler_List.rev pat_binders), uu___3) in - FStar_Pervasives_Native.Some uu___2 - | (uu___2, []) -> - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.mk_Total t_res in - FStar_Syntax_Util.arrow formals uu___5 in - ((FStar_Compiler_List.rev pat_binders), uu___4) in - FStar_Pervasives_Native.Some uu___3 - | (fml::formals1, (a, a_imp)::args2) -> - let uu___2 = - ((fml.FStar_Syntax_Syntax.binder_bv), - (fml.FStar_Syntax_Syntax.binder_qual)) in - (match uu___2 with - | (formal, formal_imp) -> - let uu___3 = - let uu___4 = FStar_Syntax_Subst.compress a in - uu___4.FStar_Syntax_Syntax.n in - (match uu___3 with - | FStar_Syntax_Syntax.Tm_name x -> - let uu___4 = - (name_exists_in x ctx) || - (name_exists_in x pat_binders) in - if uu___4 - then aux (fml :: pat_binders) formals1 t_res args2 - else - (let x1 = - { - FStar_Syntax_Syntax.ppname = - (x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (x.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = - (formal.FStar_Syntax_Syntax.sort) - } in - let subst = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Syntax_Syntax.bv_to_name x1 in - (formal, uu___8) in - FStar_Syntax_Syntax.NT uu___7 in - [uu___6] in - let formals2 = - FStar_Syntax_Subst.subst_binders subst - formals1 in - let t_res1 = - FStar_Syntax_Subst.subst subst t_res in - let uu___6 = - FStar_Syntax_Util.bqual_and_attrs_of_aqual - a_imp in - match uu___6 with - | (q, uu___7) -> - let uu___8 = - let uu___9 = - FStar_Syntax_Syntax.mk_binder_with_attrs - { - FStar_Syntax_Syntax.ppname = - (x1.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (x1.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = - (formal.FStar_Syntax_Syntax.sort) - } q - fml.FStar_Syntax_Syntax.binder_positivity - fml.FStar_Syntax_Syntax.binder_attrs in - uu___9 :: pat_binders in - aux uu___8 formals2 t_res1 args2) - | uu___4 -> - aux (fml :: pat_binders) formals1 t_res args2)) - | ([], args2) -> - let uu___2 = - let uu___3 = - FStar_TypeChecker_Normalize.unfold_whnf env t_res in - FStar_Syntax_Util.arrow_formals uu___3 in - (match uu___2 with - | (more_formals, t_res1) -> - (match more_formals with - | [] -> FStar_Pervasives_Native.None - | uu___3 -> aux pat_binders more_formals t_res1 args2)) in - (match args with - | [] -> FStar_Pervasives_Native.Some ([], t_hd) - | uu___2 -> - let uu___3 = FStar_Syntax_Util.arrow_formals t_hd in - (match uu___3 with - | (formals, t_res) -> aux [] formals t_res args)) -let (run_meta_arg_tac : - FStar_TypeChecker_Env.env_t -> - FStar_Syntax_Syntax.ctx_uvar -> FStar_Syntax_Syntax.term) - = - fun env -> - fun ctx_u -> - match ctx_u.FStar_Syntax_Syntax.ctx_uvar_meta with - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Ctx_uvar_meta_tac - tau) -> - let env1 = - { - FStar_TypeChecker_Env.solver = - (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (ctx_u.FStar_Syntax_Syntax.ctx_uvar_gamma); - FStar_TypeChecker_Env.gamma_sig = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = (env.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env.FStar_TypeChecker_Env.missing_decl) - } in - ((let uu___1 = FStar_Compiler_Effect.op_Bang dbg_Tac in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_ctxu ctx_u in - FStar_Compiler_Util.print1 "Running tactic for meta-arg %s\n" - uu___2 - else ()); - FStar_Errors.with_ctx "Running tactic for meta-arg" - (fun uu___1 -> - let uu___2 = FStar_Syntax_Util.ctx_uvar_typ ctx_u in - env1.FStar_TypeChecker_Env.synth_hook env1 uu___2 tau)) - | uu___ -> - failwith - "run_meta_arg_tac must have been called with a uvar that has a meta tac" -let (simplify_vc : - Prims.bool -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun full_norm_allowed -> - fun env -> - fun t -> - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_Simplification in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.print1 "Simplifying guard %s\n" uu___2 - else ()); - (let steps = - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.Simplify; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.Exclude FStar_TypeChecker_Env.Zeta] in - let steps1 = - if full_norm_allowed - then steps - else FStar_TypeChecker_Env.NoFullNorm :: steps in - let t' = - norm_with_steps "FStar.TypeChecker.Rel.simplify_vc" steps1 env t in - (let uu___2 = FStar_Compiler_Effect.op_Bang dbg_Simplification in - if uu___2 - then - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t' in - FStar_Compiler_Util.print1 "Simplified guard to %s\n" uu___3 - else ()); - t') -let (__simplify_guard : - Prims.bool -> - FStar_TypeChecker_Env.env -> - FStar_TypeChecker_Common.guard_t -> FStar_TypeChecker_Common.guard_t) - = - fun full_norm_allowed -> - fun env -> - fun g -> - match g.FStar_TypeChecker_Common.guard_f with - | FStar_TypeChecker_Common.Trivial -> g - | FStar_TypeChecker_Common.NonTrivial f -> - let f1 = simplify_vc full_norm_allowed env f in - let f2 = FStar_TypeChecker_Common.check_trivial f1 in - { - FStar_TypeChecker_Common.guard_f = f2; - FStar_TypeChecker_Common.deferred_to_tac = - (g.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (g.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (g.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = - (g.FStar_TypeChecker_Common.implicits) - } -let (simplify_guard : - FStar_TypeChecker_Env.env -> - FStar_TypeChecker_Common.guard_t -> FStar_TypeChecker_Common.guard_t) - = - fun env -> - fun g -> - match g.FStar_TypeChecker_Common.guard_f with - | FStar_TypeChecker_Common.Trivial -> g - | FStar_TypeChecker_Common.NonTrivial f -> - let f1 = simplify_vc false env f in - let f2 = FStar_TypeChecker_Common.check_trivial f1 in - { - FStar_TypeChecker_Common.guard_f = f2; - FStar_TypeChecker_Common.deferred_to_tac = - (g.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (g.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (g.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = - (g.FStar_TypeChecker_Common.implicits) - } -let (simplify_guard_full_norm : - FStar_TypeChecker_Env.env -> - FStar_TypeChecker_Common.guard_t -> FStar_TypeChecker_Common.guard_t) - = - fun env -> - fun g -> - match g.FStar_TypeChecker_Common.guard_f with - | FStar_TypeChecker_Common.Trivial -> g - | FStar_TypeChecker_Common.NonTrivial f -> - let f1 = simplify_vc true env f in - let f2 = FStar_TypeChecker_Common.check_trivial f1 in - { - FStar_TypeChecker_Common.guard_f = f2; - FStar_TypeChecker_Common.deferred_to_tac = - (g.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (g.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (g.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = - (g.FStar_TypeChecker_Common.implicits) - } -let (apply_substitutive_indexed_subcomp : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.indexed_effect_combinator_kind -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.comp -> - FStar_Syntax_Syntax.comp_typ -> - FStar_Syntax_Syntax.comp_typ -> - (worklist -> - FStar_Syntax_Syntax.term -> - FStar_TypeChecker_Common.rel -> - FStar_Syntax_Syntax.term -> - Prims.string -> - (FStar_TypeChecker_Common.prob * worklist)) - -> - Prims.int -> - worklist -> - Prims.string -> - FStar_Compiler_Range_Type.range -> - (FStar_Syntax_Syntax.typ * - FStar_TypeChecker_Common.prob Prims.list * - worklist)) - = - fun env -> - fun k -> - fun bs -> - fun subcomp_c -> - fun ct1 -> - fun ct2 -> - fun sub_prob -> - fun num_effect_params -> - fun wl -> - fun subcomp_name -> - fun r1 -> - let uu___ = - let uu___1 = bs in - match uu___1 with - | a_b::bs1 -> - (bs1, - [FStar_Syntax_Syntax.NT - ((a_b.FStar_Syntax_Syntax.binder_bv), - (ct2.FStar_Syntax_Syntax.result_typ))]) in - match uu___ with - | (bs1, subst) -> - let uu___1 = - if num_effect_params = Prims.int_zero - then - (bs1, subst, - (ct1.FStar_Syntax_Syntax.effect_args), - (ct2.FStar_Syntax_Syntax.effect_args), [], - wl) - else - (let split l = - FStar_Compiler_List.splitAt - num_effect_params l in - let uu___3 = split bs1 in - match uu___3 with - | (eff_params_bs, bs2) -> - let uu___4 = - split - ct1.FStar_Syntax_Syntax.effect_args in - (match uu___4 with - | (param_args1, args1) -> - let uu___5 = - split - ct2.FStar_Syntax_Syntax.effect_args in - (match uu___5 with - | (param_args2, args2) -> - let uu___6 = - FStar_Compiler_List.fold_left2 - (fun uu___7 -> - fun uu___8 -> - fun uu___9 -> - match (uu___7, - uu___8, - uu___9) - with - | ((ps, wl1), - (t1, uu___10), - (t2, uu___11)) - -> - let uu___12 = - sub_prob wl1 - t1 - FStar_TypeChecker_Common.EQ - t2 - "effect params subcomp" in - (match uu___12 - with - | (p, wl2) -> - ((FStar_Compiler_List.op_At - ps [p]), - wl2))) - ([], wl) param_args1 - param_args2 in - (match uu___6 with - | (probs, wl1) -> - let param_subst = - FStar_Compiler_List.map2 - (fun b -> - fun uu___7 -> - match uu___7 - with - | (arg, uu___8) - -> - FStar_Syntax_Syntax.NT - ((b.FStar_Syntax_Syntax.binder_bv), - arg)) - eff_params_bs - param_args1 in - (bs2, - (FStar_Compiler_List.op_At - subst param_subst), - args1, args2, probs, - wl1))))) in - (match uu___1 with - | (bs2, subst1, args1, args2, - eff_params_sub_probs, wl1) -> - let uu___2 = - let uu___3 = - FStar_Compiler_List.splitAt - (FStar_Compiler_List.length args1) bs2 in - match uu___3 with - | (f_bs, bs3) -> - let f_substs = - FStar_Compiler_List.map2 - (fun f_b -> - fun uu___4 -> - match uu___4 with - | (arg, uu___5) -> - FStar_Syntax_Syntax.NT - ((f_b.FStar_Syntax_Syntax.binder_bv), - arg)) f_bs args1 in - (bs3, - (FStar_Compiler_List.op_At subst1 - f_substs)) in - (match uu___2 with - | (bs3, subst2) -> - let uu___3 = - if - FStar_Syntax_Syntax.uu___is_Substitutive_combinator - k - then - let uu___4 = - FStar_Compiler_List.splitAt - (FStar_Compiler_List.length - args2) bs3 in - match uu___4 with - | (g_bs, bs4) -> - let g_substs = - FStar_Compiler_List.map2 - (fun g_b -> - fun uu___5 -> - match uu___5 with - | (arg, uu___6) -> - FStar_Syntax_Syntax.NT - ((g_b.FStar_Syntax_Syntax.binder_bv), - arg)) g_bs - args2 in - (bs4, - (FStar_Compiler_List.op_At - subst2 g_substs), [], wl1) - else - if - FStar_Syntax_Syntax.uu___is_Substitutive_invariant_combinator - k - then - (let uu___5 = - FStar_Compiler_List.fold_left2 - (fun uu___6 -> - fun uu___7 -> - fun uu___8 -> - match (uu___6, - uu___7, - uu___8) - with - | ((ps, wl2), - (t1, uu___9), - (t2, uu___10)) -> - let uu___11 = - sub_prob wl2 t1 - FStar_TypeChecker_Common.EQ - t2 - "substitutive inv subcomp args" in - (match uu___11 - with - | (p, wl3) -> - ((FStar_Compiler_List.op_At - ps - [p]), - wl3))) - ([], wl1) args1 args2 in - match uu___5 with - | (probs, wl2) -> - (bs3, subst2, probs, wl2)) - else - failwith - "Impossible (rel.apply_substitutive_indexed_subcomp unexpected k" in - (match uu___3 with - | (bs4, subst3, f_g_args_eq_sub_probs, - wl2) -> - let bs5 = - let uu___4 = - FStar_Compiler_List.splitAt - ((FStar_Compiler_List.length - bs4) - - Prims.int_one) bs4 in - FStar_Pervasives_Native.fst - uu___4 in - let uu___4 = - FStar_Compiler_List.fold_left - (fun uu___5 -> - fun b -> - match uu___5 with - | (ss, wl3) -> - let uu___6 = - FStar_TypeChecker_Env.uvars_for_binders - env [b] ss - (fun b1 -> - let uu___7 = - FStar_Compiler_Effect.op_Bang - dbg_LayeredEffectsApp in - if uu___7 - then - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_binder - b1 in - let uu___9 = - FStar_Compiler_Range_Ops.string_of_range - r1 in - FStar_Compiler_Util.format3 - "implicit var for additional binder %s in subcomp %s at %s" - uu___8 - subcomp_name - uu___9 - else - "apply_substitutive_indexed_subcomp") - r1 in - (match uu___6 with - | (uv_t::[], g) -> - let uu___7 = - let uu___8 = - FStar_Class_Monoid.op_Plus_Plus - (FStar_Compiler_CList.monoid_clist - ()) - g.FStar_TypeChecker_Common.implicits - wl3.wl_implicits in - { - attempting = - (wl3.attempting); - wl_deferred - = - (wl3.wl_deferred); - wl_deferred_to_tac - = - (wl3.wl_deferred_to_tac); - ctr = - (wl3.ctr); - defer_ok = - (wl3.defer_ok); - smt_ok = - (wl3.smt_ok); - umax_heuristic_ok - = - (wl3.umax_heuristic_ok); - tcenv = - (wl3.tcenv); - wl_implicits - = uu___8; - repr_subcomp_allowed - = - (wl3.repr_subcomp_allowed); - typeclass_variables - = - (wl3.typeclass_variables) - } in - ((FStar_Compiler_List.op_At - ss - [FStar_Syntax_Syntax.NT - ((b.FStar_Syntax_Syntax.binder_bv), - uv_t)]), - uu___7))) - (subst3, wl2) bs5 in - (match uu___4 with - | (subst4, wl3) -> - let subcomp_ct = - let uu___5 = - FStar_Syntax_Subst.subst_comp - subst4 subcomp_c in - FStar_TypeChecker_Env.comp_to_comp_typ - env uu___5 in - let fml = - let uu___5 = - let uu___6 = - FStar_Compiler_List.hd - subcomp_ct.FStar_Syntax_Syntax.comp_univs in - let uu___7 = - let uu___8 = - FStar_Compiler_List.hd - subcomp_ct.FStar_Syntax_Syntax.effect_args in - FStar_Pervasives_Native.fst - uu___8 in - (uu___6, uu___7) in - match uu___5 with - | (u, wp) -> - FStar_TypeChecker_Env.pure_precondition_for_trivial_post - env u - subcomp_ct.FStar_Syntax_Syntax.result_typ - wp - FStar_Compiler_Range_Type.dummyRange in - (fml, - (FStar_Compiler_List.op_At - eff_params_sub_probs - f_g_args_eq_sub_probs), - wl3))))) -let (apply_ad_hoc_indexed_subcomp : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.comp -> - FStar_Syntax_Syntax.comp_typ -> - FStar_Syntax_Syntax.comp_typ -> - (worklist -> - FStar_Syntax_Syntax.term -> - FStar_TypeChecker_Common.rel -> - FStar_Syntax_Syntax.term -> - Prims.string -> - (FStar_TypeChecker_Common.prob * worklist)) - -> - worklist -> - Prims.string -> - FStar_Compiler_Range_Type.range -> - (FStar_Syntax_Syntax.typ * FStar_TypeChecker_Common.prob - Prims.list * worklist)) - = - fun env -> - fun bs -> - fun subcomp_c -> - fun ct1 -> - fun ct2 -> - fun sub_prob -> - fun wl -> - fun subcomp_name -> - fun r1 -> - let stronger_t_shape_error s = - let uu___ = - FStar_Ident.string_of_lid - ct2.FStar_Syntax_Syntax.effect_name in - FStar_Compiler_Util.format2 - "Unexpected shape of stronger for %s, reason: %s" - uu___ s in - let uu___ = - if - (FStar_Compiler_List.length bs) >= (Prims.of_int (2)) - then - let uu___1 = bs in - match uu___1 with - | a_b::bs1 -> - let uu___2 = - let uu___3 = - FStar_Compiler_List.splitAt - ((FStar_Compiler_List.length bs1) - - Prims.int_one) bs1 in - match uu___3 with - | (l1, l2) -> - let uu___4 = FStar_Compiler_List.hd l2 in - (l1, uu___4) in - (match uu___2 with - | (rest_bs, f_b) -> (a_b, rest_bs, f_b)) - else - (let uu___2 = - stronger_t_shape_error - "not an arrow or not enough binders" in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range r1 - FStar_Errors_Codes.Fatal_UnexpectedExpressionType - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)) in - match uu___ with - | (a_b, rest_bs, f_b) -> - let uu___1 = - FStar_TypeChecker_Env.uvars_for_binders env rest_bs - [FStar_Syntax_Syntax.NT - ((a_b.FStar_Syntax_Syntax.binder_bv), - (ct2.FStar_Syntax_Syntax.result_typ))] - (fun b -> - let uu___2 = - FStar_Compiler_Effect.op_Bang - dbg_LayeredEffectsApp in - if uu___2 - then - let uu___3 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_binder b in - let uu___4 = - FStar_Compiler_Range_Ops.string_of_range - r1 in - FStar_Compiler_Util.format3 - "implicit for binder %s in subcomp %s at %s" - uu___3 subcomp_name uu___4 - else "apply_ad_hoc_indexed_subcomp") r1 in - (match uu___1 with - | (rest_bs_uvars, g_uvars) -> - let wl1 = - let uu___2 = - FStar_Class_Monoid.op_Plus_Plus - (FStar_Compiler_CList.monoid_clist ()) - g_uvars.FStar_TypeChecker_Common.implicits - wl.wl_implicits in - { - attempting = (wl.attempting); - wl_deferred = (wl.wl_deferred); - wl_deferred_to_tac = (wl.wl_deferred_to_tac); - ctr = (wl.ctr); - defer_ok = (wl.defer_ok); - smt_ok = (wl.smt_ok); - umax_heuristic_ok = (wl.umax_heuristic_ok); - tcenv = (wl.tcenv); - wl_implicits = uu___2; - repr_subcomp_allowed = - (wl.repr_subcomp_allowed); - typeclass_variables = - (wl.typeclass_variables) - } in - let substs = - FStar_Compiler_List.map2 - (fun b -> - fun t -> - FStar_Syntax_Syntax.NT - ((b.FStar_Syntax_Syntax.binder_bv), - t)) (a_b :: rest_bs) - ((ct2.FStar_Syntax_Syntax.result_typ) :: - rest_bs_uvars) in - let uu___2 = - let f_sort_is = - let uu___3 = - let uu___4 = - FStar_TypeChecker_Env.is_layered_effect - env - ct1.FStar_Syntax_Syntax.effect_name in - let uu___5 = - stronger_t_shape_error - "type of f is not a repr type" in - FStar_Syntax_Util.effect_indices_from_repr - (f_b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort - uu___4 r1 uu___5 in - FStar_Compiler_List.map - (FStar_Syntax_Subst.subst substs) uu___3 in - let uu___3 = - FStar_Compiler_List.map - FStar_Pervasives_Native.fst - ct1.FStar_Syntax_Syntax.effect_args in - FStar_Compiler_List.fold_left2 - (fun uu___4 -> - fun f_sort_i -> - fun c1_i -> - match uu___4 with - | (ps, wl2) -> - ((let uu___6 = - FStar_Compiler_Effect.op_Bang - dbg_LayeredEffectsApp in - if uu___6 - then - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - f_sort_i in - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - c1_i in - FStar_Compiler_Util.print3 - "Layered Effects (%s) %s = %s\n" - subcomp_name uu___7 uu___8 - else ()); - (let uu___6 = - sub_prob wl2 f_sort_i - FStar_TypeChecker_Common.EQ - c1_i "indices of c1" in - match uu___6 with - | (p, wl3) -> - ((FStar_Compiler_List.op_At - ps [p]), wl3)))) - ([], wl1) f_sort_is uu___3 in - (match uu___2 with - | (f_sub_probs, wl2) -> - let subcomp_ct = - let uu___3 = - FStar_Syntax_Subst.subst_comp substs - subcomp_c in - FStar_TypeChecker_Env.comp_to_comp_typ - env uu___3 in - let uu___3 = - let g_sort_is = - let uu___4 = - FStar_TypeChecker_Env.is_layered_effect - env - ct2.FStar_Syntax_Syntax.effect_name in - let uu___5 = - stronger_t_shape_error - "subcomp return type is not a repr" in - FStar_Syntax_Util.effect_indices_from_repr - subcomp_ct.FStar_Syntax_Syntax.result_typ - uu___4 r1 uu___5 in - let uu___4 = - FStar_Compiler_List.map - FStar_Pervasives_Native.fst - ct2.FStar_Syntax_Syntax.effect_args in - FStar_Compiler_List.fold_left2 - (fun uu___5 -> - fun g_sort_i -> - fun c2_i -> - match uu___5 with - | (ps, wl3) -> - ((let uu___7 = - FStar_Compiler_Effect.op_Bang - dbg_LayeredEffectsApp in - if uu___7 - then - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - g_sort_i in - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - c2_i in - FStar_Compiler_Util.print3 - "Layered Effects (%s) %s = %s\n" - subcomp_name uu___8 - uu___9 - else ()); - (let uu___7 = - sub_prob wl3 g_sort_i - FStar_TypeChecker_Common.EQ - c2_i "indices of c2" in - match uu___7 with - | (p, wl4) -> - ((FStar_Compiler_List.op_At - ps [p]), wl4)))) - ([], wl2) g_sort_is uu___4 in - (match uu___3 with - | (g_sub_probs, wl3) -> - let fml = - let uu___4 = - let uu___5 = - FStar_Compiler_List.hd - subcomp_ct.FStar_Syntax_Syntax.comp_univs in - let uu___6 = - let uu___7 = - FStar_Compiler_List.hd - subcomp_ct.FStar_Syntax_Syntax.effect_args in - FStar_Pervasives_Native.fst - uu___7 in - (uu___5, uu___6) in - match uu___4 with - | (u, wp) -> - FStar_TypeChecker_Env.pure_precondition_for_trivial_post - env u - subcomp_ct.FStar_Syntax_Syntax.result_typ - wp - FStar_Compiler_Range_Type.dummyRange in - (fml, - (FStar_Compiler_List.op_At - f_sub_probs g_sub_probs), wl3)))) -let (has_typeclass_constraint : - FStar_Syntax_Syntax.ctx_uvar -> worklist -> Prims.bool) = - fun u -> - fun wl -> - FStar_Class_Setlike.for_any () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset FStar_Syntax_Free.ord_ctx_uvar)) - (fun v -> - FStar_Syntax_Unionfind.equiv v.FStar_Syntax_Syntax.ctx_uvar_head - u.FStar_Syntax_Syntax.ctx_uvar_head) - (Obj.magic wl.typeclass_variables) -let (lazy_complete_repr : FStar_Syntax_Syntax.lazy_kind -> Prims.bool) = - fun k -> - match k with - | FStar_Syntax_Syntax.Lazy_bv -> true - | FStar_Syntax_Syntax.Lazy_namedv -> true - | FStar_Syntax_Syntax.Lazy_binder -> true - | FStar_Syntax_Syntax.Lazy_letbinding -> true - | FStar_Syntax_Syntax.Lazy_fvar -> true - | FStar_Syntax_Syntax.Lazy_comp -> true - | FStar_Syntax_Syntax.Lazy_sigelt -> true - | FStar_Syntax_Syntax.Lazy_universe -> true - | uu___ -> false -let (has_free_uvars : FStar_Syntax_Syntax.term -> Prims.bool) = - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Free.uvars_uncached t in - FStar_Class_Setlike.is_empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) (Obj.magic uu___1) in - Prims.op_Negation uu___ -let (env_has_free_uvars : FStar_TypeChecker_Env.env_t -> Prims.bool) = - fun e -> - let uu___ = FStar_TypeChecker_Env.all_binders e in - FStar_Compiler_List.existsb - (fun b -> - has_free_uvars - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort) uu___ -let (gamma_has_free_uvars : - FStar_Syntax_Syntax.binding Prims.list -> Prims.bool) = - fun g -> - FStar_Compiler_List.existsb - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.Binding_var bv -> - has_free_uvars bv.FStar_Syntax_Syntax.sort - | uu___1 -> false) g -type reveal_hide_t = - | Hide of (FStar_Syntax_Syntax.universe * FStar_Syntax_Syntax.typ * - FStar_Syntax_Syntax.term) - | Reveal of (FStar_Syntax_Syntax.universe * FStar_Syntax_Syntax.typ * - FStar_Syntax_Syntax.term) -let (uu___is_Hide : reveal_hide_t -> Prims.bool) = - fun projectee -> match projectee with | Hide _0 -> true | uu___ -> false -let (__proj__Hide__item___0 : - reveal_hide_t -> - (FStar_Syntax_Syntax.universe * FStar_Syntax_Syntax.typ * - FStar_Syntax_Syntax.term)) - = fun projectee -> match projectee with | Hide _0 -> _0 -let (uu___is_Reveal : reveal_hide_t -> Prims.bool) = - fun projectee -> match projectee with | Reveal _0 -> true | uu___ -> false -let (__proj__Reveal__item___0 : - reveal_hide_t -> - (FStar_Syntax_Syntax.universe * FStar_Syntax_Syntax.typ * - FStar_Syntax_Syntax.term)) - = fun projectee -> match projectee with | Reveal _0 -> _0 -let rec (solve : worklist -> solution) = - fun probs -> - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___1 - then - let uu___2 = wl_to_string probs in - FStar_Compiler_Util.print1 "solve:\n\t%s\n" uu___2 - else ()); - (let uu___2 = FStar_Compiler_Effect.op_Bang dbg_ImplicitTrace in - if uu___2 - then - let uu___3 = - FStar_Class_Show.show - (FStar_Compiler_CList.showable_clist - FStar_TypeChecker_Common.showable_implicit) probs.wl_implicits in - FStar_Compiler_Util.print1 "solve: wl_implicits = %s\n" uu___3 - else ()); - (let uu___2 = next_prob probs in - match uu___2 with - | FStar_Pervasives_Native.Some (hd, tl, rank1) -> - let probs1 = - { - attempting = tl; - wl_deferred = (probs.wl_deferred); - wl_deferred_to_tac = (probs.wl_deferred_to_tac); - ctr = (probs.ctr); - defer_ok = (probs.defer_ok); - smt_ok = (probs.smt_ok); - umax_heuristic_ok = (probs.umax_heuristic_ok); - tcenv = (probs.tcenv); - wl_implicits = (probs.wl_implicits); - repr_subcomp_allowed = (probs.repr_subcomp_allowed); - typeclass_variables = (probs.typeclass_variables) - } in - (def_check_prob "solve,hd" hd; - (match hd with - | FStar_TypeChecker_Common.CProb cp -> - solve_c (maybe_invert cp) probs1 - | FStar_TypeChecker_Common.TProb tp -> - let uu___4 = - FStar_Compiler_Util.physical_equality - tp.FStar_TypeChecker_Common.lhs - tp.FStar_TypeChecker_Common.rhs in - if uu___4 - then - let uu___5 = - solve_prob hd FStar_Pervasives_Native.None [] probs1 in - solve uu___5 - else - (let is_expand_uvar t = - let uu___6 = - let uu___7 = FStar_Syntax_Subst.compress t in - uu___7.FStar_Syntax_Syntax.n in - match uu___6 with - | FStar_Syntax_Syntax.Tm_uvar (ctx_u, uu___7) -> - let uu___8 = - FStar_Syntax_Unionfind.find_decoration - ctx_u.FStar_Syntax_Syntax.ctx_uvar_head in - uu___8.FStar_Syntax_Syntax.uvar_decoration_should_unrefine - | uu___7 -> false in - let maybe_expand tp1 = - let uu___6 = - ((let uu___7 = FStar_Options_Ext.get "__unrefine" in - uu___7 <> "") && - (tp1.FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.SUB)) - && (is_expand_uvar tp1.FStar_TypeChecker_Common.rhs) in - if uu___6 - then - let lhs = tp1.FStar_TypeChecker_Common.lhs in - let lhs_norm = - FStar_TypeChecker_Normalize.unfold_whnf' - [FStar_TypeChecker_Env.DontUnfoldAttr - [FStar_Parser_Const.do_not_unrefine_attr]] - (p_env probs1 hd) lhs in - let uu___7 = - let uu___8 = - let uu___9 = FStar_Syntax_Subst.compress lhs_norm in - uu___9.FStar_Syntax_Syntax.n in - FStar_Syntax_Syntax.uu___is_Tm_refine uu___8 in - (if uu___7 - then - let lhs' = - FStar_TypeChecker_Normalize.unfold_whnf' - [FStar_TypeChecker_Env.DontUnfoldAttr - [FStar_Parser_Const.do_not_unrefine_attr]; - FStar_TypeChecker_Env.Unrefine] - (p_env probs1 hd) lhs_norm in - ((let uu___9 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___9 - then - let uu___10 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - tp1.FStar_TypeChecker_Common.rhs in - let uu___11 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term lhs in - let uu___12 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term lhs' in - FStar_Compiler_Util.print3 - "GGG widening uvar %s! RHS %s ~> %s\n" uu___10 - uu___11 uu___12 - else ()); - { - FStar_TypeChecker_Common.pid = - (tp1.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = lhs'; - FStar_TypeChecker_Common.relation = - (tp1.FStar_TypeChecker_Common.relation); - FStar_TypeChecker_Common.rhs = - (tp1.FStar_TypeChecker_Common.rhs); - FStar_TypeChecker_Common.element = - (tp1.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (tp1.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (tp1.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (tp1.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = - (tp1.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = - (tp1.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = - (tp1.FStar_TypeChecker_Common.logical) - }) - else tp1) - else tp1 in - let tp1 = maybe_expand tp in - if - (rank1 = FStar_TypeChecker_Common.Rigid_rigid) || - ((tp1.FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.EQ) - && (rank1 <> FStar_TypeChecker_Common.Flex_flex)) - then solve_t' tp1 probs1 - else - if probs1.defer_ok = DeferAny - then - maybe_defer_to_user_tac tp1 - "deferring flex_rigid or flex_flex subtyping" probs1 - else - if rank1 = FStar_TypeChecker_Common.Flex_flex - then - solve_t' - { - FStar_TypeChecker_Common.pid = - (tp1.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = - (tp1.FStar_TypeChecker_Common.lhs); - FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.EQ; - FStar_TypeChecker_Common.rhs = - (tp1.FStar_TypeChecker_Common.rhs); - FStar_TypeChecker_Common.element = - (tp1.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (tp1.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (tp1.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (tp1.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = - (tp1.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = - (tp1.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = - (tp1.FStar_TypeChecker_Common.logical) - } probs1 - else - solve_rigid_flex_or_flex_rigid_subtyping rank1 tp1 - probs1))) - | FStar_Pervasives_Native.None -> - let uu___3 = - Obj.magic - (FStar_Class_Listlike.view () - (Obj.magic (FStar_Compiler_CList.listlike_clist ())) - (Obj.magic probs.wl_deferred)) in - (match uu___3 with - | FStar_Class_Listlike.VNil -> - let uu___4 = - let uu___5 = as_deferred probs.wl_deferred_to_tac in - ((Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic (FStar_Compiler_CList.listlike_clist ())))), - uu___5, (probs.wl_implicits)) in - Success uu___4 - | FStar_Class_Listlike.VCons (uu___4, uu___5) -> - let uu___6 = - FStar_Compiler_CList.partition - (fun uu___7 -> - match uu___7 with - | (c, uu___8, uu___9, uu___10) -> c < probs.ctr) - probs.wl_deferred in - (match uu___6 with - | (attempt1, rest) -> - let uu___7 = - Obj.magic - (FStar_Class_Listlike.view () - (Obj.magic (FStar_Compiler_CList.listlike_clist ())) - (Obj.magic attempt1)) in - (match uu___7 with - | FStar_Class_Listlike.VNil -> - let uu___8 = - let uu___9 = as_deferred probs.wl_deferred in - let uu___10 = as_deferred probs.wl_deferred_to_tac in - (uu___9, uu___10, (probs.wl_implicits)) in - Success uu___8 - | uu___8 -> - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Class_Listlike.to_list - (FStar_Compiler_CList.listlike_clist ()) - attempt1 in - FStar_Compiler_List.map - (fun uu___12 -> - match uu___12 with - | (uu___13, uu___14, uu___15, y) -> y) - uu___11 in - { - attempting = uu___10; - wl_deferred = rest; - wl_deferred_to_tac = (probs.wl_deferred_to_tac); - ctr = (probs.ctr); - defer_ok = (probs.defer_ok); - smt_ok = (probs.smt_ok); - umax_heuristic_ok = (probs.umax_heuristic_ok); - tcenv = (probs.tcenv); - wl_implicits = (probs.wl_implicits); - repr_subcomp_allowed = - (probs.repr_subcomp_allowed); - typeclass_variables = (probs.typeclass_variables) - } in - solve uu___9)))) -and (solve_one_universe_eq : - FStar_TypeChecker_Common.prob -> - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.universe -> worklist -> solution) - = - fun orig -> - fun u1 -> - fun u2 -> - fun wl -> - let uu___ = solve_universe_eq (p_pid orig) wl u1 u2 in - match uu___ with - | USolved wl1 -> - let uu___1 = - solve_prob orig FStar_Pervasives_Native.None [] wl1 in - solve uu___1 - | UFailed msg -> giveup wl msg orig - | UDeferred wl1 -> - let uu___1 = - defer_lit FStar_TypeChecker_Common.Deferred_univ_constraint - "" orig wl1 in - solve uu___1 -and (solve_maybe_uinsts : - FStar_TypeChecker_Common.prob -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> worklist -> univ_eq_sol) - = - fun orig -> - fun t1 -> - fun t2 -> - fun wl -> - let rec aux wl1 us1 us2 = - match (us1, us2) with - | ([], []) -> USolved wl1 - | (u1::us11, u2::us21) -> - let uu___ = solve_universe_eq (p_pid orig) wl1 u1 u2 in - (match uu___ with - | USolved wl2 -> aux wl2 us11 us21 - | failed_or_deferred -> failed_or_deferred) - | uu___ -> ufailed_simple "Unequal number of universes" in - let env = p_env wl orig in - FStar_Defensive.def_check_scoped - FStar_TypeChecker_Env.hasBinders_env - FStar_Class_Binders.hasNames_term FStar_Syntax_Print.pretty_term - t1.FStar_Syntax_Syntax.pos "solve_maybe_uinsts.whnf1" env t1; - FStar_Defensive.def_check_scoped - FStar_TypeChecker_Env.hasBinders_env - FStar_Class_Binders.hasNames_term FStar_Syntax_Print.pretty_term - t2.FStar_Syntax_Syntax.pos "solve_maybe_uinsts.whnf2" env t2; - (let t11 = whnf env t1 in - let t21 = whnf env t2 in - match ((t11.FStar_Syntax_Syntax.n), (t21.FStar_Syntax_Syntax.n)) - with - | (FStar_Syntax_Syntax.Tm_uinst - ({ FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar f; - FStar_Syntax_Syntax.pos = uu___2; - FStar_Syntax_Syntax.vars = uu___3; - FStar_Syntax_Syntax.hash_code = uu___4;_}, - us1), - FStar_Syntax_Syntax.Tm_uinst - ({ FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar g; - FStar_Syntax_Syntax.pos = uu___5; - FStar_Syntax_Syntax.vars = uu___6; - FStar_Syntax_Syntax.hash_code = uu___7;_}, - us2)) -> - let b = FStar_Syntax_Syntax.fv_eq f g in aux wl us1 us2 - | (FStar_Syntax_Syntax.Tm_uinst uu___2, uu___3) -> - failwith "Impossible: expect head symbols to match" - | (uu___2, FStar_Syntax_Syntax.Tm_uinst uu___3) -> - failwith "Impossible: expect head symbols to match" - | uu___2 -> USolved wl) -and (giveup_or_defer : - FStar_TypeChecker_Common.prob -> - worklist -> - FStar_TypeChecker_Common.deferred_reason -> lstring -> solution) - = - fun orig -> - fun wl -> - fun reason -> - fun msg -> - if wl.defer_ok = DeferAny - then - ((let uu___1 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___1 - then - let uu___2 = prob_to_string wl.tcenv orig in - let uu___3 = FStar_Thunk.force msg in - FStar_Compiler_Util.print2 - "\n\t\tDeferring %s\n\t\tBecause %s\n" uu___2 uu___3 - else ()); - (let uu___1 = defer reason msg orig wl in solve uu___1)) - else giveup wl msg orig -and (giveup_or_defer_flex_flex : - FStar_TypeChecker_Common.prob -> - worklist -> - FStar_TypeChecker_Common.deferred_reason -> lstring -> solution) - = - fun orig -> - fun wl -> - fun reason -> - fun msg -> - if wl.defer_ok <> NoDefer - then - ((let uu___1 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___1 - then - let uu___2 = prob_to_string wl.tcenv orig in - let uu___3 = FStar_Thunk.force msg in - FStar_Compiler_Util.print2 - "\n\t\tDeferring %s\n\t\tBecause %s\n" uu___2 uu___3 - else ()); - (let uu___1 = defer reason msg orig wl in solve uu___1)) - else giveup wl msg orig -and (defer_to_user_tac : - FStar_TypeChecker_Common.prob -> Prims.string -> worklist -> solution) = - fun orig -> - fun reason -> - fun wl -> - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___1 - then - let uu___2 = prob_to_string wl.tcenv orig in - FStar_Compiler_Util.print1 "\n\t\tDeferring %s to a tactic\n" - uu___2 - else ()); - (let wl1 = solve_prob orig FStar_Pervasives_Native.None [] wl in - let wl2 = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Thunk.mkv reason in - ((wl1.ctr), FStar_TypeChecker_Common.Deferred_to_user_tac, - uu___3, orig) in - Obj.magic - (FStar_Class_Listlike.cons () - (Obj.magic (FStar_Compiler_CList.listlike_clist ())) uu___2 - (Obj.magic wl1.wl_deferred_to_tac)) in - { - attempting = (wl1.attempting); - wl_deferred = (wl1.wl_deferred); - wl_deferred_to_tac = uu___1; - ctr = (wl1.ctr); - defer_ok = (wl1.defer_ok); - smt_ok = (wl1.smt_ok); - umax_heuristic_ok = (wl1.umax_heuristic_ok); - tcenv = (wl1.tcenv); - wl_implicits = (wl1.wl_implicits); - repr_subcomp_allowed = (wl1.repr_subcomp_allowed); - typeclass_variables = (wl1.typeclass_variables) - } in - solve wl2) -and (maybe_defer_to_user_tac : tprob -> Prims.string -> worklist -> solution) - = - fun prob -> - fun reason -> - fun wl -> - match prob.FStar_TypeChecker_Common.relation with - | FStar_TypeChecker_Common.EQ -> - let should_defer_tac t = - let uu___ = FStar_Syntax_Util.head_and_args t in - match uu___ with - | (head, uu___1) -> - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress head in - uu___3.FStar_Syntax_Syntax.n in - (match uu___2 with - | FStar_Syntax_Syntax.Tm_uvar (uv, uu___3) -> - let uu___4 = - FStar_TypeChecker_DeferredImplicits.should_defer_uvar_to_user_tac - wl.tcenv uv in - (uu___4, (uv.FStar_Syntax_Syntax.ctx_uvar_reason)) - | uu___3 -> (false, "")) in - let uu___ = should_defer_tac prob.FStar_TypeChecker_Common.lhs in - (match uu___ with - | (l1, r1) -> - let uu___1 = - should_defer_tac prob.FStar_TypeChecker_Common.rhs in - (match uu___1 with - | (l2, r2) -> - if l1 || l2 - then - defer_to_user_tac - (FStar_TypeChecker_Common.TProb prob) - (Prims.strcat r1 (Prims.strcat ", " r2)) wl - else - (let uu___3 = - defer_lit FStar_TypeChecker_Common.Deferred_flex - reason (FStar_TypeChecker_Common.TProb prob) wl in - solve uu___3))) - | uu___ -> - let uu___1 = - defer_lit FStar_TypeChecker_Common.Deferred_flex reason - (FStar_TypeChecker_Common.TProb prob) wl in - solve uu___1 -and (solve_rigid_flex_or_flex_rigid_subtyping : - FStar_TypeChecker_Common.rank_t -> tprob -> worklist -> solution) = - fun rank1 -> - fun tp -> - fun wl -> - def_check_prob "solve_rigid_flex_or_flex_rigid_subtyping" - (FStar_TypeChecker_Common.TProb tp); - (let flip = rank1 = FStar_TypeChecker_Common.Flex_rigid in - let meet_or_join op ts wl1 = - let eq_prob t1 t2 wl2 = - let uu___1 = - new_problem wl2 - (p_env wl2 (FStar_TypeChecker_Common.TProb tp)) t1 - FStar_TypeChecker_Common.EQ t2 FStar_Pervasives_Native.None - t1.FStar_Syntax_Syntax.pos "join/meet refinements" in - match uu___1 with - | (p, wl3) -> - (def_check_prob "meet_or_join" - (FStar_TypeChecker_Common.TProb p); - ((FStar_TypeChecker_Common.TProb p), wl3)) in - let pairwise t1 t2 wl2 = - (let uu___2 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___2 - then - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t2 in - FStar_Compiler_Util.print2 - "[meet/join]: pairwise: %s and %s\n" uu___3 uu___4 - else ()); - (let uu___2 = - head_matches_delta - (p_env wl2 (FStar_TypeChecker_Common.TProb tp)) - tp.FStar_TypeChecker_Common.logical wl2.smt_ok t1 t2 in - match uu___2 with - | (mr, ts1) -> - (match mr with - | HeadMatch (true) -> - let uu___3 = eq_prob t1 t2 wl2 in - (match uu___3 with | (p, wl3) -> (t1, [p], wl3)) - | MisMatch uu___3 -> - let uu___4 = eq_prob t1 t2 wl2 in - (match uu___4 with | (p, wl3) -> (t1, [p], wl3)) - | FullMatch -> - (match ts1 with - | FStar_Pervasives_Native.None -> (t1, [], wl2) - | FStar_Pervasives_Native.Some (t11, t21) -> - (t11, [], wl2)) - | HeadMatch (false) -> - let uu___3 = - match ts1 with - | FStar_Pervasives_Native.Some (t11, t21) -> - let uu___4 = FStar_Syntax_Subst.compress t11 in - let uu___5 = FStar_Syntax_Subst.compress t21 in - (uu___4, uu___5) - | FStar_Pervasives_Native.None -> - let uu___4 = FStar_Syntax_Subst.compress t1 in - let uu___5 = FStar_Syntax_Subst.compress t2 in - (uu___4, uu___5) in - (match uu___3 with - | (t11, t21) -> - let try_eq t12 t22 wl3 = - let uu___4 = - FStar_Syntax_Util.head_and_args t12 in - match uu___4 with - | (t1_hd, t1_args) -> - let uu___5 = - FStar_Syntax_Util.head_and_args t22 in - (match uu___5 with - | (t2_hd, t2_args) -> - if - (FStar_Compiler_List.length t1_args) - <> - (FStar_Compiler_List.length - t2_args) - then FStar_Pervasives_Native.None - else - (let uu___7 = - let uu___8 = - let uu___9 = - FStar_Syntax_Syntax.as_arg - t1_hd in - uu___9 :: t1_args in - let uu___9 = - let uu___10 = - FStar_Syntax_Syntax.as_arg - t2_hd in - uu___10 :: t2_args in - FStar_Compiler_List.fold_left2 - (fun uu___10 -> - fun uu___11 -> - fun uu___12 -> - match (uu___10, uu___11, - uu___12) - with - | ((probs, wl4), - (a1, uu___13), - (a2, uu___14)) -> - let uu___15 = - eq_prob a1 a2 wl4 in - (match uu___15 with - | (p, wl5) -> - ((p :: probs), - wl5))) - ([], wl3) uu___8 uu___9 in - match uu___7 with - | (probs, wl4) -> - let wl' = - { - attempting = probs; - wl_deferred = - (Obj.magic - (FStar_Class_Listlike.empty - () - (Obj.magic - (FStar_Compiler_CList.listlike_clist - ())))); - wl_deferred_to_tac = - (wl4.wl_deferred_to_tac); - ctr = (wl4.ctr); - defer_ok = NoDefer; - smt_ok = false; - umax_heuristic_ok = - (wl4.umax_heuristic_ok); - tcenv = (wl4.tcenv); - wl_implicits = - (Obj.magic - (FStar_Class_Listlike.empty - () - (Obj.magic - (FStar_Compiler_CList.listlike_clist - ())))); - repr_subcomp_allowed = - (wl4.repr_subcomp_allowed); - typeclass_variables = - (wl4.typeclass_variables) - } in - let tx = - FStar_Syntax_Unionfind.new_transaction - () in - let uu___8 = solve wl' in - (match uu___8 with - | Success - (uu___9, defer_to_tac, - imps) - -> - (FStar_Syntax_Unionfind.commit - tx; - (let uu___11 = - extend_wl wl4 - (Obj.magic - (FStar_Class_Listlike.empty - () - (Obj.magic - (FStar_Compiler_CList.listlike_clist - ())))) - defer_to_tac imps in - FStar_Pervasives_Native.Some - uu___11)) - | Failed uu___9 -> - (FStar_Syntax_Unionfind.rollback - tx; - FStar_Pervasives_Native.None)))) in - let combine t12 t22 wl3 = - let env = - p_env wl3 (FStar_TypeChecker_Common.TProb tp) in - let uu___4 = - base_and_refinement_maybe_delta false env t12 in - match uu___4 with - | (t1_base, p1_opt) -> - let uu___5 = - base_and_refinement_maybe_delta false env - t22 in - (match uu___5 with - | (t2_base, p2_opt) -> - let apply_op env1 op1 phi1 phi2 = - let squash phi = - let uu___6 = - env1.FStar_TypeChecker_Env.universe_of - env1 phi in - match uu___6 with - | FStar_Syntax_Syntax.U_zero -> - phi - | u -> - FStar_Syntax_Util.mk_squash u - phi in - let uu___6 = squash phi1 in - let uu___7 = squash phi2 in - op1 uu___6 uu___7 in - let combine_refinements t_base p1_opt1 - p2_opt1 = - match op with - | FStar_Pervasives_Native.None -> - t_base - | FStar_Pervasives_Native.Some op1 - -> - let refine x t = - let uu___6 = - FStar_Syntax_Util.is_t_true - t in - if uu___6 - then - x.FStar_Syntax_Syntax.sort - else - FStar_Syntax_Util.refine x t in - (match (p1_opt1, p2_opt1) with - | (FStar_Pervasives_Native.Some - (x, phi1), - FStar_Pervasives_Native.Some - (y, phi2)) -> - let x1 = - FStar_Syntax_Syntax.freshen_bv - x in - let subst = - [FStar_Syntax_Syntax.DB - (Prims.int_zero, x1)] in - let phi11 = - FStar_Syntax_Subst.subst - subst phi1 in - let phi21 = - FStar_Syntax_Subst.subst - subst phi2 in - let env_x = - FStar_TypeChecker_Env.push_bv - env x1 in - let uu___6 = - apply_op env_x op1 phi11 - phi21 in - refine x1 uu___6 - | (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.Some - (x, phi)) -> - let x1 = - FStar_Syntax_Syntax.freshen_bv - x in - let subst = - [FStar_Syntax_Syntax.DB - (Prims.int_zero, x1)] in - let phi1 = - FStar_Syntax_Subst.subst - subst phi in - let env_x = - FStar_TypeChecker_Env.push_bv - env x1 in - let uu___6 = - apply_op env_x op1 - FStar_Syntax_Util.t_true - phi1 in - refine x1 uu___6 - | (FStar_Pervasives_Native.Some - (x, phi), - FStar_Pervasives_Native.None) - -> - let x1 = - FStar_Syntax_Syntax.freshen_bv - x in - let subst = - [FStar_Syntax_Syntax.DB - (Prims.int_zero, x1)] in - let phi1 = - FStar_Syntax_Subst.subst - subst phi in - let env_x = - FStar_TypeChecker_Env.push_bv - env x1 in - let uu___6 = - apply_op env_x op1 - FStar_Syntax_Util.t_true - phi1 in - refine x1 uu___6 - | uu___6 -> t_base) in - let uu___6 = - try_eq t1_base t2_base wl3 in - (match uu___6 with - | FStar_Pervasives_Native.Some wl4 -> - let uu___7 = - combine_refinements t1_base - p1_opt p2_opt in - (uu___7, [], wl4) - | FStar_Pervasives_Native.None -> - let uu___7 = - base_and_refinement_maybe_delta - true env t12 in - (match uu___7 with - | (t1_base1, p1_opt1) -> - let uu___8 = - base_and_refinement_maybe_delta - true env t22 in - (match uu___8 with - | (t2_base1, p2_opt1) -> - let uu___9 = - eq_prob t1_base1 - t2_base1 wl3 in - (match uu___9 with - | (p, wl4) -> - let t = - combine_refinements - t1_base1 - p1_opt1 - p2_opt1 in - (t, [p], wl4)))))) in - let uu___4 = combine t11 t21 wl2 in - (match uu___4 with - | (t12, ps, wl3) -> - ((let uu___6 = - FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___6 - then - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t12 in - FStar_Compiler_Util.print1 - "pairwise fallback2 succeeded: %s" - uu___7 - else ()); - (t12, ps, wl3)))))) in - let rec aux uu___1 ts1 = - match uu___1 with - | (out, probs, wl2) -> - (match ts1 with - | [] -> (out, probs, wl2) - | t::ts2 -> - let uu___2 = pairwise out t wl2 in - (match uu___2 with - | (out1, probs', wl3) -> - aux - (out1, (FStar_Compiler_List.op_At probs probs'), - wl3) ts2)) in - let uu___1 = - let uu___2 = FStar_Compiler_List.hd ts in (uu___2, [], wl1) in - let uu___2 = FStar_Compiler_List.tl ts in aux uu___1 uu___2 in - let uu___1 = - if flip - then - ((tp.FStar_TypeChecker_Common.lhs), - (tp.FStar_TypeChecker_Common.rhs)) - else - ((tp.FStar_TypeChecker_Common.rhs), - (tp.FStar_TypeChecker_Common.lhs)) in - match uu___1 with - | (this_flex, this_rigid) -> - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress this_rigid in - uu___3.FStar_Syntax_Syntax.n in - (match uu___2 with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = _bs; - FStar_Syntax_Syntax.comp = comp;_} - -> - let uu___3 = FStar_Syntax_Util.is_tot_or_gtot_comp comp in - if uu___3 - then - let uu___4 = destruct_flex_t this_flex wl in - (match uu___4 with - | (flex, wl1) -> - let uu___5 = quasi_pattern wl1.tcenv flex in - (match uu___5 with - | FStar_Pervasives_Native.None -> - giveup_lit wl1 - "flex-arrow subtyping, not a quasi pattern" - (FStar_TypeChecker_Common.TProb tp) - | FStar_Pervasives_Native.Some (flex_bs, flex_t1) - -> - ((let uu___7 = - FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___7 - then - let uu___8 = - FStar_Compiler_Util.string_of_int - tp.FStar_TypeChecker_Common.pid in - FStar_Compiler_Util.print1 - "Trying to solve by imitating arrow:%s\n" - uu___8 - else ()); - imitate_arrow - (FStar_TypeChecker_Common.TProb tp) wl1 flex - flex_bs flex_t1 - tp.FStar_TypeChecker_Common.relation - this_rigid))) - else - (let uu___5 = - attempt - [FStar_TypeChecker_Common.TProb - { - FStar_TypeChecker_Common.pid = - (tp.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = - (tp.FStar_TypeChecker_Common.lhs); - FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.EQ; - FStar_TypeChecker_Common.rhs = - (tp.FStar_TypeChecker_Common.rhs); - FStar_TypeChecker_Common.element = - (tp.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (tp.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (tp.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (tp.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = - (tp.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = - (tp.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = - (tp.FStar_TypeChecker_Common.logical) - }] wl in - solve uu___5) - | uu___3 -> - ((let uu___5 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___5 - then - let uu___6 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - tp.FStar_TypeChecker_Common.pid in - FStar_Compiler_Util.print1 - "Trying to solve by meeting refinements:%s\n" uu___6 - else ()); - (let uu___5 = FStar_Syntax_Util.head_and_args this_flex in - match uu___5 with - | (u, _args) -> - let env = - p_env wl (FStar_TypeChecker_Common.TProb tp) in - let uu___6 = - let uu___7 = FStar_Syntax_Subst.compress u in - uu___7.FStar_Syntax_Syntax.n in - (match uu___6 with - | FStar_Syntax_Syntax.Tm_uvar (ctx_uvar, _subst) -> - let equiv t = - let uu___7 = FStar_Syntax_Util.head_and_args t in - match uu___7 with - | (u', uu___8) -> - let uu___9 = - let uu___10 = whnf env u' in - uu___10.FStar_Syntax_Syntax.n in - (match uu___9 with - | FStar_Syntax_Syntax.Tm_uvar - (ctx_uvar', _subst') -> - FStar_Syntax_Unionfind.equiv - ctx_uvar.FStar_Syntax_Syntax.ctx_uvar_head - ctx_uvar'.FStar_Syntax_Syntax.ctx_uvar_head - | uu___10 -> false) in - let uu___7 = - FStar_Compiler_List.partition - (fun uu___8 -> - match uu___8 with - | FStar_TypeChecker_Common.TProb tp1 -> - let tp2 = maybe_invert tp1 in - (match tp2.FStar_TypeChecker_Common.rank - with - | FStar_Pervasives_Native.Some rank' - when rank1 = rank' -> - if flip - then - equiv - tp2.FStar_TypeChecker_Common.lhs - else - equiv - tp2.FStar_TypeChecker_Common.rhs - | uu___9 -> false) - | uu___9 -> false) wl.attempting in - (match uu___7 with - | (bounds_probs, rest) -> - let bounds_typs = - let uu___8 = whnf env this_rigid in - let uu___9 = - FStar_Compiler_List.collect - (fun uu___10 -> - match uu___10 with - | FStar_TypeChecker_Common.TProb p - -> - let uu___11 = - if flip - then - whnf env - (maybe_invert p).FStar_TypeChecker_Common.rhs - else - whnf env - (maybe_invert p).FStar_TypeChecker_Common.lhs in - [uu___11] - | uu___11 -> []) bounds_probs in - uu___8 :: uu___9 in - let uu___8 = - let uu___9 = - (has_typeclass_constraint ctx_uvar wl) - && (Prims.op_Negation flip) in - if uu___9 - then (true, FStar_Pervasives_Native.None) - else - (false, - (FStar_Pervasives_Native.Some - (if flip - then - FStar_Syntax_Util.mk_conj_simp - else - FStar_Syntax_Util.mk_disj_simp))) in - (match uu___8 with - | (widen, meet_or_join_op) -> - let uu___9 = - match bounds_typs with - | t::[] -> - if widen - then - let uu___10 = - let uu___11 = - base_and_refinement_maybe_delta - false env t in - FStar_Pervasives_Native.fst - uu___11 in - (uu___10, [], wl) - else (t, [], wl) - | uu___10 -> - meet_or_join meet_or_join_op - bounds_typs wl in - (match uu___9 with - | (bound, sub_probs, wl1) -> - let uu___10 = - let flex_u = - flex_uvar_head this_flex in - let bound1 = - let uu___11 = - let uu___12 = - FStar_Syntax_Subst.compress - bound in - uu___12.FStar_Syntax_Syntax.n in - match uu___11 with - | FStar_Syntax_Syntax.Tm_refine - { - FStar_Syntax_Syntax.b = - x; - FStar_Syntax_Syntax.phi - = phi;_} - when - (tp.FStar_TypeChecker_Common.relation - = - FStar_TypeChecker_Common.SUB) - && - (let uu___12 = - occurs flex_u - x.FStar_Syntax_Syntax.sort in - FStar_Pervasives_Native.snd - uu___12) - -> - x.FStar_Syntax_Syntax.sort - | uu___12 -> bound in - let uu___11 = - new_problem wl1 - (p_env wl1 - (FStar_TypeChecker_Common.TProb - tp)) bound1 - FStar_TypeChecker_Common.EQ - this_flex - FStar_Pervasives_Native.None - tp.FStar_TypeChecker_Common.loc - (if flip - then "joining refinements" - else "meeting refinements") in - (bound1, uu___11) in - (match uu___10 with - | (bound_typ, (eq_prob, wl')) -> - (def_check_prob - "meet_or_join2" - (FStar_TypeChecker_Common.TProb - eq_prob); - (let uu___13 = - FStar_Compiler_Effect.op_Bang - dbg_Rel in - if uu___13 - then - let wl'1 = - { - attempting = - ((FStar_TypeChecker_Common.TProb - eq_prob) :: - sub_probs); - wl_deferred = - (wl1.wl_deferred); - wl_deferred_to_tac = - (wl1.wl_deferred_to_tac); - ctr = (wl1.ctr); - defer_ok = - (wl1.defer_ok); - smt_ok = - (wl1.smt_ok); - umax_heuristic_ok = - (wl1.umax_heuristic_ok); - tcenv = (wl1.tcenv); - wl_implicits = - (wl1.wl_implicits); - repr_subcomp_allowed - = - (wl1.repr_subcomp_allowed); - typeclass_variables - = - (wl1.typeclass_variables) - } in - let uu___14 = - wl_to_string wl'1 in - FStar_Compiler_Util.print1 - "After meet/join refinements: %s\n" - uu___14 - else ()); - (let tx = - FStar_Syntax_Unionfind.new_transaction - () in - FStar_Compiler_List.iter - (def_check_prob - "meet_or_join3_sub") - sub_probs; - (let uu___14 = - solve_t eq_prob - { - attempting = - sub_probs; - wl_deferred = - (Obj.magic - (FStar_Class_Listlike.empty - () - (Obj.magic - (FStar_Compiler_CList.listlike_clist - ())))); - wl_deferred_to_tac - = - (wl'.wl_deferred_to_tac); - ctr = (wl'.ctr); - defer_ok = NoDefer; - smt_ok = - (wl'.smt_ok); - umax_heuristic_ok = - (wl'.umax_heuristic_ok); - tcenv = (wl'.tcenv); - wl_implicits = - (Obj.magic - (FStar_Class_Listlike.empty - () - (Obj.magic - (FStar_Compiler_CList.listlike_clist - ())))); - repr_subcomp_allowed - = - (wl'.repr_subcomp_allowed); - typeclass_variables - = - (wl'.typeclass_variables) - } in - match uu___14 with - | Success - (uu___15, - defer_to_tac, imps) - -> - let wl2 = - { - attempting = rest; - wl_deferred = - (wl'.wl_deferred); - wl_deferred_to_tac - = - (wl'.wl_deferred_to_tac); - ctr = (wl'.ctr); - defer_ok = - (wl'.defer_ok); - smt_ok = - (wl'.smt_ok); - umax_heuristic_ok - = - (wl'.umax_heuristic_ok); - tcenv = - (wl'.tcenv); - wl_implicits = - (wl'.wl_implicits); - repr_subcomp_allowed - = - (wl'.repr_subcomp_allowed); - typeclass_variables - = - (wl'.typeclass_variables) - } in - let wl3 = - extend_wl wl2 - (Obj.magic - (FStar_Class_Listlike.empty - () - (Obj.magic - (FStar_Compiler_CList.listlike_clist - ())))) - defer_to_tac imps in - let g = - FStar_Compiler_List.fold_left - (fun g1 -> - fun p -> - FStar_Syntax_Util.mk_conj - g1 - (p_guard p)) - eq_prob.FStar_TypeChecker_Common.logical_guard - sub_probs in - let wl4 = - solve_prob' false - (FStar_TypeChecker_Common.TProb - tp) - (FStar_Pervasives_Native.Some - g) [] wl3 in - let uu___16 = - FStar_Compiler_List.fold_left - (fun wl5 -> - fun p -> - solve_prob' - true p - FStar_Pervasives_Native.None - [] wl5) - wl4 bounds_probs in - (FStar_Syntax_Unionfind.commit - tx; - solve wl4) - | Failed (p, msg) -> - ((let uu___16 = - FStar_Compiler_Effect.op_Bang - dbg_Rel in - if uu___16 - then - let uu___17 = - let uu___18 = - FStar_Compiler_List.map - (prob_to_string - env) - ((FStar_TypeChecker_Common.TProb - eq_prob) - :: - sub_probs) in - FStar_Compiler_String.concat - "\n" uu___18 in - FStar_Compiler_Util.print1 - "meet/join attempted and failed to solve problems:\n%s\n" - uu___17 - else ()); - (let uu___16 = - let uu___17 = - base_and_refinement - env bound_typ in - (rank1, uu___17) in - match uu___16 with - | (FStar_TypeChecker_Common.Rigid_flex, - (t_base, - FStar_Pervasives_Native.Some - uu___17)) -> - (FStar_Syntax_Unionfind.rollback - tx; - (let uu___19 = - new_problem - wl1 - ( - p_env wl1 - (FStar_TypeChecker_Common.TProb - tp)) - t_base - FStar_TypeChecker_Common.EQ - this_flex - FStar_Pervasives_Native.None - tp.FStar_TypeChecker_Common.loc - "widened subtyping" in - match uu___19 - with - | (eq_prob1, - wl2) -> - ( - def_check_prob - "meet_or_join3" - (FStar_TypeChecker_Common.TProb - eq_prob1); - ( - let wl3 = - solve_prob' - false - (FStar_TypeChecker_Common.TProb - tp) - (FStar_Pervasives_Native.Some - (p_guard - (FStar_TypeChecker_Common.TProb - eq_prob1))) - [] wl2 in - let uu___21 - = - attempt - [ - FStar_TypeChecker_Common.TProb - eq_prob1] - wl3 in - solve - uu___21)))) - | (FStar_TypeChecker_Common.Flex_rigid, - (t_base, - FStar_Pervasives_Native.Some - (x, phi))) -> - (FStar_Syntax_Unionfind.rollback - tx; - (let x1 = - FStar_Syntax_Syntax.freshen_bv - x in - let uu___18 = - let uu___19 - = - let uu___20 - = - FStar_Syntax_Syntax.mk_binder - x1 in - [uu___20] in - FStar_Syntax_Subst.open_term - uu___19 - phi in - match uu___18 - with - | (uu___19, - phi1) -> - let uu___20 - = - new_problem - wl1 env - t_base - FStar_TypeChecker_Common.EQ - this_flex - FStar_Pervasives_Native.None - tp.FStar_TypeChecker_Common.loc - "widened subtyping" in - (match uu___20 - with - | - (eq_prob1, - wl2) -> - (def_check_prob - "meet_or_join4" - (FStar_TypeChecker_Common.TProb - eq_prob1); - (let phi2 - = - guard_on_element - wl2 tp x1 - phi1 in - let wl3 = - let uu___22 - = - let uu___23 - = - FStar_Syntax_Util.mk_conj - phi2 - (p_guard - (FStar_TypeChecker_Common.TProb - eq_prob1)) in - FStar_Pervasives_Native.Some - uu___23 in - solve_prob' - false - (FStar_TypeChecker_Common.TProb - tp) - uu___22 - [] wl2 in - let uu___22 - = - attempt - [ - FStar_TypeChecker_Common.TProb - eq_prob1] - wl3 in - solve - uu___22))))) - | uu___17 -> - let uu___18 = - FStar_Thunk.map - (fun s -> - Prims.strcat - "failed to solve the sub-problems: " - s) msg in - giveup wl1 - uu___18 p))))))))) - | uu___7 when flip -> - let uu___8 = - let uu___9 = - FStar_Compiler_Util.string_of_int - (rank_t_num rank1) in - let uu___10 = - prob_to_string env - (FStar_TypeChecker_Common.TProb tp) in - FStar_Compiler_Util.format2 - "Impossible: (rank=%s) Not a flex-rigid: %s" - uu___9 uu___10 in - failwith uu___8 - | uu___7 -> - let uu___8 = - let uu___9 = - FStar_Compiler_Util.string_of_int - (rank_t_num rank1) in - let uu___10 = - prob_to_string env - (FStar_TypeChecker_Common.TProb tp) in - FStar_Compiler_Util.format2 - "Impossible: (rank=%s) Not a rigid-flex: %s" - uu___9 uu___10 in - failwith uu___8))))) -and (imitate_arrow : - FStar_TypeChecker_Common.prob -> - worklist -> - flex_t -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.term -> - FStar_TypeChecker_Common.rel -> - FStar_Syntax_Syntax.term -> solution) - = - fun orig -> - fun wl -> - fun lhs -> - fun bs_lhs -> - fun t_res_lhs -> - fun rel -> - fun arrow -> - let bs_lhs_args = - FStar_Compiler_List.map - (fun uu___ -> - match uu___ with - | { FStar_Syntax_Syntax.binder_bv = x; - FStar_Syntax_Syntax.binder_qual = i; - FStar_Syntax_Syntax.binder_positivity = uu___1; - FStar_Syntax_Syntax.binder_attrs = uu___2;_} -> - let uu___3 = FStar_Syntax_Syntax.bv_to_name x in - (uu___3, i)) bs_lhs in - let uu___ = lhs in - match uu___ with - | Flex (uu___1, u_lhs, uu___2) -> - let imitate_comp bs bs_terms c wl1 = - let imitate_tot_or_gtot t f wl2 = - let uu___3 = FStar_Syntax_Util.type_u () in - match uu___3 with - | (k, uu___4) -> - let uu___5 = - copy_uvar u_lhs - (FStar_Compiler_List.op_At bs_lhs bs) k wl2 in - (match uu___5 with - | (uu___6, u, wl3) -> - let uu___7 = f u in (uu___7, wl3)) in - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total t -> - imitate_tot_or_gtot t FStar_Syntax_Syntax.mk_Total - wl1 - | FStar_Syntax_Syntax.GTotal t -> - imitate_tot_or_gtot t FStar_Syntax_Syntax.mk_GTotal - wl1 - | FStar_Syntax_Syntax.Comp ct -> - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Syntax_Syntax.as_arg - ct.FStar_Syntax_Syntax.result_typ in - uu___5 :: (ct.FStar_Syntax_Syntax.effect_args) in - FStar_Compiler_List.fold_right - (fun uu___5 -> - fun uu___6 -> - match (uu___5, uu___6) with - | ((a, i), (out_args, wl2)) -> - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Syntax_Util.type_u () in - FStar_Pervasives_Native.fst uu___9 in - copy_uvar u_lhs [] uu___8 wl2 in - (match uu___7 with - | (uu___8, t_a, wl3) -> - let uu___9 = - copy_uvar u_lhs bs t_a wl3 in - (match uu___9 with - | (uu___10, a', wl4) -> - (((a', i) :: out_args), wl4)))) - uu___4 ([], wl1) in - (match uu___3 with - | (out_args, wl2) -> - let nodec flags = - FStar_Compiler_List.filter - (fun uu___4 -> - match uu___4 with - | FStar_Syntax_Syntax.DECREASES uu___5 - -> false - | uu___5 -> true) flags in - let ct' = - let uu___4 = - let uu___5 = - FStar_Compiler_List.hd out_args in - FStar_Pervasives_Native.fst uu___5 in - let uu___5 = FStar_Compiler_List.tl out_args in - let uu___6 = - nodec ct.FStar_Syntax_Syntax.flags in - { - FStar_Syntax_Syntax.comp_univs = - (ct.FStar_Syntax_Syntax.comp_univs); - FStar_Syntax_Syntax.effect_name = - (ct.FStar_Syntax_Syntax.effect_name); - FStar_Syntax_Syntax.result_typ = uu___4; - FStar_Syntax_Syntax.effect_args = uu___5; - FStar_Syntax_Syntax.flags = uu___6 - } in - ({ - FStar_Syntax_Syntax.n = - (FStar_Syntax_Syntax.Comp ct'); - FStar_Syntax_Syntax.pos = - (c.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = - (c.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (c.FStar_Syntax_Syntax.hash_code) - }, wl2)) in - let uu___3 = FStar_Syntax_Util.arrow_formals_comp arrow in - (match uu___3 with - | (formals, c) -> - let rec aux bs bs_terms formals1 wl1 = - match formals1 with - | [] -> - let uu___4 = imitate_comp bs bs_terms c wl1 in - (match uu___4 with - | (c', wl2) -> - let lhs' = FStar_Syntax_Util.arrow bs c' in - let sol = - let uu___5 = - let uu___6 = - FStar_Syntax_Util.abs bs_lhs lhs' - (FStar_Pervasives_Native.Some - (FStar_Syntax_Util.residual_tot - t_res_lhs)) in - (u_lhs, uu___6) in - TERM uu___5 in - let uu___5 = - mk_t_problem wl2 [] orig lhs' rel arrow - FStar_Pervasives_Native.None - "arrow imitation" in - (match uu___5 with - | (sub_prob, wl3) -> - let uu___6 = - let uu___7 = - solve_prob orig - FStar_Pervasives_Native.None - [sol] wl3 in - attempt [sub_prob] uu___7 in - solve uu___6)) - | { FStar_Syntax_Syntax.binder_bv = x; - FStar_Syntax_Syntax.binder_qual = imp; - FStar_Syntax_Syntax.binder_positivity = pqual; - FStar_Syntax_Syntax.binder_attrs = attrs;_}::formals2 - -> - let uu___4 = - let uu___5 = - let uu___6 = FStar_Syntax_Util.type_u () in - FStar_Pervasives_Native.fst uu___6 in - copy_uvar u_lhs - (FStar_Compiler_List.op_At bs_lhs bs) - uu___5 wl1 in - (match uu___4 with - | (_ctx_u_x, u_x, wl2) -> - let y = - let uu___5 = - let uu___6 = - FStar_Syntax_Syntax.range_of_bv x in - FStar_Pervasives_Native.Some uu___6 in - FStar_Syntax_Syntax.new_bv uu___5 u_x in - let b = - FStar_Syntax_Syntax.mk_binder_with_attrs - y imp pqual attrs in - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Syntax_Util.arg_of_non_null_binder - b in - [uu___7] in - FStar_Compiler_List.op_At bs_terms - uu___6 in - aux (FStar_Compiler_List.op_At bs [b]) - uu___5 formals2 wl2) in - let uu___4 = occurs_check u_lhs arrow in - (match uu___4 with - | (uu___5, occurs_ok, msg) -> - if Prims.op_Negation occurs_ok - then - let uu___6 = - mklstr - (fun uu___7 -> - let uu___8 = - FStar_Compiler_Option.get msg in - Prims.strcat "occurs-check failed: " - uu___8) in - giveup_or_defer orig wl - FStar_TypeChecker_Common.Deferred_occur_check_failed - uu___6 - else aux [] [] formals wl)) -and (solve_binders : - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.binders -> - FStar_TypeChecker_Common.prob -> - worklist -> - (worklist -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.subst_elt Prims.list -> - (FStar_TypeChecker_Common.prob * worklist)) - -> solution) - = - fun bs1 -> - fun bs2 -> - fun orig -> - fun wl -> - fun rhs -> - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binder) bs1 in - let uu___3 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binder) bs2 in - FStar_Compiler_Util.print3 "solve_binders\n\t%s\n%s\n\t%s\n" - uu___2 (rel_to_string (p_rel orig)) uu___3 - else ()); - (let eq_bqual a1 a2 = - match (a1, a2) with - | (FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit - b1), FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Implicit b2)) -> true - | uu___1 -> FStar_Syntax_Util.eq_bqual a1 a2 in - let compat_positivity_qualifiers p1 p2 = - match p_rel orig with - | FStar_TypeChecker_Common.EQ -> - FStar_TypeChecker_Common.check_positivity_qual false p1 p2 - | FStar_TypeChecker_Common.SUB -> - FStar_TypeChecker_Common.check_positivity_qual true p1 p2 - | FStar_TypeChecker_Common.SUBINV -> - FStar_TypeChecker_Common.check_positivity_qual true p2 p1 in - let rec aux wl1 scope subst xs ys = - match (xs, ys) with - | ([], []) -> - let uu___1 = rhs wl1 scope subst in - (match uu___1 with - | (rhs_prob, wl2) -> - ((let uu___3 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___3 - then - let uu___4 = - prob_to_string (p_env wl2 rhs_prob) rhs_prob in - FStar_Compiler_Util.print1 "rhs_prob = %s\n" - uu___4 - else ()); - (let formula = p_guard rhs_prob in - ((FStar_Pervasives.Inl ([rhs_prob], formula)), wl2)))) - | (x::xs1, y::ys1) when - (eq_bqual x.FStar_Syntax_Syntax.binder_qual - y.FStar_Syntax_Syntax.binder_qual) - && - (compat_positivity_qualifiers - x.FStar_Syntax_Syntax.binder_positivity - y.FStar_Syntax_Syntax.binder_positivity) - -> - let uu___1 = - ((x.FStar_Syntax_Syntax.binder_bv), - (x.FStar_Syntax_Syntax.binder_qual)) in - (match uu___1 with - | (hd1, imp) -> - let uu___2 = - ((y.FStar_Syntax_Syntax.binder_bv), - (y.FStar_Syntax_Syntax.binder_qual)) in - (match uu___2 with - | (hd2, imp') -> - let hd11 = - let uu___3 = - FStar_Syntax_Subst.subst subst - hd1.FStar_Syntax_Syntax.sort in - { - FStar_Syntax_Syntax.ppname = - (hd1.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (hd1.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = uu___3 - } in - let hd21 = - let uu___3 = - FStar_Syntax_Subst.subst subst - hd2.FStar_Syntax_Syntax.sort in - { - FStar_Syntax_Syntax.ppname = - (hd2.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (hd2.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = uu___3 - } in - let uu___3 = - mk_t_problem wl1 scope orig - hd11.FStar_Syntax_Syntax.sort - (invert_rel (p_rel orig)) - hd21.FStar_Syntax_Syntax.sort - FStar_Pervasives_Native.None - "Formal parameter" in - (match uu___3 with - | (prob, wl2) -> - let hd12 = - FStar_Syntax_Syntax.freshen_bv hd11 in - let subst1 = - let uu___4 = - FStar_Syntax_Subst.shift_subst - Prims.int_one subst in - (FStar_Syntax_Syntax.DB - (Prims.int_zero, hd12)) - :: uu___4 in - let uu___4 = - aux wl2 - (FStar_Compiler_List.op_At scope - [{ - FStar_Syntax_Syntax.binder_bv = - hd12; - FStar_Syntax_Syntax.binder_qual = - (x.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity - = - (x.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs - = - (x.FStar_Syntax_Syntax.binder_attrs) - }]) subst1 xs1 ys1 in - (match uu___4 with - | (FStar_Pervasives.Inl (sub_probs, phi), - wl3) -> - let phi1 = - let uu___5 = - FStar_TypeChecker_Env.close_forall - (p_env wl3 prob) - [{ - FStar_Syntax_Syntax.binder_bv - = hd12; - FStar_Syntax_Syntax.binder_qual - = - (x.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity - = - (x.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs - = - (x.FStar_Syntax_Syntax.binder_attrs) - }] phi in - FStar_Syntax_Util.mk_conj - (p_guard prob) uu___5 in - ((let uu___6 = - FStar_Compiler_Effect.op_Bang - dbg_Rel in - if uu___6 - then - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - phi1 in - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_bv - hd12 in - FStar_Compiler_Util.print2 - "Formula is %s\n\thd1=%s\n" - uu___7 uu___8 - else ()); - ((FStar_Pervasives.Inl - ((prob :: sub_probs), phi1)), - wl3)) - | fail -> fail)))) - | uu___1 -> - ((FStar_Pervasives.Inr - "arity or argument-qualifier mismatch"), wl1) in - let uu___1 = aux wl [] [] bs1 bs2 in - match uu___1 with - | (FStar_Pervasives.Inr msg, wl1) -> giveup_lit wl1 msg orig - | (FStar_Pervasives.Inl (sub_probs, phi), wl1) -> - let wl2 = - solve_prob orig (FStar_Pervasives_Native.Some phi) [] wl1 in - let uu___2 = attempt sub_probs wl2 in solve uu___2) -and (try_solve_without_smt_or_else : - worklist -> - (worklist -> solution) -> - (worklist -> (FStar_TypeChecker_Common.prob * lstring) -> solution) -> - solution) - = - fun wl -> - fun try_solve -> - fun else_solve -> - let wl' = - { - attempting = []; - wl_deferred = - (Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic (FStar_Compiler_CList.listlike_clist ())))); - wl_deferred_to_tac = (wl.wl_deferred_to_tac); - ctr = (wl.ctr); - defer_ok = NoDefer; - smt_ok = false; - umax_heuristic_ok = false; - tcenv = (wl.tcenv); - wl_implicits = - (Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic (FStar_Compiler_CList.listlike_clist ())))); - repr_subcomp_allowed = (wl.repr_subcomp_allowed); - typeclass_variables = (wl.typeclass_variables) - } in - let tx = FStar_Syntax_Unionfind.new_transaction () in - let uu___ = try_solve wl' in - match uu___ with - | Success (uu___1, defer_to_tac, imps) -> - (FStar_Syntax_Unionfind.commit tx; - (let wl1 = - extend_wl wl - (Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic (FStar_Compiler_CList.listlike_clist ())))) - defer_to_tac imps in - solve wl1)) - | Failed (p, s) -> - (FStar_Syntax_Unionfind.rollback tx; else_solve wl (p, s)) -and (try_solve_then_or_else : - worklist -> - (worklist -> solution) -> - (worklist -> solution) -> (worklist -> solution) -> solution) - = - fun wl -> - fun try_solve -> - fun then_solve -> - fun else_solve -> - let empty_wl = - { - attempting = []; - wl_deferred = - (Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic (FStar_Compiler_CList.listlike_clist ())))); - wl_deferred_to_tac = (wl.wl_deferred_to_tac); - ctr = (wl.ctr); - defer_ok = NoDefer; - smt_ok = (wl.smt_ok); - umax_heuristic_ok = (wl.umax_heuristic_ok); - tcenv = (wl.tcenv); - wl_implicits = - (Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic (FStar_Compiler_CList.listlike_clist ())))); - repr_subcomp_allowed = (wl.repr_subcomp_allowed); - typeclass_variables = (wl.typeclass_variables) - } in - let tx = FStar_Syntax_Unionfind.new_transaction () in - let uu___ = try_solve empty_wl in - match uu___ with - | Success (uu___1, defer_to_tac, imps) -> - (FStar_Syntax_Unionfind.commit tx; - (let wl1 = - extend_wl wl - (Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic (FStar_Compiler_CList.listlike_clist ())))) - defer_to_tac imps in - then_solve wl1)) - | Failed (p, s) -> - (FStar_Syntax_Unionfind.rollback tx; else_solve wl) -and (try_solve_probs_without_smt : - worklist -> - (worklist -> (FStar_TypeChecker_Common.probs * worklist)) -> - (worklist, lstring) FStar_Pervasives.either) - = - fun wl -> - fun probs -> - let uu___ = probs wl in - match uu___ with - | (probs1, wl') -> - let wl'1 = - { - attempting = probs1; - wl_deferred = - (Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic (FStar_Compiler_CList.listlike_clist ())))); - wl_deferred_to_tac = (wl.wl_deferred_to_tac); - ctr = (wl.ctr); - defer_ok = NoDefer; - smt_ok = false; - umax_heuristic_ok = false; - tcenv = (wl.tcenv); - wl_implicits = - (Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic (FStar_Compiler_CList.listlike_clist ())))); - repr_subcomp_allowed = (wl.repr_subcomp_allowed); - typeclass_variables = (wl.typeclass_variables) - } in - let uu___1 = solve wl'1 in - (match uu___1 with - | Success (uu___2, defer_to_tac, imps) -> - let wl1 = - extend_wl wl - (Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic (FStar_Compiler_CList.listlike_clist ())))) - defer_to_tac imps in - FStar_Pervasives.Inl wl1 - | Failed (uu___2, ls) -> FStar_Pervasives.Inr ls) -and (solve_t : tprob -> worklist -> solution) = - fun problem -> - fun wl -> - def_check_prob "solve_t" (FStar_TypeChecker_Common.TProb problem); - (let uu___1 = compress_tprob wl problem in solve_t' uu___1 wl) -and (solve_t_flex_rigid_eq : - FStar_TypeChecker_Common.prob -> - worklist -> flex_t -> FStar_Syntax_Syntax.term -> solution) - = - fun orig -> - fun wl -> - fun lhs -> - fun rhs -> - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term rhs in - FStar_Compiler_Util.print1 "solve_t_flex_rigid_eq rhs=%s\n" - uu___2 - else ()); - (let uu___1 = should_defer_flex_to_user_tac wl lhs in - if uu___1 - then defer_to_user_tac orig (flex_reason lhs) wl - else - (let mk_solution env lhs1 bs rhs1 = - let bs_orig = bs in - let rhs_orig = rhs1 in - let uu___3 = lhs1 in - match uu___3 with - | Flex (uu___4, ctx_u, args) -> - let uu___5 = - let bv_not_free_in_arg x arg = - let uu___6 = - let uu___7 = - FStar_Syntax_Free.names - (FStar_Pervasives_Native.fst arg) in - FStar_Class_Setlike.mem () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) x - (Obj.magic uu___7) in - Prims.op_Negation uu___6 in - let bv_not_free_in_args x args1 = - FStar_Compiler_Util.for_all (bv_not_free_in_arg x) - args1 in - let binder_matches_aqual b aq = - match ((b.FStar_Syntax_Syntax.binder_qual), aq) with - | (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None) -> true - | (FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Implicit uu___6), - FStar_Pervasives_Native.Some a) -> - a.FStar_Syntax_Syntax.aqual_implicit && - (FStar_Syntax_Util.eqlist - (fun x -> - fun y -> - let uu___7 = - FStar_TypeChecker_TermEqAndSimplify.eq_tm - env x y in - uu___7 = - FStar_TypeChecker_TermEqAndSimplify.Equal) - b.FStar_Syntax_Syntax.binder_attrs - a.FStar_Syntax_Syntax.aqual_attributes) - | uu___6 -> false in - let rec remove_matching_prefix lhs_binders rhs_args = - match (lhs_binders, rhs_args) with - | ([], uu___6) -> (lhs_binders, rhs_args) - | (uu___6, []) -> (lhs_binders, rhs_args) - | (b::lhs_tl, (t, aq)::rhs_tl) -> - let uu___6 = - let uu___7 = FStar_Syntax_Subst.compress t in - uu___7.FStar_Syntax_Syntax.n in - (match uu___6 with - | FStar_Syntax_Syntax.Tm_name x when - ((FStar_Syntax_Syntax.bv_eq - b.FStar_Syntax_Syntax.binder_bv x) - && (binder_matches_aqual b aq)) - && - (bv_not_free_in_args - b.FStar_Syntax_Syntax.binder_bv rhs_tl) - -> remove_matching_prefix lhs_tl rhs_tl - | uu___7 -> (lhs_binders, rhs_args)) in - let uu___6 = FStar_Syntax_Util.head_and_args rhs1 in - match uu___6 with - | (rhs_hd, rhs_args) -> - let uu___7 = - let uu___8 = - remove_matching_prefix - (FStar_Compiler_List.rev bs_orig) - (FStar_Compiler_List.rev rhs_args) in - match uu___8 with - | (bs_rev, args_rev) -> - ((FStar_Compiler_List.rev bs_rev), - (FStar_Compiler_List.rev args_rev)) in - (match uu___7 with - | (bs1, rhs_args1) -> - let uu___8 = - FStar_Syntax_Syntax.mk_Tm_app rhs_hd - rhs_args1 rhs1.FStar_Syntax_Syntax.pos in - (bs1, uu___8)) in - (match uu___5 with - | (bs1, rhs2) -> - let sol = - match bs1 with - | [] -> rhs2 - | uu___6 -> - let uu___7 = - FStar_Syntax_Util.ctx_uvar_typ ctx_u in - let uu___8 = sn_binders env bs1 in - u_abs uu___7 uu___8 rhs2 in - [TERM (ctx_u, sol)]) in - let try_quasi_pattern orig1 env wl1 lhs1 rhs1 = - (let uu___4 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___4 - then FStar_Compiler_Util.print_string "try_quasi_pattern\n" - else ()); - (let uu___4 = quasi_pattern env lhs1 in - match uu___4 with - | FStar_Pervasives_Native.None -> - ((FStar_Pervasives.Inl "Not a quasi-pattern"), wl1) - | FStar_Pervasives_Native.Some (bs, uu___5) -> - let uu___6 = lhs1 in - (match uu___6 with - | Flex (t_lhs, ctx_u, args) -> - let uu___7 = occurs_check ctx_u rhs1 in - (match uu___7 with - | (uvars, occurs_ok, msg) -> - if Prims.op_Negation occurs_ok - then - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Compiler_Option.get msg in - Prims.strcat - "quasi-pattern, occurs-check failed: " - uu___10 in - FStar_Pervasives.Inl uu___9 in - (uu___8, wl1) - else - (let fvs_lhs = - binders_as_bv_set - (FStar_Compiler_List.op_At - ctx_u.FStar_Syntax_Syntax.ctx_uvar_binders - bs) in - let fvs_rhs = FStar_Syntax_Free.names rhs1 in - let uu___9 = - let uu___10 = - FStar_Class_Setlike.subset () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) - (Obj.magic fvs_rhs) - (Obj.magic fvs_lhs) in - Prims.op_Negation uu___10 in - if uu___9 - then - ((FStar_Pervasives.Inl - "quasi-pattern, free names on the RHS are not included in the LHS"), - wl1) - else - (let uu___11 = - let uu___12 = - mk_solution env lhs1 bs rhs1 in - FStar_Pervasives.Inr uu___12 in - let uu___12 = - restrict_all_uvars env ctx_u [] uvars - wl1 in - (uu___11, uu___12)))))) in - let imitate_app orig1 env wl1 lhs1 bs_lhs t_res_lhs rhs1 = - let uu___3 = FStar_Syntax_Util.head_and_args rhs1 in - match uu___3 with - | (rhs_hd, args) -> - let uu___4 = FStar_Compiler_Util.prefix args in - (match uu___4 with - | (args_rhs, last_arg_rhs) -> - let rhs' = - FStar_Syntax_Syntax.mk_Tm_app rhs_hd args_rhs - rhs1.FStar_Syntax_Syntax.pos in - let uu___5 = lhs1 in - (match uu___5 with - | Flex (t_lhs, u_lhs, _lhs_args) -> - let uu___6 = - let uu___7 = - let env1 = p_env wl1 orig1 in - env1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - { - FStar_TypeChecker_Env.solver = - (env1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - FStar_Pervasives_Native.None; - FStar_TypeChecker_Env.sigtab = - (env1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = true; - FStar_TypeChecker_Env.lax_universes = - (env1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (env1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (env1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (env1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (env1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (env1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (env1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (env1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (env1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (env1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env1.FStar_TypeChecker_Env.missing_decl) - } - (FStar_Pervasives_Native.fst last_arg_rhs) - false in - match uu___7 with - | (t_last_arg, uu___8) -> - let uu___9 = - let b = - FStar_Syntax_Syntax.null_binder - t_last_arg in - let uu___10 = - let uu___11 = - FStar_Syntax_Syntax.mk_Total - t_res_lhs in - FStar_Syntax_Util.arrow [b] uu___11 in - copy_uvar u_lhs - (FStar_Compiler_List.op_At bs_lhs [b]) - uu___10 wl1 in - (match uu___9 with - | (uu___10, lhs', wl2) -> - let uu___11 = - copy_uvar u_lhs bs_lhs t_last_arg - wl2 in - (match uu___11 with - | (uu___12, lhs'_last_arg, wl3) -> - (lhs', lhs'_last_arg, wl3))) in - (match uu___6 with - | (lhs', lhs'_last_arg, wl2) -> - let sol = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Syntax_Syntax.mk_Tm_app - lhs' - [(lhs'_last_arg, - (FStar_Pervasives_Native.snd - last_arg_rhs))] - t_lhs.FStar_Syntax_Syntax.pos in - FStar_Syntax_Util.abs bs_lhs - uu___10 - (FStar_Pervasives_Native.Some - (FStar_Syntax_Util.residual_tot - t_res_lhs)) in - (u_lhs, uu___9) in - TERM uu___8 in - [uu___7] in - let uu___7 = - let uu___8 = - mk_t_problem wl2 [] orig1 lhs' - FStar_TypeChecker_Common.EQ rhs' - FStar_Pervasives_Native.None - "first-order lhs" in - match uu___8 with - | (p1, wl3) -> - let uu___9 = - mk_t_problem wl3 [] orig1 - lhs'_last_arg - FStar_TypeChecker_Common.EQ - (FStar_Pervasives_Native.fst - last_arg_rhs) - FStar_Pervasives_Native.None - "first-order rhs" in - (match uu___9 with - | (p2, wl4) -> ([p1; p2], wl4)) in - (match uu___7 with - | (sub_probs, wl3) -> - let uu___8 = - let uu___9 = - solve_prob orig1 - FStar_Pervasives_Native.None - sol wl3 in - attempt sub_probs uu___9 in - solve uu___8)))) in - let imitate orig1 env wl1 lhs1 rhs1 = - (let uu___4 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___4 - then FStar_Compiler_Util.print_string "imitate\n" - else ()); - (let is_app rhs2 = - let uu___4 = FStar_Syntax_Util.head_and_args rhs2 in - match uu___4 with - | (uu___5, args) -> - (match args with | [] -> false | uu___6 -> true) in - let is_arrow rhs2 = - let uu___4 = - let uu___5 = FStar_Syntax_Subst.compress rhs2 in - uu___5.FStar_Syntax_Syntax.n in - match uu___4 with - | FStar_Syntax_Syntax.Tm_arrow uu___5 -> true - | uu___5 -> false in - let uu___4 = quasi_pattern env lhs1 in - match uu___4 with - | FStar_Pervasives_Native.None -> - let msg = - mklstr - (fun uu___5 -> - let uu___6 = prob_to_string env orig1 in - FStar_Compiler_Util.format1 - "imitate heuristic cannot solve %s; lhs not a quasi-pattern" - uu___6) in - giveup_or_defer orig1 wl1 - FStar_TypeChecker_Common.Deferred_first_order_heuristic_failed - msg - | FStar_Pervasives_Native.Some (bs_lhs, t_res_lhs) -> - let uu___5 = is_app rhs1 in - if uu___5 - then - imitate_app orig1 env wl1 lhs1 bs_lhs t_res_lhs rhs1 - else - (let uu___7 = is_arrow rhs1 in - if uu___7 - then - imitate_arrow orig1 wl1 lhs1 bs_lhs t_res_lhs - FStar_TypeChecker_Common.EQ rhs1 - else - (let msg = - mklstr - (fun uu___9 -> - let uu___10 = prob_to_string env orig1 in - FStar_Compiler_Util.format1 - "imitate heuristic cannot solve %s; rhs not an app or arrow" - uu___10) in - giveup_or_defer orig1 wl1 - FStar_TypeChecker_Common.Deferred_first_order_heuristic_failed - msg))) in - let try_first_order orig1 env wl1 lhs1 rhs1 = - let inapplicable msg lstring_opt = - (let uu___4 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___4 - then - let extra_msg = - match lstring_opt with - | FStar_Pervasives_Native.None -> "" - | FStar_Pervasives_Native.Some l -> - FStar_Thunk.force l in - FStar_Compiler_Util.print2 - "try_first_order failed because: %s\n%s\n" msg - extra_msg - else ()); - FStar_Pervasives.Inl "first_order doesn't apply" in - (let uu___4 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___4 - then - let uu___5 = flex_t_to_string lhs1 in - let uu___6 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - rhs1 in - FStar_Compiler_Util.print2 - "try_first_order\n\tlhs=%s\n\trhs=%s\n" uu___5 uu___6 - else ()); - (let uu___4 = lhs1 in - match uu___4 with - | Flex (_t1, ctx_uv, args_lhs) -> - let n_args_lhs = FStar_Compiler_List.length args_lhs in - let uu___5 = FStar_Syntax_Util.head_and_args rhs1 in - (match uu___5 with - | (head, args_rhs) -> - let n_args_rhs = - FStar_Compiler_List.length args_rhs in - if n_args_lhs > n_args_rhs - then - inapplicable "not enough args" - FStar_Pervasives_Native.None - else - (let i = n_args_rhs - n_args_lhs in - let uu___7 = - FStar_Compiler_List.splitAt i args_rhs in - match uu___7 with - | (prefix, args_rhs1) -> - let head1 = - FStar_Syntax_Syntax.mk_Tm_app head prefix - head.FStar_Syntax_Syntax.pos in - let uu___8 = occurs_check ctx_uv head1 in - (match uu___8 with - | (uvars_head, occurs_ok, uu___9) -> - if Prims.op_Negation occurs_ok - then - inapplicable "occurs check failed" - FStar_Pervasives_Native.None - else - (let uu___11 = - let uu___12 = - let uu___13 = - FStar_Syntax_Free.names head1 in - let uu___14 = - binders_as_bv_set - ctx_uv.FStar_Syntax_Syntax.ctx_uvar_binders in - FStar_Class_Setlike.subset () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) - (Obj.magic uu___13) - (Obj.magic uu___14) in - Prims.op_Negation uu___12 in - if uu___11 - then - inapplicable - "free name inclusion failed" - FStar_Pervasives_Native.None - else - (let uu___13 = - env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - { - FStar_TypeChecker_Env.solver - = - (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range - = - (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule - = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma - = - (env.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig - = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache - = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules - = - (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ - = - FStar_Pervasives_Native.None; - FStar_TypeChecker_Env.sigtab - = - (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab - = - (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp - = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects - = - (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize - = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs - = - (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level - = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars - = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict - = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface - = - (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit - = true; - FStar_TypeChecker_Env.lax_universes - = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 - = - (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard - = - (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking - = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping - = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics - = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce - = - (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term - = - (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of - = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force - = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths - = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns - = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook - = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice - = - (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess - = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess - = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info - = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks - = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv - = - (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab - = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check - = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl - = - (env.FStar_TypeChecker_Env.missing_decl) - } head1 false in - match uu___13 with - | (t_head, uu___14) -> - let tx = - FStar_Syntax_Unionfind.new_transaction - () in - let solve_sub_probs_if_head_types_equal - head_uvars_to_restrict wl2 - = - let sol = - [TERM (ctx_uv, head1)] in - let wl3 = - restrict_all_uvars env - ctx_uv [] - head_uvars_to_restrict - wl2 in - let wl4 = - solve_prob orig1 - FStar_Pervasives_Native.None - sol wl3 in - let uu___15 = - FStar_Compiler_List.fold_left2 - (fun uu___16 -> - fun uu___17 -> - fun uu___18 -> - match (uu___16, - uu___17, - uu___18) - with - | ((probs, wl5), - (arg_lhs, - uu___19), - (arg_rhs, - uu___20)) -> - let uu___21 - = - mk_t_problem - wl5 [] - orig1 - arg_lhs - FStar_TypeChecker_Common.EQ - arg_rhs - FStar_Pervasives_Native.None - "first-order arg" in - (match uu___21 - with - | (p, wl6) - -> - ((p :: - probs), - wl6))) - ([], wl4) args_lhs - args_rhs1 in - match uu___15 with - | (sub_probs, wl5) -> - let wl' = - { - attempting = - sub_probs; - wl_deferred = - (Obj.magic - (FStar_Class_Listlike.empty - () - (Obj.magic - (FStar_Compiler_CList.listlike_clist - ())))); - wl_deferred_to_tac - = - (wl5.wl_deferred_to_tac); - ctr = (wl5.ctr); - defer_ok = NoDefer; - smt_ok = false; - umax_heuristic_ok = - (wl5.umax_heuristic_ok); - tcenv = (wl5.tcenv); - wl_implicits = - (Obj.magic - (FStar_Class_Listlike.empty - () - (Obj.magic - (FStar_Compiler_CList.listlike_clist - ())))); - repr_subcomp_allowed - = - (wl5.repr_subcomp_allowed); - typeclass_variables - = - (wl5.typeclass_variables) - } in - let uu___16 = solve wl' in - (match uu___16 with - | Success - (uu___17, - defer_to_tac, - imps) - -> - let wl6 = - extend_wl wl5 - (Obj.magic - (FStar_Class_Listlike.empty - () - (Obj.magic - (FStar_Compiler_CList.listlike_clist - ())))) - defer_to_tac - imps in - (FStar_Syntax_Unionfind.commit - tx; - FStar_Pervasives.Inr - wl6) - | Failed - (uu___17, - lstring1) - -> - (FStar_Syntax_Unionfind.rollback - tx; - inapplicable - "Subprobs failed: " - (FStar_Pervasives_Native.Some - lstring1))) in - let uu___15 = - let uu___16 = - let uu___17 = - FStar_Syntax_Util.ctx_uvar_typ - ctx_uv in - FStar_TypeChecker_TermEqAndSimplify.eq_tm - env t_head uu___17 in - uu___16 = - FStar_TypeChecker_TermEqAndSimplify.Equal in - if uu___15 - then - solve_sub_probs_if_head_types_equal - uvars_head wl1 - else - ((let uu___18 = - FStar_Compiler_Effect.op_Bang - dbg_Rel in - if uu___18 - then - let uu___19 = - let uu___20 = - FStar_Syntax_Util.ctx_uvar_typ - ctx_uv in - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - uu___20 in - let uu___20 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t_head in - FStar_Compiler_Util.print2 - "first-order: head type mismatch:\n\tlhs=%s\n\trhs=%s\n" - uu___19 uu___20 - else ()); - (let typ_equality_prob wl2 - = - let uu___18 = - let uu___19 = - FStar_Syntax_Util.ctx_uvar_typ - ctx_uv in - mk_t_problem wl2 [] - orig1 uu___19 - FStar_TypeChecker_Common.EQ - t_head - FStar_Pervasives_Native.None - "first-order head type" in - match uu___18 with - | (p, wl3) -> - ([p], wl3) in - let uu___18 = - try_solve_probs_without_smt - wl1 typ_equality_prob in - match uu___18 with - | FStar_Pervasives.Inl - wl2 -> - let uu___19 = - let uu___20 = - FStar_Syntax_Free.uvars - head1 in - FStar_Class_Setlike.elems - () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) - (Obj.magic - uu___20) in - solve_sub_probs_if_head_types_equal - uu___19 wl2 - | FStar_Pervasives.Inr - msg -> - (FStar_Syntax_Unionfind.rollback - tx; - inapplicable - "first-order: head type mismatch" - (FStar_Pervasives_Native.Some - msg)))))))))) in - match p_rel orig with - | FStar_TypeChecker_Common.SUB -> - if wl.defer_ok = DeferAny - then - let uu___3 = FStar_Thunk.mkv "flex-rigid subtyping" in - giveup_or_defer orig wl - FStar_TypeChecker_Common.Deferred_flex uu___3 - else solve_t_flex_rigid_eq (make_prob_eq orig) wl lhs rhs - | FStar_TypeChecker_Common.SUBINV -> - if wl.defer_ok = DeferAny - then - let uu___3 = FStar_Thunk.mkv "flex-rigid subtyping" in - giveup_or_defer orig wl - FStar_TypeChecker_Common.Deferred_flex uu___3 - else solve_t_flex_rigid_eq (make_prob_eq orig) wl lhs rhs - | FStar_TypeChecker_Common.EQ -> - let uu___3 = lhs in - (match uu___3 with - | Flex (_t1, ctx_uv, args_lhs) -> - let env = p_env wl orig in - let uu___4 = - pat_vars env - ctx_uv.FStar_Syntax_Syntax.ctx_uvar_binders - args_lhs in - (match uu___4 with - | FStar_Pervasives_Native.Some lhs_binders -> - ((let uu___6 = - FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___6 - then - FStar_Compiler_Util.print_string - "it's a pattern\n" - else ()); - (let rhs1 = sn env rhs in - let fvs1 = - binders_as_bv_set - (FStar_Compiler_List.op_At - ctx_uv.FStar_Syntax_Syntax.ctx_uvar_binders - lhs_binders) in - let fvs2 = FStar_Syntax_Free.names rhs1 in - let uu___6 = occurs_check ctx_uv rhs1 in - match uu___6 with - | (uvars, occurs_ok, msg) -> - let uu___7 = - if occurs_ok - then ((uvars, occurs_ok, msg), rhs1) - else - (let rhs2 = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.Weak; - FStar_TypeChecker_Env.HNF; - FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.Unascribe] - (p_env wl orig) rhs1 in - let uu___9 = occurs_check ctx_uv rhs2 in - (uu___9, rhs2)) in - (match uu___7 with - | ((uvars1, occurs_ok1, msg1), rhs2) -> - let uu___8 = - (term_is_uvar ctx_uv rhs2) && - (Prims.uu___is_Nil args_lhs) in - if uu___8 - then - let uu___9 = - solve_prob orig - FStar_Pervasives_Native.None [] - wl in - solve uu___9 - else - if Prims.op_Negation occurs_ok1 - then - (let uu___10 = - let uu___11 = - let uu___12 = - FStar_Compiler_Option.get - msg1 in - Prims.strcat - "occurs-check failed: " - uu___12 in - FStar_Thunk.mkv uu___11 in - giveup_or_defer orig wl - FStar_TypeChecker_Common.Deferred_occur_check_failed - uu___10) - else - (let uu___11 = - FStar_Class_Setlike.subset () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) - (Obj.magic fvs2) - (Obj.magic fvs1) in - if uu___11 - then - let sol = - mk_solution env lhs - lhs_binders rhs2 in - let wl1 = - restrict_all_uvars env ctx_uv - lhs_binders uvars1 wl in - let uu___12 = - solve_prob orig - FStar_Pervasives_Native.None - sol wl1 in - solve uu___12 - else - if wl.defer_ok = DeferAny - then - (let msg2 = - mklstr - (fun uu___13 -> - let uu___14 = - FStar_Class_Show.show - (FStar_Compiler_FlatSet.showable_set - FStar_Syntax_Syntax.ord_bv - FStar_Syntax_Print.showable_bv) - fvs2 in - let uu___15 = - FStar_Class_Show.show - (FStar_Compiler_FlatSet.showable_set - FStar_Syntax_Syntax.ord_bv - FStar_Syntax_Print.showable_bv) - fvs1 in - let uu___16 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binder) - (FStar_Compiler_List.op_At - ctx_uv.FStar_Syntax_Syntax.ctx_uvar_binders - lhs_binders) in - FStar_Compiler_Util.format3 - "free names in the RHS {%s} are out of scope for the LHS: {%s}, {%s}" - uu___14 uu___15 - uu___16) in - giveup_or_defer orig wl - FStar_TypeChecker_Common.Deferred_free_names_check_failed - msg2) - else - imitate orig env wl lhs rhs2)))) - | uu___5 -> - if wl.defer_ok = DeferAny - then - let uu___6 = FStar_Thunk.mkv "Not a pattern" in - giveup_or_defer orig wl - FStar_TypeChecker_Common.Deferred_not_a_pattern - uu___6 - else - (let uu___7 = - try_first_order orig env wl lhs rhs in - match uu___7 with - | FStar_Pervasives.Inr wl1 -> solve wl1 - | uu___8 -> - let uu___9 = - try_quasi_pattern orig env wl lhs rhs in - (match uu___9 with - | (FStar_Pervasives.Inr sol, wl1) -> - let uu___10 = - solve_prob orig - FStar_Pervasives_Native.None sol - wl1 in - solve uu___10 - | (FStar_Pervasives.Inl msg, uu___10) -> - imitate orig env wl lhs rhs)))))) -and (solve_t_flex_flex : - FStar_TypeChecker_Env.env_t -> - FStar_TypeChecker_Common.prob -> worklist -> flex_t -> flex_t -> solution) - = - fun env -> - fun orig -> - fun wl -> - fun lhs -> - fun rhs -> - let should_run_meta_arg_tac flex = - let uv = flex_uvar flex in - ((flex_uvar_has_meta_tac uv) && - (let uu___ = - let uu___1 = FStar_Syntax_Util.ctx_uvar_typ uv in - has_free_uvars uu___1 in - Prims.op_Negation uu___)) - && - (let uu___ = - gamma_has_free_uvars uv.FStar_Syntax_Syntax.ctx_uvar_gamma in - Prims.op_Negation uu___) in - let run_meta_arg_tac_and_try_again flex = - let uv = flex_uvar flex in - let t = run_meta_arg_tac env uv in - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_ctxu uv in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.print2 - "solve_t_flex_flex: solving meta arg uvar %s with %s\n" - uu___2 uu___3 - else ()); - set_uvar env uv FStar_Pervasives_Native.None t; - (let uu___2 = attempt [orig] wl in solve uu___2) in - match p_rel orig with - | FStar_TypeChecker_Common.SUB -> - if wl.defer_ok = DeferAny - then - let uu___ = FStar_Thunk.mkv "flex-flex subtyping" in - giveup_or_defer_flex_flex orig wl - FStar_TypeChecker_Common.Deferred_flex uu___ - else solve_t_flex_flex env (make_prob_eq orig) wl lhs rhs - | FStar_TypeChecker_Common.SUBINV -> - if wl.defer_ok = DeferAny - then - let uu___ = FStar_Thunk.mkv "flex-flex subtyping" in - giveup_or_defer_flex_flex orig wl - FStar_TypeChecker_Common.Deferred_flex uu___ - else solve_t_flex_flex env (make_prob_eq orig) wl lhs rhs - | FStar_TypeChecker_Common.EQ -> - let uu___ = - (should_defer_flex_to_user_tac wl lhs) || - (should_defer_flex_to_user_tac wl rhs) in - if uu___ - then - defer_to_user_tac orig - (Prims.strcat (flex_reason lhs) - (Prims.strcat ", " (flex_reason rhs))) wl - else - if - ((wl.defer_ok = DeferAny) || - (wl.defer_ok = DeferFlexFlexOnly)) - && - ((Prims.op_Negation (is_flex_pat lhs)) || - (Prims.op_Negation (is_flex_pat rhs))) - then - (let uu___2 = FStar_Thunk.mkv "flex-flex non-pattern" in - giveup_or_defer_flex_flex orig wl - FStar_TypeChecker_Common.Deferred_flex_flex_nonpattern - uu___2) - else - (let uu___3 = should_run_meta_arg_tac lhs in - if uu___3 - then run_meta_arg_tac_and_try_again lhs - else - (let uu___5 = should_run_meta_arg_tac rhs in - if uu___5 - then run_meta_arg_tac_and_try_again rhs - else - (let rec occurs_bs u bs = - match bs with - | [] -> false - | b::bs1 -> - (let uu___7 = - occurs u - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - FStar_Pervasives_Native.snd uu___7) || - (occurs_bs u bs1) in - let uu___7 = - let uu___8 = quasi_pattern env lhs in - let uu___9 = quasi_pattern env rhs in - (uu___8, uu___9) in - match uu___7 with - | (FStar_Pervasives_Native.Some - (binders_lhs, t_res_lhs), - FStar_Pervasives_Native.Some - (binders_rhs, t_res_rhs)) -> - let uu___8 = lhs in - (match uu___8 with - | Flex - ({ FStar_Syntax_Syntax.n = uu___9; - FStar_Syntax_Syntax.pos = range; - FStar_Syntax_Syntax.vars = uu___10; - FStar_Syntax_Syntax.hash_code = - uu___11;_}, - u_lhs, uu___12) - -> - let uu___13 = occurs_bs u_lhs binders_lhs in - if uu___13 - then - let uu___14 = - FStar_Thunk.mkv - "flex-flex: occurs check failed on the LHS flex quasi-pattern" in - giveup_or_defer orig wl - FStar_TypeChecker_Common.Deferred_flex_flex_nonpattern - uu___14 - else - (let uu___15 = rhs in - match uu___15 with - | Flex (uu___16, u_rhs, uu___17) -> - let uu___18 = - (FStar_Syntax_Unionfind.equiv - u_lhs.FStar_Syntax_Syntax.ctx_uvar_head - u_rhs.FStar_Syntax_Syntax.ctx_uvar_head) - && - (binders_eq binders_lhs - binders_rhs) in - if uu___18 - then - let uu___19 = - solve_prob orig - FStar_Pervasives_Native.None - [] wl in - solve uu___19 - else - (let uu___20 = - maximal_prefix - u_lhs.FStar_Syntax_Syntax.ctx_uvar_binders - u_rhs.FStar_Syntax_Syntax.ctx_uvar_binders in - match uu___20 with - | (ctx_w, (ctx_l, ctx_r)) -> - let gamma_w = - gamma_until - u_lhs.FStar_Syntax_Syntax.ctx_uvar_gamma - ctx_w in - let zs = - intersect_binders gamma_w - (FStar_Compiler_List.op_At - ctx_l binders_lhs) - (FStar_Compiler_List.op_At - ctx_r binders_rhs) in - let new_uvar_typ = - let uu___21 = - FStar_Syntax_Syntax.mk_Total - t_res_lhs in - FStar_Syntax_Util.arrow - zs uu___21 in - let uu___21 = - (let uu___22 = - occurs u_lhs - new_uvar_typ in - FStar_Pervasives_Native.snd - uu___22) - || - ((let uu___22 = - FStar_Syntax_Unionfind.equiv - u_lhs.FStar_Syntax_Syntax.ctx_uvar_head - u_rhs.FStar_Syntax_Syntax.ctx_uvar_head in - Prims.op_Negation - uu___22) - && - (let uu___22 = - occurs u_rhs - new_uvar_typ in - FStar_Pervasives_Native.snd - uu___22)) in - if uu___21 - then - let uu___22 = - let uu___23 = - let uu___24 = - FStar_Class_Show.show - uu___0 - wl.defer_ok in - FStar_Compiler_Util.format1 - "flex-flex: occurs\n defer_ok=%s\n" - uu___24 in - FStar_Thunk.mkv uu___23 in - giveup_or_defer_flex_flex - orig wl - FStar_TypeChecker_Common.Deferred_flex_flex_nonpattern - uu___22 - else - (let uu___23 = - let uu___24 = - let uu___25 = - FStar_Syntax_Util.ctx_uvar_should_check - u_lhs in - let uu___26 = - FStar_Syntax_Util.ctx_uvar_should_check - u_rhs in - (uu___25, uu___26) in - match uu___24 with - | (FStar_Syntax_Syntax.Allow_untyped - r, - FStar_Syntax_Syntax.Allow_untyped - uu___25) -> - ((FStar_Syntax_Syntax.Allow_untyped - r), false) - | (FStar_Syntax_Syntax.Allow_ghost - r, uu___25) -> - ((FStar_Syntax_Syntax.Allow_ghost - r), true) - | (uu___25, - FStar_Syntax_Syntax.Allow_ghost - r) -> - ((FStar_Syntax_Syntax.Allow_ghost - r), true) - | uu___25 -> - (FStar_Syntax_Syntax.Strict, - false) in - match uu___23 with - | (new_uvar_should_check, - is_ghost) -> - let uu___24 = - new_uvar - (Prims.strcat - "flex-flex quasi:" - (Prims.strcat - "\tlhs=" - (Prims.strcat - u_lhs.FStar_Syntax_Syntax.ctx_uvar_reason - (Prims.strcat - "\trhs=" - u_rhs.FStar_Syntax_Syntax.ctx_uvar_reason)))) - wl range gamma_w - ctx_w - new_uvar_typ - new_uvar_should_check - (if - FStar_Pervasives_Native.uu___is_Some - u_lhs.FStar_Syntax_Syntax.ctx_uvar_meta - then - u_lhs.FStar_Syntax_Syntax.ctx_uvar_meta - else - u_rhs.FStar_Syntax_Syntax.ctx_uvar_meta) in - (match uu___24 with - | (uu___25, w, wl1) - -> - let w_app = - let uu___26 = - FStar_Compiler_List.map - ( - fun - uu___27 - -> - match uu___27 - with - | - { - FStar_Syntax_Syntax.binder_bv - = z; - FStar_Syntax_Syntax.binder_qual - = uu___28; - FStar_Syntax_Syntax.binder_positivity - = uu___29; - FStar_Syntax_Syntax.binder_attrs - = uu___30;_} - -> - let uu___31 - = - FStar_Syntax_Syntax.bv_to_name - z in - FStar_Syntax_Syntax.as_arg - uu___31) - zs in - FStar_Syntax_Syntax.mk_Tm_app - w uu___26 - w.FStar_Syntax_Syntax.pos in - ((let uu___27 = - FStar_Compiler_Effect.op_Bang - dbg_Rel in - if uu___27 - then - let uu___28 - = - let uu___29 - = - flex_t_to_string - lhs in - let uu___30 - = - let uu___31 - = - flex_t_to_string - rhs in - let uu___32 - = - let uu___33 - = - term_to_string - w in - let uu___34 - = - let uu___35 - = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binder) - (FStar_Compiler_List.op_At - ctx_l - binders_lhs) in - let uu___36 - = - let uu___37 - = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binder) - (FStar_Compiler_List.op_At - ctx_r - binders_rhs) in - let uu___38 - = - let uu___39 - = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binder) - zs in - [uu___39] in - uu___37 - :: - uu___38 in - uu___35 - :: - uu___36 in - uu___33 - :: - uu___34 in - uu___31 - :: - uu___32 in - uu___29 - :: - uu___30 in - FStar_Compiler_Util.print - "flex-flex quasi:\n\tlhs=%s\n\trhs=%s\n\tsol=%s\n\tctx_l@binders_lhs=%s\n\tctx_r@binders_rhs=%s\n\tzs=%s\n" - uu___28 - else ()); - (let rc = - if is_ghost - then - FStar_Syntax_Util.residual_gtot - t_res_lhs - else - FStar_Syntax_Util.residual_tot - t_res_lhs in - let s1_sol = - FStar_Syntax_Util.abs - binders_lhs - w_app - ( - FStar_Pervasives_Native.Some - rc) in - let s1 = - TERM - (u_lhs, - s1_sol) in - let uu___27 = - FStar_Syntax_Unionfind.equiv - u_lhs.FStar_Syntax_Syntax.ctx_uvar_head - u_rhs.FStar_Syntax_Syntax.ctx_uvar_head in - if uu___27 - then - let uu___28 - = - solve_prob - orig - FStar_Pervasives_Native.None - [s1] wl1 in - solve - uu___28 - else - (let s2_sol - = - FStar_Syntax_Util.abs - binders_rhs - w_app - (FStar_Pervasives_Native.Some - rc) in - let s2 = - TERM - (u_rhs, - s2_sol) in - let uu___29 - = - solve_prob - orig - FStar_Pervasives_Native.None - [s1; s2] - wl1 in - solve - uu___29)))))))) - | uu___8 -> - let uu___9 = - FStar_Thunk.mkv "flex-flex: non-patterns" in - giveup_or_defer orig wl - FStar_TypeChecker_Common.Deferred_flex_flex_nonpattern - uu___9))) -and (solve_t' : tprob -> worklist -> solution) = - fun problem -> - fun wl -> - def_check_prob "solve_t'.1" (FStar_TypeChecker_Common.TProb problem); - (let giveup_or_defer1 orig msg = giveup_or_defer orig wl msg in - let rigid_heads_match need_unif torig wl1 t1 t2 = - let orig = FStar_TypeChecker_Common.TProb torig in - let env = p_env wl1 orig in - (let uu___2 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___2 - then - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - let uu___4 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t1 in - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t2 in - let uu___6 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t2 in - FStar_Compiler_Util.print5 "Heads %s: %s (%s) and %s (%s)\n" - (if need_unif then "need unification" else "match") uu___3 - uu___4 uu___5 uu___6 - else ()); - (let uu___2 = FStar_Syntax_Util.head_and_args t1 in - match uu___2 with - | (head1, args1) -> - let uu___3 = FStar_Syntax_Util.head_and_args t2 in - (match uu___3 with - | (head2, args2) -> - let need_unif1 = - match (((head1.FStar_Syntax_Syntax.n), args1), - ((head2.FStar_Syntax_Syntax.n), args2)) - with - | ((FStar_Syntax_Syntax.Tm_uinst (uu___4, us1), - uu___5::uu___6), - (FStar_Syntax_Syntax.Tm_uinst (uu___7, us2), - uu___8::uu___9)) -> - let uu___10 = - (FStar_Compiler_List.for_all - (fun u -> - let uu___11 = universe_has_max env u in - Prims.op_Negation uu___11) us1) - && - (FStar_Compiler_List.for_all - (fun u -> - let uu___11 = universe_has_max env u in - Prims.op_Negation uu___11) us2) in - if uu___10 then need_unif else true - | uu___4 -> need_unif in - let solve_head_then wl2 k = - if need_unif1 - then k true wl2 - else - (let uu___5 = solve_maybe_uinsts orig head1 head2 wl2 in - match uu___5 with - | USolved wl3 -> k true wl3 - | UFailed msg -> giveup wl2 msg orig - | UDeferred wl3 -> - let uu___6 = - defer_lit - FStar_TypeChecker_Common.Deferred_univ_constraint - "universe constraints" orig wl3 in - k false uu___6) in - let nargs = FStar_Compiler_List.length args1 in - if nargs <> (FStar_Compiler_List.length args2) - then - let uu___4 = - mklstr - (fun uu___5 -> - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head1 in - let uu___7 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - (FStar_Class_Show.show_tuple2 - FStar_Syntax_Print.showable_term - FStar_Syntax_Print.showable_aqual)) - args1 in - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head2 in - let uu___9 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - (FStar_Class_Show.show_tuple2 - FStar_Syntax_Print.showable_term - FStar_Syntax_Print.showable_aqual)) - args2 in - FStar_Compiler_Util.format4 - "unequal number of arguments: %s[%s] and %s[%s]" - uu___6 uu___7 uu___8 uu___9) in - giveup wl1 uu___4 orig - else - (let uu___5 = - (nargs = Prims.int_zero) || - (let uu___6 = - FStar_TypeChecker_TermEqAndSimplify.eq_args env - args1 args2 in - uu___6 = FStar_TypeChecker_TermEqAndSimplify.Equal) in - if uu___5 - then - (if need_unif1 - then - solve_t - { - FStar_TypeChecker_Common.pid = - (problem.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = head1; - FStar_TypeChecker_Common.relation = - (problem.FStar_TypeChecker_Common.relation); - FStar_TypeChecker_Common.rhs = head2; - FStar_TypeChecker_Common.element = - (problem.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (problem.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (problem.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (problem.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = - (problem.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = - (problem.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = - (problem.FStar_TypeChecker_Common.logical) - } wl1 - else - solve_head_then wl1 - (fun ok -> - fun wl2 -> - if ok - then - let uu___7 = - solve_prob orig - FStar_Pervasives_Native.None [] wl2 in - solve uu___7 - else solve wl2)) - else - (let uu___7 = base_and_refinement env t1 in - match uu___7 with - | (base1, refinement1) -> - let uu___8 = base_and_refinement env t2 in - (match uu___8 with - | (base2, refinement2) -> - (match (refinement1, refinement2) with - | (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None) -> - let mk_sub_probs wl2 = - let argp = - if need_unif1 - then - FStar_Compiler_List.zip - ((head1, - FStar_Pervasives_Native.None) - :: args1) - ((head2, - FStar_Pervasives_Native.None) - :: args2) - else - FStar_Compiler_List.zip args1 - args2 in - let uu___9 = - FStar_Compiler_List.fold_right - (fun uu___10 -> - fun uu___11 -> - match (uu___10, uu___11) - with - | (((a1, uu___12), - (a2, uu___13)), - (probs, wl3)) -> - let uu___14 = - mk_problem wl3 [] - orig a1 - FStar_TypeChecker_Common.EQ - a2 - FStar_Pervasives_Native.None - "index" in - (match uu___14 with - | (prob', wl4) -> - (((FStar_TypeChecker_Common.TProb - prob') :: - probs), wl4))) - argp ([], wl2) in - match uu___9 with - | (subprobs, wl3) -> - ((let uu___11 = - FStar_Compiler_Effect.op_Bang - dbg_Rel in - if uu___11 - then - let uu___12 = - FStar_Compiler_Util.string_of_bool - wl3.smt_ok in - let uu___13 = - (FStar_Common.string_of_list - ()) - (prob_to_string env) - subprobs in - FStar_Compiler_Util.print2 - "Adding subproblems for arguments (smtok=%s): %s" - uu___12 uu___13 - else ()); - (let uu___12 = - FStar_Options.defensive () in - if uu___12 - then - FStar_Compiler_List.iter - (def_check_prob - "solve_t' subprobs") - subprobs - else ()); - (subprobs, wl3)) in - let solve_sub_probs env1 wl2 = - solve_head_then wl2 - (fun ok -> - fun wl3 -> - if Prims.op_Negation ok - then solve wl3 - else - (let uu___10 = - mk_sub_probs wl3 in - match uu___10 with - | (subprobs, wl4) -> - let formula = - let uu___11 = - FStar_Compiler_List.map - (fun p -> - p_guard p) - subprobs in - FStar_Syntax_Util.mk_conj_l - uu___11 in - let wl5 = - solve_prob orig - (FStar_Pervasives_Native.Some - formula) [] wl4 in - let uu___11 = - attempt subprobs wl5 in - solve uu___11)) in - let solve_sub_probs_no_smt wl2 = - solve_head_then wl2 - (fun ok -> - fun wl3 -> - let uu___9 = mk_sub_probs wl3 in - match uu___9 with - | (subprobs, wl4) -> - let formula = - let uu___10 = - FStar_Compiler_List.map - (fun p -> p_guard p) - subprobs in - FStar_Syntax_Util.mk_conj_l - uu___10 in - let wl5 = - solve_prob orig - (FStar_Pervasives_Native.Some - formula) [] wl4 in - let uu___10 = - attempt subprobs wl5 in - solve uu___10) in - let unfold_and_retry d wl2 uu___9 = - match uu___9 with - | (prob, reason) -> - ((let uu___11 = - FStar_Compiler_Effect.op_Bang - dbg_Rel in - if uu___11 - then - let uu___12 = - prob_to_string env orig in - let uu___13 = - FStar_Thunk.force reason in - FStar_Compiler_Util.print2 - "Failed to solve %s because a sub-problem is not solvable without SMT because %s" - uu___12 uu___13 - else ()); - (let env1 = p_env wl2 prob in - let uu___11 = - let uu___12 = - FStar_TypeChecker_Normalize.unfold_head_once - env1 t1 in - let uu___13 = - FStar_TypeChecker_Normalize.unfold_head_once - env1 t2 in - (uu___12, uu___13) in - match uu___11 with - | (FStar_Pervasives_Native.Some - t1', - FStar_Pervasives_Native.Some - t2') -> - let uu___12 = - FStar_Syntax_Util.head_and_args - t1' in - (match uu___12 with - | (head1', uu___13) -> - let uu___14 = - FStar_Syntax_Util.head_and_args - t2' in - (match uu___14 with - | (head2', uu___15) - -> - let uu___16 = - let uu___17 = - FStar_TypeChecker_TermEqAndSimplify.eq_tm - env1 - head1' - head1 in - let uu___18 = - FStar_TypeChecker_TermEqAndSimplify.eq_tm - env1 - head2' - head2 in - (uu___17, - uu___18) in - (match uu___16 - with - | (FStar_TypeChecker_TermEqAndSimplify.Equal, - FStar_TypeChecker_TermEqAndSimplify.Equal) - -> - ((let uu___18 - = - FStar_Compiler_Effect.op_Bang - dbg_Rel in - if - uu___18 - then - let uu___19 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t1 in - let uu___20 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t1' in - let uu___21 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t2 in - let uu___22 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t2' in - FStar_Compiler_Util.print4 - "Unfolding didn't make progress ... got %s ~> %s;\nand %s ~> %s\n" - uu___19 - uu___20 - uu___21 - uu___22 - else ()); - solve_sub_probs - env1 wl2) - | uu___17 -> - let torig' - = - { - FStar_TypeChecker_Common.pid - = - (torig.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs - = t1'; - FStar_TypeChecker_Common.relation - = - (torig.FStar_TypeChecker_Common.relation); - FStar_TypeChecker_Common.rhs - = t2'; - FStar_TypeChecker_Common.element - = - (torig.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard - = - (torig.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar - = - (torig.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason - = - (torig.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc - = - (torig.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank - = - (torig.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical - = - (torig.FStar_TypeChecker_Common.logical) - } in - ((let uu___19 - = - FStar_Compiler_Effect.op_Bang - dbg_Rel in - if - uu___19 - then - let uu___20 - = - prob_to_string - env1 - (FStar_TypeChecker_Common.TProb - torig') in - FStar_Compiler_Util.print1 - "Unfolded and now trying %s\n" - uu___20 - else ()); - solve_t - torig' - wl2)))) - | uu___12 -> - solve_sub_probs env1 wl2)) in - let d = - let uu___9 = - FStar_TypeChecker_Env.delta_depth_of_term - env head1 in - FStar_TypeChecker_Common.decr_delta_depth - uu___9 in - let treat_as_injective = - let uu___9 = - let uu___10 = - FStar_Syntax_Util.un_uinst head1 in - uu___10.FStar_Syntax_Syntax.n in - match uu___9 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - FStar_TypeChecker_Env.fv_has_attr - env fv - FStar_Parser_Const.unifier_hint_injective_lid - | uu___10 -> false in - (match d with - | FStar_Pervasives_Native.Some d1 - when - wl1.smt_ok && - (Prims.op_Negation - treat_as_injective) - -> - try_solve_without_smt_or_else wl1 - solve_sub_probs_no_smt - (unfold_and_retry d1) - | uu___9 -> solve_sub_probs env wl1) - | uu___9 -> - let lhs = - force_refinement - (base1, refinement1) in - let rhs = - force_refinement - (base2, refinement2) in - solve_t' - { - FStar_TypeChecker_Common.pid = - (problem.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = lhs; - FStar_TypeChecker_Common.relation - = - (problem.FStar_TypeChecker_Common.relation); - FStar_TypeChecker_Common.rhs = rhs; - FStar_TypeChecker_Common.element = - (problem.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard - = - (problem.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar - = - (problem.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (problem.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = - (problem.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = - (problem.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = - (problem.FStar_TypeChecker_Common.logical) - } wl1)))))) in - let try_match_heuristic orig wl1 s1 s2 t1t2_opt = - let env = p_env wl1 orig in - let try_solve_branch scrutinee p = - let uu___1 = destruct_flex_t scrutinee wl1 in - match uu___1 with - | (Flex (_t, uv, _args), wl2) -> - let uu___2 = - FStar_TypeChecker_PatternUtils.pat_as_exp true true env p in - (match uu___2 with - | (xs, pat_term, g_pat_as_exp, uu___3) -> - let uu___4 = - FStar_Compiler_List.fold_left - (fun uu___5 -> - fun x -> - match uu___5 with - | (subst, wl3) -> - let t_x = - FStar_Syntax_Subst.subst subst - x.FStar_Syntax_Syntax.sort in - let uu___6 = copy_uvar uv [] t_x wl3 in - (match uu___6 with - | (uu___7, u, wl4) -> - let subst1 = - (FStar_Syntax_Syntax.NT (x, u)) :: - subst in - (subst1, wl4))) ([], wl2) xs in - (match uu___4 with - | (subst, wl3) -> - let pat_term1 = - FStar_Syntax_Subst.subst subst pat_term in - let uu___5 = - let must_tot = false in - let scrutinee_t = - let uu___6 = - let uu___7 = - let uu___8 = - env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - env scrutinee must_tot in - FStar_Pervasives_Native.fst uu___8 in - FStar_TypeChecker_Normalize.normalize_refinement - FStar_TypeChecker_Normalize.whnf_steps env - uu___7 in - FStar_Syntax_Util.unrefine uu___6 in - (let uu___7 = - FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___7 - then - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term pat_term1 in - FStar_Compiler_Util.print1 - "Match heuristic, typechecking the pattern term: %s {\n\n" - uu___8 - else ()); - (let uu___7 = - let uu___8 = - FStar_TypeChecker_Env.set_expected_typ env - scrutinee_t in - env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term - uu___8 pat_term1 must_tot in - match uu___7 with - | (pat_term2, pat_term_t, g_pat_term) -> - ((let uu___9 = - FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___9 - then - let uu___10 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - pat_term2 in - let uu___11 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - pat_term_t in - FStar_Compiler_Util.print2 - "} Match heuristic, typechecked pattern term to %s and type %s\n" - uu___10 uu___11 - else ()); - (pat_term2, g_pat_term))) in - (match uu___5 with - | (pat_term2, g_pat_term) -> - let uu___6 = - let uu___7 = simplify_guard env g_pat_term in - FStar_TypeChecker_Env.is_trivial_guard_formula - uu___7 in - if uu___6 - then - let uu___7 = - new_problem wl3 env scrutinee - FStar_TypeChecker_Common.EQ pat_term2 - FStar_Pervasives_Native.None - scrutinee.FStar_Syntax_Syntax.pos - "match heuristic" in - (match uu___7 with - | (prob, wl4) -> - let wl' = - extend_wl - { - attempting = - [FStar_TypeChecker_Common.TProb - prob]; - wl_deferred = - (Obj.magic - (FStar_Class_Listlike.empty - () - (Obj.magic - (FStar_Compiler_CList.listlike_clist - ())))); - wl_deferred_to_tac = - (wl4.wl_deferred_to_tac); - ctr = (wl4.ctr); - defer_ok = NoDefer; - smt_ok = false; - umax_heuristic_ok = - (wl4.umax_heuristic_ok); - tcenv = (wl4.tcenv); - wl_implicits = - (Obj.magic - (FStar_Class_Listlike.empty - () - (Obj.magic - (FStar_Compiler_CList.listlike_clist - ())))); - repr_subcomp_allowed = - (wl4.repr_subcomp_allowed); - typeclass_variables = - (wl4.typeclass_variables) - } - g_pat_term.FStar_TypeChecker_Common.deferred - g_pat_term.FStar_TypeChecker_Common.deferred_to_tac - (Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic - (FStar_Compiler_CList.listlike_clist - ())))) in - let tx = - FStar_Syntax_Unionfind.new_transaction - () in - let uu___8 = solve wl' in - (match uu___8 with - | Success (uu___9, defer_to_tac, imps) - -> - let wl'1 = - { - attempting = [orig]; - wl_deferred = (wl'.wl_deferred); - wl_deferred_to_tac = - (wl'.wl_deferred_to_tac); - ctr = (wl'.ctr); - defer_ok = (wl'.defer_ok); - smt_ok = (wl'.smt_ok); - umax_heuristic_ok = - (wl'.umax_heuristic_ok); - tcenv = (wl'.tcenv); - wl_implicits = - (wl'.wl_implicits); - repr_subcomp_allowed = - (wl'.repr_subcomp_allowed); - typeclass_variables = - (wl'.typeclass_variables) - } in - let uu___10 = solve wl'1 in - (match uu___10 with - | Success - (uu___11, defer_to_tac', - imps') - -> - (FStar_Syntax_Unionfind.commit - tx; - (let uu___13 = - let uu___14 = - FStar_Class_Monoid.op_Plus_Plus - (FStar_Compiler_CList.monoid_clist - ()) defer_to_tac - defer_to_tac' in - let uu___15 = - let uu___16 = - let uu___17 = - FStar_Class_Monoid.op_Plus_Plus - (FStar_Compiler_CList.monoid_clist - ()) imps imps' in - FStar_Class_Monoid.op_Plus_Plus - (FStar_Compiler_CList.monoid_clist - ()) uu___17 - g_pat_as_exp.FStar_TypeChecker_Common.implicits in - FStar_Class_Monoid.op_Plus_Plus - (FStar_Compiler_CList.monoid_clist - ()) uu___16 - g_pat_term.FStar_TypeChecker_Common.implicits in - extend_wl wl4 - (Obj.magic - (FStar_Class_Listlike.empty - () - (Obj.magic - (FStar_Compiler_CList.listlike_clist - ())))) - uu___14 uu___15 in - FStar_Pervasives_Native.Some - uu___13)) - | Failed uu___11 -> - (FStar_Syntax_Unionfind.rollback - tx; - FStar_Pervasives_Native.None)) - | uu___9 -> - (FStar_Syntax_Unionfind.rollback tx; - FStar_Pervasives_Native.None))) - else FStar_Pervasives_Native.None))) in - match t1t2_opt with - | FStar_Pervasives_Native.None -> - FStar_Pervasives.Inr FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (t1, t2) -> - ((let uu___2 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___2 - then - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t2 in - FStar_Compiler_Util.print2 - "Trying match heuristic for %s vs. %s\n" uu___3 uu___4 - else ()); - (let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Util.unmeta t1 in (s1, uu___4) in - let uu___4 = - let uu___5 = FStar_Syntax_Util.unmeta t2 in (s2, uu___5) in - (uu___3, uu___4) in - match uu___2 with - | ((uu___3, - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = scrutinee; - FStar_Syntax_Syntax.ret_opt = uu___4; - FStar_Syntax_Syntax.brs = branches; - FStar_Syntax_Syntax.rc_opt1 = uu___5;_}; - FStar_Syntax_Syntax.pos = uu___6; - FStar_Syntax_Syntax.vars = uu___7; - FStar_Syntax_Syntax.hash_code = uu___8;_}), - (s, t)) -> - let uu___9 = - let uu___10 = is_flex scrutinee in - Prims.op_Negation uu___10 in - if uu___9 - then - ((let uu___11 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___11 - then - let uu___12 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term scrutinee in - FStar_Compiler_Util.print1 - "match head %s is not a flex term\n" uu___12 - else ()); - FStar_Pervasives.Inr FStar_Pervasives_Native.None) - else - if wl1.defer_ok = DeferAny - then - ((let uu___12 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___12 - then - FStar_Compiler_Util.print_string - "Deferring ... \n" - else ()); - FStar_Pervasives.Inl "defer") - else - ((let uu___13 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___13 - then - let uu___14 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term scrutinee in - let uu___15 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.print2 - "Heuristic applicable with scrutinee %s and other side = %s\n" - uu___14 uu___15 - else ()); - (let pat_discriminates uu___13 = - match uu___13 with - | ({ - FStar_Syntax_Syntax.v = - FStar_Syntax_Syntax.Pat_constant uu___14; - FStar_Syntax_Syntax.p = uu___15;_}, - FStar_Pervasives_Native.None, uu___16) -> true - | ({ - FStar_Syntax_Syntax.v = - FStar_Syntax_Syntax.Pat_cons uu___14; - FStar_Syntax_Syntax.p = uu___15;_}, - FStar_Pervasives_Native.None, uu___16) -> true - | uu___14 -> false in - let head_matching_branch = - FStar_Compiler_Util.try_find - (fun b -> - if pat_discriminates b - then - let uu___13 = - FStar_Syntax_Subst.open_branch b in - match uu___13 with - | (uu___14, uu___15, t') -> - let uu___16 = - head_matches_delta (p_env wl1 orig) - (p_logical orig) wl1.smt_ok s t' in - (match uu___16 with - | (FullMatch, uu___17) -> true - | (HeadMatch uu___17, uu___18) -> true - | uu___17 -> false) - else false) branches in - match head_matching_branch with - | FStar_Pervasives_Native.None -> - ((let uu___14 = - FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___14 - then - FStar_Compiler_Util.print_string - "No head_matching branch\n" - else ()); - (let try_branches = - let uu___14 = - FStar_Compiler_Util.prefix_until - (fun b -> - Prims.op_Negation - (pat_discriminates b)) branches in - match uu___14 with - | FStar_Pervasives_Native.Some - (branches1, uu___15, uu___16) -> - branches1 - | uu___15 -> branches in - let uu___14 = - FStar_Compiler_Util.find_map try_branches - (fun b -> - let uu___15 = - FStar_Syntax_Subst.open_branch b in - match uu___15 with - | (p, uu___16, uu___17) -> - try_solve_branch scrutinee p) in - FStar_Pervasives.Inr uu___14)) - | FStar_Pervasives_Native.Some b -> - let uu___13 = FStar_Syntax_Subst.open_branch b in - (match uu___13 with - | (p, uu___14, e) -> - ((let uu___16 = - FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___16 - then - let uu___17 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_pat p in - let uu___18 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term e in - FStar_Compiler_Util.print2 - "Found head matching branch %s -> %s\n" - uu___17 uu___18 - else ()); - (let uu___16 = - try_solve_branch scrutinee p in - FStar_Pervasives.Inr uu___16))))) - | ((s, t), - (uu___3, - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = scrutinee; - FStar_Syntax_Syntax.ret_opt = uu___4; - FStar_Syntax_Syntax.brs = branches; - FStar_Syntax_Syntax.rc_opt1 = uu___5;_}; - FStar_Syntax_Syntax.pos = uu___6; - FStar_Syntax_Syntax.vars = uu___7; - FStar_Syntax_Syntax.hash_code = uu___8;_})) - -> - let uu___9 = - let uu___10 = is_flex scrutinee in - Prims.op_Negation uu___10 in - if uu___9 - then - ((let uu___11 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___11 - then - let uu___12 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term scrutinee in - FStar_Compiler_Util.print1 - "match head %s is not a flex term\n" uu___12 - else ()); - FStar_Pervasives.Inr FStar_Pervasives_Native.None) - else - if wl1.defer_ok = DeferAny - then - ((let uu___12 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___12 - then - FStar_Compiler_Util.print_string - "Deferring ... \n" - else ()); - FStar_Pervasives.Inl "defer") - else - ((let uu___13 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___13 - then - let uu___14 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term scrutinee in - let uu___15 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.print2 - "Heuristic applicable with scrutinee %s and other side = %s\n" - uu___14 uu___15 - else ()); - (let pat_discriminates uu___13 = - match uu___13 with - | ({ - FStar_Syntax_Syntax.v = - FStar_Syntax_Syntax.Pat_constant uu___14; - FStar_Syntax_Syntax.p = uu___15;_}, - FStar_Pervasives_Native.None, uu___16) -> true - | ({ - FStar_Syntax_Syntax.v = - FStar_Syntax_Syntax.Pat_cons uu___14; - FStar_Syntax_Syntax.p = uu___15;_}, - FStar_Pervasives_Native.None, uu___16) -> true - | uu___14 -> false in - let head_matching_branch = - FStar_Compiler_Util.try_find - (fun b -> - if pat_discriminates b - then - let uu___13 = - FStar_Syntax_Subst.open_branch b in - match uu___13 with - | (uu___14, uu___15, t') -> - let uu___16 = - head_matches_delta (p_env wl1 orig) - (p_logical orig) wl1.smt_ok s t' in - (match uu___16 with - | (FullMatch, uu___17) -> true - | (HeadMatch uu___17, uu___18) -> true - | uu___17 -> false) - else false) branches in - match head_matching_branch with - | FStar_Pervasives_Native.None -> - ((let uu___14 = - FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___14 - then - FStar_Compiler_Util.print_string - "No head_matching branch\n" - else ()); - (let try_branches = - let uu___14 = - FStar_Compiler_Util.prefix_until - (fun b -> - Prims.op_Negation - (pat_discriminates b)) branches in - match uu___14 with - | FStar_Pervasives_Native.Some - (branches1, uu___15, uu___16) -> - branches1 - | uu___15 -> branches in - let uu___14 = - FStar_Compiler_Util.find_map try_branches - (fun b -> - let uu___15 = - FStar_Syntax_Subst.open_branch b in - match uu___15 with - | (p, uu___16, uu___17) -> - try_solve_branch scrutinee p) in - FStar_Pervasives.Inr uu___14)) - | FStar_Pervasives_Native.Some b -> - let uu___13 = FStar_Syntax_Subst.open_branch b in - (match uu___13 with - | (p, uu___14, e) -> - ((let uu___16 = - FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___16 - then - let uu___17 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_pat p in - let uu___18 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term e in - FStar_Compiler_Util.print2 - "Found head matching branch %s -> %s\n" - uu___17 uu___18 - else ()); - (let uu___16 = - try_solve_branch scrutinee p in - FStar_Pervasives.Inr uu___16))))) - | uu___3 -> - ((let uu___5 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___5 - then - let uu___6 = - FStar_Class_Tagged.tag_of - FStar_Syntax_Syntax.tagged_term t1 in - let uu___7 = - FStar_Class_Tagged.tag_of - FStar_Syntax_Syntax.tagged_term t2 in - FStar_Compiler_Util.print2 - "Heuristic not applicable: tag lhs=%s, rhs=%s\n" - uu___6 uu___7 - else ()); - FStar_Pervasives.Inr FStar_Pervasives_Native.None))) in - let rigid_rigid_delta torig wl1 head1 head2 t1 t2 = - let orig = FStar_TypeChecker_Common.TProb torig in - (let uu___2 = FStar_Compiler_Effect.op_Bang dbg_RelDelta in - if uu___2 - then - let uu___3 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t1 in - let uu___4 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t2 in - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - let uu___6 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t2 in - FStar_Compiler_Util.print4 - "rigid_rigid_delta of %s-%s (%s, %s)\n" uu___3 uu___4 uu___5 - uu___6 - else ()); - (let uu___2 = - head_matches_delta (p_env wl1 orig) (p_logical orig) wl1.smt_ok - t1 t2 in - match uu___2 with - | (m, o) -> - (match (m, o) with - | (MisMatch uu___3, uu___4) -> - let try_reveal_hide t11 t21 = - let payload_of_hide_reveal h args = - match ((h.FStar_Syntax_Syntax.n), args) with - | (FStar_Syntax_Syntax.Tm_uinst (uu___5, u::[]), - (ty, FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = uu___6;_}):: - (t, uu___7)::[]) -> - FStar_Pervasives_Native.Some (u, ty, t) - | uu___5 -> FStar_Pervasives_Native.None in - let is_reveal_or_hide t = - let uu___5 = FStar_Syntax_Util.head_and_args t in - match uu___5 with - | (h, args) -> - let uu___6 = - FStar_Syntax_Util.is_fvar - FStar_Parser_Const.reveal h in - if uu___6 - then - let uu___7 = payload_of_hide_reveal h args in - (match uu___7 with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some t3 -> - FStar_Pervasives_Native.Some (Reveal t3)) - else - (let uu___8 = - FStar_Syntax_Util.is_fvar - FStar_Parser_Const.hide h in - if uu___8 - then - let uu___9 = payload_of_hide_reveal h args in - match uu___9 with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some t3 -> - FStar_Pervasives_Native.Some (Hide t3) - else FStar_Pervasives_Native.None) in - let mk_fv_app lid u args r = - let fv = - FStar_TypeChecker_Env.fvar_of_nonqual_lid wl1.tcenv - lid in - let head = FStar_Syntax_Syntax.mk_Tm_uinst fv [u] in - FStar_Syntax_Syntax.mk_Tm_app head args r in - let uu___5 = - let uu___6 = is_reveal_or_hide t11 in - let uu___7 = is_reveal_or_hide t21 in (uu___6, uu___7) in - match uu___5 with - | (FStar_Pervasives_Native.Some (Reveal (u, ty, lhs)), - FStar_Pervasives_Native.None) when is_flex lhs -> - let rhs = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Syntax_Syntax.as_aqual_implicit true in - (ty, uu___8) in - [uu___7; (t21, FStar_Pervasives_Native.None)] in - mk_fv_app FStar_Parser_Const.hide u uu___6 - t21.FStar_Syntax_Syntax.pos in - FStar_Pervasives_Native.Some (lhs, rhs) - | (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.Some (Reveal (u, ty, rhs))) - when is_flex rhs -> - let lhs = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Syntax_Syntax.as_aqual_implicit true in - (ty, uu___8) in - [uu___7; (t11, FStar_Pervasives_Native.None)] in - mk_fv_app FStar_Parser_Const.hide u uu___6 - t11.FStar_Syntax_Syntax.pos in - FStar_Pervasives_Native.Some (lhs, rhs) - | (FStar_Pervasives_Native.Some (Hide (u, ty, lhs)), - FStar_Pervasives_Native.None) -> - let rhs = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Syntax_Syntax.as_aqual_implicit true in - (ty, uu___8) in - [uu___7; (t21, FStar_Pervasives_Native.None)] in - mk_fv_app FStar_Parser_Const.reveal u uu___6 - t21.FStar_Syntax_Syntax.pos in - FStar_Pervasives_Native.Some (lhs, rhs) - | (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.Some (Hide (u, ty, rhs))) -> - let lhs = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Syntax_Syntax.as_aqual_implicit true in - (ty, uu___8) in - [uu___7; (t11, FStar_Pervasives_Native.None)] in - mk_fv_app FStar_Parser_Const.reveal u uu___6 - t11.FStar_Syntax_Syntax.pos in - FStar_Pervasives_Native.Some (lhs, rhs) - | uu___6 -> FStar_Pervasives_Native.None in - let uu___5 = try_match_heuristic orig wl1 t1 t2 o in - (match uu___5 with - | FStar_Pervasives.Inl _defer_ok -> - let uu___6 = - FStar_Thunk.mkv "delaying match heuristic" in - giveup_or_defer1 orig - FStar_TypeChecker_Common.Deferred_delay_match_heuristic - uu___6 - | FStar_Pervasives.Inr (FStar_Pervasives_Native.Some wl2) - -> solve wl2 - | FStar_Pervasives.Inr (FStar_Pervasives_Native.None) -> - let uu___6 = try_reveal_hide t1 t2 in - (match uu___6 with - | FStar_Pervasives_Native.Some (t1', t2') -> - solve_t - { - FStar_TypeChecker_Common.pid = - (problem.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = t1'; - FStar_TypeChecker_Common.relation = - (problem.FStar_TypeChecker_Common.relation); - FStar_TypeChecker_Common.rhs = t2'; - FStar_TypeChecker_Common.element = - (problem.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (problem.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar - = - (problem.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (problem.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = - (problem.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = - (problem.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = - (problem.FStar_TypeChecker_Common.logical) - } wl1 - | FStar_Pervasives_Native.None -> - let uu___7 = - ((may_relate wl1.tcenv - problem.FStar_TypeChecker_Common.relation - head1) - || - (may_relate wl1.tcenv - problem.FStar_TypeChecker_Common.relation - head2)) - && wl1.smt_ok in - if uu___7 - then - let uu___8 = guard_of_prob wl1 problem t1 t2 in - (match uu___8 with - | (guard, wl2) -> - let uu___9 = - solve_prob orig - (FStar_Pervasives_Native.Some guard) - [] wl2 in - solve uu___9) - else - (let uu___9 = - mklstr - (fun uu___10 -> - let uu___11 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - head1 in - let uu___12 = - let uu___13 = - FStar_TypeChecker_Env.delta_depth_of_term - wl1.tcenv head1 in - FStar_Class_Show.show - FStar_Syntax_Syntax.showable_delta_depth - uu___13 in - let uu___13 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - head2 in - let uu___14 = - let uu___15 = - FStar_TypeChecker_Env.delta_depth_of_term - wl1.tcenv head2 in - FStar_Class_Show.show - FStar_Syntax_Syntax.showable_delta_depth - uu___15 in - FStar_Compiler_Util.format4 - "head mismatch (%s (%s) vs %s (%s))" - uu___11 uu___12 uu___13 uu___14) in - giveup wl1 uu___9 orig))) - | (HeadMatch (true), uu___3) when - problem.FStar_TypeChecker_Common.relation <> - FStar_TypeChecker_Common.EQ - -> - if wl1.smt_ok - then - let uu___4 = guard_of_prob wl1 problem t1 t2 in - (match uu___4 with - | (guard, wl2) -> - let uu___5 = - solve_prob orig - (FStar_Pervasives_Native.Some guard) [] wl2 in - solve uu___5) - else - (let uu___5 = - mklstr - (fun uu___6 -> - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t1 in - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t2 in - FStar_Compiler_Util.format2 - "head mismatch for subtyping (%s vs %s)" - uu___7 uu___8) in - giveup wl1 uu___5 orig) - | (uu___3, FStar_Pervasives_Native.Some (t11, t21)) -> - solve_t - { - FStar_TypeChecker_Common.pid = - (problem.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = t11; - FStar_TypeChecker_Common.relation = - (problem.FStar_TypeChecker_Common.relation); - FStar_TypeChecker_Common.rhs = t21; - FStar_TypeChecker_Common.element = - (problem.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (problem.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (problem.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (problem.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = - (problem.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = - (problem.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = - (problem.FStar_TypeChecker_Common.logical) - } wl1 - | (HeadMatch need_unif, FStar_Pervasives_Native.None) -> - rigid_heads_match need_unif torig wl1 t1 t2 - | (FullMatch, FStar_Pervasives_Native.None) -> - rigid_heads_match false torig wl1 t1 t2)) in - let orig = FStar_TypeChecker_Common.TProb problem in - def_check_prob "solve_t'.2" orig; - (let uu___2 = - FStar_Compiler_Util.physical_equality - problem.FStar_TypeChecker_Common.lhs - problem.FStar_TypeChecker_Common.rhs in - if uu___2 - then - let uu___3 = solve_prob orig FStar_Pervasives_Native.None [] wl in - solve uu___3 - else - (let t1 = problem.FStar_TypeChecker_Common.lhs in - let t2 = problem.FStar_TypeChecker_Common.rhs in - (let uu___5 = - let uu___6 = p_scope orig in - FStar_Compiler_List.map - (fun b -> b.FStar_Syntax_Syntax.binder_bv) uu___6 in - FStar_Defensive.def_check_scoped - FStar_Class_Binders.hasBinders_list_bv - FStar_Class_Binders.hasNames_term - FStar_Syntax_Print.pretty_term (p_loc orig) "ref.t1" uu___5 t1); - (let uu___6 = - let uu___7 = p_scope orig in - FStar_Compiler_List.map - (fun b -> b.FStar_Syntax_Syntax.binder_bv) uu___7 in - FStar_Defensive.def_check_scoped - FStar_Class_Binders.hasBinders_list_bv - FStar_Class_Binders.hasNames_term - FStar_Syntax_Print.pretty_term (p_loc orig) "ref.t2" uu___6 t2); - (let uu___7 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___7 - then - let uu___8 = - FStar_Compiler_Util.string_of_int - problem.FStar_TypeChecker_Common.pid in - let uu___9 = - let uu___10 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term - t1 in - let uu___11 = - let uu___12 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - Prims.strcat "::" uu___12 in - Prims.strcat uu___10 uu___11 in - let uu___10 = - let uu___11 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term - t2 in - let uu___12 = - let uu___13 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t2 in - Prims.strcat "::" uu___13 in - Prims.strcat uu___11 uu___12 in - let uu___11 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_nat) - (FStar_Compiler_List.length wl.attempting) in - FStar_Compiler_Util.print5 - "Attempting %s (%s vs %s); rel = (%s); number of problems in wl = %s\n" - uu___8 uu___9 uu___10 - (rel_to_string problem.FStar_TypeChecker_Common.relation) - uu___11 - else ()); - (match ((t1.FStar_Syntax_Syntax.n), (t2.FStar_Syntax_Syntax.n)) - with - | (FStar_Syntax_Syntax.Tm_delayed uu___7, uu___8) -> - failwith "Impossible: terms were not compressed" - | (uu___7, FStar_Syntax_Syntax.Tm_delayed uu___8) -> - failwith "Impossible: terms were not compressed" - | (FStar_Syntax_Syntax.Tm_ascribed uu___7, uu___8) -> - let uu___9 = - let uu___10 = FStar_Syntax_Util.unascribe t1 in - { - FStar_TypeChecker_Common.pid = - (problem.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = uu___10; - FStar_TypeChecker_Common.relation = - (problem.FStar_TypeChecker_Common.relation); - FStar_TypeChecker_Common.rhs = - (problem.FStar_TypeChecker_Common.rhs); - FStar_TypeChecker_Common.element = - (problem.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (problem.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (problem.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (problem.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = - (problem.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = - (problem.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = - (problem.FStar_TypeChecker_Common.logical) - } in - solve_t' uu___9 wl - | (FStar_Syntax_Syntax.Tm_meta uu___7, uu___8) -> - let uu___9 = - let uu___10 = FStar_Syntax_Util.unmeta t1 in - { - FStar_TypeChecker_Common.pid = - (problem.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = uu___10; - FStar_TypeChecker_Common.relation = - (problem.FStar_TypeChecker_Common.relation); - FStar_TypeChecker_Common.rhs = - (problem.FStar_TypeChecker_Common.rhs); - FStar_TypeChecker_Common.element = - (problem.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (problem.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (problem.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (problem.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = - (problem.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = - (problem.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = - (problem.FStar_TypeChecker_Common.logical) - } in - solve_t' uu___9 wl - | (uu___7, FStar_Syntax_Syntax.Tm_ascribed uu___8) -> - let uu___9 = - let uu___10 = FStar_Syntax_Util.unascribe t2 in - { - FStar_TypeChecker_Common.pid = - (problem.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = - (problem.FStar_TypeChecker_Common.lhs); - FStar_TypeChecker_Common.relation = - (problem.FStar_TypeChecker_Common.relation); - FStar_TypeChecker_Common.rhs = uu___10; - FStar_TypeChecker_Common.element = - (problem.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (problem.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (problem.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (problem.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = - (problem.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = - (problem.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = - (problem.FStar_TypeChecker_Common.logical) - } in - solve_t' uu___9 wl - | (uu___7, FStar_Syntax_Syntax.Tm_meta uu___8) -> - let uu___9 = - let uu___10 = FStar_Syntax_Util.unmeta t2 in - { - FStar_TypeChecker_Common.pid = - (problem.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = - (problem.FStar_TypeChecker_Common.lhs); - FStar_TypeChecker_Common.relation = - (problem.FStar_TypeChecker_Common.relation); - FStar_TypeChecker_Common.rhs = uu___10; - FStar_TypeChecker_Common.element = - (problem.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (problem.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (problem.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (problem.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = - (problem.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = - (problem.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = - (problem.FStar_TypeChecker_Common.logical) - } in - solve_t' uu___9 wl - | (FStar_Syntax_Syntax.Tm_quoted (t11, uu___7), - FStar_Syntax_Syntax.Tm_quoted (t21, uu___8)) -> - let uu___9 = - solve_prob orig FStar_Pervasives_Native.None [] wl in - solve uu___9 - | (FStar_Syntax_Syntax.Tm_bvar uu___7, uu___8) -> - failwith - "Only locally nameless! We should never see a de Bruijn variable" - | (uu___7, FStar_Syntax_Syntax.Tm_bvar uu___8) -> - failwith - "Only locally nameless! We should never see a de Bruijn variable" - | (FStar_Syntax_Syntax.Tm_type u1, FStar_Syntax_Syntax.Tm_type - u2) -> solve_one_universe_eq orig u1 u2 wl - | (FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs1; - FStar_Syntax_Syntax.comp = c1;_}, - FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs2; - FStar_Syntax_Syntax.comp = c2;_}) - -> - let mk_c c uu___7 = - match uu___7 with - | [] -> c - | bs -> - let uu___8 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 = bs; - FStar_Syntax_Syntax.comp = c - }) c.FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.mk_Total uu___8 in - let uu___7 = - match_num_binders (bs1, (mk_c c1)) (bs2, (mk_c c2)) in - (match uu___7 with - | ((bs11, c11), (bs21, c21)) -> - solve_binders bs11 bs21 orig wl - (fun wl1 -> - fun scope -> - fun subst -> - let c12 = - FStar_Syntax_Subst.subst_comp subst c11 in - let c22 = - FStar_Syntax_Subst.subst_comp subst c21 in - let rel = - let uu___8 = - FStar_Options.use_eq_at_higher_order () in - if uu___8 - then FStar_TypeChecker_Common.EQ - else - problem.FStar_TypeChecker_Common.relation in - mk_c_problem wl1 scope orig c12 rel c22 - FStar_Pervasives_Native.None - "function co-domain")) - | (FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs1; - FStar_Syntax_Syntax.body = tbody1; - FStar_Syntax_Syntax.rc_opt = lopt1;_}, - FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs2; - FStar_Syntax_Syntax.body = tbody2; - FStar_Syntax_Syntax.rc_opt = lopt2;_}) - -> - let mk_t t l uu___7 = - match uu___7 with - | [] -> t - | bs -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = bs; - FStar_Syntax_Syntax.body = t; - FStar_Syntax_Syntax.rc_opt = l - }) t.FStar_Syntax_Syntax.pos in - let uu___7 = - match_num_binders (bs1, (mk_t tbody1 lopt1)) - (bs2, (mk_t tbody2 lopt2)) in - (match uu___7 with - | ((bs11, tbody11), (bs21, tbody21)) -> - solve_binders bs11 bs21 orig wl - (fun wl1 -> - fun scope -> - fun subst -> - let uu___8 = - FStar_Syntax_Subst.subst subst tbody11 in - let uu___9 = - FStar_Syntax_Subst.subst subst tbody21 in - mk_t_problem wl1 scope orig uu___8 - problem.FStar_TypeChecker_Common.relation - uu___9 FStar_Pervasives_Native.None - "lambda co-domain")) - | (FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x1; - FStar_Syntax_Syntax.phi = phi1;_}, - FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x2; - FStar_Syntax_Syntax.phi = phi2;_}) - -> - let env = p_env wl (FStar_TypeChecker_Common.TProb problem) in - let uu___7 = - let uu___8 = - head_matches_delta env false wl.smt_ok - x1.FStar_Syntax_Syntax.sort x2.FStar_Syntax_Syntax.sort in - match uu___8 with - | (FullMatch, FStar_Pervasives_Native.Some (t11, t21)) -> - ({ - FStar_Syntax_Syntax.ppname = - (x1.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (x1.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = t11 - }, - { - FStar_Syntax_Syntax.ppname = - (x2.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (x2.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = t21 - }) - | (HeadMatch uu___9, FStar_Pervasives_Native.Some - (t11, t21)) -> - ({ - FStar_Syntax_Syntax.ppname = - (x1.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (x1.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = t11 - }, - { - FStar_Syntax_Syntax.ppname = - (x2.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (x2.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = t21 - }) - | uu___9 -> (x1, x2) in - (match uu___7 with - | (x11, x21) -> - let t11 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_refine - { - FStar_Syntax_Syntax.b = x11; - FStar_Syntax_Syntax.phi = phi1 - }) t1.FStar_Syntax_Syntax.pos in - let t21 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_refine - { - FStar_Syntax_Syntax.b = x21; - FStar_Syntax_Syntax.phi = phi2 - }) t2.FStar_Syntax_Syntax.pos in - let uu___8 = as_refinement false env t11 in - (match uu___8 with - | (x12, phi11) -> - let uu___9 = as_refinement false env t21 in - (match uu___9 with - | (x22, phi21) -> - ((let uu___11 = - FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___11 - then - ((let uu___13 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_bv x12 in - let uu___14 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - x12.FStar_Syntax_Syntax.sort in - let uu___15 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - phi11 in - FStar_Compiler_Util.print3 - "ref1 = (%s):(%s){%s}\n" uu___13 - uu___14 uu___15); - (let uu___13 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_bv x22 in - let uu___14 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - x22.FStar_Syntax_Syntax.sort in - let uu___15 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - phi21 in - FStar_Compiler_Util.print3 - "ref2 = (%s):(%s){%s}\n" uu___13 - uu___14 uu___15)) - else ()); - (let uu___11 = - mk_t_problem wl [] orig - x12.FStar_Syntax_Syntax.sort - problem.FStar_TypeChecker_Common.relation - x22.FStar_Syntax_Syntax.sort - problem.FStar_TypeChecker_Common.element - "refinement base type" in - match uu___11 with - | (base_prob, wl1) -> - let x13 = - FStar_Syntax_Syntax.freshen_bv x12 in - let subst = - [FStar_Syntax_Syntax.DB - (Prims.int_zero, x13)] in - let phi12 = - FStar_Syntax_Subst.subst subst phi11 in - let phi22 = - FStar_Syntax_Subst.subst subst phi21 in - let mk_imp imp phi13 phi23 = - let uu___12 = imp phi13 phi23 in - guard_on_element wl1 problem x13 - uu___12 in - let fallback uu___12 = - let impl = - if - problem.FStar_TypeChecker_Common.relation - = FStar_TypeChecker_Common.EQ - then - mk_imp FStar_Syntax_Util.mk_iff - phi12 phi22 - else - mk_imp FStar_Syntax_Util.mk_imp - phi12 phi22 in - let guard = - FStar_Syntax_Util.mk_conj - (p_guard base_prob) impl in - (let uu___14 = - let uu___15 = p_scope orig in - FStar_Compiler_List.map - (fun b -> - b.FStar_Syntax_Syntax.binder_bv) - uu___15 in - FStar_Defensive.def_check_scoped - FStar_Class_Binders.hasBinders_list_bv - FStar_Class_Binders.hasNames_term - FStar_Syntax_Print.pretty_term - (p_loc orig) "ref.1" uu___14 - (p_guard base_prob)); - (let uu___15 = - let uu___16 = p_scope orig in - FStar_Compiler_List.map - (fun b -> - b.FStar_Syntax_Syntax.binder_bv) - uu___16 in - FStar_Defensive.def_check_scoped - FStar_Class_Binders.hasBinders_list_bv - FStar_Class_Binders.hasNames_term - FStar_Syntax_Print.pretty_term - (p_loc orig) "ref.2" uu___15 impl); - (let wl2 = - solve_prob orig - (FStar_Pervasives_Native.Some - guard) [] wl1 in - let uu___15 = attempt [base_prob] wl2 in - solve uu___15) in - let has_uvars = - (let uu___12 = - let uu___13 = - FStar_Syntax_Free.uvars phi12 in - FStar_Class_Setlike.is_empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) - (Obj.magic uu___13) in - Prims.op_Negation uu___12) || - (let uu___12 = - let uu___13 = - FStar_Syntax_Free.uvars phi22 in - FStar_Class_Setlike.is_empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) - (Obj.magic uu___13) in - Prims.op_Negation uu___12) in - if - (problem.FStar_TypeChecker_Common.relation - = FStar_TypeChecker_Common.EQ) - || - ((Prims.op_Negation - env.FStar_TypeChecker_Env.uvar_subtyping) - && has_uvars) - then - let uu___12 = - let uu___13 = - let uu___14 = - FStar_Syntax_Syntax.mk_binder - x13 in - [uu___14] in - mk_t_problem wl1 uu___13 orig phi12 - FStar_TypeChecker_Common.EQ phi22 - FStar_Pervasives_Native.None - "refinement formula" in - (match uu___12 with - | (ref_prob, wl2) -> - let ref_prob1 = - set_logical true ref_prob in - let tx = - FStar_Syntax_Unionfind.new_transaction - () in - let uu___13 = - solve - { - attempting = [ref_prob1]; - wl_deferred = - (Obj.magic - (FStar_Class_Listlike.empty - () - (Obj.magic - (FStar_Compiler_CList.listlike_clist - ())))); - wl_deferred_to_tac = - (wl2.wl_deferred_to_tac); - ctr = (wl2.ctr); - defer_ok = NoDefer; - smt_ok = (wl2.smt_ok); - umax_heuristic_ok = - (wl2.umax_heuristic_ok); - tcenv = (wl2.tcenv); - wl_implicits = - (Obj.magic - (FStar_Class_Listlike.empty - () - (Obj.magic - (FStar_Compiler_CList.listlike_clist - ())))); - repr_subcomp_allowed = - (wl2.repr_subcomp_allowed); - typeclass_variables = - (wl2.typeclass_variables) - } in - (match uu___13 with - | Failed (prob, msg) -> - (FStar_Syntax_Unionfind.rollback - tx; - if - (((Prims.op_Negation - env.FStar_TypeChecker_Env.uvar_subtyping) - && has_uvars) - || - (Prims.op_Negation - wl2.smt_ok)) - && - (Prims.op_Negation - env.FStar_TypeChecker_Env.unif_allow_ref_guards) - then giveup wl2 msg prob - else fallback ()) - | Success - (uu___14, defer_to_tac, - imps) - -> - (FStar_Syntax_Unionfind.commit - tx; - (let guard = - let uu___16 = - guard_on_element wl2 - problem x13 - (p_guard ref_prob1) in - FStar_Syntax_Util.mk_conj - (p_guard base_prob) - uu___16 in - let wl3 = - solve_prob orig - (FStar_Pervasives_Native.Some - guard) [] wl2 in - let wl4 = - { - attempting = - (wl3.attempting); - wl_deferred = - (wl3.wl_deferred); - wl_deferred_to_tac = - (wl3.wl_deferred_to_tac); - ctr = - (wl3.ctr + - Prims.int_one); - defer_ok = - (wl3.defer_ok); - smt_ok = (wl3.smt_ok); - umax_heuristic_ok = - (wl3.umax_heuristic_ok); - tcenv = (wl3.tcenv); - wl_implicits = - (wl3.wl_implicits); - repr_subcomp_allowed = - (wl3.repr_subcomp_allowed); - typeclass_variables = - (wl3.typeclass_variables) - } in - let wl5 = - extend_wl wl4 - (Obj.magic - (FStar_Class_Listlike.empty - () - (Obj.magic - (FStar_Compiler_CList.listlike_clist - ())))) - defer_to_tac imps in - let uu___16 = - attempt [base_prob] wl5 in - solve uu___16)))) - else fallback ()))))) - | (FStar_Syntax_Syntax.Tm_uvar uu___7, - FStar_Syntax_Syntax.Tm_uvar uu___8) -> - let env = p_env wl (FStar_TypeChecker_Common.TProb problem) in - let uu___9 = ensure_no_uvar_subst env t1 wl in - (match uu___9 with - | (t11, wl1) -> - let t21 = FStar_Syntax_Util.canon_app t2 in - let uu___10 = ensure_no_uvar_subst env t21 wl1 in - (match uu___10 with - | (t22, wl2) -> - let f1 = destruct_flex_t' t11 in - let f2 = destruct_flex_t' t22 in - solve_t_flex_flex env orig wl2 f1 f2)) - | (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_uvar - uu___7; - FStar_Syntax_Syntax.pos = uu___8; - FStar_Syntax_Syntax.vars = uu___9; - FStar_Syntax_Syntax.hash_code = uu___10;_}; - FStar_Syntax_Syntax.args = uu___11;_}, - FStar_Syntax_Syntax.Tm_uvar uu___12) -> - let env = p_env wl (FStar_TypeChecker_Common.TProb problem) in - let uu___13 = ensure_no_uvar_subst env t1 wl in - (match uu___13 with - | (t11, wl1) -> - let t21 = FStar_Syntax_Util.canon_app t2 in - let uu___14 = ensure_no_uvar_subst env t21 wl1 in - (match uu___14 with - | (t22, wl2) -> - let f1 = destruct_flex_t' t11 in - let f2 = destruct_flex_t' t22 in - solve_t_flex_flex env orig wl2 f1 f2)) - | (FStar_Syntax_Syntax.Tm_uvar uu___7, FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_uvar - uu___8; - FStar_Syntax_Syntax.pos = uu___9; - FStar_Syntax_Syntax.vars = uu___10; - FStar_Syntax_Syntax.hash_code = uu___11;_}; - FStar_Syntax_Syntax.args = uu___12;_}) - -> - let env = p_env wl (FStar_TypeChecker_Common.TProb problem) in - let uu___13 = ensure_no_uvar_subst env t1 wl in - (match uu___13 with - | (t11, wl1) -> - let t21 = FStar_Syntax_Util.canon_app t2 in - let uu___14 = ensure_no_uvar_subst env t21 wl1 in - (match uu___14 with - | (t22, wl2) -> - let f1 = destruct_flex_t' t11 in - let f2 = destruct_flex_t' t22 in - solve_t_flex_flex env orig wl2 f1 f2)) - | (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_uvar - uu___7; - FStar_Syntax_Syntax.pos = uu___8; - FStar_Syntax_Syntax.vars = uu___9; - FStar_Syntax_Syntax.hash_code = uu___10;_}; - FStar_Syntax_Syntax.args = uu___11;_}, - FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_uvar - uu___12; - FStar_Syntax_Syntax.pos = uu___13; - FStar_Syntax_Syntax.vars = uu___14; - FStar_Syntax_Syntax.hash_code = uu___15;_}; - FStar_Syntax_Syntax.args = uu___16;_}) - -> - let env = p_env wl (FStar_TypeChecker_Common.TProb problem) in - let uu___17 = ensure_no_uvar_subst env t1 wl in - (match uu___17 with - | (t11, wl1) -> - let t21 = FStar_Syntax_Util.canon_app t2 in - let uu___18 = ensure_no_uvar_subst env t21 wl1 in - (match uu___18 with - | (t22, wl2) -> - let f1 = destruct_flex_t' t11 in - let f2 = destruct_flex_t' t22 in - solve_t_flex_flex env orig wl2 f1 f2)) - | (FStar_Syntax_Syntax.Tm_uvar uu___7, uu___8) when - problem.FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.EQ - -> - let uu___9 = destruct_flex_t t1 wl in - (match uu___9 with - | (f1, wl1) -> solve_t_flex_rigid_eq orig wl1 f1 t2) - | (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_uvar - uu___7; - FStar_Syntax_Syntax.pos = uu___8; - FStar_Syntax_Syntax.vars = uu___9; - FStar_Syntax_Syntax.hash_code = uu___10;_}; - FStar_Syntax_Syntax.args = uu___11;_}, - uu___12) when - problem.FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.EQ - -> - let uu___13 = destruct_flex_t t1 wl in - (match uu___13 with - | (f1, wl1) -> solve_t_flex_rigid_eq orig wl1 f1 t2) - | (uu___7, FStar_Syntax_Syntax.Tm_uvar uu___8) when - problem.FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.EQ - -> solve_t' (invert problem) wl - | (uu___7, FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_uvar - uu___8; - FStar_Syntax_Syntax.pos = uu___9; - FStar_Syntax_Syntax.vars = uu___10; - FStar_Syntax_Syntax.hash_code = uu___11;_}; - FStar_Syntax_Syntax.args = uu___12;_}) - when - problem.FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.EQ - -> solve_t' (invert problem) wl - | (FStar_Syntax_Syntax.Tm_uvar uu___7, - FStar_Syntax_Syntax.Tm_arrow uu___8) -> - solve_t' - { - FStar_TypeChecker_Common.pid = - (problem.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = - (problem.FStar_TypeChecker_Common.lhs); - FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.EQ; - FStar_TypeChecker_Common.rhs = - (problem.FStar_TypeChecker_Common.rhs); - FStar_TypeChecker_Common.element = - (problem.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (problem.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (problem.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (problem.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = - (problem.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = - (problem.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = - (problem.FStar_TypeChecker_Common.logical) - } wl - | (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_uvar - uu___7; - FStar_Syntax_Syntax.pos = uu___8; - FStar_Syntax_Syntax.vars = uu___9; - FStar_Syntax_Syntax.hash_code = uu___10;_}; - FStar_Syntax_Syntax.args = uu___11;_}, - FStar_Syntax_Syntax.Tm_arrow uu___12) -> - solve_t' - { - FStar_TypeChecker_Common.pid = - (problem.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = - (problem.FStar_TypeChecker_Common.lhs); - FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.EQ; - FStar_TypeChecker_Common.rhs = - (problem.FStar_TypeChecker_Common.rhs); - FStar_TypeChecker_Common.element = - (problem.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (problem.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (problem.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (problem.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = - (problem.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = - (problem.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = - (problem.FStar_TypeChecker_Common.logical) - } wl - | (uu___7, FStar_Syntax_Syntax.Tm_uvar uu___8) -> - let uu___9 = - attempt [FStar_TypeChecker_Common.TProb problem] wl in - solve uu___9 - | (uu___7, FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_uvar - uu___8; - FStar_Syntax_Syntax.pos = uu___9; - FStar_Syntax_Syntax.vars = uu___10; - FStar_Syntax_Syntax.hash_code = uu___11;_}; - FStar_Syntax_Syntax.args = uu___12;_}) - -> - let uu___13 = - attempt [FStar_TypeChecker_Common.TProb problem] wl in - solve uu___13 - | (FStar_Syntax_Syntax.Tm_uvar uu___7, uu___8) -> - let uu___9 = - attempt [FStar_TypeChecker_Common.TProb problem] wl in - solve uu___9 - | (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_uvar - uu___7; - FStar_Syntax_Syntax.pos = uu___8; - FStar_Syntax_Syntax.vars = uu___9; - FStar_Syntax_Syntax.hash_code = uu___10;_}; - FStar_Syntax_Syntax.args = uu___11;_}, - uu___12) -> - let uu___13 = - attempt [FStar_TypeChecker_Common.TProb problem] wl in - solve uu___13 - | (FStar_Syntax_Syntax.Tm_abs uu___7, uu___8) -> - let is_abs t = - match t.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_abs uu___9 -> - FStar_Pervasives.Inl t - | uu___9 -> FStar_Pervasives.Inr t in - let env = p_env wl orig in - (match ((is_abs t1), (is_abs t2)) with - | (FStar_Pervasives.Inl t_abs, FStar_Pervasives.Inr not_abs) - -> - let uu___9 = - (is_flex not_abs) && - ((p_rel orig) = FStar_TypeChecker_Common.EQ) in - if uu___9 - then - let uu___10 = destruct_flex_t not_abs wl in - (match uu___10 with - | (flex, wl1) -> - solve_t_flex_rigid_eq orig wl1 flex t_abs) - else - (let uu___11 = - head_matches_delta env false wl.smt_ok not_abs - t_abs in - match uu___11 with - | (HeadMatch uu___12, FStar_Pervasives_Native.Some - (not_abs', uu___13)) -> - solve_t - { - FStar_TypeChecker_Common.pid = - (problem.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = not_abs'; - FStar_TypeChecker_Common.relation = - (problem.FStar_TypeChecker_Common.relation); - FStar_TypeChecker_Common.rhs = t_abs; - FStar_TypeChecker_Common.element = - (problem.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (problem.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (problem.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (problem.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = - (problem.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = - (problem.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = - (problem.FStar_TypeChecker_Common.logical) - } wl - | uu___12 -> - let uu___13 = - FStar_Syntax_Util.head_and_args not_abs in - (match uu___13 with - | (head, uu___14) -> - let uu___15 = - wl.smt_ok && - (may_relate wl.tcenv (p_rel orig) head) in - if uu___15 - then - let uu___16 = mk_eq2 wl orig t_abs not_abs in - (match uu___16 with - | (g, wl1) -> - let uu___17 = - solve_prob orig - (FStar_Pervasives_Native.Some g) - [] wl1 in - solve uu___17) - else - (let uu___17 = - FStar_Thunk.mkv - "head tag mismatch: RHS is an abstraction" in - giveup wl uu___17 orig))) - | (FStar_Pervasives.Inr not_abs, FStar_Pervasives.Inl t_abs) - -> - let uu___9 = - (is_flex not_abs) && - ((p_rel orig) = FStar_TypeChecker_Common.EQ) in - if uu___9 - then - let uu___10 = destruct_flex_t not_abs wl in - (match uu___10 with - | (flex, wl1) -> - solve_t_flex_rigid_eq orig wl1 flex t_abs) - else - (let uu___11 = - head_matches_delta env false wl.smt_ok not_abs - t_abs in - match uu___11 with - | (HeadMatch uu___12, FStar_Pervasives_Native.Some - (not_abs', uu___13)) -> - solve_t - { - FStar_TypeChecker_Common.pid = - (problem.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = not_abs'; - FStar_TypeChecker_Common.relation = - (problem.FStar_TypeChecker_Common.relation); - FStar_TypeChecker_Common.rhs = t_abs; - FStar_TypeChecker_Common.element = - (problem.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (problem.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (problem.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (problem.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = - (problem.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = - (problem.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = - (problem.FStar_TypeChecker_Common.logical) - } wl - | uu___12 -> - let uu___13 = - FStar_Syntax_Util.head_and_args not_abs in - (match uu___13 with - | (head, uu___14) -> - let uu___15 = - wl.smt_ok && - (may_relate wl.tcenv (p_rel orig) head) in - if uu___15 - then - let uu___16 = mk_eq2 wl orig t_abs not_abs in - (match uu___16 with - | (g, wl1) -> - let uu___17 = - solve_prob orig - (FStar_Pervasives_Native.Some g) - [] wl1 in - solve uu___17) - else - (let uu___17 = - FStar_Thunk.mkv - "head tag mismatch: RHS is an abstraction" in - giveup wl uu___17 orig))) - | uu___9 -> - failwith - "Impossible: at least one side is an abstraction") - | (uu___7, FStar_Syntax_Syntax.Tm_abs uu___8) -> - let is_abs t = - match t.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_abs uu___9 -> - FStar_Pervasives.Inl t - | uu___9 -> FStar_Pervasives.Inr t in - let env = p_env wl orig in - (match ((is_abs t1), (is_abs t2)) with - | (FStar_Pervasives.Inl t_abs, FStar_Pervasives.Inr not_abs) - -> - let uu___9 = - (is_flex not_abs) && - ((p_rel orig) = FStar_TypeChecker_Common.EQ) in - if uu___9 - then - let uu___10 = destruct_flex_t not_abs wl in - (match uu___10 with - | (flex, wl1) -> - solve_t_flex_rigid_eq orig wl1 flex t_abs) - else - (let uu___11 = - head_matches_delta env false wl.smt_ok not_abs - t_abs in - match uu___11 with - | (HeadMatch uu___12, FStar_Pervasives_Native.Some - (not_abs', uu___13)) -> - solve_t - { - FStar_TypeChecker_Common.pid = - (problem.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = not_abs'; - FStar_TypeChecker_Common.relation = - (problem.FStar_TypeChecker_Common.relation); - FStar_TypeChecker_Common.rhs = t_abs; - FStar_TypeChecker_Common.element = - (problem.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (problem.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (problem.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (problem.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = - (problem.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = - (problem.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = - (problem.FStar_TypeChecker_Common.logical) - } wl - | uu___12 -> - let uu___13 = - FStar_Syntax_Util.head_and_args not_abs in - (match uu___13 with - | (head, uu___14) -> - let uu___15 = - wl.smt_ok && - (may_relate wl.tcenv (p_rel orig) head) in - if uu___15 - then - let uu___16 = mk_eq2 wl orig t_abs not_abs in - (match uu___16 with - | (g, wl1) -> - let uu___17 = - solve_prob orig - (FStar_Pervasives_Native.Some g) - [] wl1 in - solve uu___17) - else - (let uu___17 = - FStar_Thunk.mkv - "head tag mismatch: RHS is an abstraction" in - giveup wl uu___17 orig))) - | (FStar_Pervasives.Inr not_abs, FStar_Pervasives.Inl t_abs) - -> - let uu___9 = - (is_flex not_abs) && - ((p_rel orig) = FStar_TypeChecker_Common.EQ) in - if uu___9 - then - let uu___10 = destruct_flex_t not_abs wl in - (match uu___10 with - | (flex, wl1) -> - solve_t_flex_rigid_eq orig wl1 flex t_abs) - else - (let uu___11 = - head_matches_delta env false wl.smt_ok not_abs - t_abs in - match uu___11 with - | (HeadMatch uu___12, FStar_Pervasives_Native.Some - (not_abs', uu___13)) -> - solve_t - { - FStar_TypeChecker_Common.pid = - (problem.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = not_abs'; - FStar_TypeChecker_Common.relation = - (problem.FStar_TypeChecker_Common.relation); - FStar_TypeChecker_Common.rhs = t_abs; - FStar_TypeChecker_Common.element = - (problem.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (problem.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (problem.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (problem.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = - (problem.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = - (problem.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = - (problem.FStar_TypeChecker_Common.logical) - } wl - | uu___12 -> - let uu___13 = - FStar_Syntax_Util.head_and_args not_abs in - (match uu___13 with - | (head, uu___14) -> - let uu___15 = - wl.smt_ok && - (may_relate wl.tcenv (p_rel orig) head) in - if uu___15 - then - let uu___16 = mk_eq2 wl orig t_abs not_abs in - (match uu___16 with - | (g, wl1) -> - let uu___17 = - solve_prob orig - (FStar_Pervasives_Native.Some g) - [] wl1 in - solve uu___17) - else - (let uu___17 = - FStar_Thunk.mkv - "head tag mismatch: RHS is an abstraction" in - giveup wl uu___17 orig))) - | uu___9 -> - failwith - "Impossible: at least one side is an abstraction") - | (FStar_Syntax_Syntax.Tm_refine uu___7, uu___8) -> - let t21 = - let uu___9 = base_and_refinement (p_env wl orig) t2 in - force_refinement uu___9 in - solve_t' - { - FStar_TypeChecker_Common.pid = - (problem.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = - (problem.FStar_TypeChecker_Common.lhs); - FStar_TypeChecker_Common.relation = - (problem.FStar_TypeChecker_Common.relation); - FStar_TypeChecker_Common.rhs = t21; - FStar_TypeChecker_Common.element = - (problem.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (problem.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (problem.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (problem.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = - (problem.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = - (problem.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = - (problem.FStar_TypeChecker_Common.logical) - } wl - | (uu___7, FStar_Syntax_Syntax.Tm_refine uu___8) -> - let t11 = - let uu___9 = base_and_refinement (p_env wl orig) t1 in - force_refinement uu___9 in - solve_t' - { - FStar_TypeChecker_Common.pid = - (problem.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = t11; - FStar_TypeChecker_Common.relation = - (problem.FStar_TypeChecker_Common.relation); - FStar_TypeChecker_Common.rhs = - (problem.FStar_TypeChecker_Common.rhs); - FStar_TypeChecker_Common.element = - (problem.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (problem.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (problem.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (problem.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = - (problem.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = - (problem.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = - (problem.FStar_TypeChecker_Common.logical) - } wl - | (FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = s1; - FStar_Syntax_Syntax.ret_opt = uu___7; - FStar_Syntax_Syntax.brs = brs1; - FStar_Syntax_Syntax.rc_opt1 = uu___8;_}, - FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = s2; - FStar_Syntax_Syntax.ret_opt = uu___9; - FStar_Syntax_Syntax.brs = brs2; - FStar_Syntax_Syntax.rc_opt1 = uu___10;_}) - -> - let by_smt uu___11 = - let uu___12 = guard_of_prob wl problem t1 t2 in - match uu___12 with - | (guard, wl1) -> - let uu___13 = - solve_prob orig (FStar_Pervasives_Native.Some guard) - [] wl1 in - solve uu___13 in - let rec solve_branches wl1 brs11 brs21 = - match (brs11, brs21) with - | (br1::rs1, br2::rs2) -> - let uu___11 = br1 in - (match uu___11 with - | (p1, w1, uu___12) -> - let uu___13 = br2 in - (match uu___13 with - | (p2, w2, uu___14) -> - let uu___15 = - let uu___16 = - FStar_Syntax_Syntax.eq_pat p1 p2 in - Prims.op_Negation uu___16 in - if uu___15 - then FStar_Pervasives_Native.None - else - (let uu___17 = - FStar_Syntax_Subst.open_branch' br1 in - match uu___17 with - | ((p11, w11, e1), s) -> - let uu___18 = br2 in - (match uu___18 with - | (p21, w21, e2) -> - let w22 = - FStar_Compiler_Util.map_opt w21 - (FStar_Syntax_Subst.subst s) in - let e21 = - FStar_Syntax_Subst.subst s e2 in - let scope = - let uu___19 = - FStar_Syntax_Syntax.pat_bvs - p11 in - FStar_Compiler_List.map - FStar_Syntax_Syntax.mk_binder - uu___19 in - let uu___19 = - match (w11, w22) with - | (FStar_Pervasives_Native.Some - uu___20, - FStar_Pervasives_Native.None) - -> - FStar_Pervasives_Native.None - | (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.Some - uu___20) -> - FStar_Pervasives_Native.None - | (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None) - -> - FStar_Pervasives_Native.Some - ([], wl1) - | (FStar_Pervasives_Native.Some - w12, - FStar_Pervasives_Native.Some - w23) -> - let uu___20 = - mk_t_problem wl1 scope - orig w12 - FStar_TypeChecker_Common.EQ - w23 - FStar_Pervasives_Native.None - "when clause" in - (match uu___20 with - | (p, wl2) -> - FStar_Pervasives_Native.Some - ([(scope, p)], wl2)) in - FStar_Compiler_Util.bind_opt - uu___19 - (fun uu___20 -> - match uu___20 with - | (wprobs, wl2) -> - let uu___21 = - mk_t_problem wl2 scope - orig e1 - FStar_TypeChecker_Common.EQ - e21 - FStar_Pervasives_Native.None - "branch body" in - (match uu___21 with - | (prob, wl3) -> - ((let uu___23 = - FStar_Compiler_Effect.op_Bang - dbg_Rel in - if uu___23 - then - let uu___24 = - prob_to_string' - wl3 prob in - let uu___25 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binder) - scope in - FStar_Compiler_Util.print2 - "Created problem for branches %s with scope %s\n" - uu___24 - uu___25 - else ()); - (let uu___23 = - solve_branches - wl3 rs1 rs2 in - FStar_Compiler_Util.bind_opt - uu___23 - (fun uu___24 -> - match uu___24 - with - | (r, wl4) - -> - FStar_Pervasives_Native.Some - (((scope, - prob) :: - (FStar_Compiler_List.op_At - wprobs r)), - wl4)))))))))) - | ([], []) -> FStar_Pervasives_Native.Some ([], wl1) - | uu___11 -> FStar_Pervasives_Native.None in - let uu___11 = solve_branches wl brs1 brs2 in - (match uu___11 with - | FStar_Pervasives_Native.None -> - if wl.smt_ok - then by_smt () - else - (let uu___13 = - FStar_Thunk.mkv "Tm_match branches don't match" in - giveup wl uu___13 orig) - | FStar_Pervasives_Native.Some (sub_probs, wl1) -> - let uu___12 = - mk_t_problem wl1 [] orig s1 - FStar_TypeChecker_Common.EQ s2 - FStar_Pervasives_Native.None "match scrutinee" in - (match uu___12 with - | (sc_prob, wl2) -> - let sub_probs1 = ([], sc_prob) :: sub_probs in - let formula = - let uu___13 = - FStar_Compiler_List.map - (fun uu___14 -> - match uu___14 with - | (scope, p) -> - FStar_TypeChecker_Env.close_forall - (p_env wl2 orig) scope (p_guard p)) - sub_probs1 in - FStar_Syntax_Util.mk_conj_l uu___13 in - let tx = FStar_Syntax_Unionfind.new_transaction () in - let wl3 = - solve_prob orig - (FStar_Pervasives_Native.Some formula) [] wl2 in - let uu___13 = - let uu___14 = - let uu___15 = - FStar_Compiler_List.map - FStar_Pervasives_Native.snd sub_probs1 in - attempt uu___15 - { - attempting = (wl3.attempting); - wl_deferred = (wl3.wl_deferred); - wl_deferred_to_tac = - (wl3.wl_deferred_to_tac); - ctr = (wl3.ctr); - defer_ok = (wl3.defer_ok); - smt_ok = false; - umax_heuristic_ok = (wl3.umax_heuristic_ok); - tcenv = (wl3.tcenv); - wl_implicits = (wl3.wl_implicits); - repr_subcomp_allowed = - (wl3.repr_subcomp_allowed); - typeclass_variables = - (wl3.typeclass_variables) - } in - solve uu___14 in - (match uu___13 with - | Success (ds, ds', imp) -> - (FStar_Syntax_Unionfind.commit tx; - Success (ds, ds', imp)) - | Failed uu___14 -> - (FStar_Syntax_Unionfind.rollback tx; - if wl3.smt_ok - then by_smt () - else - (let uu___17 = - FStar_Thunk.mkv - "Could not unify matches without SMT" in - giveup wl3 uu___17 orig))))) - | (FStar_Syntax_Syntax.Tm_match uu___7, uu___8) -> - let head1 = - let uu___9 = FStar_Syntax_Util.head_and_args t1 in - FStar_Pervasives_Native.fst uu___9 in - let head2 = - let uu___9 = FStar_Syntax_Util.head_and_args t2 in - FStar_Pervasives_Native.fst uu___9 in - ((let uu___10 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___10 - then - let uu___11 = - let uu___12 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - problem.FStar_TypeChecker_Common.pid in - let uu___13 = - let uu___14 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - wl.smt_ok in - let uu___15 = - let uu___16 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head1 in - let uu___17 = - let uu___18 = - let uu___19 = - FStar_TypeChecker_Env.is_interpreted - wl.tcenv head1 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___19 in - let uu___19 = - let uu___20 = - let uu___21 = no_free_uvars t1 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___21 in - let uu___21 = - let uu___22 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head2 in - let uu___23 = - let uu___24 = - let uu___25 = - FStar_TypeChecker_Env.is_interpreted - wl.tcenv head2 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___25 in - let uu___25 = - let uu___26 = - let uu___27 = no_free_uvars t2 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___27 in - [uu___26] in - uu___24 :: uu___25 in - uu___22 :: uu___23 in - uu___20 :: uu___21 in - uu___18 :: uu___19 in - uu___16 :: uu___17 in - uu___14 :: uu___15 in - uu___12 :: uu___13 in - FStar_Compiler_Util.print - ">> (%s) (smtok=%s)\n>>> head1 = %s [interpreted=%s; no_free_uvars=%s]\n>>> head2 = %s [interpreted=%s; no_free_uvars=%s]\n" - uu___11 - else ()); - (let equal t11 t21 = - let env = p_env wl orig in - let r = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in - match r with - | FStar_TypeChecker_TermEqAndSimplify.Equal -> true - | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false - | FStar_TypeChecker_TermEqAndSimplify.Unknown -> - let steps = - [FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.Iota] in - let t12 = - norm_with_steps - "FStar.TypeChecker.Rel.norm_with_steps.2" steps - env t11 in - let t22 = - norm_with_steps - "FStar.TypeChecker.Rel.norm_with_steps.3" steps - env t21 in - let uu___10 = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 - t22 in - uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in - let uu___10 = - ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || - (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) - && - (problem.FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.EQ) in - if uu___10 - then - let solve_with_smt uu___11 = - let uu___12 = - let uu___13 = equal t1 t2 in - if uu___13 - then (FStar_Pervasives_Native.None, wl) - else - (let uu___15 = mk_eq2 wl orig t1 t2 in - match uu___15 with - | (g, wl1) -> - ((FStar_Pervasives_Native.Some g), wl1)) in - match uu___12 with - | (guard, wl1) -> - let uu___13 = solve_prob orig guard [] wl1 in - solve uu___13 in - let uu___11 = (no_free_uvars t1) && (no_free_uvars t2) in - (if uu___11 - then - let uu___12 = - (Prims.op_Negation wl.smt_ok) || - (FStar_Options.ml_ish ()) in - (if uu___12 - then - let uu___13 = equal t1 t2 in - (if uu___13 - then - let uu___14 = - solve_prob orig FStar_Pervasives_Native.None - [] wl in - solve uu___14 - else - rigid_rigid_delta problem wl head1 head2 t1 t2) - else solve_with_smt ()) - else - (let uu___13 = - (Prims.op_Negation wl.smt_ok) || - (FStar_Options.ml_ish ()) in - if uu___13 - then rigid_rigid_delta problem wl head1 head2 t1 t2 - else - try_solve_then_or_else wl - (fun wl_empty -> - rigid_rigid_delta problem wl_empty head1 head2 - t1 t2) (fun wl1 -> solve wl1) - (fun uu___15 -> solve_with_smt ()))) - else rigid_rigid_delta problem wl head1 head2 t1 t2)) - | (FStar_Syntax_Syntax.Tm_uinst uu___7, uu___8) -> - let head1 = - let uu___9 = FStar_Syntax_Util.head_and_args t1 in - FStar_Pervasives_Native.fst uu___9 in - let head2 = - let uu___9 = FStar_Syntax_Util.head_and_args t2 in - FStar_Pervasives_Native.fst uu___9 in - ((let uu___10 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___10 - then - let uu___11 = - let uu___12 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - problem.FStar_TypeChecker_Common.pid in - let uu___13 = - let uu___14 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - wl.smt_ok in - let uu___15 = - let uu___16 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head1 in - let uu___17 = - let uu___18 = - let uu___19 = - FStar_TypeChecker_Env.is_interpreted - wl.tcenv head1 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___19 in - let uu___19 = - let uu___20 = - let uu___21 = no_free_uvars t1 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___21 in - let uu___21 = - let uu___22 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head2 in - let uu___23 = - let uu___24 = - let uu___25 = - FStar_TypeChecker_Env.is_interpreted - wl.tcenv head2 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___25 in - let uu___25 = - let uu___26 = - let uu___27 = no_free_uvars t2 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___27 in - [uu___26] in - uu___24 :: uu___25 in - uu___22 :: uu___23 in - uu___20 :: uu___21 in - uu___18 :: uu___19 in - uu___16 :: uu___17 in - uu___14 :: uu___15 in - uu___12 :: uu___13 in - FStar_Compiler_Util.print - ">> (%s) (smtok=%s)\n>>> head1 = %s [interpreted=%s; no_free_uvars=%s]\n>>> head2 = %s [interpreted=%s; no_free_uvars=%s]\n" - uu___11 - else ()); - (let equal t11 t21 = - let env = p_env wl orig in - let r = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in - match r with - | FStar_TypeChecker_TermEqAndSimplify.Equal -> true - | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false - | FStar_TypeChecker_TermEqAndSimplify.Unknown -> - let steps = - [FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.Iota] in - let t12 = - norm_with_steps - "FStar.TypeChecker.Rel.norm_with_steps.2" steps - env t11 in - let t22 = - norm_with_steps - "FStar.TypeChecker.Rel.norm_with_steps.3" steps - env t21 in - let uu___10 = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 - t22 in - uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in - let uu___10 = - ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || - (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) - && - (problem.FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.EQ) in - if uu___10 - then - let solve_with_smt uu___11 = - let uu___12 = - let uu___13 = equal t1 t2 in - if uu___13 - then (FStar_Pervasives_Native.None, wl) - else - (let uu___15 = mk_eq2 wl orig t1 t2 in - match uu___15 with - | (g, wl1) -> - ((FStar_Pervasives_Native.Some g), wl1)) in - match uu___12 with - | (guard, wl1) -> - let uu___13 = solve_prob orig guard [] wl1 in - solve uu___13 in - let uu___11 = (no_free_uvars t1) && (no_free_uvars t2) in - (if uu___11 - then - let uu___12 = - (Prims.op_Negation wl.smt_ok) || - (FStar_Options.ml_ish ()) in - (if uu___12 - then - let uu___13 = equal t1 t2 in - (if uu___13 - then - let uu___14 = - solve_prob orig FStar_Pervasives_Native.None - [] wl in - solve uu___14 - else - rigid_rigid_delta problem wl head1 head2 t1 t2) - else solve_with_smt ()) - else - (let uu___13 = - (Prims.op_Negation wl.smt_ok) || - (FStar_Options.ml_ish ()) in - if uu___13 - then rigid_rigid_delta problem wl head1 head2 t1 t2 - else - try_solve_then_or_else wl - (fun wl_empty -> - rigid_rigid_delta problem wl_empty head1 head2 - t1 t2) (fun wl1 -> solve wl1) - (fun uu___15 -> solve_with_smt ()))) - else rigid_rigid_delta problem wl head1 head2 t1 t2)) - | (FStar_Syntax_Syntax.Tm_name uu___7, uu___8) -> - let head1 = - let uu___9 = FStar_Syntax_Util.head_and_args t1 in - FStar_Pervasives_Native.fst uu___9 in - let head2 = - let uu___9 = FStar_Syntax_Util.head_and_args t2 in - FStar_Pervasives_Native.fst uu___9 in - ((let uu___10 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___10 - then - let uu___11 = - let uu___12 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - problem.FStar_TypeChecker_Common.pid in - let uu___13 = - let uu___14 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - wl.smt_ok in - let uu___15 = - let uu___16 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head1 in - let uu___17 = - let uu___18 = - let uu___19 = - FStar_TypeChecker_Env.is_interpreted - wl.tcenv head1 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___19 in - let uu___19 = - let uu___20 = - let uu___21 = no_free_uvars t1 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___21 in - let uu___21 = - let uu___22 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head2 in - let uu___23 = - let uu___24 = - let uu___25 = - FStar_TypeChecker_Env.is_interpreted - wl.tcenv head2 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___25 in - let uu___25 = - let uu___26 = - let uu___27 = no_free_uvars t2 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___27 in - [uu___26] in - uu___24 :: uu___25 in - uu___22 :: uu___23 in - uu___20 :: uu___21 in - uu___18 :: uu___19 in - uu___16 :: uu___17 in - uu___14 :: uu___15 in - uu___12 :: uu___13 in - FStar_Compiler_Util.print - ">> (%s) (smtok=%s)\n>>> head1 = %s [interpreted=%s; no_free_uvars=%s]\n>>> head2 = %s [interpreted=%s; no_free_uvars=%s]\n" - uu___11 - else ()); - (let equal t11 t21 = - let env = p_env wl orig in - let r = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in - match r with - | FStar_TypeChecker_TermEqAndSimplify.Equal -> true - | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false - | FStar_TypeChecker_TermEqAndSimplify.Unknown -> - let steps = - [FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.Iota] in - let t12 = - norm_with_steps - "FStar.TypeChecker.Rel.norm_with_steps.2" steps - env t11 in - let t22 = - norm_with_steps - "FStar.TypeChecker.Rel.norm_with_steps.3" steps - env t21 in - let uu___10 = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 - t22 in - uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in - let uu___10 = - ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || - (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) - && - (problem.FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.EQ) in - if uu___10 - then - let solve_with_smt uu___11 = - let uu___12 = - let uu___13 = equal t1 t2 in - if uu___13 - then (FStar_Pervasives_Native.None, wl) - else - (let uu___15 = mk_eq2 wl orig t1 t2 in - match uu___15 with - | (g, wl1) -> - ((FStar_Pervasives_Native.Some g), wl1)) in - match uu___12 with - | (guard, wl1) -> - let uu___13 = solve_prob orig guard [] wl1 in - solve uu___13 in - let uu___11 = (no_free_uvars t1) && (no_free_uvars t2) in - (if uu___11 - then - let uu___12 = - (Prims.op_Negation wl.smt_ok) || - (FStar_Options.ml_ish ()) in - (if uu___12 - then - let uu___13 = equal t1 t2 in - (if uu___13 - then - let uu___14 = - solve_prob orig FStar_Pervasives_Native.None - [] wl in - solve uu___14 - else - rigid_rigid_delta problem wl head1 head2 t1 t2) - else solve_with_smt ()) - else - (let uu___13 = - (Prims.op_Negation wl.smt_ok) || - (FStar_Options.ml_ish ()) in - if uu___13 - then rigid_rigid_delta problem wl head1 head2 t1 t2 - else - try_solve_then_or_else wl - (fun wl_empty -> - rigid_rigid_delta problem wl_empty head1 head2 - t1 t2) (fun wl1 -> solve wl1) - (fun uu___15 -> solve_with_smt ()))) - else rigid_rigid_delta problem wl head1 head2 t1 t2)) - | (FStar_Syntax_Syntax.Tm_constant uu___7, uu___8) -> - let head1 = - let uu___9 = FStar_Syntax_Util.head_and_args t1 in - FStar_Pervasives_Native.fst uu___9 in - let head2 = - let uu___9 = FStar_Syntax_Util.head_and_args t2 in - FStar_Pervasives_Native.fst uu___9 in - ((let uu___10 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___10 - then - let uu___11 = - let uu___12 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - problem.FStar_TypeChecker_Common.pid in - let uu___13 = - let uu___14 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - wl.smt_ok in - let uu___15 = - let uu___16 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head1 in - let uu___17 = - let uu___18 = - let uu___19 = - FStar_TypeChecker_Env.is_interpreted - wl.tcenv head1 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___19 in - let uu___19 = - let uu___20 = - let uu___21 = no_free_uvars t1 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___21 in - let uu___21 = - let uu___22 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head2 in - let uu___23 = - let uu___24 = - let uu___25 = - FStar_TypeChecker_Env.is_interpreted - wl.tcenv head2 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___25 in - let uu___25 = - let uu___26 = - let uu___27 = no_free_uvars t2 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___27 in - [uu___26] in - uu___24 :: uu___25 in - uu___22 :: uu___23 in - uu___20 :: uu___21 in - uu___18 :: uu___19 in - uu___16 :: uu___17 in - uu___14 :: uu___15 in - uu___12 :: uu___13 in - FStar_Compiler_Util.print - ">> (%s) (smtok=%s)\n>>> head1 = %s [interpreted=%s; no_free_uvars=%s]\n>>> head2 = %s [interpreted=%s; no_free_uvars=%s]\n" - uu___11 - else ()); - (let equal t11 t21 = - let env = p_env wl orig in - let r = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in - match r with - | FStar_TypeChecker_TermEqAndSimplify.Equal -> true - | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false - | FStar_TypeChecker_TermEqAndSimplify.Unknown -> - let steps = - [FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.Iota] in - let t12 = - norm_with_steps - "FStar.TypeChecker.Rel.norm_with_steps.2" steps - env t11 in - let t22 = - norm_with_steps - "FStar.TypeChecker.Rel.norm_with_steps.3" steps - env t21 in - let uu___10 = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 - t22 in - uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in - let uu___10 = - ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || - (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) - && - (problem.FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.EQ) in - if uu___10 - then - let solve_with_smt uu___11 = - let uu___12 = - let uu___13 = equal t1 t2 in - if uu___13 - then (FStar_Pervasives_Native.None, wl) - else - (let uu___15 = mk_eq2 wl orig t1 t2 in - match uu___15 with - | (g, wl1) -> - ((FStar_Pervasives_Native.Some g), wl1)) in - match uu___12 with - | (guard, wl1) -> - let uu___13 = solve_prob orig guard [] wl1 in - solve uu___13 in - let uu___11 = (no_free_uvars t1) && (no_free_uvars t2) in - (if uu___11 - then - let uu___12 = - (Prims.op_Negation wl.smt_ok) || - (FStar_Options.ml_ish ()) in - (if uu___12 - then - let uu___13 = equal t1 t2 in - (if uu___13 - then - let uu___14 = - solve_prob orig FStar_Pervasives_Native.None - [] wl in - solve uu___14 - else - rigid_rigid_delta problem wl head1 head2 t1 t2) - else solve_with_smt ()) - else - (let uu___13 = - (Prims.op_Negation wl.smt_ok) || - (FStar_Options.ml_ish ()) in - if uu___13 - then rigid_rigid_delta problem wl head1 head2 t1 t2 - else - try_solve_then_or_else wl - (fun wl_empty -> - rigid_rigid_delta problem wl_empty head1 head2 - t1 t2) (fun wl1 -> solve wl1) - (fun uu___15 -> solve_with_smt ()))) - else rigid_rigid_delta problem wl head1 head2 t1 t2)) - | (FStar_Syntax_Syntax.Tm_fvar uu___7, uu___8) -> - let head1 = - let uu___9 = FStar_Syntax_Util.head_and_args t1 in - FStar_Pervasives_Native.fst uu___9 in - let head2 = - let uu___9 = FStar_Syntax_Util.head_and_args t2 in - FStar_Pervasives_Native.fst uu___9 in - ((let uu___10 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___10 - then - let uu___11 = - let uu___12 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - problem.FStar_TypeChecker_Common.pid in - let uu___13 = - let uu___14 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - wl.smt_ok in - let uu___15 = - let uu___16 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head1 in - let uu___17 = - let uu___18 = - let uu___19 = - FStar_TypeChecker_Env.is_interpreted - wl.tcenv head1 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___19 in - let uu___19 = - let uu___20 = - let uu___21 = no_free_uvars t1 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___21 in - let uu___21 = - let uu___22 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head2 in - let uu___23 = - let uu___24 = - let uu___25 = - FStar_TypeChecker_Env.is_interpreted - wl.tcenv head2 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___25 in - let uu___25 = - let uu___26 = - let uu___27 = no_free_uvars t2 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___27 in - [uu___26] in - uu___24 :: uu___25 in - uu___22 :: uu___23 in - uu___20 :: uu___21 in - uu___18 :: uu___19 in - uu___16 :: uu___17 in - uu___14 :: uu___15 in - uu___12 :: uu___13 in - FStar_Compiler_Util.print - ">> (%s) (smtok=%s)\n>>> head1 = %s [interpreted=%s; no_free_uvars=%s]\n>>> head2 = %s [interpreted=%s; no_free_uvars=%s]\n" - uu___11 - else ()); - (let equal t11 t21 = - let env = p_env wl orig in - let r = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in - match r with - | FStar_TypeChecker_TermEqAndSimplify.Equal -> true - | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false - | FStar_TypeChecker_TermEqAndSimplify.Unknown -> - let steps = - [FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.Iota] in - let t12 = - norm_with_steps - "FStar.TypeChecker.Rel.norm_with_steps.2" steps - env t11 in - let t22 = - norm_with_steps - "FStar.TypeChecker.Rel.norm_with_steps.3" steps - env t21 in - let uu___10 = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 - t22 in - uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in - let uu___10 = - ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || - (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) - && - (problem.FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.EQ) in - if uu___10 - then - let solve_with_smt uu___11 = - let uu___12 = - let uu___13 = equal t1 t2 in - if uu___13 - then (FStar_Pervasives_Native.None, wl) - else - (let uu___15 = mk_eq2 wl orig t1 t2 in - match uu___15 with - | (g, wl1) -> - ((FStar_Pervasives_Native.Some g), wl1)) in - match uu___12 with - | (guard, wl1) -> - let uu___13 = solve_prob orig guard [] wl1 in - solve uu___13 in - let uu___11 = (no_free_uvars t1) && (no_free_uvars t2) in - (if uu___11 - then - let uu___12 = - (Prims.op_Negation wl.smt_ok) || - (FStar_Options.ml_ish ()) in - (if uu___12 - then - let uu___13 = equal t1 t2 in - (if uu___13 - then - let uu___14 = - solve_prob orig FStar_Pervasives_Native.None - [] wl in - solve uu___14 - else - rigid_rigid_delta problem wl head1 head2 t1 t2) - else solve_with_smt ()) - else - (let uu___13 = - (Prims.op_Negation wl.smt_ok) || - (FStar_Options.ml_ish ()) in - if uu___13 - then rigid_rigid_delta problem wl head1 head2 t1 t2 - else - try_solve_then_or_else wl - (fun wl_empty -> - rigid_rigid_delta problem wl_empty head1 head2 - t1 t2) (fun wl1 -> solve wl1) - (fun uu___15 -> solve_with_smt ()))) - else rigid_rigid_delta problem wl head1 head2 t1 t2)) - | (FStar_Syntax_Syntax.Tm_app uu___7, uu___8) -> - let head1 = - let uu___9 = FStar_Syntax_Util.head_and_args t1 in - FStar_Pervasives_Native.fst uu___9 in - let head2 = - let uu___9 = FStar_Syntax_Util.head_and_args t2 in - FStar_Pervasives_Native.fst uu___9 in - ((let uu___10 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___10 - then - let uu___11 = - let uu___12 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - problem.FStar_TypeChecker_Common.pid in - let uu___13 = - let uu___14 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - wl.smt_ok in - let uu___15 = - let uu___16 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head1 in - let uu___17 = - let uu___18 = - let uu___19 = - FStar_TypeChecker_Env.is_interpreted - wl.tcenv head1 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___19 in - let uu___19 = - let uu___20 = - let uu___21 = no_free_uvars t1 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___21 in - let uu___21 = - let uu___22 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head2 in - let uu___23 = - let uu___24 = - let uu___25 = - FStar_TypeChecker_Env.is_interpreted - wl.tcenv head2 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___25 in - let uu___25 = - let uu___26 = - let uu___27 = no_free_uvars t2 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___27 in - [uu___26] in - uu___24 :: uu___25 in - uu___22 :: uu___23 in - uu___20 :: uu___21 in - uu___18 :: uu___19 in - uu___16 :: uu___17 in - uu___14 :: uu___15 in - uu___12 :: uu___13 in - FStar_Compiler_Util.print - ">> (%s) (smtok=%s)\n>>> head1 = %s [interpreted=%s; no_free_uvars=%s]\n>>> head2 = %s [interpreted=%s; no_free_uvars=%s]\n" - uu___11 - else ()); - (let equal t11 t21 = - let env = p_env wl orig in - let r = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in - match r with - | FStar_TypeChecker_TermEqAndSimplify.Equal -> true - | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false - | FStar_TypeChecker_TermEqAndSimplify.Unknown -> - let steps = - [FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.Iota] in - let t12 = - norm_with_steps - "FStar.TypeChecker.Rel.norm_with_steps.2" steps - env t11 in - let t22 = - norm_with_steps - "FStar.TypeChecker.Rel.norm_with_steps.3" steps - env t21 in - let uu___10 = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 - t22 in - uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in - let uu___10 = - ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || - (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) - && - (problem.FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.EQ) in - if uu___10 - then - let solve_with_smt uu___11 = - let uu___12 = - let uu___13 = equal t1 t2 in - if uu___13 - then (FStar_Pervasives_Native.None, wl) - else - (let uu___15 = mk_eq2 wl orig t1 t2 in - match uu___15 with - | (g, wl1) -> - ((FStar_Pervasives_Native.Some g), wl1)) in - match uu___12 with - | (guard, wl1) -> - let uu___13 = solve_prob orig guard [] wl1 in - solve uu___13 in - let uu___11 = (no_free_uvars t1) && (no_free_uvars t2) in - (if uu___11 - then - let uu___12 = - (Prims.op_Negation wl.smt_ok) || - (FStar_Options.ml_ish ()) in - (if uu___12 - then - let uu___13 = equal t1 t2 in - (if uu___13 - then - let uu___14 = - solve_prob orig FStar_Pervasives_Native.None - [] wl in - solve uu___14 - else - rigid_rigid_delta problem wl head1 head2 t1 t2) - else solve_with_smt ()) - else - (let uu___13 = - (Prims.op_Negation wl.smt_ok) || - (FStar_Options.ml_ish ()) in - if uu___13 - then rigid_rigid_delta problem wl head1 head2 t1 t2 - else - try_solve_then_or_else wl - (fun wl_empty -> - rigid_rigid_delta problem wl_empty head1 head2 - t1 t2) (fun wl1 -> solve wl1) - (fun uu___15 -> solve_with_smt ()))) - else rigid_rigid_delta problem wl head1 head2 t1 t2)) - | (uu___7, FStar_Syntax_Syntax.Tm_match uu___8) -> - let head1 = - let uu___9 = FStar_Syntax_Util.head_and_args t1 in - FStar_Pervasives_Native.fst uu___9 in - let head2 = - let uu___9 = FStar_Syntax_Util.head_and_args t2 in - FStar_Pervasives_Native.fst uu___9 in - ((let uu___10 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___10 - then - let uu___11 = - let uu___12 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - problem.FStar_TypeChecker_Common.pid in - let uu___13 = - let uu___14 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - wl.smt_ok in - let uu___15 = - let uu___16 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head1 in - let uu___17 = - let uu___18 = - let uu___19 = - FStar_TypeChecker_Env.is_interpreted - wl.tcenv head1 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___19 in - let uu___19 = - let uu___20 = - let uu___21 = no_free_uvars t1 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___21 in - let uu___21 = - let uu___22 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head2 in - let uu___23 = - let uu___24 = - let uu___25 = - FStar_TypeChecker_Env.is_interpreted - wl.tcenv head2 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___25 in - let uu___25 = - let uu___26 = - let uu___27 = no_free_uvars t2 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___27 in - [uu___26] in - uu___24 :: uu___25 in - uu___22 :: uu___23 in - uu___20 :: uu___21 in - uu___18 :: uu___19 in - uu___16 :: uu___17 in - uu___14 :: uu___15 in - uu___12 :: uu___13 in - FStar_Compiler_Util.print - ">> (%s) (smtok=%s)\n>>> head1 = %s [interpreted=%s; no_free_uvars=%s]\n>>> head2 = %s [interpreted=%s; no_free_uvars=%s]\n" - uu___11 - else ()); - (let equal t11 t21 = - let env = p_env wl orig in - let r = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in - match r with - | FStar_TypeChecker_TermEqAndSimplify.Equal -> true - | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false - | FStar_TypeChecker_TermEqAndSimplify.Unknown -> - let steps = - [FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.Iota] in - let t12 = - norm_with_steps - "FStar.TypeChecker.Rel.norm_with_steps.2" steps - env t11 in - let t22 = - norm_with_steps - "FStar.TypeChecker.Rel.norm_with_steps.3" steps - env t21 in - let uu___10 = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 - t22 in - uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in - let uu___10 = - ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || - (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) - && - (problem.FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.EQ) in - if uu___10 - then - let solve_with_smt uu___11 = - let uu___12 = - let uu___13 = equal t1 t2 in - if uu___13 - then (FStar_Pervasives_Native.None, wl) - else - (let uu___15 = mk_eq2 wl orig t1 t2 in - match uu___15 with - | (g, wl1) -> - ((FStar_Pervasives_Native.Some g), wl1)) in - match uu___12 with - | (guard, wl1) -> - let uu___13 = solve_prob orig guard [] wl1 in - solve uu___13 in - let uu___11 = (no_free_uvars t1) && (no_free_uvars t2) in - (if uu___11 - then - let uu___12 = - (Prims.op_Negation wl.smt_ok) || - (FStar_Options.ml_ish ()) in - (if uu___12 - then - let uu___13 = equal t1 t2 in - (if uu___13 - then - let uu___14 = - solve_prob orig FStar_Pervasives_Native.None - [] wl in - solve uu___14 - else - rigid_rigid_delta problem wl head1 head2 t1 t2) - else solve_with_smt ()) - else - (let uu___13 = - (Prims.op_Negation wl.smt_ok) || - (FStar_Options.ml_ish ()) in - if uu___13 - then rigid_rigid_delta problem wl head1 head2 t1 t2 - else - try_solve_then_or_else wl - (fun wl_empty -> - rigid_rigid_delta problem wl_empty head1 head2 - t1 t2) (fun wl1 -> solve wl1) - (fun uu___15 -> solve_with_smt ()))) - else rigid_rigid_delta problem wl head1 head2 t1 t2)) - | (uu___7, FStar_Syntax_Syntax.Tm_uinst uu___8) -> - let head1 = - let uu___9 = FStar_Syntax_Util.head_and_args t1 in - FStar_Pervasives_Native.fst uu___9 in - let head2 = - let uu___9 = FStar_Syntax_Util.head_and_args t2 in - FStar_Pervasives_Native.fst uu___9 in - ((let uu___10 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___10 - then - let uu___11 = - let uu___12 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - problem.FStar_TypeChecker_Common.pid in - let uu___13 = - let uu___14 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - wl.smt_ok in - let uu___15 = - let uu___16 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head1 in - let uu___17 = - let uu___18 = - let uu___19 = - FStar_TypeChecker_Env.is_interpreted - wl.tcenv head1 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___19 in - let uu___19 = - let uu___20 = - let uu___21 = no_free_uvars t1 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___21 in - let uu___21 = - let uu___22 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head2 in - let uu___23 = - let uu___24 = - let uu___25 = - FStar_TypeChecker_Env.is_interpreted - wl.tcenv head2 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___25 in - let uu___25 = - let uu___26 = - let uu___27 = no_free_uvars t2 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___27 in - [uu___26] in - uu___24 :: uu___25 in - uu___22 :: uu___23 in - uu___20 :: uu___21 in - uu___18 :: uu___19 in - uu___16 :: uu___17 in - uu___14 :: uu___15 in - uu___12 :: uu___13 in - FStar_Compiler_Util.print - ">> (%s) (smtok=%s)\n>>> head1 = %s [interpreted=%s; no_free_uvars=%s]\n>>> head2 = %s [interpreted=%s; no_free_uvars=%s]\n" - uu___11 - else ()); - (let equal t11 t21 = - let env = p_env wl orig in - let r = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in - match r with - | FStar_TypeChecker_TermEqAndSimplify.Equal -> true - | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false - | FStar_TypeChecker_TermEqAndSimplify.Unknown -> - let steps = - [FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.Iota] in - let t12 = - norm_with_steps - "FStar.TypeChecker.Rel.norm_with_steps.2" steps - env t11 in - let t22 = - norm_with_steps - "FStar.TypeChecker.Rel.norm_with_steps.3" steps - env t21 in - let uu___10 = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 - t22 in - uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in - let uu___10 = - ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || - (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) - && - (problem.FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.EQ) in - if uu___10 - then - let solve_with_smt uu___11 = - let uu___12 = - let uu___13 = equal t1 t2 in - if uu___13 - then (FStar_Pervasives_Native.None, wl) - else - (let uu___15 = mk_eq2 wl orig t1 t2 in - match uu___15 with - | (g, wl1) -> - ((FStar_Pervasives_Native.Some g), wl1)) in - match uu___12 with - | (guard, wl1) -> - let uu___13 = solve_prob orig guard [] wl1 in - solve uu___13 in - let uu___11 = (no_free_uvars t1) && (no_free_uvars t2) in - (if uu___11 - then - let uu___12 = - (Prims.op_Negation wl.smt_ok) || - (FStar_Options.ml_ish ()) in - (if uu___12 - then - let uu___13 = equal t1 t2 in - (if uu___13 - then - let uu___14 = - solve_prob orig FStar_Pervasives_Native.None - [] wl in - solve uu___14 - else - rigid_rigid_delta problem wl head1 head2 t1 t2) - else solve_with_smt ()) - else - (let uu___13 = - (Prims.op_Negation wl.smt_ok) || - (FStar_Options.ml_ish ()) in - if uu___13 - then rigid_rigid_delta problem wl head1 head2 t1 t2 - else - try_solve_then_or_else wl - (fun wl_empty -> - rigid_rigid_delta problem wl_empty head1 head2 - t1 t2) (fun wl1 -> solve wl1) - (fun uu___15 -> solve_with_smt ()))) - else rigid_rigid_delta problem wl head1 head2 t1 t2)) - | (uu___7, FStar_Syntax_Syntax.Tm_name uu___8) -> - let head1 = - let uu___9 = FStar_Syntax_Util.head_and_args t1 in - FStar_Pervasives_Native.fst uu___9 in - let head2 = - let uu___9 = FStar_Syntax_Util.head_and_args t2 in - FStar_Pervasives_Native.fst uu___9 in - ((let uu___10 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___10 - then - let uu___11 = - let uu___12 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - problem.FStar_TypeChecker_Common.pid in - let uu___13 = - let uu___14 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - wl.smt_ok in - let uu___15 = - let uu___16 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head1 in - let uu___17 = - let uu___18 = - let uu___19 = - FStar_TypeChecker_Env.is_interpreted - wl.tcenv head1 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___19 in - let uu___19 = - let uu___20 = - let uu___21 = no_free_uvars t1 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___21 in - let uu___21 = - let uu___22 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head2 in - let uu___23 = - let uu___24 = - let uu___25 = - FStar_TypeChecker_Env.is_interpreted - wl.tcenv head2 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___25 in - let uu___25 = - let uu___26 = - let uu___27 = no_free_uvars t2 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___27 in - [uu___26] in - uu___24 :: uu___25 in - uu___22 :: uu___23 in - uu___20 :: uu___21 in - uu___18 :: uu___19 in - uu___16 :: uu___17 in - uu___14 :: uu___15 in - uu___12 :: uu___13 in - FStar_Compiler_Util.print - ">> (%s) (smtok=%s)\n>>> head1 = %s [interpreted=%s; no_free_uvars=%s]\n>>> head2 = %s [interpreted=%s; no_free_uvars=%s]\n" - uu___11 - else ()); - (let equal t11 t21 = - let env = p_env wl orig in - let r = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in - match r with - | FStar_TypeChecker_TermEqAndSimplify.Equal -> true - | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false - | FStar_TypeChecker_TermEqAndSimplify.Unknown -> - let steps = - [FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.Iota] in - let t12 = - norm_with_steps - "FStar.TypeChecker.Rel.norm_with_steps.2" steps - env t11 in - let t22 = - norm_with_steps - "FStar.TypeChecker.Rel.norm_with_steps.3" steps - env t21 in - let uu___10 = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 - t22 in - uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in - let uu___10 = - ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || - (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) - && - (problem.FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.EQ) in - if uu___10 - then - let solve_with_smt uu___11 = - let uu___12 = - let uu___13 = equal t1 t2 in - if uu___13 - then (FStar_Pervasives_Native.None, wl) - else - (let uu___15 = mk_eq2 wl orig t1 t2 in - match uu___15 with - | (g, wl1) -> - ((FStar_Pervasives_Native.Some g), wl1)) in - match uu___12 with - | (guard, wl1) -> - let uu___13 = solve_prob orig guard [] wl1 in - solve uu___13 in - let uu___11 = (no_free_uvars t1) && (no_free_uvars t2) in - (if uu___11 - then - let uu___12 = - (Prims.op_Negation wl.smt_ok) || - (FStar_Options.ml_ish ()) in - (if uu___12 - then - let uu___13 = equal t1 t2 in - (if uu___13 - then - let uu___14 = - solve_prob orig FStar_Pervasives_Native.None - [] wl in - solve uu___14 - else - rigid_rigid_delta problem wl head1 head2 t1 t2) - else solve_with_smt ()) - else - (let uu___13 = - (Prims.op_Negation wl.smt_ok) || - (FStar_Options.ml_ish ()) in - if uu___13 - then rigid_rigid_delta problem wl head1 head2 t1 t2 - else - try_solve_then_or_else wl - (fun wl_empty -> - rigid_rigid_delta problem wl_empty head1 head2 - t1 t2) (fun wl1 -> solve wl1) - (fun uu___15 -> solve_with_smt ()))) - else rigid_rigid_delta problem wl head1 head2 t1 t2)) - | (uu___7, FStar_Syntax_Syntax.Tm_constant uu___8) -> - let head1 = - let uu___9 = FStar_Syntax_Util.head_and_args t1 in - FStar_Pervasives_Native.fst uu___9 in - let head2 = - let uu___9 = FStar_Syntax_Util.head_and_args t2 in - FStar_Pervasives_Native.fst uu___9 in - ((let uu___10 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___10 - then - let uu___11 = - let uu___12 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - problem.FStar_TypeChecker_Common.pid in - let uu___13 = - let uu___14 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - wl.smt_ok in - let uu___15 = - let uu___16 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head1 in - let uu___17 = - let uu___18 = - let uu___19 = - FStar_TypeChecker_Env.is_interpreted - wl.tcenv head1 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___19 in - let uu___19 = - let uu___20 = - let uu___21 = no_free_uvars t1 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___21 in - let uu___21 = - let uu___22 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head2 in - let uu___23 = - let uu___24 = - let uu___25 = - FStar_TypeChecker_Env.is_interpreted - wl.tcenv head2 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___25 in - let uu___25 = - let uu___26 = - let uu___27 = no_free_uvars t2 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___27 in - [uu___26] in - uu___24 :: uu___25 in - uu___22 :: uu___23 in - uu___20 :: uu___21 in - uu___18 :: uu___19 in - uu___16 :: uu___17 in - uu___14 :: uu___15 in - uu___12 :: uu___13 in - FStar_Compiler_Util.print - ">> (%s) (smtok=%s)\n>>> head1 = %s [interpreted=%s; no_free_uvars=%s]\n>>> head2 = %s [interpreted=%s; no_free_uvars=%s]\n" - uu___11 - else ()); - (let equal t11 t21 = - let env = p_env wl orig in - let r = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in - match r with - | FStar_TypeChecker_TermEqAndSimplify.Equal -> true - | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false - | FStar_TypeChecker_TermEqAndSimplify.Unknown -> - let steps = - [FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.Iota] in - let t12 = - norm_with_steps - "FStar.TypeChecker.Rel.norm_with_steps.2" steps - env t11 in - let t22 = - norm_with_steps - "FStar.TypeChecker.Rel.norm_with_steps.3" steps - env t21 in - let uu___10 = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 - t22 in - uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in - let uu___10 = - ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || - (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) - && - (problem.FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.EQ) in - if uu___10 - then - let solve_with_smt uu___11 = - let uu___12 = - let uu___13 = equal t1 t2 in - if uu___13 - then (FStar_Pervasives_Native.None, wl) - else - (let uu___15 = mk_eq2 wl orig t1 t2 in - match uu___15 with - | (g, wl1) -> - ((FStar_Pervasives_Native.Some g), wl1)) in - match uu___12 with - | (guard, wl1) -> - let uu___13 = solve_prob orig guard [] wl1 in - solve uu___13 in - let uu___11 = (no_free_uvars t1) && (no_free_uvars t2) in - (if uu___11 - then - let uu___12 = - (Prims.op_Negation wl.smt_ok) || - (FStar_Options.ml_ish ()) in - (if uu___12 - then - let uu___13 = equal t1 t2 in - (if uu___13 - then - let uu___14 = - solve_prob orig FStar_Pervasives_Native.None - [] wl in - solve uu___14 - else - rigid_rigid_delta problem wl head1 head2 t1 t2) - else solve_with_smt ()) - else - (let uu___13 = - (Prims.op_Negation wl.smt_ok) || - (FStar_Options.ml_ish ()) in - if uu___13 - then rigid_rigid_delta problem wl head1 head2 t1 t2 - else - try_solve_then_or_else wl - (fun wl_empty -> - rigid_rigid_delta problem wl_empty head1 head2 - t1 t2) (fun wl1 -> solve wl1) - (fun uu___15 -> solve_with_smt ()))) - else rigid_rigid_delta problem wl head1 head2 t1 t2)) - | (uu___7, FStar_Syntax_Syntax.Tm_fvar uu___8) -> - let head1 = - let uu___9 = FStar_Syntax_Util.head_and_args t1 in - FStar_Pervasives_Native.fst uu___9 in - let head2 = - let uu___9 = FStar_Syntax_Util.head_and_args t2 in - FStar_Pervasives_Native.fst uu___9 in - ((let uu___10 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___10 - then - let uu___11 = - let uu___12 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - problem.FStar_TypeChecker_Common.pid in - let uu___13 = - let uu___14 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - wl.smt_ok in - let uu___15 = - let uu___16 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head1 in - let uu___17 = - let uu___18 = - let uu___19 = - FStar_TypeChecker_Env.is_interpreted - wl.tcenv head1 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___19 in - let uu___19 = - let uu___20 = - let uu___21 = no_free_uvars t1 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___21 in - let uu___21 = - let uu___22 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head2 in - let uu___23 = - let uu___24 = - let uu___25 = - FStar_TypeChecker_Env.is_interpreted - wl.tcenv head2 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___25 in - let uu___25 = - let uu___26 = - let uu___27 = no_free_uvars t2 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___27 in - [uu___26] in - uu___24 :: uu___25 in - uu___22 :: uu___23 in - uu___20 :: uu___21 in - uu___18 :: uu___19 in - uu___16 :: uu___17 in - uu___14 :: uu___15 in - uu___12 :: uu___13 in - FStar_Compiler_Util.print - ">> (%s) (smtok=%s)\n>>> head1 = %s [interpreted=%s; no_free_uvars=%s]\n>>> head2 = %s [interpreted=%s; no_free_uvars=%s]\n" - uu___11 - else ()); - (let equal t11 t21 = - let env = p_env wl orig in - let r = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in - match r with - | FStar_TypeChecker_TermEqAndSimplify.Equal -> true - | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false - | FStar_TypeChecker_TermEqAndSimplify.Unknown -> - let steps = - [FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.Iota] in - let t12 = - norm_with_steps - "FStar.TypeChecker.Rel.norm_with_steps.2" steps - env t11 in - let t22 = - norm_with_steps - "FStar.TypeChecker.Rel.norm_with_steps.3" steps - env t21 in - let uu___10 = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 - t22 in - uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in - let uu___10 = - ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || - (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) - && - (problem.FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.EQ) in - if uu___10 - then - let solve_with_smt uu___11 = - let uu___12 = - let uu___13 = equal t1 t2 in - if uu___13 - then (FStar_Pervasives_Native.None, wl) - else - (let uu___15 = mk_eq2 wl orig t1 t2 in - match uu___15 with - | (g, wl1) -> - ((FStar_Pervasives_Native.Some g), wl1)) in - match uu___12 with - | (guard, wl1) -> - let uu___13 = solve_prob orig guard [] wl1 in - solve uu___13 in - let uu___11 = (no_free_uvars t1) && (no_free_uvars t2) in - (if uu___11 - then - let uu___12 = - (Prims.op_Negation wl.smt_ok) || - (FStar_Options.ml_ish ()) in - (if uu___12 - then - let uu___13 = equal t1 t2 in - (if uu___13 - then - let uu___14 = - solve_prob orig FStar_Pervasives_Native.None - [] wl in - solve uu___14 - else - rigid_rigid_delta problem wl head1 head2 t1 t2) - else solve_with_smt ()) - else - (let uu___13 = - (Prims.op_Negation wl.smt_ok) || - (FStar_Options.ml_ish ()) in - if uu___13 - then rigid_rigid_delta problem wl head1 head2 t1 t2 - else - try_solve_then_or_else wl - (fun wl_empty -> - rigid_rigid_delta problem wl_empty head1 head2 - t1 t2) (fun wl1 -> solve wl1) - (fun uu___15 -> solve_with_smt ()))) - else rigid_rigid_delta problem wl head1 head2 t1 t2)) - | (uu___7, FStar_Syntax_Syntax.Tm_app uu___8) -> - let head1 = - let uu___9 = FStar_Syntax_Util.head_and_args t1 in - FStar_Pervasives_Native.fst uu___9 in - let head2 = - let uu___9 = FStar_Syntax_Util.head_and_args t2 in - FStar_Pervasives_Native.fst uu___9 in - ((let uu___10 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___10 - then - let uu___11 = - let uu___12 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - problem.FStar_TypeChecker_Common.pid in - let uu___13 = - let uu___14 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - wl.smt_ok in - let uu___15 = - let uu___16 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head1 in - let uu___17 = - let uu___18 = - let uu___19 = - FStar_TypeChecker_Env.is_interpreted - wl.tcenv head1 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___19 in - let uu___19 = - let uu___20 = - let uu___21 = no_free_uvars t1 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___21 in - let uu___21 = - let uu___22 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head2 in - let uu___23 = - let uu___24 = - let uu___25 = - FStar_TypeChecker_Env.is_interpreted - wl.tcenv head2 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___25 in - let uu___25 = - let uu___26 = - let uu___27 = no_free_uvars t2 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - uu___27 in - [uu___26] in - uu___24 :: uu___25 in - uu___22 :: uu___23 in - uu___20 :: uu___21 in - uu___18 :: uu___19 in - uu___16 :: uu___17 in - uu___14 :: uu___15 in - uu___12 :: uu___13 in - FStar_Compiler_Util.print - ">> (%s) (smtok=%s)\n>>> head1 = %s [interpreted=%s; no_free_uvars=%s]\n>>> head2 = %s [interpreted=%s; no_free_uvars=%s]\n" - uu___11 - else ()); - (let equal t11 t21 = - let env = p_env wl orig in - let r = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env t11 t21 in - match r with - | FStar_TypeChecker_TermEqAndSimplify.Equal -> true - | FStar_TypeChecker_TermEqAndSimplify.NotEqual -> false - | FStar_TypeChecker_TermEqAndSimplify.Unknown -> - let steps = - [FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.Iota] in - let t12 = - norm_with_steps - "FStar.TypeChecker.Rel.norm_with_steps.2" steps - env t11 in - let t22 = - norm_with_steps - "FStar.TypeChecker.Rel.norm_with_steps.3" steps - env t21 in - let uu___10 = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env t12 - t22 in - uu___10 = FStar_TypeChecker_TermEqAndSimplify.Equal in - let uu___10 = - ((FStar_TypeChecker_Env.is_interpreted wl.tcenv head1) || - (FStar_TypeChecker_Env.is_interpreted wl.tcenv head2)) - && - (problem.FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.EQ) in - if uu___10 - then - let solve_with_smt uu___11 = - let uu___12 = - let uu___13 = equal t1 t2 in - if uu___13 - then (FStar_Pervasives_Native.None, wl) - else - (let uu___15 = mk_eq2 wl orig t1 t2 in - match uu___15 with - | (g, wl1) -> - ((FStar_Pervasives_Native.Some g), wl1)) in - match uu___12 with - | (guard, wl1) -> - let uu___13 = solve_prob orig guard [] wl1 in - solve uu___13 in - let uu___11 = (no_free_uvars t1) && (no_free_uvars t2) in - (if uu___11 - then - let uu___12 = - (Prims.op_Negation wl.smt_ok) || - (FStar_Options.ml_ish ()) in - (if uu___12 - then - let uu___13 = equal t1 t2 in - (if uu___13 - then - let uu___14 = - solve_prob orig FStar_Pervasives_Native.None - [] wl in - solve uu___14 - else - rigid_rigid_delta problem wl head1 head2 t1 t2) - else solve_with_smt ()) - else - (let uu___13 = - (Prims.op_Negation wl.smt_ok) || - (FStar_Options.ml_ish ()) in - if uu___13 - then rigid_rigid_delta problem wl head1 head2 t1 t2 - else - try_solve_then_or_else wl - (fun wl_empty -> - rigid_rigid_delta problem wl_empty head1 head2 - t1 t2) (fun wl1 -> solve wl1) - (fun uu___15 -> solve_with_smt ()))) - else rigid_rigid_delta problem wl head1 head2 t1 t2)) - | (FStar_Syntax_Syntax.Tm_let uu___7, FStar_Syntax_Syntax.Tm_let - uu___8) -> - let uu___9 = FStar_Syntax_Util.term_eq t1 t2 in - if uu___9 - then - let uu___10 = - solve_prob orig FStar_Pervasives_Native.None [] wl in - solve uu___10 - else - (let uu___11 = FStar_Thunk.mkv "Tm_let mismatch" in - giveup wl uu___11 orig) - | (FStar_Syntax_Syntax.Tm_let uu___7, uu___8) -> - let uu___9 = - let uu___10 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term - t1 in - let uu___11 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term - t2 in - let uu___12 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - let uu___13 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t2 in - FStar_Compiler_Util.format4 - "Internal error: unexpected flex-flex of %s and %s\n>>> (%s) -- (%s)" - uu___10 uu___11 uu___12 uu___13 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) t1 - FStar_Errors_Codes.Fatal_UnificationNotWellFormed () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___9) - | (uu___7, FStar_Syntax_Syntax.Tm_let uu___8) -> - let uu___9 = - let uu___10 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term - t1 in - let uu___11 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term - t2 in - let uu___12 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - let uu___13 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t2 in - FStar_Compiler_Util.format4 - "Internal error: unexpected flex-flex of %s and %s\n>>> (%s) -- (%s)" - uu___10 uu___11 uu___12 uu___13 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) t1 - FStar_Errors_Codes.Fatal_UnificationNotWellFormed () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___9) - | (FStar_Syntax_Syntax.Tm_lazy li1, FStar_Syntax_Syntax.Tm_lazy - li2) when - (FStar_Class_Deq.op_Equals_Question - FStar_Syntax_Syntax.deq_lazy_kind - li1.FStar_Syntax_Syntax.lkind - li2.FStar_Syntax_Syntax.lkind) - && (lazy_complete_repr li1.FStar_Syntax_Syntax.lkind) - -> - let uu___7 = - let uu___8 = FStar_Syntax_Util.unfold_lazy li1 in - let uu___9 = FStar_Syntax_Util.unfold_lazy li2 in - { - FStar_TypeChecker_Common.pid = - (problem.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = uu___8; - FStar_TypeChecker_Common.relation = - (problem.FStar_TypeChecker_Common.relation); - FStar_TypeChecker_Common.rhs = uu___9; - FStar_TypeChecker_Common.element = - (problem.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (problem.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (problem.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (problem.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = - (problem.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = - (problem.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = - (problem.FStar_TypeChecker_Common.logical) - } in - solve_t' uu___7 wl - | uu___7 -> - let uu___8 = - FStar_Thunk.mk - (fun uu___9 -> - let uu___10 = - let uu___11 = - FStar_Class_Tagged.tag_of - FStar_Syntax_Syntax.tagged_term t1 in - let uu___12 = - let uu___13 = - FStar_Class_Tagged.tag_of - FStar_Syntax_Syntax.tagged_term t2 in - Prims.strcat " vs " uu___13 in - Prims.strcat uu___11 uu___12 in - Prims.strcat "head tag mismatch: " uu___10) in - giveup wl uu___8 orig)))) -and (solve_c : - FStar_Syntax_Syntax.comp FStar_TypeChecker_Common.problem -> - worklist -> solution) - = - fun problem -> - fun wl -> - let c1 = problem.FStar_TypeChecker_Common.lhs in - let c2 = problem.FStar_TypeChecker_Common.rhs in - let orig = FStar_TypeChecker_Common.CProb problem in - let env = p_env wl orig in - let sub_prob wl1 t1 rel t2 reason = - mk_t_problem wl1 [] orig t1 rel t2 FStar_Pervasives_Native.None - reason in - let solve_eq c1_comp c2_comp g_lift = - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_EQ in - if uu___1 - then - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.mk_Comp c1_comp in - FStar_Class_Show.show FStar_Syntax_Print.showable_comp uu___3 in - let uu___3 = - let uu___4 = FStar_Syntax_Syntax.mk_Comp c2_comp in - FStar_Class_Show.show FStar_Syntax_Print.showable_comp uu___4 in - FStar_Compiler_Util.print2 - "solve_c is using an equality constraint (%s vs %s)\n" uu___2 - uu___3 - else ()); - (let uu___1 = - let uu___2 = - FStar_Ident.lid_equals c1_comp.FStar_Syntax_Syntax.effect_name - c2_comp.FStar_Syntax_Syntax.effect_name in - Prims.op_Negation uu___2 in - if uu___1 - then - let uu___2 = - mklstr - (fun uu___3 -> - let uu___4 = - FStar_Class_Show.show FStar_Ident.showable_lident - c1_comp.FStar_Syntax_Syntax.effect_name in - let uu___5 = - FStar_Class_Show.show FStar_Ident.showable_lident - c2_comp.FStar_Syntax_Syntax.effect_name in - FStar_Compiler_Util.format2 - "incompatible effects: %s <> %s" uu___4 uu___5) in - giveup wl uu___2 orig - else - if - (FStar_Compiler_List.length - c1_comp.FStar_Syntax_Syntax.effect_args) - <> - (FStar_Compiler_List.length - c2_comp.FStar_Syntax_Syntax.effect_args) - then - (let uu___3 = - mklstr - (fun uu___4 -> - let uu___5 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - (FStar_Class_Show.show_tuple2 - FStar_Syntax_Print.showable_term - FStar_Syntax_Print.showable_aqual)) - c1_comp.FStar_Syntax_Syntax.effect_args in - let uu___6 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - (FStar_Class_Show.show_tuple2 - FStar_Syntax_Print.showable_term - FStar_Syntax_Print.showable_aqual)) - c2_comp.FStar_Syntax_Syntax.effect_args in - FStar_Compiler_Util.format2 - "incompatible effect arguments: %s <> %s" uu___5 - uu___6) in - giveup wl uu___3 orig) - else - (let uu___4 = - FStar_Compiler_List.fold_left2 - (fun uu___5 -> - fun u1 -> - fun u2 -> - match uu___5 with - | (univ_sub_probs, wl1) -> - let uu___6 = - let uu___7 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_type u1) - FStar_Compiler_Range_Type.dummyRange in - let uu___8 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_type u2) - FStar_Compiler_Range_Type.dummyRange in - sub_prob wl1 uu___7 - FStar_TypeChecker_Common.EQ uu___8 - "effect universes" in - (match uu___6 with - | (p, wl2) -> - let uu___7 = - let uu___8 = - Obj.magic - (FStar_Class_Listlike.cons () - (Obj.magic - (FStar_Compiler_CList.listlike_clist - ())) p - (FStar_Class_Listlike.empty () - (Obj.magic - (FStar_Compiler_CList.listlike_clist - ())))) in - FStar_Class_Monoid.op_Plus_Plus - (FStar_Compiler_CList.monoid_clist ()) - univ_sub_probs uu___8 in - (uu___7, wl2))) - ((Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic (FStar_Compiler_CList.listlike_clist ())))), - wl) c1_comp.FStar_Syntax_Syntax.comp_univs - c2_comp.FStar_Syntax_Syntax.comp_univs in - match uu___4 with - | (univ_sub_probs, wl1) -> - let uu___5 = - sub_prob wl1 c1_comp.FStar_Syntax_Syntax.result_typ - FStar_TypeChecker_Common.EQ - c2_comp.FStar_Syntax_Syntax.result_typ - "effect ret type" in - (match uu___5 with - | (ret_sub_prob, wl2) -> - let uu___6 = - FStar_Compiler_List.fold_right2 - (fun uu___7 -> - fun uu___8 -> - fun uu___9 -> - match (uu___7, uu___8, uu___9) with - | ((a1, uu___10), (a2, uu___11), - (arg_sub_probs, wl3)) -> - let uu___12 = - sub_prob wl3 a1 - FStar_TypeChecker_Common.EQ a2 - "effect arg" in - (match uu___12 with - | (p, wl4) -> - let uu___13 = - Obj.magic - (FStar_Class_Listlike.cons () - (Obj.magic - (FStar_Compiler_CList.listlike_clist - ())) p - (Obj.magic arg_sub_probs)) in - (uu___13, wl4))) - c1_comp.FStar_Syntax_Syntax.effect_args - c2_comp.FStar_Syntax_Syntax.effect_args - ((Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic - (FStar_Compiler_CList.listlike_clist ())))), - wl2) in - (match uu___6 with - | (arg_sub_probs, wl3) -> - let sub_probs = - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Compiler_CList.map - (fun uu___10 -> - match uu___10 with - | (uu___11, uu___12, p) -> p) - g_lift.FStar_TypeChecker_Common.deferred in - FStar_Class_Monoid.op_Plus_Plus - (FStar_Compiler_CList.monoid_clist ()) - arg_sub_probs uu___9 in - Obj.magic - (FStar_Class_Listlike.cons () - (Obj.magic - (FStar_Compiler_CList.listlike_clist - ())) ret_sub_prob - (Obj.magic uu___8)) in - FStar_Class_Monoid.op_Plus_Plus - (FStar_Compiler_CList.monoid_clist ()) - univ_sub_probs uu___7 in - let sub_probs1 = - FStar_Class_Listlike.to_list - (FStar_Compiler_CList.listlike_clist ()) - sub_probs in - let guard = - let guard1 = - let uu___7 = - FStar_Compiler_List.map p_guard sub_probs1 in - FStar_Syntax_Util.mk_conj_l uu___7 in - match g_lift.FStar_TypeChecker_Common.guard_f - with - | FStar_TypeChecker_Common.Trivial -> guard1 - | FStar_TypeChecker_Common.NonTrivial f -> - FStar_Syntax_Util.mk_conj guard1 f in - let wl4 = - let uu___7 = - FStar_Class_Monoid.op_Plus_Plus - (FStar_Compiler_CList.monoid_clist ()) - g_lift.FStar_TypeChecker_Common.implicits - wl3.wl_implicits in - { - attempting = (wl3.attempting); - wl_deferred = (wl3.wl_deferred); - wl_deferred_to_tac = (wl3.wl_deferred_to_tac); - ctr = (wl3.ctr); - defer_ok = (wl3.defer_ok); - smt_ok = (wl3.smt_ok); - umax_heuristic_ok = (wl3.umax_heuristic_ok); - tcenv = (wl3.tcenv); - wl_implicits = uu___7; - repr_subcomp_allowed = - (wl3.repr_subcomp_allowed); - typeclass_variables = - (wl3.typeclass_variables) - } in - let wl5 = - solve_prob orig - (FStar_Pervasives_Native.Some guard) [] wl4 in - let uu___7 = attempt sub_probs1 wl5 in - solve uu___7)))) in - let should_fail_since_repr_subcomp_not_allowed repr_subcomp_allowed c11 - c21 = - let uu___ = - let uu___1 = FStar_TypeChecker_Env.norm_eff_name wl.tcenv c11 in - let uu___2 = FStar_TypeChecker_Env.norm_eff_name wl.tcenv c21 in - (uu___1, uu___2) in - match uu___ with - | (c12, c22) -> - ((Prims.op_Negation wl.repr_subcomp_allowed) && - (let uu___1 = FStar_Ident.lid_equals c12 c22 in - Prims.op_Negation uu___1)) - && (FStar_TypeChecker_Env.is_reifiable_effect wl.tcenv c22) in - let solve_layered_sub c11 c21 = - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_LayeredEffectsApp in - if uu___1 - then - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.mk_Comp c11 in - FStar_Class_Show.show FStar_Syntax_Print.showable_comp uu___3 in - let uu___3 = - let uu___4 = FStar_Syntax_Syntax.mk_Comp c21 in - FStar_Class_Show.show FStar_Syntax_Print.showable_comp uu___4 in - FStar_Compiler_Util.print2 - "solve_layered_sub c1: %s and c2: %s {\n" uu___2 uu___3 - else ()); - if - problem.FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.EQ - then solve_eq c11 c21 FStar_TypeChecker_Env.trivial_guard - else - (let r = FStar_TypeChecker_Env.get_range wl.tcenv in - let uu___2 = - should_fail_since_repr_subcomp_not_allowed - wl.repr_subcomp_allowed c11.FStar_Syntax_Syntax.effect_name - c21.FStar_Syntax_Syntax.effect_name in - if uu___2 - then - let uu___3 = - mklstr - (fun uu___4 -> - let uu___5 = - FStar_Ident.string_of_lid - c11.FStar_Syntax_Syntax.effect_name in - let uu___6 = - FStar_Ident.string_of_lid - c21.FStar_Syntax_Syntax.effect_name in - FStar_Compiler_Util.format2 - "Cannot lift from %s to %s, it needs a lift\n" uu___5 - uu___6) in - giveup wl uu___3 orig - else - (let subcomp_name = - let uu___4 = - let uu___5 = - FStar_Ident.ident_of_lid - c11.FStar_Syntax_Syntax.effect_name in - FStar_Ident.string_of_id uu___5 in - let uu___5 = - let uu___6 = - FStar_Ident.ident_of_lid - c21.FStar_Syntax_Syntax.effect_name in - FStar_Ident.string_of_id uu___6 in - FStar_Compiler_Util.format2 "%s <: %s" uu___4 uu___5 in - let lift_c1 edge = - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.mk_Comp c11 in - (edge.FStar_TypeChecker_Env.mlift).FStar_TypeChecker_Env.mlift_wp - env uu___5 in - match uu___4 with - | (c, g) -> - let uu___5 = FStar_TypeChecker_Env.comp_to_comp_typ env c in - (uu___5, g) in - let uu___4 = - let uu___5 = - FStar_TypeChecker_Env.exists_polymonadic_subcomp env - c11.FStar_Syntax_Syntax.effect_name - c21.FStar_Syntax_Syntax.effect_name in - match uu___5 with - | FStar_Pervasives_Native.None -> - let uu___6 = - FStar_TypeChecker_Env.monad_leq env - c11.FStar_Syntax_Syntax.effect_name - c21.FStar_Syntax_Syntax.effect_name in - (match uu___6 with - | FStar_Pervasives_Native.None -> - (c11, FStar_TypeChecker_Env.trivial_guard, - FStar_Pervasives_Native.None, - FStar_Syntax_Syntax.Ad_hoc_combinator, - Prims.int_zero, false) - | FStar_Pervasives_Native.Some edge -> - let uu___7 = lift_c1 edge in - (match uu___7 with - | (c12, g_lift) -> - let ed2 = - FStar_TypeChecker_Env.get_effect_decl env - c21.FStar_Syntax_Syntax.effect_name in - let uu___8 = - let uu___9 = - FStar_Syntax_Util.get_stronger_vc_combinator - ed2 in - match uu___9 with - | (ts, kopt) -> - let uu___10 = - let uu___11 = - let uu___12 = - FStar_TypeChecker_Env.inst_tscheme_with - ts - c21.FStar_Syntax_Syntax.comp_univs in - FStar_Pervasives_Native.snd uu___12 in - FStar_Pervasives_Native.Some uu___11 in - let uu___11 = - FStar_Compiler_Util.must kopt in - (uu___10, uu___11) in - (match uu___8 with - | (tsopt, k) -> - let num_eff_params = - match ed2.FStar_Syntax_Syntax.signature - with - | FStar_Syntax_Syntax.Layered_eff_sig - (n, uu___9) -> n - | uu___9 -> - failwith - "Impossible (expected indexed effect subcomp)" in - (c12, g_lift, tsopt, k, num_eff_params, - false)))) - | FStar_Pervasives_Native.Some (t, kind) -> - let uu___6 = - let uu___7 = - let uu___8 = - FStar_TypeChecker_Env.inst_tscheme_with t - c21.FStar_Syntax_Syntax.comp_univs in - FStar_Pervasives_Native.snd uu___8 in - FStar_Pervasives_Native.Some uu___7 in - (c11, FStar_TypeChecker_Env.trivial_guard, uu___6, kind, - Prims.int_zero, true) in - match uu___4 with - | (c12, g_lift, stronger_t_opt, kind, num_eff_params, - is_polymonadic) -> - if FStar_Compiler_Util.is_none stronger_t_opt - then - let uu___5 = - mklstr - (fun uu___6 -> - let uu___7 = - FStar_Class_Show.show - FStar_Ident.showable_lident - c12.FStar_Syntax_Syntax.effect_name in - let uu___8 = - FStar_Class_Show.show - FStar_Ident.showable_lident - c21.FStar_Syntax_Syntax.effect_name in - FStar_Compiler_Util.format2 - "incompatible monad ordering: %s %s since its type %s is informative" - uu___9 uu___10 uu___11 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Error_TypeError () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___8) - else ()); - (let uu___7 = - if is_polymonadic - then ([], wl1) - else - (let rec is_uvar t = - let uu___9 = - let uu___10 = FStar_Syntax_Subst.compress t in - uu___10.FStar_Syntax_Syntax.n in - match uu___9 with - | FStar_Syntax_Syntax.Tm_uvar (uv, uu___10) -> - let uu___11 = - FStar_TypeChecker_DeferredImplicits.should_defer_uvar_to_user_tac - env uv in - Prims.op_Negation uu___11 - | FStar_Syntax_Syntax.Tm_uinst (t1, uu___10) -> - is_uvar t1 - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = t1; - FStar_Syntax_Syntax.args = uu___10;_} - -> is_uvar t1 - | uu___10 -> false in - FStar_Compiler_List.fold_right2 - (fun uu___9 -> - fun uu___10 -> - fun uu___11 -> - match (uu___9, uu___10, uu___11) with - | ((a1, uu___12), (a2, uu___13), - (is_sub_probs, wl2)) -> - let uu___14 = is_uvar a1 in - if uu___14 - then - ((let uu___16 = - FStar_Compiler_Effect.op_Bang - dbg_LayeredEffectsEqns in - if uu___16 - then - let uu___17 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - a1 in - let uu___18 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - a2 in - FStar_Compiler_Util.print2 - "Layered Effects teq (rel c1 index uvar) %s = %s\n" - uu___17 uu___18 - else ()); - (let uu___16 = - sub_prob wl2 a1 - FStar_TypeChecker_Common.EQ - a2 "l.h.s. effect index uvar" in - match uu___16 with - | (p, wl3) -> - ((p :: is_sub_probs), wl3))) - else (is_sub_probs, wl2)) - c12.FStar_Syntax_Syntax.effect_args - c21.FStar_Syntax_Syntax.effect_args ([], wl1)) in - match uu___7 with - | (is_sub_probs, wl2) -> - let uu___8 = - sub_prob wl2 c12.FStar_Syntax_Syntax.result_typ - problem.FStar_TypeChecker_Common.relation - c21.FStar_Syntax_Syntax.result_typ - "result type" in - (match uu___8 with - | (ret_sub_prob, wl3) -> - let uu___9 = - FStar_Syntax_Util.arrow_formals_comp - stronger_t in - (match uu___9 with - | (bs, subcomp_c) -> - let uu___10 = - if - kind = - FStar_Syntax_Syntax.Ad_hoc_combinator - then - apply_ad_hoc_indexed_subcomp env bs - subcomp_c c12 c21 sub_prob wl3 - subcomp_name r - else - apply_substitutive_indexed_subcomp - env kind bs subcomp_c c12 c21 - sub_prob num_eff_params wl3 - subcomp_name r in - (match uu___10 with - | (fml, sub_probs, wl4) -> - let sub_probs1 = ret_sub_prob :: - (FStar_Compiler_List.op_At - is_sub_probs sub_probs) in - let guard = - let guard1 = - let uu___11 = - FStar_Compiler_List.map - p_guard sub_probs1 in - FStar_Syntax_Util.mk_conj_l - uu___11 in - let guard2 = - match g_lift.FStar_TypeChecker_Common.guard_f - with - | FStar_TypeChecker_Common.Trivial - -> guard1 - | FStar_TypeChecker_Common.NonTrivial - f -> - FStar_Syntax_Util.mk_conj - guard1 f in - FStar_Syntax_Util.mk_conj guard2 - fml in - let wl5 = - solve_prob orig - (FStar_Pervasives_Native.Some - guard) [] wl4 in - ((let uu___12 = - FStar_Compiler_Effect.op_Bang - dbg_LayeredEffectsApp in - if uu___12 - then - FStar_Compiler_Util.print_string - "}\n" - else ()); - (let uu___12 = - attempt sub_probs1 wl5 in - solve uu___12))))))))) in - let solve_sub c11 edge c21 = - if - problem.FStar_TypeChecker_Common.relation <> - FStar_TypeChecker_Common.SUB - then failwith "impossible: solve_sub" - else (); - (let r = FStar_TypeChecker_Env.get_range env in - let lift_c1 uu___1 = - let univs = - match c11.FStar_Syntax_Syntax.comp_univs with - | [] -> - let uu___2 = - env.FStar_TypeChecker_Env.universe_of env - c11.FStar_Syntax_Syntax.result_typ in - [uu___2] - | x -> x in - let c12 = - { - FStar_Syntax_Syntax.comp_univs = univs; - FStar_Syntax_Syntax.effect_name = - (c11.FStar_Syntax_Syntax.effect_name); - FStar_Syntax_Syntax.result_typ = - (c11.FStar_Syntax_Syntax.result_typ); - FStar_Syntax_Syntax.effect_args = - (c11.FStar_Syntax_Syntax.effect_args); - FStar_Syntax_Syntax.flags = (c11.FStar_Syntax_Syntax.flags) - } in - let uu___2 = - let uu___3 = - FStar_Syntax_Syntax.mk_Comp - { - FStar_Syntax_Syntax.comp_univs = univs; - FStar_Syntax_Syntax.effect_name = - (c12.FStar_Syntax_Syntax.effect_name); - FStar_Syntax_Syntax.result_typ = - (c12.FStar_Syntax_Syntax.result_typ); - FStar_Syntax_Syntax.effect_args = - (c12.FStar_Syntax_Syntax.effect_args); - FStar_Syntax_Syntax.flags = - (c12.FStar_Syntax_Syntax.flags) - } in - (edge.FStar_TypeChecker_Env.mlift).FStar_TypeChecker_Env.mlift_wp - env uu___3 in - match uu___2 with - | (c, g) -> - let uu___3 = - let uu___4 = FStar_TypeChecker_Env.is_trivial g in - Prims.op_Negation uu___4 in - if uu___3 - then - let uu___4 = - let uu___5 = - FStar_Class_Show.show FStar_Ident.showable_lident - c12.FStar_Syntax_Syntax.effect_name in - let uu___6 = - FStar_Class_Show.show FStar_Ident.showable_lident - c21.FStar_Syntax_Syntax.effect_name in - FStar_Compiler_Util.format2 - "Lift between wp-effects (%s~>%s) should not have returned a non-trivial guard" - uu___5 uu___6 in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range - r FStar_Errors_Codes.Fatal_UnexpectedEffect () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4) - else FStar_TypeChecker_Env.comp_to_comp_typ env c in - let uu___1 = - should_fail_since_repr_subcomp_not_allowed wl.repr_subcomp_allowed - c11.FStar_Syntax_Syntax.effect_name - c21.FStar_Syntax_Syntax.effect_name in - if uu___1 - then - let uu___2 = - mklstr - (fun uu___3 -> - let uu___4 = - FStar_Ident.string_of_lid - c11.FStar_Syntax_Syntax.effect_name in - let uu___5 = - FStar_Ident.string_of_lid - c21.FStar_Syntax_Syntax.effect_name in - FStar_Compiler_Util.format2 - "Cannot lift from %s to %s, it needs a lift\n" uu___4 - uu___5) in - giveup wl uu___2 orig - else - (let is_null_wp_2 = - FStar_Compiler_Util.for_some - (fun uu___3 -> - match uu___3 with - | FStar_Syntax_Syntax.TOTAL -> true - | FStar_Syntax_Syntax.MLEFFECT -> true - | FStar_Syntax_Syntax.SOMETRIVIAL -> true - | uu___4 -> false) c21.FStar_Syntax_Syntax.flags in - let uu___3 = - match ((c11.FStar_Syntax_Syntax.effect_args), - (c21.FStar_Syntax_Syntax.effect_args)) - with - | ((wp1, uu___4)::uu___5, (wp2, uu___6)::uu___7) -> (wp1, wp2) - | uu___4 -> - let uu___5 = - let uu___6 = - FStar_Class_Show.show FStar_Ident.showable_lident - c11.FStar_Syntax_Syntax.effect_name in - let uu___7 = - FStar_Class_Show.show FStar_Ident.showable_lident - c21.FStar_Syntax_Syntax.effect_name in - FStar_Compiler_Util.format2 - "Got effects %s and %s, expected normalized effects" - uu___6 uu___7 in - FStar_Errors.raise_error FStar_TypeChecker_Env.hasRange_env - env FStar_Errors_Codes.Fatal_ExpectNormalizedEffect () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___5) in - match uu___3 with - | (wpc1, wpc2) -> - let uu___4 = FStar_Compiler_Util.physical_equality wpc1 wpc2 in - if uu___4 - then - let uu___5 = - problem_using_guard orig - c11.FStar_Syntax_Syntax.result_typ - problem.FStar_TypeChecker_Common.relation - c21.FStar_Syntax_Syntax.result_typ - FStar_Pervasives_Native.None "result type" in - solve_t uu___5 wl - else - (let uu___6 = - let uu___7 = - FStar_TypeChecker_Env.effect_decl_opt env - c21.FStar_Syntax_Syntax.effect_name in - FStar_Compiler_Util.must uu___7 in - match uu___6 with - | (c2_decl, qualifiers) -> - if - FStar_Compiler_List.contains - FStar_Syntax_Syntax.Reifiable qualifiers - then - let c1_repr = - let uu___7 = - let uu___8 = - let uu___9 = lift_c1 () in - FStar_Syntax_Syntax.mk_Comp uu___9 in - let uu___9 = - env.FStar_TypeChecker_Env.universe_of env - c11.FStar_Syntax_Syntax.result_typ in - FStar_TypeChecker_Env.reify_comp env uu___8 - uu___9 in - norm_with_steps - "FStar.TypeChecker.Rel.norm_with_steps.4" - [FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Weak; - FStar_TypeChecker_Env.HNF] env uu___7 in - let c2_repr = - let uu___7 = - let uu___8 = FStar_Syntax_Syntax.mk_Comp c21 in - let uu___9 = - env.FStar_TypeChecker_Env.universe_of env - c21.FStar_Syntax_Syntax.result_typ in - FStar_TypeChecker_Env.reify_comp env uu___8 - uu___9 in - norm_with_steps - "FStar.TypeChecker.Rel.norm_with_steps.5" - [FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Weak; - FStar_TypeChecker_Env.HNF] env uu___7 in - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term c1_repr in - let uu___10 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term c2_repr in - FStar_Compiler_Util.format2 - "sub effect repr: %s <: %s" uu___9 uu___10 in - sub_prob wl c1_repr - problem.FStar_TypeChecker_Common.relation - c2_repr uu___8 in - (match uu___7 with - | (prob, wl1) -> - let wl2 = - solve_prob orig - (FStar_Pervasives_Native.Some - (p_guard prob)) [] wl1 in - let uu___8 = attempt [prob] wl2 in solve uu___8) - else - (let g = - let uu___8 = FStar_Options.lax () in - if uu___8 - then FStar_Syntax_Util.t_true - else - (let wpc1_2 = - let uu___10 = lift_c1 () in - FStar_Compiler_List.hd - uu___10.FStar_Syntax_Syntax.effect_args in - if is_null_wp_2 - then - ((let uu___11 = - FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___11 - then - FStar_Compiler_Util.print_string - "Using trivial wp ... \n" - else ()); - (let c1_univ = - env.FStar_TypeChecker_Env.universe_of - env c11.FStar_Syntax_Syntax.result_typ in - let trivial = - let uu___11 = - FStar_Syntax_Util.get_wp_trivial_combinator - c2_decl in - match uu___11 with - | FStar_Pervasives_Native.None -> - failwith - "Rel doesn't yet handle undefined trivial combinator in an effect" - | FStar_Pervasives_Native.Some t -> t in - let uu___11 = - let uu___12 = - let uu___13 = - FStar_TypeChecker_Env.inst_effect_fun_with - [c1_univ] env c2_decl trivial in - let uu___14 = - let uu___15 = - FStar_Syntax_Syntax.as_arg - c11.FStar_Syntax_Syntax.result_typ in - [uu___15; wpc1_2] in - { - FStar_Syntax_Syntax.hd = uu___13; - FStar_Syntax_Syntax.args = uu___14 - } in - FStar_Syntax_Syntax.Tm_app uu___12 in - FStar_Syntax_Syntax.mk uu___11 r)) - else - (let c2_univ = - env.FStar_TypeChecker_Env.universe_of env - c21.FStar_Syntax_Syntax.result_typ in - let stronger = - let uu___11 = - FStar_Syntax_Util.get_stronger_vc_combinator - c2_decl in - FStar_Pervasives_Native.fst uu___11 in - let uu___11 = - let uu___12 = - let uu___13 = - FStar_TypeChecker_Env.inst_effect_fun_with - [c2_univ] env c2_decl stronger in - let uu___14 = - let uu___15 = - FStar_Syntax_Syntax.as_arg - c21.FStar_Syntax_Syntax.result_typ in - let uu___16 = - let uu___17 = - FStar_Syntax_Syntax.as_arg wpc2 in - [uu___17; wpc1_2] in - uu___15 :: uu___16 in - { - FStar_Syntax_Syntax.hd = uu___13; - FStar_Syntax_Syntax.args = uu___14 - } in - FStar_Syntax_Syntax.Tm_app uu___12 in - FStar_Syntax_Syntax.mk uu___11 r)) in - (let uu___9 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___9 - then - let uu___10 = - let uu___11 = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Iota; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.Simplify] env g in - FStar_Class_Show.show - FStar_Syntax_Print.showable_term uu___11 in - FStar_Compiler_Util.print1 - "WP guard (simplifed) is (%s)\n" uu___10 - else ()); - (let uu___9 = - sub_prob wl c11.FStar_Syntax_Syntax.result_typ - problem.FStar_TypeChecker_Common.relation - c21.FStar_Syntax_Syntax.result_typ - "result type" in - match uu___9 with - | (base_prob, wl1) -> - let wl2 = - let uu___10 = - let uu___11 = - FStar_Syntax_Util.mk_conj - (p_guard base_prob) g in - FStar_Pervasives_Native.Some uu___11 in - solve_prob orig uu___10 [] wl1 in - let uu___10 = attempt [base_prob] wl2 in - solve uu___10))))) in - let uu___ = FStar_Compiler_Util.physical_equality c1 c2 in - if uu___ - then - let uu___1 = solve_prob orig FStar_Pervasives_Native.None [] wl in - solve uu___1 - else - ((let uu___3 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___3 - then - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_comp c1 in - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_comp c2 in - FStar_Compiler_Util.print3 "solve_c %s %s %s\n" uu___4 - (rel_to_string problem.FStar_TypeChecker_Common.relation) - uu___5 - else ()); - (let uu___3 = - let uu___4 = - let uu___5 = - FStar_TypeChecker_Env.norm_eff_name env - (FStar_Syntax_Util.comp_effect_name c1) in - let uu___6 = - FStar_TypeChecker_Env.norm_eff_name env - (FStar_Syntax_Util.comp_effect_name c2) in - (uu___5, uu___6) in - match uu___4 with - | (eff1, eff2) -> - let uu___5 = FStar_Ident.lid_equals eff1 eff2 in - if uu___5 - then (c1, c2) - else FStar_TypeChecker_Normalize.ghost_to_pure2 env (c1, c2) in - match uu___3 with - | (c11, c21) -> - (match ((c11.FStar_Syntax_Syntax.n), - (c21.FStar_Syntax_Syntax.n)) - with - | (FStar_Syntax_Syntax.GTotal t1, FStar_Syntax_Syntax.Total - t2) when FStar_TypeChecker_Env.non_informative env t2 -> - let uu___4 = - problem_using_guard orig t1 - problem.FStar_TypeChecker_Common.relation t2 - FStar_Pervasives_Native.None "result type" in - solve_t uu___4 wl - | (FStar_Syntax_Syntax.GTotal uu___4, - FStar_Syntax_Syntax.Total uu___5) -> - let uu___6 = - FStar_Thunk.mkv - "incompatible monad ordering: GTot - let uu___4 = - problem_using_guard orig t1 - problem.FStar_TypeChecker_Common.relation t2 - FStar_Pervasives_Native.None "result type" in - solve_t uu___4 wl - | (FStar_Syntax_Syntax.GTotal t1, FStar_Syntax_Syntax.GTotal - t2) -> - let uu___4 = - problem_using_guard orig t1 - problem.FStar_TypeChecker_Common.relation t2 - FStar_Pervasives_Native.None "result type" in - solve_t uu___4 wl - | (FStar_Syntax_Syntax.Total t1, FStar_Syntax_Syntax.GTotal - t2) when - problem.FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.SUB - -> - let uu___4 = - problem_using_guard orig t1 - problem.FStar_TypeChecker_Common.relation t2 - FStar_Pervasives_Native.None "result type" in - solve_t uu___4 wl - | (FStar_Syntax_Syntax.Total t1, FStar_Syntax_Syntax.GTotal - t2) -> - let uu___4 = FStar_Thunk.mkv "GTot =/= Tot" in - giveup wl uu___4 orig - | (FStar_Syntax_Syntax.GTotal uu___4, FStar_Syntax_Syntax.Comp - uu___5) -> - let uu___6 = - let uu___7 = - let uu___8 = - FStar_TypeChecker_Env.comp_to_comp_typ env c11 in - FStar_Syntax_Syntax.mk_Comp uu___8 in - { - FStar_TypeChecker_Common.pid = - (problem.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = uu___7; - FStar_TypeChecker_Common.relation = - (problem.FStar_TypeChecker_Common.relation); - FStar_TypeChecker_Common.rhs = - (problem.FStar_TypeChecker_Common.rhs); - FStar_TypeChecker_Common.element = - (problem.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (problem.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (problem.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (problem.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = - (problem.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = - (problem.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = - (problem.FStar_TypeChecker_Common.logical) - } in - solve_c uu___6 wl - | (FStar_Syntax_Syntax.Total uu___4, FStar_Syntax_Syntax.Comp - uu___5) -> - let uu___6 = - let uu___7 = - let uu___8 = - FStar_TypeChecker_Env.comp_to_comp_typ env c11 in - FStar_Syntax_Syntax.mk_Comp uu___8 in - { - FStar_TypeChecker_Common.pid = - (problem.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = uu___7; - FStar_TypeChecker_Common.relation = - (problem.FStar_TypeChecker_Common.relation); - FStar_TypeChecker_Common.rhs = - (problem.FStar_TypeChecker_Common.rhs); - FStar_TypeChecker_Common.element = - (problem.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (problem.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (problem.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (problem.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = - (problem.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = - (problem.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = - (problem.FStar_TypeChecker_Common.logical) - } in - solve_c uu___6 wl - | (FStar_Syntax_Syntax.Comp uu___4, FStar_Syntax_Syntax.GTotal - uu___5) -> - let uu___6 = - let uu___7 = - let uu___8 = - FStar_TypeChecker_Env.comp_to_comp_typ env c21 in - FStar_Syntax_Syntax.mk_Comp uu___8 in - { - FStar_TypeChecker_Common.pid = - (problem.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = - (problem.FStar_TypeChecker_Common.lhs); - FStar_TypeChecker_Common.relation = - (problem.FStar_TypeChecker_Common.relation); - FStar_TypeChecker_Common.rhs = uu___7; - FStar_TypeChecker_Common.element = - (problem.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (problem.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (problem.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (problem.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = - (problem.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = - (problem.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = - (problem.FStar_TypeChecker_Common.logical) - } in - solve_c uu___6 wl - | (FStar_Syntax_Syntax.Comp uu___4, FStar_Syntax_Syntax.Total - uu___5) -> - let uu___6 = - let uu___7 = - let uu___8 = - FStar_TypeChecker_Env.comp_to_comp_typ env c21 in - FStar_Syntax_Syntax.mk_Comp uu___8 in - { - FStar_TypeChecker_Common.pid = - (problem.FStar_TypeChecker_Common.pid); - FStar_TypeChecker_Common.lhs = - (problem.FStar_TypeChecker_Common.lhs); - FStar_TypeChecker_Common.relation = - (problem.FStar_TypeChecker_Common.relation); - FStar_TypeChecker_Common.rhs = uu___7; - FStar_TypeChecker_Common.element = - (problem.FStar_TypeChecker_Common.element); - FStar_TypeChecker_Common.logical_guard = - (problem.FStar_TypeChecker_Common.logical_guard); - FStar_TypeChecker_Common.logical_guard_uvar = - (problem.FStar_TypeChecker_Common.logical_guard_uvar); - FStar_TypeChecker_Common.reason = - (problem.FStar_TypeChecker_Common.reason); - FStar_TypeChecker_Common.loc = - (problem.FStar_TypeChecker_Common.loc); - FStar_TypeChecker_Common.rank = - (problem.FStar_TypeChecker_Common.rank); - FStar_TypeChecker_Common.logical = - (problem.FStar_TypeChecker_Common.logical) - } in - solve_c uu___6 wl - | (FStar_Syntax_Syntax.Comp uu___4, FStar_Syntax_Syntax.Comp - uu___5) -> - let uu___6 = - (((FStar_Syntax_Util.is_ml_comp c11) && - (FStar_Syntax_Util.is_ml_comp c21)) - || - ((FStar_Syntax_Util.is_total_comp c11) && - (FStar_Syntax_Util.is_total_comp c21))) - || - (((FStar_Syntax_Util.is_total_comp c11) && - (FStar_Syntax_Util.is_ml_comp c21)) - && - (problem.FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.SUB)) in - if uu___6 - then - let uu___7 = - problem_using_guard orig - (FStar_Syntax_Util.comp_result c11) - problem.FStar_TypeChecker_Common.relation - (FStar_Syntax_Util.comp_result c21) - FStar_Pervasives_Native.None "result type" in - solve_t uu___7 wl - else - (let c1_comp = - FStar_TypeChecker_Env.comp_to_comp_typ env c11 in - let c2_comp = - FStar_TypeChecker_Env.comp_to_comp_typ env c21 in - if - problem.FStar_TypeChecker_Common.relation = - FStar_TypeChecker_Common.EQ - then - let uu___8 = - let uu___9 = - FStar_Ident.lid_equals - c1_comp.FStar_Syntax_Syntax.effect_name - c2_comp.FStar_Syntax_Syntax.effect_name in - if uu___9 - then (c1_comp, c2_comp) - else - (let uu___11 = - FStar_TypeChecker_Env.unfold_effect_abbrev env - c11 in - let uu___12 = - FStar_TypeChecker_Env.unfold_effect_abbrev env - c21 in - (uu___11, uu___12)) in - match uu___8 with - | (c1_comp1, c2_comp1) -> - solve_eq c1_comp1 c2_comp1 - FStar_TypeChecker_Env.trivial_guard - else - (let c12 = - FStar_TypeChecker_Env.unfold_effect_abbrev env c11 in - let c22 = - FStar_TypeChecker_Env.unfold_effect_abbrev env c21 in - (let uu___10 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___10 - then - let uu___11 = - FStar_Ident.string_of_lid - c12.FStar_Syntax_Syntax.effect_name in - let uu___12 = - FStar_Ident.string_of_lid - c22.FStar_Syntax_Syntax.effect_name in - FStar_Compiler_Util.print2 - "solve_c for %s and %s\n" uu___11 uu___12 - else ()); - (let uu___10 = - FStar_TypeChecker_Env.is_layered_effect env - c22.FStar_Syntax_Syntax.effect_name in - if uu___10 - then solve_layered_sub c12 c22 - else - (let uu___12 = - FStar_TypeChecker_Env.monad_leq env - c12.FStar_Syntax_Syntax.effect_name - c22.FStar_Syntax_Syntax.effect_name in - match uu___12 with - | FStar_Pervasives_Native.None -> - let uu___13 = - mklstr - (fun uu___14 -> - let uu___15 = - FStar_Class_Show.show - FStar_Ident.showable_lident - c12.FStar_Syntax_Syntax.effect_name in - let uu___16 = - FStar_Class_Show.show - FStar_Ident.showable_lident - c22.FStar_Syntax_Syntax.effect_name in - FStar_Compiler_Util.format2 - "incompatible monad ordering: %s - solve_sub c12 edge c22))))))) -let (print_pending_implicits : - FStar_TypeChecker_Common.guard_t -> Prims.string) = - fun g -> - let uu___ = - FStar_Compiler_CList.map - (fun i -> - FStar_Class_Show.show FStar_Syntax_Print.showable_ctxu - i.FStar_TypeChecker_Common.imp_uvar) - g.FStar_TypeChecker_Common.implicits in - FStar_Class_Show.show - (FStar_Compiler_CList.showable_clist - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_string)) uu___ -let (ineqs_to_string : - (FStar_Syntax_Syntax.universe FStar_Compiler_CList.clist * - (FStar_Syntax_Syntax.universe * FStar_Syntax_Syntax.universe) - FStar_Compiler_CList.clist) -> Prims.string) - = - fun ineqs -> - let uu___ = ineqs in - match uu___ with - | (vars, ineqs1) -> - let ineqs2 = - FStar_Compiler_CList.map - (fun uu___1 -> - match uu___1 with - | (u1, u2) -> - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_univ - u1 in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_univ - u2 in - FStar_Compiler_Util.format2 "%s < %s" uu___2 uu___3) - ineqs1 in - let uu___1 = - FStar_Class_Show.show - (FStar_Compiler_CList.showable_clist - FStar_Syntax_Print.showable_univ) vars in - let uu___2 = - FStar_Class_Show.show - (FStar_Compiler_CList.showable_clist - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_string)) ineqs2 in - FStar_Compiler_Util.format2 "Solving for %s; inequalities are %s" - uu___1 uu___2 -let (guard_to_string : - FStar_TypeChecker_Env.env -> - FStar_TypeChecker_Common.guard_t -> Prims.string) - = - fun env -> - fun g -> - let uu___ = - let uu___1 = - Obj.magic - (FStar_Class_Listlike.view () - (Obj.magic (FStar_Compiler_CList.listlike_clist ())) - (Obj.magic g.FStar_TypeChecker_Common.deferred)) in - ((g.FStar_TypeChecker_Common.guard_f), uu___1) in - match uu___ with - | (FStar_TypeChecker_Common.Trivial, FStar_Class_Listlike.VNil) when - (let uu___1 = FStar_Options.print_implicits () in - Prims.op_Negation uu___1) && - (FStar_Class_Listlike.is_empty - (FStar_Compiler_CList.listlike_clist ()) - (FStar_Pervasives_Native.snd - g.FStar_TypeChecker_Common.univ_ineqs)) - -> "{}" - | uu___1 -> - let form = - match g.FStar_TypeChecker_Common.guard_f with - | FStar_TypeChecker_Common.Trivial -> "trivial" - | FStar_TypeChecker_Common.NonTrivial f -> - let uu___2 = - ((FStar_Compiler_Effect.op_Bang dbg_Rel) || - (FStar_Compiler_Debug.extreme ())) - || (FStar_Options.print_implicits ()) in - if uu___2 - then FStar_TypeChecker_Normalize.term_to_string env f - else "non-trivial" in - let carry defs = - let uu___2 = - let uu___3 = - FStar_Compiler_CList.map - (fun uu___4 -> - match uu___4 with - | (uu___5, msg, x) -> - let uu___6 = - let uu___7 = prob_to_string env x in - Prims.strcat ": " uu___7 in - Prims.strcat msg uu___6) defs in - FStar_Class_Listlike.to_list - (FStar_Compiler_CList.listlike_clist ()) uu___3 in - FStar_Compiler_String.concat ",\n" uu___2 in - let imps = print_pending_implicits g in - let uu___2 = carry g.FStar_TypeChecker_Common.deferred in - let uu___3 = carry g.FStar_TypeChecker_Common.deferred_to_tac in - let uu___4 = ineqs_to_string g.FStar_TypeChecker_Common.univ_ineqs in - FStar_Compiler_Util.format5 - "\n\t{guard_f=%s;\n\t deferred={\n%s};\n\t deferred_to_tac={\n%s};\n\t univ_ineqs={%s};\n\t implicits=%s}\n" - form uu___2 uu___3 uu___4 imps -let (new_t_problem : - worklist -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_TypeChecker_Common.rel -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.bv FStar_Pervasives_Native.option -> - FStar_Compiler_Range_Type.range -> - (FStar_TypeChecker_Common.prob * worklist)) - = - fun wl -> - fun env -> - fun lhs -> - fun rel -> - fun rhs -> - fun elt -> - fun loc -> - let reason = - let uu___ = - (FStar_Compiler_Effect.op_Bang dbg_ExplainRel) || - (FStar_Compiler_Effect.op_Bang dbg_Rel) in - if uu___ - then - let uu___1 = - FStar_TypeChecker_Normalize.term_to_string env lhs in - let uu___2 = - FStar_TypeChecker_Normalize.term_to_string env rhs in - FStar_Compiler_Util.format3 "Top-level:\n%s\n\t%s\n%s" - uu___1 (rel_to_string rel) uu___2 - else "TOP" in - let uu___ = new_problem wl env lhs rel rhs elt loc reason in - match uu___ with - | (p, wl1) -> - (def_check_prob (Prims.strcat "new_t_problem." reason) - (FStar_TypeChecker_Common.TProb p); - ((FStar_TypeChecker_Common.TProb p), wl1)) -let (new_t_prob : - worklist -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_TypeChecker_Common.rel -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - (FStar_TypeChecker_Common.prob * FStar_Syntax_Syntax.bv * - worklist)) - = - fun wl -> - fun env -> - fun t1 -> - fun rel -> - fun t2 -> - let x = - let uu___ = - let uu___1 = FStar_TypeChecker_Env.get_range env in - FStar_Pervasives_Native.Some uu___1 in - FStar_Syntax_Syntax.new_bv uu___ t1 in - let uu___ = - let uu___1 = FStar_TypeChecker_Env.get_range env in - new_t_problem wl env t1 rel t2 (FStar_Pervasives_Native.Some x) - uu___1 in - match uu___ with | (p, wl1) -> (p, x, wl1) -let (solve_and_commit : - worklist -> - ((FStar_TypeChecker_Common.prob * lstring) -> - (FStar_TypeChecker_Common.deferred * FStar_TypeChecker_Common.deferred - * FStar_TypeChecker_Common.implicits_t) - FStar_Pervasives_Native.option) - -> - (FStar_TypeChecker_Common.deferred * FStar_TypeChecker_Common.deferred - * FStar_TypeChecker_Common.implicits_t) - FStar_Pervasives_Native.option) - = - fun wl -> - fun err -> - let tx = FStar_Syntax_Unionfind.new_transaction () in - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_RelBench in - if uu___1 - then - let uu___2 = - (FStar_Common.string_of_list ()) - (fun p -> FStar_Compiler_Util.string_of_int (p_pid p)) - wl.attempting in - FStar_Compiler_Util.print1 "solving problems %s {\n" uu___2 - else ()); - (let uu___1 = FStar_Compiler_Util.record_time (fun uu___2 -> solve wl) in - match uu___1 with - | (sol, ms) -> - ((let uu___3 = FStar_Compiler_Effect.op_Bang dbg_RelBench in - if uu___3 - then - let uu___4 = FStar_Compiler_Util.string_of_int ms in - FStar_Compiler_Util.print1 "} solved in %s ms\n" uu___4 - else ()); - (match sol with - | Success (deferred, defer_to_tac, implicits) -> - let uu___3 = - FStar_Compiler_Util.record_time - (fun uu___4 -> FStar_Syntax_Unionfind.commit tx) in - (match uu___3 with - | ((), ms1) -> - ((let uu___5 = - FStar_Compiler_Effect.op_Bang dbg_RelBench in - if uu___5 - then - let uu___6 = FStar_Compiler_Util.string_of_int ms1 in - FStar_Compiler_Util.print1 "committed in %s ms\n" - uu___6 - else ()); - FStar_Pervasives_Native.Some - (deferred, defer_to_tac, implicits))) - | Failed (d, s) -> - ((let uu___4 = - (FStar_Compiler_Effect.op_Bang dbg_ExplainRel) || - (FStar_Compiler_Effect.op_Bang dbg_Rel) in - if uu___4 - then - let uu___5 = explain wl d s in - FStar_Compiler_Util.print_string uu___5 - else ()); - (let result = err (d, s) in - FStar_Syntax_Unionfind.rollback tx; result))))) -let (with_guard : - FStar_TypeChecker_Env.env -> - FStar_TypeChecker_Common.prob -> - (FStar_TypeChecker_Common.deferred * FStar_TypeChecker_Common.deferred - * FStar_TypeChecker_Common.implicits_t) - FStar_Pervasives_Native.option -> - FStar_TypeChecker_Common.guard_t FStar_Pervasives_Native.option) - = - fun env -> - fun prob -> - fun dopt -> - match dopt with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (deferred, defer_to_tac, implicits) -> - (FStar_Defensive.def_check_scoped - FStar_TypeChecker_Env.hasBinders_env - FStar_Class_Binders.hasNames_term - FStar_Syntax_Print.pretty_term (p_loc prob) "with_guard" env - (p_guard prob); - (let uu___1 = - simplify_guard env - { - FStar_TypeChecker_Common.guard_f = - (FStar_TypeChecker_Common.NonTrivial (p_guard prob)); - FStar_TypeChecker_Common.deferred_to_tac = defer_to_tac; - FStar_TypeChecker_Common.deferred = deferred; - FStar_TypeChecker_Common.univ_ineqs = - ((Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic - (FStar_Compiler_CList.listlike_clist ())))), - (Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic - (FStar_Compiler_CList.listlike_clist ()))))); - FStar_TypeChecker_Common.implicits = implicits - } in - FStar_Pervasives_Native.Some uu___1)) -let (try_teq : - Prims.bool -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.typ -> - FStar_TypeChecker_Common.guard_t FStar_Pervasives_Native.option) - = - fun smt_ok -> - fun env -> - fun t1 -> - fun t2 -> - FStar_Defensive.def_check_scoped - FStar_TypeChecker_Env.hasBinders_env - FStar_Class_Binders.hasNames_term FStar_Syntax_Print.pretty_term - t1.FStar_Syntax_Syntax.pos "try_teq.1" env t1; - FStar_Defensive.def_check_scoped - FStar_TypeChecker_Env.hasBinders_env - FStar_Class_Binders.hasNames_term FStar_Syntax_Print.pretty_term - t2.FStar_Syntax_Syntax.pos "try_teq.2" env t2; - (let smt_ok1 = - smt_ok && - (let uu___2 = FStar_Options.ml_ish () in - Prims.op_Negation uu___2) in - let uu___2 = - let uu___3 = - let uu___4 = FStar_TypeChecker_Env.current_module env in - FStar_Ident.string_of_lid uu___4 in - FStar_Pervasives_Native.Some uu___3 in - FStar_Profiling.profile - (fun uu___3 -> - (let uu___5 = FStar_Compiler_Effect.op_Bang dbg_RelTop in - if uu___5 - then - let uu___6 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - t1 in - let uu___7 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - t2 in - let uu___8 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binding) - env.FStar_TypeChecker_Env.gamma in - FStar_Compiler_Util.print3 - "try_teq of %s and %s in %s {\n" uu___6 uu___7 uu___8 - else ()); - (let uu___5 = - let uu___6 = empty_worklist env in - let uu___7 = FStar_TypeChecker_Env.get_range env in - new_t_problem uu___6 env t1 FStar_TypeChecker_Common.EQ t2 - FStar_Pervasives_Native.None uu___7 in - match uu___5 with - | (prob, wl) -> - let g = - let uu___6 = - solve_and_commit (singleton wl prob smt_ok1) - (fun uu___7 -> FStar_Pervasives_Native.None) in - with_guard env prob uu___6 in - ((let uu___7 = FStar_Compiler_Effect.op_Bang dbg_RelTop in - if uu___7 - then - let uu___8 = - FStar_Common.string_of_option - (guard_to_string env) g in - FStar_Compiler_Util.print1 "} res = %s\n" uu___8 - else ()); - g))) uu___2 "FStar.TypeChecker.Rel.try_teq") -let (teq : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.typ -> FStar_TypeChecker_Common.guard_t) - = - fun env -> - fun t1 -> - fun t2 -> - let uu___ = try_teq true env t1 t2 in - match uu___ with - | FStar_Pervasives_Native.None -> - (FStar_TypeChecker_Err.basic_type_error env - env.FStar_TypeChecker_Env.range FStar_Pervasives_Native.None - t2 t1; - FStar_TypeChecker_Common.trivial_guard) - | FStar_Pervasives_Native.Some g -> - ((let uu___2 = - (FStar_Compiler_Effect.op_Bang dbg_Rel) || - (FStar_Compiler_Effect.op_Bang dbg_RelTop) in - if uu___2 - then - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t2 in - let uu___5 = guard_to_string env g in - FStar_Compiler_Util.print3 - "teq of %s and %s succeeded with guard %s\n" uu___3 uu___4 - uu___5 - else ()); - g) -let (get_teq_predicate : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.typ -> - FStar_TypeChecker_Common.guard_t FStar_Pervasives_Native.option) - = - fun env -> - fun t1 -> - fun t2 -> - (let uu___1 = - (FStar_Compiler_Effect.op_Bang dbg_Rel) || - (FStar_Compiler_Effect.op_Bang dbg_RelTop) in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t2 in - FStar_Compiler_Util.print2 "get_teq_predicate of %s and %s {\n" - uu___2 uu___3 - else ()); - (let uu___1 = - let uu___2 = empty_worklist env in - new_t_prob uu___2 env t1 FStar_TypeChecker_Common.EQ t2 in - match uu___1 with - | (prob, x, wl) -> - let g = - let uu___2 = - solve_and_commit (singleton wl prob true) - (fun uu___3 -> FStar_Pervasives_Native.None) in - with_guard env prob uu___2 in - ((let uu___3 = - (FStar_Compiler_Effect.op_Bang dbg_Rel) || - (FStar_Compiler_Effect.op_Bang dbg_RelTop) in - if uu___3 - then - let uu___4 = - FStar_Common.string_of_option (guard_to_string env) g in - FStar_Compiler_Util.print1 "} res teq predicate = %s\n" - uu___4 - else ()); - (match g with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some g1 -> - let uu___3 = - let uu___4 = FStar_Syntax_Syntax.mk_binder x in - FStar_TypeChecker_Env.abstract_guard uu___4 g1 in - FStar_Pervasives_Native.Some uu___3))) -let (subtype_fail : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.typ -> unit) - = - fun env -> - fun e -> - fun t1 -> - fun t2 -> - let uu___ = FStar_TypeChecker_Env.get_range env in - FStar_TypeChecker_Err.basic_type_error env uu___ - (FStar_Pervasives_Native.Some e) t2 t1 -let (sub_or_eq_comp : - FStar_TypeChecker_Env.env -> - Prims.bool -> - FStar_Syntax_Syntax.comp -> - FStar_Syntax_Syntax.comp -> - FStar_TypeChecker_Common.guard_t FStar_Pervasives_Native.option) - = - fun env -> - fun use_eq -> - fun c1 -> - fun c2 -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_Env.current_module env in - FStar_Ident.string_of_lid uu___2 in - FStar_Pervasives_Native.Some uu___1 in - FStar_Profiling.profile - (fun uu___1 -> - let rel = - if use_eq - then FStar_TypeChecker_Common.EQ - else FStar_TypeChecker_Common.SUB in - (let uu___3 = - (FStar_Compiler_Effect.op_Bang dbg_Rel) || - (FStar_Compiler_Effect.op_Bang dbg_RelTop) in - if uu___3 - then - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_comp c1 in - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_comp c2 in - FStar_Compiler_Util.print3 - "sub_comp of %s --and-- %s --with-- %s\n" uu___4 uu___5 - (if rel = FStar_TypeChecker_Common.EQ - then "EQ" - else "SUB") - else ()); - (let uu___3 = - let uu___4 = empty_worklist env in - let uu___5 = FStar_TypeChecker_Env.get_range env in - new_problem uu___4 env c1 rel c2 - FStar_Pervasives_Native.None uu___5 "sub_comp" in - match uu___3 with - | (prob, wl) -> - let wl1 = - { - attempting = (wl.attempting); - wl_deferred = (wl.wl_deferred); - wl_deferred_to_tac = (wl.wl_deferred_to_tac); - ctr = (wl.ctr); - defer_ok = (wl.defer_ok); - smt_ok = (wl.smt_ok); - umax_heuristic_ok = (wl.umax_heuristic_ok); - tcenv = (wl.tcenv); - wl_implicits = (wl.wl_implicits); - repr_subcomp_allowed = true; - typeclass_variables = (wl.typeclass_variables) - } in - let prob1 = FStar_TypeChecker_Common.CProb prob in - (def_check_prob "sub_comp" prob1; - (let uu___5 = - FStar_Compiler_Util.record_time - (fun uu___6 -> - let uu___7 = - solve_and_commit (singleton wl1 prob1 true) - (fun uu___8 -> FStar_Pervasives_Native.None) in - with_guard env prob1 uu___7) in - match uu___5 with - | (r, ms) -> - ((let uu___7 = - ((FStar_Compiler_Effect.op_Bang dbg_Rel) || - (FStar_Compiler_Effect.op_Bang dbg_RelTop)) - || - (FStar_Compiler_Effect.op_Bang dbg_RelBench) in - if uu___7 - then - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_comp c1 in - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_comp c2 in - let uu___10 = - FStar_Compiler_Util.string_of_int ms in - FStar_Compiler_Util.print4 - "sub_comp of %s --and-- %s --with-- %s --- solved in %s ms\n" - uu___8 uu___9 - (if rel = FStar_TypeChecker_Common.EQ - then "EQ" - else "SUB") uu___10 - else ()); - r))))) uu___ "FStar.TypeChecker.Rel.sub_comp" -let (sub_comp : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.comp -> - FStar_Syntax_Syntax.comp -> - FStar_TypeChecker_Common.guard_t FStar_Pervasives_Native.option) - = - fun env -> - fun c1 -> - fun c2 -> - FStar_Errors.with_ctx "While trying to subtype computation types" - (fun uu___ -> - FStar_Defensive.def_check_scoped - FStar_TypeChecker_Env.hasBinders_env - FStar_Class_Binders.hasNames_comp - FStar_Syntax_Print.pretty_comp c1.FStar_Syntax_Syntax.pos - "sub_comp c1" env c1; - FStar_Defensive.def_check_scoped - FStar_TypeChecker_Env.hasBinders_env - FStar_Class_Binders.hasNames_comp - FStar_Syntax_Print.pretty_comp c2.FStar_Syntax_Syntax.pos - "sub_comp c2" env c2; - sub_or_eq_comp env false c1 c2) -let (eq_comp : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.comp -> - FStar_Syntax_Syntax.comp -> - FStar_TypeChecker_Common.guard_t FStar_Pervasives_Native.option) - = - fun env -> - fun c1 -> - fun c2 -> - FStar_Errors.with_ctx "While trying to equate computation types" - (fun uu___ -> - FStar_Defensive.def_check_scoped - FStar_TypeChecker_Env.hasBinders_env - FStar_Class_Binders.hasNames_comp - FStar_Syntax_Print.pretty_comp c1.FStar_Syntax_Syntax.pos - "eq_comp c1" env c1; - FStar_Defensive.def_check_scoped - FStar_TypeChecker_Env.hasBinders_env - FStar_Class_Binders.hasNames_comp - FStar_Syntax_Print.pretty_comp c2.FStar_Syntax_Syntax.pos - "eq_comp c2" env c2; - sub_or_eq_comp env true c1 c2) -let (solve_universe_inequalities' : - FStar_Syntax_Unionfind.tx -> - FStar_TypeChecker_Env.env_t -> - (FStar_Syntax_Syntax.universe FStar_Compiler_CList.clist * - (FStar_Syntax_Syntax.universe * FStar_Syntax_Syntax.universe) - FStar_Compiler_CList.clist) -> unit) - = - fun tx -> - fun env -> - fun uu___ -> - match uu___ with - | (variables, ineqs) -> - let fail u1 u2 = - FStar_Syntax_Unionfind.rollback tx; - (let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_univ u1 in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_univ u2 in - FStar_Compiler_Util.format2 - "Universe %s and %s are incompatible" uu___3 uu___4 in - FStar_Errors.raise_error FStar_TypeChecker_Env.hasRange_env - env FStar_Errors_Codes.Fatal_IncompatibleUniverse () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)) in - let equiv v v' = - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress_univ v in - let uu___3 = FStar_Syntax_Subst.compress_univ v' in - (uu___2, uu___3) in - match uu___1 with - | (FStar_Syntax_Syntax.U_unif v0, FStar_Syntax_Syntax.U_unif - v0') -> FStar_Syntax_Unionfind.univ_equiv v0 v0' - | uu___2 -> false in - let sols = - FStar_Compiler_CList.collect - (fun uu___1 -> - (fun v -> - let uu___1 = FStar_Syntax_Subst.compress_univ v in - match uu___1 with - | FStar_Syntax_Syntax.U_unif uu___2 -> - Obj.magic - (Obj.repr - (let lower_bounds_of_v = - FStar_Compiler_CList.collect - (fun uu___3 -> - (fun uu___3 -> - match uu___3 with - | (u, v') -> - let uu___4 = equiv v v' in - if uu___4 - then - let uu___5 = - FStar_Compiler_CList.existsb - (equiv u) variables in - (if uu___5 - then - Obj.magic - (FStar_Class_Listlike.empty - () - (Obj.magic - (FStar_Compiler_CList.listlike_clist - ()))) - else - Obj.magic - (FStar_Class_Listlike.cons - () - (Obj.magic - (FStar_Compiler_CList.listlike_clist - ())) u - (FStar_Class_Listlike.empty - () - (Obj.magic - (FStar_Compiler_CList.listlike_clist - ()))))) - else - Obj.magic - (FStar_Class_Listlike.empty - () - (Obj.magic - (FStar_Compiler_CList.listlike_clist - ())))) uu___3) - ineqs in - let lb = - let uu___3 = - let uu___4 = - FStar_Class_Listlike.to_list - (FStar_Compiler_CList.listlike_clist - ()) lower_bounds_of_v in - FStar_Syntax_Syntax.U_max uu___4 in - FStar_TypeChecker_Normalize.normalize_universe - env uu___3 in - FStar_Class_Listlike.singleton - (FStar_Compiler_CList.listlike_clist ()) - (lb, v))) - | uu___2 -> - Obj.magic - (Obj.repr - (FStar_Class_Listlike.empty () - (Obj.magic - (FStar_Compiler_CList.listlike_clist ()))))) - uu___1) variables in - let uu___1 = - let wl = - let uu___2 = empty_worklist env in - { - attempting = (uu___2.attempting); - wl_deferred = (uu___2.wl_deferred); - wl_deferred_to_tac = (uu___2.wl_deferred_to_tac); - ctr = (uu___2.ctr); - defer_ok = NoDefer; - smt_ok = (uu___2.smt_ok); - umax_heuristic_ok = (uu___2.umax_heuristic_ok); - tcenv = (uu___2.tcenv); - wl_implicits = (uu___2.wl_implicits); - repr_subcomp_allowed = (uu___2.repr_subcomp_allowed); - typeclass_variables = (uu___2.typeclass_variables) - } in - FStar_Compiler_CList.map - (fun uu___2 -> - match uu___2 with - | (lb, v) -> - let uu___3 = - solve_universe_eq (Prims.of_int (-1)) wl lb v in - (match uu___3 with - | USolved wl1 -> () - | uu___4 -> fail lb v)) sols in - let rec check_ineq uu___2 = - match uu___2 with - | (u, v) -> - let u1 = - FStar_TypeChecker_Normalize.normalize_universe env u in - let v1 = - FStar_TypeChecker_Normalize.normalize_universe env v in - (match (u1, v1) with - | (FStar_Syntax_Syntax.U_zero, uu___3) -> true - | (FStar_Syntax_Syntax.U_succ u0, - FStar_Syntax_Syntax.U_succ v0) -> check_ineq (u0, v0) - | (FStar_Syntax_Syntax.U_name u0, - FStar_Syntax_Syntax.U_name v0) -> - FStar_Ident.ident_equals u0 v0 - | (FStar_Syntax_Syntax.U_unif u0, - FStar_Syntax_Syntax.U_unif v0) -> - FStar_Syntax_Unionfind.univ_equiv u0 v0 - | (FStar_Syntax_Syntax.U_name uu___3, - FStar_Syntax_Syntax.U_succ v0) -> check_ineq (u1, v0) - | (FStar_Syntax_Syntax.U_unif uu___3, - FStar_Syntax_Syntax.U_succ v0) -> check_ineq (u1, v0) - | (FStar_Syntax_Syntax.U_max us, uu___3) -> - FStar_Compiler_Util.for_all - (fun u2 -> check_ineq (u2, v1)) us - | (uu___3, FStar_Syntax_Syntax.U_max vs) -> - FStar_Compiler_Util.for_some - (fun v2 -> check_ineq (u1, v2)) vs - | uu___3 -> false) in - let uu___2 = - FStar_Compiler_CList.for_all - (fun uu___3 -> - match uu___3 with - | (u, v) -> - let uu___4 = check_ineq (u, v) in - if uu___4 - then true - else - ((let uu___7 = - FStar_Compiler_Effect.op_Bang dbg_GenUniverses in - if uu___7 - then - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_univ u in - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_univ v in - FStar_Compiler_Util.print2 "%s - (FStar_Syntax_Syntax.universe FStar_Compiler_CList.clist * - (FStar_Syntax_Syntax.universe * FStar_Syntax_Syntax.universe) - FStar_Compiler_CList.clist) -> unit) - = - fun env -> - fun ineqs -> - let tx = FStar_Syntax_Unionfind.new_transaction () in - solve_universe_inequalities' tx env ineqs; - FStar_Syntax_Unionfind.commit tx -let (try_solve_deferred_constraints : - defer_ok_t -> - Prims.bool -> - Prims.bool -> - FStar_TypeChecker_Env.env -> - FStar_TypeChecker_Common.guard_t -> - FStar_TypeChecker_Common.guard_t) - = - fun defer_ok -> - fun smt_ok -> - fun deferred_to_tac_ok -> - fun env -> - fun g -> - let smt_ok1 = - smt_ok && - (let uu___ = FStar_Options.ml_ish () in - Prims.op_Negation uu___) in - FStar_Errors.with_ctx "While solving deferred constraints" - (fun uu___ -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_TypeChecker_Env.current_module env in - FStar_Ident.string_of_lid uu___3 in - FStar_Pervasives_Native.Some uu___2 in - FStar_Profiling.profile - (fun uu___2 -> - let imps_l = - FStar_Class_Listlike.to_list - (FStar_Compiler_CList.listlike_clist ()) - g.FStar_TypeChecker_Common.implicits in - let typeclass_variables = - let uu___3 = - FStar_Compiler_List.collect - (fun i -> - match (i.FStar_TypeChecker_Common.imp_uvar).FStar_Syntax_Syntax.ctx_uvar_meta - with - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Ctx_uvar_meta_tac - tac) -> - let uu___4 = - FStar_Syntax_Util.head_and_args_full tac in - (match uu___4 with - | (head, uu___5) -> - let uu___6 = - FStar_Syntax_Util.is_fvar - FStar_Parser_Const.tcresolve_lid - head in - if uu___6 - then - let goal_type = - FStar_Syntax_Util.ctx_uvar_typ - i.FStar_TypeChecker_Common.imp_uvar in - let uvs = - FStar_Syntax_Free.uvars goal_type in - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) - (Obj.magic uvs) - else []) - | uu___4 -> []) imps_l in - Obj.magic - (FStar_Class_Setlike.from_list () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Free.ord_ctx_uvar)) uu___3) in - let wl = - let uu___3 = - let uu___4 = - FStar_Class_Listlike.to_list - (FStar_Compiler_CList.listlike_clist ()) - g.FStar_TypeChecker_Common.deferred in - wl_of_guard env uu___4 in - { - attempting = (uu___3.attempting); - wl_deferred = (uu___3.wl_deferred); - wl_deferred_to_tac = (uu___3.wl_deferred_to_tac); - ctr = (uu___3.ctr); - defer_ok; - smt_ok = smt_ok1; - umax_heuristic_ok = (uu___3.umax_heuristic_ok); - tcenv = (uu___3.tcenv); - wl_implicits = (uu___3.wl_implicits); - repr_subcomp_allowed = - (uu___3.repr_subcomp_allowed); - typeclass_variables - } in - let fail uu___3 = - match uu___3 with - | (d, s) -> - let msg = explain wl d s in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range (p_loc d) - FStar_Errors_Codes.Fatal_ErrorInSolveDeferredConstraints - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic msg) in - (let uu___4 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___4 - then - let uu___5 = FStar_Class_Show.show uu___0 defer_ok in - let uu___6 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - deferred_to_tac_ok in - let uu___7 = FStar_Class_Show.show showable_wl wl in - let uu___8 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_nat) - (FStar_Compiler_List.length imps_l) in - FStar_Compiler_Util.print4 - "Trying to solve carried problems (defer_ok=%s) (deferred_to_tac_ok=%s): begin\n\t%s\nend\n and %s implicits\n" - uu___5 uu___6 uu___7 uu___8 - else ()); - (let g1 = - let uu___4 = solve_and_commit wl fail in - match uu___4 with - | FStar_Pervasives_Native.Some - (deferred, uu___5, uu___6) when - (let uu___7 = - Obj.magic - (FStar_Class_Listlike.view () - (Obj.magic - (FStar_Compiler_CList.listlike_clist - ())) (Obj.magic deferred)) in - FStar_Class_Listlike.uu___is_VCons uu___7) && - (defer_ok = NoDefer) - -> - failwith - "Impossible: Unexpected deferred constraints remain" - | FStar_Pervasives_Native.Some - (deferred, defer_to_tac, imps) -> - let uu___5 = - FStar_Class_Monoid.op_Plus_Plus - (FStar_Compiler_CList.monoid_clist ()) - g.FStar_TypeChecker_Common.deferred_to_tac - defer_to_tac in - let uu___6 = - FStar_Class_Monoid.op_Plus_Plus - (FStar_Compiler_CList.monoid_clist ()) - g.FStar_TypeChecker_Common.implicits imps in - { - FStar_TypeChecker_Common.guard_f = - (g.FStar_TypeChecker_Common.guard_f); - FStar_TypeChecker_Common.deferred_to_tac = - uu___5; - FStar_TypeChecker_Common.deferred = deferred; - FStar_TypeChecker_Common.univ_ineqs = - (g.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = uu___6 - } - | uu___5 -> - failwith - "Impossible: should have raised a failure already" in - solve_universe_inequalities env - g1.FStar_TypeChecker_Common.univ_ineqs; - (let g2 = - if deferred_to_tac_ok - then - let uu___5 = - let uu___6 = - let uu___7 = - FStar_TypeChecker_Env.current_module env in - FStar_Ident.string_of_lid uu___7 in - FStar_Pervasives_Native.Some uu___6 in - FStar_Profiling.profile - (fun uu___6 -> - FStar_TypeChecker_DeferredImplicits.solve_deferred_to_tactic_goals - env g1) uu___5 - "FStar.TypeChecker.Rel.solve_deferred_to_tactic_goals" - else g1 in - (let uu___6 = - FStar_Compiler_Effect.op_Bang - dbg_ResolveImplicitsHook in - if uu___6 - then - let uu___7 = guard_to_string env g2 in - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Class_Listlike.to_list - (FStar_Compiler_CList.listlike_clist ()) - g2.FStar_TypeChecker_Common.implicits in - FStar_Compiler_List.length uu___10 in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_nat) uu___9 in - FStar_Compiler_Util.print2 - "ResolveImplicitsHook: Solved deferred to tactic goals, remaining guard is\n%s (and %s implicits)\n" - uu___7 uu___8 - else ()); - { - FStar_TypeChecker_Common.guard_f = - (g2.FStar_TypeChecker_Common.guard_f); - FStar_TypeChecker_Common.deferred_to_tac = - (g2.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (g2.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - ((Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic - (FStar_Compiler_CList.listlike_clist ())))), - (Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic - (FStar_Compiler_CList.listlike_clist - ()))))); - FStar_TypeChecker_Common.implicits = - (g2.FStar_TypeChecker_Common.implicits) - }))) uu___1 - "FStar.TypeChecker.Rel.try_solve_deferred_constraints") -let (solve_deferred_constraints : - FStar_TypeChecker_Env.env -> - FStar_TypeChecker_Common.guard_t -> FStar_TypeChecker_Common.guard_t) - = - fun env -> - fun g -> - let defer_ok = NoDefer in - let smt_ok = - let uu___ = FStar_Options.ml_ish () in Prims.op_Negation uu___ in - let deferred_to_tac_ok = true in - try_solve_deferred_constraints defer_ok smt_ok deferred_to_tac_ok env g -let (solve_non_tactic_deferred_constraints : - Prims.bool -> - FStar_TypeChecker_Env.env -> - FStar_TypeChecker_Common.guard_t -> FStar_TypeChecker_Common.guard_t) - = - fun maybe_defer_flex_flex -> - fun env -> - fun g -> - FStar_Errors.with_ctx "solve_non_tactic_deferred_constraints" - (fun uu___ -> - FStar_Defensive.def_check_scoped - FStar_TypeChecker_Env.hasBinders_env - FStar_TypeChecker_Env.hasNames_guard - FStar_TypeChecker_Env.pretty_guard - FStar_Compiler_Range_Type.dummyRange - "solve_non_tactic_deferred_constraints.g" env g; - (let defer_ok = - if maybe_defer_flex_flex then DeferFlexFlexOnly else NoDefer in - let smt_ok = - let uu___2 = FStar_Options.ml_ish () in - Prims.op_Negation uu___2 in - let deferred_to_tac_ok = false in - try_solve_deferred_constraints defer_ok smt_ok - deferred_to_tac_ok env g)) -let (do_discharge_vc : - (unit -> Prims.string) FStar_Pervasives_Native.option -> - FStar_TypeChecker_Env.env -> FStar_TypeChecker_Env.goal -> unit) - = - fun use_env_range_msg -> - fun env -> - fun vc -> - let debug = - ((FStar_Compiler_Effect.op_Bang dbg_Rel) || - (FStar_Compiler_Effect.op_Bang dbg_SMTQuery)) - || (FStar_Compiler_Effect.op_Bang dbg_Discharge) in - let diag uu___1 uu___ = - (let uu___ = FStar_TypeChecker_Env.get_range env in - Obj.magic - (FStar_Errors.diag FStar_Class_HasRange.hasRange_range uu___ ())) - uu___1 uu___ in - if debug - then - (let uu___1 = - let uu___2 = - let uu___3 = FStar_Errors_Msg.text "Checking VC:" in - let uu___4 = - FStar_Class_PP.pp FStar_Syntax_Print.pretty_term vc in - FStar_Pprint.op_Hat_Slash_Hat uu___3 uu___4 in - [uu___2] in - diag FStar_Errors_Msg.is_error_message_list_doc uu___1) - else (); - (let vcs = - let uu___1 = FStar_Options.use_tactics () in - if uu___1 - then - FStar_Options.with_saved_options - (fun uu___2 -> - (let uu___4 = FStar_Options.set_options "--no_tactics" in - ()); - (let uu___4 = - (env.FStar_TypeChecker_Env.solver).FStar_TypeChecker_Env.preprocess - env vc in - match uu___4 with - | (did_anything, vcs1) -> - (if debug && did_anything - then - (let uu___6 = - let uu___7 = - let uu___8 = - FStar_Errors_Msg.text - "Tactic preprocessing produced" in - let uu___9 = - let uu___10 = - FStar_Class_PP.pp FStar_Class_PP.pp_int - (FStar_Compiler_List.length vcs1) in - let uu___11 = FStar_Errors_Msg.text "goals" in - FStar_Pprint.op_Hat_Slash_Hat uu___10 - uu___11 in - FStar_Pprint.op_Hat_Slash_Hat uu___8 uu___9 in - [uu___7] in - diag FStar_Errors_Msg.is_error_message_list_doc - uu___6) - else (); - (let vcs2 = - FStar_Compiler_List.map - (fun uu___6 -> - match uu___6 with - | (env1, goal, opts) -> - let uu___7 = - norm_with_steps - "FStar.TypeChecker.Rel.norm_with_steps.7" - [FStar_TypeChecker_Env.Simplify; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.Exclude - FStar_TypeChecker_Env.Zeta] env1 - goal in - (env1, uu___7, opts)) vcs1 in - let vcs3 = - FStar_Compiler_List.concatMap - (fun uu___6 -> - match uu___6 with - | (env1, goal, opts) -> - let uu___7 = - (env1.FStar_TypeChecker_Env.solver).FStar_TypeChecker_Env.handle_smt_goal - env1 goal in - FStar_Compiler_List.map - (fun uu___8 -> - match uu___8 with - | (env2, goal1) -> - (env2, goal1, opts)) uu___7) - vcs2 in - let vcs4 = - FStar_Compiler_List.concatMap - (fun uu___6 -> - match uu___6 with - | (env1, goal, opts) -> - let uu___7 = - FStar_TypeChecker_Common.check_trivial - goal in - (match uu___7 with - | FStar_TypeChecker_Common.Trivial -> - (if debug - then - (let uu___9 = - let uu___10 = - FStar_Errors_Msg.text - "Goal completely solved by tactic\n" in - [uu___10] in - diag - FStar_Errors_Msg.is_error_message_list_doc - uu___9) - else (); - []) - | FStar_TypeChecker_Common.NonTrivial - goal1 -> [(env1, goal1, opts)])) - vcs3 in - vcs4)))) - else - (let uu___3 = - let uu___4 = FStar_Options.peek () in (env, vc, uu___4) in - [uu___3]) in - let vcs1 = - let uu___1 = - let uu___2 = FStar_Options.split_queries () in - uu___2 = FStar_Options.Always in - if uu___1 - then - FStar_Compiler_List.collect - (fun uu___2 -> - match uu___2 with - | (env1, goal, opts) -> - let uu___3 = - FStar_TypeChecker_Env.split_smt_query env1 goal in - (match uu___3 with - | FStar_Pervasives_Native.None -> [(env1, goal, opts)] - | FStar_Pervasives_Native.Some goals -> - FStar_Compiler_List.map - (fun uu___4 -> - match uu___4 with - | (env2, goal1) -> (env2, goal1, opts)) goals)) - vcs - else vcs in - FStar_Compiler_List.iter - (fun uu___1 -> - match uu___1 with - | (env1, goal, opts) -> - FStar_Options.with_saved_options - (fun uu___2 -> - FStar_Options.set opts; - if debug - then - (let uu___5 = - let uu___6 = - let uu___7 = - FStar_Errors_Msg.text - "Before calling solver, VC =" in - let uu___8 = - FStar_Class_PP.pp - FStar_Syntax_Print.pretty_term goal in - FStar_Pprint.op_Hat_Slash_Hat uu___7 uu___8 in - [uu___6] in - diag FStar_Errors_Msg.is_error_message_list_doc - uu___5) - else (); - (env1.FStar_TypeChecker_Env.solver).FStar_TypeChecker_Env.solve - use_env_range_msg env1 goal)) vcs1) -let (discharge_guard' : - (unit -> Prims.string) FStar_Pervasives_Native.option -> - FStar_TypeChecker_Env.env -> - FStar_TypeChecker_Common.guard_t -> - Prims.bool -> - FStar_TypeChecker_Common.guard_t FStar_Pervasives_Native.option) - = - fun use_env_range_msg -> - fun env -> - fun g -> - fun use_smt -> - (let uu___1 = - FStar_Compiler_Effect.op_Bang dbg_ResolveImplicitsHook in - if uu___1 - then - let uu___2 = guard_to_string env g in - FStar_Compiler_Util.print1 - "///////////////////ResolveImplicitsHook: discharge_guard'\nguard = %s\n" - uu___2 - else ()); - (let g1 = - let defer_ok = NoDefer in - let smt_ok = - (let uu___1 = FStar_Options.ml_ish () in - Prims.op_Negation uu___1) && use_smt in - let deferred_to_tac_ok = true in - try_solve_deferred_constraints defer_ok smt_ok - deferred_to_tac_ok env g in - let debug = - ((FStar_Compiler_Effect.op_Bang dbg_Rel) || - (FStar_Compiler_Effect.op_Bang dbg_SMTQuery)) - || (FStar_Compiler_Effect.op_Bang dbg_Discharge) in - let diag uu___2 uu___1 = - (let uu___1 = FStar_TypeChecker_Env.get_range env in - Obj.magic - (FStar_Errors.diag FStar_Class_HasRange.hasRange_range uu___1 - ())) uu___2 uu___1 in - let ret_g = - { - FStar_TypeChecker_Common.guard_f = - FStar_TypeChecker_Common.Trivial; - FStar_TypeChecker_Common.deferred_to_tac = - (g1.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (g1.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (g1.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = - (g1.FStar_TypeChecker_Common.implicits) - } in - if env.FStar_TypeChecker_Env.admit - then - (if - (debug && - (Prims.op_Negation - (FStar_TypeChecker_Common.uu___is_Trivial - g1.FStar_TypeChecker_Common.guard_f))) - && (Prims.op_Negation env.FStar_TypeChecker_Env.phase1) - then - (let uu___2 = - let uu___3 = - FStar_Errors_Msg.text - "Skipping VC because verification is disabled." in - let uu___4 = - let uu___5 = - let uu___6 = FStar_Errors_Msg.text "VC =" in - let uu___7 = - FStar_Class_PP.pp FStar_TypeChecker_Env.pretty_guard - g1 in - FStar_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in - [uu___5] in - uu___3 :: uu___4 in - diag FStar_Errors_Msg.is_error_message_list_doc uu___2) - else (); - FStar_Pervasives_Native.Some ret_g) - else - (let g2 = simplify_guard_full_norm env g1 in - match g2.FStar_TypeChecker_Common.guard_f with - | FStar_TypeChecker_Common.Trivial -> - FStar_Pervasives_Native.Some ret_g - | FStar_TypeChecker_Common.NonTrivial vc when - Prims.op_Negation use_smt -> - (if debug - then - (let uu___3 = - let uu___4 = - let uu___5 = - FStar_Errors_Msg.text "Cannot solve without SMT:" in - let uu___6 = - FStar_Class_PP.pp FStar_Syntax_Print.pretty_term - vc in - FStar_Pprint.op_Hat_Slash_Hat uu___5 uu___6 in - [uu___4] in - diag FStar_Errors_Msg.is_error_message_list_doc uu___3) - else (); - FStar_Pervasives_Native.None) - | FStar_TypeChecker_Common.NonTrivial vc -> - (do_discharge_vc use_env_range_msg env vc; - FStar_Pervasives_Native.Some ret_g))) -let (discharge_guard : - FStar_TypeChecker_Env.env -> - FStar_TypeChecker_Common.guard_t -> FStar_TypeChecker_Common.guard_t) - = - fun env -> - fun g -> - let uu___ = discharge_guard' FStar_Pervasives_Native.None env g true in - match uu___ with - | FStar_Pervasives_Native.Some g1 -> g1 - | FStar_Pervasives_Native.None -> - failwith - "Impossible, with use_smt = true, discharge_guard' should never have returned None" -let (discharge_guard_no_smt : - FStar_TypeChecker_Env.env -> - FStar_TypeChecker_Common.guard_t -> FStar_TypeChecker_Common.guard_t) - = - fun env -> - fun g -> - let uu___ = discharge_guard' FStar_Pervasives_Native.None env g false in - match uu___ with - | FStar_Pervasives_Native.Some g1 -> g1 - | FStar_Pervasives_Native.None -> - let uu___1 = - let uu___2 = - FStar_Errors_Msg.text "Expected a trivial pre-condition" in - [uu___2] in - FStar_Errors.raise_error FStar_TypeChecker_Env.hasRange_env env - FStar_Errors_Codes.Fatal_ExpectTrivialPreCondition () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___1) -let (teq_nosmt : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.typ -> - FStar_TypeChecker_Common.guard_t FStar_Pervasives_Native.option) - = - fun env -> - fun t1 -> - fun t2 -> - let uu___ = try_teq false env t1 t2 in - match uu___ with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some g -> - discharge_guard' FStar_Pervasives_Native.None env g false -let (subtype_nosmt : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.typ -> - FStar_TypeChecker_Common.guard_t FStar_Pervasives_Native.option) - = - fun env -> - fun t1 -> - fun t2 -> - (let uu___1 = - (FStar_Compiler_Effect.op_Bang dbg_Rel) || - (FStar_Compiler_Effect.op_Bang dbg_RelTop) in - if uu___1 - then - let uu___2 = FStar_TypeChecker_Normalize.term_to_string env t1 in - let uu___3 = FStar_TypeChecker_Normalize.term_to_string env t2 in - FStar_Compiler_Util.print2 "try_subtype_no_smt of %s and %s\n" - uu___2 uu___3 - else ()); - (let uu___1 = - let uu___2 = empty_worklist env in - new_t_prob uu___2 env t1 FStar_TypeChecker_Common.SUB t2 in - match uu___1 with - | (prob, x, wl) -> - let g = - let uu___2 = - solve_and_commit (singleton wl prob false) - (fun uu___3 -> FStar_Pervasives_Native.None) in - with_guard env prob uu___2 in - (match g with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some g1 -> - let g2 = - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.mk_binder x in - [uu___3] in - FStar_TypeChecker_Env.close_guard env uu___2 g1 in - discharge_guard' FStar_Pervasives_Native.None env g2 false)) -let (check_subtyping : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - (FStar_Syntax_Syntax.bv * FStar_TypeChecker_Common.guard_t) - FStar_Pervasives_Native.option) - = - fun env -> - fun t1 -> - fun t2 -> - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_Env.current_module env in - FStar_Ident.string_of_lid uu___2 in - FStar_Pervasives_Native.Some uu___1 in - FStar_Profiling.profile - (fun uu___1 -> - (let uu___3 = - (FStar_Compiler_Effect.op_Bang dbg_Rel) || - (FStar_Compiler_Effect.op_Bang dbg_RelTop) in - if uu___3 - then - let uu___4 = - FStar_TypeChecker_Normalize.term_to_string env t1 in - let uu___5 = - FStar_TypeChecker_Normalize.term_to_string env t2 in - FStar_Compiler_Util.print2 "check_subtyping of %s and %s\n" - uu___4 uu___5 - else ()); - (let uu___3 = - let uu___4 = empty_worklist env in - new_t_prob uu___4 env t1 FStar_TypeChecker_Common.SUB t2 in - match uu___3 with - | (prob, x, wl) -> - let env_x = FStar_TypeChecker_Env.push_bv env x in - let smt_ok = - let uu___4 = FStar_Options.ml_ish () in - Prims.op_Negation uu___4 in - let g = - let uu___4 = - solve_and_commit (singleton wl prob smt_ok) - (fun uu___5 -> FStar_Pervasives_Native.None) in - with_guard env_x prob uu___4 in - (match g with - | FStar_Pervasives_Native.None -> - ((let uu___5 = - (FStar_Compiler_Effect.op_Bang dbg_Rel) || - (FStar_Compiler_Effect.op_Bang dbg_RelTop) in - if uu___5 - then - let uu___6 = - FStar_TypeChecker_Normalize.term_to_string env_x - t1 in - let uu___7 = - FStar_TypeChecker_Normalize.term_to_string env_x - t2 in - FStar_Compiler_Util.print2 - "check_subtyping FAILED: %s <: %s\n" uu___6 - uu___7 - else ()); - FStar_Pervasives_Native.None) - | FStar_Pervasives_Native.Some g1 -> - ((let uu___5 = - (FStar_Compiler_Effect.op_Bang dbg_Rel) || - (FStar_Compiler_Effect.op_Bang dbg_RelTop) in - if uu___5 - then - let uu___6 = - FStar_TypeChecker_Normalize.term_to_string env_x - t1 in - let uu___7 = - FStar_TypeChecker_Normalize.term_to_string env_x - t2 in - let uu___8 = guard_to_string env_x g1 in - FStar_Compiler_Util.print3 - "check_subtyping succeeded: %s <: %s\n\tguard is %s\n" - uu___6 uu___7 uu___8 - else ()); - FStar_Pervasives_Native.Some (x, g1))))) uu___ - "FStar.TypeChecker.Rel.check_subtyping" -let (get_subtyping_predicate : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.typ -> - FStar_TypeChecker_Common.guard_t FStar_Pervasives_Native.option) - = - fun env -> - fun t1 -> - fun t2 -> - FStar_Errors.with_ctx "While trying to get a subtyping predicate" - (fun uu___ -> - FStar_Defensive.def_check_scoped - FStar_TypeChecker_Env.hasBinders_env - FStar_Class_Binders.hasNames_term - FStar_Syntax_Print.pretty_term t1.FStar_Syntax_Syntax.pos - "get_subtyping_predicate.1" env t1; - FStar_Defensive.def_check_scoped - FStar_TypeChecker_Env.hasBinders_env - FStar_Class_Binders.hasNames_term - FStar_Syntax_Print.pretty_term t2.FStar_Syntax_Syntax.pos - "get_subtyping_predicate.2" env t2; - (let uu___3 = check_subtyping env t1 t2 in - match uu___3 with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (x, g) -> - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.mk_binder x in - FStar_TypeChecker_Env.abstract_guard uu___5 g in - FStar_Pervasives_Native.Some uu___4)) -let (get_subtyping_prop : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.typ -> - FStar_TypeChecker_Common.guard_t FStar_Pervasives_Native.option) - = - fun env -> - fun t1 -> - fun t2 -> - FStar_Errors.with_ctx "While trying to get a subtyping proposition" - (fun uu___ -> - FStar_Defensive.def_check_scoped - FStar_TypeChecker_Env.hasBinders_env - FStar_Class_Binders.hasNames_term - FStar_Syntax_Print.pretty_term t1.FStar_Syntax_Syntax.pos - "get_subtyping_prop.1" env t1; - FStar_Defensive.def_check_scoped - FStar_TypeChecker_Env.hasBinders_env - FStar_Class_Binders.hasNames_term - FStar_Syntax_Print.pretty_term t2.FStar_Syntax_Syntax.pos - "get_subtyping_prop.2" env t2; - (let uu___3 = check_subtyping env t1 t2 in - match uu___3 with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (x, g) -> - let uu___4 = - let uu___5 = - let uu___6 = FStar_Syntax_Syntax.mk_binder x in - [uu___6] in - FStar_TypeChecker_Env.close_guard env uu___5 g in - FStar_Pervasives_Native.Some uu___4)) -let (try_solve_single_valued_implicits : - FStar_TypeChecker_Env.env -> - Prims.bool -> - FStar_TypeChecker_Env.implicits -> - (FStar_TypeChecker_Env.implicits * Prims.bool)) - = - fun env -> - fun is_tac -> - fun imps -> - if is_tac - then (imps, false) - else - (let imp_value imp = - let uu___1 = - ((imp.FStar_TypeChecker_Common.imp_uvar), - (imp.FStar_TypeChecker_Common.imp_range)) in - match uu___1 with - | (ctx_u, r) -> - let t_norm = - let uu___2 = FStar_Syntax_Util.ctx_uvar_typ ctx_u in - FStar_TypeChecker_Normalize.normalize - FStar_TypeChecker_Normalize.whnf_steps env uu___2 in - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress t_norm in - uu___3.FStar_Syntax_Syntax.n in - (match uu___2 with - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.unit_lid - -> - let uu___3 = - FStar_Syntax_Syntax.unit_const_with_range r in - FStar_Pervasives_Native.Some uu___3 - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = b; - FStar_Syntax_Syntax.phi = uu___3;_} - when - FStar_Syntax_Util.is_unit b.FStar_Syntax_Syntax.sort -> - let uu___4 = - FStar_Syntax_Syntax.unit_const_with_range r in - FStar_Pervasives_Native.Some uu___4 - | uu___3 -> FStar_Pervasives_Native.None) in - let b = - FStar_Compiler_List.fold_left - (fun b1 -> - fun imp -> - let uu___1 = - (let uu___2 = - FStar_Syntax_Unionfind.find - (imp.FStar_TypeChecker_Common.imp_uvar).FStar_Syntax_Syntax.ctx_uvar_head in - FStar_Compiler_Util.is_none uu___2) && - (let uu___2 = - FStar_Syntax_Util.ctx_uvar_should_check - imp.FStar_TypeChecker_Common.imp_uvar in - uu___2 = FStar_Syntax_Syntax.Strict) in - if uu___1 - then - let uu___2 = imp_value imp in - match uu___2 with - | FStar_Pervasives_Native.Some tm -> - (commit env - [TERM - ((imp.FStar_TypeChecker_Common.imp_uvar), tm)]; - true) - | FStar_Pervasives_Native.None -> b1 - else b1) false imps in - (imps, b)) -let (check_implicit_solution_and_discharge_guard : - FStar_TypeChecker_Env.env -> - FStar_TypeChecker_Common.implicit -> - Prims.bool -> - Prims.bool -> - FStar_TypeChecker_Common.implicits_t FStar_Pervasives_Native.option) - = - fun env -> - fun imp -> - fun is_tac -> - fun force_univ_constraints -> - let uu___ = imp in - match uu___ with - | { FStar_TypeChecker_Common.imp_reason = imp_reason; - FStar_TypeChecker_Common.imp_uvar = imp_uvar; - FStar_TypeChecker_Common.imp_tm = imp_tm; - FStar_TypeChecker_Common.imp_range = imp_range;_} -> - let uvar_ty = FStar_Syntax_Util.ctx_uvar_typ imp_uvar in - let uvar_should_check = - FStar_Syntax_Util.ctx_uvar_should_check imp_uvar in - ((let uu___2 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___2 - then - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_uvar - imp_uvar.FStar_Syntax_Syntax.ctx_uvar_head in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - imp_tm in - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - uvar_ty in - let uu___6 = - FStar_Compiler_Range_Ops.string_of_range imp_range in - FStar_Compiler_Util.print5 - "Checking uvar %s resolved to %s at type %s, introduce for %s at %s\n" - uu___3 uu___4 uu___5 imp_reason uu___6 - else ()); - (let env1 = - let uu___2 = - FStar_TypeChecker_Env.clear_expected_typ - { - FStar_TypeChecker_Env.solver = - (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (imp_uvar.FStar_Syntax_Syntax.ctx_uvar_gamma); - FStar_TypeChecker_Env.gamma_sig = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (env.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env.FStar_TypeChecker_Env.missing_decl) - } in - FStar_Pervasives_Native.fst uu___2 in - let g = - FStar_Errors.with_ctx "While checking implicit solution" - (fun uu___2 -> - let skip_core = - ((env1.FStar_TypeChecker_Env.phase1 || - env1.FStar_TypeChecker_Env.admit) - || - (FStar_Syntax_Syntax.uu___is_Allow_untyped - uvar_should_check)) - || - (FStar_Syntax_Syntax.uu___is_Already_checked - uvar_should_check) in - let must_tot = - Prims.op_Negation - ((env1.FStar_TypeChecker_Env.phase1 || - env1.FStar_TypeChecker_Env.admit) - || - (FStar_Syntax_Syntax.uu___is_Allow_ghost - uvar_should_check)) in - if skip_core - then - (if is_tac - then FStar_TypeChecker_Env.trivial_guard - else - (let imp_tm1 = - let uu___4 = - let uu___5 = - FStar_Syntax_Subst.compress imp_tm in - uu___5.FStar_Syntax_Syntax.n in - match uu___4 with - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = - FStar_Pervasives_Native.Some rc;_} - -> - { - FStar_Syntax_Syntax.n = - (FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = bs; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = - (FStar_Pervasives_Native.Some - { - FStar_Syntax_Syntax.residual_effect - = - (rc.FStar_Syntax_Syntax.residual_effect); - FStar_Syntax_Syntax.residual_typ - = - FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.residual_flags - = - (rc.FStar_Syntax_Syntax.residual_flags) - }) - }); - FStar_Syntax_Syntax.pos = - (imp_tm.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = - (imp_tm.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (imp_tm.FStar_Syntax_Syntax.hash_code) - } - | uu___5 -> imp_tm in - let uu___4 = - env1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - env1 imp_tm1 must_tot in - match uu___4 with - | (k', g1) -> - let uu___5 = - get_subtyping_predicate env1 k' uvar_ty in - (match uu___5 with - | FStar_Pervasives_Native.None -> - FStar_TypeChecker_Err.expected_expression_of_type - env1 imp_tm1.FStar_Syntax_Syntax.pos - uvar_ty imp_tm1 k' - | FStar_Pervasives_Native.Some f -> - let uu___6 = - let uu___7 = - FStar_TypeChecker_Env.apply_guard f - imp_tm1 in - FStar_TypeChecker_Env.conj_guard - uu___7 g1 in - { - FStar_TypeChecker_Common.guard_f = - FStar_TypeChecker_Common.Trivial; - FStar_TypeChecker_Common.deferred_to_tac - = - (uu___6.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (uu___6.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (uu___6.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = - (uu___6.FStar_TypeChecker_Common.implicits) - }))) - else - (let uu___4 = - env1.FStar_TypeChecker_Env.core_check env1 imp_tm - uvar_ty must_tot in - match uu___4 with - | FStar_Pervasives.Inl - (FStar_Pervasives_Native.None) -> - FStar_TypeChecker_Common.trivial_guard - | FStar_Pervasives.Inl - (FStar_Pervasives_Native.Some g1) -> - { - FStar_TypeChecker_Common.guard_f = - (FStar_TypeChecker_Common.NonTrivial g1); - FStar_TypeChecker_Common.deferred_to_tac = - (FStar_TypeChecker_Common.trivial_guard.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (FStar_TypeChecker_Common.trivial_guard.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (FStar_TypeChecker_Common.trivial_guard.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = - (FStar_TypeChecker_Common.trivial_guard.FStar_TypeChecker_Common.implicits) - } - | FStar_Pervasives.Inr print_err -> - let uu___5 = - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_ctxu imp_uvar in - let uu___7 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - is_tac in - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term imp_tm in - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term uvar_ty in - FStar_Compiler_Util.format5 - "Core checking failed for implicit %s (is_tac: %s) (reason: %s) (%s <: %s)" - uu___6 uu___7 imp_reason uu___8 uu___9 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range imp_range - FStar_Errors_Codes.Fatal_FailToResolveImplicitArgument - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___5))) in - let uu___2 = - (Prims.op_Negation force_univ_constraints) && - (FStar_Compiler_CList.existsb - (fun uu___3 -> - match uu___3 with - | (reason, uu___4, uu___5) -> - reason = - FStar_TypeChecker_Common.Deferred_univ_constraint) - g.FStar_TypeChecker_Common.deferred) in - if uu___2 - then FStar_Pervasives_Native.None - else - (let g' = - let uu___4 = - discharge_guard' - (FStar_Pervasives_Native.Some - (fun uu___5 -> - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term imp_tm in - let uu___7 = - FStar_Class_Show.show - FStar_Compiler_Range_Ops.showable_range - imp_range in - let uu___8 = - FStar_Class_Show.show - FStar_Compiler_Range_Ops.showable_range - imp_tm.FStar_Syntax_Syntax.pos in - FStar_Compiler_Util.format4 - "%s (Introduced at %s for %s resolved at %s)" - uu___6 uu___7 imp_reason uu___8)) env1 g - true in - match uu___4 with - | FStar_Pervasives_Native.Some g1 -> g1 - | FStar_Pervasives_Native.None -> - failwith - "Impossible, with use_smt = true, discharge_guard' must return Some" in - FStar_Pervasives_Native.Some - (g'.FStar_TypeChecker_Common.implicits)))) -let rec (unresolved : FStar_Syntax_Syntax.ctx_uvar -> Prims.bool) = - fun ctx_u -> - let uu___ = - FStar_Syntax_Unionfind.find ctx_u.FStar_Syntax_Syntax.ctx_uvar_head in - match uu___ with - | FStar_Pervasives_Native.Some r -> - (match ctx_u.FStar_Syntax_Syntax.ctx_uvar_meta with - | FStar_Pervasives_Native.None -> false - | FStar_Pervasives_Native.Some uu___1 -> - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress r in - uu___3.FStar_Syntax_Syntax.n in - (match uu___2 with - | FStar_Syntax_Syntax.Tm_uvar (ctx_u', uu___3) -> - unresolved ctx_u' - | uu___3 -> false)) - | FStar_Pervasives_Native.None -> true -let (pick_a_univ_deffered_implicit : - tagged_implicits -> - (FStar_TypeChecker_Env.implicit FStar_Pervasives_Native.option * - tagged_implicits)) - = - fun out -> - let uu___ = - FStar_Compiler_List.partition - (fun uu___1 -> - match uu___1 with - | (uu___2, status) -> - status = Implicit_checking_defers_univ_constraint) out in - match uu___ with - | (imps_with_deferred_univs, rest) -> - (match imps_with_deferred_univs with - | [] -> (FStar_Pervasives_Native.None, out) - | hd::tl -> - ((FStar_Pervasives_Native.Some (FStar_Pervasives_Native.fst hd)), - (FStar_Compiler_List.op_At tl rest))) -let (is_tac_implicit_resolved : - FStar_TypeChecker_Env.env -> - FStar_TypeChecker_Common.implicit -> Prims.bool) - = - fun env -> - fun i -> - let uu___ = FStar_Syntax_Free.uvars i.FStar_TypeChecker_Common.imp_tm in - FStar_Class_Setlike.for_all () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) - (fun uv -> - let uu___1 = FStar_Syntax_Util.ctx_uvar_should_check uv in - FStar_Syntax_Syntax.uu___is_Allow_unresolved uu___1) - (Obj.magic uu___) -let (resolve_implicits' : - FStar_TypeChecker_Env.env -> - Prims.bool -> - Prims.bool -> - FStar_TypeChecker_Env.implicits -> - (FStar_TypeChecker_Common.implicit * implicit_checking_status) - Prims.list) - = - fun env -> - fun is_tac -> - fun is_gen -> - fun implicits -> - let cacheable tac = - (FStar_Syntax_Util.is_fvar FStar_Parser_Const.tcresolve_lid tac) - || - (let uu___ = - let uu___1 = FStar_Syntax_Subst.compress tac in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = uu___1::[]; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = uu___2;_} - -> - let uu___3 = FStar_Syntax_Util.head_and_args body in - (match uu___3 with - | (hd, args) -> - (FStar_Syntax_Util.is_fvar - FStar_Parser_Const.tcresolve_lid hd) - && - ((FStar_Compiler_List.length args) = Prims.int_one)) - | uu___1 -> false) in - let meta_tac_allowed_for_open_problem tac = cacheable tac in - let __meta_arg_cache = FStar_Compiler_Util.mk_ref [] in - let meta_arg_cache_result tac e ty res = - let uu___ = - let uu___1 = FStar_Compiler_Effect.op_Bang __meta_arg_cache in - (tac, e, ty, res) :: uu___1 in - FStar_Compiler_Effect.op_Colon_Equals __meta_arg_cache uu___ in - let meta_arg_cache_lookup tac e ty = - let rec aux l = - match l with - | [] -> FStar_Pervasives_Native.None - | (tac', e', ty', res')::l' -> - let uu___ = - ((FStar_Syntax_Util.term_eq tac tac') && - (FStar_Common.eq_list FStar_Syntax_Util.eq_binding - e.FStar_TypeChecker_Env.gamma - e'.FStar_TypeChecker_Env.gamma)) - && (FStar_Syntax_Util.term_eq ty ty') in - if uu___ then FStar_Pervasives_Native.Some res' else aux l' in - let uu___ = FStar_Compiler_Effect.op_Bang __meta_arg_cache in - aux uu___ in - let rec until_fixpoint acc implicits1 = - let uu___ = acc in - match uu___ with - | (out, changed, defer_open_metas) -> - (match implicits1 with - | [] -> - if changed - then - let uu___1 = - FStar_Compiler_List.map FStar_Pervasives_Native.fst - out in - until_fixpoint ([], false, true) uu___1 - else - if defer_open_metas - then - (let uu___2 = - FStar_Compiler_List.map - FStar_Pervasives_Native.fst out in - until_fixpoint ([], false, false) uu___2) - else - (let uu___3 = - let uu___4 = - FStar_Compiler_List.map - FStar_Pervasives_Native.fst out in - try_solve_single_valued_implicits env is_tac - uu___4 in - match uu___3 with - | (imps, changed1) -> - if changed1 - then until_fixpoint ([], false, true) imps - else - (let uu___5 = - pick_a_univ_deffered_implicit out in - match uu___5 with - | (imp_opt, rest) -> - (match imp_opt with - | FStar_Pervasives_Native.None -> rest - | FStar_Pervasives_Native.Some imp -> - let force_univ_constraints = true in - let imps1 = - let uu___6 = - check_implicit_solution_and_discharge_guard - env imp is_tac - force_univ_constraints in - FStar_Compiler_Util.must uu___6 in - let uu___6 = - let uu___7 = - FStar_Class_Listlike.to_list - (FStar_Compiler_CList.listlike_clist - ()) imps1 in - let uu___8 = - FStar_Compiler_List.map - FStar_Pervasives_Native.fst - rest in - FStar_Class_Monoid.op_Plus_Plus - (FStar_Class_Monoid.monoid_list - ()) uu___7 uu___8 in - until_fixpoint ([], false, true) - uu___6))) - | hd::tl -> - let uu___1 = hd in - (match uu___1 with - | { FStar_TypeChecker_Common.imp_reason = reason; - FStar_TypeChecker_Common.imp_uvar = ctx_u; - FStar_TypeChecker_Common.imp_tm = tm; - FStar_TypeChecker_Common.imp_range = r;_} -> - let uu___2 = - FStar_Syntax_Unionfind.find_decoration - ctx_u.FStar_Syntax_Syntax.ctx_uvar_head in - (match uu___2 with - | { - FStar_Syntax_Syntax.uvar_decoration_typ = - uvar_decoration_typ; - FStar_Syntax_Syntax.uvar_decoration_typedness_depends_on - = uu___3; - FStar_Syntax_Syntax.uvar_decoration_should_check - = uvar_decoration_should_check; - FStar_Syntax_Syntax.uvar_decoration_should_unrefine - = uu___4;_} - -> - ((let uu___6 = - FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___6 - then - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term tm in - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_ctxu ctx_u in - let uu___9 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - is_tac in - let uu___10 = - FStar_Class_Show.show - FStar_Syntax_Syntax.showable_should_check_uvar - uvar_decoration_should_check in - FStar_Compiler_Util.print4 - "resolve_implicits' loop, imp_tm=%s and ctx_u=%s, is_tac=%s, should_check=%s\n" - uu___7 uu___8 uu___9 uu___10 - else ()); - if - FStar_Syntax_Syntax.uu___is_Allow_unresolved - uvar_decoration_should_check - then - until_fixpoint - (out, true, defer_open_metas) tl - else - if - (unresolved ctx_u) && - (flex_uvar_has_meta_tac ctx_u) - then - (let uu___6 = - ctx_u.FStar_Syntax_Syntax.ctx_uvar_meta in - match uu___6 with - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Ctx_uvar_meta_tac - tac) -> - let env1 = - { - FStar_TypeChecker_Env.solver = - (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule - = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (ctx_u.FStar_Syntax_Syntax.ctx_uvar_gamma); - FStar_TypeChecker_Env.gamma_sig - = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache - = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ - = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp - = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize - = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level - = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars - = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict - = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (env.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes - = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking - = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping - = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics - = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of - = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force - = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths - = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook - = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess - = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess - = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info - = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab - = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check - = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl - = - (env.FStar_TypeChecker_Env.missing_decl) - } in - let typ = - FStar_Syntax_Util.ctx_uvar_typ - ctx_u in - let is_open = - (has_free_uvars typ) || - (gamma_has_free_uvars - ctx_u.FStar_Syntax_Syntax.ctx_uvar_gamma) in - if defer_open_metas && is_open - then - ((let uu___8 = - (FStar_Compiler_Effect.op_Bang - dbg_Rel) - || - (FStar_Compiler_Effect.op_Bang - dbg_Imps) in - if uu___8 - then - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_ctxu - ctx_u in - FStar_Compiler_Util.print1 - "Deferring implicit due to open ctx/typ %s\n" - uu___9 - else ()); - until_fixpoint - (((hd, Implicit_unresolved) :: - out), changed, - defer_open_metas) tl) - else - (let uu___8 = - (is_open && - (let uu___9 = - meta_tac_allowed_for_open_problem - tac in - Prims.op_Negation uu___9)) - && - (let uu___9 = - FStar_Options_Ext.get - "compat:open_metas" in - uu___9 = "") in - if uu___8 - then - until_fixpoint - (((hd, Implicit_unresolved) - :: out), changed, - defer_open_metas) tl - else - (let solve_with t = - let extra = - let uu___10 = - teq_nosmt env1 t tm in - match uu___10 with - | FStar_Pervasives_Native.None - -> - failwith - "resolve_implicits: unifying with an unresolved uvar failed?" - | FStar_Pervasives_Native.Some - g -> - FStar_Class_Listlike.to_list - (FStar_Compiler_CList.listlike_clist - ()) - g.FStar_TypeChecker_Common.implicits in - until_fixpoint - (out, true, - defer_open_metas) - (FStar_Compiler_List.op_At - extra tl) in - let uu___10 = cacheable tac in - if uu___10 - then - let uu___11 = - meta_arg_cache_lookup tac - env1 typ in - match uu___11 with - | FStar_Pervasives_Native.Some - res -> solve_with res - | FStar_Pervasives_Native.None - -> - let t = - run_meta_arg_tac env1 - ctx_u in - (meta_arg_cache_result - tac env1 typ t; - solve_with t) - else - (let t = - run_meta_arg_tac env1 - ctx_u in - solve_with t)))) - else - if unresolved ctx_u - then - until_fixpoint - (((hd, Implicit_unresolved) :: out), - changed, defer_open_metas) tl - else - if - ((FStar_Syntax_Syntax.uu___is_Allow_untyped - uvar_decoration_should_check) - || - (FStar_Syntax_Syntax.uu___is_Already_checked - uvar_decoration_should_check)) - || is_gen - then - until_fixpoint - (out, true, defer_open_metas) tl - else - (let env1 = - { - FStar_TypeChecker_Env.solver = - (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule - = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (ctx_u.FStar_Syntax_Syntax.ctx_uvar_gamma); - FStar_TypeChecker_Env.gamma_sig - = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache - = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ - = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp - = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize - = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level - = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars - = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict - = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (env.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes - = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking - = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping - = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics - = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of - = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force - = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths - = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook - = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess - = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess - = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info - = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab - = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check - = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl - = - (env.FStar_TypeChecker_Env.missing_decl) - } in - let tm1 = - norm_with_steps - "FStar.TypeChecker.Rel.norm_with_steps.8" - [FStar_TypeChecker_Env.Beta] - env1 tm in - let hd1 = - { - FStar_TypeChecker_Common.imp_reason - = - (hd.FStar_TypeChecker_Common.imp_reason); - FStar_TypeChecker_Common.imp_uvar - = - (hd.FStar_TypeChecker_Common.imp_uvar); - FStar_TypeChecker_Common.imp_tm - = tm1; - FStar_TypeChecker_Common.imp_range - = - (hd.FStar_TypeChecker_Common.imp_range) - } in - if is_tac - then - ((let uu___7 = - is_tac_implicit_resolved env1 - hd1 in - if uu___7 - then - let force_univ_constraints = - true in - let res = - check_implicit_solution_and_discharge_guard - env1 hd1 is_tac - force_univ_constraints in - let res1 = - FStar_Compiler_Util.map_opt - res - (FStar_Class_Listlike.to_list - (FStar_Compiler_CList.listlike_clist - ())) in - (if - res1 <> - (FStar_Pervasives_Native.Some - []) - then - failwith - "Impossible: check_implicit_solution_and_discharge_guard for tac must return Some []" - else ()) - else ()); - until_fixpoint - (out, true, defer_open_metas) - tl) - else - (let force_univ_constraints = - false in - let imps_opt = - check_implicit_solution_and_discharge_guard - env1 hd1 is_tac - force_univ_constraints in - match imps_opt with - | FStar_Pervasives_Native.None -> - until_fixpoint - (((hd1, - Implicit_checking_defers_univ_constraint) - :: out), changed, - defer_open_metas) tl - | FStar_Pervasives_Native.Some - imps -> - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Class_Listlike.to_list - (FStar_Compiler_CList.listlike_clist - ()) imps in - FStar_Compiler_List.map - (fun i -> - (i, - Implicit_unresolved)) - uu___10 in - FStar_Compiler_List.op_At - uu___9 out in - (uu___8, true, - defer_open_metas) in - until_fixpoint uu___7 tl)))))) in - until_fixpoint ([], false, true) implicits -let (resolve_implicits : - FStar_TypeChecker_Env.env -> - FStar_TypeChecker_Common.guard_t -> FStar_TypeChecker_Common.guard_t) - = - fun env -> - fun g -> - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_ResolveImplicitsHook in - if uu___1 - then - let uu___2 = guard_to_string env g in - FStar_Compiler_Util.print1 - "//////////////////////////ResolveImplicitsHook: resolve_implicits begin////////////\nguard = %s {\n" - uu___2 - else ()); - (let tagged_implicits1 = - let uu___1 = - FStar_Class_Listlike.to_list - (FStar_Compiler_CList.listlike_clist ()) - g.FStar_TypeChecker_Common.implicits in - resolve_implicits' env false false uu___1 in - (let uu___2 = FStar_Compiler_Effect.op_Bang dbg_ResolveImplicitsHook in - if uu___2 - then - FStar_Compiler_Util.print_string - "//////////////////////////ResolveImplicitsHook: resolve_implicits end////////////\n}\n" - else ()); - (let uu___2 = - let uu___3 = - FStar_Compiler_List.map FStar_Pervasives_Native.fst - tagged_implicits1 in - FStar_Class_Listlike.from_list - (FStar_Compiler_CList.listlike_clist ()) uu___3 in - { - FStar_TypeChecker_Common.guard_f = - (g.FStar_TypeChecker_Common.guard_f); - FStar_TypeChecker_Common.deferred_to_tac = - (g.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (g.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (g.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = uu___2 - })) -let (resolve_generalization_implicits : - FStar_TypeChecker_Env.env -> - FStar_TypeChecker_Common.guard_t -> FStar_TypeChecker_Common.guard_t) - = - fun env -> - fun g -> - let tagged_implicits1 = - let uu___ = - FStar_Class_Listlike.to_list - (FStar_Compiler_CList.listlike_clist ()) - g.FStar_TypeChecker_Common.implicits in - resolve_implicits' env false true uu___ in - let uu___ = - let uu___1 = - FStar_Compiler_List.map FStar_Pervasives_Native.fst - tagged_implicits1 in - FStar_Class_Listlike.from_list - (FStar_Compiler_CList.listlike_clist ()) uu___1 in - { - FStar_TypeChecker_Common.guard_f = - (g.FStar_TypeChecker_Common.guard_f); - FStar_TypeChecker_Common.deferred_to_tac = - (g.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (g.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (g.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = uu___ - } -let (resolve_implicits_tac : - FStar_TypeChecker_Env.env -> - FStar_TypeChecker_Common.guard_t -> tagged_implicits) - = - fun env -> - fun g -> - let uu___ = - FStar_Class_Listlike.to_list (FStar_Compiler_CList.listlike_clist ()) - g.FStar_TypeChecker_Common.implicits in - resolve_implicits' env true false uu___ -let (force_trivial_guard : - FStar_TypeChecker_Env.env -> FStar_TypeChecker_Common.guard_t -> unit) = - fun env -> - fun g -> - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_ResolveImplicitsHook in - if uu___1 - then - let uu___2 = guard_to_string env g in - FStar_Compiler_Util.print1 - "//////////////////////////ResolveImplicitsHook: force_trivial_guard////////////\nguard = %s\n" - uu___2 - else ()); - (let g1 = solve_deferred_constraints env g in - let g2 = resolve_implicits env g1 in - let uu___1 = - FStar_Class_Listlike.to_list - (FStar_Compiler_CList.listlike_clist ()) - g2.FStar_TypeChecker_Common.implicits in - match uu___1 with - | [] -> let uu___2 = discharge_guard env g2 in () - | imp::uu___2 -> - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Errors_Msg.text - "Failed to resolve implicit argument" in - let uu___7 = - let uu___8 = - FStar_Class_Show.show FStar_Syntax_Print.showable_uvar - (imp.FStar_TypeChecker_Common.imp_uvar).FStar_Syntax_Syntax.ctx_uvar_head in - FStar_Pprint.arbitrary_string uu___8 in - FStar_Pprint.prefix (Prims.of_int (4)) Prims.int_one uu___6 - uu___7 in - let uu___6 = - let uu___7 = - let uu___8 = FStar_Errors_Msg.text "of type" in - let uu___9 = - let uu___10 = - FStar_Syntax_Util.ctx_uvar_typ - imp.FStar_TypeChecker_Common.imp_uvar in - FStar_TypeChecker_Normalize.term_to_doc env uu___10 in - FStar_Pprint.prefix (Prims.of_int (4)) Prims.int_one - uu___8 uu___9 in - let uu___8 = - let uu___9 = FStar_Errors_Msg.text "introduced for" in - let uu___10 = - FStar_Errors_Msg.text - imp.FStar_TypeChecker_Common.imp_reason in - FStar_Pprint.prefix (Prims.of_int (4)) Prims.int_one - uu___9 uu___10 in - FStar_Pprint.op_Hat_Slash_Hat uu___7 uu___8 in - FStar_Pprint.op_Hat_Slash_Hat uu___5 uu___6 in - [uu___4] in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range - imp.FStar_TypeChecker_Common.imp_range - FStar_Errors_Codes.Fatal_FailToResolveImplicitArgument () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___3)) -let (subtype_nosmt_force : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.typ -> Prims.bool) - = - fun env -> - fun t1 -> - fun t2 -> - let uu___ = subtype_nosmt env t1 t2 in - match uu___ with - | FStar_Pervasives_Native.None -> false - | FStar_Pervasives_Native.Some g -> (force_trivial_guard env g; true) -let (teq_force : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.typ -> unit) - = - fun env -> - fun t1 -> - fun t2 -> let uu___ = teq env t1 t2 in force_trivial_guard env uu___ -let (teq_nosmt_force : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.typ -> Prims.bool) - = - fun env -> - fun t1 -> - fun t2 -> - let uu___ = teq_nosmt env t1 t2 in - match uu___ with - | FStar_Pervasives_Native.None -> false - | FStar_Pervasives_Native.Some g -> (force_trivial_guard env g; true) -let (layered_effect_teq : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.typ -> - Prims.string FStar_Pervasives_Native.option -> - FStar_TypeChecker_Common.guard_t) - = - fun env -> - fun t1 -> - fun t2 -> - fun reason -> - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_LayeredEffectsEqns in - if uu___1 - then - let uu___2 = - if FStar_Compiler_Util.is_none reason - then "_" - else FStar_Compiler_Util.must reason in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t2 in - FStar_Compiler_Util.print3 "Layered Effect (%s) %s = %s\n" - uu___2 uu___3 uu___4 - else ()); - teq env t1 t2 -let (universe_inequality : - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.universe -> FStar_TypeChecker_Common.guard_t) - = - fun u1 -> - fun u2 -> - let uu___ = - let uu___1 = - Obj.magic - (FStar_Class_Listlike.cons () - (Obj.magic (FStar_Compiler_CList.listlike_clist ())) (u1, u2) - (FStar_Class_Listlike.empty () - (Obj.magic (FStar_Compiler_CList.listlike_clist ())))) in - ((Obj.magic - (FStar_Class_Listlike.empty () - (Obj.magic (FStar_Compiler_CList.listlike_clist ())))), - uu___1) in - { - FStar_TypeChecker_Common.guard_f = - (FStar_TypeChecker_Common.trivial_guard.FStar_TypeChecker_Common.guard_f); - FStar_TypeChecker_Common.deferred_to_tac = - (FStar_TypeChecker_Common.trivial_guard.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (FStar_TypeChecker_Common.trivial_guard.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = uu___; - FStar_TypeChecker_Common.implicits = - (FStar_TypeChecker_Common.trivial_guard.FStar_TypeChecker_Common.implicits) - } \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Tc.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Tc.ml deleted file mode 100644 index e5bb21355ee..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Tc.ml +++ /dev/null @@ -1,6005 +0,0 @@ -open Prims -let (dbg_TwoPhases : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "TwoPhases" -let (dbg_IdInfoOn : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "IdInfoOn" -let (dbg_Normalize : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Normalize" -let (dbg_UF : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "UF" -let (dbg_LogTypes : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "LogTypes" -let (sigelt_typ : - FStar_Syntax_Syntax.sigelt -> - FStar_Syntax_Syntax.typ FStar_Pervasives_Native.option) - = - fun se -> - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = uu___; FStar_Syntax_Syntax.us = uu___1; - FStar_Syntax_Syntax.params = uu___2; - FStar_Syntax_Syntax.num_uniform_params = uu___3; - FStar_Syntax_Syntax.t = t; FStar_Syntax_Syntax.mutuals = uu___4; - FStar_Syntax_Syntax.ds = uu___5; - FStar_Syntax_Syntax.injective_type_params = uu___6;_} - -> FStar_Pervasives_Native.Some t - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = uu___; FStar_Syntax_Syntax.us1 = uu___1; - FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = uu___2; - FStar_Syntax_Syntax.num_ty_params = uu___3; - FStar_Syntax_Syntax.mutuals1 = uu___4; - FStar_Syntax_Syntax.injective_type_params1 = uu___5;_} - -> FStar_Pervasives_Native.Some t - | FStar_Syntax_Syntax.Sig_declare_typ - { FStar_Syntax_Syntax.lid2 = uu___; FStar_Syntax_Syntax.us2 = uu___1; - FStar_Syntax_Syntax.t2 = t;_} - -> FStar_Pervasives_Native.Some t - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (uu___, lb::uu___1); - FStar_Syntax_Syntax.lids1 = uu___2;_} - -> FStar_Pervasives_Native.Some (lb.FStar_Syntax_Syntax.lbtyp) - | uu___ -> FStar_Pervasives_Native.None -let (set_hint_correlator : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.sigelt -> FStar_TypeChecker_Env.env) - = - fun env -> - fun se -> - let tbl = - FStar_Pervasives_Native.snd - env.FStar_TypeChecker_Env.qtbl_name_and_index in - let get_n lid = - let n_opt = - let uu___ = FStar_Class_Show.show FStar_Ident.showable_lident lid in - FStar_Compiler_Util.smap_try_find tbl uu___ in - if FStar_Compiler_Util.is_some n_opt - then FStar_Compiler_Util.must n_opt - else Prims.int_zero in - let typ = - let uu___ = sigelt_typ se in - match uu___ with - | FStar_Pervasives_Native.Some t -> t - | uu___1 -> FStar_Syntax_Syntax.tun in - let uu___ = FStar_Options.reuse_hint_for () in - match uu___ with - | FStar_Pervasives_Native.Some l -> - let lid = - let uu___1 = FStar_TypeChecker_Env.current_module env in - FStar_Ident.lid_add_suffix uu___1 l in - let uu___1 = - let uu___2 = - let uu___3 = let uu___4 = get_n lid in (lid, typ, uu___4) in - FStar_Pervasives_Native.Some uu___3 in - (uu___2, tbl) in - { - FStar_TypeChecker_Env.solver = (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = (env.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = (env.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = uu___1; - FStar_TypeChecker_Env.normalized_eff_names = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env.FStar_TypeChecker_Env.missing_decl) - } - | FStar_Pervasives_Native.None -> - let lids = FStar_Syntax_Util.lids_of_sigelt se in - let lid = - match lids with - | [] -> - let uu___1 = FStar_TypeChecker_Env.current_module env in - let uu___2 = - let uu___3 = FStar_GenSym.next_id () in - FStar_Compiler_Util.string_of_int uu___3 in - FStar_Ident.lid_add_suffix uu___1 uu___2 - | l::uu___1 -> l in - let uu___1 = - let uu___2 = - let uu___3 = let uu___4 = get_n lid in (lid, typ, uu___4) in - FStar_Pervasives_Native.Some uu___3 in - (uu___2, tbl) in - { - FStar_TypeChecker_Env.solver = (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = (env.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = (env.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = uu___1; - FStar_TypeChecker_Env.normalized_eff_names = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env.FStar_TypeChecker_Env.missing_decl) - } -let (log : FStar_TypeChecker_Env.env -> Prims.bool) = - fun env -> - (FStar_Options.log_types ()) && - (let uu___ = - let uu___1 = FStar_TypeChecker_Env.current_module env in - FStar_Ident.lid_equals FStar_Parser_Const.prims_lid uu___1 in - Prims.op_Negation uu___) -let (tc_type_common : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.tscheme -> - FStar_Syntax_Syntax.typ -> - FStar_Compiler_Range_Type.range -> FStar_Syntax_Syntax.tscheme) - = - fun env -> - fun uu___ -> - fun expected_typ -> - fun r -> - match uu___ with - | (uvs, t) -> - let uu___1 = FStar_Syntax_Subst.open_univ_vars uvs t in - (match uu___1 with - | (uvs1, t1) -> - let env1 = FStar_TypeChecker_Env.push_univ_vars env uvs1 in - let t2 = - FStar_TypeChecker_TcTerm.tc_check_trivial_guard env1 t1 - expected_typ in - if uvs1 = [] - then - let uu___2 = - FStar_TypeChecker_Generalize.generalize_universes env1 - t2 in - (match uu___2 with - | (uvs2, t3) -> - (FStar_TypeChecker_Util.check_uvars r t3; - (uvs2, t3))) - else - (let uu___3 = - let uu___4 = - FStar_TypeChecker_Normalize.remove_uvar_solutions - env1 t2 in - FStar_Syntax_Subst.close_univ_vars uvs1 uu___4 in - (uvs1, uu___3))) -let (tc_declare_typ : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.tscheme -> - FStar_Compiler_Range_Type.range -> FStar_Syntax_Syntax.tscheme) - = - fun env -> - fun ts -> - fun r -> - let uu___ = - let uu___1 = FStar_Syntax_Util.type_u () in - FStar_Pervasives_Native.fst uu___1 in - tc_type_common env ts uu___ r -let (tc_assume : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.tscheme -> - FStar_Compiler_Range_Type.range -> FStar_Syntax_Syntax.tscheme) - = - fun env -> - fun ts -> - fun r -> - let uu___ = - let uu___1 = FStar_Syntax_Util.type_u () in - FStar_Pervasives_Native.fst uu___1 in - tc_type_common env ts uu___ r -let (tc_decl_attributes : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.sigelt -> FStar_Syntax_Syntax.sigelt) - = - fun env -> - fun se -> - let uu___ = - let uu___1 = - FStar_TypeChecker_Env.lid_exists env - FStar_Parser_Const.attr_substitute_lid in - if uu___1 - then ([], (se.FStar_Syntax_Syntax.sigattrs)) - else - FStar_Compiler_List.partition - ((=) FStar_Syntax_Util.attr_substitute) - se.FStar_Syntax_Syntax.sigattrs in - match uu___ with - | (blacklisted_attrs, other_attrs) -> - let uu___1 = FStar_TypeChecker_TcTerm.tc_attributes env other_attrs in - (match uu___1 with - | (g, other_attrs1) -> - (FStar_TypeChecker_Rel.force_trivial_guard env g; - { - FStar_Syntax_Syntax.sigel = (se.FStar_Syntax_Syntax.sigel); - FStar_Syntax_Syntax.sigrng = - (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (FStar_Compiler_List.op_At blacklisted_attrs other_attrs1); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se.FStar_Syntax_Syntax.sigopts) - })) -let (tc_inductive' : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.sigelt Prims.list -> - FStar_Syntax_Syntax.qualifier Prims.list -> - FStar_Syntax_Syntax.attribute Prims.list -> - FStar_Ident.lident Prims.list -> - (FStar_Syntax_Syntax.sigelt * FStar_Syntax_Syntax.sigelt - Prims.list)) - = - fun env -> - fun ses -> - fun quals -> - fun attrs -> - fun lids -> - (let uu___1 = FStar_Compiler_Debug.low () in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_sigelt) ses in - FStar_Compiler_Util.print1 ">>>>>>>>>>>>>>tc_inductive %s\n" - uu___2 - else ()); - (let ses1 = FStar_Compiler_List.map (tc_decl_attributes env) ses in - let uu___1 = - FStar_TypeChecker_TcInductive.check_inductive_well_typedness - env ses1 quals lids in - match uu___1 with - | (sig_bndle, tcs, datas) -> - let sig_bndle1 = - FStar_TypeChecker_Positivity.mark_uniform_type_parameters - env sig_bndle in - let attrs' = - FStar_Syntax_Util.remove_attr - FStar_Parser_Const.erasable_attr attrs in - let data_ops_ses = - let uu___2 = - FStar_Compiler_List.map - (FStar_TypeChecker_TcInductive.mk_data_operations - quals attrs' env tcs) datas in - FStar_Compiler_List.flatten uu___2 in - ((let uu___3 = - (FStar_Options.no_positivity ()) || - (let uu___4 = FStar_TypeChecker_Env.should_verify env in - Prims.op_Negation uu___4) in - if uu___3 - then () - else - (let env2 = - FStar_TypeChecker_Env.push_sigelt env sig_bndle1 in - FStar_Compiler_List.iter - (fun ty -> - let b = - FStar_TypeChecker_Positivity.check_strict_positivity - env2 lids ty in - if Prims.op_Negation b - then - let uu___6 = - match ty.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = lid; - FStar_Syntax_Syntax.us = uu___7; - FStar_Syntax_Syntax.params = uu___8; - FStar_Syntax_Syntax.num_uniform_params = - uu___9; - FStar_Syntax_Syntax.t = uu___10; - FStar_Syntax_Syntax.mutuals = uu___11; - FStar_Syntax_Syntax.ds = uu___12; - FStar_Syntax_Syntax.injective_type_params - = uu___13;_} - -> (lid, (ty.FStar_Syntax_Syntax.sigrng)) - | uu___7 -> failwith "Impossible!" in - match uu___6 with - | (lid, r) -> - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Ident.string_of_lid lid in - Prims.strcat uu___9 - " does not satisfy the strict positivity condition" in - Prims.strcat "Inductive type " uu___8 in - FStar_Errors.log_issue - FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Error_InductiveTypeNotSatisfyPositivityCondition - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___7) - else ()) tcs; - FStar_Compiler_List.iter - (fun d -> - let uu___6 = - match d.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = data_lid; - FStar_Syntax_Syntax.us1 = uu___7; - FStar_Syntax_Syntax.t1 = uu___8; - FStar_Syntax_Syntax.ty_lid = ty_lid; - FStar_Syntax_Syntax.num_ty_params = uu___9; - FStar_Syntax_Syntax.mutuals1 = uu___10; - FStar_Syntax_Syntax.injective_type_params1 - = uu___11;_} - -> (data_lid, ty_lid) - | uu___7 -> failwith "Impossible" in - match uu___6 with - | (data_lid, ty_lid) -> - let uu___7 = - (FStar_Ident.lid_equals ty_lid - FStar_Parser_Const.exn_lid) - && - (let uu___8 = - FStar_TypeChecker_Positivity.check_exn_strict_positivity - env2 data_lid in - Prims.op_Negation uu___8) in - if uu___7 - then - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Ident.string_of_lid data_lid in - Prims.strcat uu___10 - " does not satisfy the positivity condition" in - Prims.strcat "Exception " uu___9 in - FStar_Errors.log_issue - FStar_Syntax_Syntax.has_range_sigelt d - FStar_Errors_Codes.Error_InductiveTypeNotSatisfyPositivityCondition - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___8) - else ()) datas)); - (let skip_haseq = - let skip_prims_type uu___3 = - let lid = - let ty = FStar_Compiler_List.hd tcs in - match ty.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = lid1; - FStar_Syntax_Syntax.us = uu___4; - FStar_Syntax_Syntax.params = uu___5; - FStar_Syntax_Syntax.num_uniform_params = - uu___6; - FStar_Syntax_Syntax.t = uu___7; - FStar_Syntax_Syntax.mutuals = uu___8; - FStar_Syntax_Syntax.ds = uu___9; - FStar_Syntax_Syntax.injective_type_params = - uu___10;_} - -> lid1 - | uu___4 -> failwith "Impossible" in - FStar_Compiler_List.existsb - (fun s -> - let uu___4 = - let uu___5 = FStar_Ident.ident_of_lid lid in - FStar_Ident.string_of_id uu___5 in - s = uu___4) - FStar_TypeChecker_TcInductive.early_prims_inductives in - let is_noeq = - FStar_Compiler_List.existsb - (fun q -> q = FStar_Syntax_Syntax.Noeq) quals in - let is_erasable uu___3 = - let uu___4 = - let uu___5 = FStar_Compiler_List.hd tcs in - uu___5.FStar_Syntax_Syntax.sigattrs in - FStar_Syntax_Util.has_attribute uu___4 - FStar_Parser_Const.erasable_attr in - ((((FStar_Compiler_List.length tcs) = Prims.int_zero) || - ((FStar_Ident.lid_equals - env.FStar_TypeChecker_Env.curmodule - FStar_Parser_Const.prims_lid) - && (skip_prims_type ()))) - || is_noeq) - || (is_erasable ()) in - let res = - if skip_haseq - then (sig_bndle1, data_ops_ses) - else - (let is_unopteq = - FStar_Compiler_List.existsb - (fun q -> q = FStar_Syntax_Syntax.Unopteq) quals in - let ses2 = - if is_unopteq - then - FStar_TypeChecker_TcInductive.unoptimized_haseq_scheme - sig_bndle1 tcs datas env - else - FStar_TypeChecker_TcInductive.optimized_haseq_scheme - sig_bndle1 tcs datas env in - (sig_bndle1, - (FStar_Compiler_List.op_At ses2 data_ops_ses))) in - res))) -let (tc_inductive : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.sigelt Prims.list -> - FStar_Syntax_Syntax.qualifier Prims.list -> - FStar_Syntax_Syntax.attribute Prims.list -> - FStar_Ident.lident Prims.list -> - (FStar_Syntax_Syntax.sigelt * FStar_Syntax_Syntax.sigelt - Prims.list)) - = - fun env -> - fun ses -> - fun quals -> - fun attrs -> - fun lids -> - let env1 = FStar_TypeChecker_Env.push env "tc_inductive" in - let pop uu___ = - let uu___1 = FStar_TypeChecker_Env.pop env1 "tc_inductive" in - () in - let uu___ = FStar_Options.trace_error () in - if uu___ - then - let r = tc_inductive' env1 ses quals attrs lids in (pop (); r) - else - (try - (fun uu___2 -> - match () with - | () -> - let uu___3 = tc_inductive' env1 ses quals attrs lids in - (pop (); uu___3)) () - with | uu___2 -> (pop (); FStar_Compiler_Effect.raise uu___2)) -let proc_check_with : - 'a . FStar_Syntax_Syntax.attribute Prims.list -> (unit -> 'a) -> 'a = - fun attrs -> - fun kont -> - let uu___ = - FStar_Syntax_Util.get_attribute FStar_Parser_Const.check_with_lid - attrs in - match uu___ with - | FStar_Pervasives_Native.None -> kont () - | FStar_Pervasives_Native.Some ((a1, FStar_Pervasives_Native.None)::[]) - -> - let uu___1 = - FStar_Syntax_Embeddings_Base.unembed - FStar_Syntax_Embeddings.e_vconfig a1 - FStar_Syntax_Embeddings_Base.id_norm_cb in - (match uu___1 with - | FStar_Pervasives_Native.None -> failwith "nah" - | FStar_Pervasives_Native.Some vcfg -> - FStar_Options.with_saved_options - (fun uu___2 -> FStar_Options.set_vconfig vcfg; kont ()) - | uu___2 -> failwith "ill-formed `check_with`") -let (handle_postprocess_with_attr : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.attribute Prims.list -> - (FStar_Syntax_Syntax.attribute Prims.list * FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option)) - = - fun env -> - fun ats -> - let uu___ = - FStar_Syntax_Util.extract_attr' FStar_Parser_Const.postprocess_with - ats in - match uu___ with - | FStar_Pervasives_Native.None -> (ats, FStar_Pervasives_Native.None) - | FStar_Pervasives_Native.Some - (ats1, (tau, FStar_Pervasives_Native.None)::[]) -> - (ats1, (FStar_Pervasives_Native.Some tau)) - | FStar_Pervasives_Native.Some (ats1, args) -> - ((let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Ident.showable_lident - FStar_Parser_Const.postprocess_with in - FStar_Compiler_Util.format1 "Ill-formed application of `%s`" - uu___3 in - FStar_Errors.log_issue FStar_TypeChecker_Env.hasRange_env env - FStar_Errors_Codes.Warning_UnrecognizedAttribute () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - (ats1, FStar_Pervasives_Native.None)) -let (store_sigopts : - FStar_Syntax_Syntax.sigelt -> FStar_Syntax_Syntax.sigelt) = - fun se -> - let uu___ = - let uu___1 = FStar_Options.get_vconfig () in - FStar_Pervasives_Native.Some uu___1 in - { - FStar_Syntax_Syntax.sigel = (se.FStar_Syntax_Syntax.sigel); - FStar_Syntax_Syntax.sigrng = (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = (se.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = (se.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = uu___ - } -let (tc_decls_knot : - (FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.sigelt Prims.list -> - (FStar_Syntax_Syntax.sigelt Prims.list * FStar_TypeChecker_Env.env)) - FStar_Pervasives_Native.option FStar_Compiler_Effect.ref) - = FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None -let do_two_phases : 'uuuuu . 'uuuuu -> Prims.bool = - fun env -> let uu___ = FStar_Options.lax () in Prims.op_Negation uu___ -let run_phase1 : 'a . (unit -> 'a) -> 'a = - fun f -> - FStar_TypeChecker_Core.clear_memo_table (); - (let r = f () in FStar_TypeChecker_Core.clear_memo_table (); r) -let (tc_sig_let : - FStar_TypeChecker_Env.env -> - FStar_Compiler_Range_Type.range -> - FStar_Syntax_Syntax.sigelt -> - (Prims.bool * FStar_Syntax_Syntax.letbinding Prims.list) -> - FStar_Ident.lident Prims.list -> - (FStar_Syntax_Syntax.sigelt Prims.list * - FStar_Syntax_Syntax.sigelt Prims.list * - FStar_TypeChecker_Env.env)) - = - fun env -> - fun r -> - fun se -> - fun lbs -> - fun lids -> - let env0 = env in - let env1 = FStar_TypeChecker_Env.set_range env r in - let check_quals_eq l qopt val_q = - match qopt with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.Some val_q - | FStar_Pervasives_Native.Some q' -> - let drop_logic_and_irreducible = - FStar_Compiler_List.filter - (fun x -> - Prims.op_Negation - ((x = FStar_Syntax_Syntax.Logic) || - (x = FStar_Syntax_Syntax.Irreducible))) in - let uu___ = - let uu___1 = - let uu___2 = drop_logic_and_irreducible val_q in - let uu___3 = drop_logic_and_irreducible q' in - (uu___2, uu___3) in - match uu___1 with - | (val_q1, q'1) -> - ((FStar_Compiler_List.length val_q1) = - (FStar_Compiler_List.length q'1)) - && - (FStar_Compiler_List.forall2 - FStar_Syntax_Util.qualifier_equal val_q1 q'1) in - if uu___ - then FStar_Pervasives_Native.Some q' - else - (let uu___2 = - let uu___3 = - let uu___4 = - FStar_Errors_Msg.text - "Inconsistent qualifier annotations on" in - let uu___5 = - let uu___6 = - FStar_Class_Show.show - FStar_Ident.showable_lident l in - FStar_Pprint.doc_of_string uu___6 in - FStar_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = FStar_Errors_Msg.text "Expected" in - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_qualifier) - val_q in - FStar_Pprint.arbitrary_string uu___10 in - FStar_Pprint.squotes uu___9 in - FStar_Pprint.prefix (Prims.of_int (4)) - Prims.int_one uu___7 uu___8 in - let uu___7 = - let uu___8 = FStar_Errors_Msg.text "got" in - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_qualifier) - q' in - FStar_Pprint.arbitrary_string uu___11 in - FStar_Pprint.squotes uu___10 in - FStar_Pprint.prefix (Prims.of_int (4)) - Prims.int_one uu___8 uu___9 in - FStar_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in - [uu___5] in - uu___3 :: uu___4 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_InconsistentQualifierAnnotation - () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___2)) in - let rename_parameters lb = - let rename_in_typ def typ = - let typ1 = FStar_Syntax_Subst.compress typ in - let def_bs = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress def in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = binders; - FStar_Syntax_Syntax.body = uu___1; - FStar_Syntax_Syntax.rc_opt = uu___2;_} - -> binders - | uu___1 -> [] in - match typ1 with - | { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = val_bs; - FStar_Syntax_Syntax.comp = c;_}; - FStar_Syntax_Syntax.pos = r1; - FStar_Syntax_Syntax.vars = uu___; - FStar_Syntax_Syntax.hash_code = uu___1;_} -> - let has_auto_name bv = - let uu___2 = - FStar_Ident.string_of_id - bv.FStar_Syntax_Syntax.ppname in - FStar_Compiler_Util.starts_with uu___2 - FStar_Ident.reserved_prefix in - let rec rename_binders def_bs1 val_bs1 = - match (def_bs1, val_bs1) with - | ([], uu___2) -> val_bs1 - | (uu___2, []) -> val_bs1 - | ({ FStar_Syntax_Syntax.binder_bv = body_bv; - FStar_Syntax_Syntax.binder_qual = uu___2; - FStar_Syntax_Syntax.binder_positivity = uu___3; - FStar_Syntax_Syntax.binder_attrs = uu___4;_}::bt, - val_b::vt) -> - let uu___5 = - let uu___6 = - let uu___7 = has_auto_name body_bv in - let uu___8 = - has_auto_name - val_b.FStar_Syntax_Syntax.binder_bv in - (uu___7, uu___8) in - match uu___6 with - | (true, uu___7) -> val_b - | (false, true) -> - let uu___7 = - let uu___8 = - val_b.FStar_Syntax_Syntax.binder_bv in - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Ident.string_of_id - body_bv.FStar_Syntax_Syntax.ppname in - let uu___12 = - FStar_Ident.range_of_id - (val_b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.ppname in - (uu___11, uu___12) in - FStar_Ident.mk_ident uu___10 in - { - FStar_Syntax_Syntax.ppname = uu___9; - FStar_Syntax_Syntax.index = - (uu___8.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = - (uu___8.FStar_Syntax_Syntax.sort) - } in - { - FStar_Syntax_Syntax.binder_bv = uu___7; - FStar_Syntax_Syntax.binder_qual = - (val_b.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity = - (val_b.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs = - (val_b.FStar_Syntax_Syntax.binder_attrs) - } - | (false, false) -> val_b in - let uu___6 = rename_binders bt vt in uu___5 :: - uu___6 in - let uu___2 = - let uu___3 = - let uu___4 = rename_binders def_bs val_bs in - { - FStar_Syntax_Syntax.bs1 = uu___4; - FStar_Syntax_Syntax.comp = c - } in - FStar_Syntax_Syntax.Tm_arrow uu___3 in - FStar_Syntax_Syntax.mk uu___2 r1 - | uu___ -> typ1 in - let uu___ = - rename_in_typ lb.FStar_Syntax_Syntax.lbdef - lb.FStar_Syntax_Syntax.lbtyp in - { - FStar_Syntax_Syntax.lbname = (lb.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = uu___; - FStar_Syntax_Syntax.lbeff = (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = (lb.FStar_Syntax_Syntax.lbdef); - FStar_Syntax_Syntax.lbattrs = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = (lb.FStar_Syntax_Syntax.lbpos) - } in - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun lb -> - match uu___1 with - | (gen, lbs1, quals_opt) -> - let lbname = - FStar_Compiler_Util.right - lb.FStar_Syntax_Syntax.lbname in - let uu___2 = - let uu___3 = - FStar_TypeChecker_Env.try_lookup_val_decl env1 - (lbname.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - match uu___3 with - | FStar_Pervasives_Native.None -> - (gen, lb, quals_opt) - | FStar_Pervasives_Native.Some - ((uvs, tval), quals) -> - let quals_opt1 = - check_quals_eq - (lbname.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - quals_opt quals in - let def = - match (lb.FStar_Syntax_Syntax.lbtyp).FStar_Syntax_Syntax.n - with - | FStar_Syntax_Syntax.Tm_unknown -> - lb.FStar_Syntax_Syntax.lbdef - | uu___4 -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_ascribed - { - FStar_Syntax_Syntax.tm = - (lb.FStar_Syntax_Syntax.lbdef); - FStar_Syntax_Syntax.asc = - ((FStar_Pervasives.Inl - (lb.FStar_Syntax_Syntax.lbtyp)), - FStar_Pervasives_Native.None, - false); - FStar_Syntax_Syntax.eff_opt = - FStar_Pervasives_Native.None - }) - (lb.FStar_Syntax_Syntax.lbdef).FStar_Syntax_Syntax.pos in - (if - (lb.FStar_Syntax_Syntax.lbunivs <> []) && - ((FStar_Compiler_List.length - lb.FStar_Syntax_Syntax.lbunivs) - <> (FStar_Compiler_List.length uvs)) - then - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_IncoherentInlineUniverse - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Inline universes are incoherent with annotation from val declaration") - else (); - (let uu___5 = - FStar_Syntax_Syntax.mk_lb - ((FStar_Pervasives.Inr lbname), uvs, - FStar_Parser_Const.effect_Tot_lid, - tval, def, - (lb.FStar_Syntax_Syntax.lbattrs), - (lb.FStar_Syntax_Syntax.lbpos)) in - (false, uu___5, quals_opt1))) in - (match uu___2 with - | (gen1, lb1, quals_opt1) -> - (gen1, (lb1 :: lbs1), quals_opt1))) - (true, [], - (if se.FStar_Syntax_Syntax.sigquals = [] - then FStar_Pervasives_Native.None - else - FStar_Pervasives_Native.Some - (se.FStar_Syntax_Syntax.sigquals))) - (FStar_Pervasives_Native.snd lbs) in - match uu___ with - | (should_generalize, lbs', quals_opt) -> - (FStar_Syntax_Util.check_mutual_universes lbs'; - (let quals = - match quals_opt with - | FStar_Pervasives_Native.None -> - [FStar_Syntax_Syntax.Visible_default] - | FStar_Pervasives_Native.Some q -> - let uu___2 = - FStar_Compiler_Util.for_some - (fun uu___3 -> - match uu___3 with - | FStar_Syntax_Syntax.Irreducible -> true - | FStar_Syntax_Syntax.Visible_default -> true - | FStar_Syntax_Syntax.Unfold_for_unification_and_vcgen - -> true - | uu___4 -> false) q in - if uu___2 - then q - else FStar_Syntax_Syntax.Visible_default :: q in - let lbs'1 = FStar_Compiler_List.rev lbs' in - let uu___2 = - let uu___3 = - FStar_Syntax_Util.extract_attr' - FStar_Parser_Const.preprocess_with - se.FStar_Syntax_Syntax.sigattrs in - match uu___3 with - | FStar_Pervasives_Native.None -> - ((se.FStar_Syntax_Syntax.sigattrs), - FStar_Pervasives_Native.None) - | FStar_Pervasives_Native.Some - (ats, (tau, FStar_Pervasives_Native.None)::[]) -> - (ats, (FStar_Pervasives_Native.Some tau)) - | FStar_Pervasives_Native.Some (ats, args) -> - (FStar_Errors.log_issue - FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Warning_UnrecognizedAttribute - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Ill-formed application of `preprocess_with`"); - ((se.FStar_Syntax_Syntax.sigattrs), - FStar_Pervasives_Native.None)) in - match uu___2 with - | (attrs, pre_tau) -> - let se1 = - { - FStar_Syntax_Syntax.sigel = - (se.FStar_Syntax_Syntax.sigel); - FStar_Syntax_Syntax.sigrng = - (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = attrs; - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se.FStar_Syntax_Syntax.sigopts) - } in - let preprocess_lb tau lb = - let lbdef = - FStar_TypeChecker_Env.preprocess env1 tau - lb.FStar_Syntax_Syntax.lbdef in - (let uu___4 = - (FStar_Compiler_Debug.medium ()) || - (FStar_Compiler_Effect.op_Bang dbg_TwoPhases) in - if uu___4 - then - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term lbdef in - FStar_Compiler_Util.print1 - "lb preprocessed into: %s\n" uu___5 - else ()); - { - FStar_Syntax_Syntax.lbname = - (lb.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = - (lb.FStar_Syntax_Syntax.lbtyp); - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = lbdef; - FStar_Syntax_Syntax.lbattrs = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - } in - let lbs'2 = - match pre_tau with - | FStar_Pervasives_Native.Some tau -> - FStar_Compiler_List.map (preprocess_lb tau) lbs'1 - | FStar_Pervasives_Native.None -> lbs'1 in - let e = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_constant - FStar_Const.Const_unit) r in - { - FStar_Syntax_Syntax.lbs = - ((FStar_Pervasives_Native.fst lbs), lbs'2); - FStar_Syntax_Syntax.body1 = uu___5 - } in - FStar_Syntax_Syntax.Tm_let uu___4 in - FStar_Syntax_Syntax.mk uu___3 r in - let env' = - { - FStar_TypeChecker_Env.solver = - (env1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - should_generalize; - FStar_TypeChecker_Env.letrecs = - (env1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = true; - FStar_TypeChecker_Env.check_uvars = - (env1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (env1.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env1.FStar_TypeChecker_Env.missing_decl) - } in - let e1 = - let uu___3 = do_two_phases env' in - if uu___3 - then - run_phase1 - (fun uu___4 -> - let drop_lbtyp e_lax = - let uu___5 = - let uu___6 = - FStar_Syntax_Subst.compress e_lax in - uu___6.FStar_Syntax_Syntax.n in - match uu___5 with - | FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = - (false, lb::[]); - FStar_Syntax_Syntax.body1 = e2;_} - -> - let lb_unannotated = - let uu___6 = - let uu___7 = - FStar_Syntax_Subst.compress e in - uu___7.FStar_Syntax_Syntax.n in - match uu___6 with - | FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = - (uu___7, lb1::[]); - FStar_Syntax_Syntax.body1 = - uu___8;_} - -> - let uu___9 = - let uu___10 = - FStar_Syntax_Subst.compress - lb1.FStar_Syntax_Syntax.lbtyp in - uu___10.FStar_Syntax_Syntax.n in - (match uu___9 with - | FStar_Syntax_Syntax.Tm_unknown - -> true - | uu___10 -> false) - | uu___7 -> - failwith - "Impossible: first phase lb and second phase lb differ in structure!" in - if lb_unannotated - then - { - FStar_Syntax_Syntax.n = - (FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = - (false, - [{ - FStar_Syntax_Syntax.lbname - = - (lb.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs - = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp - = - FStar_Syntax_Syntax.tun; - FStar_Syntax_Syntax.lbeff - = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef - = - (lb.FStar_Syntax_Syntax.lbdef); - FStar_Syntax_Syntax.lbattrs - = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos - = - (lb.FStar_Syntax_Syntax.lbpos) - }]); - FStar_Syntax_Syntax.body1 = - e2 - }); - FStar_Syntax_Syntax.pos = - (e_lax.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = - (e_lax.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (e_lax.FStar_Syntax_Syntax.hash_code) - } - else e_lax - | FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = (true, lbs1); - FStar_Syntax_Syntax.body1 = uu___6;_} - -> - (FStar_Syntax_Util.check_mutual_universes - lbs1; - e_lax) in - let e2 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_TypeChecker_Env.current_module - env1 in - FStar_Ident.string_of_lid uu___7 in - FStar_Pervasives_Native.Some uu___6 in - FStar_Profiling.profile - (fun uu___6 -> - let uu___7 = - FStar_TypeChecker_TcTerm.tc_maybe_toplevel_term - { - FStar_TypeChecker_Env.solver = - (env'.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env'.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env'.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env'.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env'.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache - = - (env'.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env'.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ - = - (env'.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env'.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env'.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp - = - (env'.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env'.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize - = - (env'.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env'.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env'.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars - = - (env'.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict - = - (env'.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env'.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - true; - FStar_TypeChecker_Env.lax_universes - = - (env'.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - true; - FStar_TypeChecker_Env.failhard = - (env'.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking - = - (env'.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping - = - (env'.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env'.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env'.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env'.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (env'.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of - = - (env'.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env'.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force - = - (env'.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (env'.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (env'.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (env'.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths - = - (env'.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env'.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook - = - (env'.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (env'.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env'.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess - = - (env'.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess - = - (env'.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info - = - (env'.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env'.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env'.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env'.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab - = - (env'.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (env'.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (env'.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (env'.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (env'.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check - = - (env'.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl - = - (env'.FStar_TypeChecker_Env.missing_decl) - } e in - match uu___7 with - | (e3, uu___8, uu___9) -> e3) uu___5 - "FStar.TypeChecker.Tc.tc_sig_let-tc-phase1" in - (let uu___6 = - (FStar_Compiler_Debug.medium ()) || - (FStar_Compiler_Effect.op_Bang - dbg_TwoPhases) in - if uu___6 - then - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term e2 in - FStar_Compiler_Util.print1 - "Let binding after phase 1, before removing uvars: %s\n" - uu___7 - else ()); - (let e3 = - let uu___6 = - FStar_TypeChecker_Normalize.remove_uvar_solutions - env' e2 in - drop_lbtyp uu___6 in - (let uu___7 = - (FStar_Compiler_Debug.medium ()) || - (FStar_Compiler_Effect.op_Bang - dbg_TwoPhases) in - if uu___7 - then - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term e3 in - FStar_Compiler_Util.print1 - "Let binding after phase 1, uvars removed: %s\n" - uu___8 - else ()); - e3)) - else e in - let uu___3 = - handle_postprocess_with_attr env1 - se1.FStar_Syntax_Syntax.sigattrs in - (match uu___3 with - | (attrs1, post_tau) -> - let se2 = - { - FStar_Syntax_Syntax.sigel = - (se1.FStar_Syntax_Syntax.sigel); - FStar_Syntax_Syntax.sigrng = - (se1.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se1.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se1.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = attrs1; - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se1.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se1.FStar_Syntax_Syntax.sigopts) - } in - let postprocess_lb tau lb = - let uu___4 = - FStar_Syntax_Subst.univ_var_opening - lb.FStar_Syntax_Syntax.lbunivs in - match uu___4 with - | (s, univnames) -> - let lbdef = - FStar_Syntax_Subst.subst s - lb.FStar_Syntax_Syntax.lbdef in - let lbtyp = - FStar_Syntax_Subst.subst s - lb.FStar_Syntax_Syntax.lbtyp in - let env2 = - FStar_TypeChecker_Env.push_univ_vars env1 - univnames in - let lbdef1 = - FStar_TypeChecker_Env.postprocess env2 tau - lbtyp lbdef in - let lbdef2 = - FStar_Syntax_Subst.close_univ_vars - univnames lbdef1 in - { - FStar_Syntax_Syntax.lbname = - (lb.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = - (lb.FStar_Syntax_Syntax.lbtyp); - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = lbdef2; - FStar_Syntax_Syntax.lbattrs = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - } in - let env'1 = - let uu___4 = - let uu___5 = FStar_Syntax_Subst.compress e1 in - uu___5.FStar_Syntax_Syntax.n in - match uu___4 with - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = lbs1; - FStar_Syntax_Syntax.body1 = uu___5;_} - -> - let se3 = - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_let - { - FStar_Syntax_Syntax.lbs1 = lbs1; - FStar_Syntax_Syntax.lids1 = lids - }); - FStar_Syntax_Syntax.sigrng = - (se2.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se2.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se2.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se2.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs - = - (se2.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se2.FStar_Syntax_Syntax.sigopts) - } in - set_hint_correlator env' se3 - | uu___5 -> failwith "no way, not a let?" in - (FStar_Errors.stop_if_err (); - (let r1 = - let should_generalize1 = - let uu___5 = do_two_phases env'1 in - Prims.op_Negation uu___5 in - let uu___5 = - let uu___6 = - let uu___7 = - FStar_TypeChecker_Env.current_module - env1 in - FStar_Ident.string_of_lid uu___7 in - FStar_Pervasives_Native.Some uu___6 in - FStar_Profiling.profile - (fun uu___6 -> - FStar_TypeChecker_TcTerm.tc_maybe_toplevel_term - { - FStar_TypeChecker_Env.solver = - (env'1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env'1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env'1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env'1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env'1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env'1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env'1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env'1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env'1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env'1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp - = - (env'1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env'1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - should_generalize1; - FStar_TypeChecker_Env.letrecs = - (env'1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env'1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env'1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env'1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env'1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (env'1.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env'1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env'1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env'1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env'1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping - = - (env'1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env'1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env'1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env'1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (env'1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env'1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env'1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force - = - (env'1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (env'1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (env'1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (env'1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths - = - (env'1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env'1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env'1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (env'1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env'1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env'1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env'1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info - = - (env'1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env'1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env'1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env'1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab - = - (env'1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (env'1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (env'1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (env'1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (env'1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env'1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env'1.FStar_TypeChecker_Env.missing_decl) - } e1) uu___5 - "FStar.TypeChecker.Tc.tc_sig_let-tc-phase2" in - let uu___5 = - match r1 with - | ({ - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = lbs1; - FStar_Syntax_Syntax.body1 = e2;_}; - FStar_Syntax_Syntax.pos = uu___6; - FStar_Syntax_Syntax.vars = uu___7; - FStar_Syntax_Syntax.hash_code = uu___8;_}, - uu___9, g) when - FStar_TypeChecker_Env.is_trivial g -> - (FStar_Syntax_Util.check_mutual_universes - (FStar_Pervasives_Native.snd lbs1); - (let lbs2 = - let uu___11 = - FStar_Compiler_List.map - rename_parameters - (FStar_Pervasives_Native.snd lbs1) in - ((FStar_Pervasives_Native.fst lbs1), - uu___11) in - let lbs3 = - let uu___11 = - match post_tau with - | FStar_Pervasives_Native.Some tau - -> - FStar_Compiler_List.map - (postprocess_lb tau) - (FStar_Pervasives_Native.snd - lbs2) - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.snd lbs2 in - ((FStar_Pervasives_Native.fst lbs2), - uu___11) in - let quals1 = - match e2.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 = - uu___11; - FStar_Syntax_Syntax.meta = - FStar_Syntax_Syntax.Meta_desugared - (FStar_Syntax_Syntax.Masked_effect);_} - -> - FStar_Syntax_Syntax.HasMaskedEffect - :: quals - | uu___11 -> quals in - ({ - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_let - { - FStar_Syntax_Syntax.lbs1 = - lbs3; - FStar_Syntax_Syntax.lids1 = - lids - }); - FStar_Syntax_Syntax.sigrng = - (se2.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = quals1; - FStar_Syntax_Syntax.sigmeta = - (se2.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se2.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs - = - (se2.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se2.FStar_Syntax_Syntax.sigopts) - }, lbs3))) - | uu___6 -> - failwith - "impossible (typechecking should preserve Tm_let)" in - match uu___5 with - | (se3, lbs1) -> - ((let uu___7 = - FStar_Syntax_Util.has_attribute - se3.FStar_Syntax_Syntax.sigattrs - FStar_Parser_Const.no_subtping_attr_lid in - if uu___7 - then - let env'2 = - { - FStar_TypeChecker_Env.solver = - (env'1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env'1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env'1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env'1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env'1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env'1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env'1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env'1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env'1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env'1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp - = - (env'1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env'1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env'1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env'1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env'1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env'1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict - = true; - FStar_TypeChecker_Env.is_iface = - (env'1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (env'1.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes - = - (env'1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env'1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env'1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env'1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping - = - (env'1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env'1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env'1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env'1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (env'1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env'1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env'1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force - = - (env'1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (env'1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (env'1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (env'1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths - = - (env'1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env'1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env'1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (env'1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env'1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env'1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env'1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info - = - (env'1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env'1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env'1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env'1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab - = - (env'1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (env'1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (env'1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (env'1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (env'1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env'1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env'1.FStar_TypeChecker_Env.missing_decl) - } in - let err s pos = - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - pos - FStar_Errors_Codes.Fatal_InconsistentQualifierAnnotation - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic s) in - FStar_Compiler_List.iter - (fun lb -> - let uu___8 = - let uu___9 = - FStar_Syntax_Util.is_lemma - lb.FStar_Syntax_Syntax.lbtyp in - Prims.op_Negation uu___9 in - if uu___8 - then - err - "no_subtype annotation on a non-lemma" - lb.FStar_Syntax_Syntax.lbpos - else - (let lid_opt = - let uu___10 = - let uu___11 = - FStar_Syntax_Free.fvars - lb.FStar_Syntax_Syntax.lbtyp in - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Syntax_Syntax.ord_fv)) - (Obj.magic uu___11) in - FStar_Compiler_List.tryFind - (fun lid -> - let uu___11 = - (let uu___12 = - let uu___13 = - FStar_Ident.path_of_lid - lid in - FStar_Compiler_List.hd - uu___13 in - uu___12 = "Prims") || - (FStar_Ident.lid_equals - lid - FStar_Parser_Const.pattern_lid) in - Prims.op_Negation uu___11) - uu___10 in - if - FStar_Compiler_Util.is_some - lid_opt - then - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Compiler_Util.must - lid_opt in - FStar_Ident.string_of_lid - uu___12 in - FStar_Compiler_Util.format1 - "%s is not allowed in no_subtyping lemmas (only prims symbols)" - uu___11 in - err uu___10 - lb.FStar_Syntax_Syntax.lbpos - else - (let uu___11 = - FStar_Syntax_Util.type_u () in - match uu___11 with - | (t, uu___12) -> - let uu___13 = - FStar_Syntax_Subst.open_univ_vars - lb.FStar_Syntax_Syntax.lbunivs - lb.FStar_Syntax_Syntax.lbtyp in - (match uu___13 with - | (uvs, lbtyp) -> - let uu___14 = - let uu___15 = - FStar_TypeChecker_Env.push_univ_vars - env'2 uvs in - FStar_TypeChecker_TcTerm.tc_check_tot_or_gtot_term - uu___15 lbtyp t - (FStar_Pervasives_Native.Some - "checking no_subtype annotation") in - (match uu___14 with - | (uu___15, - uu___16, g) -> - FStar_TypeChecker_Rel.force_trivial_guard - env'2 g))))) - (FStar_Pervasives_Native.snd lbs1) - else ()); - FStar_Compiler_List.iter - (fun lb -> - let fv = - FStar_Compiler_Util.right - lb.FStar_Syntax_Syntax.lbname in - FStar_TypeChecker_Env.insert_fv_info - env1 fv lb.FStar_Syntax_Syntax.lbtyp) - (FStar_Pervasives_Native.snd lbs1); - (let uu___9 = log env1 in - if uu___9 - then - let uu___10 = - let uu___11 = - FStar_Compiler_List.map - (fun lb -> - let should_log = - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - FStar_Compiler_Util.right - lb.FStar_Syntax_Syntax.lbname in - uu___15.FStar_Syntax_Syntax.fv_name in - uu___14.FStar_Syntax_Syntax.v in - FStar_TypeChecker_Env.try_lookup_val_decl - env1 uu___13 in - match uu___12 with - | FStar_Pervasives_Native.None - -> true - | uu___13 -> false in - if should_log - then - let uu___12 = - FStar_Class_Show.show - (FStar_Class_Show.show_either - FStar_Syntax_Print.showable_bv - FStar_Syntax_Print.showable_fv) - lb.FStar_Syntax_Syntax.lbname in - let uu___13 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - lb.FStar_Syntax_Syntax.lbtyp in - FStar_Compiler_Util.format2 - "let %s : %s" uu___12 - uu___13 - else "") - (FStar_Pervasives_Native.snd lbs1) in - FStar_Compiler_String.concat "\n" - uu___11 in - FStar_Compiler_Util.print1 "%s\n" - uu___10 - else ()); - ([se3], [], env0))))))) -let (tc_decl' : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.sigelt -> - (FStar_Syntax_Syntax.sigelt Prims.list * FStar_Syntax_Syntax.sigelt - Prims.list * FStar_TypeChecker_Env.env)) - = - fun env0 -> - fun se -> - let env = env0 in - let se1 = - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_fail uu___ -> se - | uu___ -> tc_decl_attributes env se in - FStar_TypeChecker_Quals.check_sigelt_quals_pre env se1; - proc_check_with se1.FStar_Syntax_Syntax.sigattrs - (fun uu___1 -> - let r = se1.FStar_Syntax_Syntax.sigrng in - let se2 = - let uu___2 = FStar_Options.record_options () in - if uu___2 then store_sigopts se1 else se1 in - match se2.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ uu___2 -> - failwith "Impossible bare data-constructor" - | FStar_Syntax_Syntax.Sig_datacon uu___2 -> - failwith "Impossible bare data-constructor" - | FStar_Syntax_Syntax.Sig_fail - { FStar_Syntax_Syntax.errs = uu___2; - FStar_Syntax_Syntax.fail_in_lax = false; - FStar_Syntax_Syntax.ses1 = uu___3;_} - when env.FStar_TypeChecker_Env.admit -> - ((let uu___5 = FStar_Compiler_Debug.any () in - if uu___5 - then - let uu___6 = FStar_Syntax_Print.sigelt_to_string_short se2 in - FStar_Compiler_Util.print1 - "Skipping %s since env.admit=true and this is not an expect_lax_failure\n" - uu___6 - else ()); - ([], [], env)) - | FStar_Syntax_Syntax.Sig_fail - { FStar_Syntax_Syntax.errs = expected_errors; - FStar_Syntax_Syntax.fail_in_lax = lax; - FStar_Syntax_Syntax.ses1 = ses;_} - -> - let env' = - if lax - then - { - FStar_TypeChecker_Env.solver = - (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = true; - FStar_TypeChecker_Env.lax_universes = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env.FStar_TypeChecker_Env.missing_decl) - } - else env in - let env'1 = FStar_TypeChecker_Env.push env' "expect_failure" in - ((let uu___3 = FStar_Compiler_Debug.low () in - if uu___3 - then - let uu___4 = - let uu___5 = - FStar_Compiler_List.map - FStar_Compiler_Util.string_of_int expected_errors in - FStar_Compiler_String.concat "; " uu___5 in - FStar_Compiler_Util.print1 ">> Expecting errors: [%s]\n" - uu___4 - else ()); - (let uu___3 = - FStar_Errors.catch_errors - (fun uu___4 -> - FStar_Options.with_saved_options - (fun uu___5 -> - let uu___6 = - let uu___7 = - FStar_Compiler_Effect.op_Bang tc_decls_knot in - FStar_Compiler_Util.must uu___7 in - uu___6 env'1 ses)) in - match uu___3 with - | (errs, uu___4) -> - ((let uu___6 = - (FStar_Options.print_expected_failures ()) || - (FStar_Compiler_Debug.low ()) in - if uu___6 - then - (FStar_Compiler_Util.print_string - ">> Got issues: [\n"; - FStar_Compiler_List.iter FStar_Errors.print_issue - errs; - FStar_Compiler_Util.print_string ">>]\n") - else ()); - (let uu___6 = - FStar_TypeChecker_Env.pop env'1 "expect_failure" in - let actual_errors = - FStar_Compiler_List.concatMap - (fun i -> - FStar_Common.list_of_option - i.FStar_Errors.issue_number) errs in - (match errs with - | [] -> - (FStar_Compiler_List.iter - FStar_Errors.print_issue errs; - (let uu___9 = - let uu___10 = - FStar_Errors_Msg.text - "This top-level definition was expected to fail, but it succeeded" in - [uu___10] in - FStar_Errors.log_issue - FStar_Syntax_Syntax.has_range_sigelt se2 - FStar_Errors_Codes.Error_DidNotFail () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___9))) - | uu___8 -> - if expected_errors <> [] - then - let uu___9 = - FStar_Errors.find_multiset_discrepancy - expected_errors actual_errors in - (match uu___9 with - | FStar_Pervasives_Native.None -> () - | FStar_Pervasives_Native.Some (e, n1, n2) -> - (FStar_Compiler_List.iter - FStar_Errors.print_issue errs; - (let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - FStar_Errors_Msg.text - "This top-level definition was expected to raise error codes" in - let uu___15 = - FStar_Class_PP.pp - (FStar_Class_PP.pp_list - FStar_Class_PP.pp_int) - expected_errors in - FStar_Pprint.prefix - (Prims.of_int (2)) Prims.int_one - uu___14 uu___15 in - let uu___14 = - let uu___15 = - let uu___16 = - FStar_Errors_Msg.text - "but it raised" in - let uu___17 = - FStar_Class_PP.pp - (FStar_Class_PP.pp_list - FStar_Class_PP.pp_int) - actual_errors in - FStar_Pprint.prefix - (Prims.of_int (2)) - Prims.int_one uu___16 uu___17 in - FStar_Pprint.op_Hat_Hat uu___15 - FStar_Pprint.dot in - FStar_Pprint.op_Hat_Slash_Hat - uu___13 uu___14 in - let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - e in - let uu___17 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - n2 in - let uu___18 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - n1 in - FStar_Compiler_Util.format3 - "Error #%s was raised %s times, instead of %s." - uu___16 uu___17 uu___18 in - FStar_Errors_Msg.text uu___15 in - [uu___14] in - uu___12 :: uu___13 in - FStar_Errors.log_issue - FStar_Syntax_Syntax.has_range_sigelt - se2 - FStar_Errors_Codes.Error_DidNotFail () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___11)))) - else ()); - ([], [], env))))) - | FStar_Syntax_Syntax.Sig_bundle - { FStar_Syntax_Syntax.ses = ses; - FStar_Syntax_Syntax.lids = lids;_} - -> - let env1 = FStar_TypeChecker_Env.set_range env r in - let ses1 = - let uu___2 = do_two_phases env1 in - if uu___2 - then - run_phase1 - (fun uu___3 -> - let ses2 = - let uu___4 = - let uu___5 = - let uu___6 = - tc_inductive - { - FStar_TypeChecker_Env.solver = - (env1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = true; - FStar_TypeChecker_Env.lax_universes = - (env1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = true; - FStar_TypeChecker_Env.failhard = - (env1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (env1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (env1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (env1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (env1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (env1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (env1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (env1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (env1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (env1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env1.FStar_TypeChecker_Env.missing_decl) - } ses se2.FStar_Syntax_Syntax.sigquals - se2.FStar_Syntax_Syntax.sigattrs lids in - FStar_Pervasives_Native.fst uu___6 in - FStar_TypeChecker_Normalize.elim_uvars env1 - uu___5 in - FStar_Syntax_Util.ses_of_sigbundle uu___4 in - (let uu___5 = - (FStar_Compiler_Debug.medium ()) || - (FStar_Compiler_Effect.op_Bang dbg_TwoPhases) in - if uu___5 - then - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_sigelt - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_bundle - { - FStar_Syntax_Syntax.ses = ses2; - FStar_Syntax_Syntax.lids = lids - }); - FStar_Syntax_Syntax.sigrng = - (se2.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se2.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se2.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se2.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se2.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se2.FStar_Syntax_Syntax.sigopts) - } in - FStar_Compiler_Util.print1 - "Inductive after phase 1: %s\n" uu___6 - else ()); - ses2) - else ses in - let uu___2 = - tc_inductive env1 ses1 se2.FStar_Syntax_Syntax.sigquals - se2.FStar_Syntax_Syntax.sigattrs lids in - (match uu___2 with - | (sigbndle, projectors_ses) -> - let sigbndle1 = - { - FStar_Syntax_Syntax.sigel = - (sigbndle.FStar_Syntax_Syntax.sigel); - FStar_Syntax_Syntax.sigrng = - (sigbndle.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (sigbndle.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (sigbndle.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se2.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (sigbndle.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (sigbndle.FStar_Syntax_Syntax.sigopts) - } in - ([sigbndle1], projectors_ses, env0)) - | FStar_Syntax_Syntax.Sig_pragma p -> - (FStar_Syntax_Util.process_pragma p r; ([se2], [], env0)) - | FStar_Syntax_Syntax.Sig_new_effect ne -> - let is_unelaborated_dm4f = - match ne.FStar_Syntax_Syntax.combinators with - | FStar_Syntax_Syntax.DM4F_eff combs -> - let uu___2 = - FStar_Syntax_Subst.compress - (FStar_Pervasives_Native.snd - combs.FStar_Syntax_Syntax.ret_wp) in - (match uu___2 with - | { - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_unknown; - FStar_Syntax_Syntax.pos = uu___3; - FStar_Syntax_Syntax.vars = uu___4; - FStar_Syntax_Syntax.hash_code = uu___5;_} -> true - | uu___3 -> false) - | uu___2 -> false in - if is_unelaborated_dm4f - then - let env1 = FStar_TypeChecker_Env.set_range env r in - let uu___2 = - FStar_TypeChecker_TcEffect.dmff_cps_and_elaborate env1 ne in - (match uu___2 with - | (ses, ne1, lift_from_pure_opt) -> - let effect_and_lift_ses = - match lift_from_pure_opt with - | FStar_Pervasives_Native.Some lift -> - [{ - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_new_effect ne1); - FStar_Syntax_Syntax.sigrng = - (se2.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se2.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se2.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se2.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se2.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se2.FStar_Syntax_Syntax.sigopts) - }; - lift] - | FStar_Pervasives_Native.None -> - [{ - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_new_effect ne1); - FStar_Syntax_Syntax.sigrng = - (se2.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se2.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se2.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se2.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se2.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se2.FStar_Syntax_Syntax.sigopts) - }] in - let effect_and_lift_ses1 = - FStar_Compiler_List.map - (fun sigelt -> - { - FStar_Syntax_Syntax.sigel = - (sigelt.FStar_Syntax_Syntax.sigel); - FStar_Syntax_Syntax.sigrng = - (sigelt.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (sigelt.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (let uu___3 = - sigelt.FStar_Syntax_Syntax.sigmeta in - { - FStar_Syntax_Syntax.sigmeta_active = - (uu___3.FStar_Syntax_Syntax.sigmeta_active); - FStar_Syntax_Syntax.sigmeta_fact_db_ids = - (uu___3.FStar_Syntax_Syntax.sigmeta_fact_db_ids); - FStar_Syntax_Syntax.sigmeta_admit = true; - FStar_Syntax_Syntax.sigmeta_spliced = - (uu___3.FStar_Syntax_Syntax.sigmeta_spliced); - FStar_Syntax_Syntax.sigmeta_already_checked - = - (uu___3.FStar_Syntax_Syntax.sigmeta_already_checked); - FStar_Syntax_Syntax.sigmeta_extension_data - = - (uu___3.FStar_Syntax_Syntax.sigmeta_extension_data) - }); - FStar_Syntax_Syntax.sigattrs = - (sigelt.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (sigelt.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (sigelt.FStar_Syntax_Syntax.sigopts) - }) effect_and_lift_ses in - ([], - (FStar_Compiler_List.op_At ses effect_and_lift_ses1), - env0)) - else - (let ne1 = - let uu___3 = do_two_phases env in - if uu___3 - then - run_phase1 - (fun uu___4 -> - let ne2 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_TypeChecker_TcEffect.tc_eff_decl - { - FStar_TypeChecker_Env.solver = - (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp - = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = true; - FStar_TypeChecker_Env.lax_universes = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = true; - FStar_TypeChecker_Env.failhard = - (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force - = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths - = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info - = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab - = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env.FStar_TypeChecker_Env.missing_decl) - } ne se2.FStar_Syntax_Syntax.sigquals - se2.FStar_Syntax_Syntax.sigattrs in - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_new_effect - uu___7); - FStar_Syntax_Syntax.sigrng = - (se2.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se2.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se2.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se2.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se2.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se2.FStar_Syntax_Syntax.sigopts) - } in - FStar_TypeChecker_Normalize.elim_uvars env - uu___6 in - FStar_Syntax_Util.eff_decl_of_new_effect uu___5 in - (let uu___6 = - (FStar_Compiler_Debug.medium ()) || - (FStar_Compiler_Effect.op_Bang dbg_TwoPhases) in - if uu___6 - then - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_sigelt - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_new_effect ne2); - FStar_Syntax_Syntax.sigrng = - (se2.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se2.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se2.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se2.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs - = - (se2.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se2.FStar_Syntax_Syntax.sigopts) - } in - FStar_Compiler_Util.print1 - "Effect decl after phase 1: %s\n" uu___7 - else ()); - ne2) - else ne in - let ne2 = - FStar_TypeChecker_TcEffect.tc_eff_decl env ne1 - se2.FStar_Syntax_Syntax.sigquals - se2.FStar_Syntax_Syntax.sigattrs in - let se3 = - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_new_effect ne2); - FStar_Syntax_Syntax.sigrng = - (se2.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se2.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se2.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se2.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se2.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se2.FStar_Syntax_Syntax.sigopts) - } in - ([se3], [], env0)) - | FStar_Syntax_Syntax.Sig_sub_effect sub -> - let sub1 = FStar_TypeChecker_TcEffect.tc_lift env sub r in - let se3 = - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_sub_effect sub1); - FStar_Syntax_Syntax.sigrng = - (se2.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se2.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se2.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se2.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se2.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se2.FStar_Syntax_Syntax.sigopts) - } in - ([se3], [], env) - | FStar_Syntax_Syntax.Sig_effect_abbrev - { FStar_Syntax_Syntax.lid4 = lid; - FStar_Syntax_Syntax.us4 = uvs; - FStar_Syntax_Syntax.bs2 = tps; - FStar_Syntax_Syntax.comp1 = c; - FStar_Syntax_Syntax.cflags = flags;_} - -> - let uu___2 = - let uu___3 = do_two_phases env in - if uu___3 - then - run_phase1 - (fun uu___4 -> - let uu___5 = - let uu___6 = - let uu___7 = - FStar_TypeChecker_TcEffect.tc_effect_abbrev - { - FStar_TypeChecker_Env.solver = - (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = true; - FStar_TypeChecker_Env.lax_universes = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = true; - FStar_TypeChecker_Env.failhard = - (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env.FStar_TypeChecker_Env.missing_decl) - } (lid, uvs, tps, c) r in - match uu___7 with - | (lid1, uvs1, tps1, c1) -> - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_effect_abbrev - { - FStar_Syntax_Syntax.lid4 = lid1; - FStar_Syntax_Syntax.us4 = uvs1; - FStar_Syntax_Syntax.bs2 = tps1; - FStar_Syntax_Syntax.comp1 = c1; - FStar_Syntax_Syntax.cflags = flags - }); - FStar_Syntax_Syntax.sigrng = - (se2.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se2.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se2.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se2.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se2.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se2.FStar_Syntax_Syntax.sigopts) - } in - FStar_TypeChecker_Normalize.elim_uvars env uu___6 in - match uu___5.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_effect_abbrev - { FStar_Syntax_Syntax.lid4 = lid1; - FStar_Syntax_Syntax.us4 = uvs1; - FStar_Syntax_Syntax.bs2 = tps1; - FStar_Syntax_Syntax.comp1 = c1; - FStar_Syntax_Syntax.cflags = uu___6;_} - -> (lid1, uvs1, tps1, c1) - | uu___6 -> - failwith - "Did not expect Sig_effect_abbrev to not be one after phase 1") - else (lid, uvs, tps, c) in - (match uu___2 with - | (lid1, uvs1, tps1, c1) -> - let uu___3 = - FStar_TypeChecker_TcEffect.tc_effect_abbrev env - (lid1, uvs1, tps1, c1) r in - (match uu___3 with - | (lid2, uvs2, tps2, c2) -> - let se3 = - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_effect_abbrev - { - FStar_Syntax_Syntax.lid4 = lid2; - FStar_Syntax_Syntax.us4 = uvs2; - FStar_Syntax_Syntax.bs2 = tps2; - FStar_Syntax_Syntax.comp1 = c2; - FStar_Syntax_Syntax.cflags = flags - }); - FStar_Syntax_Syntax.sigrng = - (se2.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se2.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se2.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se2.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se2.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se2.FStar_Syntax_Syntax.sigopts) - } in - ([se3], [], env0))) - | FStar_Syntax_Syntax.Sig_declare_typ uu___2 when - FStar_Compiler_Util.for_some - (fun uu___3 -> - match uu___3 with - | FStar_Syntax_Syntax.OnlyName -> true - | uu___4 -> false) se2.FStar_Syntax_Syntax.sigquals - -> ([], [], env0) - | FStar_Syntax_Syntax.Sig_let uu___2 when - FStar_Compiler_Util.for_some - (fun uu___3 -> - match uu___3 with - | FStar_Syntax_Syntax.OnlyName -> true - | uu___4 -> false) se2.FStar_Syntax_Syntax.sigquals - -> ([], [], env0) - | FStar_Syntax_Syntax.Sig_declare_typ - { FStar_Syntax_Syntax.lid2 = lid; - FStar_Syntax_Syntax.us2 = uvs; FStar_Syntax_Syntax.t2 = t;_} - -> - ((let uu___3 = FStar_TypeChecker_Env.lid_exists env lid in - if uu___3 - then - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Class_Show.show FStar_Ident.showable_lident - lid in - FStar_Compiler_Util.format1 - "Top-level declaration %s for a name that is already used in this module." - uu___7 in - FStar_Errors_Msg.text uu___6 in - let uu___6 = - let uu___7 = - FStar_Errors_Msg.text - "Top-level declarations must be unique in their module." in - [uu___7] in - uu___5 :: uu___6 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_AlreadyDefinedTopLevelDeclaration - () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___4) - else ()); - (let env1 = FStar_TypeChecker_Env.set_range env r in - let uu___3 = - let uu___4 = do_two_phases env1 in - if uu___4 - then - run_phase1 - (fun uu___5 -> - let uu___6 = - tc_declare_typ - { - FStar_TypeChecker_Env.solver = - (env1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = true; - FStar_TypeChecker_Env.lax_universes = - (env1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = true; - FStar_TypeChecker_Env.failhard = - (env1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (env1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (env1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env1.FStar_TypeChecker_Env.missing_decl) - } (uvs, t) se2.FStar_Syntax_Syntax.sigrng in - match uu___6 with - | (uvs1, t1) -> - ((let uu___8 = - (FStar_Compiler_Debug.medium ()) || - (FStar_Compiler_Effect.op_Bang - dbg_TwoPhases) in - if uu___8 - then - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t1 in - let uu___10 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Ident.showable_ident) uvs1 in - FStar_Compiler_Util.print2 - "Val declaration after phase 1: %s and uvs: %s\n" - uu___9 uu___10 - else ()); - (uvs1, t1))) - else (uvs, t) in - match uu___3 with - | (uvs1, t1) -> - let uu___4 = - tc_declare_typ env1 (uvs1, t1) - se2.FStar_Syntax_Syntax.sigrng in - (match uu___4 with - | (uvs2, t2) -> - ([{ - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_declare_typ - { - FStar_Syntax_Syntax.lid2 = lid; - FStar_Syntax_Syntax.us2 = uvs2; - FStar_Syntax_Syntax.t2 = t2 - }); - FStar_Syntax_Syntax.sigrng = - (se2.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se2.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se2.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se2.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se2.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se2.FStar_Syntax_Syntax.sigopts) - }], [], env0)))) - | FStar_Syntax_Syntax.Sig_assume - { FStar_Syntax_Syntax.lid3 = lid; - FStar_Syntax_Syntax.us3 = uvs; - FStar_Syntax_Syntax.phi1 = t;_} - -> - (if - Prims.op_Negation - (FStar_Compiler_List.contains - FStar_Syntax_Syntax.InternalAssumption - se2.FStar_Syntax_Syntax.sigquals) - then - (let uu___3 = - let uu___4 = - FStar_Class_Show.show FStar_Ident.showable_lident lid in - FStar_Compiler_Util.format1 - "Admitting a top-level assumption %s" uu___4 in - FStar_Errors.log_issue FStar_Class_HasRange.hasRange_range - r FStar_Errors_Codes.Warning_WarnOnUse () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___3)) - else (); - (let env1 = FStar_TypeChecker_Env.set_range env r in - let uu___3 = - let uu___4 = do_two_phases env1 in - if uu___4 - then - run_phase1 - (fun uu___5 -> - let uu___6 = - tc_assume - { - FStar_TypeChecker_Env.solver = - (env1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = true; - FStar_TypeChecker_Env.lax_universes = - (env1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = true; - FStar_TypeChecker_Env.failhard = - (env1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (env1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (env1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env1.FStar_TypeChecker_Env.missing_decl) - } (uvs, t) se2.FStar_Syntax_Syntax.sigrng in - match uu___6 with - | (uvs1, t1) -> - ((let uu___8 = - (FStar_Compiler_Debug.medium ()) || - (FStar_Compiler_Effect.op_Bang - dbg_TwoPhases) in - if uu___8 - then - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t1 in - let uu___10 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Ident.showable_ident) uvs1 in - FStar_Compiler_Util.print2 - "Assume after phase 1: %s and uvs: %s\n" - uu___9 uu___10 - else ()); - (uvs1, t1))) - else (uvs, t) in - match uu___3 with - | (uvs1, t1) -> - let uu___4 = - tc_assume env1 (uvs1, t1) - se2.FStar_Syntax_Syntax.sigrng in - (match uu___4 with - | (uvs2, t2) -> - ([{ - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_assume - { - FStar_Syntax_Syntax.lid3 = lid; - FStar_Syntax_Syntax.us3 = uvs2; - FStar_Syntax_Syntax.phi1 = t2 - }); - FStar_Syntax_Syntax.sigrng = - (se2.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se2.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se2.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se2.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se2.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se2.FStar_Syntax_Syntax.sigopts) - }], [], env0)))) - | FStar_Syntax_Syntax.Sig_splice - { FStar_Syntax_Syntax.is_typed = is_typed; - FStar_Syntax_Syntax.lids2 = lids; - FStar_Syntax_Syntax.tac = t;_} - -> - ((let uu___3 = FStar_Compiler_Debug.any () in - if uu___3 - then - let uu___4 = - FStar_Ident.string_of_lid - env.FStar_TypeChecker_Env.curmodule in - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - let uu___6 = FStar_Compiler_Util.string_of_bool is_typed in - FStar_Compiler_Util.print3 - "%s: Found splice of (%s) with is_typed: %s\n" uu___4 - uu___5 uu___6 - else ()); - (let ses = - env.FStar_TypeChecker_Env.splice env is_typed lids t - se2.FStar_Syntax_Syntax.sigrng in - let ses1 = - if is_typed - then - let sigquals = - match se2.FStar_Syntax_Syntax.sigquals with - | [] -> [FStar_Syntax_Syntax.Visible_default] - | qs -> qs in - FStar_Compiler_List.map - (fun sp -> - { - FStar_Syntax_Syntax.sigel = - (sp.FStar_Syntax_Syntax.sigel); - FStar_Syntax_Syntax.sigrng = - (sp.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (FStar_Compiler_List.op_At sigquals - sp.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (sp.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (FStar_Compiler_List.op_At - se2.FStar_Syntax_Syntax.sigattrs - sp.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (sp.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (sp.FStar_Syntax_Syntax.sigopts) - }) ses - else ses in - let ses2 = - FStar_Compiler_List.map - (fun se3 -> - if - env.FStar_TypeChecker_Env.is_iface && - (FStar_Syntax_Syntax.uu___is_Sig_declare_typ - se3.FStar_Syntax_Syntax.sigel) - then - let uu___3 = - let uu___4 = - FStar_Compiler_List.filter - (fun q -> - q <> FStar_Syntax_Syntax.Irreducible) - se3.FStar_Syntax_Syntax.sigquals in - FStar_Syntax_Syntax.Assumption :: uu___4 in - { - FStar_Syntax_Syntax.sigel = - (se3.FStar_Syntax_Syntax.sigel); - FStar_Syntax_Syntax.sigrng = - (se3.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = uu___3; - FStar_Syntax_Syntax.sigmeta = - (se3.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se3.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se3.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se3.FStar_Syntax_Syntax.sigopts) - } - else se3) ses1 in - let ses3 = - FStar_Compiler_List.map - (fun se3 -> - { - FStar_Syntax_Syntax.sigel = - (se3.FStar_Syntax_Syntax.sigel); - FStar_Syntax_Syntax.sigrng = - (se3.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se3.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (let uu___3 = se3.FStar_Syntax_Syntax.sigmeta in - { - FStar_Syntax_Syntax.sigmeta_active = - (uu___3.FStar_Syntax_Syntax.sigmeta_active); - FStar_Syntax_Syntax.sigmeta_fact_db_ids = - (uu___3.FStar_Syntax_Syntax.sigmeta_fact_db_ids); - FStar_Syntax_Syntax.sigmeta_admit = - (uu___3.FStar_Syntax_Syntax.sigmeta_admit); - FStar_Syntax_Syntax.sigmeta_spliced = true; - FStar_Syntax_Syntax.sigmeta_already_checked = - (uu___3.FStar_Syntax_Syntax.sigmeta_already_checked); - FStar_Syntax_Syntax.sigmeta_extension_data = - (uu___3.FStar_Syntax_Syntax.sigmeta_extension_data) - }); - FStar_Syntax_Syntax.sigattrs = - (se3.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se3.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se3.FStar_Syntax_Syntax.sigopts) - }) ses2 in - let dsenv = - FStar_Compiler_List.fold_left - FStar_Syntax_DsEnv.push_sigelt_force - env.FStar_TypeChecker_Env.dsenv ses3 in - let env1 = - { - FStar_TypeChecker_Env.solver = - (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (env.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = dsenv; - FStar_TypeChecker_Env.nbe = - (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env.FStar_TypeChecker_Env.missing_decl) - } in - (let uu___4 = FStar_Compiler_Debug.low () in - if uu___4 - then - let uu___5 = - let uu___6 = - FStar_Compiler_List.map - (FStar_Class_Show.show - FStar_Syntax_Print.showable_sigelt) ses3 in - FStar_Compiler_String.concat "\n" uu___6 in - FStar_Compiler_Util.print1 - "Splice returned sigelts {\n%s\n}\n" uu___5 - else ()); - ([], ses3, env1))) - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = lbs; - FStar_Syntax_Syntax.lids1 = lids;_} - -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_TypeChecker_Env.current_module env in - FStar_Ident.string_of_lid uu___4 in - FStar_Pervasives_Native.Some uu___3 in - FStar_Profiling.profile - (fun uu___3 -> tc_sig_let env r se2 lbs lids) uu___2 - "FStar.TypeChecker.Tc.tc_sig_let" - | FStar_Syntax_Syntax.Sig_polymonadic_bind - { FStar_Syntax_Syntax.m_lid = m; - FStar_Syntax_Syntax.n_lid = n; - FStar_Syntax_Syntax.p_lid = p; FStar_Syntax_Syntax.tm3 = t; - FStar_Syntax_Syntax.typ = uu___2; - FStar_Syntax_Syntax.kind1 = uu___3;_} - -> - let t1 = - let uu___4 = do_two_phases env in - if uu___4 - then - run_phase1 - (fun uu___5 -> - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - FStar_TypeChecker_TcEffect.tc_polymonadic_bind - { - FStar_TypeChecker_Env.solver = - (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = true; - FStar_TypeChecker_Env.lax_universes = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = true; - FStar_TypeChecker_Env.failhard = - (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env.FStar_TypeChecker_Env.missing_decl) - } m n p t in - match uu___9 with - | (t2, ty, uu___10) -> - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_polymonadic_bind - { - FStar_Syntax_Syntax.m_lid = m; - FStar_Syntax_Syntax.n_lid = n; - FStar_Syntax_Syntax.p_lid = p; - FStar_Syntax_Syntax.tm3 = t2; - FStar_Syntax_Syntax.typ = ty; - FStar_Syntax_Syntax.kind1 = - FStar_Pervasives_Native.None - }); - FStar_Syntax_Syntax.sigrng = - (se2.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se2.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se2.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se2.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs - = - (se2.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se2.FStar_Syntax_Syntax.sigopts) - } in - FStar_TypeChecker_Normalize.elim_uvars env uu___8 in - match uu___7.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_polymonadic_bind - { FStar_Syntax_Syntax.m_lid = uu___8; - FStar_Syntax_Syntax.n_lid = uu___9; - FStar_Syntax_Syntax.p_lid = uu___10; - FStar_Syntax_Syntax.tm3 = t2; - FStar_Syntax_Syntax.typ = ty; - FStar_Syntax_Syntax.kind1 = uu___11;_} - -> (t2, ty) - | uu___8 -> - failwith - "Impossible! tc for Sig_polymonadic_bind must be a Sig_polymonadic_bind" in - match uu___6 with - | (t2, ty) -> - ((let uu___8 = - (FStar_Compiler_Debug.medium ()) || - (FStar_Compiler_Effect.op_Bang - dbg_TwoPhases) in - if uu___8 - then - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_sigelt - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_polymonadic_bind - { - FStar_Syntax_Syntax.m_lid = m; - FStar_Syntax_Syntax.n_lid = n; - FStar_Syntax_Syntax.p_lid = p; - FStar_Syntax_Syntax.tm3 = t2; - FStar_Syntax_Syntax.typ = ty; - FStar_Syntax_Syntax.kind1 = - FStar_Pervasives_Native.None - }); - FStar_Syntax_Syntax.sigrng = - (se2.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se2.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se2.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se2.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs - = - (se2.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se2.FStar_Syntax_Syntax.sigopts) - } in - FStar_Compiler_Util.print1 - "Polymonadic bind after phase 1: %s\n" - uu___9 - else ()); - t2)) - else t in - let uu___4 = - FStar_TypeChecker_TcEffect.tc_polymonadic_bind env m n p t1 in - (match uu___4 with - | (t2, ty, k) -> - let se3 = - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_polymonadic_bind - { - FStar_Syntax_Syntax.m_lid = m; - FStar_Syntax_Syntax.n_lid = n; - FStar_Syntax_Syntax.p_lid = p; - FStar_Syntax_Syntax.tm3 = t2; - FStar_Syntax_Syntax.typ = ty; - FStar_Syntax_Syntax.kind1 = - (FStar_Pervasives_Native.Some k) - }); - FStar_Syntax_Syntax.sigrng = - (se2.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se2.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se2.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se2.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se2.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se2.FStar_Syntax_Syntax.sigopts) - } in - ([se3], [], env0)) - | FStar_Syntax_Syntax.Sig_polymonadic_subcomp - { FStar_Syntax_Syntax.m_lid1 = m; - FStar_Syntax_Syntax.n_lid1 = n; FStar_Syntax_Syntax.tm4 = t; - FStar_Syntax_Syntax.typ1 = uu___2; - FStar_Syntax_Syntax.kind2 = uu___3;_} - -> - let t1 = - let uu___4 = do_two_phases env in - if uu___4 - then - run_phase1 - (fun uu___5 -> - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - FStar_TypeChecker_TcEffect.tc_polymonadic_subcomp - { - FStar_TypeChecker_Env.solver = - (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = true; - FStar_TypeChecker_Env.lax_universes = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = true; - FStar_TypeChecker_Env.failhard = - (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env.FStar_TypeChecker_Env.missing_decl) - } m n t in - match uu___9 with - | (t2, ty, uu___10) -> - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_polymonadic_subcomp - { - FStar_Syntax_Syntax.m_lid1 = m; - FStar_Syntax_Syntax.n_lid1 = n; - FStar_Syntax_Syntax.tm4 = t2; - FStar_Syntax_Syntax.typ1 = ty; - FStar_Syntax_Syntax.kind2 = - FStar_Pervasives_Native.None - }); - FStar_Syntax_Syntax.sigrng = - (se2.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se2.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se2.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se2.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs - = - (se2.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se2.FStar_Syntax_Syntax.sigopts) - } in - FStar_TypeChecker_Normalize.elim_uvars env uu___8 in - match uu___7.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_polymonadic_subcomp - { FStar_Syntax_Syntax.m_lid1 = uu___8; - FStar_Syntax_Syntax.n_lid1 = uu___9; - FStar_Syntax_Syntax.tm4 = t2; - FStar_Syntax_Syntax.typ1 = ty; - FStar_Syntax_Syntax.kind2 = uu___10;_} - -> (t2, ty) - | uu___8 -> - failwith - "Impossible! tc for Sig_polymonadic_subcomp must be a Sig_polymonadic_subcomp" in - match uu___6 with - | (t2, ty) -> - ((let uu___8 = - (FStar_Compiler_Debug.medium ()) || - (FStar_Compiler_Effect.op_Bang - dbg_TwoPhases) in - if uu___8 - then - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_sigelt - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_polymonadic_subcomp - { - FStar_Syntax_Syntax.m_lid1 = m; - FStar_Syntax_Syntax.n_lid1 = n; - FStar_Syntax_Syntax.tm4 = t2; - FStar_Syntax_Syntax.typ1 = ty; - FStar_Syntax_Syntax.kind2 = - FStar_Pervasives_Native.None - }); - FStar_Syntax_Syntax.sigrng = - (se2.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se2.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se2.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se2.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs - = - (se2.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se2.FStar_Syntax_Syntax.sigopts) - } in - FStar_Compiler_Util.print1 - "Polymonadic subcomp after phase 1: %s\n" - uu___9 - else ()); - t2)) - else t in - let uu___4 = - FStar_TypeChecker_TcEffect.tc_polymonadic_subcomp env m n t1 in - (match uu___4 with - | (t2, ty, k) -> - let se3 = - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_polymonadic_subcomp - { - FStar_Syntax_Syntax.m_lid1 = m; - FStar_Syntax_Syntax.n_lid1 = n; - FStar_Syntax_Syntax.tm4 = t2; - FStar_Syntax_Syntax.typ1 = ty; - FStar_Syntax_Syntax.kind2 = - (FStar_Pervasives_Native.Some k) - }); - FStar_Syntax_Syntax.sigrng = - (se2.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se2.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se2.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se2.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se2.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se2.FStar_Syntax_Syntax.sigopts) - } in - ([se3], [], env0))) -let (tc_decl : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.sigelt -> - (FStar_Syntax_Syntax.sigelt Prims.list * FStar_Syntax_Syntax.sigelt - Prims.list * FStar_TypeChecker_Env.env)) - = - fun env -> - fun se -> - FStar_GenSym.reset_gensym (); - (let env0 = env in - let env1 = set_hint_correlator env se in - let env2 = - let uu___1 = FStar_Options.admit_smt_queries () in - if uu___1 - then - { - FStar_TypeChecker_Env.solver = - (env1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = (env1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = (env1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = true; - FStar_TypeChecker_Env.lax_universes = - (env1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = (env1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (env1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env1.FStar_TypeChecker_Env.missing_decl) - } - else env1 in - (let uu___2 = FStar_Compiler_Debug.any () in - if uu___2 - then - let uu___3 = FStar_Syntax_Print.sigelt_to_string_short se in - FStar_Compiler_Util.print1 "Processing %s\n" uu___3 - else ()); - (let uu___3 = FStar_Compiler_Debug.medium () in - if uu___3 - then - let uu___4 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - env2.FStar_TypeChecker_Env.admit in - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_sigelt se in - FStar_Compiler_Util.print2 ">>>>>>>>>>>>>>tc_decl admit=%s %s\n" - uu___4 uu___5 - else ()); - (let result = - if - (se.FStar_Syntax_Syntax.sigmeta).FStar_Syntax_Syntax.sigmeta_already_checked - then ([se], [], env2) - else - if - (se.FStar_Syntax_Syntax.sigmeta).FStar_Syntax_Syntax.sigmeta_admit - then - (let result1 = - tc_decl' - { - FStar_TypeChecker_Env.solver = - (env2.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env2.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env2.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env2.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env2.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env2.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env2.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env2.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env2.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env2.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env2.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env2.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env2.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env2.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env2.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env2.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env2.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env2.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = true; - FStar_TypeChecker_Env.lax_universes = - (env2.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env2.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env2.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env2.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env2.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env2.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env2.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env2.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env2.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env2.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env2.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env2.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env2.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env2.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env2.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env2.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env2.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env2.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env2.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env2.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env2.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env2.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env2.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env2.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env2.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env2.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env2.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env2.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env2.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env2.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env2.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env2.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env2.FStar_TypeChecker_Env.missing_decl) - } se in - result1) - else tc_decl' env2 se in - (let uu___4 = result in - match uu___4 with - | (ses, uu___5, uu___6) -> - FStar_Compiler_List.iter - (FStar_TypeChecker_Quals.check_sigelt_quals_post env2) ses); - (match () with - | () -> - let result1 = - let uu___4 = result in - match uu___4 with - | (ses, ses_e, env3) -> - (ses, ses_e, - { - FStar_TypeChecker_Env.solver = - (env3.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env3.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env3.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env3.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env3.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env3.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env3.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env3.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env3.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env3.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env3.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env3.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env3.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env3.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env3.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env3.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env3.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env3.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (env0.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env3.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env3.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env3.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env3.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env3.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env3.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env3.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env3.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env3.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env3.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env3.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env3.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env3.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env3.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env3.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env3.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env3.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env3.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env3.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env3.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env3.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env3.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env3.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env3.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env3.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env3.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env3.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env3.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env3.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env3.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env3.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env3.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env3.FStar_TypeChecker_Env.missing_decl) - }) in - result1))) -let (add_sigelt_to_env : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.sigelt -> Prims.bool -> FStar_TypeChecker_Env.env) - = - fun env -> - fun se -> - fun from_cache -> - (let uu___1 = FStar_Compiler_Debug.low () in - if uu___1 - then - let uu___2 = FStar_Syntax_Print.sigelt_to_string_short se in - let uu___3 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) from_cache in - FStar_Compiler_Util.print2 - ">>>>>>>>>>>>>>Adding top-level decl to environment: %s (from_cache:%s)\n" - uu___2 uu___3 - else ()); - (match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_sigelt se in - FStar_Compiler_Util.format1 - "add_sigelt_to_env: unexpected bare type/data constructor: %s" - uu___3 in - FStar_Errors.raise_error FStar_Syntax_Syntax.has_range_sigelt se - FStar_Errors_Codes.Fatal_UnexpectedInductivetype () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2) - | FStar_Syntax_Syntax.Sig_datacon uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_sigelt se in - FStar_Compiler_Util.format1 - "add_sigelt_to_env: unexpected bare type/data constructor: %s" - uu___3 in - FStar_Errors.raise_error FStar_Syntax_Syntax.has_range_sigelt se - FStar_Errors_Codes.Fatal_UnexpectedInductivetype () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2) - | FStar_Syntax_Syntax.Sig_declare_typ uu___1 when - FStar_Compiler_Util.for_some - (fun uu___2 -> - match uu___2 with - | FStar_Syntax_Syntax.OnlyName -> true - | uu___3 -> false) se.FStar_Syntax_Syntax.sigquals - -> env - | FStar_Syntax_Syntax.Sig_let uu___1 when - FStar_Compiler_Util.for_some - (fun uu___2 -> - match uu___2 with - | FStar_Syntax_Syntax.OnlyName -> true - | uu___3 -> false) se.FStar_Syntax_Syntax.sigquals - -> env - | uu___1 -> - let env1 = FStar_TypeChecker_Env.push_sigelt env se in - (match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_pragma - (FStar_Syntax_Syntax.ShowOptions) -> - ((let uu___3 = - let uu___4 = FStar_Errors_Msg.text "Option state:" in - let uu___5 = - let uu___6 = - let uu___7 = FStar_Options.show_options () in - FStar_Pprint.arbitrary_string uu___7 in - [uu___6] in - uu___4 :: uu___5 in - FStar_Errors.info FStar_Syntax_Syntax.has_range_sigelt se - () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___3)); - env1) - | FStar_Syntax_Syntax.Sig_pragma - (FStar_Syntax_Syntax.PushOptions uu___2) -> - if from_cache - then env1 - else - (let uu___4 = FStar_Options.using_facts_from () in - { - FStar_TypeChecker_Env.solver = - (env1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (env1.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = uu___4; - FStar_TypeChecker_Env.synth_hook = - (env1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env1.FStar_TypeChecker_Env.missing_decl) - }) - | FStar_Syntax_Syntax.Sig_pragma - (FStar_Syntax_Syntax.PopOptions) -> - if from_cache - then env1 - else - (let uu___3 = FStar_Options.using_facts_from () in - { - FStar_TypeChecker_Env.solver = - (env1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (env1.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = uu___3; - FStar_TypeChecker_Env.synth_hook = - (env1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env1.FStar_TypeChecker_Env.missing_decl) - }) - | FStar_Syntax_Syntax.Sig_pragma - (FStar_Syntax_Syntax.SetOptions uu___2) -> - if from_cache - then env1 - else - (let uu___4 = FStar_Options.using_facts_from () in - { - FStar_TypeChecker_Env.solver = - (env1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (env1.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = uu___4; - FStar_TypeChecker_Env.synth_hook = - (env1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env1.FStar_TypeChecker_Env.missing_decl) - }) - | FStar_Syntax_Syntax.Sig_pragma - (FStar_Syntax_Syntax.ResetOptions uu___2) -> - if from_cache - then env1 - else - (let uu___4 = FStar_Options.using_facts_from () in - { - FStar_TypeChecker_Env.solver = - (env1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (env1.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = uu___4; - FStar_TypeChecker_Env.synth_hook = - (env1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env1.FStar_TypeChecker_Env.missing_decl) - }) - | FStar_Syntax_Syntax.Sig_pragma - (FStar_Syntax_Syntax.RestartSolver) -> - if from_cache || env1.FStar_TypeChecker_Env.flychecking - then env1 - else - ((env1.FStar_TypeChecker_Env.solver).FStar_TypeChecker_Env.refresh - (FStar_Pervasives_Native.Some - (env1.FStar_TypeChecker_Env.proof_ns)); - env1) - | FStar_Syntax_Syntax.Sig_pragma - (FStar_Syntax_Syntax.PrintEffectsGraph) -> - ((let uu___3 = - FStar_TypeChecker_Env.print_effects_graph env1 in - FStar_Compiler_Util.write_file "effects.graph" uu___3); - env1) - | FStar_Syntax_Syntax.Sig_new_effect ne -> - let env2 = - FStar_TypeChecker_Env.push_new_effect env1 - (ne, (se.FStar_Syntax_Syntax.sigquals)) in - FStar_Compiler_List.fold_left - (fun env3 -> - fun a -> - let uu___2 = - FStar_Syntax_Util.action_as_lb - ne.FStar_Syntax_Syntax.mname a - (a.FStar_Syntax_Syntax.action_defn).FStar_Syntax_Syntax.pos in - FStar_TypeChecker_Env.push_sigelt env3 uu___2) env2 - ne.FStar_Syntax_Syntax.actions - | FStar_Syntax_Syntax.Sig_sub_effect sub -> - FStar_TypeChecker_Util.update_env_sub_eff env1 sub - se.FStar_Syntax_Syntax.sigrng - | FStar_Syntax_Syntax.Sig_polymonadic_bind - { FStar_Syntax_Syntax.m_lid = m; - FStar_Syntax_Syntax.n_lid = n; - FStar_Syntax_Syntax.p_lid = p; - FStar_Syntax_Syntax.tm3 = uu___2; - FStar_Syntax_Syntax.typ = ty; - FStar_Syntax_Syntax.kind1 = k;_} - -> - let uu___3 = FStar_Compiler_Util.must k in - FStar_TypeChecker_Util.update_env_polymonadic_bind env1 m n - p ty uu___3 - | FStar_Syntax_Syntax.Sig_polymonadic_subcomp - { FStar_Syntax_Syntax.m_lid1 = m; - FStar_Syntax_Syntax.n_lid1 = n; - FStar_Syntax_Syntax.tm4 = uu___2; - FStar_Syntax_Syntax.typ1 = ty; - FStar_Syntax_Syntax.kind2 = k;_} - -> - let uu___3 = - let uu___4 = FStar_Compiler_Util.must k in (ty, uu___4) in - FStar_TypeChecker_Env.add_polymonadic_subcomp env1 m n - uu___3 - | uu___2 -> env1)) -let (compress_and_norm : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.typ FStar_Pervasives_Native.option) - = - fun env -> - fun t -> - let uu___ = FStar_Syntax_Compress.deep_compress_if_no_uvars t in - match uu___ with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some t1 -> - let uu___1 = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.AllowUnboundUniverses; - FStar_TypeChecker_Env.CheckNoUvars; - FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.DoNotUnfoldPureLets; - FStar_TypeChecker_Env.CompressUvars; - FStar_TypeChecker_Env.Exclude FStar_TypeChecker_Env.Zeta; - FStar_TypeChecker_Env.Exclude FStar_TypeChecker_Env.Iota; - FStar_TypeChecker_Env.NoFullNorm] env t1 in - FStar_Pervasives_Native.Some uu___1 -let (tc_decls : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.sigelt Prims.list -> - (FStar_Syntax_Syntax.sigelt Prims.list * FStar_TypeChecker_Env.env)) - = - fun env -> - fun ses -> - let rec process_one_decl uu___ se = - match uu___ with - | (ses1, env1) -> - (FStar_Compiler_Effect.op_Colon_Equals - FStar_Errors.fallback_range - (FStar_Pervasives_Native.Some (se.FStar_Syntax_Syntax.sigrng)); - (let uu___2 = - env1.FStar_TypeChecker_Env.flychecking && - (FStar_Compiler_Debug.any ()) in - if uu___2 - then ((ses1, env1), []) - else - ((let uu___5 = FStar_Compiler_Debug.low () in - if uu___5 - then - let uu___6 = - FStar_Class_Tagged.tag_of - FStar_Syntax_Syntax.tagged_sigelt se in - let uu___7 = FStar_Syntax_Print.sigelt_to_string_short se in - FStar_Compiler_Util.print2 - ">>>>>>>>>>>>>>Checking top-level %s decl %s\n" uu___6 - uu___7 - else ()); - (let uu___6 = FStar_Options.ide_id_info_off () in - if uu___6 - then FStar_TypeChecker_Env.toggle_id_info env1 false - else ()); - (let uu___7 = FStar_Compiler_Effect.op_Bang dbg_IdInfoOn in - if uu___7 - then FStar_TypeChecker_Env.toggle_id_info env1 true - else ()); - (let uu___7 = - let uu___8 = - let uu___9 = - FStar_Syntax_Print.sigelt_to_string_short se in - FStar_Compiler_Util.format2 - "While typechecking the %stop-level declaration `%s`" - (if - (se.FStar_Syntax_Syntax.sigmeta).FStar_Syntax_Syntax.sigmeta_spliced - then "(spliced) " - else "") uu___9 in - FStar_Errors.with_ctx uu___8 - (fun uu___9 -> tc_decl env1 se) in - match uu___7 with - | (ses', ses_elaborated, env2) -> - let ses'1 = - FStar_Compiler_List.map - (fun se1 -> - (let uu___9 = - FStar_Compiler_Effect.op_Bang dbg_UF in - if uu___9 - then - let uu___10 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_sigelt se1 in - FStar_Compiler_Util.print1 - "About to elim vars from %s\n" uu___10 - else ()); - FStar_TypeChecker_Normalize.elim_uvars env2 se1) - ses' in - let ses_elaborated1 = - FStar_Compiler_List.map - (fun se1 -> - (let uu___9 = - FStar_Compiler_Effect.op_Bang dbg_UF in - if uu___9 - then - let uu___10 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_sigelt se1 in - FStar_Compiler_Util.print1 - "About to elim vars from (elaborated) %s\n" - uu___10 - else ()); - FStar_TypeChecker_Normalize.elim_uvars env2 se1) - ses_elaborated in - (FStar_TypeChecker_Env.promote_id_info env2 - (compress_and_norm env2); - (let ses'2 = - FStar_Compiler_List.map - (FStar_Syntax_Compress.deep_compress_se false - false) ses'1 in - let env3 = - FStar_Compiler_List.fold_left - (fun env4 -> - fun se1 -> add_sigelt_to_env env4 se1 false) - env2 ses'2 in - FStar_Syntax_Unionfind.reset (); - (let uu___11 = - ((FStar_Options.log_types ()) || - (FStar_Compiler_Debug.medium ())) - || (FStar_Compiler_Effect.op_Bang dbg_LogTypes) in - if uu___11 - then - let uu___12 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_sigelt) ses'2 in - FStar_Compiler_Util.print1 "Checked: %s\n" uu___12 - else ()); - (let uu___12 = - let uu___13 = - let uu___14 = - FStar_TypeChecker_Env.current_module env3 in - FStar_Ident.string_of_lid uu___14 in - FStar_Pervasives_Native.Some uu___13 in - FStar_Profiling.profile - (fun uu___13 -> - FStar_Compiler_List.iter - (fun se1 -> - (env3.FStar_TypeChecker_Env.solver).FStar_TypeChecker_Env.encode_sig - env3 se1) ses'2) uu___12 - "FStar.TypeChecker.Tc.encode_sig"); - (((FStar_Compiler_List.rev_append ses'2 ses1), env3), - ses_elaborated1))))))) in - let process_one_decl_timed acc se = - FStar_TypeChecker_Core.clear_memo_table (); - (let uu___1 = acc in - match uu___1 with - | (uu___2, env1) -> - let r = - let uu___3 = - let uu___4 = - let uu___5 = FStar_TypeChecker_Env.current_module env1 in - FStar_Ident.string_of_lid uu___5 in - FStar_Pervasives_Native.Some uu___4 in - FStar_Profiling.profile - (fun uu___4 -> process_one_decl acc se) uu___3 - "FStar.TypeChecker.Tc.process_one_decl" in - ((let uu___4 = - (FStar_Options.profile_group_by_decl ()) || - (FStar_Options.timing ()) in - if uu___4 - then - let tag = - match FStar_Syntax_Util.lids_of_sigelt se with - | hd::uu___5 -> FStar_Ident.string_of_lid hd - | uu___5 -> - FStar_Compiler_Range_Ops.string_of_range - (FStar_Syntax_Util.range_of_sigelt se) in - FStar_Profiling.report_and_clear tag - else ()); - r)) in - let uu___ = - FStar_Syntax_Unionfind.with_uf_enabled - (fun uu___1 -> - FStar_Compiler_Util.fold_flatten process_one_decl_timed - ([], env) ses) in - match uu___ with - | (ses1, env1) -> ((FStar_Compiler_List.rev_append ses1 []), env1) -let (uu___0 : unit) = - FStar_Compiler_Effect.op_Colon_Equals tc_decls_knot - (FStar_Pervasives_Native.Some tc_decls) -let (snapshot_context : - FStar_TypeChecker_Env.env -> - Prims.string -> - ((Prims.int * Prims.int * FStar_TypeChecker_Env.solver_depth_t * - Prims.int) * FStar_TypeChecker_Env.env)) - = - fun env -> - fun msg -> - FStar_Compiler_Util.atomically - (fun uu___ -> FStar_TypeChecker_Env.snapshot env msg) -let (rollback_context : - FStar_TypeChecker_Env.solver_t -> - Prims.string -> - (Prims.int * Prims.int * FStar_TypeChecker_Env.solver_depth_t * - Prims.int) FStar_Pervasives_Native.option -> - FStar_TypeChecker_Env.env) - = - fun solver -> - fun msg -> - fun depth -> - FStar_Compiler_Util.atomically - (fun uu___ -> - let env = FStar_TypeChecker_Env.rollback solver msg depth in env) -let (push_context : - FStar_TypeChecker_Env.env -> Prims.string -> FStar_TypeChecker_Env.env) = - fun env -> - fun msg -> - let uu___ = snapshot_context env msg in - FStar_Pervasives_Native.snd uu___ -let (pop_context : - FStar_TypeChecker_Env.env -> Prims.string -> FStar_TypeChecker_Env.env) = - fun env -> - fun msg -> - rollback_context env.FStar_TypeChecker_Env.solver msg - FStar_Pervasives_Native.None -let (tc_partial_modul : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.modul -> - (FStar_Syntax_Syntax.modul * FStar_TypeChecker_Env.env)) - = - fun env -> - fun modul -> - let verify = - let uu___ = FStar_Ident.string_of_lid modul.FStar_Syntax_Syntax.name in - FStar_Options.should_verify uu___ in - let action = if verify then "verifying" else "lax-checking" in - let label = - if modul.FStar_Syntax_Syntax.is_interface - then "interface" - else "implementation" in - (let uu___1 = FStar_Compiler_Debug.any () in - if uu___1 - then - let uu___2 = - FStar_Ident.string_of_lid modul.FStar_Syntax_Syntax.name in - FStar_Compiler_Util.print3 "Now %s %s of %s\n" action label uu___2 - else ()); - FStar_Compiler_Debug.disable_all (); - (let uu___3 = - let uu___4 = - FStar_Ident.string_of_lid modul.FStar_Syntax_Syntax.name in - FStar_Options.should_check uu___4 in - if uu___3 - then - let uu___4 = FStar_Options.debug_keys () in - FStar_Compiler_Debug.enable_toggles uu___4 - else ()); - (let name = - let uu___3 = - FStar_Ident.string_of_lid modul.FStar_Syntax_Syntax.name in - FStar_Compiler_Util.format2 "%s %s" - (if modul.FStar_Syntax_Syntax.is_interface - then "interface" - else "module") uu___3 in - let env1 = - { - FStar_TypeChecker_Env.solver = (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = (env.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (modul.FStar_Syntax_Syntax.is_interface); - FStar_TypeChecker_Env.admit = (Prims.op_Negation verify); - FStar_TypeChecker_Env.lax_universes = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env.FStar_TypeChecker_Env.missing_decl) - } in - let env2 = - FStar_TypeChecker_Env.set_current_module env1 - modul.FStar_Syntax_Syntax.name in - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Ident.string_of_lid modul.FStar_Syntax_Syntax.name in - FStar_Options.should_check uu___5 in - Prims.op_Negation uu___4 in - let uu___4 = - let uu___5 = - FStar_Ident.string_of_lid modul.FStar_Syntax_Syntax.name in - FStar_Compiler_Util.format2 "While loading dependency %s%s" uu___5 - (if modul.FStar_Syntax_Syntax.is_interface - then " (interface)" - else "") in - FStar_Errors.with_ctx_if uu___3 uu___4 - (fun uu___5 -> - let uu___6 = tc_decls env2 modul.FStar_Syntax_Syntax.declarations in - match uu___6 with - | (ses, env3) -> - ({ - FStar_Syntax_Syntax.name = - (modul.FStar_Syntax_Syntax.name); - FStar_Syntax_Syntax.declarations = ses; - FStar_Syntax_Syntax.is_interface = - (modul.FStar_Syntax_Syntax.is_interface) - }, env3))) -let (tc_more_partial_modul : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.modul -> - FStar_Syntax_Syntax.sigelt Prims.list -> - (FStar_Syntax_Syntax.modul * FStar_Syntax_Syntax.sigelt Prims.list * - FStar_TypeChecker_Env.env)) - = - fun env -> - fun modul -> - fun decls -> - let uu___ = tc_decls env decls in - match uu___ with - | (ses, env1) -> - let modul1 = - { - FStar_Syntax_Syntax.name = (modul.FStar_Syntax_Syntax.name); - FStar_Syntax_Syntax.declarations = - (FStar_Compiler_List.op_At - modul.FStar_Syntax_Syntax.declarations ses); - FStar_Syntax_Syntax.is_interface = - (modul.FStar_Syntax_Syntax.is_interface) - } in - (modul1, ses, env1) -let (finish_partial_modul : - Prims.bool -> - Prims.bool -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.modul -> - (FStar_Syntax_Syntax.modul * FStar_TypeChecker_Env.env)) - = - fun loading_from_cache -> - fun iface_exists -> - fun en -> - fun m -> - let env = FStar_TypeChecker_Env.finish_module en m in - if Prims.op_Negation loading_from_cache - then - (let missing = FStar_TypeChecker_Env.missing_definition_list env in - if Prims.uu___is_Cons missing - then - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Ident.string_of_lid m.FStar_Syntax_Syntax.name in - FStar_Compiler_Util.format1 - "Missing definitions in module %s:" uu___5 in - FStar_Errors_Msg.text uu___4 in - let uu___4 = - FStar_Pprint.separate_map FStar_Pprint.hardline - (fun l -> - let uu___5 = FStar_Ident.ident_of_lid l in - FStar_Class_PP.pp FStar_Ident.pretty_ident uu___5) - missing in - FStar_Pprint.prefix (Prims.of_int (2)) Prims.int_one - uu___3 uu___4 in - [uu___2] in - FStar_Errors.log_issue FStar_TypeChecker_Env.hasRange_env env - FStar_Errors_Codes.Error_AdmitWithoutDefinition () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___1) - else ()) - else (); - FStar_Compiler_Util.smap_clear - (FStar_Pervasives_Native.snd - env.FStar_TypeChecker_Env.qtbl_name_and_index); - (let uu___3 = - let uu___4 = - let uu___5 = - FStar_Ident.string_of_lid m.FStar_Syntax_Syntax.name in - Prims.strcat "Ending modul " uu___5 in - pop_context env uu___4 in - ()); - (let uu___4 = - let uu___5 = FStar_Options.depth () in uu___5 > Prims.int_zero in - if uu___4 - then - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = FStar_Options.depth () in - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) uu___8 in - Prims.strcat uu___7 "." in - Prims.strcat - "Some #push-options have not been popped. Current depth is " - uu___6 in - FStar_Errors.log_issue FStar_TypeChecker_Env.hasRange_env env - FStar_Errors_Codes.Error_MissingPopOptions () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___5) - else ()); - (m, env) -let (deep_compress_modul : - FStar_Syntax_Syntax.modul -> FStar_Syntax_Syntax.modul) = - fun m -> - let uu___ = - FStar_Compiler_List.map - (FStar_Syntax_Compress.deep_compress_se false false) - m.FStar_Syntax_Syntax.declarations in - { - FStar_Syntax_Syntax.name = (m.FStar_Syntax_Syntax.name); - FStar_Syntax_Syntax.declarations = uu___; - FStar_Syntax_Syntax.is_interface = (m.FStar_Syntax_Syntax.is_interface) - } -let (tc_modul : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.modul -> - Prims.bool -> (FStar_Syntax_Syntax.modul * FStar_TypeChecker_Env.env)) - = - fun env0 -> - fun m -> - fun iface_exists -> - let msg = - let uu___ = FStar_Ident.string_of_lid m.FStar_Syntax_Syntax.name in - Prims.strcat "Internals for " uu___ in - let env01 = push_context env0 msg in - let uu___ = tc_partial_modul env01 m in - match uu___ with - | (modul, env) -> finish_partial_modul false iface_exists env modul -let (load_checked_module_sigelts : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.modul -> FStar_TypeChecker_Env.env) - = - fun en -> - fun m -> - let env = - FStar_TypeChecker_Env.set_current_module en - m.FStar_Syntax_Syntax.name in - let env1 = - let uu___ = - let uu___1 = FStar_Ident.string_of_lid m.FStar_Syntax_Syntax.name in - Prims.strcat "Internals for " uu___1 in - push_context env uu___ in - let env2 = - FStar_Compiler_List.fold_left - (fun env3 -> - fun se -> - let env4 = add_sigelt_to_env env3 se true in - let lids = FStar_Syntax_Util.lids_of_sigelt se in - FStar_Compiler_List.iter - (fun lid -> - let uu___1 = FStar_TypeChecker_Env.lookup_sigelt env4 lid in - ()) lids; - env4) env1 m.FStar_Syntax_Syntax.declarations in - env2 -let (load_checked_module : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.modul -> FStar_TypeChecker_Env.env) - = - fun en -> - fun m -> - (let uu___1 = - (let uu___2 = FStar_Ident.string_of_lid m.FStar_Syntax_Syntax.name in - FStar_Options.should_check uu___2) || - (FStar_Options.debug_all_modules ()) in - if uu___1 - then - let uu___2 = FStar_Options.debug_keys () in - FStar_Compiler_Debug.enable_toggles uu___2 - else FStar_Compiler_Debug.disable_all ()); - (let m1 = deep_compress_modul m in - let env = load_checked_module_sigelts en m1 in - let uu___1 = finish_partial_modul true true env m1 in - match uu___1 with | (uu___2, env1) -> env1) -let (load_partial_checked_module : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.modul -> FStar_TypeChecker_Env.env) - = - fun en -> - fun m -> - let m1 = deep_compress_modul m in load_checked_module_sigelts en m1 -let (check_module : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.modul -> - Prims.bool -> (FStar_Syntax_Syntax.modul * FStar_TypeChecker_Env.env)) - = - fun env0 -> - fun m -> - fun b -> - (let uu___1 = FStar_Compiler_Debug.any () in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show FStar_Ident.showable_lident - m.FStar_Syntax_Syntax.name in - FStar_Compiler_Util.print2 "Checking %s: %s\n" - (if m.FStar_Syntax_Syntax.is_interface - then "i'face" - else "module") uu___2 - else ()); - (let uu___2 = - let uu___3 = FStar_Ident.string_of_lid m.FStar_Syntax_Syntax.name in - FStar_Options.dump_module uu___3 in - if uu___2 - then - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_modul m in - FStar_Compiler_Util.print1 "Module before type checking:\n%s\n" - uu___3 - else ()); - (let env = - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Ident.string_of_lid m.FStar_Syntax_Syntax.name in - FStar_Options.should_verify uu___4 in - Prims.op_Negation uu___3 in - { - FStar_TypeChecker_Env.solver = - (env0.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = (env0.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env0.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = (env0.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env0.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env0.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env0.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env0.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env0.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env0.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env0.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env0.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env0.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env0.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env0.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env0.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env0.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env0.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = uu___2; - FStar_TypeChecker_Env.lax_universes = - (env0.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env0.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env0.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env0.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env0.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env0.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env0.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env0.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env0.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env0.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env0.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env0.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env0.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env0.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env0.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env0.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env0.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env0.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env0.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env0.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env0.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env0.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env0.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env0.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = (env0.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (env0.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env0.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env0.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env0.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env0.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env0.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env0.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env0.FStar_TypeChecker_Env.missing_decl) - } in - let uu___2 = tc_modul env m b in - match uu___2 with - | (m1, env1) -> - let env2 = - { - FStar_TypeChecker_Env.solver = - (env1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (env0.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (env1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env1.FStar_TypeChecker_Env.missing_decl) - } in - ((let uu___4 = - let uu___5 = - FStar_Ident.string_of_lid m1.FStar_Syntax_Syntax.name in - FStar_Options.dump_module uu___5 in - if uu___4 - then - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_modul m1 in - FStar_Compiler_Util.print1 - "Module after type checking:\n%s\n" uu___5 - else ()); - (let uu___5 = - (let uu___6 = - FStar_Ident.string_of_lid m1.FStar_Syntax_Syntax.name in - FStar_Options.dump_module uu___6) && - (FStar_Compiler_Effect.op_Bang dbg_Normalize) in - if uu___5 - then - let normalize_toplevel_lets se = - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_let - { FStar_Syntax_Syntax.lbs1 = (b1, lbs); - FStar_Syntax_Syntax.lids1 = ids;_} - -> - let n = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.Reify; - FStar_TypeChecker_Env.Inlining; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.AllowUnboundUniverses] in - let update lb = - let uu___6 = - FStar_Syntax_Subst.open_univ_vars - lb.FStar_Syntax_Syntax.lbunivs - lb.FStar_Syntax_Syntax.lbdef in - match uu___6 with - | (univnames, e) -> - let uu___7 = - let uu___8 = - FStar_TypeChecker_Env.push_univ_vars env2 - univnames in - n uu___8 e in - { - FStar_Syntax_Syntax.lbname = - (lb.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = - (lb.FStar_Syntax_Syntax.lbtyp); - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = uu___7; - FStar_Syntax_Syntax.lbattrs = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - } in - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = FStar_Compiler_List.map update lbs in - (b1, uu___9) in - { - FStar_Syntax_Syntax.lbs1 = uu___8; - FStar_Syntax_Syntax.lids1 = ids - } in - FStar_Syntax_Syntax.Sig_let uu___7 in - { - FStar_Syntax_Syntax.sigel = uu___6; - FStar_Syntax_Syntax.sigrng = - (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se.FStar_Syntax_Syntax.sigopts) - } - | uu___6 -> se in - let normalized_module = - let uu___6 = - FStar_Compiler_List.map normalize_toplevel_lets - m1.FStar_Syntax_Syntax.declarations in - { - FStar_Syntax_Syntax.name = (m1.FStar_Syntax_Syntax.name); - FStar_Syntax_Syntax.declarations = uu___6; - FStar_Syntax_Syntax.is_interface = - (m1.FStar_Syntax_Syntax.is_interface) - } in - let uu___6 = - FStar_Class_Show.show FStar_Syntax_Print.showable_modul - normalized_module in - FStar_Compiler_Util.print1 "%s\n" uu___6 - else ()); - (m1, env2))) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_TcEffect.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_TcEffect.ml deleted file mode 100644 index 927e4c3b115..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_TcEffect.ml +++ /dev/null @@ -1,10052 +0,0 @@ -open Prims -let (dbg : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "ED" -let (dbg_LayeredEffectsTc : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "LayeredEffectsTc" -let (dmff_cps_and_elaborate : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.eff_decl -> - (FStar_Syntax_Syntax.sigelt Prims.list * FStar_Syntax_Syntax.eff_decl * - FStar_Syntax_Syntax.sigelt FStar_Pervasives_Native.option)) - = fun env -> fun ed -> FStar_TypeChecker_DMFF.cps_and_elaborate env ed -let (check_and_gen : - FStar_TypeChecker_Env.env -> - Prims.string -> - Prims.string -> - Prims.int -> - (FStar_Syntax_Syntax.univ_names * FStar_Syntax_Syntax.term) -> - (FStar_Syntax_Syntax.univ_names * FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.typ)) - = - fun env -> - fun eff_name -> - fun comb -> - fun n -> - fun uu___ -> - match uu___ with - | (us, t) -> - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Class_Show.show - (FStar_Class_Show.show_tuple2 - (FStar_Class_Show.show_list - FStar_Ident.showable_ident) - FStar_Syntax_Print.showable_term) (us, t) in - Prims.strcat " = " uu___4 in - Prims.strcat comb uu___3 in - Prims.strcat "While checking combinator " uu___2 in - FStar_Errors.with_ctx uu___1 - (fun uu___2 -> - let uu___3 = FStar_Syntax_Subst.open_univ_vars us t in - match uu___3 with - | (us1, t1) -> - let uu___4 = - let uu___5 = - let uu___6 = - FStar_TypeChecker_Env.push_univ_vars env us1 in - FStar_TypeChecker_TcTerm.tc_tot_or_gtot_term - uu___6 t1 in - match uu___5 with - | (t2, lc, g) -> - (FStar_TypeChecker_Rel.force_trivial_guard env - g; - (t2, (lc.FStar_TypeChecker_Common.res_typ))) in - (match uu___4 with - | (t2, ty) -> - let uu___5 = - FStar_TypeChecker_Generalize.generalize_universes - env t2 in - (match uu___5 with - | (g_us, t3) -> - let ty1 = - FStar_Syntax_Subst.close_univ_vars g_us - ty in - (if (FStar_Compiler_List.length g_us) <> n - then - (let error = - let uu___6 = - FStar_Compiler_Util.string_of_int - n in - let uu___7 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length g_us) in - let uu___8 = - FStar_Syntax_Print.tscheme_to_string - (g_us, t3) in - FStar_Compiler_Util.format5 - "Expected %s:%s to be universe-polymorphic in %s universes, but found %s (tscheme: %s)" - eff_name comb uu___6 uu___7 uu___8 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax - ()) t3 - FStar_Errors_Codes.Fatal_MismatchUniversePolymorphic - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic error); - (match us1 with - | [] -> () - | uu___7 -> - let uu___8 = - ((FStar_Compiler_List.length - us1) - = - (FStar_Compiler_List.length - g_us)) - && - (FStar_Compiler_List.forall2 - (fun u1 -> - fun u2 -> - let uu___9 = - FStar_Syntax_Syntax.order_univ_name - u1 u2 in - uu___9 = - Prims.int_zero) us1 - g_us) in - if uu___8 - then () - else - (let uu___10 = - let uu___11 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Ident.showable_ident) - us1 in - let uu___12 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Ident.showable_ident) - g_us in - FStar_Compiler_Util.format4 - "Expected and generalized universes in the declaration for %s:%s are different, input: %s, but after gen: %s" - eff_name comb uu___11 - uu___12 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax - ()) t3 - FStar_Errors_Codes.Fatal_UnexpectedNumberOfUniverse - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___10)))) - else (); - (g_us, t3, ty1))))) -let (pure_wp_uvar : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> - Prims.string -> - FStar_Compiler_Range_Type.range -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.guard_t)) - = - fun env -> - fun t -> - fun reason -> - fun r -> - let pure_wp_t = - let pure_wp_ts = - let uu___ = - FStar_TypeChecker_Env.lookup_definition - [FStar_TypeChecker_Env.NoDelta] env - FStar_Parser_Const.pure_wp_lid in - FStar_Compiler_Util.must uu___ in - let uu___ = FStar_TypeChecker_Env.inst_tscheme pure_wp_ts in - match uu___ with - | (uu___1, pure_wp_t1) -> - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.as_arg t in [uu___3] in - FStar_Syntax_Syntax.mk_Tm_app pure_wp_t1 uu___2 r in - let uu___ = - FStar_TypeChecker_Env.new_implicit_var_aux reason r env pure_wp_t - FStar_Syntax_Syntax.Strict FStar_Pervasives_Native.None false in - match uu___ with - | (pure_wp_uvar1, uu___1, guard_wp) -> (pure_wp_uvar1, guard_wp) -let op_let_Question : - 'a 'b . - 'a FStar_Pervasives_Native.option -> - ('a -> 'b FStar_Pervasives_Native.option) -> - 'b FStar_Pervasives_Native.option - = - fun f -> - fun g -> - match f with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some x -> g x -let (mteq : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.typ -> Prims.bool) - = - fun env -> - fun t1 -> - fun t2 -> - try - (fun uu___ -> - match () with - | () -> FStar_TypeChecker_Rel.teq_nosmt_force env t1 t2) () - with | uu___ -> false -let (eq_binders : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.indexed_effect_binder_kind Prims.list - FStar_Pervasives_Native.option) - = - fun env -> - fun bs1 -> - fun bs2 -> - let uu___ = - let uu___1 = - FStar_Compiler_List.fold_left2 - (fun uu___2 -> - fun b1 -> - fun b2 -> - match uu___2 with - | (b, ss) -> - let uu___3 = - b && - (let uu___4 = - FStar_Syntax_Subst.subst ss - (b1.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - mteq env uu___4 - (b2.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort) in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Syntax_Syntax.bv_to_name - b2.FStar_Syntax_Syntax.binder_bv in - ((b1.FStar_Syntax_Syntax.binder_bv), uu___8) in - FStar_Syntax_Syntax.NT uu___7 in - [uu___6] in - FStar_Compiler_List.op_At ss uu___5 in - (uu___3, uu___4)) (true, []) bs1 bs2 in - FStar_Pervasives_Native.fst uu___1 in - if uu___ - then - let uu___1 = - FStar_Compiler_List.map - (fun uu___2 -> FStar_Syntax_Syntax.Substitutive_binder) bs1 in - FStar_Pervasives_Native.Some uu___1 - else FStar_Pervasives_Native.None -let (log_ad_hoc_combinator_warning : - Prims.string -> FStar_Compiler_Range_Type.range -> unit) = - fun comb_name -> - fun r -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Compiler_Util.format1 - "Combinator %s is not a substitutive indexed effect combinator, it is better to make it one if possible for better performance and ease of use" - comb_name in - FStar_Errors_Msg.text uu___2 in - [uu___1] in - FStar_Errors.log_issue FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Warning_Adhoc_IndexedEffect_Combinator () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___) -let (bind_combinator_kind : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident -> - FStar_Ident.lident -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.tscheme -> - FStar_Syntax_Syntax.tscheme -> - FStar_Syntax_Syntax.tscheme -> - FStar_Syntax_Syntax.tscheme FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.tscheme FStar_Pervasives_Native.option - -> - FStar_Syntax_Syntax.tscheme - FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.univ_names -> - FStar_Syntax_Syntax.typ -> - Prims.int -> - Prims.bool -> - FStar_Syntax_Syntax.indexed_effect_binder_kind - Prims.list FStar_Pervasives_Native.option) - = - fun env -> - fun m_eff_name -> - fun n_eff_name -> - fun p_eff_name -> - fun m_sig_ts -> - fun n_sig_ts -> - fun p_sig_ts -> - fun m_repr_ts -> - fun n_repr_ts -> - fun p_repr_ts -> - fun bind_us -> - fun k -> - fun num_effect_params -> - fun has_range_binders -> - let debug s = - let uu___ = - (FStar_Compiler_Debug.medium ()) || - (FStar_Compiler_Effect.op_Bang - dbg_LayeredEffectsTc) in - if uu___ - then FStar_Compiler_Util.print1 "%s\n" s - else () in - (let uu___1 = - let uu___2 = - FStar_Compiler_Util.string_of_int - num_effect_params in - FStar_Compiler_Util.format1 - "Checking bind combinator kind with %s effect parameters" - uu___2 in - debug uu___1); - (let uu___1 = bind_us in - match uu___1 with - | u_a::u_b::[] -> - let uu___2 = - let uu___3 = - FStar_Syntax_Util.arrow_formals k in - FStar_Pervasives_Native.fst uu___3 in - (match uu___2 with - | a_b::b_b::rest_bs -> - let uu___3 = - if - num_effect_params = - Prims.int_zero - then - FStar_Pervasives_Native.Some - ([], [], rest_bs) - else - (let uu___5 = - FStar_TypeChecker_Env.inst_tscheme_with - m_sig_ts - [FStar_Syntax_Syntax.U_name - u_a] in - match uu___5 with - | (uu___6, sig1) -> - let sig_bs = - let uu___7 = - let uu___8 = - FStar_Syntax_Util.arrow_formals - sig1 in - FStar_Pervasives_Native.fst - uu___8 in - FStar_Compiler_List.tl - uu___7 in - let uu___7 = - if - (FStar_Compiler_List.length - sig_bs) - < num_effect_params - then - FStar_Pervasives_Native.None - else - (let uu___9 = - let uu___10 = - FStar_Compiler_List.splitAt - num_effect_params - sig_bs in - FStar_Pervasives_Native.fst - uu___10 in - FStar_Pervasives_Native.Some - uu___9) in - op_let_Question uu___7 - (fun sig_eff_params_bs -> - let uu___8 = - if - (FStar_Compiler_List.length - rest_bs) - < - num_effect_params - then - FStar_Pervasives_Native.None - else - (let uu___10 = - FStar_Compiler_List.splitAt - num_effect_params - rest_bs in - FStar_Pervasives_Native.Some - uu___10) in - op_let_Question uu___8 - (fun uu___9 -> - match uu___9 with - | (eff_params_bs, - rest_bs1) -> - let uu___10 = - eq_binders - env - sig_eff_params_bs - eff_params_bs in - op_let_Question - uu___10 - (fun - eff_params_bs_kinds - -> - FStar_Pervasives_Native.Some - (eff_params_bs, - eff_params_bs_kinds, - rest_bs1))))) in - op_let_Question uu___3 - (fun uu___4 -> - match uu___4 with - | (eff_params_bs, - eff_params_bs_kinds, - rest_bs1) -> - let uu___5 = - let f_sig_bs = - let uu___6 = - FStar_TypeChecker_Env.inst_tscheme_with - m_sig_ts - [FStar_Syntax_Syntax.U_name - u_a] in - match uu___6 with - | (uu___7, sig1) -> - let uu___8 = - let uu___9 = - FStar_Syntax_Util.arrow_formals - sig1 in - FStar_Pervasives_Native.fst - uu___9 in - (match uu___8 with - | a::bs -> - let uu___9 = - FStar_Compiler_List.splitAt - num_effect_params - bs in - (match uu___9 - with - | (sig_bs, - bs1) -> - let ss = - let uu___10 - = - let uu___11 - = - let uu___12 - = - let uu___13 - = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - ((a.FStar_Syntax_Syntax.binder_bv), - uu___13) in - FStar_Syntax_Syntax.NT - uu___12 in - [uu___11] in - FStar_Compiler_List.fold_left2 - (fun ss1 - -> - fun sig_b - -> - fun b -> - let uu___11 - = - let uu___12 - = - let uu___13 - = - let uu___14 - = - FStar_Syntax_Syntax.bv_to_name - b.FStar_Syntax_Syntax.binder_bv in - ((sig_b.FStar_Syntax_Syntax.binder_bv), - uu___14) in - FStar_Syntax_Syntax.NT - uu___13 in - [uu___12] in - FStar_Compiler_List.op_At - ss1 - uu___11) - uu___10 - sig_bs - eff_params_bs in - FStar_Syntax_Subst.subst_binders - ss bs1)) in - let uu___6 = - if - (FStar_Compiler_List.length - rest_bs1) - < - (FStar_Compiler_List.length - f_sig_bs) - then - FStar_Pervasives_Native.None - else - (let uu___8 = - FStar_Compiler_List.splitAt - (FStar_Compiler_List.length - f_sig_bs) - rest_bs1 in - FStar_Pervasives_Native.Some - uu___8) in - op_let_Question uu___6 - (fun uu___7 -> - match uu___7 with - | (f_bs, rest_bs2) -> - let uu___8 = - eq_binders env - f_sig_bs f_bs in - op_let_Question - uu___8 - (fun f_bs_kinds - -> - FStar_Pervasives_Native.Some - (f_bs, - f_bs_kinds, - rest_bs2))) in - op_let_Question uu___5 - (fun uu___6 -> - match uu___6 with - | (f_bs, f_bs_kinds, - rest_bs2) -> - let uu___7 = - let g_sig_bs = - let uu___8 = - FStar_TypeChecker_Env.inst_tscheme_with - n_sig_ts - [FStar_Syntax_Syntax.U_name - u_b] in - match uu___8 - with - | (uu___9, - sig1) -> - let uu___10 - = - let uu___11 - = - FStar_Syntax_Util.arrow_formals - sig1 in - FStar_Pervasives_Native.fst - uu___11 in - (match uu___10 - with - | - b::bs -> - let uu___11 - = - FStar_Compiler_List.splitAt - num_effect_params - bs in - (match uu___11 - with - | - (sig_bs, - bs1) -> - let ss = - let uu___12 - = - let uu___13 - = - let uu___14 - = - let uu___15 - = - FStar_Syntax_Syntax.bv_to_name - b_b.FStar_Syntax_Syntax.binder_bv in - ((b.FStar_Syntax_Syntax.binder_bv), - uu___15) in - FStar_Syntax_Syntax.NT - uu___14 in - [uu___13] in - FStar_Compiler_List.fold_left2 - (fun ss1 - -> - fun sig_b - -> - fun b1 -> - let uu___13 - = - let uu___14 - = - let uu___15 - = - let uu___16 - = - FStar_Syntax_Syntax.bv_to_name - b1.FStar_Syntax_Syntax.binder_bv in - ((sig_b.FStar_Syntax_Syntax.binder_bv), - uu___16) in - FStar_Syntax_Syntax.NT - uu___15 in - [uu___14] in - FStar_Compiler_List.op_At - ss1 - uu___13) - uu___12 - sig_bs - eff_params_bs in - FStar_Syntax_Subst.subst_binders - ss bs1)) in - let uu___8 = - if - (FStar_Compiler_List.length - rest_bs2) - < - (FStar_Compiler_List.length - g_sig_bs) - then - FStar_Pervasives_Native.None - else - (let uu___10 - = - FStar_Compiler_List.splitAt - (FStar_Compiler_List.length - g_sig_bs) - rest_bs2 in - FStar_Pervasives_Native.Some - uu___10) in - op_let_Question - uu___8 - (fun uu___9 -> - match uu___9 - with - | (g_bs, - rest_bs3) - -> - let uu___10 - = - let uu___11 - = - FStar_Compiler_List.fold_left2 - (fun - uu___12 - -> - fun - g_sig_b - -> - fun g_b - -> - match uu___12 - with - | - (l, ss) - -> - let g_sig_b_sort - = - FStar_Syntax_Subst.subst - ss - (g_sig_b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - let g_sig_b_arrow_t - = - let x_bv - = - let uu___13 - = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - FStar_Syntax_Syntax.gen_bv - "x" - FStar_Pervasives_Native.None - uu___13 in - let ss1 = - let uu___13 - = - FStar_Compiler_List.map - (fun - uu___14 - -> - match uu___14 - with - | - (bv, k1) - -> - if - k1 = - FStar_Syntax_Syntax.Substitutive_binder - then - let uu___15 - = - let uu___16 - = - let uu___17 - = - let uu___18 - = - FStar_Syntax_Syntax.bv_to_name - bv in - let uu___19 - = - let uu___20 - = - let uu___21 - = - FStar_Syntax_Syntax.bv_to_name - x_bv in - FStar_Syntax_Syntax.as_arg - uu___21 in - [uu___20] in - FStar_Syntax_Syntax.mk_Tm_app - uu___18 - uu___19 - FStar_Compiler_Range_Type.dummyRange in - (bv, - uu___17) in - FStar_Syntax_Syntax.NT - uu___16 in - [uu___15] - else []) - l in - FStar_Compiler_List.flatten - uu___13 in - let g_sig_b_sort1 - = - FStar_Syntax_Subst.subst - ss1 - g_sig_b_sort in - let uu___13 - = - let uu___14 - = - FStar_Syntax_Syntax.mk_binder - x_bv in - [uu___14] in - let uu___14 - = - FStar_Syntax_Syntax.mk_Total - g_sig_b_sort1 in - FStar_Syntax_Util.arrow - uu___13 - uu___14 in - let g_b_kind - = - let uu___13 - = - let uu___14 - = - FStar_TypeChecker_TermEqAndSimplify.eq_tm - env - g_sig_b_arrow_t - (g_b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - uu___14 = - FStar_TypeChecker_TermEqAndSimplify.Equal in - if - uu___13 - then - FStar_Syntax_Syntax.Substitutive_binder - else - (let uu___15 - = - let uu___16 - = - FStar_TypeChecker_TermEqAndSimplify.eq_tm - env - g_sig_b_sort - (g_b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - uu___16 = - FStar_TypeChecker_TermEqAndSimplify.Equal in - if - uu___15 - then - FStar_Syntax_Syntax.BindCont_no_abstraction_binder - else - FStar_Syntax_Syntax.Ad_hoc_binder) in - let ss1 = - let uu___13 - = - let uu___14 - = - let uu___15 - = - let uu___16 - = - FStar_Syntax_Syntax.bv_to_name - g_b.FStar_Syntax_Syntax.binder_bv in - ((g_sig_b.FStar_Syntax_Syntax.binder_bv), - uu___16) in - FStar_Syntax_Syntax.NT - uu___15 in - [uu___14] in - FStar_Compiler_List.op_At - ss - uu___13 in - ((FStar_Compiler_List.op_At - l - [ - ((g_b.FStar_Syntax_Syntax.binder_bv), - g_b_kind)]), - ss1)) - ([], []) - g_sig_bs - g_bs in - match uu___11 - with - | - (g_bs_kinds, - uu___12) - -> - let g_bs_kinds1 - = - FStar_Compiler_List.map - FStar_Pervasives_Native.snd - g_bs_kinds in - if - FStar_Compiler_List.contains - FStar_Syntax_Syntax.Ad_hoc_binder - g_bs_kinds1 - then - FStar_Pervasives_Native.None - else - FStar_Pervasives_Native.Some - g_bs_kinds1 in - op_let_Question - uu___10 - (fun - g_bs_kinds - -> - FStar_Pervasives_Native.Some - (g_bs, - g_bs_kinds, - rest_bs3))) in - op_let_Question - uu___7 - (fun uu___8 -> - match uu___8 - with - | (g_bs, - g_bs_kinds, - rest_bs3) - -> - let uu___9 - = - if - has_range_binders - then - FStar_Compiler_List.splitAt - (Prims.of_int (2)) - rest_bs3 - else - ([], - rest_bs3) in - (match uu___9 - with - | - (range_bs, - rest_bs4) - -> - let uu___10 - = uu___9 in - let uu___11 - = - if - (FStar_Compiler_List.length - rest_bs4) - >= - (Prims.of_int (2)) - then - let uu___12 - = - FStar_Compiler_List.splitAt - ((FStar_Compiler_List.length - rest_bs4) - - - (Prims.of_int (2))) - rest_bs4 in - match uu___12 - with - | - (rest_bs5, - f_b::g_b::[]) - -> - FStar_Pervasives_Native.Some - (rest_bs5, - f_b, g_b) - else - FStar_Pervasives_Native.None in - op_let_Question - uu___11 - (fun - uu___12 - -> - match uu___12 - with - | - (rest_bs5, - f_b, g_b) - -> - let uu___13 - = - let repr_app_bs - = - FStar_Compiler_List.op_At - eff_params_bs - f_bs in - let expected_f_b_sort - = - match m_repr_ts - with - | - FStar_Pervasives_Native.Some - repr_ts - -> - let uu___14 - = - FStar_TypeChecker_Env.inst_tscheme_with - repr_ts - [ - FStar_Syntax_Syntax.U_name - u_a] in - (match uu___14 - with - | - (uu___15, - t) -> - let uu___16 - = - let uu___17 - = - let uu___18 - = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - FStar_Syntax_Syntax.as_arg - uu___18 in - let uu___18 - = - FStar_Compiler_List.map - (fun - uu___19 - -> - match uu___19 - with - | - { - FStar_Syntax_Syntax.binder_bv - = b; - FStar_Syntax_Syntax.binder_qual - = uu___20; - FStar_Syntax_Syntax.binder_positivity - = uu___21; - FStar_Syntax_Syntax.binder_attrs - = uu___22;_} - -> - let uu___23 - = - FStar_Syntax_Syntax.bv_to_name - b in - FStar_Syntax_Syntax.as_arg - uu___23) - repr_app_bs in - uu___17 - :: - uu___18 in - FStar_Syntax_Syntax.mk_Tm_app - t uu___16 - FStar_Compiler_Range_Type.dummyRange) - | - FStar_Pervasives_Native.None - -> - let uu___14 - = - let uu___15 - = - FStar_Syntax_Syntax.null_binder - FStar_Syntax_Syntax.t_unit in - [uu___15] in - let uu___15 - = - let uu___16 - = - let uu___17 - = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - let uu___18 - = - FStar_Compiler_List.map - (fun b -> - let uu___19 - = - FStar_Syntax_Syntax.bv_to_name - b.FStar_Syntax_Syntax.binder_bv in - FStar_Syntax_Syntax.as_arg - uu___19) - repr_app_bs in - { - FStar_Syntax_Syntax.comp_univs - = - [ - FStar_Syntax_Syntax.U_name - u_a]; - FStar_Syntax_Syntax.effect_name - = - m_eff_name; - FStar_Syntax_Syntax.result_typ - = uu___17; - FStar_Syntax_Syntax.effect_args - = uu___18; - FStar_Syntax_Syntax.flags - = [] - } in - FStar_Syntax_Syntax.mk_Comp - uu___16 in - FStar_Syntax_Util.arrow - uu___14 - uu___15 in - let uu___14 - = - let uu___15 - = - FStar_TypeChecker_TermEqAndSimplify.eq_tm - env - (f_b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort - expected_f_b_sort in - uu___15 = - FStar_TypeChecker_TermEqAndSimplify.Equal in - if - uu___14 - then - FStar_Pervasives_Native.Some - () - else - FStar_Pervasives_Native.None in - op_let_Question - uu___13 - (fun - _f_b_ok_ - -> - let uu___14 - = - let expected_g_b_sort - = - let x_bv - = - let uu___15 - = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - FStar_Syntax_Syntax.gen_bv - "x" - FStar_Pervasives_Native.None - uu___15 in - let eff_params_args - = - FStar_Compiler_List.map - (fun - uu___15 - -> - match uu___15 - with - | - { - FStar_Syntax_Syntax.binder_bv - = b; - FStar_Syntax_Syntax.binder_qual - = uu___16; - FStar_Syntax_Syntax.binder_positivity - = uu___17; - FStar_Syntax_Syntax.binder_attrs - = uu___18;_} - -> - let uu___19 - = - FStar_Syntax_Syntax.bv_to_name - b in - FStar_Syntax_Syntax.as_arg - uu___19) - eff_params_bs in - let g_bs_args - = - let uu___15 - = - FStar_Compiler_List.map2 - (fun - uu___16 - -> - fun kind - -> - match uu___16 - with - | - { - FStar_Syntax_Syntax.binder_bv - = b; - FStar_Syntax_Syntax.binder_qual - = uu___17; - FStar_Syntax_Syntax.binder_positivity - = uu___18; - FStar_Syntax_Syntax.binder_attrs - = uu___19;_} - -> - if - kind = - FStar_Syntax_Syntax.Substitutive_binder - then - let uu___20 - = - FStar_Syntax_Syntax.bv_to_name - b in - let uu___21 - = - let uu___22 - = - let uu___23 - = - FStar_Syntax_Syntax.bv_to_name - x_bv in - FStar_Syntax_Syntax.as_arg - uu___23 in - [uu___22] in - FStar_Syntax_Syntax.mk_Tm_app - uu___20 - uu___21 - FStar_Compiler_Range_Type.dummyRange - else - FStar_Syntax_Syntax.bv_to_name - b) g_bs - g_bs_kinds in - FStar_Compiler_List.map - FStar_Syntax_Syntax.as_arg - uu___15 in - let repr_args - = - FStar_Compiler_List.op_At - eff_params_args - g_bs_args in - match n_repr_ts - with - | - FStar_Pervasives_Native.Some - repr_ts - -> - let uu___15 - = - FStar_TypeChecker_Env.inst_tscheme_with - repr_ts - [ - FStar_Syntax_Syntax.U_name - u_b] in - (match uu___15 - with - | - (uu___16, - repr_hd) - -> - let repr_app - = - let uu___17 - = - let uu___18 - = - let uu___19 - = - FStar_Syntax_Syntax.bv_to_name - b_b.FStar_Syntax_Syntax.binder_bv in - FStar_Syntax_Syntax.as_arg - uu___19 in - uu___18 - :: - repr_args in - FStar_Syntax_Syntax.mk_Tm_app - repr_hd - uu___17 - FStar_Compiler_Range_Type.dummyRange in - let uu___17 - = - let uu___18 - = - FStar_Syntax_Syntax.mk_binder - x_bv in - [uu___18] in - let uu___18 - = - FStar_Syntax_Syntax.mk_Total - repr_app in - FStar_Syntax_Util.arrow - uu___17 - uu___18) - | - FStar_Pervasives_Native.None - -> - let thunk_t - = - let uu___15 - = - let uu___16 - = - FStar_Syntax_Syntax.null_binder - FStar_Syntax_Syntax.t_unit in - [uu___16] in - let uu___16 - = - let uu___17 - = - let uu___18 - = - FStar_Syntax_Syntax.bv_to_name - b_b.FStar_Syntax_Syntax.binder_bv in - { - FStar_Syntax_Syntax.comp_univs - = - [ - FStar_Syntax_Syntax.U_name - u_b]; - FStar_Syntax_Syntax.effect_name - = - n_eff_name; - FStar_Syntax_Syntax.result_typ - = uu___18; - FStar_Syntax_Syntax.effect_args - = - repr_args; - FStar_Syntax_Syntax.flags - = [] - } in - FStar_Syntax_Syntax.mk_Comp - uu___17 in - FStar_Syntax_Util.arrow - uu___15 - uu___16 in - let uu___15 - = - let uu___16 - = - FStar_Syntax_Syntax.mk_binder - x_bv in - [uu___16] in - let uu___16 - = - FStar_Syntax_Syntax.mk_Total - thunk_t in - FStar_Syntax_Util.arrow - uu___15 - uu___16 in - let uu___15 - = - let uu___16 - = - FStar_TypeChecker_TermEqAndSimplify.eq_tm - env - (g_b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort - expected_g_b_sort in - uu___16 = - FStar_TypeChecker_TermEqAndSimplify.Equal in - if - uu___15 - then - FStar_Pervasives_Native.Some - () - else - FStar_Pervasives_Native.None in - op_let_Question - uu___14 - (fun - _g_b_ok - -> - let range_kinds - = - FStar_Compiler_List.map - (fun - uu___15 - -> - FStar_Syntax_Syntax.Range_binder) - range_bs in - let rest_kinds - = - FStar_Compiler_List.map - (fun - uu___15 - -> - FStar_Syntax_Syntax.Ad_hoc_binder) - rest_bs5 in - FStar_Pervasives_Native.Some - (FStar_Compiler_List.op_At - [FStar_Syntax_Syntax.Type_binder; - FStar_Syntax_Syntax.Type_binder] - (FStar_Compiler_List.op_At - eff_params_bs_kinds - (FStar_Compiler_List.op_At - f_bs_kinds - (FStar_Compiler_List.op_At - g_bs_kinds - (FStar_Compiler_List.op_At - range_kinds - (FStar_Compiler_List.op_At - rest_kinds - [FStar_Syntax_Syntax.Repr_binder; - FStar_Syntax_Syntax.Repr_binder]))))))))))))))) -let (validate_indexed_effect_bind_shape : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident -> - FStar_Ident.lident -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.tscheme -> - FStar_Syntax_Syntax.tscheme -> - FStar_Syntax_Syntax.tscheme -> - FStar_Syntax_Syntax.tscheme FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.tscheme FStar_Pervasives_Native.option - -> - FStar_Syntax_Syntax.tscheme - FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.univ_names -> - FStar_Syntax_Syntax.typ -> - FStar_Compiler_Range_Type.range -> - Prims.int -> - Prims.bool -> - (FStar_Syntax_Syntax.typ * - FStar_Syntax_Syntax.indexed_effect_combinator_kind)) - = - fun env -> - fun m_eff_name -> - fun n_eff_name -> - fun p_eff_name -> - fun m_sig_ts -> - fun n_sig_ts -> - fun p_sig_ts -> - fun m_repr_ts -> - fun n_repr_ts -> - fun p_repr_ts -> - fun bind_us -> - fun bind_t -> - fun r -> - fun num_effect_params -> - fun has_range_binders -> - let bind_name = - let uu___ = - FStar_Ident.string_of_lid m_eff_name in - let uu___1 = - FStar_Ident.string_of_lid n_eff_name in - let uu___2 = - FStar_Ident.string_of_lid p_eff_name in - FStar_Compiler_Util.format3 - "(%s , %s) |> %s" uu___ uu___1 uu___2 in - let uu___ = bind_us in - match uu___ with - | u_a::u_b::[] -> - let a_b = - let uu___1 = - let uu___2 = - FStar_Syntax_Util.type_with_u - (FStar_Syntax_Syntax.U_name u_a) in - FStar_Syntax_Syntax.gen_bv "a" - FStar_Pervasives_Native.None uu___2 in - FStar_Syntax_Syntax.mk_binder uu___1 in - let b_b = - let uu___1 = - let uu___2 = - FStar_Syntax_Util.type_with_u - (FStar_Syntax_Syntax.U_name u_b) in - FStar_Syntax_Syntax.gen_bv "b" - FStar_Pervasives_Native.None uu___2 in - FStar_Syntax_Syntax.mk_binder uu___1 in - let rest_bs = - let uu___1 = - let uu___2 = - FStar_Syntax_Subst.compress bind_t in - uu___2.FStar_Syntax_Syntax.n in - match uu___1 with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; - FStar_Syntax_Syntax.comp = uu___2;_} - when - (FStar_Compiler_List.length bs) >= - (Prims.of_int (4)) - -> - let uu___3 = - FStar_Syntax_Subst.open_binders - bs in - (match uu___3 with - | { - FStar_Syntax_Syntax.binder_bv - = a; - FStar_Syntax_Syntax.binder_qual - = uu___4; - FStar_Syntax_Syntax.binder_positivity - = uu___5; - FStar_Syntax_Syntax.binder_attrs - = uu___6;_}::{ - FStar_Syntax_Syntax.binder_bv - = b; - FStar_Syntax_Syntax.binder_qual - = uu___7; - FStar_Syntax_Syntax.binder_positivity - = uu___8; - FStar_Syntax_Syntax.binder_attrs - = uu___9;_}::bs1 - -> - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - (a, uu___13) in - FStar_Syntax_Syntax.NT - uu___12 in - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - FStar_Syntax_Syntax.bv_to_name - b_b.FStar_Syntax_Syntax.binder_bv in - (b, uu___15) in - FStar_Syntax_Syntax.NT - uu___14 in - [uu___13] in - uu___11 :: uu___12 in - let uu___11 = - let uu___12 = - FStar_Compiler_List.splitAt - ((FStar_Compiler_List.length - bs1) - - (Prims.of_int (2))) - bs1 in - FStar_Pervasives_Native.fst - uu___12 in - FStar_Syntax_Subst.subst_binders - uu___10 uu___11) - | uu___2 -> - let uu___3 = - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - bind_t in - FStar_Compiler_Util.format2 - "Type of %s is not an arrow with >= 4 binders (%s)" - bind_name uu___4 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - r - FStar_Errors_Codes.Fatal_UnexpectedEffect - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___3) in - let uu___1 = - if has_range_binders - then - (if - (FStar_Compiler_List.length - rest_bs) - >= (Prims.of_int (2)) - then - FStar_Compiler_List.splitAt - ((FStar_Compiler_List.length - rest_bs) - - (Prims.of_int (2))) rest_bs - else - (let uu___3 = - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - bind_t in - FStar_Compiler_Util.format2 - "Type of %s is not an arrow with >= 6 binders (%s)" - bind_name uu___4 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - r - FStar_Errors_Codes.Fatal_UnexpectedEffect - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___3))) - else (rest_bs, []) in - (match uu___1 with - | (rest_bs1, range_bs) -> - let uu___2 = - let uu___3 = - let uu___4 = - FStar_TypeChecker_Env.push_binders - env (a_b :: b_b :: rest_bs1) in - let uu___5 = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - FStar_TypeChecker_Util.fresh_effect_repr - uu___4 r m_eff_name m_sig_ts - m_repr_ts - (FStar_Syntax_Syntax.U_name - u_a) uu___5 in - match uu___3 with - | (repr, g) -> - let uu___4 = - let uu___5 = - FStar_Syntax_Syntax.gen_bv - "f" - FStar_Pervasives_Native.None - repr in - FStar_Syntax_Syntax.mk_binder - uu___5 in - (uu___4, g) in - (match uu___2 with - | (f, guard_f) -> - let uu___3 = - let x_a = - let uu___4 = - let uu___5 = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - FStar_Syntax_Syntax.gen_bv - "x" - FStar_Pervasives_Native.None - uu___5 in - FStar_Syntax_Syntax.mk_binder - uu___4 in - let uu___4 = - let uu___5 = - FStar_TypeChecker_Env.push_binders - env - (FStar_Compiler_List.op_At - (a_b :: b_b :: - rest_bs1) [x_a]) in - let uu___6 = - FStar_Syntax_Syntax.bv_to_name - b_b.FStar_Syntax_Syntax.binder_bv in - FStar_TypeChecker_Util.fresh_effect_repr - uu___5 r n_eff_name - n_sig_ts n_repr_ts - (FStar_Syntax_Syntax.U_name - u_b) uu___6 in - match uu___4 with - | (repr, g) -> - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Syntax_Syntax.mk_Total - repr in - FStar_Syntax_Util.arrow - [x_a] uu___8 in - FStar_Syntax_Syntax.gen_bv - "g" - FStar_Pervasives_Native.None - uu___7 in - FStar_Syntax_Syntax.mk_binder - uu___6 in - (uu___5, g) in - (match uu___3 with - | (g, guard_g) -> - let uu___4 = - let uu___5 = - FStar_TypeChecker_Env.push_binders - env (a_b :: b_b :: - rest_bs1) in - let uu___6 = - FStar_Syntax_Syntax.bv_to_name - b_b.FStar_Syntax_Syntax.binder_bv in - FStar_TypeChecker_Util.fresh_effect_repr - uu___5 r p_eff_name - p_sig_ts p_repr_ts - (FStar_Syntax_Syntax.U_name - u_b) uu___6 in - (match uu___4 with - | (return_repr, - guard_return_repr) -> - let uu___5 = - let uu___6 = - FStar_TypeChecker_Env.push_binders - env (a_b :: b_b - :: rest_bs1) in - let uu___7 = - FStar_Compiler_Util.format1 - "implicit for pure_wp in checking bind %s" - bind_name in - pure_wp_uvar uu___6 - return_repr - uu___7 r in - (match uu___5 with - | (pure_wp_uvar1, - g_pure_wp_uvar) - -> - let k = - let uu___6 = - let uu___7 = - let uu___8 - = - let uu___9 - = - FStar_TypeChecker_Env.new_u_univ - () in - [uu___9] in - let uu___9 - = - let uu___10 - = - FStar_Syntax_Syntax.as_arg - pure_wp_uvar1 in - [uu___10] in - { - FStar_Syntax_Syntax.comp_univs - = uu___8; - FStar_Syntax_Syntax.effect_name - = - FStar_Parser_Const.effect_PURE_lid; - FStar_Syntax_Syntax.result_typ - = - return_repr; - FStar_Syntax_Syntax.effect_args - = uu___9; - FStar_Syntax_Syntax.flags - = [] - } in - FStar_Syntax_Syntax.mk_Comp - uu___7 in - FStar_Syntax_Util.arrow - (a_b :: b_b - :: - (FStar_Compiler_List.op_At - rest_bs1 - ( - FStar_Compiler_List.op_At - range_bs - [f; g]))) - uu___6 in - let guard_eq = - let uu___6 = - FStar_TypeChecker_Rel.teq_nosmt - env k - bind_t in - match uu___6 - with - | FStar_Pervasives_Native.None - -> - let uu___7 - = - let uu___8 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - bind_t in - FStar_Compiler_Util.format2 - "Unexpected type of %s (%s)\n" - bind_name - uu___8 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - r - FStar_Errors_Codes.Fatal_UnexpectedEffect - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - uu___7) - | FStar_Pervasives_Native.Some - g1 -> g1 in - ((let uu___7 = - FStar_TypeChecker_Env.conj_guards - [guard_f; - guard_g; - guard_return_repr; - g_pure_wp_uvar; - guard_eq] in - FStar_TypeChecker_Rel.force_trivial_guard - env uu___7); - (let k1 = - let uu___7 = - FStar_TypeChecker_Normalize.remove_uvar_solutions - env k in - FStar_Syntax_Subst.compress - uu___7 in - let lopt = - bind_combinator_kind - env - m_eff_name - n_eff_name - p_eff_name - m_sig_ts - n_sig_ts - p_sig_ts - m_repr_ts - n_repr_ts - p_repr_ts - bind_us k1 - num_effect_params - has_range_binders in - let kind = - match lopt - with - | FStar_Pervasives_Native.None - -> - (log_ad_hoc_combinator_warning - bind_name - r; - FStar_Syntax_Syntax.Ad_hoc_combinator) - | FStar_Pervasives_Native.Some - l -> - FStar_Syntax_Syntax.Substitutive_combinator - l in - (let uu___8 = - (FStar_Compiler_Debug.medium - ()) || - ( - FStar_Compiler_Effect.op_Bang - dbg_LayeredEffectsTc) in - if uu___8 - then - let uu___9 - = - FStar_Class_Show.show - FStar_Syntax_Syntax.showable_indexed_effect_combinator_kind - kind in - FStar_Compiler_Util.print2 - "Bind %s has %s kind\n" - bind_name - uu___9 - else ()); - (k1, kind)))))))) -let (subcomp_combinator_kind : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.tscheme -> - FStar_Syntax_Syntax.tscheme -> - FStar_Syntax_Syntax.tscheme FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.tscheme FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.univ_name -> - FStar_Syntax_Syntax.typ -> - Prims.int -> - FStar_Syntax_Syntax.indexed_effect_combinator_kind - FStar_Pervasives_Native.option) - = - fun env -> - fun m_eff_name -> - fun n_eff_name -> - fun m_sig_ts -> - fun n_sig_ts -> - fun m_repr_ts -> - fun n_repr_ts -> - fun u -> - fun k -> - fun num_effect_params -> - let uu___ = FStar_Syntax_Util.arrow_formals_comp k in - match uu___ with - | (a_b::rest_bs, k_c) -> - let uu___1 = - if num_effect_params = Prims.int_zero - then - FStar_Pervasives_Native.Some ([], [], rest_bs) - else - (let uu___3 = - FStar_TypeChecker_Env.inst_tscheme_with - m_sig_ts [FStar_Syntax_Syntax.U_name u] in - match uu___3 with - | (uu___4, sig1) -> - let uu___5 = - FStar_Syntax_Util.arrow_formals sig1 in - (match uu___5 with - | (uu___6::sig_bs, uu___7) -> - let sig_effect_params_bs = - let uu___8 = - FStar_Compiler_List.splitAt - num_effect_params sig_bs in - FStar_Pervasives_Native.fst uu___8 in - let uu___8 = - FStar_Compiler_List.splitAt - num_effect_params rest_bs in - (match uu___8 with - | (eff_params_bs, rest_bs1) -> - let uu___9 = - eq_binders env - sig_effect_params_bs - eff_params_bs in - op_let_Question uu___9 - (fun eff_params_bs_kinds -> - FStar_Pervasives_Native.Some - (eff_params_bs, - eff_params_bs_kinds, - rest_bs1))))) in - op_let_Question uu___1 - (fun uu___2 -> - match uu___2 with - | (eff_params_bs, eff_params_bs_kinds, - rest_bs1) -> - let uu___3 = - let f_sig_bs = - let uu___4 = - FStar_TypeChecker_Env.inst_tscheme_with - m_sig_ts - [FStar_Syntax_Syntax.U_name u] in - match uu___4 with - | (uu___5, sig1) -> - let uu___6 = - let uu___7 = - FStar_Syntax_Util.arrow_formals - sig1 in - FStar_Pervasives_Native.fst - uu___7 in - (match uu___6 with - | a::bs -> - let uu___7 = - FStar_Compiler_List.splitAt - num_effect_params bs in - (match uu___7 with - | (sig_bs, bs1) -> - let ss = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - ((a.FStar_Syntax_Syntax.binder_bv), - uu___11) in - FStar_Syntax_Syntax.NT - uu___10 in - [uu___9] in - FStar_Compiler_List.fold_left2 - (fun ss1 -> - fun sig_b -> - fun b -> - let uu___9 = - let uu___10 - = - let uu___11 - = - let uu___12 - = - FStar_Syntax_Syntax.bv_to_name - b.FStar_Syntax_Syntax.binder_bv in - ((sig_b.FStar_Syntax_Syntax.binder_bv), - uu___12) in - FStar_Syntax_Syntax.NT - uu___11 in - [uu___10] in - FStar_Compiler_List.op_At - ss1 uu___9) - uu___8 sig_bs - eff_params_bs in - FStar_Syntax_Subst.subst_binders - ss bs1)) in - let uu___4 = - if - (FStar_Compiler_List.length rest_bs1) - < - (FStar_Compiler_List.length - f_sig_bs) - then FStar_Pervasives_Native.None - else - (let uu___6 = - FStar_Compiler_List.splitAt - (FStar_Compiler_List.length - f_sig_bs) rest_bs1 in - FStar_Pervasives_Native.Some uu___6) in - op_let_Question uu___4 - (fun uu___5 -> - match uu___5 with - | (f_bs, rest_bs2) -> - let uu___6 = - eq_binders env f_sig_bs f_bs in - op_let_Question uu___6 - (fun f_bs_kinds -> - FStar_Pervasives_Native.Some - (f_bs, f_bs_kinds, - rest_bs2))) in - op_let_Question uu___3 - (fun uu___4 -> - match uu___4 with - | (f_bs, f_bs_kinds, rest_bs2) -> - let uu___5 = - if - (FStar_Compiler_List.length - rest_bs2) - >= Prims.int_one - then - let uu___6 = - FStar_Compiler_List.splitAt - ((FStar_Compiler_List.length - rest_bs2) - - Prims.int_one) - rest_bs2 in - match uu___6 with - | (rest_bs3, f_b::[]) -> - FStar_Pervasives_Native.Some - (rest_bs3, f_b) - else - FStar_Pervasives_Native.None in - op_let_Question uu___5 - (fun uu___6 -> - match uu___6 with - | (rest_bs3, f_b) -> - let uu___7 = - let expected_f_b_sort - = - match m_repr_ts with - | FStar_Pervasives_Native.Some - repr_ts -> - let uu___8 = - FStar_TypeChecker_Env.inst_tscheme_with - repr_ts - [FStar_Syntax_Syntax.U_name - u] in - (match uu___8 - with - | (uu___9, t) - -> - let uu___10 - = - let uu___11 - = - let uu___12 - = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - FStar_Syntax_Syntax.as_arg - uu___12 in - let uu___12 - = - FStar_Compiler_List.map - (fun - uu___13 - -> - match uu___13 - with - | - { - FStar_Syntax_Syntax.binder_bv - = b; - FStar_Syntax_Syntax.binder_qual - = uu___14; - FStar_Syntax_Syntax.binder_positivity - = uu___15; - FStar_Syntax_Syntax.binder_attrs - = uu___16;_} - -> - let uu___17 - = - FStar_Syntax_Syntax.bv_to_name - b in - FStar_Syntax_Syntax.as_arg - uu___17) - (FStar_Compiler_List.op_At - eff_params_bs - f_bs) in - uu___11 - :: - uu___12 in - FStar_Syntax_Syntax.mk_Tm_app - t uu___10 - FStar_Compiler_Range_Type.dummyRange) - | FStar_Pervasives_Native.None - -> - let uu___8 = - let uu___9 = - FStar_Syntax_Syntax.null_binder - FStar_Syntax_Syntax.t_unit in - [uu___9] in - let uu___9 = - let uu___10 = - let uu___11 - = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - let uu___12 - = - FStar_Compiler_List.map - (fun b -> - let uu___13 - = - FStar_Syntax_Syntax.bv_to_name - b.FStar_Syntax_Syntax.binder_bv in - FStar_Syntax_Syntax.as_arg - uu___13) - (FStar_Compiler_List.op_At - eff_params_bs - f_bs) in - { - FStar_Syntax_Syntax.comp_univs - = - [ - FStar_Syntax_Syntax.U_name - u]; - FStar_Syntax_Syntax.effect_name - = - m_eff_name; - FStar_Syntax_Syntax.result_typ - = uu___11; - FStar_Syntax_Syntax.effect_args - = uu___12; - FStar_Syntax_Syntax.flags - = [] - } in - FStar_Syntax_Syntax.mk_Comp - uu___10 in - FStar_Syntax_Util.arrow - uu___8 uu___9 in - let uu___8 = - let uu___9 = - FStar_TypeChecker_TermEqAndSimplify.eq_tm - env - (f_b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort - expected_f_b_sort in - uu___9 = - FStar_TypeChecker_TermEqAndSimplify.Equal in - if uu___8 - then - FStar_Pervasives_Native.Some - () - else - FStar_Pervasives_Native.None in - op_let_Question uu___7 - (fun _f_b_ok_ -> - let check_ret_t - f_or_g_bs = - let expected_t = - match n_repr_ts - with - | FStar_Pervasives_Native.Some - repr_ts -> - let uu___8 - = - FStar_TypeChecker_Env.inst_tscheme_with - repr_ts - [ - FStar_Syntax_Syntax.U_name - u] in - (match uu___8 - with - | - (uu___9, - t) -> - let uu___10 - = - let uu___11 - = - let uu___12 - = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - FStar_Syntax_Syntax.as_arg - uu___12 in - let uu___12 - = - FStar_Compiler_List.map - (fun - uu___13 - -> - match uu___13 - with - | - { - FStar_Syntax_Syntax.binder_bv - = b; - FStar_Syntax_Syntax.binder_qual - = uu___14; - FStar_Syntax_Syntax.binder_positivity - = uu___15; - FStar_Syntax_Syntax.binder_attrs - = uu___16;_} - -> - let uu___17 - = - FStar_Syntax_Syntax.bv_to_name - b in - FStar_Syntax_Syntax.as_arg - uu___17) - (FStar_Compiler_List.op_At - eff_params_bs - f_or_g_bs) in - uu___11 - :: - uu___12 in - FStar_Syntax_Syntax.mk_Tm_app - t uu___10 - FStar_Compiler_Range_Type.dummyRange) - | FStar_Pervasives_Native.None - -> - let uu___8 - = - let uu___9 - = - FStar_Syntax_Syntax.null_binder - FStar_Syntax_Syntax.t_unit in - [uu___9] in - let uu___9 - = - let uu___10 - = - let uu___11 - = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - let uu___12 - = - FStar_Compiler_List.map - (fun b -> - let uu___13 - = - FStar_Syntax_Syntax.bv_to_name - b.FStar_Syntax_Syntax.binder_bv in - FStar_Syntax_Syntax.as_arg - uu___13) - (FStar_Compiler_List.op_At - eff_params_bs - f_or_g_bs) in - { - FStar_Syntax_Syntax.comp_univs - = - [ - FStar_Syntax_Syntax.U_name - u]; - FStar_Syntax_Syntax.effect_name - = - n_eff_name; - FStar_Syntax_Syntax.result_typ - = uu___11; - FStar_Syntax_Syntax.effect_args - = uu___12; - FStar_Syntax_Syntax.flags - = [] - } in - FStar_Syntax_Syntax.mk_Comp - uu___10 in - FStar_Syntax_Util.arrow - uu___8 - uu___9 in - let uu___8 = - let uu___9 = - FStar_TypeChecker_TermEqAndSimplify.eq_tm - env - (FStar_Syntax_Util.comp_result - k_c) - expected_t in - uu___9 = - FStar_TypeChecker_TermEqAndSimplify.Equal in - if uu___8 - then - FStar_Pervasives_Native.Some - () - else - FStar_Pervasives_Native.None in - let uu___8 = - let uu___9 = - check_ret_t - f_bs in - FStar_Pervasives_Native.uu___is_Some - uu___9 in - if uu___8 - then - FStar_Pervasives_Native.Some - FStar_Syntax_Syntax.Substitutive_invariant_combinator - else - (let uu___10 = - let g_sig_bs = - let uu___11 - = - FStar_TypeChecker_Env.inst_tscheme_with - n_sig_ts - [ - FStar_Syntax_Syntax.U_name - u] in - match uu___11 - with - | (uu___12, - sig1) -> - let uu___13 - = - let uu___14 - = - FStar_Syntax_Util.arrow_formals - sig1 in - FStar_Pervasives_Native.fst - uu___14 in - (match uu___13 - with - | - a::bs -> - let uu___14 - = - FStar_Compiler_List.splitAt - num_effect_params - bs in - (match uu___14 - with - | - (sig_bs, - bs1) -> - let ss = - let uu___15 - = - let uu___16 - = - let uu___17 - = - let uu___18 - = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - ((a.FStar_Syntax_Syntax.binder_bv), - uu___18) in - FStar_Syntax_Syntax.NT - uu___17 in - [uu___16] in - FStar_Compiler_List.fold_left2 - (fun ss1 - -> - fun sig_b - -> - fun b -> - let uu___16 - = - let uu___17 - = - let uu___18 - = - let uu___19 - = - FStar_Syntax_Syntax.bv_to_name - b.FStar_Syntax_Syntax.binder_bv in - ((sig_b.FStar_Syntax_Syntax.binder_bv), - uu___19) in - FStar_Syntax_Syntax.NT - uu___18 in - [uu___17] in - FStar_Compiler_List.op_At - ss1 - uu___16) - uu___15 - sig_bs - eff_params_bs in - FStar_Syntax_Subst.subst_binders - ss bs1)) in - let uu___11 = - if - (FStar_Compiler_List.length - rest_bs3) - < - (FStar_Compiler_List.length - g_sig_bs) - then - FStar_Pervasives_Native.None - else - (let uu___13 - = - FStar_Compiler_List.splitAt - (FStar_Compiler_List.length - g_sig_bs) - rest_bs3 in - FStar_Pervasives_Native.Some - uu___13) in - op_let_Question - uu___11 - (fun uu___12 - -> - match uu___12 - with - | - (g_bs, - rest_bs4) - -> - let uu___13 - = - eq_binders - env - g_sig_bs - g_bs in - op_let_Question - uu___13 - (fun - g_bs_kinds - -> - FStar_Pervasives_Native.Some - (g_bs, - g_bs_kinds, - rest_bs4))) in - op_let_Question - uu___10 - (fun uu___11 - -> - match uu___11 - with - | (g_bs, - g_bs_kinds, - rest_bs4) - -> - let uu___12 - = - check_ret_t - g_bs in - op_let_Question - uu___12 - (fun - _ret_t_ok_ - -> - let rest_kinds - = - FStar_Compiler_List.map - (fun - uu___13 - -> - FStar_Syntax_Syntax.Ad_hoc_binder) - rest_bs4 in - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Substitutive_combinator - (FStar_Compiler_List.op_At - [FStar_Syntax_Syntax.Type_binder] - (FStar_Compiler_List.op_At - eff_params_bs_kinds - (FStar_Compiler_List.op_At - f_bs_kinds - (FStar_Compiler_List.op_At - g_bs_kinds - (FStar_Compiler_List.op_At - rest_kinds - [FStar_Syntax_Syntax.Repr_binder]))))))))))))) -let (validate_indexed_effect_subcomp_shape : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.tscheme -> - FStar_Syntax_Syntax.tscheme -> - FStar_Syntax_Syntax.tscheme FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.tscheme FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.univ_name -> - FStar_Syntax_Syntax.typ -> - Prims.int -> - FStar_Compiler_Range_Type.range -> - (FStar_Syntax_Syntax.typ * - FStar_Syntax_Syntax.indexed_effect_combinator_kind)) - = - fun env -> - fun m_eff_name -> - fun n_eff_name -> - fun m_sig_ts -> - fun n_sig_ts -> - fun m_repr_ts -> - fun n_repr_ts -> - fun u -> - fun subcomp_t -> - fun num_effect_params -> - fun r -> - let subcomp_name = - let uu___ = FStar_Ident.string_of_lid m_eff_name in - let uu___1 = FStar_Ident.string_of_lid n_eff_name in - FStar_Compiler_Util.format2 "%s <: %s" uu___ uu___1 in - let a_b = - let uu___ = - let uu___1 = - FStar_Syntax_Util.type_with_u - (FStar_Syntax_Syntax.U_name u) in - FStar_Syntax_Syntax.gen_bv "a" - FStar_Pervasives_Native.None uu___1 in - FStar_Syntax_Syntax.mk_binder uu___ in - let rest_bs = - let uu___ = - let uu___1 = - FStar_Syntax_Subst.compress subcomp_t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; - FStar_Syntax_Syntax.comp = uu___1;_} - when - (FStar_Compiler_List.length bs) >= - (Prims.of_int (2)) - -> - let uu___2 = FStar_Syntax_Subst.open_binders bs in - (match uu___2 with - | { FStar_Syntax_Syntax.binder_bv = a; - FStar_Syntax_Syntax.binder_qual = uu___3; - FStar_Syntax_Syntax.binder_positivity = - uu___4; - FStar_Syntax_Syntax.binder_attrs = uu___5;_}::bs1 - -> - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - (a, uu___9) in - FStar_Syntax_Syntax.NT uu___8 in - [uu___7] in - let uu___7 = - let uu___8 = - FStar_Compiler_List.splitAt - ((FStar_Compiler_List.length bs1) - - Prims.int_one) bs1 in - FStar_Pervasives_Native.fst uu___8 in - FStar_Syntax_Subst.subst_binders uu___6 - uu___7) - | uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - subcomp_t in - FStar_Compiler_Util.format2 - "Type of %s is not an arrow with >= 2 binders (%s)" - subcomp_name uu___3 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_UnexpectedEffect () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2) in - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_Env.push_binders env (a_b :: - rest_bs) in - let uu___3 = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - FStar_TypeChecker_Util.fresh_effect_repr uu___2 r - m_eff_name m_sig_ts m_repr_ts - (FStar_Syntax_Syntax.U_name u) uu___3 in - match uu___1 with - | (repr, g) -> - let uu___2 = - let uu___3 = - FStar_Syntax_Syntax.gen_bv "f" - FStar_Pervasives_Native.None repr in - FStar_Syntax_Syntax.mk_binder uu___3 in - (uu___2, g) in - match uu___ with - | (f, guard_f) -> - let uu___1 = - let uu___2 = - FStar_TypeChecker_Env.push_binders env (a_b - :: rest_bs) in - let uu___3 = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - FStar_TypeChecker_Util.fresh_effect_repr uu___2 - r n_eff_name n_sig_ts n_repr_ts - (FStar_Syntax_Syntax.U_name u) uu___3 in - (match uu___1 with - | (ret_t, guard_ret_t) -> - let uu___2 = - let uu___3 = - FStar_TypeChecker_Env.push_binders env - (a_b :: rest_bs) in - let uu___4 = - FStar_Compiler_Util.format1 - "implicit for pure_wp in checking %s" - subcomp_name in - pure_wp_uvar uu___3 ret_t uu___4 r in - (match uu___2 with - | (pure_wp_uvar1, guard_wp) -> - let c = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_TypeChecker_Env.new_u_univ - () in - [uu___5] in - let uu___5 = - let uu___6 = - FStar_Syntax_Syntax.as_arg - pure_wp_uvar1 in - [uu___6] in - { - FStar_Syntax_Syntax.comp_univs = - uu___4; - FStar_Syntax_Syntax.effect_name = - FStar_Parser_Const.effect_PURE_lid; - FStar_Syntax_Syntax.result_typ = - ret_t; - FStar_Syntax_Syntax.effect_args = - uu___5; - FStar_Syntax_Syntax.flags = [] - } in - FStar_Syntax_Syntax.mk_Comp uu___3 in - let k = - FStar_Syntax_Util.arrow - (FStar_Compiler_List.op_At (a_b :: - rest_bs) [f]) c in - ((let uu___4 = - (FStar_Compiler_Debug.medium ()) || - (FStar_Compiler_Effect.op_Bang - dbg_LayeredEffectsTc) in - if uu___4 - then - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - k in - FStar_Compiler_Util.print1 - "Expected type of subcomp before unification: %s\n" - uu___5 - else ()); - (let guard_eq = - let uu___4 = - FStar_TypeChecker_Rel.teq_nosmt - env subcomp_t k in - match uu___4 with - | FStar_Pervasives_Native.None -> - let uu___5 = - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - subcomp_t in - FStar_Compiler_Util.format2 - "Unexpected type of %s (%s)\n" - subcomp_name uu___6 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - r - FStar_Errors_Codes.Fatal_UnexpectedEffect - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___5) - | FStar_Pervasives_Native.Some g -> - g in - (let uu___5 = - FStar_TypeChecker_Env.conj_guards - [guard_f; - guard_ret_t; - guard_wp; - guard_eq] in - FStar_TypeChecker_Rel.force_trivial_guard - env uu___5); - (let k1 = - let uu___5 = - FStar_TypeChecker_Normalize.remove_uvar_solutions - env k in - FStar_Syntax_Subst.compress uu___5 in - let kopt = - subcomp_combinator_kind env - m_eff_name n_eff_name m_sig_ts - n_sig_ts m_repr_ts n_repr_ts u - k1 num_effect_params in - let kind = - match kopt with - | FStar_Pervasives_Native.None -> - (log_ad_hoc_combinator_warning - subcomp_name r; - FStar_Syntax_Syntax.Ad_hoc_combinator) - | FStar_Pervasives_Native.Some k2 - -> k2 in - (let uu___6 = - (FStar_Compiler_Debug.medium ()) - || - (FStar_Compiler_Effect.op_Bang - dbg_LayeredEffectsTc) in - if uu___6 - then - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Syntax.showable_indexed_effect_combinator_kind - kind in - FStar_Compiler_Util.print2 - "Subcomp %s has %s kind\n" - subcomp_name uu___7 - else ()); - (k1, kind)))))) -let (ite_combinator_kind : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.tscheme -> - FStar_Syntax_Syntax.tscheme -> - FStar_Syntax_Syntax.univ_name -> - FStar_Syntax_Syntax.term -> - Prims.int -> - FStar_Syntax_Syntax.indexed_effect_combinator_kind - FStar_Pervasives_Native.option) - = - fun env -> - fun eff_name -> - fun sig_ts -> - fun repr_ts -> - fun u -> - fun tm -> - fun num_effect_params -> - let uu___ = FStar_Syntax_Util.abs_formals tm in - match uu___ with - | (a_b::rest_bs, uu___1, uu___2) -> - let uu___3 = - if num_effect_params = Prims.int_zero - then FStar_Pervasives_Native.Some ([], [], rest_bs) - else - (let uu___5 = - FStar_TypeChecker_Env.inst_tscheme_with sig_ts - [FStar_Syntax_Syntax.U_name u] in - match uu___5 with - | (uu___6, sig1) -> - let uu___7 = - FStar_Syntax_Util.arrow_formals sig1 in - (match uu___7 with - | (uu___8::sig_bs, uu___9) -> - let sig_effect_params_bs = - let uu___10 = - FStar_Compiler_List.splitAt - num_effect_params sig_bs in - FStar_Pervasives_Native.fst uu___10 in - let uu___10 = - FStar_Compiler_List.splitAt - num_effect_params rest_bs in - (match uu___10 with - | (eff_params_bs, rest_bs1) -> - let uu___11 = - eq_binders env sig_effect_params_bs - eff_params_bs in - op_let_Question uu___11 - (fun eff_params_bs_kinds -> - FStar_Pervasives_Native.Some - (eff_params_bs, - eff_params_bs_kinds, - rest_bs1))))) in - op_let_Question uu___3 - (fun uu___4 -> - match uu___4 with - | (eff_params_bs, eff_params_bs_kinds, rest_bs1) -> - let uu___5 = - let f_sig_bs = - let uu___6 = - FStar_TypeChecker_Env.inst_tscheme_with - sig_ts [FStar_Syntax_Syntax.U_name u] in - match uu___6 with - | (uu___7, sig1) -> - let uu___8 = - let uu___9 = - FStar_Syntax_Util.arrow_formals sig1 in - FStar_Pervasives_Native.fst uu___9 in - (match uu___8 with - | a::bs -> - let uu___9 = - FStar_Compiler_List.splitAt - num_effect_params bs in - (match uu___9 with - | (sig_bs, bs1) -> - let ss = - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - ((a.FStar_Syntax_Syntax.binder_bv), - uu___13) in - FStar_Syntax_Syntax.NT - uu___12 in - [uu___11] in - FStar_Compiler_List.fold_left2 - (fun ss1 -> - fun sig_b -> - fun b -> - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - FStar_Syntax_Syntax.bv_to_name - b.FStar_Syntax_Syntax.binder_bv in - ((sig_b.FStar_Syntax_Syntax.binder_bv), - uu___14) in - FStar_Syntax_Syntax.NT - uu___13 in - [uu___12] in - FStar_Compiler_List.op_At - ss1 uu___11) - uu___10 sig_bs - eff_params_bs in - FStar_Syntax_Subst.subst_binders - ss bs1)) in - let uu___6 = - if - (FStar_Compiler_List.length rest_bs1) < - (FStar_Compiler_List.length f_sig_bs) - then FStar_Pervasives_Native.None - else - (let uu___8 = - FStar_Compiler_List.splitAt - (FStar_Compiler_List.length f_sig_bs) - rest_bs1 in - FStar_Pervasives_Native.Some uu___8) in - op_let_Question uu___6 - (fun uu___7 -> - match uu___7 with - | (f_bs, rest_bs2) -> - let uu___8 = - eq_binders env f_sig_bs f_bs in - op_let_Question uu___8 - (fun f_bs_kinds -> - FStar_Pervasives_Native.Some - (f_bs, f_bs_kinds, rest_bs2))) in - op_let_Question uu___5 - (fun uu___6 -> - match uu___6 with - | (f_bs, f_bs_kinds, rest_bs2) -> - let uu___7 = - if - (FStar_Compiler_List.length - rest_bs2) - >= (Prims.of_int (3)) - then - let uu___8 = - FStar_Compiler_List.splitAt - ((FStar_Compiler_List.length - rest_bs2) - - (Prims.of_int (3))) - rest_bs2 in - FStar_Pervasives_Native.Some uu___8 - else FStar_Pervasives_Native.None in - op_let_Question uu___7 - (fun uu___8 -> - match uu___8 with - | (rest_bs3, f_b::g_b::p_b::[]) -> - let uu___9 = - let expected_f_b_sort = - let uu___10 = - FStar_TypeChecker_Env.inst_tscheme_with - repr_ts - [FStar_Syntax_Syntax.U_name - u] in - match uu___10 with - | (uu___11, t) -> - let uu___12 = - let uu___13 = - let uu___14 = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - FStar_Syntax_Syntax.as_arg - uu___14 in - let uu___14 = - FStar_Compiler_List.map - (fun uu___15 -> - match uu___15 - with - | { - FStar_Syntax_Syntax.binder_bv - = b; - FStar_Syntax_Syntax.binder_qual - = uu___16; - FStar_Syntax_Syntax.binder_positivity - = uu___17; - FStar_Syntax_Syntax.binder_attrs - = uu___18;_} - -> - let uu___19 - = - FStar_Syntax_Syntax.bv_to_name - b in - FStar_Syntax_Syntax.as_arg - uu___19) - (FStar_Compiler_List.op_At - eff_params_bs - f_bs) in - uu___13 :: uu___14 in - FStar_Syntax_Syntax.mk_Tm_app - t uu___12 - FStar_Compiler_Range_Type.dummyRange in - let uu___10 = - let uu___11 = - FStar_TypeChecker_TermEqAndSimplify.eq_tm - env - (f_b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort - expected_f_b_sort in - uu___11 = - FStar_TypeChecker_TermEqAndSimplify.Equal in - if uu___10 - then - FStar_Pervasives_Native.Some - () - else - FStar_Pervasives_Native.None in - op_let_Question uu___9 - (fun _f_b_ok_ -> - let check_g_b f_or_g_bs = - let expected_g_b_sort = - let uu___10 = - FStar_TypeChecker_Env.inst_tscheme_with - repr_ts - [FStar_Syntax_Syntax.U_name - u] in - match uu___10 with - | (uu___11, t) -> - let uu___12 = - let uu___13 = - let uu___14 = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - FStar_Syntax_Syntax.as_arg - uu___14 in - let uu___14 = - FStar_Compiler_List.map - (fun - uu___15 - -> - match uu___15 - with - | - { - FStar_Syntax_Syntax.binder_bv - = b; - FStar_Syntax_Syntax.binder_qual - = uu___16; - FStar_Syntax_Syntax.binder_positivity - = uu___17; - FStar_Syntax_Syntax.binder_attrs - = uu___18;_} - -> - let uu___19 - = - FStar_Syntax_Syntax.bv_to_name - b in - FStar_Syntax_Syntax.as_arg - uu___19) - (FStar_Compiler_List.op_At - eff_params_bs - f_or_g_bs) in - uu___13 :: - uu___14 in - FStar_Syntax_Syntax.mk_Tm_app - t uu___12 - FStar_Compiler_Range_Type.dummyRange in - let uu___10 = - let uu___11 = - FStar_TypeChecker_TermEqAndSimplify.eq_tm - env - (g_b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort - expected_g_b_sort in - uu___11 = - FStar_TypeChecker_TermEqAndSimplify.Equal in - if uu___10 - then - FStar_Pervasives_Native.Some - () - else - FStar_Pervasives_Native.None in - let uu___10 = - let uu___11 = - check_g_b f_bs in - FStar_Pervasives_Native.uu___is_Some - uu___11 in - if uu___10 - then - FStar_Pervasives_Native.Some - FStar_Syntax_Syntax.Substitutive_invariant_combinator - else - (let uu___12 = - let g_sig_bs = - let uu___13 = - FStar_TypeChecker_Env.inst_tscheme_with - sig_ts - [FStar_Syntax_Syntax.U_name - u] in - match uu___13 with - | (uu___14, sig1) - -> - let uu___15 = - let uu___16 - = - FStar_Syntax_Util.arrow_formals - sig1 in - FStar_Pervasives_Native.fst - uu___16 in - (match uu___15 - with - | a::bs -> - let uu___16 - = - FStar_Compiler_List.splitAt - num_effect_params - bs in - (match uu___16 - with - | - (sig_bs, - bs1) -> - let ss = - let uu___17 - = - let uu___18 - = - let uu___19 - = - let uu___20 - = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - ((a.FStar_Syntax_Syntax.binder_bv), - uu___20) in - FStar_Syntax_Syntax.NT - uu___19 in - [uu___18] in - FStar_Compiler_List.fold_left2 - (fun ss1 - -> - fun sig_b - -> - fun b -> - let uu___18 - = - let uu___19 - = - let uu___20 - = - let uu___21 - = - FStar_Syntax_Syntax.bv_to_name - b.FStar_Syntax_Syntax.binder_bv in - ((sig_b.FStar_Syntax_Syntax.binder_bv), - uu___21) in - FStar_Syntax_Syntax.NT - uu___20 in - [uu___19] in - FStar_Compiler_List.op_At - ss1 - uu___18) - uu___17 - sig_bs - eff_params_bs in - FStar_Syntax_Subst.subst_binders - ss bs1)) in - let uu___13 = - if - (FStar_Compiler_List.length - rest_bs3) - < - (FStar_Compiler_List.length - g_sig_bs) - then - FStar_Pervasives_Native.None - else - (let uu___15 = - FStar_Compiler_List.splitAt - (FStar_Compiler_List.length - g_sig_bs) - rest_bs3 in - FStar_Pervasives_Native.Some - uu___15) in - op_let_Question - uu___13 - (fun uu___14 -> - match uu___14 - with - | (g_bs, - rest_bs4) -> - let uu___15 - = - eq_binders - env - g_sig_bs - g_bs in - op_let_Question - uu___15 - ( - fun - g_bs_kinds - -> - FStar_Pervasives_Native.Some - (g_bs, - g_bs_kinds, - rest_bs4))) in - op_let_Question - uu___12 - (fun uu___13 -> - match uu___13 - with - | (g_bs, - g_bs_kinds, - rest_bs4) -> - let uu___14 = - check_g_b - g_bs in - op_let_Question - uu___14 - (fun - _g_b_ok_ - -> - let rest_kinds - = - FStar_Compiler_List.map - (fun - uu___15 - -> - FStar_Syntax_Syntax.Ad_hoc_binder) - rest_bs4 in - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Substitutive_combinator - (FStar_Compiler_List.op_At - [FStar_Syntax_Syntax.Type_binder] - (FStar_Compiler_List.op_At - eff_params_bs_kinds - (FStar_Compiler_List.op_At - f_bs_kinds - (FStar_Compiler_List.op_At - g_bs_kinds - (FStar_Compiler_List.op_At - rest_kinds - [FStar_Syntax_Syntax.Repr_binder; - FStar_Syntax_Syntax.Repr_binder; - FStar_Syntax_Syntax.Substitutive_binder]))))))))))))) -let (validate_indexed_effect_ite_shape : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.tscheme -> - FStar_Syntax_Syntax.tscheme -> - FStar_Syntax_Syntax.univ_name -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.term -> - Prims.int -> - FStar_Compiler_Range_Type.range -> - (FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.indexed_effect_combinator_kind)) - = - fun env -> - fun eff_name -> - fun sig_ts -> - fun repr_ts -> - fun u -> - fun ite_ty -> - fun ite_tm -> - fun num_effect_params -> - fun r -> - let ite_name = - let uu___ = FStar_Ident.string_of_lid eff_name in - FStar_Compiler_Util.format1 "ite_%s" uu___ in - let a_b = - let uu___ = - let uu___1 = - FStar_Syntax_Util.type_with_u - (FStar_Syntax_Syntax.U_name u) in - FStar_Syntax_Syntax.gen_bv "a" - FStar_Pervasives_Native.None uu___1 in - FStar_Syntax_Syntax.mk_binder uu___ in - let rest_bs = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress ite_ty in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; - FStar_Syntax_Syntax.comp = uu___1;_} - when - (FStar_Compiler_List.length bs) >= - (Prims.of_int (4)) - -> - let uu___2 = FStar_Syntax_Subst.open_binders bs in - (match uu___2 with - | { FStar_Syntax_Syntax.binder_bv = a; - FStar_Syntax_Syntax.binder_qual = uu___3; - FStar_Syntax_Syntax.binder_positivity = uu___4; - FStar_Syntax_Syntax.binder_attrs = uu___5;_}::bs1 - -> - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - (a, uu___9) in - FStar_Syntax_Syntax.NT uu___8 in - [uu___7] in - let uu___7 = - let uu___8 = - FStar_Compiler_List.splitAt - ((FStar_Compiler_List.length bs1) - - (Prims.of_int (3))) bs1 in - FStar_Pervasives_Native.fst uu___8 in - FStar_Syntax_Subst.subst_binders uu___6 uu___7) - | uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term ite_ty in - FStar_Compiler_Util.format2 - "Type of %s is not an arrow with >= 4 binders (%s)" - ite_name uu___3 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_UnexpectedEffect () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2) in - let uu___ = - let uu___1 = - let uu___2 = - FStar_TypeChecker_Env.push_binders env (a_b :: - rest_bs) in - let uu___3 = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - FStar_TypeChecker_Util.fresh_effect_repr uu___2 r - eff_name sig_ts - (FStar_Pervasives_Native.Some repr_ts) - (FStar_Syntax_Syntax.U_name u) uu___3 in - match uu___1 with - | (repr, g) -> - let uu___2 = - let uu___3 = - FStar_Syntax_Syntax.gen_bv "f" - FStar_Pervasives_Native.None repr in - FStar_Syntax_Syntax.mk_binder uu___3 in - (uu___2, g) in - match uu___ with - | (f, guard_f) -> - let uu___1 = - let uu___2 = - let uu___3 = - FStar_TypeChecker_Env.push_binders env (a_b :: - rest_bs) in - let uu___4 = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - FStar_TypeChecker_Util.fresh_effect_repr uu___3 r - eff_name sig_ts - (FStar_Pervasives_Native.Some repr_ts) - (FStar_Syntax_Syntax.U_name u) uu___4 in - match uu___2 with - | (repr, g) -> - let uu___3 = - let uu___4 = - FStar_Syntax_Syntax.gen_bv "g" - FStar_Pervasives_Native.None repr in - FStar_Syntax_Syntax.mk_binder uu___4 in - (uu___3, g) in - (match uu___1 with - | (g, guard_g) -> - let p = - let uu___2 = - FStar_Syntax_Syntax.gen_bv "p" - FStar_Pervasives_Native.None - FStar_Syntax_Util.t_bool in - FStar_Syntax_Syntax.mk_binder uu___2 in - let uu___2 = - let uu___3 = - FStar_TypeChecker_Env.push_binders env - (FStar_Compiler_List.op_At (a_b :: - rest_bs) [p]) in - let uu___4 = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - FStar_TypeChecker_Util.fresh_effect_repr - uu___3 r eff_name sig_ts - (FStar_Pervasives_Native.Some repr_ts) - (FStar_Syntax_Syntax.U_name u) uu___4 in - (match uu___2 with - | (body_tm, guard_body) -> - let k = - FStar_Syntax_Util.abs - (FStar_Compiler_List.op_At (a_b :: - rest_bs) [f; g; p]) body_tm - FStar_Pervasives_Native.None in - let guard_eq = - let uu___3 = - FStar_TypeChecker_Rel.teq_nosmt env - ite_tm k in - match uu___3 with - | FStar_Pervasives_Native.None -> - let uu___4 = - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - ite_tm in - FStar_Compiler_Util.format2 - "Unexpected term for %s (%s)\n" - ite_name uu___5 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - r - FStar_Errors_Codes.Fatal_UnexpectedEffect - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4) - | FStar_Pervasives_Native.Some g1 -> g1 in - ((let uu___4 = - FStar_TypeChecker_Env.conj_guards - [guard_f; - guard_g; - guard_body; - guard_eq] in - FStar_TypeChecker_Rel.force_trivial_guard - env uu___4); - (let k1 = - let uu___4 = - FStar_TypeChecker_Normalize.remove_uvar_solutions - env k in - FStar_Syntax_Subst.compress uu___4 in - let kopt = - ite_combinator_kind env eff_name sig_ts - repr_ts u k1 num_effect_params in - let kind = - match kopt with - | FStar_Pervasives_Native.None -> - (log_ad_hoc_combinator_warning - ite_name r; - FStar_Syntax_Syntax.Ad_hoc_combinator) - | FStar_Pervasives_Native.Some k2 -> k2 in - (let uu___5 = - (FStar_Compiler_Debug.medium ()) || - (FStar_Compiler_Effect.op_Bang - dbg_LayeredEffectsTc) in - if uu___5 - then - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Syntax.showable_indexed_effect_combinator_kind - kind in - FStar_Compiler_Util.print2 - "Ite %s has %s kind\n" ite_name - uu___6 - else ()); - (k1, kind))))) -let (validate_indexed_effect_close_shape : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.tscheme -> - FStar_Syntax_Syntax.tscheme -> - FStar_Syntax_Syntax.univ_name -> - FStar_Syntax_Syntax.univ_name -> - FStar_Syntax_Syntax.term -> - Prims.int -> - FStar_Compiler_Range_Type.range -> FStar_Syntax_Syntax.term) - = - fun env -> - fun eff_name -> - fun sig_ts -> - fun repr_ts -> - fun u_a -> - fun u_b -> - fun close_tm -> - fun num_effect_params -> - fun r -> - let close_name = - let uu___ = FStar_Ident.string_of_lid eff_name in - FStar_Compiler_Util.format1 "close_%s" uu___ in - let b_b = - let uu___ = - let uu___1 = - FStar_Syntax_Util.type_with_u - (FStar_Syntax_Syntax.U_name u_b) in - FStar_Syntax_Syntax.gen_bv "b" - FStar_Pervasives_Native.None uu___1 in - FStar_Syntax_Syntax.mk_binder uu___ in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - FStar_TypeChecker_Env.inst_tscheme_with sig_ts - [FStar_Syntax_Syntax.U_name u_a] in - FStar_Pervasives_Native.snd uu___3 in - FStar_Syntax_Util.arrow_formals uu___2 in - FStar_Pervasives_Native.fst uu___1 in - match uu___ with - | a_b::sig_bs -> - let uu___1 = - FStar_Compiler_List.splitAt num_effect_params - sig_bs in - (match uu___1 with - | (eff_params_bs, sig_bs1) -> - let bs = - FStar_Compiler_List.map - (fun b -> - let x_b = - let uu___2 = - let uu___3 = - FStar_Syntax_Syntax.bv_to_name - b_b.FStar_Syntax_Syntax.binder_bv in - FStar_Syntax_Syntax.gen_bv "x" - FStar_Pervasives_Native.None uu___3 in - FStar_Syntax_Syntax.mk_binder uu___2 in - let uu___2 = - let uu___3 = - b.FStar_Syntax_Syntax.binder_bv in - let uu___4 = - let uu___5 = - FStar_Syntax_Syntax.mk_Total - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - FStar_Syntax_Util.arrow [x_b] uu___5 in - { - FStar_Syntax_Syntax.ppname = - (uu___3.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (uu___3.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = uu___4 - } in - { - FStar_Syntax_Syntax.binder_bv = uu___2; - FStar_Syntax_Syntax.binder_qual = - (b.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity = - (b.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs = - (b.FStar_Syntax_Syntax.binder_attrs) - }) sig_bs1 in - let f_b = - let uu___2 = - FStar_TypeChecker_Env.inst_tscheme_with - repr_ts [FStar_Syntax_Syntax.U_name u_a] in - match uu___2 with - | (uu___3, repr_t) -> - let x_b = - let uu___4 = - let uu___5 = - FStar_Syntax_Syntax.bv_to_name - b_b.FStar_Syntax_Syntax.binder_bv in - FStar_Syntax_Syntax.gen_bv "x" - FStar_Pervasives_Native.None uu___5 in - FStar_Syntax_Syntax.mk_binder uu___4 in - let is_args = - FStar_Compiler_List.map - (fun uu___4 -> - match uu___4 with - | { - FStar_Syntax_Syntax.binder_bv = - binder_bv; - FStar_Syntax_Syntax.binder_qual - = uu___5; - FStar_Syntax_Syntax.binder_positivity - = uu___6; - FStar_Syntax_Syntax.binder_attrs - = uu___7;_} - -> - let uu___8 = - let uu___9 = - FStar_Syntax_Syntax.bv_to_name - binder_bv in - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Syntax_Syntax.bv_to_name - x_b.FStar_Syntax_Syntax.binder_bv in - FStar_Syntax_Syntax.as_arg - uu___12 in - [uu___11] in - FStar_Syntax_Syntax.mk_Tm_app - uu___9 uu___10 - FStar_Compiler_Range_Type.dummyRange in - FStar_Syntax_Syntax.as_arg - uu___8) bs in - let repr_app = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - FStar_Syntax_Syntax.as_arg uu___6 in - uu___5 :: is_args in - FStar_Syntax_Syntax.mk_Tm_app repr_t - uu___4 - FStar_Compiler_Range_Type.dummyRange in - let f_sort = - let uu___4 = - FStar_Syntax_Syntax.mk_Total repr_app in - FStar_Syntax_Util.arrow [x_b] uu___4 in - let uu___4 = - FStar_Syntax_Syntax.gen_bv "f" - FStar_Pervasives_Native.None f_sort in - FStar_Syntax_Syntax.mk_binder uu___4 in - let env1 = - FStar_TypeChecker_Env.push_binders env (a_b :: - b_b :: - (FStar_Compiler_List.op_At eff_params_bs bs)) in - let uu___2 = - let uu___3 = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - FStar_TypeChecker_Util.fresh_effect_repr env1 - r eff_name sig_ts - (FStar_Pervasives_Native.Some repr_ts) - (FStar_Syntax_Syntax.U_name u_a) uu___3 in - (match uu___2 with - | (body_tm, g_body) -> - let k = - FStar_Syntax_Util.abs (a_b :: b_b :: - (FStar_Compiler_List.op_At - eff_params_bs - (FStar_Compiler_List.op_At bs [f_b]))) - body_tm FStar_Pervasives_Native.None in - let g_eq = - let uu___3 = - FStar_TypeChecker_Rel.teq_nosmt env1 - close_tm k in - match uu___3 with - | FStar_Pervasives_Native.None -> - let uu___4 = - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - close_tm in - FStar_Compiler_Util.format2 - "Unexpected term for %s (%s)\n" - close_name uu___5 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - r - FStar_Errors_Codes.Fatal_UnexpectedEffect - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4) - | FStar_Pervasives_Native.Some g -> g in - ((let uu___4 = - FStar_TypeChecker_Env.conj_guard g_body - g_eq in - FStar_TypeChecker_Rel.force_trivial_guard - env1 uu___4); - (let uu___4 = - FStar_TypeChecker_Normalize.remove_uvar_solutions - env1 k in - FStar_Syntax_Subst.compress uu___4)))) -let (lift_combinator_kind : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.tscheme -> - FStar_Syntax_Syntax.tscheme FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.univ_name -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.indexed_effect_binder_kind Prims.list - FStar_Pervasives_Native.option) - = - fun env -> - fun m_eff_name -> - fun m_sig_ts -> - fun m_repr_ts -> - fun u -> - fun k -> - let uu___ = FStar_Syntax_Util.arrow_formals k in - match uu___ with - | (a_b::rest_bs, uu___1) -> - let uu___2 = - let f_sig_bs = - let uu___3 = - FStar_TypeChecker_Env.inst_tscheme_with m_sig_ts - [FStar_Syntax_Syntax.U_name u] in - match uu___3 with - | (uu___4, sig1) -> - let uu___5 = - let uu___6 = FStar_Syntax_Util.arrow_formals sig1 in - FStar_Pervasives_Native.fst uu___6 in - (match uu___5 with - | a::bs -> - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - ((a.FStar_Syntax_Syntax.binder_bv), - uu___9) in - FStar_Syntax_Syntax.NT uu___8 in - [uu___7] in - FStar_Syntax_Subst.subst_binders uu___6 bs) in - let uu___3 = - if - (FStar_Compiler_List.length rest_bs) < - (FStar_Compiler_List.length f_sig_bs) - then FStar_Pervasives_Native.None - else - (let uu___5 = - FStar_Compiler_List.splitAt - (FStar_Compiler_List.length f_sig_bs) rest_bs in - FStar_Pervasives_Native.Some uu___5) in - op_let_Question uu___3 - (fun uu___4 -> - match uu___4 with - | (f_bs, rest_bs1) -> - let uu___5 = eq_binders env f_sig_bs f_bs in - op_let_Question uu___5 - (fun f_bs_kinds -> - FStar_Pervasives_Native.Some - (f_bs, f_bs_kinds, rest_bs1))) in - op_let_Question uu___2 - (fun uu___3 -> - match uu___3 with - | (f_bs, f_bs_kinds, rest_bs1) -> - let uu___4 = - if - (FStar_Compiler_List.length rest_bs1) >= - Prims.int_one - then - let uu___5 = - FStar_Compiler_List.splitAt - ((FStar_Compiler_List.length rest_bs1) - - Prims.int_one) rest_bs1 in - match uu___5 with - | (rest_bs2, f_b::[]) -> - FStar_Pervasives_Native.Some - (rest_bs2, f_b) - else FStar_Pervasives_Native.None in - op_let_Question uu___4 - (fun uu___5 -> - match uu___5 with - | (rest_bs2, f_b) -> - let uu___6 = - let expected_f_b_sort = - match m_repr_ts with - | FStar_Pervasives_Native.Some - repr_ts -> - let uu___7 = - FStar_TypeChecker_Env.inst_tscheme_with - repr_ts - [FStar_Syntax_Syntax.U_name u] in - (match uu___7 with - | (uu___8, t) -> - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - FStar_Syntax_Syntax.as_arg - uu___11 in - let uu___11 = - FStar_Compiler_List.map - (fun uu___12 -> - match uu___12 with - | { - FStar_Syntax_Syntax.binder_bv - = b; - FStar_Syntax_Syntax.binder_qual - = uu___13; - FStar_Syntax_Syntax.binder_positivity - = uu___14; - FStar_Syntax_Syntax.binder_attrs - = uu___15;_} - -> - let uu___16 = - FStar_Syntax_Syntax.bv_to_name - b in - FStar_Syntax_Syntax.as_arg - uu___16) f_bs in - uu___10 :: uu___11 in - FStar_Syntax_Syntax.mk_Tm_app - t uu___9 - FStar_Compiler_Range_Type.dummyRange) - | FStar_Pervasives_Native.None -> - let uu___7 = - let uu___8 = - FStar_Syntax_Syntax.null_binder - FStar_Syntax_Syntax.t_unit in - [uu___8] in - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - let uu___11 = - FStar_Compiler_List.map - (fun b -> - let uu___12 = - FStar_Syntax_Syntax.bv_to_name - b.FStar_Syntax_Syntax.binder_bv in - FStar_Syntax_Syntax.as_arg - uu___12) f_bs in - { - FStar_Syntax_Syntax.comp_univs - = - [FStar_Syntax_Syntax.U_name - u]; - FStar_Syntax_Syntax.effect_name - = m_eff_name; - FStar_Syntax_Syntax.result_typ - = uu___10; - FStar_Syntax_Syntax.effect_args - = uu___11; - FStar_Syntax_Syntax.flags = - [] - } in - FStar_Syntax_Syntax.mk_Comp - uu___9 in - FStar_Syntax_Util.arrow uu___7 - uu___8 in - let uu___7 = - let uu___8 = - FStar_TypeChecker_TermEqAndSimplify.eq_tm - env - (f_b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort - expected_f_b_sort in - uu___8 = - FStar_TypeChecker_TermEqAndSimplify.Equal in - if uu___7 - then FStar_Pervasives_Native.Some () - else FStar_Pervasives_Native.None in - op_let_Question uu___6 - (fun _f_b_ok_ -> - let rest_kinds = - FStar_Compiler_List.map - (fun uu___7 -> - FStar_Syntax_Syntax.Ad_hoc_binder) - rest_bs2 in - FStar_Pervasives_Native.Some - (FStar_Compiler_List.op_At - [FStar_Syntax_Syntax.Type_binder] - (FStar_Compiler_List.op_At - f_bs_kinds - (FStar_Compiler_List.op_At - rest_kinds - [FStar_Syntax_Syntax.Repr_binder])))))) -let (validate_indexed_effect_lift_shape : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.univ_name -> - FStar_Syntax_Syntax.typ -> - FStar_Compiler_Range_Type.range -> - (FStar_Syntax_Syntax.typ * - FStar_Syntax_Syntax.indexed_effect_combinator_kind)) - = - fun env -> - fun m_eff_name -> - fun n_eff_name -> - fun u -> - fun lift_t -> - fun r -> - let lift_name = - let uu___ = FStar_Ident.string_of_lid m_eff_name in - let uu___1 = FStar_Ident.string_of_lid n_eff_name in - FStar_Compiler_Util.format2 "%s ~> %s" uu___ uu___1 in - let lift_t_shape_error s = - FStar_Compiler_Util.format2 - "Unexpected shape of lift %s, reason:%s" lift_name s in - let uu___ = - let uu___1 = - FStar_TypeChecker_Env.get_effect_decl env m_eff_name in - let uu___2 = - FStar_TypeChecker_Env.get_effect_decl env n_eff_name in - (uu___1, uu___2) in - match uu___ with - | (m_ed, n_ed) -> - let a_b = - let uu___1 = - let uu___2 = - FStar_Syntax_Util.type_with_u - (FStar_Syntax_Syntax.U_name u) in - FStar_Syntax_Syntax.gen_bv "a" - FStar_Pervasives_Native.None uu___2 in - FStar_Syntax_Syntax.mk_binder uu___1 in - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress lift_t in - uu___3.FStar_Syntax_Syntax.n in - match uu___2 with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; - FStar_Syntax_Syntax.comp = c;_} - when - (FStar_Compiler_List.length bs) >= (Prims.of_int (2)) - -> - let uu___3 = FStar_Syntax_Subst.open_binders bs in - (match uu___3 with - | { FStar_Syntax_Syntax.binder_bv = a; - FStar_Syntax_Syntax.binder_qual = uu___4; - FStar_Syntax_Syntax.binder_positivity = uu___5; - FStar_Syntax_Syntax.binder_attrs = uu___6;_}::bs1 - -> - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - (a, uu___11) in - FStar_Syntax_Syntax.NT uu___10 in - [uu___9] in - let uu___9 = - let uu___10 = - FStar_Compiler_List.splitAt - ((FStar_Compiler_List.length bs1) - - Prims.int_one) bs1 in - FStar_Pervasives_Native.fst uu___10 in - FStar_Syntax_Subst.subst_binders uu___8 uu___9 in - let uu___8 = - FStar_TypeChecker_Env.norm_eff_name env - (FStar_Syntax_Util.comp_effect_name c) in - (uu___7, uu___8)) - | uu___3 -> - let uu___4 = - lift_t_shape_error - "either not an arrow, or not enough binders" in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_UnexpectedExpressionType - () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4) in - (match uu___1 with - | (rest_bs, lift_eff) -> - ((let uu___3 = - let uu___4 = - (FStar_Ident.lid_equals lift_eff - FStar_Parser_Const.effect_PURE_lid) - || - ((FStar_Ident.lid_equals lift_eff - FStar_Parser_Const.effect_GHOST_lid) - && - (FStar_TypeChecker_Env.is_erasable_effect - env m_eff_name)) in - Prims.op_Negation uu___4 in - if uu___3 - then - let uu___4 = - lift_t_shape_error - "the lift combinator has an unexpected effect: it must either be PURE or if the source effect is erasable then may be GHOST" in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_UnexpectedExpressionType - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4) - else ()); - (let uu___3 = - let uu___4 = - let uu___5 = - FStar_TypeChecker_Env.push_binders env (a_b :: - rest_bs) in - let uu___6 = - FStar_Syntax_Util.effect_sig_ts - m_ed.FStar_Syntax_Syntax.signature in - let uu___7 = FStar_Syntax_Util.get_eff_repr m_ed in - let uu___8 = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - FStar_TypeChecker_Util.fresh_effect_repr uu___5 - r m_eff_name uu___6 uu___7 - (FStar_Syntax_Syntax.U_name u) uu___8 in - match uu___4 with - | (repr, g) -> - let uu___5 = - let uu___6 = - FStar_Syntax_Syntax.gen_bv "f" - FStar_Pervasives_Native.None repr in - FStar_Syntax_Syntax.mk_binder uu___6 in - (uu___5, g) in - match uu___3 with - | (f, guard_f) -> - let uu___4 = - let uu___5 = - FStar_TypeChecker_Env.push_binders env (a_b - :: rest_bs) in - let uu___6 = - FStar_Syntax_Util.effect_sig_ts - n_ed.FStar_Syntax_Syntax.signature in - let uu___7 = - FStar_Syntax_Util.get_eff_repr n_ed in - let uu___8 = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - FStar_TypeChecker_Util.fresh_effect_repr - uu___5 r n_eff_name uu___6 uu___7 - (FStar_Syntax_Syntax.U_name u) uu___8 in - (match uu___4 with - | (ret_t, guard_ret_t) -> - let uu___5 = - let uu___6 = - FStar_TypeChecker_Env.push_binders env - (a_b :: rest_bs) in - let uu___7 = - FStar_Compiler_Util.format1 - "implicit for pure_wp in typechecking lift %s" - lift_name in - pure_wp_uvar uu___6 ret_t uu___7 r in - (match uu___5 with - | (pure_wp_uvar1, guard_wp) -> - let c = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_TypeChecker_Env.new_u_univ - () in - [uu___8] in - let uu___8 = - let uu___9 = - FStar_Syntax_Syntax.as_arg - pure_wp_uvar1 in - [uu___9] in - { - FStar_Syntax_Syntax.comp_univs = - uu___7; - FStar_Syntax_Syntax.effect_name - = lift_eff; - FStar_Syntax_Syntax.result_typ = - ret_t; - FStar_Syntax_Syntax.effect_args - = uu___8; - FStar_Syntax_Syntax.flags = [] - } in - FStar_Syntax_Syntax.mk_Comp uu___6 in - let k = - FStar_Syntax_Util.arrow - (FStar_Compiler_List.op_At (a_b :: - rest_bs) [f]) c in - let guard_eq = - let uu___6 = - FStar_TypeChecker_Rel.teq_nosmt - env lift_t k in - match uu___6 with - | FStar_Pervasives_Native.None -> - let uu___7 = - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - lift_t in - FStar_Compiler_Util.format2 - "Unexpected type of %s (%s)\n" - lift_name uu___8 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - r - FStar_Errors_Codes.Fatal_UnexpectedEffect - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___7) - | FStar_Pervasives_Native.Some g -> - g in - ((let uu___7 = - FStar_TypeChecker_Env.conj_guards - [guard_f; - guard_ret_t; - guard_wp; - guard_eq] in - FStar_TypeChecker_Rel.force_trivial_guard - env uu___7); - (let k1 = - let uu___7 = - FStar_TypeChecker_Normalize.remove_uvar_solutions - env k in - FStar_Syntax_Subst.compress uu___7 in - let lopt = - let uu___7 = - FStar_Syntax_Util.effect_sig_ts - m_ed.FStar_Syntax_Syntax.signature in - let uu___8 = - FStar_Syntax_Util.get_eff_repr - m_ed in - lift_combinator_kind env - m_eff_name uu___7 uu___8 u k1 in - let kind = - match lopt with - | FStar_Pervasives_Native.None -> - (log_ad_hoc_combinator_warning - lift_name r; - FStar_Syntax_Syntax.Ad_hoc_combinator) - | FStar_Pervasives_Native.Some l - -> - FStar_Syntax_Syntax.Substitutive_combinator - l in - (let uu___8 = - (FStar_Compiler_Debug.medium ()) - || - (FStar_Compiler_Effect.op_Bang - dbg_LayeredEffectsTc) in - if uu___8 - then - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Syntax.showable_indexed_effect_combinator_kind - kind in - FStar_Compiler_Util.print2 - "Lift %s has %s kind\n" - lift_name uu___9 - else ()); - (k1, kind)))))))) -let (tc_layered_eff_decl : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.eff_decl -> - FStar_Syntax_Syntax.qualifier Prims.list -> - FStar_Syntax_Syntax.attribute Prims.list -> - FStar_Syntax_Syntax.eff_decl) - = - fun env0 -> - fun ed -> - fun quals -> - fun attrs -> - let uu___ = - let uu___1 = - FStar_Ident.string_of_lid ed.FStar_Syntax_Syntax.mname in - FStar_Compiler_Util.format1 - "While checking layered effect definition `%s`" uu___1 in - FStar_Errors.with_ctx uu___ - (fun uu___1 -> - (let uu___3 = - FStar_Compiler_Effect.op_Bang dbg_LayeredEffectsTc in - if uu___3 - then - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_eff_decl ed in - FStar_Compiler_Util.print1 - "Typechecking layered effect: \n\t%s\n" uu___4 - else ()); - if - ((FStar_Compiler_List.length ed.FStar_Syntax_Syntax.univs) - <> Prims.int_zero) - || - ((FStar_Compiler_List.length - ed.FStar_Syntax_Syntax.binders) - <> Prims.int_zero) - then - (let uu___4 = - let uu___5 = - let uu___6 = - FStar_Ident.string_of_lid - ed.FStar_Syntax_Syntax.mname in - Prims.strcat uu___6 ")" in - Prims.strcat - "Binders are not supported for layered effects (" - uu___5 in - FStar_Errors.raise_error FStar_Ident.hasrange_lident - ed.FStar_Syntax_Syntax.mname - FStar_Errors_Codes.Fatal_UnexpectedEffect () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4)) - else (); - (let log_combinator s uu___4 = - match uu___4 with - | (us, t, ty) -> - let uu___5 = - FStar_Compiler_Effect.op_Bang dbg_LayeredEffectsTc in - if uu___5 - then - let uu___6 = - FStar_Ident.string_of_lid - ed.FStar_Syntax_Syntax.mname in - let uu___7 = - FStar_Syntax_Print.tscheme_to_string (us, t) in - let uu___8 = - FStar_Syntax_Print.tscheme_to_string (us, ty) in - FStar_Compiler_Util.print4 - "Typechecked %s:%s = %s:%s\n" uu___6 s uu___7 - uu___8 - else () in - let fresh_a_and_u_a a = - let uu___4 = FStar_Syntax_Util.type_u () in - match uu___4 with - | (t, u) -> - let uu___5 = - let uu___6 = - FStar_Syntax_Syntax.gen_bv a - FStar_Pervasives_Native.None t in - FStar_Syntax_Syntax.mk_binder uu___6 in - (uu___5, u) in - let fresh_x_a x a = - let uu___4 = - let uu___5 = - FStar_Syntax_Syntax.bv_to_name - a.FStar_Syntax_Syntax.binder_bv in - FStar_Syntax_Syntax.gen_bv x FStar_Pervasives_Native.None - uu___5 in - FStar_Syntax_Syntax.mk_binder uu___4 in - let check_and_gen1 = - let uu___4 = - FStar_Ident.string_of_lid ed.FStar_Syntax_Syntax.mname in - check_and_gen env0 uu___4 in - let uu___4 = - let uu___5 = - match ed.FStar_Syntax_Syntax.signature with - | FStar_Syntax_Syntax.Layered_eff_sig (n, ts) -> (n, ts) - | uu___6 -> - failwith - "Impossible (tc_layered_eff_decl with a wp effect sig" in - match uu___5 with - | (n, sig_ts) -> - FStar_Errors.with_ctx - "While checking the effect signature" - (fun uu___6 -> - let r = - (FStar_Pervasives_Native.snd sig_ts).FStar_Syntax_Syntax.pos in - let uu___7 = - check_and_gen1 "signature" Prims.int_one sig_ts in - match uu___7 with - | (sig_us, sig_t, sig_ty) -> - let uu___8 = - FStar_Syntax_Subst.open_univ_vars sig_us - sig_t in - (match uu___8 with - | (us, t) -> - let env = - FStar_TypeChecker_Env.push_univ_vars - env0 us in - let uu___9 = fresh_a_and_u_a "a" in - (match uu___9 with - | (a, u) -> - let rest_bs = - let uu___10 = - FStar_Syntax_Syntax.bv_to_name - a.FStar_Syntax_Syntax.binder_bv in - FStar_TypeChecker_Util.layered_effect_indices_as_binders - env r - ed.FStar_Syntax_Syntax.mname - (sig_us, sig_t) u uu___10 in - let bs = a :: rest_bs in - let k = - let uu___10 = - FStar_Syntax_Syntax.mk_Total - FStar_Syntax_Syntax.teff in - FStar_Syntax_Util.arrow bs uu___10 in - let g_eq = - FStar_TypeChecker_Rel.teq env t k in - (FStar_TypeChecker_Rel.force_trivial_guard - env g_eq; - (let uu___11 = - let uu___12 = - let uu___13 = - FStar_TypeChecker_Normalize.remove_uvar_solutions - env k in - FStar_Syntax_Subst.close_univ_vars - us uu___13 in - (sig_us, uu___12, sig_ty) in - (n, uu___11)))))) in - match uu___4 with - | (num_effect_params, signature) -> - (log_combinator "signature" signature; - (let repr = - FStar_Errors.with_ctx - "While checking the effect repr" - (fun uu___6 -> - let repr_ts = - let uu___7 = FStar_Syntax_Util.get_eff_repr ed in - FStar_Compiler_Util.must uu___7 in - let r = - (FStar_Pervasives_Native.snd repr_ts).FStar_Syntax_Syntax.pos in - let uu___7 = - check_and_gen1 "repr" Prims.int_one repr_ts in - match uu___7 with - | (repr_us, repr_t, repr_ty) -> - let uu___8 = - FStar_Syntax_Subst.open_univ_vars repr_us - repr_ty in - (match uu___8 with - | (us, ty) -> - let env = - FStar_TypeChecker_Env.push_univ_vars - env0 us in - let uu___9 = fresh_a_and_u_a "a" in - (match uu___9 with - | (a, u) -> - let rest_bs = - let signature_ts = - let uu___10 = signature in - match uu___10 with - | (us1, t, uu___11) -> - (us1, t) in - let uu___10 = - FStar_Syntax_Syntax.bv_to_name - a.FStar_Syntax_Syntax.binder_bv in - FStar_TypeChecker_Util.layered_effect_indices_as_binders - env r - ed.FStar_Syntax_Syntax.mname - signature_ts u uu___10 in - let bs = a :: rest_bs in - let k = - let uu___10 = - let uu___11 = - FStar_Syntax_Util.type_u () in - match uu___11 with - | (t, u1) -> - FStar_Syntax_Syntax.mk_Total - t in - FStar_Syntax_Util.arrow bs - uu___10 in - let g = - FStar_TypeChecker_Rel.teq env ty - k in - (FStar_TypeChecker_Rel.force_trivial_guard - env g; - (let uu___11 = - let uu___12 = - FStar_TypeChecker_Normalize.remove_uvar_solutions - env k in - FStar_Syntax_Subst.close_univ_vars - us uu___12 in - (repr_us, repr_t, uu___11)))))) in - log_combinator "repr" repr; - (let fresh_repr r env u a_tm = - let signature_ts = - let uu___7 = signature in - match uu___7 with | (us, t, uu___8) -> (us, t) in - let repr_ts = - let uu___7 = repr in - match uu___7 with | (us, t, uu___8) -> (us, t) in - FStar_TypeChecker_Util.fresh_effect_repr env r - ed.FStar_Syntax_Syntax.mname signature_ts - (FStar_Pervasives_Native.Some repr_ts) u a_tm in - let not_an_arrow_error comb n t r = - let uu___7 = - let uu___8 = - FStar_Ident.string_of_lid - ed.FStar_Syntax_Syntax.mname in - let uu___9 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) n in - let uu___10 = - FStar_Class_Tagged.tag_of - FStar_Syntax_Syntax.tagged_term t in - let uu___11 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.format5 - "Type of %s:%s is not an arrow with >= %s binders (%s::%s)" - uu___8 comb uu___9 uu___10 uu___11 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_UnexpectedEffect () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___7) in - let return_repr = - FStar_Errors.with_ctx - "While checking the return combinator" - (fun uu___7 -> - let return_repr_ts = - let uu___8 = - FStar_Syntax_Util.get_return_repr ed in - FStar_Compiler_Util.must uu___8 in - let r = - (FStar_Pervasives_Native.snd return_repr_ts).FStar_Syntax_Syntax.pos in - let uu___8 = - check_and_gen1 "return_repr" Prims.int_one - return_repr_ts in - match uu___8 with - | (ret_us, ret_t, ret_ty) -> - let uu___9 = - FStar_Syntax_Subst.open_univ_vars ret_us - ret_ty in - (match uu___9 with - | (us, ty) -> - let env = - FStar_TypeChecker_Env.push_univ_vars - env0 us in - let uu___10 = fresh_a_and_u_a "a" in - (match uu___10 with - | (a, u_a) -> - let x_a = fresh_x_a "x" a in - let rest_bs = - let uu___11 = - let uu___12 = - FStar_Syntax_Subst.compress - ty in - uu___12.FStar_Syntax_Syntax.n in - match uu___11 with - | FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 = - bs; - FStar_Syntax_Syntax.comp - = uu___12;_} - when - (FStar_Compiler_List.length - bs) - >= (Prims.of_int (2)) - -> - let uu___13 = - FStar_Syntax_Subst.open_binders - bs in - (match uu___13 with - | { - FStar_Syntax_Syntax.binder_bv - = a'; - FStar_Syntax_Syntax.binder_qual - = uu___14; - FStar_Syntax_Syntax.binder_positivity - = uu___15; - FStar_Syntax_Syntax.binder_attrs - = uu___16;_}:: - { - FStar_Syntax_Syntax.binder_bv - = x'; - FStar_Syntax_Syntax.binder_qual - = uu___17; - FStar_Syntax_Syntax.binder_positivity - = uu___18; - FStar_Syntax_Syntax.binder_attrs - = uu___19;_}::bs1 - -> - let uu___20 = - let uu___21 = - let uu___22 = - let uu___23 = - FStar_Syntax_Syntax.bv_to_name - x_a.FStar_Syntax_Syntax.binder_bv in - (x', uu___23) in - FStar_Syntax_Syntax.NT - uu___22 in - [uu___21] in - let uu___21 = - let uu___22 = - let uu___23 = - let uu___24 = - let uu___25 = - FStar_Syntax_Syntax.bv_to_name - a.FStar_Syntax_Syntax.binder_bv in - (a', uu___25) in - FStar_Syntax_Syntax.NT - uu___24 in - [uu___23] in - FStar_Syntax_Subst.subst_binders - uu___22 bs1 in - FStar_Syntax_Subst.subst_binders - uu___20 uu___21) - | uu___12 -> - not_an_arrow_error "return" - (Prims.of_int (2)) ty r in - let bs = a :: x_a :: rest_bs in - let uu___11 = - let uu___12 = - FStar_TypeChecker_Env.push_binders - env bs in - let uu___13 = - FStar_Syntax_Syntax.bv_to_name - a.FStar_Syntax_Syntax.binder_bv in - fresh_repr r uu___12 u_a - uu___13 in - (match uu___11 with - | (repr1, g) -> - let k = - let uu___12 = - FStar_Syntax_Syntax.mk_Total - repr1 in - FStar_Syntax_Util.arrow bs - uu___12 in - let g_eq = - FStar_TypeChecker_Rel.teq - env ty k in - ((let uu___13 = - FStar_TypeChecker_Env.conj_guard - g g_eq in - FStar_TypeChecker_Rel.force_trivial_guard - env uu___13); - (let k1 = - FStar_TypeChecker_Normalize.remove_uvar_solutions - env k in - let uu___13 = - FStar_Syntax_Subst.close_univ_vars - us k1 in - (ret_us, ret_t, uu___13))))))) in - log_combinator "return_repr" return_repr; - (let uu___8 = - FStar_Errors.with_ctx - "While checking the bind combinator" - (fun uu___9 -> - let bind_repr_ts = - let uu___10 = - FStar_Syntax_Util.get_bind_repr ed in - FStar_Compiler_Util.must uu___10 in - let r = - (FStar_Pervasives_Native.snd bind_repr_ts).FStar_Syntax_Syntax.pos in - let uu___10 = - check_and_gen1 "bind_repr" - (Prims.of_int (2)) bind_repr_ts in - match uu___10 with - | (bind_us, bind_t, bind_ty) -> - let uu___11 = - FStar_Syntax_Subst.open_univ_vars - bind_us bind_ty in - (match uu___11 with - | (us, ty) -> - let env = - FStar_TypeChecker_Env.push_univ_vars - env0 us in - let uu___12 = - let sig_ts = - let uu___13 = signature in - match uu___13 with - | (us1, t, uu___14) -> (us1, t) in - let repr_ts = - let uu___13 = repr in - match uu___13 with - | (us1, t, uu___14) -> (us1, t) in - let uu___13 = - FStar_Syntax_Util.has_attribute - ed.FStar_Syntax_Syntax.eff_attrs - FStar_Parser_Const.bind_has_range_args_attr in - validate_indexed_effect_bind_shape - env ed.FStar_Syntax_Syntax.mname - ed.FStar_Syntax_Syntax.mname - ed.FStar_Syntax_Syntax.mname - sig_ts sig_ts sig_ts - (FStar_Pervasives_Native.Some - repr_ts) - (FStar_Pervasives_Native.Some - repr_ts) - (FStar_Pervasives_Native.Some - repr_ts) us ty r - num_effect_params uu___13 in - (match uu___12 with - | (k, kind) -> - let uu___13 = - let uu___14 = - FStar_Syntax_Subst.close_univ_vars - bind_us k in - (bind_us, bind_t, uu___14) in - (uu___13, kind)))) in - match uu___8 with - | (bind_repr, bind_kind) -> - (log_combinator "bind_repr" bind_repr; - (let uu___10 = - FStar_Errors.with_ctx - "While checking the subcomp combinator" - (fun uu___11 -> - let stronger_repr = - let ts = - let uu___12 = - FStar_Syntax_Util.get_stronger_repr - ed in - FStar_Compiler_Util.must uu___12 in - let uu___12 = - let uu___13 = - FStar_Syntax_Subst.compress - (FStar_Pervasives_Native.snd ts) in - uu___13.FStar_Syntax_Syntax.n in - match uu___12 with - | FStar_Syntax_Syntax.Tm_unknown -> - let signature_ts = - let uu___13 = signature in - match uu___13 with - | (us, t, uu___14) -> (us, t) in - let uu___13 = - FStar_TypeChecker_Env.inst_tscheme_with - signature_ts - [FStar_Syntax_Syntax.U_unknown] in - (match uu___13 with - | (uu___14, signature_t) -> - let uu___15 = - let uu___16 = - FStar_Syntax_Subst.compress - signature_t in - uu___16.FStar_Syntax_Syntax.n in - (match uu___15 with - | FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 - = bs; - FStar_Syntax_Syntax.comp - = uu___16;_} - -> - let bs1 = - FStar_Syntax_Subst.open_binders - bs in - let repr_t = - let repr_ts = - let uu___17 = repr in - match uu___17 with - | (us, t, uu___18) - -> (us, t) in - let uu___17 = - FStar_TypeChecker_Env.inst_tscheme_with - repr_ts - [FStar_Syntax_Syntax.U_unknown] in - FStar_Pervasives_Native.snd - uu___17 in - let repr_t_applied = - let uu___17 = - let uu___18 = - let uu___19 = - let uu___20 = - let uu___21 = - FStar_Compiler_List.map - (fun b -> - b.FStar_Syntax_Syntax.binder_bv) - bs1 in - FStar_Compiler_List.map - FStar_Syntax_Syntax.bv_to_name - uu___21 in - FStar_Compiler_List.map - FStar_Syntax_Syntax.as_arg - uu___20 in - { - FStar_Syntax_Syntax.hd - = repr_t; - FStar_Syntax_Syntax.args - = uu___19 - } in - FStar_Syntax_Syntax.Tm_app - uu___18 in - let uu___18 = - FStar_Ident.range_of_lid - ed.FStar_Syntax_Syntax.mname in - FStar_Syntax_Syntax.mk - uu___17 uu___18 in - let f_b = - FStar_Syntax_Syntax.null_binder - repr_t_applied in - let uu___17 = - let uu___18 = - let uu___19 = - FStar_Syntax_Syntax.bv_to_name - f_b.FStar_Syntax_Syntax.binder_bv in - FStar_Syntax_Util.abs - (FStar_Compiler_List.op_At - bs1 [f_b]) - uu___19 - FStar_Pervasives_Native.None in - let uu___19 = - FStar_Ident.range_of_lid - ed.FStar_Syntax_Syntax.mname in - { - FStar_Syntax_Syntax.n - = - (uu___18.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos - = uu___19; - FStar_Syntax_Syntax.vars - = - (uu___18.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code - = - (uu___18.FStar_Syntax_Syntax.hash_code) - } in - ([], uu___17) - | uu___16 -> - failwith "Impossible!")) - | uu___13 -> ts in - let r = - (FStar_Pervasives_Native.snd - stronger_repr).FStar_Syntax_Syntax.pos in - let uu___12 = - check_and_gen1 "stronger_repr" - Prims.int_one stronger_repr in - match uu___12 with - | (stronger_us, stronger_t, stronger_ty) - -> - ((let uu___14 = - FStar_Compiler_Effect.op_Bang - dbg_LayeredEffectsTc in - if uu___14 - then - let uu___15 = - FStar_Syntax_Print.tscheme_to_string - (stronger_us, stronger_t) in - let uu___16 = - FStar_Syntax_Print.tscheme_to_string - (stronger_us, stronger_ty) in - FStar_Compiler_Util.print2 - "stronger combinator typechecked with term: %s and type: %s\n" - uu___15 uu___16 - else ()); - (let uu___14 = - FStar_Syntax_Subst.open_univ_vars - stronger_us stronger_ty in - match uu___14 with - | (us, ty) -> - let env = - FStar_TypeChecker_Env.push_univ_vars - env0 us in - let uu___15 = - let sig_ts = - let uu___16 = signature in - match uu___16 with - | (us1, t, uu___17) -> - (us1, t) in - let repr_ts = - let uu___16 = repr in - match uu___16 with - | (us1, t, uu___17) -> - (us1, t) in - let uu___16 = - FStar_Compiler_List.hd us in - validate_indexed_effect_subcomp_shape - env - ed.FStar_Syntax_Syntax.mname - ed.FStar_Syntax_Syntax.mname - sig_ts sig_ts - (FStar_Pervasives_Native.Some - repr_ts) - (FStar_Pervasives_Native.Some - repr_ts) uu___16 ty - num_effect_params r in - (match uu___15 with - | (k, kind) -> - let uu___16 = - let uu___17 = - FStar_Syntax_Subst.close_univ_vars - stronger_us k in - (stronger_us, - stronger_t, uu___17) in - (uu___16, kind))))) in - match uu___10 with - | (stronger_repr, subcomp_kind) -> - (log_combinator "stronger_repr" - stronger_repr; - (let uu___12 = - FStar_Errors.with_ctx - "While checking the if_then_else combinator" - (fun uu___13 -> - let if_then_else_ts = - let ts = - let uu___14 = - let uu___15 = - FStar_Syntax_Util.get_layered_if_then_else_combinator - ed in - FStar_Compiler_Util.must - uu___15 in - FStar_Pervasives_Native.fst - uu___14 in - let uu___14 = - let uu___15 = - FStar_Syntax_Subst.compress - (FStar_Pervasives_Native.snd - ts) in - uu___15.FStar_Syntax_Syntax.n in - match uu___14 with - | FStar_Syntax_Syntax.Tm_unknown - -> - let signature_ts = - let uu___15 = signature in - match uu___15 with - | (us, t, uu___16) -> - (us, t) in - let uu___15 = - FStar_TypeChecker_Env.inst_tscheme_with - signature_ts - [FStar_Syntax_Syntax.U_unknown] in - (match uu___15 with - | (uu___16, signature_t) -> - let uu___17 = - let uu___18 = - FStar_Syntax_Subst.compress - signature_t in - uu___18.FStar_Syntax_Syntax.n in - (match uu___17 with - | FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 - = bs; - FStar_Syntax_Syntax.comp - = uu___18;_} - -> - let bs1 = - FStar_Syntax_Subst.open_binders - bs in - let repr_t = - let repr_ts = - let uu___19 = - repr in - match uu___19 - with - | (us, t, - uu___20) -> - (us, t) in - let uu___19 = - FStar_TypeChecker_Env.inst_tscheme_with - repr_ts - [FStar_Syntax_Syntax.U_unknown] in - FStar_Pervasives_Native.snd - uu___19 in - let repr_t_applied - = - let uu___19 = - let uu___20 = - let uu___21 - = - let uu___22 - = - let uu___23 - = - FStar_Compiler_List.map - (fun b -> - b.FStar_Syntax_Syntax.binder_bv) - bs1 in - FStar_Compiler_List.map - FStar_Syntax_Syntax.bv_to_name - uu___23 in - FStar_Compiler_List.map - FStar_Syntax_Syntax.as_arg - uu___22 in - { - FStar_Syntax_Syntax.hd - = repr_t; - FStar_Syntax_Syntax.args - = uu___21 - } in - FStar_Syntax_Syntax.Tm_app - uu___20 in - let uu___20 = - FStar_Ident.range_of_lid - ed.FStar_Syntax_Syntax.mname in - FStar_Syntax_Syntax.mk - uu___19 - uu___20 in - let f_b = - FStar_Syntax_Syntax.null_binder - repr_t_applied in - let g_b = - FStar_Syntax_Syntax.null_binder - repr_t_applied in - let b_b = - FStar_Syntax_Syntax.null_binder - FStar_Syntax_Util.t_bool in - let uu___19 = - let uu___20 = - FStar_Syntax_Util.abs - (FStar_Compiler_List.op_At - bs1 - [f_b; - g_b; - b_b]) - repr_t_applied - FStar_Pervasives_Native.None in - let uu___21 = - FStar_Ident.range_of_lid - ed.FStar_Syntax_Syntax.mname in - { - FStar_Syntax_Syntax.n - = - (uu___20.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos - = uu___21; - FStar_Syntax_Syntax.vars - = - (uu___20.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code - = - (uu___20.FStar_Syntax_Syntax.hash_code) - } in - ([], uu___19) - | uu___18 -> - failwith - "Impossible!")) - | uu___15 -> ts in - let r = - (FStar_Pervasives_Native.snd - if_then_else_ts).FStar_Syntax_Syntax.pos in - let uu___14 = - check_and_gen1 "if_then_else" - Prims.int_one if_then_else_ts in - match uu___14 with - | (if_then_else_us, - if_then_else_t, - if_then_else_ty) -> - let uu___15 = - FStar_Syntax_Subst.open_univ_vars - if_then_else_us - if_then_else_t in - (match uu___15 with - | (us, t) -> - let uu___16 = - FStar_Syntax_Subst.open_univ_vars - if_then_else_us - if_then_else_ty in - (match uu___16 with - | (uu___17, ty) -> - let env = - FStar_TypeChecker_Env.push_univ_vars - env0 us in - let uu___18 = - let sig_ts = - let uu___19 = - signature in - match uu___19 - with - | (us1, t1, - uu___20) -> - (us1, t1) in - let repr_ts = - let uu___19 = - repr in - match uu___19 - with - | (us1, t1, - uu___20) -> - (us1, t1) in - let uu___19 = - FStar_Compiler_List.hd - us in - validate_indexed_effect_ite_shape - env - ed.FStar_Syntax_Syntax.mname - sig_ts repr_ts - uu___19 ty t - num_effect_params - r in - (match uu___18 with - | (k, kind) -> - let uu___19 = - let uu___20 = - FStar_Syntax_Subst.close_univ_vars - if_then_else_us - k in - (if_then_else_us, - uu___20, - if_then_else_ty) in - (uu___19, kind))))) in - match uu___12 with - | (if_then_else, ite_kind) -> - (log_combinator "if_then_else" - if_then_else; - FStar_Errors.with_ctx - "While checking if-then-else soundness" - (fun uu___14 -> - let r = - let uu___15 = - let uu___16 = - let uu___17 = - let uu___18 = - FStar_Syntax_Util.get_layered_if_then_else_combinator - ed in - FStar_Compiler_Util.must - uu___18 in - FStar_Pervasives_Native.fst - uu___17 in - FStar_Pervasives_Native.snd - uu___16 in - uu___15.FStar_Syntax_Syntax.pos in - let uu___15 = if_then_else in - match uu___15 with - | (ite_us, ite_t, uu___16) -> - let uu___17 = - FStar_Syntax_Subst.open_univ_vars - ite_us ite_t in - (match uu___17 with - | (us, ite_t1) -> - let uu___18 = - let uu___19 = - let uu___20 = - FStar_Syntax_Subst.compress - ite_t1 in - uu___20.FStar_Syntax_Syntax.n in - match uu___19 with - | FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs - = bs; - FStar_Syntax_Syntax.body - = uu___20; - FStar_Syntax_Syntax.rc_opt - = uu___21;_} - -> - let bs1 = - FStar_Syntax_Subst.open_binders - bs in - let uu___22 = - let uu___23 = - let uu___24 - = - FStar_Compiler_List.splitAt - ((FStar_Compiler_List.length - bs1) - - (Prims.of_int (3))) - bs1 in - FStar_Pervasives_Native.snd - uu___24 in - let uu___24 = - uu___23 in - match uu___24 - with - | f::g::p::[] - -> - (f, g, p) in - (match uu___22 - with - | (f_b, g_b, - p_b) -> - let env = - let uu___23 - = - FStar_TypeChecker_Env.push_univ_vars - env0 us in - FStar_TypeChecker_Env.push_binders - uu___23 - bs1 in - let uu___23 - = - let uu___24 - = - let uu___25 - = - FStar_Compiler_List.map - (fun b -> - let uu___26 - = - FStar_Syntax_Syntax.bv_to_name - b.FStar_Syntax_Syntax.binder_bv in - let uu___27 - = - FStar_Syntax_Util.aqual_of_binder - b in - (uu___26, - uu___27)) - bs1 in - FStar_Syntax_Syntax.mk_Tm_app - ite_t1 - uu___25 r in - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Beta] - env - uu___24 in - let uu___24 - = - FStar_Compiler_List.hd - bs1 in - let uu___25 - = - FStar_Syntax_Syntax.bv_to_name - p_b.FStar_Syntax_Syntax.binder_bv in - (env, - uu___23, - uu___24, - f_b, g_b, - uu___25)) - | uu___20 -> - failwith - "Impossible! ite_t must have been an abstraction with at least 3 binders" in - (match uu___18 with - | (env, - ite_t_applied, - a_b, f_b, g_b, - p_t) -> - let uu___19 = - let uu___20 = - stronger_repr in - match uu___20 - with - | (uu___21, - uu___22, - subcomp_ty) - -> - let uu___23 - = - FStar_Syntax_Subst.open_univ_vars - us - subcomp_ty in - (match uu___23 - with - | - (uu___24, - subcomp_ty1) - -> - let uu___25 - = - let uu___26 - = - FStar_Syntax_Subst.compress - subcomp_ty1 in - uu___26.FStar_Syntax_Syntax.n in - (match uu___25 - with - | - FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 - = bs; - FStar_Syntax_Syntax.comp - = c;_} -> - let uu___26 - = - FStar_Syntax_Subst.open_comp - bs c in - (match uu___26 - with - | - (bs1, c1) - -> - let uu___27 - = - let uu___28 - = - FStar_Compiler_List.hd - bs1 in - let uu___29 - = - FStar_Compiler_List.tl - bs1 in - (uu___28, - uu___29) in - (match uu___27 - with - | - (a_b1, - rest_bs) - -> - let uu___28 - = - let uu___29 - = - FStar_Compiler_List.splitAt - ((FStar_Compiler_List.length - rest_bs) - - - Prims.int_one) - rest_bs in - match uu___29 - with - | - (l1, l2) - -> - let uu___30 - = - FStar_Compiler_List.hd - l2 in - (l1, - uu___30) in - (match uu___28 - with - | - (rest_bs1, - f_b1) -> - (a_b1, - rest_bs1, - f_b1, c1)))) - | - uu___26 - -> - failwith - "Impossible! subcomp_ty must have been an arrow with at lease 1 binder")) in - (match uu___19 - with - | (subcomp_a_b, - subcomp_bs, - subcomp_f_b, - subcomp_c) -> - let check_branch - env1 - ite_f_or_g_sort - attr_opt = - let uu___20 - = - let uu___21 - = - let uu___22 - = - let uu___23 - = - let uu___24 - = - let uu___25 - = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - ((subcomp_a_b.FStar_Syntax_Syntax.binder_bv), - uu___25) in - FStar_Syntax_Syntax.NT - uu___24 in - [uu___23] in - (uu___22, - [], - FStar_TypeChecker_Env.trivial_guard) in - FStar_Compiler_List.fold_left - (fun - uu___22 - -> - fun b -> - match uu___22 - with - | - (subst, - uvars, g) - -> - let sort - = - FStar_Syntax_Subst.subst - subst - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - let uu___23 - = - let ctx_uvar_meta - = - FStar_Compiler_Util.map_option - (fun - uu___24 - -> - FStar_Syntax_Syntax.Ctx_uvar_meta_attr - uu___24) - attr_opt in - let uu___24 - = - let uu___25 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_binder - b in - FStar_Compiler_Util.format1 - "uvar for subcomp %s binder when checking ite soundness" - uu___25 in - FStar_TypeChecker_Env.new_implicit_var_aux - uu___24 r - env1 sort - FStar_Syntax_Syntax.Strict - ctx_uvar_meta - false in - (match uu___23 - with - | - (t, - uu___24, - g_t) -> - let uu___25 - = - FStar_TypeChecker_Common.conj_guard - g g_t in - ((FStar_Compiler_List.op_At - subst - [ - FStar_Syntax_Syntax.NT - ((b.FStar_Syntax_Syntax.binder_bv), - t)]), - (FStar_Compiler_List.op_At - uvars - [t]), - uu___25))) - uu___21 - subcomp_bs in - match uu___20 - with - | - (subst, - uvars, - g_uvars) - -> - let subcomp_f_sort - = - FStar_Syntax_Subst.subst - subst - (subcomp_f_b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - let c = - let uu___21 - = - FStar_Syntax_Subst.subst_comp - subst - subcomp_c in - FStar_TypeChecker_Env.unfold_effect_abbrev - env1 - uu___21 in - let g_f_or_g - = - FStar_TypeChecker_Rel.layered_effect_teq - env1 - subcomp_f_sort - ite_f_or_g_sort - FStar_Pervasives_Native.None in - let g_c = - FStar_TypeChecker_Rel.layered_effect_teq - env1 - c.FStar_Syntax_Syntax.result_typ - ite_t_applied - FStar_Pervasives_Native.None in - let fml = - let uu___21 - = - FStar_Compiler_List.hd - c.FStar_Syntax_Syntax.comp_univs in - let uu___22 - = - let uu___23 - = - FStar_Compiler_List.hd - c.FStar_Syntax_Syntax.effect_args in - FStar_Pervasives_Native.fst - uu___23 in - FStar_TypeChecker_Env.pure_precondition_for_trivial_post - env1 - uu___21 - c.FStar_Syntax_Syntax.result_typ - uu___22 r in - let g_precondition - = - match attr_opt - with - | - FStar_Pervasives_Native.None - -> - FStar_TypeChecker_Env.guard_of_guard_formula - (FStar_TypeChecker_Common.NonTrivial - fml) - | - FStar_Pervasives_Native.Some - attr -> - let uu___21 - = - let uu___22 - = - FStar_Syntax_Util.mk_squash - FStar_Syntax_Syntax.U_zero - fml in - FStar_TypeChecker_Env.new_implicit_var_aux - "tc_layered_effect_decl.g_precondition" - r env1 - uu___22 - FStar_Syntax_Syntax.Strict - (FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Ctx_uvar_meta_attr - attr)) - false in - (match uu___21 - with - | - (uu___22, - uu___23, - g) -> g) in - let uu___21 - = - FStar_TypeChecker_Env.conj_guards - [g_uvars; - g_f_or_g; - g_c; - g_precondition] in - FStar_TypeChecker_Rel.force_trivial_guard - env1 - uu___21 in - let ite_soundness_tac_attr - = - let uu___20 - = - FStar_Syntax_Util.get_attribute - FStar_Parser_Const.ite_soundness_by_attr - attrs in - match uu___20 - with - | - FStar_Pervasives_Native.Some - ((t, - uu___21)::uu___22) - -> - FStar_Pervasives_Native.Some - t - | - uu___21 -> - FStar_Pervasives_Native.None in - ((let env1 = - let uu___20 - = - let uu___21 - = - let uu___22 - = - FStar_Syntax_Util.b2t - p_t in - FStar_Syntax_Util.mk_squash - FStar_Syntax_Syntax.U_zero - uu___22 in - FStar_Syntax_Syntax.new_bv - FStar_Pervasives_Native.None - uu___21 in - FStar_TypeChecker_Env.push_bv - env - uu___20 in - check_branch - env1 - (f_b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort - ite_soundness_tac_attr); - (let not_p - = - let uu___20 - = - let uu___21 - = - FStar_Syntax_Syntax.lid_as_fv - FStar_Parser_Const.not_lid - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm - uu___21 in - let uu___21 - = - let uu___22 - = - let uu___23 - = - FStar_Syntax_Util.b2t - p_t in - FStar_Syntax_Syntax.as_arg - uu___23 in - [uu___22] in - FStar_Syntax_Syntax.mk_Tm_app - uu___20 - uu___21 r in - let env1 = - let uu___20 - = - FStar_Syntax_Syntax.new_bv - FStar_Pervasives_Native.None - not_p in - FStar_TypeChecker_Env.push_bv - env - uu___20 in - check_branch - env1 - (g_b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort - ite_soundness_tac_attr)))))); - (let close_ = - FStar_Errors.with_ctx - "While checking the close combinator" - (fun uu___14 -> - let ts_opt = - FStar_Syntax_Util.get_layered_close_combinator - ed in - match ts_opt with - | FStar_Pervasives_Native.None - -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some - close_ts -> - let r = - (FStar_Pervasives_Native.snd - close_ts).FStar_Syntax_Syntax.pos in - let uu___15 = - check_and_gen1 "close" - (Prims.of_int (2)) - close_ts in - (match uu___15 with - | (close_us, close_t, - close_ty) -> - let uu___16 = - FStar_Syntax_Subst.open_univ_vars - close_us - close_t in - (match uu___16 with - | (us, t) -> - let env = - FStar_TypeChecker_Env.push_univ_vars - env0 us in - let k = - let sig_ts = - let uu___17 - = - signature in - match uu___17 - with - | - (us1, t1, - uu___18) - -> - (us1, t1) in - let repr_ts - = - let uu___17 - = repr in - match uu___17 - with - | - (us1, t1, - uu___18) - -> - (us1, t1) in - let uu___17 - = us in - match uu___17 - with - | u_a::u_b::[] - -> - validate_indexed_effect_close_shape - env - ed.FStar_Syntax_Syntax.mname - sig_ts - repr_ts - u_a u_b t - num_effect_params - r in - let uu___17 = - let uu___18 - = - FStar_Syntax_Subst.close_univ_vars - close_us - k in - (close_us, - uu___18, - close_ty) in - FStar_Pervasives_Native.Some - uu___17))) in - FStar_Errors.with_ctx - "While checking the soundness of the close combinator" - (fun uu___14 -> - match close_ with - | FStar_Pervasives_Native.None - -> () - | FStar_Pervasives_Native.Some - close_1 -> - let uu___15 = close_1 in - (match uu___15 with - | (us, close_tm, uu___16) - -> - let r = - close_tm.FStar_Syntax_Syntax.pos in - ((let supported_subcomp - = - match subcomp_kind - with - | FStar_Syntax_Syntax.Substitutive_combinator - l -> - Prims.op_Negation - (FStar_Compiler_List.contains - FStar_Syntax_Syntax.Ad_hoc_binder - l) - | uu___18 -> - false in - if - Prims.op_Negation - supported_subcomp - then - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - r - FStar_Errors_Codes.Fatal_UnexpectedEffect - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "close combinator is only allowed for effects with substitutive subcomp") - else ()); - (let uu___18 = - FStar_Syntax_Subst.open_univ_vars - us close_tm in - match uu___18 with - | (us1, close_tm1) - -> - let uu___19 = - FStar_Syntax_Util.abs_formals - close_tm1 in - (match uu___19 - with - | (close_bs, - close_body, - uu___20) -> - let uu___21 - = - close_bs in - (match uu___21 - with - | - a_b::b_b::close_bs1 - -> - let uu___22 - = - FStar_Compiler_List.splitAt - ((FStar_Compiler_List.length - close_bs1) - - - Prims.int_one) - close_bs1 in - (match uu___22 - with - | - (is_bs, - uu___23) - -> - let x_bv - = - let uu___24 - = - FStar_Syntax_Syntax.bv_to_name - b_b.FStar_Syntax_Syntax.binder_bv in - FStar_Syntax_Syntax.gen_bv - "x" - FStar_Pervasives_Native.None - uu___24 in - let args1 - = - FStar_Compiler_List.map - (fun i_b - -> - let uu___24 - = - FStar_Syntax_Syntax.bv_to_name - i_b.FStar_Syntax_Syntax.binder_bv in - let uu___25 - = - let uu___26 - = - let uu___27 - = - FStar_Syntax_Syntax.bv_to_name - x_bv in - FStar_Syntax_Syntax.as_arg - uu___27 in - [uu___26] in - FStar_Syntax_Syntax.mk_Tm_app - uu___24 - uu___25 r) - is_bs in - let args2 - = - let uu___24 - = - let uu___25 - = - FStar_Syntax_Subst.compress - close_body in - uu___25.FStar_Syntax_Syntax.n in - match uu___24 - with - | - FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd - = uu___25; - FStar_Syntax_Syntax.args - = a::args;_} - -> - FStar_Compiler_List.map - FStar_Pervasives_Native.fst - args - | - uu___25 - -> - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - r - FStar_Errors_Codes.Fatal_UnexpectedEffect - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "close combinator body not a repr") in - let env = - let uu___24 - = - let uu___25 - = - let uu___26 - = - FStar_Syntax_Syntax.mk_binder - x_bv in - [uu___26] in - FStar_Compiler_List.op_At - (a_b :: - b_b :: - is_bs) - uu___25 in - FStar_TypeChecker_Env.push_binders - env0 - uu___24 in - let subcomp_ts - = - let uu___24 - = - stronger_repr in - match uu___24 - with - | - (us2, - uu___25, - t) -> - (us2, t) in - let uu___24 - = - let uu___25 - = - let uu___26 - = - let uu___27 - = - FStar_Compiler_List.hd - us1 in - FStar_Syntax_Syntax.U_name - uu___27 in - [uu___26] in - FStar_TypeChecker_Env.inst_tscheme_with - subcomp_ts - uu___25 in - (match uu___24 - with - | - (uu___25, - subcomp_t) - -> - let uu___26 - = - FStar_Syntax_Util.arrow_formals_comp - subcomp_t in - (match uu___26 - with - | - (a_b_subcomp::subcomp_bs, - subcomp_c) - -> - let subcomp_substs - = - let uu___27 - = - let uu___28 - = - let uu___29 - = - FStar_Syntax_Syntax.bv_to_name - a_b.FStar_Syntax_Syntax.binder_bv in - ((a_b_subcomp.FStar_Syntax_Syntax.binder_bv), - uu___29) in - FStar_Syntax_Syntax.NT - uu___28 in - [uu___27] in - let uu___27 - = - FStar_Compiler_List.splitAt - (FStar_Compiler_List.length - args1) - subcomp_bs in - (match uu___27 - with - | - (subcomp_f_bs, - subcomp_bs1) - -> - let subcomp_substs1 - = - let uu___28 - = - FStar_Compiler_List.map2 - (fun b -> - fun arg1 - -> - FStar_Syntax_Syntax.NT - ((b.FStar_Syntax_Syntax.binder_bv), - arg1)) - subcomp_f_bs - args1 in - FStar_Compiler_List.op_At - subcomp_substs - uu___28 in - let uu___28 - = - FStar_Compiler_List.splitAt - (FStar_Compiler_List.length - args2) - subcomp_bs1 in - (match uu___28 - with - | - (subcomp_g_bs, - uu___29) - -> - let subcomp_substs2 - = - let uu___30 - = - FStar_Compiler_List.map2 - (fun b -> - fun arg2 - -> - FStar_Syntax_Syntax.NT - ((b.FStar_Syntax_Syntax.binder_bv), - arg2)) - subcomp_g_bs - args2 in - FStar_Compiler_List.op_At - subcomp_substs1 - uu___30 in - let subcomp_c1 - = - let uu___30 - = - FStar_Syntax_Subst.subst_comp - subcomp_substs2 - subcomp_c in - FStar_TypeChecker_Env.unfold_effect_abbrev - env - uu___30 in - let fml = - let uu___30 - = - FStar_Compiler_List.hd - subcomp_c1.FStar_Syntax_Syntax.comp_univs in - let uu___31 - = - let uu___32 - = - FStar_Compiler_List.hd - subcomp_c1.FStar_Syntax_Syntax.effect_args in - FStar_Pervasives_Native.fst - uu___32 in - FStar_TypeChecker_Env.pure_precondition_for_trivial_post - env - uu___30 - subcomp_c1.FStar_Syntax_Syntax.result_typ - uu___31 r in - let uu___30 - = - FStar_TypeChecker_Env.guard_of_guard_formula - (FStar_TypeChecker_Common.NonTrivial - fml) in - FStar_TypeChecker_Rel.force_trivial_guard - env - uu___30))))))))))); - (let tc_action env act = - let env01 = env in - let r = - (act.FStar_Syntax_Syntax.action_defn).FStar_Syntax_Syntax.pos in - if - (FStar_Compiler_List.length - act.FStar_Syntax_Syntax.action_params) - <> Prims.int_zero - then - (let uu___15 = - let uu___16 = - FStar_Ident.string_of_lid - ed.FStar_Syntax_Syntax.mname in - let uu___17 = - FStar_Ident.string_of_lid - act.FStar_Syntax_Syntax.action_name in - let uu___18 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binder) - act.FStar_Syntax_Syntax.action_params in - FStar_Compiler_Util.format3 - "Action %s:%s has non-empty action params (%s)" - uu___16 uu___17 uu___18 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - r - FStar_Errors_Codes.Fatal_MalformedActionDeclaration - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___15)) - else (); - (let uu___15 = - let uu___16 = - FStar_Syntax_Subst.univ_var_opening - act.FStar_Syntax_Syntax.action_univs in - match uu___16 with - | (usubst, us) -> - let uu___17 = - FStar_TypeChecker_Env.push_univ_vars - env us in - let uu___18 = - let uu___19 = - FStar_Syntax_Subst.subst - usubst - act.FStar_Syntax_Syntax.action_defn in - let uu___20 = - FStar_Syntax_Subst.subst - usubst - act.FStar_Syntax_Syntax.action_typ in - { - FStar_Syntax_Syntax.action_name - = - (act.FStar_Syntax_Syntax.action_name); - FStar_Syntax_Syntax.action_unqualified_name - = - (act.FStar_Syntax_Syntax.action_unqualified_name); - FStar_Syntax_Syntax.action_univs - = us; - FStar_Syntax_Syntax.action_params - = - (act.FStar_Syntax_Syntax.action_params); - FStar_Syntax_Syntax.action_defn - = uu___19; - FStar_Syntax_Syntax.action_typ - = uu___20 - } in - (uu___17, uu___18) in - match uu___15 with - | (env1, act1) -> - let act_typ = - let uu___16 = - let uu___17 = - FStar_Syntax_Subst.compress - act1.FStar_Syntax_Syntax.action_typ in - uu___17.FStar_Syntax_Syntax.n in - match uu___16 with - | FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 - = bs; - FStar_Syntax_Syntax.comp - = c;_} - -> - let ct = - FStar_TypeChecker_Env.comp_to_comp_typ - env1 c in - let uu___17 = - FStar_Ident.lid_equals - ct.FStar_Syntax_Syntax.effect_name - ed.FStar_Syntax_Syntax.mname in - if uu___17 - then - let repr_ts = - let uu___18 = - repr in - match uu___18 - with - | (us, t, - uu___19) -> - (us, t) in - let repr1 = - let uu___18 = - FStar_TypeChecker_Env.inst_tscheme_with - repr_ts - ct.FStar_Syntax_Syntax.comp_univs in - FStar_Pervasives_Native.snd - uu___18 in - let repr2 = - let uu___18 = - let uu___19 = - FStar_Syntax_Syntax.as_arg - ct.FStar_Syntax_Syntax.result_typ in - uu___19 :: - (ct.FStar_Syntax_Syntax.effect_args) in - FStar_Syntax_Syntax.mk_Tm_app - repr1 uu___18 r in - let c1 = - FStar_Syntax_Syntax.mk_Total - repr2 in - FStar_Syntax_Util.arrow - bs c1 - else - act1.FStar_Syntax_Syntax.action_typ - | uu___17 -> - act1.FStar_Syntax_Syntax.action_typ in - let uu___16 = - FStar_TypeChecker_TcTerm.tc_tot_or_gtot_term - env1 act_typ in - (match uu___16 with - | (act_typ1, uu___17, g_t) - -> - let uu___18 = - let uu___19 = - let uu___20 = - FStar_TypeChecker_Env.set_expected_typ - env1 act_typ1 in - { - FStar_TypeChecker_Env.solver - = - (uu___20.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range - = - (uu___20.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule - = - (uu___20.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma - = - (uu___20.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig - = - (uu___20.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache - = - (uu___20.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules - = - (uu___20.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ - = - (uu___20.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab - = - (uu___20.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab - = - (uu___20.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp - = false; - FStar_TypeChecker_Env.effects - = - (uu___20.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize - = - (uu___20.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs - = - (uu___20.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level - = - (uu___20.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars - = - (uu___20.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict - = - (uu___20.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface - = - (uu___20.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit - = - (uu___20.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes - = - (uu___20.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 - = - (uu___20.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard - = - (uu___20.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking - = - (uu___20.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping - = - (uu___20.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics - = - (uu___20.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce - = - (uu___20.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term - = - (uu___20.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (uu___20.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of - = - (uu___20.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (uu___20.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force - = - (uu___20.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (uu___20.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (uu___20.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (uu___20.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths - = - (uu___20.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns - = - (uu___20.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook - = - (uu___20.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (uu___20.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice - = - (uu___20.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess - = - (uu___20.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess - = - (uu___20.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info - = - (uu___20.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks - = - (uu___20.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv - = - (uu___20.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe - = - (uu___20.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab - = - (uu___20.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (uu___20.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (uu___20.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (uu___20.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (uu___20.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check - = - (uu___20.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl - = - (uu___20.FStar_TypeChecker_Env.missing_decl) - } in - FStar_TypeChecker_TcTerm.tc_tot_or_gtot_term - uu___19 - act1.FStar_Syntax_Syntax.action_defn in - (match uu___18 with - | (act_defn, uu___19, - g_d) -> - ((let uu___21 = - (FStar_Compiler_Debug.medium - ()) - || - (FStar_Compiler_Effect.op_Bang - dbg_LayeredEffectsTc) in - if uu___21 - then - let uu___22 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - act_defn in - let uu___23 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - act_typ1 in - FStar_Compiler_Util.print2 - "Typechecked action definition: %s and action type: %s\n" - uu___22 - uu___23 - else ()); - (let uu___21 = - let act_typ2 - = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Beta] - env1 - act_typ1 in - let uu___22 = - let uu___23 - = - FStar_Syntax_Subst.compress - act_typ2 in - uu___23.FStar_Syntax_Syntax.n in - match uu___22 - with - | FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 - = bs; - FStar_Syntax_Syntax.comp - = uu___23;_} - -> - let bs1 = - FStar_Syntax_Subst.open_binders - bs in - let env2 - = - FStar_TypeChecker_Env.push_binders - env1 bs1 in - let uu___24 - = - FStar_Syntax_Util.type_u - () in - (match uu___24 - with - | - (t, u) -> - let reason - = - let uu___25 - = - FStar_Ident.string_of_lid - ed.FStar_Syntax_Syntax.mname in - let uu___26 - = - FStar_Ident.string_of_lid - act1.FStar_Syntax_Syntax.action_name in - FStar_Compiler_Util.format2 - "implicit for return type of action %s:%s" - uu___25 - uu___26 in - let uu___25 - = - FStar_TypeChecker_Util.new_implicit_var - reason r - env2 t - false in - (match uu___25 - with - | - (a_tm, - uu___26, - g_tm) -> - let uu___27 - = - fresh_repr - r env2 u - a_tm in - (match uu___27 - with - | - (repr1, - g) -> - let uu___28 - = - let uu___29 - = - FStar_Syntax_Syntax.mk_Total - repr1 in - FStar_Syntax_Util.arrow - bs1 - uu___29 in - let uu___29 - = - FStar_TypeChecker_Env.conj_guard - g g_tm in - (uu___28, - uu___29)))) - | uu___23 -> - let uu___24 - = - let uu___25 - = - FStar_Class_Show.show - FStar_Ident.showable_lident - ed.FStar_Syntax_Syntax.mname in - let uu___26 - = - FStar_Class_Show.show - FStar_Ident.showable_lident - act1.FStar_Syntax_Syntax.action_name in - let uu___27 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - act_typ2 in - FStar_Compiler_Util.format3 - "Unexpected non-function type for action %s:%s (%s)" - uu___25 - uu___26 - uu___27 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - r - FStar_Errors_Codes.Fatal_ActionMustHaveFunctionType - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - uu___24) in - match uu___21 - with - | (k, g_k) -> - ((let uu___23 - = - (FStar_Compiler_Debug.medium - ()) || - (FStar_Compiler_Effect.op_Bang - dbg_LayeredEffectsTc) in - if - uu___23 - then - let uu___24 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - k in - FStar_Compiler_Util.print1 - "Expected action type: %s\n" - uu___24 - else ()); - (let g = - FStar_TypeChecker_Rel.teq - env1 - act_typ1 - k in - FStar_Compiler_List.iter - (FStar_TypeChecker_Rel.force_trivial_guard - env1) - [g_t; - g_d; - g_k; - g]; - ( - let uu___25 - = - (FStar_Compiler_Debug.medium - ()) || - (FStar_Compiler_Effect.op_Bang - dbg_LayeredEffectsTc) in - if - uu___25 - then - let uu___26 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - k in - FStar_Compiler_Util.print1 - "Expected action type after unification: %s\n" - uu___26 - else ()); - ( - let act_typ2 - = - let err_msg - t = - let uu___25 - = - FStar_Ident.string_of_lid - ed.FStar_Syntax_Syntax.mname in - let uu___26 - = - FStar_Ident.string_of_lid - act1.FStar_Syntax_Syntax.action_name in - let uu___27 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t in - FStar_Compiler_Util.format3 - "Unexpected (k-)type of action %s:%s, expected bs -> repr i_1 ... i_n, found: %s" - uu___25 - uu___26 - uu___27 in - let repr_args - t = - let uu___25 - = - let uu___26 - = - FStar_Syntax_Subst.compress - t in - uu___26.FStar_Syntax_Syntax.n in - match uu___25 - with - | - FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd - = head; - FStar_Syntax_Syntax.args - = a::is;_} - -> - let uu___26 - = - let uu___27 - = - FStar_Syntax_Subst.compress - head in - uu___27.FStar_Syntax_Syntax.n in - (match uu___26 - with - | - FStar_Syntax_Syntax.Tm_uinst - (uu___27, - us) -> - (us, - (FStar_Pervasives_Native.fst - a), is) - | - uu___27 - -> - let uu___28 - = - err_msg t in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - r - FStar_Errors_Codes.Fatal_ActionMustHaveFunctionType - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - uu___28)) - | - uu___26 - -> - let uu___27 - = - err_msg t in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - r - FStar_Errors_Codes.Fatal_ActionMustHaveFunctionType - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - uu___27) in - let k1 = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Beta] - env1 k in - let uu___25 - = - let uu___26 - = - FStar_Syntax_Subst.compress - k1 in - uu___26.FStar_Syntax_Syntax.n in - match uu___25 - with - | - FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 - = bs; - FStar_Syntax_Syntax.comp - = c;_} -> - let uu___26 - = - FStar_Syntax_Subst.open_comp - bs c in - (match uu___26 - with - | - (bs1, c1) - -> - let uu___27 - = - repr_args - (FStar_Syntax_Util.comp_result - c1) in - (match uu___27 - with - | - (us, a, - is) -> - let ct = - { - FStar_Syntax_Syntax.comp_univs - = us; - FStar_Syntax_Syntax.effect_name - = - (ed.FStar_Syntax_Syntax.mname); - FStar_Syntax_Syntax.result_typ - = a; - FStar_Syntax_Syntax.effect_args - = is; - FStar_Syntax_Syntax.flags - = [] - } in - let uu___28 - = - FStar_Syntax_Syntax.mk_Comp - ct in - FStar_Syntax_Util.arrow - bs1 - uu___28)) - | - uu___26 - -> - let uu___27 - = - err_msg - k1 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - r - FStar_Errors_Codes.Fatal_ActionMustHaveFunctionType - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - uu___27) in - ( - let uu___26 - = - (FStar_Compiler_Debug.medium - ()) || - (FStar_Compiler_Effect.op_Bang - dbg_LayeredEffectsTc) in - if - uu___26 - then - let uu___27 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - act_typ2 in - FStar_Compiler_Util.print1 - "Action type after injecting it into the monad: %s\n" - uu___27 - else ()); - ( - let act2 - = - let uu___26 - = - FStar_TypeChecker_Generalize.generalize_universes - env1 - act_defn in - match uu___26 - with - | - (us, - act_defn1) - -> - if - act1.FStar_Syntax_Syntax.action_univs - = [] - then - let uu___27 - = - FStar_Syntax_Subst.close_univ_vars - us - act_typ2 in - { - FStar_Syntax_Syntax.action_name - = - (act1.FStar_Syntax_Syntax.action_name); - FStar_Syntax_Syntax.action_unqualified_name - = - (act1.FStar_Syntax_Syntax.action_unqualified_name); - FStar_Syntax_Syntax.action_univs - = us; - FStar_Syntax_Syntax.action_params - = - (act1.FStar_Syntax_Syntax.action_params); - FStar_Syntax_Syntax.action_defn - = - act_defn1; - FStar_Syntax_Syntax.action_typ - = uu___27 - } - else - (let uu___28 - = - ((FStar_Compiler_List.length - us) = - (FStar_Compiler_List.length - act1.FStar_Syntax_Syntax.action_univs)) - && - (FStar_Compiler_List.forall2 - (fun u1 - -> - fun u2 -> - let uu___29 - = - FStar_Syntax_Syntax.order_univ_name - u1 u2 in - uu___29 = - Prims.int_zero) - us - act1.FStar_Syntax_Syntax.action_univs) in - if - uu___28 - then - let uu___29 - = - FStar_Syntax_Subst.close_univ_vars - act1.FStar_Syntax_Syntax.action_univs - act_typ2 in - { - FStar_Syntax_Syntax.action_name - = - (act1.FStar_Syntax_Syntax.action_name); - FStar_Syntax_Syntax.action_unqualified_name - = - (act1.FStar_Syntax_Syntax.action_unqualified_name); - FStar_Syntax_Syntax.action_univs - = - (act1.FStar_Syntax_Syntax.action_univs); - FStar_Syntax_Syntax.action_params - = - (act1.FStar_Syntax_Syntax.action_params); - FStar_Syntax_Syntax.action_defn - = - act_defn1; - FStar_Syntax_Syntax.action_typ - = uu___29 - } - else - (let uu___30 - = - let uu___31 - = - FStar_Ident.string_of_lid - ed.FStar_Syntax_Syntax.mname in - let uu___32 - = - FStar_Ident.string_of_lid - act1.FStar_Syntax_Syntax.action_name in - let uu___33 - = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Ident.showable_ident) - us in - let uu___34 - = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Ident.showable_ident) - act1.FStar_Syntax_Syntax.action_univs in - FStar_Compiler_Util.format4 - "Expected and generalized universes in the declaration for %s:%s are different, input: %s, but after gen: %s" - uu___31 - uu___32 - uu___33 - uu___34 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - r - FStar_Errors_Codes.Fatal_UnexpectedNumberOfUniverse - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - uu___30))) in - act2))))))))) in - let tc_action_with_ctx env act = - let uu___14 = - let uu___15 = - FStar_Ident.string_of_lid - act.FStar_Syntax_Syntax.action_name in - FStar_Compiler_Util.format1 - "While checking the action %s" - uu___15 in - FStar_Errors.with_ctx uu___14 - (fun uu___15 -> - tc_action env act) in - let extraction_mode = - let has_primitive_extraction = - FStar_Syntax_Util.has_attribute - ed.FStar_Syntax_Syntax.eff_attrs - FStar_Parser_Const.primitive_extraction_attr in - let is_reifiable = - FStar_Compiler_List.contains - FStar_Syntax_Syntax.Reifiable - quals in - if - has_primitive_extraction && - is_reifiable - then - let uu___14 = - let uu___15 = - FStar_Class_Show.show - FStar_Ident.showable_lident - ed.FStar_Syntax_Syntax.mname in - FStar_Compiler_Util.format1 - "Effect %s is declared to be both primitive extraction and reifiable" - uu___15 in - FStar_Errors.raise_error - FStar_Ident.hasrange_lident - ed.FStar_Syntax_Syntax.mname - FStar_Errors_Codes.Fatal_UnexpectedEffect - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___14) - else - if has_primitive_extraction - then - FStar_Syntax_Syntax.Extract_primitive - else - (let uu___16 = - let uu___17 = - let uu___18 = signature in - match uu___18 with - | (us, t, uu___19) -> - (us, t) in - match uu___17 with - | (us, t) -> - let uu___18 = - let uu___19 = - FStar_Syntax_Subst.compress - t in - uu___19.FStar_Syntax_Syntax.n in - (match uu___18 with - | FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 - = bs; - FStar_Syntax_Syntax.comp - = uu___19;_} - -> - let uu___20 = - FStar_Syntax_Subst.open_binders - bs in - (match uu___20 - with - | a_b::rest_bs - -> - (us, a_b, - rest_bs)) - | uu___19 -> - failwith - "Impossible!") in - match uu___16 with - | (us, a_b, rest_bs) -> - let env = - FStar_TypeChecker_Env.push_univ_vars - env0 us in - let env1 = - FStar_TypeChecker_Env.push_binders - env [a_b] in - let uu___17 = - FStar_Compiler_List.fold_left - (fun uu___18 -> - fun b -> - match uu___18 - with - | (env2, r) -> - let r1 = - r && - (FStar_TypeChecker_Normalize.non_info_norm - env2 - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort) in - let uu___19 - = - FStar_TypeChecker_Env.push_binders - env2 - [b] in - (uu___19, - r1)) - (env1, true) - rest_bs in - (match uu___17 with - | (uu___18, r) -> - let uu___19 = - (r && - (FStar_Syntax_Syntax.uu___is_Substitutive_combinator - bind_kind)) - && - (is_reifiable - || - (FStar_Ident.lid_equals - ed.FStar_Syntax_Syntax.mname - FStar_Parser_Const.effect_TAC_lid)) in - if uu___19 - then - FStar_Syntax_Syntax.Extract_reify - else - (let m = - if - Prims.op_Negation - r - then - "one or more effect indices are informative" - else - if - Prims.op_Negation - (FStar_Syntax_Syntax.uu___is_Substitutive_combinator - bind_kind) - then - "bind is not substitutive" - else - "the effect is not reifiable" in - FStar_Syntax_Syntax.Extract_none - m))) in - (let uu___15 = - FStar_Compiler_Effect.op_Bang - dbg_LayeredEffectsTc in - if uu___15 - then - let uu___16 = - FStar_Class_Show.show - FStar_Ident.showable_lident - ed.FStar_Syntax_Syntax.mname in - let uu___17 = - FStar_Class_Show.show - FStar_Syntax_Syntax.showable_eff_extraction_mode - extraction_mode in - FStar_Compiler_Util.print2 - "Effect %s has extraction mode %s\n" - uu___16 uu___17 - else ()); - (let tschemes_of uu___15 k = - match uu___15 with - | (us, t, ty) -> - ((us, t), (us, ty), k) in - let tschemes_of2 uu___15 = - match uu___15 with - | (us, t, ty) -> - ((us, t), (us, ty)) in - let combinators = - FStar_Syntax_Syntax.Layered_eff - { - FStar_Syntax_Syntax.l_repr - = (tschemes_of2 repr); - FStar_Syntax_Syntax.l_return - = - (tschemes_of2 return_repr); - FStar_Syntax_Syntax.l_bind - = - (tschemes_of bind_repr - (FStar_Pervasives_Native.Some - bind_kind)); - FStar_Syntax_Syntax.l_subcomp - = - (tschemes_of - stronger_repr - (FStar_Pervasives_Native.Some - subcomp_kind)); - FStar_Syntax_Syntax.l_if_then_else - = - (tschemes_of if_then_else - (FStar_Pervasives_Native.Some - ite_kind)); - FStar_Syntax_Syntax.l_close - = - (match close_ with - | FStar_Pervasives_Native.None - -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some - (us, t, ty) -> - FStar_Pervasives_Native.Some - ((us, t), - (us, ty))) - } in - let uu___15 = - FStar_Compiler_List.map - (tc_action_with_ctx env0) - ed.FStar_Syntax_Syntax.actions in - { - FStar_Syntax_Syntax.mname = - (ed.FStar_Syntax_Syntax.mname); - FStar_Syntax_Syntax.cattributes - = - (ed.FStar_Syntax_Syntax.cattributes); - FStar_Syntax_Syntax.univs = - (ed.FStar_Syntax_Syntax.univs); - FStar_Syntax_Syntax.binders = - (ed.FStar_Syntax_Syntax.binders); - FStar_Syntax_Syntax.signature = - (FStar_Syntax_Syntax.Layered_eff_sig - (num_effect_params, - (let uu___16 = signature in - match uu___16 with - | (us, t, uu___17) -> - (us, t)))); - FStar_Syntax_Syntax.combinators - = combinators; - FStar_Syntax_Syntax.actions = - uu___15; - FStar_Syntax_Syntax.eff_attrs = - (ed.FStar_Syntax_Syntax.eff_attrs); - FStar_Syntax_Syntax.extraction_mode - = extraction_mode - })))))))))))))) -let (tc_non_layered_eff_decl : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.eff_decl -> - FStar_Syntax_Syntax.qualifier Prims.list -> - FStar_Syntax_Syntax.attribute Prims.list -> - FStar_Syntax_Syntax.eff_decl) - = - fun env0 -> - fun ed -> - fun _quals -> - fun _attrs -> - let uu___ = - let uu___1 = - FStar_Ident.string_of_lid ed.FStar_Syntax_Syntax.mname in - FStar_Compiler_Util.format1 - "While checking effect definition `%s`" uu___1 in - FStar_Errors.with_ctx uu___ - (fun uu___1 -> - (let uu___3 = FStar_Compiler_Effect.op_Bang dbg in - if uu___3 - then - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_eff_decl ed in - FStar_Compiler_Util.print1 - "Typechecking eff_decl: \n\t%s\n" uu___4 - else ()); - (let uu___3 = - let uu___4 = - FStar_Syntax_Subst.univ_var_opening - ed.FStar_Syntax_Syntax.univs in - match uu___4 with - | (ed_univs_subst, ed_univs) -> - let bs = - let uu___5 = - FStar_Syntax_Subst.subst_binders ed_univs_subst - ed.FStar_Syntax_Syntax.binders in - FStar_Syntax_Subst.open_binders uu___5 in - let uu___5 = - let uu___6 = - FStar_TypeChecker_Env.push_univ_vars env0 ed_univs in - FStar_TypeChecker_TcTerm.tc_tparams uu___6 bs in - (match uu___5 with - | (bs1, uu___6, uu___7) -> - let uu___8 = - let tmp_t = - let uu___9 = - FStar_Syntax_Syntax.mk_Total - FStar_Syntax_Syntax.t_unit in - FStar_Syntax_Util.arrow bs1 uu___9 in - let uu___9 = - FStar_TypeChecker_Generalize.generalize_universes - env0 tmp_t in - match uu___9 with - | (us, tmp_t1) -> - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Syntax_Util.arrow_formals tmp_t1 in - FStar_Pervasives_Native.fst uu___12 in - FStar_Syntax_Subst.close_binders uu___11 in - (us, uu___10) in - (match uu___8 with - | (us, bs2) -> - (match ed_univs with - | [] -> (us, bs2) - | uu___9 -> - let uu___10 = - ((FStar_Compiler_List.length ed_univs) - = (FStar_Compiler_List.length us)) - && - (FStar_Compiler_List.forall2 - (fun u1 -> - fun u2 -> - let uu___11 = - FStar_Syntax_Syntax.order_univ_name - u1 u2 in - uu___11 = Prims.int_zero) - ed_univs us) in - if uu___10 - then (us, bs2) - else - (let uu___12 = - let uu___13 = - let uu___14 = - FStar_Errors_Msg.text - "Expected and generalized universes in effect declaration for" in - let uu___15 = - let uu___16 = - let uu___17 = - FStar_Ident.string_of_lid - ed.FStar_Syntax_Syntax.mname in - FStar_Pprint.doc_of_string - uu___17 in - let uu___17 = - FStar_Errors_Msg.text - "are different" in - FStar_Pprint.op_Hat_Slash_Hat - uu___16 uu___17 in - FStar_Pprint.op_Hat_Slash_Hat - uu___14 uu___15 in - let uu___14 = - let uu___15 = - let uu___16 = - FStar_Errors_Msg.text - "Expected" in - let uu___17 = - let uu___18 = - FStar_Class_PP.pp - FStar_Class_PP.pp_int - (FStar_Compiler_List.length - ed_univs) in - let uu___19 = - let uu___20 = - FStar_Errors_Msg.text - "but found" in - let uu___21 = - FStar_Class_PP.pp - FStar_Class_PP.pp_int - (FStar_Compiler_List.length - us) in - FStar_Pprint.op_Hat_Slash_Hat - uu___20 uu___21 in - FStar_Pprint.op_Hat_Slash_Hat - uu___18 uu___19 in - FStar_Pprint.op_Hat_Slash_Hat - uu___16 uu___17 in - [uu___15] in - uu___13 :: uu___14 in - FStar_Errors.raise_error - FStar_Ident.hasrange_lident - ed.FStar_Syntax_Syntax.mname - FStar_Errors_Codes.Fatal_UnexpectedNumberOfUniverse - () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___12))))) in - match uu___3 with - | (us, bs) -> - let ed1 = - { - FStar_Syntax_Syntax.mname = - (ed.FStar_Syntax_Syntax.mname); - FStar_Syntax_Syntax.cattributes = - (ed.FStar_Syntax_Syntax.cattributes); - FStar_Syntax_Syntax.univs = us; - FStar_Syntax_Syntax.binders = bs; - FStar_Syntax_Syntax.signature = - (ed.FStar_Syntax_Syntax.signature); - FStar_Syntax_Syntax.combinators = - (ed.FStar_Syntax_Syntax.combinators); - FStar_Syntax_Syntax.actions = - (ed.FStar_Syntax_Syntax.actions); - FStar_Syntax_Syntax.eff_attrs = - (ed.FStar_Syntax_Syntax.eff_attrs); - FStar_Syntax_Syntax.extraction_mode = - (ed.FStar_Syntax_Syntax.extraction_mode) - } in - let uu___4 = FStar_Syntax_Subst.univ_var_opening us in - (match uu___4 with - | (ed_univs_subst, ed_univs) -> - let uu___5 = - let uu___6 = - FStar_Syntax_Subst.subst_binders ed_univs_subst - bs in - FStar_Syntax_Subst.open_binders' uu___6 in - (match uu___5 with - | (ed_bs, ed_bs_subst) -> - let ed2 = - let op uu___6 = - match uu___6 with - | (us1, t) -> - let t1 = - let uu___7 = - FStar_Syntax_Subst.shift_subst - ((FStar_Compiler_List.length - ed_bs) - + - (FStar_Compiler_List.length - us1)) ed_univs_subst in - FStar_Syntax_Subst.subst uu___7 t in - let uu___7 = - let uu___8 = - FStar_Syntax_Subst.shift_subst - (FStar_Compiler_List.length us1) - ed_bs_subst in - FStar_Syntax_Subst.subst uu___8 t1 in - (us1, uu___7) in - let uu___6 = - FStar_Syntax_Util.apply_eff_sig op - ed1.FStar_Syntax_Syntax.signature in - let uu___7 = - FStar_Syntax_Util.apply_eff_combinators op - ed1.FStar_Syntax_Syntax.combinators in - let uu___8 = - FStar_Compiler_List.map - (fun a -> - let uu___9 = - let uu___10 = - op - ((a.FStar_Syntax_Syntax.action_univs), - (a.FStar_Syntax_Syntax.action_defn)) in - FStar_Pervasives_Native.snd uu___10 in - let uu___10 = - let uu___11 = - op - ((a.FStar_Syntax_Syntax.action_univs), - (a.FStar_Syntax_Syntax.action_typ)) in - FStar_Pervasives_Native.snd uu___11 in - { - FStar_Syntax_Syntax.action_name = - (a.FStar_Syntax_Syntax.action_name); - FStar_Syntax_Syntax.action_unqualified_name - = - (a.FStar_Syntax_Syntax.action_unqualified_name); - FStar_Syntax_Syntax.action_univs = - (a.FStar_Syntax_Syntax.action_univs); - FStar_Syntax_Syntax.action_params = - (a.FStar_Syntax_Syntax.action_params); - FStar_Syntax_Syntax.action_defn = - uu___9; - FStar_Syntax_Syntax.action_typ = - uu___10 - }) ed1.FStar_Syntax_Syntax.actions in - { - FStar_Syntax_Syntax.mname = - (ed1.FStar_Syntax_Syntax.mname); - FStar_Syntax_Syntax.cattributes = - (ed1.FStar_Syntax_Syntax.cattributes); - FStar_Syntax_Syntax.univs = - (ed1.FStar_Syntax_Syntax.univs); - FStar_Syntax_Syntax.binders = - (ed1.FStar_Syntax_Syntax.binders); - FStar_Syntax_Syntax.signature = uu___6; - FStar_Syntax_Syntax.combinators = uu___7; - FStar_Syntax_Syntax.actions = uu___8; - FStar_Syntax_Syntax.eff_attrs = - (ed1.FStar_Syntax_Syntax.eff_attrs); - FStar_Syntax_Syntax.extraction_mode = - (ed1.FStar_Syntax_Syntax.extraction_mode) - } in - ((let uu___7 = - FStar_Compiler_Effect.op_Bang dbg in - if uu___7 - then - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_eff_decl - ed2 in - FStar_Compiler_Util.print1 - "After typechecking binders eff_decl: \n\t%s\n" - uu___8 - else ()); - (let env = - let uu___7 = - FStar_TypeChecker_Env.push_univ_vars env0 - ed_univs in - FStar_TypeChecker_Env.push_binders uu___7 - ed_bs in - let check_and_gen' comb n env_opt uu___7 k = - match uu___7 with - | (us1, t) -> - let env1 = - if - FStar_Compiler_Util.is_some env_opt - then FStar_Compiler_Util.must env_opt - else env in - let uu___8 = - FStar_Syntax_Subst.open_univ_vars us1 - t in - (match uu___8 with - | (us2, t1) -> - let t2 = - match k with - | FStar_Pervasives_Native.Some - k1 -> - let uu___9 = - FStar_TypeChecker_Env.push_univ_vars - env1 us2 in - FStar_TypeChecker_TcTerm.tc_check_trivial_guard - uu___9 t1 k1 - | FStar_Pervasives_Native.None - -> - let uu___9 = - let uu___10 = - FStar_TypeChecker_Env.push_univ_vars - env1 us2 in - FStar_TypeChecker_TcTerm.tc_tot_or_gtot_term - uu___10 t1 in - (match uu___9 with - | (t3, uu___10, g) -> - (FStar_TypeChecker_Rel.force_trivial_guard - env1 g; - t3)) in - let uu___9 = - FStar_TypeChecker_Generalize.generalize_universes - env1 t2 in - (match uu___9 with - | (g_us, t3) -> - (if - (FStar_Compiler_List.length - g_us) - <> n - then - (let error = - let uu___11 = - FStar_Ident.string_of_lid - ed2.FStar_Syntax_Syntax.mname in - let uu___12 = - FStar_Compiler_Util.string_of_int - n in - let uu___13 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length - g_us) in - FStar_Compiler_Util.format4 - "Expected %s:%s to be universe-polymorphic in %s universes, found %s" - uu___11 comb uu___12 - uu___13 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax - ()) t3 - FStar_Errors_Codes.Fatal_MismatchUniversePolymorphic - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic error)) - else (); - (match us2 with - | [] -> (g_us, t3) - | uu___11 -> - let uu___12 = - ((FStar_Compiler_List.length - us2) - = - (FStar_Compiler_List.length - g_us)) - && - (FStar_Compiler_List.forall2 - (fun u1 -> - fun u2 -> - let uu___13 - = - FStar_Syntax_Syntax.order_univ_name - u1 u2 in - uu___13 = - Prims.int_zero) - us2 g_us) in - if uu___12 - then (g_us, t3) - else - (let uu___14 = - let uu___15 = - FStar_Ident.string_of_lid - ed2.FStar_Syntax_Syntax.mname in - let uu___16 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length - us2) in - let uu___17 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length - g_us) in - FStar_Compiler_Util.format4 - "Expected and generalized universes in the declaration for %s:%s are different, expected: %s, but found %s" - uu___15 comb - uu___16 uu___17 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax - ()) t3 - FStar_Errors_Codes.Fatal_UnexpectedNumberOfUniverse - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___14)))))) in - let signature = - let uu___7 = - FStar_Syntax_Util.effect_sig_ts - ed2.FStar_Syntax_Syntax.signature in - check_and_gen' "signature" Prims.int_one - FStar_Pervasives_Native.None uu___7 - FStar_Pervasives_Native.None in - (let uu___8 = - FStar_Compiler_Effect.op_Bang dbg in - if uu___8 - then - let uu___9 = - FStar_Syntax_Print.tscheme_to_string - signature in - FStar_Compiler_Util.print1 - "Typechecked signature: %s\n" uu___9 - else ()); - (let fresh_a_and_wp uu___8 = - let fail t = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Syntax_Util.effect_sig_ts - ed2.FStar_Syntax_Syntax.signature in - FStar_Pervasives_Native.snd uu___11 in - uu___10.FStar_Syntax_Syntax.pos in - FStar_TypeChecker_Err.unexpected_signature_for_monad - env uu___9 - ed2.FStar_Syntax_Syntax.mname t in - let uu___9 = - FStar_TypeChecker_Env.inst_tscheme - signature in - match uu___9 with - | (uu___10, signature1) -> - let uu___11 = - let uu___12 = - FStar_Syntax_Subst.compress - signature1 in - uu___12.FStar_Syntax_Syntax.n in - (match uu___11 with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs1; - FStar_Syntax_Syntax.comp = - uu___12;_} - -> - let bs2 = - FStar_Syntax_Subst.open_binders - bs1 in - (match bs2 with - | { - FStar_Syntax_Syntax.binder_bv - = a; - FStar_Syntax_Syntax.binder_qual - = uu___13; - FStar_Syntax_Syntax.binder_positivity - = uu___14; - FStar_Syntax_Syntax.binder_attrs - = uu___15;_}::{ - FStar_Syntax_Syntax.binder_bv - = wp; - FStar_Syntax_Syntax.binder_qual - = uu___16; - FStar_Syntax_Syntax.binder_positivity - = uu___17; - FStar_Syntax_Syntax.binder_attrs - = uu___18;_}::[] - -> - (a, - (wp.FStar_Syntax_Syntax.sort)) - | uu___13 -> fail signature1) - | uu___12 -> fail signature1) in - let log_combinator s ts = - let uu___8 = - FStar_Compiler_Effect.op_Bang dbg in - if uu___8 - then - let uu___9 = - FStar_Ident.string_of_lid - ed2.FStar_Syntax_Syntax.mname in - let uu___10 = - FStar_Syntax_Print.tscheme_to_string - ts in - FStar_Compiler_Util.print3 - "Typechecked %s:%s = %s\n" uu___9 s - uu___10 - else () in - let ret_wp = - let uu___8 = fresh_a_and_wp () in - match uu___8 with - | (a, wp_sort) -> - let k = - let uu___9 = - let uu___10 = - FStar_Syntax_Syntax.mk_binder a in - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Syntax_Syntax.bv_to_name - a in - FStar_Syntax_Syntax.null_binder - uu___13 in - [uu___12] in - uu___10 :: uu___11 in - let uu___10 = - FStar_Syntax_Syntax.mk_GTotal - wp_sort in - FStar_Syntax_Util.arrow uu___9 - uu___10 in - let uu___9 = - FStar_Syntax_Util.get_return_vc_combinator - ed2 in - check_and_gen' "ret_wp" Prims.int_one - FStar_Pervasives_Native.None uu___9 - (FStar_Pervasives_Native.Some k) in - log_combinator "ret_wp" ret_wp; - (let bind_wp = - let uu___9 = fresh_a_and_wp () in - match uu___9 with - | (a, wp_sort_a) -> - let uu___10 = fresh_a_and_wp () in - (match uu___10 with - | (b, wp_sort_b) -> - let wp_sort_a_b = - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Syntax_Syntax.bv_to_name - a in - FStar_Syntax_Syntax.null_binder - uu___13 in - [uu___12] in - let uu___12 = - FStar_Syntax_Syntax.mk_Total - wp_sort_b in - FStar_Syntax_Util.arrow - uu___11 uu___12 in - let k = - let uu___11 = - let uu___12 = - FStar_Syntax_Syntax.mk_binder - a in - let uu___13 = - let uu___14 = - FStar_Syntax_Syntax.mk_binder - b in - let uu___15 = - let uu___16 = - FStar_Syntax_Syntax.null_binder - wp_sort_a in - let uu___17 = - let uu___18 = - FStar_Syntax_Syntax.null_binder - wp_sort_a_b in - [uu___18] in - uu___16 :: uu___17 in - uu___14 :: uu___15 in - uu___12 :: uu___13 in - let uu___12 = - FStar_Syntax_Syntax.mk_Total - wp_sort_b in - FStar_Syntax_Util.arrow - uu___11 uu___12 in - let uu___11 = - let uu___12 = - FStar_Syntax_Util.get_bind_vc_combinator - ed2 in - FStar_Pervasives_Native.fst - uu___12 in - check_and_gen' "bind_wp" - (Prims.of_int (2)) - FStar_Pervasives_Native.None - uu___11 - (FStar_Pervasives_Native.Some - k)) in - log_combinator "bind_wp" bind_wp; - (let stronger = - let uu___10 = fresh_a_and_wp () in - match uu___10 with - | (a, wp_sort_a) -> - let uu___11 = - FStar_Syntax_Util.type_u () in - (match uu___11 with - | (t, uu___12) -> - let k = - let uu___13 = - let uu___14 = - FStar_Syntax_Syntax.mk_binder - a in - let uu___15 = - let uu___16 = - FStar_Syntax_Syntax.null_binder - wp_sort_a in - let uu___17 = - let uu___18 = - FStar_Syntax_Syntax.null_binder - wp_sort_a in - [uu___18] in - uu___16 :: uu___17 in - uu___14 :: uu___15 in - let uu___14 = - FStar_Syntax_Syntax.mk_Total - t in - FStar_Syntax_Util.arrow - uu___13 uu___14 in - let uu___13 = - let uu___14 = - FStar_Syntax_Util.get_stronger_vc_combinator - ed2 in - FStar_Pervasives_Native.fst - uu___14 in - check_and_gen' "stronger" - Prims.int_one - FStar_Pervasives_Native.None - uu___13 - (FStar_Pervasives_Native.Some - k)) in - log_combinator "stronger" stronger; - (let if_then_else = - let uu___11 = fresh_a_and_wp () in - match uu___11 with - | (a, wp_sort_a) -> - let p = - let uu___12 = - let uu___13 = - FStar_Ident.range_of_lid - ed2.FStar_Syntax_Syntax.mname in - FStar_Pervasives_Native.Some - uu___13 in - let uu___13 = - let uu___14 = - FStar_Syntax_Util.type_u () in - FStar_Pervasives_Native.fst - uu___14 in - FStar_Syntax_Syntax.new_bv - uu___12 uu___13 in - let k = - let uu___12 = - let uu___13 = - FStar_Syntax_Syntax.mk_binder - a in - let uu___14 = - let uu___15 = - FStar_Syntax_Syntax.mk_binder - p in - let uu___16 = - let uu___17 = - FStar_Syntax_Syntax.null_binder - wp_sort_a in - let uu___18 = - let uu___19 = - FStar_Syntax_Syntax.null_binder - wp_sort_a in - [uu___19] in - uu___17 :: uu___18 in - uu___15 :: uu___16 in - uu___13 :: uu___14 in - let uu___13 = - FStar_Syntax_Syntax.mk_Total - wp_sort_a in - FStar_Syntax_Util.arrow uu___12 - uu___13 in - let uu___12 = - let uu___13 = - FStar_Syntax_Util.get_wp_if_then_else_combinator - ed2 in - FStar_Compiler_Util.must uu___13 in - check_and_gen' "if_then_else" - Prims.int_one - FStar_Pervasives_Native.None - uu___12 - (FStar_Pervasives_Native.Some k) in - log_combinator "if_then_else" - if_then_else; - (let ite_wp = - let uu___12 = fresh_a_and_wp () in - match uu___12 with - | (a, wp_sort_a) -> - let k = - let uu___13 = - let uu___14 = - FStar_Syntax_Syntax.mk_binder - a in - let uu___15 = - let uu___16 = - FStar_Syntax_Syntax.null_binder - wp_sort_a in - [uu___16] in - uu___14 :: uu___15 in - let uu___14 = - FStar_Syntax_Syntax.mk_Total - wp_sort_a in - FStar_Syntax_Util.arrow uu___13 - uu___14 in - let uu___13 = - let uu___14 = - FStar_Syntax_Util.get_wp_ite_combinator - ed2 in - FStar_Compiler_Util.must uu___14 in - check_and_gen' "ite_wp" - Prims.int_one - FStar_Pervasives_Native.None - uu___13 - (FStar_Pervasives_Native.Some k) in - log_combinator "ite_wp" ite_wp; - (let close_wp = - let uu___13 = fresh_a_and_wp () in - match uu___13 with - | (a, wp_sort_a) -> - let b = - let uu___14 = - let uu___15 = - FStar_Ident.range_of_lid - ed2.FStar_Syntax_Syntax.mname in - FStar_Pervasives_Native.Some - uu___15 in - let uu___15 = - let uu___16 = - FStar_Syntax_Util.type_u () in - FStar_Pervasives_Native.fst - uu___16 in - FStar_Syntax_Syntax.new_bv - uu___14 uu___15 in - let wp_sort_b_a = - let uu___14 = - let uu___15 = - let uu___16 = - FStar_Syntax_Syntax.bv_to_name - b in - FStar_Syntax_Syntax.null_binder - uu___16 in - [uu___15] in - let uu___15 = - FStar_Syntax_Syntax.mk_Total - wp_sort_a in - FStar_Syntax_Util.arrow uu___14 - uu___15 in - let k = - let uu___14 = - let uu___15 = - FStar_Syntax_Syntax.mk_binder - a in - let uu___16 = - let uu___17 = - FStar_Syntax_Syntax.mk_binder - b in - let uu___18 = - let uu___19 = - FStar_Syntax_Syntax.null_binder - wp_sort_b_a in - [uu___19] in - uu___17 :: uu___18 in - uu___15 :: uu___16 in - let uu___15 = - FStar_Syntax_Syntax.mk_Total - wp_sort_a in - FStar_Syntax_Util.arrow uu___14 - uu___15 in - let uu___14 = - let uu___15 = - FStar_Syntax_Util.get_wp_close_combinator - ed2 in - FStar_Compiler_Util.must - uu___15 in - check_and_gen' "close_wp" - (Prims.of_int (2)) - FStar_Pervasives_Native.None - uu___14 - (FStar_Pervasives_Native.Some k) in - log_combinator "close_wp" close_wp; - (let trivial = - let uu___14 = fresh_a_and_wp () in - match uu___14 with - | (a, wp_sort_a) -> - let uu___15 = - FStar_Syntax_Util.type_u () in - (match uu___15 with - | (t, uu___16) -> - let k = - let uu___17 = - let uu___18 = - FStar_Syntax_Syntax.mk_binder - a in - let uu___19 = - let uu___20 = - FStar_Syntax_Syntax.null_binder - wp_sort_a in - [uu___20] in - uu___18 :: uu___19 in - let uu___18 = - FStar_Syntax_Syntax.mk_GTotal - t in - FStar_Syntax_Util.arrow - uu___17 uu___18 in - let trivial1 = - let uu___17 = - let uu___18 = - FStar_Syntax_Util.get_wp_trivial_combinator - ed2 in - FStar_Compiler_Util.must - uu___18 in - check_and_gen' "trivial" - Prims.int_one - FStar_Pervasives_Native.None - uu___17 - (FStar_Pervasives_Native.Some - k) in - (log_combinator "trivial" - trivial1; - trivial1)) in - let uu___14 = - let uu___15 = - FStar_Syntax_Util.get_eff_repr ed2 in - match uu___15 with - | FStar_Pervasives_Native.None -> - (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None, - (ed2.FStar_Syntax_Syntax.actions)) - | uu___16 -> - let repr = - let uu___17 = - fresh_a_and_wp () in - match uu___17 with - | (a, wp_sort_a) -> - let uu___18 = - FStar_Syntax_Util.type_u - () in - (match uu___18 with - | (t, uu___19) -> - let k = - let uu___20 = - let uu___21 = - FStar_Syntax_Syntax.mk_binder - a in - let uu___22 = - let uu___23 = - FStar_Syntax_Syntax.null_binder - wp_sort_a in - [uu___23] in - uu___21 :: - uu___22 in - let uu___21 = - FStar_Syntax_Syntax.mk_GTotal - t in - FStar_Syntax_Util.arrow - uu___20 uu___21 in - let uu___20 = - let uu___21 = - FStar_Syntax_Util.get_eff_repr - ed2 in - FStar_Compiler_Util.must - uu___21 in - check_and_gen' "repr" - Prims.int_one - FStar_Pervasives_Native.None - uu___20 - (FStar_Pervasives_Native.Some - k)) in - (log_combinator "repr" repr; - (let mk_repr' t wp = - let uu___18 = - FStar_TypeChecker_Env.inst_tscheme - repr in - match uu___18 with - | (uu___19, repr1) -> - let repr2 = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.EraseUniverses; - FStar_TypeChecker_Env.AllowUnboundUniverses] - env repr1 in - let uu___20 = - let uu___21 = - let uu___22 = - let uu___23 = - FStar_Syntax_Syntax.as_arg - t in - let uu___24 = - let uu___25 = - FStar_Syntax_Syntax.as_arg - wp in - [uu___25] in - uu___23 :: uu___24 in - { - FStar_Syntax_Syntax.hd - = repr2; - FStar_Syntax_Syntax.args - = uu___22 - } in - FStar_Syntax_Syntax.Tm_app - uu___21 in - FStar_Syntax_Syntax.mk - uu___20 - FStar_Compiler_Range_Type.dummyRange in - let mk_repr a wp = - let uu___18 = - FStar_Syntax_Syntax.bv_to_name - a in - mk_repr' uu___18 wp in - let destruct_repr t = - let uu___18 = - let uu___19 = - FStar_Syntax_Subst.compress - t in - uu___19.FStar_Syntax_Syntax.n in - match uu___18 with - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd - = uu___19; - FStar_Syntax_Syntax.args - = - (t1, uu___20):: - (wp, uu___21)::[];_} - -> (t1, wp) - | uu___19 -> - failwith - "Unexpected repr type" in - let return_repr = - let return_repr_ts = - let uu___18 = - FStar_Syntax_Util.get_return_repr - ed2 in - FStar_Compiler_Util.must - uu___18 in - let uu___18 = - fresh_a_and_wp () in - match uu___18 with - | (a, uu___19) -> - let x_a = - let uu___20 = - FStar_Syntax_Syntax.bv_to_name - a in - FStar_Syntax_Syntax.gen_bv - "x_a" - FStar_Pervasives_Native.None - uu___20 in - let res = - let wp = - let uu___20 = - let uu___21 = - FStar_TypeChecker_Env.inst_tscheme - ret_wp in - FStar_Pervasives_Native.snd - uu___21 in - let uu___21 = - let uu___22 = - let uu___23 = - FStar_Syntax_Syntax.bv_to_name - a in - FStar_Syntax_Syntax.as_arg - uu___23 in - let uu___23 = - let uu___24 = - let uu___25 = - FStar_Syntax_Syntax.bv_to_name - x_a in - FStar_Syntax_Syntax.as_arg - uu___25 in - [uu___24] in - uu___22 :: uu___23 in - FStar_Syntax_Syntax.mk_Tm_app - uu___20 uu___21 - FStar_Compiler_Range_Type.dummyRange in - mk_repr a wp in - let k = - let uu___20 = - let uu___21 = - FStar_Syntax_Syntax.mk_binder - a in - let uu___22 = - let uu___23 = - FStar_Syntax_Syntax.mk_binder - x_a in - [uu___23] in - uu___21 :: uu___22 in - let uu___21 = - FStar_Syntax_Syntax.mk_Total - res in - FStar_Syntax_Util.arrow - uu___20 uu___21 in - let uu___20 = - FStar_TypeChecker_TcTerm.tc_tot_or_gtot_term - env k in - (match uu___20 with - | (k1, uu___21, - uu___22) -> - let env1 = - let uu___23 = - FStar_TypeChecker_Env.set_range - env - (FStar_Pervasives_Native.snd - return_repr_ts).FStar_Syntax_Syntax.pos in - FStar_Pervasives_Native.Some - uu___23 in - check_and_gen' - "return_repr" - Prims.int_one - env1 - return_repr_ts - (FStar_Pervasives_Native.Some - k1)) in - log_combinator "return_repr" - return_repr; - (let bind_repr = - let bind_repr_ts = - let uu___19 = - FStar_Syntax_Util.get_bind_repr - ed2 in - FStar_Compiler_Util.must - uu___19 in - let uu___19 = - fresh_a_and_wp () in - match uu___19 with - | (a, wp_sort_a) -> - let uu___20 = - fresh_a_and_wp () in - (match uu___20 with - | (b, wp_sort_b) -> - let wp_sort_a_b = - let uu___21 = - let uu___22 = - let uu___23 - = - FStar_Syntax_Syntax.bv_to_name - a in - FStar_Syntax_Syntax.null_binder - uu___23 in - [uu___22] in - let uu___22 = - FStar_Syntax_Syntax.mk_Total - wp_sort_b in - FStar_Syntax_Util.arrow - uu___21 - uu___22 in - let wp_f = - FStar_Syntax_Syntax.gen_bv - "wp_f" - FStar_Pervasives_Native.None - wp_sort_a in - let wp_g = - FStar_Syntax_Syntax.gen_bv - "wp_g" - FStar_Pervasives_Native.None - wp_sort_a_b in - let x_a = - let uu___21 = - FStar_Syntax_Syntax.bv_to_name - a in - FStar_Syntax_Syntax.gen_bv - "x_a" - FStar_Pervasives_Native.None - uu___21 in - let wp_g_x = - let uu___21 = - FStar_Syntax_Syntax.bv_to_name - wp_g in - let uu___22 = - let uu___23 = - let uu___24 - = - FStar_Syntax_Syntax.bv_to_name - x_a in - FStar_Syntax_Syntax.as_arg - uu___24 in - [uu___23] in - FStar_Syntax_Syntax.mk_Tm_app - uu___21 - uu___22 - FStar_Compiler_Range_Type.dummyRange in - let res = - let wp = - let uu___21 = - let uu___22 - = - FStar_TypeChecker_Env.inst_tscheme - bind_wp in - FStar_Pervasives_Native.snd - uu___22 in - let uu___22 = - let uu___23 - = - let uu___24 - = - FStar_Syntax_Syntax.bv_to_name - a in - let uu___25 - = - let uu___26 - = - FStar_Syntax_Syntax.bv_to_name - b in - let uu___27 - = - let uu___28 - = - FStar_Syntax_Syntax.bv_to_name - wp_f in - let uu___29 - = - let uu___30 - = - FStar_Syntax_Syntax.bv_to_name - wp_g in - [uu___30] in - uu___28 - :: - uu___29 in - uu___26 - :: - uu___27 in - uu___24 :: - uu___25 in - FStar_Compiler_List.map - FStar_Syntax_Syntax.as_arg - uu___23 in - FStar_Syntax_Syntax.mk_Tm_app - uu___21 - uu___22 - FStar_Compiler_Range_Type.dummyRange in - mk_repr b wp in - let maybe_range_arg - = - let uu___21 = - FStar_Compiler_Util.for_some - (FStar_TypeChecker_TermEqAndSimplify.eq_tm_bool - env - FStar_Syntax_Util.dm4f_bind_range_attr) - ed2.FStar_Syntax_Syntax.eff_attrs in - if uu___21 - then - let uu___22 = - FStar_Syntax_Syntax.null_binder - FStar_Syntax_Syntax.t_range in - let uu___23 = - let uu___24 - = - FStar_Syntax_Syntax.null_binder - FStar_Syntax_Syntax.t_range in - [uu___24] in - uu___22 :: - uu___23 - else [] in - let k = - let uu___21 = - let uu___22 = - let uu___23 - = - FStar_Syntax_Syntax.mk_binder - a in - let uu___24 - = - let uu___25 - = - FStar_Syntax_Syntax.mk_binder - b in - [uu___25] in - uu___23 :: - uu___24 in - let uu___23 = - let uu___24 - = - let uu___25 - = - FStar_Syntax_Syntax.mk_binder - wp_f in - let uu___26 - = - let uu___27 - = - let uu___28 - = - let uu___29 - = - FStar_Syntax_Syntax.bv_to_name - wp_f in - mk_repr a - uu___29 in - FStar_Syntax_Syntax.null_binder - uu___28 in - let uu___28 - = - let uu___29 - = - FStar_Syntax_Syntax.mk_binder - wp_g in - let uu___30 - = - let uu___31 - = - let uu___32 - = - let uu___33 - = - let uu___34 - = - FStar_Syntax_Syntax.mk_binder - x_a in - [uu___34] in - let uu___34 - = - let uu___35 - = - mk_repr b - wp_g_x in - FStar_Syntax_Syntax.mk_Total - uu___35 in - FStar_Syntax_Util.arrow - uu___33 - uu___34 in - FStar_Syntax_Syntax.null_binder - uu___32 in - [uu___31] in - uu___29 - :: - uu___30 in - uu___27 - :: - uu___28 in - uu___25 :: - uu___26 in - FStar_Compiler_List.op_At - maybe_range_arg - uu___24 in - FStar_Compiler_List.op_At - uu___22 - uu___23 in - let uu___22 = - FStar_Syntax_Syntax.mk_Total - res in - FStar_Syntax_Util.arrow - uu___21 - uu___22 in - let uu___21 = - FStar_TypeChecker_TcTerm.tc_tot_or_gtot_term - env k in - (match uu___21 - with - | (k1, uu___22, - uu___23) -> - let env1 = - FStar_TypeChecker_Env.set_range - env - (FStar_Pervasives_Native.snd - bind_repr_ts).FStar_Syntax_Syntax.pos in - let env2 = - FStar_Pervasives_Native.Some - { - FStar_TypeChecker_Env.solver - = - (env1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range - = - (env1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule - = - (env1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma - = - (env1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig - = - (env1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache - = - (env1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules - = - (env1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ - = - (env1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab - = - (env1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab - = - (env1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp - = - (env1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects - = - (env1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize - = - (env1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs - = - (env1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level - = - (env1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars - = - (env1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict - = - (env1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface - = - (env1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit - = true; - FStar_TypeChecker_Env.lax_universes - = - (env1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 - = - (env1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard - = - (env1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking - = - (env1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping - = - (env1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics - = - (env1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce - = - (env1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term - = - (env1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (env1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of - = - (env1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force - = - (env1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (env1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (env1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (env1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths - = - (env1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns - = - (env1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook - = - (env1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (env1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice - = - (env1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess - = - (env1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess - = - (env1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info - = - (env1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks - = - (env1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv - = - (env1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe - = - (env1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab - = - (env1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (env1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (env1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (env1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (env1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check - = - (env1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl - = - (env1.FStar_TypeChecker_Env.missing_decl) - } in - check_and_gen' - "bind_repr" - (Prims.of_int (2)) - env2 - bind_repr_ts - (FStar_Pervasives_Native.Some - k1))) in - log_combinator "bind_repr" - bind_repr; - (let actions = - let check_action act = - if - (FStar_Compiler_List.length - act.FStar_Syntax_Syntax.action_params) - <> Prims.int_zero - then - failwith - "tc_eff_decl: expected action_params to be empty" - else (); - (let uu___21 = - if - act.FStar_Syntax_Syntax.action_univs - = [] - then (env, act) - else - (let uu___23 = - FStar_Syntax_Subst.univ_var_opening - act.FStar_Syntax_Syntax.action_univs in - match uu___23 with - | (usubst, uvs) -> - let uu___24 = - FStar_TypeChecker_Env.push_univ_vars - env uvs in - let uu___25 = - let uu___26 - = - FStar_Syntax_Subst.subst - usubst - act.FStar_Syntax_Syntax.action_defn in - let uu___27 - = - FStar_Syntax_Subst.subst - usubst - act.FStar_Syntax_Syntax.action_typ in - { - FStar_Syntax_Syntax.action_name - = - (act.FStar_Syntax_Syntax.action_name); - FStar_Syntax_Syntax.action_unqualified_name - = - (act.FStar_Syntax_Syntax.action_unqualified_name); - FStar_Syntax_Syntax.action_univs - = uvs; - FStar_Syntax_Syntax.action_params - = - (act.FStar_Syntax_Syntax.action_params); - FStar_Syntax_Syntax.action_defn - = uu___26; - FStar_Syntax_Syntax.action_typ - = uu___27 - } in - (uu___24, - uu___25)) in - match uu___21 with - | (env1, act1) -> - let act_typ = - let uu___22 = - let uu___23 = - FStar_Syntax_Subst.compress - act1.FStar_Syntax_Syntax.action_typ in - uu___23.FStar_Syntax_Syntax.n in - match uu___22 - with - | FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 - = bs1; - FStar_Syntax_Syntax.comp - = c;_} - -> - let c1 = - FStar_TypeChecker_Env.comp_to_comp_typ - env1 c in - let uu___23 = - FStar_Ident.lid_equals - c1.FStar_Syntax_Syntax.effect_name - ed2.FStar_Syntax_Syntax.mname in - if uu___23 - then - let uu___24 - = - let uu___25 - = - let uu___26 - = - let uu___27 - = - FStar_Compiler_List.hd - c1.FStar_Syntax_Syntax.effect_args in - FStar_Pervasives_Native.fst - uu___27 in - mk_repr' - c1.FStar_Syntax_Syntax.result_typ - uu___26 in - FStar_Syntax_Syntax.mk_Total - uu___25 in - FStar_Syntax_Util.arrow - bs1 - uu___24 - else - act1.FStar_Syntax_Syntax.action_typ - | uu___23 -> - act1.FStar_Syntax_Syntax.action_typ in - let uu___22 = - FStar_TypeChecker_TcTerm.tc_tot_or_gtot_term - env1 act_typ in - (match uu___22 with - | (act_typ1, - uu___23, g_t) - -> - let env' = - let uu___24 - = - FStar_TypeChecker_Env.set_expected_typ - env1 - act_typ1 in - { - FStar_TypeChecker_Env.solver - = - (uu___24.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range - = - (uu___24.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule - = - (uu___24.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma - = - (uu___24.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig - = - (uu___24.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache - = - (uu___24.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules - = - (uu___24.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ - = - (uu___24.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab - = - (uu___24.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab - = - (uu___24.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp - = false; - FStar_TypeChecker_Env.effects - = - (uu___24.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize - = - (uu___24.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs - = - (uu___24.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level - = - (uu___24.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars - = - (uu___24.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict - = - (uu___24.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface - = - (uu___24.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit - = - (uu___24.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes - = - (uu___24.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 - = - (uu___24.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard - = - (uu___24.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking - = - (uu___24.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping - = - (uu___24.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics - = - (uu___24.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce - = - (uu___24.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term - = - (uu___24.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (uu___24.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of - = - (uu___24.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (uu___24.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force - = - (uu___24.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (uu___24.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (uu___24.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (uu___24.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths - = - (uu___24.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns - = - (uu___24.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook - = - (uu___24.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (uu___24.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice - = - (uu___24.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess - = - (uu___24.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess - = - (uu___24.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info - = - (uu___24.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks - = - (uu___24.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv - = - (uu___24.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe - = - (uu___24.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab - = - (uu___24.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (uu___24.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (uu___24.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (uu___24.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (uu___24.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check - = - (uu___24.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl - = - (uu___24.FStar_TypeChecker_Env.missing_decl) - } in - ((let uu___25 - = - FStar_Compiler_Effect.op_Bang - dbg in - if uu___25 - then - let uu___26 - = - FStar_Ident.string_of_lid - act1.FStar_Syntax_Syntax.action_name in - let uu___27 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - act1.FStar_Syntax_Syntax.action_defn in - let uu___28 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - act_typ1 in - FStar_Compiler_Util.print3 - "Checking action %s:\n[definition]: %s\n[cps'd type]: %s\n" - uu___26 - uu___27 - uu___28 - else ()); - (let uu___25 - = - FStar_TypeChecker_TcTerm.tc_tot_or_gtot_term - env' - act1.FStar_Syntax_Syntax.action_defn in - match uu___25 - with - | (act_defn, - uu___26, - g_a) -> - (( - let uu___28 - = - FStar_TypeChecker_Env.conj_guards - [g_a; - g_t] in - FStar_TypeChecker_Rel.force_trivial_guard - env1 - uu___28); - (let act_defn1 - = - FStar_TypeChecker_Normalize.normalize - [ - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant] - env1 - act_defn in - let act_typ2 - = - FStar_TypeChecker_Normalize.normalize - [ - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.Beta] - env1 - act_typ1 in - let uu___28 - = - let act_typ3 - = - FStar_Syntax_Subst.compress - act_typ2 in - match - act_typ3.FStar_Syntax_Syntax.n - with - | - FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 - = bs1; - FStar_Syntax_Syntax.comp - = c;_} -> - let uu___29 - = - FStar_Syntax_Subst.open_comp - bs1 c in - (match uu___29 - with - | - (bs2, - uu___30) - -> - let res = - mk_repr' - FStar_Syntax_Syntax.tun - FStar_Syntax_Syntax.tun in - let k = - let uu___31 - = - FStar_Syntax_Syntax.mk_Total - res in - FStar_Syntax_Util.arrow - bs2 - uu___31 in - let uu___31 - = - FStar_TypeChecker_TcTerm.tc_tot_or_gtot_term - env1 k in - (match uu___31 - with - | - (k1, - uu___32, - g) -> - (k1, g))) - | - uu___29 - -> - let uu___30 - = - let uu___31 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - act_typ3 in - let uu___32 - = - FStar_Class_Tagged.tag_of - FStar_Syntax_Syntax.tagged_term - act_typ3 in - FStar_Compiler_Util.format2 - "Actions must have function types (not: %s, a.k.a. %s)" - uu___31 - uu___32 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax - ()) - act_defn1 - FStar_Errors_Codes.Fatal_ActionMustHaveFunctionType - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - uu___30) in - match uu___28 - with - | - (expected_k, - g_k) -> - (( - let g = - FStar_TypeChecker_Rel.teq - env1 - act_typ2 - expected_k in - let g1 = - FStar_TypeChecker_Env.conj_guard - g g_k in - match - g1.FStar_TypeChecker_Common.guard_f - with - | - FStar_TypeChecker_Common.NonTrivial - uu___30 - -> - let uu___31 - = - let uu___32 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - act_typ2 in - FStar_Compiler_Util.format1 - "Unexpected non trivial guard formula when checking action type shape (%s)" - uu___32 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax - ()) - act_defn1 - FStar_Errors_Codes.Fatal_ActionMustHaveFunctionType - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - uu___31) - | - FStar_TypeChecker_Common.Trivial - -> - let uu___30 - = - FStar_TypeChecker_Env.conj_guards - [g_k; g1] in - FStar_TypeChecker_Rel.force_trivial_guard - { - FStar_TypeChecker_Env.solver - = - (env1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range - = - (env1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule - = - (env1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma - = - (env1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig - = - (env1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache - = - (env1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules - = - (env1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ - = - (env1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab - = - (env1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab - = - (env1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp - = - (env1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects - = - (env1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize - = - (env1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs - = - (env1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level - = - (env1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars - = - (env1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict - = - (env1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface - = - (env1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit - = true; - FStar_TypeChecker_Env.lax_universes - = - (env1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 - = - (env1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard - = - (env1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking - = - (env1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping - = - (env1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics - = - (env1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce - = - (env1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term - = - (env1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (env1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of - = - (env1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force - = - (env1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (env1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (env1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (env1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths - = - (env1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns - = - (env1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook - = - (env1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (env1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice - = - (env1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess - = - (env1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess - = - (env1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info - = - (env1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks - = - (env1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv - = - (env1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe - = - (env1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab - = - (env1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (env1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (env1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (env1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (env1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check - = - (env1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl - = - (env1.FStar_TypeChecker_Env.missing_decl) - } uu___30); - (let act_typ3 - = - let uu___30 - = - let uu___31 - = - FStar_Syntax_Subst.compress - expected_k in - uu___31.FStar_Syntax_Syntax.n in - match uu___30 - with - | - FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 - = bs1; - FStar_Syntax_Syntax.comp - = c;_} -> - let uu___31 - = - FStar_Syntax_Subst.open_comp - bs1 c in - (match uu___31 - with - | - (bs2, c1) - -> - let uu___32 - = - destruct_repr - (FStar_Syntax_Util.comp_result - c1) in - (match uu___32 - with - | - (a, wp) - -> - let c2 = - let uu___33 - = - let uu___34 - = - let uu___35 - = - FStar_TypeChecker_Env.push_binders - env1 bs2 in - env1.FStar_TypeChecker_Env.universe_of - uu___35 a in - [uu___34] in - let uu___34 - = - let uu___35 - = - FStar_Syntax_Syntax.as_arg - wp in - [uu___35] in - { - FStar_Syntax_Syntax.comp_univs - = uu___33; - FStar_Syntax_Syntax.effect_name - = - (ed2.FStar_Syntax_Syntax.mname); - FStar_Syntax_Syntax.result_typ - = a; - FStar_Syntax_Syntax.effect_args - = uu___34; - FStar_Syntax_Syntax.flags - = [] - } in - let uu___33 - = - FStar_Syntax_Syntax.mk_Comp - c2 in - FStar_Syntax_Util.arrow - bs2 - uu___33)) - | - uu___31 - -> - failwith - "Impossible (expected_k is an arrow)" in - let uu___30 - = - if - act1.FStar_Syntax_Syntax.action_univs - = [] - then - FStar_TypeChecker_Generalize.generalize_universes - env1 - act_defn1 - else - (let uu___32 - = - FStar_Syntax_Subst.close_univ_vars - act1.FStar_Syntax_Syntax.action_univs - act_defn1 in - ((act1.FStar_Syntax_Syntax.action_univs), - uu___32)) in - match uu___30 - with - | - (univs, - act_defn2) - -> - let act_typ4 - = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Beta] - env1 - act_typ3 in - let act_typ5 - = - FStar_Syntax_Subst.close_univ_vars - univs - act_typ4 in - { - FStar_Syntax_Syntax.action_name - = - (act1.FStar_Syntax_Syntax.action_name); - FStar_Syntax_Syntax.action_unqualified_name - = - (act1.FStar_Syntax_Syntax.action_unqualified_name); - FStar_Syntax_Syntax.action_univs - = univs; - FStar_Syntax_Syntax.action_params - = - (act1.FStar_Syntax_Syntax.action_params); - FStar_Syntax_Syntax.action_defn - = - act_defn2; - FStar_Syntax_Syntax.action_typ - = - act_typ5 - })))))))) in - FStar_Compiler_List.map - check_action - ed2.FStar_Syntax_Syntax.actions in - ((FStar_Pervasives_Native.Some - repr), - (FStar_Pervasives_Native.Some - return_repr), - (FStar_Pervasives_Native.Some - bind_repr), actions))))) in - match uu___14 with - | (repr, return_repr, bind_repr, - actions) -> - let cl ts = - let ts1 = - FStar_Syntax_Subst.close_tscheme - ed_bs ts in - let ed_univs_closing = - FStar_Syntax_Subst.univ_var_closing - ed_univs in - let uu___15 = - FStar_Syntax_Subst.shift_subst - (FStar_Compiler_List.length - ed_bs) ed_univs_closing in - FStar_Syntax_Subst.subst_tscheme - uu___15 ts1 in - let combinators = - { - FStar_Syntax_Syntax.ret_wp = - ret_wp; - FStar_Syntax_Syntax.bind_wp = - bind_wp; - FStar_Syntax_Syntax.stronger = - stronger; - FStar_Syntax_Syntax.if_then_else - = if_then_else; - FStar_Syntax_Syntax.ite_wp = - ite_wp; - FStar_Syntax_Syntax.close_wp = - close_wp; - FStar_Syntax_Syntax.trivial = - trivial; - FStar_Syntax_Syntax.repr = - repr; - FStar_Syntax_Syntax.return_repr - = return_repr; - FStar_Syntax_Syntax.bind_repr - = bind_repr - } in - let combinators1 = - FStar_Syntax_Util.apply_wp_eff_combinators - cl combinators in - let combinators2 = - match ed2.FStar_Syntax_Syntax.combinators - with - | FStar_Syntax_Syntax.Primitive_eff - uu___15 -> - FStar_Syntax_Syntax.Primitive_eff - combinators1 - | FStar_Syntax_Syntax.DM4F_eff - uu___15 -> - FStar_Syntax_Syntax.DM4F_eff - combinators1 - | uu___15 -> - failwith - "Impossible! tc_eff_decl on a layered effect is not expected" in - let ed3 = - let uu___15 = - let uu___16 = cl signature in - FStar_Syntax_Syntax.WP_eff_sig - uu___16 in - let uu___16 = - FStar_Compiler_List.map - (fun a -> - let uu___17 = - let uu___18 = - cl - ((a.FStar_Syntax_Syntax.action_univs), - (a.FStar_Syntax_Syntax.action_defn)) in - FStar_Pervasives_Native.snd - uu___18 in - let uu___18 = - let uu___19 = - cl - ((a.FStar_Syntax_Syntax.action_univs), - (a.FStar_Syntax_Syntax.action_typ)) in - FStar_Pervasives_Native.snd - uu___19 in - { - FStar_Syntax_Syntax.action_name - = - (a.FStar_Syntax_Syntax.action_name); - FStar_Syntax_Syntax.action_unqualified_name - = - (a.FStar_Syntax_Syntax.action_unqualified_name); - FStar_Syntax_Syntax.action_univs - = - (a.FStar_Syntax_Syntax.action_univs); - FStar_Syntax_Syntax.action_params - = - (a.FStar_Syntax_Syntax.action_params); - FStar_Syntax_Syntax.action_defn - = uu___17; - FStar_Syntax_Syntax.action_typ - = uu___18 - }) actions in - { - FStar_Syntax_Syntax.mname = - (ed2.FStar_Syntax_Syntax.mname); - FStar_Syntax_Syntax.cattributes - = - (ed2.FStar_Syntax_Syntax.cattributes); - FStar_Syntax_Syntax.univs = - (ed2.FStar_Syntax_Syntax.univs); - FStar_Syntax_Syntax.binders = - (ed2.FStar_Syntax_Syntax.binders); - FStar_Syntax_Syntax.signature - = uu___15; - FStar_Syntax_Syntax.combinators - = combinators2; - FStar_Syntax_Syntax.actions = - uu___16; - FStar_Syntax_Syntax.eff_attrs - = - (ed2.FStar_Syntax_Syntax.eff_attrs); - FStar_Syntax_Syntax.extraction_mode - = - (ed2.FStar_Syntax_Syntax.extraction_mode) - } in - ((let uu___16 = - FStar_Compiler_Effect.op_Bang - dbg in - if uu___16 - then - let uu___17 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_eff_decl - ed3 in - FStar_Compiler_Util.print1 - "Typechecked effect declaration:\n\t%s\n" - uu___17 - else ()); - ed3)))))))))))))) -let (tc_eff_decl : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.eff_decl -> - FStar_Syntax_Syntax.qualifier Prims.list -> - FStar_Syntax_Syntax.attribute Prims.list -> - FStar_Syntax_Syntax.eff_decl) - = - fun env -> - fun ed -> - fun quals -> - fun attrs -> - let uu___ = FStar_Syntax_Util.is_layered ed in - if uu___ - then tc_layered_eff_decl env ed quals attrs - else tc_non_layered_eff_decl env ed quals attrs -let (monad_signature : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.bv * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax)) - = - fun env -> - fun m -> - fun s -> - let fail uu___ = - let uu___1 = FStar_Ident.range_of_lid m in - FStar_TypeChecker_Err.unexpected_signature_for_monad env uu___1 m s in - let s1 = FStar_Syntax_Subst.compress s in - match s1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; FStar_Syntax_Syntax.comp = c;_} - -> - let bs1 = FStar_Syntax_Subst.open_binders bs in - (match bs1 with - | { FStar_Syntax_Syntax.binder_bv = a; - FStar_Syntax_Syntax.binder_qual = uu___; - FStar_Syntax_Syntax.binder_positivity = uu___1; - FStar_Syntax_Syntax.binder_attrs = uu___2;_}::{ - FStar_Syntax_Syntax.binder_bv - = wp; - FStar_Syntax_Syntax.binder_qual - = uu___3; - FStar_Syntax_Syntax.binder_positivity - = uu___4; - FStar_Syntax_Syntax.binder_attrs - = uu___5;_}::[] - -> (a, (wp.FStar_Syntax_Syntax.sort)) - | uu___ -> fail ()) - | uu___ -> fail () -let (tc_layered_lift : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.sub_eff -> FStar_Syntax_Syntax.sub_eff) - = - fun env0 -> - fun sub -> - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_LayeredEffectsTc in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_sub_eff sub in - FStar_Compiler_Util.print1 "Typechecking sub_effect: %s\n" uu___2 - else ()); - (let lift_ts = FStar_Compiler_Util.must sub.FStar_Syntax_Syntax.lift in - let r = (FStar_Pervasives_Native.snd lift_ts).FStar_Syntax_Syntax.pos in - let uu___1 = check_and_gen env0 "" "lift" Prims.int_one lift_ts in - match uu___1 with - | (us, lift, lift_ty) -> - ((let uu___3 = FStar_Compiler_Effect.op_Bang dbg_LayeredEffectsTc in - if uu___3 - then - let uu___4 = FStar_Syntax_Print.tscheme_to_string (us, lift) in - let uu___5 = - FStar_Syntax_Print.tscheme_to_string (us, lift_ty) in - FStar_Compiler_Util.print2 - "Typechecked lift: %s and lift_ty: %s\n" uu___4 uu___5 - else ()); - (let uu___3 = FStar_Syntax_Subst.open_univ_vars us lift_ty in - match uu___3 with - | (us1, lift_ty1) -> - let env = FStar_TypeChecker_Env.push_univ_vars env0 us1 in - let uu___4 = - let uu___5 = FStar_Compiler_List.hd us1 in - validate_indexed_effect_lift_shape env - sub.FStar_Syntax_Syntax.source - sub.FStar_Syntax_Syntax.target uu___5 lift_ty1 r in - (match uu___4 with - | (k, kind) -> - let sub1 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Syntax_Subst.close_univ_vars us1 k in - (us1, uu___7) in - FStar_Pervasives_Native.Some uu___6 in - { - FStar_Syntax_Syntax.source = - (sub.FStar_Syntax_Syntax.source); - FStar_Syntax_Syntax.target = - (sub.FStar_Syntax_Syntax.target); - FStar_Syntax_Syntax.lift_wp = uu___5; - FStar_Syntax_Syntax.lift = - (FStar_Pervasives_Native.Some (us1, lift)); - FStar_Syntax_Syntax.kind = - (FStar_Pervasives_Native.Some kind) - } in - ((let uu___6 = - FStar_Compiler_Effect.op_Bang dbg_LayeredEffectsTc in - if uu___6 - then - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_sub_eff sub1 in - FStar_Compiler_Util.print1 "Final sub_effect: %s\n" - uu___7 - else ()); - sub1))))) -let (check_lift_for_erasable_effects : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident -> - FStar_Ident.lident -> FStar_Compiler_Range_Type.range -> unit) - = - fun env -> - fun m1 -> - fun m2 -> - fun r -> - let err reason = - let uu___ = - let uu___1 = FStar_Ident.string_of_lid m1 in - let uu___2 = FStar_Ident.string_of_lid m2 in - FStar_Compiler_Util.format3 - "Error defining a lift/subcomp %s ~> %s: %s" uu___1 uu___2 - reason in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_UnexpectedEffect () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___) in - let m11 = FStar_TypeChecker_Env.norm_eff_name env m1 in - let uu___ = - FStar_Ident.lid_equals m11 FStar_Parser_Const.effect_GHOST_lid in - if uu___ - then err "user-defined lifts from GHOST effect are not allowed" - else - (let m1_erasable = - FStar_TypeChecker_Env.is_erasable_effect env m11 in - let m2_erasable = - FStar_TypeChecker_Env.is_erasable_effect env m2 in - let uu___2 = - (m2_erasable && (Prims.op_Negation m1_erasable)) && - (let uu___3 = - FStar_Ident.lid_equals m11 - FStar_Parser_Const.effect_PURE_lid in - Prims.op_Negation uu___3) in - if uu___2 - then - err - "cannot lift a non-erasable effect to an erasable effect unless the non-erasable effect is PURE" - else ()) -let (tc_lift : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.sub_eff -> - FStar_Compiler_Range_Type.range -> FStar_Syntax_Syntax.sub_eff) - = - fun env -> - fun sub -> - fun r -> - (let uu___1 = - FStar_Ident.lid_equals sub.FStar_Syntax_Syntax.source - sub.FStar_Syntax_Syntax.target in - if uu___1 - then - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Ident.showable_lident - sub.FStar_Syntax_Syntax.source in - FStar_Compiler_Util.format1 - "Cannot define a lift with same source and target (%s)" uu___3 in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_UnexpectedEffect () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2) - else ()); - (let check_and_gen1 env1 t k = - let uu___1 = - FStar_TypeChecker_TcTerm.tc_check_trivial_guard env1 t k in - FStar_TypeChecker_Generalize.generalize_universes env1 uu___1 in - check_lift_for_erasable_effects env sub.FStar_Syntax_Syntax.source - sub.FStar_Syntax_Syntax.target r; - (let ed_src = - FStar_TypeChecker_Env.get_effect_decl env - sub.FStar_Syntax_Syntax.source in - let ed_tgt = - FStar_TypeChecker_Env.get_effect_decl env - sub.FStar_Syntax_Syntax.target in - let uu___2 = - (FStar_Syntax_Util.is_layered ed_src) || - (FStar_Syntax_Util.is_layered ed_tgt) in - if uu___2 - then - let uu___3 = FStar_TypeChecker_Env.set_range env r in - tc_layered_lift uu___3 sub - else - (let uu___4 = - let uu___5 = - FStar_TypeChecker_Env.lookup_effect_lid env - sub.FStar_Syntax_Syntax.source in - monad_signature env sub.FStar_Syntax_Syntax.source uu___5 in - match uu___4 with - | (a, wp_a_src) -> - let uu___5 = - let uu___6 = - FStar_TypeChecker_Env.lookup_effect_lid env - sub.FStar_Syntax_Syntax.target in - monad_signature env sub.FStar_Syntax_Syntax.target uu___6 in - (match uu___5 with - | (b, wp_b_tgt) -> - let wp_a_tgt = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = FStar_Syntax_Syntax.bv_to_name a in - (b, uu___9) in - FStar_Syntax_Syntax.NT uu___8 in - [uu___7] in - FStar_Syntax_Subst.subst uu___6 wp_b_tgt in - let expected_k = - let uu___6 = - let uu___7 = FStar_Syntax_Syntax.mk_binder a in - let uu___8 = - let uu___9 = - FStar_Syntax_Syntax.null_binder wp_a_src in - [uu___9] in - uu___7 :: uu___8 in - let uu___7 = FStar_Syntax_Syntax.mk_Total wp_a_tgt in - FStar_Syntax_Util.arrow uu___6 uu___7 in - let repr_type eff_name a1 wp = - (let uu___7 = - let uu___8 = - FStar_TypeChecker_Env.is_reifiable_effect env - eff_name in - Prims.op_Negation uu___8 in - if uu___7 - then - let uu___8 = - let uu___9 = FStar_Ident.string_of_lid eff_name in - FStar_Compiler_Util.format1 - "Effect %s cannot be reified" uu___9 in - FStar_Errors.raise_error - FStar_TypeChecker_Env.hasRange_env env - FStar_Errors_Codes.Fatal_EffectCannotBeReified - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___8) - else ()); - (let uu___7 = - FStar_TypeChecker_Env.effect_decl_opt env eff_name in - match uu___7 with - | FStar_Pervasives_Native.None -> - failwith - "internal error: reifiable effect has no decl?" - | FStar_Pervasives_Native.Some (ed, qualifiers) -> - let repr = - let uu___8 = - let uu___9 = - FStar_Syntax_Util.get_eff_repr ed in - FStar_Compiler_Util.must uu___9 in - FStar_TypeChecker_Env.inst_effect_fun_with - [FStar_Syntax_Syntax.U_unknown] env ed - uu___8 in - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Syntax_Syntax.as_arg a1 in - let uu___12 = - let uu___13 = - FStar_Syntax_Syntax.as_arg wp in - [uu___13] in - uu___11 :: uu___12 in - { - FStar_Syntax_Syntax.hd = repr; - FStar_Syntax_Syntax.args = uu___10 - } in - FStar_Syntax_Syntax.Tm_app uu___9 in - let uu___9 = FStar_TypeChecker_Env.get_range env in - FStar_Syntax_Syntax.mk uu___8 uu___9) in - let uu___6 = - match ((sub.FStar_Syntax_Syntax.lift), - (sub.FStar_Syntax_Syntax.lift_wp)) - with - | (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None) -> - failwith "Impossible (parser)" - | (lift, FStar_Pervasives_Native.Some (uvs, lift_wp)) - -> - let uu___7 = - if - (FStar_Compiler_List.length uvs) > - Prims.int_zero - then - let uu___8 = - FStar_Syntax_Subst.univ_var_opening uvs in - match uu___8 with - | (usubst, uvs1) -> - let uu___9 = - FStar_TypeChecker_Env.push_univ_vars - env uvs1 in - let uu___10 = - FStar_Syntax_Subst.subst usubst lift_wp in - (uu___9, uu___10) - else (env, lift_wp) in - (match uu___7 with - | (env1, lift_wp1) -> - let lift_wp2 = - if - (FStar_Compiler_List.length uvs) = - Prims.int_zero - then - check_and_gen1 env1 lift_wp1 expected_k - else - (let lift_wp3 = - FStar_TypeChecker_TcTerm.tc_check_trivial_guard - env1 lift_wp1 expected_k in - let uu___9 = - FStar_Syntax_Subst.close_univ_vars - uvs lift_wp3 in - (uvs, uu___9)) in - (lift, lift_wp2)) - | (FStar_Pervasives_Native.Some (what, lift), - FStar_Pervasives_Native.None) -> - let uu___7 = - if - (FStar_Compiler_List.length what) > - Prims.int_zero - then - let uu___8 = - FStar_Syntax_Subst.univ_var_opening what in - match uu___8 with - | (usubst, uvs) -> - let uu___9 = - FStar_Syntax_Subst.subst usubst lift in - (uvs, uu___9) - else ([], lift) in - (match uu___7 with - | (uvs, lift1) -> - ((let uu___9 = - FStar_Compiler_Effect.op_Bang dbg in - if uu___9 - then - let uu___10 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - lift1 in - FStar_Compiler_Util.print1 - "Lift for free : %s\n" uu___10 - else ()); - (let dmff_env = - FStar_TypeChecker_DMFF.empty env - (FStar_TypeChecker_TcTerm.tc_constant - env - FStar_Compiler_Range_Type.dummyRange) in - let uu___9 = - let uu___10 = - FStar_TypeChecker_Env.push_univ_vars - env uvs in - FStar_TypeChecker_TcTerm.tc_term uu___10 - lift1 in - match uu___9 with - | (lift2, comp, uu___10) -> - let uu___11 = - FStar_TypeChecker_DMFF.star_expr - dmff_env lift2 in - (match uu___11 with - | (uu___12, lift_wp, lift_elab) -> - let lift_wp1 = - FStar_TypeChecker_DMFF.recheck_debug - "lift-wp" env lift_wp in - let lift_elab1 = - FStar_TypeChecker_DMFF.recheck_debug - "lift-elab" env lift_elab in - if - (FStar_Compiler_List.length uvs) - = Prims.int_zero - then - let uu___13 = - let uu___14 = - FStar_TypeChecker_Generalize.generalize_universes - env lift_elab1 in - FStar_Pervasives_Native.Some - uu___14 in - let uu___14 = - FStar_TypeChecker_Generalize.generalize_universes - env lift_wp1 in - (uu___13, uu___14) - else - (let uu___14 = - let uu___15 = - let uu___16 = - FStar_Syntax_Subst.close_univ_vars - uvs lift_elab1 in - (uvs, uu___16) in - FStar_Pervasives_Native.Some - uu___15 in - let uu___15 = - let uu___16 = - FStar_Syntax_Subst.close_univ_vars - uvs lift_wp1 in - (uvs, uu___16) in - (uu___14, uu___15)))))) in - (match uu___6 with - | (lift, lift_wp) -> - let env1 = - { - FStar_TypeChecker_Env.solver = - (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = true; - FStar_TypeChecker_Env.lax_universes = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env.FStar_TypeChecker_Env.missing_decl) - } in - let lift1 = - match lift with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (uvs, lift2) -> - let uu___7 = - let uu___8 = - FStar_Syntax_Subst.univ_var_opening uvs in - match uu___8 with - | (usubst, uvs1) -> - let uu___9 = - FStar_TypeChecker_Env.push_univ_vars - env1 uvs1 in - let uu___10 = - FStar_Syntax_Subst.subst usubst - lift2 in - (uu___9, uu___10) in - (match uu___7 with - | (env2, lift3) -> - let uu___8 = - let uu___9 = - FStar_TypeChecker_Env.lookup_effect_lid - env2 - sub.FStar_Syntax_Syntax.source in - monad_signature env2 - sub.FStar_Syntax_Syntax.source - uu___9 in - (match uu___8 with - | (a1, wp_a_src1) -> - let wp_a = - FStar_Syntax_Syntax.new_bv - FStar_Pervasives_Native.None - wp_a_src1 in - let a_typ = - FStar_Syntax_Syntax.bv_to_name - a1 in - let wp_a_typ = - FStar_Syntax_Syntax.bv_to_name - wp_a in - let repr_f = - repr_type - sub.FStar_Syntax_Syntax.source - a_typ wp_a_typ in - let repr_result = - let lift_wp1 = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.EraseUniverses; - FStar_TypeChecker_Env.AllowUnboundUniverses] - env2 - (FStar_Pervasives_Native.snd - lift_wp) in - let lift_wp_a = - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Syntax_Syntax.as_arg - a_typ in - let uu___13 = - let uu___14 = - FStar_Syntax_Syntax.as_arg - wp_a_typ in - [uu___14] in - uu___12 :: uu___13 in - { - FStar_Syntax_Syntax.hd = - lift_wp1; - FStar_Syntax_Syntax.args - = uu___11 - } in - FStar_Syntax_Syntax.Tm_app - uu___10 in - let uu___10 = - FStar_TypeChecker_Env.get_range - env2 in - FStar_Syntax_Syntax.mk uu___9 - uu___10 in - repr_type - sub.FStar_Syntax_Syntax.target - a_typ lift_wp_a in - let expected_k1 = - let uu___9 = - let uu___10 = - FStar_Syntax_Syntax.mk_binder - a1 in - let uu___11 = - let uu___12 = - FStar_Syntax_Syntax.mk_binder - wp_a in - let uu___13 = - let uu___14 = - FStar_Syntax_Syntax.null_binder - repr_f in - [uu___14] in - uu___12 :: uu___13 in - uu___10 :: uu___11 in - let uu___10 = - FStar_Syntax_Syntax.mk_Total - repr_result in - FStar_Syntax_Util.arrow uu___9 - uu___10 in - let uu___9 = - FStar_TypeChecker_TcTerm.tc_tot_or_gtot_term - env2 expected_k1 in - (match uu___9 with - | (expected_k2, uu___10, uu___11) - -> - let lift4 = - if - (FStar_Compiler_List.length - uvs) - = Prims.int_zero - then - check_and_gen1 env2 lift3 - expected_k2 - else - (let lift5 = - FStar_TypeChecker_TcTerm.tc_check_trivial_guard - env2 lift3 - expected_k2 in - let uu___13 = - FStar_Syntax_Subst.close_univ_vars - uvs lift5 in - (uvs, uu___13)) in - FStar_Pervasives_Native.Some - lift4))) in - (if - (FStar_Compiler_List.length - (FStar_Pervasives_Native.fst lift_wp)) - <> Prims.int_one - then - (let uu___8 = - let uu___9 = - FStar_Class_Show.show - FStar_Ident.showable_lident - sub.FStar_Syntax_Syntax.source in - let uu___10 = - FStar_Class_Show.show - FStar_Ident.showable_lident - sub.FStar_Syntax_Syntax.target in - let uu___11 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length - (FStar_Pervasives_Native.fst lift_wp)) in - FStar_Compiler_Util.format3 - "Sub effect wp must be polymorphic in exactly 1 universe; %s ~> %s has %s universes" - uu___9 uu___10 uu___11 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_TooManyUniverse () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___8)) - else (); - (let uu___9 = - (FStar_Compiler_Util.is_some lift1) && - (let uu___10 = - let uu___11 = - let uu___12 = - FStar_Compiler_Util.must lift1 in - FStar_Pervasives_Native.fst uu___12 in - FStar_Compiler_List.length uu___11 in - uu___10 <> Prims.int_one) in - if uu___9 - then - let uu___10 = - let uu___11 = - FStar_Class_Show.show - FStar_Ident.showable_lident - sub.FStar_Syntax_Syntax.source in - let uu___12 = - FStar_Class_Show.show - FStar_Ident.showable_lident - sub.FStar_Syntax_Syntax.target in - let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = - FStar_Compiler_Util.must lift1 in - FStar_Pervasives_Native.fst uu___16 in - FStar_Compiler_List.length uu___15 in - FStar_Compiler_Util.string_of_int uu___14 in - FStar_Compiler_Util.format3 - "Sub effect lift must be polymorphic in exactly 1 universe; %s ~> %s has %s universes" - uu___11 uu___12 uu___13 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_TooManyUniverse () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___10) - else ()); - { - FStar_Syntax_Syntax.source = - (sub.FStar_Syntax_Syntax.source); - FStar_Syntax_Syntax.target = - (sub.FStar_Syntax_Syntax.target); - FStar_Syntax_Syntax.lift_wp = - (FStar_Pervasives_Native.Some lift_wp); - FStar_Syntax_Syntax.lift = lift1; - FStar_Syntax_Syntax.kind = - (sub.FStar_Syntax_Syntax.kind) - })))))) -let (tc_effect_abbrev : - FStar_TypeChecker_Env.env -> - (FStar_Ident.lident * FStar_Syntax_Syntax.univ_names * - FStar_Syntax_Syntax.binders * FStar_Syntax_Syntax.comp) -> - FStar_Compiler_Range_Type.range -> - (FStar_Ident.lident * FStar_Syntax_Syntax.univ_names * - FStar_Syntax_Syntax.binders * FStar_Syntax_Syntax.comp)) - = - fun env -> - fun uu___ -> - fun r -> - match uu___ with - | (lid, uvs, tps, c) -> - let env0 = env in - let uu___1 = - if (FStar_Compiler_List.length uvs) = Prims.int_zero - then (env, uvs, tps, c) - else - (let uu___3 = FStar_Syntax_Subst.univ_var_opening uvs in - match uu___3 with - | (usubst, uvs1) -> - let tps1 = FStar_Syntax_Subst.subst_binders usubst tps in - let c1 = - let uu___4 = - FStar_Syntax_Subst.shift_subst - (FStar_Compiler_List.length tps1) usubst in - FStar_Syntax_Subst.subst_comp uu___4 c in - let uu___4 = - FStar_TypeChecker_Env.push_univ_vars env uvs1 in - (uu___4, uvs1, tps1, c1)) in - (match uu___1 with - | (env1, uvs1, tps1, c1) -> - let env2 = FStar_TypeChecker_Env.set_range env1 r in - let uu___2 = FStar_Syntax_Subst.open_comp tps1 c1 in - (match uu___2 with - | (tps2, c2) -> - let uu___3 = - FStar_TypeChecker_TcTerm.tc_tparams env2 tps2 in - (match uu___3 with - | (tps3, env3, us) -> - let uu___4 = - FStar_TypeChecker_TcTerm.tc_comp env3 c2 in - (match uu___4 with - | (c3, u, g) -> - let is_default_effect = - let uu___5 = - FStar_TypeChecker_Env.get_default_effect - env3 - (FStar_Syntax_Util.comp_effect_name c3) in - match uu___5 with - | FStar_Pervasives_Native.None -> false - | FStar_Pervasives_Native.Some l -> - FStar_Ident.lid_equals l lid in - (FStar_TypeChecker_Rel.force_trivial_guard - env3 g; - (let expected_result_typ = - match tps3 with - | { FStar_Syntax_Syntax.binder_bv = x; - FStar_Syntax_Syntax.binder_qual = - uu___7; - FStar_Syntax_Syntax.binder_positivity - = uu___8; - FStar_Syntax_Syntax.binder_attrs = - uu___9;_}::tl - -> - (if - is_default_effect && - (Prims.op_Negation (tl = [])) - then - (let uu___11 = - let uu___12 = - FStar_Ident.string_of_lid lid in - let uu___13 = - FStar_Ident.string_of_lid - (FStar_Syntax_Util.comp_effect_name - c3) in - FStar_Compiler_Util.format2 - "Effect %s is marked as a default effect for %s, but it has more than one arguments" - uu___12 uu___13 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - r - FStar_Errors_Codes.Fatal_UnexpectedEffect - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___11)) - else (); - FStar_Syntax_Syntax.bv_to_name x) - | uu___7 -> - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - r - FStar_Errors_Codes.Fatal_NotEnoughArgumentsForEffect - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Effect abbreviations must bind at least the result type") in - let def_result_typ = - FStar_Syntax_Util.comp_result c3 in - let uu___7 = - let uu___8 = - FStar_TypeChecker_Rel.teq_nosmt_force - env3 expected_result_typ - def_result_typ in - Prims.op_Negation uu___8 in - if uu___7 - then - let uu___8 = - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - expected_result_typ in - let uu___10 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - def_result_typ in - FStar_Compiler_Util.format2 - "Result type of effect abbreviation `%s` does not match the result type of its definition `%s`" - uu___9 uu___10 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_EffectAbbreviationResultTypeMismatch - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___8) - else ()); - (let tps4 = - FStar_Syntax_Subst.close_binders tps3 in - let c4 = - FStar_Syntax_Subst.close_comp tps4 c3 in - let uu___7 = - let uu___8 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 = tps4; - FStar_Syntax_Syntax.comp = c4 - }) r in - FStar_TypeChecker_Generalize.generalize_universes - env0 uu___8 in - match uu___7 with - | (uvs2, t) -> - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Syntax_Subst.compress t in - uu___11.FStar_Syntax_Syntax.n in - (tps4, uu___10) in - match uu___9 with - | ([], FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 = - uu___10; - FStar_Syntax_Syntax.comp = c5;_}) - -> ([], c5) - | (uu___10, - FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = tps5; - FStar_Syntax_Syntax.comp = c5;_}) - -> (tps5, c5) - | uu___10 -> - failwith - "Impossible (t is an arrow)" in - (match uu___8 with - | (tps5, c5) -> - (if - (FStar_Compiler_List.length - uvs2) - <> Prims.int_one - then - (let uu___10 = - FStar_Syntax_Subst.open_univ_vars - uvs2 t in - match uu___10 with - | (uu___11, t1) -> - let uu___12 = - let uu___13 = - FStar_Class_Show.show - FStar_Ident.showable_lident - lid in - let uu___14 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_nat) - (FStar_Compiler_List.length - uvs2) in - let uu___15 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t1 in - FStar_Compiler_Util.format3 - "Effect abbreviations must be polymorphic in exactly 1 universe; %s has %s universes (%s)" - uu___13 uu___14 - uu___15 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - r - FStar_Errors_Codes.Fatal_TooManyUniverse - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___12)) - else (); - (lid, uvs2, tps5, c5))))))))) -let (check_polymonadic_bind_for_erasable_effects : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident -> - FStar_Ident.lident -> - FStar_Ident.lident -> FStar_Compiler_Range_Type.range -> unit) - = - fun env -> - fun m -> - fun n -> - fun p -> - fun r -> - let err reason = - let uu___ = - let uu___1 = - FStar_Class_Show.show FStar_Ident.showable_lident m in - let uu___2 = - FStar_Class_Show.show FStar_Ident.showable_lident n in - let uu___3 = - FStar_Class_Show.show FStar_Ident.showable_lident p in - FStar_Compiler_Util.format4 - "Error definition polymonadic bind (%s, %s) |> %s: %s" - uu___1 uu___2 uu___3 reason in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_UnexpectedEffect () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___) in - let m1 = FStar_TypeChecker_Env.norm_eff_name env m in - let n1 = FStar_TypeChecker_Env.norm_eff_name env n in - let uu___ = - (FStar_Ident.lid_equals m1 FStar_Parser_Const.effect_GHOST_lid) - || - (FStar_Ident.lid_equals n1 - FStar_Parser_Const.effect_GHOST_lid) in - if uu___ - then - err - "GHOST computations are not allowed to be composed using user-defined polymonadic binds" - else - (let m_erasable = - FStar_TypeChecker_Env.is_erasable_effect env m1 in - let n_erasable = - FStar_TypeChecker_Env.is_erasable_effect env n1 in - let p_erasable = - FStar_TypeChecker_Env.is_erasable_effect env p in - if p_erasable - then - let uu___2 = - (Prims.op_Negation m_erasable) && - (let uu___3 = - FStar_Ident.lid_equals m1 - FStar_Parser_Const.effect_PURE_lid in - Prims.op_Negation uu___3) in - (if uu___2 - then - let uu___3 = - let uu___4 = FStar_Ident.string_of_lid m1 in - FStar_Compiler_Util.format1 - "target effect is erasable but %s is neither erasable nor PURE" - uu___4 in - err uu___3 - else - (let uu___4 = - (Prims.op_Negation n_erasable) && - (let uu___5 = - FStar_Ident.lid_equals n1 - FStar_Parser_Const.effect_PURE_lid in - Prims.op_Negation uu___5) in - if uu___4 - then - let uu___5 = - let uu___6 = FStar_Ident.string_of_lid n1 in - FStar_Compiler_Util.format1 - "target effect is erasable but %s is neither erasable nor PURE" - uu___6 in - err uu___5 - else ())) - else ()) -let (tc_polymonadic_bind : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident -> - FStar_Ident.lident -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.tscheme -> - (FStar_Syntax_Syntax.tscheme * FStar_Syntax_Syntax.tscheme * - FStar_Syntax_Syntax.indexed_effect_combinator_kind)) - = - fun env -> - fun m -> - fun n -> - fun p -> - fun ts -> - let eff_name = - let uu___ = - let uu___1 = FStar_Ident.ident_of_lid m in - FStar_Ident.string_of_id uu___1 in - let uu___1 = - let uu___2 = FStar_Ident.ident_of_lid n in - FStar_Ident.string_of_id uu___2 in - let uu___2 = - let uu___3 = FStar_Ident.ident_of_lid p in - FStar_Ident.string_of_id uu___3 in - FStar_Compiler_Util.format3 "(%s, %s) |> %s)" uu___ uu___1 - uu___2 in - let r = (FStar_Pervasives_Native.snd ts).FStar_Syntax_Syntax.pos in - check_polymonadic_bind_for_erasable_effects env m n p r; - (let uu___1 = - check_and_gen env eff_name "polymonadic_bind" - (Prims.of_int (2)) ts in - match uu___1 with - | (us, t, ty) -> - let uu___2 = FStar_Syntax_Subst.open_univ_vars us ty in - (match uu___2 with - | (us1, ty1) -> - let env1 = FStar_TypeChecker_Env.push_univ_vars env us1 in - let uu___3 = - let uu___4 = - FStar_TypeChecker_Env.get_effect_decl env1 m in - let uu___5 = - FStar_TypeChecker_Env.get_effect_decl env1 n in - let uu___6 = - FStar_TypeChecker_Env.get_effect_decl env1 p in - (uu___4, uu___5, uu___6) in - (match uu___3 with - | (m_ed, n_ed, p_ed) -> - let uu___4 = - let uu___5 = - FStar_Syntax_Util.effect_sig_ts - m_ed.FStar_Syntax_Syntax.signature in - let uu___6 = - FStar_Syntax_Util.effect_sig_ts - n_ed.FStar_Syntax_Syntax.signature in - let uu___7 = - FStar_Syntax_Util.effect_sig_ts - p_ed.FStar_Syntax_Syntax.signature in - let uu___8 = FStar_Syntax_Util.get_eff_repr m_ed in - let uu___9 = FStar_Syntax_Util.get_eff_repr n_ed in - let uu___10 = - FStar_Syntax_Util.get_eff_repr p_ed in - let uu___11 = - FStar_TypeChecker_Env.get_range env1 in - validate_indexed_effect_bind_shape env1 m n p - uu___5 uu___6 uu___7 uu___8 uu___9 uu___10 us1 - ty1 uu___11 Prims.int_zero false in - (match uu___4 with - | (k, kind) -> - ((let uu___6 = - FStar_Compiler_Debug.extreme () in - if uu___6 - then - let uu___7 = - FStar_Syntax_Print.tscheme_to_string - (us1, t) in - let uu___8 = - FStar_Syntax_Print.tscheme_to_string - (us1, k) in - FStar_Compiler_Util.print3 - "Polymonadic bind %s after typechecking (%s::%s)\n" - eff_name uu___7 uu___8 - else ()); - (let uu___7 = - let uu___8 = - let uu___9 = - FStar_Compiler_Util.format1 - "Polymonadic binds (%s in this case) is an experimental feature;it is subject to some redesign in the future. Please keep us informed (on github etc.) about how you are using it" - eff_name in - FStar_Errors_Msg.text uu___9 in - [uu___8] in - FStar_Errors.log_issue - FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Warning_BleedingEdge_Feature - () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___7)); - (let uu___7 = - let uu___8 = - FStar_Syntax_Subst.close_univ_vars us1 - k in - (us1, uu___8) in - ((us1, t), uu___7, kind))))))) -let (tc_polymonadic_subcomp : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.tscheme -> - (FStar_Syntax_Syntax.tscheme * FStar_Syntax_Syntax.tscheme * - FStar_Syntax_Syntax.indexed_effect_combinator_kind)) - = - fun env0 -> - fun m -> - fun n -> - fun ts -> - let r = (FStar_Pervasives_Native.snd ts).FStar_Syntax_Syntax.pos in - check_lift_for_erasable_effects env0 m n r; - (let combinator_name = - let uu___1 = - let uu___2 = FStar_Ident.ident_of_lid m in - FStar_Ident.string_of_id uu___2 in - let uu___2 = - let uu___3 = - let uu___4 = FStar_Ident.ident_of_lid n in - FStar_Ident.string_of_id uu___4 in - Prims.strcat " <: " uu___3 in - Prims.strcat uu___1 uu___2 in - let uu___1 = - check_and_gen env0 combinator_name "polymonadic_subcomp" - Prims.int_one ts in - match uu___1 with - | (us, t, ty) -> - let uu___2 = FStar_Syntax_Subst.open_univ_vars us ty in - (match uu___2 with - | (us1, ty1) -> - let env = FStar_TypeChecker_Env.push_univ_vars env0 us1 in - let uu___3 = - let uu___4 = - FStar_TypeChecker_Env.get_effect_decl env m in - let uu___5 = - FStar_TypeChecker_Env.get_effect_decl env n in - (uu___4, uu___5) in - (match uu___3 with - | (m_ed, n_ed) -> - let uu___4 = - let uu___5 = - FStar_Syntax_Util.effect_sig_ts - m_ed.FStar_Syntax_Syntax.signature in - let uu___6 = - FStar_Syntax_Util.effect_sig_ts - n_ed.FStar_Syntax_Syntax.signature in - let uu___7 = FStar_Syntax_Util.get_eff_repr m_ed in - let uu___8 = FStar_Syntax_Util.get_eff_repr n_ed in - let uu___9 = FStar_Compiler_List.hd us1 in - let uu___10 = FStar_TypeChecker_Env.get_range env in - validate_indexed_effect_subcomp_shape env m n - uu___5 uu___6 uu___7 uu___8 uu___9 ty1 - Prims.int_zero uu___10 in - (match uu___4 with - | (k, kind) -> - ((let uu___6 = FStar_Compiler_Debug.extreme () in - if uu___6 - then - let uu___7 = - FStar_Syntax_Print.tscheme_to_string - (us1, t) in - let uu___8 = - FStar_Syntax_Print.tscheme_to_string - (us1, k) in - FStar_Compiler_Util.print3 - "Polymonadic subcomp %s after typechecking (%s::%s)\n" - combinator_name uu___7 uu___8 - else ()); - (let uu___7 = - let uu___8 = - let uu___9 = - FStar_Compiler_Util.format1 - "Polymonadic subcomp (%s in this case) is an experimental feature;it is subject to some redesign in the future. Please keep us informed (on github etc.) about how you are using it" - combinator_name in - FStar_Errors_Msg.text uu___9 in - [uu___8] in - FStar_Errors.log_issue - FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Warning_BleedingEdge_Feature - () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___7)); - (let uu___7 = - let uu___8 = - FStar_Syntax_Subst.close_univ_vars us1 k in - (us1, uu___8) in - ((us1, t), uu___7, kind))))))) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_TcInductive.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_TcInductive.ml deleted file mode 100644 index 462c0bc4c4d..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_TcInductive.ml +++ /dev/null @@ -1,3775 +0,0 @@ -open Prims -let (dbg_GenUniverses : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "GenUniverses" -let (dbg_LogTypes : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "LogTypes" -let (dbg_Injectivity : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Injectivity" -let (unfold_whnf : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - FStar_TypeChecker_Normalize.unfold_whnf' - [FStar_TypeChecker_Env.AllowUnboundUniverses] -let (check_sig_inductive_injectivity_on_params : - FStar_TypeChecker_Env.env_t -> - FStar_Syntax_Syntax.sigelt -> FStar_Syntax_Syntax.sigelt) - = - fun tcenv -> - fun se -> - if tcenv.FStar_TypeChecker_Env.phase1 - then se - else - (let uu___1 = se.FStar_Syntax_Syntax.sigel in - match uu___1 with - | FStar_Syntax_Syntax.Sig_inductive_typ dd -> - let uu___2 = dd in - (match uu___2 with - | { FStar_Syntax_Syntax.lid = t; - FStar_Syntax_Syntax.us = universe_names; - FStar_Syntax_Syntax.params = tps; - FStar_Syntax_Syntax.num_uniform_params = uu___3; - FStar_Syntax_Syntax.t = k; - FStar_Syntax_Syntax.mutuals = uu___4; - FStar_Syntax_Syntax.ds = uu___5; - FStar_Syntax_Syntax.injective_type_params = uu___6;_} -> - let t_lid = t in - let uu___7 = - FStar_Syntax_Subst.univ_var_opening universe_names in - (match uu___7 with - | (usubst, uvs) -> - let uu___8 = - let uu___9 = - FStar_TypeChecker_Env.push_univ_vars tcenv uvs in - let uu___10 = - FStar_Syntax_Subst.subst_binders usubst tps in - let uu___11 = - let uu___12 = - FStar_Syntax_Subst.shift_subst - (FStar_Compiler_List.length tps) usubst in - FStar_Syntax_Subst.subst uu___12 k in - (uu___9, uu___10, uu___11) in - (match uu___8 with - | (tcenv1, tps1, k1) -> - let uu___9 = FStar_Syntax_Subst.open_term tps1 k1 in - (match uu___9 with - | (tps2, k2) -> - let uu___10 = - FStar_Syntax_Util.arrow_formals k2 in - (match uu___10 with - | (uu___11, k3) -> - let uu___12 = - FStar_TypeChecker_TcTerm.tc_binders - tcenv1 tps2 in - (match uu___12 with - | (tps3, env_tps, uu___13, us) -> - let u_k = - let uu___14 = - let uu___15 = - FStar_Syntax_Syntax.fvar t - FStar_Pervasives_Native.None in - let uu___16 = - let uu___17 = - FStar_Syntax_Util.args_of_binders - tps3 in - FStar_Pervasives_Native.snd - uu___17 in - let uu___17 = - FStar_Ident.range_of_lid t in - FStar_Syntax_Syntax.mk_Tm_app - uu___15 uu___16 uu___17 in - FStar_TypeChecker_TcTerm.level_of_type - env_tps uu___14 k3 in - let rec universe_leq u v = - match (u, v) with - | (FStar_Syntax_Syntax.U_zero, - uu___14) -> true - | (FStar_Syntax_Syntax.U_succ - u0, - FStar_Syntax_Syntax.U_succ - v0) -> universe_leq u0 v0 - | (FStar_Syntax_Syntax.U_name - u0, - FStar_Syntax_Syntax.U_name - v0) -> - FStar_Ident.ident_equals u0 - v0 - | (FStar_Syntax_Syntax.U_name - uu___14, - FStar_Syntax_Syntax.U_succ - v0) -> universe_leq u v0 - | (FStar_Syntax_Syntax.U_max - us1, uu___14) -> - FStar_Compiler_Util.for_all - (fun u1 -> - universe_leq u1 v) us1 - | (uu___14, - FStar_Syntax_Syntax.U_max vs) - -> - FStar_Compiler_Util.for_some - (universe_leq u) vs - | (FStar_Syntax_Syntax.U_unknown, - uu___14) -> - let uu___15 = - let uu___16 = - FStar_Class_Show.show - FStar_Ident.showable_lident - t in - let uu___17 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_univ - u in - let uu___18 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_univ - v in - FStar_Compiler_Util.format3 - "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" - uu___16 uu___17 uu___18 in - failwith uu___15 - | (uu___14, - FStar_Syntax_Syntax.U_unknown) - -> - let uu___15 = - let uu___16 = - FStar_Class_Show.show - FStar_Ident.showable_lident - t in - let uu___17 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_univ - u in - let uu___18 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_univ - v in - FStar_Compiler_Util.format3 - "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" - uu___16 uu___17 uu___18 in - failwith uu___15 - | (FStar_Syntax_Syntax.U_unif - uu___14, uu___15) -> - let uu___16 = - let uu___17 = - FStar_Class_Show.show - FStar_Ident.showable_lident - t in - let uu___18 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_univ - u in - let uu___19 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_univ - v in - FStar_Compiler_Util.format3 - "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" - uu___17 uu___18 uu___19 in - failwith uu___16 - | (uu___14, - FStar_Syntax_Syntax.U_unif - uu___15) -> - let uu___16 = - let uu___17 = - FStar_Class_Show.show - FStar_Ident.showable_lident - t in - let uu___18 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_univ - u in - let uu___19 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_univ - v in - FStar_Compiler_Util.format3 - "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" - uu___17 uu___18 uu___19 in - failwith uu___16 - | uu___14 -> false in - let u_leq_u_k u = - let u1 = - FStar_TypeChecker_Normalize.normalize_universe - env_tps u in - universe_leq u1 u_k in - let tp_ok tp u_tp = - let t_tp = - (tp.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - let uu___14 = u_leq_u_k u_tp in - if uu___14 - then true - else - (let t_tp1 = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Unrefine; - FStar_TypeChecker_Env.Unascribe; - FStar_TypeChecker_Env.Unmeta; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.HNF; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Beta] - env_tps t_tp in - let uu___16 = - FStar_Syntax_Util.arrow_formals - t_tp1 in - match uu___16 with - | (formals, t1) -> - let uu___17 = - FStar_TypeChecker_TcTerm.tc_binders - env_tps formals in - (match uu___17 with - | (uu___18, uu___19, - uu___20, u_formals) - -> - let inj = - FStar_Compiler_Util.for_all - (fun u_formal -> - u_leq_u_k - u_formal) - u_formals in - if inj - then - let uu___21 = - let uu___22 = - FStar_Syntax_Subst.compress - t1 in - uu___22.FStar_Syntax_Syntax.n in - (match uu___21 - with - | FStar_Syntax_Syntax.Tm_type - u -> - u_leq_u_k u - | uu___22 -> - false) - else false)) in - let injective_type_params = - FStar_Compiler_List.forall2 - tp_ok tps3 us in - ((let uu___15 = - FStar_Compiler_Effect.op_Bang - dbg_Injectivity in - if uu___15 - then - let uu___16 = - FStar_Ident.string_of_lid t in - FStar_Compiler_Util.print2 - "%s injectivity for %s\n" - (if injective_type_params - then "YES" - else "NO") uu___16 - else ()); - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_inductive_typ - { - FStar_Syntax_Syntax.lid - = - (dd.FStar_Syntax_Syntax.lid); - FStar_Syntax_Syntax.us = - (dd.FStar_Syntax_Syntax.us); - FStar_Syntax_Syntax.params - = - (dd.FStar_Syntax_Syntax.params); - FStar_Syntax_Syntax.num_uniform_params - = - (dd.FStar_Syntax_Syntax.num_uniform_params); - FStar_Syntax_Syntax.t = - (dd.FStar_Syntax_Syntax.t); - FStar_Syntax_Syntax.mutuals - = - (dd.FStar_Syntax_Syntax.mutuals); - FStar_Syntax_Syntax.ds = - (dd.FStar_Syntax_Syntax.ds); - FStar_Syntax_Syntax.injective_type_params - = - injective_type_params - }); - FStar_Syntax_Syntax.sigrng = - (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs - = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se.FStar_Syntax_Syntax.sigopts) - })))))))) -let (tc_tycon : - FStar_TypeChecker_Env.env_t -> - FStar_Syntax_Syntax.sigelt -> - (FStar_TypeChecker_Env.env_t * FStar_Syntax_Syntax.sigelt * - FStar_Syntax_Syntax.universe * FStar_TypeChecker_Common.guard_t)) - = - fun env -> - fun s -> - match s.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = tc; FStar_Syntax_Syntax.us = uvs; - FStar_Syntax_Syntax.params = tps; - FStar_Syntax_Syntax.num_uniform_params = n_uniform; - FStar_Syntax_Syntax.t = k; FStar_Syntax_Syntax.mutuals = mutuals; - FStar_Syntax_Syntax.ds = data; - FStar_Syntax_Syntax.injective_type_params = uu___;_} - -> - let env0 = env in - let uu___1 = FStar_Syntax_Subst.univ_var_opening uvs in - (match uu___1 with - | (usubst, uvs1) -> - let uu___2 = - let uu___3 = FStar_TypeChecker_Env.push_univ_vars env uvs1 in - let uu___4 = FStar_Syntax_Subst.subst_binders usubst tps in - let uu___5 = - let uu___6 = - FStar_Syntax_Subst.shift_subst - (FStar_Compiler_List.length tps) usubst in - FStar_Syntax_Subst.subst uu___6 k in - (uu___3, uu___4, uu___5) in - (match uu___2 with - | (env1, tps1, k1) -> - let uu___3 = FStar_Syntax_Subst.open_term tps1 k1 in - (match uu___3 with - | (tps2, k2) -> - let uu___4 = - FStar_TypeChecker_TcTerm.tc_binders env1 tps2 in - (match uu___4 with - | (tps3, env_tps, guard_params, us) -> - let uu___5 = - let uu___6 = - FStar_TypeChecker_TcTerm.tc_tot_or_gtot_term - env_tps k2 in - match uu___6 with - | (k3, uu___7, g) -> - let k4 = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Exclude - FStar_TypeChecker_Env.Iota; - FStar_TypeChecker_Env.Exclude - FStar_TypeChecker_Env.Zeta; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.NoFullNorm; - FStar_TypeChecker_Env.Exclude - FStar_TypeChecker_Env.Beta] env_tps - k3 in - let uu___8 = - FStar_Syntax_Util.arrow_formals k4 in - let uu___9 = - let uu___10 = - FStar_TypeChecker_Env.conj_guard - guard_params g in - FStar_TypeChecker_Rel.discharge_guard - env_tps uu___10 in - (uu___8, uu___9) in - (match uu___5 with - | ((indices, t), guard) -> - let k3 = - let uu___6 = - FStar_Syntax_Syntax.mk_Total t in - FStar_Syntax_Util.arrow indices uu___6 in - let uu___6 = FStar_Syntax_Util.type_u () in - (match uu___6 with - | (t_type, u) -> - let valid_type = - (((FStar_Syntax_Util.is_eqtype_no_unrefine - t) - && - (Prims.op_Negation - (FStar_Compiler_List.contains - FStar_Syntax_Syntax.Noeq - s.FStar_Syntax_Syntax.sigquals))) - && - (Prims.op_Negation - (FStar_Compiler_List.contains - FStar_Syntax_Syntax.Unopteq - s.FStar_Syntax_Syntax.sigquals))) - || - (FStar_TypeChecker_Rel.teq_nosmt_force - env1 t t_type) in - (if Prims.op_Negation valid_type - then - (let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t in - let uu___12 = - FStar_Class_Show.show - FStar_Ident.showable_lident - tc in - FStar_Compiler_Util.format2 - "Type annotation %s for inductive %s is not Type or eqtype, or it is eqtype but contains noeq/unopteq qualifiers" - uu___11 uu___12 in - FStar_Errors_Msg.text uu___10 in - [uu___9] in - FStar_Errors.raise_error - FStar_Syntax_Syntax.has_range_sigelt - s - FStar_Errors_Codes.Error_InductiveAnnotNotAType - () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___8)) - else (); - (let usubst1 = - FStar_Syntax_Subst.univ_var_closing - uvs1 in - let guard1 = - FStar_TypeChecker_Util.close_guard_implicits - env1 false tps3 guard in - let t_tc = - let uu___8 = - let uu___9 = - FStar_Syntax_Subst.subst_binders - usubst1 tps3 in - let uu___10 = - let uu___11 = - FStar_Syntax_Subst.shift_subst - (FStar_Compiler_List.length - tps3) usubst1 in - FStar_Syntax_Subst.subst_binders - uu___11 indices in - FStar_Compiler_List.op_At - uu___9 uu___10 in - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Syntax_Subst.shift_subst - ((FStar_Compiler_List.length - tps3) - + - (FStar_Compiler_List.length - indices)) usubst1 in - FStar_Syntax_Subst.subst - uu___11 t in - FStar_Syntax_Syntax.mk_Total - uu___10 in - FStar_Syntax_Util.arrow uu___8 - uu___9 in - let tps4 = - FStar_Syntax_Subst.close_binders - tps3 in - let k4 = - FStar_Syntax_Subst.close tps4 k3 in - let uu___8 = - let uu___9 = - FStar_Syntax_Subst.subst_binders - usubst1 tps4 in - let uu___10 = - let uu___11 = - FStar_Syntax_Subst.shift_subst - (FStar_Compiler_List.length - tps4) usubst1 in - FStar_Syntax_Subst.subst - uu___11 k4 in - (uu___9, uu___10) in - match uu___8 with - | (tps5, k5) -> - let fv_tc = - FStar_Syntax_Syntax.lid_as_fv - tc - FStar_Pervasives_Native.None in - let uu___9 = - FStar_Syntax_Subst.open_univ_vars - uvs1 t_tc in - (match uu___9 with - | (uvs2, t_tc1) -> - let uu___10 = - FStar_TypeChecker_Env.push_let_binding - env0 - (FStar_Pervasives.Inr - fv_tc) - (uvs2, t_tc1) in - (uu___10, - { - FStar_Syntax_Syntax.sigel - = - (FStar_Syntax_Syntax.Sig_inductive_typ - { - FStar_Syntax_Syntax.lid - = tc; - FStar_Syntax_Syntax.us - = uvs2; - FStar_Syntax_Syntax.params - = tps5; - FStar_Syntax_Syntax.num_uniform_params - = n_uniform; - FStar_Syntax_Syntax.t - = k5; - FStar_Syntax_Syntax.mutuals - = mutuals; - FStar_Syntax_Syntax.ds - = data; - FStar_Syntax_Syntax.injective_type_params - = false - }); - FStar_Syntax_Syntax.sigrng - = - (s.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals - = - (s.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta - = - (s.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs - = - (s.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs - = - (s.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts - = - (s.FStar_Syntax_Syntax.sigopts) - }, u, guard1)))))))))) - | uu___ -> failwith "impossible" -let (mk_implicit : FStar_Syntax_Syntax.bqual -> FStar_Syntax_Syntax.bqual) = - fun uu___ -> - match uu___ with - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta q) -> - FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta q) - | uu___1 -> - FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit false) -let (tc_data : - FStar_TypeChecker_Env.env_t -> - (FStar_Syntax_Syntax.sigelt * FStar_Syntax_Syntax.universe) Prims.list -> - FStar_Syntax_Syntax.sigelt -> - (FStar_Syntax_Syntax.sigelt * FStar_TypeChecker_Common.guard_t)) - = - fun env -> - fun tcs -> - fun se -> - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = c; FStar_Syntax_Syntax.us1 = _uvs; - FStar_Syntax_Syntax.t1 = t; - FStar_Syntax_Syntax.ty_lid = tc_lid; - FStar_Syntax_Syntax.num_ty_params = ntps; - FStar_Syntax_Syntax.mutuals1 = mutual_tcs; - FStar_Syntax_Syntax.injective_type_params1 = uu___;_} - -> - let uu___1 = FStar_Syntax_Subst.univ_var_opening _uvs in - (match uu___1 with - | (usubst, _uvs1) -> - let uu___2 = - let uu___3 = - FStar_TypeChecker_Env.push_univ_vars env _uvs1 in - let uu___4 = FStar_Syntax_Subst.subst usubst t in - (uu___3, uu___4) in - (match uu___2 with - | (env1, t1) -> - let uu___3 = - let tps_u_opt = - FStar_Compiler_Util.find_map tcs - (fun uu___4 -> - match uu___4 with - | (se1, u_tc) -> - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Syntax_Util.lid_of_sigelt se1 in - FStar_Compiler_Util.must uu___7 in - FStar_Ident.lid_equals tc_lid uu___6 in - if uu___5 - then - (match se1.FStar_Syntax_Syntax.sigel - with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = uu___6; - FStar_Syntax_Syntax.us = uu___7; - FStar_Syntax_Syntax.params = tps; - FStar_Syntax_Syntax.num_uniform_params - = uu___8; - FStar_Syntax_Syntax.t = uu___9; - FStar_Syntax_Syntax.mutuals = - uu___10; - FStar_Syntax_Syntax.ds = uu___11; - FStar_Syntax_Syntax.injective_type_params - = uu___12;_} - -> - let tps1 = - let uu___13 = - FStar_Syntax_Subst.subst_binders - usubst tps in - FStar_Compiler_List.map - (fun x -> - { - FStar_Syntax_Syntax.binder_bv - = - (x.FStar_Syntax_Syntax.binder_bv); - FStar_Syntax_Syntax.binder_qual - = - (FStar_Pervasives_Native.Some - FStar_Syntax_Syntax.imp_tag); - FStar_Syntax_Syntax.binder_positivity - = - (x.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs - = - (x.FStar_Syntax_Syntax.binder_attrs) - }) uu___13 in - let tps2 = - FStar_Syntax_Subst.open_binders - tps1 in - let uu___13 = - let uu___14 = - FStar_TypeChecker_Env.push_binders - env1 tps2 in - (uu___14, tps2, u_tc) in - FStar_Pervasives_Native.Some - uu___13 - | uu___6 -> failwith "Impossible") - else FStar_Pervasives_Native.None) in - match tps_u_opt with - | FStar_Pervasives_Native.Some x -> x - | FStar_Pervasives_Native.None -> - let uu___4 = - FStar_Ident.lid_equals tc_lid - FStar_Parser_Const.exn_lid in - if uu___4 - then (env1, [], FStar_Syntax_Syntax.U_zero) - else - FStar_Errors.raise_error - FStar_Syntax_Syntax.has_range_sigelt se - FStar_Errors_Codes.Fatal_UnexpectedDataConstructor - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic "Unexpected data constructor") in - (match uu___3 with - | (env2, tps, u_tc) -> - let uu___4 = - let t2 = - FStar_TypeChecker_Normalize.normalize - (FStar_Compiler_List.op_At - FStar_TypeChecker_Normalize.whnf_steps - [FStar_TypeChecker_Env.AllowUnboundUniverses]) - env2 t1 in - let t3 = FStar_Syntax_Util.canon_arrow t2 in - let uu___5 = - let uu___6 = FStar_Syntax_Subst.compress t3 in - uu___6.FStar_Syntax_Syntax.n in - match uu___5 with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; - FStar_Syntax_Syntax.comp = res;_} - -> - let uu___6 = - FStar_Compiler_Util.first_N ntps bs in - (match uu___6 with - | (uu___7, bs') -> - let t4 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 = bs'; - FStar_Syntax_Syntax.comp = res - }) t3.FStar_Syntax_Syntax.pos in - let subst = - FStar_Compiler_List.mapi - (fun i -> - fun uu___8 -> - match uu___8 with - | { - FStar_Syntax_Syntax.binder_bv - = x; - FStar_Syntax_Syntax.binder_qual - = uu___9; - FStar_Syntax_Syntax.binder_positivity - = uu___10; - FStar_Syntax_Syntax.binder_attrs - = uu___11;_} - -> - FStar_Syntax_Syntax.DB - ((ntps - - (Prims.int_one + i)), - x)) tps in - let uu___8 = - let uu___9 = - FStar_Syntax_Subst.subst subst t4 in - FStar_Syntax_Util.arrow_formals_comp - uu___9 in - (match uu___8 with - | (bs1, c1) -> - let uu___9 = - (FStar_Options.ml_ish ()) || - (FStar_Syntax_Util.is_total_comp - c1) in - if uu___9 - then - (bs1, - (FStar_Syntax_Util.comp_result - c1)) - else - FStar_Errors.raise_error - FStar_Ident.hasrange_lident - (FStar_Syntax_Util.comp_effect_name - c1) - FStar_Errors_Codes.Fatal_UnexpectedConstructorType - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Constructors cannot have effects"))) - | uu___6 -> ([], t3) in - (match uu___4 with - | (arguments, result) -> - ((let uu___6 = FStar_Compiler_Debug.low () in - if uu___6 - then - let uu___7 = - FStar_Class_Show.show - FStar_Ident.showable_lident c in - let uu___8 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binder) - arguments in - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - result in - FStar_Compiler_Util.print3 - "Checking datacon %s : %s -> %s \n" - uu___7 uu___8 uu___9 - else ()); - (let uu___6 = - FStar_TypeChecker_TcTerm.tc_tparams env2 - arguments in - match uu___6 with - | (arguments1, env', us) -> - let type_u_tc = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_type u_tc) - result.FStar_Syntax_Syntax.pos in - let env'1 = - FStar_TypeChecker_Env.set_expected_typ - env' type_u_tc in - let uu___7 = - FStar_TypeChecker_TcTerm.tc_trivial_guard - env'1 result in - (match uu___7 with - | (result1, res_lcomp) -> - let uu___8 = - FStar_Syntax_Util.head_and_args_full - result1 in - (match uu___8 with - | (head, args) -> - let g_uvs = - let uu___9 = - let uu___10 = - FStar_Syntax_Subst.compress - head in - uu___10.FStar_Syntax_Syntax.n in - match uu___9 with - | FStar_Syntax_Syntax.Tm_uinst - ({ - FStar_Syntax_Syntax.n - = - FStar_Syntax_Syntax.Tm_fvar - fv; - FStar_Syntax_Syntax.pos - = uu___10; - FStar_Syntax_Syntax.vars - = uu___11; - FStar_Syntax_Syntax.hash_code - = uu___12;_}, - tuvs) - when - FStar_Syntax_Syntax.fv_eq_lid - fv tc_lid - -> - if - (FStar_Compiler_List.length - _uvs1) - = - (FStar_Compiler_List.length - tuvs) - then - FStar_Compiler_List.fold_left2 - (fun g -> - fun u1 -> - fun u2 -> - let uu___13 - = - let uu___14 - = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_type - u1) - FStar_Compiler_Range_Type.dummyRange in - let uu___15 - = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_type - (FStar_Syntax_Syntax.U_name - u2)) - FStar_Compiler_Range_Type.dummyRange in - FStar_TypeChecker_Rel.teq - env'1 - uu___14 - uu___15 in - FStar_TypeChecker_Env.conj_guard - g uu___13) - FStar_TypeChecker_Env.trivial_guard - tuvs _uvs1 - else - FStar_Errors.raise_error - FStar_Syntax_Syntax.has_range_sigelt - se - FStar_Errors_Codes.Fatal_UnexpectedConstructorType - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Length of annotated universes does not match inferred universes") - | FStar_Syntax_Syntax.Tm_fvar - fv when - FStar_Syntax_Syntax.fv_eq_lid - fv tc_lid - -> - FStar_TypeChecker_Env.trivial_guard - | uu___10 -> - let uu___11 = - let uu___12 = - FStar_Class_Show.show - FStar_Ident.showable_lident - tc_lid in - let uu___13 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - head in - FStar_Compiler_Util.format2 - "Expected a constructor of type %s; got %s" - uu___12 uu___13 in - FStar_Errors.raise_error - FStar_Syntax_Syntax.has_range_sigelt - se - FStar_Errors_Codes.Fatal_UnexpectedConstructorType - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___11) in - let g = - FStar_Compiler_List.fold_left2 - (fun g1 -> - fun uu___9 -> - fun u_x -> - match uu___9 with - | { - FStar_Syntax_Syntax.binder_bv - = x; - FStar_Syntax_Syntax.binder_qual - = uu___10; - FStar_Syntax_Syntax.binder_positivity - = uu___11; - FStar_Syntax_Syntax.binder_attrs - = uu___12;_} - -> - let uu___13 = - FStar_TypeChecker_Rel.universe_inequality - u_x u_tc in - FStar_TypeChecker_Env.conj_guard - g1 uu___13) - g_uvs arguments1 us in - (FStar_Errors.stop_if_err (); - (let p_args = - let uu___10 = - FStar_Compiler_Util.first_N - (FStar_Compiler_List.length - tps) args in - FStar_Pervasives_Native.fst - uu___10 in - FStar_Compiler_List.iter2 - (fun uu___11 -> - fun uu___12 -> - match (uu___11, - uu___12) - with - | ({ - FStar_Syntax_Syntax.binder_bv - = bv; - FStar_Syntax_Syntax.binder_qual - = uu___13; - FStar_Syntax_Syntax.binder_positivity - = uu___14; - FStar_Syntax_Syntax.binder_attrs - = uu___15;_}, - (t2, uu___16)) -> - let uu___17 = - let uu___18 = - FStar_Syntax_Subst.compress - t2 in - uu___18.FStar_Syntax_Syntax.n in - (match uu___17 - with - | FStar_Syntax_Syntax.Tm_name - bv' when - FStar_Syntax_Syntax.bv_eq - bv bv' - -> () - | uu___18 -> - let uu___19 - = - let uu___20 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_bv - bv in - let uu___21 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t2 in - FStar_Compiler_Util.format2 - "This parameter is not constant: expected %s, got %s" - uu___20 - uu___21 in - FStar_Errors.raise_error - ( - FStar_Syntax_Syntax.has_range_syntax - ()) t2 - FStar_Errors_Codes.Error_BadInductiveParam - () - ( - Obj.magic - FStar_Errors_Msg.is_error_message_string) - ( - Obj.magic - uu___19))) - tps p_args; - (let ty = - let uu___11 = - unfold_whnf env2 - res_lcomp.FStar_TypeChecker_Common.res_typ in - FStar_Syntax_Util.unrefine - uu___11 in - (let uu___12 = - let uu___13 = - FStar_Syntax_Subst.compress - ty in - uu___13.FStar_Syntax_Syntax.n in - match uu___12 with - | FStar_Syntax_Syntax.Tm_type - uu___13 -> () - | uu___13 -> - let uu___14 = - let uu___15 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - result1 in - let uu___16 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - ty in - FStar_Compiler_Util.format2 - "The type of %s is %s, but since this is the result type of a constructor its type should be Type" - uu___15 uu___16 in - FStar_Errors.raise_error - FStar_Syntax_Syntax.has_range_sigelt - se - FStar_Errors_Codes.Fatal_WrongResultTypeAfterConstrutor - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___14)); - (let t2 = - let uu___12 = - let uu___13 = - FStar_Compiler_List.map - (fun b -> - { - FStar_Syntax_Syntax.binder_bv - = - (b.FStar_Syntax_Syntax.binder_bv); - FStar_Syntax_Syntax.binder_qual - = - (FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Implicit - true)); - FStar_Syntax_Syntax.binder_positivity - = - (b.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs - = - (b.FStar_Syntax_Syntax.binder_attrs) - }) tps in - FStar_Compiler_List.op_At - uu___13 arguments1 in - let uu___13 = - FStar_Syntax_Syntax.mk_Total - result1 in - FStar_Syntax_Util.arrow - uu___12 uu___13 in - let t3 = - FStar_Syntax_Subst.close_univ_vars - _uvs1 t2 in - ({ - FStar_Syntax_Syntax.sigel - = - (FStar_Syntax_Syntax.Sig_datacon - { - FStar_Syntax_Syntax.lid1 - = c; - FStar_Syntax_Syntax.us1 - = _uvs1; - FStar_Syntax_Syntax.t1 - = t3; - FStar_Syntax_Syntax.ty_lid - = tc_lid; - FStar_Syntax_Syntax.num_ty_params - = ntps; - FStar_Syntax_Syntax.mutuals1 - = mutual_tcs; - FStar_Syntax_Syntax.injective_type_params1 - = false - }); - FStar_Syntax_Syntax.sigrng - = - (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals - = - (se.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta - = - (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs - = - (se.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs - = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts - = - (se.FStar_Syntax_Syntax.sigopts) - }, g))))))))))))) - | uu___ -> failwith "impossible" -let (generalize_and_inst_within : - FStar_TypeChecker_Env.env_t -> - (FStar_Syntax_Syntax.sigelt * FStar_Syntax_Syntax.universe) Prims.list -> - FStar_Syntax_Syntax.sigelt Prims.list -> - (FStar_Syntax_Syntax.sigelt Prims.list * FStar_Syntax_Syntax.sigelt - Prims.list)) - = - fun env -> - fun tcs -> - fun datas -> - let binders = - FStar_Compiler_List.map - (fun uu___ -> - match uu___ with - | (se, uu___1) -> - (match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = uu___2; - FStar_Syntax_Syntax.us = uu___3; - FStar_Syntax_Syntax.params = tps; - FStar_Syntax_Syntax.num_uniform_params = uu___4; - FStar_Syntax_Syntax.t = k; - FStar_Syntax_Syntax.mutuals = uu___5; - FStar_Syntax_Syntax.ds = uu___6; - FStar_Syntax_Syntax.injective_type_params = uu___7;_} - -> - let uu___8 = - let uu___9 = FStar_Syntax_Syntax.mk_Total k in - FStar_Syntax_Util.arrow tps uu___9 in - FStar_Syntax_Syntax.null_binder uu___8 - | uu___2 -> failwith "Impossible")) tcs in - let binders' = - FStar_Compiler_List.map - (fun se -> - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = uu___; - FStar_Syntax_Syntax.us1 = uu___1; - FStar_Syntax_Syntax.t1 = t; - FStar_Syntax_Syntax.ty_lid = uu___2; - FStar_Syntax_Syntax.num_ty_params = uu___3; - FStar_Syntax_Syntax.mutuals1 = uu___4; - FStar_Syntax_Syntax.injective_type_params1 = uu___5;_} - -> FStar_Syntax_Syntax.null_binder t - | uu___ -> failwith "Impossible") datas in - let t = - let uu___ = FStar_Syntax_Syntax.mk_Total FStar_Syntax_Syntax.t_unit in - FStar_Syntax_Util.arrow - (FStar_Compiler_List.op_At binders binders') uu___ in - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_GenUniverses in - if uu___1 - then - let uu___2 = FStar_TypeChecker_Normalize.term_to_string env t in - FStar_Compiler_Util.print1 - "@@@@@@Trying to generalize universes in %s\n" uu___2 - else ()); - (let uu___1 = FStar_TypeChecker_Generalize.generalize_universes env t in - match uu___1 with - | (uvs, t1) -> - ((let uu___3 = FStar_Compiler_Effect.op_Bang dbg_GenUniverses in - if uu___3 - then - let uu___4 = - let uu___5 = - FStar_Compiler_List.map - (fun u -> FStar_Ident.string_of_id u) uvs in - FStar_Compiler_String.concat ", " uu___5 in - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - FStar_Compiler_Util.print2 "@@@@@@Generalized to (%s, %s)\n" - uu___4 uu___5 - else ()); - (let uu___3 = FStar_Syntax_Subst.open_univ_vars uvs t1 in - match uu___3 with - | (uvs1, t2) -> - let uu___4 = FStar_Syntax_Util.arrow_formals t2 in - (match uu___4 with - | (args, uu___5) -> - let uu___6 = - FStar_Compiler_Util.first_N - (FStar_Compiler_List.length binders) args in - (match uu___6 with - | (tc_types, data_types) -> - let tcs1 = - FStar_Compiler_List.map2 - (fun uu___7 -> - fun uu___8 -> - match (uu___7, uu___8) with - | ({ FStar_Syntax_Syntax.binder_bv = x; - FStar_Syntax_Syntax.binder_qual = - uu___9; - FStar_Syntax_Syntax.binder_positivity - = uu___10; - FStar_Syntax_Syntax.binder_attrs = - uu___11;_}, - (se, uu___12)) -> - (match se.FStar_Syntax_Syntax.sigel - with - | FStar_Syntax_Syntax.Sig_inductive_typ - { - FStar_Syntax_Syntax.lid = tc; - FStar_Syntax_Syntax.us = - uu___13; - FStar_Syntax_Syntax.params = - tps; - FStar_Syntax_Syntax.num_uniform_params - = num_uniform; - FStar_Syntax_Syntax.t = - uu___14; - FStar_Syntax_Syntax.mutuals - = mutuals; - FStar_Syntax_Syntax.ds = - datas1; - FStar_Syntax_Syntax.injective_type_params - = uu___15;_} - -> - let ty = - FStar_Syntax_Subst.close_univ_vars - uvs1 - x.FStar_Syntax_Syntax.sort in - let uu___16 = - let uu___17 = - let uu___18 = - FStar_Syntax_Subst.compress - ty in - uu___18.FStar_Syntax_Syntax.n in - match uu___17 with - | FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 - = binders1; - FStar_Syntax_Syntax.comp - = c;_} - -> - let uu___18 = - FStar_Compiler_Util.first_N - (FStar_Compiler_List.length - tps) binders1 in - (match uu___18 with - | (tps1, rest) -> - let t3 = - match rest with - | [] -> - FStar_Syntax_Util.comp_result - c - | uu___19 -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 - = rest; - FStar_Syntax_Syntax.comp - = c - }) - (x.FStar_Syntax_Syntax.sort).FStar_Syntax_Syntax.pos in - (tps1, t3)) - | uu___18 -> ([], ty) in - (match uu___16 with - | (tps1, t3) -> - { - FStar_Syntax_Syntax.sigel - = - (FStar_Syntax_Syntax.Sig_inductive_typ - { - FStar_Syntax_Syntax.lid - = tc; - FStar_Syntax_Syntax.us - = uvs1; - FStar_Syntax_Syntax.params - = tps1; - FStar_Syntax_Syntax.num_uniform_params - = num_uniform; - FStar_Syntax_Syntax.t - = t3; - FStar_Syntax_Syntax.mutuals - = mutuals; - FStar_Syntax_Syntax.ds - = datas1; - FStar_Syntax_Syntax.injective_type_params - = false - }); - FStar_Syntax_Syntax.sigrng - = - (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals - = - (se.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta - = - (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs - = - (se.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs - = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts - = - (se.FStar_Syntax_Syntax.sigopts) - }) - | uu___13 -> failwith "Impossible")) - tc_types tcs in - let datas1 = - match uvs1 with - | [] -> datas - | uu___7 -> - let uvs_universes = - FStar_Compiler_List.map - (fun uu___8 -> - FStar_Syntax_Syntax.U_name uu___8) - uvs1 in - let tc_insts = - FStar_Compiler_List.map - (fun uu___8 -> - match uu___8 with - | { - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_inductive_typ - { - FStar_Syntax_Syntax.lid = - tc; - FStar_Syntax_Syntax.us = - uu___9; - FStar_Syntax_Syntax.params - = uu___10; - FStar_Syntax_Syntax.num_uniform_params - = uu___11; - FStar_Syntax_Syntax.t = - uu___12; - FStar_Syntax_Syntax.mutuals - = uu___13; - FStar_Syntax_Syntax.ds = - uu___14; - FStar_Syntax_Syntax.injective_type_params - = uu___15;_}; - FStar_Syntax_Syntax.sigrng = - uu___16; - FStar_Syntax_Syntax.sigquals = - uu___17; - FStar_Syntax_Syntax.sigmeta = - uu___18; - FStar_Syntax_Syntax.sigattrs = - uu___19; - FStar_Syntax_Syntax.sigopens_and_abbrevs - = uu___20; - FStar_Syntax_Syntax.sigopts = - uu___21;_} - -> (tc, uvs_universes) - | uu___9 -> failwith "Impossible") - tcs1 in - FStar_Compiler_List.map2 - (fun uu___8 -> - fun d -> - match uu___8 with - | { - FStar_Syntax_Syntax.binder_bv = - t3; - FStar_Syntax_Syntax.binder_qual - = uu___9; - FStar_Syntax_Syntax.binder_positivity - = uu___10; - FStar_Syntax_Syntax.binder_attrs - = uu___11;_} - -> - (match d.FStar_Syntax_Syntax.sigel - with - | FStar_Syntax_Syntax.Sig_datacon - { - FStar_Syntax_Syntax.lid1 - = l; - FStar_Syntax_Syntax.us1 - = uu___12; - FStar_Syntax_Syntax.t1 = - uu___13; - FStar_Syntax_Syntax.ty_lid - = tc; - FStar_Syntax_Syntax.num_ty_params - = ntps; - FStar_Syntax_Syntax.mutuals1 - = mutuals; - FStar_Syntax_Syntax.injective_type_params1 - = uu___14;_} - -> - let ty = - let uu___15 = - FStar_Syntax_InstFV.instantiate - tc_insts - t3.FStar_Syntax_Syntax.sort in - FStar_Syntax_Subst.close_univ_vars - uvs1 uu___15 in - { - FStar_Syntax_Syntax.sigel - = - (FStar_Syntax_Syntax.Sig_datacon - { - FStar_Syntax_Syntax.lid1 - = l; - FStar_Syntax_Syntax.us1 - = uvs1; - FStar_Syntax_Syntax.t1 - = ty; - FStar_Syntax_Syntax.ty_lid - = tc; - FStar_Syntax_Syntax.num_ty_params - = ntps; - FStar_Syntax_Syntax.mutuals1 - = mutuals; - FStar_Syntax_Syntax.injective_type_params1 - = false - }); - FStar_Syntax_Syntax.sigrng - = - (d.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals - = - (d.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta - = - (d.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs - = - (d.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs - = - (d.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts - = - (d.FStar_Syntax_Syntax.sigopts) - } - | uu___12 -> - failwith "Impossible")) - data_types datas in - (tcs1, datas1)))))) -let (datacon_typ : FStar_Syntax_Syntax.sigelt -> FStar_Syntax_Syntax.term) = - fun data -> - match data.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = uu___; FStar_Syntax_Syntax.us1 = uu___1; - FStar_Syntax_Syntax.t1 = t; FStar_Syntax_Syntax.ty_lid = uu___2; - FStar_Syntax_Syntax.num_ty_params = uu___3; - FStar_Syntax_Syntax.mutuals1 = uu___4; - FStar_Syntax_Syntax.injective_type_params1 = uu___5;_} - -> t - | uu___ -> failwith "Impossible!" -let (haseq_suffix : Prims.string) = "__uu___haseq" -let (is_haseq_lid : FStar_Ident.lid -> Prims.bool) = - fun lid -> - let str = FStar_Ident.string_of_lid lid in - let len = FStar_Compiler_String.length str in - let haseq_suffix_len = FStar_Compiler_String.length haseq_suffix in - (len > haseq_suffix_len) && - (let uu___ = - let uu___1 = - FStar_Compiler_String.substring str (len - haseq_suffix_len) - haseq_suffix_len in - FStar_Compiler_String.compare uu___1 haseq_suffix in - uu___ = Prims.int_zero) -let (get_haseq_axiom_lid : FStar_Ident.lid -> FStar_Ident.lid) = - fun lid -> - let uu___ = - let uu___1 = FStar_Ident.ns_of_lid lid in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = FStar_Ident.ident_of_lid lid in - FStar_Ident.string_of_id uu___6 in - Prims.strcat uu___5 haseq_suffix in - FStar_Ident.id_of_text uu___4 in - [uu___3] in - FStar_Compiler_List.op_At uu___1 uu___2 in - FStar_Ident.lid_of_ids uu___ -let (get_optimized_haseq_axiom : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.sigelt -> - FStar_Syntax_Syntax.subst_elt Prims.list -> - FStar_Syntax_Syntax.univ_names -> - (FStar_Ident.lident * FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.binders * FStar_Syntax_Syntax.binders * - FStar_Syntax_Syntax.term)) - = - fun en -> - fun ty -> - fun usubst -> - fun us -> - let uu___ = - match ty.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = lid; - FStar_Syntax_Syntax.us = uu___1; - FStar_Syntax_Syntax.params = bs; - FStar_Syntax_Syntax.num_uniform_params = uu___2; - FStar_Syntax_Syntax.t = t; - FStar_Syntax_Syntax.mutuals = uu___3; - FStar_Syntax_Syntax.ds = uu___4; - FStar_Syntax_Syntax.injective_type_params = uu___5;_} - -> (lid, bs, t) - | uu___1 -> failwith "Impossible!" in - match uu___ with - | (lid, bs, t) -> - let bs1 = FStar_Syntax_Subst.subst_binders usubst bs in - let t1 = - let uu___1 = - FStar_Syntax_Subst.shift_subst - (FStar_Compiler_List.length bs1) usubst in - FStar_Syntax_Subst.subst uu___1 t in - let uu___1 = FStar_Syntax_Subst.open_term bs1 t1 in - (match uu___1 with - | (bs2, t2) -> - let ibs = - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress t2 in - uu___3.FStar_Syntax_Syntax.n in - match uu___2 with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = ibs1; - FStar_Syntax_Syntax.comp = uu___3;_} - -> ibs1 - | uu___3 -> [] in - let ibs1 = FStar_Syntax_Subst.open_binders ibs in - let ind = - let uu___2 = - FStar_Syntax_Syntax.fvar lid - FStar_Pervasives_Native.None in - let uu___3 = - FStar_Compiler_List.map - (fun u -> FStar_Syntax_Syntax.U_name u) us in - FStar_Syntax_Syntax.mk_Tm_uinst uu___2 uu___3 in - let ind1 = - let uu___2 = - FStar_Compiler_List.map - FStar_Syntax_Util.arg_of_non_null_binder bs2 in - FStar_Syntax_Syntax.mk_Tm_app ind uu___2 - FStar_Compiler_Range_Type.dummyRange in - let ind2 = - let uu___2 = - FStar_Compiler_List.map - FStar_Syntax_Util.arg_of_non_null_binder ibs1 in - FStar_Syntax_Syntax.mk_Tm_app ind1 uu___2 - FStar_Compiler_Range_Type.dummyRange in - let haseq_ind = - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.as_arg ind2 in - [uu___3] in - FStar_Syntax_Syntax.mk_Tm_app FStar_Syntax_Util.t_haseq - uu___2 FStar_Compiler_Range_Type.dummyRange in - let bs' = - FStar_Compiler_List.filter - (fun b -> - let uu___2 = - let uu___3 = FStar_Syntax_Util.type_u () in - FStar_Pervasives_Native.fst uu___3 in - FStar_TypeChecker_Rel.subtype_nosmt_force en - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort - uu___2) bs2 in - let haseq_bs = - FStar_Compiler_List.fold_left - (fun t3 -> - fun b -> - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Syntax_Syntax.bv_to_name - b.FStar_Syntax_Syntax.binder_bv in - FStar_Syntax_Syntax.as_arg uu___5 in - [uu___4] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Syntax_Util.t_haseq uu___3 - FStar_Compiler_Range_Type.dummyRange in - FStar_Syntax_Util.mk_conj t3 uu___2) - FStar_Syntax_Util.t_true bs' in - let fml = FStar_Syntax_Util.mk_imp haseq_bs haseq_ind in - let fml1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Syntax.binders_to_names ibs1 in - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Syntax_Syntax.as_arg haseq_ind in - [uu___9] in - [uu___8] in - (uu___6, uu___7) in - FStar_Syntax_Syntax.Meta_pattern uu___5 in - { - FStar_Syntax_Syntax.tm2 = fml; - FStar_Syntax_Syntax.meta = uu___4 - } in - FStar_Syntax_Syntax.Tm_meta uu___3 in - { - FStar_Syntax_Syntax.n = uu___2; - FStar_Syntax_Syntax.pos = - (fml.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = - (fml.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (fml.FStar_Syntax_Syntax.hash_code) - } in - let fml2 = - FStar_Compiler_List.fold_right - (fun b -> - fun t3 -> - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Syntax.mk_binder - b.FStar_Syntax_Syntax.binder_bv in - [uu___6] in - let uu___6 = - FStar_Syntax_Subst.close [b] t3 in - FStar_Syntax_Util.abs uu___5 uu___6 - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.as_arg uu___4 in - [uu___3] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Syntax_Util.tforall uu___2 - FStar_Compiler_Range_Type.dummyRange) ibs1 fml1 in - let fml3 = - FStar_Compiler_List.fold_right - (fun b -> - fun t3 -> - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Syntax.mk_binder - b.FStar_Syntax_Syntax.binder_bv in - [uu___6] in - let uu___6 = - FStar_Syntax_Subst.close [b] t3 in - FStar_Syntax_Util.abs uu___5 uu___6 - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.as_arg uu___4 in - [uu___3] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Syntax_Util.tforall uu___2 - FStar_Compiler_Range_Type.dummyRange) bs2 fml2 in - let axiom_lid = get_haseq_axiom_lid lid in - (axiom_lid, fml3, bs2, ibs1, haseq_bs)) -let (optimized_haseq_soundness_for_data : - FStar_Ident.lident -> - FStar_Syntax_Syntax.sigelt -> - FStar_Syntax_Syntax.subst_elt Prims.list -> - FStar_Syntax_Syntax.binders -> FStar_Syntax_Syntax.term) - = - fun ty_lid -> - fun data -> - fun usubst -> - fun bs -> - let dt = datacon_typ data in - let dt1 = FStar_Syntax_Subst.subst usubst dt in - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress dt1 in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = dbs; - FStar_Syntax_Syntax.comp = uu___1;_} - -> - let dbs1 = - let uu___2 = - FStar_Compiler_List.splitAt (FStar_Compiler_List.length bs) - dbs in - FStar_Pervasives_Native.snd uu___2 in - let dbs2 = - let uu___2 = FStar_Syntax_Subst.opening_of_binders bs in - FStar_Syntax_Subst.subst_binders uu___2 dbs1 in - let dbs3 = FStar_Syntax_Subst.open_binders dbs2 in - let cond = - FStar_Compiler_List.fold_left - (fun t -> - fun b -> - let haseq_b = - let uu___2 = - let uu___3 = - FStar_Syntax_Syntax.as_arg - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - [uu___3] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Syntax_Util.t_haseq uu___2 - FStar_Compiler_Range_Type.dummyRange in - let sort_range = - ((b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort).FStar_Syntax_Syntax.pos in - let haseq_b1 = - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Errors_Msg.text - "Failed to prove that the type" in - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Class_PP.pp - FStar_Ident.pretty_lident ty_lid in - FStar_Pprint.squotes uu___7 in - let uu___7 = - FStar_Errors_Msg.text - "supports decidable equality because of this argument." in - FStar_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in - FStar_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in - let uu___4 = - let uu___5 = - FStar_Errors_Msg.text - "Add either the 'noeq' or 'unopteq' qualifier" in - [uu___5] in - uu___3 :: uu___4 in - FStar_TypeChecker_Util.label uu___2 sort_range - haseq_b in - FStar_Syntax_Util.mk_conj t haseq_b1) - FStar_Syntax_Util.t_true dbs3 in - FStar_Compiler_List.fold_right - (fun b -> - fun t -> - let uu___2 = - let uu___3 = - FStar_Syntax_Syntax.iarg - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Syntax_Syntax.mk_binder - b.FStar_Syntax_Syntax.binder_bv in - [uu___8] in - let uu___8 = FStar_Syntax_Subst.close [b] t in - FStar_Syntax_Util.abs uu___7 uu___8 - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.as_arg uu___6 in - [uu___5] in - uu___3 :: uu___4 in - FStar_Syntax_Syntax.mk_Tm_app FStar_Syntax_Util.tforall - uu___2 FStar_Compiler_Range_Type.dummyRange) dbs3 cond - | uu___1 -> FStar_Syntax_Util.t_true -let (optimized_haseq_ty : - FStar_Syntax_Syntax.sigelts -> - FStar_Syntax_Syntax.subst_elt Prims.list -> - FStar_Syntax_Syntax.univ_name Prims.list -> - ((FStar_Ident.lident * FStar_Syntax_Syntax.term) Prims.list * - FStar_TypeChecker_Env.env * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax) -> - FStar_Syntax_Syntax.sigelt -> - ((FStar_Ident.lident * FStar_Syntax_Syntax.term) Prims.list * - FStar_TypeChecker_Env.env * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax)) - = - fun all_datas_in_the_bundle -> - fun usubst -> - fun us -> - fun acc -> - fun ty -> - let lid = - match ty.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = lid1; - FStar_Syntax_Syntax.us = uu___; - FStar_Syntax_Syntax.params = uu___1; - FStar_Syntax_Syntax.num_uniform_params = uu___2; - FStar_Syntax_Syntax.t = uu___3; - FStar_Syntax_Syntax.mutuals = uu___4; - FStar_Syntax_Syntax.ds = uu___5; - FStar_Syntax_Syntax.injective_type_params = uu___6;_} - -> lid1 - | uu___ -> failwith "Impossible!" in - let uu___ = acc in - match uu___ with - | (uu___1, en, uu___2, uu___3) -> - let uu___4 = get_optimized_haseq_axiom en ty usubst us in - (match uu___4 with - | (axiom_lid, fml, bs, ibs, haseq_bs) -> - let guard = FStar_Syntax_Util.mk_conj haseq_bs fml in - let uu___5 = acc in - (match uu___5 with - | (l_axioms, env, guard', cond') -> - let env1 = - FStar_TypeChecker_Env.push_binders env bs in - let env2 = - FStar_TypeChecker_Env.push_binders env1 ibs in - let t_datas = - FStar_Compiler_List.filter - (fun s -> - match s.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = uu___6; - FStar_Syntax_Syntax.us1 = uu___7; - FStar_Syntax_Syntax.t1 = uu___8; - FStar_Syntax_Syntax.ty_lid = t_lid; - FStar_Syntax_Syntax.num_ty_params = - uu___9; - FStar_Syntax_Syntax.mutuals1 = uu___10; - FStar_Syntax_Syntax.injective_type_params1 - = uu___11;_} - -> t_lid = lid - | uu___6 -> failwith "Impossible") - all_datas_in_the_bundle in - let cond = - FStar_Compiler_List.fold_left - (fun acc1 -> - fun d -> - let uu___6 = - optimized_haseq_soundness_for_data lid d - usubst bs in - FStar_Syntax_Util.mk_conj acc1 uu___6) - FStar_Syntax_Util.t_true t_datas in - let uu___6 = FStar_Syntax_Util.mk_conj guard' guard in - let uu___7 = FStar_Syntax_Util.mk_conj cond' cond in - ((FStar_Compiler_List.op_At l_axioms - [(axiom_lid, fml)]), env2, uu___6, uu___7))) -let (optimized_haseq_scheme : - FStar_Syntax_Syntax.sigelt -> - FStar_Syntax_Syntax.sigelt Prims.list -> - FStar_Syntax_Syntax.sigelt Prims.list -> - FStar_TypeChecker_Env.env_t -> FStar_Syntax_Syntax.sigelt Prims.list) - = - fun sig_bndle -> - fun tcs -> - fun datas -> - fun env0 -> - let uu___ = - let ty = FStar_Compiler_List.hd tcs in - match ty.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = uu___1; - FStar_Syntax_Syntax.us = us; - FStar_Syntax_Syntax.params = uu___2; - FStar_Syntax_Syntax.num_uniform_params = uu___3; - FStar_Syntax_Syntax.t = t; - FStar_Syntax_Syntax.mutuals = uu___4; - FStar_Syntax_Syntax.ds = uu___5; - FStar_Syntax_Syntax.injective_type_params = uu___6;_} - -> (us, t) - | uu___1 -> failwith "Impossible!" in - match uu___ with - | (us, t) -> - let uu___1 = FStar_Syntax_Subst.univ_var_opening us in - (match uu___1 with - | (usubst, us1) -> - let env = FStar_TypeChecker_Env.push env0 "haseq" in - let env1 = - FStar_TypeChecker_Env.push_sigelt_force env sig_bndle in - ((env1.FStar_TypeChecker_Env.solver).FStar_TypeChecker_Env.encode_sig - env1 sig_bndle; - (let env2 = FStar_TypeChecker_Env.push_univ_vars env1 us1 in - let uu___3 = - FStar_Compiler_List.fold_left - (optimized_haseq_ty datas usubst us1) - ([], env2, FStar_Syntax_Util.t_true, - FStar_Syntax_Util.t_true) tcs in - match uu___3 with - | (axioms, env3, guard, cond) -> - let phi = - let uu___4 = FStar_Syntax_Util.arrow_formals t in - match uu___4 with - | (uu___5, t1) -> - let uu___6 = - FStar_Syntax_Util.is_eqtype_no_unrefine t1 in - if uu___6 - then cond - else FStar_Syntax_Util.mk_imp guard cond in - let uu___4 = - FStar_TypeChecker_TcTerm.tc_trivial_guard env3 phi in - (match uu___4 with - | (phi1, uu___5) -> - ((let uu___7 = - FStar_TypeChecker_Env.should_verify env3 in - if uu___7 - then - let uu___8 = - FStar_TypeChecker_Env.guard_of_guard_formula - (FStar_TypeChecker_Common.NonTrivial - phi1) in - FStar_TypeChecker_Rel.force_trivial_guard - env3 uu___8 - else ()); - (let ses = - FStar_Compiler_List.fold_left - (fun l -> - fun uu___7 -> - match uu___7 with - | (lid, fml) -> - let fml1 = - FStar_Syntax_Subst.close_univ_vars - us1 fml in - FStar_Compiler_List.op_At l - [{ - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_assume - { - FStar_Syntax_Syntax.lid3 - = lid; - FStar_Syntax_Syntax.us3 - = us1; - FStar_Syntax_Syntax.phi1 - = fml1 - }); - FStar_Syntax_Syntax.sigrng - = - FStar_Compiler_Range_Type.dummyRange; - FStar_Syntax_Syntax.sigquals - = - [FStar_Syntax_Syntax.InternalAssumption]; - FStar_Syntax_Syntax.sigmeta - = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs - = []; - FStar_Syntax_Syntax.sigopens_and_abbrevs - = []; - FStar_Syntax_Syntax.sigopts - = - FStar_Pervasives_Native.None - }]) [] axioms in - (let uu___8 = - FStar_TypeChecker_Env.pop env3 "haseq" in - ()); - ses)))))) -let (unoptimized_haseq_data : - FStar_Syntax_Syntax.subst_elt Prims.list -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.term -> - FStar_Ident.lident Prims.list -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.sigelt -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun usubst -> - fun bs -> - fun haseq_ind -> - fun mutuals -> - fun acc -> - fun data -> - let rec is_mutual t = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_fvar fv -> - FStar_Compiler_List.existsb - (fun lid -> - FStar_Ident.lid_equals lid - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v) - mutuals - | FStar_Syntax_Syntax.Tm_uinst (t', uu___1) -> is_mutual t' - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = bv; - FStar_Syntax_Syntax.phi = uu___1;_} - -> is_mutual bv.FStar_Syntax_Syntax.sort - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = t'; - FStar_Syntax_Syntax.args = args;_} - -> - let uu___1 = is_mutual t' in - if uu___1 - then true - else - (let uu___3 = - FStar_Compiler_List.map FStar_Pervasives_Native.fst - args in - exists_mutual uu___3) - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t'; - FStar_Syntax_Syntax.meta = uu___1;_} - -> is_mutual t' - | uu___1 -> false - and exists_mutual uu___ = - match uu___ with - | [] -> false - | hd::tl -> (is_mutual hd) || (exists_mutual tl) in - let dt = datacon_typ data in - let dt1 = FStar_Syntax_Subst.subst usubst dt in - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress dt1 in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = dbs; - FStar_Syntax_Syntax.comp = uu___1;_} - -> - let dbs1 = - let uu___2 = - FStar_Compiler_List.splitAt - (FStar_Compiler_List.length bs) dbs in - FStar_Pervasives_Native.snd uu___2 in - let dbs2 = - let uu___2 = FStar_Syntax_Subst.opening_of_binders bs in - FStar_Syntax_Subst.subst_binders uu___2 dbs1 in - let dbs3 = FStar_Syntax_Subst.open_binders dbs2 in - let cond = - FStar_Compiler_List.fold_left - (fun t -> - fun b -> - let sort = - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - let haseq_sort = - let uu___2 = - let uu___3 = - FStar_Syntax_Syntax.as_arg - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - [uu___3] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Syntax_Util.t_haseq uu___2 - FStar_Compiler_Range_Type.dummyRange in - let haseq_sort1 = - let uu___2 = is_mutual sort in - if uu___2 - then - FStar_Syntax_Util.mk_imp haseq_ind haseq_sort - else haseq_sort in - FStar_Syntax_Util.mk_conj t haseq_sort1) - FStar_Syntax_Util.t_true dbs3 in - let cond1 = - FStar_Compiler_List.fold_right - (fun b -> - fun t -> - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Syntax.mk_binder - b.FStar_Syntax_Syntax.binder_bv in - [uu___6] in - let uu___6 = FStar_Syntax_Subst.close [b] t in - FStar_Syntax_Util.abs uu___5 uu___6 - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.as_arg uu___4 in - [uu___3] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Syntax_Util.tforall uu___2 - FStar_Compiler_Range_Type.dummyRange) dbs3 cond in - FStar_Syntax_Util.mk_conj acc cond1 - | uu___1 -> acc -let (unoptimized_haseq_ty : - FStar_Syntax_Syntax.sigelt Prims.list -> - FStar_Ident.lident Prims.list -> - FStar_Syntax_Syntax.subst_elt Prims.list -> - FStar_Syntax_Syntax.univ_name Prims.list -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.sigelt -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun all_datas_in_the_bundle -> - fun mutuals -> - fun usubst -> - fun us -> - fun acc -> - fun ty -> - let uu___ = - match ty.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = lid; - FStar_Syntax_Syntax.us = uu___1; - FStar_Syntax_Syntax.params = bs; - FStar_Syntax_Syntax.num_uniform_params = uu___2; - FStar_Syntax_Syntax.t = t; - FStar_Syntax_Syntax.mutuals = uu___3; - FStar_Syntax_Syntax.ds = d_lids; - FStar_Syntax_Syntax.injective_type_params = uu___4;_} - -> (lid, bs, t, d_lids) - | uu___1 -> failwith "Impossible!" in - match uu___ with - | (lid, bs, t, d_lids) -> - let bs1 = FStar_Syntax_Subst.subst_binders usubst bs in - let t1 = - let uu___1 = - FStar_Syntax_Subst.shift_subst - (FStar_Compiler_List.length bs1) usubst in - FStar_Syntax_Subst.subst uu___1 t in - let uu___1 = FStar_Syntax_Subst.open_term bs1 t1 in - (match uu___1 with - | (bs2, t2) -> - let ibs = - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress t2 in - uu___3.FStar_Syntax_Syntax.n in - match uu___2 with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = ibs1; - FStar_Syntax_Syntax.comp = uu___3;_} - -> ibs1 - | uu___3 -> [] in - let ibs1 = FStar_Syntax_Subst.open_binders ibs in - let ind = - let uu___2 = - FStar_Syntax_Syntax.fvar lid - FStar_Pervasives_Native.None in - let uu___3 = - FStar_Compiler_List.map - (fun u -> FStar_Syntax_Syntax.U_name u) us in - FStar_Syntax_Syntax.mk_Tm_uinst uu___2 uu___3 in - let ind1 = - let uu___2 = - FStar_Compiler_List.map - FStar_Syntax_Util.arg_of_non_null_binder bs2 in - FStar_Syntax_Syntax.mk_Tm_app ind uu___2 - FStar_Compiler_Range_Type.dummyRange in - let ind2 = - let uu___2 = - FStar_Compiler_List.map - FStar_Syntax_Util.arg_of_non_null_binder ibs1 in - FStar_Syntax_Syntax.mk_Tm_app ind1 uu___2 - FStar_Compiler_Range_Type.dummyRange in - let haseq_ind = - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.as_arg ind2 in - [uu___3] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Syntax_Util.t_haseq uu___2 - FStar_Compiler_Range_Type.dummyRange in - let t_datas = - FStar_Compiler_List.filter - (fun s -> - match s.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = uu___2; - FStar_Syntax_Syntax.us1 = uu___3; - FStar_Syntax_Syntax.t1 = uu___4; - FStar_Syntax_Syntax.ty_lid = t_lid; - FStar_Syntax_Syntax.num_ty_params = - uu___5; - FStar_Syntax_Syntax.mutuals1 = uu___6; - FStar_Syntax_Syntax.injective_type_params1 - = uu___7;_} - -> t_lid = lid - | uu___2 -> failwith "Impossible") - all_datas_in_the_bundle in - let data_cond = - FStar_Compiler_List.fold_left - (unoptimized_haseq_data usubst bs2 haseq_ind - mutuals) FStar_Syntax_Util.t_true t_datas in - let fml = FStar_Syntax_Util.mk_imp data_cond haseq_ind in - let fml1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Syntax.binders_to_names ibs1 in - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Syntax_Syntax.as_arg haseq_ind in - [uu___9] in - [uu___8] in - (uu___6, uu___7) in - FStar_Syntax_Syntax.Meta_pattern uu___5 in - { - FStar_Syntax_Syntax.tm2 = fml; - FStar_Syntax_Syntax.meta = uu___4 - } in - FStar_Syntax_Syntax.Tm_meta uu___3 in - { - FStar_Syntax_Syntax.n = uu___2; - FStar_Syntax_Syntax.pos = - (fml.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = - (fml.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (fml.FStar_Syntax_Syntax.hash_code) - } in - let fml2 = - FStar_Compiler_List.fold_right - (fun b -> - fun t3 -> - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Syntax.mk_binder - b.FStar_Syntax_Syntax.binder_bv in - [uu___6] in - let uu___6 = - FStar_Syntax_Subst.close [b] t3 in - FStar_Syntax_Util.abs uu___5 uu___6 - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.as_arg uu___4 in - [uu___3] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Syntax_Util.tforall uu___2 - FStar_Compiler_Range_Type.dummyRange) ibs1 - fml1 in - let fml3 = - FStar_Compiler_List.fold_right - (fun b -> - fun t3 -> - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Syntax.mk_binder - b.FStar_Syntax_Syntax.binder_bv in - [uu___6] in - let uu___6 = - FStar_Syntax_Subst.close [b] t3 in - FStar_Syntax_Util.abs uu___5 uu___6 - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.as_arg uu___4 in - [uu___3] in - FStar_Syntax_Syntax.mk_Tm_app - FStar_Syntax_Util.tforall uu___2 - FStar_Compiler_Range_Type.dummyRange) bs2 - fml2 in - FStar_Syntax_Util.mk_conj acc fml3) -let (unoptimized_haseq_scheme : - FStar_Syntax_Syntax.sigelt -> - FStar_Syntax_Syntax.sigelt Prims.list -> - FStar_Syntax_Syntax.sigelt Prims.list -> - FStar_TypeChecker_Env.env_t -> FStar_Syntax_Syntax.sigelt Prims.list) - = - fun sig_bndle -> - fun tcs -> - fun datas -> - fun env0 -> - let mutuals = - FStar_Compiler_List.map - (fun ty -> - match ty.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = lid; - FStar_Syntax_Syntax.us = uu___; - FStar_Syntax_Syntax.params = uu___1; - FStar_Syntax_Syntax.num_uniform_params = uu___2; - FStar_Syntax_Syntax.t = uu___3; - FStar_Syntax_Syntax.mutuals = uu___4; - FStar_Syntax_Syntax.ds = uu___5; - FStar_Syntax_Syntax.injective_type_params = uu___6;_} - -> lid - | uu___ -> failwith "Impossible!") tcs in - let uu___ = - let ty = FStar_Compiler_List.hd tcs in - match ty.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = lid; FStar_Syntax_Syntax.us = us; - FStar_Syntax_Syntax.params = uu___1; - FStar_Syntax_Syntax.num_uniform_params = uu___2; - FStar_Syntax_Syntax.t = uu___3; - FStar_Syntax_Syntax.mutuals = uu___4; - FStar_Syntax_Syntax.ds = uu___5; - FStar_Syntax_Syntax.injective_type_params = uu___6;_} - -> (lid, us) - | uu___1 -> failwith "Impossible!" in - match uu___ with - | (lid, us) -> - let uu___1 = FStar_Syntax_Subst.univ_var_opening us in - (match uu___1 with - | (usubst, us1) -> - let fml = - FStar_Compiler_List.fold_left - (unoptimized_haseq_ty datas mutuals usubst us1) - FStar_Syntax_Util.t_true tcs in - let se = - let uu___2 = - let uu___3 = - let uu___4 = get_haseq_axiom_lid lid in - { - FStar_Syntax_Syntax.lid3 = uu___4; - FStar_Syntax_Syntax.us3 = us1; - FStar_Syntax_Syntax.phi1 = fml - } in - FStar_Syntax_Syntax.Sig_assume uu___3 in - { - FStar_Syntax_Syntax.sigel = uu___2; - FStar_Syntax_Syntax.sigrng = - FStar_Compiler_Range_Type.dummyRange; - FStar_Syntax_Syntax.sigquals = - [FStar_Syntax_Syntax.InternalAssumption]; - FStar_Syntax_Syntax.sigmeta = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs = []; - FStar_Syntax_Syntax.sigopens_and_abbrevs = []; - FStar_Syntax_Syntax.sigopts = - FStar_Pervasives_Native.None - } in - [se]) -let (check_inductive_well_typedness : - FStar_TypeChecker_Env.env_t -> - FStar_Syntax_Syntax.sigelt Prims.list -> - FStar_Syntax_Syntax.qualifier Prims.list -> - FStar_Ident.lident Prims.list -> - (FStar_Syntax_Syntax.sigelt * FStar_Syntax_Syntax.sigelt Prims.list - * FStar_Syntax_Syntax.sigelt Prims.list)) - = - fun env -> - fun ses -> - fun quals -> - fun lids -> - let uu___ = - FStar_Compiler_List.partition - (fun uu___1 -> - match uu___1 with - | { - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_inductive_typ uu___2; - FStar_Syntax_Syntax.sigrng = uu___3; - FStar_Syntax_Syntax.sigquals = uu___4; - FStar_Syntax_Syntax.sigmeta = uu___5; - FStar_Syntax_Syntax.sigattrs = uu___6; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___7; - FStar_Syntax_Syntax.sigopts = uu___8;_} -> true - | uu___2 -> false) ses in - match uu___ with - | (tys, datas) -> - ((let uu___2 = - FStar_Compiler_Util.for_some - (fun uu___3 -> - match uu___3 with - | { - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_datacon uu___4; - FStar_Syntax_Syntax.sigrng = uu___5; - FStar_Syntax_Syntax.sigquals = uu___6; - FStar_Syntax_Syntax.sigmeta = uu___7; - FStar_Syntax_Syntax.sigattrs = uu___8; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___9; - FStar_Syntax_Syntax.sigopts = uu___10;_} -> false - | uu___4 -> true) datas in - if uu___2 - then - FStar_Errors.raise_error FStar_TypeChecker_Env.hasRange_env - env - FStar_Errors_Codes.Fatal_NonInductiveInMutuallyDefinedType - () (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Mutually defined type contains a non-inductive element") - else ()); - (let univs = - if (FStar_Compiler_List.length tys) = Prims.int_zero - then [] - else - (let uu___3 = - let uu___4 = FStar_Compiler_List.hd tys in - uu___4.FStar_Syntax_Syntax.sigel in - match uu___3 with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = uu___4; - FStar_Syntax_Syntax.us = uvs; - FStar_Syntax_Syntax.params = uu___5; - FStar_Syntax_Syntax.num_uniform_params = uu___6; - FStar_Syntax_Syntax.t = uu___7; - FStar_Syntax_Syntax.mutuals = uu___8; - FStar_Syntax_Syntax.ds = uu___9; - FStar_Syntax_Syntax.injective_type_params = - uu___10;_} - -> uvs - | uu___4 -> failwith "Impossible, can't happen!") in - let env0 = env in - let uu___2 = - FStar_Compiler_List.fold_right - (fun tc -> - fun uu___3 -> - match uu___3 with - | (env1, all_tcs, g) -> - let uu___4 = tc_tycon env1 tc in - (match uu___4 with - | (env2, tc1, tc_u, guard) -> - let g' = - FStar_TypeChecker_Rel.universe_inequality - FStar_Syntax_Syntax.U_zero tc_u in - ((let uu___6 = FStar_Compiler_Debug.low () in - if uu___6 - then - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_sigelt - tc1 in - FStar_Compiler_Util.print1 - "Checked inductive: %s\n" uu___7 - else ()); - (let uu___6 = - let uu___7 = - FStar_TypeChecker_Env.conj_guard - guard g' in - FStar_TypeChecker_Env.conj_guard g - uu___7 in - (env2, ((tc1, tc_u) :: all_tcs), uu___6))))) - tys (env, [], FStar_TypeChecker_Env.trivial_guard) in - match uu___2 with - | (env1, tcs, g) -> - let g1 = FStar_TypeChecker_Rel.resolve_implicits env1 g in - let uu___3 = - FStar_Compiler_List.fold_right - (fun se -> - fun uu___4 -> - match uu___4 with - | (datas1, g2) -> - let uu___5 = - let uu___6 = tc_data env1 tcs in uu___6 se in - (match uu___5 with - | (data, g') -> - let uu___6 = - FStar_TypeChecker_Env.conj_guard g2 - g' in - ((data :: datas1), uu___6))) datas - ([], g1) in - (match uu___3 with - | (datas1, g2) -> - let uu___4 = - let tc_universe_vars = - FStar_Compiler_List.map - FStar_Pervasives_Native.snd tcs in - let g3 = - let uu___5 = - let uu___6 = - FStar_Class_Listlike.from_list - (FStar_Compiler_CList.listlike_clist ()) - tc_universe_vars in - (uu___6, - (FStar_Pervasives_Native.snd - g2.FStar_TypeChecker_Common.univ_ineqs)) in - { - FStar_TypeChecker_Common.guard_f = - (g2.FStar_TypeChecker_Common.guard_f); - FStar_TypeChecker_Common.deferred_to_tac = - (g2.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (g2.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = uu___5; - FStar_TypeChecker_Common.implicits = - (g2.FStar_TypeChecker_Common.implicits) - } in - (let uu___6 = - FStar_Compiler_Effect.op_Bang dbg_GenUniverses in - if uu___6 - then - let uu___7 = - FStar_TypeChecker_Rel.guard_to_string env1 g3 in - FStar_Compiler_Util.print1 - "@@@@@@Guard before (possible) generalization: %s\n" - uu___7 - else ()); - FStar_TypeChecker_Rel.force_trivial_guard env0 g3; - if - (FStar_Compiler_List.length univs) = - Prims.int_zero - then generalize_and_inst_within env0 tcs datas1 - else - (let uu___8 = - FStar_Compiler_List.map - FStar_Pervasives_Native.fst tcs in - (uu___8, datas1)) in - (match uu___4 with - | (tcs1, datas2) -> - let tcs2 = - FStar_Compiler_List.map - (fun se -> - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = l; - FStar_Syntax_Syntax.us = univs1; - FStar_Syntax_Syntax.params = - binders; - FStar_Syntax_Syntax.num_uniform_params - = num_uniform; - FStar_Syntax_Syntax.t = typ; - FStar_Syntax_Syntax.mutuals = ts; - FStar_Syntax_Syntax.ds = ds; - FStar_Syntax_Syntax.injective_type_params - = uu___5;_} - -> - let fail expected inferred = - let uu___6 = - let uu___7 = - FStar_Syntax_Print.tscheme_to_string - expected in - let uu___8 = - FStar_Syntax_Print.tscheme_to_string - inferred in - FStar_Compiler_Util.format2 - "Expected an inductive with type %s; got %s" - uu___7 uu___8 in - FStar_Errors.raise_error - FStar_Syntax_Syntax.has_range_sigelt - se - FStar_Errors_Codes.Fatal_UnexpectedInductivetype - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___6) in - let copy_binder_attrs_from_val - binders1 expected = - let expected_attrs = - let uu___6 = - let uu___7 = - FStar_TypeChecker_Normalize.get_n_binders - env1 - (FStar_Compiler_List.length - binders1) expected in - FStar_Pervasives_Native.fst - uu___7 in - FStar_Compiler_List.map - (fun uu___7 -> - match uu___7 with - | { - FStar_Syntax_Syntax.binder_bv - = uu___8; - FStar_Syntax_Syntax.binder_qual - = uu___9; - FStar_Syntax_Syntax.binder_positivity - = pqual; - FStar_Syntax_Syntax.binder_attrs - = attrs;_} - -> (attrs, pqual)) - uu___6 in - if - (FStar_Compiler_List.length - expected_attrs) - <> - (FStar_Compiler_List.length - binders1) - then - let uu___6 = - let uu___7 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length - binders1) in - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - expected in - FStar_Compiler_Util.format2 - "Could not get %s type parameters from val type %s" - uu___7 uu___8 in - FStar_Errors.raise_error - FStar_Syntax_Syntax.has_range_sigelt - se - FStar_Errors_Codes.Fatal_UnexpectedInductivetype - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___6) - else - FStar_Compiler_List.map2 - (fun uu___7 -> - fun b -> - match uu___7 with - | (ex_attrs, pqual) -> - ((let uu___9 = - let uu___10 = - FStar_TypeChecker_Common.check_positivity_qual - true pqual - b.FStar_Syntax_Syntax.binder_positivity in - Prims.op_Negation - uu___10 in - if uu___9 - then - FStar_Errors.raise_error - FStar_Syntax_Syntax.hasRange_binder - b - FStar_Errors_Codes.Fatal_UnexpectedInductivetype - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Incompatible positivity annotation") - else ()); - { - FStar_Syntax_Syntax.binder_bv - = - (b.FStar_Syntax_Syntax.binder_bv); - FStar_Syntax_Syntax.binder_qual - = - (b.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity - = pqual; - FStar_Syntax_Syntax.binder_attrs - = - (FStar_Compiler_List.op_At - b.FStar_Syntax_Syntax.binder_attrs - ex_attrs) - })) expected_attrs - binders1 in - let inferred_typ_with_binders - binders1 = - let body = - match binders1 with - | [] -> typ - | uu___6 -> - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Syntax_Syntax.mk_Total - typ in - { - FStar_Syntax_Syntax.bs1 - = binders1; - FStar_Syntax_Syntax.comp - = uu___9 - } in - FStar_Syntax_Syntax.Tm_arrow - uu___8 in - FStar_Syntax_Syntax.mk - uu___7 - se.FStar_Syntax_Syntax.sigrng in - (univs1, body) in - let uu___6 = - FStar_TypeChecker_Env.try_lookup_val_decl - env0 l in - (match uu___6 with - | FStar_Pervasives_Native.None -> - se - | FStar_Pervasives_Native.Some - (expected_typ, uu___7) -> - if - (FStar_Compiler_List.length - univs1) - = - (FStar_Compiler_List.length - (FStar_Pervasives_Native.fst - expected_typ)) - then - let uu___8 = - FStar_Syntax_Subst.open_univ_vars - univs1 - (FStar_Pervasives_Native.snd - expected_typ) in - (match uu___8 with - | (uu___9, expected) -> - let binders1 = - copy_binder_attrs_from_val - binders expected in - let inferred_typ = - inferred_typ_with_binders - binders1 in - let uu___10 = - FStar_Syntax_Subst.open_univ_vars - univs1 - (FStar_Pervasives_Native.snd - inferred_typ) in - (match uu___10 with - | (uu___11, inferred) - -> - let uu___12 = - FStar_TypeChecker_Rel.teq_nosmt_force - env0 inferred - expected in - if uu___12 - then - { - FStar_Syntax_Syntax.sigel - = - (FStar_Syntax_Syntax.Sig_inductive_typ - { - FStar_Syntax_Syntax.lid - = l; - FStar_Syntax_Syntax.us - = univs1; - FStar_Syntax_Syntax.params - = - binders1; - FStar_Syntax_Syntax.num_uniform_params - = - num_uniform; - FStar_Syntax_Syntax.t - = typ; - FStar_Syntax_Syntax.mutuals - = ts; - FStar_Syntax_Syntax.ds - = ds; - FStar_Syntax_Syntax.injective_type_params - = false - }); - FStar_Syntax_Syntax.sigrng - = - (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals - = - (se.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta - = - (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs - = - (se.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs - = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts - = - (se.FStar_Syntax_Syntax.sigopts) - } - else - fail expected_typ - inferred_typ)) - else - (let uu___9 = - inferred_typ_with_binders - binders in - fail expected_typ uu___9)) - | uu___5 -> se) tcs1 in - let tcs3 = - FStar_Compiler_List.map - (check_sig_inductive_injectivity_on_params - env0) tcs2 in - let is_injective l = - let uu___5 = - FStar_Compiler_List.tryPick - (fun se -> - let uu___6 = - se.FStar_Syntax_Syntax.sigel in - match uu___6 with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = lid; - FStar_Syntax_Syntax.us = uu___7; - FStar_Syntax_Syntax.params = - uu___8; - FStar_Syntax_Syntax.num_uniform_params - = uu___9; - FStar_Syntax_Syntax.t = uu___10; - FStar_Syntax_Syntax.mutuals = - uu___11; - FStar_Syntax_Syntax.ds = uu___12; - FStar_Syntax_Syntax.injective_type_params - = injective_type_params;_} - -> - let uu___13 = - FStar_Ident.lid_equals l lid in - if uu___13 - then - FStar_Pervasives_Native.Some - injective_type_params - else FStar_Pervasives_Native.None) - tcs3 in - match uu___5 with - | FStar_Pervasives_Native.None -> false - | FStar_Pervasives_Native.Some i -> i in - let datas3 = - FStar_Compiler_List.map - (fun se -> - let uu___5 = - se.FStar_Syntax_Syntax.sigel in - match uu___5 with - | FStar_Syntax_Syntax.Sig_datacon dd -> - let uu___6 = - let uu___7 = - let uu___8 = - is_injective - dd.FStar_Syntax_Syntax.ty_lid in - { - FStar_Syntax_Syntax.lid1 = - (dd.FStar_Syntax_Syntax.lid1); - FStar_Syntax_Syntax.us1 = - (dd.FStar_Syntax_Syntax.us1); - FStar_Syntax_Syntax.t1 = - (dd.FStar_Syntax_Syntax.t1); - FStar_Syntax_Syntax.ty_lid = - (dd.FStar_Syntax_Syntax.ty_lid); - FStar_Syntax_Syntax.num_ty_params - = - (dd.FStar_Syntax_Syntax.num_ty_params); - FStar_Syntax_Syntax.mutuals1 = - (dd.FStar_Syntax_Syntax.mutuals1); - FStar_Syntax_Syntax.injective_type_params1 - = uu___8 - } in - FStar_Syntax_Syntax.Sig_datacon - uu___7 in - { - FStar_Syntax_Syntax.sigel = uu___6; - FStar_Syntax_Syntax.sigrng = - (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = - (se.FStar_Syntax_Syntax.sigattrs); - FStar_Syntax_Syntax.sigopens_and_abbrevs - = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se.FStar_Syntax_Syntax.sigopts) - }) datas2 in - let sig_bndle = - let uu___5 = - FStar_TypeChecker_Env.get_range env0 in - let uu___6 = - FStar_Compiler_List.collect - (fun s -> s.FStar_Syntax_Syntax.sigattrs) - ses in - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_bundle - { - FStar_Syntax_Syntax.ses = - (FStar_Compiler_List.op_At tcs3 - datas3); - FStar_Syntax_Syntax.lids = lids - }); - FStar_Syntax_Syntax.sigrng = uu___5; - FStar_Syntax_Syntax.sigquals = quals; - FStar_Syntax_Syntax.sigmeta = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs = uu___6; - FStar_Syntax_Syntax.sigopens_and_abbrevs = - []; - FStar_Syntax_Syntax.sigopts = - FStar_Pervasives_Native.None - } in - (sig_bndle, tcs3, datas3))))) -let (early_prims_inductives : Prims.string Prims.list) = - ["empty"; "trivial"; "equals"; "pair"; "sum"] -let (mk_discriminator_and_indexed_projectors : - FStar_Syntax_Syntax.qualifier Prims.list -> - FStar_Syntax_Syntax.attribute Prims.list -> - FStar_Syntax_Syntax.fv_qual -> - Prims.bool -> - FStar_TypeChecker_Env.env -> - FStar_Ident.lident -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.univ_names -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.binders -> - Prims.bool -> FStar_Syntax_Syntax.sigelt Prims.list) - = - fun iquals -> - fun attrs -> - fun fvq -> - fun refine_domain -> - fun env -> - fun tc -> - fun lid -> - fun uvs -> - fun inductive_tps -> - fun indices -> - fun fields -> - fun erasable -> - let p = FStar_Ident.range_of_lid lid in - let pos q = FStar_Syntax_Syntax.withinfo q p in - let projectee ptyp = - FStar_Syntax_Syntax.gen_bv "projectee" - (FStar_Pervasives_Native.Some p) ptyp in - let inst_univs = - FStar_Compiler_List.map - (fun u -> FStar_Syntax_Syntax.U_name u) uvs in - let tps = inductive_tps in - let arg_typ = - let inst_tc = - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Syntax_Syntax.lid_as_fv tc - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___3 in - (uu___2, inst_univs) in - FStar_Syntax_Syntax.Tm_uinst uu___1 in - FStar_Syntax_Syntax.mk uu___ p in - let args = - FStar_Compiler_List.map - FStar_Syntax_Util.arg_of_non_null_binder - (FStar_Compiler_List.op_At tps indices) in - FStar_Syntax_Syntax.mk_Tm_app inst_tc args p in - let unrefined_arg_binder = - let uu___ = projectee arg_typ in - FStar_Syntax_Syntax.mk_binder uu___ in - let arg_binder = - if Prims.op_Negation refine_domain - then unrefined_arg_binder - else - (let disc_name = - FStar_Syntax_Util.mk_discriminator lid in - let x = - FStar_Syntax_Syntax.new_bv - (FStar_Pervasives_Native.Some p) arg_typ in - let sort = - let disc_fvar = - let uu___1 = - FStar_Ident.set_lid_range disc_name p in - FStar_Syntax_Syntax.fvar_with_dd uu___1 - FStar_Pervasives_Native.None in - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Syntax_Syntax.mk_Tm_uinst - disc_fvar inst_univs in - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Syntax.bv_to_name x in - FStar_Syntax_Syntax.as_arg uu___6 in - [uu___5] in - FStar_Syntax_Syntax.mk_Tm_app uu___3 - uu___4 p in - FStar_Syntax_Util.b2t uu___2 in - FStar_Syntax_Util.refine x uu___1 in - let uu___1 = - let uu___2 = projectee arg_typ in - { - FStar_Syntax_Syntax.ppname = - (uu___2.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (uu___2.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = sort - } in - FStar_Syntax_Syntax.mk_binder uu___1) in - let ntps = FStar_Compiler_List.length tps in - let all_params = - let uu___ = - FStar_Compiler_List.map - (fun b -> - { - FStar_Syntax_Syntax.binder_bv = - (b.FStar_Syntax_Syntax.binder_bv); - FStar_Syntax_Syntax.binder_qual = - (FStar_Pervasives_Native.Some - FStar_Syntax_Syntax.imp_tag); - FStar_Syntax_Syntax.binder_positivity = - (b.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs = - (b.FStar_Syntax_Syntax.binder_attrs) - }) tps in - FStar_Compiler_List.op_At uu___ fields in - let imp_binders = - FStar_Compiler_List.map - (fun b -> - let uu___ = - mk_implicit - b.FStar_Syntax_Syntax.binder_qual in - { - FStar_Syntax_Syntax.binder_bv = - (b.FStar_Syntax_Syntax.binder_bv); - FStar_Syntax_Syntax.binder_qual = uu___; - FStar_Syntax_Syntax.binder_positivity = - (b.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs = - (b.FStar_Syntax_Syntax.binder_attrs) - }) (FStar_Compiler_List.op_At tps indices) in - let early_prims_inductive = - (let uu___ = - FStar_TypeChecker_Env.current_module env in - FStar_Ident.lid_equals - FStar_Parser_Const.prims_lid uu___) - && - (FStar_Compiler_List.existsb - (fun s -> - let uu___ = - let uu___1 = - FStar_Ident.ident_of_lid tc in - FStar_Ident.string_of_id uu___1 in - s = uu___) early_prims_inductives) in - let discriminator_ses = - if fvq <> FStar_Syntax_Syntax.Data_ctor - then [] - else - (let discriminator_name = - FStar_Syntax_Util.mk_discriminator lid in - let no_decl = false in - let only_decl = - early_prims_inductive || - (FStar_Syntax_Util.has_attribute attrs - FStar_Parser_Const.no_auto_projectors_attr) in - let quals = - let uu___1 = - FStar_Compiler_List.filter - (fun uu___2 -> - match uu___2 with - | FStar_Syntax_Syntax.Inline_for_extraction - -> true - | FStar_Syntax_Syntax.NoExtract -> - true - | FStar_Syntax_Syntax.Private -> true - | uu___3 -> false) iquals in - FStar_Compiler_List.op_At - ((FStar_Syntax_Syntax.Discriminator lid) - :: - (if only_decl - then - [FStar_Syntax_Syntax.Logic; - FStar_Syntax_Syntax.Assumption] - else [])) uu___1 in - let binders = - FStar_Compiler_List.op_At imp_binders - [unrefined_arg_binder] in - let t = - let bool_typ = - if erasable - then - FStar_Syntax_Syntax.mk_GTotal - FStar_Syntax_Util.t_bool - else - FStar_Syntax_Syntax.mk_Total - FStar_Syntax_Util.t_bool in - let uu___1 = - FStar_Syntax_Util.arrow binders bool_typ in - FStar_Syntax_Subst.close_univ_vars uvs - uu___1 in - let decl = - let uu___1 = - FStar_Ident.range_of_lid - discriminator_name in - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_declare_typ - { - FStar_Syntax_Syntax.lid2 = - discriminator_name; - FStar_Syntax_Syntax.us2 = uvs; - FStar_Syntax_Syntax.t2 = t - }); - FStar_Syntax_Syntax.sigrng = uu___1; - FStar_Syntax_Syntax.sigquals = quals; - FStar_Syntax_Syntax.sigmeta = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs = attrs; - FStar_Syntax_Syntax.sigopens_and_abbrevs = - []; - FStar_Syntax_Syntax.sigopts = - FStar_Pervasives_Native.None - } in - (let uu___2 = - FStar_Compiler_Effect.op_Bang dbg_LogTypes in - if uu___2 - then - let uu___3 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_sigelt decl in - FStar_Compiler_Util.print1 - "Declaration of a discriminator %s\n" - uu___3 - else ()); - if only_decl - then [decl] - else - (let body = - if Prims.op_Negation refine_domain - then FStar_Syntax_Util.exp_true_bool - else - (let arg_pats = - FStar_Compiler_List.mapi - (fun j -> - fun uu___4 -> - match uu___4 with - | { - FStar_Syntax_Syntax.binder_bv - = x; - FStar_Syntax_Syntax.binder_qual - = imp; - FStar_Syntax_Syntax.binder_positivity - = uu___5; - FStar_Syntax_Syntax.binder_attrs - = uu___6;_} - -> - let b = - FStar_Syntax_Syntax.is_bqual_implicit - imp in - if b && (j < ntps) - then - let uu___7 = - pos - (FStar_Syntax_Syntax.Pat_dot_term - FStar_Pervasives_Native.None) in - (uu___7, b) - else - (let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Ident.string_of_id - x.FStar_Syntax_Syntax.ppname in - FStar_Syntax_Syntax.gen_bv - uu___11 - FStar_Pervasives_Native.None - FStar_Syntax_Syntax.tun in - FStar_Syntax_Syntax.Pat_var - uu___10 in - pos uu___9 in - (uu___8, b))) - all_params in - let pat_true = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Syntax_Syntax.lid_as_fv - lid - (FStar_Pervasives_Native.Some - fvq) in - (uu___7, - FStar_Pervasives_Native.None, - arg_pats) in - FStar_Syntax_Syntax.Pat_cons - uu___6 in - pos uu___5 in - (uu___4, - FStar_Pervasives_Native.None, - FStar_Syntax_Util.exp_true_bool) in - let pat_false = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Syntax.new_bv - FStar_Pervasives_Native.None - FStar_Syntax_Syntax.tun in - FStar_Syntax_Syntax.Pat_var - uu___6 in - pos uu___5 in - (uu___4, - FStar_Pervasives_Native.None, - FStar_Syntax_Util.exp_false_bool) in - let arg_exp = - FStar_Syntax_Syntax.bv_to_name - unrefined_arg_binder.FStar_Syntax_Syntax.binder_bv in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Syntax_Util.branch - pat_true in - let uu___8 = - let uu___9 = - FStar_Syntax_Util.branch - pat_false in - [uu___9] in - uu___7 :: uu___8 in - { - FStar_Syntax_Syntax.scrutinee = - arg_exp; - FStar_Syntax_Syntax.ret_opt = - FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.brs = uu___6; - FStar_Syntax_Syntax.rc_opt1 = - FStar_Pervasives_Native.None - } in - FStar_Syntax_Syntax.Tm_match uu___5 in - FStar_Syntax_Syntax.mk uu___4 p) in - let imp = - FStar_Syntax_Util.abs binders body - FStar_Pervasives_Native.None in - let lbtyp = - if no_decl - then t - else FStar_Syntax_Syntax.tun in - let lb = - let uu___3 = - let uu___4 = - FStar_Syntax_Syntax.lid_and_dd_as_fv - discriminator_name - FStar_Pervasives_Native.None in - FStar_Pervasives.Inr uu___4 in - let uu___4 = - FStar_Syntax_Subst.close_univ_vars uvs - imp in - FStar_Syntax_Util.mk_letbinding uu___3 - uvs lbtyp - FStar_Parser_Const.effect_Tot_lid - uu___4 [] - FStar_Compiler_Range_Type.dummyRange in - let impl = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Compiler_Util.right - lb.FStar_Syntax_Syntax.lbname in - (uu___7.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - [uu___6] in - { - FStar_Syntax_Syntax.lbs1 = - (false, [lb]); - FStar_Syntax_Syntax.lids1 = uu___5 - } in - FStar_Syntax_Syntax.Sig_let uu___4 in - { - FStar_Syntax_Syntax.sigel = uu___3; - FStar_Syntax_Syntax.sigrng = p; - FStar_Syntax_Syntax.sigquals = quals; - FStar_Syntax_Syntax.sigmeta = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs = attrs; - FStar_Syntax_Syntax.sigopens_and_abbrevs - = []; - FStar_Syntax_Syntax.sigopts = - FStar_Pervasives_Native.None - } in - (let uu___4 = - FStar_Compiler_Effect.op_Bang - dbg_LogTypes in - if uu___4 - then - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_sigelt - impl in - FStar_Compiler_Util.print1 - "Implementation of a discriminator %s\n" - uu___5 - else ()); - [decl; impl])) in - let arg_exp = - FStar_Syntax_Syntax.bv_to_name - arg_binder.FStar_Syntax_Syntax.binder_bv in - let binders = - FStar_Compiler_List.op_At imp_binders - [arg_binder] in - let arg = - FStar_Syntax_Util.arg_of_non_null_binder - arg_binder in - let subst = - FStar_Compiler_List.mapi - (fun i -> - fun uu___ -> - match uu___ with - | { FStar_Syntax_Syntax.binder_bv = a; - FStar_Syntax_Syntax.binder_qual = - uu___1; - FStar_Syntax_Syntax.binder_positivity - = uu___2; - FStar_Syntax_Syntax.binder_attrs = - uu___3;_} - -> - let field_name = - FStar_Syntax_Util.mk_field_projector_name - lid a i in - let field_proj_tm = - let uu___4 = - let uu___5 = - FStar_Syntax_Syntax.lid_as_fv - field_name - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm - uu___5 in - FStar_Syntax_Syntax.mk_Tm_uinst - uu___4 inst_univs in - let proj = - FStar_Syntax_Syntax.mk_Tm_app - field_proj_tm [arg] p in - FStar_Syntax_Syntax.NT (a, proj)) - fields in - let projectors_ses = - let uu___ = - (FStar_Syntax_Util.has_attribute attrs - FStar_Parser_Const.no_auto_projectors_decls_attr) - || - (FStar_Syntax_Util.has_attribute attrs - FStar_Parser_Const.meta_projectors_attr) in - if uu___ - then [] - else - (let uu___2 = - FStar_Compiler_List.mapi - (fun i -> - fun uu___3 -> - match uu___3 with - | { - FStar_Syntax_Syntax.binder_bv = x; - FStar_Syntax_Syntax.binder_qual = - uu___4; - FStar_Syntax_Syntax.binder_positivity - = uu___5; - FStar_Syntax_Syntax.binder_attrs - = uu___6;_} - -> - let p1 = - FStar_Syntax_Syntax.range_of_bv - x in - let field_name = - FStar_Syntax_Util.mk_field_projector_name - lid x i in - let result_comp = - let t = - FStar_Syntax_Subst.subst - subst - x.FStar_Syntax_Syntax.sort in - if erasable - then - FStar_Syntax_Syntax.mk_GTotal - t - else - FStar_Syntax_Syntax.mk_Total - t in - let t = - let uu___7 = - FStar_Syntax_Util.arrow - binders result_comp in - FStar_Syntax_Subst.close_univ_vars - uvs uu___7 in - let only_decl = - early_prims_inductive || - (FStar_Syntax_Util.has_attribute - attrs - FStar_Parser_Const.no_auto_projectors_attr) in - let no_decl = false in - let quals q = - if only_decl - then - FStar_Syntax_Syntax.Assumption - :: q - else q in - let quals1 = - let iquals1 = - FStar_Compiler_List.filter - (fun uu___7 -> - match uu___7 with - | FStar_Syntax_Syntax.Inline_for_extraction - -> true - | FStar_Syntax_Syntax.NoExtract - -> true - | FStar_Syntax_Syntax.Private - -> true - | uu___8 -> false) - iquals in - quals - ((FStar_Syntax_Syntax.Projector - (lid, - (x.FStar_Syntax_Syntax.ppname))) - :: iquals1) in - let attrs1 = - FStar_Compiler_List.op_At - (if only_decl - then [] - else - [FStar_Syntax_Util.attr_substitute]) - attrs in - let decl = - let uu___7 = - FStar_Ident.range_of_lid - field_name in - { - FStar_Syntax_Syntax.sigel = - (FStar_Syntax_Syntax.Sig_declare_typ - { - FStar_Syntax_Syntax.lid2 - = field_name; - FStar_Syntax_Syntax.us2 - = uvs; - FStar_Syntax_Syntax.t2 - = t - }); - FStar_Syntax_Syntax.sigrng = - uu___7; - FStar_Syntax_Syntax.sigquals - = quals1; - FStar_Syntax_Syntax.sigmeta = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs - = attrs1; - FStar_Syntax_Syntax.sigopens_and_abbrevs - = []; - FStar_Syntax_Syntax.sigopts = - FStar_Pervasives_Native.None - } in - ((let uu___8 = - FStar_Compiler_Effect.op_Bang - dbg_LogTypes in - if uu___8 - then - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_sigelt - decl in - FStar_Compiler_Util.print1 - "Declaration of a projector %s\n" - uu___9 - else ()); - if only_decl - then [decl] - else - (let projection = - let uu___9 = - FStar_Ident.string_of_id - x.FStar_Syntax_Syntax.ppname in - FStar_Syntax_Syntax.gen_bv - uu___9 - FStar_Pervasives_Native.None - FStar_Syntax_Syntax.tun in - let arg_pats = - FStar_Compiler_List.mapi - (fun j -> - fun uu___9 -> - match uu___9 with - | { - FStar_Syntax_Syntax.binder_bv - = x1; - FStar_Syntax_Syntax.binder_qual - = imp; - FStar_Syntax_Syntax.binder_positivity - = uu___10; - FStar_Syntax_Syntax.binder_attrs - = uu___11;_} - -> - let b = - FStar_Syntax_Syntax.is_bqual_implicit - imp in - if - (i + ntps) = j - then - let uu___12 = - pos - (FStar_Syntax_Syntax.Pat_var - projection) in - (uu___12, b) - else - if - b && - (j < ntps) - then - (let uu___13 - = - pos - (FStar_Syntax_Syntax.Pat_dot_term - FStar_Pervasives_Native.None) in - (uu___13, - b)) - else - (let uu___14 - = - let uu___15 - = - let uu___16 - = - let uu___17 - = - FStar_Ident.string_of_id - x1.FStar_Syntax_Syntax.ppname in - FStar_Syntax_Syntax.gen_bv - uu___17 - FStar_Pervasives_Native.None - FStar_Syntax_Syntax.tun in - FStar_Syntax_Syntax.Pat_var - uu___16 in - pos - uu___15 in - (uu___14, - b))) - all_params in - let pat = - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Syntax_Syntax.lid_as_fv - lid - (FStar_Pervasives_Native.Some - fvq) in - (uu___12, - FStar_Pervasives_Native.None, - arg_pats) in - FStar_Syntax_Syntax.Pat_cons - uu___11 in - pos uu___10 in - let uu___10 = - FStar_Syntax_Syntax.bv_to_name - projection in - (uu___9, - FStar_Pervasives_Native.None, - uu___10) in - let body = - let return_bv = - FStar_Syntax_Syntax.gen_bv - "proj_ret" - (FStar_Pervasives_Native.Some - p1) - FStar_Syntax_Syntax.tun in - let result_typ = - let uu___9 = - let uu___10 = - FStar_Syntax_Syntax.mk_binder - return_bv in - [uu___10] in - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - FStar_Syntax_Syntax.bv_to_name - return_bv in - ((arg_binder.FStar_Syntax_Syntax.binder_bv), - uu___14) in - FStar_Syntax_Syntax.NT - uu___13 in - [uu___12] in - FStar_Syntax_Subst.subst - uu___11 - (FStar_Syntax_Util.comp_result - result_comp) in - FStar_Syntax_Subst.close - uu___9 uu___10 in - let return_binder = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Syntax_Syntax.mk_binder - return_bv in - [uu___11] in - FStar_Syntax_Subst.close_binders - uu___10 in - FStar_Compiler_List.hd - uu___9 in - let returns_annotation = - let use_eq = true in - FStar_Pervasives_Native.Some - (return_binder, - ((FStar_Pervasives.Inl - result_typ), - FStar_Pervasives_Native.None, - use_eq)) in - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Syntax_Util.branch - pat in - [uu___12] in - { - FStar_Syntax_Syntax.scrutinee - = arg_exp; - FStar_Syntax_Syntax.ret_opt - = - returns_annotation; - FStar_Syntax_Syntax.brs - = uu___11; - FStar_Syntax_Syntax.rc_opt1 - = - FStar_Pervasives_Native.None - } in - FStar_Syntax_Syntax.Tm_match - uu___10 in - FStar_Syntax_Syntax.mk - uu___9 p1 in - let imp = - FStar_Syntax_Util.abs - binders body - FStar_Pervasives_Native.None in - let dd = - FStar_Syntax_Syntax.Delta_equational_at_level - Prims.int_one in - let lbtyp = - if no_decl - then t - else - FStar_Syntax_Syntax.tun in - let lb = - let uu___9 = - let uu___10 = - FStar_Syntax_Syntax.lid_and_dd_as_fv - field_name - FStar_Pervasives_Native.None in - FStar_Pervasives.Inr - uu___10 in - let uu___10 = - FStar_Syntax_Subst.close_univ_vars - uvs imp in - { - FStar_Syntax_Syntax.lbname - = uu___9; - FStar_Syntax_Syntax.lbunivs - = uvs; - FStar_Syntax_Syntax.lbtyp - = lbtyp; - FStar_Syntax_Syntax.lbeff - = - FStar_Parser_Const.effect_Tot_lid; - FStar_Syntax_Syntax.lbdef - = uu___10; - FStar_Syntax_Syntax.lbattrs - = []; - FStar_Syntax_Syntax.lbpos - = - FStar_Compiler_Range_Type.dummyRange - } in - let impl = - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Compiler_Util.right - lb.FStar_Syntax_Syntax.lbname in - (uu___13.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - [uu___12] in - { - FStar_Syntax_Syntax.lbs1 - = (false, [lb]); - FStar_Syntax_Syntax.lids1 - = uu___11 - } in - FStar_Syntax_Syntax.Sig_let - uu___10 in - { - FStar_Syntax_Syntax.sigel - = uu___9; - FStar_Syntax_Syntax.sigrng - = p1; - FStar_Syntax_Syntax.sigquals - = quals1; - FStar_Syntax_Syntax.sigmeta - = - FStar_Syntax_Syntax.default_sigmeta; - FStar_Syntax_Syntax.sigattrs - = attrs1; - FStar_Syntax_Syntax.sigopens_and_abbrevs - = []; - FStar_Syntax_Syntax.sigopts - = - FStar_Pervasives_Native.None - } in - (let uu___10 = - FStar_Compiler_Effect.op_Bang - dbg_LogTypes in - if uu___10 - then - let uu___11 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_sigelt - impl in - FStar_Compiler_Util.print1 - "Implementation of a projector %s\n" - uu___11 - else ()); - if no_decl - then [impl] - else [decl; impl]))) fields in - FStar_Compiler_List.flatten uu___2) in - let no_plugin se = - let not_plugin_attr t = - let h = FStar_Syntax_Util.head_of t in - let uu___ = - FStar_Syntax_Util.is_fvar - FStar_Parser_Const.plugin_attr h in - Prims.op_Negation uu___ in - let uu___ = - FStar_Compiler_List.filter not_plugin_attr - se.FStar_Syntax_Syntax.sigattrs in - { - FStar_Syntax_Syntax.sigel = - (se.FStar_Syntax_Syntax.sigel); - FStar_Syntax_Syntax.sigrng = - (se.FStar_Syntax_Syntax.sigrng); - FStar_Syntax_Syntax.sigquals = - (se.FStar_Syntax_Syntax.sigquals); - FStar_Syntax_Syntax.sigmeta = - (se.FStar_Syntax_Syntax.sigmeta); - FStar_Syntax_Syntax.sigattrs = uu___; - FStar_Syntax_Syntax.sigopens_and_abbrevs = - (se.FStar_Syntax_Syntax.sigopens_and_abbrevs); - FStar_Syntax_Syntax.sigopts = - (se.FStar_Syntax_Syntax.sigopts) - } in - FStar_Compiler_List.map no_plugin - (FStar_Compiler_List.op_At discriminator_ses - projectors_ses) -let (mk_data_operations : - FStar_Syntax_Syntax.qualifier Prims.list -> - FStar_Syntax_Syntax.attribute Prims.list -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.sigelt Prims.list -> - FStar_Syntax_Syntax.sigelt -> FStar_Syntax_Syntax.sigelt Prims.list) - = - fun iquals -> - fun attrs -> - fun env -> - fun tcs -> - fun se -> - match se.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = constr_lid; - FStar_Syntax_Syntax.us1 = uvs; FStar_Syntax_Syntax.t1 = t; - FStar_Syntax_Syntax.ty_lid = typ_lid; - FStar_Syntax_Syntax.num_ty_params = n_typars; - FStar_Syntax_Syntax.mutuals1 = uu___; - FStar_Syntax_Syntax.injective_type_params1 = uu___1;_} - -> - let uu___2 = FStar_Syntax_Subst.univ_var_opening uvs in - (match uu___2 with - | (univ_opening, uvs1) -> - let t1 = FStar_Syntax_Subst.subst univ_opening t in - let uu___3 = FStar_Syntax_Util.arrow_formals t1 in - (match uu___3 with - | (formals, uu___4) -> - let uu___5 = - let tps_opt = - FStar_Compiler_Util.find_map tcs - (fun se1 -> - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Syntax_Util.lid_of_sigelt se1 in - FStar_Compiler_Util.must uu___8 in - FStar_Ident.lid_equals typ_lid uu___7 in - if uu___6 - then - match se1.FStar_Syntax_Syntax.sigel with - | FStar_Syntax_Syntax.Sig_inductive_typ - { FStar_Syntax_Syntax.lid = uu___7; - FStar_Syntax_Syntax.us = uvs'; - FStar_Syntax_Syntax.params = tps; - FStar_Syntax_Syntax.num_uniform_params - = uu___8; - FStar_Syntax_Syntax.t = typ0; - FStar_Syntax_Syntax.mutuals = - uu___9; - FStar_Syntax_Syntax.ds = constrs; - FStar_Syntax_Syntax.injective_type_params - = uu___10;_} - -> - FStar_Pervasives_Native.Some - (tps, typ0, - ((FStar_Compiler_List.length - constrs) - > Prims.int_one)) - | uu___7 -> failwith "Impossible" - else FStar_Pervasives_Native.None) in - match tps_opt with - | FStar_Pervasives_Native.Some x -> x - | FStar_Pervasives_Native.None -> - let uu___6 = - FStar_Ident.lid_equals typ_lid - FStar_Parser_Const.exn_lid in - if uu___6 - then ([], FStar_Syntax_Util.ktype0, true) - else - FStar_Errors.raise_error - FStar_Syntax_Syntax.has_range_sigelt se - FStar_Errors_Codes.Fatal_UnexpectedDataConstructor - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic "Unexpected data constructor") in - (match uu___5 with - | (inductive_tps, typ0, should_refine) -> - let inductive_tps1 = - FStar_Syntax_Subst.subst_binders - univ_opening inductive_tps in - let typ01 = - let uu___6 = - FStar_Syntax_Subst.shift_subst - (FStar_Compiler_List.length - inductive_tps1) univ_opening in - FStar_Syntax_Subst.subst uu___6 typ0 in - let uu___6 = - FStar_Syntax_Util.arrow_formals typ01 in - (match uu___6 with - | (indices, uu___7) -> - let refine_domain = - let uu___8 = - FStar_Compiler_Util.for_some - (fun uu___9 -> - match uu___9 with - | FStar_Syntax_Syntax.RecordConstructor - uu___10 -> true - | uu___10 -> false) - se.FStar_Syntax_Syntax.sigquals in - if uu___8 then false else should_refine in - let fv_qual = - let filter_records uu___8 = - match uu___8 with - | FStar_Syntax_Syntax.RecordConstructor - (uu___9, fns) -> - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Record_ctor - (typ_lid, fns)) - | uu___9 -> - FStar_Pervasives_Native.None in - let uu___8 = - FStar_Compiler_Util.find_map - se.FStar_Syntax_Syntax.sigquals - filter_records in - match uu___8 with - | FStar_Pervasives_Native.None -> - FStar_Syntax_Syntax.Data_ctor - | FStar_Pervasives_Native.Some q -> q in - let fields = - let uu___8 = - FStar_Compiler_Util.first_N n_typars - formals in - match uu___8 with - | (imp_tps, fields1) -> - let rename = - FStar_Compiler_List.map2 - (fun uu___9 -> - fun uu___10 -> - match (uu___9, uu___10) - with - | ({ - FStar_Syntax_Syntax.binder_bv - = x; - FStar_Syntax_Syntax.binder_qual - = uu___11; - FStar_Syntax_Syntax.binder_positivity - = uu___12; - FStar_Syntax_Syntax.binder_attrs - = uu___13;_}, - { - FStar_Syntax_Syntax.binder_bv - = x'; - FStar_Syntax_Syntax.binder_qual - = uu___14; - FStar_Syntax_Syntax.binder_positivity - = uu___15; - FStar_Syntax_Syntax.binder_attrs - = uu___16;_}) - -> - let uu___17 = - let uu___18 = - FStar_Syntax_Syntax.bv_to_name - x' in - (x, uu___18) in - FStar_Syntax_Syntax.NT - uu___17) imp_tps - inductive_tps1 in - FStar_Syntax_Subst.subst_binders - rename fields1 in - let erasable = - FStar_Syntax_Util.has_attribute - se.FStar_Syntax_Syntax.sigattrs - FStar_Parser_Const.erasable_attr in - mk_discriminator_and_indexed_projectors - iquals attrs fv_qual refine_domain env - typ_lid constr_lid uvs1 inductive_tps1 - indices fields erasable)))) - | uu___ -> [] \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_TcTerm.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_TcTerm.ml deleted file mode 100644 index 2052a66fe03..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_TcTerm.ml +++ /dev/null @@ -1,14011 +0,0 @@ -open Prims -let (dbg_Exports : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Exports" -let (dbg_LayeredEffects : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "LayeredEffects" -let (dbg_NYC : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "NYC" -let (dbg_Patterns : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Patterns" -let (dbg_Range : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Range" -let (dbg_RelCheck : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "RelCheck" -let (dbg_RFD : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "RFD" -let (dbg_Tac : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Tac" -let (dbg_UniverseOf : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "UniverseOf" -let (instantiate_both : - FStar_TypeChecker_Env.env -> FStar_TypeChecker_Env.env) = - fun env -> - { - FStar_TypeChecker_Env.solver = (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = (env.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = true; - FStar_TypeChecker_Env.effects = (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = (env.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env.FStar_TypeChecker_Env.missing_decl) - } -let (no_inst : FStar_TypeChecker_Env.env -> FStar_TypeChecker_Env.env) = - fun env -> - { - FStar_TypeChecker_Env.solver = (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = (env.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = false; - FStar_TypeChecker_Env.effects = (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = (env.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env.FStar_TypeChecker_Env.missing_decl) - } -let (is_eq : - FStar_Syntax_Syntax.binder_qualifier FStar_Pervasives_Native.option -> - Prims.bool) - = - fun uu___ -> - match uu___ with - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Equality) -> true - | uu___1 -> false -let steps : 'uuuuu . 'uuuuu -> FStar_TypeChecker_Env.step Prims.list = - fun env -> - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.NoFullNorm; - FStar_TypeChecker_Env.Exclude FStar_TypeChecker_Env.Zeta] -let (norm : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun env -> fun t -> FStar_TypeChecker_Normalize.normalize (steps env) env t -let (norm_c : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.comp -> FStar_Syntax_Syntax.comp) - = - fun env -> - fun c -> FStar_TypeChecker_Normalize.normalize_comp (steps env) env c -let (check_no_escape : - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.bv Prims.list -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Env.guard_t)) - = - fun head_opt -> - fun env -> - fun fvs -> - fun kt -> - FStar_Errors.with_ctx "While checking for escaped variables" - (fun uu___ -> - let fail x = - let msg = - match head_opt with - | FStar_Pervasives_Native.None -> - let uu___1 = - let uu___2 = FStar_Errors_Msg.text "Bound variable" in - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Class_PP.pp FStar_Syntax_Print.pretty_bv - x in - FStar_Pprint.squotes uu___5 in - let uu___5 = - FStar_Errors_Msg.text - "would escape in the type of this letbinding" in - FStar_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in - FStar_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in - let uu___2 = - let uu___3 = - FStar_Errors_Msg.text - "Add a type annotation that does not mention it" in - [uu___3] in - uu___1 :: uu___2 - | FStar_Pervasives_Native.Some head -> - let uu___1 = - let uu___2 = FStar_Errors_Msg.text "Bound variable" in - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Class_PP.pp FStar_Syntax_Print.pretty_bv - x in - FStar_Pprint.squotes uu___5 in - let uu___5 = - let uu___6 = - FStar_Errors_Msg.text - "escapes because of impure applications in the type of" in - let uu___7 = - let uu___8 = - FStar_TypeChecker_Normalize.term_to_doc env - head in - FStar_Pprint.squotes uu___8 in - FStar_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in - FStar_Pprint.op_Hat_Slash_Hat uu___4 uu___5 in - FStar_Pprint.op_Hat_Slash_Hat uu___2 uu___3 in - let uu___2 = - let uu___3 = - FStar_Errors_Msg.text - "Add explicit let-bindings to avoid this" in - [uu___3] in - uu___1 :: uu___2 in - FStar_Errors.raise_error FStar_TypeChecker_Env.hasRange_env - env FStar_Errors_Codes.Fatal_EscapedBoundVar () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic msg) in - match fvs with - | [] -> - (kt, - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t)) - | uu___1 -> - let rec aux try_norm t = - let t1 = if try_norm then norm env t else t in - let fvs' = FStar_Syntax_Free.names t1 in - let uu___2 = - FStar_Compiler_List.tryFind - (fun x -> - FStar_Class_Setlike.mem () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) x - (Obj.magic fvs')) fvs in - match uu___2 with - | FStar_Pervasives_Native.None -> - (t1, - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t)) - | FStar_Pervasives_Native.Some x -> - if Prims.op_Negation try_norm - then let uu___3 = norm env t1 in aux true uu___3 - else - (try - (fun uu___4 -> - match () with - | () -> - let env_extended = - FStar_TypeChecker_Env.push_bvs env fvs in - let uu___5 = - let uu___6 = - FStar_TypeChecker_Env.get_range env in - let uu___7 = - let uu___8 = - FStar_Syntax_Util.type_u () in - FStar_Pervasives_Native.fst uu___8 in - FStar_TypeChecker_Util.new_implicit_var - "no escape" uu___6 env uu___7 false in - (match uu___5 with - | (s, uu___6, g0) -> - let uu___7 = - FStar_TypeChecker_Rel.try_teq - false env_extended t1 s in - (match uu___7 with - | FStar_Pervasives_Native.Some g - -> - let g1 = - let uu___8 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g g0 in - FStar_TypeChecker_Rel.solve_deferred_constraints - env_extended uu___8 in - (s, g1) - | uu___8 -> fail x))) () - with | uu___4 -> fail x) in - aux false kt) -let (check_expected_aqual_for_binder : - FStar_Syntax_Syntax.aqual -> - FStar_Syntax_Syntax.binder -> - FStar_Compiler_Range_Type.range -> FStar_Syntax_Syntax.aqual) - = - fun aq -> - fun b -> - fun pos -> - let uu___ = - let expected_aq = FStar_Syntax_Util.aqual_of_binder b in - match (aq, expected_aq) with - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> - FStar_Pervasives.Inr aq - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.Some eaq) - -> - if eaq.FStar_Syntax_Syntax.aqual_implicit - then - FStar_Pervasives.Inl - "expected implicit annotation on the argument" - else FStar_Pervasives.Inr expected_aq - | (FStar_Pervasives_Native.Some aq1, FStar_Pervasives_Native.None) - -> - FStar_Pervasives.Inl - "expected an explicit argument (without annotation)" - | (FStar_Pervasives_Native.Some aq1, FStar_Pervasives_Native.Some - eaq) -> - if - aq1.FStar_Syntax_Syntax.aqual_implicit <> - eaq.FStar_Syntax_Syntax.aqual_implicit - then FStar_Pervasives.Inl "mismatch" - else FStar_Pervasives.Inr expected_aq in - match uu___ with - | FStar_Pervasives.Inl err -> - let msg = - let uu___1 = - FStar_Errors_Msg.text - (Prims.strcat "Inconsistent argument qualifiers: " - (Prims.strcat err ".")) in - [uu___1] in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range pos - FStar_Errors_Codes.Fatal_InconsistentImplicitQualifier () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic msg) - | FStar_Pervasives.Inr r -> r -let (check_erasable_binder_attributes : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term Prims.list -> FStar_Syntax_Syntax.typ -> unit) - = - fun env -> - fun attrs -> - fun binder_ty -> - FStar_Compiler_List.iter - (fun attr -> - let uu___ = - (FStar_Syntax_Util.is_fvar FStar_Parser_Const.erasable_attr - attr) - && - (let uu___1 = - FStar_TypeChecker_Normalize.non_info_norm env binder_ty in - Prims.op_Negation uu___1) in - if uu___ - then - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) attr - FStar_Errors_Codes.Fatal_QulifierListNotPermitted () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Incompatible attributes: an erasable attribute on a binder must bind a name at an non-informative type") - else ()) attrs -let (push_binding : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.binder -> FStar_TypeChecker_Env.env) - = - fun env -> - fun b -> - FStar_TypeChecker_Env.push_bv env b.FStar_Syntax_Syntax.binder_bv -let (maybe_extend_subst : - FStar_Syntax_Syntax.subst_elt Prims.list -> - FStar_Syntax_Syntax.binder -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.subst_t) - = - fun s -> - fun b -> - fun v -> - let uu___ = FStar_Syntax_Syntax.is_null_binder b in - if uu___ - then s - else (FStar_Syntax_Syntax.NT ((b.FStar_Syntax_Syntax.binder_bv), v)) - :: s -let (set_lcomp_result : - FStar_TypeChecker_Common.lcomp -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_TypeChecker_Common.lcomp) - = - fun lc -> - fun t -> - FStar_TypeChecker_Common.apply_lcomp - (fun c -> FStar_Syntax_Util.set_result_typ c t) (fun g -> g) - { - FStar_TypeChecker_Common.eff_name = - (lc.FStar_TypeChecker_Common.eff_name); - FStar_TypeChecker_Common.res_typ = t; - FStar_TypeChecker_Common.cflags = - (lc.FStar_TypeChecker_Common.cflags); - FStar_TypeChecker_Common.comp_thunk = - (lc.FStar_TypeChecker_Common.comp_thunk) - } -let (memo_tk : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.term) - = fun e -> fun t -> e -let (maybe_warn_on_use : - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.fv -> unit) = - fun env -> - fun fv -> - let uu___ = - FStar_TypeChecker_Env.lookup_attrs_of_lid env - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - match uu___ with - | FStar_Pervasives_Native.None -> () - | FStar_Pervasives_Native.Some attrs -> - FStar_Compiler_List.iter - (fun a -> - let uu___1 = FStar_Syntax_Util.head_and_args a in - match uu___1 with - | (head, args) -> - let msg_arg m = - match args with - | ({ - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_string (s, uu___2)); - FStar_Syntax_Syntax.pos = uu___3; - FStar_Syntax_Syntax.vars = uu___4; - FStar_Syntax_Syntax.hash_code = uu___5;_}, - uu___6)::[] -> - let uu___7 = - let uu___8 = FStar_Errors_Msg.text s in [uu___8] in - FStar_Compiler_List.op_At m uu___7 - | uu___2 -> m in - (match head.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_fvar attr_fv when - FStar_Ident.lid_equals - (attr_fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - FStar_Parser_Const.warn_on_use_attr - -> - let m = - let uu___2 = - let uu___3 = - FStar_Ident.string_of_lid - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - FStar_Compiler_Util.format1 - "Every use of %s triggers a warning" uu___3 in - FStar_Errors_Msg.text uu___2 in - let uu___2 = msg_arg [m] in - FStar_Errors.log_issue FStar_Ident.hasrange_lident - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - FStar_Errors_Codes.Warning_WarnOnUse () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___2) - | FStar_Syntax_Syntax.Tm_fvar attr_fv when - FStar_Ident.lid_equals - (attr_fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - FStar_Parser_Const.deprecated_attr - -> - let m = - let uu___2 = - let uu___3 = - FStar_Ident.string_of_lid - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - FStar_Compiler_Util.format1 "%s is deprecated" - uu___3 in - FStar_Errors_Msg.text uu___2 in - let uu___2 = msg_arg [m] in - FStar_Errors.log_issue FStar_Ident.hasrange_lident - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - FStar_Errors_Codes.Warning_DeprecatedDefinition () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___2) - | uu___2 -> ())) attrs -let (value_check_expected_typ : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.typ, FStar_TypeChecker_Common.lcomp) - FStar_Pervasives.either -> - FStar_TypeChecker_Env.guard_t -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.lcomp * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun e -> - fun tlc -> - fun guard -> - FStar_Defensive.def_check_scoped - FStar_TypeChecker_Env.hasBinders_env - FStar_TypeChecker_Env.hasNames_guard - FStar_TypeChecker_Env.pretty_guard e.FStar_Syntax_Syntax.pos - "value_check_expected_typ" env guard; - (let lc = - match tlc with - | FStar_Pervasives.Inl t -> - let uu___1 = FStar_Syntax_Syntax.mk_Total t in - FStar_TypeChecker_Common.lcomp_of_comp uu___1 - | FStar_Pervasives.Inr lc1 -> lc1 in - let t = lc.FStar_TypeChecker_Common.res_typ in - let uu___1 = - let uu___2 = FStar_TypeChecker_Env.expected_typ env in - match uu___2 with - | FStar_Pervasives_Native.None -> ((memo_tk e t), lc, guard) - | FStar_Pervasives_Native.Some (t', use_eq) -> - let uu___3 = - FStar_TypeChecker_Util.check_has_type_maybe_coerce env e - lc t' use_eq in - (match uu___3 with - | (e1, lc1, g) -> - ((let uu___5 = FStar_Compiler_Debug.medium () in - if uu___5 - then - let uu___6 = - FStar_TypeChecker_Common.lcomp_to_string lc1 in - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t' in - let uu___8 = - FStar_TypeChecker_Rel.guard_to_string env g in - let uu___9 = - FStar_TypeChecker_Rel.guard_to_string env guard in - FStar_Compiler_Util.print4 - "value_check_expected_typ: type is %s<:%s \tguard is %s, %s\n" - uu___6 uu___7 uu___8 uu___9 - else ()); - (let t1 = lc1.FStar_TypeChecker_Common.res_typ in - let g1 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t g guard in - let msg = - let uu___5 = - FStar_TypeChecker_Env.is_trivial_guard_formula g1 in - if uu___5 - then FStar_Pervasives_Native.None - else - FStar_Pervasives_Native.Some - (FStar_TypeChecker_Err.subtyping_failed env t1 - t') in - let uu___5 = - FStar_TypeChecker_Util.strengthen_precondition msg - env e1 lc1 g1 in - match uu___5 with - | (lc2, g2) -> - let uu___6 = set_lcomp_result lc2 t' in - ((memo_tk e1 t'), uu___6, g2)))) in - match uu___1 with | (e1, lc1, g) -> (e1, lc1, g)) -let (comp_check_expected_typ : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_TypeChecker_Common.lcomp -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.lcomp * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun e -> - fun lc -> - let uu___ = FStar_TypeChecker_Env.expected_typ env in - match uu___ with - | FStar_Pervasives_Native.None -> - (e, lc, - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t)) - | FStar_Pervasives_Native.Some (t, use_eq) -> - let uu___1 = FStar_TypeChecker_Util.maybe_coerce_lc env e lc t in - (match uu___1 with - | (e1, lc1, g_c) -> - let uu___2 = - FStar_TypeChecker_Util.weaken_result_typ env e1 lc1 t - use_eq in - (match uu___2 with - | (e2, lc2, g) -> - let uu___3 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t g g_c in - (e2, lc2, uu___3))) -let (check_expected_effect : - FStar_TypeChecker_Env.env -> - Prims.bool -> - FStar_Syntax_Syntax.comp FStar_Pervasives_Native.option -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.comp) -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.comp * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun use_eq -> - fun copt -> - fun ec -> - let uu___ = ec in - match uu___ with - | (e, c) -> - let tot_or_gtot c1 = - let uu___1 = FStar_Syntax_Util.is_pure_comp c1 in - if uu___1 - then - FStar_Syntax_Syntax.mk_Total - (FStar_Syntax_Util.comp_result c1) - else - (let uu___3 = FStar_Syntax_Util.is_pure_or_ghost_comp c1 in - if uu___3 - then - FStar_Syntax_Syntax.mk_GTotal - (FStar_Syntax_Util.comp_result c1) - else failwith "Impossible: Expected pure_or_ghost comp") in - let uu___1 = - let ct = FStar_Syntax_Util.comp_result c in - match copt with - | FStar_Pervasives_Native.Some uu___2 -> - (copt, c, FStar_Pervasives_Native.None) - | FStar_Pervasives_Native.None -> - let uu___2 = - ((FStar_Options.ml_ish ()) && - (let uu___3 = FStar_Parser_Const.effect_ALL_lid () in - FStar_Ident.lid_equals uu___3 - (FStar_Syntax_Util.comp_effect_name c))) - || - (((FStar_Options.ml_ish ()) && (FStar_Options.lax ())) - && - (let uu___3 = - FStar_Syntax_Util.is_pure_or_ghost_comp c in - Prims.op_Negation uu___3)) in - if uu___2 - then - let uu___3 = - let uu___4 = - FStar_Syntax_Util.ml_comp ct - e.FStar_Syntax_Syntax.pos in - FStar_Pervasives_Native.Some uu___4 in - (uu___3, c, FStar_Pervasives_Native.None) - else - (let uu___4 = FStar_Syntax_Util.is_tot_or_gtot_comp c in - if uu___4 - then - let uu___5 = tot_or_gtot c in - (FStar_Pervasives_Native.None, uu___5, - FStar_Pervasives_Native.None) - else - (let uu___6 = - FStar_Syntax_Util.is_pure_or_ghost_comp c in - if uu___6 - then - let uu___7 = - let uu___8 = tot_or_gtot c in - FStar_Pervasives_Native.Some uu___8 in - (uu___7, c, FStar_Pervasives_Native.None) - else - (let norm_eff_name = - FStar_TypeChecker_Env.norm_eff_name env - (FStar_Syntax_Util.comp_effect_name c) in - let uu___8 = - FStar_TypeChecker_Env.is_layered_effect env - norm_eff_name in - if uu___8 - then - let def_eff_opt = - FStar_TypeChecker_Env.get_default_effect env - norm_eff_name in - match def_eff_opt with - | FStar_Pervasives_Native.None -> - let uu___9 = - let uu___10 = - FStar_Class_Show.show - FStar_Ident.showable_lident - (FStar_Syntax_Util.comp_effect_name - c) in - let uu___11 = - FStar_Class_Show.show - FStar_Compiler_Range_Ops.showable_range - e.FStar_Syntax_Syntax.pos in - FStar_Compiler_Util.format2 - "Missing annotation for a layered effect (%s) computation at %s" - uu___10 uu___11 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) - e - FStar_Errors_Codes.Error_LayeredMissingAnnot - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___9) - | FStar_Pervasives_Native.Some def_eff -> - let uu___9 = - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Comp - { - FStar_Syntax_Syntax.comp_univs = - comp_univs; - FStar_Syntax_Syntax.effect_name = - uu___10; - FStar_Syntax_Syntax.result_typ = - result_ty; - FStar_Syntax_Syntax.effect_args = - uu___11; - FStar_Syntax_Syntax.flags = - uu___12;_} - -> (comp_univs, result_ty) - | uu___10 -> failwith "Impossible!" in - (match uu___9 with - | (comp_univs, result_ty) -> - let expected_c = - { - FStar_Syntax_Syntax.comp_univs = - comp_univs; - FStar_Syntax_Syntax.effect_name = - def_eff; - FStar_Syntax_Syntax.result_typ = - result_ty; - FStar_Syntax_Syntax.effect_args = - []; - FStar_Syntax_Syntax.flags = [] - } in - let uu___10 = - let uu___11 = - FStar_Syntax_Syntax.mk_Comp - expected_c in - FStar_Pervasives_Native.Some - uu___11 in - (uu___10, c, - FStar_Pervasives_Native.None)) - else - (let uu___10 = - FStar_Options.trivial_pre_for_unannotated_effectful_fns - () in - if uu___10 - then - let uu___11 = - let uu___12 = - FStar_TypeChecker_Util.check_trivial_precondition_wp - env c in - match uu___12 with - | (uu___13, uu___14, g) -> - FStar_Pervasives_Native.Some g in - (FStar_Pervasives_Native.None, c, uu___11) - else - (FStar_Pervasives_Native.None, c, - FStar_Pervasives_Native.None))))) in - (match uu___1 with - | (expected_c_opt, c1, gopt) -> - (FStar_Defensive.def_check_scoped - FStar_TypeChecker_Env.hasBinders_env - FStar_Class_Binders.hasNames_comp - FStar_Syntax_Print.pretty_comp - c1.FStar_Syntax_Syntax.pos - "check_expected_effect.c.before_norm" env c1; - (let c2 = - FStar_Errors.with_ctx - "While normalizing actual computation type in check_expected_effect" - (fun uu___3 -> norm_c env c1) in - FStar_Defensive.def_check_scoped - FStar_TypeChecker_Env.hasBinders_env - FStar_Class_Binders.hasNames_comp - FStar_Syntax_Print.pretty_comp - c2.FStar_Syntax_Syntax.pos - "check_expected_effect.c.after_norm" env c2; - (match expected_c_opt with - | FStar_Pervasives_Native.None -> - (e, c2, - ((match gopt with - | FStar_Pervasives_Native.None -> - FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t - | FStar_Pervasives_Native.Some g -> g))) - | FStar_Pervasives_Native.Some expected_c -> - ((match gopt with - | FStar_Pervasives_Native.None -> () - | FStar_Pervasives_Native.Some uu___5 -> - failwith - "Impossible! check_expected_effect, gopt should have been None"); - (let c3 = - let uu___5 = - FStar_TypeChecker_Common.lcomp_of_comp c2 in - FStar_TypeChecker_Util.maybe_assume_result_eq_pure_term - env e uu___5 in - let uu___5 = - FStar_TypeChecker_Common.lcomp_comp c3 in - match uu___5 with - | (c4, g_c) -> - (FStar_Defensive.def_check_scoped - FStar_TypeChecker_Env.hasBinders_env - FStar_Class_Binders.hasNames_comp - FStar_Syntax_Print.pretty_comp - c4.FStar_Syntax_Syntax.pos - "check_expected_effect.c.after_assume" env - c4; - (let uu___8 = FStar_Compiler_Debug.medium () in - if uu___8 - then - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term e in - let uu___10 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_comp c4 in - let uu___11 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_comp - expected_c in - let uu___12 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - use_eq in - FStar_Compiler_Util.print4 - "In check_expected_effect, asking rel to solve the problem on e=(%s) and c=(%s), expected_c=(%s), and use_eq=%s\n" - uu___9 uu___10 uu___11 uu___12 - else ()); - (let uu___8 = - FStar_TypeChecker_Util.check_comp env - use_eq e c4 expected_c in - match uu___8 with - | (e1, uu___9, g) -> - let g1 = - let uu___10 = - FStar_TypeChecker_Env.get_range env in - let uu___11 = - FStar_Errors_Msg.mkmsg - "Could not prove post-condition" in - FStar_TypeChecker_Util.label_guard - uu___10 uu___11 g in - ((let uu___11 = - FStar_Compiler_Debug.medium () in - if uu___11 - then - let uu___12 = - FStar_Compiler_Range_Ops.string_of_range - e1.FStar_Syntax_Syntax.pos in - let uu___13 = - FStar_TypeChecker_Rel.guard_to_string - env g1 in - FStar_Compiler_Util.print2 - "(%s) DONE check_expected_effect;\n\tguard is: %s\n" - uu___12 uu___13 - else ()); - (let e2 = - FStar_TypeChecker_Util.maybe_lift - env e1 - (FStar_Syntax_Util.comp_effect_name - c4) - (FStar_Syntax_Util.comp_effect_name - expected_c) - (FStar_Syntax_Util.comp_result c4) in - let uu___11 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g1 g_c in - (e2, expected_c, uu___11))))))))))) -let no_logical_guard : - 'uuuuu 'uuuuu1 . - FStar_TypeChecker_Env.env -> - ('uuuuu * 'uuuuu1 * FStar_TypeChecker_Env.guard_t) -> - ('uuuuu * 'uuuuu1 * FStar_TypeChecker_Env.guard_t) - = - fun env -> - fun uu___ -> - match uu___ with - | (te, kt, f) -> - let uu___1 = FStar_TypeChecker_Env.guard_form f in - (match uu___1 with - | FStar_TypeChecker_Common.Trivial -> (te, kt, f) - | FStar_TypeChecker_Common.NonTrivial f1 -> - FStar_TypeChecker_Err.unexpected_non_trivial_precondition_on_term - env f1) -let (print_expected_ty_str : FStar_TypeChecker_Env.env -> Prims.string) = - fun env -> - let uu___ = FStar_TypeChecker_Env.expected_typ env in - match uu___ with - | FStar_Pervasives_Native.None -> "Expected type is None" - | FStar_Pervasives_Native.Some (t, use_eq) -> - let uu___1 = FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - let uu___2 = FStar_Compiler_Util.string_of_bool use_eq in - FStar_Compiler_Util.format2 "Expected type is (%s, use_eq = %s)" - uu___1 uu___2 -let (print_expected_ty : FStar_TypeChecker_Env.env -> unit) = - fun env -> - let uu___ = print_expected_ty_str env in - FStar_Compiler_Util.print1 "%s\n" uu___ -let rec (get_pat_vars' : - FStar_Syntax_Syntax.bv Prims.list -> - Prims.bool -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.bv FStar_Compiler_FlatSet.t) - = - fun uu___2 -> - fun uu___1 -> - fun uu___ -> - (fun all -> - fun andlist -> - fun pats -> - let pats1 = FStar_Syntax_Util.unmeta pats in - let uu___ = FStar_Syntax_Util.head_and_args pats1 in - match uu___ with - | (head, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst head in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, uu___2) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.nil_lid - -> - Obj.magic - (Obj.repr - (if andlist - then - FStar_Class_Setlike.from_list () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) all - else - FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) ())) - | (FStar_Syntax_Syntax.Tm_fvar fv, - (uu___2, FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = uu___3;_}):: - (hd, FStar_Pervasives_Native.None)::(tl, - FStar_Pervasives_Native.None)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.cons_lid - -> - Obj.magic - (Obj.repr - (let hdvs = get_pat_vars' all false hd in - let tlvs = get_pat_vars' all andlist tl in - if andlist - then - FStar_Class_Setlike.inter () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) - (Obj.magic hdvs) (Obj.magic tlvs) - else - FStar_Class_Setlike.union () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) - (Obj.magic hdvs) (Obj.magic tlvs))) - | (FStar_Syntax_Syntax.Tm_fvar fv, - (uu___2, FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = uu___3;_}):: - (pat, FStar_Pervasives_Native.None)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.smtpat_lid - -> Obj.magic (Obj.repr (FStar_Syntax_Free.names pat)) - | (FStar_Syntax_Syntax.Tm_fvar fv, - (subpats, FStar_Pervasives_Native.None)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.smtpatOr_lid - -> - Obj.magic (Obj.repr (get_pat_vars' all true subpats)) - | uu___2 -> - Obj.magic - (Obj.repr - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) ())))) - uu___2 uu___1 uu___ -let (get_pat_vars : - FStar_Syntax_Syntax.bv Prims.list -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.bv FStar_Compiler_FlatSet.t) - = fun all -> fun pats -> get_pat_vars' all false pats -let (check_pat_fvs : - FStar_Compiler_Range_Type.range -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.binder Prims.list -> unit) - = - fun rng -> - fun env -> - fun pats -> - fun bs -> - let pat_vars = - let uu___ = - FStar_Compiler_List.map - (fun b -> b.FStar_Syntax_Syntax.binder_bv) bs in - let uu___1 = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Beta] env pats in - get_pat_vars uu___ uu___1 in - let uu___ = - FStar_Compiler_Util.find_opt - (fun uu___1 -> - match uu___1 with - | { FStar_Syntax_Syntax.binder_bv = b; - FStar_Syntax_Syntax.binder_qual = uu___2; - FStar_Syntax_Syntax.binder_positivity = uu___3; - FStar_Syntax_Syntax.binder_attrs = uu___4;_} -> - let uu___5 = - FStar_Class_Setlike.mem () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) b - (Obj.magic pat_vars) in - Prims.op_Negation uu___5) bs in - match uu___ with - | FStar_Pervasives_Native.None -> () - | FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.binder_bv = x; - FStar_Syntax_Syntax.binder_qual = uu___1; - FStar_Syntax_Syntax.binder_positivity = uu___2; - FStar_Syntax_Syntax.binder_attrs = uu___3;_} - -> - let uu___4 = - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_bv x in - FStar_Compiler_Util.format1 - "Pattern misses at least one bound variable: %s" uu___5 in - FStar_Errors.log_issue FStar_Class_HasRange.hasRange_range rng - FStar_Errors_Codes.Warning_SMTPatternIllFormed () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4) -let (check_no_smt_theory_symbols : - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.term -> unit) = - fun en -> - fun t -> - let rec pat_terms t1 = - let t2 = FStar_Syntax_Util.unmeta t1 in - let uu___ = FStar_Syntax_Util.head_and_args t2 in - match uu___ with - | (head, args) -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst head in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - (match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, uu___2) when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.nil_lid - -> [] - | (FStar_Syntax_Syntax.Tm_fvar fv, - uu___2::(hd, uu___3)::(tl, uu___4)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.cons_lid - -> - let uu___5 = pat_terms hd in - let uu___6 = pat_terms tl in - FStar_Compiler_List.op_At uu___5 uu___6 - | (FStar_Syntax_Syntax.Tm_fvar fv, uu___2::(pat, uu___3)::[]) - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.smtpat_lid - -> [pat] - | (FStar_Syntax_Syntax.Tm_fvar fv, - (subpats, FStar_Pervasives_Native.None)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.smtpatOr_lid - -> pat_terms subpats - | uu___2 -> []) in - let rec aux t1 = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t1 in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_bvar uu___1 -> [] - | FStar_Syntax_Syntax.Tm_name uu___1 -> [] - | FStar_Syntax_Syntax.Tm_constant uu___1 -> [] - | FStar_Syntax_Syntax.Tm_type uu___1 -> [] - | FStar_Syntax_Syntax.Tm_uvar uu___1 -> [] - | FStar_Syntax_Syntax.Tm_lazy uu___1 -> [] - | FStar_Syntax_Syntax.Tm_unknown -> [] - | FStar_Syntax_Syntax.Tm_abs uu___1 -> [t1] - | FStar_Syntax_Syntax.Tm_arrow uu___1 -> [t1] - | FStar_Syntax_Syntax.Tm_refine uu___1 -> [t1] - | FStar_Syntax_Syntax.Tm_match uu___1 -> [t1] - | FStar_Syntax_Syntax.Tm_let uu___1 -> [t1] - | FStar_Syntax_Syntax.Tm_delayed uu___1 -> [t1] - | FStar_Syntax_Syntax.Tm_quoted uu___1 -> [t1] - | FStar_Syntax_Syntax.Tm_fvar fv -> - let uu___1 = - FStar_TypeChecker_Env.fv_has_attr en fv - FStar_Parser_Const.smt_theory_symbol_attr_lid in - if uu___1 then [t1] else [] - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = t2; FStar_Syntax_Syntax.args = args;_} - -> - let uu___1 = aux t2 in - FStar_Compiler_List.fold_left - (fun acc -> - fun uu___2 -> - match uu___2 with - | (t3, uu___3) -> - let uu___4 = aux t3 in - FStar_Compiler_List.op_At acc uu___4) uu___1 args - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t2; FStar_Syntax_Syntax.asc = uu___1; - FStar_Syntax_Syntax.eff_opt = uu___2;_} - -> aux t2 - | FStar_Syntax_Syntax.Tm_uinst (t2, uu___1) -> aux t2 - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t2; - FStar_Syntax_Syntax.meta = uu___1;_} - -> aux t2 in - let tlist = - let uu___ = pat_terms t in FStar_Compiler_List.collect aux uu___ in - if (FStar_Compiler_List.length tlist) = Prims.int_zero - then () - else - (let uu___1 = - let uu___2 = - let uu___3 = - FStar_Errors_Msg.text - "Pattern uses these theory symbols or terms that should not be in an SMT pattern:" in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = FStar_Pprint.break_ Prims.int_one in - FStar_Pprint.op_Hat_Hat FStar_Pprint.comma uu___7 in - FStar_Pprint.separate_map uu___6 - (FStar_Class_PP.pp FStar_Syntax_Print.pretty_term) tlist in - FStar_Pprint.group uu___5 in - FStar_Pprint.prefix (Prims.of_int (2)) Prims.int_one uu___3 - uu___4 in - [uu___2] in - FStar_Errors.log_issue (FStar_Syntax_Syntax.has_range_syntax ()) t - FStar_Errors_Codes.Warning_SMTPatternIllFormed () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___1)) -let (check_smt_pat : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.binder Prims.list -> - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> unit) - = - fun env -> - fun t -> - fun bs -> - fun c -> - let uu___ = FStar_Syntax_Util.is_smt_lemma t in - if uu___ - then - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Comp - { FStar_Syntax_Syntax.comp_univs = uu___1; - FStar_Syntax_Syntax.effect_name = uu___2; - FStar_Syntax_Syntax.result_typ = uu___3; - FStar_Syntax_Syntax.effect_args = - _pre::_post::(pats, uu___4)::[]; - FStar_Syntax_Syntax.flags = uu___5;_} - -> - (check_pat_fvs t.FStar_Syntax_Syntax.pos env pats bs; - check_no_smt_theory_symbols env pats) - | uu___1 -> failwith "Impossible: check_smt_pat: not Comp" - else () -let (guard_letrecs : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> - (FStar_Syntax_Syntax.lbname * FStar_Syntax_Syntax.typ * - FStar_Syntax_Syntax.univ_names) Prims.list) - = - fun env -> - fun actuals -> - fun expected_c -> - match env.FStar_TypeChecker_Env.letrecs with - | [] -> [] - | letrecs -> - let r = FStar_TypeChecker_Env.get_range env in - let env1 = - { - FStar_TypeChecker_Env.solver = - (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = []; - FStar_TypeChecker_Env.top_level = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (env.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env.FStar_TypeChecker_Env.missing_decl) - } in - let decreases_clause bs c = - (let uu___1 = FStar_Compiler_Debug.low () in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binder) bs in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_comp c in - FStar_Compiler_Util.print2 - "Building a decreases clause over (%s) and %s\n" uu___2 - uu___3 - else ()); - (let filter_types_and_functions bs1 = - let uu___1 = - FStar_Compiler_List.fold_left - (fun uu___2 -> - fun binder -> - match uu___2 with - | (out, env2) -> - let b = binder.FStar_Syntax_Syntax.binder_bv in - let t = - let uu___3 = - FStar_Syntax_Util.unrefine - b.FStar_Syntax_Syntax.sort in - FStar_TypeChecker_Normalize.unfold_whnf env2 - uu___3 in - let env3 = - FStar_TypeChecker_Env.push_binders env2 - [binder] in - (match t.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_type uu___3 -> - (out, env3) - | FStar_Syntax_Syntax.Tm_arrow uu___3 -> - (out, env3) - | uu___3 -> - let arg = FStar_Syntax_Syntax.bv_to_name b in - let arg1 = - let uu___4 = - FStar_Syntax_Util.is_erased_head t in - match uu___4 with - | FStar_Pervasives_Native.Some (u, ty) - -> - FStar_Syntax_Util.apply_reveal u ty - arg - | uu___5 -> arg in - ((arg1 :: out), env3))) ([], env1) bs1 in - match uu___1 with - | (out_rev, env2) -> FStar_Compiler_List.rev out_rev in - let cflags = FStar_Syntax_Util.comp_flags c in - let uu___1 = - FStar_Compiler_List.tryFind - (fun uu___2 -> - match uu___2 with - | FStar_Syntax_Syntax.DECREASES uu___3 -> true - | uu___3 -> false) cflags in - match uu___1 with - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.DECREASES - d) -> d - | uu___2 -> - let uu___3 = filter_types_and_functions bs in - FStar_Syntax_Syntax.Decreases_lex uu___3) in - let precedes_t = - FStar_TypeChecker_Util.fvar_env env1 - FStar_Parser_Const.precedes_lid in - let rec mk_precedes_lex env2 l l_prev = - let rec aux l1 l_prev1 = - let type_of should_warn e1 e2 = - let t1 = - let uu___ = - let uu___1 = - env2.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - env2 e1 false in - FStar_Pervasives_Native.fst uu___1 in - FStar_Syntax_Util.unrefine uu___ in - let t2 = - let uu___ = - let uu___1 = - env2.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - env2 e2 false in - FStar_Pervasives_Native.fst uu___1 in - FStar_Syntax_Util.unrefine uu___ in - let rec warn t11 t21 = - let uu___ = - let uu___1 = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env2 t11 - t21 in - uu___1 = FStar_TypeChecker_TermEqAndSimplify.Equal in - if uu___ - then false - else - (let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Subst.compress t11 in - uu___4.FStar_Syntax_Syntax.n in - let uu___4 = - let uu___5 = FStar_Syntax_Subst.compress t21 in - uu___5.FStar_Syntax_Syntax.n in - (uu___3, uu___4) in - match uu___2 with - | (FStar_Syntax_Syntax.Tm_uinst (t12, uu___3), - FStar_Syntax_Syntax.Tm_uinst (t22, uu___4)) -> - warn t12 t22 - | (FStar_Syntax_Syntax.Tm_name uu___3, - FStar_Syntax_Syntax.Tm_name uu___4) -> false - | (FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = h1; - FStar_Syntax_Syntax.args = args1;_}, - FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = h2; - FStar_Syntax_Syntax.args = args2;_}) - -> - ((warn h1 h2) || - ((FStar_Compiler_List.length args1) <> - (FStar_Compiler_List.length args2))) - || - (let uu___3 = - FStar_Compiler_List.zip args1 args2 in - FStar_Compiler_List.existsML - (fun uu___4 -> - match uu___4 with - | ((a1, uu___5), (a2, uu___6)) -> - warn a1 a2) uu___3) - | (FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = t12; - FStar_Syntax_Syntax.phi = phi1;_}, - FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = t22; - FStar_Syntax_Syntax.phi = phi2;_}) - -> - (warn t12.FStar_Syntax_Syntax.sort - t22.FStar_Syntax_Syntax.sort) - || (warn phi1 phi2) - | (FStar_Syntax_Syntax.Tm_uvar uu___3, uu___4) -> - false - | (uu___3, FStar_Syntax_Syntax.Tm_uvar uu___4) -> - false - | (uu___3, uu___4) -> true) in - (let uu___1 = - ((Prims.op_Negation env2.FStar_TypeChecker_Env.phase1) - && should_warn) - && (warn t1 t2) in - if uu___1 - then - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Subst.compress t1 in - uu___4.FStar_Syntax_Syntax.n in - let uu___4 = - let uu___5 = FStar_Syntax_Subst.compress t2 in - uu___5.FStar_Syntax_Syntax.n in - (uu___3, uu___4) in - match uu___2 with - | (FStar_Syntax_Syntax.Tm_name uu___3, - FStar_Syntax_Syntax.Tm_name uu___4) -> () - | (uu___3, uu___4) -> - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Errors_Msg.text - "In the decreases clause for this function, the SMT solver may not be able to prove that the types of" in - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Class_PP.pp - FStar_Syntax_Print.pretty_term e1 in - let uu___12 = - let uu___13 = - let uu___14 = - FStar_Errors_Msg.text "bound in" in - let uu___15 = - FStar_Class_PP.pp - FStar_Compiler_Range_Ops.pretty_range - e1.FStar_Syntax_Syntax.pos in - FStar_Pprint.op_Hat_Slash_Hat uu___14 - uu___15 in - FStar_Pprint.parens uu___13 in - FStar_Pprint.op_Hat_Slash_Hat uu___11 - uu___12 in - FStar_Pprint.group uu___10 in - FStar_Pprint.prefix (Prims.of_int (2)) - Prims.int_one uu___8 uu___9 in - let uu___8 = - let uu___9 = - let uu___10 = FStar_Errors_Msg.text "and" in - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Class_PP.pp - FStar_Syntax_Print.pretty_term e2 in - let uu___14 = - let uu___15 = - let uu___16 = - FStar_Errors_Msg.text "bound in" in - let uu___17 = - FStar_Class_PP.pp - FStar_Compiler_Range_Ops.pretty_range - e2.FStar_Syntax_Syntax.pos in - FStar_Pprint.op_Hat_Slash_Hat - uu___16 uu___17 in - FStar_Pprint.parens uu___15 in - FStar_Pprint.op_Hat_Slash_Hat uu___13 - uu___14 in - FStar_Pprint.group uu___12 in - FStar_Pprint.prefix (Prims.of_int (2)) - Prims.int_one uu___10 uu___11 in - let uu___10 = - FStar_Errors_Msg.text "are equal." in - FStar_Pprint.op_Hat_Slash_Hat uu___9 uu___10 in - FStar_Pprint.op_Hat_Slash_Hat uu___7 uu___8 in - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Errors_Msg.text - "The type of the first term is:" in - let uu___10 = - FStar_Class_PP.pp - FStar_Syntax_Print.pretty_term t1 in - FStar_Pprint.prefix (Prims.of_int (2)) - Prims.int_one uu___9 uu___10 in - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Errors_Msg.text - "The type of the second term is:" in - let uu___12 = - FStar_Class_PP.pp - FStar_Syntax_Print.pretty_term t2 in - FStar_Pprint.prefix (Prims.of_int (2)) - Prims.int_one uu___11 uu___12 in - let uu___11 = - let uu___12 = - FStar_Errors_Msg.text - "If the proof fails, try annotating these with the same type." in - [uu___12] in - uu___10 :: uu___11 in - uu___8 :: uu___9 in - uu___6 :: uu___7 in - FStar_Errors.log_issue - (FStar_Syntax_Syntax.has_range_syntax ()) e1 - FStar_Errors_Codes.Warning_Defensive () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___5) - else ()); - (t1, t2) in - match (l1, l_prev1) with - | ([], []) -> - let uu___ = - let uu___1 = - FStar_Syntax_Syntax.as_arg - FStar_Syntax_Syntax.unit_const in - let uu___2 = - let uu___3 = - FStar_Syntax_Syntax.as_arg - FStar_Syntax_Syntax.unit_const in - [uu___3] in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app precedes_t uu___ r - | (x::[], x_prev::[]) -> - let uu___ = type_of false x x_prev in - (match uu___ with - | (t_x, t_x_prev) -> - let uu___1 = - let uu___2 = FStar_Syntax_Syntax.iarg t_x in - let uu___3 = - let uu___4 = FStar_Syntax_Syntax.iarg t_x_prev in - let uu___5 = - let uu___6 = FStar_Syntax_Syntax.as_arg x in - let uu___7 = - let uu___8 = - FStar_Syntax_Syntax.as_arg x_prev in - [uu___8] in - uu___6 :: uu___7 in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - FStar_Syntax_Syntax.mk_Tm_app precedes_t uu___1 r) - | (x::tl, x_prev::tl_prev) -> - let uu___ = type_of true x x_prev in - (match uu___ with - | (t_x, t_x_prev) -> - let tm_precedes = - let uu___1 = - let uu___2 = FStar_Syntax_Syntax.iarg t_x in - let uu___3 = - let uu___4 = FStar_Syntax_Syntax.iarg t_x_prev in - let uu___5 = - let uu___6 = FStar_Syntax_Syntax.as_arg x in - let uu___7 = - let uu___8 = - FStar_Syntax_Syntax.as_arg x_prev in - [uu___8] in - uu___6 :: uu___7 in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - FStar_Syntax_Syntax.mk_Tm_app precedes_t uu___1 r in - let eq3_x_x_prev = - FStar_Syntax_Util.mk_eq3_no_univ t_x t_x_prev x - x_prev in - let uu___1 = - let uu___2 = aux tl tl_prev in - FStar_Syntax_Util.mk_conj eq3_x_x_prev uu___2 in - FStar_Syntax_Util.mk_disj tm_precedes uu___1) in - let uu___ = - let uu___1 = - ((FStar_Compiler_List.length l), - (FStar_Compiler_List.length l_prev)) in - match uu___1 with - | (n, n_prev) -> - if n = n_prev - then (l, l_prev) - else - if n < n_prev - then - (let uu___3 = - let uu___4 = FStar_Compiler_List.splitAt n l_prev in - FStar_Pervasives_Native.fst uu___4 in - (l, uu___3)) - else - (let uu___4 = - let uu___5 = FStar_Compiler_List.splitAt n_prev l in - FStar_Pervasives_Native.fst uu___5 in - (uu___4, l_prev)) in - match uu___ with | (l1, l_prev1) -> aux l1 l_prev1 in - let mk_precedes env2 d d_prev = - match (d, d_prev) with - | (FStar_Syntax_Syntax.Decreases_lex l, - FStar_Syntax_Syntax.Decreases_lex l_prev) -> - mk_precedes_lex env2 l l_prev - | (FStar_Syntax_Syntax.Decreases_wf (rel, e), - FStar_Syntax_Syntax.Decreases_wf (rel_prev, e_prev)) -> - let rel_guard = - let uu___ = - let uu___1 = FStar_Syntax_Syntax.as_arg e in - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.as_arg e_prev in - [uu___3] in - uu___1 :: uu___2 in - FStar_Syntax_Syntax.mk_Tm_app rel uu___ r in - let uu___ = - let uu___1 = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env2 rel - rel_prev in - uu___1 = FStar_TypeChecker_TermEqAndSimplify.Equal in - if uu___ - then rel_guard - else - (let uu___2 = - FStar_Errors.with_ctx - "Typechecking decreases well-founded relation" - (fun uu___3 -> - env2.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - env2 rel false) in - match uu___2 with - | (t_rel, uu___3) -> - let uu___4 = - FStar_Errors.with_ctx - "Typechecking previous decreases well-founded relation" - (fun uu___5 -> - env2.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - env2 rel_prev false) in - (match uu___4 with - | (t_rel_prev, uu___5) -> - let eq_guard = - FStar_Syntax_Util.mk_eq3_no_univ t_rel - t_rel_prev rel rel_prev in - FStar_Syntax_Util.mk_conj eq_guard rel_guard)) - | (uu___, uu___1) -> - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_UnexpectedTerm () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Cannot build termination VC with a well-founded relation and lex ordering") in - let previous_dec = decreases_clause actuals expected_c in - let guard_one_letrec uu___ = - match uu___ with - | (l, arity, t, u_names) -> - let uu___1 = - FStar_TypeChecker_Normalize.get_n_binders env1 arity t in - (match uu___1 with - | (formals, c) -> - (if arity > (FStar_Compiler_List.length formals) - then - failwith - "impossible: bad formals arity, guard_one_letrec" - else (); - (let formals1 = - FStar_Compiler_List.map - (fun b -> - let uu___3 = - FStar_Syntax_Syntax.is_null_bv - b.FStar_Syntax_Syntax.binder_bv in - if uu___3 - then - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Syntax.range_of_bv - b.FStar_Syntax_Syntax.binder_bv in - FStar_Pervasives_Native.Some uu___6 in - FStar_Syntax_Syntax.new_bv uu___5 - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - { - FStar_Syntax_Syntax.binder_bv = uu___4; - FStar_Syntax_Syntax.binder_qual = - (b.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity = - (b.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs = - (b.FStar_Syntax_Syntax.binder_attrs) - } - else b) formals in - let dec = decreases_clause formals1 c in - let precedes = - let env2 = - FStar_TypeChecker_Env.push_binders env1 formals1 in - mk_precedes env2 dec previous_dec in - let precedes1 = - let uu___3 = - FStar_Errors_Msg.mkmsg - "Could not prove termination of this recursive call" in - FStar_TypeChecker_Util.label uu___3 r precedes in - let uu___3 = FStar_Compiler_Util.prefix formals1 in - match uu___3 with - | (bs, - { FStar_Syntax_Syntax.binder_bv = last; - FStar_Syntax_Syntax.binder_qual = imp; - FStar_Syntax_Syntax.binder_positivity = pqual; - FStar_Syntax_Syntax.binder_attrs = attrs;_}) - -> - let last1 = - let uu___4 = - FStar_Syntax_Util.refine last precedes1 in - { - FStar_Syntax_Syntax.ppname = - (last.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (last.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = uu___4 - } in - let refined_formals = - let uu___4 = - let uu___5 = - FStar_Syntax_Syntax.mk_binder_with_attrs - last1 imp pqual attrs in - [uu___5] in - FStar_Compiler_List.op_At bs uu___4 in - let t' = - FStar_Syntax_Util.arrow refined_formals c in - ((let uu___5 = FStar_Compiler_Debug.medium () in - if uu___5 - then - let uu___6 = - FStar_Class_Show.show - (FStar_Class_Show.show_either - FStar_Syntax_Print.showable_bv - FStar_Syntax_Print.showable_fv) l in - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t' in - FStar_Compiler_Util.print3 - "Refined let rec %s\n\tfrom type %s\n\tto type %s\n" - uu___6 uu___7 uu___8 - else ()); - (l, t', u_names))))) in - FStar_Compiler_List.map guard_one_letrec letrecs -let (wrap_guard_with_tactic_opt : - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option -> - FStar_TypeChecker_Env.guard_t -> FStar_TypeChecker_Env.guard_t) - = - fun topt -> - fun g -> - match topt with - | FStar_Pervasives_Native.None -> g - | FStar_Pervasives_Native.Some tactic -> - FStar_TypeChecker_Env.always_map_guard g - (fun g1 -> - let uu___ = - FStar_Syntax_Util.mk_squash FStar_Syntax_Syntax.U_zero g1 in - FStar_TypeChecker_Common.mk_by_tactic tactic uu___) -let (is_comp_ascribed_reflect : - FStar_Syntax_Syntax.term -> - (FStar_Ident.lident * FStar_Syntax_Syntax.term * - FStar_Syntax_Syntax.aqual) FStar_Pervasives_Native.option) - = - fun e -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress e in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = e1; - FStar_Syntax_Syntax.asc = - (FStar_Pervasives.Inr uu___1, uu___2, uu___3); - FStar_Syntax_Syntax.eff_opt = uu___4;_} - -> - let uu___5 = - let uu___6 = FStar_Syntax_Subst.compress e1 in - uu___6.FStar_Syntax_Syntax.n in - (match uu___5 with - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = args;_} - when (FStar_Compiler_List.length args) = Prims.int_one -> - let uu___6 = - let uu___7 = FStar_Syntax_Subst.compress head in - uu___7.FStar_Syntax_Syntax.n in - (match uu___6 with - | FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_reflect l) - -> - let uu___7 = - let uu___8 = FStar_Compiler_List.hd args in - match uu___8 with | (e2, aqual) -> (l, e2, aqual) in - FStar_Pervasives_Native.Some uu___7 - | uu___7 -> FStar_Pervasives_Native.None) - | uu___6 -> FStar_Pervasives_Native.None) - | uu___1 -> FStar_Pervasives_Native.None -let rec (tc_term : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.lcomp * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun e -> - FStar_Defensive.def_check_scoped FStar_TypeChecker_Env.hasBinders_env - FStar_Class_Binders.hasNames_term FStar_Syntax_Print.pretty_term - e.FStar_Syntax_Syntax.pos "tc_term.entry" env e; - (let uu___2 = FStar_Compiler_Debug.medium () in - if uu___2 - then - let uu___3 = - let uu___4 = FStar_TypeChecker_Env.get_range env in - FStar_Compiler_Range_Ops.string_of_range uu___4 in - let uu___4 = - FStar_Compiler_Util.string_of_bool - env.FStar_TypeChecker_Env.phase1 in - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - let uu___6 = - let uu___7 = FStar_Syntax_Subst.compress e in - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term uu___7 in - let uu___7 = print_expected_ty_str env in - FStar_Compiler_Util.print5 - "(%s) Starting tc_term (phase1=%s) of %s (%s), %s {\n" uu___3 - uu___4 uu___5 uu___6 uu___7 - else ()); - (let uu___2 = - FStar_Compiler_Util.record_time - (fun uu___3 -> - tc_maybe_toplevel_term - { - FStar_TypeChecker_Env.solver = - (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = false; - FStar_TypeChecker_Env.check_uvars = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (env.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env.FStar_TypeChecker_Env.missing_decl) - } e) in - match uu___2 with - | (r, ms) -> - ((let uu___4 = FStar_Compiler_Debug.medium () in - if uu___4 - then - ((let uu___6 = - let uu___7 = FStar_TypeChecker_Env.get_range env in - FStar_Compiler_Range_Ops.string_of_range uu___7 in - let uu___7 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - let uu___8 = - let uu___9 = FStar_Syntax_Subst.compress e in - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term - uu___9 in - let uu___9 = FStar_Compiler_Util.string_of_int ms in - FStar_Compiler_Util.print4 - "(%s) } tc_term of %s (%s) took %sms\n" uu___6 uu___7 - uu___8 uu___9); - (let uu___6 = r in - match uu___6 with - | (e1, lc, uu___7) -> - let uu___8 = - let uu___9 = FStar_TypeChecker_Env.get_range env in - FStar_Compiler_Range_Ops.string_of_range uu___9 in - let uu___9 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - e1 in - let uu___10 = - FStar_TypeChecker_Common.lcomp_to_string lc in - let uu___11 = - let uu___12 = FStar_Syntax_Subst.compress e1 in - FStar_Class_Tagged.tag_of - FStar_Syntax_Syntax.tagged_term uu___12 in - FStar_Compiler_Util.print4 - "(%s) Result is: (%s:%s) (%s)\n" uu___8 uu___9 uu___10 - uu___11)) - else ()); - r)) -and (tc_maybe_toplevel_term : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.lcomp * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun e -> - let env1 = - if e.FStar_Syntax_Syntax.pos = FStar_Compiler_Range_Type.dummyRange - then env - else FStar_TypeChecker_Env.set_range env e.FStar_Syntax_Syntax.pos in - FStar_Defensive.def_check_scoped FStar_TypeChecker_Env.hasBinders_env - FStar_Class_Binders.hasNames_term FStar_Syntax_Print.pretty_term - e.FStar_Syntax_Syntax.pos "tc_maybe_toplevel_term.entry" env1 e; - (let top = FStar_Syntax_Subst.compress e in - (let uu___2 = FStar_Compiler_Debug.medium () in - if uu___2 - then - let uu___3 = - let uu___4 = FStar_TypeChecker_Env.get_range env1 in - FStar_Class_Show.show FStar_Compiler_Range_Ops.showable_range - uu___4 in - let uu___4 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term top in - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term top in - FStar_Compiler_Util.print3 "Typechecking %s (%s): %s\n" uu___3 - uu___4 uu___5 - else ()); - (match top.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_delayed uu___2 -> failwith "Impossible" - | FStar_Syntax_Syntax.Tm_bvar uu___2 -> - failwith "Impossible: tc_maybe_toplevel_term: not LN" - | FStar_Syntax_Syntax.Tm_uinst uu___2 -> tc_value env1 e - | FStar_Syntax_Syntax.Tm_uvar uu___2 -> tc_value env1 e - | FStar_Syntax_Syntax.Tm_name uu___2 -> tc_value env1 e - | FStar_Syntax_Syntax.Tm_fvar uu___2 -> tc_value env1 e - | FStar_Syntax_Syntax.Tm_constant uu___2 -> tc_value env1 e - | FStar_Syntax_Syntax.Tm_abs uu___2 -> tc_value env1 e - | FStar_Syntax_Syntax.Tm_arrow uu___2 -> tc_value env1 e - | FStar_Syntax_Syntax.Tm_refine uu___2 -> tc_value env1 e - | FStar_Syntax_Syntax.Tm_type uu___2 -> tc_value env1 e - | FStar_Syntax_Syntax.Tm_unknown -> tc_value env1 e - | FStar_Syntax_Syntax.Tm_quoted (qt, qi) -> - let projl uu___2 = - match uu___2 with - | FStar_Pervasives.Inl x -> x - | FStar_Pervasives.Inr uu___3 -> failwith "projl fail" in - let non_trivial_antiquotations qi1 = - let is_not_name t = - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress t in - uu___3.FStar_Syntax_Syntax.n in - match uu___2 with - | FStar_Syntax_Syntax.Tm_name uu___3 -> false - | uu___3 -> true in - FStar_Compiler_Util.for_some is_not_name - (FStar_Pervasives_Native.snd - qi1.FStar_Syntax_Syntax.antiquotations) in - (match qi.FStar_Syntax_Syntax.qkind with - | FStar_Syntax_Syntax.Quote_static when - non_trivial_antiquotations qi -> - let e0 = e in - let newbvs = - FStar_Compiler_List.map - (fun uu___2 -> - FStar_Syntax_Syntax.new_bv - FStar_Pervasives_Native.None - FStar_Syntax_Syntax.t_term) - (FStar_Pervasives_Native.snd - qi.FStar_Syntax_Syntax.antiquotations) in - let z = - FStar_Compiler_List.zip - (FStar_Pervasives_Native.snd - qi.FStar_Syntax_Syntax.antiquotations) newbvs in - let lbs = - FStar_Compiler_List.map - (fun uu___2 -> - match uu___2 with - | (t, bv') -> - FStar_Syntax_Util.close_univs_and_mk_letbinding - FStar_Pervasives_Native.None - (FStar_Pervasives.Inl bv') [] - FStar_Syntax_Syntax.t_term - FStar_Parser_Const.effect_Tot_lid t [] - t.FStar_Syntax_Syntax.pos) z in - let qi1 = - let uu___2 = - let uu___3 = - FStar_Compiler_List.map - (fun uu___4 -> - match uu___4 with - | (t, bv') -> FStar_Syntax_Syntax.bv_to_name bv') - z in - (Prims.int_zero, uu___3) in - { - FStar_Syntax_Syntax.qkind = - (qi.FStar_Syntax_Syntax.qkind); - FStar_Syntax_Syntax.antiquotations = uu___2 - } in - let nq = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_quoted (qt, qi1)) - top.FStar_Syntax_Syntax.pos in - let e1 = - FStar_Compiler_List.fold_left - (fun t -> - fun lb -> - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - projl lb.FStar_Syntax_Syntax.lbname in - FStar_Syntax_Syntax.mk_binder uu___7 in - [uu___6] in - FStar_Syntax_Subst.close uu___5 t in - { - FStar_Syntax_Syntax.lbs = (false, [lb]); - FStar_Syntax_Syntax.body1 = uu___4 - } in - FStar_Syntax_Syntax.Tm_let uu___3 in - FStar_Syntax_Syntax.mk uu___2 - top.FStar_Syntax_Syntax.pos) nq lbs in - tc_maybe_toplevel_term env1 e1 - | FStar_Syntax_Syntax.Quote_static -> - let aqs = - FStar_Pervasives_Native.snd - qi.FStar_Syntax_Syntax.antiquotations in - let env_tm = - FStar_TypeChecker_Env.set_expected_typ env1 - FStar_Syntax_Syntax.t_term in - let uu___2 = - FStar_Compiler_List.fold_left - (fun uu___3 -> - fun aq_tm -> - match uu___3 with - | (aqs_rev, guard, env_tm1) -> - let uu___4 = tc_term env_tm1 aq_tm in - (match uu___4 with - | (aq_tm1, uu___5, g) -> - let env_tm2 = - let uu___6 = - FStar_Syntax_Syntax.new_bv - FStar_Pervasives_Native.None - FStar_Syntax_Syntax.t_term in - FStar_TypeChecker_Env.push_bv env_tm1 - uu___6 in - let uu___6 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g guard in - ((aq_tm1 :: aqs_rev), uu___6, env_tm2))) - ([], - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t), env_tm) - aqs in - (match uu___2 with - | (aqs_rev, guard, _env) -> - let qi1 = - { - FStar_Syntax_Syntax.qkind = - (qi.FStar_Syntax_Syntax.qkind); - FStar_Syntax_Syntax.antiquotations = - (Prims.int_zero, - (FStar_Compiler_List.rev aqs_rev)) - } in - let tm = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_quoted (qt, qi1)) - top.FStar_Syntax_Syntax.pos in - value_check_expected_typ env1 tm - (FStar_Pervasives.Inl FStar_Syntax_Syntax.t_term) - guard) - | FStar_Syntax_Syntax.Quote_dynamic -> - let c = - FStar_Syntax_Syntax.mk_Tac FStar_Syntax_Syntax.t_term in - let uu___2 = FStar_TypeChecker_Env.clear_expected_typ env1 in - (match uu___2 with - | (env', uu___3) -> - let env'1 = - { - FStar_TypeChecker_Env.solver = - (env'.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env'.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env'.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env'.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env'.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env'.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env'.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env'.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env'.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env'.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env'.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env'.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env'.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env'.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env'.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env'.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env'.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env'.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = true; - FStar_TypeChecker_Env.lax_universes = - (env'.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env'.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env'.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env'.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env'.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env'.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env'.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env'.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env'.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env'.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env'.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env'.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env'.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env'.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env'.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env'.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env'.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env'.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env'.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env'.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env'.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env'.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env'.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env'.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env'.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env'.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env'.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env'.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env'.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env'.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env'.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env'.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env'.FStar_TypeChecker_Env.missing_decl) - } in - let uu___4 = tc_term env'1 qt in - (match uu___4 with - | (qt1, uu___5, g) -> - let g0 = - { - FStar_TypeChecker_Common.guard_f = - FStar_TypeChecker_Common.Trivial; - FStar_TypeChecker_Common.deferred_to_tac = - (g.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (g.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (g.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = - (g.FStar_TypeChecker_Common.implicits) - } in - let g01 = - FStar_TypeChecker_Rel.resolve_implicits env'1 g0 in - let t = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_quoted (qt1, qi)) - top.FStar_Syntax_Syntax.pos in - let uu___6 = - let uu___7 = - let uu___8 = - FStar_TypeChecker_Common.lcomp_of_comp c in - FStar_Pervasives.Inr uu___8 in - value_check_expected_typ env1 t uu___7 - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t) in - (match uu___6 with - | (t1, lc, g1) -> - let t2 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 = t1; - FStar_Syntax_Syntax.meta = - (FStar_Syntax_Syntax.Meta_monadic_lift - (FStar_Parser_Const.effect_PURE_lid, - FStar_Parser_Const.effect_TAC_lid, - FStar_Syntax_Syntax.t_term)) - }) t1.FStar_Syntax_Syntax.pos in - let uu___7 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g1 g01 in - (t2, lc, uu___7))))) - | FStar_Syntax_Syntax.Tm_lazy - { FStar_Syntax_Syntax.blob = uu___2; - FStar_Syntax_Syntax.lkind = FStar_Syntax_Syntax.Lazy_embedding - uu___3; - FStar_Syntax_Syntax.ltyp = uu___4; - FStar_Syntax_Syntax.rng = uu___5;_} - -> - let uu___6 = FStar_Syntax_Util.unlazy top in tc_term env1 uu___6 - | FStar_Syntax_Syntax.Tm_lazy i -> - value_check_expected_typ env1 top - (FStar_Pervasives.Inl (i.FStar_Syntax_Syntax.ltyp)) - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t) - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = e1; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_desugared - (FStar_Syntax_Syntax.Meta_smt_pat);_} - -> - let uu___2 = tc_tot_or_gtot_term env1 e1 in - (match uu___2 with - | (e2, c, g) -> - let g1 = - { - FStar_TypeChecker_Common.guard_f = - FStar_TypeChecker_Common.Trivial; - FStar_TypeChecker_Common.deferred_to_tac = - (g.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (g.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (g.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = - (g.FStar_TypeChecker_Common.implicits) - } in - let uu___3 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 = e2; - FStar_Syntax_Syntax.meta = - (FStar_Syntax_Syntax.Meta_desugared - FStar_Syntax_Syntax.Meta_smt_pat) - }) top.FStar_Syntax_Syntax.pos in - (uu___3, c, g1)) - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = e1; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_pattern - (names, pats);_} - -> - let uu___2 = FStar_Syntax_Util.type_u () in - (match uu___2 with - | (t, u) -> - let uu___3 = - tc_check_tot_or_gtot_term env1 e1 t - FStar_Pervasives_Native.None in - (match uu___3 with - | (e2, c, g) -> - let uu___4 = - let uu___5 = - FStar_TypeChecker_Env.clear_expected_typ env1 in - match uu___5 with - | (env2, uu___6) -> tc_smt_pats env2 pats in - (match uu___4 with - | (pats1, g') -> - let g'1 = - { - FStar_TypeChecker_Common.guard_f = - FStar_TypeChecker_Common.Trivial; - FStar_TypeChecker_Common.deferred_to_tac = - (g'.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (g'.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (g'.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = - (g'.FStar_TypeChecker_Common.implicits) - } in - let uu___5 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 = e2; - FStar_Syntax_Syntax.meta = - (FStar_Syntax_Syntax.Meta_pattern - (names, pats1)) - }) top.FStar_Syntax_Syntax.pos in - let uu___6 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t g g'1 in - (uu___5, c, uu___6)))) - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = e1; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_desugared - (FStar_Syntax_Syntax.Sequence);_} - -> - let uu___2 = tc_term env1 e1 in - (match uu___2 with - | (e2, c, g) -> - let e3 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 = e2; - FStar_Syntax_Syntax.meta = - (FStar_Syntax_Syntax.Meta_desugared - FStar_Syntax_Syntax.Sequence) - }) top.FStar_Syntax_Syntax.pos in - (e3, c, g)) - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = e1; - FStar_Syntax_Syntax.meta = FStar_Syntax_Syntax.Meta_monadic - uu___2;_} - -> tc_term env1 e1 - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = e1; - FStar_Syntax_Syntax.meta = - FStar_Syntax_Syntax.Meta_monadic_lift uu___2;_} - -> tc_term env1 e1 - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = e1; FStar_Syntax_Syntax.meta = m;_} - -> - let uu___2 = tc_term env1 e1 in - (match uu___2 with - | (e2, c, g) -> - let e3 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 = e2; - FStar_Syntax_Syntax.meta = m - }) top.FStar_Syntax_Syntax.pos in - (e3, c, g)) - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = e1; - FStar_Syntax_Syntax.asc = - (asc, FStar_Pervasives_Native.Some tac, use_eq); - FStar_Syntax_Syntax.eff_opt = labopt;_} - -> - let uu___2 = - tc_tactic FStar_Syntax_Syntax.t_unit FStar_Syntax_Syntax.t_unit - env1 tac in - (match uu___2 with - | (tac1, uu___3, g_tac) -> - let t' = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_ascribed - { - FStar_Syntax_Syntax.tm = e1; - FStar_Syntax_Syntax.asc = - (asc, FStar_Pervasives_Native.None, use_eq); - FStar_Syntax_Syntax.eff_opt = labopt - }) top.FStar_Syntax_Syntax.pos in - let uu___4 = tc_term env1 t' in - (match uu___4 with - | (t'1, c, g) -> - let t'2 = - let uu___5 = - let uu___6 = FStar_Syntax_Subst.compress t'1 in - uu___6.FStar_Syntax_Syntax.n in - match uu___5 with - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = e2; - FStar_Syntax_Syntax.asc = - (asc1, FStar_Pervasives_Native.None, _use_eq); - FStar_Syntax_Syntax.eff_opt = labopt1;_} - -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_ascribed - { - FStar_Syntax_Syntax.tm = e2; - FStar_Syntax_Syntax.asc = - (asc1, - (FStar_Pervasives_Native.Some tac1), - use_eq); - FStar_Syntax_Syntax.eff_opt = labopt1 - }) t'1.FStar_Syntax_Syntax.pos - | uu___6 -> failwith "impossible" in - let g1 = - wrap_guard_with_tactic_opt - (FStar_Pervasives_Native.Some tac1) g in - let uu___5 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t g1 g_tac in - (t'2, c, uu___5))) - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = uu___2; - FStar_Syntax_Syntax.asc = - (FStar_Pervasives.Inr expected_c, - FStar_Pervasives_Native.None, use_eq); - FStar_Syntax_Syntax.eff_opt = uu___3;_} - when - let uu___4 = is_comp_ascribed_reflect top in - FStar_Compiler_Util.is_some uu___4 -> - let uu___4 = - let uu___5 = is_comp_ascribed_reflect top in - FStar_Compiler_Util.must uu___5 in - (match uu___4 with - | (effect_lid, e1, aqual) -> - let uu___5 = FStar_TypeChecker_Env.clear_expected_typ env1 in - (match uu___5 with - | (env0, uu___6) -> - let uu___7 = tc_comp env0 expected_c in - (match uu___7 with - | (expected_c1, uu___8, g_c) -> - let expected_ct = - FStar_TypeChecker_Env.unfold_effect_abbrev env0 - expected_c1 in - ((let uu___10 = - let uu___11 = - FStar_Ident.lid_equals effect_lid - expected_ct.FStar_Syntax_Syntax.effect_name in - Prims.op_Negation uu___11 in - if uu___10 - then - let uu___11 = - let uu___12 = - FStar_Class_Show.show - FStar_Ident.showable_lident effect_lid in - let uu___13 = - FStar_Class_Show.show - FStar_Ident.showable_lident - expected_ct.FStar_Syntax_Syntax.effect_name in - FStar_Compiler_Util.format2 - "The effect on reflect %s does not match with the annotation %s\n" - uu___12 uu___13 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) - top - FStar_Errors_Codes.Fatal_UnexpectedEffect () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___11) - else ()); - (let uu___11 = - let uu___12 = - FStar_TypeChecker_Env.is_user_reflectable_effect - env1 effect_lid in - Prims.op_Negation uu___12 in - if uu___11 - then - let uu___12 = - let uu___13 = - FStar_Class_Show.show - FStar_Ident.showable_lident effect_lid in - FStar_Compiler_Util.format1 - "Effect %s cannot be reflected" uu___13 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) - top - FStar_Errors_Codes.Fatal_EffectCannotBeReified - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___12) - else ()); - (let u_c = - FStar_Compiler_List.hd - expected_ct.FStar_Syntax_Syntax.comp_univs in - let repr = - let uu___11 = - let uu___12 = - FStar_Syntax_Syntax.mk_Comp expected_ct in - FStar_TypeChecker_Env.effect_repr env0 - uu___12 u_c in - FStar_Compiler_Util.must uu___11 in - let e2 = - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - let uu___15 = - FStar_Syntax_Syntax.mk_Total repr in - FStar_Pervasives.Inr uu___15 in - (uu___14, FStar_Pervasives_Native.None, - use_eq) in - { - FStar_Syntax_Syntax.tm = e1; - FStar_Syntax_Syntax.asc = uu___13; - FStar_Syntax_Syntax.eff_opt = - FStar_Pervasives_Native.None - } in - FStar_Syntax_Syntax.Tm_ascribed uu___12 in - FStar_Syntax_Syntax.mk uu___11 - e1.FStar_Syntax_Syntax.pos in - (let uu___12 = FStar_Compiler_Debug.extreme () in - if uu___12 - then - let uu___13 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term e2 in - FStar_Compiler_Util.print1 - "Typechecking ascribed reflect, inner ascribed term: %s\n" - uu___13 - else ()); - (let uu___12 = tc_tot_or_gtot_term env0 e2 in - match uu___12 with - | (e3, uu___13, g_e) -> - let e4 = FStar_Syntax_Util.unascribe e3 in - ((let uu___15 = - FStar_Compiler_Debug.extreme () in - if uu___15 - then - let uu___16 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term e4 in - let uu___17 = - FStar_TypeChecker_Rel.guard_to_string - env0 g_e in - FStar_Compiler_Util.print2 - "Typechecking ascribed reflect, after typechecking inner ascribed term: %s and guard: %s\n" - uu___16 uu___17 - else ()); - (let top1 = - let r = top.FStar_Syntax_Syntax.pos in - let tm = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_reflect - effect_lid)) r in - let tm1 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = tm; - FStar_Syntax_Syntax.args = - [(e4, aqual)] - }) r in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_ascribed - { - FStar_Syntax_Syntax.tm = tm1; - FStar_Syntax_Syntax.asc = - ((FStar_Pervasives.Inr - expected_c1), - FStar_Pervasives_Native.None, - use_eq); - FStar_Syntax_Syntax.eff_opt = - (FStar_Pervasives_Native.Some - (FStar_Syntax_Util.comp_effect_name - expected_c1)) - }) r in - let uu___15 = - let uu___16 = - FStar_TypeChecker_Common.lcomp_of_comp - expected_c1 in - comp_check_expected_typ env1 top1 - uu___16 in - match uu___15 with - | (top2, c, g_env) -> - let uu___16 = - let uu___17 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g_c g_e in - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - uu___17 g_env in - (top2, c, uu___16))))))))) - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = e1; - FStar_Syntax_Syntax.asc = - (FStar_Pervasives.Inr expected_c, - FStar_Pervasives_Native.None, use_eq); - FStar_Syntax_Syntax.eff_opt = uu___2;_} - -> - let uu___3 = FStar_TypeChecker_Env.clear_expected_typ env1 in - (match uu___3 with - | (env0, uu___4) -> - let uu___5 = tc_comp env0 expected_c in - (match uu___5 with - | (expected_c1, uu___6, g) -> - let uu___7 = - let uu___8 = - FStar_TypeChecker_Env.set_expected_typ_maybe_eq - env0 (FStar_Syntax_Util.comp_result expected_c1) - use_eq in - tc_term uu___8 e1 in - (match uu___7 with - | (e2, c', g') -> - let uu___8 = - let uu___9 = - FStar_TypeChecker_Common.lcomp_comp c' in - match uu___9 with - | (c'1, g_c') -> - let uu___10 = - check_expected_effect env0 use_eq - (FStar_Pervasives_Native.Some - expected_c1) (e2, c'1) in - (match uu___10 with - | (e3, expected_c2, g'') -> - let uu___11 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g_c' g'' in - (e3, expected_c2, uu___11)) in - (match uu___8 with - | (e3, expected_c2, g'') -> - let e4 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_ascribed - { - FStar_Syntax_Syntax.tm = e3; - FStar_Syntax_Syntax.asc = - ((FStar_Pervasives.Inr expected_c2), - FStar_Pervasives_Native.None, - use_eq); - FStar_Syntax_Syntax.eff_opt = - (FStar_Pervasives_Native.Some - (FStar_Syntax_Util.comp_effect_name - expected_c2)) - }) top.FStar_Syntax_Syntax.pos in - let lc = - FStar_TypeChecker_Common.lcomp_of_comp - expected_c2 in - let f = - let uu___9 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g g' in - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - uu___9 g'' in - let uu___9 = - comp_check_expected_typ env1 e4 lc in - (match uu___9 with - | (e5, c, f2) -> - let uu___10 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - f f2 in - (e5, c, uu___10)))))) - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = e1; - FStar_Syntax_Syntax.asc = - (FStar_Pervasives.Inl t, FStar_Pervasives_Native.None, - use_eq); - FStar_Syntax_Syntax.eff_opt = uu___2;_} - -> - let uu___3 = FStar_Syntax_Util.type_u () in - (match uu___3 with - | (k, u) -> - let uu___4 = - tc_check_tot_or_gtot_term env1 t k - FStar_Pervasives_Native.None in - (match uu___4 with - | (t1, uu___5, f) -> - let uu___6 = - let uu___7 = - FStar_TypeChecker_Env.set_expected_typ_maybe_eq - env1 t1 use_eq in - tc_term uu___7 e1 in - (match uu___6 with - | (e2, c, g) -> - let uu___7 = - let uu___8 = - FStar_TypeChecker_Env.set_range env1 - t1.FStar_Syntax_Syntax.pos in - FStar_TypeChecker_Util.strengthen_precondition - (FStar_Pervasives_Native.Some - (fun uu___9 -> - FStar_TypeChecker_Err.ill_kinded_type)) - uu___8 e2 c f in - (match uu___7 with - | (c1, f1) -> - let uu___8 = - let uu___9 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_ascribed - { - FStar_Syntax_Syntax.tm = e2; - FStar_Syntax_Syntax.asc = - ((FStar_Pervasives.Inl t1), - FStar_Pervasives_Native.None, - use_eq); - FStar_Syntax_Syntax.eff_opt = - (FStar_Pervasives_Native.Some - (c1.FStar_TypeChecker_Common.eff_name)) - }) top.FStar_Syntax_Syntax.pos in - comp_check_expected_typ env1 uu___9 c1 in - (match uu___8 with - | (e3, c2, f2) -> - let uu___9 = - let uu___10 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g f2 in - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - f1 uu___10 in - (e3, c2, uu___9)))))) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_range_of); - FStar_Syntax_Syntax.pos = uu___2; - FStar_Syntax_Syntax.vars = uu___3; - FStar_Syntax_Syntax.hash_code = uu___4;_}; - FStar_Syntax_Syntax.args = a::hd::rest;_} - -> - let rest1 = hd :: rest in - let uu___5 = FStar_Syntax_Util.head_and_args top in - (match uu___5 with - | (unary_op, uu___6) -> - let head = - let uu___7 = - FStar_Compiler_Range_Ops.union_ranges - unary_op.FStar_Syntax_Syntax.pos - (FStar_Pervasives_Native.fst a).FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = unary_op; - FStar_Syntax_Syntax.args = [a] - }) uu___7 in - let t = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = rest1 - }) top.FStar_Syntax_Syntax.pos in - tc_term env1 t) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_reify uu___2); - FStar_Syntax_Syntax.pos = uu___3; - FStar_Syntax_Syntax.vars = uu___4; - FStar_Syntax_Syntax.hash_code = uu___5;_}; - FStar_Syntax_Syntax.args = a::hd::rest;_} - -> - let rest1 = hd :: rest in - let uu___6 = FStar_Syntax_Util.head_and_args top in - (match uu___6 with - | (unary_op, uu___7) -> - let head = - let uu___8 = - FStar_Compiler_Range_Ops.union_ranges - unary_op.FStar_Syntax_Syntax.pos - (FStar_Pervasives_Native.fst a).FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = unary_op; - FStar_Syntax_Syntax.args = [a] - }) uu___8 in - let t = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = rest1 - }) top.FStar_Syntax_Syntax.pos in - tc_term env1 t) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_reflect uu___2); - FStar_Syntax_Syntax.pos = uu___3; - FStar_Syntax_Syntax.vars = uu___4; - FStar_Syntax_Syntax.hash_code = uu___5;_}; - FStar_Syntax_Syntax.args = a::hd::rest;_} - -> - let rest1 = hd :: rest in - let uu___6 = FStar_Syntax_Util.head_and_args top in - (match uu___6 with - | (unary_op, uu___7) -> - let head = - let uu___8 = - FStar_Compiler_Range_Ops.union_ranges - unary_op.FStar_Syntax_Syntax.pos - (FStar_Pervasives_Native.fst a).FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = unary_op; - FStar_Syntax_Syntax.args = [a] - }) uu___8 in - let t = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = rest1 - }) top.FStar_Syntax_Syntax.pos in - tc_term env1 t) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_set_range_of); - FStar_Syntax_Syntax.pos = uu___2; - FStar_Syntax_Syntax.vars = uu___3; - FStar_Syntax_Syntax.hash_code = uu___4;_}; - FStar_Syntax_Syntax.args = a1::a2::hd::rest;_} - -> - let rest1 = hd :: rest in - let uu___5 = FStar_Syntax_Util.head_and_args top in - (match uu___5 with - | (unary_op, uu___6) -> - let head = - let uu___7 = - FStar_Compiler_Range_Ops.union_ranges - unary_op.FStar_Syntax_Syntax.pos - (FStar_Pervasives_Native.fst a1).FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = unary_op; - FStar_Syntax_Syntax.args = [a1; a2] - }) uu___7 in - let t = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = rest1 - }) top.FStar_Syntax_Syntax.pos in - tc_term env1 t) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_range_of); - FStar_Syntax_Syntax.pos = uu___2; - FStar_Syntax_Syntax.vars = uu___3; - FStar_Syntax_Syntax.hash_code = uu___4;_}; - FStar_Syntax_Syntax.args = - (e1, FStar_Pervasives_Native.None)::[];_} - -> - let uu___5 = - let uu___6 = - let uu___7 = FStar_TypeChecker_Env.clear_expected_typ env1 in - FStar_Pervasives_Native.fst uu___7 in - tc_term uu___6 e1 in - (match uu___5 with - | (e2, c, g) -> - let uu___6 = FStar_Syntax_Util.head_and_args top in - (match uu___6 with - | (head, uu___7) -> - let uu___8 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = - [(e2, FStar_Pervasives_Native.None)] - }) top.FStar_Syntax_Syntax.pos in - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Syntax_Syntax.tabbrev - FStar_Parser_Const.range_lid in - FStar_Syntax_Syntax.mk_Total uu___11 in - FStar_TypeChecker_Common.lcomp_of_comp uu___10 in - (uu___8, uu___9, g))) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_set_range_of); - FStar_Syntax_Syntax.pos = uu___2; - FStar_Syntax_Syntax.vars = uu___3; - FStar_Syntax_Syntax.hash_code = uu___4;_}; - FStar_Syntax_Syntax.args = - (t, FStar_Pervasives_Native.None)::(r, - FStar_Pervasives_Native.None)::[];_} - -> - let uu___5 = FStar_Syntax_Util.head_and_args top in - (match uu___5 with - | (head, uu___6) -> - let env' = - let uu___7 = - FStar_Syntax_Syntax.tabbrev FStar_Parser_Const.range_lid in - FStar_TypeChecker_Env.set_expected_typ env1 uu___7 in - let uu___7 = tc_term env' r in - (match uu___7 with - | (er, uu___8, gr) -> - let uu___9 = tc_term env1 t in - (match uu___9 with - | (t1, tt, gt) -> - let g = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t gr gt in - let uu___10 = - let uu___11 = - let uu___12 = FStar_Syntax_Syntax.as_arg t1 in - let uu___13 = - let uu___14 = FStar_Syntax_Syntax.as_arg r in - [uu___14] in - uu___12 :: uu___13 in - FStar_Syntax_Syntax.mk_Tm_app head uu___11 - top.FStar_Syntax_Syntax.pos in - (uu___10, tt, g)))) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_range_of); - FStar_Syntax_Syntax.pos = uu___2; - FStar_Syntax_Syntax.vars = uu___3; - FStar_Syntax_Syntax.hash_code = uu___4;_}; - FStar_Syntax_Syntax.args = uu___5;_} - -> - let uu___6 = - let uu___7 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term top in - FStar_Compiler_Util.format1 "Ill-applied constant %s" uu___7 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) e - FStar_Errors_Codes.Fatal_IllAppliedConstant () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___6) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_set_range_of); - FStar_Syntax_Syntax.pos = uu___2; - FStar_Syntax_Syntax.vars = uu___3; - FStar_Syntax_Syntax.hash_code = uu___4;_}; - FStar_Syntax_Syntax.args = uu___5;_} - -> - let uu___6 = - let uu___7 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term top in - FStar_Compiler_Util.format1 "Ill-applied constant %s" uu___7 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) e - FStar_Errors_Codes.Fatal_IllAppliedConstant () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___6) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_reify uu___2); - FStar_Syntax_Syntax.pos = uu___3; - FStar_Syntax_Syntax.vars = uu___4; - FStar_Syntax_Syntax.hash_code = uu___5;_}; - FStar_Syntax_Syntax.args = (e1, aqual)::[];_} - -> - (if FStar_Compiler_Option.isSome aqual - then - FStar_Errors.log_issue - (FStar_Syntax_Syntax.has_range_syntax ()) e1 - FStar_Errors_Codes.Warning_IrrelevantQualifierOnArgumentToReify - () (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Qualifier on argument to reify is irrelevant and will be ignored") - else (); - (let uu___7 = FStar_TypeChecker_Env.clear_expected_typ env1 in - match uu___7 with - | (env0, uu___8) -> - let uu___9 = tc_term env0 e1 in - (match uu___9 with - | (e2, c, g) -> - let uu___10 = - let uu___11 = FStar_TypeChecker_Common.lcomp_comp c in - match uu___11 with - | (c1, g_c) -> - let uu___12 = - FStar_TypeChecker_Env.unfold_effect_abbrev - env1 c1 in - (uu___12, g_c) in - (match uu___10 with - | (c1, g_c) -> - ((let uu___12 = - let uu___13 = - FStar_TypeChecker_Env.is_user_reifiable_effect - env1 c1.FStar_Syntax_Syntax.effect_name in - Prims.op_Negation uu___13 in - if uu___12 - then - let uu___13 = - let uu___14 = - FStar_Ident.string_of_lid - c1.FStar_Syntax_Syntax.effect_name in - FStar_Compiler_Util.format1 - "Effect %s cannot be reified" uu___14 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) - e2 - FStar_Errors_Codes.Fatal_EffectCannotBeReified - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___13) - else ()); - (let u_c = - FStar_Compiler_List.hd - c1.FStar_Syntax_Syntax.comp_univs in - let e3 = - FStar_Syntax_Util.mk_reify e2 - (FStar_Pervasives_Native.Some - (c1.FStar_Syntax_Syntax.effect_name)) in - let repr = - let uu___12 = FStar_Syntax_Syntax.mk_Comp c1 in - FStar_TypeChecker_Env.reify_comp env1 uu___12 - u_c in - let c2 = - let uu___12 = - FStar_TypeChecker_Env.is_total_effect env1 - c1.FStar_Syntax_Syntax.effect_name in - if uu___12 - then - let uu___13 = - FStar_Syntax_Syntax.mk_Total repr in - FStar_TypeChecker_Common.lcomp_of_comp - uu___13 - else - (let ct = - { - FStar_Syntax_Syntax.comp_univs = [u_c]; - FStar_Syntax_Syntax.effect_name = - FStar_Parser_Const.effect_Dv_lid; - FStar_Syntax_Syntax.result_typ = repr; - FStar_Syntax_Syntax.effect_args = []; - FStar_Syntax_Syntax.flags = [] - } in - let uu___14 = - FStar_Syntax_Syntax.mk_Comp ct in - FStar_TypeChecker_Common.lcomp_of_comp - uu___14) in - let uu___12 = - comp_check_expected_typ env1 e3 c2 in - match uu___12 with - | (e4, c3, g') -> - let uu___13 = - let uu___14 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g_c g' in - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g uu___14 in - (e4, c3, uu___13))))))) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_reflect l); - FStar_Syntax_Syntax.pos = uu___2; - FStar_Syntax_Syntax.vars = uu___3; - FStar_Syntax_Syntax.hash_code = uu___4;_}; - FStar_Syntax_Syntax.args = (e1, aqual)::[];_} - -> - (if FStar_Compiler_Option.isSome aqual - then - FStar_Errors.log_issue - (FStar_Syntax_Syntax.has_range_syntax ()) e1 - FStar_Errors_Codes.Warning_IrrelevantQualifierOnArgumentToReflect - () (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Qualifier on argument to reflect is irrelevant and will be ignored") - else (); - (let uu___7 = - let uu___8 = - FStar_TypeChecker_Env.is_user_reflectable_effect env1 l in - Prims.op_Negation uu___8 in - if uu___7 - then - let uu___8 = - let uu___9 = FStar_Ident.string_of_lid l in - FStar_Compiler_Util.format1 "Effect %s cannot be reflected" - uu___9 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) e1 - FStar_Errors_Codes.Fatal_EffectCannotBeReified () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___8) - else ()); - (let uu___7 = FStar_Syntax_Util.head_and_args top in - match uu___7 with - | (reflect_op, uu___8) -> - let uu___9 = FStar_TypeChecker_Env.effect_decl_opt env1 l in - (match uu___9 with - | FStar_Pervasives_Native.None -> - let uu___10 = - let uu___11 = FStar_Ident.string_of_lid l in - FStar_Compiler_Util.format1 - "Effect %s not found (for reflect)" uu___11 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) e1 - FStar_Errors_Codes.Fatal_EffectNotFound () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___10) - | FStar_Pervasives_Native.Some (ed, qualifiers) -> - let uu___10 = - FStar_TypeChecker_Env.clear_expected_typ env1 in - (match uu___10 with - | (env_no_ex, uu___11) -> - let uu___12 = - let uu___13 = tc_tot_or_gtot_term env_no_ex e1 in - match uu___13 with - | (e2, c, g) -> - ((let uu___15 = - let uu___16 = - FStar_TypeChecker_Common.is_total_lcomp - c in - Prims.op_Negation uu___16 in - if uu___15 - then - FStar_Errors.log_issue - (FStar_Syntax_Syntax.has_range_syntax - ()) e2 - FStar_Errors_Codes.Error_UnexpectedGTotComputation - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Expected Tot, got a GTot computation") - else ()); - (e2, c, g)) in - (match uu___12 with - | (e2, c_e, g_e) -> - let uu___13 = - let uu___14 = FStar_Syntax_Util.type_u () in - match uu___14 with - | (a, u_a) -> - let uu___15 = - FStar_TypeChecker_Util.new_implicit_var - "tc_term reflect" - e2.FStar_Syntax_Syntax.pos - env_no_ex a false in - (match uu___15 with - | (a_uvar, uu___16, g_a) -> - let uu___17 = - FStar_TypeChecker_Util.fresh_effect_repr_en - env_no_ex - e2.FStar_Syntax_Syntax.pos l - u_a a_uvar in - (uu___17, u_a, a_uvar, g_a)) in - (match uu___13 with - | ((expected_repr_typ, g_repr), u_a, a, - g_a) -> - let g_eq = - FStar_TypeChecker_Rel.teq env_no_ex - c_e.FStar_TypeChecker_Common.res_typ - expected_repr_typ in - let eff_args = - let uu___14 = - let uu___15 = - FStar_Syntax_Subst.compress - expected_repr_typ in - uu___15.FStar_Syntax_Syntax.n in - match uu___14 with - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - uu___15; - FStar_Syntax_Syntax.args = - uu___16::args;_} - -> args - | uu___15 -> - let uu___16 = - let uu___17 = - FStar_Class_Show.show - FStar_Ident.showable_lident - l in - let uu___18 = - FStar_Class_Tagged.tag_of - FStar_Syntax_Syntax.tagged_term - expected_repr_typ in - let uu___19 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - expected_repr_typ in - FStar_Compiler_Util.format3 - "Expected repr type for %s is not an application node (%s:%s)" - uu___17 uu___18 uu___19 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax - ()) top - FStar_Errors_Codes.Fatal_UnexpectedEffect - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___16) in - let c = - let uu___14 = - FStar_Syntax_Syntax.mk_Comp - { - FStar_Syntax_Syntax.comp_univs - = [u_a]; - FStar_Syntax_Syntax.effect_name - = - (ed.FStar_Syntax_Syntax.mname); - FStar_Syntax_Syntax.result_typ - = a; - FStar_Syntax_Syntax.effect_args - = eff_args; - FStar_Syntax_Syntax.flags = [] - } in - FStar_TypeChecker_Common.lcomp_of_comp - uu___14 in - let e3 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - reflect_op; - FStar_Syntax_Syntax.args = - [(e2, aqual)] - }) top.FStar_Syntax_Syntax.pos in - let uu___14 = - comp_check_expected_typ env1 e3 c in - (match uu___14 with - | (e4, c1, g') -> - let e5 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 = - e4; - FStar_Syntax_Syntax.meta - = - (FStar_Syntax_Syntax.Meta_monadic - ((c1.FStar_TypeChecker_Common.eff_name), - (c1.FStar_TypeChecker_Common.res_typ))) - }) - e4.FStar_Syntax_Syntax.pos in - let uu___15 = - FStar_Class_Monoid.msum - FStar_TypeChecker_Common.monoid_guard_t - [g_e; g_repr; g_a; g_eq; g'] in - (e5, c1, uu___15)))))))) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar - { FStar_Syntax_Syntax.fv_name = uu___2; - FStar_Syntax_Syntax.fv_qual = - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Unresolved_constructor uc);_}; - FStar_Syntax_Syntax.pos = uu___3; - FStar_Syntax_Syntax.vars = uu___4; - FStar_Syntax_Syntax.hash_code = uu___5;_}; - FStar_Syntax_Syntax.args = args;_} - -> - let uu___6 = - let uu___7 = - if uc.FStar_Syntax_Syntax.uc_base_term - then - match args with - | (b, uu___8)::rest -> - ((FStar_Pervasives_Native.Some b), rest) - | uu___8 -> failwith "Impossible" - else (FStar_Pervasives_Native.None, args) in - match uu___7 with - | (base_term, fields) -> - if - (FStar_Compiler_List.length - uc.FStar_Syntax_Syntax.uc_fields) - <> (FStar_Compiler_List.length fields) - then - let uu___8 = - let uu___9 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_nat) - (FStar_Compiler_List.length - uc.FStar_Syntax_Syntax.uc_fields) in - let uu___10 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_nat) - (FStar_Compiler_List.length fields) in - FStar_Compiler_Util.format2 - "Could not resolve constructor; expected %s fields but only found %s" - uu___9 uu___10 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) top - FStar_Errors_Codes.Fatal_IdentifierNotFound () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___8) - else - (let uu___9 = - let uu___10 = - FStar_Compiler_List.map FStar_Pervasives_Native.fst - fields in - FStar_Compiler_List.zip - uc.FStar_Syntax_Syntax.uc_fields uu___10 in - (base_term, uu___9)) in - (match uu___6 with - | (base_term, uc_fields) -> - let uu___7 = - let uu___8 = FStar_TypeChecker_Env.expected_typ env1 in - match uu___8 with - | FStar_Pervasives_Native.Some (t, uu___9) -> - let uu___10 = - FStar_TypeChecker_Util.find_record_or_dc_from_typ - env1 (FStar_Pervasives_Native.Some t) uc - top.FStar_Syntax_Syntax.pos in - (uu___10, - (FStar_Pervasives_Native.Some - (FStar_Pervasives.Inl t))) - | FStar_Pervasives_Native.None -> - (match base_term with - | FStar_Pervasives_Native.Some e1 -> - let uu___9 = tc_term env1 e1 in - (match uu___9 with - | (uu___10, lc, uu___11) -> - let uu___12 = - FStar_TypeChecker_Util.find_record_or_dc_from_typ - env1 - (FStar_Pervasives_Native.Some - (lc.FStar_TypeChecker_Common.res_typ)) - uc top.FStar_Syntax_Syntax.pos in - (uu___12, - (FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr - (lc.FStar_TypeChecker_Common.res_typ))))) - | FStar_Pervasives_Native.None -> - let uu___9 = - FStar_TypeChecker_Util.find_record_or_dc_from_typ - env1 FStar_Pervasives_Native.None uc - top.FStar_Syntax_Syntax.pos in - (uu___9, FStar_Pervasives_Native.None)) in - (match uu___7 with - | ((rdc, constrname, constructor), topt) -> - let rdc1 = rdc in - let constructor1 = - FStar_Syntax_Syntax.fv_to_tm constructor in - let mk_field_projector i x = - let projname = - FStar_Syntax_Util.mk_field_projector_name_from_ident - constrname i in - let qual = - if rdc1.FStar_Syntax_DsEnv.is_record - then - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Record_projector - (constrname, i)) - else FStar_Pervasives_Native.None in - let candidate = - let uu___8 = - FStar_Ident.set_lid_range projname - x.FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.fvar uu___8 qual in - FStar_Syntax_Syntax.mk_Tm_app candidate - [(x, FStar_Pervasives_Native.None)] - x.FStar_Syntax_Syntax.pos in - let fields = - FStar_TypeChecker_Util.make_record_fields_in_order - env1 uc topt rdc1 uc_fields - (fun field_name -> - match base_term with - | FStar_Pervasives_Native.Some x -> - let uu___8 = mk_field_projector field_name x in - FStar_Pervasives_Native.Some uu___8 - | uu___8 -> FStar_Pervasives_Native.None) - top.FStar_Syntax_Syntax.pos in - let args1 = - FStar_Compiler_List.map - (fun x -> (x, FStar_Pervasives_Native.None)) fields in - let term = - FStar_Syntax_Syntax.mk_Tm_app constructor1 args1 - top.FStar_Syntax_Syntax.pos in - tc_term env1 term)) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar - { - FStar_Syntax_Syntax.fv_name = - { FStar_Syntax_Syntax.v = field_name; - FStar_Syntax_Syntax.p = uu___2;_}; - FStar_Syntax_Syntax.fv_qual = - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Unresolved_projector candidate);_}; - FStar_Syntax_Syntax.pos = uu___3; - FStar_Syntax_Syntax.vars = uu___4; - FStar_Syntax_Syntax.hash_code = uu___5;_}; - FStar_Syntax_Syntax.args = - (e1, FStar_Pervasives_Native.None)::rest;_} - -> - let proceed_with choice = - match choice with - | FStar_Pervasives_Native.None -> - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = FStar_Ident.string_of_lid field_name in - FStar_Compiler_Util.format1 - "Field name %s could not be resolved" uu___9 in - FStar_Errors_Msg.text uu___8 in - [uu___7] in - FStar_Errors.raise_error FStar_Ident.hasrange_lident - field_name FStar_Errors_Codes.Fatal_IdentifierNotFound () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___6) - | FStar_Pervasives_Native.Some choice1 -> - let f = FStar_Syntax_Syntax.fv_to_tm choice1 in - let term = - FStar_Syntax_Syntax.mk_Tm_app f - ((e1, FStar_Pervasives_Native.None) :: rest) - top.FStar_Syntax_Syntax.pos in - tc_term env1 term in - let uu___6 = - let uu___7 = FStar_TypeChecker_Env.clear_expected_typ env1 in - match uu___7 with | (env2, uu___8) -> tc_term env2 e1 in - (match uu___6 with - | (uu___7, lc, uu___8) -> - let t0 = - FStar_TypeChecker_Normalize.unfold_whnf' - [FStar_TypeChecker_Env.Unascribe; - FStar_TypeChecker_Env.Unmeta; - FStar_TypeChecker_Env.Unrefine] env1 - lc.FStar_TypeChecker_Common.res_typ in - let uu___9 = FStar_Syntax_Util.head_and_args t0 in - (match uu___9 with - | (thead, uu___10) -> - ((let uu___12 = FStar_Compiler_Effect.op_Bang dbg_RFD in - if uu___12 - then - let uu___13 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - lc.FStar_TypeChecker_Common.res_typ in - let uu___14 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t0 in - let uu___15 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term thead in - FStar_Compiler_Util.print3 - "Got lc.res_typ=%s; t0 = %s; thead = %s\n" - uu___13 uu___14 uu___15 - else ()); - (let uu___12 = - let uu___13 = - let uu___14 = FStar_Syntax_Util.un_uinst thead in - FStar_Syntax_Subst.compress uu___14 in - uu___13.FStar_Syntax_Syntax.n in - match uu___12 with - | FStar_Syntax_Syntax.Tm_fvar type_name -> - let uu___13 = - FStar_TypeChecker_Util.try_lookup_record_type - env1 - (type_name.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - (match uu___13 with - | FStar_Pervasives_Native.None -> - proceed_with candidate - | FStar_Pervasives_Native.Some rdc -> - let i = - FStar_Compiler_List.tryFind - (fun uu___14 -> - match uu___14 with - | (i1, uu___15) -> - FStar_TypeChecker_Util.field_name_matches - field_name rdc i1) - rdc.FStar_Syntax_DsEnv.fields in - (match i with - | FStar_Pervasives_Native.None -> - proceed_with candidate - | FStar_Pervasives_Native.Some - (i1, uu___14) -> - let constrname = - let uu___15 = - let uu___16 = - FStar_Ident.ns_of_lid - rdc.FStar_Syntax_DsEnv.typename in - FStar_Compiler_List.op_At uu___16 - [rdc.FStar_Syntax_DsEnv.constrname] in - FStar_Ident.lid_of_ids uu___15 in - let projname = - FStar_Syntax_Util.mk_field_projector_name_from_ident - constrname i1 in - let qual = - if rdc.FStar_Syntax_DsEnv.is_record - then - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Record_projector - (constrname, i1)) - else FStar_Pervasives_Native.None in - let choice = - let uu___15 = - let uu___16 = - FStar_Ident.range_of_lid - field_name in - FStar_Ident.set_lid_range projname - uu___16 in - FStar_Syntax_Syntax.lid_as_fv uu___15 - qual in - proceed_with - (FStar_Pervasives_Native.Some choice))) - | uu___13 -> proceed_with candidate)))) - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = - (tau, FStar_Pervasives_Native.None)::[];_} - when - (FStar_Syntax_Util.is_synth_by_tactic head) && - (Prims.op_Negation env1.FStar_TypeChecker_Env.phase1) - -> - let uu___2 = FStar_Syntax_Util.head_and_args top in - (match uu___2 with - | (head1, args) -> - tc_synth head1 env1 args top.FStar_Syntax_Syntax.pos) - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = - (uu___2, FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = uu___3;_}):: - (tau, FStar_Pervasives_Native.None)::[];_} - when - (FStar_Syntax_Util.is_synth_by_tactic head) && - (Prims.op_Negation env1.FStar_TypeChecker_Env.phase1) - -> - let uu___4 = FStar_Syntax_Util.head_and_args top in - (match uu___4 with - | (head1, args) -> - tc_synth head1 env1 args top.FStar_Syntax_Syntax.pos) - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = args;_} - when - (FStar_Syntax_Util.is_synth_by_tactic head) && - (Prims.op_Negation env1.FStar_TypeChecker_Env.phase1) - -> - let uu___2 = - match args with - | (tau, FStar_Pervasives_Native.None)::rest -> - ([(tau, FStar_Pervasives_Native.None)], rest) - | (a, FStar_Pervasives_Native.Some aq)::(tau, - FStar_Pervasives_Native.None)::rest - when aq.FStar_Syntax_Syntax.aqual_implicit -> - ([(a, (FStar_Pervasives_Native.Some aq)); - (tau, FStar_Pervasives_Native.None)], rest) - | uu___3 -> - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) top - FStar_Errors_Codes.Fatal_SynthByTacticError () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic "synth_by_tactic: bad application") in - (match uu___2 with - | (args1, args2) -> - let t1 = FStar_Syntax_Util.mk_app head args1 in - let t2 = FStar_Syntax_Util.mk_app t1 args2 in - tc_term env1 t2) - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = args;_} - -> - let env0 = env1 in - let env2 = - let uu___2 = - let uu___3 = FStar_TypeChecker_Env.clear_expected_typ env1 in - FStar_Pervasives_Native.fst uu___3 in - instantiate_both uu___2 in - ((let uu___3 = FStar_Compiler_Debug.high () in - if uu___3 - then - let uu___4 = - FStar_Compiler_Range_Ops.string_of_range - top.FStar_Syntax_Syntax.pos in - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term top in - let uu___6 = print_expected_ty_str env0 in - FStar_Compiler_Util.print3 "(%s) Checking app %s, %s\n" - uu___4 uu___5 uu___6 - else ()); - (let uu___3 = tc_term (no_inst env2) head in - match uu___3 with - | (head1, chead, g_head) -> - let uu___4 = - let uu___5 = FStar_TypeChecker_Common.lcomp_comp chead in - match uu___5 with - | (c, g) -> - let uu___6 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t g_head g in - (c, uu___6) in - (match uu___4 with - | (chead1, g_head1) -> - let uu___5 = - let uu___6 = - ((FStar_TypeChecker_Util.short_circuit_head head1) - && - (let uu___7 = FStar_Options.ml_ish () in - Prims.op_Negation uu___7)) - && - (Prims.op_Negation - env2.FStar_TypeChecker_Env.phase1) in - if uu___6 - then - let uu___7 = - let uu___8 = - FStar_TypeChecker_Env.expected_typ env0 in - check_short_circuit_args env2 head1 chead1 - g_head1 args uu___8 in - match uu___7 with | (e1, c, g) -> (e1, c, g) - else - (let uu___8 = - FStar_TypeChecker_Env.expected_typ env0 in - check_application_args env2 head1 chead1 g_head1 - args uu___8) in - (match uu___5 with - | (e1, c, g) -> - let uu___6 = - let uu___7 = - (FStar_TypeChecker_Common.is_tot_or_gtot_lcomp - c) - || - (env2.FStar_TypeChecker_Env.phase1 && - (FStar_TypeChecker_Common.is_pure_or_ghost_lcomp - c)) in - if uu___7 - then - let uu___8 = - FStar_TypeChecker_Util.maybe_instantiate - env0 e1 - c.FStar_TypeChecker_Common.res_typ in - match uu___8 with - | (e2, res_typ, implicits) -> - let uu___9 = - FStar_TypeChecker_Common.set_result_typ_lc - c res_typ in - (e2, uu___9, implicits) - else - (e1, c, - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t)) in - (match uu___6 with - | (e2, c1, implicits) -> - ((let uu___8 = - FStar_Compiler_Debug.extreme () in - if uu___8 - then - let uu___9 = - FStar_TypeChecker_Rel.print_pending_implicits - g in - FStar_Compiler_Util.print1 - "Introduced {%s} implicits in application\n" - uu___9 - else ()); - (let uu___8 = - comp_check_expected_typ env0 e2 c1 in - match uu___8 with - | (e3, c2, g') -> - let gres = - let uu___9 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g g' in - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - uu___9 implicits in - ((let uu___10 = - FStar_Compiler_Debug.extreme () in - if uu___10 - then - let uu___11 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - e3 in - let uu___12 = - FStar_TypeChecker_Rel.guard_to_string - env2 gres in - FStar_Compiler_Util.print2 - "Guard from application node %s is %s\n" - uu___11 uu___12 - else ()); - (e3, c2, gres))))))))) - | FStar_Syntax_Syntax.Tm_match uu___2 -> tc_match env1 top - | FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = - (false, - { FStar_Syntax_Syntax.lbname = FStar_Pervasives.Inr uu___2; - FStar_Syntax_Syntax.lbunivs = uu___3; - FStar_Syntax_Syntax.lbtyp = uu___4; - FStar_Syntax_Syntax.lbeff = uu___5; - FStar_Syntax_Syntax.lbdef = uu___6; - FStar_Syntax_Syntax.lbattrs = uu___7; - FStar_Syntax_Syntax.lbpos = uu___8;_}::[]); - FStar_Syntax_Syntax.body1 = uu___9;_} - -> check_top_level_let env1 top - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (false, uu___2); - FStar_Syntax_Syntax.body1 = uu___3;_} - -> check_inner_let env1 top - | FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = - (true, - { FStar_Syntax_Syntax.lbname = FStar_Pervasives.Inr uu___2; - FStar_Syntax_Syntax.lbunivs = uu___3; - FStar_Syntax_Syntax.lbtyp = uu___4; - FStar_Syntax_Syntax.lbeff = uu___5; - FStar_Syntax_Syntax.lbdef = uu___6; - FStar_Syntax_Syntax.lbattrs = uu___7; - FStar_Syntax_Syntax.lbpos = uu___8;_}::uu___9); - FStar_Syntax_Syntax.body1 = uu___10;_} - -> check_top_level_let_rec env1 top - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (true, uu___2); - FStar_Syntax_Syntax.body1 = uu___3;_} - -> check_inner_let_rec env1 top)) -and (tc_match : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.lcomp * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun top -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress top in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = e1; - FStar_Syntax_Syntax.ret_opt = ret_opt; - FStar_Syntax_Syntax.brs = eqns; - FStar_Syntax_Syntax.rc_opt1 = uu___1;_} - -> - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_TypeChecker_Env.clear_expected_typ env in - FStar_Pervasives_Native.fst uu___5 in - instantiate_both uu___4 in - tc_term uu___3 e1 in - (match uu___2 with - | (e11, c1, g1) -> - let uu___3 = - match eqns with - | (p, uu___4, uu___5)::uu___6 -> - (match p.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_cons (fv, uu___7, uu___8) -> - let r = - try - (fun uu___9 -> - match () with - | () -> - let uu___10 = - FStar_TypeChecker_Env.lookup_datacon - env - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - FStar_Pervasives_Native.Some uu___10) () - with | uu___9 -> FStar_Pervasives_Native.None in - (match r with - | FStar_Pervasives_Native.Some (us, t) -> - let uu___9 = - FStar_Syntax_Util.arrow_formals_comp t in - (match uu___9 with - | (bs, c) -> - let env' = - FStar_TypeChecker_Env.push_binders env - bs in - FStar_TypeChecker_Util.maybe_coerce_lc - env' e11 c1 - (FStar_Syntax_Util.comp_result c)) - | FStar_Pervasives_Native.None -> - (e11, c1, - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t))) - | uu___7 -> - (e11, c1, - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t))) - | uu___4 -> - (e11, c1, - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t)) in - (match uu___3 with - | (e12, c11, g_c) -> - let uu___4 = - match ret_opt with - | FStar_Pervasives_Native.None -> - let uu___5 = FStar_TypeChecker_Env.expected_typ env in - (match uu___5 with - | FStar_Pervasives_Native.Some uu___6 -> - (env, FStar_Pervasives_Native.None, g1) - | FStar_Pervasives_Native.None -> - let uu___6 = FStar_Syntax_Util.type_u () in - (match uu___6 with - | (k, uu___7) -> - let uu___8 = - FStar_TypeChecker_Util.new_implicit_var - "match result" - e12.FStar_Syntax_Syntax.pos env k - false in - (match uu___8 with - | (res_t, uu___9, g) -> - let uu___10 = - FStar_TypeChecker_Env.set_expected_typ - env res_t in - let uu___11 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g1 g in - (uu___10, - FStar_Pervasives_Native.None, - uu___11)))) - | FStar_Pervasives_Native.Some (b, asc) -> - ((let uu___6 = - let uu___7 = - FStar_TypeChecker_Util.is_pure_or_ghost_effect - env c11.FStar_TypeChecker_Common.eff_name in - Prims.op_Negation uu___7 in - if uu___6 - then - let uu___7 = - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term e12 in - let uu___9 = - FStar_Ident.string_of_lid - c11.FStar_TypeChecker_Common.eff_name in - FStar_Compiler_Util.format2 - "For a match with returns annotation, the scrutinee should be pure/ghost, found %s with effect %s" - uu___8 uu___9 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) e12 - FStar_Errors_Codes.Fatal_UnexpectedEffect () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___7) - else ()); - (let uu___6 = - FStar_TypeChecker_Env.clear_expected_typ env in - match uu___6 with - | (env1, uu___7) -> - let uu___8 = - let uu___9 = - FStar_Syntax_Subst.open_ascription - [b] asc in - match uu___9 with - | (bs, asc1) -> - let b1 = FStar_Compiler_List.hd bs in - ({ - FStar_Syntax_Syntax.binder_bv = - (let uu___10 = - b1.FStar_Syntax_Syntax.binder_bv in - { - FStar_Syntax_Syntax.ppname = - (uu___10.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (uu___10.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = - (c11.FStar_TypeChecker_Common.res_typ) - }); - FStar_Syntax_Syntax.binder_qual = - (b1.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity - = - (b1.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs = - (b1.FStar_Syntax_Syntax.binder_attrs) - }, asc1) in - (match uu___8 with - | (b1, asc1) -> - let env_asc = - FStar_TypeChecker_Env.push_binders - env1 [b1] in - let uu___9 = - match asc1 with - | (FStar_Pervasives.Inl t, - FStar_Pervasives_Native.None, - use_eq) -> - let uu___10 = - FStar_Syntax_Util.type_u () in - (match uu___10 with - | (k, uu___11) -> - let uu___12 = - tc_check_tot_or_gtot_term - env_asc t k - FStar_Pervasives_Native.None in - (match uu___12 with - | (t1, uu___13, g) -> - (((FStar_Pervasives.Inl - t1), - FStar_Pervasives_Native.None, - use_eq), g))) - | (FStar_Pervasives.Inr c, - FStar_Pervasives_Native.None, - use_eq) -> - let uu___10 = tc_comp env_asc c in - (match uu___10 with - | (c2, uu___11, g) -> - (((FStar_Pervasives.Inr c2), - FStar_Pervasives_Native.None, - use_eq), g)) - | uu___10 -> - FStar_Errors.raise_error - FStar_TypeChecker_Env.hasRange_env - env1 - FStar_Errors_Codes.Fatal_UnexpectedTerm - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Tactic is not yet supported with match returns") in - (match uu___9 with - | (asc2, g_asc) -> - let uu___10 = - let uu___11 = - FStar_TypeChecker_Env.close_guard - env_asc [b1] g_asc in - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g1 uu___11 in - (env1, - (FStar_Pervasives_Native.Some - (b1, asc2)), uu___10))))) in - (match uu___4 with - | (env_branches, ret_opt1, g11) -> - let guard_x = - FStar_Syntax_Syntax.new_bv - (FStar_Pervasives_Native.Some - (e12.FStar_Syntax_Syntax.pos)) - c11.FStar_TypeChecker_Common.res_typ in - let t_eqns = - FStar_Compiler_List.map - (tc_eqn guard_x env_branches ret_opt1) eqns in - let uu___5 = - match ret_opt1 with - | FStar_Pervasives_Native.Some - (b, (FStar_Pervasives.Inr c, uu___6, uu___7)) - -> - let c2 = - FStar_Syntax_Subst.subst_comp - [FStar_Syntax_Syntax.NT - ((b.FStar_Syntax_Syntax.binder_bv), - e12)] c in - let uu___8 = - let uu___9 = - FStar_Compiler_List.map - (fun uu___10 -> - match uu___10 with - | (uu___11, f, uu___12, uu___13, - uu___14, g, b1) -> (f, g, b1)) - t_eqns in - FStar_Compiler_List.unzip3 uu___9 in - (match uu___8 with - | (fmls, gs, erasables) -> - let uu___9 = - FStar_TypeChecker_Util.get_neg_branch_conds - fmls in - (match uu___9 with - | (neg_conds, exhaustiveness_cond) -> - let g = - let uu___10 = - FStar_Compiler_List.map2 - FStar_TypeChecker_Common.weaken_guard_formula - gs neg_conds in - FStar_Class_Monoid.msum - FStar_TypeChecker_Common.monoid_guard_t - uu___10 in - let g_exhaustiveness = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_TypeChecker_Env.get_range - env in - let uu___13 = - FStar_Syntax_Util.mk_imp - exhaustiveness_cond - FStar_Syntax_Util.t_false in - FStar_TypeChecker_Util.label - FStar_TypeChecker_Err.exhaustiveness_check - uu___12 uu___13 in - FStar_TypeChecker_Common.NonTrivial - uu___11 in - FStar_TypeChecker_Env.guard_of_guard_formula - uu___10 in - let g2 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g g_exhaustiveness in - let g3 = - let uu___10 = - let uu___11 = - env.FStar_TypeChecker_Env.universe_of - env - c11.FStar_TypeChecker_Common.res_typ in - let uu___12 = - FStar_Syntax_Syntax.bv_to_name - guard_x in - FStar_Syntax_Util.mk_eq2 uu___11 - c11.FStar_TypeChecker_Common.res_typ - uu___12 e12 in - FStar_TypeChecker_Common.weaken_guard_formula - g2 uu___10 in - let g4 = - let uu___10 = - let uu___11 = - FStar_Syntax_Syntax.mk_binder - guard_x in - [uu___11] in - FStar_TypeChecker_Env.close_guard - env uu___10 g3 in - let uu___10 = - FStar_TypeChecker_Common.lcomp_of_comp - c2 in - let uu___11 = - FStar_Compiler_List.fold_left - (fun acc -> fun b1 -> acc || b1) - false erasables in - (uu___10, g4, uu___11))) - | uu___6 -> - let uu___7 = - FStar_Compiler_List.fold_right - (fun uu___8 -> - fun uu___9 -> - match (uu___8, uu___9) with - | ((branch, f, eff_label, cflags, c, - g, erasable_branch), - (caccum, gaccum, erasable)) -> - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Compiler_Util.must - cflags in - let uu___13 = - FStar_Compiler_Util.must c in - (f, eff_label, uu___12, - uu___13) in - uu___11 :: caccum in - let uu___11 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g gaccum in - (uu___10, uu___11, - (erasable || erasable_branch))) - t_eqns - ([], - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t), - false) in - (match uu___7 with - | (cases, g, erasable) -> - (match ret_opt1 with - | FStar_Pervasives_Native.None -> - let res_t = - let uu___8 = - let uu___9 = - FStar_TypeChecker_Env.expected_typ - env_branches in - FStar_Compiler_Util.must uu___9 in - FStar_Pervasives_Native.fst uu___8 in - let uu___8 = - FStar_TypeChecker_Util.bind_cases - env res_t cases guard_x in - (uu___8, g, erasable) - | FStar_Pervasives_Native.Some - (b, - (FStar_Pervasives.Inl t, uu___8, - uu___9)) - -> - let t1 = - FStar_Syntax_Subst.subst - [FStar_Syntax_Syntax.NT - ((b.FStar_Syntax_Syntax.binder_bv), - e12)] t in - let cases1 = - FStar_Compiler_List.map - (fun uu___10 -> - match uu___10 with - | (f, eff_label, cflags, c) - -> - (f, eff_label, cflags, - ((fun b1 -> - let uu___11 = c b1 in - FStar_TypeChecker_Common.set_result_typ_lc - uu___11 t1)))) - cases in - let uu___10 = - FStar_TypeChecker_Util.bind_cases - env t1 cases1 guard_x in - (uu___10, g, erasable))) in - (match uu___5 with - | (c_branches, g_branches, erasable) -> - let cres = - FStar_TypeChecker_Util.bind - e12.FStar_Syntax_Syntax.pos env - (FStar_Pervasives_Native.Some e12) c11 - ((FStar_Pervasives_Native.Some guard_x), - c_branches) in - let cres1 = - if erasable - then - let e = FStar_Syntax_Util.exp_true_bool in - let c = - FStar_Syntax_Syntax.mk_GTotal - FStar_Syntax_Util.t_bool in - let uu___6 = - FStar_TypeChecker_Common.lcomp_of_comp c in - FStar_TypeChecker_Util.bind - e.FStar_Syntax_Syntax.pos env - (FStar_Pervasives_Native.Some e) uu___6 - (FStar_Pervasives_Native.None, cres) - else cres in - let e = - let ret_opt2 = - match ret_opt1 with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (b, asc) -> - let asc1 = - FStar_Syntax_Subst.close_ascription - [b] asc in - let b1 = - let uu___6 = - FStar_Syntax_Subst.close_binders - [b] in - FStar_Compiler_List.hd uu___6 in - let b2 = - { - FStar_Syntax_Syntax.binder_bv = - (let uu___6 = - b1.FStar_Syntax_Syntax.binder_bv in - { - FStar_Syntax_Syntax.ppname = - (uu___6.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (uu___6.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = - FStar_Syntax_Syntax.tun - }); - FStar_Syntax_Syntax.binder_qual = - (b1.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity - = - (b1.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs = - (b1.FStar_Syntax_Syntax.binder_attrs) - } in - FStar_Pervasives_Native.Some (b2, asc1) in - let mk_match scrutinee = - let branches = - FStar_Compiler_List.map - (fun uu___6 -> - match uu___6 with - | ((pat, wopt, br), uu___7, - eff_label, uu___8, uu___9, - uu___10, uu___11) -> - let uu___12 = - FStar_TypeChecker_Util.maybe_lift - env br eff_label - cres1.FStar_TypeChecker_Common.eff_name - cres1.FStar_TypeChecker_Common.res_typ in - (pat, wopt, uu___12)) t_eqns in - let e2 = - let rc = - { - FStar_Syntax_Syntax.residual_effect = - (cres1.FStar_TypeChecker_Common.eff_name); - FStar_Syntax_Syntax.residual_typ = - (FStar_Pervasives_Native.Some - (cres1.FStar_TypeChecker_Common.res_typ)); - FStar_Syntax_Syntax.residual_flags = - (cres1.FStar_TypeChecker_Common.cflags) - } in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_match - { - FStar_Syntax_Syntax.scrutinee = - scrutinee; - FStar_Syntax_Syntax.ret_opt = - ret_opt2; - FStar_Syntax_Syntax.brs = branches; - FStar_Syntax_Syntax.rc_opt1 = - (FStar_Pervasives_Native.Some rc) - }) top.FStar_Syntax_Syntax.pos in - let e3 = - FStar_TypeChecker_Util.maybe_monadic env - e2 - cres1.FStar_TypeChecker_Common.eff_name - cres1.FStar_TypeChecker_Common.res_typ in - match ret_opt2 with - | FStar_Pervasives_Native.None -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_ascribed - { - FStar_Syntax_Syntax.tm = e3; - FStar_Syntax_Syntax.asc = - ((FStar_Pervasives.Inl - (cres1.FStar_TypeChecker_Common.res_typ)), - FStar_Pervasives_Native.None, - false); - FStar_Syntax_Syntax.eff_opt = - (FStar_Pervasives_Native.Some - (cres1.FStar_TypeChecker_Common.eff_name)) - }) e3.FStar_Syntax_Syntax.pos - | uu___6 -> e3 in - let uu___6 = - FStar_TypeChecker_Util.is_pure_or_ghost_effect - env c11.FStar_TypeChecker_Common.eff_name in - if uu___6 - then mk_match e12 - else - (let e_match = - let uu___8 = - FStar_Syntax_Syntax.bv_to_name guard_x in - mk_match uu___8 in - let lb = - let uu___8 = - FStar_TypeChecker_Env.norm_eff_name - env - c11.FStar_TypeChecker_Common.eff_name in - FStar_Syntax_Util.mk_letbinding - (FStar_Pervasives.Inl guard_x) [] - c11.FStar_TypeChecker_Common.res_typ - uu___8 e12 [] - e12.FStar_Syntax_Syntax.pos in - let e2 = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Syntax_Syntax.mk_binder - guard_x in - [uu___12] in - FStar_Syntax_Subst.close uu___11 - e_match in - { - FStar_Syntax_Syntax.lbs = - (false, [lb]); - FStar_Syntax_Syntax.body1 = - uu___10 - } in - FStar_Syntax_Syntax.Tm_let uu___9 in - FStar_Syntax_Syntax.mk uu___8 - top.FStar_Syntax_Syntax.pos in - FStar_TypeChecker_Util.maybe_monadic env - e2 - cres1.FStar_TypeChecker_Common.eff_name - cres1.FStar_TypeChecker_Common.res_typ) in - let uu___6 = - match ret_opt1 with - | FStar_Pervasives_Native.None -> - (e, cres1, - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t)) - | uu___7 -> - comp_check_expected_typ env e cres1 in - (match uu___6 with - | (e2, cres2, g_expected_type) -> - ((let uu___8 = - FStar_Compiler_Debug.extreme () in - if uu___8 - then - let uu___9 = - FStar_Compiler_Range_Ops.string_of_range - top.FStar_Syntax_Syntax.pos in - let uu___10 = - FStar_TypeChecker_Common.lcomp_to_string - cres2 in - FStar_Compiler_Util.print2 - "(%s) Typechecked Tm_match, comp type = %s\n" - uu___9 uu___10 - else ()); - (let uu___8 = - let uu___9 = - let uu___10 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g_c g11 in - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - uu___10 g_branches in - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - uu___9 g_expected_type in - (e2, cres2, uu___8)))))))) - | uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term top in - FStar_Compiler_Util.format1 "tc_match called on %s\n" uu___3 in - failwith uu___2 -and (tc_synth : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_TypeChecker_Env.env -> - (FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) - Prims.list -> - FStar_Compiler_Range_Type.range -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.lcomp * - FStar_TypeChecker_Env.guard_t)) - = - fun head -> - fun env -> - fun args -> - fun rng -> - let uu___ = - match args with - | (tau, FStar_Pervasives_Native.None)::[] -> - (tau, FStar_Pervasives_Native.None) - | (a, FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = uu___1;_})::(tau, - FStar_Pervasives_Native.None)::[] - -> (tau, (FStar_Pervasives_Native.Some a)) - | uu___1 -> - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range - rng FStar_Errors_Codes.Fatal_SynthByTacticError () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic "synth_by_tactic: bad application") in - match uu___ with - | (tau, atyp) -> - ((let uu___2 = FStar_Compiler_Effect.op_Bang dbg_Tac in - if uu___2 - then - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - tau in - let uu___4 = - FStar_Class_Show.show - (FStar_Class_Show.show_option - FStar_Syntax_Print.showable_term) atyp in - FStar_Compiler_Util.print2 - "Processing synth of %s at type %s\n" uu___3 uu___4 - else ()); - (let typ = - match atyp with - | FStar_Pervasives_Native.Some t -> t - | FStar_Pervasives_Native.None -> - let uu___2 = FStar_TypeChecker_Env.expected_typ env in - (match uu___2 with - | FStar_Pervasives_Native.Some (t, use_eq) -> - (if use_eq - then - (let uu___4 = - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.format1 - "Equality ascription in synth (%s) is not yet supported, please use subtyping" - uu___5 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) t - FStar_Errors_Codes.Fatal_NotSupported () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4)) - else (); - t) - | FStar_Pervasives_Native.None -> - FStar_Errors.raise_error - FStar_TypeChecker_Env.hasRange_env env - FStar_Errors_Codes.Fatal_SynthByTacticError () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "synth_by_tactic: need a type annotation when no expected type is present")) in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Util.type_u () in - FStar_Pervasives_Native.fst uu___5 in - FStar_TypeChecker_Env.set_expected_typ env uu___4 in - tc_term uu___3 typ in - match uu___2 with - | (typ1, uu___3, g1) -> - (FStar_TypeChecker_Rel.force_trivial_guard env g1; - (let uu___5 = - tc_tactic FStar_Syntax_Syntax.t_unit - FStar_Syntax_Syntax.t_unit env tau in - match uu___5 with - | (tau1, uu___6, g2) -> - (FStar_TypeChecker_Rel.force_trivial_guard env g2; - (let t = - env.FStar_TypeChecker_Env.synth_hook env typ1 - { - FStar_Syntax_Syntax.n = - (tau1.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = rng; - FStar_Syntax_Syntax.vars = - (tau1.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (tau1.FStar_Syntax_Syntax.hash_code) - } in - (let uu___9 = - FStar_Compiler_Effect.op_Bang dbg_Tac in - if uu___9 - then - let uu___10 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.print1 "Got %s\n" uu___10 - else ()); - FStar_TypeChecker_Util.check_uvars - tau1.FStar_Syntax_Syntax.pos t; - (let uu___10 = - let uu___11 = - FStar_Syntax_Syntax.mk_Total typ1 in - FStar_TypeChecker_Common.lcomp_of_comp uu___11 in - (t, uu___10, - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t))))))))) -and (tc_tactic : - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.typ -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.lcomp * - FStar_TypeChecker_Env.guard_t)) - = - fun a -> - fun b -> - fun env -> - fun tau -> - let env1 = - { - FStar_TypeChecker_Env.solver = - (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = (env.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = (env.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = true; - FStar_TypeChecker_Env.flychecking = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env.FStar_TypeChecker_Env.missing_decl) - } in - let uu___ = FStar_Syntax_Syntax.t_tac_of a b in - tc_check_tot_or_gtot_term env1 tau uu___ - FStar_Pervasives_Native.None -and (check_instantiated_fvar : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.var -> - FStar_Syntax_Syntax.fv_qual FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.typ -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.lcomp * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun v -> - fun q -> - fun e -> - fun t0 -> - let is_data_ctor uu___ = - match uu___ with - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Data_ctor) - -> true - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Record_ctor - uu___1) -> true - | uu___1 -> false in - (let uu___1 = - (is_data_ctor q) && - (let uu___2 = - FStar_TypeChecker_Env.is_datacon env - v.FStar_Syntax_Syntax.v in - Prims.op_Negation uu___2) in - if uu___1 - then - let uu___2 = - let uu___3 = - FStar_Ident.string_of_lid v.FStar_Syntax_Syntax.v in - FStar_Compiler_Util.format1 - "Expected a data constructor; got %s" uu___3 in - FStar_Errors.raise_error FStar_TypeChecker_Env.hasRange_env - env FStar_Errors_Codes.Fatal_MissingDataConstructor () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2) - else ()); - (let t = FStar_Syntax_Util.remove_inacc t0 in - let uu___1 = FStar_TypeChecker_Util.maybe_instantiate env e t in - match uu___1 with - | (e1, t1, implicits) -> - let tc = - let uu___2 = FStar_TypeChecker_Env.should_verify env in - if uu___2 - then FStar_Pervasives.Inl t1 - else - (let uu___4 = - let uu___5 = FStar_Syntax_Syntax.mk_Total t1 in - FStar_TypeChecker_Common.lcomp_of_comp uu___5 in - FStar_Pervasives.Inr uu___4) in - value_check_expected_typ env e1 tc implicits) -and (tc_value : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.lcomp * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun e -> - let env1 = - FStar_TypeChecker_Env.set_range env e.FStar_Syntax_Syntax.pos in - let top = FStar_Syntax_Subst.compress e in - match top.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_bvar x -> - let uu___ = - let uu___1 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term top in - FStar_Compiler_Util.format1 - "Violation of locally nameless convention: %s" uu___1 in - FStar_Errors.raise_error (FStar_Syntax_Syntax.has_range_syntax ()) - top FStar_Errors_Codes.Error_IllScopedTerm () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___) - | FStar_Syntax_Syntax.Tm_uvar (u, s) -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Syntax_Util.ctx_uvar_typ u in - FStar_Syntax_Subst.subst' s uu___2 in - FStar_Pervasives.Inl uu___1 in - value_check_expected_typ env1 e uu___ - (FStar_Class_Monoid.mzero FStar_TypeChecker_Common.monoid_guard_t) - | FStar_Syntax_Syntax.Tm_unknown -> - let r = FStar_TypeChecker_Env.get_range env1 in - let uu___ = - let uu___1 = FStar_TypeChecker_Env.expected_typ env1 in - match uu___1 with - | FStar_Pervasives_Native.None -> - let uu___2 = FStar_Syntax_Util.type_u () in - (match uu___2 with - | (k, u) -> - let uu___3 = - FStar_TypeChecker_Util.new_implicit_var - "type of user-provided implicit term" r env1 k false in - (match uu___3 with | (t, uu___4, g0) -> (t, g0))) - | FStar_Pervasives_Native.Some (t, use_eq) when use_eq -> - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.format1 - "Equality ascription as an expected type for unk (:%s) is not yet supported." - uu___5 in - FStar_Errors_Msg.text uu___4 in - let uu___4 = - let uu___5 = - FStar_Errors_Msg.text "Please use subtyping." in - [uu___5] in - uu___3 :: uu___4 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) e - FStar_Errors_Codes.Fatal_NotSupported () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___2) - | FStar_Pervasives_Native.Some (t, uu___2) -> - (t, - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t)) in - (match uu___ with - | (t, g0) -> - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Class_Show.show - FStar_Compiler_Range_Ops.showable_range r in - Prims.strcat "user-provided implicit term at " uu___3 in - FStar_TypeChecker_Util.new_implicit_var uu___2 r env1 t - false in - (match uu___1 with - | (e1, uu___2, g1) -> - let uu___3 = - let uu___4 = FStar_Syntax_Syntax.mk_Total t in - FStar_TypeChecker_Common.lcomp_of_comp uu___4 in - let uu___4 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t g0 g1 in - (e1, uu___3, uu___4))) - | FStar_Syntax_Syntax.Tm_name x -> - let uu___ = FStar_TypeChecker_Env.lookup_bv env1 x in - (match uu___ with - | (t, rng) -> - let x1 = - FStar_Syntax_Syntax.set_range_of_bv - { - FStar_Syntax_Syntax.ppname = - (x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (x.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = t - } rng in - (FStar_TypeChecker_Env.insert_bv_info env1 x1 t; - (let e1 = FStar_Syntax_Syntax.bv_to_name x1 in - let uu___2 = - FStar_TypeChecker_Util.maybe_instantiate env1 e1 t in - match uu___2 with - | (e2, t1, implicits) -> - let tc = - let uu___3 = FStar_TypeChecker_Env.should_verify env1 in - if uu___3 - then FStar_Pervasives.Inl t1 - else - (let uu___5 = - let uu___6 = FStar_Syntax_Syntax.mk_Total t1 in - FStar_TypeChecker_Common.lcomp_of_comp uu___6 in - FStar_Pervasives.Inr uu___5) in - value_check_expected_typ env1 e2 tc implicits))) - | FStar_Syntax_Syntax.Tm_uinst - ({ FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___; - FStar_Syntax_Syntax.vars = uu___1; - FStar_Syntax_Syntax.hash_code = uu___2;_}, - uu___3) - when - (FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.synth_lid) && - (Prims.op_Negation env1.FStar_TypeChecker_Env.phase1) - -> - FStar_Errors.raise_error FStar_TypeChecker_Env.hasRange_env env1 - FStar_Errors_Codes.Fatal_BadlyInstantiatedSynthByTactic () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic "Badly instantiated synth_by_tactic") - | FStar_Syntax_Syntax.Tm_fvar fv when - (FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.synth_lid) && - (Prims.op_Negation env1.FStar_TypeChecker_Env.phase1) - -> - FStar_Errors.raise_error FStar_TypeChecker_Env.hasRange_env env1 - FStar_Errors_Codes.Fatal_BadlyInstantiatedSynthByTactic () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic "Badly instantiated synth_by_tactic") - | FStar_Syntax_Syntax.Tm_uinst - ({ FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___; - FStar_Syntax_Syntax.vars = uu___1; - FStar_Syntax_Syntax.hash_code = uu___2;_}, - us) - -> - let us1 = FStar_Compiler_List.map (tc_universe env1) us in - let uu___3 = - FStar_TypeChecker_Env.lookup_lid env1 - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - (match uu___3 with - | ((us', t), range) -> - let fv1 = FStar_Syntax_Syntax.set_range_of_fv fv range in - (maybe_warn_on_use env1 fv1; - if - (FStar_Compiler_List.length us1) <> - (FStar_Compiler_List.length us') - then - (let uu___6 = - let uu___7 = - FStar_Class_Show.show FStar_Syntax_Print.showable_fv - fv1 in - let uu___8 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_nat) - (FStar_Compiler_List.length us1) in - let uu___9 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_nat) - (FStar_Compiler_List.length us') in - FStar_Compiler_Util.format3 - "Unexpected number of universe instantiations for \"%s\" (%s vs %s)" - uu___7 uu___8 uu___9 in - FStar_Errors.raise_error - FStar_TypeChecker_Env.hasRange_env env1 - FStar_Errors_Codes.Fatal_UnexpectedNumberOfUniverse () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___6)) - else (); - FStar_Compiler_List.iter2 - (fun ul -> - fun ur -> - match (ul, ur) with - | (FStar_Syntax_Syntax.U_unif u'', uu___7) -> - FStar_Syntax_Unionfind.univ_change u'' ur - | (FStar_Syntax_Syntax.U_name n1, - FStar_Syntax_Syntax.U_name n2) when - FStar_Ident.ident_equals n1 n2 -> () - | uu___7 -> - let uu___8 = - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_fv fv1 in - let uu___10 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_univ ul in - let uu___11 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_univ ur in - FStar_Compiler_Util.format3 - "Incompatible universe application for %s, expected %s got %s\n" - uu___9 uu___10 uu___11 in - FStar_Errors.raise_error - FStar_TypeChecker_Env.hasRange_env env1 - FStar_Errors_Codes.Fatal_IncompatibleUniverse () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___8)) us' us1; - FStar_TypeChecker_Env.insert_fv_info env1 fv1 t; - (let e1 = - let uu___8 = - FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_fvar fv1) - e.FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.mk_Tm_uinst uu___8 us1 in - check_instantiated_fvar env1 fv1.FStar_Syntax_Syntax.fv_name - fv1.FStar_Syntax_Syntax.fv_qual e1 t))) - | FStar_Syntax_Syntax.Tm_uinst (uu___, us) -> - FStar_Errors.raise_error FStar_TypeChecker_Env.hasRange_env env1 - FStar_Errors_Codes.Fatal_UnexpectedNumberOfUniverse () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Universe applications are only allowed on top-level identifiers") - | FStar_Syntax_Syntax.Tm_fvar fv -> - let uu___ = - FStar_TypeChecker_Env.lookup_lid env1 - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - (match uu___ with - | ((us, t), range) -> - let fv1 = FStar_Syntax_Syntax.set_range_of_fv fv range in - (maybe_warn_on_use env1 fv1; - (let uu___3 = FStar_Compiler_Effect.op_Bang dbg_Range in - if uu___3 - then - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.lid_of_fv fv1 in - FStar_Class_Show.show FStar_Ident.showable_lident uu___5 in - let uu___5 = - FStar_Compiler_Range_Ops.string_of_range - e.FStar_Syntax_Syntax.pos in - let uu___6 = - FStar_Compiler_Range_Ops.string_of_range range in - let uu___7 = - FStar_Compiler_Range_Ops.string_of_use_range range in - let uu___8 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.print5 - "Lookup up fvar %s at location %s (lid range = defined at %s, used at %s); got universes type %s\n" - uu___4 uu___5 uu___6 uu___7 uu___8 - else ()); - FStar_TypeChecker_Env.insert_fv_info env1 fv1 t; - (let e1 = - let uu___4 = - FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_fvar fv1) - e.FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.mk_Tm_uinst uu___4 us in - check_instantiated_fvar env1 fv1.FStar_Syntax_Syntax.fv_name - fv1.FStar_Syntax_Syntax.fv_qual e1 t))) - | FStar_Syntax_Syntax.Tm_constant c -> - let t = tc_constant env1 top.FStar_Syntax_Syntax.pos c in - let e1 = - FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_constant c) - e.FStar_Syntax_Syntax.pos in - value_check_expected_typ env1 e1 (FStar_Pervasives.Inl t) - (FStar_Class_Monoid.mzero FStar_TypeChecker_Common.monoid_guard_t) - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; FStar_Syntax_Syntax.comp = c;_} -> - let uu___ = FStar_Syntax_Subst.open_comp bs c in - (match uu___ with - | (bs1, c1) -> - let env0 = env1 in - let uu___1 = FStar_TypeChecker_Env.clear_expected_typ env1 in - (match uu___1 with - | (env2, uu___2) -> - let uu___3 = tc_binders env2 bs1 in - (match uu___3 with - | (bs2, env3, g, us) -> - let uu___4 = tc_comp env3 c1 in - (match uu___4 with - | (c2, uc, f) -> - let e1 = - let uu___5 = FStar_Syntax_Util.arrow bs2 c2 in - { - FStar_Syntax_Syntax.n = - (uu___5.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = - (top.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = - (uu___5.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (uu___5.FStar_Syntax_Syntax.hash_code) - } in - (if - Prims.op_Negation - env3.FStar_TypeChecker_Env.phase1 - then check_smt_pat env3 e1 bs2 c2 - else (); - (let u = FStar_Syntax_Syntax.U_max (uc :: us) in - let t = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_type u) - top.FStar_Syntax_Syntax.pos in - let g1 = - let uu___6 = - FStar_TypeChecker_Env.close_guard_univs - us bs2 f in - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t g - uu___6 in - let g2 = - FStar_TypeChecker_Util.close_guard_implicits - env3 false bs2 g1 in - value_check_expected_typ env0 e1 - (FStar_Pervasives.Inl t) g2)))))) - | FStar_Syntax_Syntax.Tm_type u -> - let u1 = tc_universe env1 u in - let t = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_type (FStar_Syntax_Syntax.U_succ u1)) - top.FStar_Syntax_Syntax.pos in - let e1 = - FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_type u1) - top.FStar_Syntax_Syntax.pos in - value_check_expected_typ env1 e1 (FStar_Pervasives.Inl t) - (FStar_Class_Monoid.mzero FStar_TypeChecker_Common.monoid_guard_t) - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x; FStar_Syntax_Syntax.phi = phi;_} -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Syntax_Syntax.mk_binder x in [uu___2] in - FStar_Syntax_Subst.open_term uu___1 phi in - (match uu___ with - | (x1, phi1) -> - let env0 = env1 in - let uu___1 = FStar_TypeChecker_Env.clear_expected_typ env1 in - (match uu___1 with - | (env2, uu___2) -> - let uu___3 = - let uu___4 = FStar_Compiler_List.hd x1 in - tc_binder env2 uu___4 in - (match uu___3 with - | (x2, env3, f1, u) -> - ((let uu___5 = FStar_Compiler_Debug.high () in - if uu___5 - then - let uu___6 = - FStar_Compiler_Range_Ops.string_of_range - top.FStar_Syntax_Syntax.pos in - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term phi1 in - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_bv - x2.FStar_Syntax_Syntax.binder_bv in - FStar_Compiler_Util.print3 - "(%s) Checking refinement formula %s; binder is %s\n" - uu___6 uu___7 uu___8 - else ()); - (let uu___5 = FStar_Syntax_Util.type_u () in - match uu___5 with - | (t_phi, uu___6) -> - let uu___7 = - tc_check_tot_or_gtot_term env3 phi1 t_phi - (FStar_Pervasives_Native.Some - "refinement formula must be pure or ghost") in - (match uu___7 with - | (phi2, uu___8, f2) -> - let e1 = - let uu___9 = - FStar_Syntax_Util.refine - x2.FStar_Syntax_Syntax.binder_bv - phi2 in - { - FStar_Syntax_Syntax.n = - (uu___9.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = - (top.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = - (uu___9.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (uu___9.FStar_Syntax_Syntax.hash_code) - } in - let t = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_type u) - top.FStar_Syntax_Syntax.pos in - let g = - let uu___9 = - FStar_TypeChecker_Env.close_guard_univs - [u] [x2] f2 in - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - f1 uu___9 in - let g1 = - FStar_TypeChecker_Util.close_guard_implicits - env3 false [x2] g in - value_check_expected_typ env0 e1 - (FStar_Pervasives.Inl t) g1)))))) - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs; FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = uu___;_} - -> - let bs1 = FStar_TypeChecker_Util.maybe_add_implicit_binders env1 bs in - ((let uu___2 = FStar_Compiler_Debug.medium () in - if uu___2 - then - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - { - FStar_Syntax_Syntax.n = - (FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = bs1; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = - FStar_Pervasives_Native.None - }); - FStar_Syntax_Syntax.pos = (top.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = (top.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (top.FStar_Syntax_Syntax.hash_code) - } in - FStar_Compiler_Util.print1 "Abstraction is: %s\n" uu___3 - else ()); - (let uu___2 = FStar_Syntax_Subst.open_term bs1 body in - match uu___2 with | (bs2, body1) -> tc_abs env1 top bs2 body1)) - | uu___ -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term top in - let uu___3 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term top in - FStar_Compiler_Util.format2 "Unexpected value: %s (%s)" uu___2 - uu___3 in - failwith uu___1 -and (tc_constant : - FStar_TypeChecker_Env.env -> - FStar_Compiler_Range_Type.range -> - FStar_Const.sconst -> FStar_Syntax_Syntax.typ) - = - fun env -> - fun r -> - fun c -> - let res = - match c with - | FStar_Const.Const_unit -> FStar_Syntax_Syntax.t_unit - | FStar_Const.Const_bool uu___ -> FStar_Syntax_Util.t_bool - | FStar_Const.Const_int (uu___, FStar_Pervasives_Native.None) -> - FStar_Syntax_Syntax.t_int - | FStar_Const.Const_int (uu___, FStar_Pervasives_Native.Some msize) - -> - FStar_Syntax_Syntax.tconst - (match msize with - | (FStar_Const.Signed, FStar_Const.Int8) -> - FStar_Parser_Const.int8_lid - | (FStar_Const.Signed, FStar_Const.Int16) -> - FStar_Parser_Const.int16_lid - | (FStar_Const.Signed, FStar_Const.Int32) -> - FStar_Parser_Const.int32_lid - | (FStar_Const.Signed, FStar_Const.Int64) -> - FStar_Parser_Const.int64_lid - | (FStar_Const.Unsigned, FStar_Const.Int8) -> - FStar_Parser_Const.uint8_lid - | (FStar_Const.Unsigned, FStar_Const.Int16) -> - FStar_Parser_Const.uint16_lid - | (FStar_Const.Unsigned, FStar_Const.Int32) -> - FStar_Parser_Const.uint32_lid - | (FStar_Const.Unsigned, FStar_Const.Int64) -> - FStar_Parser_Const.uint64_lid - | (FStar_Const.Unsigned, FStar_Const.Sizet) -> - FStar_Parser_Const.sizet_lid) - | FStar_Const.Const_string uu___ -> FStar_Syntax_Syntax.t_string - | FStar_Const.Const_real uu___ -> FStar_Syntax_Syntax.t_real - | FStar_Const.Const_char uu___ -> - let uu___1 = - FStar_Syntax_DsEnv.try_lookup_lid - env.FStar_TypeChecker_Env.dsenv FStar_Parser_Const.char_lid in - FStar_Compiler_Util.must uu___1 - | FStar_Const.Const_effect -> FStar_Syntax_Util.ktype0 - | FStar_Const.Const_range uu___ -> FStar_Syntax_Syntax.t_range - | FStar_Const.Const_range_of -> - let uu___ = - let uu___1 = - FStar_Class_Show.show FStar_Syntax_Print.showable_const c in - FStar_Compiler_Util.format1 - "Ill-typed %s: this constant must be fully applied" uu___1 in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_IllTyped () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___) - | FStar_Const.Const_set_range_of -> - let uu___ = - let uu___1 = - FStar_Class_Show.show FStar_Syntax_Print.showable_const c in - FStar_Compiler_Util.format1 - "Ill-typed %s: this constant must be fully applied" uu___1 in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_IllTyped () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___) - | FStar_Const.Const_reify uu___ -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_const c in - FStar_Compiler_Util.format1 - "Ill-typed %s: this constant must be fully applied" uu___2 in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_IllTyped () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) - | FStar_Const.Const_reflect uu___ -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_const c in - FStar_Compiler_Util.format1 - "Ill-typed %s: this constant must be fully applied" uu___2 in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_IllTyped () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) - | uu___ -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_const c in - Prims.strcat "Unsupported constant: " uu___2 in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_UnsupportedConstant () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) in - FStar_Syntax_Subst.set_use_range r res -and (tc_comp : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.comp -> - (FStar_Syntax_Syntax.comp * FStar_Syntax_Syntax.universe * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun c -> - let c0 = c in - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total t -> - let uu___ = FStar_Syntax_Util.type_u () in - (match uu___ with - | (k, u) -> - let uu___1 = - tc_check_tot_or_gtot_term env t k - FStar_Pervasives_Native.None in - (match uu___1 with - | (t1, uu___2, g) -> - let uu___3 = FStar_Syntax_Syntax.mk_Total t1 in - (uu___3, u, g))) - | FStar_Syntax_Syntax.GTotal t -> - let uu___ = FStar_Syntax_Util.type_u () in - (match uu___ with - | (k, u) -> - let uu___1 = - tc_check_tot_or_gtot_term env t k - FStar_Pervasives_Native.None in - (match uu___1 with - | (t1, uu___2, g) -> - let uu___3 = FStar_Syntax_Syntax.mk_GTotal t1 in - (uu___3, u, g))) - | FStar_Syntax_Syntax.Comp c1 -> - let head = - FStar_Syntax_Syntax.fvar c1.FStar_Syntax_Syntax.effect_name - FStar_Pervasives_Native.None in - let head1 = - match c1.FStar_Syntax_Syntax.comp_univs with - | [] -> head - | us -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_uinst (head, us)) - c0.FStar_Syntax_Syntax.pos in - let tc = - let uu___ = - let uu___1 = - FStar_Syntax_Syntax.as_arg c1.FStar_Syntax_Syntax.result_typ in - uu___1 :: (c1.FStar_Syntax_Syntax.effect_args) in - FStar_Syntax_Syntax.mk_Tm_app head1 uu___ - (c1.FStar_Syntax_Syntax.result_typ).FStar_Syntax_Syntax.pos in - let uu___ = - tc_check_tot_or_gtot_term - { - FStar_TypeChecker_Env.solver = - (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (env.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = true; - FStar_TypeChecker_Env.flychecking = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env.FStar_TypeChecker_Env.missing_decl) - } tc FStar_Syntax_Syntax.teff FStar_Pervasives_Native.None in - (match uu___ with - | (tc1, uu___1, f) -> - let uu___2 = FStar_Syntax_Util.head_and_args tc1 in - (match uu___2 with - | (head2, args) -> - let comp_univs = - let uu___3 = - let uu___4 = FStar_Syntax_Subst.compress head2 in - uu___4.FStar_Syntax_Syntax.n in - match uu___3 with - | FStar_Syntax_Syntax.Tm_uinst (uu___4, us) -> us - | uu___4 -> [] in - let uu___3 = FStar_Syntax_Util.head_and_args tc1 in - (match uu___3 with - | (uu___4, args1) -> - let uu___5 = - let uu___6 = FStar_Compiler_List.hd args1 in - let uu___7 = FStar_Compiler_List.tl args1 in - (uu___6, uu___7) in - (match uu___5 with - | (res, args2) -> - let uu___6 = - let uu___7 = - FStar_Compiler_List.map - (fun uu___8 -> - match uu___8 with - | FStar_Syntax_Syntax.DECREASES - (FStar_Syntax_Syntax.Decreases_lex - l) -> - let uu___9 = - FStar_TypeChecker_Env.clear_expected_typ - env in - (match uu___9 with - | (env1, uu___10) -> - let uu___11 = - FStar_Compiler_List.fold_left - (fun uu___12 -> - fun e -> - match uu___12 with - | (l1, g) -> - let uu___13 = - tc_tot_or_gtot_term - env1 e in - (match uu___13 - with - | (e1, uu___14, - g_e) -> - let uu___15 - = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g g_e in - ((FStar_Compiler_List.op_At - l1 - [e1]), - uu___15))) - ([], - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t)) - l in - (match uu___11 with - | (l1, g) -> - ((FStar_Syntax_Syntax.DECREASES - (FStar_Syntax_Syntax.Decreases_lex - l1)), g))) - | FStar_Syntax_Syntax.DECREASES - (FStar_Syntax_Syntax.Decreases_wf - (rel, e)) -> - let uu___9 = - FStar_TypeChecker_Env.clear_expected_typ - env in - (match uu___9 with - | (env1, uu___10) -> - let uu___11 = - FStar_Syntax_Util.type_u () in - (match uu___11 with - | (t, u_t) -> - let u_r = - FStar_TypeChecker_Env.new_u_univ - () in - let uu___12 = - FStar_TypeChecker_Util.new_implicit_var - "implicit for type of the well-founded relation in decreases clause" - rel.FStar_Syntax_Syntax.pos - env1 t false in - (match uu___12 with - | (a, uu___13, g_a) -> - let wf_t = - let uu___14 = - let uu___15 = - FStar_TypeChecker_Env.fvar_of_nonqual_lid - env1 - FStar_Parser_Const.well_founded_relation_lid in - FStar_Syntax_Syntax.mk_Tm_uinst - uu___15 - [u_t; u_r] in - let uu___15 = - let uu___16 = - FStar_Syntax_Syntax.as_arg - a in - [uu___16] in - FStar_Syntax_Syntax.mk_Tm_app - uu___14 uu___15 - rel.FStar_Syntax_Syntax.pos in - let uu___14 = - let uu___15 = - FStar_TypeChecker_Env.set_expected_typ - env1 wf_t in - tc_tot_or_gtot_term - uu___15 rel in - (match uu___14 with - | (rel1, uu___15, - g_rel) -> - let uu___16 = - let uu___17 - = - FStar_TypeChecker_Env.set_expected_typ - env1 a in - tc_tot_or_gtot_term - uu___17 e in - (match uu___16 - with - | (e1, - uu___17, - g_e) -> - let uu___18 - = - let uu___19 - = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g_a g_rel in - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - uu___19 - g_e in - ((FStar_Syntax_Syntax.DECREASES - (FStar_Syntax_Syntax.Decreases_wf - (rel1, - e1))), - uu___18)))))) - | f1 -> - (f1, - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t))) - c1.FStar_Syntax_Syntax.flags in - FStar_Compiler_List.unzip uu___7 in - (match uu___6 with - | (flags, guards) -> - let u = - env.FStar_TypeChecker_Env.universe_of - env (FStar_Pervasives_Native.fst res) in - let c2 = - FStar_Syntax_Syntax.mk_Comp - { - FStar_Syntax_Syntax.comp_univs = - comp_univs; - FStar_Syntax_Syntax.effect_name = - (c1.FStar_Syntax_Syntax.effect_name); - FStar_Syntax_Syntax.result_typ = - (FStar_Pervasives_Native.fst res); - FStar_Syntax_Syntax.effect_args = - args2; - FStar_Syntax_Syntax.flags = flags - } in - let u_c = - FStar_TypeChecker_Util.universe_of_comp - env u c2 in - let uu___7 = - let uu___8 = - FStar_Class_Monoid.msum - FStar_TypeChecker_Common.monoid_guard_t - guards in - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - f uu___8 in - (c2, u_c, uu___7)))))) -and (tc_universe : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.universe -> FStar_Syntax_Syntax.universe) - = - fun env -> - fun u -> - let rec aux u1 = - let u2 = FStar_Syntax_Subst.compress_univ u1 in - match u2 with - | FStar_Syntax_Syntax.U_bvar uu___ -> - failwith "Impossible: locally nameless" - | FStar_Syntax_Syntax.U_unknown -> failwith "Unknown universe" - | FStar_Syntax_Syntax.U_unif uu___ -> u2 - | FStar_Syntax_Syntax.U_zero -> u2 - | FStar_Syntax_Syntax.U_succ u3 -> - let uu___ = aux u3 in FStar_Syntax_Syntax.U_succ uu___ - | FStar_Syntax_Syntax.U_max us -> - let uu___ = FStar_Compiler_List.map aux us in - FStar_Syntax_Syntax.U_max uu___ - | FStar_Syntax_Syntax.U_name x -> - let uu___ = FStar_TypeChecker_Env.lookup_univ env x in - if uu___ - then u2 - else - (let uu___2 = - let uu___3 = - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_univ - u2 in - Prims.strcat uu___4 " not found" in - Prims.strcat "Universe variable " uu___3 in - failwith uu___2) in - if env.FStar_TypeChecker_Env.lax_universes - then FStar_Syntax_Syntax.U_zero - else - (match u with - | FStar_Syntax_Syntax.U_unknown -> - let uu___1 = FStar_Syntax_Util.type_u () in - FStar_Pervasives_Native.snd uu___1 - | uu___1 -> aux u) -and (tc_abs_expected_function_typ : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.binders -> - (FStar_Syntax_Syntax.typ * Prims.bool) FStar_Pervasives_Native.option - -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.typ FStar_Pervasives_Native.option * - FStar_Syntax_Syntax.binders * FStar_Syntax_Syntax.binders * - FStar_Syntax_Syntax.comp FStar_Pervasives_Native.option * - FStar_TypeChecker_Env.env * FStar_Syntax_Syntax.term * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun bs -> - fun t0 -> - fun body -> - match t0 with - | FStar_Pervasives_Native.None -> - ((match env.FStar_TypeChecker_Env.letrecs with - | [] -> () - | uu___1 -> - failwith - "Impossible: Can't have a let rec annotation but no expected type"); - (let uu___1 = tc_binders env bs in - match uu___1 with - | (bs1, envbody, g_env, uu___2) -> - (FStar_Pervasives_Native.None, bs1, [], - FStar_Pervasives_Native.None, envbody, body, g_env))) - | FStar_Pervasives_Native.Some (t, use_eq) -> - let t1 = FStar_Syntax_Subst.compress t in - let rec as_function_typ norm1 t2 = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t2 in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_uvar uu___1 -> - ((match env.FStar_TypeChecker_Env.letrecs with - | [] -> () - | uu___3 -> - failwith - "Impossible: uvar abs with non-empty environment"); - (let uu___3 = tc_binders env bs in - match uu___3 with - | (bs1, envbody, g_env, uu___4) -> - let uu___5 = - FStar_TypeChecker_Env.clear_expected_typ envbody in - (match uu___5 with - | (envbody1, uu___6) -> - ((FStar_Pervasives_Native.Some t2), bs1, [], - FStar_Pervasives_Native.None, envbody1, - body, g_env)))) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_uvar - uu___1; - FStar_Syntax_Syntax.pos = uu___2; - FStar_Syntax_Syntax.vars = uu___3; - FStar_Syntax_Syntax.hash_code = uu___4;_}; - FStar_Syntax_Syntax.args = uu___5;_} - -> - ((match env.FStar_TypeChecker_Env.letrecs with - | [] -> () - | uu___7 -> - failwith - "Impossible: uvar abs with non-empty environment"); - (let uu___7 = tc_binders env bs in - match uu___7 with - | (bs1, envbody, g_env, uu___8) -> - let uu___9 = - FStar_TypeChecker_Env.clear_expected_typ envbody in - (match uu___9 with - | (envbody1, uu___10) -> - ((FStar_Pervasives_Native.Some t2), bs1, [], - FStar_Pervasives_Native.None, envbody1, - body, g_env)))) - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = b; - FStar_Syntax_Syntax.phi = uu___1;_} - -> - let uu___2 = - as_function_typ norm1 b.FStar_Syntax_Syntax.sort in - (match uu___2 with - | (uu___3, bs1, bs', copt, env_body, body1, g_env) -> - ((FStar_Pervasives_Native.Some t2), bs1, bs', copt, - env_body, body1, g_env)) - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs_expected; - FStar_Syntax_Syntax.comp = c_expected;_} - -> - let uu___1 = - FStar_Syntax_Subst.open_comp bs_expected c_expected in - (match uu___1 with - | (bs_expected1, c_expected1) -> - let check_actuals_against_formals env1 bs1 - bs_expected2 body1 = - let rec handle_more uu___2 c_expected2 body2 = - match uu___2 with - | (env_bs, bs2, more, guard_env, subst) -> - (match more with - | FStar_Pervasives_Native.None -> - let uu___3 = - FStar_Syntax_Subst.subst_comp subst - c_expected2 in - (env_bs, bs2, guard_env, uu___3, body2) - | FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr more_bs_expected) - -> - let c = - let uu___3 = - FStar_Syntax_Util.arrow - more_bs_expected c_expected2 in - FStar_Syntax_Syntax.mk_Total uu___3 in - let uu___3 = - FStar_Syntax_Subst.subst_comp subst c in - (env_bs, bs2, guard_env, uu___3, body2) - | FStar_Pervasives_Native.Some - (FStar_Pervasives.Inl more_bs) -> - let c = - FStar_Syntax_Subst.subst_comp subst - c_expected2 in - let uu___3 = - (FStar_Options.ml_ish ()) || - (FStar_Syntax_Util.is_named_tot c) in - if uu___3 - then - let t3 = - FStar_TypeChecker_Normalize.unfold_whnf - env_bs - (FStar_Syntax_Util.comp_result c) in - (match t3.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 = - bs_expected3; - FStar_Syntax_Syntax.comp = - c_expected3;_} - -> - let uu___4 = - FStar_Syntax_Subst.open_comp - bs_expected3 c_expected3 in - (match uu___4 with - | (bs_expected4, c_expected4) - -> - let uu___5 = - tc_abs_check_binders - env_bs more_bs - bs_expected4 use_eq in - (match uu___5 with - | (env_bs_bs', bs', more1, - guard'_env_bs, subst1) - -> - let guard'_env = - FStar_TypeChecker_Env.close_guard - env_bs bs2 - guard'_env_bs in - let uu___6 = - let uu___7 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - guard_env - guard'_env in - (env_bs_bs', - (FStar_Compiler_List.op_At - bs2 bs'), - more1, uu___7, - subst1) in - handle_more uu___6 - c_expected4 body2)) - | uu___4 -> - let body3 = - FStar_Syntax_Util.abs more_bs - body2 - FStar_Pervasives_Native.None in - (env_bs, bs2, guard_env, c, - body3)) - else - (let body3 = - FStar_Syntax_Util.abs more_bs - body2 - FStar_Pervasives_Native.None in - (env_bs, bs2, guard_env, c, body3))) in - let uu___2 = - tc_abs_check_binders env1 bs1 bs_expected2 - use_eq in - handle_more uu___2 c_expected1 body1 in - let mk_letrec_env envbody bs1 c = - let letrecs = guard_letrecs envbody bs1 c in - let envbody1 = - { - FStar_TypeChecker_Env.solver = - (envbody.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (envbody.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (envbody.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (envbody.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (envbody.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (envbody.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (envbody.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (envbody.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (envbody.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (envbody.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (envbody.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (envbody.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (envbody.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = []; - FStar_TypeChecker_Env.top_level = - (envbody.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (envbody.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (envbody.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (envbody.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (envbody.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (envbody.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (envbody.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (envbody.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (envbody.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (envbody.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (envbody.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (envbody.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (envbody.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (envbody.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (envbody.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (envbody.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (envbody.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (envbody.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (envbody.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (envbody.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (envbody.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (envbody.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (envbody.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (envbody.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (envbody.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (envbody.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (envbody.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (envbody.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (envbody.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (envbody.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (envbody.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (envbody.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (envbody.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (envbody.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (envbody.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (envbody.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (envbody.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (envbody.FStar_TypeChecker_Env.missing_decl) - } in - let uu___2 = - FStar_Compiler_List.fold_left - (fun uu___3 -> - fun uu___4 -> - match (uu___3, uu___4) with - | ((env1, letrec_binders, g), - (l, t3, u_names)) -> - let uu___5 = - let uu___6 = - let uu___7 = - FStar_TypeChecker_Env.clear_expected_typ - env1 in - FStar_Pervasives_Native.fst - uu___7 in - tc_term uu___6 t3 in - (match uu___5 with - | (t4, uu___6, g') -> - let env2 = - FStar_TypeChecker_Env.push_let_binding - env1 l (u_names, t4) in - let lb = - match l with - | FStar_Pervasives.Inl x -> - let uu___7 = - FStar_Syntax_Syntax.mk_binder - { - FStar_Syntax_Syntax.ppname - = - (x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index - = - (x.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort - = t4 - } in - uu___7 :: letrec_binders - | uu___7 -> letrec_binders in - let uu___7 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g g' in - (env2, lb, uu___7))) - (envbody1, [], - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t)) - letrecs in - match uu___2 with - | (envbody2, letrec_binders, g) -> - let uu___3 = - FStar_TypeChecker_Env.close_guard envbody2 - bs1 g in - (envbody2, letrec_binders, uu___3) in - let envbody = - { - FStar_TypeChecker_Env.solver = - (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = []; - FStar_TypeChecker_Env.top_level = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (env.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env.FStar_TypeChecker_Env.missing_decl) - } in - let uu___2 = - check_actuals_against_formals envbody bs - bs_expected1 body in - (match uu___2 with - | (envbody1, bs1, g_env, c, body1) -> - let envbody2 = - { - FStar_TypeChecker_Env.solver = - (envbody1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (envbody1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (envbody1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (envbody1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (envbody1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (envbody1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (envbody1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (envbody1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (envbody1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (envbody1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (envbody1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (envbody1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (envbody1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (envbody1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (envbody1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (envbody1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (envbody1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (envbody1.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (envbody1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (envbody1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (envbody1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (envbody1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (envbody1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (envbody1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (envbody1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (envbody1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (envbody1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (envbody1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (envbody1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (envbody1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (envbody1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (envbody1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (envbody1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (envbody1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (envbody1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (envbody1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (envbody1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (envbody1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (envbody1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (envbody1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (envbody1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (envbody1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (envbody1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (envbody1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (envbody1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (envbody1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (envbody1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (envbody1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (envbody1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (envbody1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (envbody1.FStar_TypeChecker_Env.missing_decl) - } in - let uu___3 = mk_letrec_env envbody2 bs1 c in - (match uu___3 with - | (envbody3, letrecs, g_annots) -> - let envbody4 = - FStar_TypeChecker_Env.set_expected_typ_maybe_eq - envbody3 - (FStar_Syntax_Util.comp_result c) - use_eq in - let uu___4 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g_env g_annots in - ((FStar_Pervasives_Native.Some t2), bs1, - letrecs, - (FStar_Pervasives_Native.Some c), - envbody4, body1, uu___4)))) - | uu___1 -> - if Prims.op_Negation norm1 - then - let uu___2 = - let uu___3 = - FStar_TypeChecker_Normalize.unfold_whnf env t2 in - FStar_Syntax_Util.unascribe uu___3 in - as_function_typ true uu___2 - else - (let uu___3 = - tc_abs_expected_function_typ env bs - FStar_Pervasives_Native.None body in - match uu___3 with - | (uu___4, bs1, uu___5, c_opt, envbody, body1, g_env) - -> - ((FStar_Pervasives_Native.Some t2), bs1, [], - c_opt, envbody, body1, g_env)) in - as_function_typ false t1 -and (tc_abs_check_binders : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.binders -> - Prims.bool -> - (FStar_TypeChecker_Env.env * FStar_Syntax_Syntax.binders * - (FStar_Syntax_Syntax.binders, FStar_Syntax_Syntax.binders) - FStar_Pervasives.either FStar_Pervasives_Native.option * - FStar_TypeChecker_Env.guard_t * FStar_Syntax_Syntax.subst_t)) - = - fun env -> - fun bs -> - fun bs_expected -> - fun use_eq -> - let rec aux uu___ bs1 bs_expected1 = - match uu___ with - | (env1, subst) -> - (match (bs1, bs_expected1) with - | ([], []) -> - (env1, [], FStar_Pervasives_Native.None, - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t), subst) - | ({ FStar_Syntax_Syntax.binder_bv = uu___1; - FStar_Syntax_Syntax.binder_qual = - FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.binder_positivity = uu___2; - FStar_Syntax_Syntax.binder_attrs = uu___3;_}::uu___4, - { FStar_Syntax_Syntax.binder_bv = hd_e; - FStar_Syntax_Syntax.binder_qual = q; - FStar_Syntax_Syntax.binder_positivity = pqual; - FStar_Syntax_Syntax.binder_attrs = attrs;_}::uu___5) - when FStar_Syntax_Syntax.is_bqual_implicit_or_meta q -> - let bv = - let uu___6 = - let uu___7 = - FStar_Ident.range_of_id - hd_e.FStar_Syntax_Syntax.ppname in - FStar_Pervasives_Native.Some uu___7 in - let uu___7 = - FStar_Syntax_Subst.subst subst - hd_e.FStar_Syntax_Syntax.sort in - FStar_Syntax_Syntax.new_bv uu___6 uu___7 in - let uu___6 = - let uu___7 = - FStar_Syntax_Syntax.mk_binder_with_attrs bv q pqual - attrs in - uu___7 :: bs1 in - aux (env1, subst) uu___6 bs_expected1 - | ({ FStar_Syntax_Syntax.binder_bv = hd; - FStar_Syntax_Syntax.binder_qual = imp; - FStar_Syntax_Syntax.binder_positivity = pqual_actual; - FStar_Syntax_Syntax.binder_attrs = attrs;_}::bs2, - { FStar_Syntax_Syntax.binder_bv = hd_expected; - FStar_Syntax_Syntax.binder_qual = imp'; - FStar_Syntax_Syntax.binder_positivity = pqual_expected; - FStar_Syntax_Syntax.binder_attrs = attrs';_}::bs_expected2) - -> - ((let special q1 q2 = - match (q1, q2) with - | (FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Meta uu___2), - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Meta uu___3)) -> true - | (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Equality)) -> true - | (FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Implicit uu___2), - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Meta uu___3)) -> true - | uu___2 -> false in - let uu___2 = - (Prims.op_Negation (special imp imp')) && - (let uu___3 = FStar_Syntax_Util.eq_bqual imp imp' in - Prims.op_Negation uu___3) in - if uu___2 - then - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_bv hd in - FStar_Compiler_Util.format1 - "Inconsistent implicit argument annotation on argument %s" - uu___6 in - FStar_Errors_Msg.text uu___5 in - let uu___5 = - let uu___6 = - let uu___7 = FStar_Errors_Msg.text "Got:" in - let uu___8 = - let uu___9 = - let uu___10 = - FStar_Syntax_Print.bqual_to_string imp in - FStar_Pprint.doc_of_string uu___10 in - FStar_Pprint.squotes uu___9 in - FStar_Pprint.prefix (Prims.of_int (2)) - Prims.int_one uu___7 uu___8 in - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Errors_Msg.text "Expected:" in - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Syntax_Print.bqual_to_string - imp' in - FStar_Pprint.doc_of_string uu___12 in - FStar_Pprint.squotes uu___11 in - FStar_Pprint.prefix (Prims.of_int (2)) - Prims.int_one uu___9 uu___10 in - [uu___8] in - uu___6 :: uu___7 in - uu___4 :: uu___5 in - FStar_Errors.raise_error - FStar_Syntax_Syntax.hasRange_bv hd - FStar_Errors_Codes.Fatal_InconsistentImplicitArgumentAnnotation - () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___3) - else ()); - (let positivity_qual_to_string uu___2 = - match uu___2 with - | FStar_Pervasives_Native.None -> "None" - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.BinderStrictlyPositive) -> - "StrictlyPositive" - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.BinderUnused) -> "Unused" in - (let uu___3 = - let uu___4 = - FStar_TypeChecker_Common.check_positivity_qual - true pqual_expected pqual_actual in - Prims.op_Negation uu___4 in - if uu___3 - then - let uu___4 = - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_bv hd in - FStar_Compiler_Util.format3 - "Inconsistent positivity qualifier on argument %s; Expected qualifier %s, found qualifier %s" - uu___5 - (positivity_qual_to_string pqual_expected) - (positivity_qual_to_string pqual_actual) in - FStar_Errors.raise_error - FStar_Syntax_Syntax.hasRange_bv hd - FStar_Errors_Codes.Fatal_InconsistentQualifierAnnotation - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4) - else ()); - (let expected_t = - FStar_Syntax_Subst.subst subst - hd_expected.FStar_Syntax_Syntax.sort in - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Syntax_Util.unmeta - hd.FStar_Syntax_Syntax.sort in - uu___5.FStar_Syntax_Syntax.n in - match uu___4 with - | FStar_Syntax_Syntax.Tm_unknown -> - (expected_t, - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t)) - | uu___5 -> - ((let uu___7 = FStar_Compiler_Debug.high () in - if uu___7 - then - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_bv hd in - FStar_Compiler_Util.print1 - "Checking binder %s\n" uu___8 - else ()); - (let uu___7 = - tc_tot_or_gtot_term env1 - hd.FStar_Syntax_Syntax.sort in - match uu___7 with - | (t, uu___8, g1_env) -> - let g2_env = - let label_guard g = - let uu___9 = - FStar_Errors_Msg.mkmsg - "Type annotation on parameter incompatible with the expected type" in - FStar_TypeChecker_Util.label_guard - (hd.FStar_Syntax_Syntax.sort).FStar_Syntax_Syntax.pos - uu___9 g in - let uu___9 = - FStar_TypeChecker_Rel.teq_nosmt env1 - t expected_t in - match uu___9 with - | FStar_Pervasives_Native.Some g -> - FStar_TypeChecker_Rel.resolve_implicits - env1 g - | FStar_Pervasives_Native.None -> - if use_eq - then - let uu___10 = - FStar_TypeChecker_Rel.teq env1 - t expected_t in - label_guard uu___10 - else - (let uu___11 = - FStar_TypeChecker_Rel.get_subtyping_prop - env1 expected_t t in - match uu___11 with - | FStar_Pervasives_Native.None - -> - let uu___12 = - FStar_TypeChecker_Env.get_range - env1 in - FStar_TypeChecker_Err.raise_basic_type_error - env1 uu___12 - FStar_Pervasives_Native.None - expected_t t - | FStar_Pervasives_Native.Some - g_env -> label_guard g_env) in - let uu___9 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g1_env g2_env in - (t, uu___9))) in - match uu___3 with - | (t, g_env) -> - let hd1 = - { - FStar_Syntax_Syntax.ppname = - (hd.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (hd.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = t - } in - let combine_attrs attrs1 attrs'1 = - let diff = - FStar_Compiler_List.filter - (fun attr' -> - let uu___4 = - FStar_Compiler_List.existsb - (fun attr -> - let uu___5 = - FStar_TypeChecker_TermEqAndSimplify.eq_tm - env1 attr attr' in - uu___5 = - FStar_TypeChecker_TermEqAndSimplify.Equal) - attrs1 in - Prims.op_Negation uu___4) attrs'1 in - FStar_Compiler_List.op_At attrs1 diff in - let b = - let uu___4 = combine_attrs attrs attrs' in - { - FStar_Syntax_Syntax.binder_bv = hd1; - FStar_Syntax_Syntax.binder_qual = imp; - FStar_Syntax_Syntax.binder_positivity = - pqual_expected; - FStar_Syntax_Syntax.binder_attrs = uu___4 - } in - (check_erasable_binder_attributes env1 - b.FStar_Syntax_Syntax.binder_attrs t; - (let b_expected = - { - FStar_Syntax_Syntax.binder_bv = hd_expected; - FStar_Syntax_Syntax.binder_qual = imp'; - FStar_Syntax_Syntax.binder_positivity = - pqual_expected; - FStar_Syntax_Syntax.binder_attrs = attrs' - } in - let env_b = push_binding env1 b in - let subst1 = - let uu___5 = - FStar_Syntax_Syntax.bv_to_name hd1 in - maybe_extend_subst subst b_expected uu___5 in - let uu___5 = - aux (env_b, subst1) bs2 bs_expected2 in - match uu___5 with - | (env_bs, bs3, rest, g'_env_b, subst2) -> - let g'_env = - FStar_TypeChecker_Env.close_guard env_bs - [b] g'_env_b in - let uu___6 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g_env g'_env in - (env_bs, (b :: bs3), rest, uu___6, subst2)))))) - | (rest, []) -> - (env1, [], - (FStar_Pervasives_Native.Some - (FStar_Pervasives.Inl rest)), - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t), subst) - | ([], rest) -> - (env1, [], - (FStar_Pervasives_Native.Some - (FStar_Pervasives.Inr rest)), - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t), subst)) in - aux (env, []) bs bs_expected -and (tc_abs : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.lcomp * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun top -> - fun bs -> - fun body -> - let fail msg t = - FStar_TypeChecker_Err.expected_a_term_of_type_t_got_a_function - env top.FStar_Syntax_Syntax.pos msg t top in - let env0 = env in - let uu___ = FStar_TypeChecker_Env.clear_expected_typ env in - match uu___ with - | (env1, topt) -> - ((let uu___2 = FStar_Compiler_Debug.high () in - if uu___2 - then - let uu___3 = - FStar_Class_Show.show - (FStar_Class_Show.show_option - (FStar_Class_Show.show_tuple2 - FStar_Syntax_Print.showable_term - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool))) topt in - let uu___4 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) - env1.FStar_TypeChecker_Env.top_level in - FStar_Compiler_Util.print2 - "!!!!!!!!!!!!!!!Expected type is (%s), top_level=%s\n" - uu___3 uu___4 - else ()); - (let uu___2 = tc_abs_expected_function_typ env1 bs topt body in - match uu___2 with - | (tfun_opt, bs1, letrec_binders, c_opt, envbody, body1, - g_env) -> - ((let uu___4 = FStar_Compiler_Debug.extreme () in - if uu___4 - then - let uu___5 = - FStar_Class_Show.show - (FStar_Class_Show.show_option - FStar_Syntax_Print.showable_term) tfun_opt in - let uu___6 = - FStar_Class_Show.show - (FStar_Class_Show.show_option - FStar_Syntax_Print.showable_comp) c_opt in - let uu___7 = - let uu___8 = - FStar_TypeChecker_Env.expected_typ envbody in - FStar_Class_Show.show - (FStar_Class_Show.show_option - (FStar_Class_Show.show_tuple2 - FStar_Syntax_Print.showable_term - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool))) - uu___8 in - FStar_Compiler_Util.print3 - "After expected_function_typ, tfun_opt: %s, c_opt: %s, and expected type in envbody: %s\n" - uu___5 uu___6 uu___7 - else ()); - (let uu___5 = FStar_Compiler_Effect.op_Bang dbg_NYC in - if uu___5 - then - let uu___6 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binder) bs1 in - let uu___7 = - FStar_TypeChecker_Rel.guard_to_string env1 g_env in - FStar_Compiler_Util.print2 - "!!!!!!!!!!!!!!!Guard for function with binders %s is %s\n" - uu___6 uu___7 - else ()); - (let envbody1 = - FStar_TypeChecker_Env.set_range envbody - body1.FStar_Syntax_Syntax.pos in - let uu___5 = - let uu___6 = - let use_eq_opt = - match topt with - | FStar_Pervasives_Native.Some (uu___7, use_eq) - -> FStar_Pervasives_Native.Some use_eq - | uu___7 -> FStar_Pervasives_Native.None in - let uu___7 = - (FStar_Compiler_Util.is_some c_opt) && - (let uu___8 = - let uu___9 = - FStar_Syntax_Subst.compress body1 in - uu___9.FStar_Syntax_Syntax.n in - match uu___8 with - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = args;_} - when - (FStar_Compiler_List.length args) = - Prims.int_one - -> - let uu___9 = - let uu___10 = - FStar_Syntax_Subst.compress head in - uu___10.FStar_Syntax_Syntax.n in - (match uu___9 with - | FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_reflect uu___10) - -> true - | uu___10 -> false) - | uu___9 -> false) in - if uu___7 - then - let uu___8 = - let uu___9 = - FStar_TypeChecker_Env.clear_expected_typ - envbody1 in - FStar_Pervasives_Native.fst uu___9 in - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - FStar_Compiler_Util.must c_opt in - FStar_Pervasives.Inr uu___14 in - let uu___14 = - FStar_Compiler_Util.must use_eq_opt in - (uu___13, FStar_Pervasives_Native.None, - uu___14) in - { - FStar_Syntax_Syntax.tm = body1; - FStar_Syntax_Syntax.asc = uu___12; - FStar_Syntax_Syntax.eff_opt = - FStar_Pervasives_Native.None - } in - FStar_Syntax_Syntax.Tm_ascribed uu___11 in - FStar_Syntax_Syntax.mk uu___10 - FStar_Compiler_Range_Type.dummyRange in - (uu___8, uu___9, (FStar_Pervasives.Inr ())) - else - (let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Syntax_Subst.compress body1 in - uu___12.FStar_Syntax_Syntax.n in - (c_opt, uu___11) in - match uu___10 with - | (FStar_Pervasives_Native.None, - FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = uu___11; - FStar_Syntax_Syntax.asc = - (FStar_Pervasives.Inr expected_c, - uu___12, uu___13); - FStar_Syntax_Syntax.eff_opt = uu___14;_}) - -> FStar_Pervasives.Inr () - | uu___11 -> - FStar_Pervasives.Inl - (FStar_Compiler_Util.dflt false - use_eq_opt) in - (envbody1, body1, uu___9)) in - match uu___6 with - | (envbody2, body2, should_check_expected_effect) -> - let uu___7 = - tc_term - { - FStar_TypeChecker_Env.solver = - (envbody2.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (envbody2.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (envbody2.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (envbody2.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (envbody2.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (envbody2.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (envbody2.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (envbody2.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (envbody2.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (envbody2.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (envbody2.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (envbody2.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (envbody2.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (envbody2.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = false; - FStar_TypeChecker_Env.check_uvars = - (envbody2.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (envbody2.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (envbody2.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (envbody2.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (envbody2.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (envbody2.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (envbody2.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (envbody2.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (envbody2.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (envbody2.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (envbody2.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (envbody2.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (envbody2.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (envbody2.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (envbody2.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (envbody2.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (envbody2.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (envbody2.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (envbody2.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (envbody2.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (envbody2.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (envbody2.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (envbody2.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (envbody2.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (envbody2.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (envbody2.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (envbody2.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (envbody2.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (envbody2.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (envbody2.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (envbody2.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (envbody2.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (envbody2.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (envbody2.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (envbody2.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (envbody2.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (envbody2.FStar_TypeChecker_Env.missing_decl) - } body2 in - (match uu___7 with - | (body3, cbody, guard_body) -> - let guard_body1 = - FStar_TypeChecker_Rel.solve_non_tactic_deferred_constraints - true envbody2 guard_body in - (match should_check_expected_effect with - | FStar_Pervasives.Inl use_eq -> - let uu___8 = - FStar_TypeChecker_Common.lcomp_comp - cbody in - (match uu___8 with - | (cbody1, g_lc) -> - let uu___9 = - FStar_Errors.with_ctx - "While checking that lambda abstraction has expected effect" - (fun uu___10 -> - check_expected_effect - envbody2 use_eq c_opt - (body3, cbody1)) in - (match uu___9 with - | (body4, cbody2, guard) -> - let uu___10 = - let uu___11 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - guard_body1 g_lc in - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - uu___11 guard in - (body4, cbody2, uu___10))) - | FStar_Pervasives.Inr uu___8 -> - let uu___9 = - FStar_TypeChecker_Common.lcomp_comp - cbody in - (match uu___9 with - | (cbody1, g_lc) -> - let uu___10 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - guard_body1 g_lc in - (body3, cbody1, uu___10)))) in - match uu___5 with - | (body2, cbody, guard_body) -> - ((let uu___7 = FStar_Compiler_Debug.extreme () in - if uu___7 - then - let uu___8 = - FStar_TypeChecker_Rel.guard_to_string env1 - guard_body in - FStar_Compiler_Util.print1 - "tc_abs: guard_body: %s\n" uu___8 - else ()); - (let guard_body1 = - if env1.FStar_TypeChecker_Env.top_level - then - ((let uu___8 = FStar_Compiler_Debug.medium () in - if uu___8 - then - let uu___9 = - FStar_TypeChecker_Rel.guard_to_string - env1 guard_body in - FStar_Compiler_Util.print1 - "tc_abs: FORCING guard_body: %s\n" - uu___9 - else ()); - FStar_TypeChecker_Rel.discharge_guard - envbody1 guard_body) - else guard_body in - let guard = - let guard_body2 = - FStar_TypeChecker_Env.close_guard envbody1 - (FStar_Compiler_List.op_At bs1 - letrec_binders) guard_body1 in - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t g_env - guard_body2 in - let guard1 = - FStar_TypeChecker_Util.close_guard_implicits - env1 false bs1 guard in - let tfun_computed = - FStar_Syntax_Util.arrow bs1 cbody in - let e = - let uu___7 = - let uu___8 = - FStar_Syntax_Util.residual_comp_of_comp - (FStar_Compiler_Util.dflt cbody c_opt) in - FStar_Pervasives_Native.Some uu___8 in - FStar_Syntax_Util.abs bs1 body2 uu___7 in - FStar_Compiler_List.iter - (fun b -> - let uu___8 = FStar_Options.no_positivity () in - if uu___8 - then () - else - ((let uu___11 = - (FStar_Syntax_Util.is_binder_unused b) - && - (let uu___12 = - FStar_TypeChecker_Positivity.name_unused_in_type - envbody1 - b.FStar_Syntax_Syntax.binder_bv - body2 in - Prims.op_Negation uu___12) in - if uu___11 - then - let uu___12 = - let uu___13 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_binder - b in - FStar_Compiler_Util.format1 - "Binder %s is marked unused, but its use in the definition is not" - uu___13 in - FStar_Errors.raise_error - FStar_Syntax_Syntax.hasRange_binder - b - FStar_Errors_Codes.Error_InductiveTypeNotSatisfyPositivityCondition - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___12) - else ()); - (let uu___11 = - (FStar_Syntax_Util.is_binder_strictly_positive - b) - && - (let uu___12 = - FStar_TypeChecker_Positivity.name_strictly_positive_in_type - envbody1 - b.FStar_Syntax_Syntax.binder_bv - body2 in - Prims.op_Negation uu___12) in - if uu___11 - then - let uu___12 = - let uu___13 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_binder - b in - FStar_Compiler_Util.format1 - "Binder %s is marked strictly positive, but its use in the definition is not" - uu___13 in - FStar_Errors.raise_error - FStar_Syntax_Syntax.hasRange_binder - b - FStar_Errors_Codes.Error_InductiveTypeNotSatisfyPositivityCondition - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___12) - else ()))) bs1; - (let uu___8 = - match tfun_opt with - | FStar_Pervasives_Native.Some t -> - let t1 = FStar_Syntax_Subst.compress t in - let uu___9 = - match topt with - | FStar_Pervasives_Native.Some - (t2, use_eq) -> (t2, use_eq) - | FStar_Pervasives_Native.None -> - failwith - "Impossible! tc_abs: if tfun_computed is Some, expected topt to also be Some" in - (match uu___9 with - | (t_annot, use_eq) -> - (match t1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_arrow - uu___10 -> (e, t_annot, guard1) - | uu___10 -> - let lc = - let uu___11 = - FStar_Syntax_Syntax.mk_Total - tfun_computed in - FStar_TypeChecker_Common.lcomp_of_comp - uu___11 in - let uu___11 = - FStar_TypeChecker_Util.check_has_type_maybe_coerce - env1 e lc t1 use_eq in - (match uu___11 with - | (e1, uu___12, guard') -> - let guard'1 = - let uu___13 = - FStar_TypeChecker_Err.subtyping_failed - env1 - lc.FStar_TypeChecker_Common.res_typ - t1 () in - FStar_TypeChecker_Util.label_guard - e1.FStar_Syntax_Syntax.pos - uu___13 guard' in - let uu___13 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - guard1 guard'1 in - (e1, t_annot, uu___13)))) - | FStar_Pervasives_Native.None -> - (e, tfun_computed, guard1) in - match uu___8 with - | (e1, tfun, guard2) -> - let c = FStar_Syntax_Syntax.mk_Total tfun in - let uu___9 = - let uu___10 = - FStar_TypeChecker_Common.lcomp_of_comp c in - FStar_TypeChecker_Util.strengthen_precondition - FStar_Pervasives_Native.None env1 e1 - uu___10 guard2 in - (match uu___9 with | (c1, g) -> (e1, c1, g))))))))) -and (check_application_args : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.comp -> - FStar_TypeChecker_Env.guard_t -> - (FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) - Prims.list -> - (FStar_Syntax_Syntax.typ * Prims.bool) - FStar_Pervasives_Native.option -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.lcomp * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun head -> - fun chead -> - fun ghead -> - fun args -> - fun expected_topt -> - let n_args = FStar_Compiler_List.length args in - let r = FStar_TypeChecker_Env.get_range env in - let thead = FStar_Syntax_Util.comp_result chead in - (let uu___1 = FStar_Compiler_Debug.high () in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show - FStar_Compiler_Range_Ops.showable_range - head.FStar_Syntax_Syntax.pos in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - thead in - let uu___4 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - (FStar_Class_Show.show_tuple2 - FStar_Syntax_Print.showable_term - FStar_Syntax_Print.showable_aqual)) args in - FStar_Compiler_Util.print3 - "(%s) Type of head is %s\nArgs = %s\n" uu___2 uu___3 - uu___4 - else ()); - (let monadic_application uu___1 subst arg_comps_rev - arg_rets_rev guard fvs bs = - match uu___1 with - | (head1, chead1, ghead1, cres) -> - let uu___2 = - match bs with - | [] -> - let uu___3 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t ghead1 - guard in - (cres, uu___3) - | uu___3 -> - let g = - let uu___4 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - ghead1 guard in - FStar_TypeChecker_Rel.solve_deferred_constraints - env uu___4 in - let uu___4 = - let uu___5 = FStar_Syntax_Util.arrow bs cres in - FStar_Syntax_Syntax.mk_Total uu___5 in - (uu___4, g) in - (match uu___2 with - | (cres1, guard1) -> - let uu___3 = - check_no_escape - (FStar_Pervasives_Native.Some head1) env fvs - (FStar_Syntax_Util.comp_result cres1) in - (match uu___3 with - | (rt, g0) -> - let uu___4 = - let uu___5 = - FStar_Syntax_Util.set_result_typ cres1 rt in - let uu___6 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g0 guard1 in - (uu___5, uu___6) in - (match uu___4 with - | (cres2, guard2) -> - ((let uu___6 = - FStar_Compiler_Debug.medium () in - if uu___6 - then - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_comp - cres2 in - FStar_Compiler_Util.print1 - "\t Type of result cres is %s\n" - uu___7 - else ()); - (let uu___6 = - let uu___7 = - let uu___8 = - FStar_Syntax_Subst.subst_comp - subst chead1 in - FStar_TypeChecker_Common.lcomp_of_comp - uu___8 in - let uu___8 = - let uu___9 = - FStar_Syntax_Subst.subst_comp - subst cres2 in - FStar_TypeChecker_Common.lcomp_of_comp - uu___9 in - (uu___7, uu___8) in - match uu___6 with - | (chead2, cres3) -> - let uu___7 = - let head_is_pure_and_some_arg_is_effectful - = - (FStar_TypeChecker_Common.is_pure_or_ghost_lcomp - chead2) - && - (FStar_Compiler_Util.for_some - (fun uu___8 -> - match uu___8 with - | (uu___9, uu___10, lc) - -> - (let uu___11 = - FStar_TypeChecker_Common.is_pure_or_ghost_lcomp - lc in - Prims.op_Negation - uu___11) - || - (FStar_TypeChecker_Util.should_not_inline_lc - lc)) - arg_comps_rev) in - let term = - FStar_Syntax_Syntax.mk_Tm_app - head1 - (FStar_Compiler_List.rev - arg_rets_rev) - head1.FStar_Syntax_Syntax.pos in - let uu___8 = - (FStar_TypeChecker_Common.is_pure_or_ghost_lcomp - cres3) - && - head_is_pure_and_some_arg_is_effectful in - if uu___8 - then - ((let uu___10 = - FStar_Compiler_Debug.extreme - () in - if uu___10 - then - let uu___11 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - term in - FStar_Compiler_Util.print1 - "(a) Monadic app: Return inserted in monadic application: %s\n" - uu___11 - else ()); - (let uu___10 = - FStar_TypeChecker_Util.maybe_assume_result_eq_pure_term - env term cres3 in - (uu___10, true))) - else - ((let uu___11 = - FStar_Compiler_Debug.extreme - () in - if uu___11 - then - let uu___12 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - term in - FStar_Compiler_Util.print1 - "(a) Monadic app: No return inserted in monadic application: %s\n" - uu___12 - else ()); - (cres3, false)) in - (match uu___7 with - | (cres4, inserted_return_in_cres) - -> - let comp = - let arg_rets_names_opt = - FStar_Compiler_List.map - (fun uu___8 -> - match uu___8 with - | (t, uu___9) -> - let uu___10 = - let uu___11 = - FStar_Syntax_Subst.compress - t in - uu___11.FStar_Syntax_Syntax.n in - (match uu___10 - with - | FStar_Syntax_Syntax.Tm_name - bv -> - FStar_Pervasives_Native.Some - bv - | uu___11 -> - FStar_Pervasives_Native.None)) - (FStar_Compiler_List.rev - arg_rets_rev) in - let push_option_names_to_env - = - FStar_Compiler_List.fold_left - (fun env1 -> - fun name_opt -> - let uu___8 = - FStar_Compiler_Util.map_option - (FStar_TypeChecker_Env.push_bv - env1) - name_opt in - FStar_Compiler_Util.dflt - env1 uu___8) in - let uu___8 = - FStar_Compiler_List.fold_left - (fun uu___9 -> - fun uu___10 -> - match (uu___9, - uu___10) - with - | ((i, out_c), - ((e, q), x, c)) - -> - ((let uu___12 = - FStar_Compiler_Debug.extreme - () in - if uu___12 - then - let uu___13 - = - match x - with - | - FStar_Pervasives_Native.None - -> "_" - | - FStar_Pervasives_Native.Some - x1 -> - FStar_Class_Show.show - FStar_Syntax_Print.showable_bv - x1 in - let uu___14 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - e in - let uu___15 - = - FStar_TypeChecker_Common.lcomp_to_string - c in - FStar_Compiler_Util.print3 - "(b) Monadic app: Binding argument %s : %s of type (%s)\n" - uu___13 - uu___14 - uu___15 - else ()); - (let env1 = - if - inserted_return_in_cres - then - let uu___12 - = - let uu___13 - = - FStar_Compiler_List.splitAt - ((FStar_Compiler_List.length - arg_rets_names_opt) - - i) - arg_rets_names_opt in - FStar_Pervasives_Native.fst - uu___13 in - push_option_names_to_env - env - uu___12 - else env in - let uu___12 = - FStar_TypeChecker_Common.is_pure_or_ghost_lcomp - c in - if uu___12 - then - let uu___13 - = - FStar_TypeChecker_Util.bind - e.FStar_Syntax_Syntax.pos - env1 - (FStar_Pervasives_Native.Some - e) c - (x, - out_c) in - ((i + - Prims.int_one), - uu___13) - else - (let uu___14 - = - FStar_TypeChecker_Util.bind - e.FStar_Syntax_Syntax.pos - env1 - FStar_Pervasives_Native.None - c - (x, - out_c) in - ((i + - Prims.int_one), - uu___14))))) - (Prims.int_one, cres4) - arg_comps_rev in - match uu___8 with - | (uu___9, comp1) -> - let env1 = - push_option_names_to_env - env - arg_rets_names_opt in - ((let uu___11 = - FStar_Compiler_Debug.extreme - () in - if uu___11 - then - let uu___12 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - head1 in - let uu___13 = - FStar_TypeChecker_Common.lcomp_to_string - chead2 in - FStar_Compiler_Util.print2 - "(c) Monadic app: Binding head %s, chead: %s\n" - uu___12 uu___13 - else ()); - (let uu___11 = - FStar_TypeChecker_Common.is_pure_or_ghost_lcomp - chead2 in - if uu___11 - then - FStar_TypeChecker_Util.bind - head1.FStar_Syntax_Syntax.pos - env1 - (FStar_Pervasives_Native.Some - head1) chead2 - (FStar_Pervasives_Native.None, - comp1) - else - FStar_TypeChecker_Util.bind - head1.FStar_Syntax_Syntax.pos - env1 - FStar_Pervasives_Native.None - chead2 - (FStar_Pervasives_Native.None, - comp1))) in - let shortcuts_evaluation_order - = - let uu___8 = - let uu___9 = - FStar_Syntax_Subst.compress - head1 in - uu___9.FStar_Syntax_Syntax.n in - match uu___8 with - | FStar_Syntax_Syntax.Tm_fvar - fv -> - (FStar_Syntax_Syntax.fv_eq_lid - fv - FStar_Parser_Const.op_And) - || - (FStar_Syntax_Syntax.fv_eq_lid - fv - FStar_Parser_Const.op_Or) - | uu___9 -> false in - let app = - if - shortcuts_evaluation_order - then - let args1 = - FStar_Compiler_List.fold_left - (fun args2 -> - fun uu___8 -> - match uu___8 with - | (arg, uu___9, - uu___10) -> - arg :: args2) - [] arg_comps_rev in - let app1 = - FStar_Syntax_Syntax.mk_Tm_app - head1 args1 r in - let app2 = - FStar_TypeChecker_Util.maybe_lift - env app1 - cres4.FStar_TypeChecker_Common.eff_name - comp.FStar_TypeChecker_Common.eff_name - comp.FStar_TypeChecker_Common.res_typ in - FStar_TypeChecker_Util.maybe_monadic - env app2 - comp.FStar_TypeChecker_Common.eff_name - comp.FStar_TypeChecker_Common.res_typ - else - (let uu___9 = - let map_fun uu___10 = - match uu___10 with - | ((e, q), uu___11, - c) -> - ((let uu___13 = - FStar_Compiler_Debug.extreme - () in - if uu___13 - then - let uu___14 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - e in - let uu___15 = - FStar_TypeChecker_Common.lcomp_to_string - c in - FStar_Compiler_Util.print2 - "For arg e=(%s) c=(%s)... " - uu___14 - uu___15 - else ()); - (let uu___13 = - FStar_TypeChecker_Common.is_pure_or_ghost_lcomp - c in - if uu___13 - then - ((let uu___15 - = - FStar_Compiler_Debug.extreme - () in - if uu___15 - then - FStar_Compiler_Util.print_string - "... not lifting\n" - else ()); - (FStar_Pervasives_Native.None, - (e, q))) - else - (let warn_effectful_args - = - (FStar_TypeChecker_Util.must_erase_for_extraction - env - chead2.FStar_TypeChecker_Common.res_typ) - && - (let uu___15 - = - let uu___16 - = - let uu___17 - = - FStar_Syntax_Util.un_uinst - head1 in - uu___17.FStar_Syntax_Syntax.n in - match uu___16 - with - | - FStar_Syntax_Syntax.Tm_fvar - fv -> - let uu___17 - = - FStar_Parser_Const.psconst - "ignore" in - FStar_Syntax_Syntax.fv_eq_lid - fv - uu___17 - | - uu___17 - -> true in - Prims.op_Negation - uu___15) in - if - warn_effectful_args - then - (let uu___16 - = - let uu___17 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - e in - let uu___18 - = - FStar_Class_Show.show - FStar_Ident.showable_lident - c.FStar_TypeChecker_Common.eff_name in - let uu___19 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - head1 in - FStar_Compiler_Util.format3 - "Effectful argument %s (%s) to erased function %s, consider let binding it" - uu___17 - uu___18 - uu___19 in - FStar_Errors.log_issue - (FStar_Syntax_Syntax.has_range_syntax - ()) e - FStar_Errors_Codes.Warning_EffectfulArgumentToErasedFunction - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - uu___16)) - else (); - (let uu___17 - = - FStar_Compiler_Debug.extreme - () in - if uu___17 - then - FStar_Compiler_Util.print_string - "... lifting!\n" - else ()); - (let x = - FStar_Syntax_Syntax.new_bv - FStar_Pervasives_Native.None - c.FStar_TypeChecker_Common.res_typ in - let e1 = - FStar_TypeChecker_Util.maybe_lift - env e - c.FStar_TypeChecker_Common.eff_name - comp.FStar_TypeChecker_Common.eff_name - c.FStar_TypeChecker_Common.res_typ in - let uu___17 - = - let uu___18 - = - FStar_Syntax_Syntax.bv_to_name - x in - (uu___18, - q) in - ((FStar_Pervasives_Native.Some - (x, - (c.FStar_TypeChecker_Common.eff_name), - (c.FStar_TypeChecker_Common.res_typ), - e1)), - uu___17))))) in - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - let uu___14 = - FStar_Syntax_Syntax.as_arg - head1 in - (uu___14, - FStar_Pervasives_Native.None, - chead2) in - uu___13 :: - arg_comps_rev in - FStar_Compiler_List.map - map_fun uu___12 in - FStar_Compiler_List.split - uu___11 in - match uu___10 with - | (lifted_args, - reverse_args) -> - let uu___11 = - let uu___12 = - FStar_Compiler_List.hd - reverse_args in - FStar_Pervasives_Native.fst - uu___12 in - let uu___12 = - let uu___13 = - FStar_Compiler_List.tl - reverse_args in - FStar_Compiler_List.rev - uu___13 in - (lifted_args, - uu___11, uu___12) in - match uu___9 with - | (lifted_args, head2, - args1) -> - let app1 = - FStar_Syntax_Syntax.mk_Tm_app - head2 args1 r in - let app2 = - FStar_TypeChecker_Util.maybe_lift - env app1 - cres4.FStar_TypeChecker_Common.eff_name - comp.FStar_TypeChecker_Common.eff_name - comp.FStar_TypeChecker_Common.res_typ in - let app3 = - FStar_TypeChecker_Util.maybe_monadic - env app2 - comp.FStar_TypeChecker_Common.eff_name - comp.FStar_TypeChecker_Common.res_typ in - let bind_lifted_args - e uu___10 = - match uu___10 with - | FStar_Pervasives_Native.None - -> e - | FStar_Pervasives_Native.Some - (x, m, t, e1) - -> - let lb = - FStar_Syntax_Util.mk_letbinding - (FStar_Pervasives.Inl - x) [] t m - e1 [] - e1.FStar_Syntax_Syntax.pos in - let letbinding - = - let uu___11 = - let uu___12 - = - let uu___13 - = - let uu___14 - = - let uu___15 - = - FStar_Syntax_Syntax.mk_binder - x in - [uu___15] in - FStar_Syntax_Subst.close - uu___14 e in - { - FStar_Syntax_Syntax.lbs - = - (false, - [lb]); - FStar_Syntax_Syntax.body1 - = uu___13 - } in - FStar_Syntax_Syntax.Tm_let - uu___12 in - FStar_Syntax_Syntax.mk - uu___11 - e.FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 - = - letbinding; - FStar_Syntax_Syntax.meta - = - (FStar_Syntax_Syntax.Meta_monadic - (m, - (comp.FStar_TypeChecker_Common.res_typ))) - }) - e.FStar_Syntax_Syntax.pos in - FStar_Compiler_List.fold_left - bind_lifted_args - app3 lifted_args) in - let uu___8 = - FStar_TypeChecker_Util.strengthen_precondition - FStar_Pervasives_Native.None - env app comp guard2 in - (match uu___8 with - | (comp1, g) -> - ((let uu___10 = - FStar_Compiler_Debug.extreme - () in - if uu___10 - then - let uu___11 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - app in - let uu___12 = - FStar_TypeChecker_Common.lcomp_to_string - comp1 in - FStar_Compiler_Util.print2 - "(d) Monadic app: type of app\n\t(%s)\n\t: %s\n" - uu___11 uu___12 - else ()); - (app, comp1, g))))))))) in - let rec tc_args head_info uu___1 bs args1 = - match uu___1 with - | (subst, outargs, arg_rets, g, fvs) -> - let instantiate_one_and_go b rest_bs args2 = - let r1 = - match outargs with - | [] -> head.FStar_Syntax_Syntax.pos - | ((t, uu___2), uu___3, uu___4)::uu___5 -> - let uu___6 = - FStar_Compiler_Range_Type.def_range - head.FStar_Syntax_Syntax.pos in - let uu___7 = - let uu___8 = - FStar_Compiler_Range_Type.use_range - head.FStar_Syntax_Syntax.pos in - let uu___9 = - FStar_Compiler_Range_Type.use_range - t.FStar_Syntax_Syntax.pos in - FStar_Compiler_Range_Ops.union_rng uu___8 - uu___9 in - FStar_Compiler_Range_Type.range_of_rng uu___6 - uu___7 in - let b1 = FStar_Syntax_Subst.subst_binder subst b in - let uu___2 = - FStar_TypeChecker_Util.instantiate_one_binder env r1 - b1 in - match uu___2 with - | (tm, ty, aq, g') -> - let uu___3 = - check_no_escape - (FStar_Pervasives_Native.Some head) env fvs ty in - (match uu___3 with - | (ty1, g_ex) -> - let guard = - let uu___4 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g g' in - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - uu___4 g_ex in - let arg = (tm, aq) in - let subst1 = - (FStar_Syntax_Syntax.NT - ((b1.FStar_Syntax_Syntax.binder_bv), tm)) - :: subst in - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Syntax_Syntax.mk_Total ty1 in - FStar_TypeChecker_Common.lcomp_of_comp - uu___8 in - (arg, FStar_Pervasives_Native.None, - uu___7) in - uu___6 :: outargs in - (subst1, uu___5, (arg :: arg_rets), guard, - fvs) in - tc_args head_info uu___4 rest_bs args2) in - (match (bs, args1) with - | ({ FStar_Syntax_Syntax.binder_bv = x; - FStar_Syntax_Syntax.binder_qual = - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Implicit uu___2); - FStar_Syntax_Syntax.binder_positivity = uu___3; - FStar_Syntax_Syntax.binder_attrs = uu___4;_}::rest, - (uu___5, FStar_Pervasives_Native.None)::uu___6) -> - let uu___7 = FStar_Compiler_List.hd bs in - instantiate_one_and_go uu___7 rest args1 - | ({ FStar_Syntax_Syntax.binder_bv = x; - FStar_Syntax_Syntax.binder_qual = - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Meta uu___2); - FStar_Syntax_Syntax.binder_positivity = uu___3; - FStar_Syntax_Syntax.binder_attrs = uu___4;_}::rest, - (uu___5, FStar_Pervasives_Native.None)::uu___6) -> - let uu___7 = FStar_Compiler_List.hd bs in - instantiate_one_and_go uu___7 rest args1 - | ({ FStar_Syntax_Syntax.binder_bv = x; - FStar_Syntax_Syntax.binder_qual = - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Meta tau); - FStar_Syntax_Syntax.binder_positivity = uu___2; - FStar_Syntax_Syntax.binder_attrs = b_attrs;_}::rest, - ({ - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_unknown; - FStar_Syntax_Syntax.pos = uu___3; - FStar_Syntax_Syntax.vars = uu___4; - FStar_Syntax_Syntax.hash_code = uu___5;_}, - FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = uu___6;_})::rest') - -> - let uu___7 = FStar_Compiler_List.hd bs in - instantiate_one_and_go uu___7 rest rest' - | ({ FStar_Syntax_Syntax.binder_bv = x; - FStar_Syntax_Syntax.binder_qual = bqual; - FStar_Syntax_Syntax.binder_positivity = uu___2; - FStar_Syntax_Syntax.binder_attrs = b_attrs;_}::rest, - (e, aq)::rest') -> - let aq1 = - let uu___3 = FStar_Compiler_List.hd bs in - check_expected_aqual_for_binder aq uu___3 - e.FStar_Syntax_Syntax.pos in - let targ = - FStar_Syntax_Subst.subst subst - x.FStar_Syntax_Syntax.sort in - let bqual1 = - FStar_Syntax_Subst.subst_bqual subst bqual in - let x1 = - { - FStar_Syntax_Syntax.ppname = - (x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (x.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = targ - } in - ((let uu___4 = FStar_Compiler_Debug.extreme () in - if uu___4 - then - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_bv x1 in - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - x1.FStar_Syntax_Syntax.sort in - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term e in - let uu___8 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_subst_elt) - subst in - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term targ in - FStar_Compiler_Util.print5 - "\tFormal is %s : %s\tType of arg %s (after subst %s) = %s\n" - uu___5 uu___6 uu___7 uu___8 uu___9 - else ()); - (let uu___4 = - check_no_escape - (FStar_Pervasives_Native.Some head) env fvs - targ in - match uu___4 with - | (targ1, g_ex) -> - let env1 = - FStar_TypeChecker_Env.set_expected_typ_maybe_eq - env targ1 (is_eq bqual1) in - ((let uu___6 = FStar_Compiler_Debug.high () in - if uu___6 - then - let uu___7 = - FStar_Class_Tagged.tag_of - FStar_Syntax_Syntax.tagged_term e in - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term e in - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - targ1 in - let uu___10 = - FStar_Compiler_Util.string_of_bool - (is_eq bqual1) in - FStar_Compiler_Util.print4 - "Checking arg (%s) %s at type %s with use_eq:%s\n" - uu___7 uu___8 uu___9 uu___10 - else ()); - (let uu___6 = tc_term env1 e in - match uu___6 with - | (e1, c, g_e) -> - let g1 = - let uu___7 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g_ex g in - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - uu___7 g_e in - let arg = (e1, aq1) in - let xterm = - let uu___7 = - FStar_Syntax_Syntax.bv_to_name x1 in - (uu___7, aq1) in - let uu___7 = - (FStar_TypeChecker_Common.is_tot_or_gtot_lcomp - c) - || - (FStar_TypeChecker_Util.is_pure_or_ghost_effect - env1 - c.FStar_TypeChecker_Common.eff_name) in - if uu___7 - then - let subst1 = - let uu___8 = - FStar_Compiler_List.hd bs in - maybe_extend_subst subst uu___8 e1 in - tc_args head_info - (subst1, - ((arg, - (FStar_Pervasives_Native.Some - x1), c) :: outargs), (xterm - :: arg_rets), g1, fvs) rest rest' - else - tc_args head_info - (subst, - ((arg, - (FStar_Pervasives_Native.Some - x1), c) :: outargs), (xterm - :: arg_rets), g1, (x1 :: fvs)) - rest rest')))) - | (uu___2, []) -> - monadic_application head_info subst outargs - arg_rets g fvs bs - | ([], arg::uu___2) -> - let uu___3 = - monadic_application head_info subst outargs - arg_rets g fvs [] in - (match uu___3 with - | (head1, chead1, ghead1) -> - let uu___4 = - let uu___5 = - FStar_TypeChecker_Common.lcomp_comp chead1 in - match uu___5 with - | (c, g1) -> - let uu___6 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - ghead1 g1 in - (c, uu___6) in - (match uu___4 with - | (chead2, ghead2) -> - let rec aux norm1 solve ghead3 tres = - let tres1 = - let uu___5 = - let uu___6 = - FStar_Syntax_Subst.compress tres in - FStar_Syntax_Util.unrefine uu___6 in - FStar_Syntax_Util.unmeta_safe uu___5 in - match tres1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs1; - FStar_Syntax_Syntax.comp = cres';_} - -> - let uu___5 = - FStar_Syntax_Subst.open_comp bs1 - cres' in - (match uu___5 with - | (bs2, cres'1) -> - let head_info1 = - (head1, chead2, ghead3, - cres'1) in - ((let uu___7 = - FStar_Compiler_Debug.low - () in - if uu___7 - then - FStar_Errors.log_issue - (FStar_Syntax_Syntax.has_range_syntax - ()) tres1 - FStar_Errors_Codes.Warning_RedundantExplicitCurrying - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Potentially redundant explicit currying of a function type") - else ()); - tc_args head_info1 - ([], [], [], - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t), - []) bs2 args1)) - | uu___5 when Prims.op_Negation norm1 - -> - let rec norm_tres tres2 = - let tres3 = - let uu___6 = - FStar_TypeChecker_Normalize.unfold_whnf - env tres2 in - FStar_Syntax_Util.unascribe - uu___6 in - let uu___6 = - let uu___7 = - FStar_Syntax_Subst.compress - tres3 in - uu___7.FStar_Syntax_Syntax.n in - match uu___6 with - | FStar_Syntax_Syntax.Tm_refine - { - FStar_Syntax_Syntax.b = - { - FStar_Syntax_Syntax.ppname - = uu___7; - FStar_Syntax_Syntax.index - = uu___8; - FStar_Syntax_Syntax.sort - = tres4;_}; - FStar_Syntax_Syntax.phi = - uu___9;_} - -> norm_tres tres4 - | uu___7 -> tres3 in - let uu___6 = norm_tres tres1 in - aux true solve ghead3 uu___6 - | uu___5 when Prims.op_Negation solve - -> - let ghead4 = - FStar_TypeChecker_Rel.solve_deferred_constraints - env ghead3 in - aux norm1 true ghead4 tres1 - | uu___5 -> - let uu___6 = - FStar_Syntax_Syntax.argpos arg in - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Errors_Msg.text - "Too many arguments to function of type" in - let uu___10 = - FStar_Class_PP.pp - FStar_Syntax_Print.pretty_term - thead in - FStar_Pprint.prefix - (Prims.of_int (4)) - Prims.int_one uu___9 uu___10 in - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Errors_Msg.text "Got" in - let uu___12 = - let uu___13 = - FStar_Class_PP.pp - FStar_Class_PP.pp_int - n_args in - let uu___14 = - FStar_Errors_Msg.text - "arguments" in - FStar_Pprint.op_Hat_Slash_Hat - uu___13 uu___14 in - FStar_Pprint.op_Hat_Slash_Hat - uu___11 uu___12 in - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Errors_Msg.text - "Remaining type is" in - let uu___14 = - FStar_Class_PP.pp - FStar_Syntax_Print.pretty_term - tres1 in - FStar_Pprint.prefix - (Prims.of_int (4)) - Prims.int_one uu___13 - uu___14 in - [uu___12] in - uu___10 :: uu___11 in - uu___8 :: uu___9 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - uu___6 - FStar_Errors_Codes.Fatal_ToManyArgumentToFunction - () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___7) in - aux false false ghead2 - (FStar_Syntax_Util.comp_result chead2)))) in - let rec check_function_app tf guard = - let tf1 = FStar_TypeChecker_Normalize.unfold_whnf env tf in - let uu___1 = - let uu___2 = FStar_Syntax_Util.unmeta tf1 in - uu___2.FStar_Syntax_Syntax.n in - match uu___1 with - | FStar_Syntax_Syntax.Tm_uvar uu___2 -> - let uu___3 = - FStar_Compiler_List.fold_right - (fun uu___4 -> - fun uu___5 -> - match uu___5 with - | (bs, guard1) -> - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Syntax_Util.type_u () in - FStar_Pervasives_Native.fst uu___8 in - FStar_TypeChecker_Util.new_implicit_var - "formal parameter" - tf1.FStar_Syntax_Syntax.pos env uu___7 - false in - (match uu___6 with - | (t, uu___7, g) -> - let uu___8 = - let uu___9 = - FStar_Syntax_Syntax.null_binder t in - uu___9 :: bs in - let uu___9 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g guard1 in - (uu___8, uu___9))) args ([], guard) in - (match uu___3 with - | (bs, guard1) -> - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = FStar_Syntax_Util.type_u () in - FStar_Pervasives_Native.fst uu___7 in - FStar_TypeChecker_Util.new_implicit_var - "result type" tf1.FStar_Syntax_Syntax.pos env - uu___6 false in - match uu___5 with - | (t, uu___6, g) -> - let uu___7 = FStar_Options.ml_ish () in - if uu___7 - then - let uu___8 = FStar_Syntax_Util.ml_comp t r in - let uu___9 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - guard1 g in - (uu___8, uu___9) - else - (let uu___9 = - FStar_Syntax_Syntax.mk_Total t in - let uu___10 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - guard1 g in - (uu___9, uu___10)) in - (match uu___4 with - | (cres, guard2) -> - let bs_cres = FStar_Syntax_Util.arrow bs cres in - ((let uu___6 = FStar_Compiler_Debug.extreme () in - if uu___6 - then - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head in - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term tf1 in - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - bs_cres in - FStar_Compiler_Util.print3 - "Forcing the type of %s from %s to %s\n" - uu___7 uu___8 uu___9 - else ()); - (let g = - let uu___6 = - FStar_TypeChecker_Rel.teq env tf1 - bs_cres in - FStar_TypeChecker_Rel.solve_deferred_constraints - env uu___6 in - let uu___6 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g guard2 in - check_function_app bs_cres uu___6)))) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_uvar uu___2; - FStar_Syntax_Syntax.pos = uu___3; - FStar_Syntax_Syntax.vars = uu___4; - FStar_Syntax_Syntax.hash_code = uu___5;_}; - FStar_Syntax_Syntax.args = uu___6;_} - -> - let uu___7 = - FStar_Compiler_List.fold_right - (fun uu___8 -> - fun uu___9 -> - match uu___9 with - | (bs, guard1) -> - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Syntax_Util.type_u () in - FStar_Pervasives_Native.fst uu___12 in - FStar_TypeChecker_Util.new_implicit_var - "formal parameter" - tf1.FStar_Syntax_Syntax.pos env uu___11 - false in - (match uu___10 with - | (t, uu___11, g) -> - let uu___12 = - let uu___13 = - FStar_Syntax_Syntax.null_binder t in - uu___13 :: bs in - let uu___13 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g guard1 in - (uu___12, uu___13))) args ([], guard) in - (match uu___7 with - | (bs, guard1) -> - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = FStar_Syntax_Util.type_u () in - FStar_Pervasives_Native.fst uu___11 in - FStar_TypeChecker_Util.new_implicit_var - "result type" tf1.FStar_Syntax_Syntax.pos env - uu___10 false in - match uu___9 with - | (t, uu___10, g) -> - let uu___11 = FStar_Options.ml_ish () in - if uu___11 - then - let uu___12 = FStar_Syntax_Util.ml_comp t r in - let uu___13 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - guard1 g in - (uu___12, uu___13) - else - (let uu___13 = - FStar_Syntax_Syntax.mk_Total t in - let uu___14 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - guard1 g in - (uu___13, uu___14)) in - (match uu___8 with - | (cres, guard2) -> - let bs_cres = FStar_Syntax_Util.arrow bs cres in - ((let uu___10 = - FStar_Compiler_Debug.extreme () in - if uu___10 - then - let uu___11 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head in - let uu___12 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term tf1 in - let uu___13 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - bs_cres in - FStar_Compiler_Util.print3 - "Forcing the type of %s from %s to %s\n" - uu___11 uu___12 uu___13 - else ()); - (let g = - let uu___10 = - FStar_TypeChecker_Rel.teq env tf1 - bs_cres in - FStar_TypeChecker_Rel.solve_deferred_constraints - env uu___10 in - let uu___10 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g guard2 in - check_function_app bs_cres uu___10)))) - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; - FStar_Syntax_Syntax.comp = c;_} - -> - let uu___2 = FStar_Syntax_Subst.open_comp bs c in - (match uu___2 with - | (bs1, c1) -> - let head_info = (head, chead, ghead, c1) in - ((let uu___4 = FStar_Compiler_Debug.extreme () in - if uu___4 - then - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head in - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term tf1 in - let uu___7 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_binder) bs1 in - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_comp c1 in - FStar_Compiler_Util.print4 - "######tc_args of head %s @ %s with formals=%s and result type=%s\n" - uu___5 uu___6 uu___7 uu___8 - else ()); - tc_args head_info ([], [], [], guard, []) bs1 args)) - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = bv; - FStar_Syntax_Syntax.phi = uu___2;_} - -> check_function_app bv.FStar_Syntax_Syntax.sort guard - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t; - FStar_Syntax_Syntax.asc = uu___2; - FStar_Syntax_Syntax.eff_opt = uu___3;_} - -> check_function_app t guard - | uu___2 -> - FStar_TypeChecker_Err.expected_function_typ env - head.FStar_Syntax_Syntax.pos tf1 in - check_function_app thead - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t)) -and (check_short_circuit_args : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.comp -> - FStar_TypeChecker_Env.guard_t -> - (FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) - Prims.list -> - (FStar_Syntax_Syntax.typ * Prims.bool) - FStar_Pervasives_Native.option -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.lcomp * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun head -> - fun chead -> - fun g_head -> - fun args -> - fun expected_topt -> - let r = FStar_TypeChecker_Env.get_range env in - let tf = - FStar_Syntax_Subst.compress - (FStar_Syntax_Util.comp_result chead) in - match tf.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; - FStar_Syntax_Syntax.comp = c;_} - when - (FStar_Syntax_Util.is_total_comp c) && - ((FStar_Compiler_List.length bs) = - (FStar_Compiler_List.length args)) - -> - let res_t = FStar_Syntax_Util.comp_result c in - let uu___ = - FStar_Compiler_List.fold_left2 - (fun uu___1 -> - fun uu___2 -> - fun b -> - match (uu___1, uu___2) with - | ((seen, guard, ghost), (e, aq)) -> - let aq1 = - check_expected_aqual_for_binder aq b - e.FStar_Syntax_Syntax.pos in - let uu___3 = - tc_check_tot_or_gtot_term env e - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort - (FStar_Pervasives_Native.Some - "arguments to short circuiting operators must be pure or ghost") in - (match uu___3 with - | (e1, c1, g) -> - let short = - FStar_TypeChecker_Util.short_circuit - head seen in - let g1 = - let uu___4 = - FStar_TypeChecker_Env.guard_of_guard_formula - short in - FStar_TypeChecker_Env.imp_guard - uu___4 g in - let ghost1 = - ghost || - ((let uu___4 = - FStar_TypeChecker_Common.is_total_lcomp - c1 in - Prims.op_Negation uu___4) && - (let uu___4 = - FStar_TypeChecker_Util.is_pure_effect - env - c1.FStar_TypeChecker_Common.eff_name in - Prims.op_Negation uu___4)) in - let uu___4 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - guard g1 in - ((FStar_Compiler_List.op_At seen - [(e1, aq1)]), uu___4, ghost1))) - ([], g_head, false) args bs in - (match uu___ with - | (args1, guard, ghost) -> - let e = FStar_Syntax_Syntax.mk_Tm_app head args1 r in - let c1 = - if ghost - then - let uu___1 = FStar_Syntax_Syntax.mk_GTotal res_t in - FStar_TypeChecker_Common.lcomp_of_comp uu___1 - else FStar_TypeChecker_Common.lcomp_of_comp c in - let uu___1 = - FStar_TypeChecker_Util.strengthen_precondition - FStar_Pervasives_Native.None env e c1 guard in - (match uu___1 with | (c2, g) -> (e, c2, g))) - | uu___ -> - check_application_args env head chead g_head args - expected_topt -and (tc_pat : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.pat -> - (FStar_Syntax_Syntax.pat * FStar_Syntax_Syntax.bv Prims.list * - FStar_Syntax_Syntax.term Prims.list * FStar_TypeChecker_Env.env * - FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.term * - FStar_TypeChecker_Env.guard_t * Prims.bool)) - = - fun env -> - fun pat_t -> - fun p0 -> - let fail msg = - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range - p0.FStar_Syntax_Syntax.p - FStar_Errors_Codes.Fatal_MismatchedPatternType () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic msg) in - let expected_pat_typ env1 pos scrutinee_t = - let rec aux norm1 t = - let t1 = FStar_Syntax_Util.unrefine t in - let uu___ = FStar_Syntax_Util.head_and_args t1 in - match uu___ with - | (head, args) -> - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress head in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_uinst - ({ - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar f; - FStar_Syntax_Syntax.pos = uu___2; - FStar_Syntax_Syntax.vars = uu___3; - FStar_Syntax_Syntax.hash_code = uu___4;_}, - us) - -> unfold_once t1 f us args - | FStar_Syntax_Syntax.Tm_fvar f -> unfold_once t1 f [] args - | uu___2 -> - if norm1 - then t1 - else - (let uu___4 = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.HNF; - FStar_TypeChecker_Env.Unmeta; - FStar_TypeChecker_Env.Unascribe; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant] env1 t1 in - aux true uu___4)) - and unfold_once t f us args = - let uu___ = - FStar_TypeChecker_Env.is_type_constructor env1 - (f.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - if uu___ - then t - else - (let uu___2 = - FStar_TypeChecker_Env.lookup_definition - [FStar_TypeChecker_Env.Unfold - FStar_Syntax_Syntax.delta_constant] env1 - (f.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - match uu___2 with - | FStar_Pervasives_Native.None -> t - | FStar_Pervasives_Native.Some head_def_ts -> - let uu___3 = - FStar_TypeChecker_Env.inst_tscheme_with head_def_ts us in - (match uu___3 with - | (uu___4, head_def) -> - let t' = - FStar_Syntax_Syntax.mk_Tm_app head_def args - t.FStar_Syntax_Syntax.pos in - let t'1 = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Iota] env1 t' in - aux false t'1)) in - let uu___ = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Beta; FStar_TypeChecker_Env.Iota] env1 - scrutinee_t in - aux false uu___ in - let pat_typ_ok env1 pat_t1 scrutinee_t = - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_Patterns in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term pat_t1 in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - scrutinee_t in - FStar_Compiler_Util.print2 "$$$$$$$$$$$$pat_typ_ok? %s vs. %s\n" - uu___2 uu___3 - else ()); - FStar_Defensive.def_check_scoped - FStar_TypeChecker_Env.hasBinders_env - FStar_Class_Binders.hasNames_term FStar_Syntax_Print.pretty_term - pat_t1.FStar_Syntax_Syntax.pos "pat_typ_ok.pat_t.entry" env1 - pat_t1; - (let fail1 msg_str = - let msg = - if msg_str = "" - then [] - else (let uu___3 = FStar_Errors_Msg.text msg_str in [uu___3]) in - let msg1 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Errors_Msg.text "Type of pattern" in - let uu___5 = - FStar_Class_PP.pp FStar_Syntax_Print.pretty_term pat_t1 in - FStar_Pprint.prefix (Prims.of_int (2)) Prims.int_one - uu___4 uu___5 in - let uu___4 = - let uu___5 = - FStar_Errors_Msg.text "does not match type of scrutinee" in - let uu___6 = - FStar_Class_PP.pp FStar_Syntax_Print.pretty_term - scrutinee_t in - FStar_Pprint.prefix (Prims.of_int (2)) Prims.int_one - uu___5 uu___6 in - FStar_Pprint.op_Hat_Slash_Hat uu___3 uu___4 in - uu___2 :: msg in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range - p0.FStar_Syntax_Syntax.p - FStar_Errors_Codes.Fatal_MismatchedPatternType () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic msg1) in - let uu___2 = FStar_Syntax_Util.head_and_args scrutinee_t in - match uu___2 with - | (head_s, args_s) -> - let pat_t2 = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Beta] env1 pat_t1 in - let uu___3 = FStar_Syntax_Util.un_uinst head_s in - (match uu___3 with - | { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar - uu___4; - FStar_Syntax_Syntax.pos = uu___5; - FStar_Syntax_Syntax.vars = uu___6; - FStar_Syntax_Syntax.hash_code = uu___7;_} -> - let uu___8 = FStar_Syntax_Util.head_and_args pat_t2 in - (match uu___8 with - | (head_p, args_p) -> - let uu___9 = - FStar_TypeChecker_Rel.teq_nosmt_force env1 head_p - head_s in - if uu___9 - then - let uu___10 = - let uu___11 = FStar_Syntax_Util.un_uinst head_p in - uu___11.FStar_Syntax_Syntax.n in - (match uu___10 with - | FStar_Syntax_Syntax.Tm_fvar f -> - ((let uu___12 = - let uu___13 = - let uu___14 = - FStar_Syntax_Syntax.lid_of_fv f in - FStar_TypeChecker_Env.is_type_constructor - env1 uu___14 in - Prims.op_Negation uu___13 in - if uu___12 - then - fail1 - "Pattern matching a non-inductive type" - else ()); - if - (FStar_Compiler_List.length args_p) <> - (FStar_Compiler_List.length args_s) - then fail1 "" - else (); - (let uu___13 = - let uu___14 = - let uu___15 = - FStar_Syntax_Syntax.lid_of_fv f in - FStar_TypeChecker_Env.num_inductive_ty_params - env1 uu___15 in - match uu___14 with - | FStar_Pervasives_Native.None -> - (args_p, args_s) - | FStar_Pervasives_Native.Some n -> - let uu___15 = - FStar_Compiler_Util.first_N n - args_p in - (match uu___15 with - | (params_p, uu___16) -> - let uu___17 = - FStar_Compiler_Util.first_N n - args_s in - (match uu___17 with - | (params_s, uu___18) -> - (params_p, params_s))) in - match uu___13 with - | (params_p, params_s) -> - FStar_Compiler_List.fold_left2 - (fun out -> - fun uu___14 -> - fun uu___15 -> - match (uu___14, uu___15) with - | ((p, uu___16), (s, uu___17)) - -> - let uu___18 = - FStar_TypeChecker_Rel.teq_nosmt - env1 p s in - (match uu___18 with - | FStar_Pervasives_Native.None - -> - let uu___19 = - let uu___20 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - p in - let uu___21 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - s in - FStar_Compiler_Util.format2 - "Parameter %s <> Parameter %s" - uu___20 uu___21 in - fail1 uu___19 - | FStar_Pervasives_Native.Some - g -> - let g1 = - FStar_TypeChecker_Rel.discharge_guard_no_smt - env1 g in - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g1 out)) - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t) - params_p params_s)) - | uu___11 -> - fail1 "Pattern matching a non-inductive type") - else - (let uu___11 = - let uu___12 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head_p in - let uu___13 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term head_s in - FStar_Compiler_Util.format2 - "Head mismatch %s vs %s" uu___12 uu___13 in - fail1 uu___11)) - | uu___4 -> - let uu___5 = - FStar_TypeChecker_Rel.teq_nosmt env1 pat_t2 scrutinee_t in - (match uu___5 with - | FStar_Pervasives_Native.None -> fail1 "" - | FStar_Pervasives_Native.Some g -> - let g1 = - FStar_TypeChecker_Rel.discharge_guard_no_smt env1 - g in - g1))) in - let type_of_simple_pat env1 e = - let uu___ = FStar_Syntax_Util.head_and_args e in - match uu___ with - | (head, args) -> - (match head.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_uinst - ({ - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar - uu___1; - FStar_Syntax_Syntax.pos = uu___2; - FStar_Syntax_Syntax.vars = uu___3; - FStar_Syntax_Syntax.hash_code = uu___4;_}, - uu___5) - -> - let uu___6 = - match head.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_uinst (head1, us) -> - let uu___7 = head1.FStar_Syntax_Syntax.n in - (match uu___7 with - | FStar_Syntax_Syntax.Tm_fvar f -> - let res = - FStar_TypeChecker_Env.try_lookup_and_inst_lid - env1 us - (f.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - (match res with - | FStar_Pervasives_Native.Some (t, uu___8) - when - FStar_TypeChecker_Env.is_datacon env1 - (f.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - -> (head1, (us, t)) - | uu___8 -> - let uu___9 = - let uu___10 = - FStar_Ident.string_of_lid - (f.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - FStar_Compiler_Util.format1 - "Could not find constructor: %s" - uu___10 in - fail uu___9)) - | FStar_Syntax_Syntax.Tm_fvar f -> - let uu___7 = - FStar_TypeChecker_Env.lookup_datacon env1 - (f.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - (head, uu___7) in - (match uu___6 with - | (head1, (us, t_f)) -> - let uu___7 = FStar_Syntax_Util.arrow_formals t_f in - (match uu___7 with - | (formals, t) -> - let erasable = - FStar_TypeChecker_Env.non_informative env1 t in - (if - (FStar_Compiler_List.length formals) <> - (FStar_Compiler_List.length args) - then - fail - "Pattern is not a fully-applied data constructor" - else (); - (let rec aux uu___9 formals1 args1 = - match uu___9 with - | (subst, args_out, bvs, guard) -> - (match (formals1, args1) with - | ([], []) -> - let head2 = - FStar_Syntax_Syntax.mk_Tm_uinst - head1 us in - let pat_e = - FStar_Syntax_Syntax.mk_Tm_app - head2 args_out - e.FStar_Syntax_Syntax.pos in - let uu___10 = - FStar_Syntax_Subst.subst subst t in - (pat_e, uu___10, bvs, guard, - erasable) - | ({ FStar_Syntax_Syntax.binder_bv = f; - FStar_Syntax_Syntax.binder_qual = - uu___10; - FStar_Syntax_Syntax.binder_positivity - = uu___11; - FStar_Syntax_Syntax.binder_attrs = - uu___12;_}::formals2, - (a, imp_a)::args2) -> - let t_f1 = - FStar_Syntax_Subst.subst subst - f.FStar_Syntax_Syntax.sort in - let uu___13 = - let uu___14 = - let uu___15 = - FStar_Syntax_Subst.compress a in - uu___15.FStar_Syntax_Syntax.n in - match uu___14 with - | FStar_Syntax_Syntax.Tm_name x - -> - let x1 = - { - FStar_Syntax_Syntax.ppname - = - (x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index - = - (x.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort - = t_f1 - } in - let a1 = - FStar_Syntax_Syntax.bv_to_name - x1 in - let subst1 = - (FStar_Syntax_Syntax.NT - (f, a1)) - :: subst in - ((a1, imp_a), subst1, - (FStar_Compiler_List.op_At - bvs [x1]), - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t)) - | FStar_Syntax_Syntax.Tm_uvar - uu___15 -> - let use_eq = true in - let env2 = - FStar_TypeChecker_Env.set_expected_typ_maybe_eq - env1 t_f1 use_eq in - let uu___16 = - tc_tot_or_gtot_term_maybe_solve_deferred - env2 a - FStar_Pervasives_Native.None - false in - (match uu___16 with - | (a1, uu___17, g) -> - let subst1 = - (FStar_Syntax_Syntax.NT - (f, a1)) - :: subst in - ((a1, imp_a), subst1, - bvs, g)) - | uu___15 -> - let a1 = - FStar_Syntax_Subst.subst - subst a in - let env2 = - FStar_TypeChecker_Env.set_expected_typ - env1 t_f1 in - let uu___16 = - tc_tot_or_gtot_term env2 a1 in - (match uu___16 with - | (a2, uu___17, g) -> - let subst1 = - (FStar_Syntax_Syntax.NT - (f, a2)) - :: subst in - ((a2, imp_a), subst1, - bvs, g)) in - (match uu___13 with - | (a1, subst1, bvs1, g) -> - let uu___14 = - let uu___15 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g guard in - (subst1, - (FStar_Compiler_List.op_At - args_out [a1]), bvs1, - uu___15) in - aux uu___14 formals2 args2) - | uu___10 -> - fail "Not a fully applied pattern") in - aux - ([], [], [], - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t)) - formals args)))) - | FStar_Syntax_Syntax.Tm_fvar uu___1 -> - let uu___2 = - match head.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_uinst (head1, us) -> - let uu___3 = head1.FStar_Syntax_Syntax.n in - (match uu___3 with - | FStar_Syntax_Syntax.Tm_fvar f -> - let res = - FStar_TypeChecker_Env.try_lookup_and_inst_lid - env1 us - (f.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - (match res with - | FStar_Pervasives_Native.Some (t, uu___4) - when - FStar_TypeChecker_Env.is_datacon env1 - (f.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v - -> (head1, (us, t)) - | uu___4 -> - let uu___5 = - let uu___6 = - FStar_Ident.string_of_lid - (f.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - FStar_Compiler_Util.format1 - "Could not find constructor: %s" - uu___6 in - fail uu___5)) - | FStar_Syntax_Syntax.Tm_fvar f -> - let uu___3 = - FStar_TypeChecker_Env.lookup_datacon env1 - (f.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - (head, uu___3) in - (match uu___2 with - | (head1, (us, t_f)) -> - let uu___3 = FStar_Syntax_Util.arrow_formals t_f in - (match uu___3 with - | (formals, t) -> - let erasable = - FStar_TypeChecker_Env.non_informative env1 t in - (if - (FStar_Compiler_List.length formals) <> - (FStar_Compiler_List.length args) - then - fail - "Pattern is not a fully-applied data constructor" - else (); - (let rec aux uu___5 formals1 args1 = - match uu___5 with - | (subst, args_out, bvs, guard) -> - (match (formals1, args1) with - | ([], []) -> - let head2 = - FStar_Syntax_Syntax.mk_Tm_uinst - head1 us in - let pat_e = - FStar_Syntax_Syntax.mk_Tm_app - head2 args_out - e.FStar_Syntax_Syntax.pos in - let uu___6 = - FStar_Syntax_Subst.subst subst t in - (pat_e, uu___6, bvs, guard, - erasable) - | ({ FStar_Syntax_Syntax.binder_bv = f; - FStar_Syntax_Syntax.binder_qual = - uu___6; - FStar_Syntax_Syntax.binder_positivity - = uu___7; - FStar_Syntax_Syntax.binder_attrs = - uu___8;_}::formals2, - (a, imp_a)::args2) -> - let t_f1 = - FStar_Syntax_Subst.subst subst - f.FStar_Syntax_Syntax.sort in - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Syntax_Subst.compress a in - uu___11.FStar_Syntax_Syntax.n in - match uu___10 with - | FStar_Syntax_Syntax.Tm_name x - -> - let x1 = - { - FStar_Syntax_Syntax.ppname - = - (x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index - = - (x.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort - = t_f1 - } in - let a1 = - FStar_Syntax_Syntax.bv_to_name - x1 in - let subst1 = - (FStar_Syntax_Syntax.NT - (f, a1)) - :: subst in - ((a1, imp_a), subst1, - (FStar_Compiler_List.op_At - bvs [x1]), - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t)) - | FStar_Syntax_Syntax.Tm_uvar - uu___11 -> - let use_eq = true in - let env2 = - FStar_TypeChecker_Env.set_expected_typ_maybe_eq - env1 t_f1 use_eq in - let uu___12 = - tc_tot_or_gtot_term_maybe_solve_deferred - env2 a - FStar_Pervasives_Native.None - false in - (match uu___12 with - | (a1, uu___13, g) -> - let subst1 = - (FStar_Syntax_Syntax.NT - (f, a1)) - :: subst in - ((a1, imp_a), subst1, - bvs, g)) - | uu___11 -> - let a1 = - FStar_Syntax_Subst.subst - subst a in - let env2 = - FStar_TypeChecker_Env.set_expected_typ - env1 t_f1 in - let uu___12 = - tc_tot_or_gtot_term env2 a1 in - (match uu___12 with - | (a2, uu___13, g) -> - let subst1 = - (FStar_Syntax_Syntax.NT - (f, a2)) - :: subst in - ((a2, imp_a), subst1, - bvs, g)) in - (match uu___9 with - | (a1, subst1, bvs1, g) -> - let uu___10 = - let uu___11 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g guard in - (subst1, - (FStar_Compiler_List.op_At - args_out [a1]), bvs1, - uu___11) in - aux uu___10 formals2 args2) - | uu___6 -> - fail "Not a fully applied pattern") in - aux - ([], [], [], - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t)) - formals args)))) - | uu___1 -> fail "Not a simple pattern") in - let rec check_nested_pattern env1 p t = - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_Patterns in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_pat p in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.print2 - "Checking nested pattern %s at type %s\n" uu___2 uu___3 - else ()); - (let id t1 = - let uu___1 = - FStar_Syntax_Syntax.fvar FStar_Parser_Const.id_lid - FStar_Pervasives_Native.None in - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.iarg t1 in [uu___3] in - FStar_Syntax_Syntax.mk_Tm_app uu___1 uu___2 - t1.FStar_Syntax_Syntax.pos in - let mk_disc_t disc inner_t = - let x_b = - let uu___1 = - FStar_Syntax_Syntax.gen_bv "x" FStar_Pervasives_Native.None - t in - FStar_Syntax_Syntax.mk_binder uu___1 in - let ty_args = - let uu___1 = FStar_Syntax_Util.head_and_args t in - match uu___1 with - | (hd, args) -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Subst.compress hd in - FStar_Syntax_Util.un_uinst uu___4 in - uu___3.FStar_Syntax_Syntax.n in - (match uu___2 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.lid_of_fv fv in - FStar_TypeChecker_Env.num_inductive_ty_params - env1 uu___5 in - let uu___5 = - FStar_Compiler_Util.map_option - (fun n -> - if (FStar_Compiler_List.length args) >= n - then - let uu___6 = - FStar_Compiler_List.splitAt n args in - FStar_Pervasives_Native.fst uu___6 - else []) uu___4 in - FStar_Compiler_Util.dflt [] uu___5 in - FStar_Compiler_List.map - (fun uu___4 -> - match uu___4 with - | (t1, uu___5) -> FStar_Syntax_Syntax.iarg t1) - uu___3 - | uu___3 -> []) in - let tm = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Syntax_Syntax.bv_to_name - x_b.FStar_Syntax_Syntax.binder_bv in - FStar_Syntax_Syntax.as_arg uu___4 in - [uu___3] in - FStar_Compiler_List.op_At ty_args uu___2 in - FStar_Syntax_Syntax.mk_Tm_app disc uu___1 - FStar_Compiler_Range_Type.dummyRange in - let tm1 = - let uu___1 = - let uu___2 = FStar_Syntax_Syntax.as_arg tm in [uu___2] in - FStar_Syntax_Syntax.mk_Tm_app inner_t uu___1 - FStar_Compiler_Range_Type.dummyRange in - FStar_Syntax_Util.abs [x_b] tm1 FStar_Pervasives_Native.None in - match p.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_dot_term uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_pat p in - FStar_Compiler_Util.format1 - "Impossible: Expected an undecorated pattern, got %s" - uu___3 in - failwith uu___2 - | FStar_Syntax_Syntax.Pat_var x -> - let x1 = - { - FStar_Syntax_Syntax.ppname = - (x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = (x.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = t - } in - let uu___1 = let uu___2 = id t in [uu___2] in - let uu___2 = FStar_Syntax_Syntax.bv_to_name x1 in - ([x1], uu___1, uu___2, - { - FStar_Syntax_Syntax.v = (FStar_Syntax_Syntax.Pat_var x1); - FStar_Syntax_Syntax.p = (p.FStar_Syntax_Syntax.p) - }, - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t), false) - | FStar_Syntax_Syntax.Pat_constant c -> - ((match c with - | FStar_Const.Const_unit -> () - | FStar_Const.Const_bool uu___2 -> () - | FStar_Const.Const_int uu___2 -> () - | FStar_Const.Const_char uu___2 -> () - | FStar_Const.Const_string uu___2 -> () - | uu___2 -> - let uu___3 = - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_const c in - FStar_Compiler_Util.format1 - "Pattern matching a constant that does not have decidable equality: %s" - uu___4 in - fail uu___3); - (let uu___2 = - FStar_TypeChecker_PatternUtils.pat_as_exp false false env1 - p in - match uu___2 with - | (uu___3, e_c, uu___4, uu___5) -> - let uu___6 = tc_tot_or_gtot_term env1 e_c in - (match uu___6 with - | (e_c1, lc, g) -> - (FStar_TypeChecker_Rel.force_trivial_guard env1 g; - (let expected_t = - expected_pat_typ env1 p0.FStar_Syntax_Syntax.p - t in - (let uu___9 = - let uu___10 = - FStar_TypeChecker_Rel.teq_nosmt_force env1 - lc.FStar_TypeChecker_Common.res_typ - expected_t in - Prims.op_Negation uu___10 in - if uu___9 - then - let uu___10 = - let uu___11 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - lc.FStar_TypeChecker_Common.res_typ in - let uu___12 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - expected_t in - FStar_Compiler_Util.format2 - "Type of pattern (%s) does not match type of scrutinee (%s)" - uu___11 uu___12 in - fail uu___10 - else ()); - ([], [], e_c1, p, - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t), - false)))))) - | FStar_Syntax_Syntax.Pat_cons - ({ FStar_Syntax_Syntax.fv_name = uu___1; - FStar_Syntax_Syntax.fv_qual = FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Unresolved_constructor uc);_}, - us_opt, sub_pats) - -> - let uu___2 = - FStar_TypeChecker_Util.find_record_or_dc_from_typ env1 - (FStar_Pervasives_Native.Some t) uc - p.FStar_Syntax_Syntax.p in - (match uu___2 with - | (rdc, uu___3, constructor_fv) -> - let f_sub_pats = - FStar_Compiler_List.zip - uc.FStar_Syntax_Syntax.uc_fields sub_pats in - let sub_pats1 = - FStar_TypeChecker_Util.make_record_fields_in_order env1 - uc - (FStar_Pervasives_Native.Some - (FStar_Pervasives.Inl t)) rdc f_sub_pats - (fun uu___4 -> - let x = - FStar_Syntax_Syntax.new_bv - FStar_Pervasives_Native.None - FStar_Syntax_Syntax.tun in - let uu___5 = - let uu___6 = - FStar_Syntax_Syntax.withinfo - (FStar_Syntax_Syntax.Pat_var x) - p.FStar_Syntax_Syntax.p in - (uu___6, false) in - FStar_Pervasives_Native.Some uu___5) - p.FStar_Syntax_Syntax.p in - let p1 = - { - FStar_Syntax_Syntax.v = - (FStar_Syntax_Syntax.Pat_cons - (constructor_fv, us_opt, sub_pats1)); - FStar_Syntax_Syntax.p = (p.FStar_Syntax_Syntax.p) - } in - let p2 = - FStar_TypeChecker_PatternUtils.elaborate_pat env1 p1 in - check_nested_pattern env1 p2 t) - | FStar_Syntax_Syntax.Pat_cons (fv, us_opt, sub_pats) -> - let simple_pat = - let simple_sub_pats = - FStar_Compiler_List.map - (fun uu___1 -> - match uu___1 with - | (p1, b) -> - (match p1.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_dot_term uu___2 -> - (p1, b) - | uu___2 -> - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Syntax_Syntax.new_bv - (FStar_Pervasives_Native.Some - (p1.FStar_Syntax_Syntax.p)) - FStar_Syntax_Syntax.tun in - FStar_Syntax_Syntax.Pat_var uu___5 in - FStar_Syntax_Syntax.withinfo uu___4 - p1.FStar_Syntax_Syntax.p in - (uu___3, b))) sub_pats in - { - FStar_Syntax_Syntax.v = - (FStar_Syntax_Syntax.Pat_cons - (fv, us_opt, simple_sub_pats)); - FStar_Syntax_Syntax.p = (p.FStar_Syntax_Syntax.p) - } in - let sub_pats1 = - FStar_Compiler_List.filter - (fun uu___1 -> - match uu___1 with - | (x, uu___2) -> - (match x.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_dot_term uu___3 -> false - | uu___3 -> true)) sub_pats in - let uu___1 = - FStar_TypeChecker_PatternUtils.pat_as_exp false false env1 - simple_pat in - (match uu___1 with - | (simple_bvs_pat, simple_pat_e, g0, simple_pat_elab) -> - (if - (FStar_Compiler_List.length simple_bvs_pat) <> - (FStar_Compiler_List.length sub_pats1) - then - (let uu___3 = - let uu___4 = - FStar_Compiler_Range_Ops.string_of_range - p.FStar_Syntax_Syntax.p in - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_pat simple_pat in - let uu___6 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length sub_pats1) in - let uu___7 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length simple_bvs_pat) in - FStar_Compiler_Util.format4 - "(%s) Impossible: pattern bvar mismatch: %s; expected %s sub pats; got %s" - uu___4 uu___5 uu___6 uu___7 in - failwith uu___3) - else (); - (let uu___3 = - let uu___4 = type_of_simple_pat env1 simple_pat_e in - match uu___4 with - | (simple_pat_e1, simple_pat_t, simple_bvs, guard, - erasable) -> - let simple_bvs1 = - let uu___5 = - FStar_Compiler_Util.first_N - ((FStar_Compiler_List.length simple_bvs) - - (FStar_Compiler_List.length - simple_bvs_pat)) simple_bvs in - FStar_Pervasives_Native.snd uu___5 in - let g' = - let uu___5 = - FStar_TypeChecker_Env.push_bvs env1 - simple_bvs1 in - let uu___6 = - expected_pat_typ env1 - p0.FStar_Syntax_Syntax.p t in - pat_typ_ok uu___5 simple_pat_t uu___6 in - let guard1 = - let fml = - FStar_TypeChecker_Env.guard_form guard in - let guard2 = - FStar_TypeChecker_Rel.discharge_guard_no_smt - env1 - { - FStar_TypeChecker_Common.guard_f = - FStar_TypeChecker_Common.Trivial; - FStar_TypeChecker_Common.deferred_to_tac - = - (guard.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (guard.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (guard.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = - (guard.FStar_TypeChecker_Common.implicits) - } in - { - FStar_TypeChecker_Common.guard_f = fml; - FStar_TypeChecker_Common.deferred_to_tac = - (guard2.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (guard2.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (guard2.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = - (guard2.FStar_TypeChecker_Common.implicits) - } in - let guard2 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - guard1 g' in - ((let uu___6 = - FStar_Compiler_Effect.op_Bang dbg_Patterns in - if uu___6 - then - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - simple_pat_e1 in - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - simple_pat_t in - let uu___9 = - let uu___10 = - FStar_Compiler_List.map - (fun x -> - let uu___11 = - let uu___12 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_bv - x in - let uu___13 = - let uu___14 = - let uu___15 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - x.FStar_Syntax_Syntax.sort in - Prims.strcat uu___15 ")" in - Prims.strcat " : " uu___14 in - Prims.strcat uu___12 uu___13 in - Prims.strcat "(" uu___11) - simple_bvs1 in - FStar_Compiler_String.concat " " uu___10 in - FStar_Compiler_Util.print3 - "$$$$$$$$$$$$Checked simple pattern %s at type %s with bvs=%s\n" - uu___7 uu___8 uu___9 - else ()); - (simple_pat_e1, simple_bvs1, guard2, erasable)) in - match uu___3 with - | (simple_pat_e1, simple_bvs, g1, erasable) -> - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t g0 - g1 in - ([], [], [], [], uu___6, erasable, - Prims.int_zero) in - FStar_Compiler_List.fold_left2 - (fun uu___6 -> - fun uu___7 -> - fun x -> - match (uu___6, uu___7) with - | ((bvs, tms, pats, subst, g, erasable1, - i), - (p1, b)) -> - let expected_t = - FStar_Syntax_Subst.subst subst - x.FStar_Syntax_Syntax.sort in - let env2 = - FStar_TypeChecker_Env.push_bvs - env1 bvs in - let uu___8 = - check_nested_pattern env2 p1 - expected_t in - (match uu___8 with - | (bvs_p, tms_p, e_p, p2, g', - erasable_p) -> - let g'1 = - let uu___9 = - FStar_Compiler_List.map - FStar_Syntax_Syntax.mk_binder - bvs in - FStar_TypeChecker_Env.close_guard - env2 uu___9 g' in - let tms_p1 = - let disc_tm = - let uu___9 = - FStar_Syntax_Syntax.lid_of_fv - fv in - FStar_TypeChecker_Util.get_field_projector_name - env2 uu___9 i in - let uu___9 = - let uu___10 = - FStar_Syntax_Syntax.fvar - disc_tm - FStar_Pervasives_Native.None in - mk_disc_t uu___10 in - FStar_Compiler_List.map - uu___9 tms_p in - let uu___9 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g g'1 in - ((FStar_Compiler_List.op_At bvs - bvs_p), - (FStar_Compiler_List.op_At - tms tms_p1), - (FStar_Compiler_List.op_At - pats [(p2, b)]), - ((FStar_Syntax_Syntax.NT - (x, e_p)) :: subst), - uu___9, - (erasable1 || erasable_p), - (i + Prims.int_one)))) uu___5 - sub_pats1 simple_bvs in - (match uu___4 with - | (bvs, tms, checked_sub_pats, subst, g, - erasable1, uu___5) -> - let pat_e = - FStar_Syntax_Subst.subst subst simple_pat_e1 in - let reconstruct_nested_pat pat = - let rec aux simple_pats bvs1 sub_pats2 = - match simple_pats with - | [] -> [] - | (hd, b)::simple_pats1 -> - (match hd.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_dot_term - eopt -> - let eopt1 = - FStar_Compiler_Util.map_option - (FStar_Syntax_Subst.subst - subst) eopt in - let hd1 = - { - FStar_Syntax_Syntax.v = - (FStar_Syntax_Syntax.Pat_dot_term - eopt1); - FStar_Syntax_Syntax.p = - (hd.FStar_Syntax_Syntax.p) - } in - let uu___6 = - aux simple_pats1 bvs1 sub_pats2 in - (hd1, b) :: uu___6 - | FStar_Syntax_Syntax.Pat_var x -> - (match (bvs1, sub_pats2) with - | (x'::bvs2, - (hd1, uu___6)::sub_pats3) - when - FStar_Syntax_Syntax.bv_eq x - x' - -> - let uu___7 = - aux simple_pats1 bvs2 - sub_pats3 in - (hd1, b) :: uu___7 - | uu___6 -> - failwith - "Impossible: simple pat variable mismatch") - | uu___6 -> - failwith - "Impossible: expected a simple pattern") in - let us = - let uu___6 = - FStar_Syntax_Util.head_and_args - simple_pat_e1 in - match uu___6 with - | (hd, uu___7) -> - let uu___8 = - let uu___9 = - FStar_Syntax_Subst.compress hd in - uu___9.FStar_Syntax_Syntax.n in - (match uu___8 with - | FStar_Syntax_Syntax.Tm_fvar uu___9 - -> [] - | FStar_Syntax_Syntax.Tm_uinst - (uu___9, us1) -> us1 - | uu___9 -> - failwith - "Impossible: tc_pat: pattern head not fvar or uinst") in - match pat.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_cons - (fv1, uu___6, simple_pats) -> - let nested_pats = - aux simple_pats simple_bvs - checked_sub_pats in - { - FStar_Syntax_Syntax.v = - (FStar_Syntax_Syntax.Pat_cons - (fv1, - (FStar_Pervasives_Native.Some - us), nested_pats)); - FStar_Syntax_Syntax.p = - (pat.FStar_Syntax_Syntax.p) - } - | uu___6 -> - failwith - "Impossible: tc_pat: pat.v expected Pat_cons" in - let uu___6 = - reconstruct_nested_pat simple_pat_elab in - (bvs, tms, pat_e, uu___6, g, erasable1)))))) in - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_Patterns in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_pat p0 in - FStar_Compiler_Util.print1 "Checking pattern: %s\n" uu___2 - else ()); - (let uu___1 = - let uu___2 = - let uu___3 = FStar_TypeChecker_Env.clear_expected_typ env in - FStar_Pervasives_Native.fst uu___3 in - let uu___3 = FStar_TypeChecker_PatternUtils.elaborate_pat env p0 in - let uu___4 = expected_pat_typ env p0.FStar_Syntax_Syntax.p pat_t in - check_nested_pattern uu___2 uu___3 uu___4 in - match uu___1 with - | (bvs, tms, pat_e, pat, g, erasable) -> - let extended_env = FStar_TypeChecker_Env.push_bvs env bvs in - let pat_e_norm = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Beta] extended_env pat_e in - ((let uu___3 = FStar_Compiler_Effect.op_Bang dbg_Patterns in - if uu___3 - then - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_pat pat in - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - pat_e in - FStar_Compiler_Util.print2 - "Done checking pattern %s as expression %s\n" uu___4 - uu___5 - else ()); - (pat, bvs, tms, extended_env, pat_e, pat_e_norm, g, erasable))) -and (tc_eqn : - FStar_Syntax_Syntax.bv -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.match_returns_ascription - FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.branch -> - ((FStar_Syntax_Syntax.pat * FStar_Syntax_Syntax.term - FStar_Pervasives_Native.option * FStar_Syntax_Syntax.term) * - FStar_Syntax_Syntax.formula * FStar_Ident.lident * - FStar_Syntax_Syntax.cflag Prims.list - FStar_Pervasives_Native.option * - (Prims.bool -> FStar_TypeChecker_Common.lcomp) - FStar_Pervasives_Native.option * FStar_TypeChecker_Env.guard_t * - Prims.bool)) - = - fun scrutinee -> - fun env -> - fun ret_opt -> - fun branch -> - let uu___ = FStar_Syntax_Subst.open_branch branch in - match uu___ with - | (pattern, when_clause, branch_exp) -> - let uu___1 = branch in - (match uu___1 with - | (cpat, uu___2, cbr) -> - let pat_t = scrutinee.FStar_Syntax_Syntax.sort in - let scrutinee_tm = - FStar_Syntax_Syntax.bv_to_name scrutinee in - let uu___3 = - let uu___4 = FStar_TypeChecker_Env.push_bv env scrutinee in - FStar_TypeChecker_Env.clear_expected_typ uu___4 in - (match uu___3 with - | (scrutinee_env, uu___4) -> - let uu___5 = - let uu___6 = - FStar_TypeChecker_Env.push_bv env scrutinee in - tc_pat uu___6 pat_t pattern in - (match uu___5 with - | (pattern1, pat_bvs, pat_bv_tms, pat_env, pat_exp, - norm_pat_exp, guard_pat, erasable) -> - ((let uu___7 = FStar_Compiler_Debug.extreme () in - if uu___7 - then - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_pat pattern1 in - let uu___9 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_bv) - pat_bvs in - let uu___10 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_term) - pat_bv_tms in - FStar_Compiler_Util.print3 - "tc_eqn: typechecked pattern %s with bvs %s and pat_bv_tms=%s\n" - uu___8 uu___9 uu___10 - else ()); - (let uu___7 = - match when_clause with - | FStar_Pervasives_Native.None -> - (FStar_Pervasives_Native.None, - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t)) - | FStar_Pervasives_Native.Some e -> - let uu___8 = - FStar_TypeChecker_Env.should_verify - env in - if uu___8 - then - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax - ()) e - FStar_Errors_Codes.Fatal_WhenClauseNotSupported - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "When clauses are not yet supported in --verify mode; they will be some day") - else - (let uu___10 = - let uu___11 = - FStar_TypeChecker_Env.set_expected_typ - pat_env - FStar_Syntax_Util.t_bool in - tc_term uu___11 e in - match uu___10 with - | (e1, c, g) -> - ((FStar_Pervasives_Native.Some e1), - g)) in - match uu___7 with - | (when_clause1, g_when) -> - let uu___8 = - let branch_exp1 = - match ret_opt with - | FStar_Pervasives_Native.None -> - branch_exp - | FStar_Pervasives_Native.Some - (b, asc) -> - let uu___9 = - FStar_Syntax_Subst.subst_ascription - [FStar_Syntax_Syntax.NT - ((b.FStar_Syntax_Syntax.binder_bv), - norm_pat_exp)] asc in - FStar_Syntax_Util.ascribe - branch_exp uu___9 in - let uu___9 = tc_term pat_env branch_exp1 in - match uu___9 with - | (branch_exp2, c, g_branch) -> - let branch_exp3 = - match ret_opt with - | FStar_Pervasives_Native.None -> - branch_exp2 - | uu___10 -> - let uu___11 = - let uu___12 = - FStar_Syntax_Subst.compress - branch_exp2 in - uu___12.FStar_Syntax_Syntax.n in - (match uu___11 with - | FStar_Syntax_Syntax.Tm_ascribed - { - FStar_Syntax_Syntax.tm - = branch_exp4; - FStar_Syntax_Syntax.asc - = uu___12; - FStar_Syntax_Syntax.eff_opt - = uu___13;_} - -> branch_exp4 - | uu___12 -> - failwith - "Impossible (expected the match branch with an ascription)") in - (branch_exp3, c, g_branch) in - (match uu___8 with - | (branch_exp1, c, g_branch) -> - (FStar_Defensive.def_check_scoped - FStar_TypeChecker_Env.hasBinders_env - FStar_TypeChecker_Env.hasNames_guard - FStar_TypeChecker_Env.pretty_guard - cbr.FStar_Syntax_Syntax.pos - "tc_eqn.1" pat_env g_branch; - (let when_condition = - match when_clause1 with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some w - -> - let uu___10 = - FStar_Syntax_Util.mk_eq2 - FStar_Syntax_Syntax.U_zero - FStar_Syntax_Util.t_bool - w - FStar_Syntax_Util.exp_true_bool in - FStar_Pervasives_Native.Some - uu___10 in - let branch_guard = - let uu___10 = - let uu___11 = - FStar_TypeChecker_Env.should_verify - env in - Prims.op_Negation uu___11 in - if uu___10 - then - FStar_Syntax_Util.exp_true_bool - else - (let rec build_branch_guard - scrutinee_tm1 pattern2 - pat_exp1 = - let discriminate - scrutinee_tm2 f = - let uu___12 = - let uu___13 = - FStar_TypeChecker_Env.typ_of_datacon - env - f.FStar_Syntax_Syntax.v in - FStar_TypeChecker_Env.datacons_of_typ - env uu___13 in - match uu___12 with - | (is_induc, datacons) -> - if - (Prims.op_Negation - is_induc) - || - ((FStar_Compiler_List.length - datacons) - > Prims.int_one) - then - let discriminator = - FStar_Syntax_Util.mk_discriminator - f.FStar_Syntax_Syntax.v in - let uu___13 = - FStar_TypeChecker_Env.try_lookup_lid - env - discriminator in - (match uu___13 with - | FStar_Pervasives_Native.None - -> [] - | uu___14 -> - let disc = - FStar_Syntax_Syntax.fvar - discriminator - FStar_Pervasives_Native.None in - let uu___15 = - let uu___16 = - let uu___17 - = - FStar_Syntax_Syntax.as_arg - scrutinee_tm2 in - [uu___17] in - FStar_Syntax_Syntax.mk_Tm_app - disc - uu___16 - scrutinee_tm2.FStar_Syntax_Syntax.pos in - [uu___15]) - else [] in - let fail uu___12 = - let uu___13 = - let uu___14 = - FStar_Compiler_Range_Ops.string_of_range - pat_exp1.FStar_Syntax_Syntax.pos in - let uu___15 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - pat_exp1 in - let uu___16 = - FStar_Class_Tagged.tag_of - FStar_Syntax_Syntax.tagged_term - pat_exp1 in - FStar_Compiler_Util.format3 - "tc_eqn: Impossible (%s) %s (%s)" - uu___14 uu___15 - uu___16 in - failwith uu___13 in - let rec head_constructor t = - match t.FStar_Syntax_Syntax.n - with - | FStar_Syntax_Syntax.Tm_fvar - fv -> - fv.FStar_Syntax_Syntax.fv_name - | FStar_Syntax_Syntax.Tm_uinst - (t1, uu___12) -> - head_constructor t1 - | uu___12 -> fail () in - let force_scrutinee uu___12 - = - match scrutinee_tm1 with - | FStar_Pervasives_Native.None - -> - let uu___13 = - let uu___14 = - FStar_Compiler_Range_Ops.string_of_range - pattern2.FStar_Syntax_Syntax.p in - let uu___15 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_pat - pattern2 in - FStar_Compiler_Util.format2 - "Impossible (%s): scrutinee of match is not defined %s" - uu___14 uu___15 in - failwith uu___13 - | FStar_Pervasives_Native.Some - t -> t in - let pat_exp2 = - let uu___12 = - FStar_Syntax_Subst.compress - pat_exp1 in - FStar_Syntax_Util.unmeta - uu___12 in - match ((pattern2.FStar_Syntax_Syntax.v), - (pat_exp2.FStar_Syntax_Syntax.n)) - with - | (uu___12, - FStar_Syntax_Syntax.Tm_name - uu___13) -> [] - | (uu___12, - FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_unit)) - -> [] - | (FStar_Syntax_Syntax.Pat_constant - _c, - FStar_Syntax_Syntax.Tm_constant - c1) -> - let uu___12 = - let uu___13 = - tc_constant env - pat_exp2.FStar_Syntax_Syntax.pos - c1 in - let uu___14 = - force_scrutinee () in - FStar_Syntax_Util.mk_decidable_eq - uu___13 uu___14 - pat_exp2 in - [uu___12] - | (FStar_Syntax_Syntax.Pat_constant - (FStar_Const.Const_int - (uu___12, - FStar_Pervasives_Native.Some - uu___13)), - uu___14) -> - let uu___15 = - let uu___16 = - FStar_TypeChecker_Env.clear_expected_typ - env in - match uu___16 with - | (env1, uu___17) -> - env1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term - env1 pat_exp2 - true in - (match uu___15 with - | (uu___16, t, uu___17) - -> - let uu___18 = - let uu___19 = - force_scrutinee - () in - FStar_Syntax_Util.mk_decidable_eq - t uu___19 - pat_exp2 in - [uu___18]) - | (FStar_Syntax_Syntax.Pat_cons - (uu___12, uu___13, []), - FStar_Syntax_Syntax.Tm_uinst - uu___14) -> - let f = - head_constructor - pat_exp2 in - let uu___15 = - let uu___16 = - FStar_TypeChecker_Env.is_datacon - env - f.FStar_Syntax_Syntax.v in - Prims.op_Negation - uu___16 in - if uu___15 - then - failwith - "Impossible: nullary patterns must be data constructors" - else - (let uu___17 = - force_scrutinee () in - let uu___18 = - head_constructor - pat_exp2 in - discriminate uu___17 - uu___18) - | (FStar_Syntax_Syntax.Pat_cons - (uu___12, uu___13, []), - FStar_Syntax_Syntax.Tm_fvar - uu___14) -> - let f = - head_constructor - pat_exp2 in - let uu___15 = - let uu___16 = - FStar_TypeChecker_Env.is_datacon - env - f.FStar_Syntax_Syntax.v in - Prims.op_Negation - uu___16 in - if uu___15 - then - failwith - "Impossible: nullary patterns must be data constructors" - else - (let uu___17 = - force_scrutinee () in - let uu___18 = - head_constructor - pat_exp2 in - discriminate uu___17 - uu___18) - | (FStar_Syntax_Syntax.Pat_cons - (uu___12, uu___13, - pat_args), - FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd - = head; - FStar_Syntax_Syntax.args - = args;_}) - -> - let f = - head_constructor head in - let uu___14 = - (let uu___15 = - FStar_TypeChecker_Env.is_datacon - env - f.FStar_Syntax_Syntax.v in - Prims.op_Negation - uu___15) - || - ((FStar_Compiler_List.length - pat_args) - <> - (FStar_Compiler_List.length - args)) in - if uu___14 - then - failwith - "Impossible: application patterns must be fully-applied data constructors" - else - (let sub_term_guards = - let uu___16 = - let uu___17 = - FStar_Compiler_List.zip - pat_args args in - FStar_Compiler_List.mapi - (fun i -> - fun uu___18 - -> - match uu___18 - with - | - ((pi, - uu___19), - (ei, - uu___20)) - -> - let projector - = - FStar_TypeChecker_Env.lookup_projector - env - f.FStar_Syntax_Syntax.v - i in - let scrutinee_tm2 - = - let uu___21 - = - FStar_TypeChecker_Env.try_lookup_lid - env - projector in - match uu___21 - with - | - FStar_Pervasives_Native.None - -> - FStar_Pervasives_Native.None - | - uu___22 - -> - let proj - = - let uu___23 - = - FStar_Ident.set_lid_range - projector - f.FStar_Syntax_Syntax.p in - FStar_Syntax_Syntax.fvar - uu___23 - FStar_Pervasives_Native.None in - let uu___23 - = - let uu___24 - = - let uu___25 - = - let uu___26 - = - force_scrutinee - () in - FStar_Syntax_Syntax.as_arg - uu___26 in - [uu___25] in - FStar_Syntax_Syntax.mk_Tm_app - proj - uu___24 - f.FStar_Syntax_Syntax.p in - FStar_Pervasives_Native.Some - uu___23 in - build_branch_guard - scrutinee_tm2 - pi ei) - uu___17 in - FStar_Compiler_List.flatten - uu___16 in - let uu___16 = - let uu___17 = - force_scrutinee - () in - discriminate - uu___17 f in - FStar_Compiler_List.op_At - uu___16 - sub_term_guards) - | (FStar_Syntax_Syntax.Pat_dot_term - uu___12, uu___13) -> [] - | uu___12 -> - let uu___13 = - let uu___14 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_pat - pattern2 in - let uu___15 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - pat_exp2 in - FStar_Compiler_Util.format2 - "Internal error: unexpected elaborated pattern: %s and pattern expression %s" - uu___14 uu___15 in - failwith uu___13 in - let build_and_check_branch_guard - scrutinee_tm1 pattern2 pat = - let uu___12 = - let uu___13 = - FStar_TypeChecker_Env.should_verify - env in - Prims.op_Negation uu___13 in - if uu___12 - then - FStar_Syntax_Util.exp_true_bool - else - (let t = - let uu___14 = - build_branch_guard - scrutinee_tm1 - pattern2 pat in - FStar_Syntax_Util.mk_and_l - uu___14 in - (let uu___15 = - FStar_Compiler_Debug.high - () in - if uu___15 - then - let uu___16 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t in - FStar_Compiler_Util.print1 - "tc_eqn: branch guard before typechecking: %s\n" - uu___16 - else ()); - (let uu___15 = - tc_check_tot_or_gtot_term - scrutinee_env t - FStar_Syntax_Util.t_bool - FStar_Pervasives_Native.None in - match uu___15 with - | (t1, uu___16, uu___17) - -> - ((let uu___19 = - FStar_Compiler_Debug.high - () in - if uu___19 - then - let uu___20 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t1 in - FStar_Compiler_Util.print1 - "tc_eqn: branch guard after typechecking: %s\n" - uu___20 - else ()); - t1))) in - let branch_guard1 = - build_and_check_branch_guard - (FStar_Pervasives_Native.Some - scrutinee_tm) pattern1 - norm_pat_exp in - let branch_guard2 = - match when_condition with - | FStar_Pervasives_Native.None - -> branch_guard1 - | FStar_Pervasives_Native.Some - w -> - FStar_Syntax_Util.mk_and - branch_guard1 w in - branch_guard2) in - (let uu___11 = - FStar_Compiler_Debug.extreme () in - if uu___11 - then - let uu___12 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - branch_guard in - FStar_Compiler_Util.print1 - "tc_eqn: branch guard : %s\n" - uu___12 - else ()); - (let uu___11 = - let eqs = - let env1 = pat_env in - let uu___12 = - let uu___13 = - FStar_TypeChecker_Env.should_verify - env1 in - Prims.op_Negation uu___13 in - if uu___12 - then - FStar_Pervasives_Native.None - else - (let e = - FStar_Syntax_Subst.compress - pat_exp in - let uu___14 = - let uu___15 = - env1.FStar_TypeChecker_Env.universe_of - env1 pat_t in - FStar_Syntax_Util.mk_eq2 - uu___15 pat_t - scrutinee_tm e in - FStar_Pervasives_Native.Some - uu___14) in - match ret_opt with - | FStar_Pervasives_Native.Some - (uu___12, - (FStar_Pervasives.Inr c1, - uu___13, uu___14)) - -> - let pat_bs = - FStar_Compiler_List.map - FStar_Syntax_Syntax.mk_binder - pat_bvs in - let g_branch1 = - let uu___15 = - let uu___16 = - if - FStar_Compiler_Util.is_some - eqs - then - let uu___17 = - FStar_Compiler_Util.must - eqs in - FStar_TypeChecker_Common.weaken_guard_formula - g_branch uu___17 - else g_branch in - FStar_TypeChecker_Env.close_guard - env pat_bs uu___16 in - FStar_TypeChecker_Util.close_guard_implicits - env true pat_bs uu___15 in - ((FStar_Syntax_Util.comp_effect_name - c1), - FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None, - g_when, g_branch1) - | uu___12 -> - let uu___13 = - FStar_TypeChecker_Util.strengthen_precondition - FStar_Pervasives_Native.None - env branch_exp1 c - g_branch in - (match uu___13 with - | (c1, g_branch1) -> - let close_branch_with_substitutions - = - let m = - FStar_TypeChecker_Env.norm_eff_name - env - c1.FStar_TypeChecker_Common.eff_name in - (FStar_TypeChecker_Env.is_layered_effect - env m) - && - (let uu___14 = - let uu___15 = - FStar_TypeChecker_Env.get_effect_decl - env m in - FStar_Syntax_Util.get_layered_close_combinator - uu___15 in - FStar_Pervasives_Native.uu___is_None - uu___14) in - let uu___14 = - if - close_branch_with_substitutions - then - let c2 = - let uu___15 = - let uu___16 = - FStar_Syntax_Util.b2t - branch_guard in - FStar_TypeChecker_Common.NonTrivial - uu___16 in - FStar_TypeChecker_Util.weaken_precondition - pat_env c1 - uu___15 in - (c2, - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t)) - else - if - (let uu___16 = - FStar_TypeChecker_Env.should_verify - pat_env in - Prims.op_Negation - uu___16) - then (c1, g_when) - else - (match (eqs, - when_condition) - with - | (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.None) - -> - (c1, g_when) - | (FStar_Pervasives_Native.Some - f, - FStar_Pervasives_Native.None) - -> - let gf = - FStar_TypeChecker_Common.NonTrivial - f in - let g = - FStar_TypeChecker_Env.guard_of_guard_formula - gf in - let uu___16 - = - FStar_TypeChecker_Util.weaken_precondition - pat_env - c1 gf in - let uu___17 - = - FStar_TypeChecker_Env.imp_guard - g g_when in - (uu___16, - uu___17) - | (FStar_Pervasives_Native.Some - f, - FStar_Pervasives_Native.Some - w) -> - let g_f = - FStar_TypeChecker_Common.NonTrivial - f in - let g_fw = - let uu___16 - = - FStar_Syntax_Util.mk_conj - f w in - FStar_TypeChecker_Common.NonTrivial - uu___16 in - let uu___16 - = - FStar_TypeChecker_Util.weaken_precondition - pat_env - c1 g_fw in - let uu___17 - = - let uu___18 - = - FStar_TypeChecker_Env.guard_of_guard_formula - g_f in - FStar_TypeChecker_Env.imp_guard - uu___18 - g_when in - (uu___16, - uu___17) - | (FStar_Pervasives_Native.None, - FStar_Pervasives_Native.Some - w) -> - let g_w = - FStar_TypeChecker_Common.NonTrivial - w in - let g = - FStar_TypeChecker_Env.guard_of_guard_formula - g_w in - let uu___16 - = - FStar_TypeChecker_Util.weaken_precondition - pat_env - c1 g_w in - (uu___16, - g_when)) in - (match uu___14 with - | (c_weak, - g_when_weak) -> - let binders = - FStar_Compiler_List.map - FStar_Syntax_Syntax.mk_binder - pat_bvs in - let maybe_return_c_weak - should_return = - let c_weak1 = - let uu___15 = - should_return - && - (FStar_TypeChecker_Common.is_pure_or_ghost_lcomp - c_weak) in - if uu___15 - then - let uu___16 - = - FStar_TypeChecker_Env.push_bvs - scrutinee_env - pat_bvs in - FStar_TypeChecker_Util.maybe_assume_result_eq_pure_term - uu___16 - branch_exp1 - c_weak - else c_weak in - if - close_branch_with_substitutions - then - ((let uu___16 - = - FStar_Compiler_Effect.op_Bang - dbg_LayeredEffects in - if uu___16 - then - FStar_Compiler_Util.print_string - "Typechecking pat_bv_tms ...\n" - else ()); - (let pat_bv_tms1 - = - FStar_Compiler_List.map - (fun - pat_bv_tm - -> - let uu___16 - = - let uu___17 - = - FStar_Syntax_Syntax.as_arg - scrutinee_tm in - [uu___17] in - FStar_Syntax_Syntax.mk_Tm_app - pat_bv_tm - uu___16 - FStar_Compiler_Range_Type.dummyRange) - pat_bv_tms in - let pat_bv_tms2 - = - let env1 = - let uu___16 - = - FStar_TypeChecker_Env.push_bv - env - scrutinee in - { - FStar_TypeChecker_Env.solver - = - (uu___16.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range - = - (uu___16.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule - = - (uu___16.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma - = - (uu___16.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig - = - (uu___16.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache - = - (uu___16.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules - = - (uu___16.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ - = - (uu___16.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab - = - (uu___16.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab - = - (uu___16.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp - = - (uu___16.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects - = - (uu___16.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize - = - (uu___16.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs - = - (uu___16.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level - = - (uu___16.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars - = - (uu___16.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict - = - (uu___16.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface - = - (uu___16.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit - = true; - FStar_TypeChecker_Env.lax_universes - = - (uu___16.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 - = - (uu___16.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard - = - (uu___16.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking - = - (uu___16.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping - = - (uu___16.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics - = - (uu___16.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce - = - (uu___16.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term - = - (uu___16.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (uu___16.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of - = - (uu___16.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (uu___16.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force - = - (uu___16.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (uu___16.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (uu___16.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (uu___16.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths - = - (uu___16.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns - = - (uu___16.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook - = - (uu___16.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (uu___16.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice - = - (uu___16.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess - = - (uu___16.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess - = - (uu___16.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info - = - (uu___16.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks - = - (uu___16.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv - = - (uu___16.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe - = - (uu___16.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab - = - (uu___16.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (uu___16.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (uu___16.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (uu___16.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (uu___16.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check - = - (uu___16.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl - = - (uu___16.FStar_TypeChecker_Env.missing_decl) - } in - let uu___16 - = - let uu___17 - = - FStar_Compiler_List.fold_left2 - (fun - uu___18 - -> - fun - pat_bv_tm - -> - fun bv -> - match uu___18 - with - | - (substs, - acc) -> - let expected_t - = - FStar_Syntax_Subst.subst - substs - bv.FStar_Syntax_Syntax.sort in - let pat_bv_tm1 - = - let uu___19 - = - let uu___20 - = - FStar_TypeChecker_Env.set_expected_typ - env1 - expected_t in - let uu___21 - = - FStar_Syntax_Subst.subst - substs - pat_bv_tm in - tc_trivial_guard - uu___20 - uu___21 in - FStar_Pervasives_Native.fst - uu___19 in - ((FStar_Compiler_List.op_At - substs - [ - FStar_Syntax_Syntax.NT - (bv, - pat_bv_tm1)]), - (FStar_Compiler_List.op_At - acc - [pat_bv_tm1]))) - ([], []) - pat_bv_tms1 - pat_bvs in - FStar_Pervasives_Native.snd - uu___17 in - FStar_Compiler_List.map - (FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Beta] - env1) - uu___16 in - (let uu___17 - = - FStar_Compiler_Effect.op_Bang - dbg_LayeredEffects in - if uu___17 - then - let uu___18 - = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_term) - pat_bv_tms2 in - let uu___19 - = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Syntax_Print.showable_bv) - pat_bvs in - FStar_Compiler_Util.print2 - "tc_eqn: typechecked pat_bv_tms=%s (pat_bvs=%s)\n" - uu___18 - uu___19 - else ()); - (let uu___17 - = - FStar_TypeChecker_Env.push_bv - env - scrutinee in - let uu___18 - = - FStar_TypeChecker_Common.apply_lcomp - (fun c2 - -> c2) - (fun g -> - match eqs - with - | - FStar_Pervasives_Native.None - -> g - | - FStar_Pervasives_Native.Some - eqs1 -> - FStar_TypeChecker_Common.weaken_guard_formula - g eqs1) - c_weak1 in - FStar_TypeChecker_Util.close_layered_lcomp_with_substitutions - uu___17 - pat_bvs - pat_bv_tms2 - uu___18))) - else - (let uu___16 = - let uu___17 - = - FStar_TypeChecker_Env.norm_eff_name - env - c_weak1.FStar_TypeChecker_Common.eff_name in - FStar_TypeChecker_Env.is_layered_effect - env - uu___17 in - if uu___16 - then - let uu___17 - = - FStar_TypeChecker_Env.push_bv - env - scrutinee in - FStar_TypeChecker_Util.close_layered_lcomp_with_combinator - uu___17 - pat_bvs - c_weak1 - else - (let uu___18 - = - FStar_TypeChecker_Env.push_bv - env - scrutinee in - FStar_TypeChecker_Util.close_wp_lcomp - uu___18 - pat_bvs - c_weak1)) in - let uu___15 = - FStar_TypeChecker_Env.close_guard - env binders - g_when_weak in - let uu___16 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - guard_pat - g_branch1 in - ((c_weak.FStar_TypeChecker_Common.eff_name), - (FStar_Pervasives_Native.Some - (c_weak.FStar_TypeChecker_Common.cflags)), - (FStar_Pervasives_Native.Some - maybe_return_c_weak), - uu___15, - uu___16))) in - match uu___11 with - | (effect_label, cflags, - maybe_return_c, g_when1, - g_branch1) -> - let guard = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g_when1 g_branch1 in - ((let uu___13 = - FStar_Compiler_Debug.high - () in - if uu___13 - then - let uu___14 = - FStar_TypeChecker_Rel.guard_to_string - env guard in - FStar_Compiler_Util.print1 - "Carrying guard from match: %s\n" - uu___14 - else ()); - (let uu___13 = - FStar_Syntax_Subst.close_branch - (pattern1, when_clause1, - branch_exp1) in - let uu___14 = - let uu___15 = - FStar_Compiler_List.map - FStar_Syntax_Syntax.mk_binder - pat_bvs in - FStar_TypeChecker_Util.close_guard_implicits - env false uu___15 guard in - (uu___13, branch_guard, - effect_label, cflags, - maybe_return_c, uu___14, - erasable)))))))))))) -and (check_top_level_let : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.lcomp * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun e -> - let env1 = instantiate_both env in - match e.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (false, lb::[]); - FStar_Syntax_Syntax.body1 = e2;_} - -> - let uu___ = check_let_bound_def true env1 lb in - (match uu___ with - | (e1, univ_vars, c1, g1, annotated) -> - let uu___1 = - if - annotated && - (Prims.op_Negation env1.FStar_TypeChecker_Env.generalize) - then - let uu___2 = - FStar_TypeChecker_Normalize.reduce_uvar_solutions env1 - e1 in - (g1, uu___2, univ_vars, c1) - else - (let g11 = - let uu___3 = - FStar_TypeChecker_Rel.solve_deferred_constraints env1 - g1 in - FStar_TypeChecker_Rel.resolve_implicits env1 uu___3 in - let uu___3 = FStar_TypeChecker_Common.lcomp_comp c1 in - match uu___3 with - | (comp1, g_comp1) -> - let g12 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t g11 - g_comp1 in - let uu___4 = - let uu___5 = - FStar_TypeChecker_Generalize.generalize env1 - false - [((lb.FStar_Syntax_Syntax.lbname), e1, comp1)] in - FStar_Compiler_List.hd uu___5 in - (match uu___4 with - | (uu___5, univs, e11, c11, gvs) -> - let g13 = - FStar_TypeChecker_Rel.resolve_generalization_implicits - env1 g12 in - let g14 = - FStar_TypeChecker_Env.map_guard g13 - (FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.DoNotUnfoldPureLets; - FStar_TypeChecker_Env.CompressUvars; - FStar_TypeChecker_Env.NoFullNorm; - FStar_TypeChecker_Env.Exclude - FStar_TypeChecker_Env.Zeta] env1) in - let g15 = - FStar_TypeChecker_Env.abstract_guard_n gvs g14 in - let uu___6 = - FStar_TypeChecker_Common.lcomp_of_comp c11 in - (g15, e11, univs, uu___6))) in - (match uu___1 with - | (g11, e11, univ_vars1, c11) -> - let uu___2 = - let uu___3 = - FStar_TypeChecker_Util.check_top_level env1 g11 c11 in - match uu___3 with - | (ok, c12) -> - if ok - then (e2, c12) - else - ((let uu___6 = - let uu___7 = FStar_Options.ml_ish () in - Prims.op_Negation uu___7 in - if uu___6 - then - let uu___7 = - FStar_TypeChecker_Env.get_range env1 in - FStar_TypeChecker_Err.warn_top_level_effect - uu___7 - else ()); - (let uu___6 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 = e2; - FStar_Syntax_Syntax.meta = - (FStar_Syntax_Syntax.Meta_desugared - FStar_Syntax_Syntax.Masked_effect) - }) e2.FStar_Syntax_Syntax.pos in - (uu___6, c12))) in - (match uu___2 with - | (e21, c12) -> - ((let uu___4 = FStar_Compiler_Debug.medium () in - if uu___4 - then - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term e11 in - FStar_Compiler_Util.print1 - "Let binding BEFORE tcnorm: %s\n" uu___5 - else ()); - (let e12 = - let uu___4 = FStar_Options.tcnorm () in - if uu___4 - then - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.UnfoldAttr - [FStar_Parser_Const.tcnorm_attr]; - FStar_TypeChecker_Env.Exclude - FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Exclude - FStar_TypeChecker_Env.Zeta; - FStar_TypeChecker_Env.NoFullNorm; - FStar_TypeChecker_Env.DoNotUnfoldPureLets] - env1 e11 - else e11 in - (let uu___5 = FStar_Compiler_Debug.medium () in - if uu___5 - then - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term e12 in - FStar_Compiler_Util.print1 - "Let binding AFTER tcnorm: %s\n" uu___6 - else ()); - (let cres = - FStar_Syntax_Syntax.mk_Total - FStar_Syntax_Syntax.t_unit in - let lb1 = - FStar_Syntax_Util.close_univs_and_mk_letbinding - FStar_Pervasives_Native.None - lb.FStar_Syntax_Syntax.lbname univ_vars1 - (FStar_Syntax_Util.comp_result c12) - (FStar_Syntax_Util.comp_effect_name c12) e12 - lb.FStar_Syntax_Syntax.lbattrs - lb.FStar_Syntax_Syntax.lbpos in - let uu___5 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = (false, [lb1]); - FStar_Syntax_Syntax.body1 = e21 - }) e.FStar_Syntax_Syntax.pos in - let uu___6 = - FStar_TypeChecker_Common.lcomp_of_comp cres in - (uu___5, uu___6, - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t)))))))) - | uu___ -> failwith "Impossible: check_top_level_let: not a let" -and (maybe_intro_smt_lemma : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_TypeChecker_Common.lcomp -> FStar_TypeChecker_Common.lcomp) - = - fun env -> - fun lem_typ -> - fun c2 -> - let uu___ = FStar_Syntax_Util.is_smt_lemma lem_typ in - if uu___ - then - let universe_of_binders bs = - let uu___1 = - FStar_Compiler_List.fold_left - (fun uu___2 -> - fun b -> - match uu___2 with - | (env1, us) -> - let u = - env1.FStar_TypeChecker_Env.universe_of env1 - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - let env2 = - FStar_TypeChecker_Env.push_binders env1 [b] in - (env2, (u :: us))) (env, []) bs in - match uu___1 with | (uu___2, us) -> FStar_Compiler_List.rev us in - let quant = - FStar_Syntax_Util.smt_lemma_as_forall lem_typ universe_of_binders in - FStar_TypeChecker_Util.weaken_precondition env c2 - (FStar_TypeChecker_Common.NonTrivial quant) - else c2 -and (check_inner_let : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.lcomp * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun e -> - let env1 = instantiate_both env in - match e.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (false, lb::[]); - FStar_Syntax_Syntax.body1 = e2;_} - -> - let env2 = - { - FStar_TypeChecker_Env.solver = - (env1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = false; - FStar_TypeChecker_Env.check_uvars = - (env1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (env1.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (env1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env1.FStar_TypeChecker_Env.missing_decl) - } in - let uu___ = - let uu___1 = - let uu___2 = FStar_TypeChecker_Env.clear_expected_typ env2 in - FStar_Pervasives_Native.fst uu___2 in - check_let_bound_def false uu___1 lb in - (match uu___ with - | (e1, uu___1, c1, g1, annotated) -> - let pure_or_ghost = - FStar_TypeChecker_Common.is_pure_or_ghost_lcomp c1 in - let is_inline_let = - FStar_Compiler_Util.for_some - (FStar_Syntax_Util.is_fvar - FStar_Parser_Const.inline_let_attr) - lb.FStar_Syntax_Syntax.lbattrs in - ((let uu___3 = - is_inline_let && - (let uu___4 = - pure_or_ghost || - (FStar_TypeChecker_Env.is_erasable_effect env2 - c1.FStar_TypeChecker_Common.eff_name) in - Prims.op_Negation uu___4) in - if uu___3 - then - let uu___4 = - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - e1 in - let uu___6 = - FStar_Class_Show.show FStar_Ident.showable_lident - c1.FStar_TypeChecker_Common.eff_name in - FStar_Compiler_Util.format2 - "Definitions marked @inline_let are expected to be pure or ghost; got an expression \"%s\" with effect \"%s\"" - uu___5 uu___6 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) e1 - FStar_Errors_Codes.Fatal_ExpectedPureExpression () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4) - else ()); - (let x = - let uu___3 = - FStar_Compiler_Util.left lb.FStar_Syntax_Syntax.lbname in - { - FStar_Syntax_Syntax.ppname = - (uu___3.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (uu___3.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = - (c1.FStar_TypeChecker_Common.res_typ) - } in - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.mk_binder x in [uu___5] in - FStar_Syntax_Subst.open_term uu___4 e2 in - match uu___3 with - | (xb, e21) -> - let xbinder = FStar_Compiler_List.hd xb in - let x1 = xbinder.FStar_Syntax_Syntax.binder_bv in - let env_x = FStar_TypeChecker_Env.push_bv env2 x1 in - let uu___4 = - let uu___5 = tc_term env_x e21 in - match uu___5 with - | (e22, c2, g2) -> - let uu___6 = - FStar_TypeChecker_Util.strengthen_precondition - (FStar_Pervasives_Native.Some - (fun uu___7 -> - FStar_Errors_Msg.mkmsg - "folding guard g2 of e2 in the lcomp")) - env_x e22 c2 g2 in - (match uu___6 with | (c21, g21) -> (e22, c21, g21)) in - (match uu___4 with - | (e22, c2, g2) -> - let c21 = - maybe_intro_smt_lemma env_x - c1.FStar_TypeChecker_Common.res_typ c2 in - let cres = - FStar_TypeChecker_Util.maybe_return_e2_and_bind - e1.FStar_Syntax_Syntax.pos env2 - (FStar_Pervasives_Native.Some e1) c1 e22 - ((FStar_Pervasives_Native.Some x1), c21) in - let e11 = - FStar_TypeChecker_Util.maybe_lift env2 e1 - c1.FStar_TypeChecker_Common.eff_name - cres.FStar_TypeChecker_Common.eff_name - c1.FStar_TypeChecker_Common.res_typ in - let e23 = - FStar_TypeChecker_Util.maybe_lift env2 e22 - c21.FStar_TypeChecker_Common.eff_name - cres.FStar_TypeChecker_Common.eff_name - c21.FStar_TypeChecker_Common.res_typ in - let lb1 = - let attrs = - let add_inline_let = - (Prims.op_Negation is_inline_let) && - ((pure_or_ghost && - (FStar_Syntax_Util.is_unit - c1.FStar_TypeChecker_Common.res_typ)) - || - ((FStar_TypeChecker_Env.is_erasable_effect - env2 - c1.FStar_TypeChecker_Common.eff_name) - && - (let uu___5 = - FStar_TypeChecker_Env.is_erasable_effect - env2 - cres.FStar_TypeChecker_Common.eff_name in - Prims.op_Negation uu___5))) in - if add_inline_let - then FStar_Syntax_Util.inline_let_attr :: - (lb.FStar_Syntax_Syntax.lbattrs) - else lb.FStar_Syntax_Syntax.lbattrs in - FStar_Syntax_Util.mk_letbinding - (FStar_Pervasives.Inl x1) [] - c1.FStar_TypeChecker_Common.res_typ - cres.FStar_TypeChecker_Common.eff_name e11 - attrs lb.FStar_Syntax_Syntax.lbpos in - let e3 = - let uu___5 = - let uu___6 = - let uu___7 = FStar_Syntax_Subst.close xb e23 in - { - FStar_Syntax_Syntax.lbs = (false, [lb1]); - FStar_Syntax_Syntax.body1 = uu___7 - } in - FStar_Syntax_Syntax.Tm_let uu___6 in - FStar_Syntax_Syntax.mk uu___5 - e.FStar_Syntax_Syntax.pos in - let e4 = - FStar_TypeChecker_Util.maybe_monadic env2 e3 - cres.FStar_TypeChecker_Common.eff_name - cres.FStar_TypeChecker_Common.res_typ in - let g21 = - let uu___5 = - let uu___6 = - FStar_TypeChecker_Env.norm_eff_name env2 - cres.FStar_TypeChecker_Common.eff_name in - FStar_TypeChecker_Env.is_layered_effect env2 - uu___6 in - FStar_TypeChecker_Util.close_guard_implicits env2 - uu___5 xb g2 in - let guard = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t g1 g21 in - let uu___5 = - let uu___6 = - FStar_TypeChecker_Env.expected_typ env2 in - FStar_Compiler_Option.isSome uu___6 in - if uu___5 - then - let tt = - let uu___6 = - let uu___7 = - FStar_TypeChecker_Env.expected_typ env2 in - FStar_Compiler_Option.get uu___7 in - FStar_Pervasives_Native.fst uu___6 in - ((let uu___7 = - FStar_Compiler_Effect.op_Bang dbg_Exports in - if uu___7 - then - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term tt in - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - cres.FStar_TypeChecker_Common.res_typ in - FStar_Compiler_Util.print2 - "Got expected type from env %s\ncres.res_typ=%s\n" - uu___8 uu___9 - else ()); - (e4, cres, guard)) - else - (let uu___7 = - check_no_escape FStar_Pervasives_Native.None - env2 [x1] - cres.FStar_TypeChecker_Common.res_typ in - match uu___7 with - | (t, g_ex) -> - ((let uu___9 = - FStar_Compiler_Effect.op_Bang - dbg_Exports in - if uu___9 - then - let uu___10 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - cres.FStar_TypeChecker_Common.res_typ in - let uu___11 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.print2 - "Checked %s has no escaping types; normalized to %s\n" - uu___10 uu___11 - else ()); - (let uu___9 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g_ex guard in - (e4, - { - FStar_TypeChecker_Common.eff_name = - (cres.FStar_TypeChecker_Common.eff_name); - FStar_TypeChecker_Common.res_typ = t; - FStar_TypeChecker_Common.cflags = - (cres.FStar_TypeChecker_Common.cflags); - FStar_TypeChecker_Common.comp_thunk = - (cres.FStar_TypeChecker_Common.comp_thunk) - }, uu___9)))))))) - | uu___ -> failwith "Impossible (inner let with more than one lb)" -and (check_top_level_let_rec : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.lcomp * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun top -> - let env1 = instantiate_both env in - match top.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (true, lbs); - FStar_Syntax_Syntax.body1 = e2;_} - -> - let uu___ = FStar_Syntax_Subst.open_let_rec lbs e2 in - (match uu___ with - | (lbs1, e21) -> - let uu___1 = FStar_TypeChecker_Env.clear_expected_typ env1 in - (match uu___1 with - | (env0, topt) -> - let uu___2 = build_let_rec_env true env0 lbs1 in - (match uu___2 with - | (lbs2, rec_env, g_t) -> - let uu___3 = check_let_recs rec_env lbs2 in - (match uu___3 with - | (lbs3, g_lbs) -> - let g_lbs1 = - let uu___4 = - let uu___5 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g_t g_lbs in - FStar_TypeChecker_Rel.solve_deferred_constraints - env1 uu___5 in - FStar_TypeChecker_Rel.resolve_implicits env1 - uu___4 in - let all_lb_names = - let uu___4 = - FStar_Compiler_List.map - (fun lb -> - FStar_Compiler_Util.right - lb.FStar_Syntax_Syntax.lbname) lbs3 in - FStar_Pervasives_Native.Some uu___4 in - let uu___4 = - if - Prims.op_Negation - env1.FStar_TypeChecker_Env.generalize - then - let lbs4 = - FStar_Compiler_List.map - (fun lb -> - let lbdef = - FStar_TypeChecker_Normalize.reduce_uvar_solutions - env1 - lb.FStar_Syntax_Syntax.lbdef in - if - lb.FStar_Syntax_Syntax.lbunivs = - [] - then lb - else - FStar_Syntax_Util.close_univs_and_mk_letbinding - all_lb_names - lb.FStar_Syntax_Syntax.lbname - lb.FStar_Syntax_Syntax.lbunivs - lb.FStar_Syntax_Syntax.lbtyp - lb.FStar_Syntax_Syntax.lbeff - lbdef - lb.FStar_Syntax_Syntax.lbattrs - lb.FStar_Syntax_Syntax.lbpos) - lbs3 in - (lbs4, g_lbs1) - else - (let ecs = - let uu___6 = - FStar_Compiler_List.map - (fun lb -> - let uu___7 = - FStar_Syntax_Syntax.mk_Total - lb.FStar_Syntax_Syntax.lbtyp in - ((lb.FStar_Syntax_Syntax.lbname), - (lb.FStar_Syntax_Syntax.lbdef), - uu___7)) lbs3 in - FStar_TypeChecker_Generalize.generalize - env1 true uu___6 in - let lbs4 = - FStar_Compiler_List.map2 - (fun uu___6 -> - fun lb -> - match uu___6 with - | (x, uvs, e, c, gvs) -> - FStar_Syntax_Util.close_univs_and_mk_letbinding - all_lb_names x uvs - (FStar_Syntax_Util.comp_result - c) - (FStar_Syntax_Util.comp_effect_name - c) e - lb.FStar_Syntax_Syntax.lbattrs - lb.FStar_Syntax_Syntax.lbpos) - ecs lbs3 in - let g_lbs2 = - FStar_TypeChecker_Rel.resolve_generalization_implicits - env1 g_lbs1 in - (lbs4, g_lbs2)) in - (match uu___4 with - | (lbs4, g_lbs2) -> - let cres = - let uu___5 = - FStar_Syntax_Syntax.mk_Total - FStar_Syntax_Syntax.t_unit in - FStar_TypeChecker_Common.lcomp_of_comp - uu___5 in - let uu___5 = - FStar_Syntax_Subst.close_let_rec lbs4 - e21 in - (match uu___5 with - | (lbs5, e22) -> - ((let uu___7 = - FStar_TypeChecker_Rel.discharge_guard - env1 g_lbs2 in - FStar_TypeChecker_Rel.force_trivial_guard - env1 uu___7); - (let uu___7 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = - (true, lbs5); - FStar_Syntax_Syntax.body1 - = e22 - }) - top.FStar_Syntax_Syntax.pos in - (uu___7, cres, - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t)))))))))) - | uu___ -> - failwith "Impossible: check_top_level_let_rec: not a let rec" -and (check_inner_let_rec : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.lcomp * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun top -> - let env1 = instantiate_both env in - match top.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (true, lbs); - FStar_Syntax_Syntax.body1 = e2;_} - -> - let uu___ = FStar_Syntax_Subst.open_let_rec lbs e2 in - (match uu___ with - | (lbs1, e21) -> - let uu___1 = FStar_TypeChecker_Env.clear_expected_typ env1 in - (match uu___1 with - | (env0, topt) -> - let uu___2 = build_let_rec_env false env0 lbs1 in - (match uu___2 with - | (lbs2, rec_env, g_t) -> - let uu___3 = - let uu___4 = check_let_recs rec_env lbs2 in - match uu___4 with - | (lbs3, g) -> - let uu___5 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g_t g in - (lbs3, uu___5) in - (match uu___3 with - | (lbs3, g_lbs) -> - let uu___4 = - FStar_Compiler_Util.fold_map - (fun env2 -> - fun lb -> - let x = - let uu___5 = - FStar_Compiler_Util.left - lb.FStar_Syntax_Syntax.lbname in - { - FStar_Syntax_Syntax.ppname = - (uu___5.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (uu___5.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = - (lb.FStar_Syntax_Syntax.lbtyp) - } in - let lb1 = - { - FStar_Syntax_Syntax.lbname = - (FStar_Pervasives.Inl x); - FStar_Syntax_Syntax.lbunivs = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = - (lb.FStar_Syntax_Syntax.lbtyp); - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = - (lb.FStar_Syntax_Syntax.lbdef); - FStar_Syntax_Syntax.lbattrs = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - } in - let env3 = - FStar_TypeChecker_Env.push_let_binding - env2 - lb1.FStar_Syntax_Syntax.lbname - ([], - (lb1.FStar_Syntax_Syntax.lbtyp)) in - (env3, lb1)) env1 lbs3 in - (match uu___4 with - | (env2, lbs4) -> - let bvs = - FStar_Compiler_List.map - (fun lb -> - FStar_Compiler_Util.left - lb.FStar_Syntax_Syntax.lbname) - lbs4 in - let uu___5 = tc_term env2 e21 in - (match uu___5 with - | (e22, cres, g2) -> - let cres1 = - FStar_Compiler_List.fold_right - (fun lb -> - fun cres2 -> - maybe_intro_smt_lemma env2 - lb.FStar_Syntax_Syntax.lbtyp - cres2) lbs4 cres in - let cres2 = - FStar_TypeChecker_Util.maybe_assume_result_eq_pure_term - env2 e22 cres1 in - let cres3 = - FStar_TypeChecker_Common.lcomp_set_flags - cres2 - [FStar_Syntax_Syntax.SHOULD_NOT_INLINE] in - let guard = - let uu___6 = - let uu___7 = - FStar_Compiler_List.map - FStar_Syntax_Syntax.mk_binder - bvs in - FStar_TypeChecker_Env.close_guard - env2 uu___7 g2 in - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g_lbs uu___6 in - let cres4 = - let uu___6 = - let uu___7 = - FStar_TypeChecker_Env.norm_eff_name - env2 - cres3.FStar_TypeChecker_Common.eff_name in - FStar_TypeChecker_Env.is_layered_effect - env2 uu___7 in - if uu___6 - then - let bvss = - Obj.magic - (FStar_Class_Setlike.from_list - () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) - bvs) in - FStar_TypeChecker_Common.apply_lcomp - (fun c -> - let uu___7 = - let uu___8 = - FStar_Syntax_Util.comp_effect_args - c in - FStar_Compiler_List.existsb - (fun uu___9 -> - match uu___9 with - | (t, uu___10) -> - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Syntax_Free.names - t in - Obj.magic - (FStar_Class_Setlike.inter - () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) - (Obj.magic - bvss) - (Obj.magic - uu___13)) in - FStar_Class_Setlike.is_empty - () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) - (Obj.magic - uu___12) in - Prims.op_Negation - uu___11) uu___8 in - if uu___7 - then - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax - ()) top - FStar_Errors_Codes.Fatal_EscapedBoundVar - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "One of the inner let recs escapes in the effect argument(s), try adding a type annotation") - else c) (fun g -> g) cres3 - else - FStar_TypeChecker_Util.close_wp_lcomp - env2 bvs cres3 in - let tres = - norm env2 - cres4.FStar_TypeChecker_Common.res_typ in - let cres5 = - { - FStar_TypeChecker_Common.eff_name - = - (cres4.FStar_TypeChecker_Common.eff_name); - FStar_TypeChecker_Common.res_typ - = tres; - FStar_TypeChecker_Common.cflags = - (cres4.FStar_TypeChecker_Common.cflags); - FStar_TypeChecker_Common.comp_thunk - = - (cres4.FStar_TypeChecker_Common.comp_thunk) - } in - let guard1 = - let bs = - FStar_Compiler_List.map - (fun lb -> - let uu___6 = - FStar_Compiler_Util.left - lb.FStar_Syntax_Syntax.lbname in - FStar_Syntax_Syntax.mk_binder - uu___6) lbs4 in - FStar_TypeChecker_Util.close_guard_implicits - env2 false bs guard in - let uu___6 = - FStar_Syntax_Subst.close_let_rec - lbs4 e22 in - (match uu___6 with - | (lbs5, e23) -> - let e = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs - = (true, lbs5); - FStar_Syntax_Syntax.body1 - = e23 - }) - top.FStar_Syntax_Syntax.pos in - (match topt with - | FStar_Pervasives_Native.Some - uu___7 -> - (e, cres5, guard1) - | FStar_Pervasives_Native.None - -> - let uu___7 = - check_no_escape - FStar_Pervasives_Native.None - env2 bvs tres in - (match uu___7 with - | (tres1, g_ex) -> - let cres6 = - { - FStar_TypeChecker_Common.eff_name - = - (cres5.FStar_TypeChecker_Common.eff_name); - FStar_TypeChecker_Common.res_typ - = tres1; - FStar_TypeChecker_Common.cflags - = - (cres5.FStar_TypeChecker_Common.cflags); - FStar_TypeChecker_Common.comp_thunk - = - (cres5.FStar_TypeChecker_Common.comp_thunk) - } in - let uu___8 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g_ex guard1 in - (e, cres6, uu___8)))))))))) - | uu___ -> failwith "Impossible: check_inner_let_rec: not a let rec" -and (build_let_rec_env : - Prims.bool -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.letbinding Prims.list -> - (FStar_Syntax_Syntax.letbinding Prims.list * - FStar_TypeChecker_Env.env_t * FStar_TypeChecker_Env.guard_t)) - = - fun _top_level -> - fun env -> - fun lbs -> - let env0 = env in - let termination_check_enabled attrs lbname lbdef lbtyp = - let uu___ = FStar_Options.ml_ish () in - if uu___ - then FStar_Pervasives_Native.None - else - (let lbtyp0 = lbtyp in - let uu___2 = FStar_Syntax_Util.abs_formals lbdef in - match uu___2 with - | (actuals, body, body_lc) -> - let actuals1 = - let uu___3 = - FStar_TypeChecker_Env.set_expected_typ env lbtyp in - FStar_TypeChecker_Util.maybe_add_implicit_binders uu___3 - actuals in - let nactuals = FStar_Compiler_List.length actuals1 in - let uu___3 = - FStar_TypeChecker_Normalize.get_n_binders env nactuals - lbtyp in - (match uu___3 with - | (formals, c) -> - (if - (FStar_Compiler_List.isEmpty formals) || - (FStar_Compiler_List.isEmpty actuals1) - then - (let uu___5 = - let uu___6 = - FStar_Class_Tagged.tag_of - FStar_Syntax_Syntax.tagged_term lbdef in - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term lbdef in - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term lbtyp in - FStar_Compiler_Util.format3 - "Only function literals with arrow types can be defined recursively; got (%s) %s : %s" - uu___6 uu___7 uu___8 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) lbtyp - FStar_Errors_Codes.Fatal_RecursiveFunctionLiteral - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___5)) - else (); - (let nformals = FStar_Compiler_List.length formals in - let uu___5 = - FStar_Syntax_Util.has_attribute attrs - FStar_Parser_Const.admit_termination_lid in - if uu___5 - then - ((let uu___7 = - let uu___8 = - FStar_Class_Show.show - (FStar_Class_Show.show_either - FStar_Syntax_Print.showable_bv - FStar_Syntax_Print.showable_fv) lbname in - Prims.strcat "Admitting termination of " uu___8 in - FStar_Errors.log_issue - FStar_TypeChecker_Env.hasRange_env env - FStar_Errors_Codes.Warning_WarnOnUse () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___7)); - FStar_Pervasives_Native.None) - else - (let uu___7 = - let uu___8 = - FStar_TypeChecker_Env.lookup_effect_quals env - (FStar_Syntax_Util.comp_effect_name c) in - FStar_Compiler_List.contains - FStar_Syntax_Syntax.TotalEffect uu___8 in - if uu___7 - then - let uu___8 = - let uu___9 = - FStar_Syntax_Util.abs actuals1 body body_lc in - (nformals, uu___9) in - FStar_Pervasives_Native.Some uu___8 - else FStar_Pervasives_Native.None))))) in - let check_annot univ_vars t = - let env01 = FStar_TypeChecker_Env.push_univ_vars env0 univ_vars in - let uu___ = - let uu___1 = - let uu___2 = FStar_Syntax_Util.type_u () in - FStar_Pervasives_Native.fst uu___2 in - tc_check_tot_or_gtot_term - { - FStar_TypeChecker_Env.solver = - (env01.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env01.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env01.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env01.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env01.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env01.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env01.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env01.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env01.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env01.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env01.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env01.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env01.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env01.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env01.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = true; - FStar_TypeChecker_Env.use_eq_strict = - (env01.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env01.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (env01.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env01.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env01.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env01.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env01.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env01.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env01.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env01.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env01.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env01.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env01.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env01.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env01.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env01.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env01.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env01.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env01.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env01.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env01.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env01.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env01.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env01.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env01.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env01.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env01.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env01.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (env01.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env01.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env01.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env01.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env01.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env01.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env01.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env01.FStar_TypeChecker_Env.missing_decl) - } t uu___1 FStar_Pervasives_Native.None in - match uu___ with - | (t1, uu___1, g) -> - let uu___2 = - let uu___3 = FStar_TypeChecker_Rel.resolve_implicits env g in - FStar_TypeChecker_Rel.discharge_guard env01 uu___3 in - (env01, uu___2, t1) in - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun lb -> - match uu___1 with - | (lbs1, env1, g_acc) -> - let uu___2 = - FStar_TypeChecker_Util.extract_let_rec_annotation env1 - lb in - (match uu___2 with - | (univ_vars, lbtyp, lbdef, check_t) -> - let env2 = - FStar_TypeChecker_Env.push_univ_vars env1 - univ_vars in - let uu___3 = - if Prims.op_Negation check_t - then (g_acc, lbtyp) - else - (let uu___5 = check_annot univ_vars lbtyp in - match uu___5 with - | (uu___6, g, t) -> - let uu___7 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g_acc g in - (uu___7, t)) in - (match uu___3 with - | (g, lbtyp1) -> - let uu___4 = - let uu___5 = - termination_check_enabled - lb.FStar_Syntax_Syntax.lbattrs - lb.FStar_Syntax_Syntax.lbname lbdef - lbtyp1 in - match uu___5 with - | FStar_Pervasives_Native.Some - (arity, lbdef1) -> - ((let uu___7 = - FStar_Compiler_Debug.extreme () in - if uu___7 - then - let uu___8 = - FStar_Compiler_Util.string_of_int - arity in - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - lbdef1 in - FStar_Compiler_Util.print2 - "termination_check_enabled returned arity: %s and lbdef: %s\n" - uu___8 uu___9 - else ()); - (let lb1 = - { - FStar_Syntax_Syntax.lbname = - (lb.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs = - univ_vars; - FStar_Syntax_Syntax.lbtyp = lbtyp1; - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = lbdef1; - FStar_Syntax_Syntax.lbattrs = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - } in - let env3 = - { - FStar_TypeChecker_Env.solver = - (env2.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env2.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env2.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env2.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env2.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache - = - (env2.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env2.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ - = - (env2.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env2.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env2.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp - = - (env2.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env2.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env2.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (((lb1.FStar_Syntax_Syntax.lbname), - arity, lbtyp1, univ_vars) :: - (env2.FStar_TypeChecker_Env.letrecs)); - FStar_TypeChecker_Env.top_level = - (env2.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars - = - (env2.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict - = - (env2.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env2.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (env2.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes - = - (env2.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env2.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env2.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking - = - (env2.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping - = - (env2.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env2.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env2.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env2.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (env2.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of - = - (env2.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env2.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force - = - (env2.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (env2.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (env2.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (env2.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths - = - (env2.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env2.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env2.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (env2.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env2.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess - = - (env2.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess - = - (env2.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info - = - (env2.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env2.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env2.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env2.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab - = - (env2.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (env2.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (env2.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (env2.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (env2.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env2.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl - = - (env2.FStar_TypeChecker_Env.missing_decl) - } in - (lb1, env3))) - | FStar_Pervasives_Native.None -> - let lb1 = - { - FStar_Syntax_Syntax.lbname = - (lb.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs = - univ_vars; - FStar_Syntax_Syntax.lbtyp = lbtyp1; - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = lbdef; - FStar_Syntax_Syntax.lbattrs = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - } in - let uu___6 = - FStar_TypeChecker_Env.push_let_binding - env2 lb1.FStar_Syntax_Syntax.lbname - (univ_vars, lbtyp1) in - (lb1, uu___6) in - (match uu___4 with - | (lb1, env3) -> ((lb1 :: lbs1), env3, g))))) - ([], env, - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t)) lbs in - match uu___ with - | (lbs1, env1, g) -> ((FStar_Compiler_List.rev lbs1), env1, g) -and (check_let_recs : - FStar_TypeChecker_Env.env_t -> - FStar_Syntax_Syntax.letbinding Prims.list -> - (FStar_Syntax_Syntax.letbinding Prims.list * - FStar_TypeChecker_Common.guard_t)) - = - fun env -> - fun lbts -> - let uu___ = - let uu___1 = - FStar_Compiler_List.map - (fun lb -> - let uu___2 = - FStar_Syntax_Util.abs_formals lb.FStar_Syntax_Syntax.lbdef in - match uu___2 with - | (bs, t, lcomp) -> - (match bs with - | [] -> - let uu___3 = - FStar_Syntax_Syntax.range_of_lbname - lb.FStar_Syntax_Syntax.lbname in - let uu___4 = - let uu___5 = - FStar_Class_Show.show - (FStar_Class_Show.show_either - FStar_Syntax_Print.showable_bv - FStar_Syntax_Print.showable_fv) - lb.FStar_Syntax_Syntax.lbname in - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - lb.FStar_Syntax_Syntax.lbdef in - FStar_Compiler_Util.format2 - "Only function literals may be defined recursively; %s is defined to be %s" - uu___5 uu___6 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range uu___3 - FStar_Errors_Codes.Fatal_RecursiveFunctionLiteral - () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4) - | uu___3 -> - let arity = - let uu___4 = - FStar_TypeChecker_Env.get_letrec_arity env - lb.FStar_Syntax_Syntax.lbname in - match uu___4 with - | FStar_Pervasives_Native.Some n -> n - | FStar_Pervasives_Native.None -> - FStar_Compiler_List.length bs in - let uu___4 = FStar_Compiler_List.splitAt arity bs in - (match uu___4 with - | (bs0, bs1) -> - let def = - if FStar_Compiler_List.isEmpty bs1 - then FStar_Syntax_Util.abs bs0 t lcomp - else - (let inner = - FStar_Syntax_Util.abs bs1 t lcomp in - let inner1 = - FStar_Syntax_Subst.close bs0 inner in - let bs01 = - FStar_Syntax_Subst.close_binders bs0 in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = bs01; - FStar_Syntax_Syntax.body = inner1; - FStar_Syntax_Syntax.rc_opt = - FStar_Pervasives_Native.None - }) inner1.FStar_Syntax_Syntax.pos) in - let lb1 = - { - FStar_Syntax_Syntax.lbname = - (lb.FStar_Syntax_Syntax.lbname); - FStar_Syntax_Syntax.lbunivs = - (lb.FStar_Syntax_Syntax.lbunivs); - FStar_Syntax_Syntax.lbtyp = - (lb.FStar_Syntax_Syntax.lbtyp); - FStar_Syntax_Syntax.lbeff = - (lb.FStar_Syntax_Syntax.lbeff); - FStar_Syntax_Syntax.lbdef = def; - FStar_Syntax_Syntax.lbattrs = - (lb.FStar_Syntax_Syntax.lbattrs); - FStar_Syntax_Syntax.lbpos = - (lb.FStar_Syntax_Syntax.lbpos) - } in - let uu___5 = - let uu___6 = - FStar_TypeChecker_Env.set_expected_typ env - lb1.FStar_Syntax_Syntax.lbtyp in - tc_tot_or_gtot_term uu___6 - lb1.FStar_Syntax_Syntax.lbdef in - (match uu___5 with - | (e, c, g) -> - ((let uu___7 = - let uu___8 = - FStar_TypeChecker_Common.is_total_lcomp - c in - Prims.op_Negation uu___8 in - if uu___7 - then - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax - ()) e - FStar_Errors_Codes.Fatal_UnexpectedGTotForLetRec - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Expected let rec to be a Tot term; got effect GTot") - else ()); - (let lb2 = - FStar_Syntax_Util.mk_letbinding - lb1.FStar_Syntax_Syntax.lbname - lb1.FStar_Syntax_Syntax.lbunivs - lb1.FStar_Syntax_Syntax.lbtyp - FStar_Parser_Const.effect_Tot_lid e - lb1.FStar_Syntax_Syntax.lbattrs - lb1.FStar_Syntax_Syntax.lbpos in - (lb2, g))))))) lbts in - FStar_Compiler_List.unzip uu___1 in - match uu___ with - | (lbs, gs) -> - let uu___1 = - FStar_Class_Monoid.msum FStar_TypeChecker_Common.monoid_guard_t - gs in - (lbs, uu___1) -and (check_let_bound_def : - Prims.bool -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.letbinding -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.univ_names * - FStar_TypeChecker_Common.lcomp * FStar_TypeChecker_Env.guard_t * - Prims.bool)) - = - fun top_level -> - fun env -> - fun lb -> - let uu___ = FStar_TypeChecker_Env.clear_expected_typ env in - match uu___ with - | (env1, uu___1) -> - let e1 = lb.FStar_Syntax_Syntax.lbdef in - let uu___2 = check_lbtyp top_level env lb in - (match uu___2 with - | (topt, wf_annot, univ_vars, univ_opening, env11) -> - (if (Prims.op_Negation top_level) && (univ_vars <> []) - then - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) e1 - FStar_Errors_Codes.Fatal_UniversePolymorphicInnerLetBound - () (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Inner let-bound definitions cannot be universe polymorphic") - else (); - (let e11 = FStar_Syntax_Subst.subst univ_opening e1 in - let uu___4 = - tc_maybe_toplevel_term - { - FStar_TypeChecker_Env.solver = - (env11.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env11.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env11.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env11.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env11.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env11.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env11.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env11.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env11.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env11.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env11.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env11.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env11.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env11.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = top_level; - FStar_TypeChecker_Env.check_uvars = - (env11.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env11.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env11.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (env11.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env11.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env11.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env11.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env11.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env11.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env11.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env11.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env11.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env11.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env11.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env11.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env11.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env11.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env11.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env11.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env11.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env11.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env11.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env11.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env11.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env11.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env11.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env11.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env11.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env11.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env11.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env11.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env11.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env11.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env11.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env11.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env11.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env11.FStar_TypeChecker_Env.missing_decl) - } e11 in - match uu___4 with - | (e12, c1, g1) -> - let uu___5 = - let uu___6 = - FStar_TypeChecker_Env.set_range env11 - e12.FStar_Syntax_Syntax.pos in - FStar_TypeChecker_Util.strengthen_precondition - (FStar_Pervasives_Native.Some - (fun uu___7 -> - FStar_Compiler_Util.return_all - FStar_TypeChecker_Err.ill_kinded_type)) - uu___6 e12 c1 wf_annot in - (match uu___5 with - | (c11, guard_f) -> - let g11 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t g1 - guard_f in - ((let uu___7 = FStar_Compiler_Debug.extreme () in - if uu___7 - then - let uu___8 = - FStar_Class_Show.show - (FStar_Class_Show.show_either - FStar_Syntax_Print.showable_bv - FStar_Syntax_Print.showable_fv) - lb.FStar_Syntax_Syntax.lbname in - let uu___9 = - FStar_TypeChecker_Common.lcomp_to_string - c11 in - let uu___10 = - FStar_TypeChecker_Rel.guard_to_string env - g11 in - FStar_Compiler_Util.print3 - "checked let-bound def %s : %s guard is %s\n" - uu___8 uu___9 uu___10 - else ()); - (e12, univ_vars, c11, g11, - (FStar_Compiler_Option.isSome topt))))))) -and (check_lbtyp : - Prims.bool -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.letbinding -> - (FStar_Syntax_Syntax.typ FStar_Pervasives_Native.option * - FStar_TypeChecker_Env.guard_t * FStar_Syntax_Syntax.univ_names * - FStar_Syntax_Syntax.subst_elt Prims.list * - FStar_TypeChecker_Env.env)) - = - fun top_level -> - fun env -> - fun lb -> - FStar_Errors.with_ctx - "While checking type annotation of a letbinding" - (fun uu___ -> - let t = FStar_Syntax_Subst.compress lb.FStar_Syntax_Syntax.lbtyp in - match t.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_unknown -> - let uu___1 = - FStar_Syntax_Subst.univ_var_opening - lb.FStar_Syntax_Syntax.lbunivs in - (match uu___1 with - | (univ_opening, univ_vars) -> - let uu___2 = - FStar_TypeChecker_Env.push_univ_vars env univ_vars in - (FStar_Pervasives_Native.None, - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t), - univ_vars, univ_opening, uu___2)) - | uu___1 -> - let uu___2 = - FStar_Syntax_Subst.univ_var_opening - lb.FStar_Syntax_Syntax.lbunivs in - (match uu___2 with - | (univ_opening, univ_vars) -> - let t1 = FStar_Syntax_Subst.subst univ_opening t in - let env1 = - FStar_TypeChecker_Env.push_univ_vars env univ_vars in - if - top_level && - (Prims.op_Negation - env.FStar_TypeChecker_Env.generalize) - then - let uu___3 = - FStar_TypeChecker_Env.set_expected_typ env1 t1 in - ((FStar_Pervasives_Native.Some t1), - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t), - univ_vars, univ_opening, uu___3) - else - (let uu___4 = FStar_Syntax_Util.type_u () in - match uu___4 with - | (k, uu___5) -> - let uu___6 = - tc_check_tot_or_gtot_term env1 t1 k - FStar_Pervasives_Native.None in - (match uu___6 with - | (t2, uu___7, g) -> - ((let uu___9 = - FStar_Compiler_Debug.medium () in - if uu___9 - then - let uu___10 = - let uu___11 = - FStar_Syntax_Syntax.range_of_lbname - lb.FStar_Syntax_Syntax.lbname in - FStar_Compiler_Range_Ops.string_of_range - uu___11 in - let uu___11 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t2 in - FStar_Compiler_Util.print2 - "(%s) Checked type annotation %s\n" - uu___10 uu___11 - else ()); - (let t3 = norm env1 t2 in - let uu___9 = - FStar_TypeChecker_Env.set_expected_typ - env1 t3 in - ((FStar_Pervasives_Native.Some t3), g, - univ_vars, univ_opening, uu___9))))))) -and (tc_binder : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.binder -> - (FStar_Syntax_Syntax.binder * FStar_TypeChecker_Env.env * - FStar_TypeChecker_Common.guard_t * FStar_Syntax_Syntax.universe)) - = - fun env -> - fun uu___ -> - match uu___ with - | { FStar_Syntax_Syntax.binder_bv = x; - FStar_Syntax_Syntax.binder_qual = imp; - FStar_Syntax_Syntax.binder_positivity = pqual; - FStar_Syntax_Syntax.binder_attrs = attrs;_} -> - let uu___1 = FStar_Syntax_Util.type_u () in - (match uu___1 with - | (tu, u) -> - ((let uu___3 = FStar_Compiler_Debug.extreme () in - if uu___3 - then - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_bv x in - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - x.FStar_Syntax_Syntax.sort in - let uu___6 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - tu in - FStar_Compiler_Util.print3 - "Checking binder %s:%s at type %s\n" uu___4 uu___5 - uu___6 - else ()); - (let uu___3 = - tc_check_tot_or_gtot_term env x.FStar_Syntax_Syntax.sort - tu FStar_Pervasives_Native.None in - match uu___3 with - | (t, uu___4, g) -> - let uu___5 = - match imp with - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Meta tau) -> - let uu___6 = - tc_tactic FStar_Syntax_Syntax.t_unit - FStar_Syntax_Syntax.t_unit env tau in - (match uu___6 with - | (tau1, uu___7, g1) -> - ((FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Meta tau1)), g1)) - | uu___6 -> - (imp, - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t)) in - (match uu___5 with - | (imp1, g') -> - let uu___6 = tc_attributes env attrs in - (match uu___6 with - | (g_attrs, attrs1) -> - let g1 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t g - g_attrs in - (check_erasable_binder_attributes env attrs1 t; - (let x1 = - FStar_Syntax_Syntax.mk_binder_with_attrs - { - FStar_Syntax_Syntax.ppname = - (x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (x.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = t - } imp1 pqual attrs1 in - (let uu___9 = FStar_Compiler_Debug.high () in - if uu___9 - then - let uu___10 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_bv - x1.FStar_Syntax_Syntax.binder_bv in - let uu___11 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.print2 - "Pushing binder %s at type %s\n" - uu___10 uu___11 - else ()); - (let uu___9 = push_binding env x1 in - (x1, uu___9, g1, u))))))))) -and (tc_binders : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.binders -> - (FStar_Syntax_Syntax.binders * FStar_TypeChecker_Env.env * - FStar_TypeChecker_Env.guard_t * FStar_Syntax_Syntax.universes)) - = - fun env -> - fun bs -> - (let uu___1 = FStar_Compiler_Debug.extreme () in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show - (FStar_Class_Show.show_list FStar_Syntax_Print.showable_binder) - bs in - FStar_Compiler_Util.print1 "Checking binders %s\n" uu___2 - else ()); - (let rec aux env1 bs1 = - match bs1 with - | [] -> - ([], env1, - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t), []) - | b::bs2 -> - let uu___1 = tc_binder env1 b in - (match uu___1 with - | (b1, env', g, u) -> - let uu___2 = aux env' bs2 in - (match uu___2 with - | (bs3, env'1, g', us) -> - let uu___3 = - let uu___4 = - FStar_TypeChecker_Env.close_guard_univs [u] - [b1] g' in - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t g uu___4 in - ((b1 :: bs3), env'1, uu___3, (u :: us)))) in - aux env bs) -and (tc_smt_pats : - FStar_TypeChecker_Env.env -> - (FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) - Prims.list Prims.list -> - ((FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * - FStar_Syntax_Syntax.arg_qualifier FStar_Pervasives_Native.option) - Prims.list Prims.list * FStar_TypeChecker_Common.guard_t)) - = - fun en -> - fun pats -> - let tc_args en1 args = - FStar_Compiler_List.fold_right - (fun uu___ -> - fun uu___1 -> - match (uu___, uu___1) with - | ((t, imp), (args1, g)) -> - (check_no_smt_theory_symbols en1 t; - (let uu___3 = tc_term en1 t in - match uu___3 with - | (t1, uu___4, g') -> - let uu___5 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t g g' in - (((t1, imp) :: args1), uu___5)))) args - ([], - (FStar_Class_Monoid.mzero FStar_TypeChecker_Common.monoid_guard_t)) in - FStar_Compiler_List.fold_right - (fun p -> - fun uu___ -> - match uu___ with - | (pats1, g) -> - let uu___1 = tc_args en p in - (match uu___1 with - | (args, g') -> - let uu___2 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t g g' in - ((args :: pats1), uu___2))) pats - ([], - (FStar_Class_Monoid.mzero FStar_TypeChecker_Common.monoid_guard_t)) -and (tc_tot_or_gtot_term_maybe_solve_deferred : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - Prims.string FStar_Pervasives_Native.option -> - Prims.bool -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.lcomp * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun e -> - fun msg -> - fun solve_deferred -> - let uu___ = tc_maybe_toplevel_term env e in - match uu___ with - | (e1, c, g) -> - let uu___1 = FStar_TypeChecker_Common.is_tot_or_gtot_lcomp c in - if uu___1 - then (e1, c, g) - else - (let g1 = - if solve_deferred - then - FStar_TypeChecker_Rel.solve_deferred_constraints env g - else g in - let uu___3 = FStar_TypeChecker_Common.lcomp_comp c in - match uu___3 with - | (c1, g_c) -> - let c2 = norm_c env c1 in - let uu___4 = - let uu___5 = - FStar_TypeChecker_Util.is_pure_effect env - (FStar_Syntax_Util.comp_effect_name c2) in - if uu___5 - then - let uu___6 = - FStar_Syntax_Syntax.mk_Total - (FStar_Syntax_Util.comp_result c2) in - (uu___6, false) - else - (let uu___7 = - FStar_Syntax_Syntax.mk_GTotal - (FStar_Syntax_Util.comp_result c2) in - (uu___7, true)) in - (match uu___4 with - | (target_comp, allow_ghost) -> - let uu___5 = - FStar_TypeChecker_Rel.sub_comp env c2 target_comp in - (match uu___5 with - | FStar_Pervasives_Native.Some g' -> - let uu___6 = - FStar_TypeChecker_Common.lcomp_of_comp - target_comp in - let uu___7 = - let uu___8 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g_c g' in - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t g1 - uu___8 in - (e1, uu___6, uu___7) - | uu___6 -> - if allow_ghost - then - FStar_TypeChecker_Err.expected_ghost_expression - e1.FStar_Syntax_Syntax.pos e1 c2 msg - else - FStar_TypeChecker_Err.expected_pure_expression - e1.FStar_Syntax_Syntax.pos e1 c2 msg))) -and (tc_tot_or_gtot_term' : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - Prims.string FStar_Pervasives_Native.option -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.lcomp * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun e -> - fun msg -> tc_tot_or_gtot_term_maybe_solve_deferred env e msg true -and (tc_tot_or_gtot_term : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.lcomp * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> fun e -> tc_tot_or_gtot_term' env e FStar_Pervasives_Native.None -and (tc_check_tot_or_gtot_term : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.typ -> - Prims.string FStar_Pervasives_Native.option -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.lcomp * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun e -> - fun t -> - fun msg -> - let env1 = FStar_TypeChecker_Env.set_expected_typ env t in - tc_tot_or_gtot_term' env1 e msg -and (tc_trivial_guard : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.lcomp)) - = - fun env -> - fun t -> - let uu___ = tc_tot_or_gtot_term env t in - match uu___ with - | (t1, c, g) -> - (FStar_TypeChecker_Rel.force_trivial_guard env g; (t1, c)) -and (tc_attributes : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term Prims.list -> - (FStar_TypeChecker_Env.guard_t * FStar_Syntax_Syntax.term Prims.list)) - = - fun env -> - fun attrs -> - FStar_Compiler_List.fold_left - (fun uu___ -> - fun attr -> - match uu___ with - | (g, attrs1) -> - let uu___1 = tc_tot_or_gtot_term env attr in - (match uu___1 with - | (attr', uu___2, g') -> - let uu___3 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t g g' in - (uu___3, (attr' :: attrs1)))) - ((FStar_Class_Monoid.mzero FStar_TypeChecker_Common.monoid_guard_t), - []) (FStar_Compiler_List.rev attrs) -let (tc_check_trivial_guard : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun env -> - fun t -> - fun k -> - let uu___ = - tc_check_tot_or_gtot_term env t k FStar_Pervasives_Native.None in - match uu___ with - | (t1, uu___1, g) -> - (FStar_TypeChecker_Rel.force_trivial_guard env g; t1) -let (typeof_tot_or_gtot_term : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - Prims.bool -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.typ * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun e -> - fun must_tot -> - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_RelCheck in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - FStar_Compiler_Util.print1 "Checking term %s\n" uu___2 - else ()); - (let env1 = - { - FStar_TypeChecker_Env.solver = - (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = (env.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = []; - FStar_TypeChecker_Env.top_level = false; - FStar_TypeChecker_Env.check_uvars = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = (env.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env.FStar_TypeChecker_Env.missing_decl) - } in - let uu___1 = - try - (fun uu___2 -> match () with | () -> tc_tot_or_gtot_term env1 e) - () - with - | FStar_Errors.Error (e1, msg, r, ctx) when - r = FStar_Compiler_Range_Type.dummyRange -> - let uu___3 = - let uu___4 = - let uu___5 = FStar_TypeChecker_Env.get_range env1 in - (e1, msg, uu___5, ctx) in - FStar_Errors.Error uu___4 in - FStar_Compiler_Effect.raise uu___3 in - match uu___1 with - | (t, c, g) -> - if must_tot - then - let c1 = - FStar_TypeChecker_Normalize.maybe_ghost_to_pure_lcomp env1 c in - let uu___2 = FStar_TypeChecker_Common.is_total_lcomp c1 in - (if uu___2 - then (t, (c1.FStar_TypeChecker_Common.res_typ), g) - else - (let uu___4 = - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - e in - FStar_Compiler_Util.format1 - "Implicit argument: Expected a total term; got a ghost term: %s" - uu___5 in - FStar_Errors.raise_error - FStar_TypeChecker_Env.hasRange_env env1 - FStar_Errors_Codes.Fatal_UnexpectedImplictArgument () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4))) - else (t, (c.FStar_TypeChecker_Common.res_typ), g)) -let level_of_type_fail : - 'uuuuu . - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> Prims.string -> 'uuuuu - = - fun env -> - fun e -> - fun t -> - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - FStar_Compiler_Util.format2 - "Expected a type; got %s of type %s" uu___3 t in - FStar_Errors_Msg.text uu___2 in - [uu___1] in - FStar_Errors.raise_error FStar_TypeChecker_Env.hasRange_env env - FStar_Errors_Codes.Fatal_UnexpectedTermType () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___) -let (level_of_type : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.universe) - = - fun env -> - fun e -> - fun t -> - let rec aux retry t1 = - let uu___ = - let uu___1 = FStar_Syntax_Util.unrefine t1 in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_type u -> u - | uu___1 -> - if retry - then - let t2 = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant] env t1 in - aux false t2 - else - (let uu___3 = FStar_Syntax_Util.type_u () in - match uu___3 with - | (t_u, u) -> - let env1 = - { - FStar_TypeChecker_Env.solver = - (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = true; - FStar_TypeChecker_Env.lax_universes = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env.FStar_TypeChecker_Env.missing_decl) - } in - let g = FStar_TypeChecker_Rel.teq env1 t1 t_u in - ((match g.FStar_TypeChecker_Common.guard_f with - | FStar_TypeChecker_Common.NonTrivial f -> - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t1 in - level_of_type_fail env1 e uu___5 - | uu___5 -> - FStar_TypeChecker_Rel.force_trivial_guard env1 g); - u)) in - aux true t -let rec (apply_well_typed : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.typ FStar_Pervasives_Native.option) - = - fun env -> - fun t_hd -> - fun args -> - if (FStar_Compiler_List.length args) = Prims.int_zero - then FStar_Pervasives_Native.Some t_hd - else - (let uu___1 = - let uu___2 = FStar_TypeChecker_Normalize.unfold_whnf env t_hd in - uu___2.FStar_Syntax_Syntax.n in - match uu___1 with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; - FStar_Syntax_Syntax.comp = c;_} - -> - let n_args = FStar_Compiler_List.length args in - let n_bs = FStar_Compiler_List.length bs in - let uu___2 = - if n_args < n_bs - then - let uu___3 = FStar_Compiler_Util.first_N n_args bs in - match uu___3 with - | (bs1, rest) -> - let t = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_arrow - { - FStar_Syntax_Syntax.bs1 = rest; - FStar_Syntax_Syntax.comp = c - }) t_hd.FStar_Syntax_Syntax.pos in - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.mk_Total t in - FStar_Syntax_Subst.open_comp bs1 uu___5 in - (match uu___4 with - | (bs2, c1) -> - (bs2, args, (FStar_Syntax_Util.comp_result c1), - [])) - else - (let uu___4 = FStar_Syntax_Subst.open_comp bs c in - match uu___4 with - | (bs1, c1) -> - let uu___5 = FStar_Compiler_List.splitAt n_bs args in - (match uu___5 with - | (args1, remaining_args) -> - (bs1, args1, (FStar_Syntax_Util.comp_result c1), - remaining_args))) in - (match uu___2 with - | (bs1, args1, t, remaining_args) -> - let subst = - FStar_Compiler_List.map2 - (fun b -> - fun a -> - FStar_Syntax_Syntax.NT - ((b.FStar_Syntax_Syntax.binder_bv), - (FStar_Pervasives_Native.fst a))) bs1 args1 in - let t1 = FStar_Syntax_Subst.subst subst t in - apply_well_typed env t1 remaining_args) - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x; - FStar_Syntax_Syntax.phi = uu___2;_} - -> apply_well_typed env x.FStar_Syntax_Syntax.sort args - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t; - FStar_Syntax_Syntax.asc = uu___2; - FStar_Syntax_Syntax.eff_opt = uu___3;_} - -> apply_well_typed env t args - | uu___2 -> FStar_Pervasives_Native.None) -let rec (universe_of_aux : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term) - = - fun env -> - fun e -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress e in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_bvar uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - Prims.strcat "TcTerm.universe_of:Impossible (bvar/unknown/lazy) " - uu___3 in - failwith uu___2 - | FStar_Syntax_Syntax.Tm_unknown -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - Prims.strcat "TcTerm.universe_of:Impossible (bvar/unknown/lazy) " - uu___2 in - failwith uu___1 - | FStar_Syntax_Syntax.Tm_delayed uu___1 -> - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - Prims.strcat "TcTerm.universe_of:Impossible (bvar/unknown/lazy) " - uu___3 in - failwith uu___2 - | FStar_Syntax_Syntax.Tm_let uu___1 -> - let e1 = FStar_TypeChecker_Normalize.normalize [] env e in - universe_of_aux env e1 - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs; FStar_Syntax_Syntax.body = t; - FStar_Syntax_Syntax.rc_opt = uu___1;_} - -> level_of_type_fail env e "arrow type" - | FStar_Syntax_Syntax.Tm_uvar (u, s) -> - let uu___1 = FStar_Syntax_Util.ctx_uvar_typ u in - FStar_Syntax_Subst.subst' s uu___1 - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t; FStar_Syntax_Syntax.meta = uu___1;_} - -> universe_of_aux env t - | FStar_Syntax_Syntax.Tm_name n -> - let uu___1 = FStar_TypeChecker_Env.lookup_bv env n in - (match uu___1 with | (t, _rng) -> t) - | FStar_Syntax_Syntax.Tm_fvar fv -> - let uu___1 = - FStar_TypeChecker_Env.lookup_lid env - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - (match uu___1 with | ((uu___2, t), uu___3) -> t) - | FStar_Syntax_Syntax.Tm_lazy i -> - let uu___1 = FStar_Syntax_Util.unfold_lazy i in - universe_of_aux env uu___1 - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = uu___1; - FStar_Syntax_Syntax.asc = - (FStar_Pervasives.Inl t, uu___2, uu___3); - FStar_Syntax_Syntax.eff_opt = uu___4;_} - -> t - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = uu___1; - FStar_Syntax_Syntax.asc = - (FStar_Pervasives.Inr c, uu___2, uu___3); - FStar_Syntax_Syntax.eff_opt = uu___4;_} - -> FStar_Syntax_Util.comp_result c - | FStar_Syntax_Syntax.Tm_type u -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_type (FStar_Syntax_Syntax.U_succ u)) - e.FStar_Syntax_Syntax.pos - | FStar_Syntax_Syntax.Tm_quoted uu___1 -> FStar_Syntax_Util.ktype0 - | FStar_Syntax_Syntax.Tm_constant sc -> - tc_constant env e.FStar_Syntax_Syntax.pos sc - | FStar_Syntax_Syntax.Tm_uinst - ({ FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___1; - FStar_Syntax_Syntax.vars = uu___2; - FStar_Syntax_Syntax.hash_code = uu___3;_}, - us) - -> - let uu___4 = - FStar_TypeChecker_Env.lookup_lid env - (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - (match uu___4 with - | ((us', t), uu___5) -> - (if - (FStar_Compiler_List.length us) <> - (FStar_Compiler_List.length us') - then - FStar_Errors.raise_error FStar_TypeChecker_Env.hasRange_env - env FStar_Errors_Codes.Fatal_UnexpectedNumberOfUniverse - () (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic "Unexpected number of universe instantiations") - else (); - FStar_Compiler_List.iter2 - (fun ul -> - fun ur -> - match (ul, ur) with - | (FStar_Syntax_Syntax.U_unif u'', uu___8) -> - FStar_Syntax_Unionfind.univ_change u'' ur - | (FStar_Syntax_Syntax.U_name n1, - FStar_Syntax_Syntax.U_name n2) when - FStar_Ident.ident_equals n1 n2 -> () - | uu___8 -> - let uu___9 = - let uu___10 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_fv fv in - let uu___11 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_univ ul in - let uu___12 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_univ ur in - FStar_Compiler_Util.format3 - "Incompatible universe application for %s, expected %s got %s\n" - uu___10 uu___11 uu___12 in - FStar_Errors.raise_error - FStar_TypeChecker_Env.hasRange_env env - FStar_Errors_Codes.Fatal_IncompatibleUniverse () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___9)) us' us; - t)) - | FStar_Syntax_Syntax.Tm_uinst uu___1 -> - failwith "Impossible: Tm_uinst's head must be an fvar" - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x; FStar_Syntax_Syntax.phi = uu___1;_} -> - universe_of_aux env x.FStar_Syntax_Syntax.sort - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; FStar_Syntax_Syntax.comp = c;_} -> - let uu___1 = FStar_Syntax_Subst.open_comp bs c in - (match uu___1 with - | (bs1, c1) -> - let env1 = FStar_TypeChecker_Env.push_binders env bs1 in - let us = - FStar_Compiler_List.map - (fun uu___2 -> - match uu___2 with - | { FStar_Syntax_Syntax.binder_bv = b; - FStar_Syntax_Syntax.binder_qual = uu___3; - FStar_Syntax_Syntax.binder_positivity = uu___4; - FStar_Syntax_Syntax.binder_attrs = uu___5;_} -> - let uu___6 = - universe_of_aux env1 b.FStar_Syntax_Syntax.sort in - level_of_type env1 b.FStar_Syntax_Syntax.sort - uu___6) bs1 in - let u_res = - let res = FStar_Syntax_Util.comp_result c1 in - let uu___2 = universe_of_aux env1 res in - level_of_type env1 res uu___2 in - let u_c = - FStar_TypeChecker_Util.universe_of_comp env1 u_res c1 in - let u = - FStar_TypeChecker_Normalize.normalize_universe env1 - (FStar_Syntax_Syntax.U_max (u_c :: us)) in - FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_type u) - e.FStar_Syntax_Syntax.pos) - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = hd; FStar_Syntax_Syntax.args = args;_} - -> - let rec type_of_head retry env1 hd1 args1 = - let hd2 = FStar_Syntax_Subst.compress hd1 in - match hd2.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_unknown -> - failwith - "Impossible: universe_of_aux: Tm_app: unexpected head type" - | FStar_Syntax_Syntax.Tm_bvar uu___1 -> - failwith - "Impossible: universe_of_aux: Tm_app: unexpected head type" - | FStar_Syntax_Syntax.Tm_delayed uu___1 -> - failwith - "Impossible: universe_of_aux: Tm_app: unexpected head type" - | FStar_Syntax_Syntax.Tm_fvar uu___1 -> - let uu___2 = universe_of_aux env1 hd2 in (uu___2, args1) - | FStar_Syntax_Syntax.Tm_name uu___1 -> - let uu___2 = universe_of_aux env1 hd2 in (uu___2, args1) - | FStar_Syntax_Syntax.Tm_uvar uu___1 -> - let uu___2 = universe_of_aux env1 hd2 in (uu___2, args1) - | FStar_Syntax_Syntax.Tm_uinst uu___1 -> - let uu___2 = universe_of_aux env1 hd2 in (uu___2, args1) - | FStar_Syntax_Syntax.Tm_ascribed uu___1 -> - let uu___2 = universe_of_aux env1 hd2 in (uu___2, args1) - | FStar_Syntax_Syntax.Tm_refine uu___1 -> - let uu___2 = universe_of_aux env1 hd2 in (uu___2, args1) - | FStar_Syntax_Syntax.Tm_constant uu___1 -> - let uu___2 = universe_of_aux env1 hd2 in (uu___2, args1) - | FStar_Syntax_Syntax.Tm_arrow uu___1 -> - let uu___2 = universe_of_aux env1 hd2 in (uu___2, args1) - | FStar_Syntax_Syntax.Tm_meta uu___1 -> - let uu___2 = universe_of_aux env1 hd2 in (uu___2, args1) - | FStar_Syntax_Syntax.Tm_type uu___1 -> - let uu___2 = universe_of_aux env1 hd2 in (uu___2, args1) - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = uu___1; - FStar_Syntax_Syntax.ret_opt = uu___2; - FStar_Syntax_Syntax.brs = b::uu___3; - FStar_Syntax_Syntax.rc_opt1 = uu___4;_} - -> - let uu___5 = FStar_Syntax_Subst.open_branch b in - (match uu___5 with - | (pat, uu___6, tm) -> - let bvs = FStar_Syntax_Syntax.pat_bvs pat in - let uu___7 = FStar_Syntax_Util.head_and_args tm in - (match uu___7 with - | (hd3, args') -> - let uu___8 = - FStar_TypeChecker_Env.push_bvs env1 bvs in - type_of_head retry uu___8 hd3 - (FStar_Compiler_List.op_At args' args1))) - | uu___1 when retry -> - let e1 = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.DoNotUnfoldPureLets] env1 e in - let uu___2 = FStar_Syntax_Util.head_and_args e1 in - (match uu___2 with - | (hd3, args2) -> type_of_head false env1 hd3 args2) - | uu___1 -> - let uu___2 = FStar_TypeChecker_Env.clear_expected_typ env1 in - (match uu___2 with - | (env2, uu___3) -> - let env3 = - { - FStar_TypeChecker_Env.solver = - (env2.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env2.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env2.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env2.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env2.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env2.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env2.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env2.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env2.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env2.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env2.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env2.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env2.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env2.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = false; - FStar_TypeChecker_Env.check_uvars = - (env2.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env2.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env2.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = true; - FStar_TypeChecker_Env.lax_universes = - (env2.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env2.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env2.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env2.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env2.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env2.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env2.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env2.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env2.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env2.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env2.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env2.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env2.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env2.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env2.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env2.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env2.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env2.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env2.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env2.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env2.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env2.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env2.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env2.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = - (env2.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = - (env2.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env2.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env2.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env2.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env2.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env2.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env2.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env2.FStar_TypeChecker_Env.missing_decl) - } in - ((let uu___5 = - FStar_Compiler_Effect.op_Bang dbg_UniverseOf in - if uu___5 - then - let uu___6 = - let uu___7 = FStar_TypeChecker_Env.get_range env3 in - FStar_Compiler_Range_Ops.string_of_range uu___7 in - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term hd2 in - FStar_Compiler_Util.print2 - "%s: About to type-check %s\n" uu___6 uu___7 - else ()); - (let uu___5 = tc_term env3 hd2 in - match uu___5 with - | (uu___6, - { FStar_TypeChecker_Common.eff_name = uu___7; - FStar_TypeChecker_Common.res_typ = t; - FStar_TypeChecker_Common.cflags = uu___8; - FStar_TypeChecker_Common.comp_thunk = uu___9;_}, - g) -> - ((let uu___11 = - FStar_TypeChecker_Rel.solve_deferred_constraints - env3 g in - ()); - (t, args1))))) in - let uu___1 = type_of_head true env hd args in - (match uu___1 with - | (t, args1) -> - let uu___2 = apply_well_typed env t args1 in - (match uu___2 with - | FStar_Pervasives_Native.Some t1 -> t1 - | FStar_Pervasives_Native.None -> - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - t in - level_of_type_fail env e uu___3)) - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = uu___1; - FStar_Syntax_Syntax.ret_opt = uu___2; - FStar_Syntax_Syntax.brs = b::uu___3; - FStar_Syntax_Syntax.rc_opt1 = uu___4;_} - -> - let uu___5 = FStar_Syntax_Subst.open_branch b in - (match uu___5 with - | (pat, uu___6, tm) -> - let bvs = FStar_Syntax_Syntax.pat_bvs pat in - let uu___7 = FStar_TypeChecker_Env.push_bvs env bvs in - universe_of_aux uu___7 tm) - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = uu___1; - FStar_Syntax_Syntax.ret_opt = uu___2; - FStar_Syntax_Syntax.brs = []; - FStar_Syntax_Syntax.rc_opt1 = uu___3;_} - -> level_of_type_fail env e "empty match cases" -let (universe_of : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.universe) - = - fun env -> - fun e -> - FStar_Errors.with_ctx "While attempting to compute a universe level" - (fun uu___ -> - (let uu___2 = FStar_Compiler_Debug.high () in - if uu___2 - then - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - FStar_Compiler_Util.print1 - "Calling universe_of_aux with %s {\n" uu___3 - else ()); - FStar_Defensive.def_check_scoped - FStar_TypeChecker_Env.hasBinders_env - FStar_Class_Binders.hasNames_term FStar_Syntax_Print.pretty_term - e.FStar_Syntax_Syntax.pos "universe_of entry" env e; - (let r = universe_of_aux env e in - (let uu___4 = FStar_Compiler_Debug.high () in - if uu___4 - then - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term r in - FStar_Compiler_Util.print1 - "Got result from universe_of_aux = %s }\n" uu___5 - else ()); - level_of_type env e r)) -let (tc_tparams : - FStar_TypeChecker_Env.env_t -> - FStar_Syntax_Syntax.binders -> - (FStar_Syntax_Syntax.binders * FStar_TypeChecker_Env.env * - FStar_Syntax_Syntax.universes)) - = - fun env0 -> - fun tps -> - let uu___ = tc_binders env0 tps in - match uu___ with - | (tps1, env, g, us) -> - (FStar_TypeChecker_Rel.force_trivial_guard env0 g; (tps1, env, us)) -let rec (__typeof_tot_or_gtot_term_fastpath : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - Prims.bool -> FStar_Syntax_Syntax.typ FStar_Pervasives_Native.option) - = - fun env -> - fun t -> - fun must_tot -> - let mk_tm_type u = - FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_type u) - t.FStar_Syntax_Syntax.pos in - let effect_ok k = - (Prims.op_Negation must_tot) || - (FStar_TypeChecker_Normalize.non_info_norm env k) in - let t1 = FStar_Syntax_Subst.compress t in - match t1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_delayed uu___ -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - Prims.strcat "Impossible: " uu___2 in - failwith uu___1 - | FStar_Syntax_Syntax.Tm_bvar uu___ -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - Prims.strcat "Impossible: " uu___2 in - failwith uu___1 - | FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_reify uu___) -> - FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_reflect uu___) - -> FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Tm_name uu___ -> - let uu___1 = universe_of_aux env t1 in - FStar_Pervasives_Native.Some uu___1 - | FStar_Syntax_Syntax.Tm_fvar uu___ -> - let uu___1 = universe_of_aux env t1 in - FStar_Pervasives_Native.Some uu___1 - | FStar_Syntax_Syntax.Tm_uinst uu___ -> - let uu___1 = universe_of_aux env t1 in - FStar_Pervasives_Native.Some uu___1 - | FStar_Syntax_Syntax.Tm_constant uu___ -> - let uu___1 = universe_of_aux env t1 in - FStar_Pervasives_Native.Some uu___1 - | FStar_Syntax_Syntax.Tm_type uu___ -> - let uu___1 = universe_of_aux env t1 in - FStar_Pervasives_Native.Some uu___1 - | FStar_Syntax_Syntax.Tm_arrow uu___ -> - let uu___1 = universe_of_aux env t1 in - FStar_Pervasives_Native.Some uu___1 - | FStar_Syntax_Syntax.Tm_lazy i -> - let uu___ = FStar_Syntax_Util.unfold_lazy i in - __typeof_tot_or_gtot_term_fastpath env uu___ must_tot - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs; FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.residual_effect = eff; - FStar_Syntax_Syntax.residual_typ = tbody; - FStar_Syntax_Syntax.residual_flags = uu___;_};_} - -> - let mk_comp = - let uu___1 = - FStar_Ident.lid_equals eff FStar_Parser_Const.effect_Tot_lid in - if uu___1 - then FStar_Pervasives_Native.Some FStar_Syntax_Syntax.mk_Total - else - (let uu___3 = - FStar_Ident.lid_equals eff - FStar_Parser_Const.effect_GTot_lid in - if uu___3 - then - FStar_Pervasives_Native.Some FStar_Syntax_Syntax.mk_GTotal - else FStar_Pervasives_Native.None) in - FStar_Compiler_Util.bind_opt mk_comp - (fun f -> - let tbody1 = - match tbody with - | FStar_Pervasives_Native.Some uu___1 -> tbody - | FStar_Pervasives_Native.None -> - let uu___1 = FStar_Syntax_Subst.open_term bs body in - (match uu___1 with - | (bs1, body1) -> - let uu___2 = - let uu___3 = - FStar_TypeChecker_Env.push_binders env bs1 in - __typeof_tot_or_gtot_term_fastpath uu___3 body1 - false in - FStar_Compiler_Util.map_opt uu___2 - (FStar_Syntax_Subst.close bs1)) in - FStar_Compiler_Util.bind_opt tbody1 - (fun tbody2 -> - let uu___1 = FStar_Syntax_Subst.open_term bs tbody2 in - match uu___1 with - | (bs1, tbody3) -> - let u = - let uu___2 = - FStar_TypeChecker_Env.push_binders env bs1 in - universe_of uu___2 tbody3 in - let uu___2 = - let uu___3 = f tbody3 in - FStar_Syntax_Util.arrow bs1 uu___3 in - FStar_Pervasives_Native.Some uu___2)) - | FStar_Syntax_Syntax.Tm_abs uu___ -> FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x; FStar_Syntax_Syntax.phi = uu___;_} - -> - __typeof_tot_or_gtot_term_fastpath env x.FStar_Syntax_Syntax.sort - must_tot - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_range_of); - FStar_Syntax_Syntax.pos = uu___; - FStar_Syntax_Syntax.vars = uu___1; - FStar_Syntax_Syntax.hash_code = uu___2;_}; - FStar_Syntax_Syntax.args = a::hd::rest;_} - -> - let rest1 = hd :: rest in - let uu___3 = FStar_Syntax_Util.head_and_args t1 in - (match uu___3 with - | (unary_op, uu___4) -> - let head = - let uu___5 = - FStar_Compiler_Range_Ops.union_ranges - unary_op.FStar_Syntax_Syntax.pos - (FStar_Pervasives_Native.fst a).FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = unary_op; - FStar_Syntax_Syntax.args = [a] - }) uu___5 in - let t2 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = rest1 - }) t1.FStar_Syntax_Syntax.pos in - __typeof_tot_or_gtot_term_fastpath env t2 must_tot) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_set_range_of); - FStar_Syntax_Syntax.pos = uu___; - FStar_Syntax_Syntax.vars = uu___1; - FStar_Syntax_Syntax.hash_code = uu___2;_}; - FStar_Syntax_Syntax.args = a1::a2::hd::rest;_} - -> - let rest1 = hd :: rest in - let uu___3 = FStar_Syntax_Util.head_and_args t1 in - (match uu___3 with - | (unary_op, uu___4) -> - let head = - let uu___5 = - FStar_Compiler_Range_Ops.union_ranges - unary_op.FStar_Syntax_Syntax.pos - (FStar_Pervasives_Native.fst a1).FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = unary_op; - FStar_Syntax_Syntax.args = [a1; a2] - }) uu___5 in - let t2 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = rest1 - }) t1.FStar_Syntax_Syntax.pos in - __typeof_tot_or_gtot_term_fastpath env t2 must_tot) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_range_of); - FStar_Syntax_Syntax.pos = uu___; - FStar_Syntax_Syntax.vars = uu___1; - FStar_Syntax_Syntax.hash_code = uu___2;_}; - FStar_Syntax_Syntax.args = uu___3::[];_} - -> FStar_Pervasives_Native.Some FStar_Syntax_Syntax.t_range - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_set_range_of); - FStar_Syntax_Syntax.pos = uu___; - FStar_Syntax_Syntax.vars = uu___1; - FStar_Syntax_Syntax.hash_code = uu___2;_}; - FStar_Syntax_Syntax.args = (t2, uu___3)::uu___4::[];_} - -> __typeof_tot_or_gtot_term_fastpath env t2 must_tot - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = hd; FStar_Syntax_Syntax.args = args;_} - -> - let t_hd = __typeof_tot_or_gtot_term_fastpath env hd must_tot in - FStar_Compiler_Util.bind_opt t_hd - (fun t_hd1 -> - let uu___ = apply_well_typed env t_hd1 args in - FStar_Compiler_Util.bind_opt uu___ - (fun t2 -> - let uu___1 = - (effect_ok t2) || - (FStar_Compiler_List.for_all - (fun uu___2 -> - match uu___2 with - | (a, uu___3) -> - let uu___4 = - __typeof_tot_or_gtot_term_fastpath env - a must_tot in - FStar_Compiler_Util.is_some uu___4) args) in - if uu___1 - then FStar_Pervasives_Native.Some t2 - else FStar_Pervasives_Native.None)) - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t2; - FStar_Syntax_Syntax.asc = - (FStar_Pervasives.Inl k, uu___, uu___1); - FStar_Syntax_Syntax.eff_opt = uu___2;_} - -> - let uu___3 = effect_ok k in - if uu___3 - then FStar_Pervasives_Native.Some k - else __typeof_tot_or_gtot_term_fastpath env t2 must_tot - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = uu___; - FStar_Syntax_Syntax.asc = - (FStar_Pervasives.Inr c, uu___1, uu___2); - FStar_Syntax_Syntax.eff_opt = uu___3;_} - -> - let k = FStar_Syntax_Util.comp_result c in - let uu___4 = - ((Prims.op_Negation must_tot) || - (let uu___5 = - FStar_TypeChecker_Env.norm_eff_name env - (FStar_Syntax_Util.comp_effect_name c) in - FStar_Ident.lid_equals FStar_Parser_Const.effect_PURE_lid - uu___5)) - || (FStar_TypeChecker_Normalize.non_info_norm env k) in - if uu___4 - then FStar_Pervasives_Native.Some k - else FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Tm_uvar (u, s) -> - if Prims.op_Negation must_tot - then - let uu___ = - let uu___1 = FStar_Syntax_Util.ctx_uvar_typ u in - FStar_Syntax_Subst.subst' s uu___1 in - FStar_Pervasives_Native.Some uu___ - else FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Tm_quoted (tm, qi) -> - if Prims.op_Negation must_tot - then FStar_Pervasives_Native.Some FStar_Syntax_Syntax.t_term - else FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t2; - FStar_Syntax_Syntax.meta = uu___;_} - -> __typeof_tot_or_gtot_term_fastpath env t2 must_tot - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = uu___; - FStar_Syntax_Syntax.ret_opt = uu___1; - FStar_Syntax_Syntax.brs = uu___2; - FStar_Syntax_Syntax.rc_opt1 = FStar_Pervasives_Native.Some rc;_} - -> rc.FStar_Syntax_Syntax.residual_typ - | FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (false, lb::[]); - FStar_Syntax_Syntax.body1 = body;_} - -> - let x = FStar_Compiler_Util.left lb.FStar_Syntax_Syntax.lbname in - let uu___ = - let uu___1 = - let uu___2 = FStar_Syntax_Syntax.mk_binder x in [uu___2] in - FStar_Syntax_Subst.open_term uu___1 body in - (match uu___ with - | (xb, body1) -> - let xbinder = FStar_Compiler_List.hd xb in - let x1 = xbinder.FStar_Syntax_Syntax.binder_bv in - let env_x = FStar_TypeChecker_Env.push_bv env x1 in - let t2 = - __typeof_tot_or_gtot_term_fastpath env_x body1 must_tot in - FStar_Compiler_Util.bind_opt t2 - (fun t3 -> - let t4 = FStar_Syntax_Subst.close xb t3 in - FStar_Pervasives_Native.Some t4)) - | FStar_Syntax_Syntax.Tm_match uu___ -> FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Tm_let uu___ -> FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Tm_unknown -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term - t1 in - Prims.strcat uu___2 ")" in - Prims.strcat "Impossible! (" uu___1 in - failwith uu___ - | uu___ -> - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term - t1 in - Prims.strcat uu___3 ")" in - Prims.strcat "Impossible! (" uu___2 in - failwith uu___1 -let (typeof_tot_or_gtot_term_fastpath : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_TypeChecker_Env.must_tot -> - FStar_Syntax_Syntax.typ FStar_Pervasives_Native.option) - = - fun env -> - fun t -> - fun must_tot -> - FStar_Defensive.def_check_scoped FStar_TypeChecker_Env.hasBinders_env - FStar_Class_Binders.hasNames_term FStar_Syntax_Print.pretty_term - t.FStar_Syntax_Syntax.pos "fastpath" env t; - FStar_Errors.with_ctx "In a call to typeof_tot_or_gtot_term_fastpath" - (fun uu___1 -> __typeof_tot_or_gtot_term_fastpath env t must_tot) -let rec (effectof_tot_or_gtot_term_fastpath : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Ident.lident FStar_Pervasives_Native.option) - = - fun env -> - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_delayed uu___1 -> failwith "Impossible!" - | FStar_Syntax_Syntax.Tm_bvar uu___1 -> failwith "Impossible!" - | FStar_Syntax_Syntax.Tm_name uu___1 -> - FStar_Pervasives_Native.Some FStar_Parser_Const.effect_PURE_lid - | FStar_Syntax_Syntax.Tm_lazy uu___1 -> - FStar_Pervasives_Native.Some FStar_Parser_Const.effect_PURE_lid - | FStar_Syntax_Syntax.Tm_fvar uu___1 -> - FStar_Pervasives_Native.Some FStar_Parser_Const.effect_PURE_lid - | FStar_Syntax_Syntax.Tm_uinst uu___1 -> - FStar_Pervasives_Native.Some FStar_Parser_Const.effect_PURE_lid - | FStar_Syntax_Syntax.Tm_constant uu___1 -> - FStar_Pervasives_Native.Some FStar_Parser_Const.effect_PURE_lid - | FStar_Syntax_Syntax.Tm_type uu___1 -> - FStar_Pervasives_Native.Some FStar_Parser_Const.effect_PURE_lid - | FStar_Syntax_Syntax.Tm_abs uu___1 -> - FStar_Pervasives_Native.Some FStar_Parser_Const.effect_PURE_lid - | FStar_Syntax_Syntax.Tm_arrow uu___1 -> - FStar_Pervasives_Native.Some FStar_Parser_Const.effect_PURE_lid - | FStar_Syntax_Syntax.Tm_refine uu___1 -> - FStar_Pervasives_Native.Some FStar_Parser_Const.effect_PURE_lid - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = hd; FStar_Syntax_Syntax.args = args;_} - -> - let join_effects eff1 eff2 = - let uu___1 = - let uu___2 = FStar_TypeChecker_Env.norm_eff_name env eff1 in - let uu___3 = FStar_TypeChecker_Env.norm_eff_name env eff2 in - (uu___2, uu___3) in - match uu___1 with - | (eff11, eff21) -> - let uu___2 = - (FStar_Parser_Const.effect_PURE_lid, - FStar_Parser_Const.effect_GHOST_lid) in - (match uu___2 with - | (pure, ghost) -> - let uu___3 = - (FStar_Ident.lid_equals eff11 pure) && - (FStar_Ident.lid_equals eff21 pure) in - if uu___3 - then FStar_Pervasives_Native.Some pure - else - (let uu___5 = - ((FStar_Ident.lid_equals eff11 ghost) || - (FStar_Ident.lid_equals eff11 pure)) - && - ((FStar_Ident.lid_equals eff21 ghost) || - (FStar_Ident.lid_equals eff21 pure)) in - if uu___5 - then FStar_Pervasives_Native.Some ghost - else FStar_Pervasives_Native.None)) in - let uu___1 = effectof_tot_or_gtot_term_fastpath env hd in - FStar_Compiler_Util.bind_opt uu___1 - (fun eff_hd -> - let uu___2 = - FStar_Compiler_List.fold_left - (fun eff_opt -> - fun arg -> - FStar_Compiler_Util.bind_opt eff_opt - (fun eff -> - let uu___3 = - effectof_tot_or_gtot_term_fastpath env - (FStar_Pervasives_Native.fst arg) in - FStar_Compiler_Util.bind_opt uu___3 - (join_effects eff))) - (FStar_Pervasives_Native.Some eff_hd) args in - FStar_Compiler_Util.bind_opt uu___2 - (fun eff_hd_and_args -> - let uu___3 = typeof_tot_or_gtot_term_fastpath env hd true in - FStar_Compiler_Util.bind_opt uu___3 - (fun t_hd -> - let rec maybe_arrow t1 = - let t2 = - FStar_TypeChecker_Normalize.unfold_whnf env t1 in - match t2.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_arrow uu___4 -> t2 - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x; - FStar_Syntax_Syntax.phi = uu___4;_} - -> maybe_arrow x.FStar_Syntax_Syntax.sort - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t3; - FStar_Syntax_Syntax.asc = uu___4; - FStar_Syntax_Syntax.eff_opt = uu___5;_} - -> maybe_arrow t3 - | uu___4 -> t2 in - let uu___4 = - let uu___5 = maybe_arrow t_hd in - uu___5.FStar_Syntax_Syntax.n in - match uu___4 with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; - FStar_Syntax_Syntax.comp = c;_} - -> - let eff_app = - if - (FStar_Compiler_List.length args) < - (FStar_Compiler_List.length bs) - then FStar_Parser_Const.effect_PURE_lid - else FStar_Syntax_Util.comp_effect_name c in - join_effects eff_hd_and_args eff_app - | uu___5 -> FStar_Pervasives_Native.None))) - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t1; - FStar_Syntax_Syntax.asc = - (FStar_Pervasives.Inl uu___1, uu___2, uu___3); - FStar_Syntax_Syntax.eff_opt = uu___4;_} - -> effectof_tot_or_gtot_term_fastpath env t1 - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = uu___1; - FStar_Syntax_Syntax.asc = - (FStar_Pervasives.Inr c, uu___2, uu___3); - FStar_Syntax_Syntax.eff_opt = uu___4;_} - -> - let c_eff = - FStar_TypeChecker_Env.norm_eff_name env - (FStar_Syntax_Util.comp_effect_name c) in - let uu___5 = - (FStar_Ident.lid_equals c_eff FStar_Parser_Const.effect_PURE_lid) - || - (FStar_Ident.lid_equals c_eff - FStar_Parser_Const.effect_GHOST_lid) in - if uu___5 - then FStar_Pervasives_Native.Some c_eff - else FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Tm_uvar uu___1 -> FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Tm_quoted uu___1 -> FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t1; - FStar_Syntax_Syntax.meta = uu___1;_} - -> effectof_tot_or_gtot_term_fastpath env t1 - | FStar_Syntax_Syntax.Tm_match uu___1 -> FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Tm_let uu___1 -> FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Tm_unknown -> FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Tm_uinst uu___1 -> FStar_Pervasives_Native.None - | uu___1 -> FStar_Pervasives_Native.None \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_TermEqAndSimplify.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_TermEqAndSimplify.ml deleted file mode 100644 index 0f6b5733091..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_TermEqAndSimplify.ml +++ /dev/null @@ -1,1382 +0,0 @@ -open Prims -type eq_result = - | Equal - | NotEqual - | Unknown -let (uu___is_Equal : eq_result -> Prims.bool) = - fun projectee -> match projectee with | Equal -> true | uu___ -> false -let (uu___is_NotEqual : eq_result -> Prims.bool) = - fun projectee -> match projectee with | NotEqual -> true | uu___ -> false -let (uu___is_Unknown : eq_result -> Prims.bool) = - fun projectee -> match projectee with | Unknown -> true | uu___ -> false -let (injectives : Prims.string Prims.list) = - ["FStar.Int8.int_to_t"; - "FStar.Int16.int_to_t"; - "FStar.Int32.int_to_t"; - "FStar.Int64.int_to_t"; - "FStar.Int128.int_to_t"; - "FStar.UInt8.uint_to_t"; - "FStar.UInt16.uint_to_t"; - "FStar.UInt32.uint_to_t"; - "FStar.UInt64.uint_to_t"; - "FStar.UInt128.uint_to_t"; - "FStar.SizeT.uint_to_t"; - "FStar.Int8.__int_to_t"; - "FStar.Int16.__int_to_t"; - "FStar.Int32.__int_to_t"; - "FStar.Int64.__int_to_t"; - "FStar.Int128.__int_to_t"; - "FStar.UInt8.__uint_to_t"; - "FStar.UInt16.__uint_to_t"; - "FStar.UInt32.__uint_to_t"; - "FStar.UInt64.__uint_to_t"; - "FStar.UInt128.__uint_to_t"; - "FStar.SizeT.__uint_to_t"] -let (eq_inj : eq_result -> eq_result -> eq_result) = - fun r -> - fun s -> - match (r, s) with - | (Equal, Equal) -> Equal - | (NotEqual, uu___) -> NotEqual - | (uu___, NotEqual) -> NotEqual - | (uu___, uu___1) -> Unknown -let (equal_if : Prims.bool -> eq_result) = - fun uu___ -> if uu___ then Equal else Unknown -let (equal_iff : Prims.bool -> eq_result) = - fun uu___ -> if uu___ then Equal else NotEqual -let (eq_and : eq_result -> (unit -> eq_result) -> eq_result) = - fun r -> - fun s -> - let uu___ = (r = Equal) && (let uu___1 = s () in uu___1 = Equal) in - if uu___ then Equal else Unknown -let rec (eq_tm : - FStar_TypeChecker_Env.env_t -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term -> eq_result) - = - fun env -> - fun t1 -> - fun t2 -> - let t11 = FStar_Syntax_Util.canon_app t1 in - let t21 = FStar_Syntax_Util.canon_app t2 in - let equal_data f1 args1 f2 args2 n_parms = - let uu___ = FStar_Syntax_Syntax.fv_eq f1 f2 in - if uu___ - then - let n1 = FStar_Compiler_List.length args1 in - let n2 = FStar_Compiler_List.length args2 in - (if (n1 = n2) && (n_parms <= n1) - then - let uu___1 = FStar_Compiler_List.splitAt n_parms args1 in - match uu___1 with - | (parms1, args11) -> - let uu___2 = FStar_Compiler_List.splitAt n_parms args2 in - (match uu___2 with - | (parms2, args21) -> - let eq_arg_list as1 as2 = - FStar_Compiler_List.fold_left2 - (fun acc -> - fun uu___3 -> - fun uu___4 -> - match (uu___3, uu___4) with - | ((a1, q1), (a2, q2)) -> - let uu___5 = eq_tm env a1 a2 in - eq_inj acc uu___5) Equal as1 as2 in - eq_arg_list args11 args21) - else Unknown) - else NotEqual in - let qual_is_inj uu___ = - match uu___ with - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Data_ctor) -> - true - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Record_ctor - uu___1) -> true - | uu___1 -> false in - let heads_and_args_in_case_both_data = - let uu___ = - let uu___1 = FStar_Syntax_Util.unmeta t11 in - FStar_Syntax_Util.head_and_args uu___1 in - match uu___ with - | (head1, args1) -> - let uu___1 = - let uu___2 = FStar_Syntax_Util.unmeta t21 in - FStar_Syntax_Util.head_and_args uu___2 in - (match uu___1 with - | (head2, args2) -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Util.un_uinst head1 in - uu___4.FStar_Syntax_Syntax.n in - let uu___4 = - let uu___5 = FStar_Syntax_Util.un_uinst head2 in - uu___5.FStar_Syntax_Syntax.n in - (uu___3, uu___4) in - (match uu___2 with - | (FStar_Syntax_Syntax.Tm_fvar f, - FStar_Syntax_Syntax.Tm_fvar g) when - (qual_is_inj f.FStar_Syntax_Syntax.fv_qual) && - (qual_is_inj g.FStar_Syntax_Syntax.fv_qual) - -> - let uu___3 = - let uu___4 = FStar_Syntax_Syntax.lid_of_fv f in - FStar_TypeChecker_Env.num_datacon_non_injective_ty_params - env uu___4 in - (match uu___3 with - | FStar_Pervasives_Native.Some n -> - FStar_Pervasives_Native.Some - (f, args1, g, args2, n) - | uu___4 -> FStar_Pervasives_Native.None) - | uu___3 -> FStar_Pervasives_Native.None)) in - let t12 = FStar_Syntax_Util.unmeta t11 in - let t22 = FStar_Syntax_Util.unmeta t21 in - match ((t12.FStar_Syntax_Syntax.n), (t22.FStar_Syntax_Syntax.n)) with - | (FStar_Syntax_Syntax.Tm_bvar bv1, FStar_Syntax_Syntax.Tm_bvar bv2) - -> - equal_if - (bv1.FStar_Syntax_Syntax.index = bv2.FStar_Syntax_Syntax.index) - | (FStar_Syntax_Syntax.Tm_lazy uu___, uu___1) -> - let uu___2 = FStar_Syntax_Util.unlazy t12 in eq_tm env uu___2 t22 - | (uu___, FStar_Syntax_Syntax.Tm_lazy uu___1) -> - let uu___2 = FStar_Syntax_Util.unlazy t22 in eq_tm env t12 uu___2 - | (FStar_Syntax_Syntax.Tm_name a, FStar_Syntax_Syntax.Tm_name b) -> - let uu___ = FStar_Syntax_Syntax.bv_eq a b in equal_if uu___ - | uu___ when - FStar_Pervasives_Native.uu___is_Some - heads_and_args_in_case_both_data - -> - let uu___1 = - FStar_Compiler_Util.must heads_and_args_in_case_both_data in - (match uu___1 with - | (f, args1, g, args2, n) -> equal_data f args1 g args2 n) - | (FStar_Syntax_Syntax.Tm_fvar f, FStar_Syntax_Syntax.Tm_fvar g) -> - let uu___ = FStar_Syntax_Syntax.fv_eq f g in equal_if uu___ - | (FStar_Syntax_Syntax.Tm_uinst (f, us), FStar_Syntax_Syntax.Tm_uinst - (g, vs)) -> - let uu___ = eq_tm env f g in - eq_and uu___ - (fun uu___1 -> - let uu___2 = FStar_Syntax_Util.eq_univs_list us vs in - equal_if uu___2) - | (FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_range uu___), - FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_range uu___1)) - -> Unknown - | (FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_real r1), - FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_real r2)) -> - equal_if (r1 = r2) - | (FStar_Syntax_Syntax.Tm_constant c, FStar_Syntax_Syntax.Tm_constant - d) -> let uu___ = FStar_Const.eq_const c d in equal_iff uu___ - | (FStar_Syntax_Syntax.Tm_uvar (u1, ([], uu___)), - FStar_Syntax_Syntax.Tm_uvar (u2, ([], uu___1))) -> - let uu___2 = - FStar_Syntax_Unionfind.equiv - u1.FStar_Syntax_Syntax.ctx_uvar_head - u2.FStar_Syntax_Syntax.ctx_uvar_head in - equal_if uu___2 - | (FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = h1; FStar_Syntax_Syntax.args = args1;_}, - FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = h2; FStar_Syntax_Syntax.args = args2;_}) - -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Syntax_Util.un_uinst h1 in - uu___2.FStar_Syntax_Syntax.n in - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst h2 in - uu___3.FStar_Syntax_Syntax.n in - (uu___1, uu___2) in - (match uu___ with - | (FStar_Syntax_Syntax.Tm_fvar f1, FStar_Syntax_Syntax.Tm_fvar - f2) when - (FStar_Syntax_Syntax.fv_eq f1 f2) && - (let uu___1 = - let uu___2 = FStar_Syntax_Syntax.lid_of_fv f1 in - FStar_Ident.string_of_lid uu___2 in - FStar_Compiler_List.mem uu___1 injectives) - -> equal_data f1 args1 f2 args2 Prims.int_zero - | uu___1 -> - let uu___2 = eq_tm env h1 h2 in - eq_and uu___2 (fun uu___3 -> eq_args env args1 args2)) - | (FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = t13; - FStar_Syntax_Syntax.ret_opt = uu___; - FStar_Syntax_Syntax.brs = bs1; - FStar_Syntax_Syntax.rc_opt1 = uu___1;_}, - FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = t23; - FStar_Syntax_Syntax.ret_opt = uu___2; - FStar_Syntax_Syntax.brs = bs2; - FStar_Syntax_Syntax.rc_opt1 = uu___3;_}) - -> - if - (FStar_Compiler_List.length bs1) = - (FStar_Compiler_List.length bs2) - then - let uu___4 = FStar_Compiler_List.zip bs1 bs2 in - let uu___5 = eq_tm env t13 t23 in - FStar_Compiler_List.fold_right - (fun uu___6 -> - fun a -> - match uu___6 with - | (b1, b2) -> - eq_and a (fun uu___7 -> branch_matches env b1 b2)) - uu___4 uu___5 - else Unknown - | (FStar_Syntax_Syntax.Tm_type u, FStar_Syntax_Syntax.Tm_type v) -> - let uu___ = FStar_Syntax_Util.eq_univs u v in equal_if uu___ - | (FStar_Syntax_Syntax.Tm_quoted (t13, q1), - FStar_Syntax_Syntax.Tm_quoted (t23, q2)) -> Unknown - | (FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = t13; FStar_Syntax_Syntax.phi = phi1;_}, - FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = t23; FStar_Syntax_Syntax.phi = phi2;_}) - -> - let uu___ = - eq_tm env t13.FStar_Syntax_Syntax.sort - t23.FStar_Syntax_Syntax.sort in - eq_and uu___ (fun uu___1 -> eq_tm env phi1 phi2) - | (FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs1; FStar_Syntax_Syntax.body = body1; - FStar_Syntax_Syntax.rc_opt = uu___;_}, - FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = bs2; FStar_Syntax_Syntax.body = body2; - FStar_Syntax_Syntax.rc_opt = uu___1;_}) - when - (FStar_Compiler_List.length bs1) = - (FStar_Compiler_List.length bs2) - -> - let uu___2 = - FStar_Compiler_List.fold_left2 - (fun r -> - fun b1 -> - fun b2 -> - eq_and r - (fun uu___3 -> - eq_tm env - (b1.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort - (b2.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort)) - Equal bs1 bs2 in - eq_and uu___2 (fun uu___3 -> eq_tm env body1 body2) - | (FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs1; FStar_Syntax_Syntax.comp = c1;_}, - FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs2; FStar_Syntax_Syntax.comp = c2;_}) - when - (FStar_Compiler_List.length bs1) = - (FStar_Compiler_List.length bs2) - -> - let uu___ = - FStar_Compiler_List.fold_left2 - (fun r -> - fun b1 -> - fun b2 -> - eq_and r - (fun uu___1 -> - eq_tm env - (b1.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort - (b2.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort)) - Equal bs1 bs2 in - eq_and uu___ (fun uu___1 -> eq_comp env c1 c2) - | uu___ -> Unknown -and (eq_antiquotations : - FStar_TypeChecker_Env.env_t -> - FStar_Syntax_Syntax.term Prims.list -> - FStar_Syntax_Syntax.term Prims.list -> eq_result) - = - fun env -> - fun a1 -> - fun a2 -> - match (a1, a2) with - | ([], []) -> Equal - | ([], uu___) -> NotEqual - | (uu___, []) -> NotEqual - | (t1::a11, t2::a21) -> - let uu___ = eq_tm env t1 t2 in - (match uu___ with - | NotEqual -> NotEqual - | Unknown -> - let uu___1 = eq_antiquotations env a11 a21 in - (match uu___1 with - | NotEqual -> NotEqual - | uu___2 -> Unknown) - | Equal -> eq_antiquotations env a11 a21) -and (branch_matches : - FStar_TypeChecker_Env.env_t -> - (FStar_Syntax_Syntax.pat' FStar_Syntax_Syntax.withinfo_t * - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - FStar_Pervasives_Native.option * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax) -> - (FStar_Syntax_Syntax.pat' FStar_Syntax_Syntax.withinfo_t * - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax - FStar_Pervasives_Native.option * FStar_Syntax_Syntax.term' - FStar_Syntax_Syntax.syntax) -> eq_result) - = - fun env -> - fun b1 -> - fun b2 -> - let related_by f o1 o2 = - match (o1, o2) with - | (FStar_Pervasives_Native.None, FStar_Pervasives_Native.None) -> - true - | (FStar_Pervasives_Native.Some x, FStar_Pervasives_Native.Some y) - -> f x y - | (uu___, uu___1) -> false in - let uu___ = b1 in - match uu___ with - | (p1, w1, t1) -> - let uu___1 = b2 in - (match uu___1 with - | (p2, w2, t2) -> - let uu___2 = FStar_Syntax_Syntax.eq_pat p1 p2 in - if uu___2 - then - let uu___3 = - (let uu___4 = eq_tm env t1 t2 in uu___4 = Equal) && - (related_by - (fun t11 -> - fun t21 -> - let uu___4 = eq_tm env t11 t21 in - uu___4 = Equal) w1 w2) in - (if uu___3 then Equal else Unknown) - else Unknown) -and (eq_args : - FStar_TypeChecker_Env.env_t -> - FStar_Syntax_Syntax.args -> FStar_Syntax_Syntax.args -> eq_result) - = - fun env -> - fun a1 -> - fun a2 -> - match (a1, a2) with - | ([], []) -> Equal - | ((a, uu___)::a11, (b, uu___1)::b1) -> - let uu___2 = eq_tm env a b in - (match uu___2 with - | Equal -> eq_args env a11 b1 - | uu___3 -> Unknown) - | uu___ -> Unknown -and (eq_comp : - FStar_TypeChecker_Env.env_t -> - FStar_Syntax_Syntax.comp -> FStar_Syntax_Syntax.comp -> eq_result) - = - fun env -> - fun c1 -> - fun c2 -> - match ((c1.FStar_Syntax_Syntax.n), (c2.FStar_Syntax_Syntax.n)) with - | (FStar_Syntax_Syntax.Total t1, FStar_Syntax_Syntax.Total t2) -> - eq_tm env t1 t2 - | (FStar_Syntax_Syntax.GTotal t1, FStar_Syntax_Syntax.GTotal t2) -> - eq_tm env t1 t2 - | (FStar_Syntax_Syntax.Comp ct1, FStar_Syntax_Syntax.Comp ct2) -> - let uu___ = - let uu___1 = - FStar_Syntax_Util.eq_univs_list - ct1.FStar_Syntax_Syntax.comp_univs - ct2.FStar_Syntax_Syntax.comp_univs in - equal_if uu___1 in - eq_and uu___ - (fun uu___1 -> - let uu___2 = - let uu___3 = - FStar_Ident.lid_equals - ct1.FStar_Syntax_Syntax.effect_name - ct2.FStar_Syntax_Syntax.effect_name in - equal_if uu___3 in - eq_and uu___2 - (fun uu___3 -> - let uu___4 = - eq_tm env ct1.FStar_Syntax_Syntax.result_typ - ct2.FStar_Syntax_Syntax.result_typ in - eq_and uu___4 - (fun uu___5 -> - eq_args env ct1.FStar_Syntax_Syntax.effect_args - ct2.FStar_Syntax_Syntax.effect_args))) - | uu___ -> NotEqual -let (eq_tm_bool : - FStar_TypeChecker_Env.env_t -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term -> Prims.bool) - = fun e -> fun t1 -> fun t2 -> let uu___ = eq_tm e t1 t2 in uu___ = Equal -let (simplify : - Prims.bool -> - FStar_TypeChecker_Env.env_t -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun debug -> - fun env -> - fun tm -> - let w t = - { - FStar_Syntax_Syntax.n = (t.FStar_Syntax_Syntax.n); - FStar_Syntax_Syntax.pos = (tm.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = (t.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = (t.FStar_Syntax_Syntax.hash_code) - } in - let simp_t t = - let uu___ = - let uu___1 = FStar_Syntax_Util.unmeta t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.true_lid -> - FStar_Pervasives_Native.Some true - | FStar_Syntax_Syntax.Tm_fvar fv when - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.false_lid - -> FStar_Pervasives_Native.Some false - | uu___1 -> FStar_Pervasives_Native.None in - let rec args_are_binders args bs = - match (args, bs) with - | ((t, uu___)::args1, b::bs1) -> - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress t in - uu___2.FStar_Syntax_Syntax.n in - (match uu___1 with - | FStar_Syntax_Syntax.Tm_name bv' -> - (FStar_Syntax_Syntax.bv_eq b.FStar_Syntax_Syntax.binder_bv - bv') - && (args_are_binders args1 bs1) - | uu___2 -> false) - | ([], []) -> true - | (uu___, uu___1) -> false in - let is_applied bs t = - if debug - then - (let uu___1 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - let uu___2 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t in - FStar_Compiler_Util.print2 "WPE> is_applied %s -- %s\n" uu___1 - uu___2) - else (); - (let uu___1 = FStar_Syntax_Util.head_and_args_full t in - match uu___1 with - | (hd, args) -> - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress hd in - uu___3.FStar_Syntax_Syntax.n in - (match uu___2 with - | FStar_Syntax_Syntax.Tm_name bv when - args_are_binders args bs -> - (if debug - then - (let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_bv bv in - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term hd in - FStar_Compiler_Util.print3 - "WPE> got it\n>>>>top = %s\n>>>>b = %s\n>>>>hd = %s\n" - uu___4 uu___5 uu___6) - else (); - FStar_Pervasives_Native.Some bv) - | uu___3 -> FStar_Pervasives_Native.None)) in - let is_applied_maybe_squashed bs t = - if debug - then - (let uu___1 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - let uu___2 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t in - FStar_Compiler_Util.print2 - "WPE> is_applied_maybe_squashed %s -- %s\n" uu___1 uu___2) - else (); - (let uu___1 = FStar_Syntax_Util.is_squash t in - match uu___1 with - | FStar_Pervasives_Native.Some (uu___2, t') -> is_applied bs t' - | uu___2 -> - let uu___3 = FStar_Syntax_Util.is_auto_squash t in - (match uu___3 with - | FStar_Pervasives_Native.Some (uu___4, t') -> - is_applied bs t' - | uu___4 -> is_applied bs t)) in - let is_const_match phi = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress phi in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = uu___1; - FStar_Syntax_Syntax.ret_opt = uu___2; - FStar_Syntax_Syntax.brs = br::brs; - FStar_Syntax_Syntax.rc_opt1 = uu___3;_} - -> - let uu___4 = br in - (match uu___4 with - | (uu___5, uu___6, e) -> - let r = - let uu___7 = simp_t e in - match uu___7 with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some b -> - let uu___8 = - FStar_Compiler_List.for_all - (fun uu___9 -> - match uu___9 with - | (uu___10, uu___11, e') -> - let uu___12 = simp_t e' in - uu___12 = - (FStar_Pervasives_Native.Some b)) brs in - if uu___8 - then FStar_Pervasives_Native.Some b - else FStar_Pervasives_Native.None in - r) - | uu___1 -> FStar_Pervasives_Native.None in - let maybe_auto_squash t = - let uu___ = FStar_Syntax_Util.is_sub_singleton t in - if uu___ - then t - else FStar_Syntax_Util.mk_auto_squash FStar_Syntax_Syntax.U_zero t in - let squashed_head_un_auto_squash_args t = - let maybe_un_auto_squash_arg uu___ = - match uu___ with - | (t1, q) -> - let uu___1 = FStar_Syntax_Util.is_auto_squash t1 in - (match uu___1 with - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.U_zero, t2) -> (t2, q) - | uu___2 -> (t1, q)) in - let uu___ = FStar_Syntax_Util.head_and_args t in - match uu___ with - | (head, args) -> - let args1 = - FStar_Compiler_List.map maybe_un_auto_squash_arg args in - FStar_Syntax_Syntax.mk_Tm_app head args1 - t.FStar_Syntax_Syntax.pos in - let rec clearly_inhabited ty = - let uu___ = - let uu___1 = FStar_Syntax_Util.unmeta ty in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_uinst (t, uu___1) -> clearly_inhabited t - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = uu___1; - FStar_Syntax_Syntax.comp = c;_} - -> clearly_inhabited (FStar_Syntax_Util.comp_result c) - | FStar_Syntax_Syntax.Tm_fvar fv -> - let l = FStar_Syntax_Syntax.lid_of_fv fv in - (((FStar_Ident.lid_equals l FStar_Parser_Const.int_lid) || - (FStar_Ident.lid_equals l FStar_Parser_Const.bool_lid)) - || (FStar_Ident.lid_equals l FStar_Parser_Const.string_lid)) - || (FStar_Ident.lid_equals l FStar_Parser_Const.exn_lid) - | uu___1 -> false in - let simplify1 arg = - let uu___ = simp_t (FStar_Pervasives_Native.fst arg) in - (uu___, arg) in - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress tm in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_uinst - ({ - FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___1; - FStar_Syntax_Syntax.vars = uu___2; - FStar_Syntax_Syntax.hash_code = uu___3;_}, - uu___4); - FStar_Syntax_Syntax.pos = uu___5; - FStar_Syntax_Syntax.vars = uu___6; - FStar_Syntax_Syntax.hash_code = uu___7;_}; - FStar_Syntax_Syntax.args = args;_} - -> - let uu___8 = - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.squash_lid in - if uu___8 - then squashed_head_un_auto_squash_args tm - else - (let uu___10 = - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.and_lid in - if uu___10 - then - let uu___11 = FStar_Compiler_List.map simplify1 args in - match uu___11 with - | (FStar_Pervasives_Native.Some (true), uu___12)::(uu___13, - (arg, - uu___14))::[] - -> maybe_auto_squash arg - | (uu___12, (arg, uu___13))::(FStar_Pervasives_Native.Some - (true), uu___14)::[] - -> maybe_auto_squash arg - | (FStar_Pervasives_Native.Some (false), uu___12)::uu___13::[] - -> w FStar_Syntax_Util.t_false - | uu___12::(FStar_Pervasives_Native.Some (false), uu___13)::[] - -> w FStar_Syntax_Util.t_false - | uu___12 -> squashed_head_un_auto_squash_args tm - else - (let uu___12 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.or_lid in - if uu___12 - then - let uu___13 = FStar_Compiler_List.map simplify1 args in - match uu___13 with - | (FStar_Pervasives_Native.Some (true), uu___14)::uu___15::[] - -> w FStar_Syntax_Util.t_true - | uu___14::(FStar_Pervasives_Native.Some (true), uu___15)::[] - -> w FStar_Syntax_Util.t_true - | (FStar_Pervasives_Native.Some (false), uu___14):: - (uu___15, (arg, uu___16))::[] -> - maybe_auto_squash arg - | (uu___14, (arg, uu___15))::(FStar_Pervasives_Native.Some - (false), uu___16)::[] - -> maybe_auto_squash arg - | uu___14 -> squashed_head_un_auto_squash_args tm - else - (let uu___14 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.imp_lid in - if uu___14 - then - let uu___15 = FStar_Compiler_List.map simplify1 args in - match uu___15 with - | uu___16::(FStar_Pervasives_Native.Some (true), - uu___17)::[] - -> w FStar_Syntax_Util.t_true - | (FStar_Pervasives_Native.Some (false), uu___16)::uu___17::[] - -> w FStar_Syntax_Util.t_true - | (FStar_Pervasives_Native.Some (true), uu___16):: - (uu___17, (arg, uu___18))::[] -> - maybe_auto_squash arg - | (uu___16, (p, uu___17))::(uu___18, (q, uu___19))::[] - -> - let uu___20 = FStar_Syntax_Util.term_eq p q in - (if uu___20 - then w FStar_Syntax_Util.t_true - else squashed_head_un_auto_squash_args tm) - | uu___16 -> squashed_head_un_auto_squash_args tm - else - (let uu___16 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.iff_lid in - if uu___16 - then - let uu___17 = - FStar_Compiler_List.map simplify1 args in - match uu___17 with - | (FStar_Pervasives_Native.Some (true), uu___18):: - (FStar_Pervasives_Native.Some (true), uu___19)::[] - -> w FStar_Syntax_Util.t_true - | (FStar_Pervasives_Native.Some (false), uu___18):: - (FStar_Pervasives_Native.Some (false), uu___19)::[] - -> w FStar_Syntax_Util.t_true - | (FStar_Pervasives_Native.Some (true), uu___18):: - (FStar_Pervasives_Native.Some (false), uu___19)::[] - -> w FStar_Syntax_Util.t_false - | (FStar_Pervasives_Native.Some (false), uu___18):: - (FStar_Pervasives_Native.Some (true), uu___19)::[] - -> w FStar_Syntax_Util.t_false - | (uu___18, (arg, uu___19))::(FStar_Pervasives_Native.Some - (true), uu___20)::[] - -> maybe_auto_squash arg - | (FStar_Pervasives_Native.Some (true), uu___18):: - (uu___19, (arg, uu___20))::[] -> - maybe_auto_squash arg - | (uu___18, (arg, uu___19))::(FStar_Pervasives_Native.Some - (false), uu___20)::[] - -> - let uu___21 = FStar_Syntax_Util.mk_neg arg in - maybe_auto_squash uu___21 - | (FStar_Pervasives_Native.Some (false), uu___18):: - (uu___19, (arg, uu___20))::[] -> - let uu___21 = FStar_Syntax_Util.mk_neg arg in - maybe_auto_squash uu___21 - | (uu___18, (p, uu___19))::(uu___20, (q, uu___21))::[] - -> - let uu___22 = FStar_Syntax_Util.term_eq p q in - (if uu___22 - then w FStar_Syntax_Util.t_true - else squashed_head_un_auto_squash_args tm) - | uu___18 -> squashed_head_un_auto_squash_args tm - else - (let uu___18 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.not_lid in - if uu___18 - then - let uu___19 = - FStar_Compiler_List.map simplify1 args in - match uu___19 with - | (FStar_Pervasives_Native.Some (true), uu___20)::[] - -> w FStar_Syntax_Util.t_false - | (FStar_Pervasives_Native.Some (false), - uu___20)::[] -> w FStar_Syntax_Util.t_true - | uu___20 -> - squashed_head_un_auto_squash_args tm - else - (let uu___20 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.forall_lid in - if uu___20 - then - match args with - | (t, uu___21)::[] -> - let uu___22 = - let uu___23 = - FStar_Syntax_Subst.compress t in - uu___23.FStar_Syntax_Syntax.n in - (match uu___22 with - | FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = - uu___23::[]; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = - uu___24;_} - -> - let uu___25 = simp_t body in - (match uu___25 with - | FStar_Pervasives_Native.Some - (true) -> - w FStar_Syntax_Util.t_true - | uu___26 -> tm) - | uu___23 -> tm) - | (ty, FStar_Pervasives_Native.Some - { - FStar_Syntax_Syntax.aqual_implicit = - true; - FStar_Syntax_Syntax.aqual_attributes = - uu___21;_})::(t, uu___22)::[] - -> - let uu___23 = - let uu___24 = - FStar_Syntax_Subst.compress t in - uu___24.FStar_Syntax_Syntax.n in - (match uu___23 with - | FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = - uu___24::[]; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = - uu___25;_} - -> - let uu___26 = simp_t body in - (match uu___26 with - | FStar_Pervasives_Native.Some - (true) -> - w FStar_Syntax_Util.t_true - | FStar_Pervasives_Native.Some - (false) when - clearly_inhabited ty -> - w FStar_Syntax_Util.t_false - | uu___27 -> tm) - | uu___24 -> tm) - | uu___21 -> tm - else - (let uu___22 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.exists_lid in - if uu___22 - then - match args with - | (t, uu___23)::[] -> - let uu___24 = - let uu___25 = - FStar_Syntax_Subst.compress t in - uu___25.FStar_Syntax_Syntax.n in - (match uu___24 with - | FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = - uu___25::[]; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = - uu___26;_} - -> - let uu___27 = simp_t body in - (match uu___27 with - | FStar_Pervasives_Native.Some - (false) -> - w FStar_Syntax_Util.t_false - | uu___28 -> tm) - | uu___25 -> tm) - | (ty, FStar_Pervasives_Native.Some - { - FStar_Syntax_Syntax.aqual_implicit = - true; - FStar_Syntax_Syntax.aqual_attributes - = uu___23;_})::(t, uu___24)::[] - -> - let uu___25 = - let uu___26 = - FStar_Syntax_Subst.compress t in - uu___26.FStar_Syntax_Syntax.n in - (match uu___25 with - | FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = - uu___26::[]; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = - uu___27;_} - -> - let uu___28 = simp_t body in - (match uu___28 with - | FStar_Pervasives_Native.Some - (false) -> - w FStar_Syntax_Util.t_false - | FStar_Pervasives_Native.Some - (true) when - clearly_inhabited ty -> - w FStar_Syntax_Util.t_true - | uu___29 -> tm) - | uu___26 -> tm) - | uu___23 -> tm - else - (let uu___24 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.b2t_lid in - if uu___24 - then - match args with - | ({ - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_bool (true)); - FStar_Syntax_Syntax.pos = uu___25; - FStar_Syntax_Syntax.vars = uu___26; - FStar_Syntax_Syntax.hash_code = - uu___27;_}, - uu___28)::[] -> - w FStar_Syntax_Util.t_true - | ({ - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_bool (false)); - FStar_Syntax_Syntax.pos = uu___25; - FStar_Syntax_Syntax.vars = uu___26; - FStar_Syntax_Syntax.hash_code = - uu___27;_}, - uu___28)::[] -> - w FStar_Syntax_Util.t_false - | uu___25 -> tm - else - (let uu___26 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.haseq_lid in - if uu___26 - then - let t_has_eq_for_sure t = - let haseq_lids = - [FStar_Parser_Const.int_lid; - FStar_Parser_Const.bool_lid; - FStar_Parser_Const.unit_lid; - FStar_Parser_Const.string_lid] in - let uu___27 = - let uu___28 = - FStar_Syntax_Subst.compress t in - uu___28.FStar_Syntax_Syntax.n in - match uu___27 with - | FStar_Syntax_Syntax.Tm_fvar fv1 - when - FStar_Compiler_List.existsb - (fun l -> - FStar_Syntax_Syntax.fv_eq_lid - fv1 l) haseq_lids - -> true - | uu___28 -> false in - (if - (FStar_Compiler_List.length args) - = Prims.int_one - then - let t = - let uu___27 = - FStar_Compiler_List.hd args in - FStar_Pervasives_Native.fst - uu___27 in - let uu___27 = t_has_eq_for_sure t in - (if uu___27 - then w FStar_Syntax_Util.t_true - else - (let uu___29 = - let uu___30 = - FStar_Syntax_Subst.compress - t in - uu___30.FStar_Syntax_Syntax.n in - match uu___29 with - | FStar_Syntax_Syntax.Tm_refine - uu___30 -> - let t1 = - FStar_Syntax_Util.unrefine - t in - let uu___31 = - t_has_eq_for_sure t1 in - if uu___31 - then - w - FStar_Syntax_Util.t_true - else - (let haseq_tm = - let uu___33 = - let uu___34 = - FStar_Syntax_Subst.compress - tm in - uu___34.FStar_Syntax_Syntax.n in - match uu___33 with - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd - = hd; - FStar_Syntax_Syntax.args - = uu___34;_} - -> hd - | uu___34 -> - failwith - "Impossible! We have already checked that this is a Tm_app" in - let uu___33 = - let uu___34 = - FStar_Syntax_Syntax.as_arg - t1 in - [uu___34] in - FStar_Syntax_Util.mk_app - haseq_tm uu___33) - | uu___30 -> tm)) - else tm) - else - (let uu___28 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.eq2_lid in - if uu___28 - then - match args with - | (_typ, uu___29)::(a1, uu___30):: - (a2, uu___31)::[] -> - let uu___32 = eq_tm env a1 a2 in - (match uu___32 with - | Equal -> - w - FStar_Syntax_Util.t_true - | NotEqual -> - w - FStar_Syntax_Util.t_false - | uu___33 -> tm) - | uu___29 -> tm - else - (let uu___30 = - FStar_Syntax_Util.is_auto_squash - tm in - match uu___30 with - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.U_zero, - t) - when - FStar_Syntax_Util.is_sub_singleton - t - -> t - | uu___31 -> tm))))))))))) - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___1; - FStar_Syntax_Syntax.vars = uu___2; - FStar_Syntax_Syntax.hash_code = uu___3;_}; - FStar_Syntax_Syntax.args = args;_} - -> - let uu___4 = - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.squash_lid in - if uu___4 - then squashed_head_un_auto_squash_args tm - else - (let uu___6 = - FStar_Syntax_Syntax.fv_eq_lid fv FStar_Parser_Const.and_lid in - if uu___6 - then - let uu___7 = FStar_Compiler_List.map simplify1 args in - match uu___7 with - | (FStar_Pervasives_Native.Some (true), uu___8)::(uu___9, - (arg, - uu___10))::[] - -> maybe_auto_squash arg - | (uu___8, (arg, uu___9))::(FStar_Pervasives_Native.Some - (true), uu___10)::[] - -> maybe_auto_squash arg - | (FStar_Pervasives_Native.Some (false), uu___8)::uu___9::[] - -> w FStar_Syntax_Util.t_false - | uu___8::(FStar_Pervasives_Native.Some (false), uu___9)::[] - -> w FStar_Syntax_Util.t_false - | uu___8 -> squashed_head_un_auto_squash_args tm - else - (let uu___8 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.or_lid in - if uu___8 - then - let uu___9 = FStar_Compiler_List.map simplify1 args in - match uu___9 with - | (FStar_Pervasives_Native.Some (true), uu___10)::uu___11::[] - -> w FStar_Syntax_Util.t_true - | uu___10::(FStar_Pervasives_Native.Some (true), uu___11)::[] - -> w FStar_Syntax_Util.t_true - | (FStar_Pervasives_Native.Some (false), uu___10):: - (uu___11, (arg, uu___12))::[] -> - maybe_auto_squash arg - | (uu___10, (arg, uu___11))::(FStar_Pervasives_Native.Some - (false), uu___12)::[] - -> maybe_auto_squash arg - | uu___10 -> squashed_head_un_auto_squash_args tm - else - (let uu___10 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.imp_lid in - if uu___10 - then - let uu___11 = FStar_Compiler_List.map simplify1 args in - match uu___11 with - | uu___12::(FStar_Pervasives_Native.Some (true), - uu___13)::[] - -> w FStar_Syntax_Util.t_true - | (FStar_Pervasives_Native.Some (false), uu___12)::uu___13::[] - -> w FStar_Syntax_Util.t_true - | (FStar_Pervasives_Native.Some (true), uu___12):: - (uu___13, (arg, uu___14))::[] -> - maybe_auto_squash arg - | (uu___12, (p, uu___13))::(uu___14, (q, uu___15))::[] - -> - let uu___16 = FStar_Syntax_Util.term_eq p q in - (if uu___16 - then w FStar_Syntax_Util.t_true - else squashed_head_un_auto_squash_args tm) - | uu___12 -> squashed_head_un_auto_squash_args tm - else - (let uu___12 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.iff_lid in - if uu___12 - then - let uu___13 = - FStar_Compiler_List.map simplify1 args in - match uu___13 with - | (FStar_Pervasives_Native.Some (true), uu___14):: - (FStar_Pervasives_Native.Some (true), uu___15)::[] - -> w FStar_Syntax_Util.t_true - | (FStar_Pervasives_Native.Some (false), uu___14):: - (FStar_Pervasives_Native.Some (false), uu___15)::[] - -> w FStar_Syntax_Util.t_true - | (FStar_Pervasives_Native.Some (true), uu___14):: - (FStar_Pervasives_Native.Some (false), uu___15)::[] - -> w FStar_Syntax_Util.t_false - | (FStar_Pervasives_Native.Some (false), uu___14):: - (FStar_Pervasives_Native.Some (true), uu___15)::[] - -> w FStar_Syntax_Util.t_false - | (uu___14, (arg, uu___15))::(FStar_Pervasives_Native.Some - (true), uu___16)::[] - -> maybe_auto_squash arg - | (FStar_Pervasives_Native.Some (true), uu___14):: - (uu___15, (arg, uu___16))::[] -> - maybe_auto_squash arg - | (uu___14, (arg, uu___15))::(FStar_Pervasives_Native.Some - (false), uu___16)::[] - -> - let uu___17 = FStar_Syntax_Util.mk_neg arg in - maybe_auto_squash uu___17 - | (FStar_Pervasives_Native.Some (false), uu___14):: - (uu___15, (arg, uu___16))::[] -> - let uu___17 = FStar_Syntax_Util.mk_neg arg in - maybe_auto_squash uu___17 - | (uu___14, (p, uu___15))::(uu___16, (q, uu___17))::[] - -> - let uu___18 = FStar_Syntax_Util.term_eq p q in - (if uu___18 - then w FStar_Syntax_Util.t_true - else squashed_head_un_auto_squash_args tm) - | uu___14 -> squashed_head_un_auto_squash_args tm - else - (let uu___14 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.not_lid in - if uu___14 - then - let uu___15 = - FStar_Compiler_List.map simplify1 args in - match uu___15 with - | (FStar_Pervasives_Native.Some (true), uu___16)::[] - -> w FStar_Syntax_Util.t_false - | (FStar_Pervasives_Native.Some (false), - uu___16)::[] -> w FStar_Syntax_Util.t_true - | uu___16 -> - squashed_head_un_auto_squash_args tm - else - (let uu___16 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.forall_lid in - if uu___16 - then - match args with - | (t, uu___17)::[] -> - let uu___18 = - let uu___19 = - FStar_Syntax_Subst.compress t in - uu___19.FStar_Syntax_Syntax.n in - (match uu___18 with - | FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = - uu___19::[]; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = - uu___20;_} - -> - let uu___21 = simp_t body in - (match uu___21 with - | FStar_Pervasives_Native.Some - (true) -> - w FStar_Syntax_Util.t_true - | uu___22 -> tm) - | uu___19 -> tm) - | (ty, FStar_Pervasives_Native.Some - { - FStar_Syntax_Syntax.aqual_implicit = - true; - FStar_Syntax_Syntax.aqual_attributes = - uu___17;_})::(t, uu___18)::[] - -> - let uu___19 = - let uu___20 = - FStar_Syntax_Subst.compress t in - uu___20.FStar_Syntax_Syntax.n in - (match uu___19 with - | FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = - uu___20::[]; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = - uu___21;_} - -> - let uu___22 = simp_t body in - (match uu___22 with - | FStar_Pervasives_Native.Some - (true) -> - w FStar_Syntax_Util.t_true - | FStar_Pervasives_Native.Some - (false) when - clearly_inhabited ty -> - w FStar_Syntax_Util.t_false - | uu___23 -> tm) - | uu___20 -> tm) - | uu___17 -> tm - else - (let uu___18 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.exists_lid in - if uu___18 - then - match args with - | (t, uu___19)::[] -> - let uu___20 = - let uu___21 = - FStar_Syntax_Subst.compress t in - uu___21.FStar_Syntax_Syntax.n in - (match uu___20 with - | FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = - uu___21::[]; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = - uu___22;_} - -> - let uu___23 = simp_t body in - (match uu___23 with - | FStar_Pervasives_Native.Some - (false) -> - w FStar_Syntax_Util.t_false - | uu___24 -> tm) - | uu___21 -> tm) - | (ty, FStar_Pervasives_Native.Some - { - FStar_Syntax_Syntax.aqual_implicit = - true; - FStar_Syntax_Syntax.aqual_attributes - = uu___19;_})::(t, uu___20)::[] - -> - let uu___21 = - let uu___22 = - FStar_Syntax_Subst.compress t in - uu___22.FStar_Syntax_Syntax.n in - (match uu___21 with - | FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = - uu___22::[]; - FStar_Syntax_Syntax.body = body; - FStar_Syntax_Syntax.rc_opt = - uu___23;_} - -> - let uu___24 = simp_t body in - (match uu___24 with - | FStar_Pervasives_Native.Some - (false) -> - w FStar_Syntax_Util.t_false - | FStar_Pervasives_Native.Some - (true) when - clearly_inhabited ty -> - w FStar_Syntax_Util.t_true - | uu___25 -> tm) - | uu___22 -> tm) - | uu___19 -> tm - else - (let uu___20 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.b2t_lid in - if uu___20 - then - match args with - | ({ - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_bool (true)); - FStar_Syntax_Syntax.pos = uu___21; - FStar_Syntax_Syntax.vars = uu___22; - FStar_Syntax_Syntax.hash_code = - uu___23;_}, - uu___24)::[] -> - w FStar_Syntax_Util.t_true - | ({ - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_constant - (FStar_Const.Const_bool (false)); - FStar_Syntax_Syntax.pos = uu___21; - FStar_Syntax_Syntax.vars = uu___22; - FStar_Syntax_Syntax.hash_code = - uu___23;_}, - uu___24)::[] -> - w FStar_Syntax_Util.t_false - | uu___21 -> tm - else - (let uu___22 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.haseq_lid in - if uu___22 - then - let t_has_eq_for_sure t = - let haseq_lids = - [FStar_Parser_Const.int_lid; - FStar_Parser_Const.bool_lid; - FStar_Parser_Const.unit_lid; - FStar_Parser_Const.string_lid] in - let uu___23 = - let uu___24 = - FStar_Syntax_Subst.compress t in - uu___24.FStar_Syntax_Syntax.n in - match uu___23 with - | FStar_Syntax_Syntax.Tm_fvar fv1 - when - FStar_Compiler_List.existsb - (fun l -> - FStar_Syntax_Syntax.fv_eq_lid - fv1 l) haseq_lids - -> true - | uu___24 -> false in - (if - (FStar_Compiler_List.length args) - = Prims.int_one - then - let t = - let uu___23 = - FStar_Compiler_List.hd args in - FStar_Pervasives_Native.fst - uu___23 in - let uu___23 = t_has_eq_for_sure t in - (if uu___23 - then w FStar_Syntax_Util.t_true - else - (let uu___25 = - let uu___26 = - FStar_Syntax_Subst.compress - t in - uu___26.FStar_Syntax_Syntax.n in - match uu___25 with - | FStar_Syntax_Syntax.Tm_refine - uu___26 -> - let t1 = - FStar_Syntax_Util.unrefine - t in - let uu___27 = - t_has_eq_for_sure t1 in - if uu___27 - then - w - FStar_Syntax_Util.t_true - else - (let haseq_tm = - let uu___29 = - let uu___30 = - FStar_Syntax_Subst.compress - tm in - uu___30.FStar_Syntax_Syntax.n in - match uu___29 with - | FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd - = hd; - FStar_Syntax_Syntax.args - = uu___30;_} - -> hd - | uu___30 -> - failwith - "Impossible! We have already checked that this is a Tm_app" in - let uu___29 = - let uu___30 = - FStar_Syntax_Syntax.as_arg - t1 in - [uu___30] in - FStar_Syntax_Util.mk_app - haseq_tm uu___29) - | uu___26 -> tm)) - else tm) - else - (let uu___24 = - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.eq2_lid in - if uu___24 - then - match args with - | (_typ, uu___25)::(a1, uu___26):: - (a2, uu___27)::[] -> - let uu___28 = eq_tm env a1 a2 in - (match uu___28 with - | Equal -> - w - FStar_Syntax_Util.t_true - | NotEqual -> - w - FStar_Syntax_Util.t_false - | uu___29 -> tm) - | uu___25 -> tm - else - (let uu___26 = - FStar_Syntax_Util.is_auto_squash - tm in - match uu___26 with - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.U_zero, - t) - when - FStar_Syntax_Util.is_sub_singleton - t - -> t - | uu___27 -> tm))))))))))) - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = bv; FStar_Syntax_Syntax.phi = t;_} -> - let uu___1 = simp_t t in - (match uu___1 with - | FStar_Pervasives_Native.Some (true) -> - bv.FStar_Syntax_Syntax.sort - | FStar_Pervasives_Native.Some (false) -> tm - | FStar_Pervasives_Native.None -> tm) - | FStar_Syntax_Syntax.Tm_match uu___1 -> - let uu___2 = is_const_match tm in - (match uu___2 with - | FStar_Pervasives_Native.Some (true) -> - w FStar_Syntax_Util.t_true - | FStar_Pervasives_Native.Some (false) -> - w FStar_Syntax_Util.t_false - | FStar_Pervasives_Native.None -> tm) - | uu___1 -> tm \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_TypeChecker_Util.ml b/ocaml/fstar-lib/generated/FStar_TypeChecker_Util.ml deleted file mode 100644 index 0085c09023a..00000000000 --- a/ocaml/fstar-lib/generated/FStar_TypeChecker_Util.ml +++ /dev/null @@ -1,8767 +0,0 @@ -open Prims -type lcomp_with_binder = - (FStar_Syntax_Syntax.bv FStar_Pervasives_Native.option * - FStar_TypeChecker_Common.lcomp) -let (dbg_bind : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Bind" -let (dbg_Coercions : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Coercions" -let (dbg_Dec : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Dec" -let (dbg_Extraction : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Extraction" -let (dbg_LayeredEffects : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "LayeredEffects" -let (dbg_LayeredEffectsApp : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "LayeredEffectsApp" -let (dbg_Pat : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Pat" -let (dbg_Rel : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Rel" -let (dbg_ResolveImplicitsHook : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "ResolveImplicitsHook" -let (dbg_Return : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Return" -let (dbg_Simplification : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Simplification" -let (dbg_SMTEncodingReify : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "SMTEncodingReify" -let (new_implicit_var : - Prims.string -> - FStar_Compiler_Range_Type.range -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> - Prims.bool -> - (FStar_Syntax_Syntax.term * (FStar_Syntax_Syntax.ctx_uvar * - FStar_Compiler_Range_Type.range) * - FStar_TypeChecker_Env.guard_t)) - = - fun reason -> - fun r -> - fun env -> - fun k -> - fun unrefine -> - FStar_TypeChecker_Env.new_implicit_var_aux reason r env k - FStar_Syntax_Syntax.Strict FStar_Pervasives_Native.None - unrefine -let (close_guard_implicits : - FStar_TypeChecker_Env.env -> - Prims.bool -> - FStar_Syntax_Syntax.binders -> - FStar_TypeChecker_Env.guard_t -> FStar_TypeChecker_Env.guard_t) - = - fun env -> - fun solve_deferred -> - fun xs -> - fun g -> - let uu___ = (FStar_Options.eager_subtyping ()) || solve_deferred in - if uu___ - then - let uu___1 = - let uu___2 = - FStar_Class_Listlike.to_list - (FStar_Compiler_CList.listlike_clist ()) - g.FStar_TypeChecker_Common.deferred in - FStar_Compiler_List.partition - (fun uu___3 -> - match uu___3 with - | (uu___4, uu___5, p) -> - FStar_TypeChecker_Rel.flex_prob_closing env xs p) - uu___2 in - match uu___1 with - | (solve_now, defer) -> - ((let uu___3 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___3 - then - (FStar_Compiler_Util.print_string - "SOLVE BEFORE CLOSING:\n"; - FStar_Compiler_List.iter - (fun uu___6 -> - match uu___6 with - | (uu___7, s, p) -> - let uu___8 = - FStar_TypeChecker_Rel.prob_to_string env p in - FStar_Compiler_Util.print2 "%s: %s\n" s uu___8) - solve_now; - FStar_Compiler_Util.print_string - " ...DEFERRED THE REST:\n"; - FStar_Compiler_List.iter - (fun uu___8 -> - match uu___8 with - | (uu___9, s, p) -> - let uu___10 = - FStar_TypeChecker_Rel.prob_to_string env p in - FStar_Compiler_Util.print2 "%s: %s\n" s uu___10) - defer; - FStar_Compiler_Util.print_string "END\n") - else ()); - (let g1 = - let uu___3 = - let uu___4 = - FStar_Class_Listlike.from_list - (FStar_Compiler_CList.listlike_clist ()) solve_now in - { - FStar_TypeChecker_Common.guard_f = - (g.FStar_TypeChecker_Common.guard_f); - FStar_TypeChecker_Common.deferred_to_tac = - (g.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = uu___4; - FStar_TypeChecker_Common.univ_ineqs = - (g.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = - (g.FStar_TypeChecker_Common.implicits) - } in - FStar_TypeChecker_Rel.solve_non_tactic_deferred_constraints - false env uu___3 in - let g2 = - let uu___3 = - FStar_Class_Listlike.from_list - (FStar_Compiler_CList.listlike_clist ()) defer in - { - FStar_TypeChecker_Common.guard_f = - (g1.FStar_TypeChecker_Common.guard_f); - FStar_TypeChecker_Common.deferred_to_tac = - (g1.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = uu___3; - FStar_TypeChecker_Common.univ_ineqs = - (g1.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = - (g1.FStar_TypeChecker_Common.implicits) - } in - g2)) - else g -let (check_uvars : - FStar_Compiler_Range_Type.range -> FStar_Syntax_Syntax.typ -> unit) = - fun r -> - fun t -> - let uvs = FStar_Syntax_Free.uvars t in - let uu___ = - let uu___1 = - FStar_Class_Setlike.is_empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Free.ord_ctx_uvar)) (Obj.magic uvs) in - Prims.op_Negation uu___1 in - if uu___ - then - (FStar_Options.push (); - FStar_Options.set_option "hide_uvar_nums" (FStar_Options.Bool false); - FStar_Options.set_option "print_implicits" (FStar_Options.Bool true); - (let uu___5 = - let uu___6 = - FStar_Class_Show.show - (FStar_Compiler_FlatSet.showable_set - FStar_Syntax_Free.ord_ctx_uvar - FStar_Syntax_Print.showable_ctxu) uvs in - let uu___7 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.format2 - "Unconstrained unification variables %s in type signature %s; please add an annotation" - uu___6 uu___7 in - FStar_Errors.log_issue FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Error_UncontrainedUnificationVar () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___5)); - FStar_Options.pop ()) - else () -let (extract_let_rec_annotation : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.letbinding -> - (FStar_Syntax_Syntax.univ_names * FStar_Syntax_Syntax.typ * - FStar_Syntax_Syntax.term * Prims.bool)) - = - fun env -> - fun uu___ -> - match uu___ with - | { FStar_Syntax_Syntax.lbname = lbname; - FStar_Syntax_Syntax.lbunivs = univ_vars; - FStar_Syntax_Syntax.lbtyp = t; FStar_Syntax_Syntax.lbeff = uu___1; - FStar_Syntax_Syntax.lbdef = e; - FStar_Syntax_Syntax.lbattrs = uu___2; - FStar_Syntax_Syntax.lbpos = uu___3;_} -> - let rng = FStar_Syntax_Syntax.range_of_lbname lbname in - let t1 = FStar_Syntax_Subst.compress t in - let uu___4 = FStar_Syntax_Subst.univ_var_opening univ_vars in - (match uu___4 with - | (u_subst, univ_vars1) -> - let e1 = FStar_Syntax_Subst.subst u_subst e in - let t2 = FStar_Syntax_Subst.subst u_subst t1 in - ((let uu___6 = FStar_Compiler_Effect.op_Bang dbg_Dec in - if uu___6 - then - let uu___7 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - e1 in - let uu___8 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - t2 in - FStar_Compiler_Util.print2 - "extract_let_rec_annotation lbdef=%s; lbtyp=%s\n" uu___7 - uu___8 - else ()); - (let env1 = - FStar_TypeChecker_Env.push_univ_vars env univ_vars1 in - let un_arrow t3 = - let uu___6 = - let uu___7 = FStar_Syntax_Subst.compress t3 in - uu___7.FStar_Syntax_Syntax.n in - match uu___6 with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; - FStar_Syntax_Syntax.comp = c;_} - -> FStar_Syntax_Subst.open_comp bs c - | uu___7 -> - let uu___8 = - let uu___9 = - FStar_Errors_Msg.text - "Recursive functions must be introduced at arrow types." in - [uu___9] in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range rng - FStar_Errors_Codes.Fatal_LetRecArgumentMismatch () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___8) in - let reconcile_let_rec_ascription_and_body_type tarr - lbtyp_opt = - let get_decreases c = - FStar_Compiler_Util.prefix_until - (fun uu___6 -> - match uu___6 with - | FStar_Syntax_Syntax.DECREASES uu___7 -> true - | uu___7 -> false) (FStar_Syntax_Util.comp_flags c) in - let fallback uu___6 = - let uu___7 = FStar_Syntax_Util.arrow_formals_comp tarr in - match uu___7 with - | (bs, c) -> - let uu___8 = get_decreases c in - (match uu___8 with - | FStar_Pervasives_Native.Some - (pfx, FStar_Syntax_Syntax.DECREASES d, sfx) -> - let c1 = - FStar_TypeChecker_Env.comp_set_flags env1 c - (FStar_Compiler_List.op_At pfx sfx) in - let uu___9 = FStar_Syntax_Util.arrow bs c1 in - (uu___9, tarr, true) - | uu___9 -> (tarr, tarr, true)) in - match lbtyp_opt with - | FStar_Pervasives_Native.None -> fallback () - | FStar_Pervasives_Native.Some annot -> - let uu___6 = un_arrow tarr in - (match uu___6 with - | (bs, c) -> - let n_bs = FStar_Compiler_List.length bs in - let uu___7 = - FStar_TypeChecker_Normalize.get_n_binders env1 - n_bs annot in - (match uu___7 with - | (bs', c') -> - (if (FStar_Compiler_List.length bs') <> n_bs - then - (let uu___9 = - let uu___10 = - FStar_Errors_Msg.text - "Arity mismatch on let rec annotation" in - let uu___11 = - let uu___12 = - FStar_Errors_Msg.text "(explain)" in - [uu___12] in - uu___10 :: uu___11 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - rng - FStar_Errors_Codes.Fatal_LetRecArgumentMismatch - () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___9)) - else (); - (let move_decreases d flags flags' = - let d' = - let s = - FStar_Syntax_Util.rename_binders bs - bs' in - FStar_Syntax_Subst.subst_decreasing_order - s d in - let c1 = - let uu___9 = - FStar_TypeChecker_Env.push_binders - env1 bs in - FStar_TypeChecker_Env.comp_set_flags - uu___9 c flags in - let tarr1 = - FStar_Syntax_Util.arrow bs c1 in - let c'1 = - let uu___9 = - FStar_TypeChecker_Env.push_binders - env1 bs' in - FStar_TypeChecker_Env.comp_set_flags - uu___9 c' - ((FStar_Syntax_Syntax.DECREASES d') - :: flags') in - let tannot = - FStar_Syntax_Util.arrow bs' c'1 in - (tarr1, tannot, true) in - let uu___9 = - let uu___10 = get_decreases c in - let uu___11 = get_decreases c' in - (uu___10, uu___11) in - match uu___9 with - | (FStar_Pervasives_Native.None, uu___10) - -> (tarr, annot, false) - | (FStar_Pervasives_Native.Some - (pfx, FStar_Syntax_Syntax.DECREASES d, - sfx), - FStar_Pervasives_Native.Some - (pfx', FStar_Syntax_Syntax.DECREASES - d', sfx')) -> - ((let uu___11 = - let uu___12 = - FStar_Errors_Msg.text - "This definitions has multiple decreases clauses." in - let uu___13 = - let uu___14 = - FStar_Errors_Msg.text - "The decreases clause on the declaration is ignored, please remove it." in - [uu___14] in - uu___12 :: uu___13 in - FStar_Errors.log_issue - FStar_Class_HasRange.hasRange_range - rng - FStar_Errors_Codes.Warning_DeprecatedGeneric - () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___11)); - move_decreases d - (FStar_Compiler_List.op_At pfx sfx) - (FStar_Compiler_List.op_At pfx' - sfx')) - | (FStar_Pervasives_Native.Some - (pfx, FStar_Syntax_Syntax.DECREASES d, - sfx), - FStar_Pervasives_Native.None) -> - move_decreases d - (FStar_Compiler_List.op_At pfx sfx) - (FStar_Syntax_Util.comp_flags c') - | uu___10 -> failwith "Impossible")))) in - let extract_annot_from_body lbtyp_opt = - let rec aux_lbdef e2 = - let e3 = FStar_Syntax_Subst.compress e2 in - match e3.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = e'; - FStar_Syntax_Syntax.meta = m;_} - -> - let uu___6 = aux_lbdef e' in - (match uu___6 with - | (t3, e'1, recheck) -> - (t3, - { - FStar_Syntax_Syntax.n = - (FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 = e'1; - FStar_Syntax_Syntax.meta = m - }); - FStar_Syntax_Syntax.pos = - (e3.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = - (e3.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (e3.FStar_Syntax_Syntax.hash_code) - }, recheck)) - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = e'; - FStar_Syntax_Syntax.asc = - (FStar_Pervasives.Inr c, tac_opt, use_eq); - FStar_Syntax_Syntax.eff_opt = lopt;_} - -> - let uu___6 = FStar_Syntax_Util.is_total_comp c in - if uu___6 - then - let uu___7 = - reconcile_let_rec_ascription_and_body_type - (FStar_Syntax_Util.comp_result c) lbtyp_opt in - (match uu___7 with - | (t3, lbtyp, recheck) -> - let e4 = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Syntax_Syntax.mk_Total t3 in - FStar_Pervasives.Inr uu___12 in - (uu___11, tac_opt, use_eq) in - { - FStar_Syntax_Syntax.tm = e'; - FStar_Syntax_Syntax.asc = uu___10; - FStar_Syntax_Syntax.eff_opt = lopt - } in - FStar_Syntax_Syntax.Tm_ascribed uu___9 in - { - FStar_Syntax_Syntax.n = uu___8; - FStar_Syntax_Syntax.pos = - (e3.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = - (e3.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (e3.FStar_Syntax_Syntax.hash_code) - } in - (lbtyp, e4, recheck)) - else - (let uu___8 = - let uu___9 = - FStar_Errors_Msg.text - "Expected a 'let rec' to be annotated with a value type" in - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Errors_Msg.text - "Got a computation type" in - let uu___13 = - let uu___14 = - FStar_Class_PP.pp - FStar_Syntax_Print.pretty_comp c in - let uu___15 = - FStar_Errors_Msg.text "instead" in - FStar_Pprint.op_Hat_Slash_Hat uu___14 - uu___15 in - FStar_Pprint.op_Hat_Slash_Hat uu___12 - uu___13 in - [uu___11] in - uu___9 :: uu___10 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range rng - FStar_Errors_Codes.Fatal_UnexpectedComputationTypeForLetRec - () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___8)) - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = e'; - FStar_Syntax_Syntax.asc = - (FStar_Pervasives.Inl t3, tac_opt, use_eq); - FStar_Syntax_Syntax.eff_opt = lopt;_} - -> - let uu___6 = - reconcile_let_rec_ascription_and_body_type t3 - lbtyp_opt in - (match uu___6 with - | (t4, lbtyp, recheck) -> - let e4 = - { - FStar_Syntax_Syntax.n = - (FStar_Syntax_Syntax.Tm_ascribed - { - FStar_Syntax_Syntax.tm = e'; - FStar_Syntax_Syntax.asc = - ((FStar_Pervasives.Inl t4), - tac_opt, use_eq); - FStar_Syntax_Syntax.eff_opt = lopt - }); - FStar_Syntax_Syntax.pos = - (e3.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = - (e3.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (e3.FStar_Syntax_Syntax.hash_code) - } in - (lbtyp, e4, recheck)) - | FStar_Syntax_Syntax.Tm_abs uu___6 -> - let uu___7 = - FStar_Syntax_Util.abs_formals_maybe_unascribe_body - false e3 in - (match uu___7 with - | (bs, body, rcopt) -> - let mk_comp t3 = - let uu___8 = FStar_Options.ml_ish () in - if uu___8 - then - FStar_Syntax_Util.ml_comp t3 - t3.FStar_Syntax_Syntax.pos - else FStar_Syntax_Syntax.mk_Total t3 in - let mk_arrow c = FStar_Syntax_Util.arrow bs c in - let rec aux_abs_body body1 = - let body2 = FStar_Syntax_Subst.compress body1 in - match body2.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = body3; - FStar_Syntax_Syntax.meta = m;_} - -> - let uu___8 = aux_abs_body body3 in - (match uu___8 with - | (t3, body', recheck) -> - let body4 = - { - FStar_Syntax_Syntax.n = - (FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 = - body'; - FStar_Syntax_Syntax.meta - = m - }); - FStar_Syntax_Syntax.pos = - (body3.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars = - (body3.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code = - (body3.FStar_Syntax_Syntax.hash_code) - } in - (t3, body4, recheck)) - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = uu___8; - FStar_Syntax_Syntax.asc = - (FStar_Pervasives.Inl t3, uu___9, - use_eq); - FStar_Syntax_Syntax.eff_opt = uu___10;_} - -> - (if use_eq - then - (let uu___12 = - let uu___13 = - let uu___14 = - FStar_Errors_Msg.text - "Equality ascription in this case" in - let uu___15 = - let uu___16 = - let uu___17 = - FStar_Class_PP.pp - FStar_Syntax_Print.pretty_term - t3 in - FStar_Pprint.parens uu___17 in - let uu___17 = - FStar_Errors_Msg.text - "is not yet supported." in - FStar_Pprint.op_Hat_Slash_Hat - uu___16 uu___17 in - FStar_Pprint.op_Hat_Slash_Hat - uu___14 uu___15 in - let uu___14 = - let uu___15 = - FStar_Errors_Msg.text - "Please use subtyping instead" in - [uu___15] in - uu___13 :: uu___14 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax - ()) t3 - FStar_Errors_Codes.Fatal_NotSupported - () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___12)) - else (); - (match lbtyp_opt with - | FStar_Pervasives_Native.Some lbtyp -> - (lbtyp, body2, false) - | FStar_Pervasives_Native.None -> - let t4 = - let uu___12 = mk_comp t3 in - mk_arrow uu___12 in - (t4, body2, true))) - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = body'; - FStar_Syntax_Syntax.asc = - (FStar_Pervasives.Inr c, tac_opt, - use_eq); - FStar_Syntax_Syntax.eff_opt = lopt;_} - -> - let tarr = mk_arrow c in - let uu___8 = - reconcile_let_rec_ascription_and_body_type - tarr lbtyp_opt in - (match uu___8 with - | (tarr1, lbtyp, recheck) -> - let n_bs = - FStar_Compiler_List.length bs in - let uu___9 = - FStar_TypeChecker_Normalize.get_n_binders - env1 n_bs tarr1 in - (match uu___9 with - | (bs', c1) -> - if - (FStar_Compiler_List.length - bs') - <> n_bs - then failwith "Impossible" - else - (let subst = - FStar_Syntax_Util.rename_binders - bs' bs in - let c2 = - FStar_Syntax_Subst.subst_comp - subst c1 in - let body3 = - { - FStar_Syntax_Syntax.n = - (FStar_Syntax_Syntax.Tm_ascribed - { - FStar_Syntax_Syntax.tm - = body'; - FStar_Syntax_Syntax.asc - = - ((FStar_Pervasives.Inr - c2), - tac_opt, - use_eq); - FStar_Syntax_Syntax.eff_opt - = lopt - }); - FStar_Syntax_Syntax.pos - = - (body2.FStar_Syntax_Syntax.pos); - FStar_Syntax_Syntax.vars - = - (body2.FStar_Syntax_Syntax.vars); - FStar_Syntax_Syntax.hash_code - = - (body2.FStar_Syntax_Syntax.hash_code) - } in - (lbtyp, body3, recheck)))) - | uu___8 -> - (match lbtyp_opt with - | FStar_Pervasives_Native.Some lbtyp -> - (lbtyp, body2, false) - | FStar_Pervasives_Native.None -> - let tarr = - let uu___9 = - mk_comp FStar_Syntax_Syntax.tun in - mk_arrow uu___9 in - (tarr, body2, true)) in - let uu___8 = aux_abs_body body in - (match uu___8 with - | (lbtyp, body1, recheck) -> - let uu___9 = - FStar_Syntax_Util.abs bs body1 rcopt in - (lbtyp, uu___9, recheck))) - | uu___6 -> - let uu___7 = - let uu___8 = - FStar_Errors_Msg.text - "The definition of a 'let rec' must be a function literal" in - let uu___9 = - let uu___10 = - let uu___11 = FStar_Errors_Msg.text "Got" in - let uu___12 = - let uu___13 = - FStar_Class_PP.pp - FStar_Syntax_Print.pretty_term e3 in - let uu___14 = - FStar_Errors_Msg.text "instead" in - FStar_Pprint.op_Hat_Slash_Hat uu___13 - uu___14 in - FStar_Pprint.op_Hat_Slash_Hat uu___11 uu___12 in - [uu___10] in - uu___8 :: uu___9 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) e3 - FStar_Errors_Codes.Fatal_UnexpectedComputationTypeForLetRec - () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___7) in - aux_lbdef e1 in - match t2.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_unknown -> - let uu___6 = - extract_annot_from_body FStar_Pervasives_Native.None in - (match uu___6 with - | (lbtyp, e2, uu___7) -> (univ_vars1, lbtyp, e2, true)) - | uu___6 -> - let uu___7 = FStar_Syntax_Util.arrow_formals_comp t2 in - (match uu___7 with - | (uu___8, c) -> - let uu___9 = - let uu___10 = - let uu___11 = - FStar_TypeChecker_Env.lookup_effect_quals - env1 (FStar_Syntax_Util.comp_effect_name c) in - FStar_Compiler_List.contains - FStar_Syntax_Syntax.TotalEffect uu___11 in - Prims.op_Negation uu___10 in - if uu___9 - then (univ_vars1, t2, e1, false) - else - (let uu___11 = - extract_annot_from_body - (FStar_Pervasives_Native.Some t2) in - match uu___11 with - | (lbtyp, e2, check_lbtyp) -> - (univ_vars1, lbtyp, e2, check_lbtyp)))))) -let rec (decorated_pattern_as_term : - FStar_Syntax_Syntax.pat -> - (FStar_Syntax_Syntax.bv Prims.list * FStar_Syntax_Syntax.term)) - = - fun pat -> - let mk f = FStar_Syntax_Syntax.mk f pat.FStar_Syntax_Syntax.p in - let pat_as_arg uu___ = - match uu___ with - | (p, i) -> - let uu___1 = decorated_pattern_as_term p in - (match uu___1 with - | (vars, te) -> - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.as_aqual_implicit i in - (te, uu___3) in - (vars, uu___2)) in - match pat.FStar_Syntax_Syntax.v with - | FStar_Syntax_Syntax.Pat_constant c -> - let uu___ = mk (FStar_Syntax_Syntax.Tm_constant c) in ([], uu___) - | FStar_Syntax_Syntax.Pat_var x -> - let uu___ = mk (FStar_Syntax_Syntax.Tm_name x) in ([x], uu___) - | FStar_Syntax_Syntax.Pat_cons (fv, us_opt, pats) -> - let uu___ = - let uu___1 = FStar_Compiler_List.map pat_as_arg pats in - FStar_Compiler_List.unzip uu___1 in - (match uu___ with - | (vars, args) -> - let vars1 = FStar_Compiler_List.flatten vars in - let head = FStar_Syntax_Syntax.fv_to_tm fv in - let head1 = - match us_opt with - | FStar_Pervasives_Native.None -> head - | FStar_Pervasives_Native.Some us -> - FStar_Syntax_Syntax.mk_Tm_uinst head us in - let uu___1 = - mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = head1; - FStar_Syntax_Syntax.args = args - }) in - (vars1, uu___1)) - | FStar_Syntax_Syntax.Pat_dot_term eopt -> - (match eopt with - | FStar_Pervasives_Native.None -> - failwith - "TcUtil::decorated_pattern_as_term: dot pattern not resolved" - | FStar_Pervasives_Native.Some e -> ([], e)) -let (comp_univ_opt : - FStar_Syntax_Syntax.comp' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.universe FStar_Pervasives_Native.option) - = - fun c -> - match c.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Total uu___ -> FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.GTotal uu___ -> FStar_Pervasives_Native.None - | FStar_Syntax_Syntax.Comp c1 -> - (match c1.FStar_Syntax_Syntax.comp_univs with - | [] -> FStar_Pervasives_Native.None - | hd::uu___ -> FStar_Pervasives_Native.Some hd) -let (lcomp_univ_opt : - FStar_TypeChecker_Common.lcomp -> - (FStar_Syntax_Syntax.universe FStar_Pervasives_Native.option * - FStar_TypeChecker_Env.guard_t)) - = - fun lc -> - let uu___ = FStar_TypeChecker_Common.lcomp_comp lc in - match uu___ with | (c, g) -> ((comp_univ_opt c), g) -let (destruct_wp_comp : - FStar_Syntax_Syntax.comp_typ -> - (FStar_Syntax_Syntax.universe * FStar_Syntax_Syntax.typ * - FStar_Syntax_Syntax.typ)) - = fun c -> FStar_Syntax_Util.destruct_comp c -let (mk_comp_l : - FStar_Ident.lident -> - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.cflag Prims.list -> FStar_Syntax_Syntax.comp) - = - fun mname -> - fun u_result -> - fun result -> - fun wp -> - fun flags -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Syntax_Syntax.as_arg wp in [uu___2] in - { - FStar_Syntax_Syntax.comp_univs = [u_result]; - FStar_Syntax_Syntax.effect_name = mname; - FStar_Syntax_Syntax.result_typ = result; - FStar_Syntax_Syntax.effect_args = uu___1; - FStar_Syntax_Syntax.flags = flags - } in - FStar_Syntax_Syntax.mk_Comp uu___ -let (mk_comp : - FStar_Syntax_Syntax.eff_decl -> - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.cflag Prims.list -> FStar_Syntax_Syntax.comp) - = fun md -> mk_comp_l md.FStar_Syntax_Syntax.mname -let (effect_args_from_repr : - FStar_Syntax_Syntax.term -> - Prims.bool -> - FStar_Compiler_Range_Type.range -> FStar_Syntax_Syntax.term Prims.list) - = - fun repr -> - fun is_layered -> - fun r -> - let err uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Errors_Msg.text "Could not get effect args from repr" in - let uu___4 = - let uu___5 = - FStar_Class_PP.pp FStar_Syntax_Print.pretty_term repr in - let uu___6 = - let uu___7 = FStar_Errors_Msg.text "with is_layered=" in - let uu___8 = - FStar_Class_PP.pp FStar_Class_PP.pp_bool is_layered in - FStar_Pprint.op_Hat_Hat uu___7 uu___8 in - FStar_Pprint.op_Hat_Slash_Hat uu___5 uu___6 in - FStar_Pprint.op_Hat_Slash_Hat uu___3 uu___4 in - [uu___2] in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_UnexpectedEffect () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___1) in - let repr1 = FStar_Syntax_Subst.compress repr in - if is_layered - then - match repr1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = uu___; - FStar_Syntax_Syntax.args = uu___1::is;_} - -> FStar_Compiler_List.map FStar_Pervasives_Native.fst is - | uu___ -> err () - else - (match repr1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = uu___1; - FStar_Syntax_Syntax.comp = c;_} - -> - let uu___2 = FStar_Syntax_Util.comp_eff_name_res_and_args c in - (match uu___2 with - | (uu___3, uu___4, args) -> - FStar_Compiler_List.map FStar_Pervasives_Native.fst args) - | uu___1 -> err ()) -let (mk_wp_return : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.eff_decl -> - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.term -> - FStar_Compiler_Range_Type.range -> FStar_Syntax_Syntax.comp) - = - fun env -> - fun ed -> - fun u_a -> - fun a -> - fun e -> - fun r -> - let c = - let uu___ = - let uu___1 = - FStar_TypeChecker_Env.lid_exists env - FStar_Parser_Const.effect_GTot_lid in - Prims.op_Negation uu___1 in - if uu___ - then FStar_Syntax_Syntax.mk_Total a - else - (let uu___2 = FStar_Syntax_Util.is_unit a in - if uu___2 - then FStar_Syntax_Syntax.mk_Total a - else - (let wp = - let uu___4 = - (FStar_Options.lax ()) && (FStar_Options.ml_ish ()) in - if uu___4 - then FStar_Syntax_Syntax.tun - else - (let ret_wp = - FStar_Syntax_Util.get_return_vc_combinator ed in - let uu___6 = - FStar_TypeChecker_Env.inst_effect_fun_with - [u_a] env ed ret_wp in - let uu___7 = - let uu___8 = FStar_Syntax_Syntax.as_arg a in - let uu___9 = - let uu___10 = FStar_Syntax_Syntax.as_arg e in - [uu___10] in - uu___8 :: uu___9 in - FStar_Syntax_Syntax.mk_Tm_app uu___6 uu___7 - e.FStar_Syntax_Syntax.pos) in - mk_comp ed u_a a wp [FStar_Syntax_Syntax.RETURN])) in - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_Return in - if uu___1 - then - let uu___2 = - FStar_Compiler_Range_Ops.string_of_range - e.FStar_Syntax_Syntax.pos in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - let uu___4 = - FStar_TypeChecker_Normalize.comp_to_string env c in - FStar_Compiler_Util.print3 - "(%s) returning %s at comp type %s\n" uu___2 uu___3 uu___4 - else ()); - c -let (label : - FStar_Pprint.document Prims.list -> - FStar_Compiler_Range_Type.range -> - FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.typ) - = - fun reason -> - fun r -> - fun f -> - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 = f; - FStar_Syntax_Syntax.meta = - (FStar_Syntax_Syntax.Meta_labeled (reason, r, false)) - }) f.FStar_Syntax_Syntax.pos -let (label_opt : - FStar_TypeChecker_Env.env -> - (unit -> FStar_Pprint.document Prims.list) FStar_Pervasives_Native.option - -> - FStar_Compiler_Range_Type.range -> - FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.typ) - = - fun env -> - fun reason -> - fun r -> - fun f -> - match reason with - | FStar_Pervasives_Native.None -> f - | FStar_Pervasives_Native.Some reason1 -> - let uu___ = - let uu___1 = FStar_TypeChecker_Env.should_verify env in - Prims.op_Negation uu___1 in - if uu___ - then f - else (let uu___2 = reason1 () in label uu___2 r f) -let (label_guard : - FStar_Compiler_Range_Type.range -> - FStar_Pprint.document Prims.list -> - FStar_TypeChecker_Env.guard_t -> FStar_TypeChecker_Env.guard_t) - = - fun r -> - fun reason -> - fun g -> - match g.FStar_TypeChecker_Common.guard_f with - | FStar_TypeChecker_Common.Trivial -> g - | FStar_TypeChecker_Common.NonTrivial f -> - let uu___ = - let uu___1 = label reason r f in - FStar_TypeChecker_Common.NonTrivial uu___1 in - { - FStar_TypeChecker_Common.guard_f = uu___; - FStar_TypeChecker_Common.deferred_to_tac = - (g.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (g.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (g.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = - (g.FStar_TypeChecker_Common.implicits) - } -let (lift_comp : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.comp_typ -> - FStar_TypeChecker_Env.mlift -> - (FStar_Syntax_Syntax.comp * FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun c -> - fun lift -> - let uu___ = - FStar_Syntax_Syntax.mk_Comp - { - FStar_Syntax_Syntax.comp_univs = - (c.FStar_Syntax_Syntax.comp_univs); - FStar_Syntax_Syntax.effect_name = - (c.FStar_Syntax_Syntax.effect_name); - FStar_Syntax_Syntax.result_typ = - (c.FStar_Syntax_Syntax.result_typ); - FStar_Syntax_Syntax.effect_args = - (c.FStar_Syntax_Syntax.effect_args); - FStar_Syntax_Syntax.flags = [] - } in - lift.FStar_TypeChecker_Env.mlift_wp env uu___ -let (join_effects : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident -> FStar_Ident.lident -> FStar_Ident.lident) - = - fun env -> - fun l1_in -> - fun l2_in -> - let uu___ = - let uu___1 = FStar_TypeChecker_Env.norm_eff_name env l1_in in - let uu___2 = FStar_TypeChecker_Env.norm_eff_name env l2_in in - (uu___1, uu___2) in - match uu___ with - | (l1, l2) -> - let uu___1 = FStar_TypeChecker_Env.join_opt env l1 l2 in - (match uu___1 with - | FStar_Pervasives_Native.Some (m, uu___2, uu___3) -> m - | FStar_Pervasives_Native.None -> - let uu___2 = - FStar_TypeChecker_Env.exists_polymonadic_bind env l1 l2 in - (match uu___2 with - | FStar_Pervasives_Native.Some (m, uu___3) -> m - | FStar_Pervasives_Native.None -> - let uu___3 = - let uu___4 = - let uu___5 = FStar_Errors_Msg.text "Effects" in - let uu___6 = - let uu___7 = - FStar_Class_PP.pp FStar_Ident.pretty_lident - l1_in in - let uu___8 = - let uu___9 = FStar_Errors_Msg.text "and" in - let uu___10 = - let uu___11 = - FStar_Class_PP.pp FStar_Ident.pretty_lident - l2_in in - let uu___12 = - FStar_Errors_Msg.text "cannot be composed" in - FStar_Pprint.op_Hat_Slash_Hat uu___11 uu___12 in - FStar_Pprint.op_Hat_Slash_Hat uu___9 uu___10 in - FStar_Pprint.op_Hat_Slash_Hat uu___7 uu___8 in - FStar_Pprint.op_Hat_Slash_Hat uu___5 uu___6 in - [uu___4] in - FStar_Errors.raise_error - FStar_TypeChecker_Env.hasRange_env env - FStar_Errors_Codes.Fatal_EffectsCannotBeComposed () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___3))) -let (join_lcomp : - FStar_TypeChecker_Env.env -> - FStar_TypeChecker_Common.lcomp -> - FStar_TypeChecker_Common.lcomp -> FStar_Ident.lident) - = - fun env -> - fun c1 -> - fun c2 -> - let uu___ = - (FStar_TypeChecker_Common.is_total_lcomp c1) && - (FStar_TypeChecker_Common.is_total_lcomp c2) in - if uu___ - then FStar_Parser_Const.effect_Tot_lid - else - join_effects env c1.FStar_TypeChecker_Common.eff_name - c2.FStar_TypeChecker_Common.eff_name -let (maybe_push : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.bv FStar_Pervasives_Native.option -> - FStar_TypeChecker_Env.env) - = - fun env -> - fun b -> - match b with - | FStar_Pervasives_Native.None -> env - | FStar_Pervasives_Native.Some bv -> - FStar_TypeChecker_Env.push_bv env bv -let (lift_comps_sep_guards : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.comp -> - FStar_Syntax_Syntax.comp -> - FStar_Syntax_Syntax.bv FStar_Pervasives_Native.option -> - Prims.bool -> - (FStar_Ident.lident * FStar_Syntax_Syntax.comp * - FStar_Syntax_Syntax.comp * FStar_TypeChecker_Env.guard_t * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun c1 -> - fun c2 -> - fun b -> - fun for_bind -> - let c11 = FStar_TypeChecker_Env.unfold_effect_abbrev env c1 in - let env2 = maybe_push env b in - let c21 = FStar_TypeChecker_Env.unfold_effect_abbrev env2 c2 in - let uu___ = - FStar_TypeChecker_Env.join_opt env - c11.FStar_Syntax_Syntax.effect_name - c21.FStar_Syntax_Syntax.effect_name in - match uu___ with - | FStar_Pervasives_Native.Some (m, lift1, lift2) -> - let uu___1 = lift_comp env c11 lift1 in - (match uu___1 with - | (c12, g1) -> - let uu___2 = - if Prims.op_Negation for_bind - then lift_comp env2 c21 lift2 - else - (let x_a = - match b with - | FStar_Pervasives_Native.None -> - FStar_Syntax_Syntax.null_binder - (FStar_Syntax_Util.comp_result c12) - | FStar_Pervasives_Native.Some x -> - FStar_Syntax_Syntax.mk_binder x in - let env_x = - FStar_TypeChecker_Env.push_binders env [x_a] in - let uu___4 = lift_comp env_x c21 lift2 in - match uu___4 with - | (c22, g2) -> - let uu___5 = - FStar_TypeChecker_Env.close_guard env - [x_a] g2 in - (c22, uu___5)) in - (match uu___2 with | (c22, g2) -> (m, c12, c22, g1, g2))) - | FStar_Pervasives_Native.None -> - let uu___1 = - let uu___2 = - let uu___3 = FStar_Errors_Msg.text "Effects" in - let uu___4 = - let uu___5 = - FStar_Class_PP.pp FStar_Ident.pretty_lident - c11.FStar_Syntax_Syntax.effect_name in - let uu___6 = - let uu___7 = FStar_Errors_Msg.text "and" in - let uu___8 = - let uu___9 = - FStar_Class_PP.pp FStar_Ident.pretty_lident - c21.FStar_Syntax_Syntax.effect_name in - let uu___10 = - FStar_Errors_Msg.text "cannot be composed" in - FStar_Pprint.op_Hat_Slash_Hat uu___9 uu___10 in - FStar_Pprint.op_Hat_Slash_Hat uu___7 uu___8 in - FStar_Pprint.op_Hat_Slash_Hat uu___5 uu___6 in - FStar_Pprint.op_Hat_Slash_Hat uu___3 uu___4 in - [uu___2] in - FStar_Errors.raise_error FStar_TypeChecker_Env.hasRange_env - env FStar_Errors_Codes.Fatal_EffectsCannotBeComposed () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___1) -let (lift_comps : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.comp -> - FStar_Syntax_Syntax.comp -> - FStar_Syntax_Syntax.bv FStar_Pervasives_Native.option -> - Prims.bool -> - (FStar_Ident.lident * FStar_Syntax_Syntax.comp * - FStar_Syntax_Syntax.comp * FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun c1 -> - fun c2 -> - fun b -> - fun for_bind -> - let uu___ = lift_comps_sep_guards env c1 c2 b for_bind in - match uu___ with - | (l, c11, c21, g1, g2) -> - let uu___1 = FStar_TypeChecker_Env.conj_guard g1 g2 in - (l, c11, c21, uu___1) -let (is_pure_effect : - FStar_TypeChecker_Env.env -> FStar_Ident.lident -> Prims.bool) = - fun env -> - fun l -> - let l1 = FStar_TypeChecker_Env.norm_eff_name env l in - FStar_Ident.lid_equals l1 FStar_Parser_Const.effect_PURE_lid -let (is_ghost_effect : - FStar_TypeChecker_Env.env -> FStar_Ident.lident -> Prims.bool) = - fun env -> - fun l -> - let l1 = FStar_TypeChecker_Env.norm_eff_name env l in - FStar_Ident.lid_equals l1 FStar_Parser_Const.effect_GHOST_lid -let (is_pure_or_ghost_effect : - FStar_TypeChecker_Env.env -> FStar_Ident.lident -> Prims.bool) = - fun env -> - fun l -> - let l1 = FStar_TypeChecker_Env.norm_eff_name env l in - (FStar_Ident.lid_equals l1 FStar_Parser_Const.effect_PURE_lid) || - (FStar_Ident.lid_equals l1 FStar_Parser_Const.effect_GHOST_lid) -let (lax_mk_tot_or_comp_l : - FStar_Ident.lident -> - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.cflag Prims.list -> FStar_Syntax_Syntax.comp) - = - fun mname -> - fun u_result -> - fun result -> - fun flags -> - let uu___ = - FStar_Ident.lid_equals mname FStar_Parser_Const.effect_Tot_lid in - if uu___ - then FStar_Syntax_Syntax.mk_Total result - else mk_comp_l mname u_result result FStar_Syntax_Syntax.tun flags -let (is_function : FStar_Syntax_Syntax.term -> Prims.bool) = - fun t -> - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_arrow uu___1 -> true - | uu___1 -> false -let (close_wp_comp : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.bv Prims.list -> - FStar_Syntax_Syntax.comp -> FStar_Syntax_Syntax.comp) - = - fun env -> - fun bvs -> - fun c -> - (let uu___1 = FStar_TypeChecker_Env.push_bvs env bvs in - FStar_Defensive.def_check_scoped - FStar_TypeChecker_Env.hasBinders_env - FStar_Class_Binders.hasNames_comp FStar_Syntax_Print.pretty_comp - c.FStar_Syntax_Syntax.pos "close_wp_comp" uu___1 c); - (let uu___1 = FStar_Syntax_Util.is_ml_comp c in - if uu___1 - then c - else - (let uu___3 = (FStar_Options.lax ()) && (FStar_Options.ml_ish ()) in - if uu___3 - then c - else - (let env_bvs = FStar_TypeChecker_Env.push_bvs env bvs in - let close_wp u_res md res_t bvs1 wp0 = - let close = - let uu___5 = FStar_Syntax_Util.get_wp_close_combinator md in - FStar_Compiler_Util.must uu___5 in - FStar_Compiler_List.fold_right - (fun x -> - fun wp -> - let bs = - let uu___5 = FStar_Syntax_Syntax.mk_binder x in - [uu___5] in - let us = - let uu___5 = - let uu___6 = - env.FStar_TypeChecker_Env.universe_of env_bvs - x.FStar_Syntax_Syntax.sort in - [uu___6] in - u_res :: uu___5 in - let wp1 = - FStar_Syntax_Util.abs bs wp - (FStar_Pervasives_Native.Some - (FStar_Syntax_Util.mk_residual_comp - FStar_Parser_Const.effect_Tot_lid - FStar_Pervasives_Native.None - [FStar_Syntax_Syntax.TOTAL])) in - let uu___5 = - FStar_TypeChecker_Env.inst_effect_fun_with us env - md close in - let uu___6 = - let uu___7 = FStar_Syntax_Syntax.as_arg res_t in - let uu___8 = - let uu___9 = - FStar_Syntax_Syntax.as_arg - x.FStar_Syntax_Syntax.sort in - let uu___10 = - let uu___11 = FStar_Syntax_Syntax.as_arg wp1 in - [uu___11] in - uu___9 :: uu___10 in - uu___7 :: uu___8 in - FStar_Syntax_Syntax.mk_Tm_app uu___5 uu___6 - wp0.FStar_Syntax_Syntax.pos) bvs1 wp0 in - let c1 = FStar_TypeChecker_Env.unfold_effect_abbrev env_bvs c in - let uu___5 = destruct_wp_comp c1 in - match uu___5 with - | (u_res_t, res_t, wp) -> - let md = - FStar_TypeChecker_Env.get_effect_decl env - c1.FStar_Syntax_Syntax.effect_name in - let wp1 = close_wp u_res_t md res_t bvs wp in - let uu___6 = - FStar_Compiler_List.filter - (fun uu___7 -> - match uu___7 with - | FStar_Syntax_Syntax.MLEFFECT -> true - | FStar_Syntax_Syntax.SHOULD_NOT_INLINE -> true - | uu___8 -> false) c1.FStar_Syntax_Syntax.flags in - mk_comp md u_res_t c1.FStar_Syntax_Syntax.result_typ wp1 - uu___6))) -let (close_wp_lcomp : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.bv Prims.list -> - FStar_TypeChecker_Common.lcomp -> FStar_TypeChecker_Common.lcomp) - = - fun env -> - fun bvs -> - fun lc -> - let bs = FStar_Compiler_List.map FStar_Syntax_Syntax.mk_binder bvs in - FStar_TypeChecker_Common.apply_lcomp (close_wp_comp env bvs) - (fun g -> - let uu___ = FStar_TypeChecker_Env.close_guard env bs g in - close_guard_implicits env false bs uu___) lc -let (substitutive_indexed_close_substs : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.bv -> - FStar_Syntax_Syntax.args -> - Prims.int -> - FStar_Compiler_Range_Type.range -> - FStar_Syntax_Syntax.subst_elt Prims.list) - = - fun env -> - fun close_bs -> - fun a -> - fun b_bv -> - fun ct_args -> - fun num_effect_params -> - fun r -> - let debug = - FStar_Compiler_Effect.op_Bang dbg_LayeredEffectsApp in - let uu___ = - let uu___1 = close_bs in - match uu___1 with - | a_b::b_b::close_bs1 -> - (close_bs1, - [FStar_Syntax_Syntax.NT - ((a_b.FStar_Syntax_Syntax.binder_bv), a); - FStar_Syntax_Syntax.NT - ((b_b.FStar_Syntax_Syntax.binder_bv), - (b_bv.FStar_Syntax_Syntax.sort))]) in - match uu___ with - | (close_bs1, subst) -> - let uu___1 = - let uu___2 = - FStar_Compiler_List.splitAt num_effect_params - close_bs1 in - match uu___2 with - | (eff_params_bs, close_bs2) -> - let uu___3 = - FStar_Compiler_List.splitAt num_effect_params - ct_args in - (match uu___3 with - | (ct_eff_params_args, ct_args1) -> - let uu___4 = - let uu___5 = - FStar_Compiler_List.map2 - (fun b -> - fun uu___6 -> - match uu___6 with - | (arg, uu___7) -> - FStar_Syntax_Syntax.NT - ((b.FStar_Syntax_Syntax.binder_bv), - arg)) eff_params_bs - ct_eff_params_args in - FStar_Compiler_List.op_At subst uu___5 in - (close_bs2, uu___4, ct_args1)) in - (match uu___1 with - | (close_bs2, subst1, ct_args1) -> - let uu___2 = - FStar_Compiler_List.splitAt - ((FStar_Compiler_List.length close_bs2) - - Prims.int_one) close_bs2 in - (match uu___2 with - | (close_bs3, uu___3) -> - FStar_Compiler_List.fold_left2 - (fun ss -> - fun b -> - fun uu___4 -> - match uu___4 with - | (ct_arg, uu___5) -> - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_Syntax_Syntax.mk_binder - b_bv in - [uu___11] in - FStar_Syntax_Util.abs - uu___10 ct_arg - FStar_Pervasives_Native.None in - ((b.FStar_Syntax_Syntax.binder_bv), - uu___9) in - FStar_Syntax_Syntax.NT uu___8 in - [uu___7] in - FStar_Compiler_List.op_At ss - uu___6) subst1 close_bs3 - ct_args1)) -let (close_layered_comp_with_combinator : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.bv Prims.list -> - FStar_Syntax_Syntax.comp -> FStar_Syntax_Syntax.comp) - = - fun env -> - fun bvs -> - fun c -> - let r = c.FStar_Syntax_Syntax.pos in - let env_bvs = FStar_TypeChecker_Env.push_bvs env bvs in - let ct = FStar_TypeChecker_Env.unfold_effect_abbrev env_bvs c in - let ed = - FStar_TypeChecker_Env.get_effect_decl env_bvs - ct.FStar_Syntax_Syntax.effect_name in - let num_effect_params = - match ed.FStar_Syntax_Syntax.signature with - | FStar_Syntax_Syntax.Layered_eff_sig (n, uu___) -> n - | uu___ -> - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_UnexpectedEffect () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "mk_indexed_close called with a non-indexed effect") in - let close_ts = - let uu___ = FStar_Syntax_Util.get_layered_close_combinator ed in - FStar_Compiler_Util.must uu___ in - let effect_args = - FStar_Compiler_List.fold_right - (fun x -> - fun args -> - let u_a = - FStar_Compiler_List.hd ct.FStar_Syntax_Syntax.comp_univs in - let u_b = - env.FStar_TypeChecker_Env.universe_of env_bvs - x.FStar_Syntax_Syntax.sort in - let uu___ = - FStar_TypeChecker_Env.inst_tscheme_with close_ts - [u_a; u_b] in - match uu___ with - | (uu___1, close_t) -> - let uu___2 = FStar_Syntax_Util.abs_formals close_t in - (match uu___2 with - | (close_bs, close_body, uu___3) -> - let ss = - substitutive_indexed_close_substs env_bvs - close_bs ct.FStar_Syntax_Syntax.result_typ x - args num_effect_params r in - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Subst.subst ss close_body in - FStar_Syntax_Subst.compress uu___6 in - uu___5.FStar_Syntax_Syntax.n in - (match uu___4 with - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = uu___5; - FStar_Syntax_Syntax.args = uu___6::args1;_} - -> args1 - | uu___5 -> - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_UnexpectedEffect () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Unexpected close combinator shape")))) - bvs ct.FStar_Syntax_Syntax.effect_args in - FStar_Syntax_Syntax.mk_Comp - { - FStar_Syntax_Syntax.comp_univs = - (ct.FStar_Syntax_Syntax.comp_univs); - FStar_Syntax_Syntax.effect_name = - (ct.FStar_Syntax_Syntax.effect_name); - FStar_Syntax_Syntax.result_typ = - (ct.FStar_Syntax_Syntax.result_typ); - FStar_Syntax_Syntax.effect_args = effect_args; - FStar_Syntax_Syntax.flags = (ct.FStar_Syntax_Syntax.flags) - } -let (close_layered_lcomp_with_combinator : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.bv Prims.list -> - FStar_TypeChecker_Common.lcomp -> FStar_TypeChecker_Common.lcomp) - = - fun env -> - fun bvs -> - fun lc -> - let bs = FStar_Compiler_List.map FStar_Syntax_Syntax.mk_binder bvs in - FStar_TypeChecker_Common.apply_lcomp - (close_layered_comp_with_combinator env bvs) - (fun g -> - let uu___ = FStar_TypeChecker_Env.close_guard env bs g in - close_guard_implicits env false bs uu___) lc -let (close_layered_lcomp_with_substitutions : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.bv Prims.list -> - FStar_Syntax_Syntax.term Prims.list -> - FStar_TypeChecker_Common.lcomp -> FStar_TypeChecker_Common.lcomp) - = - fun env -> - fun bvs -> - fun tms -> - fun lc -> - let bs = FStar_Compiler_List.map FStar_Syntax_Syntax.mk_binder bvs in - let substs = - FStar_Compiler_List.map2 - (fun bv -> fun tm -> FStar_Syntax_Syntax.NT (bv, tm)) bvs tms in - FStar_TypeChecker_Common.apply_lcomp - (FStar_Syntax_Subst.subst_comp substs) - (fun g -> - let uu___ = FStar_TypeChecker_Env.close_guard env bs g in - close_guard_implicits env false bs uu___) lc -let (should_not_inline_lc : FStar_TypeChecker_Common.lcomp -> Prims.bool) = - fun lc -> - FStar_Compiler_Util.for_some - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.SHOULD_NOT_INLINE -> true - | uu___1 -> false) lc.FStar_TypeChecker_Common.cflags -let (should_return : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option -> - FStar_TypeChecker_Common.lcomp -> Prims.bool) - = - fun env -> - fun eopt -> - fun lc -> - let lc_is_unit_or_effectful = - let c = - let uu___ = - FStar_Syntax_Util.arrow_formals_comp - lc.FStar_TypeChecker_Common.res_typ in - FStar_Pervasives_Native.snd uu___ in - let uu___ = FStar_TypeChecker_Env.is_reifiable_comp env c in - if uu___ - then - let c_eff_name = - FStar_TypeChecker_Env.norm_eff_name env - (FStar_Syntax_Util.comp_effect_name c) in - let uu___1 = - (FStar_TypeChecker_Common.is_pure_or_ghost_lcomp lc) && - (FStar_Ident.lid_equals c_eff_name - FStar_Parser_Const.effect_TAC_lid) in - (if uu___1 - then false - else FStar_TypeChecker_Env.is_layered_effect env c_eff_name) - else - (let uu___2 = FStar_Syntax_Util.is_pure_or_ghost_comp c in - if uu___2 - then - let uu___3 = - FStar_TypeChecker_Normalize.unfold_whnf env - (FStar_Syntax_Util.comp_result c) in - FStar_Syntax_Util.is_unit uu___3 - else true) in - match eopt with - | FStar_Pervasives_Native.None -> false - | FStar_Pervasives_Native.Some e -> - (((FStar_TypeChecker_Common.is_pure_or_ghost_lcomp lc) && - (Prims.op_Negation lc_is_unit_or_effectful)) - && - (let uu___ = FStar_Syntax_Util.head_and_args_full e in - match uu___ with - | (head, uu___1) -> - let uu___2 = - let uu___3 = FStar_Syntax_Util.un_uinst head in - uu___3.FStar_Syntax_Syntax.n in - (match uu___2 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - let uu___3 = - let uu___4 = FStar_Syntax_Syntax.lid_of_fv fv in - FStar_TypeChecker_Env.is_irreducible env uu___4 in - Prims.op_Negation uu___3 - | uu___3 -> true))) - && - (let uu___ = should_not_inline_lc lc in Prims.op_Negation uu___) -let (substitutive_indexed_bind_substs : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.eff_decl -> - FStar_Syntax_Syntax.eff_decl -> - FStar_Syntax_Syntax.eff_decl -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.indexed_effect_binder_kind Prims.list -> - FStar_Syntax_Syntax.comp_typ -> - FStar_Syntax_Syntax.bv FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.comp_typ -> - FStar_Compiler_Range_Type.range -> - Prims.int -> - Prims.bool -> - (FStar_Syntax_Syntax.subst_elt Prims.list * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun m_ed -> - fun n_ed -> - fun p_ed -> - fun bs -> - fun binder_kinds -> - fun ct1 -> - fun b -> - fun ct2 -> - fun r1 -> - fun num_effect_params -> - fun has_range_binders -> - let debug = - FStar_Compiler_Effect.op_Bang - dbg_LayeredEffectsApp in - let bind_name uu___ = - if debug - then - let uu___1 = - let uu___2 = - FStar_Ident.ident_of_lid - m_ed.FStar_Syntax_Syntax.mname in - FStar_Ident.string_of_id uu___2 in - let uu___2 = - let uu___3 = - FStar_Ident.ident_of_lid - n_ed.FStar_Syntax_Syntax.mname in - FStar_Ident.string_of_id uu___3 in - let uu___3 = - let uu___4 = - FStar_Ident.ident_of_lid - p_ed.FStar_Syntax_Syntax.mname in - FStar_Ident.string_of_id uu___4 in - FStar_Compiler_Util.format3 "(%s, %s) |> %s" - uu___1 uu___2 uu___3 - else "" in - let uu___ = - let uu___1 = bs in - match uu___1 with - | a_b::b_b::bs1 -> - let uu___2 = - let uu___3 = - FStar_Compiler_List.splitAt - (Prims.of_int (2)) binder_kinds in - FStar_Pervasives_Native.snd uu___3 in - (bs1, uu___2, - [FStar_Syntax_Syntax.NT - ((a_b.FStar_Syntax_Syntax.binder_bv), - (ct1.FStar_Syntax_Syntax.result_typ)); - FStar_Syntax_Syntax.NT - ((b_b.FStar_Syntax_Syntax.binder_bv), - (ct2.FStar_Syntax_Syntax.result_typ))]) in - match uu___ with - | (bs1, binder_kinds1, subst) -> - let uu___1 = - if num_effect_params = Prims.int_zero - then - (bs1, binder_kinds1, subst, - FStar_TypeChecker_Env.trivial_guard, - (ct1.FStar_Syntax_Syntax.effect_args), - (ct2.FStar_Syntax_Syntax.effect_args)) - else - (let split l = - FStar_Compiler_List.splitAt - num_effect_params l in - let uu___3 = split bs1 in - match uu___3 with - | (eff_params_bs, bs2) -> - let uu___4 = split binder_kinds1 in - (match uu___4 with - | (uu___5, binder_kinds2) -> - let uu___6 = - split - ct1.FStar_Syntax_Syntax.effect_args in - (match uu___6 with - | (param_args1, args1) -> - let uu___7 = - split - ct2.FStar_Syntax_Syntax.effect_args in - (match uu___7 with - | (param_args2, args2) -> - let g = - FStar_Compiler_List.fold_left2 - (fun g1 -> - fun uu___8 -> - fun uu___9 -> - match - (uu___8, - uu___9) - with - | ((arg1, - uu___10), - (arg2, - uu___11)) - -> - let uu___12 - = - FStar_TypeChecker_Rel.layered_effect_teq - env arg1 - arg2 - (FStar_Pervasives_Native.Some - "effect param bind") in - FStar_TypeChecker_Env.conj_guard - g1 - uu___12) - FStar_TypeChecker_Env.trivial_guard - param_args1 - param_args2 in - let param_subst = - FStar_Compiler_List.map2 - (fun b1 -> - fun uu___8 -> - match uu___8 - with - | (arg, - uu___9) -> - FStar_Syntax_Syntax.NT - ((b1.FStar_Syntax_Syntax.binder_bv), - arg)) - eff_params_bs - param_args1 in - (bs2, binder_kinds2, - (FStar_Compiler_List.op_At - subst param_subst), - g, args1, args2))))) in - (match uu___1 with - | (bs2, binder_kinds2, subst1, guard, args1, - args2) -> - let uu___2 = - let m_num_effect_args = - FStar_Compiler_List.length args1 in - let uu___3 = - FStar_Compiler_List.splitAt - m_num_effect_args bs2 in - match uu___3 with - | (f_bs, bs3) -> - let f_subst = - FStar_Compiler_List.map2 - (fun f_b -> - fun arg -> - FStar_Syntax_Syntax.NT - ((f_b.FStar_Syntax_Syntax.binder_bv), - (FStar_Pervasives_Native.fst - arg))) f_bs args1 in - let uu___4 = - let uu___5 = - FStar_Compiler_List.splitAt - m_num_effect_args - binder_kinds2 in - FStar_Pervasives_Native.snd uu___5 in - (bs3, uu___4, - (FStar_Compiler_List.op_At subst1 - f_subst)) in - (match uu___2 with - | (bs3, binder_kinds3, subst2) -> - let uu___3 = - let n_num_effect_args = - FStar_Compiler_List.length args2 in - let uu___4 = - FStar_Compiler_List.splitAt - n_num_effect_args bs3 in - match uu___4 with - | (g_bs, bs4) -> - let g_bs_kinds = - let uu___5 = - FStar_Compiler_List.splitAt - n_num_effect_args - binder_kinds3 in - FStar_Pervasives_Native.fst - uu___5 in - let x_bv = - match b with - | FStar_Pervasives_Native.None - -> - FStar_Syntax_Syntax.null_bv - ct1.FStar_Syntax_Syntax.result_typ - | FStar_Pervasives_Native.Some - x -> x in - let uu___5 = - let uu___6 = - FStar_Compiler_List.zip - g_bs g_bs_kinds in - FStar_Compiler_List.fold_left2 - (fun uu___7 -> - fun uu___8 -> - fun arg -> - match (uu___7, - uu___8) - with - | ((ss, g), - (g_b, g_b_kind)) - -> - if - g_b_kind = - FStar_Syntax_Syntax.Substitutive_binder - then - let arg_t = - let uu___9 = - let uu___10 - = - FStar_Syntax_Syntax.mk_binder - x_bv in - [uu___10] in - FStar_Syntax_Util.abs - uu___9 - (FStar_Pervasives_Native.fst - arg) - FStar_Pervasives_Native.None in - ((FStar_Compiler_List.op_At - ss - [FStar_Syntax_Syntax.NT - ((g_b.FStar_Syntax_Syntax.binder_bv), - arg_t)]), - g) - else - if - g_b_kind = - FStar_Syntax_Syntax.BindCont_no_abstraction_binder - then - (let uu___10 - = - FStar_TypeChecker_Env.uvars_for_binders - env - [g_b] ss - (fun b1 - -> - if debug - then - let uu___11 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_binder - b1 in - let uu___12 - = - bind_name - () in - let uu___13 - = - FStar_Compiler_Range_Ops.string_of_range - r1 in - FStar_Compiler_Util.format3 - "implicit var for no abs g binder %s of %s at %s" - uu___11 - uu___12 - uu___13 - else - "substitutive_indexed_bind_substs.1") - r1 in - match uu___10 - with - | (uv_t::[], - g_uv) -> - let g_unif - = - let uu___11 - = - let uu___12 - = - let uu___13 - = - FStar_Syntax_Syntax.mk_binder - x_bv in - [uu___13] in - FStar_TypeChecker_Env.push_binders - env - uu___12 in - FStar_TypeChecker_Rel.layered_effect_teq - uu___11 - uv_t - (FStar_Pervasives_Native.fst - arg) - (FStar_Pervasives_Native.Some - "") in - let uu___11 - = - FStar_TypeChecker_Env.conj_guards - [g; - g_uv; - g_unif] in - ((FStar_Compiler_List.op_At - ss - [ - FStar_Syntax_Syntax.NT - ((g_b.FStar_Syntax_Syntax.binder_bv), - uv_t)]), - uu___11)) - else - failwith - "Impossible (standard bind with unexpected binder kind)") - (subst2, guard) uu___6 - args2 in - (match uu___5 with - | (subst3, guard1) -> - (bs4, subst3, guard1)) in - (match uu___3 with - | (bs4, subst3, guard1) -> - let bs5 = - if has_range_binders - then - let uu___4 = - FStar_Compiler_List.splitAt - (Prims.of_int (2)) bs4 in - FStar_Pervasives_Native.snd - uu___4 - else bs4 in - let bs6 = - let uu___4 = - FStar_Compiler_List.splitAt - ((FStar_Compiler_List.length - bs5) - - (Prims.of_int (2))) - bs5 in - FStar_Pervasives_Native.fst - uu___4 in - FStar_Compiler_List.fold_left - (fun uu___4 -> - fun b1 -> - match uu___4 with - | (ss, g) -> - let uu___5 = - FStar_TypeChecker_Env.uvars_for_binders - env [b1] ss - (fun b2 -> - if debug - then - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_binder - b2 in - let uu___7 = - bind_name - () in - let uu___8 = - FStar_Compiler_Range_Ops.string_of_range - r1 in - FStar_Compiler_Util.format3 - "implicit var for additional g binder %s of %s at %s" - uu___6 - uu___7 - uu___8 - else - "substitutive_indexed_bind_substs.2") - r1 in - (match uu___5 with - | (uv_t::[], g_uv) - -> - let uu___6 = - FStar_TypeChecker_Env.conj_guard - g g_uv in - ((FStar_Compiler_List.op_At - ss - [FStar_Syntax_Syntax.NT - ((b1.FStar_Syntax_Syntax.binder_bv), - uv_t)]), - uu___6))) - (subst3, guard1) bs6))) -let (ad_hoc_indexed_bind_substs : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.eff_decl -> - FStar_Syntax_Syntax.eff_decl -> - FStar_Syntax_Syntax.eff_decl -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.comp_typ -> - FStar_Syntax_Syntax.bv FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.comp_typ -> - FStar_Compiler_Range_Type.range -> - Prims.bool -> - (FStar_Syntax_Syntax.subst_elt Prims.list * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun m_ed -> - fun n_ed -> - fun p_ed -> - fun bs -> - fun ct1 -> - fun b -> - fun ct2 -> - fun r1 -> - fun has_range_binders -> - let debug = - FStar_Compiler_Effect.op_Bang dbg_LayeredEffectsApp in - let bind_name uu___ = - if debug - then - let uu___1 = - let uu___2 = - FStar_Ident.ident_of_lid - m_ed.FStar_Syntax_Syntax.mname in - FStar_Ident.string_of_id uu___2 in - let uu___2 = - let uu___3 = - FStar_Ident.ident_of_lid - n_ed.FStar_Syntax_Syntax.mname in - FStar_Ident.string_of_id uu___3 in - let uu___3 = - let uu___4 = - FStar_Ident.ident_of_lid - p_ed.FStar_Syntax_Syntax.mname in - FStar_Ident.string_of_id uu___4 in - FStar_Compiler_Util.format3 "(%s, %s) |> %s" uu___1 - uu___2 uu___3 - else "" in - let bind_t_shape_error r s = - let uu___ = - let uu___1 = bind_name () in - FStar_Compiler_Util.format2 - "bind %s does not have proper shape (reason:%s)" - uu___1 s in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Fatal_UnexpectedEffect () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___) in - let num_range_binders = - if has_range_binders - then (Prims.of_int (2)) - else Prims.int_zero in - let uu___ = - if - (FStar_Compiler_List.length bs) >= - (num_range_binders + (Prims.of_int (4))) - then - let uu___1 = bs in - match uu___1 with - | a_b::b_b::bs1 -> - let uu___2 = - let uu___3 = - FStar_Compiler_List.splitAt - (((FStar_Compiler_List.length bs1) - - (Prims.of_int (2))) - - num_range_binders) bs1 in - match uu___3 with - | (l1, l2) -> - let uu___4 = - FStar_Compiler_List.splitAt - num_range_binders l2 in - (match uu___4 with - | (uu___5, l21) -> - let uu___6 = - FStar_Compiler_List.hd l21 in - let uu___7 = - let uu___8 = - FStar_Compiler_List.tl l21 in - FStar_Compiler_List.hd uu___8 in - (l1, uu___6, uu___7)) in - (match uu___2 with - | (rest_bs, f_b, g_b) -> - (a_b, b_b, rest_bs, f_b, g_b)) - else - bind_t_shape_error r1 - "Either not an arrow or not enough binders" in - match uu___ with - | (a_b, b_b, rest_bs, f_b, g_b) -> - let uu___1 = - FStar_TypeChecker_Env.uvars_for_binders env - rest_bs - [FStar_Syntax_Syntax.NT - ((a_b.FStar_Syntax_Syntax.binder_bv), - (ct1.FStar_Syntax_Syntax.result_typ)); - FStar_Syntax_Syntax.NT - ((b_b.FStar_Syntax_Syntax.binder_bv), - (ct2.FStar_Syntax_Syntax.result_typ))] - (fun b1 -> - if debug - then - let uu___2 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_binder b1 in - let uu___3 = bind_name () in - let uu___4 = - FStar_Compiler_Range_Ops.string_of_range - r1 in - FStar_Compiler_Util.format3 - "implicit var for binder %s of %s at %s" - uu___2 uu___3 uu___4 - else "ad_hoc_indexed_bind_substs") r1 in - (match uu___1 with - | (rest_bs_uvars, g_uvars) -> - ((let uu___3 = - FStar_Compiler_Effect.op_Bang - dbg_ResolveImplicitsHook in - if uu___3 - then - FStar_Compiler_List.iter - (fun t -> - let uu___4 = - let uu___5 = - FStar_Syntax_Subst.compress t in - uu___5.FStar_Syntax_Syntax.n in - match uu___4 with - | FStar_Syntax_Syntax.Tm_uvar - (u, uu___5) -> - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t in - let uu___7 = - FStar_Class_Show.show - (FStar_Class_Show.show_option - FStar_Syntax_Print.showable_ctx_uvar_meta) - u.FStar_Syntax_Syntax.ctx_uvar_meta in - FStar_Compiler_Util.print2 - "Generated uvar %s with attribute %s\n" - uu___6 uu___7 - | uu___5 -> - let uu___6 = - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t in - Prims.strcat - "Impossible, expected a uvar, got : " - uu___7 in - failwith uu___6) rest_bs_uvars - else ()); - (let subst = - FStar_Compiler_List.map2 - (fun b1 -> - fun t -> - FStar_Syntax_Syntax.NT - ((b1.FStar_Syntax_Syntax.binder_bv), - t)) (a_b :: b_b :: rest_bs) - ((ct1.FStar_Syntax_Syntax.result_typ) :: - (ct2.FStar_Syntax_Syntax.result_typ) :: - rest_bs_uvars) in - let f_guard = - let f_sort_is = - let uu___3 = - let uu___4 = - FStar_Syntax_Subst.compress - (f_b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - let uu___5 = - FStar_Syntax_Util.is_layered m_ed in - effect_args_from_repr uu___4 uu___5 r1 in - FStar_Compiler_List.map - (FStar_Syntax_Subst.subst subst) - uu___3 in - let uu___3 = - FStar_Compiler_List.map - FStar_Pervasives_Native.fst - ct1.FStar_Syntax_Syntax.effect_args in - FStar_Compiler_List.fold_left2 - (fun g -> - fun i1 -> - fun f_i1 -> - (let uu___5 = - FStar_Compiler_Effect.op_Bang - dbg_ResolveImplicitsHook in - if uu___5 - then - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - i1 in - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - f_i1 in - FStar_Compiler_Util.print2 - "Generating constraint %s = %s\n" - uu___6 uu___7 - else ()); - (let uu___5 = - let uu___6 = - let uu___7 = bind_name () in - FStar_Pervasives_Native.Some - uu___7 in - FStar_TypeChecker_Rel.layered_effect_teq - env i1 f_i1 uu___6 in - FStar_TypeChecker_Env.conj_guard - g uu___5)) - FStar_TypeChecker_Env.trivial_guard - uu___3 f_sort_is in - let g_guard = - let x_a = - match b with - | FStar_Pervasives_Native.None -> - FStar_Syntax_Syntax.null_binder - ct1.FStar_Syntax_Syntax.result_typ - | FStar_Pervasives_Native.Some x -> - FStar_Syntax_Syntax.mk_binder - { - FStar_Syntax_Syntax.ppname = - (x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (x.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = - (ct1.FStar_Syntax_Syntax.result_typ) - } in - let g_sort_is = - let uu___3 = - let uu___4 = - FStar_Syntax_Subst.compress - (g_b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - uu___4.FStar_Syntax_Syntax.n in - match uu___3 with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs1; - FStar_Syntax_Syntax.comp = c;_} - -> - let uu___4 = - FStar_Syntax_Subst.open_comp bs1 c in - (match uu___4 with - | (bs2, c1) -> - let bs_subst = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Compiler_List.hd - bs2 in - uu___7.FStar_Syntax_Syntax.binder_bv in - let uu___7 = - FStar_Syntax_Syntax.bv_to_name - x_a.FStar_Syntax_Syntax.binder_bv in - (uu___6, uu___7) in - FStar_Syntax_Syntax.NT uu___5 in - let c2 = - FStar_Syntax_Subst.subst_comp - [bs_subst] c1 in - let uu___5 = - let uu___6 = - FStar_Syntax_Subst.compress - (FStar_Syntax_Util.comp_result - c2) in - let uu___7 = - FStar_Syntax_Util.is_layered - n_ed in - effect_args_from_repr uu___6 - uu___7 r1 in - FStar_Compiler_List.map - (FStar_Syntax_Subst.subst - subst) uu___5) - | uu___4 -> - failwith - "impossible: mk_indexed_bind" in - let env_g = - FStar_TypeChecker_Env.push_binders env - [x_a] in - let uu___3 = - let uu___4 = - FStar_Compiler_List.map - FStar_Pervasives_Native.fst - ct2.FStar_Syntax_Syntax.effect_args in - FStar_Compiler_List.fold_left2 - (fun g -> - fun i1 -> - fun g_i1 -> - (let uu___6 = - FStar_Compiler_Effect.op_Bang - dbg_ResolveImplicitsHook in - if uu___6 - then - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - i1 in - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - g_i1 in - FStar_Compiler_Util.print2 - "Generating constraint %s = %s\n" - uu___7 uu___8 - else ()); - (let uu___6 = - let uu___7 = - let uu___8 = bind_name () in - FStar_Pervasives_Native.Some - uu___8 in - FStar_TypeChecker_Rel.layered_effect_teq - env_g i1 g_i1 uu___7 in - FStar_TypeChecker_Env.conj_guard - g uu___6)) - FStar_TypeChecker_Env.trivial_guard - uu___4 g_sort_is in - FStar_TypeChecker_Env.close_guard env - [x_a] uu___3 in - let uu___3 = - FStar_TypeChecker_Env.conj_guards - [g_uvars; f_guard; g_guard] in - (subst, uu___3)))) -let (mk_indexed_return : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.eff_decl -> - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.term -> - FStar_Compiler_Range_Type.range -> - (FStar_Syntax_Syntax.comp * FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun ed -> - fun u_a -> - fun a -> - fun e -> - fun r -> - let debug = FStar_Compiler_Effect.op_Bang dbg_LayeredEffectsApp in - if debug - then - (let uu___1 = - FStar_Ident.string_of_lid ed.FStar_Syntax_Syntax.mname in - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_univ u_a in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term a in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - FStar_Compiler_Util.print4 - "Computing %s.return for u_a:%s, a:%s, and e:%s{\n" uu___1 - uu___2 uu___3 uu___4) - else (); - (let uu___1 = - let uu___2 = FStar_Syntax_Util.get_return_vc_combinator ed in - FStar_TypeChecker_Env.inst_tscheme_with uu___2 [u_a] in - match uu___1 with - | (uu___2, return_t) -> - let return_t_shape_error r1 s = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Class_PP.pp FStar_Ident.pretty_lident - ed.FStar_Syntax_Syntax.mname in - let uu___6 = - let uu___7 = FStar_Errors_Msg.text ".return" in - let uu___8 = - FStar_Errors_Msg.text - "does not have proper shape" in - FStar_Pprint.op_Hat_Slash_Hat uu___7 uu___8 in - FStar_Pprint.op_Hat_Slash_Hat uu___5 uu___6 in - let uu___5 = - let uu___6 = - let uu___7 = FStar_Errors_Msg.text "Reason: " in - let uu___8 = FStar_Errors_Msg.text s in - FStar_Pprint.op_Hat_Hat uu___7 uu___8 in - [uu___6] in - uu___4 :: uu___5 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range r1 - FStar_Errors_Codes.Fatal_UnexpectedEffect () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___3) in - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Subst.compress return_t in - uu___5.FStar_Syntax_Syntax.n in - match uu___4 with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; - FStar_Syntax_Syntax.comp = c;_} - when - (FStar_Compiler_List.length bs) >= - (Prims.of_int (2)) - -> - let uu___5 = FStar_Syntax_Subst.open_comp bs c in - (match uu___5 with - | (a_b::x_b::bs1, c1) -> - (a_b, x_b, bs1, - (FStar_Syntax_Util.comp_result c1))) - | uu___5 -> - return_t_shape_error r - "Either not an arrow or not enough binders" in - (match uu___3 with - | (a_b, x_b, rest_bs, return_typ) -> - let uu___4 = - FStar_TypeChecker_Env.uvars_for_binders env rest_bs - [FStar_Syntax_Syntax.NT - ((a_b.FStar_Syntax_Syntax.binder_bv), a); - FStar_Syntax_Syntax.NT - ((x_b.FStar_Syntax_Syntax.binder_bv), e)] - (fun b -> - if debug - then - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_binder b in - let uu___6 = - let uu___7 = - FStar_Ident.string_of_lid - ed.FStar_Syntax_Syntax.mname in - FStar_Compiler_Util.format1 "%s.return" - uu___7 in - let uu___7 = - FStar_Compiler_Range_Ops.string_of_range r in - FStar_Compiler_Util.format3 - "implicit var for binder %s of %s at %s" - uu___5 uu___6 uu___7 - else "mk_indexed_return_env") r in - (match uu___4 with - | (rest_bs_uvars, g_uvars) -> - let subst = - FStar_Compiler_List.map2 - (fun b -> - fun t -> - FStar_Syntax_Syntax.NT - ((b.FStar_Syntax_Syntax.binder_bv), - t)) (a_b :: x_b :: rest_bs) (a :: e - :: rest_bs_uvars) in - let is = - let uu___5 = - let uu___6 = - FStar_Syntax_Subst.compress return_typ in - let uu___7 = FStar_Syntax_Util.is_layered ed in - effect_args_from_repr uu___6 uu___7 r in - FStar_Compiler_List.map - (FStar_Syntax_Subst.subst subst) uu___5 in - let c = - let uu___5 = - let uu___6 = - FStar_Compiler_List.map - FStar_Syntax_Syntax.as_arg is in - { - FStar_Syntax_Syntax.comp_univs = [u_a]; - FStar_Syntax_Syntax.effect_name = - (ed.FStar_Syntax_Syntax.mname); - FStar_Syntax_Syntax.result_typ = a; - FStar_Syntax_Syntax.effect_args = uu___6; - FStar_Syntax_Syntax.flags = [] - } in - FStar_Syntax_Syntax.mk_Comp uu___5 in - (if debug - then - (let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_comp c in - FStar_Compiler_Util.print1 - "} c after return %s\n" uu___6) - else (); - (c, g_uvars))))) -let (mk_indexed_bind : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident -> - FStar_Ident.lident -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.tscheme -> - FStar_Syntax_Syntax.indexed_effect_combinator_kind -> - FStar_Syntax_Syntax.comp_typ -> - FStar_Syntax_Syntax.bv FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.comp_typ -> - FStar_Syntax_Syntax.cflag Prims.list -> - FStar_Compiler_Range_Type.range -> - Prims.int -> - Prims.bool -> - (FStar_Syntax_Syntax.comp * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun m -> - fun n -> - fun p -> - fun bind_t -> - fun bind_combinator_kind -> - fun ct1 -> - fun b -> - fun ct2 -> - fun flags -> - fun r1 -> - fun num_effect_params -> - fun has_range_binders -> - let debug = - FStar_Compiler_Effect.op_Bang - dbg_LayeredEffectsApp in - if debug - then - (let uu___1 = - let uu___2 = FStar_Syntax_Syntax.mk_Comp ct1 in - FStar_Class_Show.show - FStar_Syntax_Print.showable_comp uu___2 in - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.mk_Comp ct2 in - FStar_Class_Show.show - FStar_Syntax_Print.showable_comp uu___3 in - FStar_Compiler_Util.print2 - "Binding indexed effects: c1:%s and c2:%s {\n" - uu___1 uu___2) - else (); - (let uu___2 = - FStar_Compiler_Effect.op_Bang - dbg_ResolveImplicitsHook in - if uu___2 - then - let uu___3 = - let uu___4 = - FStar_TypeChecker_Env.get_range env in - FStar_Compiler_Range_Ops.string_of_range - uu___4 in - let uu___4 = - FStar_Syntax_Print.tscheme_to_string bind_t in - FStar_Compiler_Util.print2 - "///////////////////////////////Bind at %s/////////////////////\nwith bind_t = %s\n" - uu___3 uu___4 - else ()); - (let uu___2 = - let uu___3 = - FStar_TypeChecker_Env.get_effect_decl env m in - let uu___4 = - FStar_TypeChecker_Env.get_effect_decl env n in - let uu___5 = - FStar_TypeChecker_Env.get_effect_decl env p in - (uu___3, uu___4, uu___5) in - match uu___2 with - | (m_ed, n_ed, p_ed) -> - let bind_name uu___3 = - let uu___4 = - let uu___5 = - FStar_Ident.ident_of_lid - m_ed.FStar_Syntax_Syntax.mname in - FStar_Ident.string_of_id uu___5 in - let uu___5 = - let uu___6 = - FStar_Ident.ident_of_lid - n_ed.FStar_Syntax_Syntax.mname in - FStar_Ident.string_of_id uu___6 in - let uu___6 = - let uu___7 = - FStar_Ident.ident_of_lid - p_ed.FStar_Syntax_Syntax.mname in - FStar_Ident.string_of_id uu___7 in - FStar_Compiler_Util.format3 - "(%s, %s) |> %s" uu___4 uu___5 uu___6 in - ((let uu___4 = - (((FStar_TypeChecker_Env.is_erasable_effect - env m) - && - (let uu___5 = - FStar_TypeChecker_Env.is_erasable_effect - env p in - Prims.op_Negation uu___5)) - && - (let uu___5 = - FStar_TypeChecker_Normalize.non_info_norm - env - ct1.FStar_Syntax_Syntax.result_typ in - Prims.op_Negation uu___5)) - || - (((FStar_TypeChecker_Env.is_erasable_effect - env n) - && - (let uu___5 = - FStar_TypeChecker_Env.is_erasable_effect - env p in - Prims.op_Negation uu___5)) - && - (let uu___5 = - FStar_TypeChecker_Normalize.non_info_norm - env - ct2.FStar_Syntax_Syntax.result_typ in - Prims.op_Negation uu___5)) in - if uu___4 - then - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Errors_Msg.text - "Cannot apply bind" in - let uu___8 = - let uu___9 = - let uu___10 = bind_name () in - FStar_Pprint.doc_of_string - uu___10 in - let uu___10 = - let uu___11 = - FStar_Errors_Msg.text "since" in - let uu___12 = - let uu___13 = - FStar_Class_PP.pp - FStar_Ident.pretty_lident - p in - let uu___14 = - FStar_Errors_Msg.text - "is not erasable and one of the computations is informative." in - FStar_Pprint.op_Hat_Slash_Hat - uu___13 uu___14 in - FStar_Pprint.op_Hat_Slash_Hat - uu___11 uu___12 in - FStar_Pprint.op_Hat_Slash_Hat - uu___9 uu___10 in - FStar_Pprint.op_Hat_Slash_Hat uu___7 - uu___8 in - [uu___6] in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range r1 - FStar_Errors_Codes.Fatal_UnexpectedEffect - () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___5) - else ()); - (let uu___4 = - let uu___5 = - let uu___6 = - FStar_Compiler_List.hd - ct1.FStar_Syntax_Syntax.comp_univs in - let uu___7 = - let uu___8 = - FStar_Compiler_List.hd - ct2.FStar_Syntax_Syntax.comp_univs in - [uu___8] in - uu___6 :: uu___7 in - FStar_TypeChecker_Env.inst_tscheme_with - bind_t uu___5 in - match uu___4 with - | (uu___5, bind_t1) -> - let uu___6 = - FStar_Syntax_Util.arrow_formals_comp - bind_t1 in - (match uu___6 with - | (bind_t_bs, bind_c) -> - let uu___7 = - if - bind_combinator_kind = - FStar_Syntax_Syntax.Ad_hoc_combinator - then - ad_hoc_indexed_bind_substs - env m_ed n_ed p_ed - bind_t_bs ct1 b ct2 r1 - has_range_binders - else - (let uu___9 = - bind_combinator_kind in - match uu___9 with - | FStar_Syntax_Syntax.Substitutive_combinator - binder_kinds -> - substitutive_indexed_bind_substs - env m_ed n_ed p_ed - bind_t_bs binder_kinds - ct1 b ct2 r1 - num_effect_params - has_range_binders) in - (match uu___7 with - | (subst, g) -> - let bind_ct = - let uu___8 = - FStar_Syntax_Subst.subst_comp - subst bind_c in - FStar_TypeChecker_Env.comp_to_comp_typ - env uu___8 in - let fml = - let uu___8 = - let uu___9 = - FStar_Compiler_List.hd - bind_ct.FStar_Syntax_Syntax.comp_univs in - let uu___10 = - let uu___11 = - FStar_Compiler_List.hd - bind_ct.FStar_Syntax_Syntax.effect_args in - FStar_Pervasives_Native.fst - uu___11 in - (uu___9, uu___10) in - match uu___8 with - | (u, wp) -> - FStar_TypeChecker_Env.pure_precondition_for_trivial_post - env u - bind_ct.FStar_Syntax_Syntax.result_typ - wp - FStar_Compiler_Range_Type.dummyRange in - let is = - let uu___8 = - FStar_Syntax_Subst.compress - bind_ct.FStar_Syntax_Syntax.result_typ in - let uu___9 = - FStar_Syntax_Util.is_layered - p_ed in - effect_args_from_repr - uu___8 uu___9 r1 in - let c = - let uu___8 = - let uu___9 = - FStar_Compiler_List.map - FStar_Syntax_Syntax.as_arg - is in - { - FStar_Syntax_Syntax.comp_univs - = - (ct2.FStar_Syntax_Syntax.comp_univs); - FStar_Syntax_Syntax.effect_name - = - (p_ed.FStar_Syntax_Syntax.mname); - FStar_Syntax_Syntax.result_typ - = - (ct2.FStar_Syntax_Syntax.result_typ); - FStar_Syntax_Syntax.effect_args - = uu___9; - FStar_Syntax_Syntax.flags - = flags - } in - FStar_Syntax_Syntax.mk_Comp - uu___8 in - (if debug - then - (let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_comp - c in - FStar_Compiler_Util.print1 - "} c after bind: %s\n" - uu___9) - else (); - (let guard = - let uu___9 = - let uu___10 = - let uu___11 = - FStar_TypeChecker_Env.guard_of_guard_formula - (FStar_TypeChecker_Common.NonTrivial - fml) in - [uu___11] in - g :: uu___10 in - FStar_TypeChecker_Env.conj_guards - uu___9 in - (let uu___10 = - FStar_Compiler_Effect.op_Bang - dbg_ResolveImplicitsHook in - if uu___10 - then - let uu___11 = - let uu___12 = - FStar_TypeChecker_Env.get_range - env in - FStar_Compiler_Range_Ops.string_of_range - uu___12 in - let uu___12 = - FStar_TypeChecker_Rel.guard_to_string - env guard in - FStar_Compiler_Util.print2 - "///////////////////////////////EndBind at %s/////////////////////\nguard = %s\n" - uu___11 uu___12 - else ()); - (c, guard)))))))) -let (mk_wp_bind : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.comp_typ -> - FStar_Syntax_Syntax.bv FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.comp_typ -> - FStar_Syntax_Syntax.cflag Prims.list -> - FStar_Compiler_Range_Type.range -> FStar_Syntax_Syntax.comp) - = - fun env -> - fun m -> - fun ct1 -> - fun b -> - fun ct2 -> - fun flags -> - fun r1 -> - let uu___ = - let md = FStar_TypeChecker_Env.get_effect_decl env m in - let uu___1 = FStar_TypeChecker_Env.wp_signature env m in - match uu___1 with - | (a, kwp) -> - let uu___2 = destruct_wp_comp ct1 in - let uu___3 = destruct_wp_comp ct2 in - ((md, a, kwp), uu___2, uu___3) in - match uu___ with - | ((md, a, kwp), (u_t1, t1, wp1), (u_t2, t2, wp2)) -> - let bs = - match b with - | FStar_Pervasives_Native.None -> - let uu___1 = FStar_Syntax_Syntax.null_binder t1 in - [uu___1] - | FStar_Pervasives_Native.Some x -> - let uu___1 = FStar_Syntax_Syntax.mk_binder x in - [uu___1] in - let mk_lam wp = - FStar_Syntax_Util.abs bs wp - (FStar_Pervasives_Native.Some - (FStar_Syntax_Util.mk_residual_comp - FStar_Parser_Const.effect_Tot_lid - FStar_Pervasives_Native.None - [FStar_Syntax_Syntax.TOTAL])) in - let wp_args = - let uu___1 = FStar_Syntax_Syntax.as_arg t1 in - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.as_arg t2 in - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.as_arg wp1 in - let uu___6 = - let uu___7 = - let uu___8 = mk_lam wp2 in - FStar_Syntax_Syntax.as_arg uu___8 in - [uu___7] in - uu___5 :: uu___6 in - uu___3 :: uu___4 in - uu___1 :: uu___2 in - let uu___1 = FStar_Syntax_Util.get_bind_vc_combinator md in - (match uu___1 with - | (bind_wp, uu___2) -> - let wp = - let uu___3 = - FStar_TypeChecker_Env.inst_effect_fun_with - [u_t1; u_t2] env md bind_wp in - FStar_Syntax_Syntax.mk_Tm_app uu___3 wp_args - t2.FStar_Syntax_Syntax.pos in - mk_comp md u_t2 t2 wp flags) -let (mk_bind : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.comp -> - FStar_Syntax_Syntax.bv FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.comp -> - FStar_Syntax_Syntax.cflag Prims.list -> - FStar_Compiler_Range_Type.range -> - (FStar_Syntax_Syntax.comp * FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun c1 -> - fun b -> - fun c2 -> - fun flags -> - fun r1 -> - let env2 = maybe_push env b in - let uu___ = - let uu___1 = - FStar_TypeChecker_Env.unfold_effect_abbrev env c1 in - let uu___2 = - FStar_TypeChecker_Env.unfold_effect_abbrev env2 c2 in - (uu___1, uu___2) in - match uu___ with - | (ct1, ct2) -> - let uu___1 = - FStar_TypeChecker_Env.exists_polymonadic_bind env - ct1.FStar_Syntax_Syntax.effect_name - ct2.FStar_Syntax_Syntax.effect_name in - (match uu___1 with - | FStar_Pervasives_Native.Some (p, f_bind) -> - f_bind env ct1 b ct2 flags r1 - | FStar_Pervasives_Native.None -> - let uu___2 = lift_comps env c1 c2 b true in - (match uu___2 with - | (m, c11, c21, g_lift) -> - let uu___3 = - let uu___4 = - FStar_TypeChecker_Env.comp_to_comp_typ env - c11 in - let uu___5 = - FStar_TypeChecker_Env.comp_to_comp_typ env2 - c21 in - (uu___4, uu___5) in - (match uu___3 with - | (ct11, ct21) -> - let uu___4 = - let uu___5 = - FStar_TypeChecker_Env.is_layered_effect - env m in - if uu___5 - then - let m_ed = - FStar_TypeChecker_Env.get_effect_decl - env m in - let num_effect_params = - match m_ed.FStar_Syntax_Syntax.signature - with - | FStar_Syntax_Syntax.Layered_eff_sig - (n, uu___6) -> n - | uu___6 -> - failwith - "Impossible (mk_bind expected an indexed effect)" in - let uu___6 = - FStar_Syntax_Util.get_bind_vc_combinator - m_ed in - match uu___6 with - | (bind_t, bind_kind) -> - let has_range_args = - FStar_Syntax_Util.has_attribute - m_ed.FStar_Syntax_Syntax.eff_attrs - FStar_Parser_Const.bind_has_range_args_attr in - let uu___7 = - FStar_Compiler_Util.must bind_kind in - mk_indexed_bind env m m m bind_t - uu___7 ct11 b ct21 flags r1 - num_effect_params has_range_args - else - (let uu___7 = - mk_wp_bind env m ct11 b ct21 flags r1 in - (uu___7, - FStar_TypeChecker_Env.trivial_guard)) in - (match uu___4 with - | (c, g_bind) -> - let uu___5 = - FStar_TypeChecker_Env.conj_guard - g_lift g_bind in - (c, uu___5))))) -let (strengthen_comp : - FStar_TypeChecker_Env.env -> - (unit -> FStar_Pprint.document Prims.list) FStar_Pervasives_Native.option - -> - FStar_Syntax_Syntax.comp -> - FStar_Syntax_Syntax.formula -> - FStar_Syntax_Syntax.cflag Prims.list -> - (FStar_Syntax_Syntax.comp * FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun reason -> - fun c -> - fun f -> - fun flags -> - let uu___ = - env.FStar_TypeChecker_Env.phase1 || - (FStar_TypeChecker_Env.too_early_in_prims env) in - if uu___ - then (c, FStar_TypeChecker_Env.trivial_guard) - else - (let r = FStar_TypeChecker_Env.get_range env in - let pure_assert_wp = - let uu___2 = - FStar_Syntax_Syntax.lid_as_fv - FStar_Parser_Const.pure_assert_wp_lid - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___2 in - let pure_assert_wp1 = - let uu___2 = - let uu___3 = - let uu___4 = label_opt env reason r f in - FStar_Syntax_Syntax.as_arg uu___4 in - [uu___3] in - FStar_Syntax_Syntax.mk_Tm_app pure_assert_wp uu___2 r in - let r1 = FStar_TypeChecker_Env.get_range env in - let pure_c = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Syntax.as_arg pure_assert_wp1 in - [uu___4] in - { - FStar_Syntax_Syntax.comp_univs = - [FStar_Syntax_Syntax.U_zero]; - FStar_Syntax_Syntax.effect_name = - FStar_Parser_Const.effect_PURE_lid; - FStar_Syntax_Syntax.result_typ = - FStar_Syntax_Syntax.t_unit; - FStar_Syntax_Syntax.effect_args = uu___3; - FStar_Syntax_Syntax.flags = [] - } in - FStar_Syntax_Syntax.mk_Comp uu___2 in - mk_bind env pure_c FStar_Pervasives_Native.None c flags r1) -let (mk_return : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.eff_decl -> - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.term -> - FStar_Compiler_Range_Type.range -> - (FStar_Syntax_Syntax.comp * FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun ed -> - fun u_a -> - fun a -> - fun e -> - fun r -> - let uu___ = FStar_Syntax_Util.is_layered ed in - if uu___ - then mk_indexed_return env ed u_a a e r - else - (let uu___2 = mk_wp_return env ed u_a a e r in - (uu___2, FStar_TypeChecker_Env.trivial_guard)) -let (return_value : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.universe FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - (FStar_Syntax_Syntax.comp * FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun eff_lid -> - fun u_t_opt -> - fun t -> - fun v -> - let u = - match u_t_opt with - | FStar_Pervasives_Native.None -> - env.FStar_TypeChecker_Env.universe_of env t - | FStar_Pervasives_Native.Some u1 -> u1 in - let uu___ = FStar_TypeChecker_Env.get_effect_decl env eff_lid in - mk_return env uu___ u t v v.FStar_Syntax_Syntax.pos -let (weaken_flags : - FStar_Syntax_Syntax.cflag Prims.list -> - FStar_Syntax_Syntax.cflag Prims.list) - = - fun flags -> - let uu___ = - FStar_Compiler_Util.for_some - (fun uu___1 -> - match uu___1 with - | FStar_Syntax_Syntax.SHOULD_NOT_INLINE -> true - | uu___2 -> false) flags in - if uu___ - then [FStar_Syntax_Syntax.SHOULD_NOT_INLINE] - else - FStar_Compiler_List.collect - (fun uu___2 -> - match uu___2 with - | FStar_Syntax_Syntax.TOTAL -> - [FStar_Syntax_Syntax.TRIVIAL_POSTCONDITION] - | FStar_Syntax_Syntax.RETURN -> - [FStar_Syntax_Syntax.PARTIAL_RETURN; - FStar_Syntax_Syntax.TRIVIAL_POSTCONDITION] - | f -> [f]) flags -let (weaken_comp : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.comp -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.comp * FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun c -> - fun formula -> - let uu___ = FStar_Syntax_Util.is_ml_comp c in - if uu___ - then (c, FStar_TypeChecker_Env.trivial_guard) - else - (let ct = FStar_TypeChecker_Env.unfold_effect_abbrev env c in - let pure_assume_wp = - let uu___2 = - FStar_Syntax_Syntax.lid_as_fv - FStar_Parser_Const.pure_assume_wp_lid - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.fv_to_tm uu___2 in - let pure_assume_wp1 = - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.as_arg formula in [uu___3] in - let uu___3 = FStar_TypeChecker_Env.get_range env in - FStar_Syntax_Syntax.mk_Tm_app pure_assume_wp uu___2 uu___3 in - let r = FStar_TypeChecker_Env.get_range env in - let pure_c = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Syntax.as_arg pure_assume_wp1 in - [uu___4] in - { - FStar_Syntax_Syntax.comp_univs = - [FStar_Syntax_Syntax.U_zero]; - FStar_Syntax_Syntax.effect_name = - FStar_Parser_Const.effect_PURE_lid; - FStar_Syntax_Syntax.result_typ = FStar_Syntax_Syntax.t_unit; - FStar_Syntax_Syntax.effect_args = uu___3; - FStar_Syntax_Syntax.flags = [] - } in - FStar_Syntax_Syntax.mk_Comp uu___2 in - let uu___2 = weaken_flags ct.FStar_Syntax_Syntax.flags in - mk_bind env pure_c FStar_Pervasives_Native.None c uu___2 r) -let (weaken_precondition : - FStar_TypeChecker_Env.env -> - FStar_TypeChecker_Common.lcomp -> - FStar_TypeChecker_Common.guard_formula -> - FStar_TypeChecker_Common.lcomp) - = - fun env -> - fun lc -> - fun f -> - let weaken uu___ = - let uu___1 = FStar_TypeChecker_Common.lcomp_comp lc in - match uu___1 with - | (c, g_c) -> - let uu___2 = - (FStar_Options.lax ()) && (FStar_Options.ml_ish ()) in - if uu___2 - then (c, g_c) - else - (match f with - | FStar_TypeChecker_Common.Trivial -> (c, g_c) - | FStar_TypeChecker_Common.NonTrivial f1 -> - let uu___4 = weaken_comp env c f1 in - (match uu___4 with - | (c1, g_w) -> - let uu___5 = - FStar_TypeChecker_Env.conj_guard g_c g_w in - (c1, uu___5))) in - let uu___ = weaken_flags lc.FStar_TypeChecker_Common.cflags in - FStar_TypeChecker_Common.mk_lcomp - lc.FStar_TypeChecker_Common.eff_name - lc.FStar_TypeChecker_Common.res_typ uu___ weaken -let (strengthen_precondition : - (unit -> FStar_Pprint.document Prims.list) FStar_Pervasives_Native.option - -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_TypeChecker_Common.lcomp -> - FStar_TypeChecker_Env.guard_t -> - (FStar_TypeChecker_Common.lcomp * FStar_TypeChecker_Env.guard_t)) - = - fun reason -> - fun env -> - fun e_for_debugging_only -> - fun lc -> - fun g0 -> - let uu___ = FStar_TypeChecker_Env.is_trivial_guard_formula g0 in - if uu___ - then (lc, g0) - else - (let flags = - let uu___2 = - let uu___3 = - FStar_TypeChecker_Common.is_tot_or_gtot_lcomp lc in - if uu___3 - then (true, [FStar_Syntax_Syntax.TRIVIAL_POSTCONDITION]) - else (false, []) in - match uu___2 with - | (maybe_trivial_post, flags1) -> - let uu___3 = - FStar_Compiler_List.collect - (fun uu___4 -> - match uu___4 with - | FStar_Syntax_Syntax.RETURN -> - [FStar_Syntax_Syntax.PARTIAL_RETURN] - | FStar_Syntax_Syntax.PARTIAL_RETURN -> - [FStar_Syntax_Syntax.PARTIAL_RETURN] - | FStar_Syntax_Syntax.SOMETRIVIAL when - Prims.op_Negation maybe_trivial_post -> - [FStar_Syntax_Syntax.TRIVIAL_POSTCONDITION] - | FStar_Syntax_Syntax.TRIVIAL_POSTCONDITION when - Prims.op_Negation maybe_trivial_post -> - [FStar_Syntax_Syntax.TRIVIAL_POSTCONDITION] - | FStar_Syntax_Syntax.SHOULD_NOT_INLINE -> - [FStar_Syntax_Syntax.SHOULD_NOT_INLINE] - | uu___5 -> []) - lc.FStar_TypeChecker_Common.cflags in - FStar_Compiler_List.op_At flags1 uu___3 in - let strengthen uu___2 = - let uu___3 = FStar_TypeChecker_Common.lcomp_comp lc in - match uu___3 with - | (c, g_c) -> - let uu___4 = FStar_Options.lax () in - if uu___4 - then (c, g_c) - else - (let g01 = FStar_TypeChecker_Rel.simplify_guard env g0 in - let uu___6 = FStar_TypeChecker_Env.guard_form g01 in - match uu___6 with - | FStar_TypeChecker_Common.Trivial -> (c, g_c) - | FStar_TypeChecker_Common.NonTrivial f -> - ((let uu___8 = FStar_Compiler_Debug.extreme () in - if uu___8 - then - let uu___9 = - FStar_TypeChecker_Normalize.term_to_string - env e_for_debugging_only in - let uu___10 = - FStar_TypeChecker_Normalize.term_to_string - env f in - FStar_Compiler_Util.print2 - "-------------Strengthening pre-condition of term %s with guard %s\n" - uu___9 uu___10 - else ()); - (let uu___8 = - strengthen_comp env reason c f flags in - match uu___8 with - | (c1, g_s) -> - let uu___9 = - FStar_TypeChecker_Env.conj_guard g_c g_s in - (c1, uu___9)))) in - let uu___2 = - let uu___3 = - FStar_TypeChecker_Env.norm_eff_name env - lc.FStar_TypeChecker_Common.eff_name in - FStar_TypeChecker_Common.mk_lcomp uu___3 - lc.FStar_TypeChecker_Common.res_typ flags strengthen in - (uu___2, - { - FStar_TypeChecker_Common.guard_f = - FStar_TypeChecker_Common.Trivial; - FStar_TypeChecker_Common.deferred_to_tac = - (g0.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (g0.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (g0.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = - (g0.FStar_TypeChecker_Common.implicits) - })) -let (lcomp_has_trivial_postcondition : - FStar_TypeChecker_Common.lcomp -> Prims.bool) = - fun lc -> - (FStar_TypeChecker_Common.is_tot_or_gtot_lcomp lc) || - (FStar_Compiler_Util.for_some - (fun uu___ -> - match uu___ with - | FStar_Syntax_Syntax.SOMETRIVIAL -> true - | FStar_Syntax_Syntax.TRIVIAL_POSTCONDITION -> true - | uu___1 -> false) lc.FStar_TypeChecker_Common.cflags) -let (maybe_capture_unit_refinement : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.bv -> - FStar_Syntax_Syntax.comp -> - (FStar_Syntax_Syntax.comp * FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun t -> - fun x -> - fun c -> - let t1 = - FStar_TypeChecker_Normalize.normalize_refinement - FStar_TypeChecker_Normalize.whnf_steps env t in - match t1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = b; FStar_Syntax_Syntax.phi = phi;_} - -> - let is_unit = - match (b.FStar_Syntax_Syntax.sort).FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_fvar fv -> - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.unit_lid - | uu___ -> false in - if is_unit - then - let uu___ = - let uu___1 = - FStar_TypeChecker_Env.norm_eff_name env - (FStar_Syntax_Util.comp_effect_name c) in - FStar_TypeChecker_Env.is_layered_effect env uu___1 in - (if uu___ - then - let uu___1 = FStar_Syntax_Subst.open_term_bv b phi in - match uu___1 with - | (b1, phi1) -> - let phi2 = - FStar_Syntax_Subst.subst - [FStar_Syntax_Syntax.NT - (b1, FStar_Syntax_Syntax.unit_const)] phi1 in - weaken_comp env c phi2 - else - (let uu___2 = close_wp_comp env [x] c in - (uu___2, FStar_TypeChecker_Env.trivial_guard))) - else (c, FStar_TypeChecker_Env.trivial_guard) - | uu___ -> (c, FStar_TypeChecker_Env.trivial_guard) -let (bind : - FStar_Compiler_Range_Type.range -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option -> - FStar_TypeChecker_Common.lcomp -> - lcomp_with_binder -> FStar_TypeChecker_Common.lcomp) - = - fun r1 -> - fun env -> - fun e1opt -> - fun lc1 -> - fun uu___ -> - match uu___ with - | (b, lc2) -> - let debug f = - let uu___1 = - (FStar_Compiler_Debug.extreme ()) || - (FStar_Compiler_Effect.op_Bang dbg_bind) in - if uu___1 then f () else () in - let uu___1 = - FStar_TypeChecker_Normalize.ghost_to_pure_lcomp2 env - (lc1, lc2) in - (match uu___1 with - | (lc11, lc21) -> - let joined_eff = join_lcomp env lc11 lc21 in - let bind_flags = - let uu___2 = - (should_not_inline_lc lc11) || - (should_not_inline_lc lc21) in - if uu___2 - then [FStar_Syntax_Syntax.SHOULD_NOT_INLINE] - else - (let flags = - let uu___4 = - FStar_TypeChecker_Common.is_total_lcomp lc11 in - if uu___4 - then - let uu___5 = - FStar_TypeChecker_Common.is_total_lcomp lc21 in - (if uu___5 - then [FStar_Syntax_Syntax.TOTAL] - else - (let uu___7 = - FStar_TypeChecker_Common.is_tot_or_gtot_lcomp - lc21 in - if uu___7 - then [FStar_Syntax_Syntax.SOMETRIVIAL] - else [])) - else - (let uu___6 = - (FStar_TypeChecker_Common.is_tot_or_gtot_lcomp - lc11) - && - (FStar_TypeChecker_Common.is_tot_or_gtot_lcomp - lc21) in - if uu___6 - then [FStar_Syntax_Syntax.SOMETRIVIAL] - else []) in - let uu___4 = lcomp_has_trivial_postcondition lc21 in - if uu___4 - then FStar_Syntax_Syntax.TRIVIAL_POSTCONDITION :: - flags - else flags) in - let bind_it uu___2 = - let uu___3 = - (FStar_Options.lax ()) && (FStar_Options.ml_ish ()) in - if uu___3 - then - let u_t = - env.FStar_TypeChecker_Env.universe_of env - lc21.FStar_TypeChecker_Common.res_typ in - let uu___4 = - lax_mk_tot_or_comp_l joined_eff u_t - lc21.FStar_TypeChecker_Common.res_typ [] in - (uu___4, FStar_TypeChecker_Env.trivial_guard) - else - (let uu___5 = - FStar_TypeChecker_Common.lcomp_comp lc11 in - match uu___5 with - | (c1, g_c1) -> - let uu___6 = - FStar_TypeChecker_Common.lcomp_comp lc21 in - (match uu___6 with - | (c2, g_c2) -> - let trivial_guard = - let uu___7 = - match b with - | FStar_Pervasives_Native.Some x -> - let b1 = - FStar_Syntax_Syntax.mk_binder x in - let uu___8 = - FStar_Syntax_Syntax.is_null_binder - b1 in - if uu___8 - then g_c2 - else - FStar_TypeChecker_Env.close_guard - env [b1] g_c2 - | FStar_Pervasives_Native.None -> g_c2 in - FStar_TypeChecker_Env.conj_guard g_c1 - uu___7 in - (debug - (fun uu___8 -> - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_comp - c1 in - let uu___10 = - match b with - | FStar_Pervasives_Native.None -> - "none" - | FStar_Pervasives_Native.Some x - -> - FStar_Class_Show.show - FStar_Syntax_Print.showable_bv - x in - let uu___11 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_comp - c2 in - let uu___12 = - match e1opt with - | FStar_Pervasives_Native.None -> - "none" - | FStar_Pervasives_Native.Some e1 - -> - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - e1 in - FStar_Compiler_Util.print4 - "(1) bind: \n\tc1=%s\n\tx=%s\n\tc2=%s\n\te1=%s\n(1. end bind)\n" - uu___9 uu___10 uu___11 uu___12); - (let aux uu___8 = - let uu___9 = - FStar_Syntax_Util.is_trivial_wp c1 in - if uu___9 - then - match b with - | FStar_Pervasives_Native.None -> - FStar_Pervasives.Inl - (c2, "trivial no binder") - | FStar_Pervasives_Native.Some - uu___10 -> - let uu___11 = - FStar_Syntax_Util.is_ml_comp - c2 in - (if uu___11 - then - FStar_Pervasives.Inl - (c2, "trivial ml") - else - FStar_Pervasives.Inr - "c1 trivial; but c2 is not ML") - else - (let uu___11 = - (FStar_Syntax_Util.is_ml_comp c1) - && - (FStar_Syntax_Util.is_ml_comp - c2) in - if uu___11 - then - FStar_Pervasives.Inl - (c2, "both ml") - else - FStar_Pervasives.Inr - "c1 not trivial, and both are not ML") in - let try_simplify uu___8 = - let aux_with_trivial_guard uu___9 = - let uu___10 = aux () in - match uu___10 with - | FStar_Pervasives.Inl (c, reason) - -> - FStar_Pervasives.Inl - (c, trivial_guard, reason) - | FStar_Pervasives.Inr reason -> - FStar_Pervasives.Inr reason in - let uu___9 = - FStar_TypeChecker_Env.too_early_in_prims - env in - if uu___9 - then - FStar_Pervasives.Inl - (c2, trivial_guard, - "Early in prims; we don't have bind yet") - else - (let uu___11 = - FStar_Syntax_Util.is_total_comp - c1 in - if uu___11 - then - let close_with_type_of_x x c = - let x1 = - { - FStar_Syntax_Syntax.ppname - = - (x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (x.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = - (FStar_Syntax_Util.comp_result - c1) - } in - maybe_capture_unit_refinement - env - x1.FStar_Syntax_Syntax.sort - x1 c in - match (e1opt, b) with - | (FStar_Pervasives_Native.Some - e, - FStar_Pervasives_Native.Some - x) -> - let uu___12 = - let uu___13 = - FStar_Syntax_Subst.subst_comp - [FStar_Syntax_Syntax.NT - (x, e)] c2 in - close_with_type_of_x x - uu___13 in - (match uu___12 with - | (c21, g_close) -> - let uu___13 = - let uu___14 = - let uu___15 = - let uu___16 = - let uu___17 = - FStar_TypeChecker_Env.map_guard - g_c2 - (FStar_Syntax_Subst.subst - [ - FStar_Syntax_Syntax.NT - (x, e)]) in - [uu___17; - g_close] in - g_c1 :: uu___16 in - FStar_TypeChecker_Env.conj_guards - uu___15 in - (c21, uu___14, - "c1 Tot") in - FStar_Pervasives.Inl - uu___13) - | (uu___12, - FStar_Pervasives_Native.Some - x) -> - let uu___13 = - close_with_type_of_x x c2 in - (match uu___13 with - | (c21, g_close) -> - let uu___14 = - let uu___15 = - let uu___16 = - let uu___17 = - let uu___18 = - let uu___19 = - let uu___20 - = - FStar_Syntax_Syntax.mk_binder - x in - [uu___20] in - FStar_TypeChecker_Env.close_guard - env uu___19 - g_c2 in - [uu___18; - g_close] in - g_c1 :: uu___17 in - FStar_TypeChecker_Env.conj_guards - uu___16 in - (c21, uu___15, - "c1 Tot only close") in - FStar_Pervasives.Inl - uu___14) - | (uu___12, uu___13) -> - aux_with_trivial_guard () - else - (let uu___13 = - (FStar_Syntax_Util.is_tot_or_gtot_comp - c1) - && - (FStar_Syntax_Util.is_tot_or_gtot_comp - c2) in - if uu___13 - then - let uu___14 = - let uu___15 = - FStar_Syntax_Syntax.mk_GTotal - (FStar_Syntax_Util.comp_result - c2) in - (uu___15, trivial_guard, - "both GTot") in - FStar_Pervasives.Inl uu___14 - else aux_with_trivial_guard ())) in - let uu___8 = try_simplify () in - match uu___8 with - | FStar_Pervasives.Inl (c, g, reason) -> - (debug - (fun uu___10 -> - let uu___11 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_comp - c in - FStar_Compiler_Util.print2 - "(2) bind: Simplified (because %s) to\n\t%s\n" - reason uu___11); - (c, g)) - | FStar_Pervasives.Inr reason -> - (debug - (fun uu___10 -> - FStar_Compiler_Util.print1 - "(2) bind: Not simplified because %s\n" - reason); - (let mk_bind1 c11 b1 c21 g = - let uu___10 = - mk_bind env c11 b1 c21 - bind_flags r1 in - match uu___10 with - | (c, g_bind) -> - let uu___11 = - FStar_TypeChecker_Env.conj_guard - g g_bind in - (c, uu___11) in - let uu___10 = - let t = - FStar_Syntax_Util.comp_result - c1 in - match comp_univ_opt c1 with - | FStar_Pervasives_Native.None - -> - let uu___11 = - env.FStar_TypeChecker_Env.universe_of - env t in - (uu___11, t) - | FStar_Pervasives_Native.Some u - -> (u, t) in - match uu___10 with - | (u_res_t1, res_t1) -> - let uu___11 = - (FStar_Compiler_Option.isSome - b) - && - (should_return env e1opt - lc11) in - if uu___11 - then - let e1 = - FStar_Compiler_Option.get - e1opt in - let x = - FStar_Compiler_Option.get - b in - let uu___12 = - FStar_Syntax_Util.is_partial_return - c1 in - (if uu___12 - then - (debug - (fun uu___14 -> - let uu___15 = - FStar_TypeChecker_Normalize.term_to_string - env e1 in - let uu___16 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_bv - x in - FStar_Compiler_Util.print2 - "(3) bind (case a): Substituting %s for %s\n" - uu___15 uu___16); - (let c21 = - FStar_Syntax_Subst.subst_comp - [FStar_Syntax_Syntax.NT - (x, e1)] c2 in - let g = - let uu___14 = - FStar_TypeChecker_Env.map_guard - g_c2 - (FStar_Syntax_Subst.subst - [FStar_Syntax_Syntax.NT - (x, e1)]) in - FStar_TypeChecker_Env.conj_guard - g_c1 uu___14 in - mk_bind1 c1 b c21 g)) - else - (debug - (fun uu___15 -> - let uu___16 = - FStar_TypeChecker_Normalize.term_to_string - env e1 in - let uu___17 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_bv - x in - FStar_Compiler_Util.print2 - "(3) bind (case b): Adding equality %s = %s\n" - uu___16 uu___17); - (let c21 = - FStar_Syntax_Subst.subst_comp - [FStar_Syntax_Syntax.NT - (x, e1)] c2 in - let x_eq_e = - let uu___15 = - FStar_Syntax_Syntax.bv_to_name - x in - FStar_Syntax_Util.mk_eq2 - u_res_t1 res_t1 e1 - uu___15 in - let uu___15 = - let uu___16 = - let uu___17 = - let uu___18 = - FStar_Syntax_Syntax.mk_binder - x in - [uu___18] in - FStar_TypeChecker_Env.push_binders - env uu___17 in - weaken_comp uu___16 - c21 x_eq_e in - match uu___15 with - | (c22, g_w) -> - let g = - let uu___16 = - let uu___17 = - let uu___18 = - let uu___19 - = - let uu___20 - = - FStar_Syntax_Syntax.mk_binder - x in - [uu___20] in - FStar_TypeChecker_Env.close_guard - env - uu___19 - g_w in - let uu___19 = - let uu___20 - = - let uu___21 - = - let uu___22 - = - FStar_Syntax_Syntax.mk_binder - x in - [uu___22] in - let uu___22 - = - FStar_TypeChecker_Common.weaken_guard_formula - g_c2 - x_eq_e in - FStar_TypeChecker_Env.close_guard - env - uu___21 - uu___22 in - [uu___20] in - uu___18 :: - uu___19 in - g_c1 :: uu___17 in - FStar_TypeChecker_Env.conj_guards - uu___16 in - mk_bind1 c1 b c22 g))) - else - mk_bind1 c1 b c2 - trivial_guard)))))) in - FStar_TypeChecker_Common.mk_lcomp joined_eff - lc21.FStar_TypeChecker_Common.res_typ bind_flags - bind_it) -let (weaken_guard : - FStar_TypeChecker_Common.guard_formula -> - FStar_TypeChecker_Common.guard_formula -> - FStar_TypeChecker_Common.guard_formula) - = - fun g1 -> - fun g2 -> - match (g1, g2) with - | (FStar_TypeChecker_Common.NonTrivial f1, - FStar_TypeChecker_Common.NonTrivial f2) -> - let g = FStar_Syntax_Util.mk_imp f1 f2 in - FStar_TypeChecker_Common.NonTrivial g - | uu___ -> g2 -let (assume_result_eq_pure_term_in_m : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.term -> - FStar_TypeChecker_Common.lcomp -> FStar_TypeChecker_Common.lcomp) - = - fun env -> - fun m_opt -> - fun e -> - fun lc -> - let m = - let uu___ = - (FStar_Compiler_Util.is_none m_opt) || - (is_ghost_effect env lc.FStar_TypeChecker_Common.eff_name) in - if uu___ - then FStar_Parser_Const.effect_PURE_lid - else FStar_Compiler_Util.must m_opt in - let flags = - let uu___ = FStar_TypeChecker_Common.is_total_lcomp lc in - if uu___ - then FStar_Syntax_Syntax.RETURN :: - (lc.FStar_TypeChecker_Common.cflags) - else FStar_Syntax_Syntax.PARTIAL_RETURN :: - (lc.FStar_TypeChecker_Common.cflags) in - let refine uu___ = - let uu___1 = FStar_TypeChecker_Common.lcomp_comp lc in - match uu___1 with - | (c, g_c) -> - let u_t = - match comp_univ_opt c with - | FStar_Pervasives_Native.Some u_t1 -> u_t1 - | FStar_Pervasives_Native.None -> - env.FStar_TypeChecker_Env.universe_of env - (FStar_Syntax_Util.comp_result c) in - let uu___2 = FStar_Syntax_Util.is_tot_or_gtot_comp c in - if uu___2 - then - let uu___3 = - return_value env m (FStar_Pervasives_Native.Some u_t) - (FStar_Syntax_Util.comp_result c) e in - (match uu___3 with - | (retc, g_retc) -> - let g_c1 = FStar_TypeChecker_Env.conj_guard g_c g_retc in - let uu___4 = - let uu___5 = FStar_Syntax_Util.is_pure_comp c in - Prims.op_Negation uu___5 in - if uu___4 - then - let retc1 = - FStar_TypeChecker_Env.comp_to_comp_typ env retc in - let retc2 = - { - FStar_Syntax_Syntax.comp_univs = - (retc1.FStar_Syntax_Syntax.comp_univs); - FStar_Syntax_Syntax.effect_name = - FStar_Parser_Const.effect_GHOST_lid; - FStar_Syntax_Syntax.result_typ = - (retc1.FStar_Syntax_Syntax.result_typ); - FStar_Syntax_Syntax.effect_args = - (retc1.FStar_Syntax_Syntax.effect_args); - FStar_Syntax_Syntax.flags = flags - } in - let uu___5 = FStar_Syntax_Syntax.mk_Comp retc2 in - (uu___5, g_c1) - else - (let uu___6 = - FStar_TypeChecker_Env.comp_set_flags env retc - flags in - (uu___6, g_c1))) - else - (let c1 = FStar_TypeChecker_Env.unfold_effect_abbrev env c in - let t = c1.FStar_Syntax_Syntax.result_typ in - let c2 = FStar_Syntax_Syntax.mk_Comp c1 in - let x = - FStar_Syntax_Syntax.new_bv - (FStar_Pervasives_Native.Some - (t.FStar_Syntax_Syntax.pos)) t in - let xexp = FStar_Syntax_Syntax.bv_to_name x in - let env_x = FStar_TypeChecker_Env.push_bv env x in - let uu___4 = - return_value env_x m (FStar_Pervasives_Native.Some u_t) - t xexp in - match uu___4 with - | (ret, g_ret) -> - let ret1 = - let uu___5 = - FStar_TypeChecker_Env.comp_set_flags env_x ret - [FStar_Syntax_Syntax.PARTIAL_RETURN] in - FStar_TypeChecker_Common.lcomp_of_comp uu___5 in - let eq = FStar_Syntax_Util.mk_eq2 u_t t xexp e in - let eq_ret = - weaken_precondition env_x ret1 - (FStar_TypeChecker_Common.NonTrivial eq) in - let uu___5 = - let uu___6 = - let uu___7 = - FStar_TypeChecker_Common.lcomp_of_comp c2 in - bind e.FStar_Syntax_Syntax.pos env - FStar_Pervasives_Native.None uu___7 - ((FStar_Pervasives_Native.Some x), eq_ret) in - FStar_TypeChecker_Common.lcomp_comp uu___6 in - (match uu___5 with - | (bind_c, g_bind) -> - let uu___6 = - FStar_TypeChecker_Env.comp_set_flags env bind_c - flags in - let uu___7 = - FStar_TypeChecker_Env.conj_guards - [g_c; g_ret; g_bind] in - (uu___6, uu___7))) in - let uu___ = should_not_inline_lc lc in - if uu___ - then - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Errors_Msg.text - "assume_result_eq_pure_term cannot inline an non-inlineable lc : " in - let uu___4 = - FStar_Class_PP.pp FStar_Syntax_Print.pretty_term e in - FStar_Pprint.op_Hat_Hat uu___3 uu___4 in - [uu___2] in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) e - FStar_Errors_Codes.Fatal_UnexpectedTerm () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___1) - else - (let uu___2 = refine () in - match uu___2 with - | (c, g) -> FStar_TypeChecker_Common.lcomp_of_comp_guard c g) -let (maybe_assume_result_eq_pure_term_in_m : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.term -> - FStar_TypeChecker_Common.lcomp -> FStar_TypeChecker_Common.lcomp) - = - fun env -> - fun m_opt -> - fun e -> - fun lc -> - let should_return1 = - (((Prims.op_Negation env.FStar_TypeChecker_Env.phase1) && - (let uu___ = FStar_TypeChecker_Env.too_early_in_prims env in - Prims.op_Negation uu___)) - && (should_return env (FStar_Pervasives_Native.Some e) lc)) - && - (let uu___ = - FStar_TypeChecker_Common.is_lcomp_partial_return lc in - Prims.op_Negation uu___) in - if Prims.op_Negation should_return1 - then lc - else assume_result_eq_pure_term_in_m env m_opt e lc -let (maybe_assume_result_eq_pure_term : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_TypeChecker_Common.lcomp -> FStar_TypeChecker_Common.lcomp) - = - fun env -> - fun e -> - fun lc -> - maybe_assume_result_eq_pure_term_in_m env - FStar_Pervasives_Native.None e lc -let (maybe_return_e2_and_bind : - FStar_Compiler_Range_Type.range -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term FStar_Pervasives_Native.option -> - FStar_TypeChecker_Common.lcomp -> - FStar_Syntax_Syntax.term -> - lcomp_with_binder -> FStar_TypeChecker_Common.lcomp) - = - fun r -> - fun env -> - fun e1opt -> - fun lc1 -> - fun e2 -> - fun uu___ -> - match uu___ with - | (x, lc2) -> - let env_x = - match x with - | FStar_Pervasives_Native.None -> env - | FStar_Pervasives_Native.Some x1 -> - FStar_TypeChecker_Env.push_bv env x1 in - let uu___1 = - FStar_TypeChecker_Normalize.ghost_to_pure_lcomp2 env - (lc1, lc2) in - (match uu___1 with - | (lc11, lc21) -> - let lc22 = - let eff1 = - FStar_TypeChecker_Env.norm_eff_name env - lc11.FStar_TypeChecker_Common.eff_name in - let eff2 = - FStar_TypeChecker_Env.norm_eff_name env - lc21.FStar_TypeChecker_Common.eff_name in - let uu___2 = - ((FStar_Ident.lid_equals eff2 - FStar_Parser_Const.effect_PURE_lid) - && - (let uu___3 = - FStar_TypeChecker_Env.join_opt env eff1 eff2 in - FStar_Compiler_Util.is_none uu___3)) - && - (let uu___3 = - FStar_TypeChecker_Env.exists_polymonadic_bind - env eff1 eff2 in - FStar_Compiler_Util.is_none uu___3) in - if uu___2 - then - assume_result_eq_pure_term_in_m env_x - (FStar_Pervasives_Native.Some eff1) e2 lc21 - else - (let uu___4 = - ((let uu___5 = is_pure_or_ghost_effect env eff1 in - Prims.op_Negation uu___5) || - (should_not_inline_lc lc11)) - && (is_pure_or_ghost_effect env eff2) in - if uu___4 - then - maybe_assume_result_eq_pure_term_in_m env_x - (FStar_Pervasives_Native.Some eff1) e2 lc21 - else lc21) in - bind r env e1opt lc11 (x, lc22)) -let (fvar_env : - FStar_TypeChecker_Env.env -> FStar_Ident.lident -> FStar_Syntax_Syntax.term) - = - fun env -> - fun lid -> - let uu___ = - let uu___1 = FStar_TypeChecker_Env.get_range env in - FStar_Ident.set_lid_range lid uu___1 in - FStar_Syntax_Syntax.fvar uu___ FStar_Pervasives_Native.None -let (substitutive_indexed_ite_substs : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.indexed_effect_combinator_kind -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.comp_typ -> - FStar_Syntax_Syntax.comp_typ -> - Prims.int -> - FStar_Compiler_Range_Type.range -> - (FStar_Syntax_Syntax.subst_elt Prims.list * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun k -> - fun bs -> - fun a -> - fun p -> - fun ct_then -> - fun ct_else -> - fun num_effect_params -> - fun r -> - let debug = - FStar_Compiler_Effect.op_Bang dbg_LayeredEffectsApp in - let uu___ = - let uu___1 = bs in - match uu___1 with - | a_b::bs1 -> - (bs1, - [FStar_Syntax_Syntax.NT - ((a_b.FStar_Syntax_Syntax.binder_bv), a)]) in - match uu___ with - | (bs1, subst) -> - let uu___1 = - if num_effect_params = Prims.int_zero - then - (bs1, subst, FStar_TypeChecker_Env.trivial_guard, - (ct_then.FStar_Syntax_Syntax.effect_args), - (ct_else.FStar_Syntax_Syntax.effect_args)) - else - (let split l = - FStar_Compiler_List.splitAt num_effect_params - l in - let uu___3 = split bs1 in - match uu___3 with - | (eff_params_bs, bs2) -> - let uu___4 = - split - ct_then.FStar_Syntax_Syntax.effect_args in - (match uu___4 with - | (param_args1, args1) -> - let uu___5 = - split - ct_else.FStar_Syntax_Syntax.effect_args in - (match uu___5 with - | (param_args2, args2) -> - let g = - FStar_Compiler_List.fold_left2 - (fun g1 -> - fun uu___6 -> - fun uu___7 -> - match (uu___6, uu___7) - with - | ((arg1, uu___8), - (arg2, uu___9)) -> - let uu___10 = - FStar_TypeChecker_Rel.layered_effect_teq - env arg1 arg2 - (FStar_Pervasives_Native.Some - "effect param ite") in - FStar_TypeChecker_Env.conj_guard - g1 uu___10) - FStar_TypeChecker_Env.trivial_guard - param_args1 param_args2 in - let param_subst = - FStar_Compiler_List.map2 - (fun b -> - fun uu___6 -> - match uu___6 with - | (arg, uu___7) -> - FStar_Syntax_Syntax.NT - ((b.FStar_Syntax_Syntax.binder_bv), - arg)) - eff_params_bs param_args1 in - (bs2, - (FStar_Compiler_List.op_At subst - param_subst), g, args1, - args2)))) in - (match uu___1 with - | (bs2, subst1, guard, args1, args2) -> - let uu___2 = - let m_num_effect_args = - FStar_Compiler_List.length args1 in - let uu___3 = - FStar_Compiler_List.splitAt - m_num_effect_args bs2 in - match uu___3 with - | (f_bs, bs3) -> - let f_subst = - FStar_Compiler_List.map2 - (fun f_b -> - fun uu___4 -> - match uu___4 with - | (arg, uu___5) -> - FStar_Syntax_Syntax.NT - ((f_b.FStar_Syntax_Syntax.binder_bv), - arg)) f_bs args1 in - (bs3, - (FStar_Compiler_List.op_At subst1 - f_subst)) in - (match uu___2 with - | (bs3, subst2) -> - let uu___3 = - if - FStar_Syntax_Syntax.uu___is_Substitutive_combinator - k - then - let n_num_effect_args = - FStar_Compiler_List.length args2 in - let uu___4 = - FStar_Compiler_List.splitAt - n_num_effect_args bs3 in - match uu___4 with - | (g_bs, bs4) -> - let g_subst = - FStar_Compiler_List.map2 - (fun g_b -> - fun uu___5 -> - match uu___5 with - | (arg, uu___6) -> - FStar_Syntax_Syntax.NT - ((g_b.FStar_Syntax_Syntax.binder_bv), - arg)) g_bs args2 in - (bs4, - (FStar_Compiler_List.op_At subst2 - g_subst), guard) - else - if - FStar_Syntax_Syntax.uu___is_Substitutive_invariant_combinator - k - then - (let uu___5 = - FStar_Compiler_List.fold_left2 - (fun guard1 -> - fun uu___6 -> - fun uu___7 -> - match (uu___6, uu___7) - with - | ((arg1, uu___8), - (arg2, uu___9)) -> - let uu___10 = - FStar_TypeChecker_Rel.layered_effect_teq - env arg1 arg2 - (FStar_Pervasives_Native.Some - "substitutive_inv ite args") in - FStar_TypeChecker_Env.conj_guard - guard1 uu___10) - guard args1 args2 in - (bs3, subst2, uu___5)) - else - failwith - "Impossible (substitutive_indexed_ite: unexpected k)" in - (match uu___3 with - | (bs4, subst3, guard1) -> - let uu___4 = - FStar_Compiler_List.splitAt - ((FStar_Compiler_List.length bs4) - - (Prims.of_int (3))) bs4 in - (match uu___4 with - | (bs5, uu___5::uu___6::p_b::[]) -> - let uu___7 = - FStar_Compiler_List.fold_left - (fun uu___8 -> - fun b -> - match uu___8 with - | (subst4, g) -> - let uu___9 = - FStar_TypeChecker_Env.uvars_for_binders - env [b] subst4 - (fun b1 -> - if debug - then - let uu___10 - = - FStar_Class_Show.show - FStar_Syntax_Print.showable_binder - b1 in - let uu___11 - = - FStar_Ident.string_of_lid - ct_then.FStar_Syntax_Syntax.effect_name in - let uu___12 - = - FStar_Compiler_Range_Ops.string_of_range - r in - FStar_Compiler_Util.format3 - "implicit var for additional ite binder %s of %s at %s)" - uu___10 - uu___11 - uu___12 - else - "substitutive_indexed_ite_substs") - r in - (match uu___9 with - | (uv_t::[], g_uv) - -> - let uu___10 = - FStar_TypeChecker_Env.conj_guard - g g_uv in - ((FStar_Compiler_List.op_At - subst4 - [FStar_Syntax_Syntax.NT - ((b.FStar_Syntax_Syntax.binder_bv), - uv_t)]), - uu___10))) - (subst3, guard1) bs5 in - (match uu___7 with - | (subst4, g) -> - ((FStar_Compiler_List.op_At - subst4 - [FStar_Syntax_Syntax.NT - ((p_b.FStar_Syntax_Syntax.binder_bv), - p)]), g)))))) -let (ad_hoc_indexed_ite_substs : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.comp_typ -> - FStar_Syntax_Syntax.comp_typ -> - FStar_Compiler_Range_Type.range -> - (FStar_Syntax_Syntax.subst_elt Prims.list * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun bs -> - fun a -> - fun p -> - fun ct_then -> - fun ct_else -> - fun r -> - let debug = - FStar_Compiler_Effect.op_Bang dbg_LayeredEffectsApp in - let conjunction_name uu___ = - if debug - then - let uu___1 = - FStar_Ident.string_of_lid - ct_then.FStar_Syntax_Syntax.effect_name in - FStar_Compiler_Util.format1 "%s.conjunction" uu___1 - else "" in - let conjunction_t_error r1 s = - let uu___ = - let uu___1 = - let uu___2 = FStar_Errors_Msg.text "Conjunction" in - let uu___3 = - let uu___4 = - FStar_Class_PP.pp FStar_Ident.pretty_lident - ct_then.FStar_Syntax_Syntax.effect_name in - let uu___5 = - FStar_Errors_Msg.text "does not have proper shape." in - FStar_Pprint.op_Hat_Hat uu___4 uu___5 in - FStar_Pprint.op_Hat_Hat uu___2 uu___3 in - let uu___2 = - let uu___3 = - let uu___4 = FStar_Errors_Msg.text "Reason: " in - let uu___5 = FStar_Errors_Msg.text s in - FStar_Pprint.op_Hat_Hat uu___4 uu___5 in - [uu___3] in - uu___1 :: uu___2 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range r1 - FStar_Errors_Codes.Fatal_UnexpectedEffect () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___) in - let uu___ = - if (FStar_Compiler_List.length bs) >= (Prims.of_int (4)) - then - let uu___1 = bs in - match uu___1 with - | a_b::bs1 -> - let uu___2 = - FStar_Compiler_List.splitAt - ((FStar_Compiler_List.length bs1) - - (Prims.of_int (3))) bs1 in - (match uu___2 with - | (rest_bs, f_b::g_b::p_b::[]) -> - (a_b, rest_bs, f_b, g_b, p_b)) - else - conjunction_t_error r - "Either not an abstraction or not enough binders" in - match uu___ with - | (a_b, rest_bs, f_b, g_b, p_b) -> - let uu___1 = - FStar_TypeChecker_Env.uvars_for_binders env rest_bs - [FStar_Syntax_Syntax.NT - ((a_b.FStar_Syntax_Syntax.binder_bv), a)] - (fun b -> - if debug - then - let uu___2 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_binder b in - let uu___3 = - FStar_Ident.string_of_lid - ct_then.FStar_Syntax_Syntax.effect_name in - let uu___4 = - FStar_Compiler_Range_Ops.string_of_range r in - FStar_Compiler_Util.format3 - "implicit var for binder %s of %s:conjunction at %s" - uu___2 uu___3 uu___4 - else "ad_hoc_indexed_ite_substs") r in - (match uu___1 with - | (rest_bs_uvars, g_uvars) -> - let substs = - FStar_Compiler_List.map2 - (fun b -> - fun t -> - FStar_Syntax_Syntax.NT - ((b.FStar_Syntax_Syntax.binder_bv), t)) - (a_b :: - (FStar_Compiler_List.op_At rest_bs [p_b])) (a :: - (FStar_Compiler_List.op_At rest_bs_uvars [p])) in - let f_guard = - let f_sort_is = - let uu___2 = - let uu___3 = - FStar_Syntax_Subst.compress - (f_b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - uu___3.FStar_Syntax_Syntax.n in - match uu___2 with - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = uu___3; - FStar_Syntax_Syntax.args = uu___4::is;_} - -> - let uu___5 = - FStar_Compiler_List.map - FStar_Pervasives_Native.fst is in - FStar_Compiler_List.map - (FStar_Syntax_Subst.subst substs) uu___5 - | uu___3 -> - conjunction_t_error r - "f's type is not a repr type" in - let uu___2 = - FStar_Compiler_List.map - FStar_Pervasives_Native.fst - ct_then.FStar_Syntax_Syntax.effect_args in - FStar_Compiler_List.fold_left2 - (fun g -> - fun i1 -> - fun f_i -> - let uu___3 = - let uu___4 = - let uu___5 = conjunction_name () in - FStar_Pervasives_Native.Some uu___5 in - FStar_TypeChecker_Rel.layered_effect_teq - env i1 f_i uu___4 in - FStar_TypeChecker_Env.conj_guard g uu___3) - FStar_TypeChecker_Env.trivial_guard uu___2 - f_sort_is in - let g_guard = - let g_sort_is = - let uu___2 = - let uu___3 = - FStar_Syntax_Subst.compress - (g_b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - uu___3.FStar_Syntax_Syntax.n in - match uu___2 with - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = uu___3; - FStar_Syntax_Syntax.args = uu___4::is;_} - -> - let uu___5 = - FStar_Compiler_List.map - FStar_Pervasives_Native.fst is in - FStar_Compiler_List.map - (FStar_Syntax_Subst.subst substs) uu___5 - | uu___3 -> - conjunction_t_error r - "g's type is not a repr type" in - let uu___2 = - FStar_Compiler_List.map - FStar_Pervasives_Native.fst - ct_else.FStar_Syntax_Syntax.effect_args in - FStar_Compiler_List.fold_left2 - (fun g -> - fun i2 -> - fun g_i -> - let uu___3 = - let uu___4 = - let uu___5 = conjunction_name () in - FStar_Pervasives_Native.Some uu___5 in - FStar_TypeChecker_Rel.layered_effect_teq - env i2 g_i uu___4 in - FStar_TypeChecker_Env.conj_guard g uu___3) - FStar_TypeChecker_Env.trivial_guard uu___2 - g_sort_is in - let uu___2 = - FStar_TypeChecker_Env.conj_guards - [g_uvars; f_guard; g_guard] in - (substs, uu___2)) -let (mk_layered_conjunction : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.eff_decl -> - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.comp_typ -> - FStar_Syntax_Syntax.comp_typ -> - FStar_Compiler_Range_Type.range -> - (FStar_Syntax_Syntax.comp * FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun ed -> - fun u_a -> - fun a -> - fun p -> - fun ct1 -> - fun ct2 -> - fun r -> - let debug = - FStar_Compiler_Effect.op_Bang dbg_LayeredEffectsApp in - let conjunction_t_error r1 s = - let uu___ = - let uu___1 = - let uu___2 = FStar_Errors_Msg.text "Conjunction" in - let uu___3 = - let uu___4 = - FStar_Class_PP.pp FStar_Ident.pretty_lident - ct1.FStar_Syntax_Syntax.effect_name in - let uu___5 = - FStar_Errors_Msg.text - "does not have proper shape." in - FStar_Pprint.op_Hat_Hat uu___4 uu___5 in - FStar_Pprint.op_Hat_Hat uu___2 uu___3 in - let uu___2 = - let uu___3 = - let uu___4 = FStar_Errors_Msg.text "Reason: " in - let uu___5 = FStar_Errors_Msg.text s in - FStar_Pprint.op_Hat_Hat uu___4 uu___5 in - [uu___3] in - uu___1 :: uu___2 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range r1 - FStar_Errors_Codes.Fatal_UnexpectedEffect () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___) in - let uu___ = - let uu___1 = - let uu___2 = - FStar_Syntax_Util.get_layered_if_then_else_combinator - ed in - FStar_Compiler_Util.must uu___2 in - match uu___1 with - | (ts, kopt) -> - let uu___2 = - FStar_TypeChecker_Env.inst_tscheme_with ts [u_a] in - (match uu___2 with - | (uu___3, conjunction) -> - let uu___4 = FStar_Compiler_Util.must kopt in - (conjunction, uu___4)) in - match uu___ with - | (conjunction, kind) -> - let uu___1 = FStar_Syntax_Util.abs_formals conjunction in - (match uu___1 with - | (bs, body, uu___2) -> - (if debug - then - (let uu___4 = - let uu___5 = FStar_Syntax_Syntax.mk_Comp ct1 in - FStar_Class_Show.show - FStar_Syntax_Print.showable_comp uu___5 in - let uu___5 = - let uu___6 = FStar_Syntax_Syntax.mk_Comp ct2 in - FStar_Class_Show.show - FStar_Syntax_Print.showable_comp uu___6 in - FStar_Compiler_Util.print2 - "layered_ite c1: %s and c2: %s {\n" uu___4 - uu___5) - else (); - (let uu___4 = - if - kind = FStar_Syntax_Syntax.Ad_hoc_combinator - then - ad_hoc_indexed_ite_substs env bs a p ct1 ct2 - r - else - (let num_effect_params = - match ed.FStar_Syntax_Syntax.signature - with - | FStar_Syntax_Syntax.Layered_eff_sig - (n, uu___6) -> n - | uu___6 -> failwith "Impossible!" in - substitutive_indexed_ite_substs env kind bs - a p ct1 ct2 num_effect_params r) in - match uu___4 with - | (substs, g) -> - let body1 = - FStar_Syntax_Subst.subst substs body in - let is = - let uu___5 = - let uu___6 = - FStar_Syntax_Subst.compress body1 in - uu___6.FStar_Syntax_Syntax.n in - match uu___5 with - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = uu___6; - FStar_Syntax_Syntax.args = a1::args;_} - -> - FStar_Compiler_List.map - FStar_Pervasives_Native.fst args - | uu___6 -> - conjunction_t_error r - "body is not a repr type" in - let c = - let uu___5 = - let uu___6 = - FStar_Compiler_List.map - FStar_Syntax_Syntax.as_arg is in - { - FStar_Syntax_Syntax.comp_univs = [u_a]; - FStar_Syntax_Syntax.effect_name = - (ed.FStar_Syntax_Syntax.mname); - FStar_Syntax_Syntax.result_typ = a; - FStar_Syntax_Syntax.effect_args = - uu___6; - FStar_Syntax_Syntax.flags = [] - } in - FStar_Syntax_Syntax.mk_Comp uu___5 in - (if debug - then - FStar_Compiler_Util.print_string "\n}\n" - else (); - (c, g))))) -let (mk_non_layered_conjunction : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.eff_decl -> - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.comp_typ -> - FStar_Syntax_Syntax.comp_typ -> - FStar_Compiler_Range_Type.range -> - (FStar_Syntax_Syntax.comp * FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun ed -> - fun u_a -> - fun a -> - fun p -> - fun ct1 -> - fun ct2 -> - fun uu___ -> - let p1 = FStar_Syntax_Util.b2t p in - let if_then_else = - let uu___1 = - FStar_Syntax_Util.get_wp_if_then_else_combinator ed in - FStar_Compiler_Util.must uu___1 in - let uu___1 = destruct_wp_comp ct1 in - match uu___1 with - | (uu___2, uu___3, wp_t) -> - let uu___4 = destruct_wp_comp ct2 in - (match uu___4 with - | (uu___5, uu___6, wp_e) -> - let wp = - let uu___7 = - FStar_TypeChecker_Env.inst_effect_fun_with - [u_a] env ed if_then_else in - let uu___8 = - let uu___9 = FStar_Syntax_Syntax.as_arg a in - let uu___10 = - let uu___11 = FStar_Syntax_Syntax.as_arg p1 in - let uu___12 = - let uu___13 = - FStar_Syntax_Syntax.as_arg wp_t in - let uu___14 = - let uu___15 = - FStar_Syntax_Syntax.as_arg wp_e in - [uu___15] in - uu___13 :: uu___14 in - uu___11 :: uu___12 in - uu___9 :: uu___10 in - let uu___9 = - FStar_Compiler_Range_Ops.union_ranges - wp_t.FStar_Syntax_Syntax.pos - wp_e.FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.mk_Tm_app uu___7 uu___8 - uu___9 in - let uu___7 = mk_comp ed u_a a wp [] in - (uu___7, FStar_TypeChecker_Env.trivial_guard)) -let (comp_pure_wp_false : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.comp) - = - fun env -> - fun u -> - fun t -> - let post_k = - let uu___ = - let uu___1 = FStar_Syntax_Syntax.null_binder t in [uu___1] in - let uu___1 = FStar_Syntax_Syntax.mk_Total FStar_Syntax_Util.ktype0 in - FStar_Syntax_Util.arrow uu___ uu___1 in - let kwp = - let uu___ = - let uu___1 = FStar_Syntax_Syntax.null_binder post_k in [uu___1] in - let uu___1 = FStar_Syntax_Syntax.mk_Total FStar_Syntax_Util.ktype0 in - FStar_Syntax_Util.arrow uu___ uu___1 in - let post = - FStar_Syntax_Syntax.new_bv FStar_Pervasives_Native.None post_k in - let wp = - let uu___ = - let uu___1 = FStar_Syntax_Syntax.mk_binder post in [uu___1] in - let uu___1 = fvar_env env FStar_Parser_Const.false_lid in - FStar_Syntax_Util.abs uu___ uu___1 - (FStar_Pervasives_Native.Some - (FStar_Syntax_Util.mk_residual_comp - FStar_Parser_Const.effect_Tot_lid - FStar_Pervasives_Native.None [FStar_Syntax_Syntax.TOTAL])) in - let md = - FStar_TypeChecker_Env.get_effect_decl env - FStar_Parser_Const.effect_PURE_lid in - mk_comp md u t wp [] -let (get_neg_branch_conds : - FStar_Syntax_Syntax.formula Prims.list -> - (FStar_Syntax_Syntax.formula Prims.list * FStar_Syntax_Syntax.formula)) - = - fun branch_conds -> - let uu___ = - let uu___1 = - let uu___2 = - FStar_Compiler_List.fold_left - (fun uu___3 -> - fun g -> - match uu___3 with - | (conds, acc) -> - let cond = - let uu___4 = - let uu___5 = FStar_Syntax_Util.b2t g in - FStar_Syntax_Util.mk_neg uu___5 in - FStar_Syntax_Util.mk_conj acc uu___4 in - ((FStar_Compiler_List.op_At conds [cond]), cond)) - ([FStar_Syntax_Util.t_true], FStar_Syntax_Util.t_true) - branch_conds in - FStar_Pervasives_Native.fst uu___2 in - FStar_Compiler_List.splitAt - ((FStar_Compiler_List.length uu___1) - Prims.int_one) uu___1 in - match uu___ with - | (l1, l2) -> let uu___1 = FStar_Compiler_List.hd l2 in (l1, uu___1) -let (bind_cases : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ -> - (FStar_Syntax_Syntax.typ * FStar_Ident.lident * - FStar_Syntax_Syntax.cflag Prims.list * - (Prims.bool -> FStar_TypeChecker_Common.lcomp)) Prims.list -> - FStar_Syntax_Syntax.bv -> FStar_TypeChecker_Common.lcomp) - = - fun env0 -> - fun res_t -> - fun lcases -> - fun scrutinee -> - let env = - let uu___ = - let uu___1 = FStar_Syntax_Syntax.mk_binder scrutinee in - [uu___1] in - FStar_TypeChecker_Env.push_binders env0 uu___ in - let eff = - FStar_Compiler_List.fold_left - (fun eff1 -> - fun uu___ -> - match uu___ with - | (uu___1, eff_label, uu___2, uu___3) -> - join_effects env eff1 eff_label) - FStar_Parser_Const.effect_PURE_lid lcases in - let uu___ = - let uu___1 = - FStar_Compiler_Util.for_some - (fun uu___2 -> - match uu___2 with - | (uu___3, uu___4, flags, uu___5) -> - FStar_Compiler_Util.for_some - (fun uu___6 -> - match uu___6 with - | FStar_Syntax_Syntax.SHOULD_NOT_INLINE -> true - | uu___7 -> false) flags) lcases in - if uu___1 - then (true, [FStar_Syntax_Syntax.SHOULD_NOT_INLINE]) - else (false, []) in - match uu___ with - | (should_not_inline_whole_match, bind_cases_flags) -> - let bind_cases1 uu___1 = - let u_res_t = env.FStar_TypeChecker_Env.universe_of env res_t in - let uu___2 = - (FStar_Options.lax ()) && (FStar_Options.ml_ish ()) in - if uu___2 - then - let uu___3 = lax_mk_tot_or_comp_l eff u_res_t res_t [] in - (uu___3, FStar_TypeChecker_Env.trivial_guard) - else - (let maybe_return eff_label_then cthen = - let uu___4 = - should_not_inline_whole_match || - (let uu___5 = is_pure_or_ghost_effect env eff in - Prims.op_Negation uu___5) in - if uu___4 then cthen true else cthen false in - let uu___4 = - let uu___5 = - FStar_Compiler_List.map - (fun uu___6 -> - match uu___6 with - | (g, uu___7, uu___8, uu___9) -> g) lcases in - get_neg_branch_conds uu___5 in - match uu___4 with - | (neg_branch_conds, exhaustiveness_branch_cond) -> - let uu___5 = - match lcases with - | [] -> - let uu___6 = - comp_pure_wp_false env u_res_t res_t in - (FStar_Pervasives_Native.None, uu___6, - FStar_TypeChecker_Env.trivial_guard) - | uu___6 -> - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Compiler_List.splitAt - ((FStar_Compiler_List.length lcases) - - Prims.int_one) neg_branch_conds in - match uu___9 with - | (l1, l2) -> - let uu___10 = FStar_Compiler_List.hd l2 in - (l1, uu___10) in - match uu___8 with - | (neg_branch_conds1, neg_last) -> - let uu___9 = - let uu___10 = - FStar_Compiler_List.splitAt - ((FStar_Compiler_List.length lcases) - - Prims.int_one) lcases in - match uu___10 with - | (l1, l2) -> - let uu___11 = - FStar_Compiler_List.hd l2 in - (l1, uu___11) in - (match uu___9 with - | (lcases1, - (g_last, eff_last, uu___10, c_last)) - -> - let uu___11 = - let lc = - maybe_return eff_last c_last in - let uu___12 = - FStar_TypeChecker_Common.lcomp_comp - lc in - match uu___12 with - | (c, g) -> - let uu___13 = - let uu___14 = - let uu___15 = - FStar_Syntax_Util.b2t - g_last in - FStar_Syntax_Util.mk_conj - uu___15 neg_last in - FStar_TypeChecker_Common.weaken_guard_formula - g uu___14 in - (c, uu___13) in - (match uu___11 with - | (c, g) -> - let uu___12 = - let uu___13 = - FStar_TypeChecker_Env.norm_eff_name - env eff_last in - FStar_TypeChecker_Env.get_effect_decl - env uu___13 in - (lcases1, neg_branch_conds1, - uu___12, c, g))) in - (match uu___7 with - | (lcases1, neg_branch_conds1, md, comp, - g_comp) -> - FStar_Compiler_List.fold_right2 - (fun uu___8 -> - fun neg_cond -> - fun uu___9 -> - match (uu___8, uu___9) with - | ((g, eff_label, uu___10, cthen), - (uu___11, celse, g_comp1)) -> - let uu___12 = - let uu___13 = - maybe_return eff_label - cthen in - FStar_TypeChecker_Common.lcomp_comp - uu___13 in - (match uu___12 with - | (cthen1, g_then) -> - let uu___13 = - let uu___14 = - lift_comps_sep_guards - env cthen1 celse - FStar_Pervasives_Native.None - false in - match uu___14 with - | (m, cthen2, celse1, - g_lift_then, - g_lift_else) -> - let md1 = - FStar_TypeChecker_Env.get_effect_decl - env m in - let uu___15 = - FStar_TypeChecker_Env.comp_to_comp_typ - env cthen2 in - let uu___16 = - FStar_TypeChecker_Env.comp_to_comp_typ - env celse1 in - (md1, uu___15, - uu___16, - g_lift_then, - g_lift_else) in - (match uu___13 with - | (md1, ct_then, - ct_else, g_lift_then, - g_lift_else) -> - let fn = - let uu___14 = - FStar_Syntax_Util.is_layered - md1 in - if uu___14 - then - mk_layered_conjunction - else - mk_non_layered_conjunction in - let uu___14 = - let uu___15 = - FStar_TypeChecker_Env.get_range - env in - fn env md1 u_res_t - res_t g ct_then - ct_else uu___15 in - (match uu___14 with - | (c, - g_conjunction) - -> - let uu___15 = - let g1 = - FStar_Syntax_Util.b2t - g in - let uu___16 = - let uu___17 - = - FStar_TypeChecker_Env.conj_guard - g_then - g_lift_then in - let uu___18 - = - FStar_Syntax_Util.mk_conj - neg_cond - g1 in - FStar_TypeChecker_Common.weaken_guard_formula - uu___17 - uu___18 in - let uu___17 = - let uu___18 - = - let uu___19 - = - FStar_Syntax_Util.mk_neg - g1 in - FStar_Syntax_Util.mk_conj - neg_cond - uu___19 in - FStar_TypeChecker_Common.weaken_guard_formula - g_lift_else - uu___18 in - (uu___16, - uu___17) in - (match uu___15 - with - | (g_then1, - g_else) -> - let uu___16 - = - FStar_TypeChecker_Env.conj_guards - [g_comp1; - g_then1; - g_else; - g_conjunction] in - ((FStar_Pervasives_Native.Some - md1), c, - uu___16)))))) - lcases1 neg_branch_conds1 - ((FStar_Pervasives_Native.Some md), comp, - g_comp)) in - (match uu___5 with - | (md, comp, g_comp) -> - let uu___6 = - let uu___7 = - let check = - FStar_Syntax_Util.mk_imp - exhaustiveness_branch_cond - FStar_Syntax_Util.t_false in - let check1 = - let uu___8 = - FStar_TypeChecker_Env.get_range env in - label - FStar_TypeChecker_Err.exhaustiveness_check - uu___8 check in - strengthen_comp env - FStar_Pervasives_Native.None comp check1 - bind_cases_flags in - match uu___7 with - | (c, g) -> - let uu___8 = - FStar_TypeChecker_Env.conj_guard g_comp g in - (c, uu___8) in - (match uu___6 with - | (comp1, g_comp1) -> - (match lcases with - | [] -> (comp1, g_comp1) - | uu___7::[] -> (comp1, g_comp1) - | uu___7 -> - let uu___8 = - let uu___9 = - FStar_Compiler_Util.must md in - FStar_Syntax_Util.is_layered uu___9 in - if uu___8 - then (comp1, g_comp1) - else - (let comp2 = - FStar_TypeChecker_Env.comp_to_comp_typ - env comp1 in - let md1 = - FStar_TypeChecker_Env.get_effect_decl - env - comp2.FStar_Syntax_Syntax.effect_name in - let uu___10 = destruct_wp_comp comp2 in - match uu___10 with - | (uu___11, uu___12, wp) -> - let ite_wp = - let uu___13 = - FStar_Syntax_Util.get_wp_ite_combinator - md1 in - FStar_Compiler_Util.must - uu___13 in - let wp1 = - let uu___13 = - FStar_TypeChecker_Env.inst_effect_fun_with - [u_res_t] env md1 ite_wp in - let uu___14 = - let uu___15 = - FStar_Syntax_Syntax.as_arg - res_t in - let uu___16 = - let uu___17 = - FStar_Syntax_Syntax.as_arg - wp in - [uu___17] in - uu___15 :: uu___16 in - FStar_Syntax_Syntax.mk_Tm_app - uu___13 uu___14 - wp.FStar_Syntax_Syntax.pos in - let uu___13 = - mk_comp md1 u_res_t res_t wp1 - bind_cases_flags in - (uu___13, g_comp1)))))) in - FStar_TypeChecker_Common.mk_lcomp eff res_t bind_cases_flags - bind_cases1 -let (check_comp : - FStar_TypeChecker_Env.env -> - Prims.bool -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.comp -> - FStar_Syntax_Syntax.comp -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.comp * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun use_eq -> - fun e -> - fun c -> - fun c' -> - FStar_Defensive.def_check_scoped - FStar_TypeChecker_Env.hasBinders_env - FStar_Class_Binders.hasNames_comp - FStar_Syntax_Print.pretty_comp c.FStar_Syntax_Syntax.pos - "check_comp.c" env c; - FStar_Defensive.def_check_scoped - FStar_TypeChecker_Env.hasBinders_env - FStar_Class_Binders.hasNames_comp - FStar_Syntax_Print.pretty_comp c'.FStar_Syntax_Syntax.pos - "check_comp.c'" env c'; - (let uu___3 = FStar_Compiler_Debug.extreme () in - if uu___3 - then - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_comp c in - let uu___6 = - FStar_Class_Show.show FStar_Syntax_Print.showable_comp c' in - FStar_Compiler_Util.print4 - "Checking comp relation:\n%s has type %s\n\t %s \n%s\n" - uu___4 uu___5 (if use_eq then "$:" else "<:") uu___6 - else ()); - (let f = - if use_eq - then FStar_TypeChecker_Rel.eq_comp - else FStar_TypeChecker_Rel.sub_comp in - let uu___3 = f env c c' in - match uu___3 with - | FStar_Pervasives_Native.None -> - if use_eq - then - let uu___4 = FStar_TypeChecker_Env.get_range env in - FStar_TypeChecker_Err.computed_computation_type_does_not_match_annotation_eq - env uu___4 e c c' - else - (let uu___5 = FStar_TypeChecker_Env.get_range env in - FStar_TypeChecker_Err.computed_computation_type_does_not_match_annotation - env uu___5 e c c') - | FStar_Pervasives_Native.Some g -> (e, c', g)) -let (universe_of_comp : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.comp -> FStar_Syntax_Syntax.universe) - = - fun env -> - fun u_res -> - fun c -> - let c_lid = - FStar_TypeChecker_Env.norm_eff_name env - (FStar_Syntax_Util.comp_effect_name c) in - let uu___ = FStar_Syntax_Util.is_pure_or_ghost_effect c_lid in - if uu___ - then u_res - else - (let is_total = - let uu___2 = FStar_TypeChecker_Env.lookup_effect_quals env c_lid in - FStar_Compiler_List.existsb - (fun q -> q = FStar_Syntax_Syntax.TotalEffect) uu___2 in - if Prims.op_Negation is_total - then FStar_Syntax_Syntax.U_zero - else - (let uu___3 = FStar_TypeChecker_Env.effect_repr env c u_res in - match uu___3 with - | FStar_Pervasives_Native.None -> - let uu___4 = - let uu___5 = - FStar_Class_Show.show FStar_Ident.showable_lident c_lid in - FStar_Compiler_Util.format1 - "Effect %s is marked total but does not have a repr" - uu___5 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) c - FStar_Errors_Codes.Fatal_EffectCannotBeReified () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4) - | FStar_Pervasives_Native.Some tm -> - env.FStar_TypeChecker_Env.universe_of env tm)) -let (check_trivial_precondition_wp : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.comp -> - (FStar_Syntax_Syntax.comp_typ * FStar_Syntax_Syntax.formula * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun c -> - let ct = FStar_TypeChecker_Env.unfold_effect_abbrev env c in - let md = - FStar_TypeChecker_Env.get_effect_decl env - ct.FStar_Syntax_Syntax.effect_name in - let uu___ = destruct_wp_comp ct in - match uu___ with - | (u_t, t, wp) -> - let vc = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Util.get_wp_trivial_combinator md in - FStar_Compiler_Util.must uu___3 in - FStar_TypeChecker_Env.inst_effect_fun_with [u_t] env md uu___2 in - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.as_arg t in - let uu___4 = - let uu___5 = FStar_Syntax_Syntax.as_arg wp in [uu___5] in - uu___3 :: uu___4 in - let uu___3 = FStar_TypeChecker_Env.get_range env in - FStar_Syntax_Syntax.mk_Tm_app uu___1 uu___2 uu___3 in - let uu___1 = - FStar_TypeChecker_Env.guard_of_guard_formula - (FStar_TypeChecker_Common.NonTrivial vc) in - (ct, vc, uu___1) -let (maybe_lift : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Ident.lident -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.term) - = - fun env -> - fun e -> - fun c1 -> - fun c2 -> - fun t -> - let m1 = FStar_TypeChecker_Env.norm_eff_name env c1 in - let m2 = FStar_TypeChecker_Env.norm_eff_name env c2 in - let uu___ = - ((FStar_Ident.lid_equals m1 m2) || - ((FStar_Syntax_Util.is_pure_effect c1) && - (FStar_Syntax_Util.is_ghost_effect c2))) - || - ((FStar_Syntax_Util.is_pure_effect c2) && - (FStar_Syntax_Util.is_ghost_effect c1)) in - if uu___ - then e - else - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 = e; - FStar_Syntax_Syntax.meta = - (FStar_Syntax_Syntax.Meta_monadic_lift (m1, m2, t)) - }) e.FStar_Syntax_Syntax.pos -let (maybe_monadic : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.term) - = - fun env -> - fun e -> - fun c -> - fun t -> - let m = FStar_TypeChecker_Env.norm_eff_name env c in - let uu___ = - ((is_pure_or_ghost_effect env m) || - (FStar_Ident.lid_equals m FStar_Parser_Const.effect_Tot_lid)) - || - (FStar_Ident.lid_equals m FStar_Parser_Const.effect_GTot_lid) in - if uu___ - then e - else - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_meta - { - FStar_Syntax_Syntax.tm2 = e; - FStar_Syntax_Syntax.meta = - (FStar_Syntax_Syntax.Meta_monadic (m, t)) - }) e.FStar_Syntax_Syntax.pos -let (coerce_with : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_TypeChecker_Common.lcomp -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.universes -> - FStar_Syntax_Syntax.args -> - FStar_Syntax_Syntax.comp -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.lcomp)) - = - fun env -> - fun e -> - fun lc -> - fun f -> - fun us -> - fun eargs -> - fun comp2 -> - let uu___ = FStar_TypeChecker_Env.try_lookup_lid env f in - match uu___ with - | FStar_Pervasives_Native.Some uu___1 -> - ((let uu___3 = - FStar_Compiler_Effect.op_Bang dbg_Coercions in - if uu___3 - then - let uu___4 = FStar_Ident.string_of_lid f in - FStar_Compiler_Util.print1 "Coercing with %s!\n" - uu___4 - else ()); - (let lc2 = FStar_TypeChecker_Common.lcomp_of_comp comp2 in - let lc_res = - bind e.FStar_Syntax_Syntax.pos env - (FStar_Pervasives_Native.Some e) lc - (FStar_Pervasives_Native.None, lc2) in - let coercion = - let uu___3 = - FStar_Ident.set_lid_range f - e.FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.fvar uu___3 - FStar_Pervasives_Native.None in - let coercion1 = - FStar_Syntax_Syntax.mk_Tm_uinst coercion us in - let e1 = - let uu___3 = - FStar_TypeChecker_Common.is_pure_or_ghost_lcomp lc in - if uu___3 - then - let uu___4 = - let uu___5 = - let uu___6 = FStar_Syntax_Syntax.as_arg e in - [uu___6] in - FStar_Compiler_List.op_At eargs uu___5 in - FStar_Syntax_Syntax.mk_Tm_app coercion1 uu___4 - e.FStar_Syntax_Syntax.pos - else - (let x = - FStar_Syntax_Syntax.new_bv - (FStar_Pervasives_Native.Some - (e.FStar_Syntax_Syntax.pos)) - lc.FStar_TypeChecker_Common.res_typ in - let e2 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Syntax_Syntax.bv_to_name x in - FStar_Syntax_Syntax.as_arg uu___8 in - [uu___7] in - FStar_Compiler_List.op_At eargs uu___6 in - FStar_Syntax_Syntax.mk_Tm_app coercion1 uu___5 - e.FStar_Syntax_Syntax.pos in - let e3 = - maybe_lift env e - lc.FStar_TypeChecker_Common.eff_name - lc_res.FStar_TypeChecker_Common.eff_name - lc.FStar_TypeChecker_Common.res_typ in - let e21 = - let uu___5 = FStar_TypeChecker_Env.push_bv env x in - maybe_lift uu___5 e2 - lc2.FStar_TypeChecker_Common.eff_name - lc_res.FStar_TypeChecker_Common.eff_name - lc2.FStar_TypeChecker_Common.res_typ in - let lb = - FStar_Syntax_Util.mk_letbinding - (FStar_Pervasives.Inl x) [] - lc.FStar_TypeChecker_Common.res_typ - lc_res.FStar_TypeChecker_Common.eff_name e3 [] - e3.FStar_Syntax_Syntax.pos in - let e4 = - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Syntax_Syntax.mk_binder x in - [uu___9] in - FStar_Syntax_Subst.close uu___8 e21 in - { - FStar_Syntax_Syntax.lbs = (false, [lb]); - FStar_Syntax_Syntax.body1 = uu___7 - } in - FStar_Syntax_Syntax.Tm_let uu___6 in - FStar_Syntax_Syntax.mk uu___5 - e3.FStar_Syntax_Syntax.pos in - maybe_monadic env e4 - lc_res.FStar_TypeChecker_Common.eff_name - lc_res.FStar_TypeChecker_Common.res_typ) in - (e1, lc_res))) - | FStar_Pervasives_Native.None -> - ((let uu___2 = - let uu___3 = FStar_Ident.string_of_lid f in - FStar_Compiler_Util.format1 - "Coercion %s was not found in the environment, not coercing." - uu___3 in - FStar_Errors.log_issue - (FStar_Syntax_Syntax.has_range_syntax ()) e - FStar_Errors_Codes.Warning_CoercionNotFound () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)); - (e, lc)) -type isErased = - | Yes of FStar_Syntax_Syntax.term - | Maybe - | No -let (uu___is_Yes : isErased -> Prims.bool) = - fun projectee -> match projectee with | Yes _0 -> true | uu___ -> false -let (__proj__Yes__item___0 : isErased -> FStar_Syntax_Syntax.term) = - fun projectee -> match projectee with | Yes _0 -> _0 -let (uu___is_Maybe : isErased -> Prims.bool) = - fun projectee -> match projectee with | Maybe -> true | uu___ -> false -let (uu___is_No : isErased -> Prims.bool) = - fun projectee -> match projectee with | No -> true | uu___ -> false -let rec (check_erased : - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.term -> isErased) = - fun env -> - fun t -> - let norm' = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Exclude FStar_TypeChecker_Env.Zeta; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.Unascribe; - FStar_TypeChecker_Env.Unmeta; - FStar_TypeChecker_Env.Unrefine; - FStar_TypeChecker_Env.Weak; - FStar_TypeChecker_Env.HNF; - FStar_TypeChecker_Env.Iota] in - let t1 = norm' env t in - let uu___ = FStar_Syntax_Util.head_and_args t1 in - match uu___ with - | (h, args) -> - let h1 = FStar_Syntax_Util.un_uinst h in - let r = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress h1 in - uu___3.FStar_Syntax_Syntax.n in - (uu___2, args) in - match uu___1 with - | (FStar_Syntax_Syntax.Tm_fvar fv, (a, uu___2)::[]) when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.erased_lid - -> Yes a - | (FStar_Syntax_Syntax.Tm_uvar uu___2, uu___3) -> Maybe - | (FStar_Syntax_Syntax.Tm_unknown, uu___2) -> Maybe - | (FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = uu___2; - FStar_Syntax_Syntax.ret_opt = uu___3; - FStar_Syntax_Syntax.brs = branches; - FStar_Syntax_Syntax.rc_opt1 = uu___4;_}, - uu___5) -> - FStar_Compiler_List.fold_left - (fun acc -> - fun br -> - match acc with - | Yes uu___6 -> Maybe - | Maybe -> Maybe - | No -> - let uu___6 = FStar_Syntax_Subst.open_branch br in - (match uu___6 with - | (uu___7, uu___8, br_body) -> - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Syntax_Free.names br_body in - FStar_Class_Setlike.elems () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Syntax_Syntax.ord_bv)) - (Obj.magic uu___12) in - FStar_TypeChecker_Env.push_bvs env - uu___11 in - check_erased uu___10 br_body in - (match uu___9 with - | No -> No - | uu___10 -> Maybe))) No branches - | uu___2 -> No in - r -let rec first_opt : - 'a 'b . - ('a -> 'b FStar_Pervasives_Native.option) -> - 'a Prims.list -> 'b FStar_Pervasives_Native.option - = - fun f -> - fun xs -> - match xs with - | [] -> FStar_Pervasives_Native.None - | x::xs1 -> - let uu___ = f x in - FStar_Compiler_Util.catch_opt uu___ (fun uu___1 -> first_opt f xs1) -let op_let_Question : - 'uuuuu 'uuuuu1 . - unit -> - 'uuuuu FStar_Pervasives_Native.option -> - ('uuuuu -> 'uuuuu1 FStar_Pervasives_Native.option) -> - 'uuuuu1 FStar_Pervasives_Native.option - = fun uu___ -> FStar_Compiler_Util.bind_opt -let (bool_guard : Prims.bool -> unit FStar_Pervasives_Native.option) = - fun b -> - if b - then FStar_Pervasives_Native.Some () - else FStar_Pervasives_Native.None -let (find_coercion : - FStar_TypeChecker_Env.env -> - FStar_TypeChecker_Common.lcomp -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.lcomp * - FStar_TypeChecker_Env.guard_t) FStar_Pervasives_Native.option) - = - fun env -> - fun checked -> - fun exp_t -> - fun e -> - FStar_Errors.with_ctx "find_coercion" - (fun uu___ -> - let is_type t = - let t1 = FStar_TypeChecker_Normalize.unfold_whnf env t in - let t2 = FStar_Syntax_Util.unrefine t1 in - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress t2 in - uu___2.FStar_Syntax_Syntax.n in - match uu___1 with - | FStar_Syntax_Syntax.Tm_type uu___2 -> true - | uu___2 -> false in - let rec head_of t = - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress t in - uu___2.FStar_Syntax_Syntax.n in - match uu___1 with - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = t1; - FStar_Syntax_Syntax.args = uu___2;_} - -> head_of t1 - | FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = t1; - FStar_Syntax_Syntax.ret_opt = uu___2; - FStar_Syntax_Syntax.brs = uu___3; - FStar_Syntax_Syntax.rc_opt1 = uu___4;_} - -> head_of t1 - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = uu___2; - FStar_Syntax_Syntax.body = t1; - FStar_Syntax_Syntax.rc_opt = uu___3;_} - -> head_of t1 - | FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t1; - FStar_Syntax_Syntax.asc = uu___2; - FStar_Syntax_Syntax.eff_opt = uu___3;_} - -> head_of t1 - | FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t1; - FStar_Syntax_Syntax.meta = uu___2;_} - -> head_of t1 - | FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = b; - FStar_Syntax_Syntax.phi = uu___2;_} - -> head_of b.FStar_Syntax_Syntax.sort - | uu___2 -> t in - let is_head_defined t = - let h = head_of t in - let h1 = FStar_Syntax_Subst.compress h in - ((FStar_Syntax_Syntax.uu___is_Tm_fvar - h1.FStar_Syntax_Syntax.n) - || - (FStar_Syntax_Syntax.uu___is_Tm_uinst - h1.FStar_Syntax_Syntax.n)) - || - (FStar_Syntax_Syntax.uu___is_Tm_type - h1.FStar_Syntax_Syntax.n) in - let head_unfold env1 t = - FStar_TypeChecker_Normalize.unfold_whnf' - [FStar_TypeChecker_Env.Unascribe; - FStar_TypeChecker_Env.Unmeta; - FStar_TypeChecker_Env.Unrefine] env1 t in - let uu___1 = - let uu___2 = - (is_head_defined exp_t) && - (is_head_defined - checked.FStar_TypeChecker_Common.res_typ) in - bool_guard uu___2 in - (op_let_Question ()) uu___1 - (fun uu___2 -> - let computed_t = - head_unfold env - checked.FStar_TypeChecker_Common.res_typ in - let uu___3 = FStar_Syntax_Util.head_and_args computed_t in - match uu___3 with - | (head, args) -> - let exp_t1 = head_unfold env exp_t in - let uu___4 = - let uu___5 = - let uu___6 = FStar_Syntax_Util.un_uinst head in - uu___6.FStar_Syntax_Syntax.n in - (uu___5, args) in - (match uu___4 with - | (FStar_Syntax_Syntax.Tm_fvar fv, []) when - (FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.bool_lid) - && (is_type exp_t1) - -> - let lc2 = - let uu___5 = - FStar_Syntax_Syntax.mk_Total - FStar_Syntax_Util.ktype0 in - FStar_TypeChecker_Common.lcomp_of_comp uu___5 in - let lc_res = - bind e.FStar_Syntax_Syntax.pos env - (FStar_Pervasives_Native.Some e) checked - (FStar_Pervasives_Native.None, lc2) in - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Syntax_Syntax.fvar - FStar_Parser_Const.b2t_lid - FStar_Pervasives_Native.None in - let uu___8 = - let uu___9 = FStar_Syntax_Syntax.as_arg e in - [uu___9] in - FStar_Syntax_Util.mk_app uu___7 uu___8 in - (uu___6, lc_res, - FStar_TypeChecker_Env.trivial_guard) in - FStar_Pervasives_Native.Some uu___5 - | uu___5 -> - let head_lid_of t = - let uu___6 = - let uu___7 = - let uu___8 = head_of t in - FStar_Syntax_Subst.compress uu___8 in - uu___7.FStar_Syntax_Syntax.n in - match uu___6 with - | FStar_Syntax_Syntax.Tm_fvar fv -> - let uu___7 = - FStar_Syntax_Syntax.lid_of_fv fv in - FStar_Pervasives_Native.Some uu___7 - | FStar_Syntax_Syntax.Tm_uinst - ({ - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___7; - FStar_Syntax_Syntax.vars = uu___8; - FStar_Syntax_Syntax.hash_code = uu___9;_}, - uu___10) - -> - let uu___11 = - FStar_Syntax_Syntax.lid_of_fv fv in - FStar_Pervasives_Native.Some uu___11 - | uu___7 -> FStar_Pervasives_Native.None in - let uu___6 = head_lid_of exp_t1 in - (op_let_Question ()) uu___6 - (fun exp_head_lid -> - let uu___7 = head_lid_of computed_t in - (op_let_Question ()) uu___7 - (fun computed_head_lid -> - let candidates = - FStar_TypeChecker_Env.lookup_attr - env "FStar.Pervasives.coercion" in - first_opt - (fun se -> - let uu___8 = - match se.FStar_Syntax_Syntax.sigel - with - | FStar_Syntax_Syntax.Sig_let - { - FStar_Syntax_Syntax.lbs1 - = (uu___9, lb::[]); - FStar_Syntax_Syntax.lids1 - = uu___10;_} - -> - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Compiler_Util.right - lb.FStar_Syntax_Syntax.lbname in - FStar_Syntax_Syntax.lid_of_fv - uu___13 in - (uu___12, - (lb.FStar_Syntax_Syntax.lbunivs), - (lb.FStar_Syntax_Syntax.lbtyp)) in - FStar_Pervasives_Native.Some - uu___11 - | FStar_Syntax_Syntax.Sig_declare_typ - { - FStar_Syntax_Syntax.lid2 - = lid; - FStar_Syntax_Syntax.us2 = - us; - FStar_Syntax_Syntax.t2 = - t;_} - -> - FStar_Pervasives_Native.Some - (lid, us, t) - | uu___9 -> - FStar_Pervasives_Native.None in - (op_let_Question ()) uu___8 - (fun uu___9 -> - match uu___9 with - | (f_name, f_us, f_typ) -> - let uu___10 = - FStar_Syntax_Subst.open_univ_vars - f_us f_typ in - (match uu___10 with - | (uu___11, f_typ1) -> - let uu___12 = - FStar_Syntax_Util.arrow_formals_comp - f_typ1 in - (match uu___12 with - | (f_bs, f_c) -> - let uu___13 = - bool_guard - (f_bs <> - []) in - (op_let_Question - ()) uu___13 - (fun uu___14 - -> - let f_res - = - FStar_Syntax_Util.comp_result - f_c in - let f_res1 - = - let uu___15 - = - FStar_TypeChecker_Env.push_binders - env f_bs in - head_unfold - uu___15 - f_res in - let uu___15 - = - head_lid_of - f_res1 in - (op_let_Question - ()) - uu___15 - (fun - f_res_head_lid - -> - let uu___16 - = - let uu___17 - = - FStar_Ident.lid_equals - exp_head_lid - f_res_head_lid in - bool_guard - uu___17 in - (op_let_Question - ()) - uu___16 - (fun - uu___17 - -> - let b = - FStar_Compiler_List.last - f_bs in - let b_ty - = - (b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - let b_ty1 - = - let uu___18 - = - let uu___19 - = - FStar_Compiler_List.init - f_bs in - FStar_TypeChecker_Env.push_binders - env - uu___19 in - head_unfold - uu___18 - b_ty in - let uu___18 - = - head_lid_of - b_ty1 in - (op_let_Question - ()) - uu___18 - (fun - b_head_lid - -> - let uu___19 - = - let uu___20 - = - FStar_Ident.lid_equals - computed_head_lid - b_head_lid in - bool_guard - uu___20 in - (op_let_Question - ()) - uu___19 - (fun - uu___20 - -> - let f_tm - = - FStar_Syntax_Syntax.fvar - f_name - FStar_Pervasives_Native.None in - let tt = - let uu___21 - = - let uu___22 - = - FStar_Syntax_Syntax.as_arg - e in - [uu___22] in - FStar_Syntax_Util.mk_app - f_tm - uu___21 in - let uu___21 - = - env.FStar_TypeChecker_Env.tc_term - { - FStar_TypeChecker_Env.solver - = - (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range - = - (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule - = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma - = - (env.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig - = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache - = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules - = - (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ - = - (FStar_Pervasives_Native.Some - (exp_t1, - false)); - FStar_TypeChecker_Env.sigtab - = - (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab - = - (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp - = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects - = - (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize - = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs - = - (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level - = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars - = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict - = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface - = - (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit - = true; - FStar_TypeChecker_Env.lax_universes - = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 - = - (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard - = - (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking - = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping - = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics - = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce - = true; - FStar_TypeChecker_Env.tc_term - = - (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term - = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of - = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term - = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force - = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force - = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index - = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names - = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths - = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns - = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook - = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook - = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice - = - (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess - = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess - = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info - = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks - = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv - = - (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe - = - (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab - = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab - = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac - = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards - = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args - = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check - = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl - = - (env.FStar_TypeChecker_Env.missing_decl) - } tt in - FStar_Pervasives_Native.Some - uu___21))))))))) - candidates))))) -let (maybe_coerce_lc : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_TypeChecker_Common.lcomp -> - FStar_Syntax_Syntax.typ -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.lcomp * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun e -> - fun lc -> - fun exp_t -> - let should_coerce = - (env.FStar_TypeChecker_Env.phase1 || (FStar_Options.lax ())) && - (Prims.op_Negation env.FStar_TypeChecker_Env.nocoerce) in - if Prims.op_Negation should_coerce - then - ((let uu___1 = FStar_Compiler_Effect.op_Bang dbg_Coercions in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show - FStar_Compiler_Range_Ops.showable_range - e.FStar_Syntax_Syntax.pos in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - lc.FStar_TypeChecker_Common.res_typ in - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - exp_t in - FStar_Compiler_Util.print4 - "(%s) NOT Trying to coerce %s from type (%s) to type (%s)\n" - uu___2 uu___3 uu___4 uu___5 - else ()); - (e, lc, FStar_TypeChecker_Env.trivial_guard)) - else - ((let uu___2 = FStar_Compiler_Effect.op_Bang dbg_Coercions in - if uu___2 - then - let uu___3 = - FStar_Class_Show.show - FStar_Compiler_Range_Ops.showable_range - e.FStar_Syntax_Syntax.pos in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - lc.FStar_TypeChecker_Common.res_typ in - let uu___6 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - exp_t in - FStar_Compiler_Util.print4 - "(%s) Trying to coerce %s from type (%s) to type (%s)\n" - uu___3 uu___4 uu___5 uu___6 - else ()); - (let uu___2 = find_coercion env lc exp_t e in - match uu___2 with - | FStar_Pervasives_Native.Some (coerced, lc1, g) -> - ((let uu___4 = FStar_Compiler_Effect.op_Bang dbg_Coercions in - if uu___4 - then - let uu___5 = - FStar_Compiler_Range_Ops.string_of_range - e.FStar_Syntax_Syntax.pos in - let uu___6 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term e in - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term coerced in - FStar_Compiler_Util.print3 "(%s) COERCING %s to %s\n" - uu___5 uu___6 uu___7 - else ()); - (coerced, lc1, g)) - | FStar_Pervasives_Native.None -> - ((let uu___4 = FStar_Compiler_Effect.op_Bang dbg_Coercions in - if uu___4 - then - let uu___5 = - FStar_Compiler_Range_Ops.string_of_range - e.FStar_Syntax_Syntax.pos in - FStar_Compiler_Util.print1 - "(%s) No user coercion found\n" uu___5 - else ()); - (let strip_hide_or_reveal e1 hide_or_reveal = - let uu___4 = - FStar_Syntax_Util.leftmost_head_and_args e1 in - match uu___4 with - | (hd, args) -> - let uu___5 = - let uu___6 = - let uu___7 = FStar_Syntax_Subst.compress hd in - uu___7.FStar_Syntax_Syntax.n in - (uu___6, args) in - (match uu___5 with - | (FStar_Syntax_Syntax.Tm_uinst (hd1, uu___6), - (uu___7, aq_t)::(e2, aq_e)::[]) when - (((FStar_Syntax_Util.is_fvar hide_or_reveal - hd1) - && - (FStar_Pervasives_Native.uu___is_Some aq_t)) - && - (FStar_Pervasives_Native.__proj__Some__item__v - aq_t).FStar_Syntax_Syntax.aqual_implicit) - && - ((aq_e = FStar_Pervasives_Native.None) || - (Prims.op_Negation - (FStar_Pervasives_Native.__proj__Some__item__v - aq_e).FStar_Syntax_Syntax.aqual_implicit)) - -> FStar_Pervasives_Native.Some e2 - | uu___6 -> FStar_Pervasives_Native.None) in - let uu___4 = - let uu___5 = - check_erased env lc.FStar_TypeChecker_Common.res_typ in - let uu___6 = check_erased env exp_t in (uu___5, uu___6) in - match uu___4 with - | (No, Yes ty) -> - let u = env.FStar_TypeChecker_Env.universe_of env ty in - let uu___5 = - FStar_TypeChecker_Rel.get_subtyping_predicate env - lc.FStar_TypeChecker_Common.res_typ ty in - (match uu___5 with - | FStar_Pervasives_Native.None -> - (e, lc, FStar_TypeChecker_Env.trivial_guard) - | FStar_Pervasives_Native.Some g -> - let g1 = FStar_TypeChecker_Env.apply_guard g e in - let uu___6 = - let uu___7 = - let uu___8 = FStar_Syntax_Syntax.iarg ty in - [uu___8] in - let uu___8 = - FStar_Syntax_Syntax.mk_Total exp_t in - coerce_with env e lc FStar_Parser_Const.hide - [u] uu___7 uu___8 in - (match uu___6 with - | (e_hide, lc1) -> - let e_hide1 = - let uu___7 = - strip_hide_or_reveal e - FStar_Parser_Const.reveal in - FStar_Compiler_Util.dflt e_hide uu___7 in - (e_hide1, lc1, g1))) - | (Yes ty, No) -> - let u = env.FStar_TypeChecker_Env.universe_of env ty in - let uu___5 = - let uu___6 = - let uu___7 = FStar_Syntax_Syntax.iarg ty in - [uu___7] in - let uu___7 = FStar_Syntax_Syntax.mk_GTotal ty in - coerce_with env e lc FStar_Parser_Const.reveal - [u] uu___6 uu___7 in - (match uu___5 with - | (e_reveal, lc1) -> - let e_reveal1 = - let uu___6 = - strip_hide_or_reveal e - FStar_Parser_Const.hide in - FStar_Compiler_Util.dflt e_reveal uu___6 in - (e_reveal1, lc1, - FStar_TypeChecker_Env.trivial_guard)) - | uu___5 -> (e, lc, FStar_TypeChecker_Env.trivial_guard))))) -let (weaken_result_typ : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_TypeChecker_Common.lcomp -> - FStar_Syntax_Syntax.typ -> - Prims.bool -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.lcomp * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun e -> - fun lc -> - fun t -> - fun use_eq -> - (let uu___1 = FStar_Compiler_Debug.high () in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool) use_eq in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - let uu___4 = FStar_TypeChecker_Common.lcomp_to_string lc in - let uu___5 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.print4 - "weaken_result_typ use_eq=%s e=(%s) lc=(%s) t=(%s)\n" uu___2 - uu___3 uu___4 uu___5 - else ()); - (let use_eq1 = - (use_eq || env.FStar_TypeChecker_Env.use_eq_strict) || - (let uu___1 = - FStar_TypeChecker_Env.effect_decl_opt env - lc.FStar_TypeChecker_Common.eff_name in - match uu___1 with - | FStar_Pervasives_Native.Some (ed, qualifiers) -> - FStar_Compiler_List.contains - FStar_Syntax_Syntax.Reifiable qualifiers - | uu___2 -> false) in - let gopt = - if use_eq1 - then - let uu___1 = - FStar_TypeChecker_Rel.try_teq true env - lc.FStar_TypeChecker_Common.res_typ t in - (uu___1, false) - else - (let uu___2 = - FStar_TypeChecker_Rel.get_subtyping_predicate env - lc.FStar_TypeChecker_Common.res_typ t in - (uu___2, true)) in - match gopt with - | (FStar_Pervasives_Native.None, uu___1) -> - if env.FStar_TypeChecker_Env.failhard - then - FStar_TypeChecker_Err.raise_basic_type_error env - e.FStar_Syntax_Syntax.pos - (FStar_Pervasives_Native.Some e) t - lc.FStar_TypeChecker_Common.res_typ - else - (FStar_TypeChecker_Rel.subtype_fail env e - lc.FStar_TypeChecker_Common.res_typ t; - (e, - { - FStar_TypeChecker_Common.eff_name = - (lc.FStar_TypeChecker_Common.eff_name); - FStar_TypeChecker_Common.res_typ = t; - FStar_TypeChecker_Common.cflags = - (lc.FStar_TypeChecker_Common.cflags); - FStar_TypeChecker_Common.comp_thunk = - (lc.FStar_TypeChecker_Common.comp_thunk) - }, FStar_TypeChecker_Env.trivial_guard)) - | (FStar_Pervasives_Native.Some g, apply_guard) -> - let uu___1 = FStar_TypeChecker_Env.guard_form g in - (match uu___1 with - | FStar_TypeChecker_Common.Trivial -> - let strengthen_trivial uu___2 = - let uu___3 = FStar_TypeChecker_Common.lcomp_comp lc in - match uu___3 with - | (c, g_c) -> - let res_t = FStar_Syntax_Util.comp_result c in - let set_result_typ c1 = - FStar_Syntax_Util.set_result_typ c1 t in - let uu___4 = - let uu___5 = - FStar_TypeChecker_TermEqAndSimplify.eq_tm env - t res_t in - uu___5 = - FStar_TypeChecker_TermEqAndSimplify.Equal in - if uu___4 - then - ((let uu___6 = FStar_Compiler_Debug.extreme () in - if uu___6 - then - let uu___7 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term res_t in - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.print2 - "weaken_result_type::strengthen_trivial: res_t:%s is same as t:%s\n" - uu___7 uu___8 - else ()); - (let uu___6 = set_result_typ c in - (uu___6, g_c))) - else - (let is_res_t_refinement = - let res_t1 = - FStar_TypeChecker_Normalize.normalize_refinement - FStar_TypeChecker_Normalize.whnf_steps - env res_t in - match res_t1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_refine uu___6 -> - true - | uu___6 -> false in - if is_res_t_refinement - then - let x = - FStar_Syntax_Syntax.new_bv - (FStar_Pervasives_Native.Some - (res_t.FStar_Syntax_Syntax.pos)) - res_t in - let uu___6 = - let uu___7 = - FStar_TypeChecker_Env.norm_eff_name env - (FStar_Syntax_Util.comp_effect_name c) in - let uu___8 = - FStar_Syntax_Syntax.bv_to_name x in - return_value env uu___7 (comp_univ_opt c) - res_t uu___8 in - match uu___6 with - | (cret, gret) -> - let lc1 = - let uu___7 = - FStar_TypeChecker_Common.lcomp_of_comp - c in - let uu___8 = - let uu___9 = - FStar_TypeChecker_Common.lcomp_of_comp - cret in - ((FStar_Pervasives_Native.Some x), - uu___9) in - bind e.FStar_Syntax_Syntax.pos env - (FStar_Pervasives_Native.Some e) - uu___7 uu___8 in - ((let uu___8 = - FStar_Compiler_Debug.extreme () in - if uu___8 - then - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - e in - let uu___10 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_comp - c in - let uu___11 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - t in - let uu___12 = - FStar_TypeChecker_Common.lcomp_to_string - lc1 in - FStar_Compiler_Util.print4 - "weaken_result_type::strengthen_trivial: inserting a return for e: %s, c: %s, t: %s, and then post return lc: %s\n" - uu___9 uu___10 uu___11 uu___12 - else ()); - (let uu___8 = - FStar_TypeChecker_Common.lcomp_comp - lc1 in - match uu___8 with - | (c1, g_lc) -> - let uu___9 = set_result_typ c1 in - let uu___10 = - FStar_TypeChecker_Env.conj_guards - [g_c; gret; g_lc] in - (uu___9, uu___10))) - else - ((let uu___8 = - FStar_Compiler_Debug.extreme () in - if uu___8 - then - let uu___9 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term - res_t in - let uu___10 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_comp c in - FStar_Compiler_Util.print2 - "weaken_result_type::strengthen_trivial: res_t:%s is not a refinement, leaving c:%s as is\n" - uu___9 uu___10 - else ()); - (let uu___8 = set_result_typ c in - (uu___8, g_c)))) in - let lc1 = - FStar_TypeChecker_Common.mk_lcomp - lc.FStar_TypeChecker_Common.eff_name t - lc.FStar_TypeChecker_Common.cflags - strengthen_trivial in - (e, lc1, g) - | FStar_TypeChecker_Common.NonTrivial f -> - let g1 = - { - FStar_TypeChecker_Common.guard_f = - FStar_TypeChecker_Common.Trivial; - FStar_TypeChecker_Common.deferred_to_tac = - (g.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (g.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (g.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = - (g.FStar_TypeChecker_Common.implicits) - } in - let strengthen uu___2 = - let uu___3 = - (FStar_Options.lax ()) && (FStar_Options.ml_ish ()) in - if uu___3 - then FStar_TypeChecker_Common.lcomp_comp lc - else - (let f1 = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.Simplify; - FStar_TypeChecker_Env.Primops] env f in - let uu___5 = - let uu___6 = FStar_Syntax_Subst.compress f1 in - uu___6.FStar_Syntax_Syntax.n in - match uu___5 with - | FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = uu___6; - FStar_Syntax_Syntax.body = - { - FStar_Syntax_Syntax.n = - FStar_Syntax_Syntax.Tm_fvar fv; - FStar_Syntax_Syntax.pos = uu___7; - FStar_Syntax_Syntax.vars = uu___8; - FStar_Syntax_Syntax.hash_code = uu___9;_}; - FStar_Syntax_Syntax.rc_opt = uu___10;_} - when - FStar_Syntax_Syntax.fv_eq_lid fv - FStar_Parser_Const.true_lid - -> - let lc1 = - { - FStar_TypeChecker_Common.eff_name = - (lc.FStar_TypeChecker_Common.eff_name); - FStar_TypeChecker_Common.res_typ = t; - FStar_TypeChecker_Common.cflags = - (lc.FStar_TypeChecker_Common.cflags); - FStar_TypeChecker_Common.comp_thunk = - (lc.FStar_TypeChecker_Common.comp_thunk) - } in - FStar_TypeChecker_Common.lcomp_comp lc1 - | uu___6 -> - let uu___7 = - FStar_TypeChecker_Common.lcomp_comp lc in - (match uu___7 with - | (c, g_c) -> - ((let uu___9 = - FStar_Compiler_Debug.extreme () in - if uu___9 - then - let uu___10 = - FStar_TypeChecker_Normalize.term_to_string - env - lc.FStar_TypeChecker_Common.res_typ in - let uu___11 = - FStar_TypeChecker_Normalize.term_to_string - env t in - let uu___12 = - FStar_TypeChecker_Normalize.comp_to_string - env c in - let uu___13 = - FStar_TypeChecker_Normalize.term_to_string - env f1 in - FStar_Compiler_Util.print4 - "Weakened from %s to %s\nStrengthening %s with guard %s\n" - uu___10 uu___11 uu___12 uu___13 - else ()); - (let u_t_opt = comp_univ_opt c in - let x = - FStar_Syntax_Syntax.new_bv - (FStar_Pervasives_Native.Some - (t.FStar_Syntax_Syntax.pos)) t in - let xexp = - FStar_Syntax_Syntax.bv_to_name x in - let uu___9 = - let uu___10 = - FStar_TypeChecker_Env.norm_eff_name - env - (FStar_Syntax_Util.comp_effect_name - c) in - return_value env uu___10 u_t_opt t - xexp in - match uu___9 with - | (cret, gret) -> - let guard = - if apply_guard - then - let uu___10 = - let uu___11 = - FStar_Syntax_Syntax.as_arg - xexp in - [uu___11] in - FStar_Syntax_Syntax.mk_Tm_app - f1 uu___10 - f1.FStar_Syntax_Syntax.pos - else f1 in - let uu___10 = - let uu___11 = - let uu___12 = - FStar_TypeChecker_Env.push_bvs - env [x] in - FStar_TypeChecker_Env.set_range - uu___12 - e.FStar_Syntax_Syntax.pos in - let uu___12 = - FStar_TypeChecker_Common.lcomp_of_comp - cret in - let uu___13 = - FStar_TypeChecker_Env.guard_of_guard_formula - (FStar_TypeChecker_Common.NonTrivial - guard) in - strengthen_precondition - (FStar_Pervasives_Native.Some - (FStar_TypeChecker_Err.subtyping_failed - env - lc.FStar_TypeChecker_Common.res_typ - t)) uu___11 e uu___12 - uu___13 in - (match uu___10 with - | (eq_ret, - _trivial_so_ok_to_discard) -> - let x1 = - { - FStar_Syntax_Syntax.ppname - = - (x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index - = - (x.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = - (lc.FStar_TypeChecker_Common.res_typ) - } in - let c1 = - let uu___11 = - FStar_TypeChecker_Common.lcomp_of_comp - c in - bind - e.FStar_Syntax_Syntax.pos - env - (FStar_Pervasives_Native.Some - e) uu___11 - ((FStar_Pervasives_Native.Some - x1), eq_ret) in - let uu___11 = - FStar_TypeChecker_Common.lcomp_comp - c1 in - (match uu___11 with - | (c2, g_lc) -> - ((let uu___13 = - FStar_Compiler_Debug.extreme - () in - if uu___13 - then - let uu___14 = - FStar_TypeChecker_Normalize.comp_to_string - env c2 in - FStar_Compiler_Util.print1 - "Strengthened to %s\n" - uu___14 - else ()); - (let uu___13 = - FStar_TypeChecker_Env.conj_guards - [g_c; gret; g_lc] in - (c2, uu___13))))))))) in - let flags = - FStar_Compiler_List.collect - (fun uu___2 -> - match uu___2 with - | FStar_Syntax_Syntax.RETURN -> - [FStar_Syntax_Syntax.PARTIAL_RETURN] - | FStar_Syntax_Syntax.PARTIAL_RETURN -> - [FStar_Syntax_Syntax.PARTIAL_RETURN] - | FStar_Syntax_Syntax.CPS -> - [FStar_Syntax_Syntax.CPS] - | uu___3 -> []) - lc.FStar_TypeChecker_Common.cflags in - let lc1 = - let uu___2 = - FStar_TypeChecker_Env.norm_eff_name env - lc.FStar_TypeChecker_Common.eff_name in - FStar_TypeChecker_Common.mk_lcomp uu___2 t flags - strengthen in - let g2 = - { - FStar_TypeChecker_Common.guard_f = - FStar_TypeChecker_Common.Trivial; - FStar_TypeChecker_Common.deferred_to_tac = - (g1.FStar_TypeChecker_Common.deferred_to_tac); - FStar_TypeChecker_Common.deferred = - (g1.FStar_TypeChecker_Common.deferred); - FStar_TypeChecker_Common.univ_ineqs = - (g1.FStar_TypeChecker_Common.univ_ineqs); - FStar_TypeChecker_Common.implicits = - (g1.FStar_TypeChecker_Common.implicits) - } in - (e, lc1, g2))) -let (pure_or_ghost_pre_and_post : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.comp -> - (FStar_Syntax_Syntax.typ FStar_Pervasives_Native.option * - FStar_Syntax_Syntax.typ)) - = - fun env -> - fun comp -> - let mk_post_type res_t ens = - let x = FStar_Syntax_Syntax.new_bv FStar_Pervasives_Native.None res_t in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = FStar_Syntax_Syntax.bv_to_name x in - FStar_Syntax_Syntax.as_arg uu___3 in - [uu___2] in - FStar_Syntax_Syntax.mk_Tm_app ens uu___1 - res_t.FStar_Syntax_Syntax.pos in - FStar_Syntax_Util.refine x uu___ in - let norm t = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.EraseUniverses] env t in - let uu___ = FStar_Syntax_Util.is_tot_or_gtot_comp comp in - if uu___ - then - (FStar_Pervasives_Native.None, (FStar_Syntax_Util.comp_result comp)) - else - (match comp.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.GTotal uu___2 -> failwith "Impossible" - | FStar_Syntax_Syntax.Total uu___2 -> failwith "Impossible" - | FStar_Syntax_Syntax.Comp ct -> - let uu___2 = - (FStar_Ident.lid_equals ct.FStar_Syntax_Syntax.effect_name - FStar_Parser_Const.effect_Pure_lid) - || - (FStar_Ident.lid_equals ct.FStar_Syntax_Syntax.effect_name - FStar_Parser_Const.effect_Ghost_lid) in - if uu___2 - then - (match ct.FStar_Syntax_Syntax.effect_args with - | (req, uu___3)::(ens, uu___4)::uu___5 -> - let uu___6 = - let uu___7 = norm req in - FStar_Pervasives_Native.Some uu___7 in - let uu___7 = - let uu___8 = - mk_post_type ct.FStar_Syntax_Syntax.result_typ ens in - norm uu___8 in - (uu___6, uu___7) - | uu___3 -> - let uu___4 = - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_comp comp in - FStar_Compiler_Util.format1 - "Effect constructor is not fully applied; got %s" - uu___5 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) comp - FStar_Errors_Codes.Fatal_EffectConstructorNotFullyApplied - () (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___4)) - else - (let ct1 = FStar_TypeChecker_Env.unfold_effect_abbrev env comp in - match ct1.FStar_Syntax_Syntax.effect_args with - | (wp, uu___4)::uu___5 -> - let uu___6 = - let uu___7 = - FStar_TypeChecker_Env.lookup_lid env - FStar_Parser_Const.as_requires in - FStar_Pervasives_Native.fst uu___7 in - (match uu___6 with - | (us_r, uu___7) -> - let uu___8 = - let uu___9 = - FStar_TypeChecker_Env.lookup_lid env - FStar_Parser_Const.as_ensures in - FStar_Pervasives_Native.fst uu___9 in - (match uu___8 with - | (us_e, uu___9) -> - let r = - (ct1.FStar_Syntax_Syntax.result_typ).FStar_Syntax_Syntax.pos in - let as_req = - let uu___10 = - let uu___11 = - FStar_Ident.set_lid_range - FStar_Parser_Const.as_requires r in - FStar_Syntax_Syntax.fvar uu___11 - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.mk_Tm_uinst uu___10 us_r in - let as_ens = - let uu___10 = - let uu___11 = - FStar_Ident.set_lid_range - FStar_Parser_Const.as_ensures r in - FStar_Syntax_Syntax.fvar uu___11 - FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.mk_Tm_uinst uu___10 us_e in - let req = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Syntax_Syntax.as_aqual_implicit - true in - ((ct1.FStar_Syntax_Syntax.result_typ), - uu___12) in - let uu___12 = - let uu___13 = - FStar_Syntax_Syntax.as_arg wp in - [uu___13] in - uu___11 :: uu___12 in - FStar_Syntax_Syntax.mk_Tm_app as_req uu___10 - (ct1.FStar_Syntax_Syntax.result_typ).FStar_Syntax_Syntax.pos in - let ens = - let uu___10 = - let uu___11 = - let uu___12 = - FStar_Syntax_Syntax.as_aqual_implicit - true in - ((ct1.FStar_Syntax_Syntax.result_typ), - uu___12) in - let uu___12 = - let uu___13 = - FStar_Syntax_Syntax.as_arg wp in - [uu___13] in - uu___11 :: uu___12 in - FStar_Syntax_Syntax.mk_Tm_app as_ens uu___10 - (ct1.FStar_Syntax_Syntax.result_typ).FStar_Syntax_Syntax.pos in - let uu___10 = - let uu___11 = norm req in - FStar_Pervasives_Native.Some uu___11 in - let uu___11 = - let uu___12 = - mk_post_type - ct1.FStar_Syntax_Syntax.result_typ ens in - norm uu___12 in - (uu___10, uu___11))) - | uu___4 -> failwith "Impossible")) -let (norm_reify : - FStar_TypeChecker_Env.env -> - FStar_TypeChecker_Env.steps -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun env -> - fun steps -> - fun t -> - FStar_Defensive.def_check_scoped FStar_TypeChecker_Env.hasBinders_env - FStar_Class_Binders.hasNames_term FStar_Syntax_Print.pretty_term - t.FStar_Syntax_Syntax.pos "norm_reify" env t; - (let t' = - FStar_TypeChecker_Normalize.normalize - (FStar_Compiler_List.op_At - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.Reify; - FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.EraseUniverses; - FStar_TypeChecker_Env.AllowUnboundUniverses; - FStar_TypeChecker_Env.Exclude FStar_TypeChecker_Env.Zeta] - steps) env t in - (let uu___2 = FStar_Compiler_Effect.op_Bang dbg_SMTEncodingReify in - if uu___2 - then - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t' in - FStar_Compiler_Util.print2 "Reified body %s \nto %s\n" uu___3 - uu___4 - else ()); - t') -let (remove_reify : FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = - fun t -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Syntax_Subst.compress t in - uu___2.FStar_Syntax_Syntax.n in - match uu___1 with - | FStar_Syntax_Syntax.Tm_app uu___2 -> false - | uu___2 -> true in - if uu___ - then t - else - (let uu___2 = FStar_Syntax_Util.head_and_args t in - match uu___2 with - | (head, args) -> - let uu___3 = - let uu___4 = - let uu___5 = FStar_Syntax_Subst.compress head in - uu___5.FStar_Syntax_Syntax.n in - match uu___4 with - | FStar_Syntax_Syntax.Tm_constant (FStar_Const.Const_reify - uu___5) -> true - | uu___5 -> false in - if uu___3 - then - (match args with - | x::[] -> FStar_Pervasives_Native.fst x - | uu___4 -> - failwith - "Impossible : Reify applied to multiple arguments after normalization.") - else t) -let (maybe_implicit_with_meta_or_attr : - FStar_Syntax_Syntax.bqual -> - FStar_Syntax_Syntax.attribute Prims.list -> Prims.bool) - = - fun aq -> - fun attrs -> - match (aq, attrs) with - | (FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta uu___), - uu___1) -> true - | (FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit uu___), - uu___1::uu___2) -> true - | uu___ -> false -let (instantiate_one_binder : - FStar_TypeChecker_Env.env_t -> - FStar_Compiler_Range_Type.range -> - FStar_Syntax_Syntax.binder -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.typ * - FStar_Syntax_Syntax.aqual * FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun r -> - fun b -> - (let uu___1 = FStar_Compiler_Debug.high () in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_binder b in - FStar_Compiler_Util.print1 - "instantiate_one_binder: Instantiating implicit binder %s\n" - uu___2 - else ()); - (let op_Plus_Plus = FStar_TypeChecker_Env.conj_guard in - let uu___1 = b in - match uu___1 with - | { FStar_Syntax_Syntax.binder_bv = x; - FStar_Syntax_Syntax.binder_qual = uu___2; - FStar_Syntax_Syntax.binder_positivity = uu___3; - FStar_Syntax_Syntax.binder_attrs = uu___4;_} -> - let uu___5 = FStar_TypeChecker_Env.uvar_meta_for_binder b in - (match uu___5 with - | (ctx_uvar_meta, should_unrefine) -> - let t = x.FStar_Syntax_Syntax.sort in - let uu___6 = - let msg = - let is_typeclass = - match ctx_uvar_meta with - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Ctx_uvar_meta_tac tau) -> - FStar_Syntax_Util.is_fvar - FStar_Parser_Const.tcresolve_lid tau - | uu___7 -> false in - if is_typeclass - then "Typeclass constraint argument" - else - if FStar_Pervasives_Native.uu___is_Some ctx_uvar_meta - then "Instantiating meta argument" - else "Instantiating implicit argument" in - FStar_TypeChecker_Env.new_implicit_var_aux msg r env t - FStar_Syntax_Syntax.Strict ctx_uvar_meta - should_unrefine in - (match uu___6 with - | (varg, uu___7, implicits) -> - let aq = FStar_Syntax_Util.aqual_of_binder b in - let arg = (varg, aq) in - let r1 = (varg, t, aq, implicits) in - ((let uu___9 = FStar_Compiler_Debug.high () in - if uu___9 - then - let uu___10 = - FStar_Class_Show.show - (FStar_Class_Show.show_tuple2 - FStar_Syntax_Print.showable_term - FStar_Syntax_Print.showable_term) - ((FStar_Pervasives_Native.__proj__Mktuple4__item___1 - r1), - (FStar_Pervasives_Native.__proj__Mktuple4__item___2 - r1)) in - FStar_Compiler_Util.print1 - "instantiate_one_binder: result = %s\n" uu___10 - else ()); - r1)))) -let (maybe_instantiate : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.typ -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.typ * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun e -> - fun t -> - let torig = FStar_Syntax_Subst.compress t in - if Prims.op_Negation env.FStar_TypeChecker_Env.instantiate_imp - then - (e, torig, - (FStar_Class_Monoid.mzero FStar_TypeChecker_Common.monoid_guard_t)) - else - ((let uu___2 = FStar_Compiler_Debug.high () in - if uu___2 - then - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term e in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - let uu___5 = - let uu___6 = FStar_TypeChecker_Env.expected_typ env in - FStar_Class_Show.show - (FStar_Class_Show.show_option - (FStar_Class_Show.show_tuple2 - FStar_Syntax_Print.showable_term - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_bool))) uu___6 in - FStar_Compiler_Util.print3 - "maybe_instantiate: starting check for (%s) of type (%s), expected type is %s\n" - uu___3 uu___4 uu___5 - else ()); - (let unfolded_arrow_formals env1 t1 = - let rec aux env2 bs t2 = - let t3 = FStar_TypeChecker_Normalize.unfold_whnf env2 t2 in - let uu___2 = FStar_Syntax_Util.arrow_formals t3 in - match uu___2 with - | (bs', t4) -> - (match bs' with - | [] -> bs - | bs'1 -> - let uu___3 = - FStar_TypeChecker_Env.push_binders env2 bs'1 in - aux uu___3 (FStar_Compiler_List.op_At bs bs'1) t4) in - aux env1 [] t1 in - let number_of_implicits t1 = - let formals = unfolded_arrow_formals env t1 in - let n_implicits = - let uu___2 = - FStar_Compiler_Util.prefix_until - (fun uu___3 -> - match uu___3 with - | { FStar_Syntax_Syntax.binder_bv = uu___4; - FStar_Syntax_Syntax.binder_qual = imp; - FStar_Syntax_Syntax.binder_positivity = uu___5; - FStar_Syntax_Syntax.binder_attrs = uu___6;_} -> - (FStar_Compiler_Option.isNone imp) || - (FStar_Syntax_Util.eq_bqual imp - (FStar_Pervasives_Native.Some - FStar_Syntax_Syntax.Equality))) formals in - match uu___2 with - | FStar_Pervasives_Native.None -> - FStar_Compiler_List.length formals - | FStar_Pervasives_Native.Some - (implicits, _first_explicit, _rest) -> - FStar_Compiler_List.length implicits in - n_implicits in - let inst_n_binders t1 = - let uu___2 = FStar_TypeChecker_Env.expected_typ env in - match uu___2 with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some (expected_t, uu___3) -> - let n_expected = number_of_implicits expected_t in - let n_available = number_of_implicits t1 in - if n_available < n_expected - then - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Errors_Msg.text "Expected a term with " in - let uu___7 = - let uu___8 = - FStar_Class_PP.pp FStar_Class_PP.pp_int - n_expected in - let uu___9 = - let uu___10 = - FStar_Errors_Msg.text - " implicit arguments, but " in - let uu___11 = - let uu___12 = - FStar_Class_PP.pp - FStar_Syntax_Print.pretty_term e in - let uu___13 = - let uu___14 = - FStar_Errors_Msg.text " has only " in - let uu___15 = - let uu___16 = - FStar_Class_PP.pp FStar_Class_PP.pp_int - n_available in - let uu___17 = FStar_Errors_Msg.text "." in - FStar_Pprint.op_Hat_Hat uu___16 uu___17 in - FStar_Pprint.op_Hat_Slash_Hat uu___14 uu___15 in - FStar_Pprint.op_Hat_Slash_Hat uu___12 uu___13 in - FStar_Pprint.op_Hat_Slash_Hat uu___10 uu___11 in - FStar_Pprint.op_Hat_Slash_Hat uu___8 uu___9 in - FStar_Pprint.op_Hat_Slash_Hat uu___6 uu___7 in - [uu___5] in - FStar_Errors.raise_error - FStar_TypeChecker_Env.hasRange_env env - FStar_Errors_Codes.Fatal_MissingImplicitArguments () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___4) - else - FStar_Pervasives_Native.Some (n_available - n_expected) in - let decr_inst uu___2 = - match uu___2 with - | FStar_Pervasives_Native.None -> FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some i -> - FStar_Pervasives_Native.Some (i - Prims.int_one) in - let t1 = FStar_TypeChecker_Normalize.unfold_whnf env t in - match t1.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; - FStar_Syntax_Syntax.comp = c;_} - -> - let uu___2 = FStar_Syntax_Subst.open_comp bs c in - (match uu___2 with - | (bs1, c1) -> - let rec aux subst inst_n bs2 = - match (inst_n, bs2) with - | (FStar_Pervasives_Native.Some uu___3, uu___4) when - uu___3 = Prims.int_zero -> - ([], bs2, subst, - FStar_TypeChecker_Env.trivial_guard) - | (uu___3, - { FStar_Syntax_Syntax.binder_bv = uu___4; - FStar_Syntax_Syntax.binder_qual = - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Implicit uu___5); - FStar_Syntax_Syntax.binder_positivity = uu___6; - FStar_Syntax_Syntax.binder_attrs = uu___7;_}::rest) - -> - let b = FStar_Compiler_List.hd bs2 in - let b1 = FStar_Syntax_Subst.subst_binder subst b in - let uu___8 = - instantiate_one_binder env - e.FStar_Syntax_Syntax.pos b1 in - (match uu___8 with - | (tm, ty, aq, g) -> - let subst1 = - (FStar_Syntax_Syntax.NT - ((b1.FStar_Syntax_Syntax.binder_bv), tm)) - :: subst in - let uu___9 = - aux subst1 (decr_inst inst_n) rest in - (match uu___9 with - | (args, bs3, subst2, g') -> - let uu___10 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g g' in - (((tm, aq) :: args), bs3, subst2, - uu___10))) - | (uu___3, - { FStar_Syntax_Syntax.binder_bv = uu___4; - FStar_Syntax_Syntax.binder_qual = - FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Meta uu___5); - FStar_Syntax_Syntax.binder_positivity = uu___6; - FStar_Syntax_Syntax.binder_attrs = uu___7;_}::rest) - -> - let b = FStar_Compiler_List.hd bs2 in - let b1 = FStar_Syntax_Subst.subst_binder subst b in - let uu___8 = - instantiate_one_binder env - e.FStar_Syntax_Syntax.pos b1 in - (match uu___8 with - | (tm, ty, aq, g) -> - let subst1 = - (FStar_Syntax_Syntax.NT - ((b1.FStar_Syntax_Syntax.binder_bv), tm)) - :: subst in - let uu___9 = - aux subst1 (decr_inst inst_n) rest in - (match uu___9 with - | (args, bs3, subst2, g') -> - let uu___10 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g g' in - (((tm, aq) :: args), bs3, subst2, - uu___10))) - | (uu___3, - { FStar_Syntax_Syntax.binder_bv = uu___4; - FStar_Syntax_Syntax.binder_qual = uu___5; - FStar_Syntax_Syntax.binder_positivity = uu___6; - FStar_Syntax_Syntax.binder_attrs = uu___7::uu___8;_}::rest) - -> - let b = FStar_Compiler_List.hd bs2 in - let b1 = FStar_Syntax_Subst.subst_binder subst b in - let uu___9 = - instantiate_one_binder env - e.FStar_Syntax_Syntax.pos b1 in - (match uu___9 with - | (tm, ty, aq, g) -> - let subst1 = - (FStar_Syntax_Syntax.NT - ((b1.FStar_Syntax_Syntax.binder_bv), tm)) - :: subst in - let uu___10 = - aux subst1 (decr_inst inst_n) rest in - (match uu___10 with - | (args, bs3, subst2, g') -> - let uu___11 = - FStar_Class_Monoid.op_Plus_Plus - FStar_TypeChecker_Common.monoid_guard_t - g g' in - (((tm, aq) :: args), bs3, subst2, - uu___11))) - | (uu___3, bs3) -> - ([], bs3, subst, - (FStar_Class_Monoid.mzero - FStar_TypeChecker_Common.monoid_guard_t)) in - let uu___3 = - let uu___4 = inst_n_binders t1 in aux [] uu___4 bs1 in - (match uu___3 with - | (args, bs2, subst, guard) -> - (match (args, bs2) with - | ([], uu___4) -> (e, torig, guard) - | (uu___4, []) when - let uu___5 = - FStar_Syntax_Util.is_total_comp c1 in - Prims.op_Negation uu___5 -> - (e, torig, - FStar_TypeChecker_Env.trivial_guard) - | uu___4 -> - let t2 = - match bs2 with - | [] -> FStar_Syntax_Util.comp_result c1 - | uu___5 -> FStar_Syntax_Util.arrow bs2 c1 in - let t3 = FStar_Syntax_Subst.subst subst t2 in - let e1 = - FStar_Syntax_Syntax.mk_Tm_app e args - e.FStar_Syntax_Syntax.pos in - (e1, t3, guard)))) - | uu___2 -> (e, torig, FStar_TypeChecker_Env.trivial_guard))) -let (check_has_type : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.typ -> - Prims.bool -> FStar_TypeChecker_Env.guard_t) - = - fun env -> - fun e -> - fun t1 -> - fun t2 -> - fun use_eq -> - let env1 = - FStar_TypeChecker_Env.set_range env e.FStar_Syntax_Syntax.pos in - let g_opt = - if env1.FStar_TypeChecker_Env.use_eq_strict - then - let uu___ = FStar_TypeChecker_Rel.teq_nosmt_force env1 t1 t2 in - (if uu___ - then - FStar_Pervasives_Native.Some - FStar_TypeChecker_Env.trivial_guard - else FStar_Pervasives_Native.None) - else - if use_eq - then FStar_TypeChecker_Rel.try_teq true env1 t1 t2 - else - (let uu___2 = - FStar_TypeChecker_Rel.get_subtyping_predicate env1 t1 t2 in - match uu___2 with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some f -> - let uu___3 = FStar_TypeChecker_Env.apply_guard f e in - FStar_Pervasives_Native.Some uu___3) in - match g_opt with - | FStar_Pervasives_Native.None -> - let uu___ = FStar_TypeChecker_Env.get_range env1 in - FStar_TypeChecker_Err.expected_expression_of_type env1 uu___ - t2 e t1 - | FStar_Pervasives_Native.Some g -> g -let (check_has_type_maybe_coerce : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.term -> - FStar_TypeChecker_Common.lcomp -> - FStar_Syntax_Syntax.typ -> - Prims.bool -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Common.lcomp * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun e -> - fun lc -> - fun t2 -> - fun use_eq -> - let env1 = - FStar_TypeChecker_Env.set_range env e.FStar_Syntax_Syntax.pos in - let uu___ = maybe_coerce_lc env1 e lc t2 in - match uu___ with - | (e1, lc1, g_c) -> - let g = - check_has_type env1 e1 lc1.FStar_TypeChecker_Common.res_typ - t2 use_eq in - ((let uu___2 = FStar_Compiler_Effect.op_Bang dbg_Rel in - if uu___2 - then - let uu___3 = FStar_TypeChecker_Rel.guard_to_string env1 g in - FStar_Compiler_Util.print1 "Applied guard is %s\n" uu___3 - else ()); - (let uu___2 = FStar_TypeChecker_Env.conj_guard g g_c in - (e1, lc1, uu___2))) -let (check_top_level : - FStar_TypeChecker_Env.env -> - FStar_TypeChecker_Env.guard_t -> - FStar_TypeChecker_Common.lcomp -> - (Prims.bool * FStar_Syntax_Syntax.comp)) - = - fun env -> - fun g -> - fun lc -> - FStar_Errors.with_ctx "While checking for top-level effects" - (fun uu___ -> - (let uu___2 = FStar_Compiler_Debug.medium () in - if uu___2 - then - let uu___3 = FStar_TypeChecker_Common.lcomp_to_string lc in - FStar_Compiler_Util.print1 "check_top_level, lc = %s\n" - uu___3 - else ()); - (let discharge g1 = - FStar_TypeChecker_Rel.force_trivial_guard env g1; - FStar_TypeChecker_Common.is_pure_lcomp lc in - let g1 = FStar_TypeChecker_Rel.solve_deferred_constraints env g in - let uu___2 = FStar_TypeChecker_Common.lcomp_comp lc in - match uu___2 with - | (c, g_c) -> - let uu___3 = FStar_TypeChecker_Common.is_total_lcomp lc in - if uu___3 - then - let uu___4 = - let uu___5 = FStar_TypeChecker_Env.conj_guard g1 g_c in - discharge uu___5 in - (uu___4, c) - else - (let c1 = - FStar_TypeChecker_Env.unfold_effect_abbrev env c in - let us = c1.FStar_Syntax_Syntax.comp_univs in - let uu___5 = - FStar_TypeChecker_Env.is_layered_effect env - c1.FStar_Syntax_Syntax.effect_name in - if uu___5 - then - let c_eff = c1.FStar_Syntax_Syntax.effect_name in - let ret_comp = FStar_Syntax_Syntax.mk_Comp c1 in - let steps = - [FStar_TypeChecker_Env.Eager_unfolding; - FStar_TypeChecker_Env.Simplify; - FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.NoFullNorm] in - let c2 = - let uu___6 = FStar_Syntax_Syntax.mk_Comp c1 in - FStar_TypeChecker_Normalize.normalize_comp steps env - uu___6 in - let top_level_eff_opt = - FStar_TypeChecker_Env.get_top_level_effect env c_eff in - match top_level_eff_opt with - | FStar_Pervasives_Native.None -> - let uu___6 = FStar_TypeChecker_Env.get_range env in - let uu___7 = - let uu___8 = FStar_Ident.string_of_lid c_eff in - FStar_Compiler_Util.format1 - "Indexed effect %s cannot be used as a top-level effect" - uu___8 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range uu___6 - FStar_Errors_Codes.Fatal_UnexpectedEffect () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___7) - | FStar_Pervasives_Native.Some top_level_eff -> - let uu___6 = - FStar_Ident.lid_equals top_level_eff c_eff in - (if uu___6 - then - let uu___7 = discharge g_c in - (uu___7, ret_comp) - else - (let bc_opt = - FStar_TypeChecker_Env.lookup_effect_abbrev - env us top_level_eff in - match bc_opt with - | FStar_Pervasives_Native.None -> - let uu___8 = - let uu___9 = - FStar_Ident.string_of_lid - top_level_eff in - let uu___10 = - FStar_Ident.string_of_lid c_eff in - FStar_Compiler_Util.format2 - "Could not find top-level effect abbreviation %s for %s" - uu___9 uu___10 in - FStar_Errors.raise_error - FStar_TypeChecker_Env.hasRange_env env - FStar_Errors_Codes.Fatal_UnexpectedEffect - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___8) - | FStar_Pervasives_Native.Some (bs, uu___8) -> - let debug = - FStar_Compiler_Effect.op_Bang - dbg_LayeredEffectsApp in - let uu___9 = - FStar_Syntax_Subst.open_binders bs in - (match uu___9 with - | a::bs1 -> - let uu___10 = - let uu___11 = - FStar_TypeChecker_Env.get_range - env in - FStar_TypeChecker_Env.uvars_for_binders - env bs1 - [FStar_Syntax_Syntax.NT - ((a.FStar_Syntax_Syntax.binder_bv), - (FStar_Syntax_Util.comp_result - c2))] - (fun b -> - if debug - then - let uu___12 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_binder - b in - let uu___13 = - FStar_Ident.string_of_lid - top_level_eff in - FStar_Compiler_Util.format2 - "implicit for binder %s in effect abbreviation %s while checking top-level effect" - uu___12 uu___13 - else "check_top_level") - uu___11 in - (match uu___10 with - | (uvs, g_uvs) -> - let top_level_comp = - let uu___11 = - let uu___12 = - FStar_Compiler_List.map - FStar_Syntax_Syntax.as_arg - uvs in - { - FStar_Syntax_Syntax.comp_univs - = us; - FStar_Syntax_Syntax.effect_name - = top_level_eff; - FStar_Syntax_Syntax.result_typ - = - (FStar_Syntax_Util.comp_result - c2); - FStar_Syntax_Syntax.effect_args - = uu___12; - FStar_Syntax_Syntax.flags - = [] - } in - FStar_Syntax_Syntax.mk_Comp - uu___11 in - let gopt = - FStar_TypeChecker_Rel.eq_comp - env top_level_comp c2 in - (match gopt with - | FStar_Pervasives_Native.None - -> - let uu___11 = - let uu___12 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_comp - top_level_comp in - let uu___13 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_comp - c2 in - FStar_Compiler_Util.format2 - "Could not unify %s and %s when checking top-level effect" - uu___12 uu___13 in - FStar_Errors.raise_error - FStar_TypeChecker_Env.hasRange_env - env - FStar_Errors_Codes.Fatal_UnexpectedEffect - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___11) - | FStar_Pervasives_Native.Some - g2 -> - let uu___11 = - let uu___12 = - FStar_TypeChecker_Env.conj_guards - [g_c; g_uvs; g2] in - discharge uu___12 in - (uu___11, ret_comp)))))) - else - (let steps = - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.NoFullNorm; - FStar_TypeChecker_Env.DoNotUnfoldPureLets] in - let c2 = - let uu___7 = FStar_Syntax_Syntax.mk_Comp c1 in - FStar_TypeChecker_Normalize.normalize_comp steps - env uu___7 in - let uu___7 = check_trivial_precondition_wp env c2 in - match uu___7 with - | (ct, vc, g_pre) -> - ((let uu___9 = - FStar_Compiler_Effect.op_Bang - dbg_Simplification in - if uu___9 - then - let uu___10 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term vc in - FStar_Compiler_Util.print1 - "top-level VC: %s\n" uu___10 - else ()); - (let uu___9 = - let uu___10 = - let uu___11 = - FStar_TypeChecker_Env.conj_guard g_c - g_pre in - FStar_TypeChecker_Env.conj_guard g1 uu___11 in - discharge uu___10 in - let uu___10 = FStar_Syntax_Syntax.mk_Comp ct in - (uu___9, uu___10))))))) -let (short_circuit : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.args -> FStar_TypeChecker_Common.guard_formula) - = - fun head -> - fun seen_args -> - let short_bin_op f uu___ = - match uu___ with - | [] -> FStar_TypeChecker_Common.Trivial - | (fst, uu___1)::[] -> f fst - | uu___1 -> failwith "Unexpected args to binary operator" in - let op_and_e e = - let uu___ = FStar_Syntax_Util.b2t e in - FStar_TypeChecker_Common.NonTrivial uu___ in - let op_or_e e = - let uu___ = - let uu___1 = FStar_Syntax_Util.b2t e in - FStar_Syntax_Util.mk_neg uu___1 in - FStar_TypeChecker_Common.NonTrivial uu___ in - let op_and_t t = FStar_TypeChecker_Common.NonTrivial t in - let op_or_t t = - let uu___ = FStar_Syntax_Util.mk_neg t in - FStar_TypeChecker_Common.NonTrivial uu___ in - let op_imp_t t = FStar_TypeChecker_Common.NonTrivial t in - let short_op_ite uu___ = - match uu___ with - | [] -> FStar_TypeChecker_Common.Trivial - | (guard, uu___1)::[] -> FStar_TypeChecker_Common.NonTrivial guard - | _then::(guard, uu___1)::[] -> - let uu___2 = FStar_Syntax_Util.mk_neg guard in - FStar_TypeChecker_Common.NonTrivial uu___2 - | uu___1 -> failwith "Unexpected args to ITE" in - let table = - let uu___ = - let uu___1 = short_bin_op op_and_e in - (FStar_Parser_Const.op_And, uu___1) in - let uu___1 = - let uu___2 = - let uu___3 = short_bin_op op_or_e in - (FStar_Parser_Const.op_Or, uu___3) in - let uu___3 = - let uu___4 = - let uu___5 = short_bin_op op_and_t in - (FStar_Parser_Const.and_lid, uu___5) in - let uu___5 = - let uu___6 = - let uu___7 = short_bin_op op_or_t in - (FStar_Parser_Const.or_lid, uu___7) in - let uu___7 = - let uu___8 = - let uu___9 = short_bin_op op_imp_t in - (FStar_Parser_Const.imp_lid, uu___9) in - [uu___8; (FStar_Parser_Const.ite_lid, short_op_ite)] in - uu___6 :: uu___7 in - uu___4 :: uu___5 in - uu___2 :: uu___3 in - uu___ :: uu___1 in - match head.FStar_Syntax_Syntax.n with - | FStar_Syntax_Syntax.Tm_fvar fv -> - let lid = (fv.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - let uu___ = - FStar_Compiler_Util.find_map table - (fun uu___1 -> - match uu___1 with - | (x, mk) -> - let uu___2 = FStar_Ident.lid_equals x lid in - if uu___2 - then - let uu___3 = mk seen_args in - FStar_Pervasives_Native.Some uu___3 - else FStar_Pervasives_Native.None) in - (match uu___ with - | FStar_Pervasives_Native.None -> FStar_TypeChecker_Common.Trivial - | FStar_Pervasives_Native.Some g -> g) - | uu___ -> FStar_TypeChecker_Common.Trivial -let (short_circuit_head : FStar_Syntax_Syntax.term -> Prims.bool) = - fun l -> - let uu___ = - let uu___1 = FStar_Syntax_Util.un_uinst l in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_fvar fv -> - FStar_Compiler_Util.for_some (FStar_Syntax_Syntax.fv_eq_lid fv) - [FStar_Parser_Const.op_And; - FStar_Parser_Const.op_Or; - FStar_Parser_Const.and_lid; - FStar_Parser_Const.or_lid; - FStar_Parser_Const.imp_lid; - FStar_Parser_Const.ite_lid] - | uu___1 -> false -let (maybe_add_implicit_binders : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.binders -> FStar_Syntax_Syntax.binders) - = - fun env -> - fun bs -> - let is_implicit_binder uu___ = - match uu___ with - | { FStar_Syntax_Syntax.binder_bv = uu___1; - FStar_Syntax_Syntax.binder_qual = q; - FStar_Syntax_Syntax.binder_positivity = uu___2; - FStar_Syntax_Syntax.binder_attrs = uu___3;_} -> - (match q with - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Implicit - uu___4) -> true - | FStar_Pervasives_Native.Some (FStar_Syntax_Syntax.Meta uu___4) - -> true - | uu___4 -> false) in - let pos bs1 = - match bs1 with - | { FStar_Syntax_Syntax.binder_bv = hd; - FStar_Syntax_Syntax.binder_qual = uu___; - FStar_Syntax_Syntax.binder_positivity = uu___1; - FStar_Syntax_Syntax.binder_attrs = uu___2;_}::uu___3 -> - FStar_Syntax_Syntax.range_of_bv hd - | uu___ -> FStar_TypeChecker_Env.get_range env in - match bs with - | b::uu___ when is_implicit_binder b -> bs - | uu___ -> - let uu___1 = FStar_TypeChecker_Env.expected_typ env in - (match uu___1 with - | FStar_Pervasives_Native.None -> bs - | FStar_Pervasives_Native.Some (t, uu___2) -> - let uu___3 = - let uu___4 = FStar_Syntax_Subst.compress t in - uu___4.FStar_Syntax_Syntax.n in - (match uu___3 with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs'; - FStar_Syntax_Syntax.comp = uu___4;_} - -> - let uu___5 = - FStar_Compiler_Util.prefix_until - (fun b -> - let uu___6 = is_implicit_binder b in - Prims.op_Negation uu___6) bs' in - (match uu___5 with - | FStar_Pervasives_Native.None -> bs - | FStar_Pervasives_Native.Some ([], uu___6, uu___7) -> - bs - | FStar_Pervasives_Native.Some (imps, uu___6, uu___7) -> - let r = pos bs in - let imps1 = - FStar_Compiler_List.map - (fun b -> - let uu___8 = - FStar_Syntax_Syntax.set_range_of_bv - b.FStar_Syntax_Syntax.binder_bv r in - { - FStar_Syntax_Syntax.binder_bv = uu___8; - FStar_Syntax_Syntax.binder_qual = - (b.FStar_Syntax_Syntax.binder_qual); - FStar_Syntax_Syntax.binder_positivity = - (b.FStar_Syntax_Syntax.binder_positivity); - FStar_Syntax_Syntax.binder_attrs = - (b.FStar_Syntax_Syntax.binder_attrs) - }) imps in - FStar_Compiler_List.op_At imps1 bs) - | uu___4 -> bs)) -let (must_erase_for_extraction : - FStar_TypeChecker_Env.env -> FStar_Syntax_Syntax.term -> Prims.bool) = - fun g -> - fun t -> - let rec descend env t1 = - let uu___ = - let uu___1 = FStar_Syntax_Subst.compress t1 in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_arrow uu___1 -> - let uu___2 = FStar_Syntax_Util.arrow_formals_comp t1 in - (match uu___2 with - | (bs, c) -> - let env1 = FStar_TypeChecker_Env.push_binders env bs in - (FStar_TypeChecker_Env.is_erasable_effect env1 - (FStar_Syntax_Util.comp_effect_name c)) - || - ((FStar_Syntax_Util.is_pure_or_ghost_comp c) && - (aux env1 (FStar_Syntax_Util.comp_result c)))) - | FStar_Syntax_Syntax.Tm_refine - { - FStar_Syntax_Syntax.b = - { FStar_Syntax_Syntax.ppname = uu___1; - FStar_Syntax_Syntax.index = uu___2; - FStar_Syntax_Syntax.sort = t2;_}; - FStar_Syntax_Syntax.phi = uu___3;_} - -> aux env t2 - | FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = head; - FStar_Syntax_Syntax.args = uu___1;_} - -> descend env head - | FStar_Syntax_Syntax.Tm_uinst (head, uu___1) -> descend env head - | FStar_Syntax_Syntax.Tm_fvar fv -> - FStar_TypeChecker_Env.fv_has_attr env fv - FStar_Parser_Const.must_erase_for_extraction_attr - | uu___1 -> false - and aux env t1 = - let t2 = - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.Weak; - FStar_TypeChecker_Env.HNF; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.AllowUnboundUniverses; - FStar_TypeChecker_Env.Zeta; - FStar_TypeChecker_Env.Iota; - FStar_TypeChecker_Env.Unascribe] env t1 in - let res = - (FStar_TypeChecker_Env.non_informative env t2) || (descend env t2) in - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_Extraction in - if uu___1 - then - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t2 in - FStar_Compiler_Util.print2 "must_erase=%s: %s\n" - (if res then "true" else "false") uu___2 - else ()); - res in - aux g t -let (effect_extraction_mode : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident -> FStar_Syntax_Syntax.eff_extraction_mode) - = - fun env -> - fun l -> - let uu___ = - let uu___1 = FStar_TypeChecker_Env.norm_eff_name env l in - FStar_TypeChecker_Env.get_effect_decl env uu___1 in - uu___.FStar_Syntax_Syntax.extraction_mode -let (fresh_effect_repr : - FStar_TypeChecker_Env.env -> - FStar_Compiler_Range_Type.range -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.tscheme -> - FStar_Syntax_Syntax.tscheme FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun r -> - fun eff_name -> - fun signature_ts -> - fun repr_ts_opt -> - fun u -> - fun a_tm -> - let fail t = - FStar_TypeChecker_Err.unexpected_signature_for_monad env r - eff_name t in - let uu___ = FStar_TypeChecker_Env.inst_tscheme signature_ts in - match uu___ with - | (uu___1, signature) -> - let debug = - FStar_Compiler_Effect.op_Bang dbg_LayeredEffectsApp in - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress signature in - uu___3.FStar_Syntax_Syntax.n in - (match uu___2 with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; - FStar_Syntax_Syntax.comp = uu___3;_} - -> - let bs1 = FStar_Syntax_Subst.open_binders bs in - (match bs1 with - | a::bs2 -> - let uu___4 = - FStar_TypeChecker_Env.uvars_for_binders env - bs2 - [FStar_Syntax_Syntax.NT - ((a.FStar_Syntax_Syntax.binder_bv), - a_tm)] - (fun b -> - if debug - then - let uu___5 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_binder - b in - let uu___6 = - FStar_Ident.string_of_lid eff_name in - let uu___7 = - FStar_Compiler_Range_Ops.string_of_range - r in - FStar_Compiler_Util.format3 - "uvar for binder %s when creating a fresh repr for %s at %s" - uu___5 uu___6 uu___7 - else "fresh_effect_repr") r in - (match uu___4 with - | (is, g) -> - let uu___5 = - match repr_ts_opt with - | FStar_Pervasives_Native.None -> - let eff_c = - let uu___6 = - let uu___7 = - FStar_Compiler_List.map - FStar_Syntax_Syntax.as_arg - is in - { - FStar_Syntax_Syntax.comp_univs - = [u]; - FStar_Syntax_Syntax.effect_name - = eff_name; - FStar_Syntax_Syntax.result_typ - = a_tm; - FStar_Syntax_Syntax.effect_args - = uu___7; - FStar_Syntax_Syntax.flags = [] - } in - FStar_Syntax_Syntax.mk_Comp uu___6 in - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Syntax_Syntax.null_binder - FStar_Syntax_Syntax.t_unit in - [uu___9] in - { - FStar_Syntax_Syntax.bs1 = - uu___8; - FStar_Syntax_Syntax.comp = - eff_c - } in - FStar_Syntax_Syntax.Tm_arrow - uu___7 in - FStar_Syntax_Syntax.mk uu___6 r - | FStar_Pervasives_Native.Some repr_ts - -> - let repr = - let uu___6 = - FStar_TypeChecker_Env.inst_tscheme_with - repr_ts [u] in - FStar_Pervasives_Native.snd uu___6 in - let is_args = - FStar_Compiler_List.map2 - (fun i -> - fun b -> - let uu___6 = - FStar_Syntax_Util.aqual_of_binder - b in - (i, uu___6)) is bs2 in - let uu___6 = - let uu___7 = - FStar_Syntax_Syntax.as_arg a_tm in - uu___7 :: is_args in - FStar_Syntax_Syntax.mk_Tm_app repr - uu___6 r in - (uu___5, g)) - | uu___4 -> fail signature) - | uu___3 -> fail signature) -let (fresh_effect_repr_en : - FStar_TypeChecker_Env.env -> - FStar_Compiler_Range_Type.range -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.term -> - (FStar_Syntax_Syntax.term * FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun r -> - fun eff_name -> - fun u -> - fun a_tm -> - let uu___ = FStar_TypeChecker_Env.get_effect_decl env eff_name in - let uu___1 = - FStar_Syntax_Util.effect_sig_ts - uu___.FStar_Syntax_Syntax.signature in - let uu___2 = FStar_Syntax_Util.get_eff_repr uu___ in - fresh_effect_repr env r eff_name uu___1 uu___2 u a_tm -let (layered_effect_indices_as_binders : - FStar_TypeChecker_Env.env -> - FStar_Compiler_Range_Type.range -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.tscheme -> - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.binders) - = - fun env -> - fun r -> - fun eff_name -> - fun sig_ts -> - fun u -> - fun a_tm -> - let uu___ = FStar_TypeChecker_Env.inst_tscheme_with sig_ts [u] in - match uu___ with - | (uu___1, sig_tm) -> - let fail t = - FStar_TypeChecker_Err.unexpected_signature_for_monad env - r eff_name t in - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress sig_tm in - uu___3.FStar_Syntax_Syntax.n in - (match uu___2 with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; - FStar_Syntax_Syntax.comp = uu___3;_} - -> - let bs1 = FStar_Syntax_Subst.open_binders bs in - (match bs1 with - | { FStar_Syntax_Syntax.binder_bv = a'; - FStar_Syntax_Syntax.binder_qual = uu___4; - FStar_Syntax_Syntax.binder_positivity = uu___5; - FStar_Syntax_Syntax.binder_attrs = uu___6;_}::bs2 - -> - FStar_Syntax_Subst.subst_binders - [FStar_Syntax_Syntax.NT (a', a_tm)] bs2 - | uu___4 -> fail sig_tm) - | uu___3 -> fail sig_tm) -let (check_non_informative_type_for_lift : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.term -> FStar_Compiler_Range_Type.range -> unit) - = - fun env -> - fun m1 -> - fun m2 -> - fun t -> - fun r -> - let uu___ = - ((FStar_TypeChecker_Env.is_erasable_effect env m1) && - (let uu___1 = - FStar_TypeChecker_Env.is_erasable_effect env m2 in - Prims.op_Negation uu___1)) - && - (let uu___1 = FStar_TypeChecker_Normalize.non_info_norm env t in - Prims.op_Negation uu___1) in - if uu___ - then - let uu___1 = - let uu___2 = FStar_Ident.string_of_lid m1 in - let uu___3 = FStar_Ident.string_of_lid m2 in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t in - FStar_Compiler_Util.format3 - "Cannot lift erasable expression from %s ~> %s since its type %s is informative" - uu___2 uu___3 uu___4 in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range r - FStar_Errors_Codes.Error_TypeError () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) - else () -let (substitutive_indexed_lift_substs : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.comp_typ -> - Prims.string -> - FStar_Compiler_Range_Type.range -> - (FStar_Syntax_Syntax.subst_elt Prims.list * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun bs -> - fun ct -> - fun lift_name -> - fun r -> - let debug = FStar_Compiler_Effect.op_Bang dbg_LayeredEffectsApp in - let uu___ = - let uu___1 = bs in - match uu___1 with - | a_b::bs1 -> - (bs1, - [FStar_Syntax_Syntax.NT - ((a_b.FStar_Syntax_Syntax.binder_bv), - (ct.FStar_Syntax_Syntax.result_typ))]) in - match uu___ with - | (bs1, subst) -> - let uu___1 = - let m_num_effect_args = - FStar_Compiler_List.length - ct.FStar_Syntax_Syntax.effect_args in - let uu___2 = - FStar_Compiler_List.splitAt m_num_effect_args bs1 in - match uu___2 with - | (f_bs, bs2) -> - let f_subst = - FStar_Compiler_List.map2 - (fun f_b -> - fun uu___3 -> - match uu___3 with - | (arg, uu___4) -> - FStar_Syntax_Syntax.NT - ((f_b.FStar_Syntax_Syntax.binder_bv), - arg)) f_bs - ct.FStar_Syntax_Syntax.effect_args in - (bs2, (FStar_Compiler_List.op_At subst f_subst)) in - (match uu___1 with - | (bs2, subst1) -> - let bs3 = - let uu___2 = - FStar_Compiler_List.splitAt - ((FStar_Compiler_List.length bs2) - Prims.int_one) - bs2 in - FStar_Pervasives_Native.fst uu___2 in - FStar_Compiler_List.fold_left - (fun uu___2 -> - fun b -> - match uu___2 with - | (subst2, g) -> - let uu___3 = - FStar_TypeChecker_Env.uvars_for_binders env - [b] subst2 - (fun b1 -> - if debug - then - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_binder - b1 in - let uu___5 = - FStar_Compiler_Range_Ops.string_of_range - r in - FStar_Compiler_Util.format3 - "implicit var for additional lift binder %s of %s at %s)" - uu___4 lift_name uu___5 - else - "substitutive_indexed_lift_substs") - r in - (match uu___3 with - | (uv_t::[], g_uv) -> - let uu___4 = - FStar_TypeChecker_Env.conj_guard g - g_uv in - ((FStar_Compiler_List.op_At subst2 - [FStar_Syntax_Syntax.NT - ((b.FStar_Syntax_Syntax.binder_bv), - uv_t)]), uu___4))) - (subst1, FStar_TypeChecker_Env.trivial_guard) bs3) -let (ad_hoc_indexed_lift_substs : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.binders -> - FStar_Syntax_Syntax.comp_typ -> - Prims.string -> - FStar_Compiler_Range_Type.range -> - (FStar_Syntax_Syntax.subst_elt Prims.list * - FStar_TypeChecker_Env.guard_t)) - = - fun env -> - fun bs -> - fun ct -> - fun lift_name -> - fun r -> - let debug = FStar_Compiler_Effect.op_Bang dbg_LayeredEffectsApp in - let lift_t_shape_error s = - FStar_Compiler_Util.format2 - "Lift %s has unexpected shape, reason: %s" lift_name s in - let uu___ = - if (FStar_Compiler_List.length bs) >= (Prims.of_int (2)) - then - let uu___1 = bs in - match uu___1 with - | a_b::bs1 -> - let uu___2 = - FStar_Compiler_List.splitAt - ((FStar_Compiler_List.length bs1) - Prims.int_one) - bs1 in - (a_b, uu___2) - else - (let uu___2 = - lift_t_shape_error - "either not an arrow or not enough binders" in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range - r FStar_Errors_Codes.Fatal_UnexpectedEffect () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2)) in - match uu___ with - | (a_b, (rest_bs, f_b::[])) -> - let uu___1 = - FStar_TypeChecker_Env.uvars_for_binders env rest_bs - [FStar_Syntax_Syntax.NT - ((a_b.FStar_Syntax_Syntax.binder_bv), - (ct.FStar_Syntax_Syntax.result_typ))] - (fun b -> - if debug - then - let uu___2 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_binder b in - let uu___3 = - FStar_Compiler_Range_Ops.string_of_range r in - FStar_Compiler_Util.format3 - "implicit var for binder %s of %s at %s" uu___2 - lift_name uu___3 - else "ad_hoc_indexed_lift_substs") r in - (match uu___1 with - | (rest_bs_uvars, g) -> - let substs = - FStar_Compiler_List.map2 - (fun b -> - fun t -> - FStar_Syntax_Syntax.NT - ((b.FStar_Syntax_Syntax.binder_bv), t)) (a_b - :: rest_bs) ((ct.FStar_Syntax_Syntax.result_typ) :: - rest_bs_uvars) in - let guard_f = - let f_sort = - let uu___2 = - FStar_Syntax_Subst.subst substs - (f_b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort in - FStar_Syntax_Subst.compress uu___2 in - let f_sort_is = - let uu___2 = - FStar_TypeChecker_Env.is_layered_effect env - ct.FStar_Syntax_Syntax.effect_name in - effect_args_from_repr f_sort uu___2 r in - let uu___2 = - FStar_Compiler_List.map FStar_Pervasives_Native.fst - ct.FStar_Syntax_Syntax.effect_args in - FStar_Compiler_List.fold_left2 - (fun g1 -> - fun i1 -> - fun i2 -> - let uu___3 = - FStar_TypeChecker_Rel.layered_effect_teq - env i1 i2 - (FStar_Pervasives_Native.Some lift_name) in - FStar_TypeChecker_Env.conj_guard g1 uu___3) - FStar_TypeChecker_Env.trivial_guard uu___2 f_sort_is in - let uu___2 = FStar_TypeChecker_Env.conj_guard g guard_f in - (substs, uu___2)) -let (lift_tf_layered_effect : - FStar_Ident.lident -> - FStar_Syntax_Syntax.tscheme -> - FStar_Syntax_Syntax.indexed_effect_combinator_kind -> - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.comp -> - (FStar_Syntax_Syntax.comp * FStar_TypeChecker_Env.guard_t)) - = - fun tgt -> - fun lift_ts -> - fun kind -> - fun env -> - fun c -> - let debug = FStar_Compiler_Effect.op_Bang dbg_LayeredEffectsApp in - if debug - then - (let uu___1 = - FStar_Class_Show.show FStar_Syntax_Print.showable_comp c in - let uu___2 = - FStar_Class_Show.show FStar_Ident.showable_lident tgt in - FStar_Compiler_Util.print2 - "Lifting indexed comp %s to %s {\n" uu___1 uu___2) - else (); - (let r = FStar_TypeChecker_Env.get_range env in - let ct = FStar_TypeChecker_Env.comp_to_comp_typ env c in - check_non_informative_type_for_lift env - ct.FStar_Syntax_Syntax.effect_name tgt - ct.FStar_Syntax_Syntax.result_typ r; - (let lift_name uu___2 = - if debug - then - let uu___3 = - FStar_Ident.string_of_lid - ct.FStar_Syntax_Syntax.effect_name in - let uu___4 = FStar_Ident.string_of_lid tgt in - FStar_Compiler_Util.format2 "%s ~> %s" uu___3 uu___4 - else "" in - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Compiler_List.hd ct.FStar_Syntax_Syntax.comp_univs in - [uu___4] in - FStar_TypeChecker_Env.inst_tscheme_with lift_ts uu___3 in - match uu___2 with - | (uu___3, lift_t) -> - let uu___4 = FStar_Syntax_Util.arrow_formals_comp lift_t in - (match uu___4 with - | (bs, lift_c) -> - let uu___5 = - if kind = FStar_Syntax_Syntax.Ad_hoc_combinator - then - let uu___6 = lift_name () in - ad_hoc_indexed_lift_substs env bs ct uu___6 r - else - (let uu___7 = lift_name () in - substitutive_indexed_lift_substs env bs ct uu___7 - r) in - (match uu___5 with - | (substs, g) -> - let lift_ct = - let uu___6 = - FStar_Syntax_Subst.subst_comp substs lift_c in - FStar_TypeChecker_Env.comp_to_comp_typ env - uu___6 in - let is = - let uu___6 = - FStar_TypeChecker_Env.is_layered_effect env - tgt in - effect_args_from_repr - lift_ct.FStar_Syntax_Syntax.result_typ uu___6 - r in - let fml = - let uu___6 = - let uu___7 = - FStar_Compiler_List.hd - lift_ct.FStar_Syntax_Syntax.comp_univs in - let uu___8 = - let uu___9 = - FStar_Compiler_List.hd - lift_ct.FStar_Syntax_Syntax.effect_args in - FStar_Pervasives_Native.fst uu___9 in - (uu___7, uu___8) in - match uu___6 with - | (u, wp) -> - FStar_TypeChecker_Env.pure_precondition_for_trivial_post - env u - lift_ct.FStar_Syntax_Syntax.result_typ wp - FStar_Compiler_Range_Type.dummyRange in - ((let uu___7 = - (FStar_Compiler_Effect.op_Bang - dbg_LayeredEffects) - && (FStar_Compiler_Debug.extreme ()) in - if uu___7 - then - let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term fml in - FStar_Compiler_Util.print1 - "Guard for lift is: %s" uu___8 - else ()); - (let c1 = - let uu___7 = - let uu___8 = - FStar_Compiler_List.map - FStar_Syntax_Syntax.as_arg is in - { - FStar_Syntax_Syntax.comp_univs = - (ct.FStar_Syntax_Syntax.comp_univs); - FStar_Syntax_Syntax.effect_name = tgt; - FStar_Syntax_Syntax.result_typ = - (ct.FStar_Syntax_Syntax.result_typ); - FStar_Syntax_Syntax.effect_args = uu___8; - FStar_Syntax_Syntax.flags = [] - } in - FStar_Syntax_Syntax.mk_Comp uu___7 in - if debug - then - (let uu___8 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_comp c1 in - FStar_Compiler_Util.print1 - "} Lifted comp: %s\n" uu___8) - else (); - (let g1 = - let uu___8 = - let uu___9 = - let uu___10 = - FStar_TypeChecker_Env.guard_of_guard_formula - (FStar_TypeChecker_Common.NonTrivial - fml) in - [uu___10] in - g :: uu___9 in - FStar_TypeChecker_Env.conj_guards uu___8 in - (c1, g1)))))))) -let lift_tf_layered_effect_term : - 'uuuuu . - 'uuuuu -> - FStar_Syntax_Syntax.sub_eff -> - FStar_Syntax_Syntax.universe -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term - = - fun env -> - fun sub -> - fun u -> - fun a -> - fun e -> - let lift = - let uu___ = - let uu___1 = - FStar_Compiler_Util.must sub.FStar_Syntax_Syntax.lift in - FStar_TypeChecker_Env.inst_tscheme_with uu___1 [u] in - FStar_Pervasives_Native.snd uu___ in - let rest_bs = - let lift_t = - FStar_Compiler_Util.must sub.FStar_Syntax_Syntax.lift_wp in - let uu___ = - let uu___1 = - FStar_Syntax_Subst.compress - (FStar_Pervasives_Native.snd lift_t) in - uu___1.FStar_Syntax_Syntax.n in - match uu___ with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = uu___1::bs; - FStar_Syntax_Syntax.comp = uu___2;_} - when (FStar_Compiler_List.length bs) >= Prims.int_one -> - let uu___3 = - FStar_Compiler_List.splitAt - ((FStar_Compiler_List.length bs) - Prims.int_one) bs in - FStar_Pervasives_Native.fst uu___3 - | uu___1 -> - let uu___2 = - let uu___3 = FStar_Syntax_Print.tscheme_to_string lift_t in - FStar_Compiler_Util.format1 - "lift_t tscheme %s is not an arrow with enough binders" - uu___3 in - FStar_Errors.raise_error - (FStar_Syntax_Syntax.has_range_syntax ()) - (FStar_Pervasives_Native.snd lift_t) - FStar_Errors_Codes.Fatal_UnexpectedEffect () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2) in - let args = - let uu___ = FStar_Syntax_Syntax.as_arg a in - let uu___1 = - let uu___2 = - FStar_Compiler_List.map - (fun uu___3 -> - FStar_Syntax_Syntax.as_arg - FStar_Syntax_Syntax.unit_const) rest_bs in - let uu___3 = - let uu___4 = FStar_Syntax_Syntax.as_arg e in [uu___4] in - FStar_Compiler_List.op_At uu___2 uu___3 in - uu___ :: uu___1 in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = lift; - FStar_Syntax_Syntax.args = args - }) e.FStar_Syntax_Syntax.pos -let (get_field_projector_name : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident -> Prims.int -> FStar_Ident.lident) - = - fun env -> - fun datacon -> - fun index -> - let uu___ = FStar_TypeChecker_Env.lookup_datacon env datacon in - match uu___ with - | (uu___1, t) -> - let err n = - let uu___2 = - let uu___3 = - FStar_Class_Show.show FStar_Ident.showable_lident datacon in - let uu___4 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) n in - let uu___5 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) index in - FStar_Compiler_Util.format3 - "Data constructor %s does not have enough binders (has %s, tried %s)" - uu___3 uu___4 uu___5 in - FStar_Errors.raise_error FStar_TypeChecker_Env.hasRange_env env - FStar_Errors_Codes.Fatal_UnexpectedDataConstructor () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___2) in - let uu___2 = - let uu___3 = FStar_Syntax_Subst.compress t in - uu___3.FStar_Syntax_Syntax.n in - (match uu___2 with - | FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = bs; - FStar_Syntax_Syntax.comp = uu___3;_} - -> - let bs1 = - FStar_Compiler_List.filter - (fun uu___4 -> - match uu___4 with - | { FStar_Syntax_Syntax.binder_bv = uu___5; - FStar_Syntax_Syntax.binder_qual = q; - FStar_Syntax_Syntax.binder_positivity = uu___6; - FStar_Syntax_Syntax.binder_attrs = uu___7;_} -> - (match q with - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Implicit (true)) -> - false - | uu___8 -> true)) bs in - if (FStar_Compiler_List.length bs1) <= index - then err (FStar_Compiler_List.length bs1) - else - (let b = FStar_Compiler_List.nth bs1 index in - FStar_Syntax_Util.mk_field_projector_name datacon - b.FStar_Syntax_Syntax.binder_bv index) - | uu___3 -> err Prims.int_zero) -let (get_mlift_for_subeff : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.sub_eff -> FStar_TypeChecker_Env.mlift) - = - fun env -> - fun sub -> - let uu___ = - (FStar_TypeChecker_Env.is_layered_effect env - sub.FStar_Syntax_Syntax.source) - || - (FStar_TypeChecker_Env.is_layered_effect env - sub.FStar_Syntax_Syntax.target) in - if uu___ - then - let uu___1 = - let uu___2 = - FStar_Compiler_Util.must sub.FStar_Syntax_Syntax.lift_wp in - let uu___3 = FStar_Compiler_Util.must sub.FStar_Syntax_Syntax.kind in - lift_tf_layered_effect sub.FStar_Syntax_Syntax.target uu___2 uu___3 in - { - FStar_TypeChecker_Env.mlift_wp = uu___1; - FStar_TypeChecker_Env.mlift_term = - (FStar_Pervasives_Native.Some - (lift_tf_layered_effect_term env sub)) - } - else - (let mk_mlift_wp ts env1 c = - let ct = FStar_TypeChecker_Env.comp_to_comp_typ env1 c in - check_non_informative_type_for_lift env1 - ct.FStar_Syntax_Syntax.effect_name - sub.FStar_Syntax_Syntax.target ct.FStar_Syntax_Syntax.result_typ - env1.FStar_TypeChecker_Env.range; - (let uu___3 = - FStar_TypeChecker_Env.inst_tscheme_with ts - ct.FStar_Syntax_Syntax.comp_univs in - match uu___3 with - | (uu___4, lift_t) -> - let wp = - FStar_Compiler_List.hd ct.FStar_Syntax_Syntax.effect_args in - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - let uu___9 = - let uu___10 = - let uu___11 = - let uu___12 = - let uu___13 = - FStar_Syntax_Syntax.as_arg - ct.FStar_Syntax_Syntax.result_typ in - [uu___13; wp] in - { - FStar_Syntax_Syntax.hd = lift_t; - FStar_Syntax_Syntax.args = uu___12 - } in - FStar_Syntax_Syntax.Tm_app uu___11 in - FStar_Syntax_Syntax.mk uu___10 - (FStar_Pervasives_Native.fst wp).FStar_Syntax_Syntax.pos in - FStar_Syntax_Syntax.as_arg uu___9 in - [uu___8] in - { - FStar_Syntax_Syntax.comp_univs = - (ct.FStar_Syntax_Syntax.comp_univs); - FStar_Syntax_Syntax.effect_name = - (sub.FStar_Syntax_Syntax.target); - FStar_Syntax_Syntax.result_typ = - (ct.FStar_Syntax_Syntax.result_typ); - FStar_Syntax_Syntax.effect_args = uu___7; - FStar_Syntax_Syntax.flags = - (ct.FStar_Syntax_Syntax.flags) - } in - FStar_Syntax_Syntax.mk_Comp uu___6 in - (uu___5, FStar_TypeChecker_Common.trivial_guard)) in - let mk_mlift_term ts u r e = - let uu___2 = FStar_TypeChecker_Env.inst_tscheme_with ts [u] in - match uu___2 with - | (uu___3, lift_t) -> - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = FStar_Syntax_Syntax.as_arg r in - let uu___8 = - let uu___9 = - FStar_Syntax_Syntax.as_arg FStar_Syntax_Syntax.tun in - let uu___10 = - let uu___11 = FStar_Syntax_Syntax.as_arg e in - [uu___11] in - uu___9 :: uu___10 in - uu___7 :: uu___8 in - { - FStar_Syntax_Syntax.hd = lift_t; - FStar_Syntax_Syntax.args = uu___6 - } in - FStar_Syntax_Syntax.Tm_app uu___5 in - FStar_Syntax_Syntax.mk uu___4 e.FStar_Syntax_Syntax.pos in - let uu___2 = - let uu___3 = - FStar_Compiler_Util.must sub.FStar_Syntax_Syntax.lift_wp in - mk_mlift_wp uu___3 in - { - FStar_TypeChecker_Env.mlift_wp = uu___2; - FStar_TypeChecker_Env.mlift_term = - (match sub.FStar_Syntax_Syntax.lift with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.Some - ((fun uu___3 -> - fun uu___4 -> - fun e -> FStar_Compiler_Util.return_all e)) - | FStar_Pervasives_Native.Some ts -> - FStar_Pervasives_Native.Some (mk_mlift_term ts)) - }) -let (update_env_sub_eff : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.sub_eff -> - FStar_Compiler_Range_Type.range -> FStar_TypeChecker_Env.env) - = - fun env -> - fun sub -> - fun r -> - let r0 = env.FStar_TypeChecker_Env.range in - let env1 = - let uu___ = get_mlift_for_subeff env sub in - FStar_TypeChecker_Env.update_effect_lattice - { - FStar_TypeChecker_Env.solver = - (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = r; - FStar_TypeChecker_Env.curmodule = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = (env.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = (env.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env.FStar_TypeChecker_Env.missing_decl) - } sub.FStar_Syntax_Syntax.source sub.FStar_Syntax_Syntax.target - uu___ in - { - FStar_TypeChecker_Env.solver = (env1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = r0; - FStar_TypeChecker_Env.curmodule = - (env1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = (env1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = (env1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = (env1.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = (env1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env1.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = (env1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = (env1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (env1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env1.FStar_TypeChecker_Env.missing_decl) - } -let (update_env_polymonadic_bind : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident -> - FStar_Ident.lident -> - FStar_Ident.lident -> - FStar_Syntax_Syntax.tscheme -> - FStar_Syntax_Syntax.indexed_effect_combinator_kind -> - FStar_TypeChecker_Env.env) - = - fun env -> - fun m -> - fun n -> - fun p -> - fun ty -> - fun k -> - FStar_TypeChecker_Env.add_polymonadic_bind env m n p - (fun env1 -> - fun c1 -> - fun bv_opt -> - fun c2 -> - fun flags -> - fun r -> - mk_indexed_bind env1 m n p ty k c1 bv_opt c2 - flags r Prims.int_zero false) -let (try_lookup_record_type : - FStar_TypeChecker_Env.env -> - FStar_Ident.lident -> - FStar_Syntax_DsEnv.record_or_dc FStar_Pervasives_Native.option) - = - fun env -> - fun typename -> - try - (fun uu___ -> - match () with - | () -> - let uu___1 = - FStar_TypeChecker_Env.datacons_of_typ env typename in - (match uu___1 with - | (uu___2, dc::[]) -> - let se = FStar_TypeChecker_Env.lookup_sigelt env dc in - (match se with - | FStar_Pervasives_Native.Some - { - FStar_Syntax_Syntax.sigel = - FStar_Syntax_Syntax.Sig_datacon - { FStar_Syntax_Syntax.lid1 = uu___3; - FStar_Syntax_Syntax.us1 = uu___4; - FStar_Syntax_Syntax.t1 = t; - FStar_Syntax_Syntax.ty_lid = uu___5; - FStar_Syntax_Syntax.num_ty_params = nparms; - FStar_Syntax_Syntax.mutuals1 = uu___6; - FStar_Syntax_Syntax.injective_type_params1 = - uu___7;_}; - FStar_Syntax_Syntax.sigrng = uu___8; - FStar_Syntax_Syntax.sigquals = uu___9; - FStar_Syntax_Syntax.sigmeta = uu___10; - FStar_Syntax_Syntax.sigattrs = uu___11; - FStar_Syntax_Syntax.sigopens_and_abbrevs = uu___12; - FStar_Syntax_Syntax.sigopts = uu___13;_} - -> - let uu___14 = FStar_Syntax_Util.arrow_formals t in - (match uu___14 with - | (formals, c) -> - if - nparms < (FStar_Compiler_List.length formals) - then - let uu___15 = - FStar_Compiler_List.splitAt nparms formals in - (match uu___15 with - | (uu___16, fields) -> - let fields1 = - FStar_Compiler_List.filter - (fun b -> - match b.FStar_Syntax_Syntax.binder_qual - with - | FStar_Pervasives_Native.Some - (FStar_Syntax_Syntax.Implicit - uu___17) -> false - | uu___17 -> true) fields in - let fields2 = - FStar_Compiler_List.map - (fun b -> - (((b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.ppname), - ((b.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort))) - fields1 in - let is_rec = - FStar_TypeChecker_Env.is_record env - typename in - let r = - let uu___17 = - FStar_Ident.ident_of_lid dc in - { - FStar_Syntax_DsEnv.typename = - typename; - FStar_Syntax_DsEnv.constrname = - uu___17; - FStar_Syntax_DsEnv.parms = []; - FStar_Syntax_DsEnv.fields = fields2; - FStar_Syntax_DsEnv.is_private = - false; - FStar_Syntax_DsEnv.is_record = - is_rec - } in - FStar_Pervasives_Native.Some r) - else FStar_Pervasives_Native.None) - | uu___3 -> FStar_Pervasives_Native.None) - | (uu___2, dcs) -> FStar_Pervasives_Native.None)) () - with | uu___ -> FStar_Pervasives_Native.None -let (find_record_or_dc_from_typ : - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.typ FStar_Pervasives_Native.option -> - FStar_Syntax_Syntax.unresolved_constructor -> - FStar_Compiler_Range_Type.range -> - (FStar_Syntax_DsEnv.record_or_dc * FStar_Ident.lident * - FStar_Syntax_Syntax.fv)) - = - fun env -> - fun t -> - fun uc -> - fun rng -> - let default_rdc uu___ = - match ((uc.FStar_Syntax_Syntax.uc_typename), - (uc.FStar_Syntax_Syntax.uc_fields)) - with - | (FStar_Pervasives_Native.None, []) -> - let uu___1 = - let uu___2 = - FStar_Errors_Msg.text - "Could not resolve the type for this record." in - [uu___2] in - FStar_Errors.raise_error FStar_Class_HasRange.hasRange_range - rng FStar_Errors_Codes.Error_CannotResolveRecord () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___1) - | (FStar_Pervasives_Native.None, f::uu___1) -> - let f1 = - FStar_Compiler_List.hd uc.FStar_Syntax_Syntax.uc_fields in - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = FStar_Ident.string_of_lid f1 in - FStar_Compiler_Util.format1 - "Field name %s could not be resolved." uu___5 in - FStar_Errors_Msg.text uu___4 in - [uu___3] in - FStar_Errors.raise_error FStar_Ident.hasrange_lident f1 - FStar_Errors_Codes.Error_CannotResolveRecord () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___2) - | (FStar_Pervasives_Native.Some tn, uu___1) -> - let uu___2 = try_lookup_record_type env tn in - (match uu___2 with - | FStar_Pervasives_Native.Some rdc -> rdc - | FStar_Pervasives_Native.None -> - let uu___3 = - let uu___4 = FStar_Ident.string_of_lid tn in - FStar_Compiler_Util.format1 - "Record name %s not found." uu___4 in - FStar_Errors.raise_error FStar_Ident.hasrange_lident tn - FStar_Errors_Codes.Fatal_NameNotFound () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___3)) in - let rdc = - match t with - | FStar_Pervasives_Native.None -> default_rdc () - | FStar_Pervasives_Native.Some t1 -> - let uu___ = - let uu___1 = - FStar_TypeChecker_Normalize.unfold_whnf' - [FStar_TypeChecker_Env.Unascribe; - FStar_TypeChecker_Env.Unmeta; - FStar_TypeChecker_Env.Unrefine] env t1 in - FStar_Syntax_Util.head_and_args uu___1 in - (match uu___ with - | (thead, uu___1) -> - let uu___2 = - let uu___3 = - let uu___4 = FStar_Syntax_Util.un_uinst thead in - FStar_Syntax_Subst.compress uu___4 in - uu___3.FStar_Syntax_Syntax.n in - (match uu___2 with - | FStar_Syntax_Syntax.Tm_fvar type_name -> - let uu___3 = - try_lookup_record_type env - (type_name.FStar_Syntax_Syntax.fv_name).FStar_Syntax_Syntax.v in - (match uu___3 with - | FStar_Pervasives_Native.None -> default_rdc () - | FStar_Pervasives_Native.Some r -> r) - | uu___3 -> default_rdc ())) in - let constrname = - let name = - let uu___ = - let uu___1 = - FStar_Ident.ns_of_lid rdc.FStar_Syntax_DsEnv.typename in - FStar_Compiler_List.op_At uu___1 - [rdc.FStar_Syntax_DsEnv.constrname] in - FStar_Ident.lid_of_ids uu___ in - FStar_Ident.set_lid_range name rng in - let constructor = - let qual = - if rdc.FStar_Syntax_DsEnv.is_record - then - let uu___ = - let uu___1 = - let uu___2 = - FStar_Compiler_List.map FStar_Pervasives_Native.fst - rdc.FStar_Syntax_DsEnv.fields in - ((rdc.FStar_Syntax_DsEnv.typename), uu___2) in - FStar_Syntax_Syntax.Record_ctor uu___1 in - FStar_Pervasives_Native.Some uu___ - else FStar_Pervasives_Native.None in - FStar_Syntax_Syntax.lid_as_fv constrname qual in - (rdc, constrname, constructor) -let (field_name_matches : - FStar_Ident.lident -> - FStar_Syntax_DsEnv.record_or_dc -> FStar_Ident.ident -> Prims.bool) - = - fun field_name -> - fun rdc -> - fun field -> - (let uu___ = FStar_Ident.ident_of_lid field_name in - FStar_Ident.ident_equals field uu___) && - (let uu___ = - let uu___1 = FStar_Ident.ns_of_lid field_name in uu___1 <> [] in - if uu___ - then - let uu___1 = FStar_Ident.nsstr field_name in - let uu___2 = FStar_Ident.nsstr rdc.FStar_Syntax_DsEnv.typename in - uu___1 = uu___2 - else true) -let make_record_fields_in_order : - 'a . - FStar_TypeChecker_Env.env -> - FStar_Syntax_Syntax.unresolved_constructor -> - (FStar_Syntax_Syntax.typ, FStar_Syntax_Syntax.typ) - FStar_Pervasives.either FStar_Pervasives_Native.option -> - FStar_Syntax_DsEnv.record_or_dc -> - (FStar_Ident.lident * 'a) Prims.list -> - (FStar_Ident.ident -> 'a FStar_Pervasives_Native.option) -> - FStar_Compiler_Range_Type.range -> 'a Prims.list - = - fun env -> - fun uc -> - fun topt -> - fun rdc -> - fun fas -> - fun not_found -> - fun rng -> - let debug uu___ = - let print_rdc rdc1 = - let uu___1 = - FStar_Ident.string_of_lid - rdc1.FStar_Syntax_DsEnv.typename in - let uu___2 = - FStar_Ident.string_of_id - rdc1.FStar_Syntax_DsEnv.constrname in - let uu___3 = - let uu___4 = - FStar_Compiler_List.map - (fun uu___5 -> - match uu___5 with - | (i, uu___6) -> FStar_Ident.string_of_id i) - rdc1.FStar_Syntax_DsEnv.fields in - FStar_Compiler_String.concat "; " uu___4 in - FStar_Compiler_Util.format3 - "{typename=%s; constrname=%s; fields=[%s]}" uu___1 - uu___2 uu___3 in - let print_topt topt1 = - let uu___1 = - FStar_Class_Show.show - (FStar_Class_Show.show_option - (FStar_Class_Show.show_either - FStar_Syntax_Print.showable_term - FStar_Syntax_Print.showable_term)) topt1 in - let uu___2 = print_rdc rdc in - FStar_Compiler_Util.format2 "topt=%s; rdc=%s" uu___1 - uu___2 in - let uu___1 = - FStar_Class_Show.show - (FStar_Class_Show.show_option - FStar_Ident.showable_lident) - uc.FStar_Syntax_Syntax.uc_typename in - let uu___2 = - FStar_Class_Show.show - (FStar_Class_Show.show_list FStar_Ident.showable_lident) - uc.FStar_Syntax_Syntax.uc_fields in - let uu___3 = print_topt topt in - let uu___4 = print_rdc rdc in - let uu___5 = - let uu___6 = - FStar_Compiler_List.map FStar_Pervasives_Native.fst fas in - FStar_Class_Show.show - (FStar_Class_Show.show_list FStar_Ident.showable_lident) - uu___6 in - FStar_Compiler_Util.print5 - "Resolved uc={typename=%s;fields=%s}\n\ttopt=%s\n\t{rdc = %s\n\tfield assignments=[%s]}\n" - uu___1 uu___2 uu___3 uu___4 uu___5 in - let uu___ = - FStar_Compiler_List.fold_left - (fun uu___1 -> - fun uu___2 -> - match (uu___1, uu___2) with - | ((fields, as_rev, missing), (field_name, uu___3)) - -> - let uu___4 = - FStar_Compiler_List.partition - (fun uu___5 -> - match uu___5 with - | (fn, uu___6) -> - field_name_matches fn rdc field_name) - fields in - (match uu___4 with - | (matching, rest) -> - (match matching with - | (uu___5, a1)::[] -> - (rest, (a1 :: as_rev), missing) - | [] -> - let uu___5 = not_found field_name in - (match uu___5 with - | FStar_Pervasives_Native.None -> - (rest, as_rev, (field_name :: - missing)) - | FStar_Pervasives_Native.Some a1 -> - (rest, (a1 :: as_rev), missing)) - | uu___5 -> - let uu___6 = - let uu___7 = - FStar_Ident.string_of_id - field_name in - let uu___8 = - FStar_Ident.string_of_lid - rdc.FStar_Syntax_DsEnv.typename in - FStar_Compiler_Util.format2 - "Field %s of record type %s is given multiple assignments" - uu___7 uu___8 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - rng - FStar_Errors_Codes.Fatal_MissingFieldInRecord - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___6)))) (fas, [], []) - rdc.FStar_Syntax_DsEnv.fields in - match uu___ with - | (rest, as_rev, missing) -> - let pp_missing uu___1 = - let uu___2 = - let uu___3 = FStar_Pprint.break_ Prims.int_one in - FStar_Pprint.op_Hat_Hat FStar_Pprint.comma uu___3 in - FStar_Pprint.separate_map uu___2 - (fun f -> - let uu___3 = - let uu___4 = - FStar_Class_Show.show - FStar_Ident.showable_ident f in - FStar_Pprint.doc_of_string uu___4 in - FStar_Pprint.squotes uu___3) missing in - ((match (rest, missing) with - | ([], []) -> () - | ((f, uu___2)::uu___3, uu___4) -> - let uu___5 = - let uu___6 = - let uu___7 = - let uu___8 = - FStar_Class_Show.show - FStar_Ident.showable_lident f in - let uu___9 = - FStar_Class_Show.show - FStar_Ident.showable_lident - rdc.FStar_Syntax_DsEnv.typename in - FStar_Compiler_Util.format2 - "Field '%s' is redundant for type %s" - uu___8 uu___9 in - FStar_Errors_Msg.text uu___7 in - let uu___7 = - let uu___8 = - if Prims.uu___is_Cons missing - then - let uu___9 = - FStar_Errors_Msg.text "Missing fields:" in - let uu___10 = pp_missing () in - FStar_Pprint.prefix (Prims.of_int (2)) - Prims.int_one uu___9 uu___10 - else FStar_Pprint.empty in - [uu___8] in - uu___6 :: uu___7 in - FStar_Errors.raise_error - FStar_Ident.hasrange_lident f - FStar_Errors_Codes.Fatal_MissingFieldInRecord () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___5) - | ([], uu___2) -> - let uu___3 = - let uu___4 = - let uu___5 = - let uu___6 = - let uu___7 = - FStar_Class_Show.show - FStar_Ident.showable_lident - rdc.FStar_Syntax_DsEnv.typename in - FStar_Compiler_Util.format1 - "Missing fields for record type '%s':" - uu___7 in - FStar_Errors_Msg.text uu___6 in - let uu___6 = pp_missing () in - FStar_Pprint.prefix (Prims.of_int (2)) - Prims.int_one uu___5 uu___6 in - [uu___4] in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range rng - FStar_Errors_Codes.Fatal_MissingFieldInRecord () - (Obj.magic - FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___3)); - FStar_Compiler_List.rev as_rev) \ No newline at end of file diff --git a/ocaml/fstar-lib/generated/FStar_Universal.ml b/ocaml/fstar-lib/generated/FStar_Universal.ml deleted file mode 100644 index b1f38d0a9c8..00000000000 --- a/ocaml/fstar-lib/generated/FStar_Universal.ml +++ /dev/null @@ -1,1533 +0,0 @@ -open Prims -type uenv = FStar_Extraction_ML_UEnv.uenv -let (module_or_interface_name : - FStar_Syntax_Syntax.modul -> (Prims.bool * FStar_Ident.lid)) = - fun m -> - ((m.FStar_Syntax_Syntax.is_interface), (m.FStar_Syntax_Syntax.name)) -let with_dsenv_of_tcenv : - 'a . - FStar_TypeChecker_Env.env -> - 'a FStar_Syntax_DsEnv.withenv -> ('a * FStar_TypeChecker_Env.env) - = - fun tcenv -> - fun f -> - let uu___ = f tcenv.FStar_TypeChecker_Env.dsenv in - match uu___ with - | (a1, dsenv) -> - (a1, - { - FStar_TypeChecker_Env.solver = - (tcenv.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (tcenv.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (tcenv.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (tcenv.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (tcenv.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (tcenv.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (tcenv.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (tcenv.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (tcenv.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (tcenv.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (tcenv.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (tcenv.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (tcenv.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (tcenv.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (tcenv.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (tcenv.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (tcenv.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (tcenv.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (tcenv.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (tcenv.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (tcenv.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (tcenv.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (tcenv.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (tcenv.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (tcenv.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (tcenv.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (tcenv.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (tcenv.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (tcenv.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (tcenv.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (tcenv.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (tcenv.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (tcenv.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (tcenv.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (tcenv.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (tcenv.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (tcenv.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (tcenv.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (tcenv.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (tcenv.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (tcenv.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (tcenv.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (tcenv.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = dsenv; - FStar_TypeChecker_Env.nbe = (tcenv.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (tcenv.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (tcenv.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (tcenv.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (tcenv.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (tcenv.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (tcenv.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (tcenv.FStar_TypeChecker_Env.missing_decl) - }) -let with_tcenv_of_env : - 'a . - uenv -> - (FStar_TypeChecker_Env.env -> ('a * FStar_TypeChecker_Env.env)) -> - ('a * uenv) - = - fun e -> - fun f -> - let uu___ = - let uu___1 = FStar_Extraction_ML_UEnv.tcenv_of_uenv e in f uu___1 in - match uu___ with - | (a1, t') -> - let uu___1 = FStar_Extraction_ML_UEnv.set_tcenv e t' in - (a1, uu___1) -let with_dsenv_of_env : - 'a . uenv -> 'a FStar_Syntax_DsEnv.withenv -> ('a * uenv) = - fun e -> - fun f -> - let uu___ = - let uu___1 = FStar_Extraction_ML_UEnv.tcenv_of_uenv e in - with_dsenv_of_tcenv uu___1 f in - match uu___ with - | (a1, tcenv) -> - let uu___1 = FStar_Extraction_ML_UEnv.set_tcenv e tcenv in - (a1, uu___1) -let (push_env : uenv -> uenv) = - fun env -> - let uu___ = - with_tcenv_of_env env - (fun tcenv -> - let uu___1 = - let uu___2 = FStar_Extraction_ML_UEnv.tcenv_of_uenv env in - FStar_TypeChecker_Env.push uu___2 "top-level: push_env" in - ((), uu___1)) in - FStar_Pervasives_Native.snd uu___ -let (pop_env : uenv -> uenv) = - fun env -> - let uu___ = - with_tcenv_of_env env - (fun tcenv -> - let uu___1 = FStar_TypeChecker_Env.pop tcenv "top-level: pop_env" in - ((), uu___1)) in - FStar_Pervasives_Native.snd uu___ -let with_env : 'a . uenv -> (uenv -> 'a) -> 'a = - fun env -> - fun f -> - let env1 = push_env env in - let res = f env1 in let uu___ = pop_env env1 in res -let (env_of_tcenv : - FStar_TypeChecker_Env.env -> FStar_Extraction_ML_UEnv.uenv) = - fun env -> FStar_Extraction_ML_UEnv.new_uenv env -let (parse : - uenv -> - Prims.string FStar_Pervasives_Native.option -> - Prims.string -> (FStar_Syntax_Syntax.modul * uenv)) - = - fun env -> - fun pre_fn -> - fun fn -> - let uu___ = FStar_Parser_Driver.parse_file fn in - match uu___ with - | (ast, uu___1) -> - let uu___2 = - match pre_fn with - | FStar_Pervasives_Native.None -> (ast, env) - | FStar_Pervasives_Native.Some pre_fn1 -> - let uu___3 = FStar_Parser_Driver.parse_file pre_fn1 in - (match uu___3 with - | (pre_ast, uu___4) -> - (match (pre_ast, ast) with - | (FStar_Parser_AST.Interface (lid1, decls1, uu___5), - FStar_Parser_AST.Module (lid2, decls2)) when - FStar_Ident.lid_equals lid1 lid2 -> - let uu___6 = - let uu___7 = - FStar_ToSyntax_Interleave.initialize_interface - lid1 decls1 in - with_dsenv_of_env env uu___7 in - (match uu___6 with - | (uu___7, env1) -> - let uu___8 = - FStar_ToSyntax_Interleave.interleave_module - ast true in - with_dsenv_of_env env1 uu___8) - | (FStar_Parser_AST.Interface (lid1, uu___5, uu___6), - FStar_Parser_AST.Module (lid2, uu___7)) -> - FStar_Errors.raise_error - FStar_Ident.hasrange_lident lid1 - FStar_Errors_Codes.Fatal_PreModuleMismatch () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Module name in implementation does not match that of interface.") - | uu___5 -> - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_PreModuleMismatch () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "Module name in implementation does not match that of interface."))) in - (match uu___2 with - | (ast1, env1) -> - let uu___3 = FStar_ToSyntax_ToSyntax.ast_modul_to_modul ast1 in - with_dsenv_of_env env1 uu___3) -let (core_check : FStar_TypeChecker_Env.core_check_t) = - fun env -> - fun tm -> - fun t -> - fun must_tot -> - let uu___ = - let uu___1 = FStar_Options.compat_pre_core_should_check () in - Prims.op_Negation uu___1 in - if uu___ - then FStar_Pervasives.Inl FStar_Pervasives_Native.None - else - (let uu___2 = FStar_TypeChecker_Core.check_term env tm t must_tot in - match uu___2 with - | FStar_Pervasives.Inl (FStar_Pervasives_Native.None) -> - FStar_Pervasives.Inl FStar_Pervasives_Native.None - | FStar_Pervasives.Inl (FStar_Pervasives_Native.Some g) -> - let uu___3 = FStar_Options.compat_pre_core_set () in - if uu___3 - then FStar_Pervasives.Inl FStar_Pervasives_Native.None - else FStar_Pervasives.Inl (FStar_Pervasives_Native.Some g) - | FStar_Pervasives.Inr err -> - FStar_Pervasives.Inr - ((fun b -> - if b - then FStar_TypeChecker_Core.print_error_short err - else FStar_TypeChecker_Core.print_error err))) -let (init_env : FStar_Parser_Dep.deps -> FStar_TypeChecker_Env.env) = - fun deps -> - let solver = - let uu___ = FStar_Options.lax () in - if uu___ - then FStar_SMTEncoding_Solver.dummy - else - { - FStar_TypeChecker_Env.init = - (FStar_SMTEncoding_Solver.solver.FStar_TypeChecker_Env.init); - FStar_TypeChecker_Env.snapshot = - (FStar_SMTEncoding_Solver.solver.FStar_TypeChecker_Env.snapshot); - FStar_TypeChecker_Env.rollback = - (FStar_SMTEncoding_Solver.solver.FStar_TypeChecker_Env.rollback); - FStar_TypeChecker_Env.encode_sig = - (FStar_SMTEncoding_Solver.solver.FStar_TypeChecker_Env.encode_sig); - FStar_TypeChecker_Env.preprocess = FStar_Tactics_Hooks.preprocess; - FStar_TypeChecker_Env.spinoff_strictly_positive_goals = - (FStar_Pervasives_Native.Some - FStar_Tactics_Hooks.spinoff_strictly_positive_goals); - FStar_TypeChecker_Env.handle_smt_goal = - FStar_Tactics_Hooks.handle_smt_goal; - FStar_TypeChecker_Env.solve = - (FStar_SMTEncoding_Solver.solver.FStar_TypeChecker_Env.solve); - FStar_TypeChecker_Env.solve_sync = - (FStar_SMTEncoding_Solver.solver.FStar_TypeChecker_Env.solve_sync); - FStar_TypeChecker_Env.finish = - (FStar_SMTEncoding_Solver.solver.FStar_TypeChecker_Env.finish); - FStar_TypeChecker_Env.refresh = - (FStar_SMTEncoding_Solver.solver.FStar_TypeChecker_Env.refresh) - } in - let env = - let uu___ = - let uu___1 = FStar_Tactics_Interpreter.primitive_steps () in - FStar_TypeChecker_NBE.normalize uu___1 in - FStar_TypeChecker_Env.initial_env deps FStar_TypeChecker_TcTerm.tc_term - FStar_TypeChecker_TcTerm.typeof_tot_or_gtot_term - FStar_TypeChecker_TcTerm.typeof_tot_or_gtot_term_fastpath - FStar_TypeChecker_TcTerm.universe_of - FStar_TypeChecker_Rel.teq_nosmt_force - FStar_TypeChecker_Rel.subtype_nosmt_force solver - FStar_Parser_Const.prims_lid uu___ core_check in - let env1 = - { - FStar_TypeChecker_Env.solver = (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = (env.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = (env.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = FStar_Tactics_Hooks.synthesize; - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = (env.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env.FStar_TypeChecker_Env.missing_decl) - } in - let env2 = - { - FStar_TypeChecker_Env.solver = (env1.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = (env1.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env1.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = (env1.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env1.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env1.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = (env1.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env1.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = (env1.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = (env1.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env1.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = (env1.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env1.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = (env1.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env1.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env1.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env1.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env1.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = (env1.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env1.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = (env1.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env1.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env1.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env1.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env1.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env1.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = (env1.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env1.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env1.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env1.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env1.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env1.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env1.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env1.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env1.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env1.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env1.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - FStar_Tactics_Hooks.solve_implicits; - FStar_TypeChecker_Env.splice = (env1.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env1.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env1.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env1.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env1.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = (env1.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (env1.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env1.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env1.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env1.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env1.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env1.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env1.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env1.FStar_TypeChecker_Env.missing_decl) - } in - let env3 = - { - FStar_TypeChecker_Env.solver = (env2.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = (env2.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env2.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = (env2.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env2.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env2.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = (env2.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env2.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = (env2.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = (env2.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env2.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = (env2.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env2.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = (env2.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env2.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env2.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env2.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env2.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = (env2.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env2.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = (env2.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env2.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env2.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env2.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env2.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env2.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = (env2.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env2.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env2.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env2.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env2.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env2.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env2.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env2.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env2.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env2.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env2.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env2.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = FStar_Tactics_Hooks.splice; - FStar_TypeChecker_Env.mpreprocess = - (env2.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env2.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env2.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env2.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = (env2.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (env2.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env2.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env2.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env2.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env2.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env2.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env2.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env2.FStar_TypeChecker_Env.missing_decl) - } in - let env4 = - { - FStar_TypeChecker_Env.solver = (env3.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = (env3.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env3.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = (env3.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env3.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env3.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = (env3.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env3.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = (env3.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = (env3.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env3.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = (env3.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env3.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = (env3.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env3.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env3.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env3.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env3.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = (env3.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env3.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = (env3.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env3.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env3.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env3.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env3.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env3.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = (env3.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env3.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env3.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env3.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env3.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env3.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env3.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env3.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env3.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env3.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env3.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env3.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = (env3.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = FStar_Tactics_Hooks.mpreprocess; - FStar_TypeChecker_Env.postprocess = - (env3.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env3.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env3.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = (env3.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (env3.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env3.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env3.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env3.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env3.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env3.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env3.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env3.FStar_TypeChecker_Env.missing_decl) - } in - let env5 = - { - FStar_TypeChecker_Env.solver = (env4.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = (env4.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env4.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = (env4.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env4.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env4.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = (env4.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env4.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = (env4.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = (env4.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env4.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = (env4.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env4.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = (env4.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env4.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env4.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env4.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env4.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = (env4.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env4.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = (env4.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env4.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env4.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env4.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env4.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env4.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = (env4.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env4.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env4.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env4.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env4.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env4.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env4.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env4.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env4.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env4.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env4.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env4.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = (env4.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env4.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = FStar_Tactics_Hooks.postprocess; - FStar_TypeChecker_Env.identifier_info = - (env4.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env4.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = (env4.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (env4.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env4.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env4.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env4.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env4.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env4.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env4.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env4.FStar_TypeChecker_Env.missing_decl) - } in - (env5.FStar_TypeChecker_Env.solver).FStar_TypeChecker_Env.init env5; env5 -type lang_decls_t = FStar_Parser_AST.decl Prims.list -let (tc_one_fragment : - FStar_Syntax_Syntax.modul FStar_Pervasives_Native.option -> - FStar_TypeChecker_Env.env_t -> - ((FStar_Parser_ParseIt.input_frag * lang_decls_t), - FStar_Parser_AST.decl) FStar_Pervasives.either -> - (FStar_Syntax_Syntax.modul FStar_Pervasives_Native.option * - FStar_TypeChecker_Env.env * lang_decls_t)) - = - fun curmod -> - fun env -> - fun frag -> - let fname env1 = - let uu___ = FStar_Options.lsp_server () in - if uu___ - then - let uu___1 = FStar_TypeChecker_Env.get_range env1 in - FStar_Compiler_Range_Ops.file_of_range uu___1 - else - (let uu___2 = FStar_Options.file_list () in - FStar_Compiler_List.hd uu___2) in - let acceptable_mod_name modul = - let uu___ = - let uu___1 = fname env in - FStar_Parser_Dep.lowercase_module_name uu___1 in - let uu___1 = - let uu___2 = - FStar_Ident.string_of_lid modul.FStar_Syntax_Syntax.name in - FStar_Compiler_String.lowercase uu___2 in - uu___ = uu___1 in - let range_of_first_mod_decl modul = - match modul with - | FStar_Parser_AST.Module - (uu___, - { FStar_Parser_AST.d = uu___1; FStar_Parser_AST.drange = d; - FStar_Parser_AST.quals = uu___2; - FStar_Parser_AST.attrs = uu___3; - FStar_Parser_AST.interleaved = uu___4;_}::uu___5) - -> d - | FStar_Parser_AST.Interface - (uu___, - { FStar_Parser_AST.d = uu___1; FStar_Parser_AST.drange = d; - FStar_Parser_AST.quals = uu___2; - FStar_Parser_AST.attrs = uu___3; - FStar_Parser_AST.interleaved = uu___4;_}::uu___5, - uu___6) - -> d - | uu___ -> FStar_Compiler_Range_Type.dummyRange in - let filter_lang_decls d = - match d.FStar_Parser_AST.d with - | FStar_Parser_AST.UseLangDecls uu___ -> true - | uu___ -> false in - let use_lang_decl ds = - FStar_Compiler_List.tryFind - (fun d -> - FStar_Parser_AST.uu___is_UseLangDecls d.FStar_Parser_AST.d) ds in - let check_module_name_declaration ast_modul = - let uu___ = - let uu___1 = - FStar_ToSyntax_Interleave.interleave_module ast_modul false in - with_dsenv_of_tcenv env uu___1 in - match uu___ with - | (ast_modul1, env1) -> - let uu___1 = - let uu___2 = - FStar_ToSyntax_ToSyntax.partial_ast_modul_to_modul curmod - ast_modul1 in - with_dsenv_of_tcenv env1 uu___2 in - (match uu___1 with - | (modul, env2) -> - ((let uu___3 = - let uu___4 = acceptable_mod_name modul in - Prims.op_Negation uu___4 in - if uu___3 - then - let msg = - let uu___4 = - let uu___5 = fname env2 in - FStar_Parser_Dep.module_name_of_file uu___5 in - FStar_Compiler_Util.format1 - "Interactive mode only supports a single module at the top-level. Expected module %s" - uu___4 in - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range - (range_of_first_mod_decl ast_modul1) - FStar_Errors_Codes.Fatal_NonSingletonTopLevelModule - () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic msg) - else ()); - (let uu___3 = - let uu___4 = - FStar_Syntax_DsEnv.syntax_only - env2.FStar_TypeChecker_Env.dsenv in - if uu___4 - then (modul, env2) - else FStar_TypeChecker_Tc.tc_partial_modul env2 modul in - match uu___3 with - | (modul1, env3) -> - let lang_decls = - let decls = - match ast_modul1 with - | FStar_Parser_AST.Module (uu___4, decls1) -> - decls1 - | FStar_Parser_AST.Interface - (uu___4, decls1, uu___5) -> decls1 in - FStar_Compiler_List.filter filter_lang_decls decls in - ((FStar_Pervasives_Native.Some modul1), env3, - lang_decls)))) in - let check_decls ast_decls = - match curmod with - | FStar_Pervasives_Native.None -> - let uu___ = FStar_Compiler_List.hd ast_decls in - (match uu___ with - | { FStar_Parser_AST.d = uu___1; - FStar_Parser_AST.drange = rng; - FStar_Parser_AST.quals = uu___2; - FStar_Parser_AST.attrs = uu___3; - FStar_Parser_AST.interleaved = uu___4;_} -> - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range rng - FStar_Errors_Codes.Fatal_ModuleFirstStatement () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic - "First statement must be a module declaration")) - | FStar_Pervasives_Native.Some modul -> - let uu___ = - FStar_Compiler_Util.fold_map - (fun env1 -> - fun a_decl -> - let uu___1 = - let uu___2 = - FStar_ToSyntax_Interleave.prefix_with_interface_decls - modul.FStar_Syntax_Syntax.name a_decl in - with_dsenv_of_tcenv env1 uu___2 in - match uu___1 with | (decls, env2) -> (env2, decls)) - env ast_decls in - (match uu___ with - | (env1, ast_decls_l) -> - let uu___1 = - let uu___2 = - FStar_ToSyntax_ToSyntax.decls_to_sigelts - (FStar_Compiler_List.flatten ast_decls_l) in - with_dsenv_of_tcenv env1 uu___2 in - (match uu___1 with - | (sigelts, env2) -> - let uu___2 = - let uu___3 = - FStar_Syntax_DsEnv.syntax_only - env2.FStar_TypeChecker_Env.dsenv in - if uu___3 - then (modul, [], env2) - else - FStar_TypeChecker_Tc.tc_more_partial_modul env2 - modul sigelts in - (match uu___2 with - | (modul1, uu___3, env3) -> - let uu___4 = - FStar_Compiler_List.filter filter_lang_decls - ast_decls in - ((FStar_Pervasives_Native.Some modul1), env3, - uu___4)))) in - match frag with - | FStar_Pervasives.Inr d -> - (match d.FStar_Parser_AST.d with - | FStar_Parser_AST.TopLevelModule lid -> - check_module_name_declaration - (FStar_Parser_AST.Module (lid, [d])) - | uu___ -> check_decls [d]) - | FStar_Pervasives.Inl (frag1, lang_decls) -> - let parse_frag frag2 = - let uu___ = use_lang_decl lang_decls in - match uu___ with - | FStar_Pervasives_Native.None -> - FStar_Parser_Driver.parse_fragment - FStar_Pervasives_Native.None frag2 - | FStar_Pervasives_Native.Some - { FStar_Parser_AST.d = FStar_Parser_AST.UseLangDecls lang; - FStar_Parser_AST.drange = uu___1; - FStar_Parser_AST.quals = uu___2; - FStar_Parser_AST.attrs = uu___3; - FStar_Parser_AST.interleaved = uu___4;_} - -> - FStar_Parser_Driver.parse_fragment - (FStar_Pervasives_Native.Some lang) frag2 in - let uu___ = parse_frag frag1 in - (match uu___ with - | FStar_Parser_Driver.Empty -> (curmod, env, []) - | FStar_Parser_Driver.Decls [] -> (curmod, env, []) - | FStar_Parser_Driver.Modul ast_modul -> - check_module_name_declaration ast_modul - | FStar_Parser_Driver.Decls ast_decls -> check_decls ast_decls) -let (load_interface_decls : - FStar_TypeChecker_Env.env -> Prims.string -> FStar_TypeChecker_Env.env_t) = - fun env -> - fun interface_file_name -> - let r = - FStar_Parser_ParseIt.parse FStar_Pervasives_Native.None - (FStar_Parser_ParseIt.Filename interface_file_name) in - match r with - | FStar_Parser_ParseIt.ASTFragment - (FStar_Pervasives.Inl (FStar_Parser_AST.Interface - (l, decls, uu___)), uu___1) - -> - let uu___2 = - let uu___3 = - FStar_ToSyntax_Interleave.initialize_interface l decls in - with_dsenv_of_tcenv env uu___3 in - FStar_Pervasives_Native.snd uu___2 - | FStar_Parser_ParseIt.ASTFragment uu___ -> - let uu___1 = - FStar_Compiler_Util.format1 - "Unexpected result from parsing %s; expected a single interface" - interface_file_name in - FStar_Errors.raise_error0 FStar_Errors_Codes.Fatal_ParseErrors () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1) - | FStar_Parser_ParseIt.ParseError (err, msg, rng) -> - FStar_Compiler_Effect.raise - (FStar_Errors.Error (err, msg, rng, [])) - | FStar_Parser_ParseIt.Term uu___ -> - failwith - "Impossible: parsing a Toplevel always results in an ASTFragment" -let (emit : - FStar_Parser_Dep.deps -> - (uenv * FStar_Extraction_ML_Syntax.mllib) Prims.list -> unit) - = - fun dep_graph -> - fun mllibs -> - let opt = FStar_Options.codegen () in - let fail uu___ = - let uu___1 = - let uu___2 = - FStar_Class_Show.show - (FStar_Class_Show.show_option FStar_Options.showable_codegen_t) - opt in - Prims.strcat "Unrecognized extraction backend: " uu___2 in - failwith uu___1 in - if opt <> FStar_Pervasives_Native.None - then - let ext = - match opt with - | FStar_Pervasives_Native.Some (FStar_Options.FSharp) -> ".fs" - | FStar_Pervasives_Native.Some (FStar_Options.OCaml) -> ".ml" - | FStar_Pervasives_Native.Some (FStar_Options.Plugin) -> ".ml" - | FStar_Pervasives_Native.Some (FStar_Options.Krml) -> ".krml" - | FStar_Pervasives_Native.Some (FStar_Options.Extension) -> ".ast" - | uu___ -> fail () in - match opt with - | FStar_Pervasives_Native.Some (FStar_Options.FSharp) -> - let outdir = FStar_Options.output_dir () in - let uu___ = - FStar_Compiler_List.map FStar_Pervasives_Native.snd mllibs in - FStar_Compiler_List.iter - (FStar_Extraction_ML_PrintML.print outdir ext) uu___ - | FStar_Pervasives_Native.Some (FStar_Options.OCaml) -> - let outdir = FStar_Options.output_dir () in - let uu___ = - FStar_Compiler_List.map FStar_Pervasives_Native.snd mllibs in - FStar_Compiler_List.iter - (FStar_Extraction_ML_PrintML.print outdir ext) uu___ - | FStar_Pervasives_Native.Some (FStar_Options.Plugin) -> - let outdir = FStar_Options.output_dir () in - let uu___ = - FStar_Compiler_List.map FStar_Pervasives_Native.snd mllibs in - FStar_Compiler_List.iter - (FStar_Extraction_ML_PrintML.print outdir ext) uu___ - | FStar_Pervasives_Native.Some (FStar_Options.Extension) -> - FStar_Compiler_List.iter - (fun uu___ -> - match uu___ with - | (env, m) -> - let uu___1 = m in - (match uu___1 with - | FStar_Extraction_ML_Syntax.MLLib ms -> - FStar_Compiler_List.iter - (fun m1 -> - let uu___2 = m1 in - match uu___2 with - | (mname, modul, uu___3) -> - let filename = - FStar_Compiler_String.concat "_" - (FStar_Compiler_List.op_At - (FStar_Pervasives_Native.fst mname) - [FStar_Pervasives_Native.snd mname]) in - (match modul with - | FStar_Pervasives_Native.Some - (uu___4, decls) -> - let bindings = - FStar_Extraction_ML_UEnv.bindings_of_uenv - env in - let deps = - let uu___5 = - FStar_Extraction_ML_Syntax.string_of_mlpath - mname in - FStar_Parser_Dep.deps_of_modul - dep_graph uu___5 in - let uu___5 = - FStar_Options.prepend_output_dir - (Prims.strcat filename ext) in - FStar_Compiler_Util.save_value_to_file - uu___5 (deps, bindings, decls) - | FStar_Pervasives_Native.None -> - failwith - "Unexpected ml modul in Extension extraction mode")) - ms)) mllibs - | FStar_Pervasives_Native.Some (FStar_Options.Krml) -> - let programs = - FStar_Compiler_List.collect - (fun uu___ -> - match uu___ with - | (ue, mllibs1) -> - FStar_Extraction_Krml.translate ue mllibs1) mllibs in - let bin = (FStar_Extraction_Krml.current_version, programs) in - let oname = - let uu___ = FStar_Options.krmloutput () in - match uu___ with - | FStar_Pervasives_Native.Some fname -> fname - | uu___1 -> - (match programs with - | (name, uu___2)::[] -> - FStar_Options.prepend_output_dir - (Prims.strcat name ext) - | uu___2 -> - FStar_Options.prepend_output_dir - (Prims.strcat "out" ext)) in - FStar_Compiler_Util.save_value_to_file oname bin - | uu___ -> fail () - else () -let (tc_one_file : - uenv -> - Prims.string FStar_Pervasives_Native.option -> - Prims.string -> - FStar_Parser_Dep.parsing_data -> - (FStar_CheckedFiles.tc_result * FStar_Extraction_ML_Syntax.mllib - FStar_Pervasives_Native.option * uenv)) - = - fun env -> - fun pre_fn -> - fun fn -> - fun parsing_data -> - FStar_GenSym.reset_gensym (); - (let maybe_restore_opts uu___1 = - let uu___2 = - let uu___3 = FStar_Options.interactive () in - Prims.op_Negation uu___3 in - if uu___2 - then - let uu___3 = FStar_Options.restore_cmd_line_options true in () - else () in - let maybe_extract_mldefs tcmod env1 = - let uu___1 = FStar_Options.codegen () in - match uu___1 with - | FStar_Pervasives_Native.None -> - (FStar_Pervasives_Native.None, Prims.int_zero) - | FStar_Pervasives_Native.Some tgt -> - let uu___2 = - let uu___3 = - let uu___4 = - FStar_Ident.string_of_lid - tcmod.FStar_Syntax_Syntax.name in - FStar_Options.should_extract uu___4 tgt in - Prims.op_Negation uu___3 in - if uu___2 - then (FStar_Pervasives_Native.None, Prims.int_zero) - else - FStar_Compiler_Util.record_time - (fun uu___4 -> - with_env env1 - (fun env2 -> - let uu___5 = - FStar_Extraction_ML_Modul.extract env2 tcmod in - match uu___5 with | (uu___6, defs) -> defs)) in - let maybe_extract_ml_iface tcmod env1 = - let uu___1 = - let uu___2 = FStar_Options.codegen () in - uu___2 = FStar_Pervasives_Native.None in - if uu___1 - then (env1, Prims.int_zero) - else - FStar_Compiler_Util.record_time - (fun uu___3 -> - let uu___4 = - with_env env1 - (fun env2 -> - FStar_Extraction_ML_Modul.extract_iface env2 tcmod) in - match uu___4 with | (env2, uu___5) -> env2) in - let tc_source_file uu___1 = - let uu___2 = parse env pre_fn fn in - match uu___2 with - | (fmod, env1) -> - let mii = - let uu___3 = - let uu___4 = FStar_Extraction_ML_UEnv.tcenv_of_uenv env1 in - uu___4.FStar_TypeChecker_Env.dsenv in - FStar_Syntax_DsEnv.inclusion_info uu___3 - fmod.FStar_Syntax_Syntax.name in - let check_mod uu___3 = - let check env2 = - (let uu___5 = - let uu___6 = FStar_Options.lax () in - Prims.op_Negation uu___6 in - if uu___5 - then - FStar_SMTEncoding_Z3.refresh - FStar_Pervasives_Native.None - else ()); - with_tcenv_of_env env2 - (fun tcenv -> - (match tcenv.FStar_TypeChecker_Env.gamma with - | [] -> () - | uu___6 -> - failwith - "Impossible: gamma contains leaked names"); - (let uu___6 = - FStar_TypeChecker_Tc.check_module tcenv fmod - (FStar_Compiler_Util.is_some pre_fn) in - match uu___6 with - | (modul, env3) -> - (maybe_restore_opts (); - (let smt_decls = - let uu___8 = - let uu___9 = FStar_Options.lax () in - Prims.op_Negation uu___9 in - if uu___8 - then - FStar_SMTEncoding_Encode.encode_modul - env3 modul - else ([], []) in - ((modul, smt_decls), env3))))) in - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Ident.string_of_lid - fmod.FStar_Syntax_Syntax.name in - FStar_Pervasives_Native.Some uu___6 in - FStar_Profiling.profile (fun uu___6 -> check env1) - uu___5 "FStar.Universal.tc_source_file" in - match uu___4 with - | ((tcmod, smt_decls), env2) -> - let tc_time = Prims.int_zero in - let uu___5 = maybe_extract_mldefs tcmod env2 in - (match uu___5 with - | (extracted_defs, extract_time) -> - let uu___6 = maybe_extract_ml_iface tcmod env2 in - (match uu___6 with - | (env3, iface_extraction_time) -> - ({ - FStar_CheckedFiles.checked_module = tcmod; - FStar_CheckedFiles.mii = mii; - FStar_CheckedFiles.smt_decls = smt_decls; - FStar_CheckedFiles.tc_time = tc_time; - FStar_CheckedFiles.extraction_time = - (extract_time + iface_extraction_time) - }, extracted_defs, env3))) in - let uu___3 = - (let uu___4 = - FStar_Ident.string_of_lid fmod.FStar_Syntax_Syntax.name in - FStar_Options.should_verify uu___4) && - ((FStar_Options.record_hints ()) || - (FStar_Options.use_hints ())) in - if uu___3 - then - let uu___4 = FStar_Parser_ParseIt.find_file fn in - FStar_SMTEncoding_Solver.with_hints_db uu___4 check_mod - else check_mod () in - let uu___1 = - let uu___2 = FStar_Options.cache_off () in - Prims.op_Negation uu___2 in - if uu___1 - then - let r = - let uu___2 = FStar_Extraction_ML_UEnv.tcenv_of_uenv env in - FStar_CheckedFiles.load_module_from_cache uu___2 fn in - let r1 = - let uu___2 = - (FStar_Options.force ()) && - (FStar_Options.should_check_file fn) in - if uu___2 then FStar_Pervasives_Native.None else r in - match r1 with - | FStar_Pervasives_Native.None -> - ((let uu___3 = - (let uu___4 = FStar_Parser_Dep.module_name_of_file fn in - FStar_Options.should_be_already_cached uu___4) && - (let uu___4 = FStar_Options.force () in - Prims.op_Negation uu___4) in - if uu___3 - then - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Compiler_Util.format1 - "Expected %s to already be checked." fn in - FStar_Errors_Msg.text uu___6 in - [uu___5] in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Error_AlreadyCachedAssertionFailure - () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___4) - else ()); - (let uu___4 = - ((let uu___5 = FStar_Options.codegen () in - FStar_Compiler_Option.isSome uu___5) && - (FStar_Options.cmi ())) - && - (let uu___5 = FStar_Options.force () in - Prims.op_Negation uu___5) in - if uu___4 - then - let uu___5 = - let uu___6 = - FStar_Errors_Msg.text - "Cross-module inlining expects all modules to be checked first." in - let uu___7 = - let uu___8 = - let uu___9 = - FStar_Compiler_Util.format1 - "Module %s was not checked." fn in - FStar_Errors_Msg.text uu___9 in - [uu___8] in - uu___6 :: uu___7 in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Error_AlreadyCachedAssertionFailure - () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic uu___5) - else ()); - (let uu___4 = tc_source_file () in - match uu___4 with - | (tc_result, mllib, env1) -> - ((let uu___6 = - (let uu___7 = FStar_Errors.get_err_count () in - uu___7 = Prims.int_zero) && - ((FStar_Options.lax ()) || - (let uu___7 = - FStar_Ident.string_of_lid - (tc_result.FStar_CheckedFiles.checked_module).FStar_Syntax_Syntax.name in - FStar_Options.should_verify uu___7)) in - if uu___6 - then - let uu___7 = - FStar_Extraction_ML_UEnv.tcenv_of_uenv env1 in - FStar_CheckedFiles.store_module_to_cache uu___7 fn - parsing_data tc_result - else ()); - (tc_result, mllib, env1)))) - | FStar_Pervasives_Native.Some tc_result -> - let tcmod = tc_result.FStar_CheckedFiles.checked_module in - let smt_decls = tc_result.FStar_CheckedFiles.smt_decls in - ((let uu___3 = - let uu___4 = - FStar_Ident.string_of_lid - tcmod.FStar_Syntax_Syntax.name in - FStar_Options.dump_module uu___4 in - if uu___3 - then - let uu___4 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_modul tcmod in - FStar_Compiler_Util.print1 - "Module after type checking:\n%s\n" uu___4 - else ()); - (let extend_tcenv tcmod1 tcenv = - (let uu___4 = - let uu___5 = FStar_Options.lax () in - Prims.op_Negation uu___5 in - if uu___4 - then - FStar_SMTEncoding_Z3.refresh - FStar_Pervasives_Native.None - else ()); - (let uu___4 = - let uu___5 = - FStar_ToSyntax_ToSyntax.add_modul_to_env tcmod1 - tc_result.FStar_CheckedFiles.mii - (FStar_TypeChecker_Normalize.erase_universes - tcenv) in - with_dsenv_of_tcenv tcenv uu___5 in - match uu___4 with - | (uu___5, tcenv1) -> - let env1 = - FStar_TypeChecker_Tc.load_checked_module tcenv1 - tcmod1 in - (maybe_restore_opts (); - (let uu___8 = - let uu___9 = FStar_Options.lax () in - Prims.op_Negation uu___9 in - if uu___8 - then - FStar_SMTEncoding_Encode.encode_modul_from_cache - env1 tcmod1 smt_decls - else ()); - ((), env1))) in - let env1 = - FStar_Profiling.profile - (fun uu___3 -> - let uu___4 = - with_tcenv_of_env env (extend_tcenv tcmod) in - FStar_Pervasives_Native.snd uu___4) - FStar_Pervasives_Native.None - "FStar.Universal.extend_tcenv" in - let mllib = - let uu___3 = FStar_Options.codegen () in - match uu___3 with - | FStar_Pervasives_Native.None -> - FStar_Pervasives_Native.None - | FStar_Pervasives_Native.Some tgt -> - let uu___4 = - (let uu___5 = - FStar_Ident.string_of_lid - tcmod.FStar_Syntax_Syntax.name in - FStar_Options.should_extract uu___5 tgt) && - ((Prims.op_Negation - tcmod.FStar_Syntax_Syntax.is_interface) - || (tgt = FStar_Options.Krml)) in - if uu___4 - then - let uu___5 = maybe_extract_mldefs tcmod env1 in - (match uu___5 with - | (extracted_defs, _extraction_time) -> - extracted_defs) - else FStar_Pervasives_Native.None in - let uu___3 = maybe_extract_ml_iface tcmod env1 in - match uu___3 with - | (env2, _time) -> (tc_result, mllib, env2))) - else - (let uu___3 = tc_source_file () in - match uu___3 with - | (tc_result, mllib, env1) -> (tc_result, mllib, env1))) -let (tc_one_file_for_ide : - FStar_TypeChecker_Env.env_t -> - Prims.string FStar_Pervasives_Native.option -> - Prims.string -> - FStar_Parser_Dep.parsing_data -> - (FStar_CheckedFiles.tc_result * FStar_TypeChecker_Env.env_t)) - = - fun env -> - fun pre_fn -> - fun fn -> - fun parsing_data -> - let env1 = env_of_tcenv env in - let uu___ = tc_one_file env1 pre_fn fn parsing_data in - match uu___ with - | (tc_result, uu___1, env2) -> - let uu___2 = FStar_Extraction_ML_UEnv.tcenv_of_uenv env2 in - (tc_result, uu___2) -let (needs_interleaving : Prims.string -> Prims.string -> Prims.bool) = - fun intf -> - fun impl -> - let m1 = FStar_Parser_Dep.lowercase_module_name intf in - let m2 = FStar_Parser_Dep.lowercase_module_name impl in - ((m1 = m2) && - (let uu___ = FStar_Compiler_Util.get_file_extension intf in - FStar_Compiler_List.mem uu___ ["fsti"; "fsi"])) - && - (let uu___ = FStar_Compiler_Util.get_file_extension impl in - FStar_Compiler_List.mem uu___ ["fst"; "fs"]) -let (tc_one_file_from_remaining : - Prims.string Prims.list -> - uenv -> - FStar_Parser_Dep.deps -> - (Prims.string Prims.list * FStar_CheckedFiles.tc_result * - FStar_Extraction_ML_Syntax.mllib FStar_Pervasives_Native.option * - uenv)) - = - fun remaining -> - fun env -> - fun deps -> - let uu___ = - match remaining with - | intf::impl::remaining1 when needs_interleaving intf impl -> - let uu___1 = - let uu___2 = FStar_Parser_Dep.parsing_data_of deps impl in - tc_one_file env (FStar_Pervasives_Native.Some intf) impl - uu___2 in - (match uu___1 with - | (m, mllib, env1) -> (remaining1, (m, mllib, env1))) - | intf_or_impl::remaining1 -> - let uu___1 = - let uu___2 = - FStar_Parser_Dep.parsing_data_of deps intf_or_impl in - tc_one_file env FStar_Pervasives_Native.None intf_or_impl - uu___2 in - (match uu___1 with - | (m, mllib, env1) -> (remaining1, (m, mllib, env1))) - | [] -> failwith "Impossible: Empty remaining modules" in - match uu___ with - | (remaining1, (nmods, mllib, env1)) -> - (remaining1, nmods, mllib, env1) -let rec (tc_fold_interleave : - FStar_Parser_Dep.deps -> - (FStar_CheckedFiles.tc_result Prims.list * (uenv * - FStar_Extraction_ML_Syntax.mllib) Prims.list * uenv) -> - Prims.string Prims.list -> - (FStar_CheckedFiles.tc_result Prims.list * (uenv * - FStar_Extraction_ML_Syntax.mllib) Prims.list * uenv)) - = - fun deps -> - fun acc -> - fun remaining -> - let as_list env mllib = - match mllib with - | FStar_Pervasives_Native.None -> [] - | FStar_Pervasives_Native.Some mllib1 -> [(env, mllib1)] in - match remaining with - | [] -> acc - | uu___ -> - let uu___1 = acc in - (match uu___1 with - | (mods, mllibs, env_before) -> - let uu___2 = - tc_one_file_from_remaining remaining env_before deps in - (match uu___2 with - | (remaining1, nmod, mllib, env) -> - ((let uu___4 = - let uu___5 = FStar_Options.profile_group_by_decl () in - Prims.op_Negation uu___5 in - if uu___4 - then - let uu___5 = - FStar_Ident.string_of_lid - (nmod.FStar_CheckedFiles.checked_module).FStar_Syntax_Syntax.name in - FStar_Profiling.report_and_clear uu___5 - else ()); - tc_fold_interleave deps - ((FStar_Compiler_List.op_At mods [nmod]), - (FStar_Compiler_List.op_At mllibs - (as_list env mllib)), env) remaining1))) -let (dbg_dep : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Debug.get_toggle "Dep" -let (batch_mode_tc : - Prims.string Prims.list -> - FStar_Parser_Dep.deps -> - (FStar_CheckedFiles.tc_result Prims.list * uenv * (uenv -> uenv))) - = - fun filenames -> - fun dep_graph -> - (let uu___1 = FStar_Compiler_Effect.op_Bang dbg_dep in - if uu___1 - then - (FStar_Compiler_Util.print_endline - "Auto-deps kicked in; here's some info."; - FStar_Compiler_Util.print1 - "Here's the list of filenames we will process: %s\n" - (FStar_Compiler_String.concat " " filenames); - (let uu___4 = - let uu___5 = - FStar_Compiler_List.filter FStar_Options.should_verify_file - filenames in - FStar_Compiler_String.concat " " uu___5 in - FStar_Compiler_Util.print1 - "Here's the list of modules we will verify: %s\n" uu___4)) - else ()); - (let env = - let uu___1 = init_env dep_graph in - FStar_Extraction_ML_UEnv.new_uenv uu___1 in - let uu___1 = tc_fold_interleave dep_graph ([], [], env) filenames in - match uu___1 with - | (all_mods, mllibs, env1) -> - ((let uu___3 = - let uu___4 = FStar_Errors.get_err_count () in - uu___4 = Prims.int_zero in - if uu___3 then emit dep_graph mllibs else ()); - (let solver_refresh env2 = - let uu___3 = - with_tcenv_of_env env2 - (fun tcenv -> - (let uu___5 = - (FStar_Options.interactive ()) && - (let uu___6 = FStar_Errors.get_err_count () in - uu___6 = Prims.int_zero) in - if uu___5 - then - (tcenv.FStar_TypeChecker_Env.solver).FStar_TypeChecker_Env.refresh - FStar_Pervasives_Native.None - else - (tcenv.FStar_TypeChecker_Env.solver).FStar_TypeChecker_Env.finish - ()); - ((), tcenv)) in - FStar_Pervasives_Native.snd uu___3 in - (all_mods, env1, solver_refresh)))) \ No newline at end of file diff --git a/ocaml/fstar-lib/make_fstar_version.sh b/ocaml/fstar-lib/make_fstar_version.sh index 2c8d10da529..37bf71d8e54 100755 --- a/ocaml/fstar-lib/make_fstar_version.sh +++ b/ocaml/fstar-lib/make_fstar_version.sh @@ -20,9 +20,9 @@ fi COMMITDATE=$(git log --pretty=format:%ci -n 1 2>/dev/null || echo unset) echo "let dummy () = ();;" -echo "FStar_Options._version := \"$VERSION\";" -echo "FStar_Options._platform := \"$PLATFORM\";;" -echo "FStar_Options._compiler := \"$COMPILER\";;" +echo "FStarC_Options._version := \"$VERSION\";" +echo "FStarC_Options._platform := \"$PLATFORM\";;" +echo "FStarC_Options._compiler := \"$COMPILER\";;" # We deliberately use commitdate instead of date, so that rebuilds are no-ops -echo "FStar_Options._date := \"$COMMITDATE\";;" -echo "FStar_Options._commit:= \"$FSTAR_COMMIT\";;" +echo "FStarC_Options._date := \"$COMMITDATE\";;" +echo "FStarC_Options._commit:= \"$FSTAR_COMMIT\";;" diff --git a/ocaml/fstar-tests/FStar_Tests_Main.ml b/ocaml/fstar-tests/FStar_Tests_Main.ml index 2723e0e40e9..8d5d9998d29 100644 --- a/ocaml/fstar-tests/FStar_Tests_Main.ml +++ b/ocaml/fstar-tests/FStar_Tests_Main.ml @@ -1,3 +1,3 @@ let _ = Printexc.record_backtrace true; - FStar_Tests_Test.main () + FStarC_Tests_Test.main () diff --git a/ocaml/fstar-tests/generated/FStarC_Tests_Data.ml b/ocaml/fstar-tests/generated/FStarC_Tests_Data.ml new file mode 100644 index 00000000000..0d6aed5c7ed --- /dev/null +++ b/ocaml/fstar-tests/generated/FStarC_Tests_Data.ml @@ -0,0 +1,173 @@ +open Prims +let rec insert : + 'set . + Prims.int -> + (Prims.int, 'set) FStarC_Class_Setlike.setlike -> 'set -> 'set + = + fun n -> + fun uu___ -> + fun s -> + if n = Prims.int_zero + then s + else + (let uu___2 = + Obj.magic + (FStarC_Class_Setlike.add () (Obj.magic uu___) n (Obj.magic s)) in + insert (n - Prims.int_one) uu___ uu___2) +let rec all_mem : + 'set . + Prims.int -> + (Prims.int, 'set) FStarC_Class_Setlike.setlike -> 'set -> Prims.bool + = + fun n -> + fun uu___ -> + fun s -> + if n = Prims.int_zero + then true + else + (FStarC_Class_Setlike.mem () (Obj.magic uu___) n (Obj.magic s)) && + (all_mem (n - Prims.int_one) uu___ s) +let rec all_remove : + 'set . + Prims.int -> + (Prims.int, 'set) FStarC_Class_Setlike.setlike -> 'set -> 'set + = + fun n -> + fun uu___ -> + fun s -> + if n = Prims.int_zero + then s + else + (let uu___2 = + Obj.magic + (FStarC_Class_Setlike.remove () (Obj.magic uu___) n + (Obj.magic s)) in + all_remove (n - Prims.int_one) uu___ uu___2) +let (nn : Prims.int) = (Prims.of_int (10000)) +let (run_all : unit -> unit) = + fun uu___ -> + FStarC_Compiler_Util.print_string "data tests\n"; + (let uu___2 = + FStarC_Compiler_Util.record_time + (fun uu___3 -> + let uu___4 = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Class_Ord.ord_int)) ()) in + insert nn + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Class_Ord.ord_int) uu___4) in + match uu___2 with + | (f, ms) -> + ((let uu___4 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) ms in + FStarC_Compiler_Util.print1 "FlatSet insert: %s\n" uu___4); + (let uu___4 = + FStarC_Compiler_Util.record_time + (fun uu___5 -> + all_mem nn + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Class_Ord.ord_int) f) in + match uu___4 with + | (f_ok, ms1) -> + ((let uu___6 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) ms1 in + FStarC_Compiler_Util.print1 "FlatSet all_mem: %s\n" uu___6); + (let uu___6 = + FStarC_Compiler_Util.record_time + (fun uu___7 -> + all_remove nn + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Class_Ord.ord_int) f) in + match uu___6 with + | (f1, ms2) -> + ((let uu___8 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) ms2 in + FStarC_Compiler_Util.print1 "FlatSet all_remove: %s\n" + uu___8); + if Prims.op_Negation f_ok + then failwith "FlatSet all_mem failed" + else (); + (let uu___10 = + let uu___11 = + FStarC_Class_Setlike.is_empty () + (Obj.magic + (FStarC_Compiler_FlatSet.setlike_flat_set + FStarC_Class_Ord.ord_int)) (Obj.magic f1) in + Prims.op_Negation uu___11 in + if uu___10 + then failwith "FlatSet all_remove failed" + else ()); + (let uu___10 = + FStarC_Compiler_Util.record_time + (fun uu___11 -> + let uu___12 = + Obj.magic + (FStarC_Class_Setlike.empty () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_int)) ()) in + insert nn + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_int) uu___12) in + match uu___10 with + | (rb, ms3) -> + ((let uu___12 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) ms3 in + FStarC_Compiler_Util.print1 "RBSet insert: %s\n" + uu___12); + (let uu___12 = + FStarC_Compiler_Util.record_time + (fun uu___13 -> + all_mem nn + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_int) rb) in + match uu___12 with + | (rb_ok, ms4) -> + ((let uu___14 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + ms4 in + FStarC_Compiler_Util.print1 + "RBSet all_mem: %s\n" uu___14); + (let uu___14 = + FStarC_Compiler_Util.record_time + (fun uu___15 -> + all_remove nn + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_int) rb) in + match uu___14 with + | (rb1, ms5) -> + ((let uu___16 = + FStarC_Class_Show.show + (FStarC_Class_Show.printableshow + FStar_Class_Printable.printable_int) + ms5 in + FStarC_Compiler_Util.print1 + "RBSet all_remove: %s\n" uu___16); + if Prims.op_Negation rb_ok + then failwith "RBSet all_mem failed" + else (); + (let uu___18 = + let uu___19 = + FStarC_Class_Setlike.is_empty () + (Obj.magic + (FStarC_Compiler_RBSet.setlike_rbset + FStarC_Class_Ord.ord_int)) + (Obj.magic rb1) in + Prims.op_Negation uu___19 in + if uu___18 + then + failwith "RBSet all_remove failed" + else ()))))))))))))) \ No newline at end of file diff --git a/ocaml/fstar-tests/generated/FStarC_Tests_Norm.ml b/ocaml/fstar-tests/generated/FStarC_Tests_Norm.ml new file mode 100644 index 00000000000..ebf6e55828d --- /dev/null +++ b/ocaml/fstar-tests/generated/FStarC_Tests_Norm.ml @@ -0,0 +1,1487 @@ +open Prims +let (b : FStarC_Syntax_Syntax.bv -> FStarC_Syntax_Syntax.binder) = + FStarC_Syntax_Syntax.mk_binder +let (id : FStarC_Syntax_Syntax.term) = FStarC_Tests_Pars.pars "fun x -> x" +let (apply : FStarC_Syntax_Syntax.term) = + FStarC_Tests_Pars.pars "fun f x -> f x" +let (twice : FStarC_Syntax_Syntax.term) = + FStarC_Tests_Pars.pars "fun f x -> f (f x)" +let (tt : FStarC_Syntax_Syntax.term) = FStarC_Tests_Pars.pars "fun x y -> x" +let (ff : FStarC_Syntax_Syntax.term) = FStarC_Tests_Pars.pars "fun x y -> y" +let (z : FStarC_Syntax_Syntax.term) = FStarC_Tests_Pars.pars "fun f x -> x" +let (one : FStarC_Syntax_Syntax.term) = + FStarC_Tests_Pars.pars "fun f x -> f x" +let (two : FStarC_Syntax_Syntax.term) = + FStarC_Tests_Pars.pars "fun f x -> f (f x)" +let (succ : FStarC_Syntax_Syntax.term) = + FStarC_Tests_Pars.pars "fun n f x -> f (n f x)" +let (pred : FStarC_Syntax_Syntax.term) = + FStarC_Tests_Pars.pars + "fun n f x -> n (fun g h -> h (g f)) (fun y -> x) (fun y -> y)" +let (mul : FStarC_Syntax_Syntax.term) = + FStarC_Tests_Pars.pars "fun m n f -> m (n f)" +let rec (encode : Prims.int -> FStarC_Syntax_Syntax.term) = + fun n -> + if n = Prims.int_zero + then z + else + (let uu___1 = let uu___2 = encode (n - Prims.int_one) in [uu___2] in + FStarC_Tests_Util.app succ uu___1) +let (minus : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = fun m -> fun n -> FStarC_Tests_Util.app n [pred; m] +let (let_ : + FStarC_Syntax_Syntax.bv -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term) + = + fun x -> + fun e -> + fun e' -> + let uu___ = + let uu___1 = let uu___2 = b x in [uu___2] in + FStarC_Syntax_Util.abs uu___1 e' FStar_Pervasives_Native.None in + FStarC_Tests_Util.app uu___ [e] +let (mk_let : + FStarC_Syntax_Syntax.bv -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) + = + fun x -> + fun e -> + fun e' -> + let e'1 = + FStarC_Syntax_Subst.subst + [FStarC_Syntax_Syntax.NM (x, Prims.int_zero)] e' in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_let + { + FStarC_Syntax_Syntax.lbs = + (false, + [{ + FStarC_Syntax_Syntax.lbname = (FStar_Pervasives.Inl x); + FStarC_Syntax_Syntax.lbunivs = []; + FStarC_Syntax_Syntax.lbtyp = FStarC_Syntax_Syntax.tun; + FStarC_Syntax_Syntax.lbeff = + FStarC_Parser_Const.effect_Tot_lid; + FStarC_Syntax_Syntax.lbdef = e; + FStarC_Syntax_Syntax.lbattrs = []; + FStarC_Syntax_Syntax.lbpos = + FStarC_Compiler_Range_Type.dummyRange + }]); + FStarC_Syntax_Syntax.body1 = e'1 + }) FStarC_Compiler_Range_Type.dummyRange +let (lid : Prims.string -> FStarC_Ident.lident) = + fun x -> + FStarC_Ident.lid_of_path ["Test"; x] + FStarC_Compiler_Range_Type.dummyRange +let (znat_l : FStarC_Syntax_Syntax.fv) = + let uu___ = lid "Z" in + FStarC_Syntax_Syntax.lid_as_fv uu___ + (FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.Data_ctor) +let (snat_l : FStarC_Syntax_Syntax.fv) = + let uu___ = lid "S" in + FStarC_Syntax_Syntax.lid_as_fv uu___ + (FStar_Pervasives_Native.Some FStarC_Syntax_Syntax.Data_ctor) +let (tm_fv : + FStarC_Syntax_Syntax.fv -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun fv -> + FStarC_Syntax_Syntax.mk (FStarC_Syntax_Syntax.Tm_fvar fv) + FStarC_Compiler_Range_Type.dummyRange +let (znat : FStarC_Syntax_Syntax.term) = tm_fv znat_l +let (snat : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun s -> + let uu___ = + let uu___1 = + let uu___2 = tm_fv snat_l in + let uu___3 = let uu___4 = FStarC_Syntax_Syntax.as_arg s in [uu___4] in + { + FStarC_Syntax_Syntax.hd = uu___2; + FStarC_Syntax_Syntax.args = uu___3 + } in + FStarC_Syntax_Syntax.Tm_app uu___1 in + FStarC_Syntax_Syntax.mk uu___ FStarC_Compiler_Range_Type.dummyRange +let pat : 'uuuuu . 'uuuuu -> 'uuuuu FStarC_Syntax_Syntax.withinfo_t = + fun p -> + FStarC_Syntax_Syntax.withinfo p FStarC_Compiler_Range_Type.dummyRange +let (snat_type : FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) = + let uu___ = + let uu___1 = lid "snat" in + FStarC_Syntax_Syntax.lid_as_fv uu___1 FStar_Pervasives_Native.None in + tm_fv uu___ +let (mk_match : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.branch Prims.list -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun h -> + fun branches -> + let branches1 = + FStarC_Compiler_List.map FStarC_Syntax_Util.branch branches in + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_match + { + FStarC_Syntax_Syntax.scrutinee = h; + FStarC_Syntax_Syntax.ret_opt = FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.brs = branches1; + FStarC_Syntax_Syntax.rc_opt1 = FStar_Pervasives_Native.None + }) FStarC_Compiler_Range_Type.dummyRange +let (pred_nat : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun s -> + let zbranch = + let uu___ = + pat + (FStarC_Syntax_Syntax.Pat_cons + (znat_l, FStar_Pervasives_Native.None, [])) in + (uu___, FStar_Pervasives_Native.None, znat) in + let sbranch = + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + pat (FStarC_Syntax_Syntax.Pat_var FStarC_Tests_Util.x) in + (uu___5, false) in + [uu___4] in + (snat_l, FStar_Pervasives_Native.None, uu___3) in + FStarC_Syntax_Syntax.Pat_cons uu___2 in + pat uu___1 in + let uu___1 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_bvar + { + FStarC_Syntax_Syntax.ppname = + (FStarC_Tests_Util.x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = Prims.int_zero; + FStarC_Syntax_Syntax.sort = + (FStarC_Tests_Util.x.FStarC_Syntax_Syntax.sort) + }) FStarC_Compiler_Range_Type.dummyRange in + (uu___, FStar_Pervasives_Native.None, uu___1) in + mk_match s [zbranch; sbranch] +let (minus_nat : + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun t1 -> + fun t2 -> + let minus1 = FStarC_Tests_Util.m in + let x = + { + FStarC_Syntax_Syntax.ppname = + (FStarC_Tests_Util.x.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (FStarC_Tests_Util.x.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = snat_type + } in + let y = + { + FStarC_Syntax_Syntax.ppname = + (FStarC_Tests_Util.y.FStarC_Syntax_Syntax.ppname); + FStarC_Syntax_Syntax.index = + (FStarC_Tests_Util.y.FStarC_Syntax_Syntax.index); + FStarC_Syntax_Syntax.sort = snat_type + } in + let zbranch = + let uu___ = + pat + (FStarC_Syntax_Syntax.Pat_cons + (znat_l, FStar_Pervasives_Native.None, [])) in + let uu___1 = FStarC_Tests_Util.nm x in + (uu___, FStar_Pervasives_Native.None, uu___1) in + let sbranch = + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = + let uu___5 = + pat (FStarC_Syntax_Syntax.Pat_var FStarC_Tests_Util.n) in + (uu___5, false) in + [uu___4] in + (snat_l, FStar_Pervasives_Native.None, uu___3) in + FStarC_Syntax_Syntax.Pat_cons uu___2 in + pat uu___1 in + let uu___1 = + let uu___2 = FStarC_Tests_Util.nm minus1 in + let uu___3 = + let uu___4 = + let uu___5 = FStarC_Tests_Util.nm x in pred_nat uu___5 in + let uu___5 = + let uu___6 = FStarC_Tests_Util.nm FStarC_Tests_Util.n in + [uu___6] in + uu___4 :: uu___5 in + FStarC_Tests_Util.app uu___2 uu___3 in + (uu___, FStar_Pervasives_Native.None, uu___1) in + let lb = + let uu___ = + FStarC_Ident.lid_of_path ["Pure"] + FStarC_Compiler_Range_Type.dummyRange in + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = b x in + let uu___5 = let uu___6 = b y in [uu___6] in uu___4 :: uu___5 in + let uu___4 = + let uu___5 = FStarC_Tests_Util.nm y in + mk_match uu___5 [zbranch; sbranch] in + FStarC_Syntax_Util.abs uu___3 uu___4 FStar_Pervasives_Native.None in + FStarC_Syntax_Subst.subst + [FStarC_Syntax_Syntax.NM (minus1, Prims.int_zero)] uu___2 in + { + FStarC_Syntax_Syntax.lbname = (FStar_Pervasives.Inl minus1); + FStarC_Syntax_Syntax.lbunivs = []; + FStarC_Syntax_Syntax.lbtyp = FStarC_Syntax_Syntax.tun; + FStarC_Syntax_Syntax.lbeff = uu___; + FStarC_Syntax_Syntax.lbdef = uu___1; + FStarC_Syntax_Syntax.lbattrs = []; + FStarC_Syntax_Syntax.lbpos = FStarC_Compiler_Range_Type.dummyRange + } in + let uu___ = + let uu___1 = + let uu___2 = + let uu___3 = + let uu___4 = FStarC_Tests_Util.nm minus1 in + FStarC_Tests_Util.app uu___4 [t1; t2] in + FStarC_Syntax_Subst.subst + [FStarC_Syntax_Syntax.NM (minus1, Prims.int_zero)] uu___3 in + { + FStarC_Syntax_Syntax.lbs = (true, [lb]); + FStarC_Syntax_Syntax.body1 = uu___2 + } in + FStarC_Syntax_Syntax.Tm_let uu___1 in + FStarC_Syntax_Syntax.mk uu___ FStarC_Compiler_Range_Type.dummyRange +let (encode_nat : Prims.int -> FStarC_Syntax_Syntax.term) = + fun n -> + let rec aux out n1 = + if n1 = Prims.int_zero + then out + else (let uu___1 = snat out in aux uu___1 (n1 - Prims.int_one)) in + aux znat n +let (default_tests : + (Prims.int * FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax * + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) Prims.list) + = + FStarC_Tests_Pars.pars_and_tc_fragment + "let rec copy (x:list int) : Tot (list int) = match x with | [] -> [] | hd::tl -> hd::copy tl"; + FStarC_Tests_Pars.pars_and_tc_fragment + "let recons (x:list 'a) : Tot (list 'a) = match x with | [] -> [] | hd::tl -> hd::tl"; + FStarC_Tests_Pars.pars_and_tc_fragment + "let rev (x:list 'a) : Tot (list 'a) = let rec aux (x:list 'a) (out:list 'a) : Tot (list 'a) = match x with | [] -> out | hd::tl -> aux tl (hd::out) in aux x []"; + FStarC_Tests_Pars.pars_and_tc_fragment + "type t = | A : int -> int -> t | B : int -> int -> t let f = function | A x y | B y x -> y - x"; + FStarC_Tests_Pars.pars_and_tc_fragment "type snat = | Z | S : snat -> snat"; + FStarC_Tests_Pars.pars_and_tc_fragment "type tb = | T | F"; + FStarC_Tests_Pars.pars_and_tc_fragment "type rb = | A1 | A2 | A3"; + FStarC_Tests_Pars.pars_and_tc_fragment "type hb = | H : tb -> hb"; + FStarC_Tests_Pars.pars_and_tc_fragment + "let select (i:tb) (x:'a) (y:'a) : Tot 'a = match i with | T -> x | F -> y"; + FStarC_Tests_Pars.pars_and_tc_fragment + "let select_int3 (i:int) (x:'a) (y:'a) (z:'a) : Tot 'a = match i with | 0 -> x | 1 -> y | _ -> z"; + FStarC_Tests_Pars.pars_and_tc_fragment + "let select_bool (b:bool) (x:'a) (y:'a) : Tot 'a = if b then x else y"; + FStarC_Tests_Pars.pars_and_tc_fragment + "let select_string3 (s:string) (x:'a) (y:'a) (z:'a) : Tot 'a = match s with | \"abc\" -> x | \"def\" -> y | _ -> z"; + FStarC_Tests_Pars.pars_and_tc_fragment + "let recons_m (x:list tb) = match x with | [] -> [] | hd::tl -> hd::tl"; + FStarC_Tests_Pars.pars_and_tc_fragment + "let rec copy_tb_list_2 (x:list tb) : Tot (list tb) = match x with | [] -> [] | [hd] -> [hd]\n | hd1::hd2::tl -> hd1::hd2::copy_tb_list_2 tl"; + FStarC_Tests_Pars.pars_and_tc_fragment + "let rec copy_list_2 (x:list 'a) : Tot (list 'a) = match x with | [] -> [] | [hd] -> [hd]\n | hd1::hd2::tl -> hd1::hd2::copy_list_2 tl"; + FStarC_Tests_Pars.pars_and_tc_fragment "let (x1:int{x1>3}) = 6"; + FStarC_Tests_Pars.pars_and_tc_fragment + "let (x2:int{x2+1>3 /\\ not (x2-5>0)}) = 2"; + FStarC_Tests_Pars.pars_and_tc_fragment + "let my_plus (x:int) (y:int) = x + y"; + FStarC_Tests_Pars.pars_and_tc_fragment + "let (x3:int{forall (a:nat). a > x2}) = 7"; + FStarC_Tests_Pars.pars_and_tc_fragment "let idd (x: 'a) = x"; + FStarC_Tests_Pars.pars_and_tc_fragment + "let revtb (x: tb) = match x with | T -> F | F -> T"; + FStarC_Tests_Pars.pars_and_tc_fragment "let id_tb (x: tb) = x"; + FStarC_Tests_Pars.pars_and_tc_fragment "let fst_a (x: 'a) (y: 'a) = x"; + FStarC_Tests_Pars.pars_and_tc_fragment "let id_list (x: list 'a) = x"; + FStarC_Tests_Pars.pars_and_tc_fragment "let id_list_m (x: list tb) = x"; + (let uu___25 = + let uu___26 = + let uu___27 = + let uu___28 = + let uu___29 = + let uu___30 = FStarC_Tests_Util.nm FStarC_Tests_Util.n in + [uu___30] in + id :: uu___29 in + one :: uu___28 in + FStarC_Tests_Util.app apply uu___27 in + let uu___27 = FStarC_Tests_Util.nm FStarC_Tests_Util.n in + (Prims.int_zero, uu___26, uu___27) in + let uu___26 = + let uu___27 = + let uu___28 = + let uu___29 = + let uu___30 = FStarC_Tests_Util.nm FStarC_Tests_Util.x in + [uu___30] in + FStarC_Tests_Util.app id uu___29 in + let uu___29 = FStarC_Tests_Util.nm FStarC_Tests_Util.x in + (Prims.int_one, uu___28, uu___29) in + let uu___28 = + let uu___29 = + let uu___30 = + let uu___31 = + let uu___32 = + let uu___33 = FStarC_Tests_Util.nm FStarC_Tests_Util.n in + let uu___34 = + let uu___35 = FStarC_Tests_Util.nm FStarC_Tests_Util.m in + [uu___35] in + uu___33 :: uu___34 in + tt :: uu___32 in + FStarC_Tests_Util.app apply uu___31 in + let uu___31 = FStarC_Tests_Util.nm FStarC_Tests_Util.n in + (Prims.int_one, uu___30, uu___31) in + let uu___30 = + let uu___31 = + let uu___32 = + let uu___33 = + let uu___34 = + let uu___35 = FStarC_Tests_Util.nm FStarC_Tests_Util.n in + let uu___36 = + let uu___37 = FStarC_Tests_Util.nm FStarC_Tests_Util.m in + [uu___37] in + uu___35 :: uu___36 in + ff :: uu___34 in + FStarC_Tests_Util.app apply uu___33 in + let uu___33 = FStarC_Tests_Util.nm FStarC_Tests_Util.m in + ((Prims.of_int (2)), uu___32, uu___33) in + let uu___32 = + let uu___33 = + let uu___34 = + let uu___35 = + let uu___36 = + let uu___37 = + let uu___38 = + let uu___39 = + let uu___40 = + let uu___41 = + let uu___42 = + FStarC_Tests_Util.nm FStarC_Tests_Util.n in + let uu___43 = + let uu___44 = + FStarC_Tests_Util.nm FStarC_Tests_Util.m in + [uu___44] in + uu___42 :: uu___43 in + ff :: uu___41 in + apply :: uu___40 in + apply :: uu___39 in + apply :: uu___38 in + apply :: uu___37 in + apply :: uu___36 in + FStarC_Tests_Util.app apply uu___35 in + let uu___35 = FStarC_Tests_Util.nm FStarC_Tests_Util.m in + ((Prims.of_int (3)), uu___34, uu___35) in + let uu___34 = + let uu___35 = + let uu___36 = + let uu___37 = + let uu___38 = + let uu___39 = + let uu___40 = FStarC_Tests_Util.nm FStarC_Tests_Util.n in + let uu___41 = + let uu___42 = + FStarC_Tests_Util.nm FStarC_Tests_Util.m in + [uu___42] in + uu___40 :: uu___41 in + ff :: uu___39 in + apply :: uu___38 in + FStarC_Tests_Util.app twice uu___37 in + let uu___37 = FStarC_Tests_Util.nm FStarC_Tests_Util.m in + ((Prims.of_int (4)), uu___36, uu___37) in + let uu___36 = + let uu___37 = + let uu___38 = minus one z in + ((Prims.of_int (5)), uu___38, one) in + let uu___38 = + let uu___39 = + let uu___40 = FStarC_Tests_Util.app pred [one] in + ((Prims.of_int (6)), uu___40, z) in + let uu___40 = + let uu___41 = + let uu___42 = minus one one in + ((Prims.of_int (7)), uu___42, z) in + let uu___42 = + let uu___43 = + let uu___44 = FStarC_Tests_Util.app mul [one; one] in + ((Prims.of_int (8)), uu___44, one) in + let uu___44 = + let uu___45 = + let uu___46 = FStarC_Tests_Util.app mul [two; one] in + ((Prims.of_int (9)), uu___46, two) in + let uu___46 = + let uu___47 = + let uu___48 = + let uu___49 = + let uu___50 = FStarC_Tests_Util.app succ [one] in + [uu___50; one] in + FStarC_Tests_Util.app mul uu___49 in + ((Prims.of_int (10)), uu___48, two) in + let uu___48 = + let uu___49 = + let uu___50 = + let uu___51 = encode (Prims.of_int (10)) in + let uu___52 = encode (Prims.of_int (10)) in + minus uu___51 uu___52 in + ((Prims.of_int (11)), uu___50, z) in + let uu___50 = + let uu___51 = + let uu___52 = + let uu___53 = encode (Prims.of_int (100)) in + let uu___54 = encode (Prims.of_int (100)) in + minus uu___53 uu___54 in + ((Prims.of_int (12)), uu___52, z) in + let uu___52 = + let uu___53 = + let uu___54 = + let uu___55 = encode (Prims.of_int (100)) in + let uu___56 = + let uu___57 = + FStarC_Tests_Util.nm + FStarC_Tests_Util.x in + let uu___58 = + FStarC_Tests_Util.nm + FStarC_Tests_Util.x in + minus uu___57 uu___58 in + let_ FStarC_Tests_Util.x uu___55 uu___56 in + ((Prims.of_int (13)), uu___54, z) in + let uu___54 = + let uu___55 = + let uu___56 = + let uu___57 = + FStarC_Tests_Util.app succ [one] in + let uu___58 = + let uu___59 = + let uu___60 = + let uu___61 = + FStarC_Tests_Util.nm + FStarC_Tests_Util.x in + let uu___62 = + let uu___63 = + FStarC_Tests_Util.nm + FStarC_Tests_Util.x in + [uu___63] in + uu___61 :: uu___62 in + FStarC_Tests_Util.app mul uu___60 in + let uu___60 = + let uu___61 = + let uu___62 = + let uu___63 = + FStarC_Tests_Util.nm + FStarC_Tests_Util.y in + let uu___64 = + let uu___65 = + FStarC_Tests_Util.nm + FStarC_Tests_Util.y in + [uu___65] in + uu___63 :: uu___64 in + FStarC_Tests_Util.app mul uu___62 in + let uu___62 = + let uu___63 = + FStarC_Tests_Util.nm + FStarC_Tests_Util.h in + let uu___64 = + FStarC_Tests_Util.nm + FStarC_Tests_Util.h in + minus uu___63 uu___64 in + let_ FStarC_Tests_Util.h uu___61 + uu___62 in + let_ FStarC_Tests_Util.y uu___59 + uu___60 in + let_ FStarC_Tests_Util.x uu___57 uu___58 in + ((Prims.of_int (15)), uu___56, z) in + let uu___56 = + let uu___57 = + let uu___58 = + let uu___59 = + FStarC_Tests_Util.app succ [one] in + let uu___60 = + let uu___61 = + let uu___62 = + let uu___63 = + FStarC_Tests_Util.nm + FStarC_Tests_Util.x in + let uu___64 = + let uu___65 = + FStarC_Tests_Util.nm + FStarC_Tests_Util.x in + [uu___65] in + uu___63 :: uu___64 in + FStarC_Tests_Util.app mul uu___62 in + let uu___62 = + let uu___63 = + let uu___64 = + let uu___65 = + FStarC_Tests_Util.nm + FStarC_Tests_Util.y in + let uu___66 = + let uu___67 = + FStarC_Tests_Util.nm + FStarC_Tests_Util.y in + [uu___67] in + uu___65 :: uu___66 in + FStarC_Tests_Util.app mul + uu___64 in + let uu___64 = + let uu___65 = + FStarC_Tests_Util.nm + FStarC_Tests_Util.h in + let uu___66 = + FStarC_Tests_Util.nm + FStarC_Tests_Util.h in + minus uu___65 uu___66 in + mk_let FStarC_Tests_Util.h uu___63 + uu___64 in + mk_let FStarC_Tests_Util.y uu___61 + uu___62 in + mk_let FStarC_Tests_Util.x uu___59 + uu___60 in + ((Prims.of_int (16)), uu___58, z) in + let uu___58 = + let uu___59 = + let uu___60 = + let uu___61 = + FStarC_Tests_Util.app succ [one] in + let uu___62 = + let uu___63 = + let uu___64 = + let uu___65 = + FStarC_Tests_Util.nm + FStarC_Tests_Util.x in + let uu___66 = + let uu___67 = + FStarC_Tests_Util.nm + FStarC_Tests_Util.x in + [uu___67] in + uu___65 :: uu___66 in + FStarC_Tests_Util.app mul + uu___64 in + let uu___64 = + let uu___65 = + let uu___66 = + let uu___67 = + FStarC_Tests_Util.nm + FStarC_Tests_Util.y in + let uu___68 = + let uu___69 = + FStarC_Tests_Util.nm + FStarC_Tests_Util.y in + [uu___69] in + uu___67 :: uu___68 in + FStarC_Tests_Util.app mul + uu___66 in + let uu___66 = + let uu___67 = + FStarC_Tests_Util.nm + FStarC_Tests_Util.h in + let uu___68 = + FStarC_Tests_Util.nm + FStarC_Tests_Util.h in + minus uu___67 uu___68 in + let_ FStarC_Tests_Util.h uu___65 + uu___66 in + let_ FStarC_Tests_Util.y uu___63 + uu___64 in + let_ FStarC_Tests_Util.x uu___61 + uu___62 in + ((Prims.of_int (17)), uu___60, z) in + let uu___60 = + let uu___61 = + let uu___62 = + let uu___63 = + let uu___64 = snat znat in + snat uu___64 in + pred_nat uu___63 in + let uu___63 = snat znat in + ((Prims.of_int (18)), uu___62, + uu___63) in + let uu___62 = + let uu___63 = + let uu___64 = + let uu___65 = + let uu___66 = + let uu___67 = snat znat in + snat uu___67 in + let uu___67 = snat znat in + minus_nat uu___66 uu___67 in + FStarC_Tests_Pars.tc_term + uu___65 in + let uu___65 = snat znat in + ((Prims.of_int (19)), uu___64, + uu___65) in + let uu___64 = + let uu___65 = + let uu___66 = + let uu___67 = + let uu___68 = + encode_nat + (Prims.of_int (10)) in + let uu___69 = + encode_nat + (Prims.of_int (10)) in + minus_nat uu___68 uu___69 in + FStarC_Tests_Pars.tc_term + uu___67 in + ((Prims.of_int (20)), uu___66, + znat) in + let uu___66 = + let uu___67 = + let uu___68 = + let uu___69 = + let uu___70 = + encode_nat + (Prims.of_int (100)) in + let uu___71 = + encode_nat + (Prims.of_int (100)) in + minus_nat uu___70 uu___71 in + FStarC_Tests_Pars.tc_term + uu___69 in + ((Prims.of_int (21)), uu___68, + znat) in + let uu___68 = + let uu___69 = + let uu___70 = + FStarC_Tests_Pars.tc + "recons [0;1]" in + let uu___71 = + FStarC_Tests_Pars.tc + "[0;1]" in + ((Prims.of_int (24)), + uu___70, uu___71) in + let uu___70 = + let uu___71 = + let uu___72 = + FStarC_Tests_Pars.tc + "recons [false;true;false]" in + let uu___73 = + FStarC_Tests_Pars.tc + "[false;true;false]" in + ((Prims.of_int (241)), + uu___72, uu___73) in + let uu___72 = + let uu___73 = + let uu___74 = + FStarC_Tests_Pars.tc + "copy [0;1]" in + let uu___75 = + FStarC_Tests_Pars.tc + "[0;1]" in + ((Prims.of_int (25)), + uu___74, uu___75) in + let uu___74 = + let uu___75 = + let uu___76 = + FStarC_Tests_Pars.tc + "rev [0;1;2;3;4;5;6;7;8;9;10]" in + let uu___77 = + FStarC_Tests_Pars.tc + "[10;9;8;7;6;5;4;3;2;1;0]" in + ((Prims.of_int (26)), + uu___76, uu___77) in + let uu___76 = + let uu___77 = + let uu___78 = + FStarC_Tests_Pars.tc + "(fun x y z q -> z) T T F T" in + let uu___79 = + FStarC_Tests_Pars.tc + "F" in + ((Prims.of_int (28)), + uu___78, uu___79) in + let uu___78 = + let uu___79 = + let uu___80 = + FStarC_Tests_Pars.tc + "[T; F]" in + let uu___81 = + FStarC_Tests_Pars.tc + "[T; F]" in + ((Prims.of_int (29)), + uu___80, + uu___81) in + let uu___80 = + let uu___81 = + let uu___82 = + FStarC_Tests_Pars.tc + "id_tb T" in + let uu___83 = + FStarC_Tests_Pars.tc + "T" in + ((Prims.of_int (31)), + uu___82, + uu___83) in + let uu___82 = + let uu___83 = + let uu___84 = + FStarC_Tests_Pars.tc + "(fun #a x -> x) #tb T" in + let uu___85 = + FStarC_Tests_Pars.tc + "T" in + ((Prims.of_int (32)), + uu___84, + uu___85) in + let uu___84 = + let uu___85 = + let uu___86 + = + FStarC_Tests_Pars.tc + "revtb T" in + let uu___87 + = + FStarC_Tests_Pars.tc + "F" in + ((Prims.of_int (33)), + uu___86, + uu___87) in + let uu___86 = + let uu___87 + = + let uu___88 + = + FStarC_Tests_Pars.tc + "(fun x y -> x) T F" in + let uu___89 + = + FStarC_Tests_Pars.tc + "T" in + ((Prims.of_int (34)), + uu___88, + uu___89) in + let uu___88 + = + let uu___89 + = + let uu___90 + = + FStarC_Tests_Pars.tc + "fst_a T F" in + let uu___91 + = + FStarC_Tests_Pars.tc + "T" in + ((Prims.of_int (35)), + uu___90, + uu___91) in + let uu___90 + = + let uu___91 + = + let uu___92 + = + FStarC_Tests_Pars.tc + "idd T" in + let uu___93 + = + FStarC_Tests_Pars.tc + "T" in + ((Prims.of_int (36)), + uu___92, + uu___93) in + let uu___92 + = + let uu___93 + = + let uu___94 + = + FStarC_Tests_Pars.tc + "id_list [T]" in + let uu___95 + = + FStarC_Tests_Pars.tc + "[T]" in + ((Prims.of_int (301)), + uu___94, + uu___95) in + let uu___94 + = + let uu___95 + = + let uu___96 + = + FStarC_Tests_Pars.tc + "id_list_m [T]" in + let uu___97 + = + FStarC_Tests_Pars.tc + "[T]" in + ((Prims.of_int (3012)), + uu___96, + uu___97) in + let uu___96 + = + let uu___97 + = + let uu___98 + = + FStarC_Tests_Pars.tc + "recons_m [T; F]" in + let uu___99 + = + FStarC_Tests_Pars.tc + "[T; F]" in + ((Prims.of_int (302)), + uu___98, + uu___99) in + let uu___98 + = + let uu___99 + = + let uu___100 + = + FStarC_Tests_Pars.tc + "select T A1 A3" in + let uu___101 + = + FStarC_Tests_Pars.tc + "A1" in + ((Prims.of_int (303)), + uu___100, + uu___101) in + let uu___100 + = + let uu___101 + = + let uu___102 + = + FStarC_Tests_Pars.tc + "select T 3 4" in + let uu___103 + = + FStarC_Tests_Pars.tc + "3" in + ((Prims.of_int (3031)), + uu___102, + uu___103) in + let uu___102 + = + let uu___103 + = + let uu___104 + = + FStarC_Tests_Pars.tc + "select_bool false 3 4" in + let uu___105 + = + FStarC_Tests_Pars.tc + "4" in + ((Prims.of_int (3032)), + uu___104, + uu___105) in + let uu___104 + = + let uu___105 + = + let uu___106 + = + FStarC_Tests_Pars.tc + "select_int3 1 7 8 9" in + let uu___107 + = + FStarC_Tests_Pars.tc + "8" in + ((Prims.of_int (3033)), + uu___106, + uu___107) in + let uu___106 + = + let uu___107 + = + let uu___108 + = + FStarC_Tests_Pars.tc + "[5]" in + let uu___109 + = + FStarC_Tests_Pars.tc + "[5]" in + ((Prims.of_int (3034)), + uu___108, + uu___109) in + let uu___108 + = + let uu___109 + = + let uu___110 + = + FStarC_Tests_Pars.tc + "[\"abcd\"]" in + let uu___111 + = + FStarC_Tests_Pars.tc + "[\"abcd\"]" in + ((Prims.of_int (3035)), + uu___110, + uu___111) in + let uu___110 + = + let uu___111 + = + let uu___112 + = + FStarC_Tests_Pars.tc + "select_string3 \"def\" 5 6 7" in + let uu___113 + = + FStarC_Tests_Pars.tc + "6" in + ((Prims.of_int (3036)), + uu___112, + uu___113) in + let uu___112 + = + let uu___113 + = + let uu___114 + = + FStarC_Tests_Pars.tc + "idd T" in + let uu___115 + = + FStarC_Tests_Pars.tc + "T" in + ((Prims.of_int (305)), + uu___114, + uu___115) in + let uu___114 + = + let uu___115 + = + let uu___116 + = + FStarC_Tests_Pars.tc + "recons [T]" in + let uu___117 + = + FStarC_Tests_Pars.tc + "[T]" in + ((Prims.of_int (306)), + uu___116, + uu___117) in + let uu___116 + = + let uu___117 + = + let uu___118 + = + FStarC_Tests_Pars.tc + "copy_tb_list_2 [T;F;T;F;T;F;F]" in + let uu___119 + = + FStarC_Tests_Pars.tc + "[T;F;T;F;T;F;F]" in + ((Prims.of_int (307)), + uu___118, + uu___119) in + let uu___118 + = + let uu___119 + = + let uu___120 + = + FStarC_Tests_Pars.tc + "copy_list_2 [T;F;T;F;T;F;F]" in + let uu___121 + = + FStarC_Tests_Pars.tc + "[T;F;T;F;T;F;F]" in + ((Prims.of_int (308)), + uu___120, + uu___121) in + let uu___120 + = + let uu___121 + = + let uu___122 + = + FStarC_Tests_Pars.tc + "rev [T; F; F]" in + let uu___123 + = + FStarC_Tests_Pars.tc + "[F; F; T]" in + ((Prims.of_int (304)), + uu___122, + uu___123) in + let uu___122 + = + let uu___123 + = + let uu___124 + = + FStarC_Tests_Pars.tc + "rev [[T]; [F; T]]" in + let uu___125 + = + FStarC_Tests_Pars.tc + "[[F; T]; [T]]" in + ((Prims.of_int (305)), + uu___124, + uu___125) in + let uu___124 + = + let uu___125 + = + let uu___126 + = + FStarC_Tests_Pars.tc + "x1" in + let uu___127 + = + FStarC_Tests_Pars.tc + "6" in + ((Prims.of_int (309)), + uu___126, + uu___127) in + let uu___126 + = + let uu___127 + = + let uu___128 + = + FStarC_Tests_Pars.tc + "x2" in + let uu___129 + = + FStarC_Tests_Pars.tc + "2" in + ((Prims.of_int (310)), + uu___128, + uu___129) in + let uu___128 + = + let uu___129 + = + let uu___130 + = + FStarC_Tests_Pars.tc + "7 + 3" in + let uu___131 + = + FStarC_Tests_Pars.tc + "10" in + ((Prims.of_int (401)), + uu___130, + uu___131) in + let uu___130 + = + let uu___131 + = + let uu___132 + = + FStarC_Tests_Pars.tc + "true && false" in + let uu___133 + = + FStarC_Tests_Pars.tc + "false" in + ((Prims.of_int (402)), + uu___132, + uu___133) in + let uu___132 + = + let uu___133 + = + let uu___134 + = + FStarC_Tests_Pars.tc + "3 = 5" in + let uu___135 + = + FStarC_Tests_Pars.tc + "false" in + ((Prims.of_int (403)), + uu___134, + uu___135) in + let uu___134 + = + let uu___135 + = + let uu___136 + = + FStarC_Tests_Pars.tc + "\"abc\" ^ \"def\"" in + let uu___137 + = + FStarC_Tests_Pars.tc + "\"abcdef\"" in + ((Prims.of_int (404)), + uu___136, + uu___137) in + let uu___136 + = + let uu___137 + = + let uu___138 + = + FStarC_Tests_Pars.tc + "(fun (x:list int) -> match x with | [] -> 0 | hd::tl -> 1) []" in + let uu___139 + = + FStarC_Tests_Pars.tc + "0" in + ((Prims.of_int (405)), + uu___138, + uu___139) in + [uu___137] in + uu___135 + :: + uu___136 in + uu___133 + :: + uu___134 in + uu___131 + :: + uu___132 in + uu___129 + :: + uu___130 in + uu___127 + :: + uu___128 in + uu___125 + :: + uu___126 in + uu___123 + :: + uu___124 in + uu___121 + :: + uu___122 in + uu___119 + :: + uu___120 in + uu___117 + :: + uu___118 in + uu___115 + :: + uu___116 in + uu___113 + :: + uu___114 in + uu___111 + :: + uu___112 in + uu___109 + :: + uu___110 in + uu___107 + :: + uu___108 in + uu___105 + :: + uu___106 in + uu___103 + :: + uu___104 in + uu___101 + :: + uu___102 in + uu___99 + :: + uu___100 in + uu___97 + :: + uu___98 in + uu___95 + :: + uu___96 in + uu___93 + :: + uu___94 in + uu___91 + :: + uu___92 in + uu___89 :: + uu___90 in + uu___87 :: + uu___88 in + uu___85 :: + uu___86 in + uu___83 :: + uu___84 in + uu___81 :: uu___82 in + uu___79 :: uu___80 in + uu___77 :: uu___78 in + uu___75 :: uu___76 in + uu___73 :: uu___74 in + uu___71 :: uu___72 in + uu___69 :: uu___70 in + uu___67 :: uu___68 in + uu___65 :: uu___66 in + uu___63 :: uu___64 in + uu___61 :: uu___62 in + uu___59 :: uu___60 in + uu___57 :: uu___58 in + uu___55 :: uu___56 in + uu___53 :: uu___54 in + uu___51 :: uu___52 in + uu___49 :: uu___50 in + uu___47 :: uu___48 in + uu___45 :: uu___46 in + uu___43 :: uu___44 in + uu___41 :: uu___42 in + uu___39 :: uu___40 in + uu___37 :: uu___38 in + uu___35 :: uu___36 in + uu___33 :: uu___34 in + uu___31 :: uu___32 in + uu___29 :: uu___30 in + uu___27 :: uu___28 in + uu___25 :: uu___26) +let run_either : + 'uuuuu . + Prims.int -> + 'uuuuu -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + (FStarC_TypeChecker_Env.env -> 'uuuuu -> FStarC_Syntax_Syntax.term) + -> unit + = + fun i -> + fun r -> + fun expected -> + fun normalizer -> + (let uu___1 = FStarC_Compiler_Util.string_of_int i in + FStarC_Compiler_Util.print1 "%s: ... \n\n" uu___1); + (let tcenv = FStarC_Tests_Pars.init () in + (let uu___2 = FStarC_Main.process_args () in ()); + (let x = normalizer tcenv r in + FStarC_Options.init (); + FStarC_Options.set_option "print_universes" + (FStarC_Options.Bool true); + FStarC_Options.set_option "print_implicits" + (FStarC_Options.Bool true); + FStarC_Options.set_option "ugly" (FStarC_Options.Bool true); + FStarC_Options.set_option "print_bound_var_types" + (FStarC_Options.Bool true); + (let uu___7 = + let uu___8 = FStarC_Syntax_Util.unascribe x in + FStarC_Tests_Util.term_eq uu___8 expected in + FStarC_Tests_Util.always i uu___7))) +let (run_whnf : + Prims.int -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> unit) + = + fun i -> + fun r -> + fun expected -> + let steps = + [FStarC_TypeChecker_Env.Primops; + FStarC_TypeChecker_Env.Weak; + FStarC_TypeChecker_Env.HNF; + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant] in + run_either i r expected + (FStarC_TypeChecker_Normalize.normalize steps) +let (run_interpreter : + Prims.int -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> unit) + = + fun i -> + fun r -> + fun expected -> + run_either i r expected + (FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.Beta; + FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant; + FStarC_TypeChecker_Env.Primops]) +let (run_nbe : + Prims.int -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> unit) + = + fun i -> + fun r -> + fun expected -> + run_either i r expected + (FStarC_TypeChecker_NBE.normalize_for_unit_test + [FStarC_TypeChecker_Env.UnfoldUntil + FStarC_Syntax_Syntax.delta_constant]) +let (run_interpreter_with_time : + Prims.int -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + (Prims.int * FStarC_BaseTypes.float)) + = + fun i -> + fun r -> + fun expected -> + let interp uu___ = run_interpreter i r expected in + let uu___ = + let uu___1 = FStarC_Compiler_Util.return_execution_time interp in + FStar_Pervasives_Native.snd uu___1 in + (i, uu___) +let (run_whnf_with_time : + Prims.int -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + (Prims.int * FStarC_BaseTypes.float)) + = + fun i -> + fun r -> + fun expected -> + let whnf uu___ = run_whnf i r expected in + let uu___ = + let uu___1 = FStarC_Compiler_Util.return_execution_time whnf in + FStar_Pervasives_Native.snd uu___1 in + (i, uu___) +let (run_nbe_with_time : + Prims.int -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + (Prims.int * FStarC_BaseTypes.float)) + = + fun i -> + fun r -> + fun expected -> + let nbe uu___ = run_nbe i r expected in + let uu___ = + let uu___1 = FStarC_Compiler_Util.return_execution_time nbe in + FStar_Pervasives_Native.snd uu___1 in + (i, uu___) +let run_tests : + 'uuuuu 'uuuuu1 'uuuuu2 'uuuuu3 . + ('uuuuu * 'uuuuu1 * 'uuuuu2) Prims.list -> + ('uuuuu -> 'uuuuu1 -> 'uuuuu2 -> 'uuuuu3) -> 'uuuuu3 Prims.list + = + fun tests -> + fun run -> + FStarC_Options.__set_unit_tests (); + (let l = + FStarC_Compiler_List.map + (fun uu___1 -> + match uu___1 with | (no, test, res) -> run no test res) tests in + FStarC_Options.__clear_unit_tests (); l) +let (whnf_tests : + (Prims.int * FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.term) + Prims.list) + = + FStarC_Tests_Pars.pars_and_tc_fragment "assume val def : Type0"; + FStarC_Tests_Pars.pars_and_tc_fragment "assume val pred : Type0"; + FStarC_Tests_Pars.pars_and_tc_fragment "let def0 (y:int) = def"; + FStarC_Tests_Pars.pars_and_tc_fragment + "unfold let def1 (y:int) = x:def0 y { pred }"; + (let def_def1 = FStarC_Tests_Pars.tc "x:def0 17 { pred }" in + let def_def1_unfolded = FStarC_Tests_Pars.tc "x:def { pred }" in + let tests = + let uu___4 = + let uu___5 = FStarC_Tests_Pars.tc "def1 17" in + ((Prims.of_int (601)), uu___5, def_def1) in + [uu___4; ((Prims.of_int (602)), def_def1, def_def1_unfolded)] in + tests) +let (run_all_whnf : unit -> unit) = + fun uu___ -> + FStarC_Compiler_Util.print_string "Testing Normlizer WHNF\n"; + (let uu___2 = run_tests whnf_tests run_whnf in + FStarC_Compiler_Util.print_string "Normalizer WHNF ok\n") +let (run_all_nbe : unit -> unit) = + fun uu___ -> + FStarC_Compiler_Util.print_string "Testing NBE\n"; + (let uu___2 = run_tests default_tests run_nbe in + FStarC_Compiler_Util.print_string "NBE ok\n") +let (run_all_interpreter : unit -> unit) = + fun uu___ -> + FStarC_Compiler_Util.print_string "Testing the normalizer\n"; + (let uu___2 = run_tests default_tests run_interpreter in + FStarC_Compiler_Util.print_string "Normalizer ok\n") +let (run_all_whnf_with_time : + unit -> (Prims.int * FStarC_BaseTypes.float) Prims.list) = + fun uu___ -> + FStarC_Compiler_Util.print_string "Testing WHNF\n"; + (let l = run_tests whnf_tests run_whnf_with_time in + FStarC_Compiler_Util.print_string "WHNF ok\n"; l) +let (run_all_nbe_with_time : + unit -> (Prims.int * FStarC_BaseTypes.float) Prims.list) = + fun uu___ -> + FStarC_Compiler_Util.print_string "Testing NBE\n"; + (let l = run_tests default_tests run_nbe_with_time in + FStarC_Compiler_Util.print_string "NBE ok\n"; l) +let (run_all_interpreter_with_time : + unit -> (Prims.int * FStarC_BaseTypes.float) Prims.list) = + fun uu___ -> + FStarC_Compiler_Util.print_string "Testing the normalizer\n"; + (let l = run_tests default_tests run_interpreter_with_time in + FStarC_Compiler_Util.print_string "Normalizer ok\n"; l) +let (run_both_with_time : + Prims.int -> + FStarC_Syntax_Syntax.term -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> unit) + = + fun i -> + fun r -> + fun expected -> + let nbe uu___ = run_nbe i r expected in + let norm uu___ = run_interpreter i r expected in + FStarC_Compiler_Util.measure_execution_time "nbe" nbe; + FStarC_Compiler_Util.print_string "\n"; + FStarC_Compiler_Util.measure_execution_time "normalizer" norm; + FStarC_Compiler_Util.print_string "\n" +let (compare : unit -> unit) = + fun uu___ -> + FStarC_Compiler_Util.print_string + "Comparing times for normalization and nbe\n"; + (let uu___2 = + let uu___3 = encode (Prims.of_int (1000)) in + let uu___4 = + let uu___5 = FStarC_Tests_Util.nm FStarC_Tests_Util.x in + let uu___6 = FStarC_Tests_Util.nm FStarC_Tests_Util.x in + minus uu___5 uu___6 in + let_ FStarC_Tests_Util.x uu___3 uu___4 in + run_both_with_time (Prims.of_int (14)) uu___2 z) +let (compare_times : + (Prims.int * FStarC_BaseTypes.float) Prims.list -> + (Prims.int * FStarC_BaseTypes.float) Prims.list -> unit) + = + fun l_int -> + fun l_nbe -> + FStarC_Compiler_Util.print_string + "Comparing times for normalization and nbe\n"; + FStarC_Compiler_List.iter2 + (fun res1 -> + fun res2 -> + let uu___1 = res1 in + match uu___1 with + | (t1, time_int) -> + let uu___2 = res2 in + (match uu___2 with + | (t2, time_nbe) -> + if t1 = t2 + then + let uu___3 = FStarC_Compiler_Util.string_of_int t1 in + FStarC_Compiler_Util.print3 + "Test %s\nNBE %s\nInterpreter %s\n" uu___3 + (FStarC_Compiler_Util.string_of_float time_nbe) + (FStarC_Compiler_Util.string_of_float time_int) + else + FStarC_Compiler_Util.print_string + "Test numbers do not match...\n")) l_int l_nbe +let (run_all : unit -> unit) = + fun uu___ -> + (let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term znat in + FStarC_Compiler_Util.print1 "%s" uu___2); + (let uu___2 = run_all_whnf_with_time () in + let l_int = run_all_interpreter_with_time () in + let l_nbe = run_all_nbe_with_time () in compare_times l_int l_nbe) \ No newline at end of file diff --git a/ocaml/fstar-tests/generated/FStarC_Tests_Pars.ml b/ocaml/fstar-tests/generated/FStarC_Tests_Pars.ml new file mode 100644 index 00000000000..9fc05436848 --- /dev/null +++ b/ocaml/fstar-tests/generated/FStarC_Tests_Pars.ml @@ -0,0 +1,875 @@ +open Prims +let (test_lid : FStarC_Ident.lident) = + FStarC_Ident.lid_of_path ["Test"] FStarC_Compiler_Range_Type.dummyRange +let (tcenv_ref : + FStarC_TypeChecker_Env.env FStar_Pervasives_Native.option + FStarC_Compiler_Effect.ref) + = FStarC_Compiler_Util.mk_ref FStar_Pervasives_Native.None +let (test_mod_ref : + FStarC_Syntax_Syntax.modul FStar_Pervasives_Native.option + FStarC_Compiler_Effect.ref) + = + FStarC_Compiler_Util.mk_ref + (FStar_Pervasives_Native.Some + { + FStarC_Syntax_Syntax.name = test_lid; + FStarC_Syntax_Syntax.declarations = []; + FStarC_Syntax_Syntax.is_interface = false + }) +let (parse_mod : + Prims.string -> + FStarC_Syntax_DsEnv.env -> + (FStarC_Syntax_DsEnv.env * FStarC_Syntax_Syntax.modul)) + = + fun mod_name -> + fun dsenv -> + let uu___ = + FStarC_Parser_ParseIt.parse FStar_Pervasives_Native.None + (FStarC_Parser_ParseIt.Filename mod_name) in + match uu___ with + | FStarC_Parser_ParseIt.ASTFragment (FStar_Pervasives.Inl m, uu___1) -> + let uu___2 = + let uu___3 = FStarC_ToSyntax_ToSyntax.ast_modul_to_modul m in + uu___3 dsenv in + (match uu___2 with + | (m1, env') -> + let uu___3 = + let uu___4 = + FStarC_Ident.lid_of_path ["Test"] + FStarC_Compiler_Range_Type.dummyRange in + FStarC_Syntax_DsEnv.prepare_module_or_interface false false + env' uu___4 FStarC_Syntax_DsEnv.default_mii in + (match uu___3 with | (env'1, uu___4) -> (env'1, m1))) + | FStarC_Parser_ParseIt.ParseError (err, msg, r) -> + FStarC_Compiler_Effect.raise + (FStarC_Errors.Error (err, msg, r, [])) + | FStarC_Parser_ParseIt.ASTFragment + (FStar_Pervasives.Inr uu___1, uu___2) -> + let msg = + FStarC_Compiler_Util.format1 "%s: expected a module\n" mod_name in + FStarC_Errors.raise_error0 FStarC_Errors_Codes.Fatal_ModuleExpected + () (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic msg) + | FStarC_Parser_ParseIt.Term uu___1 -> + failwith + "Impossible: parsing a Filename always results in an ASTFragment" +let (add_mods : + Prims.string Prims.list -> + FStarC_Syntax_DsEnv.env -> + FStarC_TypeChecker_Env.env -> + (FStarC_Syntax_DsEnv.env * FStarC_TypeChecker_Env.env)) + = + fun mod_names -> + fun dsenv -> + fun env -> + FStarC_Compiler_List.fold_left + (fun uu___ -> + fun mod_name -> + match uu___ with + | (dsenv1, env1) -> + let uu___1 = parse_mod mod_name dsenv1 in + (match uu___1 with + | (dsenv2, string_mod) -> + let uu___2 = + FStarC_TypeChecker_Tc.check_module env1 string_mod + false in + (match uu___2 with | (_mod, env2) -> (dsenv2, env2)))) + (dsenv, env) mod_names +let (init_once : unit -> unit) = + fun uu___ -> + let solver = FStarC_SMTEncoding_Solver.dummy in + let env = + FStarC_TypeChecker_Env.initial_env FStarC_Parser_Dep.empty_deps + FStarC_TypeChecker_TcTerm.tc_term + FStarC_TypeChecker_TcTerm.typeof_tot_or_gtot_term + FStarC_TypeChecker_TcTerm.typeof_tot_or_gtot_term_fastpath + FStarC_TypeChecker_TcTerm.universe_of + FStarC_TypeChecker_Rel.teq_nosmt_force + FStarC_TypeChecker_Rel.subtype_nosmt_force solver + FStarC_Parser_Const.prims_lid + FStarC_TypeChecker_NBE.normalize_for_unit_test + FStarC_Universal.core_check in + (env.FStarC_TypeChecker_Env.solver).FStarC_TypeChecker_Env.init env; + (let uu___2 = + let uu___3 = FStarC_Basefiles.prims () in + let uu___4 = + FStarC_Syntax_DsEnv.empty_env FStarC_Parser_Dep.empty_deps in + parse_mod uu___3 uu___4 in + match uu___2 with + | (dsenv, prims_mod) -> + let env1 = + { + FStarC_TypeChecker_Env.solver = + (env.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = dsenv; + FStarC_TypeChecker_Env.nbe = (env.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env.FStarC_TypeChecker_Env.missing_decl) + } in + let uu___3 = FStarC_TypeChecker_Tc.check_module env1 prims_mod false in + (match uu___3 with + | (_prims_mod, env2) -> + let env3 = + { + FStarC_TypeChecker_Env.solver = + (env2.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = + (env2.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (env2.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = + (env2.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (env2.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (env2.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (env2.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (env2.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = + (env2.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (env2.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (env2.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (env2.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (env2.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (env2.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = + (env2.FStarC_TypeChecker_Env.top_level); + FStarC_TypeChecker_Env.check_uvars = + (env2.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (env2.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (env2.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = + (env2.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (env2.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = + (env2.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (env2.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (env2.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (env2.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (env2.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (env2.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (env2.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (env2.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (env2.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (env2.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (env2.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (env2.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (env2.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (env2.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (env2.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (env2.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (env2.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (env2.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = + (env2.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (env2.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (env2.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (env2.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (env2.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = dsenv; + FStarC_TypeChecker_Env.nbe = + (env2.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (env2.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (env2.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (env2.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (env2.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (env2.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (env2.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (env2.FStarC_TypeChecker_Env.missing_decl) + } in + let env4 = + FStarC_TypeChecker_Env.set_current_module env3 test_lid in + FStarC_Compiler_Effect.op_Colon_Equals tcenv_ref + (FStar_Pervasives_Native.Some env4))) +let (uu___0 : unit) = FStarC_Main.setup_hooks (); init_once () +let (init : unit -> FStarC_TypeChecker_Env.env) = + fun uu___ -> + let uu___1 = FStarC_Compiler_Effect.op_Bang tcenv_ref in + match uu___1 with + | FStar_Pervasives_Native.Some f -> f + | uu___2 -> + failwith + "Should have already been initialized by the top-level effect" +let (frag_of_text : Prims.string -> FStarC_Parser_ParseIt.input_frag) = + fun s -> + { + FStarC_Parser_ParseIt.frag_fname = " input"; + FStarC_Parser_ParseIt.frag_text = s; + FStarC_Parser_ParseIt.frag_line = Prims.int_one; + FStarC_Parser_ParseIt.frag_col = Prims.int_zero + } +let (pars : Prims.string -> FStarC_Syntax_Syntax.term) = + fun s -> + try + (fun uu___ -> + match () with + | () -> + let tcenv = init () in + let uu___1 = + FStarC_Parser_ParseIt.parse FStar_Pervasives_Native.None + (FStarC_Parser_ParseIt.Fragment (frag_of_text s)) in + (match uu___1 with + | FStarC_Parser_ParseIt.Term t -> + FStarC_ToSyntax_ToSyntax.desugar_term + tcenv.FStarC_TypeChecker_Env.dsenv t + | FStarC_Parser_ParseIt.ParseError (e, msg, r) -> + FStarC_Errors.raise_error + FStarC_Class_HasRange.hasRange_range r e () + (Obj.magic FStarC_Errors_Msg.is_error_message_list_doc) + (Obj.magic msg) + | FStarC_Parser_ParseIt.ASTFragment uu___2 -> + failwith + "Impossible: parsing a Fragment always results in a Term")) + () + with + | FStarC_Errors.Error (err, msg, r, _ctx) when + let uu___1 = FStarC_Options.trace_error () in + Prims.op_Negation uu___1 -> + (if r = FStarC_Compiler_Range_Type.dummyRange + then + (let uu___2 = FStarC_Errors_Msg.rendermsg msg in + FStarC_Compiler_Util.print_string uu___2) + else + (let uu___3 = FStarC_Compiler_Range_Ops.string_of_range r in + let uu___4 = FStarC_Errors_Msg.rendermsg msg in + FStarC_Compiler_Util.print2 "%s: %s\n" uu___3 uu___4); + FStarC_Compiler_Effect.exit Prims.int_one) + | e when + let uu___1 = FStarC_Options.trace_error () in + Prims.op_Negation uu___1 -> FStarC_Compiler_Effect.raise e +let (tc' : + Prims.string -> (FStarC_Syntax_Syntax.term * FStarC_TypeChecker_Env.env)) = + fun s -> + let tm = pars s in + let tcenv = init () in + let tcenv1 = + { + FStarC_TypeChecker_Env.solver = (tcenv.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = (tcenv.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (tcenv.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = (tcenv.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (tcenv.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (tcenv.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (tcenv.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (tcenv.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = (tcenv.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (tcenv.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (tcenv.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (tcenv.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (tcenv.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (tcenv.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = false; + FStarC_TypeChecker_Env.check_uvars = + (tcenv.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (tcenv.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (tcenv.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = (tcenv.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (tcenv.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = true; + FStarC_TypeChecker_Env.failhard = + (tcenv.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (tcenv.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (tcenv.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (tcenv.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (tcenv.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (tcenv.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (tcenv.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (tcenv.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (tcenv.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (tcenv.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (tcenv.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (tcenv.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (tcenv.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (tcenv.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (tcenv.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (tcenv.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (tcenv.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = (tcenv.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (tcenv.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (tcenv.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (tcenv.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (tcenv.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = (tcenv.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = (tcenv.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (tcenv.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (tcenv.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (tcenv.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (tcenv.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (tcenv.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (tcenv.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (tcenv.FStarC_TypeChecker_Env.missing_decl) + } in + let uu___ = FStarC_TypeChecker_TcTerm.tc_tot_or_gtot_term tcenv1 tm in + match uu___ with + | (tm1, uu___1, g) -> + (FStarC_TypeChecker_Rel.force_trivial_guard tcenv1 g; + (let tm2 = FStarC_Syntax_Compress.deep_compress false false tm1 in + (tm2, tcenv1))) +let (tc : Prims.string -> FStarC_Syntax_Syntax.term) = + fun s -> let uu___ = tc' s in match uu___ with | (tm, uu___1) -> tm +let (tc_term : FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) = + fun tm -> + let tcenv = init () in + let tcenv1 = + { + FStarC_TypeChecker_Env.solver = (tcenv.FStarC_TypeChecker_Env.solver); + FStarC_TypeChecker_Env.range = (tcenv.FStarC_TypeChecker_Env.range); + FStarC_TypeChecker_Env.curmodule = + (tcenv.FStarC_TypeChecker_Env.curmodule); + FStarC_TypeChecker_Env.gamma = (tcenv.FStarC_TypeChecker_Env.gamma); + FStarC_TypeChecker_Env.gamma_sig = + (tcenv.FStarC_TypeChecker_Env.gamma_sig); + FStarC_TypeChecker_Env.gamma_cache = + (tcenv.FStarC_TypeChecker_Env.gamma_cache); + FStarC_TypeChecker_Env.modules = + (tcenv.FStarC_TypeChecker_Env.modules); + FStarC_TypeChecker_Env.expected_typ = + (tcenv.FStarC_TypeChecker_Env.expected_typ); + FStarC_TypeChecker_Env.sigtab = (tcenv.FStarC_TypeChecker_Env.sigtab); + FStarC_TypeChecker_Env.attrtab = + (tcenv.FStarC_TypeChecker_Env.attrtab); + FStarC_TypeChecker_Env.instantiate_imp = + (tcenv.FStarC_TypeChecker_Env.instantiate_imp); + FStarC_TypeChecker_Env.effects = + (tcenv.FStarC_TypeChecker_Env.effects); + FStarC_TypeChecker_Env.generalize = + (tcenv.FStarC_TypeChecker_Env.generalize); + FStarC_TypeChecker_Env.letrecs = + (tcenv.FStarC_TypeChecker_Env.letrecs); + FStarC_TypeChecker_Env.top_level = false; + FStarC_TypeChecker_Env.check_uvars = + (tcenv.FStarC_TypeChecker_Env.check_uvars); + FStarC_TypeChecker_Env.use_eq_strict = + (tcenv.FStarC_TypeChecker_Env.use_eq_strict); + FStarC_TypeChecker_Env.is_iface = + (tcenv.FStarC_TypeChecker_Env.is_iface); + FStarC_TypeChecker_Env.admit = (tcenv.FStarC_TypeChecker_Env.admit); + FStarC_TypeChecker_Env.lax_universes = + (tcenv.FStarC_TypeChecker_Env.lax_universes); + FStarC_TypeChecker_Env.phase1 = (tcenv.FStarC_TypeChecker_Env.phase1); + FStarC_TypeChecker_Env.failhard = + (tcenv.FStarC_TypeChecker_Env.failhard); + FStarC_TypeChecker_Env.flychecking = + (tcenv.FStarC_TypeChecker_Env.flychecking); + FStarC_TypeChecker_Env.uvar_subtyping = + (tcenv.FStarC_TypeChecker_Env.uvar_subtyping); + FStarC_TypeChecker_Env.intactics = + (tcenv.FStarC_TypeChecker_Env.intactics); + FStarC_TypeChecker_Env.nocoerce = + (tcenv.FStarC_TypeChecker_Env.nocoerce); + FStarC_TypeChecker_Env.tc_term = + (tcenv.FStarC_TypeChecker_Env.tc_term); + FStarC_TypeChecker_Env.typeof_tot_or_gtot_term = + (tcenv.FStarC_TypeChecker_Env.typeof_tot_or_gtot_term); + FStarC_TypeChecker_Env.universe_of = + (tcenv.FStarC_TypeChecker_Env.universe_of); + FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = + (tcenv.FStarC_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); + FStarC_TypeChecker_Env.teq_nosmt_force = + (tcenv.FStarC_TypeChecker_Env.teq_nosmt_force); + FStarC_TypeChecker_Env.subtype_nosmt_force = + (tcenv.FStarC_TypeChecker_Env.subtype_nosmt_force); + FStarC_TypeChecker_Env.qtbl_name_and_index = + (tcenv.FStarC_TypeChecker_Env.qtbl_name_and_index); + FStarC_TypeChecker_Env.normalized_eff_names = + (tcenv.FStarC_TypeChecker_Env.normalized_eff_names); + FStarC_TypeChecker_Env.fv_delta_depths = + (tcenv.FStarC_TypeChecker_Env.fv_delta_depths); + FStarC_TypeChecker_Env.proof_ns = + (tcenv.FStarC_TypeChecker_Env.proof_ns); + FStarC_TypeChecker_Env.synth_hook = + (tcenv.FStarC_TypeChecker_Env.synth_hook); + FStarC_TypeChecker_Env.try_solve_implicits_hook = + (tcenv.FStarC_TypeChecker_Env.try_solve_implicits_hook); + FStarC_TypeChecker_Env.splice = (tcenv.FStarC_TypeChecker_Env.splice); + FStarC_TypeChecker_Env.mpreprocess = + (tcenv.FStarC_TypeChecker_Env.mpreprocess); + FStarC_TypeChecker_Env.postprocess = + (tcenv.FStarC_TypeChecker_Env.postprocess); + FStarC_TypeChecker_Env.identifier_info = + (tcenv.FStarC_TypeChecker_Env.identifier_info); + FStarC_TypeChecker_Env.tc_hooks = + (tcenv.FStarC_TypeChecker_Env.tc_hooks); + FStarC_TypeChecker_Env.dsenv = (tcenv.FStarC_TypeChecker_Env.dsenv); + FStarC_TypeChecker_Env.nbe = (tcenv.FStarC_TypeChecker_Env.nbe); + FStarC_TypeChecker_Env.strict_args_tab = + (tcenv.FStarC_TypeChecker_Env.strict_args_tab); + FStarC_TypeChecker_Env.erasable_types_tab = + (tcenv.FStarC_TypeChecker_Env.erasable_types_tab); + FStarC_TypeChecker_Env.enable_defer_to_tac = + (tcenv.FStarC_TypeChecker_Env.enable_defer_to_tac); + FStarC_TypeChecker_Env.unif_allow_ref_guards = + (tcenv.FStarC_TypeChecker_Env.unif_allow_ref_guards); + FStarC_TypeChecker_Env.erase_erasable_args = + (tcenv.FStarC_TypeChecker_Env.erase_erasable_args); + FStarC_TypeChecker_Env.core_check = + (tcenv.FStarC_TypeChecker_Env.core_check); + FStarC_TypeChecker_Env.missing_decl = + (tcenv.FStarC_TypeChecker_Env.missing_decl) + } in + let uu___ = FStarC_TypeChecker_TcTerm.tc_tot_or_gtot_term tcenv1 tm in + match uu___ with + | (tm1, uu___1, g) -> + (FStarC_TypeChecker_Rel.force_trivial_guard tcenv1 g; + (let tm2 = FStarC_Syntax_Compress.deep_compress false false tm1 in + tm2)) +let (pars_and_tc_fragment : Prims.string -> unit) = + fun s -> + FStarC_Options.set_option "trace_error" (FStarC_Options.Bool true); + (let report uu___1 = let uu___2 = FStarC_Errors.report_all () in () in + try + (fun uu___1 -> + match () with + | () -> + let tcenv = init () in + let frag = frag_of_text s in + (try + (fun uu___2 -> + match () with + | () -> + let uu___3 = + let uu___4 = + FStarC_Compiler_Effect.op_Bang test_mod_ref in + FStarC_Universal.tc_one_fragment uu___4 tcenv + (FStar_Pervasives.Inl (frag, [])) in + (match uu___3 with + | (test_mod', tcenv', uu___4) -> + (FStarC_Compiler_Effect.op_Colon_Equals + test_mod_ref test_mod'; + FStarC_Compiler_Effect.op_Colon_Equals + tcenv_ref + (FStar_Pervasives_Native.Some tcenv'); + (let n = FStarC_Errors.get_err_count () in + if n <> Prims.int_zero + then + (report (); + (let uu___8 = + let uu___9 = + FStarC_Compiler_Util.string_of_int n in + FStarC_Compiler_Util.format1 + "%s errors were reported" uu___9 in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_ErrorsReported + () + (Obj.magic + FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___8))) + else ())))) () + with + | uu___2 -> + (report (); + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_TcOneFragmentFailed () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic (Prims.strcat "tc_one_fragment failed: " s))))) + () + with + | uu___1 -> + ((fun uu___1 -> + if + let uu___2 = FStarC_Options.trace_error () in + Prims.op_Negation uu___2 + then Obj.magic (Obj.repr (FStarC_Compiler_Effect.raise uu___1)) + else Obj.magic (Obj.repr (failwith "unreachable")))) uu___1) +let (test_hashes : unit -> unit) = + fun uu___ -> + (let uu___2 = FStarC_Main.process_args () in ()); + pars_and_tc_fragment "type unary_nat = | U0 | US of unary_nat"; + (let test_one_hash n = + let rec aux n1 = + if n1 = Prims.int_zero + then "U0" + else + (let uu___4 = + let uu___5 = aux (n1 - Prims.int_one) in + Prims.strcat uu___5 ")" in + Prims.strcat "(US " uu___4) in + let tm = let uu___3 = aux n in tc uu___3 in + let hc = FStarC_Syntax_Hash.ext_hash_term tm in + let uu___3 = FStarC_Compiler_Util.string_of_int n in + let uu___4 = FStarC_Hash.string_of_hash_code hc in + FStarC_Compiler_Util.print2 "Hash of unary %s is %s\n" uu___3 uu___4 in + let rec aux n = + if n = Prims.int_zero + then () + else (test_one_hash n; aux (n - Prims.int_one)) in + aux (Prims.of_int (100)); FStarC_Options.init ()) +let (parse_incremental_decls : unit -> unit) = + fun uu___ -> + let source0 = + "module Demo\nlet f x = match x with | Some x -> true | None -> false\nlet test y = if Some? y then f y else true\n```pulse\nfn f() {}\n```\n```pulse\nfn g() {}\n```\nlet something = more\nlet >< junk" in + let source1 = + "module Demo\nlet f x = match x with | Some x -> true | None -> false\nlet test y = if Some? y then f y else true\n```pulse\nfn f() {}\n```\n\n```pulse\nfn g() {}\n```\nlet something = more\nlet >< junk" in + let input0 = + FStarC_Parser_ParseIt.Incremental + { + FStarC_Parser_ParseIt.frag_fname = "Demo.fst"; + FStarC_Parser_ParseIt.frag_text = source0; + FStarC_Parser_ParseIt.frag_line = Prims.int_one; + FStarC_Parser_ParseIt.frag_col = Prims.int_zero + } in + let input1 = + FStarC_Parser_ParseIt.Incremental + { + FStarC_Parser_ParseIt.frag_fname = "Demo.fst"; + FStarC_Parser_ParseIt.frag_text = source1; + FStarC_Parser_ParseIt.frag_line = Prims.int_one; + FStarC_Parser_ParseIt.frag_col = Prims.int_zero + } in + let uu___1 = + let uu___2 = + FStarC_Parser_ParseIt.parse FStar_Pervasives_Native.None input0 in + let uu___3 = + FStarC_Parser_ParseIt.parse FStar_Pervasives_Native.None input1 in + (uu___2, uu___3) in + match uu___1 with + | (FStarC_Parser_ParseIt.IncrementalFragment + (decls0, uu___2, parse_err0), + FStarC_Parser_ParseIt.IncrementalFragment + (decls1, uu___3, parse_err1)) -> + let check_range r l c = + let p = FStarC_Compiler_Range_Ops.start_of_range r in + let uu___4 = + (let uu___5 = FStarC_Compiler_Range_Ops.line_of_pos p in + uu___5 = l) && + (let uu___5 = FStarC_Compiler_Range_Ops.col_of_pos p in + uu___5 = c) in + if uu___4 + then () + else + (let uu___6 = + let uu___7 = FStarC_Compiler_Util.string_of_int l in + let uu___8 = FStarC_Compiler_Util.string_of_int c in + let uu___9 = + let uu___10 = FStarC_Compiler_Range_Ops.line_of_pos p in + FStarC_Compiler_Util.string_of_int uu___10 in + let uu___10 = + let uu___11 = FStarC_Compiler_Range_Ops.col_of_pos p in + FStarC_Compiler_Util.string_of_int uu___11 in + FStarC_Compiler_Util.format4 + "Incremental parsing failed: Expected syntax error at (%s, %s), got error at (%s, %s)" + uu___7 uu___8 uu___9 uu___10 in + failwith uu___6) in + ((match (parse_err0, parse_err1) with + | (FStar_Pervasives_Native.None, uu___5) -> + failwith + "Incremental parsing failed: Expected syntax error at (8, 6), got no error" + | (uu___5, FStar_Pervasives_Native.None) -> + failwith + "Incremental parsing failed: Expected syntax error at (9, 6), got no error" + | (FStar_Pervasives_Native.Some (uu___5, uu___6, rng0), + FStar_Pervasives_Native.Some (uu___7, uu___8, rng1)) -> + (check_range rng0 (Prims.of_int (11)) (Prims.of_int (6)); + check_range rng1 (Prims.of_int (12)) (Prims.of_int (6)))); + (match (decls0, decls1) with + | (d0::d1::d2::d3::d4::d5::[], e0::e1::e2::e3::e4::e5::[]) -> + let uu___5 = + FStarC_Compiler_List.forall2 + (fun uu___6 -> + fun uu___7 -> + match (uu___6, uu___7) with + | ((x, uu___8), (y, uu___9)) -> + FStarC_Parser_AST_Util.eq_decl x y) decls0 decls1 in + if uu___5 + then () + else + failwith + "Incremental parsing failed; unexpected change in a decl" + | uu___5 -> + let uu___6 = + let uu___7 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length decls0) in + let uu___8 = + FStarC_Compiler_Util.string_of_int + (FStarC_Compiler_List.length decls1) in + FStarC_Compiler_Util.format2 + "Incremental parsing failed; expected 6 decls got %s and %s\n" + uu___7 uu___8 in + failwith uu___6)) + | (FStarC_Parser_ParseIt.ParseError (code, message, range), uu___2) -> + let msg = + let uu___3 = FStarC_Compiler_Range_Ops.string_of_range range in + let uu___4 = FStarC_Errors_Msg.rendermsg message in + FStarC_Compiler_Util.format2 + "Incremental parsing failed: Syntax error @ %s: %s" uu___3 uu___4 in + failwith msg + | (uu___2, FStarC_Parser_ParseIt.ParseError (code, message, range)) -> + let msg = + let uu___3 = FStarC_Compiler_Range_Ops.string_of_range range in + let uu___4 = FStarC_Errors_Msg.rendermsg message in + FStarC_Compiler_Util.format2 + "Incremental parsing failed: Syntax error @ %s: %s" uu___3 uu___4 in + failwith msg + | uu___2 -> failwith "Incremental parsing failed: Unexpected output" +let (parse_incremental_decls_use_lang : unit -> unit) = + fun uu___ -> + let source0 = + "module Demo\nlet x = 0\n#lang-somelang\nval f : t\nlet g x = f x\n#restart-solver" in + FStarC_Parser_AST_Util.register_extension_lang_parser "somelang" + FStarC_Parser_ParseIt.parse_fstar_incrementally; + (let input0 = + FStarC_Parser_ParseIt.Incremental + { + FStarC_Parser_ParseIt.frag_fname = "Demo.fst"; + FStarC_Parser_ParseIt.frag_text = source0; + FStarC_Parser_ParseIt.frag_line = Prims.int_one; + FStarC_Parser_ParseIt.frag_col = Prims.int_zero + } in + let uu___2 = + FStarC_Parser_ParseIt.parse FStar_Pervasives_Native.None input0 in + match uu___2 with + | FStarC_Parser_ParseIt.IncrementalFragment (decls0, uu___3, parse_err0) + -> + ((match parse_err0 with + | FStar_Pervasives_Native.None -> () + | FStar_Pervasives_Native.Some uu___5 -> + failwith "Incremental parsing failed: ..."); + (let ds = + FStarC_Compiler_List.map FStar_Pervasives_Native.fst decls0 in + match ds with + | { FStarC_Parser_AST.d = FStarC_Parser_AST.TopLevelModule uu___5; + FStarC_Parser_AST.drange = uu___6; + FStarC_Parser_AST.quals = uu___7; + FStarC_Parser_AST.attrs = uu___8; + FStarC_Parser_AST.interleaved = uu___9;_}::{ + FStarC_Parser_AST.d + = + FStarC_Parser_AST.TopLevelLet + uu___10; + FStarC_Parser_AST.drange + = uu___11; + FStarC_Parser_AST.quals + = uu___12; + FStarC_Parser_AST.attrs + = uu___13; + FStarC_Parser_AST.interleaved + = uu___14;_}:: + { + FStarC_Parser_AST.d = FStarC_Parser_AST.UseLangDecls uu___15; + FStarC_Parser_AST.drange = uu___16; + FStarC_Parser_AST.quals = uu___17; + FStarC_Parser_AST.attrs = uu___18; + FStarC_Parser_AST.interleaved = uu___19;_}::{ + FStarC_Parser_AST.d + = + FStarC_Parser_AST.Val + uu___20; + FStarC_Parser_AST.drange + = uu___21; + FStarC_Parser_AST.quals + = uu___22; + FStarC_Parser_AST.attrs + = uu___23; + FStarC_Parser_AST.interleaved + = uu___24;_}:: + { FStarC_Parser_AST.d = FStarC_Parser_AST.TopLevelLet uu___25; + FStarC_Parser_AST.drange = uu___26; + FStarC_Parser_AST.quals = uu___27; + FStarC_Parser_AST.attrs = uu___28; + FStarC_Parser_AST.interleaved = uu___29;_}::{ + FStarC_Parser_AST.d + = + FStarC_Parser_AST.Pragma + uu___30; + FStarC_Parser_AST.drange + = uu___31; + FStarC_Parser_AST.quals + = uu___32; + FStarC_Parser_AST.attrs + = uu___33; + FStarC_Parser_AST.interleaved + = uu___34;_}::[] + -> () + | uu___5 -> + let uu___6 = + let uu___7 = + FStarC_Class_Show.show + (FStarC_Class_Show.show_list + FStarC_Parser_AST.showable_decl) ds in + Prims.strcat + "Incremental parsing failed; unexpected decls: " uu___7 in + failwith uu___6)) + | FStarC_Parser_ParseIt.ParseError (code, message, range) -> + let msg = + let uu___3 = FStarC_Compiler_Range_Ops.string_of_range range in + let uu___4 = FStarC_Errors_Msg.rendermsg message in + FStarC_Compiler_Util.format2 + "Incremental parsing failed: Syntax error @ %s: %s" uu___3 + uu___4 in + failwith msg + | uu___3 -> failwith "Incremental parsing failed: Unexpected output") \ No newline at end of file diff --git a/ocaml/fstar-tests/generated/FStarC_Tests_Test.ml b/ocaml/fstar-tests/generated/FStarC_Tests_Test.ml new file mode 100644 index 00000000000..866b9a4c4af --- /dev/null +++ b/ocaml/fstar-tests/generated/FStarC_Tests_Test.ml @@ -0,0 +1,73 @@ +open Prims +let main : 'uuuuu 'uuuuu1 . 'uuuuu -> 'uuuuu1 = + fun argv -> + FStarC_Compiler_Util.print_string "Initializing tests...\n"; + (try + (fun uu___1 -> + match () with + | () -> + let uu___2 = FStarC_Options.parse_cmd_line () in + (match uu___2 with + | (res, fs) -> + (match res with + | FStarC_Getopt.Help -> + (FStarC_Compiler_Util.print_string + "F* unit tests. This binary can take the same options as F*, but not all of them are meaningful."; + FStarC_Compiler_Effect.exit Prims.int_zero) + | FStarC_Getopt.Error msg -> + (FStarC_Compiler_Util.print_error msg; + FStarC_Compiler_Effect.exit Prims.int_one) + | FStarC_Getopt.Empty -> + (FStarC_Main.setup_hooks (); + (let uu___5 = FStarC_Tests_Pars.init () in ()); + FStarC_Tests_Pars.parse_incremental_decls (); + FStarC_Tests_Pars.parse_incremental_decls_use_lang + (); + FStarC_Tests_Norm.run_all (); + (let uu___9 = FStarC_Tests_Unif.run_all () in + if uu___9 + then () + else FStarC_Compiler_Effect.exit Prims.int_one); + FStarC_Tests_Data.run_all (); + (let uu___11 = FStarC_Errors.report_all () in ()); + (let nerrs = FStarC_Errors.get_err_count () in + if nerrs > Prims.int_zero + then FStarC_Compiler_Effect.exit Prims.int_one + else (); + FStarC_Compiler_Effect.exit Prims.int_zero)) + | FStarC_Getopt.Success -> + (FStarC_Main.setup_hooks (); + (let uu___5 = FStarC_Tests_Pars.init () in ()); + FStarC_Tests_Pars.parse_incremental_decls (); + FStarC_Tests_Pars.parse_incremental_decls_use_lang + (); + FStarC_Tests_Norm.run_all (); + (let uu___9 = FStarC_Tests_Unif.run_all () in + if uu___9 + then () + else FStarC_Compiler_Effect.exit Prims.int_one); + FStarC_Tests_Data.run_all (); + (let uu___11 = FStarC_Errors.report_all () in ()); + (let nerrs = FStarC_Errors.get_err_count () in + if nerrs > Prims.int_zero + then FStarC_Compiler_Effect.exit Prims.int_one + else (); + FStarC_Compiler_Effect.exit Prims.int_zero))))) () + with + | FStarC_Errors.Error (err, msg, r, _ctx) when + let uu___2 = FStarC_Options.trace_error () in + Prims.op_Negation uu___2 -> + (if r = FStarC_Compiler_Range_Type.dummyRange + then + (let uu___3 = FStarC_Errors_Msg.rendermsg msg in + FStarC_Compiler_Util.print_string uu___3) + else + (let uu___4 = FStarC_Compiler_Range_Ops.string_of_range r in + let uu___5 = FStarC_Errors_Msg.rendermsg msg in + FStarC_Compiler_Util.print2 "%s: %s\n" uu___4 uu___5); + FStarC_Compiler_Effect.exit Prims.int_one) + | e -> + ((let uu___3 = FStarC_Compiler_Util.message_of_exn e in + let uu___4 = FStarC_Compiler_Util.trace_of_exn e in + FStarC_Compiler_Util.print2_error "Error\n%s\n%s\n" uu___3 uu___4); + FStarC_Compiler_Effect.exit Prims.int_one)) \ No newline at end of file diff --git a/ocaml/fstar-tests/generated/FStarC_Tests_Unif.ml b/ocaml/fstar-tests/generated/FStarC_Tests_Unif.ml new file mode 100644 index 00000000000..19566a6d979 --- /dev/null +++ b/ocaml/fstar-tests/generated/FStarC_Tests_Unif.ml @@ -0,0 +1,590 @@ +open Prims +let (tcenv : unit -> FStarC_TypeChecker_Env.env) = + fun uu___ -> FStarC_Tests_Pars.init () +let (guard_to_string : + FStarC_TypeChecker_Common.guard_formula -> Prims.string) = + fun g -> + match g with + | FStarC_TypeChecker_Common.Trivial -> "trivial" + | FStarC_TypeChecker_Common.NonTrivial f -> + let uu___ = tcenv () in + FStarC_TypeChecker_Normalize.term_to_string uu___ f +let (success : Prims.bool FStarC_Compiler_Effect.ref) = + FStarC_Compiler_Util.mk_ref true +let (fail : Prims.string -> unit) = + fun msg -> + FStarC_Compiler_Util.print_string msg; + FStarC_Compiler_Effect.op_Colon_Equals success false +let (guard_eq : + Prims.int -> + FStarC_TypeChecker_Common.guard_formula -> + FStarC_TypeChecker_Common.guard_formula -> unit) + = + fun i -> + fun g -> + fun g' -> + let uu___ = + match (g, g') with + | (FStarC_TypeChecker_Common.Trivial, + FStarC_TypeChecker_Common.Trivial) -> (true, g, g') + | (FStarC_TypeChecker_Common.NonTrivial f, + FStarC_TypeChecker_Common.NonTrivial f') -> + let f1 = + let uu___1 = tcenv () in + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.EraseUniverses] uu___1 f in + let f'1 = + let uu___1 = tcenv () in + FStarC_TypeChecker_Normalize.normalize + [FStarC_TypeChecker_Env.EraseUniverses] uu___1 f' in + let uu___1 = FStarC_Tests_Util.term_eq f1 f'1 in + (uu___1, (FStarC_TypeChecker_Common.NonTrivial f1), + (FStarC_TypeChecker_Common.NonTrivial f'1)) + | uu___1 -> (false, g, g') in + match uu___ with + | (b, g1, g'1) -> + (if Prims.op_Negation b + then + (let uu___2 = + let uu___3 = FStarC_Compiler_Util.string_of_int i in + let uu___4 = guard_to_string g'1 in + let uu___5 = guard_to_string g1 in + FStarC_Compiler_Util.format3 + "Test %s failed:\n\tExpected guard %s;\n\tGot guard %s\n" + uu___3 uu___4 uu___5 in + fail uu___2) + else (); + (let uu___2 = (FStarC_Compiler_Effect.op_Bang success) && b in + FStarC_Compiler_Effect.op_Colon_Equals success uu___2)) +let (unify : + Prims.int -> + FStarC_Syntax_Syntax.bv Prims.list -> + FStarC_Syntax_Syntax.typ -> + FStarC_Syntax_Syntax.typ -> + FStarC_TypeChecker_Common.guard_formula -> (unit -> unit) -> unit) + = + fun i -> + fun bvs -> + fun x -> + fun y -> + fun g' -> + fun check -> + (let uu___1 = FStarC_Compiler_Util.string_of_int i in + FStarC_Compiler_Util.print1 "%s ..." uu___1); + (let uu___2 = FStarC_Main.process_args () in ()); + (let uu___3 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term x in + let uu___4 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term y in + FStarC_Compiler_Util.print2 "Unify %s\nand %s\n" uu___3 uu___4); + (let tcenv1 = tcenv () in + let tcenv2 = FStarC_TypeChecker_Env.push_bvs tcenv1 bvs in + let g = + let uu___3 = + let uu___4 = FStarC_TypeChecker_Rel.teq tcenv2 x y in + FStarC_TypeChecker_Rel.solve_deferred_constraints tcenv2 + uu___4 in + FStarC_TypeChecker_Rel.simplify_guard tcenv2 uu___3 in + guard_eq i g.FStarC_TypeChecker_Common.guard_f g'; + check (); + FStarC_Options.init ()) +let (should_fail : + FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.typ -> unit) = + fun x -> + fun y -> + try + (fun uu___ -> + match () with + | () -> + let g = + let uu___1 = tcenv () in + let uu___2 = + let uu___3 = tcenv () in + FStarC_TypeChecker_Rel.teq uu___3 x y in + FStarC_TypeChecker_Rel.solve_deferred_constraints uu___1 + uu___2 in + (match g.FStarC_TypeChecker_Common.guard_f with + | FStarC_TypeChecker_Common.Trivial -> + let uu___1 = + let uu___2 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term x in + let uu___3 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term y in + FStarC_Compiler_Util.format2 + "%s and %s should not be unifiable\n" uu___2 uu___3 in + fail uu___1 + | FStarC_TypeChecker_Common.NonTrivial f -> + let uu___1 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term x in + let uu___2 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term y in + let uu___3 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term f in + FStarC_Compiler_Util.print3 + "%s and %s are unifiable if %s\n" uu___1 uu___2 uu___3)) + () + with + | FStarC_Errors.Error (e, msg, r, _ctx) -> + let uu___1 = FStarC_Errors_Msg.rendermsg msg in + FStarC_Compiler_Util.print1 "%s\n" uu___1 +let (unify' : Prims.string -> Prims.string -> unit) = + fun x -> + fun y -> + let x1 = FStarC_Tests_Pars.pars x in + let y1 = FStarC_Tests_Pars.pars y in + let g = + let uu___ = tcenv () in + let uu___1 = + let uu___2 = tcenv () in FStarC_TypeChecker_Rel.teq uu___2 x1 y1 in + FStarC_TypeChecker_Rel.solve_deferred_constraints uu___ uu___1 in + let uu___ = FStarC_Class_Show.show FStarC_Syntax_Print.showable_term x1 in + let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term y1 in + let uu___2 = guard_to_string g.FStarC_TypeChecker_Common.guard_f in + FStarC_Compiler_Util.print3 "%s and %s are unifiable with guard %s\n" + uu___ uu___1 uu___2 +let (norm : FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.term) = + fun t -> + let uu___ = tcenv () in FStarC_TypeChecker_Normalize.normalize [] uu___ t +let (check_core : + Prims.int -> + Prims.bool -> + Prims.bool -> + FStarC_Syntax_Syntax.typ -> FStarC_Syntax_Syntax.typ -> unit) + = + fun i -> + fun subtyping -> + fun guard_ok -> + fun x -> + fun y -> + (let uu___1 = FStarC_Main.process_args () in ()); + (let env = tcenv () in + let res = + if subtyping + then + FStarC_TypeChecker_Core.check_term_subtyping true true env x + y + else + FStarC_TypeChecker_Core.check_term_equality true true env x + y in + (match res with + | FStar_Pervasives.Inl (FStar_Pervasives_Native.None) -> + let uu___2 = FStarC_Compiler_Util.string_of_int i in + FStarC_Compiler_Util.print1 "%s core check ok\n" uu___2 + | FStar_Pervasives.Inl (FStar_Pervasives_Native.Some g) -> + ((let uu___3 = FStarC_Compiler_Util.string_of_int i in + let uu___4 = + FStarC_Class_Show.show + FStarC_Syntax_Print.showable_term g in + FStarC_Compiler_Util.print2 + "%s core check computed guard %s ok\n" uu___3 uu___4); + if Prims.op_Negation guard_ok + then FStarC_Compiler_Effect.op_Colon_Equals success false + else ()) + | FStar_Pervasives.Inr err -> + (FStarC_Compiler_Effect.op_Colon_Equals success false; + (let uu___3 = FStarC_Compiler_Util.string_of_int i in + let uu___4 = FStarC_TypeChecker_Core.print_error err in + FStarC_Compiler_Util.print2 "%s failed\n%s\n" uu___3 + uu___4))); + FStarC_Options.init ()) +let (check_core_typing : + Prims.int -> FStarC_Syntax_Syntax.term -> FStarC_Syntax_Syntax.typ -> unit) + = + fun i -> + fun e -> + fun t -> + (let uu___1 = FStarC_Main.process_args () in ()); + (let env = tcenv () in + (let uu___2 = FStarC_TypeChecker_Core.check_term env e t true in + match uu___2 with + | FStar_Pervasives.Inl (FStar_Pervasives_Native.None) -> + let uu___3 = FStarC_Compiler_Util.string_of_int i in + FStarC_Compiler_Util.print1 "%s core typing ok\n" uu___3 + | FStar_Pervasives.Inl (FStar_Pervasives_Native.Some g) -> + ((let uu___4 = FStarC_Compiler_Util.string_of_int i in + FStarC_Compiler_Util.print1 + "%s core typing produced a guard\n" uu___4); + FStarC_Compiler_Effect.op_Colon_Equals success false) + | FStar_Pervasives.Inr err -> + (FStarC_Compiler_Effect.op_Colon_Equals success false; + (let uu___4 = FStarC_Compiler_Util.string_of_int i in + let uu___5 = FStarC_TypeChecker_Core.print_error err in + FStarC_Compiler_Util.print2 "%s failed\n%s\n" uu___4 uu___5))); + FStarC_Options.init ()) +let (inst : + Prims.int -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + (FStarC_Syntax_Syntax.term * FStarC_Syntax_Syntax.term Prims.list)) + = + fun n -> + fun tm -> + let rec aux out n1 = + if n1 = Prims.int_zero + then out + else + (let uu___1 = + let uu___2 = FStarC_Tests_Pars.init () in + FStarC_TypeChecker_Util.new_implicit_var "" + FStarC_Compiler_Range_Type.dummyRange uu___2 + FStarC_Syntax_Util.ktype0 false in + match uu___1 with + | (t, uu___2, uu___3) -> + let uu___4 = + let uu___5 = FStarC_Tests_Pars.init () in + FStarC_TypeChecker_Util.new_implicit_var "" + FStarC_Compiler_Range_Type.dummyRange uu___5 t false in + (match uu___4 with + | (u, uu___5, uu___6) -> aux (u :: out) (n1 - Prims.int_one))) in + let us = aux [] n in + let uu___ = let uu___1 = FStarC_Tests_Util.app tm us in norm uu___1 in + (uu___, us) +let (run_all : unit -> Prims.bool) = + fun uu___ -> + FStarC_Compiler_Util.print_string "Testing the unifier\n"; + FStarC_Options.__set_unit_tests (); + (let unify_check n bvs x y g f = unify n bvs x y g f in + let unify1 n bvs x y g = unify n bvs x y g (fun uu___3 -> ()) in + let int_t = FStarC_Tests_Pars.tc "Prims.int" in + let x_bv = + FStarC_Syntax_Syntax.gen_bv "x" FStar_Pervasives_Native.None int_t in + let y_bv = + FStarC_Syntax_Syntax.gen_bv "y" FStar_Pervasives_Native.None int_t in + let x = FStarC_Syntax_Syntax.bv_to_name x_bv in + let y = FStarC_Syntax_Syntax.bv_to_name y_bv in + unify1 Prims.int_zero [x_bv] x x FStarC_TypeChecker_Common.Trivial; + (let uu___5 = + let uu___6 = + FStarC_Syntax_Util.mk_eq2 FStarC_Syntax_Syntax.U_zero + FStarC_Syntax_Util.t_bool x y in + FStarC_TypeChecker_Common.NonTrivial uu___6 in + unify1 Prims.int_one [x_bv; y_bv] x y uu___5); + (let id = FStarC_Tests_Pars.tc "fun (x:bool) -> x" in + (let uu___6 = FStarC_Tests_Util.app id [x] in + unify1 (Prims.of_int (2)) [x_bv] x uu___6 + FStarC_TypeChecker_Common.Trivial); + (let id1 = FStarC_Tests_Pars.tc "fun (x:bool) -> x" in + unify1 (Prims.of_int (3)) [] id1 id1 FStarC_TypeChecker_Common.Trivial; + (let id2 = FStarC_Tests_Pars.tc "fun (x:bool) -> x" in + let id' = FStarC_Tests_Pars.tc "fun (y:bool) -> y" in + unify1 (Prims.of_int (4)) [] id2 id' + FStarC_TypeChecker_Common.Trivial; + (let uu___9 = FStarC_Tests_Pars.tc "fun (x y:bool) -> x" in + let uu___10 = FStarC_Tests_Pars.tc "fun (a b:bool) -> a" in + unify1 (Prims.of_int (5)) [] uu___9 uu___10 + FStarC_TypeChecker_Common.Trivial); + (let uu___10 = FStarC_Tests_Pars.tc "fun (x y z:bool) -> y" in + let uu___11 = FStarC_Tests_Pars.tc "fun (a b c:bool) -> b" in + unify1 (Prims.of_int (6)) [] uu___10 uu___11 + FStarC_TypeChecker_Common.Trivial); + (let uu___11 = FStarC_Tests_Pars.tc "fun (x:int) (y:int) -> y" in + let uu___12 = FStarC_Tests_Pars.tc "fun (x:int) (y:int) -> x" in + let uu___13 = + let uu___14 = + FStarC_Tests_Pars.tc "(forall (x:int). (forall (y:int). y==x))" in + FStarC_TypeChecker_Common.NonTrivial uu___14 in + unify1 (Prims.of_int (7)) [] uu___11 uu___12 uu___13); + (let uu___12 = + FStarC_Tests_Pars.tc "fun (x:int) (y:int) (z:int) -> y" in + let uu___13 = + FStarC_Tests_Pars.tc "fun (x:int) (y:int) (z:int) -> z" in + let uu___14 = + let uu___15 = + FStarC_Tests_Pars.tc + "(forall (x:int). (forall (y:int). (forall (z:int). y==z)))" in + FStarC_TypeChecker_Common.NonTrivial uu___15 in + unify1 (Prims.of_int (8)) [] uu___12 uu___13 uu___14); + (let uu___13 = FStarC_Main.process_args () in ()); + (let uu___13 = + let uu___14 = + FStarC_Tests_Pars.tc "fun (u:Type0 -> Type0) (x:Type0) -> u x" in + inst Prims.int_one uu___14 in + match uu___13 with + | (tm, us) -> + let sol = FStarC_Tests_Pars.tc "fun (x:Type0) -> Prims.pair x x" in + (unify_check (Prims.of_int (9)) [] tm sol + FStarC_TypeChecker_Common.Trivial + (fun uu___15 -> + let uu___16 = + let uu___17 = + let uu___18 = FStarC_Compiler_List.hd us in + norm uu___18 in + let uu___18 = norm sol in + FStarC_Tests_Util.term_eq uu___17 uu___18 in + FStarC_Tests_Util.always (Prims.of_int (9)) uu___16); + (let uu___15 = + let uu___16 = + FStarC_Tests_Pars.tc + "fun (u: int -> int -> int) (x:int) -> u x" in + inst Prims.int_one uu___16 in + match uu___15 with + | (tm1, us1) -> + let sol1 = FStarC_Tests_Pars.tc "fun (x y:int) -> x + y" in + (unify_check (Prims.of_int (10)) [] tm1 sol1 + FStarC_TypeChecker_Common.Trivial + (fun uu___17 -> + let uu___18 = + let uu___19 = + let uu___20 = FStarC_Compiler_List.hd us1 in + norm uu___20 in + let uu___20 = norm sol1 in + FStarC_Tests_Util.term_eq uu___19 uu___20 in + FStarC_Tests_Util.always (Prims.of_int (10)) uu___18); + (let tm11 = + FStarC_Tests_Pars.tc "x:int -> y:int{eq2 y x} -> bool" in + let tm2 = FStarC_Tests_Pars.tc "x:int -> y:int -> bool" in + (let uu___18 = + let uu___19 = + FStarC_Tests_Pars.tc + "forall (x:int). (forall (y:int). y==x)" in + FStarC_TypeChecker_Common.NonTrivial uu___19 in + unify1 (Prims.of_int (11)) [] tm11 tm2 uu___18); + (let tm12 = + FStarC_Tests_Pars.tc + "a:Type0 -> b:(a -> Type0) -> x:a -> y:b x -> Tot Type0" in + let tm21 = + FStarC_Tests_Pars.tc + "a:Type0 -> b:(a -> Type0) -> x:a -> y:b x -> Tot Type0" in + unify1 (Prims.of_int (12)) [] tm12 tm21 + FStarC_TypeChecker_Common.Trivial; + (let uu___19 = + let int_typ = FStarC_Tests_Pars.tc "int" in + let x1 = + FStarC_Syntax_Syntax.new_bv + FStar_Pervasives_Native.None int_typ in + let typ = FStarC_Tests_Pars.tc "unit -> Type0" in + let l = + FStarC_Tests_Pars.tc + "fun (q:(unit -> Type0)) -> q ()" in + let q = + FStarC_Syntax_Syntax.new_bv + FStar_Pervasives_Native.None typ in + let tm13 = + let uu___20 = + let uu___21 = + let uu___22 = + FStarC_Syntax_Syntax.bv_to_name q in + [uu___22] in + FStarC_Tests_Util.app l uu___21 in + norm uu___20 in + let l1 = + FStarC_Tests_Pars.tc "fun (p:unit -> Type0) -> p" in + let unit = FStarC_Tests_Pars.tc "()" in + let env = + let uu___20 = FStarC_Tests_Pars.init () in + let uu___21 = + let uu___22 = FStarC_Syntax_Syntax.mk_binder x1 in + let uu___23 = + let uu___24 = FStarC_Syntax_Syntax.mk_binder q in + [uu___24] in + uu___22 :: uu___23 in + FStarC_TypeChecker_Env.push_binders uu___20 + uu___21 in + let uu___20 = + FStarC_TypeChecker_Util.new_implicit_var "" + FStarC_Compiler_Range_Type.dummyRange env typ + false in + match uu___20 with + | (u_p, uu___21, uu___22) -> + let tm22 = + let uu___23 = + let uu___24 = FStarC_Tests_Util.app l1 [u_p] in + norm uu___24 in + FStarC_Tests_Util.app uu___23 [unit] in + (tm13, tm22, [x1; q]) in + match uu___19 with + | (tm13, tm22, bvs_13) -> + (unify1 (Prims.of_int (13)) bvs_13 tm13 tm22 + FStarC_TypeChecker_Common.Trivial; + (let uu___21 = + let int_typ = FStarC_Tests_Pars.tc "int" in + let x1 = + FStarC_Syntax_Syntax.new_bv + FStar_Pervasives_Native.None int_typ in + let typ = + FStarC_Tests_Pars.tc "pure_post unit" in + let l = + FStarC_Tests_Pars.tc + "fun (q:pure_post unit) -> q ()" in + let q = + FStarC_Syntax_Syntax.new_bv + FStar_Pervasives_Native.None typ in + let tm14 = + let uu___22 = + let uu___23 = + let uu___24 = + FStarC_Syntax_Syntax.bv_to_name q in + [uu___24] in + FStarC_Tests_Util.app l uu___23 in + norm uu___22 in + let l1 = + FStarC_Tests_Pars.tc + "fun (p:pure_post unit) -> p" in + let unit = FStarC_Tests_Pars.tc "()" in + let env = + let uu___22 = FStarC_Tests_Pars.init () in + let uu___23 = + let uu___24 = + FStarC_Syntax_Syntax.mk_binder x1 in + let uu___25 = + let uu___26 = + FStarC_Syntax_Syntax.mk_binder q in + [uu___26] in + uu___24 :: uu___25 in + FStarC_TypeChecker_Env.push_binders uu___22 + uu___23 in + let uu___22 = + FStarC_TypeChecker_Util.new_implicit_var "" + FStarC_Compiler_Range_Type.dummyRange env + typ false in + match uu___22 with + | (u_p, uu___23, uu___24) -> + let tm23 = + let uu___25 = + let uu___26 = + FStarC_Tests_Util.app l1 [u_p] in + norm uu___26 in + FStarC_Tests_Util.app uu___25 [unit] in + (tm14, tm23, [x1; q]) in + match uu___21 with + | (tm14, tm23, bvs_14) -> + (unify1 (Prims.of_int (14)) bvs_14 tm14 tm23 + FStarC_TypeChecker_Common.Trivial; + (let uu___23 = + FStarC_Tests_Pars.pars_and_tc_fragment + "let ty0 n = x:int { x >= n }\nlet ty1 n = x:ty0 n { x > n }\nassume val tc (t:Type0) : Type0"; + (let t0 = FStarC_Tests_Pars.tc "ty1 17" in + let t1 = + FStarC_Tests_Pars.tc + "x:ty0 17 { x > 17 }" in + (t0, t1)) in + match uu___23 with + | (tm15, tm24) -> + (check_core (Prims.of_int (15)) false + false tm15 tm24; + (let uu___25 = + let t0 = + FStarC_Tests_Pars.tc + "x:int { x >= 17 /\\ x > 17 }" in + let t1 = + FStarC_Tests_Pars.tc + "x:ty0 17 { x > 17 }" in + (t0, t1) in + match uu___25 with + | (tm16, tm25) -> + (check_core (Prims.of_int (16)) + false false tm16 tm25; + (let uu___27 = + FStarC_Tests_Pars.pars_and_tc_fragment + "let defn17_0 (x:nat) : nat -> nat -> Type0 = fun y z -> a:int { a + x == y + z }"; + (let t0 = + FStarC_Tests_Pars.tc + "defn17_0 0 1 2" in + let t1_head = + FStarC_Tests_Pars.tc + "(defn17_0 0)" in + let arg1 = + FStarC_Tests_Pars.tc "1" in + let arg2 = + FStarC_Tests_Pars.tc "2" in + let t1 = + FStarC_Syntax_Syntax.mk_Tm_app + t1_head + [(arg1, + FStar_Pervasives_Native.None); + (arg2, + FStar_Pervasives_Native.None)] + t0.FStarC_Syntax_Syntax.pos in + (t0, t1)) in + match uu___27 with + | (tm17, tm26) -> + (check_core + (Prims.of_int (17)) + false false tm17 tm26; + (let uu___29 = + let t0 = + FStarC_Tests_Pars.tc + "dp:((dtuple2 int (fun (y:int) -> z:int{ z > y })) <: Type0) { let (| x, _ |) = dp in x > 17 }" in + let t1 = + FStarC_Tests_Pars.tc + "(dtuple2 int (fun (y:int) -> z:int{ z > y }))" in + (t0, t1) in + match uu___29 with + | (tm18, tm27) -> + (check_core + (Prims.of_int (18)) + true false tm18 + tm27; + (let uu___31 = + FStarC_Tests_Pars.pars_and_tc_fragment + "type vprop' = { t:Type0 ; n:nat }"; + (let t0 = + FStarC_Tests_Pars.tc + "x:(({ t=bool; n=0 }).t <: Type0) { x == false }" in + let t1 = + FStarC_Tests_Pars.tc + "x:bool{ x == false }" in + (t0, t1)) in + match uu___31 with + | (tm19, tm28) -> + (check_core + (Prims.of_int (19)) + false false + tm19 tm28; + (let uu___33 + = + let t0 = + FStarC_Tests_Pars.tc + "int" in + let t1 = + FStarC_Tests_Pars.tc + "j:(i:nat{ i > 17 } <: Type0){j > 42}" in + (t0, t1) in + match uu___33 + with + | (tm110, + tm29) -> + (check_core + (Prims.of_int (20)) + true true + tm110 + tm29; + (let uu___35 + = + FStarC_Tests_Pars.pars_and_tc_fragment + "assume val tstr21 (x:string) : Type0"; + ( + let t0 = + FStarC_Tests_Pars.tc + "(fun (x:bool) (y:int) (z: (fun (x:string) -> tstr21 x) \"hello\") -> x)" in + let ty = + FStarC_Tests_Pars.tc + "bool -> int -> tstr21 \"hello\" -> bool" in + (t0, ty)) in + match uu___35 + with + | + (tm3, ty) + -> + (check_core_typing + (Prims.of_int (21)) + tm3 ty; + FStarC_Options.__clear_unit_tests + (); + (let uu___39 + = + FStarC_Compiler_Effect.op_Bang + success in + if + uu___39 + then + FStarC_Compiler_Util.print_string + "Unifier ok\n" + else ()); + FStarC_Compiler_Effect.op_Bang + success)))))))))))))))))))))))))))) \ No newline at end of file diff --git a/ocaml/fstar-tests/generated/FStarC_Tests_Util.ml b/ocaml/fstar-tests/generated/FStarC_Tests_Util.ml new file mode 100644 index 00000000000..c0ade574c38 --- /dev/null +++ b/ocaml/fstar-tests/generated/FStarC_Tests_Util.ml @@ -0,0 +1,341 @@ +open Prims +let (always : Prims.int -> Prims.bool -> unit) = + fun id -> + fun b -> + if b + then () + else + (let uu___1 = + let uu___2 = FStarC_Compiler_Util.string_of_int id in + FStarC_Compiler_Util.format1 "Assertion failed: test %s" uu___2 in + FStarC_Errors.raise_error0 + FStarC_Errors_Codes.Fatal_AssertionFailure () + (Obj.magic FStarC_Errors_Msg.is_error_message_string) + (Obj.magic uu___1)) +let (x : FStarC_Syntax_Syntax.bv) = + FStarC_Syntax_Syntax.gen_bv "x" FStar_Pervasives_Native.None + FStarC_Syntax_Syntax.tun +let (y : FStarC_Syntax_Syntax.bv) = + FStarC_Syntax_Syntax.gen_bv "y" FStar_Pervasives_Native.None + FStarC_Syntax_Syntax.tun +let (n : FStarC_Syntax_Syntax.bv) = + FStarC_Syntax_Syntax.gen_bv "n" FStar_Pervasives_Native.None + FStarC_Syntax_Syntax.tun +let (h : FStarC_Syntax_Syntax.bv) = + FStarC_Syntax_Syntax.gen_bv "h" FStar_Pervasives_Native.None + FStarC_Syntax_Syntax.tun +let (m : FStarC_Syntax_Syntax.bv) = + FStarC_Syntax_Syntax.gen_bv "m" FStar_Pervasives_Native.None + FStarC_Syntax_Syntax.tun +let tm : 'uuuuu . 'uuuuu -> 'uuuuu FStarC_Syntax_Syntax.syntax = + fun t -> FStarC_Syntax_Syntax.mk t FStarC_Compiler_Range_Type.dummyRange +let (nm : FStarC_Syntax_Syntax.bv -> FStarC_Syntax_Syntax.term) = + fun x1 -> FStarC_Syntax_Syntax.bv_to_name x1 +let (app : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term Prims.list -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax) + = + fun x1 -> + fun ts -> + let uu___ = + let uu___1 = + let uu___2 = + FStarC_Compiler_List.map FStarC_Syntax_Syntax.as_arg ts in + { FStarC_Syntax_Syntax.hd = x1; FStarC_Syntax_Syntax.args = uu___2 + } in + FStarC_Syntax_Syntax.Tm_app uu___1 in + FStarC_Syntax_Syntax.mk uu___ FStarC_Compiler_Range_Type.dummyRange +let rec (term_eq' : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> Prims.bool) + = + fun t1 -> + fun t2 -> + let t11 = FStarC_Syntax_Subst.compress t1 in + let t21 = FStarC_Syntax_Subst.compress t2 in + let binders_eq xs ys = + ((FStarC_Compiler_List.length xs) = (FStarC_Compiler_List.length ys)) + && + (FStarC_Compiler_List.forall2 + (fun x1 -> + fun y1 -> + term_eq' + (x1.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort + (y1.FStarC_Syntax_Syntax.binder_bv).FStarC_Syntax_Syntax.sort) + xs ys) in + let args_eq xs ys = + ((FStarC_Compiler_List.length xs) = (FStarC_Compiler_List.length ys)) + && + (FStarC_Compiler_List.forall2 + (fun uu___ -> + fun uu___1 -> + match (uu___, uu___1) with + | ((a, imp), (b, imp')) -> + (term_eq' a b) && + (FStarC_Syntax_Util.eq_aqual imp imp')) xs ys) in + let comp_eq c d = + match ((c.FStarC_Syntax_Syntax.n), (d.FStarC_Syntax_Syntax.n)) with + | (FStarC_Syntax_Syntax.Total t, FStarC_Syntax_Syntax.Total s) -> + term_eq' t s + | (FStarC_Syntax_Syntax.Comp ct1, FStarC_Syntax_Syntax.Comp ct2) -> + ((FStarC_Ident.lid_equals ct1.FStarC_Syntax_Syntax.effect_name + ct2.FStarC_Syntax_Syntax.effect_name) + && + (term_eq' ct1.FStarC_Syntax_Syntax.result_typ + ct2.FStarC_Syntax_Syntax.result_typ)) + && + (args_eq ct1.FStarC_Syntax_Syntax.effect_args + ct2.FStarC_Syntax_Syntax.effect_args) + | uu___ -> false in + match ((t11.FStarC_Syntax_Syntax.n), (t21.FStarC_Syntax_Syntax.n)) with + | (FStarC_Syntax_Syntax.Tm_lazy l, uu___) -> + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Compiler_Effect.op_Bang + FStarC_Syntax_Syntax.lazy_chooser in + FStarC_Compiler_Util.must uu___3 in + uu___2 l.FStarC_Syntax_Syntax.lkind l in + term_eq' uu___1 t21 + | (uu___, FStarC_Syntax_Syntax.Tm_lazy l) -> + let uu___1 = + let uu___2 = + let uu___3 = + FStarC_Compiler_Effect.op_Bang + FStarC_Syntax_Syntax.lazy_chooser in + FStarC_Compiler_Util.must uu___3 in + uu___2 l.FStarC_Syntax_Syntax.lkind l in + term_eq' t11 uu___1 + | (FStarC_Syntax_Syntax.Tm_bvar x1, FStarC_Syntax_Syntax.Tm_bvar y1) -> + x1.FStarC_Syntax_Syntax.index = y1.FStarC_Syntax_Syntax.index + | (FStarC_Syntax_Syntax.Tm_name x1, FStarC_Syntax_Syntax.Tm_name y1) -> + FStarC_Syntax_Syntax.bv_eq x1 y1 + | (FStarC_Syntax_Syntax.Tm_fvar f, FStarC_Syntax_Syntax.Tm_fvar g) -> + FStarC_Syntax_Syntax.fv_eq f g + | (FStarC_Syntax_Syntax.Tm_uinst (t, uu___), + FStarC_Syntax_Syntax.Tm_uinst (s, uu___1)) -> term_eq' t s + | (FStarC_Syntax_Syntax.Tm_constant c1, + FStarC_Syntax_Syntax.Tm_constant c2) -> FStarC_Const.eq_const c1 c2 + | (FStarC_Syntax_Syntax.Tm_type u, FStarC_Syntax_Syntax.Tm_type v) -> + u = v + | (FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = xs; FStarC_Syntax_Syntax.body = t; + FStarC_Syntax_Syntax.rc_opt = uu___;_}, + FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = ys; FStarC_Syntax_Syntax.body = u; + FStarC_Syntax_Syntax.rc_opt = uu___1;_}) + when + (FStarC_Compiler_List.length xs) = (FStarC_Compiler_List.length ys) + -> (binders_eq xs ys) && (term_eq' t u) + | (FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = xs; FStarC_Syntax_Syntax.body = t; + FStarC_Syntax_Syntax.rc_opt = uu___;_}, + FStarC_Syntax_Syntax.Tm_abs + { FStarC_Syntax_Syntax.bs = ys; FStarC_Syntax_Syntax.body = u; + FStarC_Syntax_Syntax.rc_opt = uu___1;_}) + -> + if + (FStarC_Compiler_List.length xs) > + (FStarC_Compiler_List.length ys) + then + let uu___2 = + FStarC_Compiler_Util.first_N (FStarC_Compiler_List.length ys) + xs in + (match uu___2 with + | (xs1, xs') -> + let t12 = + let uu___3 = + let uu___4 = + let uu___5 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs = xs'; + FStarC_Syntax_Syntax.body = t; + FStarC_Syntax_Syntax.rc_opt = + FStar_Pervasives_Native.None + }) t11.FStarC_Syntax_Syntax.pos in + { + FStarC_Syntax_Syntax.bs = xs1; + FStarC_Syntax_Syntax.body = uu___5; + FStarC_Syntax_Syntax.rc_opt = + FStar_Pervasives_Native.None + } in + FStarC_Syntax_Syntax.Tm_abs uu___4 in + FStarC_Syntax_Syntax.mk uu___3 + t11.FStarC_Syntax_Syntax.pos in + term_eq' t12 t21) + else + (let uu___3 = + FStarC_Compiler_Util.first_N (FStarC_Compiler_List.length xs) + ys in + match uu___3 with + | (ys1, ys') -> + let t22 = + let uu___4 = + let uu___5 = + let uu___6 = + FStarC_Syntax_Syntax.mk + (FStarC_Syntax_Syntax.Tm_abs + { + FStarC_Syntax_Syntax.bs = ys'; + FStarC_Syntax_Syntax.body = u; + FStarC_Syntax_Syntax.rc_opt = + FStar_Pervasives_Native.None + }) t21.FStarC_Syntax_Syntax.pos in + { + FStarC_Syntax_Syntax.bs = ys1; + FStarC_Syntax_Syntax.body = uu___6; + FStarC_Syntax_Syntax.rc_opt = + FStar_Pervasives_Native.None + } in + FStarC_Syntax_Syntax.Tm_abs uu___5 in + FStarC_Syntax_Syntax.mk uu___4 + t21.FStarC_Syntax_Syntax.pos in + term_eq' t11 t22) + | (FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = xs; FStarC_Syntax_Syntax.comp = c;_}, + FStarC_Syntax_Syntax.Tm_arrow + { FStarC_Syntax_Syntax.bs1 = ys; FStarC_Syntax_Syntax.comp = d;_}) + -> (binders_eq xs ys) && (comp_eq c d) + | (FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = x1; FStarC_Syntax_Syntax.phi = t;_}, + FStarC_Syntax_Syntax.Tm_refine + { FStarC_Syntax_Syntax.b = y1; FStarC_Syntax_Syntax.phi = u;_}) -> + (term_eq' x1.FStarC_Syntax_Syntax.sort y1.FStarC_Syntax_Syntax.sort) + && (term_eq' t u) + | (FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar fv_eq_1; + FStarC_Syntax_Syntax.pos = uu___; + FStarC_Syntax_Syntax.vars = uu___1; + FStarC_Syntax_Syntax.hash_code = uu___2;_}; + FStarC_Syntax_Syntax.args = + (uu___3, FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = uu___4;_})::t12::t22::[];_}, + FStarC_Syntax_Syntax.Tm_app + { + FStarC_Syntax_Syntax.hd = + { FStarC_Syntax_Syntax.n = FStarC_Syntax_Syntax.Tm_fvar fv_eq_2; + FStarC_Syntax_Syntax.pos = uu___5; + FStarC_Syntax_Syntax.vars = uu___6; + FStarC_Syntax_Syntax.hash_code = uu___7;_}; + FStarC_Syntax_Syntax.args = + (uu___8, FStar_Pervasives_Native.Some + { FStarC_Syntax_Syntax.aqual_implicit = true; + FStarC_Syntax_Syntax.aqual_attributes = uu___9;_})::s1::s2::[];_}) + when + (FStarC_Syntax_Syntax.fv_eq_lid fv_eq_1 FStarC_Parser_Const.eq2_lid) + && + (FStarC_Syntax_Syntax.fv_eq_lid fv_eq_2 + FStarC_Parser_Const.eq2_lid) + -> args_eq [s1; s2] [t12; t22] + | (FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = t; FStarC_Syntax_Syntax.args = args;_}, + FStarC_Syntax_Syntax.Tm_app + { FStarC_Syntax_Syntax.hd = s; FStarC_Syntax_Syntax.args = args';_}) + -> (term_eq' t s) && (args_eq args args') + | (FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = t; + FStarC_Syntax_Syntax.ret_opt = FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.brs = pats; + FStarC_Syntax_Syntax.rc_opt1 = uu___;_}, + FStarC_Syntax_Syntax.Tm_match + { FStarC_Syntax_Syntax.scrutinee = t'; + FStarC_Syntax_Syntax.ret_opt = FStar_Pervasives_Native.None; + FStarC_Syntax_Syntax.brs = pats'; + FStarC_Syntax_Syntax.rc_opt1 = uu___1;_}) + -> + (((FStarC_Compiler_List.length pats) = + (FStarC_Compiler_List.length pats')) + && + (FStarC_Compiler_List.forall2 + (fun uu___2 -> + fun uu___3 -> + match (uu___2, uu___3) with + | ((uu___4, uu___5, e), (uu___6, uu___7, e')) -> + term_eq' e e') pats pats')) + && (term_eq' t t') + | (FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = t12; + FStarC_Syntax_Syntax.asc = + (FStar_Pervasives.Inl t22, uu___, uu___1); + FStarC_Syntax_Syntax.eff_opt = uu___2;_}, + FStarC_Syntax_Syntax.Tm_ascribed + { FStarC_Syntax_Syntax.tm = s1; + FStarC_Syntax_Syntax.asc = + (FStar_Pervasives.Inl s2, uu___3, uu___4); + FStarC_Syntax_Syntax.eff_opt = uu___5;_}) + -> (term_eq' t12 s1) && (term_eq' t22 s2) + | (FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (is_rec, lbs); + FStarC_Syntax_Syntax.body1 = t;_}, + FStarC_Syntax_Syntax.Tm_let + { FStarC_Syntax_Syntax.lbs = (is_rec', lbs'); + FStarC_Syntax_Syntax.body1 = s;_}) + when is_rec = is_rec' -> + (((FStarC_Compiler_List.length lbs) = + (FStarC_Compiler_List.length lbs')) + && + (FStarC_Compiler_List.forall2 + (fun lb1 -> + fun lb2 -> + (term_eq' lb1.FStarC_Syntax_Syntax.lbtyp + lb2.FStarC_Syntax_Syntax.lbtyp) + && + (term_eq' lb1.FStarC_Syntax_Syntax.lbdef + lb2.FStarC_Syntax_Syntax.lbdef)) lbs lbs')) + && (term_eq' t s) + | (FStarC_Syntax_Syntax.Tm_uvar (u, uu___), + FStarC_Syntax_Syntax.Tm_uvar (u', uu___1)) -> + FStarC_Syntax_Unionfind.equiv u.FStarC_Syntax_Syntax.ctx_uvar_head + u'.FStarC_Syntax_Syntax.ctx_uvar_head + | (FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t12; + FStarC_Syntax_Syntax.meta = uu___;_}, + uu___1) -> term_eq' t12 t21 + | (uu___, FStarC_Syntax_Syntax.Tm_meta + { FStarC_Syntax_Syntax.tm2 = t22; + FStarC_Syntax_Syntax.meta = uu___1;_}) + -> term_eq' t11 t22 + | (FStarC_Syntax_Syntax.Tm_delayed uu___, uu___1) -> + let uu___2 = + let uu___3 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t11 in + let uu___4 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t21 in + FStarC_Compiler_Util.format2 "Impossible: %s and %s" uu___3 + uu___4 in + failwith uu___2 + | (uu___, FStarC_Syntax_Syntax.Tm_delayed uu___1) -> + let uu___2 = + let uu___3 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t11 in + let uu___4 = + FStarC_Class_Tagged.tag_of FStarC_Syntax_Syntax.tagged_term t21 in + FStarC_Compiler_Util.format2 "Impossible: %s and %s" uu___3 + uu___4 in + failwith uu___2 + | (FStarC_Syntax_Syntax.Tm_unknown, FStarC_Syntax_Syntax.Tm_unknown) -> + true + | uu___ -> false +let (term_eq : + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> + FStarC_Syntax_Syntax.term' FStarC_Syntax_Syntax.syntax -> Prims.bool) + = + fun t1 -> + fun t2 -> + let b = term_eq' t1 t2 in + if Prims.op_Negation b + then + (let uu___1 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t1 in + let uu___2 = + FStarC_Class_Show.show FStarC_Syntax_Print.showable_term t2 in + FStarC_Compiler_Util.print2 + ">>>>>>>>>>>Term %s is not equal to %s\n" uu___1 uu___2) + else (); + b \ No newline at end of file diff --git a/ocaml/fstar-tests/generated/FStar_Tests_Data.ml b/ocaml/fstar-tests/generated/FStar_Tests_Data.ml deleted file mode 100644 index 714e8c95f8b..00000000000 --- a/ocaml/fstar-tests/generated/FStar_Tests_Data.ml +++ /dev/null @@ -1,173 +0,0 @@ -open Prims -let rec insert : - 'set . - Prims.int -> - (Prims.int, 'set) FStar_Class_Setlike.setlike -> 'set -> 'set - = - fun n -> - fun uu___ -> - fun s -> - if n = Prims.int_zero - then s - else - (let uu___2 = - Obj.magic - (FStar_Class_Setlike.add () (Obj.magic uu___) n (Obj.magic s)) in - insert (n - Prims.int_one) uu___ uu___2) -let rec all_mem : - 'set . - Prims.int -> - (Prims.int, 'set) FStar_Class_Setlike.setlike -> 'set -> Prims.bool - = - fun n -> - fun uu___ -> - fun s -> - if n = Prims.int_zero - then true - else - (FStar_Class_Setlike.mem () (Obj.magic uu___) n (Obj.magic s)) && - (all_mem (n - Prims.int_one) uu___ s) -let rec all_remove : - 'set . - Prims.int -> - (Prims.int, 'set) FStar_Class_Setlike.setlike -> 'set -> 'set - = - fun n -> - fun uu___ -> - fun s -> - if n = Prims.int_zero - then s - else - (let uu___2 = - Obj.magic - (FStar_Class_Setlike.remove () (Obj.magic uu___) n - (Obj.magic s)) in - all_remove (n - Prims.int_one) uu___ uu___2) -let (nn : Prims.int) = (Prims.of_int (10000)) -let (run_all : unit -> unit) = - fun uu___ -> - FStar_Compiler_Util.print_string "data tests\n"; - (let uu___2 = - FStar_Compiler_Util.record_time - (fun uu___3 -> - let uu___4 = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Class_Ord.ord_int)) ()) in - insert nn - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Class_Ord.ord_int) uu___4) in - match uu___2 with - | (f, ms) -> - ((let uu___4 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) ms in - FStar_Compiler_Util.print1 "FlatSet insert: %s\n" uu___4); - (let uu___4 = - FStar_Compiler_Util.record_time - (fun uu___5 -> - all_mem nn - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Class_Ord.ord_int) f) in - match uu___4 with - | (f_ok, ms1) -> - ((let uu___6 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) ms1 in - FStar_Compiler_Util.print1 "FlatSet all_mem: %s\n" uu___6); - (let uu___6 = - FStar_Compiler_Util.record_time - (fun uu___7 -> - all_remove nn - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Class_Ord.ord_int) f) in - match uu___6 with - | (f1, ms2) -> - ((let uu___8 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) ms2 in - FStar_Compiler_Util.print1 "FlatSet all_remove: %s\n" - uu___8); - if Prims.op_Negation f_ok - then failwith "FlatSet all_mem failed" - else (); - (let uu___10 = - let uu___11 = - FStar_Class_Setlike.is_empty () - (Obj.magic - (FStar_Compiler_FlatSet.setlike_flat_set - FStar_Class_Ord.ord_int)) (Obj.magic f1) in - Prims.op_Negation uu___11 in - if uu___10 - then failwith "FlatSet all_remove failed" - else ()); - (let uu___10 = - FStar_Compiler_Util.record_time - (fun uu___11 -> - let uu___12 = - Obj.magic - (FStar_Class_Setlike.empty () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_int)) ()) in - insert nn - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_int) uu___12) in - match uu___10 with - | (rb, ms3) -> - ((let uu___12 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) ms3 in - FStar_Compiler_Util.print1 "RBSet insert: %s\n" - uu___12); - (let uu___12 = - FStar_Compiler_Util.record_time - (fun uu___13 -> - all_mem nn - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_int) rb) in - match uu___12 with - | (rb_ok, ms4) -> - ((let uu___14 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - ms4 in - FStar_Compiler_Util.print1 - "RBSet all_mem: %s\n" uu___14); - (let uu___14 = - FStar_Compiler_Util.record_time - (fun uu___15 -> - all_remove nn - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_int) rb) in - match uu___14 with - | (rb1, ms5) -> - ((let uu___16 = - FStar_Class_Show.show - (FStar_Class_Show.printableshow - FStar_Class_Printable.printable_int) - ms5 in - FStar_Compiler_Util.print1 - "RBSet all_remove: %s\n" uu___16); - if Prims.op_Negation rb_ok - then failwith "RBSet all_mem failed" - else (); - (let uu___18 = - let uu___19 = - FStar_Class_Setlike.is_empty () - (Obj.magic - (FStar_Compiler_RBSet.setlike_rbset - FStar_Class_Ord.ord_int)) - (Obj.magic rb1) in - Prims.op_Negation uu___19 in - if uu___18 - then - failwith "RBSet all_remove failed" - else ()))))))))))))) \ No newline at end of file diff --git a/ocaml/fstar-tests/generated/FStar_Tests_Norm.ml b/ocaml/fstar-tests/generated/FStar_Tests_Norm.ml deleted file mode 100644 index 5401773a557..00000000000 --- a/ocaml/fstar-tests/generated/FStar_Tests_Norm.ml +++ /dev/null @@ -1,1472 +0,0 @@ -open Prims -let (b : FStar_Syntax_Syntax.bv -> FStar_Syntax_Syntax.binder) = - FStar_Syntax_Syntax.mk_binder -let (id : FStar_Syntax_Syntax.term) = FStar_Tests_Pars.pars "fun x -> x" -let (apply : FStar_Syntax_Syntax.term) = - FStar_Tests_Pars.pars "fun f x -> f x" -let (twice : FStar_Syntax_Syntax.term) = - FStar_Tests_Pars.pars "fun f x -> f (f x)" -let (tt : FStar_Syntax_Syntax.term) = FStar_Tests_Pars.pars "fun x y -> x" -let (ff : FStar_Syntax_Syntax.term) = FStar_Tests_Pars.pars "fun x y -> y" -let (z : FStar_Syntax_Syntax.term) = FStar_Tests_Pars.pars "fun f x -> x" -let (one : FStar_Syntax_Syntax.term) = FStar_Tests_Pars.pars "fun f x -> f x" -let (two : FStar_Syntax_Syntax.term) = - FStar_Tests_Pars.pars "fun f x -> f (f x)" -let (succ : FStar_Syntax_Syntax.term) = - FStar_Tests_Pars.pars "fun n f x -> f (n f x)" -let (pred : FStar_Syntax_Syntax.term) = - FStar_Tests_Pars.pars - "fun n f x -> n (fun g h -> h (g f)) (fun y -> x) (fun y -> y)" -let (mul : FStar_Syntax_Syntax.term) = - FStar_Tests_Pars.pars "fun m n f -> m (n f)" -let rec (encode : Prims.int -> FStar_Syntax_Syntax.term) = - fun n -> - if n = Prims.int_zero - then z - else - (let uu___1 = let uu___2 = encode (n - Prims.int_one) in [uu___2] in - FStar_Tests_Util.app succ uu___1) -let (minus : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = fun m -> fun n -> FStar_Tests_Util.app n [pred; m] -let (let_ : - FStar_Syntax_Syntax.bv -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term) - = - fun x -> - fun e -> - fun e' -> - let uu___ = - let uu___1 = let uu___2 = b x in [uu___2] in - FStar_Syntax_Util.abs uu___1 e' FStar_Pervasives_Native.None in - FStar_Tests_Util.app uu___ [e] -let (mk_let : - FStar_Syntax_Syntax.bv -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) - = - fun x -> - fun e -> - fun e' -> - let e'1 = - FStar_Syntax_Subst.subst - [FStar_Syntax_Syntax.NM (x, Prims.int_zero)] e' in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_let - { - FStar_Syntax_Syntax.lbs = - (false, - [{ - FStar_Syntax_Syntax.lbname = (FStar_Pervasives.Inl x); - FStar_Syntax_Syntax.lbunivs = []; - FStar_Syntax_Syntax.lbtyp = FStar_Syntax_Syntax.tun; - FStar_Syntax_Syntax.lbeff = - FStar_Parser_Const.effect_Tot_lid; - FStar_Syntax_Syntax.lbdef = e; - FStar_Syntax_Syntax.lbattrs = []; - FStar_Syntax_Syntax.lbpos = - FStar_Compiler_Range_Type.dummyRange - }]); - FStar_Syntax_Syntax.body1 = e'1 - }) FStar_Compiler_Range_Type.dummyRange -let (lid : Prims.string -> FStar_Ident.lident) = - fun x -> - FStar_Ident.lid_of_path ["Test"; x] FStar_Compiler_Range_Type.dummyRange -let (znat_l : FStar_Syntax_Syntax.fv) = - let uu___ = lid "Z" in - FStar_Syntax_Syntax.lid_as_fv uu___ - (FStar_Pervasives_Native.Some FStar_Syntax_Syntax.Data_ctor) -let (snat_l : FStar_Syntax_Syntax.fv) = - let uu___ = lid "S" in - FStar_Syntax_Syntax.lid_as_fv uu___ - (FStar_Pervasives_Native.Some FStar_Syntax_Syntax.Data_ctor) -let (tm_fv : - FStar_Syntax_Syntax.fv -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun fv -> - FStar_Syntax_Syntax.mk (FStar_Syntax_Syntax.Tm_fvar fv) - FStar_Compiler_Range_Type.dummyRange -let (znat : FStar_Syntax_Syntax.term) = tm_fv znat_l -let (snat : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun s -> - let uu___ = - let uu___1 = - let uu___2 = tm_fv snat_l in - let uu___3 = let uu___4 = FStar_Syntax_Syntax.as_arg s in [uu___4] in - { FStar_Syntax_Syntax.hd = uu___2; FStar_Syntax_Syntax.args = uu___3 - } in - FStar_Syntax_Syntax.Tm_app uu___1 in - FStar_Syntax_Syntax.mk uu___ FStar_Compiler_Range_Type.dummyRange -let pat : 'uuuuu . 'uuuuu -> 'uuuuu FStar_Syntax_Syntax.withinfo_t = - fun p -> - FStar_Syntax_Syntax.withinfo p FStar_Compiler_Range_Type.dummyRange -let (snat_type : FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) = - let uu___ = - let uu___1 = lid "snat" in - FStar_Syntax_Syntax.lid_as_fv uu___1 FStar_Pervasives_Native.None in - tm_fv uu___ -let (mk_match : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.branch Prims.list -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun h -> - fun branches -> - let branches1 = - FStar_Compiler_List.map FStar_Syntax_Util.branch branches in - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_match - { - FStar_Syntax_Syntax.scrutinee = h; - FStar_Syntax_Syntax.ret_opt = FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.brs = branches1; - FStar_Syntax_Syntax.rc_opt1 = FStar_Pervasives_Native.None - }) FStar_Compiler_Range_Type.dummyRange -let (pred_nat : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun s -> - let zbranch = - let uu___ = - pat - (FStar_Syntax_Syntax.Pat_cons - (znat_l, FStar_Pervasives_Native.None, [])) in - (uu___, FStar_Pervasives_Native.None, znat) in - let sbranch = - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - pat (FStar_Syntax_Syntax.Pat_var FStar_Tests_Util.x) in - (uu___5, false) in - [uu___4] in - (snat_l, FStar_Pervasives_Native.None, uu___3) in - FStar_Syntax_Syntax.Pat_cons uu___2 in - pat uu___1 in - let uu___1 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_bvar - { - FStar_Syntax_Syntax.ppname = - (FStar_Tests_Util.x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = Prims.int_zero; - FStar_Syntax_Syntax.sort = - (FStar_Tests_Util.x.FStar_Syntax_Syntax.sort) - }) FStar_Compiler_Range_Type.dummyRange in - (uu___, FStar_Pervasives_Native.None, uu___1) in - mk_match s [zbranch; sbranch] -let (minus_nat : - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun t1 -> - fun t2 -> - let minus1 = FStar_Tests_Util.m in - let x = - { - FStar_Syntax_Syntax.ppname = - (FStar_Tests_Util.x.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (FStar_Tests_Util.x.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = snat_type - } in - let y = - { - FStar_Syntax_Syntax.ppname = - (FStar_Tests_Util.y.FStar_Syntax_Syntax.ppname); - FStar_Syntax_Syntax.index = - (FStar_Tests_Util.y.FStar_Syntax_Syntax.index); - FStar_Syntax_Syntax.sort = snat_type - } in - let zbranch = - let uu___ = - pat - (FStar_Syntax_Syntax.Pat_cons - (znat_l, FStar_Pervasives_Native.None, [])) in - let uu___1 = FStar_Tests_Util.nm x in - (uu___, FStar_Pervasives_Native.None, uu___1) in - let sbranch = - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = - let uu___5 = - pat (FStar_Syntax_Syntax.Pat_var FStar_Tests_Util.n) in - (uu___5, false) in - [uu___4] in - (snat_l, FStar_Pervasives_Native.None, uu___3) in - FStar_Syntax_Syntax.Pat_cons uu___2 in - pat uu___1 in - let uu___1 = - let uu___2 = FStar_Tests_Util.nm minus1 in - let uu___3 = - let uu___4 = - let uu___5 = FStar_Tests_Util.nm x in pred_nat uu___5 in - let uu___5 = - let uu___6 = FStar_Tests_Util.nm FStar_Tests_Util.n in [uu___6] in - uu___4 :: uu___5 in - FStar_Tests_Util.app uu___2 uu___3 in - (uu___, FStar_Pervasives_Native.None, uu___1) in - let lb = - let uu___ = - FStar_Ident.lid_of_path ["Pure"] - FStar_Compiler_Range_Type.dummyRange in - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = b x in - let uu___5 = let uu___6 = b y in [uu___6] in uu___4 :: uu___5 in - let uu___4 = - let uu___5 = FStar_Tests_Util.nm y in - mk_match uu___5 [zbranch; sbranch] in - FStar_Syntax_Util.abs uu___3 uu___4 FStar_Pervasives_Native.None in - FStar_Syntax_Subst.subst - [FStar_Syntax_Syntax.NM (minus1, Prims.int_zero)] uu___2 in - { - FStar_Syntax_Syntax.lbname = (FStar_Pervasives.Inl minus1); - FStar_Syntax_Syntax.lbunivs = []; - FStar_Syntax_Syntax.lbtyp = FStar_Syntax_Syntax.tun; - FStar_Syntax_Syntax.lbeff = uu___; - FStar_Syntax_Syntax.lbdef = uu___1; - FStar_Syntax_Syntax.lbattrs = []; - FStar_Syntax_Syntax.lbpos = FStar_Compiler_Range_Type.dummyRange - } in - let uu___ = - let uu___1 = - let uu___2 = - let uu___3 = - let uu___4 = FStar_Tests_Util.nm minus1 in - FStar_Tests_Util.app uu___4 [t1; t2] in - FStar_Syntax_Subst.subst - [FStar_Syntax_Syntax.NM (minus1, Prims.int_zero)] uu___3 in - { - FStar_Syntax_Syntax.lbs = (true, [lb]); - FStar_Syntax_Syntax.body1 = uu___2 - } in - FStar_Syntax_Syntax.Tm_let uu___1 in - FStar_Syntax_Syntax.mk uu___ FStar_Compiler_Range_Type.dummyRange -let (encode_nat : Prims.int -> FStar_Syntax_Syntax.term) = - fun n -> - let rec aux out n1 = - if n1 = Prims.int_zero - then out - else (let uu___1 = snat out in aux uu___1 (n1 - Prims.int_one)) in - aux znat n -let (default_tests : - (Prims.int * FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax * - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) Prims.list) - = - FStar_Tests_Pars.pars_and_tc_fragment - "let rec copy (x:list int) : Tot (list int) = match x with | [] -> [] | hd::tl -> hd::copy tl"; - FStar_Tests_Pars.pars_and_tc_fragment - "let recons (x:list 'a) : Tot (list 'a) = match x with | [] -> [] | hd::tl -> hd::tl"; - FStar_Tests_Pars.pars_and_tc_fragment - "let rev (x:list 'a) : Tot (list 'a) = let rec aux (x:list 'a) (out:list 'a) : Tot (list 'a) = match x with | [] -> out | hd::tl -> aux tl (hd::out) in aux x []"; - FStar_Tests_Pars.pars_and_tc_fragment - "type t = | A : int -> int -> t | B : int -> int -> t let f = function | A x y | B y x -> y - x"; - FStar_Tests_Pars.pars_and_tc_fragment "type snat = | Z | S : snat -> snat"; - FStar_Tests_Pars.pars_and_tc_fragment "type tb = | T | F"; - FStar_Tests_Pars.pars_and_tc_fragment "type rb = | A1 | A2 | A3"; - FStar_Tests_Pars.pars_and_tc_fragment "type hb = | H : tb -> hb"; - FStar_Tests_Pars.pars_and_tc_fragment - "let select (i:tb) (x:'a) (y:'a) : Tot 'a = match i with | T -> x | F -> y"; - FStar_Tests_Pars.pars_and_tc_fragment - "let select_int3 (i:int) (x:'a) (y:'a) (z:'a) : Tot 'a = match i with | 0 -> x | 1 -> y | _ -> z"; - FStar_Tests_Pars.pars_and_tc_fragment - "let select_bool (b:bool) (x:'a) (y:'a) : Tot 'a = if b then x else y"; - FStar_Tests_Pars.pars_and_tc_fragment - "let select_string3 (s:string) (x:'a) (y:'a) (z:'a) : Tot 'a = match s with | \"abc\" -> x | \"def\" -> y | _ -> z"; - FStar_Tests_Pars.pars_and_tc_fragment - "let recons_m (x:list tb) = match x with | [] -> [] | hd::tl -> hd::tl"; - FStar_Tests_Pars.pars_and_tc_fragment - "let rec copy_tb_list_2 (x:list tb) : Tot (list tb) = match x with | [] -> [] | [hd] -> [hd]\n | hd1::hd2::tl -> hd1::hd2::copy_tb_list_2 tl"; - FStar_Tests_Pars.pars_and_tc_fragment - "let rec copy_list_2 (x:list 'a) : Tot (list 'a) = match x with | [] -> [] | [hd] -> [hd]\n | hd1::hd2::tl -> hd1::hd2::copy_list_2 tl"; - FStar_Tests_Pars.pars_and_tc_fragment "let (x1:int{x1>3}) = 6"; - FStar_Tests_Pars.pars_and_tc_fragment - "let (x2:int{x2+1>3 /\\ not (x2-5>0)}) = 2"; - FStar_Tests_Pars.pars_and_tc_fragment "let my_plus (x:int) (y:int) = x + y"; - FStar_Tests_Pars.pars_and_tc_fragment - "let (x3:int{forall (a:nat). a > x2}) = 7"; - FStar_Tests_Pars.pars_and_tc_fragment "let idd (x: 'a) = x"; - FStar_Tests_Pars.pars_and_tc_fragment - "let revtb (x: tb) = match x with | T -> F | F -> T"; - FStar_Tests_Pars.pars_and_tc_fragment "let id_tb (x: tb) = x"; - FStar_Tests_Pars.pars_and_tc_fragment "let fst_a (x: 'a) (y: 'a) = x"; - FStar_Tests_Pars.pars_and_tc_fragment "let id_list (x: list 'a) = x"; - FStar_Tests_Pars.pars_and_tc_fragment "let id_list_m (x: list tb) = x"; - (let uu___25 = - let uu___26 = - let uu___27 = - let uu___28 = - let uu___29 = - let uu___30 = FStar_Tests_Util.nm FStar_Tests_Util.n in - [uu___30] in - id :: uu___29 in - one :: uu___28 in - FStar_Tests_Util.app apply uu___27 in - let uu___27 = FStar_Tests_Util.nm FStar_Tests_Util.n in - (Prims.int_zero, uu___26, uu___27) in - let uu___26 = - let uu___27 = - let uu___28 = - let uu___29 = - let uu___30 = FStar_Tests_Util.nm FStar_Tests_Util.x in [uu___30] in - FStar_Tests_Util.app id uu___29 in - let uu___29 = FStar_Tests_Util.nm FStar_Tests_Util.x in - (Prims.int_one, uu___28, uu___29) in - let uu___28 = - let uu___29 = - let uu___30 = - let uu___31 = - let uu___32 = - let uu___33 = FStar_Tests_Util.nm FStar_Tests_Util.n in - let uu___34 = - let uu___35 = FStar_Tests_Util.nm FStar_Tests_Util.m in - [uu___35] in - uu___33 :: uu___34 in - tt :: uu___32 in - FStar_Tests_Util.app apply uu___31 in - let uu___31 = FStar_Tests_Util.nm FStar_Tests_Util.n in - (Prims.int_one, uu___30, uu___31) in - let uu___30 = - let uu___31 = - let uu___32 = - let uu___33 = - let uu___34 = - let uu___35 = FStar_Tests_Util.nm FStar_Tests_Util.n in - let uu___36 = - let uu___37 = FStar_Tests_Util.nm FStar_Tests_Util.m in - [uu___37] in - uu___35 :: uu___36 in - ff :: uu___34 in - FStar_Tests_Util.app apply uu___33 in - let uu___33 = FStar_Tests_Util.nm FStar_Tests_Util.m in - ((Prims.of_int (2)), uu___32, uu___33) in - let uu___32 = - let uu___33 = - let uu___34 = - let uu___35 = - let uu___36 = - let uu___37 = - let uu___38 = - let uu___39 = - let uu___40 = - let uu___41 = - let uu___42 = - FStar_Tests_Util.nm FStar_Tests_Util.n in - let uu___43 = - let uu___44 = - FStar_Tests_Util.nm FStar_Tests_Util.m in - [uu___44] in - uu___42 :: uu___43 in - ff :: uu___41 in - apply :: uu___40 in - apply :: uu___39 in - apply :: uu___38 in - apply :: uu___37 in - apply :: uu___36 in - FStar_Tests_Util.app apply uu___35 in - let uu___35 = FStar_Tests_Util.nm FStar_Tests_Util.m in - ((Prims.of_int (3)), uu___34, uu___35) in - let uu___34 = - let uu___35 = - let uu___36 = - let uu___37 = - let uu___38 = - let uu___39 = - let uu___40 = FStar_Tests_Util.nm FStar_Tests_Util.n in - let uu___41 = - let uu___42 = FStar_Tests_Util.nm FStar_Tests_Util.m in - [uu___42] in - uu___40 :: uu___41 in - ff :: uu___39 in - apply :: uu___38 in - FStar_Tests_Util.app twice uu___37 in - let uu___37 = FStar_Tests_Util.nm FStar_Tests_Util.m in - ((Prims.of_int (4)), uu___36, uu___37) in - let uu___36 = - let uu___37 = - let uu___38 = minus one z in - ((Prims.of_int (5)), uu___38, one) in - let uu___38 = - let uu___39 = - let uu___40 = FStar_Tests_Util.app pred [one] in - ((Prims.of_int (6)), uu___40, z) in - let uu___40 = - let uu___41 = - let uu___42 = minus one one in - ((Prims.of_int (7)), uu___42, z) in - let uu___42 = - let uu___43 = - let uu___44 = FStar_Tests_Util.app mul [one; one] in - ((Prims.of_int (8)), uu___44, one) in - let uu___44 = - let uu___45 = - let uu___46 = FStar_Tests_Util.app mul [two; one] in - ((Prims.of_int (9)), uu___46, two) in - let uu___46 = - let uu___47 = - let uu___48 = - let uu___49 = - let uu___50 = FStar_Tests_Util.app succ [one] in - [uu___50; one] in - FStar_Tests_Util.app mul uu___49 in - ((Prims.of_int (10)), uu___48, two) in - let uu___48 = - let uu___49 = - let uu___50 = - let uu___51 = encode (Prims.of_int (10)) in - let uu___52 = encode (Prims.of_int (10)) in - minus uu___51 uu___52 in - ((Prims.of_int (11)), uu___50, z) in - let uu___50 = - let uu___51 = - let uu___52 = - let uu___53 = encode (Prims.of_int (100)) in - let uu___54 = encode (Prims.of_int (100)) in - minus uu___53 uu___54 in - ((Prims.of_int (12)), uu___52, z) in - let uu___52 = - let uu___53 = - let uu___54 = - let uu___55 = encode (Prims.of_int (100)) in - let uu___56 = - let uu___57 = - FStar_Tests_Util.nm FStar_Tests_Util.x in - let uu___58 = - FStar_Tests_Util.nm FStar_Tests_Util.x in - minus uu___57 uu___58 in - let_ FStar_Tests_Util.x uu___55 uu___56 in - ((Prims.of_int (13)), uu___54, z) in - let uu___54 = - let uu___55 = - let uu___56 = - let uu___57 = - FStar_Tests_Util.app succ [one] in - let uu___58 = - let uu___59 = - let uu___60 = - let uu___61 = - FStar_Tests_Util.nm - FStar_Tests_Util.x in - let uu___62 = - let uu___63 = - FStar_Tests_Util.nm - FStar_Tests_Util.x in - [uu___63] in - uu___61 :: uu___62 in - FStar_Tests_Util.app mul uu___60 in - let uu___60 = - let uu___61 = - let uu___62 = - let uu___63 = - FStar_Tests_Util.nm - FStar_Tests_Util.y in - let uu___64 = - let uu___65 = - FStar_Tests_Util.nm - FStar_Tests_Util.y in - [uu___65] in - uu___63 :: uu___64 in - FStar_Tests_Util.app mul uu___62 in - let uu___62 = - let uu___63 = - FStar_Tests_Util.nm - FStar_Tests_Util.h in - let uu___64 = - FStar_Tests_Util.nm - FStar_Tests_Util.h in - minus uu___63 uu___64 in - let_ FStar_Tests_Util.h uu___61 - uu___62 in - let_ FStar_Tests_Util.y uu___59 - uu___60 in - let_ FStar_Tests_Util.x uu___57 uu___58 in - ((Prims.of_int (15)), uu___56, z) in - let uu___56 = - let uu___57 = - let uu___58 = - let uu___59 = - FStar_Tests_Util.app succ [one] in - let uu___60 = - let uu___61 = - let uu___62 = - let uu___63 = - FStar_Tests_Util.nm - FStar_Tests_Util.x in - let uu___64 = - let uu___65 = - FStar_Tests_Util.nm - FStar_Tests_Util.x in - [uu___65] in - uu___63 :: uu___64 in - FStar_Tests_Util.app mul uu___62 in - let uu___62 = - let uu___63 = - let uu___64 = - let uu___65 = - FStar_Tests_Util.nm - FStar_Tests_Util.y in - let uu___66 = - let uu___67 = - FStar_Tests_Util.nm - FStar_Tests_Util.y in - [uu___67] in - uu___65 :: uu___66 in - FStar_Tests_Util.app mul uu___64 in - let uu___64 = - let uu___65 = - FStar_Tests_Util.nm - FStar_Tests_Util.h in - let uu___66 = - FStar_Tests_Util.nm - FStar_Tests_Util.h in - minus uu___65 uu___66 in - mk_let FStar_Tests_Util.h uu___63 - uu___64 in - mk_let FStar_Tests_Util.y uu___61 - uu___62 in - mk_let FStar_Tests_Util.x uu___59 - uu___60 in - ((Prims.of_int (16)), uu___58, z) in - let uu___58 = - let uu___59 = - let uu___60 = - let uu___61 = - FStar_Tests_Util.app succ [one] in - let uu___62 = - let uu___63 = - let uu___64 = - let uu___65 = - FStar_Tests_Util.nm - FStar_Tests_Util.x in - let uu___66 = - let uu___67 = - FStar_Tests_Util.nm - FStar_Tests_Util.x in - [uu___67] in - uu___65 :: uu___66 in - FStar_Tests_Util.app mul uu___64 in - let uu___64 = - let uu___65 = - let uu___66 = - let uu___67 = - FStar_Tests_Util.nm - FStar_Tests_Util.y in - let uu___68 = - let uu___69 = - FStar_Tests_Util.nm - FStar_Tests_Util.y in - [uu___69] in - uu___67 :: uu___68 in - FStar_Tests_Util.app mul - uu___66 in - let uu___66 = - let uu___67 = - FStar_Tests_Util.nm - FStar_Tests_Util.h in - let uu___68 = - FStar_Tests_Util.nm - FStar_Tests_Util.h in - minus uu___67 uu___68 in - let_ FStar_Tests_Util.h uu___65 - uu___66 in - let_ FStar_Tests_Util.y uu___63 - uu___64 in - let_ FStar_Tests_Util.x uu___61 - uu___62 in - ((Prims.of_int (17)), uu___60, z) in - let uu___60 = - let uu___61 = - let uu___62 = - let uu___63 = - let uu___64 = snat znat in - snat uu___64 in - pred_nat uu___63 in - let uu___63 = snat znat in - ((Prims.of_int (18)), uu___62, - uu___63) in - let uu___62 = - let uu___63 = - let uu___64 = - let uu___65 = - let uu___66 = - let uu___67 = snat znat in - snat uu___67 in - let uu___67 = snat znat in - minus_nat uu___66 uu___67 in - FStar_Tests_Pars.tc_term uu___65 in - let uu___65 = snat znat in - ((Prims.of_int (19)), uu___64, - uu___65) in - let uu___64 = - let uu___65 = - let uu___66 = - let uu___67 = - let uu___68 = - encode_nat - (Prims.of_int (10)) in - let uu___69 = - encode_nat - (Prims.of_int (10)) in - minus_nat uu___68 uu___69 in - FStar_Tests_Pars.tc_term - uu___67 in - ((Prims.of_int (20)), uu___66, - znat) in - let uu___66 = - let uu___67 = - let uu___68 = - let uu___69 = - let uu___70 = - encode_nat - (Prims.of_int (100)) in - let uu___71 = - encode_nat - (Prims.of_int (100)) in - minus_nat uu___70 uu___71 in - FStar_Tests_Pars.tc_term - uu___69 in - ((Prims.of_int (21)), uu___68, - znat) in - let uu___68 = - let uu___69 = - let uu___70 = - FStar_Tests_Pars.tc - "recons [0;1]" in - let uu___71 = - FStar_Tests_Pars.tc - "[0;1]" in - ((Prims.of_int (24)), - uu___70, uu___71) in - let uu___70 = - let uu___71 = - let uu___72 = - FStar_Tests_Pars.tc - "recons [false;true;false]" in - let uu___73 = - FStar_Tests_Pars.tc - "[false;true;false]" in - ((Prims.of_int (241)), - uu___72, uu___73) in - let uu___72 = - let uu___73 = - let uu___74 = - FStar_Tests_Pars.tc - "copy [0;1]" in - let uu___75 = - FStar_Tests_Pars.tc - "[0;1]" in - ((Prims.of_int (25)), - uu___74, uu___75) in - let uu___74 = - let uu___75 = - let uu___76 = - FStar_Tests_Pars.tc - "rev [0;1;2;3;4;5;6;7;8;9;10]" in - let uu___77 = - FStar_Tests_Pars.tc - "[10;9;8;7;6;5;4;3;2;1;0]" in - ((Prims.of_int (26)), - uu___76, uu___77) in - let uu___76 = - let uu___77 = - let uu___78 = - FStar_Tests_Pars.tc - "(fun x y z q -> z) T T F T" in - let uu___79 = - FStar_Tests_Pars.tc - "F" in - ((Prims.of_int (28)), - uu___78, uu___79) in - let uu___78 = - let uu___79 = - let uu___80 = - FStar_Tests_Pars.tc - "[T; F]" in - let uu___81 = - FStar_Tests_Pars.tc - "[T; F]" in - ((Prims.of_int (29)), - uu___80, - uu___81) in - let uu___80 = - let uu___81 = - let uu___82 = - FStar_Tests_Pars.tc - "id_tb T" in - let uu___83 = - FStar_Tests_Pars.tc - "T" in - ((Prims.of_int (31)), - uu___82, - uu___83) in - let uu___82 = - let uu___83 = - let uu___84 = - FStar_Tests_Pars.tc - "(fun #a x -> x) #tb T" in - let uu___85 = - FStar_Tests_Pars.tc - "T" in - ((Prims.of_int (32)), - uu___84, - uu___85) in - let uu___84 = - let uu___85 = - let uu___86 - = - FStar_Tests_Pars.tc - "revtb T" in - let uu___87 - = - FStar_Tests_Pars.tc - "F" in - ((Prims.of_int (33)), - uu___86, - uu___87) in - let uu___86 = - let uu___87 - = - let uu___88 - = - FStar_Tests_Pars.tc - "(fun x y -> x) T F" in - let uu___89 - = - FStar_Tests_Pars.tc - "T" in - ((Prims.of_int (34)), - uu___88, - uu___89) in - let uu___88 - = - let uu___89 - = - let uu___90 - = - FStar_Tests_Pars.tc - "fst_a T F" in - let uu___91 - = - FStar_Tests_Pars.tc - "T" in - ((Prims.of_int (35)), - uu___90, - uu___91) in - let uu___90 - = - let uu___91 - = - let uu___92 - = - FStar_Tests_Pars.tc - "idd T" in - let uu___93 - = - FStar_Tests_Pars.tc - "T" in - ((Prims.of_int (36)), - uu___92, - uu___93) in - let uu___92 - = - let uu___93 - = - let uu___94 - = - FStar_Tests_Pars.tc - "id_list [T]" in - let uu___95 - = - FStar_Tests_Pars.tc - "[T]" in - ((Prims.of_int (301)), - uu___94, - uu___95) in - let uu___94 - = - let uu___95 - = - let uu___96 - = - FStar_Tests_Pars.tc - "id_list_m [T]" in - let uu___97 - = - FStar_Tests_Pars.tc - "[T]" in - ((Prims.of_int (3012)), - uu___96, - uu___97) in - let uu___96 - = - let uu___97 - = - let uu___98 - = - FStar_Tests_Pars.tc - "recons_m [T; F]" in - let uu___99 - = - FStar_Tests_Pars.tc - "[T; F]" in - ((Prims.of_int (302)), - uu___98, - uu___99) in - let uu___98 - = - let uu___99 - = - let uu___100 - = - FStar_Tests_Pars.tc - "select T A1 A3" in - let uu___101 - = - FStar_Tests_Pars.tc - "A1" in - ((Prims.of_int (303)), - uu___100, - uu___101) in - let uu___100 - = - let uu___101 - = - let uu___102 - = - FStar_Tests_Pars.tc - "select T 3 4" in - let uu___103 - = - FStar_Tests_Pars.tc - "3" in - ((Prims.of_int (3031)), - uu___102, - uu___103) in - let uu___102 - = - let uu___103 - = - let uu___104 - = - FStar_Tests_Pars.tc - "select_bool false 3 4" in - let uu___105 - = - FStar_Tests_Pars.tc - "4" in - ((Prims.of_int (3032)), - uu___104, - uu___105) in - let uu___104 - = - let uu___105 - = - let uu___106 - = - FStar_Tests_Pars.tc - "select_int3 1 7 8 9" in - let uu___107 - = - FStar_Tests_Pars.tc - "8" in - ((Prims.of_int (3033)), - uu___106, - uu___107) in - let uu___106 - = - let uu___107 - = - let uu___108 - = - FStar_Tests_Pars.tc - "[5]" in - let uu___109 - = - FStar_Tests_Pars.tc - "[5]" in - ((Prims.of_int (3034)), - uu___108, - uu___109) in - let uu___108 - = - let uu___109 - = - let uu___110 - = - FStar_Tests_Pars.tc - "[\"abcd\"]" in - let uu___111 - = - FStar_Tests_Pars.tc - "[\"abcd\"]" in - ((Prims.of_int (3035)), - uu___110, - uu___111) in - let uu___110 - = - let uu___111 - = - let uu___112 - = - FStar_Tests_Pars.tc - "select_string3 \"def\" 5 6 7" in - let uu___113 - = - FStar_Tests_Pars.tc - "6" in - ((Prims.of_int (3036)), - uu___112, - uu___113) in - let uu___112 - = - let uu___113 - = - let uu___114 - = - FStar_Tests_Pars.tc - "idd T" in - let uu___115 - = - FStar_Tests_Pars.tc - "T" in - ((Prims.of_int (305)), - uu___114, - uu___115) in - let uu___114 - = - let uu___115 - = - let uu___116 - = - FStar_Tests_Pars.tc - "recons [T]" in - let uu___117 - = - FStar_Tests_Pars.tc - "[T]" in - ((Prims.of_int (306)), - uu___116, - uu___117) in - let uu___116 - = - let uu___117 - = - let uu___118 - = - FStar_Tests_Pars.tc - "copy_tb_list_2 [T;F;T;F;T;F;F]" in - let uu___119 - = - FStar_Tests_Pars.tc - "[T;F;T;F;T;F;F]" in - ((Prims.of_int (307)), - uu___118, - uu___119) in - let uu___118 - = - let uu___119 - = - let uu___120 - = - FStar_Tests_Pars.tc - "copy_list_2 [T;F;T;F;T;F;F]" in - let uu___121 - = - FStar_Tests_Pars.tc - "[T;F;T;F;T;F;F]" in - ((Prims.of_int (308)), - uu___120, - uu___121) in - let uu___120 - = - let uu___121 - = - let uu___122 - = - FStar_Tests_Pars.tc - "rev [T; F; F]" in - let uu___123 - = - FStar_Tests_Pars.tc - "[F; F; T]" in - ((Prims.of_int (304)), - uu___122, - uu___123) in - let uu___122 - = - let uu___123 - = - let uu___124 - = - FStar_Tests_Pars.tc - "rev [[T]; [F; T]]" in - let uu___125 - = - FStar_Tests_Pars.tc - "[[F; T]; [T]]" in - ((Prims.of_int (305)), - uu___124, - uu___125) in - let uu___124 - = - let uu___125 - = - let uu___126 - = - FStar_Tests_Pars.tc - "x1" in - let uu___127 - = - FStar_Tests_Pars.tc - "6" in - ((Prims.of_int (309)), - uu___126, - uu___127) in - let uu___126 - = - let uu___127 - = - let uu___128 - = - FStar_Tests_Pars.tc - "x2" in - let uu___129 - = - FStar_Tests_Pars.tc - "2" in - ((Prims.of_int (310)), - uu___128, - uu___129) in - let uu___128 - = - let uu___129 - = - let uu___130 - = - FStar_Tests_Pars.tc - "7 + 3" in - let uu___131 - = - FStar_Tests_Pars.tc - "10" in - ((Prims.of_int (401)), - uu___130, - uu___131) in - let uu___130 - = - let uu___131 - = - let uu___132 - = - FStar_Tests_Pars.tc - "true && false" in - let uu___133 - = - FStar_Tests_Pars.tc - "false" in - ((Prims.of_int (402)), - uu___132, - uu___133) in - let uu___132 - = - let uu___133 - = - let uu___134 - = - FStar_Tests_Pars.tc - "3 = 5" in - let uu___135 - = - FStar_Tests_Pars.tc - "false" in - ((Prims.of_int (403)), - uu___134, - uu___135) in - let uu___134 - = - let uu___135 - = - let uu___136 - = - FStar_Tests_Pars.tc - "\"abc\" ^ \"def\"" in - let uu___137 - = - FStar_Tests_Pars.tc - "\"abcdef\"" in - ((Prims.of_int (404)), - uu___136, - uu___137) in - let uu___136 - = - let uu___137 - = - let uu___138 - = - FStar_Tests_Pars.tc - "(fun (x:list int) -> match x with | [] -> 0 | hd::tl -> 1) []" in - let uu___139 - = - FStar_Tests_Pars.tc - "0" in - ((Prims.of_int (405)), - uu___138, - uu___139) in - [uu___137] in - uu___135 - :: - uu___136 in - uu___133 - :: - uu___134 in - uu___131 - :: - uu___132 in - uu___129 - :: - uu___130 in - uu___127 - :: - uu___128 in - uu___125 - :: - uu___126 in - uu___123 - :: - uu___124 in - uu___121 - :: - uu___122 in - uu___119 - :: - uu___120 in - uu___117 - :: - uu___118 in - uu___115 - :: - uu___116 in - uu___113 - :: - uu___114 in - uu___111 - :: - uu___112 in - uu___109 - :: - uu___110 in - uu___107 - :: - uu___108 in - uu___105 - :: - uu___106 in - uu___103 - :: - uu___104 in - uu___101 - :: - uu___102 in - uu___99 - :: - uu___100 in - uu___97 - :: - uu___98 in - uu___95 - :: - uu___96 in - uu___93 - :: - uu___94 in - uu___91 - :: - uu___92 in - uu___89 :: - uu___90 in - uu___87 :: - uu___88 in - uu___85 :: - uu___86 in - uu___83 :: - uu___84 in - uu___81 :: uu___82 in - uu___79 :: uu___80 in - uu___77 :: uu___78 in - uu___75 :: uu___76 in - uu___73 :: uu___74 in - uu___71 :: uu___72 in - uu___69 :: uu___70 in - uu___67 :: uu___68 in - uu___65 :: uu___66 in - uu___63 :: uu___64 in - uu___61 :: uu___62 in - uu___59 :: uu___60 in - uu___57 :: uu___58 in - uu___55 :: uu___56 in - uu___53 :: uu___54 in - uu___51 :: uu___52 in - uu___49 :: uu___50 in - uu___47 :: uu___48 in - uu___45 :: uu___46 in - uu___43 :: uu___44 in - uu___41 :: uu___42 in - uu___39 :: uu___40 in - uu___37 :: uu___38 in - uu___35 :: uu___36 in - uu___33 :: uu___34 in - uu___31 :: uu___32 in - uu___29 :: uu___30 in - uu___27 :: uu___28 in - uu___25 :: uu___26) -let run_either : - 'uuuuu . - Prims.int -> - 'uuuuu -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - (FStar_TypeChecker_Env.env -> 'uuuuu -> FStar_Syntax_Syntax.term) - -> unit - = - fun i -> - fun r -> - fun expected -> - fun normalizer -> - (let uu___1 = FStar_Compiler_Util.string_of_int i in - FStar_Compiler_Util.print1 "%s: ... \n\n" uu___1); - (let tcenv = FStar_Tests_Pars.init () in - (let uu___2 = FStar_Main.process_args () in ()); - (let x = normalizer tcenv r in - FStar_Options.init (); - FStar_Options.set_option "print_universes" - (FStar_Options.Bool true); - FStar_Options.set_option "print_implicits" - (FStar_Options.Bool true); - FStar_Options.set_option "ugly" (FStar_Options.Bool true); - FStar_Options.set_option "print_bound_var_types" - (FStar_Options.Bool true); - (let uu___7 = - let uu___8 = FStar_Syntax_Util.unascribe x in - FStar_Tests_Util.term_eq uu___8 expected in - FStar_Tests_Util.always i uu___7))) -let (run_whnf : - Prims.int -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> unit) - = - fun i -> - fun r -> - fun expected -> - let steps = - [FStar_TypeChecker_Env.Primops; - FStar_TypeChecker_Env.Weak; - FStar_TypeChecker_Env.HNF; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant] in - run_either i r expected (FStar_TypeChecker_Normalize.normalize steps) -let (run_interpreter : - Prims.int -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> unit) - = - fun i -> - fun r -> - fun expected -> - run_either i r expected - (FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.Beta; - FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant; - FStar_TypeChecker_Env.Primops]) -let (run_nbe : - Prims.int -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> unit) - = - fun i -> - fun r -> - fun expected -> - run_either i r expected - (FStar_TypeChecker_NBE.normalize_for_unit_test - [FStar_TypeChecker_Env.UnfoldUntil - FStar_Syntax_Syntax.delta_constant]) -let (run_interpreter_with_time : - Prims.int -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - (Prims.int * FStar_BaseTypes.float)) - = - fun i -> - fun r -> - fun expected -> - let interp uu___ = run_interpreter i r expected in - let uu___ = - let uu___1 = FStar_Compiler_Util.return_execution_time interp in - FStar_Pervasives_Native.snd uu___1 in - (i, uu___) -let (run_whnf_with_time : - Prims.int -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - (Prims.int * FStar_BaseTypes.float)) - = - fun i -> - fun r -> - fun expected -> - let whnf uu___ = run_whnf i r expected in - let uu___ = - let uu___1 = FStar_Compiler_Util.return_execution_time whnf in - FStar_Pervasives_Native.snd uu___1 in - (i, uu___) -let (run_nbe_with_time : - Prims.int -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - (Prims.int * FStar_BaseTypes.float)) - = - fun i -> - fun r -> - fun expected -> - let nbe uu___ = run_nbe i r expected in - let uu___ = - let uu___1 = FStar_Compiler_Util.return_execution_time nbe in - FStar_Pervasives_Native.snd uu___1 in - (i, uu___) -let run_tests : - 'uuuuu 'uuuuu1 'uuuuu2 'uuuuu3 . - ('uuuuu * 'uuuuu1 * 'uuuuu2) Prims.list -> - ('uuuuu -> 'uuuuu1 -> 'uuuuu2 -> 'uuuuu3) -> 'uuuuu3 Prims.list - = - fun tests -> - fun run -> - FStar_Options.__set_unit_tests (); - (let l = - FStar_Compiler_List.map - (fun uu___1 -> - match uu___1 with | (no, test, res) -> run no test res) tests in - FStar_Options.__clear_unit_tests (); l) -let (whnf_tests : - (Prims.int * FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.term) - Prims.list) - = - FStar_Tests_Pars.pars_and_tc_fragment "assume val def : Type0"; - FStar_Tests_Pars.pars_and_tc_fragment "assume val pred : Type0"; - FStar_Tests_Pars.pars_and_tc_fragment "let def0 (y:int) = def"; - FStar_Tests_Pars.pars_and_tc_fragment - "unfold let def1 (y:int) = x:def0 y { pred }"; - (let def_def1 = FStar_Tests_Pars.tc "x:def0 17 { pred }" in - let def_def1_unfolded = FStar_Tests_Pars.tc "x:def { pred }" in - let tests = - let uu___4 = - let uu___5 = FStar_Tests_Pars.tc "def1 17" in - ((Prims.of_int (601)), uu___5, def_def1) in - [uu___4; ((Prims.of_int (602)), def_def1, def_def1_unfolded)] in - tests) -let (run_all_whnf : unit -> unit) = - fun uu___ -> - FStar_Compiler_Util.print_string "Testing Normlizer WHNF\n"; - (let uu___2 = run_tests whnf_tests run_whnf in - FStar_Compiler_Util.print_string "Normalizer WHNF ok\n") -let (run_all_nbe : unit -> unit) = - fun uu___ -> - FStar_Compiler_Util.print_string "Testing NBE\n"; - (let uu___2 = run_tests default_tests run_nbe in - FStar_Compiler_Util.print_string "NBE ok\n") -let (run_all_interpreter : unit -> unit) = - fun uu___ -> - FStar_Compiler_Util.print_string "Testing the normalizer\n"; - (let uu___2 = run_tests default_tests run_interpreter in - FStar_Compiler_Util.print_string "Normalizer ok\n") -let (run_all_whnf_with_time : - unit -> (Prims.int * FStar_BaseTypes.float) Prims.list) = - fun uu___ -> - FStar_Compiler_Util.print_string "Testing WHNF\n"; - (let l = run_tests whnf_tests run_whnf_with_time in - FStar_Compiler_Util.print_string "WHNF ok\n"; l) -let (run_all_nbe_with_time : - unit -> (Prims.int * FStar_BaseTypes.float) Prims.list) = - fun uu___ -> - FStar_Compiler_Util.print_string "Testing NBE\n"; - (let l = run_tests default_tests run_nbe_with_time in - FStar_Compiler_Util.print_string "NBE ok\n"; l) -let (run_all_interpreter_with_time : - unit -> (Prims.int * FStar_BaseTypes.float) Prims.list) = - fun uu___ -> - FStar_Compiler_Util.print_string "Testing the normalizer\n"; - (let l = run_tests default_tests run_interpreter_with_time in - FStar_Compiler_Util.print_string "Normalizer ok\n"; l) -let (run_both_with_time : - Prims.int -> - FStar_Syntax_Syntax.term -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> unit) - = - fun i -> - fun r -> - fun expected -> - let nbe uu___ = run_nbe i r expected in - let norm uu___ = run_interpreter i r expected in - FStar_Compiler_Util.measure_execution_time "nbe" nbe; - FStar_Compiler_Util.print_string "\n"; - FStar_Compiler_Util.measure_execution_time "normalizer" norm; - FStar_Compiler_Util.print_string "\n" -let (compare : unit -> unit) = - fun uu___ -> - FStar_Compiler_Util.print_string - "Comparing times for normalization and nbe\n"; - (let uu___2 = - let uu___3 = encode (Prims.of_int (1000)) in - let uu___4 = - let uu___5 = FStar_Tests_Util.nm FStar_Tests_Util.x in - let uu___6 = FStar_Tests_Util.nm FStar_Tests_Util.x in - minus uu___5 uu___6 in - let_ FStar_Tests_Util.x uu___3 uu___4 in - run_both_with_time (Prims.of_int (14)) uu___2 z) -let (compare_times : - (Prims.int * FStar_BaseTypes.float) Prims.list -> - (Prims.int * FStar_BaseTypes.float) Prims.list -> unit) - = - fun l_int -> - fun l_nbe -> - FStar_Compiler_Util.print_string - "Comparing times for normalization and nbe\n"; - FStar_Compiler_List.iter2 - (fun res1 -> - fun res2 -> - let uu___1 = res1 in - match uu___1 with - | (t1, time_int) -> - let uu___2 = res2 in - (match uu___2 with - | (t2, time_nbe) -> - if t1 = t2 - then - let uu___3 = FStar_Compiler_Util.string_of_int t1 in - FStar_Compiler_Util.print3 - "Test %s\nNBE %s\nInterpreter %s\n" uu___3 - (FStar_Compiler_Util.string_of_float time_nbe) - (FStar_Compiler_Util.string_of_float time_int) - else - FStar_Compiler_Util.print_string - "Test numbers do not match...\n")) l_int l_nbe -let (run_all : unit -> unit) = - fun uu___ -> - (let uu___2 = FStar_Class_Show.show FStar_Syntax_Print.showable_term znat in - FStar_Compiler_Util.print1 "%s" uu___2); - (let uu___2 = run_all_whnf_with_time () in - let l_int = run_all_interpreter_with_time () in - let l_nbe = run_all_nbe_with_time () in compare_times l_int l_nbe) \ No newline at end of file diff --git a/ocaml/fstar-tests/generated/FStar_Tests_Pars.ml b/ocaml/fstar-tests/generated/FStar_Tests_Pars.ml deleted file mode 100644 index 6a56f2e0bca..00000000000 --- a/ocaml/fstar-tests/generated/FStar_Tests_Pars.ml +++ /dev/null @@ -1,857 +0,0 @@ -open Prims -let (test_lid : FStar_Ident.lident) = - FStar_Ident.lid_of_path ["Test"] FStar_Compiler_Range_Type.dummyRange -let (tcenv_ref : - FStar_TypeChecker_Env.env FStar_Pervasives_Native.option - FStar_Compiler_Effect.ref) - = FStar_Compiler_Util.mk_ref FStar_Pervasives_Native.None -let (test_mod_ref : - FStar_Syntax_Syntax.modul FStar_Pervasives_Native.option - FStar_Compiler_Effect.ref) - = - FStar_Compiler_Util.mk_ref - (FStar_Pervasives_Native.Some - { - FStar_Syntax_Syntax.name = test_lid; - FStar_Syntax_Syntax.declarations = []; - FStar_Syntax_Syntax.is_interface = false - }) -let (parse_mod : - Prims.string -> - FStar_Syntax_DsEnv.env -> - (FStar_Syntax_DsEnv.env * FStar_Syntax_Syntax.modul)) - = - fun mod_name -> - fun dsenv -> - let uu___ = - FStar_Parser_ParseIt.parse FStar_Pervasives_Native.None - (FStar_Parser_ParseIt.Filename mod_name) in - match uu___ with - | FStar_Parser_ParseIt.ASTFragment (FStar_Pervasives.Inl m, uu___1) -> - let uu___2 = - let uu___3 = FStar_ToSyntax_ToSyntax.ast_modul_to_modul m in - uu___3 dsenv in - (match uu___2 with - | (m1, env') -> - let uu___3 = - let uu___4 = - FStar_Ident.lid_of_path ["Test"] - FStar_Compiler_Range_Type.dummyRange in - FStar_Syntax_DsEnv.prepare_module_or_interface false false - env' uu___4 FStar_Syntax_DsEnv.default_mii in - (match uu___3 with | (env'1, uu___4) -> (env'1, m1))) - | FStar_Parser_ParseIt.ParseError (err, msg, r) -> - FStar_Compiler_Effect.raise (FStar_Errors.Error (err, msg, r, [])) - | FStar_Parser_ParseIt.ASTFragment - (FStar_Pervasives.Inr uu___1, uu___2) -> - let msg = - FStar_Compiler_Util.format1 "%s: expected a module\n" mod_name in - FStar_Errors.raise_error0 FStar_Errors_Codes.Fatal_ModuleExpected - () (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic msg) - | FStar_Parser_ParseIt.Term uu___1 -> - failwith - "Impossible: parsing a Filename always results in an ASTFragment" -let (add_mods : - Prims.string Prims.list -> - FStar_Syntax_DsEnv.env -> - FStar_TypeChecker_Env.env -> - (FStar_Syntax_DsEnv.env * FStar_TypeChecker_Env.env)) - = - fun mod_names -> - fun dsenv -> - fun env -> - FStar_Compiler_List.fold_left - (fun uu___ -> - fun mod_name -> - match uu___ with - | (dsenv1, env1) -> - let uu___1 = parse_mod mod_name dsenv1 in - (match uu___1 with - | (dsenv2, string_mod) -> - let uu___2 = - FStar_TypeChecker_Tc.check_module env1 string_mod - false in - (match uu___2 with | (_mod, env2) -> (dsenv2, env2)))) - (dsenv, env) mod_names -let (init_once : unit -> unit) = - fun uu___ -> - let solver = FStar_SMTEncoding_Solver.dummy in - let env = - FStar_TypeChecker_Env.initial_env FStar_Parser_Dep.empty_deps - FStar_TypeChecker_TcTerm.tc_term - FStar_TypeChecker_TcTerm.typeof_tot_or_gtot_term - FStar_TypeChecker_TcTerm.typeof_tot_or_gtot_term_fastpath - FStar_TypeChecker_TcTerm.universe_of - FStar_TypeChecker_Rel.teq_nosmt_force - FStar_TypeChecker_Rel.subtype_nosmt_force solver - FStar_Parser_Const.prims_lid - FStar_TypeChecker_NBE.normalize_for_unit_test - FStar_Universal.core_check in - (env.FStar_TypeChecker_Env.solver).FStar_TypeChecker_Env.init env; - (let uu___2 = - let uu___3 = FStar_Basefiles.prims () in - let uu___4 = FStar_Syntax_DsEnv.empty_env FStar_Parser_Dep.empty_deps in - parse_mod uu___3 uu___4 in - match uu___2 with - | (dsenv, prims_mod) -> - let env1 = - { - FStar_TypeChecker_Env.solver = - (env.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = (env.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = (env.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = (env.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = dsenv; - FStar_TypeChecker_Env.nbe = (env.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env.FStar_TypeChecker_Env.missing_decl) - } in - let uu___3 = FStar_TypeChecker_Tc.check_module env1 prims_mod false in - (match uu___3 with - | (_prims_mod, env2) -> - let env3 = - { - FStar_TypeChecker_Env.solver = - (env2.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = - (env2.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (env2.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = - (env2.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (env2.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (env2.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = - (env2.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (env2.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = - (env2.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = - (env2.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (env2.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = - (env2.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (env2.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = - (env2.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = - (env2.FStar_TypeChecker_Env.top_level); - FStar_TypeChecker_Env.check_uvars = - (env2.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (env2.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (env2.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = - (env2.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (env2.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = - (env2.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (env2.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (env2.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (env2.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (env2.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (env2.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = - (env2.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (env2.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (env2.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (env2.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (env2.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (env2.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (env2.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (env2.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (env2.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (env2.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (env2.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (env2.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = - (env2.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (env2.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (env2.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (env2.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (env2.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = dsenv; - FStar_TypeChecker_Env.nbe = - (env2.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (env2.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (env2.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (env2.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (env2.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (env2.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (env2.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (env2.FStar_TypeChecker_Env.missing_decl) - } in - let env4 = - FStar_TypeChecker_Env.set_current_module env3 test_lid in - FStar_Compiler_Effect.op_Colon_Equals tcenv_ref - (FStar_Pervasives_Native.Some env4))) -let (uu___0 : unit) = FStar_Main.setup_hooks (); init_once () -let (init : unit -> FStar_TypeChecker_Env.env) = - fun uu___ -> - let uu___1 = FStar_Compiler_Effect.op_Bang tcenv_ref in - match uu___1 with - | FStar_Pervasives_Native.Some f -> f - | uu___2 -> - failwith - "Should have already been initialized by the top-level effect" -let (frag_of_text : Prims.string -> FStar_Parser_ParseIt.input_frag) = - fun s -> - { - FStar_Parser_ParseIt.frag_fname = " input"; - FStar_Parser_ParseIt.frag_text = s; - FStar_Parser_ParseIt.frag_line = Prims.int_one; - FStar_Parser_ParseIt.frag_col = Prims.int_zero - } -let (pars : Prims.string -> FStar_Syntax_Syntax.term) = - fun s -> - try - (fun uu___ -> - match () with - | () -> - let tcenv = init () in - let uu___1 = - FStar_Parser_ParseIt.parse FStar_Pervasives_Native.None - (FStar_Parser_ParseIt.Fragment (frag_of_text s)) in - (match uu___1 with - | FStar_Parser_ParseIt.Term t -> - FStar_ToSyntax_ToSyntax.desugar_term - tcenv.FStar_TypeChecker_Env.dsenv t - | FStar_Parser_ParseIt.ParseError (e, msg, r) -> - FStar_Errors.raise_error - FStar_Class_HasRange.hasRange_range r e () - (Obj.magic FStar_Errors_Msg.is_error_message_list_doc) - (Obj.magic msg) - | FStar_Parser_ParseIt.ASTFragment uu___2 -> - failwith - "Impossible: parsing a Fragment always results in a Term")) - () - with - | FStar_Errors.Error (err, msg, r, _ctx) when - let uu___1 = FStar_Options.trace_error () in Prims.op_Negation uu___1 - -> - (if r = FStar_Compiler_Range_Type.dummyRange - then - (let uu___2 = FStar_Errors_Msg.rendermsg msg in - FStar_Compiler_Util.print_string uu___2) - else - (let uu___3 = FStar_Compiler_Range_Ops.string_of_range r in - let uu___4 = FStar_Errors_Msg.rendermsg msg in - FStar_Compiler_Util.print2 "%s: %s\n" uu___3 uu___4); - FStar_Compiler_Effect.exit Prims.int_one) - | e when - let uu___1 = FStar_Options.trace_error () in Prims.op_Negation uu___1 - -> FStar_Compiler_Effect.raise e -let (tc' : - Prims.string -> (FStar_Syntax_Syntax.term * FStar_TypeChecker_Env.env)) = - fun s -> - let tm = pars s in - let tcenv = init () in - let tcenv1 = - { - FStar_TypeChecker_Env.solver = (tcenv.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = (tcenv.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (tcenv.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = (tcenv.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (tcenv.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (tcenv.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = (tcenv.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (tcenv.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = (tcenv.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = (tcenv.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (tcenv.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = (tcenv.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (tcenv.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = (tcenv.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = false; - FStar_TypeChecker_Env.check_uvars = - (tcenv.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (tcenv.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (tcenv.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = (tcenv.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (tcenv.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = true; - FStar_TypeChecker_Env.failhard = - (tcenv.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (tcenv.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (tcenv.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (tcenv.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (tcenv.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = (tcenv.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (tcenv.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (tcenv.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (tcenv.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (tcenv.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (tcenv.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (tcenv.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (tcenv.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (tcenv.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (tcenv.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (tcenv.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (tcenv.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = (tcenv.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (tcenv.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (tcenv.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (tcenv.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (tcenv.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = (tcenv.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (tcenv.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (tcenv.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (tcenv.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (tcenv.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (tcenv.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (tcenv.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (tcenv.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (tcenv.FStar_TypeChecker_Env.missing_decl) - } in - let uu___ = FStar_TypeChecker_TcTerm.tc_tot_or_gtot_term tcenv1 tm in - match uu___ with - | (tm1, uu___1, g) -> - (FStar_TypeChecker_Rel.force_trivial_guard tcenv1 g; - (let tm2 = FStar_Syntax_Compress.deep_compress false false tm1 in - (tm2, tcenv1))) -let (tc : Prims.string -> FStar_Syntax_Syntax.term) = - fun s -> let uu___ = tc' s in match uu___ with | (tm, uu___1) -> tm -let (tc_term : FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = - fun tm -> - let tcenv = init () in - let tcenv1 = - { - FStar_TypeChecker_Env.solver = (tcenv.FStar_TypeChecker_Env.solver); - FStar_TypeChecker_Env.range = (tcenv.FStar_TypeChecker_Env.range); - FStar_TypeChecker_Env.curmodule = - (tcenv.FStar_TypeChecker_Env.curmodule); - FStar_TypeChecker_Env.gamma = (tcenv.FStar_TypeChecker_Env.gamma); - FStar_TypeChecker_Env.gamma_sig = - (tcenv.FStar_TypeChecker_Env.gamma_sig); - FStar_TypeChecker_Env.gamma_cache = - (tcenv.FStar_TypeChecker_Env.gamma_cache); - FStar_TypeChecker_Env.modules = (tcenv.FStar_TypeChecker_Env.modules); - FStar_TypeChecker_Env.expected_typ = - (tcenv.FStar_TypeChecker_Env.expected_typ); - FStar_TypeChecker_Env.sigtab = (tcenv.FStar_TypeChecker_Env.sigtab); - FStar_TypeChecker_Env.attrtab = (tcenv.FStar_TypeChecker_Env.attrtab); - FStar_TypeChecker_Env.instantiate_imp = - (tcenv.FStar_TypeChecker_Env.instantiate_imp); - FStar_TypeChecker_Env.effects = (tcenv.FStar_TypeChecker_Env.effects); - FStar_TypeChecker_Env.generalize = - (tcenv.FStar_TypeChecker_Env.generalize); - FStar_TypeChecker_Env.letrecs = (tcenv.FStar_TypeChecker_Env.letrecs); - FStar_TypeChecker_Env.top_level = false; - FStar_TypeChecker_Env.check_uvars = - (tcenv.FStar_TypeChecker_Env.check_uvars); - FStar_TypeChecker_Env.use_eq_strict = - (tcenv.FStar_TypeChecker_Env.use_eq_strict); - FStar_TypeChecker_Env.is_iface = - (tcenv.FStar_TypeChecker_Env.is_iface); - FStar_TypeChecker_Env.admit = (tcenv.FStar_TypeChecker_Env.admit); - FStar_TypeChecker_Env.lax_universes = - (tcenv.FStar_TypeChecker_Env.lax_universes); - FStar_TypeChecker_Env.phase1 = (tcenv.FStar_TypeChecker_Env.phase1); - FStar_TypeChecker_Env.failhard = - (tcenv.FStar_TypeChecker_Env.failhard); - FStar_TypeChecker_Env.flychecking = - (tcenv.FStar_TypeChecker_Env.flychecking); - FStar_TypeChecker_Env.uvar_subtyping = - (tcenv.FStar_TypeChecker_Env.uvar_subtyping); - FStar_TypeChecker_Env.intactics = - (tcenv.FStar_TypeChecker_Env.intactics); - FStar_TypeChecker_Env.nocoerce = - (tcenv.FStar_TypeChecker_Env.nocoerce); - FStar_TypeChecker_Env.tc_term = (tcenv.FStar_TypeChecker_Env.tc_term); - FStar_TypeChecker_Env.typeof_tot_or_gtot_term = - (tcenv.FStar_TypeChecker_Env.typeof_tot_or_gtot_term); - FStar_TypeChecker_Env.universe_of = - (tcenv.FStar_TypeChecker_Env.universe_of); - FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term = - (tcenv.FStar_TypeChecker_Env.typeof_well_typed_tot_or_gtot_term); - FStar_TypeChecker_Env.teq_nosmt_force = - (tcenv.FStar_TypeChecker_Env.teq_nosmt_force); - FStar_TypeChecker_Env.subtype_nosmt_force = - (tcenv.FStar_TypeChecker_Env.subtype_nosmt_force); - FStar_TypeChecker_Env.qtbl_name_and_index = - (tcenv.FStar_TypeChecker_Env.qtbl_name_and_index); - FStar_TypeChecker_Env.normalized_eff_names = - (tcenv.FStar_TypeChecker_Env.normalized_eff_names); - FStar_TypeChecker_Env.fv_delta_depths = - (tcenv.FStar_TypeChecker_Env.fv_delta_depths); - FStar_TypeChecker_Env.proof_ns = - (tcenv.FStar_TypeChecker_Env.proof_ns); - FStar_TypeChecker_Env.synth_hook = - (tcenv.FStar_TypeChecker_Env.synth_hook); - FStar_TypeChecker_Env.try_solve_implicits_hook = - (tcenv.FStar_TypeChecker_Env.try_solve_implicits_hook); - FStar_TypeChecker_Env.splice = (tcenv.FStar_TypeChecker_Env.splice); - FStar_TypeChecker_Env.mpreprocess = - (tcenv.FStar_TypeChecker_Env.mpreprocess); - FStar_TypeChecker_Env.postprocess = - (tcenv.FStar_TypeChecker_Env.postprocess); - FStar_TypeChecker_Env.identifier_info = - (tcenv.FStar_TypeChecker_Env.identifier_info); - FStar_TypeChecker_Env.tc_hooks = - (tcenv.FStar_TypeChecker_Env.tc_hooks); - FStar_TypeChecker_Env.dsenv = (tcenv.FStar_TypeChecker_Env.dsenv); - FStar_TypeChecker_Env.nbe = (tcenv.FStar_TypeChecker_Env.nbe); - FStar_TypeChecker_Env.strict_args_tab = - (tcenv.FStar_TypeChecker_Env.strict_args_tab); - FStar_TypeChecker_Env.erasable_types_tab = - (tcenv.FStar_TypeChecker_Env.erasable_types_tab); - FStar_TypeChecker_Env.enable_defer_to_tac = - (tcenv.FStar_TypeChecker_Env.enable_defer_to_tac); - FStar_TypeChecker_Env.unif_allow_ref_guards = - (tcenv.FStar_TypeChecker_Env.unif_allow_ref_guards); - FStar_TypeChecker_Env.erase_erasable_args = - (tcenv.FStar_TypeChecker_Env.erase_erasable_args); - FStar_TypeChecker_Env.core_check = - (tcenv.FStar_TypeChecker_Env.core_check); - FStar_TypeChecker_Env.missing_decl = - (tcenv.FStar_TypeChecker_Env.missing_decl) - } in - let uu___ = FStar_TypeChecker_TcTerm.tc_tot_or_gtot_term tcenv1 tm in - match uu___ with - | (tm1, uu___1, g) -> - (FStar_TypeChecker_Rel.force_trivial_guard tcenv1 g; - (let tm2 = FStar_Syntax_Compress.deep_compress false false tm1 in - tm2)) -let (pars_and_tc_fragment : Prims.string -> unit) = - fun s -> - FStar_Options.set_option "trace_error" (FStar_Options.Bool true); - (let report uu___1 = let uu___2 = FStar_Errors.report_all () in () in - try - (fun uu___1 -> - match () with - | () -> - let tcenv = init () in - let frag = frag_of_text s in - (try - (fun uu___2 -> - match () with - | () -> - let uu___3 = - let uu___4 = - FStar_Compiler_Effect.op_Bang test_mod_ref in - FStar_Universal.tc_one_fragment uu___4 tcenv - (FStar_Pervasives.Inl (frag, [])) in - (match uu___3 with - | (test_mod', tcenv', uu___4) -> - (FStar_Compiler_Effect.op_Colon_Equals - test_mod_ref test_mod'; - FStar_Compiler_Effect.op_Colon_Equals tcenv_ref - (FStar_Pervasives_Native.Some tcenv'); - (let n = FStar_Errors.get_err_count () in - if n <> Prims.int_zero - then - (report (); - (let uu___8 = - let uu___9 = - FStar_Compiler_Util.string_of_int n in - FStar_Compiler_Util.format1 - "%s errors were reported" uu___9 in - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_ErrorsReported - () - (Obj.magic - FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___8))) - else ())))) () - with - | uu___2 -> - (report (); - FStar_Errors.raise_error0 - FStar_Errors_Codes.Fatal_TcOneFragmentFailed () - (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic (Prims.strcat "tc_one_fragment failed: " s))))) - () - with - | uu___1 -> - ((fun uu___1 -> - if - let uu___2 = FStar_Options.trace_error () in - Prims.op_Negation uu___2 - then Obj.magic (Obj.repr (FStar_Compiler_Effect.raise uu___1)) - else Obj.magic (Obj.repr (failwith "unreachable")))) uu___1) -let (test_hashes : unit -> unit) = - fun uu___ -> - (let uu___2 = FStar_Main.process_args () in ()); - pars_and_tc_fragment "type unary_nat = | U0 | US of unary_nat"; - (let test_one_hash n = - let rec aux n1 = - if n1 = Prims.int_zero - then "U0" - else - (let uu___4 = - let uu___5 = aux (n1 - Prims.int_one) in - Prims.strcat uu___5 ")" in - Prims.strcat "(US " uu___4) in - let tm = let uu___3 = aux n in tc uu___3 in - let hc = FStar_Syntax_Hash.ext_hash_term tm in - let uu___3 = FStar_Compiler_Util.string_of_int n in - let uu___4 = FStar_Hash.string_of_hash_code hc in - FStar_Compiler_Util.print2 "Hash of unary %s is %s\n" uu___3 uu___4 in - let rec aux n = - if n = Prims.int_zero - then () - else (test_one_hash n; aux (n - Prims.int_one)) in - aux (Prims.of_int (100)); FStar_Options.init ()) -let (parse_incremental_decls : unit -> unit) = - fun uu___ -> - let source0 = - "module Demo\nlet f x = match x with | Some x -> true | None -> false\nlet test y = if Some? y then f y else true\n```pulse\nfn f() {}\n```\n```pulse\nfn g() {}\n```\nlet something = more\nlet >< junk" in - let source1 = - "module Demo\nlet f x = match x with | Some x -> true | None -> false\nlet test y = if Some? y then f y else true\n```pulse\nfn f() {}\n```\n\n```pulse\nfn g() {}\n```\nlet something = more\nlet >< junk" in - let input0 = - FStar_Parser_ParseIt.Incremental - { - FStar_Parser_ParseIt.frag_fname = "Demo.fst"; - FStar_Parser_ParseIt.frag_text = source0; - FStar_Parser_ParseIt.frag_line = Prims.int_one; - FStar_Parser_ParseIt.frag_col = Prims.int_zero - } in - let input1 = - FStar_Parser_ParseIt.Incremental - { - FStar_Parser_ParseIt.frag_fname = "Demo.fst"; - FStar_Parser_ParseIt.frag_text = source1; - FStar_Parser_ParseIt.frag_line = Prims.int_one; - FStar_Parser_ParseIt.frag_col = Prims.int_zero - } in - let uu___1 = - let uu___2 = - FStar_Parser_ParseIt.parse FStar_Pervasives_Native.None input0 in - let uu___3 = - FStar_Parser_ParseIt.parse FStar_Pervasives_Native.None input1 in - (uu___2, uu___3) in - match uu___1 with - | (FStar_Parser_ParseIt.IncrementalFragment (decls0, uu___2, parse_err0), - FStar_Parser_ParseIt.IncrementalFragment (decls1, uu___3, parse_err1)) - -> - let check_range r l c = - let p = FStar_Compiler_Range_Ops.start_of_range r in - let uu___4 = - (let uu___5 = FStar_Compiler_Range_Ops.line_of_pos p in - uu___5 = l) && - (let uu___5 = FStar_Compiler_Range_Ops.col_of_pos p in - uu___5 = c) in - if uu___4 - then () - else - (let uu___6 = - let uu___7 = FStar_Compiler_Util.string_of_int l in - let uu___8 = FStar_Compiler_Util.string_of_int c in - let uu___9 = - let uu___10 = FStar_Compiler_Range_Ops.line_of_pos p in - FStar_Compiler_Util.string_of_int uu___10 in - let uu___10 = - let uu___11 = FStar_Compiler_Range_Ops.col_of_pos p in - FStar_Compiler_Util.string_of_int uu___11 in - FStar_Compiler_Util.format4 - "Incremental parsing failed: Expected syntax error at (%s, %s), got error at (%s, %s)" - uu___7 uu___8 uu___9 uu___10 in - failwith uu___6) in - ((match (parse_err0, parse_err1) with - | (FStar_Pervasives_Native.None, uu___5) -> - failwith - "Incremental parsing failed: Expected syntax error at (8, 6), got no error" - | (uu___5, FStar_Pervasives_Native.None) -> - failwith - "Incremental parsing failed: Expected syntax error at (9, 6), got no error" - | (FStar_Pervasives_Native.Some (uu___5, uu___6, rng0), - FStar_Pervasives_Native.Some (uu___7, uu___8, rng1)) -> - (check_range rng0 (Prims.of_int (11)) (Prims.of_int (6)); - check_range rng1 (Prims.of_int (12)) (Prims.of_int (6)))); - (match (decls0, decls1) with - | (d0::d1::d2::d3::d4::d5::[], e0::e1::e2::e3::e4::e5::[]) -> - let uu___5 = - FStar_Compiler_List.forall2 - (fun uu___6 -> - fun uu___7 -> - match (uu___6, uu___7) with - | ((x, uu___8), (y, uu___9)) -> - FStar_Parser_AST_Util.eq_decl x y) decls0 decls1 in - if uu___5 - then () - else - failwith - "Incremental parsing failed; unexpected change in a decl" - | uu___5 -> - let uu___6 = - let uu___7 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length decls0) in - let uu___8 = - FStar_Compiler_Util.string_of_int - (FStar_Compiler_List.length decls1) in - FStar_Compiler_Util.format2 - "Incremental parsing failed; expected 6 decls got %s and %s\n" - uu___7 uu___8 in - failwith uu___6)) - | (FStar_Parser_ParseIt.ParseError (code, message, range), uu___2) -> - let msg = - let uu___3 = FStar_Compiler_Range_Ops.string_of_range range in - let uu___4 = FStar_Errors_Msg.rendermsg message in - FStar_Compiler_Util.format2 - "Incremental parsing failed: Syntax error @ %s: %s" uu___3 uu___4 in - failwith msg - | (uu___2, FStar_Parser_ParseIt.ParseError (code, message, range)) -> - let msg = - let uu___3 = FStar_Compiler_Range_Ops.string_of_range range in - let uu___4 = FStar_Errors_Msg.rendermsg message in - FStar_Compiler_Util.format2 - "Incremental parsing failed: Syntax error @ %s: %s" uu___3 uu___4 in - failwith msg - | uu___2 -> failwith "Incremental parsing failed: Unexpected output" -let (parse_incremental_decls_use_lang : unit -> unit) = - fun uu___ -> - let source0 = - "module Demo\nlet x = 0\n#lang-somelang\nval f : t\nlet g x = f x\n#restart-solver" in - FStar_Parser_AST_Util.register_extension_lang_parser "somelang" - FStar_Parser_ParseIt.parse_fstar_incrementally; - (let input0 = - FStar_Parser_ParseIt.Incremental - { - FStar_Parser_ParseIt.frag_fname = "Demo.fst"; - FStar_Parser_ParseIt.frag_text = source0; - FStar_Parser_ParseIt.frag_line = Prims.int_one; - FStar_Parser_ParseIt.frag_col = Prims.int_zero - } in - let uu___2 = - FStar_Parser_ParseIt.parse FStar_Pervasives_Native.None input0 in - match uu___2 with - | FStar_Parser_ParseIt.IncrementalFragment (decls0, uu___3, parse_err0) - -> - ((match parse_err0 with - | FStar_Pervasives_Native.None -> () - | FStar_Pervasives_Native.Some uu___5 -> - failwith "Incremental parsing failed: ..."); - (let ds = - FStar_Compiler_List.map FStar_Pervasives_Native.fst decls0 in - match ds with - | { FStar_Parser_AST.d = FStar_Parser_AST.TopLevelModule uu___5; - FStar_Parser_AST.drange = uu___6; - FStar_Parser_AST.quals = uu___7; - FStar_Parser_AST.attrs = uu___8; - FStar_Parser_AST.interleaved = uu___9;_}::{ - FStar_Parser_AST.d - = - FStar_Parser_AST.TopLevelLet - uu___10; - FStar_Parser_AST.drange - = uu___11; - FStar_Parser_AST.quals - = uu___12; - FStar_Parser_AST.attrs - = uu___13; - FStar_Parser_AST.interleaved - = uu___14;_}:: - { FStar_Parser_AST.d = FStar_Parser_AST.UseLangDecls uu___15; - FStar_Parser_AST.drange = uu___16; - FStar_Parser_AST.quals = uu___17; - FStar_Parser_AST.attrs = uu___18; - FStar_Parser_AST.interleaved = uu___19;_}::{ - FStar_Parser_AST.d - = - FStar_Parser_AST.Val - uu___20; - FStar_Parser_AST.drange - = uu___21; - FStar_Parser_AST.quals - = uu___22; - FStar_Parser_AST.attrs - = uu___23; - FStar_Parser_AST.interleaved - = uu___24;_}:: - { FStar_Parser_AST.d = FStar_Parser_AST.TopLevelLet uu___25; - FStar_Parser_AST.drange = uu___26; - FStar_Parser_AST.quals = uu___27; - FStar_Parser_AST.attrs = uu___28; - FStar_Parser_AST.interleaved = uu___29;_}::{ - FStar_Parser_AST.d - = - FStar_Parser_AST.Pragma - uu___30; - FStar_Parser_AST.drange - = uu___31; - FStar_Parser_AST.quals - = uu___32; - FStar_Parser_AST.attrs - = uu___33; - FStar_Parser_AST.interleaved - = uu___34;_}::[] - -> () - | uu___5 -> - let uu___6 = - let uu___7 = - FStar_Class_Show.show - (FStar_Class_Show.show_list - FStar_Parser_AST.showable_decl) ds in - Prims.strcat - "Incremental parsing failed; unexpected decls: " uu___7 in - failwith uu___6)) - | FStar_Parser_ParseIt.ParseError (code, message, range) -> - let msg = - let uu___3 = FStar_Compiler_Range_Ops.string_of_range range in - let uu___4 = FStar_Errors_Msg.rendermsg message in - FStar_Compiler_Util.format2 - "Incremental parsing failed: Syntax error @ %s: %s" uu___3 - uu___4 in - failwith msg - | uu___3 -> failwith "Incremental parsing failed: Unexpected output") \ No newline at end of file diff --git a/ocaml/fstar-tests/generated/FStar_Tests_Test.ml b/ocaml/fstar-tests/generated/FStar_Tests_Test.ml deleted file mode 100644 index 941ca06cb7d..00000000000 --- a/ocaml/fstar-tests/generated/FStar_Tests_Test.ml +++ /dev/null @@ -1,71 +0,0 @@ -open Prims -let main : 'uuuuu 'uuuuu1 . 'uuuuu -> 'uuuuu1 = - fun argv -> - FStar_Compiler_Util.print_string "Initializing tests...\n"; - (try - (fun uu___1 -> - match () with - | () -> - let uu___2 = FStar_Options.parse_cmd_line () in - (match uu___2 with - | (res, fs) -> - (match res with - | FStar_Getopt.Help -> - (FStar_Compiler_Util.print_string - "F* unit tests. This binary can take the same options as F*, but not all of them are meaningful."; - FStar_Compiler_Effect.exit Prims.int_zero) - | FStar_Getopt.Error msg -> - (FStar_Compiler_Util.print_error msg; - FStar_Compiler_Effect.exit Prims.int_one) - | FStar_Getopt.Empty -> - (FStar_Main.setup_hooks (); - (let uu___5 = FStar_Tests_Pars.init () in ()); - FStar_Tests_Pars.parse_incremental_decls (); - FStar_Tests_Pars.parse_incremental_decls_use_lang (); - FStar_Tests_Norm.run_all (); - (let uu___9 = FStar_Tests_Unif.run_all () in - if uu___9 - then () - else FStar_Compiler_Effect.exit Prims.int_one); - FStar_Tests_Data.run_all (); - (let uu___11 = FStar_Errors.report_all () in ()); - (let nerrs = FStar_Errors.get_err_count () in - if nerrs > Prims.int_zero - then FStar_Compiler_Effect.exit Prims.int_one - else (); - FStar_Compiler_Effect.exit Prims.int_zero)) - | FStar_Getopt.Success -> - (FStar_Main.setup_hooks (); - (let uu___5 = FStar_Tests_Pars.init () in ()); - FStar_Tests_Pars.parse_incremental_decls (); - FStar_Tests_Pars.parse_incremental_decls_use_lang (); - FStar_Tests_Norm.run_all (); - (let uu___9 = FStar_Tests_Unif.run_all () in - if uu___9 - then () - else FStar_Compiler_Effect.exit Prims.int_one); - FStar_Tests_Data.run_all (); - (let uu___11 = FStar_Errors.report_all () in ()); - (let nerrs = FStar_Errors.get_err_count () in - if nerrs > Prims.int_zero - then FStar_Compiler_Effect.exit Prims.int_one - else (); - FStar_Compiler_Effect.exit Prims.int_zero))))) () - with - | FStar_Errors.Error (err, msg, r, _ctx) when - let uu___2 = FStar_Options.trace_error () in - Prims.op_Negation uu___2 -> - (if r = FStar_Compiler_Range_Type.dummyRange - then - (let uu___3 = FStar_Errors_Msg.rendermsg msg in - FStar_Compiler_Util.print_string uu___3) - else - (let uu___4 = FStar_Compiler_Range_Ops.string_of_range r in - let uu___5 = FStar_Errors_Msg.rendermsg msg in - FStar_Compiler_Util.print2 "%s: %s\n" uu___4 uu___5); - FStar_Compiler_Effect.exit Prims.int_one) - | e -> - ((let uu___3 = FStar_Compiler_Util.message_of_exn e in - let uu___4 = FStar_Compiler_Util.trace_of_exn e in - FStar_Compiler_Util.print2_error "Error\n%s\n%s\n" uu___3 uu___4); - FStar_Compiler_Effect.exit Prims.int_one)) \ No newline at end of file diff --git a/ocaml/fstar-tests/generated/FStar_Tests_Unif.ml b/ocaml/fstar-tests/generated/FStar_Tests_Unif.ml deleted file mode 100644 index 22c5b33ca83..00000000000 --- a/ocaml/fstar-tests/generated/FStar_Tests_Unif.ml +++ /dev/null @@ -1,581 +0,0 @@ -open Prims -let (tcenv : unit -> FStar_TypeChecker_Env.env) = - fun uu___ -> FStar_Tests_Pars.init () -let (guard_to_string : - FStar_TypeChecker_Common.guard_formula -> Prims.string) = - fun g -> - match g with - | FStar_TypeChecker_Common.Trivial -> "trivial" - | FStar_TypeChecker_Common.NonTrivial f -> - let uu___ = tcenv () in - FStar_TypeChecker_Normalize.term_to_string uu___ f -let (success : Prims.bool FStar_Compiler_Effect.ref) = - FStar_Compiler_Util.mk_ref true -let (fail : Prims.string -> unit) = - fun msg -> - FStar_Compiler_Util.print_string msg; - FStar_Compiler_Effect.op_Colon_Equals success false -let (guard_eq : - Prims.int -> - FStar_TypeChecker_Common.guard_formula -> - FStar_TypeChecker_Common.guard_formula -> unit) - = - fun i -> - fun g -> - fun g' -> - let uu___ = - match (g, g') with - | (FStar_TypeChecker_Common.Trivial, - FStar_TypeChecker_Common.Trivial) -> (true, g, g') - | (FStar_TypeChecker_Common.NonTrivial f, - FStar_TypeChecker_Common.NonTrivial f') -> - let f1 = - let uu___1 = tcenv () in - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.EraseUniverses] uu___1 f in - let f'1 = - let uu___1 = tcenv () in - FStar_TypeChecker_Normalize.normalize - [FStar_TypeChecker_Env.EraseUniverses] uu___1 f' in - let uu___1 = FStar_Tests_Util.term_eq f1 f'1 in - (uu___1, (FStar_TypeChecker_Common.NonTrivial f1), - (FStar_TypeChecker_Common.NonTrivial f'1)) - | uu___1 -> (false, g, g') in - match uu___ with - | (b, g1, g'1) -> - (if Prims.op_Negation b - then - (let uu___2 = - let uu___3 = FStar_Compiler_Util.string_of_int i in - let uu___4 = guard_to_string g'1 in - let uu___5 = guard_to_string g1 in - FStar_Compiler_Util.format3 - "Test %s failed:\n\tExpected guard %s;\n\tGot guard %s\n" - uu___3 uu___4 uu___5 in - fail uu___2) - else (); - (let uu___2 = (FStar_Compiler_Effect.op_Bang success) && b in - FStar_Compiler_Effect.op_Colon_Equals success uu___2)) -let (unify : - Prims.int -> - FStar_Syntax_Syntax.bv Prims.list -> - FStar_Syntax_Syntax.typ -> - FStar_Syntax_Syntax.typ -> - FStar_TypeChecker_Common.guard_formula -> (unit -> unit) -> unit) - = - fun i -> - fun bvs -> - fun x -> - fun y -> - fun g' -> - fun check -> - (let uu___1 = FStar_Compiler_Util.string_of_int i in - FStar_Compiler_Util.print1 "%s ..." uu___1); - (let uu___2 = FStar_Main.process_args () in ()); - (let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term x in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term y in - FStar_Compiler_Util.print2 "Unify %s\nand %s\n" uu___3 uu___4); - (let tcenv1 = tcenv () in - let tcenv2 = FStar_TypeChecker_Env.push_bvs tcenv1 bvs in - let g = - let uu___3 = - let uu___4 = FStar_TypeChecker_Rel.teq tcenv2 x y in - FStar_TypeChecker_Rel.solve_deferred_constraints tcenv2 - uu___4 in - FStar_TypeChecker_Rel.simplify_guard tcenv2 uu___3 in - guard_eq i g.FStar_TypeChecker_Common.guard_f g'; - check (); - FStar_Options.init ()) -let (should_fail : - FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.typ -> unit) = - fun x -> - fun y -> - try - (fun uu___ -> - match () with - | () -> - let g = - let uu___1 = tcenv () in - let uu___2 = - let uu___3 = tcenv () in - FStar_TypeChecker_Rel.teq uu___3 x y in - FStar_TypeChecker_Rel.solve_deferred_constraints uu___1 - uu___2 in - (match g.FStar_TypeChecker_Common.guard_f with - | FStar_TypeChecker_Common.Trivial -> - let uu___1 = - let uu___2 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term x in - let uu___3 = - FStar_Class_Show.show - FStar_Syntax_Print.showable_term y in - FStar_Compiler_Util.format2 - "%s and %s should not be unifiable\n" uu___2 uu___3 in - fail uu___1 - | FStar_TypeChecker_Common.NonTrivial f -> - let uu___1 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - x in - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - y in - let uu___3 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - f in - FStar_Compiler_Util.print3 - "%s and %s are unifiable if %s\n" uu___1 uu___2 uu___3)) - () - with - | FStar_Errors.Error (e, msg, r, _ctx) -> - let uu___1 = FStar_Errors_Msg.rendermsg msg in - FStar_Compiler_Util.print1 "%s\n" uu___1 -let (unify' : Prims.string -> Prims.string -> unit) = - fun x -> - fun y -> - let x1 = FStar_Tests_Pars.pars x in - let y1 = FStar_Tests_Pars.pars y in - let g = - let uu___ = tcenv () in - let uu___1 = - let uu___2 = tcenv () in FStar_TypeChecker_Rel.teq uu___2 x1 y1 in - FStar_TypeChecker_Rel.solve_deferred_constraints uu___ uu___1 in - let uu___ = FStar_Class_Show.show FStar_Syntax_Print.showable_term x1 in - let uu___1 = FStar_Class_Show.show FStar_Syntax_Print.showable_term y1 in - let uu___2 = guard_to_string g.FStar_TypeChecker_Common.guard_f in - FStar_Compiler_Util.print3 "%s and %s are unifiable with guard %s\n" - uu___ uu___1 uu___2 -let (norm : FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.term) = - fun t -> - let uu___ = tcenv () in FStar_TypeChecker_Normalize.normalize [] uu___ t -let (check_core : - Prims.int -> - Prims.bool -> - Prims.bool -> - FStar_Syntax_Syntax.typ -> FStar_Syntax_Syntax.typ -> unit) - = - fun i -> - fun subtyping -> - fun guard_ok -> - fun x -> - fun y -> - (let uu___1 = FStar_Main.process_args () in ()); - (let env = tcenv () in - let res = - if subtyping - then - FStar_TypeChecker_Core.check_term_subtyping true true env x - y - else - FStar_TypeChecker_Core.check_term_equality true true env x y in - (match res with - | FStar_Pervasives.Inl (FStar_Pervasives_Native.None) -> - let uu___2 = FStar_Compiler_Util.string_of_int i in - FStar_Compiler_Util.print1 "%s core check ok\n" uu___2 - | FStar_Pervasives.Inl (FStar_Pervasives_Native.Some g) -> - ((let uu___3 = FStar_Compiler_Util.string_of_int i in - let uu___4 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term - g in - FStar_Compiler_Util.print2 - "%s core check computed guard %s ok\n" uu___3 uu___4); - if Prims.op_Negation guard_ok - then FStar_Compiler_Effect.op_Colon_Equals success false - else ()) - | FStar_Pervasives.Inr err -> - (FStar_Compiler_Effect.op_Colon_Equals success false; - (let uu___3 = FStar_Compiler_Util.string_of_int i in - let uu___4 = FStar_TypeChecker_Core.print_error err in - FStar_Compiler_Util.print2 "%s failed\n%s\n" uu___3 - uu___4))); - FStar_Options.init ()) -let (check_core_typing : - Prims.int -> FStar_Syntax_Syntax.term -> FStar_Syntax_Syntax.typ -> unit) = - fun i -> - fun e -> - fun t -> - (let uu___1 = FStar_Main.process_args () in ()); - (let env = tcenv () in - (let uu___2 = FStar_TypeChecker_Core.check_term env e t true in - match uu___2 with - | FStar_Pervasives.Inl (FStar_Pervasives_Native.None) -> - let uu___3 = FStar_Compiler_Util.string_of_int i in - FStar_Compiler_Util.print1 "%s core typing ok\n" uu___3 - | FStar_Pervasives.Inl (FStar_Pervasives_Native.Some g) -> - ((let uu___4 = FStar_Compiler_Util.string_of_int i in - FStar_Compiler_Util.print1 - "%s core typing produced a guard\n" uu___4); - FStar_Compiler_Effect.op_Colon_Equals success false) - | FStar_Pervasives.Inr err -> - (FStar_Compiler_Effect.op_Colon_Equals success false; - (let uu___4 = FStar_Compiler_Util.string_of_int i in - let uu___5 = FStar_TypeChecker_Core.print_error err in - FStar_Compiler_Util.print2 "%s failed\n%s\n" uu___4 uu___5))); - FStar_Options.init ()) -let (inst : - Prims.int -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - (FStar_Syntax_Syntax.term * FStar_Syntax_Syntax.term Prims.list)) - = - fun n -> - fun tm -> - let rec aux out n1 = - if n1 = Prims.int_zero - then out - else - (let uu___1 = - let uu___2 = FStar_Tests_Pars.init () in - FStar_TypeChecker_Util.new_implicit_var "" - FStar_Compiler_Range_Type.dummyRange uu___2 - FStar_Syntax_Util.ktype0 false in - match uu___1 with - | (t, uu___2, uu___3) -> - let uu___4 = - let uu___5 = FStar_Tests_Pars.init () in - FStar_TypeChecker_Util.new_implicit_var "" - FStar_Compiler_Range_Type.dummyRange uu___5 t false in - (match uu___4 with - | (u, uu___5, uu___6) -> aux (u :: out) (n1 - Prims.int_one))) in - let us = aux [] n in - let uu___ = let uu___1 = FStar_Tests_Util.app tm us in norm uu___1 in - (uu___, us) -let (run_all : unit -> Prims.bool) = - fun uu___ -> - FStar_Compiler_Util.print_string "Testing the unifier\n"; - FStar_Options.__set_unit_tests (); - (let unify_check n bvs x y g f = unify n bvs x y g f in - let unify1 n bvs x y g = unify n bvs x y g (fun uu___3 -> ()) in - let int_t = FStar_Tests_Pars.tc "Prims.int" in - let x_bv = - FStar_Syntax_Syntax.gen_bv "x" FStar_Pervasives_Native.None int_t in - let y_bv = - FStar_Syntax_Syntax.gen_bv "y" FStar_Pervasives_Native.None int_t in - let x = FStar_Syntax_Syntax.bv_to_name x_bv in - let y = FStar_Syntax_Syntax.bv_to_name y_bv in - unify1 Prims.int_zero [x_bv] x x FStar_TypeChecker_Common.Trivial; - (let uu___5 = - let uu___6 = - FStar_Syntax_Util.mk_eq2 FStar_Syntax_Syntax.U_zero - FStar_Syntax_Util.t_bool x y in - FStar_TypeChecker_Common.NonTrivial uu___6 in - unify1 Prims.int_one [x_bv; y_bv] x y uu___5); - (let id = FStar_Tests_Pars.tc "fun (x:bool) -> x" in - (let uu___6 = FStar_Tests_Util.app id [x] in - unify1 (Prims.of_int (2)) [x_bv] x uu___6 - FStar_TypeChecker_Common.Trivial); - (let id1 = FStar_Tests_Pars.tc "fun (x:bool) -> x" in - unify1 (Prims.of_int (3)) [] id1 id1 FStar_TypeChecker_Common.Trivial; - (let id2 = FStar_Tests_Pars.tc "fun (x:bool) -> x" in - let id' = FStar_Tests_Pars.tc "fun (y:bool) -> y" in - unify1 (Prims.of_int (4)) [] id2 id' FStar_TypeChecker_Common.Trivial; - (let uu___9 = FStar_Tests_Pars.tc "fun (x y:bool) -> x" in - let uu___10 = FStar_Tests_Pars.tc "fun (a b:bool) -> a" in - unify1 (Prims.of_int (5)) [] uu___9 uu___10 - FStar_TypeChecker_Common.Trivial); - (let uu___10 = FStar_Tests_Pars.tc "fun (x y z:bool) -> y" in - let uu___11 = FStar_Tests_Pars.tc "fun (a b c:bool) -> b" in - unify1 (Prims.of_int (6)) [] uu___10 uu___11 - FStar_TypeChecker_Common.Trivial); - (let uu___11 = FStar_Tests_Pars.tc "fun (x:int) (y:int) -> y" in - let uu___12 = FStar_Tests_Pars.tc "fun (x:int) (y:int) -> x" in - let uu___13 = - let uu___14 = - FStar_Tests_Pars.tc "(forall (x:int). (forall (y:int). y==x))" in - FStar_TypeChecker_Common.NonTrivial uu___14 in - unify1 (Prims.of_int (7)) [] uu___11 uu___12 uu___13); - (let uu___12 = FStar_Tests_Pars.tc "fun (x:int) (y:int) (z:int) -> y" in - let uu___13 = FStar_Tests_Pars.tc "fun (x:int) (y:int) (z:int) -> z" in - let uu___14 = - let uu___15 = - FStar_Tests_Pars.tc - "(forall (x:int). (forall (y:int). (forall (z:int). y==z)))" in - FStar_TypeChecker_Common.NonTrivial uu___15 in - unify1 (Prims.of_int (8)) [] uu___12 uu___13 uu___14); - (let uu___13 = FStar_Main.process_args () in ()); - (let uu___13 = - let uu___14 = - FStar_Tests_Pars.tc "fun (u:Type0 -> Type0) (x:Type0) -> u x" in - inst Prims.int_one uu___14 in - match uu___13 with - | (tm, us) -> - let sol = FStar_Tests_Pars.tc "fun (x:Type0) -> Prims.pair x x" in - (unify_check (Prims.of_int (9)) [] tm sol - FStar_TypeChecker_Common.Trivial - (fun uu___15 -> - let uu___16 = - let uu___17 = - let uu___18 = FStar_Compiler_List.hd us in - norm uu___18 in - let uu___18 = norm sol in - FStar_Tests_Util.term_eq uu___17 uu___18 in - FStar_Tests_Util.always (Prims.of_int (9)) uu___16); - (let uu___15 = - let uu___16 = - FStar_Tests_Pars.tc - "fun (u: int -> int -> int) (x:int) -> u x" in - inst Prims.int_one uu___16 in - match uu___15 with - | (tm1, us1) -> - let sol1 = FStar_Tests_Pars.tc "fun (x y:int) -> x + y" in - (unify_check (Prims.of_int (10)) [] tm1 sol1 - FStar_TypeChecker_Common.Trivial - (fun uu___17 -> - let uu___18 = - let uu___19 = - let uu___20 = FStar_Compiler_List.hd us1 in - norm uu___20 in - let uu___20 = norm sol1 in - FStar_Tests_Util.term_eq uu___19 uu___20 in - FStar_Tests_Util.always (Prims.of_int (10)) uu___18); - (let tm11 = - FStar_Tests_Pars.tc "x:int -> y:int{eq2 y x} -> bool" in - let tm2 = FStar_Tests_Pars.tc "x:int -> y:int -> bool" in - (let uu___18 = - let uu___19 = - FStar_Tests_Pars.tc - "forall (x:int). (forall (y:int). y==x)" in - FStar_TypeChecker_Common.NonTrivial uu___19 in - unify1 (Prims.of_int (11)) [] tm11 tm2 uu___18); - (let tm12 = - FStar_Tests_Pars.tc - "a:Type0 -> b:(a -> Type0) -> x:a -> y:b x -> Tot Type0" in - let tm21 = - FStar_Tests_Pars.tc - "a:Type0 -> b:(a -> Type0) -> x:a -> y:b x -> Tot Type0" in - unify1 (Prims.of_int (12)) [] tm12 tm21 - FStar_TypeChecker_Common.Trivial; - (let uu___19 = - let int_typ = FStar_Tests_Pars.tc "int" in - let x1 = - FStar_Syntax_Syntax.new_bv - FStar_Pervasives_Native.None int_typ in - let typ = FStar_Tests_Pars.tc "unit -> Type0" in - let l = - FStar_Tests_Pars.tc - "fun (q:(unit -> Type0)) -> q ()" in - let q = - FStar_Syntax_Syntax.new_bv - FStar_Pervasives_Native.None typ in - let tm13 = - let uu___20 = - let uu___21 = - let uu___22 = FStar_Syntax_Syntax.bv_to_name q in - [uu___22] in - FStar_Tests_Util.app l uu___21 in - norm uu___20 in - let l1 = - FStar_Tests_Pars.tc "fun (p:unit -> Type0) -> p" in - let unit = FStar_Tests_Pars.tc "()" in - let env = - let uu___20 = FStar_Tests_Pars.init () in - let uu___21 = - let uu___22 = FStar_Syntax_Syntax.mk_binder x1 in - let uu___23 = - let uu___24 = FStar_Syntax_Syntax.mk_binder q in - [uu___24] in - uu___22 :: uu___23 in - FStar_TypeChecker_Env.push_binders uu___20 uu___21 in - let uu___20 = - FStar_TypeChecker_Util.new_implicit_var "" - FStar_Compiler_Range_Type.dummyRange env typ - false in - match uu___20 with - | (u_p, uu___21, uu___22) -> - let tm22 = - let uu___23 = - let uu___24 = FStar_Tests_Util.app l1 [u_p] in - norm uu___24 in - FStar_Tests_Util.app uu___23 [unit] in - (tm13, tm22, [x1; q]) in - match uu___19 with - | (tm13, tm22, bvs_13) -> - (unify1 (Prims.of_int (13)) bvs_13 tm13 tm22 - FStar_TypeChecker_Common.Trivial; - (let uu___21 = - let int_typ = FStar_Tests_Pars.tc "int" in - let x1 = - FStar_Syntax_Syntax.new_bv - FStar_Pervasives_Native.None int_typ in - let typ = FStar_Tests_Pars.tc "pure_post unit" in - let l = - FStar_Tests_Pars.tc - "fun (q:pure_post unit) -> q ()" in - let q = - FStar_Syntax_Syntax.new_bv - FStar_Pervasives_Native.None typ in - let tm14 = - let uu___22 = - let uu___23 = - let uu___24 = - FStar_Syntax_Syntax.bv_to_name q in - [uu___24] in - FStar_Tests_Util.app l uu___23 in - norm uu___22 in - let l1 = - FStar_Tests_Pars.tc - "fun (p:pure_post unit) -> p" in - let unit = FStar_Tests_Pars.tc "()" in - let env = - let uu___22 = FStar_Tests_Pars.init () in - let uu___23 = - let uu___24 = - FStar_Syntax_Syntax.mk_binder x1 in - let uu___25 = - let uu___26 = - FStar_Syntax_Syntax.mk_binder q in - [uu___26] in - uu___24 :: uu___25 in - FStar_TypeChecker_Env.push_binders uu___22 - uu___23 in - let uu___22 = - FStar_TypeChecker_Util.new_implicit_var "" - FStar_Compiler_Range_Type.dummyRange env - typ false in - match uu___22 with - | (u_p, uu___23, uu___24) -> - let tm23 = - let uu___25 = - let uu___26 = - FStar_Tests_Util.app l1 [u_p] in - norm uu___26 in - FStar_Tests_Util.app uu___25 [unit] in - (tm14, tm23, [x1; q]) in - match uu___21 with - | (tm14, tm23, bvs_14) -> - (unify1 (Prims.of_int (14)) bvs_14 tm14 tm23 - FStar_TypeChecker_Common.Trivial; - (let uu___23 = - FStar_Tests_Pars.pars_and_tc_fragment - "let ty0 n = x:int { x >= n }\nlet ty1 n = x:ty0 n { x > n }\nassume val tc (t:Type0) : Type0"; - (let t0 = FStar_Tests_Pars.tc "ty1 17" in - let t1 = - FStar_Tests_Pars.tc - "x:ty0 17 { x > 17 }" in - (t0, t1)) in - match uu___23 with - | (tm15, tm24) -> - (check_core (Prims.of_int (15)) false - false tm15 tm24; - (let uu___25 = - let t0 = - FStar_Tests_Pars.tc - "x:int { x >= 17 /\\ x > 17 }" in - let t1 = - FStar_Tests_Pars.tc - "x:ty0 17 { x > 17 }" in - (t0, t1) in - match uu___25 with - | (tm16, tm25) -> - (check_core (Prims.of_int (16)) - false false tm16 tm25; - (let uu___27 = - FStar_Tests_Pars.pars_and_tc_fragment - "let defn17_0 (x:nat) : nat -> nat -> Type0 = fun y z -> a:int { a + x == y + z }"; - (let t0 = - FStar_Tests_Pars.tc - "defn17_0 0 1 2" in - let t1_head = - FStar_Tests_Pars.tc - "(defn17_0 0)" in - let arg1 = - FStar_Tests_Pars.tc "1" in - let arg2 = - FStar_Tests_Pars.tc "2" in - let t1 = - FStar_Syntax_Syntax.mk_Tm_app - t1_head - [(arg1, - FStar_Pervasives_Native.None); - (arg2, - FStar_Pervasives_Native.None)] - t0.FStar_Syntax_Syntax.pos in - (t0, t1)) in - match uu___27 with - | (tm17, tm26) -> - (check_core - (Prims.of_int (17)) - false false tm17 tm26; - (let uu___29 = - let t0 = - FStar_Tests_Pars.tc - "dp:((dtuple2 int (fun (y:int) -> z:int{ z > y })) <: Type0) { let (| x, _ |) = dp in x > 17 }" in - let t1 = - FStar_Tests_Pars.tc - "(dtuple2 int (fun (y:int) -> z:int{ z > y }))" in - (t0, t1) in - match uu___29 with - | (tm18, tm27) -> - (check_core - (Prims.of_int (18)) - true false tm18 - tm27; - (let uu___31 = - FStar_Tests_Pars.pars_and_tc_fragment - "type vprop' = { t:Type0 ; n:nat }"; - (let t0 = - FStar_Tests_Pars.tc - "x:(({ t=bool; n=0 }).t <: Type0) { x == false }" in - let t1 = - FStar_Tests_Pars.tc - "x:bool{ x == false }" in - (t0, t1)) in - match uu___31 with - | (tm19, tm28) -> - (check_core - (Prims.of_int (19)) - false false - tm19 tm28; - (let uu___33 - = - let t0 = - FStar_Tests_Pars.tc - "int" in - let t1 = - FStar_Tests_Pars.tc - "j:(i:nat{ i > 17 } <: Type0){j > 42}" in - (t0, t1) in - match uu___33 - with - | (tm110, - tm29) -> - (check_core - (Prims.of_int (20)) - true true - tm110 - tm29; - (let uu___35 - = - FStar_Tests_Pars.pars_and_tc_fragment - "assume val tstr21 (x:string) : Type0"; - ( - let t0 = - FStar_Tests_Pars.tc - "(fun (x:bool) (y:int) (z: (fun (x:string) -> tstr21 x) \"hello\") -> x)" in - let ty = - FStar_Tests_Pars.tc - "bool -> int -> tstr21 \"hello\" -> bool" in - (t0, ty)) in - match uu___35 - with - | - (tm3, ty) - -> - (check_core_typing - (Prims.of_int (21)) - tm3 ty; - FStar_Options.__clear_unit_tests - (); - (let uu___39 - = - FStar_Compiler_Effect.op_Bang - success in - if - uu___39 - then - FStar_Compiler_Util.print_string - "Unifier ok\n" - else ()); - FStar_Compiler_Effect.op_Bang - success)))))))))))))))))))))))))))) \ No newline at end of file diff --git a/ocaml/fstar-tests/generated/FStar_Tests_Util.ml b/ocaml/fstar-tests/generated/FStar_Tests_Util.ml deleted file mode 100644 index ddbdb8a5755..00000000000 --- a/ocaml/fstar-tests/generated/FStar_Tests_Util.ml +++ /dev/null @@ -1,329 +0,0 @@ -open Prims -let (always : Prims.int -> Prims.bool -> unit) = - fun id -> - fun b -> - if b - then () - else - (let uu___1 = - let uu___2 = FStar_Compiler_Util.string_of_int id in - FStar_Compiler_Util.format1 "Assertion failed: test %s" uu___2 in - FStar_Errors.raise_error0 FStar_Errors_Codes.Fatal_AssertionFailure - () (Obj.magic FStar_Errors_Msg.is_error_message_string) - (Obj.magic uu___1)) -let (x : FStar_Syntax_Syntax.bv) = - FStar_Syntax_Syntax.gen_bv "x" FStar_Pervasives_Native.None - FStar_Syntax_Syntax.tun -let (y : FStar_Syntax_Syntax.bv) = - FStar_Syntax_Syntax.gen_bv "y" FStar_Pervasives_Native.None - FStar_Syntax_Syntax.tun -let (n : FStar_Syntax_Syntax.bv) = - FStar_Syntax_Syntax.gen_bv "n" FStar_Pervasives_Native.None - FStar_Syntax_Syntax.tun -let (h : FStar_Syntax_Syntax.bv) = - FStar_Syntax_Syntax.gen_bv "h" FStar_Pervasives_Native.None - FStar_Syntax_Syntax.tun -let (m : FStar_Syntax_Syntax.bv) = - FStar_Syntax_Syntax.gen_bv "m" FStar_Pervasives_Native.None - FStar_Syntax_Syntax.tun -let tm : 'uuuuu . 'uuuuu -> 'uuuuu FStar_Syntax_Syntax.syntax = - fun t -> FStar_Syntax_Syntax.mk t FStar_Compiler_Range_Type.dummyRange -let (nm : FStar_Syntax_Syntax.bv -> FStar_Syntax_Syntax.term) = - fun x1 -> FStar_Syntax_Syntax.bv_to_name x1 -let (app : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term Prims.list -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax) - = - fun x1 -> - fun ts -> - let uu___ = - let uu___1 = - let uu___2 = FStar_Compiler_List.map FStar_Syntax_Syntax.as_arg ts in - { FStar_Syntax_Syntax.hd = x1; FStar_Syntax_Syntax.args = uu___2 } in - FStar_Syntax_Syntax.Tm_app uu___1 in - FStar_Syntax_Syntax.mk uu___ FStar_Compiler_Range_Type.dummyRange -let rec (term_eq' : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> Prims.bool) - = - fun t1 -> - fun t2 -> - let t11 = FStar_Syntax_Subst.compress t1 in - let t21 = FStar_Syntax_Subst.compress t2 in - let binders_eq xs ys = - ((FStar_Compiler_List.length xs) = (FStar_Compiler_List.length ys)) - && - (FStar_Compiler_List.forall2 - (fun x1 -> - fun y1 -> - term_eq' - (x1.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort - (y1.FStar_Syntax_Syntax.binder_bv).FStar_Syntax_Syntax.sort) - xs ys) in - let args_eq xs ys = - ((FStar_Compiler_List.length xs) = (FStar_Compiler_List.length ys)) - && - (FStar_Compiler_List.forall2 - (fun uu___ -> - fun uu___1 -> - match (uu___, uu___1) with - | ((a, imp), (b, imp')) -> - (term_eq' a b) && (FStar_Syntax_Util.eq_aqual imp imp')) - xs ys) in - let comp_eq c d = - match ((c.FStar_Syntax_Syntax.n), (d.FStar_Syntax_Syntax.n)) with - | (FStar_Syntax_Syntax.Total t, FStar_Syntax_Syntax.Total s) -> - term_eq' t s - | (FStar_Syntax_Syntax.Comp ct1, FStar_Syntax_Syntax.Comp ct2) -> - ((FStar_Ident.lid_equals ct1.FStar_Syntax_Syntax.effect_name - ct2.FStar_Syntax_Syntax.effect_name) - && - (term_eq' ct1.FStar_Syntax_Syntax.result_typ - ct2.FStar_Syntax_Syntax.result_typ)) - && - (args_eq ct1.FStar_Syntax_Syntax.effect_args - ct2.FStar_Syntax_Syntax.effect_args) - | uu___ -> false in - match ((t11.FStar_Syntax_Syntax.n), (t21.FStar_Syntax_Syntax.n)) with - | (FStar_Syntax_Syntax.Tm_lazy l, uu___) -> - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Compiler_Effect.op_Bang - FStar_Syntax_Syntax.lazy_chooser in - FStar_Compiler_Util.must uu___3 in - uu___2 l.FStar_Syntax_Syntax.lkind l in - term_eq' uu___1 t21 - | (uu___, FStar_Syntax_Syntax.Tm_lazy l) -> - let uu___1 = - let uu___2 = - let uu___3 = - FStar_Compiler_Effect.op_Bang - FStar_Syntax_Syntax.lazy_chooser in - FStar_Compiler_Util.must uu___3 in - uu___2 l.FStar_Syntax_Syntax.lkind l in - term_eq' t11 uu___1 - | (FStar_Syntax_Syntax.Tm_bvar x1, FStar_Syntax_Syntax.Tm_bvar y1) -> - x1.FStar_Syntax_Syntax.index = y1.FStar_Syntax_Syntax.index - | (FStar_Syntax_Syntax.Tm_name x1, FStar_Syntax_Syntax.Tm_name y1) -> - FStar_Syntax_Syntax.bv_eq x1 y1 - | (FStar_Syntax_Syntax.Tm_fvar f, FStar_Syntax_Syntax.Tm_fvar g) -> - FStar_Syntax_Syntax.fv_eq f g - | (FStar_Syntax_Syntax.Tm_uinst (t, uu___), - FStar_Syntax_Syntax.Tm_uinst (s, uu___1)) -> term_eq' t s - | (FStar_Syntax_Syntax.Tm_constant c1, FStar_Syntax_Syntax.Tm_constant - c2) -> FStar_Const.eq_const c1 c2 - | (FStar_Syntax_Syntax.Tm_type u, FStar_Syntax_Syntax.Tm_type v) -> - u = v - | (FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = xs; FStar_Syntax_Syntax.body = t; - FStar_Syntax_Syntax.rc_opt = uu___;_}, - FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = ys; FStar_Syntax_Syntax.body = u; - FStar_Syntax_Syntax.rc_opt = uu___1;_}) - when - (FStar_Compiler_List.length xs) = (FStar_Compiler_List.length ys) - -> (binders_eq xs ys) && (term_eq' t u) - | (FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = xs; FStar_Syntax_Syntax.body = t; - FStar_Syntax_Syntax.rc_opt = uu___;_}, - FStar_Syntax_Syntax.Tm_abs - { FStar_Syntax_Syntax.bs = ys; FStar_Syntax_Syntax.body = u; - FStar_Syntax_Syntax.rc_opt = uu___1;_}) - -> - if - (FStar_Compiler_List.length xs) > (FStar_Compiler_List.length ys) - then - let uu___2 = - FStar_Compiler_Util.first_N (FStar_Compiler_List.length ys) xs in - (match uu___2 with - | (xs1, xs') -> - let t12 = - let uu___3 = - let uu___4 = - let uu___5 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = xs'; - FStar_Syntax_Syntax.body = t; - FStar_Syntax_Syntax.rc_opt = - FStar_Pervasives_Native.None - }) t11.FStar_Syntax_Syntax.pos in - { - FStar_Syntax_Syntax.bs = xs1; - FStar_Syntax_Syntax.body = uu___5; - FStar_Syntax_Syntax.rc_opt = - FStar_Pervasives_Native.None - } in - FStar_Syntax_Syntax.Tm_abs uu___4 in - FStar_Syntax_Syntax.mk uu___3 t11.FStar_Syntax_Syntax.pos in - term_eq' t12 t21) - else - (let uu___3 = - FStar_Compiler_Util.first_N (FStar_Compiler_List.length xs) ys in - match uu___3 with - | (ys1, ys') -> - let t22 = - let uu___4 = - let uu___5 = - let uu___6 = - FStar_Syntax_Syntax.mk - (FStar_Syntax_Syntax.Tm_abs - { - FStar_Syntax_Syntax.bs = ys'; - FStar_Syntax_Syntax.body = u; - FStar_Syntax_Syntax.rc_opt = - FStar_Pervasives_Native.None - }) t21.FStar_Syntax_Syntax.pos in - { - FStar_Syntax_Syntax.bs = ys1; - FStar_Syntax_Syntax.body = uu___6; - FStar_Syntax_Syntax.rc_opt = - FStar_Pervasives_Native.None - } in - FStar_Syntax_Syntax.Tm_abs uu___5 in - FStar_Syntax_Syntax.mk uu___4 t21.FStar_Syntax_Syntax.pos in - term_eq' t11 t22) - | (FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = xs; FStar_Syntax_Syntax.comp = c;_}, - FStar_Syntax_Syntax.Tm_arrow - { FStar_Syntax_Syntax.bs1 = ys; FStar_Syntax_Syntax.comp = d;_}) -> - (binders_eq xs ys) && (comp_eq c d) - | (FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = x1; FStar_Syntax_Syntax.phi = t;_}, - FStar_Syntax_Syntax.Tm_refine - { FStar_Syntax_Syntax.b = y1; FStar_Syntax_Syntax.phi = u;_}) -> - (term_eq' x1.FStar_Syntax_Syntax.sort y1.FStar_Syntax_Syntax.sort) - && (term_eq' t u) - | (FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar fv_eq_1; - FStar_Syntax_Syntax.pos = uu___; - FStar_Syntax_Syntax.vars = uu___1; - FStar_Syntax_Syntax.hash_code = uu___2;_}; - FStar_Syntax_Syntax.args = - (uu___3, FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = uu___4;_})::t12::t22::[];_}, - FStar_Syntax_Syntax.Tm_app - { - FStar_Syntax_Syntax.hd = - { FStar_Syntax_Syntax.n = FStar_Syntax_Syntax.Tm_fvar fv_eq_2; - FStar_Syntax_Syntax.pos = uu___5; - FStar_Syntax_Syntax.vars = uu___6; - FStar_Syntax_Syntax.hash_code = uu___7;_}; - FStar_Syntax_Syntax.args = - (uu___8, FStar_Pervasives_Native.Some - { FStar_Syntax_Syntax.aqual_implicit = true; - FStar_Syntax_Syntax.aqual_attributes = uu___9;_})::s1::s2::[];_}) - when - (FStar_Syntax_Syntax.fv_eq_lid fv_eq_1 FStar_Parser_Const.eq2_lid) - && - (FStar_Syntax_Syntax.fv_eq_lid fv_eq_2 FStar_Parser_Const.eq2_lid) - -> args_eq [s1; s2] [t12; t22] - | (FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = t; FStar_Syntax_Syntax.args = args;_}, - FStar_Syntax_Syntax.Tm_app - { FStar_Syntax_Syntax.hd = s; FStar_Syntax_Syntax.args = args';_}) - -> (term_eq' t s) && (args_eq args args') - | (FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = t; - FStar_Syntax_Syntax.ret_opt = FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.brs = pats; - FStar_Syntax_Syntax.rc_opt1 = uu___;_}, - FStar_Syntax_Syntax.Tm_match - { FStar_Syntax_Syntax.scrutinee = t'; - FStar_Syntax_Syntax.ret_opt = FStar_Pervasives_Native.None; - FStar_Syntax_Syntax.brs = pats'; - FStar_Syntax_Syntax.rc_opt1 = uu___1;_}) - -> - (((FStar_Compiler_List.length pats) = - (FStar_Compiler_List.length pats')) - && - (FStar_Compiler_List.forall2 - (fun uu___2 -> - fun uu___3 -> - match (uu___2, uu___3) with - | ((uu___4, uu___5, e), (uu___6, uu___7, e')) -> - term_eq' e e') pats pats')) - && (term_eq' t t') - | (FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = t12; - FStar_Syntax_Syntax.asc = - (FStar_Pervasives.Inl t22, uu___, uu___1); - FStar_Syntax_Syntax.eff_opt = uu___2;_}, - FStar_Syntax_Syntax.Tm_ascribed - { FStar_Syntax_Syntax.tm = s1; - FStar_Syntax_Syntax.asc = - (FStar_Pervasives.Inl s2, uu___3, uu___4); - FStar_Syntax_Syntax.eff_opt = uu___5;_}) - -> (term_eq' t12 s1) && (term_eq' t22 s2) - | (FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (is_rec, lbs); - FStar_Syntax_Syntax.body1 = t;_}, - FStar_Syntax_Syntax.Tm_let - { FStar_Syntax_Syntax.lbs = (is_rec', lbs'); - FStar_Syntax_Syntax.body1 = s;_}) - when is_rec = is_rec' -> - (((FStar_Compiler_List.length lbs) = - (FStar_Compiler_List.length lbs')) - && - (FStar_Compiler_List.forall2 - (fun lb1 -> - fun lb2 -> - (term_eq' lb1.FStar_Syntax_Syntax.lbtyp - lb2.FStar_Syntax_Syntax.lbtyp) - && - (term_eq' lb1.FStar_Syntax_Syntax.lbdef - lb2.FStar_Syntax_Syntax.lbdef)) lbs lbs')) - && (term_eq' t s) - | (FStar_Syntax_Syntax.Tm_uvar (u, uu___), FStar_Syntax_Syntax.Tm_uvar - (u', uu___1)) -> - FStar_Syntax_Unionfind.equiv u.FStar_Syntax_Syntax.ctx_uvar_head - u'.FStar_Syntax_Syntax.ctx_uvar_head - | (FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t12; FStar_Syntax_Syntax.meta = uu___;_}, - uu___1) -> term_eq' t12 t21 - | (uu___, FStar_Syntax_Syntax.Tm_meta - { FStar_Syntax_Syntax.tm2 = t22; - FStar_Syntax_Syntax.meta = uu___1;_}) - -> term_eq' t11 t22 - | (FStar_Syntax_Syntax.Tm_delayed uu___, uu___1) -> - let uu___2 = - let uu___3 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t11 in - let uu___4 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t21 in - FStar_Compiler_Util.format2 "Impossible: %s and %s" uu___3 uu___4 in - failwith uu___2 - | (uu___, FStar_Syntax_Syntax.Tm_delayed uu___1) -> - let uu___2 = - let uu___3 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t11 in - let uu___4 = - FStar_Class_Tagged.tag_of FStar_Syntax_Syntax.tagged_term t21 in - FStar_Compiler_Util.format2 "Impossible: %s and %s" uu___3 uu___4 in - failwith uu___2 - | (FStar_Syntax_Syntax.Tm_unknown, FStar_Syntax_Syntax.Tm_unknown) -> - true - | uu___ -> false -let (term_eq : - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> - FStar_Syntax_Syntax.term' FStar_Syntax_Syntax.syntax -> Prims.bool) - = - fun t1 -> - fun t2 -> - let b = term_eq' t1 t2 in - if Prims.op_Negation b - then - (let uu___1 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t1 in - let uu___2 = - FStar_Class_Show.show FStar_Syntax_Print.showable_term t2 in - FStar_Compiler_Util.print2 ">>>>>>>>>>>Term %s is not equal to %s\n" - uu___1 uu___2) - else (); - b \ No newline at end of file diff --git a/ocaml/fstar/main.ml b/ocaml/fstar/main.ml index 4b71a36db9b..2a33d943b4f 100644 --- a/ocaml/fstar/main.ml +++ b/ocaml/fstar/main.ml @@ -4,7 +4,7 @@ let x = by default will terminate F*, and we won't get an exception or anything. So, block them, and instead rely on OCaml exceptions to detect this. *) - if FStar_Platform.system = Posix then + if FStarC_Platform.system = Posix then ignore (Unix.sigprocmask Unix.SIG_BLOCK [Sys.sigpipe]); (* Enable memtrace, only if the environment variable MEMTRACE is set. *) @@ -16,4 +16,4 @@ let x = (* Tweak garbage collector parameters. *) Gc.set { (Gc.get()) with Gc.minor_heap_size = 1048576; Gc.major_heap_increment = 4194304; Gc.space_overhead = 150; }; - FStar_Main.main () + FStarC_Main.main () diff --git a/src/FStarCompiler.fst.config.json b/src/FStarCompiler.fst.config.json index c36e0af5e3c..e0e64dc3aa2 100644 --- a/src/FStarCompiler.fst.config.json +++ b/src/FStarCompiler.fst.config.json @@ -2,6 +2,7 @@ "fstar_exe": "fstar.exe", "options": [ "--MLish", + "--MLish_effect", "FStarC.Compiler.Effect", "--lax", "--cache_dir", ".cache.boot", diff --git a/src/Makefile.boot b/src/Makefile.boot index 5fc9c798975..ac97ba48390 100644 --- a/src/Makefile.boot +++ b/src/Makefile.boot @@ -18,42 +18,26 @@ FSTAR_BOOT ?= $(FSTAR) # -- MLish and lax tune type-inference for use with unverified ML programs DUNE_SNAPSHOT ?= $(call maybe_cygwin_path,$(FSTAR_HOME)/ocaml) OUTPUT_DIRECTORY = $(FSTAR_HOME)/src/ocaml-output/fstarc + +FSTAR_BOOT_OPTIONS += --MLish_effect FStarC.Compiler.Effect + FSTAR_C=$(RUNLIM) $(FSTAR_BOOT) $(SIL) $(FSTAR_BOOT_OPTIONS) --cache_checked_modules # Tests.* goes to fstar-tests, the rest to fstar-lib -OUTPUT_DIRECTORY_FOR = $(if $(findstring FStar_Tests_,$(1)),$(DUNE_SNAPSHOT)/fstar-tests/generated,$(OUTPUT_DIRECTORY)) - -# Each "project" for the compiler is in its own namespace. We want to -# extract them all to OCaml. Would be more convenient if all of them -# were within, say, FStar.Compiler.* -EXTRACT_NAMESPACES=FStar.Extraction FStar.Parser \ - FStar.Class \ - FStar.Reflection FStar.SMTEncoding FStar.Syntax \ - FStar.Tactics FStar.Tests FStar.ToSyntax \ - FStar.TypeChecker FStar.Profiling FStar.Compiler \ - FStar.Find FStar.Basefiles +OUTPUT_DIRECTORY_FOR = $(if $(findstring FStarC_Tests_,$(1)),$(DUNE_SNAPSHOT)/fstar-tests/generated,$(OUTPUT_DIRECTORY)) + +EXTRACT_NAMESPACES=FStarC # It's that easy! # Except some files that want to extract are not within a particularly # specific namespace. So, we mention extracting those explicitly. # TODO: Do we really need this anymore? Which (implementation) modules # from src/basic are *not* extracted? -EXTRACT_MODULES=FStar.Pervasives FStar.Common FStar.Thunk \ - FStar.VConfig FStar.Options FStar.Options.Ext FStar.Ident FStar.Errors FStar.Errors.Codes \ - FStar.Errors.Msg FStar.Errors.Raise FStar.Const \ - FStar.Compiler.Order FStar.Order FStar.Dependencies \ - FStar.Interactive.CompletionTable \ - FStar.Interactive.JsonHelper FStar.Interactive.QueryHelper \ - FStar.Interactive.PushHelper FStar.Interactive.Lsp \ - FStar.Interactive.Ide FStar.Interactive.Ide.Types \ - FStar.Interactive.Incremental FStar.Interactive.Legacy \ - FStar.CheckedFiles FStar.Universal FStar.Prettyprint \ - FStar.Main FStar.Json FStar.GenSym \ - FStar.Defensive +EXTRACT_MODULES=FStar.Pervasives FStar.Order # And there are a few specific files that should not be extracted at # all, despite being in one of the EXTRACT_NAMESPACES -NO_EXTRACT=FStar.Tactics.Native FStar.Tactics.Load \ - FStar.Extraction.ML.PrintML FStar.Compiler.List +NO_EXTRACT=FStarC.Tactics.Native FStarC.Tactics.Load \ + FStarC.Extraction.ML.PrintML FStarC.Compiler.List EXTRACT = $(addprefix --extract_module , $(EXTRACT_MODULES)) \ $(addprefix --extract_namespace , $(EXTRACT_NAMESPACES)) \ @@ -96,22 +80,22 @@ EXTRACT = $(addprefix --extract_module , $(EXTRACT_MODULES)) \ .depend: $(call msg, "DEPEND") $(Q)$(FSTAR_C) --dep full \ - fstar/FStar.Main.fst \ - tests/FStar.Tests.Test.fst \ + fstar/FStarC.Main.fst \ + tests/FStarC.Tests.Test.fst \ --odir $(OUTPUT_DIRECTORY) \ $(EXTRACT) \ --output_deps_to ._depend @# We've generated deps for everything into fstar-lib/generated. @# Here we fix up the .depend file to move tests out of the library. - $(Q)$(SED) 's,src/ocaml-output/fstarc/FStar_Test,ocaml/fstar-tests/generated/FStar_Test,g' <._depend >.depend + $(Q)$(SED) 's,src/ocaml-output/fstarc/FStarC_Test,ocaml/fstar-tests/generated/FStarC_Test,g' <._depend >.depend $(Q)mkdir -p $(CACHE_DIR) .PHONY: dep.graph dep.graph: $(call msg, "DEPEND") $(Q)$(FSTAR_C) --dep graph \ - fstar/FStar.Main.fst \ - tests/FStar.Tests.Test.fst \ + fstar/FStarC.Main.fst \ + tests/FStarC.Tests.Test.fst \ $(EXTRACT) \ --output_deps_to dep.graph diff --git a/src/README b/src/README index a0d658b43f6..701ee7e95ed 100644 --- a/src/README +++ b/src/README @@ -6,8 +6,8 @@ Some files are written directly in OCaml: * The lexer: uses the OCaml Sedlexing library - * Some basic system utilities, like FStar.Compiler.Util only has an - interface in F* and is implemented as FStar_Compiler_Util.ml + * Some basic system utilities, like FStarC.Compiler.Util only has an + interface in F* and is implemented as FStarC_Compiler_Util.ml -------------------------------------------------------------------------------- diff --git a/src/basic/FStar.BaseTypes.fsti b/src/basic/FStar.BaseTypes.fsti deleted file mode 100644 index 49c2bbf6ddd..00000000000 --- a/src/basic/FStar.BaseTypes.fsti +++ /dev/null @@ -1,33 +0,0 @@ -(* - Copyright 2008-2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.BaseTypes - -/// This module aggregates commonly used primitive type constants into -/// a single module, providing abbreviations for them. - -type char = FStar.Char.char -type float -type double -type byte -type int8 -type uint8 -type int16 -type uint16 -type int32 -type uint32 -type int64 -type uint64 diff --git a/src/basic/FStar.Basefiles.fst b/src/basic/FStar.Basefiles.fst deleted file mode 100644 index 6c4eb68746f..00000000000 --- a/src/basic/FStar.Basefiles.fst +++ /dev/null @@ -1,26 +0,0 @@ -module FStar.Basefiles - -open FStar -open FStar.Compiler.Effect - -module O = FStar.Options -module BU = FStar.Compiler.Util -module E = FStar.Errors - -let must_find (fn:string) : string = - match Find.find_file fn with - | Some f -> f - | None -> - E.raise_error0 E.Fatal_ModuleNotFound [ - E.text (BU.format1 "Unable to find required file \"%s\" in the module search path." fn); - ] - -let prims () = - match O.custom_prims() with - | Some fn -> fn (* user-specified prims *) - | None -> must_find "Prims.fst" - -let prims_basename () = BU.basename (prims ()) -let pervasives () = must_find "FStar.Pervasives.fsti" -let pervasives_basename () = BU.basename (pervasives ()) -let pervasives_native_basename () = must_find "FStar.Pervasives.Native.fst" |> BU.basename diff --git a/src/basic/FStar.Basefiles.fsti b/src/basic/FStar.Basefiles.fsti deleted file mode 100644 index 621c957ed1e..00000000000 --- a/src/basic/FStar.Basefiles.fsti +++ /dev/null @@ -1,9 +0,0 @@ -module FStar.Basefiles - -open FStar.Compiler.Effect - -val prims : unit -> string -val prims_basename : unit -> string -val pervasives : unit -> string -val pervasives_basename : unit -> string -val pervasives_native_basename : unit -> string diff --git a/src/basic/FStar.BigInt.fsti b/src/basic/FStar.BigInt.fsti deleted file mode 100644 index 1c4e761a056..00000000000 --- a/src/basic/FStar.BigInt.fsti +++ /dev/null @@ -1,59 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.BigInt -open FStar.Compiler.Effect - -type bigint -type t = bigint - -val zero : bigint -val one : bigint -val two : bigint - -val succ_big_int : (bigint -> bigint) -val pred_big_int : (bigint -> bigint) -val minus_big_int : (bigint -> bigint) -val abs_big_int : (bigint -> bigint) - -val add_big_int : (bigint -> bigint -> bigint) -val mult_big_int : (bigint -> bigint -> bigint) -val sub_big_int : (bigint -> bigint -> bigint) -val div_big_int : (bigint -> bigint -> bigint) -val mod_big_int : (bigint -> bigint -> bigint) - -val eq_big_int : (bigint -> bigint -> bool) -val le_big_int : (bigint -> bigint -> bool) -val lt_big_int : (bigint -> bigint -> bool) -val ge_big_int : (bigint -> bigint -> bool) -val gt_big_int : (bigint -> bigint -> bool) - -val logand_big_int: bigint -> bigint -> bigint -val logor_big_int: bigint -> bigint -> bigint -val logxor_big_int: bigint -> bigint -> bigint -val lognot_big_int: bigint -> bigint - -val shift_left_big_int: bigint -> bigint -> bigint -val shift_right_big_int: bigint -> bigint -> bigint - -val sqrt_big_int : (bigint -> bigint) - -val string_of_big_int : (bigint -> string) -val big_int_of_string : (string -> bigint) - -val of_int_fs: (int -> bigint) -val to_int_fs: (bigint -> int) - -val of_hex: string -> bigint diff --git a/src/basic/FStar.Char.fsti b/src/basic/FStar.Char.fsti deleted file mode 100644 index ef5c1d2334d..00000000000 --- a/src/basic/FStar.Char.fsti +++ /dev/null @@ -1,32 +0,0 @@ -(* - Copyright 2008-2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Char - -(* This is a trimmed-down version of ulib/FStar.Char, realized by the -same ML implementation. It is here to prevent dependencies from the -compiler into the UInt32 module. *) - -new -val char:eqtype - -type char_code - -val int_of_char : char -> Tot int -val char_of_int : int -> Tot char - -val lowercase: char -> Tot char -val uppercase: char -> Tot char diff --git a/src/basic/FStar.Common.fst b/src/basic/FStar.Common.fst deleted file mode 100644 index 89f81558223..00000000000 --- a/src/basic/FStar.Common.fst +++ /dev/null @@ -1,156 +0,0 @@ -(* - Copyright 2008-2017 Microsoft Research - - Authors: Aseem Rastogi, Nikhil Swamy, Jonathan Protzenko - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Common -open FStar.Compiler.Effect -module List = FStar.Compiler.List -module BU = FStar.Compiler.Util - -let has_cygpath = - try - let t_out = BU.run_process "has_cygpath" "which" ["cygpath"] None in - BU.trim_string t_out = "/usr/bin/cygpath" - with - | _ -> false - -//try to convert filename passed from the editor to mixed path -//that works on both cygwin and native windows -//noop if not on cygwin -//on cygwin emacs this is required - -let try_convert_file_name_to_mixed = - let cache = BU.smap_create 20 in - fun (s:string) -> - if has_cygpath - && BU.starts_with s "/" then - match BU.smap_try_find cache s with - | Some s -> - s - | None -> - let label = "try_convert_file_name_to_mixed" in - let out = BU.run_process label "cygpath" ["-m"; s] None |> BU.trim_string in - BU.smap_add cache s out; - out - else - s - -let snapshot (push: 'a -> 'b) (stackref: ref (list 'c)) (arg: 'a) : (int & 'b) = BU.atomically (fun () -> - let len : int = List.length !stackref in - let arg' = push arg in - (len, arg')) - -let rollback (pop: unit -> 'a) (stackref: ref (list 'c)) (depth: option int) = - let rec aux n = - if n <= 0 then failwith "Too many pops" - else if n = 1 then pop () - else (ignore (pop ()); aux (n - 1)) in - let curdepth = List.length !stackref in - let n = match depth with Some d -> curdepth - d | None -> 1 in - BU.atomically (fun () -> aux n) - -// This function is separate to make it easier to put breakpoints on it -let raise_failed_assertion msg = - failwith (BU.format1 "Assertion failed: %s" msg) - -let runtime_assert b msg = - if not b then raise_failed_assertion msg - -let __string_of_list (delim:string) (f : 'a -> string) (l : list 'a) : string = - match l with - | [] -> "[]" - | x::xs -> - let strb = BU.new_string_builder () in - BU.string_builder_append strb "["; - BU.string_builder_append strb (f x); - List.iter (fun x -> - BU.string_builder_append strb delim; - BU.string_builder_append strb (f x) - ) xs ; - BU.string_builder_append strb "]"; - BU.string_of_string_builder strb - -(* Why two? This function was added during a refactoring, and -both variants existed. We cannot simply move to ";" since that is a -breaking change to anything that parses F* source code (like Vale). *) -let string_of_list = __string_of_list ", " -let string_of_list' = __string_of_list "; " - -let list_of_option (o:option 'a) : list 'a = - match o with - | None -> [] - | Some x -> [x] - -let string_of_option f = function - | None -> "None" - | Some x -> "Some " ^ f x - -(* Was List.init, but F* doesn't have this in ulib *) -let tabulate (n:int) (f : int -> 'a) : list 'a = - let rec aux i = - if i < n - then f i :: aux (i + 1) - else [] - in aux 0 - -(** max_prefix f xs returns (l, r) such that - * every x in l satisfies f - * l@r == xs - * and l is the largest list satisfying that - *) -let rec max_prefix (f : 'a -> bool) (xs : list 'a) : list 'a & list 'a = - match xs with - | [] -> [], [] - | x::xs when f x -> - let l, r = max_prefix f xs in - (x::l, r) - | x::xs -> - ([], x::xs) - -(** max_suffix f xs returns (l, r) such that - * every x in r satisfies f - * l@r == xs - * and r is the largest list satisfying that - *) -let max_suffix (f : 'a -> bool) (xs : list 'a) : list 'a & list 'a = - let rec aux acc xs = - match xs with - | [] -> acc, [] - | x::xs when f x -> - aux (x::acc) xs - | x::xs -> - (acc, x::xs) - in - xs |> List.rev |> aux [] |> (fun (xs, ys) -> List.rev ys, xs) - -let rec eq_list (f: 'a -> 'a -> bool) (l1 l2 : list 'a) - : bool - = match l1, l2 with - | [], [] -> true - | [], _ | _, [] -> false - | x1::t1, x2::t2 -> f x1 x2 && eq_list f t1 t2 - -let psmap_to_list m = - BU.psmap_fold m (fun k v a -> (k,v)::a) [] -let psmap_keys m = - BU.psmap_fold m (fun k v a -> k::a) [] -let psmap_values m = - BU.psmap_fold m (fun k v a -> v::a) [] - -let option_to_list = function - | None -> [] - | Some x -> [x] diff --git a/src/basic/FStar.Compiler.Bytes.fsti b/src/basic/FStar.Compiler.Bytes.fsti deleted file mode 100644 index 8e3ea7304b8..00000000000 --- a/src/basic/FStar.Compiler.Bytes.fsti +++ /dev/null @@ -1,36 +0,0 @@ -(* - Copyright 2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Compiler.Bytes -open FStar.Compiler.Effect -open FStar.BaseTypes - -type bytes = array byte -val length : bytes -> int -val get: bytes -> int -> int -val zero_create : int -> bytes -val string_as_unicode_bytes: string -> bytes -val unicode_bytes_as_string: bytes -> string -val utf8_bytes_as_string: bytes -> string -val append: bytes -> bytes -> bytes -val make: (int -> int) -> int -> bytes - -type bytebuf -val create: int -> bytebuf -val close : bytebuf -> bytes -val emit_int_as_byte: bytebuf -> int -> unit -val emit_bytes: bytebuf -> bytes -> unit - -val f_encode: (byte -> string) -> bytes -> string diff --git a/src/basic/FStar.Compiler.Debug.fst b/src/basic/FStar.Compiler.Debug.fst deleted file mode 100644 index 975deb2b5c3..00000000000 --- a/src/basic/FStar.Compiler.Debug.fst +++ /dev/null @@ -1,104 +0,0 @@ -(* - Copyright 2008-2020 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Compiler.Debug - -module BU = FStar.Compiler.Util - -(* Mutable state *) -let anyref = BU.mk_ref false -let _debug_all : ref bool = BU.mk_ref false -let toggle_list : ref (list (string & ref bool)) = - BU.mk_ref [] - -type saved_state = { - toggles : list (string & bool); - any : bool; - all : bool; -} - -let snapshot () : saved_state = { - toggles = !toggle_list |> List.map (fun (k, r) -> (k, !r)); - any = !anyref; - all = !_debug_all; -} - -let register_toggle (k : string) : ref bool = - let r = BU.mk_ref false in - if !_debug_all then - r := true; - toggle_list := (k, r) :: !toggle_list; - r - -let get_toggle (k : string) : ref bool = - match List.tryFind (fun (k', _) -> k = k') !toggle_list with - | Some (_, r) -> r - | None -> register_toggle k - -let restore (snapshot : saved_state) : unit = - (* Set everything to false, then set all the saved ones - to true. *) - !toggle_list |> List.iter (fun (_, r) -> r := false); - snapshot.toggles |> List.iter (fun (k, b) -> - let r = get_toggle k in - r := b); - (* Also restore these references. *) - anyref := snapshot.any; - _debug_all := snapshot.all; - () - -let list_all_toggles () : list string = - List.map fst !toggle_list - -let any () = !anyref || !_debug_all - -let tag (s:string) = - if any () then - BU.print_string ("DEBUG:" ^ s ^ "\n") - -let enable () = anyref := true - -let dbg_level = BU.mk_ref 0 - -let low () = !dbg_level >= 1 || !_debug_all -let medium () = !dbg_level >= 2 || !_debug_all -let high () = !dbg_level >= 3 || !_debug_all -let extreme () = !dbg_level >= 4 || !_debug_all - -let set_level_low () = dbg_level := 1 -let set_level_medium () = dbg_level := 2 -let set_level_high () = dbg_level := 3 -let set_level_extreme () = dbg_level := 4 - -let enable_toggles (keys : list string) : unit = - if Cons? keys then enable (); - keys |> List.iter (fun k -> - if k = "Low" then set_level_low () - else if k = "Medium" then set_level_medium () - else if k = "High" then set_level_high () - else if k = "Extreme" then set_level_extreme () - else - let t = get_toggle k in - t := true - ) - -let disable_all () : unit = - anyref := false; - dbg_level := 0; - List.iter (fun (_, r) -> r := false) !toggle_list - -let set_debug_all () : unit = - _debug_all := true diff --git a/src/basic/FStar.Compiler.Debug.fsti b/src/basic/FStar.Compiler.Debug.fsti deleted file mode 100644 index 1dd0720999d..00000000000 --- a/src/basic/FStar.Compiler.Debug.fsti +++ /dev/null @@ -1,69 +0,0 @@ -(* - Copyright 2008-2020 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Compiler.Debug - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect - -(* State handling for this module. Used by FStar.Options, which -is the only module that modifies the debug state. *) -val saved_state : Type0 -val snapshot () : saved_state -val restore (s:saved_state) : unit - -(* Enable debugging. This will make any() return true, but -does not enable any particular toggle. *) -val enable () : unit - -(* Are we doing *any* kind of debugging? *) -val any () : bool - -(* Print a quick message on stdout whenever debug is on. If the string -is not a constant, put this under an if to thunk it. *) -val tag (s : string) : unit - -(* Obtain the toggle for a given debug key *) -val get_toggle (k : string) : ref bool - -(* List all registered toggles *) -val list_all_toggles () : list string - -(* Vanilla debug levels. Each level implies the previous lower one. *) -val low () : bool -val medium () : bool -val high () : bool -val extreme () : bool - -(* Enable a list of debug toggles. If will also call enable() -is key is non-empty, and will recognize "Low", "Medium", -"High", "Extreme" as special and call the corresponding -set_level_* function. *) -val enable_toggles (keys : list string) : unit - -(* Sets the debug level to zero and sets all registered toggles -to false. any() will return false after this. *) -val disable_all () : unit - -(* Nuclear option: enable ALL debug toggles. *) -val set_debug_all () : unit - -(* Not used externally at the moment. *) -val set_level_low () : unit -val set_level_medium () : unit -val set_level_high () : unit -val set_level_extreme () : unit diff --git a/src/basic/FStar.Compiler.Effect.fsti b/src/basic/FStar.Compiler.Effect.fsti deleted file mode 100644 index c9262e674bf..00000000000 --- a/src/basic/FStar.Compiler.Effect.fsti +++ /dev/null @@ -1,60 +0,0 @@ -(* - Copyright 2008-2017 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Compiler.Effect - -new_effect ALL = ALL_h unit - -let all_pre = all_pre_h unit -let all_post' (a : Type) (pre:Type) = all_post_h' unit a pre -let all_post (a : Type) = all_post_h unit a -let all_wp (a : Type) = all_wp_h unit a - -let lift_pure_all (a:Type) (p:pure_wp a) - : all_wp a - = fun post h -> p (fun x -> post (V x) h) - -sub_effect PURE ~> ALL { lift_wp = lift_pure_all } - -sub_effect DIV ~> ALL { lift_wp = lift_pure_all } - -effect All (a:Type) (pre:all_pre) (post:(h:unit -> Tot (all_post' a (pre h)))) = - ALL a - (fun (p : all_post a) (h : unit) -> pre h /\ (forall ra h1. post h ra h1 ==> p ra h1)) - -effect ML (a:Type) = ALL a (fun (p:all_post a) (_:unit) -> forall (a:result a) (h:unit). p a h) - -new -val ref (a:Type) : Type0 - -val (!) (#a:Type) (r:ref a) - : ML a - -val (:=) (#a:Type) (r:ref a) (x:a) - : ML unit - -val alloc (#a:Type) (x:a) - : ML (ref a) - -val raise (e: exn) : ML 'a - -val exit : int -> ML 'a - -val try_with : (unit -> ML 'a) -> (exn -> ML 'a) -> ML 'a - -exception Failure of string - -val failwith : string -> ML 'a diff --git a/src/basic/FStar.Compiler.Hints.fsti b/src/basic/FStar.Compiler.Hints.fsti deleted file mode 100644 index 9c8f5cf1af9..00000000000 --- a/src/basic/FStar.Compiler.Hints.fsti +++ /dev/null @@ -1,29 +0,0 @@ -module FStar.Compiler.Hints - -open FStar.Compiler.Effect - -(** Hints. *) -type hint = { - hint_name:string; //name associated to the top-level term in the source program - hint_index:int; //the nth query associated with that top-level term - fuel:int; //fuel for unrolling recursive functions - ifuel:int; //fuel for inverting inductive datatypes - unsat_core:option (list string); //unsat core, if requested - query_elapsed_time:int; //time in milliseconds taken for the query, to decide if a fresh replay is worth it - hash:option string; //hash of the smt2 query that last succeeded -} - -type hints = list (option hint) - -type hints_db = { - module_digest:string; - hints: hints -} - -type hints_read_result = - | HintsOK of hints_db - | MalformedJson - | UnableToOpen - -val write_hints: string -> hints_db -> unit -val read_hints: string -> hints_read_result diff --git a/src/basic/FStar.Compiler.List.fsti b/src/basic/FStar.Compiler.List.fsti deleted file mode 100644 index 957872d8690..00000000000 --- a/src/basic/FStar.Compiler.List.fsti +++ /dev/null @@ -1,79 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. - *) -module FStar.Compiler.List -open FStar.Compiler.Effect -open Prims - -val isEmpty : (list 'a) -> Tot bool -val singleton : 'a -> list 'a -val hd : (list 'a) -> 'a -val length : (list 'a) -> Tot nat -val nth : (list 'a) -> int -> 'a -val rev_acc : (list 'a) -> (list 'a) -> Tot (list 'a) -val rev : (list 'a) -> Tot (list 'a) -val append : (list 'a) -> (list 'a) -> Tot (list 'a) -val ( @ ) : (list 'a) -> (list 'a) -> Tot (list 'a) -val flatten : (list (list 'a)) -> Tot (list 'a) -val iter : ('a -> unit) -> (list 'a) -> unit -val iter2 : ('a -> 'b -> unit) -> (list 'a) -> list 'b -> unit -val iteri : (int -> 'a -> unit) -> (list 'a) -> unit -val map : ('a -> 'b) -> (list 'a) -> (list 'b) -val mapi_init : (int -> 'a -> 'b) -> (list 'a) -> int -> (list 'b) -val mapi : (int -> 'a -> 'b) -> (list 'a) -> (list 'b) -val concatMap : ('a -> (list 'b)) -> (list 'a) -> (list 'b) -val map2 : ('a -> 'b -> 'c) -> (list 'a) -> (list 'b) -> (list 'c) -val map3 : ('a -> 'b -> 'c -> 'd) -> (list 'a) -> (list 'b) -> (list 'c) -> (list 'd) -val fold_left : ('a -> 'b -> 'a) -> 'a -> (list 'b) -> 'a -val fold_left2 : ('s -> 'a -> 'b -> 's) -> 's -> (list 'a) -> (list 'b) -> 's -val fold_right : ('a -> 'b -> 'b) -> (list 'a) -> 'b -> 'b -val fold_right2 : ('a -> 'b -> 'c -> 'c) -> list 'a -> list 'b -> 'c -> 'c -val rev_map_onto : ('a -> 'b) -> (list 'a) -> (list 'b) -> (list 'b) -val init : (list 'a) -> list 'a -val last : (list 'a) -> 'a -val last_opt : list 'a -> option 'a -val existsb : f:('a -> bool) -> (list 'a) -> bool -val existsML : f:('a -> bool) -> (list 'a) -> bool -val find : f:('a -> bool) -> (list 'a) -> (option 'a) -val filter : ('a -> bool) -> (list 'a) -> (list 'a) -val for_all : ('a -> bool) -> (list 'a) -> bool -val forall2 : ('a -> 'b -> bool) -> (list 'a) -> (list 'b) -> bool -val collect : ('a -> (list 'b)) -> (list 'a) -> (list 'b) -val tryFind : ('a -> bool) -> (list 'a) -> (option 'a) -val tryPick : ('a -> (option 'b)) -> (list 'a) -> (option 'b) -val choose : ('a -> (option 'b)) -> (list 'a) -> (list 'b) -val partition : ('a -> bool) -> (list 'a) -> ((list 'a) & (list 'a)) -val splitAt : int -> list 'a -> list 'a & list 'a -val split : (list ('a & 'b)) -> Tot ((list 'a) & (list 'b)) -val unzip3 : list ('a & 'b & 'c) -> Tot ((list 'a) & (list 'b) & (list 'c)) -val zip : (list 'a) -> (list 'b) -> (list ('a & 'b)) -val zip3 : (list 'a) -> (list 'b) -> (list 'c) -> (list ('a & 'b & 'c)) -val sortWith : ('a -> 'a -> int) -> (list 'a) -> (list 'a) -val bool_of_compare : ('a -> 'a -> Tot int) -> 'a -> 'a -> Tot bool -val tail : (list '_1225) -> (list '_1225) -val tl : list '_1230 -> list '_1230 -val rev_append : (list '_5110) -> (list '_5110) -> Tot (list '_5110) -val concat : (list (list '_6116)) -> Tot (list '_6116) -val unzip : (list ('_36948 & '_36947)) -> Tot ((list '_36948) & (list '_36947)) -val filter_map: ('a -> option 'b) -> list 'a -> list 'b -val count: #a:eqtype -> a -> (list a) -> Tot nat -val mem: #a:eqtype -> a -> (list a) -> Tot bool -val assoc: #a:eqtype -> #b:Type -> a -> (list (a & b)) -> Tot (option b) -val contains: #a:eqtype -> a -> (list a) -> Tot bool -val unique: #a:eqtype -> list a -> list a -val index: #a:eqtype -> (a -> bool) -> list a -> int -val span: #a:eqtype -> (a -> bool) -> list a -> Tot ((list a) & (list a)) -val deduplicate (f: 'a -> 'a -> bool) (s: list 'a) : list 'a -val fold_left_map (f: 'a -> 'b -> 'a & 'c) (s: 'a) (l: list 'b) : 'a & list 'c diff --git a/src/basic/FStar.Compiler.MachineInts.fst b/src/basic/FStar.Compiler.MachineInts.fst deleted file mode 100644 index a0ea37f5a46..00000000000 --- a/src/basic/FStar.Compiler.MachineInts.fst +++ /dev/null @@ -1,171 +0,0 @@ -module FStar.Compiler.MachineInts - -(* A type representing all the kinds of machine integers, and an -embedding instance for them. *) - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Syntax.Syntax - -module EMB = FStar.Syntax.Embeddings -module NBE = FStar.TypeChecker.NBETerm -module PC = FStar.Parser.Const -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module U = FStar.Syntax.Util -module Z = FStar.BigInt - -open FStar.Class.Show -open FStar.Class.Monad - -let all_machint_kinds = - [Int8; Int16; Int32; Int64; UInt8; UInt16; UInt32; UInt64; UInt128; SizeT] - -let is_unsigned (k : machint_kind) : bool = - match k with - | Int8 - | Int16 - | Int32 - | Int64 -> false - | UInt8 - | UInt16 - | UInt32 - | UInt64 - | UInt128 - | SizeT -> true -let is_signed k = not (is_unsigned k) - -let width (k : machint_kind) : int = - match k with - | Int8 -> 8 - | Int16 -> 16 - | Int32 -> 32 - | Int64 -> 64 - | UInt8 -> 8 - | UInt16 -> 16 - | UInt32 -> 32 - | UInt64 -> 64 - | UInt128 -> 128 - | SizeT -> 64 - -let module_name_for (k:machint_kind) : string = - match k with - | Int8 -> "Int8" - | Int16 -> "Int16" - | Int32 -> "Int32" - | Int64 -> "Int64" - | UInt8 -> "UInt8" - | UInt16 -> "UInt16" - | UInt32 -> "UInt32" - | UInt64 -> "UInt64" - | UInt128 -> "UInt128" - | SizeT -> "SizeT" - -let mask (k:machint_kind) : Z.t = - match width k with - | 8 -> Z.of_hex "ff" - | 16 -> Z.of_hex "ffff" - | 32 -> Z.of_hex "ffffffff" - | 64 -> Z.of_hex "ffffffffffffffff" - | 128 -> Z.of_hex "ffffffffffffffffffffffffffffffff" - -let int_to_t_lid_for (k:machint_kind) : Ident.lid = - let path = "FStar" :: module_name_for k :: (if is_unsigned k then "uint_to_t" else "int_to_t") :: [] in - Ident.lid_of_path path Range.dummyRange - -let int_to_t_for (k:machint_kind) : S.term = - let lid = int_to_t_lid_for k in - S.fvar lid None - -let __int_to_t_lid_for (k:machint_kind) : Ident.lid = - let path = "FStar" :: module_name_for k :: (if is_unsigned k then "__uint_to_t" else "__int_to_t") :: [] in - Ident.lid_of_path path Range.dummyRange - -let __int_to_t_for (k:machint_kind) : S.term = - let lid = __int_to_t_lid_for k in - S.fvar lid None - -(* just a newtype really, no checks or conditions here *) -type machint (k : machint_kind) = | Mk : Z.t -> option S.meta_source_info -> machint k - -let mk #k x m = Mk #k x m -let v #k (x : machint k) = - let Mk v _ = x in v -let meta #k (x : machint k) = - let Mk _ meta = x in meta -let make_as #k (x : machint k) (z : Z.t) : machint k = - Mk z (meta x) - -(* just for debugging *) -instance showable_bounded_k k : Tot (showable (machint k)) = { - show = (function Mk x m -> "machine integer " ^ show (Z.to_int_fs x) ^ "@@" ^ module_name_for k); -} - -instance e_machint (k : machint_kind) : Tot (EMB.embedding (machint k)) = - let with_meta_ds r t (m:option meta_source_info) = - match m with - | None -> t - | Some m -> S.mk (Tm_meta {tm=t; meta=Meta_desugared m}) r - in - let em (x : machint k) rng shadow cb = - let Mk i m = x in - let it = EMB.embed i rng None cb in - let int_to_t = int_to_t_for k in - let t = S.mk_Tm_app int_to_t [S.as_arg it] rng in - with_meta_ds rng t m - in - let un (t:term) cb : option (machint k) = - let (t, m) = - (match (SS.compress t).n with - | Tm_meta {tm=t; meta=Meta_desugared m} -> (t, Some m) - | _ -> (t, None)) - in - let t = U.unmeta_safe t in - match (SS.compress t).n with - | Tm_app {hd; args=[(a,_)]} when U.is_fvar (int_to_t_lid_for k) hd - || U.is_fvar (__int_to_t_lid_for k) hd -> - let a = U.unlazy_emb a in - let! a : Z.t = EMB.try_unembed a cb in - Some (Mk a m) - | _ -> - None - in - EMB.mk_emb_full em un - (fun () -> S.fvar (Ident.lid_of_path ["FStar"; module_name_for k; "t"] Range.dummyRange) None) - (fun _ -> "boundedint") - (fun () -> ET_abstract) - -instance nbe_machint (k : machint_kind) : Tot (NBE.embedding (machint k)) = - let open NBE in - let with_meta_ds t (m:option meta_source_info) = - match m with - | None -> t - | Some m -> NBE.mk_t (Meta(t, Thunk.mk (fun _ -> Meta_desugared m))) - in - let em cbs (x : machint k) = - let Mk i m = x in - let it = embed e_int cbs i in - let int_to_t args = mk_t <| FV (S.lid_as_fv (__int_to_t_lid_for k) None, [], args) in - let t = int_to_t [as_arg it] in - with_meta_ds t m - in - let un cbs a : option (machint k) = - let (a, m) = - (match a.nbe_t with - | Meta(t, tm) -> - (match Thunk.force tm with - | Meta_desugared m -> (t, Some m) - | _ -> (a, None)) - | _ -> (a, None)) - in - match a.nbe_t with - | FV (fv1, [], [(a, _)]) when Ident.lid_equals (fv1.fv_name.v) (int_to_t_lid_for k) -> - let! a : Z.t = unembed e_int cbs a in - Some (Mk a m) - | _ -> None - in - mk_emb em un - (fun () -> mkFV (lid_as_fv (Ident.lid_of_path ["FStar"; module_name_for k; "t"] Range.dummyRange) None) [] []) - (fun () -> ET_abstract) - diff --git a/src/basic/FStar.Compiler.MachineInts.fsti b/src/basic/FStar.Compiler.MachineInts.fsti deleted file mode 100644 index 2f07bb7b1c1..00000000000 --- a/src/basic/FStar.Compiler.MachineInts.fsti +++ /dev/null @@ -1,48 +0,0 @@ -module FStar.Compiler.MachineInts - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect - -module EMB = FStar.Syntax.Embeddings -module NBE = FStar.TypeChecker.NBETerm -module S = FStar.Syntax.Syntax -module Z = FStar.BigInt - -open FStar.Class.Show - -type machint_kind = - | Int8 - | Int16 - | Int32 - | Int64 - | UInt8 - | UInt16 - | UInt32 - | UInt64 - | UInt128 - | SizeT - -val all_machint_kinds : list machint_kind - -val is_unsigned (k : machint_kind) : bool -val is_signed (k : machint_kind) : bool -val width (k : machint_kind) : int -val module_name_for (k:machint_kind) : string -val mask (k:machint_kind) : Z.t - -new val machint (k : machint_kind) : Type0 - -val mk (#k:_) (i : Z.t) (m : option S.meta_source_info) : machint k // no checks at all, use with care -val v #k (x : machint k) : Z.t -val meta #k (x : machint k) : option S.meta_source_info - -(* Make a machint k copying the meta off an existing one *) -val make_as #k (x : machint k) (z : Z.t) : machint k - -instance val showable_bounded_k k : Tot (showable (machint k)) -instance val e_machint (k : machint_kind) : Tot (EMB.embedding (machint k)) - -instance val nbe_machint (k : machint_kind) : Tot (NBE.embedding (machint k)) -// ^ This instance being here is slightly fishy. It blows up the dependency -// graph of this module. diff --git a/src/basic/FStar.Compiler.Misc.fst b/src/basic/FStar.Compiler.Misc.fst deleted file mode 100644 index 82f8e9f2856..00000000000 --- a/src/basic/FStar.Compiler.Misc.fst +++ /dev/null @@ -1,16 +0,0 @@ -module FStar.Compiler.Misc - -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.Util - -open FStar.Order -open FStar.String - -let compare_version (v1 v2 : string) : order = - let cs1 = String.split ['.'] v1 |> List.map int_of_string in - let cs2 = String.split ['.'] v2 |> List.map int_of_string in - compare_list cs1 cs2 compare_int - -let version_gt v1 v2 = compare_version v1 v2 = Gt -let version_ge v1 v2 = compare_version v1 v2 <> Lt diff --git a/src/basic/FStar.Compiler.Misc.fsti b/src/basic/FStar.Compiler.Misc.fsti deleted file mode 100644 index 5d61e8c999e..00000000000 --- a/src/basic/FStar.Compiler.Misc.fsti +++ /dev/null @@ -1,10 +0,0 @@ -module FStar.Compiler.Misc - -open FStar.Compiler.Effect - -(* This functions compare version numbers. E.g. "4.8.5" and "4.12.3". -NOTE: the versions cannot contain any alphabetic character, only numbers -are allowed for now. *) - -val version_gt : string -> string -> bool -val version_ge : string -> string -> bool diff --git a/src/basic/FStar.Compiler.Option.fst b/src/basic/FStar.Compiler.Option.fst deleted file mode 100644 index c2de31881a0..00000000000 --- a/src/basic/FStar.Compiler.Option.fst +++ /dev/null @@ -1,38 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Compiler.Option - -open FStar.Compiler.Effect - -let isNone = function - | None -> true - | Some _ -> false - -let isSome = function - | Some _ -> true - | None -> false - -let map f = function - | Some x -> Some (f x) - | None -> None - -let mapTot f = function - | Some x -> Some (f x) - | None -> None - -let get = function - | Some x -> x - | None -> failwith "empty option" diff --git a/src/basic/FStar.Compiler.Option.fsti b/src/basic/FStar.Compiler.Option.fsti deleted file mode 100644 index 66a5b3ab6dc..00000000000 --- a/src/basic/FStar.Compiler.Option.fsti +++ /dev/null @@ -1,24 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Compiler.Option -open Prims -open FStar.Compiler.Effect - -val isNone: option 'a -> Tot bool -val isSome: option 'a -> Tot bool -val map: ('a -> ML 'b) -> option 'a -> ML (option 'b) -val mapTot: ('a -> Tot 'b) -> option 'a -> Tot (option 'b) -val get: option 'a -> ML 'a diff --git a/src/basic/FStar.Compiler.Order.fst b/src/basic/FStar.Compiler.Order.fst deleted file mode 100644 index 3afda5330da..00000000000 --- a/src/basic/FStar.Compiler.Order.fst +++ /dev/null @@ -1,74 +0,0 @@ -(* - Copyright 2008-2020 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Compiler.Order -open FStar.Compiler.Effect -module List = FStar.Compiler.List - -type order = | Lt | Eq | Gt - -// Some derived checks -let ge (o : order) : bool = o <> Lt -let le (o : order) : bool = o <> Gt -let ne (o : order) : bool = o <> Eq - -// Just for completeness and consistency... -let gt (o : order) : bool = o = Gt -let lt (o : order) : bool = o = Lt -let eq (o : order) : bool = o = Eq - -// Lexicographical combination, thunked to be lazy -let lex (o1 : order) (o2 : unit -> order) : order = - match o1, o2 with - | Lt, _ -> Lt - | Eq, _ -> o2 () - | Gt, _ -> Gt - -let order_from_int (i : int) : order = - if i < 0 then Lt - else if i = 0 then Eq - else Gt - -let compare_int (i : int) (j : int) : order = order_from_int (i - j) - -let compare_bool (b1 b2 : bool) : order = - match b1, b2 with - | false, true -> Lt - | true, false -> Gt - | _ -> Eq - -(* - * It promises to call the comparator in strictly smaller elements - * Useful when writing a comparator for an inductive type, - * that contains the list of itself as an argument to one of its - * data constructors - *) -let rec compare_list (#a:Type) - (l1 l2:list a) - (f:(x:a{x << l1} -> y:a{y << l2} -> order)) - : order - = match l1, l2 with - | [], [] -> Eq - | [], _ -> Lt - | _, [] -> Gt - | x::xs, y::ys -> lex (f x y) (fun _ -> compare_list xs ys f) - -let compare_option (f : 'a -> 'a -> order) (x : option 'a) (y : option 'a) : order = - match x, y with - | None , None -> Eq - | None , Some _ -> Lt - | Some _ , None -> Gt - | Some x , Some y -> f x y diff --git a/src/basic/FStar.Compiler.Plugins.Base.fsti b/src/basic/FStar.Compiler.Plugins.Base.fsti deleted file mode 100644 index 3c7e74b68c2..00000000000 --- a/src/basic/FStar.Compiler.Plugins.Base.fsti +++ /dev/null @@ -1,23 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Compiler.Plugins.Base - -open FStar.Compiler.Effect - -exception DynlinkError of string - -val dynlink_loadfile : string -> unit diff --git a/src/basic/FStar.Compiler.Plugins.fst b/src/basic/FStar.Compiler.Plugins.fst deleted file mode 100644 index 67b2d7a566e..00000000000 --- a/src/basic/FStar.Compiler.Plugins.fst +++ /dev/null @@ -1,133 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Compiler.Plugins - -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.Plugins.Base - -module BU = FStar.Compiler.Util -module E = FStar.Errors -module O = FStar.Options -open FStar.Class.Show - -let loaded : ref (list string) = BU.mk_ref [] - -let pout s = if Debug.any () then BU.print_string s -let pout1 s x = if Debug.any () then BU.print1 s x -let perr s = if Debug.any () then BU.print_error s -let perr1 s x = if Debug.any () then BU.print1_error s x - -let dynlink (fname:string) : unit = - if List.mem fname !loaded then ( - pout1 "Plugin %s already loaded, skipping\n" fname - ) else ( - pout ("Attempting to load " ^ fname ^ "\n"); - begin try - dynlink_loadfile fname - with DynlinkError e -> - E.log_issue0 E.Error_PluginDynlink [ - E.text (BU.format1 "Failed to load plugin file %s" fname); - Pprint.prefix 2 1 (E.text "Reason:") (E.text e); - E.text (BU.format1 "Remove the `--load` option or use `--warn_error -%s` to ignore and continue." - (show (E.errno E.Error_PluginDynlink))) - ]; - (* If we weren't ignoring this error, just stop now *) - E.stop_if_err () - end; - loaded := fname :: !loaded; - pout1 "Loaded %s\n" fname; - () - ) - -let load_plugin tac = - dynlink tac - -let load_plugins tacs = - List.iter load_plugin tacs - -let load_plugins_dir dir = - (* Dynlink all .cmxs files in the given directory *) - (* fixme: confusion between FStar.Compiler.String and FStar.String *) - BU.readdir dir - |> List.filter (fun s -> String.length s >= 5 && FStar.String.sub s (String.length s - 5) 5 = ".cmxs") - |> List.map (fun s -> dir ^ "/" ^ s) - |> load_plugins - -let compile_modules dir ms = - let compile m = - let packages = [ "fstar.lib" ] in - let pkg pname = "-package " ^ pname in - let args = ["ocamlopt"; "-shared"] (* FIXME shell injection *) - @ ["-I"; dir] - @ ["-w"; "-8-11-20-21-26-28" ] - @ (List.map pkg packages) - @ ["-o"; m ^ ".cmxs"; m ^ ".ml"] in - (* Note: not useful when in an OPAM setting *) - let ocamlpath_sep = match Platform.system with - | Platform.Windows -> ";" - | Platform.Posix -> ":" - in - let old_ocamlpath = - match BU.expand_environment_variable "OCAMLPATH" with - | Some s -> s - | None -> "" - in - let env_setter = BU.format5 "env OCAMLPATH=\"%s/../lib/%s%s/%s%s\"" - Options.fstar_bin_directory - ocamlpath_sep - Options.fstar_bin_directory - ocamlpath_sep - old_ocamlpath - in - let cmd = String.concat " " (env_setter :: "ocamlfind" :: args) in - let rc = BU.system_run cmd in - if rc <> 0 - then E.raise_error0 E.Fatal_FailToCompileNativeTactic [ - E.text "Failed to compile native tactic."; - E.text (BU.format2 "Command\n`%s`\nreturned with exit code %s" - cmd (show rc)) - ] - else () - in - try - ms - |> List.map (fun m -> dir ^ "/" ^ m) - |> List.iter compile - with e -> - perr (BU.format1 "Failed to load native tactic: %s\n" (BU.print_exn e)); - raise e - -(* Tries to load a plugin named like the extension. Returns true -if it could find a plugin with the proper name. This will fail hard -if loading the plugin fails. *) -let autoload_plugin (ext:string) : bool = - if Options.Ext.get "noautoload" <> "" then false else ( - if Debug.any () then - BU.print1 "Trying to find a plugin for extension %s\n" ext; - match Find.find_file (ext ^ ".cmxs") with - | Some fn -> - if List.mem fn !loaded then false - else ( - if Debug.any () then - BU.print1 "Autoloading plugin %s ...\n" fn; - load_plugin fn; - true - ) - | None -> - false -) diff --git a/src/basic/FStar.Compiler.Plugins.fsti b/src/basic/FStar.Compiler.Plugins.fsti deleted file mode 100644 index 1f05d1e95d9..00000000000 --- a/src/basic/FStar.Compiler.Plugins.fsti +++ /dev/null @@ -1,30 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Compiler.Plugins - -open FStar.Compiler.Effect -include FStar.Compiler.Plugins.Base - -val load_plugin : string -> unit -val load_plugins : list string -> unit -val load_plugins_dir : string -> unit -val compile_modules : string -> list string -> unit - -(* Tries to load a plugin named like the extension. Returns true -if it could find a plugin with the proper name. This will fail hard -if loading the plugin fails. *) -val autoload_plugin (ext:string) : bool diff --git a/src/basic/FStar.Compiler.Range.Ops.fst b/src/basic/FStar.Compiler.Range.Ops.fst deleted file mode 100644 index 0bc890638f3..00000000000 --- a/src/basic/FStar.Compiler.Range.Ops.fst +++ /dev/null @@ -1,151 +0,0 @@ -(* - Copyright 2008-2023 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -(* - Operations over the FStar.Compiler.Range.Type.range type. -*) -module FStar.Compiler.Range.Ops - -friend FStar.Compiler.Range.Type - -open FStar.Json -open FStar.Compiler.Effect -open FStar.Compiler.Util -open FStar.Class.Ord - -module Options = FStar.Options - -let union_rng r1 r2 = - if r1.file_name <> r2.file_name - then r2 - else - let start_pos = min r1.start_pos r2.start_pos in - let end_pos = max r1.end_pos r2.end_pos in - mk_rng r1.file_name start_pos end_pos - -let union_ranges r1 r2 = { - def_range=union_rng r1.def_range r2.def_range; - use_range=union_rng r1.use_range r2.use_range -} - -(* is r1 included in r2? *) -let rng_included r1 r2 = - if r1.file_name <> r2.file_name - then false - else - r2.start_pos <=? r1.start_pos && - r2.end_pos >=? r1.end_pos - -let string_of_pos pos = - format2 "%s,%s" (string_of_int pos.line) (string_of_int pos.col) -let string_of_file_name f = - if Options.Ext.get "fstar:no_absolute_paths" = "1" then - basename f - else if Options.ide () then - try - match Find.find_file (basename f) with - | None -> f //couldn't find file; just return the relative path - | Some absolute_path -> - absolute_path - with _ -> f - else f -let file_of_range r = - let f = r.def_range.file_name in - string_of_file_name f -let set_file_of_range r (f:string) = {r with def_range = {r.def_range with file_name = f}} -let string_of_rng r = - format3 "%s(%s-%s)" (string_of_file_name r.file_name) (string_of_pos r.start_pos) (string_of_pos r.end_pos) -let string_of_def_range r = string_of_rng r.def_range -let string_of_use_range r = string_of_rng r.use_range -let string_of_range r = string_of_def_range r - -let start_of_range r = r.def_range.start_pos -let end_of_range r = r.def_range.end_pos - -let file_of_use_range r = r.use_range.file_name -let start_of_use_range r = r.use_range.start_pos -let end_of_use_range r = r.use_range.end_pos - -let line_of_pos p = p.line -let col_of_pos p = p.col - -let end_range r = mk_range r.def_range.file_name r.def_range.end_pos r.def_range.end_pos - -let compare_rng r1 r2 = - let fcomp = FStar.String.compare r1.file_name r2.file_name in - if fcomp = 0 - then let start1 = r1.start_pos in - let start2 = r2.start_pos in - let lcomp = start1.line - start2.line in - if lcomp = 0 - then start1.col - start2.col - else lcomp - else fcomp -let compare r1 r2 = compare_rng r1.def_range r2.def_range -let compare_use_range r1 r2 = compare_rng r1.use_range r2.use_range -let range_before_pos m1 p = - p >=? end_of_range m1 - -let end_of_line p = {p with col=max_int} -let extend_to_end_of_line r = mk_range (file_of_range r) - (start_of_range r) - (end_of_line (end_of_range r)) - -let json_of_pos pos = - JsonList [JsonInt (line_of_pos pos); JsonInt (col_of_pos pos)] - -let json_of_range_fields file b e = - JsonAssoc [("fname", JsonStr file); - ("beg", json_of_pos b); - ("end", json_of_pos e)] - -let json_of_use_range r = - json_of_range_fields - (file_of_use_range r) - (start_of_use_range r) - (end_of_use_range r) - -let json_of_def_range r = - json_of_range_fields - (file_of_range r) - (start_of_range r) - (end_of_range r) - -let intersect_rng r1 r2 = - if r1.file_name <> r2.file_name - then r2 - else - let start_pos = max r1.start_pos r2.start_pos in - let end_pos = min r1.end_pos r2.end_pos in - (* If start_pos > end_pos, then the intersection is empty, just take the bound *) - if start_pos >=? end_pos - then r2 - else mk_rng r1.file_name start_pos end_pos - -let intersect_ranges r1 r2 = { - def_range=intersect_rng r1.def_range r2.def_range; - use_range=intersect_rng r1.use_range r2.use_range -} - -let bound_range (r bound : range) : range = - intersect_ranges r bound - -instance showable_range = { - show = string_of_range; -} - -instance pretty_range = { - pp = (fun r -> Pprint.doc_of_string (string_of_range r)); -} diff --git a/src/basic/FStar.Compiler.Range.Ops.fsti b/src/basic/FStar.Compiler.Range.Ops.fsti deleted file mode 100644 index 8f979973045..00000000000 --- a/src/basic/FStar.Compiler.Range.Ops.fsti +++ /dev/null @@ -1,57 +0,0 @@ -(* - Copyright 2008-2023 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Compiler.Range.Ops - -open FStar.Compiler.Range.Type -open FStar.Compiler.Effect -open FStar.Class.Show -open FStar.Class.PP - -val union_rng: rng -> rng -> rng -val union_ranges: range -> range -> range - -val rng_included: rng -> rng -> bool -val string_of_pos: pos -> string -val string_of_range: range -> string -val string_of_def_range: range -> string -val string_of_use_range: range -> string -val file_of_range: range -> string -val set_file_of_range: range -> string -> range -val start_of_range: range -> pos -val end_of_range: range -> pos -val file_of_use_range: range -> string -val start_of_use_range: range -> pos -val end_of_use_range: range -> pos -val line_of_pos: pos -> int -val col_of_pos: pos -> int -val end_range: range -> range -val compare: range -> range -> int -val compare_use_range: range -> range -> int -val range_before_pos : range -> pos -> bool -val end_of_line: pos -> pos -val extend_to_end_of_line: range -> range - -val json_of_pos : pos -> Json.json -val json_of_use_range : range -> Json.json -val json_of_def_range : range -> Json.json - -(** Bounds the range [r] by [bound]. Essentially, this is an intersection, -making sure that whatever we report is within the bound. If the ranges -are from different files, or there is no overlap, we return [bound]. *) -val bound_range (r : range) (bound : range) : range - -instance val showable_range : showable range -instance val pretty_range : pretty range diff --git a/src/basic/FStar.Compiler.Range.Type.fst b/src/basic/FStar.Compiler.Range.Type.fst deleted file mode 100644 index 9e035f01569..00000000000 --- a/src/basic/FStar.Compiler.Range.Type.fst +++ /dev/null @@ -1,109 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Compiler.Range.Type - -open FStar.Compiler.Effect -open FStar.Class.Deq -open FStar.Class.Ord -open FStar.Compiler.Order - -[@@ PpxDerivingYoJson; PpxDerivingShow ] -type file_name = string - -[@@ PpxDerivingYoJson; PpxDerivingShow ] -type pos = { - line:int; - col: int -} -let max i j = if i < j then j else i - -let compare_pos (p1 p2 : pos) : order = - lex (cmp p1.line p2.line) (fun _ -> cmp p1.col p2.col) - -instance deq_pos : deq pos = { (=?) = (=); } - -instance ord_pos : ord pos = { - super = deq_pos; - cmp = compare_pos; -} - -[@@ PpxDerivingYoJson; PpxDerivingShow ] -type rng = { - file_name:file_name; - start_pos:pos; - end_pos:pos; -} -[@@ PpxDerivingYoJson; PpxDerivingShow ] -type range = { - def_range:rng; - use_range:rng -} -let dummy_pos = { - line=0; - col=0; -} -let dummy_rng = { - file_name="dummy"; - start_pos=dummy_pos; - end_pos=dummy_pos -} -let dummyRange = { - def_range=dummy_rng; - use_range=dummy_rng -} -let use_range r = r.use_range -let def_range r = r.def_range -let range_of_rng d u = { - def_range=d; - use_range=u -} -let set_use_range r2 use_rng = - if use_rng <> dummy_rng then - {r2 with use_range=use_rng} - else r2 -let set_def_range r2 def_rng = - if def_rng <> dummy_rng then - {r2 with def_range=def_rng} - else r2 -let mk_pos l c = { - line=max 0 l; - col=max 0 c -} -let mk_rng file_name start_pos end_pos = { - file_name = file_name; - start_pos = start_pos; - end_pos = end_pos -} - -let mk_range f b e = let r = mk_rng f b e in range_of_rng r r - -open FStar.Json -let json_of_pos (r: pos): json - = JsonAssoc [ - "line", JsonInt r.line; - "col", JsonInt r.col; - ] -let json_of_rng (r: rng): json - = JsonAssoc [ - "file_name", JsonStr r.file_name; - "start_pos", json_of_pos r.start_pos; - "end_pos", json_of_pos r.end_pos; - ] -let json_of_range (r: range): json - = JsonAssoc [ - "def", json_of_rng r.def_range; - "use", json_of_rng r.use_range; - ] diff --git a/src/basic/FStar.Compiler.Range.Type.fsti b/src/basic/FStar.Compiler.Range.Type.fsti deleted file mode 100644 index 7f1d4a2e665..00000000000 --- a/src/basic/FStar.Compiler.Range.Type.fsti +++ /dev/null @@ -1,48 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Compiler.Range.Type - -open FStar.Compiler.Effect -open FStar.Class.Deq -open FStar.Class.Ord - -[@@ PpxDerivingYoJson; PpxDerivingShow] -new val rng : Type0 - -[@@ PpxDerivingYoJson; PpxDerivingShow] -new val range : Type0 - -[@@ PpxDerivingYoJson; PpxDerivingShow] -new val pos : Type0 - -instance val deq_pos : deq pos -instance val ord_pos : ord pos - -val dummy_rng : rng -val mk_rng : string -> pos -> pos -> rng - -val dummyRange: range -val use_range: range -> rng -val def_range: range -> rng -val range_of_rng: def_rng:rng -> use_rng:rng -> range -val set_use_range: range -> rng -> range -val set_def_range: range -> rng -> range -val mk_pos: int -> int -> pos -val mk_range: string -> pos -> pos -> range - -val json_of_pos: pos -> FStar.Json.json -val json_of_rng: rng -> FStar.Json.json -val json_of_range: range -> FStar.Json.json diff --git a/src/basic/FStar.Compiler.Range.fsti b/src/basic/FStar.Compiler.Range.fsti deleted file mode 100644 index 00492cc7b0e..00000000000 --- a/src/basic/FStar.Compiler.Range.fsti +++ /dev/null @@ -1,21 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Compiler.Range - -(* This module simply bundles together these other two. See their -interfaces for reference. *) -include FStar.Compiler.Range.Type -include FStar.Compiler.Range.Ops diff --git a/src/basic/FStar.Compiler.Real.fst b/src/basic/FStar.Compiler.Real.fst deleted file mode 100644 index 939b491b9cf..00000000000 --- a/src/basic/FStar.Compiler.Real.fst +++ /dev/null @@ -1,16 +0,0 @@ -(* - Copyright 2017-2024 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Compiler.Real diff --git a/src/basic/FStar.Compiler.Real.fsti b/src/basic/FStar.Compiler.Real.fsti deleted file mode 100644 index f40228052fe..00000000000 --- a/src/basic/FStar.Compiler.Real.fsti +++ /dev/null @@ -1,21 +0,0 @@ -(* - Copyright 2017-2024 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Compiler.Real - -(* A type for embedded real constants. This allows to write embeddings for them -(see FStar.Syntax.Embeddings and FStar.TypeChecker.NBETerm). *) - -type real = | Real of string diff --git a/src/basic/FStar.Compiler.Sealed.fst b/src/basic/FStar.Compiler.Sealed.fst deleted file mode 100644 index d398bb8c675..00000000000 --- a/src/basic/FStar.Compiler.Sealed.fst +++ /dev/null @@ -1,33 +0,0 @@ -(* - Copyright 2008-2024 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Compiler.Sealed - -(* This is the compiler-space version of the Sealed module in ulib. -Here, we define it as just an identity, but we do not expose that in -the interface so we must use the seal/unseal operations. This allows us -to - - 1) make sure we do not make mistakes forgetting to seal/unseal - 2) make sure none of these operations have any runtime behavior. - -It would be nicer to just make this a box type and expose that (internally -to the compiler) but that means extracted code would use the box. *) - -type sealed (a:Type u#a) : Type u#a = a - -let seal (x: 'a) : sealed 'a = x - -let unseal (x: sealed 'a) : 'a = x diff --git a/src/basic/FStar.Compiler.Sealed.fsti b/src/basic/FStar.Compiler.Sealed.fsti deleted file mode 100644 index 5732a73dd00..00000000000 --- a/src/basic/FStar.Compiler.Sealed.fsti +++ /dev/null @@ -1,22 +0,0 @@ -(* - Copyright 2008-2024 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Compiler.Sealed - -val sealed (a:Type u#a) : Type u#a - -val seal (x: 'a) : Tot (sealed 'a) - -val unseal (x: sealed 'a) : Tot 'a diff --git a/src/basic/FStar.Compiler.String.fsti b/src/basic/FStar.Compiler.String.fsti deleted file mode 100644 index dc973eda6b8..00000000000 --- a/src/basic/FStar.Compiler.String.fsti +++ /dev/null @@ -1,46 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Compiler.String - -open FStar.Compiler.Effect -open FStar.Char -open FStar.BigInt - -(* The name of this file is misleading: most string functions are to be found in - util.fsi *) -val make: int -> char -> string -val split: chars: list char -> s: string -> Tot (list string) -val strcat: string -> string -> Tot string -val concat: separator: string -> strings: list string -> Tot string -val compare: s1: string -> s2: string -> Tot int -val strlen: string -> Tot nat -val length: string -> Tot nat -val lowercase: string -> Tot string -val uppercase: string -> Tot string -val escaped: string -> Tot string - -val string_of_char : char -> Tot string - -(* may fail with index out of bounds *) -val substring: string -> start:int -> len:int -> string -val get: string -> int -> char -val collect: (char -> string) -> string -> string -val index_of: string -> char -> bigint -val index: string -> bigint -> char - -val list_of_string : string -> list char -val string_of_list: list char -> string -val (^) : string -> string -> string diff --git a/src/basic/FStar.Compiler.Util.fsti b/src/basic/FStar.Compiler.Util.fsti deleted file mode 100644 index 0e40c16d8c9..00000000000 --- a/src/basic/FStar.Compiler.Util.fsti +++ /dev/null @@ -1,393 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Compiler.Util -open Prims -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Json -open FStar.BaseTypes - -exception Impos - -val max_int: int -val return_all: 'a -> ML 'a - -type time -val now : unit -> time -val now_ms : unit -> int -val time_diff: time -> time -> float&int -val record_time: (unit -> 'a) -> ('a & int) -val is_before: time -> time -> bool -val get_file_last_modification_time: string -> time -val string_of_time: time -> string - -(* generic utils *) -(* smap: map from string keys *) -type smap 'value -val smap_create: int -> smap 'value -val smap_clear:smap 'value -> unit -val smap_add: smap 'value -> string -> 'value -> unit -val smap_of_list: list (string&'value) -> smap 'value -val smap_try_find: smap 'value -> string -> option 'value -val smap_fold: smap 'value -> (string -> 'value -> 'a -> 'a) -> 'a -> 'a -val smap_remove: smap 'value -> string -> unit -(* The list may contain duplicates. *) -val smap_keys: smap 'value -> list string -val smap_copy: smap 'value -> smap 'value -val smap_size: smap 'value -> int -val smap_iter: smap 'value -> (string -> 'value -> unit) -> unit - -(* pure version *) -type psmap 'value -val psmap_empty: unit -> psmap 'value // GH-1161 -val psmap_add: psmap 'value -> string -> 'value -> psmap 'value -val psmap_find_default: psmap 'value -> string -> 'value -> 'value -val psmap_try_find: psmap 'value -> string -> option 'value -val psmap_fold: psmap 'value -> (string -> 'value -> 'a -> 'a) -> 'a -> 'a -val psmap_find_map: psmap 'value -> (string -> 'value -> option 'a) -> option 'a -val psmap_modify: psmap 'value -> string -> (option 'value -> 'value) -> psmap 'value -val psmap_merge: psmap 'value -> psmap 'value -> psmap 'value -val psmap_remove: psmap 'value -> string -> psmap 'value -type imap 'value -val imap_create: int -> imap 'value -val imap_clear:imap 'value -> unit -val imap_add: imap 'value -> int -> 'value -> unit -val imap_of_list: list (int&'value) -> imap 'value -val imap_try_find: imap 'value -> int -> option 'value -val imap_fold: imap 'value -> (int -> 'value -> 'a -> 'a) -> 'a -> 'a -val imap_remove: imap 'value -> int -> unit -(* The list may contain duplicates. *) -val imap_keys: imap 'value -> list int -val imap_copy: imap 'value -> imap 'value - -(* pure version *) -type pimap 'value -val pimap_empty: unit -> pimap 'value // GH-1161 -val pimap_add: pimap 'value -> int -> 'value -> pimap 'value -val pimap_find_default: pimap 'value -> int -> 'value -> 'value -val pimap_try_find: pimap 'value -> int -> option 'value -val pimap_fold: pimap 'value -> (int -> 'value -> 'a -> 'a) -> 'a -> 'a - -val format: string -> list string -> string -val format1: string -> string -> string -val format2: string -> string -> string -> string -val format3: string -> string -> string -> string -> string -val format4: string -> string -> string -> string -> string -> string -val format5: string -> string -> string -> string -> string -> string -> string -val format6: string -> string -> string -> string -> string -> string -> string -> string - -val print: string -> list string -> unit -val print1: string -> string -> unit -val print2: string -> string -> string -> unit -val print3: string -> string -> string -> string -> unit -val print4: string -> string -> string -> string -> string -> unit -val print5: string -> string -> string -> string -> string -> string -> unit -val print6: string -> string -> string -> string -> string -> string -> string -> unit - -val print_error: string -> unit -val print1_error: string -> string -> unit -val print2_error: string -> string -> string -> unit -val print3_error: string -> string -> string -> string -> unit - -val print_warning: string -> unit -val print1_warning: string -> string -> unit -val print2_warning: string -> string -> string -> unit -val print3_warning: string -> string -> string -> string -> unit - -val flush_stdout: unit -> unit - -val stdout_isatty: unit -> option bool - -// These functions have no effect -val colorize: string -> (string & string) -> string -val colorize_bold: string -> string -val colorize_red: string -> string -val colorize_yellow: string -> string -val colorize_cyan: string -> string -val colorize_green: string -> string -val colorize_magenta : string -> string - - -type out_channel - -val stderr: out_channel -val stdout: out_channel - -val open_file_for_writing : string -> out_channel -val open_file_for_appending : string -> out_channel -val close_out_channel : out_channel -> unit - -val flush: out_channel -> unit - -val fprint: out_channel -> string -> list string -> unit - -(* Adds a newline and flushes *) -val append_to_file: out_channel -> string -> unit - -type printer = { - printer_prinfo: string -> unit; - printer_prwarning: string -> unit; - printer_prerror: string -> unit; - printer_prgeneric: string -> (unit -> string) -> (unit -> json) -> unit -} - -val default_printer : printer -val set_printer : printer -> unit - -val print_raw : string -> unit -val print_string : string -> unit -val print_generic: string -> ('a -> string) -> ('a -> json) -> 'a -> unit -val print_any : 'a -> unit -val strcat : string -> string -> string -val concat_l : string -> list string -> string - -val write_file: fn:string -> contents:string -> unit -val copy_file: string -> string -> unit -val delete_file: string -> unit -val file_get_contents: string -> string -val file_get_lines: string -> list string - -(** [mkdir clean mkparents d] a new dir with user read/write. -If clean is set and the directory exists, its contents are deleted and nothing else is done. -If clean is not set and the directory exists, do nothing. -If mkparents is true, the needed parents of the path will be created too, as mkdir -p does. -*) -val mkdir: bool-> bool -> string -> unit - -val concat_dir_filename: string -> string -> string - -type stream_reader -val open_stdin : unit -> stream_reader -val read_line: stream_reader -> option string -val nread : stream_reader -> int -> option string -val poll_stdin : float -> bool - -type string_builder -val new_string_builder: unit -> string_builder -val clear_string_builder: string_builder -> unit -val string_of_string_builder: string_builder -> string -val string_builder_append: string_builder -> string -> unit - -val message_of_exn: exn -> string -val trace_of_exn: exn -> string -val stack_dump : unit -> string - -exception SigInt -type sigint_handler -val sigint_handler_f : (int -> unit) -> sigint_handler -val sigint_ignore: sigint_handler -val sigint_raise: sigint_handler -val get_sigint_handler: unit -> sigint_handler -val set_sigint_handler: sigint_handler -> unit -val with_sigint_handler: sigint_handler -> (unit -> 'a) -> 'a - -type proc -val run_process : string -> string -> list string -> option string -> string -val start_process: string -> string -> list string -> (string -> bool) -> proc -val ask_process: proc -> string -> (*err_handler:*)(unit -> string) -> (*stderr_handler:*)(string -> unit) -> string -val kill_process: proc -> unit -val kill_all: unit -> unit -val proc_prog : proc -> string -val system_run : string -> int (* a less refined launching, implemented by Sys.command *) - -val get_file_extension: string -> string -val is_path_absolute: string -> bool -val join_paths: string -> string -> string -val normalize_file_path: string -> string -val basename: string -> string -val dirname : string -> string -val getcwd: unit -> string -val readdir: string -> list string -val paths_to_same_file: string -> string -> bool - -val file_exists: string -> Tot bool -val is_directory: string -> Tot bool - -val int_of_string: string -> int -val safe_int_of_string: string -> option int -val int_of_char: char -> Tot int -val int_of_byte: byte -> Tot int -val byte_of_char: char -> Tot byte -val char_of_int: int -> Tot char -val int_of_uint8: uint8 -> Tot int -val uint16_of_int: int -> Tot uint16 -val float_of_byte: byte -> Tot float -val float_of_int32: int32 -> Tot float -val float_of_int64: int64 -> Tot float -val float_of_string: string -> Tot float -val int_of_int32: int32 -> Tot int -val int32_of_int: int -> int32 //potentially failing int32 coercion -val string_of_int: int -> string -val string_of_bool: bool -> string -val string_of_int64: int64 -> Tot string -val string_of_int32: int32 -> Tot string -val string_of_float: float -> Tot string -val string_of_char: char -> Tot string -val hex_string_of_byte: byte -> Tot string -val string_of_bytes: array byte -> Tot string -val bytes_of_string: string -> Tot (array byte) -val base64_encode: string -> string -val base64_decode: string -> string -val starts_with: long:string -> short:string -> Tot bool -val trim_string: string -> Tot string -val ends_with: long:string -> short:string -> Tot bool -val char_at: string -> int -> char -val is_upper: char -> Tot bool -val contains: string -> string -> Tot bool -val substring_from: string -> int -> string -val substring: string -> start:int -> len:int -> string -val replace_char: string -> char -> char -> Tot string -val replace_chars: string -> char -> string -> Tot string -val hashcode: string -> Tot int -val compare: string -> string -> Tot int -val splitlines: string -> Tot (list string) -val split: str:string -> sep:string -> Tot (list string) - -val is_left: either 'a 'b -> bool -val is_right: either 'a 'b -> bool -val left: either 'a 'b -> 'a -val right: either 'a 'b -> 'b -val find_dup: ('a -> 'a -> bool) -> list 'a -> option 'a -val nodups: ('a -> 'a -> bool) -> list 'a -> bool -val sort_with: ('a -> 'a -> int) -> list 'a -> list 'a -val remove_dups: ('a -> 'a -> bool) -> list 'a -> list 'a -val add_unique: ('a -> 'a -> bool) -> 'a -> list 'a -> list 'a -val try_find: ('a -> bool) -> list 'a -> option 'a -val try_find_i: (int -> 'a -> bool) -> list 'a -> option (int & 'a) -val find_map: list 'a -> ('a -> option 'b) -> option 'b -val try_find_index: ('a -> bool) -> list 'a -> option int -val fold_map: ('a -> 'b -> 'a & 'c) -> 'a -> list 'b -> 'a & list 'c -val choose_map: ('a -> 'b -> 'a & option 'c) -> 'a -> list 'b -> 'a & list 'c -val for_all: ('a -> bool) -> list 'a -> bool -val for_some: ('a -> bool) -> list 'a -> bool -val forall_exists: ('a -> 'b -> bool) -> list 'a -> list 'b -> bool -val multiset_equiv: ('a -> 'b -> bool) -> list 'a -> list 'b -> bool -val take: ('a -> bool) -> list 'a -> list 'a & list 'a - -(* Variation on fold_left which pushes the list returned by the functional *) -(* on top of the leftover input list *) -val fold_flatten:('a -> 'b -> 'a & list 'b) -> 'a -> list 'b -> 'a - -val is_none: option 'a -> Tot bool -val is_some: option 'a -> Tot bool -val must: option 'a -> 'a -val dflt: 'a -> option 'a -> Tot 'a -val find_opt: ('a -> bool) -> list 'a -> option 'a -(* FIXME: these functions have the wrong argument order when compared to - List.map, List.iter, etc. *) -val bind_opt: option 'a -> ('a -> option 'b) -> option 'b -val catch_opt: option 'a -> (unit -> option 'a) -> option 'a -val map_opt: option 'a -> ('a -> 'b) -> option 'b -val iter_opt: option 'a -> ('a -> unit) -> unit - -val first_N: int -> list 'a -> (list 'a & list 'a) -val nth_tail: int -> list 'a -> list 'a -val prefix_until: ('a -> bool) -> list 'a -> option (list 'a & 'a & list 'a) -val prefix: list 'a -> Tot (list 'a & 'a) - -val string_of_unicode: array byte -> Tot string -val unicode_of_string: string -> Tot (array byte) -val incr: ref int -> unit -val decr: ref int -> unit -val geq: int -> int -> Tot bool -val for_range: int -> int -> (int -> unit) -> unit - -val mk_ref: 'a -> ref 'a - -val exec_name : string -val get_exec_dir: unit -> string -val get_cmd_args : unit -> list string -val expand_environment_variable: string -> option string - -val physical_equality: 'a -> 'a -> bool -val check_sharing: 'a -> 'a -> string -> unit - -val is_letter: char -> bool -val is_digit: char -> bool -val is_letter_or_digit: char -> bool -val is_punctuation: char -> bool -val is_symbol: char -> bool - -(* serialization of compiled modules *) -type oWriter = { - write_byte: byte -> unit; - write_bool: bool -> unit; - write_int: int -> unit; - write_int32: int32 -> unit; - write_int64: int64 -> unit; - write_char: char -> unit; - write_double: double -> unit; - write_bytearray: array byte -> unit; - write_string: string -> unit; - - close: unit -> unit -} - -type oReader = { - read_byte: unit -> byte; - read_bool: unit -> bool; - read_int: unit -> int; - read_int32: unit -> int32; - read_int64: unit -> int64; - read_char: unit -> char; - read_double: unit -> double; - read_bytearray: unit -> array byte; - read_string: unit -> string; - - close: unit -> unit -} - -val get_owriter: string -> oWriter -val get_oreader: string -> oReader - -val monitor_enter: 'a -> unit -val monitor_exit: 'a -> unit -val monitor_wait: 'a -> unit -val monitor_pulse: 'a -> unit -val with_monitor: 'a -> ('b -> 'c) -> 'b -> 'c -val current_tid: unit -> int -val sleep: int -> unit -val atomically: (unit -> 'a) -> 'a -val spawn: (unit -> unit) -> unit -val print_endline: string -> unit - -val map_option: ('a -> 'b) -> option 'a -> option 'b - -val save_value_to_file: string -> 'a -> unit -val load_value_from_file: string -> option 'a -val save_2values_to_file: string -> 'a -> 'b -> unit -val load_2values_from_file: string -> option ('a & 'b) -val print_exn: exn -> string -val digest_of_file: string -> string -val digest_of_string: string -> string -val touch_file: string -> unit (* Precondition: file exists *) - -val ensure_decimal: string -> string -val measure_execution_time: string -> (unit -> 'a) -> 'a -val return_execution_time: (unit -> 'a) -> ('a & float) - -(* Common interface between F#, Ocaml and F* to read and write references *) -(* F# uses native references, while OCaml uses both native references (Pervasives) and FStar_Heap ones *) -val read : ref 'a -> 'a -val write : ref 'a -> 'a -> unit - -(* Marshaling to and from strings *) -val marshal: 'a -> string -val unmarshal: string -> 'a - -val print_array (f: 'a -> string) (s:FStar.ImmutableArray.Base.t 'a) : string -val array_length (s:FStar.ImmutableArray.Base.t 'a) : FStar.BigInt.t -val array_index (s:FStar.ImmutableArray.Base.t 'a) (i:FStar.BigInt.t) : 'a diff --git a/src/basic/FStar.Const.fst b/src/basic/FStar.Const.fst deleted file mode 100644 index 1fac4a12f27..00000000000 --- a/src/basic/FStar.Const.fst +++ /dev/null @@ -1,95 +0,0 @@ -(* - Copyright 2008-2020 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Const -open FStar.Compiler.Effect -module List = FStar.Compiler.List - -open FStar.BaseTypes - -[@@ PpxDerivingYoJson; PpxDerivingShow ] -type signedness = | Unsigned | Signed -[@@ PpxDerivingYoJson; PpxDerivingShow ] -type width = | Int8 | Int16 | Int32 | Int64 | Sizet - -(* NB: - Const_int (_, None) is not a canonical representation for a mathematical integer - e.g., you can have both - Const_int("0x3ffffff", None) - and - Const_int("67108863", None) - which represent the same number - You should do an "FStar.Compiler.Util.ensure_decimal" on the - string representation before comparing integer constants. - - eq_const below does that for you -*) - -[@@ PpxDerivingYoJson; PpxDerivingShow ] -type sconst = - | Const_effect - | Const_unit - | Const_bool of bool - | Const_int of string & option (signedness & width) (* When None, means "mathematical integer", i.e. Prims.int. *) - | Const_char of char (* unicode code point: char in F#, int in OCaml *) - | Const_real of string - | Const_string of string & FStar.Compiler.Range.range (* UTF-8 encoded *) - | Const_range_of (* `range_of` primitive *) - | Const_set_range_of (* `set_range_of` primitive *) - | Const_range of FStar.Compiler.Range.range (* not denotable by the programmer *) - | Const_reify of option Ident.lid (* a coercion from a computation to its underlying repr *) - (* decorated optionally with the computation effect name *) - | Const_reflect of Ident.lid (* a coercion from a Tot term to an l-computation type *) - -let eq_const c1 c2 = - match c1, c2 with - | Const_int (s1, o1), Const_int(s2, o2) -> - FStar.Compiler.Util.ensure_decimal s1 = FStar.Compiler.Util.ensure_decimal s2 && - o1=o2 - | Const_string(a, _), Const_string(b, _) -> a=b - | Const_reflect l1, Const_reflect l2 -> Ident.lid_equals l1 l2 - | Const_reify _, Const_reify _ -> true - | _ -> c1=c2 - -open FStar.BigInt -let rec pow2 (x:bigint) : bigint = - if eq_big_int x zero - then one - else mult_big_int two (pow2 (pred_big_int x)) - - -let bounds signedness width = - let n = - match width with - | Int8 -> big_int_of_string "8" - | Int16 -> big_int_of_string "16" - | Int32 -> big_int_of_string "32" - | Int64 -> big_int_of_string "64" - | Sizet -> big_int_of_string "16" - in - let lower, upper = - match signedness with - | Unsigned -> - zero, pred_big_int (pow2 n) - | Signed -> - let upper = pow2 (pred_big_int n) in - minus_big_int upper, pred_big_int upper - in - lower, upper - -let within_bounds repr signedness width = - let lower, upper = bounds signedness width in - let value = big_int_of_string (FStar.Compiler.Util.ensure_decimal repr) in - le_big_int lower value && le_big_int value upper diff --git a/src/basic/FStar.Defensive.fst b/src/basic/FStar.Defensive.fst deleted file mode 100644 index 1c01d3503e5..00000000000 --- a/src/basic/FStar.Defensive.fst +++ /dev/null @@ -1,50 +0,0 @@ -module FStar.Defensive - -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.Util -open FStar.Class.Binders -open FStar.Class.Show -open FStar.Class.Ord -open FStar.Errors -open FStar.Errors.Msg -open FStar.Pprint -open FStar.Class.Setlike - -let () = let open FStar.Syntax.Print in () - -val __def_check_scoped : - #env_t:Type -> #thing_t:Type -> - {| hasBinders env_t |} -> - {| hasNames thing_t |} -> - {| pretty thing_t |} -> - range -> string -> - env_t -> thing_t -> unit - -instance pp_bv : pretty FStar.Syntax.Syntax.bv = { - pp = (fun bv -> arbitrary_string (show bv)); -} - -instance pp_set #a (_ : ord a) (_ : pretty a) : Tot (pretty (FlatSet.t a)) = { - pp = (fun s -> - let doclist (ds : list Pprint.document) : Pprint.document = - surround_separate 2 0 (doc_of_string "[]") lbracket (semi ^^ break_ 1) rbracket ds - in - doclist (elems s |> List.map pp)) -} - -let __def_check_scoped rng msg env thing = - let free = freeNames thing in - let scope = boundNames env in - if not (subset free scope) then - Errors.log_issue rng Errors.Warning_Defensive [ - text "Internal: term is not well-scoped " ^/^ parens (doc_of_string msg); - text "t =" ^/^ pp thing; - text "FVs =" ^/^ pp free; - text "Scope =" ^/^ pp scope; - text "Diff =" ^/^ pp (diff free scope); - ] - -let def_check_scoped rng msg env thing = - if Options.defensive () then - __def_check_scoped rng msg env thing diff --git a/src/basic/FStar.Defensive.fsti b/src/basic/FStar.Defensive.fsti deleted file mode 100644 index 54a664d2c9e..00000000000 --- a/src/basic/FStar.Defensive.fsti +++ /dev/null @@ -1,29 +0,0 @@ -(* - Copyright 2008-2020 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Defensive - -open FStar.Compiler.Effect -open FStar.Compiler.Range -open FStar.Class.Binders -open FStar.Class.PP - -val def_check_scoped : - #env_t:Type -> #thing_t:Type -> - {| hasBinders env_t |} -> - {| hasNames thing_t |} -> - {| pretty thing_t |} -> - range -> string -> - env_t -> thing_t -> unit diff --git a/src/basic/FStar.Errors.Codes.fst b/src/basic/FStar.Errors.Codes.fst deleted file mode 100644 index 53af2ed1a48..00000000000 --- a/src/basic/FStar.Errors.Codes.fst +++ /dev/null @@ -1,380 +0,0 @@ -(* - Copyright 2008-2020 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Errors.Codes - -let default_settings : list error_setting = - [ - Error_DependencyAnalysisFailed , CAlwaysError, 0; - Error_IDETooManyPops , CAlwaysError, 1; - Error_IDEUnrecognized , CAlwaysError, 2; - Error_InductiveTypeNotSatisfyPositivityCondition , CAlwaysError, 3; - Error_InvalidUniverseVar , CAlwaysError, 4; - Error_MissingFileName , CAlwaysError, 5; - Error_ModuleFileNameMismatch , CAlwaysError, 6; - Error_OpPlusInUniverse , CAlwaysError, 7; - Error_OutOfRange , CAlwaysError, 8; - Error_ProofObligationFailed , CError, 9; - Error_TooManyFiles , CAlwaysError, 10; - Error_TypeCheckerFailToProve , CAlwaysError, 11; - Error_TypeError , CAlwaysError, 12; - Error_UncontrainedUnificationVar , CAlwaysError, 13; - Error_UnexpectedGTotComputation , CAlwaysError, 14; - Error_UnexpectedInstance , CAlwaysError, 15; - Error_UnknownFatal_AssertionFailure , CError, 16; - Error_Z3InvocationError , CAlwaysError, 17; - Error_IDEAssertionFailure , CAlwaysError, 18; - Error_Z3SolverError , CError, 19; - Fatal_AbstractTypeDeclarationInInterface , CFatal, 20; - Fatal_ActionMustHaveFunctionType , CFatal, 21; - Fatal_AlreadyDefinedTopLevelDeclaration , CFatal, 22; - Fatal_ArgumentLengthMismatch , CFatal, 23; - Fatal_AssertionFailure , CFatal, 24; - Fatal_AssignToImmutableValues , CFatal, 25; - Fatal_AssumeValInInterface , CFatal, 26; - Fatal_BadlyInstantiatedSynthByTactic , CFatal, 27; - Fatal_BadSignatureShape , CFatal, 28; - Fatal_BinderAndArgsLengthMismatch , CFatal, 29; - Fatal_BothValAndLetInInterface , CFatal, 30; - Fatal_CardinalityConstraintViolated , CFatal, 31; - Fatal_ComputationNotTotal , CFatal, 32; - Fatal_ComputationTypeNotAllowed , CFatal, 33; - Fatal_ComputedTypeNotMatchAnnotation , CFatal, 34; - Fatal_ConstructorArgLengthMismatch , CFatal, 35; - Fatal_ConstructorFailedCheck , CFatal, 36; - Fatal_ConstructorNotFound , CFatal, 37; - Fatal_ConstsructorBuildWrongType , CFatal, 38; - Fatal_CycleInRecTypeAbbreviation , CFatal, 39; - Fatal_DataContructorNotFound , CFatal, 40; - Fatal_DefaultQualifierNotAllowedOnEffects , CFatal, 41; - Fatal_DefinitionNotFound , CFatal, 42; - Fatal_DisjuctivePatternVarsMismatch , CFatal, 43; - Fatal_DivergentComputationCannotBeIncludedInTotal , CFatal, 44; - Fatal_DuplicateInImplementation , CFatal, 45; - Fatal_DuplicateModuleOrInterface , CFatal, 46; - Fatal_DuplicateTopLevelNames , CFatal, 47; - Fatal_DuplicateTypeAnnotationAndValDecl , CFatal, 48; - Fatal_EffectCannotBeReified , CFatal, 49; - Fatal_EffectConstructorNotFullyApplied , CFatal, 50; - Fatal_EffectfulAndPureComputationMismatch , CFatal, 51; - Fatal_EffectNotFound , CFatal, 52; - Fatal_EffectsCannotBeComposed , CFatal, 53; - Fatal_ErrorInSolveDeferredConstraints , CFatal, 54; - Fatal_ErrorsReported , CFatal, 55; - Fatal_EscapedBoundVar , CFatal, 56; - Fatal_ExpectedArrowAnnotatedType , CFatal, 57; - Fatal_ExpectedGhostExpression , CFatal, 58; - Fatal_ExpectedPureExpression , CFatal, 59; - Fatal_ExpectNormalizedEffect , CFatal, 60; - Fatal_ExpectTermGotFunction , CFatal, 61; - Fatal_ExpectTrivialPreCondition , CFatal, 62; - Fatal_FailToExtractNativeTactic , CFatal, 63; - Fatal_FailToCompileNativeTactic , CFatal, 64; - Fatal_FailToProcessPragma , CFatal, 65; - Fatal_FailToResolveImplicitArgument , CFatal, 66; - Fatal_FailToSolveUniverseInEquality , CFatal, 67; - Fatal_FieldsNotBelongToSameRecordType , CFatal, 68; - Fatal_ForbiddenReferenceToCurrentModule , CFatal, 69; - Fatal_FreeVariables , CFatal, 70; - Fatal_FunctionTypeExpected , CFatal, 71; - Fatal_IdentifierNotFound , CFatal, 72; - Fatal_IllAppliedConstant , CFatal, 73; - Fatal_IllegalCharInByteArray , CFatal, 74; - Fatal_IllegalCharInOperatorName , CFatal, 75; - Fatal_IllTyped , CFatal, 76; - Fatal_ImpossibleAbbrevLidBundle , CFatal, 77; - Fatal_ImpossibleAbbrevRenameBundle , CFatal, 78; - Fatal_ImpossibleInductiveWithAbbrev , CFatal, 79; - Fatal_ImpossiblePrePostAbs , CFatal, 80; - Fatal_ImpossiblePrePostArrow , CFatal, 81; - Fatal_ImpossibleToGenerateDMEffect , CFatal, 82; - Fatal_ImpossibleTypeAbbrevBundle , CFatal, 83; - Fatal_ImpossibleTypeAbbrevSigeltBundle , CFatal, 84; - Fatal_IncludeModuleNotPrepared , CFatal, 85; - Fatal_IncoherentInlineUniverse , CFatal, 86; - Fatal_IncompatibleKinds , CFatal, 87; - Fatal_IncompatibleNumberOfTypes , CFatal, 88; - Fatal_IncompatibleSetOfUniverse , CFatal, 89; - Fatal_IncompatibleUniverse , CFatal, 90; - Fatal_InconsistentImplicitArgumentAnnotation , CFatal, 91; - Fatal_InconsistentImplicitQualifier , CFatal, 92; - Fatal_InconsistentQualifierAnnotation , CFatal, 93; - Fatal_InferredTypeCauseVarEscape , CFatal, 94; - Fatal_InlineRenamedAsUnfold , CFatal, 95; - Fatal_InsufficientPatternArguments , CFatal, 96; - Fatal_InterfaceAlreadyProcessed , CFatal, 97; - Fatal_InterfaceNotImplementedByModule , CError, 98; - Fatal_InterfaceWithTypeImplementation , CFatal, 99; - Fatal_InvalidFloatingPointNumber , CFatal, 100; - Fatal_InvalidFSDocKeyword , CFatal, 101; - Fatal_InvalidIdentifier , CFatal, 102; - Fatal_InvalidLemmaArgument , CFatal, 103; - Fatal_InvalidNumericLiteral , CFatal, 104; - Fatal_InvalidRedefinitionOfLexT , CFatal, 105; - Fatal_InvalidUnicodeInStringLiteral , CFatal, 106; - Fatal_InvalidUTF8Encoding , CFatal, 107; - Fatal_InvalidWarnErrorSetting , CFatal, 108; - Fatal_LetBoundMonadicMismatch , CFatal, 109; - Fatal_LetMutableForVariablesOnly , CFatal, 110; - Fatal_LetOpenModuleOnly , CFatal, 111; - Fatal_LetRecArgumentMismatch , CFatal, 112; - Fatal_MalformedActionDeclaration , CFatal, 113; - Fatal_MismatchedPatternType , CFatal, 114; - Fatal_MismatchUniversePolymorphic , CFatal, 115; - Fatal_MissingDataConstructor , CFatal, 116; - Fatal_MissingExposeInterfacesOption , CFatal, 117; - Fatal_MissingFieldInRecord , CFatal, 118; - Fatal_MissingImplementation , CFatal, 119; - Fatal_MissingImplicitArguments , CFatal, 120; - Fatal_MissingInterface , CFatal, 121; - Fatal_MissingNameInBinder , CFatal, 122; - Fatal_MissingPrimsModule , CFatal, 123; - Fatal_MissingQuantifierBinder , CFatal, 124; - Fatal_ModuleExpected , CFatal, 125; - Fatal_ModuleFileNotFound , CFatal, 126; - Fatal_ModuleFirstStatement , CFatal, 127; - Fatal_ModuleNotFound , CFatal, 128; - Fatal_ModuleOrFileNotFound , CFatal, 129; - Fatal_MonadAlreadyDefined , CFatal, 130; - Fatal_MoreThanOneDeclaration , CFatal, 131; - Fatal_MultipleLetBinding , CFatal, 132; - Fatal_NameNotFound , CFatal, 133; - Fatal_NameSpaceNotFound , CFatal, 134; - Fatal_NegativeUniverseConstFatal_NotSupported , CFatal, 135; - Fatal_NoFileProvided , CFatal, 136; - Fatal_NonInductiveInMutuallyDefinedType , CFatal, 137; - Fatal_NonLinearPatternNotPermitted , CFatal, 138; - Fatal_NonLinearPatternVars , CFatal, 139; - Fatal_NonSingletonTopLevel , CFatal, 140; - Fatal_NonSingletonTopLevelModule , CFatal, 141; - Error_NonTopRecFunctionNotFullyEncoded , CAlwaysError, 142; - Fatal_NonTrivialPreConditionInPrims , CFatal, 143; - Fatal_NonVariableInductiveTypeParameter , CFatal, 144; - Fatal_NotApplicationOrFv , CFatal, 145; - Fatal_NotEnoughArgsToEffect , CFatal, 146; - Fatal_NotEnoughArgumentsForEffect , CFatal, 147; - Fatal_NotFunctionType , CFatal, 148; - Fatal_NotSupported , CFatal, 149; - Fatal_NotTopLevelModule , CFatal, 150; - Fatal_NotValidFStarFile , CFatal, 151; - Fatal_NotValidIncludeDirectory , CWarning, 152; - Fatal_OneModulePerFile , CFatal, 153; - Fatal_OpenGoalsInSynthesis , CFatal, 154; - Fatal_OptionsNotCompatible , CFatal, 155; - Fatal_OutOfOrder , CFatal, 156; - Fatal_ParseErrors , CFatal, 157; - Fatal_ParseItError , CFatal, 158; - Fatal_PolyTypeExpected , CFatal, 159; - Fatal_PossibleInfiniteTyp , CFatal, 160; - Fatal_PreModuleMismatch , CFatal, 161; - Fatal_QulifierListNotPermitted , CFatal, 162; - Fatal_RecursiveFunctionLiteral , CFatal, 163; - Fatal_ReflectOnlySupportedOnEffects , CFatal, 164; - Fatal_ReservedPrefix , CFatal, 165; - Fatal_SMTOutputParseError , CFatal, 166; - Fatal_SMTSolverError , CFatal, 167; - Fatal_SyntaxError , CFatal, 168; - Fatal_SynthByTacticError , CFatal, 169; - Fatal_TacticGotStuck , CFatal, 170; - Fatal_TcOneFragmentFailed , CFatal, 171; - Fatal_TermOutsideOfDefLanguage , CFatal, 172; - Fatal_ToManyArgumentToFunction , CFatal, 173; - Fatal_TooManyOrTooFewFileMatch , CFatal, 174; - Fatal_TooManyPatternArguments , CFatal, 175; - Fatal_TooManyUniverse , CFatal, 176; - Fatal_TypeMismatch , CFatal, 177; - Fatal_TypeWithinPatternsAllowedOnVariablesOnly , CFatal, 178; - Fatal_UnableToReadFile , CFatal, 179; - Fatal_UnepxectedOrUnboundOperator , CFatal, 180; - Fatal_UnexpectedBinder , CFatal, 181; - Fatal_UnexpectedBindShape , CFatal, 182; - Fatal_UnexpectedChar , CFatal, 183; - Fatal_UnexpectedComputationTypeForLetRec , CFatal, 184; - Fatal_UnexpectedConstructorType , CFatal, 185; - Fatal_UnexpectedDataConstructor , CFatal, 186; - Fatal_UnexpectedEffect , CFatal, 187; - Fatal_UnexpectedEmptyRecord , CFatal, 188; - Fatal_UnexpectedExpressionType , CFatal, 189; - Fatal_UnexpectedFunctionParameterType , CFatal, 190; - Fatal_UnexpectedGeneralizedUniverse , CFatal, 191; - Fatal_UnexpectedGTotForLetRec , CFatal, 192; - Fatal_UnexpectedGuard , CFatal, 193; - Fatal_UnexpectedIdentifier , CFatal, 194; - Fatal_UnexpectedImplicitArgument , CFatal, 195; - Fatal_UnexpectedImplictArgument , CFatal, 196; - Fatal_UnexpectedInductivetype , CFatal, 197; - Fatal_UnexpectedLetBinding , CFatal, 198; - Fatal_UnexpectedModuleDeclaration , CFatal, 199; - Fatal_UnexpectedNumberOfUniverse , CFatal, 200; - Fatal_UnexpectedNumericLiteral , CFatal, 201; - Fatal_UnexpectedPattern , CFatal, 203; - Fatal_UnexpectedPosition , CFatal, 204; - Fatal_UnExpectedPreCondition , CFatal, 205; - Fatal_UnexpectedReturnShape , CFatal, 206; - Fatal_UnexpectedSignatureForMonad , CFatal, 207; - Fatal_UnexpectedTerm , CFatal, 208; - Fatal_UnexpectedTermInUniverse , CFatal, 209; - Fatal_UnexpectedTermType , CFatal, 210; - Fatal_UnexpectedTermVQuote , CFatal, 211; - Fatal_UnexpectedUniversePolymorphicReturn , CFatal, 212; - Fatal_UnexpectedUniverseVariable , CFatal, 213; - Fatal_UnfoldableDeprecated , CFatal, 214; - Fatal_UnificationNotWellFormed , CFatal, 215; - Fatal_Uninstantiated , CFatal, 216; - Error_UninstantiatedUnificationVarInTactic , CError, 217; - Fatal_UninstantiatedVarInTactic , CFatal, 218; - Fatal_UniverseMightContainSumOfTwoUnivVars , CFatal, 219; - Fatal_UniversePolymorphicInnerLetBound , CFatal, 220; - Fatal_UnknownAttribute , CFatal, 221; - Fatal_UnknownToolForDep , CFatal, 222; - Fatal_UnrecognizedExtension , CFatal, 223; - Fatal_UnresolvedPatternVar , CFatal, 224; - Fatal_UnsupportedConstant , CFatal, 225; - Fatal_UnsupportedDisjuctivePatterns , CFatal, 226; - Fatal_UnsupportedQualifier , CFatal, 227; - Fatal_UserTacticFailure , CFatal, 228; - Fatal_ValueRestriction , CFatal, 229; - Fatal_VariableNotFound , CFatal, 230; - Fatal_WrongBodyTypeForReturnWP , CFatal, 231; - Fatal_WrongDataAppHeadFormat , CFatal, 232; - Fatal_WrongDefinitionOrder , CFatal, 233; - Fatal_WrongResultTypeAfterConstrutor , CFatal, 234; - Fatal_WrongTerm , CFatal, 235; - Fatal_WhenClauseNotSupported , CFatal, 236; - Unused01 , CFatal, 237; - Warning_PluginNotImplemented , CError, 238; - Warning_AddImplicitAssumeNewQualifier , CWarning, 239; - Error_AdmitWithoutDefinition , CError, 240; - Warning_CachedFile , CWarning, 241; - Warning_DefinitionNotTranslated , CWarning, 242; - Warning_DependencyFound , CWarning, 243; - Warning_DeprecatedEqualityOnBinder , CWarning, 244; - Warning_DeprecatedOpaqueQualifier , CWarning, 245; - Warning_DocOverwrite , CWarning, 246; - Warning_FileNotWritten , CWarning, 247; - Warning_Filtered , CWarning, 248; - Warning_FunctionLiteralPrecisionLoss , CWarning, 249; - Warning_FunctionNotExtacted , CWarning, 250; - Warning_HintFailedToReplayProof , CWarning, 251; - Warning_HitReplayFailed , CWarning, 252; - Warning_IDEIgnoreCodeGen , CWarning, 253; - Warning_IllFormedGoal , CWarning, 254; - Warning_InaccessibleArgument , CWarning, 255; - Warning_IncoherentImplicitQualifier , CWarning, 256; - Warning_IrrelevantQualifierOnArgumentToReflect , CWarning, 257; - Warning_IrrelevantQualifierOnArgumentToReify , CWarning, 258; - Warning_MalformedWarnErrorList , CWarning, 259; - Warning_MetaAlienNotATmUnknown , CWarning, 260; - Warning_MultipleAscriptions , CWarning, 261; - Warning_NondependentUserDefinedDataType , CWarning, 262; - Warning_NonListLiteralSMTPattern , CWarning, 263; - Warning_NormalizationFailure , CWarning, 264; - Warning_NotDependentArrow , CWarning, 265; - Warning_NotEmbedded , CWarning, 266; - Warning_PatternMissingBoundVar , CWarning, 267; - Warning_RecursiveDependency , CWarning, 268; - Warning_RedundantExplicitCurrying , CWarning, 269; - Warning_SMTPatTDeprecated , CWarning, 270; - Warning_SMTPatternIllFormed , CWarning, 271; - Warning_TopLevelEffect , CWarning, 272; - Warning_UnboundModuleReference , CWarning, 273; - Warning_UnexpectedFile , CWarning, 274; - Warning_UnexpectedFsTypApp , CWarning, 275; - Warning_UnexpectedZ3Output , CError, 276; - Warning_UnprotectedTerm , CWarning, 277; - Warning_UnrecognizedAttribute , CWarning, 278; - Warning_UpperBoundCandidateAlreadyVisited , CWarning, 279; - Warning_UseDefaultEffect , CWarning, 280; - Warning_WrongErrorLocation , CWarning, 281; - Warning_Z3InvocationWarning , CWarning, 282; - Warning_MissingInterfaceOrImplementation , CWarning, 283; - Warning_ConstructorBuildsUnexpectedType , CWarning, 284; - Warning_ModuleOrFileNotFoundWarning , CWarning, 285; - Error_NoLetMutable , CAlwaysError, 286; - Error_BadImplicit , CAlwaysError, 287; - Warning_DeprecatedDefinition , CWarning, 288; - Fatal_SMTEncodingArityMismatch , CFatal, 289; - Warning_Defensive , CWarning, 290; - Warning_CantInspect , CWarning, 291; - Warning_NilGivenExplicitArgs , CWarning, 292; - Warning_ConsAppliedExplicitArgs , CWarning, 293; - Warning_UnembedBinderKnot , CWarning, 294; - Fatal_TacticProofRelevantGoal , CFatal, 295; - Warning_TacAdmit , CWarning, 296; - Fatal_IncoherentPatterns , CFatal, 297; - Error_NoSMTButNeeded , CAlwaysError, 298; - Fatal_UnexpectedAntiquotation , CFatal, 299; - Fatal_SplicedUndef , CFatal, 300; - Fatal_SpliceUnembedFail , CFatal, 301; - Warning_ExtractionUnexpectedEffect , CWarning, 302; - Error_DidNotFail , CError, 303; - Warning_UnappliedFail , CWarning, 304; - Warning_QuantifierWithoutPattern , CSilent, 305; - Error_EmptyFailErrs , CAlwaysError, 306; - Warning_logicqualifier , CWarning, 307; - Fatal_CyclicDependence , CFatal, 308; - Error_InductiveAnnotNotAType , CError, 309; - Fatal_FriendInterface , CFatal, 310; - Error_CannotRedefineConst , CError, 311; - Error_BadClassDecl , CError, 312; - Error_BadInductiveParam , CFatal, 313; - Error_FieldShadow , CFatal, 314; - Error_UnexpectedDM4FType , CFatal, 315; - Fatal_EffectAbbreviationResultTypeMismatch , CFatal, 316; - Error_AlreadyCachedAssertionFailure , CFatal, 317; - Error_MustEraseMissing , CWarning, 318; - Warning_EffectfulArgumentToErasedFunction , CWarning, 319; - Fatal_EmptySurfaceLet , CFatal, 320; - Warning_UnexpectedCheckedFile , CWarning, 321; - Fatal_ExtractionUnsupported , CFatal, 322; - Warning_SMTErrorReason , CWarning, 323; - Warning_CoercionNotFound , CWarning, 324; - Error_QuakeFailed , CError, 325; - Error_IllSMTPat , CError, 326; - Error_IllScopedTerm , CError, 327; - Warning_UnusedLetRec , CWarning, 328; - Fatal_Effects_Ordering_Coherence , CError, 329; - Warning_BleedingEdge_Feature , CWarning, 330; - Warning_IgnoredBinding , CWarning, 331; - Warning_CouldNotReadHints , CWarning, 333; - Fatal_BadUvar , CFatal, 334; - Warning_WarnOnUse , CSilent, 335; - Warning_DeprecatedAttributeSyntax , CSilent, 336; - Warning_DeprecatedGeneric , CWarning, 337; - Error_BadSplice , CError, 338; - Error_UnexpectedUnresolvedUvar , CAlwaysError, 339; - Warning_UnfoldPlugin , CWarning, 340; - Error_LayeredMissingAnnot , CAlwaysError, 341; - Error_CallToErased , CError, 342; - Error_ErasedCtor , CError, 343; - Error_RemoveUnusedTypeParameter , CWarning, 344; - Warning_NoMagicInFSharp , CWarning, 345; - Error_BadLetOpenRecord , CAlwaysError, 346; - Error_UnexpectedTypeclassInstance , CAlwaysError, 347; - Warning_AmbiguousResolveImplicitsHook , CWarning, 348; - Warning_SplitAndRetryQueries , CWarning, 349; - Warning_DeprecatedLightDoNotation , CWarning, 350; - Warning_FailedToCheckInitialTacticGoal , CSilent, 351; - Warning_Adhoc_IndexedEffect_Combinator , CWarning, 352; - Error_PluginDynlink , CError, 353; - Error_InternalQualifier , CAlwaysError, 354; - Warning_NameEscape , CWarning, 355; - Warning_UnexpectedZ3Stderr , CWarning, 356; - Warning_SolverMismatch , CError, 357; - Warning_SolverVersionMismatch , CError, 358; - Warning_ProofRecovery , CWarning, 359; - Error_CannotResolveRecord , CAlwaysError, 360; - Error_MissingPopOptions , CWarning, 361; - ] diff --git a/src/basic/FStar.Errors.Codes.fsti b/src/basic/FStar.Errors.Codes.fsti deleted file mode 100644 index f78128c5c07..00000000000 --- a/src/basic/FStar.Errors.Codes.fsti +++ /dev/null @@ -1,395 +0,0 @@ -(* - Copyright 2008-2020 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Errors.Codes - -(* Kinds of errors. *) -type error_flag = - | CFatal //CFatal: these are reported using a raise_error: compiler cannot progress - | CAlwaysError //CAlwaysError: these errors are reported using log_issue and cannot be suppressed - //the compiler can progress after reporting them - | CError //CError: these are reported as errors using log_issue - // but they can be turned into warnings or silenced - | CWarning //CWarning: reported using log_issue as warnings by default; - // then can be silenced or escalated to errors - | CSilent //CSilent: never the default for any issue, but warnings can be silenced - -(* The list of all available error codes *) -type error_code = - | Error_DependencyAnalysisFailed - | Error_IDETooManyPops - | Error_IDEUnrecognized - | Error_InductiveTypeNotSatisfyPositivityCondition - | Error_InvalidUniverseVar - | Error_MissingFileName - | Error_ModuleFileNameMismatch - | Error_OpPlusInUniverse - | Error_OutOfRange - | Error_ProofObligationFailed - | Error_TooManyFiles - | Error_TypeCheckerFailToProve - | Error_TypeError - | Error_UncontrainedUnificationVar - | Error_UnexpectedGTotComputation - | Error_UnexpectedInstance - | Error_UnknownFatal_AssertionFailure - | Error_Z3InvocationError - | Error_IDEAssertionFailure - | Error_Z3SolverError - | Fatal_AbstractTypeDeclarationInInterface - | Fatal_ActionMustHaveFunctionType - | Fatal_AlreadyDefinedTopLevelDeclaration - | Fatal_ArgumentLengthMismatch - | Fatal_AssertionFailure - | Fatal_AssignToImmutableValues - | Fatal_AssumeValInInterface - | Fatal_BadlyInstantiatedSynthByTactic - | Fatal_BadSignatureShape - | Fatal_BinderAndArgsLengthMismatch - | Fatal_BothValAndLetInInterface - | Fatal_CardinalityConstraintViolated - | Fatal_ComputationNotTotal - | Fatal_ComputationTypeNotAllowed - | Fatal_ComputedTypeNotMatchAnnotation - | Fatal_ConstructorArgLengthMismatch - | Fatal_ConstructorFailedCheck - | Fatal_ConstructorNotFound - | Fatal_ConstsructorBuildWrongType - | Fatal_CycleInRecTypeAbbreviation - | Fatal_DataContructorNotFound - | Fatal_DefaultQualifierNotAllowedOnEffects - | Fatal_DefinitionNotFound - | Fatal_DisjuctivePatternVarsMismatch - | Fatal_DivergentComputationCannotBeIncludedInTotal - | Fatal_DuplicateInImplementation - | Fatal_DuplicateModuleOrInterface - | Fatal_DuplicateTopLevelNames - | Fatal_DuplicateTypeAnnotationAndValDecl - | Fatal_EffectCannotBeReified - | Fatal_EffectConstructorNotFullyApplied - | Fatal_EffectfulAndPureComputationMismatch - | Fatal_EffectNotFound - | Fatal_EffectsCannotBeComposed - | Fatal_ErrorInSolveDeferredConstraints - | Fatal_ErrorsReported - | Fatal_EscapedBoundVar - | Fatal_ExpectedArrowAnnotatedType - | Fatal_ExpectedGhostExpression - | Fatal_ExpectedPureExpression - | Fatal_ExpectNormalizedEffect - | Fatal_ExpectTermGotFunction - | Fatal_ExpectTrivialPreCondition - | Fatal_FailToCompileNativeTactic - | Fatal_FailToExtractNativeTactic - | Fatal_FailToProcessPragma - | Fatal_FailToResolveImplicitArgument - | Fatal_FailToSolveUniverseInEquality - | Fatal_FieldsNotBelongToSameRecordType - | Fatal_ForbiddenReferenceToCurrentModule - | Fatal_FreeVariables - | Fatal_FunctionTypeExpected - | Fatal_IdentifierNotFound - | Fatal_IllAppliedConstant - | Fatal_IllegalCharInByteArray - | Fatal_IllegalCharInOperatorName - | Fatal_IllTyped - | Fatal_ImpossibleAbbrevLidBundle - | Fatal_ImpossibleAbbrevRenameBundle - | Fatal_ImpossibleInductiveWithAbbrev - | Fatal_ImpossiblePrePostAbs - | Fatal_ImpossiblePrePostArrow - | Fatal_ImpossibleToGenerateDMEffect - | Fatal_ImpossibleTypeAbbrevBundle - | Fatal_ImpossibleTypeAbbrevSigeltBundle - | Fatal_IncludeModuleNotPrepared - | Fatal_IncoherentInlineUniverse - | Fatal_IncompatibleKinds - | Fatal_IncompatibleNumberOfTypes - | Fatal_IncompatibleSetOfUniverse - | Fatal_IncompatibleUniverse - | Fatal_InconsistentImplicitArgumentAnnotation - | Fatal_InconsistentImplicitQualifier - | Fatal_InconsistentQualifierAnnotation - | Fatal_InferredTypeCauseVarEscape - | Fatal_InlineRenamedAsUnfold - | Fatal_InsufficientPatternArguments - | Fatal_InterfaceAlreadyProcessed - | Fatal_InterfaceNotImplementedByModule - | Fatal_InterfaceWithTypeImplementation - | Fatal_InvalidFloatingPointNumber - | Fatal_InvalidFSDocKeyword - | Fatal_InvalidIdentifier - | Fatal_InvalidLemmaArgument - | Fatal_InvalidNumericLiteral - | Fatal_InvalidRedefinitionOfLexT - | Fatal_InvalidUnicodeInStringLiteral - | Fatal_InvalidUTF8Encoding - | Fatal_InvalidWarnErrorSetting - | Fatal_LetBoundMonadicMismatch - | Fatal_LetMutableForVariablesOnly - | Fatal_LetOpenModuleOnly - | Fatal_LetRecArgumentMismatch - | Fatal_MalformedActionDeclaration - | Fatal_MismatchedPatternType - | Fatal_MismatchUniversePolymorphic - | Fatal_MissingDataConstructor - | Fatal_MissingExposeInterfacesOption - | Fatal_MissingFieldInRecord - | Fatal_MissingImplementation - | Fatal_MissingImplicitArguments - | Fatal_MissingInterface - | Fatal_MissingNameInBinder - | Fatal_MissingPrimsModule - | Fatal_MissingQuantifierBinder - | Fatal_ModuleExpected - | Fatal_ModuleFileNotFound - | Fatal_ModuleFirstStatement - | Fatal_ModuleNotFound - | Fatal_ModuleOrFileNotFound - | Fatal_MonadAlreadyDefined - | Fatal_MoreThanOneDeclaration - | Fatal_MultipleLetBinding - | Fatal_NameNotFound - | Fatal_NameSpaceNotFound - | Fatal_NegativeUniverseConstFatal_NotSupported - | Fatal_NoFileProvided - | Fatal_NonInductiveInMutuallyDefinedType - | Fatal_NonLinearPatternNotPermitted - | Fatal_NonLinearPatternVars - | Fatal_NonSingletonTopLevel - | Fatal_NonSingletonTopLevelModule - | Error_NonTopRecFunctionNotFullyEncoded - | Fatal_NonTrivialPreConditionInPrims - | Fatal_NonVariableInductiveTypeParameter - | Fatal_NotApplicationOrFv - | Fatal_NotEnoughArgsToEffect - | Fatal_NotEnoughArgumentsForEffect - | Fatal_NotFunctionType - | Fatal_NotSupported - | Fatal_NotTopLevelModule - | Fatal_NotValidFStarFile - | Fatal_NotValidIncludeDirectory - | Fatal_OneModulePerFile - | Fatal_OpenGoalsInSynthesis - | Fatal_OptionsNotCompatible - | Fatal_OutOfOrder - | Fatal_ParseErrors - | Fatal_ParseItError - | Fatal_PolyTypeExpected - | Fatal_PossibleInfiniteTyp - | Fatal_PreModuleMismatch - | Fatal_QulifierListNotPermitted - | Fatal_RecursiveFunctionLiteral - | Fatal_ReflectOnlySupportedOnEffects - | Fatal_ReservedPrefix - | Fatal_SMTOutputParseError - | Fatal_SMTSolverError - | Fatal_SyntaxError - | Fatal_SynthByTacticError - | Fatal_TacticGotStuck - | Fatal_TcOneFragmentFailed - | Fatal_TermOutsideOfDefLanguage - | Fatal_ToManyArgumentToFunction - | Fatal_TooManyOrTooFewFileMatch - | Fatal_TooManyPatternArguments - | Fatal_TooManyUniverse - | Fatal_TypeMismatch - | Fatal_TypeWithinPatternsAllowedOnVariablesOnly - | Fatal_UnableToReadFile - | Fatal_UnepxectedOrUnboundOperator - | Fatal_UnexpectedBinder - | Fatal_UnexpectedBindShape - | Fatal_UnexpectedChar - | Fatal_UnexpectedComputationTypeForLetRec - | Fatal_UnexpectedConstructorType - | Fatal_UnexpectedDataConstructor - | Fatal_UnexpectedEffect - | Fatal_UnexpectedEmptyRecord - | Fatal_UnexpectedExpressionType - | Fatal_UnexpectedFunctionParameterType - | Fatal_UnexpectedGeneralizedUniverse - | Fatal_UnexpectedGTotForLetRec - | Fatal_UnexpectedGuard - | Fatal_UnexpectedIdentifier - | Fatal_UnexpectedImplicitArgument - | Fatal_UnexpectedImplictArgument - | Fatal_UnexpectedInductivetype - | Fatal_UnexpectedLetBinding - | Fatal_UnexpectedModuleDeclaration - | Fatal_UnexpectedNumberOfUniverse - | Fatal_UnexpectedNumericLiteral - | Fatal_UnexpectedPattern - | Fatal_UnexpectedPosition - | Fatal_UnExpectedPreCondition - | Fatal_UnexpectedReturnShape - | Fatal_UnexpectedSignatureForMonad - | Fatal_UnexpectedTerm - | Fatal_UnexpectedTermInUniverse - | Fatal_UnexpectedTermType - | Fatal_UnexpectedTermVQuote - | Fatal_UnexpectedUniversePolymorphicReturn - | Fatal_UnexpectedUniverseVariable - | Fatal_UnfoldableDeprecated - | Fatal_UnificationNotWellFormed - | Fatal_Uninstantiated - | Error_UninstantiatedUnificationVarInTactic - | Fatal_UninstantiatedVarInTactic - | Fatal_UniverseMightContainSumOfTwoUnivVars - | Fatal_UniversePolymorphicInnerLetBound - | Fatal_UnknownAttribute - | Fatal_UnknownToolForDep - | Fatal_UnrecognizedExtension - | Fatal_UnresolvedPatternVar - | Fatal_UnsupportedConstant - | Fatal_UnsupportedDisjuctivePatterns - | Fatal_UnsupportedQualifier - | Fatal_UserTacticFailure - | Fatal_ValueRestriction - | Fatal_VariableNotFound - | Fatal_WrongBodyTypeForReturnWP - | Fatal_WrongDataAppHeadFormat - | Fatal_WrongDefinitionOrder - | Fatal_WrongResultTypeAfterConstrutor - | Fatal_WrongTerm - | Fatal_WhenClauseNotSupported - | Unused01 - | Warning_AddImplicitAssumeNewQualifier - | Error_AdmitWithoutDefinition - | Warning_CachedFile - | Warning_DefinitionNotTranslated - | Warning_DependencyFound - | Warning_DeprecatedEqualityOnBinder - | Warning_DeprecatedOpaqueQualifier - | Warning_DocOverwrite - | Warning_FileNotWritten - | Warning_Filtered - | Warning_FunctionLiteralPrecisionLoss - | Warning_FunctionNotExtacted - | Warning_HintFailedToReplayProof - | Warning_HitReplayFailed - | Warning_IDEIgnoreCodeGen - | Warning_IllFormedGoal - | Warning_InaccessibleArgument - | Warning_IncoherentImplicitQualifier - | Warning_IrrelevantQualifierOnArgumentToReflect - | Warning_IrrelevantQualifierOnArgumentToReify - | Warning_MalformedWarnErrorList - | Warning_MetaAlienNotATmUnknown - | Warning_MultipleAscriptions - | Warning_NondependentUserDefinedDataType - | Warning_NonListLiteralSMTPattern - | Warning_NormalizationFailure - | Warning_NotDependentArrow - | Warning_NotEmbedded - | Warning_PatternMissingBoundVar //AR: this is deprecated, use Warning_SMTPatternIllFormed instead - // not removing it so as not to mess up the error numbers - | Warning_RecursiveDependency - | Warning_RedundantExplicitCurrying - | Warning_SMTPatTDeprecated - | Warning_SMTPatternIllFormed - | Warning_TopLevelEffect - | Warning_UnboundModuleReference - | Warning_UnexpectedFile - | Warning_UnexpectedFsTypApp - | Warning_UnexpectedZ3Output - | Warning_UnprotectedTerm - | Warning_UnrecognizedAttribute - | Warning_UpperBoundCandidateAlreadyVisited - | Warning_UseDefaultEffect - | Warning_WrongErrorLocation - | Warning_Z3InvocationWarning - | Warning_PluginNotImplemented - | Warning_MissingInterfaceOrImplementation - | Warning_ConstructorBuildsUnexpectedType - | Warning_ModuleOrFileNotFoundWarning - | Error_NoLetMutable - | Error_BadImplicit - | Warning_DeprecatedDefinition - | Fatal_SMTEncodingArityMismatch - | Warning_Defensive - | Warning_CantInspect - | Warning_NilGivenExplicitArgs - | Warning_ConsAppliedExplicitArgs - | Warning_UnembedBinderKnot - | Fatal_TacticProofRelevantGoal - | Warning_TacAdmit - | Fatal_IncoherentPatterns - | Error_NoSMTButNeeded - | Fatal_UnexpectedAntiquotation - | Fatal_SplicedUndef - | Fatal_SpliceUnembedFail - | Warning_ExtractionUnexpectedEffect - | Error_DidNotFail - | Warning_UnappliedFail - | Warning_QuantifierWithoutPattern - | Error_EmptyFailErrs - | Warning_logicqualifier - | Fatal_CyclicDependence - | Error_InductiveAnnotNotAType - | Fatal_FriendInterface - | Error_CannotRedefineConst - | Error_BadClassDecl - | Error_BadInductiveParam - | Error_FieldShadow - | Error_UnexpectedDM4FType - | Fatal_EffectAbbreviationResultTypeMismatch - | Error_AlreadyCachedAssertionFailure - | Error_MustEraseMissing - | Warning_EffectfulArgumentToErasedFunction - | Fatal_EmptySurfaceLet - | Warning_UnexpectedCheckedFile - | Fatal_ExtractionUnsupported - | Warning_SMTErrorReason - | Warning_CoercionNotFound - | Error_QuakeFailed - | Error_IllSMTPat - | Error_IllScopedTerm - | Warning_UnusedLetRec - | Fatal_Effects_Ordering_Coherence - | Warning_BleedingEdge_Feature - | Warning_IgnoredBinding - | Warning_CouldNotReadHints - | Fatal_BadUvar - | Warning_WarnOnUse - | Warning_DeprecatedAttributeSyntax - | Warning_DeprecatedGeneric - | Error_BadSplice - | Error_UnexpectedUnresolvedUvar - | Warning_UnfoldPlugin - | Error_LayeredMissingAnnot - | Error_CallToErased - | Error_ErasedCtor - | Error_RemoveUnusedTypeParameter - | Warning_NoMagicInFSharp - | Error_BadLetOpenRecord - | Error_UnexpectedTypeclassInstance - | Warning_AmbiguousResolveImplicitsHook - | Warning_SplitAndRetryQueries - | Warning_DeprecatedLightDoNotation - | Warning_FailedToCheckInitialTacticGoal - | Warning_Adhoc_IndexedEffect_Combinator - | Error_PluginDynlink - | Error_InternalQualifier - | Warning_NameEscape - | Warning_UnexpectedZ3Stderr - | Warning_SolverMismatch - | Warning_SolverVersionMismatch - | Warning_ProofRecovery - | Error_CannotResolveRecord - | Error_MissingPopOptions - -type error_setting = error_code & error_flag & int - -val default_settings : list error_setting diff --git a/src/basic/FStar.Errors.Msg.fst b/src/basic/FStar.Errors.Msg.fst deleted file mode 100644 index 0799c2b3c22..00000000000 --- a/src/basic/FStar.Errors.Msg.fst +++ /dev/null @@ -1,63 +0,0 @@ -module FStar.Errors.Msg - -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.Util -open FStar.Pprint - -instance is_error_message_string : is_error_message string = { - to_doc_list = (fun s -> [arbitrary_string s]); -} - -instance is_error_message_list_doc : is_error_message (list Pprint.document) = { - to_doc_list = id; -} - -let vconcat (ds:list document) : document = - match ds with - | h::t -> - List.fold_left (fun l r -> l ^^ hardline ^^ r) h t - | [] -> - empty - -let text (s:string) : document = - flow (break_ 1) (words s) - -let sublist (h:document) (ds:list document) : document = - nest 2 (hardline ^^ align (ds |> List.map (fun d -> h ^^ d) |> vconcat)) - -let bulleted (ds:list document) : document = - sublist (doc_of_string "- ") ds - -let mkmsg (s:string) : list document = - [arbitrary_string s] - -let renderdoc (d : document) : string = - let one = float_of_string "1.0" in - pretty_string one 80 d - -let backtrace_doc () : document = - let s = stack_dump () in - text "Stack trace:" ^/^ - arbitrary_string (trim_string s) - -let subdoc' (indent:bool) d = - (* NOTE: slight hack here, using equality on Pprint documents. This works - fine, particularly for this case, since empty is just a constructor Empty. - There is even a new function to check if a document is empty, added two weeks ago! - https://github.com/fpottier/pprint/commit/afecb1a6a2751648f62147660ea8fee7a2dee054 - So I don't expect this to fail any time soon, and when it does we could just - switch to using that function. (I won't right now as it is not released). *) - if d = empty - then empty - else (if indent then blank 2 else empty) ^^ doc_of_string "-" ^^ blank 1 ^^ align d ^^ hardline - -let subdoc d = subdoc' true d - -let rendermsg (ds : list document) : string = - renderdoc (concat (List.map (fun d -> subdoc (group d)) ds)) - -let json_of_error_message (err_msg: list document): FStar.Json.json - = FStar.Compiler.List.map - (fun doc -> FStar.Json.JsonStr (renderdoc doc)) err_msg - |> FStar.Json.JsonList diff --git a/src/basic/FStar.Errors.Msg.fsti b/src/basic/FStar.Errors.Msg.fsti deleted file mode 100644 index 90003ebcbf4..00000000000 --- a/src/basic/FStar.Errors.Msg.fsti +++ /dev/null @@ -1,66 +0,0 @@ -module FStar.Errors.Msg - -open FStar.Pprint - -(* FIXME: make this interface saner, especially by providing subdoc/sublist, etc *) - -(* An error message is a list of documents. This allows us to print errors like -these: - -* Error 19 at tests/error-messages/Bug1997.fst(92,19-92,49): - - Assertion failed - - The SMT solver could not prove the query. Use --query_stats for more details. - - Also see: Prims.fst(96,32-96,42) - -The header is taken from the code and range, and then the documents are rendered -in order. - -`empty` documents in the list are skipped. -*) -type error_message = list document - -class is_error_message (t:Type) = { - to_doc_list : t -> error_message; -} - -instance val is_error_message_string : is_error_message string -instance val is_error_message_list_doc : is_error_message (list Pprint.document) - -(* A helper for creating errors from strings, only to be used for text. -This will split the string into words and format is a paragraph. - -If you call this with a string containing a pretty-printed term (or -anything else) all its formatting will be lost. You should instead use -[term_to_doc] or similar to work with the documents directly, or as a -last resort use doc_of_string. *) -val text : string -> document - -(* Makes an indented sublist using bullet as a header for each list element. *) -val sublist : bullet:document -> elems:list document -> document - -(* == sublist (doc_of_string "- ") *) -val bulleted : list document -> document - -(* Create a simple error message from a string. If the string is just -text and can be long, please use [text] instead. On the other hand, if -you need to respect indentation/spacing in the string, then use this -one, but if that's the case it's probably better to build a doc instead -of lifting from a string. NB: mkmsg s is equal to [doc_of_string s]. *) -val mkmsg : string -> error_message - -(* As subdoc, but allows to not indent. *) -val subdoc' : indent:bool -> document -> document - -(* A nested document that can be concatenated with another one *) -val subdoc : document -> document - -(* Only to be used by FStar.Errors *) -val renderdoc : document -> string - -(* Returns a document with the current stack trace *) -val backtrace_doc : unit -> document - -(* Render an error message as a string. *) -val rendermsg : error_message -> string - -val json_of_error_message: list document -> FStar.Json.json diff --git a/src/basic/FStar.Errors.fst b/src/basic/FStar.Errors.fst deleted file mode 100644 index aacb51bb227..00000000000 --- a/src/basic/FStar.Errors.fst +++ /dev/null @@ -1,693 +0,0 @@ -(* - Copyright 2008-2020 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Errors - -open FStar.Pervasives -open FStar.String -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Compiler.Util -open FStar.Compiler.Range -open FStar.Class.Monad -open FStar.Options -module List = FStar.Compiler.List -module BU = FStar.Compiler.Util -module PP = FStar.Pprint - -open FStar.Errors.Codes -open FStar.Errors.Msg -open FStar.Json - -let fallback_range : ref (option range) = BU.mk_ref None - -let error_range_bound : ref (option range) = BU.mk_ref None - -let with_error_bound (r:range) (f : unit -> 'a) : 'a = - let old = !error_range_bound in - error_range_bound := Some r; - let res = f () in - error_range_bound := old; - res - -(** This exception is raised in FStar.Error - when a warn_error string could not be processed; - The exception is handled in FStar.Options as part of - option parsing. *) -exception Invalid_warn_error_setting of string - -let lookup_error settings e = - match - BU.try_find (fun (v, _, i) -> e=v) settings - with - | Some i -> i - | None -> failwith "Impossible: unrecognized error" - -(** Find a (potentially empty) set of issues whose numbers - are in the interval [l,h]. - - Note: We intentionally do not warn on the use of non-existent - issue number *) -let lookup_error_range settings (l, h) = - let matches, _ = - List.partition (fun (_, _, i) -> l <= i && i <= h) settings - in - matches - -let error_number (_, _, i) = i -let errno (e:error_code) : int = error_number (lookup_error default_settings e) - -(* Exported *) -let warn_on_use_errno = errno Warning_WarnOnUse -let defensive_errno = errno Warning_Defensive -let call_to_erased_errno = errno Error_CallToErased - -let update_flags (l:list (error_flag & string)) - : list error_setting - = let set_one_flag i flag default_flag = - match flag, default_flag with - | (CWarning, CAlwaysError) - | (CError, CAlwaysError) -> - raise (Invalid_warn_error_setting - (BU.format1 "cannot turn error %s into warning" - (BU.string_of_int i))) - | (CSilent, CAlwaysError) -> - raise (Invalid_warn_error_setting - (BU.format1 "cannot silence error %s" - (BU.string_of_int i))) - | (CSilent, CFatal) - | (CWarning, CFatal) - | (CError, CFatal) -> - raise (Invalid_warn_error_setting - (BU.format1 "cannot change the error level of fatal error %s" - (BU.string_of_int i))) - | (CAlwaysError, CFatal) -> - CFatal - | _ -> flag - in - let set_flag_for_range (flag, range) = - let errs = lookup_error_range default_settings range in - List.map (fun (v, default_flag, i) -> v, set_one_flag i flag default_flag, i) errs - in - let compute_range (flag, s) = - let r = BU.split s ".." in - let (l,h) = - match r with - | [r1; r2] -> (int_of_string r1, int_of_string r2) - | _ -> raise (Invalid_warn_error_setting - (BU.format1 "Malformed warn-error range %s" s)) - in - flag, (l, h) - in - // NOTE: Rev below so when we handle things like '@0..100-50' - // the -50 overrides the @0..100. - let error_range_settings = List.map compute_range (List.rev l) in - List.collect set_flag_for_range error_range_settings - @ default_settings - -exception Error of error -exception Warning of error -exception Stop -exception Empty_frag - -let json_of_issue_level level - = JsonStr ( match level with - | ENotImplemented -> "NotImplemented" - | EInfo -> "Info" - | EWarning -> "Warning" - | EError -> "Error") - -let json_of_issue issue = - JsonAssoc [ - "msg", json_of_error_message issue.issue_msg; - "level", json_of_issue_level issue.issue_level; - "range", dflt JsonNull (json_of_range <$> issue.issue_range); - "number", dflt JsonNull (JsonInt <$> issue.issue_number); - "ctx", JsonList (JsonStr <$> issue.issue_ctx); - ] - - -let ctx_doc (ctx : list string) : PP.document = - let open FStar.Pprint in - if Options.error_contexts () - then - ctx - |> List.map (fun s -> hardline ^^ doc_of_string "> " ^^ doc_of_string s) - |> Pprint.concat - else empty - -(* No newline at the end *) -(* Only used externally *) -let issue_message (i:issue) : list PP.document = - let open FStar.Pprint in - i.issue_msg @ [ctx_doc i.issue_ctx] - -let string_of_issue_level il = - match il with - | EInfo -> "Info" - | EWarning -> "Warning" - | EError -> "Error" - | ENotImplemented -> "Feature not yet implemented: " -let issue_level_of_string = - function - | "Info" -> EInfo - | "Warning" -> EWarning - | "Error" -> EError - | _ -> ENotImplemented - -let optional_def (f : 'a -> PP.document) (def : PP.document) (o : option 'a) : PP.document = - match o with - | Some x -> f x - | None -> def - -let format_issue' (print_hdr:bool) (issue:issue) : string = - let open FStar.Pprint in - let level_header = doc_of_string (string_of_issue_level issue.issue_level) in - let num_opt = - if issue.issue_level = EError || issue.issue_level = EWarning - then blank 1 ^^ optional_def (fun n -> doc_of_string (string_of_int n)) (doc_of_string "") issue.issue_number - else empty - in - let r = issue.issue_range in - let atrng : document = - match r with - | Some r when r <> Range.dummyRange -> - blank 1 ^^ doc_of_string "at" ^^ blank 1 ^^ doc_of_string (Range.string_of_use_range r) - | _ -> - empty - in - let hdr : document = - if print_hdr - then - doc_of_string "*" ^^ blank 1 ^^ level_header ^^ num_opt ^^ - atrng ^^ - doc_of_string ":" ^^ hardline - else empty - in - let seealso : document = - match r with - | Some r when def_range r <> use_range r && def_range r <> def_range dummyRange -> - doc_of_string "See also" ^^ blank 1 ^^ doc_of_string (Range.string_of_range r) - | _ -> empty - in - let ctx : document = - match issue.issue_ctx with - | h::t when Options.error_contexts () -> - let d1 s = doc_of_string "> " ^^ doc_of_string s in - List.fold_left (fun l r -> l ^^ hardline ^^ d1 r) (d1 h) t - | _ -> empty - in - (* We only indent if we are are printing the header. I.e., only ident for batch errors, - not for VS code diagnostics window. *) - let subdoc = subdoc' print_hdr in - let mainmsg : document = - concat (List.map (fun d -> subdoc (group d)) issue.issue_msg) - in - let doc : document = - (* This ends in a hardline to get a 1-line spacing between errors *) - hdr ^^ - mainmsg ^^ - subdoc seealso ^^ - subdoc ctx - in - renderdoc doc - -let format_issue issue : string = format_issue' true issue - -let print_issue_json issue = - json_of_issue issue |> string_of_json |> BU.print1_error "%s\n" - -let print_issue_rendered issue = - let printer = - match issue.issue_level with - | EInfo -> (fun s -> BU.print_string (colorize_cyan s)) - | EWarning -> BU.print_warning - | EError -> BU.print_error - | ENotImplemented -> BU.print_error in - printer (format_issue issue ^ "\n") - -let print_issue issue = - match FStar.Options.message_format () with - | Human -> print_issue_rendered issue - | Json -> print_issue_json issue - -let compare_issues i1 i2 = - match i1.issue_range, i2.issue_range with - | None, None -> 0 - | None, Some _ -> -1 - | Some _, None -> 1 - | Some r1, Some r2 -> FStar.Compiler.Range.compare_use_range r1 r2 - -let dummy_ide_rng : Range.rng = - mk_rng "" (mk_pos 1 0) (mk_pos 1 0) - -let maybe_bound_rng (r : Range.range) : Range.range = - match !error_range_bound with - | Some r' -> Range.bound_range r r' - | None -> r - -(* Attempts to set a decent range (no dummy, no dummy ide) relying -on the fallback_range reference. *) -let fixup_issue_range (i:issue) : issue = - let rng = - match i.issue_range with - | None -> - (* No range given, just rely on the fallback. NB: the - fallback could also be set to None if it's too early. *) - !fallback_range - | Some range -> - let use_rng = use_range range in - let use_rng' = - if use_rng <> dummy_rng && use_rng <> dummy_ide_rng then - (* Looks good, use it *) - use_rng - else if Some? (!fallback_range) then - (* Or take the use range from the fallback *) - use_range (Some?.v (!fallback_range)) - else - (* Doesn't look good, but no fallback, oh well *) - use_rng - in - Some (set_use_range range use_rng') - in - { i with issue_range = map_opt rng maybe_bound_rng } - -let mk_default_handler print = - let issues : ref (list issue) = BU.mk_ref [] in - (* This number may be greater than the amount of 'EErrors' - * in the list above due to errors that were immediately - * printed (if debug_any()) *) - let err_count : ref int = BU.mk_ref 0 in - - let add_one (e: issue) = - (if e.issue_level = EError then - err_count := 1 + !err_count); - begin match e.issue_level with - | EInfo when print -> print_issue e - | _ when print && Debug.any () -> print_issue e - | _ -> issues := e :: !issues - end; - if Options.defensive_abort () && e.issue_number = Some defensive_errno then - failwith "Aborting due to --defensive abort"; - () - in - let count_errors () = !err_count in - let report () = - let unique_issues = BU.remove_dups (fun i0 i1 -> i0=i1) !issues in - let sorted_unique_issues = List.sortWith compare_issues unique_issues in - if print then List.iter print_issue sorted_unique_issues; - sorted_unique_issues - in - let clear () = issues := []; err_count := 0 in - { eh_name = "default handler (print=" ^ string_of_bool print ^ ")"; - eh_add_one = add_one; - eh_count_errors = count_errors; - eh_report = report; - eh_clear = clear } - -let default_handler = mk_default_handler true - -let current_handler = - BU.mk_ref default_handler - -let mk_issue level range msg n ctx = { - issue_level = level; - issue_range = range; - issue_msg = msg; - issue_number = n; - issue_ctx = ctx; -} - -let get_err_count () = (!current_handler).eh_count_errors () - -let wrapped_eh_add_one (h : error_handler) (issue : issue) : unit = - (* Try to set a good use range if we got an empty/dummy one *) - let issue = fixup_issue_range issue in - h.eh_add_one issue; - if issue.issue_level <> EInfo then begin - Options.abort_counter := !Options.abort_counter - 1; - if !Options.abort_counter = 0 then - failwith "Aborting due to --abort_on" - end - -let add_one issue = - atomically (fun () -> wrapped_eh_add_one (!current_handler) issue) - -let add_many issues = - atomically (fun () -> List.iter (wrapped_eh_add_one (!current_handler)) issues) - -let add_issues issues = add_many issues - -let report_all () = - (!current_handler).eh_report () - -let clear () = - (!current_handler).eh_clear () - -let set_handler handler = - let issues = report_all () in - clear (); current_handler := handler; add_many issues - -type error_context_t = { - push : string -> unit; - pop : unit -> string; - clear : unit -> unit; - get : unit -> list string; - set : list string -> unit; -} - -let error_context : error_context_t = - let ctxs = BU.mk_ref [] in - let push s = ctxs := s :: !ctxs in - let pop s = - match !ctxs with - | h::t -> (ctxs := t; h) - | _ -> failwith "cannot pop error prefix..." - in - let clear () = ctxs := [] in - let get () = !ctxs in - let set c = ctxs := c in - { push = push - ; pop = pop - ; clear = clear - ; get = get - ; set = set - } - -let get_ctx () : list string = - error_context.get () - -let maybe_add_backtrace (msg : error_message) : error_message = - if Options.trace_error () then - msg @ [backtrace_doc ()] - else - msg - -let warn_unsafe_options rng_opt msg = - match Options.report_assumes () with - | Some "warn" -> - add_one (mk_issue EWarning rng_opt (mkmsg ("Every use of this option triggers a warning: " ^ msg)) (Some warn_on_use_errno) []) - | Some "error" -> - add_one (mk_issue EError rng_opt (mkmsg ("Every use of this option triggers an error: " ^ msg)) (Some warn_on_use_errno) []) - | _ -> () - -let set_option_warning_callback_range (ropt:option FStar.Compiler.Range.range) = - Options.set_option_warning_callback (warn_unsafe_options ropt) - -let t_set_parse_warn_error, - error_flags = - (* To parse a warn_error string we expect a callback to be set in FStar.Main.setup_hooks *) - let parser_callback : ref (option (string -> list error_setting)) = mk_ref None in - (* The reporting of errors, particularly errors in the warn_error string itself - is delicate. - We keep a map from warn_error strings to their parsed results, - - Some list error_setting in case it parses and is interpreted successfully - - None in case it does not parse or is not intepretable - *) - let error_flags : BU.smap (option (list error_setting)) = BU.smap_create 10 in - (* set_error_flags is called by Options.set_options, parse_cmd_line etc, - upon parsing the options. - It parses the current warn_error string and sets the result in the - error_flags map above. In case it fails, it reports an Getopt error - for Options to report. Options may, in turn, report that error - back using the functionality of this module, e.g., log_issue *) - let set_error_flags () = - let parse (s:string) = - match !parser_callback with - | None -> failwith "Callback for parsing warn_error strings is not set" - | Some f -> f s - in - let we = Options.warn_error () in - try let r = parse we in - BU.smap_add error_flags we (Some r); - Getopt.Success - with Invalid_warn_error_setting msg -> - (BU.smap_add error_flags we None; - Getopt.Error ("Invalid --warn_error setting: " ^ msg ^ "\n")) - in - (* get_error_flags is called when logging an issue to figure out - which error level to report a particular issue at (Warning, Error etc.) - It is important that this function itself never raises an exception: - raising an error when trying to report an error is bad news, e.g., it - crashes the ide mode since it causes F* to exit abruptly. - So, we don't do any parsing here ... just look up the result of a - prior parse, falling back to the default settings in case the - parse didn't succeed *) - let get_error_flags () = - let we = Options.warn_error () in - match BU.smap_try_find error_flags we with - | Some (Some w) -> w - | _ -> default_settings - in - (* Setting the parser callback received from setup_hooks - and installing, in turn, callbacks in Options for - parsing warn_error settings and also for warning on the use of - unsafe options. *) - let set_callbacks (f:string -> list error_setting) = - parser_callback := Some f; - Options.set_error_flags_callback set_error_flags; - Options.set_option_warning_callback (warn_unsafe_options None) - in - set_callbacks, get_error_flags - -(* Work around bug *) -let set_parse_warn_error = t_set_parse_warn_error - -let lookup err = - let flags = error_flags () in - let v, level, i = lookup_error flags err in - let with_level level = v, level, i in - match v with - | Warning_Defensive when Options.defensive_error () || Options.defensive_abort () -> - with_level CAlwaysError - - | Warning_WarnOnUse -> - let level' = - //the level of warn_on_use is the - //max severity of the report_assumes setting (none, warn, error) - //and whatever the level is by default (e.g., due to a --warn_error setting) - match Options.report_assumes () with - | None -> level - | Some "warn" -> - (match level with - | CSilent -> CWarning - | _ -> level) - | Some "error" -> - (match level with - | CWarning - | CSilent -> CError - | _ -> level) - | Some _ -> - level - in - with_level level' - - | _ -> - with_level level - -let log_issue_ctx r (e, msg) ctx = - let msg = maybe_add_backtrace msg in - match lookup e with - | (_, CAlwaysError, errno) - | (_, CError, errno) -> - add_one (mk_issue EError (Some r) msg (Some errno) ctx) - | (_, CWarning, errno) -> - add_one (mk_issue EWarning (Some r) msg (Some errno) ctx) - | (_, CSilent, _) -> () - // We allow using log_issue to report a Fatal error in interactive mode - | (_, CFatal, errno) -> - let i = mk_issue EError (Some r) msg (Some errno) ctx in - if Options.ide() - then add_one i - else failwith ("don't use log_issue to report fatal error, should use raise_error: " ^ format_issue i) - -let info r msg = - let open FStar.Class.HasRange in - let rng = pos r in - let msg = to_doc_list msg in - let msg = maybe_add_backtrace msg in - let ctx = get_ctx () in - add_one (mk_issue EInfo (Some rng) msg None ctx) - -let diag r msg = - if Debug.any() then - info r msg - -let raise_error r e msg = - let open FStar.Class.HasRange in - let rng = pos r in - let msg = to_doc_list msg in - raise (Error (e, maybe_add_backtrace msg, rng, error_context.get ())) - -let log_issue r e msg = - let open FStar.Class.HasRange in - let rng = pos r in - let msg = to_doc_list msg in - let ctx = error_context.get () in - log_issue_ctx rng (e, msg) ctx - -let raise_error0 e msg = raise_error dummyRange e msg -let log_issue0 e msg = log_issue dummyRange e msg -let diag0 msg = diag dummyRange msg - -let add_errors (errs : list error) : unit = - atomically (fun () -> List.iter (fun (e, msg, r, ctx) -> log_issue_ctx r (e, msg) ctx) errs) - -let issue_of_exn (e:exn) : option issue = - match e with - | Error(e, msg, r, ctx) -> - let errno = error_number (lookup e) in - Some (mk_issue EError (Some r) msg (Some errno) ctx) - | _ -> None - -let err_exn exn = - if exn = Stop then () - else - match issue_of_exn exn with - | Some issue -> add_one issue - | None -> raise exn - -let handleable = function - | Error _ - | Stop -> true - | _ -> false - -let stop_if_err () = - if get_err_count () > 0 - then raise Stop - -let with_ctx (s:string) (f : unit -> 'a) : 'a = - error_context.push s; - let r = - (* If we're debugging the failure, don't do anything, - * since catching and rethrowing the exception will change - * the stack trace. We still push the context though. *) - if Options.trace_error () - then Inr (f ()) - else - try - Inr (f ()) - with - (* Adding context to `failwith`, though it will be printed badly. - * TODO: deprecate failwith and use F* exceptions, which we can - * then catch and print sensibly. *) - | Failure msg -> - Inl (Failure (msg ^ rendermsg [ctx_doc (error_context.get ())])) - | ex -> Inl ex - in - ignore (error_context.pop ()); - match r with - | Inr r -> r - | Inl e -> raise e - -let with_ctx_if (b:bool) (s:string) (f : unit -> 'a) : 'a = - if b then - with_ctx s f - else - f () - -// -// returns errors, other issues, result if any -// restores handler back -// -let catch_errors_aux (f : unit -> 'a) : list issue & list issue & option 'a = - let newh = mk_default_handler false in - let old = !current_handler in - current_handler := newh; - let finally_restore () = - let all_issues = newh.eh_report() in //de-duplicated already - current_handler := old; - let errs, rest = List.partition (fun i -> i.issue_level = EError) all_issues in - errs, rest - in - let r = try Some (f ()) - with - | ex when handleable ex -> - err_exn ex; - None - | ex -> - let _ = finally_restore() in - raise ex - in - let errs, rest = finally_restore() in - errs, rest, r - -let no_ctx (f : unit -> 'a) : 'a = - let save = error_context.get () in - error_context.clear (); - let res = f () in - error_context.set save; - res - -let catch_errors (f : unit -> 'a) : list issue & option 'a = - let errs, rest, r = catch_errors_aux f in - List.iter (!current_handler).eh_add_one rest; - errs, r - -// -// Similar to catch_errors, except the warnings are not added to the old handler -// -let catch_errors_and_ignore_rest (f:unit -> 'a) : list issue & option 'a = - let errs, rest, r = catch_errors_aux f in - List.iter (!current_handler).eh_add_one <| List.filter (fun i -> i.issue_level = EInfo) rest; - (* ^ We print diagnostics anyway, which are usually debugging messages to be rendered - in the editor. *) - errs, r - -(* Finds a discrepancy between two multisets of ints. Result is (elem, amount1, amount2) - * eg. find_multiset_discrepancy [1;1;3;5] [1;1;3;3;4;5] = Some (3, 1, 2) - * since 3 appears 1 time in l1, but 2 times in l2. *) -let find_multiset_discrepancy (l1 : list int) (l2 : list int) : option (int & int & int) = - let sort = List.sortWith (fun x y -> x - y) in - let rec collect (l : list 'a) : list ('a & int) = - match l with - | [] -> [] - | hd :: tl -> - begin match collect tl with - | [] -> [(hd, 1)] - | (h, n) :: t -> - if h = hd - then (h, n+1) :: t - else (hd, 1) :: (h, n) :: t - end - in - let l1 = collect (sort l1) in - let l2 = collect (sort l2) in - let rec aux l1 l2 = - match l1, l2 with - | [], [] -> None - - | (e, n) :: _, [] -> - Some (e, n, 0) - - | [], (e, n) :: _ -> - Some (e, 0, n) - - | (hd1, n1) :: tl1, (hd2, n2) :: tl2 -> - if hd1 < hd2 then - Some (hd1, n1, 0) - else if hd1 > hd2 then - Some (hd2, 0, n2) - else if n1 <> n2 then - Some (hd1, n1, n2) - else aux tl1 tl2 - in - aux l1 l2 - -let raise_error_doc rng code msg = raise_error rng code msg -let log_issue_doc rng code msg = log_issue rng code msg -let raise_error_text rng code msg = raise_error rng code msg -let log_issue_text rng code msg = log_issue rng code msg diff --git a/src/basic/FStar.Errors.fsti b/src/basic/FStar.Errors.fsti deleted file mode 100644 index a99b4ebd9d3..00000000000 --- a/src/basic/FStar.Errors.fsti +++ /dev/null @@ -1,195 +0,0 @@ -(* - Copyright 2008-2020 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Errors - -module Range = FStar.Compiler.Range - -include FStar.Errors.Codes -include FStar.Errors.Msg -open FStar.Errors.Msg -open FStar.Class.HasRange -open FStar.Json {json} - -(* This is a fallback to be used if an error is raised/logged -with a dummy range. It is set by TypeChecker.Tc.process_one_decl to -the range of the sigelt being checked. *) -val fallback_range : FStar.Compiler.Effect.ref (option Range.range) - -(* This range, if set, will be used to limit the range of every -issue that is logged/raised. This is set, e.g. when checking a top-level -definition, to the range of the definition, so no error can be reported -outside of it. *) -val error_range_bound : FStar.Compiler.Effect.ref (option Range.range) - -val with_error_bound (r:Range.range) (f : unit -> 'a) : 'a - -(* Get the error number for a particular code. Useful for creating error -messages mentioning --warn_error. *) -val errno : error_code -> int - -(* Particular errors code numbers, useful to build helpful error messages *) -val warn_on_use_errno : int -val defensive_errno : int -val call_to_erased_errno : int - -val update_flags : list (error_flag & string) -> list error_setting - -(* error code, message, source position, and error context *) -type error = error_code & error_message & FStar.Compiler.Range.range & list string - -exception Error of error -exception Warning of error -exception Stop -exception Empty_frag - -type issue_level = - | ENotImplemented - | EInfo - | EWarning - | EError - -val json_of_issue_level: issue_level -> json - -type issue = { - issue_msg: error_message; - issue_level: issue_level; - issue_range: option Range.range; - issue_number: option int; - issue_ctx: list string; -} - -val json_of_issue: issue -> json - -type error_handler = { - eh_name: string; (* just for debugging purposes *) - eh_add_one: issue -> unit; - eh_count_errors: unit -> int; - eh_report: unit -> list issue; - eh_clear: unit -> unit -} - -val string_of_issue_level : issue_level -> string -val issue_level_of_string : string -> issue_level -val issue_message : issue -> error_message -val format_issue' : bool -> issue -> string -val format_issue : issue -> string -val error_number : error_setting -> int -val print_issue : issue -> unit -val compare_issues : issue -> issue -> int // for sorting.. weird - -val add_errors : list error -> unit -val issue_of_exn : exn -> option issue - -val default_handler : error_handler - -val get_err_count : unit -> int -val report_all : unit -> list issue -val clear : unit -> unit -val set_handler : error_handler -> unit -val get_ctx : unit -> list string - -val set_option_warning_callback_range : ropt:option FStar.Compiler.Range.range -> unit -val set_parse_warn_error : (string -> list error_setting) -> unit - -val lookup : error_code -> error_setting - -val err_exn : exn -> unit -val handleable : exn -> bool - -(* If any error was logged, then stop the program (raising a Stop -exception). This is useful, for instance, to not run tactics in a given -top-level definition if a typechecking error was already logged, since -that may imply that the tactic will crash or loop. *) -val stop_if_err : unit -> unit - -(* Log an error/warning/etc. This does not raise an exception. Do not -use this for any CFatal error. *) - -(* Log an issue directly, rather than converting it from a error_code etc. - This does not raise an exception. Do not use this for any CFatal error. *) -val add_issues : list issue -> unit - -(* An info message. Calling this function triggers the printing immediately. *) -val info - (#pos_t:Type) {| hasRange pos_t |} (pos : pos_t) // A "position", of any type with a range - (#msg_t:_) {| is_error_message msg_t |} (msg : msg_t) // A "message", currently can be a 'string' or 'list document' - : unit - -(* A "diagnostic" message. It is the same as info, but only printed some kind of debugging is enabled. *) -val diag - (#pos_t:Type) {| hasRange pos_t |} (pos : pos_t) // A "position", of any type with a range - (#msg_t:_) {| is_error_message msg_t |} (msg : msg_t) // A "message", currently can be a 'string' or 'list document' - : unit - -val raise_error - (#pos_t:Type) {| hasRange pos_t |} (pos : pos_t) // A "position", of any type with a range - (code : error_code) // An error code - (#msg_t:_) {| is_error_message msg_t |} (msg : msg_t) // A "message", currently can be a 'string' or 'list document' - : 'a - -val log_issue - (#pos_t:Type) {| hasRange pos_t |} (pos : pos_t) // A "position", of any type with a range - (code : error_code) // An error code - (#msg_t:_) {| is_error_message msg_t |} (msg : msg_t) // A "message", currently can be a 'string' or 'list document' - : unit - -val raise_error0 : error_code -> #t:_ -> {| is_error_message t |} -> t -> 'a -val log_issue0 : error_code -> #t:_ -> {| is_error_message t |} -> t -> unit -val diag0 : #t:_ -> {| is_error_message t |} -> t -> unit - - -(* Run a function f inside an extended "error context", so its errors -are prefixed by the messages of each enclosing with_ctx. Only visible -when --error_contexts true is given. *) -val with_ctx : ctx:string -> (f : unit -> 'a) -> 'a - -(* As above, but only add the context conditionally. *) -val with_ctx_if : cond:bool -> ctx:string -> (f : unit -> 'a) -> 'a - -(* Delete all error contexts for this comp. *) -val no_ctx : (f : unit -> 'a) -> 'a - -(* Run a given function and return its result (if any) and the full list of -issues it logged/raised. *) -val catch_errors : (unit -> 'a) -> list issue & option 'a - - -(* Similar to catch_errors, except the warnings are not added to the old handler *) -val catch_errors_and_ignore_rest (f:unit -> 'a) : list issue & option 'a - - - - - - - - - - -(* TODO: Find a better home? *) -(* Finds a discrepancy between two multisets of ints. Result is (elem, amount1, amount2) - * eg. find_multiset_discrepancy [1;1;3;5] [1;1;3;3;4;5] = Some (3, 1, 2) - * since 3 appears 1 time in l1, but 2 times in l2. *) -val find_multiset_discrepancy : list int -> list int -> option (int & int & int) - - - -(* Specialized variants, only useful for OCaml code. Not to be used from F* sources. *) -val raise_error_doc : Range.range -> error_code -> error_message -> 'a -val log_issue_doc : Range.range -> error_code -> error_message -> unit -val raise_error_text : Range.range -> error_code -> string -> 'a -val log_issue_text : Range.range -> error_code -> string -> unit diff --git a/src/basic/FStar.Find.fst b/src/basic/FStar.Find.fst deleted file mode 100644 index 2b1ebbe541b..00000000000 --- a/src/basic/FStar.Find.fst +++ /dev/null @@ -1,50 +0,0 @@ -(* - Copyright 2008-2024 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Find - -open FStar -open FStar.Compiler.List -module BU = FStar.Compiler.Util - -let find_file = - let file_map = BU.smap_create 100 in - fun filename -> - match BU.smap_try_find file_map filename with - | Some f -> f - | None -> - let result = - (try - if BU.is_path_absolute filename then - if BU.file_exists filename then - Some filename - else - None - else - (* In reverse, because the last directory has the highest precedence. *) - BU.find_map (List.rev (Options.include_path ())) (fun p -> - let path = - if p = "." then filename - else BU.join_paths p filename in - if BU.file_exists path then - Some path - else - None) - with | _ -> //to deal with issues like passing bogus strings as paths like " input" - None) - in - if Some? result - then BU.smap_add file_map filename result; - result diff --git a/src/basic/FStar.Find.fsti b/src/basic/FStar.Find.fsti deleted file mode 100644 index c675e332864..00000000000 --- a/src/basic/FStar.Find.fsti +++ /dev/null @@ -1,21 +0,0 @@ -(* - Copyright 2008-2024 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Find - -open FStar.Compiler.Effect - -(* Try to find a file in the include path with a given basename. *) -val find_file (basename : string) : option string diff --git a/src/basic/FStar.GenSym.fst b/src/basic/FStar.GenSym.fst deleted file mode 100644 index ae3aca9b726..00000000000 --- a/src/basic/FStar.GenSym.fst +++ /dev/null @@ -1,22 +0,0 @@ -module FStar.GenSym - -module Util = FStar.Compiler.Util - -(* private *) -let gensym_st = Util.mk_ref 0 - -let next_id () = - let r = !gensym_st in - gensym_st := r + 1; - r - -let reset_gensym () = gensym_st := 0 - -let with_frozen_gensym f = - let v = !gensym_st in - let r = - try f () with - | e -> (gensym_st := v; raise e) - in - gensym_st := v; - r diff --git a/src/basic/FStar.GenSym.fsti b/src/basic/FStar.GenSym.fsti deleted file mode 100644 index a2087f7695f..00000000000 --- a/src/basic/FStar.GenSym.fsti +++ /dev/null @@ -1,33 +0,0 @@ -(* - Copyright 2008-2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -(* - A simple fresh symbol generator (gensym). -*) -module FStar.GenSym - -open FStar.Compiler.Effect - -(** Obtain a fresh ID. *) -val next_id : unit -> int - -(** Reset the gensym. Names generated will not be fresh with respect to -names generated before the reset. Should be used only when it is known -that freshness across resets is not needed. *) -val reset_gensym : unit -> unit - -(** Do something without affecting the gensym. Useful e.g. for printing, -to make sure there's no side effect. *) -val with_frozen_gensym : (unit -> 'a) -> 'a diff --git a/src/basic/FStar.Getopt.fsti b/src/basic/FStar.Getopt.fsti deleted file mode 100644 index a3a2310547a..00000000000 --- a/src/basic/FStar.Getopt.fsti +++ /dev/null @@ -1,38 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Getopt -open FStar.Compiler.Effect -open FStar.BaseTypes - -val noshort : char -val nolong : string -type opt_variant 'a = - | ZeroArgs of (unit -> 'a) - | OneArg of (string -> 'a) & string - -type opt' 'a = char & string & opt_variant 'a -type opt = opt' unit - -type parse_cmdline_res = - | Empty - | Help - | Error of string - | Success - -val parse_cmdline: list opt -> (string -> parse_cmdline_res) -> parse_cmdline_res -val parse_string: list opt -> (string -> parse_cmdline_res) -> string -> parse_cmdline_res -val parse_list: list opt -> (string -> parse_cmdline_res) -> list string -> parse_cmdline_res -val cmdline: unit -> list string diff --git a/src/basic/FStar.Hash.fsti b/src/basic/FStar.Hash.fsti deleted file mode 100644 index fc019906319..00000000000 --- a/src/basic/FStar.Hash.fsti +++ /dev/null @@ -1,11 +0,0 @@ -module FStar.Hash -open FStar.Compiler.Effect - -type hash_code - -val cmp_hash (_ _ : hash_code) : int - -val of_int : int -> hash_code -val of_string : string -> hash_code -val mix : hash_code -> hash_code -> hash_code -val string_of_hash_code : hash_code -> string diff --git a/src/basic/FStar.Ident.fst b/src/basic/FStar.Ident.fst deleted file mode 100644 index 318bae9c6c0..00000000000 --- a/src/basic/FStar.Ident.fst +++ /dev/null @@ -1,98 +0,0 @@ -module FStar.Ident - -open Prims -open FStar.Compiler.Effect -open FStar.Compiler.Range -open FStar.Compiler.List -module List = FStar.Compiler.List -module Util = FStar.Compiler.Util -module GS = FStar.GenSym - -[@@ PpxDerivingYoJson; PpxDerivingShow ] -type ident = {idText:string; - idRange:range} - -[@@ PpxDerivingYoJson; PpxDerivingShow ] -type lident = {ns:ipath; //["FStar"; "Basic"] - ident:ident; //"lident" - nsstr:string; // Cached version of the namespace - str:string} // Cached version of string_of_lid - -let mk_ident (text,range) = {idText=text; idRange=range} - -let set_id_range r i = { i with idRange=r } - -let reserved_prefix = "uu___" - -let gen' s r = - let i = GS.next_id() in - mk_ident (s ^ string_of_int i, r) - -let gen r = gen' reserved_prefix r - -let ident_of_lid l = l.ident - -let range_of_id (id:ident) = id.idRange -let id_of_text str = mk_ident(str, dummyRange) -let string_of_id (id:ident) = id.idText -let text_of_path path = Util.concat_l "." path -let path_of_text text = String.split ['.'] text -let path_of_ns ns = List.map string_of_id ns -let path_of_lid lid = List.map string_of_id (lid.ns@[lid.ident]) -let ns_of_lid lid = lid.ns -let ids_of_lid lid = lid.ns@[lid.ident] -let lid_of_ns_and_id ns id = - let nsstr = List.map string_of_id ns |> text_of_path in - {ns=ns; - ident=id; - nsstr=nsstr; - str=(if nsstr="" then id.idText else nsstr ^ "." ^ id.idText)} -let lid_of_ids ids = - let ns, id = Util.prefix ids in - lid_of_ns_and_id ns id -let lid_of_str str = - lid_of_ids (List.map id_of_text (Util.split str ".")) -let lid_of_path path pos = - let ids = List.map (fun s -> mk_ident(s, pos)) path in - lid_of_ids ids -let text_of_lid lid = lid.str -let lid_equals l1 l2 = l1.str = l2.str -let ident_equals id1 id2 = id1.idText = id2.idText -let range_of_lid (lid:lid) = range_of_id lid.ident -let set_lid_range l r = {l with ident={l.ident with idRange=r}} -let lid_add_suffix l s = - let path = path_of_lid l in - lid_of_path (path@[s]) (range_of_lid l) - -let ml_path_of_lid lid = - String.concat "_" <| (path_of_ns lid.ns)@[string_of_id lid.ident] - -let string_of_lid lid = lid.str - -let qual_id lid id = - set_lid_range (lid_of_ids (lid.ns @ [lid.ident;id])) (range_of_id id) - -let nsstr (l:lid) : string = l.nsstr - -instance showable_ident = { - show = string_of_id; -} -instance showable_lident = { - show = string_of_lid; -} -let pretty_ident = pretty_from_showable -let pretty_lident = pretty_from_showable -instance hasrange_ident = { - pos = range_of_id; - setPos = (fun rng id -> { id with idRange = rng }); -} -instance hasrange_lident = { - pos = (fun lid -> Class.HasRange.pos lid.ident); - setPos = (fun rng id -> { id with ident = setPos rng id.ident }); -} -instance deq_ident = { - (=?) = ident_equals; -} -instance deq_lident = { - (=?) = lid_equals; -} diff --git a/src/basic/FStar.Ident.fsti b/src/basic/FStar.Ident.fsti deleted file mode 100644 index 0d9b4c63089..00000000000 --- a/src/basic/FStar.Ident.fsti +++ /dev/null @@ -1,146 +0,0 @@ -(* - Copyright 2008-2014 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Ident - -open FStar.Compiler.Range -open FStar.Class.Show -open FStar.Class.HasRange -open FStar.Class.Deq -open FStar.Class.PP - -(** A (short) identifier for a local name. - * e.g. x in `fun x -> ...` *) -[@@ PpxDerivingYoJson; PpxDerivingShow ] -new val ident : Type0 - -// type ident - -(** A module path *) -[@@ PpxDerivingYoJson; PpxDerivingShow ] -type path = list string - -(** A module path, as idents *) -[@@ PpxDerivingYoJson; PpxDerivingShow ] -type ipath = list ident - -(** Create an ident *) -val mk_ident : (string & range) -> ident - -(** Obtain the range of an ident *) -val range_of_id : ident -> range - -(** Create an ident with a dummyRange (avoid if possible) *) -val id_of_text : string -> ident - -(** The prefix for reserved identifiers *) -val reserved_prefix : string - -(** Set the range on an ident *) -val set_id_range : range -> ident -> ident - -(** Equality of idents *) -val ident_equals : ident -> ident -> bool - -(** Print an ident *) -val string_of_id : ident -> string - -(** Generating fresh names, uses GenSym. *) -val gen' : string -> range -> ident -val gen : range -> ident - -(** Turn a string of shape A.B.C into a path *) -val path_of_text : string -> path - -(** Turn a namespace, a list of idents, into a path *) -val path_of_ns : ipath -> path - - - - - -(** A long identifier for top-level, fully-qualified names. - e.g. Prims.string. Essentially a list of idents where - the last one denotes a name, and all the others denote a - module path that qualifies the name. *) -[@@ PpxDerivingYoJson; PpxDerivingShow ] -new val lident : Type0 - -[@@ PpxDerivingYoJson; PpxDerivingShow ] -type lid = lident - -(** Obtain the range of an lid *) -val range_of_lid : lident -> range - -(* Return the name in an lid *) -val ident_of_lid : lident -> ident - -(** Equality of lidents *) -val lid_equals : lident -> lident -> bool - -(** Turn an lid into a path *) -val path_of_lid : lident -> path - -(** Return an lid as a path (containing the name itself). - e.g. ids_of_lid Prims.string = [Prims; string] *) -val ids_of_lid : lident -> ipath - -(** Return the namespace of an lid (not including its name). - e.g. ns_of_lid Prims.string = [Prims] *) -val ns_of_lid : lident -> ipath - -(** Create an lid from a ipath and a name *) -val lid_of_ns_and_id : ipath -> ident -> lident - -(** Create an lid from a ipath (last ident is the name) *) -val lid_of_ids : ipath -> lident - -(** Create an lid from a string, separating it by "." *) -val lid_of_str : string -> lident - -(** Create an lid from a (string) path and a range *) -val lid_of_path : path -> range -> lident - -(** Set the range on an lid *) -val set_lid_range : lident -> range -> lident - -(** Add a component to an lid *) -val lid_add_suffix : lident -> string -> lident - -(** Qualify an ident by a module. Similar to lid_add_suffix, but the - range is taken from the ident instead. *) -val qual_id : lident -> ident -> lident - -(** Print an lid. This is O(1). *) -val string_of_lid : lident -> string - -(** Print the namespace portion of an lid. This is O(1). *) -val nsstr : lident -> string - -(** Print a path as A.B.C *) -val text_of_path : path -> string - -(* Similar to string_of_lid, but separates with "_" instead of "." *) -val ml_path_of_lid : lident -> string - -(* Showable instances *) -instance val showable_ident : showable ident -instance val showable_lident : showable lident -instance val pretty_ident : pretty ident -instance val pretty_lident : pretty lident -instance val hasrange_ident : hasRange ident -instance val hasrange_lident : hasRange lident -instance val deq_ident : deq ident -instance val deq_lident : deq lident diff --git a/src/basic/FStar.Json.fsti b/src/basic/FStar.Json.fsti deleted file mode 100644 index 94f3f3070ca..00000000000 --- a/src/basic/FStar.Json.fsti +++ /dev/null @@ -1,29 +0,0 @@ -(* - Copyright 2008-2023 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Json - -open FStar.Compiler.Effect - -type json = -| JsonNull -| JsonBool of bool -| JsonInt of int -| JsonStr of string -| JsonList of list json -| JsonAssoc of list (string & json) - -val json_of_string : string -> option json -val string_of_json : json -> string diff --git a/src/basic/FStar.Options.Ext.fst b/src/basic/FStar.Options.Ext.fst deleted file mode 100644 index 513220713a4..00000000000 --- a/src/basic/FStar.Options.Ext.fst +++ /dev/null @@ -1,70 +0,0 @@ -(* - Copyright 2008-2024 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Options.Ext - -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Class.Show -module BU = FStar.Compiler.Util - -type ext_state = - | E : map : BU.psmap string -> ext_state - -let cur_state = BU.mk_ref (E (BU.psmap_empty ())) - -(* Set a key-value pair in the map *) -let set (k:key) (v:value) : unit = - cur_state := E (BU.psmap_add (!cur_state).map k v) - -(* Get the value from the map, or return "" if not there *) -let get (k:key) : value = - let r = - match BU.psmap_try_find (!cur_state).map k with - | None -> "" - | Some v -> v - in - r - -(* Find a home *) -let is_prefix (s1 s2 : string) : ML bool = - let open FStar.Compiler.String in - let l1 = length s1 in - let l2 = length s2 in - l2 >= l1 && substring s2 0 l1 = s1 - -(* Get a list of all KV pairs that "begin" with k, considered -as a namespace. *) -let getns (ns:string) : list (key & value) = - let f k v acc = - if (ns^":") `is_prefix` k - then (k, v) :: acc - else acc - in - BU.psmap_fold (!cur_state).map f [] - -let all () : list (key & value) = - let f k v acc = (k, v) :: acc in - BU.psmap_fold (!cur_state).map f [] - -let save () : ext_state = - !cur_state - -let restore (s:ext_state) : unit = - cur_state := s; - () - -let reset () : unit = - cur_state := E (BU.psmap_empty ()) diff --git a/src/basic/FStar.Options.Ext.fsti b/src/basic/FStar.Options.Ext.fsti deleted file mode 100644 index bed8dda6d90..00000000000 --- a/src/basic/FStar.Options.Ext.fsti +++ /dev/null @@ -1,42 +0,0 @@ -(* - Copyright 2008-2024 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Options.Ext - -open FStar.Compiler.Effect - -type key = string -type value = string - -new -val ext_state : Type0 - -(* Set a key-value pair in the map *) -val set (k:key) (v:value) : unit - -(* Get the value from the map, or return "" if not there *) -val get (k:key) : value - -(* Get a list of all KV pairs that "begin" with k, considered -as a namespace. *) -val getns (ns:string) : list (key & value) - -(* List all pairs *) -val all () : list (key & value) - -val save () : ext_state -val restore (s:ext_state) : unit - -val reset () : unit diff --git a/src/basic/FStar.Options.fst b/src/basic/FStar.Options.fst deleted file mode 100644 index 22dca285a5c..00000000000 --- a/src/basic/FStar.Options.fst +++ /dev/null @@ -1,2467 +0,0 @@ -(* - Copyright 2008-2020 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Options - -open FStar -open FStar.BaseTypes -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Compiler.String -open FStar.Compiler.Util -open FStar.Getopt -open FStar.Pervasives -open FStar.VConfig -open FStar.Class.Show -open FStar.Class.Deq - -module Option = FStar.Compiler.Option -module FC = FStar.Common -module Util = FStar.Compiler.Util -module List = FStar.Compiler.List - -module Ext = FStar.Options.Ext - -let debug_embedding = mk_ref false -let eager_embedding = mk_ref false - -(* A FLAG TO INDICATE THAT WE'RE RUNNING UNIT TESTS *) -let __unit_tests__ = Util.mk_ref false -let __unit_tests() = !__unit_tests__ -let __set_unit_tests () = __unit_tests__ := true -let __clear_unit_tests () = __unit_tests__ := false - -let as_bool = function - | Bool b -> b - | _ -> failwith "Impos: expected Bool" -let as_int = function - | Int b -> b - | _ -> failwith "Impos: expected Int" -let as_string = function - | String b -> b - | Path b -> FStar.Common.try_convert_file_name_to_mixed b - | _ -> failwith "Impos: expected String" -let as_list' = function - | List ts -> ts - | _ -> failwith "Impos: expected List" -let as_list as_t x = - as_list' x |> List.map as_t -let as_option as_t = function - | Unset -> None - | v -> Some (as_t v) -let as_comma_string_list = function - | List ls -> List.flatten <| List.map (fun l -> split (as_string l) ",") ls - | _ -> failwith "Impos: expected String (comma list)" - -let copy_optionstate m = Util.smap_copy m - -(* The option state is a stack of stacks. Why? First, we need to - * support #push-options and #pop-options, which provide the user with - * a stack-like option control, useful for rlimits and whatnot. Second, - * there's the interactive mode, which allows to traverse a file and - * backtrack over it, and must update this state accordingly. So for - * instance consider the following code: - * - * 1. #push-options "A" - * 2. let f = ... - * 3. #pop-options - * - * Running in batch mode starts with a singleton stack, then pushes, - * then pops. In the interactive mode, say we go over line 1. Then - * our current state is a stack with two elements (original state and - * state+"A"), but we need the previous state too to backtrack if we run - * C-c C-p or whatever. We can also go over line 3, and still we need - * to keep track of everything to backtrack. After processing the lines - * one-by-one in the interactive mode, the stacks are: (top at the head) - * - * (orig) - * (orig + A) (orig) - * (orig) - * - * No stack should ever be empty! Any of these failwiths should never be - * triggered externally. IOW, the API should protect this invariant. - * - * We also keep a snapshot of the Debug module's state. - *) -let history1 = Debug.saved_state & Ext.ext_state & optionstate - -let fstar_options : ref optionstate = Util.mk_ref (Util.psmap_empty ()) - -let history : ref (list (list history1)) = - Util.mk_ref [] // IRRELEVANT: see clear() below - -let peek () = !fstar_options - -let internal_push () = - let lev1::rest = !history in - let newhd = (Debug.snapshot (), Ext.save (), !fstar_options) in - history := (newhd :: lev1) :: rest - -let internal_pop () = - let lev1::rest = !history in - match lev1 with - | [] -> false - | (dbg, ext, opts)::lev1' -> - Debug.restore dbg; - Ext.restore ext; - fstar_options := opts; - history := lev1' :: rest; - true - -let push () = // already signal-atomic - (* This turns a stack like - - 4 - 3 - 2 1 current:5 - into: - 5 - 4 4 - 3 3 - 2 2 1 current:5 - - i.e. current state does not change, and - current minor stack does not change. The - "next" previous stack (now with 2,3,4,5) - has a copy of 5 at the top so we can restore regardless - of what we do in the current stack or the current state. *) - - internal_push (); - let lev1::_ = !history in - history := lev1 :: !history; - ignore (internal_pop()); - () - -let pop () = // already signal-atomic - match !history with - | [] -> failwith "TOO MANY POPS!" - | _::levs -> - history := levs; - if not (internal_pop ()) then - failwith "aaa!!!" - -let set o = - fstar_options := o - -let depth () = - let lev::_ = !history in - List.length lev - -let snapshot () = Common.snapshot push history () -let rollback depth = Common.rollback pop history depth - -let set_option k v = - let map : optionstate = peek() in - if k = "report_assumes" - then match Util.psmap_try_find map k with - | Some (String "error") -> - //It's already set to error; ignore any attempt to change it - () - | _ -> fstar_options := Util.psmap_add map k v - else fstar_options := Util.psmap_add map k v - -let set_option' (k,v) = set_option k v -let set_admit_smt_queries (b:bool) = set_option "admit_smt_queries" (Bool b) - -let defaults = - [ - ("abort_on" , Int 0); - ("admit_smt_queries" , Bool false); - ("admit_except" , Unset); - ("disallow_unification_guards" , Bool false); - ("already_cached" , Unset); - ("cache_checked_modules" , Bool false); - ("cache_dir" , Unset); - ("cache_off" , Bool false); - ("compat_pre_core" , Unset); - ("compat_pre_typed_indexed_effects" - , Bool false); - ("print_cache_version" , Bool false); - ("cmi" , Bool false); - ("codegen" , Unset); - ("codegen-lib" , List []); - ("defensive" , String "no"); - ("debug" , List []); - ("debug_all" , Bool false); - ("debug_all_modules" , Bool false); - ("dep" , Unset); - ("detail_errors" , Bool false); - ("detail_hint_replay" , Bool false); - ("dump_module" , List []); - ("eager_subtyping" , Bool false); - ("error_contexts" , Bool false); - ("expose_interfaces" , Bool false); - ("message_format" , String "human"); - ("ext" , Unset); - ("extract" , Unset); - ("extract_all" , Bool false); - ("extract_module" , List []); - ("extract_namespace" , List []); - ("full_context_dependency" , Bool true); - ("hide_uvar_nums" , Bool false); - ("hint_hook" , Unset); - ("hint_info" , Bool false); - ("hint_dir" , Unset); - ("hint_file" , Unset); - ("in" , Bool false); - ("ide" , Bool false); - ("ide_id_info_off" , Bool false); - ("lsp" , Bool false); - ("include" , List []); - ("print" , Bool false); - ("print_in_place" , Bool false); - ("force" , Bool false); - ("fuel" , Unset); - ("ifuel" , Unset); - ("initial_fuel" , Int 2); - ("initial_ifuel" , Int 1); - ("keep_query_captions" , Bool true); - ("lax" , Bool false); - ("load" , List []); - ("load_cmxs" , List []); - ("log_queries" , Bool false); - ("log_failing_queries" , Bool false); - ("log_types" , Bool false); - ("max_fuel" , Int 8); - ("max_ifuel" , Int 2); - ("MLish" , Bool false); - ("MLish_effect" , String "FStar.Compiler.Effect"); - ("no_default_includes" , Bool false); - ("no_extract" , List []); - ("no_location_info" , Bool false); - ("no_smt" , Bool false); - ("no_plugins" , Bool false); - ("no_tactics" , Bool false); - ("normalize_pure_terms_for_extraction" - , Bool false); - ("krmloutput" , Unset); - ("odir" , Unset); - ("output_deps_to" , Unset); - ("prims" , Unset); - ("pretype" , Bool true); - ("prims_ref" , Unset); - ("print_bound_var_types" , Bool false); - ("print_effect_args" , Bool false); - ("print_expected_failures" , Bool false); - ("print_full_names" , Bool false); - ("print_implicits" , Bool false); - ("print_universes" , Bool false); - ("print_z3_statistics" , Bool false); - ("prn" , Bool false); - ("proof_recovery" , Bool false); - ("quake" , Int 0); - ("quake_lo" , Int 1); - ("quake_hi" , Int 1); - ("quake_keep" , Bool false); - ("query_cache" , Bool false); - ("query_stats" , Bool false); - ("read_checked_file" , Unset); - ("list_plugins" , Bool false); - ("locate" , Bool false); - ("locate_lib" , Bool false); - ("locate_ocaml" , Bool false); - ("read_krml_file" , Unset); - ("record_hints" , Bool false); - ("record_options" , Bool false); - ("report_assumes" , Unset); - ("retry" , Bool false); - ("reuse_hint_for" , Unset); - ("silent" , Bool false); - ("smt" , Unset); - ("smtencoding.elim_box" , Bool false); - ("smtencoding.nl_arith_repr" , String "boxwrap"); - ("smtencoding.l_arith_repr" , String "boxwrap"); - ("smtencoding.valid_intro" , Bool true); - ("smtencoding.valid_elim" , Bool false); - ("split_queries" , String "on_failure"); - ("tactics_failhard" , Bool false); - ("tactics_info" , Bool false); - ("tactic_raw_binders" , Bool false); - ("tactic_trace" , Bool false); - ("tactic_trace_d" , Int 0); - - ("tcnorm" , Bool true); - ("timing" , Bool false); - ("trace_error" , Bool false); - ("ugly" , Bool false); - ("unthrottle_inductives" , Bool false); - ("unsafe_tactic_exec" , Bool false); - ("use_native_tactics" , Unset); - ("use_eq_at_higher_order" , Bool false); - ("use_hints" , Bool false); - ("use_hint_hashes" , Bool false); - ("using_facts_from" , Unset); - ("verify_module" , List []); - ("warn_default_effects" , Bool false); - ("z3refresh" , Bool false); - ("z3rlimit" , Int 5); - ("z3rlimit_factor" , Int 1); - ("z3seed" , Int 0); - ("z3cliopt" , List []); - ("z3smtopt" , List []); - ("z3version" , String "4.8.5"); - ("__no_positivity" , Bool false); - ("__tactics_nbe" , Bool false); - ("warn_error" , List []); - ("use_nbe" , Bool false); - ("use_nbe_for_extraction" , Bool false); - ("trivial_pre_for_unannotated_effectful_fns" - , Bool true); - ("profile_group_by_decl" , Bool false); - ("profile_component" , Unset); - ("profile" , Unset); - ] - -let init () = - Debug.disable_all (); - Ext.reset (); - fstar_options := Util.psmap_empty (); - defaults |> List.iter set_option' //initialize it with the default values - -let clear () = - history := [[]]; - init() - -(* Run it now. *) -let _ = clear () - -let get_option s = - match Util.psmap_try_find (peek ()) s with - | None -> failwith ("Impossible: option " ^s^ " not found") - | Some s -> s - -let rec option_val_to_string (v:option_val) : string = - match v with - | Bool b -> "Bool " ^ show b - | String s -> "String " ^ show s - | Path s -> "Path " ^ show s - | Int i -> "Int " ^ show i - | List vs -> "List " ^ Common.string_of_list option_val_to_string vs - | Unset -> "Unset" - -instance showable_option_val : showable option_val = { - show = option_val_to_string; -} - -let rec eq_option_val (v1 v2 : option_val) : bool = - match v1, v2 with - | Bool x1, Bool x2 - | String x1, String x2 - | Path x1, Path x2 - | Int x1, Int x2 -> x1 =? x2 - | Unset, Unset -> true - | List x1, List x2 -> - Common.eq_list eq_option_val x1 x2 - | _, _ -> false - -instance deq_option_val : deq option_val = { - (=?) = eq_option_val; -} - -let rec list_try_find #a #b {| deq a |} (k : a) (l : list (a & b)) -: option b -= - match l with - | [] -> None - | (k', v') :: l' -> - if k =? k' - then Some v' - else list_try_find k l' - -let show_options () = - let s = peek () in - let kvs : list (string & option_val) = - let open FStar.Class.Monad in - let! k = Common.psmap_keys s in - (* verify_module is only set internally. *) - if k = "verify_module" then [] else - let v = must <| psmap_try_find s k in - let v0 = list_try_find k defaults in - if v0 =? Some v then - [] - else - return (k, v) - in - let rec show_optionval v = - match v with - | String s -> "\"" ^ s ^ "\"" // FIXME: proper escape - | Bool b -> show b - | Int i -> show i - | Path s -> s - | List s -> List.map show_optionval s |> String.concat "," - | Unset -> "" - in - let show1 (k, v) = - Util.format2 "--%s %s" k (show_optionval v) - in - kvs |> List.map show1 |> String.concat "\n" - -let set_verification_options o = - (* This are all the options restored when processing a check_with - attribute. All others are unchanged. We do this for two reasons: - 1) It's unsafe to just set everything (e.g. verify_module would - cause lax verification, so we need to filter some stuff out). - 2) So we don't propagate meaningless debugging options, which - is probably not intended. - *) - let verifopts = [ - "initial_fuel"; - "max_fuel"; - "initial_ifuel"; - "max_ifuel"; - "detail_errors"; - "detail_hint_replay"; - "no_smt"; - "quake"; - "retry"; - "smtencoding.elim_box"; - "smtencoding.nl_arith_repr"; - "smtencoding.l_arith_repr"; - "smtencoding.valid_intro"; - "smtencoding.valid_elim"; - "tcnorm"; - "no_plugins"; - "no_tactics"; - "z3cliopt"; - "z3smtopt"; - "z3refresh"; - "z3rlimit"; - "z3rlimit_factor"; - "z3seed"; - "z3version"; - "trivial_pre_for_unannotated_effectful_fns"; - ] in - List.iter (fun k -> set_option k (Util.psmap_try_find o k |> Util.must)) verifopts - -let lookup_opt s c = - c (get_option s) - -let get_abort_on () = lookup_opt "abort_on" as_int -let get_admit_smt_queries () = lookup_opt "admit_smt_queries" as_bool -let get_admit_except () = lookup_opt "admit_except" (as_option as_string) -let get_compat_pre_core () = lookup_opt "compat_pre_core" (as_option as_int) - -let get_compat_pre_typed_indexed_effects () = lookup_opt "compat_pre_typed_indexed_effects" as_bool -let get_disallow_unification_guards () = lookup_opt "disallow_unification_guards" as_bool - -let get_already_cached () = lookup_opt "already_cached" (as_option (as_list as_string)) -let get_cache_checked_modules () = lookup_opt "cache_checked_modules" as_bool -let get_cache_dir () = lookup_opt "cache_dir" (as_option as_string) -let get_cache_off () = lookup_opt "cache_off" as_bool -let get_print_cache_version () = lookup_opt "print_cache_version" as_bool -let get_cmi () = lookup_opt "cmi" as_bool -let get_codegen () = lookup_opt "codegen" (as_option as_string) -let get_codegen_lib () = lookup_opt "codegen-lib" (as_list as_string) -let get_defensive () = lookup_opt "defensive" as_string -let get_dep () = lookup_opt "dep" (as_option as_string) -let get_detail_errors () = lookup_opt "detail_errors" as_bool -let get_detail_hint_replay () = lookup_opt "detail_hint_replay" as_bool -let get_dump_module () = lookup_opt "dump_module" (as_list as_string) -let get_eager_subtyping () = lookup_opt "eager_subtyping" as_bool -let get_error_contexts () = lookup_opt "error_contexts" as_bool -let get_expose_interfaces () = lookup_opt "expose_interfaces" as_bool -let get_message_format () = lookup_opt "message_format" as_string -let get_extract () = lookup_opt "extract" (as_option (as_list as_string)) -let get_extract_module () = lookup_opt "extract_module" (as_list as_string) -let get_extract_namespace () = lookup_opt "extract_namespace" (as_list as_string) -let get_force () = lookup_opt "force" as_bool -let get_hide_uvar_nums () = lookup_opt "hide_uvar_nums" as_bool -let get_hint_info () = lookup_opt "hint_info" as_bool -let get_hint_dir () = lookup_opt "hint_dir" (as_option as_string) -let get_hint_file () = lookup_opt "hint_file" (as_option as_string) -let get_in () = lookup_opt "in" as_bool -let get_ide () = lookup_opt "ide" as_bool -let get_ide_id_info_off () = lookup_opt "ide_id_info_off" as_bool -let get_lsp () = lookup_opt "lsp" as_bool -let get_include () = lookup_opt "include" (as_list as_string) -let get_print () = lookup_opt "print" as_bool -let get_print_in_place () = lookup_opt "print_in_place" as_bool -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_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) -let get_log_queries () = lookup_opt "log_queries" as_bool -let get_log_failing_queries () = lookup_opt "log_failing_queries" as_bool -let get_log_types () = lookup_opt "log_types" as_bool -let get_max_fuel () = lookup_opt "max_fuel" as_int -let get_max_ifuel () = lookup_opt "max_ifuel" as_int -let get_MLish () = lookup_opt "MLish" as_bool -let get_MLish_effect () = lookup_opt "MLish_effect" as_string -let get_no_default_includes () = lookup_opt "no_default_includes" as_bool -let get_no_extract () = lookup_opt "no_extract" (as_list as_string) -let get_no_location_info () = lookup_opt "no_location_info" as_bool -let get_no_plugins () = lookup_opt "no_plugins" as_bool -let get_no_smt () = lookup_opt "no_smt" as_bool -let get_normalize_pure_terms_for_extraction - () = lookup_opt "normalize_pure_terms_for_extraction" as_bool -let get_krmloutput () = lookup_opt "krmloutput" (as_option as_string) -let get_odir () = lookup_opt "odir" (as_option as_string) -let get_output_deps_to () = lookup_opt "output_deps_to" (as_option as_string) -let get_ugly () = lookup_opt "ugly" as_bool -let get_prims () = lookup_opt "prims" (as_option as_string) -let get_print_bound_var_types () = lookup_opt "print_bound_var_types" as_bool -let get_print_effect_args () = lookup_opt "print_effect_args" as_bool -let get_print_expected_failures () = lookup_opt "print_expected_failures" as_bool -let get_print_full_names () = lookup_opt "print_full_names" as_bool -let get_print_implicits () = lookup_opt "print_implicits" as_bool -let get_print_universes () = lookup_opt "print_universes" as_bool -let get_print_z3_statistics () = lookup_opt "print_z3_statistics" as_bool -let get_prn () = lookup_opt "prn" as_bool -let get_proof_recovery () = lookup_opt "proof_recovery" as_bool -let get_quake_lo () = lookup_opt "quake_lo" as_int -let get_quake_hi () = lookup_opt "quake_hi" as_int -let get_quake_keep () = lookup_opt "quake_keep" as_bool -let get_query_cache () = lookup_opt "query_cache" as_bool -let get_query_stats () = lookup_opt "query_stats" as_bool -let get_read_checked_file () = lookup_opt "read_checked_file" (as_option as_string) -let get_read_krml_file () = lookup_opt "read_krml_file" (as_option as_string) -let get_list_plugins () = lookup_opt "list_plugins" as_bool -let get_locate () = lookup_opt "locate" as_bool -let get_locate_lib () = lookup_opt "locate_lib" as_bool -let get_locate_ocaml () = lookup_opt "locate_ocaml" as_bool -let get_record_hints () = lookup_opt "record_hints" as_bool -let get_record_options () = lookup_opt "record_options" as_bool -let get_retry () = lookup_opt "retry" as_bool -let get_reuse_hint_for () = lookup_opt "reuse_hint_for" (as_option as_string) -let get_report_assumes () = lookup_opt "report_assumes" (as_option as_string) -let get_silent () = lookup_opt "silent" as_bool -let get_smt () = lookup_opt "smt" (as_option as_string) -let get_smtencoding_elim_box () = lookup_opt "smtencoding.elim_box" as_bool -let get_smtencoding_nl_arith_repr () = lookup_opt "smtencoding.nl_arith_repr" as_string -let get_smtencoding_l_arith_repr() = lookup_opt "smtencoding.l_arith_repr" as_string -let get_smtencoding_valid_intro () = lookup_opt "smtencoding.valid_intro" as_bool -let get_smtencoding_valid_elim () = lookup_opt "smtencoding.valid_elim" as_bool -let get_split_queries () = lookup_opt "split_queries" as_string -let get_tactic_raw_binders () = lookup_opt "tactic_raw_binders" as_bool -let get_tactics_failhard () = lookup_opt "tactics_failhard" as_bool -let get_tactics_info () = lookup_opt "tactics_info" as_bool -let get_tactic_trace () = lookup_opt "tactic_trace" as_bool -let get_tactic_trace_d () = lookup_opt "tactic_trace_d" as_int -let get_tactics_nbe () = lookup_opt "__tactics_nbe" as_bool -let get_tcnorm () = lookup_opt "tcnorm" as_bool -let get_timing () = lookup_opt "timing" as_bool -let get_trace_error () = lookup_opt "trace_error" as_bool -let get_unthrottle_inductives () = lookup_opt "unthrottle_inductives" as_bool -let get_unsafe_tactic_exec () = lookup_opt "unsafe_tactic_exec" as_bool -let get_use_eq_at_higher_order () = lookup_opt "use_eq_at_higher_order" as_bool -let get_use_hints () = lookup_opt "use_hints" as_bool -let get_use_hint_hashes () = lookup_opt "use_hint_hashes" as_bool -let get_use_native_tactics () = lookup_opt "use_native_tactics" (as_option as_string) -let get_no_tactics () = lookup_opt "no_tactics" as_bool -let get_using_facts_from () = lookup_opt "using_facts_from" (as_option (as_list as_string)) -let get_verify_module () = lookup_opt "verify_module" (as_list as_string) -let get_version () = lookup_opt "version" as_bool -let get_warn_default_effects () = lookup_opt "warn_default_effects" as_bool -let get_z3cliopt () = lookup_opt "z3cliopt" (as_list as_string) -let get_z3smtopt () = lookup_opt "z3smtopt" (as_list as_string) -let get_z3refresh () = lookup_opt "z3refresh" as_bool -let get_z3rlimit () = lookup_opt "z3rlimit" as_int -let get_z3rlimit_factor () = lookup_opt "z3rlimit_factor" as_int -let get_z3seed () = lookup_opt "z3seed" as_int -let get_z3version () = lookup_opt "z3version" as_string -let get_no_positivity () = lookup_opt "__no_positivity" as_bool -let get_warn_error () = lookup_opt "warn_error" (as_list as_string) -let get_use_nbe () = lookup_opt "use_nbe" as_bool -let get_use_nbe_for_extraction () = lookup_opt "use_nbe_for_extraction" as_bool -let get_trivial_pre_for_unannotated_effectful_fns - () = lookup_opt "trivial_pre_for_unannotated_effectful_fns" as_bool -let get_profile () = lookup_opt "profile" (as_option (as_list as_string)) -let get_profile_group_by_decl () = lookup_opt "profile_group_by_decl" as_bool -let get_profile_component () = lookup_opt "profile_component" (as_option (as_list as_string)) - -// See comment in the interface file -let _version = Util.mk_ref "" -let _platform = Util.mk_ref "" -let _compiler = Util.mk_ref "" -let _date = Util.mk_ref " not set" -let _commit = Util.mk_ref "" - -let display_version () = - Util.print_string (Util.format5 "F* %s\nplatform=%s\ncompiler=%s\ndate=%s\ncommit=%s\n" - !_version !_platform !_compiler !_date !_commit) - -let display_debug_keys () = - let keys = Debug.list_all_toggles () in - keys |> List.sortWith String.compare |> List.iter (fun s -> Util.print_string (s ^ "\n")) - -let display_usage_aux (specs : list (opt & Pprint.document)) : unit = - let open FStar.Pprint in - let open FStar.Errors.Msg in - let text (s:string) : document = flow (break_ 1) (words s) in - let bold_doc (d:document) : document = - (* very hacky, this would make no sense for documents going elsewhere - other than stdout *) - if stdout_isatty () = Some true - then fancystring "\x1b[39;1m" 0 ^^ d ^^ fancystring "\x1b[0m" 0 - else d - in - let d : document = - doc_of_string "fstar.exe [options] file[s] [@respfile...]" ^/^ - doc_of_string (Util.format1 " %srespfile: read command-line options from respfile\n" (Util.colorize_bold "@")) ^/^ - List.fold_right - (fun ((short, flag, p), explain) rest -> - let arg = - match p with - | ZeroArgs _ -> empty - | OneArg (_, argname) -> blank 1 ^^ doc_of_string argname - in - let short_opt = - if short <> noshort - then [doc_of_string ("-" ^ String.make 1 short) ^^ arg] - else [] - in - let long_opt = - if flag <> "" - then [doc_of_string ("--" ^ flag) ^^ arg] - else [] - in - group (bold_doc (separate (comma ^^ blank 1) (short_opt @ long_opt))) ^^ hardline ^^ - group (blank 4 ^^ align explain) ^^ hardline ^^ - rest - ) - specs empty - in - Util.print_string (pretty_string (float_of_string "1.0") 80 d) - -let mk_spec (o : char & string & opt_variant option_val) : opt = - let ns, name, arg = o in - let arg = - match arg with - | ZeroArgs f -> - let g () = set_option name (f()) in - ZeroArgs g - - | OneArg (f, d) -> - let g x = set_option name (f x) in - OneArg (g, d) in - ns, name, arg - -let accumulated_option name value = - let prev_values = Util.dflt [] (lookup_opt name (as_option as_list')) in - List (value :: prev_values) - -let reverse_accumulated_option name value = - let prev_values = Util.dflt [] (lookup_opt name (as_option as_list')) in - List (prev_values @ [value]) - -let accumulate_string name post_processor value = - set_option name (accumulated_option name (String (post_processor value))) - -let add_extract_module s = - accumulate_string "extract_module" String.lowercase s - -let add_extract_namespace s = - accumulate_string "extract_namespace" String.lowercase s - -let add_verify_module s = - accumulate_string "verify_module" String.lowercase s - -exception InvalidArgument of string // option name - -(** Parse option value `str_val` according to specification `typ`. - -For example, to parse the value "OCaml" for the option "--codegen", this -function is called as ``parse_opt_val "codegen" (EnumStr ["OCaml"; "FSharp"; -"krml"]) "OCaml"`` and returns ``String "OCaml"``. - -`opt_name` is only used in error messages. **) -let rec parse_opt_val (opt_name: string) (typ: opt_type) (str_val: string) : option_val = - try - match typ with - | Const c -> c - | IntStr _ -> (match safe_int_of_string str_val with - | Some v -> Int v - | None -> raise (InvalidArgument opt_name)) - | BoolStr -> Bool (if str_val = "true" then true - else if str_val = "false" then false - else raise (InvalidArgument opt_name)) - | PathStr _ -> Path str_val - | SimpleStr _ -> String str_val - | EnumStr strs -> if List.mem str_val strs then String str_val - else raise (InvalidArgument opt_name) - | OpenEnumStr _ -> String str_val - | PostProcessed (pp, elem_spec) -> pp (parse_opt_val opt_name elem_spec str_val) - | Accumulated elem_spec -> let v = parse_opt_val opt_name elem_spec str_val in - accumulated_option opt_name v - | ReverseAccumulated elem_spec -> let v = parse_opt_val opt_name elem_spec str_val in - reverse_accumulated_option opt_name v - | WithSideEffect (side_effect, elem_spec) -> side_effect (); - parse_opt_val opt_name elem_spec str_val - with - | InvalidArgument opt_name -> - failwith (Util.format1 "Invalid argument to --%s" opt_name) - -let rec desc_of_opt_type typ : option string = - let desc_of_enum cases = Some (String.concat "|" cases) in - match typ with - | Const c -> None - | IntStr desc -> Some desc - | BoolStr -> desc_of_enum ["true"; "false"] - | PathStr desc -> Some desc - | SimpleStr desc -> Some desc - | EnumStr strs -> desc_of_enum strs - | OpenEnumStr (strs, desc) -> desc_of_enum (strs @ [desc]) - | PostProcessed (_, elem_spec) - | Accumulated elem_spec - | ReverseAccumulated elem_spec - | WithSideEffect (_, elem_spec) -> desc_of_opt_type elem_spec - -let arg_spec_of_opt_type opt_name typ : opt_variant option_val = - let wrap s = "<" ^ s ^ ">" in - let parser = parse_opt_val opt_name typ in - match desc_of_opt_type typ with - | None -> ZeroArgs (fun () -> parser "") - | Some desc -> - let desc = wrap desc in - OneArg (parser, desc) - -let pp_validate_dir p = - let pp = as_string p in - mkdir (*clean=*)false (*mkparents=*)true pp; - p - -let pp_lowercase s = - String (String.lowercase (as_string s)) - -let abort_counter : ref int = - mk_ref 0 - -let interp_quake_arg (s:string) - : int & int & bool = - (* min, max, keep_going *) - let ios = int_of_string in - match split s "/" with - | [f] -> ios f, ios f, false - | [f1; f2] -> - if f2 = "k" - then ios f1, ios f1, true - else ios f1, ios f2, false - | [f1; f2; k] -> - if k = "k" - then ios f1, ios f2, true - else failwith "unexpected value for --quake" - | _ -> failwith "unexpected value for --quake" - -let set_option_warning_callback_aux, - option_warning_callback = - let cb = mk_ref None in - let set (f:string -> unit) = - cb := Some f - in - let call msg = - match !cb with - | None -> () - | Some f -> f msg - in - set, call -let set_option_warning_callback f = set_option_warning_callback_aux f - -let rec specs_with_types warn_unsafe : list (char & string & opt_type & Pprint.document) = - let open FStar.Pprint in - let open FStar.Errors.Msg in - let text (s:string) : document = flow (break_ 1) (words s) in - [ - ( noshort, "abort_on", - PostProcessed ((function Int x -> abort_counter := x; Int x - | x -> failwith "?"), IntStr "non-negative integer"), - text "Abort on the n-th error or warning raised. Useful in combination with --trace_error. Count starts at 1, use 0 to disable. (default 0)"); - - ( noshort, - "admit_smt_queries", - WithSideEffect ((fun _ -> if warn_unsafe then option_warning_callback "admit_smt_queries"), - BoolStr), - text "Admit SMT queries, unsafe! (default 'false')"); - - ( noshort, - "admit_except", - WithSideEffect ((fun _ -> if warn_unsafe then option_warning_callback "admit_except"), - SimpleStr "[symbol|(symbol, id)]"), - text "Admit all queries, except those with label ( symbol, id))\ - (e.g. --admit_except '(FStar.Fin.pigeonhole, 1)' or --admit_except FStar.Fin.pigeonhole)"); - - ( noshort, - "compat_pre_core", - IntStr "0, 1, 2", - text "Retain behavior of the tactic engine prior to the introduction \ - of FStar.TypeChecker.Core (0 is most permissive, 2 is least permissive)"); - - ( noshort, - "compat_pre_typed_indexed_effects", - Const (Bool true), - text "Retain untyped indexed effects implicits"); - - ( noshort, - "disallow_unification_guards", - BoolStr, - text "Fail if the SMT guard are produced when the tactic engine re-checks solutions produced by the unifier (default 'false')"); - - ( noshort, - "already_cached", - Accumulated (SimpleStr "One or more space-separated occurrences of '[+|-]( * | namespace | module)'"), - text "Expects all modules whose names or namespaces match the provided options \ - to already have valid .checked files in the include path"); - - ( noshort, - "cache_checked_modules", - Const (Bool true), - text "Write a '.checked' file for each module after verification and read from it if present, instead of re-verifying"); - - ( noshort, - "cache_dir", - PostProcessed (pp_validate_dir, PathStr "dir"), - text "Read and write .checked and .checked.lax in directory dir"); - - ( noshort, - "cache_off", - Const (Bool true), - text "Do not read or write any .checked files"); - - ( noshort, - "print_cache_version", - Const (Bool true), - text "Print the version for .checked files and exit."); - - ( noshort, - "cmi", - Const (Bool true), - text "Inline across module interfaces during extraction (aka. cross-module inlining)"); - - ( noshort, - "codegen", - EnumStr ["OCaml"; "FSharp"; "krml"; "Plugin"; "Extension"], - text "Generate code for further compilation to executable code, or build a compiler plugin"); - - ( noshort, - "codegen-lib", - Accumulated (SimpleStr "namespace"), - text "External runtime library (i.e. M.N.x extracts to M.N.X instead of M_N.x)"); - - ( 'd', - "", - PostProcessed ( - (fun o -> - Debug.enable (); - o), Const (Bool true)), - text "Enable general debugging, i.e. increase verbosity."); - - ( noshort, - "debug", - PostProcessed ( - (fun o -> - let keys = as_comma_string_list o in - Debug.enable_toggles keys; - o), ReverseAccumulated (SimpleStr "debug toggles")), - text "Enable specific debug toggles (comma-separated list of debug keys)"); - - ( noshort, - "debug_all", - PostProcessed ( - (fun o -> - match o with - | Bool true -> - Debug.set_debug_all (); - o - | _ -> failwith "?" - ), Const (Bool true)), - text "Enable all debug toggles. WARNING: this will cause a lot of output!"); - - ( noshort, - "debug_all_modules", - Const (Bool true), - text "Enable to make the effect of --debug apply to every module processed by the compiler, \ - including dependencies."); - - ( noshort, - "defensive", - EnumStr ["no"; "warn"; "error"; "abort"], - text "Enable several internal sanity checks, useful to track bugs and report issues." - ^^ bulleted [ - text "if 'no', no checks are performed"; - text "if 'warn', checks are performed and raise a warning when they fail"; - text "if 'error, like 'warn', but the compiler raises a hard error instead"; - text "if 'abort, like 'warn', but the compiler immediately aborts on an error" - ] - ^/^ text "(default 'no')"); - - ( noshort, - "dep", - EnumStr ["make"; "graph"; "full"; "raw"], - text "Output the transitive closure of the full dependency graph in three formats:" - ^^ bulleted [ - text "'graph': a format suitable the 'dot' tool from 'GraphViz'"; - text "'full': a format suitable for 'make', including dependences for producing .ml and .krml files"; - text "'make': (deprecated) a format suitable for 'make', including only dependences among source files"; - ]); - - ( noshort, - "detail_errors", - Const (Bool true), - text "Emit a detailed error report by asking the SMT solver many queries; will take longer"); - - ( noshort, - "detail_hint_replay", - Const (Bool true), - text "Emit a detailed report for proof whose unsat core fails to replay"); - - ( noshort, - "dump_module", - Accumulated (SimpleStr "module_name"), - text "Print out this module as it passes through the compiler pipeline"); - - ( noshort, - "eager_subtyping", - Const (Bool true), - text "Try to solve subtyping constraints at each binder (loses precision but may be slightly more efficient)"); - - ( noshort, - "error_contexts", - BoolStr, - text "Print context information for each error or warning raised (default false)"); - - ( noshort, - "ext", - PostProcessed ( - (fun o -> - let parse_ext (s:string) : list (string & string) = - let exts = Util.split s ";" in - List.collect (fun s -> - match Util.split s "=" with - | [k;v] -> [(k,v)] - | _ -> [s, "1"]) exts - in - as_comma_string_list o |> List.collect parse_ext |> List.iter (fun (k, v) -> Ext.set k v); - o), ReverseAccumulated (SimpleStr "extension knobs")), - text "These options are set in extensions option map. Keys are usually namespaces separated by \":\". \ - E.g., 'pulse:verbose=1;my:extension:option=xyz;foo:bar=baz'. \ - These options are typically interpreted by extensions. \ - Any later use of --ext over the same key overrides the old value. \ - An entry 'e' that is not of the form 'a=b' is treated as 'e=1', i.e., 'e' associated with string \"1\"."); - - ( noshort, - "extract", - Accumulated (SimpleStr "One or more semicolon separated occurrences of '[TargetName:]ModuleSelector'"), - text "Extract only those modules whose names or namespaces match the provided options. \ - 'TargetName' ranges over {OCaml, krml, FSharp, Plugin, Extension}. \ - A 'ModuleSelector' is a space or comma-separated list of '[+|-]( * | namespace | module)'. \ - For example --extract 'OCaml:A -A.B' --extract 'krml:A -A.C' --extract '*' means \ - for OCaml, extract everything in the A namespace only except A.B; \ - for krml, extract everything in the A namespace only except A.C; \ - for everything else, extract everything. \ - Note, the '+' is optional: --extract '+A' and --extract 'A' mean the same thing. \ - Note also that '--extract A' applies both to a module named 'A' and to any module in the 'A' namespace \ - Multiple uses of this option accumulate, e.g., --extract A --extract B is interpreted as --extract 'A B'."); - - ( noshort, - "extract_module", - Accumulated (PostProcessed (pp_lowercase, (SimpleStr "module_name"))), - text "Deprecated: use --extract instead; Only extract the specified modules (instead of the possibly-partial dependency graph)"); - - ( noshort, - "extract_namespace", - Accumulated (PostProcessed (pp_lowercase, (SimpleStr "namespace name"))), - text "Deprecated: use --extract instead; Only extract modules in the specified namespace"); - - ( noshort, - "expose_interfaces", - Const (Bool true), - text "Explicitly break the abstraction imposed by the interface of any implementation file that appears on the command line (use with care!)"); - - ( noshort, - "message_format", - EnumStr ["human"; "json"], - text "Format of the messages emitted by F* (default `human`)"); - - ( noshort, - "hide_uvar_nums", - Const (Bool true), - text "Don't print unification variable numbers"); - - ( noshort, - "hint_dir", - PostProcessed (pp_validate_dir, PathStr "dir"), - text "Read/write hints to dir/module_name.hints (instead of placing hint-file alongside source file)"); - - ( noshort, - "hint_file", - PathStr "path", - text "Read/write hints to path (instead of module-specific hints files; overrides hint_dir)"); - - ( noshort, - "hint_info", - Const (Bool true), - text "Print information regarding hints (deprecated; use --query_stats instead)"); - - ( noshort, - "in", - Const (Bool true), - text "Legacy interactive mode; reads input from stdin"); - - ( noshort, - "ide", - Const (Bool true), - text "JSON-based interactive mode for IDEs"); - - ( noshort, - "ide_id_info_off", - Const (Bool true), - text "Disable identifier tables in IDE mode (temporary workaround useful in Steel)"); - - ( noshort, - "lsp", - Const (Bool true), - text "Language Server Protocol-based interactive mode for IDEs"); - - ( noshort, - "include", - ReverseAccumulated (PathStr "path"), - text "A directory in which to search for files included on the command line"); - - ( noshort, - "print", - Const (Bool true), - text "Parses and prettyprints the files included on the command line"); - - ( noshort, - "print_in_place", - Const (Bool true), - text "Parses and prettyprints in place the files included on the command line"); - - ( 'f', - "force", - Const (Bool true), - text "Force checking the files given as arguments even if they have valid checked files"); - - ( noshort, - "fuel", - PostProcessed - ((function | String s -> - let p f = Int (int_of_string f) in - let min, max = - match Util.split s "," with - | [f] -> f, f - | [f1;f2] -> f1, f2 - | _ -> failwith "unexpected value for --fuel" - in - set_option "initial_fuel" (p min); - set_option "max_fuel" (p max); - String s - | _ -> failwith "impos"), - SimpleStr "non-negative integer or pair of non-negative integers"), - text "Set initial_fuel and max_fuel at once"); - - ( noshort, - "ifuel", - PostProcessed - ((function | String s -> - let p f = Int (int_of_string f) in - let min, max = - match Util.split s "," with - | [f] -> f, f - | [f1;f2] -> f1, f2 - | _ -> failwith "unexpected value for --ifuel" - in - set_option "initial_ifuel" (p min); - set_option "max_ifuel" (p max); - String s - | _ -> failwith "impos"), - SimpleStr "non-negative integer or pair of non-negative integers"), - text "Set initial_ifuel and max_ifuel at once"); - - ( noshort, - "initial_fuel", - IntStr "non-negative integer", - text "Number of unrolling of recursive functions to try initially (default 2)"); - - ( noshort, - "initial_ifuel", - IntStr "non-negative integer", - text "Number of unrolling of inductive datatypes to try at first (default 1)"); - - ( noshort, - "keep_query_captions", - BoolStr, - text "Retain comments in the logged SMT queries (requires --log_queries or --log_failing_queries; default true)"); - - ( noshort, - "lax", - WithSideEffect ((fun () -> if warn_unsafe then option_warning_callback "lax"), Const (Bool true)), - text "Run the lax-type checker only (admit all verification conditions)"); - - ( noshort, - "load", - ReverseAccumulated (PathStr "module"), - text "Load OCaml module, compiling it if necessary"); - - ( noshort, - "load_cmxs", - ReverseAccumulated (PathStr "module"), - text "Load compiled module, fails hard if the module is not already compiled"); - - ( noshort, - "log_types", - Const (Bool true), - text "Print types computed for data/val/let-bindings"); - - ( noshort, - "log_queries", - Const (Bool true), - text "Log the Z3 queries in several queries-*.smt2 files, as we go"); - - ( noshort, - "log_failing_queries", - Const (Bool true), - text "As --log_queries, but only save the failing queries. Each query is - saved in its own file regardless of whether they were checked during the - same invocation. The SMT2 file names begin with \"failedQueries\""); - - ( noshort, - "max_fuel", - IntStr "non-negative integer", - text "Number of unrolling of recursive functions to try at most (default 8)"); - - ( noshort, - "max_ifuel", - IntStr "non-negative integer", - text "Number of unrolling of inductive datatypes to try at most (default 2)"); - - ( noshort, - "MLish", - Const (Bool true), - text "Trigger various specializations for compiling the F* compiler itself (not meant for user code)"); - - ( noshort, - "MLish_effect", - SimpleStr "module_name", - text "Set the default effect *module* for --MLish (default: FStar.Compiler.Effect)"); - - ( noshort, - "no_default_includes", - Const (Bool true), - text "Ignore the default module search paths"); - - ( noshort, - "no_extract", - Accumulated (PathStr "module name"), - text "Deprecated: use --extract instead; Do not extract code from this module"); - - ( noshort, - "no_location_info", - Const (Bool true), - text "Suppress location information in the generated OCaml output (only relevant with --codegen OCaml)"); - - ( noshort, - "no_smt", - Const (Bool true), - text "Do not send any queries to the SMT solver, and fail on them instead"); - - ( noshort, - "normalize_pure_terms_for_extraction", - Const (Bool true), - text "Extract top-level pure terms after normalizing them. This can lead to very large code, but can result in more partial evaluation and compile-time specialization."); - - ( noshort, - "krmloutput", - PathStr "filename", - text "Place KaRaMeL extraction output in file . The path can be relative or absolute and does not depend\ - on the --odir option."); - - ( noshort, - "odir", - PostProcessed (pp_validate_dir, PathStr "dir"), - text "Place output in directory dir"); - - ( noshort, - "output_deps_to", - PathStr "file", - text "Output the result of --dep into this file instead of to standard output."); - - ( noshort, - "prims", - PathStr "file", - text "Use a custom Prims.fst file. Do not use if you do not know exactly what you're doing."); - - ( noshort, - "print_bound_var_types", - Const (Bool true), - text "Print the types of bound variables"); - - ( noshort, - "print_effect_args", - Const (Bool true), - text "Print inferred predicate transformers for all computation types"); - - ( noshort, - "print_expected_failures", - Const (Bool true), - text "Print the errors generated by declarations marked with expect_failure, \ - useful for debugging error locations"); - - ( noshort, - "print_full_names", - Const (Bool true), - text "Print full names of variables"); - - ( noshort, - "print_implicits", - Const (Bool true), - text "Print implicit arguments"); - - ( noshort, - "print_universes", - Const (Bool true), - text "Print universes"); - - ( noshort, - "print_z3_statistics", - Const (Bool true), - text "Print Z3 statistics for each SMT query (details such as relevant modules, facts, etc. for each proof)"); - - ( noshort, - "prn", - Const (Bool true), - text "Print full names (deprecated; use --print_full_names instead)"); - - ( noshort, - "proof_recovery", - Const (Bool true), - text "Proof recovery mode: before failing an SMT query, retry 3 times, increasing rlimits. \ - If the query goes through after retrying, verification will succeed, but a warning will be emitted. \ - This feature is useful to restore a project after some change to its libraries or F* upgrade. \ - Importantly, then, this option cannot be used in a pragma (#set-options, etc)."); - - ( noshort, - "quake", - PostProcessed - ((function | String s -> - let min, max, k = interp_quake_arg s in - set_option "quake_lo" (Int min); - set_option "quake_hi" (Int max); - set_option "quake_keep" (Bool k); - set_option "retry" (Bool false); - String s - | _ -> failwith "impos"), - SimpleStr "positive integer or pair of positive integers"), - text "Repeats SMT queries to check for robustness" ^^ - bulleted [ - text "--quake N/M repeats each query checks that it succeeds at least N out of M times, aborting early if possible"; - text "--quake N/M/k works as above, except it will unconditionally run M times"; - text "--quake N is an alias for --quake N/N"; - text "--quake N/k is an alias for --quake N/N/k"; - ] ^^ - text "Using --quake disables --retry. When quake testing, queries are not splitted for error reporting unless \ - '--split_queries always' is given. Queries from the smt_sync tactic are not quake-tested."); - - ( noshort, - "query_cache", - Const (Bool true), - text "Keep a running cache of SMT queries to make verification faster. \ - Only available in the interactive mode. \ - NOTE: This feature is experimental and potentially unsound! Hence why - it is not allowed in batch mode (where it is also less useful). If you - find a query that is mistakenly accepted with the cache, please - report a bug to the F* issue tracker on GitHub."); - - ( noshort, - "query_stats", - Const (Bool true), - text "Print SMT query statistics"); - - ( noshort, - "read_checked_file", - PathStr "path", - text "Read a checked file and dump it to standard output."); - - ( noshort, - "read_krml_file", - PathStr "path", - text "Read a Karamel binary file and dump it to standard output."); - - ( noshort, - "record_hints", - Const (Bool true), - text "Record a database of hints for efficient proof replay"); - - ( noshort, - "record_options", - Const (Bool true), - text "Record the state of options used to check each sigelt, useful \ - for the `check_with` attribute and metaprogramming. \ - Note that this implies a performance hit and increases the size of checked files."); - - ( noshort, - "retry", - PostProcessed - ((function | Int i -> - set_option "quake_lo" (Int 1); - set_option "quake_hi" (Int i); - set_option "quake_keep" (Bool false); - set_option "retry" (Bool true); - Bool true - | _ -> failwith "impos"), - IntStr "positive integer"), - text "Retry each SMT query N times and succeed on the first try. Using --retry disables --quake."); - - ( noshort, - "reuse_hint_for", - SimpleStr "toplevel_name", - text "Optimistically, attempt using the recorded hint for toplevel_name (a top-level name in the current module) when trying to verify some other term 'g'"); - - ( noshort, - "report_assumes", - EnumStr ["warn"; "error"], - text "Report every use of an escape hatch, include assume, admit, etc."); - - ( noshort, - "silent", - Const (Bool true), - text "Disable all non-critical output"); - - ( noshort, - "smt", - PathStr "path", - text "Path to the Z3 SMT solver (we could eventually support other solvers)"); - - ( noshort, - "smtencoding.elim_box", - BoolStr, - text "Toggle a peephole optimization that eliminates redundant uses of boxing/unboxing in the SMT encoding (default 'false')"); - - ( noshort, - "smtencoding.nl_arith_repr", - EnumStr ["native"; "wrapped"; "boxwrap"], - text "Control the representation of non-linear arithmetic functions in the SMT encoding:" ^^ - bulleted [ - text "if 'boxwrap' use 'Prims.op_Multiply, Prims.op_Division, Prims.op_Modulus'"; - text "if 'native' use '*, div, mod'"; - text "if 'wrapped' use '_mul, _div, _mod : Int*Int -> Int'"; - ] ^^ - text "(default 'boxwrap')"); - - ( noshort, - "smtencoding.l_arith_repr", - EnumStr ["native"; "boxwrap"], - text "Toggle the representation of linear arithmetic functions in the SMT encoding:" ^^ - bulleted [ - text "if 'boxwrap', use 'Prims.op_Addition, Prims.op_Subtraction, Prims.op_Minus'"; - text "if 'native', use '+, -, -'"; - ] ^^ - text "(default 'boxwrap')"); - - ( noshort, - "smtencoding.valid_intro", - BoolStr, - text "Include an axiom in the SMT encoding to introduce proof-irrelevance from a constructive proof"); - - ( noshort, - "smtencoding.valid_elim", - BoolStr, - text "Include an axiom in the SMT encoding to eliminate proof-irrelevance into the existence of a proof witness"); - - ( noshort, - "split_queries", - EnumStr ["no"; "on_failure"; "always"], - text "Split SMT verification conditions into several separate queries, one per goal. \ - Helps with localizing errors." ^^ - bulleted [ - text "Use 'no' to disable (this may reduce the quality of error messages)."; - text "Use 'on_failure' to split queries and retry when discharging fails (the default)"; - text "Use 'yes' to always split."; - ]); - - ( noshort, - "tactic_raw_binders", - Const (Bool true), - text "Do not use the lexical scope of tactics to improve binder names"); - - ( noshort, - "tactics_failhard", - Const (Bool true), - text "Do not recover from metaprogramming errors, and abort if one occurs"); - - ( noshort, - "tactics_info", - Const (Bool true), - text "Print some rough information on tactics, such as the time they take to run"); - - ( noshort, - "tactic_trace", - Const (Bool true), - text "Print a depth-indexed trace of tactic execution (Warning: very verbose)"); - - ( noshort, - "tactic_trace_d", - IntStr "positive_integer", - text "Trace tactics up to a certain binding depth"); - - ( noshort, - "__tactics_nbe", - Const (Bool true), - text "Use NBE to evaluate metaprograms (experimental)"); - - ( noshort, - "tcnorm", - BoolStr, - text "Attempt to normalize definitions marked as tcnorm (default 'true')"); - - ( noshort, - "timing", - Const (Bool true), - text "Print the time it takes to verify each top-level definition. \ - This is just an alias for an invocation of the profiler, so it may not work well if combined with --profile. \ - In particular, it implies --profile_group_by_decl."); - - ( noshort, - "trace_error", - Const (Bool true), - text "Attach stack traces on errors"); - - ( noshort, - "ugly", - Const (Bool true), - text "Emit output formatted for debugging"); - - ( noshort, - "unthrottle_inductives", - Const (Bool true), - text "Let the SMT solver unfold inductive types to arbitrary depths (may affect verifier performance)"); - - ( noshort, - "unsafe_tactic_exec", - Const (Bool true), - text "Allow tactics to run external processes. WARNING: checking an untrusted F* file while \ - using this option can have disastrous effects."); - - ( noshort, - "use_eq_at_higher_order", - Const (Bool true), - text "Use equality constraints when comparing higher-order types (Temporary)"); - - ( noshort, - "use_hints", - Const (Bool true), - text "Use a previously recorded hints database for proof replay"); - - ( noshort, - "use_hint_hashes", - Const (Bool true), - text "Admit queries if their hash matches the hash recorded in the hints database"); - - ( noshort, - "use_native_tactics", - PathStr "path", - text "Use compiled tactics from path"); - - ( noshort, - "no_plugins", - Const (Bool true), - text "Do not run plugins natively and interpret them as usual instead"); - - ( noshort, - "no_tactics", - Const (Bool true), - text "Do not run the tactic engine before discharging a VC"); - - ( noshort, - "using_facts_from", - ReverseAccumulated (SimpleStr "One or more space-separated occurrences of '[+|-]( * | namespace | fact id)'"), - text "Prunes the context to include only the facts from the given namespace or fact id. \ - Facts can be include or excluded using the [+|-] qualifier. \ - For example --using_facts_from '* -FStar.Reflection +FStar.Compiler.List -FStar.Compiler.List.Tot' will \ - remove all facts from FStar.Compiler.List.Tot.*, \ - retain all remaining facts from FStar.Compiler.List.*, \ - remove all facts from FStar.Reflection.*, \ - and retain all the rest. \ - Note, the '+' is optional: --using_facts_from 'FStar.Compiler.List' is equivalent to --using_facts_from '+FStar.Compiler.List'. \ - Multiple uses of this option accumulate, e.g., --using_facts_from A --using_facts_from B is interpreted as --using_facts_from A^B."); - - ( noshort, - "__temp_fast_implicits", - Const (Bool true), - text "This does nothing and will be removed"); - - ( 'v', - "version", - WithSideEffect ((fun _ -> display_version(); exit 0), - (Const (Bool true))), - text "Display version number"); - - ( noshort, - "warn_default_effects", - Const (Bool true), - text "Warn when (a -> b) is desugared to (a -> Tot b)"); - - ( noshort, - "z3cliopt", - ReverseAccumulated (SimpleStr "option"), - text "Z3 command line options"); - - ( noshort, - "z3smtopt", - ReverseAccumulated (SimpleStr "option"), - text "Z3 options in smt2 format"); - - ( noshort, - "z3refresh", - Const (Bool true), - text "Restart Z3 after each query; useful for ensuring proof robustness"); - - ( noshort, - "z3rlimit", - IntStr "positive_integer", - text "Set the Z3 per-query resource limit (default 5 units, taking roughtly 5s)"); - - ( noshort, - "z3rlimit_factor", - IntStr "positive_integer", - text "Set the Z3 per-query resource limit multiplier. This is useful when, say, regenerating hints and you want to be more lax. (default 1)"); - - ( noshort, - "z3seed", - IntStr "positive_integer", - text "Set the Z3 random seed (default 0)"); - - ( noshort, - "z3version", - SimpleStr "version", - text "Set the version of Z3 that is to be used. Default: 4.8.5"); - - ( noshort, - "__no_positivity", - WithSideEffect ((fun _ -> if warn_unsafe then option_warning_callback "__no_positivity"), Const (Bool true)), - text "Don't check positivity of inductive types"); - - ( noshort, - "warn_error", - ReverseAccumulated (SimpleStr ("")), - text "The [-warn_error] option follows the OCaml syntax, namely:" ^^ - bulleted [ - text "[r] is a range of warnings (either a number [n], or a range [n..n])"; - text "[-r] silences range [r]"; - text "[+r] enables range [r] as warnings (NOTE: \"enabling\" an error will downgrade it to a warning)"; - text "[@r] makes range [r] fatal." - ]); - - ( noshort, - "use_nbe", - BoolStr, - text "Use normalization by evaluation as the default normalization strategy (default 'false')"); - - ( noshort, - "use_nbe_for_extraction", - BoolStr, - text "Use normalization by evaluation for normalizing terms before extraction (default 'false')"); - - ( noshort, - "trivial_pre_for_unannotated_effectful_fns", - BoolStr, - text "Enforce trivial preconditions for unannotated effectful functions (default 'true')" ); - - ( noshort, - "__debug_embedding", - WithSideEffect ((fun _ -> debug_embedding := true), - (Const (Bool true))), - text "Debug messages for embeddings/unembeddings of natively compiled terms"); - - ( noshort, - "eager_embedding", - WithSideEffect ((fun _ -> eager_embedding := true), - (Const (Bool true))), - text "Eagerly embed and unembed terms to primitive operations and plugins: not recommended except for benchmarking"); - - ( noshort, - "profile_group_by_decl", - Const (Bool true), - text "Emit profiles grouped by declaration rather than by module"); - - ( noshort, - "profile_component", - Accumulated (SimpleStr "One or more space-separated occurrences of '[+|-]( * | namespace | module | identifier)'"), - text "Specific source locations in the compiler are instrumented with profiling counters. \ - Pass `--profile_component FStar.TypeChecker` to enable all counters in the FStar.TypeChecker namespace. \ - This option is a module or namespace selector, like many other options (e.g., `--extract`)"); - - ( noshort, - "profile", - Accumulated (SimpleStr "One or more space-separated occurrences of '[+|-]( * | namespace | module)'"), - text "Profiling can be enabled when the compiler is processing a given set of source modules. \ - Pass `--profile FStar.Pervasives` to enable profiling when the compiler is processing any module in FStar.Pervasives. \ - This option is a module or namespace selector, like many other options (e.g., `--extract`)"); - - ( 'h', - "help", - WithSideEffect ((fun _ -> display_usage_aux (specs warn_unsafe); exit 0), - (Const (Bool true))), - text "Display this information"); - - ( noshort, - "list_debug_keys", - WithSideEffect ((fun _ -> display_debug_keys(); exit 0), - (Const (Bool true))), - text "List all debug keys and exit"); - - (* FIXME: all of these should really be modes, not a boolean option *) - ( noshort, - "list_plugins", - Const (Bool true), - text "List all registered plugins and exit"); - ( noshort, - "locate", - Const (Bool true), - text "Print the root of the F* installation and exit"); - ( noshort, - "locate_lib", - Const (Bool true), - text "Print the root of the F* library and exit"); - ( noshort, - "locate_ocaml", - Const (Bool true), - text "Print the root of the built OCaml F* library and exit"); - ] - -and specs (warn_unsafe:bool) : list (FStar.Getopt.opt & Pprint.document) = - List.map (fun (short, long, typ, doc) -> - mk_spec (short, long, arg_spec_of_opt_type long typ), doc) - (specs_with_types warn_unsafe) - -// Several options can only be set at the time the process is created, -// and not controlled interactively via pragmas. -// Additionaly, the --smt option is a security concern. -let settable = function - | "__temp_fast_implicits" - | "abort_on" - | "admit_except" - | "admit_smt_queries" - | "compat_pre_core" - | "compat_pre_typed_indexed_effects" - | "disallow_unification_guards" - | "debug" - | "debug_all" - | "debug_all_modules" - | "defensive" - | "detail_errors" - | "detail_hint_replay" - | "eager_subtyping" - | "error_contexts" - | "hide_uvar_nums" - | "hint_dir" - | "hint_file" - | "hint_info" - | "fuel" - | "ext" - | "ifuel" - | "initial_fuel" - | "initial_ifuel" - | "ide_id_info_off" - | "keep_query_captions" - | "load" - | "load_cmxs" - | "log_queries" - | "log_failing_queries" - | "log_types" - | "max_fuel" - | "max_ifuel" - | "no_plugins" - | "__no_positivity" - | "normalize_pure_terms_for_extraction" - | "no_smt" - | "no_tactics" - | "print_bound_var_types" - | "print_effect_args" - | "print_expected_failures" - | "print_full_names" - | "print_implicits" - | "print_universes" - | "print_z3_statistics" - | "prn" - | "quake_lo" - | "quake_hi" - | "quake_keep" - | "quake" - | "query_cache" - | "query_stats" - | "record_options" - | "retry" - | "reuse_hint_for" - | "report_assumes" - | "silent" - | "smtencoding.elim_box" - | "smtencoding.l_arith_repr" - | "smtencoding.nl_arith_repr" - | "smtencoding.valid_intro" - | "smtencoding.valid_elim" - | "split_queries" - | "tactic_raw_binders" - | "tactics_failhard" - | "tactics_info" - | "__tactics_nbe" - | "tactic_trace" - | "tactic_trace_d" - | "tcnorm" - | "timing" - | "trace_error" - | "ugly" - | "unthrottle_inductives" - | "use_eq_at_higher_order" - | "using_facts_from" - | "warn_error" - | "z3cliopt" - | "z3smtopt" - | "z3refresh" - | "z3rlimit" - | "z3rlimit_factor" - | "z3seed" - | "z3version" - | "trivial_pre_for_unannotated_effectful_fns" - | "profile_group_by_decl" - | "profile_component" - | "profile" -> true - | _ -> false - -let all_specs = specs true -let all_specs_getopt = List.map fst all_specs - -let all_specs_with_types = specs_with_types true -let settable_specs = all_specs |> List.filter (fun ((_, x, _), _) -> settable x) - -///////////////////////////////////////////////////////////////////////////////////////////////////////// -//PUBLIC API -///////////////////////////////////////////////////////////////////////////////////////////////////////// -let set_error_flags_callback_aux, - set_error_flags = - let callback : ref (option (unit -> parse_cmdline_res)) = mk_ref None in - let set f = callback := Some f in - let call () = - match !callback with - | None -> failwith "Error flags callback not yet set" - | Some f -> f () - in - set, call - -let set_error_flags_callback = set_error_flags_callback_aux -let display_usage () = display_usage_aux all_specs - -let fstar_bin_directory = Util.get_exec_dir () - -let file_list_ : ref (list string) = Util.mk_ref [] - -(* In `parse_filename_arg specs arg`: - - * `arg` is a filename argument to be parsed. If `arg` is of the - form `@file`, then `file` is a response file, from which further - arguments (including further options) are read. Nested response - files (@ response file arguments within response files) are - supported. - - * `specs` is the list of option specifications (- and --) - - * `enable_filenames` is a boolean, true if non-response file - * filenames should be handled. - -*) - - -let rec parse_filename_arg specs enable_filenames arg = - if Util.starts_with arg "@" - then begin - // read and parse a response file - let filename = Util.substring_from arg 1 in - let lines = Util.file_get_lines filename in - Getopt.parse_list specs (parse_filename_arg specs enable_filenames) lines - end else begin - if enable_filenames - then file_list_ := !file_list_ @ [arg]; - Success - end - -let parse_cmd_line () = - let res = Getopt.parse_cmdline all_specs_getopt (parse_filename_arg all_specs_getopt true) in - let res = - if res = Success - then set_error_flags() - else res - in - res, List.map FC.try_convert_file_name_to_mixed !file_list_ - -let file_list () = - !file_list_ - -let restore_cmd_line_options should_clear = - (* Some options must be preserved because they can't be reset via #pragrams. - * Add them here as needed. *) - let old_verify_module = get_verify_module() in - if should_clear then clear() else init(); - let specs = List.map fst <| specs false in - let r = Getopt.parse_cmdline specs (parse_filename_arg specs false) in - set_option' ("verify_module", List (List.map String old_verify_module)); - r - -let module_name_of_file_name f = - let f = basename f in - let f = String.substring f 0 (String.length f - String.length (get_file_extension f) - 1) in - String.lowercase f - -let should_check m = - let l = get_verify_module () in - List.contains (String.lowercase m) l - -let should_verify m = - not (get_lax ()) && should_check m - -let should_check_file fn = - should_check (module_name_of_file_name fn) - -let should_verify_file fn = - should_verify (module_name_of_file_name fn) - -let module_name_eq m1 m2 = String.lowercase m1 = String.lowercase m2 - -let should_print_message m = - if should_verify m - then m <> "Prims" - else false - -let read_fstar_include (fn : string) : option (list string) = - try - let s = file_get_contents fn in - let subdirs = String.split ['\n'] s |> List.filter (fun s -> s <> "" && not (String.get s 0 = '#')) in - Some subdirs - with - | _ -> - failwith ("Could not read " ^ fn); - None - -let rec expand_include_d (dirname : string) : list string = - let dot_inc_path = dirname ^ "/fstar.include" in - if Util.file_exists dot_inc_path then ( - let subdirs = Some?.v <| read_fstar_include dot_inc_path in - dirname :: List.collect (fun subd -> expand_include_d (dirname ^ "/" ^ subd)) subdirs - ) else - [dirname] - -let expand_include_ds (dirnames : list string) : list string = - List.collect expand_include_d dirnames - -(* TODO: normalize these paths. This will probably affect makefiles since -make does not normalize the paths itself. Also, move this whole logic away -from this module. *) -let lib_root () : option string = - (* No default includes means we don't try to find a library on our own. *) - if get_no_default_includes() then - None - else - (* FSTAR_LIB can be set in the environment to override the library *) - match Util.expand_environment_variable "FSTAR_LIB" with - | Some s -> Some s - | None -> - (* Otherwise, try to find the library in the default locations. It's ulib/ - in the repository, and lib/fstar/ in the binary package. *) - if Util.file_exists (fstar_bin_directory ^ "/../ulib") - then Some (fstar_bin_directory ^ "/../ulib") - else if Util.file_exists (fstar_bin_directory ^ "/../lib/fstar") - then Some (fstar_bin_directory ^ "/../lib/fstar") - else None - -let lib_paths () = - Common.option_to_list (lib_root ()) |> expand_include_ds - -let include_path () = - let cache_dir = - match get_cache_dir() with - | None -> [] - | Some c -> [c] - in - let include_paths = - get_include () |> expand_include_ds - in - cache_dir @ lib_paths () @ include_paths @ expand_include_d "." - -let custom_prims () = get_prims() - -let prepend_output_dir fname = - match get_odir() with - | None -> fname - | Some x -> Util.join_paths x fname - -let prepend_cache_dir fpath = - match get_cache_dir() with - | None -> fpath - | Some x -> Util.join_paths x (Util.basename fpath) - -//Used to parse the options of -// --using_facts_from -// --extract -// --already_cached -let path_of_text text = String.split ['.'] text - -let parse_settings ns : list (list string & bool) = - let cache = Util.smap_create 31 in - let with_cache f s = - match Util.smap_try_find cache s with - | Some s -> s - | None -> - let res = f s in - Util.smap_add cache s res; - res - in - let parse_one_setting s = - if s = "*" then ([], true) - else if s = "-*" then ([], false) - else if Util.starts_with s "-" - then let path = path_of_text (Util.substring_from s 1) in - (path, false) - else let s = if Util.starts_with s "+" - then Util.substring_from s 1 - else s in - (path_of_text s, true) - in - ns |> List.collect (fun s -> - let s = Util.trim_string s in - if s = "" then [] - else with_cache (fun s -> - let s = Util.replace_char s ' ' ',' in - Util.splitlines s - |> List.concatMap (fun s -> Util.split s ",") - |> List.filter (fun s -> s <> "") - |> List.map parse_one_setting) s) - |> List.rev - -let admit_smt_queries () = get_admit_smt_queries () -let admit_except () = get_admit_except () -let compat_pre_core_should_register () = - match get_compat_pre_core() with - | Some 0 -> false - | _ -> true -let compat_pre_core_should_check () = - match get_compat_pre_core() with - | Some 0 - | Some 1 -> false - | _ -> true -let compat_pre_core_set () = - match get_compat_pre_core() with - | None -> false - | _ -> true - -let compat_pre_typed_indexed_effects () = get_compat_pre_typed_indexed_effects () - -let disallow_unification_guards () = get_disallow_unification_guards () -let cache_checked_modules () = get_cache_checked_modules () -let cache_off () = get_cache_off () -let print_cache_version () = get_print_cache_version () -let cmi () = get_cmi () - -let parse_codegen = - function - | "OCaml" -> Some OCaml - | "FSharp" -> Some FSharp - | "krml" -> Some Krml - | "Plugin" -> Some Plugin - | "Extension" -> Some Extension - | _ -> None - -let print_codegen = - function - | OCaml -> "OCaml" - | FSharp -> "FSharp" - | Krml -> "krml" - | Plugin -> "Plugin" - | Extension -> "Extension" - -let codegen () = - Util.map_opt (get_codegen()) - (fun s -> parse_codegen s |> must) - -let codegen_libs () = get_codegen_lib () |> List.map (fun x -> Util.split x ".") - -let profile_group_by_decl () = get_profile_group_by_decl () -let defensive () = get_defensive () <> "no" -let defensive_error () = get_defensive () = "error" -let defensive_abort () = get_defensive () = "abort" -let dep () = get_dep () -let detail_errors () = get_detail_errors () -let detail_hint_replay () = get_detail_hint_replay () -let any_dump_module () = Cons? (get_dump_module()) -let dump_module s = get_dump_module() |> List.existsb (module_name_eq s) -let eager_subtyping () = get_eager_subtyping() -let error_contexts () = get_error_contexts () -let expose_interfaces () = get_expose_interfaces () -let message_format () = - match get_message_format () with - | "human" -> Human - | "json" -> Json - | illegal -> failwith ("print_issue: option `message_format` was expected to be `human` or `json`, not `" ^ illegal ^ "`. This should be impossible: `message_format` was supposed to be validated.") -let force () = get_force () -let full_context_dependency () = true -let hide_uvar_nums () = get_hide_uvar_nums () -let hint_info () = get_hint_info () - || get_query_stats () -let hint_dir () = get_hint_dir () -let hint_file () = get_hint_file () -let hint_file_for_src src_filename = - match hint_file() with - | Some fn -> fn - | None -> - let file_name = - match hint_dir () with - | Some dir -> - Util.concat_dir_filename dir (Util.basename src_filename) - | _ -> src_filename - in - Util.format1 "%s.hints" file_name -let ide () = get_ide () -let ide_id_info_off () = get_ide_id_info_off () -let ide_file_name_st = - let v = Util.mk_ref (None #string) in - let set f = - match !v with - | None -> v := Some f - | Some _ -> failwith "ide_file_name_st already set" in - let get () = !v in - set, get -let set_ide_filename = fst ide_file_name_st -let ide_filename = snd ide_file_name_st -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 interactive () = get_in () || get_ide () || get_lsp () -let lax () = get_lax () -let load () = get_load () -let load_cmxs () = get_load_cmxs () -let legacy_interactive () = get_in () -let lsp_server () = get_lsp () -let log_queries () = get_log_queries () -let log_failing_queries () = get_log_failing_queries () -let keep_query_captions () = - get_keep_query_captions () - && (log_queries () || log_failing_queries ()) - -let log_types () = get_log_types () -let max_fuel () = get_max_fuel () -let max_ifuel () = get_max_ifuel () -let ml_ish () = get_MLish () -let ml_ish_effect () = get_MLish_effect () -let set_ml_ish () = set_option "MLish" (Bool true) -let no_default_includes () = get_no_default_includes () -let no_extract s = get_no_extract() |> List.existsb (module_name_eq s) -let normalize_pure_terms_for_extraction - () = get_normalize_pure_terms_for_extraction () -let no_location_info () = get_no_location_info () -let no_plugins () = get_no_plugins () -let no_smt () = get_no_smt () -let krmloutput () = get_krmloutput () -let output_dir () = get_odir () -let output_deps_to () = get_output_deps_to () -let ugly () = get_ugly () -let print_bound_var_types () = get_print_bound_var_types () -let print_effect_args () = get_print_effect_args () -let print_expected_failures () = get_print_expected_failures () -let print_implicits () = get_print_implicits () -let print_real_names () = get_prn () || get_print_full_names() -let print_universes () = get_print_universes () -let print_z3_statistics () = get_print_z3_statistics () -let proof_recovery () = get_proof_recovery () -let quake_lo () = get_quake_lo () -let quake_hi () = get_quake_hi () -let quake_keep () = get_quake_keep () -let query_cache () = get_query_cache () -let query_stats () = get_query_stats () -let read_checked_file () = get_read_checked_file () -let list_plugins () = get_list_plugins () -let locate () = get_locate () -let locate_lib () = get_locate_lib () -let locate_ocaml () = get_locate_ocaml () -let read_krml_file () = get_read_krml_file () -let record_hints () = get_record_hints () -let record_options () = get_record_options () -let retry () = get_retry () -let reuse_hint_for () = get_reuse_hint_for () -let report_assumes () = get_report_assumes () -let silent () = get_silent () -let smt () = get_smt () -let smtencoding_elim_box () = get_smtencoding_elim_box () -let smtencoding_nl_arith_native () = get_smtencoding_nl_arith_repr () = "native" -let smtencoding_nl_arith_wrapped () = get_smtencoding_nl_arith_repr () = "wrapped" -let smtencoding_nl_arith_default () = get_smtencoding_nl_arith_repr () = "boxwrap" -let smtencoding_l_arith_native () = get_smtencoding_l_arith_repr () = "native" -let smtencoding_l_arith_default () = get_smtencoding_l_arith_repr () = "boxwrap" -let smtencoding_valid_intro () = get_smtencoding_valid_intro () -let smtencoding_valid_elim () = get_smtencoding_valid_elim () - -let parse_split_queries (s:string) : option split_queries_t = - match s with - | "no" -> Some No - | "on_failure" -> Some OnFailure - | "always" -> Some Always - | _ -> None - -let split_queries () = get_split_queries () |> parse_split_queries |> Util.must -let tactic_raw_binders () = get_tactic_raw_binders () -let tactics_failhard () = get_tactics_failhard () -let tactics_info () = get_tactics_info () -let tactic_trace () = get_tactic_trace () -let tactic_trace_d () = get_tactic_trace_d () -let tactics_nbe () = get_tactics_nbe () -let tcnorm () = get_tcnorm () -let timing () = get_timing () -let trace_error () = get_trace_error () -let unthrottle_inductives () = get_unthrottle_inductives () -let unsafe_tactic_exec () = get_unsafe_tactic_exec () -let use_eq_at_higher_order () = get_use_eq_at_higher_order () -let use_hints () = get_use_hints () -let use_hint_hashes () = get_use_hint_hashes () -let use_native_tactics () = get_use_native_tactics () -let use_tactics () = not (get_no_tactics ()) -let using_facts_from () = - match get_using_facts_from () with - | None -> [ [], true ] //if not set, then retain all facts - | Some ns -> parse_settings ns -let warn_default_effects () = get_warn_default_effects () -let warn_error () = String.concat " " (get_warn_error()) -let z3_cliopt () = get_z3cliopt () -let z3_smtopt () = get_z3smtopt () -let z3_refresh () = get_z3refresh () -let z3_rlimit () = get_z3rlimit () -let z3_rlimit_factor () = get_z3rlimit_factor () -let z3_seed () = get_z3seed () -let z3_version () = get_z3version () -let no_positivity () = get_no_positivity () -let use_nbe () = get_use_nbe () -let use_nbe_for_extraction () = get_use_nbe_for_extraction () -let trivial_pre_for_unannotated_effectful_fns - () = get_trivial_pre_for_unannotated_effectful_fns () - -let debug_keys () = lookup_opt "debug" as_comma_string_list -let debug_all () = lookup_opt "debug_all" as_bool -let debug_all_modules () = lookup_opt "debug_all_modules" as_bool - -let with_saved_options f = - // take some care to not mess up the stack on errors - // (unless we're trying to track down an error) - // TODO: This assumes `f` does not mess with the stack! - if not (trace_error ()) then begin - push (); - let r = try Inr (f ()) with | ex -> Inl ex in - pop (); - match r with - | Inr v -> v - | Inl ex -> raise ex - end else begin - push (); - let retv = f () in - pop (); - retv - end - -let module_matches_namespace_filter m filter = - let m = String.lowercase m in - let setting = parse_settings filter in - let m_components = path_of_text m in - let rec matches_path m_components path = - match m_components, path with - | _, [] -> true - | m::ms, p::ps -> m=String.lowercase p && matches_path ms ps - | _ -> false - in - match setting - |> Util.try_find - (fun (path, _) -> matches_path m_components path) - with - | None -> false - | Some (_, flag) -> flag - -let matches_namespace_filter_opt m = - function - | None -> false - | Some filter -> module_matches_namespace_filter m filter - -type parsed_extract_setting = { - target_specific_settings: list (codegen_t & string); - default_settings:option string -} - -let print_pes pes = - Util.format2 "{ target_specific_settings = %s;\n\t - default_settings = %s }" - (List.map (fun (tgt, s) -> - Util.format2 "(%s, %s)" - (print_codegen tgt) - s) - pes.target_specific_settings - |> String.concat "; ") - (match pes.default_settings with - | None -> "None" - | Some s -> s) - -let find_setting_for_target tgt (s:list (codegen_t & string)) - : option string - = match Util.try_find (fun (x, _) -> x = tgt) s with - | Some (_, s) -> Some s - | _ -> None - -let extract_settings - : unit -> option parsed_extract_setting - = let memo:ref (option parsed_extract_setting & bool) = Util.mk_ref (None, false) in - let merge_parsed_extract_settings p0 p1 : parsed_extract_setting = - let merge_setting s0 s1 = - match s0, s1 with - | None, None -> None - | Some p, None - | None, Some p -> Some p - | Some p0, Some p1 -> Some (p0 ^ "," ^ p1) - in - let merge_target tgt = - match - merge_setting - (find_setting_for_target tgt p0.target_specific_settings) - (find_setting_for_target tgt p1.target_specific_settings) - with - | None -> [] - | Some x -> [tgt,x] - in - { - target_specific_settings = List.collect merge_target [OCaml;FSharp;Krml;Plugin;Extension]; - default_settings = merge_setting p0.default_settings p1.default_settings - } - in - fun _ -> - let result, set = !memo in - let fail msg = - display_usage(); - failwith (Util.format1 "Could not parse '%s' passed to the --extract option" msg) - in - if set then result - else match get_extract () with - | None -> - memo := (None, true); - None - - | Some extract_settings -> - let parse_one_setting extract_setting = - // T1:setting1; T2:setting2; ... or - // setting <-- applies to all other targets - let tgt_specific_settings = Util.split extract_setting ";" in - let split_one t_setting = - match Util.split t_setting ":" with - | [default_setting] -> - Inr (Util.trim_string default_setting) - | [target; setting] -> - let target = Util.trim_string target in - match parse_codegen target with - | None -> fail target - | Some tgt -> Inl (tgt, Util.trim_string setting) - | _ -> fail t_setting - in - let settings = List.map split_one tgt_specific_settings in - let fail_duplicate msg tgt = - display_usage(); - failwith - (Util.format2 - "Could not parse '%s'; multiple setting for %s target" - msg tgt) - in - let pes = - List.fold_right - (fun setting out -> - match setting with - | Inr def -> - (match out.default_settings with - | None -> { out with default_settings = Some def } - | Some _ -> fail_duplicate def "default") - | Inl (target, setting) -> - (match Util.try_find (fun (x, _) -> x = target) out.target_specific_settings with - | None -> { out with target_specific_settings = (target, setting):: out.target_specific_settings } - | Some _ -> fail_duplicate setting (print_codegen target))) - settings - ({ target_specific_settings = []; default_settings = None }) - in - pes - in - let empty_pes = { target_specific_settings = []; default_settings = None } in - let pes = - //the left-most settings on the command line are at the end of the list - //so fold_right - List.fold_right - (fun setting pes -> merge_parsed_extract_settings pes (parse_one_setting setting)) - extract_settings - empty_pes - in - memo := (Some pes, true); - Some pes - -let should_extract m tgt = - let m = String.lowercase m in - if m = "prims" then false - else - match extract_settings() with - | Some pes -> //new option, using --extract 'OCaml:* -FStar' etc. - let _ = - match get_no_extract(), - get_extract_namespace(), - get_extract_module () - with - | [], [], [] -> () - | _ -> failwith "Incompatible options: \ - --extract cannot be used with \ - --no_extract, --extract_namespace or --extract_module" - in - let tsetting = - match find_setting_for_target tgt pes.target_specific_settings with - | Some s -> s - | None -> - match pes.default_settings with - | Some s -> s - | None -> "*" //extract everything, by default - in - module_matches_namespace_filter m [tsetting] - | None -> //old - let should_extract_namespace m = - match get_extract_namespace () with - | [] -> false - | ns -> ns |> Util.for_some (fun n -> Util.starts_with m (String.lowercase n)) - in - let should_extract_module m = - match get_extract_module () with - | [] -> false - | l -> l |> Util.for_some (fun n -> String.lowercase n = m) - in - not (no_extract m) && - (match get_extract_namespace (), get_extract_module() with - | [], [] -> true //neither is set; extract everything - | _ -> should_extract_namespace m || should_extract_module m) - -let should_be_already_cached m = - (* should_check is true for files in the command line, - we exclude those from this check since they were explicitly - requested. *) - not (should_check m) && ( - match get_already_cached() with - | None -> false - | Some already_cached_setting -> - module_matches_namespace_filter m already_cached_setting - ) - - -let profile_enabled modul_opt phase = - match modul_opt with - | None -> //the phase is not associated with a module - matches_namespace_filter_opt phase (get_profile_component()) - - | Some modul -> - (matches_namespace_filter_opt modul (get_profile()) - && matches_namespace_filter_opt phase (get_profile_component())) - - // A special case for --timing: this option should print the time - // taken for each top-level decl, so we enable the profiler only for - // the FStar.TypeChecker.process_one_decl phase, and only for those - // modules given in the command line. - || (timing () - && phase = "FStar.TypeChecker.Tc.process_one_decl" - && should_check modul) - -exception File_argument of string - -let set_options s = - try - if s = "" - then Success - else let settable_specs = List.map fst settable_specs in - let res = Getopt.parse_string settable_specs (fun s -> raise (File_argument s); Error "set_options with file argument") s in - if res=Success - then set_error_flags() - else res - with - | File_argument s -> Getopt.Error (Util.format1 "File %s is not a valid option" s) - -let with_options s f = - with_saved_options (fun () -> - ignore (set_options s); - f ()) - -let get_vconfig () = - let vcfg = { - initial_fuel = get_initial_fuel (); - max_fuel = get_max_fuel (); - initial_ifuel = get_initial_ifuel (); - max_ifuel = get_max_ifuel (); - detail_errors = get_detail_errors (); - detail_hint_replay = get_detail_hint_replay (); - no_smt = get_no_smt (); - quake_lo = get_quake_lo (); - quake_hi = get_quake_hi (); - quake_keep = get_quake_keep (); - retry = get_retry (); - smtencoding_elim_box = get_smtencoding_elim_box (); - smtencoding_nl_arith_repr = get_smtencoding_nl_arith_repr (); - smtencoding_l_arith_repr = get_smtencoding_l_arith_repr (); - smtencoding_valid_intro = get_smtencoding_valid_intro (); - smtencoding_valid_elim = get_smtencoding_valid_elim (); - tcnorm = get_tcnorm (); - no_plugins = get_no_plugins (); - no_tactics = get_no_tactics (); - z3cliopt = get_z3cliopt (); - z3smtopt = get_z3smtopt (); - z3refresh = get_z3refresh (); - z3rlimit = get_z3rlimit (); - z3rlimit_factor = get_z3rlimit_factor (); - z3seed = get_z3seed (); - z3version = get_z3version (); - trivial_pre_for_unannotated_effectful_fns = get_trivial_pre_for_unannotated_effectful_fns (); - reuse_hint_for = get_reuse_hint_for (); - } - in - vcfg - -let set_vconfig (vcfg:vconfig) : unit = - let option_as (tag : 'a -> option_val) (o : option 'a) : option_val = - match o with - | None -> Unset - | Some s -> tag s - in - set_option "initial_fuel" (Int vcfg.initial_fuel); - set_option "max_fuel" (Int vcfg.max_fuel); - set_option "initial_ifuel" (Int vcfg.initial_ifuel); - set_option "max_ifuel" (Int vcfg.max_ifuel); - set_option "detail_errors" (Bool vcfg.detail_errors); - set_option "detail_hint_replay" (Bool vcfg.detail_hint_replay); - set_option "no_smt" (Bool vcfg.no_smt); - set_option "quake_lo" (Int vcfg.quake_lo); - set_option "quake_hi" (Int vcfg.quake_hi); - set_option "quake_keep" (Bool vcfg.quake_keep); - set_option "retry" (Bool vcfg.retry); - set_option "smtencoding.elim_box" (Bool vcfg.smtencoding_elim_box); - set_option "smtencoding.nl_arith_repr" (String vcfg.smtencoding_nl_arith_repr); - set_option "smtencoding.l_arith_repr" (String vcfg.smtencoding_l_arith_repr); - set_option "smtencoding.valid_intro" (Bool vcfg.smtencoding_valid_intro); - set_option "smtencoding.valid_elim" (Bool vcfg.smtencoding_valid_elim); - set_option "tcnorm" (Bool vcfg.tcnorm); - set_option "no_plugins" (Bool vcfg.no_plugins); - set_option "no_tactics" (Bool vcfg.no_tactics); - set_option "z3cliopt" (List (List.map String vcfg.z3cliopt)); - set_option "z3smtopt" (List (List.map String vcfg.z3smtopt)); - set_option "z3refresh" (Bool vcfg.z3refresh); - set_option "z3rlimit" (Int vcfg.z3rlimit); - set_option "z3rlimit_factor" (Int vcfg.z3rlimit_factor); - set_option "z3seed" (Int vcfg.z3seed); - set_option "z3version" (String vcfg.z3version); - set_option "trivial_pre_for_unannotated_effectful_fns" (Bool vcfg.trivial_pre_for_unannotated_effectful_fns); - set_option "reuse_hint_for" (option_as String vcfg.reuse_hint_for); - () - -instance showable_codegen_t : showable codegen_t = { - show = print_codegen; -} diff --git a/src/basic/FStar.Options.fsti b/src/basic/FStar.Options.fsti deleted file mode 100644 index 876e40616f6..00000000000 --- a/src/basic/FStar.Options.fsti +++ /dev/null @@ -1,287 +0,0 @@ -(* - Copyright 2008-2020 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Options -open FStar.All -open FStar.Compiler.Effect -open FStar.Getopt -open FStar.BaseTypes -open FStar.VConfig -open FStar.Compiler - -type codegen_t = - | OCaml - | FSharp - | Krml - | Plugin - | Extension - -//let __test_norm_all = Util.mk_ref false - -type split_queries_t = | No | OnFailure | Always - -type message_format_t = | Json | Human - -type option_val = - | Bool of bool - | String of string - | Path of string - | Int of int - | List of list option_val - | Unset - -type optionstate = FStar.Compiler.Util.psmap option_val - -type opt_type = -| Const of option_val - // --cache_checked_modules -| IntStr of string (* label *) - // --z3rlimit 5 -| BoolStr - // --admit_smt_queries true -| PathStr of string (* label *) - // --fstar_home /build/fstar -| SimpleStr of string (* label *) - // --admit_except xyz -| EnumStr of list string - // --codegen OCaml -| OpenEnumStr of list string (* suggested values (not exhaustive) *) & string (* label *) - // --debug … -| PostProcessed of ((option_val -> option_val) (* validator *) & opt_type (* elem spec *)) - // For options like --extract_module that require post-processing or validation -| Accumulated of opt_type (* elem spec *) - // For options like --extract_module that can be repeated (LIFO) -| ReverseAccumulated of opt_type (* elem spec *) - // For options like --include that can be repeated (FIFO) -| WithSideEffect of ((unit -> unit) & opt_type (* elem spec *)) - // For options like --version that have side effects - -val defaults : list (string & option_val) - -val init : unit -> unit //sets the current options to their defaults -val clear : unit -> unit //wipes the stack of options, and then inits -val restore_cmd_line_options : bool -> parse_cmdline_res //inits or clears (if the flag is set) the current options and then sets it to the cmd line - -(* Control the option stack *) -(* Briefly, push/pop are used by the interactive mode and internal_* - * by #push-options/#pop-options. Read the comment in the .fs for more - * details. *) -val push : unit -> unit -val pop : unit -> unit -val internal_push : unit -> unit -val internal_pop : unit -> bool (* returns whether it worked or not, false should be taken as a hard error *) -val depth : unit -> int (* number of elements in internal option stack, besides current. If >0, internal_pop should succeed. *) -val snapshot : unit -> (int & unit) -val rollback : option int -> unit -val peek : unit -> optionstate -val set : optionstate -> unit -val set_verification_options : optionstate -> unit - -(* Print the current optionstate as a string that could be passed to fstar.exe, e.g. -"--z3rlimit 25 --include /some/path" *) -val show_options : unit -> string - -val __unit_tests : unit -> bool -val __set_unit_tests : unit -> unit -val __clear_unit_tests : unit -> unit -val parse_cmd_line : unit -> parse_cmdline_res & list string -val add_verify_module : string -> unit - -val set_option_warning_callback : (string -> unit) -> unit -val desc_of_opt_type : opt_type -> option string -val all_specs_with_types : list (char & string & opt_type & Pprint.document) -val settable : string -> bool - -val abort_counter : ref int - -val admit_smt_queries : unit -> bool -val set_admit_smt_queries : bool -> unit -val admit_except : unit -> option string -val compat_pre_core_should_register : unit -> bool -val compat_pre_core_should_check : unit -> bool -val compat_pre_core_set : unit -> bool -val compat_pre_typed_indexed_effects: unit -> bool -val disallow_unification_guards : unit -> bool -val cache_checked_modules : unit -> bool -val cache_off : unit -> bool -val print_cache_version : unit -> bool -val cmi : unit -> bool -val codegen : unit -> option codegen_t -val parse_codegen : string -> option codegen_t -val codegen_libs : unit -> list (list string) -val profile_enabled : module_name:option string -> profile_phase:string -> bool -val profile_group_by_decl : unit -> bool -val defensive : unit -> bool // true if checks should be performed -val defensive_error : unit -> bool // true if "error" -val defensive_abort : unit -> bool // true if "abort" -val dep : unit -> option string -val detail_errors : unit -> bool -val detail_hint_replay : unit -> bool -val display_usage : unit -> unit -val any_dump_module : unit -> bool -val dump_module : string -> bool -val eager_subtyping : unit -> bool -val error_contexts : unit -> bool -val expose_interfaces : unit -> bool -val message_format : unit -> message_format_t -val file_list : unit -> list string -val force : unit -> bool -val fstar_bin_directory : string -val get_option : string -> option_val -val full_context_dependency : unit -> bool -val hide_uvar_nums : unit -> bool -val hint_info : unit -> bool -val hint_file_for_src : string -> string -val ide : unit -> bool -val ide_id_info_off : unit -> bool -val set_ide_filename : string -> unit -val ide_filename : unit -> option string -val lib_root : unit -> option string -val lib_paths : unit -> list string -val include_path : unit -> list string -val print : unit -> bool -val print_in_place : unit -> bool -val initial_fuel : unit -> int -val initial_ifuel : unit -> int -val interactive : unit -> bool -val keep_query_captions : unit -> bool -val lax : unit -> bool -val load : unit -> list string -val load_cmxs : unit -> list string -val legacy_interactive : unit -> bool -val lsp_server : unit -> bool -val log_queries : unit -> bool -val log_failing_queries : unit -> bool -val log_types : unit -> bool -val max_fuel : unit -> int -val max_ifuel : unit -> int -val ml_ish : unit -> bool -val ml_ish_effect : unit -> string -val set_ml_ish : unit -> unit -val no_default_includes : unit -> bool -val no_location_info : unit -> bool -val no_plugins : unit -> bool -val no_smt : unit -> bool -val normalize_pure_terms_for_extraction - : unit -> bool -val krmloutput : unit -> option string -val list_plugins : unit -> bool -val locate : unit -> bool -val locate_lib : unit -> bool -val locate_ocaml : unit -> bool -val output_deps_to : unit -> option string -val output_dir : unit -> option string -val prepend_cache_dir : string -> string -val prepend_output_dir : string -> string -val custom_prims : unit -> option string -val print_bound_var_types : unit -> bool -val print_effect_args : unit -> bool -val print_expected_failures : unit -> bool -val print_implicits : unit -> bool -val print_real_names : unit -> bool -val print_universes : unit -> bool -val print_z3_statistics : unit -> bool -val proof_recovery : unit -> bool -val quake_lo : unit -> int -val quake_hi : unit -> int -val quake_keep : unit -> bool -val query_cache : unit -> bool -val query_stats : unit -> bool -val read_checked_file : unit -> option string -val read_krml_file : unit -> option string -val record_hints : unit -> bool -val record_options : unit -> bool -val retry : unit -> bool -val reuse_hint_for : unit -> option string -val report_assumes : unit -> option string -val set_option : string -> option_val -> unit -val set_options : string -> parse_cmdline_res -val should_be_already_cached : string -> bool -val should_print_message : string -> bool -val should_extract : string -> codegen_t -> bool -val should_check : string -> bool (* Should check this module, lax or not. *) -val should_check_file : string -> bool (* Should check this file, lax or not. *) -val should_verify : string -> bool (* Should check this module with verification enabled. *) -val should_verify_file : string -> bool (* Should check this file with verification enabled. *) -val silent : unit -> bool -val smt : unit -> option string -val smtencoding_elim_box : unit -> bool -val smtencoding_nl_arith_default: unit -> bool -val smtencoding_nl_arith_wrapped: unit -> bool -val smtencoding_nl_arith_native : unit -> bool -val smtencoding_l_arith_default : unit -> bool -val smtencoding_l_arith_native : unit -> bool -val smtencoding_valid_intro : unit -> bool -val smtencoding_valid_elim : unit -> bool -val split_queries : unit -> split_queries_t -val tactic_raw_binders : unit -> bool -val tactics_failhard : unit -> bool -val tactics_info : unit -> bool -val tactic_trace : unit -> bool -val tactic_trace_d : unit -> int -val tactics_nbe : unit -> bool -val tcnorm : unit -> bool -val timing : unit -> bool -val trace_error : unit -> bool -val ugly : unit -> bool -val unthrottle_inductives : unit -> bool -val unsafe_tactic_exec : unit -> bool -val use_eq_at_higher_order : unit -> bool -val use_hints : unit -> bool -val use_hint_hashes : unit -> bool -val use_native_tactics : unit -> option string -val use_tactics : unit -> bool -val using_facts_from : unit -> list (list string & bool) -val warn_default_effects : unit -> bool -val with_saved_options : (unit -> 'a) -> 'a -val with_options : string -> (unit -> 'a) -> 'a -val z3_cliopt : unit -> list string -val z3_smtopt : unit -> list string -val z3_refresh : unit -> bool -val z3_rlimit : unit -> int -val z3_rlimit_factor : unit -> int -val z3_seed : unit -> int -val z3_version : unit -> string -val no_positivity : unit -> bool -val warn_error : unit -> string -val set_error_flags_callback : ((unit -> parse_cmdline_res) -> unit) -val use_nbe : unit -> bool -val use_nbe_for_extraction : unit -> bool -val trivial_pre_for_unannotated_effectful_fns - : unit -> bool - -(* List of enabled debug toggles. *) -val debug_keys : unit -> list string - -(* Whether we are debugging every module and not just the ones -in the cmdline. *) -val debug_all_modules : unit -> bool - -// HACK ALERT! This is to ensure we have no dependency from Options to Version, -// otherwise, since Version is regenerated all the time, this invalidates the -// whole build tree. A classy technique I learned from the OCaml compiler. -val _version: ref string -val _platform: ref string -val _compiler: ref string -val _date: ref string -val _commit: ref string - -val debug_embedding: ref bool -val eager_embedding: ref bool - -val get_vconfig : unit -> vconfig -val set_vconfig : vconfig -> unit - -instance val showable_codegen_t : Class.Show.showable codegen_t diff --git a/src/basic/FStar.Platform.fsti b/src/basic/FStar.Platform.fsti deleted file mode 100644 index 7b529b4fefd..00000000000 --- a/src/basic/FStar.Platform.fsti +++ /dev/null @@ -1,12 +0,0 @@ -module FStar.Platform -open FStar.Compiler.Effect - -type sys = -| Windows -| Posix - -val system : sys -val exe : string -> string - -(* true if the fstar compiler is compiled from sources extracted to ocaml, false otherwise *) -val is_fstar_compiler_using_ocaml : bool diff --git a/src/basic/FStar.Profiling.fst b/src/basic/FStar.Profiling.fst deleted file mode 100644 index f7a6ed9cb51..00000000000 --- a/src/basic/FStar.Profiling.fst +++ /dev/null @@ -1,125 +0,0 @@ -(* - Copyright 2008-2019 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Profiling -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -module List = FStar.Compiler.List -open FStar.Options -module BU = FStar.Compiler.Util -open FStar.Json - -(* - A counter id is the name of a profiling phase; - The total_time is the cumulative time attributed to this phase. - The running flag records if this phase is currently being measured - The undercount field is set if the total time is known to be undercounted, - e.g., because an exception was raised -*) -type counter = { - cid:string; - total_time:ref int; - running:ref bool; - undercount:ref bool; -} - -let json_of_counter (c: counter) = - JsonAssoc [ - "id", JsonStr c.cid; - "total_time", JsonInt !c.total_time; - "running", JsonBool !c.running; - "undercount", JsonBool !c.undercount; - ] - -(* Creating a new counter *) -let new_counter cid = { - cid = cid; - total_time = BU.mk_ref 0; - running = BU.mk_ref false; - undercount = BU.mk_ref false; -} - -(* A table of all profiling counters, indexed by their cids *) -let all_counters : BU.smap counter = BU.smap_create 20 - -(* Returns the current counter for cid *) -let create_or_lookup_counter cid = - match BU.smap_try_find all_counters cid with - | Some c -> c - | None -> - let c = new_counter cid in - BU.smap_add all_counters cid c; - c - -(* Time an operation, if the the profiler is enabled *) -let profile (f: unit -> 'a) (module_name:option string) (cid:string) : 'a = - if Options.profile_enabled module_name cid - then let c = create_or_lookup_counter cid in - if !c.running //if the counter is already running - then f () //this is a re-entrant call ... don't measure - else begin - try - c.running := true; //mark the counter as running - let res, elapsed = BU.record_time f in - c.total_time := !c.total_time + elapsed; //accumulate the time - c.running := false; //finally mark the counter as not running - res - with - | e -> //finally - c.running := false; //mark the counter as not running - c.undercount := true; //but also set the undercount flag, - //since we didn't get the full elapsed time - raise e //and propagate the exception - end - else f() - -let report_json tag c = - let counter = json_of_counter c in - JsonAssoc [ - "tag", JsonStr tag; - "counter", counter; - ] |> string_of_json |> BU.print1_error "%s\n" - -let report_human tag c = - let warn = if !c.running - then " (Warning, this counter is still running)" - else if !c.undercount - then " (Warning, some operations raised exceptions and we not accounted for)" - else "" - in - //print each counter's profile - BU.print4 "%s, profiled %s:\t %s ms%s\n" - tag - c.cid - (BU.string_of_int (!c.total_time)) - warn - -let report tag c = - match FStar.Options.message_format () with - | Human -> report_human tag c - | Json -> report_json tag c - -(* Report all profiles and clear all counters *) -let report_and_clear tag = - let ctrs = //all the counters as a list - BU.smap_fold all_counters (fun _ v l -> v :: l) [] - in - BU.smap_clear all_counters; //remove them all - let ctrs = //sort counters in descending order by elapsed time - BU.sort_with (fun c1 c2 -> !c2.total_time - !c1.total_time) ctrs - in - List.iter (report tag) ctrs diff --git a/src/basic/FStar.Profiling.fsti b/src/basic/FStar.Profiling.fsti deleted file mode 100644 index d5f4cf1e6c0..00000000000 --- a/src/basic/FStar.Profiling.fsti +++ /dev/null @@ -1,32 +0,0 @@ -(* - Copyright 2008-2019 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Profiling -open FStar.Compiler.Effect - -// When --profile module_name -// And --profile_component component_name -// are both true, measure the execution time of f -// and accumulate it in a profiling counter -// associated with `component_name` -val profile : f:(unit -> 'b) - -> module_name:option string - -> component_name:string - -> 'b - -// Print the elapsed time from all profiling counters -// Prefix the profiling report with the value of `tag` -// And reset all of the profiling counters -val report_and_clear: tag:string -> unit diff --git a/src/basic/FStar.StringBuffer.fsti b/src/basic/FStar.StringBuffer.fsti deleted file mode 100644 index 38669e40fd5..00000000000 --- a/src/basic/FStar.StringBuffer.fsti +++ /dev/null @@ -1,34 +0,0 @@ -(* - Copyright 2008-2019 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.StringBuffer - -open FStar.Compiler.Effect -open FStar.BigInt - -type t - -//This is a **MUTABLE** string buffer -//Although each function here returns a `t` the buffer is mutated in place. - -//The argument convention is chosen so that you can conveniently write code like: -// sb |> add "hello" |> add " world" |> add "!" - - -val create : FStar.BigInt.t -> t -val add: string -> t -> t -val contents: t -> string -val clear: t -> t -val output_channel: FStar.Compiler.Util.out_channel -> t -> unit diff --git a/src/basic/FStar.Thunk.fst b/src/basic/FStar.Thunk.fst deleted file mode 100644 index 981745b13be..00000000000 --- a/src/basic/FStar.Thunk.fst +++ /dev/null @@ -1,35 +0,0 @@ -(* - Copyright 2008-2019 Microsoft Research - - Authors: Aseem Rastogi, Nikhil Swamy, Jonathan Protzenko - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Thunk -open FStar.Compiler.Effect - -type thunk (a:Type) : Type = ref (either (unit -> a) a) - -let mk (f:unit -> 'a) : thunk 'a = alloc (Inl f) -let mkv (v:'a) : thunk 'a = alloc (Inr v) - -let force (t:thunk 'a) = - match !t with - | Inr a -> a - | Inl f -> - let a = f () in - t := Inr a; - a - -let map (f : 'a -> 'b) (t:thunk 'a) : thunk 'b = - mk (fun () -> f (force t)) diff --git a/src/basic/FStar.Thunk.fsti b/src/basic/FStar.Thunk.fsti deleted file mode 100644 index 10ba1a924e8..00000000000 --- a/src/basic/FStar.Thunk.fsti +++ /dev/null @@ -1,32 +0,0 @@ -(* - Copyright 2008-2019 Microsoft Research - - Authors: Aseem Rastogi, Nikhil Swamy, Jonathan Protzenko - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Thunk -open FStar.Compiler.Effect - -val thunk (a:Type0) : Type0 -type t 'a = thunk 'a - -(* Creating thunks *) -val mk : (unit -> 'a) -> thunk 'a -val mkv : 'a -> thunk 'a - -(* Forcing *) -val force : thunk 'a -> 'a - -(* Mapping an operation over the thunk, lazily *) -val map : ('a -> 'b) -> thunk 'a -> thunk 'b diff --git a/src/basic/FStar.Unionfind.fsti b/src/basic/FStar.Unionfind.fsti deleted file mode 100644 index 65bb0f44718..00000000000 --- a/src/basic/FStar.Unionfind.fsti +++ /dev/null @@ -1,38 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Unionfind - -open FStar.Compiler.Effect - -type puf 'a -type p_uvar 'a -val puf_empty: unit -> puf 'a -val puf_fresh: puf 'a -> 'a -> p_uvar 'a -val puf_id: puf 'a -> p_uvar 'a -> int -val puf_fromid: puf 'a -> int -> p_uvar 'a -val puf_find: puf 'a -> p_uvar 'a -> 'a -val puf_union: puf 'a -> p_uvar 'a -> p_uvar 'a -> puf 'a -val puf_equivalent: puf 'a -> p_uvar 'a -> p_uvar 'a -> bool -val puf_change: puf 'a -> p_uvar 'a -> 'a -> puf 'a -val puf_test: unit -> unit - -// -// Returns the unique id of the input uvar -// This is different from puf_id, that returns the -// unique id of the root of the uf tree that the input -// uvar belongs to -// -val puf_unique_id: p_uvar 'a -> int diff --git a/src/basic/FStar.VConfig.fst b/src/basic/FStar.VConfig.fst deleted file mode 100644 index eb8e012a566..00000000000 --- a/src/basic/FStar.VConfig.fst +++ /dev/null @@ -1,18 +0,0 @@ -(* - Copyright 2008-2020 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.VConfig - -(* This file here to trigger extraction. *) diff --git a/src/basic/FStar.VConfig.fsti b/src/basic/FStar.VConfig.fsti deleted file mode 100644 index 965626a14d8..00000000000 --- a/src/basic/FStar.VConfig.fsti +++ /dev/null @@ -1,55 +0,0 @@ -(* - Copyright 2008-2018 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.VConfig - -(** This type represents the set of verification-relevant options used - to check a particular definition. It can be read from tactics via - sigelt_opts and set via the check_with attribute. - *) -type vconfig = { - initial_fuel : int; - max_fuel : int; - initial_ifuel : int; - max_ifuel : int; - detail_errors : bool; - detail_hint_replay : bool; - no_smt : bool; - quake_lo : int; - quake_hi : int; - quake_keep : bool; - retry : bool; - smtencoding_elim_box : bool; - smtencoding_nl_arith_repr : string; - smtencoding_l_arith_repr : string; - smtencoding_valid_intro : bool; - smtencoding_valid_elim : bool; - tcnorm : bool; - no_plugins : bool; - no_tactics : bool; - z3cliopt : list string; - z3smtopt : list string; - z3refresh : bool; - z3rlimit : int; - z3rlimit_factor : int; - z3seed : int; - z3version : string; - trivial_pre_for_unannotated_effectful_fns : bool; - reuse_hint_for : option string; -} - -(** Marker to check a sigelt with a particular vconfig, not really used internally.. *) -irreducible -let check_with (vcfg : vconfig) : unit = () diff --git a/src/basic/FStar.Version.fsti b/src/basic/FStar.Version.fsti deleted file mode 100644 index 31ab12cc6d3..00000000000 --- a/src/basic/FStar.Version.fsti +++ /dev/null @@ -1,19 +0,0 @@ -(* - Copyright 2008-2014 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Version -open FStar.Compiler.Effect - -val dummy: unit -> unit diff --git a/src/basic/FStarC.BaseTypes.fsti b/src/basic/FStarC.BaseTypes.fsti new file mode 100644 index 00000000000..9aff903d8f5 --- /dev/null +++ b/src/basic/FStarC.BaseTypes.fsti @@ -0,0 +1,33 @@ +(* + Copyright 2008-2023 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.BaseTypes + +/// This module aggregates commonly used primitive type constants into +/// a single module, providing abbreviations for them. + +type char = FStar.Char.char +type float +type double +type byte +type int8 +type uint8 +type int16 +type uint16 +type int32 +type uint32 +type int64 +type uint64 diff --git a/src/basic/FStarC.Basefiles.fst b/src/basic/FStarC.Basefiles.fst new file mode 100644 index 00000000000..7109ba5184e --- /dev/null +++ b/src/basic/FStarC.Basefiles.fst @@ -0,0 +1,26 @@ +module FStarC.Basefiles + +open FStarC +open FStarC.Compiler.Effect + +module O = FStarC.Options +module BU = FStarC.Compiler.Util +module E = FStarC.Errors + +let must_find (fn:string) : string = + match Find.find_file fn with + | Some f -> f + | None -> + E.raise_error0 E.Fatal_ModuleNotFound [ + E.text (BU.format1 "Unable to find required file \"%s\" in the module search path." fn); + ] + +let prims () = + match O.custom_prims() with + | Some fn -> fn (* user-specified prims *) + | None -> must_find "Prims.fst" + +let prims_basename () = BU.basename (prims ()) +let pervasives () = must_find "FStar.Pervasives.fsti" +let pervasives_basename () = BU.basename (pervasives ()) +let pervasives_native_basename () = must_find "FStar.Pervasives.Native.fst" |> BU.basename diff --git a/src/basic/FStarC.Basefiles.fsti b/src/basic/FStarC.Basefiles.fsti new file mode 100644 index 00000000000..f1653beaa4d --- /dev/null +++ b/src/basic/FStarC.Basefiles.fsti @@ -0,0 +1,9 @@ +module FStarC.Basefiles + +open FStarC.Compiler.Effect + +val prims : unit -> string +val prims_basename : unit -> string +val pervasives : unit -> string +val pervasives_basename : unit -> string +val pervasives_native_basename : unit -> string diff --git a/src/basic/FStarC.BigInt.fsti b/src/basic/FStarC.BigInt.fsti new file mode 100644 index 00000000000..71bdc97a150 --- /dev/null +++ b/src/basic/FStarC.BigInt.fsti @@ -0,0 +1,59 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.BigInt +open FStarC.Compiler.Effect + +type bigint +type t = bigint + +val zero : bigint +val one : bigint +val two : bigint + +val succ_big_int : (bigint -> bigint) +val pred_big_int : (bigint -> bigint) +val minus_big_int : (bigint -> bigint) +val abs_big_int : (bigint -> bigint) + +val add_big_int : (bigint -> bigint -> bigint) +val mult_big_int : (bigint -> bigint -> bigint) +val sub_big_int : (bigint -> bigint -> bigint) +val div_big_int : (bigint -> bigint -> bigint) +val mod_big_int : (bigint -> bigint -> bigint) + +val eq_big_int : (bigint -> bigint -> bool) +val le_big_int : (bigint -> bigint -> bool) +val lt_big_int : (bigint -> bigint -> bool) +val ge_big_int : (bigint -> bigint -> bool) +val gt_big_int : (bigint -> bigint -> bool) + +val logand_big_int: bigint -> bigint -> bigint +val logor_big_int: bigint -> bigint -> bigint +val logxor_big_int: bigint -> bigint -> bigint +val lognot_big_int: bigint -> bigint + +val shift_left_big_int: bigint -> bigint -> bigint +val shift_right_big_int: bigint -> bigint -> bigint + +val sqrt_big_int : (bigint -> bigint) + +val string_of_big_int : (bigint -> string) +val big_int_of_string : (string -> bigint) + +val of_int_fs: (int -> bigint) +val to_int_fs: (bigint -> int) + +val of_hex: string -> bigint diff --git a/src/basic/FStarC.Char.fsti b/src/basic/FStarC.Char.fsti new file mode 100644 index 00000000000..271b643db3b --- /dev/null +++ b/src/basic/FStarC.Char.fsti @@ -0,0 +1,32 @@ +(* + Copyright 2008-2023 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Char + +(* This is a trimmed-down version of ulib/FStar.Char, realized by the +same ML implementation. It is here to prevent dependencies from the +compiler into the UInt32 module. *) + +new +val char:eqtype + +type char_code + +val int_of_char : char -> Tot int +val char_of_int : int -> Tot char + +val lowercase: char -> Tot char +val uppercase: char -> Tot char diff --git a/src/basic/FStarC.Common.fst b/src/basic/FStarC.Common.fst new file mode 100644 index 00000000000..e82f0e9703b --- /dev/null +++ b/src/basic/FStarC.Common.fst @@ -0,0 +1,156 @@ +(* + Copyright 2008-2017 Microsoft Research + + Authors: Aseem Rastogi, Nikhil Swamy, Jonathan Protzenko + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Common +open FStarC.Compiler.Effect +module List = FStarC.Compiler.List +module BU = FStarC.Compiler.Util + +let has_cygpath = + try + let t_out = BU.run_process "has_cygpath" "which" ["cygpath"] None in + BU.trim_string t_out = "/usr/bin/cygpath" + with + | _ -> false + +//try to convert filename passed from the editor to mixed path +//that works on both cygwin and native windows +//noop if not on cygwin +//on cygwin emacs this is required + +let try_convert_file_name_to_mixed = + let cache = BU.smap_create 20 in + fun (s:string) -> + if has_cygpath + && BU.starts_with s "/" then + match BU.smap_try_find cache s with + | Some s -> + s + | None -> + let label = "try_convert_file_name_to_mixed" in + let out = BU.run_process label "cygpath" ["-m"; s] None |> BU.trim_string in + BU.smap_add cache s out; + out + else + s + +let snapshot (push: 'a -> 'b) (stackref: ref (list 'c)) (arg: 'a) : (int & 'b) = BU.atomically (fun () -> + let len : int = List.length !stackref in + let arg' = push arg in + (len, arg')) + +let rollback (pop: unit -> 'a) (stackref: ref (list 'c)) (depth: option int) = + let rec aux n = + if n <= 0 then failwith "Too many pops" + else if n = 1 then pop () + else (ignore (pop ()); aux (n - 1)) in + let curdepth = List.length !stackref in + let n = match depth with Some d -> curdepth - d | None -> 1 in + BU.atomically (fun () -> aux n) + +// This function is separate to make it easier to put breakpoints on it +let raise_failed_assertion msg = + failwith (BU.format1 "Assertion failed: %s" msg) + +let runtime_assert b msg = + if not b then raise_failed_assertion msg + +let __string_of_list (delim:string) (f : 'a -> string) (l : list 'a) : string = + match l with + | [] -> "[]" + | x::xs -> + let strb = BU.new_string_builder () in + BU.string_builder_append strb "["; + BU.string_builder_append strb (f x); + List.iter (fun x -> + BU.string_builder_append strb delim; + BU.string_builder_append strb (f x) + ) xs ; + BU.string_builder_append strb "]"; + BU.string_of_string_builder strb + +(* Why two? This function was added during a refactoring, and +both variants existed. We cannot simply move to ";" since that is a +breaking change to anything that parses F* source code (like Vale). *) +let string_of_list = __string_of_list ", " +let string_of_list' = __string_of_list "; " + +let list_of_option (o:option 'a) : list 'a = + match o with + | None -> [] + | Some x -> [x] + +let string_of_option f = function + | None -> "None" + | Some x -> "Some " ^ f x + +(* Was List.init, but F* doesn't have this in ulib *) +let tabulate (n:int) (f : int -> 'a) : list 'a = + let rec aux i = + if i < n + then f i :: aux (i + 1) + else [] + in aux 0 + +(** max_prefix f xs returns (l, r) such that + * every x in l satisfies f + * l@r == xs + * and l is the largest list satisfying that + *) +let rec max_prefix (f : 'a -> bool) (xs : list 'a) : list 'a & list 'a = + match xs with + | [] -> [], [] + | x::xs when f x -> + let l, r = max_prefix f xs in + (x::l, r) + | x::xs -> + ([], x::xs) + +(** max_suffix f xs returns (l, r) such that + * every x in r satisfies f + * l@r == xs + * and r is the largest list satisfying that + *) +let max_suffix (f : 'a -> bool) (xs : list 'a) : list 'a & list 'a = + let rec aux acc xs = + match xs with + | [] -> acc, [] + | x::xs when f x -> + aux (x::acc) xs + | x::xs -> + (acc, x::xs) + in + xs |> List.rev |> aux [] |> (fun (xs, ys) -> List.rev ys, xs) + +let rec eq_list (f: 'a -> 'a -> bool) (l1 l2 : list 'a) + : bool + = match l1, l2 with + | [], [] -> true + | [], _ | _, [] -> false + | x1::t1, x2::t2 -> f x1 x2 && eq_list f t1 t2 + +let psmap_to_list m = + BU.psmap_fold m (fun k v a -> (k,v)::a) [] +let psmap_keys m = + BU.psmap_fold m (fun k v a -> k::a) [] +let psmap_values m = + BU.psmap_fold m (fun k v a -> v::a) [] + +let option_to_list = function + | None -> [] + | Some x -> [x] diff --git a/src/basic/FStarC.Compiler.Bytes.fsti b/src/basic/FStarC.Compiler.Bytes.fsti new file mode 100644 index 00000000000..596147aed33 --- /dev/null +++ b/src/basic/FStarC.Compiler.Bytes.fsti @@ -0,0 +1,36 @@ +(* + Copyright 2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Compiler.Bytes +open FStarC.Compiler.Effect +open FStarC.BaseTypes + +type bytes = array byte +val length : bytes -> int +val get: bytes -> int -> int +val zero_create : int -> bytes +val string_as_unicode_bytes: string -> bytes +val unicode_bytes_as_string: bytes -> string +val utf8_bytes_as_string: bytes -> string +val append: bytes -> bytes -> bytes +val make: (int -> int) -> int -> bytes + +type bytebuf +val create: int -> bytebuf +val close : bytebuf -> bytes +val emit_int_as_byte: bytebuf -> int -> unit +val emit_bytes: bytebuf -> bytes -> unit + +val f_encode: (byte -> string) -> bytes -> string diff --git a/src/basic/FStarC.Compiler.Debug.fst b/src/basic/FStarC.Compiler.Debug.fst new file mode 100644 index 00000000000..4eea278f0cd --- /dev/null +++ b/src/basic/FStarC.Compiler.Debug.fst @@ -0,0 +1,104 @@ +(* + Copyright 2008-2020 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Compiler.Debug + +module BU = FStarC.Compiler.Util + +(* Mutable state *) +let anyref = BU.mk_ref false +let _debug_all : ref bool = BU.mk_ref false +let toggle_list : ref (list (string & ref bool)) = + BU.mk_ref [] + +type saved_state = { + toggles : list (string & bool); + any : bool; + all : bool; +} + +let snapshot () : saved_state = { + toggles = !toggle_list |> List.map (fun (k, r) -> (k, !r)); + any = !anyref; + all = !_debug_all; +} + +let register_toggle (k : string) : ref bool = + let r = BU.mk_ref false in + if !_debug_all then + r := true; + toggle_list := (k, r) :: !toggle_list; + r + +let get_toggle (k : string) : ref bool = + match List.tryFind (fun (k', _) -> k = k') !toggle_list with + | Some (_, r) -> r + | None -> register_toggle k + +let restore (snapshot : saved_state) : unit = + (* Set everything to false, then set all the saved ones + to true. *) + !toggle_list |> List.iter (fun (_, r) -> r := false); + snapshot.toggles |> List.iter (fun (k, b) -> + let r = get_toggle k in + r := b); + (* Also restore these references. *) + anyref := snapshot.any; + _debug_all := snapshot.all; + () + +let list_all_toggles () : list string = + List.map fst !toggle_list + +let any () = !anyref || !_debug_all + +let tag (s:string) = + if any () then + BU.print_string ("DEBUG:" ^ s ^ "\n") + +let enable () = anyref := true + +let dbg_level = BU.mk_ref 0 + +let low () = !dbg_level >= 1 || !_debug_all +let medium () = !dbg_level >= 2 || !_debug_all +let high () = !dbg_level >= 3 || !_debug_all +let extreme () = !dbg_level >= 4 || !_debug_all + +let set_level_low () = dbg_level := 1 +let set_level_medium () = dbg_level := 2 +let set_level_high () = dbg_level := 3 +let set_level_extreme () = dbg_level := 4 + +let enable_toggles (keys : list string) : unit = + if Cons? keys then enable (); + keys |> List.iter (fun k -> + if k = "Low" then set_level_low () + else if k = "Medium" then set_level_medium () + else if k = "High" then set_level_high () + else if k = "Extreme" then set_level_extreme () + else + let t = get_toggle k in + t := true + ) + +let disable_all () : unit = + anyref := false; + dbg_level := 0; + List.iter (fun (_, r) -> r := false) !toggle_list + +let set_debug_all () : unit = + _debug_all := true diff --git a/src/basic/FStarC.Compiler.Debug.fsti b/src/basic/FStarC.Compiler.Debug.fsti new file mode 100644 index 00000000000..0846155220d --- /dev/null +++ b/src/basic/FStarC.Compiler.Debug.fsti @@ -0,0 +1,69 @@ +(* + Copyright 2008-2020 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Compiler.Debug + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect + +(* State handling for this module. Used by FStarC.Options, which +is the only module that modifies the debug state. *) +val saved_state : Type0 +val snapshot () : saved_state +val restore (s:saved_state) : unit + +(* Enable debugging. This will make any() return true, but +does not enable any particular toggle. *) +val enable () : unit + +(* Are we doing *any* kind of debugging? *) +val any () : bool + +(* Print a quick message on stdout whenever debug is on. If the string +is not a constant, put this under an if to thunk it. *) +val tag (s : string) : unit + +(* Obtain the toggle for a given debug key *) +val get_toggle (k : string) : ref bool + +(* List all registered toggles *) +val list_all_toggles () : list string + +(* Vanilla debug levels. Each level implies the previous lower one. *) +val low () : bool +val medium () : bool +val high () : bool +val extreme () : bool + +(* Enable a list of debug toggles. If will also call enable() +is key is non-empty, and will recognize "Low", "Medium", +"High", "Extreme" as special and call the corresponding +set_level_* function. *) +val enable_toggles (keys : list string) : unit + +(* Sets the debug level to zero and sets all registered toggles +to false. any() will return false after this. *) +val disable_all () : unit + +(* Nuclear option: enable ALL debug toggles. *) +val set_debug_all () : unit + +(* Not used externally at the moment. *) +val set_level_low () : unit +val set_level_medium () : unit +val set_level_high () : unit +val set_level_extreme () : unit diff --git a/src/basic/FStarC.Compiler.Effect.fsti b/src/basic/FStarC.Compiler.Effect.fsti new file mode 100644 index 00000000000..9be20e2d2ff --- /dev/null +++ b/src/basic/FStarC.Compiler.Effect.fsti @@ -0,0 +1,60 @@ +(* + Copyright 2008-2017 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Compiler.Effect + +new_effect ALL = ALL_h unit + +let all_pre = all_pre_h unit +let all_post' (a : Type) (pre:Type) = all_post_h' unit a pre +let all_post (a : Type) = all_post_h unit a +let all_wp (a : Type) = all_wp_h unit a + +let lift_pure_all (a:Type) (p:pure_wp a) + : all_wp a + = fun post h -> p (fun x -> post (V x) h) + +sub_effect PURE ~> ALL { lift_wp = lift_pure_all } + +sub_effect DIV ~> ALL { lift_wp = lift_pure_all } + +effect All (a:Type) (pre:all_pre) (post:(h:unit -> Tot (all_post' a (pre h)))) = + ALL a + (fun (p : all_post a) (h : unit) -> pre h /\ (forall ra h1. post h ra h1 ==> p ra h1)) + +effect ML (a:Type) = ALL a (fun (p:all_post a) (_:unit) -> forall (a:result a) (h:unit). p a h) + +new +val ref (a:Type) : Type0 + +val (!) (#a:Type) (r:ref a) + : ML a + +val (:=) (#a:Type) (r:ref a) (x:a) + : ML unit + +val alloc (#a:Type) (x:a) + : ML (ref a) + +val raise (e: exn) : ML 'a + +val exit : int -> ML 'a + +val try_with : (unit -> ML 'a) -> (exn -> ML 'a) -> ML 'a + +exception Failure of string + +val failwith : string -> ML 'a diff --git a/src/basic/FStarC.Compiler.Hints.fsti b/src/basic/FStarC.Compiler.Hints.fsti new file mode 100644 index 00000000000..fed6c7d33b9 --- /dev/null +++ b/src/basic/FStarC.Compiler.Hints.fsti @@ -0,0 +1,31 @@ +module FStarC.Compiler.Hints + +open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect + +(** Hints. *) +type hint = { + hint_name:string; //name associated to the top-level term in the source program + hint_index:int; //the nth query associated with that top-level term + fuel:int; //fuel for unrolling recursive functions + ifuel:int; //fuel for inverting inductive datatypes + unsat_core:option (list string); //unsat core, if requested + query_elapsed_time:int; //time in milliseconds taken for the query, to decide if a fresh replay is worth it + hash:option string; //hash of the smt2 query that last succeeded +} + +type hints = list (option hint) + +type hints_db = { + module_digest:string; + hints: hints +} + +type hints_read_result = + | HintsOK of hints_db + | MalformedJson + | UnableToOpen + +val write_hints: string -> hints_db -> unit +val read_hints: string -> hints_read_result diff --git a/src/basic/FStarC.Compiler.List.fsti b/src/basic/FStarC.Compiler.List.fsti new file mode 100644 index 00000000000..0ec10ad4263 --- /dev/null +++ b/src/basic/FStarC.Compiler.List.fsti @@ -0,0 +1,79 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + *) +module FStarC.Compiler.List +open FStarC.Compiler.Effect +open Prims + +val isEmpty : (list 'a) -> Tot bool +val singleton : 'a -> list 'a +val hd : (list 'a) -> 'a +val length : (list 'a) -> Tot nat +val nth : (list 'a) -> int -> 'a +val rev_acc : (list 'a) -> (list 'a) -> Tot (list 'a) +val rev : (list 'a) -> Tot (list 'a) +val append : (list 'a) -> (list 'a) -> Tot (list 'a) +val ( @ ) : (list 'a) -> (list 'a) -> Tot (list 'a) +val flatten : (list (list 'a)) -> Tot (list 'a) +val iter : ('a -> unit) -> (list 'a) -> unit +val iter2 : ('a -> 'b -> unit) -> (list 'a) -> list 'b -> unit +val iteri : (int -> 'a -> unit) -> (list 'a) -> unit +val map : ('a -> 'b) -> (list 'a) -> (list 'b) +val mapi_init : (int -> 'a -> 'b) -> (list 'a) -> int -> (list 'b) +val mapi : (int -> 'a -> 'b) -> (list 'a) -> (list 'b) +val concatMap : ('a -> (list 'b)) -> (list 'a) -> (list 'b) +val map2 : ('a -> 'b -> 'c) -> (list 'a) -> (list 'b) -> (list 'c) +val map3 : ('a -> 'b -> 'c -> 'd) -> (list 'a) -> (list 'b) -> (list 'c) -> (list 'd) +val fold_left : ('a -> 'b -> 'a) -> 'a -> (list 'b) -> 'a +val fold_left2 : ('s -> 'a -> 'b -> 's) -> 's -> (list 'a) -> (list 'b) -> 's +val fold_right : ('a -> 'b -> 'b) -> (list 'a) -> 'b -> 'b +val fold_right2 : ('a -> 'b -> 'c -> 'c) -> list 'a -> list 'b -> 'c -> 'c +val rev_map_onto : ('a -> 'b) -> (list 'a) -> (list 'b) -> (list 'b) +val init : (list 'a) -> list 'a +val last : (list 'a) -> 'a +val last_opt : list 'a -> option 'a +val existsb : f:('a -> bool) -> (list 'a) -> bool +val existsML : f:('a -> bool) -> (list 'a) -> bool +val find : f:('a -> bool) -> (list 'a) -> (option 'a) +val filter : ('a -> bool) -> (list 'a) -> (list 'a) +val for_all : ('a -> bool) -> (list 'a) -> bool +val forall2 : ('a -> 'b -> bool) -> (list 'a) -> (list 'b) -> bool +val collect : ('a -> (list 'b)) -> (list 'a) -> (list 'b) +val tryFind : ('a -> bool) -> (list 'a) -> (option 'a) +val tryPick : ('a -> (option 'b)) -> (list 'a) -> (option 'b) +val choose : ('a -> (option 'b)) -> (list 'a) -> (list 'b) +val partition : ('a -> bool) -> (list 'a) -> ((list 'a) & (list 'a)) +val splitAt : int -> list 'a -> list 'a & list 'a +val split : (list ('a & 'b)) -> Tot ((list 'a) & (list 'b)) +val unzip3 : list ('a & 'b & 'c) -> Tot ((list 'a) & (list 'b) & (list 'c)) +val zip : (list 'a) -> (list 'b) -> (list ('a & 'b)) +val zip3 : (list 'a) -> (list 'b) -> (list 'c) -> (list ('a & 'b & 'c)) +val sortWith : ('a -> 'a -> int) -> (list 'a) -> (list 'a) +val bool_of_compare : ('a -> 'a -> Tot int) -> 'a -> 'a -> Tot bool +val tail : (list '_1225) -> (list '_1225) +val tl : list '_1230 -> list '_1230 +val rev_append : (list '_5110) -> (list '_5110) -> Tot (list '_5110) +val concat : (list (list '_6116)) -> Tot (list '_6116) +val unzip : (list ('_36948 & '_36947)) -> Tot ((list '_36948) & (list '_36947)) +val filter_map: ('a -> option 'b) -> list 'a -> list 'b +val count: #a:eqtype -> a -> (list a) -> Tot nat +val mem: #a:eqtype -> a -> (list a) -> Tot bool +val assoc: #a:eqtype -> #b:Type -> a -> (list (a & b)) -> Tot (option b) +val contains: #a:eqtype -> a -> (list a) -> Tot bool +val unique: #a:eqtype -> list a -> list a +val index: #a:eqtype -> (a -> bool) -> list a -> int +val span: #a:eqtype -> (a -> bool) -> list a -> Tot ((list a) & (list a)) +val deduplicate (f: 'a -> 'a -> bool) (s: list 'a) : list 'a +val fold_left_map (f: 'a -> 'b -> 'a & 'c) (s: 'a) (l: list 'b) : 'a & list 'c diff --git a/src/basic/FStarC.Compiler.MachineInts.fst b/src/basic/FStarC.Compiler.MachineInts.fst new file mode 100644 index 00000000000..b7420b0c020 --- /dev/null +++ b/src/basic/FStarC.Compiler.MachineInts.fst @@ -0,0 +1,171 @@ +module FStarC.Compiler.MachineInts + +(* A type representing all the kinds of machine integers, and an +embedding instance for them. *) + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Syntax.Syntax + +module EMB = FStarC.Syntax.Embeddings +module NBE = FStarC.TypeChecker.NBETerm +module PC = FStarC.Parser.Const +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module U = FStarC.Syntax.Util +module Z = FStarC.BigInt + +open FStarC.Class.Show +open FStarC.Class.Monad + +let all_machint_kinds = + [Int8; Int16; Int32; Int64; UInt8; UInt16; UInt32; UInt64; UInt128; SizeT] + +let is_unsigned (k : machint_kind) : bool = + match k with + | Int8 + | Int16 + | Int32 + | Int64 -> false + | UInt8 + | UInt16 + | UInt32 + | UInt64 + | UInt128 + | SizeT -> true +let is_signed k = not (is_unsigned k) + +let width (k : machint_kind) : int = + match k with + | Int8 -> 8 + | Int16 -> 16 + | Int32 -> 32 + | Int64 -> 64 + | UInt8 -> 8 + | UInt16 -> 16 + | UInt32 -> 32 + | UInt64 -> 64 + | UInt128 -> 128 + | SizeT -> 64 + +let module_name_for (k:machint_kind) : string = + match k with + | Int8 -> "Int8" + | Int16 -> "Int16" + | Int32 -> "Int32" + | Int64 -> "Int64" + | UInt8 -> "UInt8" + | UInt16 -> "UInt16" + | UInt32 -> "UInt32" + | UInt64 -> "UInt64" + | UInt128 -> "UInt128" + | SizeT -> "SizeT" + +let mask (k:machint_kind) : Z.t = + match width k with + | 8 -> Z.of_hex "ff" + | 16 -> Z.of_hex "ffff" + | 32 -> Z.of_hex "ffffffff" + | 64 -> Z.of_hex "ffffffffffffffff" + | 128 -> Z.of_hex "ffffffffffffffffffffffffffffffff" + +let int_to_t_lid_for (k:machint_kind) : Ident.lid = + let path = "FStar" :: module_name_for k :: (if is_unsigned k then "uint_to_t" else "int_to_t") :: [] in + Ident.lid_of_path path Range.dummyRange + +let int_to_t_for (k:machint_kind) : S.term = + let lid = int_to_t_lid_for k in + S.fvar lid None + +let __int_to_t_lid_for (k:machint_kind) : Ident.lid = + let path = "FStar" :: module_name_for k :: (if is_unsigned k then "__uint_to_t" else "__int_to_t") :: [] in + Ident.lid_of_path path Range.dummyRange + +let __int_to_t_for (k:machint_kind) : S.term = + let lid = __int_to_t_lid_for k in + S.fvar lid None + +(* just a newtype really, no checks or conditions here *) +type machint (k : machint_kind) = | Mk : Z.t -> option S.meta_source_info -> machint k + +let mk #k x m = Mk #k x m +let v #k (x : machint k) = + let Mk v _ = x in v +let meta #k (x : machint k) = + let Mk _ meta = x in meta +let make_as #k (x : machint k) (z : Z.t) : machint k = + Mk z (meta x) + +(* just for debugging *) +instance showable_bounded_k k : Tot (showable (machint k)) = { + show = (function Mk x m -> "machine integer " ^ show (Z.to_int_fs x) ^ "@@" ^ module_name_for k); +} + +instance e_machint (k : machint_kind) : Tot (EMB.embedding (machint k)) = + let with_meta_ds r t (m:option meta_source_info) = + match m with + | None -> t + | Some m -> S.mk (Tm_meta {tm=t; meta=Meta_desugared m}) r + in + let em (x : machint k) rng shadow cb = + let Mk i m = x in + let it = EMB.embed i rng None cb in + let int_to_t = int_to_t_for k in + let t = S.mk_Tm_app int_to_t [S.as_arg it] rng in + with_meta_ds rng t m + in + let un (t:term) cb : option (machint k) = + let (t, m) = + (match (SS.compress t).n with + | Tm_meta {tm=t; meta=Meta_desugared m} -> (t, Some m) + | _ -> (t, None)) + in + let t = U.unmeta_safe t in + match (SS.compress t).n with + | Tm_app {hd; args=[(a,_)]} when U.is_fvar (int_to_t_lid_for k) hd + || U.is_fvar (__int_to_t_lid_for k) hd -> + let a = U.unlazy_emb a in + let! a : Z.t = EMB.try_unembed a cb in + Some (Mk a m) + | _ -> + None + in + EMB.mk_emb_full em un + (fun () -> S.fvar (Ident.lid_of_path ["FStar"; module_name_for k; "t"] Range.dummyRange) None) + (fun _ -> "boundedint") + (fun () -> ET_abstract) + +instance nbe_machint (k : machint_kind) : Tot (NBE.embedding (machint k)) = + let open NBE in + let with_meta_ds t (m:option meta_source_info) = + match m with + | None -> t + | Some m -> NBE.mk_t (Meta(t, Thunk.mk (fun _ -> Meta_desugared m))) + in + let em cbs (x : machint k) = + let Mk i m = x in + let it = embed e_int cbs i in + let int_to_t args = mk_t <| FV (S.lid_as_fv (__int_to_t_lid_for k) None, [], args) in + let t = int_to_t [as_arg it] in + with_meta_ds t m + in + let un cbs a : option (machint k) = + let (a, m) = + (match a.nbe_t with + | Meta(t, tm) -> + (match Thunk.force tm with + | Meta_desugared m -> (t, Some m) + | _ -> (a, None)) + | _ -> (a, None)) + in + match a.nbe_t with + | FV (fv1, [], [(a, _)]) when Ident.lid_equals (fv1.fv_name.v) (int_to_t_lid_for k) -> + let! a : Z.t = unembed e_int cbs a in + Some (Mk a m) + | _ -> None + in + mk_emb em un + (fun () -> mkFV (lid_as_fv (Ident.lid_of_path ["FStar"; module_name_for k; "t"] Range.dummyRange) None) [] []) + (fun () -> ET_abstract) + diff --git a/src/basic/FStarC.Compiler.MachineInts.fsti b/src/basic/FStarC.Compiler.MachineInts.fsti new file mode 100644 index 00000000000..0e5bd4d052a --- /dev/null +++ b/src/basic/FStarC.Compiler.MachineInts.fsti @@ -0,0 +1,48 @@ +module FStarC.Compiler.MachineInts + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect + +module EMB = FStarC.Syntax.Embeddings +module NBE = FStarC.TypeChecker.NBETerm +module S = FStarC.Syntax.Syntax +module Z = FStarC.BigInt + +open FStarC.Class.Show + +type machint_kind = + | Int8 + | Int16 + | Int32 + | Int64 + | UInt8 + | UInt16 + | UInt32 + | UInt64 + | UInt128 + | SizeT + +val all_machint_kinds : list machint_kind + +val is_unsigned (k : machint_kind) : bool +val is_signed (k : machint_kind) : bool +val width (k : machint_kind) : int +val module_name_for (k:machint_kind) : string +val mask (k:machint_kind) : Z.t + +new val machint (k : machint_kind) : Type0 + +val mk (#k:_) (i : Z.t) (m : option S.meta_source_info) : machint k // no checks at all, use with care +val v #k (x : machint k) : Z.t +val meta #k (x : machint k) : option S.meta_source_info + +(* Make a machint k copying the meta off an existing one *) +val make_as #k (x : machint k) (z : Z.t) : machint k + +instance val showable_bounded_k k : Tot (showable (machint k)) +instance val e_machint (k : machint_kind) : Tot (EMB.embedding (machint k)) + +instance val nbe_machint (k : machint_kind) : Tot (NBE.embedding (machint k)) +// ^ This instance being here is slightly fishy. It blows up the dependency +// graph of this module. diff --git a/src/basic/FStarC.Compiler.Misc.fst b/src/basic/FStarC.Compiler.Misc.fst new file mode 100644 index 00000000000..f9039b6db12 --- /dev/null +++ b/src/basic/FStarC.Compiler.Misc.fst @@ -0,0 +1,16 @@ +module FStarC.Compiler.Misc + +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.Util + +open FStarC.Compiler.Order +open FStar.String + +let compare_version (v1 v2 : string) : order = + let cs1 = String.split ['.'] v1 |> List.map int_of_string in + let cs2 = String.split ['.'] v2 |> List.map int_of_string in + compare_list cs1 cs2 compare_int + +let version_gt v1 v2 = compare_version v1 v2 = Gt +let version_ge v1 v2 = compare_version v1 v2 <> Lt diff --git a/src/basic/FStarC.Compiler.Misc.fsti b/src/basic/FStarC.Compiler.Misc.fsti new file mode 100644 index 00000000000..d0a18fc1fa8 --- /dev/null +++ b/src/basic/FStarC.Compiler.Misc.fsti @@ -0,0 +1,10 @@ +module FStarC.Compiler.Misc + +open FStarC.Compiler.Effect + +(* This functions compare version numbers. E.g. "4.8.5" and "4.12.3". +NOTE: the versions cannot contain any alphabetic character, only numbers +are allowed for now. *) + +val version_gt : string -> string -> bool +val version_ge : string -> string -> bool diff --git a/src/basic/FStarC.Compiler.Option.fst b/src/basic/FStarC.Compiler.Option.fst new file mode 100644 index 00000000000..94debfd6fce --- /dev/null +++ b/src/basic/FStarC.Compiler.Option.fst @@ -0,0 +1,38 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Compiler.Option + +open FStarC.Compiler.Effect + +let isNone = function + | None -> true + | Some _ -> false + +let isSome = function + | Some _ -> true + | None -> false + +let map f = function + | Some x -> Some (f x) + | None -> None + +let mapTot f = function + | Some x -> Some (f x) + | None -> None + +let get = function + | Some x -> x + | None -> failwith "empty option" diff --git a/src/basic/FStarC.Compiler.Option.fsti b/src/basic/FStarC.Compiler.Option.fsti new file mode 100644 index 00000000000..976f7c16391 --- /dev/null +++ b/src/basic/FStarC.Compiler.Option.fsti @@ -0,0 +1,24 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Compiler.Option +open Prims +open FStarC.Compiler.Effect + +val isNone: option 'a -> Tot bool +val isSome: option 'a -> Tot bool +val map: ('a -> ML 'b) -> option 'a -> ML (option 'b) +val mapTot: ('a -> Tot 'b) -> option 'a -> Tot (option 'b) +val get: option 'a -> ML 'a diff --git a/src/basic/FStarC.Compiler.Order.fst b/src/basic/FStarC.Compiler.Order.fst new file mode 100644 index 00000000000..6fdc2def7e1 --- /dev/null +++ b/src/basic/FStarC.Compiler.Order.fst @@ -0,0 +1,74 @@ +(* + Copyright 2008-2020 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Compiler.Order +open FStarC.Compiler.Effect +module List = FStarC.Compiler.List + +type order = | Lt | Eq | Gt + +// Some derived checks +let ge (o : order) : bool = o <> Lt +let le (o : order) : bool = o <> Gt +let ne (o : order) : bool = o <> Eq + +// Just for completeness and consistency... +let gt (o : order) : bool = o = Gt +let lt (o : order) : bool = o = Lt +let eq (o : order) : bool = o = Eq + +// Lexicographical combination, thunked to be lazy +let lex (o1 : order) (o2 : unit -> order) : order = + match o1, o2 with + | Lt, _ -> Lt + | Eq, _ -> o2 () + | Gt, _ -> Gt + +let order_from_int (i : int) : order = + if i < 0 then Lt + else if i = 0 then Eq + else Gt + +let compare_int (i : int) (j : int) : order = order_from_int (i - j) + +let compare_bool (b1 b2 : bool) : order = + match b1, b2 with + | false, true -> Lt + | true, false -> Gt + | _ -> Eq + +(* + * It promises to call the comparator in strictly smaller elements + * Useful when writing a comparator for an inductive type, + * that contains the list of itself as an argument to one of its + * data constructors + *) +let rec compare_list (#a:Type) + (l1 l2:list a) + (f:(x:a{x << l1} -> y:a{y << l2} -> order)) + : order + = match l1, l2 with + | [], [] -> Eq + | [], _ -> Lt + | _, [] -> Gt + | x::xs, y::ys -> lex (f x y) (fun _ -> compare_list xs ys f) + +let compare_option (f : 'a -> 'a -> order) (x : option 'a) (y : option 'a) : order = + match x, y with + | None , None -> Eq + | None , Some _ -> Lt + | Some _ , None -> Gt + | Some x , Some y -> f x y diff --git a/src/basic/FStarC.Compiler.Plugins.Base.fsti b/src/basic/FStarC.Compiler.Plugins.Base.fsti new file mode 100644 index 00000000000..052a773350e --- /dev/null +++ b/src/basic/FStarC.Compiler.Plugins.Base.fsti @@ -0,0 +1,23 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Compiler.Plugins.Base + +open FStarC.Compiler.Effect + +exception DynlinkError of string + +val dynlink_loadfile : string -> unit diff --git a/src/basic/FStarC.Compiler.Plugins.fst b/src/basic/FStarC.Compiler.Plugins.fst new file mode 100644 index 00000000000..41bcda5ef0e --- /dev/null +++ b/src/basic/FStarC.Compiler.Plugins.fst @@ -0,0 +1,134 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Compiler.Plugins + +open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.Plugins.Base + +module BU = FStarC.Compiler.Util +module E = FStarC.Errors +module O = FStarC.Options +open FStarC.Class.Show + +let loaded : ref (list string) = BU.mk_ref [] + +let pout s = if Debug.any () then BU.print_string s +let pout1 s x = if Debug.any () then BU.print1 s x +let perr s = if Debug.any () then BU.print_error s +let perr1 s x = if Debug.any () then BU.print1_error s x + +let dynlink (fname:string) : unit = + if List.mem fname !loaded then ( + pout1 "Plugin %s already loaded, skipping\n" fname + ) else ( + pout ("Attempting to load " ^ fname ^ "\n"); + begin try + dynlink_loadfile fname + with DynlinkError e -> + E.log_issue0 E.Error_PluginDynlink [ + E.text (BU.format1 "Failed to load plugin file %s" fname); + Pprint.prefix 2 1 (E.text "Reason:") (E.text e); + E.text (BU.format1 "Remove the `--load` option or use `--warn_error -%s` to ignore and continue." + (show (E.errno E.Error_PluginDynlink))) + ]; + (* If we weren't ignoring this error, just stop now *) + E.stop_if_err () + end; + loaded := fname :: !loaded; + pout1 "Loaded %s\n" fname; + () + ) + +let load_plugin tac = + dynlink tac + +let load_plugins tacs = + List.iter load_plugin tacs + +let load_plugins_dir dir = + (* Dynlink all .cmxs files in the given directory *) + (* fixme: confusion between FStarC.Compiler.String and FStar.String *) + BU.readdir dir + |> List.filter (fun s -> String.length s >= 5 && FStar.String.sub s (String.length s - 5) 5 = ".cmxs") + |> List.map (fun s -> dir ^ "/" ^ s) + |> load_plugins + +let compile_modules dir ms = + let compile m = + let packages = [ "fstar.lib" ] in + let pkg pname = "-package " ^ pname in + let args = ["ocamlopt"; "-shared"] (* FIXME shell injection *) + @ ["-I"; dir] + @ ["-w"; "-8-11-20-21-26-28" ] + @ (List.map pkg packages) + @ ["-o"; m ^ ".cmxs"; m ^ ".ml"] in + (* Note: not useful when in an OPAM setting *) + let ocamlpath_sep = match Platform.system with + | Platform.Windows -> ";" + | Platform.Posix -> ":" + in + let old_ocamlpath = + match BU.expand_environment_variable "OCAMLPATH" with + | Some s -> s + | None -> "" + in + let env_setter = BU.format5 "env OCAMLPATH=\"%s/../lib/%s%s/%s%s\"" + Options.fstar_bin_directory + ocamlpath_sep + Options.fstar_bin_directory + ocamlpath_sep + old_ocamlpath + in + let cmd = String.concat " " (env_setter :: "ocamlfind" :: args) in + let rc = BU.system_run cmd in + if rc <> 0 + then E.raise_error0 E.Fatal_FailToCompileNativeTactic [ + E.text "Failed to compile native tactic."; + E.text (BU.format2 "Command\n`%s`\nreturned with exit code %s" + cmd (show rc)) + ] + else () + in + try + ms + |> List.map (fun m -> dir ^ "/" ^ m) + |> List.iter compile + with e -> + perr (BU.format1 "Failed to load native tactic: %s\n" (BU.print_exn e)); + raise e + +(* Tries to load a plugin named like the extension. Returns true +if it could find a plugin with the proper name. This will fail hard +if loading the plugin fails. *) +let autoload_plugin (ext:string) : bool = + if Options.Ext.get "noautoload" <> "" then false else ( + if Debug.any () then + BU.print1 "Trying to find a plugin for extension %s\n" ext; + match Find.find_file (ext ^ ".cmxs") with + | Some fn -> + if List.mem fn !loaded then false + else ( + if Debug.any () then + BU.print1 "Autoloading plugin %s ...\n" fn; + load_plugin fn; + true + ) + | None -> + false +) diff --git a/src/basic/FStarC.Compiler.Plugins.fsti b/src/basic/FStarC.Compiler.Plugins.fsti new file mode 100644 index 00000000000..dcc478d236c --- /dev/null +++ b/src/basic/FStarC.Compiler.Plugins.fsti @@ -0,0 +1,30 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Compiler.Plugins + +open FStarC.Compiler.Effect +include FStarC.Compiler.Plugins.Base + +val load_plugin : string -> unit +val load_plugins : list string -> unit +val load_plugins_dir : string -> unit +val compile_modules : string -> list string -> unit + +(* Tries to load a plugin named like the extension. Returns true +if it could find a plugin with the proper name. This will fail hard +if loading the plugin fails. *) +val autoload_plugin (ext:string) : bool diff --git a/src/basic/FStarC.Compiler.Range.Ops.fst b/src/basic/FStarC.Compiler.Range.Ops.fst new file mode 100644 index 00000000000..98205363c00 --- /dev/null +++ b/src/basic/FStarC.Compiler.Range.Ops.fst @@ -0,0 +1,152 @@ +(* + Copyright 2008-2023 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +(* + Operations over the FStarC.Compiler.Range.Type.range type. +*) +module FStarC.Compiler.Range.Ops + +open FStarC +friend FStarC.Compiler.Range.Type + +open FStarC.Json +open FStarC.Compiler.Effect +open FStarC.Compiler.Util +open FStarC.Class.Ord + +module Options = FStarC.Options + +let union_rng r1 r2 = + if r1.file_name <> r2.file_name + then r2 + else + let start_pos = min r1.start_pos r2.start_pos in + let end_pos = max r1.end_pos r2.end_pos in + mk_rng r1.file_name start_pos end_pos + +let union_ranges r1 r2 = { + def_range=union_rng r1.def_range r2.def_range; + use_range=union_rng r1.use_range r2.use_range +} + +(* is r1 included in r2? *) +let rng_included r1 r2 = + if r1.file_name <> r2.file_name + then false + else + r2.start_pos <=? r1.start_pos && + r2.end_pos >=? r1.end_pos + +let string_of_pos pos = + format2 "%s,%s" (string_of_int pos.line) (string_of_int pos.col) +let string_of_file_name f = + if Options.Ext.get "fstar:no_absolute_paths" = "1" then + basename f + else if Options.ide () then + try + match Find.find_file (basename f) with + | None -> f //couldn't find file; just return the relative path + | Some absolute_path -> + absolute_path + with _ -> f + else f +let file_of_range r = + let f = r.def_range.file_name in + string_of_file_name f +let set_file_of_range r (f:string) = {r with def_range = {r.def_range with file_name = f}} +let string_of_rng r = + format3 "%s(%s-%s)" (string_of_file_name r.file_name) (string_of_pos r.start_pos) (string_of_pos r.end_pos) +let string_of_def_range r = string_of_rng r.def_range +let string_of_use_range r = string_of_rng r.use_range +let string_of_range r = string_of_def_range r + +let start_of_range r = r.def_range.start_pos +let end_of_range r = r.def_range.end_pos + +let file_of_use_range r = r.use_range.file_name +let start_of_use_range r = r.use_range.start_pos +let end_of_use_range r = r.use_range.end_pos + +let line_of_pos p = p.line +let col_of_pos p = p.col + +let end_range r = mk_range r.def_range.file_name r.def_range.end_pos r.def_range.end_pos + +let compare_rng r1 r2 = + let fcomp = FStar.String.compare r1.file_name r2.file_name in + if fcomp = 0 + then let start1 = r1.start_pos in + let start2 = r2.start_pos in + let lcomp = start1.line - start2.line in + if lcomp = 0 + then start1.col - start2.col + else lcomp + else fcomp +let compare r1 r2 = compare_rng r1.def_range r2.def_range +let compare_use_range r1 r2 = compare_rng r1.use_range r2.use_range +let range_before_pos m1 p = + p >=? end_of_range m1 + +let end_of_line p = {p with col=max_int} +let extend_to_end_of_line r = mk_range (file_of_range r) + (start_of_range r) + (end_of_line (end_of_range r)) + +let json_of_pos pos = + JsonList [JsonInt (line_of_pos pos); JsonInt (col_of_pos pos)] + +let json_of_range_fields file b e = + JsonAssoc [("fname", JsonStr file); + ("beg", json_of_pos b); + ("end", json_of_pos e)] + +let json_of_use_range r = + json_of_range_fields + (file_of_use_range r) + (start_of_use_range r) + (end_of_use_range r) + +let json_of_def_range r = + json_of_range_fields + (file_of_range r) + (start_of_range r) + (end_of_range r) + +let intersect_rng r1 r2 = + if r1.file_name <> r2.file_name + then r2 + else + let start_pos = max r1.start_pos r2.start_pos in + let end_pos = min r1.end_pos r2.end_pos in + (* If start_pos > end_pos, then the intersection is empty, just take the bound *) + if start_pos >=? end_pos + then r2 + else mk_rng r1.file_name start_pos end_pos + +let intersect_ranges r1 r2 = { + def_range=intersect_rng r1.def_range r2.def_range; + use_range=intersect_rng r1.use_range r2.use_range +} + +let bound_range (r bound : range) : range = + intersect_ranges r bound + +instance showable_range = { + show = string_of_range; +} + +instance pretty_range = { + pp = (fun r -> Pprint.doc_of_string (string_of_range r)); +} diff --git a/src/basic/FStarC.Compiler.Range.Ops.fsti b/src/basic/FStarC.Compiler.Range.Ops.fsti new file mode 100644 index 00000000000..b8b4df29953 --- /dev/null +++ b/src/basic/FStarC.Compiler.Range.Ops.fsti @@ -0,0 +1,58 @@ +(* + Copyright 2008-2023 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Compiler.Range.Ops + +open FStarC +open FStarC.Compiler.Range.Type +open FStarC.Compiler.Effect +open FStarC.Class.Show +open FStarC.Class.PP + +val union_rng: rng -> rng -> rng +val union_ranges: range -> range -> range + +val rng_included: rng -> rng -> bool +val string_of_pos: pos -> string +val string_of_range: range -> string +val string_of_def_range: range -> string +val string_of_use_range: range -> string +val file_of_range: range -> string +val set_file_of_range: range -> string -> range +val start_of_range: range -> pos +val end_of_range: range -> pos +val file_of_use_range: range -> string +val start_of_use_range: range -> pos +val end_of_use_range: range -> pos +val line_of_pos: pos -> int +val col_of_pos: pos -> int +val end_range: range -> range +val compare: range -> range -> int +val compare_use_range: range -> range -> int +val range_before_pos : range -> pos -> bool +val end_of_line: pos -> pos +val extend_to_end_of_line: range -> range + +val json_of_pos : pos -> Json.json +val json_of_use_range : range -> Json.json +val json_of_def_range : range -> Json.json + +(** Bounds the range [r] by [bound]. Essentially, this is an intersection, +making sure that whatever we report is within the bound. If the ranges +are from different files, or there is no overlap, we return [bound]. *) +val bound_range (r : range) (bound : range) : range + +instance val showable_range : showable range +instance val pretty_range : pretty range diff --git a/src/basic/FStarC.Compiler.Range.Type.fst b/src/basic/FStarC.Compiler.Range.Type.fst new file mode 100644 index 00000000000..a9460c42811 --- /dev/null +++ b/src/basic/FStarC.Compiler.Range.Type.fst @@ -0,0 +1,109 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Compiler.Range.Type + +open FStarC.Compiler.Effect +open FStarC.Class.Deq +open FStarC.Class.Ord +open FStarC.Compiler.Order + +[@@ PpxDerivingYoJson; PpxDerivingShow ] +type file_name = string + +[@@ PpxDerivingYoJson; PpxDerivingShow ] +type pos = { + line:int; + col: int +} +let max i j = if i < j then j else i + +let compare_pos (p1 p2 : pos) : order = + lex (cmp p1.line p2.line) (fun _ -> cmp p1.col p2.col) + +instance deq_pos : deq pos = { (=?) = (=); } + +instance ord_pos : ord pos = { + super = deq_pos; + cmp = compare_pos; +} + +[@@ PpxDerivingYoJson; PpxDerivingShow ] +type rng = { + file_name:file_name; + start_pos:pos; + end_pos:pos; +} +[@@ PpxDerivingYoJson; PpxDerivingShow ] +type range = { + def_range:rng; + use_range:rng +} +let dummy_pos = { + line=0; + col=0; +} +let dummy_rng = { + file_name="dummy"; + start_pos=dummy_pos; + end_pos=dummy_pos +} +let dummyRange = { + def_range=dummy_rng; + use_range=dummy_rng +} +let use_range r = r.use_range +let def_range r = r.def_range +let range_of_rng d u = { + def_range=d; + use_range=u +} +let set_use_range r2 use_rng = + if use_rng <> dummy_rng then + {r2 with use_range=use_rng} + else r2 +let set_def_range r2 def_rng = + if def_rng <> dummy_rng then + {r2 with def_range=def_rng} + else r2 +let mk_pos l c = { + line=max 0 l; + col=max 0 c +} +let mk_rng file_name start_pos end_pos = { + file_name = file_name; + start_pos = start_pos; + end_pos = end_pos +} + +let mk_range f b e = let r = mk_rng f b e in range_of_rng r r + +open FStarC.Json +let json_of_pos (r: pos): json + = JsonAssoc [ + "line", JsonInt r.line; + "col", JsonInt r.col; + ] +let json_of_rng (r: rng): json + = JsonAssoc [ + "file_name", JsonStr r.file_name; + "start_pos", json_of_pos r.start_pos; + "end_pos", json_of_pos r.end_pos; + ] +let json_of_range (r: range): json + = JsonAssoc [ + "def", json_of_rng r.def_range; + "use", json_of_rng r.use_range; + ] diff --git a/src/basic/FStarC.Compiler.Range.Type.fsti b/src/basic/FStarC.Compiler.Range.Type.fsti new file mode 100644 index 00000000000..4295532f5d4 --- /dev/null +++ b/src/basic/FStarC.Compiler.Range.Type.fsti @@ -0,0 +1,48 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Compiler.Range.Type + +open FStarC.Compiler.Effect +open FStarC.Class.Deq +open FStarC.Class.Ord + +[@@ PpxDerivingYoJson; PpxDerivingShow] +new val rng : Type0 + +[@@ PpxDerivingYoJson; PpxDerivingShow] +new val range : Type0 + +[@@ PpxDerivingYoJson; PpxDerivingShow] +new val pos : Type0 + +instance val deq_pos : deq pos +instance val ord_pos : ord pos + +val dummy_rng : rng +val mk_rng : string -> pos -> pos -> rng + +val dummyRange: range +val use_range: range -> rng +val def_range: range -> rng +val range_of_rng: def_rng:rng -> use_rng:rng -> range +val set_use_range: range -> rng -> range +val set_def_range: range -> rng -> range +val mk_pos: int -> int -> pos +val mk_range: string -> pos -> pos -> range + +val json_of_pos: pos -> FStarC.Json.json +val json_of_rng: rng -> FStarC.Json.json +val json_of_range: range -> FStarC.Json.json diff --git a/src/basic/FStarC.Compiler.Range.fsti b/src/basic/FStarC.Compiler.Range.fsti new file mode 100644 index 00000000000..6a893bf6537 --- /dev/null +++ b/src/basic/FStarC.Compiler.Range.fsti @@ -0,0 +1,21 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Compiler.Range + +(* This module simply bundles together these other two. See their +interfaces for reference. *) +include FStarC.Compiler.Range.Type +include FStarC.Compiler.Range.Ops diff --git a/src/basic/FStarC.Compiler.Real.fst b/src/basic/FStarC.Compiler.Real.fst new file mode 100644 index 00000000000..38e29385693 --- /dev/null +++ b/src/basic/FStarC.Compiler.Real.fst @@ -0,0 +1,16 @@ +(* + Copyright 2017-2024 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Compiler.Real diff --git a/src/basic/FStarC.Compiler.Real.fsti b/src/basic/FStarC.Compiler.Real.fsti new file mode 100644 index 00000000000..ee8d45d7132 --- /dev/null +++ b/src/basic/FStarC.Compiler.Real.fsti @@ -0,0 +1,21 @@ +(* + Copyright 2017-2024 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Compiler.Real + +(* A type for embedded real constants. This allows to write embeddings for them +(see FStarC.Syntax.Embeddings and FStarC.TypeChecker.NBETerm). *) + +type real = | Real of string diff --git a/src/basic/FStarC.Compiler.Sealed.fst b/src/basic/FStarC.Compiler.Sealed.fst new file mode 100644 index 00000000000..fed2c1531bc --- /dev/null +++ b/src/basic/FStarC.Compiler.Sealed.fst @@ -0,0 +1,33 @@ +(* + Copyright 2008-2024 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Compiler.Sealed + +(* This is the compiler-space version of the Sealed module in ulib. +Here, we define it as just an identity, but we do not expose that in +the interface so we must use the seal/unseal operations. This allows us +to + + 1) make sure we do not make mistakes forgetting to seal/unseal + 2) make sure none of these operations have any runtime behavior. + +It would be nicer to just make this a box type and expose that (internally +to the compiler) but that means extracted code would use the box. *) + +type sealed (a:Type u#a) : Type u#a = a + +let seal (x: 'a) : sealed 'a = x + +let unseal (x: sealed 'a) : 'a = x diff --git a/src/basic/FStarC.Compiler.Sealed.fsti b/src/basic/FStarC.Compiler.Sealed.fsti new file mode 100644 index 00000000000..a55b141230d --- /dev/null +++ b/src/basic/FStarC.Compiler.Sealed.fsti @@ -0,0 +1,22 @@ +(* + Copyright 2008-2024 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Compiler.Sealed + +val sealed (a:Type u#a) : Type u#a + +val seal (x: 'a) : Tot (sealed 'a) + +val unseal (x: sealed 'a) : Tot 'a diff --git a/src/basic/FStarC.Compiler.String.fsti b/src/basic/FStarC.Compiler.String.fsti new file mode 100644 index 00000000000..a9e2f25fb6a --- /dev/null +++ b/src/basic/FStarC.Compiler.String.fsti @@ -0,0 +1,46 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Compiler.String + +open FStarC.Compiler.Effect +open FStar.Char +open FStarC.BigInt + +(* The name of this file is misleading: most string functions are to be found in + util.fsi *) +val make: int -> char -> string +val split: chars: list char -> s: string -> Tot (list string) +val strcat: string -> string -> Tot string +val concat: separator: string -> strings: list string -> Tot string +val compare: s1: string -> s2: string -> Tot int +val strlen: string -> Tot nat +val length: string -> Tot nat +val lowercase: string -> Tot string +val uppercase: string -> Tot string +val escaped: string -> Tot string + +val string_of_char : char -> Tot string + +(* may fail with index out of bounds *) +val substring: string -> start:int -> len:int -> string +val get: string -> int -> char +val collect: (char -> string) -> string -> string +val index_of: string -> char -> bigint +val index: string -> bigint -> char + +val list_of_string : string -> list char +val string_of_list: list char -> string +val (^) : string -> string -> string diff --git a/src/basic/FStarC.Compiler.Util.fsti b/src/basic/FStarC.Compiler.Util.fsti new file mode 100644 index 00000000000..d62f85bcd22 --- /dev/null +++ b/src/basic/FStarC.Compiler.Util.fsti @@ -0,0 +1,393 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Compiler.Util +open Prims +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Json +open FStarC.BaseTypes + +exception Impos + +val max_int: int +val return_all: 'a -> ML 'a + +type time +val now : unit -> time +val now_ms : unit -> int +val time_diff: time -> time -> float&int +val record_time: (unit -> 'a) -> ('a & int) +val is_before: time -> time -> bool +val get_file_last_modification_time: string -> time +val string_of_time: time -> string + +(* generic utils *) +(* smap: map from string keys *) +type smap 'value +val smap_create: int -> smap 'value +val smap_clear:smap 'value -> unit +val smap_add: smap 'value -> string -> 'value -> unit +val smap_of_list: list (string&'value) -> smap 'value +val smap_try_find: smap 'value -> string -> option 'value +val smap_fold: smap 'value -> (string -> 'value -> 'a -> 'a) -> 'a -> 'a +val smap_remove: smap 'value -> string -> unit +(* The list may contain duplicates. *) +val smap_keys: smap 'value -> list string +val smap_copy: smap 'value -> smap 'value +val smap_size: smap 'value -> int +val smap_iter: smap 'value -> (string -> 'value -> unit) -> unit + +(* pure version *) +type psmap 'value +val psmap_empty: unit -> psmap 'value // GH-1161 +val psmap_add: psmap 'value -> string -> 'value -> psmap 'value +val psmap_find_default: psmap 'value -> string -> 'value -> 'value +val psmap_try_find: psmap 'value -> string -> option 'value +val psmap_fold: psmap 'value -> (string -> 'value -> 'a -> 'a) -> 'a -> 'a +val psmap_find_map: psmap 'value -> (string -> 'value -> option 'a) -> option 'a +val psmap_modify: psmap 'value -> string -> (option 'value -> 'value) -> psmap 'value +val psmap_merge: psmap 'value -> psmap 'value -> psmap 'value +val psmap_remove: psmap 'value -> string -> psmap 'value +type imap 'value +val imap_create: int -> imap 'value +val imap_clear:imap 'value -> unit +val imap_add: imap 'value -> int -> 'value -> unit +val imap_of_list: list (int&'value) -> imap 'value +val imap_try_find: imap 'value -> int -> option 'value +val imap_fold: imap 'value -> (int -> 'value -> 'a -> 'a) -> 'a -> 'a +val imap_remove: imap 'value -> int -> unit +(* The list may contain duplicates. *) +val imap_keys: imap 'value -> list int +val imap_copy: imap 'value -> imap 'value + +(* pure version *) +type pimap 'value +val pimap_empty: unit -> pimap 'value // GH-1161 +val pimap_add: pimap 'value -> int -> 'value -> pimap 'value +val pimap_find_default: pimap 'value -> int -> 'value -> 'value +val pimap_try_find: pimap 'value -> int -> option 'value +val pimap_fold: pimap 'value -> (int -> 'value -> 'a -> 'a) -> 'a -> 'a + +val format: string -> list string -> string +val format1: string -> string -> string +val format2: string -> string -> string -> string +val format3: string -> string -> string -> string -> string +val format4: string -> string -> string -> string -> string -> string +val format5: string -> string -> string -> string -> string -> string -> string +val format6: string -> string -> string -> string -> string -> string -> string -> string + +val print: string -> list string -> unit +val print1: string -> string -> unit +val print2: string -> string -> string -> unit +val print3: string -> string -> string -> string -> unit +val print4: string -> string -> string -> string -> string -> unit +val print5: string -> string -> string -> string -> string -> string -> unit +val print6: string -> string -> string -> string -> string -> string -> string -> unit + +val print_error: string -> unit +val print1_error: string -> string -> unit +val print2_error: string -> string -> string -> unit +val print3_error: string -> string -> string -> string -> unit + +val print_warning: string -> unit +val print1_warning: string -> string -> unit +val print2_warning: string -> string -> string -> unit +val print3_warning: string -> string -> string -> string -> unit + +val flush_stdout: unit -> unit + +val stdout_isatty: unit -> option bool + +// These functions have no effect +val colorize: string -> (string & string) -> string +val colorize_bold: string -> string +val colorize_red: string -> string +val colorize_yellow: string -> string +val colorize_cyan: string -> string +val colorize_green: string -> string +val colorize_magenta : string -> string + + +type out_channel + +val stderr: out_channel +val stdout: out_channel + +val open_file_for_writing : string -> out_channel +val open_file_for_appending : string -> out_channel +val close_out_channel : out_channel -> unit + +val flush: out_channel -> unit + +val fprint: out_channel -> string -> list string -> unit + +(* Adds a newline and flushes *) +val append_to_file: out_channel -> string -> unit + +type printer = { + printer_prinfo: string -> unit; + printer_prwarning: string -> unit; + printer_prerror: string -> unit; + printer_prgeneric: string -> (unit -> string) -> (unit -> json) -> unit +} + +val default_printer : printer +val set_printer : printer -> unit + +val print_raw : string -> unit +val print_string : string -> unit +val print_generic: string -> ('a -> string) -> ('a -> json) -> 'a -> unit +val print_any : 'a -> unit +val strcat : string -> string -> string +val concat_l : string -> list string -> string + +val write_file: fn:string -> contents:string -> unit +val copy_file: string -> string -> unit +val delete_file: string -> unit +val file_get_contents: string -> string +val file_get_lines: string -> list string + +(** [mkdir clean mkparents d] a new dir with user read/write. +If clean is set and the directory exists, its contents are deleted and nothing else is done. +If clean is not set and the directory exists, do nothing. +If mkparents is true, the needed parents of the path will be created too, as mkdir -p does. +*) +val mkdir: bool-> bool -> string -> unit + +val concat_dir_filename: string -> string -> string + +type stream_reader +val open_stdin : unit -> stream_reader +val read_line: stream_reader -> option string +val nread : stream_reader -> int -> option string +val poll_stdin : float -> bool + +type string_builder +val new_string_builder: unit -> string_builder +val clear_string_builder: string_builder -> unit +val string_of_string_builder: string_builder -> string +val string_builder_append: string_builder -> string -> unit + +val message_of_exn: exn -> string +val trace_of_exn: exn -> string +val stack_dump : unit -> string + +exception SigInt +type sigint_handler +val sigint_handler_f : (int -> unit) -> sigint_handler +val sigint_ignore: sigint_handler +val sigint_raise: sigint_handler +val get_sigint_handler: unit -> sigint_handler +val set_sigint_handler: sigint_handler -> unit +val with_sigint_handler: sigint_handler -> (unit -> 'a) -> 'a + +type proc +val run_process : string -> string -> list string -> option string -> string +val start_process: string -> string -> list string -> (string -> bool) -> proc +val ask_process: proc -> string -> (*err_handler:*)(unit -> string) -> (*stderr_handler:*)(string -> unit) -> string +val kill_process: proc -> unit +val kill_all: unit -> unit +val proc_prog : proc -> string +val system_run : string -> int (* a less refined launching, implemented by Sys.command *) + +val get_file_extension: string -> string +val is_path_absolute: string -> bool +val join_paths: string -> string -> string +val normalize_file_path: string -> string +val basename: string -> string +val dirname : string -> string +val getcwd: unit -> string +val readdir: string -> list string +val paths_to_same_file: string -> string -> bool + +val file_exists: string -> Tot bool +val is_directory: string -> Tot bool + +val int_of_string: string -> int +val safe_int_of_string: string -> option int +val int_of_char: char -> Tot int +val int_of_byte: byte -> Tot int +val byte_of_char: char -> Tot byte +val char_of_int: int -> Tot char +val int_of_uint8: uint8 -> Tot int +val uint16_of_int: int -> Tot uint16 +val float_of_byte: byte -> Tot float +val float_of_int32: int32 -> Tot float +val float_of_int64: int64 -> Tot float +val float_of_string: string -> Tot float +val int_of_int32: int32 -> Tot int +val int32_of_int: int -> int32 //potentially failing int32 coercion +val string_of_int: int -> string +val string_of_bool: bool -> string +val string_of_int64: int64 -> Tot string +val string_of_int32: int32 -> Tot string +val string_of_float: float -> Tot string +val string_of_char: char -> Tot string +val hex_string_of_byte: byte -> Tot string +val string_of_bytes: array byte -> Tot string +val bytes_of_string: string -> Tot (array byte) +val base64_encode: string -> string +val base64_decode: string -> string +val starts_with: long:string -> short:string -> Tot bool +val trim_string: string -> Tot string +val ends_with: long:string -> short:string -> Tot bool +val char_at: string -> int -> char +val is_upper: char -> Tot bool +val contains: string -> string -> Tot bool +val substring_from: string -> int -> string +val substring: string -> start:int -> len:int -> string +val replace_char: string -> char -> char -> Tot string +val replace_chars: string -> char -> string -> Tot string +val hashcode: string -> Tot int +val compare: string -> string -> Tot int +val splitlines: string -> Tot (list string) +val split: str:string -> sep:string -> Tot (list string) + +val is_left: either 'a 'b -> bool +val is_right: either 'a 'b -> bool +val left: either 'a 'b -> 'a +val right: either 'a 'b -> 'b +val find_dup: ('a -> 'a -> bool) -> list 'a -> option 'a +val nodups: ('a -> 'a -> bool) -> list 'a -> bool +val sort_with: ('a -> 'a -> int) -> list 'a -> list 'a +val remove_dups: ('a -> 'a -> bool) -> list 'a -> list 'a +val add_unique: ('a -> 'a -> bool) -> 'a -> list 'a -> list 'a +val try_find: ('a -> bool) -> list 'a -> option 'a +val try_find_i: (int -> 'a -> bool) -> list 'a -> option (int & 'a) +val find_map: list 'a -> ('a -> option 'b) -> option 'b +val try_find_index: ('a -> bool) -> list 'a -> option int +val fold_map: ('a -> 'b -> 'a & 'c) -> 'a -> list 'b -> 'a & list 'c +val choose_map: ('a -> 'b -> 'a & option 'c) -> 'a -> list 'b -> 'a & list 'c +val for_all: ('a -> bool) -> list 'a -> bool +val for_some: ('a -> bool) -> list 'a -> bool +val forall_exists: ('a -> 'b -> bool) -> list 'a -> list 'b -> bool +val multiset_equiv: ('a -> 'b -> bool) -> list 'a -> list 'b -> bool +val take: ('a -> bool) -> list 'a -> list 'a & list 'a + +(* Variation on fold_left which pushes the list returned by the functional *) +(* on top of the leftover input list *) +val fold_flatten:('a -> 'b -> 'a & list 'b) -> 'a -> list 'b -> 'a + +val is_none: option 'a -> Tot bool +val is_some: option 'a -> Tot bool +val must: option 'a -> 'a +val dflt: 'a -> option 'a -> Tot 'a +val find_opt: ('a -> bool) -> list 'a -> option 'a +(* FIXME: these functions have the wrong argument order when compared to + List.map, List.iter, etc. *) +val bind_opt: option 'a -> ('a -> option 'b) -> option 'b +val catch_opt: option 'a -> (unit -> option 'a) -> option 'a +val map_opt: option 'a -> ('a -> 'b) -> option 'b +val iter_opt: option 'a -> ('a -> unit) -> unit + +val first_N: int -> list 'a -> (list 'a & list 'a) +val nth_tail: int -> list 'a -> list 'a +val prefix_until: ('a -> bool) -> list 'a -> option (list 'a & 'a & list 'a) +val prefix: list 'a -> Tot (list 'a & 'a) + +val string_of_unicode: array byte -> Tot string +val unicode_of_string: string -> Tot (array byte) +val incr: ref int -> unit +val decr: ref int -> unit +val geq: int -> int -> Tot bool +val for_range: int -> int -> (int -> unit) -> unit + +val mk_ref: 'a -> ref 'a + +val exec_name : string +val get_exec_dir: unit -> string +val get_cmd_args : unit -> list string +val expand_environment_variable: string -> option string + +val physical_equality: 'a -> 'a -> bool +val check_sharing: 'a -> 'a -> string -> unit + +val is_letter: char -> bool +val is_digit: char -> bool +val is_letter_or_digit: char -> bool +val is_punctuation: char -> bool +val is_symbol: char -> bool + +(* serialization of compiled modules *) +type oWriter = { + write_byte: byte -> unit; + write_bool: bool -> unit; + write_int: int -> unit; + write_int32: int32 -> unit; + write_int64: int64 -> unit; + write_char: char -> unit; + write_double: double -> unit; + write_bytearray: array byte -> unit; + write_string: string -> unit; + + close: unit -> unit +} + +type oReader = { + read_byte: unit -> byte; + read_bool: unit -> bool; + read_int: unit -> int; + read_int32: unit -> int32; + read_int64: unit -> int64; + read_char: unit -> char; + read_double: unit -> double; + read_bytearray: unit -> array byte; + read_string: unit -> string; + + close: unit -> unit +} + +val get_owriter: string -> oWriter +val get_oreader: string -> oReader + +val monitor_enter: 'a -> unit +val monitor_exit: 'a -> unit +val monitor_wait: 'a -> unit +val monitor_pulse: 'a -> unit +val with_monitor: 'a -> ('b -> 'c) -> 'b -> 'c +val current_tid: unit -> int +val sleep: int -> unit +val atomically: (unit -> 'a) -> 'a +val spawn: (unit -> unit) -> unit +val print_endline: string -> unit + +val map_option: ('a -> 'b) -> option 'a -> option 'b + +val save_value_to_file: string -> 'a -> unit +val load_value_from_file: string -> option 'a +val save_2values_to_file: string -> 'a -> 'b -> unit +val load_2values_from_file: string -> option ('a & 'b) +val print_exn: exn -> string +val digest_of_file: string -> string +val digest_of_string: string -> string +val touch_file: string -> unit (* Precondition: file exists *) + +val ensure_decimal: string -> string +val measure_execution_time: string -> (unit -> 'a) -> 'a +val return_execution_time: (unit -> 'a) -> ('a & float) + +(* Common interface between F#, Ocaml and F* to read and write references *) +(* F# uses native references, while OCaml uses both native references (Pervasives) and FStar_Heap ones *) +val read : ref 'a -> 'a +val write : ref 'a -> 'a -> unit + +(* Marshaling to and from strings *) +val marshal: 'a -> string +val unmarshal: string -> 'a + +val print_array (f: 'a -> string) (s:FStar.ImmutableArray.Base.t 'a) : string +val array_length (s:FStar.ImmutableArray.Base.t 'a) : FStarC.BigInt.t +val array_index (s:FStar.ImmutableArray.Base.t 'a) (i:FStarC.BigInt.t) : 'a diff --git a/src/basic/FStarC.Const.fst b/src/basic/FStarC.Const.fst new file mode 100644 index 00000000000..b6ff032228e --- /dev/null +++ b/src/basic/FStarC.Const.fst @@ -0,0 +1,95 @@ +(* + Copyright 2008-2020 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Const +open FStarC.Compiler.Effect +module List = FStarC.Compiler.List + +open FStarC.BaseTypes + +[@@ PpxDerivingYoJson; PpxDerivingShow ] +type signedness = | Unsigned | Signed +[@@ PpxDerivingYoJson; PpxDerivingShow ] +type width = | Int8 | Int16 | Int32 | Int64 | Sizet + +(* NB: + Const_int (_, None) is not a canonical representation for a mathematical integer + e.g., you can have both + Const_int("0x3ffffff", None) + and + Const_int("67108863", None) + which represent the same number + You should do an "FStarC.Compiler.Util.ensure_decimal" on the + string representation before comparing integer constants. + + eq_const below does that for you +*) + +[@@ PpxDerivingYoJson; PpxDerivingShow ] +type sconst = + | Const_effect + | Const_unit + | Const_bool of bool + | Const_int of string & option (signedness & width) (* When None, means "mathematical integer", i.e. Prims.int. *) + | Const_char of char (* unicode code point: char in F#, int in OCaml *) + | Const_real of string + | Const_string of string & FStarC.Compiler.Range.range (* UTF-8 encoded *) + | Const_range_of (* `range_of` primitive *) + | Const_set_range_of (* `set_range_of` primitive *) + | Const_range of FStarC.Compiler.Range.range (* not denotable by the programmer *) + | Const_reify of option Ident.lid (* a coercion from a computation to its underlying repr *) + (* decorated optionally with the computation effect name *) + | Const_reflect of Ident.lid (* a coercion from a Tot term to an l-computation type *) + +let eq_const c1 c2 = + match c1, c2 with + | Const_int (s1, o1), Const_int(s2, o2) -> + FStarC.Compiler.Util.ensure_decimal s1 = FStarC.Compiler.Util.ensure_decimal s2 && + o1=o2 + | Const_string(a, _), Const_string(b, _) -> a=b + | Const_reflect l1, Const_reflect l2 -> Ident.lid_equals l1 l2 + | Const_reify _, Const_reify _ -> true + | _ -> c1=c2 + +open FStarC.BigInt +let rec pow2 (x:bigint) : bigint = + if eq_big_int x zero + then one + else mult_big_int two (pow2 (pred_big_int x)) + + +let bounds signedness width = + let n = + match width with + | Int8 -> big_int_of_string "8" + | Int16 -> big_int_of_string "16" + | Int32 -> big_int_of_string "32" + | Int64 -> big_int_of_string "64" + | Sizet -> big_int_of_string "16" + in + let lower, upper = + match signedness with + | Unsigned -> + zero, pred_big_int (pow2 n) + | Signed -> + let upper = pow2 (pred_big_int n) in + minus_big_int upper, pred_big_int upper + in + lower, upper + +let within_bounds repr signedness width = + let lower, upper = bounds signedness width in + let value = big_int_of_string (FStarC.Compiler.Util.ensure_decimal repr) in + le_big_int lower value && le_big_int value upper diff --git a/src/basic/FStarC.Defensive.fst b/src/basic/FStarC.Defensive.fst new file mode 100644 index 00000000000..a93035ec6de --- /dev/null +++ b/src/basic/FStarC.Defensive.fst @@ -0,0 +1,50 @@ +module FStarC.Defensive + +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.Util +open FStarC.Class.Binders +open FStarC.Class.Show +open FStarC.Class.Ord +open FStarC.Errors +open FStarC.Errors.Msg +open FStarC.Pprint +open FStarC.Class.Setlike + +let () = let open FStarC.Syntax.Print in () + +val __def_check_scoped : + #env_t:Type -> #thing_t:Type -> + {| hasBinders env_t |} -> + {| hasNames thing_t |} -> + {| pretty thing_t |} -> + range -> string -> + env_t -> thing_t -> unit + +instance pp_bv : pretty FStarC.Syntax.Syntax.bv = { + pp = (fun bv -> arbitrary_string (show bv)); +} + +instance pp_set #a (_ : ord a) (_ : pretty a) : Tot (pretty (FlatSet.t a)) = { + pp = (fun s -> + let doclist (ds : list Pprint.document) : Pprint.document = + surround_separate 2 0 (doc_of_string "[]") lbracket (semi ^^ break_ 1) rbracket ds + in + doclist (elems s |> List.map pp)) +} + +let __def_check_scoped rng msg env thing = + let free = freeNames thing in + let scope = boundNames env in + if not (subset free scope) then + Errors.log_issue rng Errors.Warning_Defensive [ + text "Internal: term is not well-scoped " ^/^ parens (doc_of_string msg); + text "t =" ^/^ pp thing; + text "FVs =" ^/^ pp free; + text "Scope =" ^/^ pp scope; + text "Diff =" ^/^ pp (diff free scope); + ] + +let def_check_scoped rng msg env thing = + if Options.defensive () then + __def_check_scoped rng msg env thing diff --git a/src/basic/FStarC.Defensive.fsti b/src/basic/FStarC.Defensive.fsti new file mode 100644 index 00000000000..8f44aa6ad13 --- /dev/null +++ b/src/basic/FStarC.Defensive.fsti @@ -0,0 +1,29 @@ +(* + Copyright 2008-2020 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Defensive + +open FStarC.Compiler.Effect +open FStarC.Compiler.Range +open FStarC.Class.Binders +open FStarC.Class.PP + +val def_check_scoped : + #env_t:Type -> #thing_t:Type -> + {| hasBinders env_t |} -> + {| hasNames thing_t |} -> + {| pretty thing_t |} -> + range -> string -> + env_t -> thing_t -> unit diff --git a/src/basic/FStarC.Dyn.fsti b/src/basic/FStarC.Dyn.fsti new file mode 100644 index 00000000000..e9436fe0472 --- /dev/null +++ b/src/basic/FStarC.Dyn.fsti @@ -0,0 +1,35 @@ +(* + Copyright 2008-2024 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Dyn + +open FStarC.Compiler.Effect + +/// Dynamic casts + +(* fixme: this should point to the parent compiler's FStar.Dyn instead. *) + +val dyn : Type0 + +(** [dyn_has_ty d a] is true if [d] was promoted from type [a] *) +val dyn_has_ty (d: dyn) (a: Type u#a) : Tot prop + +(** Promoting a value of type [a] to [dyn] *) +val mkdyn (#a: Type u#a) (x: a) : d:dyn { dyn_has_ty d a } + +(** This coerces a value of type [dyn] to its original type [a], + with [dyn_has_ty d a] as precondition *) +val undyn (#a: Type u#a) (d: dyn { dyn_has_ty d a }) : Dv a diff --git a/src/basic/FStarC.Errors.Codes.fst b/src/basic/FStarC.Errors.Codes.fst new file mode 100644 index 00000000000..7f2bc40b0a0 --- /dev/null +++ b/src/basic/FStarC.Errors.Codes.fst @@ -0,0 +1,380 @@ +(* + Copyright 2008-2020 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Errors.Codes + +let default_settings : list error_setting = + [ + Error_DependencyAnalysisFailed , CAlwaysError, 0; + Error_IDETooManyPops , CAlwaysError, 1; + Error_IDEUnrecognized , CAlwaysError, 2; + Error_InductiveTypeNotSatisfyPositivityCondition , CAlwaysError, 3; + Error_InvalidUniverseVar , CAlwaysError, 4; + Error_MissingFileName , CAlwaysError, 5; + Error_ModuleFileNameMismatch , CAlwaysError, 6; + Error_OpPlusInUniverse , CAlwaysError, 7; + Error_OutOfRange , CAlwaysError, 8; + Error_ProofObligationFailed , CError, 9; + Error_TooManyFiles , CAlwaysError, 10; + Error_TypeCheckerFailToProve , CAlwaysError, 11; + Error_TypeError , CAlwaysError, 12; + Error_UncontrainedUnificationVar , CAlwaysError, 13; + Error_UnexpectedGTotComputation , CAlwaysError, 14; + Error_UnexpectedInstance , CAlwaysError, 15; + Error_UnknownFatal_AssertionFailure , CError, 16; + Error_Z3InvocationError , CAlwaysError, 17; + Error_IDEAssertionFailure , CAlwaysError, 18; + Error_Z3SolverError , CError, 19; + Fatal_AbstractTypeDeclarationInInterface , CFatal, 20; + Fatal_ActionMustHaveFunctionType , CFatal, 21; + Fatal_AlreadyDefinedTopLevelDeclaration , CFatal, 22; + Fatal_ArgumentLengthMismatch , CFatal, 23; + Fatal_AssertionFailure , CFatal, 24; + Fatal_AssignToImmutableValues , CFatal, 25; + Fatal_AssumeValInInterface , CFatal, 26; + Fatal_BadlyInstantiatedSynthByTactic , CFatal, 27; + Fatal_BadSignatureShape , CFatal, 28; + Fatal_BinderAndArgsLengthMismatch , CFatal, 29; + Fatal_BothValAndLetInInterface , CFatal, 30; + Fatal_CardinalityConstraintViolated , CFatal, 31; + Fatal_ComputationNotTotal , CFatal, 32; + Fatal_ComputationTypeNotAllowed , CFatal, 33; + Fatal_ComputedTypeNotMatchAnnotation , CFatal, 34; + Fatal_ConstructorArgLengthMismatch , CFatal, 35; + Fatal_ConstructorFailedCheck , CFatal, 36; + Fatal_ConstructorNotFound , CFatal, 37; + Fatal_ConstsructorBuildWrongType , CFatal, 38; + Fatal_CycleInRecTypeAbbreviation , CFatal, 39; + Fatal_DataContructorNotFound , CFatal, 40; + Fatal_DefaultQualifierNotAllowedOnEffects , CFatal, 41; + Fatal_DefinitionNotFound , CFatal, 42; + Fatal_DisjuctivePatternVarsMismatch , CFatal, 43; + Fatal_DivergentComputationCannotBeIncludedInTotal , CFatal, 44; + Fatal_DuplicateInImplementation , CFatal, 45; + Fatal_DuplicateModuleOrInterface , CFatal, 46; + Fatal_DuplicateTopLevelNames , CFatal, 47; + Fatal_DuplicateTypeAnnotationAndValDecl , CFatal, 48; + Fatal_EffectCannotBeReified , CFatal, 49; + Fatal_EffectConstructorNotFullyApplied , CFatal, 50; + Fatal_EffectfulAndPureComputationMismatch , CFatal, 51; + Fatal_EffectNotFound , CFatal, 52; + Fatal_EffectsCannotBeComposed , CFatal, 53; + Fatal_ErrorInSolveDeferredConstraints , CFatal, 54; + Fatal_ErrorsReported , CFatal, 55; + Fatal_EscapedBoundVar , CFatal, 56; + Fatal_ExpectedArrowAnnotatedType , CFatal, 57; + Fatal_ExpectedGhostExpression , CFatal, 58; + Fatal_ExpectedPureExpression , CFatal, 59; + Fatal_ExpectNormalizedEffect , CFatal, 60; + Fatal_ExpectTermGotFunction , CFatal, 61; + Fatal_ExpectTrivialPreCondition , CFatal, 62; + Fatal_FailToExtractNativeTactic , CFatal, 63; + Fatal_FailToCompileNativeTactic , CFatal, 64; + Fatal_FailToProcessPragma , CFatal, 65; + Fatal_FailToResolveImplicitArgument , CFatal, 66; + Fatal_FailToSolveUniverseInEquality , CFatal, 67; + Fatal_FieldsNotBelongToSameRecordType , CFatal, 68; + Fatal_ForbiddenReferenceToCurrentModule , CFatal, 69; + Fatal_FreeVariables , CFatal, 70; + Fatal_FunctionTypeExpected , CFatal, 71; + Fatal_IdentifierNotFound , CFatal, 72; + Fatal_IllAppliedConstant , CFatal, 73; + Fatal_IllegalCharInByteArray , CFatal, 74; + Fatal_IllegalCharInOperatorName , CFatal, 75; + Fatal_IllTyped , CFatal, 76; + Fatal_ImpossibleAbbrevLidBundle , CFatal, 77; + Fatal_ImpossibleAbbrevRenameBundle , CFatal, 78; + Fatal_ImpossibleInductiveWithAbbrev , CFatal, 79; + Fatal_ImpossiblePrePostAbs , CFatal, 80; + Fatal_ImpossiblePrePostArrow , CFatal, 81; + Fatal_ImpossibleToGenerateDMEffect , CFatal, 82; + Fatal_ImpossibleTypeAbbrevBundle , CFatal, 83; + Fatal_ImpossibleTypeAbbrevSigeltBundle , CFatal, 84; + Fatal_IncludeModuleNotPrepared , CFatal, 85; + Fatal_IncoherentInlineUniverse , CFatal, 86; + Fatal_IncompatibleKinds , CFatal, 87; + Fatal_IncompatibleNumberOfTypes , CFatal, 88; + Fatal_IncompatibleSetOfUniverse , CFatal, 89; + Fatal_IncompatibleUniverse , CFatal, 90; + Fatal_InconsistentImplicitArgumentAnnotation , CFatal, 91; + Fatal_InconsistentImplicitQualifier , CFatal, 92; + Fatal_InconsistentQualifierAnnotation , CFatal, 93; + Fatal_InferredTypeCauseVarEscape , CFatal, 94; + Fatal_InlineRenamedAsUnfold , CFatal, 95; + Fatal_InsufficientPatternArguments , CFatal, 96; + Fatal_InterfaceAlreadyProcessed , CFatal, 97; + Fatal_InterfaceNotImplementedByModule , CError, 98; + Fatal_InterfaceWithTypeImplementation , CFatal, 99; + Fatal_InvalidFloatingPointNumber , CFatal, 100; + Fatal_InvalidFSDocKeyword , CFatal, 101; + Fatal_InvalidIdentifier , CFatal, 102; + Fatal_InvalidLemmaArgument , CFatal, 103; + Fatal_InvalidNumericLiteral , CFatal, 104; + Fatal_InvalidRedefinitionOfLexT , CFatal, 105; + Fatal_InvalidUnicodeInStringLiteral , CFatal, 106; + Fatal_InvalidUTF8Encoding , CFatal, 107; + Fatal_InvalidWarnErrorSetting , CFatal, 108; + Fatal_LetBoundMonadicMismatch , CFatal, 109; + Fatal_LetMutableForVariablesOnly , CFatal, 110; + Fatal_LetOpenModuleOnly , CFatal, 111; + Fatal_LetRecArgumentMismatch , CFatal, 112; + Fatal_MalformedActionDeclaration , CFatal, 113; + Fatal_MismatchedPatternType , CFatal, 114; + Fatal_MismatchUniversePolymorphic , CFatal, 115; + Fatal_MissingDataConstructor , CFatal, 116; + Fatal_MissingExposeInterfacesOption , CFatal, 117; + Fatal_MissingFieldInRecord , CFatal, 118; + Fatal_MissingImplementation , CFatal, 119; + Fatal_MissingImplicitArguments , CFatal, 120; + Fatal_MissingInterface , CFatal, 121; + Fatal_MissingNameInBinder , CFatal, 122; + Fatal_MissingPrimsModule , CFatal, 123; + Fatal_MissingQuantifierBinder , CFatal, 124; + Fatal_ModuleExpected , CFatal, 125; + Fatal_ModuleFileNotFound , CFatal, 126; + Fatal_ModuleFirstStatement , CFatal, 127; + Fatal_ModuleNotFound , CFatal, 128; + Fatal_ModuleOrFileNotFound , CFatal, 129; + Fatal_MonadAlreadyDefined , CFatal, 130; + Fatal_MoreThanOneDeclaration , CFatal, 131; + Fatal_MultipleLetBinding , CFatal, 132; + Fatal_NameNotFound , CFatal, 133; + Fatal_NameSpaceNotFound , CFatal, 134; + Fatal_NegativeUniverseConstFatal_NotSupported , CFatal, 135; + Fatal_NoFileProvided , CFatal, 136; + Fatal_NonInductiveInMutuallyDefinedType , CFatal, 137; + Fatal_NonLinearPatternNotPermitted , CFatal, 138; + Fatal_NonLinearPatternVars , CFatal, 139; + Fatal_NonSingletonTopLevel , CFatal, 140; + Fatal_NonSingletonTopLevelModule , CFatal, 141; + Error_NonTopRecFunctionNotFullyEncoded , CAlwaysError, 142; + Fatal_NonTrivialPreConditionInPrims , CFatal, 143; + Fatal_NonVariableInductiveTypeParameter , CFatal, 144; + Fatal_NotApplicationOrFv , CFatal, 145; + Fatal_NotEnoughArgsToEffect , CFatal, 146; + Fatal_NotEnoughArgumentsForEffect , CFatal, 147; + Fatal_NotFunctionType , CFatal, 148; + Fatal_NotSupported , CFatal, 149; + Fatal_NotTopLevelModule , CFatal, 150; + Fatal_NotValidFStarFile , CFatal, 151; + Fatal_NotValidIncludeDirectory , CWarning, 152; + Fatal_OneModulePerFile , CFatal, 153; + Fatal_OpenGoalsInSynthesis , CFatal, 154; + Fatal_OptionsNotCompatible , CFatal, 155; + Fatal_OutOfOrder , CFatal, 156; + Fatal_ParseErrors , CFatal, 157; + Fatal_ParseItError , CFatal, 158; + Fatal_PolyTypeExpected , CFatal, 159; + Fatal_PossibleInfiniteTyp , CFatal, 160; + Fatal_PreModuleMismatch , CFatal, 161; + Fatal_QulifierListNotPermitted , CFatal, 162; + Fatal_RecursiveFunctionLiteral , CFatal, 163; + Fatal_ReflectOnlySupportedOnEffects , CFatal, 164; + Fatal_ReservedPrefix , CFatal, 165; + Fatal_SMTOutputParseError , CFatal, 166; + Fatal_SMTSolverError , CFatal, 167; + Fatal_SyntaxError , CFatal, 168; + Fatal_SynthByTacticError , CFatal, 169; + Fatal_TacticGotStuck , CFatal, 170; + Fatal_TcOneFragmentFailed , CFatal, 171; + Fatal_TermOutsideOfDefLanguage , CFatal, 172; + Fatal_ToManyArgumentToFunction , CFatal, 173; + Fatal_TooManyOrTooFewFileMatch , CFatal, 174; + Fatal_TooManyPatternArguments , CFatal, 175; + Fatal_TooManyUniverse , CFatal, 176; + Fatal_TypeMismatch , CFatal, 177; + Fatal_TypeWithinPatternsAllowedOnVariablesOnly , CFatal, 178; + Fatal_UnableToReadFile , CFatal, 179; + Fatal_UnepxectedOrUnboundOperator , CFatal, 180; + Fatal_UnexpectedBinder , CFatal, 181; + Fatal_UnexpectedBindShape , CFatal, 182; + Fatal_UnexpectedChar , CFatal, 183; + Fatal_UnexpectedComputationTypeForLetRec , CFatal, 184; + Fatal_UnexpectedConstructorType , CFatal, 185; + Fatal_UnexpectedDataConstructor , CFatal, 186; + Fatal_UnexpectedEffect , CFatal, 187; + Fatal_UnexpectedEmptyRecord , CFatal, 188; + Fatal_UnexpectedExpressionType , CFatal, 189; + Fatal_UnexpectedFunctionParameterType , CFatal, 190; + Fatal_UnexpectedGeneralizedUniverse , CFatal, 191; + Fatal_UnexpectedGTotForLetRec , CFatal, 192; + Fatal_UnexpectedGuard , CFatal, 193; + Fatal_UnexpectedIdentifier , CFatal, 194; + Fatal_UnexpectedImplicitArgument , CFatal, 195; + Fatal_UnexpectedImplictArgument , CFatal, 196; + Fatal_UnexpectedInductivetype , CFatal, 197; + Fatal_UnexpectedLetBinding , CFatal, 198; + Fatal_UnexpectedModuleDeclaration , CFatal, 199; + Fatal_UnexpectedNumberOfUniverse , CFatal, 200; + Fatal_UnexpectedNumericLiteral , CFatal, 201; + Fatal_UnexpectedPattern , CFatal, 203; + Fatal_UnexpectedPosition , CFatal, 204; + Fatal_UnExpectedPreCondition , CFatal, 205; + Fatal_UnexpectedReturnShape , CFatal, 206; + Fatal_UnexpectedSignatureForMonad , CFatal, 207; + Fatal_UnexpectedTerm , CFatal, 208; + Fatal_UnexpectedTermInUniverse , CFatal, 209; + Fatal_UnexpectedTermType , CFatal, 210; + Fatal_UnexpectedTermVQuote , CFatal, 211; + Fatal_UnexpectedUniversePolymorphicReturn , CFatal, 212; + Fatal_UnexpectedUniverseVariable , CFatal, 213; + Fatal_UnfoldableDeprecated , CFatal, 214; + Fatal_UnificationNotWellFormed , CFatal, 215; + Fatal_Uninstantiated , CFatal, 216; + Error_UninstantiatedUnificationVarInTactic , CError, 217; + Fatal_UninstantiatedVarInTactic , CFatal, 218; + Fatal_UniverseMightContainSumOfTwoUnivVars , CFatal, 219; + Fatal_UniversePolymorphicInnerLetBound , CFatal, 220; + Fatal_UnknownAttribute , CFatal, 221; + Fatal_UnknownToolForDep , CFatal, 222; + Fatal_UnrecognizedExtension , CFatal, 223; + Fatal_UnresolvedPatternVar , CFatal, 224; + Fatal_UnsupportedConstant , CFatal, 225; + Fatal_UnsupportedDisjuctivePatterns , CFatal, 226; + Fatal_UnsupportedQualifier , CFatal, 227; + Fatal_UserTacticFailure , CFatal, 228; + Fatal_ValueRestriction , CFatal, 229; + Fatal_VariableNotFound , CFatal, 230; + Fatal_WrongBodyTypeForReturnWP , CFatal, 231; + Fatal_WrongDataAppHeadFormat , CFatal, 232; + Fatal_WrongDefinitionOrder , CFatal, 233; + Fatal_WrongResultTypeAfterConstrutor , CFatal, 234; + Fatal_WrongTerm , CFatal, 235; + Fatal_WhenClauseNotSupported , CFatal, 236; + Unused01 , CFatal, 237; + Warning_PluginNotImplemented , CError, 238; + Warning_AddImplicitAssumeNewQualifier , CWarning, 239; + Error_AdmitWithoutDefinition , CError, 240; + Warning_CachedFile , CWarning, 241; + Warning_DefinitionNotTranslated , CWarning, 242; + Warning_DependencyFound , CWarning, 243; + Warning_DeprecatedEqualityOnBinder , CWarning, 244; + Warning_DeprecatedOpaqueQualifier , CWarning, 245; + Warning_DocOverwrite , CWarning, 246; + Warning_FileNotWritten , CWarning, 247; + Warning_Filtered , CWarning, 248; + Warning_FunctionLiteralPrecisionLoss , CWarning, 249; + Warning_FunctionNotExtacted , CWarning, 250; + Warning_HintFailedToReplayProof , CWarning, 251; + Warning_HitReplayFailed , CWarning, 252; + Warning_IDEIgnoreCodeGen , CWarning, 253; + Warning_IllFormedGoal , CWarning, 254; + Warning_InaccessibleArgument , CWarning, 255; + Warning_IncoherentImplicitQualifier , CWarning, 256; + Warning_IrrelevantQualifierOnArgumentToReflect , CWarning, 257; + Warning_IrrelevantQualifierOnArgumentToReify , CWarning, 258; + Warning_MalformedWarnErrorList , CWarning, 259; + Warning_MetaAlienNotATmUnknown , CWarning, 260; + Warning_MultipleAscriptions , CWarning, 261; + Warning_NondependentUserDefinedDataType , CWarning, 262; + Warning_NonListLiteralSMTPattern , CWarning, 263; + Warning_NormalizationFailure , CWarning, 264; + Warning_NotDependentArrow , CWarning, 265; + Warning_NotEmbedded , CWarning, 266; + Warning_PatternMissingBoundVar , CWarning, 267; + Warning_RecursiveDependency , CWarning, 268; + Warning_RedundantExplicitCurrying , CWarning, 269; + Warning_SMTPatTDeprecated , CWarning, 270; + Warning_SMTPatternIllFormed , CWarning, 271; + Warning_TopLevelEffect , CWarning, 272; + Warning_UnboundModuleReference , CWarning, 273; + Warning_UnexpectedFile , CWarning, 274; + Warning_UnexpectedFsTypApp , CWarning, 275; + Warning_UnexpectedZ3Output , CError, 276; + Warning_UnprotectedTerm , CWarning, 277; + Warning_UnrecognizedAttribute , CWarning, 278; + Warning_UpperBoundCandidateAlreadyVisited , CWarning, 279; + Warning_UseDefaultEffect , CWarning, 280; + Warning_WrongErrorLocation , CWarning, 281; + Warning_Z3InvocationWarning , CWarning, 282; + Warning_MissingInterfaceOrImplementation , CWarning, 283; + Warning_ConstructorBuildsUnexpectedType , CWarning, 284; + Warning_ModuleOrFileNotFoundWarning , CWarning, 285; + Error_NoLetMutable , CAlwaysError, 286; + Error_BadImplicit , CAlwaysError, 287; + Warning_DeprecatedDefinition , CWarning, 288; + Fatal_SMTEncodingArityMismatch , CFatal, 289; + Warning_Defensive , CWarning, 290; + Warning_CantInspect , CWarning, 291; + Warning_NilGivenExplicitArgs , CWarning, 292; + Warning_ConsAppliedExplicitArgs , CWarning, 293; + Warning_UnembedBinderKnot , CWarning, 294; + Fatal_TacticProofRelevantGoal , CFatal, 295; + Warning_TacAdmit , CWarning, 296; + Fatal_IncoherentPatterns , CFatal, 297; + Error_NoSMTButNeeded , CAlwaysError, 298; + Fatal_UnexpectedAntiquotation , CFatal, 299; + Fatal_SplicedUndef , CFatal, 300; + Fatal_SpliceUnembedFail , CFatal, 301; + Warning_ExtractionUnexpectedEffect , CWarning, 302; + Error_DidNotFail , CError, 303; + Warning_UnappliedFail , CWarning, 304; + Warning_QuantifierWithoutPattern , CSilent, 305; + Error_EmptyFailErrs , CAlwaysError, 306; + Warning_logicqualifier , CWarning, 307; + Fatal_CyclicDependence , CFatal, 308; + Error_InductiveAnnotNotAType , CError, 309; + Fatal_FriendInterface , CFatal, 310; + Error_CannotRedefineConst , CError, 311; + Error_BadClassDecl , CError, 312; + Error_BadInductiveParam , CFatal, 313; + Error_FieldShadow , CFatal, 314; + Error_UnexpectedDM4FType , CFatal, 315; + Fatal_EffectAbbreviationResultTypeMismatch , CFatal, 316; + Error_AlreadyCachedAssertionFailure , CFatal, 317; + Error_MustEraseMissing , CWarning, 318; + Warning_EffectfulArgumentToErasedFunction , CWarning, 319; + Fatal_EmptySurfaceLet , CFatal, 320; + Warning_UnexpectedCheckedFile , CWarning, 321; + Fatal_ExtractionUnsupported , CFatal, 322; + Warning_SMTErrorReason , CWarning, 323; + Warning_CoercionNotFound , CWarning, 324; + Error_QuakeFailed , CError, 325; + Error_IllSMTPat , CError, 326; + Error_IllScopedTerm , CError, 327; + Warning_UnusedLetRec , CWarning, 328; + Fatal_Effects_Ordering_Coherence , CError, 329; + Warning_BleedingEdge_Feature , CWarning, 330; + Warning_IgnoredBinding , CWarning, 331; + Warning_CouldNotReadHints , CWarning, 333; + Fatal_BadUvar , CFatal, 334; + Warning_WarnOnUse , CSilent, 335; + Warning_DeprecatedAttributeSyntax , CSilent, 336; + Warning_DeprecatedGeneric , CWarning, 337; + Error_BadSplice , CError, 338; + Error_UnexpectedUnresolvedUvar , CAlwaysError, 339; + Warning_UnfoldPlugin , CWarning, 340; + Error_LayeredMissingAnnot , CAlwaysError, 341; + Error_CallToErased , CError, 342; + Error_ErasedCtor , CError, 343; + Error_RemoveUnusedTypeParameter , CWarning, 344; + Warning_NoMagicInFSharp , CWarning, 345; + Error_BadLetOpenRecord , CAlwaysError, 346; + Error_UnexpectedTypeclassInstance , CAlwaysError, 347; + Warning_AmbiguousResolveImplicitsHook , CWarning, 348; + Warning_SplitAndRetryQueries , CWarning, 349; + Warning_DeprecatedLightDoNotation , CWarning, 350; + Warning_FailedToCheckInitialTacticGoal , CSilent, 351; + Warning_Adhoc_IndexedEffect_Combinator , CWarning, 352; + Error_PluginDynlink , CError, 353; + Error_InternalQualifier , CAlwaysError, 354; + Warning_NameEscape , CWarning, 355; + Warning_UnexpectedZ3Stderr , CWarning, 356; + Warning_SolverMismatch , CError, 357; + Warning_SolverVersionMismatch , CError, 358; + Warning_ProofRecovery , CWarning, 359; + Error_CannotResolveRecord , CAlwaysError, 360; + Error_MissingPopOptions , CWarning, 361; + ] diff --git a/src/basic/FStarC.Errors.Codes.fsti b/src/basic/FStarC.Errors.Codes.fsti new file mode 100644 index 00000000000..9a6d6fe240f --- /dev/null +++ b/src/basic/FStarC.Errors.Codes.fsti @@ -0,0 +1,395 @@ +(* + Copyright 2008-2020 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Errors.Codes + +(* Kinds of errors. *) +type error_flag = + | CFatal //CFatal: these are reported using a raise_error: compiler cannot progress + | CAlwaysError //CAlwaysError: these errors are reported using log_issue and cannot be suppressed + //the compiler can progress after reporting them + | CError //CError: these are reported as errors using log_issue + // but they can be turned into warnings or silenced + | CWarning //CWarning: reported using log_issue as warnings by default; + // then can be silenced or escalated to errors + | CSilent //CSilent: never the default for any issue, but warnings can be silenced + +(* The list of all available error codes *) +type error_code = + | Error_DependencyAnalysisFailed + | Error_IDETooManyPops + | Error_IDEUnrecognized + | Error_InductiveTypeNotSatisfyPositivityCondition + | Error_InvalidUniverseVar + | Error_MissingFileName + | Error_ModuleFileNameMismatch + | Error_OpPlusInUniverse + | Error_OutOfRange + | Error_ProofObligationFailed + | Error_TooManyFiles + | Error_TypeCheckerFailToProve + | Error_TypeError + | Error_UncontrainedUnificationVar + | Error_UnexpectedGTotComputation + | Error_UnexpectedInstance + | Error_UnknownFatal_AssertionFailure + | Error_Z3InvocationError + | Error_IDEAssertionFailure + | Error_Z3SolverError + | Fatal_AbstractTypeDeclarationInInterface + | Fatal_ActionMustHaveFunctionType + | Fatal_AlreadyDefinedTopLevelDeclaration + | Fatal_ArgumentLengthMismatch + | Fatal_AssertionFailure + | Fatal_AssignToImmutableValues + | Fatal_AssumeValInInterface + | Fatal_BadlyInstantiatedSynthByTactic + | Fatal_BadSignatureShape + | Fatal_BinderAndArgsLengthMismatch + | Fatal_BothValAndLetInInterface + | Fatal_CardinalityConstraintViolated + | Fatal_ComputationNotTotal + | Fatal_ComputationTypeNotAllowed + | Fatal_ComputedTypeNotMatchAnnotation + | Fatal_ConstructorArgLengthMismatch + | Fatal_ConstructorFailedCheck + | Fatal_ConstructorNotFound + | Fatal_ConstsructorBuildWrongType + | Fatal_CycleInRecTypeAbbreviation + | Fatal_DataContructorNotFound + | Fatal_DefaultQualifierNotAllowedOnEffects + | Fatal_DefinitionNotFound + | Fatal_DisjuctivePatternVarsMismatch + | Fatal_DivergentComputationCannotBeIncludedInTotal + | Fatal_DuplicateInImplementation + | Fatal_DuplicateModuleOrInterface + | Fatal_DuplicateTopLevelNames + | Fatal_DuplicateTypeAnnotationAndValDecl + | Fatal_EffectCannotBeReified + | Fatal_EffectConstructorNotFullyApplied + | Fatal_EffectfulAndPureComputationMismatch + | Fatal_EffectNotFound + | Fatal_EffectsCannotBeComposed + | Fatal_ErrorInSolveDeferredConstraints + | Fatal_ErrorsReported + | Fatal_EscapedBoundVar + | Fatal_ExpectedArrowAnnotatedType + | Fatal_ExpectedGhostExpression + | Fatal_ExpectedPureExpression + | Fatal_ExpectNormalizedEffect + | Fatal_ExpectTermGotFunction + | Fatal_ExpectTrivialPreCondition + | Fatal_FailToCompileNativeTactic + | Fatal_FailToExtractNativeTactic + | Fatal_FailToProcessPragma + | Fatal_FailToResolveImplicitArgument + | Fatal_FailToSolveUniverseInEquality + | Fatal_FieldsNotBelongToSameRecordType + | Fatal_ForbiddenReferenceToCurrentModule + | Fatal_FreeVariables + | Fatal_FunctionTypeExpected + | Fatal_IdentifierNotFound + | Fatal_IllAppliedConstant + | Fatal_IllegalCharInByteArray + | Fatal_IllegalCharInOperatorName + | Fatal_IllTyped + | Fatal_ImpossibleAbbrevLidBundle + | Fatal_ImpossibleAbbrevRenameBundle + | Fatal_ImpossibleInductiveWithAbbrev + | Fatal_ImpossiblePrePostAbs + | Fatal_ImpossiblePrePostArrow + | Fatal_ImpossibleToGenerateDMEffect + | Fatal_ImpossibleTypeAbbrevBundle + | Fatal_ImpossibleTypeAbbrevSigeltBundle + | Fatal_IncludeModuleNotPrepared + | Fatal_IncoherentInlineUniverse + | Fatal_IncompatibleKinds + | Fatal_IncompatibleNumberOfTypes + | Fatal_IncompatibleSetOfUniverse + | Fatal_IncompatibleUniverse + | Fatal_InconsistentImplicitArgumentAnnotation + | Fatal_InconsistentImplicitQualifier + | Fatal_InconsistentQualifierAnnotation + | Fatal_InferredTypeCauseVarEscape + | Fatal_InlineRenamedAsUnfold + | Fatal_InsufficientPatternArguments + | Fatal_InterfaceAlreadyProcessed + | Fatal_InterfaceNotImplementedByModule + | Fatal_InterfaceWithTypeImplementation + | Fatal_InvalidFloatingPointNumber + | Fatal_InvalidFSDocKeyword + | Fatal_InvalidIdentifier + | Fatal_InvalidLemmaArgument + | Fatal_InvalidNumericLiteral + | Fatal_InvalidRedefinitionOfLexT + | Fatal_InvalidUnicodeInStringLiteral + | Fatal_InvalidUTF8Encoding + | Fatal_InvalidWarnErrorSetting + | Fatal_LetBoundMonadicMismatch + | Fatal_LetMutableForVariablesOnly + | Fatal_LetOpenModuleOnly + | Fatal_LetRecArgumentMismatch + | Fatal_MalformedActionDeclaration + | Fatal_MismatchedPatternType + | Fatal_MismatchUniversePolymorphic + | Fatal_MissingDataConstructor + | Fatal_MissingExposeInterfacesOption + | Fatal_MissingFieldInRecord + | Fatal_MissingImplementation + | Fatal_MissingImplicitArguments + | Fatal_MissingInterface + | Fatal_MissingNameInBinder + | Fatal_MissingPrimsModule + | Fatal_MissingQuantifierBinder + | Fatal_ModuleExpected + | Fatal_ModuleFileNotFound + | Fatal_ModuleFirstStatement + | Fatal_ModuleNotFound + | Fatal_ModuleOrFileNotFound + | Fatal_MonadAlreadyDefined + | Fatal_MoreThanOneDeclaration + | Fatal_MultipleLetBinding + | Fatal_NameNotFound + | Fatal_NameSpaceNotFound + | Fatal_NegativeUniverseConstFatal_NotSupported + | Fatal_NoFileProvided + | Fatal_NonInductiveInMutuallyDefinedType + | Fatal_NonLinearPatternNotPermitted + | Fatal_NonLinearPatternVars + | Fatal_NonSingletonTopLevel + | Fatal_NonSingletonTopLevelModule + | Error_NonTopRecFunctionNotFullyEncoded + | Fatal_NonTrivialPreConditionInPrims + | Fatal_NonVariableInductiveTypeParameter + | Fatal_NotApplicationOrFv + | Fatal_NotEnoughArgsToEffect + | Fatal_NotEnoughArgumentsForEffect + | Fatal_NotFunctionType + | Fatal_NotSupported + | Fatal_NotTopLevelModule + | Fatal_NotValidFStarFile + | Fatal_NotValidIncludeDirectory + | Fatal_OneModulePerFile + | Fatal_OpenGoalsInSynthesis + | Fatal_OptionsNotCompatible + | Fatal_OutOfOrder + | Fatal_ParseErrors + | Fatal_ParseItError + | Fatal_PolyTypeExpected + | Fatal_PossibleInfiniteTyp + | Fatal_PreModuleMismatch + | Fatal_QulifierListNotPermitted + | Fatal_RecursiveFunctionLiteral + | Fatal_ReflectOnlySupportedOnEffects + | Fatal_ReservedPrefix + | Fatal_SMTOutputParseError + | Fatal_SMTSolverError + | Fatal_SyntaxError + | Fatal_SynthByTacticError + | Fatal_TacticGotStuck + | Fatal_TcOneFragmentFailed + | Fatal_TermOutsideOfDefLanguage + | Fatal_ToManyArgumentToFunction + | Fatal_TooManyOrTooFewFileMatch + | Fatal_TooManyPatternArguments + | Fatal_TooManyUniverse + | Fatal_TypeMismatch + | Fatal_TypeWithinPatternsAllowedOnVariablesOnly + | Fatal_UnableToReadFile + | Fatal_UnepxectedOrUnboundOperator + | Fatal_UnexpectedBinder + | Fatal_UnexpectedBindShape + | Fatal_UnexpectedChar + | Fatal_UnexpectedComputationTypeForLetRec + | Fatal_UnexpectedConstructorType + | Fatal_UnexpectedDataConstructor + | Fatal_UnexpectedEffect + | Fatal_UnexpectedEmptyRecord + | Fatal_UnexpectedExpressionType + | Fatal_UnexpectedFunctionParameterType + | Fatal_UnexpectedGeneralizedUniverse + | Fatal_UnexpectedGTotForLetRec + | Fatal_UnexpectedGuard + | Fatal_UnexpectedIdentifier + | Fatal_UnexpectedImplicitArgument + | Fatal_UnexpectedImplictArgument + | Fatal_UnexpectedInductivetype + | Fatal_UnexpectedLetBinding + | Fatal_UnexpectedModuleDeclaration + | Fatal_UnexpectedNumberOfUniverse + | Fatal_UnexpectedNumericLiteral + | Fatal_UnexpectedPattern + | Fatal_UnexpectedPosition + | Fatal_UnExpectedPreCondition + | Fatal_UnexpectedReturnShape + | Fatal_UnexpectedSignatureForMonad + | Fatal_UnexpectedTerm + | Fatal_UnexpectedTermInUniverse + | Fatal_UnexpectedTermType + | Fatal_UnexpectedTermVQuote + | Fatal_UnexpectedUniversePolymorphicReturn + | Fatal_UnexpectedUniverseVariable + | Fatal_UnfoldableDeprecated + | Fatal_UnificationNotWellFormed + | Fatal_Uninstantiated + | Error_UninstantiatedUnificationVarInTactic + | Fatal_UninstantiatedVarInTactic + | Fatal_UniverseMightContainSumOfTwoUnivVars + | Fatal_UniversePolymorphicInnerLetBound + | Fatal_UnknownAttribute + | Fatal_UnknownToolForDep + | Fatal_UnrecognizedExtension + | Fatal_UnresolvedPatternVar + | Fatal_UnsupportedConstant + | Fatal_UnsupportedDisjuctivePatterns + | Fatal_UnsupportedQualifier + | Fatal_UserTacticFailure + | Fatal_ValueRestriction + | Fatal_VariableNotFound + | Fatal_WrongBodyTypeForReturnWP + | Fatal_WrongDataAppHeadFormat + | Fatal_WrongDefinitionOrder + | Fatal_WrongResultTypeAfterConstrutor + | Fatal_WrongTerm + | Fatal_WhenClauseNotSupported + | Unused01 + | Warning_AddImplicitAssumeNewQualifier + | Error_AdmitWithoutDefinition + | Warning_CachedFile + | Warning_DefinitionNotTranslated + | Warning_DependencyFound + | Warning_DeprecatedEqualityOnBinder + | Warning_DeprecatedOpaqueQualifier + | Warning_DocOverwrite + | Warning_FileNotWritten + | Warning_Filtered + | Warning_FunctionLiteralPrecisionLoss + | Warning_FunctionNotExtacted + | Warning_HintFailedToReplayProof + | Warning_HitReplayFailed + | Warning_IDEIgnoreCodeGen + | Warning_IllFormedGoal + | Warning_InaccessibleArgument + | Warning_IncoherentImplicitQualifier + | Warning_IrrelevantQualifierOnArgumentToReflect + | Warning_IrrelevantQualifierOnArgumentToReify + | Warning_MalformedWarnErrorList + | Warning_MetaAlienNotATmUnknown + | Warning_MultipleAscriptions + | Warning_NondependentUserDefinedDataType + | Warning_NonListLiteralSMTPattern + | Warning_NormalizationFailure + | Warning_NotDependentArrow + | Warning_NotEmbedded + | Warning_PatternMissingBoundVar //AR: this is deprecated, use Warning_SMTPatternIllFormed instead + // not removing it so as not to mess up the error numbers + | Warning_RecursiveDependency + | Warning_RedundantExplicitCurrying + | Warning_SMTPatTDeprecated + | Warning_SMTPatternIllFormed + | Warning_TopLevelEffect + | Warning_UnboundModuleReference + | Warning_UnexpectedFile + | Warning_UnexpectedFsTypApp + | Warning_UnexpectedZ3Output + | Warning_UnprotectedTerm + | Warning_UnrecognizedAttribute + | Warning_UpperBoundCandidateAlreadyVisited + | Warning_UseDefaultEffect + | Warning_WrongErrorLocation + | Warning_Z3InvocationWarning + | Warning_PluginNotImplemented + | Warning_MissingInterfaceOrImplementation + | Warning_ConstructorBuildsUnexpectedType + | Warning_ModuleOrFileNotFoundWarning + | Error_NoLetMutable + | Error_BadImplicit + | Warning_DeprecatedDefinition + | Fatal_SMTEncodingArityMismatch + | Warning_Defensive + | Warning_CantInspect + | Warning_NilGivenExplicitArgs + | Warning_ConsAppliedExplicitArgs + | Warning_UnembedBinderKnot + | Fatal_TacticProofRelevantGoal + | Warning_TacAdmit + | Fatal_IncoherentPatterns + | Error_NoSMTButNeeded + | Fatal_UnexpectedAntiquotation + | Fatal_SplicedUndef + | Fatal_SpliceUnembedFail + | Warning_ExtractionUnexpectedEffect + | Error_DidNotFail + | Warning_UnappliedFail + | Warning_QuantifierWithoutPattern + | Error_EmptyFailErrs + | Warning_logicqualifier + | Fatal_CyclicDependence + | Error_InductiveAnnotNotAType + | Fatal_FriendInterface + | Error_CannotRedefineConst + | Error_BadClassDecl + | Error_BadInductiveParam + | Error_FieldShadow + | Error_UnexpectedDM4FType + | Fatal_EffectAbbreviationResultTypeMismatch + | Error_AlreadyCachedAssertionFailure + | Error_MustEraseMissing + | Warning_EffectfulArgumentToErasedFunction + | Fatal_EmptySurfaceLet + | Warning_UnexpectedCheckedFile + | Fatal_ExtractionUnsupported + | Warning_SMTErrorReason + | Warning_CoercionNotFound + | Error_QuakeFailed + | Error_IllSMTPat + | Error_IllScopedTerm + | Warning_UnusedLetRec + | Fatal_Effects_Ordering_Coherence + | Warning_BleedingEdge_Feature + | Warning_IgnoredBinding + | Warning_CouldNotReadHints + | Fatal_BadUvar + | Warning_WarnOnUse + | Warning_DeprecatedAttributeSyntax + | Warning_DeprecatedGeneric + | Error_BadSplice + | Error_UnexpectedUnresolvedUvar + | Warning_UnfoldPlugin + | Error_LayeredMissingAnnot + | Error_CallToErased + | Error_ErasedCtor + | Error_RemoveUnusedTypeParameter + | Warning_NoMagicInFSharp + | Error_BadLetOpenRecord + | Error_UnexpectedTypeclassInstance + | Warning_AmbiguousResolveImplicitsHook + | Warning_SplitAndRetryQueries + | Warning_DeprecatedLightDoNotation + | Warning_FailedToCheckInitialTacticGoal + | Warning_Adhoc_IndexedEffect_Combinator + | Error_PluginDynlink + | Error_InternalQualifier + | Warning_NameEscape + | Warning_UnexpectedZ3Stderr + | Warning_SolverMismatch + | Warning_SolverVersionMismatch + | Warning_ProofRecovery + | Error_CannotResolveRecord + | Error_MissingPopOptions + +type error_setting = error_code & error_flag & int + +val default_settings : list error_setting diff --git a/src/basic/FStarC.Errors.Msg.fst b/src/basic/FStarC.Errors.Msg.fst new file mode 100644 index 00000000000..906598cee3b --- /dev/null +++ b/src/basic/FStarC.Errors.Msg.fst @@ -0,0 +1,63 @@ +module FStarC.Errors.Msg + +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.Util +open FStarC.Pprint + +instance is_error_message_string : is_error_message string = { + to_doc_list = (fun s -> [arbitrary_string s]); +} + +instance is_error_message_list_doc : is_error_message (list Pprint.document) = { + to_doc_list = id; +} + +let vconcat (ds:list document) : document = + match ds with + | h::t -> + List.fold_left (fun l r -> l ^^ hardline ^^ r) h t + | [] -> + empty + +let text (s:string) : document = + flow (break_ 1) (words s) + +let sublist (h:document) (ds:list document) : document = + nest 2 (hardline ^^ align (ds |> List.map (fun d -> h ^^ d) |> vconcat)) + +let bulleted (ds:list document) : document = + sublist (doc_of_string "- ") ds + +let mkmsg (s:string) : list document = + [arbitrary_string s] + +let renderdoc (d : document) : string = + let one = float_of_string "1.0" in + pretty_string one 80 d + +let backtrace_doc () : document = + let s = stack_dump () in + text "Stack trace:" ^/^ + arbitrary_string (trim_string s) + +let subdoc' (indent:bool) d = + (* NOTE: slight hack here, using equality on Pprint documents. This works + fine, particularly for this case, since empty is just a constructor Empty. + There is even a new function to check if a document is empty, added two weeks ago! + https://github.com/fpottier/pprint/commit/afecb1a6a2751648f62147660ea8fee7a2dee054 + So I don't expect this to fail any time soon, and when it does we could just + switch to using that function. (I won't right now as it is not released). *) + if d = empty + then empty + else (if indent then blank 2 else empty) ^^ doc_of_string "-" ^^ blank 1 ^^ align d ^^ hardline + +let subdoc d = subdoc' true d + +let rendermsg (ds : list document) : string = + renderdoc (concat (List.map (fun d -> subdoc (group d)) ds)) + +let json_of_error_message (err_msg: list document): FStarC.Json.json + = FStarC.Compiler.List.map + (fun doc -> FStarC.Json.JsonStr (renderdoc doc)) err_msg + |> FStarC.Json.JsonList diff --git a/src/basic/FStarC.Errors.Msg.fsti b/src/basic/FStarC.Errors.Msg.fsti new file mode 100644 index 00000000000..889b3352bba --- /dev/null +++ b/src/basic/FStarC.Errors.Msg.fsti @@ -0,0 +1,67 @@ +module FStarC.Errors.Msg + +open FStarC +open FStarC.Pprint + +(* FIXME: make this interface saner, especially by providing subdoc/sublist, etc *) + +(* An error message is a list of documents. This allows us to print errors like +these: + +* Error 19 at tests/error-messages/Bug1997.fst(92,19-92,49): + - Assertion failed + - The SMT solver could not prove the query. Use --query_stats for more details. + - Also see: Prims.fst(96,32-96,42) + +The header is taken from the code and range, and then the documents are rendered +in order. + +`empty` documents in the list are skipped. +*) +type error_message = list document + +class is_error_message (t:Type) = { + to_doc_list : t -> error_message; +} + +instance val is_error_message_string : is_error_message string +instance val is_error_message_list_doc : is_error_message (list Pprint.document) + +(* A helper for creating errors from strings, only to be used for text. +This will split the string into words and format is a paragraph. + +If you call this with a string containing a pretty-printed term (or +anything else) all its formatting will be lost. You should instead use +[term_to_doc] or similar to work with the documents directly, or as a +last resort use doc_of_string. *) +val text : string -> document + +(* Makes an indented sublist using bullet as a header for each list element. *) +val sublist : bullet:document -> elems:list document -> document + +(* == sublist (doc_of_string "- ") *) +val bulleted : list document -> document + +(* Create a simple error message from a string. If the string is just +text and can be long, please use [text] instead. On the other hand, if +you need to respect indentation/spacing in the string, then use this +one, but if that's the case it's probably better to build a doc instead +of lifting from a string. NB: mkmsg s is equal to [doc_of_string s]. *) +val mkmsg : string -> error_message + +(* As subdoc, but allows to not indent. *) +val subdoc' : indent:bool -> document -> document + +(* A nested document that can be concatenated with another one *) +val subdoc : document -> document + +(* Only to be used by FStarC.Errors *) +val renderdoc : document -> string + +(* Returns a document with the current stack trace *) +val backtrace_doc : unit -> document + +(* Render an error message as a string. *) +val rendermsg : error_message -> string + +val json_of_error_message: list document -> FStarC.Json.json diff --git a/src/basic/FStarC.Errors.fst b/src/basic/FStarC.Errors.fst new file mode 100644 index 00000000000..201b6075a60 --- /dev/null +++ b/src/basic/FStarC.Errors.fst @@ -0,0 +1,693 @@ +(* + Copyright 2008-2020 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Errors + +open FStar.Pervasives +open FStar.String +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Compiler.Util +open FStarC.Compiler.Range +open FStarC.Class.Monad +open FStarC.Options +module List = FStarC.Compiler.List +module BU = FStarC.Compiler.Util +module PP = FStarC.Pprint + +open FStarC.Errors.Codes +open FStarC.Errors.Msg +open FStarC.Json + +let fallback_range : ref (option range) = BU.mk_ref None + +let error_range_bound : ref (option range) = BU.mk_ref None + +let with_error_bound (r:range) (f : unit -> 'a) : 'a = + let old = !error_range_bound in + error_range_bound := Some r; + let res = f () in + error_range_bound := old; + res + +(** This exception is raised in FStar.Error + when a warn_error string could not be processed; + The exception is handled in FStarC.Options as part of + option parsing. *) +exception Invalid_warn_error_setting of string + +let lookup_error settings e = + match + BU.try_find (fun (v, _, i) -> e=v) settings + with + | Some i -> i + | None -> failwith "Impossible: unrecognized error" + +(** Find a (potentially empty) set of issues whose numbers + are in the interval [l,h]. + + Note: We intentionally do not warn on the use of non-existent + issue number *) +let lookup_error_range settings (l, h) = + let matches, _ = + List.partition (fun (_, _, i) -> l <= i && i <= h) settings + in + matches + +let error_number (_, _, i) = i +let errno (e:error_code) : int = error_number (lookup_error default_settings e) + +(* Exported *) +let warn_on_use_errno = errno Warning_WarnOnUse +let defensive_errno = errno Warning_Defensive +let call_to_erased_errno = errno Error_CallToErased + +let update_flags (l:list (error_flag & string)) + : list error_setting + = let set_one_flag i flag default_flag = + match flag, default_flag with + | (CWarning, CAlwaysError) + | (CError, CAlwaysError) -> + raise (Invalid_warn_error_setting + (BU.format1 "cannot turn error %s into warning" + (BU.string_of_int i))) + | (CSilent, CAlwaysError) -> + raise (Invalid_warn_error_setting + (BU.format1 "cannot silence error %s" + (BU.string_of_int i))) + | (CSilent, CFatal) + | (CWarning, CFatal) + | (CError, CFatal) -> + raise (Invalid_warn_error_setting + (BU.format1 "cannot change the error level of fatal error %s" + (BU.string_of_int i))) + | (CAlwaysError, CFatal) -> + CFatal + | _ -> flag + in + let set_flag_for_range (flag, range) = + let errs = lookup_error_range default_settings range in + List.map (fun (v, default_flag, i) -> v, set_one_flag i flag default_flag, i) errs + in + let compute_range (flag, s) = + let r = BU.split s ".." in + let (l,h) = + match r with + | [r1; r2] -> (int_of_string r1, int_of_string r2) + | _ -> raise (Invalid_warn_error_setting + (BU.format1 "Malformed warn-error range %s" s)) + in + flag, (l, h) + in + // NOTE: Rev below so when we handle things like '@0..100-50' + // the -50 overrides the @0..100. + let error_range_settings = List.map compute_range (List.rev l) in + List.collect set_flag_for_range error_range_settings + @ default_settings + +exception Error of error +exception Warning of error +exception Stop +exception Empty_frag + +let json_of_issue_level level + = JsonStr ( match level with + | ENotImplemented -> "NotImplemented" + | EInfo -> "Info" + | EWarning -> "Warning" + | EError -> "Error") + +let json_of_issue issue = + JsonAssoc [ + "msg", json_of_error_message issue.issue_msg; + "level", json_of_issue_level issue.issue_level; + "range", dflt JsonNull (json_of_range <$> issue.issue_range); + "number", dflt JsonNull (JsonInt <$> issue.issue_number); + "ctx", JsonList (JsonStr <$> issue.issue_ctx); + ] + + +let ctx_doc (ctx : list string) : PP.document = + let open FStarC.Pprint in + if Options.error_contexts () + then + ctx + |> List.map (fun s -> hardline ^^ doc_of_string "> " ^^ doc_of_string s) + |> Pprint.concat + else empty + +(* No newline at the end *) +(* Only used externally *) +let issue_message (i:issue) : list PP.document = + let open FStarC.Pprint in + i.issue_msg @ [ctx_doc i.issue_ctx] + +let string_of_issue_level il = + match il with + | EInfo -> "Info" + | EWarning -> "Warning" + | EError -> "Error" + | ENotImplemented -> "Feature not yet implemented: " +let issue_level_of_string = + function + | "Info" -> EInfo + | "Warning" -> EWarning + | "Error" -> EError + | _ -> ENotImplemented + +let optional_def (f : 'a -> PP.document) (def : PP.document) (o : option 'a) : PP.document = + match o with + | Some x -> f x + | None -> def + +let format_issue' (print_hdr:bool) (issue:issue) : string = + let open FStarC.Pprint in + let level_header = doc_of_string (string_of_issue_level issue.issue_level) in + let num_opt = + if issue.issue_level = EError || issue.issue_level = EWarning + then blank 1 ^^ optional_def (fun n -> doc_of_string (string_of_int n)) (doc_of_string "") issue.issue_number + else empty + in + let r = issue.issue_range in + let atrng : document = + match r with + | Some r when r <> Range.dummyRange -> + blank 1 ^^ doc_of_string "at" ^^ blank 1 ^^ doc_of_string (Range.string_of_use_range r) + | _ -> + empty + in + let hdr : document = + if print_hdr + then + doc_of_string "*" ^^ blank 1 ^^ level_header ^^ num_opt ^^ + atrng ^^ + doc_of_string ":" ^^ hardline + else empty + in + let seealso : document = + match r with + | Some r when def_range r <> use_range r && def_range r <> def_range dummyRange -> + doc_of_string "See also" ^^ blank 1 ^^ doc_of_string (Range.string_of_range r) + | _ -> empty + in + let ctx : document = + match issue.issue_ctx with + | h::t when Options.error_contexts () -> + let d1 s = doc_of_string "> " ^^ doc_of_string s in + List.fold_left (fun l r -> l ^^ hardline ^^ d1 r) (d1 h) t + | _ -> empty + in + (* We only indent if we are are printing the header. I.e., only ident for batch errors, + not for VS code diagnostics window. *) + let subdoc = subdoc' print_hdr in + let mainmsg : document = + concat (List.map (fun d -> subdoc (group d)) issue.issue_msg) + in + let doc : document = + (* This ends in a hardline to get a 1-line spacing between errors *) + hdr ^^ + mainmsg ^^ + subdoc seealso ^^ + subdoc ctx + in + renderdoc doc + +let format_issue issue : string = format_issue' true issue + +let print_issue_json issue = + json_of_issue issue |> string_of_json |> BU.print1_error "%s\n" + +let print_issue_rendered issue = + let printer = + match issue.issue_level with + | EInfo -> (fun s -> BU.print_string (colorize_cyan s)) + | EWarning -> BU.print_warning + | EError -> BU.print_error + | ENotImplemented -> BU.print_error in + printer (format_issue issue ^ "\n") + +let print_issue issue = + match FStarC.Options.message_format () with + | Human -> print_issue_rendered issue + | Json -> print_issue_json issue + +let compare_issues i1 i2 = + match i1.issue_range, i2.issue_range with + | None, None -> 0 + | None, Some _ -> -1 + | Some _, None -> 1 + | Some r1, Some r2 -> FStarC.Compiler.Range.compare_use_range r1 r2 + +let dummy_ide_rng : Range.rng = + mk_rng "" (mk_pos 1 0) (mk_pos 1 0) + +let maybe_bound_rng (r : Range.range) : Range.range = + match !error_range_bound with + | Some r' -> Range.bound_range r r' + | None -> r + +(* Attempts to set a decent range (no dummy, no dummy ide) relying +on the fallback_range reference. *) +let fixup_issue_range (i:issue) : issue = + let rng = + match i.issue_range with + | None -> + (* No range given, just rely on the fallback. NB: the + fallback could also be set to None if it's too early. *) + !fallback_range + | Some range -> + let use_rng = use_range range in + let use_rng' = + if use_rng <> dummy_rng && use_rng <> dummy_ide_rng then + (* Looks good, use it *) + use_rng + else if Some? (!fallback_range) then + (* Or take the use range from the fallback *) + use_range (Some?.v (!fallback_range)) + else + (* Doesn't look good, but no fallback, oh well *) + use_rng + in + Some (set_use_range range use_rng') + in + { i with issue_range = map_opt rng maybe_bound_rng } + +let mk_default_handler print = + let issues : ref (list issue) = BU.mk_ref [] in + (* This number may be greater than the amount of 'EErrors' + * in the list above due to errors that were immediately + * printed (if debug_any()) *) + let err_count : ref int = BU.mk_ref 0 in + + let add_one (e: issue) = + (if e.issue_level = EError then + err_count := 1 + !err_count); + begin match e.issue_level with + | EInfo when print -> print_issue e + | _ when print && Debug.any () -> print_issue e + | _ -> issues := e :: !issues + end; + if Options.defensive_abort () && e.issue_number = Some defensive_errno then + failwith "Aborting due to --defensive abort"; + () + in + let count_errors () = !err_count in + let report () = + let unique_issues = BU.remove_dups (fun i0 i1 -> i0=i1) !issues in + let sorted_unique_issues = List.sortWith compare_issues unique_issues in + if print then List.iter print_issue sorted_unique_issues; + sorted_unique_issues + in + let clear () = issues := []; err_count := 0 in + { eh_name = "default handler (print=" ^ string_of_bool print ^ ")"; + eh_add_one = add_one; + eh_count_errors = count_errors; + eh_report = report; + eh_clear = clear } + +let default_handler = mk_default_handler true + +let current_handler = + BU.mk_ref default_handler + +let mk_issue level range msg n ctx = { + issue_level = level; + issue_range = range; + issue_msg = msg; + issue_number = n; + issue_ctx = ctx; +} + +let get_err_count () = (!current_handler).eh_count_errors () + +let wrapped_eh_add_one (h : error_handler) (issue : issue) : unit = + (* Try to set a good use range if we got an empty/dummy one *) + let issue = fixup_issue_range issue in + h.eh_add_one issue; + if issue.issue_level <> EInfo then begin + Options.abort_counter := !Options.abort_counter - 1; + if !Options.abort_counter = 0 then + failwith "Aborting due to --abort_on" + end + +let add_one issue = + atomically (fun () -> wrapped_eh_add_one (!current_handler) issue) + +let add_many issues = + atomically (fun () -> List.iter (wrapped_eh_add_one (!current_handler)) issues) + +let add_issues issues = add_many issues + +let report_all () = + (!current_handler).eh_report () + +let clear () = + (!current_handler).eh_clear () + +let set_handler handler = + let issues = report_all () in + clear (); current_handler := handler; add_many issues + +type error_context_t = { + push : string -> unit; + pop : unit -> string; + clear : unit -> unit; + get : unit -> list string; + set : list string -> unit; +} + +let error_context : error_context_t = + let ctxs = BU.mk_ref [] in + let push s = ctxs := s :: !ctxs in + let pop s = + match !ctxs with + | h::t -> (ctxs := t; h) + | _ -> failwith "cannot pop error prefix..." + in + let clear () = ctxs := [] in + let get () = !ctxs in + let set c = ctxs := c in + { push = push + ; pop = pop + ; clear = clear + ; get = get + ; set = set + } + +let get_ctx () : list string = + error_context.get () + +let maybe_add_backtrace (msg : error_message) : error_message = + if Options.trace_error () then + msg @ [backtrace_doc ()] + else + msg + +let warn_unsafe_options rng_opt msg = + match Options.report_assumes () with + | Some "warn" -> + add_one (mk_issue EWarning rng_opt (mkmsg ("Every use of this option triggers a warning: " ^ msg)) (Some warn_on_use_errno) []) + | Some "error" -> + add_one (mk_issue EError rng_opt (mkmsg ("Every use of this option triggers an error: " ^ msg)) (Some warn_on_use_errno) []) + | _ -> () + +let set_option_warning_callback_range (ropt:option FStarC.Compiler.Range.range) = + Options.set_option_warning_callback (warn_unsafe_options ropt) + +let t_set_parse_warn_error, + error_flags = + (* To parse a warn_error string we expect a callback to be set in FStarC.Main.setup_hooks *) + let parser_callback : ref (option (string -> list error_setting)) = mk_ref None in + (* The reporting of errors, particularly errors in the warn_error string itself + is delicate. + We keep a map from warn_error strings to their parsed results, + - Some list error_setting in case it parses and is interpreted successfully + - None in case it does not parse or is not intepretable + *) + let error_flags : BU.smap (option (list error_setting)) = BU.smap_create 10 in + (* set_error_flags is called by Options.set_options, parse_cmd_line etc, + upon parsing the options. + It parses the current warn_error string and sets the result in the + error_flags map above. In case it fails, it reports an Getopt error + for Options to report. Options may, in turn, report that error + back using the functionality of this module, e.g., log_issue *) + let set_error_flags () = + let parse (s:string) = + match !parser_callback with + | None -> failwith "Callback for parsing warn_error strings is not set" + | Some f -> f s + in + let we = Options.warn_error () in + try let r = parse we in + BU.smap_add error_flags we (Some r); + Getopt.Success + with Invalid_warn_error_setting msg -> + (BU.smap_add error_flags we None; + Getopt.Error ("Invalid --warn_error setting: " ^ msg ^ "\n")) + in + (* get_error_flags is called when logging an issue to figure out + which error level to report a particular issue at (Warning, Error etc.) + It is important that this function itself never raises an exception: + raising an error when trying to report an error is bad news, e.g., it + crashes the ide mode since it causes F* to exit abruptly. + So, we don't do any parsing here ... just look up the result of a + prior parse, falling back to the default settings in case the + parse didn't succeed *) + let get_error_flags () = + let we = Options.warn_error () in + match BU.smap_try_find error_flags we with + | Some (Some w) -> w + | _ -> default_settings + in + (* Setting the parser callback received from setup_hooks + and installing, in turn, callbacks in Options for + parsing warn_error settings and also for warning on the use of + unsafe options. *) + let set_callbacks (f:string -> list error_setting) = + parser_callback := Some f; + Options.set_error_flags_callback set_error_flags; + Options.set_option_warning_callback (warn_unsafe_options None) + in + set_callbacks, get_error_flags + +(* Work around bug *) +let set_parse_warn_error = t_set_parse_warn_error + +let lookup err = + let flags = error_flags () in + let v, level, i = lookup_error flags err in + let with_level level = v, level, i in + match v with + | Warning_Defensive when Options.defensive_error () || Options.defensive_abort () -> + with_level CAlwaysError + + | Warning_WarnOnUse -> + let level' = + //the level of warn_on_use is the + //max severity of the report_assumes setting (none, warn, error) + //and whatever the level is by default (e.g., due to a --warn_error setting) + match Options.report_assumes () with + | None -> level + | Some "warn" -> + (match level with + | CSilent -> CWarning + | _ -> level) + | Some "error" -> + (match level with + | CWarning + | CSilent -> CError + | _ -> level) + | Some _ -> + level + in + with_level level' + + | _ -> + with_level level + +let log_issue_ctx r (e, msg) ctx = + let msg = maybe_add_backtrace msg in + match lookup e with + | (_, CAlwaysError, errno) + | (_, CError, errno) -> + add_one (mk_issue EError (Some r) msg (Some errno) ctx) + | (_, CWarning, errno) -> + add_one (mk_issue EWarning (Some r) msg (Some errno) ctx) + | (_, CSilent, _) -> () + // We allow using log_issue to report a Fatal error in interactive mode + | (_, CFatal, errno) -> + let i = mk_issue EError (Some r) msg (Some errno) ctx in + if Options.ide() + then add_one i + else failwith ("don't use log_issue to report fatal error, should use raise_error: " ^ format_issue i) + +let info r msg = + let open FStarC.Class.HasRange in + let rng = pos r in + let msg = to_doc_list msg in + let msg = maybe_add_backtrace msg in + let ctx = get_ctx () in + add_one (mk_issue EInfo (Some rng) msg None ctx) + +let diag r msg = + if Debug.any() then + info r msg + +let raise_error r e msg = + let open FStarC.Class.HasRange in + let rng = pos r in + let msg = to_doc_list msg in + raise (Error (e, maybe_add_backtrace msg, rng, error_context.get ())) + +let log_issue r e msg = + let open FStarC.Class.HasRange in + let rng = pos r in + let msg = to_doc_list msg in + let ctx = error_context.get () in + log_issue_ctx rng (e, msg) ctx + +let raise_error0 e msg = raise_error dummyRange e msg +let log_issue0 e msg = log_issue dummyRange e msg +let diag0 msg = diag dummyRange msg + +let add_errors (errs : list error) : unit = + atomically (fun () -> List.iter (fun (e, msg, r, ctx) -> log_issue_ctx r (e, msg) ctx) errs) + +let issue_of_exn (e:exn) : option issue = + match e with + | Error(e, msg, r, ctx) -> + let errno = error_number (lookup e) in + Some (mk_issue EError (Some r) msg (Some errno) ctx) + | _ -> None + +let err_exn exn = + if exn = Stop then () + else + match issue_of_exn exn with + | Some issue -> add_one issue + | None -> raise exn + +let handleable = function + | Error _ + | Stop -> true + | _ -> false + +let stop_if_err () = + if get_err_count () > 0 + then raise Stop + +let with_ctx (s:string) (f : unit -> 'a) : 'a = + error_context.push s; + let r = + (* If we're debugging the failure, don't do anything, + * since catching and rethrowing the exception will change + * the stack trace. We still push the context though. *) + if Options.trace_error () + then Inr (f ()) + else + try + Inr (f ()) + with + (* Adding context to `failwith`, though it will be printed badly. + * TODO: deprecate failwith and use F* exceptions, which we can + * then catch and print sensibly. *) + | Failure msg -> + Inl (Failure (msg ^ rendermsg [ctx_doc (error_context.get ())])) + | ex -> Inl ex + in + ignore (error_context.pop ()); + match r with + | Inr r -> r + | Inl e -> raise e + +let with_ctx_if (b:bool) (s:string) (f : unit -> 'a) : 'a = + if b then + with_ctx s f + else + f () + +// +// returns errors, other issues, result if any +// restores handler back +// +let catch_errors_aux (f : unit -> 'a) : list issue & list issue & option 'a = + let newh = mk_default_handler false in + let old = !current_handler in + current_handler := newh; + let finally_restore () = + let all_issues = newh.eh_report() in //de-duplicated already + current_handler := old; + let errs, rest = List.partition (fun i -> i.issue_level = EError) all_issues in + errs, rest + in + let r = try Some (f ()) + with + | ex when handleable ex -> + err_exn ex; + None + | ex -> + let _ = finally_restore() in + raise ex + in + let errs, rest = finally_restore() in + errs, rest, r + +let no_ctx (f : unit -> 'a) : 'a = + let save = error_context.get () in + error_context.clear (); + let res = f () in + error_context.set save; + res + +let catch_errors (f : unit -> 'a) : list issue & option 'a = + let errs, rest, r = catch_errors_aux f in + List.iter (!current_handler).eh_add_one rest; + errs, r + +// +// Similar to catch_errors, except the warnings are not added to the old handler +// +let catch_errors_and_ignore_rest (f:unit -> 'a) : list issue & option 'a = + let errs, rest, r = catch_errors_aux f in + List.iter (!current_handler).eh_add_one <| List.filter (fun i -> i.issue_level = EInfo) rest; + (* ^ We print diagnostics anyway, which are usually debugging messages to be rendered + in the editor. *) + errs, r + +(* Finds a discrepancy between two multisets of ints. Result is (elem, amount1, amount2) + * eg. find_multiset_discrepancy [1;1;3;5] [1;1;3;3;4;5] = Some (3, 1, 2) + * since 3 appears 1 time in l1, but 2 times in l2. *) +let find_multiset_discrepancy (l1 : list int) (l2 : list int) : option (int & int & int) = + let sort = List.sortWith (fun x y -> x - y) in + let rec collect (l : list 'a) : list ('a & int) = + match l with + | [] -> [] + | hd :: tl -> + begin match collect tl with + | [] -> [(hd, 1)] + | (h, n) :: t -> + if h = hd + then (h, n+1) :: t + else (hd, 1) :: (h, n) :: t + end + in + let l1 = collect (sort l1) in + let l2 = collect (sort l2) in + let rec aux l1 l2 = + match l1, l2 with + | [], [] -> None + + | (e, n) :: _, [] -> + Some (e, n, 0) + + | [], (e, n) :: _ -> + Some (e, 0, n) + + | (hd1, n1) :: tl1, (hd2, n2) :: tl2 -> + if hd1 < hd2 then + Some (hd1, n1, 0) + else if hd1 > hd2 then + Some (hd2, 0, n2) + else if n1 <> n2 then + Some (hd1, n1, n2) + else aux tl1 tl2 + in + aux l1 l2 + +let raise_error_doc rng code msg = raise_error rng code msg +let log_issue_doc rng code msg = log_issue rng code msg +let raise_error_text rng code msg = raise_error rng code msg +let log_issue_text rng code msg = log_issue rng code msg diff --git a/src/basic/FStarC.Errors.fsti b/src/basic/FStarC.Errors.fsti new file mode 100644 index 00000000000..8f091c357f3 --- /dev/null +++ b/src/basic/FStarC.Errors.fsti @@ -0,0 +1,195 @@ +(* + Copyright 2008-2020 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Errors + +module Range = FStarC.Compiler.Range + +include FStarC.Errors.Codes +include FStarC.Errors.Msg +open FStarC.Errors.Msg +open FStarC.Class.HasRange +open FStarC.Json {json} + +(* This is a fallback to be used if an error is raised/logged +with a dummy range. It is set by TypeChecker.Tc.process_one_decl to +the range of the sigelt being checked. *) +val fallback_range : FStarC.Compiler.Effect.ref (option Range.range) + +(* This range, if set, will be used to limit the range of every +issue that is logged/raised. This is set, e.g. when checking a top-level +definition, to the range of the definition, so no error can be reported +outside of it. *) +val error_range_bound : FStarC.Compiler.Effect.ref (option Range.range) + +val with_error_bound (r:Range.range) (f : unit -> 'a) : 'a + +(* Get the error number for a particular code. Useful for creating error +messages mentioning --warn_error. *) +val errno : error_code -> int + +(* Particular errors code numbers, useful to build helpful error messages *) +val warn_on_use_errno : int +val defensive_errno : int +val call_to_erased_errno : int + +val update_flags : list (error_flag & string) -> list error_setting + +(* error code, message, source position, and error context *) +type error = error_code & error_message & FStarC.Compiler.Range.range & list string + +exception Error of error +exception Warning of error +exception Stop +exception Empty_frag + +type issue_level = + | ENotImplemented + | EInfo + | EWarning + | EError + +val json_of_issue_level: issue_level -> json + +type issue = { + issue_msg: error_message; + issue_level: issue_level; + issue_range: option Range.range; + issue_number: option int; + issue_ctx: list string; +} + +val json_of_issue: issue -> json + +type error_handler = { + eh_name: string; (* just for debugging purposes *) + eh_add_one: issue -> unit; + eh_count_errors: unit -> int; + eh_report: unit -> list issue; + eh_clear: unit -> unit +} + +val string_of_issue_level : issue_level -> string +val issue_level_of_string : string -> issue_level +val issue_message : issue -> error_message +val format_issue' : bool -> issue -> string +val format_issue : issue -> string +val error_number : error_setting -> int +val print_issue : issue -> unit +val compare_issues : issue -> issue -> int // for sorting.. weird + +val add_errors : list error -> unit +val issue_of_exn : exn -> option issue + +val default_handler : error_handler + +val get_err_count : unit -> int +val report_all : unit -> list issue +val clear : unit -> unit +val set_handler : error_handler -> unit +val get_ctx : unit -> list string + +val set_option_warning_callback_range : ropt:option FStarC.Compiler.Range.range -> unit +val set_parse_warn_error : (string -> list error_setting) -> unit + +val lookup : error_code -> error_setting + +val err_exn : exn -> unit +val handleable : exn -> bool + +(* If any error was logged, then stop the program (raising a Stop +exception). This is useful, for instance, to not run tactics in a given +top-level definition if a typechecking error was already logged, since +that may imply that the tactic will crash or loop. *) +val stop_if_err : unit -> unit + +(* Log an error/warning/etc. This does not raise an exception. Do not +use this for any CFatal error. *) + +(* Log an issue directly, rather than converting it from a error_code etc. + This does not raise an exception. Do not use this for any CFatal error. *) +val add_issues : list issue -> unit + +(* An info message. Calling this function triggers the printing immediately. *) +val info + (#pos_t:Type) {| hasRange pos_t |} (pos : pos_t) // A "position", of any type with a range + (#msg_t:_) {| is_error_message msg_t |} (msg : msg_t) // A "message", currently can be a 'string' or 'list document' + : unit + +(* A "diagnostic" message. It is the same as info, but only printed some kind of debugging is enabled. *) +val diag + (#pos_t:Type) {| hasRange pos_t |} (pos : pos_t) // A "position", of any type with a range + (#msg_t:_) {| is_error_message msg_t |} (msg : msg_t) // A "message", currently can be a 'string' or 'list document' + : unit + +val raise_error + (#pos_t:Type) {| hasRange pos_t |} (pos : pos_t) // A "position", of any type with a range + (code : error_code) // An error code + (#msg_t:_) {| is_error_message msg_t |} (msg : msg_t) // A "message", currently can be a 'string' or 'list document' + : 'a + +val log_issue + (#pos_t:Type) {| hasRange pos_t |} (pos : pos_t) // A "position", of any type with a range + (code : error_code) // An error code + (#msg_t:_) {| is_error_message msg_t |} (msg : msg_t) // A "message", currently can be a 'string' or 'list document' + : unit + +val raise_error0 : error_code -> #t:_ -> {| is_error_message t |} -> t -> 'a +val log_issue0 : error_code -> #t:_ -> {| is_error_message t |} -> t -> unit +val diag0 : #t:_ -> {| is_error_message t |} -> t -> unit + + +(* Run a function f inside an extended "error context", so its errors +are prefixed by the messages of each enclosing with_ctx. Only visible +when --error_contexts true is given. *) +val with_ctx : ctx:string -> (f : unit -> 'a) -> 'a + +(* As above, but only add the context conditionally. *) +val with_ctx_if : cond:bool -> ctx:string -> (f : unit -> 'a) -> 'a + +(* Delete all error contexts for this comp. *) +val no_ctx : (f : unit -> 'a) -> 'a + +(* Run a given function and return its result (if any) and the full list of +issues it logged/raised. *) +val catch_errors : (unit -> 'a) -> list issue & option 'a + + +(* Similar to catch_errors, except the warnings are not added to the old handler *) +val catch_errors_and_ignore_rest (f:unit -> 'a) : list issue & option 'a + + + + + + + + + + +(* TODO: Find a better home? *) +(* Finds a discrepancy between two multisets of ints. Result is (elem, amount1, amount2) + * eg. find_multiset_discrepancy [1;1;3;5] [1;1;3;3;4;5] = Some (3, 1, 2) + * since 3 appears 1 time in l1, but 2 times in l2. *) +val find_multiset_discrepancy : list int -> list int -> option (int & int & int) + + + +(* Specialized variants, only useful for OCaml code. Not to be used from F* sources. *) +val raise_error_doc : Range.range -> error_code -> error_message -> 'a +val log_issue_doc : Range.range -> error_code -> error_message -> unit +val raise_error_text : Range.range -> error_code -> string -> 'a +val log_issue_text : Range.range -> error_code -> string -> unit diff --git a/src/basic/FStarC.Find.fst b/src/basic/FStarC.Find.fst new file mode 100644 index 00000000000..0809b25a4cc --- /dev/null +++ b/src/basic/FStarC.Find.fst @@ -0,0 +1,50 @@ +(* + Copyright 2008-2024 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Find + +open FStar +open FStarC.Compiler.List +module BU = FStarC.Compiler.Util + +let find_file = + let file_map = BU.smap_create 100 in + fun filename -> + match BU.smap_try_find file_map filename with + | Some f -> f + | None -> + let result = + (try + if BU.is_path_absolute filename then + if BU.file_exists filename then + Some filename + else + None + else + (* In reverse, because the last directory has the highest precedence. *) + BU.find_map (List.rev (Options.include_path ())) (fun p -> + let path = + if p = "." then filename + else BU.join_paths p filename in + if BU.file_exists path then + Some path + else + None) + with | _ -> //to deal with issues like passing bogus strings as paths like " input" + None) + in + if Some? result + then BU.smap_add file_map filename result; + result diff --git a/src/basic/FStarC.Find.fsti b/src/basic/FStarC.Find.fsti new file mode 100644 index 00000000000..17df888310f --- /dev/null +++ b/src/basic/FStarC.Find.fsti @@ -0,0 +1,21 @@ +(* + Copyright 2008-2024 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Find + +open FStarC.Compiler.Effect + +(* Try to find a file in the include path with a given basename. *) +val find_file (basename : string) : option string diff --git a/src/basic/FStarC.GenSym.fst b/src/basic/FStarC.GenSym.fst new file mode 100644 index 00000000000..7245c82d8a2 --- /dev/null +++ b/src/basic/FStarC.GenSym.fst @@ -0,0 +1,22 @@ +module FStarC.GenSym + +module Util = FStarC.Compiler.Util + +(* private *) +let gensym_st = Util.mk_ref 0 + +let next_id () = + let r = !gensym_st in + gensym_st := r + 1; + r + +let reset_gensym () = gensym_st := 0 + +let with_frozen_gensym f = + let v = !gensym_st in + let r = + try f () with + | e -> (gensym_st := v; raise e) + in + gensym_st := v; + r diff --git a/src/basic/FStarC.GenSym.fsti b/src/basic/FStarC.GenSym.fsti new file mode 100644 index 00000000000..51f4e4f1afc --- /dev/null +++ b/src/basic/FStarC.GenSym.fsti @@ -0,0 +1,33 @@ +(* + Copyright 2008-2023 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +(* + A simple fresh symbol generator (gensym). +*) +module FStarC.GenSym + +open FStarC.Compiler.Effect + +(** Obtain a fresh ID. *) +val next_id : unit -> int + +(** Reset the gensym. Names generated will not be fresh with respect to +names generated before the reset. Should be used only when it is known +that freshness across resets is not needed. *) +val reset_gensym : unit -> unit + +(** Do something without affecting the gensym. Useful e.g. for printing, +to make sure there's no side effect. *) +val with_frozen_gensym : (unit -> 'a) -> 'a diff --git a/src/basic/FStarC.Getopt.fsti b/src/basic/FStarC.Getopt.fsti new file mode 100644 index 00000000000..2259823b3c8 --- /dev/null +++ b/src/basic/FStarC.Getopt.fsti @@ -0,0 +1,38 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Getopt +open FStarC.Compiler.Effect +open FStarC.BaseTypes + +val noshort : char +val nolong : string +type opt_variant 'a = + | ZeroArgs of (unit -> 'a) + | OneArg of (string -> 'a) & string + +type opt' 'a = char & string & opt_variant 'a +type opt = opt' unit + +type parse_cmdline_res = + | Empty + | Help + | Error of string + | Success + +val parse_cmdline: list opt -> (string -> parse_cmdline_res) -> parse_cmdline_res +val parse_string: list opt -> (string -> parse_cmdline_res) -> string -> parse_cmdline_res +val parse_list: list opt -> (string -> parse_cmdline_res) -> list string -> parse_cmdline_res +val cmdline: unit -> list string diff --git a/src/basic/FStarC.Hash.fsti b/src/basic/FStarC.Hash.fsti new file mode 100644 index 00000000000..287932e35c7 --- /dev/null +++ b/src/basic/FStarC.Hash.fsti @@ -0,0 +1,11 @@ +module FStarC.Hash +open FStarC.Compiler.Effect + +type hash_code + +val cmp_hash (_ _ : hash_code) : int + +val of_int : int -> hash_code +val of_string : string -> hash_code +val mix : hash_code -> hash_code -> hash_code +val string_of_hash_code : hash_code -> string diff --git a/src/basic/FStarC.Ident.fst b/src/basic/FStarC.Ident.fst new file mode 100644 index 00000000000..d9c92fc8db6 --- /dev/null +++ b/src/basic/FStarC.Ident.fst @@ -0,0 +1,98 @@ +module FStarC.Ident + +open Prims +open FStarC.Compiler.Effect +open FStarC.Compiler.Range +open FStarC.Compiler.List +module List = FStarC.Compiler.List +module Util = FStarC.Compiler.Util +module GS = FStarC.GenSym + +[@@ PpxDerivingYoJson; PpxDerivingShow ] +type ident = {idText:string; + idRange:range} + +[@@ PpxDerivingYoJson; PpxDerivingShow ] +type lident = {ns:ipath; //["FStar"; "Basic"] + ident:ident; //"lident" + nsstr:string; // Cached version of the namespace + str:string} // Cached version of string_of_lid + +let mk_ident (text,range) = {idText=text; idRange=range} + +let set_id_range r i = { i with idRange=r } + +let reserved_prefix = "uu___" + +let gen' s r = + let i = GS.next_id() in + mk_ident (s ^ string_of_int i, r) + +let gen r = gen' reserved_prefix r + +let ident_of_lid l = l.ident + +let range_of_id (id:ident) = id.idRange +let id_of_text str = mk_ident(str, dummyRange) +let string_of_id (id:ident) = id.idText +let text_of_path path = Util.concat_l "." path +let path_of_text text = String.split ['.'] text +let path_of_ns ns = List.map string_of_id ns +let path_of_lid lid = List.map string_of_id (lid.ns@[lid.ident]) +let ns_of_lid lid = lid.ns +let ids_of_lid lid = lid.ns@[lid.ident] +let lid_of_ns_and_id ns id = + let nsstr = List.map string_of_id ns |> text_of_path in + {ns=ns; + ident=id; + nsstr=nsstr; + str=(if nsstr="" then id.idText else nsstr ^ "." ^ id.idText)} +let lid_of_ids ids = + let ns, id = Util.prefix ids in + lid_of_ns_and_id ns id +let lid_of_str str = + lid_of_ids (List.map id_of_text (Util.split str ".")) +let lid_of_path path pos = + let ids = List.map (fun s -> mk_ident(s, pos)) path in + lid_of_ids ids +let text_of_lid lid = lid.str +let lid_equals l1 l2 = l1.str = l2.str +let ident_equals id1 id2 = id1.idText = id2.idText +let range_of_lid (lid:lid) = range_of_id lid.ident +let set_lid_range l r = {l with ident={l.ident with idRange=r}} +let lid_add_suffix l s = + let path = path_of_lid l in + lid_of_path (path@[s]) (range_of_lid l) + +let ml_path_of_lid lid = + String.concat "_" <| (path_of_ns lid.ns)@[string_of_id lid.ident] + +let string_of_lid lid = lid.str + +let qual_id lid id = + set_lid_range (lid_of_ids (lid.ns @ [lid.ident;id])) (range_of_id id) + +let nsstr (l:lid) : string = l.nsstr + +instance showable_ident = { + show = string_of_id; +} +instance showable_lident = { + show = string_of_lid; +} +let pretty_ident = pretty_from_showable +let pretty_lident = pretty_from_showable +instance hasrange_ident = { + pos = range_of_id; + setPos = (fun rng id -> { id with idRange = rng }); +} +instance hasrange_lident = { + pos = (fun lid -> Class.HasRange.pos lid.ident); + setPos = (fun rng id -> { id with ident = setPos rng id.ident }); +} +instance deq_ident = { + (=?) = ident_equals; +} +instance deq_lident = { + (=?) = lid_equals; +} diff --git a/src/basic/FStarC.Ident.fsti b/src/basic/FStarC.Ident.fsti new file mode 100644 index 00000000000..58614c5aaeb --- /dev/null +++ b/src/basic/FStarC.Ident.fsti @@ -0,0 +1,146 @@ +(* + Copyright 2008-2014 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Ident + +open FStarC.Compiler.Range +open FStarC.Class.Show +open FStarC.Class.HasRange +open FStarC.Class.Deq +open FStarC.Class.PP + +(** A (short) identifier for a local name. + * e.g. x in `fun x -> ...` *) +[@@ PpxDerivingYoJson; PpxDerivingShow ] +new val ident : Type0 + +// type ident + +(** A module path *) +[@@ PpxDerivingYoJson; PpxDerivingShow ] +type path = list string + +(** A module path, as idents *) +[@@ PpxDerivingYoJson; PpxDerivingShow ] +type ipath = list ident + +(** Create an ident *) +val mk_ident : (string & range) -> ident + +(** Obtain the range of an ident *) +val range_of_id : ident -> range + +(** Create an ident with a dummyRange (avoid if possible) *) +val id_of_text : string -> ident + +(** The prefix for reserved identifiers *) +val reserved_prefix : string + +(** Set the range on an ident *) +val set_id_range : range -> ident -> ident + +(** Equality of idents *) +val ident_equals : ident -> ident -> bool + +(** Print an ident *) +val string_of_id : ident -> string + +(** Generating fresh names, uses GenSym. *) +val gen' : string -> range -> ident +val gen : range -> ident + +(** Turn a string of shape A.B.C into a path *) +val path_of_text : string -> path + +(** Turn a namespace, a list of idents, into a path *) +val path_of_ns : ipath -> path + + + + + +(** A long identifier for top-level, fully-qualified names. + e.g. Prims.string. Essentially a list of idents where + the last one denotes a name, and all the others denote a + module path that qualifies the name. *) +[@@ PpxDerivingYoJson; PpxDerivingShow ] +new val lident : Type0 + +[@@ PpxDerivingYoJson; PpxDerivingShow ] +type lid = lident + +(** Obtain the range of an lid *) +val range_of_lid : lident -> range + +(* Return the name in an lid *) +val ident_of_lid : lident -> ident + +(** Equality of lidents *) +val lid_equals : lident -> lident -> bool + +(** Turn an lid into a path *) +val path_of_lid : lident -> path + +(** Return an lid as a path (containing the name itself). + e.g. ids_of_lid Prims.string = [Prims; string] *) +val ids_of_lid : lident -> ipath + +(** Return the namespace of an lid (not including its name). + e.g. ns_of_lid Prims.string = [Prims] *) +val ns_of_lid : lident -> ipath + +(** Create an lid from a ipath and a name *) +val lid_of_ns_and_id : ipath -> ident -> lident + +(** Create an lid from a ipath (last ident is the name) *) +val lid_of_ids : ipath -> lident + +(** Create an lid from a string, separating it by "." *) +val lid_of_str : string -> lident + +(** Create an lid from a (string) path and a range *) +val lid_of_path : path -> range -> lident + +(** Set the range on an lid *) +val set_lid_range : lident -> range -> lident + +(** Add a component to an lid *) +val lid_add_suffix : lident -> string -> lident + +(** Qualify an ident by a module. Similar to lid_add_suffix, but the + range is taken from the ident instead. *) +val qual_id : lident -> ident -> lident + +(** Print an lid. This is O(1). *) +val string_of_lid : lident -> string + +(** Print the namespace portion of an lid. This is O(1). *) +val nsstr : lident -> string + +(** Print a path as A.B.C *) +val text_of_path : path -> string + +(* Similar to string_of_lid, but separates with "_" instead of "." *) +val ml_path_of_lid : lident -> string + +(* Showable instances *) +instance val showable_ident : showable ident +instance val showable_lident : showable lident +instance val pretty_ident : pretty ident +instance val pretty_lident : pretty lident +instance val hasrange_ident : hasRange ident +instance val hasrange_lident : hasRange lident +instance val deq_ident : deq ident +instance val deq_lident : deq lident diff --git a/src/basic/FStarC.Json.fsti b/src/basic/FStarC.Json.fsti new file mode 100644 index 00000000000..672f6e182e3 --- /dev/null +++ b/src/basic/FStarC.Json.fsti @@ -0,0 +1,29 @@ +(* + Copyright 2008-2023 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Json + +open FStarC.Compiler.Effect + +type json = +| JsonNull +| JsonBool of bool +| JsonInt of int +| JsonStr of string +| JsonList of list json +| JsonAssoc of list (string & json) + +val json_of_string : string -> option json +val string_of_json : json -> string diff --git a/src/basic/FStar.Options. b/src/basic/FStarC.Options. similarity index 100% rename from src/basic/FStar.Options. rename to src/basic/FStarC.Options. diff --git a/src/basic/FStarC.Options.Ext.fst b/src/basic/FStarC.Options.Ext.fst new file mode 100644 index 00000000000..f5b3baff35c --- /dev/null +++ b/src/basic/FStarC.Options.Ext.fst @@ -0,0 +1,70 @@ +(* + Copyright 2008-2024 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Options.Ext + +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Class.Show +module BU = FStarC.Compiler.Util + +type ext_state = + | E : map : BU.psmap string -> ext_state + +let cur_state = BU.mk_ref (E (BU.psmap_empty ())) + +(* Set a key-value pair in the map *) +let set (k:key) (v:value) : unit = + cur_state := E (BU.psmap_add (!cur_state).map k v) + +(* Get the value from the map, or return "" if not there *) +let get (k:key) : value = + let r = + match BU.psmap_try_find (!cur_state).map k with + | None -> "" + | Some v -> v + in + r + +(* Find a home *) +let is_prefix (s1 s2 : string) : ML bool = + let open FStarC.Compiler.String in + let l1 = length s1 in + let l2 = length s2 in + l2 >= l1 && substring s2 0 l1 = s1 + +(* Get a list of all KV pairs that "begin" with k, considered +as a namespace. *) +let getns (ns:string) : list (key & value) = + let f k v acc = + if (ns^":") `is_prefix` k + then (k, v) :: acc + else acc + in + BU.psmap_fold (!cur_state).map f [] + +let all () : list (key & value) = + let f k v acc = (k, v) :: acc in + BU.psmap_fold (!cur_state).map f [] + +let save () : ext_state = + !cur_state + +let restore (s:ext_state) : unit = + cur_state := s; + () + +let reset () : unit = + cur_state := E (BU.psmap_empty ()) diff --git a/src/basic/FStarC.Options.Ext.fsti b/src/basic/FStarC.Options.Ext.fsti new file mode 100644 index 00000000000..8670968921f --- /dev/null +++ b/src/basic/FStarC.Options.Ext.fsti @@ -0,0 +1,42 @@ +(* + Copyright 2008-2024 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Options.Ext + +open FStarC.Compiler.Effect + +type key = string +type value = string + +new +val ext_state : Type0 + +(* Set a key-value pair in the map *) +val set (k:key) (v:value) : unit + +(* Get the value from the map, or return "" if not there *) +val get (k:key) : value + +(* Get a list of all KV pairs that "begin" with k, considered +as a namespace. *) +val getns (ns:string) : list (key & value) + +(* List all pairs *) +val all () : list (key & value) + +val save () : ext_state +val restore (s:ext_state) : unit + +val reset () : unit diff --git a/src/basic/FStarC.Options.fst b/src/basic/FStarC.Options.fst new file mode 100644 index 00000000000..21d4c86cc26 --- /dev/null +++ b/src/basic/FStarC.Options.fst @@ -0,0 +1,2467 @@ +(* + Copyright 2008-2020 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Options + +open FStar open FStarC +open FStarC.BaseTypes +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Compiler.String +open FStarC.Compiler.Util +open FStarC.Getopt +open FStar.Pervasives +open FStarC.VConfig +open FStarC.Class.Show +open FStarC.Class.Deq + +module Option = FStarC.Compiler.Option +module FC = FStarC.Common +module Util = FStarC.Compiler.Util +module List = FStarC.Compiler.List + +module Ext = FStarC.Options.Ext + +let debug_embedding = mk_ref false +let eager_embedding = mk_ref false + +(* A FLAG TO INDICATE THAT WE'RE RUNNING UNIT TESTS *) +let __unit_tests__ = Util.mk_ref false +let __unit_tests() = !__unit_tests__ +let __set_unit_tests () = __unit_tests__ := true +let __clear_unit_tests () = __unit_tests__ := false + +let as_bool = function + | Bool b -> b + | _ -> failwith "Impos: expected Bool" +let as_int = function + | Int b -> b + | _ -> failwith "Impos: expected Int" +let as_string = function + | String b -> b + | Path b -> FStarC.Common.try_convert_file_name_to_mixed b + | _ -> failwith "Impos: expected String" +let as_list' = function + | List ts -> ts + | _ -> failwith "Impos: expected List" +let as_list as_t x = + as_list' x |> List.map as_t +let as_option as_t = function + | Unset -> None + | v -> Some (as_t v) +let as_comma_string_list = function + | List ls -> List.flatten <| List.map (fun l -> split (as_string l) ",") ls + | _ -> failwith "Impos: expected String (comma list)" + +let copy_optionstate m = Util.smap_copy m + +(* The option state is a stack of stacks. Why? First, we need to + * support #push-options and #pop-options, which provide the user with + * a stack-like option control, useful for rlimits and whatnot. Second, + * there's the interactive mode, which allows to traverse a file and + * backtrack over it, and must update this state accordingly. So for + * instance consider the following code: + * + * 1. #push-options "A" + * 2. let f = ... + * 3. #pop-options + * + * Running in batch mode starts with a singleton stack, then pushes, + * then pops. In the interactive mode, say we go over line 1. Then + * our current state is a stack with two elements (original state and + * state+"A"), but we need the previous state too to backtrack if we run + * C-c C-p or whatever. We can also go over line 3, and still we need + * to keep track of everything to backtrack. After processing the lines + * one-by-one in the interactive mode, the stacks are: (top at the head) + * + * (orig) + * (orig + A) (orig) + * (orig) + * + * No stack should ever be empty! Any of these failwiths should never be + * triggered externally. IOW, the API should protect this invariant. + * + * We also keep a snapshot of the Debug module's state. + *) +let history1 = Debug.saved_state & Ext.ext_state & optionstate + +let fstar_options : ref optionstate = Util.mk_ref (Util.psmap_empty ()) + +let history : ref (list (list history1)) = + Util.mk_ref [] // IRRELEVANT: see clear() below + +let peek () = !fstar_options + +let internal_push () = + let lev1::rest = !history in + let newhd = (Debug.snapshot (), Ext.save (), !fstar_options) in + history := (newhd :: lev1) :: rest + +let internal_pop () = + let lev1::rest = !history in + match lev1 with + | [] -> false + | (dbg, ext, opts)::lev1' -> + Debug.restore dbg; + Ext.restore ext; + fstar_options := opts; + history := lev1' :: rest; + true + +let push () = // already signal-atomic + (* This turns a stack like + + 4 + 3 + 2 1 current:5 + into: + 5 + 4 4 + 3 3 + 2 2 1 current:5 + + i.e. current state does not change, and + current minor stack does not change. The + "next" previous stack (now with 2,3,4,5) + has a copy of 5 at the top so we can restore regardless + of what we do in the current stack or the current state. *) + + internal_push (); + let lev1::_ = !history in + history := lev1 :: !history; + ignore (internal_pop()); + () + +let pop () = // already signal-atomic + match !history with + | [] -> failwith "TOO MANY POPS!" + | _::levs -> + history := levs; + if not (internal_pop ()) then + failwith "aaa!!!" + +let set o = + fstar_options := o + +let depth () = + let lev::_ = !history in + List.length lev + +let snapshot () = Common.snapshot push history () +let rollback depth = Common.rollback pop history depth + +let set_option k v = + let map : optionstate = peek() in + if k = "report_assumes" + then match Util.psmap_try_find map k with + | Some (String "error") -> + //It's already set to error; ignore any attempt to change it + () + | _ -> fstar_options := Util.psmap_add map k v + else fstar_options := Util.psmap_add map k v + +let set_option' (k,v) = set_option k v +let set_admit_smt_queries (b:bool) = set_option "admit_smt_queries" (Bool b) + +let defaults = + [ + ("abort_on" , Int 0); + ("admit_smt_queries" , Bool false); + ("admit_except" , Unset); + ("disallow_unification_guards" , Bool false); + ("already_cached" , Unset); + ("cache_checked_modules" , Bool false); + ("cache_dir" , Unset); + ("cache_off" , Bool false); + ("compat_pre_core" , Unset); + ("compat_pre_typed_indexed_effects" + , Bool false); + ("print_cache_version" , Bool false); + ("cmi" , Bool false); + ("codegen" , Unset); + ("codegen-lib" , List []); + ("defensive" , String "no"); + ("debug" , List []); + ("debug_all" , Bool false); + ("debug_all_modules" , Bool false); + ("dep" , Unset); + ("detail_errors" , Bool false); + ("detail_hint_replay" , Bool false); + ("dump_module" , List []); + ("eager_subtyping" , Bool false); + ("error_contexts" , Bool false); + ("expose_interfaces" , Bool false); + ("message_format" , String "human"); + ("ext" , Unset); + ("extract" , Unset); + ("extract_all" , Bool false); + ("extract_module" , List []); + ("extract_namespace" , List []); + ("full_context_dependency" , Bool true); + ("hide_uvar_nums" , Bool false); + ("hint_hook" , Unset); + ("hint_info" , Bool false); + ("hint_dir" , Unset); + ("hint_file" , Unset); + ("in" , Bool false); + ("ide" , Bool false); + ("ide_id_info_off" , Bool false); + ("lsp" , Bool false); + ("include" , List []); + ("print" , Bool false); + ("print_in_place" , Bool false); + ("force" , Bool false); + ("fuel" , Unset); + ("ifuel" , Unset); + ("initial_fuel" , Int 2); + ("initial_ifuel" , Int 1); + ("keep_query_captions" , Bool true); + ("lax" , Bool false); + ("load" , List []); + ("load_cmxs" , List []); + ("log_queries" , Bool false); + ("log_failing_queries" , Bool false); + ("log_types" , Bool false); + ("max_fuel" , Int 8); + ("max_ifuel" , Int 2); + ("MLish" , Bool false); + ("MLish_effect" , String "FStar.Compiler.Effect"); + ("no_default_includes" , Bool false); + ("no_extract" , List []); + ("no_location_info" , Bool false); + ("no_smt" , Bool false); + ("no_plugins" , Bool false); + ("no_tactics" , Bool false); + ("normalize_pure_terms_for_extraction" + , Bool false); + ("krmloutput" , Unset); + ("odir" , Unset); + ("output_deps_to" , Unset); + ("prims" , Unset); + ("pretype" , Bool true); + ("prims_ref" , Unset); + ("print_bound_var_types" , Bool false); + ("print_effect_args" , Bool false); + ("print_expected_failures" , Bool false); + ("print_full_names" , Bool false); + ("print_implicits" , Bool false); + ("print_universes" , Bool false); + ("print_z3_statistics" , Bool false); + ("prn" , Bool false); + ("proof_recovery" , Bool false); + ("quake" , Int 0); + ("quake_lo" , Int 1); + ("quake_hi" , Int 1); + ("quake_keep" , Bool false); + ("query_cache" , Bool false); + ("query_stats" , Bool false); + ("read_checked_file" , Unset); + ("list_plugins" , Bool false); + ("locate" , Bool false); + ("locate_lib" , Bool false); + ("locate_ocaml" , Bool false); + ("read_krml_file" , Unset); + ("record_hints" , Bool false); + ("record_options" , Bool false); + ("report_assumes" , Unset); + ("retry" , Bool false); + ("reuse_hint_for" , Unset); + ("silent" , Bool false); + ("smt" , Unset); + ("smtencoding.elim_box" , Bool false); + ("smtencoding.nl_arith_repr" , String "boxwrap"); + ("smtencoding.l_arith_repr" , String "boxwrap"); + ("smtencoding.valid_intro" , Bool true); + ("smtencoding.valid_elim" , Bool false); + ("split_queries" , String "on_failure"); + ("tactics_failhard" , Bool false); + ("tactics_info" , Bool false); + ("tactic_raw_binders" , Bool false); + ("tactic_trace" , Bool false); + ("tactic_trace_d" , Int 0); + + ("tcnorm" , Bool true); + ("timing" , Bool false); + ("trace_error" , Bool false); + ("ugly" , Bool false); + ("unthrottle_inductives" , Bool false); + ("unsafe_tactic_exec" , Bool false); + ("use_native_tactics" , Unset); + ("use_eq_at_higher_order" , Bool false); + ("use_hints" , Bool false); + ("use_hint_hashes" , Bool false); + ("using_facts_from" , Unset); + ("verify_module" , List []); + ("warn_default_effects" , Bool false); + ("z3refresh" , Bool false); + ("z3rlimit" , Int 5); + ("z3rlimit_factor" , Int 1); + ("z3seed" , Int 0); + ("z3cliopt" , List []); + ("z3smtopt" , List []); + ("z3version" , String "4.8.5"); + ("__no_positivity" , Bool false); + ("__tactics_nbe" , Bool false); + ("warn_error" , List []); + ("use_nbe" , Bool false); + ("use_nbe_for_extraction" , Bool false); + ("trivial_pre_for_unannotated_effectful_fns" + , Bool true); + ("profile_group_by_decl" , Bool false); + ("profile_component" , Unset); + ("profile" , Unset); + ] + +let init () = + Debug.disable_all (); + Ext.reset (); + fstar_options := Util.psmap_empty (); + defaults |> List.iter set_option' //initialize it with the default values + +let clear () = + history := [[]]; + init() + +(* Run it now. *) +let _ = clear () + +let get_option s = + match Util.psmap_try_find (peek ()) s with + | None -> failwith ("Impossible: option " ^s^ " not found") + | Some s -> s + +let rec option_val_to_string (v:option_val) : string = + match v with + | Bool b -> "Bool " ^ show b + | String s -> "String " ^ show s + | Path s -> "Path " ^ show s + | Int i -> "Int " ^ show i + | List vs -> "List " ^ Common.string_of_list option_val_to_string vs + | Unset -> "Unset" + +instance showable_option_val : showable option_val = { + show = option_val_to_string; +} + +let rec eq_option_val (v1 v2 : option_val) : bool = + match v1, v2 with + | Bool x1, Bool x2 + | String x1, String x2 + | Path x1, Path x2 + | Int x1, Int x2 -> x1 =? x2 + | Unset, Unset -> true + | List x1, List x2 -> + Common.eq_list eq_option_val x1 x2 + | _, _ -> false + +instance deq_option_val : deq option_val = { + (=?) = eq_option_val; +} + +let rec list_try_find #a #b {| deq a |} (k : a) (l : list (a & b)) +: option b += + match l with + | [] -> None + | (k', v') :: l' -> + if k =? k' + then Some v' + else list_try_find k l' + +let show_options () = + let s = peek () in + let kvs : list (string & option_val) = + let open FStarC.Class.Monad in + let! k = Common.psmap_keys s in + (* verify_module is only set internally. *) + if k = "verify_module" then [] else + let v = must <| psmap_try_find s k in + let v0 = list_try_find k defaults in + if v0 =? Some v then + [] + else + return (k, v) + in + let rec show_optionval v = + match v with + | String s -> "\"" ^ s ^ "\"" // FIXME: proper escape + | Bool b -> show b + | Int i -> show i + | Path s -> s + | List s -> List.map show_optionval s |> String.concat "," + | Unset -> "" + in + let show1 (k, v) = + Util.format2 "--%s %s" k (show_optionval v) + in + kvs |> List.map show1 |> String.concat "\n" + +let set_verification_options o = + (* This are all the options restored when processing a check_with + attribute. All others are unchanged. We do this for two reasons: + 1) It's unsafe to just set everything (e.g. verify_module would + cause lax verification, so we need to filter some stuff out). + 2) So we don't propagate meaningless debugging options, which + is probably not intended. + *) + let verifopts = [ + "initial_fuel"; + "max_fuel"; + "initial_ifuel"; + "max_ifuel"; + "detail_errors"; + "detail_hint_replay"; + "no_smt"; + "quake"; + "retry"; + "smtencoding.elim_box"; + "smtencoding.nl_arith_repr"; + "smtencoding.l_arith_repr"; + "smtencoding.valid_intro"; + "smtencoding.valid_elim"; + "tcnorm"; + "no_plugins"; + "no_tactics"; + "z3cliopt"; + "z3smtopt"; + "z3refresh"; + "z3rlimit"; + "z3rlimit_factor"; + "z3seed"; + "z3version"; + "trivial_pre_for_unannotated_effectful_fns"; + ] in + List.iter (fun k -> set_option k (Util.psmap_try_find o k |> Util.must)) verifopts + +let lookup_opt s c = + c (get_option s) + +let get_abort_on () = lookup_opt "abort_on" as_int +let get_admit_smt_queries () = lookup_opt "admit_smt_queries" as_bool +let get_admit_except () = lookup_opt "admit_except" (as_option as_string) +let get_compat_pre_core () = lookup_opt "compat_pre_core" (as_option as_int) + +let get_compat_pre_typed_indexed_effects () = lookup_opt "compat_pre_typed_indexed_effects" as_bool +let get_disallow_unification_guards () = lookup_opt "disallow_unification_guards" as_bool + +let get_already_cached () = lookup_opt "already_cached" (as_option (as_list as_string)) +let get_cache_checked_modules () = lookup_opt "cache_checked_modules" as_bool +let get_cache_dir () = lookup_opt "cache_dir" (as_option as_string) +let get_cache_off () = lookup_opt "cache_off" as_bool +let get_print_cache_version () = lookup_opt "print_cache_version" as_bool +let get_cmi () = lookup_opt "cmi" as_bool +let get_codegen () = lookup_opt "codegen" (as_option as_string) +let get_codegen_lib () = lookup_opt "codegen-lib" (as_list as_string) +let get_defensive () = lookup_opt "defensive" as_string +let get_dep () = lookup_opt "dep" (as_option as_string) +let get_detail_errors () = lookup_opt "detail_errors" as_bool +let get_detail_hint_replay () = lookup_opt "detail_hint_replay" as_bool +let get_dump_module () = lookup_opt "dump_module" (as_list as_string) +let get_eager_subtyping () = lookup_opt "eager_subtyping" as_bool +let get_error_contexts () = lookup_opt "error_contexts" as_bool +let get_expose_interfaces () = lookup_opt "expose_interfaces" as_bool +let get_message_format () = lookup_opt "message_format" as_string +let get_extract () = lookup_opt "extract" (as_option (as_list as_string)) +let get_extract_module () = lookup_opt "extract_module" (as_list as_string) +let get_extract_namespace () = lookup_opt "extract_namespace" (as_list as_string) +let get_force () = lookup_opt "force" as_bool +let get_hide_uvar_nums () = lookup_opt "hide_uvar_nums" as_bool +let get_hint_info () = lookup_opt "hint_info" as_bool +let get_hint_dir () = lookup_opt "hint_dir" (as_option as_string) +let get_hint_file () = lookup_opt "hint_file" (as_option as_string) +let get_in () = lookup_opt "in" as_bool +let get_ide () = lookup_opt "ide" as_bool +let get_ide_id_info_off () = lookup_opt "ide_id_info_off" as_bool +let get_lsp () = lookup_opt "lsp" as_bool +let get_include () = lookup_opt "include" (as_list as_string) +let get_print () = lookup_opt "print" as_bool +let get_print_in_place () = lookup_opt "print_in_place" as_bool +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_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) +let get_log_queries () = lookup_opt "log_queries" as_bool +let get_log_failing_queries () = lookup_opt "log_failing_queries" as_bool +let get_log_types () = lookup_opt "log_types" as_bool +let get_max_fuel () = lookup_opt "max_fuel" as_int +let get_max_ifuel () = lookup_opt "max_ifuel" as_int +let get_MLish () = lookup_opt "MLish" as_bool +let get_MLish_effect () = lookup_opt "MLish_effect" as_string +let get_no_default_includes () = lookup_opt "no_default_includes" as_bool +let get_no_extract () = lookup_opt "no_extract" (as_list as_string) +let get_no_location_info () = lookup_opt "no_location_info" as_bool +let get_no_plugins () = lookup_opt "no_plugins" as_bool +let get_no_smt () = lookup_opt "no_smt" as_bool +let get_normalize_pure_terms_for_extraction + () = lookup_opt "normalize_pure_terms_for_extraction" as_bool +let get_krmloutput () = lookup_opt "krmloutput" (as_option as_string) +let get_odir () = lookup_opt "odir" (as_option as_string) +let get_output_deps_to () = lookup_opt "output_deps_to" (as_option as_string) +let get_ugly () = lookup_opt "ugly" as_bool +let get_prims () = lookup_opt "prims" (as_option as_string) +let get_print_bound_var_types () = lookup_opt "print_bound_var_types" as_bool +let get_print_effect_args () = lookup_opt "print_effect_args" as_bool +let get_print_expected_failures () = lookup_opt "print_expected_failures" as_bool +let get_print_full_names () = lookup_opt "print_full_names" as_bool +let get_print_implicits () = lookup_opt "print_implicits" as_bool +let get_print_universes () = lookup_opt "print_universes" as_bool +let get_print_z3_statistics () = lookup_opt "print_z3_statistics" as_bool +let get_prn () = lookup_opt "prn" as_bool +let get_proof_recovery () = lookup_opt "proof_recovery" as_bool +let get_quake_lo () = lookup_opt "quake_lo" as_int +let get_quake_hi () = lookup_opt "quake_hi" as_int +let get_quake_keep () = lookup_opt "quake_keep" as_bool +let get_query_cache () = lookup_opt "query_cache" as_bool +let get_query_stats () = lookup_opt "query_stats" as_bool +let get_read_checked_file () = lookup_opt "read_checked_file" (as_option as_string) +let get_read_krml_file () = lookup_opt "read_krml_file" (as_option as_string) +let get_list_plugins () = lookup_opt "list_plugins" as_bool +let get_locate () = lookup_opt "locate" as_bool +let get_locate_lib () = lookup_opt "locate_lib" as_bool +let get_locate_ocaml () = lookup_opt "locate_ocaml" as_bool +let get_record_hints () = lookup_opt "record_hints" as_bool +let get_record_options () = lookup_opt "record_options" as_bool +let get_retry () = lookup_opt "retry" as_bool +let get_reuse_hint_for () = lookup_opt "reuse_hint_for" (as_option as_string) +let get_report_assumes () = lookup_opt "report_assumes" (as_option as_string) +let get_silent () = lookup_opt "silent" as_bool +let get_smt () = lookup_opt "smt" (as_option as_string) +let get_smtencoding_elim_box () = lookup_opt "smtencoding.elim_box" as_bool +let get_smtencoding_nl_arith_repr () = lookup_opt "smtencoding.nl_arith_repr" as_string +let get_smtencoding_l_arith_repr() = lookup_opt "smtencoding.l_arith_repr" as_string +let get_smtencoding_valid_intro () = lookup_opt "smtencoding.valid_intro" as_bool +let get_smtencoding_valid_elim () = lookup_opt "smtencoding.valid_elim" as_bool +let get_split_queries () = lookup_opt "split_queries" as_string +let get_tactic_raw_binders () = lookup_opt "tactic_raw_binders" as_bool +let get_tactics_failhard () = lookup_opt "tactics_failhard" as_bool +let get_tactics_info () = lookup_opt "tactics_info" as_bool +let get_tactic_trace () = lookup_opt "tactic_trace" as_bool +let get_tactic_trace_d () = lookup_opt "tactic_trace_d" as_int +let get_tactics_nbe () = lookup_opt "__tactics_nbe" as_bool +let get_tcnorm () = lookup_opt "tcnorm" as_bool +let get_timing () = lookup_opt "timing" as_bool +let get_trace_error () = lookup_opt "trace_error" as_bool +let get_unthrottle_inductives () = lookup_opt "unthrottle_inductives" as_bool +let get_unsafe_tactic_exec () = lookup_opt "unsafe_tactic_exec" as_bool +let get_use_eq_at_higher_order () = lookup_opt "use_eq_at_higher_order" as_bool +let get_use_hints () = lookup_opt "use_hints" as_bool +let get_use_hint_hashes () = lookup_opt "use_hint_hashes" as_bool +let get_use_native_tactics () = lookup_opt "use_native_tactics" (as_option as_string) +let get_no_tactics () = lookup_opt "no_tactics" as_bool +let get_using_facts_from () = lookup_opt "using_facts_from" (as_option (as_list as_string)) +let get_verify_module () = lookup_opt "verify_module" (as_list as_string) +let get_version () = lookup_opt "version" as_bool +let get_warn_default_effects () = lookup_opt "warn_default_effects" as_bool +let get_z3cliopt () = lookup_opt "z3cliopt" (as_list as_string) +let get_z3smtopt () = lookup_opt "z3smtopt" (as_list as_string) +let get_z3refresh () = lookup_opt "z3refresh" as_bool +let get_z3rlimit () = lookup_opt "z3rlimit" as_int +let get_z3rlimit_factor () = lookup_opt "z3rlimit_factor" as_int +let get_z3seed () = lookup_opt "z3seed" as_int +let get_z3version () = lookup_opt "z3version" as_string +let get_no_positivity () = lookup_opt "__no_positivity" as_bool +let get_warn_error () = lookup_opt "warn_error" (as_list as_string) +let get_use_nbe () = lookup_opt "use_nbe" as_bool +let get_use_nbe_for_extraction () = lookup_opt "use_nbe_for_extraction" as_bool +let get_trivial_pre_for_unannotated_effectful_fns + () = lookup_opt "trivial_pre_for_unannotated_effectful_fns" as_bool +let get_profile () = lookup_opt "profile" (as_option (as_list as_string)) +let get_profile_group_by_decl () = lookup_opt "profile_group_by_decl" as_bool +let get_profile_component () = lookup_opt "profile_component" (as_option (as_list as_string)) + +// See comment in the interface file +let _version = Util.mk_ref "" +let _platform = Util.mk_ref "" +let _compiler = Util.mk_ref "" +let _date = Util.mk_ref " not set" +let _commit = Util.mk_ref "" + +let display_version () = + Util.print_string (Util.format5 "F* %s\nplatform=%s\ncompiler=%s\ndate=%s\ncommit=%s\n" + !_version !_platform !_compiler !_date !_commit) + +let display_debug_keys () = + let keys = Debug.list_all_toggles () in + keys |> List.sortWith String.compare |> List.iter (fun s -> Util.print_string (s ^ "\n")) + +let display_usage_aux (specs : list (opt & Pprint.document)) : unit = + let open FStarC.Pprint in + let open FStarC.Errors.Msg in + let text (s:string) : document = flow (break_ 1) (words s) in + let bold_doc (d:document) : document = + (* very hacky, this would make no sense for documents going elsewhere + other than stdout *) + if stdout_isatty () = Some true + then fancystring "\x1b[39;1m" 0 ^^ d ^^ fancystring "\x1b[0m" 0 + else d + in + let d : document = + doc_of_string "fstar.exe [options] file[s] [@respfile...]" ^/^ + doc_of_string (Util.format1 " %srespfile: read command-line options from respfile\n" (Util.colorize_bold "@")) ^/^ + List.fold_right + (fun ((short, flag, p), explain) rest -> + let arg = + match p with + | ZeroArgs _ -> empty + | OneArg (_, argname) -> blank 1 ^^ doc_of_string argname + in + let short_opt = + if short <> noshort + then [doc_of_string ("-" ^ String.make 1 short) ^^ arg] + else [] + in + let long_opt = + if flag <> "" + then [doc_of_string ("--" ^ flag) ^^ arg] + else [] + in + group (bold_doc (separate (comma ^^ blank 1) (short_opt @ long_opt))) ^^ hardline ^^ + group (blank 4 ^^ align explain) ^^ hardline ^^ + rest + ) + specs empty + in + Util.print_string (pretty_string (float_of_string "1.0") 80 d) + +let mk_spec (o : char & string & opt_variant option_val) : opt = + let ns, name, arg = o in + let arg = + match arg with + | ZeroArgs f -> + let g () = set_option name (f()) in + ZeroArgs g + + | OneArg (f, d) -> + let g x = set_option name (f x) in + OneArg (g, d) in + ns, name, arg + +let accumulated_option name value = + let prev_values = Util.dflt [] (lookup_opt name (as_option as_list')) in + List (value :: prev_values) + +let reverse_accumulated_option name value = + let prev_values = Util.dflt [] (lookup_opt name (as_option as_list')) in + List (prev_values @ [value]) + +let accumulate_string name post_processor value = + set_option name (accumulated_option name (String (post_processor value))) + +let add_extract_module s = + accumulate_string "extract_module" String.lowercase s + +let add_extract_namespace s = + accumulate_string "extract_namespace" String.lowercase s + +let add_verify_module s = + accumulate_string "verify_module" String.lowercase s + +exception InvalidArgument of string // option name + +(** Parse option value `str_val` according to specification `typ`. + +For example, to parse the value "OCaml" for the option "--codegen", this +function is called as ``parse_opt_val "codegen" (EnumStr ["OCaml"; "FSharp"; +"krml"]) "OCaml"`` and returns ``String "OCaml"``. + +`opt_name` is only used in error messages. **) +let rec parse_opt_val (opt_name: string) (typ: opt_type) (str_val: string) : option_val = + try + match typ with + | Const c -> c + | IntStr _ -> (match safe_int_of_string str_val with + | Some v -> Int v + | None -> raise (InvalidArgument opt_name)) + | BoolStr -> Bool (if str_val = "true" then true + else if str_val = "false" then false + else raise (InvalidArgument opt_name)) + | PathStr _ -> Path str_val + | SimpleStr _ -> String str_val + | EnumStr strs -> if List.mem str_val strs then String str_val + else raise (InvalidArgument opt_name) + | OpenEnumStr _ -> String str_val + | PostProcessed (pp, elem_spec) -> pp (parse_opt_val opt_name elem_spec str_val) + | Accumulated elem_spec -> let v = parse_opt_val opt_name elem_spec str_val in + accumulated_option opt_name v + | ReverseAccumulated elem_spec -> let v = parse_opt_val opt_name elem_spec str_val in + reverse_accumulated_option opt_name v + | WithSideEffect (side_effect, elem_spec) -> side_effect (); + parse_opt_val opt_name elem_spec str_val + with + | InvalidArgument opt_name -> + failwith (Util.format1 "Invalid argument to --%s" opt_name) + +let rec desc_of_opt_type typ : option string = + let desc_of_enum cases = Some (String.concat "|" cases) in + match typ with + | Const c -> None + | IntStr desc -> Some desc + | BoolStr -> desc_of_enum ["true"; "false"] + | PathStr desc -> Some desc + | SimpleStr desc -> Some desc + | EnumStr strs -> desc_of_enum strs + | OpenEnumStr (strs, desc) -> desc_of_enum (strs @ [desc]) + | PostProcessed (_, elem_spec) + | Accumulated elem_spec + | ReverseAccumulated elem_spec + | WithSideEffect (_, elem_spec) -> desc_of_opt_type elem_spec + +let arg_spec_of_opt_type opt_name typ : opt_variant option_val = + let wrap s = "<" ^ s ^ ">" in + let parser = parse_opt_val opt_name typ in + match desc_of_opt_type typ with + | None -> ZeroArgs (fun () -> parser "") + | Some desc -> + let desc = wrap desc in + OneArg (parser, desc) + +let pp_validate_dir p = + let pp = as_string p in + mkdir (*clean=*)false (*mkparents=*)true pp; + p + +let pp_lowercase s = + String (String.lowercase (as_string s)) + +let abort_counter : ref int = + mk_ref 0 + +let interp_quake_arg (s:string) + : int & int & bool = + (* min, max, keep_going *) + let ios = int_of_string in + match split s "/" with + | [f] -> ios f, ios f, false + | [f1; f2] -> + if f2 = "k" + then ios f1, ios f1, true + else ios f1, ios f2, false + | [f1; f2; k] -> + if k = "k" + then ios f1, ios f2, true + else failwith "unexpected value for --quake" + | _ -> failwith "unexpected value for --quake" + +let set_option_warning_callback_aux, + option_warning_callback = + let cb = mk_ref None in + let set (f:string -> unit) = + cb := Some f + in + let call msg = + match !cb with + | None -> () + | Some f -> f msg + in + set, call +let set_option_warning_callback f = set_option_warning_callback_aux f + +let rec specs_with_types warn_unsafe : list (char & string & opt_type & Pprint.document) = + let open FStarC.Pprint in + let open FStarC.Errors.Msg in + let text (s:string) : document = flow (break_ 1) (words s) in + [ + ( noshort, "abort_on", + PostProcessed ((function Int x -> abort_counter := x; Int x + | x -> failwith "?"), IntStr "non-negative integer"), + text "Abort on the n-th error or warning raised. Useful in combination with --trace_error. Count starts at 1, use 0 to disable. (default 0)"); + + ( noshort, + "admit_smt_queries", + WithSideEffect ((fun _ -> if warn_unsafe then option_warning_callback "admit_smt_queries"), + BoolStr), + text "Admit SMT queries, unsafe! (default 'false')"); + + ( noshort, + "admit_except", + WithSideEffect ((fun _ -> if warn_unsafe then option_warning_callback "admit_except"), + SimpleStr "[symbol|(symbol, id)]"), + text "Admit all queries, except those with label ( symbol, id))\ + (e.g. --admit_except '(FStar.Fin.pigeonhole, 1)' or --admit_except FStar.Fin.pigeonhole)"); + + ( noshort, + "compat_pre_core", + IntStr "0, 1, 2", + text "Retain behavior of the tactic engine prior to the introduction \ + of FStarC.TypeChecker.Core (0 is most permissive, 2 is least permissive)"); + + ( noshort, + "compat_pre_typed_indexed_effects", + Const (Bool true), + text "Retain untyped indexed effects implicits"); + + ( noshort, + "disallow_unification_guards", + BoolStr, + text "Fail if the SMT guard are produced when the tactic engine re-checks solutions produced by the unifier (default 'false')"); + + ( noshort, + "already_cached", + Accumulated (SimpleStr "One or more space-separated occurrences of '[+|-]( * | namespace | module)'"), + text "Expects all modules whose names or namespaces match the provided options \ + to already have valid .checked files in the include path"); + + ( noshort, + "cache_checked_modules", + Const (Bool true), + text "Write a '.checked' file for each module after verification and read from it if present, instead of re-verifying"); + + ( noshort, + "cache_dir", + PostProcessed (pp_validate_dir, PathStr "dir"), + text "Read and write .checked and .checked.lax in directory dir"); + + ( noshort, + "cache_off", + Const (Bool true), + text "Do not read or write any .checked files"); + + ( noshort, + "print_cache_version", + Const (Bool true), + text "Print the version for .checked files and exit."); + + ( noshort, + "cmi", + Const (Bool true), + text "Inline across module interfaces during extraction (aka. cross-module inlining)"); + + ( noshort, + "codegen", + EnumStr ["OCaml"; "FSharp"; "krml"; "Plugin"; "Extension"], + text "Generate code for further compilation to executable code, or build a compiler plugin"); + + ( noshort, + "codegen-lib", + Accumulated (SimpleStr "namespace"), + text "External runtime library (i.e. M.N.x extracts to M.N.X instead of M_N.x)"); + + ( 'd', + "", + PostProcessed ( + (fun o -> + Debug.enable (); + o), Const (Bool true)), + text "Enable general debugging, i.e. increase verbosity."); + + ( noshort, + "debug", + PostProcessed ( + (fun o -> + let keys = as_comma_string_list o in + Debug.enable_toggles keys; + o), ReverseAccumulated (SimpleStr "debug toggles")), + text "Enable specific debug toggles (comma-separated list of debug keys)"); + + ( noshort, + "debug_all", + PostProcessed ( + (fun o -> + match o with + | Bool true -> + Debug.set_debug_all (); + o + | _ -> failwith "?" + ), Const (Bool true)), + text "Enable all debug toggles. WARNING: this will cause a lot of output!"); + + ( noshort, + "debug_all_modules", + Const (Bool true), + text "Enable to make the effect of --debug apply to every module processed by the compiler, \ + including dependencies."); + + ( noshort, + "defensive", + EnumStr ["no"; "warn"; "error"; "abort"], + text "Enable several internal sanity checks, useful to track bugs and report issues." + ^^ bulleted [ + text "if 'no', no checks are performed"; + text "if 'warn', checks are performed and raise a warning when they fail"; + text "if 'error, like 'warn', but the compiler raises a hard error instead"; + text "if 'abort, like 'warn', but the compiler immediately aborts on an error" + ] + ^/^ text "(default 'no')"); + + ( noshort, + "dep", + EnumStr ["make"; "graph"; "full"; "raw"], + text "Output the transitive closure of the full dependency graph in three formats:" + ^^ bulleted [ + text "'graph': a format suitable the 'dot' tool from 'GraphViz'"; + text "'full': a format suitable for 'make', including dependences for producing .ml and .krml files"; + text "'make': (deprecated) a format suitable for 'make', including only dependences among source files"; + ]); + + ( noshort, + "detail_errors", + Const (Bool true), + text "Emit a detailed error report by asking the SMT solver many queries; will take longer"); + + ( noshort, + "detail_hint_replay", + Const (Bool true), + text "Emit a detailed report for proof whose unsat core fails to replay"); + + ( noshort, + "dump_module", + Accumulated (SimpleStr "module_name"), + text "Print out this module as it passes through the compiler pipeline"); + + ( noshort, + "eager_subtyping", + Const (Bool true), + text "Try to solve subtyping constraints at each binder (loses precision but may be slightly more efficient)"); + + ( noshort, + "error_contexts", + BoolStr, + text "Print context information for each error or warning raised (default false)"); + + ( noshort, + "ext", + PostProcessed ( + (fun o -> + let parse_ext (s:string) : list (string & string) = + let exts = Util.split s ";" in + List.collect (fun s -> + match Util.split s "=" with + | [k;v] -> [(k,v)] + | _ -> [s, "1"]) exts + in + as_comma_string_list o |> List.collect parse_ext |> List.iter (fun (k, v) -> Ext.set k v); + o), ReverseAccumulated (SimpleStr "extension knobs")), + text "These options are set in extensions option map. Keys are usually namespaces separated by \":\". \ + E.g., 'pulse:verbose=1;my:extension:option=xyz;foo:bar=baz'. \ + These options are typically interpreted by extensions. \ + Any later use of --ext over the same key overrides the old value. \ + An entry 'e' that is not of the form 'a=b' is treated as 'e=1', i.e., 'e' associated with string \"1\"."); + + ( noshort, + "extract", + Accumulated (SimpleStr "One or more semicolon separated occurrences of '[TargetName:]ModuleSelector'"), + text "Extract only those modules whose names or namespaces match the provided options. \ + 'TargetName' ranges over {OCaml, krml, FSharp, Plugin, Extension}. \ + A 'ModuleSelector' is a space or comma-separated list of '[+|-]( * | namespace | module)'. \ + For example --extract 'OCaml:A -A.B' --extract 'krml:A -A.C' --extract '*' means \ + for OCaml, extract everything in the A namespace only except A.B; \ + for krml, extract everything in the A namespace only except A.C; \ + for everything else, extract everything. \ + Note, the '+' is optional: --extract '+A' and --extract 'A' mean the same thing. \ + Note also that '--extract A' applies both to a module named 'A' and to any module in the 'A' namespace \ + Multiple uses of this option accumulate, e.g., --extract A --extract B is interpreted as --extract 'A B'."); + + ( noshort, + "extract_module", + Accumulated (PostProcessed (pp_lowercase, (SimpleStr "module_name"))), + text "Deprecated: use --extract instead; Only extract the specified modules (instead of the possibly-partial dependency graph)"); + + ( noshort, + "extract_namespace", + Accumulated (PostProcessed (pp_lowercase, (SimpleStr "namespace name"))), + text "Deprecated: use --extract instead; Only extract modules in the specified namespace"); + + ( noshort, + "expose_interfaces", + Const (Bool true), + text "Explicitly break the abstraction imposed by the interface of any implementation file that appears on the command line (use with care!)"); + + ( noshort, + "message_format", + EnumStr ["human"; "json"], + text "Format of the messages emitted by F* (default `human`)"); + + ( noshort, + "hide_uvar_nums", + Const (Bool true), + text "Don't print unification variable numbers"); + + ( noshort, + "hint_dir", + PostProcessed (pp_validate_dir, PathStr "dir"), + text "Read/write hints to dir/module_name.hints (instead of placing hint-file alongside source file)"); + + ( noshort, + "hint_file", + PathStr "path", + text "Read/write hints to path (instead of module-specific hints files; overrides hint_dir)"); + + ( noshort, + "hint_info", + Const (Bool true), + text "Print information regarding hints (deprecated; use --query_stats instead)"); + + ( noshort, + "in", + Const (Bool true), + text "Legacy interactive mode; reads input from stdin"); + + ( noshort, + "ide", + Const (Bool true), + text "JSON-based interactive mode for IDEs"); + + ( noshort, + "ide_id_info_off", + Const (Bool true), + text "Disable identifier tables in IDE mode (temporary workaround useful in Steel)"); + + ( noshort, + "lsp", + Const (Bool true), + text "Language Server Protocol-based interactive mode for IDEs"); + + ( noshort, + "include", + ReverseAccumulated (PathStr "path"), + text "A directory in which to search for files included on the command line"); + + ( noshort, + "print", + Const (Bool true), + text "Parses and prettyprints the files included on the command line"); + + ( noshort, + "print_in_place", + Const (Bool true), + text "Parses and prettyprints in place the files included on the command line"); + + ( 'f', + "force", + Const (Bool true), + text "Force checking the files given as arguments even if they have valid checked files"); + + ( noshort, + "fuel", + PostProcessed + ((function | String s -> + let p f = Int (int_of_string f) in + let min, max = + match Util.split s "," with + | [f] -> f, f + | [f1;f2] -> f1, f2 + | _ -> failwith "unexpected value for --fuel" + in + set_option "initial_fuel" (p min); + set_option "max_fuel" (p max); + String s + | _ -> failwith "impos"), + SimpleStr "non-negative integer or pair of non-negative integers"), + text "Set initial_fuel and max_fuel at once"); + + ( noshort, + "ifuel", + PostProcessed + ((function | String s -> + let p f = Int (int_of_string f) in + let min, max = + match Util.split s "," with + | [f] -> f, f + | [f1;f2] -> f1, f2 + | _ -> failwith "unexpected value for --ifuel" + in + set_option "initial_ifuel" (p min); + set_option "max_ifuel" (p max); + String s + | _ -> failwith "impos"), + SimpleStr "non-negative integer or pair of non-negative integers"), + text "Set initial_ifuel and max_ifuel at once"); + + ( noshort, + "initial_fuel", + IntStr "non-negative integer", + text "Number of unrolling of recursive functions to try initially (default 2)"); + + ( noshort, + "initial_ifuel", + IntStr "non-negative integer", + text "Number of unrolling of inductive datatypes to try at first (default 1)"); + + ( noshort, + "keep_query_captions", + BoolStr, + text "Retain comments in the logged SMT queries (requires --log_queries or --log_failing_queries; default true)"); + + ( noshort, + "lax", + WithSideEffect ((fun () -> if warn_unsafe then option_warning_callback "lax"), Const (Bool true)), + text "Run the lax-type checker only (admit all verification conditions)"); + + ( noshort, + "load", + ReverseAccumulated (PathStr "module"), + text "Load OCaml module, compiling it if necessary"); + + ( noshort, + "load_cmxs", + ReverseAccumulated (PathStr "module"), + text "Load compiled module, fails hard if the module is not already compiled"); + + ( noshort, + "log_types", + Const (Bool true), + text "Print types computed for data/val/let-bindings"); + + ( noshort, + "log_queries", + Const (Bool true), + text "Log the Z3 queries in several queries-*.smt2 files, as we go"); + + ( noshort, + "log_failing_queries", + Const (Bool true), + text "As --log_queries, but only save the failing queries. Each query is + saved in its own file regardless of whether they were checked during the + same invocation. The SMT2 file names begin with \"failedQueries\""); + + ( noshort, + "max_fuel", + IntStr "non-negative integer", + text "Number of unrolling of recursive functions to try at most (default 8)"); + + ( noshort, + "max_ifuel", + IntStr "non-negative integer", + text "Number of unrolling of inductive datatypes to try at most (default 2)"); + + ( noshort, + "MLish", + Const (Bool true), + text "Trigger various specializations for compiling the F* compiler itself (not meant for user code)"); + + ( noshort, + "MLish_effect", + SimpleStr "module_name", + text "Set the default effect *module* for --MLish (default: FStar.Compiler.Effect)"); + + ( noshort, + "no_default_includes", + Const (Bool true), + text "Ignore the default module search paths"); + + ( noshort, + "no_extract", + Accumulated (PathStr "module name"), + text "Deprecated: use --extract instead; Do not extract code from this module"); + + ( noshort, + "no_location_info", + Const (Bool true), + text "Suppress location information in the generated OCaml output (only relevant with --codegen OCaml)"); + + ( noshort, + "no_smt", + Const (Bool true), + text "Do not send any queries to the SMT solver, and fail on them instead"); + + ( noshort, + "normalize_pure_terms_for_extraction", + Const (Bool true), + text "Extract top-level pure terms after normalizing them. This can lead to very large code, but can result in more partial evaluation and compile-time specialization."); + + ( noshort, + "krmloutput", + PathStr "filename", + text "Place KaRaMeL extraction output in file . The path can be relative or absolute and does not depend\ + on the --odir option."); + + ( noshort, + "odir", + PostProcessed (pp_validate_dir, PathStr "dir"), + text "Place output in directory dir"); + + ( noshort, + "output_deps_to", + PathStr "file", + text "Output the result of --dep into this file instead of to standard output."); + + ( noshort, + "prims", + PathStr "file", + text "Use a custom Prims.fst file. Do not use if you do not know exactly what you're doing."); + + ( noshort, + "print_bound_var_types", + Const (Bool true), + text "Print the types of bound variables"); + + ( noshort, + "print_effect_args", + Const (Bool true), + text "Print inferred predicate transformers for all computation types"); + + ( noshort, + "print_expected_failures", + Const (Bool true), + text "Print the errors generated by declarations marked with expect_failure, \ + useful for debugging error locations"); + + ( noshort, + "print_full_names", + Const (Bool true), + text "Print full names of variables"); + + ( noshort, + "print_implicits", + Const (Bool true), + text "Print implicit arguments"); + + ( noshort, + "print_universes", + Const (Bool true), + text "Print universes"); + + ( noshort, + "print_z3_statistics", + Const (Bool true), + text "Print Z3 statistics for each SMT query (details such as relevant modules, facts, etc. for each proof)"); + + ( noshort, + "prn", + Const (Bool true), + text "Print full names (deprecated; use --print_full_names instead)"); + + ( noshort, + "proof_recovery", + Const (Bool true), + text "Proof recovery mode: before failing an SMT query, retry 3 times, increasing rlimits. \ + If the query goes through after retrying, verification will succeed, but a warning will be emitted. \ + This feature is useful to restore a project after some change to its libraries or F* upgrade. \ + Importantly, then, this option cannot be used in a pragma (#set-options, etc)."); + + ( noshort, + "quake", + PostProcessed + ((function | String s -> + let min, max, k = interp_quake_arg s in + set_option "quake_lo" (Int min); + set_option "quake_hi" (Int max); + set_option "quake_keep" (Bool k); + set_option "retry" (Bool false); + String s + | _ -> failwith "impos"), + SimpleStr "positive integer or pair of positive integers"), + text "Repeats SMT queries to check for robustness" ^^ + bulleted [ + text "--quake N/M repeats each query checks that it succeeds at least N out of M times, aborting early if possible"; + text "--quake N/M/k works as above, except it will unconditionally run M times"; + text "--quake N is an alias for --quake N/N"; + text "--quake N/k is an alias for --quake N/N/k"; + ] ^^ + text "Using --quake disables --retry. When quake testing, queries are not splitted for error reporting unless \ + '--split_queries always' is given. Queries from the smt_sync tactic are not quake-tested."); + + ( noshort, + "query_cache", + Const (Bool true), + text "Keep a running cache of SMT queries to make verification faster. \ + Only available in the interactive mode. \ + NOTE: This feature is experimental and potentially unsound! Hence why + it is not allowed in batch mode (where it is also less useful). If you + find a query that is mistakenly accepted with the cache, please + report a bug to the F* issue tracker on GitHub."); + + ( noshort, + "query_stats", + Const (Bool true), + text "Print SMT query statistics"); + + ( noshort, + "read_checked_file", + PathStr "path", + text "Read a checked file and dump it to standard output."); + + ( noshort, + "read_krml_file", + PathStr "path", + text "Read a Karamel binary file and dump it to standard output."); + + ( noshort, + "record_hints", + Const (Bool true), + text "Record a database of hints for efficient proof replay"); + + ( noshort, + "record_options", + Const (Bool true), + text "Record the state of options used to check each sigelt, useful \ + for the `check_with` attribute and metaprogramming. \ + Note that this implies a performance hit and increases the size of checked files."); + + ( noshort, + "retry", + PostProcessed + ((function | Int i -> + set_option "quake_lo" (Int 1); + set_option "quake_hi" (Int i); + set_option "quake_keep" (Bool false); + set_option "retry" (Bool true); + Bool true + | _ -> failwith "impos"), + IntStr "positive integer"), + text "Retry each SMT query N times and succeed on the first try. Using --retry disables --quake."); + + ( noshort, + "reuse_hint_for", + SimpleStr "toplevel_name", + text "Optimistically, attempt using the recorded hint for toplevel_name (a top-level name in the current module) when trying to verify some other term 'g'"); + + ( noshort, + "report_assumes", + EnumStr ["warn"; "error"], + text "Report every use of an escape hatch, include assume, admit, etc."); + + ( noshort, + "silent", + Const (Bool true), + text "Disable all non-critical output"); + + ( noshort, + "smt", + PathStr "path", + text "Path to the Z3 SMT solver (we could eventually support other solvers)"); + + ( noshort, + "smtencoding.elim_box", + BoolStr, + text "Toggle a peephole optimization that eliminates redundant uses of boxing/unboxing in the SMT encoding (default 'false')"); + + ( noshort, + "smtencoding.nl_arith_repr", + EnumStr ["native"; "wrapped"; "boxwrap"], + text "Control the representation of non-linear arithmetic functions in the SMT encoding:" ^^ + bulleted [ + text "if 'boxwrap' use 'Prims.op_Multiply, Prims.op_Division, Prims.op_Modulus'"; + text "if 'native' use '*, div, mod'"; + text "if 'wrapped' use '_mul, _div, _mod : Int*Int -> Int'"; + ] ^^ + text "(default 'boxwrap')"); + + ( noshort, + "smtencoding.l_arith_repr", + EnumStr ["native"; "boxwrap"], + text "Toggle the representation of linear arithmetic functions in the SMT encoding:" ^^ + bulleted [ + text "if 'boxwrap', use 'Prims.op_Addition, Prims.op_Subtraction, Prims.op_Minus'"; + text "if 'native', use '+, -, -'"; + ] ^^ + text "(default 'boxwrap')"); + + ( noshort, + "smtencoding.valid_intro", + BoolStr, + text "Include an axiom in the SMT encoding to introduce proof-irrelevance from a constructive proof"); + + ( noshort, + "smtencoding.valid_elim", + BoolStr, + text "Include an axiom in the SMT encoding to eliminate proof-irrelevance into the existence of a proof witness"); + + ( noshort, + "split_queries", + EnumStr ["no"; "on_failure"; "always"], + text "Split SMT verification conditions into several separate queries, one per goal. \ + Helps with localizing errors." ^^ + bulleted [ + text "Use 'no' to disable (this may reduce the quality of error messages)."; + text "Use 'on_failure' to split queries and retry when discharging fails (the default)"; + text "Use 'yes' to always split."; + ]); + + ( noshort, + "tactic_raw_binders", + Const (Bool true), + text "Do not use the lexical scope of tactics to improve binder names"); + + ( noshort, + "tactics_failhard", + Const (Bool true), + text "Do not recover from metaprogramming errors, and abort if one occurs"); + + ( noshort, + "tactics_info", + Const (Bool true), + text "Print some rough information on tactics, such as the time they take to run"); + + ( noshort, + "tactic_trace", + Const (Bool true), + text "Print a depth-indexed trace of tactic execution (Warning: very verbose)"); + + ( noshort, + "tactic_trace_d", + IntStr "positive_integer", + text "Trace tactics up to a certain binding depth"); + + ( noshort, + "__tactics_nbe", + Const (Bool true), + text "Use NBE to evaluate metaprograms (experimental)"); + + ( noshort, + "tcnorm", + BoolStr, + text "Attempt to normalize definitions marked as tcnorm (default 'true')"); + + ( noshort, + "timing", + Const (Bool true), + text "Print the time it takes to verify each top-level definition. \ + This is just an alias for an invocation of the profiler, so it may not work well if combined with --profile. \ + In particular, it implies --profile_group_by_decl."); + + ( noshort, + "trace_error", + Const (Bool true), + text "Attach stack traces on errors"); + + ( noshort, + "ugly", + Const (Bool true), + text "Emit output formatted for debugging"); + + ( noshort, + "unthrottle_inductives", + Const (Bool true), + text "Let the SMT solver unfold inductive types to arbitrary depths (may affect verifier performance)"); + + ( noshort, + "unsafe_tactic_exec", + Const (Bool true), + text "Allow tactics to run external processes. WARNING: checking an untrusted F* file while \ + using this option can have disastrous effects."); + + ( noshort, + "use_eq_at_higher_order", + Const (Bool true), + text "Use equality constraints when comparing higher-order types (Temporary)"); + + ( noshort, + "use_hints", + Const (Bool true), + text "Use a previously recorded hints database for proof replay"); + + ( noshort, + "use_hint_hashes", + Const (Bool true), + text "Admit queries if their hash matches the hash recorded in the hints database"); + + ( noshort, + "use_native_tactics", + PathStr "path", + text "Use compiled tactics from path"); + + ( noshort, + "no_plugins", + Const (Bool true), + text "Do not run plugins natively and interpret them as usual instead"); + + ( noshort, + "no_tactics", + Const (Bool true), + text "Do not run the tactic engine before discharging a VC"); + + ( noshort, + "using_facts_from", + ReverseAccumulated (SimpleStr "One or more space-separated occurrences of '[+|-]( * | namespace | fact id)'"), + text "Prunes the context to include only the facts from the given namespace or fact id. \ + Facts can be include or excluded using the [+|-] qualifier. \ + For example --using_facts_from '* -FStarC.Reflection +FStarC.Compiler.List -FStarC.Compiler.List.Tot' will \ + remove all facts from FStarC.Compiler.List.Tot.*, \ + retain all remaining facts from FStarC.Compiler.List.*, \ + remove all facts from FStarC.Reflection.*, \ + and retain all the rest. \ + Note, the '+' is optional: --using_facts_from 'FStarC.Compiler.List' is equivalent to --using_facts_from '+FStarC.Compiler.List'. \ + Multiple uses of this option accumulate, e.g., --using_facts_from A --using_facts_from B is interpreted as --using_facts_from A^B."); + + ( noshort, + "__temp_fast_implicits", + Const (Bool true), + text "This does nothing and will be removed"); + + ( 'v', + "version", + WithSideEffect ((fun _ -> display_version(); exit 0), + (Const (Bool true))), + text "Display version number"); + + ( noshort, + "warn_default_effects", + Const (Bool true), + text "Warn when (a -> b) is desugared to (a -> Tot b)"); + + ( noshort, + "z3cliopt", + ReverseAccumulated (SimpleStr "option"), + text "Z3 command line options"); + + ( noshort, + "z3smtopt", + ReverseAccumulated (SimpleStr "option"), + text "Z3 options in smt2 format"); + + ( noshort, + "z3refresh", + Const (Bool true), + text "Restart Z3 after each query; useful for ensuring proof robustness"); + + ( noshort, + "z3rlimit", + IntStr "positive_integer", + text "Set the Z3 per-query resource limit (default 5 units, taking roughtly 5s)"); + + ( noshort, + "z3rlimit_factor", + IntStr "positive_integer", + text "Set the Z3 per-query resource limit multiplier. This is useful when, say, regenerating hints and you want to be more lax. (default 1)"); + + ( noshort, + "z3seed", + IntStr "positive_integer", + text "Set the Z3 random seed (default 0)"); + + ( noshort, + "z3version", + SimpleStr "version", + text "Set the version of Z3 that is to be used. Default: 4.8.5"); + + ( noshort, + "__no_positivity", + WithSideEffect ((fun _ -> if warn_unsafe then option_warning_callback "__no_positivity"), Const (Bool true)), + text "Don't check positivity of inductive types"); + + ( noshort, + "warn_error", + ReverseAccumulated (SimpleStr ("")), + text "The [-warn_error] option follows the OCaml syntax, namely:" ^^ + bulleted [ + text "[r] is a range of warnings (either a number [n], or a range [n..n])"; + text "[-r] silences range [r]"; + text "[+r] enables range [r] as warnings (NOTE: \"enabling\" an error will downgrade it to a warning)"; + text "[@r] makes range [r] fatal." + ]); + + ( noshort, + "use_nbe", + BoolStr, + text "Use normalization by evaluation as the default normalization strategy (default 'false')"); + + ( noshort, + "use_nbe_for_extraction", + BoolStr, + text "Use normalization by evaluation for normalizing terms before extraction (default 'false')"); + + ( noshort, + "trivial_pre_for_unannotated_effectful_fns", + BoolStr, + text "Enforce trivial preconditions for unannotated effectful functions (default 'true')" ); + + ( noshort, + "__debug_embedding", + WithSideEffect ((fun _ -> debug_embedding := true), + (Const (Bool true))), + text "Debug messages for embeddings/unembeddings of natively compiled terms"); + + ( noshort, + "eager_embedding", + WithSideEffect ((fun _ -> eager_embedding := true), + (Const (Bool true))), + text "Eagerly embed and unembed terms to primitive operations and plugins: not recommended except for benchmarking"); + + ( noshort, + "profile_group_by_decl", + Const (Bool true), + text "Emit profiles grouped by declaration rather than by module"); + + ( noshort, + "profile_component", + Accumulated (SimpleStr "One or more space-separated occurrences of '[+|-]( * | namespace | module | identifier)'"), + text "Specific source locations in the compiler are instrumented with profiling counters. \ + Pass `--profile_component FStarC.TypeChecker` to enable all counters in the FStarC.TypeChecker namespace. \ + This option is a module or namespace selector, like many other options (e.g., `--extract`)"); + + ( noshort, + "profile", + Accumulated (SimpleStr "One or more space-separated occurrences of '[+|-]( * | namespace | module)'"), + text "Profiling can be enabled when the compiler is processing a given set of source modules. \ + Pass `--profile FStar.Pervasives` to enable profiling when the compiler is processing any module in FStar.Pervasives. \ + This option is a module or namespace selector, like many other options (e.g., `--extract`)"); + + ( 'h', + "help", + WithSideEffect ((fun _ -> display_usage_aux (specs warn_unsafe); exit 0), + (Const (Bool true))), + text "Display this information"); + + ( noshort, + "list_debug_keys", + WithSideEffect ((fun _ -> display_debug_keys(); exit 0), + (Const (Bool true))), + text "List all debug keys and exit"); + + (* FIXME: all of these should really be modes, not a boolean option *) + ( noshort, + "list_plugins", + Const (Bool true), + text "List all registered plugins and exit"); + ( noshort, + "locate", + Const (Bool true), + text "Print the root of the F* installation and exit"); + ( noshort, + "locate_lib", + Const (Bool true), + text "Print the root of the F* library and exit"); + ( noshort, + "locate_ocaml", + Const (Bool true), + text "Print the root of the built OCaml F* library and exit"); + ] + +and specs (warn_unsafe:bool) : list (FStarC.Getopt.opt & Pprint.document) = + List.map (fun (short, long, typ, doc) -> + mk_spec (short, long, arg_spec_of_opt_type long typ), doc) + (specs_with_types warn_unsafe) + +// Several options can only be set at the time the process is created, +// and not controlled interactively via pragmas. +// Additionaly, the --smt option is a security concern. +let settable = function + | "__temp_fast_implicits" + | "abort_on" + | "admit_except" + | "admit_smt_queries" + | "compat_pre_core" + | "compat_pre_typed_indexed_effects" + | "disallow_unification_guards" + | "debug" + | "debug_all" + | "debug_all_modules" + | "defensive" + | "detail_errors" + | "detail_hint_replay" + | "eager_subtyping" + | "error_contexts" + | "hide_uvar_nums" + | "hint_dir" + | "hint_file" + | "hint_info" + | "fuel" + | "ext" + | "ifuel" + | "initial_fuel" + | "initial_ifuel" + | "ide_id_info_off" + | "keep_query_captions" + | "load" + | "load_cmxs" + | "log_queries" + | "log_failing_queries" + | "log_types" + | "max_fuel" + | "max_ifuel" + | "no_plugins" + | "__no_positivity" + | "normalize_pure_terms_for_extraction" + | "no_smt" + | "no_tactics" + | "print_bound_var_types" + | "print_effect_args" + | "print_expected_failures" + | "print_full_names" + | "print_implicits" + | "print_universes" + | "print_z3_statistics" + | "prn" + | "quake_lo" + | "quake_hi" + | "quake_keep" + | "quake" + | "query_cache" + | "query_stats" + | "record_options" + | "retry" + | "reuse_hint_for" + | "report_assumes" + | "silent" + | "smtencoding.elim_box" + | "smtencoding.l_arith_repr" + | "smtencoding.nl_arith_repr" + | "smtencoding.valid_intro" + | "smtencoding.valid_elim" + | "split_queries" + | "tactic_raw_binders" + | "tactics_failhard" + | "tactics_info" + | "__tactics_nbe" + | "tactic_trace" + | "tactic_trace_d" + | "tcnorm" + | "timing" + | "trace_error" + | "ugly" + | "unthrottle_inductives" + | "use_eq_at_higher_order" + | "using_facts_from" + | "warn_error" + | "z3cliopt" + | "z3smtopt" + | "z3refresh" + | "z3rlimit" + | "z3rlimit_factor" + | "z3seed" + | "z3version" + | "trivial_pre_for_unannotated_effectful_fns" + | "profile_group_by_decl" + | "profile_component" + | "profile" -> true + | _ -> false + +let all_specs = specs true +let all_specs_getopt = List.map fst all_specs + +let all_specs_with_types = specs_with_types true +let settable_specs = all_specs |> List.filter (fun ((_, x, _), _) -> settable x) + +///////////////////////////////////////////////////////////////////////////////////////////////////////// +//PUBLIC API +///////////////////////////////////////////////////////////////////////////////////////////////////////// +let set_error_flags_callback_aux, + set_error_flags = + let callback : ref (option (unit -> parse_cmdline_res)) = mk_ref None in + let set f = callback := Some f in + let call () = + match !callback with + | None -> failwith "Error flags callback not yet set" + | Some f -> f () + in + set, call + +let set_error_flags_callback = set_error_flags_callback_aux +let display_usage () = display_usage_aux all_specs + +let fstar_bin_directory = Util.get_exec_dir () + +let file_list_ : ref (list string) = Util.mk_ref [] + +(* In `parse_filename_arg specs arg`: + + * `arg` is a filename argument to be parsed. If `arg` is of the + form `@file`, then `file` is a response file, from which further + arguments (including further options) are read. Nested response + files (@ response file arguments within response files) are + supported. + + * `specs` is the list of option specifications (- and --) + + * `enable_filenames` is a boolean, true if non-response file + * filenames should be handled. + +*) + + +let rec parse_filename_arg specs enable_filenames arg = + if Util.starts_with arg "@" + then begin + // read and parse a response file + let filename = Util.substring_from arg 1 in + let lines = Util.file_get_lines filename in + Getopt.parse_list specs (parse_filename_arg specs enable_filenames) lines + end else begin + if enable_filenames + then file_list_ := !file_list_ @ [arg]; + Success + end + +let parse_cmd_line () = + let res = Getopt.parse_cmdline all_specs_getopt (parse_filename_arg all_specs_getopt true) in + let res = + if res = Success + then set_error_flags() + else res + in + res, List.map FC.try_convert_file_name_to_mixed !file_list_ + +let file_list () = + !file_list_ + +let restore_cmd_line_options should_clear = + (* Some options must be preserved because they can't be reset via #pragrams. + * Add them here as needed. *) + let old_verify_module = get_verify_module() in + if should_clear then clear() else init(); + let specs = List.map fst <| specs false in + let r = Getopt.parse_cmdline specs (parse_filename_arg specs false) in + set_option' ("verify_module", List (List.map String old_verify_module)); + r + +let module_name_of_file_name f = + let f = basename f in + let f = String.substring f 0 (String.length f - String.length (get_file_extension f) - 1) in + String.lowercase f + +let should_check m = + let l = get_verify_module () in + List.contains (String.lowercase m) l + +let should_verify m = + not (get_lax ()) && should_check m + +let should_check_file fn = + should_check (module_name_of_file_name fn) + +let should_verify_file fn = + should_verify (module_name_of_file_name fn) + +let module_name_eq m1 m2 = String.lowercase m1 = String.lowercase m2 + +let should_print_message m = + if should_verify m + then m <> "Prims" + else false + +let read_fstar_include (fn : string) : option (list string) = + try + let s = file_get_contents fn in + let subdirs = String.split ['\n'] s |> List.filter (fun s -> s <> "" && not (String.get s 0 = '#')) in + Some subdirs + with + | _ -> + failwith ("Could not read " ^ fn); + None + +let rec expand_include_d (dirname : string) : list string = + let dot_inc_path = dirname ^ "/fstar.include" in + if Util.file_exists dot_inc_path then ( + let subdirs = Some?.v <| read_fstar_include dot_inc_path in + dirname :: List.collect (fun subd -> expand_include_d (dirname ^ "/" ^ subd)) subdirs + ) else + [dirname] + +let expand_include_ds (dirnames : list string) : list string = + List.collect expand_include_d dirnames + +(* TODO: normalize these paths. This will probably affect makefiles since +make does not normalize the paths itself. Also, move this whole logic away +from this module. *) +let lib_root () : option string = + (* No default includes means we don't try to find a library on our own. *) + if get_no_default_includes() then + None + else + (* FSTAR_LIB can be set in the environment to override the library *) + match Util.expand_environment_variable "FSTAR_LIB" with + | Some s -> Some s + | None -> + (* Otherwise, try to find the library in the default locations. It's ulib/ + in the repository, and lib/fstar/ in the binary package. *) + if Util.file_exists (fstar_bin_directory ^ "/../ulib") + then Some (fstar_bin_directory ^ "/../ulib") + else if Util.file_exists (fstar_bin_directory ^ "/../lib/fstar") + then Some (fstar_bin_directory ^ "/../lib/fstar") + else None + +let lib_paths () = + Common.option_to_list (lib_root ()) |> expand_include_ds + +let include_path () = + let cache_dir = + match get_cache_dir() with + | None -> [] + | Some c -> [c] + in + let include_paths = + get_include () |> expand_include_ds + in + cache_dir @ lib_paths () @ include_paths @ expand_include_d "." + +let custom_prims () = get_prims() + +let prepend_output_dir fname = + match get_odir() with + | None -> fname + | Some x -> Util.join_paths x fname + +let prepend_cache_dir fpath = + match get_cache_dir() with + | None -> fpath + | Some x -> Util.join_paths x (Util.basename fpath) + +//Used to parse the options of +// --using_facts_from +// --extract +// --already_cached +let path_of_text text = String.split ['.'] text + +let parse_settings ns : list (list string & bool) = + let cache = Util.smap_create 31 in + let with_cache f s = + match Util.smap_try_find cache s with + | Some s -> s + | None -> + let res = f s in + Util.smap_add cache s res; + res + in + let parse_one_setting s = + if s = "*" then ([], true) + else if s = "-*" then ([], false) + else if Util.starts_with s "-" + then let path = path_of_text (Util.substring_from s 1) in + (path, false) + else let s = if Util.starts_with s "+" + then Util.substring_from s 1 + else s in + (path_of_text s, true) + in + ns |> List.collect (fun s -> + let s = Util.trim_string s in + if s = "" then [] + else with_cache (fun s -> + let s = Util.replace_char s ' ' ',' in + Util.splitlines s + |> List.concatMap (fun s -> Util.split s ",") + |> List.filter (fun s -> s <> "") + |> List.map parse_one_setting) s) + |> List.rev + +let admit_smt_queries () = get_admit_smt_queries () +let admit_except () = get_admit_except () +let compat_pre_core_should_register () = + match get_compat_pre_core() with + | Some 0 -> false + | _ -> true +let compat_pre_core_should_check () = + match get_compat_pre_core() with + | Some 0 + | Some 1 -> false + | _ -> true +let compat_pre_core_set () = + match get_compat_pre_core() with + | None -> false + | _ -> true + +let compat_pre_typed_indexed_effects () = get_compat_pre_typed_indexed_effects () + +let disallow_unification_guards () = get_disallow_unification_guards () +let cache_checked_modules () = get_cache_checked_modules () +let cache_off () = get_cache_off () +let print_cache_version () = get_print_cache_version () +let cmi () = get_cmi () + +let parse_codegen = + function + | "OCaml" -> Some OCaml + | "FSharp" -> Some FSharp + | "krml" -> Some Krml + | "Plugin" -> Some Plugin + | "Extension" -> Some Extension + | _ -> None + +let print_codegen = + function + | OCaml -> "OCaml" + | FSharp -> "FSharp" + | Krml -> "krml" + | Plugin -> "Plugin" + | Extension -> "Extension" + +let codegen () = + Util.map_opt (get_codegen()) + (fun s -> parse_codegen s |> must) + +let codegen_libs () = get_codegen_lib () |> List.map (fun x -> Util.split x ".") + +let profile_group_by_decl () = get_profile_group_by_decl () +let defensive () = get_defensive () <> "no" +let defensive_error () = get_defensive () = "error" +let defensive_abort () = get_defensive () = "abort" +let dep () = get_dep () +let detail_errors () = get_detail_errors () +let detail_hint_replay () = get_detail_hint_replay () +let any_dump_module () = Cons? (get_dump_module()) +let dump_module s = get_dump_module() |> List.existsb (module_name_eq s) +let eager_subtyping () = get_eager_subtyping() +let error_contexts () = get_error_contexts () +let expose_interfaces () = get_expose_interfaces () +let message_format () = + match get_message_format () with + | "human" -> Human + | "json" -> Json + | illegal -> failwith ("print_issue: option `message_format` was expected to be `human` or `json`, not `" ^ illegal ^ "`. This should be impossible: `message_format` was supposed to be validated.") +let force () = get_force () +let full_context_dependency () = true +let hide_uvar_nums () = get_hide_uvar_nums () +let hint_info () = get_hint_info () + || get_query_stats () +let hint_dir () = get_hint_dir () +let hint_file () = get_hint_file () +let hint_file_for_src src_filename = + match hint_file() with + | Some fn -> fn + | None -> + let file_name = + match hint_dir () with + | Some dir -> + Util.concat_dir_filename dir (Util.basename src_filename) + | _ -> src_filename + in + Util.format1 "%s.hints" file_name +let ide () = get_ide () +let ide_id_info_off () = get_ide_id_info_off () +let ide_file_name_st = + let v = Util.mk_ref (None #string) in + let set f = + match !v with + | None -> v := Some f + | Some _ -> failwith "ide_file_name_st already set" in + let get () = !v in + set, get +let set_ide_filename = fst ide_file_name_st +let ide_filename = snd ide_file_name_st +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 interactive () = get_in () || get_ide () || get_lsp () +let lax () = get_lax () +let load () = get_load () +let load_cmxs () = get_load_cmxs () +let legacy_interactive () = get_in () +let lsp_server () = get_lsp () +let log_queries () = get_log_queries () +let log_failing_queries () = get_log_failing_queries () +let keep_query_captions () = + get_keep_query_captions () + && (log_queries () || log_failing_queries ()) + +let log_types () = get_log_types () +let max_fuel () = get_max_fuel () +let max_ifuel () = get_max_ifuel () +let ml_ish () = get_MLish () +let ml_ish_effect () = get_MLish_effect () +let set_ml_ish () = set_option "MLish" (Bool true) +let no_default_includes () = get_no_default_includes () +let no_extract s = get_no_extract() |> List.existsb (module_name_eq s) +let normalize_pure_terms_for_extraction + () = get_normalize_pure_terms_for_extraction () +let no_location_info () = get_no_location_info () +let no_plugins () = get_no_plugins () +let no_smt () = get_no_smt () +let krmloutput () = get_krmloutput () +let output_dir () = get_odir () +let output_deps_to () = get_output_deps_to () +let ugly () = get_ugly () +let print_bound_var_types () = get_print_bound_var_types () +let print_effect_args () = get_print_effect_args () +let print_expected_failures () = get_print_expected_failures () +let print_implicits () = get_print_implicits () +let print_real_names () = get_prn () || get_print_full_names() +let print_universes () = get_print_universes () +let print_z3_statistics () = get_print_z3_statistics () +let proof_recovery () = get_proof_recovery () +let quake_lo () = get_quake_lo () +let quake_hi () = get_quake_hi () +let quake_keep () = get_quake_keep () +let query_cache () = get_query_cache () +let query_stats () = get_query_stats () +let read_checked_file () = get_read_checked_file () +let list_plugins () = get_list_plugins () +let locate () = get_locate () +let locate_lib () = get_locate_lib () +let locate_ocaml () = get_locate_ocaml () +let read_krml_file () = get_read_krml_file () +let record_hints () = get_record_hints () +let record_options () = get_record_options () +let retry () = get_retry () +let reuse_hint_for () = get_reuse_hint_for () +let report_assumes () = get_report_assumes () +let silent () = get_silent () +let smt () = get_smt () +let smtencoding_elim_box () = get_smtencoding_elim_box () +let smtencoding_nl_arith_native () = get_smtencoding_nl_arith_repr () = "native" +let smtencoding_nl_arith_wrapped () = get_smtencoding_nl_arith_repr () = "wrapped" +let smtencoding_nl_arith_default () = get_smtencoding_nl_arith_repr () = "boxwrap" +let smtencoding_l_arith_native () = get_smtencoding_l_arith_repr () = "native" +let smtencoding_l_arith_default () = get_smtencoding_l_arith_repr () = "boxwrap" +let smtencoding_valid_intro () = get_smtencoding_valid_intro () +let smtencoding_valid_elim () = get_smtencoding_valid_elim () + +let parse_split_queries (s:string) : option split_queries_t = + match s with + | "no" -> Some No + | "on_failure" -> Some OnFailure + | "always" -> Some Always + | _ -> None + +let split_queries () = get_split_queries () |> parse_split_queries |> Util.must +let tactic_raw_binders () = get_tactic_raw_binders () +let tactics_failhard () = get_tactics_failhard () +let tactics_info () = get_tactics_info () +let tactic_trace () = get_tactic_trace () +let tactic_trace_d () = get_tactic_trace_d () +let tactics_nbe () = get_tactics_nbe () +let tcnorm () = get_tcnorm () +let timing () = get_timing () +let trace_error () = get_trace_error () +let unthrottle_inductives () = get_unthrottle_inductives () +let unsafe_tactic_exec () = get_unsafe_tactic_exec () +let use_eq_at_higher_order () = get_use_eq_at_higher_order () +let use_hints () = get_use_hints () +let use_hint_hashes () = get_use_hint_hashes () +let use_native_tactics () = get_use_native_tactics () +let use_tactics () = not (get_no_tactics ()) +let using_facts_from () = + match get_using_facts_from () with + | None -> [ [], true ] //if not set, then retain all facts + | Some ns -> parse_settings ns +let warn_default_effects () = get_warn_default_effects () +let warn_error () = String.concat " " (get_warn_error()) +let z3_cliopt () = get_z3cliopt () +let z3_smtopt () = get_z3smtopt () +let z3_refresh () = get_z3refresh () +let z3_rlimit () = get_z3rlimit () +let z3_rlimit_factor () = get_z3rlimit_factor () +let z3_seed () = get_z3seed () +let z3_version () = get_z3version () +let no_positivity () = get_no_positivity () +let use_nbe () = get_use_nbe () +let use_nbe_for_extraction () = get_use_nbe_for_extraction () +let trivial_pre_for_unannotated_effectful_fns + () = get_trivial_pre_for_unannotated_effectful_fns () + +let debug_keys () = lookup_opt "debug" as_comma_string_list +let debug_all () = lookup_opt "debug_all" as_bool +let debug_all_modules () = lookup_opt "debug_all_modules" as_bool + +let with_saved_options f = + // take some care to not mess up the stack on errors + // (unless we're trying to track down an error) + // TODO: This assumes `f` does not mess with the stack! + if not (trace_error ()) then begin + push (); + let r = try Inr (f ()) with | ex -> Inl ex in + pop (); + match r with + | Inr v -> v + | Inl ex -> raise ex + end else begin + push (); + let retv = f () in + pop (); + retv + end + +let module_matches_namespace_filter m filter = + let m = String.lowercase m in + let setting = parse_settings filter in + let m_components = path_of_text m in + let rec matches_path m_components path = + match m_components, path with + | _, [] -> true + | m::ms, p::ps -> m=String.lowercase p && matches_path ms ps + | _ -> false + in + match setting + |> Util.try_find + (fun (path, _) -> matches_path m_components path) + with + | None -> false + | Some (_, flag) -> flag + +let matches_namespace_filter_opt m = + function + | None -> false + | Some filter -> module_matches_namespace_filter m filter + +type parsed_extract_setting = { + target_specific_settings: list (codegen_t & string); + default_settings:option string +} + +let print_pes pes = + Util.format2 "{ target_specific_settings = %s;\n\t + default_settings = %s }" + (List.map (fun (tgt, s) -> + Util.format2 "(%s, %s)" + (print_codegen tgt) + s) + pes.target_specific_settings + |> String.concat "; ") + (match pes.default_settings with + | None -> "None" + | Some s -> s) + +let find_setting_for_target tgt (s:list (codegen_t & string)) + : option string + = match Util.try_find (fun (x, _) -> x = tgt) s with + | Some (_, s) -> Some s + | _ -> None + +let extract_settings + : unit -> option parsed_extract_setting + = let memo:ref (option parsed_extract_setting & bool) = Util.mk_ref (None, false) in + let merge_parsed_extract_settings p0 p1 : parsed_extract_setting = + let merge_setting s0 s1 = + match s0, s1 with + | None, None -> None + | Some p, None + | None, Some p -> Some p + | Some p0, Some p1 -> Some (p0 ^ "," ^ p1) + in + let merge_target tgt = + match + merge_setting + (find_setting_for_target tgt p0.target_specific_settings) + (find_setting_for_target tgt p1.target_specific_settings) + with + | None -> [] + | Some x -> [tgt,x] + in + { + target_specific_settings = List.collect merge_target [OCaml;FSharp;Krml;Plugin;Extension]; + default_settings = merge_setting p0.default_settings p1.default_settings + } + in + fun _ -> + let result, set = !memo in + let fail msg = + display_usage(); + failwith (Util.format1 "Could not parse '%s' passed to the --extract option" msg) + in + if set then result + else match get_extract () with + | None -> + memo := (None, true); + None + + | Some extract_settings -> + let parse_one_setting extract_setting = + // T1:setting1; T2:setting2; ... or + // setting <-- applies to all other targets + let tgt_specific_settings = Util.split extract_setting ";" in + let split_one t_setting = + match Util.split t_setting ":" with + | [default_setting] -> + Inr (Util.trim_string default_setting) + | [target; setting] -> + let target = Util.trim_string target in + match parse_codegen target with + | None -> fail target + | Some tgt -> Inl (tgt, Util.trim_string setting) + | _ -> fail t_setting + in + let settings = List.map split_one tgt_specific_settings in + let fail_duplicate msg tgt = + display_usage(); + failwith + (Util.format2 + "Could not parse '%s'; multiple setting for %s target" + msg tgt) + in + let pes = + List.fold_right + (fun setting out -> + match setting with + | Inr def -> + (match out.default_settings with + | None -> { out with default_settings = Some def } + | Some _ -> fail_duplicate def "default") + | Inl (target, setting) -> + (match Util.try_find (fun (x, _) -> x = target) out.target_specific_settings with + | None -> { out with target_specific_settings = (target, setting):: out.target_specific_settings } + | Some _ -> fail_duplicate setting (print_codegen target))) + settings + ({ target_specific_settings = []; default_settings = None }) + in + pes + in + let empty_pes = { target_specific_settings = []; default_settings = None } in + let pes = + //the left-most settings on the command line are at the end of the list + //so fold_right + List.fold_right + (fun setting pes -> merge_parsed_extract_settings pes (parse_one_setting setting)) + extract_settings + empty_pes + in + memo := (Some pes, true); + Some pes + +let should_extract (m:string) (tgt:codegen_t) : bool = + let m = String.lowercase m in + if m = "prims" then false + else + match extract_settings() with + | Some pes -> //new option, using --extract 'OCaml:* -FStar' etc. + let _ = + match get_no_extract(), + get_extract_namespace(), + get_extract_module () + with + | [], [], [] -> () + | _ -> failwith "Incompatible options: \ + --extract cannot be used with \ + --no_extract, --extract_namespace or --extract_module" + in + let tsetting = + match find_setting_for_target tgt pes.target_specific_settings with + | Some s -> s + | None -> + match pes.default_settings with + | Some s -> s + | None -> "*" //extract everything, by default + in + module_matches_namespace_filter m [tsetting] + | None -> //old + let should_extract_namespace m = + match get_extract_namespace () with + | [] -> false + | ns -> ns |> Util.for_some (fun n -> Util.starts_with m (String.lowercase n)) + in + let should_extract_module m = + match get_extract_module () with + | [] -> false + | l -> l |> Util.for_some (fun n -> String.lowercase n = m) + in + not (no_extract m) && + (match get_extract_namespace (), get_extract_module() with + | [], [] -> true //neither is set; extract everything + | _ -> should_extract_namespace m || should_extract_module m) + +let should_be_already_cached m = + (* should_check is true for files in the command line, + we exclude those from this check since they were explicitly + requested. *) + not (should_check m) && ( + match get_already_cached() with + | None -> false + | Some already_cached_setting -> + module_matches_namespace_filter m already_cached_setting + ) + + +let profile_enabled modul_opt phase = + match modul_opt with + | None -> //the phase is not associated with a module + matches_namespace_filter_opt phase (get_profile_component()) + + | Some modul -> + (matches_namespace_filter_opt modul (get_profile()) + && matches_namespace_filter_opt phase (get_profile_component())) + + // A special case for --timing: this option should print the time + // taken for each top-level decl, so we enable the profiler only for + // the FStarC.TypeChecker.process_one_decl phase, and only for those + // modules given in the command line. + || (timing () + && phase = "FStarC.TypeChecker.Tc.process_one_decl" + && should_check modul) + +exception File_argument of string + +let set_options s = + try + if s = "" + then Success + else let settable_specs = List.map fst settable_specs in + let res = Getopt.parse_string settable_specs (fun s -> raise (File_argument s); Error "set_options with file argument") s in + if res=Success + then set_error_flags() + else res + with + | File_argument s -> Getopt.Error (Util.format1 "File %s is not a valid option" s) + +let with_options s f = + with_saved_options (fun () -> + ignore (set_options s); + f ()) + +let get_vconfig () = + let vcfg = { + initial_fuel = get_initial_fuel (); + max_fuel = get_max_fuel (); + initial_ifuel = get_initial_ifuel (); + max_ifuel = get_max_ifuel (); + detail_errors = get_detail_errors (); + detail_hint_replay = get_detail_hint_replay (); + no_smt = get_no_smt (); + quake_lo = get_quake_lo (); + quake_hi = get_quake_hi (); + quake_keep = get_quake_keep (); + retry = get_retry (); + smtencoding_elim_box = get_smtencoding_elim_box (); + smtencoding_nl_arith_repr = get_smtencoding_nl_arith_repr (); + smtencoding_l_arith_repr = get_smtencoding_l_arith_repr (); + smtencoding_valid_intro = get_smtencoding_valid_intro (); + smtencoding_valid_elim = get_smtencoding_valid_elim (); + tcnorm = get_tcnorm (); + no_plugins = get_no_plugins (); + no_tactics = get_no_tactics (); + z3cliopt = get_z3cliopt (); + z3smtopt = get_z3smtopt (); + z3refresh = get_z3refresh (); + z3rlimit = get_z3rlimit (); + z3rlimit_factor = get_z3rlimit_factor (); + z3seed = get_z3seed (); + z3version = get_z3version (); + trivial_pre_for_unannotated_effectful_fns = get_trivial_pre_for_unannotated_effectful_fns (); + reuse_hint_for = get_reuse_hint_for (); + } + in + vcfg + +let set_vconfig (vcfg:vconfig) : unit = + let option_as (tag : 'a -> option_val) (o : option 'a) : option_val = + match o with + | None -> Unset + | Some s -> tag s + in + set_option "initial_fuel" (Int vcfg.initial_fuel); + set_option "max_fuel" (Int vcfg.max_fuel); + set_option "initial_ifuel" (Int vcfg.initial_ifuel); + set_option "max_ifuel" (Int vcfg.max_ifuel); + set_option "detail_errors" (Bool vcfg.detail_errors); + set_option "detail_hint_replay" (Bool vcfg.detail_hint_replay); + set_option "no_smt" (Bool vcfg.no_smt); + set_option "quake_lo" (Int vcfg.quake_lo); + set_option "quake_hi" (Int vcfg.quake_hi); + set_option "quake_keep" (Bool vcfg.quake_keep); + set_option "retry" (Bool vcfg.retry); + set_option "smtencoding.elim_box" (Bool vcfg.smtencoding_elim_box); + set_option "smtencoding.nl_arith_repr" (String vcfg.smtencoding_nl_arith_repr); + set_option "smtencoding.l_arith_repr" (String vcfg.smtencoding_l_arith_repr); + set_option "smtencoding.valid_intro" (Bool vcfg.smtencoding_valid_intro); + set_option "smtencoding.valid_elim" (Bool vcfg.smtencoding_valid_elim); + set_option "tcnorm" (Bool vcfg.tcnorm); + set_option "no_plugins" (Bool vcfg.no_plugins); + set_option "no_tactics" (Bool vcfg.no_tactics); + set_option "z3cliopt" (List (List.map String vcfg.z3cliopt)); + set_option "z3smtopt" (List (List.map String vcfg.z3smtopt)); + set_option "z3refresh" (Bool vcfg.z3refresh); + set_option "z3rlimit" (Int vcfg.z3rlimit); + set_option "z3rlimit_factor" (Int vcfg.z3rlimit_factor); + set_option "z3seed" (Int vcfg.z3seed); + set_option "z3version" (String vcfg.z3version); + set_option "trivial_pre_for_unannotated_effectful_fns" (Bool vcfg.trivial_pre_for_unannotated_effectful_fns); + set_option "reuse_hint_for" (option_as String vcfg.reuse_hint_for); + () + +instance showable_codegen_t : showable codegen_t = { + show = print_codegen; +} diff --git a/src/basic/FStarC.Options.fsti b/src/basic/FStarC.Options.fsti new file mode 100644 index 00000000000..605f744712d --- /dev/null +++ b/src/basic/FStarC.Options.fsti @@ -0,0 +1,287 @@ +(* + Copyright 2008-2020 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Options +open FStar.All +open FStarC.Compiler.Effect +open FStarC.Getopt +open FStarC.BaseTypes +open FStarC.VConfig +open FStarC.Compiler + +type codegen_t = + | OCaml + | FSharp + | Krml + | Plugin + | Extension + +//let __test_norm_all = Util.mk_ref false + +type split_queries_t = | No | OnFailure | Always + +type message_format_t = | Json | Human + +type option_val = + | Bool of bool + | String of string + | Path of string + | Int of int + | List of list option_val + | Unset + +type optionstate = FStarC.Compiler.Util.psmap option_val + +type opt_type = +| Const of option_val + // --cache_checked_modules +| IntStr of string (* label *) + // --z3rlimit 5 +| BoolStr + // --admit_smt_queries true +| PathStr of string (* label *) + // --fstar_home /build/fstar +| SimpleStr of string (* label *) + // --admit_except xyz +| EnumStr of list string + // --codegen OCaml +| OpenEnumStr of list string (* suggested values (not exhaustive) *) & string (* label *) + // --debug … +| PostProcessed of ((option_val -> option_val) (* validator *) & opt_type (* elem spec *)) + // For options like --extract_module that require post-processing or validation +| Accumulated of opt_type (* elem spec *) + // For options like --extract_module that can be repeated (LIFO) +| ReverseAccumulated of opt_type (* elem spec *) + // For options like --include that can be repeated (FIFO) +| WithSideEffect of ((unit -> unit) & opt_type (* elem spec *)) + // For options like --version that have side effects + +val defaults : list (string & option_val) + +val init : unit -> unit //sets the current options to their defaults +val clear : unit -> unit //wipes the stack of options, and then inits +val restore_cmd_line_options : bool -> parse_cmdline_res //inits or clears (if the flag is set) the current options and then sets it to the cmd line + +(* Control the option stack *) +(* Briefly, push/pop are used by the interactive mode and internal_* + * by #push-options/#pop-options. Read the comment in the .fs for more + * details. *) +val push : unit -> unit +val pop : unit -> unit +val internal_push : unit -> unit +val internal_pop : unit -> bool (* returns whether it worked or not, false should be taken as a hard error *) +val depth : unit -> int (* number of elements in internal option stack, besides current. If >0, internal_pop should succeed. *) +val snapshot : unit -> (int & unit) +val rollback : option int -> unit +val peek : unit -> optionstate +val set : optionstate -> unit +val set_verification_options : optionstate -> unit + +(* Print the current optionstate as a string that could be passed to fstar.exe, e.g. +"--z3rlimit 25 --include /some/path" *) +val show_options : unit -> string + +val __unit_tests : unit -> bool +val __set_unit_tests : unit -> unit +val __clear_unit_tests : unit -> unit +val parse_cmd_line : unit -> parse_cmdline_res & list string +val add_verify_module : string -> unit + +val set_option_warning_callback : (string -> unit) -> unit +val desc_of_opt_type : opt_type -> option string +val all_specs_with_types : list (char & string & opt_type & Pprint.document) +val settable : string -> bool + +val abort_counter : ref int + +val admit_smt_queries : unit -> bool +val set_admit_smt_queries : bool -> unit +val admit_except : unit -> option string +val compat_pre_core_should_register : unit -> bool +val compat_pre_core_should_check : unit -> bool +val compat_pre_core_set : unit -> bool +val compat_pre_typed_indexed_effects: unit -> bool +val disallow_unification_guards : unit -> bool +val cache_checked_modules : unit -> bool +val cache_off : unit -> bool +val print_cache_version : unit -> bool +val cmi : unit -> bool +val codegen : unit -> option codegen_t +val parse_codegen : string -> option codegen_t +val codegen_libs : unit -> list (list string) +val profile_enabled : module_name:option string -> profile_phase:string -> bool +val profile_group_by_decl : unit -> bool +val defensive : unit -> bool // true if checks should be performed +val defensive_error : unit -> bool // true if "error" +val defensive_abort : unit -> bool // true if "abort" +val dep : unit -> option string +val detail_errors : unit -> bool +val detail_hint_replay : unit -> bool +val display_usage : unit -> unit +val any_dump_module : unit -> bool +val dump_module : string -> bool +val eager_subtyping : unit -> bool +val error_contexts : unit -> bool +val expose_interfaces : unit -> bool +val message_format : unit -> message_format_t +val file_list : unit -> list string +val force : unit -> bool +val fstar_bin_directory : string +val get_option : string -> option_val +val full_context_dependency : unit -> bool +val hide_uvar_nums : unit -> bool +val hint_info : unit -> bool +val hint_file_for_src : string -> string +val ide : unit -> bool +val ide_id_info_off : unit -> bool +val set_ide_filename : string -> unit +val ide_filename : unit -> option string +val lib_root : unit -> option string +val lib_paths : unit -> list string +val include_path : unit -> list string +val print : unit -> bool +val print_in_place : unit -> bool +val initial_fuel : unit -> int +val initial_ifuel : unit -> int +val interactive : unit -> bool +val keep_query_captions : unit -> bool +val lax : unit -> bool +val load : unit -> list string +val load_cmxs : unit -> list string +val legacy_interactive : unit -> bool +val lsp_server : unit -> bool +val log_queries : unit -> bool +val log_failing_queries : unit -> bool +val log_types : unit -> bool +val max_fuel : unit -> int +val max_ifuel : unit -> int +val ml_ish : unit -> bool +val ml_ish_effect : unit -> string +val set_ml_ish : unit -> unit +val no_default_includes : unit -> bool +val no_location_info : unit -> bool +val no_plugins : unit -> bool +val no_smt : unit -> bool +val normalize_pure_terms_for_extraction + : unit -> bool +val krmloutput : unit -> option string +val list_plugins : unit -> bool +val locate : unit -> bool +val locate_lib : unit -> bool +val locate_ocaml : unit -> bool +val output_deps_to : unit -> option string +val output_dir : unit -> option string +val prepend_cache_dir : string -> string +val prepend_output_dir : string -> string +val custom_prims : unit -> option string +val print_bound_var_types : unit -> bool +val print_effect_args : unit -> bool +val print_expected_failures : unit -> bool +val print_implicits : unit -> bool +val print_real_names : unit -> bool +val print_universes : unit -> bool +val print_z3_statistics : unit -> bool +val proof_recovery : unit -> bool +val quake_lo : unit -> int +val quake_hi : unit -> int +val quake_keep : unit -> bool +val query_cache : unit -> bool +val query_stats : unit -> bool +val read_checked_file : unit -> option string +val read_krml_file : unit -> option string +val record_hints : unit -> bool +val record_options : unit -> bool +val retry : unit -> bool +val reuse_hint_for : unit -> option string +val report_assumes : unit -> option string +val set_option : string -> option_val -> unit +val set_options : string -> parse_cmdline_res +val should_be_already_cached : string -> bool +val should_print_message : string -> bool +val should_extract : string -> codegen_t -> bool +val should_check : string -> bool (* Should check this module, lax or not. *) +val should_check_file : string -> bool (* Should check this file, lax or not. *) +val should_verify : string -> bool (* Should check this module with verification enabled. *) +val should_verify_file : string -> bool (* Should check this file with verification enabled. *) +val silent : unit -> bool +val smt : unit -> option string +val smtencoding_elim_box : unit -> bool +val smtencoding_nl_arith_default: unit -> bool +val smtencoding_nl_arith_wrapped: unit -> bool +val smtencoding_nl_arith_native : unit -> bool +val smtencoding_l_arith_default : unit -> bool +val smtencoding_l_arith_native : unit -> bool +val smtencoding_valid_intro : unit -> bool +val smtencoding_valid_elim : unit -> bool +val split_queries : unit -> split_queries_t +val tactic_raw_binders : unit -> bool +val tactics_failhard : unit -> bool +val tactics_info : unit -> bool +val tactic_trace : unit -> bool +val tactic_trace_d : unit -> int +val tactics_nbe : unit -> bool +val tcnorm : unit -> bool +val timing : unit -> bool +val trace_error : unit -> bool +val ugly : unit -> bool +val unthrottle_inductives : unit -> bool +val unsafe_tactic_exec : unit -> bool +val use_eq_at_higher_order : unit -> bool +val use_hints : unit -> bool +val use_hint_hashes : unit -> bool +val use_native_tactics : unit -> option string +val use_tactics : unit -> bool +val using_facts_from : unit -> list (list string & bool) +val warn_default_effects : unit -> bool +val with_saved_options : (unit -> 'a) -> 'a +val with_options : string -> (unit -> 'a) -> 'a +val z3_cliopt : unit -> list string +val z3_smtopt : unit -> list string +val z3_refresh : unit -> bool +val z3_rlimit : unit -> int +val z3_rlimit_factor : unit -> int +val z3_seed : unit -> int +val z3_version : unit -> string +val no_positivity : unit -> bool +val warn_error : unit -> string +val set_error_flags_callback : ((unit -> parse_cmdline_res) -> unit) +val use_nbe : unit -> bool +val use_nbe_for_extraction : unit -> bool +val trivial_pre_for_unannotated_effectful_fns + : unit -> bool + +(* List of enabled debug toggles. *) +val debug_keys : unit -> list string + +(* Whether we are debugging every module and not just the ones +in the cmdline. *) +val debug_all_modules : unit -> bool + +// HACK ALERT! This is to ensure we have no dependency from Options to Version, +// otherwise, since Version is regenerated all the time, this invalidates the +// whole build tree. A classy technique I learned from the OCaml compiler. +val _version: ref string +val _platform: ref string +val _compiler: ref string +val _date: ref string +val _commit: ref string + +val debug_embedding: ref bool +val eager_embedding: ref bool + +val get_vconfig : unit -> vconfig +val set_vconfig : vconfig -> unit + +instance val showable_codegen_t : Class.Show.showable codegen_t diff --git a/src/basic/FStarC.Platform.fsti b/src/basic/FStarC.Platform.fsti new file mode 100644 index 00000000000..c4644204328 --- /dev/null +++ b/src/basic/FStarC.Platform.fsti @@ -0,0 +1,12 @@ +module FStarC.Platform +open FStarC.Compiler.Effect + +type sys = +| Windows +| Posix + +val system : sys +val exe : string -> string + +(* true if the fstar compiler is compiled from sources extracted to ocaml, false otherwise *) +val is_fstar_compiler_using_ocaml : bool diff --git a/src/basic/FStarC.Profiling.fst b/src/basic/FStarC.Profiling.fst new file mode 100644 index 00000000000..a2e8e2e2390 --- /dev/null +++ b/src/basic/FStarC.Profiling.fst @@ -0,0 +1,125 @@ +(* + Copyright 2008-2019 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Profiling +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +module List = FStarC.Compiler.List +open FStarC.Options +module BU = FStarC.Compiler.Util +open FStarC.Json + +(* + A counter id is the name of a profiling phase; + The total_time is the cumulative time attributed to this phase. + The running flag records if this phase is currently being measured + The undercount field is set if the total time is known to be undercounted, + e.g., because an exception was raised +*) +type counter = { + cid:string; + total_time:ref int; + running:ref bool; + undercount:ref bool; +} + +let json_of_counter (c: counter) = + JsonAssoc [ + "id", JsonStr c.cid; + "total_time", JsonInt !c.total_time; + "running", JsonBool !c.running; + "undercount", JsonBool !c.undercount; + ] + +(* Creating a new counter *) +let new_counter cid = { + cid = cid; + total_time = BU.mk_ref 0; + running = BU.mk_ref false; + undercount = BU.mk_ref false; +} + +(* A table of all profiling counters, indexed by their cids *) +let all_counters : BU.smap counter = BU.smap_create 20 + +(* Returns the current counter for cid *) +let create_or_lookup_counter cid = + match BU.smap_try_find all_counters cid with + | Some c -> c + | None -> + let c = new_counter cid in + BU.smap_add all_counters cid c; + c + +(* Time an operation, if the the profiler is enabled *) +let profile (f: unit -> 'a) (module_name:option string) (cid:string) : 'a = + if Options.profile_enabled module_name cid + then let c = create_or_lookup_counter cid in + if !c.running //if the counter is already running + then f () //this is a re-entrant call ... don't measure + else begin + try + c.running := true; //mark the counter as running + let res, elapsed = BU.record_time f in + c.total_time := !c.total_time + elapsed; //accumulate the time + c.running := false; //finally mark the counter as not running + res + with + | e -> //finally + c.running := false; //mark the counter as not running + c.undercount := true; //but also set the undercount flag, + //since we didn't get the full elapsed time + raise e //and propagate the exception + end + else f() + +let report_json tag c = + let counter = json_of_counter c in + JsonAssoc [ + "tag", JsonStr tag; + "counter", counter; + ] |> string_of_json |> BU.print1_error "%s\n" + +let report_human tag c = + let warn = if !c.running + then " (Warning, this counter is still running)" + else if !c.undercount + then " (Warning, some operations raised exceptions and we not accounted for)" + else "" + in + //print each counter's profile + BU.print4 "%s, profiled %s:\t %s ms%s\n" + tag + c.cid + (BU.string_of_int (!c.total_time)) + warn + +let report tag c = + match FStarC.Options.message_format () with + | Human -> report_human tag c + | Json -> report_json tag c + +(* Report all profiles and clear all counters *) +let report_and_clear tag = + let ctrs = //all the counters as a list + BU.smap_fold all_counters (fun _ v l -> v :: l) [] + in + BU.smap_clear all_counters; //remove them all + let ctrs = //sort counters in descending order by elapsed time + BU.sort_with (fun c1 c2 -> !c2.total_time - !c1.total_time) ctrs + in + List.iter (report tag) ctrs diff --git a/src/basic/FStarC.Profiling.fsti b/src/basic/FStarC.Profiling.fsti new file mode 100644 index 00000000000..756616924fc --- /dev/null +++ b/src/basic/FStarC.Profiling.fsti @@ -0,0 +1,32 @@ +(* + Copyright 2008-2019 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Profiling +open FStarC.Compiler.Effect + +// When --profile module_name +// And --profile_component component_name +// are both true, measure the execution time of f +// and accumulate it in a profiling counter +// associated with `component_name` +val profile : f:(unit -> 'b) + -> module_name:option string + -> component_name:string + -> 'b + +// Print the elapsed time from all profiling counters +// Prefix the profiling report with the value of `tag` +// And reset all of the profiling counters +val report_and_clear: tag:string -> unit diff --git a/src/basic/FStarC.StringBuffer.fsti b/src/basic/FStarC.StringBuffer.fsti new file mode 100644 index 00000000000..42c918e7766 --- /dev/null +++ b/src/basic/FStarC.StringBuffer.fsti @@ -0,0 +1,34 @@ +(* + Copyright 2008-2019 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.StringBuffer + +open FStarC.Compiler.Effect +open FStarC.BigInt + +type t + +//This is a **MUTABLE** string buffer +//Although each function here returns a `t` the buffer is mutated in place. + +//The argument convention is chosen so that you can conveniently write code like: +// sb |> add "hello" |> add " world" |> add "!" + + +val create : FStarC.BigInt.t -> t +val add: string -> t -> t +val contents: t -> string +val clear: t -> t +val output_channel: FStarC.Compiler.Util.out_channel -> t -> unit diff --git a/src/basic/FStarC.Thunk.fst b/src/basic/FStarC.Thunk.fst new file mode 100644 index 00000000000..2673058f144 --- /dev/null +++ b/src/basic/FStarC.Thunk.fst @@ -0,0 +1,35 @@ +(* + Copyright 2008-2019 Microsoft Research + + Authors: Aseem Rastogi, Nikhil Swamy, Jonathan Protzenko + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Thunk +open FStarC.Compiler.Effect + +type thunk (a:Type) : Type = ref (either (unit -> a) a) + +let mk (f:unit -> 'a) : thunk 'a = alloc (Inl f) +let mkv (v:'a) : thunk 'a = alloc (Inr v) + +let force (t:thunk 'a) = + match !t with + | Inr a -> a + | Inl f -> + let a = f () in + t := Inr a; + a + +let map (f : 'a -> 'b) (t:thunk 'a) : thunk 'b = + mk (fun () -> f (force t)) diff --git a/src/basic/FStarC.Thunk.fsti b/src/basic/FStarC.Thunk.fsti new file mode 100644 index 00000000000..013f2dd8952 --- /dev/null +++ b/src/basic/FStarC.Thunk.fsti @@ -0,0 +1,32 @@ +(* + Copyright 2008-2019 Microsoft Research + + Authors: Aseem Rastogi, Nikhil Swamy, Jonathan Protzenko + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Thunk +open FStarC.Compiler.Effect + +val thunk (a:Type0) : Type0 +type t 'a = thunk 'a + +(* Creating thunks *) +val mk : (unit -> 'a) -> thunk 'a +val mkv : 'a -> thunk 'a + +(* Forcing *) +val force : thunk 'a -> 'a + +(* Mapping an operation over the thunk, lazily *) +val map : ('a -> 'b) -> thunk 'a -> thunk 'b diff --git a/src/basic/FStarC.Unionfind.fsti b/src/basic/FStarC.Unionfind.fsti new file mode 100644 index 00000000000..2b501dd6ee2 --- /dev/null +++ b/src/basic/FStarC.Unionfind.fsti @@ -0,0 +1,38 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Unionfind + +open FStarC.Compiler.Effect + +type puf 'a +type p_uvar 'a +val puf_empty: unit -> puf 'a +val puf_fresh: puf 'a -> 'a -> p_uvar 'a +val puf_id: puf 'a -> p_uvar 'a -> int +val puf_fromid: puf 'a -> int -> p_uvar 'a +val puf_find: puf 'a -> p_uvar 'a -> 'a +val puf_union: puf 'a -> p_uvar 'a -> p_uvar 'a -> puf 'a +val puf_equivalent: puf 'a -> p_uvar 'a -> p_uvar 'a -> bool +val puf_change: puf 'a -> p_uvar 'a -> 'a -> puf 'a +val puf_test: unit -> unit + +// +// Returns the unique id of the input uvar +// This is different from puf_id, that returns the +// unique id of the root of the uf tree that the input +// uvar belongs to +// +val puf_unique_id: p_uvar 'a -> int diff --git a/src/basic/FStarC.VConfig.fst b/src/basic/FStarC.VConfig.fst new file mode 100644 index 00000000000..90e33b9ab0a --- /dev/null +++ b/src/basic/FStarC.VConfig.fst @@ -0,0 +1,18 @@ +(* + Copyright 2008-2020 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.VConfig + +(* This file here to trigger extraction. *) diff --git a/src/basic/FStarC.VConfig.fsti b/src/basic/FStarC.VConfig.fsti new file mode 100644 index 00000000000..cb3a79de458 --- /dev/null +++ b/src/basic/FStarC.VConfig.fsti @@ -0,0 +1,55 @@ +(* + Copyright 2008-2018 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.VConfig + +(** This type represents the set of verification-relevant options used + to check a particular definition. It can be read from tactics via + sigelt_opts and set via the check_with attribute. + *) +type vconfig = { + initial_fuel : int; + max_fuel : int; + initial_ifuel : int; + max_ifuel : int; + detail_errors : bool; + detail_hint_replay : bool; + no_smt : bool; + quake_lo : int; + quake_hi : int; + quake_keep : bool; + retry : bool; + smtencoding_elim_box : bool; + smtencoding_nl_arith_repr : string; + smtencoding_l_arith_repr : string; + smtencoding_valid_intro : bool; + smtencoding_valid_elim : bool; + tcnorm : bool; + no_plugins : bool; + no_tactics : bool; + z3cliopt : list string; + z3smtopt : list string; + z3refresh : bool; + z3rlimit : int; + z3rlimit_factor : int; + z3seed : int; + z3version : string; + trivial_pre_for_unannotated_effectful_fns : bool; + reuse_hint_for : option string; +} + +(** Marker to check a sigelt with a particular vconfig, not really used internally.. *) +irreducible +let check_with (vcfg : vconfig) : unit = () diff --git a/src/basic/FStarC.Version.fsti b/src/basic/FStarC.Version.fsti new file mode 100644 index 00000000000..cec31cbae22 --- /dev/null +++ b/src/basic/FStarC.Version.fsti @@ -0,0 +1,19 @@ +(* + Copyright 2008-2014 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Version +open FStarC.Compiler.Effect + +val dummy: unit -> unit diff --git a/src/class/FStar.Class.Binders.fst b/src/class/FStar.Class.Binders.fst deleted file mode 100644 index da81f383375..00000000000 --- a/src/class/FStar.Class.Binders.fst +++ /dev/null @@ -1,31 +0,0 @@ -module FStar.Class.Binders - -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.Range -open FStar.Compiler.Util -open FStar.Compiler.FlatSet -open FStar.Syntax.Syntax -module F = FStar.Syntax.Free -open FStar.Errors -open FStar.Errors.Msg - -instance hasNames_term : hasNames term = { - freeNames = F.names; -} - -instance hasNames_comp : hasNames comp = { - freeNames = (fun c -> match c.n with - | Total t - | GTotal t -> F.names t - | Comp ct -> List.fold_left union (empty ()) - (F.names ct.result_typ :: (List.map (fun (a,_) -> F.names a) ct.effect_args))) -} - -instance hasBinders_list_bv = { - boundNames = from_list; -} - -instance hasBinders_set_bv = { - boundNames = id; -} diff --git a/src/class/FStar.Class.Binders.fsti b/src/class/FStar.Class.Binders.fsti deleted file mode 100644 index 2c4c13bbef7..00000000000 --- a/src/class/FStar.Class.Binders.fsti +++ /dev/null @@ -1,20 +0,0 @@ -module FStar.Class.Binders - -open FStar.Compiler.Util -open FStar.Compiler.FlatSet -open FStar.Syntax.Syntax - -(* TODO: should be for any setlike *) -class hasNames (a:Type) = { - freeNames : a -> flat_set bv; -} - -class hasBinders (a:Type) = { - boundNames : a -> flat_set bv; -} - -instance val hasNames_term : hasNames term -instance val hasNames_comp : hasNames comp - -instance val hasBinders_list_bv : hasBinders (list bv) -instance val hasBinders_set_bv : hasBinders (flat_set bv) diff --git a/src/class/FStar.Class.Deq.fst b/src/class/FStar.Class.Deq.fst deleted file mode 100644 index f029037c679..00000000000 --- a/src/class/FStar.Class.Deq.fst +++ /dev/null @@ -1,65 +0,0 @@ -module FStar.Class.Deq - -open FStar.Compiler.Effect - -let (<>?) x y = not (x =? y) - -instance deq_int : deq int = { - (=?) = (fun x y -> x = y); -} - -instance deq_bool : deq bool = { - (=?) = (fun x y -> x = y); -} - -instance deq_unit : deq unit = { - (=?) = (fun x y -> true); -} - -instance deq_string : deq string = { - (=?) = (fun x y -> x = y); -} - -instance deq_option #a (_ : deq a) : Tot (deq (option a)) = { - (=?) = (fun x y -> match x, y with - | None, None -> true - | Some x, Some y -> x =? y - | _, _ -> false) -} - -let rec eqList (#a : Type) (eq : deq a) (xs : list a) (ys : list a) : bool = - match xs, ys with - | [], [] -> true - | x::xs, y::ys -> x =? y && eqList #a eq xs ys - | _, _ -> false - -instance deq_list #a (d : deq a) : Tot (deq (list a)) = { - (=?) = eqList d -} - -instance deq_either #a #b (d1 : deq a) (d2 : deq b) : Tot (deq (either a b)) = { - (=?) = (fun x y -> match x, y with - | Inl x, Inl y -> x =? y - | Inr x, Inr y -> x =? y - | _, _ -> false) -} - -instance deq_tuple2 #a #b (d1 : deq a) (d2 : deq b) : Tot (deq (a & b)) = { - (=?) = (fun (x1, x2) (y1, y2) -> x1 =? y1 && x2 =? y2) -} - -instance deq_tuple3 #a #b #c (d1 : deq a) (d2 : deq b) (d3 : deq c) : Tot (deq (a & b & c)) = { - (=?) = (fun (x1, x2, x3) (y1, y2, y3) -> x1 =? y1 && x2 =? y2 && x3 =? y3) -} - -instance deq_tuple4 #a #b #c #d (d1 : deq a) (d2 : deq b) (d3 : deq c) (d4 : deq d) : Tot (deq (a & b & c & d)) = { - (=?) = (fun (x1, x2, x3, x4) (y1, y2, y3, y4) -> x1 =? y1 && x2 =? y2 && x3 =? y3 && x4 =? y4) -} - -instance deq_tuple5 #a #b #c #d #e (d1 : deq a) (d2 : deq b) (d3 : deq c) (d4 : deq d) (d5 : deq e) : Tot (deq (a & b & c & d & e)) = { - (=?) = (fun (x1, x2, x3, x4, x5) (y1, y2, y3, y4, y5) -> x1 =? y1 && x2 =? y2 && x3 =? y3 && x4 =? y4 && x5 =? y5) -} - -instance deq_tuple6 #a #b #c #d #e #f (d1 : deq a) (d2 : deq b) (d3 : deq c) (d4 : deq d) (d5 : deq e) (d6 : deq f) : Tot (deq (a & b & c & d & e & f)) = { - (=?) = (fun (x1, x2, x3, x4, x5, x6) (y1, y2, y3, y4, y5, y6) -> x1 =? y1 && x2 =? y2 && x3 =? y3 && x4 =? y4 && x5 =? y5 && x6 =? y6) -} diff --git a/src/class/FStar.Class.Deq.fsti b/src/class/FStar.Class.Deq.fsti deleted file mode 100644 index ae28930caac..00000000000 --- a/src/class/FStar.Class.Deq.fsti +++ /dev/null @@ -1,63 +0,0 @@ -module FStar.Class.Deq - -open FStar.Compiler.Effect - -class deq (a:Type) = { - (=?) : a -> a -> bool; -} - -val (<>?) : #a:Type -> {| deq a |} -> a -> a -> bool - -instance val deq_int : deq int -instance val deq_bool : deq bool -instance val deq_unit : deq unit -instance val deq_string : deq string - -instance val deq_option - (_ : deq 'a) -: Tot (deq (option 'a)) - -instance val deq_list - (_ : deq 'a) -: Tot (deq (list 'a)) - -instance val deq_either - (_ : deq 'a) - (_ : deq 'b) -: Tot (deq (either 'a 'b)) - -instance val deq_tuple2 - (_ : deq 'a) - (_ : deq 'b) -: Tot (deq ('a & 'b)) - -instance val deq_tuple3 - (_ : deq 'a) - (_ : deq 'b) - (_ : deq 'c) -: Tot (deq ('a & 'b & 'c)) - -instance val deq_tuple4 - (_ : deq 'a) - (_ : deq 'b) - (_ : deq 'c) - (_ : deq 'd) -: Tot (deq ('a & 'b & 'c & 'd)) - -instance val deq_tuple5 - (_ : deq 'a) - (_ : deq 'b) - (_ : deq 'c) - (_ : deq 'd) - (_ : deq 'e) -: Tot (deq ('a & 'b & 'c & 'd & 'e)) - -instance val deq_tuple6 - (_ : deq 'a) - (_ : deq 'b) - (_ : deq 'c) - (_ : deq 'd) - (_ : deq 'e) - (_ : deq 'f) -: Tot (deq ('a & 'b & 'c & 'd & 'e & 'f)) - diff --git a/src/class/FStar.Class.HasRange.fst b/src/class/FStar.Class.HasRange.fst deleted file mode 100644 index 0e8f93d3044..00000000000 --- a/src/class/FStar.Class.HasRange.fst +++ /dev/null @@ -1,8 +0,0 @@ -module FStar.Class.HasRange - -open FStar.Compiler.Range - -instance hasRange_range : hasRange range = { - pos = id; - setPos = (fun r _ -> r); // not really used -} \ No newline at end of file diff --git a/src/class/FStar.Class.HasRange.fsti b/src/class/FStar.Class.HasRange.fsti deleted file mode 100644 index 42b3f7f19bf..00000000000 --- a/src/class/FStar.Class.HasRange.fsti +++ /dev/null @@ -1,11 +0,0 @@ -module FStar.Class.HasRange - -open FStar.Compiler.Effect -open FStar.Compiler.Range - -class hasRange (a:Type) = { - pos : a -> range; - setPos : range -> a -> a; -} - -instance val hasRange_range : hasRange range \ No newline at end of file diff --git a/src/class/FStar.Class.Hashable.fst b/src/class/FStar.Class.Hashable.fst deleted file mode 100644 index 6a14d2509d8..00000000000 --- a/src/class/FStar.Class.Hashable.fst +++ /dev/null @@ -1,91 +0,0 @@ -module FStar.Class.Hashable - -open FStar -open FStar.Compiler -open FStar.Hash -open FStar.Class.Show -open FStar.Class.Deq -open FStar.Class.Ord - -instance showable_hash_code : showable hash_code = { - show = string_of_hash_code; -} - -instance eq_hash_code : deq hash_code = { - ( =? ) = (=); -} - -instance ord_hash_code : ord hash_code = { - super = FStar.Tactics.Typeclasses.solve; - cmp = (fun x y -> Order.order_from_int (cmp_hash x y)); -} - -instance hashable_int : hashable int = { hash = of_int; } -instance hashable_string : hashable string = { hash = of_string; } -instance hashable_bool : hashable bool = { - hash = (fun b -> if b then of_int 1 else of_int 2); -} - -instance hashable_list - (_ : hashable 'a) -: Tot (hashable (list 'a)) = { - hash = (fun xs -> List.fold_left (fun h x -> mix h (hash x)) (of_int 0) xs); -} - -instance hashable_option - (_ : hashable 'a) -: Tot (hashable (option 'a)) = { - hash = (fun x -> match x with None -> of_int 0 | Some x -> mix (of_int 1) (hash x)); -} - -instance hashable_either - (_ : hashable 'a) - (_ : hashable 'b) -: Tot (hashable (either 'a 'b)) = { - hash = (fun x -> match x with Inl a -> mix (of_int 0) (hash a) | Inr b -> mix (of_int 1) (hash b)); -} - -instance hashable_tuple2 - (_ : hashable 'a) - (_ : hashable 'b) -: Tot (hashable ('a & 'b)) = { - hash = (fun (a, b) -> hash a `mix` hash b); -} - -instance hashable_tuple3 - (_ : hashable 'a) - (_ : hashable 'b) - (_ : hashable 'c) -: Tot (hashable ('a & 'b & 'c)) = { - hash = (fun (a, b, c) -> hash a `mix` hash b `mix` hash c); -} - -instance hashable_tuple4 - (_ : hashable 'a) - (_ : hashable 'b) - (_ : hashable 'c) - (_ : hashable 'd) -: Tot (hashable ('a & 'b & 'c & 'd)) = { - hash = (fun (a, b, c, d) -> hash a `mix` hash b `mix` hash c `mix` hash d); -} - -instance hashable_tuple5 - (_ : hashable 'a) - (_ : hashable 'b) - (_ : hashable 'c) - (_ : hashable 'd) - (_ : hashable 'e) -: Tot (hashable ('a & 'b & 'c & 'd & 'e)) = { - hash = (fun (a, b, c, d, e) -> hash a `mix` hash b `mix` hash c `mix` hash d `mix` hash e); -} - -instance hashable_tuple6 - (_ : hashable 'a) - (_ : hashable 'b) - (_ : hashable 'c) - (_ : hashable 'd) - (_ : hashable 'e) - (_ : hashable 'f) -: Tot (hashable ('a & 'b & 'c & 'd & 'e & 'f)) = { - hash = (fun (a, b, c, d, e, f) -> hash a `mix` hash b `mix` hash c `mix` hash d `mix` hash e `mix` hash f); -} diff --git a/src/class/FStar.Class.Hashable.fsti b/src/class/FStar.Class.Hashable.fsti deleted file mode 100644 index 56200545f22..00000000000 --- a/src/class/FStar.Class.Hashable.fsti +++ /dev/null @@ -1,68 +0,0 @@ -module FStar.Class.Hashable - -open FStar.Hash -include FStar.Hash -open FStar.Class.Show -open FStar.Class.Deq -open FStar.Class.Ord - -class hashable (a:Type) = { - hash : a -> hash_code; -} - -(* Properties about hash_code, better moved elsewhere. *) -instance val showable_hash_code : showable hash_code -instance val eq_hash_code : deq hash_code -instance val ord_hash_code : ord hash_code - -instance val hashable_int : hashable int -instance val hashable_string : hashable string -instance val hashable_bool : hashable bool - -instance val hashable_list - (_ : hashable 'a) -: Tot (hashable (list 'a)) - -instance val hashable_option - (_ : hashable 'a) -: Tot (hashable (option 'a)) - -instance val hashable_either - (_ : hashable 'a) - (_ : hashable 'b) -: Tot (hashable (either 'a 'b)) - -instance val hashable_tuple2 - (_ : hashable 'a) - (_ : hashable 'b) -: Tot (hashable ('a & 'b)) - -instance val hashable_tuple3 - (_ : hashable 'a) - (_ : hashable 'b) - (_ : hashable 'c) -: Tot (hashable ('a & 'b & 'c)) - -instance val hashable_tuple4 - (_ : hashable 'a) - (_ : hashable 'b) - (_ : hashable 'c) - (_ : hashable 'd) -: Tot (hashable ('a & 'b & 'c & 'd)) - -instance val hashable_tuple5 - (_ : hashable 'a) - (_ : hashable 'b) - (_ : hashable 'c) - (_ : hashable 'd) - (_ : hashable 'e) -: Tot (hashable ('a & 'b & 'c & 'd & 'e)) - -instance val hashable_tuple6 - (_ : hashable 'a) - (_ : hashable 'b) - (_ : hashable 'c) - (_ : hashable 'd) - (_ : hashable 'e) - (_ : hashable 'f) -: Tot (hashable ('a & 'b & 'c & 'd & 'e & 'f)) diff --git a/src/class/FStar.Class.Listlike.fst b/src/class/FStar.Class.Listlike.fst deleted file mode 100644 index 7de91fdc65e..00000000000 --- a/src/class/FStar.Class.Listlike.fst +++ /dev/null @@ -1,21 +0,0 @@ -module FStar.Class.Listlike - -open FStar.Compiler.Effect - -let is_empty (#e #s : Type) {| listlike e s |} (l : s) : bool = - match view l with - | VNil -> true - | VCons _ _ -> false - -let singleton (#e #s : Type) {| listlike e s |} (x : e) : s = - cons x empty - -let rec to_list (#e #s : Type) {| listlike e s |} (l : s) : list e = - match view l with - | VNil -> [] - | VCons x xs -> x :: to_list xs - -let rec from_list (#e #s : Type) {| listlike e s |} (l : list e) : s = - match l with - | [] -> empty - | x :: xs -> cons x (from_list xs) diff --git a/src/class/FStar.Class.Listlike.fsti b/src/class/FStar.Class.Listlike.fsti deleted file mode 100644 index 63f60c9aa24..00000000000 --- a/src/class/FStar.Class.Listlike.fsti +++ /dev/null @@ -1,22 +0,0 @@ -module FStar.Class.Listlike - -open FStar.Compiler.Effect - -type view_t e s = - | VNil : view_t e s - | VCons : e -> s -> view_t e s - -[@@Tactics.Typeclasses.fundeps [0]] -class listlike (e:Type) (s:Type) = { - empty : s; - cons : e -> s -> s; - view : s -> view_t e s; -} - -val is_empty (#e #s : Type) {| listlike e s |} (l : s) : bool - -val singleton (#e #s : Type) {| listlike e s |} (x : e) : s - -val to_list (#e #s : Type) {| listlike e s |} (l : s) : list e - -val from_list (#e #s : Type) {| listlike e s |} (l : list e) : s diff --git a/src/class/FStar.Class.Monad.fst b/src/class/FStar.Class.Monad.fst deleted file mode 100644 index f71cfcef40c..00000000000 --- a/src/class/FStar.Class.Monad.fst +++ /dev/null @@ -1,75 +0,0 @@ -module FStar.Class.Monad - -open FStar.Compiler -open FStar.Compiler.Effect - -instance monad_option : monad option = { - return = (fun x -> Some x); // FIXME: without the we gell ill-typed ML - ( let! ) = Util.bind_opt; -} - -instance monad_list : monad list = { - return = (fun x -> [x]); - ( let! ) = (fun x f -> List.concatMap f x) -} - -let rec mapM f l = - match l with - | [] -> return [] - | x::xs -> - let! y = f x in - let! ys = mapM f xs in - return (y::ys) - -let mapMi #m #_ #a #b f l = - (* FIXME: need to annotate the return type, why? *) - let rec mapMi_go i f l : m (list b) = - match l with - | [] -> return [] - | x::xs -> - let! y = f i x in - let! ys = mapMi_go (i+1) f xs in - return (y::ys) - in - mapMi_go 0 f l - -let map_optM f l = - match l with - | None -> return None - | Some x -> - let! x = f x in - return (Some x) - -let rec iterM f l = - match l with - | [] -> return () - | x::xs -> - f x;! - iterM f xs - -let rec foldM_left f e xs = - match xs with - | [] -> return e - | x::xs -> - let! e' = f e x in - foldM_left f e' xs - -let rec foldM_right f xs e = - match xs with - | [] -> return e - | x::xs -> - let! e' = foldM_right f xs e in - f x e' - -let (<$>) f x = - let! v = x in - return (f v) - -let (<*>) ff x = - let! f = ff in - let! v = x in - return (f v) - -let fmap f m = - let! v = m in - return (f v) diff --git a/src/class/FStar.Class.Monad.fsti b/src/class/FStar.Class.Monad.fsti deleted file mode 100644 index 8fd10374c4d..00000000000 --- a/src/class/FStar.Class.Monad.fsti +++ /dev/null @@ -1,67 +0,0 @@ -module FStar.Class.Monad - -open FStar.Compiler -open FStar.Compiler.Effect - -class monad (m : Type -> Type) = { - return : #a:Type -> a -> m a; - ( let! ) : #a:Type -> #b:Type -> m a -> (a -> m b) -> m b -} - -instance val monad_option : monad option -instance val monad_list : monad list - -val mapM - (#m: Type -> Type) - {| monad m |} - (#a #b :Type) -: (a -> m b) -> list a -> m (list b) - -val mapMi - (#m: Type -> Type) - {| monad m |} - (#a #b :Type) -: (int -> a -> m b) -> list a -> m (list b) - -val map_optM - (#m: Type -> Type) - {| monad m |} - (#a #b :Type) -: (a -> m b) -> option a -> m (option b) - -val iterM - (#m: Type -> Type) - {| monad m |} - (#a :Type) -: (a -> m unit) -> list a -> m unit - -val foldM_left - (#m: Type -> Type) - {| monad m |} - (#a #b :Type) -: (a -> b -> m a) -> a -> list b -> m a - -val foldM_right - (#m: Type -> Type) - {| monad m |} - (#a #b :Type) -: (a -> b -> m b) -> list a -> b -> m b - -val (<$>) - (#m: Type -> Type) - {| monad m |} - (#a #b :Type) -: (a -> b) -> m a -> m b - -val (<*>) - (#m: Type -> Type) - {| monad m |} - (#a #b :Type) -: m (a -> b) -> m a -> m b - -val fmap - (#m: Type -> Type) - {| monad m |} - (#a #b :Type) - (f : a -> b) -: m a -> m b diff --git a/src/class/FStar.Class.Monoid.fst b/src/class/FStar.Class.Monoid.fst deleted file mode 100644 index a09ffd80794..00000000000 --- a/src/class/FStar.Class.Monoid.fst +++ /dev/null @@ -1,33 +0,0 @@ -module FStar.Class.Monoid - -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.List - -let ( ++ ) #a {| monoid a |} = mplus #a - -let msum xs = fold_left mplus mzero xs - -instance monoid_int : monoid int = { - mzero = 0; - mplus = (fun x y -> x + y); -} - -instance monoid_string : monoid string = { - mzero = ""; - mplus = (fun x y -> x ^ y); -} - -instance monoid_list (a:Type) : Tot (monoid (list a)) = { - mzero = []; - mplus = (fun x y -> x @ y); -} - -(* Funny output from Copilot... not bad! - -instance monoid_effect (a:Type) (e:effect) : monoid (a!e) = { - mzero = return mzero; - mplus = (fun x y -> x >>= (fun x -> y >>= (fun y -> return (mplus x y)))); -} - -*) diff --git a/src/class/FStar.Class.Monoid.fsti b/src/class/FStar.Class.Monoid.fsti deleted file mode 100644 index 838d2abd0f4..00000000000 --- a/src/class/FStar.Class.Monoid.fsti +++ /dev/null @@ -1,19 +0,0 @@ -module FStar.Class.Monoid - -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.List - -class monoid (a:Type) = { - mzero : a; - mplus : a -> a -> a; -} - -(* Alias *) -val ( ++ ) (#a:Type) {| monoid a |} : a -> a -> a - -val msum (#a:Type) {| monoid a |} (xs:list a) : a - -instance val monoid_int : monoid int -instance val monoid_string : monoid string -instance val monoid_list (a:Type) : Tot (monoid (list a)) diff --git a/src/class/FStar.Class.Ord.fst b/src/class/FStar.Class.Ord.fst deleted file mode 100644 index 5f55c4fcb61..00000000000 --- a/src/class/FStar.Class.Ord.fst +++ /dev/null @@ -1,120 +0,0 @@ -module FStar.Class.Ord - -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Tactics.Typeclasses - -let ( Gt -let (>?) x y = cmp x y = Gt -let (>=?) x y = cmp x y <> Lt - -let min x y = if x <=? y then x else y -let max x y = if x >=? y then x else y - -instance ord_eq (a:Type) (d : ord a) : Tot (deq a) = d.super - -let rec insert (#a:Type) {| ord a |} (x:a) (xs:list a) : list a = - match xs with - | [] -> [x] - | y::ys -> if x <=? y then x :: y :: ys else y :: insert x ys - -let rec sort xs = - match xs with - | [] -> [] - | x::xs -> insert x (sort xs) - -let dedup #a xs = - let open FStar.Compiler.List in - let out = fold_left (fun out x -> if existsb (fun y -> x =? y) out then out else x :: out) [] xs in - List.rev out - -instance ord_int : ord int = { - super = solve; - cmp = compare_int; -} - -instance ord_bool : ord bool = { - super = solve; - cmp = compare_bool; -} - -instance ord_unit : ord unit = { - super = solve; - cmp = (fun _ _ -> Eq); -} - -instance ord_string : ord string = { - super = solve; - cmp = (fun x y -> order_from_int (String.compare x y)); -} - -instance ord_option #a (d : ord a) : Tot (ord (option a)) = { - super = solve; - cmp = (fun x y -> match x, y with - | None, None -> Eq - | Some _, None -> Gt - | None, Some _ -> Lt - | Some x, Some y -> cmp x y - ); -} - -instance ord_list #a (d : ord a) : Tot (ord (list a)) = { - super = solve; - cmp = (fun l1 l2 -> compare_list l1 l2 cmp); -} - -instance ord_either #a #b (d1 : ord a) (d2 : ord b) : Tot (ord (either a b)) = { - super = solve; - cmp = (fun x y -> match x, y with - | Inl _, Inr _ -> Lt - | Inr _, Inl _ -> Gt - | Inl x, Inl y -> cmp x y - | Inr x, Inr y -> cmp x y - ); -} - -instance ord_tuple2 #a #b (d1 : ord a) (d2 : ord b) : Tot (ord (a & b)) = { - super = solve; - cmp = (fun (x1, x2) (y1, y2) -> - lex (cmp x1 y1) (fun () -> - cmp x2 y2)); -} - -instance ord_tuple3 #a #b #c (d1 : ord a) (d2 : ord b) (d3 : ord c): Tot (ord (a & b & c)) = { - super = solve; - cmp = (fun (x1, x2, x3) (y1, y2, y3) -> - lex (cmp x1 y1) (fun () -> - lex (cmp x2 y2) (fun () -> - cmp x3 y3))); -} - -instance ord_tuple4 #a #b #c #d (d1 : ord a) (d2 : ord b) (d3 : ord c) (d4 : ord d): Tot (ord (a & b & c & d)) = { - super = solve; - cmp = (fun (x1, x2, x3, x4) (y1, y2, y3, y4) -> - lex (cmp x1 y1) (fun () -> - lex (cmp x2 y2) (fun () -> - lex (cmp x3 y3) (fun () -> - cmp x4 y4)))); -} - -instance ord_tuple5 #a #b #c #d #e (d1 : ord a) (d2 : ord b) (d3 : ord c) (d4 : ord d) (d5 : ord e): Tot (ord (a & b & c & d & e)) = { - super = solve; - cmp = (fun (x1, x2, x3, x4, x5) (y1, y2, y3, y4, y5) -> - lex (cmp x1 y1) (fun () -> - lex (cmp x2 y2) (fun () -> - lex (cmp x3 y3) (fun () -> - lex (cmp x4 y4) (fun () -> - cmp x5 y5))))); -} - -instance ord_tuple6 #a #b #c #d #e #f (d1 : ord a) (d2 : ord b) (d3 : ord c) (d4 : ord d) (d5 : ord e) (d6 : ord f): Tot (ord (a & b & c & d & e & f)) = { - super = solve; - cmp = (fun (x1, x2, x3, x4, x5, x6) (y1, y2, y3, y4, y5, y6) -> - lex (cmp x1 y1) (fun () -> - lex (cmp x2 y2) (fun () -> - lex (cmp x3 y3) (fun () -> - lex (cmp x4 y4) (fun () -> - lex (cmp x5 y5) (fun () -> - cmp x6 y6)))))); -} diff --git a/src/class/FStar.Class.Ord.fsti b/src/class/FStar.Class.Ord.fsti deleted file mode 100644 index 01741c478c8..00000000000 --- a/src/class/FStar.Class.Ord.fsti +++ /dev/null @@ -1,86 +0,0 @@ -module FStar.Class.Ord - -open FStar.Compiler.Effect -open FStar.Compiler.Order -include FStar.Class.Deq -open FStar.Class.Deq - -class ord (a:Type) = { - super : deq a; - cmp : a -> a -> order; -} - -val sort - (#a:Type) {| ord a |} - (xs : list a) - : list a - -(* Deduplicate elements, preserving order as determined by the leftmost -occurrence. So dedup [a,b,c,a,f,e,c] = [a,b,c,f,e] *) -val dedup - (#a:Type) {| ord a |} - (xs : list a) - : list a - -instance val ord_eq (a:Type) (d : ord a) : Tot (deq a) - -val ( {| ord a |} -> a -> a -> bool -val (<=?) : #a:Type -> {| ord a |} -> a -> a -> bool -val (>?) : #a:Type -> {| ord a |} -> a -> a -> bool -val (>=?) : #a:Type -> {| ord a |} -> a -> a -> bool - -val min : #a:Type -> {| ord a |} -> a -> a -> a -val max : #a:Type -> {| ord a |} -> a -> a -> a - -instance val ord_int : ord int -instance val ord_bool : ord bool -instance val ord_unit : ord unit -instance val ord_string : ord string - -instance val ord_option - (_ : ord 'a) -: Tot (ord (option 'a)) - -instance val ord_list - (_ : ord 'a) -: Tot (ord (list 'a)) - -instance val ord_either - (_ : ord 'a) - (_ : ord 'b) -: Tot (ord (either 'a 'b)) - -instance val ord_tuple2 - (_ : ord 'a) - (_ : ord 'b) -: Tot (ord ('a & 'b)) - -instance val ord_tuple3 - (_ : ord 'a) - (_ : ord 'b) - (_ : ord 'c) -: Tot (ord ('a & 'b & 'c)) - -instance val ord_tuple4 - (_ : ord 'a) - (_ : ord 'b) - (_ : ord 'c) - (_ : ord 'd) -: Tot (ord ('a & 'b & 'c & 'd)) - -instance val ord_tuple5 - (_ : ord 'a) - (_ : ord 'b) - (_ : ord 'c) - (_ : ord 'd) - (_ : ord 'e) -: Tot (ord ('a & 'b & 'c & 'd & 'e)) - -instance val ord_tuple6 - (_ : ord 'a) - (_ : ord 'b) - (_ : ord 'c) - (_ : ord 'd) - (_ : ord 'e) - (_ : ord 'f) -: Tot (ord ('a & 'b & 'c & 'd & 'e & 'f)) diff --git a/src/class/FStar.Class.PP.fst b/src/class/FStar.Class.PP.fst deleted file mode 100644 index 88a6cf81203..00000000000 --- a/src/class/FStar.Class.PP.fst +++ /dev/null @@ -1,95 +0,0 @@ -module FStar.Class.PP - -open FStar.Compiler.Effect -open FStar.Pprint - -let gparens a = group (nest 2 (parens a)) -let gbrackets a = group (nest 2 (brackets a)) - -instance pp_unit = { - pp = (fun _ -> doc_of_string "()"); -} - -instance pp_int = { - pp = (fun x -> doc_of_string (string_of_int x)); -} - -instance pp_bool = { - pp = doc_of_bool; -} - -instance pp_list (a:Type) (_ : pretty a) : Tot (pretty (list a)) = { - pp = (fun l -> gbrackets (flow_map (semi ^^ break_ 1) pp l)); -} - -instance pp_option (a:Type) (_ : pretty a) : Tot (pretty (option a)) = { - pp = (fun o -> match o with - | Some v -> group (nest 2 (doc_of_string "Some" ^/^ pp v)) - | None -> doc_of_string "None"); -} - -instance pp_either (_ : pretty 'a) (_ : pretty 'b) = { - pp = (fun e -> group (nest 2 (match e with - | Inl x -> doc_of_string "Inl" ^/^ pp x - | Inr x -> doc_of_string "Inr" ^/^ pp x))); -} - -let comma_space = comma ^^ break_ 1 - -instance pp_tuple2 - (_ : pretty 'a) - (_ : pretty 'b) -= { - pp = (fun (x1, x2) -> - gparens (separate comma_space [pp x1; pp x2])); -} - -instance pp_tuple3 - (_ : pretty 'a) - (_ : pretty 'b) - (_ : pretty 'c) -= { - pp = (fun (x1, x2, x3) -> - gparens (separate comma_space [pp x1; pp x2; pp x3])); -} - -instance pp_tuple4 - (_ : pretty 'a) - (_ : pretty 'b) - (_ : pretty 'c) - (_ : pretty 'd) -= { - pp = (fun (x1, x2, x3, x4) -> - gparens (separate comma_space [pp x1; pp x2; pp x3; pp x4])); -} - -instance pp_tuple5 - (_ : pretty 'a) - (_ : pretty 'b) - (_ : pretty 'c) - (_ : pretty 'd) - (_ : pretty 'e) -= { - pp = (fun (x1, x2, x3, x4, x5) -> - gparens (separate comma_space [pp x1; pp x2; pp x3; pp x4; pp x5])); -} - -instance pp_tuple6 - (_ : pretty 'a) - (_ : pretty 'b) - (_ : pretty 'c) - (_ : pretty 'd) - (_ : pretty 'e) - (_ : pretty 'f) -= { - pp = (fun (x1, x2, x3, x4, x5, x6) -> - gparens (separate comma_space [pp x1; pp x2; pp x3; pp x4; pp x5; pp x6])); -} - -let pretty_from_showable (#a:Type) {| _ : Class.Show.showable a |} : Tot (pretty a) = { - pp = (fun x -> arbitrary_string (Class.Show.show x)); -} - -let showable_from_pretty (#a:Type) {| _ : pretty a |} : Tot (Class.Show.showable a) = { - show = (fun x -> render (pp x)); -} diff --git a/src/class/FStar.Class.PP.fsti b/src/class/FStar.Class.PP.fsti deleted file mode 100644 index cbeccc496e9..00000000000 --- a/src/class/FStar.Class.PP.fsti +++ /dev/null @@ -1,65 +0,0 @@ -module FStar.Class.PP - -open FStar.Compiler.Effect -open FStar.Pprint - -class pretty (a:Type) = { - pp : a -> ML document; -} - -instance val pp_unit : pretty unit -instance val pp_int : pretty int -instance val pp_bool : pretty bool -//instance val pp_char : pretty char - -(* We intentionally do not add a `pretty string` instance, as there -are many differenta ways of pprinting a string (doc_of_string, text, -arbitrary_string). *) - -instance val pp_list (a:Type) (_ : pretty a) : Tot (pretty (list a)) - -instance val pp_option (a:Type) (_ : pretty a) : Tot (pretty (option a)) - -instance val pp_either - (_ : pretty 'a) - (_ : pretty 'b) -: Tot (pretty (either 'a 'b)) - -instance val pp_tuple2 - (_ : pretty 'a) - (_ : pretty 'b) -: Tot (pretty ('a & 'b)) - -instance val pp_tuple3 - (_ : pretty 'a) - (_ : pretty 'b) - (_ : pretty 'c) -: Tot (pretty ('a & 'b & 'c)) - -instance val pp_tuple4 - (_ : pretty 'a) - (_ : pretty 'b) - (_ : pretty 'c) - (_ : pretty 'd) -: Tot (pretty ('a & 'b & 'c & 'd)) - -instance val pp_tuple5 - (_ : pretty 'a) - (_ : pretty 'b) - (_ : pretty 'c) - (_ : pretty 'd) - (_ : pretty 'e) -: Tot (pretty ('a & 'b & 'c & 'd & 'e)) - -instance val pp_tuple6 - (_ : pretty 'a) - (_ : pretty 'b) - (_ : pretty 'c) - (_ : pretty 'd) - (_ : pretty 'e) - (_ : pretty 'f) -: Tot (pretty ('a & 'b & 'c & 'd & 'e & 'f)) - -val pretty_from_showable (#a:Type) {| _ : Show.showable a |} : Tot (pretty a) - -val showable_from_pretty (#a:Type) {| _ : pretty a |} : Tot (Show.showable a) diff --git a/src/class/FStar.Class.Setlike.fst b/src/class/FStar.Class.Setlike.fst deleted file mode 100644 index ab9963f178c..00000000000 --- a/src/class/FStar.Class.Setlike.fst +++ /dev/null @@ -1,6 +0,0 @@ -module FStar.Class.Setlike - -open FStar.Compiler.Effect -open FStar.Class.Ord - -let symdiff s1 s2 = diff s1 s2 diff --git a/src/class/FStar.Class.Setlike.fsti b/src/class/FStar.Class.Setlike.fsti deleted file mode 100644 index edfa7d4b8e2..00000000000 --- a/src/class/FStar.Class.Setlike.fsti +++ /dev/null @@ -1,28 +0,0 @@ -module FStar.Class.Setlike - -open FStar.Compiler.Effect -open FStar.Class.Ord - -[@@Tactics.Typeclasses.fundeps [0]] -class setlike (e:Type) (s:Type) = { - empty : unit -> s; - singleton : e -> s; - is_empty : s -> bool; - add : e -> s -> s; - remove : e -> s -> s; - mem : e -> s -> bool; - equal : s -> s -> bool; - subset : s -> s -> bool; - union : s -> s -> s; - inter : s -> s -> s; - diff : s -> s -> s; - for_all : (e -> bool) -> s -> bool; - for_any : (e -> bool) -> s -> bool; - elems : s -> list e; - - collect : (e -> s) -> list e -> s; - from_list : list e -> s; - addn : list e -> s -> s; -} - -val symdiff (#e #s : Type) {| setlike e s |} : s -> s -> s diff --git a/src/class/FStar.Class.Show.fst b/src/class/FStar.Class.Show.fst deleted file mode 100644 index 51670f11ea3..00000000000 --- a/src/class/FStar.Class.Show.fst +++ /dev/null @@ -1,89 +0,0 @@ -module FStar.Class.Show - -open FStar.Compiler.Effect -open FStar.Class.Printable - -instance printableshow (_ : printable 'a) : Tot (showable 'a) = { - show = to_string; -} - -instance show_list (a:Type) (_ : showable a) : Tot (showable (list a)) = { - show = FStar.Common.string_of_list show; -} - -instance show_option (a:Type) (_ : showable a) : Tot (showable (option a)) = { - show = FStar.Common.string_of_option show; -} - -instance show_either - (_ : showable 'a) - (_ : showable 'b) -= { - show = (function Inl x -> "Inl " ^ show x - | Inr y -> "Inr " ^ show y); -} - -instance show_tuple2 - (_ : showable 'a) - (_ : showable 'b) -= { - show = (fun (x1, x2) -> "(" - ^ show x1 ^ ", " - ^ show x2 ^ ")"); -} - -instance show_tuple3 - (_ : showable 'a) - (_ : showable 'b) - (_ : showable 'c) -= { - show = (fun (x1, x2, x3) -> "(" - ^ show x1 ^ ", " - ^ show x2 ^ ", " - ^ show x3 ^ ")"); -} - -instance show_tuple4 - (_ : showable 'a) - (_ : showable 'b) - (_ : showable 'c) - (_ : showable 'd) -= { - show = (fun (x1, x2, x3, x4) -> "(" - ^ show x1 ^ ", " - ^ show x2 ^ ", " - ^ show x3 ^ ", " - ^ show x4 ^ ")"); -} - -instance show_tuple5 - (_ : showable 'a) - (_ : showable 'b) - (_ : showable 'c) - (_ : showable 'd) - (_ : showable 'e) -= { - show = (fun (x1, x2, x3, x4, x5) -> "(" - ^ show x1 ^ ", " - ^ show x2 ^ ", " - ^ show x3 ^ ", " - ^ show x4 ^ ", " - ^ show x5 ^ ")"); -} - -instance show_tuple6 - (_ : showable 'a) - (_ : showable 'b) - (_ : showable 'c) - (_ : showable 'd) - (_ : showable 'e) - (_ : showable 'f) -= { - show = (fun (x1, x2, x3, x4, x5, x6) -> "(" - ^ show x1 ^ ", " - ^ show x2 ^ ", " - ^ show x3 ^ ", " - ^ show x4 ^ ", " - ^ show x5 ^ ", " - ^ show x6 ^ ")"); -} diff --git a/src/class/FStar.Class.Show.fsti b/src/class/FStar.Class.Show.fsti deleted file mode 100644 index 882515455e7..00000000000 --- a/src/class/FStar.Class.Show.fsti +++ /dev/null @@ -1,57 +0,0 @@ -module FStar.Class.Show - -open FStar.Compiler.Effect -open FStar.Class.Printable -module BU = FStar.Compiler.Util - -class showable (a:Type) = { - show : a -> ML string; -} - -(* This extends the printable class from ulib, but also allows for an -ML effect of the `printer. *) -instance val printableshow (_ : printable 'a) : Tot (showable 'a) - -instance val show_list (a:Type) (_ : showable a) : Tot (showable (list a)) - -instance val show_option (a:Type) (_ : showable a) : Tot (showable (option a)) - -instance val show_either - (_ : showable 'a) - (_ : showable 'b) -: Tot (showable (either 'a 'b)) - -instance val show_tuple2 - (_ : showable 'a) - (_ : showable 'b) -: Tot (showable ('a & 'b)) - -instance val show_tuple3 - (_ : showable 'a) - (_ : showable 'b) - (_ : showable 'c) -: Tot (showable ('a & 'b & 'c)) - -instance val show_tuple4 - (_ : showable 'a) - (_ : showable 'b) - (_ : showable 'c) - (_ : showable 'd) -: Tot (showable ('a & 'b & 'c & 'd)) - -instance val show_tuple5 - (_ : showable 'a) - (_ : showable 'b) - (_ : showable 'c) - (_ : showable 'd) - (_ : showable 'e) -: Tot (showable ('a & 'b & 'c & 'd & 'e)) - -instance val show_tuple6 - (_ : showable 'a) - (_ : showable 'b) - (_ : showable 'c) - (_ : showable 'd) - (_ : showable 'e) - (_ : showable 'f) -: Tot (showable ('a & 'b & 'c & 'd & 'e & 'f)) diff --git a/src/class/FStar.Class.Tagged.fst b/src/class/FStar.Class.Tagged.fst deleted file mode 100644 index 92efe287cfd..00000000000 --- a/src/class/FStar.Class.Tagged.fst +++ /dev/null @@ -1 +0,0 @@ -module FStar.Class.Tagged diff --git a/src/class/FStar.Class.Tagged.fsti b/src/class/FStar.Class.Tagged.fsti deleted file mode 100644 index f2a5bb5ed50..00000000000 --- a/src/class/FStar.Class.Tagged.fsti +++ /dev/null @@ -1,9 +0,0 @@ -module FStar.Class.Tagged - -open FStar.Compiler.Effect - -(* This class is meant to print the constructor of a term. -It replaces tag_of_term and tag_of_sigelt. *) -class tagged (a:Type) = { - tag_of : a -> ML string; -} diff --git a/src/class/FStarC.Class.Binders.fst b/src/class/FStarC.Class.Binders.fst new file mode 100644 index 00000000000..9668db359e0 --- /dev/null +++ b/src/class/FStarC.Class.Binders.fst @@ -0,0 +1,31 @@ +module FStarC.Class.Binders + +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.Range +open FStarC.Compiler.Util +open FStarC.Compiler.FlatSet +open FStarC.Syntax.Syntax +module F = FStarC.Syntax.Free +open FStarC.Errors +open FStarC.Errors.Msg + +instance hasNames_term : hasNames term = { + freeNames = F.names; +} + +instance hasNames_comp : hasNames comp = { + freeNames = (fun c -> match c.n with + | Total t + | GTotal t -> F.names t + | Comp ct -> List.fold_left union (empty ()) + (F.names ct.result_typ :: (List.map (fun (a,_) -> F.names a) ct.effect_args))) +} + +instance hasBinders_list_bv = { + boundNames = from_list; +} + +instance hasBinders_set_bv = { + boundNames = id; +} diff --git a/src/class/FStarC.Class.Binders.fsti b/src/class/FStarC.Class.Binders.fsti new file mode 100644 index 00000000000..855967c9c7e --- /dev/null +++ b/src/class/FStarC.Class.Binders.fsti @@ -0,0 +1,20 @@ +module FStarC.Class.Binders + +open FStarC.Compiler.Util +open FStarC.Compiler.FlatSet +open FStarC.Syntax.Syntax + +(* TODO: should be for any setlike *) +class hasNames (a:Type) = { + freeNames : a -> flat_set bv; +} + +class hasBinders (a:Type) = { + boundNames : a -> flat_set bv; +} + +instance val hasNames_term : hasNames term +instance val hasNames_comp : hasNames comp + +instance val hasBinders_list_bv : hasBinders (list bv) +instance val hasBinders_set_bv : hasBinders (flat_set bv) diff --git a/src/class/FStarC.Class.Deq.fst b/src/class/FStarC.Class.Deq.fst new file mode 100644 index 00000000000..e1720918730 --- /dev/null +++ b/src/class/FStarC.Class.Deq.fst @@ -0,0 +1,65 @@ +module FStarC.Class.Deq + +open FStarC.Compiler.Effect + +let (<>?) x y = not (x =? y) + +instance deq_int : deq int = { + (=?) = (fun x y -> x = y); +} + +instance deq_bool : deq bool = { + (=?) = (fun x y -> x = y); +} + +instance deq_unit : deq unit = { + (=?) = (fun x y -> true); +} + +instance deq_string : deq string = { + (=?) = (fun x y -> x = y); +} + +instance deq_option #a (_ : deq a) : Tot (deq (option a)) = { + (=?) = (fun x y -> match x, y with + | None, None -> true + | Some x, Some y -> x =? y + | _, _ -> false) +} + +let rec eqList (#a : Type) (eq : deq a) (xs : list a) (ys : list a) : bool = + match xs, ys with + | [], [] -> true + | x::xs, y::ys -> x =? y && eqList #a eq xs ys + | _, _ -> false + +instance deq_list #a (d : deq a) : Tot (deq (list a)) = { + (=?) = eqList d +} + +instance deq_either #a #b (d1 : deq a) (d2 : deq b) : Tot (deq (either a b)) = { + (=?) = (fun x y -> match x, y with + | Inl x, Inl y -> x =? y + | Inr x, Inr y -> x =? y + | _, _ -> false) +} + +instance deq_tuple2 #a #b (d1 : deq a) (d2 : deq b) : Tot (deq (a & b)) = { + (=?) = (fun (x1, x2) (y1, y2) -> x1 =? y1 && x2 =? y2) +} + +instance deq_tuple3 #a #b #c (d1 : deq a) (d2 : deq b) (d3 : deq c) : Tot (deq (a & b & c)) = { + (=?) = (fun (x1, x2, x3) (y1, y2, y3) -> x1 =? y1 && x2 =? y2 && x3 =? y3) +} + +instance deq_tuple4 #a #b #c #d (d1 : deq a) (d2 : deq b) (d3 : deq c) (d4 : deq d) : Tot (deq (a & b & c & d)) = { + (=?) = (fun (x1, x2, x3, x4) (y1, y2, y3, y4) -> x1 =? y1 && x2 =? y2 && x3 =? y3 && x4 =? y4) +} + +instance deq_tuple5 #a #b #c #d #e (d1 : deq a) (d2 : deq b) (d3 : deq c) (d4 : deq d) (d5 : deq e) : Tot (deq (a & b & c & d & e)) = { + (=?) = (fun (x1, x2, x3, x4, x5) (y1, y2, y3, y4, y5) -> x1 =? y1 && x2 =? y2 && x3 =? y3 && x4 =? y4 && x5 =? y5) +} + +instance deq_tuple6 #a #b #c #d #e #f (d1 : deq a) (d2 : deq b) (d3 : deq c) (d4 : deq d) (d5 : deq e) (d6 : deq f) : Tot (deq (a & b & c & d & e & f)) = { + (=?) = (fun (x1, x2, x3, x4, x5, x6) (y1, y2, y3, y4, y5, y6) -> x1 =? y1 && x2 =? y2 && x3 =? y3 && x4 =? y4 && x5 =? y5 && x6 =? y6) +} diff --git a/src/class/FStarC.Class.Deq.fsti b/src/class/FStarC.Class.Deq.fsti new file mode 100644 index 00000000000..3836cc3b058 --- /dev/null +++ b/src/class/FStarC.Class.Deq.fsti @@ -0,0 +1,63 @@ +module FStarC.Class.Deq + +open FStarC.Compiler.Effect + +class deq (a:Type) = { + (=?) : a -> a -> bool; +} + +val (<>?) : #a:Type -> {| deq a |} -> a -> a -> bool + +instance val deq_int : deq int +instance val deq_bool : deq bool +instance val deq_unit : deq unit +instance val deq_string : deq string + +instance val deq_option + (_ : deq 'a) +: Tot (deq (option 'a)) + +instance val deq_list + (_ : deq 'a) +: Tot (deq (list 'a)) + +instance val deq_either + (_ : deq 'a) + (_ : deq 'b) +: Tot (deq (either 'a 'b)) + +instance val deq_tuple2 + (_ : deq 'a) + (_ : deq 'b) +: Tot (deq ('a & 'b)) + +instance val deq_tuple3 + (_ : deq 'a) + (_ : deq 'b) + (_ : deq 'c) +: Tot (deq ('a & 'b & 'c)) + +instance val deq_tuple4 + (_ : deq 'a) + (_ : deq 'b) + (_ : deq 'c) + (_ : deq 'd) +: Tot (deq ('a & 'b & 'c & 'd)) + +instance val deq_tuple5 + (_ : deq 'a) + (_ : deq 'b) + (_ : deq 'c) + (_ : deq 'd) + (_ : deq 'e) +: Tot (deq ('a & 'b & 'c & 'd & 'e)) + +instance val deq_tuple6 + (_ : deq 'a) + (_ : deq 'b) + (_ : deq 'c) + (_ : deq 'd) + (_ : deq 'e) + (_ : deq 'f) +: Tot (deq ('a & 'b & 'c & 'd & 'e & 'f)) + diff --git a/src/class/FStarC.Class.HasRange.fst b/src/class/FStarC.Class.HasRange.fst new file mode 100644 index 00000000000..a0eb4e9b458 --- /dev/null +++ b/src/class/FStarC.Class.HasRange.fst @@ -0,0 +1,8 @@ +module FStarC.Class.HasRange + +open FStarC.Compiler.Range + +instance hasRange_range : hasRange range = { + pos = id; + setPos = (fun r _ -> r); // not really used +} \ No newline at end of file diff --git a/src/class/FStarC.Class.HasRange.fsti b/src/class/FStarC.Class.HasRange.fsti new file mode 100644 index 00000000000..f8582711212 --- /dev/null +++ b/src/class/FStarC.Class.HasRange.fsti @@ -0,0 +1,11 @@ +module FStarC.Class.HasRange + +open FStarC.Compiler.Effect +open FStarC.Compiler.Range + +class hasRange (a:Type) = { + pos : a -> range; + setPos : range -> a -> a; +} + +instance val hasRange_range : hasRange range \ No newline at end of file diff --git a/src/class/FStarC.Class.Hashable.fst b/src/class/FStarC.Class.Hashable.fst new file mode 100644 index 00000000000..78371eaf077 --- /dev/null +++ b/src/class/FStarC.Class.Hashable.fst @@ -0,0 +1,91 @@ +module FStarC.Class.Hashable + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Hash +open FStarC.Class.Show +open FStarC.Class.Deq +open FStarC.Class.Ord + +instance showable_hash_code : showable hash_code = { + show = string_of_hash_code; +} + +instance eq_hash_code : deq hash_code = { + ( =? ) = (=); +} + +instance ord_hash_code : ord hash_code = { + super = FStar.Tactics.Typeclasses.solve; + cmp = (fun x y -> Order.order_from_int (cmp_hash x y)); +} + +instance hashable_int : hashable int = { hash = of_int; } +instance hashable_string : hashable string = { hash = of_string; } +instance hashable_bool : hashable bool = { + hash = (fun b -> if b then of_int 1 else of_int 2); +} + +instance hashable_list + (_ : hashable 'a) +: Tot (hashable (list 'a)) = { + hash = (fun xs -> List.fold_left (fun h x -> mix h (hash x)) (of_int 0) xs); +} + +instance hashable_option + (_ : hashable 'a) +: Tot (hashable (option 'a)) = { + hash = (fun x -> match x with None -> of_int 0 | Some x -> mix (of_int 1) (hash x)); +} + +instance hashable_either + (_ : hashable 'a) + (_ : hashable 'b) +: Tot (hashable (either 'a 'b)) = { + hash = (fun x -> match x with Inl a -> mix (of_int 0) (hash a) | Inr b -> mix (of_int 1) (hash b)); +} + +instance hashable_tuple2 + (_ : hashable 'a) + (_ : hashable 'b) +: Tot (hashable ('a & 'b)) = { + hash = (fun (a, b) -> hash a `mix` hash b); +} + +instance hashable_tuple3 + (_ : hashable 'a) + (_ : hashable 'b) + (_ : hashable 'c) +: Tot (hashable ('a & 'b & 'c)) = { + hash = (fun (a, b, c) -> hash a `mix` hash b `mix` hash c); +} + +instance hashable_tuple4 + (_ : hashable 'a) + (_ : hashable 'b) + (_ : hashable 'c) + (_ : hashable 'd) +: Tot (hashable ('a & 'b & 'c & 'd)) = { + hash = (fun (a, b, c, d) -> hash a `mix` hash b `mix` hash c `mix` hash d); +} + +instance hashable_tuple5 + (_ : hashable 'a) + (_ : hashable 'b) + (_ : hashable 'c) + (_ : hashable 'd) + (_ : hashable 'e) +: Tot (hashable ('a & 'b & 'c & 'd & 'e)) = { + hash = (fun (a, b, c, d, e) -> hash a `mix` hash b `mix` hash c `mix` hash d `mix` hash e); +} + +instance hashable_tuple6 + (_ : hashable 'a) + (_ : hashable 'b) + (_ : hashable 'c) + (_ : hashable 'd) + (_ : hashable 'e) + (_ : hashable 'f) +: Tot (hashable ('a & 'b & 'c & 'd & 'e & 'f)) = { + hash = (fun (a, b, c, d, e, f) -> hash a `mix` hash b `mix` hash c `mix` hash d `mix` hash e `mix` hash f); +} diff --git a/src/class/FStarC.Class.Hashable.fsti b/src/class/FStarC.Class.Hashable.fsti new file mode 100644 index 00000000000..7b1663c518c --- /dev/null +++ b/src/class/FStarC.Class.Hashable.fsti @@ -0,0 +1,68 @@ +module FStarC.Class.Hashable + +open FStarC.Hash +include FStarC.Hash +open FStarC.Class.Show +open FStarC.Class.Deq +open FStarC.Class.Ord + +class hashable (a:Type) = { + hash : a -> hash_code; +} + +(* Properties about hash_code, better moved elsewhere. *) +instance val showable_hash_code : showable hash_code +instance val eq_hash_code : deq hash_code +instance val ord_hash_code : ord hash_code + +instance val hashable_int : hashable int +instance val hashable_string : hashable string +instance val hashable_bool : hashable bool + +instance val hashable_list + (_ : hashable 'a) +: Tot (hashable (list 'a)) + +instance val hashable_option + (_ : hashable 'a) +: Tot (hashable (option 'a)) + +instance val hashable_either + (_ : hashable 'a) + (_ : hashable 'b) +: Tot (hashable (either 'a 'b)) + +instance val hashable_tuple2 + (_ : hashable 'a) + (_ : hashable 'b) +: Tot (hashable ('a & 'b)) + +instance val hashable_tuple3 + (_ : hashable 'a) + (_ : hashable 'b) + (_ : hashable 'c) +: Tot (hashable ('a & 'b & 'c)) + +instance val hashable_tuple4 + (_ : hashable 'a) + (_ : hashable 'b) + (_ : hashable 'c) + (_ : hashable 'd) +: Tot (hashable ('a & 'b & 'c & 'd)) + +instance val hashable_tuple5 + (_ : hashable 'a) + (_ : hashable 'b) + (_ : hashable 'c) + (_ : hashable 'd) + (_ : hashable 'e) +: Tot (hashable ('a & 'b & 'c & 'd & 'e)) + +instance val hashable_tuple6 + (_ : hashable 'a) + (_ : hashable 'b) + (_ : hashable 'c) + (_ : hashable 'd) + (_ : hashable 'e) + (_ : hashable 'f) +: Tot (hashable ('a & 'b & 'c & 'd & 'e & 'f)) diff --git a/src/class/FStarC.Class.Listlike.fst b/src/class/FStarC.Class.Listlike.fst new file mode 100644 index 00000000000..b2abd016c2c --- /dev/null +++ b/src/class/FStarC.Class.Listlike.fst @@ -0,0 +1,21 @@ +module FStarC.Class.Listlike + +open FStarC.Compiler.Effect + +let is_empty (#e #s : Type) {| listlike e s |} (l : s) : bool = + match view l with + | VNil -> true + | VCons _ _ -> false + +let singleton (#e #s : Type) {| listlike e s |} (x : e) : s = + cons x empty + +let rec to_list (#e #s : Type) {| listlike e s |} (l : s) : list e = + match view l with + | VNil -> [] + | VCons x xs -> x :: to_list xs + +let rec from_list (#e #s : Type) {| listlike e s |} (l : list e) : s = + match l with + | [] -> empty + | x :: xs -> cons x (from_list xs) diff --git a/src/class/FStarC.Class.Listlike.fsti b/src/class/FStarC.Class.Listlike.fsti new file mode 100644 index 00000000000..d06b2ea724b --- /dev/null +++ b/src/class/FStarC.Class.Listlike.fsti @@ -0,0 +1,22 @@ +module FStarC.Class.Listlike + +open FStarC.Compiler.Effect + +type view_t e s = + | VNil : view_t e s + | VCons : e -> s -> view_t e s + +[@@Tactics.Typeclasses.fundeps [0]] +class listlike (e:Type) (s:Type) = { + empty : s; + cons : e -> s -> s; + view : s -> view_t e s; +} + +val is_empty (#e #s : Type) {| listlike e s |} (l : s) : bool + +val singleton (#e #s : Type) {| listlike e s |} (x : e) : s + +val to_list (#e #s : Type) {| listlike e s |} (l : s) : list e + +val from_list (#e #s : Type) {| listlike e s |} (l : list e) : s diff --git a/src/class/FStarC.Class.Monad.fst b/src/class/FStarC.Class.Monad.fst new file mode 100644 index 00000000000..83b52598e52 --- /dev/null +++ b/src/class/FStarC.Class.Monad.fst @@ -0,0 +1,75 @@ +module FStarC.Class.Monad + +open FStarC.Compiler +open FStarC.Compiler.Effect + +instance monad_option : monad option = { + return = (fun x -> Some x); // FIXME: without the we gell ill-typed ML + ( let! ) = Util.bind_opt; +} + +instance monad_list : monad list = { + return = (fun x -> [x]); + ( let! ) = (fun x f -> List.concatMap f x) +} + +let rec mapM f l = + match l with + | [] -> return [] + | x::xs -> + let! y = f x in + let! ys = mapM f xs in + return (y::ys) + +let mapMi #m #_ #a #b f l = + (* FIXME: need to annotate the return type, why? *) + let rec mapMi_go i f l : m (list b) = + match l with + | [] -> return [] + | x::xs -> + let! y = f i x in + let! ys = mapMi_go (i+1) f xs in + return (y::ys) + in + mapMi_go 0 f l + +let map_optM f l = + match l with + | None -> return None + | Some x -> + let! x = f x in + return (Some x) + +let rec iterM f l = + match l with + | [] -> return () + | x::xs -> + f x;! + iterM f xs + +let rec foldM_left f e xs = + match xs with + | [] -> return e + | x::xs -> + let! e' = f e x in + foldM_left f e' xs + +let rec foldM_right f xs e = + match xs with + | [] -> return e + | x::xs -> + let! e' = foldM_right f xs e in + f x e' + +let (<$>) f x = + let! v = x in + return (f v) + +let (<*>) ff x = + let! f = ff in + let! v = x in + return (f v) + +let fmap f m = + let! v = m in + return (f v) diff --git a/src/class/FStarC.Class.Monad.fsti b/src/class/FStarC.Class.Monad.fsti new file mode 100644 index 00000000000..4931c56aff4 --- /dev/null +++ b/src/class/FStarC.Class.Monad.fsti @@ -0,0 +1,67 @@ +module FStarC.Class.Monad + +open FStarC.Compiler +open FStarC.Compiler.Effect + +class monad (m : Type -> Type) = { + return : #a:Type -> a -> m a; + ( let! ) : #a:Type -> #b:Type -> m a -> (a -> m b) -> m b +} + +instance val monad_option : monad option +instance val monad_list : monad list + +val mapM + (#m: Type -> Type) + {| monad m |} + (#a #b :Type) +: (a -> m b) -> list a -> m (list b) + +val mapMi + (#m: Type -> Type) + {| monad m |} + (#a #b :Type) +: (int -> a -> m b) -> list a -> m (list b) + +val map_optM + (#m: Type -> Type) + {| monad m |} + (#a #b :Type) +: (a -> m b) -> option a -> m (option b) + +val iterM + (#m: Type -> Type) + {| monad m |} + (#a :Type) +: (a -> m unit) -> list a -> m unit + +val foldM_left + (#m: Type -> Type) + {| monad m |} + (#a #b :Type) +: (a -> b -> m a) -> a -> list b -> m a + +val foldM_right + (#m: Type -> Type) + {| monad m |} + (#a #b :Type) +: (a -> b -> m b) -> list a -> b -> m b + +val (<$>) + (#m: Type -> Type) + {| monad m |} + (#a #b :Type) +: (a -> b) -> m a -> m b + +val (<*>) + (#m: Type -> Type) + {| monad m |} + (#a #b :Type) +: m (a -> b) -> m a -> m b + +val fmap + (#m: Type -> Type) + {| monad m |} + (#a #b :Type) + (f : a -> b) +: m a -> m b diff --git a/src/class/FStarC.Class.Monoid.fst b/src/class/FStarC.Class.Monoid.fst new file mode 100644 index 00000000000..b0d483de8be --- /dev/null +++ b/src/class/FStarC.Class.Monoid.fst @@ -0,0 +1,33 @@ +module FStarC.Class.Monoid + +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.List + +let ( ++ ) #a {| monoid a |} = mplus #a + +let msum xs = fold_left mplus mzero xs + +instance monoid_int : monoid int = { + mzero = 0; + mplus = (fun x y -> x + y); +} + +instance monoid_string : monoid string = { + mzero = ""; + mplus = (fun x y -> x ^ y); +} + +instance monoid_list (a:Type) : Tot (monoid (list a)) = { + mzero = []; + mplus = (fun x y -> x @ y); +} + +(* Funny output from Copilot... not bad! + +instance monoid_effect (a:Type) (e:effect) : monoid (a!e) = { + mzero = return mzero; + mplus = (fun x y -> x >>= (fun x -> y >>= (fun y -> return (mplus x y)))); +} + +*) diff --git a/src/class/FStarC.Class.Monoid.fsti b/src/class/FStarC.Class.Monoid.fsti new file mode 100644 index 00000000000..9224875f42a --- /dev/null +++ b/src/class/FStarC.Class.Monoid.fsti @@ -0,0 +1,19 @@ +module FStarC.Class.Monoid + +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.List + +class monoid (a:Type) = { + mzero : a; + mplus : a -> a -> a; +} + +(* Alias *) +val ( ++ ) (#a:Type) {| monoid a |} : a -> a -> a + +val msum (#a:Type) {| monoid a |} (xs:list a) : a + +instance val monoid_int : monoid int +instance val monoid_string : monoid string +instance val monoid_list (a:Type) : Tot (monoid (list a)) diff --git a/src/class/FStarC.Class.Ord.fst b/src/class/FStarC.Class.Ord.fst new file mode 100644 index 00000000000..3890ecfcc48 --- /dev/null +++ b/src/class/FStarC.Class.Ord.fst @@ -0,0 +1,120 @@ +module FStarC.Class.Ord + +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStar.Tactics.Typeclasses + +let ( Gt +let (>?) x y = cmp x y = Gt +let (>=?) x y = cmp x y <> Lt + +let min x y = if x <=? y then x else y +let max x y = if x >=? y then x else y + +instance ord_eq (a:Type) (d : ord a) : Tot (deq a) = d.super + +let rec insert (#a:Type) {| ord a |} (x:a) (xs:list a) : list a = + match xs with + | [] -> [x] + | y::ys -> if x <=? y then x :: y :: ys else y :: insert x ys + +let rec sort xs = + match xs with + | [] -> [] + | x::xs -> insert x (sort xs) + +let dedup #a xs = + let open FStarC.Compiler.List in + let out = fold_left (fun out x -> if existsb (fun y -> x =? y) out then out else x :: out) [] xs in + List.rev out + +instance ord_int : ord int = { + super = solve; + cmp = compare_int; +} + +instance ord_bool : ord bool = { + super = solve; + cmp = compare_bool; +} + +instance ord_unit : ord unit = { + super = solve; + cmp = (fun _ _ -> Eq); +} + +instance ord_string : ord string = { + super = solve; + cmp = (fun x y -> order_from_int (String.compare x y)); +} + +instance ord_option #a (d : ord a) : Tot (ord (option a)) = { + super = solve; + cmp = (fun x y -> match x, y with + | None, None -> Eq + | Some _, None -> Gt + | None, Some _ -> Lt + | Some x, Some y -> cmp x y + ); +} + +instance ord_list #a (d : ord a) : Tot (ord (list a)) = { + super = solve; + cmp = (fun l1 l2 -> compare_list l1 l2 cmp); +} + +instance ord_either #a #b (d1 : ord a) (d2 : ord b) : Tot (ord (either a b)) = { + super = solve; + cmp = (fun x y -> match x, y with + | Inl _, Inr _ -> Lt + | Inr _, Inl _ -> Gt + | Inl x, Inl y -> cmp x y + | Inr x, Inr y -> cmp x y + ); +} + +instance ord_tuple2 #a #b (d1 : ord a) (d2 : ord b) : Tot (ord (a & b)) = { + super = solve; + cmp = (fun (x1, x2) (y1, y2) -> + lex (cmp x1 y1) (fun () -> + cmp x2 y2)); +} + +instance ord_tuple3 #a #b #c (d1 : ord a) (d2 : ord b) (d3 : ord c): Tot (ord (a & b & c)) = { + super = solve; + cmp = (fun (x1, x2, x3) (y1, y2, y3) -> + lex (cmp x1 y1) (fun () -> + lex (cmp x2 y2) (fun () -> + cmp x3 y3))); +} + +instance ord_tuple4 #a #b #c #d (d1 : ord a) (d2 : ord b) (d3 : ord c) (d4 : ord d): Tot (ord (a & b & c & d)) = { + super = solve; + cmp = (fun (x1, x2, x3, x4) (y1, y2, y3, y4) -> + lex (cmp x1 y1) (fun () -> + lex (cmp x2 y2) (fun () -> + lex (cmp x3 y3) (fun () -> + cmp x4 y4)))); +} + +instance ord_tuple5 #a #b #c #d #e (d1 : ord a) (d2 : ord b) (d3 : ord c) (d4 : ord d) (d5 : ord e): Tot (ord (a & b & c & d & e)) = { + super = solve; + cmp = (fun (x1, x2, x3, x4, x5) (y1, y2, y3, y4, y5) -> + lex (cmp x1 y1) (fun () -> + lex (cmp x2 y2) (fun () -> + lex (cmp x3 y3) (fun () -> + lex (cmp x4 y4) (fun () -> + cmp x5 y5))))); +} + +instance ord_tuple6 #a #b #c #d #e #f (d1 : ord a) (d2 : ord b) (d3 : ord c) (d4 : ord d) (d5 : ord e) (d6 : ord f): Tot (ord (a & b & c & d & e & f)) = { + super = solve; + cmp = (fun (x1, x2, x3, x4, x5, x6) (y1, y2, y3, y4, y5, y6) -> + lex (cmp x1 y1) (fun () -> + lex (cmp x2 y2) (fun () -> + lex (cmp x3 y3) (fun () -> + lex (cmp x4 y4) (fun () -> + lex (cmp x5 y5) (fun () -> + cmp x6 y6)))))); +} diff --git a/src/class/FStarC.Class.Ord.fsti b/src/class/FStarC.Class.Ord.fsti new file mode 100644 index 00000000000..111d8ae38f0 --- /dev/null +++ b/src/class/FStarC.Class.Ord.fsti @@ -0,0 +1,86 @@ +module FStarC.Class.Ord + +open FStarC.Compiler.Effect +open FStarC.Compiler.Order +include FStarC.Class.Deq +open FStarC.Class.Deq + +class ord (a:Type) = { + super : deq a; + cmp : a -> a -> order; +} + +val sort + (#a:Type) {| ord a |} + (xs : list a) + : list a + +(* Deduplicate elements, preserving order as determined by the leftmost +occurrence. So dedup [a,b,c,a,f,e,c] = [a,b,c,f,e] *) +val dedup + (#a:Type) {| ord a |} + (xs : list a) + : list a + +instance val ord_eq (a:Type) (d : ord a) : Tot (deq a) + +val ( {| ord a |} -> a -> a -> bool +val (<=?) : #a:Type -> {| ord a |} -> a -> a -> bool +val (>?) : #a:Type -> {| ord a |} -> a -> a -> bool +val (>=?) : #a:Type -> {| ord a |} -> a -> a -> bool + +val min : #a:Type -> {| ord a |} -> a -> a -> a +val max : #a:Type -> {| ord a |} -> a -> a -> a + +instance val ord_int : ord int +instance val ord_bool : ord bool +instance val ord_unit : ord unit +instance val ord_string : ord string + +instance val ord_option + (_ : ord 'a) +: Tot (ord (option 'a)) + +instance val ord_list + (_ : ord 'a) +: Tot (ord (list 'a)) + +instance val ord_either + (_ : ord 'a) + (_ : ord 'b) +: Tot (ord (either 'a 'b)) + +instance val ord_tuple2 + (_ : ord 'a) + (_ : ord 'b) +: Tot (ord ('a & 'b)) + +instance val ord_tuple3 + (_ : ord 'a) + (_ : ord 'b) + (_ : ord 'c) +: Tot (ord ('a & 'b & 'c)) + +instance val ord_tuple4 + (_ : ord 'a) + (_ : ord 'b) + (_ : ord 'c) + (_ : ord 'd) +: Tot (ord ('a & 'b & 'c & 'd)) + +instance val ord_tuple5 + (_ : ord 'a) + (_ : ord 'b) + (_ : ord 'c) + (_ : ord 'd) + (_ : ord 'e) +: Tot (ord ('a & 'b & 'c & 'd & 'e)) + +instance val ord_tuple6 + (_ : ord 'a) + (_ : ord 'b) + (_ : ord 'c) + (_ : ord 'd) + (_ : ord 'e) + (_ : ord 'f) +: Tot (ord ('a & 'b & 'c & 'd & 'e & 'f)) diff --git a/src/class/FStarC.Class.PP.fst b/src/class/FStarC.Class.PP.fst new file mode 100644 index 00000000000..9be4858f070 --- /dev/null +++ b/src/class/FStarC.Class.PP.fst @@ -0,0 +1,96 @@ +module FStarC.Class.PP + +open FStarC +open FStarC.Compiler.Effect +open FStarC.Pprint + +let gparens a = group (nest 2 (parens a)) +let gbrackets a = group (nest 2 (brackets a)) + +instance pp_unit = { + pp = (fun _ -> doc_of_string "()"); +} + +instance pp_int = { + pp = (fun x -> doc_of_string (string_of_int x)); +} + +instance pp_bool = { + pp = doc_of_bool; +} + +instance pp_list (a:Type) (_ : pretty a) : Tot (pretty (list a)) = { + pp = (fun l -> gbrackets (flow_map (semi ^^ break_ 1) pp l)); +} + +instance pp_option (a:Type) (_ : pretty a) : Tot (pretty (option a)) = { + pp = (fun o -> match o with + | Some v -> group (nest 2 (doc_of_string "Some" ^/^ pp v)) + | None -> doc_of_string "None"); +} + +instance pp_either (_ : pretty 'a) (_ : pretty 'b) = { + pp = (fun e -> group (nest 2 (match e with + | Inl x -> doc_of_string "Inl" ^/^ pp x + | Inr x -> doc_of_string "Inr" ^/^ pp x))); +} + +let comma_space = comma ^^ break_ 1 + +instance pp_tuple2 + (_ : pretty 'a) + (_ : pretty 'b) += { + pp = (fun (x1, x2) -> + gparens (separate comma_space [pp x1; pp x2])); +} + +instance pp_tuple3 + (_ : pretty 'a) + (_ : pretty 'b) + (_ : pretty 'c) += { + pp = (fun (x1, x2, x3) -> + gparens (separate comma_space [pp x1; pp x2; pp x3])); +} + +instance pp_tuple4 + (_ : pretty 'a) + (_ : pretty 'b) + (_ : pretty 'c) + (_ : pretty 'd) += { + pp = (fun (x1, x2, x3, x4) -> + gparens (separate comma_space [pp x1; pp x2; pp x3; pp x4])); +} + +instance pp_tuple5 + (_ : pretty 'a) + (_ : pretty 'b) + (_ : pretty 'c) + (_ : pretty 'd) + (_ : pretty 'e) += { + pp = (fun (x1, x2, x3, x4, x5) -> + gparens (separate comma_space [pp x1; pp x2; pp x3; pp x4; pp x5])); +} + +instance pp_tuple6 + (_ : pretty 'a) + (_ : pretty 'b) + (_ : pretty 'c) + (_ : pretty 'd) + (_ : pretty 'e) + (_ : pretty 'f) += { + pp = (fun (x1, x2, x3, x4, x5, x6) -> + gparens (separate comma_space [pp x1; pp x2; pp x3; pp x4; pp x5; pp x6])); +} + +let pretty_from_showable (#a:Type) {| _ : Class.Show.showable a |} : Tot (pretty a) = { + pp = (fun x -> arbitrary_string (Class.Show.show x)); +} + +let showable_from_pretty (#a:Type) {| _ : pretty a |} : Tot (Class.Show.showable a) = { + show = (fun x -> render (pp x)); +} diff --git a/src/class/FStarC.Class.PP.fsti b/src/class/FStarC.Class.PP.fsti new file mode 100644 index 00000000000..f2c27165b02 --- /dev/null +++ b/src/class/FStarC.Class.PP.fsti @@ -0,0 +1,65 @@ +module FStarC.Class.PP + +open FStarC.Compiler.Effect +open FStarC.Pprint + +class pretty (a:Type) = { + pp : a -> ML document; +} + +instance val pp_unit : pretty unit +instance val pp_int : pretty int +instance val pp_bool : pretty bool +//instance val pp_char : pretty char + +(* We intentionally do not add a `pretty string` instance, as there +are many differenta ways of pprinting a string (doc_of_string, text, +arbitrary_string). *) + +instance val pp_list (a:Type) (_ : pretty a) : Tot (pretty (list a)) + +instance val pp_option (a:Type) (_ : pretty a) : Tot (pretty (option a)) + +instance val pp_either + (_ : pretty 'a) + (_ : pretty 'b) +: Tot (pretty (either 'a 'b)) + +instance val pp_tuple2 + (_ : pretty 'a) + (_ : pretty 'b) +: Tot (pretty ('a & 'b)) + +instance val pp_tuple3 + (_ : pretty 'a) + (_ : pretty 'b) + (_ : pretty 'c) +: Tot (pretty ('a & 'b & 'c)) + +instance val pp_tuple4 + (_ : pretty 'a) + (_ : pretty 'b) + (_ : pretty 'c) + (_ : pretty 'd) +: Tot (pretty ('a & 'b & 'c & 'd)) + +instance val pp_tuple5 + (_ : pretty 'a) + (_ : pretty 'b) + (_ : pretty 'c) + (_ : pretty 'd) + (_ : pretty 'e) +: Tot (pretty ('a & 'b & 'c & 'd & 'e)) + +instance val pp_tuple6 + (_ : pretty 'a) + (_ : pretty 'b) + (_ : pretty 'c) + (_ : pretty 'd) + (_ : pretty 'e) + (_ : pretty 'f) +: Tot (pretty ('a & 'b & 'c & 'd & 'e & 'f)) + +val pretty_from_showable (#a:Type) {| _ : Show.showable a |} : Tot (pretty a) + +val showable_from_pretty (#a:Type) {| _ : pretty a |} : Tot (Show.showable a) diff --git a/src/class/FStarC.Class.Setlike.fst b/src/class/FStarC.Class.Setlike.fst new file mode 100644 index 00000000000..cc149a51f41 --- /dev/null +++ b/src/class/FStarC.Class.Setlike.fst @@ -0,0 +1,6 @@ +module FStarC.Class.Setlike + +open FStarC.Compiler.Effect +open FStarC.Class.Ord + +let symdiff s1 s2 = diff s1 s2 diff --git a/src/class/FStarC.Class.Setlike.fsti b/src/class/FStarC.Class.Setlike.fsti new file mode 100644 index 00000000000..78d9743f775 --- /dev/null +++ b/src/class/FStarC.Class.Setlike.fsti @@ -0,0 +1,28 @@ +module FStarC.Class.Setlike + +open FStarC.Compiler.Effect +open FStarC.Class.Ord + +[@@Tactics.Typeclasses.fundeps [0]] +class setlike (e:Type) (s:Type) = { + empty : unit -> s; + singleton : e -> s; + is_empty : s -> bool; + add : e -> s -> s; + remove : e -> s -> s; + mem : e -> s -> bool; + equal : s -> s -> bool; + subset : s -> s -> bool; + union : s -> s -> s; + inter : s -> s -> s; + diff : s -> s -> s; + for_all : (e -> bool) -> s -> bool; + for_any : (e -> bool) -> s -> bool; + elems : s -> list e; + + collect : (e -> s) -> list e -> s; + from_list : list e -> s; + addn : list e -> s -> s; +} + +val symdiff (#e #s : Type) {| setlike e s |} : s -> s -> s diff --git a/src/class/FStarC.Class.Show.fst b/src/class/FStarC.Class.Show.fst new file mode 100644 index 00000000000..ad15749a627 --- /dev/null +++ b/src/class/FStarC.Class.Show.fst @@ -0,0 +1,89 @@ +module FStarC.Class.Show + +open FStarC.Compiler.Effect +open FStar.Class.Printable + +instance printableshow (_ : printable 'a) : Tot (showable 'a) = { + show = to_string; +} + +instance show_list (a:Type) (_ : showable a) : Tot (showable (list a)) = { + show = FStarC.Common.string_of_list show; +} + +instance show_option (a:Type) (_ : showable a) : Tot (showable (option a)) = { + show = FStarC.Common.string_of_option show; +} + +instance show_either + (_ : showable 'a) + (_ : showable 'b) += { + show = (function Inl x -> "Inl " ^ show x + | Inr y -> "Inr " ^ show y); +} + +instance show_tuple2 + (_ : showable 'a) + (_ : showable 'b) += { + show = (fun (x1, x2) -> "(" + ^ show x1 ^ ", " + ^ show x2 ^ ")"); +} + +instance show_tuple3 + (_ : showable 'a) + (_ : showable 'b) + (_ : showable 'c) += { + show = (fun (x1, x2, x3) -> "(" + ^ show x1 ^ ", " + ^ show x2 ^ ", " + ^ show x3 ^ ")"); +} + +instance show_tuple4 + (_ : showable 'a) + (_ : showable 'b) + (_ : showable 'c) + (_ : showable 'd) += { + show = (fun (x1, x2, x3, x4) -> "(" + ^ show x1 ^ ", " + ^ show x2 ^ ", " + ^ show x3 ^ ", " + ^ show x4 ^ ")"); +} + +instance show_tuple5 + (_ : showable 'a) + (_ : showable 'b) + (_ : showable 'c) + (_ : showable 'd) + (_ : showable 'e) += { + show = (fun (x1, x2, x3, x4, x5) -> "(" + ^ show x1 ^ ", " + ^ show x2 ^ ", " + ^ show x3 ^ ", " + ^ show x4 ^ ", " + ^ show x5 ^ ")"); +} + +instance show_tuple6 + (_ : showable 'a) + (_ : showable 'b) + (_ : showable 'c) + (_ : showable 'd) + (_ : showable 'e) + (_ : showable 'f) += { + show = (fun (x1, x2, x3, x4, x5, x6) -> "(" + ^ show x1 ^ ", " + ^ show x2 ^ ", " + ^ show x3 ^ ", " + ^ show x4 ^ ", " + ^ show x5 ^ ", " + ^ show x6 ^ ")"); +} diff --git a/src/class/FStarC.Class.Show.fsti b/src/class/FStarC.Class.Show.fsti new file mode 100644 index 00000000000..1837266c107 --- /dev/null +++ b/src/class/FStarC.Class.Show.fsti @@ -0,0 +1,57 @@ +module FStarC.Class.Show + +open FStarC.Compiler.Effect +open FStar.Class.Printable +module BU = FStarC.Compiler.Util + +class showable (a:Type) = { + show : a -> ML string; +} + +(* This extends the printable class from ulib, but also allows for an +ML effect of the `printer. *) +instance val printableshow (_ : printable 'a) : Tot (showable 'a) + +instance val show_list (a:Type) (_ : showable a) : Tot (showable (list a)) + +instance val show_option (a:Type) (_ : showable a) : Tot (showable (option a)) + +instance val show_either + (_ : showable 'a) + (_ : showable 'b) +: Tot (showable (either 'a 'b)) + +instance val show_tuple2 + (_ : showable 'a) + (_ : showable 'b) +: Tot (showable ('a & 'b)) + +instance val show_tuple3 + (_ : showable 'a) + (_ : showable 'b) + (_ : showable 'c) +: Tot (showable ('a & 'b & 'c)) + +instance val show_tuple4 + (_ : showable 'a) + (_ : showable 'b) + (_ : showable 'c) + (_ : showable 'd) +: Tot (showable ('a & 'b & 'c & 'd)) + +instance val show_tuple5 + (_ : showable 'a) + (_ : showable 'b) + (_ : showable 'c) + (_ : showable 'd) + (_ : showable 'e) +: Tot (showable ('a & 'b & 'c & 'd & 'e)) + +instance val show_tuple6 + (_ : showable 'a) + (_ : showable 'b) + (_ : showable 'c) + (_ : showable 'd) + (_ : showable 'e) + (_ : showable 'f) +: Tot (showable ('a & 'b & 'c & 'd & 'e & 'f)) diff --git a/src/class/FStarC.Class.Tagged.fst b/src/class/FStarC.Class.Tagged.fst new file mode 100644 index 00000000000..c4cf1b416c7 --- /dev/null +++ b/src/class/FStarC.Class.Tagged.fst @@ -0,0 +1 @@ +module FStarC.Class.Tagged diff --git a/src/class/FStarC.Class.Tagged.fsti b/src/class/FStarC.Class.Tagged.fsti new file mode 100644 index 00000000000..f82969e89cc --- /dev/null +++ b/src/class/FStarC.Class.Tagged.fsti @@ -0,0 +1,9 @@ +module FStarC.Class.Tagged + +open FStarC.Compiler.Effect + +(* This class is meant to print the constructor of a term. +It replaces tag_of_term and tag_of_sigelt. *) +class tagged (a:Type) = { + tag_of : a -> ML string; +} diff --git a/src/data/FStar.Compiler.CList.fst b/src/data/FStar.Compiler.CList.fst deleted file mode 100644 index 0203103327e..00000000000 --- a/src/data/FStar.Compiler.CList.fst +++ /dev/null @@ -1,103 +0,0 @@ -(* - Copyright 2008-2017 Microsoft Research - - Authors: Aseem Rastogi, Nikhil Swamy, Jonathan Protzenko - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Compiler.CList - -open FStar.Tactics.Typeclasses -open FStar.Class.Ord -open FStar.Class.Listlike - -type clist (a:Type0) : Type0 = - | CNil : clist a - | CCons : a -> clist a -> clist a - | CCat : clist a -> clist a -> clist a - -let ccat (#a:Type0) (xs ys : clist a) : clist a = - match xs, ys with - | CNil, _ -> ys - | _, CNil -> xs - | _ -> CCat xs ys - -let rec view (#a:Type0) (l:clist a) : Tot (view_t a (clist a)) = - match l with - | CNil -> VNil - | CCons x xs -> VCons x xs - | CCat (CCat xs ys) zs -> view (CCat xs (CCat ys zs)) - | CCat xs ys -> - match view xs with - | VNil -> view ys - | VCons x xs' -> VCons x (CCat xs' ys) - -instance listlike_clist (a:Type0) : Tot (listlike a (t a)) = { - empty = CNil; - cons = CCons; - view = view; -} - -instance monoid_clist (a:Type0) : Tot (monoid (t a)) = { - mzero = CNil; - mplus = ccat; -} - -instance showable_clist (a:Type0) (_ : showable a) : Tot (showable (t a)) = { - show = (fun l -> show (to_list l)); -} - -instance eq_clist (a:Type0) (d : deq a) : Tot (deq (t a)) = { - (=?) = (fun l1 l2 -> to_list l1 =? to_list l2); -} - -instance ord_clist (a:Type0) (d : ord a) : Tot (ord (t a)) = { - super = solve; - cmp = (fun l1 l2 -> cmp (to_list l1) (to_list l2)); -} - -let rec map (#a #b : Type0) (f : a -> b) (l : clist a) : clist b = - match l with - | CNil -> CNil - | CCons x xs -> CCons (f x) (map f xs) - | CCat xs ys -> ccat (map f xs) (map f ys) - -let rec existsb (#a : Type0) (p : a -> bool) (l : clist a) : bool = - match l with - | CNil -> false - | CCons x xs -> p x || existsb p xs - | CCat xs ys -> existsb p xs || existsb p ys - -let rec for_all (#a : Type0) (p : a -> bool) (l : clist a) : bool = - match l with - | CNil -> true - | CCons x xs -> p x && for_all p xs - | CCat xs ys -> for_all p xs && for_all p ys - -let rec partition (#a : Type0) (p : a -> bool) (l : clist a) : clist a * clist a = - match l with - | CNil -> (CNil, CNil) - | CCons x xs -> - let (ys, zs) = partition p xs in - if p x then (CCons x ys, zs) else (ys, CCons x zs) - | CCat xs ys -> - let (ys, zs) = partition p xs in - let (us, vs) = partition p ys in - (ccat ys us, ccat zs vs) - -let rec collect (#a #b : Type0) (f : a -> clist b) (l : clist a) : clist b = - match l with - | CNil -> CNil - | CCons x xs -> ccat (f x) (collect f xs) - | CCat xs ys -> ccat (collect f xs) (collect f ys) diff --git a/src/data/FStar.Compiler.CList.fsti b/src/data/FStar.Compiler.CList.fsti deleted file mode 100644 index 90d04a76f10..00000000000 --- a/src/data/FStar.Compiler.CList.fsti +++ /dev/null @@ -1,47 +0,0 @@ -(* - Copyright 2008-2017 Microsoft Research - - Authors: Aseem Rastogi, Nikhil Swamy, Jonathan Protzenko - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -(* Catenable lists, based on Jaskelioff and Rivas' "Functional Pearl: A Smart View on Datatypes" *) -module FStar.Compiler.CList - -open FStar.Class.Deq -open FStar.Class.Ord -open FStar.Class.Show -open FStar.Class.Monoid -open FStar.Class.Listlike - -new -val clist (a:Type0) : Type0 - -type t = clist - -instance val listlike_clist (a:Type0) : Tot (listlike a (t a)) -instance val monoid_clist (a:Type0) : Tot (monoid (t a)) -instance val showable_clist (a:Type0) (_ : showable a) : Tot (showable (t a)) -instance val eq_clist (a:Type0) (_ : deq a) : Tot (deq (t a)) -instance val ord_clist (a:Type0) (_ : ord a) : Tot (ord (t a)) - -val map (#a #b : Type0) (f : a -> b) (l : clist a) : clist b - -val existsb (#a : Type0) (p : a -> bool) (l : clist a) : bool - -val for_all (#a : Type0) (p : a -> bool) (l : clist a) : bool - -val partition (#a : Type0) (p : a -> bool) (l : clist a) : clist a * clist a - -val collect : ('a -> clist 'b) -> clist 'a -> clist 'b diff --git a/src/data/FStar.Compiler.FlatSet.fst b/src/data/FStar.Compiler.FlatSet.fst deleted file mode 100644 index 1d8a54231be..00000000000 --- a/src/data/FStar.Compiler.FlatSet.fst +++ /dev/null @@ -1,113 +0,0 @@ -(* - Copyright 2008-2017 Microsoft Research - - Authors: Aseem Rastogi, Nikhil Swamy, Jonathan Protzenko - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Compiler.FlatSet - -open FStar.Class.Ord -open FStar.Compiler.Effect -open FStar.Compiler.Order -open FStar.Compiler.Util - -(* This is a slow implementation that mimics FStar.Compiler.Util.set, -which is implemented with lists. As it turns out we heavily rely on -the exact order of `elems` provided by this list representation, so we -cannot (yet) do big changes here. *) - -(* Inv: no duplication. We are left-biased. *) -let flat_set t = list t - -val add (#a:Type) {| ord a |} : a -> flat_set a -> flat_set a -let rec add x s = - match s with - | [] -> [x] - | y::yy -> if x =? y then s else y :: add x yy - -val empty (#a:Type) : unit -> flat_set a -let empty () = [] - -val from_list (#a:Type) {| ord a |} : list a -> flat_set a -let from_list xs = dedup xs - -val mem (#a:Type) {| ord a |} : a -> flat_set a -> bool -let mem x s = List.existsb (fun y -> x =? y) s - -val singleton (#a:Type) {| ord a |} : a -> flat_set a -let singleton x = [x] - -val is_empty (#a:Type) : flat_set a -> bool -let is_empty s = Nil? s - -val addn (#a:Type) {| ord a |} : list a -> flat_set a -> flat_set a -let addn xs ys = List.fold_right add xs ys - -val remove (#a:Type) {| ord a |} : a -> flat_set a -> flat_set a -let rec remove x s = - match s with - | [] -> [] - | y::yy -> if x =? y then yy else y :: remove x yy - -val elems (#a:Type) : flat_set a -> list a -let elems s = s - -val for_all (#a:Type) : (a -> bool) -> flat_set a -> bool -let for_all p s = elems s |> List.for_all p - -val for_any (#a:Type) : (a -> bool) -> flat_set a -> bool -let for_any p s = elems s |> List.existsb p - -val subset (#a:Type) {| ord a |} : flat_set a -> flat_set a -> bool -let subset s1 s2 = for_all (fun y -> mem y s2) s1 - -val equal (#a:Type) {| ord a |} : flat_set a -> flat_set a -> bool -let equal s1 s2 = sort s1 =? sort s2 - -val union (#a:Type) {| ord a |} : flat_set a -> flat_set a -> flat_set a -let union s1 s2 = List.fold_left (fun s x -> add x s) s1 s2 - -val inter (#a:Type) {| ord a |} : flat_set a -> flat_set a -> flat_set a -let inter s1 s2 = List.filter (fun y -> mem y s2) s1 - -val diff (#a:Type) {| ord a |} : flat_set a -> flat_set a -> flat_set a -let diff s1 s2 = List.filter (fun y -> not (mem y s2)) s1 - -val collect (#a #b:Type) {| ord b |} : (a -> flat_set b) -> list a -> flat_set b -let collect f l = List.fold_right (fun x acc -> f x `union` acc) l (empty ()) - -instance showable_set (a:Type) (_ : ord a) (_ : showable a) : Tot (showable (flat_set a)) = { - show = (fun s -> show (elems s)); -} - -instance setlike_flat_set (a:Type) (_ : ord a) : Tot (setlike a (flat_set a)) = { - empty = empty; - from_list = from_list; - singleton = singleton; - is_empty = is_empty; - add = add; - addn = addn; - remove = remove; - mem = mem; - elems = elems; - for_all = for_all; - for_any = for_any; - subset = subset; - equal = equal; - union = union; - inter = inter; - diff = diff; - collect = collect; -} diff --git a/src/data/FStar.Compiler.FlatSet.fsti b/src/data/FStar.Compiler.FlatSet.fsti deleted file mode 100644 index fbc5939fe01..00000000000 --- a/src/data/FStar.Compiler.FlatSet.fsti +++ /dev/null @@ -1,33 +0,0 @@ -(* - Copyright 2008-2017 Microsoft Research - - Authors: Aseem Rastogi, Nikhil Swamy, Jonathan Protzenko - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Compiler.FlatSet - -open FStar.Class.Ord -open FStar.Class.Show -open FStar.Class.Setlike -include FStar.Class.Setlike - -val flat_set (a:Type0) : Type0 -type t = flat_set - -instance -val showable_set (a:Type) (_ : ord a) (_ : showable a) : Tot (showable (flat_set a)) - -instance -val setlike_flat_set (a:Type0) (_ : ord a) : Tot (setlike a (flat_set a)) diff --git a/src/data/FStar.Compiler.Path.fst b/src/data/FStar.Compiler.Path.fst deleted file mode 100644 index 365fefd0365..00000000000 --- a/src/data/FStar.Compiler.Path.fst +++ /dev/null @@ -1,35 +0,0 @@ -(* - Copyright 2008-2017 Microsoft Research - - Authors: Aseem Rastogi, Nikhil Swamy, Jonathan Protzenko - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Compiler.Path - -open FStar.Class.Deq - -let rec is_under {| deq 'a |} (p1 p2 : path 'a) : bool = - match p1, p2 with - | _, [] -> true - | [], _ -> false - | h1::t1, h2::t2 -> h1 =? h2 && is_under t1 t2 - -let search_forest #a #q {| deq a |} p f = - let roots, def = f in - let rec aux (roots : list (path a & q)) : q = - match roots with - | [] -> def - | (r, q)::rs -> if p `is_under` r then q else aux rs - in - aux roots diff --git a/src/data/FStar.Compiler.Path.fsti b/src/data/FStar.Compiler.Path.fsti deleted file mode 100644 index 26aa5da6b1e..00000000000 --- a/src/data/FStar.Compiler.Path.fsti +++ /dev/null @@ -1,30 +0,0 @@ -(* - Copyright 2008-2017 Microsoft Research - - Authors: Aseem Rastogi, Nikhil Swamy, Jonathan Protzenko - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Compiler.Path - -open FStar.Class.Deq -open FStar.Class.Show - -type path a = list a - -type forest (a:Type) (qual:Type) = - list (path a & qual) & qual - -val is_under {| deq 'a |} (p1 p2 : path 'a) : bool - -val search_forest #a #q {| deq a |} (p:path a) (f : forest a q) : q \ No newline at end of file diff --git a/src/data/FStar.Compiler.RBSet.fst b/src/data/FStar.Compiler.RBSet.fst deleted file mode 100644 index 71929eb4df6..00000000000 --- a/src/data/FStar.Compiler.RBSet.fst +++ /dev/null @@ -1,173 +0,0 @@ -(* - Copyright 2008-2017 Microsoft Research - - Authors: Aseem Rastogi, Nikhil Swamy, Jonathan Protzenko - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Compiler.RBSet - -open FStar.Class.Ord -open FStar.Class.Show -open FStar.Class.Setlike - -include FStar.Class.Setlike - -type color = | R | B - -type rbset (a:Type0) : Type0 = - | L - | N of color & rbset a & a & rbset a - -let empty () = L - -let singleton (x:'a) : rbset 'a = N (R, L, x, L) - -let is_empty = L? - -let balance c l x r = - match c, l, x, r with - | B, N (R, N (R, a, x, b), y, c), z, d - | B, a, x, N (R, N (R, b, y, c), z, d) - | B, N (R, a, x, N (R, b, y, c)), z, d - | B, a, x, N (R, b, y, N (R, c, z, d)) -> - N (R, N (B, a, x, b), y, N (B, c, z, d)) - | c, l, x, r -> N (c, l, x, r) - -let blackroot (t:rbset 'a{N? t}) : rbset 'a = - match t with - | N (_, l, x, r) -> N (B, l, x, r) - -let add {| ord 'a |} (x:'a) (s:rbset 'a) : rbset 'a = - let rec add' (s:rbset 'a) : rbset 'a = - match s with - | L -> N (R, L, x, L) - | N (c, a, y, b) -> - if x ? y then balance c a y (add' b) - else s - in - blackroot (add' s) - -let rec extract_min #a {| ord a |} (t : rbset a{N? t}) : rbset a & a = - match t with - | N (_, L, x, r) -> r, x - | N (c, a, x, b) -> - let (a', y) = extract_min a in - balance c a' x b, y - -(* This is not the right way, see https://www.cs.cornell.edu/courses/cs3110/2020sp/a4/deletion.pdf -for how to do it. But if we reach that complexity, I would like for -this whole module to be verified. *) -let rec remove {| ord 'a |} (x:'a) (t:rbset 'a) : rbset 'a = - match t with - | L -> L - | N (c, l, y, r) -> - if x ? y then balance c l y (remove x r) - else - if L? r - then - l - else - let (r', y') = extract_min r in - balance c l y' r' - -let rec mem {| ord 'a |} (x:'a) (s:rbset 'a) : bool = - match s with - | L -> false - | N (_, a, y, b) -> - if x ? y then mem x b - else true - -let rec elems (s:rbset 'a) : list 'a = - match s with - | L -> [] - | N (_, a, x, b) -> elems a @ [x] @ elems b - -let equal {| ord 'a |} (s1:rbset 'a) (s2:rbset 'a) : bool = - elems s1 =? elems s2 - -let rec union {| ord 'a |} (s1:rbset 'a) (s2:rbset 'a) : rbset 'a = - match s1 with - | L -> s2 - | N (c, a, x, b) -> union a (union b (add x s2)) - -let inter {| ord 'a |} (s1:rbset 'a) (s2:rbset 'a) : rbset 'a = - let rec aux (s1:rbset 'a) (acc : rbset 'a) : rbset 'a = - match s1 with - | L -> acc - | N (_, a, x, b) -> - if mem x s2 - then add x (aux a (aux b acc)) - else aux a (aux b acc) - in - aux s1 L - -let rec diff {| ord 'a |} (s1:rbset 'a) (s2:rbset 'a) : rbset 'a = - match s2 with - | L -> s1 - | N (_, a, x, b) -> diff (diff (remove x s1) a) b - -let rec subset {| ord 'a |} (s1:rbset 'a) (s2:rbset 'a) : bool = - match s1 with - | L -> true - | N (_, a, x, b) -> mem x s2 && subset a s2 && subset b s2 - -let rec for_all (p:'a -> bool) (s:rbset 'a) : bool = - match s with - | L -> true - | N (_, a, x, b) -> p x && for_all p a && for_all p b - -let rec for_any (p:'a -> bool) (s:rbset 'a) : bool = - match s with - | L -> false - | N (_, a, x, b) -> p x || for_any p a || for_any p b - -// Make this faster -let from_list {| ord 'a |} (xs : list 'a) : rbset 'a = - List.fold_left (fun s e -> add e s) L xs - -let addn {| ord 'a |} (xs : list 'a) (s : rbset 'a) : rbset 'a = - List.fold_left (fun s e -> add e s) s xs - -let collect #a {| ord a |} (f : a -> rbset a) - (l : list a) : rbset a = - List.fold_left (fun s e -> union (f e) s) L l - -instance setlike_rbset (a:Type) (_ : ord a) : Tot (setlike a (rbset a)) = { - empty = empty; - singleton = singleton; - is_empty = is_empty; - add = add; - remove = remove; - mem = mem; - equal = equal; - subset = subset; - union = union; - inter = inter; - diff = diff; - for_all = for_all; - for_any = for_any; - elems = elems; - - collect = collect; - from_list = from_list; - addn = addn; -} - -instance showable_rbset (a:Type) (_ : showable a) : Tot (showable (rbset a)) = { - show = (fun s -> "RBSet " ^ show (elems s)); -} diff --git a/src/data/FStar.Compiler.RBSet.fsti b/src/data/FStar.Compiler.RBSet.fsti deleted file mode 100644 index 9f0ba48a0b5..00000000000 --- a/src/data/FStar.Compiler.RBSet.fsti +++ /dev/null @@ -1,35 +0,0 @@ -(* - Copyright 2008-2017 Microsoft Research - - Authors: Aseem Rastogi, Nikhil Swamy, Jonathan Protzenko - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Compiler.RBSet - -open FStar.Class.Ord -open FStar.Class.Show -open FStar.Class.Setlike -include FStar.Class.Setlike - -new -val rbset (a:Type0) : Type0 - -type t = rbset - -instance -val setlike_rbset (a:Type0) (_ : ord a) : Tot (setlike a (t a)) - -instance -val showable_rbset (a:Type0) (_ : showable a) : Tot (showable (t a)) diff --git a/src/data/FStar.Compiler.Writer.fst b/src/data/FStar.Compiler.Writer.fst deleted file mode 100644 index 89e0ce9eace..00000000000 --- a/src/data/FStar.Compiler.Writer.fst +++ /dev/null @@ -1,24 +0,0 @@ -module FStar.Compiler.Writer - -open FStar.Class.Monoid -open FStar.Class.Monad - -let writer_return #m {| monoid m |} #a (x:a) : writer m a = - Wr (mzero, x) - -let run_writer #m {| monoid m |} #a (x : writer m a) : m & a = - let Wr (m, x) = x in - (m, x) - -let writer_bind #m {| monoid m |} #a #b (x : writer m a) (f : a -> writer m b) : writer m b = - let Wr (a, x) = x in - let Wr (b, y) = f x in - Wr (mplus a b, y) - -instance monad_writer (m :_ ) (d : monoid m) : Tot (monad (writer m)) = { - return = writer_return; - ( let! ) = writer_bind; -} - -let emit #m {| monoid m |} (x : m) : writer m unit = - Wr (x, ()) diff --git a/src/data/FStar.Compiler.Writer.fsti b/src/data/FStar.Compiler.Writer.fsti deleted file mode 100644 index 7ed4f787e08..00000000000 --- a/src/data/FStar.Compiler.Writer.fsti +++ /dev/null @@ -1,13 +0,0 @@ -module FStar.Compiler.Writer - -open FStar.Class.Monoid -open FStar.Class.Monad - -type writer (m : Type) {| monoid m |} (a : Type0) = - | Wr of m & a - -val run_writer #m {| monoid m |} #a (x : writer m a) : m & a - -instance val monad_writer (m :_ ) (d : monoid m) : Tot (monad (writer m)) - -val emit #m {| monoid m |} (x : m) : writer m unit diff --git a/src/data/FStarC.Compiler.CList.fst b/src/data/FStarC.Compiler.CList.fst new file mode 100644 index 00000000000..3f333b01cfc --- /dev/null +++ b/src/data/FStarC.Compiler.CList.fst @@ -0,0 +1,103 @@ +(* + Copyright 2008-2017 Microsoft Research + + Authors: Aseem Rastogi, Nikhil Swamy, Jonathan Protzenko + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Compiler.CList + +open FStar.Tactics.Typeclasses +open FStarC.Class.Ord +open FStarC.Class.Listlike + +type clist (a:Type0) : Type0 = + | CNil : clist a + | CCons : a -> clist a -> clist a + | CCat : clist a -> clist a -> clist a + +let ccat (#a:Type0) (xs ys : clist a) : clist a = + match xs, ys with + | CNil, _ -> ys + | _, CNil -> xs + | _ -> CCat xs ys + +let rec view (#a:Type0) (l:clist a) : Tot (view_t a (clist a)) = + match l with + | CNil -> VNil + | CCons x xs -> VCons x xs + | CCat (CCat xs ys) zs -> view (CCat xs (CCat ys zs)) + | CCat xs ys -> + match view xs with + | VNil -> view ys + | VCons x xs' -> VCons x (CCat xs' ys) + +instance listlike_clist (a:Type0) : Tot (listlike a (t a)) = { + empty = CNil; + cons = CCons; + view = view; +} + +instance monoid_clist (a:Type0) : Tot (monoid (t a)) = { + mzero = CNil; + mplus = ccat; +} + +instance showable_clist (a:Type0) (_ : showable a) : Tot (showable (t a)) = { + show = (fun l -> show (to_list l)); +} + +instance eq_clist (a:Type0) (d : deq a) : Tot (deq (t a)) = { + (=?) = (fun l1 l2 -> to_list l1 =? to_list l2); +} + +instance ord_clist (a:Type0) (d : ord a) : Tot (ord (t a)) = { + super = solve; + cmp = (fun l1 l2 -> cmp (to_list l1) (to_list l2)); +} + +let rec map (#a #b : Type0) (f : a -> b) (l : clist a) : clist b = + match l with + | CNil -> CNil + | CCons x xs -> CCons (f x) (map f xs) + | CCat xs ys -> ccat (map f xs) (map f ys) + +let rec existsb (#a : Type0) (p : a -> bool) (l : clist a) : bool = + match l with + | CNil -> false + | CCons x xs -> p x || existsb p xs + | CCat xs ys -> existsb p xs || existsb p ys + +let rec for_all (#a : Type0) (p : a -> bool) (l : clist a) : bool = + match l with + | CNil -> true + | CCons x xs -> p x && for_all p xs + | CCat xs ys -> for_all p xs && for_all p ys + +let rec partition (#a : Type0) (p : a -> bool) (l : clist a) : clist a * clist a = + match l with + | CNil -> (CNil, CNil) + | CCons x xs -> + let (ys, zs) = partition p xs in + if p x then (CCons x ys, zs) else (ys, CCons x zs) + | CCat xs ys -> + let (ys, zs) = partition p xs in + let (us, vs) = partition p ys in + (ccat ys us, ccat zs vs) + +let rec collect (#a #b : Type0) (f : a -> clist b) (l : clist a) : clist b = + match l with + | CNil -> CNil + | CCons x xs -> ccat (f x) (collect f xs) + | CCat xs ys -> ccat (collect f xs) (collect f ys) diff --git a/src/data/FStarC.Compiler.CList.fsti b/src/data/FStarC.Compiler.CList.fsti new file mode 100644 index 00000000000..59650e3eb88 --- /dev/null +++ b/src/data/FStarC.Compiler.CList.fsti @@ -0,0 +1,47 @@ +(* + Copyright 2008-2017 Microsoft Research + + Authors: Aseem Rastogi, Nikhil Swamy, Jonathan Protzenko + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +(* Catenable lists, based on Jaskelioff and Rivas' "Functional Pearl: A Smart View on Datatypes" *) +module FStarC.Compiler.CList + +open FStarC.Class.Deq +open FStarC.Class.Ord +open FStarC.Class.Show +open FStarC.Class.Monoid +open FStarC.Class.Listlike + +new +val clist (a:Type0) : Type0 + +type t = clist + +instance val listlike_clist (a:Type0) : Tot (listlike a (t a)) +instance val monoid_clist (a:Type0) : Tot (monoid (t a)) +instance val showable_clist (a:Type0) (_ : showable a) : Tot (showable (t a)) +instance val eq_clist (a:Type0) (_ : deq a) : Tot (deq (t a)) +instance val ord_clist (a:Type0) (_ : ord a) : Tot (ord (t a)) + +val map (#a #b : Type0) (f : a -> b) (l : clist a) : clist b + +val existsb (#a : Type0) (p : a -> bool) (l : clist a) : bool + +val for_all (#a : Type0) (p : a -> bool) (l : clist a) : bool + +val partition (#a : Type0) (p : a -> bool) (l : clist a) : clist a * clist a + +val collect : ('a -> clist 'b) -> clist 'a -> clist 'b diff --git a/src/data/FStarC.Compiler.FlatSet.fst b/src/data/FStarC.Compiler.FlatSet.fst new file mode 100644 index 00000000000..938b55e7636 --- /dev/null +++ b/src/data/FStarC.Compiler.FlatSet.fst @@ -0,0 +1,113 @@ +(* + Copyright 2008-2017 Microsoft Research + + Authors: Aseem Rastogi, Nikhil Swamy, Jonathan Protzenko + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Compiler.FlatSet + +open FStarC.Class.Ord +open FStarC.Compiler.Effect +open FStarC.Compiler.Order +open FStarC.Compiler.Util + +(* This is a slow implementation that mimics FStarC.Compiler.Util.set, +which is implemented with lists. As it turns out we heavily rely on +the exact order of `elems` provided by this list representation, so we +cannot (yet) do big changes here. *) + +(* Inv: no duplication. We are left-biased. *) +let flat_set t = list t + +val add (#a:Type) {| ord a |} : a -> flat_set a -> flat_set a +let rec add x s = + match s with + | [] -> [x] + | y::yy -> if x =? y then s else y :: add x yy + +val empty (#a:Type) : unit -> flat_set a +let empty () = [] + +val from_list (#a:Type) {| ord a |} : list a -> flat_set a +let from_list xs = dedup xs + +val mem (#a:Type) {| ord a |} : a -> flat_set a -> bool +let mem x s = List.existsb (fun y -> x =? y) s + +val singleton (#a:Type) {| ord a |} : a -> flat_set a +let singleton x = [x] + +val is_empty (#a:Type) : flat_set a -> bool +let is_empty s = Nil? s + +val addn (#a:Type) {| ord a |} : list a -> flat_set a -> flat_set a +let addn xs ys = List.fold_right add xs ys + +val remove (#a:Type) {| ord a |} : a -> flat_set a -> flat_set a +let rec remove x s = + match s with + | [] -> [] + | y::yy -> if x =? y then yy else y :: remove x yy + +val elems (#a:Type) : flat_set a -> list a +let elems s = s + +val for_all (#a:Type) : (a -> bool) -> flat_set a -> bool +let for_all p s = elems s |> List.for_all p + +val for_any (#a:Type) : (a -> bool) -> flat_set a -> bool +let for_any p s = elems s |> List.existsb p + +val subset (#a:Type) {| ord a |} : flat_set a -> flat_set a -> bool +let subset s1 s2 = for_all (fun y -> mem y s2) s1 + +val equal (#a:Type) {| ord a |} : flat_set a -> flat_set a -> bool +let equal s1 s2 = sort s1 =? sort s2 + +val union (#a:Type) {| ord a |} : flat_set a -> flat_set a -> flat_set a +let union s1 s2 = List.fold_left (fun s x -> add x s) s1 s2 + +val inter (#a:Type) {| ord a |} : flat_set a -> flat_set a -> flat_set a +let inter s1 s2 = List.filter (fun y -> mem y s2) s1 + +val diff (#a:Type) {| ord a |} : flat_set a -> flat_set a -> flat_set a +let diff s1 s2 = List.filter (fun y -> not (mem y s2)) s1 + +val collect (#a #b:Type) {| ord b |} : (a -> flat_set b) -> list a -> flat_set b +let collect f l = List.fold_right (fun x acc -> f x `union` acc) l (empty ()) + +instance showable_set (a:Type) (_ : ord a) (_ : showable a) : Tot (showable (flat_set a)) = { + show = (fun s -> show (elems s)); +} + +instance setlike_flat_set (a:Type) (_ : ord a) : Tot (setlike a (flat_set a)) = { + empty = empty; + from_list = from_list; + singleton = singleton; + is_empty = is_empty; + add = add; + addn = addn; + remove = remove; + mem = mem; + elems = elems; + for_all = for_all; + for_any = for_any; + subset = subset; + equal = equal; + union = union; + inter = inter; + diff = diff; + collect = collect; +} diff --git a/src/data/FStarC.Compiler.FlatSet.fsti b/src/data/FStarC.Compiler.FlatSet.fsti new file mode 100644 index 00000000000..e26c23e2b52 --- /dev/null +++ b/src/data/FStarC.Compiler.FlatSet.fsti @@ -0,0 +1,33 @@ +(* + Copyright 2008-2017 Microsoft Research + + Authors: Aseem Rastogi, Nikhil Swamy, Jonathan Protzenko + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Compiler.FlatSet + +open FStarC.Class.Ord +open FStarC.Class.Show +open FStarC.Class.Setlike +include FStarC.Class.Setlike + +val flat_set (a:Type0) : Type0 +type t = flat_set + +instance +val showable_set (a:Type) (_ : ord a) (_ : showable a) : Tot (showable (flat_set a)) + +instance +val setlike_flat_set (a:Type0) (_ : ord a) : Tot (setlike a (flat_set a)) diff --git a/src/data/FStarC.Compiler.Path.fst b/src/data/FStarC.Compiler.Path.fst new file mode 100644 index 00000000000..3449a059ca9 --- /dev/null +++ b/src/data/FStarC.Compiler.Path.fst @@ -0,0 +1,35 @@ +(* + Copyright 2008-2017 Microsoft Research + + Authors: Aseem Rastogi, Nikhil Swamy, Jonathan Protzenko + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Compiler.Path + +open FStarC.Class.Deq + +let rec is_under {| deq 'a |} (p1 p2 : path 'a) : bool = + match p1, p2 with + | _, [] -> true + | [], _ -> false + | h1::t1, h2::t2 -> h1 =? h2 && is_under t1 t2 + +let search_forest #a #q {| deq a |} p f = + let roots, def = f in + let rec aux (roots : list (path a & q)) : q = + match roots with + | [] -> def + | (r, q)::rs -> if p `is_under` r then q else aux rs + in + aux roots diff --git a/src/data/FStarC.Compiler.Path.fsti b/src/data/FStarC.Compiler.Path.fsti new file mode 100644 index 00000000000..db7af195392 --- /dev/null +++ b/src/data/FStarC.Compiler.Path.fsti @@ -0,0 +1,30 @@ +(* + Copyright 2008-2017 Microsoft Research + + Authors: Aseem Rastogi, Nikhil Swamy, Jonathan Protzenko + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Compiler.Path + +open FStarC.Class.Deq +open FStarC.Class.Show + +type path a = list a + +type forest (a:Type) (qual:Type) = + list (path a & qual) & qual + +val is_under {| deq 'a |} (p1 p2 : path 'a) : bool + +val search_forest #a #q {| deq a |} (p:path a) (f : forest a q) : q \ No newline at end of file diff --git a/src/data/FStarC.Compiler.RBSet.fst b/src/data/FStarC.Compiler.RBSet.fst new file mode 100644 index 00000000000..543f2091f7f --- /dev/null +++ b/src/data/FStarC.Compiler.RBSet.fst @@ -0,0 +1,173 @@ +(* + Copyright 2008-2017 Microsoft Research + + Authors: Aseem Rastogi, Nikhil Swamy, Jonathan Protzenko + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Compiler.RBSet + +open FStarC.Class.Ord +open FStarC.Class.Show +open FStarC.Class.Setlike + +include FStarC.Class.Setlike + +type color = | R | B + +type rbset (a:Type0) : Type0 = + | L + | N of color & rbset a & a & rbset a + +let empty () = L + +let singleton (x:'a) : rbset 'a = N (R, L, x, L) + +let is_empty = L? + +let balance c l x r = + match c, l, x, r with + | B, N (R, N (R, a, x, b), y, c), z, d + | B, a, x, N (R, N (R, b, y, c), z, d) + | B, N (R, a, x, N (R, b, y, c)), z, d + | B, a, x, N (R, b, y, N (R, c, z, d)) -> + N (R, N (B, a, x, b), y, N (B, c, z, d)) + | c, l, x, r -> N (c, l, x, r) + +let blackroot (t:rbset 'a{N? t}) : rbset 'a = + match t with + | N (_, l, x, r) -> N (B, l, x, r) + +let add {| ord 'a |} (x:'a) (s:rbset 'a) : rbset 'a = + let rec add' (s:rbset 'a) : rbset 'a = + match s with + | L -> N (R, L, x, L) + | N (c, a, y, b) -> + if x ? y then balance c a y (add' b) + else s + in + blackroot (add' s) + +let rec extract_min #a {| ord a |} (t : rbset a{N? t}) : rbset a & a = + match t with + | N (_, L, x, r) -> r, x + | N (c, a, x, b) -> + let (a', y) = extract_min a in + balance c a' x b, y + +(* This is not the right way, see https://www.cs.cornell.edu/courses/cs3110/2020sp/a4/deletion.pdf +for how to do it. But if we reach that complexity, I would like for +this whole module to be verified. *) +let rec remove {| ord 'a |} (x:'a) (t:rbset 'a) : rbset 'a = + match t with + | L -> L + | N (c, l, y, r) -> + if x ? y then balance c l y (remove x r) + else + if L? r + then + l + else + let (r', y') = extract_min r in + balance c l y' r' + +let rec mem {| ord 'a |} (x:'a) (s:rbset 'a) : bool = + match s with + | L -> false + | N (_, a, y, b) -> + if x ? y then mem x b + else true + +let rec elems (s:rbset 'a) : list 'a = + match s with + | L -> [] + | N (_, a, x, b) -> elems a @ [x] @ elems b + +let equal {| ord 'a |} (s1:rbset 'a) (s2:rbset 'a) : bool = + elems s1 =? elems s2 + +let rec union {| ord 'a |} (s1:rbset 'a) (s2:rbset 'a) : rbset 'a = + match s1 with + | L -> s2 + | N (c, a, x, b) -> union a (union b (add x s2)) + +let inter {| ord 'a |} (s1:rbset 'a) (s2:rbset 'a) : rbset 'a = + let rec aux (s1:rbset 'a) (acc : rbset 'a) : rbset 'a = + match s1 with + | L -> acc + | N (_, a, x, b) -> + if mem x s2 + then add x (aux a (aux b acc)) + else aux a (aux b acc) + in + aux s1 L + +let rec diff {| ord 'a |} (s1:rbset 'a) (s2:rbset 'a) : rbset 'a = + match s2 with + | L -> s1 + | N (_, a, x, b) -> diff (diff (remove x s1) a) b + +let rec subset {| ord 'a |} (s1:rbset 'a) (s2:rbset 'a) : bool = + match s1 with + | L -> true + | N (_, a, x, b) -> mem x s2 && subset a s2 && subset b s2 + +let rec for_all (p:'a -> bool) (s:rbset 'a) : bool = + match s with + | L -> true + | N (_, a, x, b) -> p x && for_all p a && for_all p b + +let rec for_any (p:'a -> bool) (s:rbset 'a) : bool = + match s with + | L -> false + | N (_, a, x, b) -> p x || for_any p a || for_any p b + +// Make this faster +let from_list {| ord 'a |} (xs : list 'a) : rbset 'a = + List.fold_left (fun s e -> add e s) L xs + +let addn {| ord 'a |} (xs : list 'a) (s : rbset 'a) : rbset 'a = + List.fold_left (fun s e -> add e s) s xs + +let collect #a {| ord a |} (f : a -> rbset a) + (l : list a) : rbset a = + List.fold_left (fun s e -> union (f e) s) L l + +instance setlike_rbset (a:Type) (_ : ord a) : Tot (setlike a (rbset a)) = { + empty = empty; + singleton = singleton; + is_empty = is_empty; + add = add; + remove = remove; + mem = mem; + equal = equal; + subset = subset; + union = union; + inter = inter; + diff = diff; + for_all = for_all; + for_any = for_any; + elems = elems; + + collect = collect; + from_list = from_list; + addn = addn; +} + +instance showable_rbset (a:Type) (_ : showable a) : Tot (showable (rbset a)) = { + show = (fun s -> "RBSet " ^ show (elems s)); +} diff --git a/src/data/FStarC.Compiler.RBSet.fsti b/src/data/FStarC.Compiler.RBSet.fsti new file mode 100644 index 00000000000..98a74adb33c --- /dev/null +++ b/src/data/FStarC.Compiler.RBSet.fsti @@ -0,0 +1,35 @@ +(* + Copyright 2008-2017 Microsoft Research + + Authors: Aseem Rastogi, Nikhil Swamy, Jonathan Protzenko + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Compiler.RBSet + +open FStarC.Class.Ord +open FStarC.Class.Show +open FStarC.Class.Setlike +include FStarC.Class.Setlike + +new +val rbset (a:Type0) : Type0 + +type t = rbset + +instance +val setlike_rbset (a:Type0) (_ : ord a) : Tot (setlike a (t a)) + +instance +val showable_rbset (a:Type0) (_ : showable a) : Tot (showable (t a)) diff --git a/src/data/FStarC.Compiler.Writer.fst b/src/data/FStarC.Compiler.Writer.fst new file mode 100644 index 00000000000..15c7beb186f --- /dev/null +++ b/src/data/FStarC.Compiler.Writer.fst @@ -0,0 +1,24 @@ +module FStarC.Compiler.Writer + +open FStarC.Class.Monoid +open FStarC.Class.Monad + +let writer_return #m {| monoid m |} #a (x:a) : writer m a = + Wr (mzero, x) + +let run_writer #m {| monoid m |} #a (x : writer m a) : m & a = + let Wr (m, x) = x in + (m, x) + +let writer_bind #m {| monoid m |} #a #b (x : writer m a) (f : a -> writer m b) : writer m b = + let Wr (a, x) = x in + let Wr (b, y) = f x in + Wr (mplus a b, y) + +instance monad_writer (m :_ ) (d : monoid m) : Tot (monad (writer m)) = { + return = writer_return; + ( let! ) = writer_bind; +} + +let emit #m {| monoid m |} (x : m) : writer m unit = + Wr (x, ()) diff --git a/src/data/FStarC.Compiler.Writer.fsti b/src/data/FStarC.Compiler.Writer.fsti new file mode 100644 index 00000000000..2074f053514 --- /dev/null +++ b/src/data/FStarC.Compiler.Writer.fsti @@ -0,0 +1,13 @@ +module FStarC.Compiler.Writer + +open FStarC.Class.Monoid +open FStarC.Class.Monad + +type writer (m : Type) {| monoid m |} (a : Type0) = + | Wr of m & a + +val run_writer #m {| monoid m |} #a (x : writer m a) : m & a + +instance val monad_writer (m :_ ) (d : monoid m) : Tot (monad (writer m)) + +val emit #m {| monoid m |} (x : m) : writer m unit diff --git a/src/extraction/FStar.Extraction.Krml.fst b/src/extraction/FStar.Extraction.Krml.fst deleted file mode 100644 index 8e3568c8acd..00000000000 --- a/src/extraction/FStar.Extraction.Krml.fst +++ /dev/null @@ -1,1546 +0,0 @@ -(* - Copyright 2008-2015 Abhishek Anand, Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -(* -------------------------------------------------------------------- *) - -module FStar.Extraction.Krml -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.Compiler.Util -open FStar.Extraction -open FStar.Extraction.ML -open FStar.Extraction.ML.Syntax -open FStar.Extraction.ML.UEnv -open FStar.Const -open FStar.BaseTypes - -open FStar.Class.Show -open FStar.Class.PP -open FStar.Pprint - -module BU = FStar.Compiler.Util -module FC = FStar.Const - -(** CHANGELOG -- v24: Added a single constructor to the expression type to reflect the addition - of type applications to the ML extraction language. -- v25: Added a number of type parameters for globals. -- v26: Flags for DExternal and all the DType's -- v27: Added PConstant -- v28: added many things for which the AST wasn't bumped; bumped it for - TConstBuf which will expect will be used soon -- v29: added a SizeT and PtrdiffT width to machine integers -- v30: Added EBufDiff -- v31: Added a `meta` field to binders. Currently only relevant to propagate `CInline`. -*) -let current_version: version = 31 - -(* COPY-PASTED ****************************************************************) - -type decl = - | DGlobal of list flag & lident & int & typ & expr - | DFunction of option cc & list flag & int & typ & lident & list binder & expr - | DTypeAlias of lident & list flag & int & typ - | DTypeFlat of lident & list flag & int & fields_t - | DUnusedRetainedForBackwardsCompat of option cc & list flag & lident & typ - | DTypeVariant of lident & list flag & int & branches_t - | DTypeAbstractStruct of lident - | DExternal of option cc & list flag & lident & typ & list ident - | DUntaggedUnion of lident & list flag & int & list (ident & typ) - -and cc = - | StdCall - | CDecl - | FastCall - -and fields_t = - list (ident & (typ & bool)) - -and branches_t = - list (ident & fields_t) - -and flag = - | Private - | WipeBody - | CInline - | Substitute - | GCType - | Comment of string - | MustDisappear - | Const of string - | Prologue of string - | Epilogue of string - | Abstract - | IfDef - | Macro - | Deprecated of string - | CNoInline - -and fsdoc = string - -and lifetime = - | Eternal - | Stack - | ManuallyManaged - -and expr = - | EBound of var - | EQualified of lident - | EConstant of constant - | EUnit - | EApp of expr & list expr - | ETypApp of expr & list typ - | ELet of binder & expr & expr - | EIfThenElse of expr & expr & expr - | ESequence of list expr - | EAssign of expr & expr - | (** left expression can only be a EBound of EOpen *) - EBufCreate of lifetime & expr & expr - | EBufRead of expr & expr - | EBufWrite of expr & expr & expr - | EBufSub of expr & expr - | EBufBlit of expr & expr & expr & expr & expr - | EMatch of expr & branches - | EOp of op & width - | ECast of expr & typ - | EPushFrame - | EPopFrame - | EBool of bool - | EAny - | EAbort - | EReturn of expr - | EFlat of typ & list (ident & expr) - | EField of typ & expr & ident - | EWhile of expr & expr - | EBufCreateL of lifetime & list expr - | ETuple of list expr - | ECons of typ & ident & list expr - | EBufFill of expr & expr & expr - | EString of string - | EFun of list binder & expr & typ - | EAbortS of string - | EBufFree of expr - | EBufCreateNoInit of lifetime & expr - | EAbortT of string & typ - | EComment of string & expr & string - | EStandaloneComment of string - | EAddrOf of expr - | EBufNull of typ - | EBufDiff of expr & expr - -and op = - | Add | AddW | Sub | SubW | Div | DivW | Mult | MultW | Mod - | BOr | BAnd | BXor | BShiftL | BShiftR | BNot - | Eq | Neq | Lt | Lte | Gt | Gte - | And | Or | Xor | Not - -and branches = - list branch - -and branch = - pattern & expr - -and pattern = - | PUnit - | PBool of bool - | PVar of binder - | PCons of (ident & list pattern) - | PTuple of list pattern - | PRecord of list (ident & pattern) - | PConstant of constant - -and width = - | UInt8 | UInt16 | UInt32 | UInt64 - | Int8 | Int16 | Int32 | Int64 - | Bool - | CInt - | SizeT | PtrdiffT - -and constant = width & string - -(* a De Bruijn index *) -and var = int - -and binder = { - name: ident; - typ: typ; - mut: bool; - meta: list flag; -} - -(* for pretty-printing *) -and ident = string - -and lident = - list ident & ident - -and typ = - | TInt of width - | TBuf of typ - | TUnit - | TQualified of lident - | TBool - | TAny - | TArrow of typ & typ - | TBound of int - | TApp of lident & list typ - | TTuple of list typ - | TConstBuf of typ - | TArray of typ & constant - -instance pretty_width = { pp = function - | UInt8 -> doc_of_string "UInt8" - | UInt16 -> doc_of_string "UInt16" - | UInt32 -> doc_of_string "UInt32" - | UInt64 -> doc_of_string "UInt64" - | Int8 -> doc_of_string "Int8" - | Int16 -> doc_of_string "Int16" - | Int32 -> doc_of_string "Int32" - | Int64 -> doc_of_string "Int64" - | Bool -> doc_of_string "Bool" - | CInt -> doc_of_string "CInt" - | SizeT -> doc_of_string "SizeT" - | PtrdiffT -> doc_of_string "PtrdiffT" -} - -let record_string (fs : list (string & string)) : string = - "{" ^ - (String.concat "; " <| List.map (fun (f, s) -> f ^ " = " ^ s) fs) ^ - "}" - -let ctor (n: string) (args: list document) = - nest 2 (group (parens (flow (break_ 1) (doc_of_string n :: args)))) -// let ctor (n: string) (arg: document) : document = -// nest 2 (group (parens (doc_of_string n ^/^ arg))) - -let pp_list' (#a:Type) (f: a -> document) (xs: list a) : document = - (pp_list a { pp = f }).pp xs // hack - -let rec typ_to_doc (t:typ) : document = - match t with - | TInt w -> ctor "TInt" [pp w] - | TBuf t -> ctor "TBuf" [typ_to_doc t] - | TUnit -> doc_of_string "TUnit" - | TQualified x -> ctor "TQualified" [doc_of_string (show x)] - | TBool -> doc_of_string "TBool" - | TAny -> doc_of_string "TAny" - | TArrow (t1, t2) -> ctor "TArrow" [typ_to_doc t1; typ_to_doc t2] - | TBound x -> ctor "TBound" [pp x] - | TApp (x, xs) -> ctor "TApp" [doc_of_string (show x); pp_list' typ_to_doc xs] - | TTuple ts -> ctor "TTuple" [pp_list' typ_to_doc ts] - | TConstBuf t -> ctor "TConstBuf" [typ_to_doc t] - | TArray (t, c) -> ctor "TArray" [typ_to_doc t; parens (separate comma [pp (fst c); doc_of_string (snd c)])] - -instance pretty_typ = { pp = typ_to_doc } - -instance pretty_string = { pp = (fun s -> dquotes (doc_of_string s)) } - -instance pretty_flag = { pp = function - | Private -> doc_of_string "Private" - | WipeBody -> doc_of_string "WipeBody" - | CInline -> doc_of_string "CInline" - | Substitute -> doc_of_string "Substitute" - | GCType -> doc_of_string "GCType" - | Comment s -> ctor "Comment" [pp s] - | MustDisappear -> doc_of_string "MustDisappear" - | Const s -> ctor "Const" [pp s] - | Prologue s -> ctor "Prologue" [pp s] - | Epilogue s -> ctor "Epilogue" [pp s] - | Abstract -> doc_of_string "Abstract" - | IfDef -> doc_of_string "IfDef" - | Macro -> doc_of_string "Macro" - | Deprecated s -> ctor "Deprecated" [pp s] - | CNoInline -> doc_of_string "CNoInline" -} - -let spaced a = break_ 1 ^^ a ^^ break_ 1 -let record fs = - group <| nest 2 <| braces <| spaced <| separate (semi ^^ break_ 1) fs -let fld n v = group <| nest 2 <| doc_of_string (n ^ " =") ^/^ v - -instance pretty_binder = { pp = fun b -> - record [ - fld "name" (pp b.name); - fld "typ" (pp b.typ); - fld "mut" (pp b.mut); - fld "meta" (pp b.meta); - ] -} - -instance pretty_lifetime : pretty lifetime = { pp = function - | Eternal -> doc_of_string "Eternal" - | Stack -> doc_of_string "Stack" - | ManuallyManaged -> doc_of_string "ManuallyManaged" -} - -instance pretty_op = { pp = function - | Add -> doc_of_string "Add" - | AddW -> doc_of_string "AddW" - | Sub -> doc_of_string "Sub" - | SubW -> doc_of_string "SubW" - | Div -> doc_of_string "Div" - | DivW -> doc_of_string "DivW" - | Mult -> doc_of_string "Mult" - | MultW -> doc_of_string "MultW" - | Mod -> doc_of_string "Mod" - | BOr -> doc_of_string "BOr" - | BAnd -> doc_of_string "BAnd" - | BXor -> doc_of_string "BXor" - | BShiftL -> doc_of_string "BShiftL" - | BShiftR -> doc_of_string "BShiftR" - | BNot -> doc_of_string "BNot" - | Eq -> doc_of_string "Eq" - | Neq -> doc_of_string "Neq" - | Lt -> doc_of_string "Lt" - | Lte -> doc_of_string "Lte" - | Gt -> doc_of_string "Gt" - | Gte -> doc_of_string "Gte" - | And -> doc_of_string "And" - | Or -> doc_of_string "Or" - | Xor -> doc_of_string "Xor" - | Not -> doc_of_string "Not" -} - -instance pretty_cc = { pp = function - | StdCall -> doc_of_string "StdCall" - | CDecl -> doc_of_string "CDecl" - | FastCall -> doc_of_string "FastCall" -} - -let rec pattern_to_doc (p:pattern) : document = - match p with - | PUnit -> doc_of_string "PUnit" - | PBool b -> ctor "PBool" [pp b] - | PVar b -> ctor "PVar" [pp b] - | PCons (x, ps) -> ctor "PCons" [pp x; pp_list' pattern_to_doc ps] - | PTuple ps -> ctor "PTuple" [pp_list' pattern_to_doc ps] - | PRecord fs -> ctor "PRecord" [record (List.map (fun (s, p) -> fld s (pattern_to_doc p)) fs)] - | PConstant c -> ctor "PConstant" [pp c] - -instance pretty_pattern = { pp = pattern_to_doc } - -let rec decl_to_doc (d:decl) : document = - match d with - | DGlobal (fs, x, i, t, e) -> ctor "DGlobal" [pp fs; pp x; pp i; pp t; expr_to_doc e] - | DFunction (cc, fs, i, t, x, bs, e) -> ctor "DFunction" [pp cc; pp fs; pp i; pp t; pp x; pp bs; expr_to_doc e] - | DTypeAlias (x, fs, i, t) -> ctor "DTypeAlias" [pp x; pp fs; pp i; pp t] - | DTypeFlat (x, fs, i, f) -> ctor "DTypeFlat" [pp x; pp fs; pp i; pp f] - | DUnusedRetainedForBackwardsCompat (cc, fs, x, t) -> ctor "DUnusedRetainedForBackwardsCompat" [pp cc; pp fs; pp x; pp t] - | DTypeVariant (x, fs, i, bs) -> ctor "DTypeVariant" [pp x; pp fs; pp i; pp bs] - | DTypeAbstractStruct x -> ctor "DTypeAbstractStruct" [pp x] - | DExternal (cc, fs, x, t, xs) -> ctor "DExternal" [pp cc; pp fs; pp x; pp t; pp xs] - | DUntaggedUnion (x, fs, i, xs) -> ctor "DUntaggedUnion" [pp x; pp fs; pp i; pp xs] - -and expr_to_doc (e:expr) : document = - match e with - | EBound x -> ctor "EBound" [pp x] - | EQualified x -> ctor "EQualified" [pp x] - | EConstant x -> ctor "EConstant" [pp x] - | EUnit -> doc_of_string "EUnit" - | EApp (x, xs) -> ctor "EApp" [expr_to_doc x; pp_list' expr_to_doc xs] - | ETypApp (x, xs) -> ctor "ETypApp" [expr_to_doc x; pp xs] - | ELet (x, y, z) -> ctor "ELet" [pp x; expr_to_doc y; expr_to_doc z] - | EIfThenElse (x, y, z) -> ctor "EIfThenElse" [expr_to_doc x; expr_to_doc y; expr_to_doc z] - | ESequence xs -> ctor "ESequence" [pp_list' expr_to_doc xs] - | EAssign (x, y) -> ctor "EAssign" [expr_to_doc x; expr_to_doc y] - | EBufCreate (x, y, z) -> ctor "EBufCreate" [pp x; expr_to_doc y; expr_to_doc z] - | EBufRead (x, y) -> ctor "EBufRead" [expr_to_doc x; expr_to_doc y] - | EBufWrite (x, y, z) -> ctor "EBufWrite" [expr_to_doc x; expr_to_doc y; expr_to_doc z] - | EBufSub (x, y) -> ctor "EBufSub" [expr_to_doc x; expr_to_doc y] - | EBufBlit (x, y, z, a, b) -> ctor "EBufBlit" [expr_to_doc x; expr_to_doc y; expr_to_doc z; expr_to_doc a; expr_to_doc b] - | EMatch (x, bs) -> ctor "EMatch" [expr_to_doc x; pp_list' pp_branch bs] - | EOp (x, y) -> ctor "EOp" [pp x; pp y] - | ECast (x, y) -> ctor "ECast" [expr_to_doc x; pp y] - | EPushFrame -> doc_of_string "EPushFrame" - | EPopFrame -> doc_of_string "EPopFrame" - | EBool x -> ctor "EBool" [pp x] - | EAny -> doc_of_string "EAny" - | EAbort -> doc_of_string "EAbort" - | EReturn x -> ctor "EReturn" [expr_to_doc x] - | EFlat (x, xs) -> ctor "EFlat" [pp x; record (List.map (fun (s, e) -> fld s (expr_to_doc e)) xs)] - | EField (x, y, z) -> ctor "EField" [pp x; expr_to_doc y; pp z] - | EWhile (x, y) -> ctor "EWhile" [expr_to_doc x; expr_to_doc y] - | EBufCreateL (x, xs) -> ctor "EBufCreateL" [pp x; pp_list' expr_to_doc xs] - | ETuple xs -> ctor "ETuple" [pp_list' expr_to_doc xs] - | ECons (x, y, xs) -> ctor "ECons" [pp x; pp y; pp_list' expr_to_doc xs] - | EBufFill (x, y, z) -> ctor "EBufFill" [expr_to_doc x; expr_to_doc y; expr_to_doc z] - | EString x -> ctor "EString" [pp x] - | EFun (xs, y, z) -> ctor "EFun" [pp_list' pp xs; expr_to_doc y; pp z] - | EAbortS x -> ctor "EAbortS" [pp x] - | EBufFree x -> ctor "EBufFree" [expr_to_doc x] - | EBufCreateNoInit (x, y) -> ctor "EBufCreateNoInit" [pp x; expr_to_doc y] - | EAbortT (x, y) -> ctor "EAbortT" [pp x; pp y] - | EComment (x, y, z) -> ctor "EComment" [pp x; expr_to_doc y; pp z] - | EStandaloneComment x -> ctor "EStandaloneComment" [pp x] - | EAddrOf x -> ctor "EAddrOf" [expr_to_doc x] - | EBufNull x -> ctor "EBufNull" [pp x] - | EBufDiff (x, y) -> ctor "EBufDiff" [expr_to_doc x; expr_to_doc y] - -and pp_branch (b:branch) : document = - let (p, e) = b in - parens (pp p ^^ comma ^/^ expr_to_doc e) - -instance pretty_decl : pretty decl = { pp = decl_to_doc; } -instance showable_decl : showable decl = showable_from_pretty - -(* Utilities *****************************************************************) - -let fst3 (x, _, _) = x -let snd3 (_, x, _) = x -let thd3 (_, _, x) = x - -let mk_width = function - | "UInt8" -> Some UInt8 - | "UInt16" -> Some UInt16 - | "UInt32" -> Some UInt32 - | "UInt64" -> Some UInt64 - | "Int8" -> Some Int8 - | "Int16" -> Some Int16 - | "Int32" -> Some Int32 - | "Int64" -> Some Int64 - | "SizeT" -> Some SizeT - | "PtrdiffT" -> Some PtrdiffT - | _ -> None - -let mk_bool_op = function - | "op_Negation" -> - Some Not - | "op_AmpAmp" -> - Some And - | "op_BarBar" -> - Some Or - | "op_Equality" -> - Some Eq - | "op_disEquality" -> - Some Neq - | _ -> - None - -let is_bool_op op = - mk_bool_op op <> None - -let mk_op = function - | "add" | "op_Plus_Hat" | "add_underspec" -> - Some Add - | "add_mod" | "op_Plus_Percent_Hat" -> - Some AddW - | "sub" | "op_Subtraction_Hat" | "sub_underspec" -> - Some Sub - | "sub_mod" | "op_Subtraction_Percent_Hat" -> - Some SubW - | "mul" | "op_Star_Hat" | "mul_underspec" -> - Some Mult - | "mul_mod" | "op_Star_Percent_Hat" -> - Some MultW - | "div" | "op_Slash_Hat" -> - Some Div - | "div_mod" | "op_Slash_Percent_Hat" -> - Some DivW - | "rem" | "op_Percent_Hat" -> - Some Mod - | "logor" | "op_Bar_Hat" -> - Some BOr - | "logxor" | "op_Hat_Hat" -> - Some BXor - | "logand" | "op_Amp_Hat" -> - Some BAnd - | "lognot" -> - Some BNot - | "shift_right" | "op_Greater_Greater_Hat" -> - Some BShiftR - | "shift_left" | "op_Less_Less_Hat" -> - Some BShiftL - | "eq" | "op_Equals_Hat" -> - Some Eq - | "op_Greater_Hat" | "gt" -> - Some Gt - | "op_Greater_Equals_Hat" | "gte" -> - Some Gte - | "op_Less_Hat" | "lt" -> - Some Lt - | "op_Less_Equals_Hat" | "lte" -> - Some Lte - | _ -> - None - -let is_op op = - mk_op op <> None - -let is_machine_int m = - mk_width m <> None - -(* Environments **************************************************************) - -type env = { - uenv : uenv; - names: list name; - names_t: list string; - module_name: list string; -} - -and name = { - pretty: string; -} - -let empty uenv module_name = { - uenv = uenv; - names = []; - names_t = []; - module_name = module_name -} - -let extend env x = - { env with names = { pretty = x } :: env.names } - -let extend_t env x = - { env with names_t = x :: env.names_t } - -let find_name env x = - match List.tryFind (fun name -> name.pretty = x) env.names with - | Some name -> - name - | None -> - failwith "internal error: name not found" - -let find env x = - try - List.index (fun name -> name.pretty = x) env.names - with _ -> - failwith (BU.format1 "Internal error: name not found %s\n" x) - -let find_t env x = - try - List.index (fun name -> name = x) env.names_t - with _ -> - failwith (BU.format1 "Internal error: name not found %s\n" x) - -let add_binders env bs = - List.fold_left (fun env {mlbinder_name} -> extend env mlbinder_name) env bs - -(* Actual translation ********************************************************) - -let list_elements e = - let lopt = FStar.Extraction.ML.Util.list_elements e in - match lopt with - | None -> failwith "Argument of FStar.Buffer.createL is not a list literal!" - | Some l -> l - -let translate_flags flags = - List.choose (function - | Syntax.Private -> Some Private - | Syntax.NoExtract -> Some WipeBody - | Syntax.CInline -> Some CInline - | Syntax.CNoInline -> Some CNoInline - | Syntax.Substitute -> Some Substitute - | Syntax.GCType -> Some GCType - | Syntax.Comment s -> Some (Comment s) - | Syntax.StackInline -> Some MustDisappear - | Syntax.CConst s -> Some (Const s) - | Syntax.CPrologue s -> Some (Prologue s) - | Syntax.CEpilogue s -> Some (Epilogue s) - | Syntax.CAbstract -> Some Abstract - | Syntax.CIfDef -> Some IfDef - | Syntax.CMacro -> Some Macro - | Syntax.Deprecated s -> Some (Deprecated s) - | _ -> None // is this all of them? - ) flags - -let translate_cc flags = - match List.choose (function | Syntax.CCConv s -> Some s | _ -> None) flags with - | [ "stdcall" ] -> Some StdCall - | [ "fastcall" ] -> Some FastCall - | [ "cdecl" ] -> Some CDecl - | _ -> None - -(* Per FStarLang/karamel#324 *) -let generate_is_null - (t: typ) - (x: expr) -: Tot expr -= let dummy = UInt64 in - EApp (ETypApp (EOp (Eq, dummy), [TBuf t]), [x; EBufNull t]) - -exception NotSupportedByKrmlExtension - -let translate_type_without_decay_t = env -> mlty -> ML typ -let ref_translate_type_without_decay : ref translate_type_without_decay_t = mk_ref (fun _ _ -> raise NotSupportedByKrmlExtension) -let register_pre_translate_type_without_decay - (f: translate_type_without_decay_t) -: ML unit -= let before : translate_type_without_decay_t = !ref_translate_type_without_decay in - let after : translate_type_without_decay_t = fun e t -> - try - f e t - with NotSupportedByKrmlExtension -> before e t - in - ref_translate_type_without_decay := after -let register_post_translate_type_without_decay - (f: translate_type_without_decay_t) -: ML unit -= let before : translate_type_without_decay_t = !ref_translate_type_without_decay in - let after : translate_type_without_decay_t = fun e t -> - try - before e t - with NotSupportedByKrmlExtension -> f e t - in - ref_translate_type_without_decay := after -let translate_type_without_decay env t = !ref_translate_type_without_decay env t - -// The outermost array type constructor decays to pointer -let translate_type_t = env -> mlty -> ML typ -let ref_translate_type : ref translate_type_t = mk_ref (fun _ _ -> raise NotSupportedByKrmlExtension) -let register_pre_translate_type - (f: translate_type_t) -: ML unit -= let before : translate_type_t = !ref_translate_type in - let after : translate_type_t = fun e t -> - try - f e t - with NotSupportedByKrmlExtension -> before e t - in - ref_translate_type := after -let register_post_translate_type - (f: translate_type_t) -: ML unit -= let before : translate_type_t = !ref_translate_type in - let after : translate_type_t = fun e t -> - try - before e t - with NotSupportedByKrmlExtension -> f e t - in - ref_translate_type := after -let translate_type env t = !ref_translate_type env t - -let translate_expr_t = env -> mlexpr -> ML expr -let ref_translate_expr : ref translate_expr_t = mk_ref (fun _ _ -> raise NotSupportedByKrmlExtension) -let register_pre_translate_expr - (f: translate_expr_t) -: ML unit -= let before : translate_expr_t = !ref_translate_expr in - let after : translate_expr_t = fun e t -> - try - f e t - with NotSupportedByKrmlExtension -> before e t - in - ref_translate_expr := after -let register_post_translate_expr - (f: translate_expr_t) -: ML unit -= let before : translate_expr_t = !ref_translate_expr in - let after : translate_expr_t = fun e t -> - try - before e t - with NotSupportedByKrmlExtension -> f e t - in - ref_translate_expr := after -let translate_expr (env: env) (e: mlexpr) = !ref_translate_expr env e - -let translate_type_decl_t = env -> one_mltydecl -> ML (option decl) -let ref_translate_type_decl : ref translate_type_decl_t = mk_ref (fun _ _ -> raise NotSupportedByKrmlExtension) -let register_pre_translate_type_decl - (f: translate_type_decl_t) -: ML unit -= let before : translate_type_decl_t = !ref_translate_type_decl in - let after : translate_type_decl_t = fun e t -> - try - f e t - with NotSupportedByKrmlExtension -> before e t - in - ref_translate_type_decl := after -let register_post_translate_type_decl - (f: translate_type_decl_t) -: ML unit -= let before : translate_type_decl_t = !ref_translate_type_decl in - let after : translate_type_decl_t = fun e t -> - try - before e t - with NotSupportedByKrmlExtension -> f e t - in - ref_translate_type_decl := after -let translate_type_decl env ty: option decl = - if List.mem Syntax.NoExtract ty.tydecl_meta then - None - else - !ref_translate_type_decl env ty - -let rec translate_type_without_decay' env t: typ = - match t with - | MLTY_Tuple [] - | MLTY_Top -> - TAny - | MLTY_Var name -> - TBound (find_t env name) - | MLTY_Fun (t1, _, t2) -> - TArrow (translate_type_without_decay env t1, translate_type_without_decay env t2) - | MLTY_Erased -> - TUnit - | MLTY_Named ([], p) when (Syntax.string_of_mlpath p = "Prims.unit") -> - TUnit - | MLTY_Named ([], p) when (Syntax.string_of_mlpath p = "Prims.bool") -> - TBool - | MLTY_Named ([], ([ "FStar"; m ], "t")) when is_machine_int m -> - TInt (must (mk_width m)) - | MLTY_Named ([], ([ "FStar"; m ], "t'")) when is_machine_int m -> - TInt (must (mk_width m)) - | MLTY_Named ([], p) when (Syntax.string_of_mlpath p = "FStar.Monotonic.HyperStack.mem") -> - TUnit - - | MLTY_Named ([_; arg; _], p) when - Syntax.string_of_mlpath p = "FStar.Monotonic.HyperStack.s_mref" || - Syntax.string_of_mlpath p = "FStar.Monotonic.HyperHeap.mrref" || - Syntax.string_of_mlpath p = "FStar.HyperStack.ST.m_rref" || - Syntax.string_of_mlpath p = "FStar.HyperStack.ST.s_mref" - -> - TBuf (translate_type_without_decay env arg) - - | MLTY_Named ([arg; _], p) when - Syntax.string_of_mlpath p = "FStar.Monotonic.HyperStack.mreference" || - Syntax.string_of_mlpath p = "FStar.Monotonic.HyperStack.mstackref" || - Syntax.string_of_mlpath p = "FStar.Monotonic.HyperStack.mref" || - Syntax.string_of_mlpath p = "FStar.Monotonic.HyperStack.mmmstackref" || - Syntax.string_of_mlpath p = "FStar.Monotonic.HyperStack.mmmref" || - Syntax.string_of_mlpath p = "FStar.Monotonic.Heap.mref" || - Syntax.string_of_mlpath p = "FStar.HyperStack.ST.mreference" || - Syntax.string_of_mlpath p = "FStar.HyperStack.ST.mstackref" || - Syntax.string_of_mlpath p = "FStar.HyperStack.ST.mref" || - Syntax.string_of_mlpath p = "FStar.HyperStack.ST.mmmstackref" || - Syntax.string_of_mlpath p = "FStar.HyperStack.ST.mmmref" - -> - TBuf (translate_type_without_decay env arg) - - | MLTY_Named ([arg; _; _], p) when - Syntax.string_of_mlpath p = "LowStar.Monotonic.Buffer.mbuffer" -> TBuf (translate_type_without_decay env arg) - - | MLTY_Named ([arg], p) when - Syntax.string_of_mlpath p = "LowStar.ConstBuffer.const_buffer" || - false - -> TConstBuf (translate_type_without_decay env arg) - - | MLTY_Named ([arg], p) when - Syntax.string_of_mlpath p = "FStar.Buffer.buffer" || - Syntax.string_of_mlpath p = "LowStar.Buffer.buffer" || - Syntax.string_of_mlpath p = "LowStar.ImmutableBuffer.ibuffer" || - Syntax.string_of_mlpath p = "LowStar.UninitializedBuffer.ubuffer" || - Syntax.string_of_mlpath p = "FStar.HyperStack.reference" || - Syntax.string_of_mlpath p = "FStar.HyperStack.stackref" || - Syntax.string_of_mlpath p = "FStar.HyperStack.ref" || - Syntax.string_of_mlpath p = "FStar.HyperStack.mmstackref" || - Syntax.string_of_mlpath p = "FStar.HyperStack.mmref" || - Syntax.string_of_mlpath p = "FStar.HyperStack.ST.reference" || - Syntax.string_of_mlpath p = "FStar.HyperStack.ST.stackref" || - Syntax.string_of_mlpath p = "FStar.HyperStack.ST.ref" || - Syntax.string_of_mlpath p = "FStar.HyperStack.ST.mmstackref" || - Syntax.string_of_mlpath p = "FStar.HyperStack.ST.mmref" || - false - -> - TBuf (translate_type_without_decay env arg) - - | MLTY_Named ([_;arg], p) when - Syntax.string_of_mlpath p = "FStar.HyperStack.s_ref" || - Syntax.string_of_mlpath p = "FStar.HyperStack.ST.s_ref" - -> - TBuf (translate_type_without_decay env arg) - - | MLTY_Named ([arg], p) when - Syntax.string_of_mlpath p = "FStar.Universe.raise_t" - -> - translate_type_without_decay env arg - - | MLTY_Named ([_], p) when (Syntax.string_of_mlpath p = "FStar.Ghost.erased") -> - TAny - - | MLTY_Named ([], (path, type_name)) -> - // Generate an unbound reference... to be filled in later by glue code. - TQualified (path, type_name) - - | MLTY_Named (args, (ns, t)) when (ns = ["Prims"] || ns = ["FStar"; "Pervasives"; "Native"]) && BU.starts_with t "tuple" -> - TTuple (List.map (translate_type_without_decay env) args) - - | MLTY_Named (args, lid) -> - if List.length args > 0 then - TApp (lid, List.map (translate_type_without_decay env) args) - else - TQualified lid - - | MLTY_Tuple ts -> - TTuple (List.map (translate_type_without_decay env) ts) - -and translate_type' env t: typ = - // The outermost array type constructor decays to pointer - match t with - - | t -> translate_type_without_decay env t - -and translate_binders env bs = - List.map (translate_binder env) bs - -and translate_binder env ({mlbinder_name; mlbinder_ty; mlbinder_attrs} ) = - { - name = mlbinder_name; - typ = translate_type env mlbinder_ty; - mut = false; - meta = []; - } - -and translate_expr' env e: expr = - match e.expr with - | MLE_Tuple [] -> - EUnit - - | MLE_Const c -> - translate_constant c - - | MLE_Var name -> - EBound (find env name) - - // Some of these may not appear beneath an [EApp] node because of partial applications - | MLE_Name ([ "FStar"; m ], op) when (is_machine_int m && is_op op) -> - EOp (must (mk_op op), must (mk_width m)) - - | MLE_Name ([ "Prims" ], op) when (is_bool_op op) -> - EOp (must (mk_bool_op op), Bool) - - | MLE_Name n -> - EQualified n - - | MLE_Let ((flavor, [{ - mllb_name = name; - mllb_tysc = Some ([], typ); // assuming unquantified type - mllb_add_unit = add_unit; // ? - mllb_def = body; - mllb_meta = flags; - print_typ = print // ? - }]), continuation) -> - let binder = { name = name; typ = translate_type env typ; mut = false; meta = translate_flags flags; } in - let body = translate_expr env body in - let env = extend env name in - let continuation = translate_expr env continuation in - ELet (binder, body, continuation) - - | MLE_Match (expr, branches) -> - EMatch (translate_expr env expr, translate_branches env branches) - - // We recognize certain distinguished names from [FStar.HST] and other - // modules, and translate them into built-in Karamel constructs - | MLE_App({expr=MLE_TApp ({ expr = MLE_Name p }, [t])}, [arg]) - when string_of_mlpath p = "FStar.Dyn.undyn" -> - ECast (translate_expr env arg, translate_type env t) - | MLE_App({expr=MLE_TApp ({ expr = MLE_Name p }, _)}, _) - when string_of_mlpath p = "Prims.admit" -> - EAbort - | MLE_App({expr=MLE_TApp ({ expr = MLE_Name p }, [ t ])}, - [{ expr = MLE_Const (MLC_String s) }]) - when string_of_mlpath p = "LowStar.Failure.failwith" -> - EAbortT (s, translate_type env t) - | MLE_App({expr=MLE_TApp ({ expr = MLE_Name p }, _)}, [arg]) - when string_of_mlpath p = "FStar.HyperStack.All.failwith" - || string_of_mlpath p = "FStar.Error.unexpected" - || string_of_mlpath p = "FStar.Error.unreachable" -> - (match arg with - | {expr=MLE_Const (MLC_String msg)} -> EAbortS msg - | _ -> - let print_nm = ["FStar"; "HyperStack"; "IO"], "print_string" in - let print = with_ty MLTY_Top (MLE_Name print_nm) in - let print = with_ty MLTY_Top (MLE_App (print, [arg])) in - let t = translate_expr env print in - ESequence [t; EAbort]) - - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e ] ) - when string_of_mlpath p = "LowStar.ToFStarBuffer.new_to_old_st" || - string_of_mlpath p = "LowStar.ToFStarBuffer.old_to_new_st" - -> - translate_expr env e - - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e1; e2 ]) - when string_of_mlpath p = "FStar.Buffer.index" || string_of_mlpath p = "FStar.Buffer.op_Array_Access" - || string_of_mlpath p = "LowStar.Monotonic.Buffer.index" - || string_of_mlpath p = "LowStar.UninitializedBuffer.uindex" - || string_of_mlpath p = "LowStar.ConstBuffer.index" - -> - EBufRead (translate_expr env e1, translate_expr env e2) - - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e ]) - when string_of_mlpath p = "FStar.HyperStack.ST.op_Bang" - -> - EBufRead (translate_expr env e, EQualified (["C"], "_zero_for_deref")) - - (* Flatten all universes *) - - | MLE_App ({ expr = MLE_TApp ({ expr = MLE_Name p }, _) }, [arg]) - when string_of_mlpath p = "FStar.Universe.raise_val" -> - translate_expr env arg - - | MLE_App ({ expr = MLE_TApp ({ expr = MLE_Name p }, _) }, [arg]) - when string_of_mlpath p = "FStar.Universe.downgrade_val" -> - translate_expr env arg - - (* All the distinguished combinators that correspond to allocation, either on - * the stack, on the heap (GC'd or manually-managed). *) - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) } , [ e1; e2 ]) - when (string_of_mlpath p = "FStar.Buffer.create" || - string_of_mlpath p = "LowStar.Monotonic.Buffer.malloca" || - string_of_mlpath p = "LowStar.ImmutableBuffer.ialloca") -> - EBufCreate (Stack, translate_expr env e1, translate_expr env e2) - - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) } , [ elen ]) - when string_of_mlpath p = "LowStar.UninitializedBuffer.ualloca" -> - EBufCreateNoInit (Stack, translate_expr env elen) - - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) } , [ init ]) - when ( - string_of_mlpath p = "FStar.HyperStack.ST.salloc" || - false - ) -> - EBufCreate (Stack, translate_expr env init, EConstant (UInt32, "1")) - - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e2 ]) - when (string_of_mlpath p = "FStar.Buffer.createL" || - string_of_mlpath p = "LowStar.Monotonic.Buffer.malloca_of_list" || - string_of_mlpath p = "LowStar.ImmutableBuffer.ialloca_of_list") -> - EBufCreateL (Stack, List.map (translate_expr env) (list_elements e2)) - - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ _erid; e2 ]) - when string_of_mlpath p = "LowStar.Monotonic.Buffer.mgcmalloc_of_list" || - string_of_mlpath p = "LowStar.ImmutableBuffer.igcmalloc_of_list" -> - EBufCreateL (Eternal, List.map (translate_expr env) (list_elements e2)) - - (* - * AR: TODO: FIXME: - * temporarily extraction of ralloc_drgn is same as ralloc - *) - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) } , [ _rid; init ]) - when (string_of_mlpath p = "FStar.HyperStack.ST.ralloc") || - (string_of_mlpath p = "FStar.HyperStack.ST.ralloc_drgn") -> - EBufCreate (Eternal, translate_expr env init, EConstant (UInt32, "1")) - - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ _e0; e1; e2 ]) - when (string_of_mlpath p = "FStar.Buffer.rcreate" || string_of_mlpath p = "LowStar.Monotonic.Buffer.mgcmalloc" || - string_of_mlpath p = "LowStar.ImmutableBuffer.igcmalloc") -> - EBufCreate (Eternal, translate_expr env e1, translate_expr env e2) - - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, _) - when (string_of_mlpath p = "LowStar.Monotonic.Buffer.mgcmalloc_and_blit" || - string_of_mlpath p = "LowStar.Monotonic.Buffer.mmalloc_and_blit" || - string_of_mlpath p = "LowStar.Monotonic.Buffer.malloca_and_blit" || - string_of_mlpath p = "LowStar.ImmutableBuffer.igcmalloc_and_blit" || - string_of_mlpath p = "LowStar.ImmutableBuffer.imalloc_and_blit" || - string_of_mlpath p = "LowStar.ImmutableBuffer.ialloca_and_blit") -> - EAbortS "alloc_and_blit family of functions are not yet supported downstream" - - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ _erid; elen ]) - when string_of_mlpath p = "LowStar.UninitializedBuffer.ugcmalloc" -> - EBufCreateNoInit (Eternal, translate_expr env elen) - - (* - * AR: TODO: FIXME: - * temporarily extraction of ralloc_drgn_mm is same as ralloc_mm - *) - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) } , [ _rid; init ]) - when (string_of_mlpath p = "FStar.HyperStack.ST.ralloc_mm") || - (string_of_mlpath p = "FStar.HyperStack.ST.ralloc_drgn_mm") -> - EBufCreate (ManuallyManaged, translate_expr env init, EConstant (UInt32, "1")) - - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ _e0; e1; e2 ]) - when (string_of_mlpath p = "FStar.Buffer.rcreate_mm" || - string_of_mlpath p = "LowStar.Monotonic.Buffer.mmalloc" || - string_of_mlpath p = "LowStar.Monotonic.Buffer.mmalloc" || - string_of_mlpath p = "LowStar.ImmutableBuffer.imalloc") -> - EBufCreate (ManuallyManaged, translate_expr env e1, translate_expr env e2) - - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ _erid; elen ]) - when string_of_mlpath p = "LowStar.UninitializedBuffer.umalloc" -> - EBufCreateNoInit (ManuallyManaged, translate_expr env elen) - - (* Only manually-managed references and buffers can be freed. *) - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e2 ]) when - (string_of_mlpath p = "FStar.HyperStack.ST.rfree" || - false) -> - EBufFree (translate_expr env e2) - - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e2 ]) - when (string_of_mlpath p = "FStar.Buffer.rfree" || - string_of_mlpath p = "LowStar.Monotonic.Buffer.free") -> - EBufFree (translate_expr env e2) - - (* Generic buffer operations. *) - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e1; e2; _e3 ]) when (string_of_mlpath p = "FStar.Buffer.sub") -> - EBufSub (translate_expr env e1, translate_expr env e2) - - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e1; e2; _e3 ]) - when string_of_mlpath p = "LowStar.Monotonic.Buffer.msub" - || string_of_mlpath p = "LowStar.ConstBuffer.sub" -> - EBufSub (translate_expr env e1, translate_expr env e2) - - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e1; e2 ]) when (string_of_mlpath p = "FStar.Buffer.join") -> - (translate_expr env e1) - - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e1; e2 ]) - when string_of_mlpath p = "FStar.Buffer.offset" - -> - EBufSub (translate_expr env e1, translate_expr env e2) - - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e1; e2 ]) when string_of_mlpath p = "LowStar.Monotonic.Buffer.moffset" -> - EBufSub (translate_expr env e1, translate_expr env e2) - - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e1; e2; e3 ]) - when string_of_mlpath p = "FStar.Buffer.upd" || string_of_mlpath p = "FStar.Buffer.op_Array_Assignment" - || string_of_mlpath p = "LowStar.Monotonic.Buffer.upd'" - || string_of_mlpath p = "LowStar.UninitializedBuffer.uupd" - -> - EBufWrite (translate_expr env e1, translate_expr env e2, translate_expr env e3) - - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e1; e2 ]) - when string_of_mlpath p = "FStar.HyperStack.ST.op_Colon_Equals" - -> - EBufWrite (translate_expr env e1, EQualified (["C"], "_zero_for_deref"), translate_expr env e2) - - | MLE_App ({ expr = MLE_Name p }, [ _ ]) when ( - string_of_mlpath p = "FStar.HyperStack.ST.push_frame" || - false - ) -> - EPushFrame - | MLE_App ({ expr = MLE_Name p }, [ _ ]) when (string_of_mlpath p = "FStar.HyperStack.ST.pop_frame") -> - EPopFrame - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e1; e2; e3; e4; e5 ]) when ( - string_of_mlpath p = "FStar.Buffer.blit" || - string_of_mlpath p = "LowStar.Monotonic.Buffer.blit" || - string_of_mlpath p = "LowStar.UninitializedBuffer.ublit" - ) -> - EBufBlit (translate_expr env e1, translate_expr env e2, translate_expr env e3, translate_expr env e4, translate_expr env e5) - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e1; e2; e3 ]) - when (let s = string_of_mlpath p in (s = "FStar.Buffer.fill" || s = "LowStar.Monotonic.Buffer.fill" )) -> - EBufFill (translate_expr env e1, translate_expr env e2, translate_expr env e3) - | MLE_App ({ expr = MLE_Name p }, [ _ ]) when string_of_mlpath p = "FStar.HyperStack.ST.get" -> - // We need to reveal to Karamel that FStar.HST.get is equivalent to - // (void*)0 so that it can get rid of ghost calls to HST.get at the - // beginning of functions, which is needed to enforce the push/pop - // structure. - EUnit - - (* - * AR: TODO: FIXME: - * temporarily extraction of new_drgn and free_drgn is same just unit - *) - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) } , [ _rid ]) - when (string_of_mlpath p = "FStar.HyperStack.ST.free_drgn") || - (string_of_mlpath p = "FStar.HyperStack.ST.new_drgn") -> - EUnit - - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ _ebuf; _eseq ]) - when (string_of_mlpath p = "LowStar.Monotonic.Buffer.witness_p" || - string_of_mlpath p = "LowStar.Monotonic.Buffer.recall_p" || - string_of_mlpath p = "LowStar.ImmutableBuffer.witness_contents" || - string_of_mlpath p = "LowStar.ImmutableBuffer.recall_contents") -> - EUnit - - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e1 ]) - when string_of_mlpath p = "LowStar.ConstBuffer.of_buffer" - || string_of_mlpath p = "LowStar.ConstBuffer.of_ibuffer" - -> - // The injection from *t to const *t should always be re-checkable by the - // Low* checker and should not necessitate the insertion of casts. This is - // the C semantics: if the context wants a const pointer, providing a - // non-const pointer should always be checkable. - translate_expr env e1 - - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, [ t ]) }, [ _eqal; e1 ]) - when string_of_mlpath p = "LowStar.ConstBuffer.of_qbuf" - -> - ECast (translate_expr env e1, TConstBuf (translate_type env t)) - - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, [ t ]) }, [ e1 ]) - when string_of_mlpath p = "LowStar.ConstBuffer.cast" || - string_of_mlpath p = "LowStar.ConstBuffer.to_buffer" || - string_of_mlpath p = "LowStar.ConstBuffer.to_ibuffer" - -> - // See comments in LowStar.ConstBuffer.fsti - ECast (translate_expr env e1, TBuf (translate_type env t)) - - | MLE_App ({ expr = MLE_Name p }, [ e ]) when string_of_mlpath p = "Obj.repr" -> - ECast (translate_expr env e, TAny) - - // Operators from fixed-width integer modules, e.g. [FStar.Int32.addw]. - | MLE_App ({ expr = MLE_Name ([ "FStar"; m ], op) }, args) when (is_machine_int m && is_op op) -> - mk_op_app env (must (mk_width m)) (must (mk_op op)) args - - | MLE_App ({ expr = MLE_Name ([ "Prims" ], op) }, args) when (is_bool_op op) -> - mk_op_app env Bool (must (mk_bool_op op)) args - - // Fixed-width literals are represented as calls to [FStar.Int32.uint_to_t] - | MLE_App ({ expr = MLE_Name ([ "FStar"; m ], "int_to_t") }, [ { expr = MLE_Const (MLC_Int (c, None)) }]) - | MLE_App ({ expr = MLE_Name ([ "FStar"; m ], "uint_to_t") }, [ { expr = MLE_Const (MLC_Int (c, None)) }]) when is_machine_int m -> - EConstant (must (mk_width m), c) - - | MLE_App ({ expr = MLE_Name ([ "C" ], "string_of_literal") }, [ { expr = e } ]) - | MLE_App ({ expr = MLE_Name ([ "C"; "Compat"; "String" ], "of_literal") }, [ { expr = e } ]) - | MLE_App ({ expr = MLE_Name ([ "C"; "String" ], "of_literal") }, [ { expr = e } ]) -> - begin match e with - | MLE_Const (MLC_String s) -> - EString s - | _ -> - failwith "Cannot extract string_of_literal applied to a non-literal" - end - - | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ { expr = ebefore }; e ; { expr = eafter } ] ) - when string_of_mlpath p = "LowStar.Comment.comment_gen" -> - begin match ebefore, eafter with - | MLE_Const (MLC_String sbefore), MLE_Const (MLC_String safter) -> - if contains sbefore "*/" - then failwith "Before Comment contains end-of-comment marker"; - if contains safter "*/" - then failwith "After Comment contains end-of-comment marker"; - EComment (sbefore, translate_expr env e, safter) - | _ -> - failwith "Cannot extract comment applied to a non-literal" - end - - | MLE_App ({ expr = MLE_Name p }, [ { expr = e } ] ) - when string_of_mlpath p = "LowStar.Comment.comment" -> - begin match e with - | MLE_Const (MLC_String s) -> - if contains s "*/" - then failwith "Standalone Comment contains end-of-comment marker"; - EStandaloneComment s - | _ -> - failwith "Cannot extract comment applied to a non-literal" - end - - | MLE_App ({ expr = MLE_Name ([ "LowStar"; "Literal" ], "buffer_of_literal") }, [ { expr = e } ]) -> - begin match e with - | MLE_Const (MLC_String s) -> - ECast (EString s, TBuf (TInt UInt8)) - | _ -> - failwith "Cannot extract buffer_of_literal applied to a non-literal" - end - - | MLE_App ({ expr = MLE_Name ([ "FStar"; "Int"; "Cast" ], c) }, [ arg ]) -> - let is_known_type = - starts_with c "uint8" || starts_with c "uint16" || - starts_with c "uint32" || starts_with c "uint64" || - starts_with c "int8" || starts_with c "int16" || - starts_with c "int32" || starts_with c "int64" - in - if ends_with c "uint64" && is_known_type then - ECast (translate_expr env arg, TInt UInt64) - else if ends_with c "uint32" && is_known_type then - ECast (translate_expr env arg, TInt UInt32) - else if ends_with c "uint16" && is_known_type then - ECast (translate_expr env arg, TInt UInt16) - else if ends_with c "uint8" && is_known_type then - ECast (translate_expr env arg, TInt UInt8) - else if ends_with c "int64" && is_known_type then - ECast (translate_expr env arg, TInt Int64) - else if ends_with c "int32" && is_known_type then - ECast (translate_expr env arg, TInt Int32) - else if ends_with c "int16" && is_known_type then - ECast (translate_expr env arg, TInt Int16) - else if ends_with c "int8" && is_known_type then - ECast (translate_expr env arg, TInt Int8) - else - EApp (EQualified ([ "FStar"; "Int"; "Cast" ], c), [ translate_expr env arg ]) - - | MLE_App ({ expr = MLE_Name p }, [ arg ]) - when string_of_mlpath p = "FStar.SizeT.uint16_to_sizet" || - string_of_mlpath p = "FStar.SizeT.uint32_to_sizet" || - string_of_mlpath p = "FStar.SizeT.uint64_to_sizet" || - string_of_mlpath p = "FStar.PtrdiffT.ptrdifft_to_sizet" -> - ECast (translate_expr env arg, TInt SizeT) - - | MLE_App ({ expr = MLE_Name p }, [ arg ]) - when string_of_mlpath p = "FStar.SizeT.sizet_to_uint32" -> - ECast (translate_expr env arg, TInt UInt32) - - | MLE_App ({ expr = MLE_Name p }, [ arg ]) - when string_of_mlpath p = "FStar.SizeT.sizet_to_uint64" -> - ECast (translate_expr env arg, TInt UInt64) - - | MLE_App (head, args) -> - EApp (translate_expr env head, List.map (translate_expr env) args) - - | MLE_TApp (head, ty_args) -> - ETypApp (translate_expr env head, List.map (translate_type env) ty_args) - - | MLE_Coerce (e, t_from, t_to) -> - ECast (translate_expr env e, translate_type env t_to) - - | MLE_Record (_, _, fields) -> - EFlat (assert_lid env e.mlty, List.map (fun (field, expr) -> - field, translate_expr env expr) fields) - - | MLE_Proj (e, path) -> - EField (assert_lid env e.mlty, translate_expr env e, snd path) - - | MLE_Let _ -> - (* Things not supported (yet): let-bindings for functions; meaning, rec flags are not - * supported, and quantified type schemes are not supported either *) - failwith (BU.format1 "todo: translate_expr [MLE_Let] (expr is: %s)" - (ML.Code.string_of_mlexpr ([],"") e)) - | MLE_App (head, _) -> - failwith (BU.format1 "todo: translate_expr [MLE_App] (head is: %s)" - (ML.Code.string_of_mlexpr ([], "") head)) - | MLE_Seq seqs -> - ESequence (List.map (translate_expr env) seqs) - | MLE_Tuple es -> - ETuple (List.map (translate_expr env) es) - - | MLE_CTor ((_, cons), es) -> - ECons (assert_lid env e.mlty, cons, List.map (translate_expr env) es) - - | MLE_Fun (bs, body) -> - let binders = translate_binders env bs in - let env = add_binders env bs in - EFun (binders, translate_expr env body, translate_type env body.mlty) - - | MLE_If (e1, e2, e3) -> - EIfThenElse (translate_expr env e1, translate_expr env e2, (match e3 with - | None -> EUnit - | Some e3 -> translate_expr env e3)) - | MLE_Raise _ -> - failwith "todo: translate_expr [MLE_Raise]" - | MLE_Try _ -> - failwith "todo: translate_expr [MLE_Try]" - | MLE_Coerce _ -> - failwith "todo: translate_expr [MLE_Coerce]" - -and assert_lid env t = - match t with - | MLTY_Named (ts, lid) -> - if List.length ts > 0 then - TApp (lid, List.map (translate_type env) ts) - else - TQualified lid - | _ -> failwith (BU.format1 "invalid argument: expected MLTY_Named, got %s" - (ML.Code.string_of_mlty ([], "") t)) - -and translate_branches env branches = - List.map (translate_branch env) branches - -and translate_branch env (pat, guard, expr) = - if guard = None then - let env, pat = translate_pat env pat in - pat, translate_expr env expr - else - failwith "todo: translate_branch" - -and translate_width = function - | None -> CInt - | Some (FC.Signed, FC.Int8) -> Int8 - | Some (FC.Signed, FC.Int16) -> Int16 - | Some (FC.Signed, FC.Int32) -> Int32 - | Some (FC.Signed, FC.Int64) -> Int64 - | Some (FC.Unsigned, FC.Int8) -> UInt8 - | Some (FC.Unsigned, FC.Int16) -> UInt16 - | Some (FC.Unsigned, FC.Int32) -> UInt32 - | Some (FC.Unsigned, FC.Int64) -> UInt64 - | Some (FC.Unsigned, FC.Sizet) -> SizeT - -and translate_pat env p = - match p with - | MLP_Const MLC_Unit -> - env, PUnit - | MLP_Const (MLC_Bool b) -> - env, PBool b - | MLP_Const (MLC_Int (s, sw)) -> - env, PConstant (translate_width sw, s) - | MLP_Var name -> - let env = extend env name in - env, PVar ({ name = name; typ = TAny; mut = false; meta = [] }) - | MLP_Wild -> - let env = extend env "_" in - env, PVar ({ name = "_"; typ = TAny; mut = false; meta = [] }) - | MLP_CTor ((_, cons), ps) -> - let env, ps = List.fold_left (fun (env, acc) p -> - let env, p = translate_pat env p in - env, p :: acc - ) (env, []) ps in - env, PCons (cons, List.rev ps) - | MLP_Record (_, ps) -> - let env, ps = List.fold_left (fun (env, acc) (field, p) -> - let env, p = translate_pat env p in - env, (field, p) :: acc - ) (env, []) ps in - env, PRecord (List.rev ps) - - | MLP_Tuple ps -> - let env, ps = List.fold_left (fun (env, acc) p -> - let env, p = translate_pat env p in - env, p :: acc - ) (env, []) ps in - env, PTuple (List.rev ps) - - | MLP_Const _ -> - failwith "todo: translate_pat [MLP_Const]" - | MLP_Branch _ -> - failwith "todo: translate_pat [MLP_Branch]" - -and translate_constant c: expr = - match c with - | MLC_Unit -> - EUnit - | MLC_Bool b -> - EBool b - | MLC_String s -> - if FStar.String.list_of_string s - |> BU.for_some (fun (c:Char.char) -> c = Char.char_of_int 0) - then failwith (BU.format1 "Refusing to translate a string literal that contains a null character: %s" s); - EString s - | MLC_Char c -> - let i = BU.int_of_char c in - let s = BU.string_of_int i in - let c = EConstant (CInt, s) in - let char_of_int = EQualified (["FStar"; "Char"], "char_of_int") in - EApp(char_of_int, [c]) - | MLC_Int (s, Some (sg, wd)) -> - EConstant (translate_width (Some (sg, wd)), s) - | MLC_Float _ -> - failwith "todo: translate_expr [MLC_Float]" - | MLC_Bytes _ -> - failwith "todo: translate_expr [MLC_Bytes]" - | MLC_Int (s, None) -> - EConstant (CInt, s) - -(* Helper functions **********************************************************) - -and mk_op_app env w op args = - EApp (EOp (op, w), List.map (translate_expr env) args) - -let translate_type_decl' env ty: option decl = - match ty with - | {tydecl_assumed=assumed; - tydecl_name=name; - tydecl_parameters=args; - tydecl_meta=flags; - tydecl_defn= Some (MLTD_Abbrev t)} -> - let name = env.module_name, name in - let env = List.fold_left (fun env {ty_param_name} -> extend_t env ty_param_name) env args in - if assumed && List.mem Syntax.CAbstract flags then - Some (DTypeAbstractStruct name) - else if assumed then - let name = string_of_mlpath name in - BU.print1_warning "Not extracting type definition %s to KaRaMeL (assumed type)\n" name; - // JP: TODO: shall we be smarter here? - None - else - Some (DTypeAlias (name, translate_flags flags, List.length args, translate_type env t)) - - | {tydecl_name=name; - tydecl_parameters=args; - tydecl_meta=flags; - tydecl_defn=Some (MLTD_Record fields)} -> - let name = env.module_name, name in - let env = List.fold_left (fun env {ty_param_name} -> extend_t env ty_param_name) env args in - Some (DTypeFlat (name, translate_flags flags, List.length args, List.map (fun (f, t) -> - f, (translate_type_without_decay env t, false)) fields)) - - | {tydecl_name=name; - tydecl_parameters=args; - tydecl_meta=flags; - tydecl_defn=Some (MLTD_DType branches)} -> - let name = env.module_name, name in - let flags = translate_flags flags in - let env = args |> ty_param_names |> List.fold_left extend_t env in - Some (DTypeVariant (name, flags, List.length args, List.map (fun (cons, ts) -> - cons, List.map (fun (name, t) -> - name, (translate_type_without_decay env t, false) - ) ts - ) branches)) - | {tydecl_name=name} -> - // JP: TODO: figure out why and how this happens - Errors.log_issue0 Errors.Warning_DefinitionNotTranslated [ - Errors.Msg.text <| BU.format1 "Error extracting type definition %s to KaRaMeL." name; - ]; - None - -let translate_let' env flavor lb: option decl = - match lb with - | { - mllb_name = name; - mllb_tysc = Some (tvars, t0); - mllb_def = e; - mllb_meta = meta - } when BU.for_some (function Syntax.Assumed -> true | _ -> false) meta -> - let name = env.module_name, name in - let arg_names = match e.expr with - | MLE_Fun (bs, _) -> List.map (fun {mlbinder_name} -> mlbinder_name) bs - | _ -> [] - in - if List.length tvars = 0 then - Some (DExternal (translate_cc meta, translate_flags meta, name, translate_type env t0, arg_names)) - else begin - BU.print1_warning "Not extracting %s to KaRaMeL (polymorphic assumes are not supported)\n" (Syntax.string_of_mlpath name); - None - end - - | { - mllb_name = name; - mllb_tysc = Some (tvars, t0); - mllb_def = { expr = MLE_Fun (args, body) }; - mllb_meta = meta - } -> - if List.mem Syntax.NoExtract meta then - None - else - // Case 1: a possibly-polymorphic function. - let env = if flavor = Rec then extend env name else env in - let env = tvars |> ty_param_names |> List.fold_left (fun env name -> extend_t env name) env in - let rec find_return_type eff i = function - | MLTY_Fun (_, eff, t) when i > 0 -> - find_return_type eff (i - 1) t - | t -> - i, eff, t - in - let name = env.module_name, name in - let i, eff, t = find_return_type E_PURE (List.length args) t0 in - if i > 0 then begin - let msg = "function type annotation has less arrows than the \ - number of arguments; please mark the return type abbreviation as \ - inline_for_extraction" in - BU.print2_warning "Not extracting %s to KaRaMeL (%s)\n" (Syntax.string_of_mlpath name) msg - end; - let t = translate_type env t in - let binders = translate_binders env args in - let env = add_binders env args in - let cc = translate_cc meta in - let meta = match eff, t with - | E_ERASABLE, _ - | E_PURE, TUnit -> MustDisappear :: translate_flags meta - | _ -> translate_flags meta - in - begin try - let body = translate_expr env body in - Some (DFunction (cc, meta, List.length tvars, t, name, binders, body)) - with e -> - // JP: TODO: figure out what are the remaining things we don't extract - let msg = BU.print_exn e in - Errors.log_issue0 Errors.Warning_FunctionNotExtacted [ - Errors.Msg.text <| BU.format1 "Error while extracting %s to KaRaMeL." (Syntax.string_of_mlpath name); - Pprint.arbitrary_string msg; - ]; - let msg = "This function was not extracted:\n" ^ msg in - Some (DFunction (cc, meta, List.length tvars, t, name, binders, EAbortS msg)) - end - - | { - mllb_name = name; - mllb_tysc = Some (tvars, t); - mllb_def = expr; - mllb_meta = meta - } -> - if List.mem Syntax.NoExtract meta then - None - else - // Case 2: this is a global - let meta = translate_flags meta in - let env = tvars |> ty_param_names |> List.fold_left (fun env name -> extend_t env name) env in - let t = translate_type env t in - let name = env.module_name, name in - begin try - let expr = translate_expr env expr in - Some (DGlobal (meta, name, List.length tvars, t, expr)) - with e -> - Errors.log_issue0 Errors.Warning_DefinitionNotTranslated [ - Errors.Msg.text <| BU.format1 "Error extracting %s to KaRaMeL." (Syntax.string_of_mlpath name); - Pprint.arbitrary_string (BU.print_exn e); - ]; - Some (DGlobal (meta, name, List.length tvars, t, EAny)) - end - - | { mllb_name = name; mllb_tysc = ts } -> - // TODO JP: figure out what exactly we're hitting here...? - Errors.log_issue0 Errors.Warning_DefinitionNotTranslated - (BU.format1 "Not extracting %s to KaRaMeL\n" name); - begin match ts with - | Some (tps, t) -> - BU.print2 "Type scheme is: forall %s. %s\n" - (String.concat ", " (ty_param_names tps)) - (ML.Code.string_of_mlty ([], "") t) - | None -> - () - end; - None - -let translate_let_t = env -> mlletflavor -> mllb -> ML (option decl) -(* translate_let' is not recursive, so we can directly use it to initialize ref_translate_let *) -let ref_translate_let : ref translate_let_t = mk_ref translate_let' -let register_pre_translate_let - (f: translate_let_t) -: ML unit -= let before : translate_let_t = !ref_translate_let in - let after : translate_let_t = fun e fl lb -> - try - f e fl lb - with NotSupportedByKrmlExtension -> before e fl lb - in - ref_translate_let := after -let translate_let env flavor lb: option decl = - !ref_translate_let env flavor lb - -let translate_decl env d: list decl = - match d.mlmodule1_m with - | MLM_Let (flavor, lbs) -> - // We don't care about mutual recursion, since every C file will include - // its own header with the forward declarations. - List.choose (translate_let env flavor) lbs - - | MLM_Loc _ -> - // JP: TODO: use this to reconstruct location information - [] - - | MLM_Ty tys -> - // We don't care about mutual recursion, since KaRaMeL will insert forward - // declarations exactly as needed, as part of its monomorphization phase - List.choose (translate_type_decl env) tys - - | MLM_Top _ -> - failwith "todo: translate_decl [MLM_Top]" - - | MLM_Exn (m, _) -> - BU.print1_warning "Not extracting exception %s to KaRaMeL (exceptions unsupported)\n" m; - [] - -let translate_module uenv (m : mlpath & option (mlsig & mlmodule) & mllib) : file = - let (module_name, modul, _) = m in - let module_name = fst module_name @ [ snd module_name ] in - let program = match modul with - | Some (_signature, decls) -> - List.collect (translate_decl (empty uenv module_name)) decls - | _ -> - failwith "Unexpected standalone interface or nested modules" - in - (String.concat "_" module_name), program - -let translate (ue:uenv) (MLLib modules): list file = - List.filter_map (fun m -> - let m_name = - let path, _, _ = m in - Syntax.string_of_mlpath path - in - try - if not (Options.silent()) then (BU.print1 "Attempting to translate module %s\n" m_name); - Some (translate_module ue m) - with - | e -> - BU.print2 "Unable to translate module: %s because:\n %s\n" - m_name (BU.print_exn e); - None - ) modules - -let _ = - register_post_translate_type_without_decay translate_type_without_decay'; - register_post_translate_type translate_type'; - register_post_translate_type_decl translate_type_decl'; - register_post_translate_expr translate_expr' diff --git a/src/extraction/FStar.Extraction.Krml.fsti b/src/extraction/FStar.Extraction.Krml.fsti deleted file mode 100644 index ee2280e0aa3..00000000000 --- a/src/extraction/FStar.Extraction.Krml.fsti +++ /dev/null @@ -1,35 +0,0 @@ -(* - Copyright 2008-2017 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -(* -------------------------------------------------------------------- *) -module FStar.Extraction.Krml - -open FStar.Class.Show - -type version = int -val current_version: version (* version of AST type, for binary compatibility *) - -val decl : Type0 - -instance val showable_decl : showable decl - -type program = list decl -type file = string & program - -(** Versioned binary writing/reading of ASTs. - Serialization/parsing is with output_value/input_value. *) -type binary_format = version & list file - -val translate : Extraction.ML.UEnv.uenv -> FStar.Extraction.ML.Syntax.mllib -> list file diff --git a/src/extraction/FStar.Extraction.ML.Code.fst b/src/extraction/FStar.Extraction.ML.Code.fst deleted file mode 100644 index 5b879ad77d4..00000000000 --- a/src/extraction/FStar.Extraction.ML.Code.fst +++ /dev/null @@ -1,869 +0,0 @@ -(* - Copyright 2008-2015 Abhishek Anand, Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -(* -------------------------------------------------------------------- *) -module FStar.Extraction.ML.Code -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.Compiler.Util -open FStar.Extraction.ML -open FStar.Extraction.ML.Syntax -open FStar.Pprint -open FStar.Const -open FStar.BaseTypes -module BU = FStar.Compiler.Util - -(* This is the old printer used exclusively for the F# build of F*. It will not - * evolve in the future. *) - -(* -------------------------------------------------------------------- *) -type assoc = | ILeft | IRight | Left | Right | NonAssoc -type fixity = | Prefix | Postfix | Infix of assoc -type opprec = int & fixity -type level = opprec & assoc - -let t_prio_fun = (10, Infix Right) -let t_prio_tpl = (20, Infix NonAssoc) -let t_prio_name = (30, Postfix) - -let e_bin_prio_lambda = ( 5, Prefix) -let e_bin_prio_if = (15, Prefix) -let e_bin_prio_letin = (19, Prefix) -let e_bin_prio_or = (20, Infix Left) -let e_bin_prio_and = (25, Infix Left) -let e_bin_prio_eq = (27, Infix NonAssoc) -let e_bin_prio_order = (29, Infix NonAssoc) -let e_bin_prio_op1 = (30, Infix Left) -let e_bin_prio_op2 = (40, Infix Left) -let e_bin_prio_op3 = (50, Infix Left) -let e_bin_prio_op4 = (60, Infix Left) -let e_bin_prio_comb = (70, Infix Left) -let e_bin_prio_seq = (100, Infix Left) -let e_app_prio = (10000, Infix Left) - -let min_op_prec = (-1, Infix NonAssoc) -let max_op_prec = (max_int, Infix NonAssoc) - -(* Little helpers *) - -let empty = Doc "" -let hardline = Doc "\n" - -let text (s : string) = Doc s -let num (i : int) = Doc (string_of_int i) - -let break1 = text " " - -let enclose (Doc l) (Doc r) (Doc x) = - Doc (l^x^r) - -let cbrackets (Doc d) = enclose (text "{") (text "}") (Doc d) -let parens (Doc d ) = enclose (text "(") (text ")") (Doc d) - -let cat (Doc d1) (Doc d2) = Doc (d1 ^ d2) - -let reduce (docs : list doc) = - List.fold_left cat empty docs - -let combine (Doc sep) (docs : list doc) = - let select (Doc d) = if d = "" then None else Some d in - let docs = List.choose select docs in - Doc (String.concat sep docs) - -let reduce1 (docs : list doc) = - combine break1 docs - -let hbox (d : doc) = d (* FIXME *) - -(*copied from ocaml-asttrans.fs*) - -(* -------------------------------------------------------------------- *) -let rec in_ns (x: (list 'a & list 'a)) : bool = match x with - | [], _ -> true - | x1::t1, x2::t2 when (x1 = x2) -> in_ns (t1, t2) - | _, _ -> false - -(* -------------------------------------------------------------------- *) -let path_of_ns (currentModule : mlsymbol) ns = - let ns' = Util.flatten_ns ns in - if ns' = currentModule - then [] - else let cg_libs = Options.codegen_libs() in - let ns_len = List.length ns in - let found = BU.find_map cg_libs (fun cg_path -> - let cg_len = List.length cg_path in - if List.length cg_path < ns_len - then let pfx, sfx = BU.first_N cg_len ns in - if pfx = cg_path - then Some (pfx@[Util.flatten_ns sfx]) - else None - else None) in - match found with - | None -> [ns'] - | Some x -> x - -let mlpath_of_mlpath (currentModule : mlsymbol) (x : mlpath) : mlpath = - match string_of_mlpath x with - | "Prims.Some" -> ([], "Some") - | "Prims.None" -> ([], "None") - | _ -> - let ns, x = x in - (path_of_ns currentModule ns, x) - -let ptsym_of_symbol (s : mlsymbol) : mlsymbol = - if Char.lowercase (String.get s 0) <> String.get s 0 - then "l__" ^ s - else s - -let ptsym (currentModule : mlsymbol) (mlp : mlpath) : mlsymbol = - if (List.isEmpty (fst mlp)) - then ptsym_of_symbol (snd mlp) - else - let (p, s) = mlpath_of_mlpath currentModule mlp in - String.concat "." (p @ [ptsym_of_symbol s]) - - -let ptctor (currentModule : mlsymbol) (mlp : mlpath) : mlsymbol = - let (p, s) = mlpath_of_mlpath currentModule mlp in - let s = if Char.uppercase (String.get s 0) <> String.get s 0 then "U__" ^ s else s in - String.concat "." (p @ [s]) - -(* -------------------------------------------------------------------- *) -let infix_prim_ops = [ - ("op_Addition" , e_bin_prio_op1 , "+" ); - ("op_Subtraction" , e_bin_prio_op1 , "-" ); - ("op_Multiply" , e_bin_prio_op1 , "*" ); - ("op_Division" , e_bin_prio_op1 , "/" ); - ("op_Equality" , e_bin_prio_eq , "=" ); - ("op_Colon_Equals" , e_bin_prio_eq , ":="); - ("op_disEquality" , e_bin_prio_eq , "<>"); - ("op_AmpAmp" , e_bin_prio_and , "&&"); - ("op_BarBar" , e_bin_prio_or , "||"); - ("op_LessThanOrEqual" , e_bin_prio_order , "<="); - ("op_GreaterThanOrEqual", e_bin_prio_order , ">="); - ("op_LessThan" , e_bin_prio_order , "<" ); - ("op_GreaterThan" , e_bin_prio_order , ">" ); - ("op_Modulus" , e_bin_prio_order , "mod" ); -] - -(* -------------------------------------------------------------------- *) -let prim_uni_ops () = - let op_minus = if Util.codegen_fsharp() - then "-" - else "~-" in - [ ("op_Negation", "not"); - ("op_Minus", op_minus); - ("op_Bang","Support.ST.read") ] - -(* -------------------------------------------------------------------- *) -let prim_types = [] - -(* -------------------------------------------------------------------- *) -let prim_constructors = [ - ("Some", "Some"); - ("None", "None"); - ("Nil", "[]"); - ("Cons", "::"); -] - -(* -------------------------------------------------------------------- *) -let is_prims_ns (ns : list mlsymbol) = - ns = ["Prims"] - -(* -------------------------------------------------------------------- *) -let as_bin_op ((ns, x) : mlpath) = - if is_prims_ns ns then - List.tryFind (fun (y, _, _) -> x = y) infix_prim_ops - else - None - -(* -------------------------------------------------------------------- *) -let is_bin_op (p : mlpath) = - as_bin_op p <> None - -(* -------------------------------------------------------------------- *) -let as_uni_op ((ns, x) : mlpath) = - if is_prims_ns ns then - List.tryFind (fun (y, _) -> x = y) (prim_uni_ops ()) - else - None - -(* -------------------------------------------------------------------- *) -let is_uni_op (p : mlpath) = - as_uni_op p <> None - -(* -------------------------------------------------------------------- *) -let is_standard_type (p : mlpath) = false - -(* -------------------------------------------------------------------- *) -let as_standard_constructor ((ns, x) : mlpath) = - if is_prims_ns ns then - List.tryFind (fun (y, _) -> x = y) prim_constructors - else - None - -(* -------------------------------------------------------------------- *) -let is_standard_constructor (p : mlpath) = - as_standard_constructor p <> None - -(* -------------------------------------------------------------------- *) -let maybe_paren (outer, side) inner doc = - let noparens _inner _outer side = - let (pi, fi) = _inner in - let (po, fo) = _outer in - (pi > po) || - (match (fi, side) with - | Postfix , Left -> true - | Prefix , Right -> true - | Infix Left , Left -> (pi = po) && (fo = Infix Left ) - | Infix Right, Right -> (pi = po) && (fo = Infix Right) - | Infix Left , ILeft -> (pi = po) && (fo = Infix Left ) - | Infix Right, IRight -> (pi = po) && (fo = Infix Right) - | _ , NonAssoc -> (pi = po) && (fi = fo) - | _ , _ -> false) - in - - if noparens inner outer side then doc else parens doc - -(* -------------------------------------------------------------------- *) -let escape_byte_hex (x: byte) = - "\\x" ^ hex_string_of_byte x - -let escape_char_hex (x: char) = - escape_byte_hex (byte_of_char x) - -(* -------------------------------------------------------------------- *) -let escape_or fallback = function - | c when (c = '\\') -> "\\\\" - | c when (c = ' ' ) -> " " - | c when (c = '\b') -> "\\b" - | c when (c = '\t') -> "\\t" - | c when (c = '\r') -> "\\r" - | c when (c = '\n') -> "\\n" - | c when (c = '\'') -> "\\'" - | c when (c = '\"') -> "\\\"" - | c when (is_letter_or_digit c)-> string_of_char c - | c when (is_punctuation c) -> string_of_char c - | c when (is_symbol c) -> string_of_char c - | c -> fallback c - - -(* -------------------------------------------------------------------- *) -let string_of_mlconstant (sctt : mlconstant) = - match sctt with - | MLC_Unit -> "()" - | MLC_Bool true -> "true" - | MLC_Bool false -> "false" - | MLC_Char c -> (* Unicode characters, in OCaml we use BatUChar (wraper for int) *) - if Util.codegen_fsharp() then "'" ^ (string_of_char c) ^ "'" else - let nc = Char.int_of_char c in - (string_of_int nc) ^ (if nc >= 32 && nc = 127 && nc < 34 then " (*" ^ (string_of_char c) ^"*)" else "") - | MLC_Int (s, Some (Signed, Int32)) -> s ^"l" - | MLC_Int (s, Some (Signed, Int64)) -> s ^"L" - | MLC_Int (s, Some (_, Int8)) - | MLC_Int (s, Some (_, Int16)) -> s - | MLC_Int (v, Some (_, Sizet)) -> - let z = "(Prims.parse_int \"" ^ v ^ "\")" in - "(FStar_SizeT.uint_to_t (" ^ z ^ "))" - | MLC_Int (v, Some (s, w)) -> - let sign = match s with - | Signed -> "Int" - | Unsigned -> "UInt" in - let ws = match w with - | Int8 -> "8" - | Int16 -> "16" - | Int32 -> "32" - | Int64 -> "64" in - let z = "(Prims.parse_int \"" ^ v ^ "\")" in - let u = match s with - | Signed -> "" - | Unsigned -> "u" in - "(FStar_" ^ sign ^ ws ^ "." ^ u ^ "int_to_t (" ^ z ^ "))" - | MLC_Int (s, None) -> "(Prims.parse_int \"" ^s^ "\")" - | MLC_Float d -> string_of_float d - - | MLC_Bytes bytes -> - (* A byte buffer. Not meant to be readable. *) - "\"" ^ FStar.Compiler.Bytes.f_encode escape_byte_hex bytes ^ "\"" - - | MLC_String chars -> - (* It was a string literal. Escape what was (likely) escaped originally. - Leave everything else as is. That way, we get the OCaml semantics, - which is that strings are series of bytes, and that if you happen to - provide some well-formed UTF-8 sequence (e.g. "héhé", which has length - 6), then you get the same well-formed UTF-8 sequence on exit. It is up - to userland to provide some UTF-8 compatible functions (e.g. - utf8_length). *) - "\"" ^ String.collect (escape_or string_of_char) chars ^ "\"" - - | _ -> failwith "TODO: extract integer constants properly into OCaml" - - -(* -------------------------------------------------------------------- *) -let string_of_etag = function - | E_PURE -> "" - | E_ERASABLE -> "Erased" - | E_IMPURE -> "Impure" - -let rec doc_of_mltype' (currentModule : mlsymbol) (outer : level) (ty : mlty) = - match ty with - | MLTY_Var x -> - let escape_tyvar s = - if BU.starts_with s "'_" //this denotes a weak type variable in OCaml; it cannot be written in source programs - then BU.replace_char s '_' 'u' - else s in - text (escape_tyvar x) - - | MLTY_Tuple tys -> - let doc = List.map (doc_of_mltype currentModule (t_prio_tpl, Left)) tys in - let doc = parens (hbox (combine (text " * ") doc)) in - doc - - | MLTY_Named (args, name) -> begin - let args = - match args with - | [] -> empty - | [arg] -> doc_of_mltype currentModule (t_prio_name, Left) arg - | _ -> - let args = List.map (doc_of_mltype currentModule (min_op_prec, NonAssoc)) args in - parens (hbox (combine (text ", ") args)) - - in - - let name = ptsym currentModule name in - - hbox (reduce1 [args; text name]) - end - - | MLTY_Fun (t1, et, t2) -> - let d1 = doc_of_mltype currentModule (t_prio_fun, Left ) t1 in - let d2 = doc_of_mltype currentModule (t_prio_fun, Right) t2 in - maybe_paren outer t_prio_fun (hbox (reduce1 [d1; text " -> "; d2])) - - | MLTY_Top -> - if Util.codegen_fsharp() - then text "obj" - else text "Obj.t" - - | MLTY_Erased -> - text "unit" - -and doc_of_mltype (currentModule : mlsymbol) (outer : level) (ty : mlty) = - doc_of_mltype' currentModule outer (Util.resugar_mlty ty) - -(* -------------------------------------------------------------------- *) -let rec doc_of_expr (currentModule : mlsymbol) (outer : level) (e : mlexpr) : doc = - match e.expr with - | MLE_Coerce (e, t, t') -> - let doc = doc_of_expr currentModule (min_op_prec, NonAssoc) e in - if Util.codegen_fsharp() - then parens (reduce [text "Prims.unsafe_coerce "; doc]) - else parens (reduce [text "Obj.magic "; parens doc]) - - | MLE_Seq es -> - let docs = List.map (doc_of_expr currentModule (min_op_prec, NonAssoc)) es in - let docs = List.map (fun d -> reduce [d; text ";"; hardline]) docs in - parens (reduce docs) - - | MLE_Const c -> - text (string_of_mlconstant c) - - | MLE_Var x -> - text x - - | MLE_Name path -> - text (ptsym currentModule path) - - | MLE_Record (path, _, fields) -> - let for1 (name, e) = - let doc = doc_of_expr currentModule (min_op_prec, NonAssoc) e in - reduce1 [text (ptsym currentModule (path, name)); text "="; doc] in - - cbrackets (combine (text "; ") (List.map for1 fields)) - - | MLE_CTor (ctor, []) -> - let name = - if is_standard_constructor ctor then - snd (Option.get (as_standard_constructor ctor)) - else - ptctor currentModule ctor in - text name - - | MLE_CTor (ctor, args) -> - let name = - if is_standard_constructor ctor then - snd (Option.get (as_standard_constructor ctor)) - else - ptctor currentModule ctor in - let args = List.map (doc_of_expr currentModule (min_op_prec, NonAssoc)) args in - let doc = - match name, args with - (* Special case for Cons *) - | "::", [x;xs] -> reduce [parens x; text "::"; xs] - | _, _ -> reduce1 [text name; parens (combine (text ", ") args)] in - maybe_paren outer e_app_prio doc - - | MLE_Tuple es -> - let docs = List.map (fun x -> parens (doc_of_expr currentModule (min_op_prec, NonAssoc) x)) es in - let docs = parens (combine (text ", ") docs) in - docs - - | MLE_Let ((rec_, lets), body) -> - let pre = - if e.loc <> dummy_loc - then reduce [hardline; doc_of_loc e.loc] - else empty - in - let doc = doc_of_lets currentModule (rec_, false, lets) in - let body = doc_of_expr currentModule (min_op_prec, NonAssoc) body in - parens (combine hardline [pre; doc; reduce1 [text "in"; body]]) - - | MLE_App (e, args) -> begin - match e.expr, args with - | MLE_Name p, [ - ({ expr = MLE_Fun ([ _ ], scrutinee) }); - ({ expr = MLE_Fun ([ {mlbinder_name=arg} ], possible_match)}) - ] when (string_of_mlpath p = "FStar.Compiler.Effect.try_with" || - string_of_mlpath p = "FStar.All.try_with") -> - let branches = - match possible_match with - | ({ expr = MLE_Match ({ expr = MLE_Var arg' }, branches) }) when (arg = arg') -> - branches - | e -> - (* F* may reduce [match ... with ... -> e | ... -> e] into [e]. *) - [ (MLP_Wild, None, e) ] - in - doc_of_expr currentModule outer ({ - expr = MLE_Try (scrutinee, branches); - mlty = possible_match.mlty; - loc = possible_match.loc - }) - | (MLE_Name p, [e1; e2]) when is_bin_op p -> doc_of_binop currentModule p e1 e2 - - | (MLE_App ({expr=MLE_Name p},[unitVal]), [e1; e2]) when (is_bin_op p && unitVal=ml_unit) -> - doc_of_binop currentModule p e1 e2 - - | (MLE_Name p, [e1]) when is_uni_op p -> doc_of_uniop currentModule p e1 - - | (MLE_App ({expr=MLE_Name p},[unitVal]), [e1]) when (is_uni_op p && unitVal=ml_unit) -> doc_of_uniop currentModule p e1 - - | _ -> - let e = doc_of_expr currentModule (e_app_prio, ILeft) e in - let args = List.map (doc_of_expr currentModule (e_app_prio, IRight)) args in - parens (reduce1 (e :: args)) - end - - | MLE_Proj (e, f) -> - let e = doc_of_expr currentModule (min_op_prec, NonAssoc) e in - let doc = - if Util.codegen_fsharp() //field names are not qualified in F# - then reduce [e; text "."; text (snd f)] - else reduce [e; text "."; text (ptsym currentModule f)] in - doc - - | MLE_Fun (ids, body) -> - let bvar_annot x xt = - if Util.codegen_fsharp() //type inference in F# is not complete, particularly for field projections; so these annotations are needed - then reduce1 [text "("; text x ; - (match xt with | Some xxt -> reduce1 [text " : "; doc_of_mltype currentModule outer xxt] | _ -> text ""); - text ")"] - else text x in - let ids = List.map (fun {mlbinder_name=x;mlbinder_ty=xt} -> bvar_annot x (Some xt)) ids in - let body = doc_of_expr currentModule (min_op_prec, NonAssoc) body in - let doc = reduce1 [text "fun"; reduce1 ids; text "->"; body] in - parens doc - - | MLE_If (cond, e1, None) -> - let cond = doc_of_expr currentModule (min_op_prec, NonAssoc) cond in - let doc = - combine hardline [ - reduce1 [text "if"; cond; text "then"; text "begin"]; - doc_of_expr currentModule (min_op_prec, NonAssoc) e1; - text "end" - ] - - in maybe_paren outer e_bin_prio_if doc - - | MLE_If (cond, e1, Some e2) -> - let cond = doc_of_expr currentModule (min_op_prec, NonAssoc) cond in - let doc = - combine hardline [ - reduce1 [text "if"; cond; text "then"; text "begin"]; - doc_of_expr currentModule (min_op_prec, NonAssoc) e1; - reduce1 [text "end"; text "else"; text "begin"]; - doc_of_expr currentModule (min_op_prec, NonAssoc) e2; - text "end" - ] - - in maybe_paren outer e_bin_prio_if doc - - | MLE_Match (cond, pats) -> - let cond = doc_of_expr currentModule (min_op_prec, NonAssoc) cond in - let pats = List.map (doc_of_branch currentModule) pats in - let doc = reduce1 [text "match"; parens cond; text "with"] :: pats in - let doc = combine hardline doc in - - parens doc - - | MLE_Raise (exn, []) -> - reduce1 [text "raise"; text (ptctor currentModule exn)] - - | MLE_Raise (exn, args) -> - let args = List.map (doc_of_expr currentModule (min_op_prec, NonAssoc)) args in - reduce1 [text "raise"; text (ptctor currentModule exn); parens (combine (text ", ") args)] - - | MLE_Try (e, pats) -> - combine hardline [ - text "try"; - doc_of_expr currentModule (min_op_prec, NonAssoc) e; - text "with"; - combine hardline (List.map (doc_of_branch currentModule) pats) - ] - | MLE_TApp (head, ty_args) -> - // Type applications are only useful meta-data for backends without inference, for example Krml. - // We just skip them here. - doc_of_expr currentModule outer head -and doc_of_binop currentModule p e1 e2 : doc = - let (_, prio, txt) = Option.get (as_bin_op p) in - let e1 = doc_of_expr currentModule (prio, Left ) e1 in - let e2 = doc_of_expr currentModule (prio, Right) e2 in - let doc = reduce1 [e1; text txt; e2] in - parens doc - -and doc_of_uniop currentModule p e1 : doc = - let (_, txt) = Option.get (as_uni_op p) in - let e1 = doc_of_expr currentModule (min_op_prec, NonAssoc ) e1 in - let doc = reduce1 [text txt; parens e1] in - parens doc -(* -------------------------------------------------------------------- *) -and doc_of_pattern (currentModule : mlsymbol) (pattern : mlpattern) : doc = - match pattern with - | MLP_Wild -> text "_" - | MLP_Const c -> text (string_of_mlconstant c) - | MLP_Var x -> text x - - | MLP_Record (path, fields) -> - let for1 (name, p) = reduce1 [text (ptsym currentModule (path, name)); text "="; doc_of_pattern currentModule p] in - cbrackets (combine (text "; ") (List.map for1 fields)) - - | MLP_CTor (ctor, []) -> - let name = - if is_standard_constructor ctor then - snd (Option.get (as_standard_constructor ctor)) - else - ptctor currentModule ctor in - text name - - | MLP_CTor (ctor, pats) -> - let name = - if is_standard_constructor ctor then - snd (Option.get (as_standard_constructor ctor)) - else - ptctor currentModule ctor in - let doc = - match name, pats with - (* Special case for Cons *) - | "::", [x;xs] -> reduce [parens (doc_of_pattern currentModule x); text "::"; doc_of_pattern currentModule xs] - | _, [MLP_Tuple _] -> reduce1 [text name; doc_of_pattern currentModule (List.hd pats)] //no redundant parens; particularly if we have (T of a * b), we must generate T (x, y) not T ((x, y)) - | _ -> reduce1 [text name; parens (combine (text ", ") (List.map (doc_of_pattern currentModule) pats))] in - maybe_paren (min_op_prec, NonAssoc) e_app_prio doc - - | MLP_Tuple ps -> - let ps = List.map (doc_of_pattern currentModule) ps in - parens (combine (text ", ") ps) - - | MLP_Branch ps -> - let ps = List.map (doc_of_pattern currentModule) ps in - let ps = List.map parens ps in - combine (text " | ") ps - -(* -------------------------------------------------------------------- *) -and doc_of_branch (currentModule : mlsymbol) ((p, cond, e) : mlbranch) : doc = - let case = - match cond with - | None -> reduce1 [text "|"; doc_of_pattern currentModule p] - | Some c -> - let c = doc_of_expr currentModule (min_op_prec, NonAssoc) c in - reduce1 [text "|"; doc_of_pattern currentModule p; text "when"; c] in - - combine hardline [ - reduce1 [case; text "->"; text "begin"]; - doc_of_expr currentModule (min_op_prec, NonAssoc) e; - text "end"; - ] - -(* -------------------------------------------------------------------- *) -and doc_of_lets (currentModule : mlsymbol) (rec_, top_level, lets) = - let for1 {mllb_name=name; mllb_tysc=tys; mllb_def=e; print_typ=pt} = - let e = doc_of_expr currentModule (min_op_prec, NonAssoc) e in - //TODO: maybe extract the top-level binders from e and print it alongside name - //let f x = x - //let f = fun x -> x - //i.e., print the latter as the former - let ids = [] in - let ty_annot = - if (not pt) then text "" - else - if Util.codegen_fsharp () && (rec_ = Rec || top_level) //needed for polymorphic recursion and to overcome incompleteness of type inference in F# - then match tys with - | Some (_::_, _) | None -> //except, emitting binders for type variables in F# sometimes also requires emitting type constraints; which is not yet supported - text "" - | Some ([], ty) -> - let ty = doc_of_mltype currentModule (min_op_prec, NonAssoc) ty in - reduce1 [text ":"; ty] - else if top_level - then match tys with - | None -> - text "" - | Some ([], ty) -> - let ty = doc_of_mltype currentModule (min_op_prec, NonAssoc) ty in - reduce1 [text ":"; ty] - | Some (vs, ty) -> - let ty = doc_of_mltype currentModule (min_op_prec, NonAssoc) ty in - let vars = vs |> ty_param_names - |> List.map (fun x -> doc_of_mltype currentModule (min_op_prec, NonAssoc) (MLTY_Var x)) - |> reduce1 in - reduce1 [text ":"; vars; text "."; ty] - else text "" in - reduce1 [text name; reduce1 ids; ty_annot; text "="; e] in - - let letdoc = if rec_ = Rec then reduce1 [text "let"; text "rec"] else text "let" in - - let lets = List.map for1 lets in - let lets = List.mapi (fun i doc -> - reduce1 [(if i = 0 then letdoc else text "and"); doc]) - lets in - - combine hardline lets - - -and doc_of_loc (lineno, file) = - if (Options.no_location_info()) || Util.codegen_fsharp () || file=" dummy" then - empty - else - let file = BU.basename file in - reduce1 [ text "#"; num lineno; text ("\"" ^ file ^ "\"") ] - -(* -------------------------------------------------------------------- *) -let doc_of_mltydecl (currentModule : mlsymbol) (decls : mltydecl) = - let for1 ({tydecl_name=x; tydecl_ignored=mangle_opt; tydecl_parameters=tparams; tydecl_defn=body}) = - let x = match mangle_opt with - | None -> x - | Some y -> y in - let tparams = - let tparams = ty_param_names tparams in - match tparams with - | [] -> empty - | [x] -> text x - | _ -> - let doc = List.map (fun x -> (text x)) tparams in - parens (combine (text ", ") doc) in - - let forbody (body : mltybody) = - match body with - | MLTD_Abbrev ty -> - doc_of_mltype currentModule (min_op_prec, NonAssoc) ty - - | MLTD_Record fields -> begin - let forfield (name, ty) = - let name = text name in - let ty = doc_of_mltype currentModule (min_op_prec, NonAssoc) ty in - reduce1 [name; text ":"; ty] - - in cbrackets (combine (text "; ") (List.map forfield fields)) - end - - | MLTD_DType ctors -> - let forctor (name, tys) = - let _names, tys = List.split tys in - match tys with - | [] -> text name - | _ -> - let tys = List.map (doc_of_mltype currentModule (t_prio_tpl, Left)) tys in - let tys = combine (text " * ") tys in - reduce1 [text name; text "of"; tys] - in - - let ctors = List.map forctor ctors in - let ctors = List.map (fun d -> reduce1 [text "|"; d]) ctors in - combine hardline ctors - - in - - let doc = reduce1 [tparams; text (ptsym currentModule ([], x))] in - - match body with - | None -> doc - | Some body -> - let body = forbody body in - combine hardline [reduce1 [doc; text "="]; body] - - in - - let doc = List.map for1 decls in - let doc = if (List.length doc >0) then reduce1 [text "type"; combine (text " \n and ") doc] else text "" in - doc - -(* -------------------------------------------------------------------- *) -let rec doc_of_sig1 currentModule s = - match s with - | MLS_Mod (x, subsig) -> - combine hardline - [reduce1 [text "module"; text x; text "="]; - doc_of_sig currentModule subsig; - reduce1 [text "end"]] - - | MLS_Exn (x, []) -> - reduce1 [text "exception"; text x] - - | MLS_Exn (x, args) -> - let args = List.map (doc_of_mltype currentModule (min_op_prec, NonAssoc)) args in - let args = parens (combine (text " * ") args) in - reduce1 [text "exception"; text x; text "of"; args] - - | MLS_Val (x, (_, ty)) -> - let ty = doc_of_mltype currentModule (min_op_prec, NonAssoc) ty in - reduce1 [text "val"; text x; text ": "; ty] - - | MLS_Ty decls -> - doc_of_mltydecl currentModule decls - -(* -------------------------------------------------------------------- *) -and doc_of_sig (currentModule : mlsymbol) (s : mlsig) = - let docs = List.map (doc_of_sig1 currentModule) s in - let docs = List.map (fun x -> reduce [x; hardline; hardline]) docs in - reduce docs - - -(* -------------------------------------------------------------------- *) -let doc_of_mod1 (currentModule : mlsymbol) (m : mlmodule1) = - match m.mlmodule1_m with - | MLM_Exn (x, []) -> - reduce1 [text "exception"; text x] - - | MLM_Exn (x, args) -> - let args = List.map snd args in - let args = List.map (doc_of_mltype currentModule (min_op_prec, NonAssoc)) args in - let args = parens (combine (text " * ") args) in - reduce1 [text "exception"; text x; text "of"; args] - - | MLM_Ty decls -> - doc_of_mltydecl currentModule decls - - | MLM_Let (rec_, lets) -> - doc_of_lets currentModule (rec_, true, lets) - - | MLM_Top e -> - reduce1 [ - text "let"; text "_"; text "="; - doc_of_expr currentModule (min_op_prec, NonAssoc) e - ] - - | MLM_Loc loc -> - doc_of_loc loc - -(* -------------------------------------------------------------------- *) -let doc_of_mod (currentModule : mlsymbol) (m : mlmodule) = - let docs = List.map (fun x -> - let doc = doc_of_mod1 currentModule x in - [doc; (match x.mlmodule1_m with | MLM_Loc _ -> empty | _ -> hardline); hardline]) m in - reduce (List.flatten docs) - -(* -------------------------------------------------------------------- *) -let doc_of_mllib_r (MLLib mllib) = - let rec for1_sig (x, sigmod, MLLib sub) = - let x = Util.flatten_mlpath x in - let head = reduce1 [text "module"; text x; text ":"; text "sig"] in - let tail = reduce1 [text "end"] in - let doc = Option.map (fun (s, _) -> doc_of_sig x s) sigmod in - let sub = List.map for1_sig sub in - let sub = List.map (fun x -> reduce [x; hardline; hardline]) sub in - - reduce [ - cat head hardline; - (match doc with - | None -> empty - | Some s -> cat s hardline); - reduce sub; - cat tail hardline; - ] - and for1_mod istop (mod_name, sigmod, MLLib sub) = - let target_mod_name = Util.flatten_mlpath mod_name in - let maybe_open_pervasives = - match mod_name with - | ["FStar"], "Pervasives" -> [] - | _ -> - let pervasives = Util.flatten_mlpath (["FStar"], "Pervasives") in - [hardline; - text ("open " ^ pervasives)] - in - let head = reduce1 (if Util.codegen_fsharp() - then [text "module"; text target_mod_name] - else if not istop - then [text "module"; text target_mod_name; text "="; text "struct"] - else []) in - let tail = if not istop - then reduce1 [text "end"] - else reduce1 [] in - let doc = Option.map (fun (_, m) -> doc_of_mod target_mod_name m) sigmod in - let sub = List.map (for1_mod false) sub in - let sub = List.map (fun x -> reduce [x; hardline; hardline]) sub in - let prefix = if Util.codegen_fsharp() then [cat (text "#light \"off\"") hardline] else [] in - reduce <| (prefix @ [ - head; - hardline; - text "open Prims"] @ - maybe_open_pervasives @ - [hardline; - (match doc with - | None -> empty - | Some s -> cat s hardline); - reduce sub; - cat tail hardline; - ]) - - in - - let docs = List.map (fun (x,s,m) -> - (Util.flatten_mlpath x,for1_mod true (x,s,m))) mllib in - docs - -(* -------------------------------------------------------------------- *) -let pretty (sz : int) (Doc doc) = doc - -let doc_of_mllib mllib = - doc_of_mllib_r mllib - -let string_of_mlexpr cmod (e:mlexpr) = - let doc = doc_of_expr (Util.flatten_mlpath cmod) (min_op_prec, NonAssoc) e in - pretty 0 doc - -let string_of_mlty (cmod) (e:mlty) = - let doc = doc_of_mltype (Util.flatten_mlpath cmod) (min_op_prec, NonAssoc) e in - pretty 0 doc - -instance showable_mlexpr : showable mlexpr = { - show = string_of_mlexpr ([], ""); -} - -instance showable_mlty : showable mlty = { - show = string_of_mlty ([], ""); -} - -instance showable_etag : showable e_tag = { - show = string_of_etag -} diff --git a/src/extraction/FStar.Extraction.ML.Code.fsti b/src/extraction/FStar.Extraction.ML.Code.fsti deleted file mode 100644 index c12b92fc661..00000000000 --- a/src/extraction/FStar.Extraction.ML.Code.fsti +++ /dev/null @@ -1,34 +0,0 @@ -(* - Copyright 2008-2015 Abhishek Anand, Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -(* -------------------------------------------------------------------- *) -module FStar.Extraction.ML.Code -open FStar.Compiler.Effect - -open FStar.Extraction.ML.Syntax -open FStar.Class.Show -open FStar.Pprint - -type doc = | Doc of string - -val doc_of_mllib : mllib -> list (string & doc) -val doc_of_sig : mlsymbol -> mlsig -> doc -val string_of_mlexpr: mlpath -> mlexpr -> string -val string_of_mlty: mlpath -> mlty -> string -val pretty: int -> doc -> string - -instance val showable_mlexpr : showable mlexpr -instance val showable_mlty : showable mlty -instance val showable_etag : showable e_tag \ No newline at end of file diff --git a/src/extraction/FStar.Extraction.ML.Modul.fst b/src/extraction/FStar.Extraction.ML.Modul.fst deleted file mode 100644 index 085fe0a0e34..00000000000 --- a/src/extraction/FStar.Extraction.ML.Modul.fst +++ /dev/null @@ -1,1372 +0,0 @@ -(* - Copyright 2008-2015 Abhishek Anand, Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Extraction.ML.Modul - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Compiler.Util -open FStar.Const -open FStar.Extraction.ML -open FStar.Extraction.ML.RegEmb -open FStar.Extraction.ML.UEnv -open FStar.Extraction.ML.Util -open FStar.Ident -open FStar.Pervasives -open FStar.Syntax - -open FStar.Syntax.Syntax -open FStar.Extraction.ML.Syntax (* Intentionally shadows part of Syntax.Syntax *) - -open FStar.Class.Show - -module Term = FStar.Extraction.ML.Term -module MLS = FStar.Extraction.ML.Syntax -module BU = FStar.Compiler.Util -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module UF = FStar.Syntax.Unionfind -module U = FStar.Syntax.Util -module TC = FStar.TypeChecker.Tc -module N = FStar.TypeChecker.Normalize -module PC = FStar.Parser.Const -module Util = FStar.Extraction.ML.Util -module Env = FStar.TypeChecker.Env -module TcUtil = FStar.TypeChecker.Util -module EMB = FStar.Syntax.Embeddings -module Cfg = FStar.TypeChecker.Cfg -module PO = FStar.TypeChecker.Primops - -let dbg_ExtractionReify = Debug.get_toggle "ExtractionReify" - -type tydef_declaration = (mlsymbol & FStar.Extraction.ML.Syntax.metadata & int) //int is the arity - -type iface = { - iface_module_name: mlpath; - iface_bindings: list (fv & exp_binding); - iface_tydefs: list (either tydef tydef_declaration); - iface_type_names:list (fv & mlpath); -} - -let extension_extractor_table - : BU.smap extension_extractor - = FStar.Compiler.Util.smap_create 20 - -let register_extension_extractor (ext:string) (callback:extension_extractor) = - FStar.Compiler.Util.smap_add extension_extractor_table ext callback - -let lookup_extension_extractor (ext:string) = - (* Try to find a plugin if lookup fails *) - let do () = FStar.Compiler.Util.smap_try_find extension_extractor_table ext in - match do () with - | None -> - if Plugins.autoload_plugin ext - then do () - else None - | r -> r - -type env_t = UEnv.uenv - -(*This approach assumes that failwith already exists in scope. This might be problematic, see below.*) -let fail_exp (lid:lident) (t:typ) = - mk (Tm_app {hd=S.fvar (PC.failwith_lid()) None; - args=[ S.iarg t - ; S.as_arg <| - mk (Tm_constant - (Const_string ("Not yet implemented: " ^ show lid, Range.dummyRange))) - Range.dummyRange]}) - Range.dummyRange - -let always_fail lid t = - let imp = - match U.arrow_formals t with - | [], t -> - // Avoid top-level failwith statements - let b = mk_binder <| (gen_bv "_" None t) in - U.abs [b] (fail_exp lid t) None - | bs, t -> - U.abs bs (fail_exp lid t) None - in - let lb = { - lbname=Inr (S.lid_as_fv lid None); - lbunivs=[]; - lbtyp=t; - lbeff=PC.effect_ML_lid(); - lbdef=imp; - lbattrs=[]; - lbpos=imp.pos; - } in - lb - -let as_pair = function - | [a;b] -> (a,b) - | _ -> failwith "Expected a list with 2 elements" - -let flag_of_qual : S.qualifier -> option meta = function - | S.Assumption -> Some Assumed - | S.Private -> Some Private - | S.NoExtract -> Some NoExtract - | _ -> None - -(*****************************************************************************) -(* Extracting type definitions from the signature *) -(*****************************************************************************) - -// So far, we recognize only a couple special attributes; they are encoded as -// type constructors for an inductive defined in Pervasives, to provide a minimal -// amount of typo-checking via desugaring. -let rec extract_meta x : option meta = - match SS.compress x with - | { n = Tm_fvar fv } -> - begin match string_of_lid (lid_of_fv fv) with - | "FStar.Pervasives.PpxDerivingShow" -> Some PpxDerivingShow - | "FStar.Pervasives.PpxDerivingYoJson" -> Some PpxDerivingYoJson - | "FStar.Pervasives.CInline" -> Some CInline - | "FStar.Pervasives.CNoInline" -> Some CNoInline - | "FStar.Pervasives.Substitute" -> Some Substitute - | "FStar.Pervasives.Gc" -> Some GCType - | "FStar.Pervasives.CAbstractStruct" -> Some CAbstract - | "FStar.Pervasives.CIfDef" -> Some CIfDef - | "FStar.Pervasives.CMacro" -> Some CMacro - | "Prims.deprecated" -> Some (Deprecated "") - | _ -> None - end - | { n = Tm_app {hd={ n = Tm_fvar fv }; args=[{ n = Tm_constant (Const_string (s, _)) }, _]} } -> - begin match string_of_lid (lid_of_fv fv) with - | "FStar.Pervasives.PpxDerivingShowConstant" -> Some (PpxDerivingShowConstant s) - | "FStar.Pervasives.Comment" -> Some (Comment s) - | "FStar.Pervasives.CPrologue" -> Some (CPrologue s) - | "FStar.Pervasives.CEpilogue" -> Some (CEpilogue s) - | "FStar.Pervasives.CConst" -> Some (CConst s) - | "FStar.Pervasives.CCConv" -> Some (CCConv s) - | "Prims.deprecated" -> Some (Deprecated s) - | _ -> None - end - | { n = Tm_constant (Const_string ("KrmlPrivate", _)) } -> Some Private // This one generated internally - // These are only for backwards compatibility, they should be removed at some point. - | { n = Tm_constant (Const_string ("c_inline", _)) } -> Some CInline - | { n = Tm_constant (Const_string ("substitute", _)) } -> Some Substitute - | { n = Tm_meta {tm=x} } -> extract_meta x - | _ -> - let head, args = U.head_and_args x in - match (SS.compress head).n, args with - | Tm_fvar fv, [_] - when S.fv_eq_lid fv FStar.Parser.Const.remove_unused_type_parameters_lid -> - begin - match fst (FStar.ToSyntax.ToSyntax.parse_attr_with_list - false x FStar.Parser.Const.remove_unused_type_parameters_lid) - with - | None -> None - | Some l -> Some (RemoveUnusedTypeParameters (l, S.range_of_fv fv)) - end - | _ -> None - -let extract_metadata metas = - List.choose extract_meta metas - -let binders_as_mlty_binders (env:UEnv.uenv) bs : UEnv.uenv & list ty_param = - BU.fold_map - (fun env ({binder_bv=bv; binder_attrs}) -> - let env = UEnv.extend_ty env bv false in - let ty_param_name = - match lookup_bv env bv with - | Inl ty -> ty.ty_b_name - | _ -> failwith "Impossible" - in - let ty_param_attrs = - List.map (fun attr -> let e, _, _ = Term.term_as_mlexpr env attr in e) binder_attrs - in - env, {ty_param_name; ty_param_attrs}) - env bs - -(*******************************************************************************) -(* A more convenient representation of inductive types for extraction purposes *) -(*******************************************************************************) - -(*just enough info to generate OCaml code; add more info as needed*) -type data_constructor = { - dname: lident; - dtyp : typ; -} - -type inductive_family = { - ifv : fv; - iname : lident; - iparams: binders; - ityp : term; - idatas : list data_constructor; - iquals : list S.qualifier; - imetadata : metadata; -} - -let print_ifamily i = - BU.print4 "\n\t%s %s : %s { %s }\n" - (show i.iname) - (show i.iparams) - (show i.ityp) - (i.idatas - |> List.map (fun d -> - show d.dname - ^ " : " - ^ show d.dtyp) - |> String.concat "\n\t\t") - -let bundle_as_inductive_families env ses quals - : UEnv.uenv - & list inductive_family = - let env, ifams = - BU.fold_map - (fun env se -> match se.sigel with - | Sig_inductive_typ {lid=l; us; params=bs; t; ds=datas} -> - let _us, t = SS.open_univ_vars us t in - let bs, t = SS.open_term bs t in - let datas = ses |> List.collect (fun se -> match se.sigel with - | Sig_datacon {lid=d; us; t; ty_lid=l'; num_ty_params=nparams} when Ident.lid_equals l l' -> - let _us, t = SS.open_univ_vars us t in - let bs', body = U.arrow_formals t in - let bs_params, rest = BU.first_N (List.length bs) bs' in - let subst = List.map2 (fun ({binder_bv=b'}) ({binder_bv=b}) -> S.NT(b', S.bv_to_name b)) bs_params bs in - let t = U.arrow rest (S.mk_Total body) |> SS.subst subst in - [{dname=d; dtyp=t}] - | _ -> []) in - let metadata = extract_metadata se.sigattrs @ List.choose flag_of_qual quals in - let fv = S.lid_as_fv l None in - let _, env = UEnv.extend_type_name env fv in - env, [{ ifv = fv - ; iname=l - ; iparams=bs - ; ityp=t - ; idatas=datas - ; iquals=se.sigquals - ; imetadata = metadata }] - | _ -> env, []) - env ses in - env, List.flatten ifams - -(********************************************************************************************) -(* Extract Interfaces *) -(********************************************************************************************) - -let empty_iface = { - iface_module_name=[], ""; - iface_bindings = []; - iface_tydefs = []; - iface_type_names = [] -} - -let iface_of_bindings fvs = { - empty_iface with - iface_bindings = fvs; -} - -let iface_of_tydefs tds = { - empty_iface with - iface_tydefs = List.map Inl tds; - iface_type_names=List.map (fun td -> tydef_fv td, tydef_mlpath td) tds; -} - -let iface_of_type_names fvs = { - empty_iface with - iface_type_names = fvs -} - -let iface_union if1 if2 = { - iface_module_name = - (if if1.iface_module_name <> if1.iface_module_name - then failwith "Union not defined" - else if1.iface_module_name); - iface_bindings = if1.iface_bindings @ if2.iface_bindings; - iface_tydefs = if1.iface_tydefs @ if2.iface_tydefs; - iface_type_names = if1.iface_type_names @ if2.iface_type_names -} - -let iface_union_l ifs = List.fold_right iface_union ifs empty_iface - -let string_of_mlpath (p:mlpath) = - String.concat ". " (fst p @ [snd p]) -let tscheme_to_string cm ts = - (Code.string_of_mlty cm (snd ts)) -let print_exp_binding cm e = - BU.format3 "{\n\texp_b_name = %s\n\texp_b_expr = %s\n\texp_b_tscheme = %s }" - e.exp_b_name - (Code.string_of_mlexpr cm e.exp_b_expr) - (tscheme_to_string cm e.exp_b_tscheme) -let print_binding cm (fv, exp_binding) = - BU.format2 "(%s, %s)" - (show #Syntax.fv fv) - (print_exp_binding cm exp_binding) -let print_tydef cm tydef = - let name, defn = - match tydef with - | Inl tydef -> - show (tydef_fv tydef), - tscheme_to_string cm (tydef_def tydef) - | Inr (p, _, _) -> - p, "None" - in - BU.format2 "(%s, %s)" name defn -let iface_to_string iface = - let cm = iface.iface_module_name in - let print_type_name (tn, _) = show tn in - BU.format4 "Interface %s = {\niface_bindings=\n%s;\n\niface_tydefs=\n%s;\n\niface_type_names=%s;\n}" - (string_of_mlpath iface.iface_module_name) - (List.map (print_binding cm) iface.iface_bindings |> String.concat "\n") - (List.map (print_tydef cm) iface.iface_tydefs |> String.concat "\n") - (List.map print_type_name iface.iface_type_names |> String.concat "\n") -let gamma_to_string env = - let cm = current_module_of_uenv env in - let gamma = List.collect (function Fv (b, e) -> [b, e] | _ -> []) (bindings_of_uenv env) in - BU.format1 "Gamma = {\n %s }" - (List.map (print_binding cm) gamma |> String.concat "\n") - -let extract_attrs env (attrs:list S.attribute) : list mlattribute = - List.map (fun attr -> let e, _, _ = Term.term_as_mlexpr env attr in e) attrs - -(* Type abbreviations: - //extracting `type t = e` - //or `let t = e` when e is a type - - Extraction for interfaces and implementations is basically the same - - - The returned env is extended with the tydef - - - A tydef provides the representation of the abbreviation - unfolded all the way to a type constant, i.e., inductive or arrow - - - The list mlmodule1 returned is the concrete definition - of the abbreviation in ML, emitted only in the implementation -*) -let extract_typ_abbrev env quals attrs lb - : env_t - & iface - & list mlmodule1 = - let tcenv, (lbdef, lbtyp) = - let tcenv, _, def_typ = - Env.open_universes_in (tcenv_of_uenv env) lb.lbunivs [lb.lbdef; lb.lbtyp] - in - tcenv, as_pair def_typ - in - let lbtyp = FStar.TypeChecker.Normalize.normalize [Env.Beta;Env.UnfoldUntil delta_constant; Env.ForExtraction] tcenv lbtyp in - //eta expansion is important; see issue #490 - let lbdef = FStar.TypeChecker.Normalize.eta_expand_with_type tcenv lbdef lbtyp in - let fv = right lb.lbname in - let lid = fv.fv_name.v in - let def = SS.compress lbdef |> U.unmeta |> U.un_uinst in - let def = - match def.n with - | Tm_abs _ -> Term.normalize_abs def - | _ -> def in - let bs, body = - match def.n with - | Tm_abs {bs; body} -> - SS.open_term bs body - | _ -> [], def in - let assumed = BU.for_some (function Assumption -> true | _ -> false) quals in - let env1, ml_bs = binders_as_mlty_binders env bs in - let body = - Term.term_as_mlty env1 body |> Util.eraseTypeDeep (Util.udelta_unfold env1) - in - let metadata = - let has_val_decl = UEnv.has_tydef_declaration env lid in - let meta = extract_metadata attrs @ List.choose flag_of_qual quals in - if has_val_decl - then (//BU.print1 "%s has val decl\n" (Ident.string_of_lid lid); - HasValDecl (Ident.range_of_lid lid) :: meta) - else (//BU.print1 "%s does not have val decl\n" (Ident.string_of_lid lid); - meta) - in - let tyscheme = ml_bs, body in - let mlpath, iface, env = - if quals |> BU.for_some (function Assumption | New -> true | _ -> false) - then let mlp, env = UEnv.extend_type_name env fv in - mlp, iface_of_type_names [(fv, mlp)], env - else let td, mlp, env = UEnv.extend_tydef env fv tyscheme metadata in - mlp, iface_of_tydefs [td], env - in - let td = { - tydecl_assumed = assumed; - tydecl_name = snd mlpath; - tydecl_ignored = None; - tydecl_parameters = ml_bs; - tydecl_meta = metadata; - tydecl_defn = Some (MLTD_Abbrev body) - } in - let loc_mlmodule1 = MLM_Loc (Util.mlloc_of_range (Ident.range_of_lid lid)) in - let ty_mlmodule1 = MLM_Ty [td] in - let def = [mk_mlmodule1 loc_mlmodule1; - mk_mlmodule1_with_attrs ty_mlmodule1 (extract_attrs env attrs)] in - env, - iface, - def - -let extract_let_rec_type env quals attrs lb - : env_t - & iface - & list mlmodule1 = - let lbtyp = - FStar.TypeChecker.Normalize.normalize - [Env.Beta; - Env.AllowUnboundUniverses; - Env.EraseUniverses; - Env.UnfoldUntil delta_constant; - Env.ForExtraction] - (tcenv_of_uenv env) - lb.lbtyp - in - let bs, _ = U.arrow_formals lbtyp in - let env1, ml_bs = binders_as_mlty_binders env bs in - let fv = right lb.lbname in - let lid = fv.fv_name.v in - let body = MLTY_Top in - let metadata = extract_metadata attrs @ List.choose flag_of_qual quals in - let assumed = false in - let tscheme = ml_bs, body in - let tydef, mlp, env = UEnv.extend_tydef env fv tscheme metadata in - let td = { - tydecl_assumed = assumed; - tydecl_name = snd mlp; - tydecl_ignored = None; - tydecl_parameters = ml_bs; - tydecl_meta = metadata; - tydecl_defn = Some (MLTD_Abbrev body) - } in - let loc_mlmodule1 = MLM_Loc (Util.mlloc_of_range (Ident.range_of_lid lid)) in - let td_mlmodule1 = MLM_Ty [td] in - let def = [mk_mlmodule1 loc_mlmodule1; - mk_mlmodule1_with_attrs td_mlmodule1 (extract_attrs env attrs)] in - let iface = iface_of_tydefs [tydef] in - env, - iface, - def - -(* extract_bundle_iface: - Extracts a bundle of inductive type definitions for an interface - - Effectively providing names and types to the data constructors - and arities for the type coonstructors -*) -let extract_bundle_iface env se - : env_t & iface = - let extract_ctor (env_iparams:env_t) - (ml_tyvars:list ty_param) - (env:env_t) - (ctor: data_constructor) - : env_t & (fv & exp_binding) = - let mlt = Util.eraseTypeDeep - (Util.udelta_unfold env_iparams) - (Term.term_as_mlty env_iparams ctor.dtyp) in - let tys = (ml_tyvars, mlt) in - let fvv = lid_as_fv ctor.dname None in - let env, _, b = extend_fv env fvv tys false in - env, (fvv, b) - in - - let extract_one_family env ind - : env_t & list (fv & exp_binding) = - let env_iparams, vars = binders_as_mlty_binders env ind.iparams in - let env, ctors = ind.idatas |> BU.fold_map (extract_ctor env_iparams vars) env in - let env = - match BU.find_opt (function RecordType _ -> true | _ -> false) ind.iquals with - | Some (RecordType (ns, ids)) -> - let g = - List.fold_right - (fun id g -> - let _, g = UEnv.extend_record_field_name g (ind.iname, id) in - g) - ids - env - in - g - | _ -> - env - in - env, ctors - in - - match se.sigel, se.sigquals with - | Sig_bundle {ses=[{sigel = Sig_datacon {lid=l; t}}]}, [ExceptionConstructor] -> - let env, ctor = extract_ctor env [] env ({dname=l; dtyp=t}) in - env, iface_of_bindings [ctor] - - | Sig_bundle {ses}, quals -> - if U.has_attribute se.sigattrs PC.erasable_attr - then env, empty_iface - else begin - let env, ifams = bundle_as_inductive_families env ses quals in - let env, td = BU.fold_map extract_one_family env ifams in - env, - iface_union - (iface_of_type_names (List.map (fun x -> x.ifv, UEnv.mlpath_of_lident env x.iname) ifams)) - (iface_of_bindings (List.flatten td)) - end - - | _ -> failwith "Unexpected signature element" - -let extract_type_declaration (g:uenv) is_interface_val lid quals attrs univs t - : env_t - & iface - & list mlmodule1 - = if not (quals |> BU.for_some (function Assumption -> true | _ -> false)) - then let g = UEnv.extend_with_tydef_declaration g lid in - g, empty_iface, [] - else let bs, _ = U.arrow_formals t in - let fv = S.lid_as_fv lid None in - let lb = { - lbname = Inr fv; - lbunivs = univs; - lbtyp = t; - lbeff = PC.effect_Tot_lid; - lbdef = U.abs bs t_unit None; - lbattrs = attrs; - lbpos = t.pos - } in - let g, iface, mods = extract_typ_abbrev g quals attrs lb in - let iface = - if is_interface_val - then let mlp = UEnv.mlpath_of_lident g lid in - let meta = extract_metadata attrs in - { empty_iface with iface_tydefs = [Inr (snd mlp, meta, List.length bs)] } - else iface - in - g, iface, mods - -let extract_reifiable_effect g ed - : uenv - & iface - & list mlmodule1 = - let extend_iface lid mlp exp exp_binding = - let fv = (S.lid_as_fv lid None) in - let lb = { - mllb_name=snd mlp; - mllb_tysc=None; - mllb_add_unit=false; - mllb_def=exp; - mllb_attrs=[]; - mllb_meta = []; - print_typ=false - } - in - iface_of_bindings [fv, exp_binding], mk_mlmodule1 (MLM_Let(NonRec, [lb])) - in - - let rec extract_fv tm = - if !dbg_ExtractionReify then - BU.print1 "extract_fv term: %s\n" (show tm); - match (SS.compress tm).n with - | Tm_uinst (tm, _) -> extract_fv tm - | Tm_fvar fv -> - let mlp = mlpath_of_lident g fv.fv_name.v in - let ({exp_b_tscheme=tysc}) = UEnv.lookup_fv tm.pos g fv in - with_ty MLTY_Top <| MLE_Name mlp, tysc - | _ -> failwith (BU.format2 "(%s) Not an fv: %s" - (Range.string_of_range tm.pos) - (show tm)) - in - - let extract_action g (a:S.action) = - assert (match a.action_params with | [] -> true | _ -> false); - if !dbg_ExtractionReify then - BU.print2 "Action type %s and term %s\n" - (show a.action_typ) - (show a.action_defn); - let lbname = Inl (S.new_bv (Some a.action_defn.pos) tun) in - let lb = mk_lb (lbname, a.action_univs, PC.effect_Tot_lid, a.action_typ, a.action_defn, [], a.action_defn.pos) in - let lbs = (false, [lb]) in - let action_lb = mk (Tm_let {lbs; body=U.exp_false_bool}) a.action_defn.pos in - let a_let, _, ty = Term.term_as_mlexpr g action_lb in - let exp, tysc = match a_let.expr with - | MLE_Let((_, [mllb]), _) -> - (match mllb.mllb_tysc with - | Some(tysc) -> mllb.mllb_def, tysc - | None -> failwith "No type scheme") - | _ -> failwith "Impossible" in - let a_nm, a_lid, exp_b, g = extend_with_action_name g ed a tysc in - if !dbg_ExtractionReify then - BU.print1 "Extracted action term: %s\n" (Code.string_of_mlexpr a_nm a_let); - if !dbg_ExtractionReify then begin - BU.print1 "Extracted action type: %s\n" (Code.string_of_mlty a_nm (snd tysc)); - List.iter (fun x -> BU.print1 "and binders: %s\n" x) (ty_param_names (fst tysc)) end; - let iface, impl = extend_iface a_lid a_nm exp exp_b in - g, (iface, impl) - in - - let g, return_iface, return_decl = - let return_tm, ty_sc = extract_fv (ed |> U.get_return_repr |> must |> snd) in - let return_nm, return_lid, return_b, g = extend_with_monad_op_name g ed "return" ty_sc in - let iface, impl = extend_iface return_lid return_nm return_tm return_b in - g, iface, impl - in - - let g, bind_iface, bind_decl = - let bind_tm, ty_sc = extract_fv (ed |> U.get_bind_repr |> must |> snd) in - let bind_nm, bind_lid, bind_b, g = extend_with_monad_op_name g ed "bind" ty_sc in - let iface, impl = extend_iface bind_lid bind_nm bind_tm bind_b in - g, iface, impl - in - - let g, actions = BU.fold_map extract_action g ed.actions in - let actions_iface, actions = List.unzip actions in - - g, - iface_union_l (return_iface::bind_iface::actions_iface), - return_decl::bind_decl::actions - -(* Returns false iff the letbinding are not homogeneous. The letbindings -are homogeneous when they all have the same "kind" (defining and arity -or a non-arity). *) -let should_split_let_rec_types_and_terms (env:uenv) (lbs:list letbinding) - : bool - = let rec is_homogeneous out lbs = - match lbs with - | [] -> true - | lb::lbs_tail -> - let is_type = Term.is_arity env lb.lbtyp in - match out with - | None -> is_homogeneous (Some is_type) lbs_tail - | Some b when b = is_type -> - is_homogeneous (Some is_type) lbs_tail - | _ -> - false - in - not (is_homogeneous None lbs) - -let split_let_rec_types_and_terms se (env:uenv) (lbs:list letbinding) - : list sigelt - = let rec aux (out:list sigelt) (mutuals:list letbinding) (lbs:list letbinding) - : (list sigelt & list letbinding) - = match lbs with - | [] -> out, mutuals - | lb::lbs_tail -> - let out, mutuals = aux out mutuals lbs_tail in - if not (Term.is_arity env lb.lbtyp) - then ( - //This is a term, not a type - out, lb::mutuals - ) - else ( - //This is a type; split it into a sigelt - let formals, body, rc_opt = U.abs_formals_maybe_unascribe_body true lb.lbdef in - let body = S.tconst PC.c_true_lid in //extract it not as unit, since otherwise it will be treated as erasable - let lbdef = U.abs formals body None in - let lb = { lb with lbdef } in - let se = { se with sigel = Sig_let {lbs=(false, [lb]); lids=[]} } in - se::out, mutuals - ) - in - let sigs, lbs = aux [] [] lbs in - let lb = {se with sigel = Sig_let {lbs=(true, lbs); - lids=List.map (fun lb -> lb.lbname |> BU.right |> lid_of_fv) lbs} } in - let sigs = sigs@[lb] in - // BU.print1 "Split let recs into %s\n" - // (List.map show sigs |> String.concat ";;\n"); - sigs - - -let extract_let_rec_types se (env:uenv) (lbs:list letbinding) = - //extracting `let rec t .. : Type = e - // and ... - if BU.for_some (fun lb -> not (Term.is_arity env lb.lbtyp)) lbs - then //mixtures of mutually recursively defined types and terms - //should have already been pre-processed away - failwith "Impossible: mixed mutual types and terms" - else - let env, iface_opt, impls = - List.fold_left - (fun (env, iface_opt, impls) lb -> - let env, iface, impl = - extract_let_rec_type env se.sigquals se.sigattrs lb - in - let iface_opt = - match iface_opt with - | None -> Some iface - | Some iface' -> Some (iface_union iface' iface) - in - (env, iface_opt, impl::impls)) - (env, None, []) - lbs - in - env, - Option.get iface_opt, - List.rev impls |> List.flatten - - -let get_noextract_to (se:sigelt) (backend:option Options.codegen_t) : bool = - BU.for_some (function attr -> - let hd, args = U.head_and_args attr in - match (SS.compress hd).n, args with - | Tm_fvar fv, [(a, _)] when S.fv_eq_lid fv PC.noextract_to_attr -> - begin match EMB.try_unembed a EMB.id_norm_cb with - | Some s -> - Option.isSome backend && Options.parse_codegen s = backend - | None -> - false - end - | _ -> false - ) se.sigattrs - -(* - * We support two kinds of noextract knobs: - * - a noextract qualifier - * - a "noextract_to" attribute that takes a string value as argument - * the string value is the backend name, e.g. Krml, OCaml, ... - * - * Whether to extract a definition depends on the backend - * since sometimes Karamel needs the stubs even for definitions - * marked as noextract - * - * TODO: what are such cases? Even there, can we optimize - * extraction to extract only the signature of the definition - * so that we don't pay the cost of normalization etc. for the body - *) -let sigelt_has_noextract (se:sigelt) : bool = - let has_noextract_qualifier = List.contains S.NoExtract se.sigquals in - let has_noextract_attribute = get_noextract_to se (Options.codegen ()) in - match Options.codegen () with - | Some Options.Krml -> - has_noextract_qualifier && has_noextract_attribute - | _ -> - has_noextract_qualifier || has_noextract_attribute - -// If this sigelt had [@@ noextract_to "krml"] and we are indeed -// extracting to Karamel, then we will still process it: it's the -// karamel pipeline which will later drop the body. It checks for the -// NoExtract qualifier to decide that, so we add it here. -let karamel_fixup_qual (se:sigelt) : sigelt = - if Options.codegen () = Some Options.Krml - && get_noextract_to se (Some Options.Krml) - && not (List.contains S.NoExtract se.sigquals) - then { se with sigquals = S.NoExtract :: se.sigquals } - else se - -let mark_sigelt_erased (se:sigelt) (g:uenv) : uenv = - debug g (fun u -> BU.print1 ">>>> NOT extracting %s \n" (Print.sigelt_to_string_short se)); - // Cheating with delta levels and qualifiers below, but we don't ever use them. - List.fold_right (fun lid g -> extend_erased_fv g (S.lid_as_fv lid None)) - (U.lids_of_sigelt se) g - -// If the definition has an [@@extract_as impl] attribute, -// replace the lbdef with the specified impl: -let fixup_sigelt_extract_as se = - match se.sigel, find_map se.sigattrs N.is_extract_as_attr with - | Sig_let {lids; lbs=(_, [lb])}, Some impl -> - // The specified implementation can be recursive, - // to be on the safe side we always mark the replaced sigelt as recursive. - {se with sigel = Sig_let {lids; lbs=(true, [{lb with lbdef = impl}])}} - | _ -> se - -(* The top-level extraction of a sigelt to an interface *) -let rec extract_sigelt_iface (g:uenv) (se:sigelt) : uenv & iface = - if sigelt_has_noextract se then - let g = mark_sigelt_erased se g in - g, empty_iface - else - let se = karamel_fixup_qual se in - let se = fixup_sigelt_extract_as se in - - match se.sigel with - | Sig_bundle _ - | Sig_inductive_typ _ - | Sig_datacon _ -> - extract_bundle_iface g se - - | Sig_declare_typ {lid; us=univs; t} when Term.is_arity g t -> //lid is a type - let env, iface, _ = - extract_type_declaration g true lid se.sigquals se.sigattrs univs t - in - env, iface - - | Sig_let {lbs=(false, [lb])} when Term.is_arity g lb.lbtyp -> - if se.sigquals |> BU.for_some (function Projector _ -> true | _ -> false) - then ( - //Don't extract projectors returning types---not useful for typing generated code and - //And can actually break F# extraction, in case there are unused type parameters - g, empty_iface - ) else ( - let env, iface, _ = - extract_typ_abbrev g se.sigquals se.sigattrs lb - in - env, iface - ) - - | Sig_let {lbs=(true, lbs)} - when should_split_let_rec_types_and_terms g lbs -> - let ses = split_let_rec_types_and_terms se g lbs in - let iface = {empty_iface with iface_module_name=(current_module_of_uenv g)} in - List.fold_left - (fun (g, out) se -> - let g, mls = extract_sigelt_iface g se in - g, iface_union out mls) - (g, iface) ses - - | Sig_let {lbs=(true, lbs)} - when BU.for_some (fun lb -> Term.is_arity g lb.lbtyp) lbs -> - let env, iface, _ = - extract_let_rec_types se g lbs - in - env, iface - - | Sig_declare_typ {lid; t} -> - let quals = se.sigquals in - if quals |> List.contains Assumption - && not (TcUtil.must_erase_for_extraction (tcenv_of_uenv g) t) - then let g, bindings = Term.extract_lb_iface g (false, [always_fail lid t]) in - g, iface_of_bindings bindings - else g, empty_iface //it's not assumed, so wait for the corresponding Sig_let to generate code - //or, it must be erased - - (* Extension extraction is only supported for non-recursive let bindings *) - | Sig_let { lbs=(false, [lb]) } when (Cons? se.sigmeta.sigmeta_extension_data) -> ( - match List.tryPick - (fun (ext, blob) -> - match lookup_extension_extractor ext with - | None -> None - | Some extractor -> Some (ext, blob, extractor)) - se.sigmeta.sigmeta_extension_data - with - | None -> - let g, bindings = Term.extract_lb_iface g (false, [lb]) in - g, iface_of_bindings bindings - | Some (ext, blob, extractor) -> - let res = extractor.extract_sigelt_iface g se blob in - match res with - | Inl res -> res - | Inr err -> - Errors.raise_error se Errors.Fatal_ExtractionUnsupported - (BU.format2 "Extension %s failed to extract iface: %s" ext err) - - ) - - | Sig_let {lbs} -> - let g, bindings = Term.extract_lb_iface g lbs in - g, iface_of_bindings bindings - - | Sig_assume _ - | Sig_sub_effect _ - | Sig_effect_abbrev _ - | Sig_polymonadic_bind _ - | Sig_polymonadic_subcomp _ -> - g, empty_iface - - | Sig_pragma (p) -> - U.process_pragma p se.sigrng; - g, empty_iface - - | Sig_splice _ -> - failwith "impossible: trying to extract splice" - - | Sig_fail _ -> - failwith "impossible: trying to extract Sig_fail" - - | Sig_new_effect ed -> - if TcUtil.effect_extraction_mode (tcenv_of_uenv g) ed.mname = S.Extract_reify - && List.isEmpty ed.binders //we do not extract parameterized effects - then let env, iface, _ = extract_reifiable_effect g ed in - env, iface - else g, empty_iface - -let extract_iface' (g:env_t) modul = - if Options.interactive() then g, empty_iface else - let _ = Options.restore_cmd_line_options true in - let decls = modul.declarations in - let iface = {empty_iface with iface_module_name=(current_module_of_uenv g)} in - let res = - List.fold_left (fun (g, iface) se -> - let g, iface' = extract_sigelt_iface g se in - g, iface_union iface iface') - (g, iface) - decls - in - ignore <| Options.restore_cmd_line_options true; - res - -let extract_iface (g:env_t) modul = - let g, iface = - UF.with_uf_enabled (fun () -> - if Debug.any() - then FStar.Compiler.Util.measure_execution_time - (BU.format1 "Extracted interface of %s" (string_of_lid modul.name)) - (fun () -> extract_iface' g modul) - else extract_iface' g modul) - in - let g, _ = UEnv.with_typars_env g (fun e -> - let iface_tydefs : list RemoveUnusedParameters.tydef = - List.map - (function - | Inl td -> snd (UEnv.tydef_mlpath td), UEnv.tydef_meta td, Inl (UEnv.tydef_def td) - | Inr (p, m, n) -> p, m, Inr n) - iface.iface_tydefs - in - let module_name, _ = UEnv.extend_with_module_name g modul.name in - let e = RemoveUnusedParameters.set_current_module e module_name in - RemoveUnusedParameters.elim_tydefs e iface_tydefs) - in - UEnv.exit_module g, iface - -(********************************************************************************************) -(* Extract Implementations *) -(********************************************************************************************) - -let extract_bundle env se = - let extract_ctor (env_iparams:env_t) - (ml_tyvars:list ty_param) - (env:env_t) - (ctor: data_constructor): - env_t & (mlsymbol & list (mlsymbol & mlty)) - = - let mlt = Util.eraseTypeDeep (Util.udelta_unfold env_iparams) (Term.term_as_mlty env_iparams ctor.dtyp) in - let steps = [ Env.Inlining; Env.UnfoldUntil S.delta_constant; Env.EraseUniverses; Env.AllowUnboundUniverses; Env.ForExtraction ] in - let names = match (SS.compress (N.normalize steps (tcenv_of_uenv env_iparams) ctor.dtyp)).n with - | Tm_arrow {bs} -> - List.map (fun ({binder_bv={ ppname = ppname }}) -> (string_of_id ppname)) bs - | _ -> - [] - in - let tys = (ml_tyvars, mlt) in - let fvv = lid_as_fv ctor.dname None in - let env, mls, _ = extend_fv env fvv tys false in - env, - (mls, List.zip names (argTypes mlt)) in - - let extract_one_family env ind = - let env_iparams, vars = binders_as_mlty_binders env ind.iparams in - let env, ctors = ind.idatas |> BU.fold_map (extract_ctor env_iparams vars) env in - let indices, _ = U.arrow_formals ind.ityp in - let ml_params = List.append vars (indices |> List.mapi (fun i _ -> { - ty_param_name = "'dummyV" ^ BU.string_of_int i; - ty_param_attrs = [] - })) in - let tbody, env = - match BU.find_opt (function RecordType _ -> true | _ -> false) ind.iquals with - | Some (RecordType (ns, ids)) -> - let _, c_ty = List.hd ctors in - assert (List.length ids = List.length c_ty); - let fields, g = - List.fold_right2 - (fun id (_, ty) (fields, g) -> - let mlid, g = UEnv.extend_record_field_name g (ind.iname, id) in - (mlid, ty)::fields, g) - ids - c_ty - ([], env) - in - Some (MLTD_Record fields), g - | _ when List.length ctors = 0 -> - None, env - | _ -> - Some (MLTD_DType ctors), env - in - let td = { - tydecl_assumed = false; - tydecl_name = snd (mlpath_of_lident env ind.iname); - tydecl_ignored = None; - tydecl_parameters = ml_params; - tydecl_meta = ind.imetadata; - tydecl_defn = tbody - } in - env, - td - in - - let mlattrs = extract_attrs env se.sigattrs in - match se.sigel, se.sigquals with - | Sig_bundle {ses=[{sigel = Sig_datacon {lid=l; t}}]}, [ExceptionConstructor] -> - let env, ctor = extract_ctor env [] env ({dname=l; dtyp=t}) in - env, [mk_mlmodule1_with_attrs (MLM_Exn ctor) mlattrs] - - | Sig_bundle {ses}, quals -> - if U.has_attribute se.sigattrs PC.erasable_attr - then env, [] - else begin - let env, ifams = bundle_as_inductive_families env ses quals in - let env, td = BU.fold_map extract_one_family env ifams in - env, [mk_mlmodule1_with_attrs (MLM_Ty td) mlattrs] - end - - | _ -> failwith "Unexpected signature element" - -let lb_is_irrelevant (g:env_t) (lb:letbinding) : bool = - Env.non_informative (tcenv_of_uenv g) lb.lbtyp && // result type is non informative - not (Term.is_arity g lb.lbtyp) && // but not a type definition - U.is_pure_or_ghost_effect lb.lbeff // and not top-level effectful - -let lb_is_tactic (g:env_t) (lb:letbinding) : bool = - if U.is_pure_effect lb.lbeff then // not top-level effectful - let bs, c = U.arrow_formals_comp_ln lb.lbtyp in - let c_eff_name = c |> U.comp_effect_name |> Env.norm_eff_name (tcenv_of_uenv g) in - lid_equals c_eff_name PC.effect_TAC_lid - else - false - -(*****************************************************************************) -(* Extracting the top-level definitions in a module *) -(*****************************************************************************) -let rec extract_sig (g:env_t) (se:sigelt) : env_t & list mlmodule1 = - Errors.with_ctx (BU.format1 "While extracting top-level definition `%s`" (Print.sigelt_to_string_short se)) (fun () -> - debug g (fun u -> BU.print1 ">>>> extract_sig %s \n" (Print.sigelt_to_string_short se)); - - if sigelt_has_noextract se then - let g = mark_sigelt_erased se g in - g, [] - else begin - let se = karamel_fixup_qual se in - let se = fixup_sigelt_extract_as se in - - match se.sigel with - | Sig_bundle _ - | Sig_inductive_typ _ - | Sig_datacon _ -> - let g, ses = extract_bundle g se in - g, ses @ maybe_register_plugin g se - - | Sig_new_effect ed when Env.is_reifiable_effect (tcenv_of_uenv g) ed.mname -> - let env, _iface, impl = - extract_reifiable_effect g ed in - env, impl - - | Sig_splice _ -> - failwith "impossible: trying to extract splice" - - | Sig_fail _ -> - failwith "impossible: trying to extract Sig_fail" - - | Sig_new_effect _ -> - g, [] - - (* Ignore all non-informative sigelts *) - | Sig_let {lbs=(_, lbs)} when List.for_all (lb_is_irrelevant g) lbs -> - g, [] - - (* Ignore tactics whenever we're not extracting plugins *) - | Sig_let {lbs=(_, lbs)} - when Options.codegen () <> Some (Options.Plugin) && - List.for_all (lb_is_tactic g) lbs -> - g, [] - - | Sig_declare_typ {lid; us=univs; t} when Term.is_arity g t -> //lid is a type - //extracting `assume type t : k` - let env, _, impl = extract_type_declaration g false lid se.sigquals se.sigattrs univs t in - env, impl - - | Sig_let {lbs=(false, [lb])} when Term.is_arity g lb.lbtyp -> - //extracting `type t = e` - //or `let t = e` when e is a type - if se.sigquals |> BU.for_some (function Projector _ -> true | _ -> false) - then ( - //Don't extract projectors returning types---not useful for typing generated code and - //And can actually break F# extraction, in case there are unused type parameters - g, [] - ) else ( - let env, _, impl = - extract_typ_abbrev g se.sigquals se.sigattrs lb - in - env, impl - ) - - | Sig_let {lbs=(true, lbs)} - when should_split_let_rec_types_and_terms g lbs -> - let ses = split_let_rec_types_and_terms se g lbs in - List.fold_left - (fun (g, out) se -> - let g, mls = extract_sig g se in - g, out@mls) (g, []) ses - - | Sig_let {lbs=(true, lbs)} - when BU.for_some (fun lb -> Term.is_arity g lb.lbtyp) lbs -> - //extracting `let rec t .. : Type = e - // and ... - let env, _, impl = - extract_let_rec_types se g lbs - in - env, impl - - (* Extension extraction is only supported for non-recursive let bindings *) - | Sig_let { lbs=(false, [lb]) } when (Cons? se.sigmeta.sigmeta_extension_data) -> ( - match List.tryPick - (fun (ext, blob) -> - match lookup_extension_extractor ext with - | None -> None - | Some extractor -> Some (ext, blob, extractor)) - se.sigmeta.sigmeta_extension_data with - | None -> - extract_sig_let g se - - | Some (ext, blob, extractor) -> - match extractor.extract_sigelt g se blob with - | Inl decls -> - let meta = extract_metadata se.sigattrs in - let mlattrs = extract_attrs g se.sigattrs in - List.fold_left (fun (g, decls) d -> - match d.mlmodule1_m with - | MLM_Let (maybe_rec, [mllb]) -> - let g, mlid, _ = - UEnv.extend_lb g lb.lbname lb.lbtyp (must mllb.mllb_tysc) mllb.mllb_add_unit in - let mllb = { mllb with mllb_name = mlid; mllb_attrs = mlattrs; mllb_meta = meta } in - g, decls@[mk_mlmodule1_with_attrs (MLM_Let (maybe_rec, [mllb])) mlattrs] - | _ -> - failwith (BU.format1 "Unexpected ML decl returned by the extension: %s" (show d)) - ) (g, []) decls - | Inr err -> - Errors.raise_error se Errors.Fatal_ExtractionUnsupported - (BU.format2 "Extension %s failed to extract term: %s" ext err) - ) - - | Sig_let _ -> extract_sig_let g se - - | Sig_declare_typ {lid; t} -> - let quals = se.sigquals in - if quals |> List.contains Assumption - && not (TcUtil.must_erase_for_extraction (tcenv_of_uenv g) t) - then let always_fail = - { se with sigel = Sig_let {lbs=(false, [always_fail lid t]); lids=[]} } in - let g, mlm = extract_sig g always_fail in //extend the scope with the new name - match BU.find_map quals (function Discriminator l -> Some l | _ -> None) with - | Some l -> //if it's a discriminator, generate real code for it, rather than mlm - g, [mk_mlmodule1 (MLM_Loc (Util.mlloc_of_range se.sigrng)); - Term.ind_discriminator_body g lid l] - - | _ -> - begin match BU.find_map quals (function Projector (l,_) -> Some l | _ -> None) with - (* TODO : this could fail, it happens that projectors for variants are assumed *) - | Some _ -> //it must be a record projector, since other projectors are not assumed - g, [] //records are extracted as ML records; no projectors for them - | _ -> - g, mlm //in all other cases, generate mlm, a stub that always fails - end - else g, [] //it's not assumed, so wait for the corresponding Sig_let to generate code - //or, it must be erased - - | Sig_assume _ //not needed; purely logical - | Sig_sub_effect _ - | Sig_effect_abbrev _ //effects are all primitive; so these are not extracted; this may change as we add user-defined non-primitive effects - | Sig_polymonadic_bind _ - | Sig_polymonadic_subcomp _ -> - g, [] - | Sig_pragma (p) -> - U.process_pragma p se.sigrng; - g, [] - end - ) - -and extract_sig_let (g:uenv) (se:sigelt) : uenv & list mlmodule1 = - if not (Sig_let? se.sigel) - then failwith "Impossible: should only be called with Sig_let" - else begin - let Sig_let { lbs } = se.sigel in - let attrs = se.sigattrs in - let quals = se.sigquals in - let maybe_postprocess_lbs lbs = - let post_tau = - match U.extract_attr' PC.postprocess_extr_with attrs with - | None -> None - | Some (_, (tau, None)::_) -> Some tau - | Some _ -> - Errors.log_issue se Errors.Warning_UnrecognizedAttribute - "Ill-formed application of 'postprocess_for_extraction_with'"; - None - in - let postprocess_lb (tau:term) (lb:letbinding) : letbinding = - let env = tcenv_of_uenv g in - let lbdef = - Profiling.profile - (fun () -> Env.postprocess env tau lb.lbtyp lb.lbdef) - (Some (Ident.string_of_lid (Env.current_module env))) - "FStar.Extraction.ML.Module.post_process_for_extraction" - in - { lb with lbdef = lbdef } - in - match post_tau with - | None -> lbs - | Some tau -> fst lbs, List.map (postprocess_lb tau) (snd lbs) - in - let maybe_normalize_for_extraction lbs = - let norm_steps = - match U.extract_attr' PC.normalize_for_extraction_lid attrs with - | None -> None - | Some (_, (steps, None)::_) -> - let steps = - //just normalizing the steps themselves, so that the user - //does not have to write a literal at every use of the attribute - N.normalize - [Env.UnfoldUntil delta_constant; Env.Zeta; Env.Iota; Env.Primops] - (tcenv_of_uenv g) - steps - in - begin - match PO.try_unembed_simple steps with - | Some steps -> - Some (Cfg.translate_norm_steps steps) - | _ -> - Errors.log_issue se Errors.Warning_UnrecognizedAttribute - (BU.format1 - "Ill-formed application of 'normalize_for_extraction': normalization steps '%s' could not be interpreted" - (show steps)); - None - end - | Some _ -> - Errors.log_issue se Errors.Warning_UnrecognizedAttribute - "Ill-formed application of 'normalize_for_extraction'"; - None - in - let norm_one_lb steps lb = - let env = tcenv_of_uenv g in - let env = {env with erase_erasable_args=true} in - let lbd = - Profiling.profile - (fun () -> N.normalize steps env lb.lbdef) - (Some (Ident.string_of_lid (Env.current_module env))) - "FStar.Extraction.ML.Module.normalize_for_extraction" - in - { lb with lbdef = lbd } - in - match norm_steps with - | None -> lbs - | Some steps -> - fst lbs, List.map (norm_one_lb steps) (snd lbs) - in - let ml_let, _, _ = - let lbs = maybe_normalize_for_extraction (maybe_postprocess_lbs lbs) in - Term.term_as_mlexpr - g - (mk (Tm_let {lbs; body=U.exp_false_bool}) se.sigrng) - in - let mlattrs = extract_attrs g se.sigattrs in - begin - match ml_let.expr with - | MLE_Let((flavor, bindings), _) -> - - (* Treatment of qualifiers: we synthesize the metadata that goes - * onto each let-binding as follows: - * - F* keywords (qualifiers, such as "inline_for_extraction" or - * "private") are in [quals] and are distributed on each - * let-binding in the mutually recursive block of bindings - * - F* attributes (custom arbitrary terms, such as "[@ GcType - * ]"), are attached to the block of mutually recursive - * definitions, we don't have syntax YET for attaching these - * to individual definitions - * - some extra information is looked up here and added as a - * bonus; in particular, the MustDisappear attribute (that - * StackInline bestows upon an individual let-binding) is - * specific to each let-binding! *) - let flags = List.choose flag_of_qual quals in - let flags' = extract_metadata attrs in - - let g, ml_lbs' = - List.fold_left2 - (fun (env, ml_lbs) (ml_lb:mllb) {lbname=lbname; lbtyp=t } -> - if ml_lb.mllb_meta |> List.contains Erased - then env, ml_lbs - else - // debug g (fun () -> printfn "Translating source lb %s at type %s to %A" (show lbname) (show t) (must (mllb.mllb_tysc))); - let lb_lid = (right lbname).fv_name.v in - let flags'' = - match (SS.compress t).n with - | Tm_arrow {comp={ n = Comp { effect_name = e }}} - when string_of_lid e = "FStar.HyperStack.ST.StackInline" -> - [ StackInline ] - | _ -> - [] - in - let meta = flags @ flags' @ flags'' in - let ml_lb = { ml_lb with mllb_attrs = mlattrs; mllb_meta = meta } in - let g, ml_lb = - if quals |> BU.for_some (function Projector _ -> true | _ -> false) //projector names have to mangled - then let env, mls, _ = - UEnv.extend_fv - env - (right lbname) - (must ml_lb.mllb_tysc) - ml_lb.mllb_add_unit - in - env, {ml_lb with mllb_name=mls } - else let env, _, _ = UEnv.extend_lb env lbname t (must ml_lb.mllb_tysc) ml_lb.mllb_add_unit in - env, ml_lb in - g, ml_lb::ml_lbs) - (g, []) - bindings - (snd lbs) in - g, - [mk_mlmodule1 (MLM_Loc (Util.mlloc_of_range se.sigrng)); - mk_mlmodule1_with_attrs (MLM_Let (flavor, List.rev ml_lbs')) mlattrs] - @ maybe_register_plugin g se - - | _ -> - failwith (BU.format1 "Impossible: Translated a let to a non-let: %s" (Code.string_of_mlexpr (current_module_of_uenv g) ml_let)) - end - end - -let extract' (g:uenv) (m:modul) : uenv & option mllib = - let _ = Options.restore_cmd_line_options true in - let name, g = UEnv.extend_with_module_name g m.name in - let g = set_tcenv g (FStar.TypeChecker.Env.set_current_module (tcenv_of_uenv g) m.name) in - let g = set_current_module g name in - let g, sigs = - BU.fold_map - (fun g se -> - if Debug.any () - then let nm = FStar.Syntax.Util.lids_of_sigelt se |> List.map Ident.string_of_lid |> String.concat ", " in - BU.print1 "+++About to extract {%s}\n" nm; - let r = FStar.Compiler.Util.measure_execution_time - (BU.format1 "---Extracted {%s}" nm) - (fun () -> extract_sig g se) - in - BU.print1 "Extraction result: %s\n" (Class.Show.show (snd r)); - r - else extract_sig g se) - g m.declarations in - let mlm : mlmodule = List.flatten sigs in - let is_karamel = Options.codegen () = Some Options.Krml in - if string_of_lid m.name <> "Prims" - && (is_karamel || not m.is_interface) - then begin - if not (Options.silent()) then (BU.print1 "Extracted module %s\n" (string_of_lid m.name)); - g, Some (MLLib ([name, Some ([], mlm), (MLLib [])])) - end - else g, None - -let extract (g:uenv) (m:modul) = - ignore <| Options.restore_cmd_line_options true; - let tgt = - match Options.codegen() with - | None -> failwith "Impossible: We're in extract, codegen must be set!" - | Some t -> t - in - if not (Options.should_extract (string_of_lid m.name) tgt) then - failwith (BU.format1 "Extract called on a module %s that should not be extracted" (Ident.string_of_lid m.name)); - - if Options.interactive() then g, None else begin - - let nm = string_of_lid m.name in - let g, mllib = - UF.with_uf_enabled (fun () -> - Errors.with_ctx ("While extracting module " ^ nm) - (fun () -> - Profiling.profile - (fun () -> extract' g m) - (Some nm) - "FStar.Extraction.ML.Modul.extract")) - in - let g, mllib = - match mllib with - | None -> - g, mllib - | Some mllib -> - let g, mllib = UEnv.with_typars_env g (fun e -> RemoveUnusedParameters.elim_mllib e mllib) in - g, Some mllib - in - ignore <| Options.restore_cmd_line_options true; - exit_module g, mllib - end diff --git a/src/extraction/FStar.Extraction.ML.Modul.fsti b/src/extraction/FStar.Extraction.ML.Modul.fsti deleted file mode 100644 index 9952a983920..00000000000 --- a/src/extraction/FStar.Extraction.ML.Modul.fsti +++ /dev/null @@ -1,43 +0,0 @@ - -(* - Copyright 2008-2015 Abhishek Anand, Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Extraction.ML.Modul -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Syntax.Syntax -open FStar.Extraction.ML.Syntax -open FStar.Extraction.ML.UEnv -module S = FStar.Syntax.Syntax - -val iface : Type0 - -type extension_sigelt_extractor = - uenv -> sigelt -> FStar.Dyn.dyn -> either mlmodule string -type extension_sigelt_iface_extractor = - uenv -> sigelt -> FStar.Dyn.dyn -> either (uenv & iface) string - -type extension_extractor = { - extract_sigelt : extension_sigelt_extractor; - extract_sigelt_iface : extension_sigelt_iface_extractor; -} - -val register_extension_extractor - (extension_name:string) - (extractor:extension_extractor) - : unit - -val extract_iface: uenv -> modul -> uenv & iface -val extract : uenv -> modul -> uenv & option mllib diff --git a/src/extraction/FStar.Extraction.ML.PrintML.fst b/src/extraction/FStar.Extraction.ML.PrintML.fst deleted file mode 100644 index b2f3e18b1d1..00000000000 --- a/src/extraction/FStar.Extraction.ML.PrintML.fst +++ /dev/null @@ -1,32 +0,0 @@ -(* - Copyright 2008-2015 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Extraction.ML.PrintML -open FStar.Compiler.Effect -open FStar.Compiler -open FStar.Extraction.ML.Syntax -open FStar.Extraction.ML.Code - -(* NOTE!!!! This file is not used by the OCaml build of F* (i.e. the main one). -Instead, it uses an OCaml version ocaml/fstar-lib/FStar_Extraction_ML_PrintML, -so it can use OCaml's native pretty printers. - -This file is here for the F# build. *) - -let print (_: option string) (ext: string) (l: mllib) = - let newDoc = FStar.Extraction.ML.Code.doc_of_mllib l in - List.iter (fun (n,d) -> - FStar.Compiler.Util.write_file (FStar.Options.prepend_output_dir (n^ext)) (FStar.Extraction.ML.Code.pretty 120 d)) newDoc diff --git a/src/extraction/FStar.Extraction.ML.PrintML.fsti b/src/extraction/FStar.Extraction.ML.PrintML.fsti deleted file mode 100644 index 239092307a3..00000000000 --- a/src/extraction/FStar.Extraction.ML.PrintML.fsti +++ /dev/null @@ -1,20 +0,0 @@ -(* - Copyright 2008-2015 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Extraction.ML.PrintML - -open FStar.Extraction.ML.Syntax - -val print: option string -> string -> mllib -> unit diff --git a/src/extraction/FStar.Extraction.ML.RegEmb.fst b/src/extraction/FStar.Extraction.ML.RegEmb.fst deleted file mode 100644 index 32773186de3..00000000000 --- a/src/extraction/FStar.Extraction.ML.RegEmb.fst +++ /dev/null @@ -1,832 +0,0 @@ -(* - Copyright 2008-2015 Abhishek Anand, Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Extraction.ML.RegEmb - -(* This module handles registering plugins and generating -embeddings for their types. *) - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Const -open FStar.Extraction.ML.Syntax -open FStar.Extraction.ML.UEnv -open FStar.Syntax.Syntax - -module BU = FStar.Compiler.Util -module Code = FStar.Extraction.ML.Code -module EMB = FStar.Syntax.Embeddings -module Env = FStar.TypeChecker.Env -module N = FStar.TypeChecker.Normalize -module NBET = FStar.TypeChecker.NBETerm -module PC = FStar.Parser.Const -module Print = FStar.Syntax.Print -module RC = FStar.Reflection.V2.Constants -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module Term = FStar.Extraction.ML.Term -module U = FStar.Syntax.Util -module Util = FStar.Extraction.ML.Util - -open FStar.Class.Show -open FStar.Class.Tagged - -exception NoEmbedding of string -exception Unsupported of string - -(*** ML syntax helpers ***) -let splitlast s = let x::xs = List.rev s in (List.rev xs, x) - -let mk e = with_ty MLTY_Top e - -let ml_name : Ident.lid -> mlexpr = - fun l -> - let s = Ident.path_of_lid l in - let ns, id = splitlast s in - mk (MLE_Name (ns, id)) - -let ml_name' : string -> mlexpr = - fun s -> - ml_name (Ident.lid_of_str s) - -let ml_ctor : Ident.lid -> list mlexpr -> mlexpr = - fun l args -> - let s = Ident.path_of_lid l in - let ns, id = splitlast s in - mk (MLE_CTor ((ns, id), args)) - -let ml_record : Ident.lid -> list (string & mlexpr) -> mlexpr = - fun l args -> - let s = Ident.path_of_lid l in - // [] -> assuming same module - mk (MLE_Record ([], l |> Ident.ident_of_lid |> Ident.string_of_id, args)) - -let mk_binder x t = {mlbinder_name=x; mlbinder_ty=t; mlbinder_attrs=[]} - -let ml_lam nm e = - mk <| MLE_Fun ([mk_binder nm MLTY_Top ], e) - -let ml_none : mlexpr = mk (MLE_Name (["FStar"; "Pervasives"; "Native"], "None")) -let ml_some : mlexpr = mk (MLE_Name (["FStar"; "Pervasives"; "Native"], "Some")) - -let tm_fvar_lid = Ident.lid_of_str "FStar.Syntax.Syntax.Tm_fvar" -let fv_eq_lid_lid = Ident.lid_of_str "FStar.Syntax.Syntax.fv_eq_lid" -let s_tdataconstr_lid = Ident.lid_of_str "FStar.Syntax.Syntax.tdataconstr" -let lid_of_str_lid = Ident.lid_of_str "FStar.Ident.lid_of_str" // :^) -let mk_app_lid = Ident.lid_of_str "FStar.Syntax.Util.mk_app" -let nil_lid = Ident.lid_of_str "Prims.Nil" -let cons_lid = Ident.lid_of_str "Prims.Cons" -let embed_lid = Ident.lid_of_str "FStar.Syntax.Embeddings.Base.extracted_embed" -let unembed_lid = Ident.lid_of_str "FStar.Syntax.Embeddings.Base.extracted_unembed" -let bind_opt_lid = Ident.lid_of_str "FStar.Compiler.Util.bind_opt" - -let ml_nbe_unsupported : mlexpr = - (* extraction thunks this definition *) - let hd = mk (MLE_Name (["FStar"; "TypeChecker"; "NBETerm"], "e_unsupported")) in - mk (MLE_App (hd, [ml_unit])) - -let ml_magic : mlexpr = - mk (MLE_Coerce (ml_unit, MLTY_Top, MLTY_Top)) - -let as_name mlp = with_ty MLTY_Top <| MLE_Name mlp - -let ml_failwith (s:string) : mlexpr = - mk <| MLE_App(as_name ([], "failwith"), [mk <| MLE_Const (MLC_String s)]) - -let rec as_ml_list (ts : list mlexpr) : mlexpr = - match ts with - | [] -> ml_ctor nil_lid [] - | t::ts -> ml_ctor cons_lid [t; as_ml_list ts] - -let rec pats_to_list_pat (vs : list mlpattern) : mlpattern = - match vs with - | [] -> MLP_CTor ((["Prims"], "Nil"), []) - | p::ps -> MLP_CTor ((["Prims"], "Cons"), [p; pats_to_list_pat ps]) -(*** / ML syntax helpers ***) - -let fresh : string -> string = - let r = BU.mk_ref 0 in - fun s -> - let v = !r in - r := v+1; - s^"_"^(string_of_int v) - -let not_implemented_warning (r: Range.range) (t: string) (msg: string) = - let open FStar.Pprint in - let open FStar.Errors.Msg in - let open FStar.Class.PP in - Errors.log_issue r Errors.Warning_PluginNotImplemented [ - prefix 2 1 (text (BU.format1 "Plugin `%s' can not run natively because:" t)) - (text msg); - text "Use --warn_error -" - ^^ pp (Errors.error_number (Errors.lookup Errors.Warning_PluginNotImplemented)) - ^/^ text "to carry on." - ] - -type embedding_data = { - arity : int; - syn_emb : Ident.lid; (* lid for regular embedding *) - nbe_emb : option Ident.lid; (* nbe embedding, optional! will abort _at runtime_ if None and called *) -} - -(*** List of registered embeddings ***) -let builtin_embeddings : list (Ident.lident & embedding_data) = - let syn_emb_lid s = Ident.lid_of_path ["FStar"; "Syntax"; "Embeddings"; s] Range.dummyRange in - let nbe_emb_lid s = Ident.lid_of_path ["FStar"; "TypeChecker"; "NBETerm"; s] Range.dummyRange in - let refl_emb_lid s = Ident.lid_of_path ["FStar"; "Reflection"; "V2"; "Embeddings"; s] Range.dummyRange in - let nbe_refl_emb_lid s = Ident.lid_of_path ["FStar"; "Reflection"; "V2"; "NBEEmbeddings"; s] Range.dummyRange in - [ - (PC.int_lid, {arity=0; syn_emb=syn_emb_lid "e_int"; nbe_emb=Some(nbe_emb_lid "e_int")}); - (PC.bool_lid, {arity=0; syn_emb=syn_emb_lid "e_bool"; nbe_emb=Some(nbe_emb_lid "e_bool")}); - (PC.unit_lid, {arity=0; syn_emb=syn_emb_lid "e_unit"; nbe_emb=Some(nbe_emb_lid "e_unit")}); - (PC.string_lid, {arity=0; syn_emb=syn_emb_lid "e_string"; nbe_emb=Some(nbe_emb_lid "e_string")}); - (PC.norm_step_lid, {arity=0; syn_emb=syn_emb_lid "e_norm_step"; nbe_emb=Some(nbe_emb_lid "e_norm_step")}); - (PC.__range_lid, {arity=0; syn_emb=syn_emb_lid "e___range"; nbe_emb=Some(nbe_emb_lid "e___range")}); - - (PC.vconfig_lid, {arity=0; syn_emb=syn_emb_lid "e_vconfig"; nbe_emb=Some(nbe_emb_lid "e_vconfig")}); - - (PC.list_lid, {arity=1; syn_emb=syn_emb_lid "e_list"; nbe_emb=Some(nbe_emb_lid "e_list")}); - (PC.option_lid, {arity=1; syn_emb=syn_emb_lid "e_option"; nbe_emb=Some(nbe_emb_lid "e_option")}); - (PC.sealed_lid, {arity=1; syn_emb=syn_emb_lid "e_sealed"; nbe_emb=Some(nbe_emb_lid "e_sealed")}); - - (PC.mk_tuple_lid 2 Range.dummyRange, {arity=2; syn_emb=syn_emb_lid "e_tuple2"; nbe_emb=Some(nbe_emb_lid "e_tuple2")}); - (PC.mk_tuple_lid 3 Range.dummyRange, {arity=3; syn_emb=syn_emb_lid "e_tuple3"; nbe_emb=Some(nbe_emb_lid "e_tuple3")}); - (PC.either_lid, {arity=2; syn_emb=syn_emb_lid "e_either"; nbe_emb=Some(nbe_emb_lid "e_either")}); - - (* Reflection base types *) - (RC.fstar_refl_types_lid "namedv", {arity=0; syn_emb=refl_emb_lid "e_namedv"; nbe_emb=Some(nbe_refl_emb_lid "e_namedv")}); - (RC.fstar_refl_types_lid "bv", {arity=0; syn_emb=refl_emb_lid "e_bv"; nbe_emb=Some(nbe_refl_emb_lid "e_bv")}); - (RC.fstar_refl_types_lid "binder", {arity=0; syn_emb=refl_emb_lid "e_binder"; nbe_emb=Some(nbe_refl_emb_lid "e_binder")}); - (RC.fstar_refl_types_lid "term", {arity=0; syn_emb=refl_emb_lid "e_term"; nbe_emb=Some(nbe_refl_emb_lid "e_term")}); - (RC.fstar_refl_types_lid "env", {arity=0; syn_emb=refl_emb_lid "e_env"; nbe_emb=Some(nbe_refl_emb_lid "e_env")}); - (RC.fstar_refl_types_lid "fv", {arity=0; syn_emb=refl_emb_lid "e_fv"; nbe_emb=Some(nbe_refl_emb_lid "e_fv")}); - (RC.fstar_refl_types_lid "comp", {arity=0; syn_emb=refl_emb_lid "e_comp"; nbe_emb=Some(nbe_refl_emb_lid "e_comp")}); - (RC.fstar_refl_types_lid "sigelt", {arity=0; syn_emb=refl_emb_lid "e_sigelt"; nbe_emb=Some(nbe_refl_emb_lid "e_sigelt")}); - (RC.fstar_refl_types_lid "ctx_uvar_and_subst", {arity=0; syn_emb=refl_emb_lid "e_ctx_uvar_and_subst"; nbe_emb=Some(nbe_refl_emb_lid "e_ctx_uvar_and_subst")}); - (RC.fstar_refl_types_lid "letbinding",{arity=0; syn_emb=refl_emb_lid "e_letbinding";nbe_emb=Some(nbe_refl_emb_lid "e_letbinding")}); - (RC.fstar_refl_types_lid "ident", {arity=0; syn_emb=refl_emb_lid "e_ident"; nbe_emb=Some(nbe_refl_emb_lid "e_ident")}); - (RC.fstar_refl_types_lid "universe_uvar", {arity=0; syn_emb=refl_emb_lid "e_universe_uvar"; nbe_emb=Some(nbe_refl_emb_lid "e_universe_uvar")}); - (RC.fstar_refl_types_lid "universe", {arity=0; syn_emb=refl_emb_lid "e_universe"; nbe_emb=Some(nbe_refl_emb_lid "e_universe")}); - - (* Views and datatypes *) - (RC.fstar_refl_data_lid "vconst", {arity=0; syn_emb=refl_emb_lid "e_vconst"; nbe_emb=Some(nbe_refl_emb_lid "e_vconst")}); - (RC.fstar_refl_data_lid "aqualv", {arity=0; syn_emb=refl_emb_lid "e_aqualv"; nbe_emb=Some(nbe_refl_emb_lid "e_aqualv")}); - (RC.fstar_refl_data_lid "pattern", {arity=0; syn_emb=refl_emb_lid "e_pattern"; nbe_emb=Some(nbe_refl_emb_lid "e_pattern")}); - (RC.fstar_refl_data_lid "namedv_view", {arity=0; syn_emb=refl_emb_lid "e_namedv_view"; nbe_emb=Some(nbe_refl_emb_lid "e_namedv_view")}); - (RC.fstar_refl_data_lid "bv_view", {arity=0; syn_emb=refl_emb_lid "e_bv_view"; nbe_emb=Some(nbe_refl_emb_lid "e_bv_view")}); - (RC.fstar_refl_data_lid "binder_view", {arity=0; syn_emb=refl_emb_lid "e_binder_view"; nbe_emb=Some(nbe_refl_emb_lid "e_binder_view")}); - (RC.fstar_refl_data_lid "binding", {arity=0; syn_emb=refl_emb_lid "e_binding"; nbe_emb=Some(nbe_refl_emb_lid "e_binding")}); - (RC.fstar_refl_data_lid "universe_view", {arity=0; syn_emb=refl_emb_lid "e_universe_view"; nbe_emb=Some(nbe_refl_emb_lid "e_universe_view")}); - (RC.fstar_refl_data_lid "term_view", {arity=0; syn_emb=refl_emb_lid "e_term_view"; nbe_emb=Some(nbe_refl_emb_lid "e_term_view")}); - (RC.fstar_refl_data_lid "comp_view", {arity=0; syn_emb=refl_emb_lid "e_comp_view"; nbe_emb=Some(nbe_refl_emb_lid "e_comp_view")}); - (RC.fstar_refl_data_lid "lb_view", {arity=0; syn_emb=refl_emb_lid "e_lb_view"; nbe_emb=Some(nbe_refl_emb_lid "e_lb_view")}); - (RC.fstar_refl_data_lid "sigelt_view", {arity=0; syn_emb=refl_emb_lid "e_sigelt_view"; nbe_emb=Some(nbe_refl_emb_lid "e_sigelt_view")}); - (RC.fstar_refl_data_lid "qualifier", {arity=0; syn_emb=refl_emb_lid "e_qualifier"; nbe_emb=Some(nbe_refl_emb_lid "e_qualifier")}); - ] - -let dbg_plugin = Debug.get_toggle "Plugins" - -let local_fv_embeddings : ref (list (Ident.lident & embedding_data)) = BU.mk_ref [] -let register_embedding (l: Ident.lident) (d: embedding_data) : unit = - if !dbg_plugin then - BU.print1 "Registering local embedding for %s\n" (Ident.string_of_lid l); - local_fv_embeddings := (l,d) :: !local_fv_embeddings - -let list_local () = !local_fv_embeddings - -let find_fv_embedding' (l: Ident.lident) : option embedding_data = - match List.find (fun (l', _) -> Ident.lid_equals l l') - (!local_fv_embeddings @ builtin_embeddings) - with - | Some (_, data) -> Some data - | None -> None - -let find_fv_embedding (l: Ident.lident) : embedding_data = - match find_fv_embedding' l with - | Some data -> data - | None -> - raise (NoEmbedding ("Embedding not defined for type " ^ Ident.string_of_lid l)) - -(*** /List of registered embeddings ***) - -type embedding_kind = - | SyntaxTerm - | NBETerm - -(*** Make an embedding for a composite type (arrows, tuples, list, etc). The environment -is a mapping from variable names into their embeddings. *) -let rec embedding_for - (tcenv:Env.env) - (mutuals: list Ident.lid) - (k: embedding_kind) - (env:list (bv & string)) - (t: term) -: mlexpr -= let str_to_name s = as_name ([], s) in - let emb_arrow e1 e2 = - let comb = - match k with - | SyntaxTerm -> ml_name' (`%EMB.e_arrow) - | NBETerm -> ml_name' (`%NBET.e_arrow) - in - mk (MLE_App (comb, [e1; e2])) - in - let find_env_entry bv (bv', _) = S.bv_eq bv bv' in - (* - * We need the whnf to reduce things like - * ppname_t ~> Inhabited.sealed_ string "" ~> Sealed.sealed string - * If we just unfold variable, we will hit lambdas. - *) - let t = N.unfold_whnf tcenv t in - let t = U.un_uinst t in - let t = SS.compress t in - match t.n with - (* A name, explain (why e_any?) *) - | Tm_name bv when BU.for_some (find_env_entry bv) env -> - let comb = - match k with - | SyntaxTerm -> ml_name' (`%EMB.mk_any_emb) - | NBETerm -> ml_name' (`%NBET.mk_any_emb) - in - let s = snd (BU.must (BU.find_opt (find_env_entry bv) env)) in - mk <| MLE_App(comb, [str_to_name s]) - - (* Refinements are irrelevant for embeddings. *) - | Tm_refine {b=x} -> - embedding_for tcenv mutuals k env x.sort - - (* Ascriptions are irrelevant for embeddings. *) - | Tm_ascribed {tm=t} -> - embedding_for tcenv mutuals k env t - - (* Pure arrow *) - | Tm_arrow {bs=[b]; comp=c} when U.is_pure_comp c -> - let [b], c = FStar.Syntax.Subst.open_comp [b] c in - let t0 = b.binder_bv.sort in - let t1 = U.comp_result c in - emb_arrow (embedding_for tcenv mutuals k env t0) (embedding_for tcenv mutuals k env t1) - - (* More than 1 binder, curry and retry *) - | Tm_arrow {bs=b::more::bs; comp=c} -> - let tail = S.mk (Tm_arrow {bs=more::bs; comp=c}) t.pos in - let t = S.mk (Tm_arrow {bs=[b]; comp=S.mk_Total tail}) t.pos in - embedding_for tcenv mutuals k env t - - | Tm_app _ -> - let head, args = U.head_and_args t in - let e_head = embedding_for tcenv mutuals k env head in - let e_args = List.map (fun (t, _) -> embedding_for tcenv mutuals k env t) args in - mk <| MLE_App (e_head, e_args) - - (* An fv part of the mutual set of inductives that we are making - an embedding for, just point to the recursive binding. There is a catch - though: we want to generate something like: - - let rec e_t1 = mk_emb ... - and e_t2 = mk_emb ... - ... - - but this does not satisfy OCamls's let-rec restrictions. Hence, we thunk - all of them, using a name prefix __knot_e, and later define the e_X at the - top-level by unthunking. - *) - | Tm_fvar fv when List.existsb (Ident.lid_equals fv.fv_name.v) mutuals -> - let head = mk <| MLE_Var ("__knot_e_" ^ Ident.string_of_id (Ident.ident_of_lid fv.fv_name.v)) in - mk (MLE_App (head, [ml_unit])) - - (* An fv for which we have an embedding already registered. *) - | Tm_fvar fv when Some? (find_fv_embedding' fv.fv_name.v) -> - let emb_data = find_fv_embedding fv.fv_name.v in - begin match k with - | SyntaxTerm -> ml_name emb_data.syn_emb - | NBETerm -> - begin match emb_data.nbe_emb with - | Some lid -> ml_name lid - | None -> - ml_nbe_unsupported - end - end - - (* - * An fv which we do not have registered, but has the plugin - * attribute. We assume it must have had an embedding generated - * right next to it in its same module. - *) - | Tm_fvar fv when Env.fv_has_attr tcenv fv PC.plugin_attr -> - begin match k with - | SyntaxTerm -> - let lid = fv.fv_name.v in - as_name (List.map Ident.string_of_id (Ident.ns_of_lid lid), - "e_" ^ Ident.string_of_id (Ident.ident_of_lid lid)) - | NBETerm -> - ml_nbe_unsupported - end - - (* An fv which we do not have registered, and did not unfold *) - | Tm_fvar fv -> - raise (NoEmbedding (BU.format1 "Embedding not defined for name `%s'" (show t))) - - | _ -> - raise (NoEmbedding (BU.format2 "Cannot embed type `%s' (%s)" (show t) (tag_of t))) - -type wrapped_term = mlexpr & mlexpr & int & bool - -let interpret_plugin_as_term_fun (env:UEnv.uenv) (fv:fv) (t:typ) (arity_opt:option int) (ml_fv:mlexpr') - : option wrapped_term = - let fv_lid = fv.fv_name.v in - let tcenv = UEnv.tcenv_of_uenv env in - let t = N.normalize [ - Env.EraseUniverses; - Env.AllowUnboundUniverses; - Env.UnfoldUntil S.delta_constant; // unfold abbreviations such as nat - Env.ForExtraction - ] tcenv t in - let as_name mlp = with_ty MLTY_Top <| MLE_Name mlp in - let lid_to_name l = with_ty MLTY_Top <| MLE_Name (UEnv.mlpath_of_lident env l) in - let str_to_name s = as_name ([], s) in - let fv_lid_embedded = - with_ty MLTY_Top <| - MLE_App (as_name (["FStar_Ident"],"lid_of_str"), - [with_ty MLTY_Top <| MLE_Const (MLC_String (Ident.string_of_lid fv_lid))]) - in - let mk_tactic_interpretation l arity = - if arity > FStar.Tactics.InterpFuns.max_tac_arity then - raise (NoEmbedding("tactic plugins can only take up to 20 arguments")) - else - let idroot = - match l with - | SyntaxTerm -> "mk_tactic_interpretation_" - | NBETerm -> "mk_nbe_tactic_interpretation_" - in - as_name (["FStar_Tactics_InterpFuns"], idroot^string_of_int arity) - in - let mk_from_tactic l arity = - let idroot = - match l with - | SyntaxTerm -> "from_tactic_" - | NBETerm -> "from_nbe_tactic_" - in - as_name (["FStar_Tactics_Native"], idroot^string_of_int arity) - in - let mk_arrow_as_prim_step k (arity: int) : mlexpr = - let modul = - match k with - | SyntaxTerm -> ["FStar"; "Syntax"; "Embeddings"] - | NBETerm -> ["FStar"; "TypeChecker"; "NBETerm"] - in - as_name (modul, "arrow_as_prim_step_" ^ string_of_int arity) - in - (* Generates the ML syntax of a term of type - `FStar.Syntax.Embeddings.embedding [[t]]` - where [[t]] is the ML denotation of the F* type t - *) - (* abstract_tvars: - body is an implicitly polymorphic function over tvar_names - whose type is of the form `args -> term` - - returns an mlexpr that explicitly abstracts over FStar.Syntax.term - representations of those type arguments - peeling away a prefix of args corresponding to the type arguments - *) - let abstract_tvars tvar_names (body:mlexpr) : mlexpr = - match tvar_names with - | [] -> - let body = - mk <| MLE_App(as_name (["FStar_Syntax_Embeddings"], "debug_wrap"), - [with_ty MLTY_Top <| MLE_Const (MLC_String (Ident.string_of_lid fv_lid)); - ml_lam "_" (mk <| MLE_App(body, [str_to_name "args"]))]) - in - ml_lam "args" body - | _ -> - let args_tail = MLP_Var "args_tail" in - let mk_cons hd_pat tail_pat = - MLP_CTor ((["Prims"], "Cons"), [hd_pat; tail_pat]) - in - let fst_pat v = - MLP_Tuple [MLP_Var v; MLP_Wild] - in - let pattern = - List.fold_right - (fun hd_var -> mk_cons (fst_pat hd_var)) - tvar_names - args_tail - in - let branch = - pattern, - None, - mk <| MLE_App(body, [as_name ([], "args_tail")]) - in - let default_branch = - MLP_Wild, - None, - mk <| MLE_App(str_to_name "failwith", - [mk <| MLE_Const (MLC_String "arity mismatch")]) - in - let body = - mk <| MLE_Match(as_name ([], "args"), [branch; default_branch]) - in - let body = - mk <| MLE_App(as_name (["FStar_Syntax_Embeddings"], "debug_wrap"), - [with_ty MLTY_Top <| MLE_Const (MLC_String (Ident.string_of_lid fv_lid)); - ml_lam "_" body]) - in - ml_lam "args" body - in - (* We're trying to register a plugin or tactic - ml_fv which has source F* type t *) - let bs, c = U.arrow_formals_comp t in - let bs, c = - match arity_opt with - | None -> bs, c - | Some n -> - let n_bs = List.length bs in - if n = n_bs then bs, c - else if n < n_bs - then let bs, rest = BU.first_N n bs in - let c = S.mk_Total <| U.arrow rest c in - bs, c - else // n > bs - let msg = - BU.format3 - "Embedding not defined for %s; expected arity at least %s; got %s" - (Ident.string_of_lid fv_lid) - (BU.string_of_int n) - (BU.string_of_int n_bs) in - raise (NoEmbedding msg) - in - let result_typ = U.comp_result c in - let arity = List.length bs in - let type_vars, bs = - match - BU.prefix_until - (fun ({binder_bv=b}) -> - match (SS.compress b.sort).n with - | Tm_type _ -> false - | _ -> true) - bs - with - | None -> - bs, [] - | Some (tvars, x, rest) -> - tvars, x::rest - in - (* Explicit polymorphism in the source type `t` - is turned into implicit polymorphism in ML. - - `t` is really `forall type_vars. bs -> result_typ` - *) - let tvar_arity = List.length type_vars in - let non_tvar_arity = List.length bs in - let tvar_names = List.mapi (fun i tv -> ("tv_" ^ string_of_int i)) type_vars in - let tvar_context : list (bv & string) = List.map2 (fun b nm -> b.binder_bv, nm) type_vars tvar_names in - // The tvar_context records all the ML type variables in scope - // All their embeddings will be just identity embeddings - - (* aux: The main function that builds the registration code - - accum_embeddings: all the embeddings of the arguments (in reverse order) - bs: the remaining arguments - - returns (mlexpr, //the registration code - int, //the arity of the compiled code (+1 for tactics) - bool) //true if this is a tactic - *) - let rec aux loc (accum_embeddings:list mlexpr) bs : (mlexpr & int & bool) = - match bs with - | [] -> - let arg_unembeddings = List.rev accum_embeddings in - let res_embedding = embedding_for tcenv [] loc tvar_context result_typ in - let fv_lid = fv.fv_name.v in - if U.is_pure_comp c - then begin - let cb = str_to_name "cb" in - let us = str_to_name "us" in - let embed_fun_N = mk_arrow_as_prim_step loc non_tvar_arity in - let args = arg_unembeddings - @ [res_embedding; - lid_to_name fv_lid; - fv_lid_embedded; - cb; - us] - in - let fun_embedding = mk <| MLE_App(embed_fun_N, args) in - let tabs = abstract_tvars tvar_names fun_embedding in - let cb_tabs = ml_lam "cb" (ml_lam "us" tabs) in - ((if loc = NBETerm then cb_tabs else ml_lam "_psc" cb_tabs), - arity, - true) - end - else if Ident.lid_equals (FStar.TypeChecker.Env.norm_eff_name tcenv (U.comp_effect_name c)) - PC.effect_TAC_lid - then begin - let h = mk_tactic_interpretation loc non_tvar_arity in - let tac_fun = mk <| MLE_App (mk_from_tactic loc non_tvar_arity, - [lid_to_name fv_lid]) - in - let psc = str_to_name "psc" in - let ncb = str_to_name "ncb" in - let us = str_to_name "us" in - let all_args = str_to_name "args" in - let args = - [mk <| MLE_Const (MLC_String (Ident.string_of_lid fv_lid ^ " (plugin)"))] @ - [tac_fun] @ - arg_unembeddings @ - [res_embedding; - psc; - ncb; - us] in - let tabs = - match tvar_names with - | [] -> ml_lam "args" (mk <| MLE_App (h, args@[all_args])) - | _ -> abstract_tvars tvar_names (mk <| MLE_App (h, args)) - in - (ml_lam "psc" (ml_lam "ncb" (ml_lam "us" tabs)), - arity + 1, - false) - end - else raise (NoEmbedding("Plugins not defined for type " ^ show t)) - - | ({binder_bv=b})::bs -> - aux loc (embedding_for tcenv [] loc tvar_context b.sort::accum_embeddings) bs - in - try - let w, a, b = aux SyntaxTerm [] bs in - let w', _, _ = aux NBETerm [] bs in - Some (w, w', a, b) - with - | NoEmbedding msg -> - not_implemented_warning (Ident.range_of_lid fv.fv_name.v) - (show fv) - msg; - None - -(* Creates an unembedding function for the type *) -let mk_unembed - (tcenv:Env.env) // tc environment mostly used to lookup fvs - (mutuals : list Ident.lid) // mutual inductives we are defining embedding for - (record_fields : option (list mlpath)) // if this type is a record, these are the (extracted) field names - (ctors: list sigelt) // constructors of the inductive -: mlexpr -= let e_branches : ref (list mlbranch) = BU.mk_ref [] in - let arg_v = fresh "tm" in - ctors |> List.iter (fun ctor -> - match ctor.sigel with - | Sig_datacon {lid; us; t; ty_lid; num_ty_params; mutuals=_} -> - let fv = fresh "fv" in - let bs, c = U.arrow_formals t in - let vs = List.map (fun b -> fresh (Ident.string_of_id b.binder_bv.ppname), b.binder_bv.sort) bs in - - let pat_s = MLP_Const (MLC_String (Ident.string_of_lid lid)) in - (* let pat_args = MLP_CTor ((["Prims"], "Nil"), List.map (fun (v, _) -> MLP_Var v) vs) in *) - let pat_args = vs |> List.map (fun (v,_) -> MLP_Var v) |> pats_to_list_pat in - let pat_both = MLP_Tuple [pat_s; pat_args] in - - let ret = - match record_fields with - | Some fields -> - ml_record lid (List.map2 (fun (v, _) fld -> snd fld, mk (MLE_Var v)) vs fields) - | None -> - ml_ctor lid (List.map (fun (v, _) -> mk (MLE_Var v)) vs) - in - let ret = mk (MLE_App (ml_some, [ret])) in // final return - - let body = List.fold_right (fun (v, ty) body -> - let body = mk (MLE_Fun ([mk_binder v MLTY_Top], body)) in - - mk (MLE_App (ml_name bind_opt_lid, [ - mk (MLE_App (ml_name unembed_lid, [embedding_for tcenv mutuals SyntaxTerm [] ty; mk (MLE_Var v)])); - body; - ])) - ) vs ret - in - let br = (pat_both, None, body) in - - e_branches := br :: !e_branches - | _ -> failwith "impossible, filter above" - ); - let nomatch : mlbranch = (MLP_Wild, None, ml_none) in - let branches = List.rev (nomatch :: !e_branches) in - let sc = mk (MLE_Var arg_v) in - let def = mk (MLE_Match (sc, branches)) in - let lam = mk (MLE_Fun ([mk_binder arg_v MLTY_Top], def)) in - lam - -(* Creates an embedding function for the type *) -let mk_embed - (tcenv:Env.env) // tc environment mostly used to lookup fvs - (mutuals : list Ident.lid) // mutual inductives we are defining embedding for - (record_fields : option (list mlpath)) // if this type is a record, these are the (extracted) field names - (ctors: list sigelt) // constructors of the inductive -: mlexpr -= let e_branches : ref (list mlbranch) = BU.mk_ref [] in - let arg_v = fresh "tm" in - ctors |> List.iter (fun ctor -> - match ctor.sigel with - | Sig_datacon {lid; us; t; ty_lid; num_ty_params; mutuals=_} -> - let fv = fresh "fv" in - let bs, c = U.arrow_formals t in - let vs = List.map (fun b -> fresh (Ident.string_of_id b.binder_bv.ppname), b.binder_bv.sort) bs in - let pat = - match record_fields with - | Some fields -> - // [] -> assuming same module - MLP_Record ([], List.map2 (fun v fld -> snd fld, MLP_Var (fst v)) vs fields) - | None -> - MLP_CTor (splitlast (Ident.path_of_lid lid), List.map (fun v -> MLP_Var (fst v)) vs) - in - let fvar = ml_name s_tdataconstr_lid in - let lid_of_str = ml_name lid_of_str_lid in - let head = mk (MLE_App (fvar, [ - mk (MLE_App (lid_of_str, [mk (MLE_Const (MLC_String (Ident.string_of_lid lid)))]))])) - in - let mk_mk_app t ts = - // FIXME: all explicit - let ts = List.map (fun t -> mk (MLE_Tuple [t; ml_none])) ts in - mk (MLE_App (ml_name mk_app_lid, [t; as_ml_list ts])) - in - let args = - vs |> List.map (fun (v, ty) -> - let vt = mk (MLE_Var v) in - mk (MLE_App (ml_name embed_lid, [embedding_for tcenv mutuals SyntaxTerm [] ty; vt])) - ) - in - let ret = mk_mk_app head args in - let br = (pat, None, ret) in - - e_branches := br :: !e_branches - | _ -> failwith "impossible, filter above" - ); - let branches = List.rev !e_branches in - let sc = mk (MLE_Var arg_v) in - let def = mk (MLE_Match (sc, branches)) in - let lam = mk (MLE_Fun ([mk_binder arg_v MLTY_Top], def)) in - lam - - -let __do_handle_plugin (g: uenv) (arity_opt: option int) (se: sigelt) : list mlmodule1 = - // BU.print2 "Got plugin with attrs = %s; arity_opt=%s" - // (List.map show se.sigattrs |> String.concat " ") - // (match arity_opt with None -> "None" | Some x -> "Some " ^ string_of_int x); - let r = se.sigrng in - match se.sigel with - | Sig_let {lbs} -> - let mk_registration lb : list mlmodule1 = - let fv = BU.right lb.lbname in - let fv_lid = fv.fv_name.v in - let fv_t = lb.lbtyp in - let ml_name_str = MLE_Const (MLC_String (Ident.string_of_lid fv_lid)) in - match interpret_plugin_as_term_fun g fv fv_t arity_opt ml_name_str with - | Some (interp, nbe_interp, arity, plugin) -> - let register, args = - if plugin - then (["FStar_Tactics_Native"], "register_plugin"), [interp; nbe_interp] - else (["FStar_Tactics_Native"], "register_tactic"), [interp] - in - let h = with_ty MLTY_Top <| MLE_Name register in - let arity = MLE_Const (MLC_Int(string_of_int arity, None)) in - let app = with_ty MLTY_Top <| MLE_App (h, [mk ml_name_str; mk arity] @ args) in - [MLM_Top app |> mk_mlmodule1] - | None -> [] - in - List.collect mk_registration (snd lbs) - - | Sig_bundle {ses} -> - let mutual_sigelts = List.filter (fun se -> match se.sigel with | Sig_inductive_typ _ -> true | _ -> false) ses in - let mutual_lids = List.map (fun se -> match se.sigel with | Sig_inductive_typ {lid} -> lid ) mutual_sigelts in - let proc_one (typ_sigelt:sigelt) = - let Sig_inductive_typ {lid=tlid; params=ps} = typ_sigelt.sigel in - if List.length ps > 0 then - raise (Unsupported "parameters on inductive"); - let ns = Ident.ns_of_lid tlid in - let name = Ident.string_of_id (List.last (Ident.ids_of_lid tlid)) in - - (* get constructors for this particular mutual *) - let ctors = - List.filter (fun se -> match se.sigel with | Sig_datacon {ty_lid} -> Ident.lid_equals ty_lid tlid | _ -> false) ses - in - let ml_name = mk (MLE_Const (MLC_String (Ident.string_of_lid tlid))) in - - let record_fields = - match List.find (function RecordType _ -> true | _ -> false) typ_sigelt.sigquals with - | Some (RecordType (_, b)) -> - (* Extraction may change the names of fields to disambiguate them, - * query the environment for the extracted names. *) - Some (List.map (fun f -> lookup_record_field_name g (tlid, f)) b) - | _ -> - None - in - - let tcenv = tcenv_of_uenv g in - let ml_unembed = mk_unembed tcenv mutual_lids record_fields ctors in - let ml_embed = mk_embed tcenv mutual_lids record_fields ctors in - let def = mk (MLE_App (mk (MLE_Name (["FStar"; "Syntax"; "Embeddings"; "Base"], "mk_extracted_embedding")), [ - ml_name; - ml_unembed; - ml_embed])) - in - let def = mk (MLE_Fun ([mk_binder "_" MLTY_Erased], def)) in // thunk - let lb = { - mllb_name = "__knot_e_" ^ name; - mllb_tysc = None; - mllb_add_unit = false; - mllb_def = def; - mllb_meta = []; - mllb_attrs = []; - print_typ = false; - } - in - // TODO: parameters - register_embedding tlid { - arity = 0; - syn_emb = Ident.lid_of_ns_and_id ns (Ident.mk_ident ("e_"^name, Range.dummyRange)); - nbe_emb = None; - }; - [lb] - in - let lbs = List.concatMap proc_one mutual_sigelts in - let unthunking : list mlmodule1 = - mutual_sigelts |> List.concatMap (fun se -> - let tlid = (match se.sigel with | Sig_inductive_typ {lid=tlid} -> tlid) in - let name = Ident.string_of_id (List.last (Ident.ids_of_lid tlid)) in - let app = - let head = mk <| MLE_Var ("__knot_e_" ^ name) in - mk (MLE_App (head, [ml_unit])) - in - let lb = { - mllb_name = "e_" ^ name; - mllb_tysc = None; - mllb_add_unit = false; - mllb_def = app; - mllb_meta = []; - mllb_attrs = []; - print_typ = false; - } - in - [MLM_Let (NonRec, [lb]) |> mk_mlmodule1] - ) - in - // TODO: We always make a let rec, we could check if that's really needed. - [MLM_Let (Rec, lbs) |> mk_mlmodule1] @ unthunking - - | _ -> [] - -let do_handle_plugin (g: uenv) (arity_opt: option int) (se: sigelt) : list mlmodule1 = - try __do_handle_plugin g arity_opt se with - | Unsupported msg -> - // Change error code? - Errors.log_issue se Errors.Warning_PluginNotImplemented - (BU.format2 "Could not generate a plugin for %s, reason = %s" (Print.sigelt_to_string_short se) msg); - [] - | NoEmbedding msg -> - not_implemented_warning se.sigrng - (Print.sigelt_to_string_short se) - msg; - [] - -(* When extracting a plugin, each top-level definition marked with a `@plugin` attribute - is extracted along with an invocation to FStar.Tactics.Native.register_tactic or register_plugin, - which installs the compiled term as a primitive step in the normalizer - *) -let maybe_register_plugin (g:uenv) (se:sigelt) : list mlmodule1 = - (* The `plugin` attribute takes an optional arity, parse it. - * None: not a plugin - * Some None: plugin without explicit arity - * Some (Some n): plugin with explicit arity n - *) - let plugin_with_arity (attrs: list term) : option (option int) = - BU.find_map attrs (fun t -> - let head, args = U.head_and_args t in - if not (U.is_fvar PC.plugin_attr head) then - None - else match args with - | [(a, _)] -> - (* Try to unembed the argument as an int, warn if not possible. *) - let nopt = EMB.unembed a EMB.id_norm_cb in - Some nopt - | _ -> Some None - ) - in - if Options.codegen() <> Some Options.Plugin then - [] - else match plugin_with_arity se.sigattrs with - | None -> [] - (* ignore projectors and discriminators, they get a @@plugin attribute inherited - from the type, but we should not do anything for them. *) - | Some _ when List.existsb (function Projector _ | Discriminator _ -> true | _ -> false) se.sigquals -> - [] - | Some arity_opt -> - do_handle_plugin g arity_opt se diff --git a/src/extraction/FStar.Extraction.ML.RegEmb.fsti b/src/extraction/FStar.Extraction.ML.RegEmb.fsti deleted file mode 100644 index c7719339513..00000000000 --- a/src/extraction/FStar.Extraction.ML.RegEmb.fsti +++ /dev/null @@ -1,43 +0,0 @@ - -(* - Copyright 2008-2015 Abhishek Anand, Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Extraction.ML.RegEmb - -(* This module handles registering plugins and generating -embeddings for their types. *) - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect - -open FStar.Syntax.Syntax -open FStar.Extraction.ML -open FStar.Extraction.ML.Syntax -open FStar.Extraction.ML.UEnv - -(* When extracting a plugin, each top-level definition marked with a `@plugin` attribute - is extracted along with an invocation to FStar.Tactics.Native.register_tactic or register_plugin, - which installs the compiled term as a primitive step in the normalizer - *) -val maybe_register_plugin (g:uenv) (se:sigelt) : list mlmodule1 - -val interpret_plugin_as_term_fun : - UEnv.uenv - -> fv:fv - -> t:typ - -> arity:option int - -> ml_fv:mlexpr' - -> option (mlexpr & mlexpr & int & bool) diff --git a/src/extraction/FStar.Extraction.ML.RemoveUnusedParameters.fst b/src/extraction/FStar.Extraction.ML.RemoveUnusedParameters.fst deleted file mode 100644 index 1a9066921d3..00000000000 --- a/src/extraction/FStar.Extraction.ML.RemoveUnusedParameters.fst +++ /dev/null @@ -1,389 +0,0 @@ -(* - Copyright 2020 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -(* -------------------------------------------------------------------- *) -module FStar.Extraction.ML.RemoveUnusedParameters -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.Ident -open FStar.Compiler.Util -open FStar.Const -open FStar.BaseTypes -open FStar.Extraction.ML.Syntax -open FStar.Class.Setlike -open FStar.Class.Show - -(** - This module implements a transformation on the FStar.Extraction.ML.Syntax - AST to remove unused type parameters from type abbreviations. - - This is mainly intended for use with F# code extraction, since the - F# compiler does not accept type abbreviations with unused - parameters. However, this transformation may also be useful for use - with OCaml, since it may lead to nicer code. -*) -module BU = FStar.Compiler.Util - -(** - The transformation maintains an environment recording which - arguments of a type definition are to be removed, extending the - environment at the definition site of each type abbreviation and - using the environment to determine which arguments should be omitted - at each use site. - - The environment maps an mlpath, a fully qualified name of a type - definition, to a list of [Retain | Omit] tags, one for each argument - of the type definition. - *) - -type argument_tag = - | Retain - | Omit - -type entry = list argument_tag - -type env_t = { - current_module:list mlsymbol; - tydef_map:BU.psmap entry; -} - -let initial_env : env_t = { - current_module = []; - tydef_map = BU.psmap_empty () -} - -let extend_env (env:env_t) (i:mlsymbol) (e:entry) : env_t = { - env with - tydef_map = BU.psmap_add env.tydef_map (string_of_mlpath (env.current_module,i)) e -} - -let lookup_tyname (env:env_t) (name:mlpath) - : option entry - = BU.psmap_try_find env.tydef_map (string_of_mlpath name) - -(** Free variables of a type: Computed to check which parameters are used *) -type var_set = RBSet.t mlident -let empty_var_set : RBSet.t string = empty () -let rec freevars_of_mlty' (vars:var_set) (t:mlty) = - match t with - | MLTY_Var i -> - add i vars - | MLTY_Fun (t0, _, t1) -> - freevars_of_mlty' (freevars_of_mlty' vars t0) t1 - | MLTY_Named (tys, _) - | MLTY_Tuple tys -> - List.fold_left freevars_of_mlty' vars tys - | _ -> vars -let freevars_of_mlty = freevars_of_mlty' empty_var_set - -(** The main rewriting in on MLTY_Named (args, name), - which eliminates some of the args in case `name` has - parameters that are marked as Omit in the environment *) -let rec elim_mlty env mlty = - match mlty with - | MLTY_Var _ -> mlty - - | MLTY_Fun (t0, e, t1) -> - MLTY_Fun(elim_mlty env t0, e, elim_mlty env t1) - - | MLTY_Named (args, name) -> - let args = List.map (elim_mlty env) args in - begin - match lookup_tyname env name with - | None -> - MLTY_Named(args, name) - | Some entry -> - if List.length entry <> List.length args - then failwith "Impossible: arity mismatch between definition and use"; - let args = - List.fold_right2 - (fun arg tag out -> - match tag with - | Retain -> arg::out - | _ -> out) - args - entry - [] - in - MLTY_Named(args, name) - end - | MLTY_Tuple tys -> //arity of tuples do not change - MLTY_Tuple (List.map (elim_mlty env) tys) - | MLTY_Top - | MLTY_Erased -> mlty - -(** Note, the arity of expressions do not change. - So, this just traverses an expression an eliminates - type arguments in any subterm to e that is an mlty *) -let rec elim_mlexpr' (env:env_t) (e:mlexpr') = - match e with - | MLE_Const _ - | MLE_Var _ - | MLE_Name _ -> e - | MLE_Let (lb, e) -> MLE_Let(elim_letbinding env lb, elim_mlexpr env e) - | MLE_App(e, es) -> MLE_App(elim_mlexpr env e, List.map (elim_mlexpr env) es) - | MLE_TApp (e, tys) -> MLE_TApp(e, List.map (elim_mlty env) tys) - | MLE_Fun(bvs, e) -> - MLE_Fun (List.map (fun b -> {mlbinder_name=b.mlbinder_name; - mlbinder_ty=elim_mlty env b.mlbinder_ty; - mlbinder_attrs=List.map (elim_mlexpr env) b.mlbinder_attrs}) bvs, elim_mlexpr env e) - | MLE_Match(e, branches) -> MLE_Match(elim_mlexpr env e, List.map (elim_branch env) branches) - | MLE_Coerce(e, t0, t1) -> MLE_Coerce(elim_mlexpr env e, elim_mlty env t0, elim_mlty env t1) - | MLE_CTor(l, es) -> MLE_CTor(l, List.map (elim_mlexpr env) es) - | MLE_Seq es -> MLE_Seq (List.map (elim_mlexpr env) es) - | MLE_Tuple es -> MLE_Tuple (List.map (elim_mlexpr env) es) - | MLE_Record(syms, nm, fields) -> MLE_Record(syms, nm, List.map (fun (s, e) -> s, elim_mlexpr env e) fields) - | MLE_Proj (e, p) -> MLE_Proj(elim_mlexpr env e, p) - | MLE_If(e, e1, e2_opt) -> MLE_If(elim_mlexpr env e, elim_mlexpr env e1, BU.map_opt e2_opt (elim_mlexpr env)) - | MLE_Raise(p, es) -> MLE_Raise (p, List.map (elim_mlexpr env) es) - | MLE_Try(e, branches) -> MLE_Try(elim_mlexpr env e, List.map (elim_branch env) branches) - -and elim_letbinding env (flavor, lbs) = - let elim_one_lb lb = - let ts = BU.map_opt lb.mllb_tysc (fun (vars, t) -> vars, elim_mlty env t) in - let expr = elim_mlexpr env lb.mllb_def in - { lb with - mllb_tysc = ts; - mllb_def = expr } - in - flavor, List.map elim_one_lb lbs - -and elim_branch env (pat, wopt, e) = - pat, BU.map_opt wopt (elim_mlexpr env), elim_mlexpr env e - -and elim_mlexpr (env:env_t) (e:mlexpr) = - { e with expr = elim_mlexpr' env e.expr; mlty = elim_mlty env e.mlty } - -exception Drop_tydef - -(** This is a key helper function: - - It is called from elim_one_mltydecl when encountering a type - definition (MLTD_Abbrev), and also when processing type - definitions when extracting interfaces for dependences. - - it computes the variables that are used and marks the unused ones - as Omit in the environment and removes them from the type scheme. -*) -let elim_tydef (env:env_t) name metadata parameters mlty - = let val_decl_range = - BU.find_map metadata (function HasValDecl r -> Some r | _ -> None) - in - let remove_typars_list = - BU.try_find (function RemoveUnusedTypeParameters _ -> true | _ -> false) metadata - in - let range_of_tydef = - match remove_typars_list with - | None -> Range.dummyRange - | Some (RemoveUnusedTypeParameters(_, r)) -> r - in - let must_eliminate i = - match remove_typars_list with - | Some (RemoveUnusedTypeParameters (l, r)) -> List.contains i l - | _ -> false - in - let can_eliminate i = - match val_decl_range, remove_typars_list with - | None, None -> true - | _ -> false - in - let mlty = elim_mlty env mlty in - let freevars = freevars_of_mlty mlty in - let _, parameters, entry = - List.fold_left - (fun (i, params, entry) param -> - let p = param.ty_param_name in - if mem p freevars - then begin - if must_eliminate i - then begin - FStar.Errors.log_issue range_of_tydef Errors.Error_RemoveUnusedTypeParameter - (BU.format2 "Expected parameter %s of %s to be unused in its definition and eliminated" p name) - end; - i+1, param::params, Retain::entry - end - else begin - if can_eliminate i //there's no val - || must_eliminate i //or there's an attribute explicitly demanding elimination - then i+1, params, Omit::entry - else if Options.codegen() = Some Options.FSharp - then //This is a hard error for F# - //unused type parameters have to be eliminated - let range = - match val_decl_range with - | Some r -> r - | _ -> range_of_tydef - in - FStar.Errors.log_issue range FStar.Errors.Error_RemoveUnusedTypeParameter - (BU.format3 - "Parameter %s of %s is unused and must be eliminated for F#; \ - add `[@@ remove_unused_type_parameters [%s; ...]]` to the interface signature; \n\ - This type definition is being dropped" (show i) name (show i)); - raise Drop_tydef - else i+1, param::params, Retain::entry - end) - (0, [], []) - parameters - in - extend_env env name (List.rev entry), - (name, metadata, List.rev parameters, mlty) - -let elim_tydef_or_decl (env:env_t) (td:tydef) - : env_t & tydef - = match td with - | name, metadata, Inr arity -> - let remove_typars_list = - BU.try_find (function RemoveUnusedTypeParameters _ -> true | _ -> false) metadata - in - begin - match remove_typars_list with - | None -> env, td - | Some (RemoveUnusedTypeParameters(l, r)) -> - let must_eliminate i = List.contains i l in - let rec aux i = - if i = arity then [] - else if must_eliminate i then Omit :: aux (i + 1) - else Retain :: aux (i + 1) - in - let entries = aux 0 in - extend_env env name entries, - td - end - - | name, metadata, Inl (parameters, mlty) -> - let env, (name, meta, params, mlty) = - elim_tydef env name metadata parameters mlty - in - env, (name, meta, Inl (params, mlty)) - -let elim_tydefs (env:env_t) (tds:list tydef) : env_t & list tydef = - if Options.codegen() <> Some Options.FSharp then env, tds else - let env, tds = - List.fold_left - (fun (env, out) td -> - try - let env, td = elim_tydef_or_decl env td in - env, td::out - with - | Drop_tydef -> - env, out) - (env, []) tds - in - env, List.rev tds - -(** This is the main function that actually extends the environment: - When encountering a type definition (MLTD_Abbrev), it - computes the variables that are used and marks the unused ones as Omit - in the environment and removes them from the definition here *) -let elim_one_mltydecl (env:env_t) (td:one_mltydecl) - : env_t - & one_mltydecl - = let {tydecl_name=name; tydecl_meta=meta; tydecl_parameters=parameters; tydecl_defn=body} = td in - let elim_td td = - match td with - | MLTD_Abbrev mlty -> - let env, (name, _, parameters, mlty) = elim_tydef env name meta parameters mlty in - env, - parameters, - MLTD_Abbrev mlty - - | MLTD_Record fields -> - env, - parameters, - MLTD_Record (List.map (fun (name, ty) -> name, elim_mlty env ty) fields) - - | MLTD_DType inductive -> - env, - parameters, - MLTD_DType ( - List.map - (fun (i, constrs) -> - i, List.map (fun (constr, ty) -> constr, elim_mlty env ty) constrs) - inductive - ) - in - let env, parameters, body = - match body with - | None -> - env, parameters, body - | Some td -> - let env, parameters, td = elim_td td in - env, parameters, Some td - in - env, - { td with tydecl_parameters = parameters; - tydecl_defn = body } - -let elim_module env m = - let elim_module1 env m = - match m.mlmodule1_m with - | MLM_Ty td -> - let env, td = BU.fold_map elim_one_mltydecl env td in - env, { m with mlmodule1_m = MLM_Ty td } - | MLM_Let lb -> - env, { m with mlmodule1_m = MLM_Let (elim_letbinding env lb) } - | MLM_Exn (name, sym_tys) -> - env, { m with mlmodule1_m = MLM_Exn (name, List.map (fun (s, t) -> s, elim_mlty env t) sym_tys) } - | MLM_Top e -> - env, { m with mlmodule1_m = MLM_Top (elim_mlexpr env e) } - | _ -> - env, m - in - let env, m = - List.fold_left - (fun (env, out) m -> - try - let env, m = elim_module1 env m in - env, m::out - with - | Drop_tydef -> - env, out) - (env, []) - m - in - env, List.rev m - -let set_current_module (e:env_t) (n:mlpath) = - let curmod = fst n @ [snd n] in - { e with current_module = curmod } - -let elim_mllib (env:env_t) (m:mllib) = - if Options.codegen() <> Some Options.FSharp then env, m else - let (MLLib libs) = m in - let elim_one_lib env lib = - let name, sig_mod, _libs = lib in - let env = set_current_module env name in - let sig_mod, env = - match sig_mod with - | Some (sig_, mod_) -> - //intentionally discard the environment from the module translation - let env, mod_ = elim_module env mod_ in - // The sig is currently empty - Some (sig_, mod_), env - | None -> - None, env - in - env, (name, sig_mod, _libs) - in - let env, libs = - BU.fold_map elim_one_lib env libs - in - env, MLLib libs - -let elim_mllibs (l:list mllib) : list mllib = - snd (BU.fold_map elim_mllib initial_env l) diff --git a/src/extraction/FStar.Extraction.ML.RemoveUnusedParameters.fsti b/src/extraction/FStar.Extraction.ML.RemoveUnusedParameters.fsti deleted file mode 100644 index 2e8c43b89b8..00000000000 --- a/src/extraction/FStar.Extraction.ML.RemoveUnusedParameters.fsti +++ /dev/null @@ -1,27 +0,0 @@ -(* - Copyright 2020 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -(* -------------------------------------------------------------------- *) -module FStar.Extraction.ML.RemoveUnusedParameters -open FStar.Ident -open FStar.Extraction.ML.Syntax - -val env_t : Type0 -val initial_env : env_t -type tydef = mlsymbol & metadata & either mltyscheme int -val set_current_module (e:env_t) (n:mlpath) : env_t - -val elim_tydefs (env:env_t) (tds:list tydef) : env_t & list tydef -val elim_mllib (env:env_t) (m:mllib) : env_t & mllib diff --git a/src/extraction/FStar.Extraction.ML.Syntax.fst b/src/extraction/FStar.Extraction.ML.Syntax.fst deleted file mode 100644 index eefa196a3e3..00000000000 --- a/src/extraction/FStar.Extraction.ML.Syntax.fst +++ /dev/null @@ -1,286 +0,0 @@ -(* - Copyright 2008-2016 Abhishek Anand, Nikhil Swamy, - Antoine Delignat-Lavaud, Pierre-Yves Strub - and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -(* -------------------------------------------------------------------- *) -module FStar.Extraction.ML.Syntax -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.Ident -open FStar.Compiler.Util -open FStar.Const -open FStar.BaseTypes - -open FStar.Class.Show -open FStar.Pprint - -(* -------------------------------------------------------------------- *) -let krml_keywords = [] - -let ocamlkeywords = [ - "and"; "as"; "assert"; "asr"; "begin"; "class"; - "constraint"; "do"; "done"; "downto"; "else"; "end"; - "exception"; "external"; "false"; "for"; "fun"; "function"; - "functor"; "if"; "in"; "include"; "inherit"; "initializer"; - "land"; "lazy"; "let"; "lor"; "lsl"; "lsr"; - "lxor"; "match"; "method"; "mod"; "module"; "mutable"; - "new"; "object"; "of"; "open"; "or"; "private"; - "rec"; "sig"; "struct"; "then"; "to"; "true"; - "try"; "type"; "val"; "virtual"; "when"; "while"; - "with"; "nonrec" -] - -let fsharpkeywords = [ - "abstract"; "and"; "as"; "assert"; "base"; "begin"; "class"; - "default"; "delegate"; "do"; "done"; "downcast"; "downto"; - "elif"; "else"; "end"; "exception"; "extern"; "false"; - "finally"; "fixed"; "for"; "fun"; "function"; "global"; "if"; - "in"; "inherit"; "inline"; "interface"; "internal"; "lazy"; - "let"; "let!"; "match"; "member"; "module"; "mutable"; - "namespace"; "new"; "not"; "null"; "of"; "open"; "or"; - "override"; "private"; "public"; "rec"; "return"; "return!"; - "select"; "static"; "struct"; "then"; "to"; "true"; "try"; - "type"; "upcast"; "use"; "use!"; "val"; "void"; "when"; - "while"; "with"; "yield"; "yield!"; - // --mlcompatibility keywords - "asr"; "land"; "lor"; - "lsl"; "lsr"; "lxor"; "mod"; "sig"; - // reserved keywords - "atomic"; "break"; "checked"; "component"; "const"; - "constraint"; "constructor"; "continue"; "eager"; "event"; - "external"; "fixed"; "functor"; "include"; "method"; "mixin"; - "object"; "parallel"; "process"; "protected"; "pure"; - "sealed"; "tailcall"; "trait"; "virtual"; "volatile" -] - -let string_of_mlpath ((p, s) : mlpath) : mlsymbol = - String.concat "." (p @ [s]) - -let dummy_loc: mlloc = 0, "" - -let mk_mlmodule1 m = { mlmodule1_m = m; mlmodule1_attrs = [] } -let mk_mlmodule1_with_attrs m attrs = { mlmodule1_m = m; mlmodule1_attrs = attrs } - -let with_ty_loc t e l = {expr=e; mlty=t; loc = l } -let with_ty t e = with_ty_loc t e dummy_loc - -// do NOT remove Prims, because all mentions of unit/bool in F* are actually Prims.unit/bool. -let ml_unit_ty = MLTY_Erased -let ml_bool_ty = MLTY_Named ([], (["Prims"], "bool")) -let ml_int_ty = MLTY_Named ([], (["Prims"], "int")) -let ml_string_ty = MLTY_Named ([], (["Prims"], "string")) - -let ml_unit = with_ty ml_unit_ty (MLE_Const MLC_Unit) - -let apply_obj_repr : mlexpr -> mlty -> mlexpr = fun x t -> - let repr_name = if Options.codegen() = Some Options.FSharp - then MLE_Name([], "box") - else MLE_Name(["Obj"], "repr") in - let obj_repr = with_ty (MLTY_Fun(t, E_PURE, MLTY_Top)) repr_name in - with_ty_loc MLTY_Top (MLE_App(obj_repr, [x])) x.loc - -let ty_param_names (tys:list ty_param) : list string = - tys |> List.map (fun {ty_param_name} -> ty_param_name) - -let push_unit eff (ts : mltyscheme) : mltyscheme = - let vs, ty = ts in - vs, MLTY_Fun(ml_unit_ty, eff, ty) - -let pop_unit (ts : mltyscheme) : e_tag & mltyscheme = - let vs, ty = ts in - match ty with - | MLTY_Fun (l, eff, t) -> - if l = ml_unit_ty - then eff, (vs, t) - else failwith "unexpected: pop_unit: domain was not unit" - | _ -> - failwith "unexpected: pop_unit: not a function type" -module BU = FStar.Compiler.Util - -let ctor' (n: string) (args: list document) = - nest 2 (group (parens (flow (break_ 1) (doc_of_string n :: args)))) -let ctor (n: string) (arg: document) = - nest 2 (group (parens (doc_of_string n ^/^ arg))) - -let rec mlty_to_doc (t:mlty) = - match t with - | MLTY_Var v -> doc_of_string v - | MLTY_Fun (t1, _, t2) -> - ctor' "" [mlty_to_doc t1; doc_of_string "->"; mlty_to_doc t2] - | MLTY_Named (ts, p) -> - ctor' "" (List.map mlty_to_doc ts @ [doc_of_string (string_of_mlpath p)]) - | MLTY_Tuple ts -> - ctor "" <| flow_map (doc_of_string " *" ^^ break_ 1) mlty_to_doc ts - | MLTY_Top -> doc_of_string "MLTY_Top" - | MLTY_Erased -> doc_of_string "MLTY_Erased" -let mlty_to_string (t:mlty) = render (mlty_to_doc t) - -let mltyscheme_to_doc (tsc:mltyscheme) = - ctor "" - (brackets (flow_map (comma ^^ break_ 1) doc_of_string (ty_param_names (fst tsc))) - ^^ doc_of_string "," ^/^ mlty_to_doc (snd tsc)) -let mltyscheme_to_string (tsc:mltyscheme) = render (mltyscheme_to_doc tsc) - -let pair a b = group (parens (a ^^ comma ^/^ b)) -let triple a b c = group (parens (a ^^ comma ^/^ b ^^ comma ^/^ c)) -let ctor2 n a b = ctor n (pair a b) -let list_to_doc #t (xs: list t) (f: t -> document) : document = - nest 2 (group (brackets (flow_map (semi ^^ break_ 1) f xs))) -let option_to_doc #t (x: option t) (f: t -> document) : document = - match x with - | Some x -> group (doc_of_string "Some" ^/^ f x) - | None -> doc_of_string "None" -let spaced a = break_ 1 ^^ a ^^ break_ 1 -let record fs = - group <| nest 2 <| braces <| spaced <| separate (semi ^^ break_ 1) fs -let fld n v = group <| nest 2 <| doc_of_string (n ^ " =") ^/^ v - -let rec mlexpr_to_doc (e:mlexpr) = - match e.expr with - | MLE_Const c -> - ctor "MLE_Const" (mlconstant_to_doc c) - | MLE_Var x -> - ctor "MLE_Var" (doc_of_string x) - | MLE_Name (p, x) -> - ctor2 "MLE_Name" (doc_of_string (String.concat "." p)) (doc_of_string x) - | MLE_Let (lbs, e) -> - ctor2 "MLE_Let" (mlletbinding_to_doc lbs) (mlexpr_to_doc e) - | MLE_App (e, es) -> - ctor2 "MLE_App" (mlexpr_to_doc e) (list_to_doc es mlexpr_to_doc) - | MLE_TApp (e, ts) -> - ctor2 "MLE_TApp" (mlexpr_to_doc e) (list_to_doc ts mlty_to_doc) - | MLE_Fun (bs, e) -> - ctor2 "MLE_Fun" - (list_to_doc bs (fun b -> pair (doc_of_string b.mlbinder_name) (mlty_to_doc b.mlbinder_ty))) - (mlexpr_to_doc e) - | MLE_Match (e, bs) -> - ctor2 "MLE_Match" (mlexpr_to_doc e) (list_to_doc bs mlbranch_to_doc) - | MLE_Coerce (e, t1, t2) -> - ctor "MLE_Coerce" <| triple (mlexpr_to_doc e) (mlty_to_doc t1) (mlty_to_doc t2) - | MLE_CTor (p, es) -> - ctor2 "MLE_CTor" (doc_of_string (string_of_mlpath p)) (list_to_doc es mlexpr_to_doc) - | MLE_Seq es -> - ctor "MLE_Seq" (list_to_doc es mlexpr_to_doc) - | MLE_Tuple es -> - ctor "MLE_Tuple" (list_to_doc es mlexpr_to_doc) - | MLE_Record (p, n, es) -> - ctor2 "MLE_Record" (list_to_doc (p@[n]) doc_of_string) - (list_to_doc es (fun (x, e) -> pair (doc_of_string x) (mlexpr_to_doc e))) - | MLE_Proj (e, p) -> - ctor2 "MLE_Proj" (mlexpr_to_doc e) (doc_of_string (string_of_mlpath p)) - | MLE_If (e1, e2, e3) -> - ctor "MLE_If" <| triple (mlexpr_to_doc e1) (mlexpr_to_doc e2) (option_to_doc e3 mlexpr_to_doc) - | MLE_Raise (p, es) -> - ctor2 "MLE_Raise" (doc_of_string (string_of_mlpath p)) (list_to_doc es mlexpr_to_doc) - | MLE_Try (e, bs) -> - ctor2 "MLE_Try" (mlexpr_to_doc e) (list_to_doc bs mlbranch_to_doc) - -and mlbranch_to_doc (p, e1, e2) = - triple (mlpattern_to_doc p) (option_to_doc e1 mlexpr_to_doc) (mlexpr_to_doc e2) - -and mlletbinding_to_doc (lbs) = - parens <| - doc_of_string (match lbs._1 with | Rec -> "Rec" | NonRec -> "NonRec") - ^^ doc_of_string ", " ^^ - list_to_doc lbs._2 mllb_to_doc - -and mllb_to_doc (lb) = - record [ - fld "mllb_name" (doc_of_string lb.mllb_name); - fld "mllb_attrs" (list_to_doc lb.mllb_attrs mlexpr_to_doc); - fld "mllb_tysc" (option_to_doc lb.mllb_tysc (fun (_, t) -> mlty_to_doc t)); - fld "mllb_add_unit" (doc_of_string (string_of_bool lb.mllb_add_unit)); - fld "mllb_def" (mlexpr_to_doc lb.mllb_def); - ] - -and mlconstant_to_doc mlc = - match mlc with - | MLC_Unit -> doc_of_string "MLC_Unit" - | MLC_Bool b -> ctor "MLC_Bool" (doc_of_string (string_of_bool b)) - | MLC_Int (s, None) -> ctor "MLC_Int" (doc_of_string s) - | MLC_Int (s, Some (s1, s2)) -> - ctor "MLC_Int" <| triple (doc_of_string s) underscore underscore - | MLC_Float f -> ctor "MLC_Float" underscore - | MLC_Char c -> ctor "MLC_Char" underscore - | MLC_String s -> ctor "MLC_String" (doc_of_string s) - | MLC_Bytes b -> ctor "MLC_Bytes" underscore - -and mlpattern_to_doc mlp = - match mlp with - | MLP_Wild -> doc_of_string "MLP_Wild" - | MLP_Const c -> ctor "MLP_Const" (mlconstant_to_doc c) - | MLP_Var x -> ctor "MLP_Var" (doc_of_string x) - | MLP_CTor (p, ps) -> ctor2 "MLP_CTor" (doc_of_string (string_of_mlpath p)) (list_to_doc ps mlpattern_to_doc) - | MLP_Branch ps -> ctor "MLP_Branch" (list_to_doc ps mlpattern_to_doc) - - | MLP_Record (path, fields) -> - ctor2 "MLP_Record" - (doc_of_string (String.concat "." path)) - (list_to_doc fields (fun (x, p) -> - pair (doc_of_string x) (mlpattern_to_doc p))) - | MLP_Tuple ps -> - ctor "MLP_Tuple" (list_to_doc ps mlpattern_to_doc) - -let mlbranch_to_string b = render (mlbranch_to_doc b) -let mlletbinding_to_string lb = render (mlletbinding_to_doc lb) -let mllb_to_string lb = render (mllb_to_doc lb) -let mlpattern_to_string p = render (mlpattern_to_doc p) -let mlconstant_to_string c = render (mlconstant_to_doc c) -let mlexpr_to_string e = render (mlexpr_to_doc e) - -let mltybody_to_doc (d:mltybody) : document = - match d with - | MLTD_Abbrev mlty -> ctor "MLTD_Abbrev" (mlty_to_doc mlty) - | MLTD_Record l -> - ctor "MLTD_Record" <| group <| nest 2 <| braces <| spaced <| - flow_map (semi ^^ break_ 1) (fun (x, t) -> pair (doc_of_string x) (mlty_to_doc t)) l - | MLTD_DType l -> - ctor "MLTD_DType" <| group <| nest 2 <| brackets <| spaced <| - flow_map (semi ^^ break_ 1) (fun (x, l) -> pair (doc_of_string x) - (list_to_doc l fun (x, t) -> pair (doc_of_string x) (mlty_to_doc t))) l -let mltybody_to_string (d:mltybody) : string = render (mltybody_to_doc d) - -let one_mltydecl_to_doc (d:one_mltydecl) : document = - record [ - fld "tydecl_name" (doc_of_string d.tydecl_name); - fld "tydecl_parameters" (doc_of_string (String.concat "," (d.tydecl_parameters |> ty_param_names))); - fld "tydecl_defn" (option_to_doc d.tydecl_defn mltybody_to_doc); - ] -let one_mltydecl_to_string (d:one_mltydecl) : string = render (one_mltydecl_to_doc d) - -let mlmodule1_to_doc (m:mlmodule1) : document = - group (match m.mlmodule1_m with - | MLM_Ty d -> doc_of_string "MLM_Ty " ^^ list_to_doc d one_mltydecl_to_doc - | MLM_Let l -> doc_of_string "MLM_Let " ^^ mlletbinding_to_doc l - | MLM_Exn (s, l) -> - doc_of_string "MLM_Exn" ^/^ - pair (doc_of_string s) - (list_to_doc l (fun (x, t) -> pair (doc_of_string x) (mlty_to_doc t))) - | MLM_Top e -> doc_of_string "MLM_Top" ^/^ mlexpr_to_doc e - | MLM_Loc _mlloc -> doc_of_string "MLM_Loc") -let mlmodule1_to_string (m:mlmodule1) : string = render (mlmodule1_to_doc m) - -let mlmodule_to_doc (m:mlmodule) : document = - group <| brackets <| spaced <| separate_map (semi ^^ break_ 1) mlmodule1_to_doc m -let mlmodule_to_string (m:mlmodule) : string = render (mlmodule_to_doc m) - -instance showable_mlty : showable mlty = { show = mlty_to_string } -instance showable_mlconstant : showable mlconstant = { show = mlconstant_to_string } -instance showable_mlexpr : showable mlexpr = { show = mlexpr_to_string } -instance showable_mlmodule1 : showable mlmodule1 = { show = mlmodule1_to_string } -instance showable_mlmodule : showable mlmodule = { show = mlmodule_to_string } diff --git a/src/extraction/FStar.Extraction.ML.Syntax.fsti b/src/extraction/FStar.Extraction.ML.Syntax.fsti deleted file mode 100644 index 3f68517fdda..00000000000 --- a/src/extraction/FStar.Extraction.ML.Syntax.fsti +++ /dev/null @@ -1,262 +0,0 @@ -(* - Copyright 2008-2016 Abhishek Anand, Nikhil Swamy, - Antoine Delignat-Lavaud, Pierre-Yves Strub - and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -(* -------------------------------------------------------------------- *) -module FStar.Extraction.ML.Syntax -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.Ident -open FStar.Compiler.Util -open FStar.Const -open FStar.BaseTypes - -open FStar.Class.Show - -(* -------------------------------------------------------------------- *) -type mlsymbol = string -type mlident = mlsymbol -type mlpath = list mlsymbol & mlsymbol //Path and name of a module - -(* -------------------------------------------------------------------- *) -val krml_keywords : list string -val ocamlkeywords : list string -val fsharpkeywords : list string - -val string_of_mlpath : mlpath -> string - -(* -------------------------------------------------------------------- *) -type mlidents = list mlident -type mlsymbols = list mlsymbol - -(* -------------------------------------------------------------------- *) -type e_tag = - | E_PURE - | E_ERASABLE - | E_IMPURE - -// Line number, file name; that's all we can emit in OCaml anyhwow -type mlloc = int & string -val dummy_loc : mlloc - -type mlty = -| MLTY_Var of mlident -| MLTY_Fun of mlty & e_tag & mlty -| MLTY_Named of list mlty & mlpath -| MLTY_Tuple of list mlty -| MLTY_Top (* \mathbb{T} type in the thesis, to be used when OCaml is not expressive enough for the source type *) -| MLTY_Erased //a type that extracts to unit - -type mlconstant = -| MLC_Unit -| MLC_Bool of bool -| MLC_Int of string & option (signedness & width) -| MLC_Float of float -| MLC_Char of char -| MLC_String of string -| MLC_Bytes of array byte - -type mlpattern = -| MLP_Wild -| MLP_Const of mlconstant -| MLP_Var of mlident -| MLP_CTor of mlpath & list mlpattern -| MLP_Branch of list mlpattern -(* SUGAR *) -| MLP_Record of list mlsymbol & list (mlsymbol & mlpattern) -| MLP_Tuple of list mlpattern - - -(* metadata, suitable for either the C or the OCaml backend *) -type meta = - | Mutable (* deprecated *) - | Assumed - | Private - | NoExtract - | CInline - | Substitute - | GCType - | PpxDerivingShow - | PpxDerivingShowConstant of string - | PpxDerivingYoJson - | Comment of string - | StackInline - | CPrologue of string - | CEpilogue of string - | CConst of string - | CCConv of string - | Erased - | CAbstract - | CIfDef - | CMacro - | Deprecated of string - | RemoveUnusedTypeParameters of list int & FStar.Compiler.Range.range //positional - | HasValDecl of FStar.Compiler.Range.range //this symbol appears in the interface of a module - | CNoInline - -// rename -type metadata = list meta - -type mlletflavor = - | Rec - | NonRec - -type mlbinder = { - mlbinder_name:mlident; - mlbinder_ty:mlty; - mlbinder_attrs:list mlattribute; -} - -and mlexpr' = -| MLE_Const of mlconstant -| MLE_Var of mlident -| MLE_Name of mlpath -| MLE_Let of mlletbinding & mlexpr //tyscheme for polymorphic recursion -| MLE_App of mlexpr & list mlexpr //why are function types curried, but the applications not curried -| MLE_TApp of mlexpr & list mlty -| MLE_Fun of list mlbinder & mlexpr -| MLE_Match of mlexpr & list mlbranch -| MLE_Coerce of mlexpr & mlty & mlty -(* SUGAR *) -| MLE_CTor of mlpath & list mlexpr -| MLE_Seq of list mlexpr -| MLE_Tuple of list mlexpr -| MLE_Record of list mlsymbol & mlsymbol & list (mlsymbol & mlexpr) // path of record type, - // name of record type, - // and fields with values -| MLE_Proj of mlexpr & mlpath -| MLE_If of mlexpr & mlexpr & option mlexpr -| MLE_Raise of mlpath & list mlexpr -| MLE_Try of mlexpr & list mlbranch - -and mlexpr = { - expr:mlexpr'; - mlty:mlty; - loc: mlloc; -} - -and mlbranch = mlpattern & option mlexpr & mlexpr - -and mllb = { - mllb_name:mlident; - mllb_tysc:option mltyscheme; // May be None for top-level bindings only - mllb_add_unit:bool; - mllb_def:mlexpr; - mllb_attrs:list mlattribute; - mllb_meta:metadata; - print_typ:bool; -} - -and mlletbinding = mlletflavor & list mllb - -and mlattribute = mlexpr - -and ty_param = { - ty_param_name : mlident; - ty_param_attrs : list mlattribute; -} - -and mltyscheme = list ty_param & mlty //forall a1..an. t (the list of binders can be empty) - -type mltybody = -| MLTD_Abbrev of mlty -| MLTD_Record of list (mlsymbol & mlty) -| MLTD_DType of list (mlsymbol & list (mlsymbol & mlty)) - (*list of constructors? list mlty is the list of arguments of the constructors? - One could have instead used a mlty and tupled the argument types? - *) - -type one_mltydecl = { - tydecl_assumed : bool; // bool: this was assumed (C backend) - tydecl_name : mlsymbol; - tydecl_ignored : option mlsymbol; - tydecl_parameters : list ty_param; - tydecl_meta : metadata; - tydecl_defn : option mltybody -} - -type mltydecl = list one_mltydecl // each element of this list is one among a collection of mutually defined types - -type mlmodule1' = -| MLM_Ty of mltydecl -| MLM_Let of mlletbinding -| MLM_Exn of mlsymbol & list (mlsymbol & mlty) -| MLM_Top of mlexpr // this seems outdated -| MLM_Loc of mlloc // Location information; line number + file; only for the OCaml backend - -type mlmodule1 = { - mlmodule1_m : mlmodule1'; - mlmodule1_attrs : list mlattribute; -} - -val mk_mlmodule1 : mlmodule1' -> mlmodule1 -val mk_mlmodule1_with_attrs : mlmodule1' -> list mlattribute -> mlmodule1 - -type mlmodule = list mlmodule1 - -type mlsig1 = -| MLS_Mod of mlsymbol & mlsig -| MLS_Ty of mltydecl - (*used for both type schemes and inductive types. Even inductives are defined in OCaml using type ...., - unlike data in Haskell *) -| MLS_Val of mlsymbol & mltyscheme -| MLS_Exn of mlsymbol & list mlty - -and mlsig = list mlsig1 - -val with_ty_loc : mlty -> mlexpr' -> mlloc -> mlexpr -val with_ty : mlty -> mlexpr' -> mlexpr - -(* -------------------------------------------------------------------- *) -type mllib = - | MLLib of list (mlpath & option (mlsig & mlmodule) & mllib) //Last field never seems to be used. Refactor? - - -(* -------------------------------------------------------------------- *) -val ml_unit_ty : mlty -val ml_bool_ty : mlty -val ml_int_ty : mlty -val ml_string_ty : mlty - -val ml_unit : mlexpr - -val apply_obj_repr : mlexpr -> mlty -> mlexpr - -val ty_param_names (tys:list ty_param) : list string - -val push_unit (eff:e_tag) (ts : mltyscheme) : mltyscheme -val pop_unit (ts : mltyscheme) : e_tag & mltyscheme - -val mltyscheme_to_string (tsc:mltyscheme) : string -val mlbranch_to_string (b:mlbranch) : string -val mlletbinding_to_string (lb:mlletbinding) : string -val mllb_to_string (lb:mllb) : string -val mlpattern_to_string (p:mlpattern) : string - -val mlconstant_to_string (c:mlconstant) : string -val mlty_to_string (t:mlty) : string -val mlexpr_to_string (e:mlexpr) : string -val mltybody_to_string (d:mltybody) : string -val one_mltydecl_to_string (d:one_mltydecl) : string -val mlmodule1_to_string (d:mlmodule1) : string - -instance val showable_mlty : showable mlty -instance val showable_mlconstant : showable mlconstant -instance val showable_mlexpr : showable mlexpr -instance val showable_mlmodule1 : showable mlmodule1 -instance val showable_mlmodule : showable mlmodule diff --git a/src/extraction/FStar.Extraction.ML.Term.fst b/src/extraction/FStar.Extraction.ML.Term.fst deleted file mode 100644 index 9e481e2423f..00000000000 --- a/src/extraction/FStar.Extraction.ML.Term.fst +++ /dev/null @@ -1,2125 +0,0 @@ -(* - Copyright 2008-2015 Abhishek Anand, Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Extraction.ML.Term -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.TypeChecker.Env -open FStar.Compiler.Util -open FStar.Const -open FStar.Ident -open FStar.Extraction -open FStar.Extraction.ML -open FStar.Extraction.ML.Syntax -open FStar.Extraction.ML.UEnv -open FStar.Extraction.ML.Util -open FStar.Syntax.Syntax -open FStar.Errors - -module BU = FStar.Compiler.Util -module Code = FStar.Extraction.ML.Code -module EMB = FStar.Syntax.Embeddings -module Env = FStar.TypeChecker.Env -module N = FStar.TypeChecker.Normalize -module PC = FStar.Parser.Const -module RC = FStar.Reflection.V2.Constants -module RD = FStar.Reflection.V2.Data -module RE = FStar.Reflection.V2.Embeddings -module R = FStar.Reflection.V2.Builtins -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module TcEnv = FStar.TypeChecker.Env -module TcTerm = FStar.TypeChecker.TcTerm -module TcUtil = FStar.TypeChecker.Util -module U = FStar.Syntax.Util - -let dbg_Extraction = Debug.get_toggle "Extraction" -let dbg_ExtractionNorm = Debug.get_toggle "ExtractionNorm" - -exception Un_extractable - -open FStar.Class.Show -open FStar.Class.Tagged -open FStar.Class.PP - - -(* - Below, "the thesis" refers to: - Letouzey, Pierre. - Programmation Fonctionnelle Certifiée: L'extraction de Programmes Dans L'assistant Coq. - Université Paris-Sud, 2004. - - English translation: - Certified Functional Programming - Program extraction within the Coq proof assistant - http://www.pps.univ-paris-diderot.fr/~letouzey/download/these_letouzey_English.ps.gz -*) - -let type_leq g t1 t2 = Util.type_leq (Util.udelta_unfold g) t1 t2 -let type_leq_c g t1 t2 = Util.type_leq_c (Util.udelta_unfold g) t1 t2 -let eraseTypeDeep g t = Util.eraseTypeDeep (Util.udelta_unfold g) t - -module Print = FStar.Syntax.Print - -(********************************************************************************************) -(* Some basic error reporting; all are fatal errors at this stage *) -(********************************************************************************************) -let err_ill_typed_application env (t : term) mlhead (args : args) (ty : mlty) = - Errors.raise_error t Fatal_IllTyped - (BU.format4 "Ill-typed application: source application is %s \n translated prefix to %s at type %s\n remaining args are %s\n" - (show t) - (Code.string_of_mlexpr (current_module_of_uenv env) mlhead) - (Code.string_of_mlty (current_module_of_uenv env) ty) - (show args)) - -let err_ill_typed_erasure env (pos:Range.range) (ty : mlty) = - Errors.raise_error pos Fatal_IllTyped - (BU.format1 "Erased value found where a value of type %s was expected" - (Code.string_of_mlty (current_module_of_uenv env) ty)) - -let err_value_restriction (t:term) = - Errors.raise_error t Fatal_ValueRestriction - (BU.format2 "Refusing to generalize because of the value restriction: (%s) %s" - (tag_of t) (show t)) - -let err_unexpected_eff env (t:term) ty f0 f1 = - let open FStar.Errors.Msg in - let open FStar.Pprint in - Errors.log_issue t Warning_ExtractionUnexpectedEffect [ - prefix 4 1 (text "For expression") (pp t) ^/^ - prefix 4 1 (text "of type") (arbitrary_string (Code.string_of_mlty (current_module_of_uenv env) ty)); - prefix 4 1 (text "Expected effect") (arbitrary_string (eff_to_string f0)) ^/^ - prefix 4 1 (text "got effect") (arbitrary_string (eff_to_string f1))] - -let err_cannot_extract_effect (l:lident) (r:Range.range) (reason:string) (ctxt:string) = - Errors.raise_error r Errors.Fatal_UnexpectedEffect [ - Errors.text <| - BU.format3 "Cannot extract effect %s because %s (when extracting %s)" - (string_of_lid l) reason ctxt - ] - -(***********************************************************************) -(* Translating an effect lid to an e_tag = {E_PURE, E_ERASABLE, E_IMPURE} *) -(***********************************************************************) -let effect_as_etag = - let cache = BU.smap_create 20 in - let rec delta_norm_eff g (l:lident) = - match BU.smap_try_find cache (string_of_lid l) with - | Some l -> l - | None -> - let res = match TypeChecker.Env.lookup_effect_abbrev (tcenv_of_uenv g) [S.U_zero] l with - | None -> l - | Some (_, c) -> delta_norm_eff g (U.comp_effect_name c) in - BU.smap_add cache (string_of_lid l) res; - res in - fun g l -> - let l = delta_norm_eff g l in - if lid_equals l PC.effect_PURE_lid - then E_PURE - else if TcEnv.is_erasable_effect (tcenv_of_uenv g) l - then E_ERASABLE - else - // Reifiable effects should be pure. Added guard because some effect declarations - // don't seem to be in the environment at this point, in particular FStar.Compiler.Effect.ML - // (maybe because it's primitive?) - let ed_opt = TcEnv.effect_decl_opt (tcenv_of_uenv g) l in - match ed_opt with - | Some (ed, qualifiers) -> - if TcEnv.is_reifiable_effect (tcenv_of_uenv g) ed.mname - then E_PURE - else E_IMPURE - | None -> E_IMPURE - -(********************************************************************************************) -(* Basic syntactic operations on a term *) -(********************************************************************************************) - -(* is_arity t: - t is a sort s, i.e., Type i - or, t = x1:t1 -> ... -> xn:tn -> C - where PC.result_type is an arity - - *) -let rec is_arity_aux tcenv t = - let t = U.unmeta t in - match (SS.compress t).n with - | Tm_unknown - | Tm_delayed _ - | Tm_ascribed _ - | Tm_meta _ -> failwith (BU.format1 "Impossible: is_arity (%s)" (tag_of t)) - | Tm_lazy i -> is_arity_aux tcenv (U.unfold_lazy i) - | Tm_uvar _ - | Tm_constant _ - | Tm_name _ - | Tm_quoted _ - | Tm_bvar _ -> false - | Tm_type _ -> true - | Tm_arrow {comp=c} -> - is_arity_aux tcenv (FStar.Syntax.Util.comp_result c) - | Tm_fvar fv -> - let topt = - FStar.TypeChecker.Env.lookup_definition - [Env.Unfold delta_constant] - tcenv - fv.fv_name.v - in - begin - match topt with - | None -> false - | Some (_, t) -> is_arity_aux tcenv t - end - | Tm_app _ -> - let head, _ = U.head_and_args t in - is_arity_aux tcenv head - | Tm_uinst(head, _) -> - is_arity_aux tcenv head - | Tm_refine {b=x} -> - is_arity_aux tcenv x.sort - | Tm_abs {body} - | Tm_let {body} -> - is_arity_aux tcenv body - | Tm_match {brs=branches} -> - begin match branches with - | (_, _, e)::_ -> is_arity_aux tcenv e - | _ -> false - end - -let is_arity env t = is_arity_aux (tcenv_of_uenv env) t - -let push_tcenv_binders (u:uenv) (bs:binders) = - let tcenv = tcenv_of_uenv u in - let tcenv = TcEnv.push_binders tcenv bs in - set_tcenv u tcenv - -//is_type_aux env t: -// Determines whether or not t is a type -// syntactic structure and type annotations -let rec is_type_aux env t = - let t = SS.compress t in - match t.n with - | Tm_delayed _ - | Tm_unknown -> - failwith (BU.format1 "Impossible: %s" (tag_of t)) - - | Tm_lazy i -> is_type_aux env (U.unfold_lazy i) - - | Tm_constant _ -> - false - - | Tm_type _ - | Tm_refine _ - | Tm_arrow _ -> - true - - | Tm_fvar fv when S.fv_eq_lid fv (PC.failwith_lid()) -> - false //special case this, since we emit it during extraction even in prims, before it is in the F* scope - - | Tm_fvar fv -> - UEnv.is_type_name env fv - - | Tm_uvar (u, s) -> - let t= U.ctx_uvar_typ u in - is_arity env (SS.subst' s t) - - | Tm_bvar ({sort=t}) -> - is_arity env t - - | Tm_name x -> ( - let g = UEnv.tcenv_of_uenv env in - match try_lookup_bv g x with - | Some (t, _) -> - is_arity env t - | _ -> ( - failwith (BU.format1 "Extraction: variable not found: %s" (tag_of t)) - ) - ) - - | Tm_ascribed {tm=t} -> - is_type_aux env t - - | Tm_uinst(t, _) -> - is_type_aux env t - - | Tm_abs {bs; body} -> - let bs, body = SS.open_term bs body in - let env = push_tcenv_binders env bs in - is_type_aux env body - - | Tm_let {lbs=(false, [lb]); body} -> - let x = BU.left lb.lbname in - let bs, body = SS.open_term [S.mk_binder x] body in - let env = push_tcenv_binders env bs in - is_type_aux env body - - | Tm_let {lbs=(_, lbs); body} -> - let lbs, body = SS.open_let_rec lbs body in - let env = push_tcenv_binders env (List.map (fun lb -> S.mk_binder (BU.left lb.lbname)) lbs) in - is_type_aux env body - - | Tm_match {brs=branches} -> - begin match branches with - | b::_ -> ( - let pat, _, e = SS.open_branch b in - match FStar.TypeChecker.PatternUtils.raw_pat_as_exp (tcenv_of_uenv env) pat with - | None -> false - | Some (_, bvs) -> - let binders = List.map (fun bv -> S.mk_binder bv) bvs in - let env = push_tcenv_binders env binders in - is_type_aux env e - ) - | _ -> false - end - - | Tm_quoted _ -> false - - | Tm_meta {tm=t} -> - is_type_aux env t - - | Tm_app {hd=head} -> - is_type_aux env head - -let is_type env t = - debug env (fun () -> BU.print2 "checking is_type (%s) %s\n" - (tag_of t) - (show t) - ); - let b = is_type_aux env t in - debug env (fun _ -> - if b - then BU.print2 "yes, is_type %s (%s)\n" (show t) (tag_of t) - else BU.print2 "not a type %s (%s)\n" (show t) (tag_of t)); - b - -let is_steel_with_invariant_g t = - let head, args = U.head_and_args t in - match (U.un_uinst head).n, args with - | Tm_fvar fv, [_a; _fp; _fp'; _o; _p; _i; _body] -> - S.fv_eq_lid fv PC.steel_with_invariant_g_lid || - S.fv_eq_lid fv PC.steel_st_with_invariant_g_lid - | _ -> false - -let is_steel_with_invariant t : option term = - let head, args = U.head_and_args t in - match (U.un_uinst head).n, args with - | Tm_fvar fv, [_a; _fp; _fp'; _o; _obs; _p; _i; body] - when - S.fv_eq_lid fv PC.steel_with_invariant_lid || - S.fv_eq_lid fv PC.steel_st_with_invariant_lid -> - Some (fst body) - - | _ -> None - -let is_steel_new_invariant t = - let head, args = U.head_and_args t in - match (U.un_uinst head).n, args with - | Tm_fvar fv, [_o; _p] -> - S.fv_eq_lid fv PC.steel_new_invariant_lid || - S.fv_eq_lid fv PC.steel_st_new_invariant_lid - | _ -> false - -let is_type_binder env x = is_arity env x.binder_bv.sort - -let is_constructor t = match (SS.compress t).n with - | Tm_fvar ({fv_qual=Some Data_ctor}) - | Tm_fvar ({fv_qual=Some (Record_ctor _)}) -> true - | _ -> false - -(* something is a value iff it qualifies for the OCaml's "value restriction", - which determines when a definition can be generalized *) -let rec is_fstar_value (t:term) = - match (SS.compress t).n with - | Tm_constant _ - | Tm_bvar _ - | Tm_fvar _ - | Tm_abs _ -> true - | Tm_app {hd=head; args} -> - if is_constructor head - then args |> List.for_all (fun (te, _) -> is_fstar_value te) - else false - (* Consider: - let f (a:Type) (x:a) : Tot a = x - let g = f int - - In principle, after erasure, g can be generalized. - But, we don't distinguish type- from term applications right now - and consider (f int) to be non-generalizable non-value. - - This may cause extraction to eta-expand g, which isn't terrible, - but we should improve it. - *) - | Tm_meta {tm=t} - | Tm_ascribed {tm=t} -> is_fstar_value t - | _ -> false - -let rec is_ml_value e = - match e.expr with - | MLE_Const _ - | MLE_Var _ - | MLE_Name _ - | MLE_Fun _ -> true - | MLE_CTor (_, exps) - | MLE_Tuple exps -> BU.for_all is_ml_value exps - | MLE_Record (_, _, fields) -> BU.for_all (fun (_, e) -> is_ml_value e) fields - | MLE_TApp (h, _) -> is_ml_value h - | _ -> false - -(*copied from ocaml-asttrans.fs*) - -//pre-condition: SS.compress t = Tm_abs _ -//Collapses adjacent abstractions into a single n-ary abstraction -let normalize_abs (t0:term) : term = - let rec aux bs t copt = - let t = SS.compress t in - match t.n with - | Tm_abs {bs=bs'; body; rc_opt=copt} -> aux (bs@bs') body copt - | _ -> - let e' = U.unascribe t in - if U.is_fun e' - then aux bs e' copt - else U.abs bs e' copt in - aux [] t0 None - -let unit_binder () = S.mk_binder <| S.new_bv None t_unit - -//check_pats_for_ite l: -// A helper to enable translating boolean matches back to if/then/else -let check_pats_for_ite (l:list (pat & option term & term)) : (bool //if l is pair of boolean branches - & option term //the 'then' case - & option term) = //the 'else' case - let def = false, None, None in - if List.length l <> 2 then def - else - let (p1, w1, e1) = List.hd l in - let (p2, w2, e2) = List.hd (List.tl l) in - match (w1, w2, p1.v, p2.v) with - | (None, None, Pat_constant (Const_bool true), Pat_constant (Const_bool false)) -> true, Some e1, Some e2 - | (None, None, Pat_constant (Const_bool false), Pat_constant (Const_bool true)) -> true, Some e2, Some e1 -// | (None, None, Pat_constant (Const_bool false), Pat_wild _) -// | (None, None, Pat_constant (Const_bool false), Pat_var _) -// | (None, None, Pat_constant (Const_bool true), Pat_wild _) -// | (None, None, Pat_constant (Const_bool true), Pat_var _) - | _ -> def - - -(* INVARIANT: we MUST always perform deep erasure after extraction of types, even - * when done indirectly e.g. translate_typ_of_arg below. - * Otherwise, there will be Obj.magic because the types get erased at some places - * and not at other places *) -//let translate_typ (g:env) (t:typ) : mlty = eraseTypeDeep g (TypeExtraction.ext g t) -//let translate_typ_of_arg (g:env) (a:arg) : mlty = eraseTypeDeep g (TypeExtraction.getTypeFromArg g a) -// erasing here is better because if we need to generate OCaml types for binders and return values, they will be accurate. By the time we reach maybe_coerce, we cant change those - - -(********************************************************************************************) -(* Operations on ml terms, types, and effect tags *) -(* 1. Instantiation of type schemes *) -(* 2. Erasure of terms *) -(* 3. Coercion (Obj.magic) *) -(********************************************************************************************) - -//instantiate_tyscheme s args: -// only handles fully applied types, -// pre-condition: List.length (fst s) = List.length args -let instantiate_tyscheme (s:mltyscheme) (args:list mlty) : mlty = Util.subst s args - -let fresh_mlidents (ts:list mlty) (g:uenv) : list (mlident & mlty) & uenv = - let g, vs_ts = - List.fold_right - (fun t (uenv, vs) -> - let uenv, v = UEnv.new_mlident uenv in - uenv, (v, t)::vs) - ts (g, []) - in - vs_ts, g - -let fresh_binders (ts:list mlty) (g:uenv) : list mlbinder & uenv = - let vs_ts, g = fresh_mlidents ts g in - List.map (fun (v, t) -> {mlbinder_name=v; mlbinder_ty=t; mlbinder_attrs=[]}) vs_ts, - g - -//instantiate_maybe_partial: -// When `e` has polymorphic type `s` -// and isn't instantiated in F* (e.g., because of first-class polymorphism) -// we extract e to a type application in ML by instantiating all its -// type arguments to MLTY_Erased (later, perhaps, being forced to insert magics) -let instantiate_maybe_partial (g:uenv) (e:mlexpr) (eff:e_tag) (s:mltyscheme) (tyargs:list mlty) : (mlexpr & e_tag & mlty) = - let vars, t = s in - let n_vars = List.length vars in - let n_args = List.length tyargs in - if n_args = n_vars - then //easy, just make a type application node - if n_args = 0 - then (e, eff, t) - else - let ts = instantiate_tyscheme (vars, t) tyargs in - let tapp = { - e with - expr=MLE_TApp(e, tyargs); - mlty=ts - } in - (tapp, eff, ts) - else if n_args < n_vars - then //We have a partial type-application in F* - //So, make a full type application node in ML, - //by generating dummy instantiations. - //And then expand it out by adding as many unit - //arguments as dummy instantiations, since these - //will be applied later to F* types that get erased to () - let extra_tyargs = - let _, rest_vars = BU.first_N n_args vars in - rest_vars |> List.map (fun _ -> MLTY_Erased) - in - let tyargs = tyargs@extra_tyargs in - let ts = instantiate_tyscheme (vars, t) tyargs in - let tapp = { - e with - expr=MLE_TApp(e, tyargs); - mlty=ts - } in - let t = - List.fold_left - (fun out t -> MLTY_Fun(t, E_PURE, out)) - ts - extra_tyargs - in - let vs_ts, g = fresh_binders extra_tyargs g in - let f = with_ty t <| MLE_Fun (vs_ts, tapp) in - (f, eff, t) - else failwith "Impossible: instantiate_maybe_partial called with too many arguments" - -(* eta-expand `e` according to its type `t` *) -let eta_expand (g:uenv) (t : mlty) (e : mlexpr) : mlexpr = - let ts, r = doms_and_cod t in - if ts = [] - then e - else // just quit if this is not a function type - let vs_ts, g = fresh_binders ts g in - let vs_es = List.map (fun {mlbinder_name=v; mlbinder_ty=t} -> with_ty t (MLE_Var v)) vs_ts in - let body = with_ty r <| MLE_App (e, vs_es) in - with_ty t <| MLE_Fun (vs_ts, body) - -let default_value_for_ty (g:uenv) (t : mlty) : mlexpr = - let ts, r = doms_and_cod t in - let body r = - let r = - match udelta_unfold g r with - | None -> r - | Some r -> r - in - match r with - | MLTY_Erased -> - ml_unit - | MLTY_Top -> - apply_obj_repr ml_unit MLTY_Erased - | _ -> - with_ty r <| MLE_Coerce (ml_unit, MLTY_Erased, r) - in - if ts = [] - then body r - else let vs_ts, g = fresh_binders ts g in - with_ty t <| MLE_Fun (vs_ts, body r) - -let maybe_eta_expand_coercion g expect e = - if Options.codegen () = Some Options.Krml // we need to stay first order for Karamel - then e - else eta_expand g expect e - -(* - A small optimization to push coercions into the structure of a term - - Otherwise, we often end up with coercions like (Obj.magic (fun x -> e) : a -> b) : a -> c - Whereas with this optimization we produce (fun x -> Obj.magic (e : b) : c) : a -> c -*) -let apply_coercion (pos:Range.range) (g:uenv) (e:mlexpr) (ty:mlty) (expect:mlty) : mlexpr = - if Util.codegen_fsharp() - then //magics are not always sound in F#; warn - FStar.Errors.log_issue pos - Errors.Warning_NoMagicInFSharp - (BU.format2 - "Inserted an unsafe type coercion in generated code from %s to %s; this may be unsound in F#" - (Code.string_of_mlty (current_module_of_uenv g) ty) - (Code.string_of_mlty (current_module_of_uenv g) expect)); - let mk_fun binder body = - match body.expr with - | MLE_Fun(binders, body) -> - MLE_Fun(binder::binders, body) - | _ -> - MLE_Fun([binder], body) - in - let rec aux (e:mlexpr) ty expect = - let coerce_branch (pat, w, b) = pat, w, aux b ty expect in - //printfn "apply_coercion: %s : %s ~> %s\n%A : %A ~> %A" - // (Code.string_of_mlexpr (current_module_of_uenv g) e) - // (Code.string_of_mlty (current_module_of_uenv g) ty) - // (Code.string_of_mlty (current_module_of_uenv g) expect) - // e ty expect; - (* The expected type may be an abbreviation and not a literal - arrow. Try to unfold it. *) - let rec undelta mlty = - match Util.udelta_unfold g mlty with - | Some t -> undelta t - | None -> mlty - in - match e.expr, ty, undelta expect with - | MLE_Fun(arg::rest, body), MLTY_Fun(t0, _, t1), MLTY_Fun(s0, _, s1) -> - let body = - match rest with - | [] -> body - | _ -> with_ty t1 (MLE_Fun(rest, body)) - in - let body = aux body t1 s1 in - if type_leq g s0 t0 - then with_ty expect (mk_fun arg body) - else let lb = - { mllb_meta = []; - mllb_attrs = []; - mllb_name = arg.mlbinder_name; - mllb_tysc = Some ([], t0); - mllb_add_unit = false; - mllb_def = with_ty t0 (MLE_Coerce(with_ty s0 <| MLE_Var arg.mlbinder_name, s0, t0)); - print_typ=false } - in - let body = with_ty s1 <| MLE_Let((NonRec, [lb]), body) in - with_ty expect (mk_fun {mlbinder_name=arg.mlbinder_name;mlbinder_ty=s0;mlbinder_attrs=[]} body) - - | MLE_Let(lbs, body), _, _ -> - with_ty expect <| (MLE_Let(lbs, aux body ty expect)) - - | MLE_Match(s, branches), _, _ -> - with_ty expect <| MLE_Match(s, List.map coerce_branch branches) - - | MLE_If(s, b1, b2_opt), _, _ -> - with_ty expect <| MLE_If(s, aux b1 ty expect, BU.map_opt b2_opt (fun b2 -> aux b2 ty expect)) - - | MLE_Seq es, _, _ -> - let prefix, last = BU.prefix es in - with_ty expect <| MLE_Seq(prefix @ [aux last ty expect]) - - | MLE_Try(s, branches), _, _ -> - with_ty expect <| MLE_Try(s, List.map coerce_branch branches) - - | _ -> - with_ty expect (MLE_Coerce(e, ty, expect)) - in - aux e ty expect - -//maybe_coerce g e ty expect: -// Inserts an Obj.magic around e if ty e' - | _ -> - match ty with - | MLTY_Erased -> - //generate a default value suitable for the expected type - default_value_for_ty g expect - | _ -> - if type_leq g (erase_effect_annotations ty) (erase_effect_annotations expect) - then let _ = debug g (fun () -> - BU.print2 "\n Effect mismatch on type of %s : %s\n" - (Code.string_of_mlexpr (current_module_of_uenv g) e) - (Code.string_of_mlty (current_module_of_uenv g) ty)) in - e //types differ but only on effect labels, which ML/KaRaMeL don't care about; so no coercion needed - else let _ = debug g (fun () -> - BU.print3 "\n (*needed to coerce expression \n %s \n of type \n %s \n to type \n %s *) \n" - (Code.string_of_mlexpr (current_module_of_uenv g) e) - (Code.string_of_mlty (current_module_of_uenv g) ty) - (Code.string_of_mlty (current_module_of_uenv g) expect)) in - maybe_eta_expand_coercion g expect (apply_coercion pos g e ty expect) - -(********************************************************************************************) -(* The main extraction of terms to ML types *) -(********************************************************************************************) -let bv_as_mlty (g:uenv) (bv:bv) = - match UEnv.lookup_bv g bv with - | Inl ty_b -> ty_b.ty_b_ty - | _ -> MLTY_Top - - -(* term_as_mlty g t: - Inspired by the \hat\epsilon function in the thesis (Sec. 3.3.5) - - pre-condition: is_type t - - First \beta, \iota and \zeta reduce ft. - Since F* does not have SN, one has to be more careful for the termination argument. - Because OCaml does not support computations in Type, MLTY_Top is supposed to be used if they are really unaviodable. - The classic example is the type : T b \def if b then nat else bool. If we dont compute, T true will extract to MLTY_Top. - Why not \delta? I guess the reason is that unfolding definitions will make the resultant OCaml code less readable. - However in the Typ_app case, \delta reduction is done as the second-last resort, just before giving up and returing MLTY_Top; - a bloated type is atleast as good as MLTY_Top? - An an F* specific example, unless we unfold Mem x pre post to StState x wp wlp, we have no idea that it should be translated to x -*) -let extraction_norm_steps = - let extraction_norm_steps_core = - [Env.AllowUnboundUniverses; - Env.EraseUniverses; - Env.Inlining; - Env.Eager_unfolding; - Env.Exclude Env.Zeta; - Env.Primops; - Env.Unascribe; - Env.ForExtraction] in - - let extraction_norm_steps_nbe = - Env.NBE::extraction_norm_steps_core in - - if Options.use_nbe_for_extraction() - then extraction_norm_steps_nbe - else extraction_norm_steps_core - -let normalize_for_extraction (env:uenv) (e:S.term) = - N.normalize extraction_norm_steps (tcenv_of_uenv env) e - -let maybe_reify_comp g (env:TcEnv.env) (c:S.comp) : S.term = - match c |> U.comp_effect_name - |> TcUtil.effect_extraction_mode env with - | S.Extract_reify -> - TcEnv.reify_comp env c S.U_unknown - |> N.normalize extraction_norm_steps env - | S.Extract_primitive -> U.comp_result c - | S.Extract_none s -> - err_cannot_extract_effect (c |> U.comp_effect_name) c.pos s (show c) - -let maybe_reify_term (env:TcEnv.env) (t:S.term) (l:lident) : S.term = - match TcUtil.effect_extraction_mode env l with - | S.Extract_reify -> - TcUtil.norm_reify env - [TcEnv.Inlining; TcEnv.ForExtraction; TcEnv.Unascribe] - (U.mk_reify t (Some l)) - | S.Extract_primitive -> t - | S.Extract_none s -> - err_cannot_extract_effect l t.pos s (show t) - -let has_extract_as_impure_effect (g:uenv) (fv:S.fv) = - TcEnv.fv_has_attr (tcenv_of_uenv g) fv FStar.Parser.Const.extract_as_impure_effect_lid - -let head_of_type_is_extract_as_impure_effect g t = - let hd, _ = U.head_and_args t in - match (U.un_uinst hd).n with - | Tm_fvar fv -> has_extract_as_impure_effect g fv - | _ -> false - -let rec translate_term_to_mlty (g:uenv) (t0:term) : mlty = - let arg_as_mlty (g:uenv) (a, _) : mlty = - if is_type g a //This is just an optimization; we could in principle always emit MLTY_Erased, at the expense of more magics - then translate_term_to_mlty g a - else MLTY_Erased - in - let fv_app_as_mlty (g:uenv) (fv:fv) (args : args) : mlty = - if not (is_fv_type g fv) - then MLTY_Top //it was translated as an expression or erased - else ( - if has_extract_as_impure_effect g fv - then let (a, _)::_ = args in - translate_term_to_mlty g a - else ( - let formals, _ = - let (_, fvty), _ = FStar.TypeChecker.Env.lookup_lid (tcenv_of_uenv g) fv.fv_name.v in - let fvty = N.normalize [Env.UnfoldUntil delta_constant; Env.ForExtraction] (tcenv_of_uenv g) fvty in - U.arrow_formals fvty in - let mlargs = List.map (arg_as_mlty g) args in - let mlargs = - let n_args = List.length args in - if List.length formals > n_args //it's not fully applied; so apply the rest to unit - then let _, rest = BU.first_N n_args formals in - mlargs @ (List.map (fun _ -> MLTY_Erased) rest) - else mlargs in - let nm = UEnv.mlpath_of_lident g fv.fv_name.v in - MLTY_Named (mlargs, nm) - ) - ) - in - let aux env t = - let t = SS.compress t in - match t.n with - | Tm_type _ -> MLTY_Erased - - | Tm_bvar _ - | Tm_delayed _ - | Tm_unknown -> failwith (BU.format1 "Impossible: Unexpected term %s" (show t)) - - | Tm_lazy i -> translate_term_to_mlty env (U.unfold_lazy i) - - | Tm_constant _ -> MLTY_Top - | Tm_quoted _ -> MLTY_Top - - | Tm_uvar _ -> MLTY_Top //really shouldn't have any uvars left; TODO: fatal failure? - - | Tm_meta {tm=t} - | Tm_refine {b={sort=t}} - | Tm_uinst(t, _) - | Tm_ascribed {tm=t} -> translate_term_to_mlty env t - - | Tm_name bv -> - bv_as_mlty env bv - - | Tm_fvar fv -> - (* it is not clear whether description in the thesis covers type applications with 0 args. - However, this case is needed to translate types like nnat, and so far seems to work as expected*) - fv_app_as_mlty env fv [] - - | Tm_arrow {bs; comp=c} -> - let bs, c = SS.open_comp bs c in - let mlbs, env = binders_as_ml_binders env bs in - let codom = maybe_reify_comp env (tcenv_of_uenv env) c in - let t_ret = translate_term_to_mlty env codom in - let etag = effect_as_etag env (U.comp_effect_name c) in - let etag = - if etag = E_IMPURE then etag - else if head_of_type_is_extract_as_impure_effect env codom - then E_IMPURE - else etag - in - let _, t = List.fold_right (fun (_, t) (tag, t') -> (E_PURE, MLTY_Fun(t, tag, t'))) mlbs (etag, t_ret) in - t - - (*can this be a partial type application? , i.e can the result of this application be something like Type -> Type, or nat -> Type? : Yes *) - (* should we try to apply additional arguments here? if not, where? FIX!! *) - | Tm_app _ -> - let head, args = U.head_and_args_full t in - let res = match (U.un_uinst head).n, args with - | Tm_name bv, _ -> - (*the args are thrown away, because in OCaml, type variables have type Type and not something like -> .. -> .. Type *) - bv_as_mlty env bv - - | Tm_fvar fv, [_] - when S.fv_eq_lid fv PC.steel_memory_inv_lid -> - translate_term_to_mlty env S.t_unit - - | Tm_fvar fv, _ -> - fv_app_as_mlty env fv args - - | _ -> MLTY_Top in - res - - | Tm_abs {bs;body=ty} -> (* (sch) rule in \hat{\epsilon} *) - (* We just translate the body in an extended environment; the binders will just end up as units *) - let bs, ty = SS.open_term bs ty in - let bts, env = binders_as_ml_binders env bs in - translate_term_to_mlty env ty - - | Tm_let _ - | Tm_match _ -> MLTY_Top - in - - let rec is_top_ty t = match t with - | MLTY_Top -> true - | MLTY_Named _ -> - begin match Util.udelta_unfold g t with - | None -> false - | Some t -> is_top_ty t - end - | _ -> false - in - if TcUtil.must_erase_for_extraction (tcenv_of_uenv g) t0 - then MLTY_Erased - else let mlt = aux g t0 in - if is_top_ty mlt - then MLTY_Top - else mlt - - -and binders_as_ml_binders (g:uenv) (bs:binders) : list (mlident & mlty) & uenv = - let ml_bs, env = bs |> List.fold_left (fun (ml_bs, env) b -> - if is_type_binder g b - then //no first-class polymorphism; so type-binders get wiped out - let b = b.binder_bv in - let env = extend_ty env b true in - let ml_b = (lookup_ty env b).ty_b_name in - let ml_b = (ml_b (*name of the binder*), - ml_unit_ty (*type of the binder. correspondingly, this argument gets converted to the unit value in application *)) in - ml_b::ml_bs, env - else let b = b.binder_bv in - let t = translate_term_to_mlty env b.sort in - let env, b, _ = extend_bv env b ([], t) false false in - let ml_b = b, t in - ml_b::ml_bs, env) - ([], g) in - List.rev ml_bs, - env - -let term_as_mlty g t0 = - let t = N.normalize extraction_norm_steps (tcenv_of_uenv g) t0 in - translate_term_to_mlty g t - - -////////////////////////////////////////////////////////////////////////////////////////////// -(********************************************************************************************) -(* The main extraction of terms to ML expressions *) -(********************************************************************************************) -////////////////////////////////////////////////////////////////////////////////////////////// - -//A peephole optimizer for sequences -let mk_MLE_Seq e1 e2 = match e1.expr, e2.expr with - | MLE_Seq es1, MLE_Seq es2 -> MLE_Seq (es1@es2) - | MLE_Seq es1, _ -> MLE_Seq (es1@[e2]) - | _, MLE_Seq es2 -> MLE_Seq (e1::es2) - | _ -> MLE_Seq [e1; e2] - -//A peephole optimizer for let -(* - 1. Optimize (let x : unit = e in ()) to e - 2. Optimize (let x : unit = e in x) to e - 3. Optimize (let x : unit = () in e) to e - 4. Optimize (let x : unit = e in e') to e;e -*) -let mk_MLE_Let top_level (lbs:mlletbinding) (body:mlexpr) = - match lbs with - | (NonRec, [lb]) when not top_level -> - (match lb.mllb_tysc with - | Some ([], t) when (t=ml_unit_ty) -> - if body.expr=ml_unit.expr - then lb.mllb_def.expr //case 1 - else (match body.expr with - | MLE_Var x when (x=lb.mllb_name) -> lb.mllb_def.expr //case 2 - | _ when (lb.mllb_def.expr=ml_unit.expr) -> body.expr //case 3 - | _ -> mk_MLE_Seq lb.mllb_def body) //case 4 - | _ -> MLE_Let(lbs, body)) - | _ -> MLE_Let(lbs, body) - -let record_fields (g:uenv) (ty:lident) (fns:list ident) (xs:list 'a) = - let fns = List.map (fun x -> UEnv.lookup_record_field_name g (ty, x)) fns in - List.map2 (fun (p, s) x -> (s, x)) fns xs - -let resugar_pat g q p = match p with - | MLP_CTor(d, pats) -> - begin match is_xtuple d with - | Some n -> MLP_Tuple(pats) - | _ -> - match q with - | Some (Record_ctor (ty, fns)) -> - let path = List.map string_of_id (ns_of_lid ty) in - let fs = record_fields g ty fns pats in - let path = no_fstar_stubs_ns path in - MLP_Record(path, fs) - | _ -> p - end - | _ -> p - -//extract_pat g p expected_t -// Translates an F* pattern to an ML pattern -// The main work is erasing inaccessible (dot) patterns -// And turning F*'s curried pattern style to ML's fully applied ones -// -//Also, as seen in Bug2595, we need to make sure that the pattern bound -//variables are introduced into the environment at their expected ML type -//rather than their computed F* type, which may be more precise than what -//is typeble in ML. -//E.g., Consider -// v: (b:bool & (if b then bool else nat)) -// and -// match v with -// | (| true, b |) -> ... -// -// In F*, the sort of b is computed to be bool, since the conditional -// can be eliminated -// But, in OCaml, this should be typed as Obj.t, since the type of v itself is -// (bool, Obj.t) dtuple2 -// -let rec extract_one_pat (imp : bool) - (g:uenv) - (p:S.pat) - (expected_ty:mlty) - (term_as_mlexpr:uenv -> S.term -> (mlexpr & e_tag & mlty)) - : uenv - & option (mlpattern & list mlexpr) - & bool = //the bool indicates whether or not a magic should be inserted around the scrutinee - let ok t = - match expected_ty with - | MLTY_Top -> - false - | _ -> - let ok = type_leq g t expected_ty in - if not ok then debug g (fun _ -> BU.print2 "Expected pattern type %s; got pattern type %s\n" - (Code.string_of_mlty (current_module_of_uenv g) expected_ty) - (Code.string_of_mlty (current_module_of_uenv g) t)); - ok - in - match p.v with - | Pat_constant (Const_int (c, swopt)) - when Options.codegen() <> Some Options.Krml -> - //Karamel supports native integer constants in patterns - //Don't convert them into `when` clauses - let mlc, ml_ty = - match swopt with - | None -> - with_ty ml_int_ty <| (MLE_Const (mlconst_of_const p.p (Const_int (c, None)))), - ml_int_ty - | Some sw -> - let source_term = - FStar.ToSyntax.ToSyntax.desugar_machine_integer (tcenv_of_uenv g).dsenv c sw Range.dummyRange in - let mlterm, _, mlty = term_as_mlexpr g source_term in - mlterm, mlty - in - //these may be extracted to bigint, in which case, we need to emit a when clause - let g, x = UEnv.new_mlident g in - let x_exp = - let x_exp = with_ty expected_ty <| MLE_Var x in - let coerce x = with_ty ml_ty <| (MLE_Coerce(x, ml_ty, expected_ty)) in - match expected_ty with - | MLTY_Top -> coerce x_exp - | _ -> - if ok ml_ty - then x_exp - else coerce x_exp - in - let when_clause = with_ty ml_bool_ty <| - MLE_App(prims_op_equality, [x_exp; - mlc]) in - g, Some (MLP_Var x, [when_clause]), ok ml_ty - - | Pat_constant s -> - let t : term = TcTerm.tc_constant (tcenv_of_uenv g) Range.dummyRange s in - let mlty = term_as_mlty g t in - g, Some (MLP_Const (mlconst_of_const p.p s), []), ok mlty - - | Pat_var x -> - //In some cases, the computed_mlty based on the F* computed sort x.sort - //can be more precise than the type in ML. see e.g., Bug2595 - //So, prefer to extend the environment with the expected ML type of the - //binder rather than the computed_mlty, so that we do not forget to put - //magics around the uses of the bound variable at use sites - let g, x, _ = extend_bv g x ([], expected_ty) false imp in - g, - (if imp then None else Some (MLP_Var x, [])), - true //variables are always ok as patterns, no need to insert a magic on the scrutinee when matching a variable - - | Pat_dot_term _ -> - g, None, true - - | Pat_cons (f, _, pats) -> - // The main subtlety here, relative to Bug2595, is to propapate the - // expected type properly - - //1. Lookup the ML name of the constructor d - // and the type scheme of the constructor tys - // parameterized by the parameters of the inductive it constructs - let d, tys = - match try_lookup_fv p.p g f with - | Some ({exp_b_expr={expr=MLE_Name n}; exp_b_tscheme=ttys}) -> n, ttys - | Some _ -> failwith "Expected a constructor" - | None -> - Errors.raise_error f.fv_name.p Errors.Error_ErasedCtor - (BU.format1 "Cannot extract this pattern, the %s constructor was erased" (show f)) - in - // The prefix of the pattern are dot patterns matching the type parameters - let nTyVars = List.length (fst tys) in - let tysVarPats, restPats = BU.first_N nTyVars pats in - // f_ty is the instantiated type of the constructor - let f_ty = - let mlty_args = - tysVarPats |> - List.map - (fun (p, _) -> - match expected_ty with - | MLTY_Top -> - //if the expected_ty of the pattern is MLTY_Top - //then treat all its parameters as MLTY_Top too - MLTY_Top - | _ -> - //Otherwise, if it has a dot pattern for matching the type parameters - match p.v with - | Pat_dot_term (Some t) -> - //use the type that the dot patterns is instantiated to - term_as_mlty g t - | _ -> - //otherwise, we're back to useing MLTY_Top for this argument - MLTY_Top) - in - //The instantiated type is of the form t1 -> .. -> tn -> T - let f_ty = subst tys mlty_args in - //collect the arguments and result ([t1;...;tn], T) - Util.uncurry_mlty_fun f_ty - in - debug g (fun () -> BU.print2 "@@@Expected type of pattern with head = %s is %s\n" - (show f) - (let args, t = f_ty in - let args = - List.map - (Code.string_of_mlty (current_module_of_uenv g)) - args - |> String.concat " -> " - in - let res = Code.string_of_mlty (current_module_of_uenv g) t in - BU.format2 "%s -> %s" args res)); - // Now extract all the type patterns - // These should all come out as None, if they are dot patterns - // Their expected type does not matter - let g, tyMLPats = - BU.fold_map - (fun g (p, imp) -> - let g, p, _ = extract_one_pat true g p MLTY_Top term_as_mlexpr in - g, p) - g - tysVarPats - in (*not all of these were type vars in ML*) - - // Extract the actual pattern arguments - let (g, f_ty, sub_pats_ok), restMLPats = - BU.fold_map - (fun (g, f_ty, ok) (p, imp) -> - //The ecpected argument type is the type of the i'th field - let f_ty, expected_arg_ty = - match f_ty with - | (hd::rest, res) -> (rest, res), hd - | _ -> ([], MLTY_Top), MLTY_Top - in - let g, p, ok' = extract_one_pat false g p expected_arg_ty term_as_mlexpr in - (g, f_ty, ok && ok'), p) - (g, f_ty, true) - restPats - in - - let mlPats, when_clauses = - List.append tyMLPats restMLPats - |> List.collect (function (Some x) -> [x] | _ -> []) - |> List.split - in - - let pat_ty_compat = - match f_ty with - | ([], t) -> ok t - | _ -> false //arity mismatch, should be impossible - in - g, - Some (resugar_pat g f.fv_qual (MLP_CTor (d, mlPats)), - when_clauses |> List.flatten), - sub_pats_ok && - pat_ty_compat - -let extract_pat (g:uenv) (p:S.pat) (expected_t:mlty) - (term_as_mlexpr: uenv -> S.term -> (mlexpr & e_tag & mlty)) - : (uenv & list (mlpattern & option mlexpr) & bool) = - let extract_one_pat g p expected_t = - match extract_one_pat false g p expected_t term_as_mlexpr with - | g, Some (x, v), b -> g, (x, v), b - | _ -> failwith "Impossible: Unable to translate pattern" - in - let mk_when_clause whens = - match whens with - | [] -> None - | hd::tl -> Some (List.fold_left conjoin hd tl) - in - let g, (p, whens), b = extract_one_pat g p expected_t in - let when_clause = mk_when_clause whens in - g, [(p, when_clause)], b - -(* - maybe_lalloc_eta_data_and_project_record g qual residualType mlAppExpr: - - Preconditions: - 1) residualType is the type of mlAppExpr - 2) mlAppExpr is an MLE_Name or an MLE_App with its head a named fvar, - and isDataCons is true iff it names a data constructor of a data type. - - Postconditions: - 1) the return value (say r) also has type residualType and its - extraction-preimage is definitionally equal in F* to that of mlAppExpr - 2) meets the ML requirements that the args to datacons be tupled - and that the datacons be fully applied - 3) In case qual is record projector and mlAppExpr is of the form (f e), - emits e.f instead, since record projection is primitive in ML -*) -let maybe_eta_data_and_project_record (g:uenv) (qual : option fv_qual) (residualType : mlty) (mlAppExpr : mlexpr) : mlexpr = - let rec eta_args g more_args t = match t with - | MLTY_Fun (t0, _, t1) -> - let g, x = UEnv.new_mlident g in - eta_args g (((x, t0), with_ty t0 <| MLE_Var x)::more_args) t1 - | MLTY_Named (_, _) -> List.rev more_args, t - | _ -> failwith (BU.format2 "Impossible: Head type is not an arrow: (%s : %s)" - (Code.string_of_mlexpr (current_module_of_uenv g) mlAppExpr) - (Code.string_of_mlty (current_module_of_uenv g) t)) - in - let as_record qual e = - match e.expr, qual with - | MLE_CTor(_, args), Some (Record_ctor(tyname, fields)) -> - let path = List.map string_of_id (ns_of_lid tyname) in - let fields = record_fields g tyname fields args in - let path = no_fstar_stubs_ns path in - with_ty e.mlty <| MLE_Record (path, tyname |> ident_of_lid |> string_of_id, fields) - | _ -> e - in - let resugar_and_maybe_eta qual e = - let eargs, tres = eta_args g [] residualType in - match eargs with - | [] -> Util.resugar_exp (as_record qual e) - | _ -> - let binders, eargs = List.unzip eargs in - match e.expr with - | MLE_CTor(head, args) -> - let body = Util.resugar_exp <| (as_record qual <| (with_ty tres <| MLE_CTor(head, args@eargs))) in - with_ty e.mlty <| MLE_Fun(List.map (fun (x,t) -> {mlbinder_name=x;mlbinder_ty=t;mlbinder_attrs=[]}) binders, body) - | _ -> failwith "Impossible: Not a constructor" - in - match mlAppExpr.expr, qual with - | _, None -> mlAppExpr - - | MLE_App({expr=MLE_Name mlp}, mle::args), Some (Record_projector (constrname, f)) - | MLE_App({expr=MLE_TApp({expr=MLE_Name mlp}, _)}, mle::args), Some (Record_projector (constrname, f))-> - let fn = UEnv.lookup_record_field_name g (TcEnv.typ_of_datacon (tcenv_of_uenv g) constrname, f) in - let proj = MLE_Proj(mle, fn) in - let e = match args with - | [] -> proj - | _ -> MLE_App(with_ty MLTY_Top <| proj, args) in //TODO: Fix imprecise with_ty on the projector - with_ty mlAppExpr.mlty e - - | MLE_App ({expr=MLE_Name mlp}, mlargs), Some Data_ctor - | MLE_App ({expr=MLE_Name mlp}, mlargs), Some (Record_ctor _) - | MLE_App ({expr=MLE_TApp({expr=MLE_Name mlp}, _)}, mlargs), Some Data_ctor - | MLE_App ({expr=MLE_TApp({expr=MLE_Name mlp}, _)}, mlargs), Some (Record_ctor _) -> - resugar_and_maybe_eta qual <| (with_ty mlAppExpr.mlty <| MLE_CTor (mlp,mlargs)) - - | MLE_Name mlp, Some Data_ctor - | MLE_Name mlp, Some (Record_ctor _) - | MLE_TApp({expr=MLE_Name mlp}, _), Some Data_ctor - | MLE_TApp({expr=MLE_Name mlp}, _), Some (Record_ctor _) -> - resugar_and_maybe_eta qual <| (with_ty mlAppExpr.mlty <| MLE_CTor (mlp, [])) - - | _ -> mlAppExpr - -let maybe_promote_effect ml_e tag t = - match tag, t with - | E_ERASABLE, MLTY_Erased - | E_PURE, MLTY_Erased -> ml_unit, E_PURE - | _ -> ml_e, tag - - -type lb_sig = - lbname //just lbname returned back - & e_tag //the ML version of the effect label lbeff - & (typ //just the source type lbtyp=t, after compression - & (S.binders //the erased type binders - & mltyscheme)) //translation of the source type t as a ML type scheme - & bool //whether or not to add a unit argument - & bool //whether this was marked CInline - & term //the term e, maybe after some type binders have been erased - -let rec extract_lb_sig (g:uenv) (lbs:letbindings) : list lb_sig = - let maybe_generalize {lbname=lbname_; lbeff=lbeff; lbtyp=lbtyp; lbdef=lbdef; lbattrs=lbattrs} : lb_sig = - let has_c_inline = U.has_attribute lbattrs PC.c_inline_attr in - // begin match lbattrs with - // | [] -> () - // | _ -> - // // BU.print1 "Testing whether term has any rename_let %s..." ""; - // begin match U.get_attribute PC.rename_let_attr lbattrs with - // | Some ((arg, _) :: _) -> - // begin match arg.n with - // | Tm_constant (Const_string (arg, _)) -> - // BU.print1 "Term has rename_let %s\n" arg - // | _ -> BU.print1 "Term has some rename_let %s\n" "" - // end - // | _ -> BU.print1 "no rename_let found %s\n" "" - // end - // end; - let f_e = effect_as_etag g lbeff in - let lbtyp = SS.compress lbtyp in - let no_gen () = - let expected_t = term_as_mlty g lbtyp in - (lbname_, f_e, (lbtyp, ([], ([],expected_t))), false, has_c_inline, lbdef) - in - if TcUtil.must_erase_for_extraction (tcenv_of_uenv g) lbtyp - then (lbname_, f_e, (lbtyp, ([], ([], MLTY_Erased))), false, has_c_inline, lbdef) - else // debug g (fun () -> printfn "Let %s at type %s; expected effect is %A\n" (show lbname) (Print.typ_to_string t) f_e); - match lbtyp.n with - | Tm_arrow {bs; comp=c} when (List.hd bs |> is_type_binder g) -> - let bs, c = SS.open_comp bs c in - //need to generalize, but will erase all the type abstractions; - //If, after erasure, what remains is not a value, then add an extra unit arg. to preserve order of evaluation/generativity - //and to circumvent the value restriction - - //We also erase type arguments that abstract over impure functions, - //replacing the type arguments with a single unit. - //For example, `a:Type -> Dv a` is extracted to `unit -Impure-> 'a` - //The important thing is that we retain an effect tag on the arrow to note - //that the type application is impure. - //See Issue #3473 - let etag_of_comp c = effect_as_etag g (U.comp_effect_name c) in - let tbinders, eff_body, tbody = - match BU.prefix_until (fun x -> not (is_type_binder g x)) bs with - | None -> bs, etag_of_comp c, U.comp_result c - | Some (bs, b, rest) -> bs, E_PURE, U.arrow (b::rest) c - in - let n_tbinders = List.length tbinders in - let lbdef = normalize_abs lbdef |> U.unmeta in - let tbinders_as_ty_params env = List.map (fun ({binder_bv=x; binder_attrs}) -> { - ty_param_name = (UEnv.lookup_ty env x).ty_b_name; - ty_param_attrs = List.map (fun attr -> let e, _, _ = term_as_mlexpr g attr in e) binder_attrs}) in - begin match lbdef.n with - | Tm_abs {bs; body; rc_opt=copt} -> - let bs, body = SS.open_term bs body in - if n_tbinders <= List.length bs - then let targs, rest_args = BU.first_N n_tbinders bs in - let expected_source_ty = - let s = List.map2 (fun ({binder_bv=x}) ({binder_bv=y}) -> S.NT(x, S.bv_to_name y)) tbinders targs in - SS.subst s tbody in - let env = List.fold_left (fun env ({binder_bv=a}) -> UEnv.extend_ty env a false) g targs in - let expected_t = term_as_mlty env expected_source_ty in - let polytype = tbinders_as_ty_params env targs, expected_t in - let add_unit = - match rest_args with - | [] -> - not (is_fstar_value body) //if it's a pure type app, then it will be extracted to a value in ML; so don't add a unit - || not (U.is_pure_comp c) - | _ -> false in - let rest_args = if add_unit then (unit_binder()::rest_args) else rest_args in - let polytype = - if add_unit - then (* record the effect of type application, eff_body *) - push_unit eff_body polytype - else polytype - in - let body = U.abs rest_args body copt in - (lbname_, f_e, (lbtyp, (targs, polytype)), add_unit, has_c_inline, body) - - else (* fails to handle: - let f : a:Type -> b:Type -> a -> b -> Tot (nat * a * b) = - fun (a:Type) -> - let x = 0 in - fun (b:Type) (y:a) (z:b) -> (x, y, z) - - Could eta-expand; but with effects this is problem; see ETA-EXPANSION and NO GENERALIZATION below - *) - failwith "Not enough type binders" //TODO: better error message - - | Tm_uinst _ - | Tm_fvar _ - | Tm_name _ -> - let env = List.fold_left (fun env ({binder_bv=a}) -> UEnv.extend_ty env a false) g tbinders in - let expected_t = term_as_mlty env tbody in - let polytype = tbinders_as_ty_params env tbinders, expected_t in - //In this case, an eta expansion is safe - let args = tbinders |> List.map (fun ({binder_bv=bv}) -> S.bv_to_name bv |> as_arg) in - let e = mk (Tm_app {hd=lbdef; args}) lbdef.pos in - (lbname_, f_e, (lbtyp, (tbinders, polytype)), false, has_c_inline, e) - - | _ -> - //ETA-EXPANSION? - //An alternative here could be to eta expand the body, but with effects, that's quite dodgy - // Consider: - // let f : ML ((a:Type) -> a -> Tot a) = x := 17; (fun (a:Type) (x:a) -> x) - // Eta-expanding this would break the assignment; so, unless we hoist the assignment, we must reject this program - // One possibility is to restrict F* so that the effect of f must be Pure - // In that case, an eta-expansion would be semantically ok, but consider this: - // let g : Tot ((a:Type) -> a -> Tot (a * nat)) = let z = expensive_pure_comp x in fun (a:Type) (x:a) -> (x,z)) - // The eta expansion would cause the expensive_pure_comp to be run each time g is instantiated (this is what Coq does, FYI) - // It may be better to hoist expensive_pure_comp again. - //NO GENERALIZATION: - //Another alternative could be to not generalize the type t, inserting MLTY_Top for the type variables - err_value_restriction lbdef - end - - | _ -> no_gen() - in - snd lbs |> List.map maybe_generalize - -and extract_lb_iface (g:uenv) (lbs:letbindings) - : uenv & list (fv & exp_binding) = - let is_top = FStar.Syntax.Syntax.is_top_level (snd lbs) in - let is_rec = not is_top && fst lbs in - let lbs = extract_lb_sig g lbs in - BU.fold_map (fun env - (lbname, _e_tag, (typ, (_binders, mltyscheme)), add_unit, _has_c_inline, _body) -> - let env, _, exp_binding = - UEnv.extend_lb env lbname typ mltyscheme add_unit in - env, (BU.right lbname, exp_binding)) - g - lbs - -//The main extraction function -and check_term_as_mlexpr (g:uenv) (e:term) (f:e_tag) (ty:mlty) : (mlexpr & mlty) = - debug g - (fun () -> BU.print3 "Checking %s at type %s and eff %s\n" - (show e) - (Code.string_of_mlty (current_module_of_uenv g) ty) - (Util.eff_to_string f)); - match f, ty with - | E_ERASABLE, _ - | E_PURE, MLTY_Erased -> ml_unit, MLTY_Erased - | _ -> - let ml_e, tag, t = term_as_mlexpr g e in - debug g (fun _ -> - BU.print4 "Extracted %s to %s at eff %s and type %s\n" - (show e) - (Code.string_of_mlexpr (current_module_of_uenv g) ml_e) - (Util.eff_to_string tag) - (Code.string_of_mlty (current_module_of_uenv g) t)); - if eff_leq tag f - then maybe_coerce e.pos g ml_e t ty, ty - else match tag, f, ty with - | E_ERASABLE, E_PURE, MLTY_Erased -> //effect downgrading for erased results - maybe_coerce e.pos g ml_e t ty, ty - | _ -> - err_unexpected_eff g e ty f tag; - maybe_coerce e.pos g ml_e t ty, ty - -and term_as_mlexpr (g:uenv) (e:term) : (mlexpr & e_tag & mlty) = - let e, f, t = term_as_mlexpr' g e in - let e, f = maybe_promote_effect e f t in - e, f, t - - -and term_as_mlexpr' (g:uenv) (top:term) : (mlexpr & e_tag & mlty) = - let top = SS.compress top in - (debug g (fun u -> BU.print_string (BU.format3 "%s: term_as_mlexpr' (%s) : %s \n" - (Range.string_of_range top.pos) - (tag_of top) - (show top)))); - - (* - * AR: Following util functions are to implement the following rule: - * (match e with | P_i -> body_i) args ~~> - * (match e with | P_i -> body_i args) - * - * This opens up more opportunities for reduction, - * especially when using layered effects where reification leads to - * some lambdas introduced and applied this way - * - * Doing it naively results in code blowup (if args are big terms) - * so controlling it specifically - *) - let is_match t = - match (t |> SS.compress |> U.unascribe).n with - | Tm_match _ -> true - | _ -> false in - - let should_apply_to_match_branches : S.args -> bool = - List.for_all (fun (t, _) -> - match (t |> SS.compress).n with - | Tm_name _ | Tm_fvar _ | Tm_constant _ -> true | _ -> false) in - - //precondition: is_match head = true - let apply_to_match_branches head args = - match (head |> SS.compress |> U.unascribe).n with - | Tm_match {scrutinee; brs=branches} -> - let branches = - branches |> List.map (fun (pat, when_opt, body) -> - pat, when_opt, { body with n = Tm_app {hd=body; args} } - ) in - { head with n = Tm_match {scrutinee; ret_opt=None; brs=branches; rc_opt=None} } //AR: dropping the return annotation and rc - | _ -> failwith "Impossible! cannot apply args to match branches if head is not a match" in - - let t = SS.compress top in - match t.n with - | Tm_unknown - | Tm_delayed _ - | Tm_uvar _ - | Tm_bvar _ -> failwith (BU.format1 "Impossible: Unexpected term: %s" (tag_of t)) - - | Tm_lazy i -> term_as_mlexpr g (U.unfold_lazy i) - - | Tm_type _ - | Tm_refine _ - | Tm_arrow _ -> - ml_unit, E_PURE, ml_unit_ty - - | Tm_quoted (qt, { qkind = Quote_dynamic }) -> - let ({exp_b_expr=fw}) = UEnv.lookup_fv t.pos g (S.lid_as_fv (PC.failwith_lid()) None) in - with_ty ml_int_ty <| MLE_App(fw, [with_ty ml_string_ty <| MLE_Const (MLC_String "Cannot evaluate open quotation at runtime")]), - E_PURE, - ml_int_ty - - | Tm_quoted (qt, { qkind = Quote_static; antiquotations = (shift, aqs) }) -> - begin match R.inspect_ln qt with - | RD.Tv_BVar bv -> - (* If it's a variable, check whether it's an antiquotation or just a bvar node *) - if bv.index < shift then - (* just a local bvar *) - let tv' = RD.Tv_BVar bv in - let tv = EMB.embed tv' t.pos None EMB.id_norm_cb in - let t = U.mk_app (RC.refl_constant_term RC.fstar_refl_pack_ln) [S.as_arg tv] in - term_as_mlexpr g t - else - let tm = S.lookup_aq bv (shift, aqs) in - term_as_mlexpr g tm - - | tv -> - (* Else, just embed recursively. *) - let tv = EMB.embed #_ #(RE.e_term_view_aq (shift, aqs)) tv t.pos None EMB.id_norm_cb in - let t = U.mk_app (RC.refl_constant_term RC.fstar_refl_pack_ln) [S.as_arg tv] in - term_as_mlexpr g t - end - - | Tm_meta {tm=t; meta=Meta_monadic (m, _)} -> - // - // A meta monadic node - // We should have taken care of it when we were reifying the Tm_abs - // But it is ok, if the effect is primitive - // - let t = SS.compress t in - begin match t.n with - | Tm_let {lbs=(false, [lb]); body} when (BU.is_left lb.lbname) -> - let tcenv = tcenv_of_uenv g in - let ed, qualifiers = must (TypeChecker.Env.effect_decl_opt tcenv m) in - if TcUtil.effect_extraction_mode tcenv ed.mname = S.Extract_primitive - then term_as_mlexpr g t - else - failwith - (BU.format1 - "This should not happen (should have been handled at Tm_abs level for effect %s)" - (string_of_lid ed.mname)) - | _ -> term_as_mlexpr g t - end - - | Tm_meta {tm=t; meta=Meta_monadic_lift (m1, _m2, _ty)} - when effect_as_etag g m1 = E_ERASABLE -> - (* - * We would come here if m2 is not erasable, - * because if it is, we would not have descended into the outer expression - * - * So if m2 is not erasable, how is erasing this lift justified? - * - * A: The typechecker ensures that _ty is non-informative - *) - ml_unit, E_ERASABLE, MLTY_Erased - - | Tm_meta {tm=t; meta=Meta_desugared (Machine_integer (signedness, width))} -> - - let t = SS.compress t in - let t = U.unascribe t in - (match t.n with - (* Should we check if hd here is [__][u]int_to_t? *) - | Tm_app {hd; args=[x, _]} -> - (let x = SS.compress x in - let x = U.unascribe x in - match x.n with - | Tm_constant (Const_int (repr, _)) -> - (let _, ty, _ = - TcTerm.typeof_tot_or_gtot_term (tcenv_of_uenv g) t true in - let ml_ty = term_as_mlty g ty in - let ml_const = Const_int (repr, Some (signedness, width)) in - with_ty ml_ty (mlexpr_of_const t.pos ml_const), E_PURE, ml_ty) - |_ -> term_as_mlexpr g t) - | _ -> term_as_mlexpr g t) - - | Tm_meta {tm=t} //TODO: handle the resugaring in case it's a 'Meta_desugared' ... for more readable output - | Tm_uinst(t, _) -> - term_as_mlexpr g t - - | Tm_constant c -> - let tcenv = tcenv_of_uenv g in - let _, ty, _ = TcTerm.typeof_tot_or_gtot_term tcenv t true in //AR: TODO: type_of_well_typed? - if TcUtil.must_erase_for_extraction tcenv ty - then ml_unit, E_PURE, MLTY_Erased - else let ml_ty = term_as_mlty g ty in - with_ty ml_ty (mlexpr_of_const t.pos c), E_PURE, ml_ty - - | Tm_name _ -> //lookup in g; decide if its in left or right; tag is Pure because it's just a variable - if is_type g t //Here, we really need to be certain that g is a type; unclear if level ensures it - then ml_unit, E_PURE, ml_unit_ty //Erase type argument - else begin match lookup_term g t with - | Inl _, _ -> - ml_unit, E_PURE, ml_unit_ty - - | Inr ({exp_b_expr=x; exp_b_tscheme=mltys; exp_b_eff=etag}), qual -> - //etag is the effect associated with simply using t, since it may - //be an effectful type application in F* - //in the common case, etag is E_PURE - begin match mltys with - | ([], t) when t=ml_unit_ty -> - ml_unit, etag, t //optimize (x:unit) to () - - | ([], t) -> - maybe_eta_data_and_project_record g qual t x, etag, t - - | _ -> - (* We have a first-class polymorphic value; - Extract it to ML by instantiating its type arguments to MLTY_Erased *) - instantiate_maybe_partial g x etag mltys [] - end - end - - | Tm_fvar fv -> //Nearly identical to Tm_name, except the fv may have been erased altogether; if so return Erased - if is_type g t //Here, we really need to be certain that g is a type - then ml_unit, E_PURE, ml_unit_ty //Erase type argument - else - begin - match try_lookup_fv t.pos g fv with - | None -> //it's been erased - // Errors.log_issue t (Errors.Error_CallToErased, - // BU.format1 "Attempting to extract a call into erased function %s" (show fv)); - ml_unit, E_PURE, MLTY_Erased - - | Some {exp_b_expr=x; exp_b_tscheme=mltys} -> - let _ = debug g (fun () -> - BU.print3 "looked up %s: got %s at %s \n" - (show fv) - (show x) - (show (snd mltys))) in - begin match mltys with - | ([], t) when (t=ml_unit_ty) -> ml_unit, E_PURE, t //optimize (x:unit) to () - | ([], t) -> maybe_eta_data_and_project_record g fv.fv_qual t x, E_PURE, t - | _ -> instantiate_maybe_partial g x E_PURE mltys [] - end - end - - | Tm_abs {bs;body;rc_opt=rcopt} (* the annotated computation type of the body *) -> - let bs, body = SS.open_term bs body in - let ml_bs, env = binders_as_ml_binders g bs in - let ml_bs = List.map2 (fun (x,t) b -> { - mlbinder_name=x; - mlbinder_ty=t; - mlbinder_attrs=List.map (fun attr -> let e, _, _ = term_as_mlexpr env attr in e) b.binder_attrs; - }) ml_bs bs in - let body = - match rcopt with - | Some rc -> - maybe_reify_term (tcenv_of_uenv env) body rc.residual_effect - | None -> debug g (fun () -> BU.print1 "No computation type for: %s\n" (show body)); body in - let ml_body, f, t = term_as_mlexpr env body in - let f, tfun = List.fold_right - (fun {mlbinder_ty=targ} (f, t) -> E_PURE, MLTY_Fun (targ, f, t)) - ml_bs (f, t) in - with_ty tfun <| MLE_Fun(ml_bs, ml_body), f, tfun - - | Tm_app {hd={n=Tm_constant Const_range_of}; args=[(a1, _)]} -> - let ty = term_as_mlty g (tabbrev PC.range_lid) in - with_ty ty <| mlexpr_of_range a1.pos, E_PURE, ty - - | Tm_app {hd={n=Tm_constant Const_set_range_of}; args=[(t, _); (r, _)]} -> - term_as_mlexpr g t - - | Tm_app {hd={n=Tm_constant (Const_reflect _)}} -> - let ({exp_b_expr=fw}) = UEnv.lookup_fv t.pos g (S.lid_as_fv (PC.failwith_lid()) None) in - with_ty ml_int_ty <| MLE_App(fw, [with_ty ml_string_ty <| MLE_Const (MLC_String "Extraction of reflect is not supported")]), - E_PURE, - ml_int_ty - - | Tm_app _ - when is_steel_with_invariant_g t -> - ml_unit, E_PURE, MLTY_Erased - - | Tm_app _ - when Some? (is_steel_with_invariant t) -> - let body = Some?.v (is_steel_with_invariant t) in - let tm = S.mk_Tm_app body [as_arg unit_const] body.pos in - term_as_mlexpr g tm - - | Tm_app _ - when is_steel_new_invariant t -> - ml_unit, E_PURE, ml_unit_ty - - | Tm_app {hd=head; args} - when is_match head && - args |> should_apply_to_match_branches -> - args |> apply_to_match_branches head |> term_as_mlexpr g - - | Tm_app {hd=head; args} -> - let is_total rc = - Ident.lid_equals rc.residual_effect PC.effect_Tot_lid - || rc.residual_flags |> List.existsb (function TOTAL -> true | _ -> false) - in - - begin match (head |> SS.compress |> U.unascribe).n with //AR: unascribe, gives more opportunities for beta - (* - * AR: do we need is_total rc here? - *) - | Tm_abs {bs; rc_opt=rc} (* when is_total _rc *) -> //this is a beta_redex --- also reduce it before extraction - t - |> N.normalize [Env.Beta; Env.Iota; Env.Zeta; Env.EraseUniverses; Env.AllowUnboundUniverses; Env.ForExtraction] (tcenv_of_uenv g) - |> term_as_mlexpr g - - | Tm_constant (Const_reify lopt) -> - (match lopt with - | Some l -> - let e = maybe_reify_term (tcenv_of_uenv g) (args |> List.hd |> fst) l in - let tm = S.mk_Tm_app (TcUtil.remove_reify e) (List.tl args) t.pos in - term_as_mlexpr g tm - | None -> - raise_error top Errors.Fatal_ExtractionUnsupported - (BU.format1 "Cannot extract %s (reify effect is not set)" (show top)) - ) - - | _ -> - - let rec extract_app is_data (mlhead, mlargs_f) (f(*:e_tag*), t (* the type of (mlhead mlargs) *)) restArgs = - let mk_head () = - let mlargs = List.rev mlargs_f |> List.map fst in - with_ty t <| MLE_App(mlhead, mlargs) - in - debug g (fun () -> BU.print3 "extract_app ml_head=%s type of head = %s, next arg = %s\n" - (Code.string_of_mlexpr (current_module_of_uenv g) (mk_head())) - (Code.string_of_mlty (current_module_of_uenv g) t) - (match restArgs with [] -> "none" | (hd, _)::_ -> show hd)); - // Printf.printf "synth_app restArgs=%d, t=%A\n" (List.length restArgs) t; - match restArgs, t with - | [], _ -> - //1. If partially applied and head is a datacon, it needs to be eta-expanded - //Note, the evaluation order for impure arguments has already been - //enforced in the main type-checker, that already let-binds any - //impure arguments - let app = maybe_eta_data_and_project_record g is_data t (mk_head()) in - app, f, t - - | (arg, _)::rest, MLTY_Fun (formal_t, f', t) - when (is_type g arg - && type_leq g formal_t ml_unit_ty) -> - //non-prefix type app; this type argument gets erased to unit - extract_app is_data (mlhead, (ml_unit, E_PURE)::mlargs_f) (join arg.pos f f', t) rest - - | (e0, _)::rest, MLTY_Fun(tExpected, f', t) -> - //This is the main case of an actualy argument e0 provided to a function - //that expects an argument of type tExpected - let r = e0.pos in - let expected_effect = - if Options.lax() - && FStar.TypeChecker.Util.short_circuit_head head - then E_IMPURE - else E_PURE in - let e0, tInferred = - check_term_as_mlexpr g e0 expected_effect tExpected in - extract_app is_data (mlhead, (e0, expected_effect)::mlargs_f) (join_l r [f;f'], t) rest - - | _ -> - begin match Util.udelta_unfold g t with - | Some t -> extract_app is_data (mlhead, mlargs_f) (f, t) restArgs - | None -> - match t with - | MLTY_Erased -> //the head of the application has been erased; so the whole application should be too - ml_unit, E_PURE, t - - | MLTY_Top -> //cf. issue #734 - //Coerce to a function of the arity of restArgs - let t = List.fold_right (fun t out -> MLTY_Fun(MLTY_Top, E_PURE, out)) restArgs MLTY_Top in - let mlhead = - let mlargs = List.rev mlargs_f |> List.map fst in - let head = with_ty MLTY_Top <| MLE_App(mlhead, mlargs) in - maybe_coerce top.pos g head MLTY_Top t - in - extract_app is_data (mlhead, []) (f, t) restArgs - - | _ -> - let mlhead = - let mlargs = List.rev mlargs_f |> List.map fst in - let head = with_ty MLTY_Top <| MLE_App(mlhead, mlargs) in - maybe_coerce top.pos g head MLTY_Top t - in - err_ill_typed_application g top mlhead restArgs t - end - in - - let extract_app_maybe_projector is_data mlhead (f, t) args = - match is_data with - | Some (Record_projector _) -> - let rec remove_implicits args f t = match args, t with - | (a0, Some ({ aqual_implicit = true }))::args, MLTY_Fun(_, f', t) -> - remove_implicits args (join a0.pos f f') t - - | _ -> args, f, t in - let args, f, t = remove_implicits args f t in - extract_app is_data (mlhead, []) (f, t) args - - | _ -> extract_app is_data (mlhead, []) (f, t) args in - - let extract_app_with_instantiations () = - let head = U.un_uinst head in - begin match head.n with - | Tm_name _ - | Tm_fvar _ -> - // debug g (fun () -> printfn "head of app is %s\n" (Print.exp_to_string head)); - let (head_ml, (vars, t), head_eff), qual = - match lookup_term g head with - | Inr exp_b, q -> - debug g (fun () -> - BU.print4 "@@@looked up %s: got %s at %s with eff <%s>\n" - (show head) - (show exp_b.exp_b_expr) - (show (snd exp_b.exp_b_tscheme)) - (show exp_b.exp_b_eff)); - (exp_b.exp_b_expr, exp_b.exp_b_tscheme, exp_b.exp_b_eff), q - | _ -> failwith "FIXME Ty" in - - let has_typ_apps = match args with - | (a, _)::_ -> is_type g a - | _ -> false in - let head_ml, head_eff, head_t, args = - (* Here, we have, say, f extracted to head_ml, with a polymorphic ML type with n type-args - If, in F*, `f` is applied to exactly `n` type args, then things are easy: - We extract those n arguments to ML types - Instantiate the type scheme of head_ml - Generate a type application node, and continue - If `f` is only partially applied, i.e., to less than `n` args then - we follow a strategy similar to the case of Tm_name and Tm_fvar - when we deal with higher rank polymorphism. - i.e., we use instantiate_maybe_partial to "complete" the type application - with additional MLTY_Erased type arguments. - - Note, in both cases, we preserve type application in the ML AST - since KaRaMeL requires it. - - See e.g., bug #1694. - *) - let n = List.length vars in - let provided_type_args, rest = - if List.length args <= n - then List.map (fun (x, _) -> term_as_mlty g x) args, - [] - else let prefix, rest = BU.first_N n args in - List.map (fun (x, _) -> term_as_mlty g x) prefix, - rest - in - let head, head_eff, t = - match head_ml.expr with - | MLE_Name _ - | MLE_Var _ -> - let head, eff, t = - instantiate_maybe_partial g head_ml head_eff (vars, t) provided_type_args - in - head, eff, t - - | MLE_App(head, [{expr=MLE_Const MLC_Unit}]) -> - //this happens when the extraction inserted an extra - //unit argument to circumvent ML's value restriction - let head, eff, t = - instantiate_maybe_partial g head head_eff (vars, t) provided_type_args - in - MLE_App(head, [ ml_unit ]) |> with_ty t, - eff, - t - - | _ -> failwith "Impossible: Unexpected head term" - in - head, head_eff, t, rest - in - begin - match args with - | [] -> maybe_eta_data_and_project_record g qual head_t head_ml, head_eff, head_t - | _ -> extract_app_maybe_projector qual head_ml (head_eff, head_t) args - end - - | _ -> - let head, f, t = term_as_mlexpr g head in // t is the type inferred for head, the head of the app - extract_app_maybe_projector None head (f, t) args - end - in - - if is_type g t - then ml_unit, E_PURE, ml_unit_ty //Erase type argument: TODO: FIXME, this could be effectful - else match (U.un_uinst head).n with - | Tm_fvar fv -> - (match try_lookup_fv t.pos g fv with - | None -> //erased head - // Errors.log_issue t - // (Errors.Error_CallToErased, - // BU.format1 "Attempting to extract a call into erased function %s" (show fv)); - ml_unit, E_PURE, MLTY_Erased - | _ -> - extract_app_with_instantiations ()) - - | _ -> - extract_app_with_instantiations () - end - - | Tm_ascribed {tm=e0; asc=(tc, _, _); eff_opt=f} -> - let t = match tc with - | Inl t -> term_as_mlty g t - | Inr c -> term_as_mlty g (maybe_reify_comp g (tcenv_of_uenv g) c) in - let f = match f with - | None -> failwith "Ascription node with an empty effect label" - | Some l -> effect_as_etag g l in - let e, t = check_term_as_mlexpr g e0 f t in - e, f, t - - | Tm_let {lbs=(false, [lb]); body=e'} - when not (is_top_level [lb]) - && BU.is_some (U.get_attribute FStar.Parser.Const.rename_let_attr lb.lbattrs) -> - let b = S.mk_binder (BU.left lb.lbname) in - let ({binder_bv=x}), body = SS.open_term_1 b e' in - // BU.print_string "Reached let with rename_let attribute\n"; - let suggested_name = - let attr = U.get_attribute FStar.Parser.Const.rename_let_attr lb.lbattrs in - match attr with - | Some ([(str, _)]) -> - begin - match (SS.compress str).n with - | Tm_constant (Const_string (s, _)) - when s <> "" -> - // BU.print1 "Found suggested name %s\n" s; - let id = Ident.mk_ident (s, range_of_bv x) in - let bv = { ppname = id; index = 0; sort = x.sort } in - let bv = freshen_bv bv in - Some bv - | _ -> - Errors.log_issue top Errors.Warning_UnrecognizedAttribute - "Ignoring ill-formed application of `rename_let`"; - None - end - - | Some _ -> - Errors.log_issue top Errors.Warning_UnrecognizedAttribute - "Ignoring ill-formed application of `rename_let`"; - None - - | None -> - None - in - let remove_attr attrs = - let _, other_attrs = - List.partition - (fun attr -> BU.is_some (U.get_attribute PC.rename_let_attr [attr])) - lb.lbattrs - in - other_attrs - in - let maybe_rewritten_let = - match suggested_name with - | None -> - let other_attrs = remove_attr lb.lbattrs in - Tm_let {lbs=(false, [{lb with lbattrs=other_attrs}]); body=e'} - - | Some y -> - let other_attrs = remove_attr lb.lbattrs in - let rename = [NT(x, S.bv_to_name y)] in - let body = SS.close ([S.mk_binder y]) (SS.subst rename body) in - let lb = { lb with lbname=Inl y; lbattrs=other_attrs } in - Tm_let {lbs=(false, [lb]); body} - in - let top = {top with n = maybe_rewritten_let } in - term_as_mlexpr' g top - - | Tm_let {lbs=(is_rec, lbs); body=e'} -> - let top_level = is_top_level lbs in - let lbs, e' = - if is_rec - then SS.open_let_rec lbs e' - else if is_top_level lbs - then lbs, e' - else let lb = List.hd lbs in - let x = S.freshen_bv (left lb.lbname) in - let lb = {lb with lbname=Inl x} in - let e' = SS.subst [DB(0, x)] e' in - [lb], e' in - let lbs = - if top_level - then - let tcenv = TcEnv.set_current_module (tcenv_of_uenv g) - (Ident.lid_of_path ((fst (current_module_of_uenv g)) @ [snd (current_module_of_uenv g)]) Range.dummyRange) in - lbs |> List.map (fun lb -> - // let tcenv = TcEnv.set_current_module (tcenv_of_uenv g) - // (Ident.lid_of_path ((fst (current_module_of_uenv g)) @ [snd (current_module_of_uenv g)]) Range.dummyRange) in - // debug g (fun () -> - // BU.print1 "!!!!!!!About to normalize: %s\n" (show lb.lbdef); - // Options.set_option "debug" (Options.List [Options.String "Norm"; Options.String "Extraction"])); - let lbdef = - let norm_call () = - Profiling.profile - (fun () -> - N.normalize (Env.PureSubtermsWithinComputations::Env.Reify::extraction_norm_steps) tcenv lb.lbdef) - (Some (Ident.string_of_lid (Env.current_module tcenv))) - "FStar.Extraction.ML.Term.normalize_lb_def" - in - if !dbg_Extraction || !dbg_ExtractionNorm - then let _ = BU.print2 "Starting to normalize top-level let %s = %s\n" - (show lb.lbname) - (show lb.lbdef) - in - let a = norm_call() in - BU.print1 "Normalized to %s\n" (show a); - a - else norm_call () - in - {lb with lbdef=lbdef}) - else lbs - in - - let check_lb env (nm_sig : mlident & lb_sig) = - let (nm, (_lbname, f, (_t, (targs, polytype)), add_unit, has_c_inline, e)) = nm_sig in - let env = List.fold_left (fun env ({binder_bv=a}) -> UEnv.extend_ty env a false) env targs in - let expected_t = snd polytype in - let e, ty = check_term_as_mlexpr env e f expected_t in - let e, f = maybe_promote_effect e f expected_t in - let meta = - match f, ty with - | E_PURE, MLTY_Erased - | E_ERASABLE, MLTY_Erased -> [Erased] - | _ -> [] - in - let meta = if has_c_inline then CInline :: meta else meta in - f, {mllb_meta = meta; mllb_attrs = []; mllb_name=nm; mllb_tysc=Some polytype; mllb_add_unit=add_unit; mllb_def=e; print_typ=true} - in - let lbs = extract_lb_sig g (is_rec, lbs) in - - (* env_burn only matters for non-recursive lets and simply burns - * the let bound variable in its own definition to generate - * code that is more understandable. We only do it for OCaml, - * to not affect Karamel naming. *) - let env_body, lbs, env_burn = List.fold_right (fun lb (env, lbs, env_burn) -> - let (lbname, _, (t, (_, polytype)), add_unit, _has_c_inline, _) = lb in - let env, nm, _ = UEnv.extend_lb env lbname t polytype add_unit in - let env_burn = - if Options.codegen () <> Some Options.Krml - then UEnv.burn_name env_burn nm - else env_burn - in - env, (nm,lb)::lbs, env_burn) lbs (g, [], g) - in - - let env_def = if is_rec then env_body else env_burn in - - let lbs = lbs |> List.map (check_lb env_def) in - - let e'_rng = e'.pos in - - let e', f', t' = term_as_mlexpr env_body e' in - - let f = join_l e'_rng (f'::List.map fst lbs) in - - let is_rec = if is_rec = true then Rec else NonRec in - - with_ty_loc t' (mk_MLE_Let top_level (is_rec, List.map snd lbs) e') (Util.mlloc_of_range t.pos), f, t' - - | Tm_match {scrutinee;brs=pats} -> - let e, f_e, t_e = term_as_mlexpr g scrutinee in - let b, then_e, else_e = check_pats_for_ite pats in - let no_lift : mlexpr -> mlty -> mlexpr = fun x t -> x in - if b then - match then_e, else_e with - | Some then_e, Some else_e -> - let then_mle, f_then, t_then = term_as_mlexpr g then_e in - let else_mle, f_else, t_else = term_as_mlexpr g else_e in - let t_branch, maybe_lift = - if type_leq g t_then t_else //the types agree except for effect labels - then t_else, no_lift - else if type_leq g t_else t_then - then t_then, no_lift - else MLTY_Top, apply_obj_repr in - with_ty t_branch <| MLE_If (e, maybe_lift then_mle t_then, Some (maybe_lift else_mle t_else)), - join then_e.pos f_then f_else, - t_branch - | _ -> failwith "ITE pats matched but then and else expressions not found?" - else - let pat_t_compat, mlbranches = pats |> BU.fold_map (fun compat br -> - let pat, when_opt, branch = SS.open_branch br in - let env, p, pat_t_compat = extract_pat g pat t_e term_as_mlexpr in - let when_opt, f_when = match when_opt with - | None -> None, E_PURE - | Some w -> - let w_pos = w.pos in - let w, f_w, t_w = term_as_mlexpr env w in - let w = maybe_coerce w_pos env w t_w ml_bool_ty in - Some w, f_w in - let mlbranch, f_branch, t_branch = term_as_mlexpr env branch in - //Printf.printf "Extracted %s to %A\n" (Print.exp_to_string branch) mlbranch; - compat&&pat_t_compat, - p |> List.map (fun (p, wopt) -> - let when_clause = conjoin_opt wopt when_opt in - p, (when_clause, f_when), (mlbranch, f_branch, t_branch))) - true in - let mlbranches : list (mlpattern & (option mlexpr & e_tag) & (mlexpr & e_tag & mlty)) - = List.flatten mlbranches in - //if the type of the pattern isn't compatible with the type of the scrutinee - // insert a magic around the scrutinee - let e = if pat_t_compat - then e - else (debug g (fun _ -> BU.print2 "Coercing scrutinee %s from type %s because pattern type is incompatible\n" - (Code.string_of_mlexpr (current_module_of_uenv g) e) - (Code.string_of_mlty (current_module_of_uenv g) t_e)); - with_ty t_e <| MLE_Coerce (e, t_e, MLTY_Top)) in - begin match mlbranches with - | [] -> - let ({exp_b_expr=fw}) = UEnv.lookup_fv t.pos g (S.lid_as_fv (PC.failwith_lid()) None) in - with_ty ml_int_ty <| MLE_App(fw, [with_ty ml_string_ty <| MLE_Const (MLC_String "unreachable")]), - E_PURE, - ml_int_ty - - - | (_, _, (_, f_first, t_first))::rest -> - let topt, f_match = List.fold_left (fun (topt, f) (_, _, (_, f_branch, t_branch)) -> - //WARNING WARNING WARNING - //We're explicitly excluding the effect of the when clause in the net effect computation - //TODO: fix this when we handle when clauses fully! - let f = join top.pos f f_branch in - let topt = match topt with - | None -> None - | Some t -> - //we just use the environment g here, since it is only needed for delta unfolding - //which is invariant across the branches - if type_leq g t t_branch - then Some t_branch - else if type_leq g t_branch t - then Some t - else None in - topt, f) - (Some t_first, f_first) - rest in - let mlbranches = mlbranches |> List.map (fun (p, (wopt, _), (b, _, t)) -> - let b = match topt with - | None -> -// Printf.printf "Apply obj repr to %A and %A\n" b t; - apply_obj_repr b t - | Some _ -> b in - (p, wopt, b)) in - let t_match = match topt with - | None -> MLTY_Top - | Some t -> t in - with_ty t_match <| MLE_Match(e, mlbranches), f_match, t_match - end - -let ind_discriminator_body env (discName:lident) (constrName:lident) : mlmodule1 = - // First, lookup the original (F*) type to figure out how many implicit arguments there are. - let _, fstar_disc_type = fst <| TypeChecker.Env.lookup_lid (tcenv_of_uenv env) discName in - let g, wildcards = match (SS.compress fstar_disc_type).n with - | Tm_arrow {bs=binders} -> - let binders = - binders - |> List.filter (function ({binder_qual=Some (Implicit _)}) -> true | _ -> false) - in - List.fold_right - (fun _ (g, vs) -> - let g, v = UEnv.new_mlident g in - g, ((v, MLTY_Top) :: vs)) - binders - (env, []) - | _ -> - failwith "Discriminator must be a function" - in - // Unfortunately, looking up the constructor name in the environment would give us a _curried_ type. - // So, we don't bother popping arrows until we find the return type of the constructor. - // We just use Top. - let g, mlid = UEnv.new_mlident g in - let targ = MLTY_Top in - // Ugly hack: we don't know what to put in there, so we just write a dummy - // polymorphic value to make sure that the type is not printed. - let disc_ty = MLTY_Top in - let discrBody = - let bs = - wildcards @ [(mlid, targ)] - |> List.map (fun (x,t) -> {mlbinder_name=x;mlbinder_ty=t;mlbinder_attrs=[]}) in - with_ty disc_ty <| - MLE_Fun(bs, - with_ty ml_bool_ty <| - (MLE_Match(with_ty targ <| MLE_Name([], mlid), - // Note: it is legal in OCaml to write [Foo _] for a constructor with zero arguments, so don't bother. - [MLP_CTor(mlpath_of_lident g constrName, [MLP_Wild]), - None, - with_ty ml_bool_ty <| MLE_Const(MLC_Bool true); - - MLP_Wild, - None, - with_ty ml_bool_ty <| MLE_Const(MLC_Bool false)]))) - in - let _, name = mlpath_of_lident env discName in - MLM_Let (NonRec, - [{ mllb_meta=[]; - mllb_attrs=[]; - mllb_name=name; - mllb_tysc=None; - mllb_add_unit=false; - mllb_def=discrBody; - print_typ=false}] ) |> mk_mlmodule1 diff --git a/src/extraction/FStar.Extraction.ML.Term.fsti b/src/extraction/FStar.Extraction.ML.Term.fsti deleted file mode 100644 index 2e97091090b..00000000000 --- a/src/extraction/FStar.Extraction.ML.Term.fsti +++ /dev/null @@ -1,29 +0,0 @@ -(* - Copyright 2008-2017 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the Licens - You may obtain a copy of the License at - - http://www.apachorg/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the Licens -*) -module FStar.Extraction.ML.Term -open FStar.Pervasives -open FStar.Extraction.ML.UEnv -open FStar.Ident -open FStar.Syntax.Syntax -open FStar.Extraction.ML.Syntax - -val normalize_abs: term -> term -val normalize_for_extraction (env:uenv) (e:term) : term -val is_arity: uenv -> term -> bool -val ind_discriminator_body : env:uenv -> discName:lident -> constrName:lident -> mlmodule1 -val term_as_mlty: uenv -> term -> mlty -val term_as_mlexpr: uenv -> term -> mlexpr & e_tag & mlty -val extract_lb_iface : uenv -> letbindings -> uenv & list (fv & exp_binding) diff --git a/src/extraction/FStar.Extraction.ML.UEnv.fst b/src/extraction/FStar.Extraction.ML.UEnv.fst deleted file mode 100644 index 605d37b6cb4..00000000000 --- a/src/extraction/FStar.Extraction.ML.UEnv.fst +++ /dev/null @@ -1,641 +0,0 @@ -(* - Copyright 2008-2020 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Extraction.ML.UEnv - -(** This module provides a typing environment used for extracting - programs to ML. It addresses the following main concerns: - - It distinguishes between several kinds of names: - - local type variable ('a, 'b, ...) - - type definition (list, option, ...) - - local variable (x, y, ...) - - top-level names (List.map, ...) - - record field names - - module names - - For each kind, it supports generating an OCaml/F# compatible name - respecting the naming and keyword conventions of those languages. - - Further, for each F* name of a given kind (except for module - names), it generates a unique name in a scope for that kind. - - See tests/bug-reports/Bug310.fst for several examples of the - kinds of concerns this addresses. - *) - -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.Compiler.Util -open FStar.Ident -open FStar.Extraction.ML.Syntax -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.TypeChecker -module U = FStar.Syntax.Util -module BU = FStar.Compiler.Util -module Const = FStar.Parser.Const - -open FStar.Class.Show - -(**** Type definitions *) - -(** A top-level F* type definition, i.e., a type abbreviation, - corresponds to a [tydef] in ML. - - Note, inductive types (e.g., list, option etc.) are separately - tracked as [tyname], see below. - - - [fv] The source F* identifier - - [tydef_mlmodule_name, tydef_name] An mlpath for [fv] - - [tydef_def]: The definition of the abbreviation - *) -type tydef = { - tydef_fv:fv; - tydef_mlmodule_name:list mlsymbol; - tydef_name:mlsymbol; - tydef_meta:FStar.Extraction.ML.Syntax.metadata; - tydef_def:mltyscheme -} - -(** tydef is abstract: Some accessors *) -let tydef_fv (td : tydef) = td.tydef_fv -let tydef_meta (td : tydef) = td.tydef_meta -let tydef_def (td : tydef) = td.tydef_def -let tydef_mlpath (td : tydef) : mlpath = td.tydef_mlmodule_name, td.tydef_name - -(** The main type of this module; it's abstract - - - [env_tcenv]: The underlying typechecker environment - - [env_bindings]: names in scope associated with their types - - [env_mlident_map]: The set of names used in the current scope (for freshness) - - [mlpath_of_lid]: A map from a full F* lident to its corresponding mlpath - - [env_fieldname_map]: The set of record field names used in the current in scope (for freshness) - - [mlpath_of_fieldname]: A map from a full F* record field identifier to its corresponding mlpath - - [tydefs]: Type abbreviations in scope - - [type_names]: Inductive type constructors in scope - - [currentModule]: ML name of the current module being extracted - *) -type uenv = { - env_tcenv:TypeChecker.Env.env; - env_bindings:list binding; - env_mlident_map:psmap mlident; - env_remove_typars:RemoveUnusedParameters.env_t; - mlpath_of_lid:psmap mlpath; - env_fieldname_map:psmap mlident; - mlpath_of_fieldname:psmap mlpath; - tydefs:list tydef; - type_names:list (fv&mlpath); - tydef_declarations:psmap bool; - currentModule: mlpath // needed to properly translate the definitions in the current file -} - -(**** Getters and Setters *) - -let tcenv_of_uenv (u:uenv) : TypeChecker.Env.env = u.env_tcenv -let set_tcenv (u:uenv) (t:TypeChecker.Env.env) = { u with env_tcenv=t} -let current_module_of_uenv (u:uenv) : mlpath = u.currentModule -let set_current_module (u:uenv) (m:mlpath) : uenv = { u with currentModule = m } -let with_typars_env (u:uenv) (f:_) = - let e, x = f u.env_remove_typars in - {u with env_remove_typars=e}, x - -(**** Debugging *) - -// Only for debug printing in Modul.fs -let bindings_of_uenv u = u.env_bindings - -let dbg = Debug.get_toggle "Extraction" -let debug g f = - let c = string_of_mlpath g.currentModule in - if !dbg - then f () - -let print_mlpath_map (g:uenv) = - let string_of_mlpath mlp = - String.concat "." (fst mlp) ^ "." ^ (snd mlp) - in - let entries = - BU.psmap_fold g.mlpath_of_lid (fun key value entries -> - BU.format2 "%s -> %s" key (string_of_mlpath value) :: entries) [] - in - String.concat "\n" entries - -(**** Constructors *) - - -(**** Looking up identifiers *) - -(** Scans the list of bindings for an fv: - - it's always mapped to an ML expression - Takes a range for error reporting. - *) - -// Inr b: success -// Inl true: was erased -// Inl false: not found -let lookup_fv_generic (g:uenv) (fv:fv) : either bool exp_binding = - let v = - BU.find_map g.env_bindings - (function - | Fv (fv', t) when fv_eq fv fv' -> Some (Inr t) - | ErasedFv fv' when fv_eq fv fv' -> Some (Inl true) - | _ -> None) - in - match v with - | Some r -> r - | None -> Inl false - -let try_lookup_fv (r:Range.range) (g:uenv) (fv:fv) : option exp_binding = - match lookup_fv_generic g fv with - | Inr r -> Some r - | Inl true -> - (* Log an error/warning and return None *) - let open FStar.Errors.Msg in - Errors.log_issue r Errors.Error_CallToErased [ - text <| BU.format1 "Will not extract reference to variable `%s` since it has the `noextract` qualifier." (show fv); - text <| "Either remove its qualifier or add it to this definition."; - text <| BU.format1 "This error can be ignored with `--warn_error -%s`." (string_of_int Errors.call_to_erased_errno)]; - None - | Inl false -> - None - -(** Fatal failure version of try_lookup_fv *) -let lookup_fv (r:Range.range) (g:uenv) (fv:fv) : exp_binding = - match lookup_fv_generic g fv with - | Inr t -> t - | Inl b -> - failwith (BU.format3 "Internal error: (%s) free variable %s not found during extraction (erased=%s)\n" - (Range.string_of_range fv.fv_name.p) - (show fv.fv_name.v) - (string_of_bool b)) - -(** An F* local variable (bv) can be mapped either to - a ML type variable or a term variable *) -let lookup_bv (g:uenv) (bv:bv) : ty_or_exp_b = - let x = - BU.find_map g.env_bindings - (function - | Bv (bv', r) when bv_eq bv bv' -> Some r - | _ -> None) - in - match x with - | None -> - failwith (BU.format2 "(%s) bound Variable %s not found\n" - (Range.string_of_range (range_of_id bv.ppname)) - (show bv)) - | Some y -> y - -(** Lookup either a local variable or a top-level name *) -let lookup_term g (t:term) = - match t.n with - | Tm_name x -> lookup_bv g x, None - | Tm_fvar x -> Inr (lookup_fv t.pos g x), x.fv_qual - | _ -> failwith "Impossible: lookup_term for a non-name" - -(** Lookup an local variable mapped to a ML type variable *) -let lookup_ty (g:uenv) (x:bv) : ty_binding = - match lookup_bv g x with - | Inl ty -> ty - | _ -> failwith "Expected a type name" - -(** Lookup a type abbreviation *) -let lookup_tydef (env:uenv) ((module_name, ty_name):mlpath) - : option mltyscheme - = BU.find_map env.tydefs (fun tydef -> - if ty_name = tydef.tydef_name - && module_name = tydef.tydef_mlmodule_name - then Some tydef.tydef_def - else None) - -let has_tydef_declaration (u:uenv) (l:lid) = - match BU.psmap_try_find u.tydef_declarations (Ident.string_of_lid l) with - | None -> false - | Some b -> b - -(** Given an F* qualified name, find its ML counterpart *) -let mlpath_of_lident (g:uenv) (x:lident) : mlpath = - match BU.psmap_try_find g.mlpath_of_lid (string_of_lid x) with - | None -> - debug g (fun _ -> - BU.print1 "Identifier not found: %s" (string_of_lid x); - BU.print1 "Env is \n%s\n" (print_mlpath_map g)); - failwith ("Identifier not found: " ^ string_of_lid x) - | Some mlp -> mlp - -(** Is [fv] the name of an F* inductive type? *) -let is_type_name g fv = - g.type_names |> - BU.for_some (fun (x, _) -> fv_eq fv x) - -(** Is [fv] the name of an F* inductive type or type abbreviation? *) -let is_fv_type g fv = - is_type_name g fv || - g.tydefs |> BU.for_some (fun tydef -> fv_eq fv tydef.tydef_fv) - -let no_fstar_stubs_ns (ns : list mlsymbol) : list mlsymbol = - match ns with - | "FStar"::"Stubs"::rest -> "FStar"::rest - | _ -> ns - -let no_fstar_stubs (p : mlpath) : mlpath = - let ns, id = p in - let ns = no_fstar_stubs_ns ns in - ns, id - -(** Find the ML counterpart of an F* record field identifier - - - F* Record field names are pairs of a fully qualified *type* name - and the short field name - - - In ML, the record field name is unique for a given namespace - (i.e., unique per F* module) - - In extend_record_field_name we associate a module-level unique ML - fieldname with the [(type_name, fn)] pair. - *) -let lookup_record_field_name g (type_name, fn) = - let key = Ident.lid_of_ids (ids_of_lid type_name @ [fn]) in - match BU.psmap_try_find g.mlpath_of_fieldname (string_of_lid key) with - | None -> failwith ("Field name not found: " ^ string_of_lid key) - | Some mlp -> - let ns, id = mlp in - List.filter (fun s -> s <> "Stubs") ns, id - -(**** Naming conventions and freshness (internal) *) - -(** The initial map of used identifiers is populated - with the keyword list of the target language. - - That ensures that any name we generate doesn't clash - with those keywords - *) -let initial_mlident_map = - let map = BU.mk_ref None in - fun () -> - match !map with - | Some m -> m - | None -> - let m = - List.fold_right - (fun x m -> BU.psmap_add m x "") - (match Options.codegen() with - | Some Options.FSharp -> fsharpkeywords - | Some Options.OCaml - | Some Options.Plugin -> ocamlkeywords - | Some Options.Krml -> krml_keywords - | Some Options.Extension -> [] // TODO - | None -> []) - (BU.psmap_empty()) - in - map := Some m; - m - -(** Enforces naming conventions for indentifiers of term and (local) - type variables: - - - Term variables - - must be sequences of letters, digits, _ and ', - - must beginning with letter or _ - - any other invalid character is replaced with __ - - - Type variables - - must begin with a ' - - their second character cannot be "_" (since that's a weak type variable in OCaml) - - rest of their characters are letter or digit or underscore (no further ' allowed) - - any other invalid character is replaced with 'u' (not _, since - that could introduce a weak type variable) - *) -let rename_conventional (s:string) (is_local_type_variable:bool) : string = - let cs = FStar.String.list_of_string s in - let sanitize_typ () = - let valid_rest c = BU.is_letter_or_digit c in - let aux cs = List.map (fun x -> if valid_rest x then x else 'u') cs in - if List.hd cs = '\'' then List.hd cs :: aux (List.tail cs) - else '\'' :: aux cs - in - let sanitize_term () = - let valid c = BU.is_letter_or_digit c || c = '_' || c = '\'' in - let cs' = List.fold_right (fun c cs -> (if valid c then [c] else ['_';'_'])@cs) cs [] in - match cs' with - | (c::cs) when BU.is_digit c || c = '\'' -> - '_'::c::cs - | _ -> cs - in - FStar.String.string_of_list - (if is_local_type_variable then sanitize_typ() else sanitize_term()) - -(** The root name of a F* local variable, adapted for conventions, is - a prefix of this name in ML, - - It is either the [ppname] (pretty-printing name) - Or, in case the [ppname] is unset, it's the unique name in F* *) -let root_name_of_bv (x:bv): mlident = - if BU.starts_with (string_of_id x.ppname) Ident.reserved_prefix - || is_null_bv x - then Ident.reserved_prefix - else string_of_id x.ppname - -(** Given a candidate root_name, generate an ML identifier - for it that is unique in the current scope. - - By, - - rewriting it to enforce naming conventions - - - and then appending a numeric suffix in case it clashes with - some variable in scope - *) -let find_uniq ml_ident_map root_name is_local_type_variable = - let rec aux i root_name = - let target_mlident = if i = 0 then root_name else root_name ^ (string_of_int i) in - match BU.psmap_try_find ml_ident_map target_mlident with - | Some x -> aux (i+1) root_name - | None -> - let map = BU.psmap_add ml_ident_map target_mlident "" in - target_mlident, map - in - let mlident = rename_conventional root_name is_local_type_variable in - if is_local_type_variable - then let nm, map = aux 0 (BU.substring_from mlident 1) in - "'" ^ nm, map - else aux 0 mlident - -(** The ML namespace corresponding to an F* qualified name - is just all the identifiers in the F* namespace (as strings) *) -let mlns_of_lid (x:lident) = - List.map string_of_id (ns_of_lid x) |> no_fstar_stubs_ns - - -(**** Extending context with identifiers *) - -(** A new [mlpath] for an F* qualified name [x]: - - It's short name (i.e., the last element of [x]) is unique for the - current scope and subsequent names in the scope will not clash - with it. - - E.g., given - {[ - module A - let id = 0 - let foo (id:int) = id - ]} - - we'll generate [id] for the top-level name - and then [id1] for the local variable -*) -let new_mlpath_of_lident (g:uenv) (x : lident) : mlpath & uenv = - let mlp, g = - if Ident.lid_equals x (FStar.Parser.Const.failwith_lid()) - then ([], string_of_id (ident_of_lid x)), g - else let name, map = find_uniq g.env_mlident_map (string_of_id (ident_of_lid x)) false in - let g = { g with env_mlident_map = map } in - (mlns_of_lid x, name), g - in - let g = { g with - mlpath_of_lid = BU.psmap_add g.mlpath_of_lid (string_of_lid x) mlp - } in - mlp, g - -(** Extending the context with an F* type variable - - - If [map_to_top] is set, then this variable gets mapped to unit in - ML, so it is not always a type variable in ML - *) -let extend_ty (g:uenv) (a:bv) (map_to_top:bool) : uenv = - let is_local_type_variable = not map_to_top in - let ml_a, mlident_map = find_uniq g.env_mlident_map (root_name_of_bv a) is_local_type_variable in - let mapped_to = - if map_to_top - then MLTY_Top - else MLTY_Var ml_a - in - let gamma = Bv(a, Inl ({ty_b_name=ml_a; ty_b_ty=mapped_to}))::g.env_bindings in - let tcenv = TypeChecker.Env.push_bv g.env_tcenv a in - {g with env_bindings=gamma; env_mlident_map=mlident_map; env_tcenv=tcenv} - -(** Extending the context with a local term variable - - [add_unit] is set if the variable should be forced on each use - - [is_rec] if the variable is bound to a local recursive definition - - [mk_unit] if every use of the variable to be erased to [()] - *) -let extend_bv (g:uenv) (x:bv) (t_x:mltyscheme) (add_unit:bool) - (mk_unit:bool (*some pattern terms become unit while extracting*)) - : uenv - & mlident - & exp_binding = - let ml_ty = match t_x with - | ([], t) -> t - | _ -> MLTY_Top in - let mlident, mlident_map = find_uniq g.env_mlident_map (root_name_of_bv x) false in - let mlx = MLE_Var mlident in - let mlx = if mk_unit - then ml_unit - else if add_unit - then with_ty MLTY_Top <| MLE_App(with_ty MLTY_Top mlx, [ml_unit]) - else with_ty ml_ty mlx in - let eff, t_x = if add_unit then pop_unit t_x else E_PURE, t_x in - let exp_binding = {exp_b_name=mlident; exp_b_expr=mlx; exp_b_tscheme=t_x; exp_b_eff=eff } in - let gamma = Bv(x, Inr exp_binding)::g.env_bindings in - let tcenv = TypeChecker.Env.push_binders g.env_tcenv (binders_of_list [x]) in - {g with env_bindings=gamma; env_mlident_map = mlident_map; env_tcenv=tcenv}, mlident, exp_binding - -let burn_name (g:uenv) (i:mlident) : uenv = - { g with env_mlident_map = BU.psmap_add g.env_mlident_map i "" } - -(** Generating a fresh local term variable *) -let new_mlident (g:uenv) - : uenv & mlident - = let ml_ty = MLTY_Top in - let x = FStar.Syntax.Syntax.new_bv None FStar.Syntax.Syntax.tun in - let g, id, _ = extend_bv g x ([], MLTY_Top) false false in - g, id - -(** Similar to [extend_bv], except for top-level term identifiers *) -let extend_fv (g:uenv) (x:fv) (t_x:mltyscheme) (add_unit:bool) - : uenv - & mlident - & exp_binding = - let rec mltyFvars (t: mlty) : list mlident = - match t with - | MLTY_Var x -> [x] - | MLTY_Fun (t1, f, t2) -> List.append (mltyFvars t1) (mltyFvars t2) - | MLTY_Named(args, path) -> List.collect mltyFvars args - | MLTY_Tuple ts -> List.collect mltyFvars ts - | MLTY_Top - | MLTY_Erased -> [] - in - let rec subsetMlidents (la : list mlident) (lb : list mlident) : bool = - match la with - | h::tla -> List.contains h lb && subsetMlidents tla lb - | [] -> true - in - let tySchemeIsClosed (tys : mltyscheme) : bool = - subsetMlidents (mltyFvars (snd tys)) (tys |> fst |> ty_param_names) - in - if tySchemeIsClosed t_x - then - let ml_ty = match t_x with - | ([], t) -> t - | _ -> MLTY_Top in - let mlpath, g = new_mlpath_of_lident g x.fv_name.v in - let mlsymbol = snd mlpath in - let mly = MLE_Name mlpath in - let mly = if add_unit then with_ty MLTY_Top <| MLE_App(with_ty MLTY_Top mly, [ml_unit]) else with_ty ml_ty mly in - let eff, t_x = if add_unit then pop_unit t_x else E_PURE, t_x in - let exp_binding = {exp_b_name=mlsymbol; exp_b_expr=mly; exp_b_tscheme=t_x; exp_b_eff=eff } in - let gamma = Fv(x, exp_binding)::g.env_bindings in - let mlident_map = BU.psmap_add g.env_mlident_map mlsymbol "" in - {g with env_bindings=gamma; env_mlident_map=mlident_map}, mlsymbol, exp_binding - else failwith (BU.format1 "freevars found (%s)" (mltyscheme_to_string t_x)) - -let extend_erased_fv (g:uenv) (f:fv) : uenv = - { g with env_bindings = ErasedFv f :: g.env_bindings } - -(** Extend with a let binding, either local or top-level *) -let extend_lb (g:uenv) (l:lbname) (t:typ) (t_x:mltyscheme) (add_unit:bool) - : uenv - & mlident - & exp_binding = - match l with - | Inl x -> - // FIXME missing in lib; NS: what does this mean?? - extend_bv g x t_x add_unit false - | Inr f -> - extend_fv g f t_x add_unit - -(** Extend with an abbreviation [fv] for the type scheme [ts] *) -let extend_tydef (g:uenv) (fv:fv) (ts:mltyscheme) (meta:FStar.Extraction.ML.Syntax.metadata) - : tydef & mlpath & uenv = - let name, g = new_mlpath_of_lident g fv.fv_name.v in - let tydef = { - tydef_fv = fv; - tydef_mlmodule_name=fst name; - tydef_name = snd name; - tydef_meta = meta; - tydef_def = ts; - } in - tydef, - name, - {g with tydefs=tydef::g.tydefs; type_names=(fv, name)::g.type_names} - -let extend_with_tydef_declaration u l = - { u with tydef_declarations = BU.psmap_add u.tydef_declarations (Ident.string_of_lid l) true } - -(** Extend with [fv], the identifer for an F* inductive type *) -let extend_type_name (g:uenv) (fv:fv) : mlpath & uenv = - let name, g = new_mlpath_of_lident g fv.fv_name.v in - name, - {g with type_names=(fv,name)::g.type_names} - - -(** The [bind] and [return] of an effect declaration - are names like field projectors *) -let extend_with_monad_op_name g (ed:Syntax.eff_decl) nm ts = - (* Extract bind and return of effects as (unqualified) projectors of that effect, *) - (* same as for actions. However, extracted code should not make explicit use of them. *) - let lid = U.mk_field_projector_name_from_ident ed.mname (id_of_text nm) in - let g, mlid, exp_b = extend_fv g (lid_as_fv lid None) ts false in - let mlp = mlns_of_lid lid, mlid in - mlp, lid, exp_b, g - -(** The actions of an effect declaration are qualified to the module - name in which they are defined. *) -let extend_with_action_name g (ed:Syntax.eff_decl) (a:Syntax.action) ts = - let nm = string_of_id (ident_of_lid a.action_name) in - let module_name = ns_of_lid ed.mname in - let lid = Ident.lid_of_ids (module_name@[Ident.id_of_text nm]) in - let g, mlid, exp_b = extend_fv g (lid_as_fv lid None) ts false in - let mlp = mlns_of_lid lid, mlid in - mlp, lid, exp_b, g - -(** Record field names are in a separate namespace in ML and cannot - clash with type names, top-level names, local identifiers etc. - - So, we maintain then in a separate map. - - We generate a unique field name associated with just the - [fn]---the generated [name] is a unique field name for the current - module. - - However, we associate this generated name with the [(type_name, - fn)] pair, and retrieve the unique ML fieldname [name] using this - pair as a key. - - This is important to avoid name clashes among record in the same - module whose fields have overlapping names. See Bug 2058 and - tests/Bug2058.fst - *) -let extend_record_field_name g (type_name, fn) = - let key = Ident.lid_of_ids (ids_of_lid type_name @ [fn]) in - let name, fieldname_map = find_uniq g.env_fieldname_map (string_of_id fn) false in - let ns = mlns_of_lid type_name in - let mlp = ns, name in - let mlp = no_fstar_stubs mlp in - let g = { g with env_fieldname_map = fieldname_map; - mlpath_of_fieldname = BU.psmap_add g.mlpath_of_fieldname (string_of_lid key) mlp } - in - name, g - - -(** Module names are in a different namespace in OCaml - and cannot clash with keywords (since they are uppercase in F* ) - or with other identifiers. - - An F* module name is mapped as is to OCaml. - When printed, instead of A.B.C, we get A_B_C *) -let extend_with_module_name (g:uenv) (m:lid) = - let ns = mlns_of_lid m in - let p = string_of_id (ident_of_lid m) in - (ns, p), g - -(** After completing the extraction of a module - we reset its uses sets so that name generation for the next module - needn't be bothered with names that were generated for prior modules - which are in a different namespace *) -let exit_module g = - { g with env_mlident_map=initial_mlident_map(); - env_fieldname_map=initial_mlident_map()} - - -(**** Constructor for a uenv *) - -let new_uenv (e:TypeChecker.Env.env) - : uenv - = let env = { - env_tcenv = e; - env_bindings =[]; - env_mlident_map=initial_mlident_map (); - env_remove_typars=RemoveUnusedParameters.initial_env; - mlpath_of_lid = BU.psmap_empty(); - env_fieldname_map=initial_mlident_map (); - mlpath_of_fieldname = BU.psmap_empty(); - tydefs =[]; - type_names=[]; - tydef_declarations = BU.psmap_empty(); - currentModule = ([], ""); - } in - (* We handle [failwith] specially, extracting it to OCaml's 'failwith' - rather than FStar.Compiler.Effect.failwith. Not sure this is necessary *) - let a = "'a" in - let failwith_ty = ([{ty_param_name=a; ty_param_attrs=[]}], - MLTY_Fun(MLTY_Named([], (["Prims"], "string")), E_IMPURE, MLTY_Var a)) in - let g, _, _ = - extend_lb env (Inr (lid_as_fv (Const.failwith_lid()) None)) tun failwith_ty false - in - g diff --git a/src/extraction/FStar.Extraction.ML.UEnv.fsti b/src/extraction/FStar.Extraction.ML.UEnv.fsti deleted file mode 100644 index a44db2a3738..00000000000 --- a/src/extraction/FStar.Extraction.ML.UEnv.fsti +++ /dev/null @@ -1,223 +0,0 @@ -(* - Copyright 2008-2020 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Extraction.ML.UEnv -open FStar.Pervasives -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.Util -open FStar.Ident -open FStar.Extraction.ML.Syntax -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.TypeChecker - -(** This module provides a typing environment used for extracting - programs to ML. - - See the implementation for more detailed descriptions. *) - - -(**** Types *) - -type ty_binding = { - ty_b_name:mlident; - ty_b_ty:mlty -} - -type exp_binding = { - exp_b_name:mlident; - exp_b_expr:mlexpr; - exp_b_tscheme:mltyscheme; - exp_b_eff: e_tag -} - -type ty_or_exp_b = either ty_binding exp_binding - -type binding = - | Bv of bv & ty_or_exp_b - | Fv of fv & exp_binding - | ErasedFv of fv - -(** Type abbreviations, aka definitions *) -val tydef : Type0 -val tydef_fv : tydef -> fv -val tydef_meta : tydef -> FStar.Extraction.ML.Syntax.metadata -val tydef_mlpath : tydef -> mlpath -val tydef_def: tydef -> mltyscheme - -(** The main type of this module *) -val uenv : Type0 -val tcenv_of_uenv : u:uenv -> TypeChecker.Env.env -val set_tcenv : u:uenv -> t:TypeChecker.Env.env -> uenv -val current_module_of_uenv : u:uenv -> mlpath -val set_current_module : u:uenv -> p:mlpath -> uenv -val with_typars_env : uenv -> (RemoveUnusedParameters.env_t -> RemoveUnusedParameters.env_t & 'a) -> uenv & 'a - -(** Debugging only *) -val bindings_of_uenv : uenv -> list binding -val debug: g:uenv -> f:(unit -> unit) -> unit - -(** Constructor *) -val new_uenv : e:TypeChecker.Env.env -> uenv - -(*** Looking up identifiers *) - -(** Lookup a top-level term identifier. Raises an error/warning when the -FV has been erased, using the given range. *) -val try_lookup_fv: Range.range -> g:uenv -> fv:fv -> option exp_binding - -(* As above, but will abort if the variable is not found or was erased. -Only use this for variables that must be in the environment, such as -definitions in Prims. *) -val lookup_fv: Range.range -> g:uenv -> fv:fv -> exp_binding - -(** Lookup a local term or type variable *) -val lookup_bv: g:uenv -> bv: bv -> ty_or_exp_b - -(** Lookup a top-level term or local type variable *) -val lookup_term: g:uenv -> t:term -> ty_or_exp_b & option fv_qual - -(** Lookup a type variable *) -val lookup_ty: g:uenv -> bv:bv -> ty_binding - -(** Lookup a type definition *) -val lookup_tydef : uenv -> mlpath -> option mltyscheme - -(** Does a type definition have an accompanying `val` declaration? *) -val has_tydef_declaration : uenv -> lident -> bool - -(** ML qualified name corresponding to an F* qualified name *) -val mlpath_of_lident : uenv -> lident -> mlpath - -(** Does the fv bind an F* inductive type? *) -val is_type_name : g:uenv -> fv:fv -> bool - -(** Does the fv bind an F* inductive type or abbreviation? *) -val is_fv_type: uenv -> fv -> bool - -(** ML record name for an F* pair of type name and field name *) -val lookup_record_field_name: uenv -> (lident & ident) -> mlpath - -(*** Extending environment *) - - -(** Fresh local identifer *) -val new_mlident : g:uenv -> uenv & mlident - -(** Extend with a type variable, potentially erased to MLTY_Top *) -val extend_ty: g:uenv -> a:bv -> map_to_top:bool -> uenv - -(** Extend with a local term variable, maybe thunked, maybe erased *) -val extend_bv: - uenv -> - bv -> - mltyscheme -> - add_unit: bool -> - mk_unit: bool -> - uenv & mlident & exp_binding - -(** Make sure a given ML name is not used in an environment. The -scope of the environment is not changed at all. This can be used to -generate less confusing names, for instance, in `let x = E in F`, we can -burn `x` in `E` to avoid generating code like `let x = let x = 1 in x in -x`, which does not have any shadowing, but is hard to read. Of course, -`x` is burnt in `F` since it is in-scope there. *) -val burn_name: - uenv -> - mlident -> - uenv - -(** Extend with an top-level term identifier, maybe thunked *) -val extend_fv: - uenv -> - fv -> - mltyscheme -> - add_unit:bool -> - uenv & mlident & exp_binding - -(** Extend the fv environment by marking that a variable was erased. *) -val extend_erased_fv: - uenv -> - fv -> - uenv - -(** Extend with a local or top-level let binding, maybe thunked *) -val extend_lb: - uenv -> - l:lbname -> - t:typ -> - t_x:mltyscheme -> - add_unit:bool -> - uenv & mlident & exp_binding - -(** Extend with a type abbreviation *) -val extend_tydef: - uenv -> - fv -> - mltyscheme -> - FStar.Extraction.ML.Syntax.metadata -> - tydef & mlpath & uenv - -(** This identifier is for the declaration of a type `val t _ : Type` - We record it in the environment to control later if we are - allows to remove unused type parameters in the definition of `t`. **) -val extend_with_tydef_declaration: - uenv -> - lident -> - uenv - -(** Extend with an inductive type *) -val extend_type_name: - uenv -> - fv -> - mlpath & uenv - -(** Extend with a [bind] or [return], - returns both the ML identifier and the generated F* lid for it *) -val extend_with_monad_op_name: - uenv -> - Syntax.eff_decl -> - string -> (* name of the op *) - mltyscheme -> - mlpath & lident & exp_binding & uenv - -(** Extend with an action, returns both the ML identifer and generated F* lident *) -val extend_with_action_name: - uenv -> - Syntax.eff_decl -> - Syntax.action -> - mltyscheme -> - mlpath & lident & exp_binding & uenv - -(** The F* record field identifier is a pair of the *typename* and the field name *) -val extend_record_field_name : - uenv -> - (lident & ident) -> - mlident & uenv - -(** ML module identifier for an F* module name *) -val extend_with_module_name : - uenv -> - lident -> - mlpath & uenv - -(** Mark exiting a module scope *) -val exit_module : uenv -> uenv - -val no_fstar_stubs : mlpath -> mlpath -val no_fstar_stubs_ns : list mlsymbol -> list mlsymbol diff --git a/src/extraction/FStar.Extraction.ML.Util.fst b/src/extraction/FStar.Extraction.ML.Util.fst deleted file mode 100644 index 45dc81e1a07..00000000000 --- a/src/extraction/FStar.Extraction.ML.Util.fst +++ /dev/null @@ -1,404 +0,0 @@ -(* - Copyright 2008-2015 Abhishek Anand, Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Extraction.ML.Util -open Prims -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.Compiler.Util -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.Syntax.Embeddings -open FStar.Extraction.ML -open FStar.Extraction.ML.Syntax -open FStar.Const -open FStar.Ident -open FStar.Errors -module BU = FStar.Compiler.Util -module U = FStar.Syntax.Util -module UEnv = FStar.Extraction.ML.UEnv -module PC = FStar.Parser.Const -module Range = FStar.Compiler.Range -module S = FStar.Syntax.Syntax -module N = FStar.TypeChecker.Normalize -module Env = FStar.TypeChecker.Env - -open FStar.Class.Show - -let codegen_fsharp () = Options.codegen () = Some Options.FSharp - -let pruneNones (l : list (option 'a)) : list 'a = - List.fold_right (fun x ll -> match x with - | Some xs -> xs::ll - | None -> ll) l [] - - -let mk_range_mle = with_ty MLTY_Top <| MLE_Name (["FStar"; "Range"], "mk_range") -let dummy_range_mle = with_ty MLTY_Top <| MLE_Name (["FStar"; "Range"], "dummyRange") - -(* private *) -let mlconst_of_const' (sctt : sconst) = - match sctt with - | Const_effect -> failwith "Unsupported constant" - - | Const_range _ - | Const_unit -> MLC_Unit - | Const_char c -> MLC_Char c - | Const_int (s, i) -> MLC_Int (s, i) - | Const_bool b -> MLC_Bool b - | Const_string (s, _) -> MLC_String (s) - - | Const_range_of - | Const_set_range_of -> - failwith "Unhandled constant: range_of/set_range_of" - - | Const_real _ - | Const_reify _ - | Const_reflect _ -> - failwith "Unhandled constant: real/reify/reflect" - -let mlconst_of_const (p:Range.range) (c:sconst) = - try mlconst_of_const' c - with _ -> failwith (BU.format2 "(%s) Failed to translate constant %s " (Range.string_of_range p) (show c)) - -let mlexpr_of_range (r:Range.range) : mlexpr' = - let cint (i : int) : mlexpr = - MLC_Int (string_of_int i, None) |> MLE_Const |> with_ty ml_int_ty - in - let cstr (s : string) : mlexpr = - MLC_String s |> MLE_Const |> with_ty ml_string_ty - in - let drop_path = BU.basename in - - // This is not being fully faithful since it disregards - // the use_range, but I assume that's not too bad. - // - // We drop the path of the file to be independent of the machine - // where this was extracted. Otherwise we run into some headaches - // with CI, stability, and moving ml files between hosts. The idea - // is that the pathless filename is enough to locate the actual file, - // since it must have been loaded as a dependency by F*. - MLE_App (mk_range_mle, [Range.file_of_range r |> drop_path |> cstr; - Range.start_of_range r |> Range.line_of_pos |> cint; - Range.start_of_range r |> Range.col_of_pos |> cint; - Range.end_of_range r |> Range.line_of_pos |> cint; - Range.end_of_range r |> Range.col_of_pos |> cint; - ]) - -let mlexpr_of_const (p:Range.range) (c:sconst) : mlexpr' = - (* Special case ranges, which can be extracted but not as constants. - * Maybe a sign that there shouldn't really be a Const_range *) - match c with - | Const_range r -> - mlexpr_of_range r - - | _ -> - MLE_Const (mlconst_of_const p c) - -let rec subst_aux (subst:list (mlident & mlty)) (t:mlty) : mlty = - match t with - | MLTY_Var x -> (match BU.find_opt (fun (y, _) -> y=x) subst with - | Some ts -> snd ts - | None -> t) // TODO : previously, this case would abort. why? this case was encountered while extracting st3.fst - | MLTY_Fun (t1, f, t2) -> MLTY_Fun(subst_aux subst t1, f, subst_aux subst t2) - | MLTY_Named(args, path) -> MLTY_Named(List.map (subst_aux subst) args, path) - | MLTY_Tuple ts -> MLTY_Tuple(List.map (subst_aux subst) ts) - | MLTY_Top - | MLTY_Erased -> t - -let try_subst ((formals, t):mltyscheme) (args:list mlty) : option mlty = - if List.length formals <> List.length args - then None - else Some (subst_aux (List.zip (ty_param_names formals) args) t) - -let subst ts args = - match try_subst ts args with - | None -> - failwith "Substitution must be fully applied (see GitHub issue #490)" - | Some t -> - t - -let udelta_unfold (g:UEnv.uenv) = function - | MLTY_Named(args, n) -> - begin match UEnv.lookup_tydef g n with - | Some ts -> - begin - match try_subst ts args with - | None -> - failwith (BU.format3 "Substitution must be fully applied; got an application of %s with %s args whereas %s were expected (see GitHub issue #490)" - (string_of_mlpath n) - (BU.string_of_int (List.length args)) - (BU.string_of_int (List.length (fst ts)))) - | Some r -> Some r - end - | _ -> None - end - | _ -> None - -let eff_leq f f' = match f, f' with - | E_PURE, _ -> true - | E_ERASABLE, E_ERASABLE -> true - | E_IMPURE, E_IMPURE -> true - | _ -> false - -let eff_to_string = function - | E_PURE -> "Pure" - | E_ERASABLE -> "Erasable" - | E_IMPURE -> "Impure" - -let join r f f' = match f, f' with - | E_IMPURE, E_PURE - | E_PURE , E_IMPURE - | E_IMPURE, E_IMPURE -> E_IMPURE - | E_ERASABLE , E_ERASABLE -> E_ERASABLE - | E_PURE , E_ERASABLE -> E_ERASABLE - | E_ERASABLE , E_PURE -> E_ERASABLE - | E_PURE , E_PURE -> E_PURE - | _ -> failwith (BU.format3 "Impossible (%s): Inconsistent effects %s and %s" - (Range.string_of_range r) - (eff_to_string f) (eff_to_string f')) - -let join_l r fs = List.fold_left (join r) E_PURE fs - -let mk_ty_fun = List.fold_right (fun {mlbinder_ty} t -> MLTY_Fun(mlbinder_ty, E_PURE, t)) - -(* type_leq is essentially the lifting of the sub-effect relation, eff_leq, into function types. - type_leq_c is a coercive variant of type_leq, which implements an optimization to erase the bodies of ghost functions. - Specifically, a function (f : t -> Pure t') can be subsumed to (t -> Ghost t') - In the case where f is a function literal, \x. e, subsuming it to (t -> Ghost t') means that we can simply - erase e to unit right away. -*) -let rec type_leq_c (unfold_ty:unfold_t) (e:option mlexpr) (t:mlty) (t':mlty) : (bool & option mlexpr) = - match t, t' with - | MLTY_Var x, MLTY_Var y -> - if x = y - then true, e - else false, None - - | MLTY_Fun (t1, f, t2), MLTY_Fun (t1', f', t2') -> - let mk_fun xs body = - match xs with - | [] -> body - | _ -> - let e = match body.expr with - | MLE_Fun(ys, body) -> MLE_Fun(xs@ys, body) - | _ -> MLE_Fun(xs, body) in - with_ty (mk_ty_fun xs body.mlty) e in - begin match e with - | Some ({expr=MLE_Fun(x::xs, body)}) -> - if type_leq unfold_ty t1' t1 - && eff_leq f f' - then if f=E_PURE - && f'=E_ERASABLE - then if type_leq unfold_ty t2 t2' - then let body = if type_leq unfold_ty t2 ml_unit_ty - then ml_unit - else with_ty t2' <| MLE_Coerce(ml_unit, ml_unit_ty, t2') in - true, Some (with_ty (mk_ty_fun [x] body.mlty) <| MLE_Fun([x], body)) - else false, None - else let ok, body = type_leq_c unfold_ty (Some <| mk_fun xs body) t2 t2' in - let res = match body with - | Some body -> Some (mk_fun [x] body) - | _ -> None in - ok, res - else false, None - - | _ -> - if type_leq unfold_ty t1' t1 - && eff_leq f f' - && type_leq unfold_ty t2 t2' - then true, e - else false, None - end - - | MLTY_Named(args, path), MLTY_Named(args', path') -> - if path=path' - then if List.forall2 (type_leq unfold_ty) args args' - then true, e - else false, None - else begin match unfold_ty t with - | Some t -> type_leq_c unfold_ty e t t' - | None -> (match unfold_ty t' with - | None -> false, None - | Some t' -> type_leq_c unfold_ty e t t') - end - - | MLTY_Tuple ts, MLTY_Tuple ts' -> - if List.forall2 (type_leq unfold_ty) ts ts' - then true, e - else false, None - - | MLTY_Top, MLTY_Top -> true, e - - | MLTY_Named _, _ -> - begin match unfold_ty t with - | Some t -> type_leq_c unfold_ty e t t' - | _ -> false, None - end - - | _, MLTY_Named _ -> - begin match unfold_ty t' with - | Some t' -> type_leq_c unfold_ty e t t' - | _ -> false, None - end - - | MLTY_Erased, MLTY_Erased -> - true, e - - | _ -> false, None - -and type_leq g t1 t2 : bool = type_leq_c g None t1 t2 |> fst - -let rec erase_effect_annotations (t:mlty) = - match t with - | MLTY_Fun(t1, f, t2) -> - MLTY_Fun(erase_effect_annotations t1, E_PURE, erase_effect_annotations t2) - | _ -> t - -let is_type_abstraction = function - | (Inl _, _)::_ -> true - | _ -> false - -let is_xtuple (ns, n) = - if FStar.Parser.Const.is_tuple_datacon_string (BU.concat_l "." (ns@[n])) - (* Returns the integer k in "Mktuplek" *) - then Some (BU.int_of_char (BU.char_at n 7)) - else None - -let resugar_exp e = match e.expr with - | MLE_CTor(mlp, args) -> - (match is_xtuple mlp with - | Some n -> with_ty e.mlty <| MLE_Tuple args - | _ -> e) - | _ -> e - -let record_field_path = function - | f::_ -> - let ns, _ = BU.prefix (ns_of_lid f) in - ns |> List.map (fun id -> (string_of_id id)) - | _ -> failwith "impos" - -let record_fields fs vs = List.map2 (fun (f:lident) e -> (string_of_id (ident_of_lid f)), e) fs vs -// -//let resugar_pat q p = match p with -// | MLP_CTor(d, pats) -> -// begin match is_xtuple d with -// | Some n -> MLP_Tuple(pats) -// | _ -> -// match q with -// | Some (Record_ctor (_, fns)) -> -// let p = record_field_path fns in -// let fs = record_fields fns pats in -// MLP_Record(p, fs) -// | _ -> p -// end -// | _ -> p - - -let is_xtuple_ty (ns, n) = - if FStar.Parser.Const.is_tuple_constructor_string (BU.concat_l "." (ns@[n])) - (* Returns the integer k in "tuplek" *) - then Some (BU.int_of_char (BU.char_at n 5)) - else None - -let resugar_mlty t = match t with - | MLTY_Named (args, mlp) -> - begin match is_xtuple_ty mlp with - | Some n -> MLTY_Tuple args - | _ -> t - end - | _ -> t - -let flatten_ns ns = String.concat "_" ns -let flatten_mlpath (ns, n) = String.concat "_" (ns@[n]) -let ml_module_name_of_lid (l:lident) = - let mlp = l |> ns_of_lid |> List.map string_of_id, string_of_id (ident_of_lid l) in - flatten_mlpath mlp - - -let rec erasableType (unfold_ty:unfold_t) (t:mlty) :bool = - let erasableTypeNoDelta (t:mlty) = - if t = ml_unit_ty then true - else match t with - | MLTY_Named (_, (["FStar"; "Ghost"], "erased")) -> true - (* erase tactic terms, unless extracting for tactic compilation *) - | MLTY_Named (_, (["FStar"; "Tactics"; "Effect"], "tactic")) -> Options.codegen () <> Some Options.Plugin - | _ -> false // this function is used by another function which does delta unfolding - in - if erasableTypeNoDelta t - then true - else match unfold_ty t with - | Some t -> erasableType unfold_ty t - | None -> false - -let rec eraseTypeDeep unfold_ty (t:mlty) : mlty = - match t with - | MLTY_Fun (tyd, etag, tycd) -> - if etag=E_PURE - then MLTY_Fun (eraseTypeDeep unfold_ty tyd, etag, eraseTypeDeep unfold_ty tycd) - else t - | MLTY_Named (lty, mlp) -> - if erasableType unfold_ty t - then MLTY_Erased - else MLTY_Named (List.map (eraseTypeDeep unfold_ty) lty, mlp) // only some named constants are erased to unit. - | MLTY_Tuple lty -> MLTY_Tuple (List.map (eraseTypeDeep unfold_ty) lty) - | _ -> t - -let prims_op_equality = with_ty MLTY_Top <| MLE_Name (["Prims"], "op_Equality") -let prims_op_amp_amp = with_ty (mk_ty_fun [{mlbinder_name="x";mlbinder_ty=ml_bool_ty;mlbinder_attrs=[]}; - {mlbinder_name="y";mlbinder_ty=ml_bool_ty;mlbinder_attrs=[]}] ml_bool_ty) <| MLE_Name (["Prims"], "op_AmpAmp") -let conjoin e1 e2 = with_ty ml_bool_ty <| MLE_App(prims_op_amp_amp, [e1;e2]) -let conjoin_opt e1 e2 = match e1, e2 with - | None, None -> None - | Some x, None - | None, Some x -> Some x - | Some x, Some y -> Some (conjoin x y) - -let mlloc_of_range (r: Range.range) = - let pos = Range.start_of_range r in - let line = Range.line_of_pos pos in - line, Range.file_of_range r - -let rec doms_and_cod (t:mlty) : list mlty & mlty = - match t with - | MLTY_Fun (a,_,b) -> - let ds, c = doms_and_cod b in - a::ds, c - | _ -> - [], t - -let argTypes (t: mlty) : list mlty = - fst (doms_and_cod t) - -let rec uncurry_mlty_fun t = - match t with - | MLTY_Fun (a,_,b) -> - let args, res = uncurry_mlty_fun b in - a::args, res - | _ -> [], t - -let list_elements (e:mlexpr) : option (list mlexpr) = - let rec list_elements acc e = - match e.expr with - | MLE_CTor (([ "Prims" ], "Cons" ), [ hd; tl ]) -> - list_elements (hd :: acc) tl - | MLE_CTor (([ "Prims" ], "Nil" ), []) -> - List.rev acc |> Some - | _ -> None - in - list_elements [] e diff --git a/src/extraction/FStar.Extraction.ML.Util.fsti b/src/extraction/FStar.Extraction.ML.Util.fsti deleted file mode 100644 index aa39297190f..00000000000 --- a/src/extraction/FStar.Extraction.ML.Util.fsti +++ /dev/null @@ -1,64 +0,0 @@ -(* - Copyright 2008-2015 Abhishek Anand, Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Extraction.ML.Util -open Prims -open FStar open FStar.Compiler -open FStar.Pervasives -open FStar.Ident -open FStar.Extraction.ML.Syntax -module S = FStar.Syntax.Syntax -module BU = FStar.Compiler.Util - -val codegen_fsharp : unit -> bool -val pruneNones : list (option 'a) -> list 'a -val mk_range_mle : mlexpr -val mlconst_of_const : p:Range.range -> c:Const.sconst -> mlconstant -val mlexpr_of_const : p:Range.range -> c:Const.sconst -> mlexpr' -val mlexpr_of_range : r:Range.range -> mlexpr' -val subst : list ty_param & mlty -> args:list mlty -> mlty -val udelta_unfold : g:UEnv.uenv -> _arg1:mlty -> option mlty -val eff_leq : f:e_tag -> f':e_tag -> bool -val eff_to_string : _arg1:e_tag -> string -val join : r:Range.range -> f:e_tag -> f':e_tag -> e_tag -val join_l : r:Range.range -> fs:Prims.list e_tag -> e_tag -val mk_ty_fun : (Prims.list mlbinder -> mlty -> mlty) -type unfold_t = mlty -> option mlty -val type_leq_c : unfold_ty:unfold_t -> e:option mlexpr -> t:mlty -> t':mlty -> bool & option mlexpr -val type_leq : g:unfold_t -> t1:mlty -> t2:mlty -> bool -val erase_effect_annotations: mlty -> mlty -val is_type_abstraction : list (either 'a 'b & 'c) -> bool -val is_xtuple : list string & string -> option int -val is_xtuple_ty : list string & string -> option int -val resugar_exp : e:mlexpr -> mlexpr -val resugar_mlty : t:mlty -> mlty -val record_field_path : list lident -> list string -val record_fields : fs:list lident -> vs:list 'a -> list (string & 'a) - -val flatten_ns : ns:list string -> string -val flatten_mlpath : list string & string -> string -val ml_module_name_of_lid: lident -> string -val erasableType : unfold_ty:unfold_t -> t:mlty -> bool -val eraseTypeDeep : unfold_ty:unfold_t -> t:mlty -> mlty -val prims_op_equality : mlexpr -val prims_op_amp_amp : mlexpr -val conjoin : e1:mlexpr -> e2:mlexpr -> mlexpr -val conjoin_opt : e1:option mlexpr -> e2:option mlexpr -> option mlexpr -val mlloc_of_range : r:Range.range -> int & string -val doms_and_cod : t:mlty -> list mlty & mlty -val argTypes : t:mlty -> list mlty -val uncurry_mlty_fun : t:mlty -> list mlty & mlty - -val list_elements : mlexpr -> option (list mlexpr) diff --git a/src/extraction/FStarC.Extraction.Krml.fst b/src/extraction/FStarC.Extraction.Krml.fst new file mode 100644 index 00000000000..9f95efe8086 --- /dev/null +++ b/src/extraction/FStarC.Extraction.Krml.fst @@ -0,0 +1,1546 @@ +(* + Copyright 2008-2015 Abhishek Anand, Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +(* -------------------------------------------------------------------- *) + +module FStarC.Extraction.Krml +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.Extraction +open FStarC.Extraction.ML +open FStarC.Extraction.ML.Syntax +open FStarC.Extraction.ML.UEnv +open FStarC.Const +open FStarC.BaseTypes + +open FStarC.Class.Show +open FStarC.Class.PP +open FStarC.Pprint + +module BU = FStarC.Compiler.Util +module FC = FStarC.Const + +(** CHANGELOG +- v24: Added a single constructor to the expression type to reflect the addition + of type applications to the ML extraction language. +- v25: Added a number of type parameters for globals. +- v26: Flags for DExternal and all the DType's +- v27: Added PConstant +- v28: added many things for which the AST wasn't bumped; bumped it for + TConstBuf which will expect will be used soon +- v29: added a SizeT and PtrdiffT width to machine integers +- v30: Added EBufDiff +- v31: Added a `meta` field to binders. Currently only relevant to propagate `CInline`. +*) +let current_version: version = 31 + +(* COPY-PASTED ****************************************************************) + +type decl = + | DGlobal of list flag & lident & int & typ & expr + | DFunction of option cc & list flag & int & typ & lident & list binder & expr + | DTypeAlias of lident & list flag & int & typ + | DTypeFlat of lident & list flag & int & fields_t + | DUnusedRetainedForBackwardsCompat of option cc & list flag & lident & typ + | DTypeVariant of lident & list flag & int & branches_t + | DTypeAbstractStruct of lident + | DExternal of option cc & list flag & lident & typ & list ident + | DUntaggedUnion of lident & list flag & int & list (ident & typ) + +and cc = + | StdCall + | CDecl + | FastCall + +and fields_t = + list (ident & (typ & bool)) + +and branches_t = + list (ident & fields_t) + +and flag = + | Private + | WipeBody + | CInline + | Substitute + | GCType + | Comment of string + | MustDisappear + | Const of string + | Prologue of string + | Epilogue of string + | Abstract + | IfDef + | Macro + | Deprecated of string + | CNoInline + +and fsdoc = string + +and lifetime = + | Eternal + | Stack + | ManuallyManaged + +and expr = + | EBound of var + | EQualified of lident + | EConstant of constant + | EUnit + | EApp of expr & list expr + | ETypApp of expr & list typ + | ELet of binder & expr & expr + | EIfThenElse of expr & expr & expr + | ESequence of list expr + | EAssign of expr & expr + | (** left expression can only be a EBound of EOpen *) + EBufCreate of lifetime & expr & expr + | EBufRead of expr & expr + | EBufWrite of expr & expr & expr + | EBufSub of expr & expr + | EBufBlit of expr & expr & expr & expr & expr + | EMatch of expr & branches + | EOp of op & width + | ECast of expr & typ + | EPushFrame + | EPopFrame + | EBool of bool + | EAny + | EAbort + | EReturn of expr + | EFlat of typ & list (ident & expr) + | EField of typ & expr & ident + | EWhile of expr & expr + | EBufCreateL of lifetime & list expr + | ETuple of list expr + | ECons of typ & ident & list expr + | EBufFill of expr & expr & expr + | EString of string + | EFun of list binder & expr & typ + | EAbortS of string + | EBufFree of expr + | EBufCreateNoInit of lifetime & expr + | EAbortT of string & typ + | EComment of string & expr & string + | EStandaloneComment of string + | EAddrOf of expr + | EBufNull of typ + | EBufDiff of expr & expr + +and op = + | Add | AddW | Sub | SubW | Div | DivW | Mult | MultW | Mod + | BOr | BAnd | BXor | BShiftL | BShiftR | BNot + | Eq | Neq | Lt | Lte | Gt | Gte + | And | Or | Xor | Not + +and branches = + list branch + +and branch = + pattern & expr + +and pattern = + | PUnit + | PBool of bool + | PVar of binder + | PCons of (ident & list pattern) + | PTuple of list pattern + | PRecord of list (ident & pattern) + | PConstant of constant + +and width = + | UInt8 | UInt16 | UInt32 | UInt64 + | Int8 | Int16 | Int32 | Int64 + | Bool + | CInt + | SizeT | PtrdiffT + +and constant = width & string + +(* a De Bruijn index *) +and var = int + +and binder = { + name: ident; + typ: typ; + mut: bool; + meta: list flag; +} + +(* for pretty-printing *) +and ident = string + +and lident = + list ident & ident + +and typ = + | TInt of width + | TBuf of typ + | TUnit + | TQualified of lident + | TBool + | TAny + | TArrow of typ & typ + | TBound of int + | TApp of lident & list typ + | TTuple of list typ + | TConstBuf of typ + | TArray of typ & constant + +instance pretty_width = { pp = function + | UInt8 -> doc_of_string "UInt8" + | UInt16 -> doc_of_string "UInt16" + | UInt32 -> doc_of_string "UInt32" + | UInt64 -> doc_of_string "UInt64" + | Int8 -> doc_of_string "Int8" + | Int16 -> doc_of_string "Int16" + | Int32 -> doc_of_string "Int32" + | Int64 -> doc_of_string "Int64" + | Bool -> doc_of_string "Bool" + | CInt -> doc_of_string "CInt" + | SizeT -> doc_of_string "SizeT" + | PtrdiffT -> doc_of_string "PtrdiffT" +} + +let record_string (fs : list (string & string)) : string = + "{" ^ + (String.concat "; " <| List.map (fun (f, s) -> f ^ " = " ^ s) fs) ^ + "}" + +let ctor (n: string) (args: list document) = + nest 2 (group (parens (flow (break_ 1) (doc_of_string n :: args)))) +// let ctor (n: string) (arg: document) : document = +// nest 2 (group (parens (doc_of_string n ^/^ arg))) + +let pp_list' (#a:Type) (f: a -> document) (xs: list a) : document = + (pp_list a { pp = f }).pp xs // hack + +let rec typ_to_doc (t:typ) : document = + match t with + | TInt w -> ctor "TInt" [pp w] + | TBuf t -> ctor "TBuf" [typ_to_doc t] + | TUnit -> doc_of_string "TUnit" + | TQualified x -> ctor "TQualified" [doc_of_string (show x)] + | TBool -> doc_of_string "TBool" + | TAny -> doc_of_string "TAny" + | TArrow (t1, t2) -> ctor "TArrow" [typ_to_doc t1; typ_to_doc t2] + | TBound x -> ctor "TBound" [pp x] + | TApp (x, xs) -> ctor "TApp" [doc_of_string (show x); pp_list' typ_to_doc xs] + | TTuple ts -> ctor "TTuple" [pp_list' typ_to_doc ts] + | TConstBuf t -> ctor "TConstBuf" [typ_to_doc t] + | TArray (t, c) -> ctor "TArray" [typ_to_doc t; parens (separate comma [pp (fst c); doc_of_string (snd c)])] + +instance pretty_typ = { pp = typ_to_doc } + +instance pretty_string = { pp = (fun s -> dquotes (doc_of_string s)) } + +instance pretty_flag = { pp = function + | Private -> doc_of_string "Private" + | WipeBody -> doc_of_string "WipeBody" + | CInline -> doc_of_string "CInline" + | Substitute -> doc_of_string "Substitute" + | GCType -> doc_of_string "GCType" + | Comment s -> ctor "Comment" [pp s] + | MustDisappear -> doc_of_string "MustDisappear" + | Const s -> ctor "Const" [pp s] + | Prologue s -> ctor "Prologue" [pp s] + | Epilogue s -> ctor "Epilogue" [pp s] + | Abstract -> doc_of_string "Abstract" + | IfDef -> doc_of_string "IfDef" + | Macro -> doc_of_string "Macro" + | Deprecated s -> ctor "Deprecated" [pp s] + | CNoInline -> doc_of_string "CNoInline" +} + +let spaced a = break_ 1 ^^ a ^^ break_ 1 +let record fs = + group <| nest 2 <| braces <| spaced <| separate (semi ^^ break_ 1) fs +let fld n v = group <| nest 2 <| doc_of_string (n ^ " =") ^/^ v + +instance pretty_binder = { pp = fun b -> + record [ + fld "name" (pp b.name); + fld "typ" (pp b.typ); + fld "mut" (pp b.mut); + fld "meta" (pp b.meta); + ] +} + +instance pretty_lifetime : pretty lifetime = { pp = function + | Eternal -> doc_of_string "Eternal" + | Stack -> doc_of_string "Stack" + | ManuallyManaged -> doc_of_string "ManuallyManaged" +} + +instance pretty_op = { pp = function + | Add -> doc_of_string "Add" + | AddW -> doc_of_string "AddW" + | Sub -> doc_of_string "Sub" + | SubW -> doc_of_string "SubW" + | Div -> doc_of_string "Div" + | DivW -> doc_of_string "DivW" + | Mult -> doc_of_string "Mult" + | MultW -> doc_of_string "MultW" + | Mod -> doc_of_string "Mod" + | BOr -> doc_of_string "BOr" + | BAnd -> doc_of_string "BAnd" + | BXor -> doc_of_string "BXor" + | BShiftL -> doc_of_string "BShiftL" + | BShiftR -> doc_of_string "BShiftR" + | BNot -> doc_of_string "BNot" + | Eq -> doc_of_string "Eq" + | Neq -> doc_of_string "Neq" + | Lt -> doc_of_string "Lt" + | Lte -> doc_of_string "Lte" + | Gt -> doc_of_string "Gt" + | Gte -> doc_of_string "Gte" + | And -> doc_of_string "And" + | Or -> doc_of_string "Or" + | Xor -> doc_of_string "Xor" + | Not -> doc_of_string "Not" +} + +instance pretty_cc = { pp = function + | StdCall -> doc_of_string "StdCall" + | CDecl -> doc_of_string "CDecl" + | FastCall -> doc_of_string "FastCall" +} + +let rec pattern_to_doc (p:pattern) : document = + match p with + | PUnit -> doc_of_string "PUnit" + | PBool b -> ctor "PBool" [pp b] + | PVar b -> ctor "PVar" [pp b] + | PCons (x, ps) -> ctor "PCons" [pp x; pp_list' pattern_to_doc ps] + | PTuple ps -> ctor "PTuple" [pp_list' pattern_to_doc ps] + | PRecord fs -> ctor "PRecord" [record (List.map (fun (s, p) -> fld s (pattern_to_doc p)) fs)] + | PConstant c -> ctor "PConstant" [pp c] + +instance pretty_pattern = { pp = pattern_to_doc } + +let rec decl_to_doc (d:decl) : document = + match d with + | DGlobal (fs, x, i, t, e) -> ctor "DGlobal" [pp fs; pp x; pp i; pp t; expr_to_doc e] + | DFunction (cc, fs, i, t, x, bs, e) -> ctor "DFunction" [pp cc; pp fs; pp i; pp t; pp x; pp bs; expr_to_doc e] + | DTypeAlias (x, fs, i, t) -> ctor "DTypeAlias" [pp x; pp fs; pp i; pp t] + | DTypeFlat (x, fs, i, f) -> ctor "DTypeFlat" [pp x; pp fs; pp i; pp f] + | DUnusedRetainedForBackwardsCompat (cc, fs, x, t) -> ctor "DUnusedRetainedForBackwardsCompat" [pp cc; pp fs; pp x; pp t] + | DTypeVariant (x, fs, i, bs) -> ctor "DTypeVariant" [pp x; pp fs; pp i; pp bs] + | DTypeAbstractStruct x -> ctor "DTypeAbstractStruct" [pp x] + | DExternal (cc, fs, x, t, xs) -> ctor "DExternal" [pp cc; pp fs; pp x; pp t; pp xs] + | DUntaggedUnion (x, fs, i, xs) -> ctor "DUntaggedUnion" [pp x; pp fs; pp i; pp xs] + +and expr_to_doc (e:expr) : document = + match e with + | EBound x -> ctor "EBound" [pp x] + | EQualified x -> ctor "EQualified" [pp x] + | EConstant x -> ctor "EConstant" [pp x] + | EUnit -> doc_of_string "EUnit" + | EApp (x, xs) -> ctor "EApp" [expr_to_doc x; pp_list' expr_to_doc xs] + | ETypApp (x, xs) -> ctor "ETypApp" [expr_to_doc x; pp xs] + | ELet (x, y, z) -> ctor "ELet" [pp x; expr_to_doc y; expr_to_doc z] + | EIfThenElse (x, y, z) -> ctor "EIfThenElse" [expr_to_doc x; expr_to_doc y; expr_to_doc z] + | ESequence xs -> ctor "ESequence" [pp_list' expr_to_doc xs] + | EAssign (x, y) -> ctor "EAssign" [expr_to_doc x; expr_to_doc y] + | EBufCreate (x, y, z) -> ctor "EBufCreate" [pp x; expr_to_doc y; expr_to_doc z] + | EBufRead (x, y) -> ctor "EBufRead" [expr_to_doc x; expr_to_doc y] + | EBufWrite (x, y, z) -> ctor "EBufWrite" [expr_to_doc x; expr_to_doc y; expr_to_doc z] + | EBufSub (x, y) -> ctor "EBufSub" [expr_to_doc x; expr_to_doc y] + | EBufBlit (x, y, z, a, b) -> ctor "EBufBlit" [expr_to_doc x; expr_to_doc y; expr_to_doc z; expr_to_doc a; expr_to_doc b] + | EMatch (x, bs) -> ctor "EMatch" [expr_to_doc x; pp_list' pp_branch bs] + | EOp (x, y) -> ctor "EOp" [pp x; pp y] + | ECast (x, y) -> ctor "ECast" [expr_to_doc x; pp y] + | EPushFrame -> doc_of_string "EPushFrame" + | EPopFrame -> doc_of_string "EPopFrame" + | EBool x -> ctor "EBool" [pp x] + | EAny -> doc_of_string "EAny" + | EAbort -> doc_of_string "EAbort" + | EReturn x -> ctor "EReturn" [expr_to_doc x] + | EFlat (x, xs) -> ctor "EFlat" [pp x; record (List.map (fun (s, e) -> fld s (expr_to_doc e)) xs)] + | EField (x, y, z) -> ctor "EField" [pp x; expr_to_doc y; pp z] + | EWhile (x, y) -> ctor "EWhile" [expr_to_doc x; expr_to_doc y] + | EBufCreateL (x, xs) -> ctor "EBufCreateL" [pp x; pp_list' expr_to_doc xs] + | ETuple xs -> ctor "ETuple" [pp_list' expr_to_doc xs] + | ECons (x, y, xs) -> ctor "ECons" [pp x; pp y; pp_list' expr_to_doc xs] + | EBufFill (x, y, z) -> ctor "EBufFill" [expr_to_doc x; expr_to_doc y; expr_to_doc z] + | EString x -> ctor "EString" [pp x] + | EFun (xs, y, z) -> ctor "EFun" [pp_list' pp xs; expr_to_doc y; pp z] + | EAbortS x -> ctor "EAbortS" [pp x] + | EBufFree x -> ctor "EBufFree" [expr_to_doc x] + | EBufCreateNoInit (x, y) -> ctor "EBufCreateNoInit" [pp x; expr_to_doc y] + | EAbortT (x, y) -> ctor "EAbortT" [pp x; pp y] + | EComment (x, y, z) -> ctor "EComment" [pp x; expr_to_doc y; pp z] + | EStandaloneComment x -> ctor "EStandaloneComment" [pp x] + | EAddrOf x -> ctor "EAddrOf" [expr_to_doc x] + | EBufNull x -> ctor "EBufNull" [pp x] + | EBufDiff (x, y) -> ctor "EBufDiff" [expr_to_doc x; expr_to_doc y] + +and pp_branch (b:branch) : document = + let (p, e) = b in + parens (pp p ^^ comma ^/^ expr_to_doc e) + +instance pretty_decl : pretty decl = { pp = decl_to_doc; } +instance showable_decl : showable decl = showable_from_pretty + +(* Utilities *****************************************************************) + +let fst3 (x, _, _) = x +let snd3 (_, x, _) = x +let thd3 (_, _, x) = x + +let mk_width = function + | "UInt8" -> Some UInt8 + | "UInt16" -> Some UInt16 + | "UInt32" -> Some UInt32 + | "UInt64" -> Some UInt64 + | "Int8" -> Some Int8 + | "Int16" -> Some Int16 + | "Int32" -> Some Int32 + | "Int64" -> Some Int64 + | "SizeT" -> Some SizeT + | "PtrdiffT" -> Some PtrdiffT + | _ -> None + +let mk_bool_op = function + | "op_Negation" -> + Some Not + | "op_AmpAmp" -> + Some And + | "op_BarBar" -> + Some Or + | "op_Equality" -> + Some Eq + | "op_disEquality" -> + Some Neq + | _ -> + None + +let is_bool_op op = + mk_bool_op op <> None + +let mk_op = function + | "add" | "op_Plus_Hat" | "add_underspec" -> + Some Add + | "add_mod" | "op_Plus_Percent_Hat" -> + Some AddW + | "sub" | "op_Subtraction_Hat" | "sub_underspec" -> + Some Sub + | "sub_mod" | "op_Subtraction_Percent_Hat" -> + Some SubW + | "mul" | "op_Star_Hat" | "mul_underspec" -> + Some Mult + | "mul_mod" | "op_Star_Percent_Hat" -> + Some MultW + | "div" | "op_Slash_Hat" -> + Some Div + | "div_mod" | "op_Slash_Percent_Hat" -> + Some DivW + | "rem" | "op_Percent_Hat" -> + Some Mod + | "logor" | "op_Bar_Hat" -> + Some BOr + | "logxor" | "op_Hat_Hat" -> + Some BXor + | "logand" | "op_Amp_Hat" -> + Some BAnd + | "lognot" -> + Some BNot + | "shift_right" | "op_Greater_Greater_Hat" -> + Some BShiftR + | "shift_left" | "op_Less_Less_Hat" -> + Some BShiftL + | "eq" | "op_Equals_Hat" -> + Some Eq + | "op_Greater_Hat" | "gt" -> + Some Gt + | "op_Greater_Equals_Hat" | "gte" -> + Some Gte + | "op_Less_Hat" | "lt" -> + Some Lt + | "op_Less_Equals_Hat" | "lte" -> + Some Lte + | _ -> + None + +let is_op op = + mk_op op <> None + +let is_machine_int m = + mk_width m <> None + +(* Environments **************************************************************) + +type env = { + uenv : uenv; + names: list name; + names_t: list string; + module_name: list string; +} + +and name = { + pretty: string; +} + +let empty uenv module_name = { + uenv = uenv; + names = []; + names_t = []; + module_name = module_name +} + +let extend env x = + { env with names = { pretty = x } :: env.names } + +let extend_t env x = + { env with names_t = x :: env.names_t } + +let find_name env x = + match List.tryFind (fun name -> name.pretty = x) env.names with + | Some name -> + name + | None -> + failwith "internal error: name not found" + +let find env x = + try + List.index (fun name -> name.pretty = x) env.names + with _ -> + failwith (BU.format1 "Internal error: name not found %s\n" x) + +let find_t env x = + try + List.index (fun name -> name = x) env.names_t + with _ -> + failwith (BU.format1 "Internal error: name not found %s\n" x) + +let add_binders env bs = + List.fold_left (fun env {mlbinder_name} -> extend env mlbinder_name) env bs + +(* Actual translation ********************************************************) + +let list_elements e = + let lopt = FStarC.Extraction.ML.Util.list_elements e in + match lopt with + | None -> failwith "Argument of FStar.Buffer.createL is not a list literal!" + | Some l -> l + +let translate_flags flags = + List.choose (function + | Syntax.Private -> Some Private + | Syntax.NoExtract -> Some WipeBody + | Syntax.CInline -> Some CInline + | Syntax.CNoInline -> Some CNoInline + | Syntax.Substitute -> Some Substitute + | Syntax.GCType -> Some GCType + | Syntax.Comment s -> Some (Comment s) + | Syntax.StackInline -> Some MustDisappear + | Syntax.CConst s -> Some (Const s) + | Syntax.CPrologue s -> Some (Prologue s) + | Syntax.CEpilogue s -> Some (Epilogue s) + | Syntax.CAbstract -> Some Abstract + | Syntax.CIfDef -> Some IfDef + | Syntax.CMacro -> Some Macro + | Syntax.Deprecated s -> Some (Deprecated s) + | _ -> None // is this all of them? + ) flags + +let translate_cc flags = + match List.choose (function | Syntax.CCConv s -> Some s | _ -> None) flags with + | [ "stdcall" ] -> Some StdCall + | [ "fastcall" ] -> Some FastCall + | [ "cdecl" ] -> Some CDecl + | _ -> None + +(* Per FStarLang/karamel#324 *) +let generate_is_null + (t: typ) + (x: expr) +: Tot expr += let dummy = UInt64 in + EApp (ETypApp (EOp (Eq, dummy), [TBuf t]), [x; EBufNull t]) + +exception NotSupportedByKrmlExtension + +let translate_type_without_decay_t = env -> mlty -> ML typ +let ref_translate_type_without_decay : ref translate_type_without_decay_t = mk_ref (fun _ _ -> raise NotSupportedByKrmlExtension) +let register_pre_translate_type_without_decay + (f: translate_type_without_decay_t) +: ML unit += let before : translate_type_without_decay_t = !ref_translate_type_without_decay in + let after : translate_type_without_decay_t = fun e t -> + try + f e t + with NotSupportedByKrmlExtension -> before e t + in + ref_translate_type_without_decay := after +let register_post_translate_type_without_decay + (f: translate_type_without_decay_t) +: ML unit += let before : translate_type_without_decay_t = !ref_translate_type_without_decay in + let after : translate_type_without_decay_t = fun e t -> + try + before e t + with NotSupportedByKrmlExtension -> f e t + in + ref_translate_type_without_decay := after +let translate_type_without_decay env t = !ref_translate_type_without_decay env t + +// The outermost array type constructor decays to pointer +let translate_type_t = env -> mlty -> ML typ +let ref_translate_type : ref translate_type_t = mk_ref (fun _ _ -> raise NotSupportedByKrmlExtension) +let register_pre_translate_type + (f: translate_type_t) +: ML unit += let before : translate_type_t = !ref_translate_type in + let after : translate_type_t = fun e t -> + try + f e t + with NotSupportedByKrmlExtension -> before e t + in + ref_translate_type := after +let register_post_translate_type + (f: translate_type_t) +: ML unit += let before : translate_type_t = !ref_translate_type in + let after : translate_type_t = fun e t -> + try + before e t + with NotSupportedByKrmlExtension -> f e t + in + ref_translate_type := after +let translate_type env t = !ref_translate_type env t + +let translate_expr_t = env -> mlexpr -> ML expr +let ref_translate_expr : ref translate_expr_t = mk_ref (fun _ _ -> raise NotSupportedByKrmlExtension) +let register_pre_translate_expr + (f: translate_expr_t) +: ML unit += let before : translate_expr_t = !ref_translate_expr in + let after : translate_expr_t = fun e t -> + try + f e t + with NotSupportedByKrmlExtension -> before e t + in + ref_translate_expr := after +let register_post_translate_expr + (f: translate_expr_t) +: ML unit += let before : translate_expr_t = !ref_translate_expr in + let after : translate_expr_t = fun e t -> + try + before e t + with NotSupportedByKrmlExtension -> f e t + in + ref_translate_expr := after +let translate_expr (env: env) (e: mlexpr) = !ref_translate_expr env e + +let translate_type_decl_t = env -> one_mltydecl -> ML (option decl) +let ref_translate_type_decl : ref translate_type_decl_t = mk_ref (fun _ _ -> raise NotSupportedByKrmlExtension) +let register_pre_translate_type_decl + (f: translate_type_decl_t) +: ML unit += let before : translate_type_decl_t = !ref_translate_type_decl in + let after : translate_type_decl_t = fun e t -> + try + f e t + with NotSupportedByKrmlExtension -> before e t + in + ref_translate_type_decl := after +let register_post_translate_type_decl + (f: translate_type_decl_t) +: ML unit += let before : translate_type_decl_t = !ref_translate_type_decl in + let after : translate_type_decl_t = fun e t -> + try + before e t + with NotSupportedByKrmlExtension -> f e t + in + ref_translate_type_decl := after +let translate_type_decl env ty: option decl = + if List.mem Syntax.NoExtract ty.tydecl_meta then + None + else + !ref_translate_type_decl env ty + +let rec translate_type_without_decay' env t: typ = + match t with + | MLTY_Tuple [] + | MLTY_Top -> + TAny + | MLTY_Var name -> + TBound (find_t env name) + | MLTY_Fun (t1, _, t2) -> + TArrow (translate_type_without_decay env t1, translate_type_without_decay env t2) + | MLTY_Erased -> + TUnit + | MLTY_Named ([], p) when (Syntax.string_of_mlpath p = "Prims.unit") -> + TUnit + | MLTY_Named ([], p) when (Syntax.string_of_mlpath p = "Prims.bool") -> + TBool + | MLTY_Named ([], ([ "FStar"; m ], "t")) when is_machine_int m -> + TInt (must (mk_width m)) + | MLTY_Named ([], ([ "FStar"; m ], "t'")) when is_machine_int m -> + TInt (must (mk_width m)) + | MLTY_Named ([], p) when (Syntax.string_of_mlpath p = "FStar.Monotonic.HyperStack.mem") -> + TUnit + + | MLTY_Named ([_; arg; _], p) when + Syntax.string_of_mlpath p = "FStar.Monotonic.HyperStack.s_mref" || + Syntax.string_of_mlpath p = "FStar.Monotonic.HyperHeap.mrref" || + Syntax.string_of_mlpath p = "FStar.HyperStack.ST.m_rref" || + Syntax.string_of_mlpath p = "FStar.HyperStack.ST.s_mref" + -> + TBuf (translate_type_without_decay env arg) + + | MLTY_Named ([arg; _], p) when + Syntax.string_of_mlpath p = "FStar.Monotonic.HyperStack.mreference" || + Syntax.string_of_mlpath p = "FStar.Monotonic.HyperStack.mstackref" || + Syntax.string_of_mlpath p = "FStar.Monotonic.HyperStack.mref" || + Syntax.string_of_mlpath p = "FStar.Monotonic.HyperStack.mmmstackref" || + Syntax.string_of_mlpath p = "FStar.Monotonic.HyperStack.mmmref" || + Syntax.string_of_mlpath p = "FStar.Monotonic.Heap.mref" || + Syntax.string_of_mlpath p = "FStar.HyperStack.ST.mreference" || + Syntax.string_of_mlpath p = "FStar.HyperStack.ST.mstackref" || + Syntax.string_of_mlpath p = "FStar.HyperStack.ST.mref" || + Syntax.string_of_mlpath p = "FStar.HyperStack.ST.mmmstackref" || + Syntax.string_of_mlpath p = "FStar.HyperStack.ST.mmmref" + -> + TBuf (translate_type_without_decay env arg) + + | MLTY_Named ([arg; _; _], p) when + Syntax.string_of_mlpath p = "LowStar.Monotonic.Buffer.mbuffer" -> TBuf (translate_type_without_decay env arg) + + | MLTY_Named ([arg], p) when + Syntax.string_of_mlpath p = "LowStar.ConstBuffer.const_buffer" || + false + -> TConstBuf (translate_type_without_decay env arg) + + | MLTY_Named ([arg], p) when + Syntax.string_of_mlpath p = "FStar.Buffer.buffer" || + Syntax.string_of_mlpath p = "LowStar.Buffer.buffer" || + Syntax.string_of_mlpath p = "LowStar.ImmutableBuffer.ibuffer" || + Syntax.string_of_mlpath p = "LowStar.UninitializedBuffer.ubuffer" || + Syntax.string_of_mlpath p = "FStar.HyperStack.reference" || + Syntax.string_of_mlpath p = "FStar.HyperStack.stackref" || + Syntax.string_of_mlpath p = "FStar.HyperStack.ref" || + Syntax.string_of_mlpath p = "FStar.HyperStack.mmstackref" || + Syntax.string_of_mlpath p = "FStar.HyperStack.mmref" || + Syntax.string_of_mlpath p = "FStar.HyperStack.ST.reference" || + Syntax.string_of_mlpath p = "FStar.HyperStack.ST.stackref" || + Syntax.string_of_mlpath p = "FStar.HyperStack.ST.ref" || + Syntax.string_of_mlpath p = "FStar.HyperStack.ST.mmstackref" || + Syntax.string_of_mlpath p = "FStar.HyperStack.ST.mmref" || + false + -> + TBuf (translate_type_without_decay env arg) + + | MLTY_Named ([_;arg], p) when + Syntax.string_of_mlpath p = "FStar.HyperStack.s_ref" || + Syntax.string_of_mlpath p = "FStar.HyperStack.ST.s_ref" + -> + TBuf (translate_type_without_decay env arg) + + | MLTY_Named ([arg], p) when + Syntax.string_of_mlpath p = "FStar.Universe.raise_t" + -> + translate_type_without_decay env arg + + | MLTY_Named ([_], p) when (Syntax.string_of_mlpath p = "FStar.Ghost.erased") -> + TAny + + | MLTY_Named ([], (path, type_name)) -> + // Generate an unbound reference... to be filled in later by glue code. + TQualified (path, type_name) + + | MLTY_Named (args, (ns, t)) when (ns = ["Prims"] || ns = ["FStar"; "Pervasives"; "Native"]) && BU.starts_with t "tuple" -> + TTuple (List.map (translate_type_without_decay env) args) + + | MLTY_Named (args, lid) -> + if List.length args > 0 then + TApp (lid, List.map (translate_type_without_decay env) args) + else + TQualified lid + + | MLTY_Tuple ts -> + TTuple (List.map (translate_type_without_decay env) ts) + +and translate_type' env t: typ = + // The outermost array type constructor decays to pointer + match t with + + | t -> translate_type_without_decay env t + +and translate_binders env bs = + List.map (translate_binder env) bs + +and translate_binder env ({mlbinder_name; mlbinder_ty; mlbinder_attrs} ) = + { + name = mlbinder_name; + typ = translate_type env mlbinder_ty; + mut = false; + meta = []; + } + +and translate_expr' env e: expr = + match e.expr with + | MLE_Tuple [] -> + EUnit + + | MLE_Const c -> + translate_constant c + + | MLE_Var name -> + EBound (find env name) + + // Some of these may not appear beneath an [EApp] node because of partial applications + | MLE_Name ([ "FStar"; m ], op) when (is_machine_int m && is_op op) -> + EOp (must (mk_op op), must (mk_width m)) + + | MLE_Name ([ "Prims" ], op) when (is_bool_op op) -> + EOp (must (mk_bool_op op), Bool) + + | MLE_Name n -> + EQualified n + + | MLE_Let ((flavor, [{ + mllb_name = name; + mllb_tysc = Some ([], typ); // assuming unquantified type + mllb_add_unit = add_unit; // ? + mllb_def = body; + mllb_meta = flags; + print_typ = print // ? + }]), continuation) -> + let binder = { name = name; typ = translate_type env typ; mut = false; meta = translate_flags flags; } in + let body = translate_expr env body in + let env = extend env name in + let continuation = translate_expr env continuation in + ELet (binder, body, continuation) + + | MLE_Match (expr, branches) -> + EMatch (translate_expr env expr, translate_branches env branches) + + // We recognize certain distinguished names from [FStar.HST] and other + // modules, and translate them into built-in Karamel constructs + | MLE_App({expr=MLE_TApp ({ expr = MLE_Name p }, [t])}, [arg]) + when string_of_mlpath p = "FStarC.Dyn.undyn" -> + ECast (translate_expr env arg, translate_type env t) + | MLE_App({expr=MLE_TApp ({ expr = MLE_Name p }, _)}, _) + when string_of_mlpath p = "Prims.admit" -> + EAbort + | MLE_App({expr=MLE_TApp ({ expr = MLE_Name p }, [ t ])}, + [{ expr = MLE_Const (MLC_String s) }]) + when string_of_mlpath p = "LowStar.Failure.failwith" -> + EAbortT (s, translate_type env t) + | MLE_App({expr=MLE_TApp ({ expr = MLE_Name p }, _)}, [arg]) + when string_of_mlpath p = "FStar.HyperStack.All.failwith" + || string_of_mlpath p = "FStar.Error.unexpected" + || string_of_mlpath p = "FStar.Error.unreachable" -> + (match arg with + | {expr=MLE_Const (MLC_String msg)} -> EAbortS msg + | _ -> + let print_nm = ["FStar"; "HyperStack"; "IO"], "print_string" in + let print = with_ty MLTY_Top (MLE_Name print_nm) in + let print = with_ty MLTY_Top (MLE_App (print, [arg])) in + let t = translate_expr env print in + ESequence [t; EAbort]) + + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e ] ) + when string_of_mlpath p = "LowStar.ToFStarBuffer.new_to_old_st" || + string_of_mlpath p = "LowStar.ToFStarBuffer.old_to_new_st" + -> + translate_expr env e + + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e1; e2 ]) + when string_of_mlpath p = "FStar.Buffer.index" || string_of_mlpath p = "FStar.Buffer.op_Array_Access" + || string_of_mlpath p = "LowStar.Monotonic.Buffer.index" + || string_of_mlpath p = "LowStar.UninitializedBuffer.uindex" + || string_of_mlpath p = "LowStar.ConstBuffer.index" + -> + EBufRead (translate_expr env e1, translate_expr env e2) + + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e ]) + when string_of_mlpath p = "FStar.HyperStack.ST.op_Bang" + -> + EBufRead (translate_expr env e, EQualified (["C"], "_zero_for_deref")) + + (* Flatten all universes *) + + | MLE_App ({ expr = MLE_TApp ({ expr = MLE_Name p }, _) }, [arg]) + when string_of_mlpath p = "FStar.Universe.raise_val" -> + translate_expr env arg + + | MLE_App ({ expr = MLE_TApp ({ expr = MLE_Name p }, _) }, [arg]) + when string_of_mlpath p = "FStar.Universe.downgrade_val" -> + translate_expr env arg + + (* All the distinguished combinators that correspond to allocation, either on + * the stack, on the heap (GC'd or manually-managed). *) + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) } , [ e1; e2 ]) + when (string_of_mlpath p = "FStar.Buffer.create" || + string_of_mlpath p = "LowStar.Monotonic.Buffer.malloca" || + string_of_mlpath p = "LowStar.ImmutableBuffer.ialloca") -> + EBufCreate (Stack, translate_expr env e1, translate_expr env e2) + + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) } , [ elen ]) + when string_of_mlpath p = "LowStar.UninitializedBuffer.ualloca" -> + EBufCreateNoInit (Stack, translate_expr env elen) + + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) } , [ init ]) + when ( + string_of_mlpath p = "FStar.HyperStack.ST.salloc" || + false + ) -> + EBufCreate (Stack, translate_expr env init, EConstant (UInt32, "1")) + + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e2 ]) + when (string_of_mlpath p = "FStar.Buffer.createL" || + string_of_mlpath p = "LowStar.Monotonic.Buffer.malloca_of_list" || + string_of_mlpath p = "LowStar.ImmutableBuffer.ialloca_of_list") -> + EBufCreateL (Stack, List.map (translate_expr env) (list_elements e2)) + + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ _erid; e2 ]) + when string_of_mlpath p = "LowStar.Monotonic.Buffer.mgcmalloc_of_list" || + string_of_mlpath p = "LowStar.ImmutableBuffer.igcmalloc_of_list" -> + EBufCreateL (Eternal, List.map (translate_expr env) (list_elements e2)) + + (* + * AR: TODO: FIXME: + * temporarily extraction of ralloc_drgn is same as ralloc + *) + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) } , [ _rid; init ]) + when (string_of_mlpath p = "FStar.HyperStack.ST.ralloc") || + (string_of_mlpath p = "FStar.HyperStack.ST.ralloc_drgn") -> + EBufCreate (Eternal, translate_expr env init, EConstant (UInt32, "1")) + + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ _e0; e1; e2 ]) + when (string_of_mlpath p = "FStar.Buffer.rcreate" || string_of_mlpath p = "LowStar.Monotonic.Buffer.mgcmalloc" || + string_of_mlpath p = "LowStar.ImmutableBuffer.igcmalloc") -> + EBufCreate (Eternal, translate_expr env e1, translate_expr env e2) + + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, _) + when (string_of_mlpath p = "LowStar.Monotonic.Buffer.mgcmalloc_and_blit" || + string_of_mlpath p = "LowStar.Monotonic.Buffer.mmalloc_and_blit" || + string_of_mlpath p = "LowStar.Monotonic.Buffer.malloca_and_blit" || + string_of_mlpath p = "LowStar.ImmutableBuffer.igcmalloc_and_blit" || + string_of_mlpath p = "LowStar.ImmutableBuffer.imalloc_and_blit" || + string_of_mlpath p = "LowStar.ImmutableBuffer.ialloca_and_blit") -> + EAbortS "alloc_and_blit family of functions are not yet supported downstream" + + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ _erid; elen ]) + when string_of_mlpath p = "LowStar.UninitializedBuffer.ugcmalloc" -> + EBufCreateNoInit (Eternal, translate_expr env elen) + + (* + * AR: TODO: FIXME: + * temporarily extraction of ralloc_drgn_mm is same as ralloc_mm + *) + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) } , [ _rid; init ]) + when (string_of_mlpath p = "FStar.HyperStack.ST.ralloc_mm") || + (string_of_mlpath p = "FStar.HyperStack.ST.ralloc_drgn_mm") -> + EBufCreate (ManuallyManaged, translate_expr env init, EConstant (UInt32, "1")) + + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ _e0; e1; e2 ]) + when (string_of_mlpath p = "FStar.Buffer.rcreate_mm" || + string_of_mlpath p = "LowStar.Monotonic.Buffer.mmalloc" || + string_of_mlpath p = "LowStar.Monotonic.Buffer.mmalloc" || + string_of_mlpath p = "LowStar.ImmutableBuffer.imalloc") -> + EBufCreate (ManuallyManaged, translate_expr env e1, translate_expr env e2) + + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ _erid; elen ]) + when string_of_mlpath p = "LowStar.UninitializedBuffer.umalloc" -> + EBufCreateNoInit (ManuallyManaged, translate_expr env elen) + + (* Only manually-managed references and buffers can be freed. *) + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e2 ]) when + (string_of_mlpath p = "FStar.HyperStack.ST.rfree" || + false) -> + EBufFree (translate_expr env e2) + + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e2 ]) + when (string_of_mlpath p = "FStar.Buffer.rfree" || + string_of_mlpath p = "LowStar.Monotonic.Buffer.free") -> + EBufFree (translate_expr env e2) + + (* Generic buffer operations. *) + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e1; e2; _e3 ]) when (string_of_mlpath p = "FStar.Buffer.sub") -> + EBufSub (translate_expr env e1, translate_expr env e2) + + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e1; e2; _e3 ]) + when string_of_mlpath p = "LowStar.Monotonic.Buffer.msub" + || string_of_mlpath p = "LowStar.ConstBuffer.sub" -> + EBufSub (translate_expr env e1, translate_expr env e2) + + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e1; e2 ]) when (string_of_mlpath p = "FStar.Buffer.join") -> + (translate_expr env e1) + + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e1; e2 ]) + when string_of_mlpath p = "FStar.Buffer.offset" + -> + EBufSub (translate_expr env e1, translate_expr env e2) + + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e1; e2 ]) when string_of_mlpath p = "LowStar.Monotonic.Buffer.moffset" -> + EBufSub (translate_expr env e1, translate_expr env e2) + + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e1; e2; e3 ]) + when string_of_mlpath p = "FStar.Buffer.upd" || string_of_mlpath p = "FStar.Buffer.op_Array_Assignment" + || string_of_mlpath p = "LowStar.Monotonic.Buffer.upd'" + || string_of_mlpath p = "LowStar.UninitializedBuffer.uupd" + -> + EBufWrite (translate_expr env e1, translate_expr env e2, translate_expr env e3) + + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e1; e2 ]) + when string_of_mlpath p = "FStar.HyperStack.ST.op_Colon_Equals" + -> + EBufWrite (translate_expr env e1, EQualified (["C"], "_zero_for_deref"), translate_expr env e2) + + | MLE_App ({ expr = MLE_Name p }, [ _ ]) when ( + string_of_mlpath p = "FStar.HyperStack.ST.push_frame" || + false + ) -> + EPushFrame + | MLE_App ({ expr = MLE_Name p }, [ _ ]) when (string_of_mlpath p = "FStar.HyperStack.ST.pop_frame") -> + EPopFrame + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e1; e2; e3; e4; e5 ]) when ( + string_of_mlpath p = "FStar.Buffer.blit" || + string_of_mlpath p = "LowStar.Monotonic.Buffer.blit" || + string_of_mlpath p = "LowStar.UninitializedBuffer.ublit" + ) -> + EBufBlit (translate_expr env e1, translate_expr env e2, translate_expr env e3, translate_expr env e4, translate_expr env e5) + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e1; e2; e3 ]) + when (let s = string_of_mlpath p in (s = "FStar.Buffer.fill" || s = "LowStar.Monotonic.Buffer.fill" )) -> + EBufFill (translate_expr env e1, translate_expr env e2, translate_expr env e3) + | MLE_App ({ expr = MLE_Name p }, [ _ ]) when string_of_mlpath p = "FStar.HyperStack.ST.get" -> + // We need to reveal to Karamel that FStar.HST.get is equivalent to + // (void*)0 so that it can get rid of ghost calls to HST.get at the + // beginning of functions, which is needed to enforce the push/pop + // structure. + EUnit + + (* + * AR: TODO: FIXME: + * temporarily extraction of new_drgn and free_drgn is same just unit + *) + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) } , [ _rid ]) + when (string_of_mlpath p = "FStar.HyperStack.ST.free_drgn") || + (string_of_mlpath p = "FStar.HyperStack.ST.new_drgn") -> + EUnit + + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ _ebuf; _eseq ]) + when (string_of_mlpath p = "LowStar.Monotonic.Buffer.witness_p" || + string_of_mlpath p = "LowStar.Monotonic.Buffer.recall_p" || + string_of_mlpath p = "LowStar.ImmutableBuffer.witness_contents" || + string_of_mlpath p = "LowStar.ImmutableBuffer.recall_contents") -> + EUnit + + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ e1 ]) + when string_of_mlpath p = "LowStar.ConstBuffer.of_buffer" + || string_of_mlpath p = "LowStar.ConstBuffer.of_ibuffer" + -> + // The injection from *t to const *t should always be re-checkable by the + // Low* checker and should not necessitate the insertion of casts. This is + // the C semantics: if the context wants a const pointer, providing a + // non-const pointer should always be checkable. + translate_expr env e1 + + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, [ t ]) }, [ _eqal; e1 ]) + when string_of_mlpath p = "LowStar.ConstBuffer.of_qbuf" + -> + ECast (translate_expr env e1, TConstBuf (translate_type env t)) + + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, [ t ]) }, [ e1 ]) + when string_of_mlpath p = "LowStar.ConstBuffer.cast" || + string_of_mlpath p = "LowStar.ConstBuffer.to_buffer" || + string_of_mlpath p = "LowStar.ConstBuffer.to_ibuffer" + -> + // See comments in LowStar.ConstBuffer.fsti + ECast (translate_expr env e1, TBuf (translate_type env t)) + + | MLE_App ({ expr = MLE_Name p }, [ e ]) when string_of_mlpath p = "Obj.repr" -> + ECast (translate_expr env e, TAny) + + // Operators from fixed-width integer modules, e.g. [FStar.Int32.addw]. + | MLE_App ({ expr = MLE_Name ([ "FStar"; m ], op) }, args) when (is_machine_int m && is_op op) -> + mk_op_app env (must (mk_width m)) (must (mk_op op)) args + + | MLE_App ({ expr = MLE_Name ([ "Prims" ], op) }, args) when (is_bool_op op) -> + mk_op_app env Bool (must (mk_bool_op op)) args + + // Fixed-width literals are represented as calls to [FStar.Int32.uint_to_t] + | MLE_App ({ expr = MLE_Name ([ "FStar"; m ], "int_to_t") }, [ { expr = MLE_Const (MLC_Int (c, None)) }]) + | MLE_App ({ expr = MLE_Name ([ "FStar"; m ], "uint_to_t") }, [ { expr = MLE_Const (MLC_Int (c, None)) }]) when is_machine_int m -> + EConstant (must (mk_width m), c) + + | MLE_App ({ expr = MLE_Name ([ "C" ], "string_of_literal") }, [ { expr = e } ]) + | MLE_App ({ expr = MLE_Name ([ "C"; "Compat"; "String" ], "of_literal") }, [ { expr = e } ]) + | MLE_App ({ expr = MLE_Name ([ "C"; "String" ], "of_literal") }, [ { expr = e } ]) -> + begin match e with + | MLE_Const (MLC_String s) -> + EString s + | _ -> + failwith "Cannot extract string_of_literal applied to a non-literal" + end + + | MLE_App ({ expr = MLE_TApp({ expr = MLE_Name p }, _) }, [ { expr = ebefore }; e ; { expr = eafter } ] ) + when string_of_mlpath p = "LowStar.Comment.comment_gen" -> + begin match ebefore, eafter with + | MLE_Const (MLC_String sbefore), MLE_Const (MLC_String safter) -> + if contains sbefore "*/" + then failwith "Before Comment contains end-of-comment marker"; + if contains safter "*/" + then failwith "After Comment contains end-of-comment marker"; + EComment (sbefore, translate_expr env e, safter) + | _ -> + failwith "Cannot extract comment applied to a non-literal" + end + + | MLE_App ({ expr = MLE_Name p }, [ { expr = e } ] ) + when string_of_mlpath p = "LowStar.Comment.comment" -> + begin match e with + | MLE_Const (MLC_String s) -> + if contains s "*/" + then failwith "Standalone Comment contains end-of-comment marker"; + EStandaloneComment s + | _ -> + failwith "Cannot extract comment applied to a non-literal" + end + + | MLE_App ({ expr = MLE_Name ([ "LowStar"; "Literal" ], "buffer_of_literal") }, [ { expr = e } ]) -> + begin match e with + | MLE_Const (MLC_String s) -> + ECast (EString s, TBuf (TInt UInt8)) + | _ -> + failwith "Cannot extract buffer_of_literal applied to a non-literal" + end + + | MLE_App ({ expr = MLE_Name ([ "FStar"; "Int"; "Cast" ], c) }, [ arg ]) -> + let is_known_type = + starts_with c "uint8" || starts_with c "uint16" || + starts_with c "uint32" || starts_with c "uint64" || + starts_with c "int8" || starts_with c "int16" || + starts_with c "int32" || starts_with c "int64" + in + if ends_with c "uint64" && is_known_type then + ECast (translate_expr env arg, TInt UInt64) + else if ends_with c "uint32" && is_known_type then + ECast (translate_expr env arg, TInt UInt32) + else if ends_with c "uint16" && is_known_type then + ECast (translate_expr env arg, TInt UInt16) + else if ends_with c "uint8" && is_known_type then + ECast (translate_expr env arg, TInt UInt8) + else if ends_with c "int64" && is_known_type then + ECast (translate_expr env arg, TInt Int64) + else if ends_with c "int32" && is_known_type then + ECast (translate_expr env arg, TInt Int32) + else if ends_with c "int16" && is_known_type then + ECast (translate_expr env arg, TInt Int16) + else if ends_with c "int8" && is_known_type then + ECast (translate_expr env arg, TInt Int8) + else + EApp (EQualified ([ "FStar"; "Int"; "Cast" ], c), [ translate_expr env arg ]) + + | MLE_App ({ expr = MLE_Name p }, [ arg ]) + when string_of_mlpath p = "FStar.SizeT.uint16_to_sizet" || + string_of_mlpath p = "FStar.SizeT.uint32_to_sizet" || + string_of_mlpath p = "FStar.SizeT.uint64_to_sizet" || + string_of_mlpath p = "FStar.PtrdiffT.ptrdifft_to_sizet" -> + ECast (translate_expr env arg, TInt SizeT) + + | MLE_App ({ expr = MLE_Name p }, [ arg ]) + when string_of_mlpath p = "FStar.SizeT.sizet_to_uint32" -> + ECast (translate_expr env arg, TInt UInt32) + + | MLE_App ({ expr = MLE_Name p }, [ arg ]) + when string_of_mlpath p = "FStar.SizeT.sizet_to_uint64" -> + ECast (translate_expr env arg, TInt UInt64) + + | MLE_App (head, args) -> + EApp (translate_expr env head, List.map (translate_expr env) args) + + | MLE_TApp (head, ty_args) -> + ETypApp (translate_expr env head, List.map (translate_type env) ty_args) + + | MLE_Coerce (e, t_from, t_to) -> + ECast (translate_expr env e, translate_type env t_to) + + | MLE_Record (_, _, fields) -> + EFlat (assert_lid env e.mlty, List.map (fun (field, expr) -> + field, translate_expr env expr) fields) + + | MLE_Proj (e, path) -> + EField (assert_lid env e.mlty, translate_expr env e, snd path) + + | MLE_Let _ -> + (* Things not supported (yet): let-bindings for functions; meaning, rec flags are not + * supported, and quantified type schemes are not supported either *) + failwith (BU.format1 "todo: translate_expr [MLE_Let] (expr is: %s)" + (ML.Code.string_of_mlexpr ([],"") e)) + | MLE_App (head, _) -> + failwith (BU.format1 "todo: translate_expr [MLE_App] (head is: %s)" + (ML.Code.string_of_mlexpr ([], "") head)) + | MLE_Seq seqs -> + ESequence (List.map (translate_expr env) seqs) + | MLE_Tuple es -> + ETuple (List.map (translate_expr env) es) + + | MLE_CTor ((_, cons), es) -> + ECons (assert_lid env e.mlty, cons, List.map (translate_expr env) es) + + | MLE_Fun (bs, body) -> + let binders = translate_binders env bs in + let env = add_binders env bs in + EFun (binders, translate_expr env body, translate_type env body.mlty) + + | MLE_If (e1, e2, e3) -> + EIfThenElse (translate_expr env e1, translate_expr env e2, (match e3 with + | None -> EUnit + | Some e3 -> translate_expr env e3)) + | MLE_Raise _ -> + failwith "todo: translate_expr [MLE_Raise]" + | MLE_Try _ -> + failwith "todo: translate_expr [MLE_Try]" + | MLE_Coerce _ -> + failwith "todo: translate_expr [MLE_Coerce]" + +and assert_lid env t = + match t with + | MLTY_Named (ts, lid) -> + if List.length ts > 0 then + TApp (lid, List.map (translate_type env) ts) + else + TQualified lid + | _ -> failwith (BU.format1 "invalid argument: expected MLTY_Named, got %s" + (ML.Code.string_of_mlty ([], "") t)) + +and translate_branches env branches = + List.map (translate_branch env) branches + +and translate_branch env (pat, guard, expr) = + if guard = None then + let env, pat = translate_pat env pat in + pat, translate_expr env expr + else + failwith "todo: translate_branch" + +and translate_width = function + | None -> CInt + | Some (FC.Signed, FC.Int8) -> Int8 + | Some (FC.Signed, FC.Int16) -> Int16 + | Some (FC.Signed, FC.Int32) -> Int32 + | Some (FC.Signed, FC.Int64) -> Int64 + | Some (FC.Unsigned, FC.Int8) -> UInt8 + | Some (FC.Unsigned, FC.Int16) -> UInt16 + | Some (FC.Unsigned, FC.Int32) -> UInt32 + | Some (FC.Unsigned, FC.Int64) -> UInt64 + | Some (FC.Unsigned, FC.Sizet) -> SizeT + +and translate_pat env p = + match p with + | MLP_Const MLC_Unit -> + env, PUnit + | MLP_Const (MLC_Bool b) -> + env, PBool b + | MLP_Const (MLC_Int (s, sw)) -> + env, PConstant (translate_width sw, s) + | MLP_Var name -> + let env = extend env name in + env, PVar ({ name = name; typ = TAny; mut = false; meta = [] }) + | MLP_Wild -> + let env = extend env "_" in + env, PVar ({ name = "_"; typ = TAny; mut = false; meta = [] }) + | MLP_CTor ((_, cons), ps) -> + let env, ps = List.fold_left (fun (env, acc) p -> + let env, p = translate_pat env p in + env, p :: acc + ) (env, []) ps in + env, PCons (cons, List.rev ps) + | MLP_Record (_, ps) -> + let env, ps = List.fold_left (fun (env, acc) (field, p) -> + let env, p = translate_pat env p in + env, (field, p) :: acc + ) (env, []) ps in + env, PRecord (List.rev ps) + + | MLP_Tuple ps -> + let env, ps = List.fold_left (fun (env, acc) p -> + let env, p = translate_pat env p in + env, p :: acc + ) (env, []) ps in + env, PTuple (List.rev ps) + + | MLP_Const _ -> + failwith "todo: translate_pat [MLP_Const]" + | MLP_Branch _ -> + failwith "todo: translate_pat [MLP_Branch]" + +and translate_constant c: expr = + match c with + | MLC_Unit -> + EUnit + | MLC_Bool b -> + EBool b + | MLC_String s -> + if FStar.String.list_of_string s + |> BU.for_some (fun (c:FStar.Char.char) -> c = FStar.Char.char_of_int 0) + then failwith (BU.format1 "Refusing to translate a string literal that contains a null character: %s" s); + EString s + | MLC_Char c -> + let i = BU.int_of_char c in + let s = BU.string_of_int i in + let c = EConstant (CInt, s) in + let char_of_int = EQualified (["FStar"; "Char"], "char_of_int") in + EApp(char_of_int, [c]) + | MLC_Int (s, Some (sg, wd)) -> + EConstant (translate_width (Some (sg, wd)), s) + | MLC_Float _ -> + failwith "todo: translate_expr [MLC_Float]" + | MLC_Bytes _ -> + failwith "todo: translate_expr [MLC_Bytes]" + | MLC_Int (s, None) -> + EConstant (CInt, s) + +(* Helper functions **********************************************************) + +and mk_op_app env w op args = + EApp (EOp (op, w), List.map (translate_expr env) args) + +let translate_type_decl' env ty: option decl = + match ty with + | {tydecl_assumed=assumed; + tydecl_name=name; + tydecl_parameters=args; + tydecl_meta=flags; + tydecl_defn= Some (MLTD_Abbrev t)} -> + let name = env.module_name, name in + let env = List.fold_left (fun env {ty_param_name} -> extend_t env ty_param_name) env args in + if assumed && List.mem Syntax.CAbstract flags then + Some (DTypeAbstractStruct name) + else if assumed then + let name = string_of_mlpath name in + BU.print1_warning "Not extracting type definition %s to KaRaMeL (assumed type)\n" name; + // JP: TODO: shall we be smarter here? + None + else + Some (DTypeAlias (name, translate_flags flags, List.length args, translate_type env t)) + + | {tydecl_name=name; + tydecl_parameters=args; + tydecl_meta=flags; + tydecl_defn=Some (MLTD_Record fields)} -> + let name = env.module_name, name in + let env = List.fold_left (fun env {ty_param_name} -> extend_t env ty_param_name) env args in + Some (DTypeFlat (name, translate_flags flags, List.length args, List.map (fun (f, t) -> + f, (translate_type_without_decay env t, false)) fields)) + + | {tydecl_name=name; + tydecl_parameters=args; + tydecl_meta=flags; + tydecl_defn=Some (MLTD_DType branches)} -> + let name = env.module_name, name in + let flags = translate_flags flags in + let env = args |> ty_param_names |> List.fold_left extend_t env in + Some (DTypeVariant (name, flags, List.length args, List.map (fun (cons, ts) -> + cons, List.map (fun (name, t) -> + name, (translate_type_without_decay env t, false) + ) ts + ) branches)) + | {tydecl_name=name} -> + // JP: TODO: figure out why and how this happens + Errors.log_issue0 Errors.Warning_DefinitionNotTranslated [ + Errors.Msg.text <| BU.format1 "Error extracting type definition %s to KaRaMeL." name; + ]; + None + +let translate_let' env flavor lb: option decl = + match lb with + | { + mllb_name = name; + mllb_tysc = Some (tvars, t0); + mllb_def = e; + mllb_meta = meta + } when BU.for_some (function Syntax.Assumed -> true | _ -> false) meta -> + let name = env.module_name, name in + let arg_names = match e.expr with + | MLE_Fun (bs, _) -> List.map (fun {mlbinder_name} -> mlbinder_name) bs + | _ -> [] + in + if List.length tvars = 0 then + Some (DExternal (translate_cc meta, translate_flags meta, name, translate_type env t0, arg_names)) + else begin + BU.print1_warning "Not extracting %s to KaRaMeL (polymorphic assumes are not supported)\n" (Syntax.string_of_mlpath name); + None + end + + | { + mllb_name = name; + mllb_tysc = Some (tvars, t0); + mllb_def = { expr = MLE_Fun (args, body) }; + mllb_meta = meta + } -> + if List.mem Syntax.NoExtract meta then + None + else + // Case 1: a possibly-polymorphic function. + let env = if flavor = Rec then extend env name else env in + let env = tvars |> ty_param_names |> List.fold_left (fun env name -> extend_t env name) env in + let rec find_return_type eff i = function + | MLTY_Fun (_, eff, t) when i > 0 -> + find_return_type eff (i - 1) t + | t -> + i, eff, t + in + let name = env.module_name, name in + let i, eff, t = find_return_type E_PURE (List.length args) t0 in + if i > 0 then begin + let msg = "function type annotation has less arrows than the \ + number of arguments; please mark the return type abbreviation as \ + inline_for_extraction" in + BU.print2_warning "Not extracting %s to KaRaMeL (%s)\n" (Syntax.string_of_mlpath name) msg + end; + let t = translate_type env t in + let binders = translate_binders env args in + let env = add_binders env args in + let cc = translate_cc meta in + let meta = match eff, t with + | E_ERASABLE, _ + | E_PURE, TUnit -> MustDisappear :: translate_flags meta + | _ -> translate_flags meta + in + begin try + let body = translate_expr env body in + Some (DFunction (cc, meta, List.length tvars, t, name, binders, body)) + with e -> + // JP: TODO: figure out what are the remaining things we don't extract + let msg = BU.print_exn e in + Errors.log_issue0 Errors.Warning_FunctionNotExtacted [ + Errors.Msg.text <| BU.format1 "Error while extracting %s to KaRaMeL." (Syntax.string_of_mlpath name); + Pprint.arbitrary_string msg; + ]; + let msg = "This function was not extracted:\n" ^ msg in + Some (DFunction (cc, meta, List.length tvars, t, name, binders, EAbortS msg)) + end + + | { + mllb_name = name; + mllb_tysc = Some (tvars, t); + mllb_def = expr; + mllb_meta = meta + } -> + if List.mem Syntax.NoExtract meta then + None + else + // Case 2: this is a global + let meta = translate_flags meta in + let env = tvars |> ty_param_names |> List.fold_left (fun env name -> extend_t env name) env in + let t = translate_type env t in + let name = env.module_name, name in + begin try + let expr = translate_expr env expr in + Some (DGlobal (meta, name, List.length tvars, t, expr)) + with e -> + Errors.log_issue0 Errors.Warning_DefinitionNotTranslated [ + Errors.Msg.text <| BU.format1 "Error extracting %s to KaRaMeL." (Syntax.string_of_mlpath name); + Pprint.arbitrary_string (BU.print_exn e); + ]; + Some (DGlobal (meta, name, List.length tvars, t, EAny)) + end + + | { mllb_name = name; mllb_tysc = ts } -> + // TODO JP: figure out what exactly we're hitting here...? + Errors.log_issue0 Errors.Warning_DefinitionNotTranslated + (BU.format1 "Not extracting %s to KaRaMeL\n" name); + begin match ts with + | Some (tps, t) -> + BU.print2 "Type scheme is: forall %s. %s\n" + (String.concat ", " (ty_param_names tps)) + (ML.Code.string_of_mlty ([], "") t) + | None -> + () + end; + None + +let translate_let_t = env -> mlletflavor -> mllb -> ML (option decl) +(* translate_let' is not recursive, so we can directly use it to initialize ref_translate_let *) +let ref_translate_let : ref translate_let_t = mk_ref translate_let' +let register_pre_translate_let + (f: translate_let_t) +: ML unit += let before : translate_let_t = !ref_translate_let in + let after : translate_let_t = fun e fl lb -> + try + f e fl lb + with NotSupportedByKrmlExtension -> before e fl lb + in + ref_translate_let := after +let translate_let env flavor lb: option decl = + !ref_translate_let env flavor lb + +let translate_decl env d: list decl = + match d.mlmodule1_m with + | MLM_Let (flavor, lbs) -> + // We don't care about mutual recursion, since every C file will include + // its own header with the forward declarations. + List.choose (translate_let env flavor) lbs + + | MLM_Loc _ -> + // JP: TODO: use this to reconstruct location information + [] + + | MLM_Ty tys -> + // We don't care about mutual recursion, since KaRaMeL will insert forward + // declarations exactly as needed, as part of its monomorphization phase + List.choose (translate_type_decl env) tys + + | MLM_Top _ -> + failwith "todo: translate_decl [MLM_Top]" + + | MLM_Exn (m, _) -> + BU.print1_warning "Not extracting exception %s to KaRaMeL (exceptions unsupported)\n" m; + [] + +let translate_module uenv (m : mlpath & option (mlsig & mlmodule) & mllib) : file = + let (module_name, modul, _) = m in + let module_name = fst module_name @ [ snd module_name ] in + let program = match modul with + | Some (_signature, decls) -> + List.collect (translate_decl (empty uenv module_name)) decls + | _ -> + failwith "Unexpected standalone interface or nested modules" + in + (String.concat "_" module_name), program + +let translate (ue:uenv) (MLLib modules): list file = + List.filter_map (fun m -> + let m_name = + let path, _, _ = m in + Syntax.string_of_mlpath path + in + try + if not (Options.silent()) then (BU.print1 "Attempting to translate module %s\n" m_name); + Some (translate_module ue m) + with + | e -> + BU.print2 "Unable to translate module: %s because:\n %s\n" + m_name (BU.print_exn e); + None + ) modules + +let _ = + register_post_translate_type_without_decay translate_type_without_decay'; + register_post_translate_type translate_type'; + register_post_translate_type_decl translate_type_decl'; + register_post_translate_expr translate_expr' diff --git a/src/extraction/FStarC.Extraction.Krml.fsti b/src/extraction/FStarC.Extraction.Krml.fsti new file mode 100644 index 00000000000..cab8aca5c69 --- /dev/null +++ b/src/extraction/FStarC.Extraction.Krml.fsti @@ -0,0 +1,36 @@ +(* + Copyright 2008-2017 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +(* -------------------------------------------------------------------- *) +module FStarC.Extraction.Krml + +open FStarC +open FStarC.Class.Show + +type version = int +val current_version: version (* version of AST type, for binary compatibility *) + +val decl : Type0 + +instance val showable_decl : showable decl + +type program = list decl +type file = string & program + +(** Versioned binary writing/reading of ASTs. + Serialization/parsing is with output_value/input_value. *) +type binary_format = version & list file + +val translate : Extraction.ML.UEnv.uenv -> FStarC.Extraction.ML.Syntax.mllib -> list file diff --git a/src/extraction/FStarC.Extraction.ML.Code.fst b/src/extraction/FStarC.Extraction.ML.Code.fst new file mode 100644 index 00000000000..300e487bdb5 --- /dev/null +++ b/src/extraction/FStarC.Extraction.ML.Code.fst @@ -0,0 +1,869 @@ +(* + Copyright 2008-2015 Abhishek Anand, Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +(* -------------------------------------------------------------------- *) +module FStarC.Extraction.ML.Code +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.Extraction.ML +open FStarC.Extraction.ML.Syntax +open FStarC.Pprint +open FStarC.Const +open FStarC.BaseTypes +module BU = FStarC.Compiler.Util + +(* This is the old printer used exclusively for the F# build of F*. It will not + * evolve in the future. *) + +(* -------------------------------------------------------------------- *) +type assoc = | ILeft | IRight | Left | Right | NonAssoc +type fixity = | Prefix | Postfix | Infix of assoc +type opprec = int & fixity +type level = opprec & assoc + +let t_prio_fun = (10, Infix Right) +let t_prio_tpl = (20, Infix NonAssoc) +let t_prio_name = (30, Postfix) + +let e_bin_prio_lambda = ( 5, Prefix) +let e_bin_prio_if = (15, Prefix) +let e_bin_prio_letin = (19, Prefix) +let e_bin_prio_or = (20, Infix Left) +let e_bin_prio_and = (25, Infix Left) +let e_bin_prio_eq = (27, Infix NonAssoc) +let e_bin_prio_order = (29, Infix NonAssoc) +let e_bin_prio_op1 = (30, Infix Left) +let e_bin_prio_op2 = (40, Infix Left) +let e_bin_prio_op3 = (50, Infix Left) +let e_bin_prio_op4 = (60, Infix Left) +let e_bin_prio_comb = (70, Infix Left) +let e_bin_prio_seq = (100, Infix Left) +let e_app_prio = (10000, Infix Left) + +let min_op_prec = (-1, Infix NonAssoc) +let max_op_prec = (max_int, Infix NonAssoc) + +(* Little helpers *) + +let empty = Doc "" +let hardline = Doc "\n" + +let text (s : string) = Doc s +let num (i : int) = Doc (string_of_int i) + +let break1 = text " " + +let enclose (Doc l) (Doc r) (Doc x) = + Doc (l^x^r) + +let cbrackets (Doc d) = enclose (text "{") (text "}") (Doc d) +let parens (Doc d ) = enclose (text "(") (text ")") (Doc d) + +let cat (Doc d1) (Doc d2) = Doc (d1 ^ d2) + +let reduce (docs : list doc) = + List.fold_left cat empty docs + +let combine (Doc sep) (docs : list doc) = + let select (Doc d) = if d = "" then None else Some d in + let docs = List.choose select docs in + Doc (String.concat sep docs) + +let reduce1 (docs : list doc) = + combine break1 docs + +let hbox (d : doc) = d (* FIXME *) + +(*copied from ocaml-asttrans.fs*) + +(* -------------------------------------------------------------------- *) +let rec in_ns (x: (list 'a & list 'a)) : bool = match x with + | [], _ -> true + | x1::t1, x2::t2 when (x1 = x2) -> in_ns (t1, t2) + | _, _ -> false + +(* -------------------------------------------------------------------- *) +let path_of_ns (currentModule : mlsymbol) ns = + let ns' = Util.flatten_ns ns in + if ns' = currentModule + then [] + else let cg_libs = Options.codegen_libs() in + let ns_len = List.length ns in + let found = BU.find_map cg_libs (fun cg_path -> + let cg_len = List.length cg_path in + if List.length cg_path < ns_len + then let pfx, sfx = BU.first_N cg_len ns in + if pfx = cg_path + then Some (pfx@[Util.flatten_ns sfx]) + else None + else None) in + match found with + | None -> [ns'] + | Some x -> x + +let mlpath_of_mlpath (currentModule : mlsymbol) (x : mlpath) : mlpath = + match string_of_mlpath x with + | "Prims.Some" -> ([], "Some") + | "Prims.None" -> ([], "None") + | _ -> + let ns, x = x in + (path_of_ns currentModule ns, x) + +let ptsym_of_symbol (s : mlsymbol) : mlsymbol = + if FStar.Char.lowercase (String.get s 0) <> String.get s 0 + then "l__" ^ s + else s + +let ptsym (currentModule : mlsymbol) (mlp : mlpath) : mlsymbol = + if (List.isEmpty (fst mlp)) + then ptsym_of_symbol (snd mlp) + else + let (p, s) = mlpath_of_mlpath currentModule mlp in + String.concat "." (p @ [ptsym_of_symbol s]) + + +let ptctor (currentModule : mlsymbol) (mlp : mlpath) : mlsymbol = + let (p, s) = mlpath_of_mlpath currentModule mlp in + let s = if FStar.Char.uppercase (String.get s 0) <> String.get s 0 then "U__" ^ s else s in + String.concat "." (p @ [s]) + +(* -------------------------------------------------------------------- *) +let infix_prim_ops = [ + ("op_Addition" , e_bin_prio_op1 , "+" ); + ("op_Subtraction" , e_bin_prio_op1 , "-" ); + ("op_Multiply" , e_bin_prio_op1 , "*" ); + ("op_Division" , e_bin_prio_op1 , "/" ); + ("op_Equality" , e_bin_prio_eq , "=" ); + ("op_Colon_Equals" , e_bin_prio_eq , ":="); + ("op_disEquality" , e_bin_prio_eq , "<>"); + ("op_AmpAmp" , e_bin_prio_and , "&&"); + ("op_BarBar" , e_bin_prio_or , "||"); + ("op_LessThanOrEqual" , e_bin_prio_order , "<="); + ("op_GreaterThanOrEqual", e_bin_prio_order , ">="); + ("op_LessThan" , e_bin_prio_order , "<" ); + ("op_GreaterThan" , e_bin_prio_order , ">" ); + ("op_Modulus" , e_bin_prio_order , "mod" ); +] + +(* -------------------------------------------------------------------- *) +let prim_uni_ops () = + let op_minus = if Util.codegen_fsharp() + then "-" + else "~-" in + [ ("op_Negation", "not"); + ("op_Minus", op_minus); + ("op_Bang","Support.ST.read") ] + +(* -------------------------------------------------------------------- *) +let prim_types = [] + +(* -------------------------------------------------------------------- *) +let prim_constructors = [ + ("Some", "Some"); + ("None", "None"); + ("Nil", "[]"); + ("Cons", "::"); +] + +(* -------------------------------------------------------------------- *) +let is_prims_ns (ns : list mlsymbol) = + ns = ["Prims"] || ns = ["Prims"] + +(* -------------------------------------------------------------------- *) +let as_bin_op ((ns, x) : mlpath) = + if is_prims_ns ns then + List.tryFind (fun (y, _, _) -> x = y) infix_prim_ops + else + None + +(* -------------------------------------------------------------------- *) +let is_bin_op (p : mlpath) = + as_bin_op p <> None + +(* -------------------------------------------------------------------- *) +let as_uni_op ((ns, x) : mlpath) = + if is_prims_ns ns then + List.tryFind (fun (y, _) -> x = y) (prim_uni_ops ()) + else + None + +(* -------------------------------------------------------------------- *) +let is_uni_op (p : mlpath) = + as_uni_op p <> None + +(* -------------------------------------------------------------------- *) +let is_standard_type (p : mlpath) = false + +(* -------------------------------------------------------------------- *) +let as_standard_constructor ((ns, x) : mlpath) = + if is_prims_ns ns then + List.tryFind (fun (y, _) -> x = y) prim_constructors + else + None + +(* -------------------------------------------------------------------- *) +let is_standard_constructor (p : mlpath) = + as_standard_constructor p <> None + +(* -------------------------------------------------------------------- *) +let maybe_paren (outer, side) inner doc = + let noparens _inner _outer side = + let (pi, fi) = _inner in + let (po, fo) = _outer in + (pi > po) || + (match (fi, side) with + | Postfix , Left -> true + | Prefix , Right -> true + | Infix Left , Left -> (pi = po) && (fo = Infix Left ) + | Infix Right, Right -> (pi = po) && (fo = Infix Right) + | Infix Left , ILeft -> (pi = po) && (fo = Infix Left ) + | Infix Right, IRight -> (pi = po) && (fo = Infix Right) + | _ , NonAssoc -> (pi = po) && (fi = fo) + | _ , _ -> false) + in + + if noparens inner outer side then doc else parens doc + +(* -------------------------------------------------------------------- *) +let escape_byte_hex (x: byte) = + "\\x" ^ hex_string_of_byte x + +let escape_char_hex (x: char) = + escape_byte_hex (byte_of_char x) + +(* -------------------------------------------------------------------- *) +let escape_or fallback = function + | c when (c = '\\') -> "\\\\" + | c when (c = ' ' ) -> " " + | c when (c = '\b') -> "\\b" + | c when (c = '\t') -> "\\t" + | c when (c = '\r') -> "\\r" + | c when (c = '\n') -> "\\n" + | c when (c = '\'') -> "\\'" + | c when (c = '\"') -> "\\\"" + | c when (is_letter_or_digit c)-> string_of_char c + | c when (is_punctuation c) -> string_of_char c + | c when (is_symbol c) -> string_of_char c + | c -> fallback c + + +(* -------------------------------------------------------------------- *) +let string_of_mlconstant (sctt : mlconstant) = + match sctt with + | MLC_Unit -> "()" + | MLC_Bool true -> "true" + | MLC_Bool false -> "false" + | MLC_Char c -> (* Unicode characters, in OCaml we use BatUChar (wraper for int) *) + if Util.codegen_fsharp() then "'" ^ (string_of_char c) ^ "'" else + let nc = FStar.Char.int_of_char c in + (string_of_int nc) ^ (if nc >= 32 && nc = 127 && nc < 34 then " (*" ^ (string_of_char c) ^"*)" else "") + | MLC_Int (s, Some (Signed, Int32)) -> s ^"l" + | MLC_Int (s, Some (Signed, Int64)) -> s ^"L" + | MLC_Int (s, Some (_, Int8)) + | MLC_Int (s, Some (_, Int16)) -> s + | MLC_Int (v, Some (_, Sizet)) -> + let z = "(Prims.parse_int \"" ^ v ^ "\")" in + "(FStar_SizeT.uint_to_t (" ^ z ^ "))" + | MLC_Int (v, Some (s, w)) -> + let sign = match s with + | Signed -> "Int" + | Unsigned -> "UInt" in + let ws = match w with + | Int8 -> "8" + | Int16 -> "16" + | Int32 -> "32" + | Int64 -> "64" in + let z = "(Prims.parse_int \"" ^ v ^ "\")" in + let u = match s with + | Signed -> "" + | Unsigned -> "u" in + "(FStar_" ^ sign ^ ws ^ "." ^ u ^ "int_to_t (" ^ z ^ "))" + | MLC_Int (s, None) -> "(Prims.parse_int \"" ^s^ "\")" + | MLC_Float d -> string_of_float d + + | MLC_Bytes bytes -> + (* A byte buffer. Not meant to be readable. *) + "\"" ^ FStarC.Compiler.Bytes.f_encode escape_byte_hex bytes ^ "\"" + + | MLC_String chars -> + (* It was a string literal. Escape what was (likely) escaped originally. + Leave everything else as is. That way, we get the OCaml semantics, + which is that strings are series of bytes, and that if you happen to + provide some well-formed UTF-8 sequence (e.g. "héhé", which has length + 6), then you get the same well-formed UTF-8 sequence on exit. It is up + to userland to provide some UTF-8 compatible functions (e.g. + utf8_length). *) + "\"" ^ String.collect (escape_or string_of_char) chars ^ "\"" + + | _ -> failwith "TODO: extract integer constants properly into OCaml" + + +(* -------------------------------------------------------------------- *) +let string_of_etag = function + | E_PURE -> "" + | E_ERASABLE -> "Erased" + | E_IMPURE -> "Impure" + +let rec doc_of_mltype' (currentModule : mlsymbol) (outer : level) (ty : mlty) = + match ty with + | MLTY_Var x -> + let escape_tyvar s = + if BU.starts_with s "'_" //this denotes a weak type variable in OCaml; it cannot be written in source programs + then BU.replace_char s '_' 'u' + else s in + text (escape_tyvar x) + + | MLTY_Tuple tys -> + let doc = List.map (doc_of_mltype currentModule (t_prio_tpl, Left)) tys in + let doc = parens (hbox (combine (text " * ") doc)) in + doc + + | MLTY_Named (args, name) -> begin + let args = + match args with + | [] -> empty + | [arg] -> doc_of_mltype currentModule (t_prio_name, Left) arg + | _ -> + let args = List.map (doc_of_mltype currentModule (min_op_prec, NonAssoc)) args in + parens (hbox (combine (text ", ") args)) + + in + + let name = ptsym currentModule name in + + hbox (reduce1 [args; text name]) + end + + | MLTY_Fun (t1, et, t2) -> + let d1 = doc_of_mltype currentModule (t_prio_fun, Left ) t1 in + let d2 = doc_of_mltype currentModule (t_prio_fun, Right) t2 in + maybe_paren outer t_prio_fun (hbox (reduce1 [d1; text " -> "; d2])) + + | MLTY_Top -> + if Util.codegen_fsharp() + then text "obj" + else text "Obj.t" + + | MLTY_Erased -> + text "unit" + +and doc_of_mltype (currentModule : mlsymbol) (outer : level) (ty : mlty) = + doc_of_mltype' currentModule outer (Util.resugar_mlty ty) + +(* -------------------------------------------------------------------- *) +let rec doc_of_expr (currentModule : mlsymbol) (outer : level) (e : mlexpr) : doc = + match e.expr with + | MLE_Coerce (e, t, t') -> + let doc = doc_of_expr currentModule (min_op_prec, NonAssoc) e in + if Util.codegen_fsharp() + then parens (reduce [text "Prims.unsafe_coerce "; doc]) + else parens (reduce [text "Obj.magic "; parens doc]) + + | MLE_Seq es -> + let docs = List.map (doc_of_expr currentModule (min_op_prec, NonAssoc)) es in + let docs = List.map (fun d -> reduce [d; text ";"; hardline]) docs in + parens (reduce docs) + + | MLE_Const c -> + text (string_of_mlconstant c) + + | MLE_Var x -> + text x + + | MLE_Name path -> + text (ptsym currentModule path) + + | MLE_Record (path, _, fields) -> + let for1 (name, e) = + let doc = doc_of_expr currentModule (min_op_prec, NonAssoc) e in + reduce1 [text (ptsym currentModule (path, name)); text "="; doc] in + + cbrackets (combine (text "; ") (List.map for1 fields)) + + | MLE_CTor (ctor, []) -> + let name = + if is_standard_constructor ctor then + snd (Option.get (as_standard_constructor ctor)) + else + ptctor currentModule ctor in + text name + + | MLE_CTor (ctor, args) -> + let name = + if is_standard_constructor ctor then + snd (Option.get (as_standard_constructor ctor)) + else + ptctor currentModule ctor in + let args = List.map (doc_of_expr currentModule (min_op_prec, NonAssoc)) args in + let doc = + match name, args with + (* Special case for Cons *) + | "::", [x;xs] -> reduce [parens x; text "::"; xs] + | _, _ -> reduce1 [text name; parens (combine (text ", ") args)] in + maybe_paren outer e_app_prio doc + + | MLE_Tuple es -> + let docs = List.map (fun x -> parens (doc_of_expr currentModule (min_op_prec, NonAssoc) x)) es in + let docs = parens (combine (text ", ") docs) in + docs + + | MLE_Let ((rec_, lets), body) -> + let pre = + if e.loc <> dummy_loc + then reduce [hardline; doc_of_loc e.loc] + else empty + in + let doc = doc_of_lets currentModule (rec_, false, lets) in + let body = doc_of_expr currentModule (min_op_prec, NonAssoc) body in + parens (combine hardline [pre; doc; reduce1 [text "in"; body]]) + + | MLE_App (e, args) -> begin + match e.expr, args with + | MLE_Name p, [ + ({ expr = MLE_Fun ([ _ ], scrutinee) }); + ({ expr = MLE_Fun ([ {mlbinder_name=arg} ], possible_match)}) + ] when (string_of_mlpath p = "FStarC.Compiler.Effect.try_with" || + string_of_mlpath p = "FStar.All.try_with") -> + let branches = + match possible_match with + | ({ expr = MLE_Match ({ expr = MLE_Var arg' }, branches) }) when (arg = arg') -> + branches + | e -> + (* F* may reduce [match ... with ... -> e | ... -> e] into [e]. *) + [ (MLP_Wild, None, e) ] + in + doc_of_expr currentModule outer ({ + expr = MLE_Try (scrutinee, branches); + mlty = possible_match.mlty; + loc = possible_match.loc + }) + | (MLE_Name p, [e1; e2]) when is_bin_op p -> doc_of_binop currentModule p e1 e2 + + | (MLE_App ({expr=MLE_Name p},[unitVal]), [e1; e2]) when (is_bin_op p && unitVal=ml_unit) -> + doc_of_binop currentModule p e1 e2 + + | (MLE_Name p, [e1]) when is_uni_op p -> doc_of_uniop currentModule p e1 + + | (MLE_App ({expr=MLE_Name p},[unitVal]), [e1]) when (is_uni_op p && unitVal=ml_unit) -> doc_of_uniop currentModule p e1 + + | _ -> + let e = doc_of_expr currentModule (e_app_prio, ILeft) e in + let args = List.map (doc_of_expr currentModule (e_app_prio, IRight)) args in + parens (reduce1 (e :: args)) + end + + | MLE_Proj (e, f) -> + let e = doc_of_expr currentModule (min_op_prec, NonAssoc) e in + let doc = + if Util.codegen_fsharp() //field names are not qualified in F# + then reduce [e; text "."; text (snd f)] + else reduce [e; text "."; text (ptsym currentModule f)] in + doc + + | MLE_Fun (ids, body) -> + let bvar_annot x xt = + if Util.codegen_fsharp() //type inference in F# is not complete, particularly for field projections; so these annotations are needed + then reduce1 [text "("; text x ; + (match xt with | Some xxt -> reduce1 [text " : "; doc_of_mltype currentModule outer xxt] | _ -> text ""); + text ")"] + else text x in + let ids = List.map (fun {mlbinder_name=x;mlbinder_ty=xt} -> bvar_annot x (Some xt)) ids in + let body = doc_of_expr currentModule (min_op_prec, NonAssoc) body in + let doc = reduce1 [text "fun"; reduce1 ids; text "->"; body] in + parens doc + + | MLE_If (cond, e1, None) -> + let cond = doc_of_expr currentModule (min_op_prec, NonAssoc) cond in + let doc = + combine hardline [ + reduce1 [text "if"; cond; text "then"; text "begin"]; + doc_of_expr currentModule (min_op_prec, NonAssoc) e1; + text "end" + ] + + in maybe_paren outer e_bin_prio_if doc + + | MLE_If (cond, e1, Some e2) -> + let cond = doc_of_expr currentModule (min_op_prec, NonAssoc) cond in + let doc = + combine hardline [ + reduce1 [text "if"; cond; text "then"; text "begin"]; + doc_of_expr currentModule (min_op_prec, NonAssoc) e1; + reduce1 [text "end"; text "else"; text "begin"]; + doc_of_expr currentModule (min_op_prec, NonAssoc) e2; + text "end" + ] + + in maybe_paren outer e_bin_prio_if doc + + | MLE_Match (cond, pats) -> + let cond = doc_of_expr currentModule (min_op_prec, NonAssoc) cond in + let pats = List.map (doc_of_branch currentModule) pats in + let doc = reduce1 [text "match"; parens cond; text "with"] :: pats in + let doc = combine hardline doc in + + parens doc + + | MLE_Raise (exn, []) -> + reduce1 [text "raise"; text (ptctor currentModule exn)] + + | MLE_Raise (exn, args) -> + let args = List.map (doc_of_expr currentModule (min_op_prec, NonAssoc)) args in + reduce1 [text "raise"; text (ptctor currentModule exn); parens (combine (text ", ") args)] + + | MLE_Try (e, pats) -> + combine hardline [ + text "try"; + doc_of_expr currentModule (min_op_prec, NonAssoc) e; + text "with"; + combine hardline (List.map (doc_of_branch currentModule) pats) + ] + | MLE_TApp (head, ty_args) -> + // Type applications are only useful meta-data for backends without inference, for example Krml. + // We just skip them here. + doc_of_expr currentModule outer head +and doc_of_binop currentModule p e1 e2 : doc = + let (_, prio, txt) = Option.get (as_bin_op p) in + let e1 = doc_of_expr currentModule (prio, Left ) e1 in + let e2 = doc_of_expr currentModule (prio, Right) e2 in + let doc = reduce1 [e1; text txt; e2] in + parens doc + +and doc_of_uniop currentModule p e1 : doc = + let (_, txt) = Option.get (as_uni_op p) in + let e1 = doc_of_expr currentModule (min_op_prec, NonAssoc ) e1 in + let doc = reduce1 [text txt; parens e1] in + parens doc +(* -------------------------------------------------------------------- *) +and doc_of_pattern (currentModule : mlsymbol) (pattern : mlpattern) : doc = + match pattern with + | MLP_Wild -> text "_" + | MLP_Const c -> text (string_of_mlconstant c) + | MLP_Var x -> text x + + | MLP_Record (path, fields) -> + let for1 (name, p) = reduce1 [text (ptsym currentModule (path, name)); text "="; doc_of_pattern currentModule p] in + cbrackets (combine (text "; ") (List.map for1 fields)) + + | MLP_CTor (ctor, []) -> + let name = + if is_standard_constructor ctor then + snd (Option.get (as_standard_constructor ctor)) + else + ptctor currentModule ctor in + text name + + | MLP_CTor (ctor, pats) -> + let name = + if is_standard_constructor ctor then + snd (Option.get (as_standard_constructor ctor)) + else + ptctor currentModule ctor in + let doc = + match name, pats with + (* Special case for Cons *) + | "::", [x;xs] -> reduce [parens (doc_of_pattern currentModule x); text "::"; doc_of_pattern currentModule xs] + | _, [MLP_Tuple _] -> reduce1 [text name; doc_of_pattern currentModule (List.hd pats)] //no redundant parens; particularly if we have (T of a * b), we must generate T (x, y) not T ((x, y)) + | _ -> reduce1 [text name; parens (combine (text ", ") (List.map (doc_of_pattern currentModule) pats))] in + maybe_paren (min_op_prec, NonAssoc) e_app_prio doc + + | MLP_Tuple ps -> + let ps = List.map (doc_of_pattern currentModule) ps in + parens (combine (text ", ") ps) + + | MLP_Branch ps -> + let ps = List.map (doc_of_pattern currentModule) ps in + let ps = List.map parens ps in + combine (text " | ") ps + +(* -------------------------------------------------------------------- *) +and doc_of_branch (currentModule : mlsymbol) ((p, cond, e) : mlbranch) : doc = + let case = + match cond with + | None -> reduce1 [text "|"; doc_of_pattern currentModule p] + | Some c -> + let c = doc_of_expr currentModule (min_op_prec, NonAssoc) c in + reduce1 [text "|"; doc_of_pattern currentModule p; text "when"; c] in + + combine hardline [ + reduce1 [case; text "->"; text "begin"]; + doc_of_expr currentModule (min_op_prec, NonAssoc) e; + text "end"; + ] + +(* -------------------------------------------------------------------- *) +and doc_of_lets (currentModule : mlsymbol) (rec_, top_level, lets) = + let for1 {mllb_name=name; mllb_tysc=tys; mllb_def=e; print_typ=pt} = + let e = doc_of_expr currentModule (min_op_prec, NonAssoc) e in + //TODO: maybe extract the top-level binders from e and print it alongside name + //let f x = x + //let f = fun x -> x + //i.e., print the latter as the former + let ids = [] in + let ty_annot = + if (not pt) then text "" + else + if Util.codegen_fsharp () && (rec_ = Rec || top_level) //needed for polymorphic recursion and to overcome incompleteness of type inference in F# + then match tys with + | Some (_::_, _) | None -> //except, emitting binders for type variables in F# sometimes also requires emitting type constraints; which is not yet supported + text "" + | Some ([], ty) -> + let ty = doc_of_mltype currentModule (min_op_prec, NonAssoc) ty in + reduce1 [text ":"; ty] + else if top_level + then match tys with + | None -> + text "" + | Some ([], ty) -> + let ty = doc_of_mltype currentModule (min_op_prec, NonAssoc) ty in + reduce1 [text ":"; ty] + | Some (vs, ty) -> + let ty = doc_of_mltype currentModule (min_op_prec, NonAssoc) ty in + let vars = vs |> ty_param_names + |> List.map (fun x -> doc_of_mltype currentModule (min_op_prec, NonAssoc) (MLTY_Var x)) + |> reduce1 in + reduce1 [text ":"; vars; text "."; ty] + else text "" in + reduce1 [text name; reduce1 ids; ty_annot; text "="; e] in + + let letdoc = if rec_ = Rec then reduce1 [text "let"; text "rec"] else text "let" in + + let lets = List.map for1 lets in + let lets = List.mapi (fun i doc -> + reduce1 [(if i = 0 then letdoc else text "and"); doc]) + lets in + + combine hardline lets + + +and doc_of_loc (lineno, file) = + if (Options.no_location_info()) || Util.codegen_fsharp () || file=" dummy" then + empty + else + let file = BU.basename file in + reduce1 [ text "#"; num lineno; text ("\"" ^ file ^ "\"") ] + +(* -------------------------------------------------------------------- *) +let doc_of_mltydecl (currentModule : mlsymbol) (decls : mltydecl) = + let for1 ({tydecl_name=x; tydecl_ignored=mangle_opt; tydecl_parameters=tparams; tydecl_defn=body}) = + let x = match mangle_opt with + | None -> x + | Some y -> y in + let tparams = + let tparams = ty_param_names tparams in + match tparams with + | [] -> empty + | [x] -> text x + | _ -> + let doc = List.map (fun x -> (text x)) tparams in + parens (combine (text ", ") doc) in + + let forbody (body : mltybody) = + match body with + | MLTD_Abbrev ty -> + doc_of_mltype currentModule (min_op_prec, NonAssoc) ty + + | MLTD_Record fields -> begin + let forfield (name, ty) = + let name = text name in + let ty = doc_of_mltype currentModule (min_op_prec, NonAssoc) ty in + reduce1 [name; text ":"; ty] + + in cbrackets (combine (text "; ") (List.map forfield fields)) + end + + | MLTD_DType ctors -> + let forctor (name, tys) = + let _names, tys = List.split tys in + match tys with + | [] -> text name + | _ -> + let tys = List.map (doc_of_mltype currentModule (t_prio_tpl, Left)) tys in + let tys = combine (text " * ") tys in + reduce1 [text name; text "of"; tys] + in + + let ctors = List.map forctor ctors in + let ctors = List.map (fun d -> reduce1 [text "|"; d]) ctors in + combine hardline ctors + + in + + let doc = reduce1 [tparams; text (ptsym currentModule ([], x))] in + + match body with + | None -> doc + | Some body -> + let body = forbody body in + combine hardline [reduce1 [doc; text "="]; body] + + in + + let doc = List.map for1 decls in + let doc = if (List.length doc >0) then reduce1 [text "type"; combine (text " \n and ") doc] else text "" in + doc + +(* -------------------------------------------------------------------- *) +let rec doc_of_sig1 currentModule s = + match s with + | MLS_Mod (x, subsig) -> + combine hardline + [reduce1 [text "module"; text x; text "="]; + doc_of_sig currentModule subsig; + reduce1 [text "end"]] + + | MLS_Exn (x, []) -> + reduce1 [text "exception"; text x] + + | MLS_Exn (x, args) -> + let args = List.map (doc_of_mltype currentModule (min_op_prec, NonAssoc)) args in + let args = parens (combine (text " * ") args) in + reduce1 [text "exception"; text x; text "of"; args] + + | MLS_Val (x, (_, ty)) -> + let ty = doc_of_mltype currentModule (min_op_prec, NonAssoc) ty in + reduce1 [text "val"; text x; text ": "; ty] + + | MLS_Ty decls -> + doc_of_mltydecl currentModule decls + +(* -------------------------------------------------------------------- *) +and doc_of_sig (currentModule : mlsymbol) (s : mlsig) = + let docs = List.map (doc_of_sig1 currentModule) s in + let docs = List.map (fun x -> reduce [x; hardline; hardline]) docs in + reduce docs + + +(* -------------------------------------------------------------------- *) +let doc_of_mod1 (currentModule : mlsymbol) (m : mlmodule1) = + match m.mlmodule1_m with + | MLM_Exn (x, []) -> + reduce1 [text "exception"; text x] + + | MLM_Exn (x, args) -> + let args = List.map snd args in + let args = List.map (doc_of_mltype currentModule (min_op_prec, NonAssoc)) args in + let args = parens (combine (text " * ") args) in + reduce1 [text "exception"; text x; text "of"; args] + + | MLM_Ty decls -> + doc_of_mltydecl currentModule decls + + | MLM_Let (rec_, lets) -> + doc_of_lets currentModule (rec_, true, lets) + + | MLM_Top e -> + reduce1 [ + text "let"; text "_"; text "="; + doc_of_expr currentModule (min_op_prec, NonAssoc) e + ] + + | MLM_Loc loc -> + doc_of_loc loc + +(* -------------------------------------------------------------------- *) +let doc_of_mod (currentModule : mlsymbol) (m : mlmodule) = + let docs = List.map (fun x -> + let doc = doc_of_mod1 currentModule x in + [doc; (match x.mlmodule1_m with | MLM_Loc _ -> empty | _ -> hardline); hardline]) m in + reduce (List.flatten docs) + +(* -------------------------------------------------------------------- *) +let doc_of_mllib_r (MLLib mllib) = + let rec for1_sig (x, sigmod, MLLib sub) = + let x = Util.flatten_mlpath x in + let head = reduce1 [text "module"; text x; text ":"; text "sig"] in + let tail = reduce1 [text "end"] in + let doc = Option.map (fun (s, _) -> doc_of_sig x s) sigmod in + let sub = List.map for1_sig sub in + let sub = List.map (fun x -> reduce [x; hardline; hardline]) sub in + + reduce [ + cat head hardline; + (match doc with + | None -> empty + | Some s -> cat s hardline); + reduce sub; + cat tail hardline; + ] + and for1_mod istop (mod_name, sigmod, MLLib sub) = + let target_mod_name = Util.flatten_mlpath mod_name in + let maybe_open_pervasives = + match mod_name with + | ["FStar"], "Pervasives" -> [] + | _ -> + let pervasives = Util.flatten_mlpath (["FStar"], "Pervasives") in + [hardline; + text ("open " ^ pervasives)] + in + let head = reduce1 (if Util.codegen_fsharp() + then [text "module"; text target_mod_name] + else if not istop + then [text "module"; text target_mod_name; text "="; text "struct"] + else []) in + let tail = if not istop + then reduce1 [text "end"] + else reduce1 [] in + let doc = Option.map (fun (_, m) -> doc_of_mod target_mod_name m) sigmod in + let sub = List.map (for1_mod false) sub in + let sub = List.map (fun x -> reduce [x; hardline; hardline]) sub in + let prefix = if Util.codegen_fsharp() then [cat (text "#light \"off\"") hardline] else [] in + reduce <| (prefix @ [ + head; + hardline; + text "open Prims"] @ + maybe_open_pervasives @ + [hardline; + (match doc with + | None -> empty + | Some s -> cat s hardline); + reduce sub; + cat tail hardline; + ]) + + in + + let docs = List.map (fun (x,s,m) -> + (Util.flatten_mlpath x,for1_mod true (x,s,m))) mllib in + docs + +(* -------------------------------------------------------------------- *) +let pretty (sz : int) (Doc doc) = doc + +let doc_of_mllib mllib = + doc_of_mllib_r mllib + +let string_of_mlexpr cmod (e:mlexpr) = + let doc = doc_of_expr (Util.flatten_mlpath cmod) (min_op_prec, NonAssoc) e in + pretty 0 doc + +let string_of_mlty (cmod) (e:mlty) = + let doc = doc_of_mltype (Util.flatten_mlpath cmod) (min_op_prec, NonAssoc) e in + pretty 0 doc + +instance showable_mlexpr : showable mlexpr = { + show = string_of_mlexpr ([], ""); +} + +instance showable_mlty : showable mlty = { + show = string_of_mlty ([], ""); +} + +instance showable_etag : showable e_tag = { + show = string_of_etag +} diff --git a/src/extraction/FStarC.Extraction.ML.Code.fsti b/src/extraction/FStarC.Extraction.ML.Code.fsti new file mode 100644 index 00000000000..7c964b19c27 --- /dev/null +++ b/src/extraction/FStarC.Extraction.ML.Code.fsti @@ -0,0 +1,34 @@ +(* + Copyright 2008-2015 Abhishek Anand, Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +(* -------------------------------------------------------------------- *) +module FStarC.Extraction.ML.Code +open FStarC.Compiler.Effect + +open FStarC.Extraction.ML.Syntax +open FStarC.Class.Show +open FStarC.Pprint + +type doc = | Doc of string + +val doc_of_mllib : mllib -> list (string & doc) +val doc_of_sig : mlsymbol -> mlsig -> doc +val string_of_mlexpr: mlpath -> mlexpr -> string +val string_of_mlty: mlpath -> mlty -> string +val pretty: int -> doc -> string + +instance val showable_mlexpr : showable mlexpr +instance val showable_mlty : showable mlty +instance val showable_etag : showable e_tag \ No newline at end of file diff --git a/src/extraction/FStarC.Extraction.ML.Modul.fst b/src/extraction/FStarC.Extraction.ML.Modul.fst new file mode 100644 index 00000000000..3fb250f74bd --- /dev/null +++ b/src/extraction/FStarC.Extraction.ML.Modul.fst @@ -0,0 +1,1372 @@ +(* + Copyright 2008-2015 Abhishek Anand, Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Extraction.ML.Modul + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Compiler.Util +open FStarC.Const +open FStarC.Extraction.ML +open FStarC.Extraction.ML.RegEmb +open FStarC.Extraction.ML.UEnv +open FStarC.Extraction.ML.Util +open FStarC.Ident +open FStar.Pervasives +open FStarC.Syntax + +open FStarC.Syntax.Syntax +open FStarC.Extraction.ML.Syntax (* Intentionally shadows part of Syntax.Syntax *) + +open FStarC.Class.Show + +module Term = FStarC.Extraction.ML.Term +module MLS = FStarC.Extraction.ML.Syntax +module BU = FStarC.Compiler.Util +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module UF = FStarC.Syntax.Unionfind +module U = FStarC.Syntax.Util +module TC = FStarC.TypeChecker.Tc +module N = FStarC.TypeChecker.Normalize +module PC = FStarC.Parser.Const +module Util = FStarC.Extraction.ML.Util +module Env = FStarC.TypeChecker.Env +module TcUtil = FStarC.TypeChecker.Util +module EMB = FStarC.Syntax.Embeddings +module Cfg = FStarC.TypeChecker.Cfg +module PO = FStarC.TypeChecker.Primops + +let dbg_ExtractionReify = Debug.get_toggle "ExtractionReify" + +type tydef_declaration = (mlsymbol & FStarC.Extraction.ML.Syntax.metadata & int) //int is the arity + +type iface = { + iface_module_name: mlpath; + iface_bindings: list (fv & exp_binding); + iface_tydefs: list (either tydef tydef_declaration); + iface_type_names:list (fv & mlpath); +} + +let extension_extractor_table + : BU.smap extension_extractor + = FStarC.Compiler.Util.smap_create 20 + +let register_extension_extractor (ext:string) (callback:extension_extractor) = + FStarC.Compiler.Util.smap_add extension_extractor_table ext callback + +let lookup_extension_extractor (ext:string) = + (* Try to find a plugin if lookup fails *) + let do () = FStarC.Compiler.Util.smap_try_find extension_extractor_table ext in + match do () with + | None -> + if Plugins.autoload_plugin ext + then do () + else None + | r -> r + +type env_t = UEnv.uenv + +(*This approach assumes that failwith already exists in scope. This might be problematic, see below.*) +let fail_exp (lid:lident) (t:typ) = + mk (Tm_app {hd=S.fvar (PC.failwith_lid()) None; + args=[ S.iarg t + ; S.as_arg <| + mk (Tm_constant + (Const_string ("Not yet implemented: " ^ show lid, Range.dummyRange))) + Range.dummyRange]}) + Range.dummyRange + +let always_fail lid t = + let imp = + match U.arrow_formals t with + | [], t -> + // Avoid top-level failwith statements + let b = mk_binder <| (gen_bv "_" None t) in + U.abs [b] (fail_exp lid t) None + | bs, t -> + U.abs bs (fail_exp lid t) None + in + let lb = { + lbname=Inr (S.lid_as_fv lid None); + lbunivs=[]; + lbtyp=t; + lbeff=PC.effect_ML_lid(); + lbdef=imp; + lbattrs=[]; + lbpos=imp.pos; + } in + lb + +let as_pair = function + | [a;b] -> (a,b) + | _ -> failwith "Expected a list with 2 elements" + +let flag_of_qual : S.qualifier -> option meta = function + | S.Assumption -> Some Assumed + | S.Private -> Some Private + | S.NoExtract -> Some NoExtract + | _ -> None + +(*****************************************************************************) +(* Extracting type definitions from the signature *) +(*****************************************************************************) + +// So far, we recognize only a couple special attributes; they are encoded as +// type constructors for an inductive defined in Pervasives, to provide a minimal +// amount of typo-checking via desugaring. +let rec extract_meta x : option meta = + match SS.compress x with + | { n = Tm_fvar fv } -> + begin match string_of_lid (lid_of_fv fv) with + | "FStar.Pervasives.PpxDerivingShow" -> Some PpxDerivingShow + | "FStar.Pervasives.PpxDerivingYoJson" -> Some PpxDerivingYoJson + | "FStar.Pervasives.CInline" -> Some CInline + | "FStar.Pervasives.CNoInline" -> Some CNoInline + | "FStar.Pervasives.Substitute" -> Some Substitute + | "FStar.Pervasives.Gc" -> Some GCType + | "FStar.Pervasives.CAbstractStruct" -> Some CAbstract + | "FStar.Pervasives.CIfDef" -> Some CIfDef + | "FStar.Pervasives.CMacro" -> Some CMacro + | "Prims.deprecated" -> Some (Deprecated "") + | _ -> None + end + | { n = Tm_app {hd={ n = Tm_fvar fv }; args=[{ n = Tm_constant (Const_string (s, _)) }, _]} } -> + begin match string_of_lid (lid_of_fv fv) with + | "FStar.Pervasives.PpxDerivingShowConstant" -> Some (PpxDerivingShowConstant s) + | "FStar.Pervasives.Comment" -> Some (Comment s) + | "FStar.Pervasives.CPrologue" -> Some (CPrologue s) + | "FStar.Pervasives.CEpilogue" -> Some (CEpilogue s) + | "FStar.Pervasives.CConst" -> Some (CConst s) + | "FStar.Pervasives.CCConv" -> Some (CCConv s) + | "Prims.deprecated" -> Some (Deprecated s) + | _ -> None + end + | { n = Tm_constant (Const_string ("KrmlPrivate", _)) } -> Some Private // This one generated internally + // These are only for backwards compatibility, they should be removed at some point. + | { n = Tm_constant (Const_string ("c_inline", _)) } -> Some CInline + | { n = Tm_constant (Const_string ("substitute", _)) } -> Some Substitute + | { n = Tm_meta {tm=x} } -> extract_meta x + | _ -> + let head, args = U.head_and_args x in + match (SS.compress head).n, args with + | Tm_fvar fv, [_] + when S.fv_eq_lid fv FStarC.Parser.Const.remove_unused_type_parameters_lid -> + begin + match fst (FStarC.ToSyntax.ToSyntax.parse_attr_with_list + false x FStarC.Parser.Const.remove_unused_type_parameters_lid) + with + | None -> None + | Some l -> Some (RemoveUnusedTypeParameters (l, S.range_of_fv fv)) + end + | _ -> None + +let extract_metadata metas = + List.choose extract_meta metas + +let binders_as_mlty_binders (env:UEnv.uenv) bs : UEnv.uenv & list ty_param = + BU.fold_map + (fun env ({binder_bv=bv; binder_attrs}) -> + let env = UEnv.extend_ty env bv false in + let ty_param_name = + match lookup_bv env bv with + | Inl ty -> ty.ty_b_name + | _ -> failwith "Impossible" + in + let ty_param_attrs = + List.map (fun attr -> let e, _, _ = Term.term_as_mlexpr env attr in e) binder_attrs + in + env, {ty_param_name; ty_param_attrs}) + env bs + +(*******************************************************************************) +(* A more convenient representation of inductive types for extraction purposes *) +(*******************************************************************************) + +(*just enough info to generate OCaml code; add more info as needed*) +type data_constructor = { + dname: lident; + dtyp : typ; +} + +type inductive_family = { + ifv : fv; + iname : lident; + iparams: binders; + ityp : term; + idatas : list data_constructor; + iquals : list S.qualifier; + imetadata : metadata; +} + +let print_ifamily i = + BU.print4 "\n\t%s %s : %s { %s }\n" + (show i.iname) + (show i.iparams) + (show i.ityp) + (i.idatas + |> List.map (fun d -> + show d.dname + ^ " : " + ^ show d.dtyp) + |> String.concat "\n\t\t") + +let bundle_as_inductive_families env ses quals + : UEnv.uenv + & list inductive_family = + let env, ifams = + BU.fold_map + (fun env se -> match se.sigel with + | Sig_inductive_typ {lid=l; us; params=bs; t; ds=datas} -> + let _us, t = SS.open_univ_vars us t in + let bs, t = SS.open_term bs t in + let datas = ses |> List.collect (fun se -> match se.sigel with + | Sig_datacon {lid=d; us; t; ty_lid=l'; num_ty_params=nparams} when Ident.lid_equals l l' -> + let _us, t = SS.open_univ_vars us t in + let bs', body = U.arrow_formals t in + let bs_params, rest = BU.first_N (List.length bs) bs' in + let subst = List.map2 (fun ({binder_bv=b'}) ({binder_bv=b}) -> S.NT(b', S.bv_to_name b)) bs_params bs in + let t = U.arrow rest (S.mk_Total body) |> SS.subst subst in + [{dname=d; dtyp=t}] + | _ -> []) in + let metadata = extract_metadata se.sigattrs @ List.choose flag_of_qual quals in + let fv = S.lid_as_fv l None in + let _, env = UEnv.extend_type_name env fv in + env, [{ ifv = fv + ; iname=l + ; iparams=bs + ; ityp=t + ; idatas=datas + ; iquals=se.sigquals + ; imetadata = metadata }] + | _ -> env, []) + env ses in + env, List.flatten ifams + +(********************************************************************************************) +(* Extract Interfaces *) +(********************************************************************************************) + +let empty_iface = { + iface_module_name=[], ""; + iface_bindings = []; + iface_tydefs = []; + iface_type_names = [] +} + +let iface_of_bindings fvs = { + empty_iface with + iface_bindings = fvs; +} + +let iface_of_tydefs tds = { + empty_iface with + iface_tydefs = List.map Inl tds; + iface_type_names=List.map (fun td -> tydef_fv td, tydef_mlpath td) tds; +} + +let iface_of_type_names fvs = { + empty_iface with + iface_type_names = fvs +} + +let iface_union if1 if2 = { + iface_module_name = + (if if1.iface_module_name <> if1.iface_module_name + then failwith "Union not defined" + else if1.iface_module_name); + iface_bindings = if1.iface_bindings @ if2.iface_bindings; + iface_tydefs = if1.iface_tydefs @ if2.iface_tydefs; + iface_type_names = if1.iface_type_names @ if2.iface_type_names +} + +let iface_union_l ifs = List.fold_right iface_union ifs empty_iface + +let string_of_mlpath (p:mlpath) = + String.concat ". " (fst p @ [snd p]) +let tscheme_to_string cm ts = + (Code.string_of_mlty cm (snd ts)) +let print_exp_binding cm e = + BU.format3 "{\n\texp_b_name = %s\n\texp_b_expr = %s\n\texp_b_tscheme = %s }" + e.exp_b_name + (Code.string_of_mlexpr cm e.exp_b_expr) + (tscheme_to_string cm e.exp_b_tscheme) +let print_binding cm (fv, exp_binding) = + BU.format2 "(%s, %s)" + (show #Syntax.fv fv) + (print_exp_binding cm exp_binding) +let print_tydef cm tydef = + let name, defn = + match tydef with + | Inl tydef -> + show (tydef_fv tydef), + tscheme_to_string cm (tydef_def tydef) + | Inr (p, _, _) -> + p, "None" + in + BU.format2 "(%s, %s)" name defn +let iface_to_string iface = + let cm = iface.iface_module_name in + let print_type_name (tn, _) = show tn in + BU.format4 "Interface %s = {\niface_bindings=\n%s;\n\niface_tydefs=\n%s;\n\niface_type_names=%s;\n}" + (string_of_mlpath iface.iface_module_name) + (List.map (print_binding cm) iface.iface_bindings |> String.concat "\n") + (List.map (print_tydef cm) iface.iface_tydefs |> String.concat "\n") + (List.map print_type_name iface.iface_type_names |> String.concat "\n") +let gamma_to_string env = + let cm = current_module_of_uenv env in + let gamma = List.collect (function Fv (b, e) -> [b, e] | _ -> []) (bindings_of_uenv env) in + BU.format1 "Gamma = {\n %s }" + (List.map (print_binding cm) gamma |> String.concat "\n") + +let extract_attrs env (attrs:list S.attribute) : list mlattribute = + List.map (fun attr -> let e, _, _ = Term.term_as_mlexpr env attr in e) attrs + +(* Type abbreviations: + //extracting `type t = e` + //or `let t = e` when e is a type + + Extraction for interfaces and implementations is basically the same + + - The returned env is extended with the tydef + + - A tydef provides the representation of the abbreviation + unfolded all the way to a type constant, i.e., inductive or arrow + + - The list mlmodule1 returned is the concrete definition + of the abbreviation in ML, emitted only in the implementation +*) +let extract_typ_abbrev env quals attrs lb + : env_t + & iface + & list mlmodule1 = + let tcenv, (lbdef, lbtyp) = + let tcenv, _, def_typ = + Env.open_universes_in (tcenv_of_uenv env) lb.lbunivs [lb.lbdef; lb.lbtyp] + in + tcenv, as_pair def_typ + in + let lbtyp = FStarC.TypeChecker.Normalize.normalize [Env.Beta;Env.UnfoldUntil delta_constant; Env.ForExtraction] tcenv lbtyp in + //eta expansion is important; see issue #490 + let lbdef = FStarC.TypeChecker.Normalize.eta_expand_with_type tcenv lbdef lbtyp in + let fv = right lb.lbname in + let lid = fv.fv_name.v in + let def = SS.compress lbdef |> U.unmeta |> U.un_uinst in + let def = + match def.n with + | Tm_abs _ -> Term.normalize_abs def + | _ -> def in + let bs, body = + match def.n with + | Tm_abs {bs; body} -> + SS.open_term bs body + | _ -> [], def in + let assumed = BU.for_some (function Assumption -> true | _ -> false) quals in + let env1, ml_bs = binders_as_mlty_binders env bs in + let body = + Term.term_as_mlty env1 body |> Util.eraseTypeDeep (Util.udelta_unfold env1) + in + let metadata = + let has_val_decl = UEnv.has_tydef_declaration env lid in + let meta = extract_metadata attrs @ List.choose flag_of_qual quals in + if has_val_decl + then (//BU.print1 "%s has val decl\n" (Ident.string_of_lid lid); + HasValDecl (Ident.range_of_lid lid) :: meta) + else (//BU.print1 "%s does not have val decl\n" (Ident.string_of_lid lid); + meta) + in + let tyscheme = ml_bs, body in + let mlpath, iface, env = + if quals |> BU.for_some (function Assumption | New -> true | _ -> false) + then let mlp, env = UEnv.extend_type_name env fv in + mlp, iface_of_type_names [(fv, mlp)], env + else let td, mlp, env = UEnv.extend_tydef env fv tyscheme metadata in + mlp, iface_of_tydefs [td], env + in + let td = { + tydecl_assumed = assumed; + tydecl_name = snd mlpath; + tydecl_ignored = None; + tydecl_parameters = ml_bs; + tydecl_meta = metadata; + tydecl_defn = Some (MLTD_Abbrev body) + } in + let loc_mlmodule1 = MLM_Loc (Util.mlloc_of_range (Ident.range_of_lid lid)) in + let ty_mlmodule1 = MLM_Ty [td] in + let def = [mk_mlmodule1 loc_mlmodule1; + mk_mlmodule1_with_attrs ty_mlmodule1 (extract_attrs env attrs)] in + env, + iface, + def + +let extract_let_rec_type env quals attrs lb + : env_t + & iface + & list mlmodule1 = + let lbtyp = + FStarC.TypeChecker.Normalize.normalize + [Env.Beta; + Env.AllowUnboundUniverses; + Env.EraseUniverses; + Env.UnfoldUntil delta_constant; + Env.ForExtraction] + (tcenv_of_uenv env) + lb.lbtyp + in + let bs, _ = U.arrow_formals lbtyp in + let env1, ml_bs = binders_as_mlty_binders env bs in + let fv = right lb.lbname in + let lid = fv.fv_name.v in + let body = MLTY_Top in + let metadata = extract_metadata attrs @ List.choose flag_of_qual quals in + let assumed = false in + let tscheme = ml_bs, body in + let tydef, mlp, env = UEnv.extend_tydef env fv tscheme metadata in + let td = { + tydecl_assumed = assumed; + tydecl_name = snd mlp; + tydecl_ignored = None; + tydecl_parameters = ml_bs; + tydecl_meta = metadata; + tydecl_defn = Some (MLTD_Abbrev body) + } in + let loc_mlmodule1 = MLM_Loc (Util.mlloc_of_range (Ident.range_of_lid lid)) in + let td_mlmodule1 = MLM_Ty [td] in + let def = [mk_mlmodule1 loc_mlmodule1; + mk_mlmodule1_with_attrs td_mlmodule1 (extract_attrs env attrs)] in + let iface = iface_of_tydefs [tydef] in + env, + iface, + def + +(* extract_bundle_iface: + Extracts a bundle of inductive type definitions for an interface + + Effectively providing names and types to the data constructors + and arities for the type coonstructors +*) +let extract_bundle_iface env se + : env_t & iface = + let extract_ctor (env_iparams:env_t) + (ml_tyvars:list ty_param) + (env:env_t) + (ctor: data_constructor) + : env_t & (fv & exp_binding) = + let mlt = Util.eraseTypeDeep + (Util.udelta_unfold env_iparams) + (Term.term_as_mlty env_iparams ctor.dtyp) in + let tys = (ml_tyvars, mlt) in + let fvv = lid_as_fv ctor.dname None in + let env, _, b = extend_fv env fvv tys false in + env, (fvv, b) + in + + let extract_one_family env ind + : env_t & list (fv & exp_binding) = + let env_iparams, vars = binders_as_mlty_binders env ind.iparams in + let env, ctors = ind.idatas |> BU.fold_map (extract_ctor env_iparams vars) env in + let env = + match BU.find_opt (function RecordType _ -> true | _ -> false) ind.iquals with + | Some (RecordType (ns, ids)) -> + let g = + List.fold_right + (fun id g -> + let _, g = UEnv.extend_record_field_name g (ind.iname, id) in + g) + ids + env + in + g + | _ -> + env + in + env, ctors + in + + match se.sigel, se.sigquals with + | Sig_bundle {ses=[{sigel = Sig_datacon {lid=l; t}}]}, [ExceptionConstructor] -> + let env, ctor = extract_ctor env [] env ({dname=l; dtyp=t}) in + env, iface_of_bindings [ctor] + + | Sig_bundle {ses}, quals -> + if U.has_attribute se.sigattrs PC.erasable_attr + then env, empty_iface + else begin + let env, ifams = bundle_as_inductive_families env ses quals in + let env, td = BU.fold_map extract_one_family env ifams in + env, + iface_union + (iface_of_type_names (List.map (fun x -> x.ifv, UEnv.mlpath_of_lident env x.iname) ifams)) + (iface_of_bindings (List.flatten td)) + end + + | _ -> failwith "Unexpected signature element" + +let extract_type_declaration (g:uenv) is_interface_val lid quals attrs univs t + : env_t + & iface + & list mlmodule1 + = if not (quals |> BU.for_some (function Assumption -> true | _ -> false)) + then let g = UEnv.extend_with_tydef_declaration g lid in + g, empty_iface, [] + else let bs, _ = U.arrow_formals t in + let fv = S.lid_as_fv lid None in + let lb = { + lbname = Inr fv; + lbunivs = univs; + lbtyp = t; + lbeff = PC.effect_Tot_lid; + lbdef = U.abs bs t_unit None; + lbattrs = attrs; + lbpos = t.pos + } in + let g, iface, mods = extract_typ_abbrev g quals attrs lb in + let iface = + if is_interface_val + then let mlp = UEnv.mlpath_of_lident g lid in + let meta = extract_metadata attrs in + { empty_iface with iface_tydefs = [Inr (snd mlp, meta, List.length bs)] } + else iface + in + g, iface, mods + +let extract_reifiable_effect g ed + : uenv + & iface + & list mlmodule1 = + let extend_iface lid mlp exp exp_binding = + let fv = (S.lid_as_fv lid None) in + let lb = { + mllb_name=snd mlp; + mllb_tysc=None; + mllb_add_unit=false; + mllb_def=exp; + mllb_attrs=[]; + mllb_meta = []; + print_typ=false + } + in + iface_of_bindings [fv, exp_binding], mk_mlmodule1 (MLM_Let(NonRec, [lb])) + in + + let rec extract_fv tm = + if !dbg_ExtractionReify then + BU.print1 "extract_fv term: %s\n" (show tm); + match (SS.compress tm).n with + | Tm_uinst (tm, _) -> extract_fv tm + | Tm_fvar fv -> + let mlp = mlpath_of_lident g fv.fv_name.v in + let ({exp_b_tscheme=tysc}) = UEnv.lookup_fv tm.pos g fv in + with_ty MLTY_Top <| MLE_Name mlp, tysc + | _ -> failwith (BU.format2 "(%s) Not an fv: %s" + (Range.string_of_range tm.pos) + (show tm)) + in + + let extract_action g (a:S.action) = + assert (match a.action_params with | [] -> true | _ -> false); + if !dbg_ExtractionReify then + BU.print2 "Action type %s and term %s\n" + (show a.action_typ) + (show a.action_defn); + let lbname = Inl (S.new_bv (Some a.action_defn.pos) tun) in + let lb = mk_lb (lbname, a.action_univs, PC.effect_Tot_lid, a.action_typ, a.action_defn, [], a.action_defn.pos) in + let lbs = (false, [lb]) in + let action_lb = mk (Tm_let {lbs; body=U.exp_false_bool}) a.action_defn.pos in + let a_let, _, ty = Term.term_as_mlexpr g action_lb in + let exp, tysc = match a_let.expr with + | MLE_Let((_, [mllb]), _) -> + (match mllb.mllb_tysc with + | Some(tysc) -> mllb.mllb_def, tysc + | None -> failwith "No type scheme") + | _ -> failwith "Impossible" in + let a_nm, a_lid, exp_b, g = extend_with_action_name g ed a tysc in + if !dbg_ExtractionReify then + BU.print1 "Extracted action term: %s\n" (Code.string_of_mlexpr a_nm a_let); + if !dbg_ExtractionReify then begin + BU.print1 "Extracted action type: %s\n" (Code.string_of_mlty a_nm (snd tysc)); + List.iter (fun x -> BU.print1 "and binders: %s\n" x) (ty_param_names (fst tysc)) end; + let iface, impl = extend_iface a_lid a_nm exp exp_b in + g, (iface, impl) + in + + let g, return_iface, return_decl = + let return_tm, ty_sc = extract_fv (ed |> U.get_return_repr |> must |> snd) in + let return_nm, return_lid, return_b, g = extend_with_monad_op_name g ed "return" ty_sc in + let iface, impl = extend_iface return_lid return_nm return_tm return_b in + g, iface, impl + in + + let g, bind_iface, bind_decl = + let bind_tm, ty_sc = extract_fv (ed |> U.get_bind_repr |> must |> snd) in + let bind_nm, bind_lid, bind_b, g = extend_with_monad_op_name g ed "bind" ty_sc in + let iface, impl = extend_iface bind_lid bind_nm bind_tm bind_b in + g, iface, impl + in + + let g, actions = BU.fold_map extract_action g ed.actions in + let actions_iface, actions = List.unzip actions in + + g, + iface_union_l (return_iface::bind_iface::actions_iface), + return_decl::bind_decl::actions + +(* Returns false iff the letbinding are not homogeneous. The letbindings +are homogeneous when they all have the same "kind" (defining and arity +or a non-arity). *) +let should_split_let_rec_types_and_terms (env:uenv) (lbs:list letbinding) + : bool + = let rec is_homogeneous out lbs = + match lbs with + | [] -> true + | lb::lbs_tail -> + let is_type = Term.is_arity env lb.lbtyp in + match out with + | None -> is_homogeneous (Some is_type) lbs_tail + | Some b when b = is_type -> + is_homogeneous (Some is_type) lbs_tail + | _ -> + false + in + not (is_homogeneous None lbs) + +let split_let_rec_types_and_terms se (env:uenv) (lbs:list letbinding) + : list sigelt + = let rec aux (out:list sigelt) (mutuals:list letbinding) (lbs:list letbinding) + : (list sigelt & list letbinding) + = match lbs with + | [] -> out, mutuals + | lb::lbs_tail -> + let out, mutuals = aux out mutuals lbs_tail in + if not (Term.is_arity env lb.lbtyp) + then ( + //This is a term, not a type + out, lb::mutuals + ) + else ( + //This is a type; split it into a sigelt + let formals, body, rc_opt = U.abs_formals_maybe_unascribe_body true lb.lbdef in + let body = S.tconst PC.c_true_lid in //extract it not as unit, since otherwise it will be treated as erasable + let lbdef = U.abs formals body None in + let lb = { lb with lbdef } in + let se = { se with sigel = Sig_let {lbs=(false, [lb]); lids=[]} } in + se::out, mutuals + ) + in + let sigs, lbs = aux [] [] lbs in + let lb = {se with sigel = Sig_let {lbs=(true, lbs); + lids=List.map (fun lb -> lb.lbname |> BU.right |> lid_of_fv) lbs} } in + let sigs = sigs@[lb] in + // BU.print1 "Split let recs into %s\n" + // (List.map show sigs |> String.concat ";;\n"); + sigs + + +let extract_let_rec_types se (env:uenv) (lbs:list letbinding) = + //extracting `let rec t .. : Type = e + // and ... + if BU.for_some (fun lb -> not (Term.is_arity env lb.lbtyp)) lbs + then //mixtures of mutually recursively defined types and terms + //should have already been pre-processed away + failwith "Impossible: mixed mutual types and terms" + else + let env, iface_opt, impls = + List.fold_left + (fun (env, iface_opt, impls) lb -> + let env, iface, impl = + extract_let_rec_type env se.sigquals se.sigattrs lb + in + let iface_opt = + match iface_opt with + | None -> Some iface + | Some iface' -> Some (iface_union iface' iface) + in + (env, iface_opt, impl::impls)) + (env, None, []) + lbs + in + env, + Option.get iface_opt, + List.rev impls |> List.flatten + + +let get_noextract_to (se:sigelt) (backend:option Options.codegen_t) : bool = + BU.for_some (function attr -> + let hd, args = U.head_and_args attr in + match (SS.compress hd).n, args with + | Tm_fvar fv, [(a, _)] when S.fv_eq_lid fv PC.noextract_to_attr -> + begin match EMB.try_unembed a EMB.id_norm_cb with + | Some s -> + Option.isSome backend && Options.parse_codegen s = backend + | None -> + false + end + | _ -> false + ) se.sigattrs + +(* + * We support two kinds of noextract knobs: + * - a noextract qualifier + * - a "noextract_to" attribute that takes a string value as argument + * the string value is the backend name, e.g. Krml, OCaml, ... + * + * Whether to extract a definition depends on the backend + * since sometimes Karamel needs the stubs even for definitions + * marked as noextract + * + * TODO: what are such cases? Even there, can we optimize + * extraction to extract only the signature of the definition + * so that we don't pay the cost of normalization etc. for the body + *) +let sigelt_has_noextract (se:sigelt) : bool = + let has_noextract_qualifier = List.contains S.NoExtract se.sigquals in + let has_noextract_attribute = get_noextract_to se (Options.codegen ()) in + match Options.codegen () with + | Some Options.Krml -> + has_noextract_qualifier && has_noextract_attribute + | _ -> + has_noextract_qualifier || has_noextract_attribute + +// If this sigelt had [@@ noextract_to "krml"] and we are indeed +// extracting to Karamel, then we will still process it: it's the +// karamel pipeline which will later drop the body. It checks for the +// NoExtract qualifier to decide that, so we add it here. +let karamel_fixup_qual (se:sigelt) : sigelt = + if Options.codegen () = Some Options.Krml + && get_noextract_to se (Some Options.Krml) + && not (List.contains S.NoExtract se.sigquals) + then { se with sigquals = S.NoExtract :: se.sigquals } + else se + +let mark_sigelt_erased (se:sigelt) (g:uenv) : uenv = + debug g (fun u -> BU.print1 ">>>> NOT extracting %s \n" (Print.sigelt_to_string_short se)); + // Cheating with delta levels and qualifiers below, but we don't ever use them. + List.fold_right (fun lid g -> extend_erased_fv g (S.lid_as_fv lid None)) + (U.lids_of_sigelt se) g + +// If the definition has an [@@extract_as impl] attribute, +// replace the lbdef with the specified impl: +let fixup_sigelt_extract_as se = + match se.sigel, find_map se.sigattrs N.is_extract_as_attr with + | Sig_let {lids; lbs=(_, [lb])}, Some impl -> + // The specified implementation can be recursive, + // to be on the safe side we always mark the replaced sigelt as recursive. + {se with sigel = Sig_let {lids; lbs=(true, [{lb with lbdef = impl}])}} + | _ -> se + +(* The top-level extraction of a sigelt to an interface *) +let rec extract_sigelt_iface (g:uenv) (se:sigelt) : uenv & iface = + if sigelt_has_noextract se then + let g = mark_sigelt_erased se g in + g, empty_iface + else + let se = karamel_fixup_qual se in + let se = fixup_sigelt_extract_as se in + + match se.sigel with + | Sig_bundle _ + | Sig_inductive_typ _ + | Sig_datacon _ -> + extract_bundle_iface g se + + | Sig_declare_typ {lid; us=univs; t} when Term.is_arity g t -> //lid is a type + let env, iface, _ = + extract_type_declaration g true lid se.sigquals se.sigattrs univs t + in + env, iface + + | Sig_let {lbs=(false, [lb])} when Term.is_arity g lb.lbtyp -> + if se.sigquals |> BU.for_some (function Projector _ -> true | _ -> false) + then ( + //Don't extract projectors returning types---not useful for typing generated code and + //And can actually break F# extraction, in case there are unused type parameters + g, empty_iface + ) else ( + let env, iface, _ = + extract_typ_abbrev g se.sigquals se.sigattrs lb + in + env, iface + ) + + | Sig_let {lbs=(true, lbs)} + when should_split_let_rec_types_and_terms g lbs -> + let ses = split_let_rec_types_and_terms se g lbs in + let iface = {empty_iface with iface_module_name=(current_module_of_uenv g)} in + List.fold_left + (fun (g, out) se -> + let g, mls = extract_sigelt_iface g se in + g, iface_union out mls) + (g, iface) ses + + | Sig_let {lbs=(true, lbs)} + when BU.for_some (fun lb -> Term.is_arity g lb.lbtyp) lbs -> + let env, iface, _ = + extract_let_rec_types se g lbs + in + env, iface + + | Sig_declare_typ {lid; t} -> + let quals = se.sigquals in + if quals |> List.contains Assumption + && not (TcUtil.must_erase_for_extraction (tcenv_of_uenv g) t) + then let g, bindings = Term.extract_lb_iface g (false, [always_fail lid t]) in + g, iface_of_bindings bindings + else g, empty_iface //it's not assumed, so wait for the corresponding Sig_let to generate code + //or, it must be erased + + (* Extension extraction is only supported for non-recursive let bindings *) + | Sig_let { lbs=(false, [lb]) } when (Cons? se.sigmeta.sigmeta_extension_data) -> ( + match List.tryPick + (fun (ext, blob) -> + match lookup_extension_extractor ext with + | None -> None + | Some extractor -> Some (ext, blob, extractor)) + se.sigmeta.sigmeta_extension_data + with + | None -> + let g, bindings = Term.extract_lb_iface g (false, [lb]) in + g, iface_of_bindings bindings + | Some (ext, blob, extractor) -> + let res = extractor.extract_sigelt_iface g se blob in + match res with + | Inl res -> res + | Inr err -> + Errors.raise_error se Errors.Fatal_ExtractionUnsupported + (BU.format2 "Extension %s failed to extract iface: %s" ext err) + + ) + + | Sig_let {lbs} -> + let g, bindings = Term.extract_lb_iface g lbs in + g, iface_of_bindings bindings + + | Sig_assume _ + | Sig_sub_effect _ + | Sig_effect_abbrev _ + | Sig_polymonadic_bind _ + | Sig_polymonadic_subcomp _ -> + g, empty_iface + + | Sig_pragma (p) -> + U.process_pragma p se.sigrng; + g, empty_iface + + | Sig_splice _ -> + failwith "impossible: trying to extract splice" + + | Sig_fail _ -> + failwith "impossible: trying to extract Sig_fail" + + | Sig_new_effect ed -> + if TcUtil.effect_extraction_mode (tcenv_of_uenv g) ed.mname = S.Extract_reify + && List.isEmpty ed.binders //we do not extract parameterized effects + then let env, iface, _ = extract_reifiable_effect g ed in + env, iface + else g, empty_iface + +let extract_iface' (g:env_t) modul = + if Options.interactive() then g, empty_iface else + let _ = Options.restore_cmd_line_options true in + let decls = modul.declarations in + let iface = {empty_iface with iface_module_name=(current_module_of_uenv g)} in + let res = + List.fold_left (fun (g, iface) se -> + let g, iface' = extract_sigelt_iface g se in + g, iface_union iface iface') + (g, iface) + decls + in + ignore <| Options.restore_cmd_line_options true; + res + +let extract_iface (g:env_t) modul = + let g, iface = + UF.with_uf_enabled (fun () -> + if Debug.any() + then FStarC.Compiler.Util.measure_execution_time + (BU.format1 "Extracted interface of %s" (string_of_lid modul.name)) + (fun () -> extract_iface' g modul) + else extract_iface' g modul) + in + let g, _ = UEnv.with_typars_env g (fun e -> + let iface_tydefs : list RemoveUnusedParameters.tydef = + List.map + (function + | Inl td -> snd (UEnv.tydef_mlpath td), UEnv.tydef_meta td, Inl (UEnv.tydef_def td) + | Inr (p, m, n) -> p, m, Inr n) + iface.iface_tydefs + in + let module_name, _ = UEnv.extend_with_module_name g modul.name in + let e = RemoveUnusedParameters.set_current_module e module_name in + RemoveUnusedParameters.elim_tydefs e iface_tydefs) + in + UEnv.exit_module g, iface + +(********************************************************************************************) +(* Extract Implementations *) +(********************************************************************************************) + +let extract_bundle env se = + let extract_ctor (env_iparams:env_t) + (ml_tyvars:list ty_param) + (env:env_t) + (ctor: data_constructor): + env_t & (mlsymbol & list (mlsymbol & mlty)) + = + let mlt = Util.eraseTypeDeep (Util.udelta_unfold env_iparams) (Term.term_as_mlty env_iparams ctor.dtyp) in + let steps = [ Env.Inlining; Env.UnfoldUntil S.delta_constant; Env.EraseUniverses; Env.AllowUnboundUniverses; Env.ForExtraction ] in + let names = match (SS.compress (N.normalize steps (tcenv_of_uenv env_iparams) ctor.dtyp)).n with + | Tm_arrow {bs} -> + List.map (fun ({binder_bv={ ppname = ppname }}) -> (string_of_id ppname)) bs + | _ -> + [] + in + let tys = (ml_tyvars, mlt) in + let fvv = lid_as_fv ctor.dname None in + let env, mls, _ = extend_fv env fvv tys false in + env, + (mls, List.zip names (argTypes mlt)) in + + let extract_one_family env ind = + let env_iparams, vars = binders_as_mlty_binders env ind.iparams in + let env, ctors = ind.idatas |> BU.fold_map (extract_ctor env_iparams vars) env in + let indices, _ = U.arrow_formals ind.ityp in + let ml_params = List.append vars (indices |> List.mapi (fun i _ -> { + ty_param_name = "'dummyV" ^ BU.string_of_int i; + ty_param_attrs = [] + })) in + let tbody, env = + match BU.find_opt (function RecordType _ -> true | _ -> false) ind.iquals with + | Some (RecordType (ns, ids)) -> + let _, c_ty = List.hd ctors in + assert (List.length ids = List.length c_ty); + let fields, g = + List.fold_right2 + (fun id (_, ty) (fields, g) -> + let mlid, g = UEnv.extend_record_field_name g (ind.iname, id) in + (mlid, ty)::fields, g) + ids + c_ty + ([], env) + in + Some (MLTD_Record fields), g + | _ when List.length ctors = 0 -> + None, env + | _ -> + Some (MLTD_DType ctors), env + in + let td = { + tydecl_assumed = false; + tydecl_name = snd (mlpath_of_lident env ind.iname); + tydecl_ignored = None; + tydecl_parameters = ml_params; + tydecl_meta = ind.imetadata; + tydecl_defn = tbody + } in + env, + td + in + + let mlattrs = extract_attrs env se.sigattrs in + match se.sigel, se.sigquals with + | Sig_bundle {ses=[{sigel = Sig_datacon {lid=l; t}}]}, [ExceptionConstructor] -> + let env, ctor = extract_ctor env [] env ({dname=l; dtyp=t}) in + env, [mk_mlmodule1_with_attrs (MLM_Exn ctor) mlattrs] + + | Sig_bundle {ses}, quals -> + if U.has_attribute se.sigattrs PC.erasable_attr + then env, [] + else begin + let env, ifams = bundle_as_inductive_families env ses quals in + let env, td = BU.fold_map extract_one_family env ifams in + env, [mk_mlmodule1_with_attrs (MLM_Ty td) mlattrs] + end + + | _ -> failwith "Unexpected signature element" + +let lb_is_irrelevant (g:env_t) (lb:letbinding) : bool = + Env.non_informative (tcenv_of_uenv g) lb.lbtyp && // result type is non informative + not (Term.is_arity g lb.lbtyp) && // but not a type definition + U.is_pure_or_ghost_effect lb.lbeff // and not top-level effectful + +let lb_is_tactic (g:env_t) (lb:letbinding) : bool = + if U.is_pure_effect lb.lbeff then // not top-level effectful + let bs, c = U.arrow_formals_comp_ln lb.lbtyp in + let c_eff_name = c |> U.comp_effect_name |> Env.norm_eff_name (tcenv_of_uenv g) in + lid_equals c_eff_name PC.effect_TAC_lid + else + false + +(*****************************************************************************) +(* Extracting the top-level definitions in a module *) +(*****************************************************************************) +let rec extract_sig (g:env_t) (se:sigelt) : env_t & list mlmodule1 = + Errors.with_ctx (BU.format1 "While extracting top-level definition `%s`" (Print.sigelt_to_string_short se)) (fun () -> + debug g (fun u -> BU.print1 ">>>> extract_sig %s \n" (Print.sigelt_to_string_short se)); + + if sigelt_has_noextract se then + let g = mark_sigelt_erased se g in + g, [] + else begin + let se = karamel_fixup_qual se in + let se = fixup_sigelt_extract_as se in + + match se.sigel with + | Sig_bundle _ + | Sig_inductive_typ _ + | Sig_datacon _ -> + let g, ses = extract_bundle g se in + g, ses @ maybe_register_plugin g se + + | Sig_new_effect ed when Env.is_reifiable_effect (tcenv_of_uenv g) ed.mname -> + let env, _iface, impl = + extract_reifiable_effect g ed in + env, impl + + | Sig_splice _ -> + failwith "impossible: trying to extract splice" + + | Sig_fail _ -> + failwith "impossible: trying to extract Sig_fail" + + | Sig_new_effect _ -> + g, [] + + (* Ignore all non-informative sigelts *) + | Sig_let {lbs=(_, lbs)} when List.for_all (lb_is_irrelevant g) lbs -> + g, [] + + (* Ignore tactics whenever we're not extracting plugins *) + | Sig_let {lbs=(_, lbs)} + when Options.codegen () <> Some (Options.Plugin) && + List.for_all (lb_is_tactic g) lbs -> + g, [] + + | Sig_declare_typ {lid; us=univs; t} when Term.is_arity g t -> //lid is a type + //extracting `assume type t : k` + let env, _, impl = extract_type_declaration g false lid se.sigquals se.sigattrs univs t in + env, impl + + | Sig_let {lbs=(false, [lb])} when Term.is_arity g lb.lbtyp -> + //extracting `type t = e` + //or `let t = e` when e is a type + if se.sigquals |> BU.for_some (function Projector _ -> true | _ -> false) + then ( + //Don't extract projectors returning types---not useful for typing generated code and + //And can actually break F# extraction, in case there are unused type parameters + g, [] + ) else ( + let env, _, impl = + extract_typ_abbrev g se.sigquals se.sigattrs lb + in + env, impl + ) + + | Sig_let {lbs=(true, lbs)} + when should_split_let_rec_types_and_terms g lbs -> + let ses = split_let_rec_types_and_terms se g lbs in + List.fold_left + (fun (g, out) se -> + let g, mls = extract_sig g se in + g, out@mls) (g, []) ses + + | Sig_let {lbs=(true, lbs)} + when BU.for_some (fun lb -> Term.is_arity g lb.lbtyp) lbs -> + //extracting `let rec t .. : Type = e + // and ... + let env, _, impl = + extract_let_rec_types se g lbs + in + env, impl + + (* Extension extraction is only supported for non-recursive let bindings *) + | Sig_let { lbs=(false, [lb]) } when (Cons? se.sigmeta.sigmeta_extension_data) -> ( + match List.tryPick + (fun (ext, blob) -> + match lookup_extension_extractor ext with + | None -> None + | Some extractor -> Some (ext, blob, extractor)) + se.sigmeta.sigmeta_extension_data with + | None -> + extract_sig_let g se + + | Some (ext, blob, extractor) -> + match extractor.extract_sigelt g se blob with + | Inl decls -> + let meta = extract_metadata se.sigattrs in + let mlattrs = extract_attrs g se.sigattrs in + List.fold_left (fun (g, decls) d -> + match d.mlmodule1_m with + | MLM_Let (maybe_rec, [mllb]) -> + let g, mlid, _ = + UEnv.extend_lb g lb.lbname lb.lbtyp (must mllb.mllb_tysc) mllb.mllb_add_unit in + let mllb = { mllb with mllb_name = mlid; mllb_attrs = mlattrs; mllb_meta = meta } in + g, decls@[mk_mlmodule1_with_attrs (MLM_Let (maybe_rec, [mllb])) mlattrs] + | _ -> + failwith (BU.format1 "Unexpected ML decl returned by the extension: %s" (show d)) + ) (g, []) decls + | Inr err -> + Errors.raise_error se Errors.Fatal_ExtractionUnsupported + (BU.format2 "Extension %s failed to extract term: %s" ext err) + ) + + | Sig_let _ -> extract_sig_let g se + + | Sig_declare_typ {lid; t} -> + let quals = se.sigquals in + if quals |> List.contains Assumption + && not (TcUtil.must_erase_for_extraction (tcenv_of_uenv g) t) + then let always_fail = + { se with sigel = Sig_let {lbs=(false, [always_fail lid t]); lids=[]} } in + let g, mlm = extract_sig g always_fail in //extend the scope with the new name + match BU.find_map quals (function Discriminator l -> Some l | _ -> None) with + | Some l -> //if it's a discriminator, generate real code for it, rather than mlm + g, [mk_mlmodule1 (MLM_Loc (Util.mlloc_of_range se.sigrng)); + Term.ind_discriminator_body g lid l] + + | _ -> + begin match BU.find_map quals (function Projector (l,_) -> Some l | _ -> None) with + (* TODO : this could fail, it happens that projectors for variants are assumed *) + | Some _ -> //it must be a record projector, since other projectors are not assumed + g, [] //records are extracted as ML records; no projectors for them + | _ -> + g, mlm //in all other cases, generate mlm, a stub that always fails + end + else g, [] //it's not assumed, so wait for the corresponding Sig_let to generate code + //or, it must be erased + + | Sig_assume _ //not needed; purely logical + | Sig_sub_effect _ + | Sig_effect_abbrev _ //effects are all primitive; so these are not extracted; this may change as we add user-defined non-primitive effects + | Sig_polymonadic_bind _ + | Sig_polymonadic_subcomp _ -> + g, [] + | Sig_pragma (p) -> + U.process_pragma p se.sigrng; + g, [] + end + ) + +and extract_sig_let (g:uenv) (se:sigelt) : uenv & list mlmodule1 = + if not (Sig_let? se.sigel) + then failwith "Impossible: should only be called with Sig_let" + else begin + let Sig_let { lbs } = se.sigel in + let attrs = se.sigattrs in + let quals = se.sigquals in + let maybe_postprocess_lbs lbs = + let post_tau = + match U.extract_attr' PC.postprocess_extr_with attrs with + | None -> None + | Some (_, (tau, None)::_) -> Some tau + | Some _ -> + Errors.log_issue se Errors.Warning_UnrecognizedAttribute + "Ill-formed application of 'postprocess_for_extraction_with'"; + None + in + let postprocess_lb (tau:term) (lb:letbinding) : letbinding = + let env = tcenv_of_uenv g in + let lbdef = + Profiling.profile + (fun () -> Env.postprocess env tau lb.lbtyp lb.lbdef) + (Some (Ident.string_of_lid (Env.current_module env))) + "FStarC.Extraction.ML.Module.post_process_for_extraction" + in + { lb with lbdef = lbdef } + in + match post_tau with + | None -> lbs + | Some tau -> fst lbs, List.map (postprocess_lb tau) (snd lbs) + in + let maybe_normalize_for_extraction lbs = + let norm_steps = + match U.extract_attr' PC.normalize_for_extraction_lid attrs with + | None -> None + | Some (_, (steps, None)::_) -> + let steps = + //just normalizing the steps themselves, so that the user + //does not have to write a literal at every use of the attribute + N.normalize + [Env.UnfoldUntil delta_constant; Env.Zeta; Env.Iota; Env.Primops] + (tcenv_of_uenv g) + steps + in + begin + match PO.try_unembed_simple steps with + | Some steps -> + Some (Cfg.translate_norm_steps steps) + | _ -> + Errors.log_issue se Errors.Warning_UnrecognizedAttribute + (BU.format1 + "Ill-formed application of 'normalize_for_extraction': normalization steps '%s' could not be interpreted" + (show steps)); + None + end + | Some _ -> + Errors.log_issue se Errors.Warning_UnrecognizedAttribute + "Ill-formed application of 'normalize_for_extraction'"; + None + in + let norm_one_lb steps lb = + let env = tcenv_of_uenv g in + let env = {env with erase_erasable_args=true} in + let lbd = + Profiling.profile + (fun () -> N.normalize steps env lb.lbdef) + (Some (Ident.string_of_lid (Env.current_module env))) + "FStarC.Extraction.ML.Module.normalize_for_extraction" + in + { lb with lbdef = lbd } + in + match norm_steps with + | None -> lbs + | Some steps -> + fst lbs, List.map (norm_one_lb steps) (snd lbs) + in + let ml_let, _, _ = + let lbs = maybe_normalize_for_extraction (maybe_postprocess_lbs lbs) in + Term.term_as_mlexpr + g + (mk (Tm_let {lbs; body=U.exp_false_bool}) se.sigrng) + in + let mlattrs = extract_attrs g se.sigattrs in + begin + match ml_let.expr with + | MLE_Let((flavor, bindings), _) -> + + (* Treatment of qualifiers: we synthesize the metadata that goes + * onto each let-binding as follows: + * - F* keywords (qualifiers, such as "inline_for_extraction" or + * "private") are in [quals] and are distributed on each + * let-binding in the mutually recursive block of bindings + * - F* attributes (custom arbitrary terms, such as "[@ GcType + * ]"), are attached to the block of mutually recursive + * definitions, we don't have syntax YET for attaching these + * to individual definitions + * - some extra information is looked up here and added as a + * bonus; in particular, the MustDisappear attribute (that + * StackInline bestows upon an individual let-binding) is + * specific to each let-binding! *) + let flags = List.choose flag_of_qual quals in + let flags' = extract_metadata attrs in + + let g, ml_lbs' = + List.fold_left2 + (fun (env, ml_lbs) (ml_lb:mllb) {lbname=lbname; lbtyp=t } -> + if ml_lb.mllb_meta |> List.contains Erased + then env, ml_lbs + else + // debug g (fun () -> printfn "Translating source lb %s at type %s to %A" (show lbname) (show t) (must (mllb.mllb_tysc))); + let lb_lid = (right lbname).fv_name.v in + let flags'' = + match (SS.compress t).n with + | Tm_arrow {comp={ n = Comp { effect_name = e }}} + when string_of_lid e = "FStar.HyperStack.ST.StackInline" -> + [ StackInline ] + | _ -> + [] + in + let meta = flags @ flags' @ flags'' in + let ml_lb = { ml_lb with mllb_attrs = mlattrs; mllb_meta = meta } in + let g, ml_lb = + if quals |> BU.for_some (function Projector _ -> true | _ -> false) //projector names have to mangled + then let env, mls, _ = + UEnv.extend_fv + env + (right lbname) + (must ml_lb.mllb_tysc) + ml_lb.mllb_add_unit + in + env, {ml_lb with mllb_name=mls } + else let env, _, _ = UEnv.extend_lb env lbname t (must ml_lb.mllb_tysc) ml_lb.mllb_add_unit in + env, ml_lb in + g, ml_lb::ml_lbs) + (g, []) + bindings + (snd lbs) in + g, + [mk_mlmodule1 (MLM_Loc (Util.mlloc_of_range se.sigrng)); + mk_mlmodule1_with_attrs (MLM_Let (flavor, List.rev ml_lbs')) mlattrs] + @ maybe_register_plugin g se + + | _ -> + failwith (BU.format1 "Impossible: Translated a let to a non-let: %s" (Code.string_of_mlexpr (current_module_of_uenv g) ml_let)) + end + end + +let extract' (g:uenv) (m:modul) : uenv & option mllib = + let _ = Options.restore_cmd_line_options true in + let name, g = UEnv.extend_with_module_name g m.name in + let g = set_tcenv g (FStarC.TypeChecker.Env.set_current_module (tcenv_of_uenv g) m.name) in + let g = set_current_module g name in + let g, sigs = + BU.fold_map + (fun g se -> + if Debug.any () + then let nm = FStarC.Syntax.Util.lids_of_sigelt se |> List.map Ident.string_of_lid |> String.concat ", " in + BU.print1 "+++About to extract {%s}\n" nm; + let r = FStarC.Compiler.Util.measure_execution_time + (BU.format1 "---Extracted {%s}" nm) + (fun () -> extract_sig g se) + in + BU.print1 "Extraction result: %s\n" (Class.Show.show (snd r)); + r + else extract_sig g se) + g m.declarations in + let mlm : mlmodule = List.flatten sigs in + let is_karamel = Options.codegen () = Some Options.Krml in + if string_of_lid m.name <> "Prims" + && (is_karamel || not m.is_interface) + then begin + if not (Options.silent()) then (BU.print1 "Extracted module %s\n" (string_of_lid m.name)); + g, Some (MLLib ([name, Some ([], mlm), (MLLib [])])) + end + else g, None + +let extract (g:uenv) (m:modul) = + ignore <| Options.restore_cmd_line_options true; + let tgt = + match Options.codegen() with + | None -> failwith "Impossible: We're in extract, codegen must be set!" + | Some t -> t + in + if not (Options.should_extract (string_of_lid m.name) tgt) then + failwith (BU.format1 "Extract called on a module %s that should not be extracted" (Ident.string_of_lid m.name)); + + if Options.interactive() then g, None else begin + + let nm = string_of_lid m.name in + let g, mllib = + UF.with_uf_enabled (fun () -> + Errors.with_ctx ("While extracting module " ^ nm) + (fun () -> + Profiling.profile + (fun () -> extract' g m) + (Some nm) + "FStarC.Extraction.ML.Modul.extract")) + in + let g, mllib = + match mllib with + | None -> + g, mllib + | Some mllib -> + let g, mllib = UEnv.with_typars_env g (fun e -> RemoveUnusedParameters.elim_mllib e mllib) in + g, Some mllib + in + ignore <| Options.restore_cmd_line_options true; + exit_module g, mllib + end diff --git a/src/extraction/FStarC.Extraction.ML.Modul.fsti b/src/extraction/FStarC.Extraction.ML.Modul.fsti new file mode 100644 index 00000000000..a983e17544d --- /dev/null +++ b/src/extraction/FStarC.Extraction.ML.Modul.fsti @@ -0,0 +1,43 @@ + +(* + Copyright 2008-2015 Abhishek Anand, Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Extraction.ML.Modul +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Syntax.Syntax +open FStarC.Extraction.ML.Syntax +open FStarC.Extraction.ML.UEnv +module S = FStarC.Syntax.Syntax + +val iface : Type0 + +type extension_sigelt_extractor = + uenv -> sigelt -> FStarC.Dyn.dyn -> either mlmodule string +type extension_sigelt_iface_extractor = + uenv -> sigelt -> FStarC.Dyn.dyn -> either (uenv & iface) string + +type extension_extractor = { + extract_sigelt : extension_sigelt_extractor; + extract_sigelt_iface : extension_sigelt_iface_extractor; +} + +val register_extension_extractor + (extension_name:string) + (extractor:extension_extractor) + : unit + +val extract_iface: uenv -> modul -> uenv & iface +val extract : uenv -> modul -> uenv & option mllib diff --git a/src/extraction/FStarC.Extraction.ML.PrintML.fst b/src/extraction/FStarC.Extraction.ML.PrintML.fst new file mode 100644 index 00000000000..1afe29e3e1c --- /dev/null +++ b/src/extraction/FStarC.Extraction.ML.PrintML.fst @@ -0,0 +1,32 @@ +(* + Copyright 2008-2015 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Extraction.ML.PrintML +open FStarC.Compiler.Effect +open FStarC.Compiler +open FStarC.Extraction.ML.Syntax +open FStarC.Extraction.ML.Code + +(* NOTE!!!! This file is not used by the OCaml build of F* (i.e. the main one). +Instead, it uses an OCaml version ocaml/fstar-lib/FStar_Extraction_ML_PrintML, +so it can use OCaml's native pretty printers. + +This file is here for the F# build. *) + +let print (_: option string) (ext: string) (l: mllib) = + let newDoc = FStarC.Extraction.ML.Code.doc_of_mllib l in + List.iter (fun (n,d) -> + FStarC.Compiler.Util.write_file (FStarC.Options.prepend_output_dir (n^ext)) (FStarC.Extraction.ML.Code.pretty 120 d)) newDoc diff --git a/src/extraction/FStarC.Extraction.ML.PrintML.fsti b/src/extraction/FStarC.Extraction.ML.PrintML.fsti new file mode 100644 index 00000000000..78c4b3054ef --- /dev/null +++ b/src/extraction/FStarC.Extraction.ML.PrintML.fsti @@ -0,0 +1,20 @@ +(* + Copyright 2008-2015 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Extraction.ML.PrintML + +open FStarC.Extraction.ML.Syntax + +val print: option string -> string -> mllib -> unit diff --git a/src/extraction/FStarC.Extraction.ML.RegEmb.fst b/src/extraction/FStarC.Extraction.ML.RegEmb.fst new file mode 100644 index 00000000000..04ebd3ddd7e --- /dev/null +++ b/src/extraction/FStarC.Extraction.ML.RegEmb.fst @@ -0,0 +1,840 @@ +(* + Copyright 2008-2015 Abhishek Anand, Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Extraction.ML.RegEmb + +(* This module handles registering plugins and generating +embeddings for their types. *) + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Const +open FStarC.Extraction.ML.Syntax +open FStarC.Extraction.ML.UEnv +open FStarC.Syntax.Syntax + +module BU = FStarC.Compiler.Util +module Code = FStarC.Extraction.ML.Code +module EMB = FStarC.Syntax.Embeddings +module Env = FStarC.TypeChecker.Env +module N = FStarC.TypeChecker.Normalize +module NBET = FStarC.TypeChecker.NBETerm +module PC = FStarC.Parser.Const +module Print = FStarC.Syntax.Print +module RC = FStarC.Reflection.V2.Constants +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module Term = FStarC.Extraction.ML.Term +module U = FStarC.Syntax.Util +module Util = FStarC.Extraction.ML.Util + +open FStarC.Class.Show +open FStarC.Class.Tagged + +exception NoEmbedding of string +exception Unsupported of string + +(*** ML syntax helpers ***) +let splitlast s = let x::xs = List.rev s in (List.rev xs, x) + +let mk e = with_ty MLTY_Top e + +let ml_name : Ident.lid -> mlexpr = + fun l -> + let s = Ident.path_of_lid l in + let ns, id = splitlast s in + mk (MLE_Name (ns, id)) + +let ml_name' : string -> mlexpr = + fun s -> + ml_name (Ident.lid_of_str s) + +let ml_ctor : Ident.lid -> list mlexpr -> mlexpr = + fun l args -> + let s = Ident.path_of_lid l in + let ns, id = splitlast s in + mk (MLE_CTor ((ns, id), args)) + +let ml_record : Ident.lid -> list (string & mlexpr) -> mlexpr = + fun l args -> + let s = Ident.path_of_lid l in + // [] -> assuming same module + mk (MLE_Record ([], l |> Ident.ident_of_lid |> Ident.string_of_id, args)) + +let mk_binder x t = {mlbinder_name=x; mlbinder_ty=t; mlbinder_attrs=[]} + +let ml_lam nm e = + mk <| MLE_Fun ([mk_binder nm MLTY_Top ], e) + +let ml_none : mlexpr = mk (MLE_Name (["FStar"; "Pervasives"; "Native"], "None")) +let ml_some : mlexpr = mk (MLE_Name (["FStar"; "Pervasives"; "Native"], "Some")) + +let s_tdataconstr = + mk (MLE_Name (splitlast ["FStarC"; "Syntax"; "Syntax"; "tdataconstr"])) +let mk_app = + mk (MLE_Name (splitlast ["FStarC"; "Syntax"; "Util"; "mk_app"])) + +let tm_fvar = + mk (MLE_Name (splitlast ["FStarC"; "Syntax"; "Syntax"; "Tm_fvar"])) +let fv_eq_lid = + mk (MLE_Name (splitlast ["FStarC"; "Syntax"; "Syntax"; "fv_eq_lid"])) +let lid_of_str = + mk (MLE_Name (splitlast ["FStarC"; "Ident"; "lid_of_str"])) + +let nil_lid = Ident.lid_of_str "Prims.Nil" +let cons_lid = Ident.lid_of_str "Prims.Cons" + +let embed = mk (MLE_Name (splitlast ["FStarC"; "Syntax"; "Embeddings"; "Base"; "extracted_embed"])) +let unembed = mk (MLE_Name (splitlast ["FStarC"; "Syntax"; "Embeddings"; "Base"; "extracted_unembed"])) +let bind_opt = mk (MLE_Name (splitlast ["FStarC"; "Compiler"; "Util"; "bind_opt"])) + +let ml_nbe_unsupported : mlexpr = + (* extraction thunks this definition *) + let hd = mk (MLE_Name (["FStarC"; "TypeChecker"; "NBETerm"], "e_unsupported")) in + mk (MLE_App (hd, [ml_unit])) + +let ml_magic : mlexpr = + mk (MLE_Coerce (ml_unit, MLTY_Top, MLTY_Top)) + +let as_name mlp = with_ty MLTY_Top <| MLE_Name mlp + +let ml_failwith (s:string) : mlexpr = + mk <| MLE_App(as_name ([], "failwith"), [mk <| MLE_Const (MLC_String s)]) + +let rec as_ml_list (ts : list mlexpr) : mlexpr = + match ts with + | [] -> ml_ctor nil_lid [] + | t::ts -> ml_ctor cons_lid [t; as_ml_list ts] + +let rec pats_to_list_pat (vs : list mlpattern) : mlpattern = + match vs with + | [] -> MLP_CTor ((["Prims"], "Nil"), []) + | p::ps -> MLP_CTor ((["Prims"], "Cons"), [p; pats_to_list_pat ps]) +(*** / ML syntax helpers ***) + +let fresh : string -> string = + let r = BU.mk_ref 0 in + fun s -> + let v = !r in + r := v+1; + s^"_"^(string_of_int v) + +let not_implemented_warning (r: Range.range) (t: string) (msg: string) = + let open FStarC.Pprint in + let open FStarC.Errors.Msg in + let open FStarC.Class.PP in + Errors.log_issue r Errors.Warning_PluginNotImplemented [ + prefix 2 1 (text (BU.format1 "Plugin `%s' can not run natively because:" t)) + (text msg); + text "Use --warn_error -" + ^^ pp (Errors.error_number (Errors.lookup Errors.Warning_PluginNotImplemented)) + ^/^ text "to carry on." + ] + +type embedding_data = { + arity : int; + syn_emb : Ident.lid; (* lid for regular embedding *) + nbe_emb : option Ident.lid; (* nbe embedding, optional! will abort _at runtime_ if None and called *) +} + +(*** List of registered embeddings ***) +let builtin_embeddings : list (Ident.lident & embedding_data) = + let syn_emb_lid s = Ident.lid_of_path ["FStarC"; "Syntax"; "Embeddings"; s] Range.dummyRange in + let nbe_emb_lid s = Ident.lid_of_path ["FStarC"; "TypeChecker"; "NBETerm"; s] Range.dummyRange in + let refl_emb_lid s = Ident.lid_of_path ["FStarC"; "Reflection"; "V2"; "Embeddings"; s] Range.dummyRange in + let nbe_refl_emb_lid s = Ident.lid_of_path ["FStarC"; "Reflection"; "V2"; "NBEEmbeddings"; s] Range.dummyRange in + [ + (PC.int_lid, {arity=0; syn_emb=syn_emb_lid "e_int"; nbe_emb=Some(nbe_emb_lid "e_int")}); + (PC.bool_lid, {arity=0; syn_emb=syn_emb_lid "e_bool"; nbe_emb=Some(nbe_emb_lid "e_bool")}); + (PC.unit_lid, {arity=0; syn_emb=syn_emb_lid "e_unit"; nbe_emb=Some(nbe_emb_lid "e_unit")}); + (PC.string_lid, {arity=0; syn_emb=syn_emb_lid "e_string"; nbe_emb=Some(nbe_emb_lid "e_string")}); + (PC.norm_step_lid, {arity=0; syn_emb=syn_emb_lid "e_norm_step"; nbe_emb=Some(nbe_emb_lid "e_norm_step")}); + (PC.__range_lid, {arity=0; syn_emb=syn_emb_lid "e___range"; nbe_emb=Some(nbe_emb_lid "e___range")}); + + (PC.vconfig_lid, {arity=0; syn_emb=syn_emb_lid "e_vconfig"; nbe_emb=Some(nbe_emb_lid "e_vconfig")}); + + (PC.list_lid, {arity=1; syn_emb=syn_emb_lid "e_list"; nbe_emb=Some(nbe_emb_lid "e_list")}); + (PC.option_lid, {arity=1; syn_emb=syn_emb_lid "e_option"; nbe_emb=Some(nbe_emb_lid "e_option")}); + (PC.sealed_lid, {arity=1; syn_emb=syn_emb_lid "e_sealed"; nbe_emb=Some(nbe_emb_lid "e_sealed")}); + + (PC.mk_tuple_lid 2 Range.dummyRange, {arity=2; syn_emb=syn_emb_lid "e_tuple2"; nbe_emb=Some(nbe_emb_lid "e_tuple2")}); + (PC.mk_tuple_lid 3 Range.dummyRange, {arity=3; syn_emb=syn_emb_lid "e_tuple3"; nbe_emb=Some(nbe_emb_lid "e_tuple3")}); + (PC.either_lid, {arity=2; syn_emb=syn_emb_lid "e_either"; nbe_emb=Some(nbe_emb_lid "e_either")}); + + (* Reflection base types *) + (RC.fstar_refl_types_lid "namedv", {arity=0; syn_emb=refl_emb_lid "e_namedv"; nbe_emb=Some(nbe_refl_emb_lid "e_namedv")}); + (RC.fstar_refl_types_lid "bv", {arity=0; syn_emb=refl_emb_lid "e_bv"; nbe_emb=Some(nbe_refl_emb_lid "e_bv")}); + (RC.fstar_refl_types_lid "binder", {arity=0; syn_emb=refl_emb_lid "e_binder"; nbe_emb=Some(nbe_refl_emb_lid "e_binder")}); + (RC.fstar_refl_types_lid "term", {arity=0; syn_emb=refl_emb_lid "e_term"; nbe_emb=Some(nbe_refl_emb_lid "e_term")}); + (RC.fstar_refl_types_lid "env", {arity=0; syn_emb=refl_emb_lid "e_env"; nbe_emb=Some(nbe_refl_emb_lid "e_env")}); + (RC.fstar_refl_types_lid "fv", {arity=0; syn_emb=refl_emb_lid "e_fv"; nbe_emb=Some(nbe_refl_emb_lid "e_fv")}); + (RC.fstar_refl_types_lid "comp", {arity=0; syn_emb=refl_emb_lid "e_comp"; nbe_emb=Some(nbe_refl_emb_lid "e_comp")}); + (RC.fstar_refl_types_lid "sigelt", {arity=0; syn_emb=refl_emb_lid "e_sigelt"; nbe_emb=Some(nbe_refl_emb_lid "e_sigelt")}); + (RC.fstar_refl_types_lid "ctx_uvar_and_subst", {arity=0; syn_emb=refl_emb_lid "e_ctx_uvar_and_subst"; nbe_emb=Some(nbe_refl_emb_lid "e_ctx_uvar_and_subst")}); + (RC.fstar_refl_types_lid "letbinding",{arity=0; syn_emb=refl_emb_lid "e_letbinding";nbe_emb=Some(nbe_refl_emb_lid "e_letbinding")}); + (RC.fstar_refl_types_lid "ident", {arity=0; syn_emb=refl_emb_lid "e_ident"; nbe_emb=Some(nbe_refl_emb_lid "e_ident")}); + (RC.fstar_refl_types_lid "universe_uvar", {arity=0; syn_emb=refl_emb_lid "e_universe_uvar"; nbe_emb=Some(nbe_refl_emb_lid "e_universe_uvar")}); + (RC.fstar_refl_types_lid "universe", {arity=0; syn_emb=refl_emb_lid "e_universe"; nbe_emb=Some(nbe_refl_emb_lid "e_universe")}); + + (* Views and datatypes *) + (RC.fstar_refl_data_lid "vconst", {arity=0; syn_emb=refl_emb_lid "e_vconst"; nbe_emb=Some(nbe_refl_emb_lid "e_vconst")}); + (RC.fstar_refl_data_lid "aqualv", {arity=0; syn_emb=refl_emb_lid "e_aqualv"; nbe_emb=Some(nbe_refl_emb_lid "e_aqualv")}); + (RC.fstar_refl_data_lid "pattern", {arity=0; syn_emb=refl_emb_lid "e_pattern"; nbe_emb=Some(nbe_refl_emb_lid "e_pattern")}); + (RC.fstar_refl_data_lid "namedv_view", {arity=0; syn_emb=refl_emb_lid "e_namedv_view"; nbe_emb=Some(nbe_refl_emb_lid "e_namedv_view")}); + (RC.fstar_refl_data_lid "bv_view", {arity=0; syn_emb=refl_emb_lid "e_bv_view"; nbe_emb=Some(nbe_refl_emb_lid "e_bv_view")}); + (RC.fstar_refl_data_lid "binder_view", {arity=0; syn_emb=refl_emb_lid "e_binder_view"; nbe_emb=Some(nbe_refl_emb_lid "e_binder_view")}); + (RC.fstar_refl_data_lid "binding", {arity=0; syn_emb=refl_emb_lid "e_binding"; nbe_emb=Some(nbe_refl_emb_lid "e_binding")}); + (RC.fstar_refl_data_lid "universe_view", {arity=0; syn_emb=refl_emb_lid "e_universe_view"; nbe_emb=Some(nbe_refl_emb_lid "e_universe_view")}); + (RC.fstar_refl_data_lid "term_view", {arity=0; syn_emb=refl_emb_lid "e_term_view"; nbe_emb=Some(nbe_refl_emb_lid "e_term_view")}); + (RC.fstar_refl_data_lid "comp_view", {arity=0; syn_emb=refl_emb_lid "e_comp_view"; nbe_emb=Some(nbe_refl_emb_lid "e_comp_view")}); + (RC.fstar_refl_data_lid "lb_view", {arity=0; syn_emb=refl_emb_lid "e_lb_view"; nbe_emb=Some(nbe_refl_emb_lid "e_lb_view")}); + (RC.fstar_refl_data_lid "sigelt_view", {arity=0; syn_emb=refl_emb_lid "e_sigelt_view"; nbe_emb=Some(nbe_refl_emb_lid "e_sigelt_view")}); + (RC.fstar_refl_data_lid "qualifier", {arity=0; syn_emb=refl_emb_lid "e_qualifier"; nbe_emb=Some(nbe_refl_emb_lid "e_qualifier")}); + ] + +let dbg_plugin = Debug.get_toggle "Plugins" + +let local_fv_embeddings : ref (list (Ident.lident & embedding_data)) = BU.mk_ref [] +let register_embedding (l: Ident.lident) (d: embedding_data) : unit = + if !dbg_plugin then + BU.print1 "Registering local embedding for %s\n" (Ident.string_of_lid l); + local_fv_embeddings := (l,d) :: !local_fv_embeddings + +let list_local () = !local_fv_embeddings + +let find_fv_embedding' (l: Ident.lident) : option embedding_data = + match List.find (fun (l', _) -> Ident.lid_equals l l') + (!local_fv_embeddings @ builtin_embeddings) + with + | Some (_, data) -> Some data + | None -> None + +let find_fv_embedding (l: Ident.lident) : embedding_data = + match find_fv_embedding' l with + | Some data -> data + | None -> + raise (NoEmbedding ("Embedding not defined for type " ^ Ident.string_of_lid l)) + +(*** /List of registered embeddings ***) + +type embedding_kind = + | SyntaxTerm + | NBETerm + +(*** Make an embedding for a composite type (arrows, tuples, list, etc). The environment +is a mapping from variable names into their embeddings. *) +let rec embedding_for + (tcenv:Env.env) + (mutuals: list Ident.lid) + (k: embedding_kind) + (env:list (bv & string)) + (t: term) +: mlexpr += let str_to_name s = as_name ([], s) in + let emb_arrow e1 e2 = + let comb = + match k with + | SyntaxTerm -> mk <| MLE_Name (["FStarC"; "Syntax"; "Embeddings"], "e_arrow") + | NBETerm -> mk <| MLE_Name (["FStarC"; "TypeChecker"; "NBETerm"], "e_arrow") + in + mk (MLE_App (comb, [e1; e2])) + in + let find_env_entry bv (bv', _) = S.bv_eq bv bv' in + (* + * We need the whnf to reduce things like + * ppname_t ~> Inhabited.sealed_ string "" ~> Sealed.sealed string + * If we just unfold variable, we will hit lambdas. + *) + let t = N.unfold_whnf tcenv t in + let t = U.un_uinst t in + let t = SS.compress t in + match t.n with + (* A name, explain (why e_any?) *) + | Tm_name bv when BU.for_some (find_env_entry bv) env -> + let comb = + match k with + | SyntaxTerm -> mk <| MLE_Name (["FStarC"; "Syntax"; "Embeddings"], "mk_any_emb") + | NBETerm -> mk <| MLE_Name (["FStarC"; "TypeChecker"; "NBETerm"], "mk_any_emb") + in + let s = snd (BU.must (BU.find_opt (find_env_entry bv) env)) in + mk <| MLE_App(comb, [str_to_name s]) + + (* Refinements are irrelevant for embeddings. *) + | Tm_refine {b=x} -> + embedding_for tcenv mutuals k env x.sort + + (* Ascriptions are irrelevant for embeddings. *) + | Tm_ascribed {tm=t} -> + embedding_for tcenv mutuals k env t + + (* Pure arrow *) + | Tm_arrow {bs=[b]; comp=c} when U.is_pure_comp c -> + let [b], c = FStarC.Syntax.Subst.open_comp [b] c in + let t0 = b.binder_bv.sort in + let t1 = U.comp_result c in + emb_arrow (embedding_for tcenv mutuals k env t0) (embedding_for tcenv mutuals k env t1) + + (* More than 1 binder, curry and retry *) + | Tm_arrow {bs=b::more::bs; comp=c} -> + let tail = S.mk (Tm_arrow {bs=more::bs; comp=c}) t.pos in + let t = S.mk (Tm_arrow {bs=[b]; comp=S.mk_Total tail}) t.pos in + embedding_for tcenv mutuals k env t + + | Tm_app _ -> + let head, args = U.head_and_args t in + let e_head = embedding_for tcenv mutuals k env head in + let e_args = List.map (fun (t, _) -> embedding_for tcenv mutuals k env t) args in + mk <| MLE_App (e_head, e_args) + + (* An fv part of the mutual set of inductives that we are making + an embedding for, just point to the recursive binding. There is a catch + though: we want to generate something like: + + let rec e_t1 = mk_emb ... + and e_t2 = mk_emb ... + ... + + but this does not satisfy OCamls's let-rec restrictions. Hence, we thunk + all of them, using a name prefix __knot_e, and later define the e_X at the + top-level by unthunking. + *) + | Tm_fvar fv when List.existsb (Ident.lid_equals fv.fv_name.v) mutuals -> + let head = mk <| MLE_Var ("__knot_e_" ^ Ident.string_of_id (Ident.ident_of_lid fv.fv_name.v)) in + mk (MLE_App (head, [ml_unit])) + + (* An fv for which we have an embedding already registered. *) + | Tm_fvar fv when Some? (find_fv_embedding' fv.fv_name.v) -> + let emb_data = find_fv_embedding fv.fv_name.v in + begin match k with + | SyntaxTerm -> ml_name emb_data.syn_emb + | NBETerm -> + begin match emb_data.nbe_emb with + | Some lid -> ml_name lid + | None -> + ml_nbe_unsupported + end + end + + (* + * An fv which we do not have registered, but has the plugin + * attribute. We assume it must have had an embedding generated + * right next to it in its same module. + *) + | Tm_fvar fv when Env.fv_has_attr tcenv fv PC.plugin_attr -> + begin match k with + | SyntaxTerm -> + let lid = fv.fv_name.v in + as_name (List.map Ident.string_of_id (Ident.ns_of_lid lid), + "e_" ^ Ident.string_of_id (Ident.ident_of_lid lid)) + | NBETerm -> + ml_nbe_unsupported + end + + (* An fv which we do not have registered, and did not unfold *) + | Tm_fvar fv -> + raise (NoEmbedding (BU.format1 "Embedding not defined for name `%s'" (show t))) + + | _ -> + raise (NoEmbedding (BU.format2 "Cannot embed type `%s' (%s)" (show t) (tag_of t))) + +type wrapped_term = mlexpr & mlexpr & int & bool + +let interpret_plugin_as_term_fun (env:UEnv.uenv) (fv:fv) (t:typ) (arity_opt:option int) (ml_fv:mlexpr') + : option wrapped_term = + let fv_lid = fv.fv_name.v in + let tcenv = UEnv.tcenv_of_uenv env in + let t = N.normalize [ + Env.EraseUniverses; + Env.AllowUnboundUniverses; + Env.UnfoldUntil S.delta_constant; // unfold abbreviations such as nat + Env.ForExtraction + ] tcenv t in + let as_name mlp = with_ty MLTY_Top <| MLE_Name mlp in + let lid_to_name l = with_ty MLTY_Top <| MLE_Name (UEnv.mlpath_of_lident env l) in + let str_to_name s = as_name ([], s) in + let fv_lid_embedded = + with_ty MLTY_Top <| + MLE_App (as_name (["FStarC_Ident"],"lid_of_str"), + [with_ty MLTY_Top <| MLE_Const (MLC_String (Ident.string_of_lid fv_lid))]) + in + let mk_tactic_interpretation l arity = + if arity > FStarC.Tactics.InterpFuns.max_tac_arity then + raise (NoEmbedding("tactic plugins can only take up to 20 arguments")) + else + let idroot = + match l with + | SyntaxTerm -> "mk_tactic_interpretation_" + | NBETerm -> "mk_nbe_tactic_interpretation_" + in + as_name (["FStarC_Tactics_InterpFuns"], idroot^string_of_int arity) + in + let mk_from_tactic l arity = + let idroot = + match l with + | SyntaxTerm -> "from_tactic_" + | NBETerm -> "from_nbe_tactic_" + in + as_name (["FStarC_Tactics_Native"], idroot^string_of_int arity) + in + let mk_arrow_as_prim_step k (arity: int) : mlexpr = + let modul = + match k with + | SyntaxTerm -> ["FStarC"; "Syntax"; "Embeddings"] + | NBETerm -> ["FStarC"; "TypeChecker"; "NBETerm"] + in + as_name (modul, "arrow_as_prim_step_" ^ string_of_int arity) + in + (* Generates the ML syntax of a term of type + `FStarC.Syntax.Embeddings.embedding [[t]]` + where [[t]] is the ML denotation of the F* type t + *) + (* abstract_tvars: + body is an implicitly polymorphic function over tvar_names + whose type is of the form `args -> term` + + returns an mlexpr that explicitly abstracts over FStarC.Syntax.term + representations of those type arguments + peeling away a prefix of args corresponding to the type arguments + *) + let abstract_tvars tvar_names (body:mlexpr) : mlexpr = + match tvar_names with + | [] -> + let body = + mk <| MLE_App(as_name (["FStarC_Syntax_Embeddings"], "debug_wrap"), + [with_ty MLTY_Top <| MLE_Const (MLC_String (Ident.string_of_lid fv_lid)); + ml_lam "_" (mk <| MLE_App(body, [str_to_name "args"]))]) + in + ml_lam "args" body + | _ -> + let args_tail = MLP_Var "args_tail" in + let mk_cons hd_pat tail_pat = + MLP_CTor ((["Prims"], "Cons"), [hd_pat; tail_pat]) + in + let fst_pat v = + MLP_Tuple [MLP_Var v; MLP_Wild] + in + let pattern = + List.fold_right + (fun hd_var -> mk_cons (fst_pat hd_var)) + tvar_names + args_tail + in + let branch = + pattern, + None, + mk <| MLE_App(body, [as_name ([], "args_tail")]) + in + let default_branch = + MLP_Wild, + None, + mk <| MLE_App(str_to_name "failwith", + [mk <| MLE_Const (MLC_String "arity mismatch")]) + in + let body = + mk <| MLE_Match(as_name ([], "args"), [branch; default_branch]) + in + let body = + mk <| MLE_App(as_name (["FStarC_Syntax_Embeddings"], "debug_wrap"), + [with_ty MLTY_Top <| MLE_Const (MLC_String (Ident.string_of_lid fv_lid)); + ml_lam "_" body]) + in + ml_lam "args" body + in + (* We're trying to register a plugin or tactic + ml_fv which has source F* type t *) + let bs, c = U.arrow_formals_comp t in + let bs, c = + match arity_opt with + | None -> bs, c + | Some n -> + let n_bs = List.length bs in + if n = n_bs then bs, c + else if n < n_bs + then let bs, rest = BU.first_N n bs in + let c = S.mk_Total <| U.arrow rest c in + bs, c + else // n > bs + let msg = + BU.format3 + "Embedding not defined for %s; expected arity at least %s; got %s" + (Ident.string_of_lid fv_lid) + (BU.string_of_int n) + (BU.string_of_int n_bs) in + raise (NoEmbedding msg) + in + let result_typ = U.comp_result c in + let arity = List.length bs in + let type_vars, bs = + match + BU.prefix_until + (fun ({binder_bv=b}) -> + match (SS.compress b.sort).n with + | Tm_type _ -> false + | _ -> true) + bs + with + | None -> + bs, [] + | Some (tvars, x, rest) -> + tvars, x::rest + in + (* Explicit polymorphism in the source type `t` + is turned into implicit polymorphism in ML. + + `t` is really `forall type_vars. bs -> result_typ` + *) + let tvar_arity = List.length type_vars in + let non_tvar_arity = List.length bs in + let tvar_names = List.mapi (fun i tv -> ("tv_" ^ string_of_int i)) type_vars in + let tvar_context : list (bv & string) = List.map2 (fun b nm -> b.binder_bv, nm) type_vars tvar_names in + // The tvar_context records all the ML type variables in scope + // All their embeddings will be just identity embeddings + + (* aux: The main function that builds the registration code + + accum_embeddings: all the embeddings of the arguments (in reverse order) + bs: the remaining arguments + + returns (mlexpr, //the registration code + int, //the arity of the compiled code (+1 for tactics) + bool) //true if this is a tactic + *) + let rec aux loc (accum_embeddings:list mlexpr) bs : (mlexpr & int & bool) = + match bs with + | [] -> + let arg_unembeddings = List.rev accum_embeddings in + let res_embedding = embedding_for tcenv [] loc tvar_context result_typ in + let fv_lid = fv.fv_name.v in + if U.is_pure_comp c + then begin + let cb = str_to_name "cb" in + let us = str_to_name "us" in + let embed_fun_N = mk_arrow_as_prim_step loc non_tvar_arity in + let args = arg_unembeddings + @ [res_embedding; + lid_to_name fv_lid; + fv_lid_embedded; + cb; + us] + in + let fun_embedding = mk <| MLE_App(embed_fun_N, args) in + let tabs = abstract_tvars tvar_names fun_embedding in + let cb_tabs = ml_lam "cb" (ml_lam "us" tabs) in + ((if loc = NBETerm then cb_tabs else ml_lam "_psc" cb_tabs), + arity, + true) + end + else if Ident.lid_equals (FStarC.TypeChecker.Env.norm_eff_name tcenv (U.comp_effect_name c)) + PC.effect_TAC_lid + then begin + let h = mk_tactic_interpretation loc non_tvar_arity in + let tac_fun = mk <| MLE_App (mk_from_tactic loc non_tvar_arity, + [lid_to_name fv_lid]) + in + let psc = str_to_name "psc" in + let ncb = str_to_name "ncb" in + let us = str_to_name "us" in + let all_args = str_to_name "args" in + let args = + [mk <| MLE_Const (MLC_String (Ident.string_of_lid fv_lid ^ " (plugin)"))] @ + [tac_fun] @ + arg_unembeddings @ + [res_embedding; + psc; + ncb; + us] in + let tabs = + match tvar_names with + | [] -> ml_lam "args" (mk <| MLE_App (h, args@[all_args])) + | _ -> abstract_tvars tvar_names (mk <| MLE_App (h, args)) + in + (ml_lam "psc" (ml_lam "ncb" (ml_lam "us" tabs)), + arity + 1, + false) + end + else raise (NoEmbedding("Plugins not defined for type " ^ show t)) + + | ({binder_bv=b})::bs -> + aux loc (embedding_for tcenv [] loc tvar_context b.sort::accum_embeddings) bs + in + try + let w, a, b = aux SyntaxTerm [] bs in + let w', _, _ = aux NBETerm [] bs in + Some (w, w', a, b) + with + | NoEmbedding msg -> + not_implemented_warning (Ident.range_of_lid fv.fv_name.v) + (show fv) + msg; + None + +(* Creates an unembedding function for the type *) +let mk_unembed + (tcenv:Env.env) // tc environment mostly used to lookup fvs + (mutuals : list Ident.lid) // mutual inductives we are defining embedding for + (record_fields : option (list mlpath)) // if this type is a record, these are the (extracted) field names + (ctors: list sigelt) // constructors of the inductive +: mlexpr += let e_branches : ref (list mlbranch) = BU.mk_ref [] in + let arg_v = fresh "tm" in + ctors |> List.iter (fun ctor -> + match ctor.sigel with + | Sig_datacon {lid; us; t; ty_lid; num_ty_params; mutuals=_} -> + let fv = fresh "fv" in + let bs, c = U.arrow_formals t in + let vs = List.map (fun b -> fresh (Ident.string_of_id b.binder_bv.ppname), b.binder_bv.sort) bs in + + let pat_s = MLP_Const (MLC_String (Ident.string_of_lid lid)) in + (* let pat_args = MLP_CTor ((["Prims"], "Nil"), List.map (fun (v, _) -> MLP_Var v) vs) in *) + let pat_args = vs |> List.map (fun (v,_) -> MLP_Var v) |> pats_to_list_pat in + let pat_both = MLP_Tuple [pat_s; pat_args] in + + let ret = + match record_fields with + | Some fields -> + ml_record lid (List.map2 (fun (v, _) fld -> snd fld, mk (MLE_Var v)) vs fields) + | None -> + ml_ctor lid (List.map (fun (v, _) -> mk (MLE_Var v)) vs) + in + let ret = mk (MLE_App (ml_some, [ret])) in // final return + + let body = List.fold_right (fun (v, ty) body -> + let body = mk (MLE_Fun ([mk_binder v MLTY_Top], body)) in + + mk (MLE_App (bind_opt, [ + mk (MLE_App (unembed, [embedding_for tcenv mutuals SyntaxTerm [] ty; mk (MLE_Var v)])); + body; + ])) + ) vs ret + in + let br = (pat_both, None, body) in + + e_branches := br :: !e_branches + | _ -> failwith "impossible, filter above" + ); + let nomatch : mlbranch = (MLP_Wild, None, ml_none) in + let branches = List.rev (nomatch :: !e_branches) in + let sc = mk (MLE_Var arg_v) in + let def = mk (MLE_Match (sc, branches)) in + let lam = mk (MLE_Fun ([mk_binder arg_v MLTY_Top], def)) in + lam + +(* Creates an embedding function for the type *) +let mk_embed + (tcenv:Env.env) // tc environment mostly used to lookup fvs + (mutuals : list Ident.lid) // mutual inductives we are defining embedding for + (record_fields : option (list mlpath)) // if this type is a record, these are the (extracted) field names + (ctors: list sigelt) // constructors of the inductive +: mlexpr += let e_branches : ref (list mlbranch) = BU.mk_ref [] in + let arg_v = fresh "tm" in + ctors |> List.iter (fun ctor -> + match ctor.sigel with + | Sig_datacon {lid; us; t; ty_lid; num_ty_params; mutuals=_} -> + let fv = fresh "fv" in + let bs, c = U.arrow_formals t in + let vs = List.map (fun b -> fresh (Ident.string_of_id b.binder_bv.ppname), b.binder_bv.sort) bs in + let pat = + match record_fields with + | Some fields -> + // [] -> assuming same module + MLP_Record ([], List.map2 (fun v fld -> snd fld, MLP_Var (fst v)) vs fields) + | None -> + MLP_CTor (splitlast (Ident.path_of_lid lid), List.map (fun v -> MLP_Var (fst v)) vs) + in + let fvar = s_tdataconstr in + let lid_of_str = lid_of_str in + let head = mk (MLE_App (fvar, [ + mk (MLE_App (lid_of_str, [mk (MLE_Const (MLC_String (Ident.string_of_lid lid)))]))])) + in + let mk_mk_app t ts = + // FIXME: all explicit + let ts = List.map (fun t -> mk (MLE_Tuple [t; ml_none])) ts in + mk (MLE_App (mk_app, [t; as_ml_list ts])) + in + let args = + vs |> List.map (fun (v, ty) -> + let vt = mk (MLE_Var v) in + mk (MLE_App (embed, [embedding_for tcenv mutuals SyntaxTerm [] ty; vt])) + ) + in + let ret = mk_mk_app head args in + let br = (pat, None, ret) in + + e_branches := br :: !e_branches + | _ -> failwith "impossible, filter above" + ); + let branches = List.rev !e_branches in + let sc = mk (MLE_Var arg_v) in + let def = mk (MLE_Match (sc, branches)) in + let lam = mk (MLE_Fun ([mk_binder arg_v MLTY_Top], def)) in + lam + + +let __do_handle_plugin (g: uenv) (arity_opt: option int) (se: sigelt) : list mlmodule1 = + // BU.print2 "Got plugin with attrs = %s; arity_opt=%s" + // (List.map show se.sigattrs |> String.concat " ") + // (match arity_opt with None -> "None" | Some x -> "Some " ^ string_of_int x); + let r = se.sigrng in + match se.sigel with + | Sig_let {lbs} -> + let mk_registration lb : list mlmodule1 = + let fv = BU.right lb.lbname in + let fv_lid = fv.fv_name.v in + let fv_t = lb.lbtyp in + let ml_name_str = MLE_Const (MLC_String (Ident.string_of_lid fv_lid)) in + match interpret_plugin_as_term_fun g fv fv_t arity_opt ml_name_str with + | Some (interp, nbe_interp, arity, plugin) -> + let register, args = + if plugin + then (["FStarC_Tactics_Native"], "register_plugin"), [interp; nbe_interp] + else (["FStarC_Tactics_Native"], "register_tactic"), [interp] + in + let h = with_ty MLTY_Top <| MLE_Name register in + let arity = MLE_Const (MLC_Int(string_of_int arity, None)) in + let app = with_ty MLTY_Top <| MLE_App (h, [mk ml_name_str; mk arity] @ args) in + [MLM_Top app |> mk_mlmodule1] + | None -> [] + in + List.collect mk_registration (snd lbs) + + | Sig_bundle {ses} -> + let mutual_sigelts = List.filter (fun se -> match se.sigel with | Sig_inductive_typ _ -> true | _ -> false) ses in + let mutual_lids = List.map (fun se -> match se.sigel with | Sig_inductive_typ {lid} -> lid ) mutual_sigelts in + let proc_one (typ_sigelt:sigelt) = + let Sig_inductive_typ {lid=tlid; params=ps} = typ_sigelt.sigel in + if List.length ps > 0 then + raise (Unsupported "parameters on inductive"); + let ns = Ident.ns_of_lid tlid in + let name = Ident.string_of_id (List.last (Ident.ids_of_lid tlid)) in + + (* get constructors for this particular mutual *) + let ctors = + List.filter (fun se -> match se.sigel with | Sig_datacon {ty_lid} -> Ident.lid_equals ty_lid tlid | _ -> false) ses + in + let ml_name = mk (MLE_Const (MLC_String (Ident.string_of_lid tlid))) in + + let record_fields = + match List.find (function RecordType _ -> true | _ -> false) typ_sigelt.sigquals with + | Some (RecordType (_, b)) -> + (* Extraction may change the names of fields to disambiguate them, + * query the environment for the extracted names. *) + Some (List.map (fun f -> lookup_record_field_name g (tlid, f)) b) + | _ -> + None + in + + let tcenv = tcenv_of_uenv g in + let ml_unembed = mk_unembed tcenv mutual_lids record_fields ctors in + let ml_embed = mk_embed tcenv mutual_lids record_fields ctors in + let def = mk (MLE_App (mk (MLE_Name (["FStarC"; "Syntax"; "Embeddings"; "Base"], "mk_extracted_embedding")), [ + ml_name; + ml_unembed; + ml_embed])) + in + let def = mk (MLE_Fun ([mk_binder "_" MLTY_Erased], def)) in // thunk + let lb = { + mllb_name = "__knot_e_" ^ name; + mllb_tysc = None; + mllb_add_unit = false; + mllb_def = def; + mllb_meta = []; + mllb_attrs = []; + print_typ = false; + } + in + // TODO: parameters + register_embedding tlid { + arity = 0; + syn_emb = Ident.lid_of_ns_and_id ns (Ident.mk_ident ("e_"^name, Range.dummyRange)); + nbe_emb = None; + }; + [lb] + in + let lbs = List.concatMap proc_one mutual_sigelts in + let unthunking : list mlmodule1 = + mutual_sigelts |> List.concatMap (fun se -> + let tlid = (match se.sigel with | Sig_inductive_typ {lid=tlid} -> tlid) in + let name = Ident.string_of_id (List.last (Ident.ids_of_lid tlid)) in + let app = + let head = mk <| MLE_Var ("__knot_e_" ^ name) in + mk (MLE_App (head, [ml_unit])) + in + let lb = { + mllb_name = "e_" ^ name; + mllb_tysc = None; + mllb_add_unit = false; + mllb_def = app; + mllb_meta = []; + mllb_attrs = []; + print_typ = false; + } + in + [MLM_Let (NonRec, [lb]) |> mk_mlmodule1] + ) + in + // TODO: We always make a let rec, we could check if that's really needed. + [MLM_Let (Rec, lbs) |> mk_mlmodule1] @ unthunking + + | _ -> [] + +let do_handle_plugin (g: uenv) (arity_opt: option int) (se: sigelt) : list mlmodule1 = + try __do_handle_plugin g arity_opt se with + | Unsupported msg -> + // Change error code? + Errors.log_issue se Errors.Warning_PluginNotImplemented + (BU.format2 "Could not generate a plugin for %s, reason = %s" (Print.sigelt_to_string_short se) msg); + [] + | NoEmbedding msg -> + not_implemented_warning se.sigrng + (Print.sigelt_to_string_short se) + msg; + [] + +(* When extracting a plugin, each top-level definition marked with a `@plugin` attribute + is extracted along with an invocation to FStarC.Tactics.Native.register_tactic or register_plugin, + which installs the compiled term as a primitive step in the normalizer + *) +let maybe_register_plugin (g:uenv) (se:sigelt) : list mlmodule1 = + (* The `plugin` attribute takes an optional arity, parse it. + * None: not a plugin + * Some None: plugin without explicit arity + * Some (Some n): plugin with explicit arity n + *) + let plugin_with_arity (attrs: list term) : option (option int) = + BU.find_map attrs (fun t -> + let head, args = U.head_and_args t in + if not (U.is_fvar PC.plugin_attr head) then + None + else match args with + | [(a, _)] -> + (* Try to unembed the argument as an int, warn if not possible. *) + let nopt = EMB.unembed a EMB.id_norm_cb in + Some nopt + | _ -> Some None + ) + in + if Options.codegen() <> Some Options.Plugin then + [] + else match plugin_with_arity se.sigattrs with + | None -> [] + (* ignore projectors and discriminators, they get a @@plugin attribute inherited + from the type, but we should not do anything for them. *) + | Some _ when List.existsb (function Projector _ | Discriminator _ -> true | _ -> false) se.sigquals -> + [] + | Some arity_opt -> + do_handle_plugin g arity_opt se diff --git a/src/extraction/FStarC.Extraction.ML.RegEmb.fsti b/src/extraction/FStarC.Extraction.ML.RegEmb.fsti new file mode 100644 index 00000000000..af01ea8f485 --- /dev/null +++ b/src/extraction/FStarC.Extraction.ML.RegEmb.fsti @@ -0,0 +1,43 @@ + +(* + Copyright 2008-2015 Abhishek Anand, Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Extraction.ML.RegEmb + +(* This module handles registering plugins and generating +embeddings for their types. *) + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect + +open FStarC.Syntax.Syntax +open FStarC.Extraction.ML +open FStarC.Extraction.ML.Syntax +open FStarC.Extraction.ML.UEnv + +(* When extracting a plugin, each top-level definition marked with a `@plugin` attribute + is extracted along with an invocation to FStarC.Tactics.Native.register_tactic or register_plugin, + which installs the compiled term as a primitive step in the normalizer + *) +val maybe_register_plugin (g:uenv) (se:sigelt) : list mlmodule1 + +val interpret_plugin_as_term_fun : + UEnv.uenv + -> fv:fv + -> t:typ + -> arity:option int + -> ml_fv:mlexpr' + -> option (mlexpr & mlexpr & int & bool) diff --git a/src/extraction/FStarC.Extraction.ML.RemoveUnusedParameters.fst b/src/extraction/FStarC.Extraction.ML.RemoveUnusedParameters.fst new file mode 100644 index 00000000000..e6f345fe00b --- /dev/null +++ b/src/extraction/FStarC.Extraction.ML.RemoveUnusedParameters.fst @@ -0,0 +1,389 @@ +(* + Copyright 2020 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +(* -------------------------------------------------------------------- *) +module FStarC.Extraction.ML.RemoveUnusedParameters +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.Ident +open FStarC.Compiler.Util +open FStarC.Const +open FStarC.BaseTypes +open FStarC.Extraction.ML.Syntax +open FStarC.Class.Setlike +open FStarC.Class.Show + +(** + This module implements a transformation on the FStarC.Extraction.ML.Syntax + AST to remove unused type parameters from type abbreviations. + + This is mainly intended for use with F# code extraction, since the + F# compiler does not accept type abbreviations with unused + parameters. However, this transformation may also be useful for use + with OCaml, since it may lead to nicer code. +*) +module BU = FStarC.Compiler.Util + +(** + The transformation maintains an environment recording which + arguments of a type definition are to be removed, extending the + environment at the definition site of each type abbreviation and + using the environment to determine which arguments should be omitted + at each use site. + + The environment maps an mlpath, a fully qualified name of a type + definition, to a list of [Retain | Omit] tags, one for each argument + of the type definition. + *) + +type argument_tag = + | Retain + | Omit + +type entry = list argument_tag + +type env_t = { + current_module:list mlsymbol; + tydef_map:BU.psmap entry; +} + +let initial_env : env_t = { + current_module = []; + tydef_map = BU.psmap_empty () +} + +let extend_env (env:env_t) (i:mlsymbol) (e:entry) : env_t = { + env with + tydef_map = BU.psmap_add env.tydef_map (string_of_mlpath (env.current_module,i)) e +} + +let lookup_tyname (env:env_t) (name:mlpath) + : option entry + = BU.psmap_try_find env.tydef_map (string_of_mlpath name) + +(** Free variables of a type: Computed to check which parameters are used *) +type var_set = RBSet.t mlident +let empty_var_set : RBSet.t string = empty () +let rec freevars_of_mlty' (vars:var_set) (t:mlty) = + match t with + | MLTY_Var i -> + add i vars + | MLTY_Fun (t0, _, t1) -> + freevars_of_mlty' (freevars_of_mlty' vars t0) t1 + | MLTY_Named (tys, _) + | MLTY_Tuple tys -> + List.fold_left freevars_of_mlty' vars tys + | _ -> vars +let freevars_of_mlty = freevars_of_mlty' empty_var_set + +(** The main rewriting in on MLTY_Named (args, name), + which eliminates some of the args in case `name` has + parameters that are marked as Omit in the environment *) +let rec elim_mlty env mlty = + match mlty with + | MLTY_Var _ -> mlty + + | MLTY_Fun (t0, e, t1) -> + MLTY_Fun(elim_mlty env t0, e, elim_mlty env t1) + + | MLTY_Named (args, name) -> + let args = List.map (elim_mlty env) args in + begin + match lookup_tyname env name with + | None -> + MLTY_Named(args, name) + | Some entry -> + if List.length entry <> List.length args + then failwith "Impossible: arity mismatch between definition and use"; + let args = + List.fold_right2 + (fun arg tag out -> + match tag with + | Retain -> arg::out + | _ -> out) + args + entry + [] + in + MLTY_Named(args, name) + end + | MLTY_Tuple tys -> //arity of tuples do not change + MLTY_Tuple (List.map (elim_mlty env) tys) + | MLTY_Top + | MLTY_Erased -> mlty + +(** Note, the arity of expressions do not change. + So, this just traverses an expression an eliminates + type arguments in any subterm to e that is an mlty *) +let rec elim_mlexpr' (env:env_t) (e:mlexpr') = + match e with + | MLE_Const _ + | MLE_Var _ + | MLE_Name _ -> e + | MLE_Let (lb, e) -> MLE_Let(elim_letbinding env lb, elim_mlexpr env e) + | MLE_App(e, es) -> MLE_App(elim_mlexpr env e, List.map (elim_mlexpr env) es) + | MLE_TApp (e, tys) -> MLE_TApp(e, List.map (elim_mlty env) tys) + | MLE_Fun(bvs, e) -> + MLE_Fun (List.map (fun b -> {mlbinder_name=b.mlbinder_name; + mlbinder_ty=elim_mlty env b.mlbinder_ty; + mlbinder_attrs=List.map (elim_mlexpr env) b.mlbinder_attrs}) bvs, elim_mlexpr env e) + | MLE_Match(e, branches) -> MLE_Match(elim_mlexpr env e, List.map (elim_branch env) branches) + | MLE_Coerce(e, t0, t1) -> MLE_Coerce(elim_mlexpr env e, elim_mlty env t0, elim_mlty env t1) + | MLE_CTor(l, es) -> MLE_CTor(l, List.map (elim_mlexpr env) es) + | MLE_Seq es -> MLE_Seq (List.map (elim_mlexpr env) es) + | MLE_Tuple es -> MLE_Tuple (List.map (elim_mlexpr env) es) + | MLE_Record(syms, nm, fields) -> MLE_Record(syms, nm, List.map (fun (s, e) -> s, elim_mlexpr env e) fields) + | MLE_Proj (e, p) -> MLE_Proj(elim_mlexpr env e, p) + | MLE_If(e, e1, e2_opt) -> MLE_If(elim_mlexpr env e, elim_mlexpr env e1, BU.map_opt e2_opt (elim_mlexpr env)) + | MLE_Raise(p, es) -> MLE_Raise (p, List.map (elim_mlexpr env) es) + | MLE_Try(e, branches) -> MLE_Try(elim_mlexpr env e, List.map (elim_branch env) branches) + +and elim_letbinding env (flavor, lbs) = + let elim_one_lb lb = + let ts = BU.map_opt lb.mllb_tysc (fun (vars, t) -> vars, elim_mlty env t) in + let expr = elim_mlexpr env lb.mllb_def in + { lb with + mllb_tysc = ts; + mllb_def = expr } + in + flavor, List.map elim_one_lb lbs + +and elim_branch env (pat, wopt, e) = + pat, BU.map_opt wopt (elim_mlexpr env), elim_mlexpr env e + +and elim_mlexpr (env:env_t) (e:mlexpr) = + { e with expr = elim_mlexpr' env e.expr; mlty = elim_mlty env e.mlty } + +exception Drop_tydef + +(** This is a key helper function: + + It is called from elim_one_mltydecl when encountering a type + definition (MLTD_Abbrev), and also when processing type + definitions when extracting interfaces for dependences. + + it computes the variables that are used and marks the unused ones + as Omit in the environment and removes them from the type scheme. +*) +let elim_tydef (env:env_t) name metadata parameters mlty + = let val_decl_range = + BU.find_map metadata (function HasValDecl r -> Some r | _ -> None) + in + let remove_typars_list = + BU.try_find (function RemoveUnusedTypeParameters _ -> true | _ -> false) metadata + in + let range_of_tydef = + match remove_typars_list with + | None -> Range.dummyRange + | Some (RemoveUnusedTypeParameters(_, r)) -> r + in + let must_eliminate i = + match remove_typars_list with + | Some (RemoveUnusedTypeParameters (l, r)) -> List.contains i l + | _ -> false + in + let can_eliminate i = + match val_decl_range, remove_typars_list with + | None, None -> true + | _ -> false + in + let mlty = elim_mlty env mlty in + let freevars = freevars_of_mlty mlty in + let _, parameters, entry = + List.fold_left + (fun (i, params, entry) param -> + let p = param.ty_param_name in + if mem p freevars + then begin + if must_eliminate i + then begin + FStarC.Errors.log_issue range_of_tydef Errors.Error_RemoveUnusedTypeParameter + (BU.format2 "Expected parameter %s of %s to be unused in its definition and eliminated" p name) + end; + i+1, param::params, Retain::entry + end + else begin + if can_eliminate i //there's no val + || must_eliminate i //or there's an attribute explicitly demanding elimination + then i+1, params, Omit::entry + else if Options.codegen() = Some Options.FSharp + then //This is a hard error for F# + //unused type parameters have to be eliminated + let range = + match val_decl_range with + | Some r -> r + | _ -> range_of_tydef + in + FStarC.Errors.log_issue range FStarC.Errors.Error_RemoveUnusedTypeParameter + (BU.format3 + "Parameter %s of %s is unused and must be eliminated for F#; \ + add `[@@ remove_unused_type_parameters [%s; ...]]` to the interface signature; \n\ + This type definition is being dropped" (show i) name (show i)); + raise Drop_tydef + else i+1, param::params, Retain::entry + end) + (0, [], []) + parameters + in + extend_env env name (List.rev entry), + (name, metadata, List.rev parameters, mlty) + +let elim_tydef_or_decl (env:env_t) (td:tydef) + : env_t & tydef + = match td with + | name, metadata, Inr arity -> + let remove_typars_list = + BU.try_find (function RemoveUnusedTypeParameters _ -> true | _ -> false) metadata + in + begin + match remove_typars_list with + | None -> env, td + | Some (RemoveUnusedTypeParameters(l, r)) -> + let must_eliminate i = List.contains i l in + let rec aux i = + if i = arity then [] + else if must_eliminate i then Omit :: aux (i + 1) + else Retain :: aux (i + 1) + in + let entries = aux 0 in + extend_env env name entries, + td + end + + | name, metadata, Inl (parameters, mlty) -> + let env, (name, meta, params, mlty) = + elim_tydef env name metadata parameters mlty + in + env, (name, meta, Inl (params, mlty)) + +let elim_tydefs (env:env_t) (tds:list tydef) : env_t & list tydef = + if Options.codegen() <> Some Options.FSharp then env, tds else + let env, tds = + List.fold_left + (fun (env, out) td -> + try + let env, td = elim_tydef_or_decl env td in + env, td::out + with + | Drop_tydef -> + env, out) + (env, []) tds + in + env, List.rev tds + +(** This is the main function that actually extends the environment: + When encountering a type definition (MLTD_Abbrev), it + computes the variables that are used and marks the unused ones as Omit + in the environment and removes them from the definition here *) +let elim_one_mltydecl (env:env_t) (td:one_mltydecl) + : env_t + & one_mltydecl + = let {tydecl_name=name; tydecl_meta=meta; tydecl_parameters=parameters; tydecl_defn=body} = td in + let elim_td td = + match td with + | MLTD_Abbrev mlty -> + let env, (name, _, parameters, mlty) = elim_tydef env name meta parameters mlty in + env, + parameters, + MLTD_Abbrev mlty + + | MLTD_Record fields -> + env, + parameters, + MLTD_Record (List.map (fun (name, ty) -> name, elim_mlty env ty) fields) + + | MLTD_DType inductive -> + env, + parameters, + MLTD_DType ( + List.map + (fun (i, constrs) -> + i, List.map (fun (constr, ty) -> constr, elim_mlty env ty) constrs) + inductive + ) + in + let env, parameters, body = + match body with + | None -> + env, parameters, body + | Some td -> + let env, parameters, td = elim_td td in + env, parameters, Some td + in + env, + { td with tydecl_parameters = parameters; + tydecl_defn = body } + +let elim_module env m = + let elim_module1 env m = + match m.mlmodule1_m with + | MLM_Ty td -> + let env, td = BU.fold_map elim_one_mltydecl env td in + env, { m with mlmodule1_m = MLM_Ty td } + | MLM_Let lb -> + env, { m with mlmodule1_m = MLM_Let (elim_letbinding env lb) } + | MLM_Exn (name, sym_tys) -> + env, { m with mlmodule1_m = MLM_Exn (name, List.map (fun (s, t) -> s, elim_mlty env t) sym_tys) } + | MLM_Top e -> + env, { m with mlmodule1_m = MLM_Top (elim_mlexpr env e) } + | _ -> + env, m + in + let env, m = + List.fold_left + (fun (env, out) m -> + try + let env, m = elim_module1 env m in + env, m::out + with + | Drop_tydef -> + env, out) + (env, []) + m + in + env, List.rev m + +let set_current_module (e:env_t) (n:mlpath) = + let curmod = fst n @ [snd n] in + { e with current_module = curmod } + +let elim_mllib (env:env_t) (m:mllib) = + if Options.codegen() <> Some Options.FSharp then env, m else + let (MLLib libs) = m in + let elim_one_lib env lib = + let name, sig_mod, _libs = lib in + let env = set_current_module env name in + let sig_mod, env = + match sig_mod with + | Some (sig_, mod_) -> + //intentionally discard the environment from the module translation + let env, mod_ = elim_module env mod_ in + // The sig is currently empty + Some (sig_, mod_), env + | None -> + None, env + in + env, (name, sig_mod, _libs) + in + let env, libs = + BU.fold_map elim_one_lib env libs + in + env, MLLib libs + +let elim_mllibs (l:list mllib) : list mllib = + snd (BU.fold_map elim_mllib initial_env l) diff --git a/src/extraction/FStarC.Extraction.ML.RemoveUnusedParameters.fsti b/src/extraction/FStarC.Extraction.ML.RemoveUnusedParameters.fsti new file mode 100644 index 00000000000..055ac71b459 --- /dev/null +++ b/src/extraction/FStarC.Extraction.ML.RemoveUnusedParameters.fsti @@ -0,0 +1,27 @@ +(* + Copyright 2020 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +(* -------------------------------------------------------------------- *) +module FStarC.Extraction.ML.RemoveUnusedParameters +open FStarC.Ident +open FStarC.Extraction.ML.Syntax + +val env_t : Type0 +val initial_env : env_t +type tydef = mlsymbol & metadata & either mltyscheme int +val set_current_module (e:env_t) (n:mlpath) : env_t + +val elim_tydefs (env:env_t) (tds:list tydef) : env_t & list tydef +val elim_mllib (env:env_t) (m:mllib) : env_t & mllib diff --git a/src/extraction/FStarC.Extraction.ML.Syntax.fst b/src/extraction/FStarC.Extraction.ML.Syntax.fst new file mode 100644 index 00000000000..68063f1fa4f --- /dev/null +++ b/src/extraction/FStarC.Extraction.ML.Syntax.fst @@ -0,0 +1,286 @@ +(* + Copyright 2008-2016 Abhishek Anand, Nikhil Swamy, + Antoine Delignat-Lavaud, Pierre-Yves Strub + and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +(* -------------------------------------------------------------------- *) +module FStarC.Extraction.ML.Syntax +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.Ident +open FStarC.Compiler.Util +open FStarC.Const +open FStarC.BaseTypes + +open FStarC.Class.Show +open FStarC.Pprint + +(* -------------------------------------------------------------------- *) +let krml_keywords = [] + +let ocamlkeywords = [ + "and"; "as"; "assert"; "asr"; "begin"; "class"; + "constraint"; "do"; "done"; "downto"; "else"; "end"; + "exception"; "external"; "false"; "for"; "fun"; "function"; + "functor"; "if"; "in"; "include"; "inherit"; "initializer"; + "land"; "lazy"; "let"; "lor"; "lsl"; "lsr"; + "lxor"; "match"; "method"; "mod"; "module"; "mutable"; + "new"; "object"; "of"; "open"; "or"; "private"; + "rec"; "sig"; "struct"; "then"; "to"; "true"; + "try"; "type"; "val"; "virtual"; "when"; "while"; + "with"; "nonrec" +] + +let fsharpkeywords = [ + "abstract"; "and"; "as"; "assert"; "base"; "begin"; "class"; + "default"; "delegate"; "do"; "done"; "downcast"; "downto"; + "elif"; "else"; "end"; "exception"; "extern"; "false"; + "finally"; "fixed"; "for"; "fun"; "function"; "global"; "if"; + "in"; "inherit"; "inline"; "interface"; "internal"; "lazy"; + "let"; "let!"; "match"; "member"; "module"; "mutable"; + "namespace"; "new"; "not"; "null"; "of"; "open"; "or"; + "override"; "private"; "public"; "rec"; "return"; "return!"; + "select"; "static"; "struct"; "then"; "to"; "true"; "try"; + "type"; "upcast"; "use"; "use!"; "val"; "void"; "when"; + "while"; "with"; "yield"; "yield!"; + // --mlcompatibility keywords + "asr"; "land"; "lor"; + "lsl"; "lsr"; "lxor"; "mod"; "sig"; + // reserved keywords + "atomic"; "break"; "checked"; "component"; "const"; + "constraint"; "constructor"; "continue"; "eager"; "event"; + "external"; "fixed"; "functor"; "include"; "method"; "mixin"; + "object"; "parallel"; "process"; "protected"; "pure"; + "sealed"; "tailcall"; "trait"; "virtual"; "volatile" +] + +let string_of_mlpath ((p, s) : mlpath) : mlsymbol = + String.concat "." (p @ [s]) + +let dummy_loc: mlloc = 0, "" + +let mk_mlmodule1 m = { mlmodule1_m = m; mlmodule1_attrs = [] } +let mk_mlmodule1_with_attrs m attrs = { mlmodule1_m = m; mlmodule1_attrs = attrs } + +let with_ty_loc t e l = {expr=e; mlty=t; loc = l } +let with_ty t e = with_ty_loc t e dummy_loc + +// do NOT remove Prims, because all mentions of unit/bool in F* are actually Prims.unit/bool. +let ml_unit_ty = MLTY_Erased +let ml_bool_ty = MLTY_Named ([], (["Prims"], "bool")) +let ml_int_ty = MLTY_Named ([], (["Prims"], "int")) +let ml_string_ty = MLTY_Named ([], (["Prims"], "string")) + +let ml_unit = with_ty ml_unit_ty (MLE_Const MLC_Unit) + +let apply_obj_repr : mlexpr -> mlty -> mlexpr = fun x t -> + let repr_name = if Options.codegen() = Some Options.FSharp + then MLE_Name([], "box") + else MLE_Name(["Obj"], "repr") in + let obj_repr = with_ty (MLTY_Fun(t, E_PURE, MLTY_Top)) repr_name in + with_ty_loc MLTY_Top (MLE_App(obj_repr, [x])) x.loc + +let ty_param_names (tys:list ty_param) : list string = + tys |> List.map (fun {ty_param_name} -> ty_param_name) + +let push_unit eff (ts : mltyscheme) : mltyscheme = + let vs, ty = ts in + vs, MLTY_Fun(ml_unit_ty, eff, ty) + +let pop_unit (ts : mltyscheme) : e_tag & mltyscheme = + let vs, ty = ts in + match ty with + | MLTY_Fun (l, eff, t) -> + if l = ml_unit_ty + then eff, (vs, t) + else failwith "unexpected: pop_unit: domain was not unit" + | _ -> + failwith "unexpected: pop_unit: not a function type" +module BU = FStarC.Compiler.Util + +let ctor' (n: string) (args: list document) = + nest 2 (group (parens (flow (break_ 1) (doc_of_string n :: args)))) +let ctor (n: string) (arg: document) = + nest 2 (group (parens (doc_of_string n ^/^ arg))) + +let rec mlty_to_doc (t:mlty) = + match t with + | MLTY_Var v -> doc_of_string v + | MLTY_Fun (t1, _, t2) -> + ctor' "" [mlty_to_doc t1; doc_of_string "->"; mlty_to_doc t2] + | MLTY_Named (ts, p) -> + ctor' "" (List.map mlty_to_doc ts @ [doc_of_string (string_of_mlpath p)]) + | MLTY_Tuple ts -> + ctor "" <| flow_map (doc_of_string " *" ^^ break_ 1) mlty_to_doc ts + | MLTY_Top -> doc_of_string "MLTY_Top" + | MLTY_Erased -> doc_of_string "MLTY_Erased" +let mlty_to_string (t:mlty) = render (mlty_to_doc t) + +let mltyscheme_to_doc (tsc:mltyscheme) = + ctor "" + (brackets (flow_map (comma ^^ break_ 1) doc_of_string (ty_param_names (fst tsc))) + ^^ doc_of_string "," ^/^ mlty_to_doc (snd tsc)) +let mltyscheme_to_string (tsc:mltyscheme) = render (mltyscheme_to_doc tsc) + +let pair a b = group (parens (a ^^ comma ^/^ b)) +let triple a b c = group (parens (a ^^ comma ^/^ b ^^ comma ^/^ c)) +let ctor2 n a b = ctor n (pair a b) +let list_to_doc #t (xs: list t) (f: t -> document) : document = + nest 2 (group (brackets (flow_map (semi ^^ break_ 1) f xs))) +let option_to_doc #t (x: option t) (f: t -> document) : document = + match x with + | Some x -> group (doc_of_string "Some" ^/^ f x) + | None -> doc_of_string "None" +let spaced a = break_ 1 ^^ a ^^ break_ 1 +let record fs = + group <| nest 2 <| braces <| spaced <| separate (semi ^^ break_ 1) fs +let fld n v = group <| nest 2 <| doc_of_string (n ^ " =") ^/^ v + +let rec mlexpr_to_doc (e:mlexpr) = + match e.expr with + | MLE_Const c -> + ctor "MLE_Const" (mlconstant_to_doc c) + | MLE_Var x -> + ctor "MLE_Var" (doc_of_string x) + | MLE_Name (p, x) -> + ctor2 "MLE_Name" (doc_of_string (String.concat "." p)) (doc_of_string x) + | MLE_Let (lbs, e) -> + ctor2 "MLE_Let" (mlletbinding_to_doc lbs) (mlexpr_to_doc e) + | MLE_App (e, es) -> + ctor2 "MLE_App" (mlexpr_to_doc e) (list_to_doc es mlexpr_to_doc) + | MLE_TApp (e, ts) -> + ctor2 "MLE_TApp" (mlexpr_to_doc e) (list_to_doc ts mlty_to_doc) + | MLE_Fun (bs, e) -> + ctor2 "MLE_Fun" + (list_to_doc bs (fun b -> pair (doc_of_string b.mlbinder_name) (mlty_to_doc b.mlbinder_ty))) + (mlexpr_to_doc e) + | MLE_Match (e, bs) -> + ctor2 "MLE_Match" (mlexpr_to_doc e) (list_to_doc bs mlbranch_to_doc) + | MLE_Coerce (e, t1, t2) -> + ctor "MLE_Coerce" <| triple (mlexpr_to_doc e) (mlty_to_doc t1) (mlty_to_doc t2) + | MLE_CTor (p, es) -> + ctor2 "MLE_CTor" (doc_of_string (string_of_mlpath p)) (list_to_doc es mlexpr_to_doc) + | MLE_Seq es -> + ctor "MLE_Seq" (list_to_doc es mlexpr_to_doc) + | MLE_Tuple es -> + ctor "MLE_Tuple" (list_to_doc es mlexpr_to_doc) + | MLE_Record (p, n, es) -> + ctor2 "MLE_Record" (list_to_doc (p@[n]) doc_of_string) + (list_to_doc es (fun (x, e) -> pair (doc_of_string x) (mlexpr_to_doc e))) + | MLE_Proj (e, p) -> + ctor2 "MLE_Proj" (mlexpr_to_doc e) (doc_of_string (string_of_mlpath p)) + | MLE_If (e1, e2, e3) -> + ctor "MLE_If" <| triple (mlexpr_to_doc e1) (mlexpr_to_doc e2) (option_to_doc e3 mlexpr_to_doc) + | MLE_Raise (p, es) -> + ctor2 "MLE_Raise" (doc_of_string (string_of_mlpath p)) (list_to_doc es mlexpr_to_doc) + | MLE_Try (e, bs) -> + ctor2 "MLE_Try" (mlexpr_to_doc e) (list_to_doc bs mlbranch_to_doc) + +and mlbranch_to_doc (p, e1, e2) = + triple (mlpattern_to_doc p) (option_to_doc e1 mlexpr_to_doc) (mlexpr_to_doc e2) + +and mlletbinding_to_doc (lbs) = + parens <| + doc_of_string (match lbs._1 with | Rec -> "Rec" | NonRec -> "NonRec") + ^^ doc_of_string ", " ^^ + list_to_doc lbs._2 mllb_to_doc + +and mllb_to_doc (lb) = + record [ + fld "mllb_name" (doc_of_string lb.mllb_name); + fld "mllb_attrs" (list_to_doc lb.mllb_attrs mlexpr_to_doc); + fld "mllb_tysc" (option_to_doc lb.mllb_tysc (fun (_, t) -> mlty_to_doc t)); + fld "mllb_add_unit" (doc_of_string (string_of_bool lb.mllb_add_unit)); + fld "mllb_def" (mlexpr_to_doc lb.mllb_def); + ] + +and mlconstant_to_doc mlc = + match mlc with + | MLC_Unit -> doc_of_string "MLC_Unit" + | MLC_Bool b -> ctor "MLC_Bool" (doc_of_string (string_of_bool b)) + | MLC_Int (s, None) -> ctor "MLC_Int" (doc_of_string s) + | MLC_Int (s, Some (s1, s2)) -> + ctor "MLC_Int" <| triple (doc_of_string s) underscore underscore + | MLC_Float f -> ctor "MLC_Float" underscore + | MLC_Char c -> ctor "MLC_Char" underscore + | MLC_String s -> ctor "MLC_String" (doc_of_string s) + | MLC_Bytes b -> ctor "MLC_Bytes" underscore + +and mlpattern_to_doc mlp = + match mlp with + | MLP_Wild -> doc_of_string "MLP_Wild" + | MLP_Const c -> ctor "MLP_Const" (mlconstant_to_doc c) + | MLP_Var x -> ctor "MLP_Var" (doc_of_string x) + | MLP_CTor (p, ps) -> ctor2 "MLP_CTor" (doc_of_string (string_of_mlpath p)) (list_to_doc ps mlpattern_to_doc) + | MLP_Branch ps -> ctor "MLP_Branch" (list_to_doc ps mlpattern_to_doc) + + | MLP_Record (path, fields) -> + ctor2 "MLP_Record" + (doc_of_string (String.concat "." path)) + (list_to_doc fields (fun (x, p) -> + pair (doc_of_string x) (mlpattern_to_doc p))) + | MLP_Tuple ps -> + ctor "MLP_Tuple" (list_to_doc ps mlpattern_to_doc) + +let mlbranch_to_string b = render (mlbranch_to_doc b) +let mlletbinding_to_string lb = render (mlletbinding_to_doc lb) +let mllb_to_string lb = render (mllb_to_doc lb) +let mlpattern_to_string p = render (mlpattern_to_doc p) +let mlconstant_to_string c = render (mlconstant_to_doc c) +let mlexpr_to_string e = render (mlexpr_to_doc e) + +let mltybody_to_doc (d:mltybody) : document = + match d with + | MLTD_Abbrev mlty -> ctor "MLTD_Abbrev" (mlty_to_doc mlty) + | MLTD_Record l -> + ctor "MLTD_Record" <| group <| nest 2 <| braces <| spaced <| + flow_map (semi ^^ break_ 1) (fun (x, t) -> pair (doc_of_string x) (mlty_to_doc t)) l + | MLTD_DType l -> + ctor "MLTD_DType" <| group <| nest 2 <| brackets <| spaced <| + flow_map (semi ^^ break_ 1) (fun (x, l) -> pair (doc_of_string x) + (list_to_doc l fun (x, t) -> pair (doc_of_string x) (mlty_to_doc t))) l +let mltybody_to_string (d:mltybody) : string = render (mltybody_to_doc d) + +let one_mltydecl_to_doc (d:one_mltydecl) : document = + record [ + fld "tydecl_name" (doc_of_string d.tydecl_name); + fld "tydecl_parameters" (doc_of_string (String.concat "," (d.tydecl_parameters |> ty_param_names))); + fld "tydecl_defn" (option_to_doc d.tydecl_defn mltybody_to_doc); + ] +let one_mltydecl_to_string (d:one_mltydecl) : string = render (one_mltydecl_to_doc d) + +let mlmodule1_to_doc (m:mlmodule1) : document = + group (match m.mlmodule1_m with + | MLM_Ty d -> doc_of_string "MLM_Ty " ^^ list_to_doc d one_mltydecl_to_doc + | MLM_Let l -> doc_of_string "MLM_Let " ^^ mlletbinding_to_doc l + | MLM_Exn (s, l) -> + doc_of_string "MLM_Exn" ^/^ + pair (doc_of_string s) + (list_to_doc l (fun (x, t) -> pair (doc_of_string x) (mlty_to_doc t))) + | MLM_Top e -> doc_of_string "MLM_Top" ^/^ mlexpr_to_doc e + | MLM_Loc _mlloc -> doc_of_string "MLM_Loc") +let mlmodule1_to_string (m:mlmodule1) : string = render (mlmodule1_to_doc m) + +let mlmodule_to_doc (m:mlmodule) : document = + group <| brackets <| spaced <| separate_map (semi ^^ break_ 1) mlmodule1_to_doc m +let mlmodule_to_string (m:mlmodule) : string = render (mlmodule_to_doc m) + +instance showable_mlty : showable mlty = { show = mlty_to_string } +instance showable_mlconstant : showable mlconstant = { show = mlconstant_to_string } +instance showable_mlexpr : showable mlexpr = { show = mlexpr_to_string } +instance showable_mlmodule1 : showable mlmodule1 = { show = mlmodule1_to_string } +instance showable_mlmodule : showable mlmodule = { show = mlmodule_to_string } diff --git a/src/extraction/FStarC.Extraction.ML.Syntax.fsti b/src/extraction/FStarC.Extraction.ML.Syntax.fsti new file mode 100644 index 00000000000..6ca5d5a9258 --- /dev/null +++ b/src/extraction/FStarC.Extraction.ML.Syntax.fsti @@ -0,0 +1,262 @@ +(* + Copyright 2008-2016 Abhishek Anand, Nikhil Swamy, + Antoine Delignat-Lavaud, Pierre-Yves Strub + and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +(* -------------------------------------------------------------------- *) +module FStarC.Extraction.ML.Syntax +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.Ident +open FStarC.Compiler.Util +open FStarC.Const +open FStarC.BaseTypes + +open FStarC.Class.Show + +(* -------------------------------------------------------------------- *) +type mlsymbol = string +type mlident = mlsymbol +type mlpath = list mlsymbol & mlsymbol //Path and name of a module + +(* -------------------------------------------------------------------- *) +val krml_keywords : list string +val ocamlkeywords : list string +val fsharpkeywords : list string + +val string_of_mlpath : mlpath -> string + +(* -------------------------------------------------------------------- *) +type mlidents = list mlident +type mlsymbols = list mlsymbol + +(* -------------------------------------------------------------------- *) +type e_tag = + | E_PURE + | E_ERASABLE + | E_IMPURE + +// Line number, file name; that's all we can emit in OCaml anyhwow +type mlloc = int & string +val dummy_loc : mlloc + +type mlty = +| MLTY_Var of mlident +| MLTY_Fun of mlty & e_tag & mlty +| MLTY_Named of list mlty & mlpath +| MLTY_Tuple of list mlty +| MLTY_Top (* \mathbb{T} type in the thesis, to be used when OCaml is not expressive enough for the source type *) +| MLTY_Erased //a type that extracts to unit + +type mlconstant = +| MLC_Unit +| MLC_Bool of bool +| MLC_Int of string & option (signedness & width) +| MLC_Float of float +| MLC_Char of char +| MLC_String of string +| MLC_Bytes of array byte + +type mlpattern = +| MLP_Wild +| MLP_Const of mlconstant +| MLP_Var of mlident +| MLP_CTor of mlpath & list mlpattern +| MLP_Branch of list mlpattern +(* SUGAR *) +| MLP_Record of list mlsymbol & list (mlsymbol & mlpattern) +| MLP_Tuple of list mlpattern + + +(* metadata, suitable for either the C or the OCaml backend *) +type meta = + | Mutable (* deprecated *) + | Assumed + | Private + | NoExtract + | CInline + | Substitute + | GCType + | PpxDerivingShow + | PpxDerivingShowConstant of string + | PpxDerivingYoJson + | Comment of string + | StackInline + | CPrologue of string + | CEpilogue of string + | CConst of string + | CCConv of string + | Erased + | CAbstract + | CIfDef + | CMacro + | Deprecated of string + | RemoveUnusedTypeParameters of list int & FStarC.Compiler.Range.range //positional + | HasValDecl of FStarC.Compiler.Range.range //this symbol appears in the interface of a module + | CNoInline + +// rename +type metadata = list meta + +type mlletflavor = + | Rec + | NonRec + +type mlbinder = { + mlbinder_name:mlident; + mlbinder_ty:mlty; + mlbinder_attrs:list mlattribute; +} + +and mlexpr' = +| MLE_Const of mlconstant +| MLE_Var of mlident +| MLE_Name of mlpath +| MLE_Let of mlletbinding & mlexpr //tyscheme for polymorphic recursion +| MLE_App of mlexpr & list mlexpr //why are function types curried, but the applications not curried +| MLE_TApp of mlexpr & list mlty +| MLE_Fun of list mlbinder & mlexpr +| MLE_Match of mlexpr & list mlbranch +| MLE_Coerce of mlexpr & mlty & mlty +(* SUGAR *) +| MLE_CTor of mlpath & list mlexpr +| MLE_Seq of list mlexpr +| MLE_Tuple of list mlexpr +| MLE_Record of list mlsymbol & mlsymbol & list (mlsymbol & mlexpr) // path of record type, + // name of record type, + // and fields with values +| MLE_Proj of mlexpr & mlpath +| MLE_If of mlexpr & mlexpr & option mlexpr +| MLE_Raise of mlpath & list mlexpr +| MLE_Try of mlexpr & list mlbranch + +and mlexpr = { + expr:mlexpr'; + mlty:mlty; + loc: mlloc; +} + +and mlbranch = mlpattern & option mlexpr & mlexpr + +and mllb = { + mllb_name:mlident; + mllb_tysc:option mltyscheme; // May be None for top-level bindings only + mllb_add_unit:bool; + mllb_def:mlexpr; + mllb_attrs:list mlattribute; + mllb_meta:metadata; + print_typ:bool; +} + +and mlletbinding = mlletflavor & list mllb + +and mlattribute = mlexpr + +and ty_param = { + ty_param_name : mlident; + ty_param_attrs : list mlattribute; +} + +and mltyscheme = list ty_param & mlty //forall a1..an. t (the list of binders can be empty) + +type mltybody = +| MLTD_Abbrev of mlty +| MLTD_Record of list (mlsymbol & mlty) +| MLTD_DType of list (mlsymbol & list (mlsymbol & mlty)) + (*list of constructors? list mlty is the list of arguments of the constructors? + One could have instead used a mlty and tupled the argument types? + *) + +type one_mltydecl = { + tydecl_assumed : bool; // bool: this was assumed (C backend) + tydecl_name : mlsymbol; + tydecl_ignored : option mlsymbol; + tydecl_parameters : list ty_param; + tydecl_meta : metadata; + tydecl_defn : option mltybody +} + +type mltydecl = list one_mltydecl // each element of this list is one among a collection of mutually defined types + +type mlmodule1' = +| MLM_Ty of mltydecl +| MLM_Let of mlletbinding +| MLM_Exn of mlsymbol & list (mlsymbol & mlty) +| MLM_Top of mlexpr // this seems outdated +| MLM_Loc of mlloc // Location information; line number + file; only for the OCaml backend + +type mlmodule1 = { + mlmodule1_m : mlmodule1'; + mlmodule1_attrs : list mlattribute; +} + +val mk_mlmodule1 : mlmodule1' -> mlmodule1 +val mk_mlmodule1_with_attrs : mlmodule1' -> list mlattribute -> mlmodule1 + +type mlmodule = list mlmodule1 + +type mlsig1 = +| MLS_Mod of mlsymbol & mlsig +| MLS_Ty of mltydecl + (*used for both type schemes and inductive types. Even inductives are defined in OCaml using type ...., + unlike data in Haskell *) +| MLS_Val of mlsymbol & mltyscheme +| MLS_Exn of mlsymbol & list mlty + +and mlsig = list mlsig1 + +val with_ty_loc : mlty -> mlexpr' -> mlloc -> mlexpr +val with_ty : mlty -> mlexpr' -> mlexpr + +(* -------------------------------------------------------------------- *) +type mllib = + | MLLib of list (mlpath & option (mlsig & mlmodule) & mllib) //Last field never seems to be used. Refactor? + + +(* -------------------------------------------------------------------- *) +val ml_unit_ty : mlty +val ml_bool_ty : mlty +val ml_int_ty : mlty +val ml_string_ty : mlty + +val ml_unit : mlexpr + +val apply_obj_repr : mlexpr -> mlty -> mlexpr + +val ty_param_names (tys:list ty_param) : list string + +val push_unit (eff:e_tag) (ts : mltyscheme) : mltyscheme +val pop_unit (ts : mltyscheme) : e_tag & mltyscheme + +val mltyscheme_to_string (tsc:mltyscheme) : string +val mlbranch_to_string (b:mlbranch) : string +val mlletbinding_to_string (lb:mlletbinding) : string +val mllb_to_string (lb:mllb) : string +val mlpattern_to_string (p:mlpattern) : string + +val mlconstant_to_string (c:mlconstant) : string +val mlty_to_string (t:mlty) : string +val mlexpr_to_string (e:mlexpr) : string +val mltybody_to_string (d:mltybody) : string +val one_mltydecl_to_string (d:one_mltydecl) : string +val mlmodule1_to_string (d:mlmodule1) : string + +instance val showable_mlty : showable mlty +instance val showable_mlconstant : showable mlconstant +instance val showable_mlexpr : showable mlexpr +instance val showable_mlmodule1 : showable mlmodule1 +instance val showable_mlmodule : showable mlmodule diff --git a/src/extraction/FStarC.Extraction.ML.Term.fst b/src/extraction/FStarC.Extraction.ML.Term.fst new file mode 100644 index 00000000000..2a5ae75a2ea --- /dev/null +++ b/src/extraction/FStarC.Extraction.ML.Term.fst @@ -0,0 +1,2084 @@ +(* + Copyright 2008-2015 Abhishek Anand, Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Extraction.ML.Term +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.TypeChecker.Env +open FStarC.Compiler.Util +open FStarC.Const +open FStarC.Ident +open FStarC.Extraction +open FStarC.Extraction.ML +open FStarC.Extraction.ML.Syntax +open FStarC.Extraction.ML.UEnv +open FStarC.Extraction.ML.Util +open FStarC.Syntax.Syntax +open FStarC.Errors + +module BU = FStarC.Compiler.Util +module Code = FStarC.Extraction.ML.Code +module EMB = FStarC.Syntax.Embeddings +module Env = FStarC.TypeChecker.Env +module N = FStarC.TypeChecker.Normalize +module PC = FStarC.Parser.Const +module RC = FStarC.Reflection.V2.Constants +module RD = FStarC.Reflection.V2.Data +module RE = FStarC.Reflection.V2.Embeddings +module R = FStarC.Reflection.V2.Builtins +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module TcEnv = FStarC.TypeChecker.Env +module TcTerm = FStarC.TypeChecker.TcTerm +module TcUtil = FStarC.TypeChecker.Util +module U = FStarC.Syntax.Util + +let dbg_Extraction = Debug.get_toggle "Extraction" +let dbg_ExtractionNorm = Debug.get_toggle "ExtractionNorm" + +exception Un_extractable + +open FStarC.Class.Show +open FStarC.Class.Tagged +open FStarC.Class.PP + + +(* + Below, "the thesis" refers to: + Letouzey, Pierre. + Programmation Fonctionnelle Certifiée: L'extraction de Programmes Dans L'assistant Coq. + Université Paris-Sud, 2004. + + English translation: + Certified Functional Programming + Program extraction within the Coq proof assistant + http://www.pps.univ-paris-diderot.fr/~letouzey/download/these_letouzey_English.ps.gz +*) + +let type_leq g t1 t2 = Util.type_leq (Util.udelta_unfold g) t1 t2 +let type_leq_c g t1 t2 = Util.type_leq_c (Util.udelta_unfold g) t1 t2 +let eraseTypeDeep g t = Util.eraseTypeDeep (Util.udelta_unfold g) t + +module Print = FStarC.Syntax.Print + +(********************************************************************************************) +(* Some basic error reporting; all are fatal errors at this stage *) +(********************************************************************************************) +let err_ill_typed_application env (t : term) mlhead (args : args) (ty : mlty) = + Errors.raise_error t Fatal_IllTyped + (BU.format4 "Ill-typed application: source application is %s \n translated prefix to %s at type %s\n remaining args are %s\n" + (show t) + (Code.string_of_mlexpr (current_module_of_uenv env) mlhead) + (Code.string_of_mlty (current_module_of_uenv env) ty) + (show args)) + +let err_ill_typed_erasure env (pos:Range.range) (ty : mlty) = + Errors.raise_error pos Fatal_IllTyped + (BU.format1 "Erased value found where a value of type %s was expected" + (Code.string_of_mlty (current_module_of_uenv env) ty)) + +let err_value_restriction (t:term) = + Errors.raise_error t Fatal_ValueRestriction + (BU.format2 "Refusing to generalize because of the value restriction: (%s) %s" + (tag_of t) (show t)) + +let err_unexpected_eff env (t:term) ty f0 f1 = + let open FStarC.Errors.Msg in + let open FStarC.Pprint in + Errors.log_issue t Warning_ExtractionUnexpectedEffect [ + prefix 4 1 (text "For expression") (pp t) ^/^ + prefix 4 1 (text "of type") (arbitrary_string (Code.string_of_mlty (current_module_of_uenv env) ty)); + prefix 4 1 (text "Expected effect") (arbitrary_string (eff_to_string f0)) ^/^ + prefix 4 1 (text "got effect") (arbitrary_string (eff_to_string f1))] + +let err_cannot_extract_effect (l:lident) (r:Range.range) (reason:string) (ctxt:string) = + Errors.raise_error r Errors.Fatal_UnexpectedEffect [ + Errors.text <| + BU.format3 "Cannot extract effect %s because %s (when extracting %s)" + (string_of_lid l) reason ctxt + ] + +(***********************************************************************) +(* Translating an effect lid to an e_tag = {E_PURE, E_ERASABLE, E_IMPURE} *) +(***********************************************************************) +let effect_as_etag = + let cache = BU.smap_create 20 in + let rec delta_norm_eff g (l:lident) = + match BU.smap_try_find cache (string_of_lid l) with + | Some l -> l + | None -> + let res = match TypeChecker.Env.lookup_effect_abbrev (tcenv_of_uenv g) [S.U_zero] l with + | None -> l + | Some (_, c) -> delta_norm_eff g (U.comp_effect_name c) in + BU.smap_add cache (string_of_lid l) res; + res in + fun g l -> + let l = delta_norm_eff g l in + if lid_equals l PC.effect_PURE_lid + then E_PURE + else if TcEnv.is_erasable_effect (tcenv_of_uenv g) l + then E_ERASABLE + else + // Reifiable effects should be pure. Added guard because some effect declarations + // don't seem to be in the environment at this point, in particular FStarC.Compiler.Effect.ML + // (maybe because it's primitive?) + let ed_opt = TcEnv.effect_decl_opt (tcenv_of_uenv g) l in + match ed_opt with + | Some (ed, qualifiers) -> + if TcEnv.is_reifiable_effect (tcenv_of_uenv g) ed.mname + then E_PURE + else E_IMPURE + | None -> E_IMPURE + +(********************************************************************************************) +(* Basic syntactic operations on a term *) +(********************************************************************************************) + +(* is_arity t: + t is a sort s, i.e., Type i + or, t = x1:t1 -> ... -> xn:tn -> C + where PC.result_type is an arity + + *) +let rec is_arity_aux tcenv t = + let t = U.unmeta t in + match (SS.compress t).n with + | Tm_unknown + | Tm_delayed _ + | Tm_ascribed _ + | Tm_meta _ -> failwith (BU.format1 "Impossible: is_arity (%s)" (tag_of t)) + | Tm_lazy i -> is_arity_aux tcenv (U.unfold_lazy i) + | Tm_uvar _ + | Tm_constant _ + | Tm_name _ + | Tm_quoted _ + | Tm_bvar _ -> false + | Tm_type _ -> true + | Tm_arrow {comp=c} -> + is_arity_aux tcenv (FStarC.Syntax.Util.comp_result c) + | Tm_fvar fv -> + let topt = + FStarC.TypeChecker.Env.lookup_definition + [Env.Unfold delta_constant] + tcenv + fv.fv_name.v + in + begin + match topt with + | None -> false + | Some (_, t) -> is_arity_aux tcenv t + end + | Tm_app _ -> + let head, _ = U.head_and_args t in + is_arity_aux tcenv head + | Tm_uinst(head, _) -> + is_arity_aux tcenv head + | Tm_refine {b=x} -> + is_arity_aux tcenv x.sort + | Tm_abs {body} + | Tm_let {body} -> + is_arity_aux tcenv body + | Tm_match {brs=branches} -> + begin match branches with + | (_, _, e)::_ -> is_arity_aux tcenv e + | _ -> false + end + +let is_arity env t = is_arity_aux (tcenv_of_uenv env) t + +let push_tcenv_binders (u:uenv) (bs:binders) = + let tcenv = tcenv_of_uenv u in + let tcenv = TcEnv.push_binders tcenv bs in + set_tcenv u tcenv + +//is_type_aux env t: +// Determines whether or not t is a type +// syntactic structure and type annotations +let rec is_type_aux env t = + let t = SS.compress t in + match t.n with + | Tm_delayed _ + | Tm_unknown -> + failwith (BU.format1 "Impossible: %s" (tag_of t)) + + | Tm_lazy i -> is_type_aux env (U.unfold_lazy i) + + | Tm_constant _ -> + false + + | Tm_type _ + | Tm_refine _ + | Tm_arrow _ -> + true + + | Tm_fvar fv when S.fv_eq_lid fv (PC.failwith_lid()) -> + false //special case this, since we emit it during extraction even in prims, before it is in the F* scope + + | Tm_fvar fv -> + UEnv.is_type_name env fv + + | Tm_uvar (u, s) -> + let t= U.ctx_uvar_typ u in + is_arity env (SS.subst' s t) + + | Tm_bvar ({sort=t}) -> + is_arity env t + + | Tm_name x -> ( + let g = UEnv.tcenv_of_uenv env in + match try_lookup_bv g x with + | Some (t, _) -> + is_arity env t + | _ -> ( + failwith (BU.format1 "Extraction: variable not found: %s" (tag_of t)) + ) + ) + + | Tm_ascribed {tm=t} -> + is_type_aux env t + + | Tm_uinst(t, _) -> + is_type_aux env t + + | Tm_abs {bs; body} -> + let bs, body = SS.open_term bs body in + let env = push_tcenv_binders env bs in + is_type_aux env body + + | Tm_let {lbs=(false, [lb]); body} -> + let x = BU.left lb.lbname in + let bs, body = SS.open_term [S.mk_binder x] body in + let env = push_tcenv_binders env bs in + is_type_aux env body + + | Tm_let {lbs=(_, lbs); body} -> + let lbs, body = SS.open_let_rec lbs body in + let env = push_tcenv_binders env (List.map (fun lb -> S.mk_binder (BU.left lb.lbname)) lbs) in + is_type_aux env body + + | Tm_match {brs=branches} -> + begin match branches with + | b::_ -> ( + let pat, _, e = SS.open_branch b in + match FStarC.TypeChecker.PatternUtils.raw_pat_as_exp (tcenv_of_uenv env) pat with + | None -> false + | Some (_, bvs) -> + let binders = List.map (fun bv -> S.mk_binder bv) bvs in + let env = push_tcenv_binders env binders in + is_type_aux env e + ) + | _ -> false + end + + | Tm_quoted _ -> false + + | Tm_meta {tm=t} -> + is_type_aux env t + + | Tm_app {hd=head} -> + is_type_aux env head + +let is_type env t = + debug env (fun () -> BU.print2 "checking is_type (%s) %s\n" + (tag_of t) + (show t) + ); + let b = is_type_aux env t in + debug env (fun _ -> + if b + then BU.print2 "yes, is_type %s (%s)\n" (show t) (tag_of t) + else BU.print2 "not a type %s (%s)\n" (show t) (tag_of t)); + b + +let is_type_binder env x = is_arity env x.binder_bv.sort + +let is_constructor t = match (SS.compress t).n with + | Tm_fvar ({fv_qual=Some Data_ctor}) + | Tm_fvar ({fv_qual=Some (Record_ctor _)}) -> true + | _ -> false + +(* something is a value iff it qualifies for the OCaml's "value restriction", + which determines when a definition can be generalized *) +let rec is_fstar_value (t:term) = + match (SS.compress t).n with + | Tm_constant _ + | Tm_bvar _ + | Tm_fvar _ + | Tm_abs _ -> true + | Tm_app {hd=head; args} -> + if is_constructor head + then args |> List.for_all (fun (te, _) -> is_fstar_value te) + else false + (* Consider: + let f (a:Type) (x:a) : Tot a = x + let g = f int + + In principle, after erasure, g can be generalized. + But, we don't distinguish type- from term applications right now + and consider (f int) to be non-generalizable non-value. + + This may cause extraction to eta-expand g, which isn't terrible, + but we should improve it. + *) + | Tm_meta {tm=t} + | Tm_ascribed {tm=t} -> is_fstar_value t + | _ -> false + +let rec is_ml_value e = + match e.expr with + | MLE_Const _ + | MLE_Var _ + | MLE_Name _ + | MLE_Fun _ -> true + | MLE_CTor (_, exps) + | MLE_Tuple exps -> BU.for_all is_ml_value exps + | MLE_Record (_, _, fields) -> BU.for_all (fun (_, e) -> is_ml_value e) fields + | MLE_TApp (h, _) -> is_ml_value h + | _ -> false + +(*copied from ocaml-asttrans.fs*) + +//pre-condition: SS.compress t = Tm_abs _ +//Collapses adjacent abstractions into a single n-ary abstraction +let normalize_abs (t0:term) : term = + let rec aux bs t copt = + let t = SS.compress t in + match t.n with + | Tm_abs {bs=bs'; body; rc_opt=copt} -> aux (bs@bs') body copt + | _ -> + let e' = U.unascribe t in + if U.is_fun e' + then aux bs e' copt + else U.abs bs e' copt in + aux [] t0 None + +let unit_binder () = S.mk_binder <| S.new_bv None t_unit + +//check_pats_for_ite l: +// A helper to enable translating boolean matches back to if/then/else +let check_pats_for_ite (l:list (pat & option term & term)) : (bool //if l is pair of boolean branches + & option term //the 'then' case + & option term) = //the 'else' case + let def = false, None, None in + if List.length l <> 2 then def + else + let (p1, w1, e1) = List.hd l in + let (p2, w2, e2) = List.hd (List.tl l) in + match (w1, w2, p1.v, p2.v) with + | (None, None, Pat_constant (Const_bool true), Pat_constant (Const_bool false)) -> true, Some e1, Some e2 + | (None, None, Pat_constant (Const_bool false), Pat_constant (Const_bool true)) -> true, Some e2, Some e1 +// | (None, None, Pat_constant (Const_bool false), Pat_wild _) +// | (None, None, Pat_constant (Const_bool false), Pat_var _) +// | (None, None, Pat_constant (Const_bool true), Pat_wild _) +// | (None, None, Pat_constant (Const_bool true), Pat_var _) + | _ -> def + + +(* INVARIANT: we MUST always perform deep erasure after extraction of types, even + * when done indirectly e.g. translate_typ_of_arg below. + * Otherwise, there will be Obj.magic because the types get erased at some places + * and not at other places *) +//let translate_typ (g:env) (t:typ) : mlty = eraseTypeDeep g (TypeExtraction.ext g t) +//let translate_typ_of_arg (g:env) (a:arg) : mlty = eraseTypeDeep g (TypeExtraction.getTypeFromArg g a) +// erasing here is better because if we need to generate OCaml types for binders and return values, they will be accurate. By the time we reach maybe_coerce, we cant change those + + +(********************************************************************************************) +(* Operations on ml terms, types, and effect tags *) +(* 1. Instantiation of type schemes *) +(* 2. Erasure of terms *) +(* 3. Coercion (Obj.magic) *) +(********************************************************************************************) + +//instantiate_tyscheme s args: +// only handles fully applied types, +// pre-condition: List.length (fst s) = List.length args +let instantiate_tyscheme (s:mltyscheme) (args:list mlty) : mlty = Util.subst s args + +let fresh_mlidents (ts:list mlty) (g:uenv) : list (mlident & mlty) & uenv = + let g, vs_ts = + List.fold_right + (fun t (uenv, vs) -> + let uenv, v = UEnv.new_mlident uenv in + uenv, (v, t)::vs) + ts (g, []) + in + vs_ts, g + +let fresh_binders (ts:list mlty) (g:uenv) : list mlbinder & uenv = + let vs_ts, g = fresh_mlidents ts g in + List.map (fun (v, t) -> {mlbinder_name=v; mlbinder_ty=t; mlbinder_attrs=[]}) vs_ts, + g + +//instantiate_maybe_partial: +// When `e` has polymorphic type `s` +// and isn't instantiated in F* (e.g., because of first-class polymorphism) +// we extract e to a type application in ML by instantiating all its +// type arguments to MLTY_Erased (later, perhaps, being forced to insert magics) +let instantiate_maybe_partial (g:uenv) (e:mlexpr) (eff:e_tag) (s:mltyscheme) (tyargs:list mlty) : (mlexpr & e_tag & mlty) = + let vars, t = s in + let n_vars = List.length vars in + let n_args = List.length tyargs in + if n_args = n_vars + then //easy, just make a type application node + if n_args = 0 + then (e, eff, t) + else + let ts = instantiate_tyscheme (vars, t) tyargs in + let tapp = { + e with + expr=MLE_TApp(e, tyargs); + mlty=ts + } in + (tapp, eff, ts) + else if n_args < n_vars + then //We have a partial type-application in F* + //So, make a full type application node in ML, + //by generating dummy instantiations. + //And then expand it out by adding as many unit + //arguments as dummy instantiations, since these + //will be applied later to F* types that get erased to () + let extra_tyargs = + let _, rest_vars = BU.first_N n_args vars in + rest_vars |> List.map (fun _ -> MLTY_Erased) + in + let tyargs = tyargs@extra_tyargs in + let ts = instantiate_tyscheme (vars, t) tyargs in + let tapp = { + e with + expr=MLE_TApp(e, tyargs); + mlty=ts + } in + let t = + List.fold_left + (fun out t -> MLTY_Fun(t, E_PURE, out)) + ts + extra_tyargs + in + let vs_ts, g = fresh_binders extra_tyargs g in + let f = with_ty t <| MLE_Fun (vs_ts, tapp) in + (f, eff, t) + else failwith "Impossible: instantiate_maybe_partial called with too many arguments" + +(* eta-expand `e` according to its type `t` *) +let eta_expand (g:uenv) (t : mlty) (e : mlexpr) : mlexpr = + let ts, r = doms_and_cod t in + if ts = [] + then e + else // just quit if this is not a function type + let vs_ts, g = fresh_binders ts g in + let vs_es = List.map (fun {mlbinder_name=v; mlbinder_ty=t} -> with_ty t (MLE_Var v)) vs_ts in + let body = with_ty r <| MLE_App (e, vs_es) in + with_ty t <| MLE_Fun (vs_ts, body) + +let default_value_for_ty (g:uenv) (t : mlty) : mlexpr = + let ts, r = doms_and_cod t in + let body r = + let r = + match udelta_unfold g r with + | None -> r + | Some r -> r + in + match r with + | MLTY_Erased -> + ml_unit + | MLTY_Top -> + apply_obj_repr ml_unit MLTY_Erased + | _ -> + with_ty r <| MLE_Coerce (ml_unit, MLTY_Erased, r) + in + if ts = [] + then body r + else let vs_ts, g = fresh_binders ts g in + with_ty t <| MLE_Fun (vs_ts, body r) + +let maybe_eta_expand_coercion g expect e = + if Options.codegen () = Some Options.Krml // we need to stay first order for Karamel + then e + else eta_expand g expect e + +(* + A small optimization to push coercions into the structure of a term + + Otherwise, we often end up with coercions like (Obj.magic (fun x -> e) : a -> b) : a -> c + Whereas with this optimization we produce (fun x -> Obj.magic (e : b) : c) : a -> c +*) +let apply_coercion (pos:Range.range) (g:uenv) (e:mlexpr) (ty:mlty) (expect:mlty) : mlexpr = + if Util.codegen_fsharp() + then //magics are not always sound in F#; warn + FStarC.Errors.log_issue pos + Errors.Warning_NoMagicInFSharp + (BU.format2 + "Inserted an unsafe type coercion in generated code from %s to %s; this may be unsound in F#" + (Code.string_of_mlty (current_module_of_uenv g) ty) + (Code.string_of_mlty (current_module_of_uenv g) expect)); + let mk_fun binder body = + match body.expr with + | MLE_Fun(binders, body) -> + MLE_Fun(binder::binders, body) + | _ -> + MLE_Fun([binder], body) + in + let rec aux (e:mlexpr) ty expect = + let coerce_branch (pat, w, b) = pat, w, aux b ty expect in + //printfn "apply_coercion: %s : %s ~> %s\n%A : %A ~> %A" + // (Code.string_of_mlexpr (current_module_of_uenv g) e) + // (Code.string_of_mlty (current_module_of_uenv g) ty) + // (Code.string_of_mlty (current_module_of_uenv g) expect) + // e ty expect; + (* The expected type may be an abbreviation and not a literal + arrow. Try to unfold it. *) + let rec undelta mlty = + match Util.udelta_unfold g mlty with + | Some t -> undelta t + | None -> mlty + in + match e.expr, ty, undelta expect with + | MLE_Fun(arg::rest, body), MLTY_Fun(t0, _, t1), MLTY_Fun(s0, _, s1) -> + let body = + match rest with + | [] -> body + | _ -> with_ty t1 (MLE_Fun(rest, body)) + in + let body = aux body t1 s1 in + if type_leq g s0 t0 + then with_ty expect (mk_fun arg body) + else let lb = + { mllb_meta = []; + mllb_attrs = []; + mllb_name = arg.mlbinder_name; + mllb_tysc = Some ([], t0); + mllb_add_unit = false; + mllb_def = with_ty t0 (MLE_Coerce(with_ty s0 <| MLE_Var arg.mlbinder_name, s0, t0)); + print_typ=false } + in + let body = with_ty s1 <| MLE_Let((NonRec, [lb]), body) in + with_ty expect (mk_fun {mlbinder_name=arg.mlbinder_name;mlbinder_ty=s0;mlbinder_attrs=[]} body) + + | MLE_Let(lbs, body), _, _ -> + with_ty expect <| (MLE_Let(lbs, aux body ty expect)) + + | MLE_Match(s, branches), _, _ -> + with_ty expect <| MLE_Match(s, List.map coerce_branch branches) + + | MLE_If(s, b1, b2_opt), _, _ -> + with_ty expect <| MLE_If(s, aux b1 ty expect, BU.map_opt b2_opt (fun b2 -> aux b2 ty expect)) + + | MLE_Seq es, _, _ -> + let prefix, last = BU.prefix es in + with_ty expect <| MLE_Seq(prefix @ [aux last ty expect]) + + | MLE_Try(s, branches), _, _ -> + with_ty expect <| MLE_Try(s, List.map coerce_branch branches) + + | _ -> + with_ty expect (MLE_Coerce(e, ty, expect)) + in + aux e ty expect + +//maybe_coerce g e ty expect: +// Inserts an Obj.magic around e if ty e' + | _ -> + match ty with + | MLTY_Erased -> + //generate a default value suitable for the expected type + default_value_for_ty g expect + | _ -> + if type_leq g (erase_effect_annotations ty) (erase_effect_annotations expect) + then let _ = debug g (fun () -> + BU.print2 "\n Effect mismatch on type of %s : %s\n" + (Code.string_of_mlexpr (current_module_of_uenv g) e) + (Code.string_of_mlty (current_module_of_uenv g) ty)) in + e //types differ but only on effect labels, which ML/KaRaMeL don't care about; so no coercion needed + else let _ = debug g (fun () -> + BU.print3 "\n (*needed to coerce expression \n %s \n of type \n %s \n to type \n %s *) \n" + (Code.string_of_mlexpr (current_module_of_uenv g) e) + (Code.string_of_mlty (current_module_of_uenv g) ty) + (Code.string_of_mlty (current_module_of_uenv g) expect)) in + maybe_eta_expand_coercion g expect (apply_coercion pos g e ty expect) + +(********************************************************************************************) +(* The main extraction of terms to ML types *) +(********************************************************************************************) +let bv_as_mlty (g:uenv) (bv:bv) = + match UEnv.lookup_bv g bv with + | Inl ty_b -> ty_b.ty_b_ty + | _ -> MLTY_Top + + +(* term_as_mlty g t: + Inspired by the \hat\epsilon function in the thesis (Sec. 3.3.5) + + pre-condition: is_type t + + First \beta, \iota and \zeta reduce ft. + Since F* does not have SN, one has to be more careful for the termination argument. + Because OCaml does not support computations in Type, MLTY_Top is supposed to be used if they are really unaviodable. + The classic example is the type : T b \def if b then nat else bool. If we dont compute, T true will extract to MLTY_Top. + Why not \delta? I guess the reason is that unfolding definitions will make the resultant OCaml code less readable. + However in the Typ_app case, \delta reduction is done as the second-last resort, just before giving up and returing MLTY_Top; + a bloated type is atleast as good as MLTY_Top? + An an F* specific example, unless we unfold Mem x pre post to StState x wp wlp, we have no idea that it should be translated to x +*) +let extraction_norm_steps = + let extraction_norm_steps_core = + [Env.AllowUnboundUniverses; + Env.EraseUniverses; + Env.Inlining; + Env.Eager_unfolding; + Env.Exclude Env.Zeta; + Env.Primops; + Env.Unascribe; + Env.ForExtraction] in + + let extraction_norm_steps_nbe = + Env.NBE::extraction_norm_steps_core in + + if Options.use_nbe_for_extraction() + then extraction_norm_steps_nbe + else extraction_norm_steps_core + +let normalize_for_extraction (env:uenv) (e:S.term) = + N.normalize extraction_norm_steps (tcenv_of_uenv env) e + +let maybe_reify_comp g (env:TcEnv.env) (c:S.comp) : S.term = + match c |> U.comp_effect_name + |> TcUtil.effect_extraction_mode env with + | S.Extract_reify -> + TcEnv.reify_comp env c S.U_unknown + |> N.normalize extraction_norm_steps env + | S.Extract_primitive -> U.comp_result c + | S.Extract_none s -> + err_cannot_extract_effect (c |> U.comp_effect_name) c.pos s (show c) + +let maybe_reify_term (env:TcEnv.env) (t:S.term) (l:lident) : S.term = + match TcUtil.effect_extraction_mode env l with + | S.Extract_reify -> + TcUtil.norm_reify env + [TcEnv.Inlining; TcEnv.ForExtraction; TcEnv.Unascribe] + (U.mk_reify t (Some l)) + | S.Extract_primitive -> t + | S.Extract_none s -> + err_cannot_extract_effect l t.pos s (show t) + +let has_extract_as_impure_effect (g:uenv) (fv:S.fv) = + TcEnv.fv_has_attr (tcenv_of_uenv g) fv FStarC.Parser.Const.extract_as_impure_effect_lid + +let head_of_type_is_extract_as_impure_effect g t = + let hd, _ = U.head_and_args t in + match (U.un_uinst hd).n with + | Tm_fvar fv -> has_extract_as_impure_effect g fv + | _ -> false + +let rec translate_term_to_mlty (g:uenv) (t0:term) : mlty = + let arg_as_mlty (g:uenv) (a, _) : mlty = + if is_type g a //This is just an optimization; we could in principle always emit MLTY_Erased, at the expense of more magics + then translate_term_to_mlty g a + else MLTY_Erased + in + let fv_app_as_mlty (g:uenv) (fv:fv) (args : args) : mlty = + if not (is_fv_type g fv) + then MLTY_Top //it was translated as an expression or erased + else ( + if has_extract_as_impure_effect g fv + then let (a, _)::_ = args in + translate_term_to_mlty g a + else ( + let formals, _ = + let (_, fvty), _ = FStarC.TypeChecker.Env.lookup_lid (tcenv_of_uenv g) fv.fv_name.v in + let fvty = N.normalize [Env.UnfoldUntil delta_constant; Env.ForExtraction] (tcenv_of_uenv g) fvty in + U.arrow_formals fvty in + let mlargs = List.map (arg_as_mlty g) args in + let mlargs = + let n_args = List.length args in + if List.length formals > n_args //it's not fully applied; so apply the rest to unit + then let _, rest = BU.first_N n_args formals in + mlargs @ (List.map (fun _ -> MLTY_Erased) rest) + else mlargs in + let nm = UEnv.mlpath_of_lident g fv.fv_name.v in + MLTY_Named (mlargs, nm) + ) + ) + in + let aux env t = + let t = SS.compress t in + match t.n with + | Tm_type _ -> MLTY_Erased + + | Tm_bvar _ + | Tm_delayed _ + | Tm_unknown -> failwith (BU.format1 "Impossible: Unexpected term %s" (show t)) + + | Tm_lazy i -> translate_term_to_mlty env (U.unfold_lazy i) + + | Tm_constant _ -> MLTY_Top + | Tm_quoted _ -> MLTY_Top + + | Tm_uvar _ -> MLTY_Top //really shouldn't have any uvars left; TODO: fatal failure? + + | Tm_meta {tm=t} + | Tm_refine {b={sort=t}} + | Tm_uinst(t, _) + | Tm_ascribed {tm=t} -> translate_term_to_mlty env t + + | Tm_name bv -> + bv_as_mlty env bv + + | Tm_fvar fv -> + (* it is not clear whether description in the thesis covers type applications with 0 args. + However, this case is needed to translate types like nnat, and so far seems to work as expected*) + fv_app_as_mlty env fv [] + + | Tm_arrow {bs; comp=c} -> + let bs, c = SS.open_comp bs c in + let mlbs, env = binders_as_ml_binders env bs in + let codom = maybe_reify_comp env (tcenv_of_uenv env) c in + let t_ret = translate_term_to_mlty env codom in + let etag = effect_as_etag env (U.comp_effect_name c) in + let etag = + if etag = E_IMPURE then etag + else if head_of_type_is_extract_as_impure_effect env codom + then E_IMPURE + else etag + in + let _, t = List.fold_right (fun (_, t) (tag, t') -> (E_PURE, MLTY_Fun(t, tag, t'))) mlbs (etag, t_ret) in + t + + (*can this be a partial type application? , i.e can the result of this application be something like Type -> Type, or nat -> Type? : Yes *) + (* should we try to apply additional arguments here? if not, where? FIX!! *) + | Tm_app _ -> + let head, args = U.head_and_args_full t in + let res = match (U.un_uinst head).n, args with + | Tm_name bv, _ -> + (*the args are thrown away, because in OCaml, type variables have type Type and not something like -> .. -> .. Type *) + bv_as_mlty env bv + + | Tm_fvar fv, [_] + when S.fv_eq_lid fv PC.steel_memory_inv_lid -> + translate_term_to_mlty env S.t_unit + + | Tm_fvar fv, _ -> + fv_app_as_mlty env fv args + + | _ -> MLTY_Top in + res + + | Tm_abs {bs;body=ty} -> (* (sch) rule in \hat{\epsilon} *) + (* We just translate the body in an extended environment; the binders will just end up as units *) + let bs, ty = SS.open_term bs ty in + let bts, env = binders_as_ml_binders env bs in + translate_term_to_mlty env ty + + | Tm_let _ + | Tm_match _ -> MLTY_Top + in + + let rec is_top_ty t = match t with + | MLTY_Top -> true + | MLTY_Named _ -> + begin match Util.udelta_unfold g t with + | None -> false + | Some t -> is_top_ty t + end + | _ -> false + in + if TcUtil.must_erase_for_extraction (tcenv_of_uenv g) t0 + then MLTY_Erased + else let mlt = aux g t0 in + if is_top_ty mlt + then MLTY_Top + else mlt + + +and binders_as_ml_binders (g:uenv) (bs:binders) : list (mlident & mlty) & uenv = + let ml_bs, env = bs |> List.fold_left (fun (ml_bs, env) b -> + if is_type_binder g b + then //no first-class polymorphism; so type-binders get wiped out + let b = b.binder_bv in + let env = extend_ty env b true in + let ml_b = (lookup_ty env b).ty_b_name in + let ml_b = (ml_b (*name of the binder*), + ml_unit_ty (*type of the binder. correspondingly, this argument gets converted to the unit value in application *)) in + ml_b::ml_bs, env + else let b = b.binder_bv in + let t = translate_term_to_mlty env b.sort in + let env, b, _ = extend_bv env b ([], t) false false in + let ml_b = b, t in + ml_b::ml_bs, env) + ([], g) in + List.rev ml_bs, + env + +let term_as_mlty g t0 = + let t = N.normalize extraction_norm_steps (tcenv_of_uenv g) t0 in + translate_term_to_mlty g t + + +////////////////////////////////////////////////////////////////////////////////////////////// +(********************************************************************************************) +(* The main extraction of terms to ML expressions *) +(********************************************************************************************) +////////////////////////////////////////////////////////////////////////////////////////////// + +//A peephole optimizer for sequences +let mk_MLE_Seq e1 e2 = match e1.expr, e2.expr with + | MLE_Seq es1, MLE_Seq es2 -> MLE_Seq (es1@es2) + | MLE_Seq es1, _ -> MLE_Seq (es1@[e2]) + | _, MLE_Seq es2 -> MLE_Seq (e1::es2) + | _ -> MLE_Seq [e1; e2] + +//A peephole optimizer for let +(* + 1. Optimize (let x : unit = e in ()) to e + 2. Optimize (let x : unit = e in x) to e + 3. Optimize (let x : unit = () in e) to e + 4. Optimize (let x : unit = e in e') to e;e +*) +let mk_MLE_Let top_level (lbs:mlletbinding) (body:mlexpr) = + match lbs with + | (NonRec, [lb]) when not top_level -> + (match lb.mllb_tysc with + | Some ([], t) when (t=ml_unit_ty) -> + if body.expr=ml_unit.expr + then lb.mllb_def.expr //case 1 + else (match body.expr with + | MLE_Var x when (x=lb.mllb_name) -> lb.mllb_def.expr //case 2 + | _ when (lb.mllb_def.expr=ml_unit.expr) -> body.expr //case 3 + | _ -> mk_MLE_Seq lb.mllb_def body) //case 4 + | _ -> MLE_Let(lbs, body)) + | _ -> MLE_Let(lbs, body) + +let record_fields (g:uenv) (ty:lident) (fns:list ident) (xs:list 'a) = + let fns = List.map (fun x -> UEnv.lookup_record_field_name g (ty, x)) fns in + List.map2 (fun (p, s) x -> (s, x)) fns xs + +let resugar_pat g q p = match p with + | MLP_CTor(d, pats) -> + begin match is_xtuple d with + | Some n -> MLP_Tuple(pats) + | _ -> + match q with + | Some (Record_ctor (ty, fns)) -> + let path = List.map string_of_id (ns_of_lid ty) in + let fs = record_fields g ty fns pats in + let path = no_fstar_stubs_ns path in + MLP_Record(path, fs) + | _ -> p + end + | _ -> p + +//extract_pat g p expected_t +// Translates an F* pattern to an ML pattern +// The main work is erasing inaccessible (dot) patterns +// And turning F*'s curried pattern style to ML's fully applied ones +// +//Also, as seen in Bug2595, we need to make sure that the pattern bound +//variables are introduced into the environment at their expected ML type +//rather than their computed F* type, which may be more precise than what +//is typeble in ML. +//E.g., Consider +// v: (b:bool & (if b then bool else nat)) +// and +// match v with +// | (| true, b |) -> ... +// +// In F*, the sort of b is computed to be bool, since the conditional +// can be eliminated +// But, in OCaml, this should be typed as Obj.t, since the type of v itself is +// (bool, Obj.t) dtuple2 +// +let rec extract_one_pat (imp : bool) + (g:uenv) + (p:S.pat) + (expected_ty:mlty) + (term_as_mlexpr:uenv -> S.term -> (mlexpr & e_tag & mlty)) + : uenv + & option (mlpattern & list mlexpr) + & bool = //the bool indicates whether or not a magic should be inserted around the scrutinee + let ok t = + match expected_ty with + | MLTY_Top -> + false + | _ -> + let ok = type_leq g t expected_ty in + if not ok then debug g (fun _ -> BU.print2 "Expected pattern type %s; got pattern type %s\n" + (Code.string_of_mlty (current_module_of_uenv g) expected_ty) + (Code.string_of_mlty (current_module_of_uenv g) t)); + ok + in + match p.v with + | Pat_constant (Const_int (c, swopt)) + when Options.codegen() <> Some Options.Krml -> + //Karamel supports native integer constants in patterns + //Don't convert them into `when` clauses + let mlc, ml_ty = + match swopt with + | None -> + with_ty ml_int_ty <| (MLE_Const (mlconst_of_const p.p (Const_int (c, None)))), + ml_int_ty + | Some sw -> + let source_term = + FStarC.ToSyntax.ToSyntax.desugar_machine_integer (tcenv_of_uenv g).dsenv c sw Range.dummyRange in + let mlterm, _, mlty = term_as_mlexpr g source_term in + mlterm, mlty + in + //these may be extracted to bigint, in which case, we need to emit a when clause + let g, x = UEnv.new_mlident g in + let x_exp = + let x_exp = with_ty expected_ty <| MLE_Var x in + let coerce x = with_ty ml_ty <| (MLE_Coerce(x, ml_ty, expected_ty)) in + match expected_ty with + | MLTY_Top -> coerce x_exp + | _ -> + if ok ml_ty + then x_exp + else coerce x_exp + in + let when_clause = with_ty ml_bool_ty <| + MLE_App(prims_op_equality, [x_exp; + mlc]) in + g, Some (MLP_Var x, [when_clause]), ok ml_ty + + | Pat_constant s -> + let t : term = TcTerm.tc_constant (tcenv_of_uenv g) Range.dummyRange s in + let mlty = term_as_mlty g t in + g, Some (MLP_Const (mlconst_of_const p.p s), []), ok mlty + + | Pat_var x -> + //In some cases, the computed_mlty based on the F* computed sort x.sort + //can be more precise than the type in ML. see e.g., Bug2595 + //So, prefer to extend the environment with the expected ML type of the + //binder rather than the computed_mlty, so that we do not forget to put + //magics around the uses of the bound variable at use sites + let g, x, _ = extend_bv g x ([], expected_ty) false imp in + g, + (if imp then None else Some (MLP_Var x, [])), + true //variables are always ok as patterns, no need to insert a magic on the scrutinee when matching a variable + + | Pat_dot_term _ -> + g, None, true + + | Pat_cons (f, _, pats) -> + // The main subtlety here, relative to Bug2595, is to propapate the + // expected type properly + + //1. Lookup the ML name of the constructor d + // and the type scheme of the constructor tys + // parameterized by the parameters of the inductive it constructs + let d, tys = + match try_lookup_fv p.p g f with + | Some ({exp_b_expr={expr=MLE_Name n}; exp_b_tscheme=ttys}) -> n, ttys + | Some _ -> failwith "Expected a constructor" + | None -> + Errors.raise_error f.fv_name.p Errors.Error_ErasedCtor + (BU.format1 "Cannot extract this pattern, the %s constructor was erased" (show f)) + in + // The prefix of the pattern are dot patterns matching the type parameters + let nTyVars = List.length (fst tys) in + let tysVarPats, restPats = BU.first_N nTyVars pats in + // f_ty is the instantiated type of the constructor + let f_ty = + let mlty_args = + tysVarPats |> + List.map + (fun (p, _) -> + match expected_ty with + | MLTY_Top -> + //if the expected_ty of the pattern is MLTY_Top + //then treat all its parameters as MLTY_Top too + MLTY_Top + | _ -> + //Otherwise, if it has a dot pattern for matching the type parameters + match p.v with + | Pat_dot_term (Some t) -> + //use the type that the dot patterns is instantiated to + term_as_mlty g t + | _ -> + //otherwise, we're back to useing MLTY_Top for this argument + MLTY_Top) + in + //The instantiated type is of the form t1 -> .. -> tn -> T + let f_ty = subst tys mlty_args in + //collect the arguments and result ([t1;...;tn], T) + Util.uncurry_mlty_fun f_ty + in + debug g (fun () -> BU.print2 "@@@Expected type of pattern with head = %s is %s\n" + (show f) + (let args, t = f_ty in + let args = + List.map + (Code.string_of_mlty (current_module_of_uenv g)) + args + |> String.concat " -> " + in + let res = Code.string_of_mlty (current_module_of_uenv g) t in + BU.format2 "%s -> %s" args res)); + // Now extract all the type patterns + // These should all come out as None, if they are dot patterns + // Their expected type does not matter + let g, tyMLPats = + BU.fold_map + (fun g (p, imp) -> + let g, p, _ = extract_one_pat true g p MLTY_Top term_as_mlexpr in + g, p) + g + tysVarPats + in (*not all of these were type vars in ML*) + + // Extract the actual pattern arguments + let (g, f_ty, sub_pats_ok), restMLPats = + BU.fold_map + (fun (g, f_ty, ok) (p, imp) -> + //The ecpected argument type is the type of the i'th field + let f_ty, expected_arg_ty = + match f_ty with + | (hd::rest, res) -> (rest, res), hd + | _ -> ([], MLTY_Top), MLTY_Top + in + let g, p, ok' = extract_one_pat false g p expected_arg_ty term_as_mlexpr in + (g, f_ty, ok && ok'), p) + (g, f_ty, true) + restPats + in + + let mlPats, when_clauses = + List.append tyMLPats restMLPats + |> List.collect (function (Some x) -> [x] | _ -> []) + |> List.split + in + + let pat_ty_compat = + match f_ty with + | ([], t) -> ok t + | _ -> false //arity mismatch, should be impossible + in + g, + Some (resugar_pat g f.fv_qual (MLP_CTor (d, mlPats)), + when_clauses |> List.flatten), + sub_pats_ok && + pat_ty_compat + +let extract_pat (g:uenv) (p:S.pat) (expected_t:mlty) + (term_as_mlexpr: uenv -> S.term -> (mlexpr & e_tag & mlty)) + : (uenv & list (mlpattern & option mlexpr) & bool) = + let extract_one_pat g p expected_t = + match extract_one_pat false g p expected_t term_as_mlexpr with + | g, Some (x, v), b -> g, (x, v), b + | _ -> failwith "Impossible: Unable to translate pattern" + in + let mk_when_clause whens = + match whens with + | [] -> None + | hd::tl -> Some (List.fold_left conjoin hd tl) + in + let g, (p, whens), b = extract_one_pat g p expected_t in + let when_clause = mk_when_clause whens in + g, [(p, when_clause)], b + +(* + maybe_lalloc_eta_data_and_project_record g qual residualType mlAppExpr: + + Preconditions: + 1) residualType is the type of mlAppExpr + 2) mlAppExpr is an MLE_Name or an MLE_App with its head a named fvar, + and isDataCons is true iff it names a data constructor of a data type. + + Postconditions: + 1) the return value (say r) also has type residualType and its + extraction-preimage is definitionally equal in F* to that of mlAppExpr + 2) meets the ML requirements that the args to datacons be tupled + and that the datacons be fully applied + 3) In case qual is record projector and mlAppExpr is of the form (f e), + emits e.f instead, since record projection is primitive in ML +*) +let maybe_eta_data_and_project_record (g:uenv) (qual : option fv_qual) (residualType : mlty) (mlAppExpr : mlexpr) : mlexpr = + let rec eta_args g more_args t = match t with + | MLTY_Fun (t0, _, t1) -> + let g, x = UEnv.new_mlident g in + eta_args g (((x, t0), with_ty t0 <| MLE_Var x)::more_args) t1 + | MLTY_Named (_, _) -> List.rev more_args, t + | _ -> failwith (BU.format2 "Impossible: Head type is not an arrow: (%s : %s)" + (Code.string_of_mlexpr (current_module_of_uenv g) mlAppExpr) + (Code.string_of_mlty (current_module_of_uenv g) t)) + in + let as_record qual e = + match e.expr, qual with + | MLE_CTor(_, args), Some (Record_ctor(tyname, fields)) -> + let path = List.map string_of_id (ns_of_lid tyname) in + let fields = record_fields g tyname fields args in + let path = no_fstar_stubs_ns path in + with_ty e.mlty <| MLE_Record (path, tyname |> ident_of_lid |> string_of_id, fields) + | _ -> e + in + let resugar_and_maybe_eta qual e = + let eargs, tres = eta_args g [] residualType in + match eargs with + | [] -> Util.resugar_exp (as_record qual e) + | _ -> + let binders, eargs = List.unzip eargs in + match e.expr with + | MLE_CTor(head, args) -> + let body = Util.resugar_exp <| (as_record qual <| (with_ty tres <| MLE_CTor(head, args@eargs))) in + with_ty e.mlty <| MLE_Fun(List.map (fun (x,t) -> {mlbinder_name=x;mlbinder_ty=t;mlbinder_attrs=[]}) binders, body) + | _ -> failwith "Impossible: Not a constructor" + in + match mlAppExpr.expr, qual with + | _, None -> mlAppExpr + + | MLE_App({expr=MLE_Name mlp}, mle::args), Some (Record_projector (constrname, f)) + | MLE_App({expr=MLE_TApp({expr=MLE_Name mlp}, _)}, mle::args), Some (Record_projector (constrname, f))-> + let fn = UEnv.lookup_record_field_name g (TcEnv.typ_of_datacon (tcenv_of_uenv g) constrname, f) in + let proj = MLE_Proj(mle, fn) in + let e = match args with + | [] -> proj + | _ -> MLE_App(with_ty MLTY_Top <| proj, args) in //TODO: Fix imprecise with_ty on the projector + with_ty mlAppExpr.mlty e + + | MLE_App ({expr=MLE_Name mlp}, mlargs), Some Data_ctor + | MLE_App ({expr=MLE_Name mlp}, mlargs), Some (Record_ctor _) + | MLE_App ({expr=MLE_TApp({expr=MLE_Name mlp}, _)}, mlargs), Some Data_ctor + | MLE_App ({expr=MLE_TApp({expr=MLE_Name mlp}, _)}, mlargs), Some (Record_ctor _) -> + resugar_and_maybe_eta qual <| (with_ty mlAppExpr.mlty <| MLE_CTor (mlp,mlargs)) + + | MLE_Name mlp, Some Data_ctor + | MLE_Name mlp, Some (Record_ctor _) + | MLE_TApp({expr=MLE_Name mlp}, _), Some Data_ctor + | MLE_TApp({expr=MLE_Name mlp}, _), Some (Record_ctor _) -> + resugar_and_maybe_eta qual <| (with_ty mlAppExpr.mlty <| MLE_CTor (mlp, [])) + + | _ -> mlAppExpr + +let maybe_promote_effect ml_e tag t = + match tag, t with + | E_ERASABLE, MLTY_Erased + | E_PURE, MLTY_Erased -> ml_unit, E_PURE + | _ -> ml_e, tag + + +type lb_sig = + lbname //just lbname returned back + & e_tag //the ML version of the effect label lbeff + & (typ //just the source type lbtyp=t, after compression + & (S.binders //the erased type binders + & mltyscheme)) //translation of the source type t as a ML type scheme + & bool //whether or not to add a unit argument + & bool //whether this was marked CInline + & term //the term e, maybe after some type binders have been erased + +let rec extract_lb_sig (g:uenv) (lbs:letbindings) : list lb_sig = + let maybe_generalize {lbname=lbname_; lbeff=lbeff; lbtyp=lbtyp; lbdef=lbdef; lbattrs=lbattrs} : lb_sig = + let has_c_inline = U.has_attribute lbattrs PC.c_inline_attr in + // begin match lbattrs with + // | [] -> () + // | _ -> + // // BU.print1 "Testing whether term has any rename_let %s..." ""; + // begin match U.get_attribute PC.rename_let_attr lbattrs with + // | Some ((arg, _) :: _) -> + // begin match arg.n with + // | Tm_constant (Const_string (arg, _)) -> + // BU.print1 "Term has rename_let %s\n" arg + // | _ -> BU.print1 "Term has some rename_let %s\n" "" + // end + // | _ -> BU.print1 "no rename_let found %s\n" "" + // end + // end; + let f_e = effect_as_etag g lbeff in + let lbtyp = SS.compress lbtyp in + let no_gen () = + let expected_t = term_as_mlty g lbtyp in + (lbname_, f_e, (lbtyp, ([], ([],expected_t))), false, has_c_inline, lbdef) + in + if TcUtil.must_erase_for_extraction (tcenv_of_uenv g) lbtyp + then (lbname_, f_e, (lbtyp, ([], ([], MLTY_Erased))), false, has_c_inline, lbdef) + else // debug g (fun () -> printfn "Let %s at type %s; expected effect is %A\n" (show lbname) (Print.typ_to_string t) f_e); + match lbtyp.n with + | Tm_arrow {bs; comp=c} when (List.hd bs |> is_type_binder g) -> + let bs, c = SS.open_comp bs c in + //need to generalize, but will erase all the type abstractions; + //If, after erasure, what remains is not a value, then add an extra unit arg. to preserve order of evaluation/generativity + //and to circumvent the value restriction + + //We also erase type arguments that abstract over impure functions, + //replacing the type arguments with a single unit. + //For example, `a:Type -> Dv a` is extracted to `unit -Impure-> 'a` + //The important thing is that we retain an effect tag on the arrow to note + //that the type application is impure. + //See Issue #3473 + let etag_of_comp c = effect_as_etag g (U.comp_effect_name c) in + let tbinders, eff_body, tbody = + match BU.prefix_until (fun x -> not (is_type_binder g x)) bs with + | None -> bs, etag_of_comp c, U.comp_result c + | Some (bs, b, rest) -> bs, E_PURE, U.arrow (b::rest) c + in + let n_tbinders = List.length tbinders in + let lbdef = normalize_abs lbdef |> U.unmeta in + let tbinders_as_ty_params env = List.map (fun ({binder_bv=x; binder_attrs}) -> { + ty_param_name = (UEnv.lookup_ty env x).ty_b_name; + ty_param_attrs = List.map (fun attr -> let e, _, _ = term_as_mlexpr g attr in e) binder_attrs}) in + begin match lbdef.n with + | Tm_abs {bs; body; rc_opt=copt} -> + let bs, body = SS.open_term bs body in + if n_tbinders <= List.length bs + then let targs, rest_args = BU.first_N n_tbinders bs in + let expected_source_ty = + let s = List.map2 (fun ({binder_bv=x}) ({binder_bv=y}) -> S.NT(x, S.bv_to_name y)) tbinders targs in + SS.subst s tbody in + let env = List.fold_left (fun env ({binder_bv=a}) -> UEnv.extend_ty env a false) g targs in + let expected_t = term_as_mlty env expected_source_ty in + let polytype = tbinders_as_ty_params env targs, expected_t in + let add_unit = + match rest_args with + | [] -> + not (is_fstar_value body) //if it's a pure type app, then it will be extracted to a value in ML; so don't add a unit + || not (U.is_pure_comp c) + | _ -> false in + let rest_args = if add_unit then (unit_binder()::rest_args) else rest_args in + let polytype = + if add_unit + then (* record the effect of type application, eff_body *) + push_unit eff_body polytype + else polytype + in + let body = U.abs rest_args body copt in + (lbname_, f_e, (lbtyp, (targs, polytype)), add_unit, has_c_inline, body) + + else (* fails to handle: + let f : a:Type -> b:Type -> a -> b -> Tot (nat * a * b) = + fun (a:Type) -> + let x = 0 in + fun (b:Type) (y:a) (z:b) -> (x, y, z) + + Could eta-expand; but with effects this is problem; see ETA-EXPANSION and NO GENERALIZATION below + *) + failwith "Not enough type binders" //TODO: better error message + + | Tm_uinst _ + | Tm_fvar _ + | Tm_name _ -> + let env = List.fold_left (fun env ({binder_bv=a}) -> UEnv.extend_ty env a false) g tbinders in + let expected_t = term_as_mlty env tbody in + let polytype = tbinders_as_ty_params env tbinders, expected_t in + //In this case, an eta expansion is safe + let args = tbinders |> List.map (fun ({binder_bv=bv}) -> S.bv_to_name bv |> as_arg) in + let e = mk (Tm_app {hd=lbdef; args}) lbdef.pos in + (lbname_, f_e, (lbtyp, (tbinders, polytype)), false, has_c_inline, e) + + | _ -> + //ETA-EXPANSION? + //An alternative here could be to eta expand the body, but with effects, that's quite dodgy + // Consider: + // let f : ML ((a:Type) -> a -> Tot a) = x := 17; (fun (a:Type) (x:a) -> x) + // Eta-expanding this would break the assignment; so, unless we hoist the assignment, we must reject this program + // One possibility is to restrict F* so that the effect of f must be Pure + // In that case, an eta-expansion would be semantically ok, but consider this: + // let g : Tot ((a:Type) -> a -> Tot (a * nat)) = let z = expensive_pure_comp x in fun (a:Type) (x:a) -> (x,z)) + // The eta expansion would cause the expensive_pure_comp to be run each time g is instantiated (this is what Coq does, FYI) + // It may be better to hoist expensive_pure_comp again. + //NO GENERALIZATION: + //Another alternative could be to not generalize the type t, inserting MLTY_Top for the type variables + err_value_restriction lbdef + end + + | _ -> no_gen() + in + snd lbs |> List.map maybe_generalize + +and extract_lb_iface (g:uenv) (lbs:letbindings) + : uenv & list (fv & exp_binding) = + let is_top = FStarC.Syntax.Syntax.is_top_level (snd lbs) in + let is_rec = not is_top && fst lbs in + let lbs = extract_lb_sig g lbs in + BU.fold_map (fun env + (lbname, _e_tag, (typ, (_binders, mltyscheme)), add_unit, _has_c_inline, _body) -> + let env, _, exp_binding = + UEnv.extend_lb env lbname typ mltyscheme add_unit in + env, (BU.right lbname, exp_binding)) + g + lbs + +//The main extraction function +and check_term_as_mlexpr (g:uenv) (e:term) (f:e_tag) (ty:mlty) : (mlexpr & mlty) = + debug g + (fun () -> BU.print3 "Checking %s at type %s and eff %s\n" + (show e) + (Code.string_of_mlty (current_module_of_uenv g) ty) + (Util.eff_to_string f)); + match f, ty with + | E_ERASABLE, _ + | E_PURE, MLTY_Erased -> ml_unit, MLTY_Erased + | _ -> + let ml_e, tag, t = term_as_mlexpr g e in + debug g (fun _ -> + BU.print4 "Extracted %s to %s at eff %s and type %s\n" + (show e) + (Code.string_of_mlexpr (current_module_of_uenv g) ml_e) + (Util.eff_to_string tag) + (Code.string_of_mlty (current_module_of_uenv g) t)); + if eff_leq tag f + then maybe_coerce e.pos g ml_e t ty, ty + else match tag, f, ty with + | E_ERASABLE, E_PURE, MLTY_Erased -> //effect downgrading for erased results + maybe_coerce e.pos g ml_e t ty, ty + | _ -> + err_unexpected_eff g e ty f tag; + maybe_coerce e.pos g ml_e t ty, ty + +and term_as_mlexpr (g:uenv) (e:term) : (mlexpr & e_tag & mlty) = + let e, f, t = term_as_mlexpr' g e in + let e, f = maybe_promote_effect e f t in + e, f, t + + +and term_as_mlexpr' (g:uenv) (top:term) : (mlexpr & e_tag & mlty) = + let top = SS.compress top in + (debug g (fun u -> BU.print_string (BU.format3 "%s: term_as_mlexpr' (%s) : %s \n" + (Range.string_of_range top.pos) + (tag_of top) + (show top)))); + + (* + * AR: Following util functions are to implement the following rule: + * (match e with | P_i -> body_i) args ~~> + * (match e with | P_i -> body_i args) + * + * This opens up more opportunities for reduction, + * especially when using layered effects where reification leads to + * some lambdas introduced and applied this way + * + * Doing it naively results in code blowup (if args are big terms) + * so controlling it specifically + *) + let is_match t = + match (t |> SS.compress |> U.unascribe).n with + | Tm_match _ -> true + | _ -> false in + + let should_apply_to_match_branches : S.args -> bool = + List.for_all (fun (t, _) -> + match (t |> SS.compress).n with + | Tm_name _ | Tm_fvar _ | Tm_constant _ -> true | _ -> false) in + + //precondition: is_match head = true + let apply_to_match_branches head args = + match (head |> SS.compress |> U.unascribe).n with + | Tm_match {scrutinee; brs=branches} -> + let branches = + branches |> List.map (fun (pat, when_opt, body) -> + pat, when_opt, { body with n = Tm_app {hd=body; args} } + ) in + { head with n = Tm_match {scrutinee; ret_opt=None; brs=branches; rc_opt=None} } //AR: dropping the return annotation and rc + | _ -> failwith "Impossible! cannot apply args to match branches if head is not a match" in + + let t = SS.compress top in + match t.n with + | Tm_unknown + | Tm_delayed _ + | Tm_uvar _ + | Tm_bvar _ -> failwith (BU.format1 "Impossible: Unexpected term: %s" (tag_of t)) + + | Tm_lazy i -> term_as_mlexpr g (U.unfold_lazy i) + + | Tm_type _ + | Tm_refine _ + | Tm_arrow _ -> + ml_unit, E_PURE, ml_unit_ty + + | Tm_quoted (qt, { qkind = Quote_dynamic }) -> + let ({exp_b_expr=fw}) = UEnv.lookup_fv t.pos g (S.lid_as_fv (PC.failwith_lid()) None) in + with_ty ml_int_ty <| MLE_App(fw, [with_ty ml_string_ty <| MLE_Const (MLC_String "Cannot evaluate open quotation at runtime")]), + E_PURE, + ml_int_ty + + | Tm_quoted (qt, { qkind = Quote_static; antiquotations = (shift, aqs) }) -> + begin match R.inspect_ln qt with + | RD.Tv_BVar bv -> + (* If it's a variable, check whether it's an antiquotation or just a bvar node *) + if bv.index < shift then + (* just a local bvar *) + let tv' = RD.Tv_BVar bv in + let tv = EMB.embed tv' t.pos None EMB.id_norm_cb in + let t = U.mk_app (RC.refl_constant_term RC.fstar_refl_pack_ln) [S.as_arg tv] in + term_as_mlexpr g t + else + let tm = S.lookup_aq bv (shift, aqs) in + term_as_mlexpr g tm + + | tv -> + (* Else, just embed recursively. *) + let tv = EMB.embed #_ #(RE.e_term_view_aq (shift, aqs)) tv t.pos None EMB.id_norm_cb in + let t = U.mk_app (RC.refl_constant_term RC.fstar_refl_pack_ln) [S.as_arg tv] in + term_as_mlexpr g t + end + + | Tm_meta {tm=t; meta=Meta_monadic (m, _)} -> + // + // A meta monadic node + // We should have taken care of it when we were reifying the Tm_abs + // But it is ok, if the effect is primitive + // + let t = SS.compress t in + begin match t.n with + | Tm_let {lbs=(false, [lb]); body} when (BU.is_left lb.lbname) -> + let tcenv = tcenv_of_uenv g in + let ed, qualifiers = must (TypeChecker.Env.effect_decl_opt tcenv m) in + if TcUtil.effect_extraction_mode tcenv ed.mname = S.Extract_primitive + then term_as_mlexpr g t + else + failwith + (BU.format1 + "This should not happen (should have been handled at Tm_abs level for effect %s)" + (string_of_lid ed.mname)) + | _ -> term_as_mlexpr g t + end + + | Tm_meta {tm=t; meta=Meta_monadic_lift (m1, _m2, _ty)} + when effect_as_etag g m1 = E_ERASABLE -> + (* + * We would come here if m2 is not erasable, + * because if it is, we would not have descended into the outer expression + * + * So if m2 is not erasable, how is erasing this lift justified? + * + * A: The typechecker ensures that _ty is non-informative + *) + ml_unit, E_ERASABLE, MLTY_Erased + + | Tm_meta {tm=t; meta=Meta_desugared (Machine_integer (signedness, width))} -> + + let t = SS.compress t in + let t = U.unascribe t in + (match t.n with + (* Should we check if hd here is [__][u]int_to_t? *) + | Tm_app {hd; args=[x, _]} -> + (let x = SS.compress x in + let x = U.unascribe x in + match x.n with + | Tm_constant (Const_int (repr, _)) -> + (let _, ty, _ = + TcTerm.typeof_tot_or_gtot_term (tcenv_of_uenv g) t true in + let ml_ty = term_as_mlty g ty in + let ml_const = Const_int (repr, Some (signedness, width)) in + with_ty ml_ty (mlexpr_of_const t.pos ml_const), E_PURE, ml_ty) + |_ -> term_as_mlexpr g t) + | _ -> term_as_mlexpr g t) + + | Tm_meta {tm=t} //TODO: handle the resugaring in case it's a 'Meta_desugared' ... for more readable output + | Tm_uinst(t, _) -> + term_as_mlexpr g t + + | Tm_constant c -> + let tcenv = tcenv_of_uenv g in + let _, ty, _ = TcTerm.typeof_tot_or_gtot_term tcenv t true in //AR: TODO: type_of_well_typed? + if TcUtil.must_erase_for_extraction tcenv ty + then ml_unit, E_PURE, MLTY_Erased + else let ml_ty = term_as_mlty g ty in + with_ty ml_ty (mlexpr_of_const t.pos c), E_PURE, ml_ty + + | Tm_name _ -> //lookup in g; decide if its in left or right; tag is Pure because it's just a variable + if is_type g t //Here, we really need to be certain that g is a type; unclear if level ensures it + then ml_unit, E_PURE, ml_unit_ty //Erase type argument + else begin match lookup_term g t with + | Inl _, _ -> + ml_unit, E_PURE, ml_unit_ty + + | Inr ({exp_b_expr=x; exp_b_tscheme=mltys; exp_b_eff=etag}), qual -> + //etag is the effect associated with simply using t, since it may + //be an effectful type application in F* + //in the common case, etag is E_PURE + begin match mltys with + | ([], t) when t=ml_unit_ty -> + ml_unit, etag, t //optimize (x:unit) to () + + | ([], t) -> + maybe_eta_data_and_project_record g qual t x, etag, t + + | _ -> + (* We have a first-class polymorphic value; + Extract it to ML by instantiating its type arguments to MLTY_Erased *) + instantiate_maybe_partial g x etag mltys [] + end + end + + | Tm_fvar fv -> //Nearly identical to Tm_name, except the fv may have been erased altogether; if so return Erased + if is_type g t //Here, we really need to be certain that g is a type + then ml_unit, E_PURE, ml_unit_ty //Erase type argument + else + begin + match try_lookup_fv t.pos g fv with + | None -> //it's been erased + // Errors.log_issue t (Errors.Error_CallToErased, + // BU.format1 "Attempting to extract a call into erased function %s" (show fv)); + ml_unit, E_PURE, MLTY_Erased + + | Some {exp_b_expr=x; exp_b_tscheme=mltys} -> + let _ = debug g (fun () -> + BU.print3 "looked up %s: got %s at %s \n" + (show fv) + (show x) + (show (snd mltys))) in + begin match mltys with + | ([], t) when (t=ml_unit_ty) -> ml_unit, E_PURE, t //optimize (x:unit) to () + | ([], t) -> maybe_eta_data_and_project_record g fv.fv_qual t x, E_PURE, t + | _ -> instantiate_maybe_partial g x E_PURE mltys [] + end + end + + | Tm_abs {bs;body;rc_opt=rcopt} (* the annotated computation type of the body *) -> + let bs, body = SS.open_term bs body in + let ml_bs, env = binders_as_ml_binders g bs in + let ml_bs = List.map2 (fun (x,t) b -> { + mlbinder_name=x; + mlbinder_ty=t; + mlbinder_attrs=List.map (fun attr -> let e, _, _ = term_as_mlexpr env attr in e) b.binder_attrs; + }) ml_bs bs in + let body = + match rcopt with + | Some rc -> + maybe_reify_term (tcenv_of_uenv env) body rc.residual_effect + | None -> debug g (fun () -> BU.print1 "No computation type for: %s\n" (show body)); body in + let ml_body, f, t = term_as_mlexpr env body in + let f, tfun = List.fold_right + (fun {mlbinder_ty=targ} (f, t) -> E_PURE, MLTY_Fun (targ, f, t)) + ml_bs (f, t) in + with_ty tfun <| MLE_Fun(ml_bs, ml_body), f, tfun + + | Tm_app {hd={n=Tm_constant Const_range_of}; args=[(a1, _)]} -> + let ty = term_as_mlty g (tabbrev PC.range_lid) in + with_ty ty <| mlexpr_of_range a1.pos, E_PURE, ty + + | Tm_app {hd={n=Tm_constant Const_set_range_of}; args=[(t, _); (r, _)]} -> + term_as_mlexpr g t + + | Tm_app {hd={n=Tm_constant (Const_reflect _)}} -> + let ({exp_b_expr=fw}) = UEnv.lookup_fv t.pos g (S.lid_as_fv (PC.failwith_lid()) None) in + with_ty ml_int_ty <| MLE_App(fw, [with_ty ml_string_ty <| MLE_Const (MLC_String "Extraction of reflect is not supported")]), + E_PURE, + ml_int_ty + + | Tm_app {hd=head; args} + when is_match head && + args |> should_apply_to_match_branches -> + args |> apply_to_match_branches head |> term_as_mlexpr g + + | Tm_app {hd=head; args} -> + let is_total rc = + Ident.lid_equals rc.residual_effect PC.effect_Tot_lid + || rc.residual_flags |> List.existsb (function TOTAL -> true | _ -> false) + in + + begin match (head |> SS.compress |> U.unascribe).n with //AR: unascribe, gives more opportunities for beta + (* + * AR: do we need is_total rc here? + *) + | Tm_abs {bs; rc_opt=rc} (* when is_total _rc *) -> //this is a beta_redex --- also reduce it before extraction + t + |> N.normalize [Env.Beta; Env.Iota; Env.Zeta; Env.EraseUniverses; Env.AllowUnboundUniverses; Env.ForExtraction] (tcenv_of_uenv g) + |> term_as_mlexpr g + + | Tm_constant (Const_reify lopt) -> + (match lopt with + | Some l -> + let e = maybe_reify_term (tcenv_of_uenv g) (args |> List.hd |> fst) l in + let tm = S.mk_Tm_app (TcUtil.remove_reify e) (List.tl args) t.pos in + term_as_mlexpr g tm + | None -> + raise_error top Errors.Fatal_ExtractionUnsupported + (BU.format1 "Cannot extract %s (reify effect is not set)" (show top)) + ) + + | _ -> + + let rec extract_app is_data (mlhead, mlargs_f) (f(*:e_tag*), t (* the type of (mlhead mlargs) *)) restArgs = + let mk_head () = + let mlargs = List.rev mlargs_f |> List.map fst in + with_ty t <| MLE_App(mlhead, mlargs) + in + debug g (fun () -> BU.print3 "extract_app ml_head=%s type of head = %s, next arg = %s\n" + (Code.string_of_mlexpr (current_module_of_uenv g) (mk_head())) + (Code.string_of_mlty (current_module_of_uenv g) t) + (match restArgs with [] -> "none" | (hd, _)::_ -> show hd)); + // Printf.printf "synth_app restArgs=%d, t=%A\n" (List.length restArgs) t; + match restArgs, t with + | [], _ -> + //1. If partially applied and head is a datacon, it needs to be eta-expanded + //Note, the evaluation order for impure arguments has already been + //enforced in the main type-checker, that already let-binds any + //impure arguments + let app = maybe_eta_data_and_project_record g is_data t (mk_head()) in + app, f, t + + | (arg, _)::rest, MLTY_Fun (formal_t, f', t) + when (is_type g arg + && type_leq g formal_t ml_unit_ty) -> + //non-prefix type app; this type argument gets erased to unit + extract_app is_data (mlhead, (ml_unit, E_PURE)::mlargs_f) (join arg.pos f f', t) rest + + | (e0, _)::rest, MLTY_Fun(tExpected, f', t) -> + //This is the main case of an actualy argument e0 provided to a function + //that expects an argument of type tExpected + let r = e0.pos in + let expected_effect = + if Options.lax() + && FStarC.TypeChecker.Util.short_circuit_head head + then E_IMPURE + else E_PURE in + let e0, tInferred = + check_term_as_mlexpr g e0 expected_effect tExpected in + extract_app is_data (mlhead, (e0, expected_effect)::mlargs_f) (join_l r [f;f'], t) rest + + | _ -> + begin match Util.udelta_unfold g t with + | Some t -> extract_app is_data (mlhead, mlargs_f) (f, t) restArgs + | None -> + match t with + | MLTY_Erased -> //the head of the application has been erased; so the whole application should be too + ml_unit, E_PURE, t + + | MLTY_Top -> //cf. issue #734 + //Coerce to a function of the arity of restArgs + let t = List.fold_right (fun t out -> MLTY_Fun(MLTY_Top, E_PURE, out)) restArgs MLTY_Top in + let mlhead = + let mlargs = List.rev mlargs_f |> List.map fst in + let head = with_ty MLTY_Top <| MLE_App(mlhead, mlargs) in + maybe_coerce top.pos g head MLTY_Top t + in + extract_app is_data (mlhead, []) (f, t) restArgs + + | _ -> + let mlhead = + let mlargs = List.rev mlargs_f |> List.map fst in + let head = with_ty MLTY_Top <| MLE_App(mlhead, mlargs) in + maybe_coerce top.pos g head MLTY_Top t + in + err_ill_typed_application g top mlhead restArgs t + end + in + + let extract_app_maybe_projector is_data mlhead (f, t) args = + match is_data with + | Some (Record_projector _) -> + let rec remove_implicits args f t = match args, t with + | (a0, Some ({ aqual_implicit = true }))::args, MLTY_Fun(_, f', t) -> + remove_implicits args (join a0.pos f f') t + + | _ -> args, f, t in + let args, f, t = remove_implicits args f t in + extract_app is_data (mlhead, []) (f, t) args + + | _ -> extract_app is_data (mlhead, []) (f, t) args in + + let extract_app_with_instantiations () = + let head = U.un_uinst head in + begin match head.n with + | Tm_name _ + | Tm_fvar _ -> + // debug g (fun () -> printfn "head of app is %s\n" (Print.exp_to_string head)); + let (head_ml, (vars, t), head_eff), qual = + match lookup_term g head with + | Inr exp_b, q -> + debug g (fun () -> + BU.print4 "@@@looked up %s: got %s at %s with eff <%s>\n" + (show head) + (show exp_b.exp_b_expr) + (show (snd exp_b.exp_b_tscheme)) + (show exp_b.exp_b_eff)); + (exp_b.exp_b_expr, exp_b.exp_b_tscheme, exp_b.exp_b_eff), q + | _ -> failwith "FIXME Ty" in + + let has_typ_apps = match args with + | (a, _)::_ -> is_type g a + | _ -> false in + let head_ml, head_eff, head_t, args = + (* Here, we have, say, f extracted to head_ml, with a polymorphic ML type with n type-args + If, in F*, `f` is applied to exactly `n` type args, then things are easy: + We extract those n arguments to ML types + Instantiate the type scheme of head_ml + Generate a type application node, and continue + If `f` is only partially applied, i.e., to less than `n` args then + we follow a strategy similar to the case of Tm_name and Tm_fvar + when we deal with higher rank polymorphism. + i.e., we use instantiate_maybe_partial to "complete" the type application + with additional MLTY_Erased type arguments. + + Note, in both cases, we preserve type application in the ML AST + since KaRaMeL requires it. + + See e.g., bug #1694. + *) + let n = List.length vars in + let provided_type_args, rest = + if List.length args <= n + then List.map (fun (x, _) -> term_as_mlty g x) args, + [] + else let prefix, rest = BU.first_N n args in + List.map (fun (x, _) -> term_as_mlty g x) prefix, + rest + in + let head, head_eff, t = + match head_ml.expr with + | MLE_Name _ + | MLE_Var _ -> + let head, eff, t = + instantiate_maybe_partial g head_ml head_eff (vars, t) provided_type_args + in + head, eff, t + + | MLE_App(head, [{expr=MLE_Const MLC_Unit}]) -> + //this happens when the extraction inserted an extra + //unit argument to circumvent ML's value restriction + let head, eff, t = + instantiate_maybe_partial g head head_eff (vars, t) provided_type_args + in + MLE_App(head, [ ml_unit ]) |> with_ty t, + eff, + t + + | _ -> failwith "Impossible: Unexpected head term" + in + head, head_eff, t, rest + in + begin + match args with + | [] -> maybe_eta_data_and_project_record g qual head_t head_ml, head_eff, head_t + | _ -> extract_app_maybe_projector qual head_ml (head_eff, head_t) args + end + + | _ -> + let head, f, t = term_as_mlexpr g head in // t is the type inferred for head, the head of the app + extract_app_maybe_projector None head (f, t) args + end + in + + if is_type g t + then ml_unit, E_PURE, ml_unit_ty //Erase type argument: TODO: FIXME, this could be effectful + else match (U.un_uinst head).n with + | Tm_fvar fv -> + (match try_lookup_fv t.pos g fv with + | None -> //erased head + // Errors.log_issue t + // (Errors.Error_CallToErased, + // BU.format1 "Attempting to extract a call into erased function %s" (show fv)); + ml_unit, E_PURE, MLTY_Erased + | _ -> + extract_app_with_instantiations ()) + + | _ -> + extract_app_with_instantiations () + end + + | Tm_ascribed {tm=e0; asc=(tc, _, _); eff_opt=f} -> + let t = match tc with + | Inl t -> term_as_mlty g t + | Inr c -> term_as_mlty g (maybe_reify_comp g (tcenv_of_uenv g) c) in + let f = match f with + | None -> failwith "Ascription node with an empty effect label" + | Some l -> effect_as_etag g l in + let e, t = check_term_as_mlexpr g e0 f t in + e, f, t + + | Tm_let {lbs=(false, [lb]); body=e'} + when not (is_top_level [lb]) + && BU.is_some (U.get_attribute FStarC.Parser.Const.rename_let_attr lb.lbattrs) -> + let b = S.mk_binder (BU.left lb.lbname) in + let ({binder_bv=x}), body = SS.open_term_1 b e' in + // BU.print_string "Reached let with rename_let attribute\n"; + let suggested_name = + let attr = U.get_attribute FStarC.Parser.Const.rename_let_attr lb.lbattrs in + match attr with + | Some ([(str, _)]) -> + begin + match (SS.compress str).n with + | Tm_constant (Const_string (s, _)) + when s <> "" -> + // BU.print1 "Found suggested name %s\n" s; + let id = Ident.mk_ident (s, range_of_bv x) in + let bv = { ppname = id; index = 0; sort = x.sort } in + let bv = freshen_bv bv in + Some bv + | _ -> + Errors.log_issue top Errors.Warning_UnrecognizedAttribute + "Ignoring ill-formed application of `rename_let`"; + None + end + + | Some _ -> + Errors.log_issue top Errors.Warning_UnrecognizedAttribute + "Ignoring ill-formed application of `rename_let`"; + None + + | None -> + None + in + let remove_attr attrs = + let _, other_attrs = + List.partition + (fun attr -> BU.is_some (U.get_attribute PC.rename_let_attr [attr])) + lb.lbattrs + in + other_attrs + in + let maybe_rewritten_let = + match suggested_name with + | None -> + let other_attrs = remove_attr lb.lbattrs in + Tm_let {lbs=(false, [{lb with lbattrs=other_attrs}]); body=e'} + + | Some y -> + let other_attrs = remove_attr lb.lbattrs in + let rename = [NT(x, S.bv_to_name y)] in + let body = SS.close ([S.mk_binder y]) (SS.subst rename body) in + let lb = { lb with lbname=Inl y; lbattrs=other_attrs } in + Tm_let {lbs=(false, [lb]); body} + in + let top = {top with n = maybe_rewritten_let } in + term_as_mlexpr' g top + + | Tm_let {lbs=(is_rec, lbs); body=e'} -> + let top_level = is_top_level lbs in + let lbs, e' = + if is_rec + then SS.open_let_rec lbs e' + else if is_top_level lbs + then lbs, e' + else let lb = List.hd lbs in + let x = S.freshen_bv (left lb.lbname) in + let lb = {lb with lbname=Inl x} in + let e' = SS.subst [DB(0, x)] e' in + [lb], e' in + let lbs = + if top_level + then + let tcenv = TcEnv.set_current_module (tcenv_of_uenv g) + (Ident.lid_of_path ((fst (current_module_of_uenv g)) @ [snd (current_module_of_uenv g)]) Range.dummyRange) in + lbs |> List.map (fun lb -> + // let tcenv = TcEnv.set_current_module (tcenv_of_uenv g) + // (Ident.lid_of_path ((fst (current_module_of_uenv g)) @ [snd (current_module_of_uenv g)]) Range.dummyRange) in + // debug g (fun () -> + // BU.print1 "!!!!!!!About to normalize: %s\n" (show lb.lbdef); + // Options.set_option "debug" (Options.List [Options.String "Norm"; Options.String "Extraction"])); + let lbdef = + let norm_call () = + Profiling.profile + (fun () -> + N.normalize (Env.PureSubtermsWithinComputations::Env.Reify::extraction_norm_steps) tcenv lb.lbdef) + (Some (Ident.string_of_lid (Env.current_module tcenv))) + "FStarC.Extraction.ML.Term.normalize_lb_def" + in + if !dbg_Extraction || !dbg_ExtractionNorm + then let _ = BU.print2 "Starting to normalize top-level let %s = %s\n" + (show lb.lbname) + (show lb.lbdef) + in + let a = norm_call() in + BU.print1 "Normalized to %s\n" (show a); + a + else norm_call () + in + {lb with lbdef=lbdef}) + else lbs + in + + let check_lb env (nm_sig : mlident & lb_sig) = + let (nm, (_lbname, f, (_t, (targs, polytype)), add_unit, has_c_inline, e)) = nm_sig in + let env = List.fold_left (fun env ({binder_bv=a}) -> UEnv.extend_ty env a false) env targs in + let expected_t = snd polytype in + let e, ty = check_term_as_mlexpr env e f expected_t in + let e, f = maybe_promote_effect e f expected_t in + let meta = + match f, ty with + | E_PURE, MLTY_Erased + | E_ERASABLE, MLTY_Erased -> [Erased] + | _ -> [] + in + let meta = if has_c_inline then CInline :: meta else meta in + f, {mllb_meta = meta; mllb_attrs = []; mllb_name=nm; mllb_tysc=Some polytype; mllb_add_unit=add_unit; mllb_def=e; print_typ=true} + in + let lbs = extract_lb_sig g (is_rec, lbs) in + + (* env_burn only matters for non-recursive lets and simply burns + * the let bound variable in its own definition to generate + * code that is more understandable. We only do it for OCaml, + * to not affect Karamel naming. *) + let env_body, lbs, env_burn = List.fold_right (fun lb (env, lbs, env_burn) -> + let (lbname, _, (t, (_, polytype)), add_unit, _has_c_inline, _) = lb in + let env, nm, _ = UEnv.extend_lb env lbname t polytype add_unit in + let env_burn = + if Options.codegen () <> Some Options.Krml + then UEnv.burn_name env_burn nm + else env_burn + in + env, (nm,lb)::lbs, env_burn) lbs (g, [], g) + in + + let env_def = if is_rec then env_body else env_burn in + + let lbs = lbs |> List.map (check_lb env_def) in + + let e'_rng = e'.pos in + + let e', f', t' = term_as_mlexpr env_body e' in + + let f = join_l e'_rng (f'::List.map fst lbs) in + + let is_rec = if is_rec = true then Rec else NonRec in + + with_ty_loc t' (mk_MLE_Let top_level (is_rec, List.map snd lbs) e') (Util.mlloc_of_range t.pos), f, t' + + | Tm_match {scrutinee;brs=pats} -> + let e, f_e, t_e = term_as_mlexpr g scrutinee in + let b, then_e, else_e = check_pats_for_ite pats in + let no_lift : mlexpr -> mlty -> mlexpr = fun x t -> x in + if b then + match then_e, else_e with + | Some then_e, Some else_e -> + let then_mle, f_then, t_then = term_as_mlexpr g then_e in + let else_mle, f_else, t_else = term_as_mlexpr g else_e in + let t_branch, maybe_lift = + if type_leq g t_then t_else //the types agree except for effect labels + then t_else, no_lift + else if type_leq g t_else t_then + then t_then, no_lift + else MLTY_Top, apply_obj_repr in + with_ty t_branch <| MLE_If (e, maybe_lift then_mle t_then, Some (maybe_lift else_mle t_else)), + join then_e.pos f_then f_else, + t_branch + | _ -> failwith "ITE pats matched but then and else expressions not found?" + else + let pat_t_compat, mlbranches = pats |> BU.fold_map (fun compat br -> + let pat, when_opt, branch = SS.open_branch br in + let env, p, pat_t_compat = extract_pat g pat t_e term_as_mlexpr in + let when_opt, f_when = match when_opt with + | None -> None, E_PURE + | Some w -> + let w_pos = w.pos in + let w, f_w, t_w = term_as_mlexpr env w in + let w = maybe_coerce w_pos env w t_w ml_bool_ty in + Some w, f_w in + let mlbranch, f_branch, t_branch = term_as_mlexpr env branch in + //Printf.printf "Extracted %s to %A\n" (Print.exp_to_string branch) mlbranch; + compat&&pat_t_compat, + p |> List.map (fun (p, wopt) -> + let when_clause = conjoin_opt wopt when_opt in + p, (when_clause, f_when), (mlbranch, f_branch, t_branch))) + true in + let mlbranches : list (mlpattern & (option mlexpr & e_tag) & (mlexpr & e_tag & mlty)) + = List.flatten mlbranches in + //if the type of the pattern isn't compatible with the type of the scrutinee + // insert a magic around the scrutinee + let e = if pat_t_compat + then e + else (debug g (fun _ -> BU.print2 "Coercing scrutinee %s from type %s because pattern type is incompatible\n" + (Code.string_of_mlexpr (current_module_of_uenv g) e) + (Code.string_of_mlty (current_module_of_uenv g) t_e)); + with_ty t_e <| MLE_Coerce (e, t_e, MLTY_Top)) in + begin match mlbranches with + | [] -> + let ({exp_b_expr=fw}) = UEnv.lookup_fv t.pos g (S.lid_as_fv (PC.failwith_lid()) None) in + with_ty ml_int_ty <| MLE_App(fw, [with_ty ml_string_ty <| MLE_Const (MLC_String "unreachable")]), + E_PURE, + ml_int_ty + + + | (_, _, (_, f_first, t_first))::rest -> + let topt, f_match = List.fold_left (fun (topt, f) (_, _, (_, f_branch, t_branch)) -> + //WARNING WARNING WARNING + //We're explicitly excluding the effect of the when clause in the net effect computation + //TODO: fix this when we handle when clauses fully! + let f = join top.pos f f_branch in + let topt = match topt with + | None -> None + | Some t -> + //we just use the environment g here, since it is only needed for delta unfolding + //which is invariant across the branches + if type_leq g t t_branch + then Some t_branch + else if type_leq g t_branch t + then Some t + else None in + topt, f) + (Some t_first, f_first) + rest in + let mlbranches = mlbranches |> List.map (fun (p, (wopt, _), (b, _, t)) -> + let b = match topt with + | None -> +// Printf.printf "Apply obj repr to %A and %A\n" b t; + apply_obj_repr b t + | Some _ -> b in + (p, wopt, b)) in + let t_match = match topt with + | None -> MLTY_Top + | Some t -> t in + with_ty t_match <| MLE_Match(e, mlbranches), f_match, t_match + end + +let ind_discriminator_body env (discName:lident) (constrName:lident) : mlmodule1 = + // First, lookup the original (F*) type to figure out how many implicit arguments there are. + let _, fstar_disc_type = fst <| TypeChecker.Env.lookup_lid (tcenv_of_uenv env) discName in + let g, wildcards = match (SS.compress fstar_disc_type).n with + | Tm_arrow {bs=binders} -> + let binders = + binders + |> List.filter (function ({binder_qual=Some (Implicit _)}) -> true | _ -> false) + in + List.fold_right + (fun _ (g, vs) -> + let g, v = UEnv.new_mlident g in + g, ((v, MLTY_Top) :: vs)) + binders + (env, []) + | _ -> + failwith "Discriminator must be a function" + in + // Unfortunately, looking up the constructor name in the environment would give us a _curried_ type. + // So, we don't bother popping arrows until we find the return type of the constructor. + // We just use Top. + let g, mlid = UEnv.new_mlident g in + let targ = MLTY_Top in + // Ugly hack: we don't know what to put in there, so we just write a dummy + // polymorphic value to make sure that the type is not printed. + let disc_ty = MLTY_Top in + let discrBody = + let bs = + wildcards @ [(mlid, targ)] + |> List.map (fun (x,t) -> {mlbinder_name=x;mlbinder_ty=t;mlbinder_attrs=[]}) in + with_ty disc_ty <| + MLE_Fun(bs, + with_ty ml_bool_ty <| + (MLE_Match(with_ty targ <| MLE_Name([], mlid), + // Note: it is legal in OCaml to write [Foo _] for a constructor with zero arguments, so don't bother. + [MLP_CTor(mlpath_of_lident g constrName, [MLP_Wild]), + None, + with_ty ml_bool_ty <| MLE_Const(MLC_Bool true); + + MLP_Wild, + None, + with_ty ml_bool_ty <| MLE_Const(MLC_Bool false)]))) + in + let _, name = mlpath_of_lident env discName in + MLM_Let (NonRec, + [{ mllb_meta=[]; + mllb_attrs=[]; + mllb_name=name; + mllb_tysc=None; + mllb_add_unit=false; + mllb_def=discrBody; + print_typ=false}] ) |> mk_mlmodule1 diff --git a/src/extraction/FStarC.Extraction.ML.Term.fsti b/src/extraction/FStarC.Extraction.ML.Term.fsti new file mode 100644 index 00000000000..17d0aed12d2 --- /dev/null +++ b/src/extraction/FStarC.Extraction.ML.Term.fsti @@ -0,0 +1,29 @@ +(* + Copyright 2008-2017 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the Licens + You may obtain a copy of the License at + + http://www.apachorg/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the Licens +*) +module FStarC.Extraction.ML.Term +open FStar.Pervasives +open FStarC.Extraction.ML.UEnv +open FStarC.Ident +open FStarC.Syntax.Syntax +open FStarC.Extraction.ML.Syntax + +val normalize_abs: term -> term +val normalize_for_extraction (env:uenv) (e:term) : term +val is_arity: uenv -> term -> bool +val ind_discriminator_body : env:uenv -> discName:lident -> constrName:lident -> mlmodule1 +val term_as_mlty: uenv -> term -> mlty +val term_as_mlexpr: uenv -> term -> mlexpr & e_tag & mlty +val extract_lb_iface : uenv -> letbindings -> uenv & list (fv & exp_binding) diff --git a/src/extraction/FStarC.Extraction.ML.UEnv.fst b/src/extraction/FStarC.Extraction.ML.UEnv.fst new file mode 100644 index 00000000000..83db90868cf --- /dev/null +++ b/src/extraction/FStarC.Extraction.ML.UEnv.fst @@ -0,0 +1,646 @@ +(* + Copyright 2008-2020 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Extraction.ML.UEnv + +(** This module provides a typing environment used for extracting + programs to ML. It addresses the following main concerns: + + It distinguishes between several kinds of names: + - local type variable ('a, 'b, ...) + - type definition (list, option, ...) + - local variable (x, y, ...) + - top-level names (List.map, ...) + - record field names + - module names + + For each kind, it supports generating an OCaml/F# compatible name + respecting the naming and keyword conventions of those languages. + + Further, for each F* name of a given kind (except for module + names), it generates a unique name in a scope for that kind. + + See tests/bug-reports/Bug310.fst for several examples of the + kinds of concerns this addresses. + *) + +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.Ident +open FStarC.Extraction.ML.Syntax +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.TypeChecker +module U = FStarC.Syntax.Util +module BU = FStarC.Compiler.Util +module Const = FStarC.Parser.Const + +open FStarC.Class.Show + +(**** Type definitions *) + +(** A top-level F* type definition, i.e., a type abbreviation, + corresponds to a [tydef] in ML. + + Note, inductive types (e.g., list, option etc.) are separately + tracked as [tyname], see below. + + - [fv] The source F* identifier + - [tydef_mlmodule_name, tydef_name] An mlpath for [fv] + - [tydef_def]: The definition of the abbreviation + *) +type tydef = { + tydef_fv:fv; + tydef_mlmodule_name:list mlsymbol; + tydef_name:mlsymbol; + tydef_meta:FStarC.Extraction.ML.Syntax.metadata; + tydef_def:mltyscheme +} + +(** tydef is abstract: Some accessors *) +let tydef_fv (td : tydef) = td.tydef_fv +let tydef_meta (td : tydef) = td.tydef_meta +let tydef_def (td : tydef) = td.tydef_def +let tydef_mlpath (td : tydef) : mlpath = td.tydef_mlmodule_name, td.tydef_name + +(** The main type of this module; it's abstract + + - [env_tcenv]: The underlying typechecker environment + - [env_bindings]: names in scope associated with their types + - [env_mlident_map]: The set of names used in the current scope (for freshness) + - [mlpath_of_lid]: A map from a full F* lident to its corresponding mlpath + - [env_fieldname_map]: The set of record field names used in the current in scope (for freshness) + - [mlpath_of_fieldname]: A map from a full F* record field identifier to its corresponding mlpath + - [tydefs]: Type abbreviations in scope + - [type_names]: Inductive type constructors in scope + - [currentModule]: ML name of the current module being extracted + *) +type uenv = { + env_tcenv:TypeChecker.Env.env; + env_bindings:list binding; + env_mlident_map:psmap mlident; + env_remove_typars:RemoveUnusedParameters.env_t; + mlpath_of_lid:psmap mlpath; + env_fieldname_map:psmap mlident; + mlpath_of_fieldname:psmap mlpath; + tydefs:list tydef; + type_names:list (fv&mlpath); + tydef_declarations:psmap bool; + currentModule: mlpath // needed to properly translate the definitions in the current file +} + +(**** Getters and Setters *) + +let tcenv_of_uenv (u:uenv) : TypeChecker.Env.env = u.env_tcenv +let set_tcenv (u:uenv) (t:TypeChecker.Env.env) = { u with env_tcenv=t} +let current_module_of_uenv (u:uenv) : mlpath = u.currentModule +let set_current_module (u:uenv) (m:mlpath) : uenv = { u with currentModule = m } +let with_typars_env (u:uenv) (f:_) = + let e, x = f u.env_remove_typars in + {u with env_remove_typars=e}, x + +(**** Debugging *) + +// Only for debug printing in Modul.fs +let bindings_of_uenv u = u.env_bindings + +let dbg = Debug.get_toggle "Extraction" +let debug g f = + let c = string_of_mlpath g.currentModule in + if !dbg + then f () + +let print_mlpath_map (g:uenv) = + let string_of_mlpath mlp = + String.concat "." (fst mlp) ^ "." ^ (snd mlp) + in + let entries = + BU.psmap_fold g.mlpath_of_lid (fun key value entries -> + BU.format2 "%s -> %s" key (string_of_mlpath value) :: entries) [] + in + String.concat "\n" entries + +(**** Constructors *) + + +(**** Looking up identifiers *) + +(** Scans the list of bindings for an fv: + - it's always mapped to an ML expression + Takes a range for error reporting. + *) + +// Inr b: success +// Inl true: was erased +// Inl false: not found +let lookup_fv_generic (g:uenv) (fv:fv) : either bool exp_binding = + let v = + BU.find_map g.env_bindings + (function + | Fv (fv', t) when fv_eq fv fv' -> Some (Inr t) + | ErasedFv fv' when fv_eq fv fv' -> Some (Inl true) + | _ -> None) + in + match v with + | Some r -> r + | None -> Inl false + +let try_lookup_fv (r:Range.range) (g:uenv) (fv:fv) : option exp_binding = + match lookup_fv_generic g fv with + | Inr r -> Some r + | Inl true -> + (* Log an error/warning and return None *) + let open FStarC.Errors.Msg in + Errors.log_issue r Errors.Error_CallToErased [ + text <| BU.format1 "Will not extract reference to variable `%s` since it has the `noextract` qualifier." (show fv); + text <| "Either remove its qualifier or add it to this definition."; + text <| BU.format1 "This error can be ignored with `--warn_error -%s`." (string_of_int Errors.call_to_erased_errno)]; + None + | Inl false -> + None + +(** Fatal failure version of try_lookup_fv *) +let lookup_fv (r:Range.range) (g:uenv) (fv:fv) : exp_binding = + match lookup_fv_generic g fv with + | Inr t -> t + | Inl b -> + failwith (BU.format3 "Internal error: (%s) free variable %s not found during extraction (erased=%s)\n" + (Range.string_of_range fv.fv_name.p) + (show fv.fv_name.v) + (string_of_bool b)) + +(** An F* local variable (bv) can be mapped either to + a ML type variable or a term variable *) +let lookup_bv (g:uenv) (bv:bv) : ty_or_exp_b = + let x = + BU.find_map g.env_bindings + (function + | Bv (bv', r) when bv_eq bv bv' -> Some r + | _ -> None) + in + match x with + | None -> + failwith (BU.format2 "(%s) bound Variable %s not found\n" + (Range.string_of_range (range_of_id bv.ppname)) + (show bv)) + | Some y -> y + +(** Lookup either a local variable or a top-level name *) +let lookup_term g (t:term) = + match t.n with + | Tm_name x -> lookup_bv g x, None + | Tm_fvar x -> Inr (lookup_fv t.pos g x), x.fv_qual + | _ -> failwith "Impossible: lookup_term for a non-name" + +(** Lookup an local variable mapped to a ML type variable *) +let lookup_ty (g:uenv) (x:bv) : ty_binding = + match lookup_bv g x with + | Inl ty -> ty + | _ -> failwith "Expected a type name" + +(** Lookup a type abbreviation *) +let lookup_tydef (env:uenv) ((module_name, ty_name):mlpath) + : option mltyscheme + = BU.find_map env.tydefs (fun tydef -> + if ty_name = tydef.tydef_name + && module_name = tydef.tydef_mlmodule_name + then Some tydef.tydef_def + else None) + +let has_tydef_declaration (u:uenv) (l:lid) = + match BU.psmap_try_find u.tydef_declarations (Ident.string_of_lid l) with + | None -> false + | Some b -> b + +(** Given an F* qualified name, find its ML counterpart *) +let mlpath_of_lident (g:uenv) (x:lident) : mlpath = + match BU.psmap_try_find g.mlpath_of_lid (string_of_lid x) with + | None -> + debug g (fun _ -> + BU.print1 "Identifier not found: %s" (string_of_lid x); + BU.print1 "Env is \n%s\n" (print_mlpath_map g)); + failwith ("Identifier not found: " ^ string_of_lid x) + | Some mlp -> mlp + +(** Is [fv] the name of an F* inductive type? *) +let is_type_name g fv = + g.type_names |> + BU.for_some (fun (x, _) -> fv_eq fv x) + +(** Is [fv] the name of an F* inductive type or type abbreviation? *) +let is_fv_type g fv = + is_type_name g fv || + g.tydefs |> BU.for_some (fun tydef -> fv_eq fv tydef.tydef_fv) + +let no_fstar_stubs_ns (ns : list mlsymbol) : list mlsymbol = + let pl = Options.codegen () = Some Options.Plugin in + match ns with + | "Prims" :: [] when pl -> "Prims" :: [] + | "FStar"::"Stubs"::rest when pl -> "FStarC"::rest + | "FStar"::"Stubs"::rest -> "FStar"::rest // unclear + | _ -> ns + +let no_fstar_stubs (p : mlpath) : mlpath = + let ns, id = p in + let ns = no_fstar_stubs_ns ns in + ns, id + +(** Find the ML counterpart of an F* record field identifier + + - F* Record field names are pairs of a fully qualified *type* name + and the short field name + + - In ML, the record field name is unique for a given namespace + (i.e., unique per F* module) + + In extend_record_field_name we associate a module-level unique ML + fieldname with the [(type_name, fn)] pair. + *) +let lookup_record_field_name g (type_name, fn) = + let key = Ident.lid_of_ids (ids_of_lid type_name @ [fn]) in + match BU.psmap_try_find g.mlpath_of_fieldname (string_of_lid key) with + | None -> failwith ("Field name not found: " ^ string_of_lid key) + | Some mlp -> + let ns, id = mlp in + if Options.codegen () = Some Options.Plugin + then List.filter (fun s -> s <> "Stubs") ns, id + else ns, id + +(**** Naming conventions and freshness (internal) *) + +(** The initial map of used identifiers is populated + with the keyword list of the target language. + + That ensures that any name we generate doesn't clash + with those keywords + *) +let initial_mlident_map = + let map = BU.mk_ref None in + fun () -> + match !map with + | Some m -> m + | None -> + let m = + List.fold_right + (fun x m -> BU.psmap_add m x "") + (match Options.codegen() with + | Some Options.FSharp -> fsharpkeywords + | Some Options.OCaml + | Some Options.Plugin -> ocamlkeywords + | Some Options.Krml -> krml_keywords + | Some Options.Extension -> [] // TODO + | None -> []) + (BU.psmap_empty()) + in + map := Some m; + m + +(** Enforces naming conventions for indentifiers of term and (local) + type variables: + + - Term variables + - must be sequences of letters, digits, _ and ', + - must beginning with letter or _ + - any other invalid character is replaced with __ + + - Type variables + - must begin with a ' + - their second character cannot be "_" (since that's a weak type variable in OCaml) + - rest of their characters are letter or digit or underscore (no further ' allowed) + - any other invalid character is replaced with 'u' (not _, since + that could introduce a weak type variable) + *) +let rename_conventional (s:string) (is_local_type_variable:bool) : string = + let cs = FStar.String.list_of_string s in + let sanitize_typ () = + let valid_rest c = BU.is_letter_or_digit c in + let aux cs = List.map (fun x -> if valid_rest x then x else 'u') cs in + if List.hd cs = '\'' then List.hd cs :: aux (List.tail cs) + else '\'' :: aux cs + in + let sanitize_term () = + let valid c = BU.is_letter_or_digit c || c = '_' || c = '\'' in + let cs' = List.fold_right (fun c cs -> (if valid c then [c] else ['_';'_'])@cs) cs [] in + match cs' with + | (c::cs) when BU.is_digit c || c = '\'' -> + '_'::c::cs + | _ -> cs + in + FStar.String.string_of_list + (if is_local_type_variable then sanitize_typ() else sanitize_term()) + +(** The root name of a F* local variable, adapted for conventions, is + a prefix of this name in ML, + + It is either the [ppname] (pretty-printing name) + Or, in case the [ppname] is unset, it's the unique name in F* *) +let root_name_of_bv (x:bv): mlident = + if BU.starts_with (string_of_id x.ppname) Ident.reserved_prefix + || is_null_bv x + then Ident.reserved_prefix + else string_of_id x.ppname + +(** Given a candidate root_name, generate an ML identifier + for it that is unique in the current scope. + + By, + - rewriting it to enforce naming conventions + + - and then appending a numeric suffix in case it clashes with + some variable in scope + *) +let find_uniq ml_ident_map root_name is_local_type_variable = + let rec aux i root_name = + let target_mlident = if i = 0 then root_name else root_name ^ (string_of_int i) in + match BU.psmap_try_find ml_ident_map target_mlident with + | Some x -> aux (i+1) root_name + | None -> + let map = BU.psmap_add ml_ident_map target_mlident "" in + target_mlident, map + in + let mlident = rename_conventional root_name is_local_type_variable in + if is_local_type_variable + then let nm, map = aux 0 (BU.substring_from mlident 1) in + "'" ^ nm, map + else aux 0 mlident + +(** The ML namespace corresponding to an F* qualified name + is just all the identifiers in the F* namespace (as strings) *) +let mlns_of_lid (x:lident) = + List.map string_of_id (ns_of_lid x) |> no_fstar_stubs_ns + + +(**** Extending context with identifiers *) + +(** A new [mlpath] for an F* qualified name [x]: + + It's short name (i.e., the last element of [x]) is unique for the + current scope and subsequent names in the scope will not clash + with it. + + E.g., given + {[ + module A + let id = 0 + let foo (id:int) = id + ]} + + we'll generate [id] for the top-level name + and then [id1] for the local variable +*) +let new_mlpath_of_lident (g:uenv) (x : lident) : mlpath & uenv = + let mlp, g = + if Ident.lid_equals x (FStarC.Parser.Const.failwith_lid()) + then ([], string_of_id (ident_of_lid x)), g + else let name, map = find_uniq g.env_mlident_map (string_of_id (ident_of_lid x)) false in + let g = { g with env_mlident_map = map } in + (mlns_of_lid x, name), g + in + let g = { g with + mlpath_of_lid = BU.psmap_add g.mlpath_of_lid (string_of_lid x) mlp + } in + mlp, g + +(** Extending the context with an F* type variable + + - If [map_to_top] is set, then this variable gets mapped to unit in + ML, so it is not always a type variable in ML + *) +let extend_ty (g:uenv) (a:bv) (map_to_top:bool) : uenv = + let is_local_type_variable = not map_to_top in + let ml_a, mlident_map = find_uniq g.env_mlident_map (root_name_of_bv a) is_local_type_variable in + let mapped_to = + if map_to_top + then MLTY_Top + else MLTY_Var ml_a + in + let gamma = Bv(a, Inl ({ty_b_name=ml_a; ty_b_ty=mapped_to}))::g.env_bindings in + let tcenv = TypeChecker.Env.push_bv g.env_tcenv a in + {g with env_bindings=gamma; env_mlident_map=mlident_map; env_tcenv=tcenv} + +(** Extending the context with a local term variable + - [add_unit] is set if the variable should be forced on each use + - [is_rec] if the variable is bound to a local recursive definition + - [mk_unit] if every use of the variable to be erased to [()] + *) +let extend_bv (g:uenv) (x:bv) (t_x:mltyscheme) (add_unit:bool) + (mk_unit:bool (*some pattern terms become unit while extracting*)) + : uenv + & mlident + & exp_binding = + let ml_ty = match t_x with + | ([], t) -> t + | _ -> MLTY_Top in + let mlident, mlident_map = find_uniq g.env_mlident_map (root_name_of_bv x) false in + let mlx = MLE_Var mlident in + let mlx = if mk_unit + then ml_unit + else if add_unit + then with_ty MLTY_Top <| MLE_App(with_ty MLTY_Top mlx, [ml_unit]) + else with_ty ml_ty mlx in + let eff, t_x = if add_unit then pop_unit t_x else E_PURE, t_x in + let exp_binding = {exp_b_name=mlident; exp_b_expr=mlx; exp_b_tscheme=t_x; exp_b_eff=eff } in + let gamma = Bv(x, Inr exp_binding)::g.env_bindings in + let tcenv = TypeChecker.Env.push_binders g.env_tcenv (binders_of_list [x]) in + {g with env_bindings=gamma; env_mlident_map = mlident_map; env_tcenv=tcenv}, mlident, exp_binding + +let burn_name (g:uenv) (i:mlident) : uenv = + { g with env_mlident_map = BU.psmap_add g.env_mlident_map i "" } + +(** Generating a fresh local term variable *) +let new_mlident (g:uenv) + : uenv & mlident + = let ml_ty = MLTY_Top in + let x = FStarC.Syntax.Syntax.new_bv None FStarC.Syntax.Syntax.tun in + let g, id, _ = extend_bv g x ([], MLTY_Top) false false in + g, id + +(** Similar to [extend_bv], except for top-level term identifiers *) +let extend_fv (g:uenv) (x:fv) (t_x:mltyscheme) (add_unit:bool) + : uenv + & mlident + & exp_binding = + let rec mltyFvars (t: mlty) : list mlident = + match t with + | MLTY_Var x -> [x] + | MLTY_Fun (t1, f, t2) -> List.append (mltyFvars t1) (mltyFvars t2) + | MLTY_Named(args, path) -> List.collect mltyFvars args + | MLTY_Tuple ts -> List.collect mltyFvars ts + | MLTY_Top + | MLTY_Erased -> [] + in + let rec subsetMlidents (la : list mlident) (lb : list mlident) : bool = + match la with + | h::tla -> List.contains h lb && subsetMlidents tla lb + | [] -> true + in + let tySchemeIsClosed (tys : mltyscheme) : bool = + subsetMlidents (mltyFvars (snd tys)) (tys |> fst |> ty_param_names) + in + if tySchemeIsClosed t_x + then + let ml_ty = match t_x with + | ([], t) -> t + | _ -> MLTY_Top in + let mlpath, g = new_mlpath_of_lident g x.fv_name.v in + let mlsymbol = snd mlpath in + let mly = MLE_Name mlpath in + let mly = if add_unit then with_ty MLTY_Top <| MLE_App(with_ty MLTY_Top mly, [ml_unit]) else with_ty ml_ty mly in + let eff, t_x = if add_unit then pop_unit t_x else E_PURE, t_x in + let exp_binding = {exp_b_name=mlsymbol; exp_b_expr=mly; exp_b_tscheme=t_x; exp_b_eff=eff } in + let gamma = Fv(x, exp_binding)::g.env_bindings in + let mlident_map = BU.psmap_add g.env_mlident_map mlsymbol "" in + {g with env_bindings=gamma; env_mlident_map=mlident_map}, mlsymbol, exp_binding + else failwith (BU.format1 "freevars found (%s)" (mltyscheme_to_string t_x)) + +let extend_erased_fv (g:uenv) (f:fv) : uenv = + { g with env_bindings = ErasedFv f :: g.env_bindings } + +(** Extend with a let binding, either local or top-level *) +let extend_lb (g:uenv) (l:lbname) (t:typ) (t_x:mltyscheme) (add_unit:bool) + : uenv + & mlident + & exp_binding = + match l with + | Inl x -> + // FIXME missing in lib; NS: what does this mean?? + extend_bv g x t_x add_unit false + | Inr f -> + extend_fv g f t_x add_unit + +(** Extend with an abbreviation [fv] for the type scheme [ts] *) +let extend_tydef (g:uenv) (fv:fv) (ts:mltyscheme) (meta:FStarC.Extraction.ML.Syntax.metadata) + : tydef & mlpath & uenv = + let name, g = new_mlpath_of_lident g fv.fv_name.v in + let tydef = { + tydef_fv = fv; + tydef_mlmodule_name=fst name; + tydef_name = snd name; + tydef_meta = meta; + tydef_def = ts; + } in + tydef, + name, + {g with tydefs=tydef::g.tydefs; type_names=(fv, name)::g.type_names} + +let extend_with_tydef_declaration u l = + { u with tydef_declarations = BU.psmap_add u.tydef_declarations (Ident.string_of_lid l) true } + +(** Extend with [fv], the identifer for an F* inductive type *) +let extend_type_name (g:uenv) (fv:fv) : mlpath & uenv = + let name, g = new_mlpath_of_lident g fv.fv_name.v in + name, + {g with type_names=(fv,name)::g.type_names} + + +(** The [bind] and [return] of an effect declaration + are names like field projectors *) +let extend_with_monad_op_name g (ed:Syntax.eff_decl) nm ts = + (* Extract bind and return of effects as (unqualified) projectors of that effect, *) + (* same as for actions. However, extracted code should not make explicit use of them. *) + let lid = U.mk_field_projector_name_from_ident ed.mname (id_of_text nm) in + let g, mlid, exp_b = extend_fv g (lid_as_fv lid None) ts false in + let mlp = mlns_of_lid lid, mlid in + mlp, lid, exp_b, g + +(** The actions of an effect declaration are qualified to the module + name in which they are defined. *) +let extend_with_action_name g (ed:Syntax.eff_decl) (a:Syntax.action) ts = + let nm = string_of_id (ident_of_lid a.action_name) in + let module_name = ns_of_lid ed.mname in + let lid = Ident.lid_of_ids (module_name@[Ident.id_of_text nm]) in + let g, mlid, exp_b = extend_fv g (lid_as_fv lid None) ts false in + let mlp = mlns_of_lid lid, mlid in + mlp, lid, exp_b, g + +(** Record field names are in a separate namespace in ML and cannot + clash with type names, top-level names, local identifiers etc. + + So, we maintain then in a separate map. + + We generate a unique field name associated with just the + [fn]---the generated [name] is a unique field name for the current + module. + + However, we associate this generated name with the [(type_name, + fn)] pair, and retrieve the unique ML fieldname [name] using this + pair as a key. + + This is important to avoid name clashes among record in the same + module whose fields have overlapping names. See Bug 2058 and + tests/Bug2058.fst + *) +let extend_record_field_name g (type_name, fn) = + let key = Ident.lid_of_ids (ids_of_lid type_name @ [fn]) in + let name, fieldname_map = find_uniq g.env_fieldname_map (string_of_id fn) false in + let ns = mlns_of_lid type_name in + let mlp = ns, name in + let mlp = no_fstar_stubs mlp in + let g = { g with env_fieldname_map = fieldname_map; + mlpath_of_fieldname = BU.psmap_add g.mlpath_of_fieldname (string_of_lid key) mlp } + in + name, g + + +(** Module names are in a different namespace in OCaml + and cannot clash with keywords (since they are uppercase in F* ) + or with other identifiers. + + An F* module name is mapped as is to OCaml. + When printed, instead of A.B.C, we get A_B_C *) +let extend_with_module_name (g:uenv) (m:lid) = + let ns = mlns_of_lid m in + let p = string_of_id (ident_of_lid m) in + (ns, p), g + +(** After completing the extraction of a module + we reset its uses sets so that name generation for the next module + needn't be bothered with names that were generated for prior modules + which are in a different namespace *) +let exit_module g = + { g with env_mlident_map=initial_mlident_map(); + env_fieldname_map=initial_mlident_map()} + + +(**** Constructor for a uenv *) + +let new_uenv (e:TypeChecker.Env.env) + : uenv + = let env = { + env_tcenv = e; + env_bindings =[]; + env_mlident_map=initial_mlident_map (); + env_remove_typars=RemoveUnusedParameters.initial_env; + mlpath_of_lid = BU.psmap_empty(); + env_fieldname_map=initial_mlident_map (); + mlpath_of_fieldname = BU.psmap_empty(); + tydefs =[]; + type_names=[]; + tydef_declarations = BU.psmap_empty(); + currentModule = ([], ""); + } in + (* We handle [failwith] specially, extracting it to OCaml's 'failwith' + rather than FStarC.Compiler.Effect.failwith. Not sure this is necessary *) + let a = "'a" in + let failwith_ty = ([{ty_param_name=a; ty_param_attrs=[]}], + MLTY_Fun(MLTY_Named([], (["Prims"], "string")), E_IMPURE, MLTY_Var a)) in + let g, _, _ = + extend_lb env (Inr (lid_as_fv (Const.failwith_lid()) None)) tun failwith_ty false + in + g diff --git a/src/extraction/FStarC.Extraction.ML.UEnv.fsti b/src/extraction/FStarC.Extraction.ML.UEnv.fsti new file mode 100644 index 00000000000..70a1ac437a8 --- /dev/null +++ b/src/extraction/FStarC.Extraction.ML.UEnv.fsti @@ -0,0 +1,223 @@ +(* + Copyright 2008-2020 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Extraction.ML.UEnv +open FStar.Pervasives +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.Util +open FStarC.Ident +open FStarC.Extraction.ML.Syntax +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.TypeChecker + +(** This module provides a typing environment used for extracting + programs to ML. + + See the implementation for more detailed descriptions. *) + + +(**** Types *) + +type ty_binding = { + ty_b_name:mlident; + ty_b_ty:mlty +} + +type exp_binding = { + exp_b_name:mlident; + exp_b_expr:mlexpr; + exp_b_tscheme:mltyscheme; + exp_b_eff: e_tag +} + +type ty_or_exp_b = either ty_binding exp_binding + +type binding = + | Bv of bv & ty_or_exp_b + | Fv of fv & exp_binding + | ErasedFv of fv + +(** Type abbreviations, aka definitions *) +val tydef : Type0 +val tydef_fv : tydef -> fv +val tydef_meta : tydef -> FStarC.Extraction.ML.Syntax.metadata +val tydef_mlpath : tydef -> mlpath +val tydef_def: tydef -> mltyscheme + +(** The main type of this module *) +val uenv : Type0 +val tcenv_of_uenv : u:uenv -> TypeChecker.Env.env +val set_tcenv : u:uenv -> t:TypeChecker.Env.env -> uenv +val current_module_of_uenv : u:uenv -> mlpath +val set_current_module : u:uenv -> p:mlpath -> uenv +val with_typars_env : uenv -> (RemoveUnusedParameters.env_t -> RemoveUnusedParameters.env_t & 'a) -> uenv & 'a + +(** Debugging only *) +val bindings_of_uenv : uenv -> list binding +val debug: g:uenv -> f:(unit -> unit) -> unit + +(** Constructor *) +val new_uenv : e:TypeChecker.Env.env -> uenv + +(*** Looking up identifiers *) + +(** Lookup a top-level term identifier. Raises an error/warning when the +FV has been erased, using the given range. *) +val try_lookup_fv: Range.range -> g:uenv -> fv:fv -> option exp_binding + +(* As above, but will abort if the variable is not found or was erased. +Only use this for variables that must be in the environment, such as +definitions in Prims. *) +val lookup_fv: Range.range -> g:uenv -> fv:fv -> exp_binding + +(** Lookup a local term or type variable *) +val lookup_bv: g:uenv -> bv: bv -> ty_or_exp_b + +(** Lookup a top-level term or local type variable *) +val lookup_term: g:uenv -> t:term -> ty_or_exp_b & option fv_qual + +(** Lookup a type variable *) +val lookup_ty: g:uenv -> bv:bv -> ty_binding + +(** Lookup a type definition *) +val lookup_tydef : uenv -> mlpath -> option mltyscheme + +(** Does a type definition have an accompanying `val` declaration? *) +val has_tydef_declaration : uenv -> lident -> bool + +(** ML qualified name corresponding to an F* qualified name *) +val mlpath_of_lident : uenv -> lident -> mlpath + +(** Does the fv bind an F* inductive type? *) +val is_type_name : g:uenv -> fv:fv -> bool + +(** Does the fv bind an F* inductive type or abbreviation? *) +val is_fv_type: uenv -> fv -> bool + +(** ML record name for an F* pair of type name and field name *) +val lookup_record_field_name: uenv -> (lident & ident) -> mlpath + +(*** Extending environment *) + + +(** Fresh local identifer *) +val new_mlident : g:uenv -> uenv & mlident + +(** Extend with a type variable, potentially erased to MLTY_Top *) +val extend_ty: g:uenv -> a:bv -> map_to_top:bool -> uenv + +(** Extend with a local term variable, maybe thunked, maybe erased *) +val extend_bv: + uenv -> + bv -> + mltyscheme -> + add_unit: bool -> + mk_unit: bool -> + uenv & mlident & exp_binding + +(** Make sure a given ML name is not used in an environment. The +scope of the environment is not changed at all. This can be used to +generate less confusing names, for instance, in `let x = E in F`, we can +burn `x` in `E` to avoid generating code like `let x = let x = 1 in x in +x`, which does not have any shadowing, but is hard to read. Of course, +`x` is burnt in `F` since it is in-scope there. *) +val burn_name: + uenv -> + mlident -> + uenv + +(** Extend with an top-level term identifier, maybe thunked *) +val extend_fv: + uenv -> + fv -> + mltyscheme -> + add_unit:bool -> + uenv & mlident & exp_binding + +(** Extend the fv environment by marking that a variable was erased. *) +val extend_erased_fv: + uenv -> + fv -> + uenv + +(** Extend with a local or top-level let binding, maybe thunked *) +val extend_lb: + uenv -> + l:lbname -> + t:typ -> + t_x:mltyscheme -> + add_unit:bool -> + uenv & mlident & exp_binding + +(** Extend with a type abbreviation *) +val extend_tydef: + uenv -> + fv -> + mltyscheme -> + FStarC.Extraction.ML.Syntax.metadata -> + tydef & mlpath & uenv + +(** This identifier is for the declaration of a type `val t _ : Type` + We record it in the environment to control later if we are + allows to remove unused type parameters in the definition of `t`. **) +val extend_with_tydef_declaration: + uenv -> + lident -> + uenv + +(** Extend with an inductive type *) +val extend_type_name: + uenv -> + fv -> + mlpath & uenv + +(** Extend with a [bind] or [return], + returns both the ML identifier and the generated F* lid for it *) +val extend_with_monad_op_name: + uenv -> + Syntax.eff_decl -> + string -> (* name of the op *) + mltyscheme -> + mlpath & lident & exp_binding & uenv + +(** Extend with an action, returns both the ML identifer and generated F* lident *) +val extend_with_action_name: + uenv -> + Syntax.eff_decl -> + Syntax.action -> + mltyscheme -> + mlpath & lident & exp_binding & uenv + +(** The F* record field identifier is a pair of the *typename* and the field name *) +val extend_record_field_name : + uenv -> + (lident & ident) -> + mlident & uenv + +(** ML module identifier for an F* module name *) +val extend_with_module_name : + uenv -> + lident -> + mlpath & uenv + +(** Mark exiting a module scope *) +val exit_module : uenv -> uenv + +val no_fstar_stubs : mlpath -> mlpath +val no_fstar_stubs_ns : list mlsymbol -> list mlsymbol diff --git a/src/extraction/FStarC.Extraction.ML.Util.fst b/src/extraction/FStarC.Extraction.ML.Util.fst new file mode 100644 index 00000000000..a98e141af47 --- /dev/null +++ b/src/extraction/FStarC.Extraction.ML.Util.fst @@ -0,0 +1,408 @@ +(* + Copyright 2008-2015 Abhishek Anand, Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Extraction.ML.Util +open Prims +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.Syntax.Embeddings +open FStarC.Extraction.ML +open FStarC.Extraction.ML.Syntax +open FStarC.Const +open FStarC.Ident +open FStarC.Errors +module BU = FStarC.Compiler.Util +module U = FStarC.Syntax.Util +module UEnv = FStarC.Extraction.ML.UEnv +module PC = FStarC.Parser.Const +module Range = FStarC.Compiler.Range +module S = FStarC.Syntax.Syntax +module N = FStarC.TypeChecker.Normalize +module Env = FStarC.TypeChecker.Env + +open FStarC.Class.Show + +let codegen_fsharp () = Options.codegen () = Some Options.FSharp + +let pruneNones (l : list (option 'a)) : list 'a = + List.fold_right (fun x ll -> match x with + | Some xs -> xs::ll + | None -> ll) l [] + + +let mk_range_mle = with_ty MLTY_Top <| MLE_Name (["FStar"; "Range"], "mk_range") +let dummy_range_mle = with_ty MLTY_Top <| MLE_Name (["FStar"; "Range"], "dummyRange") + +(* private *) +let mlconst_of_const' (sctt : sconst) = + match sctt with + | Const_effect -> failwith "Unsupported constant" + + | Const_range _ + | Const_unit -> MLC_Unit + | Const_char c -> MLC_Char c + | Const_int (s, i) -> MLC_Int (s, i) + | Const_bool b -> MLC_Bool b + | Const_string (s, _) -> MLC_String (s) + + | Const_range_of + | Const_set_range_of -> + failwith "Unhandled constant: range_of/set_range_of" + + | Const_real _ + | Const_reify _ + | Const_reflect _ -> + failwith "Unhandled constant: real/reify/reflect" + +let mlconst_of_const (p:Range.range) (c:sconst) = + try mlconst_of_const' c + with _ -> failwith (BU.format2 "(%s) Failed to translate constant %s " (Range.string_of_range p) (show c)) + +let mlexpr_of_range (r:Range.range) : mlexpr' = + let cint (i : int) : mlexpr = + MLC_Int (string_of_int i, None) |> MLE_Const |> with_ty ml_int_ty + in + let cstr (s : string) : mlexpr = + MLC_String s |> MLE_Const |> with_ty ml_string_ty + in + let drop_path = BU.basename in + + // This is not being fully faithful since it disregards + // the use_range, but I assume that's not too bad. + // + // We drop the path of the file to be independent of the machine + // where this was extracted. Otherwise we run into some headaches + // with CI, stability, and moving ml files between hosts. The idea + // is that the pathless filename is enough to locate the actual file, + // since it must have been loaded as a dependency by F*. + MLE_App (mk_range_mle, [Range.file_of_range r |> drop_path |> cstr; + Range.start_of_range r |> Range.line_of_pos |> cint; + Range.start_of_range r |> Range.col_of_pos |> cint; + Range.end_of_range r |> Range.line_of_pos |> cint; + Range.end_of_range r |> Range.col_of_pos |> cint; + ]) + +let mlexpr_of_const (p:Range.range) (c:sconst) : mlexpr' = + (* Special case ranges, which can be extracted but not as constants. + * Maybe a sign that there shouldn't really be a Const_range *) + match c with + | Const_range r -> + mlexpr_of_range r + + | _ -> + MLE_Const (mlconst_of_const p c) + +let rec subst_aux (subst:list (mlident & mlty)) (t:mlty) : mlty = + match t with + | MLTY_Var x -> (match BU.find_opt (fun (y, _) -> y=x) subst with + | Some ts -> snd ts + | None -> t) // TODO : previously, this case would abort. why? this case was encountered while extracting st3.fst + | MLTY_Fun (t1, f, t2) -> MLTY_Fun(subst_aux subst t1, f, subst_aux subst t2) + | MLTY_Named(args, path) -> MLTY_Named(List.map (subst_aux subst) args, path) + | MLTY_Tuple ts -> MLTY_Tuple(List.map (subst_aux subst) ts) + | MLTY_Top + | MLTY_Erased -> t + +let try_subst ((formals, t):mltyscheme) (args:list mlty) : option mlty = + if List.length formals <> List.length args + then None + else Some (subst_aux (List.zip (ty_param_names formals) args) t) + +let subst ts args = + match try_subst ts args with + | None -> + failwith "Substitution must be fully applied (see GitHub issue #490)" + | Some t -> + t + +let udelta_unfold (g:UEnv.uenv) = function + | MLTY_Named(args, n) -> + begin match UEnv.lookup_tydef g n with + | Some ts -> + begin + match try_subst ts args with + | None -> + failwith (BU.format3 "Substitution must be fully applied; got an application of %s with %s args whereas %s were expected (see GitHub issue #490)" + (string_of_mlpath n) + (BU.string_of_int (List.length args)) + (BU.string_of_int (List.length (fst ts)))) + | Some r -> Some r + end + | _ -> None + end + | _ -> None + +let eff_leq f f' = match f, f' with + | E_PURE, _ -> true + | E_ERASABLE, E_ERASABLE -> true + | E_IMPURE, E_IMPURE -> true + | _ -> false + +let eff_to_string = function + | E_PURE -> "Pure" + | E_ERASABLE -> "Erasable" + | E_IMPURE -> "Impure" + +let join r f f' = match f, f' with + | E_IMPURE, E_PURE + | E_PURE , E_IMPURE + | E_IMPURE, E_IMPURE -> E_IMPURE + | E_ERASABLE , E_ERASABLE -> E_ERASABLE + | E_PURE , E_ERASABLE -> E_ERASABLE + | E_ERASABLE , E_PURE -> E_ERASABLE + | E_PURE , E_PURE -> E_PURE + | _ -> failwith (BU.format3 "Impossible (%s): Inconsistent effects %s and %s" + (Range.string_of_range r) + (eff_to_string f) (eff_to_string f')) + +let join_l r fs = List.fold_left (join r) E_PURE fs + +let mk_ty_fun = List.fold_right (fun {mlbinder_ty} t -> MLTY_Fun(mlbinder_ty, E_PURE, t)) + +(* type_leq is essentially the lifting of the sub-effect relation, eff_leq, into function types. + type_leq_c is a coercive variant of type_leq, which implements an optimization to erase the bodies of ghost functions. + Specifically, a function (f : t -> Pure t') can be subsumed to (t -> Ghost t') + In the case where f is a function literal, \x. e, subsuming it to (t -> Ghost t') means that we can simply + erase e to unit right away. +*) +let rec type_leq_c (unfold_ty:unfold_t) (e:option mlexpr) (t:mlty) (t':mlty) : (bool & option mlexpr) = + match t, t' with + | MLTY_Var x, MLTY_Var y -> + if x = y + then true, e + else false, None + + | MLTY_Fun (t1, f, t2), MLTY_Fun (t1', f', t2') -> + let mk_fun xs body = + match xs with + | [] -> body + | _ -> + let e = match body.expr with + | MLE_Fun(ys, body) -> MLE_Fun(xs@ys, body) + | _ -> MLE_Fun(xs, body) in + with_ty (mk_ty_fun xs body.mlty) e in + begin match e with + | Some ({expr=MLE_Fun(x::xs, body)}) -> + if type_leq unfold_ty t1' t1 + && eff_leq f f' + then if f=E_PURE + && f'=E_ERASABLE + then if type_leq unfold_ty t2 t2' + then let body = if type_leq unfold_ty t2 ml_unit_ty + then ml_unit + else with_ty t2' <| MLE_Coerce(ml_unit, ml_unit_ty, t2') in + true, Some (with_ty (mk_ty_fun [x] body.mlty) <| MLE_Fun([x], body)) + else false, None + else let ok, body = type_leq_c unfold_ty (Some <| mk_fun xs body) t2 t2' in + let res = match body with + | Some body -> Some (mk_fun [x] body) + | _ -> None in + ok, res + else false, None + + | _ -> + if type_leq unfold_ty t1' t1 + && eff_leq f f' + && type_leq unfold_ty t2 t2' + then true, e + else false, None + end + + | MLTY_Named(args, path), MLTY_Named(args', path') -> + if path=path' + then if List.forall2 (type_leq unfold_ty) args args' + then true, e + else false, None + else begin match unfold_ty t with + | Some t -> type_leq_c unfold_ty e t t' + | None -> (match unfold_ty t' with + | None -> false, None + | Some t' -> type_leq_c unfold_ty e t t') + end + + | MLTY_Tuple ts, MLTY_Tuple ts' -> + if List.forall2 (type_leq unfold_ty) ts ts' + then true, e + else false, None + + | MLTY_Top, MLTY_Top -> true, e + + | MLTY_Named _, _ -> + begin match unfold_ty t with + | Some t -> type_leq_c unfold_ty e t t' + | _ -> false, None + end + + | _, MLTY_Named _ -> + begin match unfold_ty t' with + | Some t' -> type_leq_c unfold_ty e t t' + | _ -> false, None + end + + | MLTY_Erased, MLTY_Erased -> + true, e + + | _ -> false, None + +and type_leq g t1 t2 : bool = type_leq_c g None t1 t2 |> fst + +let rec erase_effect_annotations (t:mlty) = + match t with + | MLTY_Fun(t1, f, t2) -> + MLTY_Fun(erase_effect_annotations t1, E_PURE, erase_effect_annotations t2) + | _ -> t + +let is_type_abstraction = function + | (Inl _, _)::_ -> true + | _ -> false + +let is_xtuple (ns, n) = + if FStarC.Parser.Const.is_tuple_datacon_string (BU.concat_l "." (ns@[n])) + (* Returns the integer k in "Mktuplek" *) + then Some (BU.int_of_char (BU.char_at n 7)) + else None + +let resugar_exp e = match e.expr with + | MLE_CTor(mlp, args) -> + (match is_xtuple mlp with + | Some n -> with_ty e.mlty <| MLE_Tuple args + | _ -> e) + | _ -> e + +let record_field_path = function + | f::_ -> + let ns, _ = BU.prefix (ns_of_lid f) in + ns |> List.map (fun id -> (string_of_id id)) + | _ -> failwith "impos" + +let record_fields fs vs = List.map2 (fun (f:lident) e -> (string_of_id (ident_of_lid f)), e) fs vs +// +//let resugar_pat q p = match p with +// | MLP_CTor(d, pats) -> +// begin match is_xtuple d with +// | Some n -> MLP_Tuple(pats) +// | _ -> +// match q with +// | Some (Record_ctor (_, fns)) -> +// let p = record_field_path fns in +// let fs = record_fields fns pats in +// MLP_Record(p, fs) +// | _ -> p +// end +// | _ -> p + + +let is_xtuple_ty (ns, n) = + if FStarC.Parser.Const.is_tuple_constructor_string (BU.concat_l "." (ns@[n])) + (* Returns the integer k in "tuplek" *) + then Some (BU.int_of_char (BU.char_at n 5)) + else None + +let resugar_mlty t = match t with + | MLTY_Named (args, mlp) -> + begin match is_xtuple_ty mlp with + | Some n -> MLTY_Tuple args + | _ -> t + end + | _ -> t + +let flatten_ns ns = String.concat "_" ns +let flatten_mlpath (ns, n) = String.concat "_" (ns@[n]) +let ml_module_name_of_lid (l:lident) = + let mlp = l |> ns_of_lid |> List.map string_of_id, string_of_id (ident_of_lid l) in + flatten_mlpath mlp + + +let rec erasableType (unfold_ty:unfold_t) (t:mlty) :bool = + let erasableTypeNoDelta (t:mlty) = + if t = ml_unit_ty then true + else match t with + | MLTY_Named (_, (["FStar"; "Ghost"], "erased")) -> true + (* erase tactic terms, unless extracting for tactic compilation *) + | MLTY_Named (_, (["FStar"; "Tactics"; "Effect"], "tactic")) -> Options.codegen () <> Some Options.Plugin + | _ -> false // this function is used by another function which does delta unfolding + in + if erasableTypeNoDelta t + then true + else match unfold_ty t with + | Some t -> erasableType unfold_ty t + | None -> false + +let rec eraseTypeDeep unfold_ty (t:mlty) : mlty = + match t with + | MLTY_Fun (tyd, etag, tycd) -> + if etag=E_PURE + then MLTY_Fun (eraseTypeDeep unfold_ty tyd, etag, eraseTypeDeep unfold_ty tycd) + else t + | MLTY_Named (lty, mlp) -> + if erasableType unfold_ty t + then MLTY_Erased + else MLTY_Named (List.map (eraseTypeDeep unfold_ty) lty, mlp) // only some named constants are erased to unit. + | MLTY_Tuple lty -> MLTY_Tuple (List.map (eraseTypeDeep unfold_ty) lty) + | _ -> t + +let prims_op_equality = with_ty MLTY_Top <| MLE_Name (["Prims"], "op_Equality") +let prims_op_amp_amp = with_ty (mk_ty_fun [{mlbinder_name="x";mlbinder_ty=ml_bool_ty;mlbinder_attrs=[]}; + {mlbinder_name="y";mlbinder_ty=ml_bool_ty;mlbinder_attrs=[]}] ml_bool_ty) <| MLE_Name (["Prims"], "op_AmpAmp") +let conjoin e1 e2 = with_ty ml_bool_ty <| MLE_App(prims_op_amp_amp, [e1;e2]) +let conjoin_opt e1 e2 = match e1, e2 with + | None, None -> None + | Some x, None + | None, Some x -> Some x + | Some x, Some y -> Some (conjoin x y) + +let mlloc_of_range (r: Range.range) = + let pos = Range.start_of_range r in + let line = Range.line_of_pos pos in + line, Range.file_of_range r + +let rec doms_and_cod (t:mlty) : list mlty & mlty = + match t with + | MLTY_Fun (a,_,b) -> + let ds, c = doms_and_cod b in + a::ds, c + | _ -> + [], t + +let argTypes (t: mlty) : list mlty = + fst (doms_and_cod t) + +let rec uncurry_mlty_fun t = + match t with + | MLTY_Fun (a,_,b) -> + let args, res = uncurry_mlty_fun b in + a::args, res + | _ -> [], t + +let list_elements (e:mlexpr) : option (list mlexpr) = + let rec list_elements acc e = + match e.expr with + | MLE_CTor (([ "Prims" ], "Cons" ), [ hd; tl ]) -> + list_elements (hd :: acc) tl + | MLE_CTor (([ "Prims" ], "Nil" ), []) -> + List.rev acc |> Some + | MLE_CTor (([ "Prims" ], "Cons" ), [ hd; tl ]) -> + list_elements (hd :: acc) tl + | MLE_CTor (([ "Prims" ], "Nil" ), []) -> + List.rev acc |> Some + | _ -> None + in + list_elements [] e diff --git a/src/extraction/FStarC.Extraction.ML.Util.fsti b/src/extraction/FStarC.Extraction.ML.Util.fsti new file mode 100644 index 00000000000..f69bbec4da0 --- /dev/null +++ b/src/extraction/FStarC.Extraction.ML.Util.fsti @@ -0,0 +1,66 @@ +(* + Copyright 2008-2015 Abhishek Anand, Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Extraction.ML.Util +open Prims +open FStar +open FStarC +open FStarC.Compiler +open FStar.Pervasives +open FStarC.Ident +open FStarC.Extraction.ML.Syntax +module S = FStarC.Syntax.Syntax +module BU = FStarC.Compiler.Util + +val codegen_fsharp : unit -> bool +val pruneNones : list (option 'a) -> list 'a +val mk_range_mle : mlexpr +val mlconst_of_const : p:Range.range -> c:Const.sconst -> mlconstant +val mlexpr_of_const : p:Range.range -> c:Const.sconst -> mlexpr' +val mlexpr_of_range : r:Range.range -> mlexpr' +val subst : list ty_param & mlty -> args:list mlty -> mlty +val udelta_unfold : g:UEnv.uenv -> _arg1:mlty -> option mlty +val eff_leq : f:e_tag -> f':e_tag -> bool +val eff_to_string : _arg1:e_tag -> string +val join : r:Range.range -> f:e_tag -> f':e_tag -> e_tag +val join_l : r:Range.range -> fs:Prims.list e_tag -> e_tag +val mk_ty_fun : (Prims.list mlbinder -> mlty -> mlty) +type unfold_t = mlty -> option mlty +val type_leq_c : unfold_ty:unfold_t -> e:option mlexpr -> t:mlty -> t':mlty -> bool & option mlexpr +val type_leq : g:unfold_t -> t1:mlty -> t2:mlty -> bool +val erase_effect_annotations: mlty -> mlty +val is_type_abstraction : list (either 'a 'b & 'c) -> bool +val is_xtuple : list string & string -> option int +val is_xtuple_ty : list string & string -> option int +val resugar_exp : e:mlexpr -> mlexpr +val resugar_mlty : t:mlty -> mlty +val record_field_path : list lident -> list string +val record_fields : fs:list lident -> vs:list 'a -> list (string & 'a) + +val flatten_ns : ns:list string -> string +val flatten_mlpath : list string & string -> string +val ml_module_name_of_lid: lident -> string +val erasableType : unfold_ty:unfold_t -> t:mlty -> bool +val eraseTypeDeep : unfold_ty:unfold_t -> t:mlty -> mlty +val prims_op_equality : mlexpr +val prims_op_amp_amp : mlexpr +val conjoin : e1:mlexpr -> e2:mlexpr -> mlexpr +val conjoin_opt : e1:option mlexpr -> e2:option mlexpr -> option mlexpr +val mlloc_of_range : r:Range.range -> int & string +val doms_and_cod : t:mlty -> list mlty & mlty +val argTypes : t:mlty -> list mlty +val uncurry_mlty_fun : t:mlty -> list mlty & mlty + +val list_elements : mlexpr -> option (list mlexpr) diff --git a/src/fstar/FStar.CheckedFiles.fst b/src/fstar/FStar.CheckedFiles.fst deleted file mode 100644 index 8badc128d93..00000000000 --- a/src/fstar/FStar.CheckedFiles.fst +++ /dev/null @@ -1,492 +0,0 @@ -(* - Copyright 2008-2018 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.CheckedFiles -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.Util - -open FStar.Class.Show - -(* Module abbreviations for the universal type-checker *) -module Syntax = FStar.Syntax.Syntax -module TcEnv = FStar.TypeChecker.Env -module SMT = FStar.SMTEncoding.Solver -module BU = FStar.Compiler.Util -module Dep = FStar.Parser.Dep - -let dbg = Debug.get_toggle "CheckedFiles" - -(* - * We write this version number to the cache files, and - * detect when loading the cache that the version number is same - * It needs to be kept in sync with Prims.fst - *) -let cache_version_number = 72 - -(* - * Abbreviation for what we store in the checked files (stages as described below) - *) -type checked_file_entry_stage1 = -{ - //cache version number - version: int; - - //digest of this source file to check if parsing data is valid - digest: string; - - //parsing data for this file - parsing_data: Parser.Dep.parsing_data -} - -type checked_file_entry_stage2 = -{ - //list of (file_name * digest) of direct dependences - //file_name is name of the source file and - //digest is that of the corresponding checked file - //except when the entries are for the current .fst and .fsti, - //digest is that of the source file - deps_dig: list (string & string); - - //typechecking result, including the smt encoding - tc_res: tc_result -} - -(* - * Local cache for checked files contents - * Note that a checked file could have valid parsing data but stale tc data - *) - -(* - * Cache files could be loaded in two steps - * - * Initially the dependence analysis is just interested in the parsing data - * and till that point we don't have the dependences sorted out, because of - * which we can't check the validity of tc data (since we need to check hashes - * of direct dependences etc.) - * - * So in this step, we read the checked file and mark the validity if tc data as Unknown - * - * Later on, we have figured the complete dependence graph, and want to load - * the tc data - * - * At that point, the cache is updated to either Valid or Invalid w.r.t. the tc data - *) -type tc_result_t = - | Unknown - | Invalid of string //reason why this is invalid - | Valid of string //digest of the checked file - -instance _ : showable tc_result_t = { - show = (function Unknown -> "Unknown" - | Invalid s -> "Invalid " ^ show s - | Valid s -> "Valid " ^ show s); -} - -(* - * The cache of checked files - *) -type cache_t = - tc_result_t & //tc data part - - //either: reason why this checked file is not valid for parsing data - //or : parsing_data - either string Dep.parsing_data - -//Internal cache -let mcache : smap cache_t = BU.smap_create 50 - -(* - * Either the reason because of which dependences are stale/invalid - * or the list of dep string, as defined in the checked_file_entry above - *) -let hash_dependences (deps:Dep.deps) (fn:string) :either string (list (string & string)) = - let fn = - match FStar.Find.find_file fn with - | Some fn -> fn - | _ -> fn - in - let module_name = Dep.lowercase_module_name fn in - let source_hash = BU.digest_of_file fn in - let has_interface = Option.isSome (Dep.interface_of deps module_name) in - let interface_checked_file_name = - if Dep.is_implementation fn - && has_interface - then module_name - |> Dep.interface_of deps - |> must - |> Dep.cache_file_name - |> Some - else None - in - let binary_deps = Dep.deps_of deps fn - |> List.filter (fun fn -> - not (Dep.is_interface fn && - Dep.lowercase_module_name fn = module_name)) in - let binary_deps = - FStar.Compiler.List.sortWith - (fun fn1 fn2 -> - String.compare (Dep.lowercase_module_name fn1) - (Dep.lowercase_module_name fn2)) - binary_deps in - - let maybe_add_iface_hash out = - match interface_checked_file_name with - | None -> Inr (("source", source_hash)::out) - | Some iface -> - (match BU.smap_try_find mcache iface with - | None -> - let msg = BU.format1 - "hash_dependences::the interface checked file %s does not exist\n" - iface in - - if !dbg - then BU.print1 "%s\n" msg; - - Inl msg - | Some (Invalid msg, _) -> Inl msg - | Some (Valid h, _) -> Inr (("source", source_hash)::("interface", h)::out) - | Some (Unknown, _) -> - failwith (BU.format1 - "Impossible: unknown entry in the mcache for interface %s\n" - iface)) - in - - let rec hash_deps out = function - | [] -> maybe_add_iface_hash out - | fn::deps -> - let cache_fn = Dep.cache_file_name fn in - (* - * It is crucial to get the digest of fn from mcache, rather than computing it directly - * See #1668 - *) - let digest = - match BU.smap_try_find mcache cache_fn with - | None -> - let msg = BU.format2 "For dependency %s, cache file %s is not loaded" fn cache_fn in - if !dbg - then BU.print1 "%s\n" msg; - Inl msg - | Some (Invalid msg, _) -> Inl msg - | Some (Valid dig, _) -> Inr dig - | Some (Unknown, _) -> - failwith (BU.format2 - "Impossible: unknown entry in the cache for dependence %s of module %s" - fn module_name) - in - match digest with - | Inl msg -> Inl msg - | Inr dig -> - hash_deps ((Dep.lowercase_module_name fn, dig) :: out) deps - in - hash_deps [] binary_deps - -(* - * Load a checked file into mcache - * - * This is loading the parsing data, and tc data as Unknown (unless checked file is invalid) - * - * See above for the two steps of loading the checked files - *) -let load_checked_file (fn:string) (checked_fn:string) :cache_t = - if !dbg then - BU.print1 "Trying to load checked file result %s\n" checked_fn; - let elt = checked_fn |> BU.smap_try_find mcache in - if elt |> is_some then elt |> must //already loaded - else - let add_and_return elt = BU.smap_add mcache checked_fn elt; elt in - if not (BU.file_exists checked_fn) - then let msg = BU.format1 "checked file %s does not exist" checked_fn in - add_and_return (Invalid msg, Inl msg) - else let entry :option checked_file_entry_stage1 = BU.load_value_from_file checked_fn in - match entry with - | None -> - let msg = BU.format1 "checked file %s is corrupt" checked_fn in - add_and_return (Invalid msg, Inl msg) - | Some (x) -> - if x.version <> cache_version_number - then let msg = BU.format1 "checked file %s has incorrect version" checked_fn in - add_and_return (Invalid msg, Inl msg) - else let current_digest = BU.digest_of_file fn in - if x.digest <> current_digest - then begin - if !dbg then - BU.print4 "Checked file %s is stale since incorrect digest of %s, \ - expected: %s, found: %s\n" - checked_fn fn current_digest x.digest; - let msg = BU.format2 "checked file %s is stale (digest mismatch for %s)" checked_fn fn in - add_and_return (Invalid msg, Inl msg) - end - else add_and_return (Unknown, Inr x.parsing_data) - -let load_tc_result (checked_fn:string) : option (list (string & string) & tc_result) = - let entry : option (checked_file_entry_stage1 & checked_file_entry_stage2) = - BU.load_2values_from_file checked_fn - in - match entry with - | Some ((_,s2)) -> Some (s2.deps_dig, s2.tc_res) - | _ -> None - -(* - * Second step for loading checked files, validates the tc data - * Either the reason why tc_result is invalid - * or tc_result - *) -let load_checked_file_with_tc_result - (deps:Dep.deps) - (fn:string) - (checked_fn:string) - : either string tc_result -= - if !dbg then - BU.print1 "Trying to load checked file with tc result %s\n" checked_fn; - - let load_tc_result' (fn:string) :list (string & string) & tc_result = - match load_tc_result fn with - | Some x -> x - | None -> failwith "Impossible! if first phase of loading was unknown, it should have succeeded" - in - - let elt = load_checked_file fn checked_fn in //first step, in case some client calls it directly - match elt with - | Invalid msg, _ -> Inl msg - | Valid _, _ -> checked_fn |> load_tc_result' |> snd |> Inr - | Unknown, parsing_data -> - match hash_dependences deps fn with - | Inl msg -> - let elt = (Invalid msg, parsing_data) in - BU.smap_add mcache checked_fn elt; - Inl msg - | Inr deps_dig' -> - let deps_dig, tc_result = checked_fn |> load_tc_result' in - if deps_dig = deps_dig' - then begin - //mark the tc data of the file as valid - let elt = (Valid (BU.digest_of_file checked_fn), parsing_data) in - BU.smap_add mcache checked_fn elt; - (* - * if there exists an interface for it, mark that too as valid - * this is specially needed for extraction invocations of F* with --cmi flag - * for example, consider a scenario: - * A.fst -> B.fsti -> Prims.fst - * ^ ^ - * | / - * B.fst - * - * when all the checked files are present and F* is invoked with --extract A --cmi - * during parsing, all checked files are loaded with tc data statemachine as Unknown - * since it is cmi (and say B has an inline_for_extraction symbol), the client - * then loads B.fst.checked BUT NOT B.fsti.checked - * this advances the state machine for B.fst, but not for B.fsti - * so when client loads A.fst.checked, B.fsti -- a dependence of A -- is still in Unknown - * following code relies on the invariant that: - * validity of implementaton tc data implies validity of iface tc data - * - * an alternative is to not do this, but in hash_dependences, if some dependence - * is in Unknown state, it could call load_checked_file_with_tc_result - *) - let validate_iface_cache () = - let iface = fn |> Dep.lowercase_module_name |> Dep.interface_of deps in - match iface with - | None -> () - | Some iface -> - try - let iface_checked_fn = iface |> Dep.cache_file_name in - match BU.smap_try_find mcache iface_checked_fn with - | Some (Unknown, parsing_data) -> - BU.smap_add mcache - iface_checked_fn - (Valid (BU.digest_of_file iface_checked_fn), parsing_data) - | _ -> () - with - | _ -> () - in - validate_iface_cache (); - Inr tc_result - end - else begin - if !dbg - then begin - BU.print4 "FAILING to load.\nExpected (%s) hashes:\n%s\n\nGot (%s) hashes:\n\t%s\n" - (BU.string_of_int (List.length deps_dig')) - (FStar.Parser.Dep.print_digest deps_dig') - (BU.string_of_int (List.length deps_dig)) - (FStar.Parser.Dep.print_digest deps_dig); - if List.length deps_dig = List.length deps_dig' - then List.iter2 (fun (x,y) (x', y') -> - if x<>x' || y<>y' - then BU.print2 "Differ at: Expected %s\n Got %s\n" - (FStar.Parser.Dep.print_digest [(x,y)]) - (FStar.Parser.Dep.print_digest [(x',y')])) deps_dig deps_dig' - end; - let msg = - BU.format1 - "checked file %s is stale (dependence hash mismatch, use --debug yes for more details)" - checked_fn - in - let elt = (Invalid msg, Inl msg) in - BU.smap_add mcache checked_fn elt; - Inl msg - end - - -let load_parsing_data_from_cache file_name = - (* - * the code below suppresses the already_cached assertion failure - * following is the reason for it: - * - * consider a scenario: - * A.fst -> B.fsti -> Prims.fst - * ^ ^ - * | / - * B.fst - * - * the dependence analysis marks B.fsti as a dependence of A.fst - * so when we use the makefiles to build this, - * makefile could first build prims, then B.fsti, and then tried to build A.fst - * with: fstar.exe A.fst already_cached '* -A' - * now F* starts to build the dependence graph for A - * it sees that A depends on B, so it reads the parsing data - * of B.fsti from its existing checked file - * however, the dependence analysis ALSO reads B.fst so as to detect cycles - * and calls load_parsing_data_from_cache_file with B.fst - * clearly until this point, B.fst has not been checked and so its checked file doesn't exist - * so cache_file_name raises an exception since B is in the already_cached list - * - * suppressing the exception here is not too bad since this exception is raised at other places - * e.g. when loading the checked file for typechecking purposes - * - * another way to handle this kind of thing would be to NOT load B.fst for cycle detection, - * rather provide a separate F* command --detect_cycles --alredy_cached '*' that builds - * can invoke in the end for cycle detection - *) - Errors.with_ctx ("While loading parsing data from " ^ file_name) (fun () -> - let cache_file = - try - Parser.Dep.cache_file_name file_name |> Some - with _ -> None - in - match cache_file with - | None -> None - | Some cache_file -> - match load_checked_file file_name cache_file with - | _, Inl msg -> None - | _, Inr data -> Some data - ) - -let load_module_from_cache = - //this is only used for supressing more than one cache invalid warnings - let already_failed = BU.mk_ref false in - fun env fn -> Errors.with_ctx ("While loading module from file " ^ fn) (fun () -> - let load_it fn () = - let cache_file = Dep.cache_file_name fn in - let fail msg cache_file = - //Don't feel too bad if fn is the file on the command line - //Also suppress the warning if already given to avoid a deluge - let suppress_warning = Options.should_check_file fn || !already_failed in - if not suppress_warning then begin - already_failed := true; - FStar.Errors.log_issue (Range.mk_range fn (Range.mk_pos 0 0) (Range.mk_pos 0 0)) - Errors.Warning_CachedFile [Errors.text (BU.format3 - "Unable to load %s since %s; will recheck %s (suppressing this warning for further modules)" - cache_file msg fn) - ] - end - in - match load_checked_file_with_tc_result - (TcEnv.dep_graph env) - fn - cache_file with - | Inl msg -> fail msg cache_file; None - | Inr tc_result -> - if !dbg then - BU.print1 "Successfully loaded module from checked file %s\n" cache_file; - Some tc_result - (* | _ -> failwith "load_checked_file_tc_result must have an Invalid or Valid entry" *) - in - - (* - * AR: cf. #1919, A.fst.checked implicitly depends on A.fsti.checked - * and thus, transitively on the dependencies of A.fsti.checked - * the dependency on A.fsti.checked is unusual in the sense that - * tcenv is not populated with its contents - * that happens via interleaving later - * this is just to make sure that we correctly track the dependence of A.fst - * on the dependences of A.fsti - *) - - let load_with_profiling fn = Profiling.profile - (load_it fn) - None - "FStar.CheckedFiles" in - - let i_fn_opt = Dep.interface_of - (TcEnv.dep_graph env) - (Dep.lowercase_module_name fn) in - - if Dep.is_implementation fn - && (i_fn_opt |> is_some) - then let i_fn = i_fn_opt |> must in - let i_tc = load_with_profiling i_fn in - match i_tc with - | None -> None - | Some _ -> load_with_profiling fn - - else load_with_profiling fn - ) - -(* - * Just to make sure data has the right type - *) -let store_values_to_cache - (cache_file:string) - (stage1:checked_file_entry_stage1) - (stage2:checked_file_entry_stage2) - :unit = - Errors.with_ctx ("While writing checked file " ^ cache_file) (fun () -> - BU.save_2values_to_file cache_file stage1 stage2) - -let store_module_to_cache env fn parsing_data tc_result = - if Options.cache_checked_modules() - && not (Options.cache_off()) - then begin - let cache_file = FStar.Parser.Dep.cache_file_name fn in - let digest = hash_dependences (TcEnv.dep_graph env) fn in - match digest with - | Inr hashes -> - let tc_result = { tc_result with tc_time=0; extraction_time=0 } in - - let stage1 = {version=cache_version_number; digest=(BU.digest_of_file fn); parsing_data=parsing_data} in - let stage2 = {deps_dig=hashes; tc_res=tc_result} in - store_values_to_cache cache_file stage1 stage2 - | Inl msg -> - let open FStar.Errors in - let open FStar.Errors.Msg in - let open FStar.Pprint in - log_issue (FStar.Compiler.Range.mk_range fn (FStar.Compiler.Range.mk_pos 0 0) - (FStar.Compiler.Range.mk_pos 0 0)) - Errors.Warning_FileNotWritten [ - text <| BU.format1 "Checked file %s was not written." cache_file; - prefix 2 1 (doc_of_string "Reason:") (text msg) - ] - end - -let unsafe_raw_load_checked_file (checked_fn:string) - = let entry : option (checked_file_entry_stage1 & checked_file_entry_stage2) = BU.load_2values_from_file checked_fn in - match entry with - | Some ((s1,s2)) -> Some (s1.parsing_data, List.map fst s2.deps_dig, s2.tc_res) - | _ -> None diff --git a/src/fstar/FStar.CheckedFiles.fsti b/src/fstar/FStar.CheckedFiles.fsti deleted file mode 100644 index cecd4fa3344..00000000000 --- a/src/fstar/FStar.CheckedFiles.fsti +++ /dev/null @@ -1,70 +0,0 @@ -(* - Copyright 2008-2018 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.CheckedFiles -open FStar.Compiler.Effect -open FStar -open FStar.Compiler -open FStar.Compiler.Util -open FStar.TypeChecker.Env -open FStar.Syntax - -module Syntax = FStar.Syntax.Syntax -module Dep = FStar.Parser.Dep -module TcEnv = FStar.TypeChecker.Env - -val cache_version_number : int - -(* - * This is what is returned when clients read a module from the caches - *) -type tc_result = { - checked_module: Syntax.modul; //persisted - mii:DsEnv.module_inclusion_info; //persisted - smt_decls:(FStar.SMTEncoding.Term.decls_t & //list of smt decls and fvbs for the module - list FStar.SMTEncoding.Env.fvar_binding); //persisted - - tc_time:int; - extraction_time:int -} - -val load_tc_result (checked_fn:string) : option (list (string & string) & tc_result) - -val load_checked_file_with_tc_result - (deps:Dep.deps) - (fn:string) - (checked_fn:string) - : either string tc_result - -(* - * Read parsing data from the checked file - * This function is passed as a callback to Parser.Dep - * - * Input is the file name, not the cache file name - * The function computes the cache file name itself - *) -val load_parsing_data_from_cache: file_name:string -> option Parser.Dep.parsing_data - -(***********************************************************************) -(* Loading and storing cache files *) -(***********************************************************************) - -val load_module_from_cache: TcEnv.env -> string -> option tc_result - -val store_module_to_cache: TcEnv.env -> file_name:string -> Dep.parsing_data -> tc_result -> unit - -val unsafe_raw_load_checked_file (checked_file_name:string) - : option (FStar.Parser.Dep.parsing_data & list string & tc_result) diff --git a/src/fstar/FStar.Dependencies.fst b/src/fstar/FStar.Dependencies.fst deleted file mode 100644 index bf13707644a..00000000000 --- a/src/fstar/FStar.Dependencies.fst +++ /dev/null @@ -1,44 +0,0 @@ -(* - Copyright 2008-2016 Jonathan Protzenko, Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -// A dependency-finding routine -module FStar.Dependencies -open FStar.Compiler.Effect -open FStar -open FStar.Compiler -open FStar.Compiler.Util -open FStar.Getopt -open FStar.Ident - -(***********************************************************************) -(* Finding the transitive dependencies of a list of files *) -(***********************************************************************) - -(* - * get_parsing_data_from_cache is a callback passed to Parser.Dep for - * getting deps from the checked files - *) -let find_deps_if_needed files - (get_parsing_data_from_cache:string -> option Parser.Dep.parsing_data) - = let all_files, deps = Parser.Dep.collect files get_parsing_data_from_cache in - match all_files with - | [] -> - Errors.log_issue0 Errors.Error_DependencyAnalysisFailed "Dependency analysis failed; reverting to using only the files provided"; - files, - deps - | _ -> - List.rev all_files, - deps diff --git a/src/fstar/FStar.Interactive.CompletionTable.fst b/src/fstar/FStar.Interactive.CompletionTable.fst deleted file mode 100644 index ecb5add273f..00000000000 --- a/src/fstar/FStar.Interactive.CompletionTable.fst +++ /dev/null @@ -1,486 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Interactive.CompletionTable - -open FStar open FStar.Compiler -open FStar.Compiler.Effect - -let string_compare s1 s2 = - String.compare s1 s2 - -(** * (Pairing) min-heaps * **) - -type heap 'a = -| EmptyHeap -| Heap of 'a & list (heap 'a) - -let heap_merge cmp h1 h2 = - match h1, h2 with - | EmptyHeap, h - | h, EmptyHeap -> h - | Heap (v1, hh1), Heap (v2, hh2) -> - if cmp v1 v2 < 0 then Heap (v1, h2 :: hh1) else Heap (v2, h1 :: hh2) - -let heap_insert cmp h v = - heap_merge cmp (Heap (v, [])) h - -let rec heap_merge_pairs cmp = function - | [] -> EmptyHeap - | [h] -> h - | h1 :: h2 :: hh -> - heap_merge cmp (heap_merge cmp h1 h2) (heap_merge_pairs cmp hh) - -let heap_peek = function - | EmptyHeap -> None - | Heap (v, _) -> Some v - -let heap_pop cmp = function - | EmptyHeap -> None - | Heap (v, hh) -> Some (v, heap_merge_pairs cmp hh) - -let heap_from_list cmp values = - List.fold_left (heap_insert cmp) EmptyHeap values - -(** * List functions * **) - -let push_nodup key_fn x = function - | [] -> [x] - | h :: t -> if string_compare (key_fn x) (key_fn h) = 0 then h :: t else x :: h :: t - -let rec add_priorities n acc = function - | [] -> acc - | h :: t -> add_priorities (n + 1) ((n, h) :: acc) t - -(** Merge ‘lists’, a list of increasing (according to ‘key_fn’) lists. - Keeps a single copy of each key that appears in more than one list (earlier - lists take precedence when chosing which value to keep). *) -let merge_increasing_lists_rev (key_fn: 'a -> string) (lists: list (list 'a)) = - let cmp v1 v2 = - match v1, v2 with - | (_, []), _ | _, (_, []) -> failwith "impossible" - | (pr1, h1 :: _), (pr2, h2 :: _) -> - let cmp_h = string_compare (key_fn h1) (key_fn h2) in - if cmp_h <> 0 then cmp_h else pr1 - pr2 in - let rec aux (lists: heap (int & list 'a)) (acc: list 'a) = - match heap_pop cmp lists with - | None -> acc - | Some ((pr, []), _) -> failwith "impossible" - | Some ((pr, [v]), lists) -> aux lists (push_nodup key_fn v acc) - | Some ((pr, v :: tl), lists) -> aux (heap_insert cmp lists (pr, tl)) (push_nodup key_fn v acc) in - let lists = List.filter (fun x -> x <> []) lists in - match lists with - | [] -> [] | [l] -> List.rev l - | _ -> - let lists = add_priorities 0 [] lists in - aux (heap_from_list cmp lists) [] - -(** * Binary trees * **) - -type btree 'a = -| StrEmpty -| StrBranch of string & 'a & (btree 'a) & (btree 'a) -(* (key: string) * (value: 'a) * (lbt: btree 'a) * (rbt: btree 'a) *) - -let rec btree_to_list_rev (btree:btree 'a) (acc:list (string & 'a)) - : list (string & 'a) = - match btree with - | StrEmpty -> acc - | StrBranch (key, value, lbt, rbt) -> - btree_to_list_rev rbt ((key, value) :: btree_to_list_rev lbt acc) - -let rec btree_from_list (nodes:list (string & 'a)) (size:int) - : btree 'a & list (string & 'a) = - if size = 0 then (StrEmpty, nodes) - else - let lbt_size = size / 2 in - let rbt_size = size - lbt_size - 1 in - let lbt, nodes_left = btree_from_list nodes lbt_size in - match nodes_left with - | [] -> failwith "Invalid size passed to btree_from_list" - | (k, v) :: nodes_left -> - let rbt, nodes_left = btree_from_list nodes_left rbt_size in - StrBranch (k, v, lbt, rbt), nodes_left - -let rec btree_insert_replace (bt: btree 'a) (k: string) (v: 'a) : btree 'a = - match bt with - | StrEmpty -> StrBranch (k, v, StrEmpty, StrEmpty) - | StrBranch (k', v', lbt, rbt) -> - let cmp = string_compare k k' in - if cmp < 0 then - StrBranch (k', v', btree_insert_replace lbt k v, rbt) - else if cmp > 0 then - StrBranch (k', v', lbt, btree_insert_replace rbt k v) - else - StrBranch (k', v, lbt, rbt) - -let rec btree_find_exact (bt: btree 'a) (k: string) : option 'a = - match bt with - | StrEmpty -> None - | StrBranch (k', v, lbt, rbt) -> - let cmp = string_compare k k' in - if cmp < 0 then - btree_find_exact lbt k - else if cmp > 0 then - btree_find_exact rbt k - else - Some v - -let rec btree_extract_min (bt: btree 'a) : option (string & 'a & btree 'a) = - match bt with - | StrEmpty -> None - | StrBranch (k, v, StrEmpty, rbt) -> Some (k, v, rbt) - | StrBranch (_, _, lbt, _) -> btree_extract_min lbt - -let rec btree_remove (bt: btree 'a) (k: string) : btree 'a = - match bt with - | StrEmpty -> StrEmpty - | StrBranch (k', v, lbt, rbt) -> - let cmp = string_compare k k' in - if cmp < 0 then - StrBranch (k', v, btree_remove lbt k, rbt) - else if cmp > 0 then - StrBranch (k', v, lbt, btree_remove rbt k) - else - match lbt with - | StrEmpty -> bt - | _ -> match btree_extract_min rbt with - | None -> lbt - | Some (rbt_min_k, rbt_min_v, rbt') -> - StrBranch (rbt_min_k, rbt_min_v, lbt, rbt') - -type prefix_match = - { prefix: option string; - completion: string } - -type path_elem = - { imports: list string; - segment: prefix_match } - -let matched_prefix_of_path_elem (elem: path_elem) = elem.segment.prefix - -let mk_path_el imports segment = { imports = imports; segment = segment } - -let btree_find_prefix (bt: btree 'a) (prefix: string) - : list (prefix_match & 'a) (* ↑ keys *) = - let rec aux (bt: btree 'a) (prefix: string) (acc: list (prefix_match & 'a)) : list (prefix_match & 'a) = - match bt with - | StrEmpty -> acc - | StrBranch (k, v, lbt, rbt) -> - let cmp = string_compare k prefix in - let include_middle = Util.starts_with k prefix in - let explore_right = cmp <= 0 || include_middle in - let explore_left = cmp > 0 in - let matches = - if explore_right then aux rbt prefix acc else acc in - let matches = - if include_middle then - ({ prefix = Some prefix; completion = k }, v) :: matches - else - matches in - let matches = - if explore_left then aux lbt prefix matches else matches in - matches in - aux bt prefix [] - -let rec btree_fold (bt: btree 'a) (f: string -> 'a -> 'b -> 'b) (acc: 'b) = - match bt with - | StrEmpty -> acc - | StrBranch (k, v, lbt, rbt) -> - btree_fold lbt f (f k v (btree_fold rbt f acc)) - -(** * Tries * **) - - -let query_to_string q = String.concat "." q - -type name_collection 'a = -| Names of btree 'a -| ImportedNames of string & names 'a -and names 'a = list (name_collection 'a) - -type trie (a:Type0) = - { bindings: names a; - namespaces: names (trie a) } - -let trie_empty = { bindings = []; namespaces = [] } - -let rec names_find_exact (names: names 'a) (ns: string) : option 'a = - let result, names = - match names with - | [] -> None, None - | Names bt :: names -> - btree_find_exact bt ns, Some names - | ImportedNames (_, names) :: more_names -> - names_find_exact names ns, Some more_names in - match result, names with - | None, Some scopes -> names_find_exact scopes ns - | _ -> result - -let rec trie_descend_exact (tr: trie 'a) (query: query) : option (trie 'a) = - match query with - | [] -> Some tr - | ns :: query -> - Util.bind_opt (names_find_exact tr.namespaces ns) - (fun scope -> trie_descend_exact scope query) - -let rec trie_find_exact (tr: trie 'a) (query: query) : option 'a = - match query with - | [] -> failwith "Empty query in trie_find_exact" - | [name] -> names_find_exact tr.bindings name - | ns :: query -> - Util.bind_opt (names_find_exact tr.namespaces ns) - (fun scope -> trie_find_exact scope query) - -let names_insert (name_collections: names 'a) (id: string) (v: 'a) : names 'a = - let bt, name_collections = - match name_collections with - | Names bt :: tl -> (bt, tl) - | _ -> (StrEmpty, name_collections) in - Names (btree_insert_replace bt id v) :: name_collections - -let rec namespaces_mutate (namespaces: names (trie 'a)) (ns: string) (q: query) - (rev_acc: query) - (mut_node: trie 'a -> string -> query -> query -> names (trie 'a) -> trie 'a) - (mut_leaf: trie 'a -> query -> trie 'a)= - let trie = Util.dflt trie_empty (names_find_exact namespaces ns) in - names_insert namespaces ns (trie_mutate trie q rev_acc mut_node mut_leaf) - -and trie_mutate (tr: trie 'a) (q: query) (rev_acc: query) - (mut_node: trie 'a -> string -> query -> query -> names (trie 'a) -> trie 'a) - (mut_leaf: trie 'a -> query -> trie 'a) : trie 'a = - match q with - | [] -> - mut_leaf tr rev_acc - | id :: q -> - let ns' = namespaces_mutate tr.namespaces id q (id :: rev_acc) mut_node mut_leaf in - mut_node tr id q rev_acc ns' - -let trie_mutate_leaf (tr: trie 'a) (query: query) = - trie_mutate tr query [] (fun tr _ _ _ namespaces -> { tr with namespaces = namespaces }) - -let trie_insert (tr: trie 'a) (ns_query: query) (id: string) (v: 'a) : trie 'a = - trie_mutate_leaf tr ns_query (fun tr _ -> { tr with bindings = names_insert tr.bindings id v }) - -let trie_import (tr: trie 'a) (host_query: query) (included_query: query) - (mutator: trie 'a -> trie 'a -> string -> trie 'a) = - let label = query_to_string included_query in - let included_trie = Util.dflt trie_empty (trie_descend_exact tr included_query) in - trie_mutate_leaf tr host_query (fun tr _ -> mutator tr included_trie label) - -let trie_include (tr: trie 'a) (host_query: query) (included_query: query) - : trie 'a = - trie_import tr host_query included_query (fun tr inc label -> - { tr with bindings = ImportedNames (label, inc.bindings) :: tr.bindings }) - -let trie_open_namespace (tr: trie 'a) (host_query: query) (included_query: query) - : trie 'a = - trie_import tr host_query included_query (fun tr inc label -> - { tr with namespaces = ImportedNames (label, inc.namespaces) :: tr.namespaces }) - -let trie_add_alias (tr: trie 'a) (key: string) - (host_query: query) (included_query: query) : trie 'a = - trie_import tr host_query included_query (fun tr inc label -> - // Very similar to an include, but aliasing A.B as M in A.C entirely - // overrides A.B.M, should that also exists. Doing this makes sense - // because we only process aliases in the current module. - trie_mutate_leaf tr [key] (fun _ignored_overwritten_trie _ -> - { bindings = [ImportedNames (label, inc.bindings)]; namespaces = [] })) - -let names_revmap (fn: btree 'a -> 'b) (name_collections: names 'a (* ↓ priority *)) - : list (list string (* imports *) & 'b) (* ↑ priority *) = - let rec aux (acc: list (list string & 'b)) - (imports: list string) (name_collections: names 'a) - : list (list string & 'b) (* #1158 *) = - List.fold_left (fun acc -> function - | Names bt -> (imports, fn bt) :: acc - | ImportedNames (nm, name_collections) -> - aux acc (nm :: imports) name_collections) - acc name_collections in - aux [] [] name_collections - -let btree_find_all (prefix: option string) (bt: btree 'a) - : list (prefix_match & 'a) (* ↑ keys *) = - btree_fold bt (fun k tr acc -> - ({ prefix = prefix; completion = k }, tr) :: acc) [] - -type name_search_term = -| NSTAll -| NSTNone -| NSTPrefix of string - -let names_find_rev (names: names 'a) (id: name_search_term) : list (path_elem & 'a) = - let matching_values_per_collection_with_imports = - match id with - | NSTNone -> [] - | NSTAll -> names_revmap (btree_find_all None) names - | NSTPrefix "" -> names_revmap (btree_find_all (Some "")) names - | NSTPrefix id -> names_revmap (fun bt -> btree_find_prefix bt id) names in - let matching_values_per_collection = - List.map (fun (imports, matches) -> - List.map (fun (segment, v) -> mk_path_el imports segment, v) matches) - matching_values_per_collection_with_imports in - merge_increasing_lists_rev - (fun (path_el, _) -> path_el.segment.completion) matching_values_per_collection - -let rec trie_find_prefix' (tr: trie 'a) (path_acc: path) - (query: query) (acc: list (path & 'a)) - : list (path & 'a) = - let ns_search_term, bindings_search_term, query = - match query with - | [] -> NSTAll, NSTAll, [] - | [id] -> NSTPrefix id, NSTPrefix id, [] - | ns :: query -> NSTPrefix ns, NSTNone, query in - - let matching_namespaces_rev = names_find_rev tr.namespaces ns_search_term in - let acc_with_recursive_bindings = - List.fold_left (fun acc (path_el, trie) -> - trie_find_prefix' trie (path_el :: path_acc) query acc) - acc matching_namespaces_rev in - - let matching_bindings_rev = names_find_rev tr.bindings bindings_search_term in - List.rev_map_onto (fun (path_el, v) -> (List.rev (path_el :: path_acc), v)) - matching_bindings_rev acc_with_recursive_bindings - -let trie_find_prefix (tr: trie 'a) (query: query) : list (path & 'a) = - trie_find_prefix' tr [] query [] - -(** * High level interface * **) - -let mod_name md = md.mod_name - -type symbol = -| ModOrNs of mod_symbol -| Lid of lid_symbol - -type table = - { tbl_lids: trie lid_symbol; - tbl_mods: trie mod_symbol } - -let empty : table = - { tbl_lids = trie_empty; - tbl_mods = trie_empty } - -// Note that we never add aliases to tbl_mods: we use tbl_mods only for -// completion of opens and includes, and these take full module paths. -// Inclusions handling would have to be reinstated should we wish to also -// complete partial names of unloaded (e.g. [open FStar // let x = List._] when -// FStar.Compiler.List isn't loaded). - -let insert (tbl: table) (host_query: query) (id: string) (c: lid_symbol) : table = - { tbl with tbl_lids = trie_insert tbl.tbl_lids host_query id c } - -let register_alias (tbl: table) (key: string) (host_query: query) (included_query: query) : table = - { tbl with tbl_lids = trie_add_alias tbl.tbl_lids key host_query included_query } - -let register_include (tbl: table) (host_query: query) (included_query: query) : table = - { tbl with tbl_lids = trie_include tbl.tbl_lids host_query included_query } - -let register_open (tbl: table) (is_module: bool) (host_query: query) (included_query: query) : table = - if is_module then - // We only process module opens for the current module, where they are just like includes - register_include tbl host_query included_query - else - { tbl with tbl_lids = trie_open_namespace tbl.tbl_lids host_query included_query } - -let register_module_path (tbl: table) (loaded: bool) (path: string) (mod_query: query) = - let ins_ns id bindings full_name loaded = - match names_find_exact bindings id, loaded with - | None, _ // Never seen before - | Some (Namespace { ns_loaded = false }), true -> // Seen, but not loaded yet - names_insert bindings id - (Namespace ({ ns_name = full_name; ns_loaded = loaded })) - | Some _, _ -> // Already seen as a loaded namespace, or as a module - bindings in - let ins_mod id bindings full_name loaded = - names_insert bindings id - (Module ({ mod_name = full_name; mod_loaded = loaded; mod_path = path })) in - let name_of_revq query = - String.concat "." (List.rev query) in - let ins id q revq bindings loaded = - let name = name_of_revq (id :: revq) in - match q with - | [] -> ins_mod id bindings name loaded - | _ -> ins_ns id bindings name loaded in - { tbl with tbl_mods = - trie_mutate tbl.tbl_mods mod_query [] (fun tr id q revq namespaces -> - { tr with namespaces = namespaces; - bindings = ins id q revq tr.bindings loaded }) - (fun tr _ -> tr) } - -let string_of_path (path: path) : string = - String.concat "." (List.map (fun el -> el.segment.completion) path) - -let match_length_of_path (path: path) : int = - let length, (last_prefix, last_completion_length) = - List.fold_left - (fun acc elem -> - let (acc_len, _) = acc in - match elem.segment.prefix with - | Some prefix -> - let completion_len = String.length elem.segment.completion in - (acc_len + 1 (* ‘.’ *) + completion_len, (prefix, completion_len)) - | None -> acc) - (0, ("", 0)) path in - length - - 1 (* extra ‘.’ *) - - last_completion_length - + (String.length last_prefix) (* match stops after last prefix *) - -let first_import_of_path (path: path) : option string = - match path with - | [] -> None - | { imports = imports } :: _ -> List.last_opt imports - -let alist_of_ns_info ns_info = - [("name", Json.JsonStr ns_info.ns_name); - ("loaded", Json.JsonBool ns_info.ns_loaded)] - -let alist_of_mod_info mod_info = - [("name", Json.JsonStr mod_info.mod_name); - ("path", Json.JsonStr mod_info.mod_path); - ("loaded", Json.JsonBool mod_info.mod_loaded)] - -let json_of_completion_result (result: completion_result) = - Json.JsonList [Json.JsonInt result.completion_match_length; - Json.JsonStr result.completion_annotation; - Json.JsonStr result.completion_candidate] - -let completion_result_of_lid (path, _lid) = - { completion_match_length = match_length_of_path path; - completion_candidate = string_of_path path; - completion_annotation = Util.dflt "" (first_import_of_path path) } - -let completion_result_of_mod annot loaded path = - { completion_match_length = match_length_of_path path; - completion_candidate = string_of_path path; - completion_annotation = Util.format1 (if loaded then " %s " else "(%s)") annot } - -let completion_result_of_ns_or_mod (path, symb) = - match symb with - | Module { mod_loaded = loaded } -> completion_result_of_mod "mod" loaded path - | Namespace { ns_loaded = loaded } -> completion_result_of_mod "ns" loaded path - -let find_module_or_ns (tbl:table) (query:query) = - trie_find_exact tbl.tbl_mods query - -let autocomplete_lid (tbl: table) (query: query) = - List.map completion_result_of_lid (trie_find_prefix tbl.tbl_lids query) - -let autocomplete_mod_or_ns (tbl: table) (query: query) (filter: (path & mod_symbol) -> option (path & mod_symbol)) = - trie_find_prefix tbl.tbl_mods query - |> List.filter_map filter - |> List.map completion_result_of_ns_or_mod diff --git a/src/fstar/FStar.Interactive.CompletionTable.fsti b/src/fstar/FStar.Interactive.CompletionTable.fsti deleted file mode 100644 index 60d7f26ff93..00000000000 --- a/src/fstar/FStar.Interactive.CompletionTable.fsti +++ /dev/null @@ -1,63 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Interactive.CompletionTable - -val path_elem : Type0 -type path = list path_elem -val matched_prefix_of_path_elem : path_elem -> option string - -type query = list string - -type ns_info = { ns_name: string; - ns_loaded: bool } -type mod_info = { mod_name: string; - mod_path: string; - mod_loaded: bool } - -val mod_name : mod_info -> string // F# doesn't like md.CompletionTable.mod_name - -type mod_symbol = -| Module of mod_info -| Namespace of ns_info - -type lid_symbol = FStar.Ident.lid - -val trie (a:Type0) : Type0 - -val table : Type0 - -val empty : table -val insert : tbl:table -> host_query:query -> id:string -> c:lid_symbol -> table -val register_alias : tbl:table -> key:string -> host_query:query -> included_query:query -> table -val register_open : tbl:table -> is_module:bool -> host_query:query -> included_query:query -> table -val register_include : tbl:table -> host_query:query -> included_query:query -> table -val register_module_path : tbl:table -> loaded:bool -> mod_path:string -> mod_query:query -> table - -val alist_of_ns_info : ns_info -> list (string & FStar.Json.json) -val alist_of_mod_info : mod_info -> list (string & FStar.Json.json) - -type completion_result = - { completion_match_length: int; - completion_candidate: string; - completion_annotation: string } -val json_of_completion_result : completion_result -> FStar.Json.json - -val find_module_or_ns : - tbl:table -> query:query -> option mod_symbol -val autocomplete_lid : - tbl:table -> query:query -> list completion_result -val autocomplete_mod_or_ns : - tbl:table -> query:query -> filter:((path & mod_symbol) -> option (path & mod_symbol)) -> list completion_result diff --git a/src/fstar/FStar.Interactive.Ide.Types.fst b/src/fstar/FStar.Interactive.Ide.Types.fst deleted file mode 100644 index 578d0443fd8..00000000000 --- a/src/fstar/FStar.Interactive.Ide.Types.fst +++ /dev/null @@ -1,367 +0,0 @@ -(* - Copyright 2008-2016 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Interactive.Ide.Types -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.Compiler.Range -open FStar.Compiler.Util -open FStar.Getopt -open FStar.Ident -open FStar.Errors -open FStar.Interactive.JsonHelper - -open FStar.Universal -open FStar.TypeChecker.Env -open FStar.TypeChecker.Common -open FStar.Interactive -open FStar.Parser.ParseIt -open FStar.Class.Show - -module SS = FStar.Syntax.Syntax -module DsEnv = FStar.Syntax.DsEnv -module TcErr = FStar.TypeChecker.Err -module TcEnv = FStar.TypeChecker.Env -module CTable = FStar.Interactive.CompletionTable -module PI = FStar.Parser.ParseIt -module U = FStar.Compiler.Util - -(* Importing this module bring FStar.Json into scope. *) -include FStar.Json - -(***********************) -(* Global state setup *) -(***********************) -let initial_range = - Range.mk_range "" (Range.mk_pos 1 0) (Range.mk_pos 1 0) - - - -type completion_context = -| CKCode -| CKOption of bool (* #set-options (false) or #reset-options (true) *) -| CKModuleOrNamespace of bool (* modules *) & bool (* namespaces *) - -type lookup_context = -| LKSymbolOnly -| LKModule -| LKOption -| LKCode - -type position = string & int & int - -type push_kind = | SyntaxCheck | LaxCheck | FullCheck - -type push_query = - { - push_kind: push_kind; - push_line: int; - push_column: int; - push_peek_only: bool; - //Either a string: Just the raw content of a document fragment - //Or a parsed document fragment and the raw content it corresponds to - push_code_or_decl: either string (FStar.Parser.AST.decl & PI.code_fragment) - } - -type lookup_symbol_range = json - -type query_status = | QueryOK | QueryNOK | QueryViolatesProtocol - -(* Types concerning repl *) -type repl_depth_t = TcEnv.tcenv_depth_t & int -type optmod_t = option Syntax.Syntax.modul - -type timed_fname = - { tf_fname: string; - tf_modtime: time } - -(** Every snapshot pushed in the repl stack is annotated with one of these. The -``LD``-prefixed (“Load Dependency”) onces are useful when loading or updating -dependencies, as they carry enough information to determine whether a dependency -is stale. **) -type repl_task = - | LDInterleaved of timed_fname & timed_fname (* (interface * implementation) *) - | LDSingle of timed_fname (* interface or implementation *) - | LDInterfaceOfCurrentFile of timed_fname (* interface *) - | PushFragment of either PI.input_frag FStar.Parser.AST.decl (* code fragment *) - & push_kind (* FullCheck, LaxCheck, SyntaxCheck *) - & list json (* any warnings that were raised while checking this fragment *) - | Noop (* Used by compute, PushPartialCheckedFile *) - -type full_buffer_request_kind = - | Full : full_buffer_request_kind - | Lax : full_buffer_request_kind - | Cache : full_buffer_request_kind - | ReloadDeps : full_buffer_request_kind - | VerifyToPosition of position - | LaxToPosition of position - -type query' = -| Exit -| DescribeProtocol -| DescribeRepl -| Segment of string (* File contents *) -| Pop -| Push of push_query -| PushPartialCheckedFile of string (* long declaration name *) -| VfsAdd of option string (* fname *) & string (* contents *) -| AutoComplete of string & completion_context -| Lookup of string & lookup_context & option position & list string & option lookup_symbol_range -| Compute of string & option (list FStar.TypeChecker.Env.step) -| Search of string -| GenericError of string -| ProtocolViolation of string -// FullBuffer: To check the full contents of a document. -// FStar.Interactive.Incremental parses it into chunks and turns this into several Push queries -| FullBuffer of string & full_buffer_request_kind & bool //bool is with_symbol -// Callback: This is an internal query, it cannot be raised by a client. -// It is useful to inject operations into the query stream. -// e.g., Incremental uses it print progress messages to the client in between -// processing a stream of Pushes that result from a chunking a FullBuffer -| Callback of callback_t -// Format: pretty-print the F* code in the selection -| Format of string -| RestartSolver -// Cancel: Cancel any remaining pushes that are at or beyond the provided position. -// Cancel all requests if the position is None -| Cancel of option position -and query = { qq: query'; qid: string } -and callback_t = repl_state -> (query_status & list json) & either repl_state int -and repl_state = { - repl_line: int; - repl_column: int; - repl_fname: string; - repl_deps_stack: repl_stack_t; - repl_curmod: optmod_t; - repl_env: TcEnv.env; - repl_stdin: stream_reader; - repl_names: CTable.table; - repl_buffered_input_queries: list query; - repl_lang:FStar.Universal.lang_decls_t; -} -and repl_stack_t = list repl_stack_entry_t -and repl_stack_entry_t = repl_depth_t & (repl_task & repl_state) - -// Global repl_state, keeping state of different buffers -type grepl_state = { grepl_repls: U.psmap repl_state; grepl_stdin: stream_reader } - - -(*************************) -(* REPL tasks and states *) -(*************************) - -let t0 = Util.now () - -(** Create a timed_fname with a dummy modtime **) -let dummy_tf_of_fname fname = - { tf_fname = fname; - tf_modtime = t0 } - -let string_of_timed_fname { tf_fname = fname; tf_modtime = modtime } = - if modtime = t0 then Util.format1 "{ %s }" fname - else Util.format2 "{ %s; %s }" fname (string_of_time modtime) - -let string_of_repl_task = function - | LDInterleaved (intf, impl) -> - Util.format2 "LDInterleaved (%s, %s)" (string_of_timed_fname intf) (string_of_timed_fname impl) - | LDSingle intf_or_impl -> - Util.format1 "LDSingle %s" (string_of_timed_fname intf_or_impl) - | LDInterfaceOfCurrentFile intf -> - Util.format1 "LDInterfaceOfCurrentFile %s" (string_of_timed_fname intf) - | PushFragment (Inl frag, _, _) -> - Util.format1 "PushFragment { code = %s }" frag.frag_text - | PushFragment (Inr d, _, _) -> - Util.format1 "PushFragment { decl = %s }" (show d) - | Noop -> "Noop {}" - -module BU = FStar.Compiler.Util - -let string_of_repl_stack_entry - : repl_stack_entry_t -> string - = fun ((depth, i), (task, state)) -> - BU.format "{depth=%s; task=%s}" - [string_of_int i; - string_of_repl_task task] - - -let string_of_repl_stack s = - String.concat ";\n\t\t" - (List.map string_of_repl_stack_entry s) - -let repl_state_to_string (r:repl_state) - : string - = BU.format - "{\n\t\ - repl_line=%s;\n\t\ - repl_column=%s;\n\t\ - repl_fname=%s;\n\t\ - repl_cur_mod=%s;\n\t\ - repl_deps_stack={%s}\n\ - }" - [string_of_int r.repl_line; - string_of_int r.repl_column; - r.repl_fname; - (match r.repl_curmod with - | None -> "None" - | Some m -> Ident.string_of_lid m.name); - string_of_repl_stack r.repl_deps_stack] - - -let push_query_to_string pq = - let pk = - match pq.push_kind with - | SyntaxCheck -> "SyntaxCheck" - | LaxCheck -> "LaxCheck" - | FullCheck -> "FullCheck" - in - let code_or_decl = - match pq.push_code_or_decl with - | Inl code -> code - | Inr (_decl, code) -> code.code - in - FStar.Compiler.Util.format "{ push_kind = %s; push_line = %s; \ - push_column = %s; push_peek_only = %s; push_code_or_decl = %s }" - [pk; string_of_int pq.push_line; - string_of_int pq.push_column; - string_of_bool pq.push_peek_only; - code_or_decl] - -let query_to_string q = match q.qq with -| Exit -> "Exit" -| DescribeProtocol -> "DescribeProtocol" -| DescribeRepl -> "DescribeRepl" -| Segment _ -> "Segment" -| Pop -> "Pop" -| Push pq -> "(Push " ^ push_query_to_string pq ^ ")" -| PushPartialCheckedFile d -> "(PushPartialCheckedFile " ^ d ^ ")" -| VfsAdd _ -> "VfsAdd" -| AutoComplete _ -> "AutoComplete" -| Lookup(s, _lc, pos, features, _sr) -> - BU.format3 "(Lookup %s %s [%s])" - s (match pos with - | None -> "None" - | Some (f, i, j) -> - BU.format3 "(%s, %s, %s)" - f (string_of_int i) (string_of_int j)) - (String.concat "; " features) -| Compute _ -> "Compute" -| Search _ -> "Search" -| GenericError _ -> "GenericError" -| ProtocolViolation _ -> "ProtocolViolation" -| FullBuffer _ -> "FullBuffer" -| Callback _ -> "Callback" -| Format _ -> "Format" -| RestartSolver -> "RestartSolver" -| Cancel _ -> "Cancel" - -let query_needs_current_module = function - | Exit | DescribeProtocol | DescribeRepl | Segment _ - | Pop | Push { push_peek_only = false } | VfsAdd _ - | GenericError _ | ProtocolViolation _ - | PushPartialCheckedFile _ - | FullBuffer _ | Callback _ | Format _ | RestartSolver | Cancel _ -> false - | Push _ | AutoComplete _ | Lookup _ | Compute _ | Search _ -> true - -let interactive_protocol_vernum = 2 - -let interactive_protocol_features = - ["autocomplete"; "autocomplete/context"; - "compute"; "compute/reify"; "compute/pure-subterms"; - "describe-protocol"; "describe-repl"; "exit"; - "lookup"; "lookup/context"; "lookup/documentation"; "lookup/definition"; - "peek"; "pop"; "push"; "push-partial-checked-file"; "search"; "segment"; - "vfs-add"; "tactic-ranges"; "interrupt"; "progress"; - "full-buffer"; "format"; "restart-solver"; "cancel"] - -let json_of_issue_level i = - JsonStr (match i with - | ENotImplemented -> "not-implemented" - | EInfo -> "info" - | EWarning -> "warning" - | EError -> "error") - -let json_of_issue issue = - JsonAssoc <| - [("level", json_of_issue_level issue.issue_level)] - @(match issue.issue_number with - | None -> [] - | Some n -> [("number", JsonInt n)]) - @[("message", JsonStr (format_issue' false issue)); - ("ranges", JsonList - ((match issue.issue_range with - | None -> [] - | Some r -> [json_of_use_range r]) @ - (match issue.issue_range with - | Some r when def_range r <> use_range r -> - [json_of_def_range r] - | _ -> [])))] - -(*****************************************) -(* Reading queries and writing responses *) -(*****************************************) - -let js_pushkind s : push_kind = match js_str s with - | "syntax" -> SyntaxCheck - | "lax" -> LaxCheck - | "full" -> FullCheck - | _ -> js_fail "push_kind" s - -let js_reductionrule s = match js_str s with - | "beta" -> FStar.TypeChecker.Env.Beta - | "delta" -> FStar.TypeChecker.Env.UnfoldUntil SS.delta_constant - | "iota" -> FStar.TypeChecker.Env.Iota - | "zeta" -> FStar.TypeChecker.Env.Zeta - | "reify" -> FStar.TypeChecker.Env.Reify - | "pure-subterms" -> FStar.TypeChecker.Env.PureSubtermsWithinComputations - | _ -> js_fail "reduction rule" s - -let js_optional_completion_context k = - match k with - | None -> CKCode - | Some k -> - match js_str k with - | "symbol" // Backwards compatibility - | "code" -> CKCode - | "set-options" -> CKOption false - | "reset-options" -> CKOption true - | "open" - | "let-open" -> CKModuleOrNamespace (true, true) - | "include" - | "module-alias" -> CKModuleOrNamespace (true, false) - | _ -> - js_fail "completion context (code, set-options, reset-options, \ -open, let-open, include, module-alias)" k - -let js_optional_lookup_context k = - match k with - | None -> LKSymbolOnly // Backwards-compatible default - | Some k -> - match js_str k with - | "symbol-only" -> LKSymbolOnly - | "code" -> LKCode - | "set-options" - | "reset-options" -> LKOption - | "open" - | "let-open" - | "include" - | "module-alias" -> LKModule - | _ -> - js_fail "lookup context (symbol-only, code, set-options, reset-options, \ -open, let-open, include, module-alias)" k - diff --git a/src/fstar/FStar.Interactive.Ide.fst b/src/fstar/FStar.Interactive.Ide.fst deleted file mode 100644 index 99c924713fa..00000000000 --- a/src/fstar/FStar.Interactive.Ide.fst +++ /dev/null @@ -1,1286 +0,0 @@ -(* - Copyright 2008-2016 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Interactive.Ide -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.Compiler.Range -open FStar.Compiler.Util -open FStar.Getopt -open FStar.Ident -open FStar.Errors -open FStar.Interactive.JsonHelper -open FStar.Interactive.QueryHelper -open FStar.Interactive.PushHelper -open FStar.Interactive.Ide.Types -module BU = FStar.Compiler.Util - -let dbg = Debug.get_toggle "IDE" - -open FStar.Universal -open FStar.TypeChecker.Env -open FStar.TypeChecker.Common -open FStar.Interactive -open FStar.Parser.ParseIt -open FStar.Interactive.Ide.Types -module SS = FStar.Syntax.Syntax -module DsEnv = FStar.Syntax.DsEnv -module TcErr = FStar.TypeChecker.Err -module TcEnv = FStar.TypeChecker.Env -module CTable = FStar.Interactive.CompletionTable -module QH = FStar.Interactive.QueryHelper - -let with_captured_errors' env sigint_handler f = - try - Util.with_sigint_handler sigint_handler (fun _ -> f env) - with - | Failure (msg) -> - let msg = "ASSERTION FAILURE: " ^ msg ^ "\n" ^ - "F* may be in an inconsistent state.\n" ^ - "Please file a bug report, ideally with a " ^ - "minimized version of the program that triggered the error." in - // Make sure the user sees the error, even if it happened transiently while - // running an automatic syntax checker like FlyCheck. - Errors.log_issue env Errors.Error_IDEAssertionFailure msg; - None - - | Util.SigInt -> - Util.print_string "Interrupted"; None - - | Error (e, msg, r, ctx) -> - TcErr.add_errors env [(e, msg, r, ctx)]; - None - - | Stop -> - None - -let with_captured_errors env sigint_handler f = - if Options.trace_error () then f env - else with_captured_errors' env sigint_handler f - -(** Tasks describing each snapshot of the REPL state. **) - -type env_t = TcEnv.env - -let repl_current_qid : ref (option string) = Util.mk_ref None // For messages - -(** Check whether users can issue further ``pop`` commands. **) -let nothing_left_to_pop st = - (* The first ``length st.repl_deps_stack`` entries in ``repl_stack`` are - dependency-loading entries, which the user may not pop (since they didn't - push them). *) - List.length !repl_stack = List.length st.repl_deps_stack - -(*********************) -(* Dependency checks *) -(*********************) - -(** Push, run `task`, and pop if it fails. - -If `must_rollback` is set, always pop. Returns a pair: a boolean indicating -success, and a new REPL state. **) -let run_repl_transaction st push_kind must_rollback task = - let st = push_repl "run_repl_transaction" push_kind task st in - let env, finish_name_tracking = track_name_changes st.repl_env in // begin name tracking … - - let check_success () = - get_err_count () = 0 && not must_rollback in - - // Run the task (and capture errors) - let curmod, env, success, lds = - match with_captured_errors env Util.sigint_raise - (fun env -> Some <| run_repl_task st.repl_curmod env task st.repl_lang) with - | Some (curmod, env, lds) when check_success () -> curmod, env, true, lds - | _ -> st.repl_curmod, env, false, [] in - - let env, name_events = finish_name_tracking env in // …end name tracking - let st = - if success then - let st = { st with repl_env = env; repl_curmod = curmod; repl_lang=List.rev lds@st.repl_lang } in - commit_name_tracking st name_events - else - pop_repl "run_repl_transaction" st in - - (success, st) - -(** Load dependencies described by `tasks`. - -Returns a new REPL state, wrapped in ``Inl`` to indicate complete success or -``Inr`` to indicate a partial failure. That new state has an updated -``repl_deps_stack``, containing loaded dependencies in reverse order compared to -the original list of tasks: the first dependencies (prims, ...) come first; the -current file's interface comes last. - -The original value of the ``repl_deps_stack`` field in ``st`` is used to skip -already completed tasks. - -This function is stateful: it uses ``push_repl`` and ``pop_repl``. - -`progress_callback` is called once per task, right before the task is run. **) -let run_repl_ld_transactions (st: repl_state) (tasks: list repl_task) - (progress_callback: repl_task -> unit) = - let debug verb task = - if !dbg then - Util.print2 "%s %s" verb (string_of_repl_task task) in - - (* Run as many ``pop_repl`` as there are entries in the input stack. - Elements of the input stack are expected to match the topmost ones of - ``!repl_stack`` *) - let rec revert_many st = function - | [] -> st - | (_id, (task, _st')) :: entries -> - //NS: this assertion has been failing for a while in debug mode; not sure why - assert (task = fst (snd (List.hd !repl_stack))); - debug "Reverting" task; - let st' = pop_repl "run_repl_ls_transactions" st in - let dep_graph = FStar.TypeChecker.Env.dep_graph st.repl_env in - let st' = {st' with repl_env=FStar.TypeChecker.Env.set_dep_graph st'.repl_env dep_graph} in - revert_many st' entries in - - let rec aux (st: repl_state) - (tasks: list repl_task) - (previous: list repl_stack_entry_t) = - match tasks, previous with - // All done: return the final state. - | [], [] -> - Inl st - - // We have more dependencies to load, and no previously loaded dependencies: - // run ``task`` and record the updated dependency stack in ``st``. - | task :: tasks, [] -> - debug "Loading" task; - progress_callback task; - Options.restore_cmd_line_options false |> ignore; - let timestamped_task = update_task_timestamps task in - let push_kind = if Options.lax () then LaxCheck else FullCheck in - let success, st = run_repl_transaction st (Some push_kind) false timestamped_task in - if success then aux ({ st with repl_deps_stack = !repl_stack }) tasks [] - else Inr st - - // We've already run ``task`` previously, and no update is needed: skip. - | task :: tasks, prev :: previous - when fst (snd prev) = update_task_timestamps task -> - debug "Skipping" task; - aux st tasks previous - - // We have a timestamp mismatch or a new dependency: - // revert now-obsolete dependencies and resume loading. - | tasks, previous -> - aux (revert_many st previous) tasks [] in - - aux st tasks (List.rev st.repl_deps_stack) - -let wrap_js_failure qid expected got = - { qid = qid; - qq = ProtocolViolation (Util.format2 "JSON decoding failed: expected %s, got %s" - expected (json_debug got)) } - -let unpack_interactive_query json = - let assoc errloc key a = - match try_assoc key a with - | Some v -> v - | None -> raise (InvalidQuery (Util.format2 "Missing key [%s] in %s." key errloc)) in - - let request = json |> js_assoc in - - let qid = assoc "query" "query-id" request |> js_str in - try - let query = assoc "query" "query" request |> js_str in - let args = assoc "query" "args" request |> js_assoc in - - let arg k = assoc "[args]" k args in - let try_arg k = - match try_assoc k args with - | Some JsonNull -> None - | other -> other in - - let read_position err loc = - assoc err "filename" loc |> js_str, - assoc err "line" loc |> js_int, - assoc err "column" loc |> js_int - in - let read_to_position () = - let to_pos = arg "to-position" |> js_assoc in - "", - assoc "to-position.line" "line" to_pos |> js_int, - assoc "to-position.column" "column" to_pos |> js_int - in - let parse_full_buffer_kind (kind:string) = - match kind with - | "full" -> Full - | "lax" -> Lax - | "cache" -> Cache - | "reload-deps" -> ReloadDeps - | "verify-to-position" -> VerifyToPosition (read_to_position ()) - | "lax-to-position" -> LaxToPosition (read_to_position ()) - | _ -> raise (InvalidQuery "Invalid full-buffer kind") - in - { qid = qid; - qq = match query with - | "exit" -> Exit - | "pop" -> Pop - | "describe-protocol" -> DescribeProtocol - | "describe-repl" -> DescribeRepl - | "segment" -> Segment (arg "code" |> js_str) - | "peek" | "push" -> Push ({ push_kind = arg "kind" |> js_pushkind; - push_code_or_decl = Inl (arg "code" |> js_str); - push_line = arg "line" |> js_int; - push_column = arg "column" |> js_int; - push_peek_only = query = "peek" }) - | "push-partial-checked-file" -> PushPartialCheckedFile (arg "until-lid" |> js_str) - | "full-buffer" -> FullBuffer (arg "code" |> js_str, - parse_full_buffer_kind (arg "kind" |> js_str), - arg "with-symbols" |> js_bool) - | "autocomplete" -> AutoComplete (arg "partial-symbol" |> js_str, - try_arg "context" |> js_optional_completion_context) - | "lookup" -> Lookup (arg "symbol" |> js_str, - try_arg "context" |> js_optional_lookup_context, - try_arg "location" - |> Util.map_option js_assoc - |> Util.map_option (read_position "[location]"), - arg "requested-info" |> js_list js_str, - try_arg "symbol-range") - | "compute" -> Compute (arg "term" |> js_str, - try_arg "rules" - |> Util.map_option (js_list js_reductionrule)) - | "search" -> Search (arg "terms" |> js_str) - | "vfs-add" -> VfsAdd (try_arg "filename" |> Util.map_option js_str, - arg "contents" |> js_str) - | "format" -> Format (arg "code" |> js_str) - | "restart-solver" -> RestartSolver - | "cancel" -> Cancel (Some("", arg "cancel-line" |> js_int, arg "cancel-column" |> js_int)) - | _ -> ProtocolViolation (Util.format1 "Unknown query '%s'" query) } - with - | InvalidQuery msg -> { qid = qid; qq = ProtocolViolation msg } - | UnexpectedJsonType (expected, got) -> wrap_js_failure qid expected got - -let deserialize_interactive_query js_query = - try - unpack_interactive_query js_query - with - | InvalidQuery msg -> { qid = "?"; qq = ProtocolViolation msg } - | UnexpectedJsonType (expected, got) -> wrap_js_failure "?" expected got - -let parse_interactive_query query_str : query = - match json_of_string query_str with - | None -> { qid = "?"; qq = ProtocolViolation "Json parsing failed." } - | Some request -> deserialize_interactive_query request - -let buffer_input_queries (st:repl_state) : repl_state = - let rec aux qs (st:repl_state) : repl_state = - let done qs st = - {st with repl_buffered_input_queries = - st.repl_buffered_input_queries @ List.rev qs} - in - if not (Util.poll_stdin (float_of_string "0.0")) - then done qs st - else ( - match Util.read_line st.repl_stdin with - | None -> - done qs st - - | Some line -> - let q = parse_interactive_query line in - match q.qq with - | Cancel _ -> - //Cancel drains all buffered queries - {st with repl_buffered_input_queries = [q] } - | _ -> aux (q :: qs) st - ) - in - aux [] st - -let read_interactive_query (st:repl_state) : query & repl_state = - match st.repl_buffered_input_queries with - | [] -> ( - match Util.read_line st.repl_stdin with - | None -> exit 0 - | Some line -> parse_interactive_query line, st - ) - | q :: qs -> - q, { st with repl_buffered_input_queries = qs } - -let json_of_opt json_of_a opt_a = - Util.dflt JsonNull (Util.map_option json_of_a opt_a) - -let alist_of_symbol_lookup_result lr symbol symrange_opt= - [("name", JsonStr lr.slr_name); - ("defined-at", json_of_opt json_of_def_range lr.slr_def_range); - ("type", json_of_opt JsonStr lr.slr_typ); - ("documentation", json_of_opt JsonStr lr.slr_doc); - ("definition", json_of_opt JsonStr lr.slr_def)] @ ( - // echo back the symbol-range and symbol, if symbol-range was provided - // (don't include it otherwise, for backwards compat with fstar-mode.el) - match symrange_opt with - | None -> [] - | Some symrange -> - [("symbol-range", json_of_opt (fun x -> x) symrange_opt); - ("symbol", JsonStr symbol)] - ) - -let alist_of_protocol_info = - let js_version = JsonInt interactive_protocol_vernum in - let js_features = JsonList <| List.map JsonStr interactive_protocol_features in - [("version", js_version); ("features", js_features)] - -type fstar_option_permission_level = -| OptSet -| OptReadOnly - -let string_of_option_permission_level = function - | OptSet -> "" - | OptReadOnly -> "read-only" - -type fstar_option = - { opt_name: string; - opt_sig: string; - opt_value: Options.option_val; - opt_default: Options.option_val; - opt_type: Options.opt_type; - opt_snippets: list string; - opt_documentation: option string; - opt_permission_level: fstar_option_permission_level } - -let rec kind_of_fstar_option_type = function - | Options.Const _ -> "flag" - | Options.IntStr _ -> "int" - | Options.BoolStr -> "bool" - | Options.PathStr _ -> "path" - | Options.SimpleStr _ -> "string" - | Options.EnumStr _ -> "enum" - | Options.OpenEnumStr _ -> "open enum" - | Options.PostProcessed (_, typ) - | Options.Accumulated typ - | Options.ReverseAccumulated typ - | Options.WithSideEffect (_, typ) -> kind_of_fstar_option_type typ - -let snippets_of_fstar_option name typ = - let mk_field field_name = - "${" ^ field_name ^ "}" in - let mk_snippet name argstring = - "--" ^ name ^ (if argstring <> "" then " " ^ argstring else "") in - let rec arg_snippets_of_type typ = - match typ with - | Options.Const _ -> [""] - | Options.BoolStr -> ["true"; "false"] - | Options.IntStr desc - | Options.PathStr desc - | Options.SimpleStr desc -> [mk_field desc] - | Options.EnumStr strs -> strs - | Options.OpenEnumStr (strs, desc) -> strs @ [mk_field desc] - | Options.PostProcessed (_, elem_spec) - | Options.Accumulated elem_spec - | Options.ReverseAccumulated elem_spec - | Options.WithSideEffect (_, elem_spec) -> arg_snippets_of_type elem_spec in - List.map (mk_snippet name) (arg_snippets_of_type typ) - -let rec json_of_fstar_option_value = function - | Options.Bool b -> JsonBool b - | Options.String s - | Options.Path s -> JsonStr s - | Options.Int n -> JsonInt n - | Options.List vs -> JsonList (List.map json_of_fstar_option_value vs) - | Options.Unset -> JsonNull - -let alist_of_fstar_option opt = - [("name", JsonStr opt.opt_name); - ("signature", JsonStr opt.opt_sig); - ("value", json_of_fstar_option_value opt.opt_value); - ("default", json_of_fstar_option_value opt.opt_default); - ("documentation", json_of_opt JsonStr opt.opt_documentation); - ("type", JsonStr (kind_of_fstar_option_type opt.opt_type)); - ("permission-level", JsonStr (string_of_option_permission_level opt.opt_permission_level))] - -let json_of_fstar_option opt = - JsonAssoc (alist_of_fstar_option opt) - -let json_of_response qid status response = - let qid = JsonStr qid in - let status = match status with - | QueryOK -> JsonStr "success" - | QueryNOK -> JsonStr "failure" - | QueryViolatesProtocol -> JsonStr "protocol-violation" in - JsonAssoc [("kind", JsonStr "response"); - ("query-id", qid); - ("status", status); - ("response", response)] - -let write_response qid status response = - write_json (json_of_response qid status response) - -let json_of_message level js_contents = - JsonAssoc [("kind", JsonStr "message"); - ("query-id", json_of_opt JsonStr !repl_current_qid); - ("level", JsonStr level); - ("contents", js_contents)] - -let forward_message callback level contents = - callback (json_of_message level contents) - -let json_of_hello = - let js_version = JsonInt interactive_protocol_vernum in - let js_features = JsonList (List.map JsonStr interactive_protocol_features) in - JsonAssoc (("kind", JsonStr "protocol-info") :: alist_of_protocol_info) - -let write_hello () = - write_json json_of_hello - -(*****************) -(* Options cache *) -(*****************) - -let sig_of_fstar_option name typ = - let flag = "--" ^ name in - match Options.desc_of_opt_type typ with - | None -> flag - | Some arg_sig -> flag ^ " " ^ arg_sig - -let fstar_options_list_cache = - let defaults = Util.smap_of_list Options.defaults in - Options.all_specs_with_types - |> List.filter_map (fun (_shortname, name, typ, doc) -> - Util.smap_try_find defaults name // Keep only options with a default value - |> Util.map_option (fun default_value -> - { opt_name = name; - opt_sig = sig_of_fstar_option name typ; - opt_value = Options.Unset; - opt_default = default_value; - opt_type = typ; - opt_snippets = snippets_of_fstar_option name typ; - opt_documentation = if doc = FStar.Pprint.empty then None else Some (renderdoc doc); - opt_permission_level = if Options.settable name then OptSet - else OptReadOnly })) - |> List.sortWith (fun o1 o2 -> - String.compare (String.lowercase (o1.opt_name)) - (String.lowercase (o2.opt_name))) - -let fstar_options_map_cache = - let cache = Util.smap_create 50 in - List.iter (fun opt -> Util.smap_add cache opt.opt_name opt) fstar_options_list_cache; - cache - -let update_option opt = - { opt with opt_value = Options.get_option opt.opt_name } - -let current_fstar_options filter = - List.map update_option (List.filter filter fstar_options_list_cache) - -let trim_option_name opt_name = - let opt_prefix = "--" in - if Util.starts_with opt_name opt_prefix then - (opt_prefix, Util.substring_from opt_name (String.length opt_prefix)) - else - ("", opt_name) - -(*************************) -(* Main interactive loop *) -(*************************) - -let json_of_repl_state st = - let filenames (_, (task, _)) = - match task with - | LDInterleaved (intf, impl) -> [intf.tf_fname; impl.tf_fname] - | LDSingle intf_or_impl -> [intf_or_impl.tf_fname] - | LDInterfaceOfCurrentFile intf -> [intf.tf_fname] - | _ -> [] in - - JsonAssoc - [("loaded-dependencies", - JsonList (List.map JsonStr (List.concatMap filenames st.repl_deps_stack))); - ("options", - JsonList (List.map json_of_fstar_option (current_fstar_options (fun _ -> true))))] - -let run_exit st = - ((QueryOK, JsonNull), Inr 0) - -let run_describe_protocol st = - ((QueryOK, JsonAssoc alist_of_protocol_info), Inl st) - -let run_describe_repl st = - ((QueryOK, json_of_repl_state st), Inl st) - -let run_protocol_violation st message = - ((QueryViolatesProtocol, JsonStr message), Inl st) - -let run_generic_error st message = - ((QueryNOK, JsonStr message), Inl st) - -let collect_errors () = - let errors = FStar.Errors.report_all() in - FStar.Errors.clear (); - errors - -let run_segment (st: repl_state) (code: string) = - // Unfortunately, frag_fname is a special case in the interactive mode, - // while in LSP, it is the only mode. To cope with this difference, - // pass a frag_fname that is expected by the Interactive mode. - let frag = { frag_fname = ""; frag_text = code; frag_line = 1; frag_col = 0 } in - - let collect_decls () = - match Parser.Driver.parse_fragment None frag with - | Parser.Driver.Empty -> [] - | Parser.Driver.Decls decls - | Parser.Driver.Modul (Parser.AST.Module (_, decls)) - | Parser.Driver.Modul (Parser.AST.Interface (_, decls, _)) -> decls in - - match with_captured_errors st.repl_env Util.sigint_ignore - (fun _ -> Some <| collect_decls ()) with - | None -> - let errors = collect_errors () |> List.map json_of_issue in - ((QueryNOK, JsonList errors), Inl st) - | Some decls -> - let json_of_decl decl = - JsonAssoc [("def_range", json_of_def_range decl.Parser.AST.drange)] in - let js_decls = - JsonList <| List.map json_of_decl decls in - ((QueryOK, JsonAssoc [("decls", js_decls)]), Inl st) - -let run_vfs_add st opt_fname contents = - let fname = Util.dflt st.repl_fname opt_fname in - Parser.ParseIt.add_vfs_entry fname contents; - ((QueryOK, JsonNull), Inl st) - -let run_pop st = - if nothing_left_to_pop st then - ((QueryNOK, JsonStr "Too many pops"), Inl st) - else - let st' = pop_repl "pop_query" st in - ((QueryOK, JsonNull), Inl st') - -let write_progress stage contents_alist = - let stage = match stage with Some s -> JsonStr s | None -> JsonNull in - let js_contents = ("stage", stage) :: contents_alist in - write_json (json_of_message "progress" (JsonAssoc js_contents)) - -let write_error contents = - write_json (json_of_message "error" (JsonAssoc contents)) - -let write_repl_ld_task_progress task = - match task with - | LDInterleaved (_, tf) | LDSingle tf | LDInterfaceOfCurrentFile tf -> - let modname = Parser.Dep.module_name_of_file tf.tf_fname in - write_progress (Some "loading-dependency") [("modname", JsonStr modname)] - | _ -> () - -(** Compute and load all dependencies of `filename`. - -Return an new REPL state wrapped in ``Inr`` in case of failure, and a new REPL -plus with a list of completed tasks wrapped in ``Inl`` in case of success. **) -let load_deps st = - match with_captured_errors st.repl_env Util.sigint_ignore - (fun _env -> Some <| deps_and_repl_ld_tasks_of_our_file st.repl_fname) with - | None -> Inr st - | Some (deps, tasks, dep_graph) -> - let st = {st with repl_env=FStar.TypeChecker.Env.set_dep_graph st.repl_env dep_graph} in - match run_repl_ld_transactions st tasks write_repl_ld_task_progress with - | Inr st -> write_progress None []; Inr st - | Inl st -> write_progress None []; Inl (st, deps) - -let rephrase_dependency_error issue = - { issue with issue_msg = - let open FStar.Pprint in - (Errors.Msg.text "Error while computing or loading dependencies")::issue.issue_msg} - -let write_full_buffer_fragment_progress (di:Incremental.fragment_progress) = - let open FStar.Interactive.Incremental in - let json_of_code_fragment (cf:FStar.Parser.ParseIt.code_fragment) = - JsonAssoc ["range", json_of_def_range cf.range; - "code-digest", JsonStr (BU.digest_of_string cf.code)] - in - match di with - | FullBufferStarted -> - write_progress (Some "full-buffer-started") [] - - | FragmentStarted d -> - write_progress (Some "full-buffer-fragment-started") - ["ranges", json_of_def_range d.FStar.Parser.AST.drange] - | FragmentSuccess (d, cf, FullCheck) -> - write_progress (Some "full-buffer-fragment-ok") - ["ranges", json_of_def_range d.FStar.Parser.AST.drange; - "code-fragment", json_of_code_fragment cf] - | FragmentSuccess (d, cf, LaxCheck) -> - write_progress (Some "full-buffer-fragment-lax-ok") - ["ranges", json_of_def_range d.FStar.Parser.AST.drange; - "code-fragment", json_of_code_fragment cf] - | FragmentFailed d -> - write_progress (Some "full-buffer-fragment-failed") - ["ranges", json_of_def_range d.FStar.Parser.AST.drange] - - | FragmentError issues -> - let qid = - match !repl_current_qid with - | None -> "unknown" - | Some q -> q - in - write_json (json_of_response qid QueryNOK (JsonList (List.map json_of_issue issues))) - - | FullBufferFinished -> - write_progress (Some "full-buffer-finished") [] - -let trunc_modul (m: SS.modul) (pred : SS.sigelt -> bool) : bool & SS.modul = - let rec filter decls acc = - match decls with - | [] -> false, List.rev acc - | d::ds -> - if pred d then true, List.rev acc else filter ds (d::acc) in - let found, decls = filter m.declarations [] in - found, { m with SS.declarations = decls } - -let load_partial_checked_file (env: TcEnv.env) (filename: string) (until_lid: string) = - match FStar.CheckedFiles.load_module_from_cache env filename with - | None -> failwith ("cannot find checked file for " ^ filename) - | Some tc_result -> - let _, env = with_dsenv_of_tcenv env (fun ds -> (), DsEnv.set_current_module ds tc_result.checked_module.name) in - let _, env = with_dsenv_of_tcenv env (fun ds -> (), DsEnv.set_iface_decls ds tc_result.checked_module.name []) in - let pred se = - let rec pred lids = match lids with - | [] -> false - | lid::lids -> if string_of_lid lid = until_lid then true else pred lids in - pred (Syntax.Util.lids_of_sigelt se) in - let found_decl, m = trunc_modul tc_result.checked_module pred in - if not found_decl then failwith ("did not find declaration with lident " ^ until_lid) else - let _, env = with_dsenv_of_tcenv env <| - FStar.ToSyntax.ToSyntax.add_partial_modul_to_env m tc_result.mii - (FStar.TypeChecker.Normalize.erase_universes env) in - let env = FStar.TypeChecker.Tc.load_partial_checked_module env m in - let _, env = with_dsenv_of_tcenv env (fun ds -> (), DsEnv.set_current_module ds m.name) in - let env = FStar.TypeChecker.Env.set_current_module env m.name in - ignore (FStar.SMTEncoding.Encode.encode_modul env m); - // TODO: opens / includes - env, m - -let run_load_partial_file st decl_name: (query_status & json) & either repl_state int = - match load_deps st with - | Inr st -> - let errors = List.map rephrase_dependency_error (collect_errors ()) in - let js_errors = errors |> List.map json_of_issue in - ((QueryNOK, JsonList js_errors), Inl st) - | Inl (st, deps) -> - // We have to specify a push_kind here, otherwise push_repl will not snapshot the environment. - let st = push_repl "load partial file" (Some FullCheck) Noop st in - let env = st.repl_env in - match with_captured_errors env Util.sigint_raise - (fun env -> Some <| load_partial_checked_file env st.repl_fname decl_name) with - | Some (env, curmod) when get_err_count () = 0 -> - let st = { st with repl_curmod = Some curmod; repl_env = env } in - ((QueryOK, JsonList []), Inl st) - | _ -> - let json_error_list = collect_errors () |> List.map json_of_issue in - let json_errors = JsonList json_error_list in - let st = pop_repl "load partial file" st in - (QueryNOK, json_errors), Inl st - -let run_push_without_deps st query - : (query_status & json) & either repl_state int = - let set_flychecking_flag st flag = - { st with repl_env = { st.repl_env with flychecking = flag } } in - - let { push_code_or_decl = code_or_decl; - push_line = line; - push_column = column; - push_peek_only = peek_only; - push_kind = push_kind } = query in - - - let _ = - if FStar.Options.ide_id_info_off() - then TcEnv.toggle_id_info st.repl_env false - else TcEnv.toggle_id_info st.repl_env true - in - let frag = - match code_or_decl with - | Inl text -> - Inl { frag_fname = ""; frag_text = text; frag_line = line; frag_col = column } - | Inr (decl, _code) -> - Inr decl - in - let st = set_flychecking_flag st peek_only in - let success, st = run_repl_transaction st (Some push_kind) peek_only (PushFragment (frag, push_kind, [])) in - let st = set_flychecking_flag st false in - - let status = if success || peek_only then QueryOK else QueryNOK in - let errs = collect_errors () in - let has_error = - List.existsb - (fun i -> - match i.issue_level with - | EError | ENotImplemented -> true - | _ -> false) - errs - in - let _ = - match code_or_decl with - | Inr (d, s) -> - if not has_error - then write_full_buffer_fragment_progress (Incremental.FragmentSuccess (d, s, push_kind)) - else write_full_buffer_fragment_progress (Incremental.FragmentFailed d) - | _ -> () - in - let json_errors = JsonList (errs |> List.map json_of_issue) in - let _ = - match errs, status with - | _::_, QueryOK -> add_issues_to_push_fragment [json_errors] - | _ -> () - in - let st = if success then { st with repl_line = line; repl_column = column } else st in - ((status, json_errors), Inl st) - -let run_push_with_deps st query = - if !dbg then - Util.print_string "Reloading dependencies"; - TcEnv.toggle_id_info st.repl_env false; - match load_deps st with - | Inr st -> - let errors = List.map rephrase_dependency_error (collect_errors ()) in - let js_errors = errors |> List.map json_of_issue in - ((QueryNOK, JsonList js_errors), Inl st) - | Inl (st, deps) -> - Options.restore_cmd_line_options false |> ignore; - let names = add_module_completions st.repl_fname deps st.repl_names in - run_push_without_deps ({ st with repl_names = names }) query - -let run_push st query = - if nothing_left_to_pop st then - run_push_with_deps st query - else - run_push_without_deps st query - -let run_symbol_lookup st symbol pos_opt requested_info (symbol_range_opt:option json) = - match QH.symlookup st.repl_env symbol pos_opt requested_info with - | None -> Inl "Symbol not found" - | Some result -> - Inr ("symbol", alist_of_symbol_lookup_result result symbol symbol_range_opt) - -let run_option_lookup opt_name = - let _, trimmed_name = trim_option_name opt_name in - match Util.smap_try_find fstar_options_map_cache trimmed_name with - | None -> Inl ("Unknown option:" ^ opt_name) - | Some opt -> Inr ("option", alist_of_fstar_option (update_option opt)) - -let run_module_lookup st symbol = - let query = Util.split symbol "." in - match CTable.find_module_or_ns st.repl_names query with - | None -> - Inl "No such module or namespace" - | Some (CTable.Module mod_info) -> - Inr ("module", CTable.alist_of_mod_info mod_info) - | Some (CTable.Namespace ns_info) -> - Inr ("namespace", CTable.alist_of_ns_info ns_info) - -let run_code_lookup st symbol pos_opt requested_info symrange_opt= - match run_symbol_lookup st symbol pos_opt requested_info symrange_opt with - | Inr alist -> Inr alist - | Inl _ -> match run_module_lookup st symbol with - | Inr alist -> Inr alist - | Inl err_msg -> Inl "No such symbol, module, or namespace." - -let run_lookup' st symbol context pos_opt requested_info symrange = - match context with - | LKSymbolOnly -> run_symbol_lookup st symbol pos_opt requested_info symrange - | LKModule -> run_module_lookup st symbol - | LKOption -> run_option_lookup symbol - | LKCode -> run_code_lookup st symbol pos_opt requested_info symrange - -let run_lookup st symbol context pos_opt requested_info symrange = - try - match run_lookup' st symbol context pos_opt requested_info symrange with - | Inl err_msg -> ( - match symrange with - | None -> - //fstar-mode.el expects a failure on symbol not found - ((QueryNOK, [JsonStr err_msg]), Inl st) - | _ -> - // This is the behavior for the vscode mode - // No result found, but don't fail the query - ((QueryOK, []), Inl st) - ) - - | Inr (kind, info) -> - ((QueryOK, [JsonAssoc (("kind", JsonStr kind) :: info)]), Inl st) - with - | _ -> ((QueryOK, [JsonStr ("Lookup of " ^ symbol^ " failed")]), Inl st) - - -let run_code_autocomplete st search_term = - let result = QH.ck_completion st search_term in - let results = - match result with - | [] -> result - | _ -> - let result_correlator : CTable.completion_result = { - completion_match_length = 0; - completion_annotation = ""; - completion_candidate = search_term - } in - result@[result_correlator] - in - let js = List.map CTable.json_of_completion_result results in - ((QueryOK, JsonList js), Inl st) - -let run_module_autocomplete st search_term modules namespaces = - let needle = Util.split search_term "." in - let mods_and_nss = CTable.autocomplete_mod_or_ns st.repl_names needle Some in - let json = List.map CTable.json_of_completion_result mods_and_nss in - ((QueryOK, JsonList json), Inl st) - -let candidates_of_fstar_option match_len is_reset opt = - let may_set, explanation = - match opt.opt_permission_level with - | OptSet -> true, "" - | OptReadOnly -> false, "read-only" in - let opt_type = - kind_of_fstar_option_type opt.opt_type in - let annot = - if may_set then opt_type else "(" ^ explanation ^ " " ^ opt_type ^ ")" in - opt.opt_snippets - |> List.map (fun snippet -> - { CTable.completion_match_length = match_len; - CTable.completion_candidate = snippet; - CTable.completion_annotation = annot }) - -let run_option_autocomplete st search_term is_reset = - match trim_option_name search_term with - | ("--", trimmed_name) -> - let matcher opt = Util.starts_with opt.opt_name trimmed_name in - let options = current_fstar_options matcher in - - let match_len = String.length search_term in - let collect_candidates = candidates_of_fstar_option match_len is_reset in - let results = List.concatMap collect_candidates options in - - let json = List.map CTable.json_of_completion_result results in - ((QueryOK, JsonList json), Inl st) - | (_, _) -> ((QueryNOK, JsonStr "Options should start with '--'"), Inl st) - -let run_autocomplete st search_term context = - match context with - | CKCode -> - run_code_autocomplete st search_term - | CKOption is_reset -> - run_option_autocomplete st search_term is_reset - | CKModuleOrNamespace (modules, namespaces) -> - run_module_autocomplete st search_term modules namespaces - -let run_and_rewind st sigint_default task = - let st = push_repl "run_and_rewind" (Some FullCheck) Noop st in - let results = - try Util.with_sigint_handler Util.sigint_raise (fun _ -> Inl <| task st) - with | Util.SigInt -> Inl sigint_default - | e -> Inr e in - let st = pop_repl "run_and_rewind" st in - match results with - | Inl results -> (results, Inl st) - | Inr e -> raise e // CPC fixme add a test with two computations - -let run_with_parsed_and_tc_term st term line column continuation = - let dummy_let_fragment term = - let dummy_decl = Util.format1 "let __compute_dummy__ = (%s)" term in - { frag_fname = " input"; frag_text = dummy_decl; frag_line = 0; frag_col = 0 } in - - let find_let_body ses = - match ses with - | [{ SS.sigel = SS.Sig_let {lbs=(_, [{ SS.lbunivs = univs; SS.lbdef = def }])} }] -> - Some (univs, def) - | _ -> None in - - let parse frag = - match FStar.Parser.ParseIt.parse None (FStar.Parser.ParseIt.Incremental frag) with - | FStar.Parser.ParseIt.IncrementalFragment (decls, _, _err) -> Some (List.map fst decls) - | _ -> None in - - let desugar env decls = - fst (FStar.ToSyntax.ToSyntax.decls_to_sigelts decls env.dsenv) in - - let typecheck tcenv decls = - let ses, _ = FStar.TypeChecker.Tc.tc_decls tcenv decls in - ses in - - run_and_rewind st (QueryNOK, JsonStr "Computation interrupted") (fun st -> - let tcenv = st.repl_env in - let frag = dummy_let_fragment term in - match parse frag with - | None -> (QueryNOK, JsonStr "Could not parse this term") - | Some decls -> - let aux () = - let decls = desugar tcenv decls in - let ses = typecheck tcenv decls in - match find_let_body ses with - | None -> (QueryNOK, JsonStr "Typechecking yielded an unexpected term") - | Some (univs, def) -> - let univs, def = Syntax.Subst.open_univ_vars univs def in - let tcenv = TcEnv.push_univ_vars tcenv univs in - continuation tcenv def in - if Options.trace_error () then - aux () - else - try aux () - with | e -> (match FStar.Errors.issue_of_exn e with - | Some issue -> (QueryNOK, JsonStr (FStar.Errors.format_issue issue)) - | None -> raise e)) - -let run_compute st term rules = - let rules = - (match rules with - | Some rules -> rules - | None -> [FStar.TypeChecker.Env.Beta; - FStar.TypeChecker.Env.Iota; - FStar.TypeChecker.Env.Zeta; - FStar.TypeChecker.Env.UnfoldUntil SS.delta_constant]) - @ [FStar.TypeChecker.Env.Inlining; - FStar.TypeChecker.Env.Eager_unfolding; - FStar.TypeChecker.Env.DontUnfoldAttr [Parser.Const.tac_opaque_attr]; - FStar.TypeChecker.Env.Primops] in - - let normalize_term tcenv rules t = - FStar.TypeChecker.Normalize.normalize rules tcenv t in - - run_with_parsed_and_tc_term st term 0 0 (fun tcenv def -> - let normalized = normalize_term tcenv rules def in - (QueryOK, JsonStr (term_to_string tcenv normalized))) - -type search_term' = -| NameContainsStr of string -| TypeContainsLid of lid -and search_term = { st_negate: bool; - st_term: search_term' } - -let st_cost = function -| NameContainsStr str -> - (String.length str) -| TypeContainsLid lid -> 1 - -type search_candidate = { sc_lid: lid; sc_typ: - ref (option Syntax.Syntax.typ); - sc_fvars: ref (option (RBSet.t lid)) } - -let sc_of_lid lid = { sc_lid = lid; - sc_typ = Util.mk_ref None; - sc_fvars = Util.mk_ref None } - -let sc_typ tcenv sc = // Memoized version of sc_typ - match !sc.sc_typ with - | Some t -> t - | None -> let typ = match try_lookup_lid tcenv sc.sc_lid with - | None -> SS.mk SS.Tm_unknown Range.dummyRange - | Some ((_, typ), _) -> typ in - sc.sc_typ := Some typ; typ - -let sc_fvars tcenv sc = // Memoized version of fc_vars - match !sc.sc_fvars with - | Some fv -> fv - | None -> let fv = Syntax.Free.fvars (sc_typ tcenv sc) in - sc.sc_fvars := Some fv; fv - -let json_of_search_result tcenv sc = - let typ_str = term_to_string tcenv (sc_typ tcenv sc) in - JsonAssoc [("lid", JsonStr (string_of_lid (DsEnv.shorten_lid tcenv.dsenv sc.sc_lid))); - ("type", JsonStr typ_str)] - -exception InvalidSearch of string - -let run_search st search_str = - let tcenv = st.repl_env in - - let st_matches candidate term = - let found = - match term.st_term with - | NameContainsStr str -> Util.contains (string_of_lid candidate.sc_lid) str - | TypeContainsLid lid -> Class.Setlike.mem lid (sc_fvars tcenv candidate) in - found <> term.st_negate in - - let parse search_str = - let parse_one term = - let negate = Util.starts_with term "-" in - let term = if negate then Util.substring_from term 1 else term in - let beg_quote = Util.starts_with term "\"" in - let end_quote = Util.ends_with term "\"" in - let strip_quotes str = - if String.length str < 2 then - raise (InvalidSearch "Empty search term") - else - Util.substring str 1 (String.length term - 2) in - let parsed = - if beg_quote <> end_quote then - raise (InvalidSearch (Util.format1 "Improperly quoted search term: %s" term)) - else if beg_quote then - NameContainsStr (strip_quotes term) - else - let lid = Ident.lid_of_str term in - match DsEnv.resolve_to_fully_qualified_name tcenv.dsenv lid with - | None -> raise (InvalidSearch (Util.format1 "Unknown identifier: %s" term)) - | Some lid -> TypeContainsLid lid in - { st_negate = negate; st_term = parsed } in - - let terms = List.map parse_one (Util.split search_str " ") in - let cmp = fun x y -> st_cost x.st_term - st_cost y.st_term in - Util.sort_with cmp terms in - - let pprint_one term = - (if term.st_negate then "-" else "") - ^ (match term.st_term with - | NameContainsStr s -> Util.format1 "\"%s\"" s - | TypeContainsLid l -> Util.format1 "%s" (string_of_lid l)) in - - let results = - try - let terms = parse search_str in - let all_lidents = TcEnv.lidents tcenv in - let all_candidates = List.map sc_of_lid all_lidents in - let matches_all candidate = List.for_all (st_matches candidate) terms in - let cmp r1 r2 = Util.compare (string_of_lid r1.sc_lid) (string_of_lid r2.sc_lid) in - let results = List.filter matches_all all_candidates in - let sorted = Util.sort_with cmp results in - let js = List.map (json_of_search_result tcenv) sorted in - match results with - | [] -> let kwds = Util.concat_l " " (List.map pprint_one terms) in - raise (InvalidSearch (Util.format1 "No results found for query [%s]" kwds)) - | _ -> (QueryOK, JsonList js) - with InvalidSearch s -> (QueryNOK, JsonStr s) in - (results, Inl st) - -let run_format_code st code = - let code_or_err = FStar.Interactive.Incremental.format_code st code in - match code_or_err with - | Inl code -> - let result = JsonAssoc ["formatted-code", JsonStr code] in - (QueryOK, result), Inl st - | Inr issue -> - let result = JsonAssoc ["formatted-code-issue", JsonList (List.map json_of_issue issue)] in - (QueryNOK, result), Inl st - -let as_json_list (q: (query_status & json) & either repl_state int) - : (query_status & list json) & either repl_state int - = let (q, j), s = q in - (q, [j]), s - -let run_query_result = (query_status & list json) & either repl_state int - -let maybe_cancel_queries st l = - let log_cancellation l = - if !dbg - then List.iter (fun q -> BU.print1 "Cancelling query: %s\n" (query_to_string q)) l - in - match st.repl_buffered_input_queries with - | { qq = Cancel p } :: rest -> ( - let st = { st with repl_buffered_input_queries = rest } in - match p with - | None -> //If no range, then cancel all remaining queries - log_cancellation l; - [], st - | Some p -> //Cancel all queries that are within the range - let query_ahead_of p q = - let _, l, c = p in - match q.qq with - | Push pq -> pq.push_line >= l - | _ -> false - in - let l = - match BU.prefix_until (query_ahead_of p) l with - | None -> l - | Some (l, q, qs) -> - log_cancellation (q::qs); - l - in - l, st - ) - | _ -> l, st - -let rec fold_query (f:repl_state -> query -> run_query_result) - (l:list query) - (st:repl_state) - : run_query_result - = match l with - | [] -> (QueryOK, []), Inl st - | q::l -> - let (status, responses), st' = f st q in - List.iter (write_response q.qid status) responses; - match status, st' with - | QueryOK, Inl st -> - let st = buffer_input_queries st in - let l, st = maybe_cancel_queries st l in - fold_query f l st - | _ -> - (status, []), st' - -let validate_query st (q: query) : query = - match q.qq with - | Push { push_kind = SyntaxCheck; push_peek_only = false } -> - { qid = q.qid; qq = ProtocolViolation "Cannot use 'kind': 'syntax' with 'query': 'push'" } - | _ -> match st.repl_curmod with - | None when query_needs_current_module q.qq -> - { qid = q.qid; qq = GenericError "Current module unset" } - | _ -> q - -let rec run_query st (q: query) : (query_status & list json) & either repl_state int = - match q.qq with - | Exit -> as_json_list (run_exit st) - | DescribeProtocol -> as_json_list (run_describe_protocol st) - | DescribeRepl -> as_json_list (run_describe_repl st) - | GenericError message -> as_json_list (run_generic_error st message) - | ProtocolViolation query -> as_json_list (run_protocol_violation st query) - | Segment c -> as_json_list (run_segment st c) - | VfsAdd (fname, contents) -> as_json_list (run_vfs_add st fname contents) - | Push pquery -> as_json_list (run_push st pquery) - | PushPartialCheckedFile decl_name -> as_json_list (run_load_partial_file st decl_name) - | Pop -> as_json_list (run_pop st) - | FullBuffer (code, full_kind, with_symbols) -> - let open FStar.Interactive.Incremental in - write_full_buffer_fragment_progress FullBufferStarted; - let queries, issues = - run_full_buffer st q.qid code full_kind with_symbols write_full_buffer_fragment_progress - in - List.iter (write_response q.qid QueryOK) issues; - let res = fold_query validate_and_run_query queries st in - write_full_buffer_fragment_progress FullBufferFinished; - res - | AutoComplete (search_term, context) -> - as_json_list (run_autocomplete st search_term context) - | Lookup (symbol, context, pos_opt, rq_info, symrange) -> - run_lookup st symbol context pos_opt rq_info symrange - | Compute (term, rules) -> - as_json_list (run_compute st term rules) - | Search term -> - as_json_list (run_search st term) - | Callback f -> - f st - | Format code -> - as_json_list (run_format_code st code) - | RestartSolver -> - st.repl_env.solver.refresh None; - (QueryOK, []), Inl st - | Cancel _ -> - //This should be handled in the fold_query loop above - (QueryOK, []), Inl st -and validate_and_run_query st query = - let query = validate_query st query in - repl_current_qid := Some query.qid; - if !dbg - then BU.print2 "Running query %s: %s\n" query.qid (query_to_string query); - run_query st query - -(** This is the body of the JavaScript port's main loop. **) -let js_repl_eval st query = - let (status, responses), st_opt = validate_and_run_query st query in - let js_responses = List.map (json_of_response query.qid status) responses in - js_responses, st_opt - -let js_repl_eval_js st query_js = - js_repl_eval st (deserialize_interactive_query query_js) - -let js_repl_eval_str st query_str = - let js_response, st_opt = - js_repl_eval st (parse_interactive_query query_str) in - (List.map string_of_json js_response), st_opt - -(** This too is called from FStar.js **) -let js_repl_init_opts () = - let res, fnames = Options.parse_cmd_line () in - match res with - | Getopt.Error msg -> failwith ("repl_init: " ^ msg) - | Getopt.Help -> failwith "repl_init: --help unexpected" - | Getopt.Success -> - match fnames with - | [] -> - failwith "repl_init: No file name given in --ide invocation" - | h :: _ :: _ -> - failwith "repl_init: Too many file names given in --ide invocation" - | _ -> () - -(** This is the main loop for the desktop version **) -let rec go st : int = - let query, st = read_interactive_query st in - let (status, responses), state_opt = validate_and_run_query st query in - List.iter (write_response query.qid status) responses; - match state_opt with - | Inl st' -> go st' - | Inr exitcode -> exitcode - -let interactive_error_handler = // No printing here — collect everything for future use - let issues : ref (list issue) = Util.mk_ref [] in - let add_one (e: issue) = issues := e :: !issues in - let count_errors () = - let issues = Util.remove_dups (fun i0 i1 -> i0=i1) !issues in - List.length (List.filter (fun e -> e.issue_level = EError) issues) - in - let report () = - List.sortWith compare_issues (Util.remove_dups (fun i0 i1 -> i0=i1) !issues) - in - let clear () = issues := [] in - { eh_name = "interactive error handler"; - eh_add_one = add_one; - eh_count_errors = count_errors; - eh_report = report; - eh_clear = clear } - -let interactive_printer printer = - { printer_prinfo = (fun s -> forward_message printer "info" (JsonStr s)); - printer_prwarning = (fun s -> forward_message printer "warning" (JsonStr s)); - printer_prerror = (fun s -> forward_message printer "error" (JsonStr s)); - printer_prgeneric = (fun label get_string get_json -> - forward_message printer label (get_json ())) } - -let install_ide_mode_hooks printer = - FStar.Compiler.Util.set_printer (interactive_printer printer); - FStar.Errors.set_handler interactive_error_handler - - -let build_initial_repl_state (filename: string) = - let env = init_env FStar.Parser.Dep.empty_deps in - let env = FStar.TypeChecker.Env.set_range env initial_range in - FStar.Options.set_ide_filename filename; - { repl_line = 1; - repl_column = 0; - repl_fname = filename; - repl_curmod = None; - repl_env = env; - repl_deps_stack = []; - repl_stdin = open_stdin (); - repl_names = CompletionTable.empty; - repl_buffered_input_queries = []; - repl_lang = [] } - -let interactive_mode' init_st = - write_hello (); - - let exit_code = - if FStar.Options.record_hints() || FStar.Options.use_hints() then - FStar.SMTEncoding.Solver.with_hints_db (List.hd (Options.file_list ())) (fun () -> go init_st) - else - go init_st in - exit exit_code - -let interactive_mode (filename:string): unit = - install_ide_mode_hooks write_json; - // Ignore unexpected interrupts (some methods override this handler) - Util.set_sigint_handler Util.sigint_ignore; - - if Option.isSome (Options.codegen ()) then - Errors.log_issue0 Errors.Warning_IDEIgnoreCodeGen "--ide: ignoring --codegen"; - - let init = build_initial_repl_state filename in - if Options.trace_error () then - // This prevents the error catcher below from swallowing backtraces - interactive_mode' init - else - try - interactive_mode' init - with - | e -> (// Revert to default handler since we won't have an opportunity to - // print errors ourselves. - FStar.Errors.set_handler FStar.Errors.default_handler; - raise e) diff --git a/src/fstar/FStar.Interactive.Incremental.fst b/src/fstar/FStar.Interactive.Incremental.fst deleted file mode 100644 index 65a33ea43ad..00000000000 --- a/src/fstar/FStar.Interactive.Incremental.fst +++ /dev/null @@ -1,368 +0,0 @@ -(* - Copyright 2023 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Interactive.Incremental -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.Compiler.Range -open FStar.Compiler.Util -open FStar.Getopt -open FStar.Ident -open FStar.Errors -open FStar.Interactive.JsonHelper -open FStar.Interactive.QueryHelper -open FStar.Interactive.PushHelper -open FStar.Universal -open FStar.TypeChecker.Env -open FStar.TypeChecker.Common -open FStar.Interactive -open FStar.Parser.ParseIt -module SS = FStar.Syntax.Syntax -module DsEnv = FStar.Syntax.DsEnv -module TcErr = FStar.TypeChecker.Err -module TcEnv = FStar.TypeChecker.Env -module CTable = FStar.Interactive.CompletionTable -open FStar.Interactive.Ide.Types -module P = FStar.Parser.ParseIt -module BU = FStar.Compiler.Util -open FStar.Parser.AST -open FStar.Parser.AST.Util - -let qid = string & int -let qst a = qid -> a & qid -let return (x:'a) : qst 'a = fun q -> x, q -let (let!) (f:qst 'a) (g: 'a -> qst 'b) - : qst 'b - = fun q -> let x, q' = f q in - g x q' - -let run_qst (f:qst 'a) (q:string) - : 'a - = fst (f (q, 0)) - - -let rec map (f:'a -> qst 'b) (l:list 'a) - : qst (list 'b) - = match l with - | [] -> return [] - | hd::tl -> - let! hd = f hd in - let! tl = map f tl in - return (hd :: tl) - -let shift_qid (q:qid) (i:int) = fst q, snd q + i - -let next_qid - : qst qid - = fun q -> let q = shift_qid q 1 in - q, q - -let get_qid - : qst qid - = fun q -> q, q - -let as_query (q:query') - : qst query - = let! (qid_prefix, i) = next_qid in - return - { - qq=q; - qid=qid_prefix ^ "." ^ string_of_int i - } - -(* This function dumps a symbol table for the decl that has just been checked *) -let dump_symbols_for_lid (l:lident) -: qst query -= let r = Ident.range_of_lid l in - let start_pos = Range.start_of_range r in - let end_pos = Range.end_of_range r in - let start_line = Range.line_of_pos start_pos in - let start_col = Range.col_of_pos start_pos in - let end_line = Range.line_of_pos end_pos in - let end_col = Range.col_of_pos end_pos in - let position = "", start_line, start_col in - as_query (Lookup(Ident.string_of_lid l, - LKCode, - Some position, - ["type"; "documentation"; "defined-at"], - Some (JsonAssoc [("fname", JsonStr ""); - ("beg", JsonList [JsonInt start_line; JsonInt start_col]); - ("end", JsonList [JsonInt end_line; JsonInt end_col])]))) - -let dump_symbols (d:decl) -: qst (list query) -= let open FStar.Parser.AST in - let ls = lidents_of_decl d in - map dump_symbols_for_lid ls - - -(* Push a decl for checking, and before it runs, - print a progress message "fragment-started" - for the decl that is about to run *) -let push_decl (push_kind:push_kind) - (with_symbols:bool) - (write_full_buffer_fragment_progress: fragment_progress -> unit) - (ds:decl & code_fragment) - : qst (list query) - = let open FStar.Compiler.Range in - let d, s = ds in - let pq = { - push_kind; - push_line = line_of_pos (start_of_range d.drange); - push_column = col_of_pos (start_of_range d.drange); - push_peek_only = false; - push_code_or_decl = Inr ds - } in - let progress st = - write_full_buffer_fragment_progress (FragmentStarted d); - (QueryOK, []), Inl st - in - let! cb = as_query (Callback progress) in - let! push = as_query (Push pq) in - if with_symbols - then ( - let! lookups = dump_symbols d in - return ([cb; push] @ lookups) - ) - else ( - return [cb; push] - ) - -let push_decls (push_kind:push_kind) - (with_symbols:bool) - (write_full_buffer_fragment_progress : fragment_progress -> unit) - (ds:list (decl & code_fragment)) - : qst (list query) - = let! qs = map (push_decl push_kind with_symbols write_full_buffer_fragment_progress) ds in - return (List.flatten qs) - -let pop_entries (e:list repl_stack_entry_t) - : qst (list query) - = map (fun _ -> as_query Pop) e - -let repl_task (_, (p, _)) = p - -(* Find a prefix of the repl stack that matche a prefix of the decls ds, - pop the rest of the stack - and push the remaining suffix of decls -*) -let inspect_repl_stack (s:repl_stack_t) - (ds:list (decl & code_fragment)) - (push_kind : push_kind) - (with_symbols:bool) - (write_full_buffer_fragment_progress: fragment_progress -> unit) - : qst (list query & list json) - = let entries = List.rev s in - let push_decls = push_decls push_kind with_symbols write_full_buffer_fragment_progress in - match BU.prefix_until - (function (_, (PushFragment _, _)) -> true | _ -> false) - entries - with - | None -> - let! ds = push_decls ds in - return (ds, []) - - | Some (prefix, first_push, rest) -> - let entries = first_push :: rest in - let repl_task (_, (p, _)) = p in - let rec matching_prefix (accum:list json) (lookups:list query) entries (ds:list (decl & code_fragment)) - : qst (list query & list json) - = match entries, ds with - | [], [] -> - return (lookups, accum) - - | e::entries, d::ds -> ( - match repl_task e with - | Noop -> - matching_prefix accum lookups entries (d::ds) - | PushFragment (Inl frag, _, _) -> - let! pops = pop_entries (e::entries) in - let! pushes = push_decls (d::ds) in - return (lookups @ pops @ pushes, accum) - | PushFragment (Inr d', pk, issues) -> - if eq_decl (fst d) d' - then ( - let d, s = d in - write_full_buffer_fragment_progress (FragmentSuccess (d, s, pk)); - if with_symbols - then let! lookups' = dump_symbols d in - matching_prefix (issues@accum) (lookups'@lookups) entries ds - else - matching_prefix (issues@accum) lookups entries ds - ) - else let! pops = pop_entries (e::entries) in - let! pushes = push_decls (d::ds) in - return (pops @ lookups @ pushes, accum) - ) - - | [], ds -> - let! pushes = push_decls ds in - return (lookups@pushes, accum) - - | es, [] -> - let! pops = pop_entries es in - return (lookups@pops, accum) - in - matching_prefix [] [] entries ds - -(* A reload_deps request just pops away the entire stack of PushFragments. - We also push on just the `module A` declaration after popping. That's done below. *) -let reload_deps repl_stack = - let pop_until_deps entries - : qst (list query) - = match BU.prefix_until - (fun e -> match repl_task e with - | PushFragment _ | Noop -> false - | _ -> true) - entries - with - | None -> return [] - | Some (prefix, _, _) -> - let! pop = as_query Pop in - return (List.map (fun _ -> pop) prefix) - in - pop_until_deps repl_stack - -(* A utility to parse a chunk, used both in full_buffer and formatting *) -let parse_code lang (code:string) = - P.parse lang (Incremental { - frag_fname = Range.file_of_range initial_range; - frag_text = code; - frag_line = Range.line_of_pos (Range.start_of_range initial_range); - frag_col = Range.col_of_pos (Range.start_of_range initial_range); - }) - -(* Format FStar.Errors.error into a JSON error message *) -let syntax_issue (raw_error, msg, range) = - let _, _, num = FStar.Errors.lookup raw_error in - let issue = { - issue_msg = msg; - issue_level = EError; - issue_range = Some range; - issue_number = Some num; - issue_ctx = [] - } in - issue - -(* See comment in the interface file *) -let run_full_buffer (st:repl_state) - (qid:string) - (code:string) - (request_type:full_buffer_request_kind) - (with_symbols:bool) - (write_full_buffer_fragment_progress: fragment_progress -> unit) - : list query & list json - = let parse_result = parse_code None code in - let log_syntax_issues err = - match err with - | None -> () - | Some err -> - let issue = syntax_issue err in - write_full_buffer_fragment_progress (FragmentError [issue]) - in - let filter_decls decls = - match request_type with - | VerifyToPosition (_, line, _col) - | LaxToPosition (_, line, _col) -> - List.filter - (fun (d, _) -> - let start = Range.start_of_range d.drange in - let start_line = Range.line_of_pos start in - start_line <= line) - decls - | _ -> decls - in - let qs = - match parse_result with - | IncrementalFragment (decls, _, err_opt) -> ( - // This is a diagnostic message that is send to the IDE as an info message - // The script test-incremental.py in tests/ide/ depends on this message - BU.print1 "Parsed %s declarations\n" (string_of_int (List.length decls)); - match request_type, decls with - | ReloadDeps, d::_ -> - run_qst (let! queries = reload_deps (!repl_stack) in - let! push_mod = push_decl FullCheck with_symbols write_full_buffer_fragment_progress d in - return (queries @ push_mod, [])) - qid - - | _ -> - let decls = filter_decls decls in - let push_kind = - match request_type with - | LaxToPosition _ -> LaxCheck - | Lax -> LaxCheck - | _ -> FullCheck - in - let queries, issues = - run_qst (inspect_repl_stack (!repl_stack) decls push_kind with_symbols write_full_buffer_fragment_progress) qid - in - if request_type <> Cache then log_syntax_issues err_opt; - if Debug.any() - then ( - BU.print1 "Generating queries\n%s\n" - (String.concat "\n" (List.map query_to_string queries)) - ); - if request_type <> Cache then (queries, issues) else ([] , issues) - - ) - - | ParseError err -> - if request_type = Full then log_syntax_issues (Some err); - [], [] - | _ -> - failwith "Unexpected parse result" - in - qs - -(* See comment in interface file *) -let format_code (st:repl_state) (code:string) - = let maybe_lang = - match st.repl_lang with - | [] -> None - | {d=FStar.Parser.AST.UseLangDecls l}::_ -> Some l - in - let parse_result = parse_code maybe_lang code in - match parse_result with - | IncrementalFragment (decls, comments, None) -> - let doc_to_string doc = - FStar.Pprint.pretty_string (float_of_string "1.0") 100 doc - in - let formatted_code_rev, leftover_comments = - List.fold_left - (fun (out, comments) (d, _) -> - let doc, comments = FStar.Parser.ToDocument.decl_with_comments_to_document d comments in - doc_to_string doc::out, comments) - ([], List.rev comments) - decls - in - let code = formatted_code_rev |> List.rev |> String.concat "\n\n" in - let formatted_code = - match leftover_comments with - | [] -> code - | _ -> - let doc = FStar.Parser.ToDocument.comments_to_document leftover_comments in - code ^ "\n\n" ^ doc_to_string doc - in - Inl formatted_code - | IncrementalFragment (_, _, Some err) -> - Inr [syntax_issue err] - | ParseError err -> - Inr [syntax_issue err] - | _ -> - failwith "Unexpected parse result" diff --git a/src/fstar/FStar.Interactive.Incremental.fsti b/src/fstar/FStar.Interactive.Incremental.fsti deleted file mode 100644 index 78d21c4c820..00000000000 --- a/src/fstar/FStar.Interactive.Incremental.fsti +++ /dev/null @@ -1,58 +0,0 @@ -(* - Copyright 2023 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Interactive.Incremental -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.Parser.AST -open FStar.Errors -open FStar.Interactive.Ide.Types -open FStar.Compiler.Util - -(* Various kinds of progress messages to print back to the client *) -type fragment_progress = - | FullBufferStarted - | FragmentStarted of decl - | FragmentSuccess of (decl & FStar.Parser.ParseIt.code_fragment & push_kind) - | FragmentFailed of decl - | FragmentError of list issue - | FullBufferFinished - -(* Translates a full-buffer(qid, code) query by - 1. Parsing the code into its declarations - 2. Finding a prefix of the repl state that matches a prefix of the declarations - 3. Popping away the suffix of the repl state - 4. Pushing the suffix of parsed decls for checking - - It uses the write_full_buffer_fragment_progress callback to issue - success markers for the prefix of decls that were found in the repl state, - and issues syntax errors for the suffix of the code that could not be parsed. -*) -val run_full_buffer (st:repl_state) - (qid:string) - (code:string) - (full:full_buffer_request_kind) - (with_symbols:bool) - (write_full_buffer_fragment_progress: fragment_progress -> unit) - : list query & list json - -(* Pretty-print the code for reformatting, or return a syntax error *) -val format_code (st:repl_state) - (code:string) - : either string (list issue) \ No newline at end of file diff --git a/src/fstar/FStar.Interactive.JsonHelper.fst b/src/fstar/FStar.Interactive.JsonHelper.fst deleted file mode 100644 index ade409d85f3..00000000000 --- a/src/fstar/FStar.Interactive.JsonHelper.fst +++ /dev/null @@ -1,264 +0,0 @@ -(* - Copyright 2019 and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -(* Json helpers mainly for FStar.Interactive.Lsp; some sharing with * - * FStar.Interactive.Ide *) - -module FStar.Interactive.JsonHelper -open FStar -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Compiler -open FStar.Compiler.Util -open FStar.Errors -open FStar.Compiler.Range -open FStar.Json -open FStar.TypeChecker.Env - -module U = FStar.Compiler.Util -module PI = FStar.Parser.ParseIt -module TcEnv = FStar.TypeChecker.Env -module CTable = FStar.Interactive.CompletionTable - -let try_assoc (key: string) (d: assoct) = - U.map_option snd (U.try_find (fun (k, _) -> k = key) d) - -// All exceptions are guaranteed to be caught in the LSP server implementation -exception MissingKey of string // Only in LSP -exception InvalidQuery of string // Only in IDE -exception UnexpectedJsonType of string & json -exception MalformedHeader -exception InputExhausted - -// The definition in IDE is nested; this differs in not providing loc -let assoc key a = - match try_assoc key a with - | Some v -> v - | None -> raise (MissingKey (U.format1 "Missing key [%s]" key)) - -let write_json (js: json) = - U.print_raw (string_of_json js); - U.print_raw "\n" - -let write_jsonrpc (js: json) : unit = - // TODO: utf-8 strings: byte buffers? - let js_str = string_of_json js in - let len = U.string_of_int (String.length js_str) in - U.print_raw (U.format2 "Content-Length: %s\r\n\r\n%s" len js_str) - -// Only used in IDE -let js_fail expected got = - raise (UnexpectedJsonType (expected, got)) - -let js_int : json -> int = function - | JsonInt i -> i - | other -> js_fail "int" other -let js_bool : json -> bool = function - | JsonBool b -> b - | other -> js_fail "int" other -let js_str : json -> string = function - | JsonStr s -> s - | other -> js_fail "string" other -let js_list k = function - | JsonList l -> List.map k l - | other -> js_fail "list" other -let js_assoc : json -> assoct = function - | JsonAssoc a -> a - | other -> js_fail "dictionary" other -let js_str_int : json -> int = function - | JsonInt i -> i - | JsonStr s -> U.int_of_string s - | other -> js_fail "string or int" other - -// May throw -let arg k r = assoc k (assoc "params" r |> js_assoc) - -// UNIX paths: file:///foo/bar corresponds to /foo/bar -// 01234567 -// -// Windows paths: "file:///z%3A/foo corresponds to z:/foo -// 0123456789 012 -let uri_to_path u = if U.substring u 9 3 = "%3A" then - U.format2 "%s:%s" (U.substring u 8 1) (U.substring_from u 12) - else U.substring_from u 7 -let path_to_uri u = if U.char_at u 1 = ':' then - let rest = U.replace_char (U.substring_from u 2) '\\' '/' in - U.format2 "file:///%s%3A%s" (U.substring u 0 1) rest - else U.format1 "file://%s" u - -let js_compl_context : json -> completion_context = function - | JsonAssoc a -> - { trigger_kind = assoc "triggerKind" a |> js_int; - trigger_char = try_assoc "triggerChar" a |> U.map_option js_str; } - | other -> js_fail "dictionary" other - -// May throw -let js_txdoc_item : json -> txdoc_item = function - | JsonAssoc a -> - let arg k = assoc k a in - { fname = uri_to_path (arg "uri" |> js_str); - langId = arg "languageId" |> js_str; - version = arg "version" |> js_int; - text = arg "text" |> js_str } - | other -> js_fail "dictionary" other - -// May throw, argument is of the form { "textDocument" : {"uri" : ... } } -let js_txdoc_id (r: list (string & json)) : string = - uri_to_path (assoc "uri" (arg "textDocument" r |> js_assoc) |> js_str) - -// May throw; argument is of the form { "textDocument" : ..., -// "position" : { "line" : ..., "character" : ... } } -let js_txdoc_pos (r: list (string & json)) : txdoc_pos = - let pos = arg "position" r |> js_assoc in - { path = js_txdoc_id r; - line = assoc "line" pos |> js_int; - col = assoc "character" pos |> js_int } - -// May throw -let js_wsch_event : json -> wsch_event = function - | JsonAssoc a -> - let added' = assoc "added" a |> js_assoc in - let removed' = assoc "removed" a |> js_assoc in - { added = { wk_uri = assoc "uri" added' |> js_str; - wk_name = assoc "name" added' |> js_str }; - removed = { wk_uri = assoc "uri" removed' |> js_str; - wk_name = assoc "name" removed' |> js_str } } - | other -> js_fail "dictionary" other - -// May throw -let js_contentch : json -> string = function - // List will have one item, and List.hd is guaranteed to work, - // since we've specified that full text should be sent on change - // in the capabilities - | JsonList l -> List.hd (List.map (fun (JsonAssoc a) -> assoc "text" a |> js_str) l) - | other -> js_fail "dictionary" other - -type rng = { rng_start: int & int; rng_end: int & int } - -// May throw -let js_rng : json -> rng = function - | JsonAssoc a -> - let st = assoc "start" a in - let fin = assoc "end" a in - let l = assoc "line" in - let c = assoc "character" in - { rng_start = l (st |> js_assoc) |> js_int, c (st |> js_assoc) |> js_int; - rng_end = l (fin |> js_assoc) |> js_int, c (st |> js_assoc) |> js_int } - | other -> js_fail "dictionary" other - -let errorcode_to_int : error_code -> int = function -| ParseError -> -32700 -| InvalidRequest -> -32600 -| MethodNotFound -> -32601 -| InvalidParams -> -32602 -| InternalError -> -32603 -| ServerErrorStart -> -32099 -| ServerErrorEnd -> -32000 -| ServerNotInitialized -> -32002 -| UnknownErrorCode -> -32001 -| RequestCancelled -> -32800 -| ContentModified -> -32801 - -let json_debug = function - | JsonNull -> "null" - | JsonBool b -> U.format1 "bool (%s)" (if b then "true" else "false") - | JsonInt i -> U.format1 "int (%s)" (U.string_of_int i) - | JsonStr s -> U.format1 "string (%s)" s - | JsonList _ -> "list (...)" - | JsonAssoc _ -> "dictionary (...)" - -// The IDE uses a slightly different variant (wrap_js_failure) -// because types differ (query' versus lsp_query) -let wrap_jsfail (qid : option int) expected got : lsp_query = - { query_id = qid; - q = BadProtocolMsg (U.format2 "JSON decoding failed: expected %s, got %s" - expected (json_debug got)) } - -(* Helpers for constructing the response *) - -// Trivial helpers -let resultResponse (r: json) : option assoct = Some [("result", r)] -let errorResponse (r: json) : option assoct = Some [("error", r)] - -// When a response is expected, but we have nothing to say (used for unimplemented bits as well) -let nullResponse : option assoct = resultResponse JsonNull - -let json_of_response (qid: option int) (response: assoct) : json = - match qid with - | Some i -> JsonAssoc ([("jsonrpc", JsonStr "2.0"); ("id", JsonInt i)] @ response) - // In the case of a notification response, there is no query_id associated - | None -> JsonAssoc ([("jsonrpc", JsonStr "2.0")] @ response) - -let js_resperr (err: error_code) (msg: string) : json = - JsonAssoc [("code", JsonInt (errorcode_to_int err)); ("message", JsonStr msg)] - -let wrap_content_szerr (m: string): lsp_query = { query_id = None; q = BadProtocolMsg m } - -let js_servcap : json = - JsonAssoc [("capabilities", - // Open, close, change, and save events will happen with full text sent; - // change is required for auto-completions - JsonAssoc [("textDocumentSync", JsonAssoc [ - ("openClose", JsonBool true); - ("change", JsonInt 1); - ("willSave", JsonBool false); - ("willSaveWaitUntil", JsonBool false); - ("save", JsonAssoc [("includeText", JsonBool true)])]); - ("hoverProvider", JsonBool true); - ("completionProvider", JsonAssoc []); - ("signatureHelpProvider", JsonAssoc []); - ("definitionProvider", JsonBool true); - ("typeDefinitionProvider", JsonBool false); - ("implementationProvider", JsonBool false); - ("referencesProvider", JsonBool false); - ("documentSymbolProvider", JsonBool false); - ("workspaceSymbolProvider", JsonBool false); - ("codeActionProvider", JsonBool false)])] - -// LSP uses zero-indexed line numbers while the F* typechecker uses 1-indexed ones; -// column numbers are zero-indexed in both -let js_pos (p: pos) : json = JsonAssoc [("line", JsonInt (line_of_pos p - 1)); - ("character", JsonInt (col_of_pos p))] - -let js_range (r: Range.range) : json = - JsonAssoc [("start", js_pos (start_of_range r)); ("end", js_pos (end_of_range r))] - -// Used to report diagnostic, for example, when loading dependencies fails -let js_dummyrange : json = - JsonAssoc [("start", JsonAssoc [("line", JsonInt 0); ("character", JsonInt 0); - ("end", JsonAssoc [("line", JsonInt 0); ("character", JsonInt 0)])])] - -let js_loclink (r: Range.range) : json = - let s = js_range r in - JsonList [JsonAssoc [("targetUri", JsonStr (path_to_uri (file_of_range r))); - ("targetRange", s); ("targetSelectionRange", s)]] - -// Lines are 0-indexed in LSP, but 1-indexed in the F* Typechecker; -let pos_munge (pos: txdoc_pos) = (pos.path, pos.line + 1, pos.col) - -let js_diag (fname: string) (msg: string) (r: option Range.range) : assoct = - let r' = match r with - | Some r -> js_range r - | None -> js_dummyrange in - // Unfortunately, the F* typechecker aborts on the very first diagnostic - let ds = ("diagnostics", JsonList [JsonAssoc [("range", r'); ("message", JsonStr msg)]]) in - [("method", JsonStr "textDocument/publishDiagnostics"); - ("params", JsonAssoc [("uri", JsonStr (path_to_uri fname)); ds])] - -let js_diag_clear (fname: string) : assoct = - [("method", JsonStr "textDocument/publishDiagnostics"); - ("params", JsonAssoc [("uri", JsonStr (path_to_uri fname)); ("diagnostics", JsonList [])])] - diff --git a/src/fstar/FStar.Interactive.JsonHelper.fsti b/src/fstar/FStar.Interactive.JsonHelper.fsti deleted file mode 100644 index 3d414bc81cd..00000000000 --- a/src/fstar/FStar.Interactive.JsonHelper.fsti +++ /dev/null @@ -1,167 +0,0 @@ -(* - Copyright 2019 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -(* Json helpers mainly for FStar.Interactive.Lsp; some sharing with * - * FStar.Interactive.Ide *) - -module FStar.Interactive.JsonHelper -open FStar -open FStar.Compiler -open FStar.Errors -open FStar.Json -open FStar.Compiler.Util - -// Type of an associative array -type assoct = list (string & json) - -val try_assoc : string -> assoct -> option json // nothrow -val assoc : string -> assoct -> json // throw - -// All exceptions are guaranteed to be caught in the LSP server implementation -exception MissingKey of string // Only in LSP -exception InvalidQuery of string // Only in IDE -exception UnexpectedJsonType of string & json -exception MalformedHeader -exception InputExhausted - -val write_json : json -> unit // Only used in IDE -val write_jsonrpc : json -> unit // Only used in LSP -val js_fail : string -> json -> 'a - -val js_int : json -> int -val js_bool : json -> bool -val js_str : json -> string -val js_list : (json -> 'a) -> json -> list 'a -val js_assoc : json -> assoct -val js_str_int : json -> int - -val arg : string -> assoct -> json -val uri_to_path : string -> string - -type completion_context = { trigger_kind: int; trigger_char: option string } -val js_compl_context : json -> completion_context - -type txdoc_item = { fname: string; langId: string; version: int; text: string } -val js_txdoc_item : json -> txdoc_item - -type txdoc_pos = { path: string; line: int; col: int } -val js_txdoc_id : assoct -> string -val js_txdoc_pos : assoct -> txdoc_pos - -type workspace_folder = { wk_uri: string; wk_name: string } -type wsch_event = { added: workspace_folder; removed: workspace_folder } -val js_wsch_event : json -> wsch_event -val js_contentch : json -> string - -type lquery = -| Initialize of int & string -| Initialized -| Shutdown -| Exit -| Cancel of int -| FolderChange of wsch_event -| ChangeConfig -| ChangeWatch -| Symbol of string -| ExecCommand of string -| DidOpen of txdoc_item -| DidChange of string & string -| WillSave of string -| WillSaveWait of string -| DidSave of string & string -| DidClose of string -| Completion of txdoc_pos & completion_context -| Resolve -| Hover of txdoc_pos -| SignatureHelp of txdoc_pos -| Declaration of txdoc_pos -| Definition of txdoc_pos -| TypeDefinition of txdoc_pos -| Implementation of txdoc_pos -| References -| DocumentHighlight of txdoc_pos -| DocumentSymbol -| CodeAction -| CodeLens -| CodeLensResolve -| DocumentLink -| DocumentLinkResolve -| DocumentColor -| ColorPresentation -| Formatting -| RangeFormatting -| TypeFormatting -| Rename -| PrepareRename of txdoc_pos -| FoldingRange -| BadProtocolMsg of string - -type lsp_query = { query_id: option int; q: lquery } - - -type error_code = -| ParseError -| InvalidRequest -| MethodNotFound -| InvalidParams -| InternalError -| ServerErrorStart -| ServerErrorEnd -| ServerNotInitialized -| UnknownErrorCode -| RequestCancelled -| ContentModified - -// A lookup table for pretty-printing error codes -val errorcode_to_int : error_code -> int - -// Another lookup table for pretty-printing JSON objects -val json_debug : json -> string - -// Wrap an error-code along with a description of the error in a BadProtocolMsg -val wrap_jsfail : option int -> string -> json -> lsp_query - -(* Helpers for constructing the response *) - -// Used by run_query heavily -val resultResponse : json -> option assoct -val errorResponse : json -> option assoct -val nullResponse : option assoct - -// Build JSON of a given response -val json_of_response : option int -> assoct -> json - -// Given an error_code and a string describing the error, build a JSON error -val js_resperr : error_code -> string -> json - -// Build an error corresponding to BadProtocolMsg -val wrap_content_szerr : string -> lsp_query - -// Report on server capabilities -val js_servcap : json - -// Create a JSON location link from a Range.range -val js_loclink : Range.range -> json - -// Convert txdoc_pos into (filename, line, col) -val pos_munge : txdoc_pos -> string & int & int - -// Build a JSON diagnostic -val js_diag : string -> string -> option Range.range -> assoct - -// Build an empty JSON diagnostic; used for clearing diagnostic -val js_diag_clear : string -> assoct - diff --git a/src/fstar/FStar.Interactive.Legacy.fst b/src/fstar/FStar.Interactive.Legacy.fst deleted file mode 100644 index ad9524645db..00000000000 --- a/src/fstar/FStar.Interactive.Legacy.fst +++ /dev/null @@ -1,581 +0,0 @@ -(* - Copyright 2008-2016 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Interactive.Legacy -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.Compiler.Util -open FStar.Getopt -open FStar.Ident - -open FStar.Universal -open FStar.TypeChecker.Env -open FStar.Parser - -module DsEnv = FStar.Syntax.DsEnv -module TcEnv = FStar.TypeChecker.Env - -// A custom version of the function that's in FStar.Universal.fs just for the -// sake of the interactive mode -let tc_one_file (remaining:list string) (env:TcEnv.env) = //:((string option * string) * uenv * string list) = - let (intf, impl), env, remaining = - match remaining with - | intf :: impl :: remaining when needs_interleaving intf impl -> - let _, env = tc_one_file_for_ide env (Some intf) impl Dep.empty_parsing_data in - (Some intf, impl), env, remaining - | intf_or_impl :: remaining -> - let _, env = tc_one_file_for_ide env None intf_or_impl Dep.empty_parsing_data in - (None, intf_or_impl), env, remaining - | [] -> failwith "Impossible" - in - (intf, impl), env, remaining - -// The interactive mode has its own notion of a stack that is super flaky, -// seeing that there's a lot of mutable state under the hood. This is most -// likely not working as the original author intended it to. - -type env_t = TcEnv.env -type modul_t = option Syntax.Syntax.modul -type stack_t = list (env_t & modul_t) - -// Note: many of these functions are passing env around just for the sake of -// providing a link to the solver (to avoid a cross-project dependency). They're -// not actually doing anything useful with the environment you're passing it (e.g. -// pop). - -let pop env msg = - ignore (TypeChecker.Tc.pop_context env msg); - Options.pop() - -let push_with_kind env lax restore_cmd_line_options msg = - let env = { env with admit = lax } in - let res = TypeChecker.Tc.push_context env msg in - Options.push(); - if restore_cmd_line_options then Options.restore_cmd_line_options false |> ignore; - res - -let check_frag (env:TcEnv.env) curmod frag = - try - let m, env, _ = tc_one_fragment curmod env (Inl frag) in - Some (m, env, FStar.Errors.get_err_count()) - with - | FStar.Errors.Error(e, msg, r, ctx) when not ((Options.trace_error())) -> - FStar.TypeChecker.Err.add_errors env [(e, msg, r, ctx)]; - None - -let report_fail () = - FStar.Errors.report_all() |> ignore; - FStar.Errors.clear() - -(******************************************************************************************) -(* The interface expected to be provided by a type-checker to run in the interactive loop *) -(******************************************************************************************) - - -(****************************************************************************************) -(* Internal data structures for managing chunks of input from the editor *) -(****************************************************************************************) -type input_chunks = - | Push of bool & int & int //the bool flag indicates lax flag set from the editor - | Pop of string - | Code of string & (string & string) - | Info of string & bool & option (string & int & int) - | Completions of string - - -type interactive_state = { - // The current chunk -- chunks end on #end boundaries per the communication - // protocol. - chunk: string_builder; - stdin: ref (option stream_reader); // Initialized once. - // A list of chunks read so far - buffer: ref (list input_chunks); - log: ref (option out_channel); -} - - -let the_interactive_state = { - chunk = Util.new_string_builder (); - stdin = mk_ref None; - buffer = mk_ref []; - log = mk_ref None -} - -(***********************************************************************) -(* Reading some input *) -(***********************************************************************) -let rec read_chunk () = - let s = the_interactive_state in - let log : string -> unit = - if Debug.any() then - let transcript = - match !s.log with - | Some transcript -> transcript - | None -> - let transcript = Util.open_file_for_writing "transcript" in - s.log := Some transcript; - transcript - in - fun line -> - Util.append_to_file transcript line; - Util.flush transcript - else - fun _ -> () - in - let stdin = - match !s.stdin with - | Some i -> i - | None -> - let i = Util.open_stdin () in - s.stdin := Some i; - i - in - let line = - match Util.read_line stdin with - | None -> exit 0 - | Some l -> l - in - log line; - - let l = Util.trim_string line in - if Util.starts_with l "#end" then begin - let responses = - match Util.split l " " with - | [_; ok; fail] -> (ok, fail) - | _ -> ("ok", "fail") in - let str = Util.string_of_string_builder s.chunk in - Util.clear_string_builder s.chunk; Code (str, responses) - end - else if Util.starts_with l "#pop" then (Util.clear_string_builder s.chunk; Pop l) - else if Util.starts_with l "#push" then ( - Util.clear_string_builder s.chunk; - let lc_lax = Util.trim_string (Util.substring_from l (String.length "#push")) in - let lc = match Util.split lc_lax " " with - | [l; c; "#lax"] -> true, Util.int_of_string l, Util.int_of_string c - | [l; c] -> false, Util.int_of_string l, Util.int_of_string c - | _ -> - Errors.log_issue0 Errors.Warning_WrongErrorLocation ("Error locations may be wrong, unrecognized string after #push: " ^ lc_lax); - false, 1, 0 - in - Push lc) - else if Util.starts_with l "#info " then - match Util.split l " " with - | [_; symbol] -> - Util.clear_string_builder s.chunk; - Info (symbol, true, None) - | [_; symbol; file; row; col] -> - Util.clear_string_builder s.chunk; - Info (symbol, false, Some (file, Util.int_of_string row, Util.int_of_string col)) - | _ -> - Errors.log_issue0 Errors.Error_IDEUnrecognized ("Unrecognized \"#info\" request: " ^ l); - exit 1 - else if Util.starts_with l "#completions " then - match Util.split l " " with - | [_; prefix; "#"] -> // Extra "#" marks the end of the input. FIXME protocol could take more structured messages. - Util.clear_string_builder s.chunk; - Completions (prefix) - | _ -> - Errors.log_issue0 Errors.Error_IDEUnrecognized ("Unrecognized \"#completions\" request: " ^ l); - exit 1 - else if l = "#finish" then exit 0 - else - (Util.string_builder_append s.chunk line; - Util.string_builder_append s.chunk "\n"; - read_chunk()) - -let shift_chunk () = - let s = the_interactive_state in - match !s.buffer with - | [] -> read_chunk () - | chunk :: chunks -> - s.buffer := chunks; - chunk - -let fill_buffer () = - let s = the_interactive_state in - s.buffer := !s.buffer @ [ read_chunk () ] - - -(******************************************************************************************) -(* The main interactive loop *) -(******************************************************************************************) -open FStar.Parser.ParseIt - -let deps_of_our_file filename = - (* Now that fstar-mode.el passes the name of the current file, we must parse - * and lax-check everything but the current module we're editing. This - * function may, optionally, return an interface if the currently edited - * module is an implementation and an interface was found. *) - let deps, dep_graph = FStar.Dependencies.find_deps_if_needed [ filename ] FStar.CheckedFiles.load_parsing_data_from_cache in - let deps, same_name = List.partition (fun x -> - Parser.Dep.lowercase_module_name x <> Parser.Dep.lowercase_module_name filename - ) deps in - let maybe_intf = match same_name with - | [ intf; impl ] -> - if not (Parser.Dep.is_interface intf) || not (Parser.Dep.is_implementation impl) then - Errors.log_issue0 Errors.Warning_MissingInterfaceOrImplementation (Util.format2 "Found %s and %s but not an interface + implementation" intf impl); - Some intf - | [ impl ] -> - None - | _ -> - Errors.log_issue0 Errors.Warning_UnexpectedFile (Util.format1 "Unexpected: ended up with %s" (String.concat " " same_name)); - None - in - deps, maybe_intf, dep_graph - -(* .fsti name (optional) * .fst name * .fsti recorded timestamp (optional) * .fst recorded timestamp *) -type m_timestamps = list (option string & string & option time & time) - -(* - * type check remaining dependencies and record the timestamps. - * m is the current module name, not the module name of the dependency. it's actually a dummy that is pushed on the stack and never used. - * it is used for type checking the fragments of the current module, but for dependencies it is a dummy. - * adding it as the stack entry needed it. - * env is the environment in which next dependency should be type checked. - * the returned timestamps are in the reverse order (i.e. final dependency first), it's the same order as the stack. - * note that for dependencies, the stack and ts go together (i.e. their sizes are same) - * returns the new stack, environment, and timestamps. - *) -let rec tc_deps (m:modul_t) (stack:stack_t) - (env:TcEnv.env) (remaining:list string) (ts:m_timestamps) -// : stack 'env,modul_t * 'env * m_timestamps - = match remaining with - | [] -> stack, env, ts - | _ -> - let stack = (env, m)::stack in - //setting the restore command line options flag true - let env = push_with_kind env (Options.lax ()) true "typecheck_modul" in - let (intf, impl), env, remaining = tc_one_file remaining env in - let intf_t, impl_t = - let intf_t = - match intf with - | Some intf -> Some (get_file_last_modification_time intf) - | None -> None - in - let impl_t = get_file_last_modification_time impl in - intf_t, impl_t - in - tc_deps m stack env remaining ((intf, impl, intf_t, impl_t)::ts) - - -(* - * check if some dependencies have been modified, added, or deleted - * if so, only type check them and anything that follows, while maintaining others as is (current dependency graph is a total order) - * we will first compute the dependencies again, and then traverse the ts list - * if we find that the dependency at the head of ts does not match that at the head of the newly computed dependency, - * or that the dependency is stale, we will typecheck that dependency, and everything that comes after that again - * the stack and timestamps are passed in "last dependency first" order, so we will reverse them before checking - * as with tc_deps, m is the dummy argument used for the stack entry - * returns the new stack, environment, and timestamps - *) -let update_deps (filename:string) (m:modul_t) (stk:stack_t) (env:env_t) (ts:m_timestamps) - : (stack_t & env_t & m_timestamps) = - let is_stale (intf:option string) (impl:string) (intf_t:option time) (impl_t:time) :bool = - let impl_mt = get_file_last_modification_time impl in - (is_before impl_t impl_mt || - (match intf, intf_t with - | Some intf, Some intf_t -> - let intf_mt = get_file_last_modification_time intf in - is_before intf_t intf_mt - | None, None -> false - | _, _ -> failwith "Impossible, if the interface is None, the timestamp entry should also be None")) - in - - (* - * iterate over the timestamps list - * if the current entry matches the head of the deps, and is not stale, then leave it as is, and go to next, else discard everything after that and tc_deps the deps again - * good_stack and good_ts are stack and timestamps that are not stale so far - * st and ts are expected to be in "first dependency first order" - * also, for the first call to iterate, good_stack and good_ts are empty - * during recursive calls, the good_stack and good_ts grow "last dependency first" order. - * returns the new stack, environment, and timestamps - *) - let rec iterate (depnames:list string) (st:stack_t) (env':env_t) - (ts:m_timestamps) (good_stack:stack_t) (good_ts:m_timestamps) = //:(stack 'env, modul_t * 'env * m_timestamps) = - //invariant length good_stack = length good_ts, and same for stack and ts - - let match_dep (depnames:list string) (intf:option string) (impl:string) : (bool & list string) = - match intf with - | None -> - (match depnames with - | dep::depnames' -> if dep = impl then true, depnames' else false, depnames - | _ -> false, depnames) - | Some intf -> - (match depnames with - | depintf::dep::depnames' -> if depintf = intf && dep = impl then true, depnames' else false, depnames - | _ -> false, depnames) - in - - //expected the stack to be in "last dependency first order", we want to pop in the proper order (although should not matter) - let rec pop_tc_and_stack (env:env_t) (stack:list (env_t & modul_t)) ts = - match ts with - | [] -> (* stack should also be empty here *) env - | _::ts -> - //pop - pop env ""; - let (env, _), stack = List.hd stack, List.tl stack in - pop_tc_and_stack env stack ts - in - - match ts with - | ts_elt::ts' -> - let intf, impl, intf_t, impl_t = ts_elt in - let b, depnames' = match_dep depnames intf impl in - if not b || (is_stale intf impl intf_t impl_t) then - //reverse st from "first dependency first order" to "last dependency first order" - let env = pop_tc_and_stack env' (List.rev_append st []) ts in - tc_deps m good_stack env depnames good_ts - else - let stack_elt, st' = List.hd st, List.tl st in - iterate depnames' st' env' ts' (stack_elt::good_stack) (ts_elt::good_ts) - | [] -> (* st should also be empty here *) tc_deps m good_stack env' depnames good_ts - in - - (* Well, the file list hasn't changed, so our (single) file is still there. *) - let filenames, _, dep_graph = deps_of_our_file filename in - //reverse stk and ts, since iterate expects them in "first dependency first order" - iterate filenames (List.rev_append stk []) env (List.rev_append ts []) [] [] - -let format_info env name typ range (doc: option string) = - Util.format4 "(defined at %s) %s: %s%s" - (Range.string_of_range range) - name - (FStar.TypeChecker.Normalize.term_to_string env typ) - (match doc with - | Some docstring -> Util.format1 "#doc %s" docstring - | None -> "") - -let rec go (line_col:(int&int)) - (filename:string) - (stack:stack_t) (curmod:modul_t) (env:env_t) (ts:m_timestamps) : unit = begin - match shift_chunk () with - | Info(symbol, fqn_only, pos_opt) -> - let info_at_pos_opt = match pos_opt with - | None -> None - | Some (file, row, col) -> FStar.TypeChecker.Err.info_at_pos env file row col in - let info_opt = match info_at_pos_opt with - | Some _ -> info_at_pos_opt - | None -> // Use name lookup as a fallback - if symbol = "" then None - else let lid = Ident.lid_of_ids (List.map Ident.id_of_text (Util.split symbol ".")) in - let lid = if fqn_only then lid - else match DsEnv.resolve_to_fully_qualified_name env.dsenv lid with - | None -> lid - | Some lid -> lid in - try_lookup_lid env lid - |> Util.map_option (fun ((_, typ), r) -> (Inr lid, typ, r)) in - (match info_opt with - | None -> Util.print_string "\n#done-nok\n" - | Some (name_or_lid, typ, rng) -> - let name, doc = - match name_or_lid with - | Inl name -> name, None - | Inr lid -> Ident.string_of_lid lid, None in - Util.print1 "%s\n#done-ok\n" (format_info env name typ rng doc)); - go line_col filename stack curmod env ts - | Completions search_term -> - //search_term is the partially written identifer by the user - // FIXME a regular expression might be faster than this explicit matching - let rec measure_anchored_match - : list string -> list ident -> option (list ident & int) - //determines it the candidate may match the search term - //and, if so, provides an integer measure of the degree of the match - //Q: isn't the output list ident always the same as the candidate? - // About the degree of the match, cpitclaudel says: - // Because we're measuring the length of the match and we allow partial - // matches. Say we're matching FS.Li.app against FStar.Compiler.List.Append. Then - // the length we want is (length "FStar" + 1 + length "List" + 1 + length - // "app"), not (length "FStar" + 1 + length "List" + 1 + length - // "append"). This length is used to know how much of the candidate to - // highlight in the company-mode popup (we want to display the candidate - // as FStar.Compiler.List.append. - = fun search_term candidate -> - match search_term, candidate with - | [], _ -> Some ([], 0) - | _, [] -> None - | hs :: ts, hc :: tc -> - let hc_text = FStar.Ident.string_of_id hc in - if Util.starts_with hc_text hs then - match ts with - | [] -> Some (candidate, String.length hs) - | _ -> measure_anchored_match ts tc |> - Util.map_option (fun (matched, len) -> (hc :: matched, String.length hc_text + 1 + len)) - else None in - let rec locate_match - : list string -> list ident -> option (list ident & list ident & int) - = fun needle candidate -> - match measure_anchored_match needle candidate with - | Some (matched, n) -> Some ([], matched, n) - | None -> - match candidate with - | [] -> None - | hc :: tc -> - locate_match needle tc |> - Util.map_option (fun (prefix, matched, len) -> (hc :: prefix, matched, len)) in - let str_of_ids ids = Util.concat_l "." (List.map FStar.Ident.string_of_id ids) in - let match_lident_against needle lident = - locate_match needle (ns_of_lid lident @ [ident_of_lid lident]) - in - let shorten_namespace (prefix, matched, match_len) = - let naked_match = match matched with [_] -> true | _ -> false in - let stripped_ns, shortened = Syntax.DsEnv.shorten_module_path env.dsenv prefix naked_match in - (str_of_ids shortened, str_of_ids matched, str_of_ids stripped_ns, match_len) in - let prepare_candidate (prefix, matched, stripped_ns, match_len) = - if prefix = "" then - (matched, stripped_ns, match_len) - else - (prefix ^ "." ^ matched, stripped_ns, String.length prefix + match_len + 1) in - let needle = Util.split search_term "." in - let all_lidents_in_env = FStar.TypeChecker.Env.lidents env in - let matches = - //There are two cases here: - //Either the needle is of the form: - // (a) A.x where A resolves to the module L.M.N - //or (b) the needle's namespace is not a well-formed module. - //In case (a), we go to the desugaring to find the names - // transitively exported by L.M.N - //In case (b), we find all lidents in the type-checking environment - // and rank them by potential matches to the needle - let case_a_find_transitive_includes (orig_ns:list string) (m:lident) (id:string) - : list (list ident & list ident & int) - = - let exported_names = DsEnv.transitive_exported_ids env.dsenv m in - let matched_length = - List.fold_left - (fun out s -> String.length s + out + 1) - (String.length id) - orig_ns - in - exported_names |> - List.filter_map (fun n -> - if Util.starts_with n id - then let lid = Ident.lid_of_ns_and_id (Ident.ids_of_lid m) (Ident.id_of_text n) in - Option.map (fun fqn -> [], (List.map Ident.id_of_text orig_ns)@[ident_of_lid fqn], matched_length) - (DsEnv.resolve_to_fully_qualified_name env.dsenv lid) - else None) - in - let case_b_find_matches_in_env () - : list (list ident & list ident & int) - = let matches = List.filter_map (match_lident_against needle) all_lidents_in_env in - //Retain only the ones that can be resolved that are resolvable to themselves in dsenv - matches |> List.filter (fun (ns, id, _) -> - match DsEnv.resolve_to_fully_qualified_name env.dsenv (Ident.lid_of_ids id) with - | None -> false - | Some l -> Ident.lid_equals l (Ident.lid_of_ids (ns@id))) - in - let ns, id = Util.prefix needle in - let matched_ids = - match ns with - | [] -> case_b_find_matches_in_env () - | _ -> - let l = Ident.lid_of_path ns Range.dummyRange in - match FStar.Syntax.DsEnv.resolve_module_name env.dsenv l true with - | None -> - case_b_find_matches_in_env () - | Some m -> - case_a_find_transitive_includes ns m id - in - matched_ids |> - List.map (fun x -> prepare_candidate (shorten_namespace x)) - in - List.iter (fun (candidate, ns, match_len) -> - Util.print3 "%s %s %s \n" - (Util.string_of_int match_len) ns candidate) - (Util.sort_with (fun (cd1, ns1, _) (cd2, ns2, _) -> - match String.compare cd1 cd2 with - | 0 -> String.compare ns1 ns2 - | n -> n) - matches); - Util.print_string "#done-ok\n"; - go line_col filename stack curmod env ts - | Pop msg -> - // This shrinks all internal stacks by 1 - pop env msg; - let (env, curmod), stack = - match stack with - | [] -> Errors.log_issue0 Errors.Error_IDETooManyPops "Too many pops"; exit 1 - | hd::tl -> hd, tl - in - go line_col filename stack curmod env ts - - | Push (lax, l, c) -> - // This grows all internal stacks by 1 - //if we are at a stage where we have not yet pushed a fragment from the current buffer, see if some dependency is stale - //if so, update it - //also if this is the first chunk, we need to restore the command line options - let restore_cmd_line_options, (stack, env, ts) = - if List.length stack = List.length ts then true, update_deps filename curmod stack env ts else false, (stack, env, ts) - in - let stack = (env, curmod)::stack in - let env = push_with_kind env lax restore_cmd_line_options "#push" in - go (l, c) filename stack curmod env ts - - | Code (text, (ok, fail)) -> - // This does not grow any of the internal stacks. - let fail curmod tcenv = - report_fail(); - Util.print1 "%s\n" fail; - // The interactive mode will send a pop here - go line_col filename stack curmod tcenv ts - in - - let frag = {frag_fname=" input"; - frag_text=text; - frag_line=fst line_col; - frag_col=snd line_col} in - let res = check_frag env curmod (frag,[]) in begin - match res with - | Some (curmod, env, n_errs) -> - if n_errs=0 then begin - Util.print1 "\n%s\n" ok; - go line_col filename stack curmod env ts - end - else fail curmod env - | _ -> fail curmod env - end -end - -// filename is the name of the file currently edited -let interactive_mode (filename:string): unit = - - if Option.isSome (Options.codegen()) then - Errors.log_issue0 Errors.Warning_IDEIgnoreCodeGen "Code-generation is not supported in interactive mode, ignoring the codegen flag"; - - //type check prims and the dependencies - let filenames, maybe_intf, dep_graph = deps_of_our_file filename in - let env = init_env dep_graph in - let stack, env, ts = tc_deps None [] env filenames [] in - let initial_range = Range.mk_range filename (Range.mk_pos 1 0) (Range.mk_pos 1 0) in - let env = FStar.TypeChecker.Env.set_range env initial_range in - let env = - match maybe_intf with - | Some intf -> - // We found an interface: record its contents in the desugaring environment - // to be interleaved with the module implementation on-demand - FStar.Universal.load_interface_decls env intf - | None -> - env - in - - if FStar.Options.record_hints() //and if we're recording or using hints - || FStar.Options.use_hints() - then FStar.SMTEncoding.Solver.with_hints_db - (List.hd (Options.file_list ())) - (fun () -> go (1, 0) filename stack None env ts) - else go (1, 0) filename stack None env ts diff --git a/src/fstar/FStar.Interactive.Lsp.fst b/src/fstar/FStar.Interactive.Lsp.fst deleted file mode 100644 index a08156fe674..00000000000 --- a/src/fstar/FStar.Interactive.Lsp.fst +++ /dev/null @@ -1,238 +0,0 @@ -(* - Copyright 2019 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Interactive.Lsp - -open FStar -open FStar.Compiler -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.Util -open FStar.Compiler.Range -open FStar.Errors -open FStar.Universal -open FStar.Interactive.Ide.Types -open FStar.Interactive.JsonHelper - -module U = FStar.Compiler.Util -module QH = FStar.Interactive.QueryHelper -module PH = FStar.Interactive.PushHelper -module PI = FStar.Parser.ParseIt -module TcEnv = FStar.TypeChecker.Env - -(* Request *) - -// nothrow -let unpack_lsp_query (r : list (string & json)) : lsp_query = - let qid = try_assoc "id" r |> U.map_option js_str_int in // noexcept - - // If we make it this far, exceptions will come with qid info. - // Wrap in `try` because all `js_*` functions and `assoc` throw - try - let method = assoc "method" r |> js_str in - { query_id = qid; - q = match method with - | "initialize" -> Initialize (arg "processId" r |> js_int, - arg "rootUri" r |> js_str) - | "initialized" -> Initialized - | "shutdown" -> Shutdown - | "exit" -> Exit - | "$/cancelRequest" -> Cancel (arg "id" r |> js_str_int) - | "workspace/didChangeWorkspaceFolders" -> FolderChange - (arg "event" r |> js_wsch_event) - | "workspace/didChangeConfiguration" -> ChangeConfig - | "workspace/didChangeWatchedFiles" -> ChangeWatch - | "workspace/symbol" -> Symbol (arg "query" r |> js_str) - | "workspace/executeCommand" -> ExecCommand - (arg "command" r |> js_str) - | "textDocument/didOpen" -> DidOpen (arg "textDocument" r |> js_txdoc_item) - | "textDocument/didChange" -> DidChange (js_txdoc_id r, - arg "contentChanges" r |> js_contentch) - | "textDocument/willSave" -> WillSave (js_txdoc_id r) - | "textDocument/willSaveWaitUntil" -> WillSaveWait (js_txdoc_id r) - | "textDocument/didSave" -> DidSave (js_txdoc_id r, arg "text" r |> js_str) - | "textDocument/didClose" -> DidClose (js_txdoc_id r) - | "textDocument/completion" -> Completion (js_txdoc_pos r, - arg "context" r |> js_compl_context) - | "completionItem/resolve" -> Resolve - | "textDocument/hover" -> Hover (js_txdoc_pos r) - | "textDocument/signatureHelp" -> SignatureHelp (js_txdoc_pos r) - | "textDocument/declaration" -> Declaration (js_txdoc_pos r) - | "textDocument/definition" -> Definition (js_txdoc_pos r) - | "textDocument/typeDefinition" -> TypeDefinition (js_txdoc_pos r) - | "textDocument/implementation" -> Implementation (js_txdoc_pos r) - | "textDocument/references" -> References - | "textDocument/documentHighlight" -> DocumentHighlight (js_txdoc_pos r) - | "textDocument/documentSymbol" -> DocumentSymbol - | "textDocument/codeAction" -> CodeAction - | "textDocument/codeLens" -> CodeLens - | "codeLens/resolve" -> CodeLensResolve - | "textDocument/documentLink" -> DocumentLink - | "documentLink/resolve" -> DocumentLinkResolve - | "textDocument/documentColor" -> DocumentColor - | "textDocument/colorPresentation" -> ColorPresentation - | "textDocument/formatting" -> Formatting - | "textDocument/rangeFormatting" -> RangeFormatting - | "textDocument/onTypeFormatting" -> TypeFormatting - | "textDocument/rename" -> Rename - | "textDocument/prepareRename" -> PrepareRename (js_txdoc_pos r) - | "textDocument/foldingRange" -> FoldingRange - | m -> BadProtocolMsg (U.format1 "Unknown method '%s'" m) } - with - | MissingKey msg -> { query_id = qid; q = BadProtocolMsg msg } - | UnexpectedJsonType (expected, got) -> wrap_jsfail qid expected got - -let deserialize_lsp_query js_query : lsp_query = - try - unpack_lsp_query (js_query |> js_assoc) - with - // This is the only excpetion that js_assoc is allowed to throw - | UnexpectedJsonType (expected, got) -> wrap_jsfail None expected got - -let parse_lsp_query query_str : lsp_query = - if false then U.print1_error ">>> %s\n" query_str; - match json_of_string query_str with - | None -> { query_id = None; q = BadProtocolMsg "Json parsing failed" } - | Some request -> deserialize_lsp_query request - -(* Repl and response *) - -let repl_state_init (fname: string) : repl_state = - let intial_range = Range.mk_range fname (Range.mk_pos 1 0) (Range.mk_pos 1 0) in - let env = init_env FStar.Parser.Dep.empty_deps in - let env = TcEnv.set_range env intial_range in - { repl_line = 1; - repl_column = 0; - repl_fname = fname; - repl_curmod = None; - repl_env = env; - repl_deps_stack = []; - repl_stdin = open_stdin (); - repl_names = CompletionTable.empty; - repl_buffered_input_queries = []; - repl_lang = [] } - -type optresponse = option assoct // Contains [("result", ...)], [("error", ...)], but is not - // the full response; call json_of_response for that -type either_gst_exit = either grepl_state int // grepl_state is independent of exit_code - -let invoke_full_lax (gst: grepl_state) (fname: string) (text: string) (force: bool) - : optresponse & either_gst_exit = - let aux () = - PI.add_vfs_entry fname text; - let diag, st' = PH.full_lax text (repl_state_init fname) in - let repls = U.psmap_add gst.grepl_repls fname st' in - // explicitly clear diags - let diag = if U.is_some diag then diag else Some (js_diag_clear fname) in - diag, Inl ({ gst with grepl_repls = repls }) in - match U.psmap_try_find gst.grepl_repls fname with - | Some _ -> if force then aux () else None, Inl gst - | None -> aux () - -let run_query (gst: grepl_state) (q: lquery) : optresponse & either_gst_exit = - match q with - | Initialize (_, _) -> resultResponse js_servcap, Inl gst - | Initialized -> None, Inl gst - | Shutdown -> nullResponse, Inl gst - | Exit -> None, Inr 0 - | Cancel id -> None, Inl gst - | FolderChange evt -> nullResponse, Inl gst - | ChangeConfig -> nullResponse, Inl gst - | ChangeWatch -> None, Inl gst - | Symbol sym -> nullResponse, Inl gst - | ExecCommand cmd -> nullResponse, Inl gst - | DidOpen { fname = f; langId = _; version = _; text = t } -> invoke_full_lax gst f t false - | DidChange (txid, content) -> PI.add_vfs_entry txid content; None, Inl gst - | WillSave txid -> None, Inl gst - | WillSaveWait txid -> nullResponse, Inl gst - | DidSave (f, t) -> invoke_full_lax gst f t true - | DidClose txid -> None, Inl gst - | Completion (txpos, ctx) -> - (match U.psmap_try_find gst.grepl_repls txpos.path with - | Some st -> QH.complookup st txpos, Inl gst - | None -> nullResponse, Inl gst) - | Resolve -> nullResponse, Inl gst - | Hover txpos -> - (match U.psmap_try_find gst.grepl_repls txpos.path with - | Some st -> QH.hoverlookup st.repl_env txpos, Inl gst - | None -> nullResponse, Inl gst) - | SignatureHelp txpos -> nullResponse, Inl gst - | Declaration txpos -> nullResponse, Inl gst - | Definition txpos -> - (match U.psmap_try_find gst.grepl_repls txpos.path with - | Some st -> QH.deflookup st.repl_env txpos, Inl gst - | None -> nullResponse, Inl gst) - | TypeDefinition txpos -> nullResponse, Inl gst - | Implementation txpos -> nullResponse, Inl gst - | References -> nullResponse, Inl gst - | DocumentHighlight txpos -> nullResponse, Inl gst - | DocumentSymbol -> nullResponse, Inl gst - | CodeAction -> nullResponse, Inl gst - | CodeLens -> nullResponse, Inl gst - | CodeLensResolve -> nullResponse, Inl gst - | DocumentLink -> nullResponse, Inl gst - | DocumentLinkResolve -> nullResponse, Inl gst - | DocumentColor -> nullResponse, Inl gst - | ColorPresentation -> nullResponse, Inl gst - | Formatting -> nullResponse, Inl gst - | RangeFormatting -> nullResponse, Inl gst - | TypeFormatting -> nullResponse, Inl gst - | Rename -> nullResponse, Inl gst - | PrepareRename txpos -> nullResponse, Inl gst - | FoldingRange -> nullResponse, Inl gst - | BadProtocolMsg msg -> errorResponse (js_resperr MethodNotFound msg), Inl gst - -// Raises exceptions, but all of them are caught -let rec parse_header_len (stream: stream_reader) (len: int): int = - // Blocking read - match U.read_line stream with - | Some s -> - if U.starts_with s "Content-Length: " then - match U.safe_int_of_string (U.substring_from s 16) with - | Some new_len -> parse_header_len stream new_len - | None -> raise MalformedHeader - else if U.starts_with s "Content-Type: " then - parse_header_len stream len - else if s = "" then - len - else - raise MalformedHeader - | None -> raise InputExhausted - -let rec read_lsp_query (stream: stream_reader) : lsp_query = - try - let n = parse_header_len stream 0 in - match U.nread stream n with - | Some s -> parse_lsp_query s - | None -> wrap_content_szerr (U.format1 "Could not read %s bytes" (U.string_of_int n)) - with - // At no cost should the server go down - | MalformedHeader -> U.print_error "[E] Malformed Content Header\n"; read_lsp_query stream - | InputExhausted -> read_lsp_query stream - -let rec go (gst: grepl_state) : int = - let query = read_lsp_query gst.grepl_stdin in - let r, state_opt = run_query gst query.q in - (match r with - | Some response -> (let response' = json_of_response query.query_id response in - if false then U.print1_error "<<< %s\n" (string_of_json response'); - write_jsonrpc response') - | None -> ()); // Don't respond - match state_opt with - | Inl gst' -> go gst' - | Inr exitcode -> exitcode - -let start_server () : unit = exit (go ({ grepl_repls = U.psmap_empty (); - grepl_stdin = open_stdin () })) diff --git a/src/fstar/FStar.Interactive.PushHelper.fst b/src/fstar/FStar.Interactive.PushHelper.fst deleted file mode 100644 index 5acce9921c5..00000000000 --- a/src/fstar/FStar.Interactive.PushHelper.fst +++ /dev/null @@ -1,392 +0,0 @@ -(* - Copyright 2019 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -(* FStar.Interactive.Lsp and FStar.Interactive.Ide need to push various * - * text fragments and update state; this file collects helpers for them *) - -module FStar.Interactive.PushHelper -open FStar -open FStar.Compiler -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Compiler.Util -open FStar.Ident -open FStar.Errors -open FStar.Universal -open FStar.Parser.ParseIt -open FStar.TypeChecker.Env -open FStar.Interactive.JsonHelper -open FStar.Interactive.Ide.Types - -module U = FStar.Compiler.Util -module SS = FStar.Syntax.Syntax -module DsEnv = FStar.Syntax.DsEnv -module TcErr = FStar.TypeChecker.Err -module TcEnv = FStar.TypeChecker.Env -module CTable = FStar.Interactive.CompletionTable - -let repl_stack: ref repl_stack_t = U.mk_ref [] - -let set_check_kind env check_kind = - { env with admit = (check_kind = LaxCheck || Options.lax()); - dsenv = DsEnv.set_syntax_only env.dsenv (check_kind = SyntaxCheck)} - -(** Build a list of dependency loading tasks from a list of dependencies **) -let repl_ld_tasks_of_deps (deps: list string) (final_tasks: list repl_task) = - let wrap fname = { tf_fname = fname; tf_modtime = U.now () } in - let rec aux (deps:list string) (final_tasks:list repl_task) - : list repl_task = - match deps with - | intf :: impl :: deps' when needs_interleaving intf impl -> - LDInterleaved (wrap intf, wrap impl) :: aux deps' final_tasks - | intf_or_impl :: deps' -> - LDSingle (wrap intf_or_impl) :: aux deps' final_tasks - | [] -> final_tasks in - aux deps final_tasks - -(** Compute dependencies of `filename` and steps needed to load them. - -The dependencies are a list of file name. The steps are a list of -``repl_task`` elements, to be executed by ``run_repl_task``. **) -let deps_and_repl_ld_tasks_of_our_file filename - : list string - & list repl_task - & FStar.Parser.Dep.deps = - let get_mod_name fname = - Parser.Dep.lowercase_module_name fname in - let our_mod_name = - get_mod_name filename in - let has_our_mod_name f = - (get_mod_name f = our_mod_name) in - - let parse_data_cache = FStar.CheckedFiles.load_parsing_data_from_cache in - let deps, dep_graph = FStar.Dependencies.find_deps_if_needed [filename] parse_data_cache in - let same_name, real_deps = - List.partition has_our_mod_name deps in - - let intf_tasks = - match same_name with - | [intf; impl] -> - if not (Parser.Dep.is_interface intf) then - raise_error0 Errors.Fatal_MissingInterface (U.format1 "Expecting an interface, got %s" intf); - if not (Parser.Dep.is_implementation impl) then - raise_error0 Errors.Fatal_MissingImplementation - (U.format1 "Expecting an implementation, got %s" impl); - [LDInterfaceOfCurrentFile ({ tf_fname = intf; tf_modtime = U.now () }) ] - | [impl] -> - [] - | _ -> - let mods_str = String.concat " " same_name in - let message = "Too many or too few files matching %s: %s" in - raise_error0 Errors.Fatal_TooManyOrTooFewFileMatch (U.format message [our_mod_name; mods_str]); - [] in - - let tasks = - repl_ld_tasks_of_deps real_deps intf_tasks in - real_deps, tasks, dep_graph - -(** Checkpoint the current (typechecking and desugaring) environment **) -let snapshot_env env msg : repl_depth_t & env_t = - let ctx_depth, env = TypeChecker.Tc.snapshot_context env msg in - let opt_depth, () = Options.snapshot () in - (ctx_depth, opt_depth), env - -let push_repl msg push_kind_opt task st = - let depth, env = snapshot_env st.repl_env msg in - repl_stack := (depth, (task, st)) :: !repl_stack; - match push_kind_opt with - | None -> st - | Some push_kind -> - { st with repl_env = set_check_kind env push_kind } // repl_env is the only mutable part of st - -(* Record the issues that were raised by the last push *) -let add_issues_to_push_fragment (issues: list json) = - match !repl_stack with - | (depth, (PushFragment(frag, push_kind, i), st))::rest -> ( - let pf = PushFragment(frag, push_kind, issues @ i) in - repl_stack := (depth, (pf, st)) :: rest - ) - | _ -> () - -(** Revert to a previous checkpoint. - -Usage note: A proper push/pop pair looks like this: - - let noop = - let env', depth = snapshot_env env in - // [Do stuff with env'] - let env'' = rollback_env env'.solver depth in - env'' - -In most cases, the invariant should hold that ``env'' === env`` (look for -assertions of the form ``physical_equality _ _`` in the sources). - -You may be wondering why we need ``snapshot`` and ``rollback``. Aren't ``push`` -and ``pop`` sufficient? They are not. The issue is that the typechecker's code -can encounter (fatal) errors at essentially any point, and was not written to -clean up after itself in these cases. Fatal errors are handled by raising an -exception, skipping all code that would ``pop`` previously pushed state. - -That's why we need ``rollback``: all that rollback does is call ``pop`` -sufficiently many times to get back into the state we were before the -corresponding ``pop``. **) -let rollback_env solver msg (ctx_depth, opt_depth) = - let env = TypeChecker.Tc.rollback_context solver msg (Some ctx_depth) in - Options.rollback (Some opt_depth); - env - -let pop_repl msg st = - match !repl_stack with - | [] -> failwith "Too many pops" - | (depth, (_, st')) :: stack_tl -> - let env = rollback_env st.repl_env.solver msg depth in - repl_stack := stack_tl; - // Because of the way ``snapshot`` is implemented, the `st'` and `env` - // that we rollback to should be consistent: - FStar.Common.runtime_assert - (U.physical_equality env st'.repl_env) - "Inconsistent stack state"; - st' - -(** Like ``tc_one_file``, but only return the new environment **) -let tc_one (env:env_t) intf_opt modf = - let parse_data = modf |> FStar.Parser.Dep.parsing_data_of (TcEnv.dep_graph env) in - let _, env = tc_one_file_for_ide env intf_opt modf parse_data in - env - -open FStar.Class.Show -(** Load the file or files described by `task` **) -let run_repl_task (curmod: optmod_t) (env: env_t) (task: repl_task) lds : optmod_t & env_t & lang_decls_t = - match task with - | LDInterleaved (intf, impl) -> - curmod, tc_one env (Some intf.tf_fname) impl.tf_fname, [] - | LDSingle intf_or_impl -> - curmod, tc_one env None intf_or_impl.tf_fname, [] - | LDInterfaceOfCurrentFile intf -> - curmod, Universal.load_interface_decls env intf.tf_fname, [] - | PushFragment (frag, _, _) -> - let frag = - match frag with - | Inl frag -> Inl (frag, lds) - | Inr decl -> Inr decl - in - let o, e, langs = tc_one_fragment curmod env frag in - o, e, langs - | Noop -> - curmod, env, [] - -(*******************************************) -(* Name tracking: required for completions *) -(*******************************************) - -let query_of_ids (ids: list ident) : CTable.query = - List.map string_of_id ids - -let query_of_lid (lid: lident) : CTable.query = - query_of_ids (ns_of_lid lid @ [ident_of_lid lid]) - -let update_names_from_event cur_mod_str table evt = - let is_cur_mod lid = (string_of_lid lid) = cur_mod_str in - match evt with - | NTAlias (host, id, included) -> - if is_cur_mod host then - CTable.register_alias - table (string_of_id id) [] (query_of_lid included) - else - table - | NTOpen (host, (included, kind, _)) -> - if is_cur_mod host then - CTable.register_open - table (kind = FStar.Syntax.Syntax.Open_module) [] (query_of_lid included) - else - table - | NTInclude (host, included) -> - CTable.register_include - table (if is_cur_mod host then [] else query_of_lid host) (query_of_lid included) - | NTBinding binding -> - let lids = - match binding with - | Inl (SS.Binding_lid (lid, _)) -> [lid] - | Inr (lids, _) -> lids - | _ -> [] in - List.fold_left - (fun tbl lid -> - let ns_query = if nsstr lid = cur_mod_str then [] - else query_of_ids (ns_of_lid lid) in - CTable.insert - tbl ns_query (string_of_id (ident_of_lid lid)) lid) - table lids - -let commit_name_tracking' cur_mod names name_events = - let cur_mod_str = match cur_mod with - | None -> "" | Some md -> string_of_lid (SS.mod_name md) in - let updater = update_names_from_event cur_mod_str in - List.fold_left updater names name_events - -let commit_name_tracking st name_events = - let names = commit_name_tracking' st.repl_curmod st.repl_names name_events in - { st with repl_names = names } - -let fresh_name_tracking_hooks () = - let events = Util.mk_ref [] in - let push_event evt = events := evt :: !events in - events, - DsEnv.mk_dsenv_hooks - (fun dsenv op -> push_event (NTOpen (DsEnv.current_module dsenv, op))) - (fun dsenv ns -> push_event (NTInclude (DsEnv.current_module dsenv, ns))) - (fun dsenv x l -> push_event (NTAlias (DsEnv.current_module dsenv, x, l))), - { TcEnv.tc_push_in_gamma_hook = - (fun _ s -> push_event (NTBinding s)) } - -let track_name_changes (env: env_t) - : env_t & (env_t -> env_t & list name_tracking_event) = - let set_hooks dshooks tchooks env = - let (), tcenv' = with_dsenv_of_tcenv env (fun dsenv -> (), DsEnv.set_ds_hooks dsenv dshooks) in - TcEnv.set_tc_hooks tcenv' tchooks in - - let old_dshooks, old_tchooks = DsEnv.ds_hooks env.dsenv, TcEnv.tc_hooks env in - let events, new_dshooks, new_tchooks = fresh_name_tracking_hooks () in - - set_hooks new_dshooks new_tchooks env, - (fun env -> set_hooks old_dshooks old_tchooks env, - List.rev !events) - -// A REPL transaction with different error handling; used exclusively by LSP; -// variant of run_repl_transaction in IDE -let repl_tx st push_kind task = - try - let st = push_repl "repl_tx" (Some push_kind) task st in - let env, finish_name_tracking = track_name_changes st.repl_env in // begin name tracking - let curmod, env, lds = run_repl_task st.repl_curmod env task st.repl_lang in - let st = { st with repl_curmod = curmod; repl_env = env; repl_lang=List.rev lds @ st.repl_lang } in - let env, name_events = finish_name_tracking env in // end name tracking - None, commit_name_tracking st name_events - with - | Failure (msg) -> - Some (js_diag st.repl_fname msg None), st - | U.SigInt -> - U.print_error "[E] Interrupt"; None, st - | Error (e, msg, r, _ctx) -> // TODO: display the error context somehow - // FIXME, or is it OK to render? - Some (js_diag st.repl_fname (Errors.rendermsg msg) (Some r)), st - | Stop -> - U.print_error "[E] Stop"; None, st - -// Little helper -let tf_of_fname fname = - { tf_fname = fname; - tf_modtime = Parser.ParseIt.get_file_last_modification_time fname } - -// Little helper: update timestamps in argument task to last modification times. -let update_task_timestamps = function - | LDInterleaved (intf, impl) -> - LDInterleaved (tf_of_fname intf.tf_fname, tf_of_fname impl.tf_fname) - | LDSingle intf_or_impl -> - LDSingle (tf_of_fname intf_or_impl.tf_fname) - | LDInterfaceOfCurrentFile intf -> - LDInterfaceOfCurrentFile (tf_of_fname intf.tf_fname) - | other -> other - -// Variant of run_repl_ld_transactions in IDE; used exclusively by LSP. -// The first dependencies (prims, ...) come first; the current file's -// interface comes last. The original value of the `repl_deps_stack` field -// in ``st`` is used to skip already completed tasks. -let repl_ldtx (st: repl_state) (tasks: list repl_task) : either_replst = - - (* Run as many ``pop_repl`` as there are entries in the input stack. - Elements of the input stack are expected to match the topmost ones of - ``!repl_stack`` *) - let rec revert_many st = function - | [] -> st - | (_id, (task, _st')) :: entries -> - let st' = pop_repl "repl_ldtx" st in - let dep_graph = TcEnv.dep_graph st.repl_env in - let st' = { st' with repl_env = TcEnv.set_dep_graph st'.repl_env dep_graph } in - revert_many st' entries in - - let rec aux (st: repl_state) - (tasks: list repl_task) - (previous: list repl_stack_entry_t) = - match tasks, previous with - // All done: return the final state. - | [], [] -> Inl st - - // We have more dependencies to load, and no previously loaded dependencies: - // run ``task`` and record the updated dependency stack in ``st``. - | task :: tasks, [] -> - let timestamped_task = update_task_timestamps task in - let diag, st = repl_tx st LaxCheck timestamped_task in - if not (U.is_some diag) then aux ({ st with repl_deps_stack = !repl_stack }) tasks [] - else Inr st - - // We've already run ``task`` previously, and no update is needed: skip. - | task :: tasks, prev :: previous - when fst (snd prev) = update_task_timestamps task -> - aux st tasks previous - - // We have a timestamp mismatch or a new dependency: - // revert now-obsolete dependencies and resume loading. - | tasks, previous -> - aux (revert_many st previous) tasks [] in - - aux st tasks (List.rev st.repl_deps_stack) - -// Variant of load_deps in IDE; used exclusively by LSP -let ld_deps st = - try - let (deps, tasks, dep_graph) = deps_and_repl_ld_tasks_of_our_file st.repl_fname in - let st = { st with repl_env = TcEnv.set_dep_graph st.repl_env dep_graph } in - match repl_ldtx st tasks with - | Inr st -> Inr st - | Inl st -> Inl (st, deps) - with - | Error (e, msg, _rng, ctx) -> U.print1_error "[E] Failed to load deps. %s" (Errors.rendermsg msg); Inr st - | exn -> U.print1_error "[E] Failed to load deps. Message: %s" (message_of_exn exn); Inr st - -let add_module_completions this_fname deps table = - let capitalize str = if str = "" then str - else let first = String.substring str 0 1 in - String.uppercase first ^ String.substring str 1 (String.length str - 1) in - let mods = - FStar.Parser.Dep.build_inclusion_candidates_list () in - let loaded_mods_set = - List.fold_left - (fun acc dep -> psmap_add acc (Parser.Dep.lowercase_module_name dep) true) - (psmap_empty ()) (Basefiles.prims () :: deps) in // Prims is an implicit dependency - let loaded modname = - psmap_find_default loaded_mods_set modname false in - let this_mod_key = - Parser.Dep.lowercase_module_name this_fname in - List.fold_left (fun table (modname, mod_path) -> - // modname is the filename part of mod_path - let mod_key = String.lowercase modname in - if this_mod_key = mod_key then - table // Exclude current module from completion - else - let ns_query = Util.split (capitalize modname) "." in - CTable.register_module_path table (loaded mod_key) mod_path ns_query) - table (List.rev mods) // List.rev to process files in order or *increasing* precedence - -// Variant of run_push_with_deps in IDE; used exclusively by LSP -let full_lax text st = - TcEnv.toggle_id_info st.repl_env true; - let frag = { frag_fname = st.repl_fname; frag_text = text; frag_line = 1; frag_col = 0 } in - match ld_deps st with - | Inl (st, deps) -> - let names = add_module_completions st.repl_fname deps st.repl_names in - repl_tx ({ st with repl_names = names }) LaxCheck (PushFragment (Inl frag, LaxCheck, [])) - | Inr st -> None, st diff --git a/src/fstar/FStar.Interactive.PushHelper.fsti b/src/fstar/FStar.Interactive.PushHelper.fsti deleted file mode 100644 index 93a11b4002a..00000000000 --- a/src/fstar/FStar.Interactive.PushHelper.fsti +++ /dev/null @@ -1,71 +0,0 @@ -(* - Copyright 2019 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -(* FStar.Interactive.Lsp and FStar.Interactive.Ide need to push various * - * text fragments and update state; this file collects helpers for them *) - -module FStar.Interactive.PushHelper -open FStar -open FStar.Compiler -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.Util -open FStar.Ident -open FStar.TypeChecker.Env -open FStar.Interactive.JsonHelper -open FStar.Interactive.Ide.Types - -module DsEnv = FStar.Syntax.DsEnv -module CTable = FStar.Interactive.CompletionTable -module TcEnv = FStar.TypeChecker.Env - -type ctx_depth_t = int & int & solver_depth_t & int -type deps_t = FStar.Parser.Dep.deps -type either_replst = either repl_state repl_state - -// Name tracking; taken directly from IDE -type name_tracking_event = -| NTAlias of lid (* host *) & ident (* alias *) & lid (* aliased *) -| NTOpen of lid (* host *) & FStar.Syntax.Syntax.open_module_or_namespace (* opened *) -| NTInclude of lid (* host *) & lid (* included *) -| NTBinding of either FStar.Syntax.Syntax.binding TcEnv.sig_binding - -val repl_stack : ref repl_stack_t -val set_check_kind : env_t -> push_kind -> env_t - -// Push an Pop, directly copied over from IDE -val push_repl : string -> option push_kind -> repl_task -> repl_state -> repl_state -val add_issues_to_push_fragment (issues: list json) : unit -val pop_repl : string -> repl_state -> repl_state - -// Factored out from IDE for use by LSP as well -val deps_and_repl_ld_tasks_of_our_file : string -> list string & list repl_task & deps_t - -// Core functionality, directly copied over from IDE -val run_repl_task -: optmod_t -> env_t -> repl_task -> FStar.Universal.lang_decls_t -> - optmod_t & env_t & FStar.Universal.lang_decls_t - -// Factored out from IDE for use by LSP as well -val update_task_timestamps : repl_task -> repl_task -val add_module_completions : string -> list string -> CTable.table -> CTable.table - -val track_name_changes : env_t -> env_t & (env_t -> env_t & list name_tracking_event) -val commit_name_tracking : repl_state -> list name_tracking_event -> repl_state - -// Lax-check the whole file; used on didOpen and didSave -// returns a diagnostic (only on error) along with the repl_state -val full_lax : string -> repl_state -> option assoct & repl_state diff --git a/src/fstar/FStar.Interactive.QueryHelper.fst b/src/fstar/FStar.Interactive.QueryHelper.fst deleted file mode 100644 index 0cb843191a8..00000000000 --- a/src/fstar/FStar.Interactive.QueryHelper.fst +++ /dev/null @@ -1,144 +0,0 @@ -(* - Copyright 2019 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -(* FStar.Interactive.Lsp needs to construct responses to various * - * queries; this file collects helpers for them *) - -module FStar.Interactive.QueryHelper -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.Pervasives -open FStar.Compiler.Range -open FStar.Compiler.Util -open FStar.TypeChecker.Env -open FStar.TypeChecker.Common -open FStar.Interactive.JsonHelper -open FStar.Interactive.CompletionTable - -module U = FStar.Compiler.Util -module PI = FStar.Parser.ParseIt -module DsEnv = FStar.Syntax.DsEnv -module TcErr = FStar.TypeChecker.Err -module TcEnv = FStar.TypeChecker.Env -module CTable = FStar.Interactive.CompletionTable - -let with_printed_effect_args k = - Options.with_saved_options - (fun () -> Options.set_option "print_effect_args" (Options.Bool true); k ()) - -let term_to_string tcenv t = - with_printed_effect_args (fun () -> FStar.TypeChecker.Normalize.term_to_string tcenv t) - -let sigelt_to_string tcenv se = - with_printed_effect_args (fun () -> Syntax.Print.sigelt_to_string' (DsEnv.set_current_module tcenv.dsenv tcenv.curmodule) se) - -let symlookup tcenv symbol pos_opt requested_info = - let info_of_lid_str lid_str = - let lid = Ident.lid_of_ids (List.map Ident.id_of_text (U.split lid_str ".")) in - let lid = U.dflt lid <| DsEnv.resolve_to_fully_qualified_name tcenv.dsenv lid in - try_lookup_lid tcenv lid |> U.map_option (fun ((_, typ), r) -> (Inr lid, typ, r)) in - - let docs_of_lid lid = None in - - let def_of_lid lid = - U.bind_opt (TcEnv.lookup_qname tcenv lid) (function - | (Inr (se, _), _) -> Some (sigelt_to_string tcenv se) - | _ -> None) in - - let info_at_pos_opt = - U.bind_opt pos_opt (fun (file, row, col) -> - TcErr.info_at_pos tcenv file row col) in - - let info_opt = - match info_at_pos_opt with - | Some _ -> info_at_pos_opt - | None -> if symbol = "" then None else info_of_lid_str symbol in - - match info_opt with - | None -> None - | Some (name_or_lid, typ, rng) -> - let name = - match name_or_lid with - | Inl name -> name - | Inr lid -> Ident.string_of_lid lid in - let str_of_opt = function - | None -> "" - | Some s -> s in - let typ_str = - if List.mem "type" requested_info then - Some (term_to_string tcenv typ) - else None in - let doc_str = - match name_or_lid with - | Inr lid when List.mem "documentation" requested_info -> docs_of_lid lid - | _ -> None in - let def_str = - match name_or_lid with - | Inr lid when List.mem "definition" requested_info -> def_of_lid lid - | _ -> None in - let def_range = - if List.mem "defined-at" requested_info then Some rng else None in - Some ({ slr_name = name; slr_def_range = def_range; - slr_typ = typ_str; slr_doc = doc_str; slr_def = def_str }) - -let mod_filter = function - | _, CTable.Namespace _ - | _, CTable.Module { CTable.mod_loaded = true } -> None - | pth, CTable.Module md -> - Some (pth, CTable.Module ({ md with CTable.mod_name = CTable.mod_name md ^ "." })) - -let ck_completion (st: repl_state) (search_term: string) : list CTable.completion_result = - let needle = U.split search_term "." in - let mods_and_nss = CTable.autocomplete_mod_or_ns st.repl_names needle mod_filter in - let lids = CTable.autocomplete_lid st.repl_names needle in - lids @ mods_and_nss - -let deflookup (env: TcEnv.env) (pos: txdoc_pos) : option assoct = - match symlookup env "" (Some (pos_munge pos)) ["defined-at"] with - | Some { slr_name = _; slr_def_range = (Some r); slr_typ = _; slr_doc = _; slr_def = _ } -> - resultResponse (js_loclink r) - | _ -> nullResponse - -// A hover-provider provides both the type and the definition of a given symbol -let hoverlookup (env: TcEnv.env) (pos: txdoc_pos) : option assoct = - match symlookup env "" (Some (pos_munge pos)) ["type"; "definition"] with - | Some { slr_name = n; slr_def_range = _; slr_typ = (Some t); slr_doc = _; slr_def = (Some d) } -> - let hovertxt = U.format2 "```fstar\n%s\n````\n---\n```fstar\n%s\n```" t d in - resultResponse (JsonAssoc [("contents", JsonAssoc [("kind", JsonStr "markdown"); - ("value", JsonStr hovertxt)])]) - | _ -> nullResponse - -let complookup (st: repl_state) (pos: txdoc_pos) : option assoct = - // current_col corresponds to the current cursor position of the incomplete identifier - let (file, row, current_col) = pos_munge pos in - let (Some (_, text)) = PI.read_vfs_entry file in - // Find the column that begins a partial identifier - let rec find_col l = - match l with - | [] -> 0 - | h::t -> if h = ' ' && List.length t < current_col then (List.length t + 1) else find_col t in - let str = List.nth (U.splitlines text) (row - 1) in - let explode s = - let rec exp i l = - if i < 0 then l else exp (i - 1) (String.get s i :: l) in - exp (String.length s - 1) [] in - let begin_col = find_col (List.rev (explode str)) in - let term = U.substring str begin_col (current_col - begin_col) in - let items = ck_completion st term in - let l = List.map (fun r -> JsonAssoc [("label", JsonStr r.completion_candidate)]) items in - resultResponse (JsonList l) diff --git a/src/fstar/FStar.Interactive.QueryHelper.fsti b/src/fstar/FStar.Interactive.QueryHelper.fsti deleted file mode 100644 index 16b071617ea..00000000000 --- a/src/fstar/FStar.Interactive.QueryHelper.fsti +++ /dev/null @@ -1,53 +0,0 @@ -(* - Copyright 2019 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -(* FStar.Interactive.Lsp needs to construct responses to various * - * queries; this file collects helpers for them *) - -module FStar.Interactive.QueryHelper -open FStar -open FStar.Compiler -open FStar.Compiler.Range -open FStar.Compiler.Util -open FStar.TypeChecker.Env -open FStar.Interactive.JsonHelper -open FStar.Interactive.Ide.Types - -module TcErr = FStar.TypeChecker.Err -module TcEnv = FStar.TypeChecker.Env -module CTable = FStar.Interactive.CompletionTable - -type position = string & int & int -type sl_reponse = { slr_name: string; - slr_def_range: option Range.range; - slr_typ: option string; - slr_doc: option string; - slr_def: option string } - -// Shared by IDE and LSP -val term_to_string : TcEnv.env -> Syntax.Syntax.term -> string -val symlookup : TcEnv.env -> string -> option position -> list string -> option sl_reponse -val ck_completion : repl_state -> string -> list CTable.completion_result - -(* Used exclusively by LSP *) -// Lookup the definition of a particular term located at txdoc_pos -val deflookup : TcEnv.env -> txdoc_pos -> option assoct - -// Lookup the on-hover documentation for a particular term located at txdoc_pos -val hoverlookup : TcEnv.env -> txdoc_pos -> option assoct - -// Lookup the completion information for a particular term located at txdoc_pos -val complookup : repl_state -> txdoc_pos -> option assoct diff --git a/src/fstar/FStar.Main.fst b/src/fstar/FStar.Main.fst deleted file mode 100644 index b3b71e145fb..00000000000 --- a/src/fstar/FStar.Main.fst +++ /dev/null @@ -1,353 +0,0 @@ -(* - Copyright 2008-2016 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Main -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Compiler.Util -open FStar.Getopt -open FStar.Ident -open FStar.CheckedFiles -open FStar.Universal -open FStar.Compiler - -open FStar.Class.Show - -module E = FStar.Errors -module UF = FStar.Syntax.Unionfind -module RE = FStar.Reflection.V2.Embeddings - -let _ = FStar.Version.dummy () - -(* These modules only mentioned to put them in the dep graph -and hence compile and link them in. They do not export anything, -instead they register primitive steps in the normalizer during -initialization. *) -open FStar.Reflection.V1.Interpreter {} -open FStar.Reflection.V2.Interpreter {} - -(* process_args: parses command line arguments, setting FStar.Options *) -(* returns an error status and list of filenames *) -let process_args () : parse_cmdline_res & list string = - Options.parse_cmd_line () - -(* cleanup: kills background Z3 processes; relevant when --n_cores > 1 *) -(* GM: unclear if it's useful now? *) -let cleanup () = Util.kill_all () - -(* printing a finished message *) -let finished_message fmods errs = - let print_to = if errs > 0 then Util.print_error else Util.print_string in - if not (Options.silent()) then begin - fmods |> List.iter (fun (iface, name) -> - let tag = if iface then "i'face (or impl+i'face)" else "module" in - if Options.should_print_message (string_of_lid name) - then print_to (Util.format2 "Verified %s: %s\n" tag (Ident.string_of_lid name))); - if errs > 0 - then if errs = 1 - then Util.print_error "1 error was reported (see above)\n" - else Util.print1_error "%s errors were reported (see above)\n" (string_of_int errs) - else print1 "%s\n" (Util.colorize_bold "All verification conditions discharged successfully") - end - -(* printing total error count *) -let report_errors fmods = - FStar.Errors.report_all () |> ignore; - let nerrs = FStar.Errors.get_err_count() in - if nerrs > 0 then begin - finished_message fmods nerrs; - exit 1 - end - -let load_native_tactics () = - let modules_to_load = Options.load() |> List.map Ident.lid_of_str in - let cmxs_to_load = Options.load_cmxs () |> List.map Ident.lid_of_str in - let ml_module_name m = FStar.Extraction.ML.Util.ml_module_name_of_lid m in - let ml_file m = ml_module_name m ^ ".ml" in - let cmxs_file m = - let cmxs = ml_module_name m ^ ".cmxs" in - match Find.find_file cmxs with - | Some f -> f - | None -> - if List.contains m cmxs_to_load //if this module comes from the cmxs list, fail hard - then E.raise_error0 E.Fatal_FailToCompileNativeTactic (Util.format1 "Could not find %s to load" cmxs) - else //else try to find and compile the ml file - match Find.find_file (ml_file m) with - | None -> - E.raise_error0 E.Fatal_FailToCompileNativeTactic - (Util.format1 "Failed to compile native tactic; extracted module %s not found" (ml_file m)) - | Some ml -> - let dir = Util.dirname ml in - Plugins.compile_modules dir [ml_module_name m]; - begin match Find.find_file cmxs with - | None -> - E.raise_error0 E.Fatal_FailToCompileNativeTactic - (Util.format1 "Failed to compile native tactic; compiled object %s not found" cmxs) - | Some f -> f - end - in - let cmxs_files = (modules_to_load@cmxs_to_load) |> List.map cmxs_file in - if Debug.any () then - Util.print1 "Will try to load cmxs files: [%s]\n" (String.concat ", " cmxs_files); - Plugins.load_plugins cmxs_files; - iter_opt (Options.use_native_tactics ()) - Plugins.load_plugins_dir; - () - - -(* Need to keep names of input files for a second pass when prettyprinting *) -(* This reference is set once in `go` and read in `main` if the print or *) -(* print_in_place options are passed *) -let fstar_files: ref (option (list string)) = Util.mk_ref None - -(****************************************************************************) -(* Main function *) -(****************************************************************************) -let go _ = - let res, filenames = process_args () in - if Options.trace_error () then begin - let h = get_sigint_handler () in - let h' s = - let open FStar.Pprint in - let open FStar.Errors.Msg in - Debug.enable (); (* make sure diag is printed *) - Options.set_option "error_contexts" (Options.Bool true); - (* ^ Print context. Stack trace will be added since we have trace_error. *) - Errors.diag Range.dummyRange [ - text "GOT SIGINT! Exiting"; - ]; - exit 1 - in - set_sigint_handler (sigint_handler_f h') - end; - match res with - | Empty -> - Options.display_usage(); exit 1 - - | Help -> - Options.display_usage(); exit 0 - - | Error msg -> - Util.print_error msg; exit 1 - - | _ when Options.print_cache_version () -> - Util.print1 "F* cache version number: %s\n" - (string_of_int FStar.CheckedFiles.cache_version_number); - exit 0 - - | Success -> - fstar_files := Some filenames; - - if Debug.any () then ( - Util.print1 "- F* executable: %s\n" (Util.exec_name); - Util.print1 "- F* exec dir: %s\n" (Options.fstar_bin_directory); - Util.print1 "- Library root: %s\n" ((Util.dflt "" (Options.lib_root ()))); - Util.print1 "- Full include path: %s\n" (show (Options.include_path ())); - Util.print_string "\n"; - () - ); - - load_native_tactics (); - - (* Set the unionfind graph to read-only mode. - * This will be unset by the typechecker and other pieces - * of code that intend to use it. It helps us catch errors. *) - (* TODO: also needed by the interactive mode below. *) - UF.set_ro (); - - (* --dep: Just compute and print the transitive dependency graph; - don't verify anything *) - if Options.dep() <> None - then let _, deps = Parser.Dep.collect filenames FStar.CheckedFiles.load_parsing_data_from_cache in - Parser.Dep.print deps; - report_errors [] - - (* --print: Emit files in canonical source syntax *) - else if Options.print () || Options.print_in_place () then - if FStar.Platform.is_fstar_compiler_using_ocaml - then let printing_mode = - if Options.print () - then FStar.Prettyprint.FromTempToStdout - else FStar.Prettyprint.FromTempToFile - in - FStar.Prettyprint.generate printing_mode filenames - else failwith "You seem to be using the F#-generated version ofthe compiler ; \o - reindenting is not known to work yet with this version" - - (* --read_checked: read and print a checked file *) - else if Some? (Options.read_checked_file ()) then - let path = Some?.v <| Options.read_checked_file () in - let env = Universal.init_env Parser.Dep.empty_deps in - let res = FStar.CheckedFiles.load_tc_result path in - match res with - | None -> - let open FStar.Pprint in - Errors.raise_error0 Errors.Fatal_ModuleOrFileNotFound [ - Errors.Msg.text "Could not read checked file:" ^/^ doc_of_string path - ] - - | Some (_, tcr) -> - print1 "%s\n" (show tcr.checked_module) - - else if Options.list_plugins () then - let ps = FStar.TypeChecker.Cfg.list_plugins () in - let ts = FStar.Tactics.Interpreter.native_tactics_steps () in - Util.print1 "Registered plugins:\n%s\n" (String.concat "\n" (List.map (fun p -> " " ^ show p.FStar.TypeChecker.Primops.Base.name) ps)); - Util.print1 "Registered tactic plugins:\n%s\n" (String.concat "\n" (List.map (fun p -> " " ^ show p.FStar.TypeChecker.Primops.Base.name) ts)); - () - - else if Options.locate () then ( - Util.print1 "%s\n" (Util.get_exec_dir () |> Util.normalize_file_path); - exit 0 - - ) else if Options.locate_lib () then ( - match Options.lib_root () with - | None -> - Util.print_error "No library found (is --no_default_includes set?)\n"; - exit 1 - | Some s -> - Util.print1 "%s\n" (Util.normalize_file_path s); - exit 0 - - ) else if Options.locate_ocaml () then ( - // This is correct right now, but probably should change. - Util.print1 "%s\n" (Util.get_exec_dir () ^ "/../lib" |> Util.normalize_file_path); - exit 0 - - ) else if Some? (Options.read_krml_file ()) then - let path = Some?.v <| Options.read_krml_file () in - match load_value_from_file path <: option FStar.Extraction.Krml.binary_format with - | None -> - let open FStar.Pprint in - Errors.raise_error0 Errors.Fatal_ModuleOrFileNotFound [ - Errors.Msg.text "Could not read krml file:" ^/^ doc_of_string path - ] - | Some (version, files) -> - print1 "Karamel format version: %s\n" (show version); - (* Just "show decls" would print it, we just format this a bit *) - files |> List.iter (fun (name, decls) -> - print1 "%s:\n" name; - decls |> List.iter (fun d -> print1 " %s\n" (show d)) - ) - - (* --lsp *) - else if Options.lsp_server () then - FStar.Interactive.Lsp.start_server () - - (* For the following cases we might need native tactics, try to load *) - else begin - - (* --ide, --in: Interactive mode *) - if Options.interactive () then begin - UF.set_rw (); - match filenames with - | [] -> (* input validation: move to process args? *) - Errors.log_issue0 Errors.Error_MissingFileName - "--ide: Name of current file missing in command line invocation\n"; - exit 1 - | _ :: _ :: _ -> (* input validation: move to process args? *) - Errors.log_issue0 Errors.Error_TooManyFiles - "--ide: Too many files in command line invocation\n"; - exit 1 - | [filename] -> - if Options.legacy_interactive () then - FStar.Interactive.Legacy.interactive_mode filename - else - FStar.Interactive.Ide.interactive_mode filename - end - - (* Normal, batch mode compiler *) - else if List.length filenames >= 1 then begin //normal batch mode - let filenames, dep_graph = FStar.Dependencies.find_deps_if_needed filenames FStar.CheckedFiles.load_parsing_data_from_cache in - let tcrs, env, cleanup = Universal.batch_mode_tc filenames dep_graph in - ignore (cleanup env); - let module_names = - tcrs - |> List.map (fun tcr -> - Universal.module_or_interface_name tcr.checked_module) - in - report_errors module_names; - finished_message module_names 0 - end //end batch mode - - else - Errors.raise_error0 Errors.Error_MissingFileName "No file provided" - end - -(* This is pretty awful. Now that we have Lazy_embedding, we can get rid of this table. *) -let lazy_chooser (k:Syntax.Syntax.lazy_kind) (i:Syntax.Syntax.lazyinfo) : Syntax.Syntax.term - = match k with - (* TODO: explain *) - | FStar.Syntax.Syntax.BadLazy -> failwith "lazy chooser: got a BadLazy" - | FStar.Syntax.Syntax.Lazy_bv -> RE.unfold_lazy_bv i - | FStar.Syntax.Syntax.Lazy_namedv -> RE.unfold_lazy_namedv i - | FStar.Syntax.Syntax.Lazy_binder -> RE.unfold_lazy_binder i - | FStar.Syntax.Syntax.Lazy_letbinding -> RE.unfold_lazy_letbinding i - | FStar.Syntax.Syntax.Lazy_optionstate -> RE.unfold_lazy_optionstate i - | FStar.Syntax.Syntax.Lazy_fvar -> RE.unfold_lazy_fvar i - | FStar.Syntax.Syntax.Lazy_comp -> RE.unfold_lazy_comp i - | FStar.Syntax.Syntax.Lazy_env -> RE.unfold_lazy_env i - | FStar.Syntax.Syntax.Lazy_sigelt -> RE.unfold_lazy_sigelt i - | FStar.Syntax.Syntax.Lazy_universe -> RE.unfold_lazy_universe i - - | FStar.Syntax.Syntax.Lazy_proofstate -> Tactics.Embedding.unfold_lazy_proofstate i - | FStar.Syntax.Syntax.Lazy_goal -> Tactics.Embedding.unfold_lazy_goal i - - | FStar.Syntax.Syntax.Lazy_doc -> RE.unfold_lazy_doc i - - | FStar.Syntax.Syntax.Lazy_uvar -> FStar.Syntax.Util.exp_string "((uvar))" - | FStar.Syntax.Syntax.Lazy_universe_uvar -> FStar.Syntax.Util.exp_string "((universe_uvar))" - | FStar.Syntax.Syntax.Lazy_issue -> FStar.Syntax.Util.exp_string "((issue))" - | FStar.Syntax.Syntax.Lazy_ident -> FStar.Syntax.Util.exp_string "((ident))" - | FStar.Syntax.Syntax.Lazy_tref -> FStar.Syntax.Util.exp_string "((tref))" - - | FStar.Syntax.Syntax.Lazy_embedding (_, t) -> Thunk.force t - | FStar.Syntax.Syntax.Lazy_extension s -> FStar.Syntax.Util.exp_string (format1 "((extension %s))" s) - -// This is called directly by the Javascript port (it doesn't call Main) -let setup_hooks () = - FStar.Syntax.DsEnv.ugly_sigelt_to_string_hook := show; - FStar.Errors.set_parse_warn_error FStar.Parser.ParseIt.parse_warn_error; - FStar.Syntax.Syntax.lazy_chooser := Some lazy_chooser; - FStar.Syntax.Util.tts_f := Some show; - FStar.Syntax.Util.ttd_f := Some Class.PP.pp; - FStar.TypeChecker.Normalize.unembed_binder_knot := Some RE.e_binder; - List.iter Tactics.Interpreter.register_tactic_primitive_step Tactics.V1.Primops.ops; - List.iter Tactics.Interpreter.register_tactic_primitive_step Tactics.V2.Primops.ops; - () - -let handle_error e = - if FStar.Errors.handleable e then - FStar.Errors.err_exn e; - if Options.trace_error() then - Util.print2_error "Unexpected error\n%s\n%s\n" (Util.message_of_exn e) (Util.trace_of_exn e) - else if not (FStar.Errors.handleable e) then - Util.print1_error "Unexpected error; please file a bug report, ideally with a minimized version of the source program that triggered the error.\n%s\n" (Util.message_of_exn e); - cleanup(); - report_errors [] - -let main () = - try - setup_hooks (); - let _, time = Util.record_time go in - if FStar.Options.query_stats() - then Util.print2_error "TOTAL TIME %s ms: %s\n" - (FStar.Compiler.Util.string_of_int time) - (String.concat " " (FStar.Getopt.cmdline())); - cleanup (); - exit 0 - with - | e -> handle_error e; - exit 1 diff --git a/src/fstar/FStar.Prettyprint.fst b/src/fstar/FStar.Prettyprint.fst deleted file mode 100644 index 3f698b9e474..00000000000 --- a/src/fstar/FStar.Prettyprint.fst +++ /dev/null @@ -1,72 +0,0 @@ -(* - Copyright 2008-2018 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Prettyprint -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Compiler.Util -open FStar.Parser.ToDocument -module List = FStar.Compiler.List -module D = FStar.Parser.Driver -module P = FStar.Pprint - -type printing_mode = - | ToTempFile - | FromTempToStdout - | FromTempToFile - -let temp_file_name f = format1 "%s.print_.fst" f - -let generate (m: printing_mode) filenames = - let parse_and_prettyprint (m: printing_mode) filename = - let modul, comments = D.parse_file filename in - let outf = - match m with - | FromTempToStdout -> None - | FromTempToFile -> - let outf = open_file_for_writing filename in - Some outf - | ToTempFile -> - let outf = open_file_for_writing (temp_file_name filename) in - Some outf - in - let leftover_comments = - let comments = List.rev comments in - let doc, comments = modul_with_comments_to_document modul comments in - (* TODO : some problem with the F# generated floats *) - (match outf with - | Some f -> append_to_file f <| P.pretty_string (float_of_string "1.0") 100 doc - | None -> P.pretty_out_channel (float_of_string "1.0") 100 doc stdout); - comments - in - let left_over_doc = - if not (FStar.Compiler.List.isEmpty leftover_comments) then - P.concat [P.hardline ; P.hardline ; comments_to_document leftover_comments] - else if m = FromTempToStdout then - // This isn't needed for FromTempToFile, when using `append_to_file` a newline is added to EoF - P.concat [P.hardline; P.hardline] - else - P.empty - in - match outf with - | None -> - P.pretty_out_channel (float_of_string "1.0") 100 left_over_doc stdout - - | Some outf -> - append_to_file outf <| P.pretty_string (float_of_string "1.0") 100 left_over_doc; - close_out_channel outf - in - List.iter (parse_and_prettyprint m) filenames diff --git a/src/fstar/FStar.Universal.fst b/src/fstar/FStar.Universal.fst deleted file mode 100644 index 78d6326988b..00000000000 --- a/src/fstar/FStar.Universal.fst +++ /dev/null @@ -1,623 +0,0 @@ -(* - Copyright 2008-2016 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -//Top-level invocations into the universal type-checker FStar.TypeChecker -module FStar.Universal -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.Errors -open FStar.Compiler.Util -open FStar.Getopt -open FStar.Ident -open FStar.Syntax.Syntax -open FStar.TypeChecker.Common -open FStar.Dependencies -open FStar.Extraction.ML.UEnv -open FStar.TypeChecker.Env -open FStar.Syntax.DsEnv -open FStar.TypeChecker -open FStar.CheckedFiles - -open FStar.Class.Show - -(* Module abbreviations for the universal type-checker *) -module DsEnv = FStar.Syntax.DsEnv -module TcEnv = FStar.TypeChecker.Env -module Syntax = FStar.Syntax.Syntax -module Util = FStar.Syntax.Util -module Desugar = FStar.ToSyntax.ToSyntax -module SMT = FStar.SMTEncoding.Solver -module Const = FStar.Parser.Const -module Pars = FStar.Parser.ParseIt -module Tc = FStar.TypeChecker.Tc -module TcTerm = FStar.TypeChecker.TcTerm -module BU = FStar.Compiler.Util -module Dep = FStar.Parser.Dep -module NBE = FStar.TypeChecker.NBE -module Ch = FStar.CheckedFiles -module MLSyntax = FStar.Extraction.ML.Syntax - -let module_or_interface_name m = m.is_interface, m.name - -let with_dsenv_of_tcenv (tcenv:TcEnv.env) (f:DsEnv.withenv 'a) : 'a & TcEnv.env = - let a, dsenv = f tcenv.dsenv in - a, ({tcenv with dsenv = dsenv}) - -let with_tcenv_of_env (e:uenv) (f:TcEnv.env -> 'a & TcEnv.env) : 'a & uenv = - let a, t' = f (tcenv_of_uenv e) in - a, (set_tcenv e t') - -let with_dsenv_of_env (e:uenv) (f:DsEnv.withenv 'a) : 'a & uenv = - let a, tcenv = with_dsenv_of_tcenv (tcenv_of_uenv e) f in - a, (set_tcenv e tcenv) - -let push_env (env:uenv) = - snd (with_tcenv_of_env env (fun tcenv -> - (), FStar.TypeChecker.Env.push (tcenv_of_uenv env) "top-level: push_env")) - -let pop_env (env:uenv) = - snd (with_tcenv_of_env env (fun tcenv -> - (), FStar.TypeChecker.Env.pop tcenv "top-level: pop_env")) - -let with_env env (f:uenv -> 'a) : 'a = - let env = push_env env in - let res = f env in - let _ = pop_env env in - res - -let env_of_tcenv (env:TcEnv.env) = - FStar.Extraction.ML.UEnv.new_uenv env - -(***********************************************************************) -(* Parse and desugar a file *) -(***********************************************************************) -let parse (env:uenv) (pre_fn: option string) (fn:string) - : Syntax.modul - & uenv = - let ast, _ = Parser.Driver.parse_file fn in - let ast, env = match pre_fn with - | None -> - ast, env - | Some pre_fn -> - let pre_ast, _ = Parser.Driver.parse_file pre_fn in - match pre_ast, ast with - | Parser.AST.Interface (lid1, decls1, _), Parser.AST.Module (lid2, decls2) - when Ident.lid_equals lid1 lid2 -> - let _, env = - with_dsenv_of_env env (FStar.ToSyntax.Interleave.initialize_interface lid1 decls1) - in - with_dsenv_of_env env (FStar.ToSyntax.Interleave.interleave_module ast true) - - | Parser.AST.Interface (lid1, _, _), Parser.AST.Module (lid2, _) -> - (* Names do not match *) - Errors.raise_error lid1 - Errors.Fatal_PreModuleMismatch - "Module name in implementation does not match that of interface." - - | _ -> - Errors.raise_error0 - Errors.Fatal_PreModuleMismatch - "Module name in implementation does not match that of interface." - in - with_dsenv_of_env env (Desugar.ast_modul_to_modul ast) - -(***********************************************************************) -(* Initialize a clean environment *) -(***********************************************************************) -let core_check : TcEnv.core_check_t = - fun env tm t must_tot -> - let open FStar.TypeChecker.Core in - if not (Options.compat_pre_core_should_check ()) - then Inl None - else match check_term env tm t must_tot with - | Inl None -> Inl None - | Inl (Some g) -> - if Options.compat_pre_core_set () - then Inl None - else Inl (Some g) - | Inr err -> - Inr (fun b -> if b then print_error_short err else print_error err) - -let init_env deps : TcEnv.env = - let solver = - if Options.lax() - then SMT.dummy - else {SMT.solver with - preprocess=FStar.Tactics.Hooks.preprocess; - spinoff_strictly_positive_goals=Some FStar.Tactics.Hooks.spinoff_strictly_positive_goals; - handle_smt_goal=FStar.Tactics.Hooks.handle_smt_goal - } in - let env = - TcEnv.initial_env - deps - TcTerm.tc_term - TcTerm.typeof_tot_or_gtot_term - TcTerm.typeof_tot_or_gtot_term_fastpath - TcTerm.universe_of - Rel.teq_nosmt_force - Rel.subtype_nosmt_force - solver - Const.prims_lid - (NBE.normalize - (FStar.Tactics.Interpreter.primitive_steps ())) - core_check - in - (* Set up some tactics callbacks *) - let env = { env with synth_hook = FStar.Tactics.Hooks.synthesize } in - let env = { env with try_solve_implicits_hook = FStar.Tactics.Hooks.solve_implicits } in - let env = { env with splice = FStar.Tactics.Hooks.splice} in - let env = { env with mpreprocess = FStar.Tactics.Hooks.mpreprocess} in - let env = { env with postprocess = FStar.Tactics.Hooks.postprocess} in - env.solver.init env; - env - -(***********************************************************************) -(* Interactive mode: checking a fragment of a code *) -(***********************************************************************) -let tc_one_fragment curmod (env:TcEnv.env_t) frag = - let open FStar.Parser.AST in - // We use file_of_range instead of `Options.file_list ()` because no file - // is passed as a command-line argument in LSP mode. - let fname env = if Options.lsp_server () then Range.file_of_range (TcEnv.get_range env) - else List.hd (Options.file_list ()) in - let acceptable_mod_name modul = - (* Interface is sent as the first chunk, so we must allow repeating the same module. *) - Parser.Dep.lowercase_module_name (fname env) = - String.lowercase (string_of_lid modul.name) in - - let range_of_first_mod_decl modul = - match modul with - | Parser.AST.Module (_, { Parser.AST.drange = d } :: _) - | Parser.AST.Interface (_, { Parser.AST.drange = d } :: _, _) -> d - | _ -> Range.dummyRange in - - let filter_lang_decls (d:FStar.Parser.AST.decl) = - match d.d with - | UseLangDecls _ -> true - | _ -> false - in - let use_lang_decl (ds:lang_decls_t) = - List.tryFind (fun d -> UseLangDecls? d.d) ds - in - let check_module_name_declaration ast_modul = - (* It may seem surprising that this function, whose name indicates that - it type-checks a fragment, can actually parse an entire module. - Actually, this is an abuse, and just means that we're type-checking the - first chunk. *) - let ast_modul, env = - with_dsenv_of_tcenv env <| FStar.ToSyntax.Interleave.interleave_module ast_modul false in - let modul, env = - with_dsenv_of_tcenv env <| Desugar.partial_ast_modul_to_modul curmod ast_modul in - if not (acceptable_mod_name modul) then - begin - let msg : string = - BU.format1 "Interactive mode only supports a single module at the top-level. Expected module %s" - (Parser.Dep.module_name_of_file (fname env)) - in - Errors.raise_error (range_of_first_mod_decl ast_modul) Errors.Fatal_NonSingletonTopLevelModule msg - end; - let modul, env = - if DsEnv.syntax_only env.dsenv then modul, env - else Tc.tc_partial_modul env modul - in - let lang_decls = - let open FStar.Parser.AST in - let decls = - match ast_modul with - | Module (_, decls) - | Interface (_, decls, _) -> decls - in - List.filter filter_lang_decls decls - in - Some modul, env, lang_decls - in - - let check_decls ast_decls = - match curmod with - | None -> - let { Parser.AST.drange = rng } = List.hd ast_decls in - Errors.raise_error rng Errors.Fatal_ModuleFirstStatement "First statement must be a module declaration" - | Some modul -> - let env, ast_decls_l = - BU.fold_map - (fun env a_decl -> - let decls, env = - with_dsenv_of_tcenv env <| - FStar.ToSyntax.Interleave.prefix_with_interface_decls modul.name a_decl - in - env, decls) - env - ast_decls in - let sigelts, env = with_dsenv_of_tcenv env <| Desugar.decls_to_sigelts (List.flatten ast_decls_l) in - let modul, _, env = if DsEnv.syntax_only env.dsenv then (modul, [], env) - else Tc.tc_more_partial_modul env modul sigelts in - Some modul, env, List.filter filter_lang_decls ast_decls - in - match frag with - | Inr d -> ( - //We already have a parsed decl, usually from FStar.Interactive.Incremental - match d.d with - | FStar.Parser.AST.TopLevelModule lid -> - check_module_name_declaration (FStar.Parser.AST.Module(lid, [d])) - | _ -> - check_decls [d] - ) - - | Inl (frag, lang_decls) -> ( - let parse_frag frag = - match use_lang_decl lang_decls with - | None -> Parser.Driver.parse_fragment None frag - | Some {d=UseLangDecls lang} -> - Parser.Driver.parse_fragment (Some lang) frag - in - match parse_frag frag with - | Parser.Driver.Empty - | Parser.Driver.Decls [] -> - curmod, env, [] - - | Parser.Driver.Modul ast_modul -> - check_module_name_declaration ast_modul - - | Parser.Driver.Decls ast_decls -> - check_decls ast_decls - ) - -let load_interface_decls env interface_file_name : TcEnv.env_t = - let r = Pars.parse None (Pars.Filename interface_file_name) in - match r with - | Pars.ASTFragment (Inl (FStar.Parser.AST.Interface(l, decls, _)), _) -> - snd (with_dsenv_of_tcenv env <| FStar.ToSyntax.Interleave.initialize_interface l decls) - | Pars.ASTFragment _ -> - Errors.raise_error0 FStar.Errors.Fatal_ParseErrors - (BU.format1 "Unexpected result from parsing %s; expected a single interface" interface_file_name) - | Pars.ParseError (err, msg, rng) -> - raise (FStar.Errors.Error(err, msg, rng, [])) - | Pars.Term _ -> - failwith "Impossible: parsing a Toplevel always results in an ASTFragment" - - -(***********************************************************************) -(* Batch mode: checking a file *) -(***********************************************************************) - -(* Extraction to OCaml, F# or Krml *) -let emit dep_graph (mllibs:list (uenv & MLSyntax.mllib)) = - let opt = Options.codegen () in - let fail #a () : a = failwith ("Unrecognized extraction backend: " ^ show opt) in - if opt <> None then - let ext = match opt with - | Some Options.FSharp -> ".fs" - | Some Options.OCaml - | Some Options.Plugin -> ".ml" - | Some Options.Krml -> ".krml" - | Some Options.Extension -> ".ast" - | _ -> fail () - in - match opt with - | Some Options.FSharp | Some Options.OCaml | Some Options.Plugin -> - (* When bootstrapped in F#, this will use the old printer in - FStar.Extraction.ML.Code for both OCaml and F# extraction. - When bootstarpped in OCaml, this will use the old printer - for F# extraction and the new printer for OCaml extraction. *) - let outdir = Options.output_dir() in - List.iter (FStar.Extraction.ML.PrintML.print outdir ext) (List.map snd mllibs) - - | Some Options.Extension -> - // - // In the Extension mode, we dump (list mname & bindings_of_uenv & ml decls) - // in the binary format to a file - // The first component is the list of dependencies - // - List.iter (fun (env, m) -> - let MLSyntax.MLLib ms = m in - List.iter (fun m -> - let mname, modul, _ = m in - let filename = String.concat "_" (fst mname @ [snd mname]) in - match modul with - | Some (_, decls) -> - let bindings = FStar.Extraction.ML.UEnv.bindings_of_uenv env in - let deps : list string = Dep.deps_of_modul dep_graph (MLSyntax.string_of_mlpath mname) in - save_value_to_file (Options.prepend_output_dir (filename^ext)) (deps, bindings, decls) - | None -> - failwith "Unexpected ml modul in Extension extraction mode" - ) ms - ) mllibs - - | Some Options.Krml -> - let programs = - mllibs |> List.collect (fun (ue, mllibs) -> - Extraction.Krml.translate ue mllibs) - in - let bin: Extraction.Krml.binary_format = Extraction.Krml.current_version, programs in - let oname : string = - match Options.krmloutput () with - | Some fname -> fname (* NB: no prepending odir nor adding extension, user chose a explicit path *) - | _ -> - match programs with - | [ name, _ ] -> name ^ ext |> Options.prepend_output_dir - | _ -> "out" ^ ext |> Options.prepend_output_dir - in - save_value_to_file oname bin - - | _ -> fail () - -let tc_one_file - (env:uenv) - (pre_fn:option string) //interface file name - (fn:string) //file name - (parsing_data:FStar.Parser.Dep.parsing_data) //passed by the caller, ONLY for caching purposes at this point - : tc_result - & option MLSyntax.mllib - & uenv = - GenSym.reset_gensym(); - - (* - * AR: smt encode_modul functions are now here instead of in Tc.fs - * this is common smt postprocessing for fresh module and module read from cache - *) - let maybe_restore_opts () : unit = - if not (Options.interactive ()) then - Options.restore_cmd_line_options true |> ignore - in - let maybe_extract_mldefs tcmod env = - match Options.codegen() with - | None -> None, 0 - | Some tgt -> - if not (Options.should_extract (string_of_lid tcmod.name) tgt) - then None, 0 - else FStar.Compiler.Util.record_time (fun () -> - with_env env (fun env -> - let _, defs = FStar.Extraction.ML.Modul.extract env tcmod in - defs) - ) - in - let maybe_extract_ml_iface tcmod env = - if Options.codegen() = None - then env, 0 - else - FStar.Compiler.Util.record_time (fun () -> - let env, _ = with_env env (fun env -> - FStar.Extraction.ML.Modul.extract_iface env tcmod) in - env - ) - in - let tc_source_file () = - let fmod, env = parse env pre_fn fn in - let mii = FStar.Syntax.DsEnv.inclusion_info (tcenv_of_uenv env).dsenv fmod.name in - let check_mod () = - let check env = - if not (Options.lax()) then FStar.SMTEncoding.Z3.refresh None; - with_tcenv_of_env env (fun tcenv -> - let _ = match tcenv.gamma with - | [] -> () - | _ -> failwith "Impossible: gamma contains leaked names" - in - let modul, env = Tc.check_module tcenv fmod (is_some pre_fn) in - //AR: encode the module to to smt - maybe_restore_opts (); - let smt_decls = - if not (Options.lax()) - then FStar.SMTEncoding.Encode.encode_modul env modul - else [], [] - in - ((modul, smt_decls), env)) - in - - let ((tcmod, smt_decls), env) = - Profiling.profile (fun () -> check env) - (Some (string_of_lid fmod.name)) - "FStar.Universal.tc_source_file" - in - - let tc_time = 0 in - let extracted_defs, extract_time = maybe_extract_mldefs tcmod env in - let env, iface_extraction_time = maybe_extract_ml_iface tcmod env in - { - checked_module=tcmod; - tc_time=tc_time; - smt_decls=smt_decls; - - extraction_time = extract_time + iface_extraction_time; - mii = mii - }, - extracted_defs, - env - in - if (Options.should_verify (string_of_lid fmod.name) //if we're verifying this module - && (FStar.Options.record_hints() //and if we're recording or using hints - || FStar.Options.use_hints())) - then SMT.with_hints_db (Pars.find_file fn) check_mod - else check_mod () //don't add a hints file for modules that are not actually verified - in - if not (Options.cache_off()) then - let r = Ch.load_module_from_cache (tcenv_of_uenv env) fn in - let r = - (* If --force and this file was given in the command line, - * forget about the cache we just loaded and recheck the file. - * Note: we do the call above anyway since load_module_from_cache - * sets some internal state about dependencies. *) - if Options.force () && Options.should_check_file fn - then None - else r - in - match r with - | None -> - if Options.should_be_already_cached (FStar.Parser.Dep.module_name_of_file fn) - && not (Options.force ()) - then FStar.Errors.raise_error0 FStar.Errors.Error_AlreadyCachedAssertionFailure [ - text <| BU.format1 "Expected %s to already be checked." fn - ]; - - if (Option.isSome (Options.codegen()) - && Options.cmi()) - && not (Options.force ()) - then FStar.Errors.raise_error0 FStar.Errors.Error_AlreadyCachedAssertionFailure [ - text "Cross-module inlining expects all modules to be checked first."; - text <| BU.format1 "Module %s was not checked." fn; - ]; - - let tc_result, mllib, env = tc_source_file () in - - if FStar.Errors.get_err_count() = 0 - && (Options.lax() //we'll write out a .checked.lax file - || Options.should_verify (string_of_lid tc_result.checked_module.name)) //we'll write out a .checked file - //but we will not write out a .checked file for an unverified dependence - //of some file that should be checked - //(i.e. we DO write .checked.lax files for dependencies even if not provided as an argument) - then Ch.store_module_to_cache (tcenv_of_uenv env) fn parsing_data tc_result; - tc_result, mllib, env - - | Some tc_result -> - let tcmod = tc_result.checked_module in - let smt_decls = tc_result.smt_decls in - if Options.dump_module (string_of_lid tcmod.name) - then BU.print1 "Module after type checking:\n%s\n" (show tcmod); - - let extend_tcenv tcmod tcenv = - if not (Options.lax()) then FStar.SMTEncoding.Z3.refresh None; - let _, tcenv = - with_dsenv_of_tcenv tcenv <| - FStar.ToSyntax.ToSyntax.add_modul_to_env - tcmod - tc_result.mii - (FStar.TypeChecker.Normalize.erase_universes tcenv) - in - let env = FStar.TypeChecker.Tc.load_checked_module tcenv tcmod in - maybe_restore_opts (); - //AR: encode smt module and do post processing - if (not (Options.lax())) then begin - FStar.SMTEncoding.Encode.encode_modul_from_cache env tcmod smt_decls - end; - (), env - in - - let env = - Profiling.profile - (fun () -> with_tcenv_of_env env (extend_tcenv tcmod) |> snd) - None - "FStar.Universal.extend_tcenv" - in - - - (* If we have to extract this module, then do it first *) - let mllib = - match Options.codegen() with - | None -> None - | Some tgt -> - if Options.should_extract (string_of_lid tcmod.name) tgt - && (not tcmod.is_interface || tgt=Options.Krml) - then let extracted_defs, _extraction_time = maybe_extract_mldefs tcmod env in - extracted_defs - else None - in - - let env, _time = maybe_extract_ml_iface tcmod env in - - tc_result, - mllib, - env - - else let tc_result, mllib, env = tc_source_file () in - tc_result, mllib, env - -let tc_one_file_for_ide - (env:TcEnv.env_t) - (pre_fn:option string) //interface file name - (fn:string) //file name - (parsing_data:FStar.Parser.Dep.parsing_data) //threaded along, ONLY for caching purposes at this point - : tc_result - & TcEnv.env_t - = - let env = env_of_tcenv env in - let tc_result, _, env = tc_one_file env pre_fn fn parsing_data in - tc_result, (tcenv_of_uenv env) - -(***********************************************************************) -(* Batch mode: composing many files in the presence of pre-modules *) -(***********************************************************************) -let needs_interleaving intf impl = - let m1 = Parser.Dep.lowercase_module_name intf in - let m2 = Parser.Dep.lowercase_module_name impl in - m1 = m2 && - List.mem (FStar.Compiler.Util.get_file_extension intf) ["fsti"; "fsi"] && - List.mem (FStar.Compiler.Util.get_file_extension impl) ["fst"; "fs"] - -let tc_one_file_from_remaining (remaining:list string) (env:uenv) - (deps:FStar.Parser.Dep.deps) //used to query parsing data - : list string & tc_result & option MLSyntax.mllib & uenv - = - let remaining, (nmods, mllib, env) = - match remaining with - | intf :: impl :: remaining when needs_interleaving intf impl -> - let m, mllib, env = tc_one_file env (Some intf) impl - (impl |> FStar.Parser.Dep.parsing_data_of deps) in - remaining, (m, mllib, env) - | intf_or_impl :: remaining -> - let m, mllib, env = tc_one_file env None intf_or_impl - (intf_or_impl |> FStar.Parser.Dep.parsing_data_of deps) in - remaining, (m, mllib, env) - | [] -> failwith "Impossible: Empty remaining modules" - in - remaining, nmods, mllib, env - -let rec tc_fold_interleave (deps:FStar.Parser.Dep.deps) //used to query parsing data - (acc:list tc_result & - list (uenv & MLSyntax.mllib) & // initial env in which this module is extracted - uenv) - (remaining:list string) = - let as_list env mllib = - match mllib with - | None -> [] - | Some mllib -> [env, mllib] in - - match remaining with - | [] -> acc - | _ -> - let mods, mllibs, env_before = acc in - let remaining, nmod, mllib, env = tc_one_file_from_remaining remaining env_before deps in - if not (Options.profile_group_by_decl()) - then Profiling.report_and_clear (Ident.string_of_lid nmod.checked_module.name); - tc_fold_interleave deps (mods@[nmod], mllibs@(as_list env mllib), env) remaining - -(***********************************************************************) -(* Batch mode: checking many files *) -(***********************************************************************) -let dbg_dep = Debug.get_toggle "Dep" -let batch_mode_tc filenames dep_graph = - if !dbg_dep then begin - FStar.Compiler.Util.print_endline "Auto-deps kicked in; here's some info."; - FStar.Compiler.Util.print1 "Here's the list of filenames we will process: %s\n" - (String.concat " " filenames); - FStar.Compiler.Util.print1 "Here's the list of modules we will verify: %s\n" - (String.concat " " (filenames |> List.filter Options.should_verify_file)) - end; - let env = FStar.Extraction.ML.UEnv.new_uenv (init_env dep_graph) in - let all_mods, mllibs, env = tc_fold_interleave dep_graph ([], [], env) filenames in - if FStar.Errors.get_err_count() = 0 then - emit dep_graph mllibs; - let solver_refresh env = - snd <| - with_tcenv_of_env env (fun tcenv -> - if Options.interactive() - && FStar.Errors.get_err_count () = 0 - then tcenv.solver.refresh None - else tcenv.solver.finish(); - (), tcenv) - in - all_mods, env, solver_refresh diff --git a/src/fstar/FStar.Universal.fsti b/src/fstar/FStar.Universal.fsti deleted file mode 100644 index d9394a13fa6..00000000000 --- a/src/fstar/FStar.Universal.fsti +++ /dev/null @@ -1,87 +0,0 @@ -(* - Copyright 2008-2016 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -//Top-level invocations into the universal type-checker FStar.TypeChecker -module FStar.Universal - -open FStar open FStar.Compiler -open FStar.Ident -open FStar.CheckedFiles -module DsEnv = FStar.Syntax.DsEnv -module TcEnv = FStar.TypeChecker.Env -module Syntax = FStar.Syntax.Syntax -module Dep = FStar.Parser.Dep -module ParseIt = FStar.Parser.ParseIt - -type uenv = FStar.Extraction.ML.UEnv.uenv - -(* Takes a module an returns whether it is an interface or not, -and an lid for its name. *) -val module_or_interface_name : Syntax.modul -> bool & lid - -(* Uses the dsenv inside the TcEnv.env to run the computation. *) -val with_dsenv_of_tcenv : TcEnv.env -> DsEnv.withenv 'a -> 'a & TcEnv.env - -(* Initialize a clean environment, built from a dependency graph. The -graph is used to populate the internal dsenv of the tcenv. *) -val init_env : Dep.deps -> TcEnv.env - -val core_check: TcEnv.core_check_t - -type lang_decls_t = list FStar.Parser.AST.decl - -(* Interactive mode: checking a fragment of code. *) -val tc_one_fragment : - option Syntax.modul -> - TcEnv.env_t -> - either (FStar.Parser.ParseIt.input_frag & lang_decls_t) FStar.Parser.AST.decl -> - option Syntax.modul & TcEnv.env & lang_decls_t - -(* Load an interface file into the dsenv. *) -val load_interface_decls : - TcEnv.env -> - string -> - TcEnv.env_t - -(* Batch mode: check one file. *) -val tc_one_file : - uenv -> - option string -> - string -> - FStar.Parser.Dep.parsing_data -> - tc_result & option FStar.Extraction.ML.Syntax.mllib & uenv - -(* A thin wrapper for tc_one_file, called by the interactive mode. -Basically discards any information about extraction. *) -val tc_one_file_for_ide : - TcEnv.env_t -> - option string -> - string -> - FStar.Parser.Dep.parsing_data -> - tc_result & TcEnv.env_t - -(* [needs_interleaving s1 s2] is when s1 and s2 are (resp.) the filenames -for the interface and implementation of a (single) module. *) -val needs_interleaving : - string -> - string -> - bool - -(* Batch mode: check multiple files. *) -val batch_mode_tc : - list string -> - FStar.Parser.Dep.deps -> - list tc_result & uenv & (uenv -> uenv) diff --git a/src/fstar/FStarC.CheckedFiles.fst b/src/fstar/FStarC.CheckedFiles.fst new file mode 100644 index 00000000000..479a6b43362 --- /dev/null +++ b/src/fstar/FStarC.CheckedFiles.fst @@ -0,0 +1,492 @@ +(* + Copyright 2008-2018 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.CheckedFiles +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.Util + +open FStarC.Class.Show + +(* Module abbreviations for the universal type-checker *) +module Syntax = FStarC.Syntax.Syntax +module TcEnv = FStarC.TypeChecker.Env +module SMT = FStarC.SMTEncoding.Solver +module BU = FStarC.Compiler.Util +module Dep = FStarC.Parser.Dep + +let dbg = Debug.get_toggle "CheckedFiles" + +(* + * We write this version number to the cache files, and + * detect when loading the cache that the version number is same + * It needs to be kept in sync with Prims.fst + *) +let cache_version_number = 72 + +(* + * Abbreviation for what we store in the checked files (stages as described below) + *) +type checked_file_entry_stage1 = +{ + //cache version number + version: int; + + //digest of this source file to check if parsing data is valid + digest: string; + + //parsing data for this file + parsing_data: Parser.Dep.parsing_data +} + +type checked_file_entry_stage2 = +{ + //list of (file_name * digest) of direct dependences + //file_name is name of the source file and + //digest is that of the corresponding checked file + //except when the entries are for the current .fst and .fsti, + //digest is that of the source file + deps_dig: list (string & string); + + //typechecking result, including the smt encoding + tc_res: tc_result +} + +(* + * Local cache for checked files contents + * Note that a checked file could have valid parsing data but stale tc data + *) + +(* + * Cache files could be loaded in two steps + * + * Initially the dependence analysis is just interested in the parsing data + * and till that point we don't have the dependences sorted out, because of + * which we can't check the validity of tc data (since we need to check hashes + * of direct dependences etc.) + * + * So in this step, we read the checked file and mark the validity if tc data as Unknown + * + * Later on, we have figured the complete dependence graph, and want to load + * the tc data + * + * At that point, the cache is updated to either Valid or Invalid w.r.t. the tc data + *) +type tc_result_t = + | Unknown + | Invalid of string //reason why this is invalid + | Valid of string //digest of the checked file + +instance _ : showable tc_result_t = { + show = (function Unknown -> "Unknown" + | Invalid s -> "Invalid " ^ show s + | Valid s -> "Valid " ^ show s); +} + +(* + * The cache of checked files + *) +type cache_t = + tc_result_t & //tc data part + + //either: reason why this checked file is not valid for parsing data + //or : parsing_data + either string Dep.parsing_data + +//Internal cache +let mcache : smap cache_t = BU.smap_create 50 + +(* + * Either the reason because of which dependences are stale/invalid + * or the list of dep string, as defined in the checked_file_entry above + *) +let hash_dependences (deps:Dep.deps) (fn:string) :either string (list (string & string)) = + let fn = + match Find.find_file fn with + | Some fn -> fn + | _ -> fn + in + let module_name = Dep.lowercase_module_name fn in + let source_hash = BU.digest_of_file fn in + let has_interface = Option.isSome (Dep.interface_of deps module_name) in + let interface_checked_file_name = + if Dep.is_implementation fn + && has_interface + then module_name + |> Dep.interface_of deps + |> must + |> Dep.cache_file_name + |> Some + else None + in + let binary_deps = Dep.deps_of deps fn + |> List.filter (fun fn -> + not (Dep.is_interface fn && + Dep.lowercase_module_name fn = module_name)) in + let binary_deps = + FStarC.Compiler.List.sortWith + (fun fn1 fn2 -> + String.compare (Dep.lowercase_module_name fn1) + (Dep.lowercase_module_name fn2)) + binary_deps in + + let maybe_add_iface_hash out = + match interface_checked_file_name with + | None -> Inr (("source", source_hash)::out) + | Some iface -> + (match BU.smap_try_find mcache iface with + | None -> + let msg = BU.format1 + "hash_dependences::the interface checked file %s does not exist\n" + iface in + + if !dbg + then BU.print1 "%s\n" msg; + + Inl msg + | Some (Invalid msg, _) -> Inl msg + | Some (Valid h, _) -> Inr (("source", source_hash)::("interface", h)::out) + | Some (Unknown, _) -> + failwith (BU.format1 + "Impossible: unknown entry in the mcache for interface %s\n" + iface)) + in + + let rec hash_deps out = function + | [] -> maybe_add_iface_hash out + | fn::deps -> + let cache_fn = Dep.cache_file_name fn in + (* + * It is crucial to get the digest of fn from mcache, rather than computing it directly + * See #1668 + *) + let digest = + match BU.smap_try_find mcache cache_fn with + | None -> + let msg = BU.format2 "For dependency %s, cache file %s is not loaded" fn cache_fn in + if !dbg + then BU.print1 "%s\n" msg; + Inl msg + | Some (Invalid msg, _) -> Inl msg + | Some (Valid dig, _) -> Inr dig + | Some (Unknown, _) -> + failwith (BU.format2 + "Impossible: unknown entry in the cache for dependence %s of module %s" + fn module_name) + in + match digest with + | Inl msg -> Inl msg + | Inr dig -> + hash_deps ((Dep.lowercase_module_name fn, dig) :: out) deps + in + hash_deps [] binary_deps + +(* + * Load a checked file into mcache + * + * This is loading the parsing data, and tc data as Unknown (unless checked file is invalid) + * + * See above for the two steps of loading the checked files + *) +let load_checked_file (fn:string) (checked_fn:string) :cache_t = + if !dbg then + BU.print1 "Trying to load checked file result %s\n" checked_fn; + let elt = checked_fn |> BU.smap_try_find mcache in + if elt |> is_some then elt |> must //already loaded + else + let add_and_return elt = BU.smap_add mcache checked_fn elt; elt in + if not (BU.file_exists checked_fn) + then let msg = BU.format1 "checked file %s does not exist" checked_fn in + add_and_return (Invalid msg, Inl msg) + else let entry :option checked_file_entry_stage1 = BU.load_value_from_file checked_fn in + match entry with + | None -> + let msg = BU.format1 "checked file %s is corrupt" checked_fn in + add_and_return (Invalid msg, Inl msg) + | Some (x) -> + if x.version <> cache_version_number + then let msg = BU.format1 "checked file %s has incorrect version" checked_fn in + add_and_return (Invalid msg, Inl msg) + else let current_digest = BU.digest_of_file fn in + if x.digest <> current_digest + then begin + if !dbg then + BU.print4 "Checked file %s is stale since incorrect digest of %s, \ + expected: %s, found: %s\n" + checked_fn fn current_digest x.digest; + let msg = BU.format2 "checked file %s is stale (digest mismatch for %s)" checked_fn fn in + add_and_return (Invalid msg, Inl msg) + end + else add_and_return (Unknown, Inr x.parsing_data) + +let load_tc_result (checked_fn:string) : option (list (string & string) & tc_result) = + let entry : option (checked_file_entry_stage1 & checked_file_entry_stage2) = + BU.load_2values_from_file checked_fn + in + match entry with + | Some ((_,s2)) -> Some (s2.deps_dig, s2.tc_res) + | _ -> None + +(* + * Second step for loading checked files, validates the tc data + * Either the reason why tc_result is invalid + * or tc_result + *) +let load_checked_file_with_tc_result + (deps:Dep.deps) + (fn:string) + (checked_fn:string) + : either string tc_result += + if !dbg then + BU.print1 "Trying to load checked file with tc result %s\n" checked_fn; + + let load_tc_result' (fn:string) :list (string & string) & tc_result = + match load_tc_result fn with + | Some x -> x + | None -> failwith "Impossible! if first phase of loading was unknown, it should have succeeded" + in + + let elt = load_checked_file fn checked_fn in //first step, in case some client calls it directly + match elt with + | Invalid msg, _ -> Inl msg + | Valid _, _ -> checked_fn |> load_tc_result' |> snd |> Inr + | Unknown, parsing_data -> + match hash_dependences deps fn with + | Inl msg -> + let elt = (Invalid msg, parsing_data) in + BU.smap_add mcache checked_fn elt; + Inl msg + | Inr deps_dig' -> + let deps_dig, tc_result = checked_fn |> load_tc_result' in + if deps_dig = deps_dig' + then begin + //mark the tc data of the file as valid + let elt = (Valid (BU.digest_of_file checked_fn), parsing_data) in + BU.smap_add mcache checked_fn elt; + (* + * if there exists an interface for it, mark that too as valid + * this is specially needed for extraction invocations of F* with --cmi flag + * for example, consider a scenario: + * A.fst -> B.fsti -> Prims.fst + * ^ ^ + * | / + * B.fst + * + * when all the checked files are present and F* is invoked with --extract A --cmi + * during parsing, all checked files are loaded with tc data statemachine as Unknown + * since it is cmi (and say B has an inline_for_extraction symbol), the client + * then loads B.fst.checked BUT NOT B.fsti.checked + * this advances the state machine for B.fst, but not for B.fsti + * so when client loads A.fst.checked, B.fsti -- a dependence of A -- is still in Unknown + * following code relies on the invariant that: + * validity of implementaton tc data implies validity of iface tc data + * + * an alternative is to not do this, but in hash_dependences, if some dependence + * is in Unknown state, it could call load_checked_file_with_tc_result + *) + let validate_iface_cache () = + let iface = fn |> Dep.lowercase_module_name |> Dep.interface_of deps in + match iface with + | None -> () + | Some iface -> + try + let iface_checked_fn = iface |> Dep.cache_file_name in + match BU.smap_try_find mcache iface_checked_fn with + | Some (Unknown, parsing_data) -> + BU.smap_add mcache + iface_checked_fn + (Valid (BU.digest_of_file iface_checked_fn), parsing_data) + | _ -> () + with + | _ -> () + in + validate_iface_cache (); + Inr tc_result + end + else begin + if !dbg + then begin + BU.print4 "FAILING to load.\nExpected (%s) hashes:\n%s\n\nGot (%s) hashes:\n\t%s\n" + (BU.string_of_int (List.length deps_dig')) + (FStarC.Parser.Dep.print_digest deps_dig') + (BU.string_of_int (List.length deps_dig)) + (FStarC.Parser.Dep.print_digest deps_dig); + if List.length deps_dig = List.length deps_dig' + then List.iter2 (fun (x,y) (x', y') -> + if x<>x' || y<>y' + then BU.print2 "Differ at: Expected %s\n Got %s\n" + (FStarC.Parser.Dep.print_digest [(x,y)]) + (FStarC.Parser.Dep.print_digest [(x',y')])) deps_dig deps_dig' + end; + let msg = + BU.format1 + "checked file %s is stale (dependence hash mismatch, use --debug yes for more details)" + checked_fn + in + let elt = (Invalid msg, Inl msg) in + BU.smap_add mcache checked_fn elt; + Inl msg + end + + +let load_parsing_data_from_cache file_name = + (* + * the code below suppresses the already_cached assertion failure + * following is the reason for it: + * + * consider a scenario: + * A.fst -> B.fsti -> Prims.fst + * ^ ^ + * | / + * B.fst + * + * the dependence analysis marks B.fsti as a dependence of A.fst + * so when we use the makefiles to build this, + * makefile could first build prims, then B.fsti, and then tried to build A.fst + * with: fstar.exe A.fst already_cached '* -A' + * now F* starts to build the dependence graph for A + * it sees that A depends on B, so it reads the parsing data + * of B.fsti from its existing checked file + * however, the dependence analysis ALSO reads B.fst so as to detect cycles + * and calls load_parsing_data_from_cache_file with B.fst + * clearly until this point, B.fst has not been checked and so its checked file doesn't exist + * so cache_file_name raises an exception since B is in the already_cached list + * + * suppressing the exception here is not too bad since this exception is raised at other places + * e.g. when loading the checked file for typechecking purposes + * + * another way to handle this kind of thing would be to NOT load B.fst for cycle detection, + * rather provide a separate F* command --detect_cycles --alredy_cached '*' that builds + * can invoke in the end for cycle detection + *) + Errors.with_ctx ("While loading parsing data from " ^ file_name) (fun () -> + let cache_file = + try + Parser.Dep.cache_file_name file_name |> Some + with _ -> None + in + match cache_file with + | None -> None + | Some cache_file -> + match load_checked_file file_name cache_file with + | _, Inl msg -> None + | _, Inr data -> Some data + ) + +let load_module_from_cache = + //this is only used for supressing more than one cache invalid warnings + let already_failed = BU.mk_ref false in + fun env fn -> Errors.with_ctx ("While loading module from file " ^ fn) (fun () -> + let load_it fn () = + let cache_file = Dep.cache_file_name fn in + let fail msg cache_file = + //Don't feel too bad if fn is the file on the command line + //Also suppress the warning if already given to avoid a deluge + let suppress_warning = Options.should_check_file fn || !already_failed in + if not suppress_warning then begin + already_failed := true; + FStarC.Errors.log_issue (Range.mk_range fn (Range.mk_pos 0 0) (Range.mk_pos 0 0)) + Errors.Warning_CachedFile [Errors.text (BU.format3 + "Unable to load %s since %s; will recheck %s (suppressing this warning for further modules)" + cache_file msg fn) + ] + end + in + match load_checked_file_with_tc_result + (TcEnv.dep_graph env) + fn + cache_file with + | Inl msg -> fail msg cache_file; None + | Inr tc_result -> + if !dbg then + BU.print1 "Successfully loaded module from checked file %s\n" cache_file; + Some tc_result + (* | _ -> failwith "load_checked_file_tc_result must have an Invalid or Valid entry" *) + in + + (* + * AR: cf. #1919, A.fst.checked implicitly depends on A.fsti.checked + * and thus, transitively on the dependencies of A.fsti.checked + * the dependency on A.fsti.checked is unusual in the sense that + * tcenv is not populated with its contents + * that happens via interleaving later + * this is just to make sure that we correctly track the dependence of A.fst + * on the dependences of A.fsti + *) + + let load_with_profiling fn = Profiling.profile + (load_it fn) + None + "FStarC.CheckedFiles" in + + let i_fn_opt = Dep.interface_of + (TcEnv.dep_graph env) + (Dep.lowercase_module_name fn) in + + if Dep.is_implementation fn + && (i_fn_opt |> is_some) + then let i_fn = i_fn_opt |> must in + let i_tc = load_with_profiling i_fn in + match i_tc with + | None -> None + | Some _ -> load_with_profiling fn + + else load_with_profiling fn + ) + +(* + * Just to make sure data has the right type + *) +let store_values_to_cache + (cache_file:string) + (stage1:checked_file_entry_stage1) + (stage2:checked_file_entry_stage2) + :unit = + Errors.with_ctx ("While writing checked file " ^ cache_file) (fun () -> + BU.save_2values_to_file cache_file stage1 stage2) + +let store_module_to_cache env fn parsing_data tc_result = + if Options.cache_checked_modules() + && not (Options.cache_off()) + then begin + let cache_file = FStarC.Parser.Dep.cache_file_name fn in + let digest = hash_dependences (TcEnv.dep_graph env) fn in + match digest with + | Inr hashes -> + let tc_result = { tc_result with tc_time=0; extraction_time=0 } in + + let stage1 = {version=cache_version_number; digest=(BU.digest_of_file fn); parsing_data=parsing_data} in + let stage2 = {deps_dig=hashes; tc_res=tc_result} in + store_values_to_cache cache_file stage1 stage2 + | Inl msg -> + let open FStarC.Errors in + let open FStarC.Errors.Msg in + let open FStarC.Pprint in + log_issue (FStarC.Compiler.Range.mk_range fn (FStarC.Compiler.Range.mk_pos 0 0) + (FStarC.Compiler.Range.mk_pos 0 0)) + Errors.Warning_FileNotWritten [ + text <| BU.format1 "Checked file %s was not written." cache_file; + prefix 2 1 (doc_of_string "Reason:") (text msg) + ] + end + +let unsafe_raw_load_checked_file (checked_fn:string) + = let entry : option (checked_file_entry_stage1 & checked_file_entry_stage2) = BU.load_2values_from_file checked_fn in + match entry with + | Some ((s1,s2)) -> Some (s1.parsing_data, List.map fst s2.deps_dig, s2.tc_res) + | _ -> None diff --git a/src/fstar/FStarC.CheckedFiles.fsti b/src/fstar/FStarC.CheckedFiles.fsti new file mode 100644 index 00000000000..3c0d41e83f6 --- /dev/null +++ b/src/fstar/FStarC.CheckedFiles.fsti @@ -0,0 +1,70 @@ +(* + Copyright 2008-2018 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.CheckedFiles +open FStarC.Compiler.Effect +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.TypeChecker.Env +open FStarC.Syntax + +module Syntax = FStarC.Syntax.Syntax +module Dep = FStarC.Parser.Dep +module TcEnv = FStarC.TypeChecker.Env + +val cache_version_number : int + +(* + * This is what is returned when clients read a module from the caches + *) +type tc_result = { + checked_module: Syntax.modul; //persisted + mii:DsEnv.module_inclusion_info; //persisted + smt_decls:(FStarC.SMTEncoding.Term.decls_t & //list of smt decls and fvbs for the module + list FStarC.SMTEncoding.Env.fvar_binding); //persisted + + tc_time:int; + extraction_time:int +} + +val load_tc_result (checked_fn:string) : option (list (string & string) & tc_result) + +val load_checked_file_with_tc_result + (deps:Dep.deps) + (fn:string) + (checked_fn:string) + : either string tc_result + +(* + * Read parsing data from the checked file + * This function is passed as a callback to Parser.Dep + * + * Input is the file name, not the cache file name + * The function computes the cache file name itself + *) +val load_parsing_data_from_cache: file_name:string -> option Parser.Dep.parsing_data + +(***********************************************************************) +(* Loading and storing cache files *) +(***********************************************************************) + +val load_module_from_cache: TcEnv.env -> string -> option tc_result + +val store_module_to_cache: TcEnv.env -> file_name:string -> Dep.parsing_data -> tc_result -> unit + +val unsafe_raw_load_checked_file (checked_file_name:string) + : option (FStarC.Parser.Dep.parsing_data & list string & tc_result) diff --git a/src/fstar/FStarC.Dependencies.fst b/src/fstar/FStarC.Dependencies.fst new file mode 100644 index 00000000000..0cb89b359f4 --- /dev/null +++ b/src/fstar/FStarC.Dependencies.fst @@ -0,0 +1,44 @@ +(* + Copyright 2008-2016 Jonathan Protzenko, Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +// A dependency-finding routine +module FStarC.Dependencies +open FStarC.Compiler.Effect +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.Getopt +open FStarC.Ident + +(***********************************************************************) +(* Finding the transitive dependencies of a list of files *) +(***********************************************************************) + +(* + * get_parsing_data_from_cache is a callback passed to Parser.Dep for + * getting deps from the checked files + *) +let find_deps_if_needed files + (get_parsing_data_from_cache:string -> option Parser.Dep.parsing_data) + = let all_files, deps = Parser.Dep.collect files get_parsing_data_from_cache in + match all_files with + | [] -> + Errors.log_issue0 Errors.Error_DependencyAnalysisFailed "Dependency analysis failed; reverting to using only the files provided"; + files, + deps + | _ -> + List.rev all_files, + deps diff --git a/src/fstar/FStarC.Interactive.CompletionTable.fst b/src/fstar/FStarC.Interactive.CompletionTable.fst new file mode 100644 index 00000000000..bbc0fa5cc49 --- /dev/null +++ b/src/fstar/FStarC.Interactive.CompletionTable.fst @@ -0,0 +1,487 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Interactive.CompletionTable + +open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect + +let string_compare s1 s2 = + String.compare s1 s2 + +(** * (Pairing) min-heaps * **) + +type heap 'a = +| EmptyHeap +| Heap of 'a & list (heap 'a) + +let heap_merge cmp h1 h2 = + match h1, h2 with + | EmptyHeap, h + | h, EmptyHeap -> h + | Heap (v1, hh1), Heap (v2, hh2) -> + if cmp v1 v2 < 0 then Heap (v1, h2 :: hh1) else Heap (v2, h1 :: hh2) + +let heap_insert cmp h v = + heap_merge cmp (Heap (v, [])) h + +let rec heap_merge_pairs cmp = function + | [] -> EmptyHeap + | [h] -> h + | h1 :: h2 :: hh -> + heap_merge cmp (heap_merge cmp h1 h2) (heap_merge_pairs cmp hh) + +let heap_peek = function + | EmptyHeap -> None + | Heap (v, _) -> Some v + +let heap_pop cmp = function + | EmptyHeap -> None + | Heap (v, hh) -> Some (v, heap_merge_pairs cmp hh) + +let heap_from_list cmp values = + List.fold_left (heap_insert cmp) EmptyHeap values + +(** * List functions * **) + +let push_nodup key_fn x = function + | [] -> [x] + | h :: t -> if string_compare (key_fn x) (key_fn h) = 0 then h :: t else x :: h :: t + +let rec add_priorities n acc = function + | [] -> acc + | h :: t -> add_priorities (n + 1) ((n, h) :: acc) t + +(** Merge ‘lists’, a list of increasing (according to ‘key_fn’) lists. + Keeps a single copy of each key that appears in more than one list (earlier + lists take precedence when chosing which value to keep). *) +let merge_increasing_lists_rev (key_fn: 'a -> string) (lists: list (list 'a)) = + let cmp v1 v2 = + match v1, v2 with + | (_, []), _ | _, (_, []) -> failwith "impossible" + | (pr1, h1 :: _), (pr2, h2 :: _) -> + let cmp_h = string_compare (key_fn h1) (key_fn h2) in + if cmp_h <> 0 then cmp_h else pr1 - pr2 in + let rec aux (lists: heap (int & list 'a)) (acc: list 'a) = + match heap_pop cmp lists with + | None -> acc + | Some ((pr, []), _) -> failwith "impossible" + | Some ((pr, [v]), lists) -> aux lists (push_nodup key_fn v acc) + | Some ((pr, v :: tl), lists) -> aux (heap_insert cmp lists (pr, tl)) (push_nodup key_fn v acc) in + let lists = List.filter (fun x -> x <> []) lists in + match lists with + | [] -> [] | [l] -> List.rev l + | _ -> + let lists = add_priorities 0 [] lists in + aux (heap_from_list cmp lists) [] + +(** * Binary trees * **) + +type btree 'a = +| StrEmpty +| StrBranch of string & 'a & (btree 'a) & (btree 'a) +(* (key: string) * (value: 'a) * (lbt: btree 'a) * (rbt: btree 'a) *) + +let rec btree_to_list_rev (btree:btree 'a) (acc:list (string & 'a)) + : list (string & 'a) = + match btree with + | StrEmpty -> acc + | StrBranch (key, value, lbt, rbt) -> + btree_to_list_rev rbt ((key, value) :: btree_to_list_rev lbt acc) + +let rec btree_from_list (nodes:list (string & 'a)) (size:int) + : btree 'a & list (string & 'a) = + if size = 0 then (StrEmpty, nodes) + else + let lbt_size = size / 2 in + let rbt_size = size - lbt_size - 1 in + let lbt, nodes_left = btree_from_list nodes lbt_size in + match nodes_left with + | [] -> failwith "Invalid size passed to btree_from_list" + | (k, v) :: nodes_left -> + let rbt, nodes_left = btree_from_list nodes_left rbt_size in + StrBranch (k, v, lbt, rbt), nodes_left + +let rec btree_insert_replace (bt: btree 'a) (k: string) (v: 'a) : btree 'a = + match bt with + | StrEmpty -> StrBranch (k, v, StrEmpty, StrEmpty) + | StrBranch (k', v', lbt, rbt) -> + let cmp = string_compare k k' in + if cmp < 0 then + StrBranch (k', v', btree_insert_replace lbt k v, rbt) + else if cmp > 0 then + StrBranch (k', v', lbt, btree_insert_replace rbt k v) + else + StrBranch (k', v, lbt, rbt) + +let rec btree_find_exact (bt: btree 'a) (k: string) : option 'a = + match bt with + | StrEmpty -> None + | StrBranch (k', v, lbt, rbt) -> + let cmp = string_compare k k' in + if cmp < 0 then + btree_find_exact lbt k + else if cmp > 0 then + btree_find_exact rbt k + else + Some v + +let rec btree_extract_min (bt: btree 'a) : option (string & 'a & btree 'a) = + match bt with + | StrEmpty -> None + | StrBranch (k, v, StrEmpty, rbt) -> Some (k, v, rbt) + | StrBranch (_, _, lbt, _) -> btree_extract_min lbt + +let rec btree_remove (bt: btree 'a) (k: string) : btree 'a = + match bt with + | StrEmpty -> StrEmpty + | StrBranch (k', v, lbt, rbt) -> + let cmp = string_compare k k' in + if cmp < 0 then + StrBranch (k', v, btree_remove lbt k, rbt) + else if cmp > 0 then + StrBranch (k', v, lbt, btree_remove rbt k) + else + match lbt with + | StrEmpty -> bt + | _ -> match btree_extract_min rbt with + | None -> lbt + | Some (rbt_min_k, rbt_min_v, rbt') -> + StrBranch (rbt_min_k, rbt_min_v, lbt, rbt') + +type prefix_match = + { prefix: option string; + completion: string } + +type path_elem = + { imports: list string; + segment: prefix_match } + +let matched_prefix_of_path_elem (elem: path_elem) = elem.segment.prefix + +let mk_path_el imports segment = { imports = imports; segment = segment } + +let btree_find_prefix (bt: btree 'a) (prefix: string) + : list (prefix_match & 'a) (* ↑ keys *) = + let rec aux (bt: btree 'a) (prefix: string) (acc: list (prefix_match & 'a)) : list (prefix_match & 'a) = + match bt with + | StrEmpty -> acc + | StrBranch (k, v, lbt, rbt) -> + let cmp = string_compare k prefix in + let include_middle = Util.starts_with k prefix in + let explore_right = cmp <= 0 || include_middle in + let explore_left = cmp > 0 in + let matches = + if explore_right then aux rbt prefix acc else acc in + let matches = + if include_middle then + ({ prefix = Some prefix; completion = k }, v) :: matches + else + matches in + let matches = + if explore_left then aux lbt prefix matches else matches in + matches in + aux bt prefix [] + +let rec btree_fold (bt: btree 'a) (f: string -> 'a -> 'b -> 'b) (acc: 'b) = + match bt with + | StrEmpty -> acc + | StrBranch (k, v, lbt, rbt) -> + btree_fold lbt f (f k v (btree_fold rbt f acc)) + +(** * Tries * **) + + +let query_to_string q = String.concat "." q + +type name_collection 'a = +| Names of btree 'a +| ImportedNames of string & names 'a +and names 'a = list (name_collection 'a) + +type trie (a:Type0) = + { bindings: names a; + namespaces: names (trie a) } + +let trie_empty = { bindings = []; namespaces = [] } + +let rec names_find_exact (names: names 'a) (ns: string) : option 'a = + let result, names = + match names with + | [] -> None, None + | Names bt :: names -> + btree_find_exact bt ns, Some names + | ImportedNames (_, names) :: more_names -> + names_find_exact names ns, Some more_names in + match result, names with + | None, Some scopes -> names_find_exact scopes ns + | _ -> result + +let rec trie_descend_exact (tr: trie 'a) (query: query) : option (trie 'a) = + match query with + | [] -> Some tr + | ns :: query -> + Util.bind_opt (names_find_exact tr.namespaces ns) + (fun scope -> trie_descend_exact scope query) + +let rec trie_find_exact (tr: trie 'a) (query: query) : option 'a = + match query with + | [] -> failwith "Empty query in trie_find_exact" + | [name] -> names_find_exact tr.bindings name + | ns :: query -> + Util.bind_opt (names_find_exact tr.namespaces ns) + (fun scope -> trie_find_exact scope query) + +let names_insert (name_collections: names 'a) (id: string) (v: 'a) : names 'a = + let bt, name_collections = + match name_collections with + | Names bt :: tl -> (bt, tl) + | _ -> (StrEmpty, name_collections) in + Names (btree_insert_replace bt id v) :: name_collections + +let rec namespaces_mutate (namespaces: names (trie 'a)) (ns: string) (q: query) + (rev_acc: query) + (mut_node: trie 'a -> string -> query -> query -> names (trie 'a) -> trie 'a) + (mut_leaf: trie 'a -> query -> trie 'a)= + let trie = Util.dflt trie_empty (names_find_exact namespaces ns) in + names_insert namespaces ns (trie_mutate trie q rev_acc mut_node mut_leaf) + +and trie_mutate (tr: trie 'a) (q: query) (rev_acc: query) + (mut_node: trie 'a -> string -> query -> query -> names (trie 'a) -> trie 'a) + (mut_leaf: trie 'a -> query -> trie 'a) : trie 'a = + match q with + | [] -> + mut_leaf tr rev_acc + | id :: q -> + let ns' = namespaces_mutate tr.namespaces id q (id :: rev_acc) mut_node mut_leaf in + mut_node tr id q rev_acc ns' + +let trie_mutate_leaf (tr: trie 'a) (query: query) = + trie_mutate tr query [] (fun tr _ _ _ namespaces -> { tr with namespaces = namespaces }) + +let trie_insert (tr: trie 'a) (ns_query: query) (id: string) (v: 'a) : trie 'a = + trie_mutate_leaf tr ns_query (fun tr _ -> { tr with bindings = names_insert tr.bindings id v }) + +let trie_import (tr: trie 'a) (host_query: query) (included_query: query) + (mutator: trie 'a -> trie 'a -> string -> trie 'a) = + let label = query_to_string included_query in + let included_trie = Util.dflt trie_empty (trie_descend_exact tr included_query) in + trie_mutate_leaf tr host_query (fun tr _ -> mutator tr included_trie label) + +let trie_include (tr: trie 'a) (host_query: query) (included_query: query) + : trie 'a = + trie_import tr host_query included_query (fun tr inc label -> + { tr with bindings = ImportedNames (label, inc.bindings) :: tr.bindings }) + +let trie_open_namespace (tr: trie 'a) (host_query: query) (included_query: query) + : trie 'a = + trie_import tr host_query included_query (fun tr inc label -> + { tr with namespaces = ImportedNames (label, inc.namespaces) :: tr.namespaces }) + +let trie_add_alias (tr: trie 'a) (key: string) + (host_query: query) (included_query: query) : trie 'a = + trie_import tr host_query included_query (fun tr inc label -> + // Very similar to an include, but aliasing A.B as M in A.C entirely + // overrides A.B.M, should that also exists. Doing this makes sense + // because we only process aliases in the current module. + trie_mutate_leaf tr [key] (fun _ignored_overwritten_trie _ -> + { bindings = [ImportedNames (label, inc.bindings)]; namespaces = [] })) + +let names_revmap (fn: btree 'a -> 'b) (name_collections: names 'a (* ↓ priority *)) + : list (list string (* imports *) & 'b) (* ↑ priority *) = + let rec aux (acc: list (list string & 'b)) + (imports: list string) (name_collections: names 'a) + : list (list string & 'b) (* #1158 *) = + List.fold_left (fun acc -> function + | Names bt -> (imports, fn bt) :: acc + | ImportedNames (nm, name_collections) -> + aux acc (nm :: imports) name_collections) + acc name_collections in + aux [] [] name_collections + +let btree_find_all (prefix: option string) (bt: btree 'a) + : list (prefix_match & 'a) (* ↑ keys *) = + btree_fold bt (fun k tr acc -> + ({ prefix = prefix; completion = k }, tr) :: acc) [] + +type name_search_term = +| NSTAll +| NSTNone +| NSTPrefix of string + +let names_find_rev (names: names 'a) (id: name_search_term) : list (path_elem & 'a) = + let matching_values_per_collection_with_imports = + match id with + | NSTNone -> [] + | NSTAll -> names_revmap (btree_find_all None) names + | NSTPrefix "" -> names_revmap (btree_find_all (Some "")) names + | NSTPrefix id -> names_revmap (fun bt -> btree_find_prefix bt id) names in + let matching_values_per_collection = + List.map (fun (imports, matches) -> + List.map (fun (segment, v) -> mk_path_el imports segment, v) matches) + matching_values_per_collection_with_imports in + merge_increasing_lists_rev + (fun (path_el, _) -> path_el.segment.completion) matching_values_per_collection + +let rec trie_find_prefix' (tr: trie 'a) (path_acc: path) + (query: query) (acc: list (path & 'a)) + : list (path & 'a) = + let ns_search_term, bindings_search_term, query = + match query with + | [] -> NSTAll, NSTAll, [] + | [id] -> NSTPrefix id, NSTPrefix id, [] + | ns :: query -> NSTPrefix ns, NSTNone, query in + + let matching_namespaces_rev = names_find_rev tr.namespaces ns_search_term in + let acc_with_recursive_bindings = + List.fold_left (fun acc (path_el, trie) -> + trie_find_prefix' trie (path_el :: path_acc) query acc) + acc matching_namespaces_rev in + + let matching_bindings_rev = names_find_rev tr.bindings bindings_search_term in + List.rev_map_onto (fun (path_el, v) -> (List.rev (path_el :: path_acc), v)) + matching_bindings_rev acc_with_recursive_bindings + +let trie_find_prefix (tr: trie 'a) (query: query) : list (path & 'a) = + trie_find_prefix' tr [] query [] + +(** * High level interface * **) + +let mod_name md = md.mod_name + +type symbol = +| ModOrNs of mod_symbol +| Lid of lid_symbol + +type table = + { tbl_lids: trie lid_symbol; + tbl_mods: trie mod_symbol } + +let empty : table = + { tbl_lids = trie_empty; + tbl_mods = trie_empty } + +// Note that we never add aliases to tbl_mods: we use tbl_mods only for +// completion of opens and includes, and these take full module paths. +// Inclusions handling would have to be reinstated should we wish to also +// complete partial names of unloaded (e.g. [open FStar // let x = List._] when +// FStarC.Compiler.List isn't loaded). + +let insert (tbl: table) (host_query: query) (id: string) (c: lid_symbol) : table = + { tbl with tbl_lids = trie_insert tbl.tbl_lids host_query id c } + +let register_alias (tbl: table) (key: string) (host_query: query) (included_query: query) : table = + { tbl with tbl_lids = trie_add_alias tbl.tbl_lids key host_query included_query } + +let register_include (tbl: table) (host_query: query) (included_query: query) : table = + { tbl with tbl_lids = trie_include tbl.tbl_lids host_query included_query } + +let register_open (tbl: table) (is_module: bool) (host_query: query) (included_query: query) : table = + if is_module then + // We only process module opens for the current module, where they are just like includes + register_include tbl host_query included_query + else + { tbl with tbl_lids = trie_open_namespace tbl.tbl_lids host_query included_query } + +let register_module_path (tbl: table) (loaded: bool) (path: string) (mod_query: query) = + let ins_ns id bindings full_name loaded = + match names_find_exact bindings id, loaded with + | None, _ // Never seen before + | Some (Namespace { ns_loaded = false }), true -> // Seen, but not loaded yet + names_insert bindings id + (Namespace ({ ns_name = full_name; ns_loaded = loaded })) + | Some _, _ -> // Already seen as a loaded namespace, or as a module + bindings in + let ins_mod id bindings full_name loaded = + names_insert bindings id + (Module ({ mod_name = full_name; mod_loaded = loaded; mod_path = path })) in + let name_of_revq query = + String.concat "." (List.rev query) in + let ins id q revq bindings loaded = + let name = name_of_revq (id :: revq) in + match q with + | [] -> ins_mod id bindings name loaded + | _ -> ins_ns id bindings name loaded in + { tbl with tbl_mods = + trie_mutate tbl.tbl_mods mod_query [] (fun tr id q revq namespaces -> + { tr with namespaces = namespaces; + bindings = ins id q revq tr.bindings loaded }) + (fun tr _ -> tr) } + +let string_of_path (path: path) : string = + String.concat "." (List.map (fun el -> el.segment.completion) path) + +let match_length_of_path (path: path) : int = + let length, (last_prefix, last_completion_length) = + List.fold_left + (fun acc elem -> + let (acc_len, _) = acc in + match elem.segment.prefix with + | Some prefix -> + let completion_len = String.length elem.segment.completion in + (acc_len + 1 (* ‘.’ *) + completion_len, (prefix, completion_len)) + | None -> acc) + (0, ("", 0)) path in + length + - 1 (* extra ‘.’ *) + - last_completion_length + + (String.length last_prefix) (* match stops after last prefix *) + +let first_import_of_path (path: path) : option string = + match path with + | [] -> None + | { imports = imports } :: _ -> List.last_opt imports + +let alist_of_ns_info ns_info = + [("name", Json.JsonStr ns_info.ns_name); + ("loaded", Json.JsonBool ns_info.ns_loaded)] + +let alist_of_mod_info mod_info = + [("name", Json.JsonStr mod_info.mod_name); + ("path", Json.JsonStr mod_info.mod_path); + ("loaded", Json.JsonBool mod_info.mod_loaded)] + +let json_of_completion_result (result: completion_result) = + Json.JsonList [Json.JsonInt result.completion_match_length; + Json.JsonStr result.completion_annotation; + Json.JsonStr result.completion_candidate] + +let completion_result_of_lid (path, _lid) = + { completion_match_length = match_length_of_path path; + completion_candidate = string_of_path path; + completion_annotation = Util.dflt "" (first_import_of_path path) } + +let completion_result_of_mod annot loaded path = + { completion_match_length = match_length_of_path path; + completion_candidate = string_of_path path; + completion_annotation = Util.format1 (if loaded then " %s " else "(%s)") annot } + +let completion_result_of_ns_or_mod (path, symb) = + match symb with + | Module { mod_loaded = loaded } -> completion_result_of_mod "mod" loaded path + | Namespace { ns_loaded = loaded } -> completion_result_of_mod "ns" loaded path + +let find_module_or_ns (tbl:table) (query:query) = + trie_find_exact tbl.tbl_mods query + +let autocomplete_lid (tbl: table) (query: query) = + List.map completion_result_of_lid (trie_find_prefix tbl.tbl_lids query) + +let autocomplete_mod_or_ns (tbl: table) (query: query) (filter: (path & mod_symbol) -> option (path & mod_symbol)) = + trie_find_prefix tbl.tbl_mods query + |> List.filter_map filter + |> List.map completion_result_of_ns_or_mod diff --git a/src/fstar/FStarC.Interactive.CompletionTable.fsti b/src/fstar/FStarC.Interactive.CompletionTable.fsti new file mode 100644 index 00000000000..f5c87bbe761 --- /dev/null +++ b/src/fstar/FStarC.Interactive.CompletionTable.fsti @@ -0,0 +1,63 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Interactive.CompletionTable + +val path_elem : Type0 +type path = list path_elem +val matched_prefix_of_path_elem : path_elem -> option string + +type query = list string + +type ns_info = { ns_name: string; + ns_loaded: bool } +type mod_info = { mod_name: string; + mod_path: string; + mod_loaded: bool } + +val mod_name : mod_info -> string // F# doesn't like md.CompletionTable.mod_name + +type mod_symbol = +| Module of mod_info +| Namespace of ns_info + +type lid_symbol = FStarC.Ident.lid + +val trie (a:Type0) : Type0 + +val table : Type0 + +val empty : table +val insert : tbl:table -> host_query:query -> id:string -> c:lid_symbol -> table +val register_alias : tbl:table -> key:string -> host_query:query -> included_query:query -> table +val register_open : tbl:table -> is_module:bool -> host_query:query -> included_query:query -> table +val register_include : tbl:table -> host_query:query -> included_query:query -> table +val register_module_path : tbl:table -> loaded:bool -> mod_path:string -> mod_query:query -> table + +val alist_of_ns_info : ns_info -> list (string & FStarC.Json.json) +val alist_of_mod_info : mod_info -> list (string & FStarC.Json.json) + +type completion_result = + { completion_match_length: int; + completion_candidate: string; + completion_annotation: string } +val json_of_completion_result : completion_result -> FStarC.Json.json + +val find_module_or_ns : + tbl:table -> query:query -> option mod_symbol +val autocomplete_lid : + tbl:table -> query:query -> list completion_result +val autocomplete_mod_or_ns : + tbl:table -> query:query -> filter:((path & mod_symbol) -> option (path & mod_symbol)) -> list completion_result diff --git a/src/fstar/FStarC.Interactive.Ide.Types.fst b/src/fstar/FStarC.Interactive.Ide.Types.fst new file mode 100644 index 00000000000..b032e8ebdce --- /dev/null +++ b/src/fstar/FStarC.Interactive.Ide.Types.fst @@ -0,0 +1,367 @@ +(* + Copyright 2008-2016 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Interactive.Ide.Types +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Range +open FStarC.Compiler.Util +open FStarC.Getopt +open FStarC.Ident +open FStarC.Errors +open FStarC.Interactive.JsonHelper + +open FStarC.Universal +open FStarC.TypeChecker.Env +open FStarC.TypeChecker.Common +open FStarC.Interactive +open FStarC.Parser.ParseIt +open FStarC.Class.Show + +module SS = FStarC.Syntax.Syntax +module DsEnv = FStarC.Syntax.DsEnv +module TcErr = FStarC.TypeChecker.Err +module TcEnv = FStarC.TypeChecker.Env +module CTable = FStarC.Interactive.CompletionTable +module PI = FStarC.Parser.ParseIt +module U = FStarC.Compiler.Util + +(* Importing this module bring FStarC.Json into scope. *) +include FStarC.Json + +(***********************) +(* Global state setup *) +(***********************) +let initial_range = + Range.mk_range "" (Range.mk_pos 1 0) (Range.mk_pos 1 0) + + + +type completion_context = +| CKCode +| CKOption of bool (* #set-options (false) or #reset-options (true) *) +| CKModuleOrNamespace of bool (* modules *) & bool (* namespaces *) + +type lookup_context = +| LKSymbolOnly +| LKModule +| LKOption +| LKCode + +type position = string & int & int + +type push_kind = | SyntaxCheck | LaxCheck | FullCheck + +type push_query = + { + push_kind: push_kind; + push_line: int; + push_column: int; + push_peek_only: bool; + //Either a string: Just the raw content of a document fragment + //Or a parsed document fragment and the raw content it corresponds to + push_code_or_decl: either string (FStarC.Parser.AST.decl & PI.code_fragment) + } + +type lookup_symbol_range = json + +type query_status = | QueryOK | QueryNOK | QueryViolatesProtocol + +(* Types concerning repl *) +type repl_depth_t = TcEnv.tcenv_depth_t & int +type optmod_t = option Syntax.Syntax.modul + +type timed_fname = + { tf_fname: string; + tf_modtime: time } + +(** Every snapshot pushed in the repl stack is annotated with one of these. The +``LD``-prefixed (“Load Dependency”) onces are useful when loading or updating +dependencies, as they carry enough information to determine whether a dependency +is stale. **) +type repl_task = + | LDInterleaved of timed_fname & timed_fname (* (interface * implementation) *) + | LDSingle of timed_fname (* interface or implementation *) + | LDInterfaceOfCurrentFile of timed_fname (* interface *) + | PushFragment of either PI.input_frag FStarC.Parser.AST.decl (* code fragment *) + & push_kind (* FullCheck, LaxCheck, SyntaxCheck *) + & list json (* any warnings that were raised while checking this fragment *) + | Noop (* Used by compute, PushPartialCheckedFile *) + +type full_buffer_request_kind = + | Full : full_buffer_request_kind + | Lax : full_buffer_request_kind + | Cache : full_buffer_request_kind + | ReloadDeps : full_buffer_request_kind + | VerifyToPosition of position + | LaxToPosition of position + +type query' = +| Exit +| DescribeProtocol +| DescribeRepl +| Segment of string (* File contents *) +| Pop +| Push of push_query +| PushPartialCheckedFile of string (* long declaration name *) +| VfsAdd of option string (* fname *) & string (* contents *) +| AutoComplete of string & completion_context +| Lookup of string & lookup_context & option position & list string & option lookup_symbol_range +| Compute of string & option (list FStarC.TypeChecker.Env.step) +| Search of string +| GenericError of string +| ProtocolViolation of string +// FullBuffer: To check the full contents of a document. +// FStarC.Interactive.Incremental parses it into chunks and turns this into several Push queries +| FullBuffer of string & full_buffer_request_kind & bool //bool is with_symbol +// Callback: This is an internal query, it cannot be raised by a client. +// It is useful to inject operations into the query stream. +// e.g., Incremental uses it print progress messages to the client in between +// processing a stream of Pushes that result from a chunking a FullBuffer +| Callback of callback_t +// Format: pretty-print the F* code in the selection +| Format of string +| RestartSolver +// Cancel: Cancel any remaining pushes that are at or beyond the provided position. +// Cancel all requests if the position is None +| Cancel of option position +and query = { qq: query'; qid: string } +and callback_t = repl_state -> (query_status & list json) & either repl_state int +and repl_state = { + repl_line: int; + repl_column: int; + repl_fname: string; + repl_deps_stack: repl_stack_t; + repl_curmod: optmod_t; + repl_env: TcEnv.env; + repl_stdin: stream_reader; + repl_names: CTable.table; + repl_buffered_input_queries: list query; + repl_lang:FStarC.Universal.lang_decls_t; +} +and repl_stack_t = list repl_stack_entry_t +and repl_stack_entry_t = repl_depth_t & (repl_task & repl_state) + +// Global repl_state, keeping state of different buffers +type grepl_state = { grepl_repls: U.psmap repl_state; grepl_stdin: stream_reader } + + +(*************************) +(* REPL tasks and states *) +(*************************) + +let t0 = Util.now () + +(** Create a timed_fname with a dummy modtime **) +let dummy_tf_of_fname fname = + { tf_fname = fname; + tf_modtime = t0 } + +let string_of_timed_fname { tf_fname = fname; tf_modtime = modtime } = + if modtime = t0 then Util.format1 "{ %s }" fname + else Util.format2 "{ %s; %s }" fname (string_of_time modtime) + +let string_of_repl_task = function + | LDInterleaved (intf, impl) -> + Util.format2 "LDInterleaved (%s, %s)" (string_of_timed_fname intf) (string_of_timed_fname impl) + | LDSingle intf_or_impl -> + Util.format1 "LDSingle %s" (string_of_timed_fname intf_or_impl) + | LDInterfaceOfCurrentFile intf -> + Util.format1 "LDInterfaceOfCurrentFile %s" (string_of_timed_fname intf) + | PushFragment (Inl frag, _, _) -> + Util.format1 "PushFragment { code = %s }" frag.frag_text + | PushFragment (Inr d, _, _) -> + Util.format1 "PushFragment { decl = %s }" (show d) + | Noop -> "Noop {}" + +module BU = FStarC.Compiler.Util + +let string_of_repl_stack_entry + : repl_stack_entry_t -> string + = fun ((depth, i), (task, state)) -> + BU.format "{depth=%s; task=%s}" + [string_of_int i; + string_of_repl_task task] + + +let string_of_repl_stack s = + String.concat ";\n\t\t" + (List.map string_of_repl_stack_entry s) + +let repl_state_to_string (r:repl_state) + : string + = BU.format + "{\n\t\ + repl_line=%s;\n\t\ + repl_column=%s;\n\t\ + repl_fname=%s;\n\t\ + repl_cur_mod=%s;\n\t\ + repl_deps_stack={%s}\n\ + }" + [string_of_int r.repl_line; + string_of_int r.repl_column; + r.repl_fname; + (match r.repl_curmod with + | None -> "None" + | Some m -> Ident.string_of_lid m.name); + string_of_repl_stack r.repl_deps_stack] + + +let push_query_to_string pq = + let pk = + match pq.push_kind with + | SyntaxCheck -> "SyntaxCheck" + | LaxCheck -> "LaxCheck" + | FullCheck -> "FullCheck" + in + let code_or_decl = + match pq.push_code_or_decl with + | Inl code -> code + | Inr (_decl, code) -> code.code + in + FStarC.Compiler.Util.format "{ push_kind = %s; push_line = %s; \ + push_column = %s; push_peek_only = %s; push_code_or_decl = %s }" + [pk; string_of_int pq.push_line; + string_of_int pq.push_column; + string_of_bool pq.push_peek_only; + code_or_decl] + +let query_to_string q = match q.qq with +| Exit -> "Exit" +| DescribeProtocol -> "DescribeProtocol" +| DescribeRepl -> "DescribeRepl" +| Segment _ -> "Segment" +| Pop -> "Pop" +| Push pq -> "(Push " ^ push_query_to_string pq ^ ")" +| PushPartialCheckedFile d -> "(PushPartialCheckedFile " ^ d ^ ")" +| VfsAdd _ -> "VfsAdd" +| AutoComplete _ -> "AutoComplete" +| Lookup(s, _lc, pos, features, _sr) -> + BU.format3 "(Lookup %s %s [%s])" + s (match pos with + | None -> "None" + | Some (f, i, j) -> + BU.format3 "(%s, %s, %s)" + f (string_of_int i) (string_of_int j)) + (String.concat "; " features) +| Compute _ -> "Compute" +| Search _ -> "Search" +| GenericError _ -> "GenericError" +| ProtocolViolation _ -> "ProtocolViolation" +| FullBuffer _ -> "FullBuffer" +| Callback _ -> "Callback" +| Format _ -> "Format" +| RestartSolver -> "RestartSolver" +| Cancel _ -> "Cancel" + +let query_needs_current_module = function + | Exit | DescribeProtocol | DescribeRepl | Segment _ + | Pop | Push { push_peek_only = false } | VfsAdd _ + | GenericError _ | ProtocolViolation _ + | PushPartialCheckedFile _ + | FullBuffer _ | Callback _ | Format _ | RestartSolver | Cancel _ -> false + | Push _ | AutoComplete _ | Lookup _ | Compute _ | Search _ -> true + +let interactive_protocol_vernum = 2 + +let interactive_protocol_features = + ["autocomplete"; "autocomplete/context"; + "compute"; "compute/reify"; "compute/pure-subterms"; + "describe-protocol"; "describe-repl"; "exit"; + "lookup"; "lookup/context"; "lookup/documentation"; "lookup/definition"; + "peek"; "pop"; "push"; "push-partial-checked-file"; "search"; "segment"; + "vfs-add"; "tactic-ranges"; "interrupt"; "progress"; + "full-buffer"; "format"; "restart-solver"; "cancel"] + +let json_of_issue_level i = + JsonStr (match i with + | ENotImplemented -> "not-implemented" + | EInfo -> "info" + | EWarning -> "warning" + | EError -> "error") + +let json_of_issue issue = + JsonAssoc <| + [("level", json_of_issue_level issue.issue_level)] + @(match issue.issue_number with + | None -> [] + | Some n -> [("number", JsonInt n)]) + @[("message", JsonStr (format_issue' false issue)); + ("ranges", JsonList + ((match issue.issue_range with + | None -> [] + | Some r -> [json_of_use_range r]) @ + (match issue.issue_range with + | Some r when def_range r <> use_range r -> + [json_of_def_range r] + | _ -> [])))] + +(*****************************************) +(* Reading queries and writing responses *) +(*****************************************) + +let js_pushkind s : push_kind = match js_str s with + | "syntax" -> SyntaxCheck + | "lax" -> LaxCheck + | "full" -> FullCheck + | _ -> js_fail "push_kind" s + +let js_reductionrule s = match js_str s with + | "beta" -> FStarC.TypeChecker.Env.Beta + | "delta" -> FStarC.TypeChecker.Env.UnfoldUntil SS.delta_constant + | "iota" -> FStarC.TypeChecker.Env.Iota + | "zeta" -> FStarC.TypeChecker.Env.Zeta + | "reify" -> FStarC.TypeChecker.Env.Reify + | "pure-subterms" -> FStarC.TypeChecker.Env.PureSubtermsWithinComputations + | _ -> js_fail "reduction rule" s + +let js_optional_completion_context k = + match k with + | None -> CKCode + | Some k -> + match js_str k with + | "symbol" // Backwards compatibility + | "code" -> CKCode + | "set-options" -> CKOption false + | "reset-options" -> CKOption true + | "open" + | "let-open" -> CKModuleOrNamespace (true, true) + | "include" + | "module-alias" -> CKModuleOrNamespace (true, false) + | _ -> + js_fail "completion context (code, set-options, reset-options, \ +open, let-open, include, module-alias)" k + +let js_optional_lookup_context k = + match k with + | None -> LKSymbolOnly // Backwards-compatible default + | Some k -> + match js_str k with + | "symbol-only" -> LKSymbolOnly + | "code" -> LKCode + | "set-options" + | "reset-options" -> LKOption + | "open" + | "let-open" + | "include" + | "module-alias" -> LKModule + | _ -> + js_fail "lookup context (symbol-only, code, set-options, reset-options, \ +open, let-open, include, module-alias)" k + diff --git a/src/fstar/FStarC.Interactive.Ide.fst b/src/fstar/FStarC.Interactive.Ide.fst new file mode 100644 index 00000000000..ee4f30978da --- /dev/null +++ b/src/fstar/FStarC.Interactive.Ide.fst @@ -0,0 +1,1286 @@ +(* + Copyright 2008-2016 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Interactive.Ide +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Range +open FStarC.Compiler.Util +open FStarC.Getopt +open FStarC.Ident +open FStarC.Errors +open FStarC.Interactive.JsonHelper +open FStarC.Interactive.QueryHelper +open FStarC.Interactive.PushHelper +open FStarC.Interactive.Ide.Types +module BU = FStarC.Compiler.Util + +let dbg = Debug.get_toggle "IDE" + +open FStarC.Universal +open FStarC.TypeChecker.Env +open FStarC.TypeChecker.Common +open FStarC.Interactive +open FStarC.Parser.ParseIt +open FStarC.Interactive.Ide.Types +module SS = FStarC.Syntax.Syntax +module DsEnv = FStarC.Syntax.DsEnv +module TcErr = FStarC.TypeChecker.Err +module TcEnv = FStarC.TypeChecker.Env +module CTable = FStarC.Interactive.CompletionTable +module QH = FStarC.Interactive.QueryHelper + +let with_captured_errors' env sigint_handler f = + try + Util.with_sigint_handler sigint_handler (fun _ -> f env) + with + | Failure (msg) -> + let msg = "ASSERTION FAILURE: " ^ msg ^ "\n" ^ + "F* may be in an inconsistent state.\n" ^ + "Please file a bug report, ideally with a " ^ + "minimized version of the program that triggered the error." in + // Make sure the user sees the error, even if it happened transiently while + // running an automatic syntax checker like FlyCheck. + Errors.log_issue env Errors.Error_IDEAssertionFailure msg; + None + + | Util.SigInt -> + Util.print_string "Interrupted"; None + + | Error (e, msg, r, ctx) -> + TcErr.add_errors env [(e, msg, r, ctx)]; + None + + | Stop -> + None + +let with_captured_errors env sigint_handler f = + if Options.trace_error () then f env + else with_captured_errors' env sigint_handler f + +(** Tasks describing each snapshot of the REPL state. **) + +type env_t = TcEnv.env + +let repl_current_qid : ref (option string) = Util.mk_ref None // For messages + +(** Check whether users can issue further ``pop`` commands. **) +let nothing_left_to_pop st = + (* The first ``length st.repl_deps_stack`` entries in ``repl_stack`` are + dependency-loading entries, which the user may not pop (since they didn't + push them). *) + List.length !repl_stack = List.length st.repl_deps_stack + +(*********************) +(* Dependency checks *) +(*********************) + +(** Push, run `task`, and pop if it fails. + +If `must_rollback` is set, always pop. Returns a pair: a boolean indicating +success, and a new REPL state. **) +let run_repl_transaction st push_kind must_rollback task = + let st = push_repl "run_repl_transaction" push_kind task st in + let env, finish_name_tracking = track_name_changes st.repl_env in // begin name tracking … + + let check_success () = + get_err_count () = 0 && not must_rollback in + + // Run the task (and capture errors) + let curmod, env, success, lds = + match with_captured_errors env Util.sigint_raise + (fun env -> Some <| run_repl_task st.repl_curmod env task st.repl_lang) with + | Some (curmod, env, lds) when check_success () -> curmod, env, true, lds + | _ -> st.repl_curmod, env, false, [] in + + let env, name_events = finish_name_tracking env in // …end name tracking + let st = + if success then + let st = { st with repl_env = env; repl_curmod = curmod; repl_lang=List.rev lds@st.repl_lang } in + commit_name_tracking st name_events + else + pop_repl "run_repl_transaction" st in + + (success, st) + +(** Load dependencies described by `tasks`. + +Returns a new REPL state, wrapped in ``Inl`` to indicate complete success or +``Inr`` to indicate a partial failure. That new state has an updated +``repl_deps_stack``, containing loaded dependencies in reverse order compared to +the original list of tasks: the first dependencies (prims, ...) come first; the +current file's interface comes last. + +The original value of the ``repl_deps_stack`` field in ``st`` is used to skip +already completed tasks. + +This function is stateful: it uses ``push_repl`` and ``pop_repl``. + +`progress_callback` is called once per task, right before the task is run. **) +let run_repl_ld_transactions (st: repl_state) (tasks: list repl_task) + (progress_callback: repl_task -> unit) = + let debug verb task = + if !dbg then + Util.print2 "%s %s" verb (string_of_repl_task task) in + + (* Run as many ``pop_repl`` as there are entries in the input stack. + Elements of the input stack are expected to match the topmost ones of + ``!repl_stack`` *) + let rec revert_many st = function + | [] -> st + | (_id, (task, _st')) :: entries -> + //NS: this assertion has been failing for a while in debug mode; not sure why + assert (task = fst (snd (List.hd !repl_stack))); + debug "Reverting" task; + let st' = pop_repl "run_repl_ls_transactions" st in + let dep_graph = FStarC.TypeChecker.Env.dep_graph st.repl_env in + let st' = {st' with repl_env=FStarC.TypeChecker.Env.set_dep_graph st'.repl_env dep_graph} in + revert_many st' entries in + + let rec aux (st: repl_state) + (tasks: list repl_task) + (previous: list repl_stack_entry_t) = + match tasks, previous with + // All done: return the final state. + | [], [] -> + Inl st + + // We have more dependencies to load, and no previously loaded dependencies: + // run ``task`` and record the updated dependency stack in ``st``. + | task :: tasks, [] -> + debug "Loading" task; + progress_callback task; + Options.restore_cmd_line_options false |> ignore; + let timestamped_task = update_task_timestamps task in + let push_kind = if Options.lax () then LaxCheck else FullCheck in + let success, st = run_repl_transaction st (Some push_kind) false timestamped_task in + if success then aux ({ st with repl_deps_stack = !repl_stack }) tasks [] + else Inr st + + // We've already run ``task`` previously, and no update is needed: skip. + | task :: tasks, prev :: previous + when fst (snd prev) = update_task_timestamps task -> + debug "Skipping" task; + aux st tasks previous + + // We have a timestamp mismatch or a new dependency: + // revert now-obsolete dependencies and resume loading. + | tasks, previous -> + aux (revert_many st previous) tasks [] in + + aux st tasks (List.rev st.repl_deps_stack) + +let wrap_js_failure qid expected got = + { qid = qid; + qq = ProtocolViolation (Util.format2 "JSON decoding failed: expected %s, got %s" + expected (json_debug got)) } + +let unpack_interactive_query json = + let assoc errloc key a = + match try_assoc key a with + | Some v -> v + | None -> raise (InvalidQuery (Util.format2 "Missing key [%s] in %s." key errloc)) in + + let request = json |> js_assoc in + + let qid = assoc "query" "query-id" request |> js_str in + try + let query = assoc "query" "query" request |> js_str in + let args = assoc "query" "args" request |> js_assoc in + + let arg k = assoc "[args]" k args in + let try_arg k = + match try_assoc k args with + | Some JsonNull -> None + | other -> other in + + let read_position err loc = + assoc err "filename" loc |> js_str, + assoc err "line" loc |> js_int, + assoc err "column" loc |> js_int + in + let read_to_position () = + let to_pos = arg "to-position" |> js_assoc in + "", + assoc "to-position.line" "line" to_pos |> js_int, + assoc "to-position.column" "column" to_pos |> js_int + in + let parse_full_buffer_kind (kind:string) = + match kind with + | "full" -> Full + | "lax" -> Lax + | "cache" -> Cache + | "reload-deps" -> ReloadDeps + | "verify-to-position" -> VerifyToPosition (read_to_position ()) + | "lax-to-position" -> LaxToPosition (read_to_position ()) + | _ -> raise (InvalidQuery "Invalid full-buffer kind") + in + { qid = qid; + qq = match query with + | "exit" -> Exit + | "pop" -> Pop + | "describe-protocol" -> DescribeProtocol + | "describe-repl" -> DescribeRepl + | "segment" -> Segment (arg "code" |> js_str) + | "peek" | "push" -> Push ({ push_kind = arg "kind" |> js_pushkind; + push_code_or_decl = Inl (arg "code" |> js_str); + push_line = arg "line" |> js_int; + push_column = arg "column" |> js_int; + push_peek_only = query = "peek" }) + | "push-partial-checked-file" -> PushPartialCheckedFile (arg "until-lid" |> js_str) + | "full-buffer" -> FullBuffer (arg "code" |> js_str, + parse_full_buffer_kind (arg "kind" |> js_str), + arg "with-symbols" |> js_bool) + | "autocomplete" -> AutoComplete (arg "partial-symbol" |> js_str, + try_arg "context" |> js_optional_completion_context) + | "lookup" -> Lookup (arg "symbol" |> js_str, + try_arg "context" |> js_optional_lookup_context, + try_arg "location" + |> Util.map_option js_assoc + |> Util.map_option (read_position "[location]"), + arg "requested-info" |> js_list js_str, + try_arg "symbol-range") + | "compute" -> Compute (arg "term" |> js_str, + try_arg "rules" + |> Util.map_option (js_list js_reductionrule)) + | "search" -> Search (arg "terms" |> js_str) + | "vfs-add" -> VfsAdd (try_arg "filename" |> Util.map_option js_str, + arg "contents" |> js_str) + | "format" -> Format (arg "code" |> js_str) + | "restart-solver" -> RestartSolver + | "cancel" -> Cancel (Some("", arg "cancel-line" |> js_int, arg "cancel-column" |> js_int)) + | _ -> ProtocolViolation (Util.format1 "Unknown query '%s'" query) } + with + | InvalidQuery msg -> { qid = qid; qq = ProtocolViolation msg } + | UnexpectedJsonType (expected, got) -> wrap_js_failure qid expected got + +let deserialize_interactive_query js_query = + try + unpack_interactive_query js_query + with + | InvalidQuery msg -> { qid = "?"; qq = ProtocolViolation msg } + | UnexpectedJsonType (expected, got) -> wrap_js_failure "?" expected got + +let parse_interactive_query query_str : query = + match json_of_string query_str with + | None -> { qid = "?"; qq = ProtocolViolation "Json parsing failed." } + | Some request -> deserialize_interactive_query request + +let buffer_input_queries (st:repl_state) : repl_state = + let rec aux qs (st:repl_state) : repl_state = + let done qs st = + {st with repl_buffered_input_queries = + st.repl_buffered_input_queries @ List.rev qs} + in + if not (Util.poll_stdin (float_of_string "0.0")) + then done qs st + else ( + match Util.read_line st.repl_stdin with + | None -> + done qs st + + | Some line -> + let q = parse_interactive_query line in + match q.qq with + | Cancel _ -> + //Cancel drains all buffered queries + {st with repl_buffered_input_queries = [q] } + | _ -> aux (q :: qs) st + ) + in + aux [] st + +let read_interactive_query (st:repl_state) : query & repl_state = + match st.repl_buffered_input_queries with + | [] -> ( + match Util.read_line st.repl_stdin with + | None -> exit 0 + | Some line -> parse_interactive_query line, st + ) + | q :: qs -> + q, { st with repl_buffered_input_queries = qs } + +let json_of_opt json_of_a opt_a = + Util.dflt JsonNull (Util.map_option json_of_a opt_a) + +let alist_of_symbol_lookup_result lr symbol symrange_opt= + [("name", JsonStr lr.slr_name); + ("defined-at", json_of_opt json_of_def_range lr.slr_def_range); + ("type", json_of_opt JsonStr lr.slr_typ); + ("documentation", json_of_opt JsonStr lr.slr_doc); + ("definition", json_of_opt JsonStr lr.slr_def)] @ ( + // echo back the symbol-range and symbol, if symbol-range was provided + // (don't include it otherwise, for backwards compat with fstar-mode.el) + match symrange_opt with + | None -> [] + | Some symrange -> + [("symbol-range", json_of_opt (fun x -> x) symrange_opt); + ("symbol", JsonStr symbol)] + ) + +let alist_of_protocol_info = + let js_version = JsonInt interactive_protocol_vernum in + let js_features = JsonList <| List.map JsonStr interactive_protocol_features in + [("version", js_version); ("features", js_features)] + +type fstar_option_permission_level = +| OptSet +| OptReadOnly + +let string_of_option_permission_level = function + | OptSet -> "" + | OptReadOnly -> "read-only" + +type fstar_option = + { opt_name: string; + opt_sig: string; + opt_value: Options.option_val; + opt_default: Options.option_val; + opt_type: Options.opt_type; + opt_snippets: list string; + opt_documentation: option string; + opt_permission_level: fstar_option_permission_level } + +let rec kind_of_fstar_option_type = function + | Options.Const _ -> "flag" + | Options.IntStr _ -> "int" + | Options.BoolStr -> "bool" + | Options.PathStr _ -> "path" + | Options.SimpleStr _ -> "string" + | Options.EnumStr _ -> "enum" + | Options.OpenEnumStr _ -> "open enum" + | Options.PostProcessed (_, typ) + | Options.Accumulated typ + | Options.ReverseAccumulated typ + | Options.WithSideEffect (_, typ) -> kind_of_fstar_option_type typ + +let snippets_of_fstar_option name typ = + let mk_field field_name = + "${" ^ field_name ^ "}" in + let mk_snippet name argstring = + "--" ^ name ^ (if argstring <> "" then " " ^ argstring else "") in + let rec arg_snippets_of_type typ = + match typ with + | Options.Const _ -> [""] + | Options.BoolStr -> ["true"; "false"] + | Options.IntStr desc + | Options.PathStr desc + | Options.SimpleStr desc -> [mk_field desc] + | Options.EnumStr strs -> strs + | Options.OpenEnumStr (strs, desc) -> strs @ [mk_field desc] + | Options.PostProcessed (_, elem_spec) + | Options.Accumulated elem_spec + | Options.ReverseAccumulated elem_spec + | Options.WithSideEffect (_, elem_spec) -> arg_snippets_of_type elem_spec in + List.map (mk_snippet name) (arg_snippets_of_type typ) + +let rec json_of_fstar_option_value = function + | Options.Bool b -> JsonBool b + | Options.String s + | Options.Path s -> JsonStr s + | Options.Int n -> JsonInt n + | Options.List vs -> JsonList (List.map json_of_fstar_option_value vs) + | Options.Unset -> JsonNull + +let alist_of_fstar_option opt = + [("name", JsonStr opt.opt_name); + ("signature", JsonStr opt.opt_sig); + ("value", json_of_fstar_option_value opt.opt_value); + ("default", json_of_fstar_option_value opt.opt_default); + ("documentation", json_of_opt JsonStr opt.opt_documentation); + ("type", JsonStr (kind_of_fstar_option_type opt.opt_type)); + ("permission-level", JsonStr (string_of_option_permission_level opt.opt_permission_level))] + +let json_of_fstar_option opt = + JsonAssoc (alist_of_fstar_option opt) + +let json_of_response qid status response = + let qid = JsonStr qid in + let status = match status with + | QueryOK -> JsonStr "success" + | QueryNOK -> JsonStr "failure" + | QueryViolatesProtocol -> JsonStr "protocol-violation" in + JsonAssoc [("kind", JsonStr "response"); + ("query-id", qid); + ("status", status); + ("response", response)] + +let write_response qid status response = + write_json (json_of_response qid status response) + +let json_of_message level js_contents = + JsonAssoc [("kind", JsonStr "message"); + ("query-id", json_of_opt JsonStr !repl_current_qid); + ("level", JsonStr level); + ("contents", js_contents)] + +let forward_message callback level contents = + callback (json_of_message level contents) + +let json_of_hello = + let js_version = JsonInt interactive_protocol_vernum in + let js_features = JsonList (List.map JsonStr interactive_protocol_features) in + JsonAssoc (("kind", JsonStr "protocol-info") :: alist_of_protocol_info) + +let write_hello () = + write_json json_of_hello + +(*****************) +(* Options cache *) +(*****************) + +let sig_of_fstar_option name typ = + let flag = "--" ^ name in + match Options.desc_of_opt_type typ with + | None -> flag + | Some arg_sig -> flag ^ " " ^ arg_sig + +let fstar_options_list_cache = + let defaults = Util.smap_of_list Options.defaults in + Options.all_specs_with_types + |> List.filter_map (fun (_shortname, name, typ, doc) -> + Util.smap_try_find defaults name // Keep only options with a default value + |> Util.map_option (fun default_value -> + { opt_name = name; + opt_sig = sig_of_fstar_option name typ; + opt_value = Options.Unset; + opt_default = default_value; + opt_type = typ; + opt_snippets = snippets_of_fstar_option name typ; + opt_documentation = if doc = FStarC.Pprint.empty then None else Some (renderdoc doc); + opt_permission_level = if Options.settable name then OptSet + else OptReadOnly })) + |> List.sortWith (fun o1 o2 -> + String.compare (String.lowercase (o1.opt_name)) + (String.lowercase (o2.opt_name))) + +let fstar_options_map_cache = + let cache = Util.smap_create 50 in + List.iter (fun opt -> Util.smap_add cache opt.opt_name opt) fstar_options_list_cache; + cache + +let update_option opt = + { opt with opt_value = Options.get_option opt.opt_name } + +let current_fstar_options filter = + List.map update_option (List.filter filter fstar_options_list_cache) + +let trim_option_name opt_name = + let opt_prefix = "--" in + if Util.starts_with opt_name opt_prefix then + (opt_prefix, Util.substring_from opt_name (String.length opt_prefix)) + else + ("", opt_name) + +(*************************) +(* Main interactive loop *) +(*************************) + +let json_of_repl_state st = + let filenames (_, (task, _)) = + match task with + | LDInterleaved (intf, impl) -> [intf.tf_fname; impl.tf_fname] + | LDSingle intf_or_impl -> [intf_or_impl.tf_fname] + | LDInterfaceOfCurrentFile intf -> [intf.tf_fname] + | _ -> [] in + + JsonAssoc + [("loaded-dependencies", + JsonList (List.map JsonStr (List.concatMap filenames st.repl_deps_stack))); + ("options", + JsonList (List.map json_of_fstar_option (current_fstar_options (fun _ -> true))))] + +let run_exit st = + ((QueryOK, JsonNull), Inr 0) + +let run_describe_protocol st = + ((QueryOK, JsonAssoc alist_of_protocol_info), Inl st) + +let run_describe_repl st = + ((QueryOK, json_of_repl_state st), Inl st) + +let run_protocol_violation st message = + ((QueryViolatesProtocol, JsonStr message), Inl st) + +let run_generic_error st message = + ((QueryNOK, JsonStr message), Inl st) + +let collect_errors () = + let errors = FStarC.Errors.report_all() in + FStarC.Errors.clear (); + errors + +let run_segment (st: repl_state) (code: string) = + // Unfortunately, frag_fname is a special case in the interactive mode, + // while in LSP, it is the only mode. To cope with this difference, + // pass a frag_fname that is expected by the Interactive mode. + let frag = { frag_fname = ""; frag_text = code; frag_line = 1; frag_col = 0 } in + + let collect_decls () = + match Parser.Driver.parse_fragment None frag with + | Parser.Driver.Empty -> [] + | Parser.Driver.Decls decls + | Parser.Driver.Modul (Parser.AST.Module (_, decls)) + | Parser.Driver.Modul (Parser.AST.Interface (_, decls, _)) -> decls in + + match with_captured_errors st.repl_env Util.sigint_ignore + (fun _ -> Some <| collect_decls ()) with + | None -> + let errors = collect_errors () |> List.map json_of_issue in + ((QueryNOK, JsonList errors), Inl st) + | Some decls -> + let json_of_decl decl = + JsonAssoc [("def_range", json_of_def_range decl.Parser.AST.drange)] in + let js_decls = + JsonList <| List.map json_of_decl decls in + ((QueryOK, JsonAssoc [("decls", js_decls)]), Inl st) + +let run_vfs_add st opt_fname contents = + let fname = Util.dflt st.repl_fname opt_fname in + Parser.ParseIt.add_vfs_entry fname contents; + ((QueryOK, JsonNull), Inl st) + +let run_pop st = + if nothing_left_to_pop st then + ((QueryNOK, JsonStr "Too many pops"), Inl st) + else + let st' = pop_repl "pop_query" st in + ((QueryOK, JsonNull), Inl st') + +let write_progress stage contents_alist = + let stage = match stage with Some s -> JsonStr s | None -> JsonNull in + let js_contents = ("stage", stage) :: contents_alist in + write_json (json_of_message "progress" (JsonAssoc js_contents)) + +let write_error contents = + write_json (json_of_message "error" (JsonAssoc contents)) + +let write_repl_ld_task_progress task = + match task with + | LDInterleaved (_, tf) | LDSingle tf | LDInterfaceOfCurrentFile tf -> + let modname = Parser.Dep.module_name_of_file tf.tf_fname in + write_progress (Some "loading-dependency") [("modname", JsonStr modname)] + | _ -> () + +(** Compute and load all dependencies of `filename`. + +Return an new REPL state wrapped in ``Inr`` in case of failure, and a new REPL +plus with a list of completed tasks wrapped in ``Inl`` in case of success. **) +let load_deps st = + match with_captured_errors st.repl_env Util.sigint_ignore + (fun _env -> Some <| deps_and_repl_ld_tasks_of_our_file st.repl_fname) with + | None -> Inr st + | Some (deps, tasks, dep_graph) -> + let st = {st with repl_env=FStarC.TypeChecker.Env.set_dep_graph st.repl_env dep_graph} in + match run_repl_ld_transactions st tasks write_repl_ld_task_progress with + | Inr st -> write_progress None []; Inr st + | Inl st -> write_progress None []; Inl (st, deps) + +let rephrase_dependency_error issue = + { issue with issue_msg = + let open FStarC.Pprint in + (Errors.Msg.text "Error while computing or loading dependencies")::issue.issue_msg} + +let write_full_buffer_fragment_progress (di:Incremental.fragment_progress) = + let open FStarC.Interactive.Incremental in + let json_of_code_fragment (cf:FStarC.Parser.ParseIt.code_fragment) = + JsonAssoc ["range", json_of_def_range cf.range; + "code-digest", JsonStr (BU.digest_of_string cf.code)] + in + match di with + | FullBufferStarted -> + write_progress (Some "full-buffer-started") [] + + | FragmentStarted d -> + write_progress (Some "full-buffer-fragment-started") + ["ranges", json_of_def_range d.FStarC.Parser.AST.drange] + | FragmentSuccess (d, cf, FullCheck) -> + write_progress (Some "full-buffer-fragment-ok") + ["ranges", json_of_def_range d.FStarC.Parser.AST.drange; + "code-fragment", json_of_code_fragment cf] + | FragmentSuccess (d, cf, LaxCheck) -> + write_progress (Some "full-buffer-fragment-lax-ok") + ["ranges", json_of_def_range d.FStarC.Parser.AST.drange; + "code-fragment", json_of_code_fragment cf] + | FragmentFailed d -> + write_progress (Some "full-buffer-fragment-failed") + ["ranges", json_of_def_range d.FStarC.Parser.AST.drange] + + | FragmentError issues -> + let qid = + match !repl_current_qid with + | None -> "unknown" + | Some q -> q + in + write_json (json_of_response qid QueryNOK (JsonList (List.map json_of_issue issues))) + + | FullBufferFinished -> + write_progress (Some "full-buffer-finished") [] + +let trunc_modul (m: SS.modul) (pred : SS.sigelt -> bool) : bool & SS.modul = + let rec filter decls acc = + match decls with + | [] -> false, List.rev acc + | d::ds -> + if pred d then true, List.rev acc else filter ds (d::acc) in + let found, decls = filter m.declarations [] in + found, { m with SS.declarations = decls } + +let load_partial_checked_file (env: TcEnv.env) (filename: string) (until_lid: string) = + match FStarC.CheckedFiles.load_module_from_cache env filename with + | None -> failwith ("cannot find checked file for " ^ filename) + | Some tc_result -> + let _, env = with_dsenv_of_tcenv env (fun ds -> (), DsEnv.set_current_module ds tc_result.checked_module.name) in + let _, env = with_dsenv_of_tcenv env (fun ds -> (), DsEnv.set_iface_decls ds tc_result.checked_module.name []) in + let pred se = + let rec pred lids = match lids with + | [] -> false + | lid::lids -> if string_of_lid lid = until_lid then true else pred lids in + pred (Syntax.Util.lids_of_sigelt se) in + let found_decl, m = trunc_modul tc_result.checked_module pred in + if not found_decl then failwith ("did not find declaration with lident " ^ until_lid) else + let _, env = with_dsenv_of_tcenv env <| + FStarC.ToSyntax.ToSyntax.add_partial_modul_to_env m tc_result.mii + (FStarC.TypeChecker.Normalize.erase_universes env) in + let env = FStarC.TypeChecker.Tc.load_partial_checked_module env m in + let _, env = with_dsenv_of_tcenv env (fun ds -> (), DsEnv.set_current_module ds m.name) in + let env = FStarC.TypeChecker.Env.set_current_module env m.name in + ignore (FStarC.SMTEncoding.Encode.encode_modul env m); + // TODO: opens / includes + env, m + +let run_load_partial_file st decl_name: (query_status & json) & either repl_state int = + match load_deps st with + | Inr st -> + let errors = List.map rephrase_dependency_error (collect_errors ()) in + let js_errors = errors |> List.map json_of_issue in + ((QueryNOK, JsonList js_errors), Inl st) + | Inl (st, deps) -> + // We have to specify a push_kind here, otherwise push_repl will not snapshot the environment. + let st = push_repl "load partial file" (Some FullCheck) Noop st in + let env = st.repl_env in + match with_captured_errors env Util.sigint_raise + (fun env -> Some <| load_partial_checked_file env st.repl_fname decl_name) with + | Some (env, curmod) when get_err_count () = 0 -> + let st = { st with repl_curmod = Some curmod; repl_env = env } in + ((QueryOK, JsonList []), Inl st) + | _ -> + let json_error_list = collect_errors () |> List.map json_of_issue in + let json_errors = JsonList json_error_list in + let st = pop_repl "load partial file" st in + (QueryNOK, json_errors), Inl st + +let run_push_without_deps st query + : (query_status & json) & either repl_state int = + let set_flychecking_flag st flag = + { st with repl_env = { st.repl_env with flychecking = flag } } in + + let { push_code_or_decl = code_or_decl; + push_line = line; + push_column = column; + push_peek_only = peek_only; + push_kind = push_kind } = query in + + + let _ = + if FStarC.Options.ide_id_info_off() + then TcEnv.toggle_id_info st.repl_env false + else TcEnv.toggle_id_info st.repl_env true + in + let frag = + match code_or_decl with + | Inl text -> + Inl { frag_fname = ""; frag_text = text; frag_line = line; frag_col = column } + | Inr (decl, _code) -> + Inr decl + in + let st = set_flychecking_flag st peek_only in + let success, st = run_repl_transaction st (Some push_kind) peek_only (PushFragment (frag, push_kind, [])) in + let st = set_flychecking_flag st false in + + let status = if success || peek_only then QueryOK else QueryNOK in + let errs = collect_errors () in + let has_error = + List.existsb + (fun i -> + match i.issue_level with + | EError | ENotImplemented -> true + | _ -> false) + errs + in + let _ = + match code_or_decl with + | Inr (d, s) -> + if not has_error + then write_full_buffer_fragment_progress (Incremental.FragmentSuccess (d, s, push_kind)) + else write_full_buffer_fragment_progress (Incremental.FragmentFailed d) + | _ -> () + in + let json_errors = JsonList (errs |> List.map json_of_issue) in + let _ = + match errs, status with + | _::_, QueryOK -> add_issues_to_push_fragment [json_errors] + | _ -> () + in + let st = if success then { st with repl_line = line; repl_column = column } else st in + ((status, json_errors), Inl st) + +let run_push_with_deps st query = + if !dbg then + Util.print_string "Reloading dependencies"; + TcEnv.toggle_id_info st.repl_env false; + match load_deps st with + | Inr st -> + let errors = List.map rephrase_dependency_error (collect_errors ()) in + let js_errors = errors |> List.map json_of_issue in + ((QueryNOK, JsonList js_errors), Inl st) + | Inl (st, deps) -> + Options.restore_cmd_line_options false |> ignore; + let names = add_module_completions st.repl_fname deps st.repl_names in + run_push_without_deps ({ st with repl_names = names }) query + +let run_push st query = + if nothing_left_to_pop st then + run_push_with_deps st query + else + run_push_without_deps st query + +let run_symbol_lookup st symbol pos_opt requested_info (symbol_range_opt:option json) = + match QH.symlookup st.repl_env symbol pos_opt requested_info with + | None -> Inl "Symbol not found" + | Some result -> + Inr ("symbol", alist_of_symbol_lookup_result result symbol symbol_range_opt) + +let run_option_lookup opt_name = + let _, trimmed_name = trim_option_name opt_name in + match Util.smap_try_find fstar_options_map_cache trimmed_name with + | None -> Inl ("Unknown option:" ^ opt_name) + | Some opt -> Inr ("option", alist_of_fstar_option (update_option opt)) + +let run_module_lookup st symbol = + let query = Util.split symbol "." in + match CTable.find_module_or_ns st.repl_names query with + | None -> + Inl "No such module or namespace" + | Some (CTable.Module mod_info) -> + Inr ("module", CTable.alist_of_mod_info mod_info) + | Some (CTable.Namespace ns_info) -> + Inr ("namespace", CTable.alist_of_ns_info ns_info) + +let run_code_lookup st symbol pos_opt requested_info symrange_opt= + match run_symbol_lookup st symbol pos_opt requested_info symrange_opt with + | Inr alist -> Inr alist + | Inl _ -> match run_module_lookup st symbol with + | Inr alist -> Inr alist + | Inl err_msg -> Inl "No such symbol, module, or namespace." + +let run_lookup' st symbol context pos_opt requested_info symrange = + match context with + | LKSymbolOnly -> run_symbol_lookup st symbol pos_opt requested_info symrange + | LKModule -> run_module_lookup st symbol + | LKOption -> run_option_lookup symbol + | LKCode -> run_code_lookup st symbol pos_opt requested_info symrange + +let run_lookup st symbol context pos_opt requested_info symrange = + try + match run_lookup' st symbol context pos_opt requested_info symrange with + | Inl err_msg -> ( + match symrange with + | None -> + //fstar-mode.el expects a failure on symbol not found + ((QueryNOK, [JsonStr err_msg]), Inl st) + | _ -> + // This is the behavior for the vscode mode + // No result found, but don't fail the query + ((QueryOK, []), Inl st) + ) + + | Inr (kind, info) -> + ((QueryOK, [JsonAssoc (("kind", JsonStr kind) :: info)]), Inl st) + with + | _ -> ((QueryOK, [JsonStr ("Lookup of " ^ symbol^ " failed")]), Inl st) + + +let run_code_autocomplete st search_term = + let result = QH.ck_completion st search_term in + let results = + match result with + | [] -> result + | _ -> + let result_correlator : CTable.completion_result = { + completion_match_length = 0; + completion_annotation = ""; + completion_candidate = search_term + } in + result@[result_correlator] + in + let js = List.map CTable.json_of_completion_result results in + ((QueryOK, JsonList js), Inl st) + +let run_module_autocomplete st search_term modules namespaces = + let needle = Util.split search_term "." in + let mods_and_nss = CTable.autocomplete_mod_or_ns st.repl_names needle Some in + let json = List.map CTable.json_of_completion_result mods_and_nss in + ((QueryOK, JsonList json), Inl st) + +let candidates_of_fstar_option match_len is_reset opt = + let may_set, explanation = + match opt.opt_permission_level with + | OptSet -> true, "" + | OptReadOnly -> false, "read-only" in + let opt_type = + kind_of_fstar_option_type opt.opt_type in + let annot = + if may_set then opt_type else "(" ^ explanation ^ " " ^ opt_type ^ ")" in + opt.opt_snippets + |> List.map (fun snippet -> + { CTable.completion_match_length = match_len; + CTable.completion_candidate = snippet; + CTable.completion_annotation = annot }) + +let run_option_autocomplete st search_term is_reset = + match trim_option_name search_term with + | ("--", trimmed_name) -> + let matcher opt = Util.starts_with opt.opt_name trimmed_name in + let options = current_fstar_options matcher in + + let match_len = String.length search_term in + let collect_candidates = candidates_of_fstar_option match_len is_reset in + let results = List.concatMap collect_candidates options in + + let json = List.map CTable.json_of_completion_result results in + ((QueryOK, JsonList json), Inl st) + | (_, _) -> ((QueryNOK, JsonStr "Options should start with '--'"), Inl st) + +let run_autocomplete st search_term context = + match context with + | CKCode -> + run_code_autocomplete st search_term + | CKOption is_reset -> + run_option_autocomplete st search_term is_reset + | CKModuleOrNamespace (modules, namespaces) -> + run_module_autocomplete st search_term modules namespaces + +let run_and_rewind st sigint_default task = + let st = push_repl "run_and_rewind" (Some FullCheck) Noop st in + let results = + try Util.with_sigint_handler Util.sigint_raise (fun _ -> Inl <| task st) + with | Util.SigInt -> Inl sigint_default + | e -> Inr e in + let st = pop_repl "run_and_rewind" st in + match results with + | Inl results -> (results, Inl st) + | Inr e -> raise e // CPC fixme add a test with two computations + +let run_with_parsed_and_tc_term st term line column continuation = + let dummy_let_fragment term = + let dummy_decl = Util.format1 "let __compute_dummy__ = (%s)" term in + { frag_fname = " input"; frag_text = dummy_decl; frag_line = 0; frag_col = 0 } in + + let find_let_body ses = + match ses with + | [{ SS.sigel = SS.Sig_let {lbs=(_, [{ SS.lbunivs = univs; SS.lbdef = def }])} }] -> + Some (univs, def) + | _ -> None in + + let parse frag = + match FStarC.Parser.ParseIt.parse None (FStarC.Parser.ParseIt.Incremental frag) with + | FStarC.Parser.ParseIt.IncrementalFragment (decls, _, _err) -> Some (List.map fst decls) + | _ -> None in + + let desugar env decls = + fst (FStarC.ToSyntax.ToSyntax.decls_to_sigelts decls env.dsenv) in + + let typecheck tcenv decls = + let ses, _ = FStarC.TypeChecker.Tc.tc_decls tcenv decls in + ses in + + run_and_rewind st (QueryNOK, JsonStr "Computation interrupted") (fun st -> + let tcenv = st.repl_env in + let frag = dummy_let_fragment term in + match parse frag with + | None -> (QueryNOK, JsonStr "Could not parse this term") + | Some decls -> + let aux () = + let decls = desugar tcenv decls in + let ses = typecheck tcenv decls in + match find_let_body ses with + | None -> (QueryNOK, JsonStr "Typechecking yielded an unexpected term") + | Some (univs, def) -> + let univs, def = Syntax.Subst.open_univ_vars univs def in + let tcenv = TcEnv.push_univ_vars tcenv univs in + continuation tcenv def in + if Options.trace_error () then + aux () + else + try aux () + with | e -> (match FStarC.Errors.issue_of_exn e with + | Some issue -> (QueryNOK, JsonStr (FStarC.Errors.format_issue issue)) + | None -> raise e)) + +let run_compute st term rules = + let rules = + (match rules with + | Some rules -> rules + | None -> [FStarC.TypeChecker.Env.Beta; + FStarC.TypeChecker.Env.Iota; + FStarC.TypeChecker.Env.Zeta; + FStarC.TypeChecker.Env.UnfoldUntil SS.delta_constant]) + @ [FStarC.TypeChecker.Env.Inlining; + FStarC.TypeChecker.Env.Eager_unfolding; + FStarC.TypeChecker.Env.DontUnfoldAttr [Parser.Const.tac_opaque_attr]; + FStarC.TypeChecker.Env.Primops] in + + let normalize_term tcenv rules t = + FStarC.TypeChecker.Normalize.normalize rules tcenv t in + + run_with_parsed_and_tc_term st term 0 0 (fun tcenv def -> + let normalized = normalize_term tcenv rules def in + (QueryOK, JsonStr (term_to_string tcenv normalized))) + +type search_term' = +| NameContainsStr of string +| TypeContainsLid of lid +and search_term = { st_negate: bool; + st_term: search_term' } + +let st_cost = function +| NameContainsStr str -> - (String.length str) +| TypeContainsLid lid -> 1 + +type search_candidate = { sc_lid: lid; sc_typ: + ref (option Syntax.Syntax.typ); + sc_fvars: ref (option (RBSet.t lid)) } + +let sc_of_lid lid = { sc_lid = lid; + sc_typ = Util.mk_ref None; + sc_fvars = Util.mk_ref None } + +let sc_typ tcenv sc = // Memoized version of sc_typ + match !sc.sc_typ with + | Some t -> t + | None -> let typ = match try_lookup_lid tcenv sc.sc_lid with + | None -> SS.mk SS.Tm_unknown Range.dummyRange + | Some ((_, typ), _) -> typ in + sc.sc_typ := Some typ; typ + +let sc_fvars tcenv sc = // Memoized version of fc_vars + match !sc.sc_fvars with + | Some fv -> fv + | None -> let fv = Syntax.Free.fvars (sc_typ tcenv sc) in + sc.sc_fvars := Some fv; fv + +let json_of_search_result tcenv sc = + let typ_str = term_to_string tcenv (sc_typ tcenv sc) in + JsonAssoc [("lid", JsonStr (string_of_lid (DsEnv.shorten_lid tcenv.dsenv sc.sc_lid))); + ("type", JsonStr typ_str)] + +exception InvalidSearch of string + +let run_search st search_str = + let tcenv = st.repl_env in + + let st_matches candidate term = + let found = + match term.st_term with + | NameContainsStr str -> Util.contains (string_of_lid candidate.sc_lid) str + | TypeContainsLid lid -> Class.Setlike.mem lid (sc_fvars tcenv candidate) in + found <> term.st_negate in + + let parse search_str = + let parse_one term = + let negate = Util.starts_with term "-" in + let term = if negate then Util.substring_from term 1 else term in + let beg_quote = Util.starts_with term "\"" in + let end_quote = Util.ends_with term "\"" in + let strip_quotes str = + if String.length str < 2 then + raise (InvalidSearch "Empty search term") + else + Util.substring str 1 (String.length term - 2) in + let parsed = + if beg_quote <> end_quote then + raise (InvalidSearch (Util.format1 "Improperly quoted search term: %s" term)) + else if beg_quote then + NameContainsStr (strip_quotes term) + else + let lid = Ident.lid_of_str term in + match DsEnv.resolve_to_fully_qualified_name tcenv.dsenv lid with + | None -> raise (InvalidSearch (Util.format1 "Unknown identifier: %s" term)) + | Some lid -> TypeContainsLid lid in + { st_negate = negate; st_term = parsed } in + + let terms = List.map parse_one (Util.split search_str " ") in + let cmp = fun x y -> st_cost x.st_term - st_cost y.st_term in + Util.sort_with cmp terms in + + let pprint_one term = + (if term.st_negate then "-" else "") + ^ (match term.st_term with + | NameContainsStr s -> Util.format1 "\"%s\"" s + | TypeContainsLid l -> Util.format1 "%s" (string_of_lid l)) in + + let results = + try + let terms = parse search_str in + let all_lidents = TcEnv.lidents tcenv in + let all_candidates = List.map sc_of_lid all_lidents in + let matches_all candidate = List.for_all (st_matches candidate) terms in + let cmp r1 r2 = Util.compare (string_of_lid r1.sc_lid) (string_of_lid r2.sc_lid) in + let results = List.filter matches_all all_candidates in + let sorted = Util.sort_with cmp results in + let js = List.map (json_of_search_result tcenv) sorted in + match results with + | [] -> let kwds = Util.concat_l " " (List.map pprint_one terms) in + raise (InvalidSearch (Util.format1 "No results found for query [%s]" kwds)) + | _ -> (QueryOK, JsonList js) + with InvalidSearch s -> (QueryNOK, JsonStr s) in + (results, Inl st) + +let run_format_code st code = + let code_or_err = FStarC.Interactive.Incremental.format_code st code in + match code_or_err with + | Inl code -> + let result = JsonAssoc ["formatted-code", JsonStr code] in + (QueryOK, result), Inl st + | Inr issue -> + let result = JsonAssoc ["formatted-code-issue", JsonList (List.map json_of_issue issue)] in + (QueryNOK, result), Inl st + +let as_json_list (q: (query_status & json) & either repl_state int) + : (query_status & list json) & either repl_state int + = let (q, j), s = q in + (q, [j]), s + +let run_query_result = (query_status & list json) & either repl_state int + +let maybe_cancel_queries st l = + let log_cancellation l = + if !dbg + then List.iter (fun q -> BU.print1 "Cancelling query: %s\n" (query_to_string q)) l + in + match st.repl_buffered_input_queries with + | { qq = Cancel p } :: rest -> ( + let st = { st with repl_buffered_input_queries = rest } in + match p with + | None -> //If no range, then cancel all remaining queries + log_cancellation l; + [], st + | Some p -> //Cancel all queries that are within the range + let query_ahead_of p q = + let _, l, c = p in + match q.qq with + | Push pq -> pq.push_line >= l + | _ -> false + in + let l = + match BU.prefix_until (query_ahead_of p) l with + | None -> l + | Some (l, q, qs) -> + log_cancellation (q::qs); + l + in + l, st + ) + | _ -> l, st + +let rec fold_query (f:repl_state -> query -> run_query_result) + (l:list query) + (st:repl_state) + : run_query_result + = match l with + | [] -> (QueryOK, []), Inl st + | q::l -> + let (status, responses), st' = f st q in + List.iter (write_response q.qid status) responses; + match status, st' with + | QueryOK, Inl st -> + let st = buffer_input_queries st in + let l, st = maybe_cancel_queries st l in + fold_query f l st + | _ -> + (status, []), st' + +let validate_query st (q: query) : query = + match q.qq with + | Push { push_kind = SyntaxCheck; push_peek_only = false } -> + { qid = q.qid; qq = ProtocolViolation "Cannot use 'kind': 'syntax' with 'query': 'push'" } + | _ -> match st.repl_curmod with + | None when query_needs_current_module q.qq -> + { qid = q.qid; qq = GenericError "Current module unset" } + | _ -> q + +let rec run_query st (q: query) : (query_status & list json) & either repl_state int = + match q.qq with + | Exit -> as_json_list (run_exit st) + | DescribeProtocol -> as_json_list (run_describe_protocol st) + | DescribeRepl -> as_json_list (run_describe_repl st) + | GenericError message -> as_json_list (run_generic_error st message) + | ProtocolViolation query -> as_json_list (run_protocol_violation st query) + | Segment c -> as_json_list (run_segment st c) + | VfsAdd (fname, contents) -> as_json_list (run_vfs_add st fname contents) + | Push pquery -> as_json_list (run_push st pquery) + | PushPartialCheckedFile decl_name -> as_json_list (run_load_partial_file st decl_name) + | Pop -> as_json_list (run_pop st) + | FullBuffer (code, full_kind, with_symbols) -> + let open FStarC.Interactive.Incremental in + write_full_buffer_fragment_progress FullBufferStarted; + let queries, issues = + run_full_buffer st q.qid code full_kind with_symbols write_full_buffer_fragment_progress + in + List.iter (write_response q.qid QueryOK) issues; + let res = fold_query validate_and_run_query queries st in + write_full_buffer_fragment_progress FullBufferFinished; + res + | AutoComplete (search_term, context) -> + as_json_list (run_autocomplete st search_term context) + | Lookup (symbol, context, pos_opt, rq_info, symrange) -> + run_lookup st symbol context pos_opt rq_info symrange + | Compute (term, rules) -> + as_json_list (run_compute st term rules) + | Search term -> + as_json_list (run_search st term) + | Callback f -> + f st + | Format code -> + as_json_list (run_format_code st code) + | RestartSolver -> + st.repl_env.solver.refresh None; + (QueryOK, []), Inl st + | Cancel _ -> + //This should be handled in the fold_query loop above + (QueryOK, []), Inl st +and validate_and_run_query st query = + let query = validate_query st query in + repl_current_qid := Some query.qid; + if !dbg + then BU.print2 "Running query %s: %s\n" query.qid (query_to_string query); + run_query st query + +(** This is the body of the JavaScript port's main loop. **) +let js_repl_eval st query = + let (status, responses), st_opt = validate_and_run_query st query in + let js_responses = List.map (json_of_response query.qid status) responses in + js_responses, st_opt + +let js_repl_eval_js st query_js = + js_repl_eval st (deserialize_interactive_query query_js) + +let js_repl_eval_str st query_str = + let js_response, st_opt = + js_repl_eval st (parse_interactive_query query_str) in + (List.map string_of_json js_response), st_opt + +(** This too is called from FStar.js **) +let js_repl_init_opts () = + let res, fnames = Options.parse_cmd_line () in + match res with + | Getopt.Error msg -> failwith ("repl_init: " ^ msg) + | Getopt.Help -> failwith "repl_init: --help unexpected" + | Getopt.Success -> + match fnames with + | [] -> + failwith "repl_init: No file name given in --ide invocation" + | h :: _ :: _ -> + failwith "repl_init: Too many file names given in --ide invocation" + | _ -> () + +(** This is the main loop for the desktop version **) +let rec go st : int = + let query, st = read_interactive_query st in + let (status, responses), state_opt = validate_and_run_query st query in + List.iter (write_response query.qid status) responses; + match state_opt with + | Inl st' -> go st' + | Inr exitcode -> exitcode + +let interactive_error_handler = // No printing here — collect everything for future use + let issues : ref (list issue) = Util.mk_ref [] in + let add_one (e: issue) = issues := e :: !issues in + let count_errors () = + let issues = Util.remove_dups (fun i0 i1 -> i0=i1) !issues in + List.length (List.filter (fun e -> e.issue_level = EError) issues) + in + let report () = + List.sortWith compare_issues (Util.remove_dups (fun i0 i1 -> i0=i1) !issues) + in + let clear () = issues := [] in + { eh_name = "interactive error handler"; + eh_add_one = add_one; + eh_count_errors = count_errors; + eh_report = report; + eh_clear = clear } + +let interactive_printer printer = + { printer_prinfo = (fun s -> forward_message printer "info" (JsonStr s)); + printer_prwarning = (fun s -> forward_message printer "warning" (JsonStr s)); + printer_prerror = (fun s -> forward_message printer "error" (JsonStr s)); + printer_prgeneric = (fun label get_string get_json -> + forward_message printer label (get_json ())) } + +let install_ide_mode_hooks printer = + FStarC.Compiler.Util.set_printer (interactive_printer printer); + FStarC.Errors.set_handler interactive_error_handler + + +let build_initial_repl_state (filename: string) = + let env = init_env FStarC.Parser.Dep.empty_deps in + let env = FStarC.TypeChecker.Env.set_range env initial_range in + FStarC.Options.set_ide_filename filename; + { repl_line = 1; + repl_column = 0; + repl_fname = filename; + repl_curmod = None; + repl_env = env; + repl_deps_stack = []; + repl_stdin = open_stdin (); + repl_names = CompletionTable.empty; + repl_buffered_input_queries = []; + repl_lang = [] } + +let interactive_mode' init_st = + write_hello (); + + let exit_code = + if FStarC.Options.record_hints() || FStarC.Options.use_hints() then + FStarC.SMTEncoding.Solver.with_hints_db (List.hd (Options.file_list ())) (fun () -> go init_st) + else + go init_st in + exit exit_code + +let interactive_mode (filename:string): unit = + install_ide_mode_hooks write_json; + // Ignore unexpected interrupts (some methods override this handler) + Util.set_sigint_handler Util.sigint_ignore; + + if Option.isSome (Options.codegen ()) then + Errors.log_issue0 Errors.Warning_IDEIgnoreCodeGen "--ide: ignoring --codegen"; + + let init = build_initial_repl_state filename in + if Options.trace_error () then + // This prevents the error catcher below from swallowing backtraces + interactive_mode' init + else + try + interactive_mode' init + with + | e -> (// Revert to default handler since we won't have an opportunity to + // print errors ourselves. + FStarC.Errors.set_handler FStarC.Errors.default_handler; + raise e) diff --git a/src/fstar/FStarC.Interactive.Incremental.fst b/src/fstar/FStarC.Interactive.Incremental.fst new file mode 100644 index 00000000000..551ff5716f3 --- /dev/null +++ b/src/fstar/FStarC.Interactive.Incremental.fst @@ -0,0 +1,368 @@ +(* + Copyright 2023 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Interactive.Incremental +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Range +open FStarC.Compiler.Util +open FStarC.Getopt +open FStarC.Ident +open FStarC.Errors +open FStarC.Interactive.JsonHelper +open FStarC.Interactive.QueryHelper +open FStarC.Interactive.PushHelper +open FStarC.Universal +open FStarC.TypeChecker.Env +open FStarC.TypeChecker.Common +open FStarC.Interactive +open FStarC.Parser.ParseIt +module SS = FStarC.Syntax.Syntax +module DsEnv = FStarC.Syntax.DsEnv +module TcErr = FStarC.TypeChecker.Err +module TcEnv = FStarC.TypeChecker.Env +module CTable = FStarC.Interactive.CompletionTable +open FStarC.Interactive.Ide.Types +module P = FStarC.Parser.ParseIt +module BU = FStarC.Compiler.Util +open FStarC.Parser.AST +open FStarC.Parser.AST.Util + +let qid = string & int +let qst a = qid -> a & qid +let return (x:'a) : qst 'a = fun q -> x, q +let (let!) (f:qst 'a) (g: 'a -> qst 'b) + : qst 'b + = fun q -> let x, q' = f q in + g x q' + +let run_qst (f:qst 'a) (q:string) + : 'a + = fst (f (q, 0)) + + +let rec map (f:'a -> qst 'b) (l:list 'a) + : qst (list 'b) + = match l with + | [] -> return [] + | hd::tl -> + let! hd = f hd in + let! tl = map f tl in + return (hd :: tl) + +let shift_qid (q:qid) (i:int) = fst q, snd q + i + +let next_qid + : qst qid + = fun q -> let q = shift_qid q 1 in + q, q + +let get_qid + : qst qid + = fun q -> q, q + +let as_query (q:query') + : qst query + = let! (qid_prefix, i) = next_qid in + return + { + qq=q; + qid=qid_prefix ^ "." ^ string_of_int i + } + +(* This function dumps a symbol table for the decl that has just been checked *) +let dump_symbols_for_lid (l:lident) +: qst query += let r = Ident.range_of_lid l in + let start_pos = Range.start_of_range r in + let end_pos = Range.end_of_range r in + let start_line = Range.line_of_pos start_pos in + let start_col = Range.col_of_pos start_pos in + let end_line = Range.line_of_pos end_pos in + let end_col = Range.col_of_pos end_pos in + let position = "", start_line, start_col in + as_query (Lookup(Ident.string_of_lid l, + LKCode, + Some position, + ["type"; "documentation"; "defined-at"], + Some (JsonAssoc [("fname", JsonStr ""); + ("beg", JsonList [JsonInt start_line; JsonInt start_col]); + ("end", JsonList [JsonInt end_line; JsonInt end_col])]))) + +let dump_symbols (d:decl) +: qst (list query) += let open FStarC.Parser.AST in + let ls = lidents_of_decl d in + map dump_symbols_for_lid ls + + +(* Push a decl for checking, and before it runs, + print a progress message "fragment-started" + for the decl that is about to run *) +let push_decl (push_kind:push_kind) + (with_symbols:bool) + (write_full_buffer_fragment_progress: fragment_progress -> unit) + (ds:decl & code_fragment) + : qst (list query) + = let open FStarC.Compiler.Range in + let d, s = ds in + let pq = { + push_kind; + push_line = line_of_pos (start_of_range d.drange); + push_column = col_of_pos (start_of_range d.drange); + push_peek_only = false; + push_code_or_decl = Inr ds + } in + let progress st = + write_full_buffer_fragment_progress (FragmentStarted d); + (QueryOK, []), Inl st + in + let! cb = as_query (Callback progress) in + let! push = as_query (Push pq) in + if with_symbols + then ( + let! lookups = dump_symbols d in + return ([cb; push] @ lookups) + ) + else ( + return [cb; push] + ) + +let push_decls (push_kind:push_kind) + (with_symbols:bool) + (write_full_buffer_fragment_progress : fragment_progress -> unit) + (ds:list (decl & code_fragment)) + : qst (list query) + = let! qs = map (push_decl push_kind with_symbols write_full_buffer_fragment_progress) ds in + return (List.flatten qs) + +let pop_entries (e:list repl_stack_entry_t) + : qst (list query) + = map (fun _ -> as_query Pop) e + +let repl_task (_, (p, _)) = p + +(* Find a prefix of the repl stack that matche a prefix of the decls ds, + pop the rest of the stack + and push the remaining suffix of decls +*) +let inspect_repl_stack (s:repl_stack_t) + (ds:list (decl & code_fragment)) + (push_kind : push_kind) + (with_symbols:bool) + (write_full_buffer_fragment_progress: fragment_progress -> unit) + : qst (list query & list json) + = let entries = List.rev s in + let push_decls = push_decls push_kind with_symbols write_full_buffer_fragment_progress in + match BU.prefix_until + (function (_, (PushFragment _, _)) -> true | _ -> false) + entries + with + | None -> + let! ds = push_decls ds in + return (ds, []) + + | Some (prefix, first_push, rest) -> + let entries = first_push :: rest in + let repl_task (_, (p, _)) = p in + let rec matching_prefix (accum:list json) (lookups:list query) entries (ds:list (decl & code_fragment)) + : qst (list query & list json) + = match entries, ds with + | [], [] -> + return (lookups, accum) + + | e::entries, d::ds -> ( + match repl_task e with + | Noop -> + matching_prefix accum lookups entries (d::ds) + | PushFragment (Inl frag, _, _) -> + let! pops = pop_entries (e::entries) in + let! pushes = push_decls (d::ds) in + return (lookups @ pops @ pushes, accum) + | PushFragment (Inr d', pk, issues) -> + if eq_decl (fst d) d' + then ( + let d, s = d in + write_full_buffer_fragment_progress (FragmentSuccess (d, s, pk)); + if with_symbols + then let! lookups' = dump_symbols d in + matching_prefix (issues@accum) (lookups'@lookups) entries ds + else + matching_prefix (issues@accum) lookups entries ds + ) + else let! pops = pop_entries (e::entries) in + let! pushes = push_decls (d::ds) in + return (pops @ lookups @ pushes, accum) + ) + + | [], ds -> + let! pushes = push_decls ds in + return (lookups@pushes, accum) + + | es, [] -> + let! pops = pop_entries es in + return (lookups@pops, accum) + in + matching_prefix [] [] entries ds + +(* A reload_deps request just pops away the entire stack of PushFragments. + We also push on just the `module A` declaration after popping. That's done below. *) +let reload_deps repl_stack = + let pop_until_deps entries + : qst (list query) + = match BU.prefix_until + (fun e -> match repl_task e with + | PushFragment _ | Noop -> false + | _ -> true) + entries + with + | None -> return [] + | Some (prefix, _, _) -> + let! pop = as_query Pop in + return (List.map (fun _ -> pop) prefix) + in + pop_until_deps repl_stack + +(* A utility to parse a chunk, used both in full_buffer and formatting *) +let parse_code lang (code:string) = + P.parse lang (Incremental { + frag_fname = Range.file_of_range initial_range; + frag_text = code; + frag_line = Range.line_of_pos (Range.start_of_range initial_range); + frag_col = Range.col_of_pos (Range.start_of_range initial_range); + }) + +(* Format FStarC.Errors.error into a JSON error message *) +let syntax_issue (raw_error, msg, range) = + let _, _, num = FStarC.Errors.lookup raw_error in + let issue = { + issue_msg = msg; + issue_level = EError; + issue_range = Some range; + issue_number = Some num; + issue_ctx = [] + } in + issue + +(* See comment in the interface file *) +let run_full_buffer (st:repl_state) + (qid:string) + (code:string) + (request_type:full_buffer_request_kind) + (with_symbols:bool) + (write_full_buffer_fragment_progress: fragment_progress -> unit) + : list query & list json + = let parse_result = parse_code None code in + let log_syntax_issues err = + match err with + | None -> () + | Some err -> + let issue = syntax_issue err in + write_full_buffer_fragment_progress (FragmentError [issue]) + in + let filter_decls decls = + match request_type with + | VerifyToPosition (_, line, _col) + | LaxToPosition (_, line, _col) -> + List.filter + (fun (d, _) -> + let start = Range.start_of_range d.drange in + let start_line = Range.line_of_pos start in + start_line <= line) + decls + | _ -> decls + in + let qs = + match parse_result with + | IncrementalFragment (decls, _, err_opt) -> ( + // This is a diagnostic message that is send to the IDE as an info message + // The script test-incremental.py in tests/ide/ depends on this message + BU.print1 "Parsed %s declarations\n" (string_of_int (List.length decls)); + match request_type, decls with + | ReloadDeps, d::_ -> + run_qst (let! queries = reload_deps (!repl_stack) in + let! push_mod = push_decl FullCheck with_symbols write_full_buffer_fragment_progress d in + return (queries @ push_mod, [])) + qid + + | _ -> + let decls = filter_decls decls in + let push_kind = + match request_type with + | LaxToPosition _ -> LaxCheck + | Lax -> LaxCheck + | _ -> FullCheck + in + let queries, issues = + run_qst (inspect_repl_stack (!repl_stack) decls push_kind with_symbols write_full_buffer_fragment_progress) qid + in + if request_type <> Cache then log_syntax_issues err_opt; + if Debug.any() + then ( + BU.print1 "Generating queries\n%s\n" + (String.concat "\n" (List.map query_to_string queries)) + ); + if request_type <> Cache then (queries, issues) else ([] , issues) + + ) + + | ParseError err -> + if request_type = Full then log_syntax_issues (Some err); + [], [] + | _ -> + failwith "Unexpected parse result" + in + qs + +(* See comment in interface file *) +let format_code (st:repl_state) (code:string) + = let maybe_lang = + match st.repl_lang with + | [] -> None + | {d=FStarC.Parser.AST.UseLangDecls l}::_ -> Some l + in + let parse_result = parse_code maybe_lang code in + match parse_result with + | IncrementalFragment (decls, comments, None) -> + let doc_to_string doc = + FStarC.Pprint.pretty_string (float_of_string "1.0") 100 doc + in + let formatted_code_rev, leftover_comments = + List.fold_left + (fun (out, comments) (d, _) -> + let doc, comments = FStarC.Parser.ToDocument.decl_with_comments_to_document d comments in + doc_to_string doc::out, comments) + ([], List.rev comments) + decls + in + let code = formatted_code_rev |> List.rev |> String.concat "\n\n" in + let formatted_code = + match leftover_comments with + | [] -> code + | _ -> + let doc = FStarC.Parser.ToDocument.comments_to_document leftover_comments in + code ^ "\n\n" ^ doc_to_string doc + in + Inl formatted_code + | IncrementalFragment (_, _, Some err) -> + Inr [syntax_issue err] + | ParseError err -> + Inr [syntax_issue err] + | _ -> + failwith "Unexpected parse result" diff --git a/src/fstar/FStarC.Interactive.Incremental.fsti b/src/fstar/FStarC.Interactive.Incremental.fsti new file mode 100644 index 00000000000..3682d01c02b --- /dev/null +++ b/src/fstar/FStarC.Interactive.Incremental.fsti @@ -0,0 +1,58 @@ +(* + Copyright 2023 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Interactive.Incremental +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.Parser.AST +open FStarC.Errors +open FStarC.Interactive.Ide.Types +open FStarC.Compiler.Util + +(* Various kinds of progress messages to print back to the client *) +type fragment_progress = + | FullBufferStarted + | FragmentStarted of decl + | FragmentSuccess of (decl & FStarC.Parser.ParseIt.code_fragment & push_kind) + | FragmentFailed of decl + | FragmentError of list issue + | FullBufferFinished + +(* Translates a full-buffer(qid, code) query by + 1. Parsing the code into its declarations + 2. Finding a prefix of the repl state that matches a prefix of the declarations + 3. Popping away the suffix of the repl state + 4. Pushing the suffix of parsed decls for checking + + It uses the write_full_buffer_fragment_progress callback to issue + success markers for the prefix of decls that were found in the repl state, + and issues syntax errors for the suffix of the code that could not be parsed. +*) +val run_full_buffer (st:repl_state) + (qid:string) + (code:string) + (full:full_buffer_request_kind) + (with_symbols:bool) + (write_full_buffer_fragment_progress: fragment_progress -> unit) + : list query & list json + +(* Pretty-print the code for reformatting, or return a syntax error *) +val format_code (st:repl_state) + (code:string) + : either string (list issue) \ No newline at end of file diff --git a/src/fstar/FStarC.Interactive.JsonHelper.fst b/src/fstar/FStarC.Interactive.JsonHelper.fst new file mode 100644 index 00000000000..a9b952acf56 --- /dev/null +++ b/src/fstar/FStarC.Interactive.JsonHelper.fst @@ -0,0 +1,264 @@ +(* + Copyright 2019 and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +(* Json helpers mainly for FStarC.Interactive.Lsp; some sharing with * + * FStarC.Interactive.Ide *) + +module FStarC.Interactive.JsonHelper +open FStar open FStarC +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.Errors +open FStarC.Compiler.Range +open FStarC.Json +open FStarC.TypeChecker.Env + +module U = FStarC.Compiler.Util +module PI = FStarC.Parser.ParseIt +module TcEnv = FStarC.TypeChecker.Env +module CTable = FStarC.Interactive.CompletionTable + +let try_assoc (key: string) (d: assoct) = + U.map_option snd (U.try_find (fun (k, _) -> k = key) d) + +// All exceptions are guaranteed to be caught in the LSP server implementation +exception MissingKey of string // Only in LSP +exception InvalidQuery of string // Only in IDE +exception UnexpectedJsonType of string & json +exception MalformedHeader +exception InputExhausted + +// The definition in IDE is nested; this differs in not providing loc +let assoc key a = + match try_assoc key a with + | Some v -> v + | None -> raise (MissingKey (U.format1 "Missing key [%s]" key)) + +let write_json (js: json) = + U.print_raw (string_of_json js); + U.print_raw "\n" + +let write_jsonrpc (js: json) : unit = + // TODO: utf-8 strings: byte buffers? + let js_str = string_of_json js in + let len = U.string_of_int (String.length js_str) in + U.print_raw (U.format2 "Content-Length: %s\r\n\r\n%s" len js_str) + +// Only used in IDE +let js_fail expected got = + raise (UnexpectedJsonType (expected, got)) + +let js_int : json -> int = function + | JsonInt i -> i + | other -> js_fail "int" other +let js_bool : json -> bool = function + | JsonBool b -> b + | other -> js_fail "int" other +let js_str : json -> string = function + | JsonStr s -> s + | other -> js_fail "string" other +let js_list k = function + | JsonList l -> List.map k l + | other -> js_fail "list" other +let js_assoc : json -> assoct = function + | JsonAssoc a -> a + | other -> js_fail "dictionary" other +let js_str_int : json -> int = function + | JsonInt i -> i + | JsonStr s -> U.int_of_string s + | other -> js_fail "string or int" other + +// May throw +let arg k r = assoc k (assoc "params" r |> js_assoc) + +// UNIX paths: file:///foo/bar corresponds to /foo/bar +// 01234567 +// +// Windows paths: "file:///z%3A/foo corresponds to z:/foo +// 0123456789 012 +let uri_to_path u = if U.substring u 9 3 = "%3A" then + U.format2 "%s:%s" (U.substring u 8 1) (U.substring_from u 12) + else U.substring_from u 7 +let path_to_uri u = if U.char_at u 1 = ':' then + let rest = U.replace_char (U.substring_from u 2) '\\' '/' in + U.format2 "file:///%s%3A%s" (U.substring u 0 1) rest + else U.format1 "file://%s" u + +let js_compl_context : json -> completion_context = function + | JsonAssoc a -> + { trigger_kind = assoc "triggerKind" a |> js_int; + trigger_char = try_assoc "triggerChar" a |> U.map_option js_str; } + | other -> js_fail "dictionary" other + +// May throw +let js_txdoc_item : json -> txdoc_item = function + | JsonAssoc a -> + let arg k = assoc k a in + { fname = uri_to_path (arg "uri" |> js_str); + langId = arg "languageId" |> js_str; + version = arg "version" |> js_int; + text = arg "text" |> js_str } + | other -> js_fail "dictionary" other + +// May throw, argument is of the form { "textDocument" : {"uri" : ... } } +let js_txdoc_id (r: list (string & json)) : string = + uri_to_path (assoc "uri" (arg "textDocument" r |> js_assoc) |> js_str) + +// May throw; argument is of the form { "textDocument" : ..., +// "position" : { "line" : ..., "character" : ... } } +let js_txdoc_pos (r: list (string & json)) : txdoc_pos = + let pos = arg "position" r |> js_assoc in + { path = js_txdoc_id r; + line = assoc "line" pos |> js_int; + col = assoc "character" pos |> js_int } + +// May throw +let js_wsch_event : json -> wsch_event = function + | JsonAssoc a -> + let added' = assoc "added" a |> js_assoc in + let removed' = assoc "removed" a |> js_assoc in + { added = { wk_uri = assoc "uri" added' |> js_str; + wk_name = assoc "name" added' |> js_str }; + removed = { wk_uri = assoc "uri" removed' |> js_str; + wk_name = assoc "name" removed' |> js_str } } + | other -> js_fail "dictionary" other + +// May throw +let js_contentch : json -> string = function + // List will have one item, and List.hd is guaranteed to work, + // since we've specified that full text should be sent on change + // in the capabilities + | JsonList l -> List.hd (List.map (fun (JsonAssoc a) -> assoc "text" a |> js_str) l) + | other -> js_fail "dictionary" other + +type rng = { rng_start: int & int; rng_end: int & int } + +// May throw +let js_rng : json -> rng = function + | JsonAssoc a -> + let st = assoc "start" a in + let fin = assoc "end" a in + let l = assoc "line" in + let c = assoc "character" in + { rng_start = l (st |> js_assoc) |> js_int, c (st |> js_assoc) |> js_int; + rng_end = l (fin |> js_assoc) |> js_int, c (st |> js_assoc) |> js_int } + | other -> js_fail "dictionary" other + +let errorcode_to_int : error_code -> int = function +| ParseError -> -32700 +| InvalidRequest -> -32600 +| MethodNotFound -> -32601 +| InvalidParams -> -32602 +| InternalError -> -32603 +| ServerErrorStart -> -32099 +| ServerErrorEnd -> -32000 +| ServerNotInitialized -> -32002 +| UnknownErrorCode -> -32001 +| RequestCancelled -> -32800 +| ContentModified -> -32801 + +let json_debug = function + | JsonNull -> "null" + | JsonBool b -> U.format1 "bool (%s)" (if b then "true" else "false") + | JsonInt i -> U.format1 "int (%s)" (U.string_of_int i) + | JsonStr s -> U.format1 "string (%s)" s + | JsonList _ -> "list (...)" + | JsonAssoc _ -> "dictionary (...)" + +// The IDE uses a slightly different variant (wrap_js_failure) +// because types differ (query' versus lsp_query) +let wrap_jsfail (qid : option int) expected got : lsp_query = + { query_id = qid; + q = BadProtocolMsg (U.format2 "JSON decoding failed: expected %s, got %s" + expected (json_debug got)) } + +(* Helpers for constructing the response *) + +// Trivial helpers +let resultResponse (r: json) : option assoct = Some [("result", r)] +let errorResponse (r: json) : option assoct = Some [("error", r)] + +// When a response is expected, but we have nothing to say (used for unimplemented bits as well) +let nullResponse : option assoct = resultResponse JsonNull + +let json_of_response (qid: option int) (response: assoct) : json = + match qid with + | Some i -> JsonAssoc ([("jsonrpc", JsonStr "2.0"); ("id", JsonInt i)] @ response) + // In the case of a notification response, there is no query_id associated + | None -> JsonAssoc ([("jsonrpc", JsonStr "2.0")] @ response) + +let js_resperr (err: error_code) (msg: string) : json = + JsonAssoc [("code", JsonInt (errorcode_to_int err)); ("message", JsonStr msg)] + +let wrap_content_szerr (m: string): lsp_query = { query_id = None; q = BadProtocolMsg m } + +let js_servcap : json = + JsonAssoc [("capabilities", + // Open, close, change, and save events will happen with full text sent; + // change is required for auto-completions + JsonAssoc [("textDocumentSync", JsonAssoc [ + ("openClose", JsonBool true); + ("change", JsonInt 1); + ("willSave", JsonBool false); + ("willSaveWaitUntil", JsonBool false); + ("save", JsonAssoc [("includeText", JsonBool true)])]); + ("hoverProvider", JsonBool true); + ("completionProvider", JsonAssoc []); + ("signatureHelpProvider", JsonAssoc []); + ("definitionProvider", JsonBool true); + ("typeDefinitionProvider", JsonBool false); + ("implementationProvider", JsonBool false); + ("referencesProvider", JsonBool false); + ("documentSymbolProvider", JsonBool false); + ("workspaceSymbolProvider", JsonBool false); + ("codeActionProvider", JsonBool false)])] + +// LSP uses zero-indexed line numbers while the F* typechecker uses 1-indexed ones; +// column numbers are zero-indexed in both +let js_pos (p: pos) : json = JsonAssoc [("line", JsonInt (line_of_pos p - 1)); + ("character", JsonInt (col_of_pos p))] + +let js_range (r: Range.range) : json = + JsonAssoc [("start", js_pos (start_of_range r)); ("end", js_pos (end_of_range r))] + +// Used to report diagnostic, for example, when loading dependencies fails +let js_dummyrange : json = + JsonAssoc [("start", JsonAssoc [("line", JsonInt 0); ("character", JsonInt 0); + ("end", JsonAssoc [("line", JsonInt 0); ("character", JsonInt 0)])])] + +let js_loclink (r: Range.range) : json = + let s = js_range r in + JsonList [JsonAssoc [("targetUri", JsonStr (path_to_uri (file_of_range r))); + ("targetRange", s); ("targetSelectionRange", s)]] + +// Lines are 0-indexed in LSP, but 1-indexed in the F* Typechecker; +let pos_munge (pos: txdoc_pos) = (pos.path, pos.line + 1, pos.col) + +let js_diag (fname: string) (msg: string) (r: option Range.range) : assoct = + let r' = match r with + | Some r -> js_range r + | None -> js_dummyrange in + // Unfortunately, the F* typechecker aborts on the very first diagnostic + let ds = ("diagnostics", JsonList [JsonAssoc [("range", r'); ("message", JsonStr msg)]]) in + [("method", JsonStr "textDocument/publishDiagnostics"); + ("params", JsonAssoc [("uri", JsonStr (path_to_uri fname)); ds])] + +let js_diag_clear (fname: string) : assoct = + [("method", JsonStr "textDocument/publishDiagnostics"); + ("params", JsonAssoc [("uri", JsonStr (path_to_uri fname)); ("diagnostics", JsonList [])])] + diff --git a/src/fstar/FStarC.Interactive.JsonHelper.fsti b/src/fstar/FStarC.Interactive.JsonHelper.fsti new file mode 100644 index 00000000000..9b20833e5cb --- /dev/null +++ b/src/fstar/FStarC.Interactive.JsonHelper.fsti @@ -0,0 +1,167 @@ +(* + Copyright 2019 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +(* Json helpers mainly for FStarC.Interactive.Lsp; some sharing with * + * FStarC.Interactive.Ide *) + +module FStarC.Interactive.JsonHelper +open FStar open FStarC +open FStarC.Compiler +open FStarC.Errors +open FStarC.Json +open FStarC.Compiler.Util + +// Type of an associative array +type assoct = list (string & json) + +val try_assoc : string -> assoct -> option json // nothrow +val assoc : string -> assoct -> json // throw + +// All exceptions are guaranteed to be caught in the LSP server implementation +exception MissingKey of string // Only in LSP +exception InvalidQuery of string // Only in IDE +exception UnexpectedJsonType of string & json +exception MalformedHeader +exception InputExhausted + +val write_json : json -> unit // Only used in IDE +val write_jsonrpc : json -> unit // Only used in LSP +val js_fail : string -> json -> 'a + +val js_int : json -> int +val js_bool : json -> bool +val js_str : json -> string +val js_list : (json -> 'a) -> json -> list 'a +val js_assoc : json -> assoct +val js_str_int : json -> int + +val arg : string -> assoct -> json +val uri_to_path : string -> string + +type completion_context = { trigger_kind: int; trigger_char: option string } +val js_compl_context : json -> completion_context + +type txdoc_item = { fname: string; langId: string; version: int; text: string } +val js_txdoc_item : json -> txdoc_item + +type txdoc_pos = { path: string; line: int; col: int } +val js_txdoc_id : assoct -> string +val js_txdoc_pos : assoct -> txdoc_pos + +type workspace_folder = { wk_uri: string; wk_name: string } +type wsch_event = { added: workspace_folder; removed: workspace_folder } +val js_wsch_event : json -> wsch_event +val js_contentch : json -> string + +type lquery = +| Initialize of int & string +| Initialized +| Shutdown +| Exit +| Cancel of int +| FolderChange of wsch_event +| ChangeConfig +| ChangeWatch +| Symbol of string +| ExecCommand of string +| DidOpen of txdoc_item +| DidChange of string & string +| WillSave of string +| WillSaveWait of string +| DidSave of string & string +| DidClose of string +| Completion of txdoc_pos & completion_context +| Resolve +| Hover of txdoc_pos +| SignatureHelp of txdoc_pos +| Declaration of txdoc_pos +| Definition of txdoc_pos +| TypeDefinition of txdoc_pos +| Implementation of txdoc_pos +| References +| DocumentHighlight of txdoc_pos +| DocumentSymbol +| CodeAction +| CodeLens +| CodeLensResolve +| DocumentLink +| DocumentLinkResolve +| DocumentColor +| ColorPresentation +| Formatting +| RangeFormatting +| TypeFormatting +| Rename +| PrepareRename of txdoc_pos +| FoldingRange +| BadProtocolMsg of string + +type lsp_query = { query_id: option int; q: lquery } + + +type error_code = +| ParseError +| InvalidRequest +| MethodNotFound +| InvalidParams +| InternalError +| ServerErrorStart +| ServerErrorEnd +| ServerNotInitialized +| UnknownErrorCode +| RequestCancelled +| ContentModified + +// A lookup table for pretty-printing error codes +val errorcode_to_int : error_code -> int + +// Another lookup table for pretty-printing JSON objects +val json_debug : json -> string + +// Wrap an error-code along with a description of the error in a BadProtocolMsg +val wrap_jsfail : option int -> string -> json -> lsp_query + +(* Helpers for constructing the response *) + +// Used by run_query heavily +val resultResponse : json -> option assoct +val errorResponse : json -> option assoct +val nullResponse : option assoct + +// Build JSON of a given response +val json_of_response : option int -> assoct -> json + +// Given an error_code and a string describing the error, build a JSON error +val js_resperr : error_code -> string -> json + +// Build an error corresponding to BadProtocolMsg +val wrap_content_szerr : string -> lsp_query + +// Report on server capabilities +val js_servcap : json + +// Create a JSON location link from a Range.range +val js_loclink : Range.range -> json + +// Convert txdoc_pos into (filename, line, col) +val pos_munge : txdoc_pos -> string & int & int + +// Build a JSON diagnostic +val js_diag : string -> string -> option Range.range -> assoct + +// Build an empty JSON diagnostic; used for clearing diagnostic +val js_diag_clear : string -> assoct + diff --git a/src/fstar/FStarC.Interactive.Legacy.fst b/src/fstar/FStarC.Interactive.Legacy.fst new file mode 100644 index 00000000000..b5355d831da --- /dev/null +++ b/src/fstar/FStarC.Interactive.Legacy.fst @@ -0,0 +1,581 @@ +(* + Copyright 2008-2016 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Interactive.Legacy +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.Getopt +open FStarC.Ident + +open FStarC.Universal +open FStarC.TypeChecker.Env +open FStarC.Parser + +module DsEnv = FStarC.Syntax.DsEnv +module TcEnv = FStarC.TypeChecker.Env + +// A custom version of the function that's in FStarC.Universal.fs just for the +// sake of the interactive mode +let tc_one_file (remaining:list string) (env:TcEnv.env) = //:((string option * string) * uenv * string list) = + let (intf, impl), env, remaining = + match remaining with + | intf :: impl :: remaining when needs_interleaving intf impl -> + let _, env = tc_one_file_for_ide env (Some intf) impl Dep.empty_parsing_data in + (Some intf, impl), env, remaining + | intf_or_impl :: remaining -> + let _, env = tc_one_file_for_ide env None intf_or_impl Dep.empty_parsing_data in + (None, intf_or_impl), env, remaining + | [] -> failwith "Impossible" + in + (intf, impl), env, remaining + +// The interactive mode has its own notion of a stack that is super flaky, +// seeing that there's a lot of mutable state under the hood. This is most +// likely not working as the original author intended it to. + +type env_t = TcEnv.env +type modul_t = option Syntax.Syntax.modul +type stack_t = list (env_t & modul_t) + +// Note: many of these functions are passing env around just for the sake of +// providing a link to the solver (to avoid a cross-project dependency). They're +// not actually doing anything useful with the environment you're passing it (e.g. +// pop). + +let pop env msg = + ignore (TypeChecker.Tc.pop_context env msg); + Options.pop() + +let push_with_kind env lax restore_cmd_line_options msg = + let env = { env with admit = lax } in + let res = TypeChecker.Tc.push_context env msg in + Options.push(); + if restore_cmd_line_options then Options.restore_cmd_line_options false |> ignore; + res + +let check_frag (env:TcEnv.env) curmod frag = + try + let m, env, _ = tc_one_fragment curmod env (Inl frag) in + Some (m, env, FStarC.Errors.get_err_count()) + with + | FStarC.Errors.Error(e, msg, r, ctx) when not ((Options.trace_error())) -> + FStarC.TypeChecker.Err.add_errors env [(e, msg, r, ctx)]; + None + +let report_fail () = + FStarC.Errors.report_all() |> ignore; + FStarC.Errors.clear() + +(******************************************************************************************) +(* The interface expected to be provided by a type-checker to run in the interactive loop *) +(******************************************************************************************) + + +(****************************************************************************************) +(* Internal data structures for managing chunks of input from the editor *) +(****************************************************************************************) +type input_chunks = + | Push of bool & int & int //the bool flag indicates lax flag set from the editor + | Pop of string + | Code of string & (string & string) + | Info of string & bool & option (string & int & int) + | Completions of string + + +type interactive_state = { + // The current chunk -- chunks end on #end boundaries per the communication + // protocol. + chunk: string_builder; + stdin: ref (option stream_reader); // Initialized once. + // A list of chunks read so far + buffer: ref (list input_chunks); + log: ref (option out_channel); +} + + +let the_interactive_state = { + chunk = Util.new_string_builder (); + stdin = mk_ref None; + buffer = mk_ref []; + log = mk_ref None +} + +(***********************************************************************) +(* Reading some input *) +(***********************************************************************) +let rec read_chunk () = + let s = the_interactive_state in + let log : string -> unit = + if Debug.any() then + let transcript = + match !s.log with + | Some transcript -> transcript + | None -> + let transcript = Util.open_file_for_writing "transcript" in + s.log := Some transcript; + transcript + in + fun line -> + Util.append_to_file transcript line; + Util.flush transcript + else + fun _ -> () + in + let stdin = + match !s.stdin with + | Some i -> i + | None -> + let i = Util.open_stdin () in + s.stdin := Some i; + i + in + let line = + match Util.read_line stdin with + | None -> exit 0 + | Some l -> l + in + log line; + + let l = Util.trim_string line in + if Util.starts_with l "#end" then begin + let responses = + match Util.split l " " with + | [_; ok; fail] -> (ok, fail) + | _ -> ("ok", "fail") in + let str = Util.string_of_string_builder s.chunk in + Util.clear_string_builder s.chunk; Code (str, responses) + end + else if Util.starts_with l "#pop" then (Util.clear_string_builder s.chunk; Pop l) + else if Util.starts_with l "#push" then ( + Util.clear_string_builder s.chunk; + let lc_lax = Util.trim_string (Util.substring_from l (String.length "#push")) in + let lc = match Util.split lc_lax " " with + | [l; c; "#lax"] -> true, Util.int_of_string l, Util.int_of_string c + | [l; c] -> false, Util.int_of_string l, Util.int_of_string c + | _ -> + Errors.log_issue0 Errors.Warning_WrongErrorLocation ("Error locations may be wrong, unrecognized string after #push: " ^ lc_lax); + false, 1, 0 + in + Push lc) + else if Util.starts_with l "#info " then + match Util.split l " " with + | [_; symbol] -> + Util.clear_string_builder s.chunk; + Info (symbol, true, None) + | [_; symbol; file; row; col] -> + Util.clear_string_builder s.chunk; + Info (symbol, false, Some (file, Util.int_of_string row, Util.int_of_string col)) + | _ -> + Errors.log_issue0 Errors.Error_IDEUnrecognized ("Unrecognized \"#info\" request: " ^ l); + exit 1 + else if Util.starts_with l "#completions " then + match Util.split l " " with + | [_; prefix; "#"] -> // Extra "#" marks the end of the input. FIXME protocol could take more structured messages. + Util.clear_string_builder s.chunk; + Completions (prefix) + | _ -> + Errors.log_issue0 Errors.Error_IDEUnrecognized ("Unrecognized \"#completions\" request: " ^ l); + exit 1 + else if l = "#finish" then exit 0 + else + (Util.string_builder_append s.chunk line; + Util.string_builder_append s.chunk "\n"; + read_chunk()) + +let shift_chunk () = + let s = the_interactive_state in + match !s.buffer with + | [] -> read_chunk () + | chunk :: chunks -> + s.buffer := chunks; + chunk + +let fill_buffer () = + let s = the_interactive_state in + s.buffer := !s.buffer @ [ read_chunk () ] + + +(******************************************************************************************) +(* The main interactive loop *) +(******************************************************************************************) +open FStarC.Parser.ParseIt + +let deps_of_our_file filename = + (* Now that fstar-mode.el passes the name of the current file, we must parse + * and lax-check everything but the current module we're editing. This + * function may, optionally, return an interface if the currently edited + * module is an implementation and an interface was found. *) + let deps, dep_graph = FStarC.Dependencies.find_deps_if_needed [ filename ] FStarC.CheckedFiles.load_parsing_data_from_cache in + let deps, same_name = List.partition (fun x -> + Parser.Dep.lowercase_module_name x <> Parser.Dep.lowercase_module_name filename + ) deps in + let maybe_intf = match same_name with + | [ intf; impl ] -> + if not (Parser.Dep.is_interface intf) || not (Parser.Dep.is_implementation impl) then + Errors.log_issue0 Errors.Warning_MissingInterfaceOrImplementation (Util.format2 "Found %s and %s but not an interface + implementation" intf impl); + Some intf + | [ impl ] -> + None + | _ -> + Errors.log_issue0 Errors.Warning_UnexpectedFile (Util.format1 "Unexpected: ended up with %s" (String.concat " " same_name)); + None + in + deps, maybe_intf, dep_graph + +(* .fsti name (optional) * .fst name * .fsti recorded timestamp (optional) * .fst recorded timestamp *) +type m_timestamps = list (option string & string & option time & time) + +(* + * type check remaining dependencies and record the timestamps. + * m is the current module name, not the module name of the dependency. it's actually a dummy that is pushed on the stack and never used. + * it is used for type checking the fragments of the current module, but for dependencies it is a dummy. + * adding it as the stack entry needed it. + * env is the environment in which next dependency should be type checked. + * the returned timestamps are in the reverse order (i.e. final dependency first), it's the same order as the stack. + * note that for dependencies, the stack and ts go together (i.e. their sizes are same) + * returns the new stack, environment, and timestamps. + *) +let rec tc_deps (m:modul_t) (stack:stack_t) + (env:TcEnv.env) (remaining:list string) (ts:m_timestamps) +// : stack 'env,modul_t * 'env * m_timestamps + = match remaining with + | [] -> stack, env, ts + | _ -> + let stack = (env, m)::stack in + //setting the restore command line options flag true + let env = push_with_kind env (Options.lax ()) true "typecheck_modul" in + let (intf, impl), env, remaining = tc_one_file remaining env in + let intf_t, impl_t = + let intf_t = + match intf with + | Some intf -> Some (get_file_last_modification_time intf) + | None -> None + in + let impl_t = get_file_last_modification_time impl in + intf_t, impl_t + in + tc_deps m stack env remaining ((intf, impl, intf_t, impl_t)::ts) + + +(* + * check if some dependencies have been modified, added, or deleted + * if so, only type check them and anything that follows, while maintaining others as is (current dependency graph is a total order) + * we will first compute the dependencies again, and then traverse the ts list + * if we find that the dependency at the head of ts does not match that at the head of the newly computed dependency, + * or that the dependency is stale, we will typecheck that dependency, and everything that comes after that again + * the stack and timestamps are passed in "last dependency first" order, so we will reverse them before checking + * as with tc_deps, m is the dummy argument used for the stack entry + * returns the new stack, environment, and timestamps + *) +let update_deps (filename:string) (m:modul_t) (stk:stack_t) (env:env_t) (ts:m_timestamps) + : (stack_t & env_t & m_timestamps) = + let is_stale (intf:option string) (impl:string) (intf_t:option time) (impl_t:time) :bool = + let impl_mt = get_file_last_modification_time impl in + (is_before impl_t impl_mt || + (match intf, intf_t with + | Some intf, Some intf_t -> + let intf_mt = get_file_last_modification_time intf in + is_before intf_t intf_mt + | None, None -> false + | _, _ -> failwith "Impossible, if the interface is None, the timestamp entry should also be None")) + in + + (* + * iterate over the timestamps list + * if the current entry matches the head of the deps, and is not stale, then leave it as is, and go to next, else discard everything after that and tc_deps the deps again + * good_stack and good_ts are stack and timestamps that are not stale so far + * st and ts are expected to be in "first dependency first order" + * also, for the first call to iterate, good_stack and good_ts are empty + * during recursive calls, the good_stack and good_ts grow "last dependency first" order. + * returns the new stack, environment, and timestamps + *) + let rec iterate (depnames:list string) (st:stack_t) (env':env_t) + (ts:m_timestamps) (good_stack:stack_t) (good_ts:m_timestamps) = //:(stack 'env, modul_t * 'env * m_timestamps) = + //invariant length good_stack = length good_ts, and same for stack and ts + + let match_dep (depnames:list string) (intf:option string) (impl:string) : (bool & list string) = + match intf with + | None -> + (match depnames with + | dep::depnames' -> if dep = impl then true, depnames' else false, depnames + | _ -> false, depnames) + | Some intf -> + (match depnames with + | depintf::dep::depnames' -> if depintf = intf && dep = impl then true, depnames' else false, depnames + | _ -> false, depnames) + in + + //expected the stack to be in "last dependency first order", we want to pop in the proper order (although should not matter) + let rec pop_tc_and_stack (env:env_t) (stack:list (env_t & modul_t)) ts = + match ts with + | [] -> (* stack should also be empty here *) env + | _::ts -> + //pop + pop env ""; + let (env, _), stack = List.hd stack, List.tl stack in + pop_tc_and_stack env stack ts + in + + match ts with + | ts_elt::ts' -> + let intf, impl, intf_t, impl_t = ts_elt in + let b, depnames' = match_dep depnames intf impl in + if not b || (is_stale intf impl intf_t impl_t) then + //reverse st from "first dependency first order" to "last dependency first order" + let env = pop_tc_and_stack env' (List.rev_append st []) ts in + tc_deps m good_stack env depnames good_ts + else + let stack_elt, st' = List.hd st, List.tl st in + iterate depnames' st' env' ts' (stack_elt::good_stack) (ts_elt::good_ts) + | [] -> (* st should also be empty here *) tc_deps m good_stack env' depnames good_ts + in + + (* Well, the file list hasn't changed, so our (single) file is still there. *) + let filenames, _, dep_graph = deps_of_our_file filename in + //reverse stk and ts, since iterate expects them in "first dependency first order" + iterate filenames (List.rev_append stk []) env (List.rev_append ts []) [] [] + +let format_info env name typ range (doc: option string) = + Util.format4 "(defined at %s) %s: %s%s" + (Range.string_of_range range) + name + (FStarC.TypeChecker.Normalize.term_to_string env typ) + (match doc with + | Some docstring -> Util.format1 "#doc %s" docstring + | None -> "") + +let rec go (line_col:(int&int)) + (filename:string) + (stack:stack_t) (curmod:modul_t) (env:env_t) (ts:m_timestamps) : unit = begin + match shift_chunk () with + | Info(symbol, fqn_only, pos_opt) -> + let info_at_pos_opt = match pos_opt with + | None -> None + | Some (file, row, col) -> FStarC.TypeChecker.Err.info_at_pos env file row col in + let info_opt = match info_at_pos_opt with + | Some _ -> info_at_pos_opt + | None -> // Use name lookup as a fallback + if symbol = "" then None + else let lid = Ident.lid_of_ids (List.map Ident.id_of_text (Util.split symbol ".")) in + let lid = if fqn_only then lid + else match DsEnv.resolve_to_fully_qualified_name env.dsenv lid with + | None -> lid + | Some lid -> lid in + try_lookup_lid env lid + |> Util.map_option (fun ((_, typ), r) -> (Inr lid, typ, r)) in + (match info_opt with + | None -> Util.print_string "\n#done-nok\n" + | Some (name_or_lid, typ, rng) -> + let name, doc = + match name_or_lid with + | Inl name -> name, None + | Inr lid -> Ident.string_of_lid lid, None in + Util.print1 "%s\n#done-ok\n" (format_info env name typ rng doc)); + go line_col filename stack curmod env ts + | Completions search_term -> + //search_term is the partially written identifer by the user + // FIXME a regular expression might be faster than this explicit matching + let rec measure_anchored_match + : list string -> list ident -> option (list ident & int) + //determines it the candidate may match the search term + //and, if so, provides an integer measure of the degree of the match + //Q: isn't the output list ident always the same as the candidate? + // About the degree of the match, cpitclaudel says: + // Because we're measuring the length of the match and we allow partial + // matches. Say we're matching FS.Li.app against FStarC.Compiler.List.Append. Then + // the length we want is (length "FStar" + 1 + length "List" + 1 + length + // "app"), not (length "FStar" + 1 + length "List" + 1 + length + // "append"). This length is used to know how much of the candidate to + // highlight in the company-mode popup (we want to display the candidate + // as FStarC.Compiler.List.append. + = fun search_term candidate -> + match search_term, candidate with + | [], _ -> Some ([], 0) + | _, [] -> None + | hs :: ts, hc :: tc -> + let hc_text = FStarC.Ident.string_of_id hc in + if Util.starts_with hc_text hs then + match ts with + | [] -> Some (candidate, String.length hs) + | _ -> measure_anchored_match ts tc |> + Util.map_option (fun (matched, len) -> (hc :: matched, String.length hc_text + 1 + len)) + else None in + let rec locate_match + : list string -> list ident -> option (list ident & list ident & int) + = fun needle candidate -> + match measure_anchored_match needle candidate with + | Some (matched, n) -> Some ([], matched, n) + | None -> + match candidate with + | [] -> None + | hc :: tc -> + locate_match needle tc |> + Util.map_option (fun (prefix, matched, len) -> (hc :: prefix, matched, len)) in + let str_of_ids ids = Util.concat_l "." (List.map FStarC.Ident.string_of_id ids) in + let match_lident_against needle lident = + locate_match needle (ns_of_lid lident @ [ident_of_lid lident]) + in + let shorten_namespace (prefix, matched, match_len) = + let naked_match = match matched with [_] -> true | _ -> false in + let stripped_ns, shortened = Syntax.DsEnv.shorten_module_path env.dsenv prefix naked_match in + (str_of_ids shortened, str_of_ids matched, str_of_ids stripped_ns, match_len) in + let prepare_candidate (prefix, matched, stripped_ns, match_len) = + if prefix = "" then + (matched, stripped_ns, match_len) + else + (prefix ^ "." ^ matched, stripped_ns, String.length prefix + match_len + 1) in + let needle = Util.split search_term "." in + let all_lidents_in_env = FStarC.TypeChecker.Env.lidents env in + let matches = + //There are two cases here: + //Either the needle is of the form: + // (a) A.x where A resolves to the module L.M.N + //or (b) the needle's namespace is not a well-formed module. + //In case (a), we go to the desugaring to find the names + // transitively exported by L.M.N + //In case (b), we find all lidents in the type-checking environment + // and rank them by potential matches to the needle + let case_a_find_transitive_includes (orig_ns:list string) (m:lident) (id:string) + : list (list ident & list ident & int) + = + let exported_names = DsEnv.transitive_exported_ids env.dsenv m in + let matched_length = + List.fold_left + (fun out s -> String.length s + out + 1) + (String.length id) + orig_ns + in + exported_names |> + List.filter_map (fun n -> + if Util.starts_with n id + then let lid = Ident.lid_of_ns_and_id (Ident.ids_of_lid m) (Ident.id_of_text n) in + Option.map (fun fqn -> [], (List.map Ident.id_of_text orig_ns)@[ident_of_lid fqn], matched_length) + (DsEnv.resolve_to_fully_qualified_name env.dsenv lid) + else None) + in + let case_b_find_matches_in_env () + : list (list ident & list ident & int) + = let matches = List.filter_map (match_lident_against needle) all_lidents_in_env in + //Retain only the ones that can be resolved that are resolvable to themselves in dsenv + matches |> List.filter (fun (ns, id, _) -> + match DsEnv.resolve_to_fully_qualified_name env.dsenv (Ident.lid_of_ids id) with + | None -> false + | Some l -> Ident.lid_equals l (Ident.lid_of_ids (ns@id))) + in + let ns, id = Util.prefix needle in + let matched_ids = + match ns with + | [] -> case_b_find_matches_in_env () + | _ -> + let l = Ident.lid_of_path ns Range.dummyRange in + match FStarC.Syntax.DsEnv.resolve_module_name env.dsenv l true with + | None -> + case_b_find_matches_in_env () + | Some m -> + case_a_find_transitive_includes ns m id + in + matched_ids |> + List.map (fun x -> prepare_candidate (shorten_namespace x)) + in + List.iter (fun (candidate, ns, match_len) -> + Util.print3 "%s %s %s \n" + (Util.string_of_int match_len) ns candidate) + (Util.sort_with (fun (cd1, ns1, _) (cd2, ns2, _) -> + match String.compare cd1 cd2 with + | 0 -> String.compare ns1 ns2 + | n -> n) + matches); + Util.print_string "#done-ok\n"; + go line_col filename stack curmod env ts + | Pop msg -> + // This shrinks all internal stacks by 1 + pop env msg; + let (env, curmod), stack = + match stack with + | [] -> Errors.log_issue0 Errors.Error_IDETooManyPops "Too many pops"; exit 1 + | hd::tl -> hd, tl + in + go line_col filename stack curmod env ts + + | Push (lax, l, c) -> + // This grows all internal stacks by 1 + //if we are at a stage where we have not yet pushed a fragment from the current buffer, see if some dependency is stale + //if so, update it + //also if this is the first chunk, we need to restore the command line options + let restore_cmd_line_options, (stack, env, ts) = + if List.length stack = List.length ts then true, update_deps filename curmod stack env ts else false, (stack, env, ts) + in + let stack = (env, curmod)::stack in + let env = push_with_kind env lax restore_cmd_line_options "#push" in + go (l, c) filename stack curmod env ts + + | Code (text, (ok, fail)) -> + // This does not grow any of the internal stacks. + let fail curmod tcenv = + report_fail(); + Util.print1 "%s\n" fail; + // The interactive mode will send a pop here + go line_col filename stack curmod tcenv ts + in + + let frag = {frag_fname=" input"; + frag_text=text; + frag_line=fst line_col; + frag_col=snd line_col} in + let res = check_frag env curmod (frag,[]) in begin + match res with + | Some (curmod, env, n_errs) -> + if n_errs=0 then begin + Util.print1 "\n%s\n" ok; + go line_col filename stack curmod env ts + end + else fail curmod env + | _ -> fail curmod env + end +end + +// filename is the name of the file currently edited +let interactive_mode (filename:string): unit = + + if Option.isSome (Options.codegen()) then + Errors.log_issue0 Errors.Warning_IDEIgnoreCodeGen "Code-generation is not supported in interactive mode, ignoring the codegen flag"; + + //type check prims and the dependencies + let filenames, maybe_intf, dep_graph = deps_of_our_file filename in + let env = init_env dep_graph in + let stack, env, ts = tc_deps None [] env filenames [] in + let initial_range = Range.mk_range filename (Range.mk_pos 1 0) (Range.mk_pos 1 0) in + let env = FStarC.TypeChecker.Env.set_range env initial_range in + let env = + match maybe_intf with + | Some intf -> + // We found an interface: record its contents in the desugaring environment + // to be interleaved with the module implementation on-demand + FStarC.Universal.load_interface_decls env intf + | None -> + env + in + + if FStarC.Options.record_hints() //and if we're recording or using hints + || FStarC.Options.use_hints() + then FStarC.SMTEncoding.Solver.with_hints_db + (List.hd (Options.file_list ())) + (fun () -> go (1, 0) filename stack None env ts) + else go (1, 0) filename stack None env ts diff --git a/src/fstar/FStarC.Interactive.Lsp.fst b/src/fstar/FStarC.Interactive.Lsp.fst new file mode 100644 index 00000000000..a5b4401ed2b --- /dev/null +++ b/src/fstar/FStarC.Interactive.Lsp.fst @@ -0,0 +1,238 @@ +(* + Copyright 2019 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Interactive.Lsp + +open FStar open FStarC +open FStarC.Compiler +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.Util +open FStarC.Compiler.Range +open FStarC.Errors +open FStarC.Universal +open FStarC.Interactive.Ide.Types +open FStarC.Interactive.JsonHelper + +module U = FStarC.Compiler.Util +module QH = FStarC.Interactive.QueryHelper +module PH = FStarC.Interactive.PushHelper +module PI = FStarC.Parser.ParseIt +module TcEnv = FStarC.TypeChecker.Env + +(* Request *) + +// nothrow +let unpack_lsp_query (r : list (string & json)) : lsp_query = + let qid = try_assoc "id" r |> U.map_option js_str_int in // noexcept + + // If we make it this far, exceptions will come with qid info. + // Wrap in `try` because all `js_*` functions and `assoc` throw + try + let method = assoc "method" r |> js_str in + { query_id = qid; + q = match method with + | "initialize" -> Initialize (arg "processId" r |> js_int, + arg "rootUri" r |> js_str) + | "initialized" -> Initialized + | "shutdown" -> Shutdown + | "exit" -> Exit + | "$/cancelRequest" -> Cancel (arg "id" r |> js_str_int) + | "workspace/didChangeWorkspaceFolders" -> FolderChange + (arg "event" r |> js_wsch_event) + | "workspace/didChangeConfiguration" -> ChangeConfig + | "workspace/didChangeWatchedFiles" -> ChangeWatch + | "workspace/symbol" -> Symbol (arg "query" r |> js_str) + | "workspace/executeCommand" -> ExecCommand + (arg "command" r |> js_str) + | "textDocument/didOpen" -> DidOpen (arg "textDocument" r |> js_txdoc_item) + | "textDocument/didChange" -> DidChange (js_txdoc_id r, + arg "contentChanges" r |> js_contentch) + | "textDocument/willSave" -> WillSave (js_txdoc_id r) + | "textDocument/willSaveWaitUntil" -> WillSaveWait (js_txdoc_id r) + | "textDocument/didSave" -> DidSave (js_txdoc_id r, arg "text" r |> js_str) + | "textDocument/didClose" -> DidClose (js_txdoc_id r) + | "textDocument/completion" -> Completion (js_txdoc_pos r, + arg "context" r |> js_compl_context) + | "completionItem/resolve" -> Resolve + | "textDocument/hover" -> Hover (js_txdoc_pos r) + | "textDocument/signatureHelp" -> SignatureHelp (js_txdoc_pos r) + | "textDocument/declaration" -> Declaration (js_txdoc_pos r) + | "textDocument/definition" -> Definition (js_txdoc_pos r) + | "textDocument/typeDefinition" -> TypeDefinition (js_txdoc_pos r) + | "textDocument/implementation" -> Implementation (js_txdoc_pos r) + | "textDocument/references" -> References + | "textDocument/documentHighlight" -> DocumentHighlight (js_txdoc_pos r) + | "textDocument/documentSymbol" -> DocumentSymbol + | "textDocument/codeAction" -> CodeAction + | "textDocument/codeLens" -> CodeLens + | "codeLens/resolve" -> CodeLensResolve + | "textDocument/documentLink" -> DocumentLink + | "documentLink/resolve" -> DocumentLinkResolve + | "textDocument/documentColor" -> DocumentColor + | "textDocument/colorPresentation" -> ColorPresentation + | "textDocument/formatting" -> Formatting + | "textDocument/rangeFormatting" -> RangeFormatting + | "textDocument/onTypeFormatting" -> TypeFormatting + | "textDocument/rename" -> Rename + | "textDocument/prepareRename" -> PrepareRename (js_txdoc_pos r) + | "textDocument/foldingRange" -> FoldingRange + | m -> BadProtocolMsg (U.format1 "Unknown method '%s'" m) } + with + | MissingKey msg -> { query_id = qid; q = BadProtocolMsg msg } + | UnexpectedJsonType (expected, got) -> wrap_jsfail qid expected got + +let deserialize_lsp_query js_query : lsp_query = + try + unpack_lsp_query (js_query |> js_assoc) + with + // This is the only excpetion that js_assoc is allowed to throw + | UnexpectedJsonType (expected, got) -> wrap_jsfail None expected got + +let parse_lsp_query query_str : lsp_query = + if false then U.print1_error ">>> %s\n" query_str; + match json_of_string query_str with + | None -> { query_id = None; q = BadProtocolMsg "Json parsing failed" } + | Some request -> deserialize_lsp_query request + +(* Repl and response *) + +let repl_state_init (fname: string) : repl_state = + let intial_range = Range.mk_range fname (Range.mk_pos 1 0) (Range.mk_pos 1 0) in + let env = init_env FStarC.Parser.Dep.empty_deps in + let env = TcEnv.set_range env intial_range in + { repl_line = 1; + repl_column = 0; + repl_fname = fname; + repl_curmod = None; + repl_env = env; + repl_deps_stack = []; + repl_stdin = open_stdin (); + repl_names = CompletionTable.empty; + repl_buffered_input_queries = []; + repl_lang = [] } + +type optresponse = option assoct // Contains [("result", ...)], [("error", ...)], but is not + // the full response; call json_of_response for that +type either_gst_exit = either grepl_state int // grepl_state is independent of exit_code + +let invoke_full_lax (gst: grepl_state) (fname: string) (text: string) (force: bool) + : optresponse & either_gst_exit = + let aux () = + PI.add_vfs_entry fname text; + let diag, st' = PH.full_lax text (repl_state_init fname) in + let repls = U.psmap_add gst.grepl_repls fname st' in + // explicitly clear diags + let diag = if U.is_some diag then diag else Some (js_diag_clear fname) in + diag, Inl ({ gst with grepl_repls = repls }) in + match U.psmap_try_find gst.grepl_repls fname with + | Some _ -> if force then aux () else None, Inl gst + | None -> aux () + +let run_query (gst: grepl_state) (q: lquery) : optresponse & either_gst_exit = + match q with + | Initialize (_, _) -> resultResponse js_servcap, Inl gst + | Initialized -> None, Inl gst + | Shutdown -> nullResponse, Inl gst + | Exit -> None, Inr 0 + | Cancel id -> None, Inl gst + | FolderChange evt -> nullResponse, Inl gst + | ChangeConfig -> nullResponse, Inl gst + | ChangeWatch -> None, Inl gst + | Symbol sym -> nullResponse, Inl gst + | ExecCommand cmd -> nullResponse, Inl gst + | DidOpen { fname = f; langId = _; version = _; text = t } -> invoke_full_lax gst f t false + | DidChange (txid, content) -> PI.add_vfs_entry txid content; None, Inl gst + | WillSave txid -> None, Inl gst + | WillSaveWait txid -> nullResponse, Inl gst + | DidSave (f, t) -> invoke_full_lax gst f t true + | DidClose txid -> None, Inl gst + | Completion (txpos, ctx) -> + (match U.psmap_try_find gst.grepl_repls txpos.path with + | Some st -> QH.complookup st txpos, Inl gst + | None -> nullResponse, Inl gst) + | Resolve -> nullResponse, Inl gst + | Hover txpos -> + (match U.psmap_try_find gst.grepl_repls txpos.path with + | Some st -> QH.hoverlookup st.repl_env txpos, Inl gst + | None -> nullResponse, Inl gst) + | SignatureHelp txpos -> nullResponse, Inl gst + | Declaration txpos -> nullResponse, Inl gst + | Definition txpos -> + (match U.psmap_try_find gst.grepl_repls txpos.path with + | Some st -> QH.deflookup st.repl_env txpos, Inl gst + | None -> nullResponse, Inl gst) + | TypeDefinition txpos -> nullResponse, Inl gst + | Implementation txpos -> nullResponse, Inl gst + | References -> nullResponse, Inl gst + | DocumentHighlight txpos -> nullResponse, Inl gst + | DocumentSymbol -> nullResponse, Inl gst + | CodeAction -> nullResponse, Inl gst + | CodeLens -> nullResponse, Inl gst + | CodeLensResolve -> nullResponse, Inl gst + | DocumentLink -> nullResponse, Inl gst + | DocumentLinkResolve -> nullResponse, Inl gst + | DocumentColor -> nullResponse, Inl gst + | ColorPresentation -> nullResponse, Inl gst + | Formatting -> nullResponse, Inl gst + | RangeFormatting -> nullResponse, Inl gst + | TypeFormatting -> nullResponse, Inl gst + | Rename -> nullResponse, Inl gst + | PrepareRename txpos -> nullResponse, Inl gst + | FoldingRange -> nullResponse, Inl gst + | BadProtocolMsg msg -> errorResponse (js_resperr MethodNotFound msg), Inl gst + +// Raises exceptions, but all of them are caught +let rec parse_header_len (stream: stream_reader) (len: int): int = + // Blocking read + match U.read_line stream with + | Some s -> + if U.starts_with s "Content-Length: " then + match U.safe_int_of_string (U.substring_from s 16) with + | Some new_len -> parse_header_len stream new_len + | None -> raise MalformedHeader + else if U.starts_with s "Content-Type: " then + parse_header_len stream len + else if s = "" then + len + else + raise MalformedHeader + | None -> raise InputExhausted + +let rec read_lsp_query (stream: stream_reader) : lsp_query = + try + let n = parse_header_len stream 0 in + match U.nread stream n with + | Some s -> parse_lsp_query s + | None -> wrap_content_szerr (U.format1 "Could not read %s bytes" (U.string_of_int n)) + with + // At no cost should the server go down + | MalformedHeader -> U.print_error "[E] Malformed Content Header\n"; read_lsp_query stream + | InputExhausted -> read_lsp_query stream + +let rec go (gst: grepl_state) : int = + let query = read_lsp_query gst.grepl_stdin in + let r, state_opt = run_query gst query.q in + (match r with + | Some response -> (let response' = json_of_response query.query_id response in + if false then U.print1_error "<<< %s\n" (string_of_json response'); + write_jsonrpc response') + | None -> ()); // Don't respond + match state_opt with + | Inl gst' -> go gst' + | Inr exitcode -> exitcode + +let start_server () : unit = exit (go ({ grepl_repls = U.psmap_empty (); + grepl_stdin = open_stdin () })) diff --git a/src/fstar/FStarC.Interactive.PushHelper.fst b/src/fstar/FStarC.Interactive.PushHelper.fst new file mode 100644 index 00000000000..d37566e62f6 --- /dev/null +++ b/src/fstar/FStarC.Interactive.PushHelper.fst @@ -0,0 +1,392 @@ +(* + Copyright 2019 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +(* FStarC.Interactive.Lsp and FStarC.Interactive.Ide need to push various * + * text fragments and update state; this file collects helpers for them *) + +module FStarC.Interactive.PushHelper +open FStar open FStarC +open FStarC.Compiler +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Compiler.Util +open FStarC.Ident +open FStarC.Errors +open FStarC.Universal +open FStarC.Parser.ParseIt +open FStarC.TypeChecker.Env +open FStarC.Interactive.JsonHelper +open FStarC.Interactive.Ide.Types + +module U = FStarC.Compiler.Util +module SS = FStarC.Syntax.Syntax +module DsEnv = FStarC.Syntax.DsEnv +module TcErr = FStarC.TypeChecker.Err +module TcEnv = FStarC.TypeChecker.Env +module CTable = FStarC.Interactive.CompletionTable + +let repl_stack: ref repl_stack_t = U.mk_ref [] + +let set_check_kind env check_kind = + { env with admit = (check_kind = LaxCheck || Options.lax()); + dsenv = DsEnv.set_syntax_only env.dsenv (check_kind = SyntaxCheck)} + +(** Build a list of dependency loading tasks from a list of dependencies **) +let repl_ld_tasks_of_deps (deps: list string) (final_tasks: list repl_task) = + let wrap fname = { tf_fname = fname; tf_modtime = U.now () } in + let rec aux (deps:list string) (final_tasks:list repl_task) + : list repl_task = + match deps with + | intf :: impl :: deps' when needs_interleaving intf impl -> + LDInterleaved (wrap intf, wrap impl) :: aux deps' final_tasks + | intf_or_impl :: deps' -> + LDSingle (wrap intf_or_impl) :: aux deps' final_tasks + | [] -> final_tasks in + aux deps final_tasks + +(** Compute dependencies of `filename` and steps needed to load them. + +The dependencies are a list of file name. The steps are a list of +``repl_task`` elements, to be executed by ``run_repl_task``. **) +let deps_and_repl_ld_tasks_of_our_file filename + : list string + & list repl_task + & FStarC.Parser.Dep.deps = + let get_mod_name fname = + Parser.Dep.lowercase_module_name fname in + let our_mod_name = + get_mod_name filename in + let has_our_mod_name f = + (get_mod_name f = our_mod_name) in + + let parse_data_cache = FStarC.CheckedFiles.load_parsing_data_from_cache in + let deps, dep_graph = FStarC.Dependencies.find_deps_if_needed [filename] parse_data_cache in + let same_name, real_deps = + List.partition has_our_mod_name deps in + + let intf_tasks = + match same_name with + | [intf; impl] -> + if not (Parser.Dep.is_interface intf) then + raise_error0 Errors.Fatal_MissingInterface (U.format1 "Expecting an interface, got %s" intf); + if not (Parser.Dep.is_implementation impl) then + raise_error0 Errors.Fatal_MissingImplementation + (U.format1 "Expecting an implementation, got %s" impl); + [LDInterfaceOfCurrentFile ({ tf_fname = intf; tf_modtime = U.now () }) ] + | [impl] -> + [] + | _ -> + let mods_str = String.concat " " same_name in + let message = "Too many or too few files matching %s: %s" in + raise_error0 Errors.Fatal_TooManyOrTooFewFileMatch (U.format message [our_mod_name; mods_str]); + [] in + + let tasks = + repl_ld_tasks_of_deps real_deps intf_tasks in + real_deps, tasks, dep_graph + +(** Checkpoint the current (typechecking and desugaring) environment **) +let snapshot_env env msg : repl_depth_t & env_t = + let ctx_depth, env = TypeChecker.Tc.snapshot_context env msg in + let opt_depth, () = Options.snapshot () in + (ctx_depth, opt_depth), env + +let push_repl msg push_kind_opt task st = + let depth, env = snapshot_env st.repl_env msg in + repl_stack := (depth, (task, st)) :: !repl_stack; + match push_kind_opt with + | None -> st + | Some push_kind -> + { st with repl_env = set_check_kind env push_kind } // repl_env is the only mutable part of st + +(* Record the issues that were raised by the last push *) +let add_issues_to_push_fragment (issues: list json) = + match !repl_stack with + | (depth, (PushFragment(frag, push_kind, i), st))::rest -> ( + let pf = PushFragment(frag, push_kind, issues @ i) in + repl_stack := (depth, (pf, st)) :: rest + ) + | _ -> () + +(** Revert to a previous checkpoint. + +Usage note: A proper push/pop pair looks like this: + + let noop = + let env', depth = snapshot_env env in + // [Do stuff with env'] + let env'' = rollback_env env'.solver depth in + env'' + +In most cases, the invariant should hold that ``env'' === env`` (look for +assertions of the form ``physical_equality _ _`` in the sources). + +You may be wondering why we need ``snapshot`` and ``rollback``. Aren't ``push`` +and ``pop`` sufficient? They are not. The issue is that the typechecker's code +can encounter (fatal) errors at essentially any point, and was not written to +clean up after itself in these cases. Fatal errors are handled by raising an +exception, skipping all code that would ``pop`` previously pushed state. + +That's why we need ``rollback``: all that rollback does is call ``pop`` +sufficiently many times to get back into the state we were before the +corresponding ``pop``. **) +let rollback_env solver msg (ctx_depth, opt_depth) = + let env = TypeChecker.Tc.rollback_context solver msg (Some ctx_depth) in + Options.rollback (Some opt_depth); + env + +let pop_repl msg st = + match !repl_stack with + | [] -> failwith "Too many pops" + | (depth, (_, st')) :: stack_tl -> + let env = rollback_env st.repl_env.solver msg depth in + repl_stack := stack_tl; + // Because of the way ``snapshot`` is implemented, the `st'` and `env` + // that we rollback to should be consistent: + FStarC.Common.runtime_assert + (U.physical_equality env st'.repl_env) + "Inconsistent stack state"; + st' + +(** Like ``tc_one_file``, but only return the new environment **) +let tc_one (env:env_t) intf_opt modf = + let parse_data = modf |> FStarC.Parser.Dep.parsing_data_of (TcEnv.dep_graph env) in + let _, env = tc_one_file_for_ide env intf_opt modf parse_data in + env + +open FStarC.Class.Show +(** Load the file or files described by `task` **) +let run_repl_task (curmod: optmod_t) (env: env_t) (task: repl_task) lds : optmod_t & env_t & lang_decls_t = + match task with + | LDInterleaved (intf, impl) -> + curmod, tc_one env (Some intf.tf_fname) impl.tf_fname, [] + | LDSingle intf_or_impl -> + curmod, tc_one env None intf_or_impl.tf_fname, [] + | LDInterfaceOfCurrentFile intf -> + curmod, Universal.load_interface_decls env intf.tf_fname, [] + | PushFragment (frag, _, _) -> + let frag = + match frag with + | Inl frag -> Inl (frag, lds) + | Inr decl -> Inr decl + in + let o, e, langs = tc_one_fragment curmod env frag in + o, e, langs + | Noop -> + curmod, env, [] + +(*******************************************) +(* Name tracking: required for completions *) +(*******************************************) + +let query_of_ids (ids: list ident) : CTable.query = + List.map string_of_id ids + +let query_of_lid (lid: lident) : CTable.query = + query_of_ids (ns_of_lid lid @ [ident_of_lid lid]) + +let update_names_from_event cur_mod_str table evt = + let is_cur_mod lid = (string_of_lid lid) = cur_mod_str in + match evt with + | NTAlias (host, id, included) -> + if is_cur_mod host then + CTable.register_alias + table (string_of_id id) [] (query_of_lid included) + else + table + | NTOpen (host, (included, kind, _)) -> + if is_cur_mod host then + CTable.register_open + table (kind = FStarC.Syntax.Syntax.Open_module) [] (query_of_lid included) + else + table + | NTInclude (host, included) -> + CTable.register_include + table (if is_cur_mod host then [] else query_of_lid host) (query_of_lid included) + | NTBinding binding -> + let lids = + match binding with + | Inl (SS.Binding_lid (lid, _)) -> [lid] + | Inr (lids, _) -> lids + | _ -> [] in + List.fold_left + (fun tbl lid -> + let ns_query = if nsstr lid = cur_mod_str then [] + else query_of_ids (ns_of_lid lid) in + CTable.insert + tbl ns_query (string_of_id (ident_of_lid lid)) lid) + table lids + +let commit_name_tracking' cur_mod names name_events = + let cur_mod_str = match cur_mod with + | None -> "" | Some md -> string_of_lid (SS.mod_name md) in + let updater = update_names_from_event cur_mod_str in + List.fold_left updater names name_events + +let commit_name_tracking st name_events = + let names = commit_name_tracking' st.repl_curmod st.repl_names name_events in + { st with repl_names = names } + +let fresh_name_tracking_hooks () = + let events = Util.mk_ref [] in + let push_event evt = events := evt :: !events in + events, + DsEnv.mk_dsenv_hooks + (fun dsenv op -> push_event (NTOpen (DsEnv.current_module dsenv, op))) + (fun dsenv ns -> push_event (NTInclude (DsEnv.current_module dsenv, ns))) + (fun dsenv x l -> push_event (NTAlias (DsEnv.current_module dsenv, x, l))), + { TcEnv.tc_push_in_gamma_hook = + (fun _ s -> push_event (NTBinding s)) } + +let track_name_changes (env: env_t) + : env_t & (env_t -> env_t & list name_tracking_event) = + let set_hooks dshooks tchooks env = + let (), tcenv' = with_dsenv_of_tcenv env (fun dsenv -> (), DsEnv.set_ds_hooks dsenv dshooks) in + TcEnv.set_tc_hooks tcenv' tchooks in + + let old_dshooks, old_tchooks = DsEnv.ds_hooks env.dsenv, TcEnv.tc_hooks env in + let events, new_dshooks, new_tchooks = fresh_name_tracking_hooks () in + + set_hooks new_dshooks new_tchooks env, + (fun env -> set_hooks old_dshooks old_tchooks env, + List.rev !events) + +// A REPL transaction with different error handling; used exclusively by LSP; +// variant of run_repl_transaction in IDE +let repl_tx st push_kind task = + try + let st = push_repl "repl_tx" (Some push_kind) task st in + let env, finish_name_tracking = track_name_changes st.repl_env in // begin name tracking + let curmod, env, lds = run_repl_task st.repl_curmod env task st.repl_lang in + let st = { st with repl_curmod = curmod; repl_env = env; repl_lang=List.rev lds @ st.repl_lang } in + let env, name_events = finish_name_tracking env in // end name tracking + None, commit_name_tracking st name_events + with + | Failure (msg) -> + Some (js_diag st.repl_fname msg None), st + | U.SigInt -> + U.print_error "[E] Interrupt"; None, st + | Error (e, msg, r, _ctx) -> // TODO: display the error context somehow + // FIXME, or is it OK to render? + Some (js_diag st.repl_fname (Errors.rendermsg msg) (Some r)), st + | Stop -> + U.print_error "[E] Stop"; None, st + +// Little helper +let tf_of_fname fname = + { tf_fname = fname; + tf_modtime = Parser.ParseIt.get_file_last_modification_time fname } + +// Little helper: update timestamps in argument task to last modification times. +let update_task_timestamps = function + | LDInterleaved (intf, impl) -> + LDInterleaved (tf_of_fname intf.tf_fname, tf_of_fname impl.tf_fname) + | LDSingle intf_or_impl -> + LDSingle (tf_of_fname intf_or_impl.tf_fname) + | LDInterfaceOfCurrentFile intf -> + LDInterfaceOfCurrentFile (tf_of_fname intf.tf_fname) + | other -> other + +// Variant of run_repl_ld_transactions in IDE; used exclusively by LSP. +// The first dependencies (prims, ...) come first; the current file's +// interface comes last. The original value of the `repl_deps_stack` field +// in ``st`` is used to skip already completed tasks. +let repl_ldtx (st: repl_state) (tasks: list repl_task) : either_replst = + + (* Run as many ``pop_repl`` as there are entries in the input stack. + Elements of the input stack are expected to match the topmost ones of + ``!repl_stack`` *) + let rec revert_many st = function + | [] -> st + | (_id, (task, _st')) :: entries -> + let st' = pop_repl "repl_ldtx" st in + let dep_graph = TcEnv.dep_graph st.repl_env in + let st' = { st' with repl_env = TcEnv.set_dep_graph st'.repl_env dep_graph } in + revert_many st' entries in + + let rec aux (st: repl_state) + (tasks: list repl_task) + (previous: list repl_stack_entry_t) = + match tasks, previous with + // All done: return the final state. + | [], [] -> Inl st + + // We have more dependencies to load, and no previously loaded dependencies: + // run ``task`` and record the updated dependency stack in ``st``. + | task :: tasks, [] -> + let timestamped_task = update_task_timestamps task in + let diag, st = repl_tx st LaxCheck timestamped_task in + if not (U.is_some diag) then aux ({ st with repl_deps_stack = !repl_stack }) tasks [] + else Inr st + + // We've already run ``task`` previously, and no update is needed: skip. + | task :: tasks, prev :: previous + when fst (snd prev) = update_task_timestamps task -> + aux st tasks previous + + // We have a timestamp mismatch or a new dependency: + // revert now-obsolete dependencies and resume loading. + | tasks, previous -> + aux (revert_many st previous) tasks [] in + + aux st tasks (List.rev st.repl_deps_stack) + +// Variant of load_deps in IDE; used exclusively by LSP +let ld_deps st = + try + let (deps, tasks, dep_graph) = deps_and_repl_ld_tasks_of_our_file st.repl_fname in + let st = { st with repl_env = TcEnv.set_dep_graph st.repl_env dep_graph } in + match repl_ldtx st tasks with + | Inr st -> Inr st + | Inl st -> Inl (st, deps) + with + | Error (e, msg, _rng, ctx) -> U.print1_error "[E] Failed to load deps. %s" (Errors.rendermsg msg); Inr st + | exn -> U.print1_error "[E] Failed to load deps. Message: %s" (message_of_exn exn); Inr st + +let add_module_completions this_fname deps table = + let capitalize str = if str = "" then str + else let first = String.substring str 0 1 in + String.uppercase first ^ String.substring str 1 (String.length str - 1) in + let mods = + FStarC.Parser.Dep.build_inclusion_candidates_list () in + let loaded_mods_set = + List.fold_left + (fun acc dep -> psmap_add acc (Parser.Dep.lowercase_module_name dep) true) + (psmap_empty ()) (Basefiles.prims () :: deps) in // Prims is an implicit dependency + let loaded modname = + psmap_find_default loaded_mods_set modname false in + let this_mod_key = + Parser.Dep.lowercase_module_name this_fname in + List.fold_left (fun table (modname, mod_path) -> + // modname is the filename part of mod_path + let mod_key = String.lowercase modname in + if this_mod_key = mod_key then + table // Exclude current module from completion + else + let ns_query = Util.split (capitalize modname) "." in + CTable.register_module_path table (loaded mod_key) mod_path ns_query) + table (List.rev mods) // List.rev to process files in order or *increasing* precedence + +// Variant of run_push_with_deps in IDE; used exclusively by LSP +let full_lax text st = + TcEnv.toggle_id_info st.repl_env true; + let frag = { frag_fname = st.repl_fname; frag_text = text; frag_line = 1; frag_col = 0 } in + match ld_deps st with + | Inl (st, deps) -> + let names = add_module_completions st.repl_fname deps st.repl_names in + repl_tx ({ st with repl_names = names }) LaxCheck (PushFragment (Inl frag, LaxCheck, [])) + | Inr st -> None, st diff --git a/src/fstar/FStarC.Interactive.PushHelper.fsti b/src/fstar/FStarC.Interactive.PushHelper.fsti new file mode 100644 index 00000000000..7858a8abfb5 --- /dev/null +++ b/src/fstar/FStarC.Interactive.PushHelper.fsti @@ -0,0 +1,71 @@ +(* + Copyright 2019 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +(* FStarC.Interactive.Lsp and FStarC.Interactive.Ide need to push various * + * text fragments and update state; this file collects helpers for them *) + +module FStarC.Interactive.PushHelper +open FStar open FStarC +open FStarC.Compiler +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.Util +open FStarC.Ident +open FStarC.TypeChecker.Env +open FStarC.Interactive.JsonHelper +open FStarC.Interactive.Ide.Types + +module DsEnv = FStarC.Syntax.DsEnv +module CTable = FStarC.Interactive.CompletionTable +module TcEnv = FStarC.TypeChecker.Env + +type ctx_depth_t = int & int & solver_depth_t & int +type deps_t = FStarC.Parser.Dep.deps +type either_replst = either repl_state repl_state + +// Name tracking; taken directly from IDE +type name_tracking_event = +| NTAlias of lid (* host *) & ident (* alias *) & lid (* aliased *) +| NTOpen of lid (* host *) & FStarC.Syntax.Syntax.open_module_or_namespace (* opened *) +| NTInclude of lid (* host *) & lid (* included *) +| NTBinding of either FStarC.Syntax.Syntax.binding TcEnv.sig_binding + +val repl_stack : ref repl_stack_t +val set_check_kind : env_t -> push_kind -> env_t + +// Push an Pop, directly copied over from IDE +val push_repl : string -> option push_kind -> repl_task -> repl_state -> repl_state +val add_issues_to_push_fragment (issues: list json) : unit +val pop_repl : string -> repl_state -> repl_state + +// Factored out from IDE for use by LSP as well +val deps_and_repl_ld_tasks_of_our_file : string -> list string & list repl_task & deps_t + +// Core functionality, directly copied over from IDE +val run_repl_task +: optmod_t -> env_t -> repl_task -> FStarC.Universal.lang_decls_t -> + optmod_t & env_t & FStarC.Universal.lang_decls_t + +// Factored out from IDE for use by LSP as well +val update_task_timestamps : repl_task -> repl_task +val add_module_completions : string -> list string -> CTable.table -> CTable.table + +val track_name_changes : env_t -> env_t & (env_t -> env_t & list name_tracking_event) +val commit_name_tracking : repl_state -> list name_tracking_event -> repl_state + +// Lax-check the whole file; used on didOpen and didSave +// returns a diagnostic (only on error) along with the repl_state +val full_lax : string -> repl_state -> option assoct & repl_state diff --git a/src/fstar/FStarC.Interactive.QueryHelper.fst b/src/fstar/FStarC.Interactive.QueryHelper.fst new file mode 100644 index 00000000000..fe32f40d39b --- /dev/null +++ b/src/fstar/FStarC.Interactive.QueryHelper.fst @@ -0,0 +1,144 @@ +(* + Copyright 2019 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +(* FStarC.Interactive.Lsp needs to construct responses to various * + * queries; this file collects helpers for them *) + +module FStarC.Interactive.QueryHelper +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStar.Pervasives +open FStarC.Compiler.Range +open FStarC.Compiler.Util +open FStarC.TypeChecker.Env +open FStarC.TypeChecker.Common +open FStarC.Interactive.JsonHelper +open FStarC.Interactive.CompletionTable + +module U = FStarC.Compiler.Util +module PI = FStarC.Parser.ParseIt +module DsEnv = FStarC.Syntax.DsEnv +module TcErr = FStarC.TypeChecker.Err +module TcEnv = FStarC.TypeChecker.Env +module CTable = FStarC.Interactive.CompletionTable + +let with_printed_effect_args k = + Options.with_saved_options + (fun () -> Options.set_option "print_effect_args" (Options.Bool true); k ()) + +let term_to_string tcenv t = + with_printed_effect_args (fun () -> FStarC.TypeChecker.Normalize.term_to_string tcenv t) + +let sigelt_to_string tcenv se = + with_printed_effect_args (fun () -> Syntax.Print.sigelt_to_string' (DsEnv.set_current_module tcenv.dsenv tcenv.curmodule) se) + +let symlookup tcenv symbol pos_opt requested_info = + let info_of_lid_str lid_str = + let lid = Ident.lid_of_ids (List.map Ident.id_of_text (U.split lid_str ".")) in + let lid = U.dflt lid <| DsEnv.resolve_to_fully_qualified_name tcenv.dsenv lid in + try_lookup_lid tcenv lid |> U.map_option (fun ((_, typ), r) -> (Inr lid, typ, r)) in + + let docs_of_lid lid = None in + + let def_of_lid lid = + U.bind_opt (TcEnv.lookup_qname tcenv lid) (function + | (Inr (se, _), _) -> Some (sigelt_to_string tcenv se) + | _ -> None) in + + let info_at_pos_opt = + U.bind_opt pos_opt (fun (file, row, col) -> + TcErr.info_at_pos tcenv file row col) in + + let info_opt = + match info_at_pos_opt with + | Some _ -> info_at_pos_opt + | None -> if symbol = "" then None else info_of_lid_str symbol in + + match info_opt with + | None -> None + | Some (name_or_lid, typ, rng) -> + let name = + match name_or_lid with + | Inl name -> name + | Inr lid -> Ident.string_of_lid lid in + let str_of_opt = function + | None -> "" + | Some s -> s in + let typ_str = + if List.mem "type" requested_info then + Some (term_to_string tcenv typ) + else None in + let doc_str = + match name_or_lid with + | Inr lid when List.mem "documentation" requested_info -> docs_of_lid lid + | _ -> None in + let def_str = + match name_or_lid with + | Inr lid when List.mem "definition" requested_info -> def_of_lid lid + | _ -> None in + let def_range = + if List.mem "defined-at" requested_info then Some rng else None in + Some ({ slr_name = name; slr_def_range = def_range; + slr_typ = typ_str; slr_doc = doc_str; slr_def = def_str }) + +let mod_filter = function + | _, CTable.Namespace _ + | _, CTable.Module { CTable.mod_loaded = true } -> None + | pth, CTable.Module md -> + Some (pth, CTable.Module ({ md with CTable.mod_name = CTable.mod_name md ^ "." })) + +let ck_completion (st: repl_state) (search_term: string) : list CTable.completion_result = + let needle = U.split search_term "." in + let mods_and_nss = CTable.autocomplete_mod_or_ns st.repl_names needle mod_filter in + let lids = CTable.autocomplete_lid st.repl_names needle in + lids @ mods_and_nss + +let deflookup (env: TcEnv.env) (pos: txdoc_pos) : option assoct = + match symlookup env "" (Some (pos_munge pos)) ["defined-at"] with + | Some { slr_name = _; slr_def_range = (Some r); slr_typ = _; slr_doc = _; slr_def = _ } -> + resultResponse (js_loclink r) + | _ -> nullResponse + +// A hover-provider provides both the type and the definition of a given symbol +let hoverlookup (env: TcEnv.env) (pos: txdoc_pos) : option assoct = + match symlookup env "" (Some (pos_munge pos)) ["type"; "definition"] with + | Some { slr_name = n; slr_def_range = _; slr_typ = (Some t); slr_doc = _; slr_def = (Some d) } -> + let hovertxt = U.format2 "```fstar\n%s\n````\n---\n```fstar\n%s\n```" t d in + resultResponse (JsonAssoc [("contents", JsonAssoc [("kind", JsonStr "markdown"); + ("value", JsonStr hovertxt)])]) + | _ -> nullResponse + +let complookup (st: repl_state) (pos: txdoc_pos) : option assoct = + // current_col corresponds to the current cursor position of the incomplete identifier + let (file, row, current_col) = pos_munge pos in + let (Some (_, text)) = PI.read_vfs_entry file in + // Find the column that begins a partial identifier + let rec find_col l = + match l with + | [] -> 0 + | h::t -> if h = ' ' && List.length t < current_col then (List.length t + 1) else find_col t in + let str = List.nth (U.splitlines text) (row - 1) in + let explode s = + let rec exp i l = + if i < 0 then l else exp (i - 1) (String.get s i :: l) in + exp (String.length s - 1) [] in + let begin_col = find_col (List.rev (explode str)) in + let term = U.substring str begin_col (current_col - begin_col) in + let items = ck_completion st term in + let l = List.map (fun r -> JsonAssoc [("label", JsonStr r.completion_candidate)]) items in + resultResponse (JsonList l) diff --git a/src/fstar/FStarC.Interactive.QueryHelper.fsti b/src/fstar/FStarC.Interactive.QueryHelper.fsti new file mode 100644 index 00000000000..feb83433d07 --- /dev/null +++ b/src/fstar/FStarC.Interactive.QueryHelper.fsti @@ -0,0 +1,53 @@ +(* + Copyright 2019 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +(* FStarC.Interactive.Lsp needs to construct responses to various * + * queries; this file collects helpers for them *) + +module FStarC.Interactive.QueryHelper +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Range +open FStarC.Compiler.Util +open FStarC.TypeChecker.Env +open FStarC.Interactive.JsonHelper +open FStarC.Interactive.Ide.Types + +module TcErr = FStarC.TypeChecker.Err +module TcEnv = FStarC.TypeChecker.Env +module CTable = FStarC.Interactive.CompletionTable + +type position = string & int & int +type sl_reponse = { slr_name: string; + slr_def_range: option Range.range; + slr_typ: option string; + slr_doc: option string; + slr_def: option string } + +// Shared by IDE and LSP +val term_to_string : TcEnv.env -> Syntax.Syntax.term -> string +val symlookup : TcEnv.env -> string -> option position -> list string -> option sl_reponse +val ck_completion : repl_state -> string -> list CTable.completion_result + +(* Used exclusively by LSP *) +// Lookup the definition of a particular term located at txdoc_pos +val deflookup : TcEnv.env -> txdoc_pos -> option assoct + +// Lookup the on-hover documentation for a particular term located at txdoc_pos +val hoverlookup : TcEnv.env -> txdoc_pos -> option assoct + +// Lookup the completion information for a particular term located at txdoc_pos +val complookup : repl_state -> txdoc_pos -> option assoct diff --git a/src/fstar/FStarC.Main.fst b/src/fstar/FStarC.Main.fst new file mode 100644 index 00000000000..297dcc94752 --- /dev/null +++ b/src/fstar/FStarC.Main.fst @@ -0,0 +1,354 @@ +(* + Copyright 2008-2016 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Main +open FStarC +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Compiler.Util +open FStarC.Getopt +open FStarC.Ident +open FStarC.CheckedFiles +open FStarC.Universal +open FStarC.Compiler + +open FStarC.Class.Show + +module E = FStarC.Errors +module UF = FStarC.Syntax.Unionfind +module RE = FStarC.Reflection.V2.Embeddings + +let _ = FStarC.Version.dummy () + +(* These modules only mentioned to put them in the dep graph +and hence compile and link them in. They do not export anything, +instead they register primitive steps in the normalizer during +initialization. *) +open FStarC.Reflection.V1.Interpreter {} +open FStarC.Reflection.V2.Interpreter {} + +(* process_args: parses command line arguments, setting FStarC.Options *) +(* returns an error status and list of filenames *) +let process_args () : parse_cmdline_res & list string = + Options.parse_cmd_line () + +(* cleanup: kills background Z3 processes; relevant when --n_cores > 1 *) +(* GM: unclear if it's useful now? *) +let cleanup () = Util.kill_all () + +(* printing a finished message *) +let finished_message fmods errs = + let print_to = if errs > 0 then Util.print_error else Util.print_string in + if not (Options.silent()) then begin + fmods |> List.iter (fun (iface, name) -> + let tag = if iface then "i'face (or impl+i'face)" else "module" in + if Options.should_print_message (string_of_lid name) + then print_to (Util.format2 "Verified %s: %s\n" tag (Ident.string_of_lid name))); + if errs > 0 + then if errs = 1 + then Util.print_error "1 error was reported (see above)\n" + else Util.print1_error "%s errors were reported (see above)\n" (string_of_int errs) + else print1 "%s\n" (Util.colorize_bold "All verification conditions discharged successfully") + end + +(* printing total error count *) +let report_errors fmods = + FStarC.Errors.report_all () |> ignore; + let nerrs = FStarC.Errors.get_err_count() in + if nerrs > 0 then begin + finished_message fmods nerrs; + exit 1 + end + +let load_native_tactics () = + let modules_to_load = Options.load() |> List.map Ident.lid_of_str in + let cmxs_to_load = Options.load_cmxs () |> List.map Ident.lid_of_str in + let ml_module_name m = FStarC.Extraction.ML.Util.ml_module_name_of_lid m in + let ml_file m = ml_module_name m ^ ".ml" in + let cmxs_file m = + let cmxs = ml_module_name m ^ ".cmxs" in + match Find.find_file cmxs with + | Some f -> f + | None -> + if List.contains m cmxs_to_load //if this module comes from the cmxs list, fail hard + then E.raise_error0 E.Fatal_FailToCompileNativeTactic (Util.format1 "Could not find %s to load" cmxs) + else //else try to find and compile the ml file + match Find.find_file (ml_file m) with + | None -> + E.raise_error0 E.Fatal_FailToCompileNativeTactic + (Util.format1 "Failed to compile native tactic; extracted module %s not found" (ml_file m)) + | Some ml -> + let dir = Util.dirname ml in + Plugins.compile_modules dir [ml_module_name m]; + begin match Find.find_file cmxs with + | None -> + E.raise_error0 E.Fatal_FailToCompileNativeTactic + (Util.format1 "Failed to compile native tactic; compiled object %s not found" cmxs) + | Some f -> f + end + in + let cmxs_files = (modules_to_load@cmxs_to_load) |> List.map cmxs_file in + if Debug.any () then + Util.print1 "Will try to load cmxs files: [%s]\n" (String.concat ", " cmxs_files); + Plugins.load_plugins cmxs_files; + iter_opt (Options.use_native_tactics ()) + Plugins.load_plugins_dir; + () + + +(* Need to keep names of input files for a second pass when prettyprinting *) +(* This reference is set once in `go` and read in `main` if the print or *) +(* print_in_place options are passed *) +let fstar_files: ref (option (list string)) = Util.mk_ref None + +(****************************************************************************) +(* Main function *) +(****************************************************************************) +let go _ = + let res, filenames = process_args () in + if Options.trace_error () then begin + let h = get_sigint_handler () in + let h' s = + let open FStarC.Pprint in + let open FStarC.Errors.Msg in + Debug.enable (); (* make sure diag is printed *) + Options.set_option "error_contexts" (Options.Bool true); + (* ^ Print context. Stack trace will be added since we have trace_error. *) + Errors.diag Range.dummyRange [ + text "GOT SIGINT! Exiting"; + ]; + exit 1 + in + set_sigint_handler (sigint_handler_f h') + end; + match res with + | Empty -> + Options.display_usage(); exit 1 + + | Help -> + Options.display_usage(); exit 0 + + | Error msg -> + Util.print_error msg; exit 1 + + | _ when Options.print_cache_version () -> + Util.print1 "F* cache version number: %s\n" + (string_of_int FStarC.CheckedFiles.cache_version_number); + exit 0 + + | Success -> + fstar_files := Some filenames; + + if Debug.any () then ( + Util.print1 "- F* executable: %s\n" (Util.exec_name); + Util.print1 "- F* exec dir: %s\n" (Options.fstar_bin_directory); + Util.print1 "- Library root: %s\n" ((Util.dflt "" (Options.lib_root ()))); + Util.print1 "- Full include path: %s\n" (show (Options.include_path ())); + Util.print_string "\n"; + () + ); + + load_native_tactics (); + + (* Set the unionfind graph to read-only mode. + * This will be unset by the typechecker and other pieces + * of code that intend to use it. It helps us catch errors. *) + (* TODO: also needed by the interactive mode below. *) + UF.set_ro (); + + (* --dep: Just compute and print the transitive dependency graph; + don't verify anything *) + if Options.dep() <> None + then let _, deps = Parser.Dep.collect filenames FStarC.CheckedFiles.load_parsing_data_from_cache in + Parser.Dep.print deps; + report_errors [] + + (* --print: Emit files in canonical source syntax *) + else if Options.print () || Options.print_in_place () then + if FStarC.Platform.is_fstar_compiler_using_ocaml + then let printing_mode = + if Options.print () + then FStarC.Prettyprint.FromTempToStdout + else FStarC.Prettyprint.FromTempToFile + in + FStarC.Prettyprint.generate printing_mode filenames + else failwith "You seem to be using the F#-generated version ofthe compiler ; \o + reindenting is not known to work yet with this version" + + (* --read_checked: read and print a checked file *) + else if Some? (Options.read_checked_file ()) then + let path = Some?.v <| Options.read_checked_file () in + let env = Universal.init_env Parser.Dep.empty_deps in + let res = FStarC.CheckedFiles.load_tc_result path in + match res with + | None -> + let open FStarC.Pprint in + Errors.raise_error0 Errors.Fatal_ModuleOrFileNotFound [ + Errors.Msg.text "Could not read checked file:" ^/^ doc_of_string path + ] + + | Some (_, tcr) -> + print1 "%s\n" (show tcr.checked_module) + + else if Options.list_plugins () then + let ps = FStarC.TypeChecker.Cfg.list_plugins () in + let ts = FStarC.Tactics.Interpreter.native_tactics_steps () in + Util.print1 "Registered plugins:\n%s\n" (String.concat "\n" (List.map (fun p -> " " ^ show p.FStarC.TypeChecker.Primops.Base.name) ps)); + Util.print1 "Registered tactic plugins:\n%s\n" (String.concat "\n" (List.map (fun p -> " " ^ show p.FStarC.TypeChecker.Primops.Base.name) ts)); + () + + else if Options.locate () then ( + Util.print1 "%s\n" (Util.get_exec_dir () |> Util.normalize_file_path); + exit 0 + + ) else if Options.locate_lib () then ( + match Options.lib_root () with + | None -> + Util.print_error "No library found (is --no_default_includes set?)\n"; + exit 1 + | Some s -> + Util.print1 "%s\n" (Util.normalize_file_path s); + exit 0 + + ) else if Options.locate_ocaml () then ( + // This is correct right now, but probably should change. + Util.print1 "%s\n" (Util.get_exec_dir () ^ "/../lib" |> Util.normalize_file_path); + exit 0 + + ) else if Some? (Options.read_krml_file ()) then + let path = Some?.v <| Options.read_krml_file () in + match load_value_from_file path <: option FStarC.Extraction.Krml.binary_format with + | None -> + let open FStarC.Pprint in + Errors.raise_error0 Errors.Fatal_ModuleOrFileNotFound [ + Errors.Msg.text "Could not read krml file:" ^/^ doc_of_string path + ] + | Some (version, files) -> + print1 "Karamel format version: %s\n" (show version); + (* Just "show decls" would print it, we just format this a bit *) + files |> List.iter (fun (name, decls) -> + print1 "%s:\n" name; + decls |> List.iter (fun d -> print1 " %s\n" (show d)) + ) + + (* --lsp *) + else if Options.lsp_server () then + FStarC.Interactive.Lsp.start_server () + + (* For the following cases we might need native tactics, try to load *) + else begin + + (* --ide, --in: Interactive mode *) + if Options.interactive () then begin + UF.set_rw (); + match filenames with + | [] -> (* input validation: move to process args? *) + Errors.log_issue0 Errors.Error_MissingFileName + "--ide: Name of current file missing in command line invocation\n"; + exit 1 + | _ :: _ :: _ -> (* input validation: move to process args? *) + Errors.log_issue0 Errors.Error_TooManyFiles + "--ide: Too many files in command line invocation\n"; + exit 1 + | [filename] -> + if Options.legacy_interactive () then + FStarC.Interactive.Legacy.interactive_mode filename + else + FStarC.Interactive.Ide.interactive_mode filename + end + + (* Normal, batch mode compiler *) + else if List.length filenames >= 1 then begin //normal batch mode + let filenames, dep_graph = FStarC.Dependencies.find_deps_if_needed filenames FStarC.CheckedFiles.load_parsing_data_from_cache in + let tcrs, env, cleanup = Universal.batch_mode_tc filenames dep_graph in + ignore (cleanup env); + let module_names = + tcrs + |> List.map (fun tcr -> + Universal.module_or_interface_name tcr.checked_module) + in + report_errors module_names; + finished_message module_names 0 + end //end batch mode + + else + Errors.raise_error0 Errors.Error_MissingFileName "No file provided" + end + +(* This is pretty awful. Now that we have Lazy_embedding, we can get rid of this table. *) +let lazy_chooser (k:Syntax.Syntax.lazy_kind) (i:Syntax.Syntax.lazyinfo) : Syntax.Syntax.term + = match k with + (* TODO: explain *) + | FStarC.Syntax.Syntax.BadLazy -> failwith "lazy chooser: got a BadLazy" + | FStarC.Syntax.Syntax.Lazy_bv -> RE.unfold_lazy_bv i + | FStarC.Syntax.Syntax.Lazy_namedv -> RE.unfold_lazy_namedv i + | FStarC.Syntax.Syntax.Lazy_binder -> RE.unfold_lazy_binder i + | FStarC.Syntax.Syntax.Lazy_letbinding -> RE.unfold_lazy_letbinding i + | FStarC.Syntax.Syntax.Lazy_optionstate -> RE.unfold_lazy_optionstate i + | FStarC.Syntax.Syntax.Lazy_fvar -> RE.unfold_lazy_fvar i + | FStarC.Syntax.Syntax.Lazy_comp -> RE.unfold_lazy_comp i + | FStarC.Syntax.Syntax.Lazy_env -> RE.unfold_lazy_env i + | FStarC.Syntax.Syntax.Lazy_sigelt -> RE.unfold_lazy_sigelt i + | FStarC.Syntax.Syntax.Lazy_universe -> RE.unfold_lazy_universe i + + | FStarC.Syntax.Syntax.Lazy_proofstate -> Tactics.Embedding.unfold_lazy_proofstate i + | FStarC.Syntax.Syntax.Lazy_goal -> Tactics.Embedding.unfold_lazy_goal i + + | FStarC.Syntax.Syntax.Lazy_doc -> RE.unfold_lazy_doc i + + | FStarC.Syntax.Syntax.Lazy_uvar -> FStarC.Syntax.Util.exp_string "((uvar))" + | FStarC.Syntax.Syntax.Lazy_universe_uvar -> FStarC.Syntax.Util.exp_string "((universe_uvar))" + | FStarC.Syntax.Syntax.Lazy_issue -> FStarC.Syntax.Util.exp_string "((issue))" + | FStarC.Syntax.Syntax.Lazy_ident -> FStarC.Syntax.Util.exp_string "((ident))" + | FStarC.Syntax.Syntax.Lazy_tref -> FStarC.Syntax.Util.exp_string "((tref))" + + | FStarC.Syntax.Syntax.Lazy_embedding (_, t) -> Thunk.force t + | FStarC.Syntax.Syntax.Lazy_extension s -> FStarC.Syntax.Util.exp_string (format1 "((extension %s))" s) + +// This is called directly by the Javascript port (it doesn't call Main) +let setup_hooks () = + FStarC.Syntax.DsEnv.ugly_sigelt_to_string_hook := show; + FStarC.Errors.set_parse_warn_error FStarC.Parser.ParseIt.parse_warn_error; + FStarC.Syntax.Syntax.lazy_chooser := Some lazy_chooser; + FStarC.Syntax.Util.tts_f := Some show; + FStarC.Syntax.Util.ttd_f := Some Class.PP.pp; + FStarC.TypeChecker.Normalize.unembed_binder_knot := Some RE.e_binder; + List.iter Tactics.Interpreter.register_tactic_primitive_step Tactics.V1.Primops.ops; + List.iter Tactics.Interpreter.register_tactic_primitive_step Tactics.V2.Primops.ops; + () + +let handle_error e = + if FStarC.Errors.handleable e then + FStarC.Errors.err_exn e; + if Options.trace_error() then + Util.print2_error "Unexpected error\n%s\n%s\n" (Util.message_of_exn e) (Util.trace_of_exn e) + else if not (FStarC.Errors.handleable e) then + Util.print1_error "Unexpected error; please file a bug report, ideally with a minimized version of the source program that triggered the error.\n%s\n" (Util.message_of_exn e); + cleanup(); + report_errors [] + +let main () = + try + setup_hooks (); + let _, time = Util.record_time go in + if FStarC.Options.query_stats() + then Util.print2_error "TOTAL TIME %s ms: %s\n" + (FStarC.Compiler.Util.string_of_int time) + (String.concat " " (FStarC.Getopt.cmdline())); + cleanup (); + exit 0 + with + | e -> handle_error e; + exit 1 diff --git a/src/fstar/FStarC.Prettyprint.fst b/src/fstar/FStarC.Prettyprint.fst new file mode 100644 index 00000000000..87031c0ad8d --- /dev/null +++ b/src/fstar/FStarC.Prettyprint.fst @@ -0,0 +1,72 @@ +(* + Copyright 2008-2018 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Prettyprint +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Compiler.Util +open FStarC.Parser.ToDocument +module List = FStarC.Compiler.List +module D = FStarC.Parser.Driver +module P = FStarC.Pprint + +type printing_mode = + | ToTempFile + | FromTempToStdout + | FromTempToFile + +let temp_file_name f = format1 "%s.print_.fst" f + +let generate (m: printing_mode) filenames = + let parse_and_prettyprint (m: printing_mode) filename = + let modul, comments = D.parse_file filename in + let outf = + match m with + | FromTempToStdout -> None + | FromTempToFile -> + let outf = open_file_for_writing filename in + Some outf + | ToTempFile -> + let outf = open_file_for_writing (temp_file_name filename) in + Some outf + in + let leftover_comments = + let comments = List.rev comments in + let doc, comments = modul_with_comments_to_document modul comments in + (* TODO : some problem with the F# generated floats *) + (match outf with + | Some f -> append_to_file f <| P.pretty_string (float_of_string "1.0") 100 doc + | None -> P.pretty_out_channel (float_of_string "1.0") 100 doc stdout); + comments + in + let left_over_doc = + if not (FStarC.Compiler.List.isEmpty leftover_comments) then + P.concat [P.hardline ; P.hardline ; comments_to_document leftover_comments] + else if m = FromTempToStdout then + // This isn't needed for FromTempToFile, when using `append_to_file` a newline is added to EoF + P.concat [P.hardline; P.hardline] + else + P.empty + in + match outf with + | None -> + P.pretty_out_channel (float_of_string "1.0") 100 left_over_doc stdout + + | Some outf -> + append_to_file outf <| P.pretty_string (float_of_string "1.0") 100 left_over_doc; + close_out_channel outf + in + List.iter (parse_and_prettyprint m) filenames diff --git a/src/fstar/FStarC.Universal.fst b/src/fstar/FStarC.Universal.fst new file mode 100644 index 00000000000..a05c3a5241c --- /dev/null +++ b/src/fstar/FStarC.Universal.fst @@ -0,0 +1,623 @@ +(* + Copyright 2008-2016 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +//Top-level invocations into the universal type-checker FStarC.TypeChecker +module FStarC.Universal +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.Errors +open FStarC.Compiler.Util +open FStarC.Getopt +open FStarC.Ident +open FStarC.Syntax.Syntax +open FStarC.TypeChecker.Common +open FStarC.Dependencies +open FStarC.Extraction.ML.UEnv +open FStarC.TypeChecker.Env +open FStarC.Syntax.DsEnv +open FStarC.TypeChecker +open FStarC.CheckedFiles + +open FStarC.Class.Show + +(* Module abbreviations for the universal type-checker *) +module DsEnv = FStarC.Syntax.DsEnv +module TcEnv = FStarC.TypeChecker.Env +module Syntax = FStarC.Syntax.Syntax +module Util = FStarC.Syntax.Util +module Desugar = FStarC.ToSyntax.ToSyntax +module SMT = FStarC.SMTEncoding.Solver +module Const = FStarC.Parser.Const +module Pars = FStarC.Parser.ParseIt +module Tc = FStarC.TypeChecker.Tc +module TcTerm = FStarC.TypeChecker.TcTerm +module BU = FStarC.Compiler.Util +module Dep = FStarC.Parser.Dep +module NBE = FStarC.TypeChecker.NBE +module Ch = FStarC.CheckedFiles +module MLSyntax = FStarC.Extraction.ML.Syntax + +let module_or_interface_name m = m.is_interface, m.name + +let with_dsenv_of_tcenv (tcenv:TcEnv.env) (f:DsEnv.withenv 'a) : 'a & TcEnv.env = + let a, dsenv = f tcenv.dsenv in + a, ({tcenv with dsenv = dsenv}) + +let with_tcenv_of_env (e:uenv) (f:TcEnv.env -> 'a & TcEnv.env) : 'a & uenv = + let a, t' = f (tcenv_of_uenv e) in + a, (set_tcenv e t') + +let with_dsenv_of_env (e:uenv) (f:DsEnv.withenv 'a) : 'a & uenv = + let a, tcenv = with_dsenv_of_tcenv (tcenv_of_uenv e) f in + a, (set_tcenv e tcenv) + +let push_env (env:uenv) = + snd (with_tcenv_of_env env (fun tcenv -> + (), FStarC.TypeChecker.Env.push (tcenv_of_uenv env) "top-level: push_env")) + +let pop_env (env:uenv) = + snd (with_tcenv_of_env env (fun tcenv -> + (), FStarC.TypeChecker.Env.pop tcenv "top-level: pop_env")) + +let with_env env (f:uenv -> 'a) : 'a = + let env = push_env env in + let res = f env in + let _ = pop_env env in + res + +let env_of_tcenv (env:TcEnv.env) = + FStarC.Extraction.ML.UEnv.new_uenv env + +(***********************************************************************) +(* Parse and desugar a file *) +(***********************************************************************) +let parse (env:uenv) (pre_fn: option string) (fn:string) + : Syntax.modul + & uenv = + let ast, _ = Parser.Driver.parse_file fn in + let ast, env = match pre_fn with + | None -> + ast, env + | Some pre_fn -> + let pre_ast, _ = Parser.Driver.parse_file pre_fn in + match pre_ast, ast with + | Parser.AST.Interface (lid1, decls1, _), Parser.AST.Module (lid2, decls2) + when Ident.lid_equals lid1 lid2 -> + let _, env = + with_dsenv_of_env env (FStarC.ToSyntax.Interleave.initialize_interface lid1 decls1) + in + with_dsenv_of_env env (FStarC.ToSyntax.Interleave.interleave_module ast true) + + | Parser.AST.Interface (lid1, _, _), Parser.AST.Module (lid2, _) -> + (* Names do not match *) + Errors.raise_error lid1 + Errors.Fatal_PreModuleMismatch + "Module name in implementation does not match that of interface." + + | _ -> + Errors.raise_error0 + Errors.Fatal_PreModuleMismatch + "Module name in implementation does not match that of interface." + in + with_dsenv_of_env env (Desugar.ast_modul_to_modul ast) + +(***********************************************************************) +(* Initialize a clean environment *) +(***********************************************************************) +let core_check : TcEnv.core_check_t = + fun env tm t must_tot -> + let open FStarC.TypeChecker.Core in + if not (Options.compat_pre_core_should_check ()) + then Inl None + else match check_term env tm t must_tot with + | Inl None -> Inl None + | Inl (Some g) -> + if Options.compat_pre_core_set () + then Inl None + else Inl (Some g) + | Inr err -> + Inr (fun b -> if b then print_error_short err else print_error err) + +let init_env deps : TcEnv.env = + let solver = + if Options.lax() + then SMT.dummy + else {SMT.solver with + preprocess=FStarC.Tactics.Hooks.preprocess; + spinoff_strictly_positive_goals=Some FStarC.Tactics.Hooks.spinoff_strictly_positive_goals; + handle_smt_goal=FStarC.Tactics.Hooks.handle_smt_goal + } in + let env = + TcEnv.initial_env + deps + TcTerm.tc_term + TcTerm.typeof_tot_or_gtot_term + TcTerm.typeof_tot_or_gtot_term_fastpath + TcTerm.universe_of + Rel.teq_nosmt_force + Rel.subtype_nosmt_force + solver + Const.prims_lid + (NBE.normalize + (FStarC.Tactics.Interpreter.primitive_steps ())) + core_check + in + (* Set up some tactics callbacks *) + let env = { env with synth_hook = FStarC.Tactics.Hooks.synthesize } in + let env = { env with try_solve_implicits_hook = FStarC.Tactics.Hooks.solve_implicits } in + let env = { env with splice = FStarC.Tactics.Hooks.splice} in + let env = { env with mpreprocess = FStarC.Tactics.Hooks.mpreprocess} in + let env = { env with postprocess = FStarC.Tactics.Hooks.postprocess} in + env.solver.init env; + env + +(***********************************************************************) +(* Interactive mode: checking a fragment of a code *) +(***********************************************************************) +let tc_one_fragment curmod (env:TcEnv.env_t) frag = + let open FStarC.Parser.AST in + // We use file_of_range instead of `Options.file_list ()` because no file + // is passed as a command-line argument in LSP mode. + let fname env = if Options.lsp_server () then Range.file_of_range (TcEnv.get_range env) + else List.hd (Options.file_list ()) in + let acceptable_mod_name modul = + (* Interface is sent as the first chunk, so we must allow repeating the same module. *) + Parser.Dep.lowercase_module_name (fname env) = + String.lowercase (string_of_lid modul.name) in + + let range_of_first_mod_decl modul = + match modul with + | Parser.AST.Module (_, { Parser.AST.drange = d } :: _) + | Parser.AST.Interface (_, { Parser.AST.drange = d } :: _, _) -> d + | _ -> Range.dummyRange in + + let filter_lang_decls (d:FStarC.Parser.AST.decl) = + match d.d with + | UseLangDecls _ -> true + | _ -> false + in + let use_lang_decl (ds:lang_decls_t) = + List.tryFind (fun d -> UseLangDecls? d.d) ds + in + let check_module_name_declaration ast_modul = + (* It may seem surprising that this function, whose name indicates that + it type-checks a fragment, can actually parse an entire module. + Actually, this is an abuse, and just means that we're type-checking the + first chunk. *) + let ast_modul, env = + with_dsenv_of_tcenv env <| FStarC.ToSyntax.Interleave.interleave_module ast_modul false in + let modul, env = + with_dsenv_of_tcenv env <| Desugar.partial_ast_modul_to_modul curmod ast_modul in + if not (acceptable_mod_name modul) then + begin + let msg : string = + BU.format1 "Interactive mode only supports a single module at the top-level. Expected module %s" + (Parser.Dep.module_name_of_file (fname env)) + in + Errors.raise_error (range_of_first_mod_decl ast_modul) Errors.Fatal_NonSingletonTopLevelModule msg + end; + let modul, env = + if DsEnv.syntax_only env.dsenv then modul, env + else Tc.tc_partial_modul env modul + in + let lang_decls = + let open FStarC.Parser.AST in + let decls = + match ast_modul with + | Module (_, decls) + | Interface (_, decls, _) -> decls + in + List.filter filter_lang_decls decls + in + Some modul, env, lang_decls + in + + let check_decls ast_decls = + match curmod with + | None -> + let { Parser.AST.drange = rng } = List.hd ast_decls in + Errors.raise_error rng Errors.Fatal_ModuleFirstStatement "First statement must be a module declaration" + | Some modul -> + let env, ast_decls_l = + BU.fold_map + (fun env a_decl -> + let decls, env = + with_dsenv_of_tcenv env <| + FStarC.ToSyntax.Interleave.prefix_with_interface_decls modul.name a_decl + in + env, decls) + env + ast_decls in + let sigelts, env = with_dsenv_of_tcenv env <| Desugar.decls_to_sigelts (List.flatten ast_decls_l) in + let modul, _, env = if DsEnv.syntax_only env.dsenv then (modul, [], env) + else Tc.tc_more_partial_modul env modul sigelts in + Some modul, env, List.filter filter_lang_decls ast_decls + in + match frag with + | Inr d -> ( + //We already have a parsed decl, usually from FStarC.Interactive.Incremental + match d.d with + | FStarC.Parser.AST.TopLevelModule lid -> + check_module_name_declaration (FStarC.Parser.AST.Module(lid, [d])) + | _ -> + check_decls [d] + ) + + | Inl (frag, lang_decls) -> ( + let parse_frag frag = + match use_lang_decl lang_decls with + | None -> Parser.Driver.parse_fragment None frag + | Some {d=UseLangDecls lang} -> + Parser.Driver.parse_fragment (Some lang) frag + in + match parse_frag frag with + | Parser.Driver.Empty + | Parser.Driver.Decls [] -> + curmod, env, [] + + | Parser.Driver.Modul ast_modul -> + check_module_name_declaration ast_modul + + | Parser.Driver.Decls ast_decls -> + check_decls ast_decls + ) + +let load_interface_decls env interface_file_name : TcEnv.env_t = + let r = Pars.parse None (Pars.Filename interface_file_name) in + match r with + | Pars.ASTFragment (Inl (FStarC.Parser.AST.Interface(l, decls, _)), _) -> + snd (with_dsenv_of_tcenv env <| FStarC.ToSyntax.Interleave.initialize_interface l decls) + | Pars.ASTFragment _ -> + Errors.raise_error0 FStarC.Errors.Fatal_ParseErrors + (BU.format1 "Unexpected result from parsing %s; expected a single interface" interface_file_name) + | Pars.ParseError (err, msg, rng) -> + raise (FStarC.Errors.Error(err, msg, rng, [])) + | Pars.Term _ -> + failwith "Impossible: parsing a Toplevel always results in an ASTFragment" + + +(***********************************************************************) +(* Batch mode: checking a file *) +(***********************************************************************) + +(* Extraction to OCaml, F# or Krml *) +let emit dep_graph (mllibs:list (uenv & MLSyntax.mllib)) = + let opt = Options.codegen () in + let fail #a () : a = failwith ("Unrecognized extraction backend: " ^ show opt) in + if opt <> None then + let ext = match opt with + | Some Options.FSharp -> ".fs" + | Some Options.OCaml + | Some Options.Plugin -> ".ml" + | Some Options.Krml -> ".krml" + | Some Options.Extension -> ".ast" + | _ -> fail () + in + match opt with + | Some Options.FSharp | Some Options.OCaml | Some Options.Plugin -> + (* When bootstrapped in F#, this will use the old printer in + FStarC.Extraction.ML.Code for both OCaml and F# extraction. + When bootstarpped in OCaml, this will use the old printer + for F# extraction and the new printer for OCaml extraction. *) + let outdir = Options.output_dir() in + List.iter (FStarC.Extraction.ML.PrintML.print outdir ext) (List.map snd mllibs) + + | Some Options.Extension -> + // + // In the Extension mode, we dump (list mname & bindings_of_uenv & ml decls) + // in the binary format to a file + // The first component is the list of dependencies + // + List.iter (fun (env, m) -> + let MLSyntax.MLLib ms = m in + List.iter (fun m -> + let mname, modul, _ = m in + let filename = String.concat "_" (fst mname @ [snd mname]) in + match modul with + | Some (_, decls) -> + let bindings = FStarC.Extraction.ML.UEnv.bindings_of_uenv env in + let deps : list string = Dep.deps_of_modul dep_graph (MLSyntax.string_of_mlpath mname) in + save_value_to_file (Options.prepend_output_dir (filename^ext)) (deps, bindings, decls) + | None -> + failwith "Unexpected ml modul in Extension extraction mode" + ) ms + ) mllibs + + | Some Options.Krml -> + let programs = + mllibs |> List.collect (fun (ue, mllibs) -> + Extraction.Krml.translate ue mllibs) + in + let bin: Extraction.Krml.binary_format = Extraction.Krml.current_version, programs in + let oname : string = + match Options.krmloutput () with + | Some fname -> fname (* NB: no prepending odir nor adding extension, user chose a explicit path *) + | _ -> + match programs with + | [ name, _ ] -> name ^ ext |> Options.prepend_output_dir + | _ -> "out" ^ ext |> Options.prepend_output_dir + in + save_value_to_file oname bin + + | _ -> fail () + +let tc_one_file + (env:uenv) + (pre_fn:option string) //interface file name + (fn:string) //file name + (parsing_data:FStarC.Parser.Dep.parsing_data) //passed by the caller, ONLY for caching purposes at this point + : tc_result + & option MLSyntax.mllib + & uenv = + GenSym.reset_gensym(); + + (* + * AR: smt encode_modul functions are now here instead of in Tc.fs + * this is common smt postprocessing for fresh module and module read from cache + *) + let maybe_restore_opts () : unit = + if not (Options.interactive ()) then + Options.restore_cmd_line_options true |> ignore + in + let maybe_extract_mldefs tcmod env = + match Options.codegen() with + | None -> None, 0 + | Some tgt -> + if not (Options.should_extract (string_of_lid tcmod.name) tgt) + then None, 0 + else FStarC.Compiler.Util.record_time (fun () -> + with_env env (fun env -> + let _, defs = FStarC.Extraction.ML.Modul.extract env tcmod in + defs) + ) + in + let maybe_extract_ml_iface tcmod env = + if Options.codegen() = None + then env, 0 + else + FStarC.Compiler.Util.record_time (fun () -> + let env, _ = with_env env (fun env -> + FStarC.Extraction.ML.Modul.extract_iface env tcmod) in + env + ) + in + let tc_source_file () = + let fmod, env = parse env pre_fn fn in + let mii = FStarC.Syntax.DsEnv.inclusion_info (tcenv_of_uenv env).dsenv fmod.name in + let check_mod () = + let check env = + if not (Options.lax()) then FStarC.SMTEncoding.Z3.refresh None; + with_tcenv_of_env env (fun tcenv -> + let _ = match tcenv.gamma with + | [] -> () + | _ -> failwith "Impossible: gamma contains leaked names" + in + let modul, env = Tc.check_module tcenv fmod (is_some pre_fn) in + //AR: encode the module to to smt + maybe_restore_opts (); + let smt_decls = + if not (Options.lax()) + then FStarC.SMTEncoding.Encode.encode_modul env modul + else [], [] + in + ((modul, smt_decls), env)) + in + + let ((tcmod, smt_decls), env) = + Profiling.profile (fun () -> check env) + (Some (string_of_lid fmod.name)) + "FStarC.Universal.tc_source_file" + in + + let tc_time = 0 in + let extracted_defs, extract_time = maybe_extract_mldefs tcmod env in + let env, iface_extraction_time = maybe_extract_ml_iface tcmod env in + { + checked_module=tcmod; + tc_time=tc_time; + smt_decls=smt_decls; + + extraction_time = extract_time + iface_extraction_time; + mii = mii + }, + extracted_defs, + env + in + if (Options.should_verify (string_of_lid fmod.name) //if we're verifying this module + && (FStarC.Options.record_hints() //and if we're recording or using hints + || FStarC.Options.use_hints())) + then SMT.with_hints_db (Pars.find_file fn) check_mod + else check_mod () //don't add a hints file for modules that are not actually verified + in + if not (Options.cache_off()) then + let r = Ch.load_module_from_cache (tcenv_of_uenv env) fn in + let r = + (* If --force and this file was given in the command line, + * forget about the cache we just loaded and recheck the file. + * Note: we do the call above anyway since load_module_from_cache + * sets some internal state about dependencies. *) + if Options.force () && Options.should_check_file fn + then None + else r + in + match r with + | None -> + if Options.should_be_already_cached (FStarC.Parser.Dep.module_name_of_file fn) + && not (Options.force ()) + then FStarC.Errors.raise_error0 FStarC.Errors.Error_AlreadyCachedAssertionFailure [ + text <| BU.format1 "Expected %s to already be checked." fn + ]; + + if (Option.isSome (Options.codegen()) + && Options.cmi()) + && not (Options.force ()) + then FStarC.Errors.raise_error0 FStarC.Errors.Error_AlreadyCachedAssertionFailure [ + text "Cross-module inlining expects all modules to be checked first."; + text <| BU.format1 "Module %s was not checked." fn; + ]; + + let tc_result, mllib, env = tc_source_file () in + + if FStarC.Errors.get_err_count() = 0 + && (Options.lax() //we'll write out a .checked.lax file + || Options.should_verify (string_of_lid tc_result.checked_module.name)) //we'll write out a .checked file + //but we will not write out a .checked file for an unverified dependence + //of some file that should be checked + //(i.e. we DO write .checked.lax files for dependencies even if not provided as an argument) + then Ch.store_module_to_cache (tcenv_of_uenv env) fn parsing_data tc_result; + tc_result, mllib, env + + | Some tc_result -> + let tcmod = tc_result.checked_module in + let smt_decls = tc_result.smt_decls in + if Options.dump_module (string_of_lid tcmod.name) + then BU.print1 "Module after type checking:\n%s\n" (show tcmod); + + let extend_tcenv tcmod tcenv = + if not (Options.lax()) then FStarC.SMTEncoding.Z3.refresh None; + let _, tcenv = + with_dsenv_of_tcenv tcenv <| + FStarC.ToSyntax.ToSyntax.add_modul_to_env + tcmod + tc_result.mii + (FStarC.TypeChecker.Normalize.erase_universes tcenv) + in + let env = FStarC.TypeChecker.Tc.load_checked_module tcenv tcmod in + maybe_restore_opts (); + //AR: encode smt module and do post processing + if (not (Options.lax())) then begin + FStarC.SMTEncoding.Encode.encode_modul_from_cache env tcmod smt_decls + end; + (), env + in + + let env = + Profiling.profile + (fun () -> with_tcenv_of_env env (extend_tcenv tcmod) |> snd) + None + "FStarC.Universal.extend_tcenv" + in + + + (* If we have to extract this module, then do it first *) + let mllib = + match Options.codegen() with + | None -> None + | Some tgt -> + if Options.should_extract (string_of_lid tcmod.name) tgt + && (not tcmod.is_interface || tgt=Options.Krml) + then let extracted_defs, _extraction_time = maybe_extract_mldefs tcmod env in + extracted_defs + else None + in + + let env, _time = maybe_extract_ml_iface tcmod env in + + tc_result, + mllib, + env + + else let tc_result, mllib, env = tc_source_file () in + tc_result, mllib, env + +let tc_one_file_for_ide + (env:TcEnv.env_t) + (pre_fn:option string) //interface file name + (fn:string) //file name + (parsing_data:FStarC.Parser.Dep.parsing_data) //threaded along, ONLY for caching purposes at this point + : tc_result + & TcEnv.env_t + = + let env = env_of_tcenv env in + let tc_result, _, env = tc_one_file env pre_fn fn parsing_data in + tc_result, (tcenv_of_uenv env) + +(***********************************************************************) +(* Batch mode: composing many files in the presence of pre-modules *) +(***********************************************************************) +let needs_interleaving intf impl = + let m1 = Parser.Dep.lowercase_module_name intf in + let m2 = Parser.Dep.lowercase_module_name impl in + m1 = m2 && + List.mem (FStarC.Compiler.Util.get_file_extension intf) ["fsti"; "fsi"] && + List.mem (FStarC.Compiler.Util.get_file_extension impl) ["fst"; "fs"] + +let tc_one_file_from_remaining (remaining:list string) (env:uenv) + (deps:FStarC.Parser.Dep.deps) //used to query parsing data + : list string & tc_result & option MLSyntax.mllib & uenv + = + let remaining, (nmods, mllib, env) = + match remaining with + | intf :: impl :: remaining when needs_interleaving intf impl -> + let m, mllib, env = tc_one_file env (Some intf) impl + (impl |> FStarC.Parser.Dep.parsing_data_of deps) in + remaining, (m, mllib, env) + | intf_or_impl :: remaining -> + let m, mllib, env = tc_one_file env None intf_or_impl + (intf_or_impl |> FStarC.Parser.Dep.parsing_data_of deps) in + remaining, (m, mllib, env) + | [] -> failwith "Impossible: Empty remaining modules" + in + remaining, nmods, mllib, env + +let rec tc_fold_interleave (deps:FStarC.Parser.Dep.deps) //used to query parsing data + (acc:list tc_result & + list (uenv & MLSyntax.mllib) & // initial env in which this module is extracted + uenv) + (remaining:list string) = + let as_list env mllib = + match mllib with + | None -> [] + | Some mllib -> [env, mllib] in + + match remaining with + | [] -> acc + | _ -> + let mods, mllibs, env_before = acc in + let remaining, nmod, mllib, env = tc_one_file_from_remaining remaining env_before deps in + if not (Options.profile_group_by_decl()) + then Profiling.report_and_clear (Ident.string_of_lid nmod.checked_module.name); + tc_fold_interleave deps (mods@[nmod], mllibs@(as_list env mllib), env) remaining + +(***********************************************************************) +(* Batch mode: checking many files *) +(***********************************************************************) +let dbg_dep = Debug.get_toggle "Dep" +let batch_mode_tc filenames dep_graph = + if !dbg_dep then begin + FStarC.Compiler.Util.print_endline "Auto-deps kicked in; here's some info."; + FStarC.Compiler.Util.print1 "Here's the list of filenames we will process: %s\n" + (String.concat " " filenames); + FStarC.Compiler.Util.print1 "Here's the list of modules we will verify: %s\n" + (String.concat " " (filenames |> List.filter Options.should_verify_file)) + end; + let env = FStarC.Extraction.ML.UEnv.new_uenv (init_env dep_graph) in + let all_mods, mllibs, env = tc_fold_interleave dep_graph ([], [], env) filenames in + if FStarC.Errors.get_err_count() = 0 then + emit dep_graph mllibs; + let solver_refresh env = + snd <| + with_tcenv_of_env env (fun tcenv -> + if Options.interactive() + && FStarC.Errors.get_err_count () = 0 + then tcenv.solver.refresh None + else tcenv.solver.finish(); + (), tcenv) + in + all_mods, env, solver_refresh diff --git a/src/fstar/FStarC.Universal.fsti b/src/fstar/FStarC.Universal.fsti new file mode 100644 index 00000000000..01eee7432ea --- /dev/null +++ b/src/fstar/FStarC.Universal.fsti @@ -0,0 +1,87 @@ +(* + Copyright 2008-2016 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +//Top-level invocations into the universal type-checker FStarC.TypeChecker +module FStarC.Universal + +open FStar open FStarC.Compiler +open FStarC.Ident +open FStarC.CheckedFiles +module DsEnv = FStarC.Syntax.DsEnv +module TcEnv = FStarC.TypeChecker.Env +module Syntax = FStarC.Syntax.Syntax +module Dep = FStarC.Parser.Dep +module ParseIt = FStarC.Parser.ParseIt + +type uenv = FStarC.Extraction.ML.UEnv.uenv + +(* Takes a module an returns whether it is an interface or not, +and an lid for its name. *) +val module_or_interface_name : Syntax.modul -> bool & lid + +(* Uses the dsenv inside the TcEnv.env to run the computation. *) +val with_dsenv_of_tcenv : TcEnv.env -> DsEnv.withenv 'a -> 'a & TcEnv.env + +(* Initialize a clean environment, built from a dependency graph. The +graph is used to populate the internal dsenv of the tcenv. *) +val init_env : Dep.deps -> TcEnv.env + +val core_check: TcEnv.core_check_t + +type lang_decls_t = list FStarC.Parser.AST.decl + +(* Interactive mode: checking a fragment of code. *) +val tc_one_fragment : + option Syntax.modul -> + TcEnv.env_t -> + either (FStarC.Parser.ParseIt.input_frag & lang_decls_t) FStarC.Parser.AST.decl -> + option Syntax.modul & TcEnv.env & lang_decls_t + +(* Load an interface file into the dsenv. *) +val load_interface_decls : + TcEnv.env -> + string -> + TcEnv.env_t + +(* Batch mode: check one file. *) +val tc_one_file : + uenv -> + option string -> + string -> + FStarC.Parser.Dep.parsing_data -> + tc_result & option FStarC.Extraction.ML.Syntax.mllib & uenv + +(* A thin wrapper for tc_one_file, called by the interactive mode. +Basically discards any information about extraction. *) +val tc_one_file_for_ide : + TcEnv.env_t -> + option string -> + string -> + FStarC.Parser.Dep.parsing_data -> + tc_result & TcEnv.env_t + +(* [needs_interleaving s1 s2] is when s1 and s2 are (resp.) the filenames +for the interface and implementation of a (single) module. *) +val needs_interleaving : + string -> + string -> + bool + +(* Batch mode: check multiple files. *) +val batch_mode_tc : + list string -> + FStarC.Parser.Dep.deps -> + list tc_result & uenv & (uenv -> uenv) diff --git a/src/ocaml-output/.ignore b/src/ocaml-output/.ignore deleted file mode 100644 index 24600083db4..00000000000 --- a/src/ocaml-output/.ignore +++ /dev/null @@ -1 +0,0 @@ -!Makefile diff --git a/src/parser/FStar.Parser.AST.Util.fst b/src/parser/FStar.Parser.AST.Util.fst deleted file mode 100644 index af8d62e2b4d..00000000000 --- a/src/parser/FStar.Parser.AST.Util.fst +++ /dev/null @@ -1,794 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. - - Authors: N. Swamy and Copilot -*) -module FStar.Parser.AST.Util -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Errors -module C = FStar.Parser.Const -open FStar.Compiler.Range -open FStar.Ident -open FStar -open FStar.Compiler -open FStar.Compiler.Util -open FStar.Const -open FStar.Parser.AST - -let eq_ident (i1 i2:ident) = - Ident.ident_equals i1 i2 - -let eq_list (f: 'a -> 'a -> bool) (t1 t2:list 'a) - : bool - = List.length t1 = List.length t2 && - List.forall2 f t1 t2 - -let eq_option (f: 'a -> 'a -> bool) (t1 t2:option 'a) - : bool - = match t1, t2 with - | None, None -> true - | Some t1, Some t2 -> f t1 t2 - | _ -> false - - -// -// TODO: There is an eq_const in FStar.Const.fst, can we use that? -// -let eq_sconst (c1 c2: sconst) : bool = - match c1, c2 with - | Const_effect, Const_effect -> true - | Const_unit, Const_unit -> true - | Const_bool b1, Const_bool b2 -> b1 = b2 - | Const_int (s1, sw1), Const_int (s2, sw2) -> s1=s2 && sw1=sw2 - | Const_char c1, Const_char c2 -> c1 = c2 - | Const_string (s1, _), Const_string (s2, _) -> s1 = s2 - | Const_real s1, Const_real s2 -> s1 = s2 - | Const_range r1, Const_range r2 -> r1 = r2 - | Const_reify _, Const_reify _ -> true - | Const_reflect l1, Const_reflect l2 -> Ident.lid_equals l1 l2 - | _ -> false - -let rec eq_term (t1 t2:term) - : bool - = eq_term' t1.tm t2.tm - -and eq_terms (t1 t2:list term) - : bool - = eq_list eq_term t1 t2 - -and eq_arg (t1 t2 : (term & imp)) - = let t1, a1 = t1 in - let t2, a2 = t2 in - eq_term t1 t2 && - eq_imp a1 a2 - -and eq_imp (i1 i2: imp) - = match i1, i2 with - | FsTypApp, FsTypApp - | Hash, Hash - | UnivApp, UnivApp - | Infix, Infix - | Nothing, Nothing -> true - | HashBrace t1, HashBrace t2 -> - eq_term t1 t2 - | _ -> false - -and eq_args (t1 t2: list (term & imp)) - : bool - = eq_list eq_arg t1 t2 - -and eq_arg_qualifier (arg_qualifier1:arg_qualifier) (arg_qualifier2:arg_qualifier) : bool = - match arg_qualifier1, arg_qualifier2 with - | Implicit, Implicit -> true - | Equality, Equality -> true - | Meta t1, Meta t2 -> eq_term t1 t2 - | TypeClassArg, TypeClassArg -> true - | _ -> false - -and eq_pattern (p1 p2:pattern) - : bool - = eq_pattern' p1.pat p2.pat - -and eq_aqual a1 a2 = eq_option eq_arg_qualifier a1 a2 - -and eq_pattern' (p1 p2:pattern') - : bool - = match p1, p2 with - | PatWild(q1, a1), PatWild(q2, a2) -> - eq_aqual q1 q2 && - eq_terms a1 a2 - | PatConst s1, PatConst s2 -> - eq_sconst s1 s2 - | PatApp (p1, ps1), PatApp(p2, ps2) -> - eq_pattern p1 p2 && - eq_list eq_pattern ps1 ps2 - | PatTvar (i1, aq1, as1), PatTvar(i2, aq2, as2) - | PatVar (i1, aq1, as1), PatVar(i2, aq2, as2) -> - Ident.ident_equals i1 i2 && - eq_aqual aq1 aq2 && - eq_terms as1 as2 - | PatName l1, PatName l2 -> - Ident.lid_equals l1 l2 - | PatOr ps1, PatOr ps2 - | PatList ps1, PatList ps2 -> - eq_list eq_pattern ps1 ps2 - | PatTuple(ps1, b1), PatTuple(ps2, b2) -> - eq_list eq_pattern ps1 ps2 && - b1 = b2 - | PatRecord ps1, PatRecord ps2 -> - eq_list (fun (l1, p1) (l2, p2) -> - Ident.lid_equals l1 l2 && - eq_pattern p1 p2) - ps1 ps2 - | PatAscribed (p1, (t1, topt1)), PatAscribed (p2, (t2, topt2)) -> - eq_pattern p1 p2 && - eq_term t1 t2 && - eq_option eq_term topt1 topt2 - | PatOp i1, PatOp i2 -> - eq_ident i1 i2 - | PatVQuote t1, PatVQuote t2 -> - eq_term t1 t2 - | _ -> false - -and eq_term' (t1 t2:term') - : bool - = match t1, t2 with - | Wild, Wild -> true - | Const s1, Const s2 -> eq_const s1 s2 - | Op (i1, ts1), Op (i2, ts2) -> - eq_ident i1 i2 && - eq_terms ts1 ts2 - | Tvar i1, Tvar i2 - | Uvar i1, Uvar i2 -> - eq_ident i1 i2 - | Var l1, Var l2 - | Name l1, Name l2 -> - Ident.lid_equals l1 l2 - | Projector (l1, i1), Projector (l2, i2) -> - Ident.lid_equals l1 l2 && - Ident.ident_equals i1 i2 - | Construct (l1, args1), Construct (l2, args2) -> - Ident.lid_equals l1 l2 && - eq_args args1 args2 - | Function (brs1, _r1), Function (brs2, _r2) -> - eq_list eq_branch brs1 brs2 - | Abs (ps1, t1), Abs (ps2, t2) -> - eq_list eq_pattern ps1 ps2 && - eq_term t1 t2 - | App (h1, t1, i1), App(h2, t2, i2) -> - eq_term h1 h2 && - eq_term t1 t2 && - eq_imp i1 i2 - | Let (lq1, defs1, t1), Let (lq2, defs2, t2) -> - lq1=lq2 && - eq_list (fun (o1, (p1, t1)) (o2, (p2, t2)) -> - eq_option eq_terms o1 o2 && - eq_pattern p1 p2 && - eq_term t1 t2) - defs1 defs2 && - eq_term t1 t2 - | LetOperator (defs1, t1), LetOperator (defs2, t2) -> - eq_list (fun (i1, ps1, t1) (i2, ps2, t2) -> - eq_ident i1 i2 && - eq_pattern ps1 ps2 && - eq_term t1 t2) - defs1 defs2 && - eq_term t1 t2 - | LetOpen (l1, t1), LetOpen (l2, t2) -> - Ident.lid_equals l1 l2 && - eq_term t1 t2 - // compare all the remaining cases of terms starting with LetOperator - | LetOpenRecord (t1, t2, t3), LetOpenRecord (t4, t5, t6) -> - eq_term t1 t4 && - eq_term t2 t5 && - eq_term t3 t6 - | Seq (t1, t2), Seq (t3, t4) -> - eq_term t1 t3 && - eq_term t2 t4 - | Bind (i1, t1, t2), Bind (i2, t3, t4) -> - Ident.ident_equals i1 i2 && - eq_term t1 t3 && - eq_term t2 t4 - | If (t1, i1, mra1, t2, t3), If (t4, i2, mra2, t5, t6) -> - eq_term t1 t4 && - eq_option eq_ident i1 i2 && - eq_option eq_match_returns_annotation mra1 mra2 && - eq_term t2 t5 && - eq_term t3 t6 - | Match (t1, i1, mra1, bs1), Match (t2, i2, mra2, bs2) -> - eq_term t1 t2 && - eq_option eq_ident i1 i2 && - eq_option eq_match_returns_annotation mra1 mra2 && - eq_list eq_branch bs1 bs2 - | TryWith (t1, bs1), TryWith (t2, bs2) -> - eq_term t1 t2 && - eq_list eq_branch bs1 bs2 - | Ascribed (t1, t2, topt1, b1), Ascribed (t3, t4, topt2, b2) -> - eq_term t1 t3 && - eq_term t2 t4 && - eq_option eq_term topt1 topt2 && - b1 = b2 - | Record (topt1, fs1), Record (topt2, fs2) -> - eq_option eq_term topt1 topt2 && - eq_list (fun (l1, t1) (l2, t2) -> - Ident.lid_equals l1 l2 && - eq_term t1 t2) - fs1 fs2 - | Project (t1, l1), Project (t2, l2) -> - eq_term t1 t2 && - Ident.lid_equals l1 l2 - | Product (bs1, t1), Product (bs2, t2) -> - eq_list eq_binder bs1 bs2 && - eq_term t1 t2 - | Sum (bs1, t1), Sum (bs2, t2) -> - eq_list (fun b1 b2 -> - match b1, b2 with - | Inl b1, Inl b2 -> - eq_binder b1 b2 - | Inr t1, Inr t2 -> - eq_term t1 t2 - | Inl _, Inr _ - | Inr _, Inl _ -> - false) - bs1 bs2 && - eq_term t1 t2 - | QForall (bs1, ps1, t1), QForall (bs2, ps2, t2) - | QExists (bs1, ps1, t1), QExists (bs2, ps2, t2) -> - //ps1 and ps2 have type list ident * list (list term) - // generate equality on ps1 p2 - let eq_ps (is1, ts1) (is2, ts2) = - eq_list eq_ident is1 is2 && - eq_list (eq_list eq_term) ts1 ts2 - in - eq_list eq_binder bs1 bs2 && - eq_ps ps1 ps2 && - eq_term t1 t2 - | QuantOp (i1, bs1, ps1, t1), QuantOp (i2, bs2, ps2, t2) -> - let eq_ps (is1, ts1) (is2, ts2) = - eq_list eq_ident is1 is2 && - eq_list (eq_list eq_term) ts1 ts2 - in - Ident.ident_equals i1 i2 && - eq_list eq_binder bs1 bs2 && - eq_ps ps1 ps2 && - eq_term t1 t2 - // continue comparing all the remaining cases of terms, starting with Refine - | Refine (t1, t2), Refine (t3, t4) -> - eq_binder t1 t3 && - eq_term t2 t4 - // continue comparing all the remaining cases of terms, starting with NamedTyp - | NamedTyp (i1, t1), NamedTyp (i2, t2) -> - eq_ident i1 i2 && - eq_term t1 t2 - | Paren t1, Paren t2 -> - eq_term t1 t2 - | Requires (t1, s1), Requires (t2, s2) -> - eq_term t1 t2 && - eq_option ( = ) s1 s2 - | Ensures (t1, s1), Ensures (t2, s2) -> - eq_term t1 t2 && - eq_option ( = ) s1 s2 - | LexList ts1, LexList ts2 -> - eq_list eq_term ts1 ts2 - | WFOrder (t1, t2), WFOrder (t3, t4) -> - eq_term t1 t3 && - eq_term t2 t4 - | Decreases (t1, s1), Decreases (t2, s2) -> - eq_term t1 t2 && - eq_option ( = ) s1 s2 - | Labeled (t1, s1, b1), Labeled (t2, s2, b2) -> - eq_term t1 t2 && - s1 = s2 && - b1 = b2 - | Discrim l1, Discrim l2 -> - Ident.lid_equals l1 l2 - | Attributes ts1, Attributes ts2 -> - eq_list eq_term ts1 ts2 - | Antiquote t1, Antiquote t2 -> - eq_term t1 t2 - | Quote (t1, k1), Quote (t2, k2) -> - eq_term t1 t2 && - k1 = k2 - | VQuote t1, VQuote t2 -> - eq_term t1 t2 - | CalcProof (t1, t2, cs1), CalcProof (t3, t4, cs2) -> - eq_term t1 t3 && - eq_term t2 t4 && - eq_list eq_calc_step cs1 cs2 - | IntroForall (bs1, t1, t2), IntroForall (bs2, t3, t4) -> - eq_list eq_binder bs1 bs2 && - eq_term t1 t3 && - eq_term t2 t4 - | IntroExists (bs1, t1, ts1, t2), IntroExists (bs2, t3, ts2, t4) -> - eq_list eq_binder bs1 bs2 && - eq_term t1 t3 && - eq_list eq_term ts1 ts2 && - eq_term t2 t4 - | IntroImplies (t1, t2, b1, t3), IntroImplies (t4, t5, b2, t6) -> - eq_term t1 t4 && - eq_term t2 t5 && - eq_binder b1 b2 && - eq_term t3 t6 - | IntroOr (b1, t1, t2, t3), IntroOr (b2, t4, t5, t6) -> - b1 = b2 && - eq_term t1 t4 && - eq_term t2 t5 && - eq_term t3 t6 - | IntroAnd (t1, t2, t3, t4), IntroAnd (t5, t6, t7, t8) -> - eq_term t1 t5 && - eq_term t2 t6 && - eq_term t3 t7 && - eq_term t4 t8 - | ElimForall (bs1, t1, ts1), ElimForall (bs2, t2, ts2) -> - eq_list eq_binder bs1 bs2 && - eq_term t1 t2 && - eq_list eq_term ts1 ts2 - | ElimExists (bs1, t1, t2, b1, t3), ElimExists (bs2, t4, t5, b2, t6) -> - eq_list eq_binder bs1 bs2 && - eq_term t1 t4 && - eq_term t2 t5 && - eq_binder b1 b2 && - eq_term t3 t6 - | ElimImplies (t1, t2, t3), ElimImplies (t4, t5, t6) -> - eq_term t1 t4 && - eq_term t2 t5 && - eq_term t3 t6 - | ElimOr (t1, t2, t3, b1, t4, b2, t5), ElimOr (t6, t7, t8, b3, t9, b4, t10) -> - eq_term t1 t6 && - eq_term t2 t7 && - eq_term t3 t8 && - eq_binder b1 b3 && - eq_term t4 t9 && - eq_binder b2 b4 && - eq_term t5 t10 - | ElimAnd (t1, t2, t3, b1, b2, t4), ElimAnd (t5, t6, t7, b3, b4, t8) -> - eq_term t1 t5 && - eq_term t2 t6 && - eq_term t3 t7 && - eq_binder b1 b3 && - eq_binder b2 b4 && - eq_term t4 t8 - | ListLiteral ts1, ListLiteral ts2 -> - eq_list eq_term ts1 ts2 - | SeqLiteral ts1, SeqLiteral ts2 -> - eq_list eq_term ts1 ts2 - | _ -> false - -and eq_calc_step (CalcStep (t1, t2, t3)) (CalcStep (t4, t5, t6)) = - eq_term t1 t4 && - eq_term t2 t5 && - eq_term t3 t6 - -and eq_binder (b1 b2:binder) = - eq_binder' b1.b b2.b && - eq_aqual b1.aqual b2.aqual && - eq_list eq_term b1.battributes b2.battributes - -and eq_binder' (b1 b2:binder') = - match b1, b2 with - | Variable i1, Variable i2 -> eq_ident i1 i2 - | TVariable i1, TVariable i2 -> eq_ident i1 i2 - | Annotated (i1, t1), Annotated (i2, t2) -> - eq_ident i1 i2 && - eq_term t1 t2 - | TAnnotated (i1, t1), TAnnotated (i2, t2) -> - eq_ident i1 i2 && - eq_term t1 t2 - | NoName t1, NoName t2 -> - eq_term t1 t2 - | _ -> false - -and eq_match_returns_annotation (i1, t1, b1) (i2, t2, b2) = - eq_option eq_ident i1 i2 && - eq_term t1 t2 && - b1 = b2 - -and eq_branch (p1, o1, t1) (p2, o2, t2) = - eq_pattern p1 p2 && - eq_option eq_term o1 o2 && - eq_term t1 t2 - - -let eq_tycon_record (t1 t2: tycon_record) = - eq_list (fun (i1, a1, a2, t1) (i2, a3, a4, t2) -> - eq_ident i1 i2 && - eq_aqual a1 a3 && - eq_list eq_term a2 a4 && - eq_term t1 t2) t1 t2 - -let eq_constructor_payload (t1 t2: constructor_payload) = - match t1, t2 with - | VpOfNotation t1, VpOfNotation t2 -> eq_term t1 t2 - | VpArbitrary t1, VpArbitrary t2 -> eq_term t1 t2 - | VpRecord (r1, k1), VpRecord (r2, k2) -> - eq_tycon_record r1 r2 && - eq_option eq_term k1 k2 - | _ -> false - -let eq_tycon (t1 t2: tycon) = - match t1, t2 with - | TyconAbstract (i1, bs1, k1), TyconAbstract (i2, bs2, k2) -> - eq_ident i1 i2 && - eq_list eq_binder bs1 bs2 && - eq_option eq_term k1 k2 - | TyconAbbrev (i1, bs1, k1, t1), TyconAbbrev (i2, bs2, k2, t2) -> - eq_ident i1 i2 && - eq_list eq_binder bs1 bs2 && - eq_option eq_term k1 k2 && - eq_term t1 t2 - | TyconRecord (i1, bs1, k1, a1, r1), TyconRecord (i2, bs2, k2, a2, r2) -> - eq_ident i1 i2 && - eq_list eq_binder bs1 bs2 && - eq_option eq_term k1 k2 && - eq_list eq_term a1 a2 && - eq_tycon_record r1 r2 - | TyconVariant (i1, bs1, k1, cs1), TyconVariant (i2, bs2, k2, cs2) -> - eq_ident i1 i2 && - eq_list eq_binder bs1 bs2 && - eq_option eq_term k1 k2 && - eq_list (fun (i1, o1, a1) (i2, o2, a2) -> - eq_ident i1 i2 && - eq_option eq_constructor_payload o1 o2 && - eq_list eq_term a1 a2) cs1 cs2 - | _ -> false - -let eq_lid = Ident.lid_equals - -let eq_lift (t1 t2: lift) = - eq_lid t1.msource t2.msource && - eq_lid t1.mdest t2.mdest && - (match t1.lift_op, t2.lift_op with - | NonReifiableLift t1, NonReifiableLift t2 -> eq_term t1 t2 - | ReifiableLift (t1, t2), ReifiableLift (t3, t4) -> - eq_term t1 t3 && - eq_term t2 t4 - | LiftForFree t1, LiftForFree t2 -> eq_term t1 t2 - | _ -> false) - - -let eq_pragma (t1 t2: pragma) = - match t1, t2 with - | SetOptions s1, SetOptions s2 -> s1 = s2 - | ResetOptions s1, ResetOptions s2 -> eq_option (fun s1 s2 -> s1 = s2) s1 s2 - | PushOptions s1, PushOptions s2 -> eq_option (fun s1 s2 -> s1 = s2) s1 s2 - | PopOptions, PopOptions -> true - | RestartSolver, RestartSolver -> true - | PrintEffectsGraph, PrintEffectsGraph -> true - | _ -> false - - -let eq_qualifier (t1 t2: qualifier) = - match t1, t2 with - | Private, Private -> true - | Noeq, Noeq -> true - | Unopteq, Unopteq -> true - | Assumption, Assumption -> true - | DefaultEffect, DefaultEffect -> true - | TotalEffect, TotalEffect -> true - | Effect_qual, Effect_qual -> true - | New, New -> true - | Inline, Inline -> true - | Visible, Visible -> true - | Unfold_for_unification_and_vcgen, Unfold_for_unification_and_vcgen -> true - | Inline_for_extraction, Inline_for_extraction -> true - | Irreducible, Irreducible -> true - | NoExtract, NoExtract -> true - | Reifiable, Reifiable -> true - | Reflectable, Reflectable -> true - | Opaque, Opaque -> true - | Logic, Logic -> true - | _ -> false - -let eq_qualifiers (t1 t2: qualifiers) = - eq_list eq_qualifier t1 t2 - -let eq_restriction (restriction1 restriction2: FStar.Syntax.Syntax.restriction) = - let open FStar.Syntax.Syntax in - match restriction1, restriction2 with - | (Unrestricted, Unrestricted) -> true - | (AllowList l1, AllowList l2) -> - let eq_tuple eq_fst eq_snd (a, b) (c, d) = eq_fst a c && eq_snd b d in - eq_list (eq_tuple eq_ident (eq_option eq_ident)) l1 l2 - -let rec eq_decl' (d1 d2:decl') : bool = - //generate the cases of this comparison starting with TopLevelModule - match d1, d2 with - | TopLevelModule lid1, TopLevelModule lid2 -> - eq_lid lid1 lid2 - | Open (lid1, restriction1), Open (lid2, restriction2) -> - eq_lid lid1 lid2 && - eq_restriction restriction1 restriction2 - | Friend lid1, Friend lid2 -> - eq_lid lid1 lid2 - | Include (lid1, restriction1), Include (lid2, restriction2) -> - eq_lid lid1 lid2 && - eq_restriction restriction1 restriction2 - | ModuleAbbrev (i1, lid1), ModuleAbbrev (i2, lid2) -> - eq_ident i1 i2 && - eq_lid lid1 lid2 - | TopLevelLet (lq1, pats1), TopLevelLet (lq2, pats2) -> - lq1=lq2 && - eq_list (fun (p1, t1) (p2, t2) -> eq_pattern p1 p2 && eq_term t1 t2) pats1 pats2 - | Tycon (b1, b2, tcs1), Tycon (b3, b4, tcs2) -> - b1 = b3 && - b2 = b4 && - eq_list eq_tycon tcs1 tcs2 - | Val (i1, t1), Val (i2, t2) -> - eq_ident i1 i2 && - eq_term t1 t2 - | Exception (i1, t1), Exception (i2, t2) -> - eq_ident i1 i2 && - eq_option eq_term t1 t2 - | NewEffect ed1, NewEffect ed2 -> - eq_effect_decl ed1 ed2 - | LayeredEffect ed1, LayeredEffect ed2 -> - eq_effect_decl ed1 ed2 - | SubEffect l1, SubEffect l2 -> - eq_lift l1 l2 - | Polymonadic_bind (lid1, lid2, lid3, t1), Polymonadic_bind (lid4, lid5, lid6, t2) -> - eq_lid lid1 lid4 && - eq_lid lid2 lid5 && - eq_lid lid3 lid6 && - eq_term t1 t2 - | Polymonadic_subcomp (lid1, lid2, t1), Polymonadic_subcomp (lid3, lid4, t2) -> - eq_lid lid1 lid3 && - eq_lid lid2 lid4 && - eq_term t1 t2 - | Pragma p1, Pragma p2 -> - eq_pragma p1 p2 - | Assume (i1, t1), Assume (i2, t2) -> - eq_ident i1 i2 && - eq_term t1 t2 - | Splice (is_typed1, is1, t1), Splice (is_typed2, is2, t2) -> - is_typed1 = is_typed2 && - eq_list eq_ident is1 is2 && - eq_term t1 t2 - | DeclSyntaxExtension (s1, t1, _, _), DeclSyntaxExtension (s2, t2, _, _) -> - s1 = s2 && t1 = t2 - | UseLangDecls p1, UseLangDecls p2 -> - p1 = p2 - | DeclToBeDesugared tbs1, DeclToBeDesugared tbs2 -> - tbs1.lang_name = tbs2.lang_name && - tbs1.eq tbs1.blob tbs2.blob - | _ -> false - -and eq_effect_decl (t1 t2: effect_decl) = - match t1, t2 with - | DefineEffect (i1, bs1, t1, ds1), DefineEffect (i2, bs2, t2, ds2) -> - eq_ident i1 i2 && - eq_list eq_binder bs1 bs2 && - eq_term t1 t2 && - eq_list eq_decl ds1 ds2 - | RedefineEffect (i1, bs1, t1), RedefineEffect (i2, bs2, t2) -> - eq_ident i1 i2 && - eq_list eq_binder bs1 bs2 && - eq_term t1 t2 - | _ -> false - -and eq_decl (d1 d2:decl) : bool = - eq_decl' d1.d d2.d && - eq_list eq_qualifier d1.quals d2.quals && - eq_list eq_term d1.attrs d2.attrs - -let concat_map = List.collect -let opt_map f (x:option 'a) = match x with | None -> [] | Some x -> f x - -let rec lidents_of_term (t:term) -: list FStar.Ident.lident -= lidents_of_term' t.tm -and lidents_of_term' (t:term') -: list FStar.Ident.lident -= match t with - | Wild -> [] - | Const _ -> [] - | Op (s, ts) -> concat_map lidents_of_term ts - | Tvar _ -> [] - | Uvar _ -> [] - | Var lid -> [lid] - | Name lid -> [lid] - | Projector (lid, _) -> [lid] - | Construct (lid, ts) -> lid :: concat_map (fun (t, _) -> lidents_of_term t) ts - | Function (brs, _) -> concat_map lidents_of_branch brs - | Abs (ps, t) -> concat_map lidents_of_pattern ps @ lidents_of_term t - | App (t1, t2, _) -> lidents_of_term t1 @ lidents_of_term t2 - | Let (_, lbs, t) -> concat_map (fun (_, (p, t)) -> lidents_of_pattern p @ lidents_of_term t) lbs @ lidents_of_term t - | LetOperator (lbs, t) -> concat_map (fun (_, p, t) -> lidents_of_pattern p @ lidents_of_term t) lbs @ lidents_of_term t - | LetOpen (lid, t) -> lid :: lidents_of_term t - | LetOpenRecord (t1, t2, t3) -> lidents_of_term t1 @ lidents_of_term t2 @ lidents_of_term t3 - | Seq (t1, t2) -> lidents_of_term t1 @ lidents_of_term t2 - | Bind (_, t1, t2) -> lidents_of_term t1 @ lidents_of_term t2 - | If (t1, _, _, t2, t3) -> lidents_of_term t1 @ lidents_of_term t2 @ lidents_of_term t3 - | Match (t, _, _, bs) -> lidents_of_term t @ concat_map lidents_of_branch bs - | TryWith (t, bs) -> lidents_of_term t @ concat_map lidents_of_branch bs - | Ascribed (t1, t2, _, _) -> lidents_of_term t1 @ lidents_of_term t2 - | Record (t, ts) -> concat_map (fun (_, t) -> lidents_of_term t) ts @ opt_map lidents_of_term t - | Project (t, _) -> lidents_of_term t - | Product (ts, t) -> concat_map lidents_of_binder ts @ lidents_of_term t - | Sum (ts, t) -> concat_map (function Inl b -> lidents_of_binder b | Inr t -> lidents_of_term t) ts @ lidents_of_term t - | QForall (bs, _pats, t) -> lidents_of_term t - | QExists (bs, _pats, t) -> lidents_of_term t - | QuantOp (i, bs, pats, t) -> lidents_of_term t - | Refine (b, t) -> lidents_of_term t - | NamedTyp (i, t) -> lidents_of_term t - | Paren t -> lidents_of_term t - | Requires (t, _) -> lidents_of_term t - | Ensures (t, _) -> lidents_of_term t - | LexList ts -> concat_map lidents_of_term ts - | WFOrder (t1, t2) -> lidents_of_term t1 @ lidents_of_term t2 - | Decreases (t, _) -> lidents_of_term t - | Labeled (t, _, _) -> lidents_of_term t - | Discrim lid -> [lid] - | Attributes ts -> concat_map lidents_of_term ts - | Antiquote t -> lidents_of_term t - | Quote (t, _) -> lidents_of_term t - | VQuote t -> lidents_of_term t - | CalcProof (t1, t2, ts) -> lidents_of_term t1 @ lidents_of_term t2 @ concat_map lidents_of_calc_step ts - | IntroForall (bs, t1, t2) -> lidents_of_term t1 @ lidents_of_term t2 - | IntroExists (bs, t1, ts, t2) -> lidents_of_term t1 @ concat_map lidents_of_term ts @ lidents_of_term t2 - | IntroImplies (t1, t2, b, t3) -> lidents_of_term t1 @ lidents_of_term t2 @ lidents_of_term t3 - | IntroOr (b, t1, t2, t3) -> lidents_of_term t1 @ lidents_of_term t2 @ lidents_of_term t3 - | IntroAnd (t1, t2, t3, t4) -> lidents_of_term t1 @ lidents_of_term t2 @ lidents_of_term t3 @ lidents_of_term t4 - | ElimForall (bs, t1, ts) -> concat_map lidents_of_binder bs @ lidents_of_term t1 @ concat_map lidents_of_term ts - | ElimExists (bs, t1, t2, b, t3) -> concat_map lidents_of_binder bs @ lidents_of_term t1 @ lidents_of_term t2 @ lidents_of_term t3 - | ElimImplies (t1, t2, t3) -> lidents_of_term t1 @ lidents_of_term t2 @ lidents_of_term t3 - | ElimOr (t1, t2, t3, b1, t4, b2, t5) -> lidents_of_term t1 @ lidents_of_term t2 @ lidents_of_term t3 @ lidents_of_term t4 @ lidents_of_term t5 - | ElimAnd (t1, t2, t3, b1, b2, t4) -> lidents_of_term t1 @ lidents_of_term t2 @ lidents_of_term t3 @ lidents_of_term t4 - | ListLiteral ts -> concat_map lidents_of_term ts - | SeqLiteral ts -> concat_map lidents_of_term ts -and lidents_of_branch (p, _, t) = lidents_of_pattern p @ lidents_of_term t -and lidents_of_calc_step = function - | CalcStep (t1, t2, t3) -> lidents_of_term t1 @ lidents_of_term t2 @ lidents_of_term t3 -and lidents_of_pattern p = - match p.pat with - | PatWild _ -> [] - | PatConst _ -> [] - | PatApp (p, ps) -> lidents_of_pattern p @ concat_map lidents_of_pattern ps - | PatVar (i, _, _) -> [FStar.Ident.lid_of_ids [i]] - | PatName lid -> [lid] - | PatTvar (i, _, _) -> [] - | PatList ps -> concat_map lidents_of_pattern ps - | PatTuple (ps, _) -> concat_map lidents_of_pattern ps - | PatRecord ps -> concat_map (fun (_, p) -> lidents_of_pattern p) ps - | PatAscribed (p, (t1, t2)) -> lidents_of_pattern p @ lidents_of_term t1 @ opt_map lidents_of_term t2 - | PatOr ps -> concat_map lidents_of_pattern ps - | PatOp _ -> [] - | PatVQuote t -> lidents_of_term t -and lidents_of_binder b = - match b.b with - | Annotated (_, t) - | TAnnotated(_, t) - | NoName t -> lidents_of_term t - | _ -> [] - -let lidents_of_tycon_record (_, _, _, t) = - lidents_of_term t - -let lidents_of_constructor_payload (t:constructor_payload) = - match t with - | VpOfNotation t -> lidents_of_term t - | VpArbitrary t -> lidents_of_term t - | VpRecord (tc, None) -> concat_map lidents_of_tycon_record tc - | VpRecord (tc, Some t) -> concat_map lidents_of_tycon_record tc @ lidents_of_term t - -let lidents_of_tycon_variant (tc:(ident & option constructor_payload & attributes_)) = - match tc with - | _, None, _ -> [] - | _, Some t, _ -> lidents_of_constructor_payload t - -let lidents_of_tycon (tc:tycon) = - match tc with - | TyconAbstract (_, bs, k) -> concat_map lidents_of_binder bs @ opt_map lidents_of_term k - | TyconAbbrev (_, bs, k, t) -> concat_map lidents_of_binder bs @ opt_map lidents_of_term k @ lidents_of_term t - | TyconRecord (_, bs, k, _, tcs) -> - concat_map lidents_of_binder bs @ - opt_map lidents_of_term k @ - concat_map lidents_of_tycon_record tcs - | TyconVariant (_, bs, k, tcs) -> - concat_map lidents_of_binder bs @ - opt_map lidents_of_term k @ - concat_map lidents_of_tycon_variant tcs - -let lidents_of_lift (l:lift) = - [l.msource; l.mdest]@ - (match l.lift_op with - | NonReifiableLift t -> lidents_of_term t - | ReifiableLift (t1, t2) -> lidents_of_term t1 @ lidents_of_term t2 - | LiftForFree t -> lidents_of_term t) - -let rec lidents_of_decl (d:decl) = - match d.d with - | TopLevelModule _ -> [] - | Open (l, _) - | Friend l - | Include (l, _) - | ModuleAbbrev (_, l) -> [l] - | TopLevelLet (_q, lbs) -> concat_map (fun (p, t) -> lidents_of_pattern p @ lidents_of_term t) lbs - | Tycon (_, _, tcs) -> concat_map lidents_of_tycon tcs - | Val (_, t) -> lidents_of_term t - | Exception (_, None) -> [] - | Exception (_, Some t) -> lidents_of_term t - | NewEffect ed - | LayeredEffect ed -> lidents_of_effect_decl ed - | SubEffect lift -> lidents_of_lift lift - | Polymonadic_bind(l0, l1, l2, t) -> l0::l1::l2::lidents_of_term t - | Polymonadic_subcomp(l0, l1, t) -> l0::l1::lidents_of_term t - | Pragma _ -> [] - | Assume (_, t) -> lidents_of_term t - | Splice (_, _, t) -> lidents_of_term t - | DeclSyntaxExtension _ - | DeclToBeDesugared _ -> [] - -and lidents_of_effect_decl (ed:effect_decl) = - match ed with - | DefineEffect (_, bs, t, ds) -> - concat_map lidents_of_binder bs @ - lidents_of_term t @ - concat_map lidents_of_decl ds - | RedefineEffect (_, bs, t) -> - concat_map lidents_of_binder bs @ - lidents_of_term t - -module BU = FStar.Compiler.Util -let extension_parser_table : BU.smap extension_parser = FStar.Compiler.Util.smap_create 20 -let register_extension_parser (ext:string) (parser:extension_parser) = - FStar.Compiler.Util.smap_add extension_parser_table ext parser - -let lookup_extension_parser (ext:string) = - let do () = FStar.Compiler.Util.smap_try_find extension_parser_table ext in - match do () with - | None -> - if Plugins.autoload_plugin ext - then do () - else None - | r -> r - -let as_open_namespaces_and_abbrevs (ls:list decl) -: open_namespaces_and_abbreviations -= List.fold_right - (fun d out -> - match d.d with - | Open (lid, _) -> {out with open_namespaces = lid :: out.open_namespaces} - | ModuleAbbrev (i, lid) -> {out with module_abbreviations = (i, lid) :: out.module_abbreviations} - | _ -> out) - ls - {open_namespaces = []; module_abbreviations = []} - -let extension_lang_parser_table : BU.smap extension_lang_parser = FStar.Compiler.Util.smap_create 20 -let register_extension_lang_parser (ext:string) (parser:extension_lang_parser) = - FStar.Compiler.Util.smap_add extension_lang_parser_table ext parser -let lookup_extension_lang_parser (ext:string) = - let r = FStar.Compiler.Util.smap_try_find extension_lang_parser_table ext in - match r with - | None -> - if Plugins.autoload_plugin ext - then FStar.Compiler.Util.smap_try_find extension_lang_parser_table ext - else None - | _ -> r - -let parse_extension_lang (lang_name:string) (raw_text:string) (raw_text_pos:range) -: list decl -= let extension_parser = lookup_extension_lang_parser lang_name in - match extension_parser with - | None -> - raise_error raw_text_pos Errors.Fatal_SyntaxError - (BU.format1 "Unknown language extension %s" lang_name) - | Some parser -> - match parser.parse_decls raw_text raw_text_pos with - | Inl error -> - raise_error error.range Errors.Fatal_SyntaxError error.message - | Inr ds -> - ds diff --git a/src/parser/FStar.Parser.AST.Util.fsti b/src/parser/FStar.Parser.AST.Util.fsti deleted file mode 100644 index 8fb768c46ef..00000000000 --- a/src/parser/FStar.Parser.AST.Util.fsti +++ /dev/null @@ -1,70 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. - - Authors: N. Swamy and Copilot -*) -module FStar.Parser.AST.Util -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Parser.AST - -(* Check if two decls are equal, ignoring range metadata. - Used in FStar.Interactive.Incremental *) -val eq_term (t1 t2:term) : bool -val eq_binder (b1 b2:binder) : bool -val eq_pattern (p1 p2:pattern) : bool -val eq_decl (d1 d2:decl) : bool - -val lidents_of_decl (t:decl) : list FStar.Ident.lident - -type open_namespaces_and_abbreviations = { - open_namespaces: list FStar.Ident.lident; - module_abbreviations: list (FStar.Ident.ident & FStar.Ident.lident); -} - -type error_message = { - message: string; - range: FStar.Compiler.Range.range; -} - -type extension_parser = { - parse_decl_name: - (contents:string -> - FStar.Compiler.Range.range -> - either error_message FStar.Ident.ident); - - parse_decl: - (open_namespaces_and_abbreviations -> - contents:string -> - p:FStar.Compiler.Range.range -> - either error_message decl) -} - -val register_extension_parser (extension_name:string) (parser:extension_parser) : unit -val lookup_extension_parser (extension_name:string) : option extension_parser - - -type extension_lang_parser = { - parse_decls: - (contents:string -> - p:FStar.Compiler.Range.range -> - either error_message (list decl)) -} - -val as_open_namespaces_and_abbrevs (ls:list decl) : open_namespaces_and_abbreviations -val register_extension_lang_parser (extension_name:string) (parser:extension_lang_parser) : unit -val lookup_extension_lang_parser (extension_name:string) : option extension_lang_parser -val parse_extension_lang (lang_name:string) (raw_text:string) (raw_text_pos:FStar.Compiler.Range.range) : list decl diff --git a/src/parser/FStar.Parser.AST.fst b/src/parser/FStar.Parser.AST.fst deleted file mode 100644 index 3644393db72..00000000000 --- a/src/parser/FStar.Parser.AST.fst +++ /dev/null @@ -1,866 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Parser.AST - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Compiler.Range -open FStar.Compiler.Util -open FStar.Const -open FStar.Errors -open FStar.Ident -open FStar.Class.Show -module C = FStar.Parser.Const - -instance hasRange_term : hasRange term = { - pos = (fun t -> t.range); - setPos = (fun r t -> { t with range = r }); -} - -instance hasRange_pattern : hasRange pattern = { - pos = (fun p -> p.prange); - setPos = (fun r p -> { p with prange = r }); -} - -instance hasRange_binder : hasRange binder = { - pos = (fun b -> b.brange); - setPos = (fun r b -> { b with brange = r }); -} - -instance hasRange_decl : hasRange decl = { - pos = (fun d -> d.drange); - setPos = (fun r d -> { d with drange = r }); -} - -let lid_of_modul (m:modul) : lid = - match m with - | Module(lid, _) -> lid - | Interface (lid, _, _) -> lid - -let check_id id = - let first_char = String.substring (string_of_id id) 0 1 in - if not (String.lowercase first_char = first_char) then - raise_error id Fatal_InvalidIdentifier - (Util.format1 "Invalid identifer '%s'; expected a symbol that begins with a lower-case character" (show id)) - -let at_most_one s (r:range) l = match l with - | [ x ] -> Some x - | [] -> None - | _ -> - raise_error r Fatal_MoreThanOneDeclaration - (Util.format1 "At most one %s is allowed on declarations" s) - -let mk_binder_with_attrs b r l i attrs = {b=b; brange=r; blevel=l; aqual=i; battributes=attrs} -let mk_binder b r l i = mk_binder_with_attrs b r l i [] -let mk_term t r l = {tm=t; range=r; level=l} -let mk_uminus t rminus r l = - let t = - match t.tm with - | Const (Const_int (s, Some (Signed, width))) -> - Const (Const_int ("-" ^ s, Some (Signed, width))) - | _ -> - Op(mk_ident ("-", rminus), [t]) - in - mk_term t r l - -let mk_pattern p r = {pat=p; prange=r} -let un_curry_abs ps body = match body.tm with - | Abs(p', body') -> Abs(ps@p', body') - | _ -> Abs(ps, body) -let mk_function branches r1 r2 = - mk_term (Function (branches, r1)) r2 Expr - -let un_function p tm = match p.pat, tm.tm with - | PatVar _, Abs(pats, body) -> Some (mk_pattern (PatApp(p, pats)) p.prange, body) - | _ -> None - -let mkApp t args r = match args with - | [] -> t - | _ -> match t.tm with - | Name s -> mk_term (Construct(s, args)) r Un - | _ -> List.fold_left (fun t (a,imp) -> mk_term (App(t, a, imp)) r Un) t args - -let consPat r hd tl = PatApp(mk_pattern (PatName C.cons_lid) r, [hd;tl]) -let consTerm r hd tl = mk_term (Construct(C.cons_lid, [(hd, Nothing);(tl, Nothing)])) r Expr - -let mkListLit r elts = - mk_term (ListLiteral elts) r Expr - -let mkSeqLit r elts = - mk_term (SeqLiteral elts) r Expr - -let unit_const r = mk_term(Const Const_unit) r Expr - -let ml_comp t = - let lid = C.effect_ML_lid () in - let ml = mk_term (Name lid) t.range Expr in - let t = mk_term (App(ml, t, Nothing)) t.range Expr in - t - -let tot_comp t = - let ml = mk_term (Name C.effect_Tot_lid) t.range Expr in - let t = mk_term (App(ml, t, Nothing)) t.range Expr in - t - -let mkRefSet r elts = - let empty_lid, singleton_lid, union_lid, addr_of_lid = - C.set_empty, C.set_singleton, C.set_union, C.heap_addr_of_lid in - let empty = mk_term (Var(set_lid_range empty_lid r)) r Expr in - let addr_of = mk_term (Var (set_lid_range addr_of_lid r)) r Expr in - let singleton = mk_term (Var (set_lid_range singleton_lid r)) r Expr in - let union = mk_term (Var(set_lid_range union_lid r)) r Expr in - List.fold_right (fun e tl -> - let e = mkApp addr_of [(e, Nothing)] r in - let single_e = mkApp singleton [(e, Nothing)] r in - mkApp union [(single_e, Nothing); (tl, Nothing)] r) elts empty - -let mkExplicitApp t args r = match args with - | [] -> t - | _ -> match t.tm with - | Name s -> mk_term (Construct(s, (List.map (fun a -> (a, Nothing)) args))) r Un - | _ -> List.fold_left (fun t a -> mk_term (App(t, a, Nothing)) r Un) t args - -let mkAdmitMagic r = - let admit = - let admit_name = mk_term(Var(set_lid_range C.admit_lid r)) r Expr in - mkExplicitApp admit_name [unit_const r] r in - let magic = - let magic_name = mk_term(Var(set_lid_range C.magic_lid r)) r Expr in - mkExplicitApp magic_name [unit_const r] r in - let admit_magic = mk_term(Seq(admit, magic)) r Expr in - admit_magic - -let mkWildAdmitMagic r = (mk_pattern (PatWild (None, [])) r, None, mkAdmitMagic r) - -let focusBranches branches r = - let should_filter = Util.for_some fst branches in - if should_filter - then - let _ = Errors.log_issue r Errors.Warning_Filtered "Focusing on only some cases" in - let focussed = List.filter fst branches |> List.map snd in - focussed@[mkWildAdmitMagic r] - else branches |> List.map snd - -let focusLetBindings lbs r = - let should_filter = Util.for_some fst lbs in - if should_filter - then - let _ = Errors.log_issue r Errors.Warning_Filtered "Focusing on only some cases in this (mutually) recursive definition" in - List.map (fun (f, lb) -> - if f then lb - else (fst lb, mkAdmitMagic r)) lbs - else lbs |> List.map snd - -let focusAttrLetBindings lbs r = - let should_filter = Util.for_some (fun (attr, (focus, _)) -> focus) lbs in - if should_filter - then - let _ = Errors.log_issue r Errors.Warning_Filtered "Focusing on only some cases in this (mutually) recursive definition" in - List.map (fun (attr, (f, lb)) -> - if f then attr, lb - else (attr, (fst lb, mkAdmitMagic r))) lbs - else lbs |> List.map (fun (attr, (_, lb)) -> (attr, lb)) - -let mkFsTypApp t args r = - mkApp t (List.map (fun a -> (a, FsTypApp)) args) r - - (* TODO : is this valid or should it use Construct ? *) -let mkTuple args r = - let cons = C.mk_tuple_data_lid (List.length args) r in - mkApp (mk_term (Name cons) r Expr) (List.map (fun x -> (x, Nothing)) args) r - -let mkDTuple args r = - let cons = C.mk_dtuple_data_lid (List.length args) r in - mkApp (mk_term (Name cons) r Expr) (List.map (fun x -> (x, Nothing)) args) r - -let mkRefinedBinder id t should_bind_var refopt m implicit attrs : binder = - let b = mk_binder_with_attrs (Annotated(id, t)) m Type_level implicit attrs in - match refopt with - | None -> b - | Some phi -> - if should_bind_var - then mk_binder_with_attrs (Annotated(id, mk_term (Refine(b, phi)) m Type_level)) m Type_level implicit attrs - else - let x = gen t.range in - let b = mk_binder_with_attrs (Annotated (x, t)) m Type_level implicit attrs in - mk_binder_with_attrs (Annotated(id, mk_term (Refine(b, phi)) m Type_level)) m Type_level implicit attrs - -let mkRefinedPattern pat t should_bind_pat phi_opt t_range range = - let t = match phi_opt with - | None -> t - | Some phi -> - if should_bind_pat - then - begin match pat.pat with - | PatVar (x,_,attrs) -> - mk_term (Refine(mk_binder_with_attrs (Annotated(x, t)) t_range Type_level None attrs, phi)) range Type_level - | _ -> - let x = gen t_range in - let phi = - (* match x with | pat -> phi | _ -> False *) - let x_var = mk_term (Var (lid_of_ids [x])) phi.range Formula in - let pat_branch = (pat, None, phi)in - let otherwise_branch = - (mk_pattern (PatWild (None, [])) phi.range, None, - mk_term (Name (lid_of_path ["False"] phi.range)) phi.range Formula) - in - mk_term (Match (x_var, None, None, [pat_branch ; otherwise_branch])) phi.range Formula - in - mk_term (Refine(mk_binder (Annotated(x, t)) t_range Type_level None, phi)) range Type_level - end - else - let x = gen t.range in - mk_term (Refine(mk_binder (Annotated (x, t)) t_range Type_level None, phi)) range Type_level - in - mk_pattern (PatAscribed(pat, (t, None))) range - -let rec extract_named_refinement (remove_parens:bool) (t1:term) : option (ident & term & option typ) = - match t1.tm with - | NamedTyp(x, t) -> Some (x, t, None) - | Refine({b=Annotated(x, t)}, t') -> Some (x, t, Some t') - | Paren t when remove_parens -> extract_named_refinement remove_parens t - | _ -> None - -(* Some helpers that parse.mly and parse.fsy will want too *) - -(* JP: what does this function do? A comment would be welcome, or at the very - least a type annotation... - JP: ok, here's my understanding. - This function peeks at the first top-level declaration; - - if this is NOT a TopLevelModule, then we're in interactive mode and return - [Inr list-of-declarations] - - if this IS a TopLevelModule, then we do a forward search and group - declarations together with the preceding [TopLevelModule] and return a [Inl - list-of-modules] where each "module" [Module (lid, list-of-declarations)], with the - unspecified invariant that the first declaration is a [TopLevelModule] - JP: TODO actually forbid multiple modules and remove all of this. *) - -//NS: needed to hoist this to workaround a bootstrapping bug -// leaving it within as_frag causes the type-checker to take a very long time, perhaps looping -let rec as_mlist (cur: (lid & decl) & list decl) (ds:list decl) : modul = - let ((m_name, m_decl), cur) = cur in - match ds with - | [] -> Module(m_name, m_decl :: List.rev cur) - | d :: ds -> - begin match d.d with - | TopLevelModule m' -> - raise_error d Fatal_UnexpectedModuleDeclaration "Unexpected module declaration" - | _ -> - as_mlist ((m_name, m_decl), d::cur) ds - end - -let as_frag (ds:list decl) : inputFragment = - let d, ds = match ds with - | d :: ds -> d, ds - | [] -> raise Empty_frag - in - match d.d with - | TopLevelModule m -> - let m = as_mlist ((m,d), []) ds in - Inl m - | _ -> - let ds = d::ds in - List.iter (function - | {d=TopLevelModule _; drange=r} -> raise_error r Fatal_UnexpectedModuleDeclaration "Unexpected module declaration" - | _ -> () - ) ds; - Inr ds - -// TODO: Move to something like FStar.Compiler.Util -let strip_prefix (prefix s: string): option string - = if starts_with s prefix - then Some (substring_from s (String.length prefix)) - else None - -let compile_op arity s r = - let name_of_char = function - |'&' -> "Amp" - |'@' -> "At" - |'+' -> "Plus" - |'-' when (arity=1) -> "Minus" - |'-' -> "Subtraction" - |'~' -> "Tilde" - |'/' -> "Slash" - |'\\' -> "Backslash" - |'<' -> "Less" - |'=' -> "Equals" - |'>' -> "Greater" - |'_' -> "Underscore" - |'|' -> "Bar" - |'!' -> "Bang" - |'^' -> "Hat" - |'%' -> "Percent" - |'*' -> "Star" - |'?' -> "Question" - |':' -> "Colon" - |'$' -> "Dollar" - |'.' -> "Dot" - | c -> "u" ^ (Util.string_of_int (Util.int_of_char c)) - in - match s with - | ".[]<-" -> "op_String_Assignment" - | ".()<-" -> "op_Array_Assignment" - | ".[||]<-" -> "op_Brack_Lens_Assignment" - | ".(||)<-" -> "op_Lens_Assignment" - | ".[]" -> "op_String_Access" - | ".()" -> "op_Array_Access" - | ".[||]" -> "op_Brack_Lens_Access" - | ".(||)" -> "op_Lens_Access" - | _ -> // handle let operators (i.e. [let?] or [and*], and [exists*] and [forall*]) - let prefix, s = - if starts_with s "let" || starts_with s "and" - then substring s 0 3 ^ "_", substring_from s 3 - else if starts_with s "exists" || starts_with s "forall" - then substring s 0 6 ^ "_", substring_from s 6 - else "", s in - "op_" ^ prefix ^ String.concat "_" (List.map name_of_char (String.list_of_string s)) - -let compile_op' s r = - compile_op (-1) s r - -let string_to_op s = - let name_of_op s = - match s with - | "Amp" -> Some ("&", None) - | "At" -> Some ("@", None) - | "Plus" -> Some ("+", Some 2) - | "Minus" -> Some ("-", None) - | "Subtraction" -> Some ("-", Some 2) - | "Tilde" -> Some ("~", None) - | "Slash" -> Some ("/", Some 2) - | "Backslash" -> Some ("\\", None) - | "Less" -> Some ("<", Some 2) - | "Equals" -> Some ("=", None) - | "Greater" -> Some (">", Some 2) - | "Underscore" -> Some ("_", None) - | "Bar" -> Some ("|", None) - | "Bang" -> Some ("!", None) - | "Hat" -> Some ("^", None) - | "Percent" -> Some ("%", None) - | "Star" -> Some ("*", None) - | "Question" -> Some ("?", None) - | "Colon" -> Some (":", None) - | "Dollar" -> Some ("$", None) - | "Dot" -> Some (".", None) - | "let" | "and" | "forall" | "exists" -> Some (s, None) - | _ -> None - in - match s with - | "op_String_Assignment" -> Some (".[]<-", None) - | "op_Array_Assignment" -> Some (".()<-", None) - | "op_Brack_Lens_Assignment" -> Some (".[||]<-", None) - | "op_Lens_Assignment" -> Some (".(||)<-", None) - | "op_String_Access" -> Some (".[]", None) - | "op_Array_Access" -> Some (".()", None) - | "op_Brack_Lens_Access" -> Some (".[||]", None) - | "op_Lens_Access" -> Some (".(||)", None) - | _ -> - if starts_with s "op_" - then let frags = split (substring_from s (String.length "op_")) "_" in - match frags with - | [op] -> - if starts_with op "u" - then map_opt (safe_int_of_string (substring_from op 1)) ( - fun op -> (string_of_char (char_of_int op), None) - ) - else name_of_op op - | _ -> - let maybeop = - List.fold_left (fun acc x -> match acc with - | None -> None - | Some acc -> - match x with - | Some (op, _) -> Some (acc ^ op) - | None -> None) - (Some "") - (List.map name_of_op frags) - in - map_opt maybeop (fun o -> (o, None)) - else None - -////////////////////////////////////////////////////////////////////////////////////////////// -// Printing ASTs, mostly for debugging -////////////////////////////////////////////////////////////////////////////////////////////// - -let string_of_fsdoc (comment,keywords) = - comment ^ (String.concat "," (List.map (fun (k,v) -> k ^ "->" ^ v) keywords)) - -let string_of_let_qualifier = function - | NoLetQualifier -> "" - | Rec -> "rec" -let to_string_l sep f l = - String.concat sep (List.map f l) -let imp_to_string = function - | Hash -> "#" - | _ -> "" -let rec term_to_string (x:term) = match x.tm with - | Wild -> "_" - | LexList l -> Util.format1 "%[%s]" - (match l with - | [] -> " " - | hd::tl -> - tl |> List.fold_left (fun s t -> s ^ "; " ^ term_to_string t) (term_to_string hd)) - | Decreases (t, _) -> Util.format1 "(decreases %s)" (term_to_string t) - | Requires (t, _) -> Util.format1 "(requires %s)" (term_to_string t) - | Ensures (t, _) -> Util.format1 "(ensures %s)" (term_to_string t) - | Labeled (t, l, _) -> Util.format2 "(labeled %s %s)" l (term_to_string t) - | Const c -> C.const_to_string c - | Op(s, xs) -> - Util.format2 "%s(%s)" (string_of_id s) (String.concat ", " (List.map (fun x -> x|> term_to_string) xs)) - | Tvar id - | Uvar id -> (string_of_id id) - | Var l - | Name l -> (string_of_lid l) - - | Projector (rec_lid, field_id) -> - Util.format2 "%s?.%s" (string_of_lid rec_lid) ((string_of_id field_id)) - - | Construct (l, args) -> - Util.format2 "(%s %s)" (string_of_lid l) (to_string_l " " (fun (a,imp) -> Util.format2 "%s%s" (imp_to_string imp) (term_to_string a)) args) - | Function (branches, r) -> - Util.format1 "(function %s)" - (to_string_l " | " (fun (p,w,e) -> Util.format2 "%s -> %s" - (p |> pat_to_string) - (e |> term_to_string)) branches) - - | Abs(pats, t) -> - Util.format2 "(fun %s -> %s)" (to_string_l " " pat_to_string pats) (t|> term_to_string) - | App(t1, t2, imp) -> Util.format3 "%s %s%s" (t1|> term_to_string) (imp_to_string imp) (t2|> term_to_string) - | Let (Rec, (a,(p,b))::lbs, body) -> - Util.format4 "%slet rec %s%s in %s" - (attrs_opt_to_string a) - (Util.format2 "%s=%s" (p|> pat_to_string) (b|> term_to_string)) - (to_string_l " " - (fun (a,(p,b)) -> - Util.format3 "%sand %s=%s" - (attrs_opt_to_string a) - (p|> pat_to_string) - (b|> term_to_string)) - lbs) - (body|> term_to_string) - | Let (q, [(attrs,(pat,tm))], body) -> - Util.format5 "%slet %s %s = %s in %s" - (attrs_opt_to_string attrs) - (string_of_let_qualifier q) - (pat|> pat_to_string) - (tm|> term_to_string) - (body|> term_to_string) - | Let (_, _, _) -> - raise_error x Fatal_EmptySurfaceLet "Internal error: found an invalid surface Let" - - | LetOpen (lid, t) -> - Util.format2 "let open %s in %s" (string_of_lid lid) (term_to_string t) - - | Seq(t1, t2) -> - Util.format2 "%s; %s" (t1|> term_to_string) (t2|> term_to_string) - - | Bind (id, t1, t2) -> - Util.format3 "%s <- %s; %s" (string_of_id id) (term_to_string t1) (term_to_string t2) - - | If(t1, op_opt, ret_opt, t2, t3) -> - Util.format5 "if%s %s %sthen %s else %s" - (match op_opt with | Some op -> string_of_id op | None -> "") - (t1|> term_to_string) - (match ret_opt with - | None -> "" - | Some (as_opt, ret, use_eq) -> - let s = if use_eq then "returns$" else "returns" in - Util.format3 "%s%s %s " - (match as_opt with - | None -> "" - | Some as_ident -> Util.format1 " as %s " (string_of_id as_ident)) - s - (term_to_string ret)) - (t2|> term_to_string) - (t3|> term_to_string) - - | Match(t, op_opt, ret_opt, branches) -> try_or_match_to_string x t branches op_opt ret_opt - | TryWith (t, branches) -> try_or_match_to_string x t branches None None - - | Ascribed(t1, t2, None, flag) -> - let s = if flag then "$:" else "<:" in - Util.format3 "(%s %s %s)" (t1|> term_to_string) s (t2|> term_to_string) - | Ascribed(t1, t2, Some tac, flag) -> - let s = if flag then "$:" else "<:" in - Util.format4 "(%s %s %s by %s)" (t1|> term_to_string) s (t2|> term_to_string) (tac |> term_to_string) - | Record(Some e, fields) -> - Util.format2 "{%s with %s}" (e|> term_to_string) (to_string_l " " (fun (l,e) -> Util.format2 "%s=%s" ((string_of_lid l)) (e|> term_to_string)) fields) - | Record(None, fields) -> - Util.format1 "{%s}" (to_string_l " " (fun (l,e) -> Util.format2 "%s=%s" ((string_of_lid l)) (e|> term_to_string)) fields) - | Project(e,l) -> - Util.format2 "%s.%s" (e|> term_to_string) ((string_of_lid l)) - | Product([], t) -> - term_to_string t - | Product(b::hd::tl, t) -> - term_to_string (mk_term (Product([b], mk_term (Product(hd::tl, t)) x.range x.level)) x.range x.level) - | Product([b], t) when (x.level = Type_level) -> - Util.format2 "%s -> %s" (b|> binder_to_string) (t|> term_to_string) - | Product([b], t) when (x.level = Kind) -> - Util.format2 "%s => %s" (b|> binder_to_string) (t|> term_to_string) - | Sum(binders, t) -> - (binders@[Inr t]) |> - List.map (function Inl b -> binder_to_string b - | Inr t -> term_to_string t) |> - String.concat " & " - | QForall(bs, (_, pats), t) -> - Util.format3 "forall %s.{:pattern %s} %s" - (to_string_l " " binder_to_string bs) - (to_string_l " \/ " (to_string_l "; " term_to_string) pats) - (t|> term_to_string) - | QExists(bs, (_, pats), t) -> - Util.format3 "exists %s.{:pattern %s} %s" - (to_string_l " " binder_to_string bs) - (to_string_l " \/ " (to_string_l "; " term_to_string) pats) - (t|> term_to_string) - | QuantOp(i, bs, (_, []), t) -> - Util.format3 "%s %s. %s" - (string_of_id i) - (to_string_l " " binder_to_string bs) - (t|> term_to_string) - | QuantOp(i, bs, (_, pats), t) -> - Util.format4 "%s %s.{:pattern %s} %s" - (string_of_id i) - (to_string_l " " binder_to_string bs) - (to_string_l " \/ " (to_string_l "; " term_to_string) pats) - (t|> term_to_string) - | Refine(b, t) -> - Util.format2 "%s:{%s}" (b|> binder_to_string) (t|> term_to_string) - | NamedTyp(x, t) -> - Util.format2 "%s:%s" (string_of_id x) (t|> term_to_string) - | Paren t -> Util.format1 "(%s)" (t|> term_to_string) - | Product(bs, t) -> - Util.format2 "Unidentified product: [%s] %s" - (bs |> List.map binder_to_string |> String.concat ",") (t|> term_to_string) - - | Discrim lid -> - Util.format1 "%s?" (string_of_lid lid) - - | Attributes ts -> - Util.format1 "(attributes %s)" (String.concat " " <| List.map term_to_string ts) - - | Antiquote t -> - Util.format1 "(`#%s)" (term_to_string t) - - | Quote (t, Static) -> - Util.format1 "(`(%s))" (term_to_string t) - - | Quote (t, Dynamic) -> - Util.format1 "quote (%s)" (term_to_string t) - - | VQuote t -> - Util.format1 "`%%%s" (term_to_string t) - - | CalcProof (rel, init, steps) -> - Util.format3 "calc (%s) { %s %s }" (term_to_string rel) - (term_to_string init) - (String.concat " " <| List.map calc_step_to_string steps) - - - | ElimForall(bs, t, vs) -> - Util.format3 "_elim_ forall %s. %s using %s" - (binders_to_string " " bs) - (term_to_string t) - (String.concat " " (List.map term_to_string vs)) - - | ElimExists(bs, p, q, b, e) -> - Util.format5 "_elim_ exists %s. %s _to_ %s\n\with %s. %s" - (binders_to_string " " bs) - (term_to_string p) - (term_to_string q) - (binder_to_string b) - (term_to_string e) - - | ElimImplies(p, q, e) -> - Util.format3 "_elim_ %s ==> %s with %s" - (term_to_string p) - (term_to_string q) - (term_to_string e) - - | ElimOr(p, q, r, x, e, y, e') -> - Util.format "_elim_ %s \/ %s _to_ %s\n\with %s. %s\n\and %s.%s" - [term_to_string p; - term_to_string q; - term_to_string r; - binder_to_string x; - term_to_string e; - binder_to_string y; - term_to_string e'] - - | ElimAnd(p, q, r, x, y, e) -> - Util.format "_elim_ %s /\ %s _to_ %s\n\with %s %s. %s" - [term_to_string p; - term_to_string q; - term_to_string r; - binder_to_string x; - binder_to_string y; - term_to_string e] - - | IntroForall(xs, p, e) -> - Util.format3 "_intro_ forall %s. %s with %s" - (binders_to_string " " xs) - (term_to_string p) - (term_to_string e) - - | IntroExists(xs, t, vs, e) -> - Util.format4 "_intro_ exists %s. %s using %s with %s" - (binders_to_string " " xs) - (term_to_string t) - (String.concat " " (List.map term_to_string vs)) - (term_to_string e) - - | IntroImplies(p, q, x, e) -> - Util.format4 ("_intro_ %s ==> %s with %s. %s") - (term_to_string p) - (term_to_string q) - (binder_to_string x) - (term_to_string p) - - | IntroOr(b, p, q, r) -> - Util.format4 ("_intro_ %s \/ %s using %s with %s") - (term_to_string p) - (term_to_string q) - (if b then "Left" else "Right") - (term_to_string r) - - | IntroAnd(p, q, e1, e2) -> - Util.format4 ("_intro_ %s /\ %s with %s and %s") - (term_to_string p) - (term_to_string q) - (term_to_string e1) - (term_to_string e2) - - | ListLiteral ts -> - Util.format1 "[%s]" (to_string_l "; " term_to_string ts) - - | SeqLiteral ts -> - Util.format1 "seq![%s]" (to_string_l "; " term_to_string ts) - -and binders_to_string sep bs = - List.map binder_to_string bs |> String.concat sep - -and try_or_match_to_string (x:term) scrutinee branches op_opt ret_opt = - let s = - match x.tm with - | Match _ -> "match" - | TryWith _ -> "try" - | _ -> failwith "impossible" in - Util.format5 "%s%s %s %swith %s" - s - (match op_opt with | Some op -> string_of_id op | None -> "") - (scrutinee|> term_to_string) - (match ret_opt with - | None -> "" - | Some (as_opt, ret, use_eq) -> - let s = if use_eq then "returns$" else "returns" in - Util.format3 "%s%s %s " s - (match as_opt with - | None -> "" - | Some as_ident -> Util.format1 "as %s " (string_of_id as_ident)) - (term_to_string ret)) - (to_string_l " | " (fun (p,w,e) -> Util.format3 "%s %s -> %s" - (p |> pat_to_string) - (match w with | None -> "" | Some e -> Util.format1 "when %s" (term_to_string e)) - (e |> term_to_string)) branches) - -and calc_step_to_string (CalcStep (rel, just, next)) = - Util.format3 "%s{ %s } %s" (term_to_string rel) (term_to_string just) (term_to_string next) - -and binder_to_string x = - let pr x = - let s = match x.b with - | Variable i -> (string_of_id i) - | TVariable i -> Util.format1 "%s:_" ((string_of_id i)) - | TAnnotated(i,t) - | Annotated(i,t) -> Util.format2 "%s:%s" ((string_of_id i)) (t |> term_to_string) - | NoName t -> t |> term_to_string in - Util.format3 "%s%s%s" - (aqual_to_string x.aqual) - (attr_list_to_string x.battributes) - s - in - (* Handle typeclass qualifier here *) - match x.aqual with - | Some TypeClassArg -> "{| " ^ pr x ^ " |}" - | _ -> pr x - -and aqual_to_string = function - | Some Equality -> "$" - | Some Implicit -> "#" - | None -> "" - | Some (Meta _) - | Some TypeClassArg -> - failwith "aqual_to_strings: meta arg qualifier?" - -and attr_list_to_string = function - | [] -> "" - | l -> attrs_opt_to_string (Some l) - -and pat_to_string x = match x.pat with - | PatWild (None, attrs) -> attr_list_to_string attrs ^ "_" - | PatWild (_, attrs) -> "#" ^ (attr_list_to_string attrs) ^ "_" - | PatConst c -> C.const_to_string c - | PatVQuote t -> Util.format1 "`%%%s" (term_to_string t) - | PatApp(p, ps) -> Util.format2 "(%s %s)" (p |> pat_to_string) (to_string_l " " pat_to_string ps) - | PatTvar (i, aq, attrs) - | PatVar (i, aq, attrs) -> Util.format3 "%s%s%s" - (aqual_to_string aq) - (attr_list_to_string attrs) - (string_of_id i) - | PatName l -> (string_of_lid l) - | PatList l -> Util.format1 "[%s]" (to_string_l "; " pat_to_string l) - | PatTuple (l, false) -> Util.format1 "(%s)" (to_string_l ", " pat_to_string l) - | PatTuple (l, true) -> Util.format1 "(|%s|)" (to_string_l ", " pat_to_string l) - | PatRecord l -> Util.format1 "{%s}" (to_string_l "; " (fun (f,e) -> Util.format2 "%s=%s" ((string_of_lid f)) (e |> pat_to_string)) l) - | PatOr l -> to_string_l "|\n " pat_to_string l - | PatOp op -> Util.format1 "(%s)" (Ident.string_of_id op) - | PatAscribed(p,(t, None)) -> Util.format2 "(%s:%s)" (p |> pat_to_string) (t |> term_to_string) - | PatAscribed(p,(t, Some tac)) -> Util.format3 "(%s:%s by %s)" (p |> pat_to_string) (t |> term_to_string) (tac |> term_to_string) - -and attrs_opt_to_string = function - | None -> "" - | Some attrs -> Util.format1 "[@ %s]" (List.map term_to_string attrs |> String.concat "; ") - -let rec head_id_of_pat p = match p.pat with - | PatName l -> [l] - | PatVar (i, _, _) -> [FStar.Ident.lid_of_ids [i]] - | PatApp(p, _) -> head_id_of_pat p - | PatAscribed(p, _) -> head_id_of_pat p - | _ -> [] - -let lids_of_let defs = defs |> List.collect (fun (p, _) -> head_id_of_pat p) - -let id_of_tycon = function - | TyconAbstract(i, _, _) - | TyconAbbrev(i, _, _, _) - | TyconRecord(i, _, _, _, _) - | TyconVariant(i, _, _, _) -> (string_of_id i) - -let string_of_pragma = function - | ShowOptions -> "show-options" - | SetOptions s -> Util.format1 "set-options \"%s\"" s - | ResetOptions s -> Util.format1 "reset-options \"%s\"" (Util.dflt "" s) - | PushOptions s -> Util.format1 "push-options \"%s\"" (Util.dflt "" s) - | PopOptions -> "pop-options" - | RestartSolver -> "restart-solver" - | PrintEffectsGraph -> "print-effects-graph" - -let restriction_to_string: FStar.Syntax.Syntax.restriction -> string = - let open FStar.Syntax.Syntax in - function | Unrestricted -> "" - | AllowList allow_list -> " {" ^ String.concat ", " (List.map (fun (id, renamed) -> string_of_id id ^ dflt "" (map_opt renamed (fun renamed -> " as " ^ string_of_id renamed))) allow_list) ^ "}" - -let rec decl_to_string (d:decl) = match d.d with - | TopLevelModule l -> "module " ^ (string_of_lid l) - | Open (l, r) -> "open " ^ string_of_lid l ^ restriction_to_string r - | Friend l -> "friend " ^ (string_of_lid l) - | Include (l, r) -> "include " ^ string_of_lid l ^ restriction_to_string r - | ModuleAbbrev (i, l) -> Util.format2 "module %s = %s" (string_of_id i) (string_of_lid l) - | TopLevelLet(_, pats) -> "let " ^ (lids_of_let pats |> List.map (fun l -> (string_of_lid l)) |> String.concat ", ") - | Assume(i, _) -> "assume " ^ (string_of_id i) - | Tycon(_, _, tys) -> "type " ^ (tys |> List.map id_of_tycon |> String.concat ", ") - | Val(i, _) -> "val " ^ (string_of_id i) - | Exception(i, _) -> "exception " ^ (string_of_id i) - | NewEffect(DefineEffect(i, _, _, _)) - | NewEffect(RedefineEffect(i, _, _)) -> "new_effect " ^ (string_of_id i) - | LayeredEffect(DefineEffect(i, _, _, _)) - | LayeredEffect(RedefineEffect(i, _, _)) -> "layered_effect " ^ (string_of_id i) - | Polymonadic_bind (l1, l2, l3, _) -> - Util.format3 "polymonadic_bind (%s, %s) |> %s" - (string_of_lid l1) (string_of_lid l2) (string_of_lid l3) - | Polymonadic_subcomp (l1, l2, _) -> - Util.format2 "polymonadic_subcomp %s <: %s" - (string_of_lid l1) (string_of_lid l2) - | Splice (is_typed, ids, t) -> - "splice" ^ (if is_typed then "_t" else "") - ^ "[" - ^ (String.concat ";" <| List.map (fun i -> (string_of_id i)) ids) ^ "] (" ^ term_to_string t ^ ")" - | SubEffect _ -> "sub_effect" - | Pragma p -> "pragma #" ^ string_of_pragma p - | DeclSyntaxExtension (id, content, _, _) -> - "```" ^ id ^ "\n" ^ content ^ "\n```" - | DeclToBeDesugared tbs -> - "(to_be_desugared: " ^ tbs.to_string tbs.blob^ ")" - | UseLangDecls str -> - format1 "#lang-%s" str - | Unparseable -> - "unparseable" - -let modul_to_string (m:modul) = match m with - | Module (_, decls) - | Interface (_, decls, _) -> - decls |> List.map decl_to_string |> String.concat "\n" - -let decl_is_val id decl = - match decl.d with - | Val (id', _) -> - Ident.ident_equals id id' - | _ -> false - -let thunk (ens : term) : term = - let wildpat = mk_pattern (PatWild (None, [])) ens.range in - mk_term (Abs ([wildpat], ens)) ens.range Expr - -let ident_of_binder r b = - match b.b with - | Variable i - | TVariable i - | Annotated (i, _) - | TAnnotated (i, _) -> i - | NoName _ -> - raise_error r Fatal_MissingQuantifierBinder "Wildcard binders in quantifiers are not allowed" - -let idents_of_binders bs r = bs |> List.map (ident_of_binder r) - -instance showable_decl : showable decl = { - show = decl_to_string; -} - -instance showable_term : showable term = { - show = term_to_string; -} - -let add_decorations d decorations = - let decorations = - let attrs, quals = List.partition DeclAttributes? decorations in - let attrs = - match attrs, d.attrs with - | attrs, [] -> attrs - | [DeclAttributes a], attrs -> [DeclAttributes (a @ attrs)] - | [], attrs -> [DeclAttributes attrs] - | _ -> - raise_error d Fatal_MoreThanOneDeclaration - (format2 - "At most one attribute set is allowed on declarations\n got %s;\n and %s" - (String.concat ", " (List.map (function DeclAttributes a -> show a | _ -> "") attrs)) - (String.concat ", " (List.map show d.attrs))) - in - List.map Qualifier d.quals @ - quals @ - attrs - in - let attributes_ = at_most_one "attribute set" d.drange ( - List.choose (function DeclAttributes a -> Some a | _ -> None) decorations - ) in - let attributes_ = Util.dflt [] attributes_ in - let qualifiers = List.choose (function Qualifier q -> Some q | _ -> None) decorations in - { d with quals=qualifiers; attrs=attributes_ } - -let mk_decl d r decorations = - let d = { d=d; drange=r; quals=[]; attrs=[]; interleaved=false } in - add_decorations d decorations - diff --git a/src/parser/FStar.Parser.AST.fsti b/src/parser/FStar.Parser.AST.fsti deleted file mode 100644 index 400674324b9..00000000000 --- a/src/parser/FStar.Parser.AST.fsti +++ /dev/null @@ -1,368 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Parser.AST - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.Range -open FStar.Const -open FStar.Ident -open FStar.Class.Show -open FStar.Class.HasRange - -module S = FStar.Syntax.Syntax -(* AST produced by the parser, before desugaring - It is not stratified: a single type called "term" containing - expressions, formulas, types, and so on - *) -type level = | Un | Expr | Type_level | Kind | Formula - -type let_qualifier = - | NoLetQualifier - | Rec - -type quote_kind = - | Static - | Dynamic - -type term' = - | Wild - | Const of sconst - | Op of ident & list term - | Tvar of ident - | Uvar of ident (* universe variable *) - | Var of lid // a qualified identifier that starts with a lowercase (Foo.Bar.baz) - | Name of lid // a qualified identifier that starts with an uppercase (Foo.Bar.Baz) - | Projector of lid & ident (* a data constructor followed by one of - its formal parameters, or an effect - followed by one of its actions or - "fields" *) - | Construct of lid & list (term&imp) (* data, type: bool in each arg records an implicit *) - | Abs of list pattern & term (* fun p1 p2 .. pn -> body *) - | Function of list branch & range (* function | p1 -> e1 | ... | pn -> en; range is for binder *) - | App of term & term & imp (* aqual marks an explicitly provided implicit parameter *) - | Let of let_qualifier & list (option attributes_ & (pattern & term)) & term - | LetOperator of list (ident & pattern & term) & term - | LetOpen of lid & term - | LetOpenRecord of term & term & term - | Seq of term & term - | Bind of ident & term & term - | If of term & option ident (* is this a regular if or a if operator (i.e. [if*]) *) - & option match_returns_annotation & term & term - | Match of term & option ident (* is this a regular match or a match operator (i.e. [match*]) *) - & option match_returns_annotation & list branch - | TryWith of term & list branch - | Ascribed of term & term & option term & bool (* bool says whether equality ascription $: *) - | Record of option term & list (lid & term) - | Project of term & lid - | Product of list binder & term (* function space *) - | Sum of list (either binder term) & term (* dependent tuple *) - | QForall of list binder & patterns & term - | QExists of list binder & patterns & term - | QuantOp of ident & list binder & patterns & term - | Refine of binder & term - | NamedTyp of ident & term - | Paren of term - | Requires of term & option string - | Ensures of term & option string - | LexList of list term (* a decreases clause mentions either a lexicographically ordered list, *) - | WFOrder of term & term (* or a well-founded relation or some type and an expression of the same type *) - | Decreases of term & option string - | Labeled of term & string & bool - | Discrim of lid (* Some? (formerly is_Some) *) - | Attributes of list term (* attributes decorating a term *) - | Antiquote of term (* Antiquotation within a quoted term *) - | Quote of term & quote_kind - | VQuote of term (* Quoting an lid, this gets removed by the desugarer *) - | CalcProof of term & term & list calc_step (* A calculational proof with relation, initial expression, and steps *) - | IntroForall of list binder & term & term (* intro_forall x1..xn. P with e *) - | IntroExists of list binder & term & list term & term (* intro_exists x1...xn.P using v1..vn with e *) - | IntroImplies of term & term & binder & term (* intro_implies P Q with x. e *) - | IntroOr of bool & term & term & term (* intro_or_{left ,right} P Q with e *) - | IntroAnd of term & term & term & term (* intro_and P Q with e1 and e2 *) - | ElimForall of list binder & term & list term (* elim_forall x1..xn. P using v1..vn *) - | ElimExists of list binder & term & term & binder & term (* elim_exists x1...xn.P to Q with e *) - | ElimImplies of term & term & term (* elim_implies P Q with e *) - | ElimOr of term & term & term & binder & term & binder & term (* elim_or P Q to R with x.e1 and y.e2 *) - | ElimAnd of term & term & term & binder & binder & term (* elim_and P Q to R with x y. e *) - | ListLiteral of list term - | SeqLiteral of list term - - -and term = {tm:term'; range:range; level:level} - - - -(* (as y)? returns t *) -and match_returns_annotation = option ident & term & bool - -and patterns = list ident & list (list term) - -and calc_step = - | CalcStep of term & term & term (* Relation, justification and next expression *) - -and attributes_ = list term - -and binder' = - | Variable of ident - | TVariable of ident - | Annotated of ident & term - | TAnnotated of ident & term - | NoName of term - -and binder = {b:binder'; brange:range; blevel:level; aqual:aqual; battributes:attributes_} - -and pattern' = - | PatWild of aqual & attributes_ - | PatConst of sconst - | PatApp of pattern & list pattern - | PatVar of ident & aqual & attributes_ - | PatName of lid - | PatTvar of ident & aqual & attributes_ - | PatList of list pattern - | PatTuple of list pattern & bool (* dependent if flag is set *) - | PatRecord of list (lid & pattern) - | PatAscribed of pattern & (term & option term) - | PatOr of list pattern - | PatOp of ident - | PatVQuote of term (* [`%foo], transformed into "X.Y.Z.foo" by the desugarer *) -and pattern = {pat:pattern'; prange:range} - -and branch = (pattern & option term & term) -and arg_qualifier = - | Implicit - | Equality - | Meta of term - | TypeClassArg -and aqual = option arg_qualifier -and imp = - | FsTypApp - | Hash - | UnivApp - | HashBrace of term - | Infix - | Nothing - -instance val hasRange_term : hasRange term -instance val hasRange_pattern : hasRange pattern -instance val hasRange_binder : hasRange binder - -type knd = term -type typ = term -type expr = term - -type tycon_record = list (ident & aqual & attributes_ & term) - -(** The different kinds of payload a constructor can carry *) -type constructor_payload - = (** constructor of arity 1 for a type of kind [Type] (e.g. [C of int]) *) - | VpOfNotation of typ - (** constructor of any arity & kind (e.g. [C:int->ind] or [C:'a->'b->ind 'c]) *) - | VpArbitrary of typ - (** constructor whose payload is a record (e.g. [C {a: int}] or [C {x: Type} -> ind x]) *) - | VpRecord of (tycon_record & option typ) - -(* TODO (KM) : it would be useful for the printer to have range information for those *) -type tycon = - | TyconAbstract of ident & list binder & option knd - | TyconAbbrev of ident & list binder & option knd & term - | TyconRecord of ident & list binder & option knd & attributes_ & tycon_record - | TyconVariant of ident & list binder & option knd & list (ident & option constructor_payload & attributes_) - -type qualifier = - | Private - | Noeq - | Unopteq - | Assumption - | DefaultEffect - | TotalEffect - | Effect_qual - | New - | Inline //a definition that *should* always be unfolded by the normalizer - | Visible //a definition that may be unfolded by the normalizer, but only if necessary (default) - | Unfold_for_unification_and_vcgen //a definition that will be unfolded by the normalizer, during unification and for SMT queries - | Inline_for_extraction //a definition that will be inlined only during compilation - | Irreducible //a definition that can never be unfolded by the normalizer - | NoExtract // a definition whose contents won't be extracted (currently, by KaRaMeL only) - | Reifiable - | Reflectable - //old qualifiers - | Opaque - | Logic - -type qualifiers = list qualifier - -type decoration = - | Qualifier of qualifier - | DeclAttributes of list term - -type lift_op = - | NonReifiableLift of term - | ReifiableLift of term & term //lift_wp, lift - | LiftForFree of term - -type lift = { - msource: lid; - mdest: lid; - lift_op: lift_op; - braced: bool; //a detail: for incremental parsing, we need to know if it is delimited by bracces -} - -type pragma = - | ShowOptions - | SetOptions of string - | ResetOptions of option string - | PushOptions of option string - | PopOptions - | RestartSolver - | PrintEffectsGraph - -type dep_scan_callbacks = { - scan_term: term -> unit; - scan_binder: binder -> unit; - scan_pattern: pattern -> unit; - add_lident: lident -> unit; - add_open: lident -> unit; -} - -type to_be_desugared = { - lang_name: string; - blob: FStar.Dyn.dyn; - idents: list ident; - to_string: FStar.Dyn.dyn -> string; - eq: FStar.Dyn.dyn -> FStar.Dyn.dyn -> bool; - dep_scan: dep_scan_callbacks -> FStar.Dyn.dyn -> unit -} - -type decl' = - | TopLevelModule of lid - | Open of lid & FStar.Syntax.Syntax.restriction - | Friend of lid - | Include of lid & FStar.Syntax.Syntax.restriction - | ModuleAbbrev of ident & lid - | TopLevelLet of let_qualifier & list (pattern & term) - | Tycon of bool & bool & list tycon - (* first bool is for effect *) - (* second bool is for typeclass *) - | Val of ident & term (* bool is for logic val *) - | Exception of ident & option term - | NewEffect of effect_decl - | LayeredEffect of effect_decl - | SubEffect of lift - | Polymonadic_bind of lid & lid & lid & term - | Polymonadic_subcomp of lid & lid & term - | Pragma of pragma - | Assume of ident & term - | Splice of bool & list ident & term (* bool is true for a typed splice *) - (* The first range is the entire range of the blob. - The second range is the start point of the extension syntax itself *) - | DeclSyntaxExtension of string & string & range & range - | UseLangDecls of string - | DeclToBeDesugared of to_be_desugared - | Unparseable - -and decl = { - d:decl'; - drange:range; - quals: qualifiers; - attrs: attributes_; - interleaved: bool; -} -and effect_decl = - (* KM : Is there really need of the generality of decl here instead of e.g. lid * term ? *) - | DefineEffect of ident & list binder & term & list decl - | RedefineEffect of ident & list binder & term - -instance val hasRange_decl : hasRange decl - -type modul = - | Module of lid & list decl - | Interface of lid & list decl & bool (* flag to mark admitted interfaces *) -type file = modul -type inputFragment = either file (list decl) - -val lid_of_modul : modul -> lid - -(* Smart constructors *) -val mk_decl : decl' -> range -> list decoration -> decl -val add_decorations: decl -> list decoration -> decl -val mk_binder_with_attrs : binder' -> range -> level -> aqual -> list term -> binder -val mk_binder : binder' -> range -> level -> aqual -> binder -val mk_term : term' -> range -> level -> term - -val mk_uminus : term -> range -> range -> level -> term -val mk_pattern : pattern' -> range -> pattern - -val un_curry_abs : list pattern -> term -> term' -val mk_function : list branch -> range -> range -> term -val un_function : pattern -> term -> option (pattern & term) - -val consPat : range -> pattern -> pattern -> pattern' -val consTerm : range -> term -> term -> term - -val unit_const : range -> term -val ml_comp : term -> term -val tot_comp : term -> term - -val mkApp : term -> list (term & imp) -> range -> term -val mkExplicitApp : term -> list term -> range -> term - -val mkRefSet : range -> list term -> term - -val focusLetBindings : list (bool & (pattern & term)) -> range -> list (pattern & term) -val focusAttrLetBindings : list (option attributes_ & (bool & (pattern & term))) -> range -> list (option attributes_ & (pattern & term)) - -val mkFsTypApp : term -> list term -> range -> term -val mkTuple : list term -> range -> term -val mkDTuple : list term -> range -> term -val mkRefinedBinder : ident -> term -> bool -> option term -> range -> aqual -> list term -> binder -val mkRefinedPattern : pattern -> term -> bool -> option term -> range -> range -> pattern -val extract_named_refinement : bool -> term -> option (ident & term & option term) - -val as_frag : list decl -> inputFragment - -// TODO: Move to something like FStar.Compiler.Util -val strip_prefix : string -> string -> option string - -val compile_op : int -> string -> range -> string -val compile_op' : string -> range -> string -val string_to_op : string -> option (string & option int) // returns operator symbol and optional arity - -val string_of_fsdoc : string & list (string & string) -> string -val string_of_let_qualifier : let_qualifier -> string - -val term_to_string : term -> string - -val lids_of_let : list (pattern & term) -> list lident -val id_of_tycon : tycon -> string - -val string_of_pragma : pragma -> string -val pat_to_string : pattern -> string -val binder_to_string : binder -> string -val modul_to_string : modul -> string - -val decl_is_val : ident -> decl -> bool - -val thunk : term -> term - -val check_id : ident -> unit - -val ident_of_binder : range -> binder -> ident -val idents_of_binders : list binder -> range -> list ident - -instance val showable_decl : showable decl -instance val showable_term : showable term diff --git a/src/parser/FStar.Parser.Const.fst b/src/parser/FStar.Parser.Const.fst deleted file mode 100644 index 4122206203b..00000000000 --- a/src/parser/FStar.Parser.Const.fst +++ /dev/null @@ -1,583 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR C ONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Parser.Const -open FStar.String -open FStar.Compiler.Effect -open FStar.Compiler.Util -open FStar.Ident -open FStar.Compiler.Range -open FStar.Const -open FStar.Compiler.List -module U = FStar.Compiler.Util -module Options = FStar.Options -module List = FStar.Compiler.List - -let p2l l = lid_of_path l dummyRange - -let pconst s = p2l ["Prims";s] -let psconst s = p2l ["FStar"; "Pervasives"; s] -let psnconst s = p2l ["FStar"; "Pervasives" ; "Native" ; s] -let prims_lid = p2l ["Prims"] -let pervasives_native_lid = p2l ["FStar"; "Pervasives"; "Native"] -let pervasives_lid = p2l ["FStar"; "Pervasives"] -let fstar_ns_lid = p2l ["FStar"] - -(* Primitive types *) -let bool_lid = pconst "bool" -let unit_lid = pconst "unit" -let squash_lid = pconst "squash" -let auto_squash_lid = pconst "auto_squash" -let string_lid = pconst "string" -let bytes_lid = pconst "bytes" -let int_lid = pconst "int" -let exn_lid = pconst "exn" -let list_lid = pconst "list" -let immutable_array_t_lid = p2l ["FStar"; "ImmutableArray"; "Base"; "t"] -let immutable_array_of_list_lid = p2l ["FStar"; "ImmutableArray"; "Base"; "of_list"] -let immutable_array_length_lid = p2l ["FStar"; "ImmutableArray"; "Base"; "length"] -let immutable_array_index_lid = p2l ["FStar"; "ImmutableArray"; "Base"; "index"] -let eqtype_lid = pconst "eqtype" -let option_lid = psnconst "option" -let either_lid = psconst "either" -let pattern_lid = psconst "pattern" -let lex_t_lid = pconst "lex_t" -let precedes_lid = pconst "precedes" -let smtpat_lid = psconst "smt_pat" -let smtpatOr_lid = psconst "smt_pat_or" -let monadic_lid = pconst "M" -let spinoff_lid = psconst "spinoff" -let inl_lid = psconst "Inl" -let inr_lid = psconst "Inr" - -let int8_lid = p2l ["FStar"; "Int8"; "t"] -let uint8_lid = p2l ["FStar"; "UInt8"; "t"] -let int16_lid = p2l ["FStar"; "Int16"; "t"] -let uint16_lid = p2l ["FStar"; "UInt16"; "t"] -let int32_lid = p2l ["FStar"; "Int32"; "t"] -let uint32_lid = p2l ["FStar"; "UInt32"; "t"] -let int64_lid = p2l ["FStar"; "Int64"; "t"] -let uint64_lid = p2l ["FStar"; "UInt64"; "t"] -let sizet_lid = p2l ["FStar"; "SizeT"; "t"] - -let salloc_lid = p2l ["FStar"; "ST"; "salloc"] -let swrite_lid = p2l ["FStar"; "ST"; "op_Colon_Equals"] -let sread_lid = p2l ["FStar"; "ST"; "op_Bang"] - -let max_lid = p2l ["max"] - -let real_lid = p2l ["FStar"; "Real"; "real"] - -let float_lid = p2l ["FStar"; "Float"; "float"] - -let char_lid = p2l ["FStar"; "Char"; "char"] - -let heap_lid = p2l ["FStar"; "Heap"; "heap"] - -let logical_lid = pconst "logical" -let prop_lid = pconst "prop" - -let smt_theory_symbol_attr_lid = pconst "smt_theory_symbol" - -let true_lid = pconst "l_True" -let false_lid = pconst "l_False" -let and_lid = pconst "l_and" -let or_lid = pconst "l_or" -let not_lid = pconst "l_not" -let imp_lid = pconst "l_imp" -let iff_lid = pconst "l_iff" -let ite_lid = pconst "l_ITE" -let exists_lid = pconst "l_Exists" -let forall_lid = pconst "l_Forall" -let haseq_lid = pconst "hasEq" -let b2t_lid = pconst "b2t" (* coercion from boolean to type *) -let admit_lid = pconst "admit" -let magic_lid = pconst "magic" -let has_type_lid = pconst "has_type" - -(* Constructive variants *) -let c_true_lid = pconst "trivial" -let empty_type_lid = pconst "empty" -let c_and_lid = pconst "pair" -let c_or_lid = pconst "sum" -let dtuple2_lid = pconst "dtuple2" // for l_Exists - -(* Various equality predicates *) -let eq2_lid = pconst "eq2" -let eq3_lid = pconst "op_Equals_Equals_Equals" -let c_eq2_lid = pconst "equals" - -(* Some common term constructors *) -let cons_lid = pconst "Cons" -let nil_lid = pconst "Nil" -let some_lid = psnconst "Some" -let none_lid = psnconst "None" -let assume_lid = pconst "_assume" -let assert_lid = pconst "_assert" -let pure_wp_lid = pconst "pure_wp" -let pure_wp_monotonic_lid = pconst "pure_wp_monotonic" -let pure_wp_monotonic0_lid = pconst "pure_wp_monotonic0" -let trivial_pure_post_lid = psconst "trivial_pure_post" -let pure_assert_wp_lid = pconst "pure_assert_wp0" -let pure_assume_wp_lid = pconst "pure_assume_wp0" -let assert_norm_lid = p2l ["FStar"; "Pervasives"; "assert_norm"] -(* list_append_lid is needed to desugar @ in the compiler *) -let list_append_lid = p2l ["FStar"; "List"; "append"] -(* list_tot_append_lid is used to desugar @ everywhere else *) -let list_tot_append_lid = p2l ["FStar"; "List"; "Tot"; "Base"; "append"] -let id_lid = psconst "id" - -let seq_cons_lid = p2l ["FStar"; "Seq"; "Base"; "cons"] -let seq_empty_lid = p2l ["FStar"; "Seq"; "Base"; "empty"] - -/// Constants from FStar.Char -let c2l s = p2l ["FStar"; "Char"; s] -let char_u32_of_char = c2l "u32_of_char" - -/// Constants from FStar.String -let s2l n = p2l ["FStar"; "String"; n] -let string_list_of_string_lid = s2l "list_of_string" -let string_string_of_list_lid = s2l "string_of_list" -let string_make_lid = s2l "make" -let string_split_lid = s2l "split" -let string_concat_lid = s2l "concat" -let string_compare_lid = s2l "compare" -let string_lowercase_lid = s2l "lowercase" -let string_uppercase_lid = s2l "uppercase" -let string_index_lid = s2l "index" -let string_index_of_lid = s2l "index_of" -let string_sub_lid = s2l "sub" -let prims_strcat_lid = pconst "strcat" -let prims_op_Hat_lid = pconst "op_Hat" - -let let_in_typ = p2l ["Prims"; "Let"] -let string_of_int_lid = p2l ["Prims"; "string_of_int"] -let string_of_bool_lid = p2l ["Prims"; "string_of_bool"] -let int_of_string_lid = p2l ["FStar"; "Parse"; "int_of_string"] -let bool_of_string_lid = p2l ["FStar"; "Parse"; "bool_of_string"] -let string_compare = p2l ["FStar"; "String"; "compare"] -let order_lid = p2l ["FStar"; "Order"; "order"] -let vconfig_lid = p2l ["FStar"; "Stubs"; "VConfig"; "vconfig"] -let mkvconfig_lid = p2l ["FStar"; "Stubs"; "VConfig"; "Mkvconfig"] - -(* Primitive operators *) -let op_Eq = pconst "op_Equality" -let op_notEq = pconst "op_disEquality" -let op_LT = pconst "op_LessThan" -let op_LTE = pconst "op_LessThanOrEqual" -let op_GT = pconst "op_GreaterThan" -let op_GTE = pconst "op_GreaterThanOrEqual" -let op_Subtraction = pconst "op_Subtraction" -let op_Minus = pconst "op_Minus" -let op_Addition = pconst "op_Addition" -let op_Multiply = pconst "op_Multiply" -let op_Division = pconst "op_Division" -let op_Modulus = pconst "op_Modulus" -let op_And = pconst "op_AmpAmp" -let op_Or = pconst "op_BarBar" -let op_Negation = pconst "op_Negation" -let subtype_of_lid = pconst "subtype_of" - -let real_const s = p2l ["FStar";"Real";s] -let real_op_LT = real_const "op_Less_Dot" -let real_op_LTE = real_const "op_Less_Equals_Dot" -let real_op_GT = real_const "op_Greater_Dot" -let real_op_GTE = real_const "op_Greater_Equals_Dot" -let real_op_Subtraction = real_const "op_Subtraction_Dot" -let real_op_Addition = real_const "op_Plus_Dot" -let real_op_Multiply = real_const "op_Star_Dot" -let real_op_Division = real_const "op_Slash_Dot" -let real_of_int = real_const "of_int" - - -let bvconst s = p2l ["FStar"; "BV"; s] - -(* BitVector constants *) -let bv_t_lid = bvconst "bv_t" //redundant -//let bv_zero_vec_lid = bvconst "bv_zero" -//let bv_ones_vec_lid = bvconst "ones_vec" - -(* BitVector operators *) -let nat_to_bv_lid = bvconst "int2bv" -let bv_to_nat_lid = bvconst "bv2int" -let bv_and_lid = bvconst "bvand" -let bv_xor_lid = bvconst "bvxor" -let bv_or_lid = bvconst "bvor" -let bv_add_lid = bvconst "bvadd" -let bv_sub_lid = bvconst "bvsub" -let bv_shift_left_lid = bvconst "bvshl" -let bv_shift_right_lid = bvconst "bvshr" -let bv_udiv_lid = bvconst "bvdiv" -let bv_mod_lid = bvconst "bvmod" -let bv_mul_lid = bvconst "bvmul" -// shifts, division and multiplication take natural numbers as their second -// arguments, which incurs some encoding overhead. The primed versions bvshl', -// bvshr', bvdiv_unsafe, bvmod_unsafe and bvmul' take a bitvector as the second -// argument instead, which more closely matches SMT-LIB. -let bv_shift_left'_lid = bvconst "bvshl'" -let bv_shift_right'_lid= bvconst "bvshr'" -let bv_udiv_unsafe_lid = bvconst "bvdiv_unsafe" -let bv_mod_unsafe_lid = bvconst "bvmod_unsafe" -let bv_mul'_lid = bvconst "bvmul'" - -let bv_ult_lid = bvconst "bvult" -let bv_uext_lid = bvconst "bv_uext" - -(* Array constants *) -let array_lid = p2l ["FStar"; "Array"; "array"] -let array_of_list_lid = p2l ["FStar"; "Array"; "of_list"] - -(* Stateful constants *) -let st_lid = p2l ["FStar"; "ST"] -let write_lid = p2l ["FStar"; "ST"; "write"] -let read_lid = p2l ["FStar"; "ST"; "read"] -let alloc_lid = p2l ["FStar"; "ST"; "alloc"] -let op_ColonEq = p2l ["FStar"; "ST"; "op_Colon_Equals"] - -(* Constants for sets and ref sets *) -let ref_lid = p2l ["FStar"; "Heap"; "ref"] -let heap_addr_of_lid = p2l ["FStar"; "Heap"; "addr_of"] -let set_empty = p2l ["FStar"; "Set"; "empty"] -let set_singleton = p2l ["FStar"; "Set"; "singleton"] -let set_union = p2l ["FStar"; "Set"; "union"] -let fstar_hyperheap_lid = p2l ["FStar"; "HyperHeap"] -let rref_lid = p2l ["FStar"; "HyperHeap"; "rref"] - -(* Other special constants *) -let erased_lid = p2l ["FStar"; "Ghost"; "erased"] - -(* monad constants *) -let effect_PURE_lid = pconst "PURE" -let effect_Pure_lid = pconst "Pure" -let effect_Tot_lid = pconst "Tot" -let effect_Lemma_lid = psconst "Lemma" -let effect_GTot_lid = pconst "GTot" -let effect_GHOST_lid = pconst "GHOST" -let effect_Ghost_lid = pconst "Ghost" -let effect_DIV_lid = psconst "DIV" -let effect_Div_lid = psconst "Div" -let effect_Dv_lid = psconst "Dv" - -(* The "All" monad and its associated symbols. - -NOTE: With --MLish and --MLish_effect this is somewhat configurable *) - -let ef_base () = - if Options.ml_ish () - then String.split ['.'] <| Options.ml_ish_effect () - else ["FStar"; "All"] - -let effect_ALL_lid () = p2l <| ef_base () @ ["ALL"] -let effect_ML_lid () = p2l <| ef_base () @ ["ML"] -let failwith_lid () = p2l <| ef_base () @ ["failwith"] -let try_with_lid () = p2l <| ef_base () @ ["try_with"] - -let as_requires = pconst "as_requires" -let as_ensures = pconst "as_ensures" -let decreases_lid = pconst "decreases" - -let reveal = p2l ["FStar"; "Ghost"; "reveal"] -let hide = p2l ["FStar"; "Ghost"; "hide"] - -(* FStar.Range *) -let labeled_lid = p2l ["FStar"; "Range"; "labeled"] -let __range_lid = p2l ["FStar"; "Range"; "__range"] -let range_lid = p2l ["FStar"; "Range"; "range"] (* this is a sealed version of the above *) -let range_0 = p2l ["FStar"; "Range"; "range_0"] -let mk_range_lid = p2l ["FStar"; "Range"; "mk_range"] -let __mk_range_lid = p2l ["FStar"; "Range"; "__mk_range"] -let __explode_range_lid = p2l ["FStar"; "Range"; "explode"] -let join_range_lid = p2l ["FStar"; "Range"; "join_range"] - -let guard_free = pconst "guard_free" -let inversion_lid = p2l ["FStar"; "Pervasives"; "inversion"] - -(* Constants for marking terms with normalization hints *) -let normalize = psconst "normalize" -let normalize_term = psconst "normalize_term" -let norm = psconst "norm" - -(* lids for normalizer steps *) -let steps_simpl = psconst "simplify" -let steps_weak = psconst "weak" -let steps_hnf = psconst "hnf" -let steps_primops = psconst "primops" -let steps_zeta = psconst "zeta" -let steps_zeta_full = psconst "zeta_full" -let steps_iota = psconst "iota" -let steps_delta = psconst "delta" -let steps_reify = psconst "reify_" -let steps_norm_debug = psconst "norm_debug" -let steps_unfoldonly = psconst "delta_only" -let steps_unfoldfully = psconst "delta_fully" -let steps_unfoldattr = psconst "delta_attr" -let steps_unfoldqual = psconst "delta_qualifier" -let steps_unfoldnamespace = psconst "delta_namespace" -let steps_unascribe = psconst "unascribe" -let steps_nbe = psconst "nbe" -let steps_unmeta = psconst "unmeta" - -(* attributes *) -let deprecated_attr = pconst "deprecated" -let warn_on_use_attr = pconst "warn_on_use" -let inline_let_attr = p2l ["FStar"; "Pervasives"; "inline_let"] -let rename_let_attr = p2l ["FStar"; "Pervasives"; "rename_let"] -let plugin_attr = p2l ["FStar"; "Pervasives"; "plugin"] -let tcnorm_attr = p2l ["FStar"; "Pervasives"; "tcnorm"] -let dm4f_bind_range_attr = p2l ["FStar"; "Pervasives"; "dm4f_bind_range"] -let must_erase_for_extraction_attr = psconst "must_erase_for_extraction" -let strict_on_arguments_attr = p2l ["FStar"; "Pervasives"; "strict_on_arguments"] -let resolve_implicits_attr_string = "FStar.Pervasives.resolve_implicits" -let unification_tag_lid = psconst "defer_to" -let override_resolve_implicits_handler_lid = p2l ["FStar"; "Pervasives"; "override_resolve_implicits_handler"] -let handle_smt_goals_attr = psconst "handle_smt_goals" -let handle_smt_goals_attr_string = "FStar.Pervasives.handle_smt_goals" -let erasable_attr = p2l ["FStar"; "Pervasives"; "erasable"] -let comment_attr = p2l ["FStar"; "Pervasives"; "Comment"] -let c_inline_attr = p2l ["FStar"; "Pervasives"; "CInline"] -let fail_attr = psconst "expect_failure" -let fail_lax_attr = psconst "expect_lax_failure" -let tcdecltime_attr = psconst "tcdecltime" -let noextract_to_attr = psconst "noextract_to" -let unifier_hint_injective_lid = psconst "unifier_hint_injective" -let normalize_for_extraction_lid = psconst "normalize_for_extraction" -let commute_nested_matches_lid = psconst "commute_nested_matches" -let remove_unused_type_parameters_lid = psconst "remove_unused_type_parameters" -let ite_soundness_by_attr = psconst "ite_soundness_by" -let default_effect_attr = psconst "default_effect" -let top_level_effect_attr = psconst "top_level_effect" -let effect_parameter_attr = psconst "effect_param" -let bind_has_range_args_attr = psconst "bind_has_range_args" -let primitive_extraction_attr = psconst "primitive_extraction" -let binder_strictly_positive_attr = psconst "strictly_positive" -let binder_unused_attr = psconst "unused" -let no_auto_projectors_decls_attr = psconst "no_auto_projectors_decls" -let no_auto_projectors_attr = psconst "no_auto_projectors" -let no_subtping_attr_lid = psconst "no_subtyping" -let admit_termination_lid = psconst "admit_termination" -let unrefine_binder_attr = pconst "unrefine" -let do_not_unrefine_attr = pconst "do_not_unrefine" -let attr_substitute_lid = p2l ["FStar"; "Pervasives"; "Substitute"] -let desugar_of_variant_record_lid = psconst "desugar_of_variant_record" - - -//the type of well-founded relations, used for decreases clauses with relations -let well_founded_relation_lid = p2l ["FStar"; "WellFounded"; "well_founded_relation"] - -let gen_reset = - let x = U.mk_ref 0 in - let gen () = U.incr x; U.read x in - let reset () = U.write x 0 in - gen, reset -let next_id = fst gen_reset - -let sli (l:lident) : string = - if FStar.Options.print_real_names() - then string_of_lid l - else string_of_id (ident_of_lid l) - -let const_to_string x = match x with - | Const_effect -> "Effect" - | Const_unit -> "()" - | Const_bool b -> if b then "true" else "false" - | Const_real r -> r^"R" - | Const_string(s, _) -> U.format1 "\"%s\"" s - | Const_int (x, _) -> x - | Const_char c -> "'" ^ U.string_of_char c ^ "'" - | Const_range r -> FStar.Compiler.Range.string_of_range r - | Const_range_of -> "range_of" - | Const_set_range_of -> "set_range_of" - | Const_reify lopt -> - U.format1 "reify%s" - (match lopt with - | None -> "" - | Some l -> U.format1 "<%s>" (string_of_lid l)) - | Const_reflect l -> U.format1 "[[%s.reflect]]" (sli l) - - -(* Tuples *) - -let mk_tuple_lid n r = - let t = U.format1 "tuple%s" (U.string_of_int n) in - set_lid_range (psnconst t) r - -let lid_tuple2 = mk_tuple_lid 2 dummyRange -let lid_tuple3 = mk_tuple_lid 3 dummyRange -let lid_tuple4 = mk_tuple_lid 4 dummyRange -let lid_tuple5 = mk_tuple_lid 5 dummyRange - -let is_tuple_constructor_string (s:string) :bool = - U.starts_with s "FStar.Pervasives.Native.tuple" - -let is_tuple_constructor_id id = is_tuple_constructor_string (string_of_id id) -let is_tuple_constructor_lid lid = is_tuple_constructor_string (string_of_lid lid) - -let mk_tuple_data_lid n r = - let t = U.format1 "Mktuple%s" (U.string_of_int n) in - set_lid_range (psnconst t) r - -let lid_Mktuple2 = mk_tuple_data_lid 2 dummyRange -let lid_Mktuple3 = mk_tuple_data_lid 3 dummyRange -let lid_Mktuple4 = mk_tuple_data_lid 4 dummyRange -let lid_Mktuple5 = mk_tuple_data_lid 5 dummyRange - -let is_tuple_datacon_string (s:string) :bool = - U.starts_with s "FStar.Pervasives.Native.Mktuple" - -let is_tuple_datacon_id id = is_tuple_datacon_string (string_of_id id) -let is_tuple_datacon_lid lid = is_tuple_datacon_string (string_of_lid lid) - -let is_tuple_data_lid f n = - lid_equals f (mk_tuple_data_lid n dummyRange) - -let is_tuple_data_lid' f = is_tuple_datacon_string (string_of_lid f) - - -(* Dtuples *) - -(* dtuple is defined in prims if n = 2, in pervasives otherwise *) -let mod_prefix_dtuple (n:int) :(string -> lident) = - if n = 2 then pconst else psconst - -let mk_dtuple_lid n r = - let t = U.format1 "dtuple%s" (U.string_of_int n) in - set_lid_range ((mod_prefix_dtuple n) t) r - -let is_dtuple_constructor_string (s:string) :bool = - s = "Prims.dtuple2" || U.starts_with s "FStar.Pervasives.dtuple" - -let is_dtuple_constructor_lid lid = is_dtuple_constructor_string (string_of_lid lid) - -let mk_dtuple_data_lid n r = - let t = U.format1 "Mkdtuple%s" (U.string_of_int n) in - set_lid_range ((mod_prefix_dtuple n) t) r - -let is_dtuple_datacon_string (s:string) :bool = - s = "Prims.Mkdtuple2" || U.starts_with s "FStar.Pervasives.Mkdtuple" - -let is_dtuple_data_lid f n = - lid_equals f (mk_dtuple_data_lid n dummyRange) - -let is_dtuple_data_lid' f = is_dtuple_datacon_string (string_of_lid f) - -let is_name (lid:lident) = - let c = U.char_at (string_of_id (ident_of_lid lid)) 0 in - U.is_upper c - -let term_view_lid = p2l ["FStar"; "Reflection"; "V1"; "Data"; "term_view"] - -(* tactic constants *) -let fstar_tactics_lid' s : lid = FStar.Ident.lid_of_path (["FStar"; "Tactics"]@s) FStar.Compiler.Range.dummyRange -let fstar_stubs_tactics_lid' s : lid = FStar.Ident.lid_of_path (["FStar"; "Stubs"; "Tactics"]@s) FStar.Compiler.Range.dummyRange -let fstar_tactics_lid s = fstar_tactics_lid' [s] -let tac_lid = fstar_tactics_lid' ["Effect"; "tac"] -let tactic_lid = fstar_tactics_lid' ["Effect"; "tactic"] - -let tac_opaque_attr = pconst "tac_opaque" - -let meta_projectors_attr = fstar_tactics_lid' ["MkProjectors"; "meta_projectors"] -let mk_projs_lid = fstar_tactics_lid' ["MkProjectors"; "mk_projs"] - -let mk_class_lid = fstar_tactics_lid' ["Typeclasses"; "mk_class"] -let tcresolve_lid = fstar_tactics_lid' ["Typeclasses"; "tcresolve"] -let tcclass_lid = fstar_tactics_lid' ["Typeclasses"; "tcclass"] -let tcinstance_lid = fstar_tactics_lid' ["Typeclasses"; "tcinstance"] -let no_method_lid = fstar_tactics_lid' ["Typeclasses"; "no_method"] - -let effect_TAC_lid = fstar_tactics_lid' ["Effect"; "TAC"] // actual effect -let effect_Tac_lid = fstar_tactics_lid' ["Effect"; "Tac"] // trivial variant - -let by_tactic_lid = fstar_tactics_lid' ["Effect"; "with_tactic"] -let rewrite_by_tactic_lid = fstar_tactics_lid' ["Effect"; "rewrite_with_tactic"] -let synth_lid = fstar_tactics_lid' ["Effect"; "synth_by_tactic"] -let assert_by_tactic_lid = fstar_tactics_lid' ["Effect"; "assert_by_tactic"] -let fstar_syntax_syntax_term = FStar.Ident.lid_of_str "FStar.Syntax.Syntax.term" -let binder_lid = lid_of_path (["FStar"; "Stubs"; "Reflection"; "Types"; "binder"]) FStar.Compiler.Range.dummyRange -let binders_lid = lid_of_path (["FStar"; "Stubs"; "Reflection"; "Types"; "binders"]) FStar.Compiler.Range.dummyRange -let bv_lid = lid_of_path (["FStar"; "Stubs"; "Reflection"; "Types"; "bv"]) FStar.Compiler.Range.dummyRange -let fv_lid = lid_of_path (["FStar"; "Stubs"; "Reflection"; "Types"; "fv"]) FStar.Compiler.Range.dummyRange -let norm_step_lid = psconst "norm_step" -let postprocess_with = p2l ["FStar"; "Tactics"; "Effect"; "postprocess_with"] -let preprocess_with = p2l ["FStar"; "Tactics"; "Effect"; "preprocess_with"] -let postprocess_extr_with = p2l ["FStar"; "Tactics"; "Effect"; "postprocess_for_extraction_with"] -let term_lid = p2l ["FStar"; "Stubs"; "Reflection"; "Types"; "term"] -let ctx_uvar_and_subst_lid = p2l ["FStar"; "Stubs"; "Reflection"; "Types"; "ctx_uvar_and_subst"] -let universe_uvar_lid = p2l ["FStar"; "Stubs"; "Reflection"; "Types"; "universe_uvar"] -let check_with_lid = lid_of_path (["FStar"; "Stubs"; "VConfig"; "check_with"]) FStar.Compiler.Range.dummyRange - -let decls_lid = p2l ["FStar"; "Stubs"; "Reflection"; "Types"; "decls"] - -// meta dsl constants -let dsl_typing_builtin s = lid_of_path (["FStar"; "Reflection"; "Typing"; "Builtins"]@[s]) FStar.Compiler.Range.dummyRange -let dsl_tac_typ_lid = lid_of_path ["FStar"; "Reflection"; "Typing"; "dsl_tac_t"] FStar.Compiler.Range.dummyRange - - -(* Calculational proofs, from FStar.Calc *) -let calc_lid i : lid = lid_of_path ["FStar"; "Calc"; i] FStar.Compiler.Range.dummyRange -let calc_init_lid = calc_lid "calc_init" -let calc_step_lid = calc_lid "calc_step" -let calc_finish_lid = calc_lid "calc_finish" -let calc_push_impl_lid = calc_lid "calc_push_impl" - -(* Classical proofs, from FStar.Classical *) -let classical_sugar_lid i : lid = lid_of_path ["FStar"; "Classical"; "Sugar"; i] FStar.Compiler.Range.dummyRange - -let forall_intro_lid = classical_sugar_lid "forall_intro" -let exists_intro_lid = classical_sugar_lid "exists_intro" -let implies_intro_lid = classical_sugar_lid "implies_intro" -let or_intro_left_lid = classical_sugar_lid "or_intro_left" -let or_intro_right_lid = classical_sugar_lid "or_intro_right" -let and_intro_lid = classical_sugar_lid "and_intro" - -let forall_elim_lid = classical_sugar_lid "forall_elim" -let exists_elim_lid = classical_sugar_lid "exists_elim" -let implies_elim_lid = classical_sugar_lid "implies_elim" -let or_elim_lid = classical_sugar_lid "or_elim" -let and_elim_lid = classical_sugar_lid "and_elim" - - -let match_returns_def_name = reserved_prefix ^ "_ret_" - -let steel_memory_inv_lid = FStar.Ident.lid_of_path ["Steel"; "Memory"; "inv"] FStar.Compiler.Range.dummyRange - -let steel_new_invariant_lid = FStar.Ident.lid_of_path ["Steel"; "Effect"; "Atomic"; "new_invariant"] FStar.Compiler.Range.dummyRange -let steel_st_new_invariant_lid = FStar.Ident.lid_of_path ["Steel"; "ST"; "Util"; "new_invariant"] FStar.Compiler.Range.dummyRange - -let steel_with_invariant_g_lid = FStar.Ident.lid_of_path ["Steel"; "Effect"; "Atomic"; "with_invariant_g"] FStar.Compiler.Range.dummyRange -let steel_st_with_invariant_g_lid = FStar.Ident.lid_of_path ["Steel"; "ST"; "Util"; "with_invariant_g"] FStar.Compiler.Range.dummyRange - -let steel_with_invariant_lid = FStar.Ident.lid_of_path ["Steel"; "Effect"; "Atomic"; "with_invariant"] FStar.Compiler.Range.dummyRange -let steel_st_with_invariant_lid = FStar.Ident.lid_of_path ["Steel"; "ST"; "Util"; "with_invariant"] FStar.Compiler.Range.dummyRange - - -(* on_domain_lids are constant, so compute them once *) -let fext_lid s = Ident.lid_of_path ["FStar"; "FunctionalExtensionality"; s] FStar.Compiler.Range.dummyRange -let fext_on_domain_lid = fext_lid "on_domain" -let fext_on_dom_lid = fext_lid "on_dom" -let fext_on_domain_g_lid = fext_lid "on_domain_g" -let fext_on_dom_g_lid = fext_lid "on_dom_g" - -let sealed_lid = p2l ["FStar"; "Sealed"; "sealed"] -let seal_lid = p2l ["FStar"; "Sealed"; "seal"] -let unseal_lid = p2l ["FStar"; "Tactics"; "Unseal"; "unseal"] (* In a separate module due to the mention of TAC *) -let map_seal_lid = p2l ["FStar"; "Sealed"; "map_seal"] -let bind_seal_lid = p2l ["FStar"; "Sealed"; "bind_seal"] -let tref_lid = p2l ["FStar"; "Stubs"; "Tactics"; "Types"; "tref"] - -let document_lid = p2l ["FStar"; "Stubs"; "Pprint"; "document"] -let issue_lid = p2l ["FStar"; "Issue"; "issue"] - -let extract_as_lid = p2l ["FStar"; "ExtractAs"; "extract_as"] -let extract_as_impure_effect_lid = p2l ["FStar"; "Pervasives"; "extract_as_impure_effect"] diff --git a/src/parser/FStar.Parser.Dep.fst b/src/parser/FStar.Parser.Dep.fst deleted file mode 100644 index b7073a4c42b..00000000000 --- a/src/parser/FStar.Parser.Dep.fst +++ /dev/null @@ -1,2075 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - - See the License for the specific language governing permissions and - limitations under the License. -*) - -(** This module provides an ocamldep-like tool for F*, invoked with [fstar --dep]. - Unlike ocamldep, it outputs the transitive closure of the dependency graph - of a given file. The dependencies that are output are *compilation units* - (not module names). -*) -module FStar.Parser.Dep - -open FStar.Pervasives -open FStar.Compiler.Effect //for ref, failwith etc -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.Parser -open FStar.Parser.AST -open FStar.Compiler.Util -open FStar.Const -open FStar.String -open FStar.Ident -open FStar.Errors -open FStar.Class.Show - -module Const = FStar.Parser.Const -module BU = FStar.Compiler.Util - -let dbg = Debug.get_toggle "Dep" -let dbg_CheckedFiles = Debug.get_toggle "CheckedFiles" - -let profile f c = Profiling.profile f None c - -(* Meant to write to a file as an out_channel. If an exception is raised, -the file is deleted. *) -let with_file_outchannel (fn : string) (k : out_channel -> 'a) : 'a = - let outc = BU.open_file_for_writing fn in - let r = - try k outc - with | e -> BU.close_out_channel outc; BU.delete_file fn; raise e - in - BU.close_out_channel outc; - r - -(* In case the user passed [--verify_all], we record every single module name we - * found in the list of modules to be verified. - * In the [VerifyUserList] case, for every [--verify_module X], we check we - * indeed find a module [X]. - * In the [VerifyFigureItOut] case, for every file that was on the command-line, - * we record its module name as one module to be verified. - *) -type verify_mode = - | VerifyAll - | VerifyUserList - | VerifyFigureItOut - -type intf_and_impl = option string & option string - -type files_for_module_name = smap intf_and_impl - -let intf_and_impl_to_string ii = - match ii with - | None, None -> ", " - | Some intf, None -> intf - | None, Some impl -> impl - | Some intf, Some impl -> intf ^ ", " ^ impl - - -let files_for_module_name_to_string (m:files_for_module_name) = - BU.print_string "Printing the file system map {\n"; - let str_opt_to_string sopt = - match sopt with - | None -> "" - | Some s -> s in - smap_iter m (fun k v -> BU.print2 "%s:%s\n" k (intf_and_impl_to_string v)); - BU.print_string "}\n" - -type color = | White | Gray | Black - -let check_and_strip_suffix (f: string): option string = - let suffixes = [ ".fsti"; ".fst"; ".fsi"; ".fs" ] in - let matches = List.map (fun ext -> - let lext = String.length ext in - let l = String.length f in - if l > lext && String.substring f (l - lext) lext = ext then - Some (String.substring f 0 (l - lext)) - else - None - ) suffixes in - match List.filter is_some matches with - | Some m :: _ -> - Some m - | _ -> - None - -(* In public interface *) -let is_interface (f: string): bool = - String.get f (String.length f - 1) = 'i' - -(* In public interface *) -let is_implementation f = - not (is_interface f) - - -let list_of_option = function Some x -> [x] | None -> [] - -let list_of_pair (intf, impl) = - list_of_option intf @ list_of_option impl - -(* In public interface *) -let maybe_module_name_of_file f = check_and_strip_suffix (basename f) -let module_name_of_file f = - match maybe_module_name_of_file f with - | Some longname -> - longname - | None -> - raise_error0 Errors.Fatal_NotValidFStarFile (Util.format1 "Not a valid FStar file: '%s'" f) - -(* In public interface *) -let lowercase_module_name f = String.lowercase (module_name_of_file f) - -let namespace_of_module f = - let lid = FStar.Ident.lid_of_path (FStar.Ident.path_of_text f) Range.dummyRange in - match ns_of_lid lid with - | [] -> None - | ns -> Some (FStar.Ident.lid_of_ids ns) - -type file_name = string -type dependence = - | UseInterface of module_name - | PreferInterface of module_name - | UseImplementation of module_name - | FriendImplementation of module_name -let dep_to_string = function - | UseInterface f -> "UseInterface " ^ f - | PreferInterface f -> "PreferInterface " ^ f - | UseImplementation f -> "UseImplementation " ^ f - | FriendImplementation f -> "FriendImplementation " ^ f -instance showable_dependence : showable dependence = { - show = dep_to_string; -} - -type dependences = list dependence -let empty_dependences = [] -type dep_node = { - edges:dependences; - color:color -} -type dependence_graph = //maps file names to the modules it depends on - | Deps of smap dep_node //(dependences * color)> - -(* - * AR: Parsing data for a file (also cached in the checked files) - * It is a summary of opens, includes, A., etc. in a module - * Earlier we used to store the dependences in the checked file, - * however that is an image of the file system, and so, when the checked - * files were used in a slightly different file system, there were strange errors - * see e.g. #1657 for a couple of cases - * Now we store the following summary and construct the dependences from the current - * file system - *) -type parsing_data_elt = - | P_begin_module of lident //begin_module - | P_open of bool & lident //record_open - | P_implicit_open_module_or_namespace of (open_kind & lid) //record_open_module_or_namespace - | P_dep of bool & lident //add_dep_on_module, bool=true iff it's a friend dependency - | P_alias of ident & lident //record_module_alias - | P_lid of lident //record_lid - | P_inline_for_extraction - -type parsing_data = - | Mk_pd of list parsing_data_elt - -let str_of_parsing_data_elt elt = - let str_of_open_kind = function - | Open_module -> "P_open_module" - | Open_namespace -> "P_open_namespace" - in - match elt with - | P_begin_module lid -> "P_begin_module (" ^ (string_of_lid lid) ^ ")" - | P_open (b, lid) -> "P_open (" ^ (string_of_bool b) ^ ", " ^ (string_of_lid lid) ^ ")" - | P_implicit_open_module_or_namespace (k, lid) -> "P_implicit_open_module_or_namespace (" ^ (str_of_open_kind k) ^ ", " ^ (string_of_lid lid) ^ ")" - | P_dep (b, lid) -> "P_dep (" ^ (string_of_lid lid) ^ ", " ^ (string_of_bool b) ^ ")" - | P_alias (id, lid) -> "P_alias (" ^ (string_of_id id) ^ ", " ^ (string_of_lid lid) ^ ")" - | P_lid lid -> "P_lid (" ^ (string_of_lid lid) ^ ")" - | P_inline_for_extraction -> "P_inline_for_extraction" - -let str_of_parsing_data = function - | Mk_pd l -> - l |> List.fold_left (fun s elt -> s ^ "; " ^ (elt |> str_of_parsing_data_elt)) "" - -let friends (p:parsing_data) : list lident = - let Mk_pd p = p in - List.collect - (function - | P_dep (true, l) -> [l] - | _ -> []) - p - - -let parsing_data_elt_eq (e1:parsing_data_elt) (e2:parsing_data_elt) = - match e1, e2 with - | P_begin_module l1, P_begin_module l2 -> lid_equals l1 l2 - | P_open (b1, l1), P_open (b2, l2) -> b1 = b2 && lid_equals l1 l2 - | P_implicit_open_module_or_namespace (k1, l1), P_implicit_open_module_or_namespace (k2, l2) -> - k1 = k2 && lid_equals l1 l2 - | P_dep (b1, l1), P_dep (b2, l2) -> b1 = b2 && lid_equals l1 l2 - | P_alias (i1, l1), P_alias (i2, l2) -> string_of_id i1 = string_of_id i2 && lid_equals l1 l2 - | P_lid l1, P_lid l2 -> lid_equals l1 l2 - | P_inline_for_extraction, P_inline_for_extraction -> true - | _, _ -> false - -let empty_parsing_data = Mk_pd [] - -type deps = { - dep_graph:dependence_graph; //dependences of the entire project, not just those reachable from the command line - file_system_map:files_for_module_name; //an abstraction of the file system, keys are lowercase module names - cmd_line_files:list file_name; //all command-line files - all_files:list file_name; //all files - interfaces_with_inlining:list module_name; //interfaces that use `inline_for_extraction` require inlining - parse_results:smap parsing_data //map from filenames to parsing_data - //callers (Universal.fs) use this to get the parsing data for caching purposes -} -let deps_try_find (Deps m) k = BU.smap_try_find m k -let deps_add_dep (Deps m) k v = - BU.smap_add m k v -let deps_keys (Deps m) = BU.smap_keys m -let deps_empty () = Deps (BU.smap_create 41) -let mk_deps dg fs c a i pr = { - dep_graph=dg; - file_system_map=fs; - cmd_line_files=c; - all_files=a; - interfaces_with_inlining=i; - parse_results=pr; -} -(* In public interface *) -let empty_deps = mk_deps (deps_empty ()) (BU.smap_create 0) [] [] [] (BU.smap_create 0) -let module_name_of_dep = function - | UseInterface m - | PreferInterface m - | UseImplementation m - | FriendImplementation m -> m - -let resolve_module_name (file_system_map:files_for_module_name) (key:module_name) - : option module_name - = match BU.smap_try_find file_system_map key with - | Some (Some fn, _) - | Some (_, Some fn) -> Some (lowercase_module_name fn) - | _ -> None - -let interface_of_internal (file_system_map:files_for_module_name) (key:module_name) - : option file_name = - match BU.smap_try_find file_system_map key with - | Some (Some iface, _) -> Some iface - | _ -> None - -let implementation_of_internal (file_system_map:files_for_module_name) (key:module_name) - : option file_name = - match BU.smap_try_find file_system_map key with - | Some (_, Some impl) -> Some impl - | _ -> None - -let interface_of deps key = interface_of_internal deps.file_system_map key -let implementation_of deps key = implementation_of_internal deps.file_system_map key - -let has_interface (file_system_map:files_for_module_name) (key:module_name) - : bool = - Option.isSome (interface_of_internal file_system_map key) - -let has_implementation (file_system_map:files_for_module_name) (key:module_name) - : bool = - Option.isSome (implementation_of_internal file_system_map key) - - -(* - * Public interface - *) -let cache_file_name = - let checked_file_and_exists_flag fn = - let cache_fn = - let lax = Options.lax () in - if lax then fn ^".checked.lax" - else fn ^".checked" - in - let mname = fn |> module_name_of_file in - match Find.find_file (cache_fn |> Util.basename) with - | Some path -> - let expected_cache_file = Options.prepend_cache_dir cache_fn in - if Option.isSome (Options.dep()) //if we're in the dependence analysis - && not (Options.should_be_already_cached mname) //and checked file is in the - && (not (BU.file_exists expected_cache_file) //wrong spot ... complain - || not (BU.paths_to_same_file path expected_cache_file)) - then ( - let open FStar.Pprint in - let open FStar.Errors.Msg in - log_issue0 FStar.Errors.Warning_UnexpectedCheckedFile [ - text "Did not expect module" ^/^ doc_of_string mname ^/^ text "to be already checked."; - prefix 2 1 (text "Found it in an unexpected location:") - (doc_of_string path) ^/^ - prefix 2 1 (text "instead of") - (doc_of_string expected_cache_file); - ] - ); - - (* This expression morally just returns [path], but prefers - * the path in [expected_cache_file] is possible to give - * preference to relative filenames. This is mostly since - * GNU make doesn't resolve paths in targets, so we try - * to keep target paths relative. See issue #1978. *) - if BU.file_exists expected_cache_file && BU.paths_to_same_file path expected_cache_file - then expected_cache_file - else path - | None -> - if !dbg_CheckedFiles then - BU.print1 "find_file(%s) returned None\n" (cache_fn |> Util.basename); - if mname |> Options.should_be_already_cached then - raise_error0 FStar.Errors.Error_AlreadyCachedAssertionFailure [ - text (BU.format1 "Expected %s to be already checked but could not find it." mname) - ]; - FStar.Options.prepend_cache_dir cache_fn - in - let memo = Util.smap_create 100 in - let memo f x = - match Util.smap_try_find memo x with - | Some res -> res - | None -> - let res = f x in - Util.smap_add memo x res; - res - in - memo checked_file_and_exists_flag - -let parsing_data_of deps fn = BU.smap_try_find deps.parse_results fn |> must - -let file_of_dep_aux - (use_checked_file:bool) - (file_system_map:files_for_module_name) - (all_cmd_line_files:list file_name) - (d:dependence) - : file_name = - let cmd_line_has_impl key = - all_cmd_line_files - |> BU.for_some (fun fn -> - is_implementation fn && - key = lowercase_module_name fn) - in - - let maybe_use_cache_of f = if use_checked_file then cache_file_name f else f in - - match d with - | UseInterface key -> - //This key always resolves to an interface source file - (match interface_of_internal file_system_map key with - | None -> - assert false; //should be unreachable; see the only use of UseInterface in discover_one - raise_error0 Errors.Fatal_MissingInterface (BU.format1 "Expected an interface for module %s, but couldn't find one" key) - | Some f -> - f) - - | PreferInterface key //key for module 'a' - when has_interface file_system_map key -> //so long as 'a.fsti' exists - if cmd_line_has_impl key //unless the cmd line contains 'a.fst' - && Option.isNone (Options.dep()) //and we're not just doing a dependency scan using `--dep _` - then if Options.expose_interfaces() - then maybe_use_cache_of (Option.get (implementation_of_internal file_system_map key)) - else raise_error0 Errors.Fatal_MissingExposeInterfacesOption [ - text <| BU.format3 "You may have a cyclic dependence on module %s: use --dep full to confirm. \ - Alternatively, invoking fstar with %s on the command line breaks \ - the abstraction imposed by its interface %s." - key - (Option.get (implementation_of_internal file_system_map key)) - (Option.get (interface_of_internal file_system_map key)); - text "If you really want this behavior add the option '--expose_interfaces'."; - ] - else maybe_use_cache_of (Option.get (interface_of_internal file_system_map key)) //we prefer to use 'a.fsti' - - | PreferInterface key - | UseImplementation key - | FriendImplementation key -> - match implementation_of_internal file_system_map key with - | None -> - //if d is actually an edge in the dep_graph computed by discover - //then d is only present if either an interface or an implementation exist - //the previous case already established that the interface doesn't exist - // since if the implementation was on the command line, it must exist because of option validation - raise_error0 Errors.Fatal_MissingImplementation - (BU.format1 "Expected an implementation of module %s, but couldn't find one" key) - | Some f -> maybe_use_cache_of f - -let file_of_dep = file_of_dep_aux false - -let dependences_of (file_system_map:files_for_module_name) - (deps:dependence_graph) - (all_cmd_line_files:list file_name) - (fn:file_name) - : list file_name = - match deps_try_find deps fn with - | None -> empty_dependences - | Some ({edges=deps}) -> - List.map (file_of_dep file_system_map all_cmd_line_files) deps - |> List.filter (fun k -> k <> fn) (* skip current module, cf #451 *) - -let print_graph (outc : out_channel) (fn : string) (graph:dependence_graph) = - if not (Options.silent ()) then begin - Util.print1 "A DOT-format graph has been dumped in the current directory as `%s`\n" fn; - Util.print1 "With GraphViz installed, try: fdp -Tpng -odep.png %s\n" fn; - Util.print1 "Hint: cat %s | grep -v _ | grep -v prims\n" fn - end; - let s = - "digraph {\n" ^ - String.concat "\n" (List.collect - (fun k -> - let deps = (must (deps_try_find graph k)).edges in - let r s = replace_char s '.' '_' in - let print dep = - Util.format2 " \"%s\" -> \"%s\"" - (r (lowercase_module_name k)) - (r (module_name_of_dep dep)) - in - List.map print deps) - (List.unique (deps_keys graph))) ^ - "\n}\n" - in - fprint outc "%s" [s] - -let safe_readdir_for_include (d:string) : list string = - try readdir d - with - | _ -> - let open FStar.Pprint in - log_issue0 Errors.Fatal_NotValidIncludeDirectory [ - prefix 2 1 (text "Not a valid include directory:") - (doc_of_string d); - ]; - [] - -(** Enumerate all F* files in include directories. - Return a list of pairs of long names and full paths. *) -(* In public interface *) -let build_inclusion_candidates_list (): list (string & string) = - let include_directories = Options.include_path () in - let include_directories = List.map normalize_file_path include_directories in - (* Note that [BatList.unique] keeps the last occurrence, that way one can - * always override the precedence order. *) - let include_directories = List.unique include_directories in - let cwd = normalize_file_path (getcwd ()) in - include_directories |> List.concatMap (fun d -> - let files = safe_readdir_for_include d in - files |> List.filter_map (fun f -> - let f = basename f in - check_and_strip_suffix f - |> Util.map_option (fun longname -> - let full_path = if d = cwd then f else join_paths d f in - (longname, full_path)) - ) - ) - -(** List the contents of all include directories, then build a map from long - names (e.g. a.b) to pairs of filenames (/path/to/A.B.fst). Long names are - all normalized to lowercase. The first component of the pair is the - interface (if any). The second component of the pair is the implementation - (if any). *) -let build_map (filenames: list string): files_for_module_name = - let map = smap_create 41 in - let add_entry key full_path = - match smap_try_find map key with - | Some (intf, impl) -> - if is_interface full_path then - smap_add map key (Some full_path, impl) - else - smap_add map key (intf, Some full_path) - | None -> - if is_interface full_path then - smap_add map key (Some full_path, None) - else - smap_add map key (None, Some full_path) - in - - (* Add files from all include directories *) - List.iter (fun (longname, full_path) -> - add_entry (String.lowercase longname) full_path - ) (build_inclusion_candidates_list ()); - (* All the files we've been given on the command-line must be valid FStar files. *) - List.iter (fun f -> - add_entry (lowercase_module_name f) f - ) filenames; - map - -let string_of_lid (l: lident) (last: bool) = - let suffix = if last then [ (string_of_id (ident_of_lid l)) ] else [ ] in - let names = List.map (fun x -> (string_of_id x)) (ns_of_lid l) @ suffix in - String.concat "." names - -(** All the components of a [lident] joined by "." (the last component of the - * lident is included iff [last = true]). *) -let lowercase_join_longident (l: lident) (last: bool) = - String.lowercase (string_of_lid l last) - -let namespace_of_lid l = - String.concat "_" (List.map string_of_id (ns_of_lid l)) - -let check_module_declaration_against_filename (lid: lident) (filename: string): unit = - let k' = string_of_lid lid true in - if must (check_and_strip_suffix (basename filename)) <> k' then - log_issue lid Errors.Error_ModuleFileNameMismatch [ - Errors.Msg.text (Util.format2 "The module declaration \"module %s\" \ - found in file %s does not match its filename." (string_of_lid lid true) filename); - Errors.Msg.text "Dependencies will be incorrect and the module will not be verified."; - ] - -exception Exit - -(* In public interface *) - -let core_modules () = - [Basefiles.prims_basename () ; - Basefiles.pervasives_basename () ; - Basefiles.pervasives_native_basename ()] - |> List.map module_name_of_file - -let implicit_ns_deps = - [ Const.fstar_ns_lid ] - -let implicit_module_deps = - [ Const.prims_lid; Const.pervasives_lid ] - -let hard_coded_dependencies full_filename = - let filename : string = basename full_filename in - - let implicit_module_deps = List.map (fun l -> l, Open_module) implicit_module_deps in - let implicit_ns_deps = List.map (fun l -> l, Open_namespace) implicit_ns_deps in - - (* The core libraries do not have any implicit dependencies *) - if List.mem (module_name_of_file filename) (core_modules ()) then [] - else match namespace_of_module (module_name_of_file full_filename) with - | None -> implicit_ns_deps @ implicit_module_deps - (* - * AR: we open FStar, and then ns - * which means that enter_namespace will be called first for F*, and then for ns - * giving precedence to My.M over FStar.M - *) - | Some ns -> implicit_ns_deps @ implicit_module_deps @ [(ns, Open_namespace)] - -let dep_subsumed_by d d' = - match d, d' with - | PreferInterface l', FriendImplementation l -> l=l' - | _ -> d = d' - -(** For all items [i] in the map that start with [prefix], add an additional - entry where [i] stripped from [prefix] points to the same value. Returns a - boolean telling whether the map was modified. - - If the open is an implicit open (as indicated by the flag), - and doing so shadows an existing entry, warn! *) -let enter_namespace - (original_map: files_for_module_name) - (working_map: files_for_module_name) - (sprefix: string) - (implicit_open:bool) : bool = - let found = BU.mk_ref false in - let sprefix = sprefix ^ "." in - let suffix_exists mopt = - match mopt with - | None -> false - | Some (intf, impl) -> is_some intf || is_some impl in - smap_iter original_map (fun k _ -> - if Util.starts_with k sprefix then - let suffix = - String.substring k (String.length sprefix) (String.length k - String.length sprefix) - in - - begin - let suffix_filename = smap_try_find original_map suffix in - if implicit_open && - suffix_exists suffix_filename - then let str = suffix_filename |> must |> intf_and_impl_to_string in - let open FStar.Pprint in - log_issue0 Errors.Warning_UnexpectedFile [ - flow (break_ 1) [ - text "Implicitly opening namespace"; - squotes (doc_of_string sprefix); - text "shadows module"; - squotes (doc_of_string suffix); - text "in file"; - dquotes (doc_of_string str) ^^ dot; - ]; - text "Rename" ^/^ dquotes (doc_of_string str) ^/^ text "to avoid conflicts."; - ] - end; - - let filename = must (smap_try_find original_map k) in - smap_add working_map suffix filename; - found := true - ); - !found - -(* - * Get parsing data for a file - * First see if the data in the checked file is good (using the provided callback) - * If it is, return that - * - * Else parse the file, walk its AST, return a list of FStar lowercased module names - it depends on - *) - -let collect_one - (original_map: files_for_module_name) - (filename: string) - (get_parsing_data_from_cache:string -> option parsing_data) - : parsing_data & - list dependence & //direct dependence - bool & //has_inline_for_extraction - list dependence //additional roots - //that used to be part of parsing_data earlier - //removing it from the cache (#1657) - //this always returns a single element, remove the list? -= - (* - * Construct dependences from the parsing data - * This is common function for when the parsing data is read from the checked files - * or constructed after AST traversal of the module - *) - let from_parsing_data (pd:parsing_data) (original_map:files_for_module_name) (filename:string) - : list dependence & - bool & - list dependence - = let deps : ref (list dependence) = BU.mk_ref [] in - let has_inline_for_extraction = BU.mk_ref false in - - - let mo_roots = - let mname = lowercase_module_name filename in - if is_interface filename - && has_implementation original_map mname - then [ UseImplementation mname ] - else [] - in - - let auto_open = hard_coded_dependencies filename |> List.map (fun (lid, k) -> - P_implicit_open_module_or_namespace (k, lid)) - in - - let working_map = smap_copy original_map in - - let set_interface_inlining () = - if is_interface filename - then has_inline_for_extraction := true - in - - let add_dep deps d = - if not (List.existsML (dep_subsumed_by d) !deps) then - deps := d :: !deps - in - - let dep_edge module_name is_friend = - if is_friend then FriendImplementation module_name - else PreferInterface module_name - in - - let add_dependence_edge original_or_working_map lid is_friend = - let key = lowercase_join_longident lid true in - match resolve_module_name original_or_working_map key with - | Some module_name -> - add_dep deps (dep_edge module_name is_friend); - true - | _ -> - false - in - - let record_open_module let_open lid = - //use the original_map here - //since the working_map will resolve lid while accounting - //for already opened namespaces - //if let_open, then this is the form `UInt64.( ... )` - // where UInt64 can resolve to FStar.UInt64 - // So, use the working map, accounting for opened namespaces - //Otherwise, this is the form `open UInt64`, - // where UInt64 must resolve to either - // a module or a namespace for F# compatibility - // So, use the original map, disregarding opened namespaces - if (let_open && add_dependence_edge working_map lid false) - || (not let_open && add_dependence_edge original_map lid false) - then true - else begin - if let_open then - log_issue lid Errors.Warning_ModuleOrFileNotFoundWarning - (Util.format1 "Module not found: %s" (string_of_lid lid true)); - false - end - in - - let record_open_namespace lid (implicit_open:bool) = - let key = lowercase_join_longident lid true in - let r = enter_namespace original_map working_map key implicit_open in - if not r && not implicit_open then //suppress the warning for implicit opens - log_issue lid Errors.Warning_ModuleOrFileNotFoundWarning - (Util.format1 "No modules in namespace %s and no file with that name either" (string_of_lid lid true)) - in - - let record_open let_open lid = - if record_open_module let_open lid - then () - else if not let_open //syntactically, this cannot be a namespace if let_open is true; so don't retry - then record_open_namespace lid false - in - - let record_implicit_open_module_or_namespace (lid, kind) = - match kind with - | Open_namespace -> record_open_namespace lid true - | Open_module -> let _ = record_open_module false lid in () - in - - let record_module_alias ident lid = - let key = String.lowercase (string_of_id ident) in - let alias = lowercase_join_longident lid true in - // Only fully qualified module aliases are allowed. - match smap_try_find original_map alias with - | Some deps_of_aliased_module -> - smap_add working_map key deps_of_aliased_module; - add_dep deps (dep_edge (lowercase_join_longident lid true) false); - true - | None -> - log_issue lid Errors.Warning_ModuleOrFileNotFoundWarning - (Util.format1 "module not found in search path: %s" alias); - false - in - - let add_dep_on_module (module_name : lid) (is_friend : bool) = - if add_dependence_edge working_map module_name is_friend - then () - else if !dbg then - log_issue module_name Errors.Warning_UnboundModuleReference - (BU.format1 "Unbound module reference %s" (show module_name)) - in - - let record_lid lid = - (* Thanks to the new `?.` and `.(` syntaxes, `lid` is no longer a - module name itself, so only its namespace part is to be - recorded as a module dependency. *) - match ns_of_lid lid with - | [] -> () - | ns -> - let module_name = Ident.lid_of_ids ns in - add_dep_on_module module_name false - in - - let begin_module lid = - if List.length (ns_of_lid lid) > 0 then - ignore (enter_namespace original_map working_map (namespace_of_lid lid)) - in - - (* - * Iterate over the parsing data elements - *) - begin - match pd with - | Mk_pd l -> - (auto_open @ l) |> List.iter (fun elt -> - match elt with - | P_begin_module lid -> begin_module lid - | P_open (b, lid) -> record_open b lid - | P_implicit_open_module_or_namespace (k, lid) -> record_implicit_open_module_or_namespace (lid, k) - | P_dep (b, lid) -> add_dep_on_module lid b - | P_alias (id, lid) -> ignore (record_module_alias id lid) - | P_lid lid -> record_lid lid - | P_inline_for_extraction -> set_interface_inlining ()) - end; - (* - * And then return the dependences - *) - !deps, - !has_inline_for_extraction, - mo_roots - in - - let data_from_cache = filename |> get_parsing_data_from_cache in - - if data_from_cache |> is_some then begin //we found the parsing data in the checked file - let deps, has_inline_for_extraction, mo_roots = from_parsing_data (data_from_cache |> must) original_map filename in - if !dbg then - BU.print2 "Reading the parsing data for %s from its checked file .. found [%s]\n" filename (show deps); - data_from_cache |> must, - deps, has_inline_for_extraction, mo_roots - end - else - //parse the file and traverse the AST to collect parsing data - let num_of_toplevelmods = BU.mk_ref 0 in - let pd : ref (list parsing_data_elt) = BU.mk_ref [] in - - let add_to_parsing_data elt = - if not (List.existsML (fun e -> parsing_data_elt_eq e elt) !pd) - then pd := elt::!pd - in - - let rec collect_module = function - | Module (lid, decls) - | Interface (lid, decls, _) -> - check_module_declaration_against_filename lid filename; - add_to_parsing_data (P_begin_module lid); - collect_decls decls - - and collect_decls decls = - List.iter (fun x -> collect_decl x.d; - List.iter collect_term x.attrs; - match x.d with - | _ when List.contains Inline_for_extraction x.quals -> - add_to_parsing_data P_inline_for_extraction - | _ -> () - ) decls - - and collect_decl d = - match d with - | Include (lid, _) - | Open (lid, _) -> - add_to_parsing_data (P_open (false, lid)) - | Friend lid -> - add_to_parsing_data (P_dep (true, (lowercase_join_longident lid true |> Ident.lid_of_str))) - | ModuleAbbrev (ident, lid) -> - add_to_parsing_data (P_alias (ident, lid)) - | TopLevelLet (_, patterms) -> - List.iter (fun (pat, t) -> collect_pattern pat; collect_term t) patterms - | Splice (_, _, t) - | Assume (_, t) - | SubEffect { lift_op = NonReifiableLift t } - | SubEffect { lift_op = LiftForFree t } - | Val (_, t) -> - collect_term t - | SubEffect { lift_op = ReifiableLift (t0, t1) } -> - collect_term t0; - collect_term t1 - | Tycon (_, tc, ts) -> - begin - if tc then - add_to_parsing_data (P_lid Const.tcclass_lid); - List.iter collect_tycon ts - end - | Exception (_, t) -> - iter_opt t collect_term - | NewEffect ed - | LayeredEffect ed -> - collect_effect_decl ed - - | Polymonadic_bind (_, _, _, t) - | Polymonadic_subcomp (_, _, t) -> collect_term t //collect deps from the effect lids? - - | DeclToBeDesugared tbs -> - tbs.dep_scan - { scan_term = collect_term; - scan_binder = collect_binder; - scan_pattern = collect_pattern; - add_lident = (fun lid -> add_to_parsing_data (P_lid lid)); - add_open = (fun lid -> add_to_parsing_data (P_open (true, lid))) - } - tbs.blob - - | UseLangDecls _ - | Pragma _ - | DeclSyntaxExtension _ - | Unparseable -> - () - | TopLevelModule lid -> - incr num_of_toplevelmods; - if (!num_of_toplevelmods > 1) then - raise_error lid Errors.Fatal_OneModulePerFile - (Util.format1 "Automatic dependency analysis demands one module per file (module %s not supported)" (string_of_lid lid true)) - and collect_tycon = function - | TyconAbstract (_, binders, k) -> - collect_binders binders; - iter_opt k collect_term - | TyconAbbrev (_, binders, k, t) -> - collect_binders binders; - iter_opt k collect_term; - collect_term t - | TyconRecord (_, binders, k, _, identterms) -> - collect_binders binders; - iter_opt k collect_term; - collect_tycon_record identterms - | TyconVariant (_, binders, k, identterms) -> - collect_binders binders; - iter_opt k collect_term; - List.iter ( function - | VpOfNotation t | VpArbitrary t -> collect_term t - | VpRecord (record, t) -> collect_tycon_record record; - iter_opt t collect_term - ) (List.filter_map Mktuple3?._2 identterms) - - and collect_tycon_record r = - List.iter (fun (_, aq, attrs, t) -> - collect_aqual aq; - attrs |> List.iter collect_term; - collect_term t) r - - and collect_effect_decl = function - | DefineEffect (_, binders, t, decls) -> - collect_binders binders; - collect_term t; - collect_decls decls - | RedefineEffect (_, binders, t) -> - collect_binders binders; - collect_term t - - and collect_binders binders = - List.iter collect_binder binders - - and collect_binder b = - collect_aqual b.aqual; - b.battributes |> List.iter collect_term; - match b with - | { b = Annotated (_, t) } - | { b = TAnnotated (_, t) } - | { b = NoName t } -> collect_term t - | _ -> () - - and collect_aqual = function - | Some (Meta t) -> collect_term t - | Some TypeClassArg -> add_to_parsing_data (P_lid Const.tcresolve_lid) - | _ -> () - - and collect_term t = - collect_term' t.tm - - and collect_constant = function - | Const_int (_, Some (Unsigned, Sizet)) -> - add_to_parsing_data (P_dep (false, ("fstar.sizeT" |> Ident.lid_of_str))) - | Const_int (_, Some (signedness, width)) -> - let u = match signedness with | Unsigned -> "u" | Signed -> "" in - let w = match width with | Int8 -> "8" | Int16 -> "16" | Int32 -> "32" | Int64 -> "64" in - add_to_parsing_data (P_dep (false, (Util.format2 "fstar.%sint%s" u w |> Ident.lid_of_str))) - | Const_char _ -> - add_to_parsing_data (P_dep (false, ("fstar.char" |> Ident.lid_of_str))) - | Const_range_of - | Const_set_range_of -> - add_to_parsing_data (P_dep (false, ("fstar.range" |> Ident.lid_of_str))) - | Const_real _ -> - add_to_parsing_data (P_dep (false, ("fstar.real" |> Ident.lid_of_str))) - | _ -> - () - - and collect_term' = function - | Wild -> - () - | Const c -> - collect_constant c - | Op (_, ts) -> - List.iter collect_term ts - | Tvar _ - | AST.Uvar _ -> - () - | Var lid - | AST.Projector (lid, _) - | AST.Discrim lid - | Name lid -> - add_to_parsing_data (P_lid lid) - | Construct (lid, termimps) -> - add_to_parsing_data (P_lid lid); - List.iter (fun (t, _) -> collect_term t) termimps - | Function (branches, _) -> - collect_branches branches - | Abs (pats, t) -> - collect_patterns pats; - collect_term t - | App (t1, t2, _) -> - collect_term t1; - collect_term t2 - | Let (_, patterms, t) -> - List.iter (fun (attrs_opt, (pat, t)) -> - ignore (BU.map_opt attrs_opt (List.iter collect_term)); - collect_pattern pat; - collect_term t) - patterms; - collect_term t - | LetOperator (lets, body) -> - List.iter (fun (ident, pat, def) -> - collect_pattern pat; - collect_term def - ) lets; - collect_term body - | LetOpen (lid, t) -> - add_to_parsing_data (P_open (true, lid)); - collect_term t - | LetOpenRecord (r, rty, e) -> - collect_term r; - collect_term rty; - collect_term e - | Bind(_, t1, t2) - | Seq (t1, t2) -> - collect_term t1; - collect_term t2 - | If (t1, _, ret_opt, t2, t3) -> - collect_term t1; - (match ret_opt with - | None -> () - | Some (_, ret, _) -> - collect_term ret); - collect_term t2; - collect_term t3 - | Match (t, _, ret_opt, bs) -> - collect_term t; - (match ret_opt with - | None -> () - | Some (_, ret, _) -> - collect_term ret); - collect_branches bs - | TryWith (t, bs) -> - collect_term t; - collect_branches bs - | Ascribed (t1, t2, None, _) -> - collect_term t1; - collect_term t2 - | Ascribed (t1, t2, Some tac, _) -> - collect_term t1; - collect_term t2; - collect_term tac - | Record (t, idterms) -> - iter_opt t collect_term; - List.iter - (fun (fn, t) -> - collect_fieldname fn; - collect_term t) - idterms - | Project (t, f) -> - collect_term t; - collect_fieldname f - | Product (binders, t) -> - collect_binders binders; - collect_term t - | Sum (binders, t) -> - List.iter (function - | Inl b -> collect_binder b - | Inr t -> collect_term t) - binders; - collect_term t - | QForall (binders, (_, ts), t) - | QExists (binders, (_, ts), t) - | QuantOp (_, binders, (_, ts), t) -> - collect_binders binders; - List.iter (List.iter collect_term) ts; - collect_term t - | Refine (binder, t) -> - collect_binder binder; - collect_term t - | NamedTyp (_, t) -> - collect_term t - | Paren t -> - collect_term t - | Requires (t, _) - | Ensures (t, _) - | Labeled (t, _, _) -> - collect_term t - | LexList l -> List.iter collect_term l - | WFOrder (t1, t2) -> - add_to_parsing_data (P_dep (false, (Ident.lid_of_str "FStar.WellFounded"))); - begin - collect_term t1; collect_term t2 - end - | Decreases (t, _) -> collect_term t - | Quote (t, _) - | Antiquote t - | VQuote t -> - collect_term t - | Attributes cattributes -> - List.iter collect_term cattributes - | CalcProof (rel, init, steps) -> - add_to_parsing_data (P_dep (false, (Ident.lid_of_str "FStar.Calc"))); - begin - collect_term rel; - collect_term init; - List.iter (function CalcStep (rel, just, next) -> - collect_term rel; - collect_term just; - collect_term next) steps - end - - | IntroForall (bs, p, e) -> - add_to_parsing_data (P_dep (false, (Ident.lid_of_str "FStar.Classical.Sugar"))); - collect_binders bs; - collect_term p; - collect_term e - - | IntroExists(bs, t, vs, e) -> - add_to_parsing_data (P_dep (false, (Ident.lid_of_str "FStar.Classical.Sugar"))); - collect_binders bs; - collect_term t; - List.iter collect_term vs; - collect_term e - - | IntroImplies(p, q, x, e) -> - add_to_parsing_data (P_dep (false, (Ident.lid_of_str "FStar.Classical.Sugar"))); - collect_term p; - collect_term q; - collect_binder x; - collect_term e - - | IntroOr(b, p, q, r) -> - add_to_parsing_data (P_dep (false, (Ident.lid_of_str "FStar.Classical.Sugar"))); - collect_term p; - collect_term q; - collect_term r - - | IntroAnd(p, q, r, e) -> - add_to_parsing_data (P_dep (false, (Ident.lid_of_str "FStar.Classical.Sugar"))); - collect_term p; - collect_term q; - collect_term r; - collect_term e - - | ElimForall(bs, p, vs) -> - add_to_parsing_data (P_dep (false, (Ident.lid_of_str "FStar.Classical.Sugar"))); - collect_binders bs; - collect_term p; - List.iter collect_term vs - - | ElimExists(bs, p, q, b, e) -> - add_to_parsing_data (P_dep (false, (Ident.lid_of_str "FStar.Classical.Sugar"))); - collect_binders bs; - collect_term p; - collect_term q; - collect_binder b; - collect_term e - - | ElimImplies(p, q, e) -> - add_to_parsing_data (P_dep (false, (Ident.lid_of_str "FStar.Classical.Sugar"))); - collect_term p; - collect_term q; - collect_term e - - | ElimAnd(p, q, r, x, y, e) -> - add_to_parsing_data (P_dep (false, (Ident.lid_of_str "FStar.Classical.Sugar"))); - collect_term p; - collect_term q; - collect_term r; - collect_binder x; - collect_binder y; - collect_term e - - | ElimOr(p, q, r, x, e, y, e') -> - add_to_parsing_data (P_dep (false, (Ident.lid_of_str "FStar.Classical.Sugar"))); - collect_term p; - collect_term q; - collect_term r; - collect_binder x; - collect_binder y; - collect_term e; - collect_term e' - - | ListLiteral ts -> - List.iter collect_term ts - - | SeqLiteral ts -> - add_to_parsing_data (P_dep (false, (Ident.lid_of_str "FStar.Seq.Base"))); - List.iter collect_term ts - - and collect_patterns ps = - List.iter collect_pattern ps - - and collect_pattern p = - collect_pattern' p.pat - - and collect_pattern' = function - | PatVar (_, aqual, attrs) - | PatTvar (_, aqual, attrs) - | PatWild (aqual, attrs) -> - collect_aqual aqual; - attrs |> List.iter collect_term - - | PatOp _ - | PatConst _ -> - () - | PatVQuote t -> - collect_term t - | PatApp (p, ps) -> - collect_pattern p; - collect_patterns ps - | PatName _ -> - () - | PatList ps - | PatOr ps - | PatTuple (ps, _) -> - collect_patterns ps - | PatRecord lidpats -> - List.iter (fun (_, p) -> collect_pattern p) lidpats - | PatAscribed (p, (t, None)) -> - collect_pattern p; - collect_term t - | PatAscribed (p, (t, Some tac)) -> - collect_pattern p; - collect_term t; - collect_term tac - - - and collect_branches bs = - List.iter collect_branch bs - - and collect_branch (pat, t1, t2) = - collect_pattern pat; - iter_opt t1 collect_term; - collect_term t2 - - and collect_fieldname fn = - if nsstr fn <> "" - then add_to_parsing_data (P_dep (false, lid_of_ids (ns_of_lid fn))) - - in - let ast, _ = Driver.parse_file filename in - collect_module ast; - let pd = Mk_pd (List.rev !pd) in - let deps, has_inline_for_extraction, mo_roots = from_parsing_data pd original_map filename in - (* Util.print2 "Deps for %s: %s\n" filename (String.concat " " (!deps)); *) - pd, deps, has_inline_for_extraction, mo_roots - - -(* JP: it looks like the code was changed but the comments were never updated. - * In particular, we no longer compute transitive dependencies, and we no longer - * map lowercase module names to filenames. *) - -// Used by F*.js -let collect_one_cache : ref (smap (list dependence & list dependence & bool)) = - BU.mk_ref (BU.smap_create 0) - -let set_collect_one_cache (cache: smap (list dependence & list dependence & bool)) : unit = - collect_one_cache := cache - -let dep_graph_copy dep_graph = - let (Deps g) = dep_graph in - Deps (BU.smap_copy g) - -let widen_deps friends dep_graph file_system_map widened = - let widened = BU.mk_ref widened in - let (Deps dg) = dep_graph in - let (Deps dg') = deps_empty() in - let widen_one deps = - deps |> List.map (fun d -> - match d with - | PreferInterface m - when (List.contains m friends && - has_implementation file_system_map m) -> - widened := true; - FriendImplementation m - | _ -> d) - in - BU.smap_fold - dg - (fun filename dep_node () -> - BU.smap_add - dg' - filename - ({dep_node with edges=widen_one dep_node.edges; color=White})) - (); - !widened, Deps dg' - -let topological_dependences_of' - file_system_map - dep_graph - interfaces_needing_inlining - root_files - widened - : list file_name - & bool = - let rec all_friend_deps_1 - dep_graph - (cycle:list file_name) - (all_friends, all_files) - filename = - let dep_node = must (deps_try_find dep_graph filename) in - match dep_node.color with - | Gray -> - failwith "Impossible: cycle detected after cycle detection has passed" - | Black -> - (* If the element has been visited already, then the map contains all its - * dependencies. Otherwise, the map only contains its direct dependencies. *) - all_friends, all_files - | White -> - if !dbg - then BU.print2 "Visiting %s: direct deps are %s\n" - filename (show dep_node.edges); - (* Unvisited. Compute. *) - deps_add_dep dep_graph filename ({dep_node with color=Gray}); - let all_friends, all_files = - all_friend_deps - dep_graph cycle (all_friends, all_files) - (dependences_of file_system_map - dep_graph - root_files - filename) - in - (* Mutate the graph to mark the node as visited *) - deps_add_dep dep_graph filename ({dep_node with color=Black}); - if !dbg - then BU.print1 "Adding %s\n" filename; - (* Also build the topological sort (Tarjan's algorithm). *) - List.collect - (function | FriendImplementation m -> [m] - | d -> []) - dep_node.edges - @all_friends, - filename :: all_files - and all_friend_deps dep_graph cycle all_friends filenames = - List.fold_left - (fun all_friends k -> - all_friend_deps_1 dep_graph (k :: cycle) all_friends k) - all_friends - filenames - in - - (* An important requirement is that in addition to files being - emitted in topological order, we require implementation files - to immmediately follow their interface files (if any) in the - final order. - - This is because the interleaving semantics of - interfaces+implementation relies on these files being adjacent - in the dependence order. - - This is enforced in several steps. - - First, every implementation file contains its interface file as - its *LAST* dependence. In a simple scenario, when scanning an - the dependences of an implementation file, we will encounter - its interface last, and so we would complete the dependence - scan of all the dependences of the implementation;then the - dependences of the interface file; then emit the interface file - in the topological sort (above); followed immediately by the - implementation. - - More complex situations arise due to friend modules where some - modules in the dependence graph may rely only on the module's - interface, whereas others may rely on its implementation. - - Further complications arise from cross-module inlining, where, - the extraction of one module may depend on the implementation - details of another module. - - To handle this, we compute the file list in several phases: - - 1. If --cmi and codegen is true, then we need to inline across - interface boundaries for modules M that are in the - interfaces_needing_inlining list. So, we transform the - dependence graph updating every interface dependence on - such a module M into a friend dependence on that module's - implementation. - - 2. Then, we traverse the graph in topological order - encountering all friend modules reachable from the - specified roots. - - 3. Then, we alter the dependences to turn every occurrence of - a interface dependence of a friend module into an - implementation dependence. Note, this does not change the - set of files reachable from the given roots. - - 4. A second traversal now collects all the files in dependence - order, ensuring that implementation and interface files are - adjacent in the dependence order, since the interface is - always the last dependence of an implementation. - - This ensures that for a given set of roots, every module that - needs to be friended or inlined is marked as a friend for - *every* module in the dependence graph, avoiding "double - vision" problems of some modules seeing the interface only - whereas others requiring both interface+implementation. - - So, when traversing the graph, we always encounter friend - module implementaions first, then their interfaces, emitting - them adjacent to the each other in the final order. - *) - - let friends, all_files_0 = - all_friend_deps dep_graph [] ([], []) root_files - in - if !dbg - then BU.print3 "Phase1 complete:\n\t\ - all_files = %s\n\t\ - all_friends=%s\n\t\ - interfaces_with_inlining=%s\n" - (String.concat ", " all_files_0) - (String.concat ", " (remove_dups (fun x y -> x=y) friends)) - (String.concat ", " (interfaces_needing_inlining)); - let widened, dep_graph = - widen_deps friends dep_graph file_system_map widened - in - let _, all_files = - if !dbg - then BU.print_string "==============Phase2==================\n"; - all_friend_deps dep_graph [] ([], []) root_files - in - if !dbg - then BU.print1 "Phase2 complete: all_files = %s\n" (String.concat ", " all_files); - all_files, - widened - -let phase1 - file_system_map - dep_graph - interfaces_needing_inlining - for_extraction -= - if !dbg - then BU.print_string "==============Phase1==================\n"; - let widened = false in - if Options.cmi() - && for_extraction - then widen_deps interfaces_needing_inlining dep_graph file_system_map widened - else widened, dep_graph - -let topological_dependences_of - file_system_map - dep_graph - interfaces_needing_inlining - root_files - for_extraction - : list file_name - & bool = - - let widened, dep_graph = phase1 file_system_map dep_graph interfaces_needing_inlining for_extraction in - topological_dependences_of' file_system_map dep_graph interfaces_needing_inlining root_files widened - -let all_files_in_include_paths () = - let paths = Options.include_path () in - 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 - List.map (fun file -> Util.join_paths path file) files) - paths - -(** Collect the dependencies for a list of given files. - And record the entire dependence graph in the memoized state above **) -(* - * get_parsing_data_from_cache is a callback passed by caller - * to read the parsing data from checked files - *) -(* In public interface *) -let collect (all_cmd_line_files: list file_name) - (get_parsing_data_from_cache:string -> option parsing_data) - : list file_name - & deps //topologically sorted transitive dependences of all_cmd_line_files - = - let all_cmd_line_files = - match all_cmd_line_files with - | [] -> all_files_in_include_paths () - | _ -> all_cmd_line_files - in - let all_cmd_line_files = - all_cmd_line_files |> List.map (fun fn -> - match Find.find_file fn with - | None -> - raise_error0 Errors.Fatal_ModuleOrFileNotFound - (Util.format1 "File %s could not be found" fn) - | Some fn -> fn) in - (* The dependency graph; keys are lowercased module names, values = list of - * lowercased module names this file depends on. *) - let dep_graph : dependence_graph = deps_empty () in - - (* A map from lowercase module names (e.g. [a.b.c]) to the corresponding - * filenames (e.g. [/where/to/find/A.B.C.fst]). Consider this map - * immutable from there on. *) - let file_system_map = build_map all_cmd_line_files in - - let interfaces_needing_inlining = BU.mk_ref [] in - let add_interface_for_inlining l = - let l = lowercase_module_name l in - interfaces_needing_inlining := l :: !interfaces_needing_inlining - in - - let parse_results = BU.smap_create 40 in - - (* discover: Do a graph traversal starting from file_name - * filling in dep_graph with the dependences *) - let rec discover_one (file_name:file_name) = - if deps_try_find dep_graph file_name = None then - begin - let parsing_data, (deps, mo_roots, needs_interface_inlining) = - match BU.smap_try_find !collect_one_cache file_name with - | Some cached -> Mk_pd [], cached - | None -> - let parsing_data, deps, needs_interface_inlining, additional_roots = collect_one file_system_map file_name get_parsing_data_from_cache in - parsing_data, (deps, additional_roots, needs_interface_inlining) in - if needs_interface_inlining - then add_interface_for_inlining file_name; - BU.smap_add parse_results file_name parsing_data; - let deps = - let module_name = lowercase_module_name file_name in - if is_implementation file_name - && has_interface file_system_map module_name - then deps @ [UseInterface module_name] - else deps - in - let dep_node : dep_node = { - edges = List.unique deps; - color = White; - } in - deps_add_dep dep_graph file_name dep_node; - List.iter - discover_one - (List.map (file_of_dep file_system_map all_cmd_line_files) - (deps @ mo_roots)) - end - in - profile (fun () -> List.iter discover_one all_cmd_line_files) "FStar.Parser.Dep.discover"; - - (* At this point, dep_graph has all the (immediate) dependency graph of all the files. *) - let cycle_detected dep_graph cycle filename = - Util.print1 "The cycle contains a subset of the modules in:\n%s \n" (String.concat "\n`used by` " cycle); - - (* Write the graph to a file for the user to see. *) - let fn = "dep.graph" in - with_file_outchannel fn (fun outc -> print_graph outc fn dep_graph); - - print_string "\n"; - raise_error0 Errors.Fatal_CyclicDependence [ - text (BU.format1 "Recursive dependency on module %s." filename); - text "A full dependency graph was written to dep.graph."; - ] - in - (* full_cycle_detection finds cycles across interface - boundaries that can otherwise be exploited to - build cross-module recursive loops, as in issue #1391 - *) - let full_cycle_detection all_command_line_files file_system_map = - let dep_graph = dep_graph_copy dep_graph in - - (* - * The cycle detection code considers all_command_line_files - * as roots to perform full cycle detection. As a result, - * all command line files, and their transitive dependences - * are considered. However, this misses the cycles through .fst - * as in the issue #1391, IF only .fsti is given on the command - * line. This is even more a problem in invocations like: - * fstar A.fsti --dep full, which dumps the .depend, while not - * noticing the cycle. - * - * A fix for this issue is to record in mo_files the implementations - * of command line interfaces whose implementations are not on the - * command line, and consider them also for cycle detection. - * - * Right now this is done even in the case of fstar A.fsti - * we can consider using mo_files only in the case of - * --dep invocations. - *) - let mo_files : ref (list string) = BU.mk_ref [] in - - - let rec aux (cycle:list file_name) filename = - let node = - match deps_try_find dep_graph filename with - | Some node -> node - | None -> - failwith (BU.format1 "Impossible: Failed to find dependencies of %s" filename) - in - let direct_deps = node.edges |> List.collect (fun x -> - match x with - | UseInterface f - | PreferInterface f -> - begin - match implementation_of_internal file_system_map f with - | None -> [x] - | Some fn when fn=filename -> - //don't add trivial self-loops - [x] - | _ -> - //if a module A uses B - //then detect cycles through both B.fsti - //and B.fst - [x; UseImplementation f] - end - | _ -> [x]) in - match node.color with - | Gray -> - cycle_detected dep_graph cycle filename - | Black -> - (* If the element has been visited already, then the map contains all its - * dependencies. Otherwise, the map only contains its direct dependencies. *) - () - | White -> - (* Unvisited. Compute. *) - deps_add_dep dep_graph filename ({node with edges=direct_deps; color=Gray}); - List.iter (fun k -> aux (k :: cycle) k) - (dependences_of file_system_map - dep_graph - all_command_line_files - filename); - (* Mutate the graph (to mark the node as visited) *) - deps_add_dep dep_graph filename ({node with edges=direct_deps; color=Black}); - - (* - * If the file is an interface, and its implementation exists, and the implementation - * is not on the command line, add it to mo_files - *) - if is_interface filename - then iter_opt - (implementation_of_internal file_system_map (lowercase_module_name filename)) - (fun impl -> if not (List.contains impl all_command_line_files) - then mo_files := impl::!mo_files - else ()) - else () - in - List.iter (aux []) all_command_line_files; - (* Detect cycles via mo_files *) - List.iter (aux []) !mo_files - in - full_cycle_detection all_cmd_line_files file_system_map; - - //only verify those files on the command line - all_cmd_line_files |> - List.iter (fun f -> - let m = lowercase_module_name f in - Options.add_verify_module m); - - let inlining_ifaces = !interfaces_needing_inlining in - let all_files, _ = - profile - (fun () -> - topological_dependences_of - file_system_map - dep_graph - inlining_ifaces - all_cmd_line_files - (Options.codegen()<>None)) - "FStar.Parser.Dep.topological_dependences_of" - in - if !dbg - then BU.print1 "Interfaces needing inlining: %s\n" (String.concat ", " inlining_ifaces); - all_files, - mk_deps dep_graph file_system_map all_cmd_line_files all_files inlining_ifaces parse_results - -(* In public interface *) -let deps_of deps (f:file_name) - : list file_name = - dependences_of deps.file_system_map deps.dep_graph deps.cmd_line_files f - -let deps_of_modul deps (m:module_name) : list module_name = - let aux (fopt:option string) = - fopt |> BU.map_option (fun f -> f |> deps_of deps |> List.map module_name_of_file) - |> BU.dflt [] - in - m |> String.lowercase - |> BU.smap_try_find deps.file_system_map - |> BU.map_option (fun (intf_opt, impl_opt) -> - BU.remove_dups (fun x y -> x = y) (aux intf_opt @ aux impl_opt)) - |> BU.dflt [] - -(* In public interface *) -let print_digest (dig:list (string & string)) : string = - dig - |> List.map (fun (m, d) -> BU.format2 "%s:%s" m (BU.base64_encode d)) - |> String.concat "\n" - -(** Print the dependencies as returned by [collect] in a Makefile-compatible - format. - - Deprecated: this will print the dependences among the source files - *) -let print_make (outc : out_channel) deps : unit = - let file_system_map = deps.file_system_map in - let all_cmd_line_files = deps.cmd_line_files in - let deps = deps.dep_graph in - let keys = deps_keys deps in - keys |> List.iter - (fun f -> - let dep_node = deps_try_find deps f |> Option.get in - let files = List.map (file_of_dep file_system_map all_cmd_line_files) dep_node.edges in - let files = List.map (fun s -> replace_chars s ' ' "\\ ") files in - //this one prints: - // a.fst: b.fst c.fsti a.fsti - Util.print2 "%s: %s\n\n" f (String.concat " " files)) - -(* In public interface *) -let print_raw (outc : out_channel) (deps:deps) = - let (Deps deps) = deps.dep_graph in - smap_fold deps (fun k dep_node out -> - BU.format2 "%s -> [\n\t%s\n] " k (List.map dep_to_string dep_node.edges |> String.concat ";\n\t") :: out) [] - |> String.concat ";;\n" - |> (fun s -> BU.fprint outc "%s\n" [s]) - -(** Print the dependencies as returned by [collect] in a Makefile-compatible - format. - - -- The dependences are among the .checked files - - -- We also print dependences for producing .ml files from .checked files - This takes care of renaming A.B.C.fst to A_B_C.ml - *) -let print_full (outc : out_channel) (deps:deps) : unit = - //let (Mk (deps, file_system_map, all_cmd_line_files, all_files)) = deps in - let sort_output_files (orig_output_file_map:BU.smap string) = - let order : ref (list string) = BU.mk_ref [] in - let remaining_output_files = BU.smap_copy orig_output_file_map in - let visited_other_modules = BU.smap_create 41 in - let should_visit lc_module_name = - Option.isSome (BU.smap_try_find remaining_output_files lc_module_name) - || Option.isNone (BU.smap_try_find visited_other_modules lc_module_name) - in - let mark_visiting lc_module_name = - let ml_file_opt = BU.smap_try_find remaining_output_files lc_module_name in - BU.smap_remove remaining_output_files lc_module_name; - BU.smap_add visited_other_modules lc_module_name true; - ml_file_opt - in - let emit_output_file_opt ml_file_opt = - match ml_file_opt with - | None -> () - | Some ml_file -> order := ml_file :: !order - in - let rec aux = function - | [] -> () - | lc_module_name::modules_to_extract -> - let visit_file file_opt = - match file_opt with - | None -> () - | Some file_name -> - match deps_try_find deps.dep_graph file_name with - | None -> failwith (BU.format2 "Impossible: module %s: %s not found" lc_module_name file_name) - | Some ({edges=immediate_deps}) -> - let immediate_deps = - List.map (fun x -> String.lowercase (module_name_of_dep x)) immediate_deps - in - aux immediate_deps - in - if should_visit lc_module_name then begin - let ml_file_opt = mark_visiting lc_module_name in - //visit all its dependences - visit_file (implementation_of deps lc_module_name); - visit_file (interface_of deps lc_module_name); - //and then emit this one's ML file - emit_output_file_opt ml_file_opt - end; - aux modules_to_extract - in - let all_extracted_modules = BU.smap_keys orig_output_file_map in - aux all_extracted_modules; - List.rev !order - in - let sb = FStar.StringBuffer.create (FStar.BigInt.of_int_fs 10000) in - let pr str = ignore <| FStar.StringBuffer.add str sb in - let print_entry target first_dep all_deps = - pr target; - pr ": "; - pr first_dep; - pr "\\\n\t"; - pr all_deps; - pr "\n\n" - in - let keys = deps_keys deps.dep_graph in - let no_fstar_stubs_file (s:string) : string = - (* If the original filename begins with FStar.Stubs, then remove that, - consistent with what extraction will actually do. *) - let s1 = "FStar.Stubs." in - let s2 = "FStar." in - let l1 = String.length s1 in - if String.length s >= l1 && String.substring s 0 l1 = s1 then - s2 ^ String.substring s l1 (String.length s - l1) - else - s - in - let output_file ext fst_file = - let basename = Option.get (check_and_strip_suffix (BU.basename fst_file)) in - let basename = no_fstar_stubs_file basename in - let ml_base_name = replace_chars basename '.' "_" in - Options.prepend_output_dir (ml_base_name ^ ext) - in - let norm_path s = replace_chars (replace_chars s '\\' "/") ' ' "\\ " in - let output_fs_file f = norm_path (output_file ".fs" f) in - let output_ml_file f = norm_path (output_file ".ml" f) in - let output_krml_file f = norm_path (output_file ".krml" f) in - let output_cmx_file f = norm_path (output_file ".cmx" f) in - let cache_file f = norm_path (cache_file_name f) in - let widened, dep_graph = phase1 deps.file_system_map deps.dep_graph deps.interfaces_with_inlining true in - let all_checked_files = - keys |> - List.fold_left - (fun all_checked_files file_name -> - let process_one_key () = - let dep_node = deps_try_find deps.dep_graph file_name |> Option.get in - let iface_fn, iface_deps = - if is_interface file_name - then None, None - else match interface_of deps (lowercase_module_name file_name) with - | None -> - None, None - | Some iface -> - Some iface, - Some ((Option.get (deps_try_find deps.dep_graph iface)).edges) - in - let iface_deps = - BU.map_opt iface_deps - (List.filter - (fun iface_dep -> - not (BU.for_some (dep_subsumed_by iface_dep) dep_node.edges))) - in - let norm_f = norm_path file_name in - let files = - List.map - (file_of_dep_aux true deps.file_system_map deps.cmd_line_files) - dep_node.edges - in - let files = - match iface_deps with - | None -> files - | Some iface_deps -> - let iface_files = - List.map (file_of_dep_aux true deps.file_system_map deps.cmd_line_files) iface_deps - in - BU.remove_dups (fun x y -> x = y) (files @ iface_files) - in - - (* - * AR: depend on A.fsti.checked, rather than A.fsti - * see #1919 - *) - let files = - if iface_fn |> is_some then - let iface_fn = iface_fn |> must in - files |> List.filter (fun f -> f <> iface_fn) - |> (fun files -> (cache_file_name iface_fn)::files) - else files in - - let files = List.map norm_path files in - let files = String.concat "\\\n\t" files in - let cache_file_name = cache_file file_name in - - let all_checked_files = - if not (Options.should_be_already_cached (module_name_of_file file_name)) - then //this one prints: - // a.fst.checked: b.fst.checked c.fsti.checked a.fsti - (print_entry cache_file_name norm_f files; - cache_file_name::all_checked_files) - else all_checked_files - in - - //And, if this is not an interface, we also print out the dependences among the .ml files - // excluding files in ulib, since these are packaged in fstar_lib.cmxa - let all_fst_files_dep, widened = - if Options.cmi() - then profile - (fun () -> - topological_dependences_of' - deps.file_system_map - (dep_graph_copy dep_graph) - deps.interfaces_with_inlining - [file_name] - widened) - "FStar.Parser.Dep.topological_dependences_of_2" - else - let maybe_widen_deps (f_deps:dependences) = - List.map - (fun dep -> - file_of_dep_aux false deps.file_system_map deps.cmd_line_files dep) - f_deps - in - let fst_files = maybe_widen_deps dep_node.edges in - let fst_files_from_iface = - match iface_deps with - | None -> [] - | Some iface_deps -> maybe_widen_deps iface_deps - in - BU.remove_dups (fun x y -> x = y) (fst_files @ fst_files_from_iface), - false - in - let all_checked_fst_dep_files = all_fst_files_dep |> List.map cache_file in - let all_checked_fst_dep_files_string = - String.concat " \\\n\t" all_checked_fst_dep_files - in - let _ = - if is_implementation file_name - then begin - if Options.cmi() - && widened - then begin - let mname = lowercase_module_name file_name in - - print_entry - (output_ml_file file_name) - cache_file_name - all_checked_fst_dep_files_string; - - if Options.should_extract mname Options.FSharp - then print_entry - (output_fs_file file_name) - cache_file_name - all_checked_fst_dep_files_string; - - print_entry - (output_krml_file file_name) - cache_file_name - all_checked_fst_dep_files_string - end - else begin - let mname = lowercase_module_name file_name in - - print_entry - (output_ml_file file_name) - cache_file_name - ""; - - if Options.should_extract mname Options.FSharp - then print_entry - (output_fs_file file_name) - cache_file_name - ""; - - print_entry - (output_krml_file file_name) - cache_file_name - "" - end; - let cmx_files = - let extracted_fst_files = - all_fst_files_dep |> - List.filter - (fun df -> - lowercase_module_name df <> lowercase_module_name file_name //avoid circular deps on f's own cmx - && Options.should_extract (lowercase_module_name df) Options.OCaml) - in - extracted_fst_files |> List.map output_cmx_file - in - if Options.should_extract (lowercase_module_name file_name) Options.OCaml - then - let cmx_files = String.concat "\\\n\t" cmx_files in - print_entry - (output_cmx_file file_name) - (output_ml_file file_name) - cmx_files - - end - else if not(has_implementation deps.file_system_map (lowercase_module_name file_name)) - && is_interface file_name - then begin - // .krml files can be produced using just an interface, unlike .ml files - if Options.cmi() - && (widened || true) - then - print_entry - (output_krml_file file_name) - cache_file_name - all_checked_fst_dep_files_string - else - print_entry - (output_krml_file file_name) - (cache_file_name) - "" - end - in - all_checked_files - in - profile process_one_key "FStar.Parser.Dep.process_one_key") - [] - in - let all_fst_files = - keys |> List.filter is_implementation - |> Util.sort_with String.compare - in - let all_fsti_files = - keys |> List.filter is_interface - |> Util.sort_with String.compare - in - let all_ml_files = - let ml_file_map = BU.smap_create 41 in - all_fst_files - |> List.iter (fun fst_file -> - let mname = lowercase_module_name fst_file in - if Options.should_extract mname Options.OCaml - then BU.smap_add ml_file_map mname (output_ml_file fst_file)); - sort_output_files ml_file_map - in - let all_fs_files = - let fs_file_map = BU.smap_create 41 in - all_fst_files - |> List.iter (fun fst_file -> - let mname = lowercase_module_name fst_file in - if Options.should_extract mname Options.FSharp - then BU.smap_add fs_file_map mname (output_fs_file fst_file)); - sort_output_files fs_file_map - in - let all_krml_files = - let krml_file_map = BU.smap_create 41 in - keys - |> List.iter (fun fst_file -> - let mname = lowercase_module_name fst_file in - if Options.should_extract mname Options.Krml - then BU.smap_add krml_file_map mname (output_krml_file fst_file)); - sort_output_files krml_file_map - in - let print_all tag files = - pr tag; - pr "=\\\n\t"; - List.iter (fun f -> pr (norm_path f); pr " \\\n\t") files; - pr "\n" - in - all_fsti_files - |> List.iter - (fun fsti -> - let mn = lowercase_module_name fsti in - let range_of_file fsti = - let r = Range.set_file_of_range Range.dummyRange fsti in - Range.set_use_range r (Range.def_range r) - in - if not (has_implementation deps.file_system_map mn) then - log_issue (range_of_file fsti) Warning_WarnOnUse - (BU.format1 "Interface %s is admitted without an implementation" (module_name_of_file fsti))); - print_all "ALL_FST_FILES" all_fst_files; - print_all "ALL_FSTI_FILES" all_fsti_files; - print_all "ALL_CHECKED_FILES" all_checked_files; - print_all "ALL_FS_FILES" all_fs_files; - print_all "ALL_ML_FILES" all_ml_files; - print_all "ALL_KRML_FILES" all_krml_files; - - FStar.StringBuffer.output_channel outc sb - -let do_print (outc : out_channel) (fn : string) deps : unit = - let pref () = - BU.fprint outc "# This .depend was generated by F* %s\n" [!Options._version]; - BU.fprint outc "# Executable: %s\n" [show BU.exec_name]; - BU.fprint outc "# Hash: %s\n" [!Options._commit]; - BU.fprint outc "# Running in directory %s\n" [show (normalize_file_path (BU.getcwd ()))]; - BU.fprint outc "# Command line arguments: \"%s\"\n" [show (BU.get_cmd_args ())]; - BU.fprint outc "\n" []; - () - in - match Options.dep() with - | Some "make" -> - pref (); - print_make outc deps - | Some "full" -> - pref (); - profile (fun () -> print_full outc deps) "FStarC.Parser.Deps.print_full_deps" - | Some "graph" -> - print_graph outc fn deps.dep_graph - | Some "raw" -> - print_raw outc deps - | Some _ -> - raise_error0 Errors.Fatal_UnknownToolForDep "unknown tool for --dep\n" - | None -> - assert false - -(* Just prints to stdout *) -let do_print_stdout deps = - do_print BU.stdout "" deps - -(* Opens the file, prints to it, and closes it. If anything failed, the file -is deleted. *) -let do_print_file deps fn = - with_file_outchannel fn (fun outc -> do_print outc fn deps) - -(* In public interface *) -let print deps = - match Options.output_deps_to () with - | Some s -> do_print_file deps s - (* Special case for --dep graph, by default we write to dep.graph instead of stdout. *) - | None when Options.dep () = Some "graph" -> do_print_file deps "dep.graph" - | None -> do_print_stdout deps - -(* In public interface *) -let module_has_interface deps module_name = - has_interface deps.file_system_map (String.lowercase (Ident.string_of_lid module_name)) - -(* In public interface *) -let deps_has_implementation deps module_name = - let m = String.lowercase (Ident.string_of_lid module_name) in - deps.all_files |> BU.for_some (fun f -> - is_implementation f - && String.lowercase (module_name_of_file f) = m) diff --git a/src/parser/FStar.Parser.Dep.fsti b/src/parser/FStar.Parser.Dep.fsti deleted file mode 100644 index 7701451f7a2..00000000000 --- a/src/parser/FStar.Parser.Dep.fsti +++ /dev/null @@ -1,65 +0,0 @@ -(* - Copyright 2008-2014 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR C ONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Parser.Dep -open FStar.Compiler.Effect -open FStar -open FStar.Compiler -open FStar.Parser -open FStar.Parser.AST -open FStar.Compiler.Util -open FStar.Const -open FStar.String -open FStar.Ident -open FStar.Errors -module Const = FStar.Parser.Const -module BU = FStar.Compiler.Util - -type open_kind = | Open_module | Open_namespace -type module_name = string - -val maybe_module_name_of_file : string -> option string -val module_name_of_file : string -> string -val lowercase_module_name : string -> string - -val build_inclusion_candidates_list : unit -> list (string & string) - -val core_modules (_: unit) : list string -(* Given a filename, returns the list of automatically opened modules -and namespaces *) -val hard_coded_dependencies : string -> list (lident & open_kind) - -val is_interface: string -> bool -val is_implementation: string -> bool - -val parsing_data : Type0 //cached in the checked files -val str_of_parsing_data (p:parsing_data) : string -val empty_parsing_data: parsing_data //for legacy ide -val friends (p:parsing_data) : list lident -val deps : Type0 - -val empty_deps : deps -val interface_of : deps -> module_name:string -> option string //return value is the file name -val implementation_of : deps -> module_name:string -> option string //return value is the file name -val cache_file_name: (string -> string) -val parsing_data_of: deps -> string -> parsing_data -val collect: list string -> (string -> option parsing_data) -> list string & deps -val deps_of : deps -> string -> list string -val deps_of_modul : deps -> module_name -> list module_name // list of modules that this module depends on -val print : deps -> unit -val print_digest: list (string & string) -> string -val module_has_interface: deps -> module_name:Ident.lident -> bool -val deps_has_implementation: deps -> module_name:Ident.lident -> bool -val print_raw: out_channel -> deps -> unit diff --git a/src/parser/FStar.Parser.Driver.fst b/src/parser/FStar.Parser.Driver.fst deleted file mode 100644 index 030a4c8b786..00000000000 --- a/src/parser/FStar.Parser.Driver.fst +++ /dev/null @@ -1,69 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Parser.Driver -open FStar.Pervasives -open FStar.Compiler.Effect - -open FStar -open FStar.Compiler -open FStar.Parser -open FStar.Parser.AST -open FStar.Parser.ParseIt -open FStar.Compiler.Util -open FStar.Errors -open FStar.Class.Show - -let is_cache_file (fn: string) = Util.get_file_extension fn = ".cache" - -let parse_fragment lang_opt (frag: ParseIt.input_frag) : fragment = - match ParseIt.parse lang_opt (Toplevel frag) with - | ASTFragment (Inl modul, _) -> //interactive mode: module - Modul modul - | ASTFragment (Inr [], _) -> //interactive mode: blank space - Empty - | ASTFragment (Inr decls, _) -> //interactive mode: more decls - Decls decls - | IncrementalFragment (decls, _, _) -> - DeclsWithContent decls - | ParseError (e, msg, r) -> - raise_error r e msg - | Term _ -> - failwith "Impossible: parsing a Toplevel always results in an ASTFragment" - -let maybe_dump_module (m:modul) = - match m with - | Module (l, ds) - | Interface (l, ds, _) -> - if FStar.Options.dump_module (Ident.string_of_lid l) - then ( - print2 "Parsed module %s\n%s\n" - (Ident.string_of_lid l) - (List.map show ds |> String.concat "\n") - ) -(* Returns a non-desugared AST (as in [parser/ast.fs]) or aborts. *) -let parse_file fn = - match ParseIt.parse None (Filename fn) with - | ASTFragment (Inl ast, comments) -> - ast, comments - | ASTFragment (Inr _ , _) -> - let msg = Util.format1 "%s: expected a module\n" fn in - let r = Range.dummyRange in - raise_error r Errors.Fatal_ModuleExpected msg - | ParseError (e, msg, r) -> - raise_error r e msg - | Term _ -> - failwith "Impossible: parsing a Filename always results in an ASTFragment" - diff --git a/src/parser/FStar.Parser.Driver.fsti b/src/parser/FStar.Parser.Driver.fsti deleted file mode 100644 index f12a2284fe5..00000000000 --- a/src/parser/FStar.Parser.Driver.fsti +++ /dev/null @@ -1,34 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Parser.Driver - -module Range = FStar.Compiler.Range -module AST = FStar.Parser.AST -module AU = FStar.Parser.AST.Util -module ParseIt = FStar.Parser.ParseIt - -val is_cache_file : string -> bool - -type fragment = - | Empty - | Modul of AST.modul // an entire module or interface -- unspecified - | Decls of list AST.decl // a partial set of declarations - | DeclsWithContent of list (AST.decl & ParseIt.code_fragment) - -val parse_fragment : ParseIt.lang_opts -> ParseIt.input_frag -> fragment - -(* Returns a non-desugared AST (as in [parser/ast.fs]) or aborts. *) -val parse_file : string -> AST.file & list (string & Range.range) diff --git a/src/parser/FStar.Parser.ParseIt.fsti b/src/parser/FStar.Parser.ParseIt.fsti deleted file mode 100644 index 3ccbf41071e..00000000000 --- a/src/parser/FStar.Parser.ParseIt.fsti +++ /dev/null @@ -1,70 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Parser.ParseIt -open FStar.Compiler.Effect -open FStar.Parser -open FStar.Compiler.Util -open FStar -open FStar.Compiler -open FStar.Errors -module AU = FStar.Parser.AST.Util -type filename = string - -type input_frag = { - frag_fname:filename; - frag_text:string; - frag_line:int; - frag_col:int -} - -val read_vfs_entry : string -> option (time & string) -// This lets the ide tell us about edits not (yet) reflected on disk. -val add_vfs_entry: fname:string -> contents:string -> unit -// This reads mtimes from the VFS as well -val get_file_last_modification_time: fname:string -> time - -type parse_frag = - | Filename of filename - | Toplevel of input_frag - | Incremental of input_frag - | Fragment of input_frag - -type parse_error = (error_code & error_message & Range.range) - -type code_fragment = { - code: string; - range: FStar.Compiler.Range.range; -} - -type incremental_result 'a = - list ('a & code_fragment) & list (string & Range.range) & option parse_error - -type parse_result = - | ASTFragment of (AST.inputFragment & list (string & Range.range)) - | IncrementalFragment of incremental_result AST.decl - | Term of AST.term - | ParseError of parse_error - -let lang_opts = option string -val parse (ext_lang:lang_opts) - (frag:parse_frag) -: parse_result -val find_file: string -> string - -val parse_warn_error: string -> list FStar.Errors.error_setting - -(* useful for unit testing and registered a #lang-fstar parser *) -val parse_fstar_incrementally : AU.extension_lang_parser diff --git a/src/parser/FStar.Parser.ToDocument.fst b/src/parser/FStar.Parser.ToDocument.fst deleted file mode 100644 index f9aa3646505..00000000000 --- a/src/parser/FStar.Parser.ToDocument.fst +++ /dev/null @@ -1,2318 +0,0 @@ -(* - Copyright 2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -(** Convert Parser.Ast to Pprint.document for prettyprinting. *) -module FStar.Parser.ToDocument -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List - -open FStar -open FStar.Compiler -open FStar.Compiler.Util -open FStar.Parser.AST -open FStar.Ident -open FStar.Const -open FStar.Pprint -open FStar.Compiler.Range -open FStar.Class.Show - -module C = FStar.Parser.Const -module BU = FStar.Compiler.Util - - - -(* !!! SIDE EFFECT WARNING !!! *) -(* There is ONE use of global side-effect in the printer for : *) -(* - Printing the comments [comment_stack] *) - -let maybe_unthunk t = - match t.tm with - | Abs ([_], body) -> body - | _ -> t - -let min x y = if x > y then y else x -let max x y = if x > y then x else y - -// VD: copied over from NBE, should both probably go in FStar.Compiler.List -let map_rev (f: 'a -> 'b) (l: list 'a): list 'b = - let rec aux (l:list 'a) (acc:list 'b) = - match l with - | [] -> acc - | x :: xs -> aux xs (f x :: acc) - in - aux l [] - -let map_if_all (f: 'a -> option 'b) (l: list 'a): option (list 'b) = - let rec aux l acc = - match l with - | [] -> acc - | x :: xs -> - (match f x with - | Some r -> aux xs (r :: acc) - | None -> []) - in - let r = aux l [] in - if List.length l = List.length r then - Some r - else None - -let rec all (f: 'a -> bool) (l: list 'a): bool = - match l with - | [] -> true - | x :: xs -> if f x then all f xs else false - -let all1_explicit (args:list (term&imp)) : bool = - not (List.isEmpty args) && - BU.for_all (function - | (_, Nothing) -> true - | _ -> false) args - -// abbrev -let str s = doc_of_string s - -// lib -let default_or_map n f x = - match x with - | None -> n - | Some x' -> f x' - -// changing PPrint's ^//^ to ^/+^ since '//' wouldn't work in F# -let prefix2 prefix_ body = prefix 2 1 prefix_ body - -let prefix2_nonempty prefix_ body = - if body = empty then prefix_ else prefix2 prefix_ body - -let ( ^/+^ ) prefix_ body = prefix2 prefix_ body - -let jump2 body = - jump 2 1 body - -let infix2 = infix 2 1 -let infix0 = infix 0 1 - -let break1 = - break_ 1 - - -(* [separate_break_map sep f l] has the following - [(f l[0]) sep (f l[1]) ... sep (f l[n])] - and the following non flat layout - [(f l[0]) sep - (f l[1]) sep - ... - (f l[n])] -*) -let separate_break_map sep f l = - group (separate_map (space ^^ sep ^^ break1) f l) - -(* [precede_break_separate_map prec sep f l] has the flat layout - - [prec (f l[0]) sep (f l[1]) ... sep (f l[n])] - - and the following non flat layout - - [prec (f l[0]) - sep (f l[1]) - ... - sep (f l[n])] -*) -let precede_break_separate_map prec sep f l = - precede (prec ^^ space) (List.hd l |> f) ^^ concat_map (fun x -> break1 ^^ sep ^^ space ^^ f x) (List.tl l) - -let concat_break_map f l = group (concat_map (fun x -> f x ^^ break1) l) - -let parens_with_nesting contents = - surround 2 0 lparen contents rparen - -let soft_parens_with_nesting contents = - soft_surround 2 0 lparen contents rparen - -let braces_with_nesting contents = - surround 2 1 lbrace contents rbrace - -let soft_braces_with_nesting contents = - soft_surround 2 1 lbrace contents rbrace - -let soft_braces_with_nesting_tight contents = - soft_surround 2 0 lbrace contents rbrace - -let brackets_with_nesting contents = - surround 2 1 lbracket contents rbracket - -let soft_brackets_with_nesting contents = - soft_surround 2 1 lbracket contents rbracket - -let soft_lens_access_with_nesting contents = - soft_surround 2 1 (str "(|") contents (str "|)") - -let soft_brackets_lens_access_with_nesting contents = - soft_surround 2 1 (str "[|") contents (str "|]") - -let soft_begin_end_with_nesting contents = - soft_surround 2 1 (str "begin") contents (str "end") - -let tc_arg contents = - soft_surround 2 1 (str "{|") contents (str "|}") - -let is_tc_binder (b:binder) : bool = - match b.aqual with - | Some TypeClassArg -> true - | _ -> false - -let is_meta_qualifier aq = - match aq with - | Some (Meta _) -> true - | _ -> false - -let is_joinable_binder (b:binder) : bool = - not (is_tc_binder b) && not (is_meta_qualifier b.aqual) - -let separate_map_last sep f es = - let l = List.length es in - let es = List.mapi (fun i e -> f (i <> l - 1) e) es in - separate sep es - -let separate_break_map_last sep f l = - group (separate_map_last (space ^^ sep ^^ break1) f l) - -let separate_map_or_flow sep f l = - if List.length l < 10 - then separate_map sep f l - else flow_map sep f l - -let flow_map_last sep f es = - let l = List.length es in - let es = List.mapi (fun i e -> f (i <> l - 1) e) es in - flow sep es - -let separate_map_or_flow_last sep f l = - if List.length l < 10 - then separate_map_last sep f l - else flow_map_last sep f l - -let separate_or_flow sep l = separate_map_or_flow sep id l - -let surround_maybe_empty n b doc1 doc2 doc3 = - if doc2 = empty then - group (doc1 ^/^ doc3) - else - surround n b doc1 doc2 doc3 - -let soft_surround_separate_map n b void_ opening sep closing f xs = - if xs = [] - then void_ - else soft_surround n b opening (separate_map sep f xs) closing - -let soft_surround_map_or_flow n b void_ opening sep closing f xs = - if xs = [] - then void_ - else soft_surround n b opening (separate_map_or_flow sep f xs) closing - - -// Really specific functions to retro-engineer the desugaring -let is_unit e = - match e.tm with - | Const Const_unit -> true - | _ -> false - -let matches_var t x = - match t.tm with - | Var y -> (string_of_id x) = string_of_lid y - | _ -> false - -let is_tuple_constructor = C.is_tuple_data_lid' -let is_dtuple_constructor = C.is_dtuple_data_lid' - -let is_array e = match e.tm with - (* TODO check that there is no implicit parameters *) - | App ({tm=Var lid}, l, Nothing) -> lid_equals lid C.array_of_list_lid && ListLiteral? l.tm - | _ -> false - -let rec is_ref_set e = match e.tm with - | Var maybe_empty_lid -> lid_equals maybe_empty_lid C.set_empty - | App ({tm=Var maybe_singleton_lid}, {tm=App({tm=Var maybe_addr_of_lid}, e, Nothing)}, Nothing) -> - lid_equals maybe_singleton_lid C.set_singleton && lid_equals maybe_addr_of_lid C.heap_addr_of_lid - | App({tm=App({tm=Var maybe_union_lid}, e1, Nothing)}, e2, Nothing) -> - lid_equals maybe_union_lid C.set_union && is_ref_set e1 && is_ref_set e2 - | _ -> false - -(* [extract_from_ref_set e] assumes that [is_ref_set e] holds and returns the list of terms contained in the set *) -let rec extract_from_ref_set e = match e.tm with - | Var _ -> [] - | App ({tm=Var _}, {tm=App({tm=Var _}, e, Nothing)}, Nothing) -> [e] - | App({tm = App({tm=Var _}, e1, Nothing)}, e2, Nothing) -> - extract_from_ref_set e1 @ extract_from_ref_set e2 - | _ -> failwith (Util.format1 "Not a ref set %s" (term_to_string e)) - -let is_general_application e = - not (is_array e || is_ref_set e) - -let is_general_construction e = - not (ListLiteral? e.tm) - -let is_general_prefix_op op = - let op_starting_char = char_at (Ident.string_of_id op) 0 in - op_starting_char = '!' || op_starting_char = '?' || - (op_starting_char = '~' && Ident.string_of_id op <> "~") - -(* might already exist somewhere *) -let head_and_args e = - let rec aux e acc = match e.tm with - | App (head, arg, imp) -> aux head ((arg,imp)::acc) - | _ -> e, acc - in aux e [] - - -(* Automatic level assignment *) -(* would be perfect with a little of staging... *) -(* TODO : see if we can plug in the menhir inspection API so that *) -(* the level_associativity_spec table below is produced by the parser *) - -type associativity = - | Left - | Right - | NonAssoc - -(* A token is either a character c representing any string beginning with c, a complete string or a unicode operator *) -type token = - | StartsWith: Char.char -> token - | Exact : string -> token - | UnicodeOperator - -type associativity_level = associativity & list token - -let token_to_string = function - | StartsWith c -> string_of_char c ^ ".*" - | Exact s -> s - | UnicodeOperator -> "" - -let is_non_latin_char (s:Char.char): bool - = int_of_char s > 0x024f - -let matches_token (s:string) = function - | StartsWith c -> FStar.Compiler.String.get s 0 = c - | Exact s' -> s = s' - | UnicodeOperator -> is_non_latin_char (FStar.Compiler.String.get s 0) - -let matches_level s (assoc_levels, tokens) = - List.tryFind (matches_token s) tokens <> None - -// GM 05/10/18, TODO: This still needs to be heavily annotated with the new unifier: - -(* Precedence and associativity levels, taken from ../src/parse.mly *) -let opinfix4 : associativity_level = Right, [Exact "**"; UnicodeOperator] -// level backtick won't be used here -let opinfix3 : associativity_level = Left, [StartsWith '*' ; StartsWith '/' ; StartsWith '%'] -let opinfix2 : associativity_level = Left, [StartsWith '+' ; StartsWith '-' ] -let minus_lvl : associativity_level = Left, [Exact "-"] // Sublevel of opinfix2, not a level on its own !!! -let opinfix1 : associativity_level = Right, [StartsWith '@' ; StartsWith '^'] -let pipe_right : associativity_level = Left, [Exact "|>"] -let opinfix0d : associativity_level = Left, [StartsWith '$'] -let opinfix0c : associativity_level = Left, [StartsWith '=' ; StartsWith '<' ; StartsWith '>'] -let equal : associativity_level = Left, [Exact "="] // Sublevel of opinfix0c, not a level on its own !!! -let opinfix0b : associativity_level = Left, [StartsWith '&'] -let opinfix0a : associativity_level = Left, [StartsWith '|'] -let colon_equals : associativity_level = NonAssoc, [Exact ":="] -let amp : associativity_level = Right, [Exact "&"] -let colon_colon : associativity_level = Right, [Exact "::"] - -(* The latter the element, the tighter it binds *) -let level_associativity_spec : list associativity_level = - [ - opinfix4 ; - opinfix3 ; - opinfix2 ; - opinfix1 ; - pipe_right ; - opinfix0d ; - opinfix0c ; - opinfix0b ; - opinfix0a ; - colon_equals ; - amp ; - colon_colon ; - ] - -let level_table = - let levels_from_associativity (l:int) = function - | Left -> l, l, l-1 - | Right -> l-1, l, l - | NonAssoc -> l - 1, l, l - 1 - in - List.mapi (fun i (assoc, tokens) -> (levels_from_associativity i assoc, tokens)) level_associativity_spec - -let assign_levels (token_associativity_spec : list associativity_level) (s:string) : int & int & int = - match List.tryFind (matches_level s) level_table with - | Some (assoc_levels, _) -> assoc_levels - | _ -> failwith ("Unrecognized operator " ^ s) - -let max_level l = - let find_level_and_max n level = - match List.tryFind (fun (_, tokens) -> tokens = snd level) level_table with - | Some ((_,l,_), _) -> max n l - | None -> failwith (Util.format1 "Undefined associativity level %s" - (String.concat "," (List.map token_to_string (snd level)))) - in List.fold_left find_level_and_max 0 l - -let levels op = - (* See comment in parse.fsy: tuples MUST be parenthesized because [t & u & v] - * is not the same thing as [(t & u) & v]. So, we are conservative and make an - * exception for the "&" operator and treat it as, really, non-associative. If - * the AST comes from the user, then the Paren node was there already and no - * extra parentheses are added. If the AST comes from some client inside of - * the F* compiler that doesn't know about this quirk, then it forces it to be - * parenthesized properly. In case the user overrode & to be a truly - * associative operator then we're just being a little - * conservative because, unlike ToSyntax.fs, we don't have lexical context to - * help us determine which operator this is, really. *) - let left, mine, right = assign_levels level_associativity_spec op in - if op = "&" then - left - 1, mine, right - else - left, mine, right - -let operatorInfix0ad12 = [opinfix0a ; opinfix0b ; opinfix0c ; opinfix0d ; opinfix1 ; opinfix2 ] - -let is_operatorInfix0ad12 op = - List.tryFind (matches_level <| Ident.string_of_id op) operatorInfix0ad12 <> None - -let is_operatorInfix34 = - let opinfix34 = [ opinfix3 ; opinfix4 ] in - fun op -> List.tryFind (matches_level <| Ident.string_of_id op) opinfix34 <> None - -let handleable_args_length (op:ident) = - let op_s = Ident.string_of_id op in - if is_general_prefix_op op || List.mem op_s [ "-" ; "~" ] then 1 - else if (is_operatorInfix0ad12 op || - is_operatorInfix34 op || - List.mem op_s ["<==>" ; "==>" ; "\\/" ; "/\\" ; "=" ; "|>" ; ":=" ; ".()" ; ".[]"; ".(||)"; ".[||]"]) - then 2 - else if (List.mem op_s [".()<-" ; ".[]<-"; ".(||)<-"; ".[||]<-"]) then 3 - else 0 - -let handleable_op op args = - match List.length args with - | 0 -> true - | 1 -> is_general_prefix_op op || List.mem (Ident.string_of_id op) [ "-" ; "~" ] - | 2 -> - is_operatorInfix0ad12 op || - is_operatorInfix34 op || - List.mem (Ident.string_of_id op) ["<==>" ; "==>" ; "\\/" ; "/\\" ; "=" ; "|>" ; ":=" ; ".()" ; ".[]"; ".(||)"; ".[||]"] - | 3 -> List.mem (Ident.string_of_id op) [".()<-" ; ".[]<-"; ".(||)<-"; ".[||]<-"] - | _ -> false - - -// Style choice for type signatures. Depending on available space, they -// can be printed in one of three ways: -// (1) all on the same line -// (2) all on the same line, except the computation type, which is -// pushed on a new line -// (3) keyword and identifier on one line, then every binder and the -// computation type on separate lines; binders can also be spread over -// multiple lines -// In case (2), the first parameter controls indentation for the -// computation type. In case (3), first parameter is indentation for each -// of the binders, second parameter is indendation for the computation -// type. -// The third parameter in Binders controls whether each binder is -// paranthesised -type annotation_style = - | Binders of int & int & bool // val f (x1:t1) ... (xn:tn) : C - | Arrows of int & int // val f : x1:t1 -> ... -> xn:tn -> C - -// decide whether a type signature can be printed in the format -// val f (x1:t1) ... (xn:tn) : C -// it can't if either not all args are annotated binders or if it has no -// arguments, in which case it will be printed using the colon + arrows style -let all_binders_annot e = - let is_binder_annot b = - match b.b with - | Annotated _ -> true - | _ -> false - in - let rec all_binders e l = - match e.tm with - | Product(bs, tgt) -> - if List.for_all is_binder_annot bs then - all_binders tgt (l+ List.length bs) - else - (false, 0) - | _ -> (true, l+1) - in - let b, l = all_binders e 0 in - if b && l > 1 then true else false - -type catf = document -> document -> document -let cat_with_colon x y = x ^^ colon ^/^ y - - -(* ****************************************************************************) -(* *) -(* Taking care of comments *) -(* *) -(* ****************************************************************************) - -(* Comments are not part of the AST but can be collected by the lexer so that we *) -(* can try to reinstate them when printing. Since they are not inside the AST, we *) -(* need to find some valid place to place them back. *) - -(* We assume that comments are tagged by their original position (a range) and *) -(* that they are given in the order they appear. Then we use the range information *) -(* inside the printed AST to reinstate the comments. *) - -(* The rules for placing comments are : *) -(* 1. There is at most one comment per line *) -(* 2. Line feeds between comments occuring between two toplevel declarations are *) -(* preserved *) -(* 3. A comment is printed just before some AST node if it has not been printed *) -(* before and its range ends before the end of the line where the AST node *) -(* was originally *) -(* 4. Left-over comments are always printed even if the position could be meaningless *) -(* 5. The AST node on which comments can be attached are the one using the *) -(* [with_comment] function defined just below *) - -(* Since comments are using side effects to be printed in the correct order it is important *) -(* that all printed AST nodes that could eventually contain a comment are printed in the *) -(* sequential order of the document. *) - -let comment_stack : ref (list (string&range))= BU.mk_ref [] - -(* some meta-information that informs spacing and the placement of comments around a declaration *) -type decl_meta = - {r: range; - has_qs: bool; //has quantifiers - has_attrs: bool; //has attributes - } -let dummy_meta = {r = dummyRange; has_qs = false; has_attrs = false} - -// TODO: rewrite in terms of with_comment_sep (some tricky issues with spacing) -let with_comment printer tm tmrange = - let rec comments_before_pos acc print_pos lookahead_pos = - match !comment_stack with - | [] -> acc, false - | (c, crange) :: cs -> - let comment = str c ^^ hardline in - if range_before_pos crange print_pos - then begin - comment_stack := cs ; - comments_before_pos (acc ^^ comment) print_pos lookahead_pos - end - else acc, range_before_pos crange lookahead_pos - in - let comments, has_lookahead = - comments_before_pos empty (end_of_line ( start_of_range tmrange)) (end_of_range tmrange) - in - let printed_e = printer tm in - let comments = - if has_lookahead - then - let pos = end_of_range tmrange in - fst (comments_before_pos comments pos pos) - else comments - in - if comments = empty then - printed_e - else - group (comments ^^ printed_e) - -let with_comment_sep printer tm tmrange = - let rec comments_before_pos acc print_pos lookahead_pos = - match !comment_stack with - | [] -> acc, false - | (c, crange) :: cs -> - let comment = str c in - if range_before_pos crange print_pos - then begin - comment_stack := cs ; - comments_before_pos (if acc = empty then comment else acc ^^ hardline ^^ comment) print_pos lookahead_pos - end - else acc, range_before_pos crange lookahead_pos - in - let comments, has_lookahead = - comments_before_pos empty (end_of_line ( start_of_range tmrange)) (end_of_range tmrange) - in - let printed_e = printer tm in - let comments = - if has_lookahead - then - let pos = end_of_range tmrange in - fst (comments_before_pos comments pos pos) - else comments - in - comments, printed_e - - -(* [place_comments_until_pos k lbegin pos doc r init] appends to doc all the comments present in *) -(* [comment_stack] whose range is before pos and separate each comments by as many lines *) -(* as indicated by the range information (at least [k]) using [lbegin] as the last line of *) -(* [doc] in the original document. Between 2 comments [k] is set to [1] *) -(* r is true if this is a recursive call (i.e. a comment has been placed) *) -(* init is true when placing the initial comment *) -let rec place_comments_until_pos (k: int) (lbegin: int) pos meta_decl doc (r: bool) (init: bool) = - match !comment_stack with - | (comment, crange) :: cs when range_before_pos crange pos -> - comment_stack := cs ; - let lnum = max k (line_of_pos (start_of_range crange) - lbegin) in - let lnum = min 2 lnum in - let doc = doc ^^ repeat lnum hardline ^^ str comment in - place_comments_until_pos 1 (line_of_pos (end_of_range crange)) pos meta_decl doc true init - | _ -> - if doc = empty then - empty - else - // lnum is initially (approximately) the number of newlines between the end of the previous declaration - // and the beginning of the one currently being printed, in the original source file (which may change - // during prettyprinting), not accounting for qualifiers and attributes; as a consequence, - // we have to massage this number in the following steps in order to achieve some sensible spacing and - // to keep prettyprinting idempotent - let lnum = line_of_pos pos - lbegin in - - // limit the number of newlines between declarations to 3 (2 empty lines in between) - let lnum = min 3 lnum in - - // range information does not include qualifiers or attributes (the start position is at "let"), - // so we need to account for (at least) one extra line - let lnum = if meta_decl.has_qs || meta_decl.has_attrs then lnum - 1 else lnum in - - // make sure lnum is not smaller than k - let lnum = max k lnum in - - // if the declaration has both qualifiers and attributes (which each go on a separate line) - // force exactly 2 spaces; this compromise will mean that the following declaration is always - // separated by exactly 1 empty line - let lnum = if meta_decl.has_qs && meta_decl.has_attrs then 2 else lnum in - - // if the module begins with a comment, force exactly 2 newlines between it and the following declaration - let lnum = if init then 2 else lnum in - - doc ^^ repeat lnum hardline - - -(* [separate_map_with_comments prefix sep f xs extract_meta] is the document *) -(* *) -(* prefix (f xs[0]) *) -(* comments[0] *) -(* sep (f xs[1]) *) -(* comments[1] *) -(* ... *) -(* sep (f xs[n]) *) -(* *) -(* where comments[_] are obtained by successive calls to [place_comments_until_pos] *) -(* using the range and metainformation provided by [extract_meta] and the comments in *) -(* [comment_stack]. [xs] must contain at least one element. There is no break *) -(* inserted after [prefix] and [sep]. *) -let separate_map_with_comments prefix sep f xs extract_meta = - let fold_fun (last_line, doc) x = - let meta_decl = extract_meta x in - let r = meta_decl.r in - let doc = place_comments_until_pos 1 last_line (start_of_range r) meta_decl doc false false in - line_of_pos (end_of_range r), doc ^^ sep ^^ f x - in - let x, xs = List.hd xs, List.tl xs in - let init = - let meta_decl = extract_meta x in - line_of_pos (end_of_range meta_decl.r), prefix ^^ f x - in - snd (List.fold_left fold_fun init xs) - -(* [separate_map_with_comments_kw prefix sep f xs extract_meta] is the same *) -(* as separate_map_with_comments but the keyword is also passed as an *) -(* argument to f, resulting in *) -(* *) -(* (f prefix xs[0]) *) -(* comments[0] *) -(* f spe xs[1]) *) -(* comments[1] *) -(* ... *) -(* (f sep xs[n]) *) -let separate_map_with_comments_kw prefix sep f xs extract_meta = - let fold_fun (last_line, doc) x = - let meta_decl = extract_meta x in - let r = meta_decl.r in - let doc = place_comments_until_pos 1 last_line (start_of_range r) meta_decl doc false false in - line_of_pos (end_of_range r), doc ^^ f sep x - in - let x, xs = List.hd xs, List.tl xs in - let init = - let meta_decl = extract_meta x in - line_of_pos (end_of_range meta_decl.r), f prefix x - in - snd (List.fold_left fold_fun init xs) - -let p_lidentOrOperator' l s_l p_l = - let lstr = s_l l in - if lstr `starts_with` "op_" then - match AST.string_to_op lstr with - | None -> - str "( " ^^ p_l l ^^ str " )" - | Some (s, _) -> - str "( " ^^ str s ^^ str " )" - else - p_l l - -(* ****************************************************************************) -(* *) -(* Printing identifiers and module paths *) -(* *) -(* ****************************************************************************) - -let string_of_id_or_underscore lid = - if starts_with (string_of_id lid) reserved_prefix && not (Options.print_real_names ()) - then underscore - else str (string_of_id lid) - -let text_of_lid_or_underscore lid = - if starts_with (string_of_id (ident_of_lid lid)) reserved_prefix && not (Options.print_real_names ()) - then underscore - else str (string_of_lid lid) - -let p_qlident lid = - text_of_lid_or_underscore lid - -let p_quident lid = - text_of_lid_or_underscore lid - -let p_ident lid = - string_of_id_or_underscore lid - -let p_lident lid = - string_of_id_or_underscore lid - -let p_uident lid = - string_of_id_or_underscore lid - -let p_tvar lid = - string_of_id_or_underscore lid - -let p_qlidentOrOperator lid = - p_lidentOrOperator' lid Ident.string_of_lid p_qlident - -let p_lidentOrOperator lid = - p_lidentOrOperator' lid Ident.string_of_id p_lident - - - -(* ****************************************************************************) -(* *) -(* Printing declarations *) -(* *) -(* ****************************************************************************) -let rec p_decl (d: decl): document = - let qualifiers= - (* Don't push 'assume' on a new line when it used as a keyword *) - match (d.quals, d.d) with - | ([Assumption], Assume(id, _)) -> - if char_at (string_of_id id) 0 |> is_upper then - p_qualifier Assumption ^^ space - else - p_qualifiers d.quals - | _ -> p_qualifiers d.quals - in - p_attributes true d.attrs ^^ - qualifiers ^^ - p_rawDecl d - -and p_attributes isTopLevel attrs = - match attrs with - | [] -> empty - | _ -> lbracket ^^ str (if isTopLevel then "@@ " else "@@@ ") ^^ - align ((flow (str "; ") (List.map (p_noSeqTermAndComment false false) attrs)) ^^ rbracket) ^^ (if isTopLevel then hardline else empty) - -and p_justSig d = match d.d with - | Val (lid, t) -> - (str "val" ^^ space ^^ p_lidentOrOperator lid ^^ space ^^ colon) ^^ p_typ false false t - | TopLevelLet (_, lbs) -> - separate_map hardline (fun lb -> group (p_letlhs (str "let") lb false)) lbs - | _ -> - empty - -and p_list #t (f: t -> _) sep l = - let rec p_list' = function - | [] -> empty - | [x] -> f x - | x::xs -> f x ^^ sep ^^ p_list' xs - in - str "[" ^^ p_list' l ^^ str "]" - -and p_restriction - = let open FStar.Syntax.Syntax in - function | Unrestricted -> empty - | AllowList ids -> - space - ^^ lbrace - ^^ p_list (fun (id, renamed) -> - p_ident id ^/^ optional p_ident renamed - ) (str ", ") ids - ^^ rbrace - -and p_rawDecl d = match d.d with - | Open (uid, r) -> - group (str "open" ^/^ p_quident uid ^/^ p_restriction r) - | Include (uid, r) -> - group (str "include" ^/^ p_quident uid ^/^ p_restriction r) - | Friend uid -> - group (str "friend" ^/^ p_quident uid) - | ModuleAbbrev (uid1, uid2) -> - (str "module" ^^ space ^^ p_uident uid1 ^^ space ^^ equals) ^/+^ p_quident uid2 - | TopLevelModule uid -> - group(str "module" ^^ space ^^ p_quident uid) - | Tycon(true, _, [TyconAbbrev(uid, tpars, None, t)]) -> - let effect_prefix_doc = str "effect" ^^ space ^^ p_uident uid in - surround 2 1 effect_prefix_doc (p_typars tpars) equals ^/+^ p_typ false false t - | Tycon(false, tc, tcdefs) -> - let s = if tc then str "class" else str "type" in - (p_typeDeclWithKw s (List.hd tcdefs)) ^^ - (concat_map (fun x -> break1 ^^ p_typeDeclWithKw (str "and") x) <| List.tl tcdefs) - | TopLevelLet(q, lbs) -> - let let_doc = str "let" ^^ p_letqualifier q in - separate_map_with_comments_kw let_doc (str "and") p_letbinding lbs - (fun (p, t) -> - { r = Range.union_ranges p.prange t.range; - has_qs = false; - has_attrs = false; }) - | Val(lid, t) -> - group <| str "val" ^^ space ^^ p_lidentOrOperator lid ^^ (sig_as_binders_if_possible t false) - (* KM : not exactly sure which one of the cases below and above is used for 'assume val ..'*) - | Assume(id, t) -> - let decl_keyword = - if char_at (string_of_id id) 0 |> is_upper - then empty - else str "val" ^^ space - in - decl_keyword ^^ p_ident id ^^ group (colon ^^ space ^^ (p_typ false false t)) - | Exception(uid, t_opt) -> - str "exception" ^^ space ^^ p_uident uid ^^ optional (fun t -> break1 ^^ str "of" ^/+^ p_typ false false t) t_opt - | NewEffect(ne) -> - str "new_effect" ^^ space ^^ p_newEffect ne - | SubEffect(se) -> - str "sub_effect" ^^ space ^^ p_subEffect se - | LayeredEffect(ne) -> - str "layered_effect" ^^ space ^^ p_newEffect ne - | Polymonadic_bind (l1, l2, l3, t) -> - (str "polymonadic_bind") - ^^ lparen ^^ p_quident l1 ^^ comma ^^ break1 ^^ p_quident l2 ^^ rparen - ^^ (str "|>") ^^ p_quident l3 ^^ equals ^^ p_simpleTerm false false t - | Pragma p -> - p_pragma p - | Tycon(true, _, _) -> - failwith "Effect abbreviation is expected to be defined by an abbreviation" - | Splice (is_typed, ids, t) -> - str "%splice" ^^ - (if is_typed then str "_t" else empty) ^^ - p_list p_uident (str ";") ids ^^ space ^^ p_term false false t - | DeclSyntaxExtension (tag, blob, blob_rng, start_rng) -> - // NB: using ^^ since the blob also contains the newlines - doc_of_string ("```"^tag) ^^ - arbitrary_string blob ^^ - doc_of_string "```" - | DeclToBeDesugared tbs -> - arbitrary_string <| tbs.to_string tbs.blob - -and p_pragma = function - | ShowOptions -> str "#show-options" - | SetOptions s -> str "#set-options" ^^ space ^^ dquotes (str s) - | ResetOptions s_opt -> str "#reset-options" ^^ optional (fun s -> space ^^ dquotes (str s)) s_opt - | PushOptions s_opt -> str "#push-options" ^^ optional (fun s -> space ^^ dquotes (str s)) s_opt - | PopOptions -> str "#pop-options" - | RestartSolver -> str "#restart-solver" - | PrintEffectsGraph -> str "#print-effects-graph" - -(* TODO : needs to take the F# specific type instantiation *) -and p_typars (bs: list binder): document = p_binders true bs - -and p_typeDeclWithKw kw typedecl = - let comm, decl, body, pre = p_typeDecl kw typedecl in - if comm = empty then - decl ^^ pre body - else - group <| ifflat - (decl ^^ pre body ^/^ comm) - (decl ^^ nest 2 (hardline ^^ comm ^^ hardline ^^ body)) - -(* [p_typeDecl pre decl] takes a prefix and a declaration and returns a comment associated with the *) -(* declaration, the formatted declaration, its body, and a spacing function which should be applied to *) -(* the body in order to correctly space it from the declaration if there is no comment present or if *) -(* the comment can be inlined after the body *) -and p_typeDecl pre = function - | TyconAbstract (lid, bs, typ_opt) -> - empty, p_typeDeclPrefix pre false lid bs typ_opt, empty, id - | TyconAbbrev (lid, bs, typ_opt, t) -> - let comm, doc = p_typ_sep false false t in - comm, p_typeDeclPrefix pre true lid bs typ_opt, doc, jump2 - | TyconRecord (lid, bs, typ_opt, attrs, record_field_decls) -> - empty - , p_typeDeclPrefix pre true lid bs typ_opt - , p_attributes false attrs ^^ p_typeDeclRecord record_field_decls - , (fun d -> space ^^ d) - | TyconVariant (lid, bs, typ_opt, ct_decls) -> - let p_constructorBranchAndComments (uid, payload, attrs) = - let range = extend_to_end_of_line ( - dflt (range_of_id uid) - (bind_opt payload - (function | VpOfNotation t | VpArbitrary t -> Some t.range - | VpRecord (record, _) -> None))) in - let comm, ctor = with_comment_sep p_constructorBranch (uid, payload, attrs) range in - inline_comment_or_above comm ctor empty - in - (* Beware of side effects with comments printing *) - let datacon_doc = - separate_map hardline p_constructorBranchAndComments ct_decls - in - empty, p_typeDeclPrefix pre true lid bs typ_opt, datacon_doc, jump2 -and p_typeDeclRecord (fields: tycon_record): document = - let p_recordField (ps: bool) (lid, aq, attrs, t) = - let comm, field = - with_comment_sep (p_recordFieldDecl ps) (lid, aq, attrs, t) - (extend_to_end_of_line t.range) in - let sep = if ps then semi else empty in - inline_comment_or_above comm field sep - in - separate_map_last hardline p_recordField fields |> braces_with_nesting - -and p_typeDeclPrefix kw eq lid bs typ_opt = - let with_kw cont = - let lid_doc = p_ident lid in - let kw_lid = group (kw ^/^ lid_doc) in - cont kw_lid - in - let typ = - let maybe_eq = if eq then equals else empty in - match typ_opt with - | None -> maybe_eq - | Some t -> colon ^^ space ^^ (p_typ false false t) ^/^ maybe_eq - in - if bs = [] - then - with_kw (fun n -> prefix2 n typ) - else - let binders = p_binders_list true bs in - with_kw (fun n -> prefix2 (prefix2 n (flow break1 binders)) typ) - -and p_recordFieldDecl ps (lid, aq, attrs, t) = - group (optional p_aqual aq ^^ - p_attributes false attrs ^^ - p_lidentOrOperator lid ^^ - colon ^^ - p_typ ps false t) - -and p_constructorBranch (uid, variant, attrs) = - let h isOf t = (if isOf then str "of" else colon) ^^ space ^^ p_typ false false t - in group (bar ^^ space ^^ p_attributes false attrs ^^ p_uident uid) - ^^ default_or_map empty - (fun payload -> space ^^ group - ( match payload with - | VpOfNotation t -> h true t | VpArbitrary t -> h false t - | VpRecord (r, t) -> p_typeDeclRecord r ^^ default_or_map empty (h false) t - )) variant -and p_letlhs kw (pat, _) inner_let = - (* TODO : this should be refined when head is an applicative pattern (function definition) *) - let pat, ascr = - // if the let binding was written in arrow style, the arguments will be in t - // if it was written in binders style then they will be in pat - match pat.pat with - | PatAscribed (pat, (t, None)) -> pat, Some (t, empty) - | PatAscribed (pat, (t, Some tac)) -> pat, Some (t, group (space ^^ str "by" ^^ space ^^ p_atomicTerm (maybe_unthunk tac))) - | _ -> pat, None - in - match pat.pat with - | PatApp ({pat=PatVar (lid, _, _)}, pats) -> - (* has binders *) - let ascr_doc = - (match ascr with - | Some (t, tac) -> (sig_as_binders_if_possible t true) ^^ tac - | None -> empty) - in - let terms, style = - // VD: should we indent inner lets less? - if inner_let then - let bs, style = pats_as_binders_if_possible pats in - bs, style - else - let bs, style = pats_as_binders_if_possible pats in - bs, style - in - group <| kw ^^ space ^^ p_lidentOrOperator lid ^^ (format_sig style terms ascr_doc true true) - | _ -> - (* doesn't have binders *) - let ascr_doc = - (match ascr with - | Some (t, tac) -> group (colon ^^ p_typ_top (Arrows (2, 2)) false false t) ^^ tac - | None -> empty) - in - group (group (kw ^/^ p_tuplePattern pat) ^^ ascr_doc) - -and p_letbinding kw (pat, e) = - let doc_pat = p_letlhs kw (pat, e) false in - let comm, doc_expr = p_term_sep false false e in - let doc_expr = inline_comment_or_above comm doc_expr empty in - ifflat (doc_pat ^/^ equals ^/^ doc_expr) (doc_pat ^^ space ^^ group (equals ^^ jump2 doc_expr)) - -and p_term_list ps pb l = - let rec aux = function - | [] -> empty - | [x] -> p_term ps pb x - | x::xs -> p_term ps pb x ^^ str ";" ^^ aux xs - in - str "[" ^^ aux l ^^ str "]" - - -(* ****************************************************************************) -(* *) -(* Printing effects *) -(* *) -(* ****************************************************************************) - -and p_newEffect = function - | RedefineEffect (lid, bs, t) -> - p_effectRedefinition lid bs t - | DefineEffect (lid, bs, t, eff_decls) -> - p_effectDefinition lid bs t eff_decls - -and p_effectRedefinition uid bs t = - surround_maybe_empty 2 1 (p_uident uid) (p_binders true bs) (prefix2 equals (p_simpleTerm false false t)) - -and p_effectDefinition uid bs t eff_decls = - let binders = p_binders true bs in - braces_with_nesting ( - group (surround_maybe_empty 2 1 (p_uident uid) (p_binders true bs) (prefix2 colon (p_typ false false t))) ^/^ - (str "with") ^^ hardline ^^ space ^^ space ^^ (separate_map_last (hardline ^^ semi ^^ space) p_effectDecl eff_decls)) - -and p_effectDecl ps d = match d.d with - | Tycon(false, _, [TyconAbbrev(lid, [], None, e)]) -> - prefix2 (p_lident lid ^^ space ^^ equals) (p_simpleTerm ps false e) - | _ -> - failwith (Util.format1 "Not a declaration of an effect member... or at least I hope so : %s" - (show d)) - -and p_subEffect lift = - let lift_op_doc = - let lifts = - match lift.lift_op with - | NonReifiableLift t -> ["lift_wp", t] - | ReifiableLift (t1, t2) -> ["lift_wp", t1 ; "lift", t2] - | LiftForFree t -> ["lift", t] - in - let p_lift ps (kwd, t) = prefix2 (str kwd ^^ space ^^ equals) (p_simpleTerm ps false t) in - separate_break_map_last semi p_lift lifts - in - prefix2 (p_quident lift.msource ^^ space ^^ str "~>") (p_quident lift.mdest) ^^ - space ^^ braces_with_nesting lift_op_doc - - -(* ****************************************************************************) -(* *) -(* Printing qualifiers, tags *) -(* *) -(* ****************************************************************************) - -and p_qualifier = function - | Private -> str "private" - | Noeq -> str "noeq" - | Unopteq -> str "unopteq" - | Assumption -> str "assume" - | DefaultEffect -> str "default" - | TotalEffect -> str "total" - | Effect_qual -> empty - | New -> str "new" - | Inline -> str "inline" - | Visible -> empty - | Unfold_for_unification_and_vcgen -> str "unfold" - | Inline_for_extraction -> str "inline_for_extraction" - | Irreducible -> str "irreducible" - | NoExtract -> str "noextract" - | Reifiable -> str "reifiable" - | Reflectable -> str "reflectable" - | Opaque -> str "opaque" - | Logic -> str "logic" - -and p_qualifiers qs = - match qs with - | [] -> empty - | [q] -> (p_qualifier q) ^^ hardline - | _ -> flow break1 (List.map p_qualifier qs) ^^ hardline - -(* Skipping focus since it cannot be recoverred at printing *) - -and p_letqualifier = function - | Rec -> space ^^ str "rec" - | NoLetQualifier -> empty - -(* This prints both arg qualifiers and binder qualifiers. Note that Meta and -Typeclass do not make sense for arg qualifiers. *) -and p_aqual = function - | Implicit -> str "#" - | Equality -> str "$" - | Meta t -> - let t = - match t.tm with - | Abs (_ ,e) -> e - | _ -> mk_term (App (t, unit_const t.range, Nothing)) t.range Expr - in - str "#[" ^^ p_term false false t ^^ str "]" ^^ break1 - | TypeClassArg -> empty (* This is handled externally *) - -(* ****************************************************************************) -(* *) -(* Printing patterns and binders *) -(* *) -(* ****************************************************************************) - -and p_disjunctivePattern p = match p.pat with - | PatOr pats -> - group (separate_map (break1 ^^ bar ^^ space) p_tuplePattern pats) - | _ -> p_tuplePattern p - -and p_tuplePattern p = match p.pat with - | PatTuple (pats, false) -> - group (separate_map (comma ^^ break1) p_constructorPattern pats) - | _ -> - p_constructorPattern p - -and p_constructorPattern p = match p.pat with - | PatApp({pat=PatName maybe_cons_lid}, [hd ; tl]) when lid_equals maybe_cons_lid C.cons_lid -> - infix0 (colon ^^ colon) (p_constructorPattern hd) (p_constructorPattern tl) - | PatApp ({pat=PatName uid}, pats) -> - prefix2 (p_quident uid) (separate_map break1 p_atomicPattern pats) - | _ -> - p_atomicPattern p - -and p_atomicPattern p = match p.pat with - | PatAscribed (pat, (t, None)) -> - (* This inverts the first rule of atomicPattern (LPAREN tuplePattern COLON - * simpleArrow RPAREN). *) - begin match pat.pat, t.tm with - | PatVar (lid, aqual, attrs), Refine({b = Annotated(lid', t)}, phi) - when (string_of_id lid) = (string_of_id lid') -> - (* p_refinement jumps into p_appTerm for the annotated type; this is - * tighter than simpleArrow (which is what the parser uses), meaning that - * this printer may conservatively insert parentheses. TODO fix, but be - * aware that there are multiple callers to p_refinement and that - * p_appTerm is probably the lower bound of all expected levels. *) - soft_parens_with_nesting (p_refinement aqual attrs (p_ident lid) t phi) - | PatWild (aqual, attrs), Refine({b = NoName t}, phi) -> - soft_parens_with_nesting (p_refinement aqual attrs underscore t phi) - | PatVar (_, aqual, _), _ - | PatWild (aqual, _), _ -> - let wrap = - if aqual = Some TypeClassArg - then tc_arg - else soft_parens_with_nesting - in - wrap (p_tuplePattern pat ^^ colon ^/^ p_tmEqNoRefinement t) - | _ -> - (* TODO implement p_simpleArrow *) - soft_parens_with_nesting (p_tuplePattern pat ^^ colon ^/^ p_tmEqNoRefinement t) - end - | PatList pats -> - surround 2 0 lbracket (separate_break_map semi p_tuplePattern pats) rbracket - | PatRecord pats -> - let p_recordFieldPat (lid, pat) = infix2 equals (p_qlident lid) (p_tuplePattern pat) in - soft_braces_with_nesting (separate_break_map semi p_recordFieldPat pats) - | PatTuple(pats, true) -> - surround 2 1 (lparen ^^ bar) (separate_break_map comma p_constructorPattern pats) (bar ^^ rparen) - | PatTvar (tv, arg_qualifier_opt, attrs) -> - assert (arg_qualifier_opt = None) ; - assert (attrs = []); - p_tvar tv - | PatOp op -> - lparen ^^ space ^^ str (Ident.string_of_id op) ^^ space ^^ rparen - | PatWild (aqual, attrs) -> - optional p_aqual aqual ^^ p_attributes false attrs ^^ underscore - | PatConst c -> - p_constant c - | PatVQuote e -> group (str "`%" ^^ p_noSeqTermAndComment false false e) - | PatVar (lid, aqual, attrs) -> - optional p_aqual aqual ^^ p_attributes false attrs ^^ p_lident lid - | PatName uid -> - p_quident uid - | PatOr _ -> failwith "Inner or pattern !" - | PatApp ({pat = PatName _}, _) - | PatTuple (_, false) -> - soft_parens_with_nesting (p_tuplePattern p) - | _ -> failwith (Util.format1 "Invalid pattern %s" (pat_to_string p)) - -(* Skipping patternOrMultibinder since it would need retro-engineering the flattening of binders *) - -and is_typ_tuple e = match e.tm with - | Op(id, _) when string_of_id id = "*" -> true - | _ -> false - -and p_binder is_atomic b = - let is_tc = is_tc_binder b in - let b', t' = p_binder' false (is_atomic && not is_tc) b in - let d = - match t' with - | Some (typ, catf) -> catf b' typ - | None -> b' - in - if is_tc - then tc_arg d - else d - -(* is_atomic is true if the binder must be parsed atomically *) -// Returns: -// 1- a doc for binder -// 2- optionally: a doc for the type annotation (if any), and a function to concat it to the binder -// When the binder is nameless, the at -// This does NOT handle typeclass arguments. The wrapping is done from the outside. -and p_binder' (no_pars: bool) (is_atomic: bool) (b: binder): document & option (document & catf) = - match b.b with - | Variable lid -> optional p_aqual b.aqual ^^ p_attributes false b.battributes ^^ p_lident lid, None - | TVariable lid -> p_attributes false b.battributes ^^ p_lident lid, None - | Annotated (lid, t) -> - let b', t' = - match t.tm with - | Refine ({b = Annotated (lid', t)}, phi) when (string_of_id lid) = (string_of_id lid') -> - p_refinement' b.aqual b.battributes (p_lident lid) t phi - | _ -> - let t' = if is_typ_tuple t then - soft_parens_with_nesting (p_tmFormula t) - else - p_tmFormula t - in - optional p_aqual b.aqual ^^ p_attributes false b.battributes ^^ p_lident lid, t' - in - let catf = - if is_atomic || (is_meta_qualifier b.aqual && not no_pars) then - (fun x y -> group (lparen ^^ (cat_with_colon x y) ^^ rparen)) - else - (fun x y -> group (cat_with_colon x y)) - in - b', Some (t', catf) - | TAnnotated _ -> failwith "Is this still used ?" - | NoName t -> - begin match t.tm with - | Refine ({b = NoName t}, phi) -> - let b', t' = p_refinement' b.aqual b.battributes underscore t phi in - b', Some (t', cat_with_colon) - | _ -> - let pref = optional p_aqual b.aqual ^^ p_attributes false b.battributes in - let p_Tm = if is_atomic then p_atomicTerm else p_appTerm in - pref ^^ p_Tm t, None - end - -and p_refinement aqual_opt attrs binder t phi = - let b, typ = p_refinement' aqual_opt attrs binder t phi in - cat_with_colon b typ - -and p_refinement' aqual_opt attrs binder t phi = - let is_t_atomic = - match t.tm with - | Construct _ - | App _ - | Op _ -> false - | _ -> true - in - let comm, phi = p_noSeqTerm false false phi in - let phi = if comm = empty then phi else comm ^^ hardline ^^ phi in - (* If t is atomic, don't put a space between t and phi - * If t can be displayed on a single line, tightly surround it with braces, - * otherwise pad with a space. *) - let jump_break = if is_t_atomic then 0 else 1 in - (optional p_aqual aqual_opt ^^ p_attributes false attrs ^^ binder), - (p_appTerm t ^^ - (jump 2 jump_break (group ((ifflat - (soft_braces_with_nesting_tight phi) (soft_braces_with_nesting phi)))))) - -(* TODO : we may prefer to flow if there are more than 15 binders *) -(* Note: also skipping multiBinder here. *) -and p_binders_list (is_atomic: bool) (bs: list binder): list document = List.map (p_binder is_atomic) bs - -and p_binders (is_atomic: bool) (bs: list binder): document = separate_or_flow break1 (p_binders_list is_atomic bs) - -and p_binders_sep (bs: list binder): document = separate_map space (fun x -> x) (p_binders_list true bs) - - - -(* ****************************************************************************) -(* *) -(* Printing terms and types *) -(* *) -(* ****************************************************************************) - -(* The grammar has shift-reduce conflicts, meaning that the printer, in addition - * to following the structure of the parser, must have extra machinery. - * Shift-reduce conflicts arise from two situations: - * - e1; e2 where e1 ends with a greedy construct that swallows semicolons (for - * instance, MATCH, LET, an operator that ends with LARROW are greedy -- IF is - * not) - * - ... -> e1 | ... -> ... where e1 ends with a greedy construct that swallows - * bars (MATCH, TRY, FUNCTION); note that FUN is not a greedy construct in - * this context; also note that this does not apply to the last branch... - * - * To deal with this issue, we keep two flags in our series of recursive calls; - * "ps" (protect semicolons) and "pb" (protect branches). Whenever we enter a - * greedy construct, we wrap it with parentheses to make it non-greedy. - * - * This is convenient: at every call-site, we need to understand whether we need - * to prevent swallowing semicolons or not. For instance, in a record field, we - * do. *) - -and paren_if (b:bool) = - if b then - soft_parens_with_nesting - else - fun x -> x - -and inline_comment_or_above comm doc sep = - if comm = empty then - group (doc ^^ sep) - else - group <| ifflat (group (doc ^^ sep ^^ break1 ^^ comm)) (comm ^^ hardline ^^ doc ^^ sep) - -and p_term (ps:bool) (pb:bool) (e:term) = match e.tm with - | Seq (e1, e2) -> - (* Don't swallow semicolons on the left-hand side of a semicolon! Note: - * the `false` for pb is kind of useless because there is no construct - * that swallows branches but not semicolons (meaning ps implies pb). *) - let comm, t1 = p_noSeqTerm true false e1 in - (inline_comment_or_above comm t1 semi) ^^ hardline ^^ p_term ps pb e2 - - | Bind(x, e1, e2) -> - group ((p_lident x ^^ space ^^ long_left_arrow) ^/+^ - (p_noSeqTermAndComment true false e1 ^^ space ^^ semi)) ^/^ p_term ps pb e2 - | _ -> - group (p_noSeqTermAndComment ps pb e) - -and p_term_sep (ps:bool) (pb:bool) (e:term) = match e.tm with - | Seq (e1, e2) -> - (* Don't swallow semicolons on the left-hand side of a semicolon! Note: - * the `false` for pb is kind of useless because there is no construct - * that swallows branches but not semicolons (meaning ps implies pb). *) - let comm, t1 = p_noSeqTerm true false e1 in - comm, group (t1 ^^ semi) ^^ hardline ^^ p_term ps pb e2 - | Bind(x, e1, e2) -> - empty, group ((p_lident x ^^ space ^^ long_left_arrow) ^/+^ - (p_noSeqTermAndComment true false e1 ^^ space ^^ semi)) ^/^ p_term ps pb e2 - | _ -> - p_noSeqTerm ps pb e - -and p_noSeqTerm ps pb e = with_comment_sep (p_noSeqTerm' ps pb) e e.range - -and p_noSeqTermAndComment ps pb e = with_comment (p_noSeqTerm' ps pb) e e.range - -and p_noSeqTerm' ps pb e = match e.tm with - | Ascribed (e, t, None, use_eq) -> - group (p_tmIff e ^/^ (if use_eq then dollar else langle) ^^ colon ^/^ p_typ ps pb t) - | Ascribed (e, t, Some tac, use_eq) -> - group (p_tmIff e ^/^ (if use_eq then dollar else langle) ^^ colon ^/^ p_typ false false t ^/^ str "by" ^/^ p_typ ps pb (maybe_unthunk tac)) - | Op (id, [ e1; e2; e3 ]) when string_of_id id = ".()<-" -> - group ( - group (p_atomicTermNotQUident e1 ^^ dot ^^ soft_parens_with_nesting (p_term false false e2) - ^^ space ^^ larrow) ^^ jump2 (p_noSeqTermAndComment ps pb e3)) - | Op (id, [ e1; e2; e3 ]) when string_of_id id = ".[]<-" -> - group ( - group (p_atomicTermNotQUident e1 ^^ dot ^^ soft_brackets_with_nesting (p_term false false e2) - ^^ space ^^ larrow) ^^ jump2 (p_noSeqTermAndComment ps pb e3)) - | Op (id, [ e1; e2; e3 ]) when string_of_id id = ".(||)<-" -> - group ( - group (p_atomicTermNotQUident e1 ^^ dot ^^ soft_lens_access_with_nesting (p_term false false e2) - ^^ space ^^ larrow) ^^ jump2 (p_noSeqTermAndComment ps pb e3)) - | Op (id, [ e1; e2; e3 ]) when string_of_id id = ".[||]<-" -> - group ( - group (p_atomicTermNotQUident e1 ^^ dot ^^ soft_brackets_lens_access_with_nesting (p_term false false e2) - ^^ space ^^ larrow) ^^ jump2 (p_noSeqTermAndComment ps pb e3)) - | Requires (e, wtf) -> - assert (wtf = None); - group (str "requires" ^/^ p_typ ps pb e) - | Ensures (e, wtf) -> - assert (wtf = None); - group (str "ensures" ^/^ p_typ ps pb e) - | WFOrder (rel, e) -> - p_dec_wf ps pb rel e - | LexList l -> - group (str "%" ^^ p_term_list ps pb l) - | Decreases (e, wtf) -> - assert (wtf = None); - group (str "decreases" ^/^ p_typ ps pb e) - | Attributes es -> - group (str "attributes" ^/^ separate_map break1 p_atomicTerm es) - | If (e1, op_opt, ret_opt, e2, e3) -> - (* No need to wrap with parentheses here, since if e1 then e2; e3 really - * does parse as (if e1 then e2); e3 -- the IF does not swallow - * semicolons. We forward our caller's [ps] parameter, though, because - * something in [e2] may swallow. *) - if is_unit e3 - then group ((str ("if" ^ (dflt "" (op_opt `map_opt` string_of_id - `bind_opt` strip_prefix "let"))) - ^/+^ p_noSeqTermAndComment false false e1) ^/^ (str "then" ^/+^ p_noSeqTermAndComment ps pb e2)) - else - let e2_doc = - match e2.tm with - (* Not protecting, since an ELSE follows. *) - | If (_, _, _, _,e3) when is_unit e3 -> - (* Dangling else *) - soft_parens_with_nesting (p_noSeqTermAndComment false false e2) - | _ -> p_noSeqTermAndComment false false e2 - in - (match ret_opt with - | None -> - group ( - (str "if" ^/+^ p_noSeqTermAndComment false false e1) ^/^ - (str "then" ^/+^ e2_doc) ^/^ - (str "else" ^/+^ p_noSeqTermAndComment ps pb e3)) - | Some (as_opt, ret, use_eq) -> - group ( - (str "if" ^/+^ p_noSeqTermAndComment false false e1) ^/^ - ((match as_opt with - | None -> empty - | Some as_ident -> str "as" ^/^ p_ident as_ident) - ^/^ - (str (if use_eq then "returns$" else "returns") ^/+^ p_tmIff ret)) ^/^ - (str "then" ^/+^ e2_doc) ^/^ - (str "else" ^/+^ p_noSeqTermAndComment ps pb e3))) - | TryWith(e, branches) -> - paren_if (ps || pb) ( - group (prefix2 (str "try") (p_noSeqTermAndComment false false e) ^/^ str "with" ^/^ - separate_map_last hardline p_patternBranch branches)) - | Match (e, op_opt, ret_opt, branches) -> - let match_doc - = str ("match" ^ (dflt "" (op_opt `map_opt` string_of_id - `bind_opt` strip_prefix "let"))) in - paren_if (ps || pb) ( - (match ret_opt with - | None -> - group (surround 2 1 match_doc (p_noSeqTermAndComment false false e) (str "with")) - | Some (as_opt, ret, use_eq) -> - group (surround 2 1 match_doc - ((p_noSeqTermAndComment false false e) ^/+^ - (match as_opt with - | None -> empty - | Some as_ident -> str "as" ^/+^ (p_ident as_ident)) ^/+^ - (str (if use_eq then "returns$" else "returns") ^/+^ p_tmIff ret)) - (str "with"))) - - ^/^ - - separate_map_last hardline p_patternBranch branches) - | LetOpen (uid, e) -> - paren_if ps ( - group (surround 2 1 (str "let open") (p_quident uid) (str "in") ^/^ p_term false pb e) - ) - | LetOpenRecord (r, rty, e) -> - paren_if ps ( - group (surround 2 1 (str "let open") (p_term false pb r) (str "as") ^/^ (p_term false pb rty) - ^/^ str "in" ^/^ p_term false pb e) - ) - | LetOperator(lets, body) -> - let p_let (id, pat, e) is_last = - let doc_let_or_and = str (string_of_id id) in - let doc_pat = p_letlhs doc_let_or_and (pat, e) true in - match pat.pat, e.tm with - | PatVar (pid, _, _), Name tid - | PatVar (pid, _, _), Var tid - when string_of_id pid = List.last (path_of_lid tid) -> - doc_pat ^/^ (if is_last then str "in" else empty) - | _ -> - let comm, doc_expr = p_term_sep false false e in - let doc_expr = inline_comment_or_above comm doc_expr empty in - if is_last then - surround 2 1 (flow break1 [doc_pat; equals]) doc_expr (str "in") - else - hang 2 (flow break1 [doc_pat; equals; doc_expr]) - in - let l = List.length lets in - let lets_docs = List.mapi (fun i lb -> - group (p_let lb (i = l - 1)) - ) lets in - let lets_doc = group (separate break1 lets_docs) in - let r = paren_if ps (group (lets_doc ^^ hardline ^^ p_term false pb body)) in - r - | Let(q, lbs, e) -> - (* We wish to print let-bindings as follows. - * - * [@ attribute ] - * let x = foo - * and x = - * too long to fit on one line - * in - * ... *) - let p_lb q (a, (pat, e)) is_last = - let attrs = p_attrs_opt true a in - let doc_let_or_and = match q with - | Some Rec -> group (str "let" ^/^ str "rec") - | Some NoLetQualifier -> str "let" - | _ -> str "and" - in - let doc_pat = p_letlhs doc_let_or_and (pat, e) true in - let comm, doc_expr = p_term_sep false false e in - let doc_expr = inline_comment_or_above comm doc_expr empty in - attrs ^^ - (if is_last then - surround 2 1 (flow break1 [doc_pat; equals]) doc_expr (str "in") - else - hang 2 (flow break1 [doc_pat; equals; doc_expr])) - in - let l = List.length lbs in - let lbs_docs = List.mapi (fun i lb -> - if i = 0 then - group (p_lb (Some q) lb (i = l - 1)) - else - group (p_lb None lb (i = l - 1)) - ) lbs in - let lbs_doc = group (separate break1 lbs_docs) in - paren_if ps (group (lbs_doc ^^ hardline ^^ p_term false pb e)) - - | Quote (e, Dynamic) -> - group (str "quote" ^/^ p_noSeqTermAndComment ps pb e) - | Quote (e, Static) -> - group (str "`" ^^ p_noSeqTermAndComment ps pb e) - | VQuote e -> - group (str "`%" ^^ p_noSeqTermAndComment ps pb e) - | Antiquote ({ tm = Quote (e, Dynamic) }) -> - group (str "`@" ^^ p_noSeqTermAndComment ps pb e) - | Antiquote e -> - group (str "`#" ^^ p_noSeqTermAndComment ps pb e) - | CalcProof (rel, init, steps) -> - let head = str "calc" ^^ space ^^ p_noSeqTermAndComment false false rel ^^ space ^^ lbrace in - let bot = rbrace in - enclose head (hardline ^^ bot) - (nest 2 <| hardline - ^^ p_noSeqTermAndComment false false init ^^ str ";" ^^ hardline - ^^ separate_map_last hardline p_calcStep steps) - - | IntroForall (xs, p, e) -> - let p = p_noSeqTermAndComment false false p in - let e = p_noSeqTermAndComment false false e in - let xs = p_binders_sep xs in - str "introduce forall" ^^ space ^^ xs ^^ space ^^ str "." ^^ space ^^ p ^^ hardline ^^ - str "with" ^^ space ^^ e - - | IntroExists(xs, p, vs, e) -> - let p = p_noSeqTermAndComment false false p in - let e = p_noSeqTermAndComment false false e in - let xs = p_binders_sep xs in - str "introduce" ^^ space ^^ str "exists" ^^ space ^^ xs ^^ str "." ^^ p ^^ hardline ^^ - str "with" ^^ space ^^ (separate_map space p_atomicTerm vs) ^^ hardline ^^ - str "and" ^^ space ^^ e - - | IntroImplies(p, q, x, e) -> - let p = p_tmFormula p in - let q = p_tmFormula q in - let e = p_noSeqTermAndComment false false e in - let x = p_binders_sep [x] in - str "introduce" ^^ space ^^ - p ^^ space ^^ str "==>" ^^ space ^^ q ^^ hardline ^^ - str "with" ^^ space ^^ x ^^ str "." ^^ space ^^ e - - | IntroOr(b, p, q, e) -> - let p = p_tmFormula p in - let q = p_tmFormula q in - let e = p_noSeqTermAndComment false false e in - str "introduce" ^^ space ^^ - p ^^ space ^^ str "\/" ^^ space ^^ q ^^ hardline ^^ - str "with" ^^ space ^^ (if b then str "Left" else str "Right") ^^ space ^^ e - - | IntroAnd(p, q, e1, e2) -> - let p = p_tmFormula p in - let q = p_tmTuple q in - let e1 = p_noSeqTermAndComment false false e1 in - let e2 = p_noSeqTermAndComment false false e2 in - str "introduce" ^^ space ^^ - p ^^ space ^^ str "/\\" ^^ space ^^ q ^^ hardline ^^ - str "with" ^^ space ^^ e1 ^^ hardline ^^ - str "and" ^^ space ^^ e2 - - | ElimForall(xs, p, vs) -> - let xs = p_binders_sep xs in - let p = p_noSeqTermAndComment false false p in - let vs = separate_map space p_atomicTerm vs in - str "eliminate" ^^ space ^^ str "forall" ^^ space ^^ xs ^^ str "." ^^ space ^^ p ^^ hardline ^^ - str "with" ^^ space ^^ vs - - | ElimExists (bs, p, q, b, e) -> - let head = str "eliminate exists" ^^ space ^^ p_binders_sep bs ^^ str "." in - let p = p_noSeqTermAndComment false false p in - let q = p_noSeqTermAndComment false false q in - let e = p_noSeqTermAndComment false false e in - head ^^ hardline ^^ - p ^^ hardline ^^ - str "returns" ^^ space ^^ q ^^ hardline ^^ - str "with" ^^ space ^^ (p_binders_sep [b]) ^^ str "." ^^ hardline ^^ - e - - | ElimImplies(p, q, e) -> - let p = p_tmFormula p in - let q = p_tmFormula q in - let e = p_noSeqTermAndComment false false e in - str "eliminate" ^^ space ^^ p ^^ space ^^ str "==>" ^^ space ^^ q ^^ hardline ^^ - str "with" ^^ space ^^ e - - | ElimOr(p, q, r, x, e1, y, e2) -> - let p = p_tmFormula p in - let q = p_tmFormula q in - let r = p_noSeqTermAndComment false false r in - let x = p_binders_sep [x] in - let e1 = p_noSeqTermAndComment false false e1 in - let y = p_binders_sep [y] in - let e2 = p_noSeqTermAndComment false false e2 in - str "eliminate" ^^ space ^^ p ^^ space ^^ str "\\/" ^^ space ^^ q ^^ hardline ^^ - str "returns" ^^ space ^^ r ^^ hardline ^^ - str "with" ^^ space ^^ x ^^ space ^^ str "." ^^ space ^^ e1 ^^ hardline ^^ - str "and" ^^ space ^^ y ^^ space ^^ str "." ^^ space ^^ e2 - - | ElimAnd(p, q, r, x, y, e) -> - let p = p_tmFormula p in - let q = p_tmTuple q in - let r = p_noSeqTermAndComment false false r in - let xy = p_binders_sep [x; y] in - let e = p_noSeqTermAndComment false false e in - str "eliminate" ^^ space ^^ p ^^ space ^^ str "/\\" ^^ space ^^ q ^^ hardline ^^ - str "returns" ^^ space ^^ r ^^ hardline ^^ - str "with" ^^ space ^^ xy ^^ space ^^ str "." ^^ space ^^ e - - | _ -> p_typ ps pb e - -and p_dec_wf ps pb rel e = - group (str "{:well-founded " ^^ p_typ ps pb rel ^/^ p_typ ps pb e ^^ str " }") - - -and p_calcStep _ (CalcStep (rel, just, next)) = - group (p_noSeqTermAndComment false false rel ^^ space ^^ lbrace ^^ space ^^ p_noSeqTermAndComment false false just ^^ space ^^ rbrace ^^ hardline - ^^ p_noSeqTermAndComment false false next ^^ str ";") - -and p_attrs_opt (isTopLevel: bool) = function - | None -> empty - | Some terms -> - group (str (if isTopLevel then "[@@" else "[@@@") ^/^ - (separate_map (str "; ") - (p_noSeqTermAndComment false false) - terms) ^/^ - str "]") - -and p_typ ps pb e = with_comment (p_typ' ps pb) e e.range - -and p_typ_sep ps pb e = with_comment_sep (p_typ' ps pb) e e.range - -and p_typ' ps pb e = match e.tm with - | QForall (bs, (_, trigger), e1) - | QExists (bs, (_, trigger), e1) - | QuantOp (_, bs, (_, trigger), e1) -> - let binders_doc = p_binders true bs in - let term_doc = p_noSeqTermAndComment ps pb e1 in - //VD: We could dispense with this pattern matching if we removed trailing whitespace after the fact - (match trigger with - | [] -> - prefix2 - (soft_surround 2 0 (p_quantifier e ^^ space) binders_doc dot) term_doc - | pats -> - prefix2 (group (prefix2 - (soft_surround 2 0 (p_quantifier e ^^ space) binders_doc dot) - (p_trigger trigger))) term_doc) - | _ -> p_simpleTerm ps pb e - -and p_typ_top style ps pb e = with_comment (p_typ_top' style ps pb) e e.range - -and p_typ_top' style ps pb e = p_tmArrow style true p_tmFormula e - -and sig_as_binders_if_possible t extra_space = - let s = if extra_space then space else empty in - if all_binders_annot t then - (s ^^ p_typ_top (Binders (4, 0, true)) false false t) - else - group (colon ^^ s ^^ p_typ_top (Arrows (2, 2)) false false t) - -// Typeclass arguments are not collapsed. -and collapse_pats (pats: list (document & document & bool & bool)): list document = - let fold_fun (bs: list (list document & document & bool & bool)) (x: document & document & bool & bool) = - let b1, t1, tc1, j1 = x in - match bs with - | [] -> [([b1], t1, tc1, j1)] - | hd::tl -> - let b2s, t2, tc2, j2 = hd in - if t1 = t2 && j1 && j2 then - (b2s @ [b1], t1, false, true) :: tl - else - ([b1], t1, tc1, j1) :: hd :: tl - in - let p_collapsed_binder (cb: list document & document & bool & bool): document = - let bs, typ, istcarg, _ = cb in - let body = - match bs with - | [] -> failwith "Impossible" // can't have dangling type - | hd::tl -> cat_with_colon (List.fold_left (fun x y -> x ^^ space ^^ y) hd tl) typ - in - if istcarg - then tc_arg body - else soft_parens_with_nesting body - in - let binders = List.fold_left fold_fun [] (List.rev pats) in - map_rev p_collapsed_binder binders - -and pats_as_binders_if_possible pats : list document & annotation_style = - // returns: doc for name, doc for type, boolean if typeclass arg - let all_binders (p:pattern) : option (document & document & bool & bool) = - match p.pat with - | PatAscribed(pat, (t, None)) -> - (match pat.pat, t.tm with - | PatVar (lid, aqual, attrs), Refine({b = Annotated(lid', t)}, phi) - when (string_of_id lid) = (string_of_id lid') -> - let (x, y) = p_refinement' aqual attrs (p_ident lid) t phi in - Some (x, y, false, false) - | PatVar (lid, aqual, attrs), _ -> - let is_tc = aqual = Some TypeClassArg in - let is_meta = match aqual with | Some (Meta _) -> true | _ -> false in - Some (optional p_aqual aqual ^^ p_attributes false attrs ^^ p_ident lid, p_tmEqNoRefinement t, is_tc, not is_tc && not is_meta) - | _ -> None) - | _ -> None - in - match map_if_all all_binders pats with - | Some bs -> - collapse_pats bs, Binders (4, 0, true) - | None -> - List.map p_atomicPattern pats, Binders (4, 0, false) - -and p_quantifier e = match e.tm with - | QForall _ -> str "forall" - | QExists _ -> str "exists" - | QuantOp (i, _, _, _) -> p_ident i - | _ -> failwith "Imposible : p_quantifier called on a non-quantifier term" - -and p_trigger = function - | [] -> empty - | pats -> - group (lbrace ^^ colon ^^ str "pattern" ^/^ jump 2 0 (p_disjunctivePats pats) ^^ rbrace) - -and p_disjunctivePats pats = - separate_map (str "\\/") p_conjunctivePats pats - -and p_conjunctivePats pats = - group (separate_map (semi ^^ break1) p_appTerm pats) - -and p_simpleTerm ps pb e = match e.tm with - | Function(branches, _) -> - paren_if (ps || pb) ( - group (str "function" ^/^ separate_map_last hardline p_patternBranch branches)) - - | Abs(pats, e) -> - let comm, doc = p_term_sep false pb e in - let prefix = str "fun" ^/+^ separate_map break1 p_atomicPattern pats ^/^ rarrow in - paren_if ps ( - if comm <> empty then - prefix ^^ hardline ^^ comm ^^ hardline ^^ doc - else - group (prefix ^/+^ doc) - ) - | _ -> p_tmIff e - -and p_maybeFocusArrow b = - if b then str "~>" else rarrow - -(* slight modification here : a patternBranch always begins with a `|` *) -(* TODO : can we recover the focusing *) -and p_patternBranch pb (pat, when_opt, e) = - (* p_patternBranch is always called immediately underneath a paren_if; if ps - * was true, then we parenthesized and there's a closing parenthesis coming - * up, meaning we're not at risk of swallowing a semicolon; if ps was false, - * then we can recursively call p_term with false. *) - let one_pattern_branch p = - let branch = - match when_opt with - | None -> group (bar ^^ space ^^ (p_tuplePattern p) ^^ space ^^ rarrow) - | Some f -> - hang 2 (bar ^^ space ^^ (group ((p_tuplePattern p) ^/^ (str "when"))) ^/^ - (flow break1 [(p_tmFormula f); rarrow])) - in - let comm, doc = p_term_sep false pb e in - // we need to be careful here because an inlined comment on the last branch could eat - // any following parenthesis; to prevent this, we never inline a comment on the last branch - if pb then - if comm = empty then - group (branch ^/+^ doc) - else - group ( - ifflat - (group (branch ^/+^ doc ^^ break1 ^^ comm)) - (branch ^^ jump2 (inline_comment_or_above comm doc empty)) - ) - else - if comm <> empty then - branch ^/+^ (comm ^^ hardline ^^ doc) - else branch ^/+^ doc - in - match pat.pat with - | PatOr pats -> - (match List.rev pats with - | hd::tl -> - (* group the last pattern with the branch so, if possible, they are kept on the same line in case of the disjunctive - pattern group being broken *) - let last_pat_branch = one_pattern_branch hd in - group (bar ^^ space ^^ (separate_map (break1 ^^ bar ^^ space) p_tuplePattern (List.rev tl)) ^/^ last_pat_branch) - | [] -> failwith "Impossible: disjunctive pattern can't be empty") - | _ -> - one_pattern_branch pat - -(* Nothing underneath tmIff is at risk of swallowing a semicolon. *) -and p_tmIff e = match e.tm with - | Op(id, [e1;e2]) when string_of_id id = "<==>" -> - infix0 (str "<==>") (p_tmImplies e1) (p_tmIff e2) - | _ -> p_tmImplies e - -and p_tmImplies e = match e.tm with - | Op(id, [e1;e2]) when string_of_id id = "==>" -> - infix0 (str "==>") (p_tmArrow (Arrows (2, 2)) false p_tmFormula e1) (p_tmImplies e2) - | _ -> p_tmArrow (Arrows (2, 2)) false p_tmFormula e - -// This function is somewhat convoluted because it is used in a few -// different contexts and it is trying to properly indent for each of -// them. For signatures, it is trying to print the whole arrow on one -// line. If this fails, it tries to print everything except the -// computation type on the same line and push the computation type on a -// new line. If this fails, it prints every term on a separate line. A -// trailing space may sometimes be introduced, which we should trim. -// It also needs to make adjustments depending on which style a signature -// is to be printed in. For more details see the `annotation_style` type -// definition. -and format_sig style terms ret_d no_last_op flat_space = - let n, last_n, sep, last_op = - match style with - | Arrows (n, ln)-> - n, ln, space ^^ rarrow ^^ break1, rarrow ^^ space - | Binders (n, ln, parens) -> - n, ln, break1, colon ^^ space - in - let last_op = if List.length terms > 0 && (not no_last_op) then last_op else empty in - let one_line_space = if not (ret_d = empty) || not no_last_op then space else empty in - let single_line_arg_indent = repeat n space in - let fs = if flat_space then space else empty in - match List.length terms with - | 0 -> ret_d - | _ -> group (ifflat (fs ^^ (separate sep terms) ^^ one_line_space ^^ last_op ^^ ret_d) - (prefix n 1 (group ((ifflat (fs ^^ separate sep terms) - (jump2 ((single_line_arg_indent ^^ separate (sep ^^ single_line_arg_indent) (List.map (fun x -> align (hang 2 x)) terms))))))) - (align (hang last_n (last_op ^^ ret_d))))) - -and p_tmArrow style flat_space p_Tm e = - let terms, ret_d = - match style with - | Arrows _ -> p_tmArrow' p_Tm e - | Binders _ -> collapse_binders style p_Tm e - in - format_sig style terms ret_d false flat_space - -and p_tmArrow' p_Tm e : list document & document = - match e.tm with - | Product(bs, tgt) -> - let bs_ds = List.map (fun b -> p_binder false b) bs in - let bs_ds', ret = p_tmArrow' p_Tm tgt in - bs_ds@bs_ds', ret - | _ -> - ([], p_Tm e) - -// When printing in `Binders` style, collapse binders which have the same -// type, so instead of printing -// val f (a: t) (b: t) (c: t) : Tot nat -// print -// val f (a b c: t) : Tot nat -// For this, we use the generalised version of p_binder, which returns -// the binder, and optionally its type and a function which -// concatenates them. -and collapse_binders (style : annotation_style) (p_Tm: term -> document) (e: term): list document & document = - let atomize = match style with - | Binders (_, _, a) -> a - | _ -> false - in - let wrap is_tc doc = - if is_tc then tc_arg doc - else if atomize then soft_parens_with_nesting doc - else doc - in - // For each binder, return: - // - document for binder - // - optional annotation doc + cat function - // - whether it was a typeclass arg - // - whether it is joinable (tc args and meta args are not) - let rec accumulate_binders p_Tm e: list ((document & option (document & catf)) & bool & bool) & document = - match e.tm with - | Product(bs, tgt) -> - let bs_ds = List.map (fun b -> p_binder' true false b, is_tc_binder b, is_joinable_binder b) bs in - let bs_ds', ret = accumulate_binders p_Tm tgt in - bs_ds@bs_ds', ret - | _ -> ([], p_Tm e) - in - let fold_fun (bs: list (list document & option (document & catf) & bool & bool)) (x: (document & option (document & catf)) & bool & bool) = - let (b1, t1), tc1, j1 = x in - match bs with - | [] -> [([b1], t1, tc1, j1)] - | hd::tl -> - let b2s, t2, tc2, j2 = hd in - match (t1, t2) with - | Some (typ1, catf1), Some (typ2, _) - when typ1 = typ2 && j1 && j2 -> - (* If the `x` binder has the same type as the group that follows, - * and both are joinable (the group and the new binder), then join - * them. Take the cat function from x. NOTE: if they were joinable, - * then they are not tc-args, hence the false. *) - (b2s @ [b1], t1, false, true) :: tl - | _ -> - (* Otherwise just make a new group *) - ([b1], t1, tc1, j1) :: bs - in - let p_collapsed_binder (cb: list document & option (document & catf) & bool & bool): document = - let bs, t, is_tc, _ = cb in - match t with - | None -> begin - match bs with - | [b] -> wrap is_tc b - | _ -> failwith "Impossible" // can't have dangling type or collapse unannotated binders - end - | Some (typ, f) -> begin - match bs with - | [] -> failwith "Impossible" // can't have dangling type - | hd::tl -> wrap is_tc <| f (List.fold_left (fun x y -> x ^^ space ^^ y) hd tl) typ - end - in - let bs_ds, ret_d = accumulate_binders p_Tm e in - let binders = List.fold_left fold_fun [] bs_ds in - map_rev p_collapsed_binder binders, ret_d - -and p_tmFormula e = - let conj = space ^^ (str "/\\") ^^ break1 in - let disj = space ^^ (str "\\/") ^^ break1 in - let formula = p_tmDisjunction e in - flow_map disj (fun d -> flow_map conj (fun x -> group x) d) formula - -and p_tmDisjunction e = match e.tm with - | Op(id, [e1;e2]) when string_of_id id = "\\/" -> - (p_tmDisjunction e1) @ [p_tmConjunction e2] - | _ -> [p_tmConjunction e] - -and p_tmConjunction e = match e.tm with - | Op(id, [e1;e2]) when string_of_id id = "/\\" -> - (p_tmConjunction e1) @ [p_tmTuple e2] - | _ -> [p_tmTuple e] - -and p_tmTuple e = with_comment p_tmTuple' e e.range - -and p_tmTuple' e = match e.tm with - | Construct (lid, args) when is_tuple_constructor lid && all1_explicit args -> - separate_map (comma ^^ break1) (fun (e, _) -> p_tmEq e) args - | _ -> p_tmEq e - -and paren_if_gt curr mine doc = - if mine > curr then - group (lparen ^^ doc ^^ rparen) - else - doc - -and p_tmEqWith p_X e = - (* TODO : this should be precomputed but F* complains about a potential ML effect *) - let n = max_level ([colon_equals ; pipe_right] @ operatorInfix0ad12) in - p_tmEqWith' p_X n e - -and p_tmEqWith' p_X curr e = match e.tm with - (* We don't have any information to print `infix` aplication *) - | Op (op, [e1; e2]) when (* Implications and iffs are handled specially by the parser *) - not (Ident.string_of_id op = "==>" - || Ident.string_of_id op = "<==>") - && (is_operatorInfix0ad12 op - || Ident.string_of_id op = "=" - || Ident.string_of_id op = "|>") -> - let op = Ident.string_of_id op in - let left, mine, right = levels op in - paren_if_gt curr mine (infix0 (str <| op) (p_tmEqWith' p_X left e1) (p_tmEqWith' p_X right e2)) - | Op(id, [ e1; e2 ]) when string_of_id id = ":=" -> - group (p_tmEqWith p_X e1 ^^ space ^^ colon ^^ equals ^/+^ p_tmEqWith p_X e2) - | Op(id, [e]) when string_of_id id = "-" -> - let left, mine, right = levels "-" in - minus ^/^ p_tmEqWith' p_X mine e - | _ -> p_tmNoEqWith p_X e - -and p_tmNoEqWith p_X e = - (* TODO : this should be precomputed but F* complains about a potential ML effect *) - let n = max_level [colon_colon ; amp ; opinfix3 ; opinfix4] in - p_tmNoEqWith' false p_X n e - -and p_tmNoEqWith' inside_tuple p_X curr e = match e.tm with - | Construct (lid, [e1, _ ; e2, _]) when lid_equals lid C.cons_lid -> - let op = "::" in - let left, mine, right = levels op in - paren_if_gt curr mine (infix0 (str op) (p_tmNoEqWith' false p_X left e1) (p_tmNoEqWith' false p_X right e2)) - | Sum(binders, res) -> - let op = "&" in - let left, mine, right = levels op in - let p_dsumfst bt = - match bt with - | Inl b -> p_binder false b ^^ space ^^ str op ^^ break1 - | Inr t -> p_tmNoEqWith' false p_X left t ^^ space ^^ str op ^^ break1 - in - paren_if_gt curr mine (concat_map p_dsumfst binders ^^ p_tmNoEqWith' false p_X right res) - | Op (op, [e1; e2]) when is_operatorInfix34 op -> - let op = Ident.string_of_id op in - let left, mine, right = levels op in - paren_if_gt curr mine (infix0 (str op) (p_tmNoEqWith' false p_X left e1) (p_tmNoEqWith' false p_X right e2)) - | Record(with_opt, record_fields) -> - braces_with_nesting ( default_or_map empty p_with_clause with_opt ^^ - separate_map_last (semi ^^ break1) p_simpleDef record_fields ) - | Op(id, [e]) when string_of_id id = "~" -> - group (str "~" ^^ p_atomicTerm e) - | Paren p when inside_tuple -> - (match p.tm with - | Op(id, [e1; e2]) when string_of_id id = "*" -> - let op = "*" in - let left, mine, right = levels op in - paren_if_gt curr mine (infix0 (str op) (p_tmNoEqWith' true p_X left e1) (p_tmNoEqWith' true p_X right e2)) - | _ -> p_X e) - | _ -> p_X e - -and p_tmEqNoRefinement e = p_tmEqWith p_appTerm e - -and p_tmEq e = p_tmEqWith p_tmRefinement e - -and p_tmNoEq e = p_tmNoEqWith p_tmRefinement e - -and p_tmRefinement e = match e.tm with - | NamedTyp(lid, e) -> - group (p_lident lid ^/^ colon ^/^ p_appTerm e) - | Refine(b, phi) -> - p_refinedBinder b phi - | _ -> p_appTerm e - -and p_with_clause e = p_appTerm e ^^ space ^^ str "with" ^^ break1 - -and p_refinedBinder b phi = - match b.b with - | Annotated (lid, t) -> p_refinement b.aqual b.battributes (p_lident lid) t phi - | Variable lid -> p_refinement b.aqual b.battributes (p_lident lid) (mk_term Wild (range_of_id lid) Type_level) phi - | TAnnotated _ -> failwith "Is this still used ?" - | TVariable _ - | NoName _ -> - failwith (Util.format1 "Impossible: a refined binder ought to be annotated (%s)" (binder_to_string b)) - -(* A simple def can be followed by a ';'. Protect except for the last one. *) -and p_simpleDef ps (lid, e) = - group (p_qlidentOrOperator lid ^/^ equals ^/^ p_noSeqTermAndComment ps false e) - - -and p_appTerm e = match e.tm with - | App _ when is_general_application e -> - let head, args = head_and_args e in - (match args with - | [e1; e2] when snd e1 = Infix -> - p_argTerm e1 ^/^ group (str "`" ^^ (p_indexingTerm head) ^^ str "`") ^/^ p_argTerm e2 - | _ -> - let head_doc, args = p_indexingTerm head, args in - group (soft_surround_map_or_flow 2 0 head_doc (head_doc ^^ space) break1 empty p_argTerm args) - ) - - (* (explicit) tuples and dependent tuples are handled below *) - | Construct (lid, args) when is_general_construction e - && not (is_dtuple_constructor lid && all1_explicit args) - && not (is_tuple_constructor lid && all1_explicit args) -> - begin match args with - | [] -> p_quident lid - | [arg] -> group (p_quident lid ^/^ p_argTerm arg) - | hd::tl -> - group ( - group (prefix2 (p_quident lid) (p_argTerm hd)) ^^ - jump2 (separate_map break1 p_argTerm tl)) - end - | _ -> - p_indexingTerm e - -and p_argTerm arg_imp = match arg_imp with - | (u, UnivApp) -> p_universe u - | (e, FsTypApp) -> - (* This case should not happen since it might lead to badly formed type applications (e.g t a b)*) - Errors.log_issue e Errors.Warning_UnexpectedFsTypApp "Unexpected FsTypApp, output might not be formatted correctly."; - surround 2 1 langle (p_indexingTerm e) rangle - | (e, Hash) -> str "#" ^^ p_indexingTerm e - | (e, HashBrace t) -> str "#[" ^^ p_indexingTerm t ^^ str "]" ^^ p_indexingTerm e - | (e, Infix) - | (e, Nothing) -> p_indexingTerm e - - -and p_indexingTerm_aux exit e = match e.tm with - | Op(id, [e1 ; e2]) when string_of_id id = ".()" -> - group (p_indexingTerm_aux p_atomicTermNotQUident e1 ^^ dot ^^ - soft_parens_with_nesting (p_term false false e2)) - | Op(id, [e1; e2]) when string_of_id id = ".[]" -> - group (p_indexingTerm_aux p_atomicTermNotQUident e1 ^^ dot ^^ - soft_brackets_with_nesting (p_term false false e2)) - | Op(id, [e1; e2]) when string_of_id id = ".(||)" -> - group (p_indexingTerm_aux p_atomicTermNotQUident e1 ^^ dot ^^ - soft_lens_access_with_nesting (p_term false false e2)) - | Op(id, [e1; e2]) when string_of_id id = ".[||]" -> - group (p_indexingTerm_aux p_atomicTermNotQUident e1 ^^ dot ^^ - soft_brackets_lens_access_with_nesting (p_term false false e2)) - | _ -> - exit e -and p_indexingTerm e = p_indexingTerm_aux p_atomicTerm e - -(* p_atomicTermQUident is merged with p_atomicTerm *) -and p_atomicTerm e = match e.tm with - | LetOpen (lid, e) -> - (* The second form of let open which is atomic, because it's delimited - * with parentheses. *) - p_quident lid ^^ dot ^^ soft_parens_with_nesting (p_term false false e) - | Name lid -> - p_quident lid - | Construct (lid, []) when is_general_construction e -> - (* - * This case is needed to avoid extra parenthesis on applications - * where the argument is a constructor. cf. #2181. - *) - p_quident lid - | Op(op, [e]) when is_general_prefix_op op -> - str (Ident.string_of_id op) ^^ p_atomicTerm e - - | ListLiteral ts -> - surround 2 0 - lbracket - (separate_map_or_flow_last (semi ^^ break1) (fun ps -> p_noSeqTermAndComment ps false) ts) - rbracket - - | SeqLiteral ts -> - surround 2 0 - (doc_of_string "seq!" ^^ lbracket) - (separate_map_or_flow_last (semi ^^ break1) (fun ps -> p_noSeqTermAndComment ps false) ts) - rbracket - - | _ -> p_atomicTermNotQUident e - -and p_atomicTermNotQUident e = match e.tm with - | Wild -> underscore - | Var lid when lid_equals lid C.assert_lid -> str "assert" - | Var lid when lid_equals lid C.assume_lid -> str "assume" - | Tvar tv -> p_tvar tv - | Const c -> - begin match c with - | Const.Const_char x when x = '\n' -> - str "0x0Az" - | _ -> p_constant c - end - | Name lid when lid_equals lid C.true_lid -> - str "True" - | Name lid when lid_equals lid C.false_lid -> - str "False" - | Op(op, [e]) when is_general_prefix_op op -> - str (Ident.string_of_id op) ^^ p_atomicTermNotQUident e - | Op(op, []) -> - lparen ^^ space ^^ str (Ident.string_of_id op) ^^ space ^^ rparen - | Construct (lid, args) when is_dtuple_constructor lid && all1_explicit args -> - surround 2 1 (lparen ^^ bar) - (separate_map (comma ^^ break1) (fun (e, _) -> p_tmEq e) args) - (bar ^^ rparen) - | Construct (lid, args) when is_tuple_constructor lid && all1_explicit args -> - parens (p_tmTuple e) - | Project (e, lid) -> - group (prefix 2 0 (p_atomicTermNotQUident e) (dot ^^ p_qlident lid)) - | _ -> - p_projectionLHS e - (* BEGIN e END skipped *) - -and p_projectionLHS e = match e.tm with - | Var lid -> - p_qlident lid - (* fsType application skipped *) - | Projector (constr_lid, field_lid) -> - p_quident constr_lid ^^ qmark ^^ dot ^^ p_lident field_lid - | Discrim constr_lid -> - p_quident constr_lid ^^ qmark - | Paren e -> - (* Adding required parentheses for tuple disambiguation in ToSyntax.fs -- - * see comment in parse.mly *) - let comm, t = p_term_sep false false e in - let doc = soft_parens_with_nesting t in - if comm = empty then - doc - else - comm ^^ hardline ^^ doc - // | _ when is_array e -> - // let es = extract_from_list e in - // surround 2 0 (lbracket ^^ bar) (separate_map_or_flow_last (semi ^^ break1) (fun ps -> p_noSeqTermAndComment ps false) es) (bar ^^ rbracket) - | _ when is_ref_set e -> - let es = extract_from_ref_set e in - surround 2 0 (bang ^^ lbrace) (separate_map_or_flow (comma ^^ break1) p_appTerm es) rbrace - - (* KM : I still think that it is wrong to print a term that's not parseable... *) - (* VD: Not parsable, but it can be called with a Labeled term via term_to_string *) - | Labeled (e, s, b) -> - str ("(*" ^ s ^ "*)") ^/^ p_term false false e - - (* Failure cases : these cases are not handled in the printing grammar since *) - (* they are considered as invalid AST. We try to fail as soon as possible in order *) - (* to prevent the pretty printer from looping *) - | Op (op, args) when not (handleable_op op args) -> - failwith ("Operation " ^ Ident.string_of_id op ^ " with " ^ string_of_int (List.length args) ^ - " arguments couldn't be handled by the pretty printer") - | Uvar id -> - failwith "Unexpected universe variable out of universe context" - - (* All the cases are explicitly listed below so that a modification of the ast doesn't lead to a loop *) - (* We must also make sure that all the constructors listed below are handled somewhere *) - | Wild (* p_atomicTermNotQUident *) - | Const _ (* p_atomicTermNotQUident *) - | Op _ (* All handleable cases should be caught in the recursion loop *) - | Tvar _ (* p_atomicTermNotQUident *) - | Var _ (* p_projectionLHS *) - | Name _ (* p_atomicTerm *) - | Construct _ (* p_atomicTerm and p_appTerm *) - | Abs _ (* p_simpleTerm *) - | App _ (* p_appTerm *) - | Let _ (* p_noSeqTerm *) - | LetOperator _ (* p_noSeqTerm *) - | LetOpen _ (* p_noSeqTerm *) - | LetOpenRecord _ (* p_noSeqTerm *) - | Seq _ (* p_term *) - | Bind _ (* p_term *) - | If _ (* p_noSeqTerm *) - | Match _ (* p_noSeqTerm *) - | TryWith _ (* p_noSeqTerm *) - | Ascribed _ (* p_noSeqTerm *) - | Record _ (* p_termNoEq *) - | Project _ (* p_atomicTermNotQUident *) - | Product _ (* p_tmArrow *) - | Sum _ (* p_tmNoEq *) - | QForall _ (* p_typ *) - | QExists _ (* p_typ *) - | QuantOp _ - | Refine _ (* p_tmNoEq *) - | NamedTyp _ (* p_tmNoEq *) - | Requires _ (* p_noSeqTerm *) - | Ensures _ (* p_noSeqTerm *) - | Decreases _ (* p_noSeqTerm *) - | Attributes _(* p_noSeqTerm *) - | Quote _ (* p_noSeqTerm *) - | VQuote _ (* p_noSeqTerm *) - | Antiquote _ (* p_noSeqTerm *) - | CalcProof _ (* p_noSeqTerm *) - | ListLiteral _ - | SeqLiteral _ - | ElimExists _ - -> soft_parens_with_nesting (p_term false false e) - | LexList l -> group (str "%" ^^ p_term_list false false l) - | WFOrder (rel, e) -> - p_dec_wf false false rel e - -and p_constant = function - | Const_effect -> str "Effect" - | Const_unit -> str "()" - | Const_bool b -> doc_of_bool b - | Const_real r -> str (r ^"R") - | Const_char x -> doc_of_char x - | Const_string(s, _) -> dquotes (str (FStar.Compiler.String.escaped s)) - | Const_int (repr, sign_width_opt) -> - let signedness = function - | Unsigned -> str "u" - | Signed -> empty - in - let width = function - | Int8 -> str "y" - | Int16 -> str "s" - | Int32 -> str "l" - | Int64 -> str "L" - in - let suffix (s, w) = - (* This handles the Sizet case, which is unsigned but - * does not have a "u" suffix. *) - match (s, w) with - | _, Sizet -> str "sz" - | _ -> signedness s ^^ width w - in - let ending = default_or_map empty suffix sign_width_opt in - str repr ^^ ending - | Const_range_of -> str "range_of" - | Const_set_range_of -> str "set_range_of" - | Const_range r -> str (Range.string_of_range r) - | Const_reify _ -> str "reify" - | Const_reflect lid -> p_quident lid ^^ qmark ^^ dot ^^ str "reflect" - -and p_universe u = str "u#" ^^ p_atomicUniverse u - -and p_universeFrom u = match u.tm with - | Op(id, [u1 ; u2]) when string_of_id id = "+" -> - group (p_universeFrom u1 ^/^ plus ^/^ p_universeFrom u2) - | App _ -> - let head, args = head_and_args u in - begin match head.tm with - | Var maybe_max_lid when lid_equals maybe_max_lid C.max_lid -> - group (p_qlident C.max_lid ^/+^ - separate_map space (fun (u,_) -> p_atomicUniverse u) args) - | _ -> - (* TODO : refine the failwiths with informations *) - failwith (Util.format1 ("Invalid term in universe context %s") (term_to_string u)) - end - | _ -> p_atomicUniverse u - -and p_atomicUniverse u = match u.tm with - | Wild -> underscore - | Const (Const_int (r, sw)) -> p_constant (Const_int (r, sw)) - | Uvar id -> str (string_of_id id) - | Paren u -> soft_parens_with_nesting (p_universeFrom u) - | App _ -> soft_parens_with_nesting (p_universeFrom u) - | Op(id, [_ ; _]) when string_of_id id = "+" -> soft_parens_with_nesting (p_universeFrom u) - | _ -> failwith (Util.format1 "Invalid term in universe context %s" (term_to_string u)) - -let term_to_document e = - p_term false false e - -let signature_to_document e = p_justSig e - -let decl_to_document e = p_decl e - -let pat_to_document p = p_disjunctivePattern p - -let binder_to_document b = p_binder true b - -let modul_to_document (m:modul) = - match m with - | Module (_, decls) - | Interface (_, decls, _) -> - decls |> List.map decl_to_document |> separate hardline - -let comments_to_document (comments : list (string & FStar.Compiler.Range.range)) = - separate_map hardline (fun (comment, range) -> str comment) comments - -let extract_decl_range (d: decl): decl_meta = - (* take newline for qualifiers into account *) - let has_qs = - match (d.quals, d.d) with - | ([Assumption], Assume(id, _)) -> false - | ([], _) -> false - | _ -> true - in - { r = d.drange; - has_qs = has_qs; - has_attrs = not (List.isEmpty d.attrs); } - -let decls_with_comments_to_document (decls:list decl) comments = - match decls with - | [] -> empty, comments - | d :: ds -> - let decls, first_range = d :: ds, d.drange in - comment_stack := comments ; - let initial_comment = place_comments_until_pos 0 1 (start_of_range first_range) dummy_meta empty false true in - let doc = separate_map_with_comments empty empty p_decl decls extract_decl_range in - let comments = !comment_stack in - comment_stack := [] ; - (initial_comment ^^ doc, comments) - -(* [modul_with_comments_to_document m comments] prints the module [m] trying *) -(* to insert the comments from [comments]. The list comments is composed of *) -(* pairs of a raw string and a position which is used to place the comment *) -(* not too far from its original position. The rules for placing comments *) -(* are described in the ``Taking care of comments`` section *) -let modul_with_comments_to_document (m:modul) comments = - let decls = match m with - | Module (_, decls) - | Interface (_, decls, _) -> decls - in - decls_with_comments_to_document decls comments - -let decl_with_comments_to_document (d:decl) comments = - decls_with_comments_to_document [d] comments diff --git a/src/parser/FStar.Parser.ToDocument.fsti b/src/parser/FStar.Parser.ToDocument.fsti deleted file mode 100644 index 99a0594e985..00000000000 --- a/src/parser/FStar.Parser.ToDocument.fsti +++ /dev/null @@ -1,30 +0,0 @@ -(* - Copyright 2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -(** Convert Parser.Ast to Pprint.document for prettyprinting. *) -module FStar.Parser.ToDocument -open FStar.Compiler.Effect - -val term_to_document : FStar.Parser.AST.term -> FStar.Pprint.document -val decl_to_document : FStar.Parser.AST.decl -> FStar.Pprint.document -val signature_to_document : FStar.Parser.AST.decl -> FStar.Pprint.document -val pat_to_document : FStar.Parser.AST.pattern -> FStar.Pprint.document -val binder_to_document : FStar.Parser.AST.binder -> FStar.Pprint.document -val modul_to_document : FStar.Parser.AST.modul -> FStar.Pprint.document -val comments_to_document : list (string & FStar.Compiler.Range.range) -> FStar.Pprint.document -val modul_with_comments_to_document : FStar.Parser.AST.modul -> list (string & FStar.Compiler.Range.range) -> FStar.Pprint.document & list (string & FStar.Compiler.Range.range) -val handleable_args_length : FStar.Ident.ident -> int -val decl_with_comments_to_document : FStar.Parser.AST.decl -> list (string & FStar.Compiler.Range.range) -> FStar.Pprint.document & list (string & FStar.Compiler.Range.range) \ No newline at end of file diff --git a/src/parser/FStarC.Parser.AST.Util.fst b/src/parser/FStarC.Parser.AST.Util.fst new file mode 100644 index 00000000000..87d8bc70552 --- /dev/null +++ b/src/parser/FStarC.Parser.AST.Util.fst @@ -0,0 +1,794 @@ +(* + Copyright 2023 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + + Authors: N. Swamy and Copilot +*) +module FStarC.Parser.AST.Util +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Errors +module C = FStarC.Parser.Const +open FStarC.Compiler.Range +open FStarC.Ident +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.Const +open FStarC.Parser.AST + +let eq_ident (i1 i2:ident) = + Ident.ident_equals i1 i2 + +let eq_list (f: 'a -> 'a -> bool) (t1 t2:list 'a) + : bool + = List.length t1 = List.length t2 && + List.forall2 f t1 t2 + +let eq_option (f: 'a -> 'a -> bool) (t1 t2:option 'a) + : bool + = match t1, t2 with + | None, None -> true + | Some t1, Some t2 -> f t1 t2 + | _ -> false + + +// +// TODO: There is an eq_const in FStarC.Const.fst, can we use that? +// +let eq_sconst (c1 c2: sconst) : bool = + match c1, c2 with + | Const_effect, Const_effect -> true + | Const_unit, Const_unit -> true + | Const_bool b1, Const_bool b2 -> b1 = b2 + | Const_int (s1, sw1), Const_int (s2, sw2) -> s1=s2 && sw1=sw2 + | Const_char c1, Const_char c2 -> c1 = c2 + | Const_string (s1, _), Const_string (s2, _) -> s1 = s2 + | Const_real s1, Const_real s2 -> s1 = s2 + | Const_range r1, Const_range r2 -> r1 = r2 + | Const_reify _, Const_reify _ -> true + | Const_reflect l1, Const_reflect l2 -> Ident.lid_equals l1 l2 + | _ -> false + +let rec eq_term (t1 t2:term) + : bool + = eq_term' t1.tm t2.tm + +and eq_terms (t1 t2:list term) + : bool + = eq_list eq_term t1 t2 + +and eq_arg (t1 t2 : (term & imp)) + = let t1, a1 = t1 in + let t2, a2 = t2 in + eq_term t1 t2 && + eq_imp a1 a2 + +and eq_imp (i1 i2: imp) + = match i1, i2 with + | FsTypApp, FsTypApp + | Hash, Hash + | UnivApp, UnivApp + | Infix, Infix + | Nothing, Nothing -> true + | HashBrace t1, HashBrace t2 -> + eq_term t1 t2 + | _ -> false + +and eq_args (t1 t2: list (term & imp)) + : bool + = eq_list eq_arg t1 t2 + +and eq_arg_qualifier (arg_qualifier1:arg_qualifier) (arg_qualifier2:arg_qualifier) : bool = + match arg_qualifier1, arg_qualifier2 with + | Implicit, Implicit -> true + | Equality, Equality -> true + | Meta t1, Meta t2 -> eq_term t1 t2 + | TypeClassArg, TypeClassArg -> true + | _ -> false + +and eq_pattern (p1 p2:pattern) + : bool + = eq_pattern' p1.pat p2.pat + +and eq_aqual a1 a2 = eq_option eq_arg_qualifier a1 a2 + +and eq_pattern' (p1 p2:pattern') + : bool + = match p1, p2 with + | PatWild(q1, a1), PatWild(q2, a2) -> + eq_aqual q1 q2 && + eq_terms a1 a2 + | PatConst s1, PatConst s2 -> + eq_sconst s1 s2 + | PatApp (p1, ps1), PatApp(p2, ps2) -> + eq_pattern p1 p2 && + eq_list eq_pattern ps1 ps2 + | PatTvar (i1, aq1, as1), PatTvar(i2, aq2, as2) + | PatVar (i1, aq1, as1), PatVar(i2, aq2, as2) -> + Ident.ident_equals i1 i2 && + eq_aqual aq1 aq2 && + eq_terms as1 as2 + | PatName l1, PatName l2 -> + Ident.lid_equals l1 l2 + | PatOr ps1, PatOr ps2 + | PatList ps1, PatList ps2 -> + eq_list eq_pattern ps1 ps2 + | PatTuple(ps1, b1), PatTuple(ps2, b2) -> + eq_list eq_pattern ps1 ps2 && + b1 = b2 + | PatRecord ps1, PatRecord ps2 -> + eq_list (fun (l1, p1) (l2, p2) -> + Ident.lid_equals l1 l2 && + eq_pattern p1 p2) + ps1 ps2 + | PatAscribed (p1, (t1, topt1)), PatAscribed (p2, (t2, topt2)) -> + eq_pattern p1 p2 && + eq_term t1 t2 && + eq_option eq_term topt1 topt2 + | PatOp i1, PatOp i2 -> + eq_ident i1 i2 + | PatVQuote t1, PatVQuote t2 -> + eq_term t1 t2 + | _ -> false + +and eq_term' (t1 t2:term') + : bool + = match t1, t2 with + | Wild, Wild -> true + | Const s1, Const s2 -> eq_const s1 s2 + | Op (i1, ts1), Op (i2, ts2) -> + eq_ident i1 i2 && + eq_terms ts1 ts2 + | Tvar i1, Tvar i2 + | Uvar i1, Uvar i2 -> + eq_ident i1 i2 + | Var l1, Var l2 + | Name l1, Name l2 -> + Ident.lid_equals l1 l2 + | Projector (l1, i1), Projector (l2, i2) -> + Ident.lid_equals l1 l2 && + Ident.ident_equals i1 i2 + | Construct (l1, args1), Construct (l2, args2) -> + Ident.lid_equals l1 l2 && + eq_args args1 args2 + | Function (brs1, _r1), Function (brs2, _r2) -> + eq_list eq_branch brs1 brs2 + | Abs (ps1, t1), Abs (ps2, t2) -> + eq_list eq_pattern ps1 ps2 && + eq_term t1 t2 + | App (h1, t1, i1), App(h2, t2, i2) -> + eq_term h1 h2 && + eq_term t1 t2 && + eq_imp i1 i2 + | Let (lq1, defs1, t1), Let (lq2, defs2, t2) -> + lq1=lq2 && + eq_list (fun (o1, (p1, t1)) (o2, (p2, t2)) -> + eq_option eq_terms o1 o2 && + eq_pattern p1 p2 && + eq_term t1 t2) + defs1 defs2 && + eq_term t1 t2 + | LetOperator (defs1, t1), LetOperator (defs2, t2) -> + eq_list (fun (i1, ps1, t1) (i2, ps2, t2) -> + eq_ident i1 i2 && + eq_pattern ps1 ps2 && + eq_term t1 t2) + defs1 defs2 && + eq_term t1 t2 + | LetOpen (l1, t1), LetOpen (l2, t2) -> + Ident.lid_equals l1 l2 && + eq_term t1 t2 + // compare all the remaining cases of terms starting with LetOperator + | LetOpenRecord (t1, t2, t3), LetOpenRecord (t4, t5, t6) -> + eq_term t1 t4 && + eq_term t2 t5 && + eq_term t3 t6 + | Seq (t1, t2), Seq (t3, t4) -> + eq_term t1 t3 && + eq_term t2 t4 + | Bind (i1, t1, t2), Bind (i2, t3, t4) -> + Ident.ident_equals i1 i2 && + eq_term t1 t3 && + eq_term t2 t4 + | If (t1, i1, mra1, t2, t3), If (t4, i2, mra2, t5, t6) -> + eq_term t1 t4 && + eq_option eq_ident i1 i2 && + eq_option eq_match_returns_annotation mra1 mra2 && + eq_term t2 t5 && + eq_term t3 t6 + | Match (t1, i1, mra1, bs1), Match (t2, i2, mra2, bs2) -> + eq_term t1 t2 && + eq_option eq_ident i1 i2 && + eq_option eq_match_returns_annotation mra1 mra2 && + eq_list eq_branch bs1 bs2 + | TryWith (t1, bs1), TryWith (t2, bs2) -> + eq_term t1 t2 && + eq_list eq_branch bs1 bs2 + | Ascribed (t1, t2, topt1, b1), Ascribed (t3, t4, topt2, b2) -> + eq_term t1 t3 && + eq_term t2 t4 && + eq_option eq_term topt1 topt2 && + b1 = b2 + | Record (topt1, fs1), Record (topt2, fs2) -> + eq_option eq_term topt1 topt2 && + eq_list (fun (l1, t1) (l2, t2) -> + Ident.lid_equals l1 l2 && + eq_term t1 t2) + fs1 fs2 + | Project (t1, l1), Project (t2, l2) -> + eq_term t1 t2 && + Ident.lid_equals l1 l2 + | Product (bs1, t1), Product (bs2, t2) -> + eq_list eq_binder bs1 bs2 && + eq_term t1 t2 + | Sum (bs1, t1), Sum (bs2, t2) -> + eq_list (fun b1 b2 -> + match b1, b2 with + | Inl b1, Inl b2 -> + eq_binder b1 b2 + | Inr t1, Inr t2 -> + eq_term t1 t2 + | Inl _, Inr _ + | Inr _, Inl _ -> + false) + bs1 bs2 && + eq_term t1 t2 + | QForall (bs1, ps1, t1), QForall (bs2, ps2, t2) + | QExists (bs1, ps1, t1), QExists (bs2, ps2, t2) -> + //ps1 and ps2 have type list ident * list (list term) + // generate equality on ps1 p2 + let eq_ps (is1, ts1) (is2, ts2) = + eq_list eq_ident is1 is2 && + eq_list (eq_list eq_term) ts1 ts2 + in + eq_list eq_binder bs1 bs2 && + eq_ps ps1 ps2 && + eq_term t1 t2 + | QuantOp (i1, bs1, ps1, t1), QuantOp (i2, bs2, ps2, t2) -> + let eq_ps (is1, ts1) (is2, ts2) = + eq_list eq_ident is1 is2 && + eq_list (eq_list eq_term) ts1 ts2 + in + Ident.ident_equals i1 i2 && + eq_list eq_binder bs1 bs2 && + eq_ps ps1 ps2 && + eq_term t1 t2 + // continue comparing all the remaining cases of terms, starting with Refine + | Refine (t1, t2), Refine (t3, t4) -> + eq_binder t1 t3 && + eq_term t2 t4 + // continue comparing all the remaining cases of terms, starting with NamedTyp + | NamedTyp (i1, t1), NamedTyp (i2, t2) -> + eq_ident i1 i2 && + eq_term t1 t2 + | Paren t1, Paren t2 -> + eq_term t1 t2 + | Requires (t1, s1), Requires (t2, s2) -> + eq_term t1 t2 && + eq_option ( = ) s1 s2 + | Ensures (t1, s1), Ensures (t2, s2) -> + eq_term t1 t2 && + eq_option ( = ) s1 s2 + | LexList ts1, LexList ts2 -> + eq_list eq_term ts1 ts2 + | WFOrder (t1, t2), WFOrder (t3, t4) -> + eq_term t1 t3 && + eq_term t2 t4 + | Decreases (t1, s1), Decreases (t2, s2) -> + eq_term t1 t2 && + eq_option ( = ) s1 s2 + | Labeled (t1, s1, b1), Labeled (t2, s2, b2) -> + eq_term t1 t2 && + s1 = s2 && + b1 = b2 + | Discrim l1, Discrim l2 -> + Ident.lid_equals l1 l2 + | Attributes ts1, Attributes ts2 -> + eq_list eq_term ts1 ts2 + | Antiquote t1, Antiquote t2 -> + eq_term t1 t2 + | Quote (t1, k1), Quote (t2, k2) -> + eq_term t1 t2 && + k1 = k2 + | VQuote t1, VQuote t2 -> + eq_term t1 t2 + | CalcProof (t1, t2, cs1), CalcProof (t3, t4, cs2) -> + eq_term t1 t3 && + eq_term t2 t4 && + eq_list eq_calc_step cs1 cs2 + | IntroForall (bs1, t1, t2), IntroForall (bs2, t3, t4) -> + eq_list eq_binder bs1 bs2 && + eq_term t1 t3 && + eq_term t2 t4 + | IntroExists (bs1, t1, ts1, t2), IntroExists (bs2, t3, ts2, t4) -> + eq_list eq_binder bs1 bs2 && + eq_term t1 t3 && + eq_list eq_term ts1 ts2 && + eq_term t2 t4 + | IntroImplies (t1, t2, b1, t3), IntroImplies (t4, t5, b2, t6) -> + eq_term t1 t4 && + eq_term t2 t5 && + eq_binder b1 b2 && + eq_term t3 t6 + | IntroOr (b1, t1, t2, t3), IntroOr (b2, t4, t5, t6) -> + b1 = b2 && + eq_term t1 t4 && + eq_term t2 t5 && + eq_term t3 t6 + | IntroAnd (t1, t2, t3, t4), IntroAnd (t5, t6, t7, t8) -> + eq_term t1 t5 && + eq_term t2 t6 && + eq_term t3 t7 && + eq_term t4 t8 + | ElimForall (bs1, t1, ts1), ElimForall (bs2, t2, ts2) -> + eq_list eq_binder bs1 bs2 && + eq_term t1 t2 && + eq_list eq_term ts1 ts2 + | ElimExists (bs1, t1, t2, b1, t3), ElimExists (bs2, t4, t5, b2, t6) -> + eq_list eq_binder bs1 bs2 && + eq_term t1 t4 && + eq_term t2 t5 && + eq_binder b1 b2 && + eq_term t3 t6 + | ElimImplies (t1, t2, t3), ElimImplies (t4, t5, t6) -> + eq_term t1 t4 && + eq_term t2 t5 && + eq_term t3 t6 + | ElimOr (t1, t2, t3, b1, t4, b2, t5), ElimOr (t6, t7, t8, b3, t9, b4, t10) -> + eq_term t1 t6 && + eq_term t2 t7 && + eq_term t3 t8 && + eq_binder b1 b3 && + eq_term t4 t9 && + eq_binder b2 b4 && + eq_term t5 t10 + | ElimAnd (t1, t2, t3, b1, b2, t4), ElimAnd (t5, t6, t7, b3, b4, t8) -> + eq_term t1 t5 && + eq_term t2 t6 && + eq_term t3 t7 && + eq_binder b1 b3 && + eq_binder b2 b4 && + eq_term t4 t8 + | ListLiteral ts1, ListLiteral ts2 -> + eq_list eq_term ts1 ts2 + | SeqLiteral ts1, SeqLiteral ts2 -> + eq_list eq_term ts1 ts2 + | _ -> false + +and eq_calc_step (CalcStep (t1, t2, t3)) (CalcStep (t4, t5, t6)) = + eq_term t1 t4 && + eq_term t2 t5 && + eq_term t3 t6 + +and eq_binder (b1 b2:binder) = + eq_binder' b1.b b2.b && + eq_aqual b1.aqual b2.aqual && + eq_list eq_term b1.battributes b2.battributes + +and eq_binder' (b1 b2:binder') = + match b1, b2 with + | Variable i1, Variable i2 -> eq_ident i1 i2 + | TVariable i1, TVariable i2 -> eq_ident i1 i2 + | Annotated (i1, t1), Annotated (i2, t2) -> + eq_ident i1 i2 && + eq_term t1 t2 + | TAnnotated (i1, t1), TAnnotated (i2, t2) -> + eq_ident i1 i2 && + eq_term t1 t2 + | NoName t1, NoName t2 -> + eq_term t1 t2 + | _ -> false + +and eq_match_returns_annotation (i1, t1, b1) (i2, t2, b2) = + eq_option eq_ident i1 i2 && + eq_term t1 t2 && + b1 = b2 + +and eq_branch (p1, o1, t1) (p2, o2, t2) = + eq_pattern p1 p2 && + eq_option eq_term o1 o2 && + eq_term t1 t2 + + +let eq_tycon_record (t1 t2: tycon_record) = + eq_list (fun (i1, a1, a2, t1) (i2, a3, a4, t2) -> + eq_ident i1 i2 && + eq_aqual a1 a3 && + eq_list eq_term a2 a4 && + eq_term t1 t2) t1 t2 + +let eq_constructor_payload (t1 t2: constructor_payload) = + match t1, t2 with + | VpOfNotation t1, VpOfNotation t2 -> eq_term t1 t2 + | VpArbitrary t1, VpArbitrary t2 -> eq_term t1 t2 + | VpRecord (r1, k1), VpRecord (r2, k2) -> + eq_tycon_record r1 r2 && + eq_option eq_term k1 k2 + | _ -> false + +let eq_tycon (t1 t2: tycon) = + match t1, t2 with + | TyconAbstract (i1, bs1, k1), TyconAbstract (i2, bs2, k2) -> + eq_ident i1 i2 && + eq_list eq_binder bs1 bs2 && + eq_option eq_term k1 k2 + | TyconAbbrev (i1, bs1, k1, t1), TyconAbbrev (i2, bs2, k2, t2) -> + eq_ident i1 i2 && + eq_list eq_binder bs1 bs2 && + eq_option eq_term k1 k2 && + eq_term t1 t2 + | TyconRecord (i1, bs1, k1, a1, r1), TyconRecord (i2, bs2, k2, a2, r2) -> + eq_ident i1 i2 && + eq_list eq_binder bs1 bs2 && + eq_option eq_term k1 k2 && + eq_list eq_term a1 a2 && + eq_tycon_record r1 r2 + | TyconVariant (i1, bs1, k1, cs1), TyconVariant (i2, bs2, k2, cs2) -> + eq_ident i1 i2 && + eq_list eq_binder bs1 bs2 && + eq_option eq_term k1 k2 && + eq_list (fun (i1, o1, a1) (i2, o2, a2) -> + eq_ident i1 i2 && + eq_option eq_constructor_payload o1 o2 && + eq_list eq_term a1 a2) cs1 cs2 + | _ -> false + +let eq_lid = Ident.lid_equals + +let eq_lift (t1 t2: lift) = + eq_lid t1.msource t2.msource && + eq_lid t1.mdest t2.mdest && + (match t1.lift_op, t2.lift_op with + | NonReifiableLift t1, NonReifiableLift t2 -> eq_term t1 t2 + | ReifiableLift (t1, t2), ReifiableLift (t3, t4) -> + eq_term t1 t3 && + eq_term t2 t4 + | LiftForFree t1, LiftForFree t2 -> eq_term t1 t2 + | _ -> false) + + +let eq_pragma (t1 t2: pragma) = + match t1, t2 with + | SetOptions s1, SetOptions s2 -> s1 = s2 + | ResetOptions s1, ResetOptions s2 -> eq_option (fun s1 s2 -> s1 = s2) s1 s2 + | PushOptions s1, PushOptions s2 -> eq_option (fun s1 s2 -> s1 = s2) s1 s2 + | PopOptions, PopOptions -> true + | RestartSolver, RestartSolver -> true + | PrintEffectsGraph, PrintEffectsGraph -> true + | _ -> false + + +let eq_qualifier (t1 t2: qualifier) = + match t1, t2 with + | Private, Private -> true + | Noeq, Noeq -> true + | Unopteq, Unopteq -> true + | Assumption, Assumption -> true + | DefaultEffect, DefaultEffect -> true + | TotalEffect, TotalEffect -> true + | Effect_qual, Effect_qual -> true + | New, New -> true + | Inline, Inline -> true + | Visible, Visible -> true + | Unfold_for_unification_and_vcgen, Unfold_for_unification_and_vcgen -> true + | Inline_for_extraction, Inline_for_extraction -> true + | Irreducible, Irreducible -> true + | NoExtract, NoExtract -> true + | Reifiable, Reifiable -> true + | Reflectable, Reflectable -> true + | Opaque, Opaque -> true + | Logic, Logic -> true + | _ -> false + +let eq_qualifiers (t1 t2: qualifiers) = + eq_list eq_qualifier t1 t2 + +let eq_restriction (restriction1 restriction2: FStarC.Syntax.Syntax.restriction) = + let open FStarC.Syntax.Syntax in + match restriction1, restriction2 with + | (Unrestricted, Unrestricted) -> true + | (AllowList l1, AllowList l2) -> + let eq_tuple eq_fst eq_snd (a, b) (c, d) = eq_fst a c && eq_snd b d in + eq_list (eq_tuple eq_ident (eq_option eq_ident)) l1 l2 + +let rec eq_decl' (d1 d2:decl') : bool = + //generate the cases of this comparison starting with TopLevelModule + match d1, d2 with + | TopLevelModule lid1, TopLevelModule lid2 -> + eq_lid lid1 lid2 + | Open (lid1, restriction1), Open (lid2, restriction2) -> + eq_lid lid1 lid2 && + eq_restriction restriction1 restriction2 + | Friend lid1, Friend lid2 -> + eq_lid lid1 lid2 + | Include (lid1, restriction1), Include (lid2, restriction2) -> + eq_lid lid1 lid2 && + eq_restriction restriction1 restriction2 + | ModuleAbbrev (i1, lid1), ModuleAbbrev (i2, lid2) -> + eq_ident i1 i2 && + eq_lid lid1 lid2 + | TopLevelLet (lq1, pats1), TopLevelLet (lq2, pats2) -> + lq1=lq2 && + eq_list (fun (p1, t1) (p2, t2) -> eq_pattern p1 p2 && eq_term t1 t2) pats1 pats2 + | Tycon (b1, b2, tcs1), Tycon (b3, b4, tcs2) -> + b1 = b3 && + b2 = b4 && + eq_list eq_tycon tcs1 tcs2 + | Val (i1, t1), Val (i2, t2) -> + eq_ident i1 i2 && + eq_term t1 t2 + | Exception (i1, t1), Exception (i2, t2) -> + eq_ident i1 i2 && + eq_option eq_term t1 t2 + | NewEffect ed1, NewEffect ed2 -> + eq_effect_decl ed1 ed2 + | LayeredEffect ed1, LayeredEffect ed2 -> + eq_effect_decl ed1 ed2 + | SubEffect l1, SubEffect l2 -> + eq_lift l1 l2 + | Polymonadic_bind (lid1, lid2, lid3, t1), Polymonadic_bind (lid4, lid5, lid6, t2) -> + eq_lid lid1 lid4 && + eq_lid lid2 lid5 && + eq_lid lid3 lid6 && + eq_term t1 t2 + | Polymonadic_subcomp (lid1, lid2, t1), Polymonadic_subcomp (lid3, lid4, t2) -> + eq_lid lid1 lid3 && + eq_lid lid2 lid4 && + eq_term t1 t2 + | Pragma p1, Pragma p2 -> + eq_pragma p1 p2 + | Assume (i1, t1), Assume (i2, t2) -> + eq_ident i1 i2 && + eq_term t1 t2 + | Splice (is_typed1, is1, t1), Splice (is_typed2, is2, t2) -> + is_typed1 = is_typed2 && + eq_list eq_ident is1 is2 && + eq_term t1 t2 + | DeclSyntaxExtension (s1, t1, _, _), DeclSyntaxExtension (s2, t2, _, _) -> + s1 = s2 && t1 = t2 + | UseLangDecls p1, UseLangDecls p2 -> + p1 = p2 + | DeclToBeDesugared tbs1, DeclToBeDesugared tbs2 -> + tbs1.lang_name = tbs2.lang_name && + tbs1.eq tbs1.blob tbs2.blob + | _ -> false + +and eq_effect_decl (t1 t2: effect_decl) = + match t1, t2 with + | DefineEffect (i1, bs1, t1, ds1), DefineEffect (i2, bs2, t2, ds2) -> + eq_ident i1 i2 && + eq_list eq_binder bs1 bs2 && + eq_term t1 t2 && + eq_list eq_decl ds1 ds2 + | RedefineEffect (i1, bs1, t1), RedefineEffect (i2, bs2, t2) -> + eq_ident i1 i2 && + eq_list eq_binder bs1 bs2 && + eq_term t1 t2 + | _ -> false + +and eq_decl (d1 d2:decl) : bool = + eq_decl' d1.d d2.d && + eq_list eq_qualifier d1.quals d2.quals && + eq_list eq_term d1.attrs d2.attrs + +let concat_map = List.collect +let opt_map f (x:option 'a) = match x with | None -> [] | Some x -> f x + +let rec lidents_of_term (t:term) +: list FStarC.Ident.lident += lidents_of_term' t.tm +and lidents_of_term' (t:term') +: list FStarC.Ident.lident += match t with + | Wild -> [] + | Const _ -> [] + | Op (s, ts) -> concat_map lidents_of_term ts + | Tvar _ -> [] + | Uvar _ -> [] + | Var lid -> [lid] + | Name lid -> [lid] + | Projector (lid, _) -> [lid] + | Construct (lid, ts) -> lid :: concat_map (fun (t, _) -> lidents_of_term t) ts + | Function (brs, _) -> concat_map lidents_of_branch brs + | Abs (ps, t) -> concat_map lidents_of_pattern ps @ lidents_of_term t + | App (t1, t2, _) -> lidents_of_term t1 @ lidents_of_term t2 + | Let (_, lbs, t) -> concat_map (fun (_, (p, t)) -> lidents_of_pattern p @ lidents_of_term t) lbs @ lidents_of_term t + | LetOperator (lbs, t) -> concat_map (fun (_, p, t) -> lidents_of_pattern p @ lidents_of_term t) lbs @ lidents_of_term t + | LetOpen (lid, t) -> lid :: lidents_of_term t + | LetOpenRecord (t1, t2, t3) -> lidents_of_term t1 @ lidents_of_term t2 @ lidents_of_term t3 + | Seq (t1, t2) -> lidents_of_term t1 @ lidents_of_term t2 + | Bind (_, t1, t2) -> lidents_of_term t1 @ lidents_of_term t2 + | If (t1, _, _, t2, t3) -> lidents_of_term t1 @ lidents_of_term t2 @ lidents_of_term t3 + | Match (t, _, _, bs) -> lidents_of_term t @ concat_map lidents_of_branch bs + | TryWith (t, bs) -> lidents_of_term t @ concat_map lidents_of_branch bs + | Ascribed (t1, t2, _, _) -> lidents_of_term t1 @ lidents_of_term t2 + | Record (t, ts) -> concat_map (fun (_, t) -> lidents_of_term t) ts @ opt_map lidents_of_term t + | Project (t, _) -> lidents_of_term t + | Product (ts, t) -> concat_map lidents_of_binder ts @ lidents_of_term t + | Sum (ts, t) -> concat_map (function Inl b -> lidents_of_binder b | Inr t -> lidents_of_term t) ts @ lidents_of_term t + | QForall (bs, _pats, t) -> lidents_of_term t + | QExists (bs, _pats, t) -> lidents_of_term t + | QuantOp (i, bs, pats, t) -> lidents_of_term t + | Refine (b, t) -> lidents_of_term t + | NamedTyp (i, t) -> lidents_of_term t + | Paren t -> lidents_of_term t + | Requires (t, _) -> lidents_of_term t + | Ensures (t, _) -> lidents_of_term t + | LexList ts -> concat_map lidents_of_term ts + | WFOrder (t1, t2) -> lidents_of_term t1 @ lidents_of_term t2 + | Decreases (t, _) -> lidents_of_term t + | Labeled (t, _, _) -> lidents_of_term t + | Discrim lid -> [lid] + | Attributes ts -> concat_map lidents_of_term ts + | Antiquote t -> lidents_of_term t + | Quote (t, _) -> lidents_of_term t + | VQuote t -> lidents_of_term t + | CalcProof (t1, t2, ts) -> lidents_of_term t1 @ lidents_of_term t2 @ concat_map lidents_of_calc_step ts + | IntroForall (bs, t1, t2) -> lidents_of_term t1 @ lidents_of_term t2 + | IntroExists (bs, t1, ts, t2) -> lidents_of_term t1 @ concat_map lidents_of_term ts @ lidents_of_term t2 + | IntroImplies (t1, t2, b, t3) -> lidents_of_term t1 @ lidents_of_term t2 @ lidents_of_term t3 + | IntroOr (b, t1, t2, t3) -> lidents_of_term t1 @ lidents_of_term t2 @ lidents_of_term t3 + | IntroAnd (t1, t2, t3, t4) -> lidents_of_term t1 @ lidents_of_term t2 @ lidents_of_term t3 @ lidents_of_term t4 + | ElimForall (bs, t1, ts) -> concat_map lidents_of_binder bs @ lidents_of_term t1 @ concat_map lidents_of_term ts + | ElimExists (bs, t1, t2, b, t3) -> concat_map lidents_of_binder bs @ lidents_of_term t1 @ lidents_of_term t2 @ lidents_of_term t3 + | ElimImplies (t1, t2, t3) -> lidents_of_term t1 @ lidents_of_term t2 @ lidents_of_term t3 + | ElimOr (t1, t2, t3, b1, t4, b2, t5) -> lidents_of_term t1 @ lidents_of_term t2 @ lidents_of_term t3 @ lidents_of_term t4 @ lidents_of_term t5 + | ElimAnd (t1, t2, t3, b1, b2, t4) -> lidents_of_term t1 @ lidents_of_term t2 @ lidents_of_term t3 @ lidents_of_term t4 + | ListLiteral ts -> concat_map lidents_of_term ts + | SeqLiteral ts -> concat_map lidents_of_term ts +and lidents_of_branch (p, _, t) = lidents_of_pattern p @ lidents_of_term t +and lidents_of_calc_step = function + | CalcStep (t1, t2, t3) -> lidents_of_term t1 @ lidents_of_term t2 @ lidents_of_term t3 +and lidents_of_pattern p = + match p.pat with + | PatWild _ -> [] + | PatConst _ -> [] + | PatApp (p, ps) -> lidents_of_pattern p @ concat_map lidents_of_pattern ps + | PatVar (i, _, _) -> [FStarC.Ident.lid_of_ids [i]] + | PatName lid -> [lid] + | PatTvar (i, _, _) -> [] + | PatList ps -> concat_map lidents_of_pattern ps + | PatTuple (ps, _) -> concat_map lidents_of_pattern ps + | PatRecord ps -> concat_map (fun (_, p) -> lidents_of_pattern p) ps + | PatAscribed (p, (t1, t2)) -> lidents_of_pattern p @ lidents_of_term t1 @ opt_map lidents_of_term t2 + | PatOr ps -> concat_map lidents_of_pattern ps + | PatOp _ -> [] + | PatVQuote t -> lidents_of_term t +and lidents_of_binder b = + match b.b with + | Annotated (_, t) + | TAnnotated(_, t) + | NoName t -> lidents_of_term t + | _ -> [] + +let lidents_of_tycon_record (_, _, _, t) = + lidents_of_term t + +let lidents_of_constructor_payload (t:constructor_payload) = + match t with + | VpOfNotation t -> lidents_of_term t + | VpArbitrary t -> lidents_of_term t + | VpRecord (tc, None) -> concat_map lidents_of_tycon_record tc + | VpRecord (tc, Some t) -> concat_map lidents_of_tycon_record tc @ lidents_of_term t + +let lidents_of_tycon_variant (tc:(ident & option constructor_payload & attributes_)) = + match tc with + | _, None, _ -> [] + | _, Some t, _ -> lidents_of_constructor_payload t + +let lidents_of_tycon (tc:tycon) = + match tc with + | TyconAbstract (_, bs, k) -> concat_map lidents_of_binder bs @ opt_map lidents_of_term k + | TyconAbbrev (_, bs, k, t) -> concat_map lidents_of_binder bs @ opt_map lidents_of_term k @ lidents_of_term t + | TyconRecord (_, bs, k, _, tcs) -> + concat_map lidents_of_binder bs @ + opt_map lidents_of_term k @ + concat_map lidents_of_tycon_record tcs + | TyconVariant (_, bs, k, tcs) -> + concat_map lidents_of_binder bs @ + opt_map lidents_of_term k @ + concat_map lidents_of_tycon_variant tcs + +let lidents_of_lift (l:lift) = + [l.msource; l.mdest]@ + (match l.lift_op with + | NonReifiableLift t -> lidents_of_term t + | ReifiableLift (t1, t2) -> lidents_of_term t1 @ lidents_of_term t2 + | LiftForFree t -> lidents_of_term t) + +let rec lidents_of_decl (d:decl) = + match d.d with + | TopLevelModule _ -> [] + | Open (l, _) + | Friend l + | Include (l, _) + | ModuleAbbrev (_, l) -> [l] + | TopLevelLet (_q, lbs) -> concat_map (fun (p, t) -> lidents_of_pattern p @ lidents_of_term t) lbs + | Tycon (_, _, tcs) -> concat_map lidents_of_tycon tcs + | Val (_, t) -> lidents_of_term t + | Exception (_, None) -> [] + | Exception (_, Some t) -> lidents_of_term t + | NewEffect ed + | LayeredEffect ed -> lidents_of_effect_decl ed + | SubEffect lift -> lidents_of_lift lift + | Polymonadic_bind(l0, l1, l2, t) -> l0::l1::l2::lidents_of_term t + | Polymonadic_subcomp(l0, l1, t) -> l0::l1::lidents_of_term t + | Pragma _ -> [] + | Assume (_, t) -> lidents_of_term t + | Splice (_, _, t) -> lidents_of_term t + | DeclSyntaxExtension _ + | DeclToBeDesugared _ -> [] + +and lidents_of_effect_decl (ed:effect_decl) = + match ed with + | DefineEffect (_, bs, t, ds) -> + concat_map lidents_of_binder bs @ + lidents_of_term t @ + concat_map lidents_of_decl ds + | RedefineEffect (_, bs, t) -> + concat_map lidents_of_binder bs @ + lidents_of_term t + +module BU = FStarC.Compiler.Util +let extension_parser_table : BU.smap extension_parser = FStarC.Compiler.Util.smap_create 20 +let register_extension_parser (ext:string) (parser:extension_parser) = + FStarC.Compiler.Util.smap_add extension_parser_table ext parser + +let lookup_extension_parser (ext:string) = + let do () = FStarC.Compiler.Util.smap_try_find extension_parser_table ext in + match do () with + | None -> + if Plugins.autoload_plugin ext + then do () + else None + | r -> r + +let as_open_namespaces_and_abbrevs (ls:list decl) +: open_namespaces_and_abbreviations += List.fold_right + (fun d out -> + match d.d with + | Open (lid, _) -> {out with open_namespaces = lid :: out.open_namespaces} + | ModuleAbbrev (i, lid) -> {out with module_abbreviations = (i, lid) :: out.module_abbreviations} + | _ -> out) + ls + {open_namespaces = []; module_abbreviations = []} + +let extension_lang_parser_table : BU.smap extension_lang_parser = FStarC.Compiler.Util.smap_create 20 +let register_extension_lang_parser (ext:string) (parser:extension_lang_parser) = + FStarC.Compiler.Util.smap_add extension_lang_parser_table ext parser +let lookup_extension_lang_parser (ext:string) = + let r = FStarC.Compiler.Util.smap_try_find extension_lang_parser_table ext in + match r with + | None -> + if Plugins.autoload_plugin ext + then FStarC.Compiler.Util.smap_try_find extension_lang_parser_table ext + else None + | _ -> r + +let parse_extension_lang (lang_name:string) (raw_text:string) (raw_text_pos:range) +: list decl += let extension_parser = lookup_extension_lang_parser lang_name in + match extension_parser with + | None -> + raise_error raw_text_pos Errors.Fatal_SyntaxError + (BU.format1 "Unknown language extension %s" lang_name) + | Some parser -> + match parser.parse_decls raw_text raw_text_pos with + | Inl error -> + raise_error error.range Errors.Fatal_SyntaxError error.message + | Inr ds -> + ds diff --git a/src/parser/FStarC.Parser.AST.Util.fsti b/src/parser/FStarC.Parser.AST.Util.fsti new file mode 100644 index 00000000000..adfc5f47e21 --- /dev/null +++ b/src/parser/FStarC.Parser.AST.Util.fsti @@ -0,0 +1,70 @@ +(* + Copyright 2023 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + + Authors: N. Swamy and Copilot +*) +module FStarC.Parser.AST.Util +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Parser.AST + +(* Check if two decls are equal, ignoring range metadata. + Used in FStarC.Interactive.Incremental *) +val eq_term (t1 t2:term) : bool +val eq_binder (b1 b2:binder) : bool +val eq_pattern (p1 p2:pattern) : bool +val eq_decl (d1 d2:decl) : bool + +val lidents_of_decl (t:decl) : list FStarC.Ident.lident + +type open_namespaces_and_abbreviations = { + open_namespaces: list FStarC.Ident.lident; + module_abbreviations: list (FStarC.Ident.ident & FStarC.Ident.lident); +} + +type error_message = { + message: string; + range: FStarC.Compiler.Range.range; +} + +type extension_parser = { + parse_decl_name: + (contents:string -> + FStarC.Compiler.Range.range -> + either error_message FStarC.Ident.ident); + + parse_decl: + (open_namespaces_and_abbreviations -> + contents:string -> + p:FStarC.Compiler.Range.range -> + either error_message decl) +} + +val register_extension_parser (extension_name:string) (parser:extension_parser) : unit +val lookup_extension_parser (extension_name:string) : option extension_parser + + +type extension_lang_parser = { + parse_decls: + (contents:string -> + p:FStarC.Compiler.Range.range -> + either error_message (list decl)) +} + +val as_open_namespaces_and_abbrevs (ls:list decl) : open_namespaces_and_abbreviations +val register_extension_lang_parser (extension_name:string) (parser:extension_lang_parser) : unit +val lookup_extension_lang_parser (extension_name:string) : option extension_lang_parser +val parse_extension_lang (lang_name:string) (raw_text:string) (raw_text_pos:FStarC.Compiler.Range.range) : list decl diff --git a/src/parser/FStarC.Parser.AST.fst b/src/parser/FStarC.Parser.AST.fst new file mode 100644 index 00000000000..c2501ed4b27 --- /dev/null +++ b/src/parser/FStarC.Parser.AST.fst @@ -0,0 +1,866 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Parser.AST + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Compiler.Range +open FStarC.Compiler.Util +open FStarC.Const +open FStarC.Errors +open FStarC.Ident +open FStarC.Class.Show +module C = FStarC.Parser.Const + +instance hasRange_term : hasRange term = { + pos = (fun t -> t.range); + setPos = (fun r t -> { t with range = r }); +} + +instance hasRange_pattern : hasRange pattern = { + pos = (fun p -> p.prange); + setPos = (fun r p -> { p with prange = r }); +} + +instance hasRange_binder : hasRange binder = { + pos = (fun b -> b.brange); + setPos = (fun r b -> { b with brange = r }); +} + +instance hasRange_decl : hasRange decl = { + pos = (fun d -> d.drange); + setPos = (fun r d -> { d with drange = r }); +} + +let lid_of_modul (m:modul) : lid = + match m with + | Module(lid, _) -> lid + | Interface (lid, _, _) -> lid + +let check_id id = + let first_char = String.substring (string_of_id id) 0 1 in + if not (String.lowercase first_char = first_char) then + raise_error id Fatal_InvalidIdentifier + (Util.format1 "Invalid identifer '%s'; expected a symbol that begins with a lower-case character" (show id)) + +let at_most_one s (r:range) l = match l with + | [ x ] -> Some x + | [] -> None + | _ -> + raise_error r Fatal_MoreThanOneDeclaration + (Util.format1 "At most one %s is allowed on declarations" s) + +let mk_binder_with_attrs b r l i attrs = {b=b; brange=r; blevel=l; aqual=i; battributes=attrs} +let mk_binder b r l i = mk_binder_with_attrs b r l i [] +let mk_term t r l = {tm=t; range=r; level=l} +let mk_uminus t rminus r l = + let t = + match t.tm with + | Const (Const_int (s, Some (Signed, width))) -> + Const (Const_int ("-" ^ s, Some (Signed, width))) + | _ -> + Op(mk_ident ("-", rminus), [t]) + in + mk_term t r l + +let mk_pattern p r = {pat=p; prange=r} +let un_curry_abs ps body = match body.tm with + | Abs(p', body') -> Abs(ps@p', body') + | _ -> Abs(ps, body) +let mk_function branches r1 r2 = + mk_term (Function (branches, r1)) r2 Expr + +let un_function p tm = match p.pat, tm.tm with + | PatVar _, Abs(pats, body) -> Some (mk_pattern (PatApp(p, pats)) p.prange, body) + | _ -> None + +let mkApp t args r = match args with + | [] -> t + | _ -> match t.tm with + | Name s -> mk_term (Construct(s, args)) r Un + | _ -> List.fold_left (fun t (a,imp) -> mk_term (App(t, a, imp)) r Un) t args + +let consPat r hd tl = PatApp(mk_pattern (PatName C.cons_lid) r, [hd;tl]) +let consTerm r hd tl = mk_term (Construct(C.cons_lid, [(hd, Nothing);(tl, Nothing)])) r Expr + +let mkListLit r elts = + mk_term (ListLiteral elts) r Expr + +let mkSeqLit r elts = + mk_term (SeqLiteral elts) r Expr + +let unit_const r = mk_term(Const Const_unit) r Expr + +let ml_comp t = + let lid = C.effect_ML_lid () in + let ml = mk_term (Name lid) t.range Expr in + let t = mk_term (App(ml, t, Nothing)) t.range Expr in + t + +let tot_comp t = + let ml = mk_term (Name C.effect_Tot_lid) t.range Expr in + let t = mk_term (App(ml, t, Nothing)) t.range Expr in + t + +let mkRefSet r elts = + let empty_lid, singleton_lid, union_lid, addr_of_lid = + C.set_empty, C.set_singleton, C.set_union, C.heap_addr_of_lid in + let empty = mk_term (Var(set_lid_range empty_lid r)) r Expr in + let addr_of = mk_term (Var (set_lid_range addr_of_lid r)) r Expr in + let singleton = mk_term (Var (set_lid_range singleton_lid r)) r Expr in + let union = mk_term (Var(set_lid_range union_lid r)) r Expr in + List.fold_right (fun e tl -> + let e = mkApp addr_of [(e, Nothing)] r in + let single_e = mkApp singleton [(e, Nothing)] r in + mkApp union [(single_e, Nothing); (tl, Nothing)] r) elts empty + +let mkExplicitApp t args r = match args with + | [] -> t + | _ -> match t.tm with + | Name s -> mk_term (Construct(s, (List.map (fun a -> (a, Nothing)) args))) r Un + | _ -> List.fold_left (fun t a -> mk_term (App(t, a, Nothing)) r Un) t args + +let mkAdmitMagic r = + let admit = + let admit_name = mk_term(Var(set_lid_range C.admit_lid r)) r Expr in + mkExplicitApp admit_name [unit_const r] r in + let magic = + let magic_name = mk_term(Var(set_lid_range C.magic_lid r)) r Expr in + mkExplicitApp magic_name [unit_const r] r in + let admit_magic = mk_term(Seq(admit, magic)) r Expr in + admit_magic + +let mkWildAdmitMagic r = (mk_pattern (PatWild (None, [])) r, None, mkAdmitMagic r) + +let focusBranches branches r = + let should_filter = Util.for_some fst branches in + if should_filter + then + let _ = Errors.log_issue r Errors.Warning_Filtered "Focusing on only some cases" in + let focussed = List.filter fst branches |> List.map snd in + focussed@[mkWildAdmitMagic r] + else branches |> List.map snd + +let focusLetBindings lbs r = + let should_filter = Util.for_some fst lbs in + if should_filter + then + let _ = Errors.log_issue r Errors.Warning_Filtered "Focusing on only some cases in this (mutually) recursive definition" in + List.map (fun (f, lb) -> + if f then lb + else (fst lb, mkAdmitMagic r)) lbs + else lbs |> List.map snd + +let focusAttrLetBindings lbs r = + let should_filter = Util.for_some (fun (attr, (focus, _)) -> focus) lbs in + if should_filter + then + let _ = Errors.log_issue r Errors.Warning_Filtered "Focusing on only some cases in this (mutually) recursive definition" in + List.map (fun (attr, (f, lb)) -> + if f then attr, lb + else (attr, (fst lb, mkAdmitMagic r))) lbs + else lbs |> List.map (fun (attr, (_, lb)) -> (attr, lb)) + +let mkFsTypApp t args r = + mkApp t (List.map (fun a -> (a, FsTypApp)) args) r + + (* TODO : is this valid or should it use Construct ? *) +let mkTuple args r = + let cons = C.mk_tuple_data_lid (List.length args) r in + mkApp (mk_term (Name cons) r Expr) (List.map (fun x -> (x, Nothing)) args) r + +let mkDTuple args r = + let cons = C.mk_dtuple_data_lid (List.length args) r in + mkApp (mk_term (Name cons) r Expr) (List.map (fun x -> (x, Nothing)) args) r + +let mkRefinedBinder id t should_bind_var refopt m implicit attrs : binder = + let b = mk_binder_with_attrs (Annotated(id, t)) m Type_level implicit attrs in + match refopt with + | None -> b + | Some phi -> + if should_bind_var + then mk_binder_with_attrs (Annotated(id, mk_term (Refine(b, phi)) m Type_level)) m Type_level implicit attrs + else + let x = gen t.range in + let b = mk_binder_with_attrs (Annotated (x, t)) m Type_level implicit attrs in + mk_binder_with_attrs (Annotated(id, mk_term (Refine(b, phi)) m Type_level)) m Type_level implicit attrs + +let mkRefinedPattern pat t should_bind_pat phi_opt t_range range = + let t = match phi_opt with + | None -> t + | Some phi -> + if should_bind_pat + then + begin match pat.pat with + | PatVar (x,_,attrs) -> + mk_term (Refine(mk_binder_with_attrs (Annotated(x, t)) t_range Type_level None attrs, phi)) range Type_level + | _ -> + let x = gen t_range in + let phi = + (* match x with | pat -> phi | _ -> False *) + let x_var = mk_term (Var (lid_of_ids [x])) phi.range Formula in + let pat_branch = (pat, None, phi)in + let otherwise_branch = + (mk_pattern (PatWild (None, [])) phi.range, None, + mk_term (Name (lid_of_path ["False"] phi.range)) phi.range Formula) + in + mk_term (Match (x_var, None, None, [pat_branch ; otherwise_branch])) phi.range Formula + in + mk_term (Refine(mk_binder (Annotated(x, t)) t_range Type_level None, phi)) range Type_level + end + else + let x = gen t.range in + mk_term (Refine(mk_binder (Annotated (x, t)) t_range Type_level None, phi)) range Type_level + in + mk_pattern (PatAscribed(pat, (t, None))) range + +let rec extract_named_refinement (remove_parens:bool) (t1:term) : option (ident & term & option typ) = + match t1.tm with + | NamedTyp(x, t) -> Some (x, t, None) + | Refine({b=Annotated(x, t)}, t') -> Some (x, t, Some t') + | Paren t when remove_parens -> extract_named_refinement remove_parens t + | _ -> None + +(* Some helpers that parse.mly and parse.fsy will want too *) + +(* JP: what does this function do? A comment would be welcome, or at the very + least a type annotation... + JP: ok, here's my understanding. + This function peeks at the first top-level declaration; + - if this is NOT a TopLevelModule, then we're in interactive mode and return + [Inr list-of-declarations] + - if this IS a TopLevelModule, then we do a forward search and group + declarations together with the preceding [TopLevelModule] and return a [Inl + list-of-modules] where each "module" [Module (lid, list-of-declarations)], with the + unspecified invariant that the first declaration is a [TopLevelModule] + JP: TODO actually forbid multiple modules and remove all of this. *) + +//NS: needed to hoist this to workaround a bootstrapping bug +// leaving it within as_frag causes the type-checker to take a very long time, perhaps looping +let rec as_mlist (cur: (lid & decl) & list decl) (ds:list decl) : modul = + let ((m_name, m_decl), cur) = cur in + match ds with + | [] -> Module(m_name, m_decl :: List.rev cur) + | d :: ds -> + begin match d.d with + | TopLevelModule m' -> + raise_error d Fatal_UnexpectedModuleDeclaration "Unexpected module declaration" + | _ -> + as_mlist ((m_name, m_decl), d::cur) ds + end + +let as_frag (ds:list decl) : inputFragment = + let d, ds = match ds with + | d :: ds -> d, ds + | [] -> raise Empty_frag + in + match d.d with + | TopLevelModule m -> + let m = as_mlist ((m,d), []) ds in + Inl m + | _ -> + let ds = d::ds in + List.iter (function + | {d=TopLevelModule _; drange=r} -> raise_error r Fatal_UnexpectedModuleDeclaration "Unexpected module declaration" + | _ -> () + ) ds; + Inr ds + +// TODO: Move to something like FStarC.Compiler.Util +let strip_prefix (prefix s: string): option string + = if starts_with s prefix + then Some (substring_from s (String.length prefix)) + else None + +let compile_op arity s r = + let name_of_char = function + |'&' -> "Amp" + |'@' -> "At" + |'+' -> "Plus" + |'-' when (arity=1) -> "Minus" + |'-' -> "Subtraction" + |'~' -> "Tilde" + |'/' -> "Slash" + |'\\' -> "Backslash" + |'<' -> "Less" + |'=' -> "Equals" + |'>' -> "Greater" + |'_' -> "Underscore" + |'|' -> "Bar" + |'!' -> "Bang" + |'^' -> "Hat" + |'%' -> "Percent" + |'*' -> "Star" + |'?' -> "Question" + |':' -> "Colon" + |'$' -> "Dollar" + |'.' -> "Dot" + | c -> "u" ^ (Util.string_of_int (Util.int_of_char c)) + in + match s with + | ".[]<-" -> "op_String_Assignment" + | ".()<-" -> "op_Array_Assignment" + | ".[||]<-" -> "op_Brack_Lens_Assignment" + | ".(||)<-" -> "op_Lens_Assignment" + | ".[]" -> "op_String_Access" + | ".()" -> "op_Array_Access" + | ".[||]" -> "op_Brack_Lens_Access" + | ".(||)" -> "op_Lens_Access" + | _ -> // handle let operators (i.e. [let?] or [and*], and [exists*] and [forall*]) + let prefix, s = + if starts_with s "let" || starts_with s "and" + then substring s 0 3 ^ "_", substring_from s 3 + else if starts_with s "exists" || starts_with s "forall" + then substring s 0 6 ^ "_", substring_from s 6 + else "", s in + "op_" ^ prefix ^ String.concat "_" (List.map name_of_char (String.list_of_string s)) + +let compile_op' s r = + compile_op (-1) s r + +let string_to_op s = + let name_of_op s = + match s with + | "Amp" -> Some ("&", None) + | "At" -> Some ("@", None) + | "Plus" -> Some ("+", Some 2) + | "Minus" -> Some ("-", None) + | "Subtraction" -> Some ("-", Some 2) + | "Tilde" -> Some ("~", None) + | "Slash" -> Some ("/", Some 2) + | "Backslash" -> Some ("\\", None) + | "Less" -> Some ("<", Some 2) + | "Equals" -> Some ("=", None) + | "Greater" -> Some (">", Some 2) + | "Underscore" -> Some ("_", None) + | "Bar" -> Some ("|", None) + | "Bang" -> Some ("!", None) + | "Hat" -> Some ("^", None) + | "Percent" -> Some ("%", None) + | "Star" -> Some ("*", None) + | "Question" -> Some ("?", None) + | "Colon" -> Some (":", None) + | "Dollar" -> Some ("$", None) + | "Dot" -> Some (".", None) + | "let" | "and" | "forall" | "exists" -> Some (s, None) + | _ -> None + in + match s with + | "op_String_Assignment" -> Some (".[]<-", None) + | "op_Array_Assignment" -> Some (".()<-", None) + | "op_Brack_Lens_Assignment" -> Some (".[||]<-", None) + | "op_Lens_Assignment" -> Some (".(||)<-", None) + | "op_String_Access" -> Some (".[]", None) + | "op_Array_Access" -> Some (".()", None) + | "op_Brack_Lens_Access" -> Some (".[||]", None) + | "op_Lens_Access" -> Some (".(||)", None) + | _ -> + if starts_with s "op_" + then let frags = split (substring_from s (String.length "op_")) "_" in + match frags with + | [op] -> + if starts_with op "u" + then map_opt (safe_int_of_string (substring_from op 1)) ( + fun op -> (string_of_char (char_of_int op), None) + ) + else name_of_op op + | _ -> + let maybeop = + List.fold_left (fun acc x -> match acc with + | None -> None + | Some acc -> + match x with + | Some (op, _) -> Some (acc ^ op) + | None -> None) + (Some "") + (List.map name_of_op frags) + in + map_opt maybeop (fun o -> (o, None)) + else None + +////////////////////////////////////////////////////////////////////////////////////////////// +// Printing ASTs, mostly for debugging +////////////////////////////////////////////////////////////////////////////////////////////// + +let string_of_fsdoc (comment,keywords) = + comment ^ (String.concat "," (List.map (fun (k,v) -> k ^ "->" ^ v) keywords)) + +let string_of_let_qualifier = function + | NoLetQualifier -> "" + | Rec -> "rec" +let to_string_l sep f l = + String.concat sep (List.map f l) +let imp_to_string = function + | Hash -> "#" + | _ -> "" +let rec term_to_string (x:term) = match x.tm with + | Wild -> "_" + | LexList l -> Util.format1 "%[%s]" + (match l with + | [] -> " " + | hd::tl -> + tl |> List.fold_left (fun s t -> s ^ "; " ^ term_to_string t) (term_to_string hd)) + | Decreases (t, _) -> Util.format1 "(decreases %s)" (term_to_string t) + | Requires (t, _) -> Util.format1 "(requires %s)" (term_to_string t) + | Ensures (t, _) -> Util.format1 "(ensures %s)" (term_to_string t) + | Labeled (t, l, _) -> Util.format2 "(labeled %s %s)" l (term_to_string t) + | Const c -> C.const_to_string c + | Op(s, xs) -> + Util.format2 "%s(%s)" (string_of_id s) (String.concat ", " (List.map (fun x -> x|> term_to_string) xs)) + | Tvar id + | Uvar id -> (string_of_id id) + | Var l + | Name l -> (string_of_lid l) + + | Projector (rec_lid, field_id) -> + Util.format2 "%s?.%s" (string_of_lid rec_lid) ((string_of_id field_id)) + + | Construct (l, args) -> + Util.format2 "(%s %s)" (string_of_lid l) (to_string_l " " (fun (a,imp) -> Util.format2 "%s%s" (imp_to_string imp) (term_to_string a)) args) + | Function (branches, r) -> + Util.format1 "(function %s)" + (to_string_l " | " (fun (p,w,e) -> Util.format2 "%s -> %s" + (p |> pat_to_string) + (e |> term_to_string)) branches) + + | Abs(pats, t) -> + Util.format2 "(fun %s -> %s)" (to_string_l " " pat_to_string pats) (t|> term_to_string) + | App(t1, t2, imp) -> Util.format3 "%s %s%s" (t1|> term_to_string) (imp_to_string imp) (t2|> term_to_string) + | Let (Rec, (a,(p,b))::lbs, body) -> + Util.format4 "%slet rec %s%s in %s" + (attrs_opt_to_string a) + (Util.format2 "%s=%s" (p|> pat_to_string) (b|> term_to_string)) + (to_string_l " " + (fun (a,(p,b)) -> + Util.format3 "%sand %s=%s" + (attrs_opt_to_string a) + (p|> pat_to_string) + (b|> term_to_string)) + lbs) + (body|> term_to_string) + | Let (q, [(attrs,(pat,tm))], body) -> + Util.format5 "%slet %s %s = %s in %s" + (attrs_opt_to_string attrs) + (string_of_let_qualifier q) + (pat|> pat_to_string) + (tm|> term_to_string) + (body|> term_to_string) + | Let (_, _, _) -> + raise_error x Fatal_EmptySurfaceLet "Internal error: found an invalid surface Let" + + | LetOpen (lid, t) -> + Util.format2 "let open %s in %s" (string_of_lid lid) (term_to_string t) + + | Seq(t1, t2) -> + Util.format2 "%s; %s" (t1|> term_to_string) (t2|> term_to_string) + + | Bind (id, t1, t2) -> + Util.format3 "%s <- %s; %s" (string_of_id id) (term_to_string t1) (term_to_string t2) + + | If(t1, op_opt, ret_opt, t2, t3) -> + Util.format5 "if%s %s %sthen %s else %s" + (match op_opt with | Some op -> string_of_id op | None -> "") + (t1|> term_to_string) + (match ret_opt with + | None -> "" + | Some (as_opt, ret, use_eq) -> + let s = if use_eq then "returns$" else "returns" in + Util.format3 "%s%s %s " + (match as_opt with + | None -> "" + | Some as_ident -> Util.format1 " as %s " (string_of_id as_ident)) + s + (term_to_string ret)) + (t2|> term_to_string) + (t3|> term_to_string) + + | Match(t, op_opt, ret_opt, branches) -> try_or_match_to_string x t branches op_opt ret_opt + | TryWith (t, branches) -> try_or_match_to_string x t branches None None + + | Ascribed(t1, t2, None, flag) -> + let s = if flag then "$:" else "<:" in + Util.format3 "(%s %s %s)" (t1|> term_to_string) s (t2|> term_to_string) + | Ascribed(t1, t2, Some tac, flag) -> + let s = if flag then "$:" else "<:" in + Util.format4 "(%s %s %s by %s)" (t1|> term_to_string) s (t2|> term_to_string) (tac |> term_to_string) + | Record(Some e, fields) -> + Util.format2 "{%s with %s}" (e|> term_to_string) (to_string_l " " (fun (l,e) -> Util.format2 "%s=%s" ((string_of_lid l)) (e|> term_to_string)) fields) + | Record(None, fields) -> + Util.format1 "{%s}" (to_string_l " " (fun (l,e) -> Util.format2 "%s=%s" ((string_of_lid l)) (e|> term_to_string)) fields) + | Project(e,l) -> + Util.format2 "%s.%s" (e|> term_to_string) ((string_of_lid l)) + | Product([], t) -> + term_to_string t + | Product(b::hd::tl, t) -> + term_to_string (mk_term (Product([b], mk_term (Product(hd::tl, t)) x.range x.level)) x.range x.level) + | Product([b], t) when (x.level = Type_level) -> + Util.format2 "%s -> %s" (b|> binder_to_string) (t|> term_to_string) + | Product([b], t) when (x.level = Kind) -> + Util.format2 "%s => %s" (b|> binder_to_string) (t|> term_to_string) + | Sum(binders, t) -> + (binders@[Inr t]) |> + List.map (function Inl b -> binder_to_string b + | Inr t -> term_to_string t) |> + String.concat " & " + | QForall(bs, (_, pats), t) -> + Util.format3 "forall %s.{:pattern %s} %s" + (to_string_l " " binder_to_string bs) + (to_string_l " \/ " (to_string_l "; " term_to_string) pats) + (t|> term_to_string) + | QExists(bs, (_, pats), t) -> + Util.format3 "exists %s.{:pattern %s} %s" + (to_string_l " " binder_to_string bs) + (to_string_l " \/ " (to_string_l "; " term_to_string) pats) + (t|> term_to_string) + | QuantOp(i, bs, (_, []), t) -> + Util.format3 "%s %s. %s" + (string_of_id i) + (to_string_l " " binder_to_string bs) + (t|> term_to_string) + | QuantOp(i, bs, (_, pats), t) -> + Util.format4 "%s %s.{:pattern %s} %s" + (string_of_id i) + (to_string_l " " binder_to_string bs) + (to_string_l " \/ " (to_string_l "; " term_to_string) pats) + (t|> term_to_string) + | Refine(b, t) -> + Util.format2 "%s:{%s}" (b|> binder_to_string) (t|> term_to_string) + | NamedTyp(x, t) -> + Util.format2 "%s:%s" (string_of_id x) (t|> term_to_string) + | Paren t -> Util.format1 "(%s)" (t|> term_to_string) + | Product(bs, t) -> + Util.format2 "Unidentified product: [%s] %s" + (bs |> List.map binder_to_string |> String.concat ",") (t|> term_to_string) + + | Discrim lid -> + Util.format1 "%s?" (string_of_lid lid) + + | Attributes ts -> + Util.format1 "(attributes %s)" (String.concat " " <| List.map term_to_string ts) + + | Antiquote t -> + Util.format1 "(`#%s)" (term_to_string t) + + | Quote (t, Static) -> + Util.format1 "(`(%s))" (term_to_string t) + + | Quote (t, Dynamic) -> + Util.format1 "quote (%s)" (term_to_string t) + + | VQuote t -> + Util.format1 "`%%%s" (term_to_string t) + + | CalcProof (rel, init, steps) -> + Util.format3 "calc (%s) { %s %s }" (term_to_string rel) + (term_to_string init) + (String.concat " " <| List.map calc_step_to_string steps) + + + | ElimForall(bs, t, vs) -> + Util.format3 "_elim_ forall %s. %s using %s" + (binders_to_string " " bs) + (term_to_string t) + (String.concat " " (List.map term_to_string vs)) + + | ElimExists(bs, p, q, b, e) -> + Util.format5 "_elim_ exists %s. %s _to_ %s\n\with %s. %s" + (binders_to_string " " bs) + (term_to_string p) + (term_to_string q) + (binder_to_string b) + (term_to_string e) + + | ElimImplies(p, q, e) -> + Util.format3 "_elim_ %s ==> %s with %s" + (term_to_string p) + (term_to_string q) + (term_to_string e) + + | ElimOr(p, q, r, x, e, y, e') -> + Util.format "_elim_ %s \/ %s _to_ %s\n\with %s. %s\n\and %s.%s" + [term_to_string p; + term_to_string q; + term_to_string r; + binder_to_string x; + term_to_string e; + binder_to_string y; + term_to_string e'] + + | ElimAnd(p, q, r, x, y, e) -> + Util.format "_elim_ %s /\ %s _to_ %s\n\with %s %s. %s" + [term_to_string p; + term_to_string q; + term_to_string r; + binder_to_string x; + binder_to_string y; + term_to_string e] + + | IntroForall(xs, p, e) -> + Util.format3 "_intro_ forall %s. %s with %s" + (binders_to_string " " xs) + (term_to_string p) + (term_to_string e) + + | IntroExists(xs, t, vs, e) -> + Util.format4 "_intro_ exists %s. %s using %s with %s" + (binders_to_string " " xs) + (term_to_string t) + (String.concat " " (List.map term_to_string vs)) + (term_to_string e) + + | IntroImplies(p, q, x, e) -> + Util.format4 ("_intro_ %s ==> %s with %s. %s") + (term_to_string p) + (term_to_string q) + (binder_to_string x) + (term_to_string p) + + | IntroOr(b, p, q, r) -> + Util.format4 ("_intro_ %s \/ %s using %s with %s") + (term_to_string p) + (term_to_string q) + (if b then "Left" else "Right") + (term_to_string r) + + | IntroAnd(p, q, e1, e2) -> + Util.format4 ("_intro_ %s /\ %s with %s and %s") + (term_to_string p) + (term_to_string q) + (term_to_string e1) + (term_to_string e2) + + | ListLiteral ts -> + Util.format1 "[%s]" (to_string_l "; " term_to_string ts) + + | SeqLiteral ts -> + Util.format1 "seq![%s]" (to_string_l "; " term_to_string ts) + +and binders_to_string sep bs = + List.map binder_to_string bs |> String.concat sep + +and try_or_match_to_string (x:term) scrutinee branches op_opt ret_opt = + let s = + match x.tm with + | Match _ -> "match" + | TryWith _ -> "try" + | _ -> failwith "impossible" in + Util.format5 "%s%s %s %swith %s" + s + (match op_opt with | Some op -> string_of_id op | None -> "") + (scrutinee|> term_to_string) + (match ret_opt with + | None -> "" + | Some (as_opt, ret, use_eq) -> + let s = if use_eq then "returns$" else "returns" in + Util.format3 "%s%s %s " s + (match as_opt with + | None -> "" + | Some as_ident -> Util.format1 "as %s " (string_of_id as_ident)) + (term_to_string ret)) + (to_string_l " | " (fun (p,w,e) -> Util.format3 "%s %s -> %s" + (p |> pat_to_string) + (match w with | None -> "" | Some e -> Util.format1 "when %s" (term_to_string e)) + (e |> term_to_string)) branches) + +and calc_step_to_string (CalcStep (rel, just, next)) = + Util.format3 "%s{ %s } %s" (term_to_string rel) (term_to_string just) (term_to_string next) + +and binder_to_string x = + let pr x = + let s = match x.b with + | Variable i -> (string_of_id i) + | TVariable i -> Util.format1 "%s:_" ((string_of_id i)) + | TAnnotated(i,t) + | Annotated(i,t) -> Util.format2 "%s:%s" ((string_of_id i)) (t |> term_to_string) + | NoName t -> t |> term_to_string in + Util.format3 "%s%s%s" + (aqual_to_string x.aqual) + (attr_list_to_string x.battributes) + s + in + (* Handle typeclass qualifier here *) + match x.aqual with + | Some TypeClassArg -> "{| " ^ pr x ^ " |}" + | _ -> pr x + +and aqual_to_string = function + | Some Equality -> "$" + | Some Implicit -> "#" + | None -> "" + | Some (Meta _) + | Some TypeClassArg -> + failwith "aqual_to_strings: meta arg qualifier?" + +and attr_list_to_string = function + | [] -> "" + | l -> attrs_opt_to_string (Some l) + +and pat_to_string x = match x.pat with + | PatWild (None, attrs) -> attr_list_to_string attrs ^ "_" + | PatWild (_, attrs) -> "#" ^ (attr_list_to_string attrs) ^ "_" + | PatConst c -> C.const_to_string c + | PatVQuote t -> Util.format1 "`%%%s" (term_to_string t) + | PatApp(p, ps) -> Util.format2 "(%s %s)" (p |> pat_to_string) (to_string_l " " pat_to_string ps) + | PatTvar (i, aq, attrs) + | PatVar (i, aq, attrs) -> Util.format3 "%s%s%s" + (aqual_to_string aq) + (attr_list_to_string attrs) + (string_of_id i) + | PatName l -> (string_of_lid l) + | PatList l -> Util.format1 "[%s]" (to_string_l "; " pat_to_string l) + | PatTuple (l, false) -> Util.format1 "(%s)" (to_string_l ", " pat_to_string l) + | PatTuple (l, true) -> Util.format1 "(|%s|)" (to_string_l ", " pat_to_string l) + | PatRecord l -> Util.format1 "{%s}" (to_string_l "; " (fun (f,e) -> Util.format2 "%s=%s" ((string_of_lid f)) (e |> pat_to_string)) l) + | PatOr l -> to_string_l "|\n " pat_to_string l + | PatOp op -> Util.format1 "(%s)" (Ident.string_of_id op) + | PatAscribed(p,(t, None)) -> Util.format2 "(%s:%s)" (p |> pat_to_string) (t |> term_to_string) + | PatAscribed(p,(t, Some tac)) -> Util.format3 "(%s:%s by %s)" (p |> pat_to_string) (t |> term_to_string) (tac |> term_to_string) + +and attrs_opt_to_string = function + | None -> "" + | Some attrs -> Util.format1 "[@ %s]" (List.map term_to_string attrs |> String.concat "; ") + +let rec head_id_of_pat p = match p.pat with + | PatName l -> [l] + | PatVar (i, _, _) -> [FStarC.Ident.lid_of_ids [i]] + | PatApp(p, _) -> head_id_of_pat p + | PatAscribed(p, _) -> head_id_of_pat p + | _ -> [] + +let lids_of_let defs = defs |> List.collect (fun (p, _) -> head_id_of_pat p) + +let id_of_tycon = function + | TyconAbstract(i, _, _) + | TyconAbbrev(i, _, _, _) + | TyconRecord(i, _, _, _, _) + | TyconVariant(i, _, _, _) -> (string_of_id i) + +let string_of_pragma = function + | ShowOptions -> "show-options" + | SetOptions s -> Util.format1 "set-options \"%s\"" s + | ResetOptions s -> Util.format1 "reset-options \"%s\"" (Util.dflt "" s) + | PushOptions s -> Util.format1 "push-options \"%s\"" (Util.dflt "" s) + | PopOptions -> "pop-options" + | RestartSolver -> "restart-solver" + | PrintEffectsGraph -> "print-effects-graph" + +let restriction_to_string: FStarC.Syntax.Syntax.restriction -> string = + let open FStarC.Syntax.Syntax in + function | Unrestricted -> "" + | AllowList allow_list -> " {" ^ String.concat ", " (List.map (fun (id, renamed) -> string_of_id id ^ dflt "" (map_opt renamed (fun renamed -> " as " ^ string_of_id renamed))) allow_list) ^ "}" + +let rec decl_to_string (d:decl) = match d.d with + | TopLevelModule l -> "module " ^ (string_of_lid l) + | Open (l, r) -> "open " ^ string_of_lid l ^ restriction_to_string r + | Friend l -> "friend " ^ (string_of_lid l) + | Include (l, r) -> "include " ^ string_of_lid l ^ restriction_to_string r + | ModuleAbbrev (i, l) -> Util.format2 "module %s = %s" (string_of_id i) (string_of_lid l) + | TopLevelLet(_, pats) -> "let " ^ (lids_of_let pats |> List.map (fun l -> (string_of_lid l)) |> String.concat ", ") + | Assume(i, _) -> "assume " ^ (string_of_id i) + | Tycon(_, _, tys) -> "type " ^ (tys |> List.map id_of_tycon |> String.concat ", ") + | Val(i, _) -> "val " ^ (string_of_id i) + | Exception(i, _) -> "exception " ^ (string_of_id i) + | NewEffect(DefineEffect(i, _, _, _)) + | NewEffect(RedefineEffect(i, _, _)) -> "new_effect " ^ (string_of_id i) + | LayeredEffect(DefineEffect(i, _, _, _)) + | LayeredEffect(RedefineEffect(i, _, _)) -> "layered_effect " ^ (string_of_id i) + | Polymonadic_bind (l1, l2, l3, _) -> + Util.format3 "polymonadic_bind (%s, %s) |> %s" + (string_of_lid l1) (string_of_lid l2) (string_of_lid l3) + | Polymonadic_subcomp (l1, l2, _) -> + Util.format2 "polymonadic_subcomp %s <: %s" + (string_of_lid l1) (string_of_lid l2) + | Splice (is_typed, ids, t) -> + "splice" ^ (if is_typed then "_t" else "") + ^ "[" + ^ (String.concat ";" <| List.map (fun i -> (string_of_id i)) ids) ^ "] (" ^ term_to_string t ^ ")" + | SubEffect _ -> "sub_effect" + | Pragma p -> "pragma #" ^ string_of_pragma p + | DeclSyntaxExtension (id, content, _, _) -> + "```" ^ id ^ "\n" ^ content ^ "\n```" + | DeclToBeDesugared tbs -> + "(to_be_desugared: " ^ tbs.to_string tbs.blob^ ")" + | UseLangDecls str -> + format1 "#lang-%s" str + | Unparseable -> + "unparseable" + +let modul_to_string (m:modul) = match m with + | Module (_, decls) + | Interface (_, decls, _) -> + decls |> List.map decl_to_string |> String.concat "\n" + +let decl_is_val id decl = + match decl.d with + | Val (id', _) -> + Ident.ident_equals id id' + | _ -> false + +let thunk (ens : term) : term = + let wildpat = mk_pattern (PatWild (None, [])) ens.range in + mk_term (Abs ([wildpat], ens)) ens.range Expr + +let ident_of_binder r b = + match b.b with + | Variable i + | TVariable i + | Annotated (i, _) + | TAnnotated (i, _) -> i + | NoName _ -> + raise_error r Fatal_MissingQuantifierBinder "Wildcard binders in quantifiers are not allowed" + +let idents_of_binders bs r = bs |> List.map (ident_of_binder r) + +instance showable_decl : showable decl = { + show = decl_to_string; +} + +instance showable_term : showable term = { + show = term_to_string; +} + +let add_decorations d decorations = + let decorations = + let attrs, quals = List.partition DeclAttributes? decorations in + let attrs = + match attrs, d.attrs with + | attrs, [] -> attrs + | [DeclAttributes a], attrs -> [DeclAttributes (a @ attrs)] + | [], attrs -> [DeclAttributes attrs] + | _ -> + raise_error d Fatal_MoreThanOneDeclaration + (format2 + "At most one attribute set is allowed on declarations\n got %s;\n and %s" + (String.concat ", " (List.map (function DeclAttributes a -> show a | _ -> "") attrs)) + (String.concat ", " (List.map show d.attrs))) + in + List.map Qualifier d.quals @ + quals @ + attrs + in + let attributes_ = at_most_one "attribute set" d.drange ( + List.choose (function DeclAttributes a -> Some a | _ -> None) decorations + ) in + let attributes_ = Util.dflt [] attributes_ in + let qualifiers = List.choose (function Qualifier q -> Some q | _ -> None) decorations in + { d with quals=qualifiers; attrs=attributes_ } + +let mk_decl d r decorations = + let d = { d=d; drange=r; quals=[]; attrs=[]; interleaved=false } in + add_decorations d decorations + diff --git a/src/parser/FStarC.Parser.AST.fsti b/src/parser/FStarC.Parser.AST.fsti new file mode 100644 index 00000000000..163cd7ce80a --- /dev/null +++ b/src/parser/FStarC.Parser.AST.fsti @@ -0,0 +1,368 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Parser.AST + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.Range +open FStarC.Const +open FStarC.Ident +open FStarC.Class.Show +open FStarC.Class.HasRange + +module S = FStarC.Syntax.Syntax +(* AST produced by the parser, before desugaring + It is not stratified: a single type called "term" containing + expressions, formulas, types, and so on + *) +type level = | Un | Expr | Type_level | Kind | Formula + +type let_qualifier = + | NoLetQualifier + | Rec + +type quote_kind = + | Static + | Dynamic + +type term' = + | Wild + | Const of sconst + | Op of ident & list term + | Tvar of ident + | Uvar of ident (* universe variable *) + | Var of lid // a qualified identifier that starts with a lowercase (Foo.Bar.baz) + | Name of lid // a qualified identifier that starts with an uppercase (Foo.Bar.Baz) + | Projector of lid & ident (* a data constructor followed by one of + its formal parameters, or an effect + followed by one of its actions or + "fields" *) + | Construct of lid & list (term&imp) (* data, type: bool in each arg records an implicit *) + | Abs of list pattern & term (* fun p1 p2 .. pn -> body *) + | Function of list branch & range (* function | p1 -> e1 | ... | pn -> en; range is for binder *) + | App of term & term & imp (* aqual marks an explicitly provided implicit parameter *) + | Let of let_qualifier & list (option attributes_ & (pattern & term)) & term + | LetOperator of list (ident & pattern & term) & term + | LetOpen of lid & term + | LetOpenRecord of term & term & term + | Seq of term & term + | Bind of ident & term & term + | If of term & option ident (* is this a regular if or a if operator (i.e. [if*]) *) + & option match_returns_annotation & term & term + | Match of term & option ident (* is this a regular match or a match operator (i.e. [match*]) *) + & option match_returns_annotation & list branch + | TryWith of term & list branch + | Ascribed of term & term & option term & bool (* bool says whether equality ascription $: *) + | Record of option term & list (lid & term) + | Project of term & lid + | Product of list binder & term (* function space *) + | Sum of list (either binder term) & term (* dependent tuple *) + | QForall of list binder & patterns & term + | QExists of list binder & patterns & term + | QuantOp of ident & list binder & patterns & term + | Refine of binder & term + | NamedTyp of ident & term + | Paren of term + | Requires of term & option string + | Ensures of term & option string + | LexList of list term (* a decreases clause mentions either a lexicographically ordered list, *) + | WFOrder of term & term (* or a well-founded relation or some type and an expression of the same type *) + | Decreases of term & option string + | Labeled of term & string & bool + | Discrim of lid (* Some? (formerly is_Some) *) + | Attributes of list term (* attributes decorating a term *) + | Antiquote of term (* Antiquotation within a quoted term *) + | Quote of term & quote_kind + | VQuote of term (* Quoting an lid, this gets removed by the desugarer *) + | CalcProof of term & term & list calc_step (* A calculational proof with relation, initial expression, and steps *) + | IntroForall of list binder & term & term (* intro_forall x1..xn. P with e *) + | IntroExists of list binder & term & list term & term (* intro_exists x1...xn.P using v1..vn with e *) + | IntroImplies of term & term & binder & term (* intro_implies P Q with x. e *) + | IntroOr of bool & term & term & term (* intro_or_{left ,right} P Q with e *) + | IntroAnd of term & term & term & term (* intro_and P Q with e1 and e2 *) + | ElimForall of list binder & term & list term (* elim_forall x1..xn. P using v1..vn *) + | ElimExists of list binder & term & term & binder & term (* elim_exists x1...xn.P to Q with e *) + | ElimImplies of term & term & term (* elim_implies P Q with e *) + | ElimOr of term & term & term & binder & term & binder & term (* elim_or P Q to R with x.e1 and y.e2 *) + | ElimAnd of term & term & term & binder & binder & term (* elim_and P Q to R with x y. e *) + | ListLiteral of list term + | SeqLiteral of list term + + +and term = {tm:term'; range:range; level:level} + + + +(* (as y)? returns t *) +and match_returns_annotation = option ident & term & bool + +and patterns = list ident & list (list term) + +and calc_step = + | CalcStep of term & term & term (* Relation, justification and next expression *) + +and attributes_ = list term + +and binder' = + | Variable of ident + | TVariable of ident + | Annotated of ident & term + | TAnnotated of ident & term + | NoName of term + +and binder = {b:binder'; brange:range; blevel:level; aqual:aqual; battributes:attributes_} + +and pattern' = + | PatWild of aqual & attributes_ + | PatConst of sconst + | PatApp of pattern & list pattern + | PatVar of ident & aqual & attributes_ + | PatName of lid + | PatTvar of ident & aqual & attributes_ + | PatList of list pattern + | PatTuple of list pattern & bool (* dependent if flag is set *) + | PatRecord of list (lid & pattern) + | PatAscribed of pattern & (term & option term) + | PatOr of list pattern + | PatOp of ident + | PatVQuote of term (* [`%foo], transformed into "X.Y.Z.foo" by the desugarer *) +and pattern = {pat:pattern'; prange:range} + +and branch = (pattern & option term & term) +and arg_qualifier = + | Implicit + | Equality + | Meta of term + | TypeClassArg +and aqual = option arg_qualifier +and imp = + | FsTypApp + | Hash + | UnivApp + | HashBrace of term + | Infix + | Nothing + +instance val hasRange_term : hasRange term +instance val hasRange_pattern : hasRange pattern +instance val hasRange_binder : hasRange binder + +type knd = term +type typ = term +type expr = term + +type tycon_record = list (ident & aqual & attributes_ & term) + +(** The different kinds of payload a constructor can carry *) +type constructor_payload + = (** constructor of arity 1 for a type of kind [Type] (e.g. [C of int]) *) + | VpOfNotation of typ + (** constructor of any arity & kind (e.g. [C:int->ind] or [C:'a->'b->ind 'c]) *) + | VpArbitrary of typ + (** constructor whose payload is a record (e.g. [C {a: int}] or [C {x: Type} -> ind x]) *) + | VpRecord of (tycon_record & option typ) + +(* TODO (KM) : it would be useful for the printer to have range information for those *) +type tycon = + | TyconAbstract of ident & list binder & option knd + | TyconAbbrev of ident & list binder & option knd & term + | TyconRecord of ident & list binder & option knd & attributes_ & tycon_record + | TyconVariant of ident & list binder & option knd & list (ident & option constructor_payload & attributes_) + +type qualifier = + | Private + | Noeq + | Unopteq + | Assumption + | DefaultEffect + | TotalEffect + | Effect_qual + | New + | Inline //a definition that *should* always be unfolded by the normalizer + | Visible //a definition that may be unfolded by the normalizer, but only if necessary (default) + | Unfold_for_unification_and_vcgen //a definition that will be unfolded by the normalizer, during unification and for SMT queries + | Inline_for_extraction //a definition that will be inlined only during compilation + | Irreducible //a definition that can never be unfolded by the normalizer + | NoExtract // a definition whose contents won't be extracted (currently, by KaRaMeL only) + | Reifiable + | Reflectable + //old qualifiers + | Opaque + | Logic + +type qualifiers = list qualifier + +type decoration = + | Qualifier of qualifier + | DeclAttributes of list term + +type lift_op = + | NonReifiableLift of term + | ReifiableLift of term & term //lift_wp, lift + | LiftForFree of term + +type lift = { + msource: lid; + mdest: lid; + lift_op: lift_op; + braced: bool; //a detail: for incremental parsing, we need to know if it is delimited by bracces +} + +type pragma = + | ShowOptions + | SetOptions of string + | ResetOptions of option string + | PushOptions of option string + | PopOptions + | RestartSolver + | PrintEffectsGraph + +type dep_scan_callbacks = { + scan_term: term -> unit; + scan_binder: binder -> unit; + scan_pattern: pattern -> unit; + add_lident: lident -> unit; + add_open: lident -> unit; +} + +type to_be_desugared = { + lang_name: string; + blob: FStarC.Dyn.dyn; + idents: list ident; + to_string: FStarC.Dyn.dyn -> string; + eq: FStarC.Dyn.dyn -> FStarC.Dyn.dyn -> bool; + dep_scan: dep_scan_callbacks -> FStarC.Dyn.dyn -> unit +} + +type decl' = + | TopLevelModule of lid + | Open of lid & FStarC.Syntax.Syntax.restriction + | Friend of lid + | Include of lid & FStarC.Syntax.Syntax.restriction + | ModuleAbbrev of ident & lid + | TopLevelLet of let_qualifier & list (pattern & term) + | Tycon of bool & bool & list tycon + (* first bool is for effect *) + (* second bool is for typeclass *) + | Val of ident & term (* bool is for logic val *) + | Exception of ident & option term + | NewEffect of effect_decl + | LayeredEffect of effect_decl + | SubEffect of lift + | Polymonadic_bind of lid & lid & lid & term + | Polymonadic_subcomp of lid & lid & term + | Pragma of pragma + | Assume of ident & term + | Splice of bool & list ident & term (* bool is true for a typed splice *) + (* The first range is the entire range of the blob. + The second range is the start point of the extension syntax itself *) + | DeclSyntaxExtension of string & string & range & range + | UseLangDecls of string + | DeclToBeDesugared of to_be_desugared + | Unparseable + +and decl = { + d:decl'; + drange:range; + quals: qualifiers; + attrs: attributes_; + interleaved: bool; +} +and effect_decl = + (* KM : Is there really need of the generality of decl here instead of e.g. lid * term ? *) + | DefineEffect of ident & list binder & term & list decl + | RedefineEffect of ident & list binder & term + +instance val hasRange_decl : hasRange decl + +type modul = + | Module of lid & list decl + | Interface of lid & list decl & bool (* flag to mark admitted interfaces *) +type file = modul +type inputFragment = either file (list decl) + +val lid_of_modul : modul -> lid + +(* Smart constructors *) +val mk_decl : decl' -> range -> list decoration -> decl +val add_decorations: decl -> list decoration -> decl +val mk_binder_with_attrs : binder' -> range -> level -> aqual -> list term -> binder +val mk_binder : binder' -> range -> level -> aqual -> binder +val mk_term : term' -> range -> level -> term + +val mk_uminus : term -> range -> range -> level -> term +val mk_pattern : pattern' -> range -> pattern + +val un_curry_abs : list pattern -> term -> term' +val mk_function : list branch -> range -> range -> term +val un_function : pattern -> term -> option (pattern & term) + +val consPat : range -> pattern -> pattern -> pattern' +val consTerm : range -> term -> term -> term + +val unit_const : range -> term +val ml_comp : term -> term +val tot_comp : term -> term + +val mkApp : term -> list (term & imp) -> range -> term +val mkExplicitApp : term -> list term -> range -> term + +val mkRefSet : range -> list term -> term + +val focusLetBindings : list (bool & (pattern & term)) -> range -> list (pattern & term) +val focusAttrLetBindings : list (option attributes_ & (bool & (pattern & term))) -> range -> list (option attributes_ & (pattern & term)) + +val mkFsTypApp : term -> list term -> range -> term +val mkTuple : list term -> range -> term +val mkDTuple : list term -> range -> term +val mkRefinedBinder : ident -> term -> bool -> option term -> range -> aqual -> list term -> binder +val mkRefinedPattern : pattern -> term -> bool -> option term -> range -> range -> pattern +val extract_named_refinement : bool -> term -> option (ident & term & option term) + +val as_frag : list decl -> inputFragment + +// TODO: Move to something like FStarC.Compiler.Util +val strip_prefix : string -> string -> option string + +val compile_op : int -> string -> range -> string +val compile_op' : string -> range -> string +val string_to_op : string -> option (string & option int) // returns operator symbol and optional arity + +val string_of_fsdoc : string & list (string & string) -> string +val string_of_let_qualifier : let_qualifier -> string + +val term_to_string : term -> string + +val lids_of_let : list (pattern & term) -> list lident +val id_of_tycon : tycon -> string + +val string_of_pragma : pragma -> string +val pat_to_string : pattern -> string +val binder_to_string : binder -> string +val modul_to_string : modul -> string + +val decl_is_val : ident -> decl -> bool + +val thunk : term -> term + +val check_id : ident -> unit + +val ident_of_binder : range -> binder -> ident +val idents_of_binders : list binder -> range -> list ident + +instance val showable_decl : showable decl +instance val showable_term : showable term diff --git a/src/parser/FStarC.Parser.Const.fst b/src/parser/FStarC.Parser.Const.fst new file mode 100644 index 00000000000..c37ad430fc5 --- /dev/null +++ b/src/parser/FStarC.Parser.Const.fst @@ -0,0 +1,585 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR C ONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Parser.Const + +open FStar.String +open FStarC +open FStarC.Compiler.Effect +open FStarC.Compiler.Util +open FStarC.Ident +open FStarC.Compiler.Range +open FStarC.Const +open FStarC.Compiler.List +module U = FStarC.Compiler.Util +module Options = FStarC.Options +module List = FStarC.Compiler.List + +let p2l l = lid_of_path l dummyRange + +let pconst s = p2l ["Prims";s] +let psconst s = p2l ["FStar"; "Pervasives"; s] +let psnconst s = p2l ["FStar"; "Pervasives" ; "Native" ; s] +let prims_lid = p2l ["Prims"] +let pervasives_native_lid = p2l ["FStar"; "Pervasives"; "Native"] +let pervasives_lid = p2l ["FStar"; "Pervasives"] +let fstar_ns_lid = p2l ["FStar"] + +(* Primitive types *) +let bool_lid = pconst "bool" +let unit_lid = pconst "unit" +let squash_lid = pconst "squash" +let auto_squash_lid = pconst "auto_squash" +let string_lid = pconst "string" +let bytes_lid = pconst "bytes" +let int_lid = pconst "int" +let exn_lid = pconst "exn" +let list_lid = pconst "list" +let immutable_array_t_lid = p2l ["FStar"; "ImmutableArray"; "Base"; "t"] +let immutable_array_of_list_lid = p2l ["FStar"; "ImmutableArray"; "Base"; "of_list"] +let immutable_array_length_lid = p2l ["FStar"; "ImmutableArray"; "Base"; "length"] +let immutable_array_index_lid = p2l ["FStar"; "ImmutableArray"; "Base"; "index"] +let eqtype_lid = pconst "eqtype" +let option_lid = psnconst "option" +let either_lid = psconst "either" +let pattern_lid = psconst "pattern" +let lex_t_lid = pconst "lex_t" +let precedes_lid = pconst "precedes" +let smtpat_lid = psconst "smt_pat" +let smtpatOr_lid = psconst "smt_pat_or" +let monadic_lid = pconst "M" +let spinoff_lid = psconst "spinoff" +let inl_lid = psconst "Inl" +let inr_lid = psconst "Inr" + +let int8_lid = p2l ["FStar"; "Int8"; "t"] +let uint8_lid = p2l ["FStar"; "UInt8"; "t"] +let int16_lid = p2l ["FStar"; "Int16"; "t"] +let uint16_lid = p2l ["FStar"; "UInt16"; "t"] +let int32_lid = p2l ["FStar"; "Int32"; "t"] +let uint32_lid = p2l ["FStar"; "UInt32"; "t"] +let int64_lid = p2l ["FStar"; "Int64"; "t"] +let uint64_lid = p2l ["FStar"; "UInt64"; "t"] +let sizet_lid = p2l ["FStar"; "SizeT"; "t"] + +let salloc_lid = p2l ["FStar"; "ST"; "salloc"] +let swrite_lid = p2l ["FStar"; "ST"; "op_Colon_Equals"] +let sread_lid = p2l ["FStar"; "ST"; "op_Bang"] + +let max_lid = p2l ["max"] + +let real_lid = p2l ["FStar"; "Real"; "real"] + +let float_lid = p2l ["FStar"; "Float"; "float"] + +let char_lid = p2l ["FStar"; "Char"; "char"] + +let heap_lid = p2l ["FStar"; "Heap"; "heap"] + +let logical_lid = pconst "logical" +let prop_lid = pconst "prop" + +let smt_theory_symbol_attr_lid = pconst "smt_theory_symbol" + +let true_lid = pconst "l_True" +let false_lid = pconst "l_False" +let and_lid = pconst "l_and" +let or_lid = pconst "l_or" +let not_lid = pconst "l_not" +let imp_lid = pconst "l_imp" +let iff_lid = pconst "l_iff" +let ite_lid = pconst "l_ITE" +let exists_lid = pconst "l_Exists" +let forall_lid = pconst "l_Forall" +let haseq_lid = pconst "hasEq" +let b2t_lid = pconst "b2t" (* coercion from boolean to type *) +let admit_lid = pconst "admit" +let magic_lid = pconst "magic" +let has_type_lid = pconst "has_type" + +(* Constructive variants *) +let c_true_lid = pconst "trivial" +let empty_type_lid = pconst "empty" +let c_and_lid = pconst "pair" +let c_or_lid = pconst "sum" +let dtuple2_lid = pconst "dtuple2" // for l_Exists + +(* Various equality predicates *) +let eq2_lid = pconst "eq2" +let eq3_lid = pconst "op_Equals_Equals_Equals" +let c_eq2_lid = pconst "equals" + +(* Some common term constructors *) +let cons_lid = pconst "Cons" +let nil_lid = pconst "Nil" +let some_lid = psnconst "Some" +let none_lid = psnconst "None" +let assume_lid = pconst "_assume" +let assert_lid = pconst "_assert" +let pure_wp_lid = pconst "pure_wp" +let pure_wp_monotonic_lid = pconst "pure_wp_monotonic" +let pure_wp_monotonic0_lid = pconst "pure_wp_monotonic0" +let trivial_pure_post_lid = psconst "trivial_pure_post" +let pure_assert_wp_lid = pconst "pure_assert_wp0" +let pure_assume_wp_lid = pconst "pure_assume_wp0" +let assert_norm_lid = p2l ["FStar"; "Pervasives"; "assert_norm"] +(* list_append_lid is needed to desugar @ in the compiler *) +let list_append_lid = p2l ["FStar"; "List"; "append"] +(* list_tot_append_lid is used to desugar @ everywhere else *) +let list_tot_append_lid = p2l ["FStar"; "List"; "Tot"; "Base"; "append"] +let id_lid = psconst "id" + +let seq_cons_lid = p2l ["FStar"; "Seq"; "Base"; "cons"] +let seq_empty_lid = p2l ["FStar"; "Seq"; "Base"; "empty"] + +/// Constants from FStar.Char +let c2l s = p2l ["FStar"; "Char"; s] +let char_u32_of_char = c2l "u32_of_char" + +/// Constants from FStar.String +let s2l n = p2l ["FStar"; "String"; n] +let string_list_of_string_lid = s2l "list_of_string" +let string_string_of_list_lid = s2l "string_of_list" +let string_make_lid = s2l "make" +let string_split_lid = s2l "split" +let string_concat_lid = s2l "concat" +let string_compare_lid = s2l "compare" +let string_lowercase_lid = s2l "lowercase" +let string_uppercase_lid = s2l "uppercase" +let string_index_lid = s2l "index" +let string_index_of_lid = s2l "index_of" +let string_sub_lid = s2l "sub" +let prims_strcat_lid = pconst "strcat" +let prims_op_Hat_lid = pconst "op_Hat" + +let let_in_typ = p2l ["Prims"; "Let"] +let string_of_int_lid = p2l ["Prims"; "string_of_int"] +let string_of_bool_lid = p2l ["Prims"; "string_of_bool"] +let int_of_string_lid = p2l ["FStar"; "Parse"; "int_of_string"] +let bool_of_string_lid = p2l ["FStar"; "Parse"; "bool_of_string"] +let string_compare = p2l ["FStar"; "String"; "compare"] +let order_lid = p2l ["FStar"; "Order"; "order"] +let vconfig_lid = p2l ["FStar"; "Stubs"; "VConfig"; "vconfig"] +let mkvconfig_lid = p2l ["FStar"; "Stubs"; "VConfig"; "Mkvconfig"] + +(* Primitive operators *) +let op_Eq = pconst "op_Equality" +let op_notEq = pconst "op_disEquality" +let op_LT = pconst "op_LessThan" +let op_LTE = pconst "op_LessThanOrEqual" +let op_GT = pconst "op_GreaterThan" +let op_GTE = pconst "op_GreaterThanOrEqual" +let op_Subtraction = pconst "op_Subtraction" +let op_Minus = pconst "op_Minus" +let op_Addition = pconst "op_Addition" +let op_Multiply = pconst "op_Multiply" +let op_Division = pconst "op_Division" +let op_Modulus = pconst "op_Modulus" +let op_And = pconst "op_AmpAmp" +let op_Or = pconst "op_BarBar" +let op_Negation = pconst "op_Negation" +let subtype_of_lid = pconst "subtype_of" + +let real_const s = p2l ["FStar";"Real";s] +let real_op_LT = real_const "op_Less_Dot" +let real_op_LTE = real_const "op_Less_Equals_Dot" +let real_op_GT = real_const "op_Greater_Dot" +let real_op_GTE = real_const "op_Greater_Equals_Dot" +let real_op_Subtraction = real_const "op_Subtraction_Dot" +let real_op_Addition = real_const "op_Plus_Dot" +let real_op_Multiply = real_const "op_Star_Dot" +let real_op_Division = real_const "op_Slash_Dot" +let real_of_int = real_const "of_int" + + +let bvconst s = p2l ["FStar"; "BV"; s] + +(* BitVector constants *) +let bv_t_lid = bvconst "bv_t" //redundant +//let bv_zero_vec_lid = bvconst "bv_zero" +//let bv_ones_vec_lid = bvconst "ones_vec" + +(* BitVector operators *) +let nat_to_bv_lid = bvconst "int2bv" +let bv_to_nat_lid = bvconst "bv2int" +let bv_and_lid = bvconst "bvand" +let bv_xor_lid = bvconst "bvxor" +let bv_or_lid = bvconst "bvor" +let bv_add_lid = bvconst "bvadd" +let bv_sub_lid = bvconst "bvsub" +let bv_shift_left_lid = bvconst "bvshl" +let bv_shift_right_lid = bvconst "bvshr" +let bv_udiv_lid = bvconst "bvdiv" +let bv_mod_lid = bvconst "bvmod" +let bv_mul_lid = bvconst "bvmul" +// shifts, division and multiplication take natural numbers as their second +// arguments, which incurs some encoding overhead. The primed versions bvshl', +// bvshr', bvdiv_unsafe, bvmod_unsafe and bvmul' take a bitvector as the second +// argument instead, which more closely matches SMT-LIB. +let bv_shift_left'_lid = bvconst "bvshl'" +let bv_shift_right'_lid= bvconst "bvshr'" +let bv_udiv_unsafe_lid = bvconst "bvdiv_unsafe" +let bv_mod_unsafe_lid = bvconst "bvmod_unsafe" +let bv_mul'_lid = bvconst "bvmul'" + +let bv_ult_lid = bvconst "bvult" +let bv_uext_lid = bvconst "bv_uext" + +(* Array constants *) +let array_lid = p2l ["FStar"; "Array"; "array"] +let array_of_list_lid = p2l ["FStar"; "Array"; "of_list"] + +(* Stateful constants *) +let st_lid = p2l ["FStar"; "ST"] +let write_lid = p2l ["FStar"; "ST"; "write"] +let read_lid = p2l ["FStar"; "ST"; "read"] +let alloc_lid = p2l ["FStar"; "ST"; "alloc"] +let op_ColonEq = p2l ["FStar"; "ST"; "op_Colon_Equals"] + +(* Constants for sets and ref sets *) +let ref_lid = p2l ["FStar"; "Heap"; "ref"] +let heap_addr_of_lid = p2l ["FStar"; "Heap"; "addr_of"] +let set_empty = p2l ["FStar"; "Set"; "empty"] +let set_singleton = p2l ["FStar"; "Set"; "singleton"] +let set_union = p2l ["FStar"; "Set"; "union"] +let fstar_hyperheap_lid = p2l ["FStar"; "HyperHeap"] +let rref_lid = p2l ["FStar"; "HyperHeap"; "rref"] + +(* Other special constants *) +let erased_lid = p2l ["FStar"; "Ghost"; "erased"] + +(* monad constants *) +let effect_PURE_lid = pconst "PURE" +let effect_Pure_lid = pconst "Pure" +let effect_Tot_lid = pconst "Tot" +let effect_Lemma_lid = psconst "Lemma" +let effect_GTot_lid = pconst "GTot" +let effect_GHOST_lid = pconst "GHOST" +let effect_Ghost_lid = pconst "Ghost" +let effect_DIV_lid = psconst "DIV" +let effect_Div_lid = psconst "Div" +let effect_Dv_lid = psconst "Dv" + +(* The "All" monad and its associated symbols. + +NOTE: With --MLish and --MLish_effect this is somewhat configurable *) + +let ef_base () = + if Options.ml_ish () + then String.split ['.'] <| Options.ml_ish_effect () + else ["FStar"; "All"] + +let effect_ALL_lid () = p2l <| ef_base () @ ["ALL"] +let effect_ML_lid () = p2l <| ef_base () @ ["ML"] +let failwith_lid () = p2l <| ef_base () @ ["failwith"] +let try_with_lid () = p2l <| ef_base () @ ["try_with"] + +let as_requires = pconst "as_requires" +let as_ensures = pconst "as_ensures" +let decreases_lid = pconst "decreases" + +let reveal = p2l ["FStar"; "Ghost"; "reveal"] +let hide = p2l ["FStar"; "Ghost"; "hide"] + +(* FStar.Range *) +let labeled_lid = p2l ["FStar"; "Range"; "labeled"] +let __range_lid = p2l ["FStar"; "Range"; "__range"] +let range_lid = p2l ["FStar"; "Range"; "range"] (* this is a sealed version of the above *) +let range_0 = p2l ["FStar"; "Range"; "range_0"] +let mk_range_lid = p2l ["FStar"; "Range"; "mk_range"] +let __mk_range_lid = p2l ["FStar"; "Range"; "__mk_range"] +let __explode_range_lid = p2l ["FStar"; "Range"; "explode"] +let join_range_lid = p2l ["FStar"; "Range"; "join_range"] + +let guard_free = pconst "guard_free" +let inversion_lid = p2l ["FStar"; "Pervasives"; "inversion"] + +(* Constants for marking terms with normalization hints *) +let normalize = psconst "normalize" +let normalize_term = psconst "normalize_term" +let norm = psconst "norm" + +(* lids for normalizer steps *) +let steps_simpl = psconst "simplify" +let steps_weak = psconst "weak" +let steps_hnf = psconst "hnf" +let steps_primops = psconst "primops" +let steps_zeta = psconst "zeta" +let steps_zeta_full = psconst "zeta_full" +let steps_iota = psconst "iota" +let steps_delta = psconst "delta" +let steps_reify = psconst "reify_" +let steps_norm_debug = psconst "norm_debug" +let steps_unfoldonly = psconst "delta_only" +let steps_unfoldfully = psconst "delta_fully" +let steps_unfoldattr = psconst "delta_attr" +let steps_unfoldqual = psconst "delta_qualifier" +let steps_unfoldnamespace = psconst "delta_namespace" +let steps_unascribe = psconst "unascribe" +let steps_nbe = psconst "nbe" +let steps_unmeta = psconst "unmeta" + +(* attributes *) +let deprecated_attr = pconst "deprecated" +let warn_on_use_attr = pconst "warn_on_use" +let inline_let_attr = p2l ["FStar"; "Pervasives"; "inline_let"] +let rename_let_attr = p2l ["FStar"; "Pervasives"; "rename_let"] +let plugin_attr = p2l ["FStar"; "Pervasives"; "plugin"] +let tcnorm_attr = p2l ["FStar"; "Pervasives"; "tcnorm"] +let dm4f_bind_range_attr = p2l ["FStar"; "Pervasives"; "dm4f_bind_range"] +let must_erase_for_extraction_attr = psconst "must_erase_for_extraction" +let strict_on_arguments_attr = p2l ["FStar"; "Pervasives"; "strict_on_arguments"] +let resolve_implicits_attr_string = "FStar.Pervasives.resolve_implicits" +let unification_tag_lid = psconst "defer_to" +let override_resolve_implicits_handler_lid = p2l ["FStar"; "Pervasives"; "override_resolve_implicits_handler"] +let handle_smt_goals_attr = psconst "handle_smt_goals" +let handle_smt_goals_attr_string = "FStar.Pervasives.handle_smt_goals" +let erasable_attr = p2l ["FStar"; "Pervasives"; "erasable"] +let comment_attr = p2l ["FStar"; "Pervasives"; "Comment"] +let c_inline_attr = p2l ["FStar"; "Pervasives"; "CInline"] +let fail_attr = psconst "expect_failure" +let fail_lax_attr = psconst "expect_lax_failure" +let tcdecltime_attr = psconst "tcdecltime" +let noextract_to_attr = psconst "noextract_to" +let unifier_hint_injective_lid = psconst "unifier_hint_injective" +let normalize_for_extraction_lid = psconst "normalize_for_extraction" +let commute_nested_matches_lid = psconst "commute_nested_matches" +let remove_unused_type_parameters_lid = psconst "remove_unused_type_parameters" +let ite_soundness_by_attr = psconst "ite_soundness_by" +let default_effect_attr = psconst "default_effect" +let top_level_effect_attr = psconst "top_level_effect" +let effect_parameter_attr = psconst "effect_param" +let bind_has_range_args_attr = psconst "bind_has_range_args" +let primitive_extraction_attr = psconst "primitive_extraction" +let binder_strictly_positive_attr = psconst "strictly_positive" +let binder_unused_attr = psconst "unused" +let no_auto_projectors_decls_attr = psconst "no_auto_projectors_decls" +let no_auto_projectors_attr = psconst "no_auto_projectors" +let no_subtping_attr_lid = psconst "no_subtyping" +let admit_termination_lid = psconst "admit_termination" +let unrefine_binder_attr = pconst "unrefine" +let do_not_unrefine_attr = pconst "do_not_unrefine" +let attr_substitute_lid = p2l ["FStar"; "Pervasives"; "Substitute"] +let desugar_of_variant_record_lid = psconst "desugar_of_variant_record" + + +//the type of well-founded relations, used for decreases clauses with relations +let well_founded_relation_lid = p2l ["FStar"; "WellFounded"; "well_founded_relation"] + +let gen_reset = + let x = U.mk_ref 0 in + let gen () = U.incr x; U.read x in + let reset () = U.write x 0 in + gen, reset +let next_id = fst gen_reset + +let sli (l:lident) : string = + if FStarC.Options.print_real_names() + then string_of_lid l + else string_of_id (ident_of_lid l) + +let const_to_string x = match x with + | Const_effect -> "Effect" + | Const_unit -> "()" + | Const_bool b -> if b then "true" else "false" + | Const_real r -> r^"R" + | Const_string(s, _) -> U.format1 "\"%s\"" s + | Const_int (x, _) -> x + | Const_char c -> "'" ^ U.string_of_char c ^ "'" + | Const_range r -> FStarC.Compiler.Range.string_of_range r + | Const_range_of -> "range_of" + | Const_set_range_of -> "set_range_of" + | Const_reify lopt -> + U.format1 "reify%s" + (match lopt with + | None -> "" + | Some l -> U.format1 "<%s>" (string_of_lid l)) + | Const_reflect l -> U.format1 "[[%s.reflect]]" (sli l) + + +(* Tuples *) + +let mk_tuple_lid n r = + let t = U.format1 "tuple%s" (U.string_of_int n) in + set_lid_range (psnconst t) r + +let lid_tuple2 = mk_tuple_lid 2 dummyRange +let lid_tuple3 = mk_tuple_lid 3 dummyRange +let lid_tuple4 = mk_tuple_lid 4 dummyRange +let lid_tuple5 = mk_tuple_lid 5 dummyRange + +let is_tuple_constructor_string (s:string) :bool = + U.starts_with s "FStar.Pervasives.Native.tuple" + +let is_tuple_constructor_id id = is_tuple_constructor_string (string_of_id id) +let is_tuple_constructor_lid lid = is_tuple_constructor_string (string_of_lid lid) + +let mk_tuple_data_lid n r = + let t = U.format1 "Mktuple%s" (U.string_of_int n) in + set_lid_range (psnconst t) r + +let lid_Mktuple2 = mk_tuple_data_lid 2 dummyRange +let lid_Mktuple3 = mk_tuple_data_lid 3 dummyRange +let lid_Mktuple4 = mk_tuple_data_lid 4 dummyRange +let lid_Mktuple5 = mk_tuple_data_lid 5 dummyRange + +let is_tuple_datacon_string (s:string) :bool = + U.starts_with s "FStar.Pervasives.Native.Mktuple" + +let is_tuple_datacon_id id = is_tuple_datacon_string (string_of_id id) +let is_tuple_datacon_lid lid = is_tuple_datacon_string (string_of_lid lid) + +let is_tuple_data_lid f n = + lid_equals f (mk_tuple_data_lid n dummyRange) + +let is_tuple_data_lid' f = is_tuple_datacon_string (string_of_lid f) + + +(* Dtuples *) + +(* dtuple is defined in prims if n = 2, in pervasives otherwise *) +let mod_prefix_dtuple (n:int) :(string -> lident) = + if n = 2 then pconst else psconst + +let mk_dtuple_lid n r = + let t = U.format1 "dtuple%s" (U.string_of_int n) in + set_lid_range ((mod_prefix_dtuple n) t) r + +let is_dtuple_constructor_string (s:string) :bool = + s = "Prims.dtuple2" || U.starts_with s "FStar.Pervasives.dtuple" + +let is_dtuple_constructor_lid lid = is_dtuple_constructor_string (string_of_lid lid) + +let mk_dtuple_data_lid n r = + let t = U.format1 "Mkdtuple%s" (U.string_of_int n) in + set_lid_range ((mod_prefix_dtuple n) t) r + +let is_dtuple_datacon_string (s:string) :bool = + s = "Prims.Mkdtuple2" || U.starts_with s "FStar.Pervasives.Mkdtuple" + +let is_dtuple_data_lid f n = + lid_equals f (mk_dtuple_data_lid n dummyRange) + +let is_dtuple_data_lid' f = is_dtuple_datacon_string (string_of_lid f) + +let is_name (lid:lident) = + let c = U.char_at (string_of_id (ident_of_lid lid)) 0 in + U.is_upper c + +let term_view_lid = p2l ["FStar"; "Reflection"; "V1"; "Data"; "term_view"] + +(* tactic constants *) +let fstar_tactics_lid' s : lid = FStarC.Ident.lid_of_path (["FStar"; "Tactics"]@s) FStarC.Compiler.Range.dummyRange +let fstar_stubs_tactics_lid' s : lid = FStarC.Ident.lid_of_path (["FStar"; "Stubs"; "Tactics"]@s) FStarC.Compiler.Range.dummyRange +let fstar_tactics_lid s = fstar_tactics_lid' [s] +let tac_lid = fstar_tactics_lid' ["Effect"; "tac"] +let tactic_lid = fstar_tactics_lid' ["Effect"; "tactic"] + +let tac_opaque_attr = pconst "tac_opaque" + +let meta_projectors_attr = fstar_tactics_lid' ["MkProjectors"; "meta_projectors"] +let mk_projs_lid = fstar_tactics_lid' ["MkProjectors"; "mk_projs"] + +let mk_class_lid = fstar_tactics_lid' ["Typeclasses"; "mk_class"] +let tcresolve_lid = fstar_tactics_lid' ["Typeclasses"; "tcresolve"] +let tcclass_lid = fstar_tactics_lid' ["Typeclasses"; "tcclass"] +let tcinstance_lid = fstar_tactics_lid' ["Typeclasses"; "tcinstance"] +let no_method_lid = fstar_tactics_lid' ["Typeclasses"; "no_method"] + +let effect_TAC_lid = fstar_tactics_lid' ["Effect"; "TAC"] // actual effect +let effect_Tac_lid = fstar_tactics_lid' ["Effect"; "Tac"] // trivial variant + +let by_tactic_lid = fstar_tactics_lid' ["Effect"; "with_tactic"] +let rewrite_by_tactic_lid = fstar_tactics_lid' ["Effect"; "rewrite_with_tactic"] +let synth_lid = fstar_tactics_lid' ["Effect"; "synth_by_tactic"] +let assert_by_tactic_lid = fstar_tactics_lid' ["Effect"; "assert_by_tactic"] +let fstar_syntax_syntax_term = FStarC.Ident.lid_of_str "FStarC.Syntax.Syntax.term" +let binder_lid = lid_of_path (["FStar"; "Stubs"; "Reflection"; "Types"; "binder"]) FStarC.Compiler.Range.dummyRange +let binders_lid = lid_of_path (["FStar"; "Stubs"; "Reflection"; "Types"; "binders"]) FStarC.Compiler.Range.dummyRange +let bv_lid = lid_of_path (["FStar"; "Stubs"; "Reflection"; "Types"; "bv"]) FStarC.Compiler.Range.dummyRange +let fv_lid = lid_of_path (["FStar"; "Stubs"; "Reflection"; "Types"; "fv"]) FStarC.Compiler.Range.dummyRange +let norm_step_lid = psconst "norm_step" +let postprocess_with = p2l ["FStar"; "Tactics"; "Effect"; "postprocess_with"] +let preprocess_with = p2l ["FStar"; "Tactics"; "Effect"; "preprocess_with"] +let postprocess_extr_with = p2l ["FStar"; "Tactics"; "Effect"; "postprocess_for_extraction_with"] +let term_lid = p2l ["FStar"; "Stubs"; "Reflection"; "Types"; "term"] +let ctx_uvar_and_subst_lid = p2l ["FStar"; "Stubs"; "Reflection"; "Types"; "ctx_uvar_and_subst"] +let universe_uvar_lid = p2l ["FStar"; "Stubs"; "Reflection"; "Types"; "universe_uvar"] +let check_with_lid = lid_of_path (["FStar"; "Stubs"; "VConfig"; "check_with"]) FStarC.Compiler.Range.dummyRange + +let decls_lid = p2l ["FStar"; "Stubs"; "Reflection"; "Types"; "decls"] + +// meta dsl constants +let dsl_typing_builtin s = lid_of_path (["FStar"; "Reflection"; "Typing"; "Builtins"]@[s]) FStarC.Compiler.Range.dummyRange +let dsl_tac_typ_lid = lid_of_path ["FStar"; "Reflection"; "Typing"; "dsl_tac_t"] FStarC.Compiler.Range.dummyRange + + +(* Calculational proofs, from FStar.Calc *) +let calc_lid i : lid = lid_of_path ["FStar"; "Calc"; i] FStarC.Compiler.Range.dummyRange +let calc_init_lid = calc_lid "calc_init" +let calc_step_lid = calc_lid "calc_step" +let calc_finish_lid = calc_lid "calc_finish" +let calc_push_impl_lid = calc_lid "calc_push_impl" + +(* Classical proofs, from FStar.Classical *) +let classical_sugar_lid i : lid = lid_of_path ["FStar"; "Classical"; "Sugar"; i] FStarC.Compiler.Range.dummyRange + +let forall_intro_lid = classical_sugar_lid "forall_intro" +let exists_intro_lid = classical_sugar_lid "exists_intro" +let implies_intro_lid = classical_sugar_lid "implies_intro" +let or_intro_left_lid = classical_sugar_lid "or_intro_left" +let or_intro_right_lid = classical_sugar_lid "or_intro_right" +let and_intro_lid = classical_sugar_lid "and_intro" + +let forall_elim_lid = classical_sugar_lid "forall_elim" +let exists_elim_lid = classical_sugar_lid "exists_elim" +let implies_elim_lid = classical_sugar_lid "implies_elim" +let or_elim_lid = classical_sugar_lid "or_elim" +let and_elim_lid = classical_sugar_lid "and_elim" + + +let match_returns_def_name = reserved_prefix ^ "_ret_" + +let steel_memory_inv_lid = FStarC.Ident.lid_of_path ["Steel"; "Memory"; "inv"] FStarC.Compiler.Range.dummyRange + +let steel_new_invariant_lid = FStarC.Ident.lid_of_path ["Steel"; "Effect"; "Atomic"; "new_invariant"] FStarC.Compiler.Range.dummyRange +let steel_st_new_invariant_lid = FStarC.Ident.lid_of_path ["Steel"; "ST"; "Util"; "new_invariant"] FStarC.Compiler.Range.dummyRange + +let steel_with_invariant_g_lid = FStarC.Ident.lid_of_path ["Steel"; "Effect"; "Atomic"; "with_invariant_g"] FStarC.Compiler.Range.dummyRange +let steel_st_with_invariant_g_lid = FStarC.Ident.lid_of_path ["Steel"; "ST"; "Util"; "with_invariant_g"] FStarC.Compiler.Range.dummyRange + +let steel_with_invariant_lid = FStarC.Ident.lid_of_path ["Steel"; "Effect"; "Atomic"; "with_invariant"] FStarC.Compiler.Range.dummyRange +let steel_st_with_invariant_lid = FStarC.Ident.lid_of_path ["Steel"; "ST"; "Util"; "with_invariant"] FStarC.Compiler.Range.dummyRange + + +(* on_domain_lids are constant, so compute them once *) +let fext_lid s = Ident.lid_of_path ["FStar"; "FunctionalExtensionality"; s] FStarC.Compiler.Range.dummyRange +let fext_on_domain_lid = fext_lid "on_domain" +let fext_on_dom_lid = fext_lid "on_dom" +let fext_on_domain_g_lid = fext_lid "on_domain_g" +let fext_on_dom_g_lid = fext_lid "on_dom_g" + +let sealed_lid = p2l ["FStar"; "Sealed"; "sealed"] +let seal_lid = p2l ["FStar"; "Sealed"; "seal"] +let unseal_lid = p2l ["FStar"; "Tactics"; "Unseal"; "unseal"] (* In a separate module due to the mention of TAC *) +let map_seal_lid = p2l ["FStar"; "Sealed"; "map_seal"] +let bind_seal_lid = p2l ["FStar"; "Sealed"; "bind_seal"] +let tref_lid = p2l ["FStar"; "Stubs"; "Tactics"; "Types"; "tref"] + +let document_lid = p2l ["FStar"; "Stubs"; "Pprint"; "document"] +let issue_lid = p2l ["FStar"; "Issue"; "issue"] + +let extract_as_lid = p2l ["FStar"; "ExtractAs"; "extract_as"] +let extract_as_impure_effect_lid = p2l ["FStar"; "Pervasives"; "extract_as_impure_effect"] diff --git a/src/parser/FStarC.Parser.Dep.fst b/src/parser/FStarC.Parser.Dep.fst new file mode 100644 index 00000000000..c0e384fa57e --- /dev/null +++ b/src/parser/FStarC.Parser.Dep.fst @@ -0,0 +1,2079 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + + See the License for the specific language governing permissions and + limitations under the License. +*) + +(** This module provides an ocamldep-like tool for F*, invoked with [fstar --dep]. + Unlike ocamldep, it outputs the transitive closure of the dependency graph + of a given file. The dependencies that are output are *compilation units* + (not module names). +*) +module FStarC.Parser.Dep + +open FStar.Pervasives +open FStarC.Compiler.Effect //for ref, failwith etc +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.Parser +open FStarC.Parser.AST +open FStarC.Compiler.Util +open FStarC.Const +open FStar.String +open FStarC.Ident +open FStarC.Errors +open FStarC.Class.Show + +module Const = FStarC.Parser.Const +module BU = FStarC.Compiler.Util + +let dbg = Debug.get_toggle "Dep" +let dbg_CheckedFiles = Debug.get_toggle "CheckedFiles" + +let profile f c = Profiling.profile f None c + +(* Meant to write to a file as an out_channel. If an exception is raised, +the file is deleted. *) +let with_file_outchannel (fn : string) (k : out_channel -> 'a) : 'a = + let outc = BU.open_file_for_writing fn in + let r = + try k outc + with | e -> BU.close_out_channel outc; BU.delete_file fn; raise e + in + BU.close_out_channel outc; + r + +(* In case the user passed [--verify_all], we record every single module name we + * found in the list of modules to be verified. + * In the [VerifyUserList] case, for every [--verify_module X], we check we + * indeed find a module [X]. + * In the [VerifyFigureItOut] case, for every file that was on the command-line, + * we record its module name as one module to be verified. + *) +type verify_mode = + | VerifyAll + | VerifyUserList + | VerifyFigureItOut + +type intf_and_impl = option string & option string + +type files_for_module_name = smap intf_and_impl + +let intf_and_impl_to_string ii = + match ii with + | None, None -> ", " + | Some intf, None -> intf + | None, Some impl -> impl + | Some intf, Some impl -> intf ^ ", " ^ impl + + +let files_for_module_name_to_string (m:files_for_module_name) = + BU.print_string "Printing the file system map {\n"; + let str_opt_to_string sopt = + match sopt with + | None -> "" + | Some s -> s in + smap_iter m (fun k v -> BU.print2 "%s:%s\n" k (intf_and_impl_to_string v)); + BU.print_string "}\n" + +type color = | White | Gray | Black + +let check_and_strip_suffix (f: string): option string = + let suffixes = [ ".fsti"; ".fst"; ".fsi"; ".fs" ] in + let matches = List.map (fun ext -> + let lext = String.length ext in + let l = String.length f in + if l > lext && String.substring f (l - lext) lext = ext then + Some (String.substring f 0 (l - lext)) + else + None + ) suffixes in + match List.filter is_some matches with + | Some m :: _ -> + Some m + | _ -> + None + +(* In public interface *) +let is_interface (f: string): bool = + String.get f (String.length f - 1) = 'i' + +(* In public interface *) +let is_implementation f = + not (is_interface f) + + +let list_of_option = function Some x -> [x] | None -> [] + +let list_of_pair (intf, impl) = + list_of_option intf @ list_of_option impl + +(* In public interface *) +let maybe_module_name_of_file f = check_and_strip_suffix (basename f) +let module_name_of_file f = + match maybe_module_name_of_file f with + | Some longname -> + longname + | None -> + raise_error0 Errors.Fatal_NotValidFStarFile (Util.format1 "Not a valid FStar file: '%s'" f) + +(* In public interface *) +let lowercase_module_name f = String.lowercase (module_name_of_file f) + +let namespace_of_module f = + let lid = FStarC.Ident.lid_of_path (FStarC.Ident.path_of_text f) Range.dummyRange in + match ns_of_lid lid with + | [] -> None + | ns -> Some (FStarC.Ident.lid_of_ids ns) + +type file_name = string +type dependence = + | UseInterface of module_name + | PreferInterface of module_name + | UseImplementation of module_name + | FriendImplementation of module_name +let dep_to_string = function + | UseInterface f -> "UseInterface " ^ f + | PreferInterface f -> "PreferInterface " ^ f + | UseImplementation f -> "UseImplementation " ^ f + | FriendImplementation f -> "FriendImplementation " ^ f +instance showable_dependence : showable dependence = { + show = dep_to_string; +} + +type dependences = list dependence +let empty_dependences = [] +type dep_node = { + edges:dependences; + color:color +} +type dependence_graph = //maps file names to the modules it depends on + | Deps of smap dep_node //(dependences * color)> + +(* + * AR: Parsing data for a file (also cached in the checked files) + * It is a summary of opens, includes, A., etc. in a module + * Earlier we used to store the dependences in the checked file, + * however that is an image of the file system, and so, when the checked + * files were used in a slightly different file system, there were strange errors + * see e.g. #1657 for a couple of cases + * Now we store the following summary and construct the dependences from the current + * file system + *) +type parsing_data_elt = + | P_begin_module of lident //begin_module + | P_open of bool & lident //record_open + | P_implicit_open_module_or_namespace of (open_kind & lid) //record_open_module_or_namespace + | P_dep of bool & lident //add_dep_on_module, bool=true iff it's a friend dependency + | P_alias of ident & lident //record_module_alias + | P_lid of lident //record_lid + | P_inline_for_extraction + +type parsing_data = + | Mk_pd of list parsing_data_elt + +let str_of_parsing_data_elt elt = + let str_of_open_kind = function + | Open_module -> "P_open_module" + | Open_namespace -> "P_open_namespace" + in + match elt with + | P_begin_module lid -> "P_begin_module (" ^ (string_of_lid lid) ^ ")" + | P_open (b, lid) -> "P_open (" ^ (string_of_bool b) ^ ", " ^ (string_of_lid lid) ^ ")" + | P_implicit_open_module_or_namespace (k, lid) -> "P_implicit_open_module_or_namespace (" ^ (str_of_open_kind k) ^ ", " ^ (string_of_lid lid) ^ ")" + | P_dep (b, lid) -> "P_dep (" ^ (string_of_lid lid) ^ ", " ^ (string_of_bool b) ^ ")" + | P_alias (id, lid) -> "P_alias (" ^ (string_of_id id) ^ ", " ^ (string_of_lid lid) ^ ")" + | P_lid lid -> "P_lid (" ^ (string_of_lid lid) ^ ")" + | P_inline_for_extraction -> "P_inline_for_extraction" + +let str_of_parsing_data = function + | Mk_pd l -> + l |> List.fold_left (fun s elt -> s ^ "; " ^ (elt |> str_of_parsing_data_elt)) "" + +let friends (p:parsing_data) : list lident = + let Mk_pd p = p in + List.collect + (function + | P_dep (true, l) -> [l] + | _ -> []) + p + + +let parsing_data_elt_eq (e1:parsing_data_elt) (e2:parsing_data_elt) = + match e1, e2 with + | P_begin_module l1, P_begin_module l2 -> lid_equals l1 l2 + | P_open (b1, l1), P_open (b2, l2) -> b1 = b2 && lid_equals l1 l2 + | P_implicit_open_module_or_namespace (k1, l1), P_implicit_open_module_or_namespace (k2, l2) -> + k1 = k2 && lid_equals l1 l2 + | P_dep (b1, l1), P_dep (b2, l2) -> b1 = b2 && lid_equals l1 l2 + | P_alias (i1, l1), P_alias (i2, l2) -> string_of_id i1 = string_of_id i2 && lid_equals l1 l2 + | P_lid l1, P_lid l2 -> lid_equals l1 l2 + | P_inline_for_extraction, P_inline_for_extraction -> true + | _, _ -> false + +let empty_parsing_data = Mk_pd [] + +type deps = { + dep_graph:dependence_graph; //dependences of the entire project, not just those reachable from the command line + file_system_map:files_for_module_name; //an abstraction of the file system, keys are lowercase module names + cmd_line_files:list file_name; //all command-line files + all_files:list file_name; //all files + interfaces_with_inlining:list module_name; //interfaces that use `inline_for_extraction` require inlining + parse_results:smap parsing_data //map from filenames to parsing_data + //callers (Universal.fs) use this to get the parsing data for caching purposes +} +let deps_try_find (Deps m) k = BU.smap_try_find m k +let deps_add_dep (Deps m) k v = + BU.smap_add m k v +let deps_keys (Deps m) = BU.smap_keys m +let deps_empty () = Deps (BU.smap_create 41) +let mk_deps dg fs c a i pr = { + dep_graph=dg; + file_system_map=fs; + cmd_line_files=c; + all_files=a; + interfaces_with_inlining=i; + parse_results=pr; +} +(* In public interface *) +let empty_deps = mk_deps (deps_empty ()) (BU.smap_create 0) [] [] [] (BU.smap_create 0) +let module_name_of_dep = function + | UseInterface m + | PreferInterface m + | UseImplementation m + | FriendImplementation m -> m + +let resolve_module_name (file_system_map:files_for_module_name) (key:module_name) + : option module_name + = match BU.smap_try_find file_system_map key with + | Some (Some fn, _) + | Some (_, Some fn) -> Some (lowercase_module_name fn) + | _ -> None + +let interface_of_internal (file_system_map:files_for_module_name) (key:module_name) + : option file_name = + match BU.smap_try_find file_system_map key with + | Some (Some iface, _) -> Some iface + | _ -> None + +let implementation_of_internal (file_system_map:files_for_module_name) (key:module_name) + : option file_name = + match BU.smap_try_find file_system_map key with + | Some (_, Some impl) -> Some impl + | _ -> None + +let interface_of deps key = interface_of_internal deps.file_system_map key +let implementation_of deps key = implementation_of_internal deps.file_system_map key + +let has_interface (file_system_map:files_for_module_name) (key:module_name) + : bool = + Option.isSome (interface_of_internal file_system_map key) + +let has_implementation (file_system_map:files_for_module_name) (key:module_name) + : bool = + Option.isSome (implementation_of_internal file_system_map key) + + +(* + * Public interface + *) +let cache_file_name = + let checked_file_and_exists_flag fn = + let cache_fn = + let lax = Options.lax () in + if lax then fn ^".checked.lax" + else fn ^".checked" + in + let mname = fn |> module_name_of_file in + match Find.find_file (cache_fn |> Util.basename) with + | Some path -> + let expected_cache_file = Options.prepend_cache_dir cache_fn in + if Option.isSome (Options.dep()) //if we're in the dependence analysis + && not (Options.should_be_already_cached mname) //and checked file is in the + && (not (BU.file_exists expected_cache_file) //wrong spot ... complain + || not (BU.paths_to_same_file path expected_cache_file)) + then ( + let open FStarC.Pprint in + let open FStarC.Errors.Msg in + log_issue0 FStarC.Errors.Warning_UnexpectedCheckedFile [ + text "Did not expect module" ^/^ doc_of_string mname ^/^ text "to be already checked."; + prefix 2 1 (text "Found it in an unexpected location:") + (doc_of_string path) ^/^ + prefix 2 1 (text "instead of") + (doc_of_string expected_cache_file); + ] + ); + + (* This expression morally just returns [path], but prefers + * the path in [expected_cache_file] is possible to give + * preference to relative filenames. This is mostly since + * GNU make doesn't resolve paths in targets, so we try + * to keep target paths relative. See issue #1978. *) + if BU.file_exists expected_cache_file && BU.paths_to_same_file path expected_cache_file + then expected_cache_file + else path + | None -> + if !dbg_CheckedFiles then + BU.print1 "find_file(%s) returned None\n" (cache_fn |> Util.basename); + if mname |> Options.should_be_already_cached then + raise_error0 FStarC.Errors.Error_AlreadyCachedAssertionFailure [ + text (BU.format1 "Expected %s to be already checked but could not find it." mname) + ]; + FStarC.Options.prepend_cache_dir cache_fn + in + let memo = Util.smap_create 100 in + let memo f x = + match Util.smap_try_find memo x with + | Some res -> res + | None -> + let res = f x in + Util.smap_add memo x res; + res + in + memo checked_file_and_exists_flag + +let parsing_data_of deps fn = BU.smap_try_find deps.parse_results fn |> must + +let file_of_dep_aux + (use_checked_file:bool) + (file_system_map:files_for_module_name) + (all_cmd_line_files:list file_name) + (d:dependence) + : file_name = + let cmd_line_has_impl key = + all_cmd_line_files + |> BU.for_some (fun fn -> + is_implementation fn && + key = lowercase_module_name fn) + in + + let maybe_use_cache_of f = if use_checked_file then cache_file_name f else f in + + match d with + | UseInterface key -> + //This key always resolves to an interface source file + (match interface_of_internal file_system_map key with + | None -> + assert false; //should be unreachable; see the only use of UseInterface in discover_one + raise_error0 Errors.Fatal_MissingInterface (BU.format1 "Expected an interface for module %s, but couldn't find one" key) + | Some f -> + f) + + | PreferInterface key //key for module 'a' + when has_interface file_system_map key -> //so long as 'a.fsti' exists + if cmd_line_has_impl key //unless the cmd line contains 'a.fst' + && Option.isNone (Options.dep()) //and we're not just doing a dependency scan using `--dep _` + then if Options.expose_interfaces() + then maybe_use_cache_of (Option.get (implementation_of_internal file_system_map key)) + else raise_error0 Errors.Fatal_MissingExposeInterfacesOption [ + text <| BU.format3 "You may have a cyclic dependence on module %s: use --dep full to confirm. \ + Alternatively, invoking fstar with %s on the command line breaks \ + the abstraction imposed by its interface %s." + key + (Option.get (implementation_of_internal file_system_map key)) + (Option.get (interface_of_internal file_system_map key)); + text "If you really want this behavior add the option '--expose_interfaces'."; + ] + else maybe_use_cache_of (Option.get (interface_of_internal file_system_map key)) //we prefer to use 'a.fsti' + + | PreferInterface key + | UseImplementation key + | FriendImplementation key -> + match implementation_of_internal file_system_map key with + | None -> + //if d is actually an edge in the dep_graph computed by discover + //then d is only present if either an interface or an implementation exist + //the previous case already established that the interface doesn't exist + // since if the implementation was on the command line, it must exist because of option validation + raise_error0 Errors.Fatal_MissingImplementation + (BU.format1 "Expected an implementation of module %s, but couldn't find one" key) + | Some f -> maybe_use_cache_of f + +let file_of_dep = file_of_dep_aux false + +let dependences_of (file_system_map:files_for_module_name) + (deps:dependence_graph) + (all_cmd_line_files:list file_name) + (fn:file_name) + : list file_name = + match deps_try_find deps fn with + | None -> empty_dependences + | Some ({edges=deps}) -> + List.map (file_of_dep file_system_map all_cmd_line_files) deps + |> List.filter (fun k -> k <> fn) (* skip current module, cf #451 *) + +let print_graph (outc : out_channel) (fn : string) (graph:dependence_graph) = + if not (Options.silent ()) then begin + Util.print1 "A DOT-format graph has been dumped in the current directory as `%s`\n" fn; + Util.print1 "With GraphViz installed, try: fdp -Tpng -odep.png %s\n" fn; + Util.print1 "Hint: cat %s | grep -v _ | grep -v prims\n" fn + end; + let s = + "digraph {\n" ^ + String.concat "\n" (List.collect + (fun k -> + let deps = (must (deps_try_find graph k)).edges in + let r s = replace_char s '.' '_' in + let print dep = + Util.format2 " \"%s\" -> \"%s\"" + (r (lowercase_module_name k)) + (r (module_name_of_dep dep)) + in + List.map print deps) + (List.unique (deps_keys graph))) ^ + "\n}\n" + in + fprint outc "%s" [s] + +let safe_readdir_for_include (d:string) : list string = + try readdir d + with + | _ -> + let open FStarC.Pprint in + if false then + // fixme: only warn if given in --include, not for transitive fstar.include + // I'd say it's legit to fstar.include a .cache dir that may not exist yet. + log_issue0 Errors.Fatal_NotValidIncludeDirectory [ + prefix 2 1 (text "Not a valid include directory:") + (doc_of_string d); + ]; + [] + +(** Enumerate all F* files in include directories. + Return a list of pairs of long names and full paths. *) +(* In public interface *) +let build_inclusion_candidates_list (): list (string & string) = + let include_directories = Options.include_path () in + let include_directories = List.map normalize_file_path include_directories in + (* Note that [BatList.unique] keeps the last occurrence, that way one can + * always override the precedence order. *) + let include_directories = List.unique include_directories in + let cwd = normalize_file_path (getcwd ()) in + include_directories |> List.concatMap (fun d -> + let files = safe_readdir_for_include d in + files |> List.filter_map (fun f -> + let f = basename f in + check_and_strip_suffix f + |> Util.map_option (fun longname -> + let full_path = if d = cwd then f else join_paths d f in + (longname, full_path)) + ) + ) + +(** List the contents of all include directories, then build a map from long + names (e.g. a.b) to pairs of filenames (/path/to/A.B.fst). Long names are + all normalized to lowercase. The first component of the pair is the + interface (if any). The second component of the pair is the implementation + (if any). *) +let build_map (filenames: list string): files_for_module_name = + let map = smap_create 41 in + let add_entry key full_path = + match smap_try_find map key with + | Some (intf, impl) -> + if is_interface full_path then + smap_add map key (Some full_path, impl) + else + smap_add map key (intf, Some full_path) + | None -> + if is_interface full_path then + smap_add map key (Some full_path, None) + else + smap_add map key (None, Some full_path) + in + + (* Add files from all include directories *) + List.iter (fun (longname, full_path) -> + add_entry (String.lowercase longname) full_path + ) (build_inclusion_candidates_list ()); + (* All the files we've been given on the command-line must be valid FStar files. *) + List.iter (fun f -> + add_entry (lowercase_module_name f) f + ) filenames; + map + +let string_of_lid (l: lident) (last: bool) = + let suffix = if last then [ (string_of_id (ident_of_lid l)) ] else [ ] in + let names = List.map (fun x -> (string_of_id x)) (ns_of_lid l) @ suffix in + String.concat "." names + +(** All the components of a [lident] joined by "." (the last component of the + * lident is included iff [last = true]). *) +let lowercase_join_longident (l: lident) (last: bool) = + String.lowercase (string_of_lid l last) + +let namespace_of_lid l = + String.concat "_" (List.map string_of_id (ns_of_lid l)) + +let check_module_declaration_against_filename (lid: lident) (filename: string): unit = + let k' = string_of_lid lid true in + if must (check_and_strip_suffix (basename filename)) <> k' then + log_issue lid Errors.Error_ModuleFileNameMismatch [ + Errors.Msg.text (Util.format2 "The module declaration \"module %s\" \ + found in file %s does not match its filename." (string_of_lid lid true) filename); + Errors.Msg.text "Dependencies will be incorrect and the module will not be verified."; + ] + +exception Exit + +(* In public interface *) + +let core_modules () = + [Basefiles.prims_basename () ; + Basefiles.pervasives_basename () ; + Basefiles.pervasives_native_basename ()] + |> List.map module_name_of_file + +let implicit_ns_deps = + [ Const.fstar_ns_lid ] + +let implicit_module_deps = + [ Const.prims_lid; Const.pervasives_lid ] + +let hard_coded_dependencies full_filename = + let filename : string = basename full_filename in + + let implicit_module_deps = List.map (fun l -> l, Open_module) implicit_module_deps in + let implicit_ns_deps = List.map (fun l -> l, Open_namespace) implicit_ns_deps in + + (* The core libraries do not have any implicit dependencies *) + if List.mem (module_name_of_file filename) (core_modules ()) then [] + else match namespace_of_module (module_name_of_file full_filename) with + | None -> implicit_ns_deps @ implicit_module_deps + (* + * AR: we open FStar, and then ns + * which means that enter_namespace will be called first for F*, and then for ns + * giving precedence to My.M over FStar.M + *) + | Some ns -> implicit_ns_deps @ implicit_module_deps @ [(ns, Open_namespace)] + +let dep_subsumed_by d d' = + match d, d' with + | PreferInterface l', FriendImplementation l -> l=l' + | _ -> d = d' + +(** For all items [i] in the map that start with [prefix], add an additional + entry where [i] stripped from [prefix] points to the same value. Returns a + boolean telling whether the map was modified. + + If the open is an implicit open (as indicated by the flag), + and doing so shadows an existing entry, warn! *) +let enter_namespace + (original_map: files_for_module_name) + (working_map: files_for_module_name) + (sprefix: string) + (implicit_open:bool) : bool = + let found = BU.mk_ref false in + let sprefix = sprefix ^ "." in + let suffix_exists mopt = + match mopt with + | None -> false + | Some (intf, impl) -> is_some intf || is_some impl in + smap_iter original_map (fun k _ -> + if Util.starts_with k sprefix then + let suffix = + String.substring k (String.length sprefix) (String.length k - String.length sprefix) + in + + begin + let suffix_filename = smap_try_find original_map suffix in + if implicit_open && + suffix_exists suffix_filename + then let str = suffix_filename |> must |> intf_and_impl_to_string in + let open FStarC.Pprint in + log_issue0 Errors.Warning_UnexpectedFile [ + flow (break_ 1) [ + text "Implicitly opening namespace"; + squotes (doc_of_string sprefix); + text "shadows module"; + squotes (doc_of_string suffix); + text "in file"; + dquotes (doc_of_string str) ^^ dot; + ]; + text "Rename" ^/^ dquotes (doc_of_string str) ^/^ text "to avoid conflicts."; + ] + end; + + let filename = must (smap_try_find original_map k) in + smap_add working_map suffix filename; + found := true + ); + !found + +(* + * Get parsing data for a file + * First see if the data in the checked file is good (using the provided callback) + * If it is, return that + * + * Else parse the file, walk its AST, return a list of FStar lowercased module names + it depends on + *) + +let collect_one + (original_map: files_for_module_name) + (filename: string) + (get_parsing_data_from_cache:string -> option parsing_data) + : parsing_data & + list dependence & //direct dependence + bool & //has_inline_for_extraction + list dependence //additional roots + //that used to be part of parsing_data earlier + //removing it from the cache (#1657) + //this always returns a single element, remove the list? += + (* + * Construct dependences from the parsing data + * This is common function for when the parsing data is read from the checked files + * or constructed after AST traversal of the module + *) + let from_parsing_data (pd:parsing_data) (original_map:files_for_module_name) (filename:string) + : list dependence & + bool & + list dependence + = let deps : ref (list dependence) = BU.mk_ref [] in + let has_inline_for_extraction = BU.mk_ref false in + + + let mo_roots = + let mname = lowercase_module_name filename in + if is_interface filename + && has_implementation original_map mname + then [ UseImplementation mname ] + else [] + in + + let auto_open = hard_coded_dependencies filename |> List.map (fun (lid, k) -> + P_implicit_open_module_or_namespace (k, lid)) + in + + let working_map = smap_copy original_map in + + let set_interface_inlining () = + if is_interface filename + then has_inline_for_extraction := true + in + + let add_dep deps d = + if not (List.existsML (dep_subsumed_by d) !deps) then + deps := d :: !deps + in + + let dep_edge module_name is_friend = + if is_friend then FriendImplementation module_name + else PreferInterface module_name + in + + let add_dependence_edge original_or_working_map lid is_friend = + let key = lowercase_join_longident lid true in + match resolve_module_name original_or_working_map key with + | Some module_name -> + add_dep deps (dep_edge module_name is_friend); + true + | _ -> + false + in + + let record_open_module let_open lid = + //use the original_map here + //since the working_map will resolve lid while accounting + //for already opened namespaces + //if let_open, then this is the form `UInt64.( ... )` + // where UInt64 can resolve to FStar.UInt64 + // So, use the working map, accounting for opened namespaces + //Otherwise, this is the form `open UInt64`, + // where UInt64 must resolve to either + // a module or a namespace for F# compatibility + // So, use the original map, disregarding opened namespaces + if (let_open && add_dependence_edge working_map lid false) + || (not let_open && add_dependence_edge original_map lid false) + then true + else begin + if let_open then + log_issue lid Errors.Warning_ModuleOrFileNotFoundWarning + (Util.format1 "Module not found: %s" (string_of_lid lid true)); + false + end + in + + let record_open_namespace lid (implicit_open:bool) = + let key = lowercase_join_longident lid true in + let r = enter_namespace original_map working_map key implicit_open in + if not r && not implicit_open then //suppress the warning for implicit opens + log_issue lid Errors.Warning_ModuleOrFileNotFoundWarning + (Util.format1 "No modules in namespace %s and no file with that name either" (string_of_lid lid true)) + in + + let record_open let_open lid = + if record_open_module let_open lid + then () + else if not let_open //syntactically, this cannot be a namespace if let_open is true; so don't retry + then record_open_namespace lid false + in + + let record_implicit_open_module_or_namespace (lid, kind) = + match kind with + | Open_namespace -> record_open_namespace lid true + | Open_module -> let _ = record_open_module false lid in () + in + + let record_module_alias ident lid = + let key = String.lowercase (string_of_id ident) in + let alias = lowercase_join_longident lid true in + // Only fully qualified module aliases are allowed. + match smap_try_find original_map alias with + | Some deps_of_aliased_module -> + smap_add working_map key deps_of_aliased_module; + add_dep deps (dep_edge (lowercase_join_longident lid true) false); + true + | None -> + log_issue lid Errors.Warning_ModuleOrFileNotFoundWarning + (Util.format1 "module not found in search path: %s" alias); + false + in + + let add_dep_on_module (module_name : lid) (is_friend : bool) = + if add_dependence_edge working_map module_name is_friend + then () + else if !dbg then + log_issue module_name Errors.Warning_UnboundModuleReference + (BU.format1 "Unbound module reference %s" (show module_name)) + in + + let record_lid lid = + (* Thanks to the new `?.` and `.(` syntaxes, `lid` is no longer a + module name itself, so only its namespace part is to be + recorded as a module dependency. *) + match ns_of_lid lid with + | [] -> () + | ns -> + let module_name = Ident.lid_of_ids ns in + add_dep_on_module module_name false + in + + let begin_module lid = + if List.length (ns_of_lid lid) > 0 then + ignore (enter_namespace original_map working_map (namespace_of_lid lid)) + in + + (* + * Iterate over the parsing data elements + *) + begin + match pd with + | Mk_pd l -> + (auto_open @ l) |> List.iter (fun elt -> + match elt with + | P_begin_module lid -> begin_module lid + | P_open (b, lid) -> record_open b lid + | P_implicit_open_module_or_namespace (k, lid) -> record_implicit_open_module_or_namespace (lid, k) + | P_dep (b, lid) -> add_dep_on_module lid b + | P_alias (id, lid) -> ignore (record_module_alias id lid) + | P_lid lid -> record_lid lid + | P_inline_for_extraction -> set_interface_inlining ()) + end; + (* + * And then return the dependences + *) + !deps, + !has_inline_for_extraction, + mo_roots + in + + let data_from_cache = filename |> get_parsing_data_from_cache in + + if data_from_cache |> is_some then begin //we found the parsing data in the checked file + let deps, has_inline_for_extraction, mo_roots = from_parsing_data (data_from_cache |> must) original_map filename in + if !dbg then + BU.print2 "Reading the parsing data for %s from its checked file .. found [%s]\n" filename (show deps); + data_from_cache |> must, + deps, has_inline_for_extraction, mo_roots + end + else + //parse the file and traverse the AST to collect parsing data + let num_of_toplevelmods = BU.mk_ref 0 in + let pd : ref (list parsing_data_elt) = BU.mk_ref [] in + + let add_to_parsing_data elt = + if not (List.existsML (fun e -> parsing_data_elt_eq e elt) !pd) + then pd := elt::!pd + in + + let rec collect_module = function + | Module (lid, decls) + | Interface (lid, decls, _) -> + check_module_declaration_against_filename lid filename; + add_to_parsing_data (P_begin_module lid); + collect_decls decls + + and collect_decls decls = + List.iter (fun x -> collect_decl x.d; + List.iter collect_term x.attrs; + match x.d with + | _ when List.contains Inline_for_extraction x.quals -> + add_to_parsing_data P_inline_for_extraction + | _ -> () + ) decls + + and collect_decl d = + match d with + | Include (lid, _) + | Open (lid, _) -> + add_to_parsing_data (P_open (false, lid)) + | Friend lid -> + add_to_parsing_data (P_dep (true, (lowercase_join_longident lid true |> Ident.lid_of_str))) + | ModuleAbbrev (ident, lid) -> + add_to_parsing_data (P_alias (ident, lid)) + | TopLevelLet (_, patterms) -> + List.iter (fun (pat, t) -> collect_pattern pat; collect_term t) patterms + | Splice (_, _, t) + | Assume (_, t) + | SubEffect { lift_op = NonReifiableLift t } + | SubEffect { lift_op = LiftForFree t } + | Val (_, t) -> + collect_term t + | SubEffect { lift_op = ReifiableLift (t0, t1) } -> + collect_term t0; + collect_term t1 + | Tycon (_, tc, ts) -> + begin + if tc then + add_to_parsing_data (P_lid Const.tcclass_lid); + List.iter collect_tycon ts + end + | Exception (_, t) -> + iter_opt t collect_term + | NewEffect ed + | LayeredEffect ed -> + collect_effect_decl ed + + | Polymonadic_bind (_, _, _, t) + | Polymonadic_subcomp (_, _, t) -> collect_term t //collect deps from the effect lids? + + | DeclToBeDesugared tbs -> + tbs.dep_scan + { scan_term = collect_term; + scan_binder = collect_binder; + scan_pattern = collect_pattern; + add_lident = (fun lid -> add_to_parsing_data (P_lid lid)); + add_open = (fun lid -> add_to_parsing_data (P_open (true, lid))) + } + tbs.blob + + | UseLangDecls _ + | Pragma _ + | DeclSyntaxExtension _ + | Unparseable -> + () + | TopLevelModule lid -> + incr num_of_toplevelmods; + if (!num_of_toplevelmods > 1) then + raise_error lid Errors.Fatal_OneModulePerFile + (Util.format1 "Automatic dependency analysis demands one module per file (module %s not supported)" (string_of_lid lid true)) + and collect_tycon = function + | TyconAbstract (_, binders, k) -> + collect_binders binders; + iter_opt k collect_term + | TyconAbbrev (_, binders, k, t) -> + collect_binders binders; + iter_opt k collect_term; + collect_term t + | TyconRecord (_, binders, k, _, identterms) -> + collect_binders binders; + iter_opt k collect_term; + collect_tycon_record identterms + | TyconVariant (_, binders, k, identterms) -> + collect_binders binders; + iter_opt k collect_term; + List.iter ( function + | VpOfNotation t | VpArbitrary t -> collect_term t + | VpRecord (record, t) -> collect_tycon_record record; + iter_opt t collect_term + ) (List.filter_map Mktuple3?._2 identterms) + + and collect_tycon_record r = + List.iter (fun (_, aq, attrs, t) -> + collect_aqual aq; + attrs |> List.iter collect_term; + collect_term t) r + + and collect_effect_decl = function + | DefineEffect (_, binders, t, decls) -> + collect_binders binders; + collect_term t; + collect_decls decls + | RedefineEffect (_, binders, t) -> + collect_binders binders; + collect_term t + + and collect_binders binders = + List.iter collect_binder binders + + and collect_binder b = + collect_aqual b.aqual; + b.battributes |> List.iter collect_term; + match b with + | { b = Annotated (_, t) } + | { b = TAnnotated (_, t) } + | { b = NoName t } -> collect_term t + | _ -> () + + and collect_aqual = function + | Some (Meta t) -> collect_term t + | Some TypeClassArg -> add_to_parsing_data (P_lid Const.tcresolve_lid) + | _ -> () + + and collect_term t = + collect_term' t.tm + + and collect_constant = function + | Const_int (_, Some (Unsigned, Sizet)) -> + add_to_parsing_data (P_dep (false, ("fstar.sizeT" |> Ident.lid_of_str))) + | Const_int (_, Some (signedness, width)) -> + let u = match signedness with | Unsigned -> "u" | Signed -> "" in + let w = match width with | Int8 -> "8" | Int16 -> "16" | Int32 -> "32" | Int64 -> "64" in + add_to_parsing_data (P_dep (false, (Util.format2 "fstar.%sint%s" u w |> Ident.lid_of_str))) + | Const_char _ -> + add_to_parsing_data (P_dep (false, ("fstar.char" |> Ident.lid_of_str))) + | Const_range_of + | Const_set_range_of -> + add_to_parsing_data (P_dep (false, ("fstar.range" |> Ident.lid_of_str))) + | Const_real _ -> + add_to_parsing_data (P_dep (false, ("fstar.real" |> Ident.lid_of_str))) + | _ -> + () + + and collect_term' = function + | Wild -> + () + | Const c -> + collect_constant c + | Op (_, ts) -> + List.iter collect_term ts + | Tvar _ + | AST.Uvar _ -> + () + | Var lid + | AST.Projector (lid, _) + | AST.Discrim lid + | Name lid -> + add_to_parsing_data (P_lid lid) + | Construct (lid, termimps) -> + add_to_parsing_data (P_lid lid); + List.iter (fun (t, _) -> collect_term t) termimps + | Function (branches, _) -> + collect_branches branches + | Abs (pats, t) -> + collect_patterns pats; + collect_term t + | App (t1, t2, _) -> + collect_term t1; + collect_term t2 + | Let (_, patterms, t) -> + List.iter (fun (attrs_opt, (pat, t)) -> + ignore (BU.map_opt attrs_opt (List.iter collect_term)); + collect_pattern pat; + collect_term t) + patterms; + collect_term t + | LetOperator (lets, body) -> + List.iter (fun (ident, pat, def) -> + collect_pattern pat; + collect_term def + ) lets; + collect_term body + | LetOpen (lid, t) -> + add_to_parsing_data (P_open (true, lid)); + collect_term t + | LetOpenRecord (r, rty, e) -> + collect_term r; + collect_term rty; + collect_term e + | Bind(_, t1, t2) + | Seq (t1, t2) -> + collect_term t1; + collect_term t2 + | If (t1, _, ret_opt, t2, t3) -> + collect_term t1; + (match ret_opt with + | None -> () + | Some (_, ret, _) -> + collect_term ret); + collect_term t2; + collect_term t3 + | Match (t, _, ret_opt, bs) -> + collect_term t; + (match ret_opt with + | None -> () + | Some (_, ret, _) -> + collect_term ret); + collect_branches bs + | TryWith (t, bs) -> + collect_term t; + collect_branches bs + | Ascribed (t1, t2, None, _) -> + collect_term t1; + collect_term t2 + | Ascribed (t1, t2, Some tac, _) -> + collect_term t1; + collect_term t2; + collect_term tac + | Record (t, idterms) -> + iter_opt t collect_term; + List.iter + (fun (fn, t) -> + collect_fieldname fn; + collect_term t) + idterms + | Project (t, f) -> + collect_term t; + collect_fieldname f + | Product (binders, t) -> + collect_binders binders; + collect_term t + | Sum (binders, t) -> + List.iter (function + | Inl b -> collect_binder b + | Inr t -> collect_term t) + binders; + collect_term t + | QForall (binders, (_, ts), t) + | QExists (binders, (_, ts), t) + | QuantOp (_, binders, (_, ts), t) -> + collect_binders binders; + List.iter (List.iter collect_term) ts; + collect_term t + | Refine (binder, t) -> + collect_binder binder; + collect_term t + | NamedTyp (_, t) -> + collect_term t + | Paren t -> + collect_term t + | Requires (t, _) + | Ensures (t, _) + | Labeled (t, _, _) -> + collect_term t + | LexList l -> List.iter collect_term l + | WFOrder (t1, t2) -> + add_to_parsing_data (P_dep (false, (Ident.lid_of_str "FStar.WellFounded"))); + begin + collect_term t1; collect_term t2 + end + | Decreases (t, _) -> collect_term t + | Quote (t, _) + | Antiquote t + | VQuote t -> + collect_term t + | Attributes cattributes -> + List.iter collect_term cattributes + | CalcProof (rel, init, steps) -> + add_to_parsing_data (P_dep (false, (Ident.lid_of_str "FStar.Calc"))); + begin + collect_term rel; + collect_term init; + List.iter (function CalcStep (rel, just, next) -> + collect_term rel; + collect_term just; + collect_term next) steps + end + + | IntroForall (bs, p, e) -> + add_to_parsing_data (P_dep (false, (Ident.lid_of_str "FStar.Classical.Sugar"))); + collect_binders bs; + collect_term p; + collect_term e + + | IntroExists(bs, t, vs, e) -> + add_to_parsing_data (P_dep (false, (Ident.lid_of_str "FStar.Classical.Sugar"))); + collect_binders bs; + collect_term t; + List.iter collect_term vs; + collect_term e + + | IntroImplies(p, q, x, e) -> + add_to_parsing_data (P_dep (false, (Ident.lid_of_str "FStar.Classical.Sugar"))); + collect_term p; + collect_term q; + collect_binder x; + collect_term e + + | IntroOr(b, p, q, r) -> + add_to_parsing_data (P_dep (false, (Ident.lid_of_str "FStar.Classical.Sugar"))); + collect_term p; + collect_term q; + collect_term r + + | IntroAnd(p, q, r, e) -> + add_to_parsing_data (P_dep (false, (Ident.lid_of_str "FStar.Classical.Sugar"))); + collect_term p; + collect_term q; + collect_term r; + collect_term e + + | ElimForall(bs, p, vs) -> + add_to_parsing_data (P_dep (false, (Ident.lid_of_str "FStar.Classical.Sugar"))); + collect_binders bs; + collect_term p; + List.iter collect_term vs + + | ElimExists(bs, p, q, b, e) -> + add_to_parsing_data (P_dep (false, (Ident.lid_of_str "FStar.Classical.Sugar"))); + collect_binders bs; + collect_term p; + collect_term q; + collect_binder b; + collect_term e + + | ElimImplies(p, q, e) -> + add_to_parsing_data (P_dep (false, (Ident.lid_of_str "FStar.Classical.Sugar"))); + collect_term p; + collect_term q; + collect_term e + + | ElimAnd(p, q, r, x, y, e) -> + add_to_parsing_data (P_dep (false, (Ident.lid_of_str "FStar.Classical.Sugar"))); + collect_term p; + collect_term q; + collect_term r; + collect_binder x; + collect_binder y; + collect_term e + + | ElimOr(p, q, r, x, e, y, e') -> + add_to_parsing_data (P_dep (false, (Ident.lid_of_str "FStar.Classical.Sugar"))); + collect_term p; + collect_term q; + collect_term r; + collect_binder x; + collect_binder y; + collect_term e; + collect_term e' + + | ListLiteral ts -> + List.iter collect_term ts + + | SeqLiteral ts -> + add_to_parsing_data (P_dep (false, (Ident.lid_of_str "FStar.Seq.Base"))); + List.iter collect_term ts + + and collect_patterns ps = + List.iter collect_pattern ps + + and collect_pattern p = + collect_pattern' p.pat + + and collect_pattern' = function + | PatVar (_, aqual, attrs) + | PatTvar (_, aqual, attrs) + | PatWild (aqual, attrs) -> + collect_aqual aqual; + attrs |> List.iter collect_term + + | PatOp _ + | PatConst _ -> + () + | PatVQuote t -> + collect_term t + | PatApp (p, ps) -> + collect_pattern p; + collect_patterns ps + | PatName _ -> + () + | PatList ps + | PatOr ps + | PatTuple (ps, _) -> + collect_patterns ps + | PatRecord lidpats -> + List.iter (fun (_, p) -> collect_pattern p) lidpats + | PatAscribed (p, (t, None)) -> + collect_pattern p; + collect_term t + | PatAscribed (p, (t, Some tac)) -> + collect_pattern p; + collect_term t; + collect_term tac + + + and collect_branches bs = + List.iter collect_branch bs + + and collect_branch (pat, t1, t2) = + collect_pattern pat; + iter_opt t1 collect_term; + collect_term t2 + + and collect_fieldname fn = + if nsstr fn <> "" + then add_to_parsing_data (P_dep (false, lid_of_ids (ns_of_lid fn))) + + in + let ast, _ = Driver.parse_file filename in + collect_module ast; + let pd = Mk_pd (List.rev !pd) in + let deps, has_inline_for_extraction, mo_roots = from_parsing_data pd original_map filename in + (* Util.print2 "Deps for %s: %s\n" filename (String.concat " " (!deps)); *) + pd, deps, has_inline_for_extraction, mo_roots + + +(* JP: it looks like the code was changed but the comments were never updated. + * In particular, we no longer compute transitive dependencies, and we no longer + * map lowercase module names to filenames. *) + +// Used by F*.js +let collect_one_cache : ref (smap (list dependence & list dependence & bool)) = + BU.mk_ref (BU.smap_create 0) + +let set_collect_one_cache (cache: smap (list dependence & list dependence & bool)) : unit = + collect_one_cache := cache + +let dep_graph_copy dep_graph = + let (Deps g) = dep_graph in + Deps (BU.smap_copy g) + +let widen_deps friends dep_graph file_system_map widened = + let widened = BU.mk_ref widened in + let (Deps dg) = dep_graph in + let (Deps dg') = deps_empty() in + let widen_one deps = + deps |> List.map (fun d -> + match d with + | PreferInterface m + when (List.contains m friends && + has_implementation file_system_map m) -> + widened := true; + FriendImplementation m + | _ -> d) + in + BU.smap_fold + dg + (fun filename dep_node () -> + BU.smap_add + dg' + filename + ({dep_node with edges=widen_one dep_node.edges; color=White})) + (); + !widened, Deps dg' + +let topological_dependences_of' + file_system_map + dep_graph + interfaces_needing_inlining + root_files + widened + : list file_name + & bool = + let rec all_friend_deps_1 + dep_graph + (cycle:list file_name) + (all_friends, all_files) + filename = + let dep_node = must (deps_try_find dep_graph filename) in + match dep_node.color with + | Gray -> + failwith "Impossible: cycle detected after cycle detection has passed" + | Black -> + (* If the element has been visited already, then the map contains all its + * dependencies. Otherwise, the map only contains its direct dependencies. *) + all_friends, all_files + | White -> + if !dbg + then BU.print2 "Visiting %s: direct deps are %s\n" + filename (show dep_node.edges); + (* Unvisited. Compute. *) + deps_add_dep dep_graph filename ({dep_node with color=Gray}); + let all_friends, all_files = + all_friend_deps + dep_graph cycle (all_friends, all_files) + (dependences_of file_system_map + dep_graph + root_files + filename) + in + (* Mutate the graph to mark the node as visited *) + deps_add_dep dep_graph filename ({dep_node with color=Black}); + if !dbg + then BU.print1 "Adding %s\n" filename; + (* Also build the topological sort (Tarjan's algorithm). *) + List.collect + (function | FriendImplementation m -> [m] + | d -> []) + dep_node.edges + @all_friends, + filename :: all_files + and all_friend_deps dep_graph cycle all_friends filenames = + List.fold_left + (fun all_friends k -> + all_friend_deps_1 dep_graph (k :: cycle) all_friends k) + all_friends + filenames + in + + (* An important requirement is that in addition to files being + emitted in topological order, we require implementation files + to immmediately follow their interface files (if any) in the + final order. + + This is because the interleaving semantics of + interfaces+implementation relies on these files being adjacent + in the dependence order. + + This is enforced in several steps. + + First, every implementation file contains its interface file as + its *LAST* dependence. In a simple scenario, when scanning an + the dependences of an implementation file, we will encounter + its interface last, and so we would complete the dependence + scan of all the dependences of the implementation;then the + dependences of the interface file; then emit the interface file + in the topological sort (above); followed immediately by the + implementation. + + More complex situations arise due to friend modules where some + modules in the dependence graph may rely only on the module's + interface, whereas others may rely on its implementation. + + Further complications arise from cross-module inlining, where, + the extraction of one module may depend on the implementation + details of another module. + + To handle this, we compute the file list in several phases: + + 1. If --cmi and codegen is true, then we need to inline across + interface boundaries for modules M that are in the + interfaces_needing_inlining list. So, we transform the + dependence graph updating every interface dependence on + such a module M into a friend dependence on that module's + implementation. + + 2. Then, we traverse the graph in topological order + encountering all friend modules reachable from the + specified roots. + + 3. Then, we alter the dependences to turn every occurrence of + a interface dependence of a friend module into an + implementation dependence. Note, this does not change the + set of files reachable from the given roots. + + 4. A second traversal now collects all the files in dependence + order, ensuring that implementation and interface files are + adjacent in the dependence order, since the interface is + always the last dependence of an implementation. + + This ensures that for a given set of roots, every module that + needs to be friended or inlined is marked as a friend for + *every* module in the dependence graph, avoiding "double + vision" problems of some modules seeing the interface only + whereas others requiring both interface+implementation. + + So, when traversing the graph, we always encounter friend + module implementaions first, then their interfaces, emitting + them adjacent to the each other in the final order. + *) + + let friends, all_files_0 = + all_friend_deps dep_graph [] ([], []) root_files + in + if !dbg + then BU.print3 "Phase1 complete:\n\t\ + all_files = %s\n\t\ + all_friends=%s\n\t\ + interfaces_with_inlining=%s\n" + (String.concat ", " all_files_0) + (String.concat ", " (remove_dups (fun x y -> x=y) friends)) + (String.concat ", " (interfaces_needing_inlining)); + let widened, dep_graph = + widen_deps friends dep_graph file_system_map widened + in + let _, all_files = + if !dbg + then BU.print_string "==============Phase2==================\n"; + all_friend_deps dep_graph [] ([], []) root_files + in + if !dbg + then BU.print1 "Phase2 complete: all_files = %s\n" (String.concat ", " all_files); + all_files, + widened + +let phase1 + file_system_map + dep_graph + interfaces_needing_inlining + for_extraction += + if !dbg + then BU.print_string "==============Phase1==================\n"; + let widened = false in + if Options.cmi() + && for_extraction + then widen_deps interfaces_needing_inlining dep_graph file_system_map widened + else widened, dep_graph + +let topological_dependences_of + file_system_map + dep_graph + interfaces_needing_inlining + root_files + for_extraction + : list file_name + & bool = + + let widened, dep_graph = phase1 file_system_map dep_graph interfaces_needing_inlining for_extraction in + topological_dependences_of' file_system_map dep_graph interfaces_needing_inlining root_files widened + +let all_files_in_include_paths () = + let paths = Options.include_path () in + 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 + List.map (fun file -> Util.join_paths path file) files) + paths + +(** Collect the dependencies for a list of given files. + And record the entire dependence graph in the memoized state above **) +(* + * get_parsing_data_from_cache is a callback passed by caller + * to read the parsing data from checked files + *) +(* In public interface *) +let collect (all_cmd_line_files: list file_name) + (get_parsing_data_from_cache:string -> option parsing_data) + : list file_name + & deps //topologically sorted transitive dependences of all_cmd_line_files + = + let all_cmd_line_files = + match all_cmd_line_files with + | [] -> all_files_in_include_paths () + | _ -> all_cmd_line_files + in + let all_cmd_line_files = + all_cmd_line_files |> List.map (fun fn -> + match Find.find_file fn with + | None -> + raise_error0 Errors.Fatal_ModuleOrFileNotFound + (Util.format1 "File %s could not be found" fn) + | Some fn -> fn) in + (* The dependency graph; keys are lowercased module names, values = list of + * lowercased module names this file depends on. *) + let dep_graph : dependence_graph = deps_empty () in + + (* A map from lowercase module names (e.g. [a.b.c]) to the corresponding + * filenames (e.g. [/where/to/find/A.B.C.fst]). Consider this map + * immutable from there on. *) + let file_system_map = build_map all_cmd_line_files in + + let interfaces_needing_inlining = BU.mk_ref [] in + let add_interface_for_inlining l = + let l = lowercase_module_name l in + interfaces_needing_inlining := l :: !interfaces_needing_inlining + in + + let parse_results = BU.smap_create 40 in + + (* discover: Do a graph traversal starting from file_name + * filling in dep_graph with the dependences *) + let rec discover_one (file_name:file_name) = + if deps_try_find dep_graph file_name = None then + begin + let parsing_data, (deps, mo_roots, needs_interface_inlining) = + match BU.smap_try_find !collect_one_cache file_name with + | Some cached -> Mk_pd [], cached + | None -> + let parsing_data, deps, needs_interface_inlining, additional_roots = collect_one file_system_map file_name get_parsing_data_from_cache in + parsing_data, (deps, additional_roots, needs_interface_inlining) in + if needs_interface_inlining + then add_interface_for_inlining file_name; + BU.smap_add parse_results file_name parsing_data; + let deps = + let module_name = lowercase_module_name file_name in + if is_implementation file_name + && has_interface file_system_map module_name + then deps @ [UseInterface module_name] + else deps + in + let dep_node : dep_node = { + edges = List.unique deps; + color = White; + } in + deps_add_dep dep_graph file_name dep_node; + List.iter + discover_one + (List.map (file_of_dep file_system_map all_cmd_line_files) + (deps @ mo_roots)) + end + in + profile (fun () -> List.iter discover_one all_cmd_line_files) "FStarC.Parser.Dep.discover"; + + (* At this point, dep_graph has all the (immediate) dependency graph of all the files. *) + let cycle_detected dep_graph cycle filename = + Util.print1 "The cycle contains a subset of the modules in:\n%s \n" (String.concat "\n`used by` " cycle); + + (* Write the graph to a file for the user to see. *) + let fn = "dep.graph" in + with_file_outchannel fn (fun outc -> print_graph outc fn dep_graph); + + print_string "\n"; + raise_error0 Errors.Fatal_CyclicDependence [ + text (BU.format1 "Recursive dependency on module %s." filename); + text "A full dependency graph was written to dep.graph."; + ] + in + (* full_cycle_detection finds cycles across interface + boundaries that can otherwise be exploited to + build cross-module recursive loops, as in issue #1391 + *) + let full_cycle_detection all_command_line_files file_system_map = + let dep_graph = dep_graph_copy dep_graph in + + (* + * The cycle detection code considers all_command_line_files + * as roots to perform full cycle detection. As a result, + * all command line files, and their transitive dependences + * are considered. However, this misses the cycles through .fst + * as in the issue #1391, IF only .fsti is given on the command + * line. This is even more a problem in invocations like: + * fstar A.fsti --dep full, which dumps the .depend, while not + * noticing the cycle. + * + * A fix for this issue is to record in mo_files the implementations + * of command line interfaces whose implementations are not on the + * command line, and consider them also for cycle detection. + * + * Right now this is done even in the case of fstar A.fsti + * we can consider using mo_files only in the case of + * --dep invocations. + *) + let mo_files : ref (list string) = BU.mk_ref [] in + + + let rec aux (cycle:list file_name) filename = + let node = + match deps_try_find dep_graph filename with + | Some node -> node + | None -> + failwith (BU.format1 "Impossible: Failed to find dependencies of %s" filename) + in + let direct_deps = node.edges |> List.collect (fun x -> + match x with + | UseInterface f + | PreferInterface f -> + begin + match implementation_of_internal file_system_map f with + | None -> [x] + | Some fn when fn=filename -> + //don't add trivial self-loops + [x] + | _ -> + //if a module A uses B + //then detect cycles through both B.fsti + //and B.fst + [x; UseImplementation f] + end + | _ -> [x]) in + match node.color with + | Gray -> + cycle_detected dep_graph cycle filename + | Black -> + (* If the element has been visited already, then the map contains all its + * dependencies. Otherwise, the map only contains its direct dependencies. *) + () + | White -> + (* Unvisited. Compute. *) + deps_add_dep dep_graph filename ({node with edges=direct_deps; color=Gray}); + List.iter (fun k -> aux (k :: cycle) k) + (dependences_of file_system_map + dep_graph + all_command_line_files + filename); + (* Mutate the graph (to mark the node as visited) *) + deps_add_dep dep_graph filename ({node with edges=direct_deps; color=Black}); + + (* + * If the file is an interface, and its implementation exists, and the implementation + * is not on the command line, add it to mo_files + *) + if is_interface filename + then iter_opt + (implementation_of_internal file_system_map (lowercase_module_name filename)) + (fun impl -> if not (List.contains impl all_command_line_files) + then mo_files := impl::!mo_files + else ()) + else () + in + List.iter (aux []) all_command_line_files; + (* Detect cycles via mo_files *) + List.iter (aux []) !mo_files + in + full_cycle_detection all_cmd_line_files file_system_map; + + //only verify those files on the command line + all_cmd_line_files |> + List.iter (fun f -> + let m = lowercase_module_name f in + Options.add_verify_module m); + + let inlining_ifaces = !interfaces_needing_inlining in + let all_files, _ = + profile + (fun () -> + topological_dependences_of + file_system_map + dep_graph + inlining_ifaces + all_cmd_line_files + (Options.codegen()<>None)) + "FStarC.Parser.Dep.topological_dependences_of" + in + if !dbg + then BU.print1 "Interfaces needing inlining: %s\n" (String.concat ", " inlining_ifaces); + all_files, + mk_deps dep_graph file_system_map all_cmd_line_files all_files inlining_ifaces parse_results + +(* In public interface *) +let deps_of deps (f:file_name) + : list file_name = + dependences_of deps.file_system_map deps.dep_graph deps.cmd_line_files f + +let deps_of_modul deps (m:module_name) : list module_name = + let aux (fopt:option string) = + fopt |> BU.map_option (fun f -> f |> deps_of deps |> List.map module_name_of_file) + |> BU.dflt [] + in + m |> String.lowercase + |> BU.smap_try_find deps.file_system_map + |> BU.map_option (fun (intf_opt, impl_opt) -> + BU.remove_dups (fun x y -> x = y) (aux intf_opt @ aux impl_opt)) + |> BU.dflt [] + +(* In public interface *) +let print_digest (dig:list (string & string)) : string = + dig + |> List.map (fun (m, d) -> BU.format2 "%s:%s" m (BU.base64_encode d)) + |> String.concat "\n" + +(** Print the dependencies as returned by [collect] in a Makefile-compatible + format. + + Deprecated: this will print the dependences among the source files + *) +let print_make (outc : out_channel) deps : unit = + let file_system_map = deps.file_system_map in + let all_cmd_line_files = deps.cmd_line_files in + let deps = deps.dep_graph in + let keys = deps_keys deps in + keys |> List.iter + (fun f -> + let dep_node = deps_try_find deps f |> Option.get in + let files = List.map (file_of_dep file_system_map all_cmd_line_files) dep_node.edges in + let files = List.map (fun s -> replace_chars s ' ' "\\ ") files in + //this one prints: + // a.fst: b.fst c.fsti a.fsti + Util.print2 "%s: %s\n\n" f (String.concat " " files)) + +(* In public interface *) +let print_raw (outc : out_channel) (deps:deps) = + let (Deps deps) = deps.dep_graph in + smap_fold deps (fun k dep_node out -> + BU.format2 "%s -> [\n\t%s\n] " k (List.map dep_to_string dep_node.edges |> String.concat ";\n\t") :: out) [] + |> String.concat ";;\n" + |> (fun s -> BU.fprint outc "%s\n" [s]) + +(** Print the dependencies as returned by [collect] in a Makefile-compatible + format. + + -- The dependences are among the .checked files + + -- We also print dependences for producing .ml files from .checked files + This takes care of renaming A.B.C.fst to A_B_C.ml + *) +let print_full (outc : out_channel) (deps:deps) : unit = + let pre_tag = Options.Ext.get "dep_pretag" in + //let (Mk (deps, file_system_map, all_cmd_line_files, all_files)) = deps in + let sort_output_files (orig_output_file_map:BU.smap string) = + let order : ref (list string) = BU.mk_ref [] in + let remaining_output_files = BU.smap_copy orig_output_file_map in + let visited_other_modules = BU.smap_create 41 in + let should_visit lc_module_name = + Option.isSome (BU.smap_try_find remaining_output_files lc_module_name) + || Option.isNone (BU.smap_try_find visited_other_modules lc_module_name) + in + let mark_visiting lc_module_name = + let ml_file_opt = BU.smap_try_find remaining_output_files lc_module_name in + BU.smap_remove remaining_output_files lc_module_name; + BU.smap_add visited_other_modules lc_module_name true; + ml_file_opt + in + let emit_output_file_opt ml_file_opt = + match ml_file_opt with + | None -> () + | Some ml_file -> order := ml_file :: !order + in + let rec aux = function + | [] -> () + | lc_module_name::modules_to_extract -> + let visit_file file_opt = + match file_opt with + | None -> () + | Some file_name -> + match deps_try_find deps.dep_graph file_name with + | None -> failwith (BU.format2 "Impossible: module %s: %s not found" lc_module_name file_name) + | Some ({edges=immediate_deps}) -> + let immediate_deps = + List.map (fun x -> String.lowercase (module_name_of_dep x)) immediate_deps + in + aux immediate_deps + in + if should_visit lc_module_name then begin + let ml_file_opt = mark_visiting lc_module_name in + //visit all its dependences + visit_file (implementation_of deps lc_module_name); + visit_file (interface_of deps lc_module_name); + //and then emit this one's ML file + emit_output_file_opt ml_file_opt + end; + aux modules_to_extract + in + let all_extracted_modules = BU.smap_keys orig_output_file_map in + aux all_extracted_modules; + List.rev !order + in + let sb = FStarC.StringBuffer.create (FStarC.BigInt.of_int_fs 10000) in + let pr str = ignore <| FStarC.StringBuffer.add str sb in + let print_entry target first_dep all_deps = + pr target; + pr ": "; + pr first_dep; + pr "\\\n\t"; + pr all_deps; + pr "\n\n" + in + let keys = deps_keys deps.dep_graph in + let no_fstar_stubs_file (s:string) : string = + (* If the original filename begins with FStar.Stubs, then remove that, + consistent with what extraction will actually do. *) + let s1 = "FStar.Stubs." in + let s2 = "FStar." in + let l1 = String.length s1 in + if String.length s >= l1 && String.substring s 0 l1 = s1 then + s2 ^ String.substring s l1 (String.length s - l1) + else + s + in + let output_file ext fst_file = + let basename = Option.get (check_and_strip_suffix (BU.basename fst_file)) in + let basename = no_fstar_stubs_file basename in + let ml_base_name = replace_chars basename '.' "_" in + Options.prepend_output_dir (ml_base_name ^ ext) + in + let norm_path s = replace_chars (replace_chars s '\\' "/") ' ' "\\ " in + let output_fs_file f = norm_path (output_file ".fs" f) in + let output_ml_file f = norm_path (output_file ".ml" f) in + let output_krml_file f = norm_path (output_file ".krml" f) in + let output_cmx_file f = norm_path (output_file ".cmx" f) in + let cache_file f = norm_path (cache_file_name f) in + let widened, dep_graph = phase1 deps.file_system_map deps.dep_graph deps.interfaces_with_inlining true in + let all_checked_files = + keys |> + List.fold_left + (fun all_checked_files file_name -> + let process_one_key () = + let dep_node = deps_try_find deps.dep_graph file_name |> Option.get in + let iface_fn, iface_deps = + if is_interface file_name + then None, None + else match interface_of deps (lowercase_module_name file_name) with + | None -> + None, None + | Some iface -> + Some iface, + Some ((Option.get (deps_try_find deps.dep_graph iface)).edges) + in + let iface_deps = + BU.map_opt iface_deps + (List.filter + (fun iface_dep -> + not (BU.for_some (dep_subsumed_by iface_dep) dep_node.edges))) + in + let norm_f = norm_path file_name in + let files = + List.map + (file_of_dep_aux true deps.file_system_map deps.cmd_line_files) + dep_node.edges + in + let files = + match iface_deps with + | None -> files + | Some iface_deps -> + let iface_files = + List.map (file_of_dep_aux true deps.file_system_map deps.cmd_line_files) iface_deps + in + BU.remove_dups (fun x y -> x = y) (files @ iface_files) + in + + (* + * AR: depend on A.fsti.checked, rather than A.fsti + * see #1919 + *) + let files = + if iface_fn |> is_some then + let iface_fn = iface_fn |> must in + files |> List.filter (fun f -> f <> iface_fn) + |> (fun files -> (cache_file_name iface_fn)::files) + else files in + + let files = List.map norm_path files in + let files = String.concat "\\\n\t" files in + let cache_file_name = cache_file file_name in + + let all_checked_files = + if not (Options.should_be_already_cached (module_name_of_file file_name)) + then //this one prints: + // a.fst.checked: b.fst.checked c.fsti.checked a.fsti + (print_entry cache_file_name norm_f files; + cache_file_name::all_checked_files) + else all_checked_files + in + + //And, if this is not an interface, we also print out the dependences among the .ml files + // excluding files in ulib, since these are packaged in fstar_lib.cmxa + let all_fst_files_dep, widened = + if Options.cmi() + then profile + (fun () -> + topological_dependences_of' + deps.file_system_map + (dep_graph_copy dep_graph) + deps.interfaces_with_inlining + [file_name] + widened) + "FStarC.Parser.Dep.topological_dependences_of_2" + else + let maybe_widen_deps (f_deps:dependences) = + List.map + (fun dep -> + file_of_dep_aux false deps.file_system_map deps.cmd_line_files dep) + f_deps + in + let fst_files = maybe_widen_deps dep_node.edges in + let fst_files_from_iface = + match iface_deps with + | None -> [] + | Some iface_deps -> maybe_widen_deps iface_deps + in + BU.remove_dups (fun x y -> x = y) (fst_files @ fst_files_from_iface), + false + in + let all_checked_fst_dep_files = all_fst_files_dep |> List.map cache_file in + let all_checked_fst_dep_files_string = + String.concat " \\\n\t" all_checked_fst_dep_files + in + let _ = + if is_implementation file_name + then begin + if Options.cmi() + && widened + then begin + let mname = lowercase_module_name file_name in + + print_entry + (output_ml_file file_name) + cache_file_name + all_checked_fst_dep_files_string; + + if Options.should_extract mname Options.FSharp + then print_entry + (output_fs_file file_name) + cache_file_name + all_checked_fst_dep_files_string; + + print_entry + (output_krml_file file_name) + cache_file_name + all_checked_fst_dep_files_string + end + else begin + let mname = lowercase_module_name file_name in + + print_entry + (output_ml_file file_name) + cache_file_name + ""; + + if Options.should_extract mname Options.FSharp + then print_entry + (output_fs_file file_name) + cache_file_name + ""; + + print_entry + (output_krml_file file_name) + cache_file_name + "" + end; + let cmx_files = + let extracted_fst_files = + all_fst_files_dep |> + List.filter + (fun df -> + lowercase_module_name df <> lowercase_module_name file_name //avoid circular deps on f's own cmx + && Options.should_extract (lowercase_module_name df) Options.OCaml) + in + extracted_fst_files |> List.map output_cmx_file + in + if Options.should_extract (lowercase_module_name file_name) Options.OCaml + then + let cmx_files = String.concat "\\\n\t" cmx_files in + print_entry + (output_cmx_file file_name) + (output_ml_file file_name) + cmx_files + + end + else if not(has_implementation deps.file_system_map (lowercase_module_name file_name)) + && is_interface file_name + then begin + // .krml files can be produced using just an interface, unlike .ml files + if Options.cmi() + && (widened || true) + then + print_entry + (output_krml_file file_name) + cache_file_name + all_checked_fst_dep_files_string + else + print_entry + (output_krml_file file_name) + (cache_file_name) + "" + end + in + all_checked_files + in + profile process_one_key "FStarC.Parser.Dep.process_one_key") + [] + in + let all_fst_files = + keys |> List.filter is_implementation + |> Util.sort_with String.compare + in + let all_fsti_files = + keys |> List.filter is_interface + |> Util.sort_with String.compare + in + let all_ml_files = + let ml_file_map = BU.smap_create 41 in + all_fst_files + |> List.iter (fun fst_file -> + let mname = lowercase_module_name fst_file in + if Options.should_extract mname Options.OCaml + then BU.smap_add ml_file_map mname (output_ml_file fst_file)); + sort_output_files ml_file_map + in + let all_fs_files = + let fs_file_map = BU.smap_create 41 in + all_fst_files + |> List.iter (fun fst_file -> + let mname = lowercase_module_name fst_file in + if Options.should_extract mname Options.FSharp + then BU.smap_add fs_file_map mname (output_fs_file fst_file)); + sort_output_files fs_file_map + in + let all_krml_files = + let krml_file_map = BU.smap_create 41 in + keys + |> List.iter (fun fst_file -> + let mname = lowercase_module_name fst_file in + if Options.should_extract mname Options.Krml + then BU.smap_add krml_file_map mname (output_krml_file fst_file)); + sort_output_files krml_file_map + in + let print_all tag files = + pr (pre_tag^tag); + pr "=\\\n\t"; + List.iter (fun f -> pr (norm_path f); pr " \\\n\t") files; + pr "\n" + in + all_fsti_files + |> List.iter + (fun fsti -> + let mn = lowercase_module_name fsti in + let range_of_file fsti = + let r = Range.set_file_of_range Range.dummyRange fsti in + Range.set_use_range r (Range.def_range r) + in + if not (has_implementation deps.file_system_map mn) then + log_issue (range_of_file fsti) Warning_WarnOnUse + (BU.format1 "Interface %s is admitted without an implementation" (module_name_of_file fsti))); + print_all "ALL_FST_FILES" all_fst_files; + print_all "ALL_FSTI_FILES" all_fsti_files; + print_all "ALL_CHECKED_FILES" all_checked_files; + print_all "ALL_FS_FILES" all_fs_files; + print_all "ALL_ML_FILES" all_ml_files; + print_all "ALL_KRML_FILES" all_krml_files; + + FStarC.StringBuffer.output_channel outc sb + +let do_print (outc : out_channel) (fn : string) deps : unit = + let pref () = + BU.fprint outc "# This .depend was generated by F* %s\n" [!Options._version]; + BU.fprint outc "# Executable: %s\n" [show BU.exec_name]; + BU.fprint outc "# Hash: %s\n" [!Options._commit]; + BU.fprint outc "# Running in directory %s\n" [show (normalize_file_path (BU.getcwd ()))]; + BU.fprint outc "# Command line arguments: \"%s\"\n" [show (BU.get_cmd_args ())]; + BU.fprint outc "\n" []; + () + in + match Options.dep() with + | Some "make" -> + pref (); + print_make outc deps + | Some "full" -> + pref (); + profile (fun () -> print_full outc deps) "FStarC.Parser.Deps.print_full_deps" + | Some "graph" -> + print_graph outc fn deps.dep_graph + | Some "raw" -> + print_raw outc deps + | Some _ -> + raise_error0 Errors.Fatal_UnknownToolForDep "unknown tool for --dep\n" + | None -> + assert false + +(* Just prints to stdout *) +let do_print_stdout deps = + do_print BU.stdout "" deps + +(* Opens the file, prints to it, and closes it. If anything failed, the file +is deleted. *) +let do_print_file deps fn = + with_file_outchannel fn (fun outc -> do_print outc fn deps) + +(* In public interface *) +let print deps = + match Options.output_deps_to () with + | Some s -> do_print_file deps s + (* Special case for --dep graph, by default we write to dep.graph instead of stdout. *) + | None when Options.dep () = Some "graph" -> do_print_file deps "dep.graph" + | None -> do_print_stdout deps + +(* In public interface *) +let module_has_interface deps module_name = + has_interface deps.file_system_map (String.lowercase (Ident.string_of_lid module_name)) + +(* In public interface *) +let deps_has_implementation deps module_name = + let m = String.lowercase (Ident.string_of_lid module_name) in + deps.all_files |> BU.for_some (fun f -> + is_implementation f + && String.lowercase (module_name_of_file f) = m) diff --git a/src/parser/FStarC.Parser.Dep.fsti b/src/parser/FStarC.Parser.Dep.fsti new file mode 100644 index 00000000000..c5c6b59935a --- /dev/null +++ b/src/parser/FStarC.Parser.Dep.fsti @@ -0,0 +1,65 @@ +(* + Copyright 2008-2014 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR C ONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Parser.Dep +open FStarC.Compiler.Effect +open FStar open FStarC +open FStarC.Compiler +open FStarC.Parser +open FStarC.Parser.AST +open FStarC.Compiler.Util +open FStarC.Const +open FStar.String +open FStarC.Ident +open FStarC.Errors +module Const = FStarC.Parser.Const +module BU = FStarC.Compiler.Util + +type open_kind = | Open_module | Open_namespace +type module_name = string + +val maybe_module_name_of_file : string -> option string +val module_name_of_file : string -> string +val lowercase_module_name : string -> string + +val build_inclusion_candidates_list : unit -> list (string & string) + +val core_modules (_: unit) : list string +(* Given a filename, returns the list of automatically opened modules +and namespaces *) +val hard_coded_dependencies : string -> list (lident & open_kind) + +val is_interface: string -> bool +val is_implementation: string -> bool + +val parsing_data : Type0 //cached in the checked files +val str_of_parsing_data (p:parsing_data) : string +val empty_parsing_data: parsing_data //for legacy ide +val friends (p:parsing_data) : list lident +val deps : Type0 + +val empty_deps : deps +val interface_of : deps -> module_name:string -> option string //return value is the file name +val implementation_of : deps -> module_name:string -> option string //return value is the file name +val cache_file_name: (string -> string) +val parsing_data_of: deps -> string -> parsing_data +val collect: list string -> (string -> option parsing_data) -> list string & deps +val deps_of : deps -> string -> list string +val deps_of_modul : deps -> module_name -> list module_name // list of modules that this module depends on +val print : deps -> unit +val print_digest: list (string & string) -> string +val module_has_interface: deps -> module_name:Ident.lident -> bool +val deps_has_implementation: deps -> module_name:Ident.lident -> bool +val print_raw: out_channel -> deps -> unit diff --git a/src/parser/FStarC.Parser.Driver.fst b/src/parser/FStarC.Parser.Driver.fst new file mode 100644 index 00000000000..5a1826db5b3 --- /dev/null +++ b/src/parser/FStarC.Parser.Driver.fst @@ -0,0 +1,69 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Parser.Driver +open FStar.Pervasives +open FStarC.Compiler.Effect + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Parser +open FStarC.Parser.AST +open FStarC.Parser.ParseIt +open FStarC.Compiler.Util +open FStarC.Errors +open FStarC.Class.Show + +let is_cache_file (fn: string) = Util.get_file_extension fn = ".cache" + +let parse_fragment lang_opt (frag: ParseIt.input_frag) : fragment = + match ParseIt.parse lang_opt (Toplevel frag) with + | ASTFragment (Inl modul, _) -> //interactive mode: module + Modul modul + | ASTFragment (Inr [], _) -> //interactive mode: blank space + Empty + | ASTFragment (Inr decls, _) -> //interactive mode: more decls + Decls decls + | IncrementalFragment (decls, _, _) -> + DeclsWithContent decls + | ParseError (e, msg, r) -> + raise_error r e msg + | Term _ -> + failwith "Impossible: parsing a Toplevel always results in an ASTFragment" + +let maybe_dump_module (m:modul) = + match m with + | Module (l, ds) + | Interface (l, ds, _) -> + if FStarC.Options.dump_module (Ident.string_of_lid l) + then ( + print2 "Parsed module %s\n%s\n" + (Ident.string_of_lid l) + (List.map show ds |> String.concat "\n") + ) +(* Returns a non-desugared AST (as in [parser/ast.fs]) or aborts. *) +let parse_file fn = + match ParseIt.parse None (Filename fn) with + | ASTFragment (Inl ast, comments) -> + ast, comments + | ASTFragment (Inr _ , _) -> + let msg = Util.format1 "%s: expected a module\n" fn in + let r = Range.dummyRange in + raise_error r Errors.Fatal_ModuleExpected msg + | ParseError (e, msg, r) -> + raise_error r e msg + | Term _ -> + failwith "Impossible: parsing a Filename always results in an ASTFragment" + diff --git a/src/parser/FStarC.Parser.Driver.fsti b/src/parser/FStarC.Parser.Driver.fsti new file mode 100644 index 00000000000..9f0cebef3ca --- /dev/null +++ b/src/parser/FStarC.Parser.Driver.fsti @@ -0,0 +1,34 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Parser.Driver + +module Range = FStarC.Compiler.Range +module AST = FStarC.Parser.AST +module AU = FStarC.Parser.AST.Util +module ParseIt = FStarC.Parser.ParseIt + +val is_cache_file : string -> bool + +type fragment = + | Empty + | Modul of AST.modul // an entire module or interface -- unspecified + | Decls of list AST.decl // a partial set of declarations + | DeclsWithContent of list (AST.decl & ParseIt.code_fragment) + +val parse_fragment : ParseIt.lang_opts -> ParseIt.input_frag -> fragment + +(* Returns a non-desugared AST (as in [parser/ast.fs]) or aborts. *) +val parse_file : string -> AST.file & list (string & Range.range) diff --git a/src/parser/FStarC.Parser.ParseIt.fsti b/src/parser/FStarC.Parser.ParseIt.fsti new file mode 100644 index 00000000000..e0c5a35758a --- /dev/null +++ b/src/parser/FStarC.Parser.ParseIt.fsti @@ -0,0 +1,70 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Parser.ParseIt +open FStarC.Compiler.Effect +open FStarC.Parser +open FStarC.Compiler.Util +open FStar open FStarC +open FStarC.Compiler +open FStarC.Errors +module AU = FStarC.Parser.AST.Util +type filename = string + +type input_frag = { + frag_fname:filename; + frag_text:string; + frag_line:int; + frag_col:int +} + +val read_vfs_entry : string -> option (time & string) +// This lets the ide tell us about edits not (yet) reflected on disk. +val add_vfs_entry: fname:string -> contents:string -> unit +// This reads mtimes from the VFS as well +val get_file_last_modification_time: fname:string -> time + +type parse_frag = + | Filename of filename + | Toplevel of input_frag + | Incremental of input_frag + | Fragment of input_frag + +type parse_error = (error_code & error_message & Range.range) + +type code_fragment = { + code: string; + range: FStarC.Compiler.Range.range; +} + +type incremental_result 'a = + list ('a & code_fragment) & list (string & Range.range) & option parse_error + +type parse_result = + | ASTFragment of (AST.inputFragment & list (string & Range.range)) + | IncrementalFragment of incremental_result AST.decl + | Term of AST.term + | ParseError of parse_error + +let lang_opts = option string +val parse (ext_lang:lang_opts) + (frag:parse_frag) +: parse_result +val find_file: string -> string + +val parse_warn_error: string -> list FStarC.Errors.error_setting + +(* useful for unit testing and registered a #lang-fstar parser *) +val parse_fstar_incrementally : AU.extension_lang_parser diff --git a/src/parser/FStarC.Parser.ToDocument.fst b/src/parser/FStarC.Parser.ToDocument.fst new file mode 100644 index 00000000000..231e1909ae8 --- /dev/null +++ b/src/parser/FStarC.Parser.ToDocument.fst @@ -0,0 +1,2319 @@ +(* + Copyright 2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +(** Convert Parser.Ast to Pprint.document for prettyprinting. *) +module FStarC.Parser.ToDocument +open FStarC +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.Parser.AST +open FStarC.Ident +open FStarC.Const +open FStarC.Pprint +open FStarC.Compiler.Range +open FStarC.Class.Show + +module C = FStarC.Parser.Const +module BU = FStarC.Compiler.Util + + + +(* !!! SIDE EFFECT WARNING !!! *) +(* There is ONE use of global side-effect in the printer for : *) +(* - Printing the comments [comment_stack] *) + +let maybe_unthunk t = + match t.tm with + | Abs ([_], body) -> body + | _ -> t + +let min x y = if x > y then y else x +let max x y = if x > y then x else y + +// VD: copied over from NBE, should both probably go in FStarC.Compiler.List +let map_rev (f: 'a -> 'b) (l: list 'a): list 'b = + let rec aux (l:list 'a) (acc:list 'b) = + match l with + | [] -> acc + | x :: xs -> aux xs (f x :: acc) + in + aux l [] + +let map_if_all (f: 'a -> option 'b) (l: list 'a): option (list 'b) = + let rec aux l acc = + match l with + | [] -> acc + | x :: xs -> + (match f x with + | Some r -> aux xs (r :: acc) + | None -> []) + in + let r = aux l [] in + if List.length l = List.length r then + Some r + else None + +let rec all (f: 'a -> bool) (l: list 'a): bool = + match l with + | [] -> true + | x :: xs -> if f x then all f xs else false + +let all1_explicit (args:list (term&imp)) : bool = + not (List.isEmpty args) && + BU.for_all (function + | (_, Nothing) -> true + | _ -> false) args + +// abbrev +let str s = doc_of_string s + +// lib +let default_or_map n f x = + match x with + | None -> n + | Some x' -> f x' + +// changing PPrint's ^//^ to ^/+^ since '//' wouldn't work in F# +let prefix2 prefix_ body = prefix 2 1 prefix_ body + +let prefix2_nonempty prefix_ body = + if body = empty then prefix_ else prefix2 prefix_ body + +let ( ^/+^ ) prefix_ body = prefix2 prefix_ body + +let jump2 body = + jump 2 1 body + +let infix2 = infix 2 1 +let infix0 = infix 0 1 + +let break1 = + break_ 1 + + +(* [separate_break_map sep f l] has the following + [(f l[0]) sep (f l[1]) ... sep (f l[n])] + and the following non flat layout + [(f l[0]) sep + (f l[1]) sep + ... + (f l[n])] +*) +let separate_break_map sep f l = + group (separate_map (space ^^ sep ^^ break1) f l) + +(* [precede_break_separate_map prec sep f l] has the flat layout + + [prec (f l[0]) sep (f l[1]) ... sep (f l[n])] + + and the following non flat layout + + [prec (f l[0]) + sep (f l[1]) + ... + sep (f l[n])] +*) +let precede_break_separate_map prec sep f l = + precede (prec ^^ space) (List.hd l |> f) ^^ concat_map (fun x -> break1 ^^ sep ^^ space ^^ f x) (List.tl l) + +let concat_break_map f l = group (concat_map (fun x -> f x ^^ break1) l) + +let parens_with_nesting contents = + surround 2 0 lparen contents rparen + +let soft_parens_with_nesting contents = + soft_surround 2 0 lparen contents rparen + +let braces_with_nesting contents = + surround 2 1 lbrace contents rbrace + +let soft_braces_with_nesting contents = + soft_surround 2 1 lbrace contents rbrace + +let soft_braces_with_nesting_tight contents = + soft_surround 2 0 lbrace contents rbrace + +let brackets_with_nesting contents = + surround 2 1 lbracket contents rbracket + +let soft_brackets_with_nesting contents = + soft_surround 2 1 lbracket contents rbracket + +let soft_lens_access_with_nesting contents = + soft_surround 2 1 (str "(|") contents (str "|)") + +let soft_brackets_lens_access_with_nesting contents = + soft_surround 2 1 (str "[|") contents (str "|]") + +let soft_begin_end_with_nesting contents = + soft_surround 2 1 (str "begin") contents (str "end") + +let tc_arg contents = + soft_surround 2 1 (str "{|") contents (str "|}") + +let is_tc_binder (b:binder) : bool = + match b.aqual with + | Some TypeClassArg -> true + | _ -> false + +let is_meta_qualifier aq = + match aq with + | Some (Meta _) -> true + | _ -> false + +let is_joinable_binder (b:binder) : bool = + not (is_tc_binder b) && not (is_meta_qualifier b.aqual) + +let separate_map_last sep f es = + let l = List.length es in + let es = List.mapi (fun i e -> f (i <> l - 1) e) es in + separate sep es + +let separate_break_map_last sep f l = + group (separate_map_last (space ^^ sep ^^ break1) f l) + +let separate_map_or_flow sep f l = + if List.length l < 10 + then separate_map sep f l + else flow_map sep f l + +let flow_map_last sep f es = + let l = List.length es in + let es = List.mapi (fun i e -> f (i <> l - 1) e) es in + flow sep es + +let separate_map_or_flow_last sep f l = + if List.length l < 10 + then separate_map_last sep f l + else flow_map_last sep f l + +let separate_or_flow sep l = separate_map_or_flow sep id l + +let surround_maybe_empty n b doc1 doc2 doc3 = + if doc2 = empty then + group (doc1 ^/^ doc3) + else + surround n b doc1 doc2 doc3 + +let soft_surround_separate_map n b void_ opening sep closing f xs = + if xs = [] + then void_ + else soft_surround n b opening (separate_map sep f xs) closing + +let soft_surround_map_or_flow n b void_ opening sep closing f xs = + if xs = [] + then void_ + else soft_surround n b opening (separate_map_or_flow sep f xs) closing + + +// Really specific functions to retro-engineer the desugaring +let is_unit e = + match e.tm with + | Const Const_unit -> true + | _ -> false + +let matches_var t x = + match t.tm with + | Var y -> (string_of_id x) = string_of_lid y + | _ -> false + +let is_tuple_constructor = C.is_tuple_data_lid' +let is_dtuple_constructor = C.is_dtuple_data_lid' + +let is_array e = match e.tm with + (* TODO check that there is no implicit parameters *) + | App ({tm=Var lid}, l, Nothing) -> lid_equals lid C.array_of_list_lid && ListLiteral? l.tm + | _ -> false + +let rec is_ref_set e = match e.tm with + | Var maybe_empty_lid -> lid_equals maybe_empty_lid C.set_empty + | App ({tm=Var maybe_singleton_lid}, {tm=App({tm=Var maybe_addr_of_lid}, e, Nothing)}, Nothing) -> + lid_equals maybe_singleton_lid C.set_singleton && lid_equals maybe_addr_of_lid C.heap_addr_of_lid + | App({tm=App({tm=Var maybe_union_lid}, e1, Nothing)}, e2, Nothing) -> + lid_equals maybe_union_lid C.set_union && is_ref_set e1 && is_ref_set e2 + | _ -> false + +(* [extract_from_ref_set e] assumes that [is_ref_set e] holds and returns the list of terms contained in the set *) +let rec extract_from_ref_set e = match e.tm with + | Var _ -> [] + | App ({tm=Var _}, {tm=App({tm=Var _}, e, Nothing)}, Nothing) -> [e] + | App({tm = App({tm=Var _}, e1, Nothing)}, e2, Nothing) -> + extract_from_ref_set e1 @ extract_from_ref_set e2 + | _ -> failwith (Util.format1 "Not a ref set %s" (term_to_string e)) + +let is_general_application e = + not (is_array e || is_ref_set e) + +let is_general_construction e = + not (ListLiteral? e.tm) + +let is_general_prefix_op op = + let op_starting_char = char_at (Ident.string_of_id op) 0 in + op_starting_char = '!' || op_starting_char = '?' || + (op_starting_char = '~' && Ident.string_of_id op <> "~") + +(* might already exist somewhere *) +let head_and_args e = + let rec aux e acc = match e.tm with + | App (head, arg, imp) -> aux head ((arg,imp)::acc) + | _ -> e, acc + in aux e [] + + +(* Automatic level assignment *) +(* would be perfect with a little of staging... *) +(* TODO : see if we can plug in the menhir inspection API so that *) +(* the level_associativity_spec table below is produced by the parser *) + +type associativity = + | Left + | Right + | NonAssoc + +(* A token is either a character c representing any string beginning with c, a complete string or a unicode operator *) +type token = + | StartsWith: Char.char -> token + | Exact : string -> token + | UnicodeOperator + +type associativity_level = associativity & list token + +let token_to_string = function + | StartsWith c -> string_of_char c ^ ".*" + | Exact s -> s + | UnicodeOperator -> "" + +let is_non_latin_char (s:Char.char): bool + = int_of_char s > 0x024f + +let matches_token (s:string) = function + | StartsWith c -> FStarC.Compiler.String.get s 0 = c + | Exact s' -> s = s' + | UnicodeOperator -> is_non_latin_char (FStarC.Compiler.String.get s 0) + +let matches_level s (assoc_levels, tokens) = + List.tryFind (matches_token s) tokens <> None + +// GM 05/10/18, TODO: This still needs to be heavily annotated with the new unifier: + +(* Precedence and associativity levels, taken from ../src/parse.mly *) +let opinfix4 : associativity_level = Right, [Exact "**"; UnicodeOperator] +// level backtick won't be used here +let opinfix3 : associativity_level = Left, [StartsWith '*' ; StartsWith '/' ; StartsWith '%'] +let opinfix2 : associativity_level = Left, [StartsWith '+' ; StartsWith '-' ] +let minus_lvl : associativity_level = Left, [Exact "-"] // Sublevel of opinfix2, not a level on its own !!! +let opinfix1 : associativity_level = Right, [StartsWith '@' ; StartsWith '^'] +let pipe_right : associativity_level = Left, [Exact "|>"] +let opinfix0d : associativity_level = Left, [StartsWith '$'] +let opinfix0c : associativity_level = Left, [StartsWith '=' ; StartsWith '<' ; StartsWith '>'] +let equal : associativity_level = Left, [Exact "="] // Sublevel of opinfix0c, not a level on its own !!! +let opinfix0b : associativity_level = Left, [StartsWith '&'] +let opinfix0a : associativity_level = Left, [StartsWith '|'] +let colon_equals : associativity_level = NonAssoc, [Exact ":="] +let amp : associativity_level = Right, [Exact "&"] +let colon_colon : associativity_level = Right, [Exact "::"] + +(* The latter the element, the tighter it binds *) +let level_associativity_spec : list associativity_level = + [ + opinfix4 ; + opinfix3 ; + opinfix2 ; + opinfix1 ; + pipe_right ; + opinfix0d ; + opinfix0c ; + opinfix0b ; + opinfix0a ; + colon_equals ; + amp ; + colon_colon ; + ] + +let level_table = + let levels_from_associativity (l:int) = function + | Left -> l, l, l-1 + | Right -> l-1, l, l + | NonAssoc -> l - 1, l, l - 1 + in + List.mapi (fun i (assoc, tokens) -> (levels_from_associativity i assoc, tokens)) level_associativity_spec + +let assign_levels (token_associativity_spec : list associativity_level) (s:string) : int & int & int = + match List.tryFind (matches_level s) level_table with + | Some (assoc_levels, _) -> assoc_levels + | _ -> failwith ("Unrecognized operator " ^ s) + +let max_level l = + let find_level_and_max n level = + match List.tryFind (fun (_, tokens) -> tokens = snd level) level_table with + | Some ((_,l,_), _) -> max n l + | None -> failwith (Util.format1 "Undefined associativity level %s" + (String.concat "," (List.map token_to_string (snd level)))) + in List.fold_left find_level_and_max 0 l + +let levels op = + (* See comment in parse.fsy: tuples MUST be parenthesized because [t & u & v] + * is not the same thing as [(t & u) & v]. So, we are conservative and make an + * exception for the "&" operator and treat it as, really, non-associative. If + * the AST comes from the user, then the Paren node was there already and no + * extra parentheses are added. If the AST comes from some client inside of + * the F* compiler that doesn't know about this quirk, then it forces it to be + * parenthesized properly. In case the user overrode & to be a truly + * associative operator then we're just being a little + * conservative because, unlike ToSyntax.fs, we don't have lexical context to + * help us determine which operator this is, really. *) + let left, mine, right = assign_levels level_associativity_spec op in + if op = "&" then + left - 1, mine, right + else + left, mine, right + +let operatorInfix0ad12 = [opinfix0a ; opinfix0b ; opinfix0c ; opinfix0d ; opinfix1 ; opinfix2 ] + +let is_operatorInfix0ad12 op = + List.tryFind (matches_level <| Ident.string_of_id op) operatorInfix0ad12 <> None + +let is_operatorInfix34 = + let opinfix34 = [ opinfix3 ; opinfix4 ] in + fun op -> List.tryFind (matches_level <| Ident.string_of_id op) opinfix34 <> None + +let handleable_args_length (op:ident) = + let op_s = Ident.string_of_id op in + if is_general_prefix_op op || List.mem op_s [ "-" ; "~" ] then 1 + else if (is_operatorInfix0ad12 op || + is_operatorInfix34 op || + List.mem op_s ["<==>" ; "==>" ; "\\/" ; "/\\" ; "=" ; "|>" ; ":=" ; ".()" ; ".[]"; ".(||)"; ".[||]"]) + then 2 + else if (List.mem op_s [".()<-" ; ".[]<-"; ".(||)<-"; ".[||]<-"]) then 3 + else 0 + +let handleable_op op args = + match List.length args with + | 0 -> true + | 1 -> is_general_prefix_op op || List.mem (Ident.string_of_id op) [ "-" ; "~" ] + | 2 -> + is_operatorInfix0ad12 op || + is_operatorInfix34 op || + List.mem (Ident.string_of_id op) ["<==>" ; "==>" ; "\\/" ; "/\\" ; "=" ; "|>" ; ":=" ; ".()" ; ".[]"; ".(||)"; ".[||]"] + | 3 -> List.mem (Ident.string_of_id op) [".()<-" ; ".[]<-"; ".(||)<-"; ".[||]<-"] + | _ -> false + + +// Style choice for type signatures. Depending on available space, they +// can be printed in one of three ways: +// (1) all on the same line +// (2) all on the same line, except the computation type, which is +// pushed on a new line +// (3) keyword and identifier on one line, then every binder and the +// computation type on separate lines; binders can also be spread over +// multiple lines +// In case (2), the first parameter controls indentation for the +// computation type. In case (3), first parameter is indentation for each +// of the binders, second parameter is indendation for the computation +// type. +// The third parameter in Binders controls whether each binder is +// paranthesised +type annotation_style = + | Binders of int & int & bool // val f (x1:t1) ... (xn:tn) : C + | Arrows of int & int // val f : x1:t1 -> ... -> xn:tn -> C + +// decide whether a type signature can be printed in the format +// val f (x1:t1) ... (xn:tn) : C +// it can't if either not all args are annotated binders or if it has no +// arguments, in which case it will be printed using the colon + arrows style +let all_binders_annot e = + let is_binder_annot b = + match b.b with + | Annotated _ -> true + | _ -> false + in + let rec all_binders e l = + match e.tm with + | Product(bs, tgt) -> + if List.for_all is_binder_annot bs then + all_binders tgt (l+ List.length bs) + else + (false, 0) + | _ -> (true, l+1) + in + let b, l = all_binders e 0 in + if b && l > 1 then true else false + +type catf = document -> document -> document +let cat_with_colon x y = x ^^ colon ^/^ y + + +(* ****************************************************************************) +(* *) +(* Taking care of comments *) +(* *) +(* ****************************************************************************) + +(* Comments are not part of the AST but can be collected by the lexer so that we *) +(* can try to reinstate them when printing. Since they are not inside the AST, we *) +(* need to find some valid place to place them back. *) + +(* We assume that comments are tagged by their original position (a range) and *) +(* that they are given in the order they appear. Then we use the range information *) +(* inside the printed AST to reinstate the comments. *) + +(* The rules for placing comments are : *) +(* 1. There is at most one comment per line *) +(* 2. Line feeds between comments occuring between two toplevel declarations are *) +(* preserved *) +(* 3. A comment is printed just before some AST node if it has not been printed *) +(* before and its range ends before the end of the line where the AST node *) +(* was originally *) +(* 4. Left-over comments are always printed even if the position could be meaningless *) +(* 5. The AST node on which comments can be attached are the one using the *) +(* [with_comment] function defined just below *) + +(* Since comments are using side effects to be printed in the correct order it is important *) +(* that all printed AST nodes that could eventually contain a comment are printed in the *) +(* sequential order of the document. *) + +let comment_stack : ref (list (string&range))= BU.mk_ref [] + +(* some meta-information that informs spacing and the placement of comments around a declaration *) +type decl_meta = + {r: range; + has_qs: bool; //has quantifiers + has_attrs: bool; //has attributes + } +let dummy_meta = {r = dummyRange; has_qs = false; has_attrs = false} + +// TODO: rewrite in terms of with_comment_sep (some tricky issues with spacing) +let with_comment printer tm tmrange = + let rec comments_before_pos acc print_pos lookahead_pos = + match !comment_stack with + | [] -> acc, false + | (c, crange) :: cs -> + let comment = str c ^^ hardline in + if range_before_pos crange print_pos + then begin + comment_stack := cs ; + comments_before_pos (acc ^^ comment) print_pos lookahead_pos + end + else acc, range_before_pos crange lookahead_pos + in + let comments, has_lookahead = + comments_before_pos empty (end_of_line ( start_of_range tmrange)) (end_of_range tmrange) + in + let printed_e = printer tm in + let comments = + if has_lookahead + then + let pos = end_of_range tmrange in + fst (comments_before_pos comments pos pos) + else comments + in + if comments = empty then + printed_e + else + group (comments ^^ printed_e) + +let with_comment_sep printer tm tmrange = + let rec comments_before_pos acc print_pos lookahead_pos = + match !comment_stack with + | [] -> acc, false + | (c, crange) :: cs -> + let comment = str c in + if range_before_pos crange print_pos + then begin + comment_stack := cs ; + comments_before_pos (if acc = empty then comment else acc ^^ hardline ^^ comment) print_pos lookahead_pos + end + else acc, range_before_pos crange lookahead_pos + in + let comments, has_lookahead = + comments_before_pos empty (end_of_line ( start_of_range tmrange)) (end_of_range tmrange) + in + let printed_e = printer tm in + let comments = + if has_lookahead + then + let pos = end_of_range tmrange in + fst (comments_before_pos comments pos pos) + else comments + in + comments, printed_e + + +(* [place_comments_until_pos k lbegin pos doc r init] appends to doc all the comments present in *) +(* [comment_stack] whose range is before pos and separate each comments by as many lines *) +(* as indicated by the range information (at least [k]) using [lbegin] as the last line of *) +(* [doc] in the original document. Between 2 comments [k] is set to [1] *) +(* r is true if this is a recursive call (i.e. a comment has been placed) *) +(* init is true when placing the initial comment *) +let rec place_comments_until_pos (k: int) (lbegin: int) pos meta_decl doc (r: bool) (init: bool) = + match !comment_stack with + | (comment, crange) :: cs when range_before_pos crange pos -> + comment_stack := cs ; + let lnum = max k (line_of_pos (start_of_range crange) - lbegin) in + let lnum = min 2 lnum in + let doc = doc ^^ repeat lnum hardline ^^ str comment in + place_comments_until_pos 1 (line_of_pos (end_of_range crange)) pos meta_decl doc true init + | _ -> + if doc = empty then + empty + else + // lnum is initially (approximately) the number of newlines between the end of the previous declaration + // and the beginning of the one currently being printed, in the original source file (which may change + // during prettyprinting), not accounting for qualifiers and attributes; as a consequence, + // we have to massage this number in the following steps in order to achieve some sensible spacing and + // to keep prettyprinting idempotent + let lnum = line_of_pos pos - lbegin in + + // limit the number of newlines between declarations to 3 (2 empty lines in between) + let lnum = min 3 lnum in + + // range information does not include qualifiers or attributes (the start position is at "let"), + // so we need to account for (at least) one extra line + let lnum = if meta_decl.has_qs || meta_decl.has_attrs then lnum - 1 else lnum in + + // make sure lnum is not smaller than k + let lnum = max k lnum in + + // if the declaration has both qualifiers and attributes (which each go on a separate line) + // force exactly 2 spaces; this compromise will mean that the following declaration is always + // separated by exactly 1 empty line + let lnum = if meta_decl.has_qs && meta_decl.has_attrs then 2 else lnum in + + // if the module begins with a comment, force exactly 2 newlines between it and the following declaration + let lnum = if init then 2 else lnum in + + doc ^^ repeat lnum hardline + + +(* [separate_map_with_comments prefix sep f xs extract_meta] is the document *) +(* *) +(* prefix (f xs[0]) *) +(* comments[0] *) +(* sep (f xs[1]) *) +(* comments[1] *) +(* ... *) +(* sep (f xs[n]) *) +(* *) +(* where comments[_] are obtained by successive calls to [place_comments_until_pos] *) +(* using the range and metainformation provided by [extract_meta] and the comments in *) +(* [comment_stack]. [xs] must contain at least one element. There is no break *) +(* inserted after [prefix] and [sep]. *) +let separate_map_with_comments prefix sep f xs extract_meta = + let fold_fun (last_line, doc) x = + let meta_decl = extract_meta x in + let r = meta_decl.r in + let doc = place_comments_until_pos 1 last_line (start_of_range r) meta_decl doc false false in + line_of_pos (end_of_range r), doc ^^ sep ^^ f x + in + let x, xs = List.hd xs, List.tl xs in + let init = + let meta_decl = extract_meta x in + line_of_pos (end_of_range meta_decl.r), prefix ^^ f x + in + snd (List.fold_left fold_fun init xs) + +(* [separate_map_with_comments_kw prefix sep f xs extract_meta] is the same *) +(* as separate_map_with_comments but the keyword is also passed as an *) +(* argument to f, resulting in *) +(* *) +(* (f prefix xs[0]) *) +(* comments[0] *) +(* f spe xs[1]) *) +(* comments[1] *) +(* ... *) +(* (f sep xs[n]) *) +let separate_map_with_comments_kw prefix sep f xs extract_meta = + let fold_fun (last_line, doc) x = + let meta_decl = extract_meta x in + let r = meta_decl.r in + let doc = place_comments_until_pos 1 last_line (start_of_range r) meta_decl doc false false in + line_of_pos (end_of_range r), doc ^^ f sep x + in + let x, xs = List.hd xs, List.tl xs in + let init = + let meta_decl = extract_meta x in + line_of_pos (end_of_range meta_decl.r), f prefix x + in + snd (List.fold_left fold_fun init xs) + +let p_lidentOrOperator' l s_l p_l = + let lstr = s_l l in + if lstr `starts_with` "op_" then + match AST.string_to_op lstr with + | None -> + str "( " ^^ p_l l ^^ str " )" + | Some (s, _) -> + str "( " ^^ str s ^^ str " )" + else + p_l l + +(* ****************************************************************************) +(* *) +(* Printing identifiers and module paths *) +(* *) +(* ****************************************************************************) + +let string_of_id_or_underscore lid = + if starts_with (string_of_id lid) reserved_prefix && not (Options.print_real_names ()) + then underscore + else str (string_of_id lid) + +let text_of_lid_or_underscore lid = + if starts_with (string_of_id (ident_of_lid lid)) reserved_prefix && not (Options.print_real_names ()) + then underscore + else str (string_of_lid lid) + +let p_qlident lid = + text_of_lid_or_underscore lid + +let p_quident lid = + text_of_lid_or_underscore lid + +let p_ident lid = + string_of_id_or_underscore lid + +let p_lident lid = + string_of_id_or_underscore lid + +let p_uident lid = + string_of_id_or_underscore lid + +let p_tvar lid = + string_of_id_or_underscore lid + +let p_qlidentOrOperator lid = + p_lidentOrOperator' lid Ident.string_of_lid p_qlident + +let p_lidentOrOperator lid = + p_lidentOrOperator' lid Ident.string_of_id p_lident + + + +(* ****************************************************************************) +(* *) +(* Printing declarations *) +(* *) +(* ****************************************************************************) +let rec p_decl (d: decl): document = + let qualifiers= + (* Don't push 'assume' on a new line when it used as a keyword *) + match (d.quals, d.d) with + | ([Assumption], Assume(id, _)) -> + if char_at (string_of_id id) 0 |> is_upper then + p_qualifier Assumption ^^ space + else + p_qualifiers d.quals + | _ -> p_qualifiers d.quals + in + p_attributes true d.attrs ^^ + qualifiers ^^ + p_rawDecl d + +and p_attributes isTopLevel attrs = + match attrs with + | [] -> empty + | _ -> lbracket ^^ str (if isTopLevel then "@@ " else "@@@ ") ^^ + align ((flow (str "; ") (List.map (p_noSeqTermAndComment false false) attrs)) ^^ rbracket) ^^ (if isTopLevel then hardline else empty) + +and p_justSig d = match d.d with + | Val (lid, t) -> + (str "val" ^^ space ^^ p_lidentOrOperator lid ^^ space ^^ colon) ^^ p_typ false false t + | TopLevelLet (_, lbs) -> + separate_map hardline (fun lb -> group (p_letlhs (str "let") lb false)) lbs + | _ -> + empty + +and p_list #t (f: t -> _) sep l = + let rec p_list' = function + | [] -> empty + | [x] -> f x + | x::xs -> f x ^^ sep ^^ p_list' xs + in + str "[" ^^ p_list' l ^^ str "]" + +and p_restriction + = let open FStarC.Syntax.Syntax in + function | Unrestricted -> empty + | AllowList ids -> + space + ^^ lbrace + ^^ p_list (fun (id, renamed) -> + p_ident id ^/^ optional p_ident renamed + ) (str ", ") ids + ^^ rbrace + +and p_rawDecl d = match d.d with + | Open (uid, r) -> + group (str "open" ^/^ p_quident uid ^/^ p_restriction r) + | Include (uid, r) -> + group (str "include" ^/^ p_quident uid ^/^ p_restriction r) + | Friend uid -> + group (str "friend" ^/^ p_quident uid) + | ModuleAbbrev (uid1, uid2) -> + (str "module" ^^ space ^^ p_uident uid1 ^^ space ^^ equals) ^/+^ p_quident uid2 + | TopLevelModule uid -> + group(str "module" ^^ space ^^ p_quident uid) + | Tycon(true, _, [TyconAbbrev(uid, tpars, None, t)]) -> + let effect_prefix_doc = str "effect" ^^ space ^^ p_uident uid in + surround 2 1 effect_prefix_doc (p_typars tpars) equals ^/+^ p_typ false false t + | Tycon(false, tc, tcdefs) -> + let s = if tc then str "class" else str "type" in + (p_typeDeclWithKw s (List.hd tcdefs)) ^^ + (concat_map (fun x -> break1 ^^ p_typeDeclWithKw (str "and") x) <| List.tl tcdefs) + | TopLevelLet(q, lbs) -> + let let_doc = str "let" ^^ p_letqualifier q in + separate_map_with_comments_kw let_doc (str "and") p_letbinding lbs + (fun (p, t) -> + { r = Range.union_ranges p.prange t.range; + has_qs = false; + has_attrs = false; }) + | Val(lid, t) -> + group <| str "val" ^^ space ^^ p_lidentOrOperator lid ^^ (sig_as_binders_if_possible t false) + (* KM : not exactly sure which one of the cases below and above is used for 'assume val ..'*) + | Assume(id, t) -> + let decl_keyword = + if char_at (string_of_id id) 0 |> is_upper + then empty + else str "val" ^^ space + in + decl_keyword ^^ p_ident id ^^ group (colon ^^ space ^^ (p_typ false false t)) + | Exception(uid, t_opt) -> + str "exception" ^^ space ^^ p_uident uid ^^ optional (fun t -> break1 ^^ str "of" ^/+^ p_typ false false t) t_opt + | NewEffect(ne) -> + str "new_effect" ^^ space ^^ p_newEffect ne + | SubEffect(se) -> + str "sub_effect" ^^ space ^^ p_subEffect se + | LayeredEffect(ne) -> + str "layered_effect" ^^ space ^^ p_newEffect ne + | Polymonadic_bind (l1, l2, l3, t) -> + (str "polymonadic_bind") + ^^ lparen ^^ p_quident l1 ^^ comma ^^ break1 ^^ p_quident l2 ^^ rparen + ^^ (str "|>") ^^ p_quident l3 ^^ equals ^^ p_simpleTerm false false t + | Pragma p -> + p_pragma p + | Tycon(true, _, _) -> + failwith "Effect abbreviation is expected to be defined by an abbreviation" + | Splice (is_typed, ids, t) -> + str "%splice" ^^ + (if is_typed then str "_t" else empty) ^^ + p_list p_uident (str ";") ids ^^ space ^^ p_term false false t + | DeclSyntaxExtension (tag, blob, blob_rng, start_rng) -> + // NB: using ^^ since the blob also contains the newlines + doc_of_string ("```"^tag) ^^ + arbitrary_string blob ^^ + doc_of_string "```" + | DeclToBeDesugared tbs -> + arbitrary_string <| tbs.to_string tbs.blob + +and p_pragma = function + | ShowOptions -> str "#show-options" + | SetOptions s -> str "#set-options" ^^ space ^^ dquotes (str s) + | ResetOptions s_opt -> str "#reset-options" ^^ optional (fun s -> space ^^ dquotes (str s)) s_opt + | PushOptions s_opt -> str "#push-options" ^^ optional (fun s -> space ^^ dquotes (str s)) s_opt + | PopOptions -> str "#pop-options" + | RestartSolver -> str "#restart-solver" + | PrintEffectsGraph -> str "#print-effects-graph" + +(* TODO : needs to take the F# specific type instantiation *) +and p_typars (bs: list binder): document = p_binders true bs + +and p_typeDeclWithKw kw typedecl = + let comm, decl, body, pre = p_typeDecl kw typedecl in + if comm = empty then + decl ^^ pre body + else + group <| ifflat + (decl ^^ pre body ^/^ comm) + (decl ^^ nest 2 (hardline ^^ comm ^^ hardline ^^ body)) + +(* [p_typeDecl pre decl] takes a prefix and a declaration and returns a comment associated with the *) +(* declaration, the formatted declaration, its body, and a spacing function which should be applied to *) +(* the body in order to correctly space it from the declaration if there is no comment present or if *) +(* the comment can be inlined after the body *) +and p_typeDecl pre = function + | TyconAbstract (lid, bs, typ_opt) -> + empty, p_typeDeclPrefix pre false lid bs typ_opt, empty, id + | TyconAbbrev (lid, bs, typ_opt, t) -> + let comm, doc = p_typ_sep false false t in + comm, p_typeDeclPrefix pre true lid bs typ_opt, doc, jump2 + | TyconRecord (lid, bs, typ_opt, attrs, record_field_decls) -> + empty + , p_typeDeclPrefix pre true lid bs typ_opt + , p_attributes false attrs ^^ p_typeDeclRecord record_field_decls + , (fun d -> space ^^ d) + | TyconVariant (lid, bs, typ_opt, ct_decls) -> + let p_constructorBranchAndComments (uid, payload, attrs) = + let range = extend_to_end_of_line ( + dflt (range_of_id uid) + (bind_opt payload + (function | VpOfNotation t | VpArbitrary t -> Some t.range + | VpRecord (record, _) -> None))) in + let comm, ctor = with_comment_sep p_constructorBranch (uid, payload, attrs) range in + inline_comment_or_above comm ctor empty + in + (* Beware of side effects with comments printing *) + let datacon_doc = + separate_map hardline p_constructorBranchAndComments ct_decls + in + empty, p_typeDeclPrefix pre true lid bs typ_opt, datacon_doc, jump2 +and p_typeDeclRecord (fields: tycon_record): document = + let p_recordField (ps: bool) (lid, aq, attrs, t) = + let comm, field = + with_comment_sep (p_recordFieldDecl ps) (lid, aq, attrs, t) + (extend_to_end_of_line t.range) in + let sep = if ps then semi else empty in + inline_comment_or_above comm field sep + in + separate_map_last hardline p_recordField fields |> braces_with_nesting + +and p_typeDeclPrefix kw eq lid bs typ_opt = + let with_kw cont = + let lid_doc = p_ident lid in + let kw_lid = group (kw ^/^ lid_doc) in + cont kw_lid + in + let typ = + let maybe_eq = if eq then equals else empty in + match typ_opt with + | None -> maybe_eq + | Some t -> colon ^^ space ^^ (p_typ false false t) ^/^ maybe_eq + in + if bs = [] + then + with_kw (fun n -> prefix2 n typ) + else + let binders = p_binders_list true bs in + with_kw (fun n -> prefix2 (prefix2 n (flow break1 binders)) typ) + +and p_recordFieldDecl ps (lid, aq, attrs, t) = + group (optional p_aqual aq ^^ + p_attributes false attrs ^^ + p_lidentOrOperator lid ^^ + colon ^^ + p_typ ps false t) + +and p_constructorBranch (uid, variant, attrs) = + let h isOf t = (if isOf then str "of" else colon) ^^ space ^^ p_typ false false t + in group (bar ^^ space ^^ p_attributes false attrs ^^ p_uident uid) + ^^ default_or_map empty + (fun payload -> space ^^ group + ( match payload with + | VpOfNotation t -> h true t | VpArbitrary t -> h false t + | VpRecord (r, t) -> p_typeDeclRecord r ^^ default_or_map empty (h false) t + )) variant +and p_letlhs kw (pat, _) inner_let = + (* TODO : this should be refined when head is an applicative pattern (function definition) *) + let pat, ascr = + // if the let binding was written in arrow style, the arguments will be in t + // if it was written in binders style then they will be in pat + match pat.pat with + | PatAscribed (pat, (t, None)) -> pat, Some (t, empty) + | PatAscribed (pat, (t, Some tac)) -> pat, Some (t, group (space ^^ str "by" ^^ space ^^ p_atomicTerm (maybe_unthunk tac))) + | _ -> pat, None + in + match pat.pat with + | PatApp ({pat=PatVar (lid, _, _)}, pats) -> + (* has binders *) + let ascr_doc = + (match ascr with + | Some (t, tac) -> (sig_as_binders_if_possible t true) ^^ tac + | None -> empty) + in + let terms, style = + // VD: should we indent inner lets less? + if inner_let then + let bs, style = pats_as_binders_if_possible pats in + bs, style + else + let bs, style = pats_as_binders_if_possible pats in + bs, style + in + group <| kw ^^ space ^^ p_lidentOrOperator lid ^^ (format_sig style terms ascr_doc true true) + | _ -> + (* doesn't have binders *) + let ascr_doc = + (match ascr with + | Some (t, tac) -> group (colon ^^ p_typ_top (Arrows (2, 2)) false false t) ^^ tac + | None -> empty) + in + group (group (kw ^/^ p_tuplePattern pat) ^^ ascr_doc) + +and p_letbinding kw (pat, e) = + let doc_pat = p_letlhs kw (pat, e) false in + let comm, doc_expr = p_term_sep false false e in + let doc_expr = inline_comment_or_above comm doc_expr empty in + ifflat (doc_pat ^/^ equals ^/^ doc_expr) (doc_pat ^^ space ^^ group (equals ^^ jump2 doc_expr)) + +and p_term_list ps pb l = + let rec aux = function + | [] -> empty + | [x] -> p_term ps pb x + | x::xs -> p_term ps pb x ^^ str ";" ^^ aux xs + in + str "[" ^^ aux l ^^ str "]" + + +(* ****************************************************************************) +(* *) +(* Printing effects *) +(* *) +(* ****************************************************************************) + +and p_newEffect = function + | RedefineEffect (lid, bs, t) -> + p_effectRedefinition lid bs t + | DefineEffect (lid, bs, t, eff_decls) -> + p_effectDefinition lid bs t eff_decls + +and p_effectRedefinition uid bs t = + surround_maybe_empty 2 1 (p_uident uid) (p_binders true bs) (prefix2 equals (p_simpleTerm false false t)) + +and p_effectDefinition uid bs t eff_decls = + let binders = p_binders true bs in + braces_with_nesting ( + group (surround_maybe_empty 2 1 (p_uident uid) (p_binders true bs) (prefix2 colon (p_typ false false t))) ^/^ + (str "with") ^^ hardline ^^ space ^^ space ^^ (separate_map_last (hardline ^^ semi ^^ space) p_effectDecl eff_decls)) + +and p_effectDecl ps d = match d.d with + | Tycon(false, _, [TyconAbbrev(lid, [], None, e)]) -> + prefix2 (p_lident lid ^^ space ^^ equals) (p_simpleTerm ps false e) + | _ -> + failwith (Util.format1 "Not a declaration of an effect member... or at least I hope so : %s" + (show d)) + +and p_subEffect lift = + let lift_op_doc = + let lifts = + match lift.lift_op with + | NonReifiableLift t -> ["lift_wp", t] + | ReifiableLift (t1, t2) -> ["lift_wp", t1 ; "lift", t2] + | LiftForFree t -> ["lift", t] + in + let p_lift ps (kwd, t) = prefix2 (str kwd ^^ space ^^ equals) (p_simpleTerm ps false t) in + separate_break_map_last semi p_lift lifts + in + prefix2 (p_quident lift.msource ^^ space ^^ str "~>") (p_quident lift.mdest) ^^ + space ^^ braces_with_nesting lift_op_doc + + +(* ****************************************************************************) +(* *) +(* Printing qualifiers, tags *) +(* *) +(* ****************************************************************************) + +and p_qualifier = function + | Private -> str "private" + | Noeq -> str "noeq" + | Unopteq -> str "unopteq" + | Assumption -> str "assume" + | DefaultEffect -> str "default" + | TotalEffect -> str "total" + | Effect_qual -> empty + | New -> str "new" + | Inline -> str "inline" + | Visible -> empty + | Unfold_for_unification_and_vcgen -> str "unfold" + | Inline_for_extraction -> str "inline_for_extraction" + | Irreducible -> str "irreducible" + | NoExtract -> str "noextract" + | Reifiable -> str "reifiable" + | Reflectable -> str "reflectable" + | Opaque -> str "opaque" + | Logic -> str "logic" + +and p_qualifiers qs = + match qs with + | [] -> empty + | [q] -> (p_qualifier q) ^^ hardline + | _ -> flow break1 (List.map p_qualifier qs) ^^ hardline + +(* Skipping focus since it cannot be recoverred at printing *) + +and p_letqualifier = function + | Rec -> space ^^ str "rec" + | NoLetQualifier -> empty + +(* This prints both arg qualifiers and binder qualifiers. Note that Meta and +Typeclass do not make sense for arg qualifiers. *) +and p_aqual = function + | Implicit -> str "#" + | Equality -> str "$" + | Meta t -> + let t = + match t.tm with + | Abs (_ ,e) -> e + | _ -> mk_term (App (t, unit_const t.range, Nothing)) t.range Expr + in + str "#[" ^^ p_term false false t ^^ str "]" ^^ break1 + | TypeClassArg -> empty (* This is handled externally *) + +(* ****************************************************************************) +(* *) +(* Printing patterns and binders *) +(* *) +(* ****************************************************************************) + +and p_disjunctivePattern p = match p.pat with + | PatOr pats -> + group (separate_map (break1 ^^ bar ^^ space) p_tuplePattern pats) + | _ -> p_tuplePattern p + +and p_tuplePattern p = match p.pat with + | PatTuple (pats, false) -> + group (separate_map (comma ^^ break1) p_constructorPattern pats) + | _ -> + p_constructorPattern p + +and p_constructorPattern p = match p.pat with + | PatApp({pat=PatName maybe_cons_lid}, [hd ; tl]) when lid_equals maybe_cons_lid C.cons_lid -> + infix0 (colon ^^ colon) (p_constructorPattern hd) (p_constructorPattern tl) + | PatApp ({pat=PatName uid}, pats) -> + prefix2 (p_quident uid) (separate_map break1 p_atomicPattern pats) + | _ -> + p_atomicPattern p + +and p_atomicPattern p = match p.pat with + | PatAscribed (pat, (t, None)) -> + (* This inverts the first rule of atomicPattern (LPAREN tuplePattern COLON + * simpleArrow RPAREN). *) + begin match pat.pat, t.tm with + | PatVar (lid, aqual, attrs), Refine({b = Annotated(lid', t)}, phi) + when (string_of_id lid) = (string_of_id lid') -> + (* p_refinement jumps into p_appTerm for the annotated type; this is + * tighter than simpleArrow (which is what the parser uses), meaning that + * this printer may conservatively insert parentheses. TODO fix, but be + * aware that there are multiple callers to p_refinement and that + * p_appTerm is probably the lower bound of all expected levels. *) + soft_parens_with_nesting (p_refinement aqual attrs (p_ident lid) t phi) + | PatWild (aqual, attrs), Refine({b = NoName t}, phi) -> + soft_parens_with_nesting (p_refinement aqual attrs underscore t phi) + | PatVar (_, aqual, _), _ + | PatWild (aqual, _), _ -> + let wrap = + if aqual = Some TypeClassArg + then tc_arg + else soft_parens_with_nesting + in + wrap (p_tuplePattern pat ^^ colon ^/^ p_tmEqNoRefinement t) + | _ -> + (* TODO implement p_simpleArrow *) + soft_parens_with_nesting (p_tuplePattern pat ^^ colon ^/^ p_tmEqNoRefinement t) + end + | PatList pats -> + surround 2 0 lbracket (separate_break_map semi p_tuplePattern pats) rbracket + | PatRecord pats -> + let p_recordFieldPat (lid, pat) = infix2 equals (p_qlident lid) (p_tuplePattern pat) in + soft_braces_with_nesting (separate_break_map semi p_recordFieldPat pats) + | PatTuple(pats, true) -> + surround 2 1 (lparen ^^ bar) (separate_break_map comma p_constructorPattern pats) (bar ^^ rparen) + | PatTvar (tv, arg_qualifier_opt, attrs) -> + assert (arg_qualifier_opt = None) ; + assert (attrs = []); + p_tvar tv + | PatOp op -> + lparen ^^ space ^^ str (Ident.string_of_id op) ^^ space ^^ rparen + | PatWild (aqual, attrs) -> + optional p_aqual aqual ^^ p_attributes false attrs ^^ underscore + | PatConst c -> + p_constant c + | PatVQuote e -> group (str "`%" ^^ p_noSeqTermAndComment false false e) + | PatVar (lid, aqual, attrs) -> + optional p_aqual aqual ^^ p_attributes false attrs ^^ p_lident lid + | PatName uid -> + p_quident uid + | PatOr _ -> failwith "Inner or pattern !" + | PatApp ({pat = PatName _}, _) + | PatTuple (_, false) -> + soft_parens_with_nesting (p_tuplePattern p) + | _ -> failwith (Util.format1 "Invalid pattern %s" (pat_to_string p)) + +(* Skipping patternOrMultibinder since it would need retro-engineering the flattening of binders *) + +and is_typ_tuple e = match e.tm with + | Op(id, _) when string_of_id id = "*" -> true + | _ -> false + +and p_binder is_atomic b = + let is_tc = is_tc_binder b in + let b', t' = p_binder' false (is_atomic && not is_tc) b in + let d = + match t' with + | Some (typ, catf) -> catf b' typ + | None -> b' + in + if is_tc + then tc_arg d + else d + +(* is_atomic is true if the binder must be parsed atomically *) +// Returns: +// 1- a doc for binder +// 2- optionally: a doc for the type annotation (if any), and a function to concat it to the binder +// When the binder is nameless, the at +// This does NOT handle typeclass arguments. The wrapping is done from the outside. +and p_binder' (no_pars: bool) (is_atomic: bool) (b: binder): document & option (document & catf) = + match b.b with + | Variable lid -> optional p_aqual b.aqual ^^ p_attributes false b.battributes ^^ p_lident lid, None + | TVariable lid -> p_attributes false b.battributes ^^ p_lident lid, None + | Annotated (lid, t) -> + let b', t' = + match t.tm with + | Refine ({b = Annotated (lid', t)}, phi) when (string_of_id lid) = (string_of_id lid') -> + p_refinement' b.aqual b.battributes (p_lident lid) t phi + | _ -> + let t' = if is_typ_tuple t then + soft_parens_with_nesting (p_tmFormula t) + else + p_tmFormula t + in + optional p_aqual b.aqual ^^ p_attributes false b.battributes ^^ p_lident lid, t' + in + let catf = + if is_atomic || (is_meta_qualifier b.aqual && not no_pars) then + (fun x y -> group (lparen ^^ (cat_with_colon x y) ^^ rparen)) + else + (fun x y -> group (cat_with_colon x y)) + in + b', Some (t', catf) + | TAnnotated _ -> failwith "Is this still used ?" + | NoName t -> + begin match t.tm with + | Refine ({b = NoName t}, phi) -> + let b', t' = p_refinement' b.aqual b.battributes underscore t phi in + b', Some (t', cat_with_colon) + | _ -> + let pref = optional p_aqual b.aqual ^^ p_attributes false b.battributes in + let p_Tm = if is_atomic then p_atomicTerm else p_appTerm in + pref ^^ p_Tm t, None + end + +and p_refinement aqual_opt attrs binder t phi = + let b, typ = p_refinement' aqual_opt attrs binder t phi in + cat_with_colon b typ + +and p_refinement' aqual_opt attrs binder t phi = + let is_t_atomic = + match t.tm with + | Construct _ + | App _ + | Op _ -> false + | _ -> true + in + let comm, phi = p_noSeqTerm false false phi in + let phi = if comm = empty then phi else comm ^^ hardline ^^ phi in + (* If t is atomic, don't put a space between t and phi + * If t can be displayed on a single line, tightly surround it with braces, + * otherwise pad with a space. *) + let jump_break = if is_t_atomic then 0 else 1 in + (optional p_aqual aqual_opt ^^ p_attributes false attrs ^^ binder), + (p_appTerm t ^^ + (jump 2 jump_break (group ((ifflat + (soft_braces_with_nesting_tight phi) (soft_braces_with_nesting phi)))))) + +(* TODO : we may prefer to flow if there are more than 15 binders *) +(* Note: also skipping multiBinder here. *) +and p_binders_list (is_atomic: bool) (bs: list binder): list document = List.map (p_binder is_atomic) bs + +and p_binders (is_atomic: bool) (bs: list binder): document = separate_or_flow break1 (p_binders_list is_atomic bs) + +and p_binders_sep (bs: list binder): document = separate_map space (fun x -> x) (p_binders_list true bs) + + + +(* ****************************************************************************) +(* *) +(* Printing terms and types *) +(* *) +(* ****************************************************************************) + +(* The grammar has shift-reduce conflicts, meaning that the printer, in addition + * to following the structure of the parser, must have extra machinery. + * Shift-reduce conflicts arise from two situations: + * - e1; e2 where e1 ends with a greedy construct that swallows semicolons (for + * instance, MATCH, LET, an operator that ends with LARROW are greedy -- IF is + * not) + * - ... -> e1 | ... -> ... where e1 ends with a greedy construct that swallows + * bars (MATCH, TRY, FUNCTION); note that FUN is not a greedy construct in + * this context; also note that this does not apply to the last branch... + * + * To deal with this issue, we keep two flags in our series of recursive calls; + * "ps" (protect semicolons) and "pb" (protect branches). Whenever we enter a + * greedy construct, we wrap it with parentheses to make it non-greedy. + * + * This is convenient: at every call-site, we need to understand whether we need + * to prevent swallowing semicolons or not. For instance, in a record field, we + * do. *) + +and paren_if (b:bool) = + if b then + soft_parens_with_nesting + else + fun x -> x + +and inline_comment_or_above comm doc sep = + if comm = empty then + group (doc ^^ sep) + else + group <| ifflat (group (doc ^^ sep ^^ break1 ^^ comm)) (comm ^^ hardline ^^ doc ^^ sep) + +and p_term (ps:bool) (pb:bool) (e:term) = match e.tm with + | Seq (e1, e2) -> + (* Don't swallow semicolons on the left-hand side of a semicolon! Note: + * the `false` for pb is kind of useless because there is no construct + * that swallows branches but not semicolons (meaning ps implies pb). *) + let comm, t1 = p_noSeqTerm true false e1 in + (inline_comment_or_above comm t1 semi) ^^ hardline ^^ p_term ps pb e2 + + | Bind(x, e1, e2) -> + group ((p_lident x ^^ space ^^ long_left_arrow) ^/+^ + (p_noSeqTermAndComment true false e1 ^^ space ^^ semi)) ^/^ p_term ps pb e2 + | _ -> + group (p_noSeqTermAndComment ps pb e) + +and p_term_sep (ps:bool) (pb:bool) (e:term) = match e.tm with + | Seq (e1, e2) -> + (* Don't swallow semicolons on the left-hand side of a semicolon! Note: + * the `false` for pb is kind of useless because there is no construct + * that swallows branches but not semicolons (meaning ps implies pb). *) + let comm, t1 = p_noSeqTerm true false e1 in + comm, group (t1 ^^ semi) ^^ hardline ^^ p_term ps pb e2 + | Bind(x, e1, e2) -> + empty, group ((p_lident x ^^ space ^^ long_left_arrow) ^/+^ + (p_noSeqTermAndComment true false e1 ^^ space ^^ semi)) ^/^ p_term ps pb e2 + | _ -> + p_noSeqTerm ps pb e + +and p_noSeqTerm ps pb e = with_comment_sep (p_noSeqTerm' ps pb) e e.range + +and p_noSeqTermAndComment ps pb e = with_comment (p_noSeqTerm' ps pb) e e.range + +and p_noSeqTerm' ps pb e = match e.tm with + | Ascribed (e, t, None, use_eq) -> + group (p_tmIff e ^/^ (if use_eq then dollar else langle) ^^ colon ^/^ p_typ ps pb t) + | Ascribed (e, t, Some tac, use_eq) -> + group (p_tmIff e ^/^ (if use_eq then dollar else langle) ^^ colon ^/^ p_typ false false t ^/^ str "by" ^/^ p_typ ps pb (maybe_unthunk tac)) + | Op (id, [ e1; e2; e3 ]) when string_of_id id = ".()<-" -> + group ( + group (p_atomicTermNotQUident e1 ^^ dot ^^ soft_parens_with_nesting (p_term false false e2) + ^^ space ^^ larrow) ^^ jump2 (p_noSeqTermAndComment ps pb e3)) + | Op (id, [ e1; e2; e3 ]) when string_of_id id = ".[]<-" -> + group ( + group (p_atomicTermNotQUident e1 ^^ dot ^^ soft_brackets_with_nesting (p_term false false e2) + ^^ space ^^ larrow) ^^ jump2 (p_noSeqTermAndComment ps pb e3)) + | Op (id, [ e1; e2; e3 ]) when string_of_id id = ".(||)<-" -> + group ( + group (p_atomicTermNotQUident e1 ^^ dot ^^ soft_lens_access_with_nesting (p_term false false e2) + ^^ space ^^ larrow) ^^ jump2 (p_noSeqTermAndComment ps pb e3)) + | Op (id, [ e1; e2; e3 ]) when string_of_id id = ".[||]<-" -> + group ( + group (p_atomicTermNotQUident e1 ^^ dot ^^ soft_brackets_lens_access_with_nesting (p_term false false e2) + ^^ space ^^ larrow) ^^ jump2 (p_noSeqTermAndComment ps pb e3)) + | Requires (e, wtf) -> + assert (wtf = None); + group (str "requires" ^/^ p_typ ps pb e) + | Ensures (e, wtf) -> + assert (wtf = None); + group (str "ensures" ^/^ p_typ ps pb e) + | WFOrder (rel, e) -> + p_dec_wf ps pb rel e + | LexList l -> + group (str "%" ^^ p_term_list ps pb l) + | Decreases (e, wtf) -> + assert (wtf = None); + group (str "decreases" ^/^ p_typ ps pb e) + | Attributes es -> + group (str "attributes" ^/^ separate_map break1 p_atomicTerm es) + | If (e1, op_opt, ret_opt, e2, e3) -> + (* No need to wrap with parentheses here, since if e1 then e2; e3 really + * does parse as (if e1 then e2); e3 -- the IF does not swallow + * semicolons. We forward our caller's [ps] parameter, though, because + * something in [e2] may swallow. *) + if is_unit e3 + then group ((str ("if" ^ (dflt "" (op_opt `map_opt` string_of_id + `bind_opt` strip_prefix "let"))) + ^/+^ p_noSeqTermAndComment false false e1) ^/^ (str "then" ^/+^ p_noSeqTermAndComment ps pb e2)) + else + let e2_doc = + match e2.tm with + (* Not protecting, since an ELSE follows. *) + | If (_, _, _, _,e3) when is_unit e3 -> + (* Dangling else *) + soft_parens_with_nesting (p_noSeqTermAndComment false false e2) + | _ -> p_noSeqTermAndComment false false e2 + in + (match ret_opt with + | None -> + group ( + (str "if" ^/+^ p_noSeqTermAndComment false false e1) ^/^ + (str "then" ^/+^ e2_doc) ^/^ + (str "else" ^/+^ p_noSeqTermAndComment ps pb e3)) + | Some (as_opt, ret, use_eq) -> + group ( + (str "if" ^/+^ p_noSeqTermAndComment false false e1) ^/^ + ((match as_opt with + | None -> empty + | Some as_ident -> str "as" ^/^ p_ident as_ident) + ^/^ + (str (if use_eq then "returns$" else "returns") ^/+^ p_tmIff ret)) ^/^ + (str "then" ^/+^ e2_doc) ^/^ + (str "else" ^/+^ p_noSeqTermAndComment ps pb e3))) + | TryWith(e, branches) -> + paren_if (ps || pb) ( + group (prefix2 (str "try") (p_noSeqTermAndComment false false e) ^/^ str "with" ^/^ + separate_map_last hardline p_patternBranch branches)) + | Match (e, op_opt, ret_opt, branches) -> + let match_doc + = str ("match" ^ (dflt "" (op_opt `map_opt` string_of_id + `bind_opt` strip_prefix "let"))) in + paren_if (ps || pb) ( + (match ret_opt with + | None -> + group (surround 2 1 match_doc (p_noSeqTermAndComment false false e) (str "with")) + | Some (as_opt, ret, use_eq) -> + group (surround 2 1 match_doc + ((p_noSeqTermAndComment false false e) ^/+^ + (match as_opt with + | None -> empty + | Some as_ident -> str "as" ^/+^ (p_ident as_ident)) ^/+^ + (str (if use_eq then "returns$" else "returns") ^/+^ p_tmIff ret)) + (str "with"))) + + ^/^ + + separate_map_last hardline p_patternBranch branches) + | LetOpen (uid, e) -> + paren_if ps ( + group (surround 2 1 (str "let open") (p_quident uid) (str "in") ^/^ p_term false pb e) + ) + | LetOpenRecord (r, rty, e) -> + paren_if ps ( + group (surround 2 1 (str "let open") (p_term false pb r) (str "as") ^/^ (p_term false pb rty) + ^/^ str "in" ^/^ p_term false pb e) + ) + | LetOperator(lets, body) -> + let p_let (id, pat, e) is_last = + let doc_let_or_and = str (string_of_id id) in + let doc_pat = p_letlhs doc_let_or_and (pat, e) true in + match pat.pat, e.tm with + | PatVar (pid, _, _), Name tid + | PatVar (pid, _, _), Var tid + when string_of_id pid = List.last (path_of_lid tid) -> + doc_pat ^/^ (if is_last then str "in" else empty) + | _ -> + let comm, doc_expr = p_term_sep false false e in + let doc_expr = inline_comment_or_above comm doc_expr empty in + if is_last then + surround 2 1 (flow break1 [doc_pat; equals]) doc_expr (str "in") + else + hang 2 (flow break1 [doc_pat; equals; doc_expr]) + in + let l = List.length lets in + let lets_docs = List.mapi (fun i lb -> + group (p_let lb (i = l - 1)) + ) lets in + let lets_doc = group (separate break1 lets_docs) in + let r = paren_if ps (group (lets_doc ^^ hardline ^^ p_term false pb body)) in + r + | Let(q, lbs, e) -> + (* We wish to print let-bindings as follows. + * + * [@ attribute ] + * let x = foo + * and x = + * too long to fit on one line + * in + * ... *) + let p_lb q (a, (pat, e)) is_last = + let attrs = p_attrs_opt true a in + let doc_let_or_and = match q with + | Some Rec -> group (str "let" ^/^ str "rec") + | Some NoLetQualifier -> str "let" + | _ -> str "and" + in + let doc_pat = p_letlhs doc_let_or_and (pat, e) true in + let comm, doc_expr = p_term_sep false false e in + let doc_expr = inline_comment_or_above comm doc_expr empty in + attrs ^^ + (if is_last then + surround 2 1 (flow break1 [doc_pat; equals]) doc_expr (str "in") + else + hang 2 (flow break1 [doc_pat; equals; doc_expr])) + in + let l = List.length lbs in + let lbs_docs = List.mapi (fun i lb -> + if i = 0 then + group (p_lb (Some q) lb (i = l - 1)) + else + group (p_lb None lb (i = l - 1)) + ) lbs in + let lbs_doc = group (separate break1 lbs_docs) in + paren_if ps (group (lbs_doc ^^ hardline ^^ p_term false pb e)) + + | Quote (e, Dynamic) -> + group (str "quote" ^/^ p_noSeqTermAndComment ps pb e) + | Quote (e, Static) -> + group (str "`" ^^ p_noSeqTermAndComment ps pb e) + | VQuote e -> + group (str "`%" ^^ p_noSeqTermAndComment ps pb e) + | Antiquote ({ tm = Quote (e, Dynamic) }) -> + group (str "`@" ^^ p_noSeqTermAndComment ps pb e) + | Antiquote e -> + group (str "`#" ^^ p_noSeqTermAndComment ps pb e) + | CalcProof (rel, init, steps) -> + let head = str "calc" ^^ space ^^ p_noSeqTermAndComment false false rel ^^ space ^^ lbrace in + let bot = rbrace in + enclose head (hardline ^^ bot) + (nest 2 <| hardline + ^^ p_noSeqTermAndComment false false init ^^ str ";" ^^ hardline + ^^ separate_map_last hardline p_calcStep steps) + + | IntroForall (xs, p, e) -> + let p = p_noSeqTermAndComment false false p in + let e = p_noSeqTermAndComment false false e in + let xs = p_binders_sep xs in + str "introduce forall" ^^ space ^^ xs ^^ space ^^ str "." ^^ space ^^ p ^^ hardline ^^ + str "with" ^^ space ^^ e + + | IntroExists(xs, p, vs, e) -> + let p = p_noSeqTermAndComment false false p in + let e = p_noSeqTermAndComment false false e in + let xs = p_binders_sep xs in + str "introduce" ^^ space ^^ str "exists" ^^ space ^^ xs ^^ str "." ^^ p ^^ hardline ^^ + str "with" ^^ space ^^ (separate_map space p_atomicTerm vs) ^^ hardline ^^ + str "and" ^^ space ^^ e + + | IntroImplies(p, q, x, e) -> + let p = p_tmFormula p in + let q = p_tmFormula q in + let e = p_noSeqTermAndComment false false e in + let x = p_binders_sep [x] in + str "introduce" ^^ space ^^ + p ^^ space ^^ str "==>" ^^ space ^^ q ^^ hardline ^^ + str "with" ^^ space ^^ x ^^ str "." ^^ space ^^ e + + | IntroOr(b, p, q, e) -> + let p = p_tmFormula p in + let q = p_tmFormula q in + let e = p_noSeqTermAndComment false false e in + str "introduce" ^^ space ^^ + p ^^ space ^^ str "\/" ^^ space ^^ q ^^ hardline ^^ + str "with" ^^ space ^^ (if b then str "Left" else str "Right") ^^ space ^^ e + + | IntroAnd(p, q, e1, e2) -> + let p = p_tmFormula p in + let q = p_tmTuple q in + let e1 = p_noSeqTermAndComment false false e1 in + let e2 = p_noSeqTermAndComment false false e2 in + str "introduce" ^^ space ^^ + p ^^ space ^^ str "/\\" ^^ space ^^ q ^^ hardline ^^ + str "with" ^^ space ^^ e1 ^^ hardline ^^ + str "and" ^^ space ^^ e2 + + | ElimForall(xs, p, vs) -> + let xs = p_binders_sep xs in + let p = p_noSeqTermAndComment false false p in + let vs = separate_map space p_atomicTerm vs in + str "eliminate" ^^ space ^^ str "forall" ^^ space ^^ xs ^^ str "." ^^ space ^^ p ^^ hardline ^^ + str "with" ^^ space ^^ vs + + | ElimExists (bs, p, q, b, e) -> + let head = str "eliminate exists" ^^ space ^^ p_binders_sep bs ^^ str "." in + let p = p_noSeqTermAndComment false false p in + let q = p_noSeqTermAndComment false false q in + let e = p_noSeqTermAndComment false false e in + head ^^ hardline ^^ + p ^^ hardline ^^ + str "returns" ^^ space ^^ q ^^ hardline ^^ + str "with" ^^ space ^^ (p_binders_sep [b]) ^^ str "." ^^ hardline ^^ + e + + | ElimImplies(p, q, e) -> + let p = p_tmFormula p in + let q = p_tmFormula q in + let e = p_noSeqTermAndComment false false e in + str "eliminate" ^^ space ^^ p ^^ space ^^ str "==>" ^^ space ^^ q ^^ hardline ^^ + str "with" ^^ space ^^ e + + | ElimOr(p, q, r, x, e1, y, e2) -> + let p = p_tmFormula p in + let q = p_tmFormula q in + let r = p_noSeqTermAndComment false false r in + let x = p_binders_sep [x] in + let e1 = p_noSeqTermAndComment false false e1 in + let y = p_binders_sep [y] in + let e2 = p_noSeqTermAndComment false false e2 in + str "eliminate" ^^ space ^^ p ^^ space ^^ str "\\/" ^^ space ^^ q ^^ hardline ^^ + str "returns" ^^ space ^^ r ^^ hardline ^^ + str "with" ^^ space ^^ x ^^ space ^^ str "." ^^ space ^^ e1 ^^ hardline ^^ + str "and" ^^ space ^^ y ^^ space ^^ str "." ^^ space ^^ e2 + + | ElimAnd(p, q, r, x, y, e) -> + let p = p_tmFormula p in + let q = p_tmTuple q in + let r = p_noSeqTermAndComment false false r in + let xy = p_binders_sep [x; y] in + let e = p_noSeqTermAndComment false false e in + str "eliminate" ^^ space ^^ p ^^ space ^^ str "/\\" ^^ space ^^ q ^^ hardline ^^ + str "returns" ^^ space ^^ r ^^ hardline ^^ + str "with" ^^ space ^^ xy ^^ space ^^ str "." ^^ space ^^ e + + | _ -> p_typ ps pb e + +and p_dec_wf ps pb rel e = + group (str "{:well-founded " ^^ p_typ ps pb rel ^/^ p_typ ps pb e ^^ str " }") + + +and p_calcStep _ (CalcStep (rel, just, next)) = + group (p_noSeqTermAndComment false false rel ^^ space ^^ lbrace ^^ space ^^ p_noSeqTermAndComment false false just ^^ space ^^ rbrace ^^ hardline + ^^ p_noSeqTermAndComment false false next ^^ str ";") + +and p_attrs_opt (isTopLevel: bool) = function + | None -> empty + | Some terms -> + group (str (if isTopLevel then "[@@" else "[@@@") ^/^ + (separate_map (str "; ") + (p_noSeqTermAndComment false false) + terms) ^/^ + str "]") + +and p_typ ps pb e = with_comment (p_typ' ps pb) e e.range + +and p_typ_sep ps pb e = with_comment_sep (p_typ' ps pb) e e.range + +and p_typ' ps pb e = match e.tm with + | QForall (bs, (_, trigger), e1) + | QExists (bs, (_, trigger), e1) + | QuantOp (_, bs, (_, trigger), e1) -> + let binders_doc = p_binders true bs in + let term_doc = p_noSeqTermAndComment ps pb e1 in + //VD: We could dispense with this pattern matching if we removed trailing whitespace after the fact + (match trigger with + | [] -> + prefix2 + (soft_surround 2 0 (p_quantifier e ^^ space) binders_doc dot) term_doc + | pats -> + prefix2 (group (prefix2 + (soft_surround 2 0 (p_quantifier e ^^ space) binders_doc dot) + (p_trigger trigger))) term_doc) + | _ -> p_simpleTerm ps pb e + +and p_typ_top style ps pb e = with_comment (p_typ_top' style ps pb) e e.range + +and p_typ_top' style ps pb e = p_tmArrow style true p_tmFormula e + +and sig_as_binders_if_possible t extra_space = + let s = if extra_space then space else empty in + if all_binders_annot t then + (s ^^ p_typ_top (Binders (4, 0, true)) false false t) + else + group (colon ^^ s ^^ p_typ_top (Arrows (2, 2)) false false t) + +// Typeclass arguments are not collapsed. +and collapse_pats (pats: list (document & document & bool & bool)): list document = + let fold_fun (bs: list (list document & document & bool & bool)) (x: document & document & bool & bool) = + let b1, t1, tc1, j1 = x in + match bs with + | [] -> [([b1], t1, tc1, j1)] + | hd::tl -> + let b2s, t2, tc2, j2 = hd in + if t1 = t2 && j1 && j2 then + (b2s @ [b1], t1, false, true) :: tl + else + ([b1], t1, tc1, j1) :: hd :: tl + in + let p_collapsed_binder (cb: list document & document & bool & bool): document = + let bs, typ, istcarg, _ = cb in + let body = + match bs with + | [] -> failwith "Impossible" // can't have dangling type + | hd::tl -> cat_with_colon (List.fold_left (fun x y -> x ^^ space ^^ y) hd tl) typ + in + if istcarg + then tc_arg body + else soft_parens_with_nesting body + in + let binders = List.fold_left fold_fun [] (List.rev pats) in + map_rev p_collapsed_binder binders + +and pats_as_binders_if_possible pats : list document & annotation_style = + // returns: doc for name, doc for type, boolean if typeclass arg + let all_binders (p:pattern) : option (document & document & bool & bool) = + match p.pat with + | PatAscribed(pat, (t, None)) -> + (match pat.pat, t.tm with + | PatVar (lid, aqual, attrs), Refine({b = Annotated(lid', t)}, phi) + when (string_of_id lid) = (string_of_id lid') -> + let (x, y) = p_refinement' aqual attrs (p_ident lid) t phi in + Some (x, y, false, false) + | PatVar (lid, aqual, attrs), _ -> + let is_tc = aqual = Some TypeClassArg in + let is_meta = match aqual with | Some (Meta _) -> true | _ -> false in + Some (optional p_aqual aqual ^^ p_attributes false attrs ^^ p_ident lid, p_tmEqNoRefinement t, is_tc, not is_tc && not is_meta) + | _ -> None) + | _ -> None + in + match map_if_all all_binders pats with + | Some bs -> + collapse_pats bs, Binders (4, 0, true) + | None -> + List.map p_atomicPattern pats, Binders (4, 0, false) + +and p_quantifier e = match e.tm with + | QForall _ -> str "forall" + | QExists _ -> str "exists" + | QuantOp (i, _, _, _) -> p_ident i + | _ -> failwith "Imposible : p_quantifier called on a non-quantifier term" + +and p_trigger = function + | [] -> empty + | pats -> + group (lbrace ^^ colon ^^ str "pattern" ^/^ jump 2 0 (p_disjunctivePats pats) ^^ rbrace) + +and p_disjunctivePats pats = + separate_map (str "\\/") p_conjunctivePats pats + +and p_conjunctivePats pats = + group (separate_map (semi ^^ break1) p_appTerm pats) + +and p_simpleTerm ps pb e = match e.tm with + | Function(branches, _) -> + paren_if (ps || pb) ( + group (str "function" ^/^ separate_map_last hardline p_patternBranch branches)) + + | Abs(pats, e) -> + let comm, doc = p_term_sep false pb e in + let prefix = str "fun" ^/+^ separate_map break1 p_atomicPattern pats ^/^ rarrow in + paren_if ps ( + if comm <> empty then + prefix ^^ hardline ^^ comm ^^ hardline ^^ doc + else + group (prefix ^/+^ doc) + ) + | _ -> p_tmIff e + +and p_maybeFocusArrow b = + if b then str "~>" else rarrow + +(* slight modification here : a patternBranch always begins with a `|` *) +(* TODO : can we recover the focusing *) +and p_patternBranch pb (pat, when_opt, e) = + (* p_patternBranch is always called immediately underneath a paren_if; if ps + * was true, then we parenthesized and there's a closing parenthesis coming + * up, meaning we're not at risk of swallowing a semicolon; if ps was false, + * then we can recursively call p_term with false. *) + let one_pattern_branch p = + let branch = + match when_opt with + | None -> group (bar ^^ space ^^ (p_tuplePattern p) ^^ space ^^ rarrow) + | Some f -> + hang 2 (bar ^^ space ^^ (group ((p_tuplePattern p) ^/^ (str "when"))) ^/^ + (flow break1 [(p_tmFormula f); rarrow])) + in + let comm, doc = p_term_sep false pb e in + // we need to be careful here because an inlined comment on the last branch could eat + // any following parenthesis; to prevent this, we never inline a comment on the last branch + if pb then + if comm = empty then + group (branch ^/+^ doc) + else + group ( + ifflat + (group (branch ^/+^ doc ^^ break1 ^^ comm)) + (branch ^^ jump2 (inline_comment_or_above comm doc empty)) + ) + else + if comm <> empty then + branch ^/+^ (comm ^^ hardline ^^ doc) + else branch ^/+^ doc + in + match pat.pat with + | PatOr pats -> + (match List.rev pats with + | hd::tl -> + (* group the last pattern with the branch so, if possible, they are kept on the same line in case of the disjunctive + pattern group being broken *) + let last_pat_branch = one_pattern_branch hd in + group (bar ^^ space ^^ (separate_map (break1 ^^ bar ^^ space) p_tuplePattern (List.rev tl)) ^/^ last_pat_branch) + | [] -> failwith "Impossible: disjunctive pattern can't be empty") + | _ -> + one_pattern_branch pat + +(* Nothing underneath tmIff is at risk of swallowing a semicolon. *) +and p_tmIff e = match e.tm with + | Op(id, [e1;e2]) when string_of_id id = "<==>" -> + infix0 (str "<==>") (p_tmImplies e1) (p_tmIff e2) + | _ -> p_tmImplies e + +and p_tmImplies e = match e.tm with + | Op(id, [e1;e2]) when string_of_id id = "==>" -> + infix0 (str "==>") (p_tmArrow (Arrows (2, 2)) false p_tmFormula e1) (p_tmImplies e2) + | _ -> p_tmArrow (Arrows (2, 2)) false p_tmFormula e + +// This function is somewhat convoluted because it is used in a few +// different contexts and it is trying to properly indent for each of +// them. For signatures, it is trying to print the whole arrow on one +// line. If this fails, it tries to print everything except the +// computation type on the same line and push the computation type on a +// new line. If this fails, it prints every term on a separate line. A +// trailing space may sometimes be introduced, which we should trim. +// It also needs to make adjustments depending on which style a signature +// is to be printed in. For more details see the `annotation_style` type +// definition. +and format_sig style terms ret_d no_last_op flat_space = + let n, last_n, sep, last_op = + match style with + | Arrows (n, ln)-> + n, ln, space ^^ rarrow ^^ break1, rarrow ^^ space + | Binders (n, ln, parens) -> + n, ln, break1, colon ^^ space + in + let last_op = if List.length terms > 0 && (not no_last_op) then last_op else empty in + let one_line_space = if not (ret_d = empty) || not no_last_op then space else empty in + let single_line_arg_indent = repeat n space in + let fs = if flat_space then space else empty in + match List.length terms with + | 0 -> ret_d + | _ -> group (ifflat (fs ^^ (separate sep terms) ^^ one_line_space ^^ last_op ^^ ret_d) + (prefix n 1 (group ((ifflat (fs ^^ separate sep terms) + (jump2 ((single_line_arg_indent ^^ separate (sep ^^ single_line_arg_indent) (List.map (fun x -> align (hang 2 x)) terms))))))) + (align (hang last_n (last_op ^^ ret_d))))) + +and p_tmArrow style flat_space p_Tm e = + let terms, ret_d = + match style with + | Arrows _ -> p_tmArrow' p_Tm e + | Binders _ -> collapse_binders style p_Tm e + in + format_sig style terms ret_d false flat_space + +and p_tmArrow' p_Tm e : list document & document = + match e.tm with + | Product(bs, tgt) -> + let bs_ds = List.map (fun b -> p_binder false b) bs in + let bs_ds', ret = p_tmArrow' p_Tm tgt in + bs_ds@bs_ds', ret + | _ -> + ([], p_Tm e) + +// When printing in `Binders` style, collapse binders which have the same +// type, so instead of printing +// val f (a: t) (b: t) (c: t) : Tot nat +// print +// val f (a b c: t) : Tot nat +// For this, we use the generalised version of p_binder, which returns +// the binder, and optionally its type and a function which +// concatenates them. +and collapse_binders (style : annotation_style) (p_Tm: term -> document) (e: term): list document & document = + let atomize = match style with + | Binders (_, _, a) -> a + | _ -> false + in + let wrap is_tc doc = + if is_tc then tc_arg doc + else if atomize then soft_parens_with_nesting doc + else doc + in + // For each binder, return: + // - document for binder + // - optional annotation doc + cat function + // - whether it was a typeclass arg + // - whether it is joinable (tc args and meta args are not) + let rec accumulate_binders p_Tm e: list ((document & option (document & catf)) & bool & bool) & document = + match e.tm with + | Product(bs, tgt) -> + let bs_ds = List.map (fun b -> p_binder' true false b, is_tc_binder b, is_joinable_binder b) bs in + let bs_ds', ret = accumulate_binders p_Tm tgt in + bs_ds@bs_ds', ret + | _ -> ([], p_Tm e) + in + let fold_fun (bs: list (list document & option (document & catf) & bool & bool)) (x: (document & option (document & catf)) & bool & bool) = + let (b1, t1), tc1, j1 = x in + match bs with + | [] -> [([b1], t1, tc1, j1)] + | hd::tl -> + let b2s, t2, tc2, j2 = hd in + match (t1, t2) with + | Some (typ1, catf1), Some (typ2, _) + when typ1 = typ2 && j1 && j2 -> + (* If the `x` binder has the same type as the group that follows, + * and both are joinable (the group and the new binder), then join + * them. Take the cat function from x. NOTE: if they were joinable, + * then they are not tc-args, hence the false. *) + (b2s @ [b1], t1, false, true) :: tl + | _ -> + (* Otherwise just make a new group *) + ([b1], t1, tc1, j1) :: bs + in + let p_collapsed_binder (cb: list document & option (document & catf) & bool & bool): document = + let bs, t, is_tc, _ = cb in + match t with + | None -> begin + match bs with + | [b] -> wrap is_tc b + | _ -> failwith "Impossible" // can't have dangling type or collapse unannotated binders + end + | Some (typ, f) -> begin + match bs with + | [] -> failwith "Impossible" // can't have dangling type + | hd::tl -> wrap is_tc <| f (List.fold_left (fun x y -> x ^^ space ^^ y) hd tl) typ + end + in + let bs_ds, ret_d = accumulate_binders p_Tm e in + let binders = List.fold_left fold_fun [] bs_ds in + map_rev p_collapsed_binder binders, ret_d + +and p_tmFormula e = + let conj = space ^^ (str "/\\") ^^ break1 in + let disj = space ^^ (str "\\/") ^^ break1 in + let formula = p_tmDisjunction e in + flow_map disj (fun d -> flow_map conj (fun x -> group x) d) formula + +and p_tmDisjunction e = match e.tm with + | Op(id, [e1;e2]) when string_of_id id = "\\/" -> + (p_tmDisjunction e1) @ [p_tmConjunction e2] + | _ -> [p_tmConjunction e] + +and p_tmConjunction e = match e.tm with + | Op(id, [e1;e2]) when string_of_id id = "/\\" -> + (p_tmConjunction e1) @ [p_tmTuple e2] + | _ -> [p_tmTuple e] + +and p_tmTuple e = with_comment p_tmTuple' e e.range + +and p_tmTuple' e = match e.tm with + | Construct (lid, args) when is_tuple_constructor lid && all1_explicit args -> + separate_map (comma ^^ break1) (fun (e, _) -> p_tmEq e) args + | _ -> p_tmEq e + +and paren_if_gt curr mine doc = + if mine > curr then + group (lparen ^^ doc ^^ rparen) + else + doc + +and p_tmEqWith p_X e = + (* TODO : this should be precomputed but F* complains about a potential ML effect *) + let n = max_level ([colon_equals ; pipe_right] @ operatorInfix0ad12) in + p_tmEqWith' p_X n e + +and p_tmEqWith' p_X curr e = match e.tm with + (* We don't have any information to print `infix` aplication *) + | Op (op, [e1; e2]) when (* Implications and iffs are handled specially by the parser *) + not (Ident.string_of_id op = "==>" + || Ident.string_of_id op = "<==>") + && (is_operatorInfix0ad12 op + || Ident.string_of_id op = "=" + || Ident.string_of_id op = "|>") -> + let op = Ident.string_of_id op in + let left, mine, right = levels op in + paren_if_gt curr mine (infix0 (str <| op) (p_tmEqWith' p_X left e1) (p_tmEqWith' p_X right e2)) + | Op(id, [ e1; e2 ]) when string_of_id id = ":=" -> + group (p_tmEqWith p_X e1 ^^ space ^^ colon ^^ equals ^/+^ p_tmEqWith p_X e2) + | Op(id, [e]) when string_of_id id = "-" -> + let left, mine, right = levels "-" in + minus ^/^ p_tmEqWith' p_X mine e + | _ -> p_tmNoEqWith p_X e + +and p_tmNoEqWith p_X e = + (* TODO : this should be precomputed but F* complains about a potential ML effect *) + let n = max_level [colon_colon ; amp ; opinfix3 ; opinfix4] in + p_tmNoEqWith' false p_X n e + +and p_tmNoEqWith' inside_tuple p_X curr e = match e.tm with + | Construct (lid, [e1, _ ; e2, _]) when lid_equals lid C.cons_lid -> + let op = "::" in + let left, mine, right = levels op in + paren_if_gt curr mine (infix0 (str op) (p_tmNoEqWith' false p_X left e1) (p_tmNoEqWith' false p_X right e2)) + | Sum(binders, res) -> + let op = "&" in + let left, mine, right = levels op in + let p_dsumfst bt = + match bt with + | Inl b -> p_binder false b ^^ space ^^ str op ^^ break1 + | Inr t -> p_tmNoEqWith' false p_X left t ^^ space ^^ str op ^^ break1 + in + paren_if_gt curr mine (concat_map p_dsumfst binders ^^ p_tmNoEqWith' false p_X right res) + | Op (op, [e1; e2]) when is_operatorInfix34 op -> + let op = Ident.string_of_id op in + let left, mine, right = levels op in + paren_if_gt curr mine (infix0 (str op) (p_tmNoEqWith' false p_X left e1) (p_tmNoEqWith' false p_X right e2)) + | Record(with_opt, record_fields) -> + braces_with_nesting ( default_or_map empty p_with_clause with_opt ^^ + separate_map_last (semi ^^ break1) p_simpleDef record_fields ) + | Op(id, [e]) when string_of_id id = "~" -> + group (str "~" ^^ p_atomicTerm e) + | Paren p when inside_tuple -> + (match p.tm with + | Op(id, [e1; e2]) when string_of_id id = "*" -> + let op = "*" in + let left, mine, right = levels op in + paren_if_gt curr mine (infix0 (str op) (p_tmNoEqWith' true p_X left e1) (p_tmNoEqWith' true p_X right e2)) + | _ -> p_X e) + | _ -> p_X e + +and p_tmEqNoRefinement e = p_tmEqWith p_appTerm e + +and p_tmEq e = p_tmEqWith p_tmRefinement e + +and p_tmNoEq e = p_tmNoEqWith p_tmRefinement e + +and p_tmRefinement e = match e.tm with + | NamedTyp(lid, e) -> + group (p_lident lid ^/^ colon ^/^ p_appTerm e) + | Refine(b, phi) -> + p_refinedBinder b phi + | _ -> p_appTerm e + +and p_with_clause e = p_appTerm e ^^ space ^^ str "with" ^^ break1 + +and p_refinedBinder b phi = + match b.b with + | Annotated (lid, t) -> p_refinement b.aqual b.battributes (p_lident lid) t phi + | Variable lid -> p_refinement b.aqual b.battributes (p_lident lid) (mk_term Wild (range_of_id lid) Type_level) phi + | TAnnotated _ -> failwith "Is this still used ?" + | TVariable _ + | NoName _ -> + failwith (Util.format1 "Impossible: a refined binder ought to be annotated (%s)" (binder_to_string b)) + +(* A simple def can be followed by a ';'. Protect except for the last one. *) +and p_simpleDef ps (lid, e) = + group (p_qlidentOrOperator lid ^/^ equals ^/^ p_noSeqTermAndComment ps false e) + + +and p_appTerm e = match e.tm with + | App _ when is_general_application e -> + let head, args = head_and_args e in + (match args with + | [e1; e2] when snd e1 = Infix -> + p_argTerm e1 ^/^ group (str "`" ^^ (p_indexingTerm head) ^^ str "`") ^/^ p_argTerm e2 + | _ -> + let head_doc, args = p_indexingTerm head, args in + group (soft_surround_map_or_flow 2 0 head_doc (head_doc ^^ space) break1 empty p_argTerm args) + ) + + (* (explicit) tuples and dependent tuples are handled below *) + | Construct (lid, args) when is_general_construction e + && not (is_dtuple_constructor lid && all1_explicit args) + && not (is_tuple_constructor lid && all1_explicit args) -> + begin match args with + | [] -> p_quident lid + | [arg] -> group (p_quident lid ^/^ p_argTerm arg) + | hd::tl -> + group ( + group (prefix2 (p_quident lid) (p_argTerm hd)) ^^ + jump2 (separate_map break1 p_argTerm tl)) + end + | _ -> + p_indexingTerm e + +and p_argTerm arg_imp = match arg_imp with + | (u, UnivApp) -> p_universe u + | (e, FsTypApp) -> + (* This case should not happen since it might lead to badly formed type applications (e.g t a b)*) + Errors.log_issue e Errors.Warning_UnexpectedFsTypApp "Unexpected FsTypApp, output might not be formatted correctly."; + surround 2 1 langle (p_indexingTerm e) rangle + | (e, Hash) -> str "#" ^^ p_indexingTerm e + | (e, HashBrace t) -> str "#[" ^^ p_indexingTerm t ^^ str "]" ^^ p_indexingTerm e + | (e, Infix) + | (e, Nothing) -> p_indexingTerm e + + +and p_indexingTerm_aux exit e = match e.tm with + | Op(id, [e1 ; e2]) when string_of_id id = ".()" -> + group (p_indexingTerm_aux p_atomicTermNotQUident e1 ^^ dot ^^ + soft_parens_with_nesting (p_term false false e2)) + | Op(id, [e1; e2]) when string_of_id id = ".[]" -> + group (p_indexingTerm_aux p_atomicTermNotQUident e1 ^^ dot ^^ + soft_brackets_with_nesting (p_term false false e2)) + | Op(id, [e1; e2]) when string_of_id id = ".(||)" -> + group (p_indexingTerm_aux p_atomicTermNotQUident e1 ^^ dot ^^ + soft_lens_access_with_nesting (p_term false false e2)) + | Op(id, [e1; e2]) when string_of_id id = ".[||]" -> + group (p_indexingTerm_aux p_atomicTermNotQUident e1 ^^ dot ^^ + soft_brackets_lens_access_with_nesting (p_term false false e2)) + | _ -> + exit e +and p_indexingTerm e = p_indexingTerm_aux p_atomicTerm e + +(* p_atomicTermQUident is merged with p_atomicTerm *) +and p_atomicTerm e = match e.tm with + | LetOpen (lid, e) -> + (* The second form of let open which is atomic, because it's delimited + * with parentheses. *) + p_quident lid ^^ dot ^^ soft_parens_with_nesting (p_term false false e) + | Name lid -> + p_quident lid + | Construct (lid, []) when is_general_construction e -> + (* + * This case is needed to avoid extra parenthesis on applications + * where the argument is a constructor. cf. #2181. + *) + p_quident lid + | Op(op, [e]) when is_general_prefix_op op -> + str (Ident.string_of_id op) ^^ p_atomicTerm e + + | ListLiteral ts -> + surround 2 0 + lbracket + (separate_map_or_flow_last (semi ^^ break1) (fun ps -> p_noSeqTermAndComment ps false) ts) + rbracket + + | SeqLiteral ts -> + surround 2 0 + (doc_of_string "seq!" ^^ lbracket) + (separate_map_or_flow_last (semi ^^ break1) (fun ps -> p_noSeqTermAndComment ps false) ts) + rbracket + + | _ -> p_atomicTermNotQUident e + +and p_atomicTermNotQUident e = match e.tm with + | Wild -> underscore + | Var lid when lid_equals lid C.assert_lid -> str "assert" + | Var lid when lid_equals lid C.assume_lid -> str "assume" + | Tvar tv -> p_tvar tv + | Const c -> + begin match c with + | Const.Const_char x when x = '\n' -> + str "0x0Az" + | _ -> p_constant c + end + | Name lid when lid_equals lid C.true_lid -> + str "True" + | Name lid when lid_equals lid C.false_lid -> + str "False" + | Op(op, [e]) when is_general_prefix_op op -> + str (Ident.string_of_id op) ^^ p_atomicTermNotQUident e + | Op(op, []) -> + lparen ^^ space ^^ str (Ident.string_of_id op) ^^ space ^^ rparen + | Construct (lid, args) when is_dtuple_constructor lid && all1_explicit args -> + surround 2 1 (lparen ^^ bar) + (separate_map (comma ^^ break1) (fun (e, _) -> p_tmEq e) args) + (bar ^^ rparen) + | Construct (lid, args) when is_tuple_constructor lid && all1_explicit args -> + parens (p_tmTuple e) + | Project (e, lid) -> + group (prefix 2 0 (p_atomicTermNotQUident e) (dot ^^ p_qlident lid)) + | _ -> + p_projectionLHS e + (* BEGIN e END skipped *) + +and p_projectionLHS e = match e.tm with + | Var lid -> + p_qlident lid + (* fsType application skipped *) + | Projector (constr_lid, field_lid) -> + p_quident constr_lid ^^ qmark ^^ dot ^^ p_lident field_lid + | Discrim constr_lid -> + p_quident constr_lid ^^ qmark + | Paren e -> + (* Adding required parentheses for tuple disambiguation in ToSyntax.fs -- + * see comment in parse.mly *) + let comm, t = p_term_sep false false e in + let doc = soft_parens_with_nesting t in + if comm = empty then + doc + else + comm ^^ hardline ^^ doc + // | _ when is_array e -> + // let es = extract_from_list e in + // surround 2 0 (lbracket ^^ bar) (separate_map_or_flow_last (semi ^^ break1) (fun ps -> p_noSeqTermAndComment ps false) es) (bar ^^ rbracket) + | _ when is_ref_set e -> + let es = extract_from_ref_set e in + surround 2 0 (bang ^^ lbrace) (separate_map_or_flow (comma ^^ break1) p_appTerm es) rbrace + + (* KM : I still think that it is wrong to print a term that's not parseable... *) + (* VD: Not parsable, but it can be called with a Labeled term via term_to_string *) + | Labeled (e, s, b) -> + str ("(*" ^ s ^ "*)") ^/^ p_term false false e + + (* Failure cases : these cases are not handled in the printing grammar since *) + (* they are considered as invalid AST. We try to fail as soon as possible in order *) + (* to prevent the pretty printer from looping *) + | Op (op, args) when not (handleable_op op args) -> + failwith ("Operation " ^ Ident.string_of_id op ^ " with " ^ string_of_int (List.length args) ^ + " arguments couldn't be handled by the pretty printer") + | Uvar id -> + failwith "Unexpected universe variable out of universe context" + + (* All the cases are explicitly listed below so that a modification of the ast doesn't lead to a loop *) + (* We must also make sure that all the constructors listed below are handled somewhere *) + | Wild (* p_atomicTermNotQUident *) + | Const _ (* p_atomicTermNotQUident *) + | Op _ (* All handleable cases should be caught in the recursion loop *) + | Tvar _ (* p_atomicTermNotQUident *) + | Var _ (* p_projectionLHS *) + | Name _ (* p_atomicTerm *) + | Construct _ (* p_atomicTerm and p_appTerm *) + | Abs _ (* p_simpleTerm *) + | App _ (* p_appTerm *) + | Let _ (* p_noSeqTerm *) + | LetOperator _ (* p_noSeqTerm *) + | LetOpen _ (* p_noSeqTerm *) + | LetOpenRecord _ (* p_noSeqTerm *) + | Seq _ (* p_term *) + | Bind _ (* p_term *) + | If _ (* p_noSeqTerm *) + | Match _ (* p_noSeqTerm *) + | TryWith _ (* p_noSeqTerm *) + | Ascribed _ (* p_noSeqTerm *) + | Record _ (* p_termNoEq *) + | Project _ (* p_atomicTermNotQUident *) + | Product _ (* p_tmArrow *) + | Sum _ (* p_tmNoEq *) + | QForall _ (* p_typ *) + | QExists _ (* p_typ *) + | QuantOp _ + | Refine _ (* p_tmNoEq *) + | NamedTyp _ (* p_tmNoEq *) + | Requires _ (* p_noSeqTerm *) + | Ensures _ (* p_noSeqTerm *) + | Decreases _ (* p_noSeqTerm *) + | Attributes _(* p_noSeqTerm *) + | Quote _ (* p_noSeqTerm *) + | VQuote _ (* p_noSeqTerm *) + | Antiquote _ (* p_noSeqTerm *) + | CalcProof _ (* p_noSeqTerm *) + | ListLiteral _ + | SeqLiteral _ + | ElimExists _ + -> soft_parens_with_nesting (p_term false false e) + | LexList l -> group (str "%" ^^ p_term_list false false l) + | WFOrder (rel, e) -> + p_dec_wf false false rel e + +and p_constant = function + | Const_effect -> str "Effect" + | Const_unit -> str "()" + | Const_bool b -> doc_of_bool b + | Const_real r -> str (r ^"R") + | Const_char x -> doc_of_char x + | Const_string(s, _) -> dquotes (str (FStarC.Compiler.String.escaped s)) + | Const_int (repr, sign_width_opt) -> + let signedness = function + | Unsigned -> str "u" + | Signed -> empty + in + let width = function + | Int8 -> str "y" + | Int16 -> str "s" + | Int32 -> str "l" + | Int64 -> str "L" + in + let suffix (s, w) = + (* This handles the Sizet case, which is unsigned but + * does not have a "u" suffix. *) + match (s, w) with + | _, Sizet -> str "sz" + | _ -> signedness s ^^ width w + in + let ending = default_or_map empty suffix sign_width_opt in + str repr ^^ ending + | Const_range_of -> str "range_of" + | Const_set_range_of -> str "set_range_of" + | Const_range r -> str (Range.string_of_range r) + | Const_reify _ -> str "reify" + | Const_reflect lid -> p_quident lid ^^ qmark ^^ dot ^^ str "reflect" + +and p_universe u = str "u#" ^^ p_atomicUniverse u + +and p_universeFrom u = match u.tm with + | Op(id, [u1 ; u2]) when string_of_id id = "+" -> + group (p_universeFrom u1 ^/^ plus ^/^ p_universeFrom u2) + | App _ -> + let head, args = head_and_args u in + begin match head.tm with + | Var maybe_max_lid when lid_equals maybe_max_lid C.max_lid -> + group (p_qlident C.max_lid ^/+^ + separate_map space (fun (u,_) -> p_atomicUniverse u) args) + | _ -> + (* TODO : refine the failwiths with informations *) + failwith (Util.format1 ("Invalid term in universe context %s") (term_to_string u)) + end + | _ -> p_atomicUniverse u + +and p_atomicUniverse u = match u.tm with + | Wild -> underscore + | Const (Const_int (r, sw)) -> p_constant (Const_int (r, sw)) + | Uvar id -> str (string_of_id id) + | Paren u -> soft_parens_with_nesting (p_universeFrom u) + | App _ -> soft_parens_with_nesting (p_universeFrom u) + | Op(id, [_ ; _]) when string_of_id id = "+" -> soft_parens_with_nesting (p_universeFrom u) + | _ -> failwith (Util.format1 "Invalid term in universe context %s" (term_to_string u)) + +let term_to_document e = + p_term false false e + +let signature_to_document e = p_justSig e + +let decl_to_document e = p_decl e + +let pat_to_document p = p_disjunctivePattern p + +let binder_to_document b = p_binder true b + +let modul_to_document (m:modul) = + match m with + | Module (_, decls) + | Interface (_, decls, _) -> + decls |> List.map decl_to_document |> separate hardline + +let comments_to_document (comments : list (string & FStarC.Compiler.Range.range)) = + separate_map hardline (fun (comment, range) -> str comment) comments + +let extract_decl_range (d: decl): decl_meta = + (* take newline for qualifiers into account *) + let has_qs = + match (d.quals, d.d) with + | ([Assumption], Assume(id, _)) -> false + | ([], _) -> false + | _ -> true + in + { r = d.drange; + has_qs = has_qs; + has_attrs = not (List.isEmpty d.attrs); } + +let decls_with_comments_to_document (decls:list decl) comments = + match decls with + | [] -> empty, comments + | d :: ds -> + let decls, first_range = d :: ds, d.drange in + comment_stack := comments ; + let initial_comment = place_comments_until_pos 0 1 (start_of_range first_range) dummy_meta empty false true in + let doc = separate_map_with_comments empty empty p_decl decls extract_decl_range in + let comments = !comment_stack in + comment_stack := [] ; + (initial_comment ^^ doc, comments) + +(* [modul_with_comments_to_document m comments] prints the module [m] trying *) +(* to insert the comments from [comments]. The list comments is composed of *) +(* pairs of a raw string and a position which is used to place the comment *) +(* not too far from its original position. The rules for placing comments *) +(* are described in the ``Taking care of comments`` section *) +let modul_with_comments_to_document (m:modul) comments = + let decls = match m with + | Module (_, decls) + | Interface (_, decls, _) -> decls + in + decls_with_comments_to_document decls comments + +let decl_with_comments_to_document (d:decl) comments = + decls_with_comments_to_document [d] comments diff --git a/src/parser/FStarC.Parser.ToDocument.fsti b/src/parser/FStarC.Parser.ToDocument.fsti new file mode 100644 index 00000000000..42f64da6889 --- /dev/null +++ b/src/parser/FStarC.Parser.ToDocument.fsti @@ -0,0 +1,30 @@ +(* + Copyright 2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +(** Convert Parser.Ast to Pprint.document for prettyprinting. *) +module FStarC.Parser.ToDocument +open FStarC.Compiler.Effect + +val term_to_document : FStarC.Parser.AST.term -> FStarC.Pprint.document +val decl_to_document : FStarC.Parser.AST.decl -> FStarC.Pprint.document +val signature_to_document : FStarC.Parser.AST.decl -> FStarC.Pprint.document +val pat_to_document : FStarC.Parser.AST.pattern -> FStarC.Pprint.document +val binder_to_document : FStarC.Parser.AST.binder -> FStarC.Pprint.document +val modul_to_document : FStarC.Parser.AST.modul -> FStarC.Pprint.document +val comments_to_document : list (string & FStarC.Compiler.Range.range) -> FStarC.Pprint.document +val modul_with_comments_to_document : FStarC.Parser.AST.modul -> list (string & FStarC.Compiler.Range.range) -> FStarC.Pprint.document & list (string & FStarC.Compiler.Range.range) +val handleable_args_length : FStarC.Ident.ident -> int +val decl_with_comments_to_document : FStarC.Parser.AST.decl -> list (string & FStarC.Compiler.Range.range) -> FStarC.Pprint.document & list (string & FStarC.Compiler.Range.range) \ No newline at end of file diff --git a/src/parser/README b/src/parser/README index 2516f3556dc..be87da38e0b 100644 --- a/src/parser/README +++ b/src/parser/README @@ -7,7 +7,7 @@ FSTAR_HOME/ocaml/fstar-lib/FStar_Parser_Parse.mly To call into the parser from F*, we have a wrapper written in OCaml with an F* interface: -* FStar.Parser.ParseIt.fsti: This is the F* interface +* FStarC.Parser.ParseIt.fsti: This is the F* interface * FSTAR_HOME/ocaml/fstar-lib/FStar_Parser_ParseIt.ml: This is its implementation @@ -29,7 +29,7 @@ FSTAR_HOME/ocaml/fstar-lib/FStar_SedLexing.ml If you want to modify the parser, you need a recent version of menhir (at least december 2016). Also the printer in -[src/parser/FStar.Parser.ToDocument.fs] should be kept up to date with +[src/parser/FStarC.Parser.ToDocument.fs] should be kept up to date with the parser as much as possible since it tries to keep the same general structure as the parser. diff --git a/src/prettyprint/FStar.Pprint.fsti b/src/prettyprint/FStar.Pprint.fsti deleted file mode 100644 index a2f9c71da42..00000000000 --- a/src/prettyprint/FStar.Pprint.fsti +++ /dev/null @@ -1,386 +0,0 @@ -(* - Copyright 2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Pprint -open FStar.Compiler.Effect -open FStar.BaseTypes - -(** A pretty-printing engine and a set of basic document combinators. *) - -(** {1 Building documents} *) - -(** Documents must be built in memory before they are rendered. This may seem - costly, but it is a simple approach, and works well. *) - -(** The following operations form a set of basic (low-level) combinators for - building documents. On top of these combinators, higher-level combinators - can be defined: see {!PPrintCombinators}. *) - -(** This is the abstract type of documents. *) -type document - -(** The following basic (low-level) combinators allow constructing documents. *) - -(** [empty] is the empty document. *) -val empty: document - -(** [doc_of_char c] is a document that consists of the single character [c]. This - character must not be a newline. *) -val doc_of_char: FStar.Char.char -> document - -(** [doc_of_string s] is a document that consists of the string [s]. This string must - not contain a newline. *) -val doc_of_string: string -> document - -(** [doc_of_bool b] is a document that consists of the boolean [b]. *) -val doc_of_bool: bool -> document - -(** [substring s ofs len] is a document that consists of the portion of the - string [s] delimited by the offset [ofs] and the length [len]. This - portion must contain a newline. *) -val substring: string -> int -> int -> document - -(** [fancystring s apparent_length] is a document that consists of the string - [s]. This string must not contain a newline. The string may contain fancy - characters: color escape characters, UTF-8 or multi-byte characters, - etc. Thus, its apparent length (which measures how many columns the text - will take up on screen) differs from its length in bytes. *) -val fancystring: string -> int -> document - -(** [fancysubstring s ofs len apparent_length] is a document that consists of - the portion of the string [s] delimited by the offset [ofs] and the length - [len]. This portion must not contain a newline. The string may contain fancy - characters. *) -val fancysubstring : string -> int -> int -> int -> document - -(** [utf8string s] is a document that consists of the UTF-8-encoded string [s]. - This string must not contain a newline. *) -val utf8string: string -> document - -(** [hardline] is a forced newline document. This document forces all enclosing - groups to be printed in non-flattening mode. In other words, any enclosing - groups are dissolved. *) -val hardline: document - -(** [blank n] is a document that consists of [n] blank characters. *) -val blank: int -> document - -(** [break_ n] is a document which consists of either [n] blank characters, - when forced to display on a single line, or a single newline character, - otherwise. Note that there is no choice at this point: choices are encoded - by the [group] combinator. *) -val break_: int -> document - -(** [doc1 ^^ doc2] is the concatenation of the documents [doc1] and [doc2]. *) -val ( ^^ ) : document -> document -> document -(** [x ^/^ y] separates x and y with a breakable space. It is a short-hand for - [x ^^ break 1 ^^ y] *) -val ( ^/^ ) : document -> document -> document - -(** [nest j doc] is the document [doc], in which the indentation level has - been increased by [j], that is, in which [j] blanks have been inserted - after every newline character. Read this again: indentation is inserted - after every newline character. No indentation is inserted at the beginning - of the document. *) -val nest: int -> document -> document - -(** [group doc] encodes a choice. If possible, then the entire document [group - doc] is rendered on a single line. Otherwise, the group is dissolved, and - [doc] is rendered. There might be further groups within [doc], whose - presence will lead to further choices being explored. *) -val group: document -> document - -// (** [column f] is the document obtained by applying the function [f] to the -// current column number. This combinator allows making the construction of -// a document dependent on the current column number. *) -// val column: (int -> document) -> document - -// (** [nesting f] is the document obtained by applying the function [f] to the -// current indentation level, that is, the number of indentation (blank) -// characters that were inserted at the beginning of the current line. *) -// val nesting: (int -> document) -> document - -// (** [position f] is the document obtained by applying the function [f] -// to the current position in the rendered output. The position -// consists of [bol], which is the character-offset of the beginnig -// of the current line (starting at 0), [line], which is the current -// line (starting at 1), and [column], which is the current column -// (starting at 0). The current character-offset is always given by -// [bol + column]. *) -// val position : (int -> int -> int -> document) -> document - -(** [ifflat doc1 doc2] is rendered as [doc1] if part of a group that can be - successfully flattened, and is rendered as [doc2] otherwise. Use this - operation with caution. Because the pretty-printer is free to choose - between [doc1] and [doc2], these documents should be semantically - equivalent. *) -val ifflat: document -> document -> document - -// SI: purposely commented-out for now. -// (** {1 Rendering documents} *) -// -// (** This renderer sends its output into an output channel. *) -// module ToChannel : PPrintRenderer.RENDERER -// with type channel = out_channel -// and type document = document -// -// (** This renderer sends its output into a memory buffer. *) -// module ToBuffer : PPrintRenderer.RENDERER -// with type channel = Buffer.t -// and type document = document -// -// (** This renderer sends its output into a formatter channel. *) -// module ToFormatter : PPrintRenderer.RENDERER -// with type channel = Format.formatter -// and type document = document - - -(** A set of high-level combinators for building documents. *) - -(** {1 Single characters} *) - -(** The following constant documents consist of a single character. *) - -val lparen: document -val rparen: document -val langle: document -val rangle: document -val lbrace: document -val rbrace: document -val lbracket: document -val rbracket: document -val squote: document -val dquote: document -val bquote: document -val semi: document -val colon: document -val comma: document -val space: document -val dot: document -val sharp: document -val slash: document -val backslash: document -val equals: document -val qmark: document -val tilde: document -val at: document -val percent: document -val dollar: document -val caret: document -val ampersand: document -val star: document -val plus: document -val minus: document -val underscore: document -val bang: document -val bar: document -val rarrow: document -val long_left_arrow: document -val larrow: document - -(** {1 Delimiters} *) - -(** [precede l x] is [l ^^ x]. *) -val precede: document -> document -> document - -(** [terminate r x] is [x ^^ r]. *) -val terminate: document -> document -> document - -(** [enclose l r x] is [l ^^ x ^^ r]. *) -val enclose: document -> document -> document -> document - -(** The following combinators enclose a document within a pair of delimiters. - They are partial applications of [enclose]. No whitespace or line break is - introduced. *) - -val squotes: document -> document -val dquotes: document -> document -val bquotes: document -> document -val braces: document -> document -val parens: document -> document -val angles: document -> document -val brackets: document -> document - -(** {1 Repetition} *) - -(** [twice doc] is the document obtained by concatenating two copies of - the document [doc]. *) -val twice: document -> document - -(** [repeat n doc] is the document obtained by concatenating [n] copies of - the document [doc]. *) -val repeat: int -> document -> document - -(** {1 Lists and options} *) - -(** [concat docs] is the concatenation of the documents in the list [docs] (with ^^). *) -val concat: list document -> document - -(** [separate sep docs] is the concatenation of the documents in the list - [docs]. The separator [sep] is inserted between every two adjacent - documents. *) -val separate: document -> list document -> document - -(** [concat_map f xs] is equivalent to [concat (List.map f xs)]. *) -val concat_map: ('a -> document) -> list 'a -> document - -(** [separate_map sep f xs] is equivalent to [separate sep (List.map f xs)]. *) -val separate_map: document -> ('a -> document) -> list 'a -> document - -(** [separate2 sep last_sep docs] is the concatenation of the documents in the - list [docs]. The separator [sep] is inserted between every two adjacent - documents, except between the last two documents, where the separator - [last_sep] is used instead. *) -val separate2: document -> document -> list document -> document - -(** [optional f None] is the empty document. [optional f (Some x)] is - the document [f x]. *) -val optional: ('a -> document) -> option 'a -> document - -(** {1 Text} *) - -(** [lines s] is the list of documents obtained by splitting [s] at newline - characters, and turning each line into a document via [substring]. This - code is not UTF-8 aware. *) -val lines: string -> list document - -(** [arbitrary_string s] is equivalent to [separate (break 1) (lines s)]. - It is analogous to [string s], but is valid even if the string [s] - contains newline characters. *) -val arbitrary_string: string -> document - -(** [words s] is the list of documents obtained by splitting [s] at whitespace - characters, and turning each word into a document via [substring]. All - whitespace is discarded. This code is not UTF-8 aware. *) -val words: string -> list document - -(** [split ok s] splits the string [s] before and after every occurrence of a - character that satisfies the predicate [ok]. The substrings thus obtained - are turned into documents, and a list of documents is returned. No - information is lost: the concatenation of the documents yields the - original string. This code is not UTF-8 aware. *) -val split: (FStar.Char.char -> bool) -> string -> list document - -(** [flow sep docs] separates the documents in the list [docs] with the - separator [sep] and arranges for a new line to begin whenever a document - does not fit on the current line. This is useful for typesetting - free-flowing, ragged-right text. A typical choice of [sep] is [break b], - where [b] is the number of spaces that must be inserted between two - consecutive words (when displayed on the same line). *) -val flow: document -> list document -> document - -(** [flow_map sep f docs] is equivalent to [flow sep (List.map f docs)]. *) -val flow_map: document -> ('a -> document) -> list 'a -> document - -(** [url s] is a possible way of displaying the URL [s]. A potential line - break is inserted immediately before and immediately after every slash - and dot character. *) -val url: string -> document - -(** {1 Alignment and indentation} *) - -(** [align doc] increases the indentation level to reach the current - column. Thus, this document will be rendered within a box whose - upper left corner is the current position. *) -val align: document -> document - -(* [hang n doc] is analogous to [align], but additionally indents - all lines, except the first one, by [n]. Thus, the text in the - box forms a hanging indent. *) -val hang: int -> document -> document - -(** [prefix n b left right] has the following flat layout: {[ -left right -]} -and the following non-flat layout: -{[ -left - right -]} -The parameter [n] controls the nesting of [right] (when not flat). -The parameter [b] controls the number of spaces between [left] and [right] -(when flat). - *) -val prefix: int -> int -> document -> document -> document - -(** [jump n b right] is equivalent to [prefix n b empty right]. *) -val jump: int -> int -> document -> document - -(** [infix n b middle left right] has the following flat layout: {[ -left middle right -]} -and the following non-flat layout: {[ -left middle - right -]} -The parameter [n] controls the nesting of [right] (when not flat). -The parameter [b] controls the number of spaces between [left] and [middle] -(always) and between [middle] and [right] (when flat). -*) -val infix: int -> int -> document -> document -> document -> document - -(** [surround n b opening contents closing] has the following flat layout: {[ -opening contents closing -]} -and the following non-flat layout: {[ -opening - contents -closing -]} -The parameter [n] controls the nesting of [contents] (when not flat). -The parameter [b] controls the number of spaces between [opening] and [contents] -and between [contents] and [closing] (when flat). -*) -val surround: int -> int -> document -> document -> document -> document - -(** [soft_surround] is analogous to [surround], but involves more than one - group, so it offers possibilities other than the completely flat layout - (where [opening], [contents], and [closing] appear on a single line) and - the completely developed layout (where [opening], [contents], and - [closing] appear on separate lines). It tries to place the beginning of - [contents] on the same line as [opening], and to place [closing] on the - same line as the end of [contents], if possible. -*) -val soft_surround: int -> int -> document -> document -> document -> document - -(** [surround_separate n b void opening sep closing docs] is equivalent to - [surround n b opening (separate sep docs) closing], except when the - list [docs] is empty, in which case it reduces to [void]. *) -val surround_separate: int -> int -> document -> document -> document -> document -> list document -> document - -(** [surround_separate_map n b void opening sep closing f xs] is equivalent to - [surround_separate n b void opening sep closing (List.map f xs)]. *) -val surround_separate_map: int -> int -> document -> document -> document -> document -> ('a -> document) -> list 'a -> document - -(** {1 Short-hands} *) - - -//(** [!^s] is a short-hand for [string s]. *) -// val ( !^ ) : string -> document - -(** [x ^/^ y] separates [x] and [y] with a breakable space. - It is a short-hand for [x ^^ break 1 ^^ y]. *) - -(** [x ^//^ y] is a short-hand for [prefix 2 1 x y]. *) -// val ( ^//^ ) : document -> document -> document - -// Expose underlying Renderer.pretty implementations (avoid inner modules). -// [pretty_string] uses ToBuffer:RENDERER implementation; -// [print_out_channel] uses the ToChannel:RENDERER one. -val pretty_string : float -> int -> document -> string -val pretty_out_channel : float -> int -> document -> FStar.Compiler.Util.out_channel -> unit - -(* Simple renderer, defined as [pretty_string 1.0 80] *) -val render : document -> string diff --git a/src/prettyprint/FStarC.Pprint.fsti b/src/prettyprint/FStarC.Pprint.fsti new file mode 100644 index 00000000000..eae67c58ef1 --- /dev/null +++ b/src/prettyprint/FStarC.Pprint.fsti @@ -0,0 +1,386 @@ +(* + Copyright 2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Pprint +open FStarC.Compiler.Effect +open FStarC.BaseTypes + +(** A pretty-printing engine and a set of basic document combinators. *) + +(** {1 Building documents} *) + +(** Documents must be built in memory before they are rendered. This may seem + costly, but it is a simple approach, and works well. *) + +(** The following operations form a set of basic (low-level) combinators for + building documents. On top of these combinators, higher-level combinators + can be defined: see {!PPrintCombinators}. *) + +(** This is the abstract type of documents. *) +type document + +(** The following basic (low-level) combinators allow constructing documents. *) + +(** [empty] is the empty document. *) +val empty: document + +(** [doc_of_char c] is a document that consists of the single character [c]. This + character must not be a newline. *) +val doc_of_char: FStar.Char.char -> document + +(** [doc_of_string s] is a document that consists of the string [s]. This string must + not contain a newline. *) +val doc_of_string: string -> document + +(** [doc_of_bool b] is a document that consists of the boolean [b]. *) +val doc_of_bool: bool -> document + +(** [substring s ofs len] is a document that consists of the portion of the + string [s] delimited by the offset [ofs] and the length [len]. This + portion must contain a newline. *) +val substring: string -> int -> int -> document + +(** [fancystring s apparent_length] is a document that consists of the string + [s]. This string must not contain a newline. The string may contain fancy + characters: color escape characters, UTF-8 or multi-byte characters, + etc. Thus, its apparent length (which measures how many columns the text + will take up on screen) differs from its length in bytes. *) +val fancystring: string -> int -> document + +(** [fancysubstring s ofs len apparent_length] is a document that consists of + the portion of the string [s] delimited by the offset [ofs] and the length + [len]. This portion must not contain a newline. The string may contain fancy + characters. *) +val fancysubstring : string -> int -> int -> int -> document + +(** [utf8string s] is a document that consists of the UTF-8-encoded string [s]. + This string must not contain a newline. *) +val utf8string: string -> document + +(** [hardline] is a forced newline document. This document forces all enclosing + groups to be printed in non-flattening mode. In other words, any enclosing + groups are dissolved. *) +val hardline: document + +(** [blank n] is a document that consists of [n] blank characters. *) +val blank: int -> document + +(** [break_ n] is a document which consists of either [n] blank characters, + when forced to display on a single line, or a single newline character, + otherwise. Note that there is no choice at this point: choices are encoded + by the [group] combinator. *) +val break_: int -> document + +(** [doc1 ^^ doc2] is the concatenation of the documents [doc1] and [doc2]. *) +val ( ^^ ) : document -> document -> document +(** [x ^/^ y] separates x and y with a breakable space. It is a short-hand for + [x ^^ break 1 ^^ y] *) +val ( ^/^ ) : document -> document -> document + +(** [nest j doc] is the document [doc], in which the indentation level has + been increased by [j], that is, in which [j] blanks have been inserted + after every newline character. Read this again: indentation is inserted + after every newline character. No indentation is inserted at the beginning + of the document. *) +val nest: int -> document -> document + +(** [group doc] encodes a choice. If possible, then the entire document [group + doc] is rendered on a single line. Otherwise, the group is dissolved, and + [doc] is rendered. There might be further groups within [doc], whose + presence will lead to further choices being explored. *) +val group: document -> document + +// (** [column f] is the document obtained by applying the function [f] to the +// current column number. This combinator allows making the construction of +// a document dependent on the current column number. *) +// val column: (int -> document) -> document + +// (** [nesting f] is the document obtained by applying the function [f] to the +// current indentation level, that is, the number of indentation (blank) +// characters that were inserted at the beginning of the current line. *) +// val nesting: (int -> document) -> document + +// (** [position f] is the document obtained by applying the function [f] +// to the current position in the rendered output. The position +// consists of [bol], which is the character-offset of the beginnig +// of the current line (starting at 0), [line], which is the current +// line (starting at 1), and [column], which is the current column +// (starting at 0). The current character-offset is always given by +// [bol + column]. *) +// val position : (int -> int -> int -> document) -> document + +(** [ifflat doc1 doc2] is rendered as [doc1] if part of a group that can be + successfully flattened, and is rendered as [doc2] otherwise. Use this + operation with caution. Because the pretty-printer is free to choose + between [doc1] and [doc2], these documents should be semantically + equivalent. *) +val ifflat: document -> document -> document + +// SI: purposely commented-out for now. +// (** {1 Rendering documents} *) +// +// (** This renderer sends its output into an output channel. *) +// module ToChannel : PPrintRenderer.RENDERER +// with type channel = out_channel +// and type document = document +// +// (** This renderer sends its output into a memory buffer. *) +// module ToBuffer : PPrintRenderer.RENDERER +// with type channel = Buffer.t +// and type document = document +// +// (** This renderer sends its output into a formatter channel. *) +// module ToFormatter : PPrintRenderer.RENDERER +// with type channel = Format.formatter +// and type document = document + + +(** A set of high-level combinators for building documents. *) + +(** {1 Single characters} *) + +(** The following constant documents consist of a single character. *) + +val lparen: document +val rparen: document +val langle: document +val rangle: document +val lbrace: document +val rbrace: document +val lbracket: document +val rbracket: document +val squote: document +val dquote: document +val bquote: document +val semi: document +val colon: document +val comma: document +val space: document +val dot: document +val sharp: document +val slash: document +val backslash: document +val equals: document +val qmark: document +val tilde: document +val at: document +val percent: document +val dollar: document +val caret: document +val ampersand: document +val star: document +val plus: document +val minus: document +val underscore: document +val bang: document +val bar: document +val rarrow: document +val long_left_arrow: document +val larrow: document + +(** {1 Delimiters} *) + +(** [precede l x] is [l ^^ x]. *) +val precede: document -> document -> document + +(** [terminate r x] is [x ^^ r]. *) +val terminate: document -> document -> document + +(** [enclose l r x] is [l ^^ x ^^ r]. *) +val enclose: document -> document -> document -> document + +(** The following combinators enclose a document within a pair of delimiters. + They are partial applications of [enclose]. No whitespace or line break is + introduced. *) + +val squotes: document -> document +val dquotes: document -> document +val bquotes: document -> document +val braces: document -> document +val parens: document -> document +val angles: document -> document +val brackets: document -> document + +(** {1 Repetition} *) + +(** [twice doc] is the document obtained by concatenating two copies of + the document [doc]. *) +val twice: document -> document + +(** [repeat n doc] is the document obtained by concatenating [n] copies of + the document [doc]. *) +val repeat: int -> document -> document + +(** {1 Lists and options} *) + +(** [concat docs] is the concatenation of the documents in the list [docs] (with ^^). *) +val concat: list document -> document + +(** [separate sep docs] is the concatenation of the documents in the list + [docs]. The separator [sep] is inserted between every two adjacent + documents. *) +val separate: document -> list document -> document + +(** [concat_map f xs] is equivalent to [concat (List.map f xs)]. *) +val concat_map: ('a -> document) -> list 'a -> document + +(** [separate_map sep f xs] is equivalent to [separate sep (List.map f xs)]. *) +val separate_map: document -> ('a -> document) -> list 'a -> document + +(** [separate2 sep last_sep docs] is the concatenation of the documents in the + list [docs]. The separator [sep] is inserted between every two adjacent + documents, except between the last two documents, where the separator + [last_sep] is used instead. *) +val separate2: document -> document -> list document -> document + +(** [optional f None] is the empty document. [optional f (Some x)] is + the document [f x]. *) +val optional: ('a -> document) -> option 'a -> document + +(** {1 Text} *) + +(** [lines s] is the list of documents obtained by splitting [s] at newline + characters, and turning each line into a document via [substring]. This + code is not UTF-8 aware. *) +val lines: string -> list document + +(** [arbitrary_string s] is equivalent to [separate (break 1) (lines s)]. + It is analogous to [string s], but is valid even if the string [s] + contains newline characters. *) +val arbitrary_string: string -> document + +(** [words s] is the list of documents obtained by splitting [s] at whitespace + characters, and turning each word into a document via [substring]. All + whitespace is discarded. This code is not UTF-8 aware. *) +val words: string -> list document + +(** [split ok s] splits the string [s] before and after every occurrence of a + character that satisfies the predicate [ok]. The substrings thus obtained + are turned into documents, and a list of documents is returned. No + information is lost: the concatenation of the documents yields the + original string. This code is not UTF-8 aware. *) +val split: (FStar.Char.char -> bool) -> string -> list document + +(** [flow sep docs] separates the documents in the list [docs] with the + separator [sep] and arranges for a new line to begin whenever a document + does not fit on the current line. This is useful for typesetting + free-flowing, ragged-right text. A typical choice of [sep] is [break b], + where [b] is the number of spaces that must be inserted between two + consecutive words (when displayed on the same line). *) +val flow: document -> list document -> document + +(** [flow_map sep f docs] is equivalent to [flow sep (List.map f docs)]. *) +val flow_map: document -> ('a -> document) -> list 'a -> document + +(** [url s] is a possible way of displaying the URL [s]. A potential line + break is inserted immediately before and immediately after every slash + and dot character. *) +val url: string -> document + +(** {1 Alignment and indentation} *) + +(** [align doc] increases the indentation level to reach the current + column. Thus, this document will be rendered within a box whose + upper left corner is the current position. *) +val align: document -> document + +(* [hang n doc] is analogous to [align], but additionally indents + all lines, except the first one, by [n]. Thus, the text in the + box forms a hanging indent. *) +val hang: int -> document -> document + +(** [prefix n b left right] has the following flat layout: {[ +left right +]} +and the following non-flat layout: +{[ +left + right +]} +The parameter [n] controls the nesting of [right] (when not flat). +The parameter [b] controls the number of spaces between [left] and [right] +(when flat). + *) +val prefix: int -> int -> document -> document -> document + +(** [jump n b right] is equivalent to [prefix n b empty right]. *) +val jump: int -> int -> document -> document + +(** [infix n b middle left right] has the following flat layout: {[ +left middle right +]} +and the following non-flat layout: {[ +left middle + right +]} +The parameter [n] controls the nesting of [right] (when not flat). +The parameter [b] controls the number of spaces between [left] and [middle] +(always) and between [middle] and [right] (when flat). +*) +val infix: int -> int -> document -> document -> document -> document + +(** [surround n b opening contents closing] has the following flat layout: {[ +opening contents closing +]} +and the following non-flat layout: {[ +opening + contents +closing +]} +The parameter [n] controls the nesting of [contents] (when not flat). +The parameter [b] controls the number of spaces between [opening] and [contents] +and between [contents] and [closing] (when flat). +*) +val surround: int -> int -> document -> document -> document -> document + +(** [soft_surround] is analogous to [surround], but involves more than one + group, so it offers possibilities other than the completely flat layout + (where [opening], [contents], and [closing] appear on a single line) and + the completely developed layout (where [opening], [contents], and + [closing] appear on separate lines). It tries to place the beginning of + [contents] on the same line as [opening], and to place [closing] on the + same line as the end of [contents], if possible. +*) +val soft_surround: int -> int -> document -> document -> document -> document + +(** [surround_separate n b void opening sep closing docs] is equivalent to + [surround n b opening (separate sep docs) closing], except when the + list [docs] is empty, in which case it reduces to [void]. *) +val surround_separate: int -> int -> document -> document -> document -> document -> list document -> document + +(** [surround_separate_map n b void opening sep closing f xs] is equivalent to + [surround_separate n b void opening sep closing (List.map f xs)]. *) +val surround_separate_map: int -> int -> document -> document -> document -> document -> ('a -> document) -> list 'a -> document + +(** {1 Short-hands} *) + + +//(** [!^s] is a short-hand for [string s]. *) +// val ( !^ ) : string -> document + +(** [x ^/^ y] separates [x] and [y] with a breakable space. + It is a short-hand for [x ^^ break 1 ^^ y]. *) + +(** [x ^//^ y] is a short-hand for [prefix 2 1 x y]. *) +// val ( ^//^ ) : document -> document -> document + +// Expose underlying Renderer.pretty implementations (avoid inner modules). +// [pretty_string] uses ToBuffer:RENDERER implementation; +// [print_out_channel] uses the ToChannel:RENDERER one. +val pretty_string : float -> int -> document -> string +val pretty_out_channel : float -> int -> document -> FStarC.Compiler.Util.out_channel -> unit + +(* Simple renderer, defined as [pretty_string 1.0 80] *) +val render : document -> string diff --git a/src/reflection/FStar.Reflection.V1.Builtins.fst b/src/reflection/FStar.Reflection.V1.Builtins.fst deleted file mode 100644 index f4f9d17cd09..00000000000 --- a/src/reflection/FStar.Reflection.V1.Builtins.fst +++ /dev/null @@ -1,976 +0,0 @@ -(* - Copyright 2008-2015 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Reflection.V1.Builtins - -open FStar -open FStar.Compiler -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Reflection.V1.Data -open FStar.Syntax.Syntax -open FStar.Order -open FStar.Errors - -module S = FStar.Syntax.Syntax // TODO: remove, it's open - -open FStar.Class.Show -open FStar.Class.Tagged - -module C = FStar.Const -module PC = FStar.Parser.Const -module SS = FStar.Syntax.Subst -module BU = FStar.Compiler.Util -module Range = FStar.Compiler.Range -module U = FStar.Syntax.Util -module UF = FStar.Syntax.Unionfind -module Print = FStar.Syntax.Print -module Ident = FStar.Ident -module Env = FStar.TypeChecker.Env -module Err = FStar.Errors -module Z = FStar.BigInt -module DsEnv = FStar.Syntax.DsEnv -module O = FStar.Options -module RD = FStar.Reflection.V1.Data -module EMB = FStar.Syntax.Embeddings -module N = FStar.TypeChecker.Normalize -open FStar.VConfig - -open FStar.Dyn - -(* This file provides implementation for reflection primitives in F*. - * - * Users can be exposed to (mostly) raw syntax of terms when working in - * a metaprogramming effect (such as TAC). These effects are irrelevant - * for runtime and cannot, of course, be used for proof (where syntax - * inspection would be completely inconsistent - *) - - (* - * Most of this file is tedious and repetitive. - * We should really allow for some metaprogramming in F*. Oh wait.... - *) - - -(* This is a hack, but it allows to lookup the constructor sigelts when -inspecting a Sig_inductive_typ. - -We need to be careful though. If we use this for, say, `lookup_attr` and -remove its `env` argument, then the normalizer can reduce it eagerly. -Trying to do this right now means calls to `lookup_attr` are evaluated -at extraction time, and will not behave as expected. The root cause is -that all of the reflection operators are taken to be pure and that't not -the case if we remove the `env` in some, like `lookup_attr`. - -In the case of `inspect_sigelt`, however, I think it won't be -noticeable since one obtain a concrete sigelt without running an impure -metaprogram. *) -let get_env () : Env.env = - match !N.reflection_env_hook with - | None -> failwith "impossible: env_hook unset in reflection" - | Some e -> e - -(* private *) -let inspect_bqual (bq : bqual) : aqualv = - match bq with - | Some (Implicit _) -> Data.Q_Implicit - | Some (Meta t) -> Data.Q_Meta t - | Some Equality - | None -> Data.Q_Explicit - -let inspect_aqual (aq : aqual) : aqualv = - match aq with - | Some ({ aqual_implicit = true }) -> Data.Q_Implicit - | _ -> Data.Q_Explicit - -(* private *) -let pack_bqual (aqv : aqualv) : bqual = - match aqv with - | Data.Q_Explicit -> None - | Data.Q_Implicit -> Some (Implicit false) - | Data.Q_Meta t -> Some (Meta t) - -let pack_aqual (aqv : aqualv) : aqual = - match aqv with - | Data.Q_Implicit -> S.as_aqual_implicit true - | _ -> None - -let inspect_fv (fv:fv) : list string = - Ident.path_of_lid (lid_of_fv fv) - -let pack_fv (ns:list string) : fv = - let lid = PC.p2l ns in - let fallback () = - let quals = - (* This an awful hack *) - if Ident.lid_equals lid PC.cons_lid then Some Data_ctor else - if Ident.lid_equals lid PC.nil_lid then Some Data_ctor else - if Ident.lid_equals lid PC.some_lid then Some Data_ctor else - if Ident.lid_equals lid PC.none_lid then Some Data_ctor else - None - in - lid_as_fv (PC.p2l ns) quals - in - match !N.reflection_env_hook with - | None -> fallback () - | Some env -> - let qninfo = Env.lookup_qname env lid in - match qninfo with - | Some (Inr (se, _us), _rng) -> - let quals = DsEnv.fv_qual_of_se se in - lid_as_fv (PC.p2l ns) quals - | _ -> - fallback () - -// TODO: move to library? -let rec last (l:list 'a) : 'a = - match l with - | [] -> failwith "last: empty list" - | [x] -> x - | _::xs -> last xs - -let rec init (l:list 'a) : list 'a = - match l with - | [] -> failwith "init: empty list" - | [x] -> [] - | x::xs -> x :: init xs - -let inspect_const (c:sconst) : vconst = - match c with - | FStar.Const.Const_unit -> C_Unit - | FStar.Const.Const_int (s, _) -> C_Int (Z.big_int_of_string s) - | FStar.Const.Const_bool true -> C_True - | FStar.Const.Const_bool false -> C_False - | FStar.Const.Const_string (s, _) -> C_String s - | FStar.Const.Const_range r -> C_Range r - | FStar.Const.Const_reify _ -> C_Reify - | FStar.Const.Const_reflect l -> C_Reflect (Ident.path_of_lid l) - | _ -> failwith (BU.format1 "unknown constant: %s" (show c)) - -let inspect_universe u = - match u with - | U_zero -> Uv_Zero - | U_succ u -> Uv_Succ u - | U_max us -> Uv_Max us - | U_bvar n -> Uv_BVar (Z.of_int_fs n) - | U_name i -> Uv_Name (Ident.string_of_id i, Ident.range_of_id i) - | U_unif u -> Uv_Unif u - | U_unknown -> Uv_Unk - -let pack_universe uv = - match uv with - | Uv_Zero -> U_zero - | Uv_Succ u -> U_succ u - | Uv_Max us -> U_max us - | Uv_BVar n -> U_bvar (Z.to_int_fs n) - | Uv_Name i -> U_name (Ident.mk_ident i) - | Uv_Unif u -> U_unif u - | Uv_Unk -> U_unknown - -let rec inspect_ln (t:term) : term_view = - // - // Only pushes delayed substitutions, - // doesn't compress uvars - // - let t = t |> SS.compress_subst in - match t.n with - | Tm_meta {tm=t} -> - inspect_ln t - - | Tm_name bv -> - Tv_Var bv - - | Tm_bvar bv -> - Tv_BVar bv - - | Tm_fvar fv -> - Tv_FVar fv - - | Tm_uinst (t, us) -> - (match t.n with - | Tm_fvar fv -> Tv_UInst (fv, us) - | _ -> failwith "Reflection::inspect_ln: uinst for a non-fvar node") - - | Tm_ascribed {tm=t; asc=(Inl ty, tacopt, eq)} -> - Tv_AscribedT (t, ty, tacopt, eq) - - | Tm_ascribed {tm=t; asc=(Inr cty, tacopt, eq)} -> - Tv_AscribedC (t, cty, tacopt, eq) - - | Tm_app {args=[]} -> - failwith "inspect_ln: empty arguments on Tm_app" - - | Tm_app {hd; args} -> - // We split at the last argument, since the term_view does not - // expose n-ary lambdas buy unary ones. - let (a, q) = last args in - let q' = inspect_aqual q in - Tv_App (U.mk_app hd (init args), (a, q')) - - | Tm_abs {bs=[]} -> - failwith "inspect_ln: empty arguments on Tm_abs" - - | Tm_abs {bs=b::bs; body=t; rc_opt=k} -> - let body = - match bs with - | [] -> t - | bs -> S.mk (Tm_abs {bs; body=t; rc_opt=k}) t.pos - in - Tv_Abs (b, body) - - | Tm_type u -> - Tv_Type u - - | Tm_arrow {bs=[]} -> - failwith "inspect_ln: empty binders on arrow" - - | Tm_arrow _ -> - begin match U.arrow_one_ln t with - | Some (b, c) -> Tv_Arrow (b, c) - | None -> failwith "impossible" - end - - | Tm_refine {b=bv; phi=t} -> - Tv_Refine (bv, bv.sort, t) - - | Tm_constant c -> - Tv_Const (inspect_const c) - - | Tm_uvar (ctx_u, s) -> - // - // Use the unique id of the uvar - // - Tv_Uvar (Z.of_int_fs (UF.uvar_unique_id ctx_u.ctx_uvar_head), - (ctx_u, s)) - - | Tm_let {lbs=(false, [lb]); body=t2} -> - if lb.lbunivs <> [] then Tv_Unsupp else - begin match lb.lbname with - | Inr _ -> Tv_Unsupp // no top level lets - | Inl bv -> - // The type of `bv` should match `lb.lbtyp` - Tv_Let (false, lb.lbattrs, bv, bv.sort, lb.lbdef, t2) - end - - | Tm_let {lbs=(true, [lb]); body=t2} -> - if lb.lbunivs <> [] then Tv_Unsupp else - begin match lb.lbname with - | Inr _ -> Tv_Unsupp // no top level lets - | Inl bv -> Tv_Let (true, lb.lbattrs, bv, bv.sort, lb.lbdef, t2) - end - - | Tm_match {scrutinee=t; ret_opt; brs} -> - let rec inspect_pat p = - match p.v with - | Pat_constant c -> Pat_Constant (inspect_const c) - | Pat_cons (fv, us_opt, ps) -> Pat_Cons (fv, us_opt, List.map (fun (p, b) -> inspect_pat p, b) ps) - | Pat_var bv -> Pat_Var (bv, Sealed.seal bv.sort) - | Pat_dot_term eopt -> Pat_Dot_Term eopt - in - let brs = List.map (function (pat, _, t) -> (inspect_pat pat, t)) brs in - Tv_Match (t, ret_opt, brs) - - | Tm_unknown -> - Tv_Unknown - - | Tm_lazy i -> - // Not calling U.unlazy_emb since that calls (stateful) SS.compress - i |> U.unfold_lazy |> inspect_ln - - | _ -> - Err.log_issue t Err.Warning_CantInspect - (BU.format2 "inspect_ln: outside of expected syntax (%s, %s)" (tag_of t) (show t)); - Tv_Unsupp - -let inspect_comp (c : comp) : comp_view = - let get_dec (flags : list cflag) : list term = - match List.tryFind (function DECREASES _ -> true | _ -> false) flags with - | None -> [] - | Some (DECREASES (Decreases_lex ts)) -> ts - | Some (DECREASES (Decreases_wf _)) -> - Err.log_issue c Err.Warning_CantInspect - (BU.format1 "inspect_comp: inspecting comp with wf decreases clause is not yet supported: %s \ - skipping the decreases clause" - (show c)); - [] - | _ -> failwith "Impossible!" - in - match c.n with - | Total t -> C_Total t - | GTotal t -> C_GTotal t - | Comp ct -> begin - let uopt = - if List.length ct.comp_univs = 0 - then U_unknown - else ct.comp_univs |> List.hd in - if Ident.lid_equals ct.effect_name PC.effect_Lemma_lid then - match ct.effect_args with - | (pre,_)::(post,_)::(pats,_)::_ -> - C_Lemma (pre, post, pats) - | _ -> - failwith "inspect_comp: Lemma does not have enough arguments?" - else - let inspect_arg (a, q) = (a, inspect_aqual q) in - C_Eff (ct.comp_univs, - Ident.path_of_lid ct.effect_name, - ct.result_typ, - List.map inspect_arg ct.effect_args, - get_dec ct.flags) - end - -let pack_comp (cv : comp_view) : comp = - let urefl_to_univs u = - if u = U_unknown - then [] - else [u] in - let urefl_to_univ_opt u = - if u = U_unknown - then None - else Some u in - match cv with - | C_Total t -> mk_Total t - | C_GTotal t -> mk_GTotal t - | C_Lemma (pre, post, pats) -> - let ct = { comp_univs = [] - ; effect_name = PC.effect_Lemma_lid - ; result_typ = S.t_unit - ; effect_args = [S.as_arg pre; S.as_arg post; S.as_arg pats] - ; flags = [] } in - S.mk_Comp ct - - | C_Eff (us, ef, res, args, decrs) -> - let pack_arg (a, q) = (a, pack_aqual q) in - let flags = - if List.length decrs = 0 - then [] - else [DECREASES (Decreases_lex decrs)] in - let ct = { comp_univs = us - ; effect_name = Ident.lid_of_path ef Range.dummyRange - ; result_typ = res - ; effect_args = List.map pack_arg args - ; flags = flags } in - S.mk_Comp ct - -let pack_const (c:vconst) : sconst = - match c with - | C_Unit -> C.Const_unit - | C_Int i -> C.Const_int (Z.string_of_big_int i, None) - | C_True -> C.Const_bool true - | C_False -> C.Const_bool false - | C_String s -> C.Const_string (s, Range.dummyRange) - | C_Range r -> C.Const_range r - | C_Reify -> C.Const_reify None - | C_Reflect ns -> C.Const_reflect (Ident.lid_of_path ns Range.dummyRange) - -// TODO: pass in range? -let pack_ln (tv:term_view) : term = - match tv with - | Tv_Var bv -> - S.bv_to_name bv - - | Tv_BVar bv -> - S.bv_to_tm bv - - | Tv_FVar fv -> - S.fv_to_tm fv - - | Tv_UInst (fv, us) -> - mk_Tm_uinst (S.fv_to_tm fv) us - - | Tv_App (l, (r, q)) -> - let q' = pack_aqual q in - U.mk_app l [(r, q')] - - | Tv_Abs (b, t) -> - mk (Tm_abs {bs=[b]; body=t; rc_opt=None}) t.pos // TODO: effect? - - | Tv_Arrow (b, c) -> - mk (Tm_arrow {bs=[b]; comp=c}) c.pos - - | Tv_Type u -> - mk (Tm_type u) Range.dummyRange - - | Tv_Refine (bv, sort, t) -> - mk (Tm_refine {b={bv with sort=sort}; phi=t}) t.pos - - | Tv_Const c -> - S.mk (Tm_constant (pack_const c)) Range.dummyRange - - | Tv_Uvar (u, ctx_u_s) -> - S.mk (Tm_uvar ctx_u_s) Range.dummyRange - - | Tv_Let (false, attrs, bv, ty, t1, t2) -> - let bv = { bv with sort=ty } in - let lb = U.mk_letbinding (Inl bv) [] bv.sort PC.effect_Tot_lid t1 attrs Range.dummyRange in - S.mk (Tm_let {lbs=(false, [lb]); body=t2}) Range.dummyRange - - | Tv_Let (true, attrs, bv, ty, t1, t2) -> - let bv = { bv with sort=ty } in - let lb = U.mk_letbinding (Inl bv) [] bv.sort PC.effect_Tot_lid t1 attrs Range.dummyRange in - S.mk (Tm_let {lbs=(true, [lb]); body=t2}) Range.dummyRange - - | Tv_Match (t, ret_opt, brs) -> - let wrap v = {v=v;p=Range.dummyRange} in - let rec pack_pat p : S.pat = - match p with - | Pat_Constant c -> wrap <| Pat_constant (pack_const c) - | Pat_Cons (fv, us_opt, ps) -> wrap <| Pat_cons (fv, us_opt, List.map (fun (p, b) -> pack_pat p, b) ps) - | Pat_Var (bv, _sort) -> wrap <| Pat_var bv - | Pat_Dot_Term eopt -> wrap <| Pat_dot_term eopt - in - let brs = List.map (function (pat, t) -> (pack_pat pat, None, t)) brs in - S.mk (Tm_match {scrutinee=t; ret_opt; brs; rc_opt=None}) Range.dummyRange - - | Tv_AscribedT(e, t, tacopt, use_eq) -> - S.mk (Tm_ascribed {tm=e; asc=(Inl t, tacopt, use_eq); eff_opt=None}) Range.dummyRange - - | Tv_AscribedC(e, c, tacopt, use_eq) -> - S.mk (Tm_ascribed {tm=e; asc=(Inr c, tacopt, use_eq); eff_opt=None}) Range.dummyRange - - | Tv_Unknown -> - S.mk Tm_unknown Range.dummyRange - - | Tv_Unsupp -> - Err.log_issue0 - Err.Warning_CantInspect "packing a Tv_Unsupp into Tm_unknown"; - S.mk Tm_unknown Range.dummyRange - -let compare_bv (x:bv) (y:bv) : order = - let n = S.order_bv x y in - if n < 0 then Lt - else if n = 0 then Eq - else Gt - -let lookup_attr (attr:term) (env:Env.env) : list fv = - match (SS.compress_subst attr).n with - | Tm_fvar fv -> - let ses = Env.lookup_attr env (Ident.string_of_lid (lid_of_fv fv)) in - List.concatMap (fun se -> match U.lid_of_sigelt se with - | None -> [] - | Some l -> [S.lid_as_fv l None]) ses - | _ -> [] - -let all_defs_in_env (env:Env.env) : list fv = - List.map (fun l -> S.lid_as_fv l None) (Env.lidents env) // |> take 10 - -let defs_in_module (env:Env.env) (modul:name) : list fv = - List.concatMap - (fun l -> - (* must succeed, ids_of_lid always returns a non-empty list *) - let ns = Ident.ids_of_lid l |> init |> List.map Ident.string_of_id in - if ns = modul - then [S.lid_as_fv l None] - else []) - (Env.lidents env) - -let lookup_typ (env:Env.env) (ns:list string) : option sigelt = - let lid = PC.p2l ns in - Env.lookup_sigelt env lid - -let sigelt_attrs (se : sigelt) : list attribute = - se.sigattrs - -let set_sigelt_attrs (attrs : list attribute) (se : sigelt) : sigelt = - { se with sigattrs = attrs } - -let inspect_ident (i:Ident.ident) : ident = Reflection.V2.Builtins.inspect_ident i -let pack_ident (i:ident) : Ident.ident = Reflection.V2.Builtins.pack_ident i - -(* PRIVATE, and hacky :-( *) -let rd_to_syntax_qual : RD.qualifier -> qualifier = function - | RD.Assumption -> Assumption - | RD.New -> New - | RD.Private -> Private - | RD.Unfold_for_unification_and_vcgen -> Unfold_for_unification_and_vcgen - | RD.Visible_default -> Visible_default - | RD.Irreducible -> Irreducible - | RD.Inline_for_extraction -> Inline_for_extraction - | RD.NoExtract -> NoExtract - | RD.Noeq -> Noeq - | RD.Unopteq -> Unopteq - | RD.TotalEffect -> TotalEffect - | RD.Logic -> Logic - | RD.Reifiable -> Reifiable - | RD.Reflectable l -> Reflectable (Ident.lid_of_path l Range.dummyRange) - | RD.Discriminator l -> Discriminator (Ident.lid_of_path l Range.dummyRange) - | RD.Projector (l, i) -> Projector (Ident.lid_of_path l Range.dummyRange, pack_ident i) - | RD.RecordType (l1, l2) -> RecordType (List.map pack_ident l1, List.map pack_ident l2) - | RD.RecordConstructor (l1, l2) -> RecordConstructor (List.map pack_ident l1, List.map pack_ident l2) - | RD.Action l -> Action (Ident.lid_of_path l Range.dummyRange) - | RD.ExceptionConstructor -> ExceptionConstructor - | RD.HasMaskedEffect -> HasMaskedEffect - | RD.Effect -> S.Effect - | RD.OnlyName -> OnlyName - -let syntax_to_rd_qual = function - | Assumption -> RD.Assumption - | New -> RD.New - | Private -> RD.Private - | Unfold_for_unification_and_vcgen -> RD.Unfold_for_unification_and_vcgen - | Visible_default -> RD.Visible_default - | Irreducible -> RD.Irreducible - | Inline_for_extraction -> RD.Inline_for_extraction - | NoExtract -> RD.NoExtract - | Noeq -> RD.Noeq - | Unopteq -> RD.Unopteq - | TotalEffect -> RD.TotalEffect - | Logic -> RD.Logic - | Reifiable -> RD.Reifiable - | Reflectable l -> RD.Reflectable (Ident.path_of_lid l) - | Discriminator l -> RD.Discriminator (Ident.path_of_lid l) - | Projector (l, i) -> RD.Projector (Ident.path_of_lid l, inspect_ident i) - | RecordType (l1, l2) -> RD.RecordType (List.map inspect_ident l1, List.map inspect_ident l2) - | RecordConstructor (l1, l2) -> RD.RecordConstructor (List.map inspect_ident l1, List.map inspect_ident l2) - | Action l -> RD.Action (Ident.path_of_lid l) - | ExceptionConstructor -> RD.ExceptionConstructor - | HasMaskedEffect -> RD.HasMaskedEffect - | S.Effect -> RD.Effect - | OnlyName -> RD.OnlyName - - -let sigelt_quals (se : sigelt) : list RD.qualifier = - se.sigquals |> List.map syntax_to_rd_qual - -let set_sigelt_quals (quals : list RD.qualifier) (se : sigelt) : sigelt = - { se with sigquals = List.map rd_to_syntax_qual quals } - -let sigelt_opts (se : sigelt) : option vconfig = se.sigopts - -let embed_vconfig (vcfg : vconfig) : term = - EMB.embed vcfg Range.dummyRange None EMB.id_norm_cb - -let inspect_sigelt (se : sigelt) : sigelt_view = - match se.sigel with - | Sig_let {lbs=(r, lbs)} -> - let inspect_letbinding (lb:letbinding) = - let {lbname=nm;lbunivs=us;lbtyp=typ;lbeff=eff;lbdef=def;lbattrs=attrs;lbpos=pos} = lb in - let s, us = SS.univ_var_opening us in - let typ = SS.subst s typ in - let def = SS.subst s def in - U.mk_letbinding nm us typ eff def attrs pos - in - Sg_Let (r, List.map inspect_letbinding lbs) - - | Sig_inductive_typ {lid; us; params=param_bs; t=ty; ds=c_lids} -> - let nm = Ident.path_of_lid lid in - let s, us = SS.univ_var_opening us in - let param_bs = SS.subst_binders s param_bs in - let ty = SS.subst s ty in - - let param_bs, ty = SS.open_term param_bs ty in - - let inspect_ctor (c_lid:Ident.lid) : ctor = - match Env.lookup_sigelt (get_env ()) c_lid with - | Some ({sigel = Sig_datacon {lid; us; t=cty; num_ty_params=nparam}}) -> - let cty = SS.subst s cty in // open universes from above - - let param_ctor_bs, c = N.get_n_binders (get_env ()) nparam cty in - - if List.length param_ctor_bs <> nparam then - failwith "impossible: inspect_sigelt: could not obtain sufficient ctor param binders"; - - if not (U.is_total_comp c) then - failwith "impossible: inspect_sigelt: removed parameters and got an effectful comp"; - let cty = U.comp_result c in - - (* Substitute the parameters of the constructor to match - * those of the inductive opened above, and return the type - * of the constructor already instantiated. *) - let s' = List.map2 (fun b1 b2 -> NT (b1.binder_bv, S.bv_to_name b2.binder_bv)) - param_ctor_bs param_bs - in - let cty = SS.subst s' cty in - - let cty = U.remove_inacc cty in - (Ident.path_of_lid lid, cty) - - | _ -> - failwith "impossible: inspect_sigelt: did not find ctor" - in - Sg_Inductive (nm, List.map inspect_ident us, param_bs, ty, List.map inspect_ctor c_lids) - - | Sig_declare_typ {lid; us; t=ty} -> - let nm = Ident.path_of_lid lid in - let us, ty = SS.open_univ_vars us ty in - Sg_Val (nm, List.map inspect_ident us, ty) - - | _ -> - Unk - -let pack_sigelt (sv:sigelt_view) : sigelt = - let check_lid lid = - if List.length (Ident.path_of_lid lid) <= 1 - then failwith ("pack_sigelt: invalid long identifier \"" - ^ Ident.string_of_lid lid - ^ "\" (did you forget a module path?)") - in - match sv with - | Sg_Let (r, lbs) -> - let pack_letbinding (lb:letbinding) = - let {lbname=nm;lbunivs=us;lbtyp=typ;lbeff=eff;lbdef=def;lbattrs=attrs;lbpos=pos} = lb in - let lid = match nm with - | Inr fv -> lid_of_fv fv - | _ -> failwith - "impossible: pack_sigelt: bv in toplevel let binding" - in - check_lid lid; - let s = SS.univ_var_closing us in - let typ = SS.subst s typ in - let def = SS.subst s def in - let lb = U.mk_letbinding nm us typ eff def attrs pos in - (lid, lb) - in - let packed = List.map pack_letbinding lbs in - let lbs = List.map snd packed in - let lids = List.map fst packed in - mk_sigelt <| Sig_let {lbs=(r, lbs); lids} - - | Sg_Inductive (nm, us_names, param_bs, ty, ctors) -> - let us_names = List.map pack_ident us_names in - let ind_lid = Ident.lid_of_path nm Range.dummyRange in - check_lid ind_lid; - let s = SS.univ_var_closing us_names in - let nparam = List.length param_bs in - //We can't tust the value of injective_type_params; set it to false here and let the typechecker recompute - let injective_type_params = false in - let pack_ctor (c:ctor) : sigelt = - let (nm, ty) = c in - let lid = Ident.lid_of_path nm Range.dummyRange in - let ty = U.arrow param_bs (S.mk_Total ty) in - let ty = SS.subst s ty in (* close univs *) - mk_sigelt <| Sig_datacon {lid; us=us_names; t=ty; ty_lid=ind_lid; num_ty_params=nparam; mutuals=[]; injective_type_params } - in - - let ctor_ses : list sigelt = List.map pack_ctor ctors in - let c_lids : list Ident.lid = List.map (fun se -> BU.must (U.lid_of_sigelt se)) ctor_ses in - - let ind_se : sigelt = - let param_bs = SS.close_binders param_bs in - let ty = SS.close param_bs ty in - - (* close univs *) - let param_bs = SS.subst_binders s param_bs in - let ty = SS.subst s ty in - //We can't trust the assignment of num uniform binders from the reflection API - //So, set it to None; it has to be checked and recomputed - mk_sigelt <| Sig_inductive_typ {lid=ind_lid; - us=us_names; - params=param_bs; - num_uniform_params=None; - t=ty; - mutuals=[]; - ds=c_lids; - injective_type_params } - in - let se = mk_sigelt <| Sig_bundle {ses=ind_se::ctor_ses; lids=ind_lid::c_lids} in - { se with sigquals = Noeq::se.sigquals } - - | Sg_Val (nm, us_names, ty) -> - let us_names = List.map pack_ident us_names in - let val_lid = Ident.lid_of_path nm Range.dummyRange in - check_lid val_lid; - let typ = SS.close_univ_vars us_names ty in - mk_sigelt <| Sig_declare_typ {lid=val_lid; us=us_names; t=typ} - - | Unk -> - failwith "packing Unk, sorry" - -let inspect_lb (lb:letbinding) : lb_view = - let {lbname=nm;lbunivs=us;lbtyp=typ;lbeff=eff;lbdef=def;lbattrs=attrs;lbpos=pos} - = lb in - let s, us = SS.univ_var_opening us in - let typ = SS.subst s typ in - let def = SS.subst s def in - let us = List.map inspect_ident us in - match nm with - | Inr fv -> {lb_fv = fv; lb_us = us; lb_typ = typ; lb_def = def} - | _ -> failwith "Impossible: bv in top-level let binding" - -let pack_lb (lbv:lb_view) : letbinding = - let {lb_fv = fv; lb_us = us; lb_typ = typ; lb_def = def} = lbv in - let us = List.map pack_ident us in - let s = SS.univ_var_closing us in - let typ = SS.subst s typ in - let def = SS.subst s def in - U.mk_letbinding (Inr fv) us typ PC.effect_Tot_lid def [] Range.dummyRange - -let inspect_bv (bv:bv) : bv_view = - if bv.index < 0 then ( - Err.log_issue0 Err.Warning_CantInspect - (BU.format3 "inspect_bv: index is negative (%s : %s), index = %s" - (Ident.string_of_id bv.ppname) - (show bv.sort) - (show bv.index)) - ); - { - bv_ppname = Sealed.seal <| Ident.string_of_id bv.ppname; - bv_index = Z.of_int_fs bv.index; - } - -let pack_bv (bvv:bv_view) : bv = - if Z.to_int_fs bvv.bv_index < 0 then ( - Err.log_issue0 Err.Warning_CantInspect - (BU.format2 "pack_bv: index is negative (%s), index = %s" - (Sealed.unseal bvv.bv_ppname) - (show (Z.to_int_fs bvv.bv_index))) - ); - { - ppname = Ident.mk_ident (Sealed.unseal <| bvv.bv_ppname, Range.dummyRange); - index = Z.to_int_fs bvv.bv_index; // Guaranteed to be a nat - sort = S.tun; - } - -let inspect_binder (b:binder) : binder_view = - let attrs = U.encode_positivity_attributes b.binder_positivity b.binder_attrs in - { - binder_bv = b.binder_bv; - binder_qual = inspect_bqual (b.binder_qual); - binder_attrs = attrs; - binder_sort = b.binder_bv.sort; - } - -let pack_binder (bview:binder_view) : binder = - let pqual, attrs = U.parse_positivity_attributes bview.binder_attrs in - { - binder_bv= { bview.binder_bv with sort = bview.binder_sort }; - binder_qual=pack_bqual (bview.binder_qual); - binder_positivity=pqual; - binder_attrs=attrs - } - -open FStar.TypeChecker.Env -let moduleof (e : Env.env) : list string = - Ident.path_of_lid e.curmodule - -let env_open_modules (e : Env.env) : list name = - List.map (fun (l, m) -> List.map Ident.string_of_id (Ident.ids_of_lid l)) - (DsEnv.open_modules e.dsenv) - -let binders_of_env e = FStar.TypeChecker.Env.all_binders e - -(* Generic combinators, safe *) -let eqopt = Syntax.Util.eqopt -let eqlist = Syntax.Util.eqlist -let eqprod = Syntax.Util.eqprod - -(* - * Why doesn't this call into Syntax.Util.term_eq? Because that function - * can expose details that are not observable in the userspace view of - * terms, and hence that function cannot be safely exposed if we wish to - * maintain the lemmas stating that pack/inspect are inverses of each - * other. - * - * In other words, we need this function to be implemented consistently - * with the view to make sure it is a _function_ in userspace, and maps - * (propositionally) equal terms to equal results. - * - * So we implement it via inspect_ln, to make sure we don't reveal - * anything inspect_ln does not already reveal. Hence this function - * is really only an optimization of this same implementation done in - * userspace. Also, nothing is guaranted about its result. It if were to - * just return false constantly, that would be safe (though useless). - * - * This same note also applies to comp, and other types that are taken - * as abstract, but have a lemma stating that the view is complete - * (or appear inside a view of one such type). - *) -let rec term_eq (t1:term) (t2:term) : bool = - match inspect_ln t1, inspect_ln t2 with - | Tv_Var bv1, Tv_Var bv2 -> - bv_eq bv1 bv2 - - | Tv_BVar bv1, Tv_BVar bv2 -> - bv_eq bv1 bv2 - - | Tv_FVar fv1, Tv_FVar fv2 -> - (* This should be equivalent to exploding the fv's name comparing *) - S.fv_eq fv1 fv2 - - | Tv_UInst (fv1, us1), Tv_UInst (fv2, us2) -> - S.fv_eq fv1 fv2 && univs_eq us1 us2 - - | Tv_App (h1, arg1), Tv_App (h2, arg2) -> - term_eq h1 h2 && arg_eq arg1 arg2 - - | Tv_Abs (b1, t1), Tv_Abs (b2, t2) -> - binder_eq b1 b2 && term_eq t1 t2 - - | Tv_Arrow (b1, c1), Tv_Arrow (b2, c2) -> - binder_eq b1 b2 && comp_eq c1 c2 - - | Tv_Type u1, Tv_Type u2 -> - univ_eq u1 u2 - - | Tv_Refine (b1, sort1, t1), Tv_Refine (b2, sort2, t2) -> - (* No need to compare bvs *) - term_eq sort1 sort2 && term_eq t1 t2 - - | Tv_Const c1, Tv_Const c2 -> - const_eq c1 c2 - - | Tv_Uvar (n1, uv1), Tv_Uvar (n2, uv2) -> - (* - * The uvs are completely opaque in userspace, so we could do a fancier - * check here without compromising soundness. But.. we cannot really check - * the unionfind graph, I think, since the result could differ as things get - * unified (though it's unclear if that can happen within two calls to this - * function within a *single* definition.. since uvars do not survive across - * top-levels. - * - * Anyway, for now just compare the associated ints. Which are *definitely* - * visible by users. - *) - n1 = n2 - - | Tv_Let (r1, ats1, bv1, ty1, m1, n1), Tv_Let (r2, ats2, bv2, ty2, m2, n2) -> - (* no need to compare bvs *) - r1 = r2 && - eqlist term_eq ats1 ats2 && - term_eq ty1 ty2 && - term_eq m1 m2 && - term_eq n1 n2 - - | Tv_Match (h1, an1, brs1), Tv_Match (h2, an2, brs2) -> - term_eq h1 h2 && - eqopt match_ret_asc_eq an1 an2 && - eqlist branch_eq brs1 brs2 - - | Tv_AscribedT (e1, t1, topt1, eq1), Tv_AscribedT (e2, t2, topt2, eq2) -> - term_eq e1 e2 && - term_eq t1 t2 && - eqopt term_eq topt1 topt2 && - eq1 = eq2 - - | Tv_AscribedC (e1, c1, topt1, eq1), Tv_AscribedC (e2, c2, topt2, eq2) -> - term_eq e1 e2 && - comp_eq c1 c2 && - eqopt term_eq topt1 topt2 && - eq1 = eq2 - - | Tv_Unknown, Tv_Unknown -> true - | _ -> false - -and arg_eq (arg1 : argv) (arg2 : argv) : bool = - let (a1, aq1) = arg1 in - let (a2, aq2) = arg2 in - term_eq a1 a2 && aqual_eq aq1 aq2 - -and aqual_eq (aq1 : aqualv) (aq2 : aqualv) : bool = - match aq1, aq2 with - | Q_Implicit, Q_Implicit -> true - | Q_Explicit, Q_Explicit -> true - | Q_Meta t1, Q_Meta t2 -> term_eq t1 t2 - | _ -> false - -and binder_eq (b1 : binder) (b2 : binder) : bool = - let bview1 = inspect_binder b1 in - let bview2 = inspect_binder b2 in - binding_bv_eq bview1.binder_bv bview2.binder_bv && - aqual_eq bview1.binder_qual bview2.binder_qual && - eqlist term_eq bview1.binder_attrs bview2.binder_attrs - -and binding_bv_eq (bv1 : bv) (bv2 : bv) : bool = - (* - * In binding ocurrences, we compare the sorts of variables. Not so - * in normal ocurrences, as term_eq does. Note we can access the sort - * safely since it's exactly what inspect_bv does. - * - * We do _not_ compare the indices. This is a binding ocurrence, so - * they do not matter at all. - *) - term_eq bv1.sort bv2.sort - -and bv_eq (bv1 : bv) (bv2 : bv) : bool = - (* - * Just compare the index. Note: this is safe since inspect_bv - * exposes it. We do _not_ compare the sorts. This is already - * what Syntax.Util.term_eq does, and they arguably should not - * be there. - *) - bv1.index = bv2.index - -and comp_eq (c1 : comp) (c2 : comp) : bool = - match inspect_comp c1, inspect_comp c2 with - | C_Total t1, C_Total t2 - | C_GTotal t1, C_GTotal t2 -> - term_eq t1 t2 - - | C_Lemma (pre1, post1, pats1), C_Lemma (pre2, post2, pats2) -> - term_eq pre1 pre2 && term_eq post1 post2 && term_eq pats1 pats2 - - | C_Eff (us1, name1, t1, args1, decrs1), C_Eff (us2, name2, t2, args2, decrs2) -> - univs_eq us1 us2 && - name1 = name2 && - term_eq t1 t2 && - eqlist arg_eq args1 args2 && - eqlist term_eq decrs1 decrs2 - - | _ -> - false - -and match_ret_asc_eq (a1 : match_returns_ascription) (a2 : match_returns_ascription) : bool = - eqprod binder_eq ascription_eq a1 a2 - -and ascription_eq (asc1 : ascription) (asc2 : ascription) : bool = - let (a1, topt1, eq1) = asc1 in - let (a2, topt2, eq2) = asc2 in - (match a1, a2 with - | Inl t1, Inl t2 -> term_eq t1 t2 - | Inr c1, Inr c2 -> comp_eq c1 c2) && - eqopt term_eq topt1 topt2 && - eq1 = eq2 - -and branch_eq (c1 : Data.branch) (c2 : Data.branch) : bool = - eqprod pattern_eq term_eq c1 c2 - -and pattern_eq (p1 : pattern) (p2 : pattern) : bool = - match p1, p2 with - | Pat_Constant c1, Pat_Constant c2 -> - const_eq c1 c2 - | Pat_Cons (fv1, us1, subpats1), Pat_Cons (fv2, us2, subpats2) -> - S.fv_eq fv1 fv2 && - eqopt (eqlist univ_eq) us1 us2 && - eqlist (eqprod pattern_eq (fun b1 b2 -> b1 = b2)) subpats1 subpats2 - - | Pat_Var (bv1, _), Pat_Var (bv2, _) -> - binding_bv_eq bv1 bv2 - - | Pat_Dot_Term topt1, Pat_Dot_Term topt2 -> - eqopt term_eq topt1 topt2 - - | _ -> false - -and const_eq (c1 : vconst) (c2 : vconst) : bool = - c1 = c2 - -and univ_eq (u1 : universe) (u2 : universe) : bool = - Syntax.Util.eq_univs u1 u2 // FIXME! - -and univs_eq (us1 : list universe) (us2 : list universe) : bool = - eqlist univ_eq us1 us2 - -let implode_qn ns = String.concat "." ns -let explode_qn s = String.split ['.'] s -let compare_string s1 s2 = Z.of_int_fs (String.compare s1 s2) - -let push_binder e b = Env.push_binders e [b] - -let subst (x:bv) (n:term) (m:term) : term = - SS.subst [NT(x,n)] m - -let close_term (b:binder) (t:term) : term = SS.close [b] t - -let range_of_term (t:term) = t.pos -let range_of_sigelt (s:sigelt) = s.sigrng diff --git a/src/reflection/FStar.Reflection.V1.Builtins.fsti b/src/reflection/FStar.Reflection.V1.Builtins.fsti deleted file mode 100644 index 8879543b693..00000000000 --- a/src/reflection/FStar.Reflection.V1.Builtins.fsti +++ /dev/null @@ -1,93 +0,0 @@ -(* - Copyright 2008-2015 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Reflection.V1.Builtins - -open FStar.Ident -open FStar.Syntax.Syntax -open FStar.Syntax.Embeddings -open FStar.Order -module Env = FStar.TypeChecker.Env -open FStar.Reflection.V1.Data -open FStar.Compiler.Effect -module O = FStar.Options -module RD = FStar.Reflection.V1.Data -module EMB = FStar.Syntax.Embeddings -module Z = FStar.BigInt -open FStar.VConfig - -(* Primitives *) -val compare_bv : bv -> bv -> order -val lookup_typ : Env.env -> list string -> option sigelt -val lookup_attr : term -> Env.env -> list fv -val all_defs_in_env : Env.env -> list fv -val defs_in_module : Env.env -> name -> list fv -val binders_of_env : Env.env -> binders -val moduleof : Env.env -> list string -val term_eq : term -> term -> bool -val env_open_modules : Env.env -> list name -val sigelt_opts : sigelt -> option vconfig -val embed_vconfig : vconfig -> term - -val sigelt_attrs : sigelt -> list attribute -val set_sigelt_attrs : list attribute -> sigelt -> sigelt - -val sigelt_quals : sigelt -> list RD.qualifier -val set_sigelt_quals : list RD.qualifier -> sigelt -> sigelt - -(* Views *) -val inspect_fv : fv -> list string -val pack_fv : list string -> fv - -val inspect_const : sconst -> vconst -val pack_const : vconst -> sconst - -val inspect_ln : term -> term_view -val pack_ln : term_view -> term - -val inspect_comp : comp -> comp_view -val pack_comp : comp_view -> comp - -val inspect_sigelt : sigelt -> sigelt_view -val pack_sigelt : sigelt_view -> sigelt - -val inspect_lb : letbinding -> lb_view -val pack_lb : lb_view -> letbinding - -val inspect_bv : bv -> bv_view -val pack_bv : bv_view -> bv - -val inspect_binder : binder -> binder_view -val pack_binder : binder_view -> binder - -val inspect_aqual : aqual -> aqualv -val pack_aqual : aqualv -> aqual - -val inspect_universe : universe -> universe_view -val pack_universe : universe_view -> universe - -val subst : bv -> term -> term -> term -val close_term : binder -> term -> term - -(* We're only taking these as primitives to break the dependency from * -FStar.Tactics into FStar.String, which pulls a LOT of modules. *) -val implode_qn : list string -> string -val explode_qn : string -> list string -val compare_string : string -> string -> Z.t - -val push_binder : Env.env -> binder -> Env.env - -val range_of_term : term -> FStar.Compiler.Range.range -val range_of_sigelt : sigelt -> FStar.Compiler.Range.range diff --git a/src/reflection/FStar.Reflection.V1.Constants.fst b/src/reflection/FStar.Reflection.V1.Constants.fst deleted file mode 100644 index ca64883294b..00000000000 --- a/src/reflection/FStar.Reflection.V1.Constants.fst +++ /dev/null @@ -1,258 +0,0 @@ -(* - Copyright 2008-2022 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Reflection.V1.Constants - - -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List - -(* NOTE: This file is exactly the same as its .fs variant. It is only -here so the equally-named interface file in ulib/ is not taken by the -dependency analysis to be the interface of the .fs. We also cannot ditch -the .fs, since out bootstrapping process does not extract any .ml file -from an interface. Hence we keep both, exactly equal to each other. *) - -open FStar.Syntax.Syntax -module Ident = FStar.Ident -module Range = FStar.Compiler.Range -module Z = FStar.BigInt -open FStar.Ident -module PC = FStar.Parser.Const - -(* Contains all lids and terms needed for embedding/unembedding *) - -type refl_constant = { - lid : FStar.Ident.lid; - fv : fv; - t : term; -} - -let refl_constant_lid rc = rc.lid -let refl_constant_term rc = rc.t -let fstar_refl_lid s = Ident.lid_of_path (["FStar"; "Stubs"; "Reflection"]@s) Range.dummyRange - -let fstar_refl_types_lid s = fstar_refl_lid ["Types"; s] -let fstar_refl_builtins_lid s = fstar_refl_lid ["V1"; "Builtins"; s] -let fstar_refl_data_lid s = fstar_refl_lid ["V1"; "Data"; s] - -let fstar_refl_data_const s = - let lid = fstar_refl_data_lid s in - { lid = lid - ; fv = lid_as_fv lid (Some Data_ctor) - ; t = tdataconstr lid - } - -let mk_refl_types_lid_as_term (s:string) = tconst (fstar_refl_types_lid s) -let mk_refl_types_lid_as_fv (s:string) = fvconst (fstar_refl_types_lid s) -let mk_refl_data_lid_as_term (s:string) = tconst (fstar_refl_data_lid s) -let mk_refl_data_lid_as_fv (s:string) = fvconst (fstar_refl_data_lid s) - -let mk_inspect_pack_pair s = - let inspect_lid = fstar_refl_builtins_lid ("inspect" ^ s) in - let pack_lid = fstar_refl_builtins_lid ("pack" ^ s) in - let inspect_fv = lid_as_fv inspect_lid None in - let pack_fv = lid_as_fv pack_lid None in - let inspect = { lid = inspect_lid ; fv = inspect_fv ; t = fv_to_tm inspect_fv } in - let pack = { lid = pack_lid ; fv = pack_fv ; t = fv_to_tm pack_fv } in - (inspect, pack) - -let fstar_refl_inspect_ln , fstar_refl_pack_ln = mk_inspect_pack_pair "_ln" -let fstar_refl_inspect_fv , fstar_refl_pack_fv = mk_inspect_pack_pair "_fv" -let fstar_refl_inspect_bv , fstar_refl_pack_bv = mk_inspect_pack_pair "_bv" -let fstar_refl_inspect_binder , fstar_refl_pack_binder = mk_inspect_pack_pair "_binder" -let fstar_refl_inspect_comp , fstar_refl_pack_comp = mk_inspect_pack_pair "_comp" -let fstar_refl_inspect_sigelt , fstar_refl_pack_sigelt = mk_inspect_pack_pair "_sigelt" -let fstar_refl_inspect_lb , fstar_refl_pack_lb = mk_inspect_pack_pair "_lb" -let fstar_refl_inspect_universe, fstar_refl_pack_universe = mk_inspect_pack_pair "_universe" - -(* assumed types *) -let fstar_refl_env = mk_refl_types_lid_as_term "env" -let fstar_refl_env_fv = mk_refl_types_lid_as_fv "env" -let fstar_refl_bv = mk_refl_types_lid_as_term "bv" -let fstar_refl_bv_fv = mk_refl_types_lid_as_fv "bv" -let fstar_refl_fv = mk_refl_types_lid_as_term "fv" -let fstar_refl_fv_fv = mk_refl_types_lid_as_fv "fv" -let fstar_refl_comp = mk_refl_types_lid_as_term "comp" -let fstar_refl_comp_fv = mk_refl_types_lid_as_fv "comp" -let fstar_refl_binder = mk_refl_types_lid_as_term "binder" -let fstar_refl_binder_fv = mk_refl_types_lid_as_fv "binder" -let fstar_refl_sigelt = mk_refl_types_lid_as_term "sigelt" -let fstar_refl_sigelt_fv = mk_refl_types_lid_as_fv "sigelt" -let fstar_refl_term = mk_refl_types_lid_as_term "term" -let fstar_refl_term_fv = mk_refl_types_lid_as_fv "term" -let fstar_refl_letbinding = mk_refl_types_lid_as_term "letbinding" -let fstar_refl_letbinding_fv = mk_refl_types_lid_as_fv "letbinding" -let fstar_refl_ident = mk_refl_types_lid_as_term "ident" -let fstar_refl_ident_fv = mk_refl_types_lid_as_fv "ident" -let fstar_refl_univ_name = mk_refl_types_lid_as_term "univ_name" -let fstar_refl_univ_name_fv = mk_refl_types_lid_as_fv "univ_name" -let fstar_refl_optionstate = mk_refl_types_lid_as_term "optionstate" -let fstar_refl_optionstate_fv = mk_refl_types_lid_as_fv "optionstate" -let fstar_refl_universe = mk_refl_types_lid_as_term "universe" -let fstar_refl_universe_fv = mk_refl_types_lid_as_fv "universe" - -(* auxiliary types *) -let fstar_refl_aqualv = mk_refl_data_lid_as_term "aqualv" -let fstar_refl_aqualv_fv = mk_refl_data_lid_as_fv "aqualv" -let fstar_refl_comp_view = mk_refl_data_lid_as_term "comp_view" -let fstar_refl_comp_view_fv = mk_refl_data_lid_as_fv "comp_view" -let fstar_refl_term_view = mk_refl_data_lid_as_term "term_view" -let fstar_refl_term_view_fv = mk_refl_data_lid_as_fv "term_view" -let fstar_refl_pattern = mk_refl_data_lid_as_term "pattern" -let fstar_refl_pattern_fv = mk_refl_data_lid_as_fv "pattern" -let fstar_refl_branch = mk_refl_data_lid_as_term "branch" -let fstar_refl_branch_fv = mk_refl_data_lid_as_fv "branch" -let fstar_refl_bv_view = mk_refl_data_lid_as_term "bv_view" -let fstar_refl_bv_view_fv = mk_refl_data_lid_as_fv "bv_view" -let fstar_refl_binder_view = mk_refl_data_lid_as_term "binder_view" -let fstar_refl_binder_view_fv = mk_refl_data_lid_as_fv "binder_view" -let fstar_refl_vconst = mk_refl_data_lid_as_term "vconst" -let fstar_refl_vconst_fv = mk_refl_data_lid_as_fv "vconst" -let fstar_refl_lb_view = mk_refl_data_lid_as_term "lb_view" -let fstar_refl_lb_view_fv = mk_refl_data_lid_as_fv "lb_view" -let fstar_refl_sigelt_view = mk_refl_data_lid_as_term "sigelt_view" -let fstar_refl_sigelt_view_fv = mk_refl_data_lid_as_fv "sigelt_view" -let fstar_refl_qualifier = mk_refl_data_lid_as_term "qualifier" -let fstar_refl_qualifier_fv = mk_refl_data_lid_as_fv "qualifier" -let fstar_refl_universe_view = mk_refl_data_lid_as_term "universe_view" -let fstar_refl_universe_view_fv = mk_refl_data_lid_as_fv "universe_view" - -(* bv_view, this is a record constructor *) - -let ref_Mk_bv = - let lid = fstar_refl_data_lid "Mkbv_view" in - let attr = Record_ctor (fstar_refl_data_lid "bv_view", [ - Ident.mk_ident ("bv_ppname", Range.dummyRange); - Ident.mk_ident ("bv_index" , Range.dummyRange)]) in - let fv = lid_as_fv lid (Some attr) in - { lid = lid - ; fv = fv - ; t = fv_to_tm fv - } - -let ref_Mk_binder = - let lid = fstar_refl_data_lid "Mkbinder_view" in - let attr = Record_ctor (fstar_refl_data_lid "binder_view", [ - Ident.mk_ident ("binder_bv", Range.dummyRange); - Ident.mk_ident ("binder_qual", Range.dummyRange); - Ident.mk_ident ("binder_attrs", Range.dummyRange); - Ident.mk_ident ("binder_sort" , Range.dummyRange)]) in - let fv = lid_as_fv lid (Some attr) in - { lid = lid; - fv = fv; - t = fv_to_tm fv } - -let ref_Mk_lb = - let lid = fstar_refl_data_lid "Mklb_view" in - let attr = Record_ctor (fstar_refl_data_lid "lb_view", [ - Ident.mk_ident ("lb_fv" , Range.dummyRange); - Ident.mk_ident ("lb_us" , Range.dummyRange); - Ident.mk_ident ("lb_typ" , Range.dummyRange); - Ident.mk_ident ("lb_def" , Range.dummyRange) - ]) in - let fv = lid_as_fv lid (Some attr) in - { lid = lid - ; fv = fv - ; t = fv_to_tm fv - } - -(* quals *) -let ref_Q_Explicit = fstar_refl_data_const "Q_Explicit" -let ref_Q_Implicit = fstar_refl_data_const "Q_Implicit" -let ref_Q_Meta = fstar_refl_data_const "Q_Meta" - -(* const *) -let ref_C_Unit = fstar_refl_data_const "C_Unit" -let ref_C_True = fstar_refl_data_const "C_True" -let ref_C_False = fstar_refl_data_const "C_False" -let ref_C_Int = fstar_refl_data_const "C_Int" -let ref_C_String = fstar_refl_data_const "C_String" -let ref_C_Range = fstar_refl_data_const "C_Range" -let ref_C_Reify = fstar_refl_data_const "C_Reify" -let ref_C_Reflect = fstar_refl_data_const "C_Reflect" - -(* pattern *) -let ref_Pat_Constant = fstar_refl_data_const "Pat_Constant" -let ref_Pat_Cons = fstar_refl_data_const "Pat_Cons" -let ref_Pat_Var = fstar_refl_data_const "Pat_Var" -let ref_Pat_Dot_Term = fstar_refl_data_const "Pat_Dot_Term" - -(* universe_view *) -let ref_Uv_Zero = fstar_refl_data_const "Uv_Zero" -let ref_Uv_Succ = fstar_refl_data_const "Uv_Succ" -let ref_Uv_Max = fstar_refl_data_const "Uv_Max" -let ref_Uv_BVar = fstar_refl_data_const "Uv_BVar" -let ref_Uv_Name = fstar_refl_data_const "Uv_Name" -let ref_Uv_Unif = fstar_refl_data_const "Uv_Unif" -let ref_Uv_Unk = fstar_refl_data_const "Uv_Unk" - -(* term_view *) -let ref_Tv_Var = fstar_refl_data_const "Tv_Var" -let ref_Tv_BVar = fstar_refl_data_const "Tv_BVar" -let ref_Tv_FVar = fstar_refl_data_const "Tv_FVar" -let ref_Tv_UInst = fstar_refl_data_const "Tv_UInst" -let ref_Tv_App = fstar_refl_data_const "Tv_App" -let ref_Tv_Abs = fstar_refl_data_const "Tv_Abs" -let ref_Tv_Arrow = fstar_refl_data_const "Tv_Arrow" -let ref_Tv_Type = fstar_refl_data_const "Tv_Type" -let ref_Tv_Refine = fstar_refl_data_const "Tv_Refine" -let ref_Tv_Const = fstar_refl_data_const "Tv_Const" -let ref_Tv_Uvar = fstar_refl_data_const "Tv_Uvar" -let ref_Tv_Let = fstar_refl_data_const "Tv_Let" -let ref_Tv_Match = fstar_refl_data_const "Tv_Match" -let ref_Tv_AscT = fstar_refl_data_const "Tv_AscribedT" -let ref_Tv_AscC = fstar_refl_data_const "Tv_AscribedC" -let ref_Tv_Unknown = fstar_refl_data_const "Tv_Unknown" -let ref_Tv_Unsupp = fstar_refl_data_const "Tv_Unsupp" - -(* comp_view *) -let ref_C_Total = fstar_refl_data_const "C_Total" -let ref_C_GTotal = fstar_refl_data_const "C_GTotal" -let ref_C_Lemma = fstar_refl_data_const "C_Lemma" -let ref_C_Eff = fstar_refl_data_const "C_Eff" - -(* inductives & sigelts *) -let ref_Sg_Let = fstar_refl_data_const "Sg_Let" -let ref_Sg_Inductive = fstar_refl_data_const "Sg_Inductive" -let ref_Sg_Val = fstar_refl_data_const "Sg_Val" -let ref_Unk = fstar_refl_data_const "Unk" - -(* qualifiers *) -let ref_qual_Assumption = fstar_refl_data_const "Assumption" -let ref_qual_InternalAssumption = fstar_refl_data_const "InternalAssumption" -let ref_qual_New = fstar_refl_data_const "New" -let ref_qual_Private = fstar_refl_data_const "Private" -let ref_qual_Unfold_for_unification_and_vcgen = fstar_refl_data_const "Unfold_for_unification_and_vcgen" -let ref_qual_Visible_default = fstar_refl_data_const "Visible_default" -let ref_qual_Irreducible = fstar_refl_data_const "Irreducible" -let ref_qual_Inline_for_extraction = fstar_refl_data_const "Inline_for_extraction" -let ref_qual_NoExtract = fstar_refl_data_const "NoExtract" -let ref_qual_Noeq = fstar_refl_data_const "Noeq" -let ref_qual_Unopteq = fstar_refl_data_const "Unopteq" -let ref_qual_TotalEffect = fstar_refl_data_const "TotalEffect" -let ref_qual_Logic = fstar_refl_data_const "Logic" -let ref_qual_Reifiable = fstar_refl_data_const "Reifiable" -let ref_qual_Reflectable = fstar_refl_data_const "Reflectable" -let ref_qual_Discriminator = fstar_refl_data_const "Discriminator" -let ref_qual_Projector = fstar_refl_data_const "Projector" -let ref_qual_RecordType = fstar_refl_data_const "RecordType" -let ref_qual_RecordConstructor = fstar_refl_data_const "RecordConstructor" -let ref_qual_Action = fstar_refl_data_const "Action" -let ref_qual_ExceptionConstructor = fstar_refl_data_const "ExceptionConstructor" -let ref_qual_HasMaskedEffect = fstar_refl_data_const "HasMaskedEffect" -let ref_qual_Effect = fstar_refl_data_const "Effect" -let ref_qual_OnlyName = fstar_refl_data_const "OnlyName" diff --git a/src/reflection/FStar.Reflection.V1.Data.fst b/src/reflection/FStar.Reflection.V1.Data.fst deleted file mode 100644 index 14c19eac0f6..00000000000 --- a/src/reflection/FStar.Reflection.V1.Data.fst +++ /dev/null @@ -1,44 +0,0 @@ -(* - Copyright 2008-2022 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Reflection.V1.Data - -(* NOTE: This file is exactly the same as its .fs/.fsi counterpart. -It is only here so the equally-named interface file in ulib/ is not -taken by the dependency analysis to be the interface of the .fs. We also -cannot ditch the .fs, since out bootstrapping process does not extract -any .ml file from an interface. Hence we keep both, exactly equal to -each other. *) -open FStar.Compiler.List -open FStar.Syntax.Syntax -module Ident = FStar.Ident -module Range = FStar.Compiler.Range -module Z = FStar.BigInt -open FStar.Ident - -(* These two functions are in ulib/FStar.Reflection.V1.Data.fsti - But, they are not extracted from there. - - Instead, these functions are extraction from this file. It is - not sufficient to place these functions in the interface - src/reflection/FStar.Reflection.V1.Data.fsti since this module, like the - rest of the compiler, is extracted in MLish mode. Which means that - functions in the interface are not supported for extraction. So, - we include them in this module implementation file to force them - to be extracted *) -let as_ppname (x:string) : Tot ppname_t = FStar.Compiler.Sealed.seal x - -let notAscription (tv:term_view) : Tot bool = - not (Tv_AscribedT? tv) && not (Tv_AscribedC? tv) diff --git a/src/reflection/FStar.Reflection.V1.Data.fsti b/src/reflection/FStar.Reflection.V1.Data.fsti deleted file mode 100644 index 19b344398aa..00000000000 --- a/src/reflection/FStar.Reflection.V1.Data.fsti +++ /dev/null @@ -1,172 +0,0 @@ -(* - Copyright 2008-2022 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Reflection.V1.Data - -(* NOTE: This file is exactly the same as its .fs/.fsi counterpart. -It is only here so the equally-named interface file in ulib/ is not -taken by the dependency analysis to be the interface of the .fs. We also -cannot ditch the .fs, since out bootstrapping process does not extract -any .ml file from an interface. Hence we keep both, exactly equal to -each other. *) -open FStar.Compiler.List -open FStar.Syntax.Syntax -open FStar.Compiler.Sealed -module Ident = FStar.Ident -module Range = FStar.Compiler.Range -module Z = FStar.BigInt -open FStar.Ident - -type name = list string -type typ = term -type binders = list binder -type ident = string & Range.range -type univ_name = ident - -type vconst = - | C_Unit - | C_Int of Z.t - | C_True - | C_False - | C_String of string - | C_Range of Range.range - | C_Reify - | C_Reflect of name - -type universes = list universe - -type pattern = - | Pat_Constant of vconst - | Pat_Cons of fv & option (list universe) & list (pattern & bool) - | Pat_Var of bv & sealed typ - | Pat_Dot_Term of option term - -type branch = pattern & term - -type aqualv = - | Q_Implicit - | Q_Explicit - | Q_Meta of term - -type argv = term & aqualv - -type ppname_t = sealed string -val as_ppname (s:string) : Tot ppname_t - -type bv_view = { - bv_ppname : ppname_t; - bv_index : Z.t; -} - -type binder_view = { - binder_bv : bv; - binder_qual : aqualv; - binder_attrs : list term; - binder_sort : typ; -} - -type universe_view = - | Uv_Zero : universe_view - | Uv_Succ : universe -> universe_view - | Uv_Max : universes -> universe_view - | Uv_BVar : Z.t -> universe_view - | Uv_Name : (string & Range.range) -> universe_view - | Uv_Unif : universe_uvar -> universe_view - | Uv_Unk : universe_view - -type term_view = - | Tv_Var of bv - | Tv_BVar of bv - | Tv_FVar of fv - | Tv_UInst of fv & universes - | Tv_App of term & argv - | Tv_Abs of binder & term - | Tv_Arrow of binder & comp - | Tv_Type of universe - | Tv_Refine of bv & typ & term - | Tv_Const of vconst - | Tv_Uvar of Z.t & ctx_uvar_and_subst - | Tv_Let of bool & list term & bv & typ & term & term - | Tv_Match of term & option match_returns_ascription & list branch - | Tv_AscribedT of term & term & option term & bool //if the boolean flag is true, the ascription is an equality ascription - //see also Syntax - | Tv_AscribedC of term & comp & option term & bool //bool is similar to Tv_AscribedT - | Tv_Unknown - | Tv_Unsupp - -val notAscription (t:term_view) : Tot bool - -type comp_view = - | C_Total of typ - | C_GTotal of typ - | C_Lemma of term & term & term - | C_Eff of universes & name & term & list argv & list term // list term is the decreases clause - -type ctor = name & typ - -type lb_view = { - lb_fv : fv; - lb_us : list univ_name; - lb_typ : typ; - lb_def : term -} - -type sigelt_view = - | Sg_Let of bool & list letbinding - // The bool indicates if it's a let rec - // Non-empty list of (possibly) mutually recursive let-bindings - | Sg_Inductive of name & list univ_name & list binder & typ & list ctor // name, params, type, constructors - | Sg_Val of name & list univ_name & typ - | Unk - - -(* This is a mirror of FStar.Syntax.Syntax.qualifier *) -type qualifier = - | Assumption - | InternalAssumption - | New - | Private - | Unfold_for_unification_and_vcgen - | Visible_default - | Irreducible - | Inline_for_extraction - | NoExtract - | Noeq - | Unopteq - | TotalEffect - | Logic - | Reifiable - | Reflectable of name - | Discriminator of name - | Projector of name & ident - | RecordType of (list ident & list ident) - | RecordConstructor of (list ident & list ident) - | Action of name - | ExceptionConstructor - | HasMaskedEffect - | Effect - | OnlyName - -type qualifiers = list qualifier - -type var = Z.t - -type exp = - | Unit - | Var of var - | Mult of exp & exp - -(* Needed so this appears in the ocaml output for the fstar tactics library *) -type decls = list sigelt diff --git a/src/reflection/FStar.Reflection.V1.Embeddings.fst b/src/reflection/FStar.Reflection.V1.Embeddings.fst deleted file mode 100644 index ed658ac6c70..00000000000 --- a/src/reflection/FStar.Reflection.V1.Embeddings.fst +++ /dev/null @@ -1,920 +0,0 @@ -(* - Copyright 2008-2022 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Reflection.V1.Embeddings - -open FStar.Compiler.Effect -open FStar.Reflection.V1.Data -open FStar.Syntax.Syntax -open FStar.Syntax.Embeddings -open FStar.Order -open FStar.Errors - -module BU = FStar.Compiler.Util -module EMB = FStar.Syntax.Embeddings -module Env = FStar.TypeChecker.Env -module Err = FStar.Errors -module I = FStar.Ident -module List = FStar.Compiler.List -module NBETerm = FStar.TypeChecker.NBETerm -module O = FStar.Options -module PC = FStar.Parser.Const -module Print = FStar.Syntax.Print -module Range = FStar.Compiler.Range -module RD = FStar.Reflection.V1.Data -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module U = FStar.Syntax.Util -module Z = FStar.BigInt - -module EmbV2 = FStar.Reflection.V2.Embeddings - -open FStar.Dyn -open FStar.Reflection.V1.Builtins //needed for inspect_fv, but that feels wrong -open FStar.Reflection.V1.Constants - -(* - * embed : from compiler to user - * unembed : from user to compiler - *) - -let noaqs : antiquotations = (0, []) - -(* -------------------------------------------------------------------------------------- *) -(* ------------------------------------- EMBEDDINGS ------------------------------------- *) -(* -------------------------------------------------------------------------------------- *) -let mk_emb f g t = - mk_emb (fun x r _topt _norm -> f r x) - (fun x _norm -> g x) - (EMB.term_as_fv t) -let embed {|embedding 'a|} r (x:'a) = embed x r None id_norm_cb -let unembed {|embedding 'a|} x : option 'a = try_unembed x id_norm_cb - -(* Abstract, reexport *) -let e_bv = EmbV2.e_bv -let e_binder = EmbV2.e_binder -let e_term_aq = EmbV2.e_term_aq -let e_term = EmbV2.e_term -let e_binders = EmbV2.e_binders -let e_fv = EmbV2.e_fv -let e_comp = EmbV2.e_comp -let e_universe = EmbV2.e_universe - -instance e_aqualv = - let embed_aqualv (rng:Range.range) (q : aqualv) : term = - let r = - match q with - | Data.Q_Explicit -> ref_Q_Explicit.t - | Data.Q_Implicit -> ref_Q_Implicit.t - | Data.Q_Meta t -> - S.mk_Tm_app ref_Q_Meta.t [S.as_arg (embed #_ #e_term rng t)] - Range.dummyRange - in { r with pos = rng } - in - let unembed_aqualv (t : term) : option aqualv = - let t = U.unascribe t in - let hd, args = U.head_and_args t in - match (U.un_uinst hd).n, args with - | Tm_fvar fv, [] when S.fv_eq_lid fv ref_Q_Explicit.lid -> Some Data.Q_Explicit - | Tm_fvar fv, [] when S.fv_eq_lid fv ref_Q_Implicit.lid -> Some Data.Q_Implicit - | Tm_fvar fv, [(t, _)] when S.fv_eq_lid fv ref_Q_Meta.lid -> - BU.bind_opt (unembed #_ #e_term t) (fun t -> - Some (Data.Q_Meta t)) - - | _ -> - None - in - mk_emb embed_aqualv unembed_aqualv fstar_refl_aqualv - -instance e_ident : embedding RD.ident = - e_tuple2 e_string e_range - -instance e_universe_view = - let embed_universe_view (rng:Range.range) (uv:universe_view) : term = - match uv with - | Uv_Zero -> ref_Uv_Zero.t - | Uv_Succ u -> - S.mk_Tm_app - ref_Uv_Succ.t - [S.as_arg (embed rng u)] - rng - | Uv_Max us -> - S.mk_Tm_app - ref_Uv_Max.t - [S.as_arg (embed rng us)] - rng - | Uv_BVar n -> - S.mk_Tm_app - ref_Uv_BVar.t - [S.as_arg (embed rng n)] - rng - | Uv_Name i -> - S.mk_Tm_app - ref_Uv_Name.t - [S.as_arg (embed rng i)] - rng - | Uv_Unif u -> - S.mk_Tm_app - ref_Uv_Unif.t - [S.as_arg (U.mk_lazy u U.t_universe_uvar Lazy_universe_uvar None)] - rng - | Uv_Unk -> - ref_Uv_Unk.t in - - let unembed_universe_view (t:term) : option universe_view = - let t = U.unascribe t in - let hd, args = U.head_and_args t in - match (U.un_uinst hd).n, args with - | Tm_fvar fv, [] when S.fv_eq_lid fv ref_Uv_Zero.lid -> Some Uv_Zero - | Tm_fvar fv, [u, _] when S.fv_eq_lid fv ref_Uv_Succ.lid -> - BU.bind_opt (unembed u) (fun u -> u |> Uv_Succ |> Some) - | Tm_fvar fv, [us, _] when S.fv_eq_lid fv ref_Uv_Max.lid -> - BU.bind_opt (unembed us) (fun us -> us |> Uv_Max |> Some) - | Tm_fvar fv, [n, _] when S.fv_eq_lid fv ref_Uv_BVar.lid -> - BU.bind_opt (unembed n) (fun n -> n |> Uv_BVar |> Some) - | Tm_fvar fv, [i, _] when S.fv_eq_lid fv ref_Uv_Name.lid -> - BU.bind_opt (unembed i) (fun i -> i |> Uv_Name |> Some) - | Tm_fvar fv, [u, _] when S.fv_eq_lid fv ref_Uv_Unif.lid -> - let u : universe_uvar = U.unlazy_as_t Lazy_universe_uvar u in - u |> Uv_Unif |> Some - | Tm_fvar fv, [] when S.fv_eq_lid fv ref_Uv_Unk.lid -> Some Uv_Unk - | _ -> - None in - - mk_emb embed_universe_view unembed_universe_view fstar_refl_universe_view - -let e_env = - let embed_env (rng:Range.range) (e:Env.env) : term = - U.mk_lazy e fstar_refl_env Lazy_env (Some rng) - in - let unembed_env (t:term) : option Env.env = - match (SS.compress t).n with - | Tm_lazy {blob=b; lkind=Lazy_env} -> - Some (undyn b) - | _ -> - None - in - mk_emb embed_env unembed_env fstar_refl_env - -instance e_const = - let embed_const (rng:Range.range) (c:vconst) : term = - let r = - match c with - | C_Unit -> ref_C_Unit.t - | C_True -> ref_C_True.t - | C_False -> ref_C_False.t - - | C_Int i -> - S.mk_Tm_app ref_C_Int.t [S.as_arg (U.exp_int (Z.string_of_big_int i))] - Range.dummyRange - | C_String s -> - S.mk_Tm_app ref_C_String.t [S.as_arg (embed rng s)] - Range.dummyRange - - | C_Range r -> - S.mk_Tm_app ref_C_Range.t [S.as_arg (embed rng r)] - Range.dummyRange - - | C_Reify -> ref_C_Reify.t - - | C_Reflect ns -> - S.mk_Tm_app ref_C_Reflect.t [S.as_arg (embed rng ns)] - Range.dummyRange - - in { r with pos = rng } - in - let unembed_const (t:term) : option vconst = - let t = U.unascribe t in - let hd, args = U.head_and_args t in - match (U.un_uinst hd).n, args with - | Tm_fvar fv, [] when S.fv_eq_lid fv ref_C_Unit.lid -> - Some C_Unit - - | Tm_fvar fv, [] when S.fv_eq_lid fv ref_C_True.lid -> - Some C_True - - | Tm_fvar fv, [] when S.fv_eq_lid fv ref_C_False.lid -> - Some C_False - - | Tm_fvar fv, [(i, _)] when S.fv_eq_lid fv ref_C_Int.lid -> - BU.bind_opt (unembed i) (fun i -> - Some <| C_Int i) - - | Tm_fvar fv, [(s, _)] when S.fv_eq_lid fv ref_C_String.lid -> - BU.bind_opt (unembed s) (fun s -> - Some <| C_String s) - - | Tm_fvar fv, [(r, _)] when S.fv_eq_lid fv ref_C_Range.lid -> - BU.bind_opt (unembed r) (fun r -> - Some <| C_Range r) - - | Tm_fvar fv, [] when S.fv_eq_lid fv ref_C_Reify.lid -> - Some <| C_Reify - - | Tm_fvar fv, [(ns, _)] when S.fv_eq_lid fv ref_C_Reflect.lid -> - BU.bind_opt (unembed ns) (fun ns -> - Some <| C_Reflect ns) - - | _ -> - None - in - mk_emb embed_const unembed_const fstar_refl_vconst - -let rec e_pattern_aq aq = - let rec embed_pattern (rng:Range.range) (p : pattern) : term = - match p with - | Pat_Constant c -> - S.mk_Tm_app ref_Pat_Constant.t [S.as_arg (embed rng c)] rng - | Pat_Cons (fv, us_opt, ps) -> - S.mk_Tm_app ref_Pat_Cons.t - [S.as_arg (embed rng fv); - S.as_arg (embed rng us_opt); - S.as_arg (embed #_ #(e_list (e_tuple2 (e_pattern_aq aq) e_bool)) rng ps)] rng - | Pat_Var (bv, sort) -> - S.mk_Tm_app ref_Pat_Var.t [S.as_arg (embed #_ #e_bv rng bv); S.as_arg (embed #_ #(e_sealed e_term) rng sort)] rng - | Pat_Dot_Term eopt -> - S.mk_Tm_app ref_Pat_Dot_Term.t [S.as_arg (embed #_ #(e_option e_term) rng eopt)] - rng - in - let rec unembed_pattern (t : term) : option pattern = - let t = U.unascribe t in - let hd, args = U.head_and_args t in - match (U.un_uinst hd).n, args with - | Tm_fvar fv, [(c, _)] when S.fv_eq_lid fv ref_Pat_Constant.lid -> - BU.bind_opt (unembed c) (fun c -> - Some <| Pat_Constant c) - - | Tm_fvar fv, [(f, _); (us_opt, _); (ps, _)] when S.fv_eq_lid fv ref_Pat_Cons.lid -> - BU.bind_opt (unembed f) (fun f -> - BU.bind_opt (unembed us_opt) (fun us_opt -> - BU.bind_opt (unembed #_ #(e_list (e_tuple2 (e_pattern_aq aq) e_bool)) ps) (fun ps -> - Some <| Pat_Cons (f, us_opt, ps)))) - - | Tm_fvar fv, [(bv, _); (sort, _)] when S.fv_eq_lid fv ref_Pat_Var.lid -> - BU.bind_opt (unembed #_ #e_bv bv) (fun bv -> - BU.bind_opt (unembed #_ #(e_sealed e_term) sort) (fun sort -> - Some <| Pat_Var (bv, sort))) - - | Tm_fvar fv, [(eopt, _)] when S.fv_eq_lid fv ref_Pat_Dot_Term.lid -> - BU.bind_opt (unembed #_ #(e_option e_term) eopt) (fun eopt -> - Some <| Pat_Dot_Term eopt) - - | _ -> - None - in - mk_emb embed_pattern unembed_pattern fstar_refl_pattern - -let e_pattern = e_pattern_aq noaqs - -let e_branch = e_tuple2 e_pattern e_term -let e_argv = e_tuple2 e_term e_aqualv - -let e_args = e_list e_argv - -let e_branch_aq aq = e_tuple2 (e_pattern_aq aq) (e_term_aq aq) -let e_argv_aq aq = e_tuple2 (e_term_aq aq) e_aqualv - -let e_match_returns_annotation = - e_option (e_tuple2 e_binder - (e_tuple3 (e_either e_term e_comp) (e_option e_term) e_bool)) - -let e_term_view_aq aq = - let push (s, aq) = (s+1, aq) in - let embed_term_view (rng:Range.range) (t:term_view) : term = - match t with - | Tv_FVar fv -> - S.mk_Tm_app ref_Tv_FVar.t [S.as_arg (embed rng fv)] - rng - - | Tv_BVar fv -> - S.mk_Tm_app ref_Tv_BVar.t [S.as_arg (embed #_ #e_bv rng fv)] - rng - - | Tv_Var bv -> - S.mk_Tm_app ref_Tv_Var.t [S.as_arg (embed #_ #e_bv rng bv)] - rng - - | Tv_UInst (fv, us) -> - S.mk_Tm_app - ref_Tv_UInst.t - [S.as_arg (embed rng fv); - S.as_arg (embed rng us)] - rng - - | Tv_App (hd, a) -> - S.mk_Tm_app ref_Tv_App.t [S.as_arg (embed #_ #(e_term_aq aq) rng hd); S.as_arg (embed #_ #(e_argv_aq aq) rng a)] - rng - - | Tv_Abs (b, t) -> - S.mk_Tm_app ref_Tv_Abs.t [S.as_arg (embed rng b); S.as_arg (embed #_ #(e_term_aq (push aq)) rng t)] - rng - - | Tv_Arrow (b, c) -> - S.mk_Tm_app ref_Tv_Arrow.t [S.as_arg (embed rng b); S.as_arg (embed rng c)] - rng - - | Tv_Type u -> - S.mk_Tm_app ref_Tv_Type.t [S.as_arg (embed rng u)] - rng - - | Tv_Refine (bv, s, t) -> - S.mk_Tm_app ref_Tv_Refine.t [S.as_arg (embed #_ #e_bv rng bv); - S.as_arg (embed #_ #(e_term_aq aq) rng s); - S.as_arg (embed #_ #(e_term_aq (push aq)) rng t)] - rng - - | Tv_Const c -> - S.mk_Tm_app ref_Tv_Const.t [S.as_arg (embed rng c)] - rng - - | Tv_Uvar (u, d) -> - S.mk_Tm_app ref_Tv_Uvar.t - [S.as_arg (embed rng u); - S.as_arg (U.mk_lazy (u,d) U.t_ctx_uvar_and_sust Lazy_uvar None)] - rng - - | Tv_Let (r, attrs, b, ty, t1, t2) -> - S.mk_Tm_app ref_Tv_Let.t [S.as_arg (embed rng r); - S.as_arg (embed #_ #(e_list e_term) rng attrs); - S.as_arg (embed #_ #e_bv rng b); - S.as_arg (embed #_ #(e_term_aq aq) rng ty); - S.as_arg (embed #_ #(e_term_aq aq) rng t1); - S.as_arg (embed #_ #(e_term_aq (push aq)) rng t2)] - rng - - | Tv_Match (t, ret_opt, brs) -> - S.mk_Tm_app ref_Tv_Match.t [S.as_arg (embed #_ #(e_term_aq aq) rng t); - S.as_arg (embed #_ #e_match_returns_annotation rng ret_opt); - S.as_arg (embed #_ #(e_list (e_branch_aq aq)) rng brs)] - rng - - | Tv_AscribedT (e, t, tacopt, use_eq) -> - S.mk_Tm_app ref_Tv_AscT.t - [S.as_arg (embed #_ #(e_term_aq aq) rng e); - S.as_arg (embed #_ #(e_term_aq aq) rng t); - S.as_arg (embed #_ #(e_option (e_term_aq aq)) rng tacopt); - S.as_arg (embed rng use_eq)] - rng - - | Tv_AscribedC (e, c, tacopt, use_eq) -> - S.mk_Tm_app ref_Tv_AscC.t - [S.as_arg (embed #_ #(e_term_aq aq) rng e); - S.as_arg (embed rng c); - S.as_arg (embed #_ #(e_option (e_term_aq aq)) rng tacopt); - S.as_arg (embed rng use_eq)] - rng - - | Tv_Unknown -> - { ref_Tv_Unknown.t with pos = rng } - - | Tv_Unsupp -> - { ref_Tv_Unsupp.t with pos = rng } - in - let unembed_term_view (t:term) : option term_view = - let hd, args = U.head_and_args t in - match (U.un_uinst hd).n, args with - | Tm_fvar fv, [(b, _)] when S.fv_eq_lid fv ref_Tv_Var.lid -> - BU.bind_opt (unembed #_ #e_bv b) (fun b -> - Some <| Tv_Var b) - - | Tm_fvar fv, [(b, _)] when S.fv_eq_lid fv ref_Tv_BVar.lid -> - BU.bind_opt (unembed #_ #e_bv b) (fun b -> - Some <| Tv_BVar b) - - | Tm_fvar fv, [(f, _)] when S.fv_eq_lid fv ref_Tv_FVar.lid -> - BU.bind_opt (unembed f) (fun f -> - Some <| Tv_FVar f) - - | Tm_fvar fv, [(f, _); (us, _)] - when S.fv_eq_lid fv ref_Tv_UInst.lid -> - BU.bind_opt (unembed f) (fun f -> - BU.bind_opt (unembed us) (fun us -> - Some <| Tv_UInst (f, us))) - - | Tm_fvar fv, [(l, _); (r, _)] when S.fv_eq_lid fv ref_Tv_App.lid -> - BU.bind_opt (unembed #_ #e_term l) (fun l -> - BU.bind_opt (unembed #_ #e_argv r) (fun r -> - Some <| Tv_App (l, r))) - - | Tm_fvar fv, [(b, _); (t, _)] when S.fv_eq_lid fv ref_Tv_Abs.lid -> - BU.bind_opt (unembed b) (fun b -> - BU.bind_opt (unembed #_ #e_term t) (fun t -> - Some <| Tv_Abs (b, t))) - - | Tm_fvar fv, [(b, _); (t, _)] when S.fv_eq_lid fv ref_Tv_Arrow.lid -> - BU.bind_opt (unembed b) (fun b -> - BU.bind_opt (unembed t) (fun c -> - Some <| Tv_Arrow (b, c))) - - | Tm_fvar fv, [(u, _)] when S.fv_eq_lid fv ref_Tv_Type.lid -> - BU.bind_opt (unembed u) (fun u -> - Some <| Tv_Type u) - - | Tm_fvar fv, [(b, _); (sort, _); (t, _)] when S.fv_eq_lid fv ref_Tv_Refine.lid -> - BU.bind_opt (unembed #_ #e_bv b) (fun b -> - BU.bind_opt (unembed #_ #e_term sort) (fun sort -> - BU.bind_opt (unembed #_ #e_term t) (fun t -> - Some <| Tv_Refine (b, sort, t)))) - - | Tm_fvar fv, [(c, _)] when S.fv_eq_lid fv ref_Tv_Const.lid -> - BU.bind_opt (unembed c) (fun c -> - Some <| Tv_Const c) - - | Tm_fvar fv, [(u, _); (l, _)] when S.fv_eq_lid fv ref_Tv_Uvar.lid -> - BU.bind_opt (unembed u) (fun u -> - let ctx_u_s : ctx_uvar_and_subst = U.unlazy_as_t Lazy_uvar l in - Some <| Tv_Uvar (u, ctx_u_s)) - - | Tm_fvar fv, [(r, _); (attrs, _); (b, _); (ty, _); (t1, _); (t2, _)] when S.fv_eq_lid fv ref_Tv_Let.lid -> - BU.bind_opt (unembed r) (fun r -> - BU.bind_opt (unembed #_ #(e_list e_term) attrs) (fun attrs -> - BU.bind_opt (unembed #_ #e_bv b) (fun b -> - BU.bind_opt (unembed #_ #e_term ty) (fun ty-> - BU.bind_opt (unembed #_ #e_term t1) (fun t1 -> - BU.bind_opt (unembed #_ #e_term t2) (fun t2 -> - Some <| Tv_Let (r, attrs, b, ty, t1, t2))))))) - - | Tm_fvar fv, [(t, _); (ret_opt, _); (brs, _)] when S.fv_eq_lid fv ref_Tv_Match.lid -> - BU.bind_opt (unembed #_ #e_term t) (fun t -> - BU.bind_opt (unembed #_ #e_match_returns_annotation ret_opt) (fun ret_opt -> - BU.bind_opt (unembed #_ #(e_list e_branch) brs) (fun brs -> - Some <| Tv_Match (t, ret_opt, brs)))) - - | Tm_fvar fv, [(e, _); (t, _); (tacopt, _); (use_eq, _)] when S.fv_eq_lid fv ref_Tv_AscT.lid -> - BU.bind_opt (unembed #_ #e_term e) (fun e -> - BU.bind_opt (unembed #_ #e_term t) (fun t -> - BU.bind_opt (unembed #_ #(e_option e_term) tacopt) (fun tacopt -> - BU.bind_opt (unembed use_eq) (fun use_eq -> - Some <| Tv_AscribedT (e, t, tacopt, use_eq))))) - - | Tm_fvar fv, [(e, _); (c, _); (tacopt, _); (use_eq, _)] when S.fv_eq_lid fv ref_Tv_AscC.lid -> - BU.bind_opt (unembed #_ #e_term e) (fun e -> - BU.bind_opt (unembed #_ #e_comp c) (fun c -> - BU.bind_opt (unembed #_ #(e_option e_term) tacopt) (fun tacopt -> - BU.bind_opt (unembed use_eq) (fun use_eq -> - Some <| Tv_AscribedC (e, c, tacopt, use_eq))))) - - | Tm_fvar fv, [] when S.fv_eq_lid fv ref_Tv_Unknown.lid -> - Some <| Tv_Unknown - - | Tm_fvar fv, [] when S.fv_eq_lid fv ref_Tv_Unsupp.lid -> - Some <| Tv_Unsupp - - | _ -> - None - in - mk_emb embed_term_view unembed_term_view fstar_refl_term_view - -let e_term_view = e_term_view_aq noaqs - -(* embeds as a string list *) -// instance e_lid : embedding I.lid = -// let embed rng lid : term = -// embed rng (I.path_of_lid lid) -// in -// let unembed t : option I.lid = -// BU.map_opt (unembed t) (fun p -> I.lid_of_path p t.pos) -// in -// EMB.mk_emb_full (fun x r _ _ -> embed r x) -// (fun x _ -> unembed x) -// (fun () -> t_list_of t_string) -// I.string_of_lid -// (fun () -> ET_abstract) - -let e_name = e_list e_string - -instance e_bv_view = - let embed_bv_view (rng:Range.range) (bvv:bv_view) : term = - S.mk_Tm_app ref_Mk_bv.t [S.as_arg (embed #_ #(e_sealed e_string) rng bvv.bv_ppname); - S.as_arg (embed rng bvv.bv_index)] - rng - in - let unembed_bv_view (t : term) : option bv_view = - let t = U.unascribe t in - let hd, args = U.head_and_args t in - match (U.un_uinst hd).n, args with - | Tm_fvar fv, [(nm, _); (idx, _)] when S.fv_eq_lid fv ref_Mk_bv.lid -> - BU.bind_opt (unembed #_ #(e_sealed e_string) nm) (fun nm -> - BU.bind_opt (unembed idx) (fun idx -> - Some <| { bv_ppname = nm ; bv_index = idx })) - - | _ -> - None - in - mk_emb embed_bv_view unembed_bv_view fstar_refl_bv_view - - -let e_attribute = e_term -let e_attributes = e_list e_attribute - -instance e_binder_view = - let embed_binder_view (rng:Range.range) (bview:binder_view) : term = - S.mk_Tm_app ref_Mk_binder.t [S.as_arg (embed #_ #e_bv rng bview.binder_bv); - S.as_arg (embed rng bview.binder_qual); - S.as_arg (embed #_ #e_attributes rng bview.binder_attrs); - S.as_arg (embed #_ #e_term rng bview.binder_sort)] - rng in - - let unembed_binder_view (t:term) : option binder_view = - let t = U.unascribe t in - let hd, args = U.head_and_args t in - match (U.un_uinst hd).n, args with - | Tm_fvar fv, [(bv, _); (q, _); (attrs, _); (sort, _)] - when S.fv_eq_lid fv ref_Mk_binder.lid -> - BU.bind_opt (unembed #_ #e_bv bv) (fun bv -> - BU.bind_opt (unembed q) (fun q -> - BU.bind_opt (unembed #_ #e_attributes attrs) (fun attrs -> - BU.bind_opt (unembed #_ #e_term sort) (fun sort -> - Some <| RD.({ binder_bv=bv;binder_qual=q; binder_attrs=attrs; binder_sort = sort}))))) - - | _ -> - None in - - mk_emb embed_binder_view unembed_binder_view fstar_refl_binder_view - -instance e_comp_view = - let embed_comp_view (rng:Range.range) (cv : comp_view) : term = - match cv with - | C_Total t -> - S.mk_Tm_app ref_C_Total.t [S.as_arg (embed #_ #e_term rng t)] - rng - - | C_GTotal t -> - S.mk_Tm_app ref_C_GTotal.t [S.as_arg (embed #_ #e_term rng t)] - rng - - | C_Lemma (pre, post, pats) -> - S.mk_Tm_app ref_C_Lemma.t [S.as_arg (embed #_ #e_term rng pre); - S.as_arg (embed #_ #e_term rng post); - S.as_arg (embed #_ #e_term rng pats)] - rng - - | C_Eff (us, eff, res, args, decrs) -> - S.mk_Tm_app ref_C_Eff.t - [ S.as_arg (embed rng us) - ; S.as_arg (embed rng eff) - ; S.as_arg (embed #_ #e_term rng res) - ; S.as_arg (embed #_ #(e_list e_argv) rng args) - ; S.as_arg (embed #_ #(e_list e_term) rng decrs)] rng - - - in - let unembed_comp_view (t : term) : option comp_view = - let t = U.unascribe t in - let hd, args = U.head_and_args t in - match (U.un_uinst hd).n, args with - | Tm_fvar fv, [(t, _)] - when S.fv_eq_lid fv ref_C_Total.lid -> - BU.bind_opt (unembed #_ #e_term t) (fun t -> - Some <| C_Total t) - - | Tm_fvar fv, [(t, _)] - when S.fv_eq_lid fv ref_C_GTotal.lid -> - BU.bind_opt (unembed #_ #e_term t) (fun t -> - Some <| C_GTotal t) - - | Tm_fvar fv, [(pre, _); (post, _); (pats, _)] when S.fv_eq_lid fv ref_C_Lemma.lid -> - BU.bind_opt (unembed #_ #e_term pre) (fun pre -> - BU.bind_opt (unembed #_ #e_term post) (fun post -> - BU.bind_opt (unembed #_ #e_term pats) (fun pats -> - Some <| C_Lemma (pre, post, pats)))) - - | Tm_fvar fv, [(us, _); (eff, _); (res, _); (args, _); (decrs, _)] - when S.fv_eq_lid fv ref_C_Eff.lid -> - BU.bind_opt (unembed us) (fun us -> - BU.bind_opt (unembed eff) (fun eff -> - BU.bind_opt (unembed #_ #e_term res) (fun res-> - BU.bind_opt (unembed #_ #(e_list e_argv) args) (fun args -> - BU.bind_opt (unembed #_ #(e_list e_term) decrs) (fun decrs -> - Some <| C_Eff (us, eff, res, args, decrs)))))) - - | _ -> - None - in - mk_emb embed_comp_view unembed_comp_view fstar_refl_comp_view - - -(* TODO: move to, Syntax.Embeddings or somewhere better even *) -instance e_sigelt = - let embed_sigelt (rng:Range.range) (se:sigelt) : term = - U.mk_lazy se fstar_refl_sigelt Lazy_sigelt (Some rng) - in - let unembed_sigelt (t:term) : option sigelt = - match (SS.compress t).n with - | Tm_lazy {blob=b; lkind=Lazy_sigelt} -> - Some (undyn b) - | _ -> - None - in - mk_emb embed_sigelt unembed_sigelt fstar_refl_sigelt - -let e_univ_name = - set_type fstar_refl_univ_name e_ident - -let e_lb_view = - let embed_lb_view (rng:Range.range) (lbv:lb_view) : term = - S.mk_Tm_app ref_Mk_lb.t [S.as_arg (embed rng lbv.lb_fv); - S.as_arg (embed rng lbv.lb_us); - S.as_arg (embed #_ #e_term rng lbv.lb_typ); - S.as_arg (embed #_ #e_term rng lbv.lb_def)] - rng - in - let unembed_lb_view (t : term) : option lb_view = - let t = U.unascribe t in - let hd, args = U.head_and_args t in - match (U.un_uinst hd).n, args with - | Tm_fvar fv, [(fv', _); (us, _); (typ, _); (def,_)] - when S.fv_eq_lid fv ref_Mk_lb.lid -> - BU.bind_opt (unembed fv') (fun fv' -> - BU.bind_opt (unembed us) (fun us -> - BU.bind_opt (unembed #_ #e_term typ) (fun typ -> - BU.bind_opt (unembed #_ #e_term def) (fun def -> - Some <| - { lb_fv = fv'; lb_us = us; lb_typ = typ; lb_def = def })))) - - | _ -> - None - in - mk_emb embed_lb_view unembed_lb_view fstar_refl_lb_view - -let e_letbinding = - let embed_letbinding (rng:Range.range) (lb:letbinding) : term = - U.mk_lazy lb fstar_refl_letbinding Lazy_letbinding (Some rng) - in - let unembed_letbinding (t : term) : option letbinding = - match (SS.compress t).n with - | Tm_lazy {blob=lb; lkind=Lazy_letbinding} -> - Some (undyn lb) - | _ -> - None - in - mk_emb embed_letbinding unembed_letbinding fstar_refl_letbinding - -let e_ctor : embedding RD.ctor = e_tuple2 (e_list e_string) e_term - -instance e_sigelt_view = - let embed_sigelt_view (rng:Range.range) (sev:sigelt_view) : term = - match sev with - | Sg_Let (r, lbs) -> - S.mk_Tm_app ref_Sg_Let.t - [S.as_arg (embed rng r); - S.as_arg (embed rng lbs)] - rng - - | Sg_Inductive (nm, univs, bs, t, dcs) -> - S.mk_Tm_app ref_Sg_Inductive.t - [S.as_arg (embed rng nm); - S.as_arg (embed rng univs); - S.as_arg (embed rng bs); - S.as_arg (embed #_ #e_term rng t); - S.as_arg (embed #_ #(e_list e_ctor) rng dcs)] - rng - - | Sg_Val (nm, univs, t) -> - S.mk_Tm_app ref_Sg_Val.t - [S.as_arg (embed rng nm); - S.as_arg (embed rng univs); - S.as_arg (embed #_ #e_term rng t)] - rng - - | Unk -> - { ref_Unk.t with pos = rng } - in - let unembed_sigelt_view (t:term) : option sigelt_view = - let t = U.unascribe t in - let hd, args = U.head_and_args t in - match (U.un_uinst hd).n, args with - | Tm_fvar fv, [(nm, _); (us, _); (bs, _); (t, _); (dcs, _)] when S.fv_eq_lid fv ref_Sg_Inductive.lid -> - BU.bind_opt (unembed nm) (fun nm -> - BU.bind_opt (unembed us) (fun us -> - BU.bind_opt (unembed bs) (fun bs -> - BU.bind_opt (unembed #_ #e_term t) (fun t -> - BU.bind_opt (unembed #_ #(e_list e_ctor) dcs) (fun dcs -> - Some <| Sg_Inductive (nm, us, bs, t, dcs)))))) - - | Tm_fvar fv, [(r, _); (lbs, _)] when S.fv_eq_lid fv ref_Sg_Let.lid -> - BU.bind_opt (unembed r) (fun r -> - BU.bind_opt (unembed lbs) (fun lbs -> - Some <| Sg_Let (r, lbs))) - - | Tm_fvar fv, [(nm, _); (us, _); (t, _)] when S.fv_eq_lid fv ref_Sg_Val.lid -> - BU.bind_opt (unembed nm) (fun nm -> - BU.bind_opt (unembed us) (fun us -> - BU.bind_opt (unembed #_ #e_term t) (fun t -> - Some <| Sg_Val (nm, us, t)))) - - | Tm_fvar fv, [] when S.fv_eq_lid fv ref_Unk.lid -> - Some Unk - - | _ -> - None - in - mk_emb embed_sigelt_view unembed_sigelt_view fstar_refl_sigelt_view - -let e_qualifier = - let embed (rng:Range.range) (q:RD.qualifier) : term = - let r = - match q with - | RD.Assumption -> ref_qual_Assumption.t - | RD.InternalAssumption -> ref_qual_InternalAssumption.t - | RD.New -> ref_qual_New.t - | RD.Private -> ref_qual_Private.t - | RD.Unfold_for_unification_and_vcgen -> ref_qual_Unfold_for_unification_and_vcgen.t - | RD.Visible_default -> ref_qual_Visible_default.t - | RD.Irreducible -> ref_qual_Irreducible.t - | RD.Inline_for_extraction -> ref_qual_Inline_for_extraction.t - | RD.NoExtract -> ref_qual_NoExtract.t - | RD.Noeq -> ref_qual_Noeq.t - | RD.Unopteq -> ref_qual_Unopteq.t - | RD.TotalEffect -> ref_qual_TotalEffect.t - | RD.Logic -> ref_qual_Logic.t - | RD.Reifiable -> ref_qual_Reifiable.t - | RD.ExceptionConstructor -> ref_qual_ExceptionConstructor.t - | RD.HasMaskedEffect -> ref_qual_HasMaskedEffect.t - | RD.Effect -> ref_qual_Effect.t - | RD.OnlyName -> ref_qual_OnlyName.t - | RD.Reflectable l -> - S.mk_Tm_app ref_qual_Reflectable.t [S.as_arg (embed rng l)] - Range.dummyRange - - | RD.Discriminator l -> - S.mk_Tm_app ref_qual_Discriminator.t [S.as_arg (embed rng l)] - Range.dummyRange - - | RD.Action l -> - S.mk_Tm_app ref_qual_Action.t [S.as_arg (embed rng l)] - Range.dummyRange - - | RD.Projector (l, i) -> - S.mk_Tm_app ref_qual_Projector.t [S.as_arg (embed rng (l, i))] - Range.dummyRange - - | RD.RecordType (ids1, ids2) -> - S.mk_Tm_app ref_qual_RecordType.t [S.as_arg (embed rng (ids1, ids2))] - Range.dummyRange - - | RD.RecordConstructor (ids1, ids2) -> - S.mk_Tm_app ref_qual_RecordConstructor.t [S.as_arg (embed rng (ids1, ids2))] - Range.dummyRange - - in { r with pos = rng } - in - let unembed (t: term) : option RD.qualifier = - let t = U.unascribe t in - let hd, args = U.head_and_args t in - match (U.un_uinst hd).n, args with - | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_Assumption.lid -> - Some RD.Assumption - - | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_InternalAssumption.lid -> - Some RD.InternalAssumption - - | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_New.lid -> - Some RD.New - - | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_Private.lid -> - Some RD.Private - - | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_Unfold_for_unification_and_vcgen.lid -> - Some RD.Unfold_for_unification_and_vcgen - - | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_Visible_default.lid -> - Some RD.Visible_default - - | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_Irreducible.lid -> - Some RD.Irreducible - - | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_Inline_for_extraction.lid -> - Some RD.Inline_for_extraction - - | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_NoExtract.lid -> - Some RD.NoExtract - - | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_Noeq.lid -> - Some RD.Noeq - - | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_Unopteq.lid -> - Some RD.Unopteq - - | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_TotalEffect.lid -> - Some RD.TotalEffect - - | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_Logic.lid -> - Some RD.Logic - - | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_Reifiable.lid -> - Some RD.Reifiable - - | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_ExceptionConstructor.lid -> - Some RD.ExceptionConstructor - - | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_HasMaskedEffect.lid -> - Some RD.HasMaskedEffect - - | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_Effect.lid -> - Some RD.Effect - - | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_OnlyName.lid -> - Some RD.OnlyName - - | Tm_fvar fv, [(l, _)] when S.fv_eq_lid fv ref_qual_Reflectable.lid -> - BU.bind_opt (unembed l) (fun l -> - Some <| RD.Reflectable l) - - | Tm_fvar fv, [(l, _)] when S.fv_eq_lid fv ref_qual_Discriminator.lid -> - BU.bind_opt (unembed l) (fun l -> - Some <| RD.Discriminator l) - - | Tm_fvar fv, [(l, _)] when S.fv_eq_lid fv ref_qual_Action.lid -> - BU.bind_opt (unembed l) (fun l -> - Some <| RD.Action l) - - | Tm_fvar fv, [(payload, _)] when S.fv_eq_lid fv ref_qual_Projector.lid -> - BU.bind_opt (unembed payload) (fun (l, i) -> - Some <| RD.Projector (l, i)) - - | Tm_fvar fv, [(payload, _)] when S.fv_eq_lid fv ref_qual_RecordType.lid -> - BU.bind_opt (unembed payload) (fun (ids1, ids2) -> - Some <| RD.RecordType (ids1, ids2)) - - | Tm_fvar fv, [(payload, _)] when S.fv_eq_lid fv ref_qual_RecordConstructor.lid -> - BU.bind_opt (unembed payload) (fun (ids1, ids2) -> - Some <| RD.RecordConstructor (ids1, ids2)) - - | _ -> - None - in - mk_emb embed unembed fstar_refl_qualifier - -let e_qualifiers = e_list e_qualifier - -(* -------------------------------------------------------------------------------------- *) -(* ------------------------------------- UNFOLDINGS ------------------------------------- *) -(* -------------------------------------------------------------------------------------- *) - - -(* Note that most of these are never needed during normalization, since - * the types are abstract. - *) - -let unfold_lazy_bv (i : lazyinfo) : term = - let bv : bv = undyn i.blob in - S.mk_Tm_app fstar_refl_pack_bv.t [S.as_arg (embed i.rng (inspect_bv bv))] - i.rng - -let unfold_lazy_binder (i : lazyinfo) : term = - let binder : binder = undyn i.blob in - S.mk_Tm_app fstar_refl_pack_binder.t [S.as_arg (embed i.rng (inspect_binder binder))] - i.rng - -let unfold_lazy_letbinding (i : lazyinfo) : term = - let lb : letbinding = undyn i.blob in - let lbv = inspect_lb lb in - S.mk_Tm_app fstar_refl_pack_lb.t - [ - S.as_arg (embed i.rng lbv.lb_fv); - S.as_arg (embed i.rng lbv.lb_us); - S.as_arg (embed #_ #e_term i.rng lbv.lb_typ); - S.as_arg (embed #_ #e_term i.rng lbv.lb_def) - ] - i.rng - -let unfold_lazy_fvar (i : lazyinfo) : term = - let fv : fv = undyn i.blob in - S.mk_Tm_app fstar_refl_pack_fv.t [S.as_arg (embed i.rng (inspect_fv fv))] - i.rng - -let unfold_lazy_comp (i : lazyinfo) : term = - let comp : comp = undyn i.blob in - S.mk_Tm_app fstar_refl_pack_comp.t [S.as_arg (embed i.rng (inspect_comp comp))] - i.rng - -let unfold_lazy_env (i : lazyinfo) : term = - (* Not needed, metaprograms never see concrete environments. *) - U.exp_unit - -let unfold_lazy_optionstate (i : lazyinfo) : term = - (* Not needed, metaprograms never see concrete optionstates . *) - U.exp_unit - -let unfold_lazy_sigelt (i : lazyinfo) : term = - let sigelt : sigelt = undyn i.blob in - S.mk_Tm_app fstar_refl_pack_sigelt.t [S.as_arg (embed i.rng (inspect_sigelt sigelt))] - i.rng - -let unfold_lazy_universe (i : lazyinfo) : term = - let u : universe = undyn i.blob in - S.mk_Tm_app fstar_refl_pack_universe.t [S.as_arg (embed i.rng (inspect_universe u))] - i.rng diff --git a/src/reflection/FStar.Reflection.V1.Embeddings.fsti b/src/reflection/FStar.Reflection.V1.Embeddings.fsti deleted file mode 100644 index f99377630ab..00000000000 --- a/src/reflection/FStar.Reflection.V1.Embeddings.fsti +++ /dev/null @@ -1,71 +0,0 @@ -(* - Copyright 2008-2022 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Reflection.V1.Embeddings - -open FStar open FStar.Compiler -open FStar.Syntax.Syntax -open FStar.Syntax.Embeddings -open FStar.Order -open FStar.TypeChecker.Env -open FStar.Reflection.V1.Data -module O = FStar.Options -module RD = FStar.Reflection.V1.Data - -(* Embeddings. We mark the ones proper to this module as instances *) -val e_bv : embedding bv -val e_binder : embedding binder -instance val e_binder_view : embedding binder_view -val e_binders : embedding binders -val e_term : embedding term -instance val e_term_view : embedding term_view -val e_fv : embedding fv -val e_comp : embedding comp -instance val e_comp_view : embedding comp_view -instance val e_const : embedding vconst -val e_env : embedding FStar.TypeChecker.Env.env -instance val e_pattern : embedding pattern -instance val e_branch : embedding Data.branch -instance val e_aqualv : embedding aqualv -instance val e_argv : embedding argv -val e_sigelt : embedding sigelt -val e_letbinding : embedding letbinding -val e_lb_view : embedding lb_view -instance val e_sigelt_view : embedding sigelt_view -instance val e_bv_view : embedding bv_view -val e_attribute : embedding attribute -val e_attributes : embedding (list attribute) (* This seems rather silly, but `attributes` is a keyword *) -instance val e_qualifier : embedding RD.qualifier -val e_qualifiers : embedding (list RD.qualifier) -val e_ident : embedding RD.ident (* NOT FStar.Ident.ident *) -val e_univ_name : embedding RD.univ_name (* NOT Syntax.univ_name *) -val e_universe : embedding universe -instance val e_universe_view : embedding universe_view - -(* Useful for embedding antiquoted terms. They are only used for the embedding part, - * so this is a bit hackish. *) -val e_term_aq : antiquotations -> embedding term -val e_term_view_aq : antiquotations -> embedding term_view - -(* Lazy unfoldings *) -val unfold_lazy_bv : lazyinfo -> term -val unfold_lazy_fvar : lazyinfo -> term -val unfold_lazy_binder : lazyinfo -> term -val unfold_lazy_optionstate : lazyinfo -> term -val unfold_lazy_comp : lazyinfo -> term -val unfold_lazy_env : lazyinfo -> term -val unfold_lazy_sigelt : lazyinfo -> term -val unfold_lazy_letbinding : lazyinfo -> term -val unfold_lazy_universe : lazyinfo -> term diff --git a/src/reflection/FStar.Reflection.V1.Interpreter.fst b/src/reflection/FStar.Reflection.V1.Interpreter.fst deleted file mode 100644 index a61ef62163f..00000000000 --- a/src/reflection/FStar.Reflection.V1.Interpreter.fst +++ /dev/null @@ -1,205 +0,0 @@ -(* - Copyright 2008-2022 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Reflection.V1.Interpreter - -module BU = FStar.Compiler.Util -module Cfg = FStar.TypeChecker.Cfg -module EMB = FStar.Syntax.Embeddings -module Env = FStar.TypeChecker.Env -module NBET = FStar.TypeChecker.NBETerm -module NRE = FStar.Reflection.V1.NBEEmbeddings -module PO = FStar.TypeChecker.Primops -module RB = FStar.Reflection.V1.Builtins -module RD = FStar.Reflection.V1.Data -module RE = FStar.Reflection.V1.Embeddings -module Z = FStar.BigInt -module Range = FStar.Compiler.Range -open FStar.Compiler -open FStar.Compiler.List -open FStar.Ident -open FStar.Syntax.Syntax -open FStar.Reflection.V1.Constants -open FStar.Class.Monad - -(* NB: assuming uarity = 0 for these three. Also, they are homogenous in KAM and NBE. *) - -val mk1 : - string -> - {| EMB.embedding 't1 |} -> - {| EMB.embedding 'res |} -> - {| NBET.embedding 't1 |} -> - {| NBET.embedding 'res |} -> - ('t1 -> 'res) -> - PO.primitive_step -let mk1 nm f = - let lid = fstar_refl_builtins_lid nm in - PO.mk1' 0 lid - (fun x -> f x |> Some) - (fun x -> f x |> Some) - -val mk2 : - string -> - {| EMB.embedding 't1 |} -> - {| EMB.embedding 't2 |} -> - {| EMB.embedding 'res |} -> - {| NBET.embedding 't1 |} -> - {| NBET.embedding 't2 |} -> - {| NBET.embedding 'res |} -> - ('t1 -> 't2 -> 'res) -> - PO.primitive_step -let mk2 nm f = - let lid = fstar_refl_builtins_lid nm in - PO.mk2' 0 lid - (fun x y -> f x y |> Some) - (fun x y -> f x y |> Some) - -val mk3 : - string -> - {| EMB.embedding 't1 |} -> - {| EMB.embedding 't2 |} -> - {| EMB.embedding 't3 |} -> - {| EMB.embedding 'res |} -> - {| NBET.embedding 't1 |} -> - {| NBET.embedding 't2 |} -> - {| NBET.embedding 't3 |} -> - {| NBET.embedding 'res |} -> - ('t1 -> 't2 -> 't3 -> 'res) -> - PO.primitive_step -let mk3 nm f = - let lid = fstar_refl_builtins_lid nm in - PO.mk3' 0 lid - (fun x y z -> f x y z |> Some) - (fun x y z -> f x y z |> Some) - -(* Use these instances in this module *) - -instance _ = RE.e_term -instance _ = RE.e_term_view -instance _ = RE.e_fv -instance _ = RE.e_bv -instance _ = RE.e_bv_view -instance _ = RE.e_comp -instance _ = RE.e_comp_view -instance _ = RE.e_universe -instance _ = RE.e_universe_view -instance _ = RE.e_sigelt -instance _ = RE.e_sigelt_view -instance _ = RE.e_binder -instance _ = RE.e_binder_view -instance _ = RE.e_binders -instance _ = RE.e_letbinding -instance _ = RE.e_lb_view -instance _ = RE.e_env -instance _ = RE.e_aqualv -instance _ = RE.e_attributes -instance _ = RE.e_qualifiers -(* And NBE *) -instance _ = NRE.e_term -instance _ = NRE.e_term_view -instance _ = NRE.e_fv -instance _ = NRE.e_bv -instance _ = NRE.e_bv_view -instance _ = NRE.e_comp -instance _ = NRE.e_comp_view -instance _ = NRE.e_universe -instance _ = NRE.e_universe_view -instance _ = NRE.e_sigelt -instance _ = NRE.e_sigelt_view -instance _ = NRE.e_binder -instance _ = NRE.e_binder_view -instance _ = NRE.e_binders -instance _ = NRE.e_letbinding -instance _ = NRE.e_lb_view -instance _ = NRE.e_env -instance _ = NRE.e_aqualv -instance _ = NRE.e_attributes -instance _ = NRE.e_qualifiers - -(* - * NOTE: all primitives must be carefully inspected to make sure they - * do not break the abstraction barrier imposed by the term_view. - * Otherwise, the pack_inspect_inv and inspect_pack_inv lemmas could - * likely be used to derive a contradiction. - * - * The way to go about adding new primitives is to implement them in the - * FStar.Reflection.V1.Builtins module and implement them using the (internal) - * inspect_ln and pack_ln functions, which means they should not break - * the view abstraction. - * - * _Any_ call to functions elsewhere, say term_to_string or - * Util.term_eq, will _very likely_ be inconsistent with the view. - * Exceptions to the "way to go" above should be well justified. - *) -let reflection_primops : list PO.primitive_step = [ - (****** Inspecting/packing various kinds of syntax ******) - mk1 "inspect_ln" RB.inspect_ln ; - mk1 "pack_ln" RB.pack_ln ; - - mk1 "inspect_fv" RB.inspect_fv; - mk1 "pack_fv" RB.pack_fv; - - mk1 "inspect_comp" RB.inspect_comp ; - mk1 "pack_comp" RB.pack_comp ; - - mk1 "inspect_universe" RB.inspect_universe ; - mk1 "pack_universe" RB.pack_universe ; - mk1 "inspect_sigelt" RB.inspect_sigelt ; - mk1 "pack_sigelt" RB.pack_sigelt ; - mk1 "inspect_lb" RB.inspect_lb ; - mk1 "pack_lb" RB.pack_lb ; - mk1 "inspect_bv" RB.inspect_bv ; - mk1 "pack_bv" RB.pack_bv ; - - (* TODO: Make this consistent with others? No good reason for it to be "exploded" *) - mk1 "inspect_binder" RB.inspect_binder; - mk1 "pack_binder" RB.pack_binder; - - (****** Actual primitives ******) - - mk1 "sigelt_opts" RB.sigelt_opts; - - (* This exposes the embedding of vconfig since it is useful to create attributes *) - mk1 "embed_vconfig" RB.embed_vconfig; - - mk1 "sigelt_attrs" RB.sigelt_attrs; - mk2 "set_sigelt_attrs" RB.set_sigelt_attrs; - mk1 "sigelt_quals" RB.sigelt_quals; - mk2 "set_sigelt_quals" RB.set_sigelt_quals; - mk3 "subst" RB.subst; - mk2 "close_term" RB.close_term; - mk2 "compare_bv" RB.compare_bv; - mk2 "lookup_attr" RB.lookup_attr; - mk1 "all_defs_in_env" RB.all_defs_in_env; - mk2 "defs_in_module" RB.defs_in_module; - - mk2 "term_eq" RB.term_eq; - mk1 "moduleof" RB.moduleof; - mk1 "binders_of_env" RB.binders_of_env; - mk2 "lookup_typ" RB.lookup_typ; - mk1 "env_open_modules" RB.env_open_modules; - - (* See note in ulib/FStar.Reflection.V1.Builtins.fsti: we expose these - three to reduce dependencies. *) - mk1 "implode_qn" RB.implode_qn; - - mk1 "explode_qn" RB.explode_qn; - mk2 "compare_string" RB.compare_string; - mk2 "push_binder" RB.push_binder; - mk1 "range_of_term" RB.range_of_term; - mk1 "range_of_sigelt" RB.range_of_sigelt; -] - -let _ = List.iter FStar.TypeChecker.Cfg.register_extra_step reflection_primops diff --git a/src/reflection/FStar.Reflection.V1.Interpreter.fsti b/src/reflection/FStar.Reflection.V1.Interpreter.fsti deleted file mode 100644 index 92020fac309..00000000000 --- a/src/reflection/FStar.Reflection.V1.Interpreter.fsti +++ /dev/null @@ -1,19 +0,0 @@ -(* - Copyright 2008-2022 Microsof Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Reflection.V1.Interpreter - -(* This module only has an initialization effect of registering -many primitive steps in the normalizer. *) diff --git a/src/reflection/FStar.Reflection.V1.NBEEmbeddings.fst b/src/reflection/FStar.Reflection.V1.NBEEmbeddings.fst deleted file mode 100644 index 8bdde0dfcc7..00000000000 --- a/src/reflection/FStar.Reflection.V1.NBEEmbeddings.fst +++ /dev/null @@ -1,887 +0,0 @@ -(* - Copyright 2008-2022 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Reflection.V1.NBEEmbeddings -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Pervasives -open FStar.Reflection.V1.Data -open FStar.Syntax.Syntax -open FStar.TypeChecker.NBETerm -open FStar.Order -open FStar.Errors - -module O = FStar.Options -module S = FStar.Syntax.Syntax // TODO: remove, it's open - -module BU = FStar.Compiler.Util -module Env = FStar.TypeChecker.Env -module Err = FStar.Errors -module I = FStar.Ident -module NBETerm = FStar.TypeChecker.NBETerm -module PC = FStar.Parser.Const -module Range = FStar.Compiler.Range -module RD = FStar.Reflection.V1.Data -module SS = FStar.Syntax.Subst -module Thunk = FStar.Thunk -module U = FStar.Syntax.Util - -open FStar.Dyn -open FStar.Reflection.V1.Constants - -(* - * embed : from compiler to user - * unembed : from user to compiler - *) - -let noaqs : antiquotations = (0, []) - -(* -------------------------------------------------------------------------------------- *) -(* ------------------------------------- EMBEDDINGS ------------------------------------- *) -(* -------------------------------------------------------------------------------------- *) - -(* PLEASE NOTE: Construct and FV accumulate their arguments BACKWARDS. That is, - * the expression (f 1 2) is stored as FV (f, [], [Constant (Int 2); Constant (Int 1)]. - * So be careful when calling mkFV/mkConstruct and matching on them. *) - -(* On that note, we use this (inefficient, FIXME) hack in this module *) -let mkFV fv us ts = mkFV fv (List.rev us) (List.rev ts) -let mkConstruct fv us ts = mkConstruct fv (List.rev us) (List.rev ts) -(* ^ We still need to match on them in reverse order though, so this is pretty dumb *) - -let fv_as_emb_typ fv = S.ET_app (FStar.Ident.string_of_lid fv.fv_name.v, []) -let mk_emb' x y fv = mk_emb x y (fun () -> mkFV fv [] []) (fun () -> fv_as_emb_typ fv) - -let mk_lazy cb obj ty kind = - let li = { - blob = FStar.Dyn.mkdyn obj - ; lkind = kind - ; ltyp = ty - ; rng = Range.dummyRange - } - in - let thunk = Thunk.mk (fun () -> translate_cb cb (U.unfold_lazy li)) in - mk_t (Lazy (Inl li, thunk)) - -let e_bv = - let embed_bv cb (bv:bv) : t = - mk_lazy cb bv fstar_refl_bv Lazy_bv - in - let unembed_bv cb (t:t) : option bv = - match t.nbe_t with - | Lazy (Inl {blob=b; lkind=Lazy_bv}, _) -> - Some <| FStar.Dyn.undyn b - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded bv: %s" (t_to_string t)); - None - in - mk_emb' embed_bv unembed_bv fstar_refl_bv_fv - - -let e_binder = - let embed_binder cb (b:binder) : t = - mk_lazy cb b fstar_refl_binder Lazy_binder - in - let unembed_binder cb (t:t) : option binder = - match t.nbe_t with - | Lazy (Inl {blob=b; lkind=Lazy_binder}, _) -> - Some (undyn b) - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded binder: %s" (t_to_string t)); - None - in - mk_emb' embed_binder unembed_binder fstar_refl_binder_fv - -let rec mapM_opt (f : ('a -> option 'b)) (l : list 'a) : option (list 'b) = - match l with - | [] -> Some [] - | x::xs -> - BU.bind_opt (f x) (fun x -> - BU.bind_opt (mapM_opt f xs) (fun xs -> - Some (x :: xs))) - -let e_term_aq aq = - let embed_term cb (t:term) : NBETerm.t = - let qi = { qkind = Quote_static; antiquotations = aq } in - mk_t (NBETerm.Quote (t, qi)) - in - let unembed_term cb (t:NBETerm.t) : option term = - match t.nbe_t with - | NBETerm.Quote (tm, qi) -> - (* Just reuse the code from Reflection *) - Syntax.Embeddings.unembed #_ #(Reflection.V1.Embeddings.e_term_aq (0, [])) (S.mk (Tm_quoted (tm, qi)) Range.dummyRange) Syntax.Embeddings.id_norm_cb - | _ -> - None - in - { NBETerm.em = embed_term - ; NBETerm.un = unembed_term - ; NBETerm.typ = (fun () -> mkFV fstar_refl_term_fv [] []) - ; NBETerm.e_typ = (fun () -> fv_as_emb_typ fstar_refl_term_fv) - } - -let e_term = e_term_aq (0, []) - -let e_sort = e_sealed e_term -let e_ppname = e_sealed e_string - -let e_aqualv = - let embed_aqualv cb (q : aqualv) : t = - match q with - | Data.Q_Explicit -> mkConstruct ref_Q_Explicit.fv [] [] - | Data.Q_Implicit -> mkConstruct ref_Q_Implicit.fv [] [] - | Data.Q_Meta t -> mkConstruct ref_Q_Meta.fv [] [as_arg (embed e_term cb t)] - in - let unembed_aqualv cb (t : t) : option aqualv = - match t.nbe_t with - | Construct (fv, [], []) when S.fv_eq_lid fv ref_Q_Explicit.lid -> Some Data.Q_Explicit - | Construct (fv, [], []) when S.fv_eq_lid fv ref_Q_Implicit.lid -> Some Data.Q_Implicit - | Construct (fv, [], [(t, _)]) when S.fv_eq_lid fv ref_Q_Meta.lid -> - BU.bind_opt (unembed e_term cb t) (fun t -> - Some (Data.Q_Meta t)) - - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded aqualv: %s" (t_to_string t)); - None - in - mk_emb embed_aqualv unembed_aqualv - (fun () -> mkConstruct fstar_refl_aqualv_fv [] []) - (fun () -> fv_as_emb_typ fstar_refl_aqualv_fv) - -let e_binders = e_list e_binder - -let e_fv = - let embed_fv cb (fv:fv) : t = - mk_lazy cb fv fstar_refl_fv Lazy_fvar - in - let unembed_fv cb (t:t) : option fv = - match t.nbe_t with - | Lazy (Inl {blob=b; lkind=Lazy_fvar}, _) -> - Some (undyn b) - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded fvar: %s" (t_to_string t)); - None - in - mk_emb' embed_fv unembed_fv fstar_refl_fv_fv - -let e_comp = - let embed_comp cb (c:S.comp) : t = - mk_lazy cb c fstar_refl_comp Lazy_comp - in - let unembed_comp cb (t:t) : option S.comp = - match t.nbe_t with - | Lazy (Inl {blob=b; lkind=Lazy_comp}, _) -> - Some (undyn b) - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded comp: %s" (t_to_string t)); - None - in - mk_emb' embed_comp unembed_comp fstar_refl_comp_fv - -let e_env = - let embed_env cb (e:Env.env) : t = - mk_lazy cb e fstar_refl_env Lazy_env - in - let unembed_env cb (t:t) : option Env.env = - match t.nbe_t with - | Lazy (Inl {blob=b; lkind=Lazy_env}, _) -> - Some (undyn b) - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded env: %s" (t_to_string t)); - None - in - mk_emb' embed_env unembed_env fstar_refl_env_fv - -let e_const = - let embed_const cb (c:vconst) : t = - match c with - | C_Unit -> mkConstruct ref_C_Unit.fv [] [] - | C_True -> mkConstruct ref_C_True.fv [] [] - | C_False -> mkConstruct ref_C_False.fv [] [] - | C_Int i -> mkConstruct ref_C_Int.fv [] [as_arg (mk_t <| Constant (Int i))] - | C_String s -> mkConstruct ref_C_String.fv [] [as_arg (embed e_string cb s)] - | C_Range r -> mkConstruct ref_C_Range.fv [] [as_arg (embed e_range cb r)] - | C_Reify -> mkConstruct ref_C_Reify.fv [] [] - | C_Reflect ns -> mkConstruct ref_C_Reflect.fv [] [as_arg (embed e_string_list cb ns)] - in - let unembed_const cb (t:t) : option vconst = - match t.nbe_t with - | Construct (fv, [], []) when S.fv_eq_lid fv ref_C_Unit.lid -> - Some C_Unit - - | Construct (fv, [], []) when S.fv_eq_lid fv ref_C_True.lid -> - Some C_True - - | Construct (fv, [], []) when S.fv_eq_lid fv ref_C_False.lid -> - Some C_False - - | Construct (fv, [], [(i, _)]) when S.fv_eq_lid fv ref_C_Int.lid -> - BU.bind_opt (unembed e_int cb i) (fun i -> - Some <| C_Int i) - - | Construct (fv, [], [(s, _)]) when S.fv_eq_lid fv ref_C_String.lid -> - BU.bind_opt (unembed e_string cb s) (fun s -> - Some <| C_String s) - - | Construct (fv, [], [(r, _)]) when S.fv_eq_lid fv ref_C_Range.lid -> - BU.bind_opt (unembed e_range cb r) (fun r -> - Some <| C_Range r) - - | Construct (fv, [], []) when S.fv_eq_lid fv ref_C_Reify.lid -> - Some C_Reify - - | Construct (fv, [], [(ns, _)]) when S.fv_eq_lid fv ref_C_Reflect.lid -> - BU.bind_opt (unembed e_string_list cb ns) (fun ns -> - Some <| C_Reflect ns) - - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded vconst: %s" (t_to_string t)); - None - in - mk_emb' embed_const unembed_const fstar_refl_vconst_fv - -let e_universe = - let embed_universe cb (u:universe) : t = - mk_lazy cb u fstar_refl_universe Lazy_universe in - let unembed_universe cb (t:t) : option S.universe = - match t.nbe_t with - | Lazy (Inl {blob=b; lkind=Lazy_universe}, _) -> - Some (undyn b) - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded - (BU.format1 "Not an embedded universe: %s" (t_to_string t)); - None - in - mk_emb' embed_universe unembed_universe fstar_refl_universe_fv - -let rec e_pattern_aq aq = - let embed_pattern cb (p : pattern) : t = - match p with - | Pat_Constant c -> - mkConstruct ref_Pat_Constant.fv [] [as_arg (embed e_const cb c)] - | Pat_Cons (fv, us_opt, ps) -> - mkConstruct ref_Pat_Cons.fv [] - [as_arg (embed e_fv cb fv); - as_arg (embed (e_option (e_list e_universe)) cb us_opt); - as_arg (embed (e_list (e_tuple2 (e_pattern_aq aq) e_bool)) cb ps)] - | Pat_Var (bv, sort) -> - mkConstruct ref_Pat_Var.fv [] [as_arg (embed e_bv cb bv); as_arg (embed e_sort cb sort)] - | Pat_Dot_Term eopt -> - mkConstruct ref_Pat_Dot_Term.fv [] [as_arg (embed (e_option e_term) cb eopt)] - in - let unembed_pattern cb (t : t) : option pattern = - match t.nbe_t with - | Construct (fv, [], [(c, _)]) when S.fv_eq_lid fv ref_Pat_Constant.lid -> - BU.bind_opt (unembed e_const cb c) (fun c -> - Some <| Pat_Constant c) - - | Construct (fv, [], [(ps, _); (us_opt, _); (f, _)]) when S.fv_eq_lid fv ref_Pat_Cons.lid -> - BU.bind_opt (unembed e_fv cb f) (fun f -> - BU.bind_opt (unembed (e_option (e_list e_universe)) cb us_opt) (fun us -> - BU.bind_opt (unembed (e_list (e_tuple2 (e_pattern_aq aq) e_bool)) cb ps) (fun ps -> - Some <| Pat_Cons (f, us, ps)))) - - | Construct (fv, [], [(sort, _); (bv, _)]) when S.fv_eq_lid fv ref_Pat_Var.lid -> - BU.bind_opt (unembed e_bv cb bv) (fun bv -> - BU.bind_opt (unembed e_sort cb sort) (fun sort -> - Some <| Pat_Var (bv, sort))) - - | Construct (fv, [], [(eopt, _)]) when S.fv_eq_lid fv ref_Pat_Dot_Term.lid -> - BU.bind_opt (unembed (e_option e_term) cb eopt) (fun eopt -> - Some <| Pat_Dot_Term eopt) - - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded pattern: %s" (t_to_string t)); - None - in - mk_emb' embed_pattern unembed_pattern fstar_refl_pattern_fv - -let e_pattern = e_pattern_aq noaqs - -let e_branch = e_tuple2 e_pattern e_term -let e_argv = e_tuple2 e_term e_aqualv - -let e_branch_aq aq = e_tuple2 (e_pattern_aq aq) (e_term_aq aq) -let e_argv_aq aq = e_tuple2 (e_term_aq aq) e_aqualv - -let e_match_returns_annotation = - e_option (e_tuple2 e_binder - (e_tuple3 (e_either e_term e_comp) (e_option e_term) e_bool)) - -let unlazy_as_t k t = - let open FStar.Class.Deq in - match t.nbe_t with - | Lazy (Inl {lkind=k'; blob=v}, _) when k =? k' -> - FStar.Dyn.undyn v - | _ -> - failwith "Not a Lazy of the expected kind (NBE)" - -let e_ident : embedding RD.ident = e_tuple2 e_string e_range - -let e_universe_view = - let embed_universe_view cb (uv:universe_view) : t = - match uv with - | Uv_Zero -> mkConstruct ref_Uv_Zero.fv [] [] - | Uv_Succ u -> - mkConstruct - ref_Uv_Succ.fv - [] - [as_arg (embed e_universe cb u)] - | Uv_Max us -> - mkConstruct - ref_Uv_Max.fv - [] - [as_arg (embed (e_list e_universe) cb us)] - | Uv_BVar n -> - mkConstruct - ref_Uv_BVar.fv - [] - [as_arg (embed e_int cb n)] - | Uv_Name i -> - mkConstruct - ref_Uv_Name.fv - [] - [as_arg (embed (e_tuple2 e_string e_range) cb i)] - | Uv_Unif u -> - mkConstruct - ref_Uv_Unif.fv - [] - [as_arg (mk_lazy cb u U.t_universe_uvar Lazy_universe_uvar)] - | Uv_Unk -> mkConstruct ref_Uv_Unk.fv [] [] in - - let unembed_universe_view cb (t:t) : option universe_view = - match t.nbe_t with - | Construct (fv, _, []) when S.fv_eq_lid fv ref_Uv_Zero.lid -> Some Uv_Zero - | Construct (fv, _, [u, _]) when S.fv_eq_lid fv ref_Uv_Succ.lid -> - BU.bind_opt (unembed e_universe cb u) (fun u -> u |> Uv_Succ |> Some) - | Construct (fv, _, [us, _]) when S.fv_eq_lid fv ref_Uv_Max.lid -> - BU.bind_opt (unembed (e_list e_universe) cb us) (fun us -> us |> Uv_Max |> Some) - | Construct (fv, _, [n, _]) when S.fv_eq_lid fv ref_Uv_BVar.lid -> - BU.bind_opt (unembed e_int cb n) (fun n -> n |> Uv_BVar |> Some) - | Construct (fv, _, [i, _]) when S.fv_eq_lid fv ref_Uv_Name.lid -> - BU.bind_opt (unembed (e_tuple2 e_string e_range) cb i) (fun i -> i |> Uv_Name |> Some) - | Construct (fv, _, [u, _]) when S.fv_eq_lid fv ref_Uv_Unif.lid -> - let u : universe_uvar = unlazy_as_t Lazy_universe_uvar u in - u |> Uv_Unif |> Some - | Construct (fv, _, []) when S.fv_eq_lid fv ref_Uv_Unk.lid -> Some Uv_Unk - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded - (BU.format1 "Not an embedded universe view: %s" (t_to_string t)); - None in - - mk_emb' embed_universe_view unembed_universe_view fstar_refl_universe_view_fv - -let e_term_view_aq aq = - let shift (s, aqs) = (s + 1, aqs) in - let embed_term_view cb (tv:term_view) : t = - match tv with - | Tv_FVar fv -> - mkConstruct ref_Tv_FVar.fv [] [as_arg (embed e_fv cb fv)] - - | Tv_BVar bv -> - mkConstruct ref_Tv_BVar.fv [] [as_arg (embed e_bv cb bv)] - - | Tv_Var bv -> - mkConstruct ref_Tv_Var.fv [] [as_arg (embed e_bv cb bv)] - - | Tv_UInst (fv, us) -> - mkConstruct ref_Tv_UInst.fv [] - [as_arg (embed e_fv cb fv); - as_arg (embed (e_list e_universe) cb us)] - - | Tv_App (hd, a) -> - mkConstruct ref_Tv_App.fv [] [as_arg (embed (e_term_aq aq) cb hd); as_arg (embed (e_argv_aq aq) cb a)] - - | Tv_Abs (b, t) -> - mkConstruct ref_Tv_Abs.fv [] [as_arg (embed e_binder cb b); as_arg (embed (e_term_aq (shift aq)) cb t)] - - | Tv_Arrow (b, c) -> - mkConstruct ref_Tv_Arrow.fv [] [as_arg (embed e_binder cb b); as_arg (embed e_comp cb c)] - - | Tv_Type u -> - mkConstruct ref_Tv_Type.fv [] [as_arg (embed e_universe cb u)] - - | Tv_Refine (bv, sort, t) -> - mkConstruct ref_Tv_Refine.fv [] [as_arg (embed e_bv cb bv); - as_arg (embed (e_term_aq aq) cb sort); - as_arg (embed (e_term_aq (shift aq)) cb t)] - - | Tv_Const c -> - mkConstruct ref_Tv_Const.fv [] [as_arg (embed e_const cb c)] - - | Tv_Uvar (u, d) -> - mkConstruct ref_Tv_Uvar.fv [] [as_arg (embed e_int cb u); as_arg (mk_lazy cb (u,d) U.t_ctx_uvar_and_sust Lazy_uvar)] - - | Tv_Let (r, attrs, b, ty, t1, t2) -> - mkConstruct ref_Tv_Let.fv [] [as_arg (embed e_bool cb r); - as_arg (embed (e_list e_term) cb attrs); - as_arg (embed e_bv cb b); - as_arg (embed (e_term_aq aq) cb ty); - as_arg (embed (e_term_aq aq) cb t1); - as_arg (embed (e_term_aq (shift aq)) cb t2)] - - | Tv_Match (t, ret_opt, brs) -> - mkConstruct ref_Tv_Match.fv [] [ - as_arg (embed (e_term_aq aq) cb t); - as_arg (embed e_match_returns_annotation cb ret_opt); - as_arg (embed (e_list (e_branch_aq aq)) cb brs)] - - | Tv_AscribedT (e, t, tacopt, use_eq) -> - mkConstruct ref_Tv_AscT.fv [] - [as_arg (embed (e_term_aq aq) cb e); - as_arg (embed (e_term_aq aq) cb t); - as_arg (embed (e_option (e_term_aq aq)) cb tacopt); - as_arg (embed e_bool cb use_eq)] - - | Tv_AscribedC (e, c, tacopt, use_eq) -> - mkConstruct ref_Tv_AscT.fv [] - [as_arg (embed (e_term_aq aq) cb e); - as_arg (embed e_comp cb c); - as_arg (embed (e_option (e_term_aq aq)) cb tacopt); - as_arg (embed e_bool cb use_eq)] - - | Tv_Unknown -> mkConstruct ref_Tv_Unknown.fv [] [] - - | Tv_Unsupp -> mkConstruct ref_Tv_Unsupp.fv [] [] - in - let unembed_term_view cb (t:t) : option term_view = - match t.nbe_t with - | Construct (fv, _, [(b, _)]) when S.fv_eq_lid fv ref_Tv_Var.lid -> - BU.bind_opt (unembed e_bv cb b) (fun b -> - Some <| Tv_Var b) - - | Construct (fv, _, [(b, _)]) when S.fv_eq_lid fv ref_Tv_BVar.lid -> - BU.bind_opt (unembed e_bv cb b) (fun b -> - Some <| Tv_BVar b) - - | Construct (fv, _, [(f, _)]) when S.fv_eq_lid fv ref_Tv_FVar.lid -> - BU.bind_opt (unembed e_fv cb f) (fun f -> - Some <| Tv_FVar f) - - | Construct (fv, _, [(f, _); (us, _)]) when S.fv_eq_lid fv ref_Tv_UInst.lid -> - BU.bind_opt (unembed e_fv cb f) (fun f -> - BU.bind_opt (unembed (e_list e_universe) cb us) (fun us -> - Some <| Tv_UInst (f, us))) - - | Construct (fv, _, [(r, _); (l, _)]) when S.fv_eq_lid fv ref_Tv_App.lid -> - BU.bind_opt (unembed e_term cb l) (fun l -> - BU.bind_opt (unembed e_argv cb r) (fun r -> - Some <| Tv_App (l, r))) - - | Construct (fv, _, [(t, _); (b, _)]) when S.fv_eq_lid fv ref_Tv_Abs.lid -> - BU.bind_opt (unembed e_binder cb b) (fun b -> - BU.bind_opt (unembed e_term cb t) (fun t -> - Some <| Tv_Abs (b, t))) - - | Construct (fv, _, [(t, _); (b, _)]) when S.fv_eq_lid fv ref_Tv_Arrow.lid -> - BU.bind_opt (unembed e_binder cb b) (fun b -> - BU.bind_opt (unembed e_comp cb t) (fun c -> - Some <| Tv_Arrow (b, c))) - - | Construct (fv, _, [(u, _)]) when S.fv_eq_lid fv ref_Tv_Type.lid -> - BU.bind_opt (unembed e_universe cb u) (fun u -> - Some <| Tv_Type u) - - | Construct (fv, _, [(t, _); (sort, _); (b, _)]) when S.fv_eq_lid fv ref_Tv_Refine.lid -> - BU.bind_opt (unembed e_bv cb b) (fun b -> - BU.bind_opt (unembed e_term cb sort) (fun sort -> - BU.bind_opt (unembed e_term cb t) (fun t -> - Some <| Tv_Refine (b, sort, t)))) - - | Construct (fv, _, [(c, _)]) when S.fv_eq_lid fv ref_Tv_Const.lid -> - BU.bind_opt (unembed e_const cb c) (fun c -> - Some <| Tv_Const c) - - | Construct (fv, _, [(l, _); (u, _)]) when S.fv_eq_lid fv ref_Tv_Uvar.lid -> - BU.bind_opt (unembed e_int cb u) (fun u -> - let ctx_u_s : ctx_uvar_and_subst = unlazy_as_t Lazy_uvar l in - Some <| Tv_Uvar (u, ctx_u_s)) - - | Construct (fv, _, [(t2, _); (t1, _); (ty, _); (b, _); (attrs, _); (r, _)]) when S.fv_eq_lid fv ref_Tv_Let.lid -> - BU.bind_opt (unembed e_bool cb r) (fun r -> - BU.bind_opt (unembed (e_list e_term) cb attrs) (fun attrs -> - BU.bind_opt (unembed e_bv cb b) (fun b -> - BU.bind_opt (unembed e_term cb ty) (fun ty -> - BU.bind_opt (unembed e_term cb t1) (fun t1 -> - BU.bind_opt (unembed e_term cb t2) (fun t2 -> - Some <| Tv_Let (r, attrs, b, ty, t1, t2))))))) - - | Construct (fv, _, [(brs, _); (ret_opt, _); (t, _)]) when S.fv_eq_lid fv ref_Tv_Match.lid -> - BU.bind_opt (unembed e_term cb t) (fun t -> - BU.bind_opt (unembed (e_list e_branch) cb brs) (fun brs -> - BU.bind_opt (unembed e_match_returns_annotation cb ret_opt) (fun ret_opt -> - Some <| Tv_Match (t, ret_opt, brs)))) - - | Construct (fv, _, [(tacopt, _); (t, _); (e, _); (use_eq, _)]) when S.fv_eq_lid fv ref_Tv_AscT.lid -> - BU.bind_opt (unembed e_term cb e) (fun e -> - BU.bind_opt (unembed e_term cb t) (fun t -> - BU.bind_opt (unembed (e_option e_term) cb tacopt) (fun tacopt -> - BU.bind_opt (unembed e_bool cb use_eq) (fun use_eq -> - Some <| Tv_AscribedT (e, t, tacopt, use_eq))))) - - | Construct (fv, _, [(tacopt, _); (c, _); (e, _); (use_eq, _)]) when S.fv_eq_lid fv ref_Tv_AscC.lid -> - BU.bind_opt (unembed e_term cb e) (fun e -> - BU.bind_opt (unembed e_comp cb c) (fun c -> - BU.bind_opt (unembed (e_option e_term) cb tacopt) (fun tacopt -> - BU.bind_opt (unembed e_bool cb use_eq) (fun use_eq -> - Some <| Tv_AscribedC (e, c, tacopt, use_eq))))) - - | Construct (fv, _, []) when S.fv_eq_lid fv ref_Tv_Unknown.lid -> - Some <| Tv_Unknown - - | Construct (fv, _, []) when S.fv_eq_lid fv ref_Tv_Unsupp.lid -> - Some <| Tv_Unsupp - - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded term_view: %s" (t_to_string t)); - None - in - mk_emb' embed_term_view unembed_term_view fstar_refl_term_view_fv - -let e_term_view = e_term_view_aq (0, []) - -let e_bv_view = - let embed_bv_view cb (bvv:bv_view) : t = - mkConstruct ref_Mk_bv.fv [] [as_arg (embed (e_sealed e_string) cb bvv.bv_ppname); - as_arg (embed e_int cb bvv.bv_index)] - in - let unembed_bv_view cb (t : t) : option bv_view = - match t.nbe_t with - | Construct (fv, _, [(idx, _); (nm, _)]) when S.fv_eq_lid fv ref_Mk_bv.lid -> - BU.bind_opt (unembed (e_sealed e_string) cb nm) (fun nm -> - BU.bind_opt (unembed e_int cb idx) (fun idx -> - Some <| { bv_ppname = nm ; bv_index = idx })) - - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded bv_view: %s" (t_to_string t)); - None - in - mk_emb' embed_bv_view unembed_bv_view fstar_refl_bv_view_fv - -let e_attribute = e_term -let e_attributes = e_list e_attribute - -let e_binder_view = - let embed_binder_view cb (bview:binder_view) : t = - mkConstruct ref_Mk_binder.fv [] [as_arg (embed e_bv cb bview.binder_bv); - as_arg (embed e_aqualv cb bview.binder_qual); - as_arg (embed e_attributes cb bview.binder_attrs); - as_arg (embed e_term cb bview.binder_sort)] in - - let unembed_binder_view cb (t:t) : option binder_view = - match t.nbe_t with - | Construct (fv, _, [(sort, _); (attrs, _); (q, _); (bv, _)]) - when S.fv_eq_lid fv ref_Mk_binder.lid -> - BU.bind_opt (unembed e_bv cb bv) (fun bv -> - BU.bind_opt (unembed e_aqualv cb q) (fun q -> - BU.bind_opt (unembed e_attributes cb attrs) (fun attrs -> - BU.bind_opt (unembed e_term cb sort) (fun sort -> - Some <| RD.({binder_bv=bv;binder_qual=q;binder_attrs=attrs;binder_sort=sort}))))) - - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded binder_view: %s" (t_to_string t)); - None - in - mk_emb' embed_binder_view unembed_binder_view fstar_refl_binder_view_fv - -let e_comp_view = - let embed_comp_view cb (cv : comp_view) : t = - match cv with - | C_Total t -> - mkConstruct ref_C_Total.fv [] [ - as_arg (embed e_term cb t)] - - | C_GTotal t -> - mkConstruct ref_C_GTotal.fv [] [ - as_arg (embed e_term cb t)] - - | C_Lemma (pre, post, pats) -> - mkConstruct ref_C_Lemma.fv [] [as_arg (embed e_term cb pre); as_arg (embed e_term cb post); as_arg (embed e_term cb pats)] - - | C_Eff (us, eff, res, args, decrs) -> - mkConstruct ref_C_Eff.fv [] - [ as_arg (embed (e_list e_universe) cb us) - ; as_arg (embed e_string_list cb eff) - ; as_arg (embed e_term cb res) - ; as_arg (embed (e_list e_argv) cb args) - ; as_arg (embed (e_list e_term) cb decrs)] - in - let unembed_comp_view cb (t : t) : option comp_view = - match t.nbe_t with - | Construct (fv, _, [(t, _)]) - when S.fv_eq_lid fv ref_C_Total.lid -> - BU.bind_opt (unembed e_term cb t) (fun t -> - Some <| C_Total t) - - | Construct (fv, _, [(t, _)]) - when S.fv_eq_lid fv ref_C_GTotal.lid -> - BU.bind_opt (unembed e_term cb t) (fun t -> - Some <| C_GTotal t) - - | Construct (fv, _, [(post, _); (pre, _); (pats, _)]) when S.fv_eq_lid fv ref_C_Lemma.lid -> - BU.bind_opt (unembed e_term cb pre) (fun pre -> - BU.bind_opt (unembed e_term cb post) (fun post -> - BU.bind_opt (unembed e_term cb pats) (fun pats -> - Some <| C_Lemma (pre, post, pats)))) - - | Construct (fv, _, [(decrs, _); (args, _); (res, _); (eff, _); (us, _)]) - when S.fv_eq_lid fv ref_C_Eff.lid -> - BU.bind_opt (unembed (e_list e_universe) cb us) (fun us -> - BU.bind_opt (unembed e_string_list cb eff) (fun eff -> - BU.bind_opt (unembed e_term cb res) (fun res-> - BU.bind_opt (unembed (e_list e_argv) cb args) (fun args -> - BU.bind_opt (unembed (e_list e_term) cb decrs) (fun decrs -> - Some <| C_Eff (us, eff, res, args, decrs)))))) - - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded comp_view: %s" (t_to_string t)); - None - in - mk_emb' embed_comp_view unembed_comp_view fstar_refl_comp_view_fv - -let e_sigelt = - let embed_sigelt cb (se:sigelt) : t = - mk_lazy cb se fstar_refl_sigelt Lazy_sigelt - in - let unembed_sigelt cb (t:t) : option sigelt = - match t.nbe_t with - | Lazy (Inl {blob=b; lkind=Lazy_sigelt}, _) -> - Some (undyn b) - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded sigelt: %s" (t_to_string t)); - None - in - mk_emb' embed_sigelt unembed_sigelt fstar_refl_sigelt_fv - -let e_univ_name = - (* TODO: Should be this, but there's a delta depth issue *) - (* set_type fstar_refl_univ_name e_ident *) - e_ident - -let e_univ_names = e_list e_univ_name -let e_string_list = e_list e_string - -let e_ctor = e_tuple2 e_string_list e_term - -let e_lb_view = - let embed_lb_view cb (lbv:lb_view) : t = - mkConstruct ref_Mk_lb.fv [] [as_arg (embed e_fv cb lbv.lb_fv); - as_arg (embed e_univ_names cb lbv.lb_us); - as_arg (embed e_term cb lbv.lb_typ); - as_arg (embed e_term cb lbv.lb_def)] - in - let unembed_lb_view cb (t : t) : option lb_view = - match t.nbe_t with - | Construct (fv, _, [(fv', _); (us, _); (typ, _); (def,_)]) - when S.fv_eq_lid fv ref_Mk_lb.lid -> - BU.bind_opt (unembed e_fv cb fv') (fun fv' -> - BU.bind_opt (unembed e_univ_names cb us) (fun us -> - BU.bind_opt (unembed e_term cb typ) (fun typ -> - BU.bind_opt (unembed e_term cb def) (fun def -> - Some <| - { lb_fv = fv'; lb_us = us; lb_typ = typ; lb_def = def })))) - - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded lb_view: %s" (t_to_string t)); - None - in - mk_emb' embed_lb_view unembed_lb_view fstar_refl_lb_view_fv - -(* embeds as a string list *) -let e_lid : embedding I.lid = - let embed rng lid : t = - embed e_string_list rng (I.path_of_lid lid) - in - let unembed cb (t : t) : option I.lid = - BU.map_opt (unembed e_string_list cb t) (fun p -> I.lid_of_path p Range.dummyRange) - in - mk_emb embed unembed - (fun () -> mkConstruct fstar_refl_aqualv_fv [] []) - (fun () -> fv_as_emb_typ fstar_refl_aqualv_fv) - -let e_letbinding = - let embed_letbinding cb (lb:letbinding) : t = - mk_lazy cb lb fstar_refl_letbinding Lazy_letbinding - in - let unembed_letbinding cb (t : t) : option letbinding = - match t.nbe_t with - | Lazy (Inl {blob=lb; lkind=Lazy_letbinding}, _) -> - Some (undyn lb) - - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded letbinding: %s" (t_to_string t)); - None - in - mk_emb' embed_letbinding unembed_letbinding fstar_refl_letbinding_fv - -let e_sigelt_view = - let embed_sigelt_view cb (sev:sigelt_view) : t = - match sev with - | Sg_Let (r, lbs) -> - mkConstruct ref_Sg_Let.fv [] [as_arg (embed e_bool cb r); - as_arg (embed (e_list e_letbinding) cb lbs)] - - | Sg_Inductive (nm, univs, bs, t, dcs) -> - mkConstruct ref_Sg_Inductive.fv [] [as_arg (embed e_string_list cb nm); - as_arg (embed e_univ_names cb univs); - as_arg (embed e_binders cb bs); - as_arg (embed e_term cb t); - as_arg (embed (e_list e_ctor) cb dcs)] - - | Sg_Val (nm, univs, t) -> - mkConstruct ref_Sg_Val.fv [] - [as_arg (embed e_string_list cb nm); - as_arg (embed e_univ_names cb univs); - as_arg (embed e_term cb t)] - - | Unk -> - mkConstruct ref_Unk.fv [] [] - in - let unembed_sigelt_view cb (t:t) : option sigelt_view = - match t.nbe_t with - | Construct (fv, _, [(dcs, _); (t, _); (bs, _); (us, _); (nm, _)]) when S.fv_eq_lid fv ref_Sg_Inductive.lid -> - BU.bind_opt (unembed e_string_list cb nm) (fun nm -> - BU.bind_opt (unembed e_univ_names cb us) (fun us -> - BU.bind_opt (unembed e_binders cb bs) (fun bs -> - BU.bind_opt (unembed e_term cb t) (fun t -> - BU.bind_opt (unembed (e_list e_ctor) cb dcs) (fun dcs -> - Some <| Sg_Inductive (nm, us, bs, t, dcs)))))) - - | Construct (fv, _, [(lbs, _); (r, _)]) when S.fv_eq_lid fv ref_Sg_Let.lid -> - BU.bind_opt (unembed e_bool cb r) (fun r -> - BU.bind_opt (unembed (e_list e_letbinding) cb lbs) (fun lbs -> - Some <| Sg_Let (r, lbs))) - - | Construct (fv, _, [(t, _); (us, _); (nm, _)]) when S.fv_eq_lid fv ref_Sg_Val.lid -> - BU.bind_opt (unembed e_string_list cb nm) (fun nm -> - BU.bind_opt (unembed e_univ_names cb us) (fun us -> - BU.bind_opt (unembed e_term cb t) (fun t -> - Some <| Sg_Val(nm, us, t)))) - - | Construct (fv, _, []) when S.fv_eq_lid fv ref_Unk.lid -> - Some Unk - - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded sigelt_view: %s" (t_to_string t)); - None - in - mk_emb' embed_sigelt_view unembed_sigelt_view fstar_refl_sigelt_view_fv - -let e_name = e_list e_string - -let e_qualifier = - let embed cb (q:RD.qualifier) : t = - match q with - | RD.Assumption -> mkConstruct ref_qual_Assumption.fv [] [] - | RD.New -> mkConstruct ref_qual_New.fv [] [] - | RD.Private -> mkConstruct ref_qual_Private.fv [] [] - | RD.Unfold_for_unification_and_vcgen -> mkConstruct ref_qual_Unfold_for_unification_and_vcgen.fv [] [] - | RD.Visible_default -> mkConstruct ref_qual_Visible_default.fv [] [] - | RD.Irreducible -> mkConstruct ref_qual_Irreducible.fv [] [] - | RD.Inline_for_extraction -> mkConstruct ref_qual_Inline_for_extraction.fv [] [] - | RD.NoExtract -> mkConstruct ref_qual_NoExtract.fv [] [] - | RD.Noeq -> mkConstruct ref_qual_Noeq.fv [] [] - | RD.Unopteq -> mkConstruct ref_qual_Unopteq.fv [] [] - | RD.TotalEffect -> mkConstruct ref_qual_TotalEffect.fv [] [] - | RD.Logic -> mkConstruct ref_qual_Logic.fv [] [] - | RD.Reifiable -> mkConstruct ref_qual_Reifiable.fv [] [] - | RD.ExceptionConstructor -> mkConstruct ref_qual_ExceptionConstructor.fv [] [] - | RD.HasMaskedEffect -> mkConstruct ref_qual_HasMaskedEffect.fv [] [] - | RD.Effect -> mkConstruct ref_qual_Effect.fv [] [] - | RD.OnlyName -> mkConstruct ref_qual_OnlyName.fv [] [] - | RD.Reflectable l -> - mkConstruct ref_qual_Reflectable.fv [] [as_arg (embed e_name cb l)] - - | RD.Discriminator l -> - mkConstruct ref_qual_Discriminator.fv [] [as_arg (embed e_name cb l)] - - | RD.Action l -> - mkConstruct ref_qual_Action.fv [] [as_arg (embed e_name cb l)] - - | RD.Projector (l, i) -> - mkConstruct ref_qual_Projector.fv [] [as_arg (embed e_name cb l); as_arg (embed e_ident cb i)] - - | RD.RecordType (ids1, ids2) -> - mkConstruct ref_qual_RecordType.fv [] [as_arg (embed (e_list e_ident) cb ids1); - as_arg (embed (e_list e_ident) cb ids2)] - - | RD.RecordConstructor (ids1, ids2) -> - mkConstruct ref_qual_RecordConstructor.fv [] [as_arg (embed (e_list e_ident) cb ids1); - as_arg (embed (e_list e_ident) cb ids2)] - in - let unembed cb (t:t) : option RD.qualifier = - match t.nbe_t with - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Assumption.lid -> Some RD.Assumption - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_New.lid -> Some RD.New - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Private.lid -> Some RD.Private - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Unfold_for_unification_and_vcgen.lid -> Some RD.Unfold_for_unification_and_vcgen - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Visible_default.lid -> Some RD.Visible_default - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Irreducible.lid -> Some RD.Irreducible - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Inline_for_extraction.lid -> Some RD.Inline_for_extraction - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_NoExtract.lid -> Some RD.NoExtract - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Noeq.lid -> Some RD.Noeq - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Unopteq.lid -> Some RD.Unopteq - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_TotalEffect.lid -> Some RD.TotalEffect - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Logic.lid -> Some RD.Logic - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Reifiable.lid -> Some RD.Reifiable - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_ExceptionConstructor.lid -> Some RD.ExceptionConstructor - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_HasMaskedEffect.lid -> Some RD.HasMaskedEffect - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Effect.lid -> Some RD.Effect - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_OnlyName.lid -> Some RD.OnlyName - - | Construct (fv, [], [(l, _)]) when S.fv_eq_lid fv ref_qual_Reflectable.lid -> - BU.bind_opt (unembed e_name cb l) (fun l -> - Some (RD.Reflectable l)) - - | Construct (fv, [], [(l, _)]) when S.fv_eq_lid fv ref_qual_Discriminator.lid -> - BU.bind_opt (unembed e_name cb l) (fun l -> - Some (RD.Discriminator l)) - - | Construct (fv, [], [(l, _)]) when S.fv_eq_lid fv ref_qual_Action.lid -> - BU.bind_opt (unembed e_name cb l) (fun l -> - Some (RD.Action l)) - - | Construct (fv, [], [(i, _); (l, _)]) when S.fv_eq_lid fv ref_qual_Projector.lid -> - BU.bind_opt (unembed e_ident cb i) (fun i -> - BU.bind_opt (unembed e_name cb l) (fun l -> - Some (RD.Projector (l, i)))) - - | Construct (fv, [], [(ids2, _); (ids1, _)]) when S.fv_eq_lid fv ref_qual_RecordType.lid -> - BU.bind_opt (unembed (e_list e_ident) cb ids1) (fun ids1 -> - BU.bind_opt (unembed (e_list e_ident) cb ids2) (fun ids2 -> - Some (RD.RecordType (ids1, ids2)))) - - | Construct (fv, [], [(ids2, _); (ids1, _)]) when S.fv_eq_lid fv ref_qual_RecordConstructor.lid -> - BU.bind_opt (unembed (e_list e_ident) cb ids1) (fun ids1 -> - BU.bind_opt (unembed (e_list e_ident) cb ids2) (fun ids2 -> - Some (RD.RecordConstructor (ids1, ids2)))) - - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded qualifier: %s" (t_to_string t)); - None - in - mk_emb embed unembed - (fun () -> mkConstruct fstar_refl_qualifier_fv [] []) - (fun () -> fv_as_emb_typ fstar_refl_qualifier_fv) - -let e_qualifiers = e_list e_qualifier - -let e_vconfig = - let emb cb (o:order) : t = - failwith "emb vconfig NBE" - in - let unemb cb (t:t) : option order = - failwith "unemb vconfig NBE" - in - mk_emb' emb unemb (lid_as_fv PC.vconfig_lid None) diff --git a/src/reflection/FStar.Reflection.V1.NBEEmbeddings.fsti b/src/reflection/FStar.Reflection.V1.NBEEmbeddings.fsti deleted file mode 100644 index 4c0e4e1ef99..00000000000 --- a/src/reflection/FStar.Reflection.V1.NBEEmbeddings.fsti +++ /dev/null @@ -1,58 +0,0 @@ -(* - Copyright 2008-2022 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Reflection.V1.NBEEmbeddings - -open FStar -open FStar.Compiler -open FStar.TypeChecker.NBETerm -open FStar.Syntax.Syntax -open FStar.Order -open FStar.TypeChecker.Env -open FStar.Reflection.V1.Data -module RD = FStar.Reflection.V1.Data -module S = FStar.Syntax.Syntax - -(* Embeddings. We mark the ones proper to this module as instances *) -instance val e_aqualv : embedding aqualv -instance val e_binder_view : embedding binder_view -instance val e_branch : embedding Data.branch -instance val e_bv_view : embedding bv_view -instance val e_comp_view : embedding comp_view -instance val e_const : embedding vconst -instance val e_lb_view : embedding lb_view -instance val e_pattern : embedding pattern -instance val e_qualifier : embedding RD.qualifier -instance val e_sigelt_view : embedding sigelt_view -instance val e_term_view : embedding term_view -instance val e_universe_view : embedding universe_view -val e_argv : embedding argv -val e_attribute : embedding attribute -val e_attributes : embedding (list attribute) (* This seems rather silly, but `attributes` is a keyword *) -val e_binder : embedding binder -val e_binders : embedding binders -val e_bv : embedding bv -val e_comp : embedding S.comp -val e_env : embedding FStar.TypeChecker.Env.env -val e_fv : embedding fv -val e_ident : embedding RD.ident (* NOT FStar.Ident.ident *) -val e_letbinding : embedding letbinding -val e_qualifiers : embedding (list RD.qualifier) -val e_sigelt : embedding sigelt -val e_term : embedding S.term -val e_univ_name : embedding RD.univ_name (* NOT Syntax.univ_name *) -val e_univ_names : embedding (list RD.univ_name) (* NOT Syntax.univ_name *) -val e_universe : embedding universe diff --git a/src/reflection/FStar.Reflection.V2.Builtins.fst b/src/reflection/FStar.Reflection.V2.Builtins.fst deleted file mode 100644 index 1f63570c65e..00000000000 --- a/src/reflection/FStar.Reflection.V2.Builtins.fst +++ /dev/null @@ -1,944 +0,0 @@ -(* - Copyright 2008-2015 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Reflection.V2.Builtins - -open FStar -open FStar.Compiler -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Reflection.V2.Data -open FStar.Syntax.Syntax -open FStar.Order -open FStar.Errors -open FStar.List.Tot.Base - -module S = FStar.Syntax.Syntax // TODO: remove, it's open - -open FStar.Class.Show -open FStar.Class.Tagged - -module C = FStar.Const -module PC = FStar.Parser.Const -module SS = FStar.Syntax.Subst -module BU = FStar.Compiler.Util -module Range = FStar.Compiler.Range -module U = FStar.Syntax.Util -module UF = FStar.Syntax.Unionfind -module Print = FStar.Syntax.Print -module Ident = FStar.Ident -module Env = FStar.TypeChecker.Env -module Err = FStar.Errors -module Z = FStar.BigInt -module DsEnv = FStar.Syntax.DsEnv -module O = FStar.Options -module RD = FStar.Reflection.V2.Data -module EMB = FStar.Syntax.Embeddings -module N = FStar.TypeChecker.Normalize -open FStar.VConfig - -open FStar.Dyn - -(* This file provides implementation for reflection primitives in F*. - * - * Users can be exposed to (mostly) raw syntax of terms when working in - * a metaprogramming effect (such as TAC). These effects are irrelevant - * for runtime and cannot, of course, be used for proof (where syntax - * inspection would be completely inconsistent - *) - - (* - * Most of this file is tedious and repetitive. - * We should really allow for some metaprogramming in F*. Oh wait.... - *) - - -(* This is a hack, but it allows to lookup the constructor sigelts when -inspecting a Sig_inductive_typ. - -We need to be careful though. If we use this for, say, `lookup_attr` and -remove its `env` argument, then the normalizer can reduce it eagerly. -Trying to do this right now means calls to `lookup_attr` are evaluated -at extraction time, and will not behave as expected. The root cause is -that all of the reflection operators are taken to be pure and that't not -the case if we remove the `env` in some, like `lookup_attr`. - -In the case of `inspect_sigelt`, however, I think it won't be -noticeable since one obtain a concrete sigelt without running an impure -metaprogram. *) -let get_env () : Env.env = - match !N.reflection_env_hook with - | None -> failwith "impossible: env_hook unset in reflection" - | Some e -> e - -(* private *) -let inspect_bqual (bq : bqual) : aqualv = - match bq with - | Some (Implicit _) -> Data.Q_Implicit - | Some (Meta t) -> Data.Q_Meta t - | Some Equality -> Data.Q_Equality - | None -> Data.Q_Explicit - -let inspect_aqual (aq : aqual) : aqualv = - match aq with - | Some ({ aqual_implicit = true }) -> Data.Q_Implicit - | _ -> Data.Q_Explicit - -(* private *) -let pack_bqual (aqv : aqualv) : bqual = - match aqv with - | Data.Q_Implicit -> Some (Implicit false) - | Data.Q_Meta t -> Some (Meta t) - | Data.Q_Equality -> Some Equality - | Data.Q_Explicit -> None - -let pack_aqual (aqv : aqualv) : aqual = - match aqv with - | Data.Q_Implicit -> S.as_aqual_implicit true - | _ -> None - -let inspect_fv (fv:fv) : list string = - Ident.path_of_lid (lid_of_fv fv) - -let pack_fv (ns:list string) : fv = - let lid = PC.p2l ns in - let fallback () = - let quals = - (* This an awful hack *) - if Ident.lid_equals lid PC.cons_lid then Some Data_ctor else - if Ident.lid_equals lid PC.nil_lid then Some Data_ctor else - if Ident.lid_equals lid PC.some_lid then Some Data_ctor else - if Ident.lid_equals lid PC.none_lid then Some Data_ctor else - None - in - lid_as_fv (PC.p2l ns) quals - in - match !N.reflection_env_hook with - | None -> fallback () - | Some env -> - let qninfo = Env.lookup_qname env lid in - match qninfo with - | Some (Inr (se, _us), _rng) -> - let quals = DsEnv.fv_qual_of_se se in - lid_as_fv (PC.p2l ns) quals - | _ -> - fallback () - -// TODO: move to library? -let rec last (l:list 'a) : 'a = - match l with - | [] -> failwith "last: empty list" - | [x] -> x - | _::xs -> last xs - -let rec init (l:list 'a) : list 'a = - match l with - | [] -> failwith "init: empty list" - | [x] -> [] - | x::xs -> x :: init xs - -let inspect_const (c:sconst) : vconst = - match c with - | FStar.Const.Const_unit -> C_Unit - | FStar.Const.Const_int (s, _) -> C_Int (Z.big_int_of_string s) - | FStar.Const.Const_bool true -> C_True - | FStar.Const.Const_bool false -> C_False - | FStar.Const.Const_string (s, _) -> C_String s - | FStar.Const.Const_range r -> C_Range r - | FStar.Const.Const_reify _ -> C_Reify - | FStar.Const.Const_reflect l -> C_Reflect (Ident.path_of_lid l) - | FStar.Const.Const_real s -> C_Real s - | _ -> failwith (BU.format1 "unknown constant: %s" (show c)) - -let inspect_universe u = - match u with - | U_zero -> Uv_Zero - | U_succ u -> Uv_Succ u - | U_max us -> Uv_Max us - | U_bvar n -> Uv_BVar (Z.of_int_fs n) - | U_name i -> Uv_Name i - | U_unif u -> Uv_Unif u - | U_unknown -> Uv_Unk - -let pack_universe uv = - match uv with - | Uv_Zero -> U_zero - | Uv_Succ u -> U_succ u - | Uv_Max us -> U_max us - | Uv_BVar n -> U_bvar (Z.to_int_fs n) - | Uv_Name i -> U_name i - | Uv_Unif u -> U_unif u - | Uv_Unk -> U_unknown - -let rec inspect_pat p = - match p.v with - | Pat_constant c -> Pat_Constant (inspect_const c) - | Pat_cons (fv, us_opt, ps) -> Pat_Cons fv us_opt (List.map (fun (p, b) -> inspect_pat p, b) ps) - | Pat_var bv -> Pat_Var (Sealed.seal bv.sort) (Sealed.seal <| string_of_id bv.ppname) - | Pat_dot_term eopt -> Pat_Dot_Term eopt - -let rec inspect_ln (t:term) : term_view = - // - // Only pushes delayed substitutions, - // doesn't compress uvars - // - let t = t |> SS.compress_subst in - match t.n with - | Tm_meta {tm=t} -> - inspect_ln t - - | Tm_name bv -> - Tv_Var bv - - | Tm_bvar bv -> - Tv_BVar bv - - | Tm_fvar fv -> - Tv_FVar fv - - | Tm_uinst (t, us) -> - (match t.n with - | Tm_fvar fv -> Tv_UInst (fv, us) - | _ -> failwith "Reflection::inspect_ln: uinst for a non-fvar node") - - | Tm_ascribed {tm=t; asc=(Inl ty, tacopt, eq)} -> - Tv_AscribedT (t, ty, tacopt, eq) - - | Tm_ascribed {tm=t; asc=(Inr cty, tacopt, eq)} -> - Tv_AscribedC (t, cty, tacopt, eq) - - | Tm_app {args=[]} -> - failwith "inspect_ln: empty arguments on Tm_app" - - | Tm_app {hd; args} -> - // We split at the last argument, since the term_view does not - // expose n-ary lambdas buy unary ones. - let (a, q) = last args in - let q' = inspect_aqual q in - Tv_App (U.mk_app hd (init args), (a, q')) - - | Tm_abs {bs=[]} -> - failwith "inspect_ln: empty arguments on Tm_abs" - - | Tm_abs {bs=b::bs; body=t; rc_opt=k} -> - let body = - match bs with - | [] -> t - | bs -> S.mk (Tm_abs {bs; body=t; rc_opt=k}) t.pos - in - Tv_Abs (b, body) - - | Tm_type u -> - Tv_Type u - - | Tm_arrow {bs=[]} -> - failwith "inspect_ln: empty binders on arrow" - - | Tm_arrow _ -> - begin match U.arrow_one_ln t with - | Some (b, c) -> Tv_Arrow (b, c) - | None -> failwith "impossible" - end - - | Tm_refine {b=bv; phi=t} -> - Tv_Refine (S.mk_binder bv, t) - - | Tm_constant c -> - Tv_Const (inspect_const c) - - | Tm_uvar (ctx_u, s) -> - // - // Use the unique id of the uvar - // - Tv_Uvar (Z.of_int_fs (UF.uvar_unique_id ctx_u.ctx_uvar_head), - (ctx_u, s)) - - | Tm_let {lbs=(isrec, [lb]); body=t2} -> - if lb.lbunivs <> [] then Tv_Unsupp else - begin match lb.lbname with - | Inr _ -> Tv_Unsupp // no top level lets - | Inl bv -> Tv_Let (isrec, lb.lbattrs, S.mk_binder bv, lb.lbdef, t2) - end - - | Tm_match {scrutinee=t; ret_opt; brs} -> - let brs = List.map (function (pat, _, t) -> (inspect_pat pat, t)) brs in - Tv_Match (t, ret_opt, brs) - - | Tm_unknown -> - Tv_Unknown - - | Tm_lazy i -> - // Not calling U.unlazy_emb since that calls (stateful) SS.compress - i |> U.unfold_lazy |> inspect_ln - - | _ -> - Err.log_issue t Err.Warning_CantInspect (BU.format2 "inspect_ln: outside of expected syntax (%s, %s)" (tag_of t) (show t)); - Tv_Unsupp - -let inspect_comp (c : comp) : comp_view = - let get_dec (flags : list cflag) : list term = - match List.tryFind (function DECREASES _ -> true | _ -> false) flags with - | None -> [] - | Some (DECREASES (Decreases_lex ts)) -> ts - | Some (DECREASES (Decreases_wf _)) -> - Err.log_issue c Err.Warning_CantInspect - (BU.format1 "inspect_comp: inspecting comp with wf decreases clause is not yet supported: %s \ - skipping the decreases clause" - (show c)); - [] - | _ -> failwith "Impossible!" - in - match c.n with - | Total t -> C_Total t - | GTotal t -> C_GTotal t - | Comp ct -> begin - let uopt = - if List.length ct.comp_univs = 0 - then U_unknown - else ct.comp_univs |> List.hd in - if Ident.lid_equals ct.effect_name PC.effect_Lemma_lid then - match ct.effect_args with - | (pre,_)::(post,_)::(pats,_)::_ -> - C_Lemma (pre, post, pats) - | _ -> - failwith "inspect_comp: Lemma does not have enough arguments?" - else - let inspect_arg (a, q) = (a, inspect_aqual q) in - C_Eff (ct.comp_univs, - Ident.path_of_lid ct.effect_name, - ct.result_typ, - List.map inspect_arg ct.effect_args, - get_dec ct.flags) - end - -let pack_comp (cv : comp_view) : comp = - let urefl_to_univs u = - if u = U_unknown - then [] - else [u] in - let urefl_to_univ_opt u = - if u = U_unknown - then None - else Some u in - match cv with - | C_Total t -> mk_Total t - | C_GTotal t -> mk_GTotal t - | C_Lemma (pre, post, pats) -> - let ct = { comp_univs = [] - ; effect_name = PC.effect_Lemma_lid - ; result_typ = S.t_unit - ; effect_args = [S.as_arg pre; S.as_arg post; S.as_arg pats] - ; flags = [] } in - S.mk_Comp ct - - | C_Eff (us, ef, res, args, decrs) -> - let pack_arg (a, q) = (a, pack_aqual q) in - let flags = - if List.length decrs = 0 - then [] - else [DECREASES (Decreases_lex decrs)] in - let ct = { comp_univs = us - ; effect_name = Ident.lid_of_path ef Range.dummyRange - ; result_typ = res - ; effect_args = List.map pack_arg args - ; flags = flags } in - S.mk_Comp ct - -let pack_const (c:vconst) : sconst = - match c with - | C_Unit -> C.Const_unit - | C_Int i -> C.Const_int (Z.string_of_big_int i, None) - | C_True -> C.Const_bool true - | C_False -> C.Const_bool false - | C_String s -> C.Const_string (s, Range.dummyRange) - | C_Range r -> C.Const_range r - | C_Reify -> C.Const_reify None - | C_Reflect ns -> C.Const_reflect (Ident.lid_of_path ns Range.dummyRange) - | C_Real r -> C.Const_real r - -let rec pack_pat p : S.pat = - let wrap v = {v=v;p=Range.dummyRange} in - match p with - | Pat_Constant c -> wrap <| Pat_constant (pack_const c) - | Pat_Cons head univs subpats -> wrap <| Pat_cons (head, univs, List.map (fun (p, b) -> pack_pat p, b) subpats) - | Pat_Var sort ppname -> - let bv = S.gen_bv (Sealed.unseal ppname) None (Sealed.unseal sort) in - wrap <| Pat_var bv - | Pat_Dot_Term eopt -> wrap <| Pat_dot_term eopt - -// TODO: pass in range? -let pack_ln (tv:term_view) : term = - match tv with - | Tv_Var bv -> - S.bv_to_name { bv with sort = S.tun } - - | Tv_BVar bv -> - S.bv_to_tm { bv with sort = S.tun } - - | Tv_FVar fv -> - S.fv_to_tm fv - - | Tv_UInst (fv, us) -> - mk_Tm_uinst (S.fv_to_tm fv) us - - | Tv_App (l, (r, q)) -> - let q' = pack_aqual q in - U.mk_app l [(r, q')] - - | Tv_Abs (b, t) -> - mk (Tm_abs {bs=[b]; body=t; rc_opt=None}) t.pos // TODO: effect? - - | Tv_Arrow (b, c) -> - mk (Tm_arrow {bs=[b]; comp=c}) c.pos - - | Tv_Type u -> - mk (Tm_type u) Range.dummyRange - - | Tv_Refine (b, t) -> - let bv : S.bv = b.binder_bv in - mk (Tm_refine {b=bv; phi=t}) t.pos - - | Tv_Const c -> - S.mk (Tm_constant (pack_const c)) Range.dummyRange - - | Tv_Uvar (u, ctx_u_s) -> - S.mk (Tm_uvar ctx_u_s) Range.dummyRange - - | Tv_Let (isrec, attrs, b, t1, t2) -> - let bv = b.binder_bv in - let lb = U.mk_letbinding (Inl bv) [] bv.sort PC.effect_Tot_lid t1 attrs Range.dummyRange in - S.mk (Tm_let {lbs=(isrec, [lb]); body=t2}) Range.dummyRange - - | Tv_Match (t, ret_opt, brs) -> - let brs = List.map (function (pat, t) -> (pack_pat pat, None, t)) brs in - S.mk (Tm_match {scrutinee=t; ret_opt; brs; rc_opt=None}) Range.dummyRange - - | Tv_AscribedT(e, t, tacopt, use_eq) -> - S.mk (Tm_ascribed {tm=e; asc=(Inl t, tacopt, use_eq); eff_opt=None}) Range.dummyRange - - | Tv_AscribedC(e, c, tacopt, use_eq) -> - S.mk (Tm_ascribed {tm=e; asc=(Inr c, tacopt, use_eq); eff_opt=None}) Range.dummyRange - - | Tv_Unknown -> - S.mk Tm_unknown Range.dummyRange - - | Tv_Unsupp -> - Err.log_issue0 Err.Warning_CantInspect "packing a Tv_Unsupp into Tm_unknown"; - S.mk Tm_unknown Range.dummyRange - -let compare_bv (x:bv) (y:bv) : order = - let n = S.order_bv x y in - if n < 0 then Lt - else if n = 0 then Eq - else Gt - -// Same as above -let compare_namedv (x:bv) (y:bv) : order = - let n = S.order_bv x y in - if n < 0 then Lt - else if n = 0 then Eq - else Gt - -let lookup_attr_ses (attr:term) (env:Env.env) : list sigelt = - match (SS.compress_subst attr).n with - | Tm_fvar fv -> Env.lookup_attr env (Ident.string_of_lid (lid_of_fv fv)) - | _ -> [] - -let lookup_attr (attr:term) (env:Env.env) : list fv = - let ses = lookup_attr_ses attr env in - List.concatMap (fun se -> match U.lid_of_sigelt se with - | None -> [] - | Some l -> [S.lid_as_fv l None]) ses - -let all_defs_in_env (env:Env.env) : list fv = - List.map (fun l -> S.lid_as_fv l None) (Env.lidents env) // |> take 10 - -let defs_in_module (env:Env.env) (modul:name) : list fv = - List.concatMap - (fun l -> - (* must succeed, ids_of_lid always returns a non-empty list *) - let ns = Ident.ids_of_lid l |> init |> List.map Ident.string_of_id in - if ns = modul - then [S.lid_as_fv l None] - else []) - (Env.lidents env) - -let lookup_typ (env:Env.env) (ns:list string) : option sigelt = - let lid = PC.p2l ns in - Env.lookup_sigelt env lid - -let sigelt_attrs (se : sigelt) : list attribute = - se.sigattrs - -let set_sigelt_attrs (attrs : list attribute) (se : sigelt) : sigelt = - { se with sigattrs = attrs } - -(* PRIVATE, and hacky :-( *) -let rd_to_syntax_qual : RD.qualifier -> qualifier = function - | RD.Assumption -> Assumption - | RD.New -> New - | RD.Private -> Private - | RD.Unfold_for_unification_and_vcgen -> Unfold_for_unification_and_vcgen - | RD.Visible_default -> Visible_default - | RD.Irreducible -> Irreducible - | RD.Inline_for_extraction -> Inline_for_extraction - | RD.NoExtract -> NoExtract - | RD.Noeq -> Noeq - | RD.Unopteq -> Unopteq - | RD.TotalEffect -> TotalEffect - | RD.Logic -> Logic - | RD.Reifiable -> Reifiable - | RD.Reflectable l -> Reflectable (Ident.lid_of_path l Range.dummyRange) - | RD.Discriminator l -> Discriminator (Ident.lid_of_path l Range.dummyRange) - | RD.Projector (l, i) -> Projector (Ident.lid_of_path l Range.dummyRange, i) - | RD.RecordType (l1, l2) -> RecordType (l1, l2) - | RD.RecordConstructor (l1, l2) -> RecordConstructor (l1, l2) - | RD.Action l -> Action (Ident.lid_of_path l Range.dummyRange) - | RD.ExceptionConstructor -> ExceptionConstructor - | RD.HasMaskedEffect -> HasMaskedEffect - | RD.Effect -> S.Effect - | RD.OnlyName -> OnlyName - -let syntax_to_rd_qual = function - | Assumption -> RD.Assumption - | New -> RD.New - | Private -> RD.Private - | Unfold_for_unification_and_vcgen -> RD.Unfold_for_unification_and_vcgen - | Visible_default -> RD.Visible_default - | Irreducible -> RD.Irreducible - | Inline_for_extraction -> RD.Inline_for_extraction - | NoExtract -> RD.NoExtract - | Noeq -> RD.Noeq - | Unopteq -> RD.Unopteq - | TotalEffect -> RD.TotalEffect - | Logic -> RD.Logic - | Reifiable -> RD.Reifiable - | Reflectable l -> RD.Reflectable (Ident.path_of_lid l) - | Discriminator l -> RD.Discriminator (Ident.path_of_lid l) - | Projector (l, i) -> RD.Projector (Ident.path_of_lid l, i) - | RecordType (l1, l2) -> RD.RecordType (l1, l2) - | RecordConstructor (l1, l2) -> RD.RecordConstructor (l1, l2) - | Action l -> RD.Action (Ident.path_of_lid l) - | ExceptionConstructor -> RD.ExceptionConstructor - | HasMaskedEffect -> RD.HasMaskedEffect - | S.Effect -> RD.Effect - | OnlyName -> RD.OnlyName - -let inspect_ident (i:ident) : string & Range.range = - (string_of_id i, range_of_id i) - -let pack_ident (i: string & Range.range) : ident = - Ident.mk_ident i - -let sigelt_quals (se : sigelt) : list RD.qualifier = - se.sigquals |> List.map syntax_to_rd_qual - -let set_sigelt_quals (quals : list RD.qualifier) (se : sigelt) : sigelt = - { se with sigquals = List.map rd_to_syntax_qual quals } - -let sigelt_opts (se : sigelt) : option vconfig = se.sigopts - -let embed_vconfig (vcfg : vconfig) : term = - EMB.embed vcfg Range.dummyRange None EMB.id_norm_cb - -let inspect_sigelt (se : sigelt) : sigelt_view = - match se.sigel with - | Sig_let {lbs=(r, lbs)} -> - Sg_Let (r, lbs) - - | Sig_inductive_typ {lid; us; params=param_bs; t=ty; ds=c_lids} -> - let nm = Ident.path_of_lid lid in - - let inspect_ctor (c_lid:Ident.lid) : ctor = - match Env.lookup_sigelt (get_env ()) c_lid with - | Some ({sigel = Sig_datacon {lid; us; t=cty; num_ty_params=nparam}}) -> - (Ident.path_of_lid lid, cty) - - | _ -> - failwith "impossible: inspect_sigelt: did not find ctor" - in - Sg_Inductive (nm, us, param_bs, ty, List.map inspect_ctor c_lids) - - | Sig_declare_typ {lid; us; t=ty} -> - let nm = Ident.path_of_lid lid in - Sg_Val (nm, us, ty) - - | _ -> - Unk - -let pack_sigelt (sv:sigelt_view) : sigelt = - let check_lid lid = - if List.length (Ident.path_of_lid lid) <= 1 - then failwith ("pack_sigelt: invalid long identifier \"" - ^ Ident.string_of_lid lid - ^ "\" (did you forget a module path?)") - in - match sv with - | Sg_Let (r, lbs) -> - let pack_letbinding (lb:letbinding) = - let {lbname=nm} = lb in - let lid = match nm with - | Inr fv -> lid_of_fv fv - | _ -> failwith - "impossible: pack_sigelt: bv in toplevel let binding" - in - check_lid lid; - (lid, lb) - in - let packed = List.map pack_letbinding lbs in - let lbs = List.map snd packed in - let lids = List.map fst packed in - mk_sigelt <| Sig_let {lbs=(r, lbs); lids} - - | Sg_Inductive (nm, us_names, param_bs, ty, ctors) -> - let ind_lid = Ident.lid_of_path nm Range.dummyRange in - check_lid ind_lid; - let nparam = List.length param_bs in - //We can't tust the value of injective_type_params; set it to false here and let the typechecker recompute - let injective_type_params = false in - let pack_ctor (c:ctor) : sigelt = - let (nm, ty) = c in - let lid = Ident.lid_of_path nm Range.dummyRange in - mk_sigelt <| Sig_datacon {lid; us=us_names; t=ty; ty_lid=ind_lid; num_ty_params=nparam; mutuals=[]; injective_type_params } - in - - let ctor_ses : list sigelt = List.map pack_ctor ctors in - let c_lids : list Ident.lid = List.map (fun se -> BU.must (U.lid_of_sigelt se)) ctor_ses in - - let ind_se : sigelt = - //We can't trust the assignment of num uniform binders from the reflection API - //So, set it to None; it has to be checked and recomputed - mk_sigelt <| Sig_inductive_typ {lid=ind_lid; - us=us_names; - params=param_bs; - num_uniform_params=None; - t=ty; - mutuals=[]; - ds=c_lids; - injective_type_params } - in - let se = mk_sigelt <| Sig_bundle {ses=ind_se::ctor_ses; lids=ind_lid::c_lids} in - { se with sigquals = Noeq::se.sigquals } - - | Sg_Val (nm, us_names, ty) -> - let val_lid = Ident.lid_of_path nm Range.dummyRange in - check_lid val_lid; - mk_sigelt <| Sig_declare_typ {lid=val_lid; us=us_names; t=ty} - - | Unk -> failwith "packing Unk, this should never happen" - -let inspect_lb (lb:letbinding) : lb_view = - let {lbname=nm; lbunivs=us; lbtyp=typ; lbeff=_; lbdef=def; lbattrs=_; lbpos=_} = lb in - match nm with - | Inr fv -> {lb_fv = fv; lb_us = us; lb_typ = typ; lb_def = def} - | _ -> failwith "Impossible: bv in top-level let binding" - -let pack_lb (lbv:lb_view) : letbinding = - let {lb_fv = fv; lb_us = us; lb_typ = typ; lb_def = def} = lbv in - U.mk_letbinding (Inr fv) us typ PC.effect_Tot_lid def [] Range.dummyRange - -let inspect_namedv (v:bv) : namedv_view = - if v.index < 0 then ( - Err.log_issue0 Err.Warning_CantInspect - (BU.format3 "inspect_namedv: uniq is negative (%s : %s), uniq = %s" - (Ident.string_of_id v.ppname) (show v.sort) (string_of_int v.index)) - ); - { - uniq = Z.of_int_fs v.index; - ppname = Sealed.seal <| Ident.string_of_id v.ppname; - sort = Sealed.seal <| v.sort - } - -let pack_namedv (vv:namedv_view) : namedv = - if Z.to_int_fs vv.uniq < 0 then ( - Err.log_issue0 Err.Warning_CantInspect - (BU.format2 "pack_namedv: uniq is negative (%s), uniq = %s" - (Sealed.unseal vv.ppname) (show (Z.to_int_fs vv.uniq))) - ); - { - index = Z.to_int_fs vv.uniq; - ppname = Ident.mk_ident (Sealed.unseal vv.ppname, Range.dummyRange); - sort = Sealed.unseal <| vv.sort; - } - -let inspect_bv (bv:bv) : bv_view = - if bv.index < 0 then ( - Err.log_issue0 Err.Warning_CantInspect - (BU.format3 "inspect_bv: index is negative (%s : %s), index = %s" - (Ident.string_of_id bv.ppname) (show bv.sort) (string_of_int bv.index)) - ); - { - index = Z.of_int_fs bv.index; - ppname = Sealed.seal <| Ident.string_of_id bv.ppname; - sort = Sealed.seal <| bv.sort; - } - -let pack_bv (bvv:bv_view) : bv = - if Z.to_int_fs bvv.index < 0 then ( - Err.log_issue0 Err.Warning_CantInspect - (BU.format2 "pack_bv: index is negative (%s), index = %s" - (Sealed.unseal bvv.ppname) (show (Z.to_int_fs bvv.index))) - ); - { - index = Z.to_int_fs bvv.index; - ppname = Ident.mk_ident (Sealed.unseal bvv.ppname, Range.dummyRange); - sort = Sealed.unseal bvv.sort; - } - -let inspect_binder (b:binder) : binder_view = - let attrs = U.encode_positivity_attributes b.binder_positivity b.binder_attrs in - { - ppname = Sealed.seal <| Ident.string_of_id b.binder_bv.ppname; - qual = inspect_bqual (b.binder_qual); - attrs = attrs; - sort = b.binder_bv.sort; - } - -let pack_binder (bview:binder_view) : binder = - let pqual, attrs = U.parse_positivity_attributes bview.attrs in - { - binder_bv= { ppname = Ident.mk_ident (Sealed.unseal bview.ppname, Range.dummyRange) - ; sort = bview.sort - ; index = 0 (* irrelevant, this is a binder *) - }; - binder_qual=pack_bqual (bview.qual); - binder_positivity=pqual; - binder_attrs=attrs - } - -open FStar.TypeChecker.Env -let moduleof (e : Env.env) : list string = - Ident.path_of_lid e.curmodule - -let env_open_modules (e : Env.env) : list name = - List.map (fun (l, m) -> List.map Ident.string_of_id (Ident.ids_of_lid l)) - (DsEnv.open_modules e.dsenv) - -let bv_to_binding (bv : bv) : RD.binding = - { - uniq = Z.of_int_fs bv.index; - sort = bv.sort; - ppname = Sealed.seal <| string_of_id bv.ppname; - } - -let vars_of_env e = FStar.TypeChecker.Env.all_binders e |> List.map (fun b -> bv_to_binding b.binder_bv) - -(* Generic combinators, safe *) -let eqopt = Syntax.Util.eqopt -let eqlist = Syntax.Util.eqlist -let eqprod = Syntax.Util.eqprod - -(* - * Why doesn't this call into Syntax.Util.term_eq? Because that function - * can expose details that are not observable in the userspace view of - * terms, and hence that function cannot be safely exposed if we wish to - * maintain the lemmas stating that pack/inspect are inverses of each - * other. - * - * In other words, we need this function to be implemented consistently - * with the view to make sure it is a _function_ in userspace, and maps - * (propositionally) equal terms to equal results. - * - * So we implement it via inspect_ln, to make sure we don't reveal - * anything inspect_ln does not already reveal. Hence this function - * is really only an optimization of this same implementation done in - * userspace. Also, nothing is guaranted about its result. It if were to - * just return false constantly, that would be safe (though useless). - * - * This same note also applies to comp, and other types that are taken - * as abstract, but have a lemma stating that the view is complete - * (or appear inside a view of one such type). - *) -let rec term_eq (t1:term) (t2:term) : bool = - match inspect_ln t1, inspect_ln t2 with - | Tv_Var bv1, Tv_Var bv2 -> - bv_eq bv1 bv2 - - | Tv_BVar bv1, Tv_BVar bv2 -> - bv_eq bv1 bv2 - - | Tv_FVar fv1, Tv_FVar fv2 -> - (* This should be equivalent to exploding the fv's name comparing *) - S.fv_eq fv1 fv2 - - | Tv_UInst (fv1, us1), Tv_UInst (fv2, us2) -> - S.fv_eq fv1 fv2 && univs_eq us1 us2 - - | Tv_App (h1, arg1), Tv_App (h2, arg2) -> - term_eq h1 h2 && arg_eq arg1 arg2 - - | Tv_Abs (b1, t1), Tv_Abs (b2, t2) -> - binder_eq b1 b2 && term_eq t1 t2 - - | Tv_Arrow (b1, c1), Tv_Arrow (b2, c2) -> - binder_eq b1 b2 && comp_eq c1 c2 - - | Tv_Type u1, Tv_Type u2 -> - univ_eq u1 u2 - - | Tv_Refine (b1, t1), Tv_Refine (b2, t2) -> - (* No need to compare bvs *) - term_eq b1.binder_bv.sort b2.binder_bv.sort && term_eq t1 t2 - - | Tv_Const c1, Tv_Const c2 -> - const_eq c1 c2 - - | Tv_Uvar (n1, uv1), Tv_Uvar (n2, uv2) -> - (* - * The uvs are completely opaque in userspace, so we could do a fancier - * check here without compromising soundness. But.. we cannot really check - * the unionfind graph, I think, since the result could differ as things get - * unified (though it's unclear if that can happen within two calls to this - * function within a *single* definition.. since uvars do not survive across - * top-levels. - * - * Anyway, for now just compare the associated ints. Which are *definitely* - * visible by users. - *) - n1 = n2 - - | Tv_Let (r1, ats1, b1, m1, n1), Tv_Let (r2, ats2, b2, m2, n2) -> - (* no need to compare bvs *) - r1 = r2 && - eqlist term_eq ats1 ats2 && - binder_eq b1 b2 && - term_eq m1 m2 && - term_eq n1 n2 - - | Tv_Match (h1, an1, brs1), Tv_Match (h2, an2, brs2) -> - term_eq h1 h2 && - eqopt match_ret_asc_eq an1 an2 && - eqlist branch_eq brs1 brs2 - - | Tv_AscribedT (e1, t1, topt1, eq1), Tv_AscribedT (e2, t2, topt2, eq2) -> - term_eq e1 e2 && - term_eq t1 t2 && - eqopt term_eq topt1 topt2 && - eq1 = eq2 - - | Tv_AscribedC (e1, c1, topt1, eq1), Tv_AscribedC (e2, c2, topt2, eq2) -> - term_eq e1 e2 && - comp_eq c1 c2 && - eqopt term_eq topt1 topt2 && - eq1 = eq2 - - | Tv_Unknown, Tv_Unknown -> true - | _ -> false - -and arg_eq (arg1 : argv) (arg2 : argv) : bool = - let (a1, aq1) = arg1 in - let (a2, aq2) = arg2 in - term_eq a1 a2 && aqual_eq aq1 aq2 - -and aqual_eq (aq1 : aqualv) (aq2 : aqualv) : bool = - match aq1, aq2 with - | Q_Implicit, Q_Implicit -> true - | Q_Explicit, Q_Explicit -> true - | Q_Meta t1, Q_Meta t2 -> term_eq t1 t2 - | _ -> false - -and binder_eq (b1 : binder) (b2 : binder) : bool = - let bview1 = inspect_binder b1 in - let bview2 = inspect_binder b2 in - term_eq bview1.sort bview2.sort && - aqual_eq bview1.qual bview2.qual && - eqlist term_eq bview1.attrs bview2.attrs - -and bv_eq (bv1 : bv) (bv2 : bv) : bool = - (* - * Just compare the index. Note: this is safe since inspect_bv - * exposes it. We do _not_ compare the sorts. This is already - * what Syntax.Util.term_eq does, and they arguably should not - * be there. - *) - bv1.index = bv2.index - -and comp_eq (c1 : comp) (c2 : comp) : bool = - match inspect_comp c1, inspect_comp c2 with - | C_Total t1, C_Total t2 - | C_GTotal t1, C_GTotal t2 -> - term_eq t1 t2 - - | C_Lemma (pre1, post1, pats1), C_Lemma (pre2, post2, pats2) -> - term_eq pre1 pre2 && term_eq post1 post2 && term_eq pats1 pats2 - - | C_Eff (us1, name1, t1, args1, decrs1), C_Eff (us2, name2, t2, args2, decrs2) -> - univs_eq us1 us2 && - name1 = name2 && - term_eq t1 t2 && - eqlist arg_eq args1 args2 && - eqlist term_eq decrs1 decrs2 - - | _ -> - false - -and match_ret_asc_eq (a1 : match_returns_ascription) (a2 : match_returns_ascription) : bool = - eqprod binder_eq ascription_eq a1 a2 - -and ascription_eq (asc1 : ascription) (asc2 : ascription) : bool = - let (a1, topt1, eq1) = asc1 in - let (a2, topt2, eq2) = asc2 in - (match a1, a2 with - | Inl t1, Inl t2 -> term_eq t1 t2 - | Inr c1, Inr c2 -> comp_eq c1 c2) && - eqopt term_eq topt1 topt2 && - eq1 = eq2 - -and branch_eq (c1 : Data.branch) (c2 : Data.branch) : bool = - eqprod pattern_eq term_eq c1 c2 - -and pattern_eq (p1 : pattern) (p2 : pattern) : bool = - match p1, p2 with - | Pat_Constant c1, Pat_Constant c2 -> - const_eq c1 c2 - | Pat_Cons fv1 us1 subpats1, Pat_Cons fv2 us2 subpats2 -> - S.fv_eq fv1 fv2 && - eqopt (eqlist univ_eq) us1 us2 && - eqlist (eqprod pattern_eq (fun b1 b2 -> b1 = b2)) subpats1 subpats2 - - | Pat_Var _ _, Pat_Var _ _ -> - true - // Should this just be true? Sorts are sealed. - - | Pat_Dot_Term topt1, Pat_Dot_Term topt2 -> - eqopt term_eq topt1 topt2 - - | _ -> false - -and const_eq (c1 : vconst) (c2 : vconst) : bool = - c1 = c2 - -and univ_eq (u1 : universe) (u2 : universe) : bool = - Syntax.Util.eq_univs u1 u2 // FIXME! - -and univs_eq (us1 : list universe) (us2 : list universe) : bool = - eqlist univ_eq us1 us2 - -let implode_qn ns = String.concat "." ns -let explode_qn s = String.split ['.'] s -let compare_string s1 s2 = Z.of_int_fs (String.compare s1 s2) - -let push_binder e b = Env.push_binders e [b] -let push_namedv e b = Env.push_binders e [S.mk_binder b] - -let subst_term (s : list subst_elt) (t : term) : term = - SS.subst s t - -let subst_comp (s : list subst_elt) (c : comp) : comp = - SS.subst_comp s c - -let range_of_term (t:term) = t.pos -let range_of_sigelt (s:sigelt) = s.sigrng - diff --git a/src/reflection/FStar.Reflection.V2.Builtins.fsti b/src/reflection/FStar.Reflection.V2.Builtins.fsti deleted file mode 100644 index 4922de6881f..00000000000 --- a/src/reflection/FStar.Reflection.V2.Builtins.fsti +++ /dev/null @@ -1,110 +0,0 @@ -(* - Copyright 2008-2015 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Reflection.V2.Builtins - -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Ident -open FStar.Order -open FStar.Reflection.V2.Data -open FStar.Syntax.Embeddings -open FStar.Syntax.Syntax -open FStar.VConfig - -module EMB = FStar.Syntax.Embeddings -module Env = FStar.TypeChecker.Env -module O = FStar.Options -module RD = FStar.Reflection.V2.Data -module S = FStar.Syntax.Syntax -module Z = FStar.BigInt - -(* Primitives *) -val compare_bv : bv -> bv -> order -val compare_namedv : namedv -> namedv -> order -val lookup_typ : Env.env -> list string -> option sigelt -val lookup_attr_ses : term -> Env.env -> list sigelt -val lookup_attr : term -> Env.env -> list fv -val all_defs_in_env : Env.env -> list fv -val defs_in_module : Env.env -> name -> list fv -val vars_of_env : Env.env -> list RD.binding -val moduleof : Env.env -> list string -val term_eq : term -> term -> bool -val env_open_modules : Env.env -> list name -val sigelt_opts : sigelt -> option vconfig -val embed_vconfig : vconfig -> term - -val sigelt_attrs : sigelt -> list attribute -val set_sigelt_attrs : list attribute -> sigelt -> sigelt - -val sigelt_quals : sigelt -> list RD.qualifier -val set_sigelt_quals : list RD.qualifier -> sigelt -> sigelt - -(* Views *) -val inspect_fv : fv -> list string -val pack_fv : list string -> fv - -val inspect_const : sconst -> vconst -val pack_const : vconst -> sconst - -val inspect_ln : term -> term_view -val pack_ln : term_view -> term - -val inspect_comp : comp -> comp_view -val pack_comp : comp_view -> comp - -val inspect_sigelt : sigelt -> sigelt_view -val pack_sigelt : sigelt_view -> sigelt - -val inspect_lb : letbinding -> lb_view -val pack_lb : lb_view -> letbinding - -val inspect_namedv : namedv -> namedv_view -val pack_namedv : namedv_view -> namedv - -val inspect_bv : bv -> bv_view -val pack_bv : bv_view -> bv - -val inspect_binder : binder -> binder_view -val pack_binder : binder_view -> binder - -val inspect_aqual : aqual -> aqualv -val pack_aqual : aqualv -> aqual - -val inspect_universe : universe -> universe_view -val pack_universe : universe_view -> universe - -(* Only used internally by check_match_complete... the pattern -(abstract) type is not really exposed, so the user has no use for these. -Perhaps it is more consistent to introduce a pattern_view... *) -val inspect_pat : S.pat -> pattern -val pack_pat : pattern -> S.pat - -(* We're only taking these as primitives to break the dependency from * -FStar.Tactics into FStar.String, which pulls a LOT of modules. *) -val implode_qn : list string -> string -val explode_qn : string -> list string -val compare_string : string -> string -> Z.t - -val push_namedv : Env.env -> bv -> Env.env - -val range_of_term : term -> Range.range -val range_of_sigelt : sigelt -> Range.range - -val subst_term : list subst_elt -> term -> term -val subst_comp : list subst_elt -> comp -> comp - -val inspect_ident : ident -> string & Range.range -val pack_ident : string & Range.range -> ident diff --git a/src/reflection/FStar.Reflection.V2.Constants.fst b/src/reflection/FStar.Reflection.V2.Constants.fst deleted file mode 100644 index 09566643908..00000000000 --- a/src/reflection/FStar.Reflection.V2.Constants.fst +++ /dev/null @@ -1,327 +0,0 @@ -(* - Copyright 2008-2022 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Reflection.V2.Constants - - -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List - -(* NOTE: This file is exactly the same as its .fs variant. It is only -here so the equally-named interface file in ulib/ is not taken by the -dependency analysis to be the interface of the .fs. We also cannot ditch -the .fs, since out bootstrapping process does not extract any .ml file -from an interface. Hence we keep both, exactly equal to each other. *) - -open FStar.Syntax.Syntax -module Ident = FStar.Ident -module Range = FStar.Compiler.Range -module Z = FStar.BigInt -open FStar.Ident -module PC = FStar.Parser.Const - -(* Contains all lids and terms needed for embedding/unembedding *) - -type refl_constant = { - lid : FStar.Ident.lid; - fv : fv; - t : term; -} - -let refl_constant_lid rc = rc.lid -let refl_constant_term rc = rc.t - -let fstar_syntax_syntax_lid s = Ident.lid_of_path (["FStar"; "Stubs"; "Syntax"; "Syntax"]@s) Range.dummyRange - -let fstar_refl_lid s = Ident.lid_of_path (["FStar"; "Stubs"; "Reflection"]@s) Range.dummyRange - -let fstar_refl_types_lid s = fstar_refl_lid ["Types"; s] -let fstar_refl_builtins_lid s = fstar_refl_lid ["V2"; "Builtins"; s] -let fstar_refl_data_lid s = fstar_refl_lid ["V2"; "Data"; s] - -let fstar_syntax_syntax_const s = - let lid = fstar_syntax_syntax_lid s in - { lid = lid - ; fv = lid_as_fv lid (Some Data_ctor) - ; t = tdataconstr lid - } - -let fstar_refl_data_const s = - let lid = fstar_refl_data_lid s in - { lid = lid - ; fv = lid_as_fv lid (Some Data_ctor) - ; t = tdataconstr lid - } - -let mk_refl_types_lid_as_term (s:string) = tconst (fstar_refl_types_lid s) -let mk_refl_types_lid_as_fv (s:string) = fvconst (fstar_refl_types_lid s) -let mk_refl_data_lid_as_term (s:string) = tconst (fstar_refl_data_lid s) -let mk_refl_data_lid_as_fv (s:string) = fvconst (fstar_refl_data_lid s) - -(* FStar.Syntax.Syntax *) -let mk_ss_lid_as_fv (s:string) = fvconst (fstar_syntax_syntax_lid [s]) -let mk_ss_lid_as_term (s:string) = tconst (fstar_syntax_syntax_lid [s]) - -let mk_inspect_pack_pair s = - let inspect_lid = fstar_refl_builtins_lid ("inspect" ^ s) in - let pack_lid = fstar_refl_builtins_lid ("pack" ^ s) in - let inspect_fv = lid_as_fv inspect_lid None in - let pack_fv = lid_as_fv pack_lid None in - let inspect = { lid = inspect_lid ; fv = inspect_fv ; t = fv_to_tm inspect_fv } in - let pack = { lid = pack_lid ; fv = pack_fv ; t = fv_to_tm pack_fv } in - (inspect, pack) - -let fstar_refl_inspect_ln , fstar_refl_pack_ln = mk_inspect_pack_pair "_ln" -let fstar_refl_inspect_fv , fstar_refl_pack_fv = mk_inspect_pack_pair "_fv" -let fstar_refl_inspect_bv , fstar_refl_pack_bv = mk_inspect_pack_pair "_bv" -let fstar_refl_inspect_namedv , fstar_refl_pack_namedv = mk_inspect_pack_pair "_namedv" -let fstar_refl_inspect_binder , fstar_refl_pack_binder = mk_inspect_pack_pair "_binder" -let fstar_refl_inspect_comp , fstar_refl_pack_comp = mk_inspect_pack_pair "_comp" -let fstar_refl_inspect_sigelt , fstar_refl_pack_sigelt = mk_inspect_pack_pair "_sigelt" -let fstar_refl_inspect_lb , fstar_refl_pack_lb = mk_inspect_pack_pair "_lb" -let fstar_refl_inspect_universe, fstar_refl_pack_universe = mk_inspect_pack_pair "_universe" - -(* assumed types *) -let fstar_refl_env = mk_refl_types_lid_as_term "env" -let fstar_refl_env_fv = mk_refl_types_lid_as_fv "env" -let fstar_refl_namedv = mk_refl_types_lid_as_term "namedv" -let fstar_refl_namedv_fv = mk_refl_types_lid_as_fv "namedv" -let fstar_refl_bv = mk_refl_types_lid_as_term "bv" -let fstar_refl_bv_fv = mk_refl_types_lid_as_fv "bv" -let fstar_refl_fv = mk_refl_types_lid_as_term "fv" -let fstar_refl_fv_fv = mk_refl_types_lid_as_fv "fv" -let fstar_refl_comp = mk_refl_types_lid_as_term "comp" -let fstar_refl_comp_fv = mk_refl_types_lid_as_fv "comp" -let fstar_refl_binding = mk_refl_types_lid_as_term "binding" -let fstar_refl_binding_fv = mk_refl_types_lid_as_fv "binding" -let fstar_refl_binder = mk_refl_types_lid_as_term "binder" -let fstar_refl_binder_fv = mk_refl_types_lid_as_fv "binder" -let fstar_refl_sigelt = mk_refl_types_lid_as_term "sigelt" -let fstar_refl_sigelt_fv = mk_refl_types_lid_as_fv "sigelt" -let fstar_refl_term = mk_refl_types_lid_as_term "term" -let fstar_refl_term_fv = mk_refl_types_lid_as_fv "term" -let fstar_refl_letbinding = mk_refl_types_lid_as_term "letbinding" -let fstar_refl_letbinding_fv = mk_refl_types_lid_as_fv "letbinding" -let fstar_refl_ident = mk_refl_types_lid_as_term "ident" -let fstar_refl_ident_fv = mk_refl_types_lid_as_fv "ident" -let fstar_refl_univ_name = mk_refl_types_lid_as_term "univ_name" -let fstar_refl_univ_name_fv = mk_refl_types_lid_as_fv "univ_name" -let fstar_refl_optionstate = mk_refl_types_lid_as_term "optionstate" -let fstar_refl_optionstate_fv = mk_refl_types_lid_as_fv "optionstate" -let fstar_refl_universe = mk_refl_types_lid_as_term "universe" -let fstar_refl_universe_fv = mk_refl_types_lid_as_fv "universe" -let fstar_refl_universe_uvar = mk_refl_types_lid_as_term "universe_uvar" -let fstar_refl_universe_uvar_fv = mk_refl_types_lid_as_fv "universe_uvar" -let fstar_refl_ctx_uvar_and_subst = mk_refl_types_lid_as_term "ctx_uvar_and_subst" -let fstar_refl_ctx_uvar_and_subst_fv = mk_refl_types_lid_as_fv "ctx_uvar_and_subst" - -(* auxiliary types *) -let fstar_refl_aqualv = mk_refl_data_lid_as_term "aqualv" -let fstar_refl_aqualv_fv = mk_refl_data_lid_as_fv "aqualv" -let fstar_refl_comp_view = mk_refl_data_lid_as_term "comp_view" -let fstar_refl_comp_view_fv = mk_refl_data_lid_as_fv "comp_view" -let fstar_refl_term_view = mk_refl_data_lid_as_term "term_view" -let fstar_refl_term_view_fv = mk_refl_data_lid_as_fv "term_view" -let fstar_refl_pattern = mk_refl_data_lid_as_term "pattern" -let fstar_refl_pattern_fv = mk_refl_data_lid_as_fv "pattern" -let fstar_refl_branch = mk_refl_data_lid_as_term "branch" -let fstar_refl_branch_fv = mk_refl_data_lid_as_fv "branch" -let fstar_refl_namedv_view = mk_refl_data_lid_as_term "namedv_view" -let fstar_refl_namedv_view_fv = mk_refl_data_lid_as_fv "namedv_view" -let fstar_refl_bv_view = mk_refl_data_lid_as_term "bv_view" -let fstar_refl_bv_view_fv = mk_refl_data_lid_as_fv "bv_view" -let fstar_refl_binder_view = mk_refl_data_lid_as_term "binder_view" -let fstar_refl_binder_view_fv = mk_refl_data_lid_as_fv "binder_view" -let fstar_refl_vconst = mk_refl_data_lid_as_term "vconst" -let fstar_refl_vconst_fv = mk_refl_data_lid_as_fv "vconst" -let fstar_refl_lb_view = mk_refl_data_lid_as_term "lb_view" -let fstar_refl_lb_view_fv = mk_refl_data_lid_as_fv "lb_view" -let fstar_refl_sigelt_view = mk_refl_data_lid_as_term "sigelt_view" -let fstar_refl_sigelt_view_fv = mk_refl_data_lid_as_fv "sigelt_view" -let fstar_refl_qualifier = mk_refl_data_lid_as_term "qualifier" -let fstar_refl_qualifier_fv = mk_refl_data_lid_as_fv "qualifier" -let fstar_refl_universe_view = mk_refl_data_lid_as_term "universe_view" -let fstar_refl_universe_view_fv = mk_refl_data_lid_as_fv "universe_view" - -let fstar_refl_subst_elt = mk_ss_lid_as_term "subst_elt" -let fstar_refl_subst_elt_fv = mk_ss_lid_as_fv "subst_elt" -let fstar_refl_subst = mk_ss_lid_as_term "subst" -let fstar_refl_subst_fv = mk_ss_lid_as_fv "subst" - - -(* bv_view, this is a record constructor *) - -let ref_Mk_namedv_view = - let lid = fstar_refl_data_lid "Mknamedv_view" in - let attr = Record_ctor (fstar_refl_data_lid "namedv_view", [ - Ident.mk_ident ("uniq" , Range.dummyRange); - Ident.mk_ident ("sort" , Range.dummyRange); - Ident.mk_ident ("ppname", Range.dummyRange); - ]) in - let fv = lid_as_fv lid (Some attr) in - { lid = lid - ; fv = fv - ; t = fv_to_tm fv - } - -let ref_Mk_bv_view = - let lid = fstar_refl_data_lid "Mkbv_view" in - let attr = Record_ctor (fstar_refl_data_lid "bv_view", [ - Ident.mk_ident ("index" , Range.dummyRange); - Ident.mk_ident ("sort" , Range.dummyRange); - Ident.mk_ident ("ppname", Range.dummyRange); - ]) in - let fv = lid_as_fv lid (Some attr) in - { lid = lid - ; fv = fv - ; t = fv_to_tm fv - } - -let ref_Mk_binding = - let lid = fstar_refl_data_lid "Mkbinding" in - let attr = Record_ctor (fstar_refl_data_lid "binding", [ - Ident.mk_ident ("uniq", Range.dummyRange); - Ident.mk_ident ("sort", Range.dummyRange); - Ident.mk_ident ("ppname" , Range.dummyRange); - ]) in - let fv = lid_as_fv lid (Some attr) in - { lid = lid; - fv = fv; - t = fv_to_tm fv } - -let ref_Mk_binder_view = - let lid = fstar_refl_data_lid "Mkbinder_view" in - let attr = Record_ctor (fstar_refl_data_lid "binder_view", [ - Ident.mk_ident ("sort" , Range.dummyRange); - Ident.mk_ident ("qual", Range.dummyRange); - Ident.mk_ident ("attrs", Range.dummyRange); - Ident.mk_ident ("ppname", Range.dummyRange); - ]) in - let fv = lid_as_fv lid (Some attr) in - { lid = lid; - fv = fv; - t = fv_to_tm fv } - -let ref_Mk_lb = - let lid = fstar_refl_data_lid "Mklb_view" in - let attr = Record_ctor (fstar_refl_data_lid "lb_view", [ - Ident.mk_ident ("lb_fv" , Range.dummyRange); - Ident.mk_ident ("lb_us" , Range.dummyRange); - Ident.mk_ident ("lb_typ" , Range.dummyRange); - Ident.mk_ident ("lb_def" , Range.dummyRange) - ]) in - let fv = lid_as_fv lid (Some attr) in - { lid = lid - ; fv = fv - ; t = fv_to_tm fv - } - -(* quals *) -let ref_Q_Explicit = fstar_refl_data_const "Q_Explicit" -let ref_Q_Implicit = fstar_refl_data_const "Q_Implicit" -let ref_Q_Equality = fstar_refl_data_const "Q_Equality" -let ref_Q_Meta = fstar_refl_data_const "Q_Meta" - -(* subst_elt *) -let ref_DB = fstar_syntax_syntax_const ["DB"] -let ref_DT = fstar_syntax_syntax_const ["DT"] -let ref_NM = fstar_syntax_syntax_const ["NM"] -let ref_NT = fstar_syntax_syntax_const ["NT"] -let ref_UN = fstar_syntax_syntax_const ["UN"] -let ref_UD = fstar_syntax_syntax_const ["UD"] - -(* const *) -let ref_C_Unit = fstar_refl_data_const "C_Unit" -let ref_C_True = fstar_refl_data_const "C_True" -let ref_C_False = fstar_refl_data_const "C_False" -let ref_C_Int = fstar_refl_data_const "C_Int" -let ref_C_String = fstar_refl_data_const "C_String" -let ref_C_Range = fstar_refl_data_const "C_Range" -let ref_C_Reify = fstar_refl_data_const "C_Reify" -let ref_C_Reflect = fstar_refl_data_const "C_Reflect" -let ref_C_Real = fstar_refl_data_const "C_Real" - -(* pattern *) -let ref_Pat_Constant = fstar_refl_data_const "Pat_Constant" -let ref_Pat_Cons = fstar_refl_data_const "Pat_Cons" -let ref_Pat_Var = fstar_refl_data_const "Pat_Var" -let ref_Pat_Dot_Term = fstar_refl_data_const "Pat_Dot_Term" - -(* universe_view *) -let ref_Uv_Zero = fstar_refl_data_const "Uv_Zero" -let ref_Uv_Succ = fstar_refl_data_const "Uv_Succ" -let ref_Uv_Max = fstar_refl_data_const "Uv_Max" -let ref_Uv_BVar = fstar_refl_data_const "Uv_BVar" -let ref_Uv_Name = fstar_refl_data_const "Uv_Name" -let ref_Uv_Unif = fstar_refl_data_const "Uv_Unif" -let ref_Uv_Unk = fstar_refl_data_const "Uv_Unk" - -(* term_view *) -let ref_Tv_Var = fstar_refl_data_const "Tv_Var" -let ref_Tv_BVar = fstar_refl_data_const "Tv_BVar" -let ref_Tv_FVar = fstar_refl_data_const "Tv_FVar" -let ref_Tv_UInst = fstar_refl_data_const "Tv_UInst" -let ref_Tv_App = fstar_refl_data_const "Tv_App" -let ref_Tv_Abs = fstar_refl_data_const "Tv_Abs" -let ref_Tv_Arrow = fstar_refl_data_const "Tv_Arrow" -let ref_Tv_Type = fstar_refl_data_const "Tv_Type" -let ref_Tv_Refine = fstar_refl_data_const "Tv_Refine" -let ref_Tv_Const = fstar_refl_data_const "Tv_Const" -let ref_Tv_Uvar = fstar_refl_data_const "Tv_Uvar" -let ref_Tv_Let = fstar_refl_data_const "Tv_Let" -let ref_Tv_Match = fstar_refl_data_const "Tv_Match" -let ref_Tv_AscT = fstar_refl_data_const "Tv_AscribedT" -let ref_Tv_AscC = fstar_refl_data_const "Tv_AscribedC" -let ref_Tv_Unknown = fstar_refl_data_const "Tv_Unknown" -let ref_Tv_Unsupp = fstar_refl_data_const "Tv_Unsupp" - -(* comp_view *) -let ref_C_Total = fstar_refl_data_const "C_Total" -let ref_C_GTotal = fstar_refl_data_const "C_GTotal" -let ref_C_Lemma = fstar_refl_data_const "C_Lemma" -let ref_C_Eff = fstar_refl_data_const "C_Eff" - -(* inductives & sigelts *) -let ref_Sg_Let = fstar_refl_data_const "Sg_Let" -let ref_Sg_Inductive = fstar_refl_data_const "Sg_Inductive" -let ref_Sg_Val = fstar_refl_data_const "Sg_Val" -let ref_Unk = fstar_refl_data_const "Unk" - -(* qualifiers *) -let ref_qual_Assumption = fstar_refl_data_const "Assumption" -let ref_qual_InternalAssumption = fstar_refl_data_const "InternalAssumption" -let ref_qual_New = fstar_refl_data_const "New" -let ref_qual_Private = fstar_refl_data_const "Private" -let ref_qual_Unfold_for_unification_and_vcgen = fstar_refl_data_const "Unfold_for_unification_and_vcgen" -let ref_qual_Visible_default = fstar_refl_data_const "Visible_default" -let ref_qual_Irreducible = fstar_refl_data_const "Irreducible" -let ref_qual_Inline_for_extraction = fstar_refl_data_const "Inline_for_extraction" -let ref_qual_NoExtract = fstar_refl_data_const "NoExtract" -let ref_qual_Noeq = fstar_refl_data_const "Noeq" -let ref_qual_Unopteq = fstar_refl_data_const "Unopteq" -let ref_qual_TotalEffect = fstar_refl_data_const "TotalEffect" -let ref_qual_Logic = fstar_refl_data_const "Logic" -let ref_qual_Reifiable = fstar_refl_data_const "Reifiable" -let ref_qual_Reflectable = fstar_refl_data_const "Reflectable" -let ref_qual_Discriminator = fstar_refl_data_const "Discriminator" -let ref_qual_Projector = fstar_refl_data_const "Projector" -let ref_qual_RecordType = fstar_refl_data_const "RecordType" -let ref_qual_RecordConstructor = fstar_refl_data_const "RecordConstructor" -let ref_qual_Action = fstar_refl_data_const "Action" -let ref_qual_ExceptionConstructor = fstar_refl_data_const "ExceptionConstructor" -let ref_qual_HasMaskedEffect = fstar_refl_data_const "HasMaskedEffect" -let ref_qual_Effect = fstar_refl_data_const "Effect" -let ref_qual_OnlyName = fstar_refl_data_const "OnlyName" diff --git a/src/reflection/FStar.Reflection.V2.Data.fst b/src/reflection/FStar.Reflection.V2.Data.fst deleted file mode 100644 index bcf74b4b038..00000000000 --- a/src/reflection/FStar.Reflection.V2.Data.fst +++ /dev/null @@ -1,44 +0,0 @@ -(* - Copyright 2008-2022 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Reflection.V2.Data - -(* NOTE: This file is exactly the same as its .fs/.fsi counterpart. -It is only here so the equally-named interface file in ulib/ is not -taken by the dependency analysis to be the interface of the .fs. We also -cannot ditch the .fs, since out bootstrapping process does not extract -any .ml file from an interface. Hence we keep both, exactly equal to -each other. *) -open FStar.Compiler.List -open FStar.Syntax.Syntax -module Ident = FStar.Ident -module Range = FStar.Compiler.Range -module Z = FStar.BigInt -open FStar.Ident - -(* These two functions are in ulib/FStar.Reflection.V2.Data.fsti - But, they are not extracted from there. - - Instead, these functions are extraction from this file. It is - not sufficient to place these functions in the interface - src/reflection/FStar.Reflection.V2.Data.fsti since this module, like the - rest of the compiler, is extracted in MLish mode. Which means that - functions in the interface are not supported for extraction. So, - we include them in this module implementation file to force them - to be extracted *) -let as_ppname (x:string) : Tot ppname_t = FStar.Compiler.Sealed.seal x - -let notAscription (tv:term_view) : Tot bool = - not (Tv_AscribedT? tv) && not (Tv_AscribedC? tv) diff --git a/src/reflection/FStar.Reflection.V2.Data.fsti b/src/reflection/FStar.Reflection.V2.Data.fsti deleted file mode 100644 index 8af3ff2a12d..00000000000 --- a/src/reflection/FStar.Reflection.V2.Data.fsti +++ /dev/null @@ -1,218 +0,0 @@ -(* - Copyright 2008-2022 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Reflection.V2.Data - -(* NOTE: This file is exactly the same as its .fs/.fsi counterpart. -It is only here so the equally-named interface file in ulib/ is not -taken by the dependency analysis to be the interface of the .fs. We also -cannot ditch the .fs, since out bootstrapping process does not extract -any .ml file from an interface. Hence we keep both, exactly equal to -each other. *) -open FStar.Compiler.List -open FStar.Syntax.Syntax -module Ident = FStar.Ident -module Range = FStar.Compiler.Range -module Z = FStar.BigInt -open FStar.Ident -open FStar.Compiler.Sealed - -type name = list string -type typ = term -type binders = list binder - -type ppname_t = sealed string -val as_ppname (s:string) : Tot ppname_t - -let binder_is_simple (b:Stubs.Reflection.Types.binder) : Tot Type0 = True - -type simple_binder = Stubs.Reflection.Types.binder - -type ident_view = string & Range.range - -(* No distinction internally between bvars and named vars *) -type namedv = bv - -type vconst = - | C_Unit - | C_Int of Z.t - | C_True - | C_False - | C_String of string - | C_Range of Range.range - | C_Reify - | C_Reflect of name - | C_Real of string (* Real literals are represented as a string e.g. "1.2" *) - -type universes = list universe - -type pattern = - // A built-in constant - | Pat_Constant : - c : vconst -> - pattern - - // A fully applied constructor, each boolean marks whether the - // argument was an explicitly-provided implicit argument - | Pat_Cons : - head : fv -> - univs : option universes -> - subpats : list (pattern & bool) -> - pattern - - // A pattern-bound variable. It has a sealed sort in it (in userland). - // This sort is ignored by the typechecker, but may be useful - // for metaprogram to look at heuristically. There is nothing - // else here but a ppname, the variable is referred to by its DB index. - // This means all Pat_Var are provably equal. - | Pat_Var : - sort : sealed term -> - ppname : ppname_t -> - pattern - - // Dot pattern: resolved by other elements in the pattern and type - | Pat_Dot_Term : - t : option term -> - pattern - -type branch = pattern & term - -type aqualv = - | Q_Implicit - | Q_Explicit - | Q_Equality - | Q_Meta of term - -type argv = term & aqualv - -type namedv_view = { - uniq : Z.t; - sort : sealed typ; - ppname : ppname_t; -} - -type bv_view = { - index : Z.t; - sort : sealed typ; - ppname : ppname_t; -} - -type binder_view = { - sort : typ; - qual : aqualv; - attrs : list term; - ppname : ppname_t; -} - -type binding = { - uniq : Z.t; - sort : typ; - ppname : ppname_t; -} -type bindings = list binding - -type universe_view = - | Uv_Zero : universe_view - | Uv_Succ : universe -> universe_view - | Uv_Max : universes -> universe_view - | Uv_BVar : Z.t -> universe_view - | Uv_Name : univ_name -> universe_view - | Uv_Unif : universe_uvar -> universe_view - | Uv_Unk : universe_view - -type term_view = - | Tv_Var of namedv - | Tv_BVar of bv - | Tv_FVar of fv - | Tv_UInst of fv & universes - | Tv_App of term & argv - | Tv_Abs of binder & term - | Tv_Arrow of binder & comp - | Tv_Type of universe - | Tv_Refine of binder & term - | Tv_Const of vconst - | Tv_Uvar of Z.t & ctx_uvar_and_subst - | Tv_Let of bool & list term & binder & term & term - | Tv_Match of term & option match_returns_ascription & list branch - | Tv_AscribedT of term & term & option term & bool //if the boolean flag is true, the ascription is an equality ascription - //see also Syntax - | Tv_AscribedC of term & comp & option term & bool //bool is similar to Tv_AscribedT - | Tv_Unknown - | Tv_Unsupp - -val notAscription (t:term_view) : Tot bool - -type comp_view = - | C_Total of typ - | C_GTotal of typ - | C_Lemma of term & term & term - | C_Eff of universes & name & term & list argv & list term // list term is the decreases clause - -type ctor = name & typ - -type lb_view = { - lb_fv : fv; - lb_us : list univ_name; - lb_typ : typ; - lb_def : term -} - -type sigelt_view = - | Sg_Let of bool & list letbinding - // The bool indicates if it's a let rec - // Non-empty list of (possibly) mutually recursive let-bindings - | Sg_Inductive of name & list univ_name & list binder & typ & list ctor // name, params, type, constructors - | Sg_Val of name & list univ_name & typ - | Unk - - -(* This is a mirror of FStar.Syntax.Syntax.qualifier *) -type qualifier = - | Assumption - | InternalAssumption - | New - | Private - | Unfold_for_unification_and_vcgen - | Visible_default - | Irreducible - | Inline_for_extraction - | NoExtract - | Noeq - | Unopteq - | TotalEffect - | Logic - | Reifiable - | Reflectable of name - | Discriminator of name - | Projector of name & ident - | RecordType of (list ident & list ident) - | RecordConstructor of (list ident & list ident) - | Action of name - | ExceptionConstructor - | HasMaskedEffect - | Effect - | OnlyName - -type qualifiers = list qualifier - -type var = Z.t - -type exp = - | Unit - | Var of var - | Mult of exp & exp - -(* Needed so this appears in the ocaml output for the fstar tactics library *) -type decls = list sigelt diff --git a/src/reflection/FStar.Reflection.V2.Embeddings.fst b/src/reflection/FStar.Reflection.V2.Embeddings.fst deleted file mode 100644 index 58525026654..00000000000 --- a/src/reflection/FStar.Reflection.V2.Embeddings.fst +++ /dev/null @@ -1,843 +0,0 @@ -(* - Copyright 2008-2022 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Reflection.V2.Embeddings - -open FStar.Compiler.Effect -open FStar.Reflection.V2.Data -open FStar.Syntax.Syntax -open FStar.Syntax.Embeddings -open FStar.Order -open FStar.Errors - -module BU = FStar.Compiler.Util -module EMB = FStar.Syntax.Embeddings -module Env = FStar.TypeChecker.Env -module Err = FStar.Errors -module I = FStar.Ident -module List = FStar.Compiler.List -module NBETerm = FStar.TypeChecker.NBETerm -module O = FStar.Options -module PC = FStar.Parser.Const -module Print = FStar.Syntax.Print -module Range = FStar.Compiler.Range -module RD = FStar.Reflection.V2.Data -module S = FStar.Syntax.Syntax // TODO: remove, it's open -module SS = FStar.Syntax.Subst -module U = FStar.Syntax.Util -module Z = FStar.BigInt - -open FStar.Reflection.V2.Builtins //needed for inspect_fv, but that feels wrong -open FStar.Dyn -open FStar.Syntax.Embeddings.AppEmb -open FStar.Class.Monad - -(* We only use simple embeddings here *) -let mk_emb f g t = - mk_emb (fun x r _topt _norm -> f r x) - (fun x _norm -> g x) - (term_as_fv t) -let embed {|embedding 'a|} r (x:'a) = embed x r None id_norm_cb -let try_unembed {|embedding 'a|} x : option 'a = try_unembed x id_norm_cb - -open FStar.Reflection.V2.Constants - -let curry f x y = f (x,y) -let curry3 f x y z = f (x,y,z) -let curry4 f x y z w = f (x,y,z,w) -let curry5 f x y z w v = f (x,y,z,w,v) - -let head_fv_and_args (t : term) : option (fv & args) = - let t = U.unascribe t in - let hd, args = U.head_and_args t in - match (U.un_uinst hd).n with - | Tm_fvar fv -> Some (fv, args) - | _ -> None - -let noaqs : antiquotations = (0, []) - -(* -------------------------------------------------------------------------------------- *) -(* ------------------------------------- EMBEDDINGS ------------------------------------- *) -(* -------------------------------------------------------------------------------------- *) - -(* The lazy embeddings: just embedding whatever value as a blob inside a Tm_Lazy node. *) -let e_bv : embedding bv = EMB.e_lazy Lazy_bv fstar_refl_bv -let e_namedv : embedding namedv = EMB.e_lazy Lazy_namedv fstar_refl_namedv -let e_binder : embedding binder = EMB.e_lazy Lazy_binder fstar_refl_binder -let e_fv : embedding fv = EMB.e_lazy Lazy_fvar fstar_refl_fv -let e_comp : embedding comp = EMB.e_lazy Lazy_comp fstar_refl_comp -let e_universe : embedding universe = EMB.e_lazy Lazy_universe fstar_refl_universe -let e_ident : embedding I.ident = EMB.e_lazy Lazy_ident fstar_refl_ident -let e_env : embedding env = EMB.e_lazy Lazy_env fstar_refl_env -let e_sigelt : embedding sigelt = EMB.e_lazy Lazy_sigelt fstar_refl_sigelt -let e_letbinding : embedding letbinding = EMB.e_lazy Lazy_letbinding fstar_refl_letbinding - -instance e_ctx_uvar_and_subst : embedding ctx_uvar_and_subst = EMB.e_lazy Lazy_uvar fstar_refl_ctx_uvar_and_subst -instance e_universe_uvar : embedding universe_uvar = EMB.e_lazy Lazy_universe_uvar fstar_refl_universe_uvar - -let rec mapM_opt (f : ('a -> option 'b)) (l : list 'a) : option (list 'b) = - match l with - | [] -> Some [] - | x::xs -> - BU.bind_opt (f x) (fun x -> - BU.bind_opt (mapM_opt f xs) (fun xs -> - Some (x :: xs))) - -let e_term_aq aq = - let embed_term (rng:Range.range) (t:term) : term = - let qi = { qkind = Quote_static; antiquotations = aq } in - S.mk (Tm_quoted (t, qi)) rng - in - let rec unembed_term (t:term) : option term = - let apply_antiquotations (t:term) (aq:antiquotations) : option term = - let shift, aqs = aq in - let aqs = List.rev aqs in - // Try to unembed all antiquotations - BU.bind_opt (mapM_opt unembed_term aqs) (fun aq_ts -> - // Create a substitution of the DB indices of t for the antiquotations - (* let n = List.length aq_ts - 1 in *) - let subst_open, subst = - aq_ts - |> List.mapi (fun i at -> - let x = S.new_bv None S.t_term in - DB(shift+i, x), NT (x, at)) - |> List.unzip - in - - // Substitute and return - Some (SS.subst subst <| SS.subst subst_open t)) - in - let t = U.unmeta t in - match (SS.compress t).n with - | Tm_quoted (tm, qi) -> - apply_antiquotations tm qi.antiquotations - | _ -> None - in - mk_emb embed_term unembed_term S.t_term - -let e_term = e_term_aq noaqs - -let e_sort : embedding (Sealed.sealed term) = e_sealed e_term -let e_ppname : embedding ppname_t = e_sealed e_string - -let e_aqualv = - let embed_aqualv (rng:Range.range) (q : aqualv) : term = - let r = - match q with - | Data.Q_Explicit -> ref_Q_Explicit.t - | Data.Q_Implicit -> ref_Q_Implicit.t - | Data.Q_Equality -> ref_Q_Equality.t - | Data.Q_Meta t -> - S.mk_Tm_app ref_Q_Meta.t [S.as_arg (embed #_ #e_term rng t)] - Range.dummyRange - in { r with pos = rng } - in - let unembed_aqualv (t : term) : option aqualv = - let? fv, args = head_fv_and_args t in - match () with - | _ when S.fv_eq_lid fv ref_Q_Explicit.lid -> run args (pure Data.Q_Explicit) - | _ when S.fv_eq_lid fv ref_Q_Implicit.lid -> run args (pure Data.Q_Implicit) - | _ when S.fv_eq_lid fv ref_Q_Equality.lid -> run args (pure Data.Q_Equality) - | _ when S.fv_eq_lid fv ref_Q_Meta.lid -> run args (Data.Q_Meta <$$> e_term) - | _ -> None - in - mk_emb embed_aqualv unembed_aqualv fstar_refl_aqualv - -let e_binders = e_list e_binder - -let e_universe_view = - let embed_universe_view (rng:Range.range) (uv:universe_view) : term = - match uv with - | Uv_Zero -> ref_Uv_Zero.t - | Uv_Succ u -> - S.mk_Tm_app - ref_Uv_Succ.t - [S.as_arg (embed rng u)] - rng - | Uv_Max us -> - S.mk_Tm_app - ref_Uv_Max.t - [S.as_arg (embed rng us)] - rng - | Uv_BVar n -> - S.mk_Tm_app - ref_Uv_BVar.t - [S.as_arg (embed rng n)] - rng - | Uv_Name i -> - S.mk_Tm_app - ref_Uv_Name.t - [S.as_arg (embed rng i)] - rng - | Uv_Unif u -> - S.mk_Tm_app - ref_Uv_Unif.t - [S.as_arg (embed rng u)] - rng - | Uv_Unk -> - ref_Uv_Unk.t in - - let unembed_universe_view (t:term) : option universe_view = - let? fv, args = head_fv_and_args t in - match () with - | _ when S.fv_eq_lid fv ref_Uv_Zero.lid -> run args (pure Uv_Zero) - | _ when S.fv_eq_lid fv ref_Uv_Succ.lid -> run args (Uv_Succ <$$> e_universe) - | _ when S.fv_eq_lid fv ref_Uv_Max.lid -> run args (Uv_Max <$$> e_list e_universe) - | _ when S.fv_eq_lid fv ref_Uv_BVar.lid -> run args (Uv_BVar <$$> e_int) - | _ when S.fv_eq_lid fv ref_Uv_Name.lid -> run args (Uv_Name <$$> e_ident) - | _ when S.fv_eq_lid fv ref_Uv_Unif.lid -> run args (Uv_Unif <$$> e_universe_uvar) - | _ when S.fv_eq_lid fv ref_Uv_Unk.lid -> run args (pure Uv_Unk) - | _ -> None - in - - mk_emb embed_universe_view unembed_universe_view fstar_refl_universe_view - -let e_vconst = - let embed_const (rng:Range.range) (c:vconst) : term = - let r = - match c with - | C_Unit -> ref_C_Unit.t - | C_True -> ref_C_True.t - | C_False -> ref_C_False.t - - | C_Int i -> - S.mk_Tm_app ref_C_Int.t [S.as_arg (U.exp_int (Z.string_of_big_int i))] - Range.dummyRange - | C_String s -> - S.mk_Tm_app ref_C_String.t [S.as_arg (embed rng s)] - Range.dummyRange - - | C_Range r -> - S.mk_Tm_app ref_C_Range.t [S.as_arg (embed rng r)] - Range.dummyRange - - | C_Reify -> ref_C_Reify.t - - | C_Reflect ns -> - S.mk_Tm_app ref_C_Reflect.t [S.as_arg (embed rng ns)] - Range.dummyRange - - | C_Real s -> - S.mk_Tm_app ref_C_Real.t [S.as_arg (embed rng s)] - Range.dummyRange - - in { r with pos = rng } - in - let unembed_const (t:term) : option vconst = - let? fv, args = head_fv_and_args t in - match () with - | _ when S.fv_eq_lid fv ref_C_Unit.lid -> run args (pure C_Unit) - | _ when S.fv_eq_lid fv ref_C_True.lid -> run args (pure C_True) - | _ when S.fv_eq_lid fv ref_C_False.lid -> run args (pure C_False) - | _ when S.fv_eq_lid fv ref_C_Int.lid -> run args (C_Int <$$> e_int) - | _ when S.fv_eq_lid fv ref_C_String.lid -> run args (C_String <$$> e_string) - | _ when S.fv_eq_lid fv ref_C_Range.lid -> run args (C_Range <$$> e_range) - | _ when S.fv_eq_lid fv ref_C_Reify.lid -> run args (pure C_Reify) - | _ when S.fv_eq_lid fv ref_C_Reflect.lid -> run args (C_Reflect <$$> e_string_list) - | _ when S.fv_eq_lid fv ref_C_Real.lid -> run args (C_Real <$$> e_string) - | _ -> None - in - mk_emb embed_const unembed_const fstar_refl_vconst - -let rec e_pattern_aq aq = - let rec embed_pattern (rng:Range.range) (p : pattern) : term = - match p with - | Pat_Constant c -> - S.mk_Tm_app ref_Pat_Constant.t [S.as_arg (embed rng c)] rng - | Pat_Cons head univs subpats -> - S.mk_Tm_app ref_Pat_Cons.t - [S.as_arg (embed rng head); - S.as_arg (embed rng univs); - S.as_arg (embed #_ #(e_list (e_tuple2 (e_pattern_aq aq) e_bool)) rng subpats)] rng - | Pat_Var sort ppname -> - S.mk_Tm_app ref_Pat_Var.t [ - S.as_arg (embed #_ #e_sort rng sort); - S.as_arg (embed rng ppname); - ] rng - | Pat_Dot_Term eopt -> - S.mk_Tm_app ref_Pat_Dot_Term.t [S.as_arg (embed #_ #(e_option e_term) rng eopt)] - rng - in - let rec unembed_pattern (t : term) : option pattern = - let? fv, args = head_fv_and_args t in - match () with - | _ when S.fv_eq_lid fv ref_Pat_Constant.lid -> - run args (Pat_Constant <$$> e_vconst) - - | _ when S.fv_eq_lid fv ref_Pat_Cons.lid -> - run args (Pat_Cons <$$> e_fv <**> e_option (e_list e_universe) <**> e_list (e_tuple2 (e_pattern_aq aq) e_bool)) - - | _ when S.fv_eq_lid fv ref_Pat_Var.lid -> - run args (Pat_Var <$$> e_sort <**> e_ppname) - - | _ when S.fv_eq_lid fv ref_Pat_Dot_Term.lid -> - run args (Pat_Dot_Term <$$> e_option e_term) - - | _ -> None - in - mk_emb embed_pattern unembed_pattern fstar_refl_pattern - -let e_pattern = e_pattern_aq noaqs - -let e_branch = e_tuple2 e_pattern e_term -let e_argv = e_tuple2 e_term e_aqualv - -let e_args = e_list e_argv - -let e_branch_aq aq = e_tuple2 (e_pattern_aq aq) (e_term_aq aq) -let e_argv_aq aq = e_tuple2 (e_term_aq aq) e_aqualv - -instance e_match_returns_annotation = - e_option (e_tuple2 e_binder - (e_tuple3 (e_either e_term e_comp) (e_option e_term) e_bool)) - -let e_term_view_aq aq = - let push (s, aq) = (s+1, aq) in - let embed_term_view (rng:Range.range) (t:term_view) : term = - match t with - | Tv_FVar fv -> - S.mk_Tm_app ref_Tv_FVar.t [S.as_arg (embed rng fv)] - rng - - | Tv_BVar fv -> - S.mk_Tm_app ref_Tv_BVar.t [S.as_arg (embed #_ #e_bv rng fv)] - rng - - | Tv_Var bv -> - S.mk_Tm_app ref_Tv_Var.t [S.as_arg (embed #_ #e_namedv rng bv)] - rng - - | Tv_UInst (fv, us) -> - S.mk_Tm_app - ref_Tv_UInst.t - [S.as_arg (embed rng fv); - S.as_arg (embed rng us)] - rng - - | Tv_App (hd, a) -> - S.mk_Tm_app ref_Tv_App.t [S.as_arg (embed #_ #(e_term_aq aq) rng hd); S.as_arg (embed #_ #(e_argv_aq aq) rng a)] - rng - - | Tv_Abs (b, t) -> - S.mk_Tm_app ref_Tv_Abs.t [S.as_arg (embed rng b); S.as_arg (embed #_ #(e_term_aq (push aq)) rng t)] - rng - - | Tv_Arrow (b, c) -> - S.mk_Tm_app ref_Tv_Arrow.t [S.as_arg (embed rng b); S.as_arg (embed rng c)] - rng - - | Tv_Type u -> - S.mk_Tm_app ref_Tv_Type.t [S.as_arg (embed rng u)] - rng - - | Tv_Refine (b, t) -> - S.mk_Tm_app ref_Tv_Refine.t [S.as_arg (embed rng b); - S.as_arg (embed #_ #(e_term_aq (push aq)) rng t)] - rng - - | Tv_Const c -> - S.mk_Tm_app ref_Tv_Const.t [S.as_arg (embed rng c)] - rng - - | Tv_Uvar (u, ctx_u) -> - S.mk_Tm_app ref_Tv_Uvar.t - [S.as_arg (embed rng u); - S.as_arg (embed rng ctx_u)] - rng - - | Tv_Let (r, attrs, b, t1, t2) -> - S.mk_Tm_app ref_Tv_Let.t [S.as_arg (embed rng r); - S.as_arg (embed #_ #(e_list e_term) rng attrs); - S.as_arg (embed rng b); - S.as_arg (embed #_ #(e_term_aq aq) rng t1); - S.as_arg (embed #_ #(e_term_aq (push aq)) rng t2)] - rng - - | Tv_Match (t, ret_opt, brs) -> - S.mk_Tm_app ref_Tv_Match.t [S.as_arg (embed #_ #(e_term_aq aq) rng t); - S.as_arg (embed rng ret_opt); - S.as_arg (embed #_ #(e_list (e_branch_aq aq)) rng brs)] - rng - - | Tv_AscribedT (e, t, tacopt, use_eq) -> - S.mk_Tm_app ref_Tv_AscT.t - [S.as_arg (embed #_ #(e_term_aq aq) rng e); - S.as_arg (embed #_ #(e_term_aq aq) rng t); - S.as_arg (embed #_ #(e_option (e_term_aq aq)) rng tacopt); - S.as_arg (embed rng use_eq)] - rng - - | Tv_AscribedC (e, c, tacopt, use_eq) -> - S.mk_Tm_app ref_Tv_AscC.t - [S.as_arg (embed #_ #(e_term_aq aq) rng e); - S.as_arg (embed rng c); - S.as_arg (embed #_ #(e_option (e_term_aq aq)) rng tacopt); - S.as_arg (embed rng use_eq)] - rng - - | Tv_Unknown -> - { ref_Tv_Unknown.t with pos = rng } - - | Tv_Unsupp -> - { ref_Tv_Unsupp.t with pos = rng } - in - let unembed_term_view (t:term) : option term_view = - let? fv, args = head_fv_and_args t in - let xTv_Let a b c d e = Tv_Let (a,b,c,d,e) in - match () with - | _ when S.fv_eq_lid fv ref_Tv_FVar.lid -> run args (Tv_FVar <$$> e_fv) - | _ when S.fv_eq_lid fv ref_Tv_BVar.lid -> run args (Tv_BVar <$$> e_bv) - | _ when S.fv_eq_lid fv ref_Tv_Var.lid -> run args (Tv_Var <$$> e_namedv) - | _ when S.fv_eq_lid fv ref_Tv_UInst.lid -> run args (curry Tv_UInst <$$> e_fv <**> e_list e_universe) - | _ when S.fv_eq_lid fv ref_Tv_App.lid -> run args (curry Tv_App <$$> e_term_aq aq <**> e_argv_aq aq) - | _ when S.fv_eq_lid fv ref_Tv_Abs.lid -> run args (curry Tv_Abs <$$> e_binder <**> e_term_aq (push aq)) - | _ when S.fv_eq_lid fv ref_Tv_Arrow.lid -> run args (curry Tv_Arrow <$$> e_binder <**> e_comp) - | _ when S.fv_eq_lid fv ref_Tv_Type.lid -> run args (Tv_Type <$$> e_universe) - | _ when S.fv_eq_lid fv ref_Tv_Refine.lid -> run args (curry Tv_Refine <$$> e_binder <**> e_term_aq (push aq)) - | _ when S.fv_eq_lid fv ref_Tv_Const.lid -> run args (Tv_Const <$$> e_vconst) - | _ when S.fv_eq_lid fv ref_Tv_Uvar.lid -> run args (curry Tv_Uvar <$$> e_int <**> e_ctx_uvar_and_subst) - | _ when S.fv_eq_lid fv ref_Tv_Let.lid -> run args (xTv_Let <$$> e_bool <**> e_list e_term <**> e_binder <**> e_term_aq aq <**> e_term_aq (push aq)) - | _ when S.fv_eq_lid fv ref_Tv_Match.lid -> run args (curry3 Tv_Match <$$> e_term_aq aq <**> e_match_returns_annotation <**> e_list (e_branch_aq aq)) - | _ when S.fv_eq_lid fv ref_Tv_AscT.lid -> run args (curry4 Tv_AscribedT <$$> e_term_aq aq <**> e_term_aq aq <**> e_option (e_term_aq aq) <**> e_bool) - | _ when S.fv_eq_lid fv ref_Tv_AscC.lid -> run args (curry4 Tv_AscribedC <$$> e_term_aq aq <**> e_comp <**> e_option (e_term_aq aq) <**> e_bool) - | _ when S.fv_eq_lid fv ref_Tv_Unknown.lid -> run args (pure Tv_Unknown) - | _ when S.fv_eq_lid fv ref_Tv_Unsupp.lid -> run args (pure Tv_Unsupp) - | _ -> None - in - mk_emb embed_term_view unembed_term_view fstar_refl_term_view - -let e_term_view = e_term_view_aq noaqs - -let e_name = e_list e_string - -(* embeds as a string list *) -// instance e_name : embedding I.lid = -// let embed rng lid : term = -// embed rng (I.path_of_lid lid) -// in -// let uu t _norm : option I.lid = -// BU.map_opt (try_unembed t) (fun p -> I.lid_of_path p t.pos) -// in -// EMB.mk_emb_full (fun x r _ _ -> embed r x) -// uu -// (fun () -> t_list_of t_string) -// I.string_of_lid -// (fun () -> ET_abstract) - - -instance e_namedv_view = - let embed_namedv_view (rng:Range.range) (namedvv:namedv_view) : term = - S.mk_Tm_app ref_Mk_namedv_view.t [ - S.as_arg (embed rng namedvv.uniq); - S.as_arg (embed #_ #e_sort rng namedvv.sort); - S.as_arg (embed rng namedvv.ppname); - ] - rng - in - let unembed_namedv_view (t : term) : option namedv_view = - let? fv, args = head_fv_and_args t in - match () with - | _ when S.fv_eq_lid fv ref_Mk_namedv_view.lid -> - run args (Mknamedv_view <$$> e_int <**> e_sort <**> e_ppname) - | _ -> None - in - mk_emb embed_namedv_view unembed_namedv_view fstar_refl_namedv_view - -instance e_bv_view = - let embed_bv_view (rng:Range.range) (bvv:bv_view) : term = - S.mk_Tm_app ref_Mk_bv_view.t [ - S.as_arg (embed rng bvv.index); - S.as_arg (embed #_ #e_sort rng bvv.sort); - S.as_arg (embed rng bvv.ppname); - ] - rng - in - let unembed_bv_view (t : term) : option bv_view = - let? fv, args = head_fv_and_args t in - match () with - | _ when S.fv_eq_lid fv ref_Mk_bv_view.lid -> - run args (Mkbv_view <$$> e_int <**> e_sort <**> e_ppname) - | _ -> None - in - mk_emb embed_bv_view unembed_bv_view fstar_refl_bv_view - -instance e_binding = - let embed (rng:Range.range) (bindingv:RD.binding) : term = - S.mk_Tm_app ref_Mk_binding.t [ - S.as_arg (embed rng bindingv.uniq); - S.as_arg (embed #_ #e_term rng bindingv.sort); - S.as_arg (embed rng bindingv.ppname); - ] - rng - in - let unembed (t : term) : option RD.binding = - let? fv, args = head_fv_and_args t in - match () with - | _ when S.fv_eq_lid fv ref_Mk_binding.lid -> - run args (Mkbinding <$$> e_int <**> e_term <**> e_ppname) - | _ -> None - in - mk_emb embed unembed fstar_refl_binding - -let e_attribute = e_term -let e_attributes = e_list e_attribute - -let e_binder_view = - let embed_binder_view (rng:Range.range) (bview:binder_view) : term = - S.mk_Tm_app ref_Mk_binder_view.t [ - S.as_arg (embed #_ #e_term rng bview.sort); - S.as_arg (embed rng bview.qual); - S.as_arg (embed #_ #e_attributes rng bview.attrs); - S.as_arg (embed rng bview.ppname); - ] - rng in - - let unembed_binder_view (t:term) : option binder_view = - let? fv, args = head_fv_and_args t in - match () with - | _ when S.fv_eq_lid fv ref_Mk_binder_view.lid -> - run args (Mkbinder_view <$$> e_term <**> e_aqualv <**> e_list e_term <**> e_ppname) - | _ -> None - in - mk_emb embed_binder_view unembed_binder_view fstar_refl_binder_view - -let e_comp_view = - let embed_comp_view (rng:Range.range) (cv : comp_view) : term = - match cv with - | C_Total t -> - S.mk_Tm_app ref_C_Total.t [S.as_arg (embed #_ #e_term rng t)] - rng - - | C_GTotal t -> - S.mk_Tm_app ref_C_GTotal.t [S.as_arg (embed #_ #e_term rng t)] - rng - - | C_Lemma (pre, post, pats) -> - S.mk_Tm_app ref_C_Lemma.t [S.as_arg (embed #_ #e_term rng pre); - S.as_arg (embed #_ #e_term rng post); - S.as_arg (embed #_ #e_term rng pats)] - rng - - | C_Eff (us, eff, res, args, decrs) -> - S.mk_Tm_app ref_C_Eff.t - [ S.as_arg (embed rng us) - ; S.as_arg (embed rng eff) - ; S.as_arg (embed #_ #e_term rng res) - ; S.as_arg (embed #_ #(e_list e_argv) rng args) - ; S.as_arg (embed #_ #(e_list e_term) rng decrs)] rng - - - in - let unembed_comp_view (t : term) : option comp_view = - let? fv, args = head_fv_and_args t in - match () with - | _ when S.fv_eq_lid fv ref_C_Total.lid -> run args (C_Total <$$> e_term) - | _ when S.fv_eq_lid fv ref_C_GTotal.lid -> run args (C_GTotal <$$> e_term) - | _ when S.fv_eq_lid fv ref_C_Lemma.lid -> - run args (curry3 C_Lemma <$$> e_term <**> e_term <**> e_term) - | _ when S.fv_eq_lid fv ref_C_Eff.lid -> - run args (curry5 C_Eff <$$> e_list e_universe <**> e_string_list <**> e_term <**> e_list e_argv <**> e_list e_term) - | _ -> None - in - mk_emb embed_comp_view unembed_comp_view fstar_refl_comp_view - -let e_univ_name = e_ident -let e_univ_names = e_list e_univ_name - -let e_subst_elt = - let ee (rng:Range.range) (e:subst_elt) : term = - match e with - | DB (i, x) -> - S.mk_Tm_app ref_DB.t [ - S.as_arg (embed rng i); - S.as_arg (embed #_ #e_namedv rng x); - ] - rng - - | DT (i, t) -> - S.mk_Tm_app ref_DT.t [ - S.as_arg (embed rng i); - S.as_arg (embed #_ #e_term rng t); - ] - rng - - | NM (x, i) -> - S.mk_Tm_app ref_NM.t [ - S.as_arg (embed #_ #e_namedv rng x); - S.as_arg (embed rng i); - ] - rng - - | NT (x, t) -> - S.mk_Tm_app ref_NT.t [ - S.as_arg (embed #_ #e_namedv rng x); - S.as_arg (embed #_ #e_term rng t); - ] - rng - - | UN (i, u) -> - S.mk_Tm_app ref_UN.t [ - S.as_arg (embed rng i); - S.as_arg (embed rng u); - ] - rng - - | UD (u, i) -> - S.mk_Tm_app ref_UD.t [ - S.as_arg (embed rng u); - S.as_arg (embed rng i); - ] - rng - in - let uu (t:term) : option subst_elt = - let? fv, args = head_fv_and_args t in - match () with - | _ when S.fv_eq_lid fv ref_DB.lid -> - run args (curry DB <$$> e_fsint <**> e_namedv) - | _ when S.fv_eq_lid fv ref_DT.lid -> - run args (curry DT <$$> e_fsint <**> e_term) - | _ when S.fv_eq_lid fv ref_NM.lid -> - run args (curry NM <$$> e_namedv <**> e_fsint) - | _ when S.fv_eq_lid fv ref_NT.lid -> - run args (curry NT <$$> e_namedv <**> e_term) - | _ when S.fv_eq_lid fv ref_UN.lid -> - run args (curry UN <$$> e_fsint <**> e_universe) - | _ when S.fv_eq_lid fv ref_UD.lid -> - run args (curry UD <$$> e_ident <**> e_fsint) - | _ -> None - in - mk_emb ee uu fstar_refl_subst_elt - -let e_subst = e_list e_subst_elt -let e_ctor = e_tuple2 (e_string_list) e_term - -let e_lb_view = - let embed_lb_view (rng:Range.range) (lbv:lb_view) : term = - S.mk_Tm_app ref_Mk_lb.t [S.as_arg (embed rng lbv.lb_fv); - S.as_arg (embed rng lbv.lb_us); - S.as_arg (embed #_ #e_term rng lbv.lb_typ); - S.as_arg (embed #_ #e_term rng lbv.lb_def)] - rng - in - let unembed_lb_view (t : term) : option lb_view = - let? fv, args = head_fv_and_args t in - match () with - | _ when S.fv_eq_lid fv ref_Mk_lb.lid -> - run args (Mklb_view <$$> e_fv <**> e_univ_names <**> e_term <**> e_term) - | _ -> None - in - mk_emb embed_lb_view unembed_lb_view fstar_refl_lb_view - -let e_sigelt_view = - let embed_sigelt_view (rng:Range.range) (sev:sigelt_view) : term = - match sev with - | Sg_Let (r, lbs) -> - S.mk_Tm_app ref_Sg_Let.t - [S.as_arg (embed rng r); - S.as_arg (embed rng lbs)] - rng - - | Sg_Inductive (nm, univs, bs, t, dcs) -> - S.mk_Tm_app ref_Sg_Inductive.t - [S.as_arg (embed rng nm); - S.as_arg (embed rng univs); - S.as_arg (embed rng bs); - S.as_arg (embed #_ #e_term rng t); - S.as_arg (embed #_ #(e_list e_ctor) rng dcs)] - rng - - | Sg_Val (nm, univs, t) -> - S.mk_Tm_app ref_Sg_Val.t - [S.as_arg (embed rng nm); - S.as_arg (embed rng univs); - S.as_arg (embed #_ #e_term rng t)] - rng - - | Unk -> - { ref_Unk.t with pos = rng } - in - let unembed_sigelt_view (t:term) : option sigelt_view = - let? fv, args = head_fv_and_args t in - match () with - | _ when S.fv_eq_lid fv ref_Sg_Inductive.lid -> - run args (curry5 Sg_Inductive <$$> e_string_list <**> e_univ_names <**> e_binders <**> e_term <**> e_list e_ctor) - | _ when S.fv_eq_lid fv ref_Sg_Let.lid -> - run args (curry Sg_Let <$$> e_bool <**> e_list e_letbinding) - | _ when S.fv_eq_lid fv ref_Sg_Val.lid -> - run args (curry3 Sg_Val <$$> e_string_list <**> e_univ_names <**> e_term) - | _ when S.fv_eq_lid fv ref_Unk.lid -> - run args (pure Unk) - | _ -> None - in - mk_emb embed_sigelt_view unembed_sigelt_view fstar_refl_sigelt_view - -let e_qualifier = - let embed (rng:Range.range) (q:RD.qualifier) : term = - let r = - match q with - | RD.Assumption -> ref_qual_Assumption.t - | RD.InternalAssumption -> ref_qual_InternalAssumption.t - | RD.New -> ref_qual_New.t - | RD.Private -> ref_qual_Private.t - | RD.Unfold_for_unification_and_vcgen -> ref_qual_Unfold_for_unification_and_vcgen.t - | RD.Visible_default -> ref_qual_Visible_default.t - | RD.Irreducible -> ref_qual_Irreducible.t - | RD.Inline_for_extraction -> ref_qual_Inline_for_extraction.t - | RD.NoExtract -> ref_qual_NoExtract.t - | RD.Noeq -> ref_qual_Noeq.t - | RD.Unopteq -> ref_qual_Unopteq.t - | RD.TotalEffect -> ref_qual_TotalEffect.t - | RD.Logic -> ref_qual_Logic.t - | RD.Reifiable -> ref_qual_Reifiable.t - | RD.ExceptionConstructor -> ref_qual_ExceptionConstructor.t - | RD.HasMaskedEffect -> ref_qual_HasMaskedEffect.t - | RD.Effect -> ref_qual_Effect.t - | RD.OnlyName -> ref_qual_OnlyName.t - | RD.Reflectable l -> - S.mk_Tm_app ref_qual_Reflectable.t [S.as_arg (embed rng l)] - Range.dummyRange - - | RD.Discriminator l -> - S.mk_Tm_app ref_qual_Discriminator.t [S.as_arg (embed rng l)] - Range.dummyRange - - | RD.Action l -> - S.mk_Tm_app ref_qual_Action.t [S.as_arg (embed rng l)] - Range.dummyRange - - | RD.Projector (l, i) -> - S.mk_Tm_app ref_qual_Projector.t [S.as_arg (embed rng (l, i))] - Range.dummyRange - - | RD.RecordType (ids1, ids2) -> - S.mk_Tm_app ref_qual_RecordType.t [S.as_arg (embed rng (ids1, ids2))] - Range.dummyRange - - | RD.RecordConstructor (ids1, ids2) -> - S.mk_Tm_app ref_qual_RecordConstructor.t [S.as_arg (embed rng (ids1, ids2))] - Range.dummyRange - - in { r with pos = rng } - in - let unembed (t: term) : option RD.qualifier = - let? fv, args = head_fv_and_args t in - match () with - | _ when S.fv_eq_lid fv ref_qual_Assumption.lid -> run args (pure RD.Assumption) - | _ when S.fv_eq_lid fv ref_qual_InternalAssumption.lid -> run args (pure RD.InternalAssumption) - | _ when S.fv_eq_lid fv ref_qual_New.lid -> run args (pure RD.New) - | _ when S.fv_eq_lid fv ref_qual_Private.lid -> run args (pure RD.Private) - | _ when S.fv_eq_lid fv ref_qual_Unfold_for_unification_and_vcgen.lid -> run args (pure RD.Unfold_for_unification_and_vcgen) - | _ when S.fv_eq_lid fv ref_qual_Visible_default.lid -> run args (pure RD.Visible_default) - | _ when S.fv_eq_lid fv ref_qual_Irreducible.lid -> run args (pure RD.Irreducible) - | _ when S.fv_eq_lid fv ref_qual_Inline_for_extraction.lid -> run args (pure RD.Inline_for_extraction) - | _ when S.fv_eq_lid fv ref_qual_NoExtract.lid -> run args (pure RD.NoExtract) - | _ when S.fv_eq_lid fv ref_qual_Noeq.lid -> run args (pure RD.Noeq) - | _ when S.fv_eq_lid fv ref_qual_Unopteq.lid -> run args (pure RD.Unopteq) - | _ when S.fv_eq_lid fv ref_qual_TotalEffect.lid -> run args (pure RD.TotalEffect) - | _ when S.fv_eq_lid fv ref_qual_Logic.lid -> run args (pure RD.Logic) - | _ when S.fv_eq_lid fv ref_qual_Reifiable.lid -> run args (pure RD.Reifiable) - | _ when S.fv_eq_lid fv ref_qual_ExceptionConstructor.lid -> run args (pure RD.ExceptionConstructor) - | _ when S.fv_eq_lid fv ref_qual_HasMaskedEffect.lid -> run args (pure RD.HasMaskedEffect) - | _ when S.fv_eq_lid fv ref_qual_Effect.lid -> run args (pure RD.Effect) - | _ when S.fv_eq_lid fv ref_qual_OnlyName.lid -> run args (pure RD.OnlyName) - | _ when S.fv_eq_lid fv ref_qual_Reflectable.lid -> - run args (RD.Reflectable <$$> e_name) - | _ when S.fv_eq_lid fv ref_qual_Discriminator.lid -> - run args (RD.Discriminator <$$> e_name) - | _ when S.fv_eq_lid fv ref_qual_Action.lid -> - run args (RD.Action <$$> e_name) - | _ when S.fv_eq_lid fv ref_qual_Projector.lid -> - run args (RD.Projector <$$> e_tuple2 e_name e_ident) - | _ when S.fv_eq_lid fv ref_qual_RecordType.lid -> - run args (RD.RecordType <$$> e_tuple2 (e_list e_ident) (e_list e_ident)) - | _ when S.fv_eq_lid fv ref_qual_RecordConstructor.lid -> - run args (RD.RecordConstructor <$$> e_tuple2 (e_list e_ident) (e_list e_ident)) - | _ -> None - in - mk_emb embed unembed fstar_refl_qualifier - -let e_qualifiers = e_list e_qualifier - -(* -------------------------------------------------------------------------------------- *) -(* ------------------------------------- UNFOLDINGS ------------------------------------- *) -(* -------------------------------------------------------------------------------------- *) - - -(* Note that most of these are never needed during normalization, since - * the types are abstract. - *) - -let unfold_lazy_bv (i : lazyinfo) : term = - let bv : bv = undyn i.blob in - S.mk_Tm_app fstar_refl_pack_bv.t [S.as_arg (embed i.rng (inspect_bv bv))] - i.rng - -let unfold_lazy_namedv (i : lazyinfo) : term = - let namedv : namedv = undyn i.blob in - S.mk_Tm_app fstar_refl_pack_namedv.t [S.as_arg (embed i.rng (inspect_namedv namedv))] - i.rng - -let unfold_lazy_binder (i : lazyinfo) : term = - let binder : binder = undyn i.blob in - S.mk_Tm_app fstar_refl_pack_binder.t [S.as_arg (embed i.rng (inspect_binder binder))] - i.rng - -let unfold_lazy_letbinding (i : lazyinfo) : term = - let lb : letbinding = undyn i.blob in - let lbv = inspect_lb lb in - S.mk_Tm_app fstar_refl_pack_lb.t - [ - S.as_arg (embed i.rng lbv.lb_fv); - S.as_arg (embed i.rng lbv.lb_us); - S.as_arg (embed #_ #e_term i.rng lbv.lb_typ); - S.as_arg (embed #_ #e_term i.rng lbv.lb_def) - ] - i.rng - -let unfold_lazy_fvar (i : lazyinfo) : term = - let fv : fv = undyn i.blob in - S.mk_Tm_app fstar_refl_pack_fv.t [S.as_arg (embed i.rng (inspect_fv fv))] - i.rng - -let unfold_lazy_comp (i : lazyinfo) : term = - let comp : comp = undyn i.blob in - S.mk_Tm_app fstar_refl_pack_comp.t [S.as_arg (embed i.rng (inspect_comp comp))] - i.rng - -let unfold_lazy_env (i : lazyinfo) : term = - (* Not needed, metaprograms never see concrete environments. *) - U.exp_unit - -let unfold_lazy_optionstate (i : lazyinfo) : term = - (* Not needed, metaprograms never see concrete optionstates . *) - U.exp_unit - -let unfold_lazy_sigelt (i : lazyinfo) : term = - let sigelt : sigelt = undyn i.blob in - S.mk_Tm_app fstar_refl_pack_sigelt.t [S.as_arg (embed i.rng (inspect_sigelt sigelt))] - i.rng - -let unfold_lazy_universe (i : lazyinfo) : term = - let u : universe = undyn i.blob in - S.mk_Tm_app fstar_refl_pack_universe.t [S.as_arg (embed i.rng (inspect_universe u))] - i.rng - -let unfold_lazy_doc (i : lazyinfo) : term = - let open FStar.Pprint in - let d : Pprint.document = undyn i.blob in - let lid = Ident.lid_of_str "FStar.Stubs.Pprint.arbitrary_string" in - let s = Pprint.render d in - S.mk_Tm_app (S.fvar lid None) [S.as_arg (embed i.rng s)] - i.rng diff --git a/src/reflection/FStar.Reflection.V2.Embeddings.fsti b/src/reflection/FStar.Reflection.V2.Embeddings.fsti deleted file mode 100644 index 51f6b12c934..00000000000 --- a/src/reflection/FStar.Reflection.V2.Embeddings.fsti +++ /dev/null @@ -1,80 +0,0 @@ -(* - Copyright 2008-2022 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Reflection.V2.Embeddings - -open FStar -open FStar.Compiler -open FStar.Syntax.Syntax -open FStar.Syntax.Embeddings -open FStar.Order -open FStar.TypeChecker.Env -open FStar.Reflection.V2.Data -module O = FStar.Options -module RD = FStar.Reflection.V2.Data - -(* FIXME: create a Reflection.Types module internally? *) -type namedv = bv - -(* Embeddings *) -val e_bv : embedding bv -val e_namedv : embedding namedv -(* Sadly these two cannot be instances: they are the same type! *) -instance val e_binding : embedding RD.binding -instance val e_binder : embedding binder -instance val e_binder_view : embedding binder_view -instance val e_binders : embedding binders -(* not instance *) val e_term : embedding term -instance val e_term_view : embedding term_view -instance val e_fv : embedding fv -instance val e_comp : embedding comp -instance val e_comp_view : embedding comp_view -instance val e_vconst : embedding vconst -instance val e_env : embedding FStar.TypeChecker.Env.env -instance val e_pattern : embedding pattern -instance val e_branch : embedding Data.branch -instance val e_aqualv : embedding aqualv -instance val e_argv : embedding argv -instance val e_sigelt : embedding sigelt -instance val e_letbinding : embedding letbinding -instance val e_lb_view : embedding lb_view -instance val e_sigelt_view : embedding sigelt_view -instance val e_namedv_view : embedding namedv_view -instance val e_bv_view : embedding bv_view - val e_attribute : embedding attribute -instance val e_qualifier : embedding RD.qualifier -instance val e_ident : embedding Ident.ident -instance val e_univ_name : embedding univ_name -instance val e_universe : embedding universe -instance val e_universe_view : embedding universe_view -instance val e_subst_elt : embedding subst_elt - -(* Useful for embedding antiquoted terms. They are only used for the embedding part, - * so this is a bit hackish. *) -val e_term_aq : antiquotations -> embedding term -val e_term_view_aq : antiquotations -> embedding term_view - -(* Lazy unfoldings *) -val unfold_lazy_bv : lazyinfo -> term -val unfold_lazy_namedv : lazyinfo -> term -val unfold_lazy_fvar : lazyinfo -> term -val unfold_lazy_binder : lazyinfo -> term -val unfold_lazy_optionstate : lazyinfo -> term -val unfold_lazy_comp : lazyinfo -> term -val unfold_lazy_env : lazyinfo -> term -val unfold_lazy_sigelt : lazyinfo -> term -val unfold_lazy_letbinding : lazyinfo -> term -val unfold_lazy_universe : lazyinfo -> term -val unfold_lazy_doc : lazyinfo -> term diff --git a/src/reflection/FStar.Reflection.V2.Interpreter.fst b/src/reflection/FStar.Reflection.V2.Interpreter.fst deleted file mode 100644 index dc66ee81453..00000000000 --- a/src/reflection/FStar.Reflection.V2.Interpreter.fst +++ /dev/null @@ -1,206 +0,0 @@ -(* - Copyright 2008-2022 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Reflection.V2.Interpreter - -module EMB = FStar.Syntax.Embeddings -module NBET = FStar.TypeChecker.NBETerm -module NRE = FStar.Reflection.V2.NBEEmbeddings -module PO = FStar.TypeChecker.Primops -module RB = FStar.Reflection.V2.Builtins -module RE = FStar.Reflection.V2.Embeddings -open FStar.Syntax.Syntax -open FStar.Reflection.V2.Constants - -let solve (#a: Type) {| ev: a |} : Tot a = ev - -(* NB: assuming uarity = 0 for these three. Also, they are homogenous in KAM and NBE. *) - -val mk1 : - string -> - {| EMB.embedding 't1 |} -> - {| EMB.embedding 'res |} -> - {| NBET.embedding 't1 |} -> - {| NBET.embedding 'res |} -> - ('t1 -> 'res) -> - PO.primitive_step -let mk1 nm f = - let lid = fstar_refl_builtins_lid nm in - PO.mk1' 0 lid - (fun x -> f x |> Some) - (fun x -> f x |> Some) - -val mk2 : - string -> - {| EMB.embedding 't1 |} -> - {| EMB.embedding 't2 |} -> - {| EMB.embedding 'res |} -> - {| NBET.embedding 't1 |} -> - {| NBET.embedding 't2 |} -> - {| NBET.embedding 'res |} -> - ('t1 -> 't2 -> 'res) -> - PO.primitive_step -let mk2 nm f = - let lid = fstar_refl_builtins_lid nm in - PO.mk2' 0 lid - (fun x y -> f x y |> Some) - (fun x y -> f x y |> Some) - -val mk3 : - string -> - {| EMB.embedding 't1 |} -> - {| EMB.embedding 't2 |} -> - {| EMB.embedding 't3 |} -> - {| EMB.embedding 'res |} -> - {| NBET.embedding 't1 |} -> - {| NBET.embedding 't2 |} -> - {| NBET.embedding 't3 |} -> - {| NBET.embedding 'res |} -> - ('t1 -> 't2 -> 't3 -> 'res) -> - PO.primitive_step -let mk3 nm f = - let lid = fstar_refl_builtins_lid nm in - PO.mk3' 0 lid - (fun x y z -> f x y z |> Some) - (fun x y z -> f x y z |> Some) - -(* - * NOTE: all primitives must be carefully inspected to make sure they - * do not break the abstraction barrier imposed by the term_view. - * Otherwise, the pack_inspect_inv and inspect_pack_inv lemmas could - * likely be used to derive a contradiction. - * - * The way to go about adding new primitives is to implement them in the - * FStar.Reflection.V2.Builtins module and implement them using the (internal) - * inspect_ln and pack_ln functions, which means they should not break - * the view abstraction. - * - * _Any_ call to functions elsewhere, say term_to_string or - * Util.term_eq, will _very likely_ be inconsistent with the view. - * Exceptions to the "way to go" above should be well justified. - *) -let reflection_primops : list PO.primitive_step = [ - (****** Inspecting/packing various kinds of syntax ******) - mk1 "inspect_ln" - #RE.e_term #_ - #NRE.e_term #_ - RB.inspect_ln; - - mk1 "pack_ln" - #_ #RE.e_term - #_ #NRE.e_term - RB.pack_ln; - - mk1 "inspect_fv" RB.inspect_fv; - mk1 "pack_fv" RB.pack_fv; - mk1 "inspect_comp" RB.inspect_comp; - mk1 "pack_comp" RB.pack_comp; - mk1 "inspect_universe" RB.inspect_universe; - mk1 "pack_universe" RB.pack_universe; - mk1 "inspect_sigelt" RB.inspect_sigelt; - mk1 "pack_sigelt" RB.pack_sigelt; - mk1 "inspect_lb" RB.inspect_lb; - mk1 "pack_lb" RB.pack_lb; - mk1 "inspect_namedv" - #RE.e_namedv #RE.e_namedv_view - #NRE.e_namedv #NRE.e_namedv_view - RB.inspect_namedv; - mk1 "pack_namedv" - #RE.e_namedv_view #RE.e_namedv - #NRE.e_namedv_view #NRE.e_namedv - RB.pack_namedv; - mk1 "inspect_bv" - #RE.e_bv #RE.e_bv_view - #NRE.e_bv #NRE.e_bv_view - RB.inspect_bv; - mk1 "pack_bv" - #RE.e_bv_view #RE.e_bv - #NRE.e_bv_view #NRE.e_bv - RB.pack_bv; - mk1 "inspect_binder" RB.inspect_binder; - mk1 "pack_binder" RB.pack_binder; - - (****** Actual primitives ******) - - mk1 "sigelt_opts" RB.sigelt_opts; - mk1 "embed_vconfig" - #_ #RE.e_term - RB.embed_vconfig; - - mk1 "sigelt_attrs" - #_ #(EMB.e_list RE.e_term) - RB.sigelt_attrs; - - mk2 "set_sigelt_attrs" - #(EMB.e_list RE.e_term) - RB.set_sigelt_attrs; - - mk1 "sigelt_quals" RB.sigelt_quals; - mk2 "set_sigelt_quals" RB.set_sigelt_quals; - mk2 "subst_term" - #_ #RE.e_term #RE.e_term - RB.subst_term; - - mk2 "subst_comp" RB.subst_comp; - mk2 "compare_bv" - #RE.e_bv #RE.e_bv #_ - #NRE.e_bv #NRE.e_bv #_ - RB.compare_bv; - mk2 "compare_namedv" - #RE.e_namedv #RE.e_namedv #_ - #NRE.e_namedv #NRE.e_namedv #_ - RB.compare_namedv; - - mk2 "lookup_attr_ses" - #RE.e_term - RB.lookup_attr_ses; - - mk2 "lookup_attr" - #RE.e_term - RB.lookup_attr; - - mk1 "all_defs_in_env" RB.all_defs_in_env; - mk2 "defs_in_module" RB.defs_in_module; - - mk2 "term_eq" - #RE.e_term #RE.e_term - RB.term_eq; - - mk1 "moduleof" RB.moduleof; - mk1 "vars_of_env" RB.vars_of_env; - mk2 "lookup_typ" RB.lookup_typ; - mk1 "env_open_modules" RB.env_open_modules; - - (* See note in ulib/FStar.Reflection.V2.Builints.fsti: we expose these - three to reduce dependencies. *) - mk1 "implode_qn" RB.implode_qn; - - mk1 "explode_qn" RB.explode_qn; - mk2 "compare_string" RB.compare_string; - mk2 "push_namedv" - #_ #RE.e_namedv #_ - #_ #NRE.e_namedv #_ - RB.push_namedv; - - mk1 "range_of_term" - #RE.e_term - RB.range_of_term; - - mk1 "range_of_sigelt" RB.range_of_sigelt; - mk1 "inspect_ident" RB.inspect_ident; - mk1 "pack_ident" RB.pack_ident; -] - -let _ = List.iter FStar.TypeChecker.Cfg.register_extra_step reflection_primops diff --git a/src/reflection/FStar.Reflection.V2.Interpreter.fsti b/src/reflection/FStar.Reflection.V2.Interpreter.fsti deleted file mode 100644 index 40b30255f44..00000000000 --- a/src/reflection/FStar.Reflection.V2.Interpreter.fsti +++ /dev/null @@ -1,19 +0,0 @@ -(* - Copyright 2008-2022 Microsof Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Reflection.V2.Interpreter - -(* This module only has an initialization effect of registering -many primitive steps in the normalizer. *) diff --git a/src/reflection/FStar.Reflection.V2.NBEEmbeddings.fst b/src/reflection/FStar.Reflection.V2.NBEEmbeddings.fst deleted file mode 100644 index 7db3779f28f..00000000000 --- a/src/reflection/FStar.Reflection.V2.NBEEmbeddings.fst +++ /dev/null @@ -1,987 +0,0 @@ -(* - Copyright 2008-2022 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Reflection.V2.NBEEmbeddings -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Pervasives -open FStar.Reflection.V2.Data -open FStar.Syntax.Syntax -open FStar.TypeChecker.NBETerm -open FStar.Order -open FStar.Errors -open FStar.Dyn -open FStar.Reflection.V2.Constants - -module BU = FStar.Compiler.Util -module Env = FStar.TypeChecker.Env -module Err = FStar.Errors -module I = FStar.Ident -module NBETerm = FStar.TypeChecker.NBETerm -module O = FStar.Options -module PC = FStar.Parser.Const -module Range = FStar.Compiler.Range -module S = FStar.Syntax.Syntax // TODO: remove, it's open -module SS = FStar.Syntax.Subst -module U = FStar.Syntax.Util -module Z = FStar.BigInt - -(* - * embed : from compiler to user - * unembed : from user to compiler - *) - -let noaqs : antiquotations = (0, []) - -(* -------------------------------------------------------------------------------------- *) -(* ------------------------------------- EMBEDDINGS ------------------------------------- *) -(* -------------------------------------------------------------------------------------- *) - -(* PLEASE NOTE: Construct and FV accumulate their arguments BACKWARDS. That is, - * the expression (f 1 2) is stored as FV (f, [], [Constant (Int 2); Constant (Int 1)]. - * So be careful when calling mkFV/mkConstruct and matching on them. *) - -(* On that note, we use this (inefficient, FIXME) hack in this module *) -let mkFV fv us ts = mkFV fv (List.rev us) (List.rev ts) -let mkConstruct fv us ts = mkConstruct fv (List.rev us) (List.rev ts) -(* ^ We still need to match on them in reverse order though, so this is pretty dumb *) - -let fv_as_emb_typ fv = S.ET_app (FStar.Ident.string_of_lid fv.fv_name.v, []) -let mk_emb' x y fv = mk_emb x y (fun () -> mkFV fv [] []) (fun () -> fv_as_emb_typ fv) - -let mk_lazy cb obj ty kind = - let li = { - blob = FStar.Dyn.mkdyn obj - ; lkind = kind - ; ltyp = ty - ; rng = Range.dummyRange - } - in - let thunk = Thunk.mk (fun () -> translate_cb cb (U.unfold_lazy li)) in - mk_t (Lazy (Inl li, thunk)) - -let e_bv = - let embed_bv cb (bv:bv) : t = - mk_lazy cb bv fstar_refl_bv Lazy_bv - in - let unembed_bv cb (t:t) : option bv = - match t.nbe_t with - | Lazy (Inl {blob=b; lkind=Lazy_bv}, _) -> - Some <| FStar.Dyn.undyn b - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded bv: %s" (t_to_string t)); - None - in - mk_emb' embed_bv unembed_bv fstar_refl_bv_fv - -let e_namedv = - let embed_namedv cb (namedv:namedv) : t = - mk_lazy cb namedv fstar_refl_namedv Lazy_namedv - in - let unembed_namedv cb (t:t) : option namedv = - match t.nbe_t with - | Lazy (Inl {blob=b; lkind=Lazy_namedv}, _) -> - Some <| FStar.Dyn.undyn b - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded namedv: %s" (t_to_string t)); - None - in - mk_emb' embed_namedv unembed_namedv fstar_refl_namedv_fv - -let e_binder = - let embed_binder cb (b:binder) : t = - mk_lazy cb b fstar_refl_binder Lazy_binder - in - let unembed_binder cb (t:t) : option binder = - match t.nbe_t with - | Lazy (Inl {blob=b; lkind=Lazy_binder}, _) -> - Some (undyn b) - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded binder: %s" (t_to_string t)); - None - in - mk_emb' embed_binder unembed_binder fstar_refl_binder_fv - -let rec mapM_opt (f : ('a -> option 'b)) (l : list 'a) : option (list 'b) = - match l with - | [] -> Some [] - | x::xs -> - BU.bind_opt (f x) (fun x -> - BU.bind_opt (mapM_opt f xs) (fun xs -> - Some (x :: xs))) - -let e_term_aq aq = - let embed_term cb (t:term) : NBETerm.t = - let qi = { qkind = Quote_static; antiquotations = aq } in - mk_t (NBETerm.Quote (t, qi)) - in - let unembed_term cb (t:NBETerm.t) : option term = - match t.nbe_t with - | NBETerm.Quote (tm, qi) -> - (* Just reuse the code from Reflection *) - Syntax.Embeddings.unembed #_ #(Reflection.V2.Embeddings.e_term_aq (0, [])) (S.mk (Tm_quoted (tm, qi)) Range.dummyRange) Syntax.Embeddings.id_norm_cb - | _ -> - None - in - { NBETerm.em = embed_term - ; NBETerm.un = unembed_term - ; NBETerm.typ = (fun () -> mkFV fstar_refl_term_fv [] []) - ; NBETerm.e_typ = (fun () -> fv_as_emb_typ fstar_refl_term_fv ) - } - -let e_term = e_term_aq (0, []) - -let e_sort = e_sealed e_term -let e_ppname = e_sealed e_string - -let e_aqualv = - let embed_aqualv cb (q : aqualv) : t = - match q with - | Data.Q_Explicit -> mkConstruct ref_Q_Explicit.fv [] [] - | Data.Q_Implicit -> mkConstruct ref_Q_Implicit.fv [] [] - | Data.Q_Meta t -> mkConstruct ref_Q_Meta.fv [] [as_arg (embed e_term cb t)] - in - let unembed_aqualv cb (t : t) : option aqualv = - match t.nbe_t with - | Construct (fv, [], []) when S.fv_eq_lid fv ref_Q_Explicit.lid -> Some Data.Q_Explicit - | Construct (fv, [], []) when S.fv_eq_lid fv ref_Q_Implicit.lid -> Some Data.Q_Implicit - | Construct (fv, [], [(t, _)]) when S.fv_eq_lid fv ref_Q_Meta.lid -> - BU.bind_opt (unembed e_term cb t) (fun t -> - Some (Data.Q_Meta t)) - - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded aqualv: %s" (t_to_string t)); - None - in - mk_emb embed_aqualv unembed_aqualv - (fun () -> mkConstruct fstar_refl_aqualv_fv [] []) - (fun () -> fv_as_emb_typ fstar_refl_aqualv_fv) - -let e_binders = e_list e_binder - -let e_fv = - let embed_fv cb (fv:fv) : t = - mk_lazy cb fv fstar_refl_fv Lazy_fvar - in - let unembed_fv cb (t:t) : option fv = - match t.nbe_t with - | Lazy (Inl {blob=b; lkind=Lazy_fvar}, _) -> - Some (undyn b) - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded fvar: %s" (t_to_string t)); - None - in - mk_emb' embed_fv unembed_fv fstar_refl_fv_fv - -let e_comp = - let embed_comp cb (c:S.comp) : t = - mk_lazy cb c fstar_refl_comp Lazy_comp - in - let unembed_comp cb (t:t) : option S.comp = - match t.nbe_t with - | Lazy (Inl {blob=b; lkind=Lazy_comp}, _) -> - Some (undyn b) - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded comp: %s" (t_to_string t)); - None - in - mk_emb' embed_comp unembed_comp fstar_refl_comp_fv - -let e_env = - let embed_env cb (e:Env.env) : t = - mk_lazy cb e fstar_refl_env Lazy_env - in - let unembed_env cb (t:t) : option Env.env = - match t.nbe_t with - | Lazy (Inl {blob=b; lkind=Lazy_env}, _) -> - Some (undyn b) - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded env: %s" (t_to_string t)); - None - in - mk_emb' embed_env unembed_env fstar_refl_env_fv - -let e_vconst = - let embed_const cb (c:vconst) : t = - match c with - | C_Unit -> mkConstruct ref_C_Unit.fv [] [] - | C_True -> mkConstruct ref_C_True.fv [] [] - | C_False -> mkConstruct ref_C_False.fv [] [] - | C_Int i -> mkConstruct ref_C_Int.fv [] [as_arg (mk_t <| Constant (Int i))] - | C_String s -> mkConstruct ref_C_String.fv [] [as_arg (embed e_string cb s)] - | C_Range r -> mkConstruct ref_C_Range.fv [] [as_arg (embed e_range cb r)] - | C_Reify -> mkConstruct ref_C_Reify.fv [] [] - | C_Reflect ns -> mkConstruct ref_C_Reflect.fv [] [as_arg (embed e_string_list cb ns)] - in - let unembed_const cb (t:t) : option vconst = - match t.nbe_t with - | Construct (fv, [], []) when S.fv_eq_lid fv ref_C_Unit.lid -> - Some C_Unit - - | Construct (fv, [], []) when S.fv_eq_lid fv ref_C_True.lid -> - Some C_True - - | Construct (fv, [], []) when S.fv_eq_lid fv ref_C_False.lid -> - Some C_False - - | Construct (fv, [], [(i, _)]) when S.fv_eq_lid fv ref_C_Int.lid -> - BU.bind_opt (unembed e_int cb i) (fun i -> - Some <| C_Int i) - - | Construct (fv, [], [(s, _)]) when S.fv_eq_lid fv ref_C_String.lid -> - BU.bind_opt (unembed e_string cb s) (fun s -> - Some <| C_String s) - - | Construct (fv, [], [(r, _)]) when S.fv_eq_lid fv ref_C_Range.lid -> - BU.bind_opt (unembed e_range cb r) (fun r -> - Some <| C_Range r) - - | Construct (fv, [], []) when S.fv_eq_lid fv ref_C_Reify.lid -> - Some C_Reify - - | Construct (fv, [], [(ns, _)]) when S.fv_eq_lid fv ref_C_Reflect.lid -> - BU.bind_opt (unembed e_string_list cb ns) (fun ns -> - Some <| C_Reflect ns) - - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded vconst: %s" (t_to_string t)); - None - in - mk_emb' embed_const unembed_const fstar_refl_vconst_fv - -let e_universe = - let embed_universe cb (u:universe) : t = - mk_lazy cb u fstar_refl_universe Lazy_universe in - let unembed_universe cb (t:t) : option S.universe = - match t.nbe_t with - | Lazy (Inl {blob=b; lkind=Lazy_universe}, _) -> - Some (undyn b) - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded - (BU.format1 "Not an embedded universe: %s" (t_to_string t)); - None - in - mk_emb' embed_universe unembed_universe fstar_refl_universe_fv - -let rec e_pattern_aq aq = - let embed_pattern cb (p : pattern) : t = - match p with - | Pat_Constant c -> - mkConstruct ref_Pat_Constant.fv [] [as_arg (embed e_vconst cb c)] - | Pat_Cons fv us_opt ps -> - mkConstruct ref_Pat_Cons.fv [] - [as_arg (embed e_fv cb fv); - as_arg (embed (e_option (e_list e_universe)) cb us_opt); - as_arg (embed (e_list (e_tuple2 (e_pattern_aq aq) e_bool)) cb ps)] - | Pat_Var sort ppname -> - mkConstruct ref_Pat_Var.fv [] [as_arg (embed e_sort cb sort); as_arg (embed e_ppname cb ppname)] - | Pat_Dot_Term eopt -> - mkConstruct ref_Pat_Dot_Term.fv [] [as_arg (embed (e_option e_term) cb eopt)] - in - let unembed_pattern cb (t : t) : option pattern = - match t.nbe_t with - | Construct (fv, [], [(c, _)]) when S.fv_eq_lid fv ref_Pat_Constant.lid -> - BU.bind_opt (unembed e_vconst cb c) (fun c -> - Some <| Pat_Constant c) - - | Construct (fv, [], [(ps, _); (us_opt, _); (f, _)]) when S.fv_eq_lid fv ref_Pat_Cons.lid -> - BU.bind_opt (unembed e_fv cb f) (fun f -> - BU.bind_opt (unembed (e_option (e_list e_universe)) cb us_opt) (fun us -> - BU.bind_opt (unembed (e_list (e_tuple2 (e_pattern_aq aq) e_bool)) cb ps) (fun ps -> - Some <| Pat_Cons f us ps))) - - | Construct (fv, [], [(ppname, _); (sort, _)]) when S.fv_eq_lid fv ref_Pat_Var.lid -> - BU.bind_opt (unembed e_sort cb sort) (fun sort -> - BU.bind_opt (unembed e_ppname cb ppname) (fun ppname -> - Some <| Pat_Var sort ppname)) - - | Construct (fv, [], [(eopt, _)]) when S.fv_eq_lid fv ref_Pat_Dot_Term.lid -> - BU.bind_opt (unembed (e_option e_term) cb eopt) (fun eopt -> - Some <| Pat_Dot_Term eopt) - - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded pattern: %s" (t_to_string t)); - None - in - mk_emb' embed_pattern unembed_pattern fstar_refl_pattern_fv - -let e_pattern = e_pattern_aq noaqs - -let e_branch = e_tuple2 e_pattern e_term -let e_argv = e_tuple2 e_term e_aqualv - -let e_branch_aq aq = e_tuple2 (e_pattern_aq aq) (e_term_aq aq) -let e_argv_aq aq = e_tuple2 (e_term_aq aq) e_aqualv - -let e_match_returns_annotation = - e_option (e_tuple2 e_binder - (e_tuple3 (e_either e_term e_comp) (e_option e_term) e_bool)) - -let unlazy_as_t k t = - let open FStar.Class.Deq in - match t.nbe_t with - | Lazy (Inl {lkind=k'; blob=v}, _) - when k =? k' -> - FStar.Dyn.undyn v - | _ -> - failwith "Not a Lazy of the expected kind (NBE)" - -let e_ident : embedding I.ident = - let embed_ident cb (se:I.ident) : t = - mk_lazy cb se fstar_refl_ident Lazy_ident - in - let unembed_ident cb (t:t) : option I.ident = - match t.nbe_t with - | Lazy (Inl {blob=b; lkind=Lazy_ident}, _) -> - Some (undyn b) - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded ident: %s" (t_to_string t)); - None - in - mk_emb' embed_ident unembed_ident fstar_refl_ident_fv -let e_univ_name = e_ident -let e_univ_names = e_list e_univ_name - -let e_universe_view = - let embed_universe_view cb (uv:universe_view) : t = - match uv with - | Uv_Zero -> mkConstruct ref_Uv_Zero.fv [] [] - | Uv_Succ u -> - mkConstruct - ref_Uv_Succ.fv - [] - [as_arg (embed e_universe cb u)] - | Uv_Max us -> - mkConstruct - ref_Uv_Max.fv - [] - [as_arg (embed (e_list e_universe) cb us)] - | Uv_BVar n -> - mkConstruct - ref_Uv_BVar.fv - [] - [as_arg (embed e_int cb n)] - | Uv_Name i -> - mkConstruct - ref_Uv_Name.fv - [] - [as_arg (embed e_ident cb i)] - | Uv_Unif u -> - mkConstruct - ref_Uv_Unif.fv - [] - [as_arg (mk_lazy cb u U.t_universe_uvar Lazy_universe_uvar)] - | Uv_Unk -> mkConstruct ref_Uv_Unk.fv [] [] in - - let unembed_universe_view cb (t:t) : option universe_view = - match t.nbe_t with - | Construct (fv, _, []) when S.fv_eq_lid fv ref_Uv_Zero.lid -> Some Uv_Zero - | Construct (fv, _, [u, _]) when S.fv_eq_lid fv ref_Uv_Succ.lid -> - BU.bind_opt (unembed e_universe cb u) (fun u -> u |> Uv_Succ |> Some) - | Construct (fv, _, [us, _]) when S.fv_eq_lid fv ref_Uv_Max.lid -> - BU.bind_opt (unembed (e_list e_universe) cb us) (fun us -> us |> Uv_Max |> Some) - | Construct (fv, _, [n, _]) when S.fv_eq_lid fv ref_Uv_BVar.lid -> - BU.bind_opt (unembed e_int cb n) (fun n -> n |> Uv_BVar |> Some) - | Construct (fv, _, [i, _]) when S.fv_eq_lid fv ref_Uv_Name.lid -> - BU.bind_opt (unembed e_ident cb i) (fun i -> i |> Uv_Name |> Some) - | Construct (fv, _, [u, _]) when S.fv_eq_lid fv ref_Uv_Unif.lid -> - let u : universe_uvar = unlazy_as_t Lazy_universe_uvar u in - u |> Uv_Unif |> Some - | Construct (fv, _, []) when S.fv_eq_lid fv ref_Uv_Unk.lid -> Some Uv_Unk - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded - (BU.format1 "Not an embedded universe view: %s" (t_to_string t)); - None in - - mk_emb' embed_universe_view unembed_universe_view fstar_refl_universe_view_fv - -let e_subst_elt = - let embed_const cb (e:subst_elt) : t = - match e with - | DB (i, x) -> mkConstruct ref_DB.fv [] [as_arg (embed e_int cb (Z.of_int_fs i)); as_arg (embed e_namedv cb x)] - | NM (x, i) -> mkConstruct ref_NM.fv [] [as_arg (embed e_namedv cb x); as_arg (embed e_int cb (Z.of_int_fs i))] - | NT (x, t) -> mkConstruct ref_NT.fv [] [as_arg (embed e_namedv cb x); as_arg (embed e_term cb t)] - | UN (i, u) -> mkConstruct ref_UN.fv [] [as_arg (embed e_int cb (Z.of_int_fs i)); as_arg (embed e_universe cb u)] - | UD (n, i) -> mkConstruct ref_UD.fv [] [as_arg (embed e_univ_name cb n); as_arg (embed e_int cb (Z.of_int_fs i))] - in - let unembed_const cb (t:t) : option subst_elt = - match t.nbe_t with - | Construct (fv, [], [(x, _); (i, _)]) when S.fv_eq_lid fv ref_DB.lid -> - BU.bind_opt (unembed e_int cb i) (fun i -> - BU.bind_opt (unembed e_namedv cb x) (fun x -> - Some <| DB (Z.to_int_fs i, x))) - | Construct (fv, [], [(i, _); (x, _)]) when S.fv_eq_lid fv ref_NM.lid -> - BU.bind_opt (unembed e_namedv cb x) (fun x -> - BU.bind_opt (unembed e_int cb i) (fun i -> - Some <| NM (x, Z.to_int_fs i))) - | Construct (fv, [], [(t, _); (x, _)]) when S.fv_eq_lid fv ref_NT.lid -> - BU.bind_opt (unembed e_namedv cb x) (fun x -> - BU.bind_opt (unembed e_term cb t) (fun t -> - Some <| NT (x, t))) - | Construct (fv, [], [(u, _); (i, _)]) when S.fv_eq_lid fv ref_UN.lid -> - BU.bind_opt (unembed e_int cb i) (fun i -> - BU.bind_opt (unembed e_universe cb u) (fun u -> - Some <| UN (Z.to_int_fs i, u))) - | Construct (fv, [], [(i, _); (n, _)]) when S.fv_eq_lid fv ref_UD.lid -> - BU.bind_opt (unembed e_univ_name cb n) (fun n -> - BU.bind_opt (unembed e_int cb i) (fun i -> - Some <| UD (n, Z.to_int_fs i))) - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded vconst: %s" (t_to_string t)); - None - in - mk_emb' embed_const unembed_const fstar_refl_subst_elt_fv - -let e_subst = e_list e_subst_elt - -let e_term_view_aq aq = - let shift (s, aqs) = (s + 1, aqs) in - let embed_term_view cb (tv:term_view) : t = - match tv with - | Tv_FVar fv -> - mkConstruct ref_Tv_FVar.fv [] [as_arg (embed e_fv cb fv)] - - | Tv_BVar bv -> - mkConstruct ref_Tv_BVar.fv [] [as_arg (embed e_bv cb bv)] - - | Tv_Var bv -> - mkConstruct ref_Tv_Var.fv [] [as_arg (embed e_bv cb bv)] - - | Tv_UInst (fv, us) -> - mkConstruct ref_Tv_UInst.fv [] - [as_arg (embed e_fv cb fv); - as_arg (embed (e_list e_universe) cb us)] - - | Tv_App (hd, a) -> - mkConstruct ref_Tv_App.fv [] [as_arg (embed (e_term_aq aq) cb hd); as_arg (embed (e_argv_aq aq) cb a)] - - | Tv_Abs (b, t) -> - mkConstruct ref_Tv_Abs.fv [] [as_arg (embed e_binder cb b); as_arg (embed (e_term_aq (shift aq)) cb t)] - - | Tv_Arrow (b, c) -> - mkConstruct ref_Tv_Arrow.fv [] [as_arg (embed e_binder cb b); as_arg (embed e_comp cb c)] - - | Tv_Type u -> - mkConstruct ref_Tv_Type.fv [] [as_arg (embed e_universe cb u)] - - | Tv_Refine (b, t) -> - mkConstruct ref_Tv_Refine.fv [] [as_arg (embed e_binder cb b); - as_arg (embed (e_term_aq (shift aq)) cb t)] - - | Tv_Const c -> - mkConstruct ref_Tv_Const.fv [] [as_arg (embed e_vconst cb c)] - - | Tv_Uvar (u, d) -> - mkConstruct ref_Tv_Uvar.fv [] [as_arg (embed e_int cb u); as_arg (mk_lazy cb (u,d) U.t_ctx_uvar_and_sust Lazy_uvar)] - - | Tv_Let (r, attrs, b, t1, t2) -> - mkConstruct ref_Tv_Let.fv [] [as_arg (embed e_bool cb r); - as_arg (embed (e_list e_term) cb attrs); - as_arg (embed e_binder cb b); - as_arg (embed (e_term_aq aq) cb t1); - as_arg (embed (e_term_aq (shift aq)) cb t2)] - - | Tv_Match (t, ret_opt, brs) -> - mkConstruct ref_Tv_Match.fv [] [ - as_arg (embed (e_term_aq aq) cb t); - as_arg (embed e_match_returns_annotation cb ret_opt); - as_arg (embed (e_list (e_branch_aq aq)) cb brs)] - - | Tv_AscribedT (e, t, tacopt, use_eq) -> - mkConstruct ref_Tv_AscT.fv [] - [as_arg (embed (e_term_aq aq) cb e); - as_arg (embed (e_term_aq aq) cb t); - as_arg (embed (e_option (e_term_aq aq)) cb tacopt); - as_arg (embed e_bool cb use_eq)] - - | Tv_AscribedC (e, c, tacopt, use_eq) -> - mkConstruct ref_Tv_AscT.fv [] - [as_arg (embed (e_term_aq aq) cb e); - as_arg (embed e_comp cb c); - as_arg (embed (e_option (e_term_aq aq)) cb tacopt); - as_arg (embed e_bool cb use_eq)] - - | Tv_Unknown -> mkConstruct ref_Tv_Unknown.fv [] [] - - | Tv_Unsupp -> mkConstruct ref_Tv_Unsupp.fv [] [] - in - let unembed_term_view cb (t:t) : option term_view = - match t.nbe_t with - | Construct (fv, _, [(b, _)]) when S.fv_eq_lid fv ref_Tv_Var.lid -> - BU.bind_opt (unembed e_bv cb b) (fun b -> - Some <| Tv_Var b) - - | Construct (fv, _, [(b, _)]) when S.fv_eq_lid fv ref_Tv_BVar.lid -> - BU.bind_opt (unembed e_bv cb b) (fun b -> - Some <| Tv_BVar b) - - | Construct (fv, _, [(f, _)]) when S.fv_eq_lid fv ref_Tv_FVar.lid -> - BU.bind_opt (unembed e_fv cb f) (fun f -> - Some <| Tv_FVar f) - - | Construct (fv, _, [(f, _); (us, _)]) when S.fv_eq_lid fv ref_Tv_UInst.lid -> - BU.bind_opt (unembed e_fv cb f) (fun f -> - BU.bind_opt (unembed (e_list e_universe) cb us) (fun us -> - Some <| Tv_UInst (f, us))) - - | Construct (fv, _, [(r, _); (l, _)]) when S.fv_eq_lid fv ref_Tv_App.lid -> - BU.bind_opt (unembed e_term cb l) (fun l -> - BU.bind_opt (unembed e_argv cb r) (fun r -> - Some <| Tv_App (l, r))) - - | Construct (fv, _, [(t, _); (b, _)]) when S.fv_eq_lid fv ref_Tv_Abs.lid -> - BU.bind_opt (unembed e_binder cb b) (fun b -> - BU.bind_opt (unembed e_term cb t) (fun t -> - Some <| Tv_Abs (b, t))) - - | Construct (fv, _, [(t, _); (b, _)]) when S.fv_eq_lid fv ref_Tv_Arrow.lid -> - BU.bind_opt (unembed e_binder cb b) (fun b -> - BU.bind_opt (unembed e_comp cb t) (fun c -> - Some <| Tv_Arrow (b, c))) - - | Construct (fv, _, [(u, _)]) when S.fv_eq_lid fv ref_Tv_Type.lid -> - BU.bind_opt (unembed e_universe cb u) (fun u -> - Some <| Tv_Type u) - - | Construct (fv, _, [(t, _); (b, _)]) when S.fv_eq_lid fv ref_Tv_Refine.lid -> - BU.bind_opt (unembed e_binder cb b) (fun b -> - BU.bind_opt (unembed e_term cb t) (fun t -> - Some <| Tv_Refine (b, t))) - - | Construct (fv, _, [(c, _)]) when S.fv_eq_lid fv ref_Tv_Const.lid -> - BU.bind_opt (unembed e_vconst cb c) (fun c -> - Some <| Tv_Const c) - - | Construct (fv, _, [(l, _); (u, _)]) when S.fv_eq_lid fv ref_Tv_Uvar.lid -> - BU.bind_opt (unembed e_int cb u) (fun u -> - let ctx_u_s : ctx_uvar_and_subst = unlazy_as_t Lazy_uvar l in - Some <| Tv_Uvar (u, ctx_u_s)) - - | Construct (fv, _, [(t2, _); (t1, _); (b, _); (attrs, _); (r, _)]) when S.fv_eq_lid fv ref_Tv_Let.lid -> - BU.bind_opt (unembed e_bool cb r) (fun r -> - BU.bind_opt (unembed (e_list e_term) cb attrs) (fun attrs -> - BU.bind_opt (unembed e_binder cb b) (fun b -> - BU.bind_opt (unembed e_term cb t1) (fun t1 -> - BU.bind_opt (unembed e_term cb t2) (fun t2 -> - Some <| Tv_Let (r, attrs, b, t1, t2)))))) - - | Construct (fv, _, [(brs, _); (ret_opt, _); (t, _)]) when S.fv_eq_lid fv ref_Tv_Match.lid -> - BU.bind_opt (unembed e_term cb t) (fun t -> - BU.bind_opt (unembed (e_list e_branch) cb brs) (fun brs -> - BU.bind_opt (unembed e_match_returns_annotation cb ret_opt) (fun ret_opt -> - Some <| Tv_Match (t, ret_opt, brs)))) - - | Construct (fv, _, [(tacopt, _); (t, _); (e, _); (use_eq, _)]) when S.fv_eq_lid fv ref_Tv_AscT.lid -> - BU.bind_opt (unembed e_term cb e) (fun e -> - BU.bind_opt (unembed e_term cb t) (fun t -> - BU.bind_opt (unembed (e_option e_term) cb tacopt) (fun tacopt -> - BU.bind_opt (unembed e_bool cb use_eq) (fun use_eq -> - Some <| Tv_AscribedT (e, t, tacopt, use_eq))))) - - | Construct (fv, _, [(tacopt, _); (c, _); (e, _); (use_eq, _)]) when S.fv_eq_lid fv ref_Tv_AscC.lid -> - BU.bind_opt (unembed e_term cb e) (fun e -> - BU.bind_opt (unembed e_comp cb c) (fun c -> - BU.bind_opt (unembed (e_option e_term) cb tacopt) (fun tacopt -> - BU.bind_opt (unembed e_bool cb use_eq) (fun use_eq -> - Some <| Tv_AscribedC (e, c, tacopt, use_eq))))) - - | Construct (fv, _, []) when S.fv_eq_lid fv ref_Tv_Unknown.lid -> - Some <| Tv_Unknown - - | Construct (fv, _, []) when S.fv_eq_lid fv ref_Tv_Unsupp.lid -> - Some <| Tv_Unsupp - - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded term_view: %s" (t_to_string t)); - None - in - mk_emb' embed_term_view unembed_term_view fstar_refl_term_view_fv - -let e_term_view = e_term_view_aq (0, []) - -let e_namedv_view = - let embed_namedv_view cb (namedvv:namedv_view) : t = - mkConstruct ref_Mk_namedv_view.fv [] [ - as_arg (embed e_int cb namedvv.uniq); - as_arg (embed e_ppname cb namedvv.ppname); - as_arg (embed e_sort cb namedvv.sort); - ] - in - let unembed_namedv_view cb (t : t) : option namedv_view = - match t.nbe_t with - | Construct (fv, _, [(sort, _); (ppname, _); (uniq, _)]) when S.fv_eq_lid fv ref_Mk_namedv_view.lid -> - BU.bind_opt (unembed e_int cb uniq) (fun uniq -> - BU.bind_opt (unembed e_ppname cb ppname) (fun ppname -> - BU.bind_opt (unembed e_sort cb sort) (fun sort -> - let r : namedv_view = { ppname = ppname; uniq = uniq ; sort=sort } in - Some r))) - - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded namedv_view: %s" (t_to_string t)); - None - in - mk_emb' embed_namedv_view unembed_namedv_view fstar_refl_namedv_view_fv - -let e_bv_view = - let embed_bv_view cb (bvv:bv_view) : t = - mkConstruct ref_Mk_bv_view.fv [] [ - as_arg (embed e_int cb bvv.index); - as_arg (embed e_ppname cb bvv.ppname); - as_arg (embed e_sort cb bvv.sort); - ] - in - let unembed_bv_view cb (t : t) : option bv_view = - match t.nbe_t with - | Construct (fv, _, [(sort, _); (ppname, _); (idx, _)]) when S.fv_eq_lid fv ref_Mk_bv_view.lid -> - BU.bind_opt (unembed e_int cb idx) (fun idx -> - BU.bind_opt (unembed e_ppname cb ppname) (fun ppname -> - BU.bind_opt (unembed e_sort cb sort) (fun sort -> - let r : bv_view = { ppname = ppname; index = idx; sort=sort } in - Some r))) - - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded bv_view: %s" (t_to_string t)); - None - in - mk_emb' embed_bv_view unembed_bv_view fstar_refl_bv_view_fv - -let e_attribute = e_term -let e_attributes = e_list e_attribute - -let e_binding = - let embed cb (b:RD.binding) : t = - mkConstruct ref_Mk_binding.fv [] [ - as_arg (embed e_int cb b.uniq); - as_arg (embed e_term cb b.sort); - as_arg (embed e_ppname cb b.ppname); - ] - in - let unembed cb (t:t) : option RD.binding = - match t.nbe_t with - | Construct (fv, _, [(ppname, _); (sort, _); (uniq, _)]) - when S.fv_eq_lid fv ref_Mk_binding.lid -> - BU.bind_opt (unembed e_int cb uniq) (fun uniq -> - BU.bind_opt (unembed e_term cb sort) (fun sort -> - BU.bind_opt (unembed e_ppname cb ppname) (fun ppname -> - let r : RD.binding = {uniq=uniq; ppname=ppname; sort=sort} in - Some r))) - in - mk_emb' embed unembed fstar_refl_binding_fv - -let e_binder_view = - let embed_binder_view cb (bview:binder_view) : t = - mkConstruct ref_Mk_binder_view.fv [] [ - as_arg (embed e_term cb bview.sort); - as_arg (embed e_aqualv cb bview.qual); - as_arg (embed e_attributes cb bview.attrs); - as_arg (embed e_ppname cb bview.ppname); - ] in - - let unembed_binder_view cb (t:t) : option binder_view = - match t.nbe_t with - | Construct (fv, _, [(ppname, _); (attrs, _); (q, _); (sort, _)]) - when S.fv_eq_lid fv ref_Mk_binder_view.lid -> - BU.bind_opt (unembed e_term cb sort) (fun sort -> - BU.bind_opt (unembed e_aqualv cb q) (fun q -> - BU.bind_opt (unembed e_attributes cb attrs) (fun attrs -> - BU.bind_opt (unembed e_ppname cb ppname) (fun ppname -> - let r : binder_view = {ppname=ppname; qual=q; attrs=attrs; sort=sort} in - Some r)))) - - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded binder_view: %s" (t_to_string t)); - None - in - mk_emb' embed_binder_view unembed_binder_view fstar_refl_binder_view_fv - -let e_comp_view = - let embed_comp_view cb (cv : comp_view) : t = - match cv with - | C_Total t -> - mkConstruct ref_C_Total.fv [] [ - as_arg (embed e_term cb t)] - - | C_GTotal t -> - mkConstruct ref_C_GTotal.fv [] [ - as_arg (embed e_term cb t)] - - | C_Lemma (pre, post, pats) -> - mkConstruct ref_C_Lemma.fv [] [as_arg (embed e_term cb pre); as_arg (embed e_term cb post); as_arg (embed e_term cb pats)] - - | C_Eff (us, eff, res, args, decrs) -> - mkConstruct ref_C_Eff.fv [] - [ as_arg (embed (e_list e_universe) cb us) - ; as_arg (embed e_string_list cb eff) - ; as_arg (embed e_term cb res) - ; as_arg (embed (e_list e_argv) cb args) - ; as_arg (embed (e_list e_term) cb decrs)] - in - let unembed_comp_view cb (t : t) : option comp_view = - match t.nbe_t with - | Construct (fv, _, [(t, _)]) - when S.fv_eq_lid fv ref_C_Total.lid -> - BU.bind_opt (unembed e_term cb t) (fun t -> - Some <| C_Total t) - - | Construct (fv, _, [(t, _)]) - when S.fv_eq_lid fv ref_C_GTotal.lid -> - BU.bind_opt (unembed e_term cb t) (fun t -> - Some <| C_GTotal t) - - | Construct (fv, _, [(post, _); (pre, _); (pats, _)]) when S.fv_eq_lid fv ref_C_Lemma.lid -> - BU.bind_opt (unembed e_term cb pre) (fun pre -> - BU.bind_opt (unembed e_term cb post) (fun post -> - BU.bind_opt (unembed e_term cb pats) (fun pats -> - Some <| C_Lemma (pre, post, pats)))) - - | Construct (fv, _, [(decrs, _); (args, _); (res, _); (eff, _); (us, _)]) - when S.fv_eq_lid fv ref_C_Eff.lid -> - BU.bind_opt (unembed (e_list e_universe) cb us) (fun us -> - BU.bind_opt (unembed e_string_list cb eff) (fun eff -> - BU.bind_opt (unembed e_term cb res) (fun res-> - BU.bind_opt (unembed (e_list e_argv) cb args) (fun args -> - BU.bind_opt (unembed (e_list e_term) cb decrs) (fun decrs -> - Some <| C_Eff (us, eff, res, args, decrs)))))) - - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded comp_view: %s" (t_to_string t)); - None - in - mk_emb' embed_comp_view unembed_comp_view fstar_refl_comp_view_fv - -let e_sigelt = - let embed_sigelt cb (se:sigelt) : t = - mk_lazy cb se fstar_refl_sigelt Lazy_sigelt - in - let unembed_sigelt cb (t:t) : option sigelt = - match t.nbe_t with - | Lazy (Inl {blob=b; lkind=Lazy_sigelt}, _) -> - Some (undyn b) - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded sigelt: %s" (t_to_string t)); - None - in - mk_emb' embed_sigelt unembed_sigelt fstar_refl_sigelt_fv - -let e_string_list = e_list e_string - -let e_ctor = e_tuple2 e_string_list e_term - -let e_lb_view = - let embed_lb_view cb (lbv:lb_view) : t = - mkConstruct ref_Mk_lb.fv [] [as_arg (embed e_fv cb lbv.lb_fv); - as_arg (embed e_univ_names cb lbv.lb_us); - as_arg (embed e_term cb lbv.lb_typ); - as_arg (embed e_term cb lbv.lb_def)] - in - let unembed_lb_view cb (t : t) : option lb_view = - match t.nbe_t with - | Construct (fv, _, [(fv', _); (us, _); (typ, _); (def,_)]) - when S.fv_eq_lid fv ref_Mk_lb.lid -> - BU.bind_opt (unembed e_fv cb fv') (fun fv' -> - BU.bind_opt (unembed e_univ_names cb us) (fun us -> - BU.bind_opt (unembed e_term cb typ) (fun typ -> - BU.bind_opt (unembed e_term cb def) (fun def -> - Some <| - { lb_fv = fv'; lb_us = us; lb_typ = typ; lb_def = def })))) - - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded lb_view: %s" (t_to_string t)); - None - in - mk_emb' embed_lb_view unembed_lb_view fstar_refl_lb_view_fv - -(* embeds as a string list *) -let e_lid : embedding I.lid = - let embed rng lid : t = - embed e_string_list rng (I.path_of_lid lid) - in - let unembed cb (t : t) : option I.lid = - BU.map_opt (unembed e_string_list cb t) (fun p -> I.lid_of_path p Range.dummyRange) - in - mk_emb embed unembed - (fun () -> mkConstruct fstar_refl_aqualv_fv [] []) - (fun () -> fv_as_emb_typ fstar_refl_aqualv_fv) - -let e_letbinding = - let embed_letbinding cb (lb:letbinding) : t = - mk_lazy cb lb fstar_refl_letbinding Lazy_letbinding - in - let unembed_letbinding cb (t : t) : option letbinding = - match t.nbe_t with - | Lazy (Inl {blob=lb; lkind=Lazy_letbinding}, _) -> - Some (undyn lb) - - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded letbinding: %s" (t_to_string t)); - None - in - mk_emb' embed_letbinding unembed_letbinding fstar_refl_letbinding_fv - -let e_sigelt_view = - let embed_sigelt_view cb (sev:sigelt_view) : t = - match sev with - | Sg_Let (r, lbs) -> - mkConstruct ref_Sg_Let.fv [] [as_arg (embed e_bool cb r); - as_arg (embed (e_list e_letbinding) cb lbs)] - - | Sg_Inductive (nm, univs, bs, t, dcs) -> - mkConstruct ref_Sg_Inductive.fv [] [as_arg (embed e_string_list cb nm); - as_arg (embed e_univ_names cb univs); - as_arg (embed e_binders cb bs); - as_arg (embed e_term cb t); - as_arg (embed (e_list e_ctor) cb dcs)] - - | Sg_Val (nm, univs, t) -> - mkConstruct ref_Sg_Val.fv [] - [as_arg (embed e_string_list cb nm); - as_arg (embed e_univ_names cb univs); - as_arg (embed e_term cb t)] - - | Unk -> - mkConstruct ref_Unk.fv [] [] - in - let unembed_sigelt_view cb (t:t) : option sigelt_view = - match t.nbe_t with - | Construct (fv, _, [(dcs, _); (t, _); (bs, _); (us, _); (nm, _)]) when S.fv_eq_lid fv ref_Sg_Inductive.lid -> - BU.bind_opt (unembed e_string_list cb nm) (fun nm -> - BU.bind_opt (unembed e_univ_names cb us) (fun us -> - BU.bind_opt (unembed e_binders cb bs) (fun bs -> - BU.bind_opt (unembed e_term cb t) (fun t -> - BU.bind_opt (unembed (e_list e_ctor) cb dcs) (fun dcs -> - Some <| Sg_Inductive (nm, us, bs, t, dcs)))))) - - | Construct (fv, _, [(lbs, _); (r, _)]) when S.fv_eq_lid fv ref_Sg_Let.lid -> - BU.bind_opt (unembed e_bool cb r) (fun r -> - BU.bind_opt (unembed (e_list e_letbinding) cb lbs) (fun lbs -> - Some <| Sg_Let (r, lbs))) - - | Construct (fv, _, [(t, _); (us, _); (nm, _)]) when S.fv_eq_lid fv ref_Sg_Val.lid -> - BU.bind_opt (unembed e_string_list cb nm) (fun nm -> - BU.bind_opt (unembed e_univ_names cb us) (fun us -> - BU.bind_opt (unembed e_term cb t) (fun t -> - Some <| Sg_Val(nm, us, t)))) - - | Construct (fv, _, []) when S.fv_eq_lid fv ref_Unk.lid -> - Some Unk - - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded sigelt_view: %s" (t_to_string t)); - None - in - mk_emb' embed_sigelt_view unembed_sigelt_view fstar_refl_sigelt_view_fv - -let e_name : embedding name = e_list e_string - -let e_qualifier = - let embed cb (q:RD.qualifier) : t = - match q with - | RD.Assumption -> mkConstruct ref_qual_Assumption.fv [] [] - | RD.New -> mkConstruct ref_qual_New.fv [] [] - | RD.Private -> mkConstruct ref_qual_Private.fv [] [] - | RD.Unfold_for_unification_and_vcgen -> mkConstruct ref_qual_Unfold_for_unification_and_vcgen.fv [] [] - | RD.Visible_default -> mkConstruct ref_qual_Visible_default.fv [] [] - | RD.Irreducible -> mkConstruct ref_qual_Irreducible.fv [] [] - | RD.Inline_for_extraction -> mkConstruct ref_qual_Inline_for_extraction.fv [] [] - | RD.NoExtract -> mkConstruct ref_qual_NoExtract.fv [] [] - | RD.Noeq -> mkConstruct ref_qual_Noeq.fv [] [] - | RD.Unopteq -> mkConstruct ref_qual_Unopteq.fv [] [] - | RD.TotalEffect -> mkConstruct ref_qual_TotalEffect.fv [] [] - | RD.Logic -> mkConstruct ref_qual_Logic.fv [] [] - | RD.Reifiable -> mkConstruct ref_qual_Reifiable.fv [] [] - | RD.ExceptionConstructor -> mkConstruct ref_qual_ExceptionConstructor.fv [] [] - | RD.HasMaskedEffect -> mkConstruct ref_qual_HasMaskedEffect.fv [] [] - | RD.Effect -> mkConstruct ref_qual_Effect.fv [] [] - | RD.OnlyName -> mkConstruct ref_qual_OnlyName.fv [] [] - | RD.Reflectable l -> - mkConstruct ref_qual_Reflectable.fv [] [as_arg (embed e_name cb l)] - - | RD.Discriminator l -> - mkConstruct ref_qual_Discriminator.fv [] [as_arg (embed e_name cb l)] - - | RD.Action l -> - mkConstruct ref_qual_Action.fv [] [as_arg (embed e_name cb l)] - - | RD.Projector li -> - mkConstruct ref_qual_Projector.fv [] [as_arg (embed (e_tuple2 e_name e_ident) cb li)] - - | RD.RecordType ids12 -> - mkConstruct ref_qual_RecordType.fv [] [as_arg (embed (e_tuple2 (e_list e_ident) (e_list e_ident)) cb ids12)] - - | RD.RecordConstructor ids12 -> - mkConstruct ref_qual_RecordConstructor.fv [] [as_arg (embed (e_tuple2 (e_list e_ident) (e_list e_ident)) cb ids12)] - in - let unembed cb (t:t) : option RD.qualifier = - match t.nbe_t with - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Assumption.lid -> Some RD.Assumption - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_New.lid -> Some RD.New - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Private.lid -> Some RD.Private - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Unfold_for_unification_and_vcgen.lid -> Some RD.Unfold_for_unification_and_vcgen - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Visible_default.lid -> Some RD.Visible_default - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Irreducible.lid -> Some RD.Irreducible - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Inline_for_extraction.lid -> Some RD.Inline_for_extraction - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_NoExtract.lid -> Some RD.NoExtract - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Noeq.lid -> Some RD.Noeq - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Unopteq.lid -> Some RD.Unopteq - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_TotalEffect.lid -> Some RD.TotalEffect - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Logic.lid -> Some RD.Logic - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Reifiable.lid -> Some RD.Reifiable - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_ExceptionConstructor.lid -> Some RD.ExceptionConstructor - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_HasMaskedEffect.lid -> Some RD.HasMaskedEffect - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Effect.lid -> Some RD.Effect - | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_OnlyName.lid -> Some RD.OnlyName - - | Construct (fv, [], [(l, _)]) when S.fv_eq_lid fv ref_qual_Reflectable.lid -> - BU.bind_opt (unembed e_name cb l) (fun l -> - Some (RD.Reflectable l)) - - | Construct (fv, [], [(l, _)]) when S.fv_eq_lid fv ref_qual_Discriminator.lid -> - BU.bind_opt (unembed e_name cb l) (fun l -> - Some (RD.Discriminator l)) - - | Construct (fv, [], [(l, _)]) when S.fv_eq_lid fv ref_qual_Action.lid -> - BU.bind_opt (unembed e_name cb l) (fun l -> - Some (RD.Action l)) - - | Construct (fv, [], [(li, _)]) when S.fv_eq_lid fv ref_qual_Projector.lid -> - BU.bind_opt (unembed (e_tuple2 e_name e_ident) cb li) (fun li -> - Some (RD.Projector li)) - - | Construct (fv, [], [(ids12, _)]) when S.fv_eq_lid fv ref_qual_RecordType.lid -> - BU.bind_opt (unembed (e_tuple2 (e_list e_ident) (e_list e_ident)) cb ids12) (fun ids12 -> - Some (RD.RecordType ids12)) - - | Construct (fv, [], [(ids12, _)]) when S.fv_eq_lid fv ref_qual_RecordConstructor.lid -> - BU.bind_opt (unembed (e_tuple2 (e_list e_ident) (e_list e_ident)) cb ids12) (fun ids12 -> - Some (RD.RecordConstructor ids12)) - - | _ -> - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded qualifier: %s" (t_to_string t)); - None - in - mk_emb embed unembed - (fun () -> mkConstruct fstar_refl_qualifier_fv [] []) - (fun () -> fv_as_emb_typ fstar_refl_qualifier_fv) - -let e_qualifiers = e_list e_qualifier - -let e_vconfig = - let emb cb (o:order) : t = - failwith "emb vconfig NBE" - in - let unemb cb (t:t) : option order = - failwith "unemb vconfig NBE" - in - mk_emb' emb unemb (lid_as_fv PC.vconfig_lid None) diff --git a/src/reflection/FStar.Reflection.V2.NBEEmbeddings.fsti b/src/reflection/FStar.Reflection.V2.NBEEmbeddings.fsti deleted file mode 100644 index 6327aba818d..00000000000 --- a/src/reflection/FStar.Reflection.V2.NBEEmbeddings.fsti +++ /dev/null @@ -1,60 +0,0 @@ -(* - Copyright 2008-2022 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Reflection.V2.NBEEmbeddings - -open FStar -open FStar.Compiler -open FStar.Syntax.Syntax -open FStar.TypeChecker.NBETerm -open FStar.Reflection.V2.Data -module RD = FStar.Reflection.V2.Data - -(* Embeddings *) -val e_bv : embedding bv -val e_namedv : embedding namedv -instance val e_binder : embedding binder -instance val e_binder_view : embedding binder_view -instance val e_binders : embedding binders -instance val e_binding : embedding RD.binding -instance val e_term : embedding term -instance val e_term_view : embedding term_view -instance val e_fv : embedding fv -instance val e_comp : embedding FStar.Syntax.Syntax.comp -instance val e_comp_view : embedding comp_view -instance val e_vconst : embedding vconst -instance val e_env : embedding FStar.TypeChecker.Env.env -instance val e_pattern : embedding pattern -instance val e_branch : embedding Data.branch -instance val e_aqualv : embedding aqualv -instance val e_argv : embedding argv -instance val e_sigelt : embedding sigelt -instance val e_letbinding : embedding letbinding -instance val e_lb_view : embedding lb_view -instance val e_sigelt_view : embedding sigelt_view -instance val e_bv_view : embedding bv_view -instance val e_namedv_view : embedding namedv_view -instance val e_attribute : embedding attribute -instance val e_attributes : embedding (list attribute) (* This seems rather silly, but `attributes` is a keyword *) -instance val e_qualifier : embedding RD.qualifier -instance val e_qualifiers : embedding (list RD.qualifier) -instance val e_ident : embedding Ident.ident -instance val e_univ_name : embedding univ_name -instance val e_univ_names : embedding (list univ_name) -instance val e_universe : embedding universe -instance val e_universe_view : embedding universe_view -instance val e_subst_elt : embedding subst_elt -instance val e_subst : embedding (list subst_elt) diff --git a/src/reflection/FStarC.Reflection.V1.Builtins.fst b/src/reflection/FStarC.Reflection.V1.Builtins.fst new file mode 100644 index 00000000000..99562b5f344 --- /dev/null +++ b/src/reflection/FStarC.Reflection.V1.Builtins.fst @@ -0,0 +1,975 @@ +(* + Copyright 2008-2015 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Reflection.V1.Builtins + +open FStar open FStarC +open FStarC.Compiler +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Reflection.V1.Data +open FStarC.Syntax.Syntax +open FStarC.Errors + +module S = FStarC.Syntax.Syntax // TODO: remove, it's open + +open FStarC.Class.Show +open FStarC.Class.Tagged + +module C = FStarC.Const +module PC = FStarC.Parser.Const +module SS = FStarC.Syntax.Subst +module BU = FStarC.Compiler.Util +module Range = FStarC.Compiler.Range +module U = FStarC.Syntax.Util +module UF = FStarC.Syntax.Unionfind +module Print = FStarC.Syntax.Print +module Ident = FStarC.Ident +module Env = FStarC.TypeChecker.Env +module Err = FStarC.Errors +module Z = FStarC.BigInt +module DsEnv = FStarC.Syntax.DsEnv +module O = FStarC.Options +module RD = FStarC.Reflection.V1.Data +module EMB = FStarC.Syntax.Embeddings +module N = FStarC.TypeChecker.Normalize +open FStarC.VConfig + +open FStarC.Dyn + +(* This file provides implementation for reflection primitives in F*. + * + * Users can be exposed to (mostly) raw syntax of terms when working in + * a metaprogramming effect (such as TAC). These effects are irrelevant + * for runtime and cannot, of course, be used for proof (where syntax + * inspection would be completely inconsistent + *) + + (* + * Most of this file is tedious and repetitive. + * We should really allow for some metaprogramming in F*. Oh wait.... + *) + + +(* This is a hack, but it allows to lookup the constructor sigelts when +inspecting a Sig_inductive_typ. + +We need to be careful though. If we use this for, say, `lookup_attr` and +remove its `env` argument, then the normalizer can reduce it eagerly. +Trying to do this right now means calls to `lookup_attr` are evaluated +at extraction time, and will not behave as expected. The root cause is +that all of the reflection operators are taken to be pure and that't not +the case if we remove the `env` in some, like `lookup_attr`. + +In the case of `inspect_sigelt`, however, I think it won't be +noticeable since one obtain a concrete sigelt without running an impure +metaprogram. *) +let get_env () : Env.env = + match !N.reflection_env_hook with + | None -> failwith "impossible: env_hook unset in reflection" + | Some e -> e + +(* private *) +let inspect_bqual (bq : bqual) : aqualv = + match bq with + | Some (Implicit _) -> Data.Q_Implicit + | Some (Meta t) -> Data.Q_Meta t + | Some Equality + | None -> Data.Q_Explicit + +let inspect_aqual (aq : aqual) : aqualv = + match aq with + | Some ({ aqual_implicit = true }) -> Data.Q_Implicit + | _ -> Data.Q_Explicit + +(* private *) +let pack_bqual (aqv : aqualv) : bqual = + match aqv with + | Data.Q_Explicit -> None + | Data.Q_Implicit -> Some (Implicit false) + | Data.Q_Meta t -> Some (Meta t) + +let pack_aqual (aqv : aqualv) : aqual = + match aqv with + | Data.Q_Implicit -> S.as_aqual_implicit true + | _ -> None + +let inspect_fv (fv:fv) : list string = + Ident.path_of_lid (lid_of_fv fv) + +let pack_fv (ns:list string) : fv = + let lid = PC.p2l ns in + let fallback () = + let quals = + (* This an awful hack *) + if Ident.lid_equals lid PC.cons_lid then Some Data_ctor else + if Ident.lid_equals lid PC.nil_lid then Some Data_ctor else + if Ident.lid_equals lid PC.some_lid then Some Data_ctor else + if Ident.lid_equals lid PC.none_lid then Some Data_ctor else + None + in + lid_as_fv (PC.p2l ns) quals + in + match !N.reflection_env_hook with + | None -> fallback () + | Some env -> + let qninfo = Env.lookup_qname env lid in + match qninfo with + | Some (Inr (se, _us), _rng) -> + let quals = DsEnv.fv_qual_of_se se in + lid_as_fv (PC.p2l ns) quals + | _ -> + fallback () + +// TODO: move to library? +let rec last (l:list 'a) : 'a = + match l with + | [] -> failwith "last: empty list" + | [x] -> x + | _::xs -> last xs + +let rec init (l:list 'a) : list 'a = + match l with + | [] -> failwith "init: empty list" + | [x] -> [] + | x::xs -> x :: init xs + +let inspect_const (c:sconst) : vconst = + match c with + | FStarC.Const.Const_unit -> C_Unit + | FStarC.Const.Const_int (s, _) -> C_Int (Z.big_int_of_string s) + | FStarC.Const.Const_bool true -> C_True + | FStarC.Const.Const_bool false -> C_False + | FStarC.Const.Const_string (s, _) -> C_String s + | FStarC.Const.Const_range r -> C_Range r + | FStarC.Const.Const_reify _ -> C_Reify + | FStarC.Const.Const_reflect l -> C_Reflect (Ident.path_of_lid l) + | _ -> failwith (BU.format1 "unknown constant: %s" (show c)) + +let inspect_universe u = + match u with + | U_zero -> Uv_Zero + | U_succ u -> Uv_Succ u + | U_max us -> Uv_Max us + | U_bvar n -> Uv_BVar (Z.of_int_fs n) + | U_name i -> Uv_Name (Ident.string_of_id i, Ident.range_of_id i) + | U_unif u -> Uv_Unif u + | U_unknown -> Uv_Unk + +let pack_universe uv = + match uv with + | Uv_Zero -> U_zero + | Uv_Succ u -> U_succ u + | Uv_Max us -> U_max us + | Uv_BVar n -> U_bvar (Z.to_int_fs n) + | Uv_Name i -> U_name (Ident.mk_ident i) + | Uv_Unif u -> U_unif u + | Uv_Unk -> U_unknown + +let rec inspect_ln (t:term) : term_view = + // + // Only pushes delayed substitutions, + // doesn't compress uvars + // + let t = t |> SS.compress_subst in + match t.n with + | Tm_meta {tm=t} -> + inspect_ln t + + | Tm_name bv -> + Tv_Var bv + + | Tm_bvar bv -> + Tv_BVar bv + + | Tm_fvar fv -> + Tv_FVar fv + + | Tm_uinst (t, us) -> + (match t.n with + | Tm_fvar fv -> Tv_UInst (fv, us) + | _ -> failwith "Reflection::inspect_ln: uinst for a non-fvar node") + + | Tm_ascribed {tm=t; asc=(Inl ty, tacopt, eq)} -> + Tv_AscribedT (t, ty, tacopt, eq) + + | Tm_ascribed {tm=t; asc=(Inr cty, tacopt, eq)} -> + Tv_AscribedC (t, cty, tacopt, eq) + + | Tm_app {args=[]} -> + failwith "inspect_ln: empty arguments on Tm_app" + + | Tm_app {hd; args} -> + // We split at the last argument, since the term_view does not + // expose n-ary lambdas buy unary ones. + let (a, q) = last args in + let q' = inspect_aqual q in + Tv_App (U.mk_app hd (init args), (a, q')) + + | Tm_abs {bs=[]} -> + failwith "inspect_ln: empty arguments on Tm_abs" + + | Tm_abs {bs=b::bs; body=t; rc_opt=k} -> + let body = + match bs with + | [] -> t + | bs -> S.mk (Tm_abs {bs; body=t; rc_opt=k}) t.pos + in + Tv_Abs (b, body) + + | Tm_type u -> + Tv_Type u + + | Tm_arrow {bs=[]} -> + failwith "inspect_ln: empty binders on arrow" + + | Tm_arrow _ -> + begin match U.arrow_one_ln t with + | Some (b, c) -> Tv_Arrow (b, c) + | None -> failwith "impossible" + end + + | Tm_refine {b=bv; phi=t} -> + Tv_Refine (bv, bv.sort, t) + + | Tm_constant c -> + Tv_Const (inspect_const c) + + | Tm_uvar (ctx_u, s) -> + // + // Use the unique id of the uvar + // + Tv_Uvar (Z.of_int_fs (UF.uvar_unique_id ctx_u.ctx_uvar_head), + (ctx_u, s)) + + | Tm_let {lbs=(false, [lb]); body=t2} -> + if lb.lbunivs <> [] then Tv_Unsupp else + begin match lb.lbname with + | Inr _ -> Tv_Unsupp // no top level lets + | Inl bv -> + // The type of `bv` should match `lb.lbtyp` + Tv_Let (false, lb.lbattrs, bv, bv.sort, lb.lbdef, t2) + end + + | Tm_let {lbs=(true, [lb]); body=t2} -> + if lb.lbunivs <> [] then Tv_Unsupp else + begin match lb.lbname with + | Inr _ -> Tv_Unsupp // no top level lets + | Inl bv -> Tv_Let (true, lb.lbattrs, bv, bv.sort, lb.lbdef, t2) + end + + | Tm_match {scrutinee=t; ret_opt; brs} -> + let rec inspect_pat p = + match p.v with + | Pat_constant c -> Pat_Constant (inspect_const c) + | Pat_cons (fv, us_opt, ps) -> Pat_Cons (fv, us_opt, List.map (fun (p, b) -> inspect_pat p, b) ps) + | Pat_var bv -> Pat_Var (bv, Sealed.seal bv.sort) + | Pat_dot_term eopt -> Pat_Dot_Term eopt + in + let brs = List.map (function (pat, _, t) -> (inspect_pat pat, t)) brs in + Tv_Match (t, ret_opt, brs) + + | Tm_unknown -> + Tv_Unknown + + | Tm_lazy i -> + // Not calling U.unlazy_emb since that calls (stateful) SS.compress + i |> U.unfold_lazy |> inspect_ln + + | _ -> + Err.log_issue t Err.Warning_CantInspect + (BU.format2 "inspect_ln: outside of expected syntax (%s, %s)" (tag_of t) (show t)); + Tv_Unsupp + +let inspect_comp (c : comp) : comp_view = + let get_dec (flags : list cflag) : list term = + match List.tryFind (function DECREASES _ -> true | _ -> false) flags with + | None -> [] + | Some (DECREASES (Decreases_lex ts)) -> ts + | Some (DECREASES (Decreases_wf _)) -> + Err.log_issue c Err.Warning_CantInspect + (BU.format1 "inspect_comp: inspecting comp with wf decreases clause is not yet supported: %s \ + skipping the decreases clause" + (show c)); + [] + | _ -> failwith "Impossible!" + in + match c.n with + | Total t -> C_Total t + | GTotal t -> C_GTotal t + | Comp ct -> begin + let uopt = + if List.length ct.comp_univs = 0 + then U_unknown + else ct.comp_univs |> List.hd in + if Ident.lid_equals ct.effect_name PC.effect_Lemma_lid then + match ct.effect_args with + | (pre,_)::(post,_)::(pats,_)::_ -> + C_Lemma (pre, post, pats) + | _ -> + failwith "inspect_comp: Lemma does not have enough arguments?" + else + let inspect_arg (a, q) = (a, inspect_aqual q) in + C_Eff (ct.comp_univs, + Ident.path_of_lid ct.effect_name, + ct.result_typ, + List.map inspect_arg ct.effect_args, + get_dec ct.flags) + end + +let pack_comp (cv : comp_view) : comp = + let urefl_to_univs u = + if u = U_unknown + then [] + else [u] in + let urefl_to_univ_opt u = + if u = U_unknown + then None + else Some u in + match cv with + | C_Total t -> mk_Total t + | C_GTotal t -> mk_GTotal t + | C_Lemma (pre, post, pats) -> + let ct = { comp_univs = [] + ; effect_name = PC.effect_Lemma_lid + ; result_typ = S.t_unit + ; effect_args = [S.as_arg pre; S.as_arg post; S.as_arg pats] + ; flags = [] } in + S.mk_Comp ct + + | C_Eff (us, ef, res, args, decrs) -> + let pack_arg (a, q) = (a, pack_aqual q) in + let flags = + if List.length decrs = 0 + then [] + else [DECREASES (Decreases_lex decrs)] in + let ct = { comp_univs = us + ; effect_name = Ident.lid_of_path ef Range.dummyRange + ; result_typ = res + ; effect_args = List.map pack_arg args + ; flags = flags } in + S.mk_Comp ct + +let pack_const (c:vconst) : sconst = + match c with + | C_Unit -> C.Const_unit + | C_Int i -> C.Const_int (Z.string_of_big_int i, None) + | C_True -> C.Const_bool true + | C_False -> C.Const_bool false + | C_String s -> C.Const_string (s, Range.dummyRange) + | C_Range r -> C.Const_range r + | C_Reify -> C.Const_reify None + | C_Reflect ns -> C.Const_reflect (Ident.lid_of_path ns Range.dummyRange) + +// TODO: pass in range? +let pack_ln (tv:term_view) : term = + match tv with + | Tv_Var bv -> + S.bv_to_name bv + + | Tv_BVar bv -> + S.bv_to_tm bv + + | Tv_FVar fv -> + S.fv_to_tm fv + + | Tv_UInst (fv, us) -> + mk_Tm_uinst (S.fv_to_tm fv) us + + | Tv_App (l, (r, q)) -> + let q' = pack_aqual q in + U.mk_app l [(r, q')] + + | Tv_Abs (b, t) -> + mk (Tm_abs {bs=[b]; body=t; rc_opt=None}) t.pos // TODO: effect? + + | Tv_Arrow (b, c) -> + mk (Tm_arrow {bs=[b]; comp=c}) c.pos + + | Tv_Type u -> + mk (Tm_type u) Range.dummyRange + + | Tv_Refine (bv, sort, t) -> + mk (Tm_refine {b={bv with sort=sort}; phi=t}) t.pos + + | Tv_Const c -> + S.mk (Tm_constant (pack_const c)) Range.dummyRange + + | Tv_Uvar (u, ctx_u_s) -> + S.mk (Tm_uvar ctx_u_s) Range.dummyRange + + | Tv_Let (false, attrs, bv, ty, t1, t2) -> + let bv = { bv with sort=ty } in + let lb = U.mk_letbinding (Inl bv) [] bv.sort PC.effect_Tot_lid t1 attrs Range.dummyRange in + S.mk (Tm_let {lbs=(false, [lb]); body=t2}) Range.dummyRange + + | Tv_Let (true, attrs, bv, ty, t1, t2) -> + let bv = { bv with sort=ty } in + let lb = U.mk_letbinding (Inl bv) [] bv.sort PC.effect_Tot_lid t1 attrs Range.dummyRange in + S.mk (Tm_let {lbs=(true, [lb]); body=t2}) Range.dummyRange + + | Tv_Match (t, ret_opt, brs) -> + let wrap v = {v=v;p=Range.dummyRange} in + let rec pack_pat p : S.pat = + match p with + | Pat_Constant c -> wrap <| Pat_constant (pack_const c) + | Pat_Cons (fv, us_opt, ps) -> wrap <| Pat_cons (fv, us_opt, List.map (fun (p, b) -> pack_pat p, b) ps) + | Pat_Var (bv, _sort) -> wrap <| Pat_var bv + | Pat_Dot_Term eopt -> wrap <| Pat_dot_term eopt + in + let brs = List.map (function (pat, t) -> (pack_pat pat, None, t)) brs in + S.mk (Tm_match {scrutinee=t; ret_opt; brs; rc_opt=None}) Range.dummyRange + + | Tv_AscribedT(e, t, tacopt, use_eq) -> + S.mk (Tm_ascribed {tm=e; asc=(Inl t, tacopt, use_eq); eff_opt=None}) Range.dummyRange + + | Tv_AscribedC(e, c, tacopt, use_eq) -> + S.mk (Tm_ascribed {tm=e; asc=(Inr c, tacopt, use_eq); eff_opt=None}) Range.dummyRange + + | Tv_Unknown -> + S.mk Tm_unknown Range.dummyRange + + | Tv_Unsupp -> + Err.log_issue0 + Err.Warning_CantInspect "packing a Tv_Unsupp into Tm_unknown"; + S.mk Tm_unknown Range.dummyRange + +let compare_bv (x:bv) (y:bv) : order = + let n = S.order_bv x y in + if n < 0 then Lt + else if n = 0 then Eq + else Gt + +let lookup_attr (attr:term) (env:Env.env) : list fv = + match (SS.compress_subst attr).n with + | Tm_fvar fv -> + let ses = Env.lookup_attr env (Ident.string_of_lid (lid_of_fv fv)) in + List.concatMap (fun se -> match U.lid_of_sigelt se with + | None -> [] + | Some l -> [S.lid_as_fv l None]) ses + | _ -> [] + +let all_defs_in_env (env:Env.env) : list fv = + List.map (fun l -> S.lid_as_fv l None) (Env.lidents env) // |> take 10 + +let defs_in_module (env:Env.env) (modul:name) : list fv = + List.concatMap + (fun l -> + (* must succeed, ids_of_lid always returns a non-empty list *) + let ns = Ident.ids_of_lid l |> init |> List.map Ident.string_of_id in + if ns = modul + then [S.lid_as_fv l None] + else []) + (Env.lidents env) + +let lookup_typ (env:Env.env) (ns:list string) : option sigelt = + let lid = PC.p2l ns in + Env.lookup_sigelt env lid + +let sigelt_attrs (se : sigelt) : list attribute = + se.sigattrs + +let set_sigelt_attrs (attrs : list attribute) (se : sigelt) : sigelt = + { se with sigattrs = attrs } + +let inspect_ident (i:Ident.ident) : ident = Reflection.V2.Builtins.inspect_ident i +let pack_ident (i:ident) : Ident.ident = Reflection.V2.Builtins.pack_ident i + +(* PRIVATE, and hacky :-( *) +let rd_to_syntax_qual : RD.qualifier -> qualifier = function + | RD.Assumption -> Assumption + | RD.New -> New + | RD.Private -> Private + | RD.Unfold_for_unification_and_vcgen -> Unfold_for_unification_and_vcgen + | RD.Visible_default -> Visible_default + | RD.Irreducible -> Irreducible + | RD.Inline_for_extraction -> Inline_for_extraction + | RD.NoExtract -> NoExtract + | RD.Noeq -> Noeq + | RD.Unopteq -> Unopteq + | RD.TotalEffect -> TotalEffect + | RD.Logic -> Logic + | RD.Reifiable -> Reifiable + | RD.Reflectable l -> Reflectable (Ident.lid_of_path l Range.dummyRange) + | RD.Discriminator l -> Discriminator (Ident.lid_of_path l Range.dummyRange) + | RD.Projector (l, i) -> Projector (Ident.lid_of_path l Range.dummyRange, pack_ident i) + | RD.RecordType (l1, l2) -> RecordType (List.map pack_ident l1, List.map pack_ident l2) + | RD.RecordConstructor (l1, l2) -> RecordConstructor (List.map pack_ident l1, List.map pack_ident l2) + | RD.Action l -> Action (Ident.lid_of_path l Range.dummyRange) + | RD.ExceptionConstructor -> ExceptionConstructor + | RD.HasMaskedEffect -> HasMaskedEffect + | RD.Effect -> S.Effect + | RD.OnlyName -> OnlyName + +let syntax_to_rd_qual = function + | Assumption -> RD.Assumption + | New -> RD.New + | Private -> RD.Private + | Unfold_for_unification_and_vcgen -> RD.Unfold_for_unification_and_vcgen + | Visible_default -> RD.Visible_default + | Irreducible -> RD.Irreducible + | Inline_for_extraction -> RD.Inline_for_extraction + | NoExtract -> RD.NoExtract + | Noeq -> RD.Noeq + | Unopteq -> RD.Unopteq + | TotalEffect -> RD.TotalEffect + | Logic -> RD.Logic + | Reifiable -> RD.Reifiable + | Reflectable l -> RD.Reflectable (Ident.path_of_lid l) + | Discriminator l -> RD.Discriminator (Ident.path_of_lid l) + | Projector (l, i) -> RD.Projector (Ident.path_of_lid l, inspect_ident i) + | RecordType (l1, l2) -> RD.RecordType (List.map inspect_ident l1, List.map inspect_ident l2) + | RecordConstructor (l1, l2) -> RD.RecordConstructor (List.map inspect_ident l1, List.map inspect_ident l2) + | Action l -> RD.Action (Ident.path_of_lid l) + | ExceptionConstructor -> RD.ExceptionConstructor + | HasMaskedEffect -> RD.HasMaskedEffect + | S.Effect -> RD.Effect + | OnlyName -> RD.OnlyName + + +let sigelt_quals (se : sigelt) : list RD.qualifier = + se.sigquals |> List.map syntax_to_rd_qual + +let set_sigelt_quals (quals : list RD.qualifier) (se : sigelt) : sigelt = + { se with sigquals = List.map rd_to_syntax_qual quals } + +let sigelt_opts (se : sigelt) : option vconfig = se.sigopts + +let embed_vconfig (vcfg : vconfig) : term = + EMB.embed vcfg Range.dummyRange None EMB.id_norm_cb + +let inspect_sigelt (se : sigelt) : sigelt_view = + match se.sigel with + | Sig_let {lbs=(r, lbs)} -> + let inspect_letbinding (lb:letbinding) = + let {lbname=nm;lbunivs=us;lbtyp=typ;lbeff=eff;lbdef=def;lbattrs=attrs;lbpos=pos} = lb in + let s, us = SS.univ_var_opening us in + let typ = SS.subst s typ in + let def = SS.subst s def in + U.mk_letbinding nm us typ eff def attrs pos + in + Sg_Let (r, List.map inspect_letbinding lbs) + + | Sig_inductive_typ {lid; us; params=param_bs; t=ty; ds=c_lids} -> + let nm = Ident.path_of_lid lid in + let s, us = SS.univ_var_opening us in + let param_bs = SS.subst_binders s param_bs in + let ty = SS.subst s ty in + + let param_bs, ty = SS.open_term param_bs ty in + + let inspect_ctor (c_lid:Ident.lid) : ctor = + match Env.lookup_sigelt (get_env ()) c_lid with + | Some ({sigel = Sig_datacon {lid; us; t=cty; num_ty_params=nparam}}) -> + let cty = SS.subst s cty in // open universes from above + + let param_ctor_bs, c = N.get_n_binders (get_env ()) nparam cty in + + if List.length param_ctor_bs <> nparam then + failwith "impossible: inspect_sigelt: could not obtain sufficient ctor param binders"; + + if not (U.is_total_comp c) then + failwith "impossible: inspect_sigelt: removed parameters and got an effectful comp"; + let cty = U.comp_result c in + + (* Substitute the parameters of the constructor to match + * those of the inductive opened above, and return the type + * of the constructor already instantiated. *) + let s' = List.map2 (fun b1 b2 -> NT (b1.binder_bv, S.bv_to_name b2.binder_bv)) + param_ctor_bs param_bs + in + let cty = SS.subst s' cty in + + let cty = U.remove_inacc cty in + (Ident.path_of_lid lid, cty) + + | _ -> + failwith "impossible: inspect_sigelt: did not find ctor" + in + Sg_Inductive (nm, List.map inspect_ident us, param_bs, ty, List.map inspect_ctor c_lids) + + | Sig_declare_typ {lid; us; t=ty} -> + let nm = Ident.path_of_lid lid in + let us, ty = SS.open_univ_vars us ty in + Sg_Val (nm, List.map inspect_ident us, ty) + + | _ -> + Unk + +let pack_sigelt (sv:sigelt_view) : sigelt = + let check_lid lid = + if List.length (Ident.path_of_lid lid) <= 1 + then failwith ("pack_sigelt: invalid long identifier \"" + ^ Ident.string_of_lid lid + ^ "\" (did you forget a module path?)") + in + match sv with + | Sg_Let (r, lbs) -> + let pack_letbinding (lb:letbinding) = + let {lbname=nm;lbunivs=us;lbtyp=typ;lbeff=eff;lbdef=def;lbattrs=attrs;lbpos=pos} = lb in + let lid = match nm with + | Inr fv -> lid_of_fv fv + | _ -> failwith + "impossible: pack_sigelt: bv in toplevel let binding" + in + check_lid lid; + let s = SS.univ_var_closing us in + let typ = SS.subst s typ in + let def = SS.subst s def in + let lb = U.mk_letbinding nm us typ eff def attrs pos in + (lid, lb) + in + let packed = List.map pack_letbinding lbs in + let lbs = List.map snd packed in + let lids = List.map fst packed in + mk_sigelt <| Sig_let {lbs=(r, lbs); lids} + + | Sg_Inductive (nm, us_names, param_bs, ty, ctors) -> + let us_names = List.map pack_ident us_names in + let ind_lid = Ident.lid_of_path nm Range.dummyRange in + check_lid ind_lid; + let s = SS.univ_var_closing us_names in + let nparam = List.length param_bs in + //We can't tust the value of injective_type_params; set it to false here and let the typechecker recompute + let injective_type_params = false in + let pack_ctor (c:ctor) : sigelt = + let (nm, ty) = c in + let lid = Ident.lid_of_path nm Range.dummyRange in + let ty = U.arrow param_bs (S.mk_Total ty) in + let ty = SS.subst s ty in (* close univs *) + mk_sigelt <| Sig_datacon {lid; us=us_names; t=ty; ty_lid=ind_lid; num_ty_params=nparam; mutuals=[]; injective_type_params } + in + + let ctor_ses : list sigelt = List.map pack_ctor ctors in + let c_lids : list Ident.lid = List.map (fun se -> BU.must (U.lid_of_sigelt se)) ctor_ses in + + let ind_se : sigelt = + let param_bs = SS.close_binders param_bs in + let ty = SS.close param_bs ty in + + (* close univs *) + let param_bs = SS.subst_binders s param_bs in + let ty = SS.subst s ty in + //We can't trust the assignment of num uniform binders from the reflection API + //So, set it to None; it has to be checked and recomputed + mk_sigelt <| Sig_inductive_typ {lid=ind_lid; + us=us_names; + params=param_bs; + num_uniform_params=None; + t=ty; + mutuals=[]; + ds=c_lids; + injective_type_params } + in + let se = mk_sigelt <| Sig_bundle {ses=ind_se::ctor_ses; lids=ind_lid::c_lids} in + { se with sigquals = Noeq::se.sigquals } + + | Sg_Val (nm, us_names, ty) -> + let us_names = List.map pack_ident us_names in + let val_lid = Ident.lid_of_path nm Range.dummyRange in + check_lid val_lid; + let typ = SS.close_univ_vars us_names ty in + mk_sigelt <| Sig_declare_typ {lid=val_lid; us=us_names; t=typ} + + | Unk -> + failwith "packing Unk, sorry" + +let inspect_lb (lb:letbinding) : lb_view = + let {lbname=nm;lbunivs=us;lbtyp=typ;lbeff=eff;lbdef=def;lbattrs=attrs;lbpos=pos} + = lb in + let s, us = SS.univ_var_opening us in + let typ = SS.subst s typ in + let def = SS.subst s def in + let us = List.map inspect_ident us in + match nm with + | Inr fv -> {lb_fv = fv; lb_us = us; lb_typ = typ; lb_def = def} + | _ -> failwith "Impossible: bv in top-level let binding" + +let pack_lb (lbv:lb_view) : letbinding = + let {lb_fv = fv; lb_us = us; lb_typ = typ; lb_def = def} = lbv in + let us = List.map pack_ident us in + let s = SS.univ_var_closing us in + let typ = SS.subst s typ in + let def = SS.subst s def in + U.mk_letbinding (Inr fv) us typ PC.effect_Tot_lid def [] Range.dummyRange + +let inspect_bv (bv:bv) : bv_view = + if bv.index < 0 then ( + Err.log_issue0 Err.Warning_CantInspect + (BU.format3 "inspect_bv: index is negative (%s : %s), index = %s" + (Ident.string_of_id bv.ppname) + (show bv.sort) + (show bv.index)) + ); + { + bv_ppname = Sealed.seal <| Ident.string_of_id bv.ppname; + bv_index = Z.of_int_fs bv.index; + } + +let pack_bv (bvv:bv_view) : bv = + if Z.to_int_fs bvv.bv_index < 0 then ( + Err.log_issue0 Err.Warning_CantInspect + (BU.format2 "pack_bv: index is negative (%s), index = %s" + (Sealed.unseal bvv.bv_ppname) + (show (Z.to_int_fs bvv.bv_index))) + ); + { + ppname = Ident.mk_ident (Sealed.unseal <| bvv.bv_ppname, Range.dummyRange); + index = Z.to_int_fs bvv.bv_index; // Guaranteed to be a nat + sort = S.tun; + } + +let inspect_binder (b:binder) : binder_view = + let attrs = U.encode_positivity_attributes b.binder_positivity b.binder_attrs in + { + binder_bv = b.binder_bv; + binder_qual = inspect_bqual (b.binder_qual); + binder_attrs = attrs; + binder_sort = b.binder_bv.sort; + } + +let pack_binder (bview:binder_view) : binder = + let pqual, attrs = U.parse_positivity_attributes bview.binder_attrs in + { + binder_bv= { bview.binder_bv with sort = bview.binder_sort }; + binder_qual=pack_bqual (bview.binder_qual); + binder_positivity=pqual; + binder_attrs=attrs + } + +open FStarC.TypeChecker.Env +let moduleof (e : Env.env) : list string = + Ident.path_of_lid e.curmodule + +let env_open_modules (e : Env.env) : list name = + List.map (fun (l, m) -> List.map Ident.string_of_id (Ident.ids_of_lid l)) + (DsEnv.open_modules e.dsenv) + +let binders_of_env e = FStarC.TypeChecker.Env.all_binders e + +(* Generic combinators, safe *) +let eqopt = Syntax.Util.eqopt +let eqlist = Syntax.Util.eqlist +let eqprod = Syntax.Util.eqprod + +(* + * Why doesn't this call into Syntax.Util.term_eq? Because that function + * can expose details that are not observable in the userspace view of + * terms, and hence that function cannot be safely exposed if we wish to + * maintain the lemmas stating that pack/inspect are inverses of each + * other. + * + * In other words, we need this function to be implemented consistently + * with the view to make sure it is a _function_ in userspace, and maps + * (propositionally) equal terms to equal results. + * + * So we implement it via inspect_ln, to make sure we don't reveal + * anything inspect_ln does not already reveal. Hence this function + * is really only an optimization of this same implementation done in + * userspace. Also, nothing is guaranted about its result. It if were to + * just return false constantly, that would be safe (though useless). + * + * This same note also applies to comp, and other types that are taken + * as abstract, but have a lemma stating that the view is complete + * (or appear inside a view of one such type). + *) +let rec term_eq (t1:term) (t2:term) : bool = + match inspect_ln t1, inspect_ln t2 with + | Tv_Var bv1, Tv_Var bv2 -> + bv_eq bv1 bv2 + + | Tv_BVar bv1, Tv_BVar bv2 -> + bv_eq bv1 bv2 + + | Tv_FVar fv1, Tv_FVar fv2 -> + (* This should be equivalent to exploding the fv's name comparing *) + S.fv_eq fv1 fv2 + + | Tv_UInst (fv1, us1), Tv_UInst (fv2, us2) -> + S.fv_eq fv1 fv2 && univs_eq us1 us2 + + | Tv_App (h1, arg1), Tv_App (h2, arg2) -> + term_eq h1 h2 && arg_eq arg1 arg2 + + | Tv_Abs (b1, t1), Tv_Abs (b2, t2) -> + binder_eq b1 b2 && term_eq t1 t2 + + | Tv_Arrow (b1, c1), Tv_Arrow (b2, c2) -> + binder_eq b1 b2 && comp_eq c1 c2 + + | Tv_Type u1, Tv_Type u2 -> + univ_eq u1 u2 + + | Tv_Refine (b1, sort1, t1), Tv_Refine (b2, sort2, t2) -> + (* No need to compare bvs *) + term_eq sort1 sort2 && term_eq t1 t2 + + | Tv_Const c1, Tv_Const c2 -> + const_eq c1 c2 + + | Tv_Uvar (n1, uv1), Tv_Uvar (n2, uv2) -> + (* + * The uvs are completely opaque in userspace, so we could do a fancier + * check here without compromising soundness. But.. we cannot really check + * the unionfind graph, I think, since the result could differ as things get + * unified (though it's unclear if that can happen within two calls to this + * function within a *single* definition.. since uvars do not survive across + * top-levels. + * + * Anyway, for now just compare the associated ints. Which are *definitely* + * visible by users. + *) + n1 = n2 + + | Tv_Let (r1, ats1, bv1, ty1, m1, n1), Tv_Let (r2, ats2, bv2, ty2, m2, n2) -> + (* no need to compare bvs *) + r1 = r2 && + eqlist term_eq ats1 ats2 && + term_eq ty1 ty2 && + term_eq m1 m2 && + term_eq n1 n2 + + | Tv_Match (h1, an1, brs1), Tv_Match (h2, an2, brs2) -> + term_eq h1 h2 && + eqopt match_ret_asc_eq an1 an2 && + eqlist branch_eq brs1 brs2 + + | Tv_AscribedT (e1, t1, topt1, eq1), Tv_AscribedT (e2, t2, topt2, eq2) -> + term_eq e1 e2 && + term_eq t1 t2 && + eqopt term_eq topt1 topt2 && + eq1 = eq2 + + | Tv_AscribedC (e1, c1, topt1, eq1), Tv_AscribedC (e2, c2, topt2, eq2) -> + term_eq e1 e2 && + comp_eq c1 c2 && + eqopt term_eq topt1 topt2 && + eq1 = eq2 + + | Tv_Unknown, Tv_Unknown -> true + | _ -> false + +and arg_eq (arg1 : argv) (arg2 : argv) : bool = + let (a1, aq1) = arg1 in + let (a2, aq2) = arg2 in + term_eq a1 a2 && aqual_eq aq1 aq2 + +and aqual_eq (aq1 : aqualv) (aq2 : aqualv) : bool = + match aq1, aq2 with + | Q_Implicit, Q_Implicit -> true + | Q_Explicit, Q_Explicit -> true + | Q_Meta t1, Q_Meta t2 -> term_eq t1 t2 + | _ -> false + +and binder_eq (b1 : binder) (b2 : binder) : bool = + let bview1 = inspect_binder b1 in + let bview2 = inspect_binder b2 in + binding_bv_eq bview1.binder_bv bview2.binder_bv && + aqual_eq bview1.binder_qual bview2.binder_qual && + eqlist term_eq bview1.binder_attrs bview2.binder_attrs + +and binding_bv_eq (bv1 : bv) (bv2 : bv) : bool = + (* + * In binding ocurrences, we compare the sorts of variables. Not so + * in normal ocurrences, as term_eq does. Note we can access the sort + * safely since it's exactly what inspect_bv does. + * + * We do _not_ compare the indices. This is a binding ocurrence, so + * they do not matter at all. + *) + term_eq bv1.sort bv2.sort + +and bv_eq (bv1 : bv) (bv2 : bv) : bool = + (* + * Just compare the index. Note: this is safe since inspect_bv + * exposes it. We do _not_ compare the sorts. This is already + * what Syntax.Util.term_eq does, and they arguably should not + * be there. + *) + bv1.index = bv2.index + +and comp_eq (c1 : comp) (c2 : comp) : bool = + match inspect_comp c1, inspect_comp c2 with + | C_Total t1, C_Total t2 + | C_GTotal t1, C_GTotal t2 -> + term_eq t1 t2 + + | C_Lemma (pre1, post1, pats1), C_Lemma (pre2, post2, pats2) -> + term_eq pre1 pre2 && term_eq post1 post2 && term_eq pats1 pats2 + + | C_Eff (us1, name1, t1, args1, decrs1), C_Eff (us2, name2, t2, args2, decrs2) -> + univs_eq us1 us2 && + name1 = name2 && + term_eq t1 t2 && + eqlist arg_eq args1 args2 && + eqlist term_eq decrs1 decrs2 + + | _ -> + false + +and match_ret_asc_eq (a1 : match_returns_ascription) (a2 : match_returns_ascription) : bool = + eqprod binder_eq ascription_eq a1 a2 + +and ascription_eq (asc1 : ascription) (asc2 : ascription) : bool = + let (a1, topt1, eq1) = asc1 in + let (a2, topt2, eq2) = asc2 in + (match a1, a2 with + | Inl t1, Inl t2 -> term_eq t1 t2 + | Inr c1, Inr c2 -> comp_eq c1 c2) && + eqopt term_eq topt1 topt2 && + eq1 = eq2 + +and branch_eq (c1 : Data.branch) (c2 : Data.branch) : bool = + eqprod pattern_eq term_eq c1 c2 + +and pattern_eq (p1 : pattern) (p2 : pattern) : bool = + match p1, p2 with + | Pat_Constant c1, Pat_Constant c2 -> + const_eq c1 c2 + | Pat_Cons (fv1, us1, subpats1), Pat_Cons (fv2, us2, subpats2) -> + S.fv_eq fv1 fv2 && + eqopt (eqlist univ_eq) us1 us2 && + eqlist (eqprod pattern_eq (fun b1 b2 -> b1 = b2)) subpats1 subpats2 + + | Pat_Var (bv1, _), Pat_Var (bv2, _) -> + binding_bv_eq bv1 bv2 + + | Pat_Dot_Term topt1, Pat_Dot_Term topt2 -> + eqopt term_eq topt1 topt2 + + | _ -> false + +and const_eq (c1 : vconst) (c2 : vconst) : bool = + c1 = c2 + +and univ_eq (u1 : universe) (u2 : universe) : bool = + Syntax.Util.eq_univs u1 u2 // FIXME! + +and univs_eq (us1 : list universe) (us2 : list universe) : bool = + eqlist univ_eq us1 us2 + +let implode_qn ns = String.concat "." ns +let explode_qn s = String.split ['.'] s +let compare_string s1 s2 = Z.of_int_fs (String.compare s1 s2) + +let push_binder e b = Env.push_binders e [b] + +let subst (x:bv) (n:term) (m:term) : term = + SS.subst [NT(x,n)] m + +let close_term (b:binder) (t:term) : term = SS.close [b] t + +let range_of_term (t:term) = t.pos +let range_of_sigelt (s:sigelt) = s.sigrng diff --git a/src/reflection/FStarC.Reflection.V1.Builtins.fsti b/src/reflection/FStarC.Reflection.V1.Builtins.fsti new file mode 100644 index 00000000000..2f09bfd14f4 --- /dev/null +++ b/src/reflection/FStarC.Reflection.V1.Builtins.fsti @@ -0,0 +1,93 @@ +(* + Copyright 2008-2015 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Reflection.V1.Builtins + +open FStarC.Ident +open FStarC.Syntax.Syntax +open FStarC.Syntax.Embeddings +open FStar.Order +module Env = FStarC.TypeChecker.Env +open FStarC.Reflection.V1.Data +open FStarC.Compiler.Effect +module O = FStarC.Options +module RD = FStarC.Reflection.V1.Data +module EMB = FStarC.Syntax.Embeddings +module Z = FStarC.BigInt +open FStarC.VConfig + +(* Primitives *) +val compare_bv : bv -> bv -> order +val lookup_typ : Env.env -> list string -> option sigelt +val lookup_attr : term -> Env.env -> list fv +val all_defs_in_env : Env.env -> list fv +val defs_in_module : Env.env -> name -> list fv +val binders_of_env : Env.env -> binders +val moduleof : Env.env -> list string +val term_eq : term -> term -> bool +val env_open_modules : Env.env -> list name +val sigelt_opts : sigelt -> option vconfig +val embed_vconfig : vconfig -> term + +val sigelt_attrs : sigelt -> list attribute +val set_sigelt_attrs : list attribute -> sigelt -> sigelt + +val sigelt_quals : sigelt -> list RD.qualifier +val set_sigelt_quals : list RD.qualifier -> sigelt -> sigelt + +(* Views *) +val inspect_fv : fv -> list string +val pack_fv : list string -> fv + +val inspect_const : sconst -> vconst +val pack_const : vconst -> sconst + +val inspect_ln : term -> term_view +val pack_ln : term_view -> term + +val inspect_comp : comp -> comp_view +val pack_comp : comp_view -> comp + +val inspect_sigelt : sigelt -> sigelt_view +val pack_sigelt : sigelt_view -> sigelt + +val inspect_lb : letbinding -> lb_view +val pack_lb : lb_view -> letbinding + +val inspect_bv : bv -> bv_view +val pack_bv : bv_view -> bv + +val inspect_binder : binder -> binder_view +val pack_binder : binder_view -> binder + +val inspect_aqual : aqual -> aqualv +val pack_aqual : aqualv -> aqual + +val inspect_universe : universe -> universe_view +val pack_universe : universe_view -> universe + +val subst : bv -> term -> term -> term +val close_term : binder -> term -> term + +(* We're only taking these as primitives to break the dependency from * +FStarC.Tactics into FStar.String, which pulls a LOT of modules. *) +val implode_qn : list string -> string +val explode_qn : string -> list string +val compare_string : string -> string -> Z.t + +val push_binder : Env.env -> binder -> Env.env + +val range_of_term : term -> FStarC.Compiler.Range.range +val range_of_sigelt : sigelt -> FStarC.Compiler.Range.range diff --git a/src/reflection/FStarC.Reflection.V1.Constants.fst b/src/reflection/FStarC.Reflection.V1.Constants.fst new file mode 100644 index 00000000000..59bf13310c8 --- /dev/null +++ b/src/reflection/FStarC.Reflection.V1.Constants.fst @@ -0,0 +1,258 @@ +(* + Copyright 2008-2022 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Reflection.V1.Constants + + +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List + +(* NOTE: This file is exactly the same as its .fs variant. It is only +here so the equally-named interface file in ulib/ is not taken by the +dependency analysis to be the interface of the .fs. We also cannot ditch +the .fs, since out bootstrapping process does not extract any .ml file +from an interface. Hence we keep both, exactly equal to each other. *) + +open FStarC.Syntax.Syntax +module Ident = FStarC.Ident +module Range = FStarC.Compiler.Range +module Z = FStarC.BigInt +open FStarC.Ident +module PC = FStarC.Parser.Const + +(* Contains all lids and terms needed for embedding/unembedding *) + +type refl_constant = { + lid : FStarC.Ident.lid; + fv : fv; + t : term; +} + +let refl_constant_lid rc = rc.lid +let refl_constant_term rc = rc.t +let fstar_refl_lid s = Ident.lid_of_path (["FStar"; "Stubs"; "Reflection"]@s) Range.dummyRange + +let fstar_refl_types_lid s = fstar_refl_lid ["Types"; s] +let fstar_refl_builtins_lid s = fstar_refl_lid ["V1"; "Builtins"; s] +let fstar_refl_data_lid s = fstar_refl_lid ["V1"; "Data"; s] + +let fstar_refl_data_const s = + let lid = fstar_refl_data_lid s in + { lid = lid + ; fv = lid_as_fv lid (Some Data_ctor) + ; t = tdataconstr lid + } + +let mk_refl_types_lid_as_term (s:string) = tconst (fstar_refl_types_lid s) +let mk_refl_types_lid_as_fv (s:string) = fvconst (fstar_refl_types_lid s) +let mk_refl_data_lid_as_term (s:string) = tconst (fstar_refl_data_lid s) +let mk_refl_data_lid_as_fv (s:string) = fvconst (fstar_refl_data_lid s) + +let mk_inspect_pack_pair s = + let inspect_lid = fstar_refl_builtins_lid ("inspect" ^ s) in + let pack_lid = fstar_refl_builtins_lid ("pack" ^ s) in + let inspect_fv = lid_as_fv inspect_lid None in + let pack_fv = lid_as_fv pack_lid None in + let inspect = { lid = inspect_lid ; fv = inspect_fv ; t = fv_to_tm inspect_fv } in + let pack = { lid = pack_lid ; fv = pack_fv ; t = fv_to_tm pack_fv } in + (inspect, pack) + +let fstar_refl_inspect_ln , fstar_refl_pack_ln = mk_inspect_pack_pair "_ln" +let fstar_refl_inspect_fv , fstar_refl_pack_fv = mk_inspect_pack_pair "_fv" +let fstar_refl_inspect_bv , fstar_refl_pack_bv = mk_inspect_pack_pair "_bv" +let fstar_refl_inspect_binder , fstar_refl_pack_binder = mk_inspect_pack_pair "_binder" +let fstar_refl_inspect_comp , fstar_refl_pack_comp = mk_inspect_pack_pair "_comp" +let fstar_refl_inspect_sigelt , fstar_refl_pack_sigelt = mk_inspect_pack_pair "_sigelt" +let fstar_refl_inspect_lb , fstar_refl_pack_lb = mk_inspect_pack_pair "_lb" +let fstar_refl_inspect_universe, fstar_refl_pack_universe = mk_inspect_pack_pair "_universe" + +(* assumed types *) +let fstar_refl_env = mk_refl_types_lid_as_term "env" +let fstar_refl_env_fv = mk_refl_types_lid_as_fv "env" +let fstar_refl_bv = mk_refl_types_lid_as_term "bv" +let fstar_refl_bv_fv = mk_refl_types_lid_as_fv "bv" +let fstar_refl_fv = mk_refl_types_lid_as_term "fv" +let fstar_refl_fv_fv = mk_refl_types_lid_as_fv "fv" +let fstar_refl_comp = mk_refl_types_lid_as_term "comp" +let fstar_refl_comp_fv = mk_refl_types_lid_as_fv "comp" +let fstar_refl_binder = mk_refl_types_lid_as_term "binder" +let fstar_refl_binder_fv = mk_refl_types_lid_as_fv "binder" +let fstar_refl_sigelt = mk_refl_types_lid_as_term "sigelt" +let fstar_refl_sigelt_fv = mk_refl_types_lid_as_fv "sigelt" +let fstar_refl_term = mk_refl_types_lid_as_term "term" +let fstar_refl_term_fv = mk_refl_types_lid_as_fv "term" +let fstar_refl_letbinding = mk_refl_types_lid_as_term "letbinding" +let fstar_refl_letbinding_fv = mk_refl_types_lid_as_fv "letbinding" +let fstar_refl_ident = mk_refl_types_lid_as_term "ident" +let fstar_refl_ident_fv = mk_refl_types_lid_as_fv "ident" +let fstar_refl_univ_name = mk_refl_types_lid_as_term "univ_name" +let fstar_refl_univ_name_fv = mk_refl_types_lid_as_fv "univ_name" +let fstar_refl_optionstate = mk_refl_types_lid_as_term "optionstate" +let fstar_refl_optionstate_fv = mk_refl_types_lid_as_fv "optionstate" +let fstar_refl_universe = mk_refl_types_lid_as_term "universe" +let fstar_refl_universe_fv = mk_refl_types_lid_as_fv "universe" + +(* auxiliary types *) +let fstar_refl_aqualv = mk_refl_data_lid_as_term "aqualv" +let fstar_refl_aqualv_fv = mk_refl_data_lid_as_fv "aqualv" +let fstar_refl_comp_view = mk_refl_data_lid_as_term "comp_view" +let fstar_refl_comp_view_fv = mk_refl_data_lid_as_fv "comp_view" +let fstar_refl_term_view = mk_refl_data_lid_as_term "term_view" +let fstar_refl_term_view_fv = mk_refl_data_lid_as_fv "term_view" +let fstar_refl_pattern = mk_refl_data_lid_as_term "pattern" +let fstar_refl_pattern_fv = mk_refl_data_lid_as_fv "pattern" +let fstar_refl_branch = mk_refl_data_lid_as_term "branch" +let fstar_refl_branch_fv = mk_refl_data_lid_as_fv "branch" +let fstar_refl_bv_view = mk_refl_data_lid_as_term "bv_view" +let fstar_refl_bv_view_fv = mk_refl_data_lid_as_fv "bv_view" +let fstar_refl_binder_view = mk_refl_data_lid_as_term "binder_view" +let fstar_refl_binder_view_fv = mk_refl_data_lid_as_fv "binder_view" +let fstar_refl_vconst = mk_refl_data_lid_as_term "vconst" +let fstar_refl_vconst_fv = mk_refl_data_lid_as_fv "vconst" +let fstar_refl_lb_view = mk_refl_data_lid_as_term "lb_view" +let fstar_refl_lb_view_fv = mk_refl_data_lid_as_fv "lb_view" +let fstar_refl_sigelt_view = mk_refl_data_lid_as_term "sigelt_view" +let fstar_refl_sigelt_view_fv = mk_refl_data_lid_as_fv "sigelt_view" +let fstar_refl_qualifier = mk_refl_data_lid_as_term "qualifier" +let fstar_refl_qualifier_fv = mk_refl_data_lid_as_fv "qualifier" +let fstar_refl_universe_view = mk_refl_data_lid_as_term "universe_view" +let fstar_refl_universe_view_fv = mk_refl_data_lid_as_fv "universe_view" + +(* bv_view, this is a record constructor *) + +let ref_Mk_bv = + let lid = fstar_refl_data_lid "Mkbv_view" in + let attr = Record_ctor (fstar_refl_data_lid "bv_view", [ + Ident.mk_ident ("bv_ppname", Range.dummyRange); + Ident.mk_ident ("bv_index" , Range.dummyRange)]) in + let fv = lid_as_fv lid (Some attr) in + { lid = lid + ; fv = fv + ; t = fv_to_tm fv + } + +let ref_Mk_binder = + let lid = fstar_refl_data_lid "Mkbinder_view" in + let attr = Record_ctor (fstar_refl_data_lid "binder_view", [ + Ident.mk_ident ("binder_bv", Range.dummyRange); + Ident.mk_ident ("binder_qual", Range.dummyRange); + Ident.mk_ident ("binder_attrs", Range.dummyRange); + Ident.mk_ident ("binder_sort" , Range.dummyRange)]) in + let fv = lid_as_fv lid (Some attr) in + { lid = lid; + fv = fv; + t = fv_to_tm fv } + +let ref_Mk_lb = + let lid = fstar_refl_data_lid "Mklb_view" in + let attr = Record_ctor (fstar_refl_data_lid "lb_view", [ + Ident.mk_ident ("lb_fv" , Range.dummyRange); + Ident.mk_ident ("lb_us" , Range.dummyRange); + Ident.mk_ident ("lb_typ" , Range.dummyRange); + Ident.mk_ident ("lb_def" , Range.dummyRange) + ]) in + let fv = lid_as_fv lid (Some attr) in + { lid = lid + ; fv = fv + ; t = fv_to_tm fv + } + +(* quals *) +let ref_Q_Explicit = fstar_refl_data_const "Q_Explicit" +let ref_Q_Implicit = fstar_refl_data_const "Q_Implicit" +let ref_Q_Meta = fstar_refl_data_const "Q_Meta" + +(* const *) +let ref_C_Unit = fstar_refl_data_const "C_Unit" +let ref_C_True = fstar_refl_data_const "C_True" +let ref_C_False = fstar_refl_data_const "C_False" +let ref_C_Int = fstar_refl_data_const "C_Int" +let ref_C_String = fstar_refl_data_const "C_String" +let ref_C_Range = fstar_refl_data_const "C_Range" +let ref_C_Reify = fstar_refl_data_const "C_Reify" +let ref_C_Reflect = fstar_refl_data_const "C_Reflect" + +(* pattern *) +let ref_Pat_Constant = fstar_refl_data_const "Pat_Constant" +let ref_Pat_Cons = fstar_refl_data_const "Pat_Cons" +let ref_Pat_Var = fstar_refl_data_const "Pat_Var" +let ref_Pat_Dot_Term = fstar_refl_data_const "Pat_Dot_Term" + +(* universe_view *) +let ref_Uv_Zero = fstar_refl_data_const "Uv_Zero" +let ref_Uv_Succ = fstar_refl_data_const "Uv_Succ" +let ref_Uv_Max = fstar_refl_data_const "Uv_Max" +let ref_Uv_BVar = fstar_refl_data_const "Uv_BVar" +let ref_Uv_Name = fstar_refl_data_const "Uv_Name" +let ref_Uv_Unif = fstar_refl_data_const "Uv_Unif" +let ref_Uv_Unk = fstar_refl_data_const "Uv_Unk" + +(* term_view *) +let ref_Tv_Var = fstar_refl_data_const "Tv_Var" +let ref_Tv_BVar = fstar_refl_data_const "Tv_BVar" +let ref_Tv_FVar = fstar_refl_data_const "Tv_FVar" +let ref_Tv_UInst = fstar_refl_data_const "Tv_UInst" +let ref_Tv_App = fstar_refl_data_const "Tv_App" +let ref_Tv_Abs = fstar_refl_data_const "Tv_Abs" +let ref_Tv_Arrow = fstar_refl_data_const "Tv_Arrow" +let ref_Tv_Type = fstar_refl_data_const "Tv_Type" +let ref_Tv_Refine = fstar_refl_data_const "Tv_Refine" +let ref_Tv_Const = fstar_refl_data_const "Tv_Const" +let ref_Tv_Uvar = fstar_refl_data_const "Tv_Uvar" +let ref_Tv_Let = fstar_refl_data_const "Tv_Let" +let ref_Tv_Match = fstar_refl_data_const "Tv_Match" +let ref_Tv_AscT = fstar_refl_data_const "Tv_AscribedT" +let ref_Tv_AscC = fstar_refl_data_const "Tv_AscribedC" +let ref_Tv_Unknown = fstar_refl_data_const "Tv_Unknown" +let ref_Tv_Unsupp = fstar_refl_data_const "Tv_Unsupp" + +(* comp_view *) +let ref_C_Total = fstar_refl_data_const "C_Total" +let ref_C_GTotal = fstar_refl_data_const "C_GTotal" +let ref_C_Lemma = fstar_refl_data_const "C_Lemma" +let ref_C_Eff = fstar_refl_data_const "C_Eff" + +(* inductives & sigelts *) +let ref_Sg_Let = fstar_refl_data_const "Sg_Let" +let ref_Sg_Inductive = fstar_refl_data_const "Sg_Inductive" +let ref_Sg_Val = fstar_refl_data_const "Sg_Val" +let ref_Unk = fstar_refl_data_const "Unk" + +(* qualifiers *) +let ref_qual_Assumption = fstar_refl_data_const "Assumption" +let ref_qual_InternalAssumption = fstar_refl_data_const "InternalAssumption" +let ref_qual_New = fstar_refl_data_const "New" +let ref_qual_Private = fstar_refl_data_const "Private" +let ref_qual_Unfold_for_unification_and_vcgen = fstar_refl_data_const "Unfold_for_unification_and_vcgen" +let ref_qual_Visible_default = fstar_refl_data_const "Visible_default" +let ref_qual_Irreducible = fstar_refl_data_const "Irreducible" +let ref_qual_Inline_for_extraction = fstar_refl_data_const "Inline_for_extraction" +let ref_qual_NoExtract = fstar_refl_data_const "NoExtract" +let ref_qual_Noeq = fstar_refl_data_const "Noeq" +let ref_qual_Unopteq = fstar_refl_data_const "Unopteq" +let ref_qual_TotalEffect = fstar_refl_data_const "TotalEffect" +let ref_qual_Logic = fstar_refl_data_const "Logic" +let ref_qual_Reifiable = fstar_refl_data_const "Reifiable" +let ref_qual_Reflectable = fstar_refl_data_const "Reflectable" +let ref_qual_Discriminator = fstar_refl_data_const "Discriminator" +let ref_qual_Projector = fstar_refl_data_const "Projector" +let ref_qual_RecordType = fstar_refl_data_const "RecordType" +let ref_qual_RecordConstructor = fstar_refl_data_const "RecordConstructor" +let ref_qual_Action = fstar_refl_data_const "Action" +let ref_qual_ExceptionConstructor = fstar_refl_data_const "ExceptionConstructor" +let ref_qual_HasMaskedEffect = fstar_refl_data_const "HasMaskedEffect" +let ref_qual_Effect = fstar_refl_data_const "Effect" +let ref_qual_OnlyName = fstar_refl_data_const "OnlyName" diff --git a/src/reflection/FStarC.Reflection.V1.Data.fst b/src/reflection/FStarC.Reflection.V1.Data.fst new file mode 100644 index 00000000000..1a4f217cd32 --- /dev/null +++ b/src/reflection/FStarC.Reflection.V1.Data.fst @@ -0,0 +1,44 @@ +(* + Copyright 2008-2022 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Reflection.V1.Data + +(* NOTE: This file is exactly the same as its .fs/.fsi counterpart. +It is only here so the equally-named interface file in ulib/ is not +taken by the dependency analysis to be the interface of the .fs. We also +cannot ditch the .fs, since out bootstrapping process does not extract +any .ml file from an interface. Hence we keep both, exactly equal to +each other. *) +open FStarC.Compiler.List +open FStarC.Syntax.Syntax +module Ident = FStarC.Ident +module Range = FStarC.Compiler.Range +module Z = FStarC.BigInt +open FStarC.Ident + +(* These two functions are in ulib/FStarC.Reflection.V1.Data.fsti + But, they are not extracted from there. + + Instead, these functions are extraction from this file. It is + not sufficient to place these functions in the interface + src/reflection/FStarC.Reflection.V1.Data.fsti since this module, like the + rest of the compiler, is extracted in MLish mode. Which means that + functions in the interface are not supported for extraction. So, + we include them in this module implementation file to force them + to be extracted *) +let as_ppname (x:string) : Tot ppname_t = FStarC.Compiler.Sealed.seal x + +let notAscription (tv:term_view) : Tot bool = + not (Tv_AscribedT? tv) && not (Tv_AscribedC? tv) diff --git a/src/reflection/FStarC.Reflection.V1.Data.fsti b/src/reflection/FStarC.Reflection.V1.Data.fsti new file mode 100644 index 00000000000..2d1e198bf8f --- /dev/null +++ b/src/reflection/FStarC.Reflection.V1.Data.fsti @@ -0,0 +1,172 @@ +(* + Copyright 2008-2022 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Reflection.V1.Data + +(* NOTE: This file is exactly the same as its .fs/.fsi counterpart. +It is only here so the equally-named interface file in ulib/ is not +taken by the dependency analysis to be the interface of the .fs. We also +cannot ditch the .fs, since out bootstrapping process does not extract +any .ml file from an interface. Hence we keep both, exactly equal to +each other. *) +open FStarC.Compiler.List +open FStarC.Syntax.Syntax +open FStarC.Compiler.Sealed +module Ident = FStarC.Ident +module Range = FStarC.Compiler.Range +module Z = FStarC.BigInt +open FStarC.Ident + +type name = list string +type typ = term +type binders = list binder +type ident = string & Range.range +type univ_name = ident + +type vconst = + | C_Unit + | C_Int of Z.t + | C_True + | C_False + | C_String of string + | C_Range of Range.range + | C_Reify + | C_Reflect of name + +type universes = list universe + +type pattern = + | Pat_Constant of vconst + | Pat_Cons of fv & option (list universe) & list (pattern & bool) + | Pat_Var of bv & sealed typ + | Pat_Dot_Term of option term + +type branch = pattern & term + +type aqualv = + | Q_Implicit + | Q_Explicit + | Q_Meta of term + +type argv = term & aqualv + +type ppname_t = sealed string +val as_ppname (s:string) : Tot ppname_t + +type bv_view = { + bv_ppname : ppname_t; + bv_index : Z.t; +} + +type binder_view = { + binder_bv : bv; + binder_qual : aqualv; + binder_attrs : list term; + binder_sort : typ; +} + +type universe_view = + | Uv_Zero : universe_view + | Uv_Succ : universe -> universe_view + | Uv_Max : universes -> universe_view + | Uv_BVar : Z.t -> universe_view + | Uv_Name : (string & Range.range) -> universe_view + | Uv_Unif : universe_uvar -> universe_view + | Uv_Unk : universe_view + +type term_view = + | Tv_Var of bv + | Tv_BVar of bv + | Tv_FVar of fv + | Tv_UInst of fv & universes + | Tv_App of term & argv + | Tv_Abs of binder & term + | Tv_Arrow of binder & comp + | Tv_Type of universe + | Tv_Refine of bv & typ & term + | Tv_Const of vconst + | Tv_Uvar of Z.t & ctx_uvar_and_subst + | Tv_Let of bool & list term & bv & typ & term & term + | Tv_Match of term & option match_returns_ascription & list branch + | Tv_AscribedT of term & term & option term & bool //if the boolean flag is true, the ascription is an equality ascription + //see also Syntax + | Tv_AscribedC of term & comp & option term & bool //bool is similar to Tv_AscribedT + | Tv_Unknown + | Tv_Unsupp + +val notAscription (t:term_view) : Tot bool + +type comp_view = + | C_Total of typ + | C_GTotal of typ + | C_Lemma of term & term & term + | C_Eff of universes & name & term & list argv & list term // list term is the decreases clause + +type ctor = name & typ + +type lb_view = { + lb_fv : fv; + lb_us : list univ_name; + lb_typ : typ; + lb_def : term +} + +type sigelt_view = + | Sg_Let of bool & list letbinding + // The bool indicates if it's a let rec + // Non-empty list of (possibly) mutually recursive let-bindings + | Sg_Inductive of name & list univ_name & list binder & typ & list ctor // name, params, type, constructors + | Sg_Val of name & list univ_name & typ + | Unk + + +(* This is a mirror of FStarC.Syntax.Syntax.qualifier *) +type qualifier = + | Assumption + | InternalAssumption + | New + | Private + | Unfold_for_unification_and_vcgen + | Visible_default + | Irreducible + | Inline_for_extraction + | NoExtract + | Noeq + | Unopteq + | TotalEffect + | Logic + | Reifiable + | Reflectable of name + | Discriminator of name + | Projector of name & ident + | RecordType of (list ident & list ident) + | RecordConstructor of (list ident & list ident) + | Action of name + | ExceptionConstructor + | HasMaskedEffect + | Effect + | OnlyName + +type qualifiers = list qualifier + +type var = Z.t + +type exp = + | Unit + | Var of var + | Mult of exp & exp + +(* Needed so this appears in the ocaml output for the fstar tactics library *) +type decls = list sigelt diff --git a/src/reflection/FStarC.Reflection.V1.Embeddings.fst b/src/reflection/FStarC.Reflection.V1.Embeddings.fst new file mode 100644 index 00000000000..98457abad39 --- /dev/null +++ b/src/reflection/FStarC.Reflection.V1.Embeddings.fst @@ -0,0 +1,920 @@ +(* + Copyright 2008-2022 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Reflection.V1.Embeddings + +open FStarC.Compiler.Effect +open FStarC.Reflection.V1.Data +open FStarC.Syntax.Syntax +open FStarC.Syntax.Embeddings +open FStar.Order +open FStarC.Errors + +module BU = FStarC.Compiler.Util +module EMB = FStarC.Syntax.Embeddings +module Env = FStarC.TypeChecker.Env +module Err = FStarC.Errors +module I = FStarC.Ident +module List = FStarC.Compiler.List +module NBETerm = FStarC.TypeChecker.NBETerm +module O = FStarC.Options +module PC = FStarC.Parser.Const +module Print = FStarC.Syntax.Print +module Range = FStarC.Compiler.Range +module RD = FStarC.Reflection.V1.Data +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module U = FStarC.Syntax.Util +module Z = FStarC.BigInt + +module EmbV2 = FStarC.Reflection.V2.Embeddings + +open FStarC.Dyn +open FStarC.Reflection.V1.Builtins //needed for inspect_fv, but that feels wrong +open FStarC.Reflection.V1.Constants + +(* + * embed : from compiler to user + * unembed : from user to compiler + *) + +let noaqs : antiquotations = (0, []) + +(* -------------------------------------------------------------------------------------- *) +(* ------------------------------------- EMBEDDINGS ------------------------------------- *) +(* -------------------------------------------------------------------------------------- *) +let mk_emb f g t = + mk_emb (fun x r _topt _norm -> f r x) + (fun x _norm -> g x) + (EMB.term_as_fv t) +let embed {|embedding 'a|} r (x:'a) = embed x r None id_norm_cb +let unembed {|embedding 'a|} x : option 'a = try_unembed x id_norm_cb + +(* Abstract, reexport *) +let e_bv = EmbV2.e_bv +let e_binder = EmbV2.e_binder +let e_term_aq = EmbV2.e_term_aq +let e_term = EmbV2.e_term +let e_binders = EmbV2.e_binders +let e_fv = EmbV2.e_fv +let e_comp = EmbV2.e_comp +let e_universe = EmbV2.e_universe + +instance e_aqualv = + let embed_aqualv (rng:Range.range) (q : aqualv) : term = + let r = + match q with + | Data.Q_Explicit -> ref_Q_Explicit.t + | Data.Q_Implicit -> ref_Q_Implicit.t + | Data.Q_Meta t -> + S.mk_Tm_app ref_Q_Meta.t [S.as_arg (embed #_ #e_term rng t)] + Range.dummyRange + in { r with pos = rng } + in + let unembed_aqualv (t : term) : option aqualv = + let t = U.unascribe t in + let hd, args = U.head_and_args t in + match (U.un_uinst hd).n, args with + | Tm_fvar fv, [] when S.fv_eq_lid fv ref_Q_Explicit.lid -> Some Data.Q_Explicit + | Tm_fvar fv, [] when S.fv_eq_lid fv ref_Q_Implicit.lid -> Some Data.Q_Implicit + | Tm_fvar fv, [(t, _)] when S.fv_eq_lid fv ref_Q_Meta.lid -> + BU.bind_opt (unembed #_ #e_term t) (fun t -> + Some (Data.Q_Meta t)) + + | _ -> + None + in + mk_emb embed_aqualv unembed_aqualv fstar_refl_aqualv + +instance e_ident : embedding RD.ident = + e_tuple2 e_string e_range + +instance e_universe_view = + let embed_universe_view (rng:Range.range) (uv:universe_view) : term = + match uv with + | Uv_Zero -> ref_Uv_Zero.t + | Uv_Succ u -> + S.mk_Tm_app + ref_Uv_Succ.t + [S.as_arg (embed rng u)] + rng + | Uv_Max us -> + S.mk_Tm_app + ref_Uv_Max.t + [S.as_arg (embed rng us)] + rng + | Uv_BVar n -> + S.mk_Tm_app + ref_Uv_BVar.t + [S.as_arg (embed rng n)] + rng + | Uv_Name i -> + S.mk_Tm_app + ref_Uv_Name.t + [S.as_arg (embed rng i)] + rng + | Uv_Unif u -> + S.mk_Tm_app + ref_Uv_Unif.t + [S.as_arg (U.mk_lazy u U.t_universe_uvar Lazy_universe_uvar None)] + rng + | Uv_Unk -> + ref_Uv_Unk.t in + + let unembed_universe_view (t:term) : option universe_view = + let t = U.unascribe t in + let hd, args = U.head_and_args t in + match (U.un_uinst hd).n, args with + | Tm_fvar fv, [] when S.fv_eq_lid fv ref_Uv_Zero.lid -> Some Uv_Zero + | Tm_fvar fv, [u, _] when S.fv_eq_lid fv ref_Uv_Succ.lid -> + BU.bind_opt (unembed u) (fun u -> u |> Uv_Succ |> Some) + | Tm_fvar fv, [us, _] when S.fv_eq_lid fv ref_Uv_Max.lid -> + BU.bind_opt (unembed us) (fun us -> us |> Uv_Max |> Some) + | Tm_fvar fv, [n, _] when S.fv_eq_lid fv ref_Uv_BVar.lid -> + BU.bind_opt (unembed n) (fun n -> n |> Uv_BVar |> Some) + | Tm_fvar fv, [i, _] when S.fv_eq_lid fv ref_Uv_Name.lid -> + BU.bind_opt (unembed i) (fun i -> i |> Uv_Name |> Some) + | Tm_fvar fv, [u, _] when S.fv_eq_lid fv ref_Uv_Unif.lid -> + let u : universe_uvar = U.unlazy_as_t Lazy_universe_uvar u in + u |> Uv_Unif |> Some + | Tm_fvar fv, [] when S.fv_eq_lid fv ref_Uv_Unk.lid -> Some Uv_Unk + | _ -> + None in + + mk_emb embed_universe_view unembed_universe_view fstar_refl_universe_view + +let e_env = + let embed_env (rng:Range.range) (e:Env.env) : term = + U.mk_lazy e fstar_refl_env Lazy_env (Some rng) + in + let unembed_env (t:term) : option Env.env = + match (SS.compress t).n with + | Tm_lazy {blob=b; lkind=Lazy_env} -> + Some (undyn b) + | _ -> + None + in + mk_emb embed_env unembed_env fstar_refl_env + +instance e_const = + let embed_const (rng:Range.range) (c:vconst) : term = + let r = + match c with + | C_Unit -> ref_C_Unit.t + | C_True -> ref_C_True.t + | C_False -> ref_C_False.t + + | C_Int i -> + S.mk_Tm_app ref_C_Int.t [S.as_arg (U.exp_int (Z.string_of_big_int i))] + Range.dummyRange + | C_String s -> + S.mk_Tm_app ref_C_String.t [S.as_arg (embed rng s)] + Range.dummyRange + + | C_Range r -> + S.mk_Tm_app ref_C_Range.t [S.as_arg (embed rng r)] + Range.dummyRange + + | C_Reify -> ref_C_Reify.t + + | C_Reflect ns -> + S.mk_Tm_app ref_C_Reflect.t [S.as_arg (embed rng ns)] + Range.dummyRange + + in { r with pos = rng } + in + let unembed_const (t:term) : option vconst = + let t = U.unascribe t in + let hd, args = U.head_and_args t in + match (U.un_uinst hd).n, args with + | Tm_fvar fv, [] when S.fv_eq_lid fv ref_C_Unit.lid -> + Some C_Unit + + | Tm_fvar fv, [] when S.fv_eq_lid fv ref_C_True.lid -> + Some C_True + + | Tm_fvar fv, [] when S.fv_eq_lid fv ref_C_False.lid -> + Some C_False + + | Tm_fvar fv, [(i, _)] when S.fv_eq_lid fv ref_C_Int.lid -> + BU.bind_opt (unembed i) (fun i -> + Some <| C_Int i) + + | Tm_fvar fv, [(s, _)] when S.fv_eq_lid fv ref_C_String.lid -> + BU.bind_opt (unembed s) (fun s -> + Some <| C_String s) + + | Tm_fvar fv, [(r, _)] when S.fv_eq_lid fv ref_C_Range.lid -> + BU.bind_opt (unembed r) (fun r -> + Some <| C_Range r) + + | Tm_fvar fv, [] when S.fv_eq_lid fv ref_C_Reify.lid -> + Some <| C_Reify + + | Tm_fvar fv, [(ns, _)] when S.fv_eq_lid fv ref_C_Reflect.lid -> + BU.bind_opt (unembed ns) (fun ns -> + Some <| C_Reflect ns) + + | _ -> + None + in + mk_emb embed_const unembed_const fstar_refl_vconst + +let rec e_pattern_aq aq = + let rec embed_pattern (rng:Range.range) (p : pattern) : term = + match p with + | Pat_Constant c -> + S.mk_Tm_app ref_Pat_Constant.t [S.as_arg (embed rng c)] rng + | Pat_Cons (fv, us_opt, ps) -> + S.mk_Tm_app ref_Pat_Cons.t + [S.as_arg (embed rng fv); + S.as_arg (embed rng us_opt); + S.as_arg (embed #_ #(e_list (e_tuple2 (e_pattern_aq aq) e_bool)) rng ps)] rng + | Pat_Var (bv, sort) -> + S.mk_Tm_app ref_Pat_Var.t [S.as_arg (embed #_ #e_bv rng bv); S.as_arg (embed #_ #(e_sealed e_term) rng sort)] rng + | Pat_Dot_Term eopt -> + S.mk_Tm_app ref_Pat_Dot_Term.t [S.as_arg (embed #_ #(e_option e_term) rng eopt)] + rng + in + let rec unembed_pattern (t : term) : option pattern = + let t = U.unascribe t in + let hd, args = U.head_and_args t in + match (U.un_uinst hd).n, args with + | Tm_fvar fv, [(c, _)] when S.fv_eq_lid fv ref_Pat_Constant.lid -> + BU.bind_opt (unembed c) (fun c -> + Some <| Pat_Constant c) + + | Tm_fvar fv, [(f, _); (us_opt, _); (ps, _)] when S.fv_eq_lid fv ref_Pat_Cons.lid -> + BU.bind_opt (unembed f) (fun f -> + BU.bind_opt (unembed us_opt) (fun us_opt -> + BU.bind_opt (unembed #_ #(e_list (e_tuple2 (e_pattern_aq aq) e_bool)) ps) (fun ps -> + Some <| Pat_Cons (f, us_opt, ps)))) + + | Tm_fvar fv, [(bv, _); (sort, _)] when S.fv_eq_lid fv ref_Pat_Var.lid -> + BU.bind_opt (unembed #_ #e_bv bv) (fun bv -> + BU.bind_opt (unembed #_ #(e_sealed e_term) sort) (fun sort -> + Some <| Pat_Var (bv, sort))) + + | Tm_fvar fv, [(eopt, _)] when S.fv_eq_lid fv ref_Pat_Dot_Term.lid -> + BU.bind_opt (unembed #_ #(e_option e_term) eopt) (fun eopt -> + Some <| Pat_Dot_Term eopt) + + | _ -> + None + in + mk_emb embed_pattern unembed_pattern fstar_refl_pattern + +let e_pattern = e_pattern_aq noaqs + +let e_branch = e_tuple2 e_pattern e_term +let e_argv = e_tuple2 e_term e_aqualv + +let e_args = e_list e_argv + +let e_branch_aq aq = e_tuple2 (e_pattern_aq aq) (e_term_aq aq) +let e_argv_aq aq = e_tuple2 (e_term_aq aq) e_aqualv + +let e_match_returns_annotation = + e_option (e_tuple2 e_binder + (e_tuple3 (e_either e_term e_comp) (e_option e_term) e_bool)) + +let e_term_view_aq aq = + let push (s, aq) = (s+1, aq) in + let embed_term_view (rng:Range.range) (t:term_view) : term = + match t with + | Tv_FVar fv -> + S.mk_Tm_app ref_Tv_FVar.t [S.as_arg (embed rng fv)] + rng + + | Tv_BVar fv -> + S.mk_Tm_app ref_Tv_BVar.t [S.as_arg (embed #_ #e_bv rng fv)] + rng + + | Tv_Var bv -> + S.mk_Tm_app ref_Tv_Var.t [S.as_arg (embed #_ #e_bv rng bv)] + rng + + | Tv_UInst (fv, us) -> + S.mk_Tm_app + ref_Tv_UInst.t + [S.as_arg (embed rng fv); + S.as_arg (embed rng us)] + rng + + | Tv_App (hd, a) -> + S.mk_Tm_app ref_Tv_App.t [S.as_arg (embed #_ #(e_term_aq aq) rng hd); S.as_arg (embed #_ #(e_argv_aq aq) rng a)] + rng + + | Tv_Abs (b, t) -> + S.mk_Tm_app ref_Tv_Abs.t [S.as_arg (embed rng b); S.as_arg (embed #_ #(e_term_aq (push aq)) rng t)] + rng + + | Tv_Arrow (b, c) -> + S.mk_Tm_app ref_Tv_Arrow.t [S.as_arg (embed rng b); S.as_arg (embed rng c)] + rng + + | Tv_Type u -> + S.mk_Tm_app ref_Tv_Type.t [S.as_arg (embed rng u)] + rng + + | Tv_Refine (bv, s, t) -> + S.mk_Tm_app ref_Tv_Refine.t [S.as_arg (embed #_ #e_bv rng bv); + S.as_arg (embed #_ #(e_term_aq aq) rng s); + S.as_arg (embed #_ #(e_term_aq (push aq)) rng t)] + rng + + | Tv_Const c -> + S.mk_Tm_app ref_Tv_Const.t [S.as_arg (embed rng c)] + rng + + | Tv_Uvar (u, d) -> + S.mk_Tm_app ref_Tv_Uvar.t + [S.as_arg (embed rng u); + S.as_arg (U.mk_lazy (u,d) U.t_ctx_uvar_and_sust Lazy_uvar None)] + rng + + | Tv_Let (r, attrs, b, ty, t1, t2) -> + S.mk_Tm_app ref_Tv_Let.t [S.as_arg (embed rng r); + S.as_arg (embed #_ #(e_list e_term) rng attrs); + S.as_arg (embed #_ #e_bv rng b); + S.as_arg (embed #_ #(e_term_aq aq) rng ty); + S.as_arg (embed #_ #(e_term_aq aq) rng t1); + S.as_arg (embed #_ #(e_term_aq (push aq)) rng t2)] + rng + + | Tv_Match (t, ret_opt, brs) -> + S.mk_Tm_app ref_Tv_Match.t [S.as_arg (embed #_ #(e_term_aq aq) rng t); + S.as_arg (embed #_ #e_match_returns_annotation rng ret_opt); + S.as_arg (embed #_ #(e_list (e_branch_aq aq)) rng brs)] + rng + + | Tv_AscribedT (e, t, tacopt, use_eq) -> + S.mk_Tm_app ref_Tv_AscT.t + [S.as_arg (embed #_ #(e_term_aq aq) rng e); + S.as_arg (embed #_ #(e_term_aq aq) rng t); + S.as_arg (embed #_ #(e_option (e_term_aq aq)) rng tacopt); + S.as_arg (embed rng use_eq)] + rng + + | Tv_AscribedC (e, c, tacopt, use_eq) -> + S.mk_Tm_app ref_Tv_AscC.t + [S.as_arg (embed #_ #(e_term_aq aq) rng e); + S.as_arg (embed rng c); + S.as_arg (embed #_ #(e_option (e_term_aq aq)) rng tacopt); + S.as_arg (embed rng use_eq)] + rng + + | Tv_Unknown -> + { ref_Tv_Unknown.t with pos = rng } + + | Tv_Unsupp -> + { ref_Tv_Unsupp.t with pos = rng } + in + let unembed_term_view (t:term) : option term_view = + let hd, args = U.head_and_args t in + match (U.un_uinst hd).n, args with + | Tm_fvar fv, [(b, _)] when S.fv_eq_lid fv ref_Tv_Var.lid -> + BU.bind_opt (unembed #_ #e_bv b) (fun b -> + Some <| Tv_Var b) + + | Tm_fvar fv, [(b, _)] when S.fv_eq_lid fv ref_Tv_BVar.lid -> + BU.bind_opt (unembed #_ #e_bv b) (fun b -> + Some <| Tv_BVar b) + + | Tm_fvar fv, [(f, _)] when S.fv_eq_lid fv ref_Tv_FVar.lid -> + BU.bind_opt (unembed f) (fun f -> + Some <| Tv_FVar f) + + | Tm_fvar fv, [(f, _); (us, _)] + when S.fv_eq_lid fv ref_Tv_UInst.lid -> + BU.bind_opt (unembed f) (fun f -> + BU.bind_opt (unembed us) (fun us -> + Some <| Tv_UInst (f, us))) + + | Tm_fvar fv, [(l, _); (r, _)] when S.fv_eq_lid fv ref_Tv_App.lid -> + BU.bind_opt (unembed #_ #e_term l) (fun l -> + BU.bind_opt (unembed #_ #e_argv r) (fun r -> + Some <| Tv_App (l, r))) + + | Tm_fvar fv, [(b, _); (t, _)] when S.fv_eq_lid fv ref_Tv_Abs.lid -> + BU.bind_opt (unembed b) (fun b -> + BU.bind_opt (unembed #_ #e_term t) (fun t -> + Some <| Tv_Abs (b, t))) + + | Tm_fvar fv, [(b, _); (t, _)] when S.fv_eq_lid fv ref_Tv_Arrow.lid -> + BU.bind_opt (unembed b) (fun b -> + BU.bind_opt (unembed t) (fun c -> + Some <| Tv_Arrow (b, c))) + + | Tm_fvar fv, [(u, _)] when S.fv_eq_lid fv ref_Tv_Type.lid -> + BU.bind_opt (unembed u) (fun u -> + Some <| Tv_Type u) + + | Tm_fvar fv, [(b, _); (sort, _); (t, _)] when S.fv_eq_lid fv ref_Tv_Refine.lid -> + BU.bind_opt (unembed #_ #e_bv b) (fun b -> + BU.bind_opt (unembed #_ #e_term sort) (fun sort -> + BU.bind_opt (unembed #_ #e_term t) (fun t -> + Some <| Tv_Refine (b, sort, t)))) + + | Tm_fvar fv, [(c, _)] when S.fv_eq_lid fv ref_Tv_Const.lid -> + BU.bind_opt (unembed c) (fun c -> + Some <| Tv_Const c) + + | Tm_fvar fv, [(u, _); (l, _)] when S.fv_eq_lid fv ref_Tv_Uvar.lid -> + BU.bind_opt (unembed u) (fun u -> + let ctx_u_s : ctx_uvar_and_subst = U.unlazy_as_t Lazy_uvar l in + Some <| Tv_Uvar (u, ctx_u_s)) + + | Tm_fvar fv, [(r, _); (attrs, _); (b, _); (ty, _); (t1, _); (t2, _)] when S.fv_eq_lid fv ref_Tv_Let.lid -> + BU.bind_opt (unembed r) (fun r -> + BU.bind_opt (unembed #_ #(e_list e_term) attrs) (fun attrs -> + BU.bind_opt (unembed #_ #e_bv b) (fun b -> + BU.bind_opt (unembed #_ #e_term ty) (fun ty-> + BU.bind_opt (unembed #_ #e_term t1) (fun t1 -> + BU.bind_opt (unembed #_ #e_term t2) (fun t2 -> + Some <| Tv_Let (r, attrs, b, ty, t1, t2))))))) + + | Tm_fvar fv, [(t, _); (ret_opt, _); (brs, _)] when S.fv_eq_lid fv ref_Tv_Match.lid -> + BU.bind_opt (unembed #_ #e_term t) (fun t -> + BU.bind_opt (unembed #_ #e_match_returns_annotation ret_opt) (fun ret_opt -> + BU.bind_opt (unembed #_ #(e_list e_branch) brs) (fun brs -> + Some <| Tv_Match (t, ret_opt, brs)))) + + | Tm_fvar fv, [(e, _); (t, _); (tacopt, _); (use_eq, _)] when S.fv_eq_lid fv ref_Tv_AscT.lid -> + BU.bind_opt (unembed #_ #e_term e) (fun e -> + BU.bind_opt (unembed #_ #e_term t) (fun t -> + BU.bind_opt (unembed #_ #(e_option e_term) tacopt) (fun tacopt -> + BU.bind_opt (unembed use_eq) (fun use_eq -> + Some <| Tv_AscribedT (e, t, tacopt, use_eq))))) + + | Tm_fvar fv, [(e, _); (c, _); (tacopt, _); (use_eq, _)] when S.fv_eq_lid fv ref_Tv_AscC.lid -> + BU.bind_opt (unembed #_ #e_term e) (fun e -> + BU.bind_opt (unembed #_ #e_comp c) (fun c -> + BU.bind_opt (unembed #_ #(e_option e_term) tacopt) (fun tacopt -> + BU.bind_opt (unembed use_eq) (fun use_eq -> + Some <| Tv_AscribedC (e, c, tacopt, use_eq))))) + + | Tm_fvar fv, [] when S.fv_eq_lid fv ref_Tv_Unknown.lid -> + Some <| Tv_Unknown + + | Tm_fvar fv, [] when S.fv_eq_lid fv ref_Tv_Unsupp.lid -> + Some <| Tv_Unsupp + + | _ -> + None + in + mk_emb embed_term_view unembed_term_view fstar_refl_term_view + +let e_term_view = e_term_view_aq noaqs + +(* embeds as a string list *) +// instance e_lid : embedding I.lid = +// let embed rng lid : term = +// embed rng (I.path_of_lid lid) +// in +// let unembed t : option I.lid = +// BU.map_opt (unembed t) (fun p -> I.lid_of_path p t.pos) +// in +// EMB.mk_emb_full (fun x r _ _ -> embed r x) +// (fun x _ -> unembed x) +// (fun () -> t_list_of t_string) +// I.string_of_lid +// (fun () -> ET_abstract) + +let e_name = e_list e_string + +instance e_bv_view = + let embed_bv_view (rng:Range.range) (bvv:bv_view) : term = + S.mk_Tm_app ref_Mk_bv.t [S.as_arg (embed #_ #(e_sealed e_string) rng bvv.bv_ppname); + S.as_arg (embed rng bvv.bv_index)] + rng + in + let unembed_bv_view (t : term) : option bv_view = + let t = U.unascribe t in + let hd, args = U.head_and_args t in + match (U.un_uinst hd).n, args with + | Tm_fvar fv, [(nm, _); (idx, _)] when S.fv_eq_lid fv ref_Mk_bv.lid -> + BU.bind_opt (unembed #_ #(e_sealed e_string) nm) (fun nm -> + BU.bind_opt (unembed idx) (fun idx -> + Some <| { bv_ppname = nm ; bv_index = idx })) + + | _ -> + None + in + mk_emb embed_bv_view unembed_bv_view fstar_refl_bv_view + + +let e_attribute = e_term +let e_attributes = e_list e_attribute + +instance e_binder_view = + let embed_binder_view (rng:Range.range) (bview:binder_view) : term = + S.mk_Tm_app ref_Mk_binder.t [S.as_arg (embed #_ #e_bv rng bview.binder_bv); + S.as_arg (embed rng bview.binder_qual); + S.as_arg (embed #_ #e_attributes rng bview.binder_attrs); + S.as_arg (embed #_ #e_term rng bview.binder_sort)] + rng in + + let unembed_binder_view (t:term) : option binder_view = + let t = U.unascribe t in + let hd, args = U.head_and_args t in + match (U.un_uinst hd).n, args with + | Tm_fvar fv, [(bv, _); (q, _); (attrs, _); (sort, _)] + when S.fv_eq_lid fv ref_Mk_binder.lid -> + BU.bind_opt (unembed #_ #e_bv bv) (fun bv -> + BU.bind_opt (unembed q) (fun q -> + BU.bind_opt (unembed #_ #e_attributes attrs) (fun attrs -> + BU.bind_opt (unembed #_ #e_term sort) (fun sort -> + Some <| RD.({ binder_bv=bv;binder_qual=q; binder_attrs=attrs; binder_sort = sort}))))) + + | _ -> + None in + + mk_emb embed_binder_view unembed_binder_view fstar_refl_binder_view + +instance e_comp_view = + let embed_comp_view (rng:Range.range) (cv : comp_view) : term = + match cv with + | C_Total t -> + S.mk_Tm_app ref_C_Total.t [S.as_arg (embed #_ #e_term rng t)] + rng + + | C_GTotal t -> + S.mk_Tm_app ref_C_GTotal.t [S.as_arg (embed #_ #e_term rng t)] + rng + + | C_Lemma (pre, post, pats) -> + S.mk_Tm_app ref_C_Lemma.t [S.as_arg (embed #_ #e_term rng pre); + S.as_arg (embed #_ #e_term rng post); + S.as_arg (embed #_ #e_term rng pats)] + rng + + | C_Eff (us, eff, res, args, decrs) -> + S.mk_Tm_app ref_C_Eff.t + [ S.as_arg (embed rng us) + ; S.as_arg (embed rng eff) + ; S.as_arg (embed #_ #e_term rng res) + ; S.as_arg (embed #_ #(e_list e_argv) rng args) + ; S.as_arg (embed #_ #(e_list e_term) rng decrs)] rng + + + in + let unembed_comp_view (t : term) : option comp_view = + let t = U.unascribe t in + let hd, args = U.head_and_args t in + match (U.un_uinst hd).n, args with + | Tm_fvar fv, [(t, _)] + when S.fv_eq_lid fv ref_C_Total.lid -> + BU.bind_opt (unembed #_ #e_term t) (fun t -> + Some <| C_Total t) + + | Tm_fvar fv, [(t, _)] + when S.fv_eq_lid fv ref_C_GTotal.lid -> + BU.bind_opt (unembed #_ #e_term t) (fun t -> + Some <| C_GTotal t) + + | Tm_fvar fv, [(pre, _); (post, _); (pats, _)] when S.fv_eq_lid fv ref_C_Lemma.lid -> + BU.bind_opt (unembed #_ #e_term pre) (fun pre -> + BU.bind_opt (unembed #_ #e_term post) (fun post -> + BU.bind_opt (unembed #_ #e_term pats) (fun pats -> + Some <| C_Lemma (pre, post, pats)))) + + | Tm_fvar fv, [(us, _); (eff, _); (res, _); (args, _); (decrs, _)] + when S.fv_eq_lid fv ref_C_Eff.lid -> + BU.bind_opt (unembed us) (fun us -> + BU.bind_opt (unembed eff) (fun eff -> + BU.bind_opt (unembed #_ #e_term res) (fun res-> + BU.bind_opt (unembed #_ #(e_list e_argv) args) (fun args -> + BU.bind_opt (unembed #_ #(e_list e_term) decrs) (fun decrs -> + Some <| C_Eff (us, eff, res, args, decrs)))))) + + | _ -> + None + in + mk_emb embed_comp_view unembed_comp_view fstar_refl_comp_view + + +(* TODO: move to, Syntax.Embeddings or somewhere better even *) +instance e_sigelt = + let embed_sigelt (rng:Range.range) (se:sigelt) : term = + U.mk_lazy se fstar_refl_sigelt Lazy_sigelt (Some rng) + in + let unembed_sigelt (t:term) : option sigelt = + match (SS.compress t).n with + | Tm_lazy {blob=b; lkind=Lazy_sigelt} -> + Some (undyn b) + | _ -> + None + in + mk_emb embed_sigelt unembed_sigelt fstar_refl_sigelt + +let e_univ_name = + set_type fstar_refl_univ_name e_ident + +let e_lb_view = + let embed_lb_view (rng:Range.range) (lbv:lb_view) : term = + S.mk_Tm_app ref_Mk_lb.t [S.as_arg (embed rng lbv.lb_fv); + S.as_arg (embed rng lbv.lb_us); + S.as_arg (embed #_ #e_term rng lbv.lb_typ); + S.as_arg (embed #_ #e_term rng lbv.lb_def)] + rng + in + let unembed_lb_view (t : term) : option lb_view = + let t = U.unascribe t in + let hd, args = U.head_and_args t in + match (U.un_uinst hd).n, args with + | Tm_fvar fv, [(fv', _); (us, _); (typ, _); (def,_)] + when S.fv_eq_lid fv ref_Mk_lb.lid -> + BU.bind_opt (unembed fv') (fun fv' -> + BU.bind_opt (unembed us) (fun us -> + BU.bind_opt (unembed #_ #e_term typ) (fun typ -> + BU.bind_opt (unembed #_ #e_term def) (fun def -> + Some <| + { lb_fv = fv'; lb_us = us; lb_typ = typ; lb_def = def })))) + + | _ -> + None + in + mk_emb embed_lb_view unembed_lb_view fstar_refl_lb_view + +let e_letbinding = + let embed_letbinding (rng:Range.range) (lb:letbinding) : term = + U.mk_lazy lb fstar_refl_letbinding Lazy_letbinding (Some rng) + in + let unembed_letbinding (t : term) : option letbinding = + match (SS.compress t).n with + | Tm_lazy {blob=lb; lkind=Lazy_letbinding} -> + Some (undyn lb) + | _ -> + None + in + mk_emb embed_letbinding unembed_letbinding fstar_refl_letbinding + +let e_ctor : embedding RD.ctor = e_tuple2 (e_list e_string) e_term + +instance e_sigelt_view = + let embed_sigelt_view (rng:Range.range) (sev:sigelt_view) : term = + match sev with + | Sg_Let (r, lbs) -> + S.mk_Tm_app ref_Sg_Let.t + [S.as_arg (embed rng r); + S.as_arg (embed rng lbs)] + rng + + | Sg_Inductive (nm, univs, bs, t, dcs) -> + S.mk_Tm_app ref_Sg_Inductive.t + [S.as_arg (embed rng nm); + S.as_arg (embed rng univs); + S.as_arg (embed rng bs); + S.as_arg (embed #_ #e_term rng t); + S.as_arg (embed #_ #(e_list e_ctor) rng dcs)] + rng + + | Sg_Val (nm, univs, t) -> + S.mk_Tm_app ref_Sg_Val.t + [S.as_arg (embed rng nm); + S.as_arg (embed rng univs); + S.as_arg (embed #_ #e_term rng t)] + rng + + | Unk -> + { ref_Unk.t with pos = rng } + in + let unembed_sigelt_view (t:term) : option sigelt_view = + let t = U.unascribe t in + let hd, args = U.head_and_args t in + match (U.un_uinst hd).n, args with + | Tm_fvar fv, [(nm, _); (us, _); (bs, _); (t, _); (dcs, _)] when S.fv_eq_lid fv ref_Sg_Inductive.lid -> + BU.bind_opt (unembed nm) (fun nm -> + BU.bind_opt (unembed us) (fun us -> + BU.bind_opt (unembed bs) (fun bs -> + BU.bind_opt (unembed #_ #e_term t) (fun t -> + BU.bind_opt (unembed #_ #(e_list e_ctor) dcs) (fun dcs -> + Some <| Sg_Inductive (nm, us, bs, t, dcs)))))) + + | Tm_fvar fv, [(r, _); (lbs, _)] when S.fv_eq_lid fv ref_Sg_Let.lid -> + BU.bind_opt (unembed r) (fun r -> + BU.bind_opt (unembed lbs) (fun lbs -> + Some <| Sg_Let (r, lbs))) + + | Tm_fvar fv, [(nm, _); (us, _); (t, _)] when S.fv_eq_lid fv ref_Sg_Val.lid -> + BU.bind_opt (unembed nm) (fun nm -> + BU.bind_opt (unembed us) (fun us -> + BU.bind_opt (unembed #_ #e_term t) (fun t -> + Some <| Sg_Val (nm, us, t)))) + + | Tm_fvar fv, [] when S.fv_eq_lid fv ref_Unk.lid -> + Some Unk + + | _ -> + None + in + mk_emb embed_sigelt_view unembed_sigelt_view fstar_refl_sigelt_view + +let e_qualifier = + let embed (rng:Range.range) (q:RD.qualifier) : term = + let r = + match q with + | RD.Assumption -> ref_qual_Assumption.t + | RD.InternalAssumption -> ref_qual_InternalAssumption.t + | RD.New -> ref_qual_New.t + | RD.Private -> ref_qual_Private.t + | RD.Unfold_for_unification_and_vcgen -> ref_qual_Unfold_for_unification_and_vcgen.t + | RD.Visible_default -> ref_qual_Visible_default.t + | RD.Irreducible -> ref_qual_Irreducible.t + | RD.Inline_for_extraction -> ref_qual_Inline_for_extraction.t + | RD.NoExtract -> ref_qual_NoExtract.t + | RD.Noeq -> ref_qual_Noeq.t + | RD.Unopteq -> ref_qual_Unopteq.t + | RD.TotalEffect -> ref_qual_TotalEffect.t + | RD.Logic -> ref_qual_Logic.t + | RD.Reifiable -> ref_qual_Reifiable.t + | RD.ExceptionConstructor -> ref_qual_ExceptionConstructor.t + | RD.HasMaskedEffect -> ref_qual_HasMaskedEffect.t + | RD.Effect -> ref_qual_Effect.t + | RD.OnlyName -> ref_qual_OnlyName.t + | RD.Reflectable l -> + S.mk_Tm_app ref_qual_Reflectable.t [S.as_arg (embed rng l)] + Range.dummyRange + + | RD.Discriminator l -> + S.mk_Tm_app ref_qual_Discriminator.t [S.as_arg (embed rng l)] + Range.dummyRange + + | RD.Action l -> + S.mk_Tm_app ref_qual_Action.t [S.as_arg (embed rng l)] + Range.dummyRange + + | RD.Projector (l, i) -> + S.mk_Tm_app ref_qual_Projector.t [S.as_arg (embed rng (l, i))] + Range.dummyRange + + | RD.RecordType (ids1, ids2) -> + S.mk_Tm_app ref_qual_RecordType.t [S.as_arg (embed rng (ids1, ids2))] + Range.dummyRange + + | RD.RecordConstructor (ids1, ids2) -> + S.mk_Tm_app ref_qual_RecordConstructor.t [S.as_arg (embed rng (ids1, ids2))] + Range.dummyRange + + in { r with pos = rng } + in + let unembed (t: term) : option RD.qualifier = + let t = U.unascribe t in + let hd, args = U.head_and_args t in + match (U.un_uinst hd).n, args with + | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_Assumption.lid -> + Some RD.Assumption + + | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_InternalAssumption.lid -> + Some RD.InternalAssumption + + | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_New.lid -> + Some RD.New + + | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_Private.lid -> + Some RD.Private + + | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_Unfold_for_unification_and_vcgen.lid -> + Some RD.Unfold_for_unification_and_vcgen + + | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_Visible_default.lid -> + Some RD.Visible_default + + | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_Irreducible.lid -> + Some RD.Irreducible + + | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_Inline_for_extraction.lid -> + Some RD.Inline_for_extraction + + | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_NoExtract.lid -> + Some RD.NoExtract + + | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_Noeq.lid -> + Some RD.Noeq + + | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_Unopteq.lid -> + Some RD.Unopteq + + | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_TotalEffect.lid -> + Some RD.TotalEffect + + | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_Logic.lid -> + Some RD.Logic + + | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_Reifiable.lid -> + Some RD.Reifiable + + | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_ExceptionConstructor.lid -> + Some RD.ExceptionConstructor + + | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_HasMaskedEffect.lid -> + Some RD.HasMaskedEffect + + | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_Effect.lid -> + Some RD.Effect + + | Tm_fvar fv, [] when S.fv_eq_lid fv ref_qual_OnlyName.lid -> + Some RD.OnlyName + + | Tm_fvar fv, [(l, _)] when S.fv_eq_lid fv ref_qual_Reflectable.lid -> + BU.bind_opt (unembed l) (fun l -> + Some <| RD.Reflectable l) + + | Tm_fvar fv, [(l, _)] when S.fv_eq_lid fv ref_qual_Discriminator.lid -> + BU.bind_opt (unembed l) (fun l -> + Some <| RD.Discriminator l) + + | Tm_fvar fv, [(l, _)] when S.fv_eq_lid fv ref_qual_Action.lid -> + BU.bind_opt (unembed l) (fun l -> + Some <| RD.Action l) + + | Tm_fvar fv, [(payload, _)] when S.fv_eq_lid fv ref_qual_Projector.lid -> + BU.bind_opt (unembed payload) (fun (l, i) -> + Some <| RD.Projector (l, i)) + + | Tm_fvar fv, [(payload, _)] when S.fv_eq_lid fv ref_qual_RecordType.lid -> + BU.bind_opt (unembed payload) (fun (ids1, ids2) -> + Some <| RD.RecordType (ids1, ids2)) + + | Tm_fvar fv, [(payload, _)] when S.fv_eq_lid fv ref_qual_RecordConstructor.lid -> + BU.bind_opt (unembed payload) (fun (ids1, ids2) -> + Some <| RD.RecordConstructor (ids1, ids2)) + + | _ -> + None + in + mk_emb embed unembed fstar_refl_qualifier + +let e_qualifiers = e_list e_qualifier + +(* -------------------------------------------------------------------------------------- *) +(* ------------------------------------- UNFOLDINGS ------------------------------------- *) +(* -------------------------------------------------------------------------------------- *) + + +(* Note that most of these are never needed during normalization, since + * the types are abstract. + *) + +let unfold_lazy_bv (i : lazyinfo) : term = + let bv : bv = undyn i.blob in + S.mk_Tm_app fstar_refl_pack_bv.t [S.as_arg (embed i.rng (inspect_bv bv))] + i.rng + +let unfold_lazy_binder (i : lazyinfo) : term = + let binder : binder = undyn i.blob in + S.mk_Tm_app fstar_refl_pack_binder.t [S.as_arg (embed i.rng (inspect_binder binder))] + i.rng + +let unfold_lazy_letbinding (i : lazyinfo) : term = + let lb : letbinding = undyn i.blob in + let lbv = inspect_lb lb in + S.mk_Tm_app fstar_refl_pack_lb.t + [ + S.as_arg (embed i.rng lbv.lb_fv); + S.as_arg (embed i.rng lbv.lb_us); + S.as_arg (embed #_ #e_term i.rng lbv.lb_typ); + S.as_arg (embed #_ #e_term i.rng lbv.lb_def) + ] + i.rng + +let unfold_lazy_fvar (i : lazyinfo) : term = + let fv : fv = undyn i.blob in + S.mk_Tm_app fstar_refl_pack_fv.t [S.as_arg (embed i.rng (inspect_fv fv))] + i.rng + +let unfold_lazy_comp (i : lazyinfo) : term = + let comp : comp = undyn i.blob in + S.mk_Tm_app fstar_refl_pack_comp.t [S.as_arg (embed i.rng (inspect_comp comp))] + i.rng + +let unfold_lazy_env (i : lazyinfo) : term = + (* Not needed, metaprograms never see concrete environments. *) + U.exp_unit + +let unfold_lazy_optionstate (i : lazyinfo) : term = + (* Not needed, metaprograms never see concrete optionstates . *) + U.exp_unit + +let unfold_lazy_sigelt (i : lazyinfo) : term = + let sigelt : sigelt = undyn i.blob in + S.mk_Tm_app fstar_refl_pack_sigelt.t [S.as_arg (embed i.rng (inspect_sigelt sigelt))] + i.rng + +let unfold_lazy_universe (i : lazyinfo) : term = + let u : universe = undyn i.blob in + S.mk_Tm_app fstar_refl_pack_universe.t [S.as_arg (embed i.rng (inspect_universe u))] + i.rng diff --git a/src/reflection/FStarC.Reflection.V1.Embeddings.fsti b/src/reflection/FStarC.Reflection.V1.Embeddings.fsti new file mode 100644 index 00000000000..ce9f4f36aa0 --- /dev/null +++ b/src/reflection/FStarC.Reflection.V1.Embeddings.fsti @@ -0,0 +1,71 @@ +(* + Copyright 2008-2022 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Reflection.V1.Embeddings + +open FStar open FStarC.Compiler +open FStarC.Syntax.Syntax +open FStarC.Syntax.Embeddings +open FStar.Order +open FStarC.TypeChecker.Env +open FStarC.Reflection.V1.Data +module O = FStarC.Options +module RD = FStarC.Reflection.V1.Data + +(* Embeddings. We mark the ones proper to this module as instances *) +val e_bv : embedding bv +val e_binder : embedding binder +instance val e_binder_view : embedding binder_view +val e_binders : embedding binders +val e_term : embedding term +instance val e_term_view : embedding term_view +val e_fv : embedding fv +val e_comp : embedding comp +instance val e_comp_view : embedding comp_view +instance val e_const : embedding vconst +val e_env : embedding FStarC.TypeChecker.Env.env +instance val e_pattern : embedding pattern +instance val e_branch : embedding Data.branch +instance val e_aqualv : embedding aqualv +instance val e_argv : embedding argv +val e_sigelt : embedding sigelt +val e_letbinding : embedding letbinding +val e_lb_view : embedding lb_view +instance val e_sigelt_view : embedding sigelt_view +instance val e_bv_view : embedding bv_view +val e_attribute : embedding attribute +val e_attributes : embedding (list attribute) (* This seems rather silly, but `attributes` is a keyword *) +instance val e_qualifier : embedding RD.qualifier +val e_qualifiers : embedding (list RD.qualifier) +val e_ident : embedding RD.ident (* NOT FStarC.Ident.ident *) +val e_univ_name : embedding RD.univ_name (* NOT Syntax.univ_name *) +val e_universe : embedding universe +instance val e_universe_view : embedding universe_view + +(* Useful for embedding antiquoted terms. They are only used for the embedding part, + * so this is a bit hackish. *) +val e_term_aq : antiquotations -> embedding term +val e_term_view_aq : antiquotations -> embedding term_view + +(* Lazy unfoldings *) +val unfold_lazy_bv : lazyinfo -> term +val unfold_lazy_fvar : lazyinfo -> term +val unfold_lazy_binder : lazyinfo -> term +val unfold_lazy_optionstate : lazyinfo -> term +val unfold_lazy_comp : lazyinfo -> term +val unfold_lazy_env : lazyinfo -> term +val unfold_lazy_sigelt : lazyinfo -> term +val unfold_lazy_letbinding : lazyinfo -> term +val unfold_lazy_universe : lazyinfo -> term diff --git a/src/reflection/FStarC.Reflection.V1.Interpreter.fst b/src/reflection/FStarC.Reflection.V1.Interpreter.fst new file mode 100644 index 00000000000..a0f428cfd78 --- /dev/null +++ b/src/reflection/FStarC.Reflection.V1.Interpreter.fst @@ -0,0 +1,205 @@ +(* + Copyright 2008-2022 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Reflection.V1.Interpreter + +module BU = FStarC.Compiler.Util +module Cfg = FStarC.TypeChecker.Cfg +module EMB = FStarC.Syntax.Embeddings +module Env = FStarC.TypeChecker.Env +module NBET = FStarC.TypeChecker.NBETerm +module NRE = FStarC.Reflection.V1.NBEEmbeddings +module PO = FStarC.TypeChecker.Primops +module RB = FStarC.Reflection.V1.Builtins +module RD = FStarC.Reflection.V1.Data +module RE = FStarC.Reflection.V1.Embeddings +module Z = FStarC.BigInt +module Range = FStarC.Compiler.Range +open FStarC.Compiler +open FStarC.Compiler.List +open FStarC.Ident +open FStarC.Syntax.Syntax +open FStarC.Reflection.V1.Constants +open FStarC.Class.Monad + +(* NB: assuming uarity = 0 for these three. Also, they are homogenous in KAM and NBE. *) + +val mk1 : + string -> + {| EMB.embedding 't1 |} -> + {| EMB.embedding 'res |} -> + {| NBET.embedding 't1 |} -> + {| NBET.embedding 'res |} -> + ('t1 -> 'res) -> + PO.primitive_step +let mk1 nm f = + let lid = fstar_refl_builtins_lid nm in + PO.mk1' 0 lid + (fun x -> f x |> Some) + (fun x -> f x |> Some) + +val mk2 : + string -> + {| EMB.embedding 't1 |} -> + {| EMB.embedding 't2 |} -> + {| EMB.embedding 'res |} -> + {| NBET.embedding 't1 |} -> + {| NBET.embedding 't2 |} -> + {| NBET.embedding 'res |} -> + ('t1 -> 't2 -> 'res) -> + PO.primitive_step +let mk2 nm f = + let lid = fstar_refl_builtins_lid nm in + PO.mk2' 0 lid + (fun x y -> f x y |> Some) + (fun x y -> f x y |> Some) + +val mk3 : + string -> + {| EMB.embedding 't1 |} -> + {| EMB.embedding 't2 |} -> + {| EMB.embedding 't3 |} -> + {| EMB.embedding 'res |} -> + {| NBET.embedding 't1 |} -> + {| NBET.embedding 't2 |} -> + {| NBET.embedding 't3 |} -> + {| NBET.embedding 'res |} -> + ('t1 -> 't2 -> 't3 -> 'res) -> + PO.primitive_step +let mk3 nm f = + let lid = fstar_refl_builtins_lid nm in + PO.mk3' 0 lid + (fun x y z -> f x y z |> Some) + (fun x y z -> f x y z |> Some) + +(* Use these instances in this module *) + +instance _ = RE.e_term +instance _ = RE.e_term_view +instance _ = RE.e_fv +instance _ = RE.e_bv +instance _ = RE.e_bv_view +instance _ = RE.e_comp +instance _ = RE.e_comp_view +instance _ = RE.e_universe +instance _ = RE.e_universe_view +instance _ = RE.e_sigelt +instance _ = RE.e_sigelt_view +instance _ = RE.e_binder +instance _ = RE.e_binder_view +instance _ = RE.e_binders +instance _ = RE.e_letbinding +instance _ = RE.e_lb_view +instance _ = RE.e_env +instance _ = RE.e_aqualv +instance _ = RE.e_attributes +instance _ = RE.e_qualifiers +(* And NBE *) +instance _ = NRE.e_term +instance _ = NRE.e_term_view +instance _ = NRE.e_fv +instance _ = NRE.e_bv +instance _ = NRE.e_bv_view +instance _ = NRE.e_comp +instance _ = NRE.e_comp_view +instance _ = NRE.e_universe +instance _ = NRE.e_universe_view +instance _ = NRE.e_sigelt +instance _ = NRE.e_sigelt_view +instance _ = NRE.e_binder +instance _ = NRE.e_binder_view +instance _ = NRE.e_binders +instance _ = NRE.e_letbinding +instance _ = NRE.e_lb_view +instance _ = NRE.e_env +instance _ = NRE.e_aqualv +instance _ = NRE.e_attributes +instance _ = NRE.e_qualifiers + +(* + * NOTE: all primitives must be carefully inspected to make sure they + * do not break the abstraction barrier imposed by the term_view. + * Otherwise, the pack_inspect_inv and inspect_pack_inv lemmas could + * likely be used to derive a contradiction. + * + * The way to go about adding new primitives is to implement them in the + * FStarC.Reflection.V1.Builtins module and implement them using the (internal) + * inspect_ln and pack_ln functions, which means they should not break + * the view abstraction. + * + * _Any_ call to functions elsewhere, say term_to_string or + * Util.term_eq, will _very likely_ be inconsistent with the view. + * Exceptions to the "way to go" above should be well justified. + *) +let reflection_primops : list PO.primitive_step = [ + (****** Inspecting/packing various kinds of syntax ******) + mk1 "inspect_ln" RB.inspect_ln ; + mk1 "pack_ln" RB.pack_ln ; + + mk1 "inspect_fv" RB.inspect_fv; + mk1 "pack_fv" RB.pack_fv; + + mk1 "inspect_comp" RB.inspect_comp ; + mk1 "pack_comp" RB.pack_comp ; + + mk1 "inspect_universe" RB.inspect_universe ; + mk1 "pack_universe" RB.pack_universe ; + mk1 "inspect_sigelt" RB.inspect_sigelt ; + mk1 "pack_sigelt" RB.pack_sigelt ; + mk1 "inspect_lb" RB.inspect_lb ; + mk1 "pack_lb" RB.pack_lb ; + mk1 "inspect_bv" RB.inspect_bv ; + mk1 "pack_bv" RB.pack_bv ; + + (* TODO: Make this consistent with others? No good reason for it to be "exploded" *) + mk1 "inspect_binder" RB.inspect_binder; + mk1 "pack_binder" RB.pack_binder; + + (****** Actual primitives ******) + + mk1 "sigelt_opts" RB.sigelt_opts; + + (* This exposes the embedding of vconfig since it is useful to create attributes *) + mk1 "embed_vconfig" RB.embed_vconfig; + + mk1 "sigelt_attrs" RB.sigelt_attrs; + mk2 "set_sigelt_attrs" RB.set_sigelt_attrs; + mk1 "sigelt_quals" RB.sigelt_quals; + mk2 "set_sigelt_quals" RB.set_sigelt_quals; + mk3 "subst" RB.subst; + mk2 "close_term" RB.close_term; + mk2 "compare_bv" RB.compare_bv; + mk2 "lookup_attr" RB.lookup_attr; + mk1 "all_defs_in_env" RB.all_defs_in_env; + mk2 "defs_in_module" RB.defs_in_module; + + mk2 "term_eq" RB.term_eq; + mk1 "moduleof" RB.moduleof; + mk1 "binders_of_env" RB.binders_of_env; + mk2 "lookup_typ" RB.lookup_typ; + mk1 "env_open_modules" RB.env_open_modules; + + (* See note in ulib/FStarC.Reflection.V1.Builtins.fsti: we expose these + three to reduce dependencies. *) + mk1 "implode_qn" RB.implode_qn; + + mk1 "explode_qn" RB.explode_qn; + mk2 "compare_string" RB.compare_string; + mk2 "push_binder" RB.push_binder; + mk1 "range_of_term" RB.range_of_term; + mk1 "range_of_sigelt" RB.range_of_sigelt; +] + +let _ = List.iter FStarC.TypeChecker.Cfg.register_extra_step reflection_primops diff --git a/src/reflection/FStarC.Reflection.V1.Interpreter.fsti b/src/reflection/FStarC.Reflection.V1.Interpreter.fsti new file mode 100644 index 00000000000..5a4555483b3 --- /dev/null +++ b/src/reflection/FStarC.Reflection.V1.Interpreter.fsti @@ -0,0 +1,19 @@ +(* + Copyright 2008-2022 Microsof Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Reflection.V1.Interpreter + +(* This module only has an initialization effect of registering +many primitive steps in the normalizer. *) diff --git a/src/reflection/FStarC.Reflection.V1.NBEEmbeddings.fst b/src/reflection/FStarC.Reflection.V1.NBEEmbeddings.fst new file mode 100644 index 00000000000..e9c34e2ff3b --- /dev/null +++ b/src/reflection/FStarC.Reflection.V1.NBEEmbeddings.fst @@ -0,0 +1,888 @@ +(* + Copyright 2008-2022 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Reflection.V1.NBEEmbeddings +open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStar.Pervasives +open FStarC.Reflection.V1.Data +open FStarC.Syntax.Syntax +open FStarC.TypeChecker.NBETerm +open FStarC.Compiler.Order +open FStarC.Errors + +module O = FStarC.Options +module S = FStarC.Syntax.Syntax // TODO: remove, it's open + +module BU = FStarC.Compiler.Util +module Env = FStarC.TypeChecker.Env +module Err = FStarC.Errors +module I = FStarC.Ident +module NBETerm = FStarC.TypeChecker.NBETerm +module PC = FStarC.Parser.Const +module Range = FStarC.Compiler.Range +module RD = FStarC.Reflection.V1.Data +module SS = FStarC.Syntax.Subst +module Thunk = FStarC.Thunk +module U = FStarC.Syntax.Util + +open FStarC.Dyn +open FStarC.Reflection.V1.Constants + +(* + * embed : from compiler to user + * unembed : from user to compiler + *) + +let noaqs : antiquotations = (0, []) + +(* -------------------------------------------------------------------------------------- *) +(* ------------------------------------- EMBEDDINGS ------------------------------------- *) +(* -------------------------------------------------------------------------------------- *) + +(* PLEASE NOTE: Construct and FV accumulate their arguments BACKWARDS. That is, + * the expression (f 1 2) is stored as FV (f, [], [Constant (Int 2); Constant (Int 1)]. + * So be careful when calling mkFV/mkConstruct and matching on them. *) + +(* On that note, we use this (inefficient, FIXME) hack in this module *) +let mkFV fv us ts = mkFV fv (List.rev us) (List.rev ts) +let mkConstruct fv us ts = mkConstruct fv (List.rev us) (List.rev ts) +(* ^ We still need to match on them in reverse order though, so this is pretty dumb *) + +let fv_as_emb_typ fv = S.ET_app (FStarC.Ident.string_of_lid fv.fv_name.v, []) +let mk_emb' x y fv = mk_emb x y (fun () -> mkFV fv [] []) (fun () -> fv_as_emb_typ fv) + +let mk_lazy cb obj ty kind = + let li = { + blob = FStarC.Dyn.mkdyn obj + ; lkind = kind + ; ltyp = ty + ; rng = Range.dummyRange + } + in + let thunk = Thunk.mk (fun () -> translate_cb cb (U.unfold_lazy li)) in + mk_t (Lazy (Inl li, thunk)) + +let e_bv = + let embed_bv cb (bv:bv) : t = + mk_lazy cb bv fstar_refl_bv Lazy_bv + in + let unembed_bv cb (t:t) : option bv = + match t.nbe_t with + | Lazy (Inl {blob=b; lkind=Lazy_bv}, _) -> + Some <| FStarC.Dyn.undyn b + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded bv: %s" (t_to_string t)); + None + in + mk_emb' embed_bv unembed_bv fstar_refl_bv_fv + + +let e_binder = + let embed_binder cb (b:binder) : t = + mk_lazy cb b fstar_refl_binder Lazy_binder + in + let unembed_binder cb (t:t) : option binder = + match t.nbe_t with + | Lazy (Inl {blob=b; lkind=Lazy_binder}, _) -> + Some (undyn b) + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded binder: %s" (t_to_string t)); + None + in + mk_emb' embed_binder unembed_binder fstar_refl_binder_fv + +let rec mapM_opt (f : ('a -> option 'b)) (l : list 'a) : option (list 'b) = + match l with + | [] -> Some [] + | x::xs -> + BU.bind_opt (f x) (fun x -> + BU.bind_opt (mapM_opt f xs) (fun xs -> + Some (x :: xs))) + +let e_term_aq aq = + let embed_term cb (t:term) : NBETerm.t = + let qi = { qkind = Quote_static; antiquotations = aq } in + mk_t (NBETerm.Quote (t, qi)) + in + let unembed_term cb (t:NBETerm.t) : option term = + match t.nbe_t with + | NBETerm.Quote (tm, qi) -> + (* Just reuse the code from Reflection *) + Syntax.Embeddings.unembed #_ #(Reflection.V1.Embeddings.e_term_aq (0, [])) (S.mk (Tm_quoted (tm, qi)) Range.dummyRange) Syntax.Embeddings.id_norm_cb + | _ -> + None + in + { NBETerm.em = embed_term + ; NBETerm.un = unembed_term + ; NBETerm.typ = (fun () -> mkFV fstar_refl_term_fv [] []) + ; NBETerm.e_typ = (fun () -> fv_as_emb_typ fstar_refl_term_fv) + } + +let e_term = e_term_aq (0, []) + +let e_sort = e_sealed e_term +let e_ppname = e_sealed e_string + +let e_aqualv = + let embed_aqualv cb (q : aqualv) : t = + match q with + | Data.Q_Explicit -> mkConstruct ref_Q_Explicit.fv [] [] + | Data.Q_Implicit -> mkConstruct ref_Q_Implicit.fv [] [] + | Data.Q_Meta t -> mkConstruct ref_Q_Meta.fv [] [as_arg (embed e_term cb t)] + in + let unembed_aqualv cb (t : t) : option aqualv = + match t.nbe_t with + | Construct (fv, [], []) when S.fv_eq_lid fv ref_Q_Explicit.lid -> Some Data.Q_Explicit + | Construct (fv, [], []) when S.fv_eq_lid fv ref_Q_Implicit.lid -> Some Data.Q_Implicit + | Construct (fv, [], [(t, _)]) when S.fv_eq_lid fv ref_Q_Meta.lid -> + BU.bind_opt (unembed e_term cb t) (fun t -> + Some (Data.Q_Meta t)) + + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded aqualv: %s" (t_to_string t)); + None + in + mk_emb embed_aqualv unembed_aqualv + (fun () -> mkConstruct fstar_refl_aqualv_fv [] []) + (fun () -> fv_as_emb_typ fstar_refl_aqualv_fv) + +let e_binders = e_list e_binder + +let e_fv = + let embed_fv cb (fv:fv) : t = + mk_lazy cb fv fstar_refl_fv Lazy_fvar + in + let unembed_fv cb (t:t) : option fv = + match t.nbe_t with + | Lazy (Inl {blob=b; lkind=Lazy_fvar}, _) -> + Some (undyn b) + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded fvar: %s" (t_to_string t)); + None + in + mk_emb' embed_fv unembed_fv fstar_refl_fv_fv + +let e_comp = + let embed_comp cb (c:S.comp) : t = + mk_lazy cb c fstar_refl_comp Lazy_comp + in + let unembed_comp cb (t:t) : option S.comp = + match t.nbe_t with + | Lazy (Inl {blob=b; lkind=Lazy_comp}, _) -> + Some (undyn b) + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded comp: %s" (t_to_string t)); + None + in + mk_emb' embed_comp unembed_comp fstar_refl_comp_fv + +let e_env = + let embed_env cb (e:Env.env) : t = + mk_lazy cb e fstar_refl_env Lazy_env + in + let unembed_env cb (t:t) : option Env.env = + match t.nbe_t with + | Lazy (Inl {blob=b; lkind=Lazy_env}, _) -> + Some (undyn b) + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded env: %s" (t_to_string t)); + None + in + mk_emb' embed_env unembed_env fstar_refl_env_fv + +let e_const = + let embed_const cb (c:vconst) : t = + match c with + | C_Unit -> mkConstruct ref_C_Unit.fv [] [] + | C_True -> mkConstruct ref_C_True.fv [] [] + | C_False -> mkConstruct ref_C_False.fv [] [] + | C_Int i -> mkConstruct ref_C_Int.fv [] [as_arg (mk_t <| Constant (Int i))] + | C_String s -> mkConstruct ref_C_String.fv [] [as_arg (embed e_string cb s)] + | C_Range r -> mkConstruct ref_C_Range.fv [] [as_arg (embed e_range cb r)] + | C_Reify -> mkConstruct ref_C_Reify.fv [] [] + | C_Reflect ns -> mkConstruct ref_C_Reflect.fv [] [as_arg (embed e_string_list cb ns)] + in + let unembed_const cb (t:t) : option vconst = + match t.nbe_t with + | Construct (fv, [], []) when S.fv_eq_lid fv ref_C_Unit.lid -> + Some C_Unit + + | Construct (fv, [], []) when S.fv_eq_lid fv ref_C_True.lid -> + Some C_True + + | Construct (fv, [], []) when S.fv_eq_lid fv ref_C_False.lid -> + Some C_False + + | Construct (fv, [], [(i, _)]) when S.fv_eq_lid fv ref_C_Int.lid -> + BU.bind_opt (unembed e_int cb i) (fun i -> + Some <| C_Int i) + + | Construct (fv, [], [(s, _)]) when S.fv_eq_lid fv ref_C_String.lid -> + BU.bind_opt (unembed e_string cb s) (fun s -> + Some <| C_String s) + + | Construct (fv, [], [(r, _)]) when S.fv_eq_lid fv ref_C_Range.lid -> + BU.bind_opt (unembed e_range cb r) (fun r -> + Some <| C_Range r) + + | Construct (fv, [], []) when S.fv_eq_lid fv ref_C_Reify.lid -> + Some C_Reify + + | Construct (fv, [], [(ns, _)]) when S.fv_eq_lid fv ref_C_Reflect.lid -> + BU.bind_opt (unembed e_string_list cb ns) (fun ns -> + Some <| C_Reflect ns) + + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded vconst: %s" (t_to_string t)); + None + in + mk_emb' embed_const unembed_const fstar_refl_vconst_fv + +let e_universe = + let embed_universe cb (u:universe) : t = + mk_lazy cb u fstar_refl_universe Lazy_universe in + let unembed_universe cb (t:t) : option S.universe = + match t.nbe_t with + | Lazy (Inl {blob=b; lkind=Lazy_universe}, _) -> + Some (undyn b) + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded + (BU.format1 "Not an embedded universe: %s" (t_to_string t)); + None + in + mk_emb' embed_universe unembed_universe fstar_refl_universe_fv + +let rec e_pattern_aq aq = + let embed_pattern cb (p : pattern) : t = + match p with + | Pat_Constant c -> + mkConstruct ref_Pat_Constant.fv [] [as_arg (embed e_const cb c)] + | Pat_Cons (fv, us_opt, ps) -> + mkConstruct ref_Pat_Cons.fv [] + [as_arg (embed e_fv cb fv); + as_arg (embed (e_option (e_list e_universe)) cb us_opt); + as_arg (embed (e_list (e_tuple2 (e_pattern_aq aq) e_bool)) cb ps)] + | Pat_Var (bv, sort) -> + mkConstruct ref_Pat_Var.fv [] [as_arg (embed e_bv cb bv); as_arg (embed e_sort cb sort)] + | Pat_Dot_Term eopt -> + mkConstruct ref_Pat_Dot_Term.fv [] [as_arg (embed (e_option e_term) cb eopt)] + in + let unembed_pattern cb (t : t) : option pattern = + match t.nbe_t with + | Construct (fv, [], [(c, _)]) when S.fv_eq_lid fv ref_Pat_Constant.lid -> + BU.bind_opt (unembed e_const cb c) (fun c -> + Some <| Pat_Constant c) + + | Construct (fv, [], [(ps, _); (us_opt, _); (f, _)]) when S.fv_eq_lid fv ref_Pat_Cons.lid -> + BU.bind_opt (unembed e_fv cb f) (fun f -> + BU.bind_opt (unembed (e_option (e_list e_universe)) cb us_opt) (fun us -> + BU.bind_opt (unembed (e_list (e_tuple2 (e_pattern_aq aq) e_bool)) cb ps) (fun ps -> + Some <| Pat_Cons (f, us, ps)))) + + | Construct (fv, [], [(sort, _); (bv, _)]) when S.fv_eq_lid fv ref_Pat_Var.lid -> + BU.bind_opt (unembed e_bv cb bv) (fun bv -> + BU.bind_opt (unembed e_sort cb sort) (fun sort -> + Some <| Pat_Var (bv, sort))) + + | Construct (fv, [], [(eopt, _)]) when S.fv_eq_lid fv ref_Pat_Dot_Term.lid -> + BU.bind_opt (unembed (e_option e_term) cb eopt) (fun eopt -> + Some <| Pat_Dot_Term eopt) + + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded pattern: %s" (t_to_string t)); + None + in + mk_emb' embed_pattern unembed_pattern fstar_refl_pattern_fv + +let e_pattern = e_pattern_aq noaqs + +let e_branch = e_tuple2 e_pattern e_term +let e_argv = e_tuple2 e_term e_aqualv + +let e_branch_aq aq = e_tuple2 (e_pattern_aq aq) (e_term_aq aq) +let e_argv_aq aq = e_tuple2 (e_term_aq aq) e_aqualv + +let e_match_returns_annotation = + e_option (e_tuple2 e_binder + (e_tuple3 (e_either e_term e_comp) (e_option e_term) e_bool)) + +let unlazy_as_t k t = + let open FStarC.Class.Deq in + match t.nbe_t with + | Lazy (Inl {lkind=k'; blob=v}, _) when k =? k' -> + FStarC.Dyn.undyn v + | _ -> + failwith "Not a Lazy of the expected kind (NBE)" + +let e_ident : embedding RD.ident = e_tuple2 e_string e_range + +let e_universe_view = + let embed_universe_view cb (uv:universe_view) : t = + match uv with + | Uv_Zero -> mkConstruct ref_Uv_Zero.fv [] [] + | Uv_Succ u -> + mkConstruct + ref_Uv_Succ.fv + [] + [as_arg (embed e_universe cb u)] + | Uv_Max us -> + mkConstruct + ref_Uv_Max.fv + [] + [as_arg (embed (e_list e_universe) cb us)] + | Uv_BVar n -> + mkConstruct + ref_Uv_BVar.fv + [] + [as_arg (embed e_int cb n)] + | Uv_Name i -> + mkConstruct + ref_Uv_Name.fv + [] + [as_arg (embed (e_tuple2 e_string e_range) cb i)] + | Uv_Unif u -> + mkConstruct + ref_Uv_Unif.fv + [] + [as_arg (mk_lazy cb u U.t_universe_uvar Lazy_universe_uvar)] + | Uv_Unk -> mkConstruct ref_Uv_Unk.fv [] [] in + + let unembed_universe_view cb (t:t) : option universe_view = + match t.nbe_t with + | Construct (fv, _, []) when S.fv_eq_lid fv ref_Uv_Zero.lid -> Some Uv_Zero + | Construct (fv, _, [u, _]) when S.fv_eq_lid fv ref_Uv_Succ.lid -> + BU.bind_opt (unembed e_universe cb u) (fun u -> u |> Uv_Succ |> Some) + | Construct (fv, _, [us, _]) when S.fv_eq_lid fv ref_Uv_Max.lid -> + BU.bind_opt (unembed (e_list e_universe) cb us) (fun us -> us |> Uv_Max |> Some) + | Construct (fv, _, [n, _]) when S.fv_eq_lid fv ref_Uv_BVar.lid -> + BU.bind_opt (unembed e_int cb n) (fun n -> n |> Uv_BVar |> Some) + | Construct (fv, _, [i, _]) when S.fv_eq_lid fv ref_Uv_Name.lid -> + BU.bind_opt (unembed (e_tuple2 e_string e_range) cb i) (fun i -> i |> Uv_Name |> Some) + | Construct (fv, _, [u, _]) when S.fv_eq_lid fv ref_Uv_Unif.lid -> + let u : universe_uvar = unlazy_as_t Lazy_universe_uvar u in + u |> Uv_Unif |> Some + | Construct (fv, _, []) when S.fv_eq_lid fv ref_Uv_Unk.lid -> Some Uv_Unk + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded + (BU.format1 "Not an embedded universe view: %s" (t_to_string t)); + None in + + mk_emb' embed_universe_view unembed_universe_view fstar_refl_universe_view_fv + +let e_term_view_aq aq = + let shift (s, aqs) = (s + 1, aqs) in + let embed_term_view cb (tv:term_view) : t = + match tv with + | Tv_FVar fv -> + mkConstruct ref_Tv_FVar.fv [] [as_arg (embed e_fv cb fv)] + + | Tv_BVar bv -> + mkConstruct ref_Tv_BVar.fv [] [as_arg (embed e_bv cb bv)] + + | Tv_Var bv -> + mkConstruct ref_Tv_Var.fv [] [as_arg (embed e_bv cb bv)] + + | Tv_UInst (fv, us) -> + mkConstruct ref_Tv_UInst.fv [] + [as_arg (embed e_fv cb fv); + as_arg (embed (e_list e_universe) cb us)] + + | Tv_App (hd, a) -> + mkConstruct ref_Tv_App.fv [] [as_arg (embed (e_term_aq aq) cb hd); as_arg (embed (e_argv_aq aq) cb a)] + + | Tv_Abs (b, t) -> + mkConstruct ref_Tv_Abs.fv [] [as_arg (embed e_binder cb b); as_arg (embed (e_term_aq (shift aq)) cb t)] + + | Tv_Arrow (b, c) -> + mkConstruct ref_Tv_Arrow.fv [] [as_arg (embed e_binder cb b); as_arg (embed e_comp cb c)] + + | Tv_Type u -> + mkConstruct ref_Tv_Type.fv [] [as_arg (embed e_universe cb u)] + + | Tv_Refine (bv, sort, t) -> + mkConstruct ref_Tv_Refine.fv [] [as_arg (embed e_bv cb bv); + as_arg (embed (e_term_aq aq) cb sort); + as_arg (embed (e_term_aq (shift aq)) cb t)] + + | Tv_Const c -> + mkConstruct ref_Tv_Const.fv [] [as_arg (embed e_const cb c)] + + | Tv_Uvar (u, d) -> + mkConstruct ref_Tv_Uvar.fv [] [as_arg (embed e_int cb u); as_arg (mk_lazy cb (u,d) U.t_ctx_uvar_and_sust Lazy_uvar)] + + | Tv_Let (r, attrs, b, ty, t1, t2) -> + mkConstruct ref_Tv_Let.fv [] [as_arg (embed e_bool cb r); + as_arg (embed (e_list e_term) cb attrs); + as_arg (embed e_bv cb b); + as_arg (embed (e_term_aq aq) cb ty); + as_arg (embed (e_term_aq aq) cb t1); + as_arg (embed (e_term_aq (shift aq)) cb t2)] + + | Tv_Match (t, ret_opt, brs) -> + mkConstruct ref_Tv_Match.fv [] [ + as_arg (embed (e_term_aq aq) cb t); + as_arg (embed e_match_returns_annotation cb ret_opt); + as_arg (embed (e_list (e_branch_aq aq)) cb brs)] + + | Tv_AscribedT (e, t, tacopt, use_eq) -> + mkConstruct ref_Tv_AscT.fv [] + [as_arg (embed (e_term_aq aq) cb e); + as_arg (embed (e_term_aq aq) cb t); + as_arg (embed (e_option (e_term_aq aq)) cb tacopt); + as_arg (embed e_bool cb use_eq)] + + | Tv_AscribedC (e, c, tacopt, use_eq) -> + mkConstruct ref_Tv_AscT.fv [] + [as_arg (embed (e_term_aq aq) cb e); + as_arg (embed e_comp cb c); + as_arg (embed (e_option (e_term_aq aq)) cb tacopt); + as_arg (embed e_bool cb use_eq)] + + | Tv_Unknown -> mkConstruct ref_Tv_Unknown.fv [] [] + + | Tv_Unsupp -> mkConstruct ref_Tv_Unsupp.fv [] [] + in + let unembed_term_view cb (t:t) : option term_view = + match t.nbe_t with + | Construct (fv, _, [(b, _)]) when S.fv_eq_lid fv ref_Tv_Var.lid -> + BU.bind_opt (unembed e_bv cb b) (fun b -> + Some <| Tv_Var b) + + | Construct (fv, _, [(b, _)]) when S.fv_eq_lid fv ref_Tv_BVar.lid -> + BU.bind_opt (unembed e_bv cb b) (fun b -> + Some <| Tv_BVar b) + + | Construct (fv, _, [(f, _)]) when S.fv_eq_lid fv ref_Tv_FVar.lid -> + BU.bind_opt (unembed e_fv cb f) (fun f -> + Some <| Tv_FVar f) + + | Construct (fv, _, [(f, _); (us, _)]) when S.fv_eq_lid fv ref_Tv_UInst.lid -> + BU.bind_opt (unembed e_fv cb f) (fun f -> + BU.bind_opt (unembed (e_list e_universe) cb us) (fun us -> + Some <| Tv_UInst (f, us))) + + | Construct (fv, _, [(r, _); (l, _)]) when S.fv_eq_lid fv ref_Tv_App.lid -> + BU.bind_opt (unembed e_term cb l) (fun l -> + BU.bind_opt (unembed e_argv cb r) (fun r -> + Some <| Tv_App (l, r))) + + | Construct (fv, _, [(t, _); (b, _)]) when S.fv_eq_lid fv ref_Tv_Abs.lid -> + BU.bind_opt (unembed e_binder cb b) (fun b -> + BU.bind_opt (unembed e_term cb t) (fun t -> + Some <| Tv_Abs (b, t))) + + | Construct (fv, _, [(t, _); (b, _)]) when S.fv_eq_lid fv ref_Tv_Arrow.lid -> + BU.bind_opt (unembed e_binder cb b) (fun b -> + BU.bind_opt (unembed e_comp cb t) (fun c -> + Some <| Tv_Arrow (b, c))) + + | Construct (fv, _, [(u, _)]) when S.fv_eq_lid fv ref_Tv_Type.lid -> + BU.bind_opt (unembed e_universe cb u) (fun u -> + Some <| Tv_Type u) + + | Construct (fv, _, [(t, _); (sort, _); (b, _)]) when S.fv_eq_lid fv ref_Tv_Refine.lid -> + BU.bind_opt (unembed e_bv cb b) (fun b -> + BU.bind_opt (unembed e_term cb sort) (fun sort -> + BU.bind_opt (unembed e_term cb t) (fun t -> + Some <| Tv_Refine (b, sort, t)))) + + | Construct (fv, _, [(c, _)]) when S.fv_eq_lid fv ref_Tv_Const.lid -> + BU.bind_opt (unembed e_const cb c) (fun c -> + Some <| Tv_Const c) + + | Construct (fv, _, [(l, _); (u, _)]) when S.fv_eq_lid fv ref_Tv_Uvar.lid -> + BU.bind_opt (unembed e_int cb u) (fun u -> + let ctx_u_s : ctx_uvar_and_subst = unlazy_as_t Lazy_uvar l in + Some <| Tv_Uvar (u, ctx_u_s)) + + | Construct (fv, _, [(t2, _); (t1, _); (ty, _); (b, _); (attrs, _); (r, _)]) when S.fv_eq_lid fv ref_Tv_Let.lid -> + BU.bind_opt (unembed e_bool cb r) (fun r -> + BU.bind_opt (unembed (e_list e_term) cb attrs) (fun attrs -> + BU.bind_opt (unembed e_bv cb b) (fun b -> + BU.bind_opt (unembed e_term cb ty) (fun ty -> + BU.bind_opt (unembed e_term cb t1) (fun t1 -> + BU.bind_opt (unembed e_term cb t2) (fun t2 -> + Some <| Tv_Let (r, attrs, b, ty, t1, t2))))))) + + | Construct (fv, _, [(brs, _); (ret_opt, _); (t, _)]) when S.fv_eq_lid fv ref_Tv_Match.lid -> + BU.bind_opt (unembed e_term cb t) (fun t -> + BU.bind_opt (unembed (e_list e_branch) cb brs) (fun brs -> + BU.bind_opt (unembed e_match_returns_annotation cb ret_opt) (fun ret_opt -> + Some <| Tv_Match (t, ret_opt, brs)))) + + | Construct (fv, _, [(tacopt, _); (t, _); (e, _); (use_eq, _)]) when S.fv_eq_lid fv ref_Tv_AscT.lid -> + BU.bind_opt (unembed e_term cb e) (fun e -> + BU.bind_opt (unembed e_term cb t) (fun t -> + BU.bind_opt (unembed (e_option e_term) cb tacopt) (fun tacopt -> + BU.bind_opt (unembed e_bool cb use_eq) (fun use_eq -> + Some <| Tv_AscribedT (e, t, tacopt, use_eq))))) + + | Construct (fv, _, [(tacopt, _); (c, _); (e, _); (use_eq, _)]) when S.fv_eq_lid fv ref_Tv_AscC.lid -> + BU.bind_opt (unembed e_term cb e) (fun e -> + BU.bind_opt (unembed e_comp cb c) (fun c -> + BU.bind_opt (unembed (e_option e_term) cb tacopt) (fun tacopt -> + BU.bind_opt (unembed e_bool cb use_eq) (fun use_eq -> + Some <| Tv_AscribedC (e, c, tacopt, use_eq))))) + + | Construct (fv, _, []) when S.fv_eq_lid fv ref_Tv_Unknown.lid -> + Some <| Tv_Unknown + + | Construct (fv, _, []) when S.fv_eq_lid fv ref_Tv_Unsupp.lid -> + Some <| Tv_Unsupp + + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded term_view: %s" (t_to_string t)); + None + in + mk_emb' embed_term_view unembed_term_view fstar_refl_term_view_fv + +let e_term_view = e_term_view_aq (0, []) + +let e_bv_view = + let embed_bv_view cb (bvv:bv_view) : t = + mkConstruct ref_Mk_bv.fv [] [as_arg (embed (e_sealed e_string) cb bvv.bv_ppname); + as_arg (embed e_int cb bvv.bv_index)] + in + let unembed_bv_view cb (t : t) : option bv_view = + match t.nbe_t with + | Construct (fv, _, [(idx, _); (nm, _)]) when S.fv_eq_lid fv ref_Mk_bv.lid -> + BU.bind_opt (unembed (e_sealed e_string) cb nm) (fun nm -> + BU.bind_opt (unembed e_int cb idx) (fun idx -> + Some <| { bv_ppname = nm ; bv_index = idx })) + + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded bv_view: %s" (t_to_string t)); + None + in + mk_emb' embed_bv_view unembed_bv_view fstar_refl_bv_view_fv + +let e_attribute = e_term +let e_attributes = e_list e_attribute + +let e_binder_view = + let embed_binder_view cb (bview:binder_view) : t = + mkConstruct ref_Mk_binder.fv [] [as_arg (embed e_bv cb bview.binder_bv); + as_arg (embed e_aqualv cb bview.binder_qual); + as_arg (embed e_attributes cb bview.binder_attrs); + as_arg (embed e_term cb bview.binder_sort)] in + + let unembed_binder_view cb (t:t) : option binder_view = + match t.nbe_t with + | Construct (fv, _, [(sort, _); (attrs, _); (q, _); (bv, _)]) + when S.fv_eq_lid fv ref_Mk_binder.lid -> + BU.bind_opt (unembed e_bv cb bv) (fun bv -> + BU.bind_opt (unembed e_aqualv cb q) (fun q -> + BU.bind_opt (unembed e_attributes cb attrs) (fun attrs -> + BU.bind_opt (unembed e_term cb sort) (fun sort -> + Some <| RD.({binder_bv=bv;binder_qual=q;binder_attrs=attrs;binder_sort=sort}))))) + + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded binder_view: %s" (t_to_string t)); + None + in + mk_emb' embed_binder_view unembed_binder_view fstar_refl_binder_view_fv + +let e_comp_view = + let embed_comp_view cb (cv : comp_view) : t = + match cv with + | C_Total t -> + mkConstruct ref_C_Total.fv [] [ + as_arg (embed e_term cb t)] + + | C_GTotal t -> + mkConstruct ref_C_GTotal.fv [] [ + as_arg (embed e_term cb t)] + + | C_Lemma (pre, post, pats) -> + mkConstruct ref_C_Lemma.fv [] [as_arg (embed e_term cb pre); as_arg (embed e_term cb post); as_arg (embed e_term cb pats)] + + | C_Eff (us, eff, res, args, decrs) -> + mkConstruct ref_C_Eff.fv [] + [ as_arg (embed (e_list e_universe) cb us) + ; as_arg (embed e_string_list cb eff) + ; as_arg (embed e_term cb res) + ; as_arg (embed (e_list e_argv) cb args) + ; as_arg (embed (e_list e_term) cb decrs)] + in + let unembed_comp_view cb (t : t) : option comp_view = + match t.nbe_t with + | Construct (fv, _, [(t, _)]) + when S.fv_eq_lid fv ref_C_Total.lid -> + BU.bind_opt (unembed e_term cb t) (fun t -> + Some <| C_Total t) + + | Construct (fv, _, [(t, _)]) + when S.fv_eq_lid fv ref_C_GTotal.lid -> + BU.bind_opt (unembed e_term cb t) (fun t -> + Some <| C_GTotal t) + + | Construct (fv, _, [(post, _); (pre, _); (pats, _)]) when S.fv_eq_lid fv ref_C_Lemma.lid -> + BU.bind_opt (unembed e_term cb pre) (fun pre -> + BU.bind_opt (unembed e_term cb post) (fun post -> + BU.bind_opt (unembed e_term cb pats) (fun pats -> + Some <| C_Lemma (pre, post, pats)))) + + | Construct (fv, _, [(decrs, _); (args, _); (res, _); (eff, _); (us, _)]) + when S.fv_eq_lid fv ref_C_Eff.lid -> + BU.bind_opt (unembed (e_list e_universe) cb us) (fun us -> + BU.bind_opt (unembed e_string_list cb eff) (fun eff -> + BU.bind_opt (unembed e_term cb res) (fun res-> + BU.bind_opt (unembed (e_list e_argv) cb args) (fun args -> + BU.bind_opt (unembed (e_list e_term) cb decrs) (fun decrs -> + Some <| C_Eff (us, eff, res, args, decrs)))))) + + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded comp_view: %s" (t_to_string t)); + None + in + mk_emb' embed_comp_view unembed_comp_view fstar_refl_comp_view_fv + +let e_sigelt = + let embed_sigelt cb (se:sigelt) : t = + mk_lazy cb se fstar_refl_sigelt Lazy_sigelt + in + let unembed_sigelt cb (t:t) : option sigelt = + match t.nbe_t with + | Lazy (Inl {blob=b; lkind=Lazy_sigelt}, _) -> + Some (undyn b) + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded sigelt: %s" (t_to_string t)); + None + in + mk_emb' embed_sigelt unembed_sigelt fstar_refl_sigelt_fv + +let e_univ_name = + (* TODO: Should be this, but there's a delta depth issue *) + (* set_type fstar_refl_univ_name e_ident *) + e_ident + +let e_univ_names = e_list e_univ_name +let e_string_list = e_list e_string + +let e_ctor = e_tuple2 e_string_list e_term + +let e_lb_view = + let embed_lb_view cb (lbv:lb_view) : t = + mkConstruct ref_Mk_lb.fv [] [as_arg (embed e_fv cb lbv.lb_fv); + as_arg (embed e_univ_names cb lbv.lb_us); + as_arg (embed e_term cb lbv.lb_typ); + as_arg (embed e_term cb lbv.lb_def)] + in + let unembed_lb_view cb (t : t) : option lb_view = + match t.nbe_t with + | Construct (fv, _, [(fv', _); (us, _); (typ, _); (def,_)]) + when S.fv_eq_lid fv ref_Mk_lb.lid -> + BU.bind_opt (unembed e_fv cb fv') (fun fv' -> + BU.bind_opt (unembed e_univ_names cb us) (fun us -> + BU.bind_opt (unembed e_term cb typ) (fun typ -> + BU.bind_opt (unembed e_term cb def) (fun def -> + Some <| + { lb_fv = fv'; lb_us = us; lb_typ = typ; lb_def = def })))) + + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded lb_view: %s" (t_to_string t)); + None + in + mk_emb' embed_lb_view unembed_lb_view fstar_refl_lb_view_fv + +(* embeds as a string list *) +let e_lid : embedding I.lid = + let embed rng lid : t = + embed e_string_list rng (I.path_of_lid lid) + in + let unembed cb (t : t) : option I.lid = + BU.map_opt (unembed e_string_list cb t) (fun p -> I.lid_of_path p Range.dummyRange) + in + mk_emb embed unembed + (fun () -> mkConstruct fstar_refl_aqualv_fv [] []) + (fun () -> fv_as_emb_typ fstar_refl_aqualv_fv) + +let e_letbinding = + let embed_letbinding cb (lb:letbinding) : t = + mk_lazy cb lb fstar_refl_letbinding Lazy_letbinding + in + let unembed_letbinding cb (t : t) : option letbinding = + match t.nbe_t with + | Lazy (Inl {blob=lb; lkind=Lazy_letbinding}, _) -> + Some (undyn lb) + + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded letbinding: %s" (t_to_string t)); + None + in + mk_emb' embed_letbinding unembed_letbinding fstar_refl_letbinding_fv + +let e_sigelt_view = + let embed_sigelt_view cb (sev:sigelt_view) : t = + match sev with + | Sg_Let (r, lbs) -> + mkConstruct ref_Sg_Let.fv [] [as_arg (embed e_bool cb r); + as_arg (embed (e_list e_letbinding) cb lbs)] + + | Sg_Inductive (nm, univs, bs, t, dcs) -> + mkConstruct ref_Sg_Inductive.fv [] [as_arg (embed e_string_list cb nm); + as_arg (embed e_univ_names cb univs); + as_arg (embed e_binders cb bs); + as_arg (embed e_term cb t); + as_arg (embed (e_list e_ctor) cb dcs)] + + | Sg_Val (nm, univs, t) -> + mkConstruct ref_Sg_Val.fv [] + [as_arg (embed e_string_list cb nm); + as_arg (embed e_univ_names cb univs); + as_arg (embed e_term cb t)] + + | Unk -> + mkConstruct ref_Unk.fv [] [] + in + let unembed_sigelt_view cb (t:t) : option sigelt_view = + match t.nbe_t with + | Construct (fv, _, [(dcs, _); (t, _); (bs, _); (us, _); (nm, _)]) when S.fv_eq_lid fv ref_Sg_Inductive.lid -> + BU.bind_opt (unembed e_string_list cb nm) (fun nm -> + BU.bind_opt (unembed e_univ_names cb us) (fun us -> + BU.bind_opt (unembed e_binders cb bs) (fun bs -> + BU.bind_opt (unembed e_term cb t) (fun t -> + BU.bind_opt (unembed (e_list e_ctor) cb dcs) (fun dcs -> + Some <| Sg_Inductive (nm, us, bs, t, dcs)))))) + + | Construct (fv, _, [(lbs, _); (r, _)]) when S.fv_eq_lid fv ref_Sg_Let.lid -> + BU.bind_opt (unembed e_bool cb r) (fun r -> + BU.bind_opt (unembed (e_list e_letbinding) cb lbs) (fun lbs -> + Some <| Sg_Let (r, lbs))) + + | Construct (fv, _, [(t, _); (us, _); (nm, _)]) when S.fv_eq_lid fv ref_Sg_Val.lid -> + BU.bind_opt (unembed e_string_list cb nm) (fun nm -> + BU.bind_opt (unembed e_univ_names cb us) (fun us -> + BU.bind_opt (unembed e_term cb t) (fun t -> + Some <| Sg_Val(nm, us, t)))) + + | Construct (fv, _, []) when S.fv_eq_lid fv ref_Unk.lid -> + Some Unk + + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded sigelt_view: %s" (t_to_string t)); + None + in + mk_emb' embed_sigelt_view unembed_sigelt_view fstar_refl_sigelt_view_fv + +let e_name = e_list e_string + +let e_qualifier = + let embed cb (q:RD.qualifier) : t = + match q with + | RD.Assumption -> mkConstruct ref_qual_Assumption.fv [] [] + | RD.New -> mkConstruct ref_qual_New.fv [] [] + | RD.Private -> mkConstruct ref_qual_Private.fv [] [] + | RD.Unfold_for_unification_and_vcgen -> mkConstruct ref_qual_Unfold_for_unification_and_vcgen.fv [] [] + | RD.Visible_default -> mkConstruct ref_qual_Visible_default.fv [] [] + | RD.Irreducible -> mkConstruct ref_qual_Irreducible.fv [] [] + | RD.Inline_for_extraction -> mkConstruct ref_qual_Inline_for_extraction.fv [] [] + | RD.NoExtract -> mkConstruct ref_qual_NoExtract.fv [] [] + | RD.Noeq -> mkConstruct ref_qual_Noeq.fv [] [] + | RD.Unopteq -> mkConstruct ref_qual_Unopteq.fv [] [] + | RD.TotalEffect -> mkConstruct ref_qual_TotalEffect.fv [] [] + | RD.Logic -> mkConstruct ref_qual_Logic.fv [] [] + | RD.Reifiable -> mkConstruct ref_qual_Reifiable.fv [] [] + | RD.ExceptionConstructor -> mkConstruct ref_qual_ExceptionConstructor.fv [] [] + | RD.HasMaskedEffect -> mkConstruct ref_qual_HasMaskedEffect.fv [] [] + | RD.Effect -> mkConstruct ref_qual_Effect.fv [] [] + | RD.OnlyName -> mkConstruct ref_qual_OnlyName.fv [] [] + | RD.Reflectable l -> + mkConstruct ref_qual_Reflectable.fv [] [as_arg (embed e_name cb l)] + + | RD.Discriminator l -> + mkConstruct ref_qual_Discriminator.fv [] [as_arg (embed e_name cb l)] + + | RD.Action l -> + mkConstruct ref_qual_Action.fv [] [as_arg (embed e_name cb l)] + + | RD.Projector (l, i) -> + mkConstruct ref_qual_Projector.fv [] [as_arg (embed e_name cb l); as_arg (embed e_ident cb i)] + + | RD.RecordType (ids1, ids2) -> + mkConstruct ref_qual_RecordType.fv [] [as_arg (embed (e_list e_ident) cb ids1); + as_arg (embed (e_list e_ident) cb ids2)] + + | RD.RecordConstructor (ids1, ids2) -> + mkConstruct ref_qual_RecordConstructor.fv [] [as_arg (embed (e_list e_ident) cb ids1); + as_arg (embed (e_list e_ident) cb ids2)] + in + let unembed cb (t:t) : option RD.qualifier = + match t.nbe_t with + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Assumption.lid -> Some RD.Assumption + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_New.lid -> Some RD.New + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Private.lid -> Some RD.Private + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Unfold_for_unification_and_vcgen.lid -> Some RD.Unfold_for_unification_and_vcgen + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Visible_default.lid -> Some RD.Visible_default + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Irreducible.lid -> Some RD.Irreducible + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Inline_for_extraction.lid -> Some RD.Inline_for_extraction + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_NoExtract.lid -> Some RD.NoExtract + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Noeq.lid -> Some RD.Noeq + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Unopteq.lid -> Some RD.Unopteq + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_TotalEffect.lid -> Some RD.TotalEffect + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Logic.lid -> Some RD.Logic + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Reifiable.lid -> Some RD.Reifiable + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_ExceptionConstructor.lid -> Some RD.ExceptionConstructor + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_HasMaskedEffect.lid -> Some RD.HasMaskedEffect + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Effect.lid -> Some RD.Effect + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_OnlyName.lid -> Some RD.OnlyName + + | Construct (fv, [], [(l, _)]) when S.fv_eq_lid fv ref_qual_Reflectable.lid -> + BU.bind_opt (unembed e_name cb l) (fun l -> + Some (RD.Reflectable l)) + + | Construct (fv, [], [(l, _)]) when S.fv_eq_lid fv ref_qual_Discriminator.lid -> + BU.bind_opt (unembed e_name cb l) (fun l -> + Some (RD.Discriminator l)) + + | Construct (fv, [], [(l, _)]) when S.fv_eq_lid fv ref_qual_Action.lid -> + BU.bind_opt (unembed e_name cb l) (fun l -> + Some (RD.Action l)) + + | Construct (fv, [], [(i, _); (l, _)]) when S.fv_eq_lid fv ref_qual_Projector.lid -> + BU.bind_opt (unembed e_ident cb i) (fun i -> + BU.bind_opt (unembed e_name cb l) (fun l -> + Some (RD.Projector (l, i)))) + + | Construct (fv, [], [(ids2, _); (ids1, _)]) when S.fv_eq_lid fv ref_qual_RecordType.lid -> + BU.bind_opt (unembed (e_list e_ident) cb ids1) (fun ids1 -> + BU.bind_opt (unembed (e_list e_ident) cb ids2) (fun ids2 -> + Some (RD.RecordType (ids1, ids2)))) + + | Construct (fv, [], [(ids2, _); (ids1, _)]) when S.fv_eq_lid fv ref_qual_RecordConstructor.lid -> + BU.bind_opt (unembed (e_list e_ident) cb ids1) (fun ids1 -> + BU.bind_opt (unembed (e_list e_ident) cb ids2) (fun ids2 -> + Some (RD.RecordConstructor (ids1, ids2)))) + + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded qualifier: %s" (t_to_string t)); + None + in + mk_emb embed unembed + (fun () -> mkConstruct fstar_refl_qualifier_fv [] []) + (fun () -> fv_as_emb_typ fstar_refl_qualifier_fv) + +let e_qualifiers = e_list e_qualifier + +let e_vconfig = + let emb cb (o:order) : t = + failwith "emb vconfig NBE" + in + let unemb cb (t:t) : option order = + failwith "unemb vconfig NBE" + in + mk_emb' emb unemb (lid_as_fv PC.vconfig_lid None) diff --git a/src/reflection/FStarC.Reflection.V1.NBEEmbeddings.fsti b/src/reflection/FStarC.Reflection.V1.NBEEmbeddings.fsti new file mode 100644 index 00000000000..ffac6752608 --- /dev/null +++ b/src/reflection/FStarC.Reflection.V1.NBEEmbeddings.fsti @@ -0,0 +1,58 @@ +(* + Copyright 2008-2022 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Reflection.V1.NBEEmbeddings + +open FStar open FStarC +open FStarC.Compiler +open FStarC.TypeChecker.NBETerm +open FStarC.Syntax.Syntax +open FStar.Order +open FStarC.TypeChecker.Env +open FStarC.Reflection.V1.Data +module RD = FStarC.Reflection.V1.Data +module S = FStarC.Syntax.Syntax + +(* Embeddings. We mark the ones proper to this module as instances *) +instance val e_aqualv : embedding aqualv +instance val e_binder_view : embedding binder_view +instance val e_branch : embedding Data.branch +instance val e_bv_view : embedding bv_view +instance val e_comp_view : embedding comp_view +instance val e_const : embedding vconst +instance val e_lb_view : embedding lb_view +instance val e_pattern : embedding pattern +instance val e_qualifier : embedding RD.qualifier +instance val e_sigelt_view : embedding sigelt_view +instance val e_term_view : embedding term_view +instance val e_universe_view : embedding universe_view +val e_argv : embedding argv +val e_attribute : embedding attribute +val e_attributes : embedding (list attribute) (* This seems rather silly, but `attributes` is a keyword *) +val e_binder : embedding binder +val e_binders : embedding binders +val e_bv : embedding bv +val e_comp : embedding S.comp +val e_env : embedding FStarC.TypeChecker.Env.env +val e_fv : embedding fv +val e_ident : embedding RD.ident (* NOT FStarC.Ident.ident *) +val e_letbinding : embedding letbinding +val e_qualifiers : embedding (list RD.qualifier) +val e_sigelt : embedding sigelt +val e_term : embedding S.term +val e_univ_name : embedding RD.univ_name (* NOT Syntax.univ_name *) +val e_univ_names : embedding (list RD.univ_name) (* NOT Syntax.univ_name *) +val e_universe : embedding universe diff --git a/src/reflection/FStarC.Reflection.V2.Builtins.fst b/src/reflection/FStarC.Reflection.V2.Builtins.fst new file mode 100644 index 00000000000..599c110d3a2 --- /dev/null +++ b/src/reflection/FStarC.Reflection.V2.Builtins.fst @@ -0,0 +1,943 @@ +(* + Copyright 2008-2015 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Reflection.V2.Builtins + +open FStar open FStarC +open FStarC.Compiler +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Reflection.V2.Data +open FStarC.Syntax.Syntax +open FStarC.Errors +open FStar.List.Tot.Base + +module S = FStarC.Syntax.Syntax // TODO: remove, it's open + +open FStarC.Class.Show +open FStarC.Class.Tagged + +module C = FStarC.Const +module PC = FStarC.Parser.Const +module SS = FStarC.Syntax.Subst +module BU = FStarC.Compiler.Util +module Range = FStarC.Compiler.Range +module U = FStarC.Syntax.Util +module UF = FStarC.Syntax.Unionfind +module Print = FStarC.Syntax.Print +module Ident = FStarC.Ident +module Env = FStarC.TypeChecker.Env +module Err = FStarC.Errors +module Z = FStarC.BigInt +module DsEnv = FStarC.Syntax.DsEnv +module O = FStarC.Options +module RD = FStarC.Reflection.V2.Data +module EMB = FStarC.Syntax.Embeddings +module N = FStarC.TypeChecker.Normalize +open FStarC.VConfig + +open FStarC.Dyn + +(* This file provides implementation for reflection primitives in F*. + * + * Users can be exposed to (mostly) raw syntax of terms when working in + * a metaprogramming effect (such as TAC). These effects are irrelevant + * for runtime and cannot, of course, be used for proof (where syntax + * inspection would be completely inconsistent + *) + + (* + * Most of this file is tedious and repetitive. + * We should really allow for some metaprogramming in F*. Oh wait.... + *) + + +(* This is a hack, but it allows to lookup the constructor sigelts when +inspecting a Sig_inductive_typ. + +We need to be careful though. If we use this for, say, `lookup_attr` and +remove its `env` argument, then the normalizer can reduce it eagerly. +Trying to do this right now means calls to `lookup_attr` are evaluated +at extraction time, and will not behave as expected. The root cause is +that all of the reflection operators are taken to be pure and that't not +the case if we remove the `env` in some, like `lookup_attr`. + +In the case of `inspect_sigelt`, however, I think it won't be +noticeable since one obtain a concrete sigelt without running an impure +metaprogram. *) +let get_env () : Env.env = + match !N.reflection_env_hook with + | None -> failwith "impossible: env_hook unset in reflection" + | Some e -> e + +(* private *) +let inspect_bqual (bq : bqual) : aqualv = + match bq with + | Some (Implicit _) -> Data.Q_Implicit + | Some (Meta t) -> Data.Q_Meta t + | Some Equality -> Data.Q_Equality + | None -> Data.Q_Explicit + +let inspect_aqual (aq : aqual) : aqualv = + match aq with + | Some ({ aqual_implicit = true }) -> Data.Q_Implicit + | _ -> Data.Q_Explicit + +(* private *) +let pack_bqual (aqv : aqualv) : bqual = + match aqv with + | Data.Q_Implicit -> Some (Implicit false) + | Data.Q_Meta t -> Some (Meta t) + | Data.Q_Equality -> Some Equality + | Data.Q_Explicit -> None + +let pack_aqual (aqv : aqualv) : aqual = + match aqv with + | Data.Q_Implicit -> S.as_aqual_implicit true + | _ -> None + +let inspect_fv (fv:fv) : list string = + Ident.path_of_lid (lid_of_fv fv) + +let pack_fv (ns:list string) : fv = + let lid = PC.p2l ns in + let fallback () = + let quals = + (* This an awful hack *) + if Ident.lid_equals lid PC.cons_lid then Some Data_ctor else + if Ident.lid_equals lid PC.nil_lid then Some Data_ctor else + if Ident.lid_equals lid PC.some_lid then Some Data_ctor else + if Ident.lid_equals lid PC.none_lid then Some Data_ctor else + None + in + lid_as_fv (PC.p2l ns) quals + in + match !N.reflection_env_hook with + | None -> fallback () + | Some env -> + let qninfo = Env.lookup_qname env lid in + match qninfo with + | Some (Inr (se, _us), _rng) -> + let quals = DsEnv.fv_qual_of_se se in + lid_as_fv (PC.p2l ns) quals + | _ -> + fallback () + +// TODO: move to library? +let rec last (l:list 'a) : 'a = + match l with + | [] -> failwith "last: empty list" + | [x] -> x + | _::xs -> last xs + +let rec init (l:list 'a) : list 'a = + match l with + | [] -> failwith "init: empty list" + | [x] -> [] + | x::xs -> x :: init xs + +let inspect_const (c:sconst) : vconst = + match c with + | FStarC.Const.Const_unit -> C_Unit + | FStarC.Const.Const_int (s, _) -> C_Int (Z.big_int_of_string s) + | FStarC.Const.Const_bool true -> C_True + | FStarC.Const.Const_bool false -> C_False + | FStarC.Const.Const_string (s, _) -> C_String s + | FStarC.Const.Const_range r -> C_Range r + | FStarC.Const.Const_reify _ -> C_Reify + | FStarC.Const.Const_reflect l -> C_Reflect (Ident.path_of_lid l) + | FStarC.Const.Const_real s -> C_Real s + | _ -> failwith (BU.format1 "unknown constant: %s" (show c)) + +let inspect_universe u = + match u with + | U_zero -> Uv_Zero + | U_succ u -> Uv_Succ u + | U_max us -> Uv_Max us + | U_bvar n -> Uv_BVar (Z.of_int_fs n) + | U_name i -> Uv_Name i + | U_unif u -> Uv_Unif u + | U_unknown -> Uv_Unk + +let pack_universe uv = + match uv with + | Uv_Zero -> U_zero + | Uv_Succ u -> U_succ u + | Uv_Max us -> U_max us + | Uv_BVar n -> U_bvar (Z.to_int_fs n) + | Uv_Name i -> U_name i + | Uv_Unif u -> U_unif u + | Uv_Unk -> U_unknown + +let rec inspect_pat p = + match p.v with + | Pat_constant c -> Pat_Constant (inspect_const c) + | Pat_cons (fv, us_opt, ps) -> Pat_Cons fv us_opt (List.map (fun (p, b) -> inspect_pat p, b) ps) + | Pat_var bv -> Pat_Var (Sealed.seal bv.sort) (Sealed.seal <| string_of_id bv.ppname) + | Pat_dot_term eopt -> Pat_Dot_Term eopt + +let rec inspect_ln (t:term) : term_view = + // + // Only pushes delayed substitutions, + // doesn't compress uvars + // + let t = t |> SS.compress_subst in + match t.n with + | Tm_meta {tm=t} -> + inspect_ln t + + | Tm_name bv -> + Tv_Var bv + + | Tm_bvar bv -> + Tv_BVar bv + + | Tm_fvar fv -> + Tv_FVar fv + + | Tm_uinst (t, us) -> + (match t.n with + | Tm_fvar fv -> Tv_UInst (fv, us) + | _ -> failwith "Reflection::inspect_ln: uinst for a non-fvar node") + + | Tm_ascribed {tm=t; asc=(Inl ty, tacopt, eq)} -> + Tv_AscribedT (t, ty, tacopt, eq) + + | Tm_ascribed {tm=t; asc=(Inr cty, tacopt, eq)} -> + Tv_AscribedC (t, cty, tacopt, eq) + + | Tm_app {args=[]} -> + failwith "inspect_ln: empty arguments on Tm_app" + + | Tm_app {hd; args} -> + // We split at the last argument, since the term_view does not + // expose n-ary lambdas buy unary ones. + let (a, q) = last args in + let q' = inspect_aqual q in + Tv_App (U.mk_app hd (init args), (a, q')) + + | Tm_abs {bs=[]} -> + failwith "inspect_ln: empty arguments on Tm_abs" + + | Tm_abs {bs=b::bs; body=t; rc_opt=k} -> + let body = + match bs with + | [] -> t + | bs -> S.mk (Tm_abs {bs; body=t; rc_opt=k}) t.pos + in + Tv_Abs (b, body) + + | Tm_type u -> + Tv_Type u + + | Tm_arrow {bs=[]} -> + failwith "inspect_ln: empty binders on arrow" + + | Tm_arrow _ -> + begin match U.arrow_one_ln t with + | Some (b, c) -> Tv_Arrow (b, c) + | None -> failwith "impossible" + end + + | Tm_refine {b=bv; phi=t} -> + Tv_Refine (S.mk_binder bv, t) + + | Tm_constant c -> + Tv_Const (inspect_const c) + + | Tm_uvar (ctx_u, s) -> + // + // Use the unique id of the uvar + // + Tv_Uvar (Z.of_int_fs (UF.uvar_unique_id ctx_u.ctx_uvar_head), + (ctx_u, s)) + + | Tm_let {lbs=(isrec, [lb]); body=t2} -> + if lb.lbunivs <> [] then Tv_Unsupp else + begin match lb.lbname with + | Inr _ -> Tv_Unsupp // no top level lets + | Inl bv -> Tv_Let (isrec, lb.lbattrs, S.mk_binder bv, lb.lbdef, t2) + end + + | Tm_match {scrutinee=t; ret_opt; brs} -> + let brs = List.map (function (pat, _, t) -> (inspect_pat pat, t)) brs in + Tv_Match (t, ret_opt, brs) + + | Tm_unknown -> + Tv_Unknown + + | Tm_lazy i -> + // Not calling U.unlazy_emb since that calls (stateful) SS.compress + i |> U.unfold_lazy |> inspect_ln + + | _ -> + Err.log_issue t Err.Warning_CantInspect (BU.format2 "inspect_ln: outside of expected syntax (%s, %s)" (tag_of t) (show t)); + Tv_Unsupp + +let inspect_comp (c : comp) : comp_view = + let get_dec (flags : list cflag) : list term = + match List.tryFind (function DECREASES _ -> true | _ -> false) flags with + | None -> [] + | Some (DECREASES (Decreases_lex ts)) -> ts + | Some (DECREASES (Decreases_wf _)) -> + Err.log_issue c Err.Warning_CantInspect + (BU.format1 "inspect_comp: inspecting comp with wf decreases clause is not yet supported: %s \ + skipping the decreases clause" + (show c)); + [] + | _ -> failwith "Impossible!" + in + match c.n with + | Total t -> C_Total t + | GTotal t -> C_GTotal t + | Comp ct -> begin + let uopt = + if List.length ct.comp_univs = 0 + then U_unknown + else ct.comp_univs |> List.hd in + if Ident.lid_equals ct.effect_name PC.effect_Lemma_lid then + match ct.effect_args with + | (pre,_)::(post,_)::(pats,_)::_ -> + C_Lemma (pre, post, pats) + | _ -> + failwith "inspect_comp: Lemma does not have enough arguments?" + else + let inspect_arg (a, q) = (a, inspect_aqual q) in + C_Eff (ct.comp_univs, + Ident.path_of_lid ct.effect_name, + ct.result_typ, + List.map inspect_arg ct.effect_args, + get_dec ct.flags) + end + +let pack_comp (cv : comp_view) : comp = + let urefl_to_univs u = + if u = U_unknown + then [] + else [u] in + let urefl_to_univ_opt u = + if u = U_unknown + then None + else Some u in + match cv with + | C_Total t -> mk_Total t + | C_GTotal t -> mk_GTotal t + | C_Lemma (pre, post, pats) -> + let ct = { comp_univs = [] + ; effect_name = PC.effect_Lemma_lid + ; result_typ = S.t_unit + ; effect_args = [S.as_arg pre; S.as_arg post; S.as_arg pats] + ; flags = [] } in + S.mk_Comp ct + + | C_Eff (us, ef, res, args, decrs) -> + let pack_arg (a, q) = (a, pack_aqual q) in + let flags = + if List.length decrs = 0 + then [] + else [DECREASES (Decreases_lex decrs)] in + let ct = { comp_univs = us + ; effect_name = Ident.lid_of_path ef Range.dummyRange + ; result_typ = res + ; effect_args = List.map pack_arg args + ; flags = flags } in + S.mk_Comp ct + +let pack_const (c:vconst) : sconst = + match c with + | C_Unit -> C.Const_unit + | C_Int i -> C.Const_int (Z.string_of_big_int i, None) + | C_True -> C.Const_bool true + | C_False -> C.Const_bool false + | C_String s -> C.Const_string (s, Range.dummyRange) + | C_Range r -> C.Const_range r + | C_Reify -> C.Const_reify None + | C_Reflect ns -> C.Const_reflect (Ident.lid_of_path ns Range.dummyRange) + | C_Real r -> C.Const_real r + +let rec pack_pat p : S.pat = + let wrap v = {v=v;p=Range.dummyRange} in + match p with + | Pat_Constant c -> wrap <| Pat_constant (pack_const c) + | Pat_Cons head univs subpats -> wrap <| Pat_cons (head, univs, List.map (fun (p, b) -> pack_pat p, b) subpats) + | Pat_Var sort ppname -> + let bv = S.gen_bv (Sealed.unseal ppname) None (Sealed.unseal sort) in + wrap <| Pat_var bv + | Pat_Dot_Term eopt -> wrap <| Pat_dot_term eopt + +// TODO: pass in range? +let pack_ln (tv:term_view) : term = + match tv with + | Tv_Var bv -> + S.bv_to_name { bv with sort = S.tun } + + | Tv_BVar bv -> + S.bv_to_tm { bv with sort = S.tun } + + | Tv_FVar fv -> + S.fv_to_tm fv + + | Tv_UInst (fv, us) -> + mk_Tm_uinst (S.fv_to_tm fv) us + + | Tv_App (l, (r, q)) -> + let q' = pack_aqual q in + U.mk_app l [(r, q')] + + | Tv_Abs (b, t) -> + mk (Tm_abs {bs=[b]; body=t; rc_opt=None}) t.pos // TODO: effect? + + | Tv_Arrow (b, c) -> + mk (Tm_arrow {bs=[b]; comp=c}) c.pos + + | Tv_Type u -> + mk (Tm_type u) Range.dummyRange + + | Tv_Refine (b, t) -> + let bv : S.bv = b.binder_bv in + mk (Tm_refine {b=bv; phi=t}) t.pos + + | Tv_Const c -> + S.mk (Tm_constant (pack_const c)) Range.dummyRange + + | Tv_Uvar (u, ctx_u_s) -> + S.mk (Tm_uvar ctx_u_s) Range.dummyRange + + | Tv_Let (isrec, attrs, b, t1, t2) -> + let bv = b.binder_bv in + let lb = U.mk_letbinding (Inl bv) [] bv.sort PC.effect_Tot_lid t1 attrs Range.dummyRange in + S.mk (Tm_let {lbs=(isrec, [lb]); body=t2}) Range.dummyRange + + | Tv_Match (t, ret_opt, brs) -> + let brs = List.map (function (pat, t) -> (pack_pat pat, None, t)) brs in + S.mk (Tm_match {scrutinee=t; ret_opt; brs; rc_opt=None}) Range.dummyRange + + | Tv_AscribedT(e, t, tacopt, use_eq) -> + S.mk (Tm_ascribed {tm=e; asc=(Inl t, tacopt, use_eq); eff_opt=None}) Range.dummyRange + + | Tv_AscribedC(e, c, tacopt, use_eq) -> + S.mk (Tm_ascribed {tm=e; asc=(Inr c, tacopt, use_eq); eff_opt=None}) Range.dummyRange + + | Tv_Unknown -> + S.mk Tm_unknown Range.dummyRange + + | Tv_Unsupp -> + Err.log_issue0 Err.Warning_CantInspect "packing a Tv_Unsupp into Tm_unknown"; + S.mk Tm_unknown Range.dummyRange + +let compare_bv (x:bv) (y:bv) : order = + let n = S.order_bv x y in + if n < 0 then Lt + else if n = 0 then Eq + else Gt + +// Same as above +let compare_namedv (x:bv) (y:bv) : order = + let n = S.order_bv x y in + if n < 0 then Lt + else if n = 0 then Eq + else Gt + +let lookup_attr_ses (attr:term) (env:Env.env) : list sigelt = + match (SS.compress_subst attr).n with + | Tm_fvar fv -> Env.lookup_attr env (Ident.string_of_lid (lid_of_fv fv)) + | _ -> [] + +let lookup_attr (attr:term) (env:Env.env) : list fv = + let ses = lookup_attr_ses attr env in + List.concatMap (fun se -> match U.lid_of_sigelt se with + | None -> [] + | Some l -> [S.lid_as_fv l None]) ses + +let all_defs_in_env (env:Env.env) : list fv = + List.map (fun l -> S.lid_as_fv l None) (Env.lidents env) // |> take 10 + +let defs_in_module (env:Env.env) (modul:name) : list fv = + List.concatMap + (fun l -> + (* must succeed, ids_of_lid always returns a non-empty list *) + let ns = Ident.ids_of_lid l |> init |> List.map Ident.string_of_id in + if ns = modul + then [S.lid_as_fv l None] + else []) + (Env.lidents env) + +let lookup_typ (env:Env.env) (ns:list string) : option sigelt = + let lid = PC.p2l ns in + Env.lookup_sigelt env lid + +let sigelt_attrs (se : sigelt) : list attribute = + se.sigattrs + +let set_sigelt_attrs (attrs : list attribute) (se : sigelt) : sigelt = + { se with sigattrs = attrs } + +(* PRIVATE, and hacky :-( *) +let rd_to_syntax_qual : RD.qualifier -> qualifier = function + | RD.Assumption -> Assumption + | RD.New -> New + | RD.Private -> Private + | RD.Unfold_for_unification_and_vcgen -> Unfold_for_unification_and_vcgen + | RD.Visible_default -> Visible_default + | RD.Irreducible -> Irreducible + | RD.Inline_for_extraction -> Inline_for_extraction + | RD.NoExtract -> NoExtract + | RD.Noeq -> Noeq + | RD.Unopteq -> Unopteq + | RD.TotalEffect -> TotalEffect + | RD.Logic -> Logic + | RD.Reifiable -> Reifiable + | RD.Reflectable l -> Reflectable (Ident.lid_of_path l Range.dummyRange) + | RD.Discriminator l -> Discriminator (Ident.lid_of_path l Range.dummyRange) + | RD.Projector (l, i) -> Projector (Ident.lid_of_path l Range.dummyRange, i) + | RD.RecordType (l1, l2) -> RecordType (l1, l2) + | RD.RecordConstructor (l1, l2) -> RecordConstructor (l1, l2) + | RD.Action l -> Action (Ident.lid_of_path l Range.dummyRange) + | RD.ExceptionConstructor -> ExceptionConstructor + | RD.HasMaskedEffect -> HasMaskedEffect + | RD.Effect -> S.Effect + | RD.OnlyName -> OnlyName + +let syntax_to_rd_qual = function + | Assumption -> RD.Assumption + | New -> RD.New + | Private -> RD.Private + | Unfold_for_unification_and_vcgen -> RD.Unfold_for_unification_and_vcgen + | Visible_default -> RD.Visible_default + | Irreducible -> RD.Irreducible + | Inline_for_extraction -> RD.Inline_for_extraction + | NoExtract -> RD.NoExtract + | Noeq -> RD.Noeq + | Unopteq -> RD.Unopteq + | TotalEffect -> RD.TotalEffect + | Logic -> RD.Logic + | Reifiable -> RD.Reifiable + | Reflectable l -> RD.Reflectable (Ident.path_of_lid l) + | Discriminator l -> RD.Discriminator (Ident.path_of_lid l) + | Projector (l, i) -> RD.Projector (Ident.path_of_lid l, i) + | RecordType (l1, l2) -> RD.RecordType (l1, l2) + | RecordConstructor (l1, l2) -> RD.RecordConstructor (l1, l2) + | Action l -> RD.Action (Ident.path_of_lid l) + | ExceptionConstructor -> RD.ExceptionConstructor + | HasMaskedEffect -> RD.HasMaskedEffect + | S.Effect -> RD.Effect + | OnlyName -> RD.OnlyName + +let inspect_ident (i:ident) : string & Range.range = + (string_of_id i, range_of_id i) + +let pack_ident (i: string & Range.range) : ident = + Ident.mk_ident i + +let sigelt_quals (se : sigelt) : list RD.qualifier = + se.sigquals |> List.map syntax_to_rd_qual + +let set_sigelt_quals (quals : list RD.qualifier) (se : sigelt) : sigelt = + { se with sigquals = List.map rd_to_syntax_qual quals } + +let sigelt_opts (se : sigelt) : option vconfig = se.sigopts + +let embed_vconfig (vcfg : vconfig) : term = + EMB.embed vcfg Range.dummyRange None EMB.id_norm_cb + +let inspect_sigelt (se : sigelt) : sigelt_view = + match se.sigel with + | Sig_let {lbs=(r, lbs)} -> + Sg_Let (r, lbs) + + | Sig_inductive_typ {lid; us; params=param_bs; t=ty; ds=c_lids} -> + let nm = Ident.path_of_lid lid in + + let inspect_ctor (c_lid:Ident.lid) : ctor = + match Env.lookup_sigelt (get_env ()) c_lid with + | Some ({sigel = Sig_datacon {lid; us; t=cty; num_ty_params=nparam}}) -> + (Ident.path_of_lid lid, cty) + + | _ -> + failwith "impossible: inspect_sigelt: did not find ctor" + in + Sg_Inductive (nm, us, param_bs, ty, List.map inspect_ctor c_lids) + + | Sig_declare_typ {lid; us; t=ty} -> + let nm = Ident.path_of_lid lid in + Sg_Val (nm, us, ty) + + | _ -> + Unk + +let pack_sigelt (sv:sigelt_view) : sigelt = + let check_lid lid = + if List.length (Ident.path_of_lid lid) <= 1 + then failwith ("pack_sigelt: invalid long identifier \"" + ^ Ident.string_of_lid lid + ^ "\" (did you forget a module path?)") + in + match sv with + | Sg_Let (r, lbs) -> + let pack_letbinding (lb:letbinding) = + let {lbname=nm} = lb in + let lid = match nm with + | Inr fv -> lid_of_fv fv + | _ -> failwith + "impossible: pack_sigelt: bv in toplevel let binding" + in + check_lid lid; + (lid, lb) + in + let packed = List.map pack_letbinding lbs in + let lbs = List.map snd packed in + let lids = List.map fst packed in + mk_sigelt <| Sig_let {lbs=(r, lbs); lids} + + | Sg_Inductive (nm, us_names, param_bs, ty, ctors) -> + let ind_lid = Ident.lid_of_path nm Range.dummyRange in + check_lid ind_lid; + let nparam = List.length param_bs in + //We can't tust the value of injective_type_params; set it to false here and let the typechecker recompute + let injective_type_params = false in + let pack_ctor (c:ctor) : sigelt = + let (nm, ty) = c in + let lid = Ident.lid_of_path nm Range.dummyRange in + mk_sigelt <| Sig_datacon {lid; us=us_names; t=ty; ty_lid=ind_lid; num_ty_params=nparam; mutuals=[]; injective_type_params } + in + + let ctor_ses : list sigelt = List.map pack_ctor ctors in + let c_lids : list Ident.lid = List.map (fun se -> BU.must (U.lid_of_sigelt se)) ctor_ses in + + let ind_se : sigelt = + //We can't trust the assignment of num uniform binders from the reflection API + //So, set it to None; it has to be checked and recomputed + mk_sigelt <| Sig_inductive_typ {lid=ind_lid; + us=us_names; + params=param_bs; + num_uniform_params=None; + t=ty; + mutuals=[]; + ds=c_lids; + injective_type_params } + in + let se = mk_sigelt <| Sig_bundle {ses=ind_se::ctor_ses; lids=ind_lid::c_lids} in + { se with sigquals = Noeq::se.sigquals } + + | Sg_Val (nm, us_names, ty) -> + let val_lid = Ident.lid_of_path nm Range.dummyRange in + check_lid val_lid; + mk_sigelt <| Sig_declare_typ {lid=val_lid; us=us_names; t=ty} + + | Unk -> failwith "packing Unk, this should never happen" + +let inspect_lb (lb:letbinding) : lb_view = + let {lbname=nm; lbunivs=us; lbtyp=typ; lbeff=_; lbdef=def; lbattrs=_; lbpos=_} = lb in + match nm with + | Inr fv -> {lb_fv = fv; lb_us = us; lb_typ = typ; lb_def = def} + | _ -> failwith "Impossible: bv in top-level let binding" + +let pack_lb (lbv:lb_view) : letbinding = + let {lb_fv = fv; lb_us = us; lb_typ = typ; lb_def = def} = lbv in + U.mk_letbinding (Inr fv) us typ PC.effect_Tot_lid def [] Range.dummyRange + +let inspect_namedv (v:bv) : namedv_view = + if v.index < 0 then ( + Err.log_issue0 Err.Warning_CantInspect + (BU.format3 "inspect_namedv: uniq is negative (%s : %s), uniq = %s" + (Ident.string_of_id v.ppname) (show v.sort) (string_of_int v.index)) + ); + { + uniq = Z.of_int_fs v.index; + ppname = Sealed.seal <| Ident.string_of_id v.ppname; + sort = Sealed.seal <| v.sort + } + +let pack_namedv (vv:namedv_view) : namedv = + if Z.to_int_fs vv.uniq < 0 then ( + Err.log_issue0 Err.Warning_CantInspect + (BU.format2 "pack_namedv: uniq is negative (%s), uniq = %s" + (Sealed.unseal vv.ppname) (show (Z.to_int_fs vv.uniq))) + ); + { + index = Z.to_int_fs vv.uniq; + ppname = Ident.mk_ident (Sealed.unseal vv.ppname, Range.dummyRange); + sort = Sealed.unseal <| vv.sort; + } + +let inspect_bv (bv:bv) : bv_view = + if bv.index < 0 then ( + Err.log_issue0 Err.Warning_CantInspect + (BU.format3 "inspect_bv: index is negative (%s : %s), index = %s" + (Ident.string_of_id bv.ppname) (show bv.sort) (string_of_int bv.index)) + ); + { + index = Z.of_int_fs bv.index; + ppname = Sealed.seal <| Ident.string_of_id bv.ppname; + sort = Sealed.seal <| bv.sort; + } + +let pack_bv (bvv:bv_view) : bv = + if Z.to_int_fs bvv.index < 0 then ( + Err.log_issue0 Err.Warning_CantInspect + (BU.format2 "pack_bv: index is negative (%s), index = %s" + (Sealed.unseal bvv.ppname) (show (Z.to_int_fs bvv.index))) + ); + { + index = Z.to_int_fs bvv.index; + ppname = Ident.mk_ident (Sealed.unseal bvv.ppname, Range.dummyRange); + sort = Sealed.unseal bvv.sort; + } + +let inspect_binder (b:binder) : binder_view = + let attrs = U.encode_positivity_attributes b.binder_positivity b.binder_attrs in + { + ppname = Sealed.seal <| Ident.string_of_id b.binder_bv.ppname; + qual = inspect_bqual (b.binder_qual); + attrs = attrs; + sort = b.binder_bv.sort; + } + +let pack_binder (bview:binder_view) : binder = + let pqual, attrs = U.parse_positivity_attributes bview.attrs in + { + binder_bv= { ppname = Ident.mk_ident (Sealed.unseal bview.ppname, Range.dummyRange) + ; sort = bview.sort + ; index = 0 (* irrelevant, this is a binder *) + }; + binder_qual=pack_bqual (bview.qual); + binder_positivity=pqual; + binder_attrs=attrs + } + +open FStarC.TypeChecker.Env +let moduleof (e : Env.env) : list string = + Ident.path_of_lid e.curmodule + +let env_open_modules (e : Env.env) : list name = + List.map (fun (l, m) -> List.map Ident.string_of_id (Ident.ids_of_lid l)) + (DsEnv.open_modules e.dsenv) + +let bv_to_binding (bv : bv) : RD.binding = + { + uniq = Z.of_int_fs bv.index; + sort = bv.sort; + ppname = Sealed.seal <| string_of_id bv.ppname; + } + +let vars_of_env e = FStarC.TypeChecker.Env.all_binders e |> List.map (fun b -> bv_to_binding b.binder_bv) + +(* Generic combinators, safe *) +let eqopt = Syntax.Util.eqopt +let eqlist = Syntax.Util.eqlist +let eqprod = Syntax.Util.eqprod + +(* + * Why doesn't this call into Syntax.Util.term_eq? Because that function + * can expose details that are not observable in the userspace view of + * terms, and hence that function cannot be safely exposed if we wish to + * maintain the lemmas stating that pack/inspect are inverses of each + * other. + * + * In other words, we need this function to be implemented consistently + * with the view to make sure it is a _function_ in userspace, and maps + * (propositionally) equal terms to equal results. + * + * So we implement it via inspect_ln, to make sure we don't reveal + * anything inspect_ln does not already reveal. Hence this function + * is really only an optimization of this same implementation done in + * userspace. Also, nothing is guaranted about its result. It if were to + * just return false constantly, that would be safe (though useless). + * + * This same note also applies to comp, and other types that are taken + * as abstract, but have a lemma stating that the view is complete + * (or appear inside a view of one such type). + *) +let rec term_eq (t1:term) (t2:term) : bool = + match inspect_ln t1, inspect_ln t2 with + | Tv_Var bv1, Tv_Var bv2 -> + bv_eq bv1 bv2 + + | Tv_BVar bv1, Tv_BVar bv2 -> + bv_eq bv1 bv2 + + | Tv_FVar fv1, Tv_FVar fv2 -> + (* This should be equivalent to exploding the fv's name comparing *) + S.fv_eq fv1 fv2 + + | Tv_UInst (fv1, us1), Tv_UInst (fv2, us2) -> + S.fv_eq fv1 fv2 && univs_eq us1 us2 + + | Tv_App (h1, arg1), Tv_App (h2, arg2) -> + term_eq h1 h2 && arg_eq arg1 arg2 + + | Tv_Abs (b1, t1), Tv_Abs (b2, t2) -> + binder_eq b1 b2 && term_eq t1 t2 + + | Tv_Arrow (b1, c1), Tv_Arrow (b2, c2) -> + binder_eq b1 b2 && comp_eq c1 c2 + + | Tv_Type u1, Tv_Type u2 -> + univ_eq u1 u2 + + | Tv_Refine (b1, t1), Tv_Refine (b2, t2) -> + (* No need to compare bvs *) + term_eq b1.binder_bv.sort b2.binder_bv.sort && term_eq t1 t2 + + | Tv_Const c1, Tv_Const c2 -> + const_eq c1 c2 + + | Tv_Uvar (n1, uv1), Tv_Uvar (n2, uv2) -> + (* + * The uvs are completely opaque in userspace, so we could do a fancier + * check here without compromising soundness. But.. we cannot really check + * the unionfind graph, I think, since the result could differ as things get + * unified (though it's unclear if that can happen within two calls to this + * function within a *single* definition.. since uvars do not survive across + * top-levels. + * + * Anyway, for now just compare the associated ints. Which are *definitely* + * visible by users. + *) + n1 = n2 + + | Tv_Let (r1, ats1, b1, m1, n1), Tv_Let (r2, ats2, b2, m2, n2) -> + (* no need to compare bvs *) + r1 = r2 && + eqlist term_eq ats1 ats2 && + binder_eq b1 b2 && + term_eq m1 m2 && + term_eq n1 n2 + + | Tv_Match (h1, an1, brs1), Tv_Match (h2, an2, brs2) -> + term_eq h1 h2 && + eqopt match_ret_asc_eq an1 an2 && + eqlist branch_eq brs1 brs2 + + | Tv_AscribedT (e1, t1, topt1, eq1), Tv_AscribedT (e2, t2, topt2, eq2) -> + term_eq e1 e2 && + term_eq t1 t2 && + eqopt term_eq topt1 topt2 && + eq1 = eq2 + + | Tv_AscribedC (e1, c1, topt1, eq1), Tv_AscribedC (e2, c2, topt2, eq2) -> + term_eq e1 e2 && + comp_eq c1 c2 && + eqopt term_eq topt1 topt2 && + eq1 = eq2 + + | Tv_Unknown, Tv_Unknown -> true + | _ -> false + +and arg_eq (arg1 : argv) (arg2 : argv) : bool = + let (a1, aq1) = arg1 in + let (a2, aq2) = arg2 in + term_eq a1 a2 && aqual_eq aq1 aq2 + +and aqual_eq (aq1 : aqualv) (aq2 : aqualv) : bool = + match aq1, aq2 with + | Q_Implicit, Q_Implicit -> true + | Q_Explicit, Q_Explicit -> true + | Q_Meta t1, Q_Meta t2 -> term_eq t1 t2 + | _ -> false + +and binder_eq (b1 : binder) (b2 : binder) : bool = + let bview1 = inspect_binder b1 in + let bview2 = inspect_binder b2 in + term_eq bview1.sort bview2.sort && + aqual_eq bview1.qual bview2.qual && + eqlist term_eq bview1.attrs bview2.attrs + +and bv_eq (bv1 : bv) (bv2 : bv) : bool = + (* + * Just compare the index. Note: this is safe since inspect_bv + * exposes it. We do _not_ compare the sorts. This is already + * what Syntax.Util.term_eq does, and they arguably should not + * be there. + *) + bv1.index = bv2.index + +and comp_eq (c1 : comp) (c2 : comp) : bool = + match inspect_comp c1, inspect_comp c2 with + | C_Total t1, C_Total t2 + | C_GTotal t1, C_GTotal t2 -> + term_eq t1 t2 + + | C_Lemma (pre1, post1, pats1), C_Lemma (pre2, post2, pats2) -> + term_eq pre1 pre2 && term_eq post1 post2 && term_eq pats1 pats2 + + | C_Eff (us1, name1, t1, args1, decrs1), C_Eff (us2, name2, t2, args2, decrs2) -> + univs_eq us1 us2 && + name1 = name2 && + term_eq t1 t2 && + eqlist arg_eq args1 args2 && + eqlist term_eq decrs1 decrs2 + + | _ -> + false + +and match_ret_asc_eq (a1 : match_returns_ascription) (a2 : match_returns_ascription) : bool = + eqprod binder_eq ascription_eq a1 a2 + +and ascription_eq (asc1 : ascription) (asc2 : ascription) : bool = + let (a1, topt1, eq1) = asc1 in + let (a2, topt2, eq2) = asc2 in + (match a1, a2 with + | Inl t1, Inl t2 -> term_eq t1 t2 + | Inr c1, Inr c2 -> comp_eq c1 c2) && + eqopt term_eq topt1 topt2 && + eq1 = eq2 + +and branch_eq (c1 : Data.branch) (c2 : Data.branch) : bool = + eqprod pattern_eq term_eq c1 c2 + +and pattern_eq (p1 : pattern) (p2 : pattern) : bool = + match p1, p2 with + | Pat_Constant c1, Pat_Constant c2 -> + const_eq c1 c2 + | Pat_Cons fv1 us1 subpats1, Pat_Cons fv2 us2 subpats2 -> + S.fv_eq fv1 fv2 && + eqopt (eqlist univ_eq) us1 us2 && + eqlist (eqprod pattern_eq (fun b1 b2 -> b1 = b2)) subpats1 subpats2 + + | Pat_Var _ _, Pat_Var _ _ -> + true + // Should this just be true? Sorts are sealed. + + | Pat_Dot_Term topt1, Pat_Dot_Term topt2 -> + eqopt term_eq topt1 topt2 + + | _ -> false + +and const_eq (c1 : vconst) (c2 : vconst) : bool = + c1 = c2 + +and univ_eq (u1 : universe) (u2 : universe) : bool = + Syntax.Util.eq_univs u1 u2 // FIXME! + +and univs_eq (us1 : list universe) (us2 : list universe) : bool = + eqlist univ_eq us1 us2 + +let implode_qn ns = String.concat "." ns +let explode_qn s = String.split ['.'] s +let compare_string s1 s2 = Z.of_int_fs (String.compare s1 s2) + +let push_binder e b = Env.push_binders e [b] +let push_namedv e b = Env.push_binders e [S.mk_binder b] + +let subst_term (s : list subst_elt) (t : term) : term = + SS.subst s t + +let subst_comp (s : list subst_elt) (c : comp) : comp = + SS.subst_comp s c + +let range_of_term (t:term) = t.pos +let range_of_sigelt (s:sigelt) = s.sigrng + diff --git a/src/reflection/FStarC.Reflection.V2.Builtins.fsti b/src/reflection/FStarC.Reflection.V2.Builtins.fsti new file mode 100644 index 00000000000..2e35aa4027e --- /dev/null +++ b/src/reflection/FStarC.Reflection.V2.Builtins.fsti @@ -0,0 +1,110 @@ +(* + Copyright 2008-2015 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Reflection.V2.Builtins + +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Ident +open FStar.Order +open FStarC.Reflection.V2.Data +open FStarC.Syntax.Embeddings +open FStarC.Syntax.Syntax +open FStarC.VConfig + +module EMB = FStarC.Syntax.Embeddings +module Env = FStarC.TypeChecker.Env +module O = FStarC.Options +module RD = FStarC.Reflection.V2.Data +module S = FStarC.Syntax.Syntax +module Z = FStarC.BigInt + +(* Primitives *) +val compare_bv : bv -> bv -> order +val compare_namedv : namedv -> namedv -> order +val lookup_typ : Env.env -> list string -> option sigelt +val lookup_attr_ses : term -> Env.env -> list sigelt +val lookup_attr : term -> Env.env -> list fv +val all_defs_in_env : Env.env -> list fv +val defs_in_module : Env.env -> name -> list fv +val vars_of_env : Env.env -> list RD.binding +val moduleof : Env.env -> list string +val term_eq : term -> term -> bool +val env_open_modules : Env.env -> list name +val sigelt_opts : sigelt -> option vconfig +val embed_vconfig : vconfig -> term + +val sigelt_attrs : sigelt -> list attribute +val set_sigelt_attrs : list attribute -> sigelt -> sigelt + +val sigelt_quals : sigelt -> list RD.qualifier +val set_sigelt_quals : list RD.qualifier -> sigelt -> sigelt + +(* Views *) +val inspect_fv : fv -> list string +val pack_fv : list string -> fv + +val inspect_const : sconst -> vconst +val pack_const : vconst -> sconst + +val inspect_ln : term -> term_view +val pack_ln : term_view -> term + +val inspect_comp : comp -> comp_view +val pack_comp : comp_view -> comp + +val inspect_sigelt : sigelt -> sigelt_view +val pack_sigelt : sigelt_view -> sigelt + +val inspect_lb : letbinding -> lb_view +val pack_lb : lb_view -> letbinding + +val inspect_namedv : namedv -> namedv_view +val pack_namedv : namedv_view -> namedv + +val inspect_bv : bv -> bv_view +val pack_bv : bv_view -> bv + +val inspect_binder : binder -> binder_view +val pack_binder : binder_view -> binder + +val inspect_aqual : aqual -> aqualv +val pack_aqual : aqualv -> aqual + +val inspect_universe : universe -> universe_view +val pack_universe : universe_view -> universe + +(* Only used internally by check_match_complete... the pattern +(abstract) type is not really exposed, so the user has no use for these. +Perhaps it is more consistent to introduce a pattern_view... *) +val inspect_pat : S.pat -> pattern +val pack_pat : pattern -> S.pat + +(* We're only taking these as primitives to break the dependency from * +FStarC.Tactics into FStar.String, which pulls a LOT of modules. *) +val implode_qn : list string -> string +val explode_qn : string -> list string +val compare_string : string -> string -> Z.t + +val push_namedv : Env.env -> bv -> Env.env + +val range_of_term : term -> Range.range +val range_of_sigelt : sigelt -> Range.range + +val subst_term : list subst_elt -> term -> term +val subst_comp : list subst_elt -> comp -> comp + +val inspect_ident : ident -> string & Range.range +val pack_ident : string & Range.range -> ident diff --git a/src/reflection/FStarC.Reflection.V2.Constants.fst b/src/reflection/FStarC.Reflection.V2.Constants.fst new file mode 100644 index 00000000000..4c87142ac14 --- /dev/null +++ b/src/reflection/FStarC.Reflection.V2.Constants.fst @@ -0,0 +1,327 @@ +(* + Copyright 2008-2022 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Reflection.V2.Constants + + +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List + +(* NOTE: This file is exactly the same as its .fs variant. It is only +here so the equally-named interface file in ulib/ is not taken by the +dependency analysis to be the interface of the .fs. We also cannot ditch +the .fs, since out bootstrapping process does not extract any .ml file +from an interface. Hence we keep both, exactly equal to each other. *) + +open FStarC.Syntax.Syntax +module Ident = FStarC.Ident +module Range = FStarC.Compiler.Range +module Z = FStarC.BigInt +open FStarC.Ident +module PC = FStarC.Parser.Const + +(* Contains all lids and terms needed for embedding/unembedding *) + +type refl_constant = { + lid : FStarC.Ident.lid; + fv : fv; + t : term; +} + +let refl_constant_lid rc = rc.lid +let refl_constant_term rc = rc.t + +let fstar_syntax_syntax_lid s = Ident.lid_of_path (["FStar"; "Stubs"; "Syntax"; "Syntax"]@s) Range.dummyRange + +let fstar_refl_lid s = Ident.lid_of_path (["FStar"; "Stubs"; "Reflection"]@s) Range.dummyRange + +let fstar_refl_types_lid s = fstar_refl_lid ["Types"; s] +let fstar_refl_builtins_lid s = fstar_refl_lid ["V2"; "Builtins"; s] +let fstar_refl_data_lid s = fstar_refl_lid ["V2"; "Data"; s] + +let fstar_syntax_syntax_const s = + let lid = fstar_syntax_syntax_lid s in + { lid = lid + ; fv = lid_as_fv lid (Some Data_ctor) + ; t = tdataconstr lid + } + +let fstar_refl_data_const s = + let lid = fstar_refl_data_lid s in + { lid = lid + ; fv = lid_as_fv lid (Some Data_ctor) + ; t = tdataconstr lid + } + +let mk_refl_types_lid_as_term (s:string) = tconst (fstar_refl_types_lid s) +let mk_refl_types_lid_as_fv (s:string) = fvconst (fstar_refl_types_lid s) +let mk_refl_data_lid_as_term (s:string) = tconst (fstar_refl_data_lid s) +let mk_refl_data_lid_as_fv (s:string) = fvconst (fstar_refl_data_lid s) + +(* FStarC.Syntax.Syntax *) +let mk_ss_lid_as_fv (s:string) = fvconst (fstar_syntax_syntax_lid [s]) +let mk_ss_lid_as_term (s:string) = tconst (fstar_syntax_syntax_lid [s]) + +let mk_inspect_pack_pair s = + let inspect_lid = fstar_refl_builtins_lid ("inspect" ^ s) in + let pack_lid = fstar_refl_builtins_lid ("pack" ^ s) in + let inspect_fv = lid_as_fv inspect_lid None in + let pack_fv = lid_as_fv pack_lid None in + let inspect = { lid = inspect_lid ; fv = inspect_fv ; t = fv_to_tm inspect_fv } in + let pack = { lid = pack_lid ; fv = pack_fv ; t = fv_to_tm pack_fv } in + (inspect, pack) + +let fstar_refl_inspect_ln , fstar_refl_pack_ln = mk_inspect_pack_pair "_ln" +let fstar_refl_inspect_fv , fstar_refl_pack_fv = mk_inspect_pack_pair "_fv" +let fstar_refl_inspect_bv , fstar_refl_pack_bv = mk_inspect_pack_pair "_bv" +let fstar_refl_inspect_namedv , fstar_refl_pack_namedv = mk_inspect_pack_pair "_namedv" +let fstar_refl_inspect_binder , fstar_refl_pack_binder = mk_inspect_pack_pair "_binder" +let fstar_refl_inspect_comp , fstar_refl_pack_comp = mk_inspect_pack_pair "_comp" +let fstar_refl_inspect_sigelt , fstar_refl_pack_sigelt = mk_inspect_pack_pair "_sigelt" +let fstar_refl_inspect_lb , fstar_refl_pack_lb = mk_inspect_pack_pair "_lb" +let fstar_refl_inspect_universe, fstar_refl_pack_universe = mk_inspect_pack_pair "_universe" + +(* assumed types *) +let fstar_refl_env = mk_refl_types_lid_as_term "env" +let fstar_refl_env_fv = mk_refl_types_lid_as_fv "env" +let fstar_refl_namedv = mk_refl_types_lid_as_term "namedv" +let fstar_refl_namedv_fv = mk_refl_types_lid_as_fv "namedv" +let fstar_refl_bv = mk_refl_types_lid_as_term "bv" +let fstar_refl_bv_fv = mk_refl_types_lid_as_fv "bv" +let fstar_refl_fv = mk_refl_types_lid_as_term "fv" +let fstar_refl_fv_fv = mk_refl_types_lid_as_fv "fv" +let fstar_refl_comp = mk_refl_types_lid_as_term "comp" +let fstar_refl_comp_fv = mk_refl_types_lid_as_fv "comp" +let fstar_refl_binding = mk_refl_types_lid_as_term "binding" +let fstar_refl_binding_fv = mk_refl_types_lid_as_fv "binding" +let fstar_refl_binder = mk_refl_types_lid_as_term "binder" +let fstar_refl_binder_fv = mk_refl_types_lid_as_fv "binder" +let fstar_refl_sigelt = mk_refl_types_lid_as_term "sigelt" +let fstar_refl_sigelt_fv = mk_refl_types_lid_as_fv "sigelt" +let fstar_refl_term = mk_refl_types_lid_as_term "term" +let fstar_refl_term_fv = mk_refl_types_lid_as_fv "term" +let fstar_refl_letbinding = mk_refl_types_lid_as_term "letbinding" +let fstar_refl_letbinding_fv = mk_refl_types_lid_as_fv "letbinding" +let fstar_refl_ident = mk_refl_types_lid_as_term "ident" +let fstar_refl_ident_fv = mk_refl_types_lid_as_fv "ident" +let fstar_refl_univ_name = mk_refl_types_lid_as_term "univ_name" +let fstar_refl_univ_name_fv = mk_refl_types_lid_as_fv "univ_name" +let fstar_refl_optionstate = mk_refl_types_lid_as_term "optionstate" +let fstar_refl_optionstate_fv = mk_refl_types_lid_as_fv "optionstate" +let fstar_refl_universe = mk_refl_types_lid_as_term "universe" +let fstar_refl_universe_fv = mk_refl_types_lid_as_fv "universe" +let fstar_refl_universe_uvar = mk_refl_types_lid_as_term "universe_uvar" +let fstar_refl_universe_uvar_fv = mk_refl_types_lid_as_fv "universe_uvar" +let fstar_refl_ctx_uvar_and_subst = mk_refl_types_lid_as_term "ctx_uvar_and_subst" +let fstar_refl_ctx_uvar_and_subst_fv = mk_refl_types_lid_as_fv "ctx_uvar_and_subst" + +(* auxiliary types *) +let fstar_refl_aqualv = mk_refl_data_lid_as_term "aqualv" +let fstar_refl_aqualv_fv = mk_refl_data_lid_as_fv "aqualv" +let fstar_refl_comp_view = mk_refl_data_lid_as_term "comp_view" +let fstar_refl_comp_view_fv = mk_refl_data_lid_as_fv "comp_view" +let fstar_refl_term_view = mk_refl_data_lid_as_term "term_view" +let fstar_refl_term_view_fv = mk_refl_data_lid_as_fv "term_view" +let fstar_refl_pattern = mk_refl_data_lid_as_term "pattern" +let fstar_refl_pattern_fv = mk_refl_data_lid_as_fv "pattern" +let fstar_refl_branch = mk_refl_data_lid_as_term "branch" +let fstar_refl_branch_fv = mk_refl_data_lid_as_fv "branch" +let fstar_refl_namedv_view = mk_refl_data_lid_as_term "namedv_view" +let fstar_refl_namedv_view_fv = mk_refl_data_lid_as_fv "namedv_view" +let fstar_refl_bv_view = mk_refl_data_lid_as_term "bv_view" +let fstar_refl_bv_view_fv = mk_refl_data_lid_as_fv "bv_view" +let fstar_refl_binder_view = mk_refl_data_lid_as_term "binder_view" +let fstar_refl_binder_view_fv = mk_refl_data_lid_as_fv "binder_view" +let fstar_refl_vconst = mk_refl_data_lid_as_term "vconst" +let fstar_refl_vconst_fv = mk_refl_data_lid_as_fv "vconst" +let fstar_refl_lb_view = mk_refl_data_lid_as_term "lb_view" +let fstar_refl_lb_view_fv = mk_refl_data_lid_as_fv "lb_view" +let fstar_refl_sigelt_view = mk_refl_data_lid_as_term "sigelt_view" +let fstar_refl_sigelt_view_fv = mk_refl_data_lid_as_fv "sigelt_view" +let fstar_refl_qualifier = mk_refl_data_lid_as_term "qualifier" +let fstar_refl_qualifier_fv = mk_refl_data_lid_as_fv "qualifier" +let fstar_refl_universe_view = mk_refl_data_lid_as_term "universe_view" +let fstar_refl_universe_view_fv = mk_refl_data_lid_as_fv "universe_view" + +let fstar_refl_subst_elt = mk_ss_lid_as_term "subst_elt" +let fstar_refl_subst_elt_fv = mk_ss_lid_as_fv "subst_elt" +let fstar_refl_subst = mk_ss_lid_as_term "subst" +let fstar_refl_subst_fv = mk_ss_lid_as_fv "subst" + + +(* bv_view, this is a record constructor *) + +let ref_Mk_namedv_view = + let lid = fstar_refl_data_lid "Mknamedv_view" in + let attr = Record_ctor (fstar_refl_data_lid "namedv_view", [ + Ident.mk_ident ("uniq" , Range.dummyRange); + Ident.mk_ident ("sort" , Range.dummyRange); + Ident.mk_ident ("ppname", Range.dummyRange); + ]) in + let fv = lid_as_fv lid (Some attr) in + { lid = lid + ; fv = fv + ; t = fv_to_tm fv + } + +let ref_Mk_bv_view = + let lid = fstar_refl_data_lid "Mkbv_view" in + let attr = Record_ctor (fstar_refl_data_lid "bv_view", [ + Ident.mk_ident ("index" , Range.dummyRange); + Ident.mk_ident ("sort" , Range.dummyRange); + Ident.mk_ident ("ppname", Range.dummyRange); + ]) in + let fv = lid_as_fv lid (Some attr) in + { lid = lid + ; fv = fv + ; t = fv_to_tm fv + } + +let ref_Mk_binding = + let lid = fstar_refl_data_lid "Mkbinding" in + let attr = Record_ctor (fstar_refl_data_lid "binding", [ + Ident.mk_ident ("uniq", Range.dummyRange); + Ident.mk_ident ("sort", Range.dummyRange); + Ident.mk_ident ("ppname" , Range.dummyRange); + ]) in + let fv = lid_as_fv lid (Some attr) in + { lid = lid; + fv = fv; + t = fv_to_tm fv } + +let ref_Mk_binder_view = + let lid = fstar_refl_data_lid "Mkbinder_view" in + let attr = Record_ctor (fstar_refl_data_lid "binder_view", [ + Ident.mk_ident ("sort" , Range.dummyRange); + Ident.mk_ident ("qual", Range.dummyRange); + Ident.mk_ident ("attrs", Range.dummyRange); + Ident.mk_ident ("ppname", Range.dummyRange); + ]) in + let fv = lid_as_fv lid (Some attr) in + { lid = lid; + fv = fv; + t = fv_to_tm fv } + +let ref_Mk_lb = + let lid = fstar_refl_data_lid "Mklb_view" in + let attr = Record_ctor (fstar_refl_data_lid "lb_view", [ + Ident.mk_ident ("lb_fv" , Range.dummyRange); + Ident.mk_ident ("lb_us" , Range.dummyRange); + Ident.mk_ident ("lb_typ" , Range.dummyRange); + Ident.mk_ident ("lb_def" , Range.dummyRange) + ]) in + let fv = lid_as_fv lid (Some attr) in + { lid = lid + ; fv = fv + ; t = fv_to_tm fv + } + +(* quals *) +let ref_Q_Explicit = fstar_refl_data_const "Q_Explicit" +let ref_Q_Implicit = fstar_refl_data_const "Q_Implicit" +let ref_Q_Equality = fstar_refl_data_const "Q_Equality" +let ref_Q_Meta = fstar_refl_data_const "Q_Meta" + +(* subst_elt *) +let ref_DB = fstar_syntax_syntax_const ["DB"] +let ref_DT = fstar_syntax_syntax_const ["DT"] +let ref_NM = fstar_syntax_syntax_const ["NM"] +let ref_NT = fstar_syntax_syntax_const ["NT"] +let ref_UN = fstar_syntax_syntax_const ["UN"] +let ref_UD = fstar_syntax_syntax_const ["UD"] + +(* const *) +let ref_C_Unit = fstar_refl_data_const "C_Unit" +let ref_C_True = fstar_refl_data_const "C_True" +let ref_C_False = fstar_refl_data_const "C_False" +let ref_C_Int = fstar_refl_data_const "C_Int" +let ref_C_String = fstar_refl_data_const "C_String" +let ref_C_Range = fstar_refl_data_const "C_Range" +let ref_C_Reify = fstar_refl_data_const "C_Reify" +let ref_C_Reflect = fstar_refl_data_const "C_Reflect" +let ref_C_Real = fstar_refl_data_const "C_Real" + +(* pattern *) +let ref_Pat_Constant = fstar_refl_data_const "Pat_Constant" +let ref_Pat_Cons = fstar_refl_data_const "Pat_Cons" +let ref_Pat_Var = fstar_refl_data_const "Pat_Var" +let ref_Pat_Dot_Term = fstar_refl_data_const "Pat_Dot_Term" + +(* universe_view *) +let ref_Uv_Zero = fstar_refl_data_const "Uv_Zero" +let ref_Uv_Succ = fstar_refl_data_const "Uv_Succ" +let ref_Uv_Max = fstar_refl_data_const "Uv_Max" +let ref_Uv_BVar = fstar_refl_data_const "Uv_BVar" +let ref_Uv_Name = fstar_refl_data_const "Uv_Name" +let ref_Uv_Unif = fstar_refl_data_const "Uv_Unif" +let ref_Uv_Unk = fstar_refl_data_const "Uv_Unk" + +(* term_view *) +let ref_Tv_Var = fstar_refl_data_const "Tv_Var" +let ref_Tv_BVar = fstar_refl_data_const "Tv_BVar" +let ref_Tv_FVar = fstar_refl_data_const "Tv_FVar" +let ref_Tv_UInst = fstar_refl_data_const "Tv_UInst" +let ref_Tv_App = fstar_refl_data_const "Tv_App" +let ref_Tv_Abs = fstar_refl_data_const "Tv_Abs" +let ref_Tv_Arrow = fstar_refl_data_const "Tv_Arrow" +let ref_Tv_Type = fstar_refl_data_const "Tv_Type" +let ref_Tv_Refine = fstar_refl_data_const "Tv_Refine" +let ref_Tv_Const = fstar_refl_data_const "Tv_Const" +let ref_Tv_Uvar = fstar_refl_data_const "Tv_Uvar" +let ref_Tv_Let = fstar_refl_data_const "Tv_Let" +let ref_Tv_Match = fstar_refl_data_const "Tv_Match" +let ref_Tv_AscT = fstar_refl_data_const "Tv_AscribedT" +let ref_Tv_AscC = fstar_refl_data_const "Tv_AscribedC" +let ref_Tv_Unknown = fstar_refl_data_const "Tv_Unknown" +let ref_Tv_Unsupp = fstar_refl_data_const "Tv_Unsupp" + +(* comp_view *) +let ref_C_Total = fstar_refl_data_const "C_Total" +let ref_C_GTotal = fstar_refl_data_const "C_GTotal" +let ref_C_Lemma = fstar_refl_data_const "C_Lemma" +let ref_C_Eff = fstar_refl_data_const "C_Eff" + +(* inductives & sigelts *) +let ref_Sg_Let = fstar_refl_data_const "Sg_Let" +let ref_Sg_Inductive = fstar_refl_data_const "Sg_Inductive" +let ref_Sg_Val = fstar_refl_data_const "Sg_Val" +let ref_Unk = fstar_refl_data_const "Unk" + +(* qualifiers *) +let ref_qual_Assumption = fstar_refl_data_const "Assumption" +let ref_qual_InternalAssumption = fstar_refl_data_const "InternalAssumption" +let ref_qual_New = fstar_refl_data_const "New" +let ref_qual_Private = fstar_refl_data_const "Private" +let ref_qual_Unfold_for_unification_and_vcgen = fstar_refl_data_const "Unfold_for_unification_and_vcgen" +let ref_qual_Visible_default = fstar_refl_data_const "Visible_default" +let ref_qual_Irreducible = fstar_refl_data_const "Irreducible" +let ref_qual_Inline_for_extraction = fstar_refl_data_const "Inline_for_extraction" +let ref_qual_NoExtract = fstar_refl_data_const "NoExtract" +let ref_qual_Noeq = fstar_refl_data_const "Noeq" +let ref_qual_Unopteq = fstar_refl_data_const "Unopteq" +let ref_qual_TotalEffect = fstar_refl_data_const "TotalEffect" +let ref_qual_Logic = fstar_refl_data_const "Logic" +let ref_qual_Reifiable = fstar_refl_data_const "Reifiable" +let ref_qual_Reflectable = fstar_refl_data_const "Reflectable" +let ref_qual_Discriminator = fstar_refl_data_const "Discriminator" +let ref_qual_Projector = fstar_refl_data_const "Projector" +let ref_qual_RecordType = fstar_refl_data_const "RecordType" +let ref_qual_RecordConstructor = fstar_refl_data_const "RecordConstructor" +let ref_qual_Action = fstar_refl_data_const "Action" +let ref_qual_ExceptionConstructor = fstar_refl_data_const "ExceptionConstructor" +let ref_qual_HasMaskedEffect = fstar_refl_data_const "HasMaskedEffect" +let ref_qual_Effect = fstar_refl_data_const "Effect" +let ref_qual_OnlyName = fstar_refl_data_const "OnlyName" diff --git a/src/reflection/FStarC.Reflection.V2.Data.fst b/src/reflection/FStarC.Reflection.V2.Data.fst new file mode 100644 index 00000000000..73d33b1b4ec --- /dev/null +++ b/src/reflection/FStarC.Reflection.V2.Data.fst @@ -0,0 +1,44 @@ +(* + Copyright 2008-2022 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Reflection.V2.Data + +(* NOTE: This file is exactly the same as its .fs/.fsi counterpart. +It is only here so the equally-named interface file in ulib/ is not +taken by the dependency analysis to be the interface of the .fs. We also +cannot ditch the .fs, since out bootstrapping process does not extract +any .ml file from an interface. Hence we keep both, exactly equal to +each other. *) +open FStarC.Compiler.List +open FStarC.Syntax.Syntax +module Ident = FStarC.Ident +module Range = FStarC.Compiler.Range +module Z = FStarC.BigInt +open FStarC.Ident + +(* These two functions are in ulib/FStarC.Reflection.V2.Data.fsti + But, they are not extracted from there. + + Instead, these functions are extraction from this file. It is + not sufficient to place these functions in the interface + src/reflection/FStarC.Reflection.V2.Data.fsti since this module, like the + rest of the compiler, is extracted in MLish mode. Which means that + functions in the interface are not supported for extraction. So, + we include them in this module implementation file to force them + to be extracted *) +let as_ppname (x:string) : Tot ppname_t = FStarC.Compiler.Sealed.seal x + +let notAscription (tv:term_view) : Tot bool = + not (Tv_AscribedT? tv) && not (Tv_AscribedC? tv) diff --git a/src/reflection/FStarC.Reflection.V2.Data.fsti b/src/reflection/FStarC.Reflection.V2.Data.fsti new file mode 100644 index 00000000000..7b0f781d8b8 --- /dev/null +++ b/src/reflection/FStarC.Reflection.V2.Data.fsti @@ -0,0 +1,218 @@ +(* + Copyright 2008-2022 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Reflection.V2.Data + +(* NOTE: This file is exactly the same as its .fs/.fsi counterpart. +It is only here so the equally-named interface file in ulib/ is not +taken by the dependency analysis to be the interface of the .fs. We also +cannot ditch the .fs, since out bootstrapping process does not extract +any .ml file from an interface. Hence we keep both, exactly equal to +each other. *) +open FStarC.Compiler.List +open FStarC.Syntax.Syntax +module Ident = FStarC.Ident +module Range = FStarC.Compiler.Range +module Z = FStarC.BigInt +open FStarC.Ident +open FStarC.Compiler.Sealed + +type name = list string +type typ = term +type binders = list binder + +type ppname_t = sealed string +val as_ppname (s:string) : Tot ppname_t + +let binder_is_simple (b:Stubs.Reflection.Types.binder) : Tot Type0 = True + +type simple_binder = binder + +type ident_view = string & Range.range + +(* No distinction internally between bvars and named vars *) +type namedv = bv + +type vconst = + | C_Unit + | C_Int of Z.t + | C_True + | C_False + | C_String of string + | C_Range of Range.range + | C_Reify + | C_Reflect of name + | C_Real of string (* Real literals are represented as a string e.g. "1.2" *) + +type universes = list universe + +type pattern = + // A built-in constant + | Pat_Constant : + c : vconst -> + pattern + + // A fully applied constructor, each boolean marks whether the + // argument was an explicitly-provided implicit argument + | Pat_Cons : + head : fv -> + univs : option universes -> + subpats : list (pattern & bool) -> + pattern + + // A pattern-bound variable. It has a sealed sort in it (in userland). + // This sort is ignored by the typechecker, but may be useful + // for metaprogram to look at heuristically. There is nothing + // else here but a ppname, the variable is referred to by its DB index. + // This means all Pat_Var are provably equal. + | Pat_Var : + sort : sealed term -> + ppname : ppname_t -> + pattern + + // Dot pattern: resolved by other elements in the pattern and type + | Pat_Dot_Term : + t : option term -> + pattern + +type branch = pattern & term + +type aqualv = + | Q_Implicit + | Q_Explicit + | Q_Equality + | Q_Meta of term + +type argv = term & aqualv + +type namedv_view = { + uniq : Z.t; + sort : sealed typ; + ppname : ppname_t; +} + +type bv_view = { + index : Z.t; + sort : sealed typ; + ppname : ppname_t; +} + +type binder_view = { + sort : typ; + qual : aqualv; + attrs : list term; + ppname : ppname_t; +} + +type binding = { + uniq : Z.t; + sort : typ; + ppname : ppname_t; +} +type bindings = list binding + +type universe_view = + | Uv_Zero : universe_view + | Uv_Succ : universe -> universe_view + | Uv_Max : universes -> universe_view + | Uv_BVar : Z.t -> universe_view + | Uv_Name : univ_name -> universe_view + | Uv_Unif : universe_uvar -> universe_view + | Uv_Unk : universe_view + +type term_view = + | Tv_Var of namedv + | Tv_BVar of bv + | Tv_FVar of fv + | Tv_UInst of fv & universes + | Tv_App of term & argv + | Tv_Abs of binder & term + | Tv_Arrow of binder & comp + | Tv_Type of universe + | Tv_Refine of binder & term + | Tv_Const of vconst + | Tv_Uvar of Z.t & ctx_uvar_and_subst + | Tv_Let of bool & list term & binder & term & term + | Tv_Match of term & option match_returns_ascription & list branch + | Tv_AscribedT of term & term & option term & bool //if the boolean flag is true, the ascription is an equality ascription + //see also Syntax + | Tv_AscribedC of term & comp & option term & bool //bool is similar to Tv_AscribedT + | Tv_Unknown + | Tv_Unsupp + +val notAscription (t:term_view) : Tot bool + +type comp_view = + | C_Total of typ + | C_GTotal of typ + | C_Lemma of term & term & term + | C_Eff of universes & name & term & list argv & list term // list term is the decreases clause + +type ctor = name & typ + +type lb_view = { + lb_fv : fv; + lb_us : list univ_name; + lb_typ : typ; + lb_def : term +} + +type sigelt_view = + | Sg_Let of bool & list letbinding + // The bool indicates if it's a let rec + // Non-empty list of (possibly) mutually recursive let-bindings + | Sg_Inductive of name & list univ_name & list binder & typ & list ctor // name, params, type, constructors + | Sg_Val of name & list univ_name & typ + | Unk + + +(* This is a mirror of FStarC.Syntax.Syntax.qualifier *) +type qualifier = + | Assumption + | InternalAssumption + | New + | Private + | Unfold_for_unification_and_vcgen + | Visible_default + | Irreducible + | Inline_for_extraction + | NoExtract + | Noeq + | Unopteq + | TotalEffect + | Logic + | Reifiable + | Reflectable of name + | Discriminator of name + | Projector of name & ident + | RecordType of (list ident & list ident) + | RecordConstructor of (list ident & list ident) + | Action of name + | ExceptionConstructor + | HasMaskedEffect + | Effect + | OnlyName + +type qualifiers = list qualifier + +type var = Z.t + +type exp = + | Unit + | Var of var + | Mult of exp & exp + +(* Needed so this appears in the ocaml output for the fstar tactics library *) +type decls = list sigelt diff --git a/src/reflection/FStarC.Reflection.V2.Embeddings.fst b/src/reflection/FStarC.Reflection.V2.Embeddings.fst new file mode 100644 index 00000000000..29257b0e61a --- /dev/null +++ b/src/reflection/FStarC.Reflection.V2.Embeddings.fst @@ -0,0 +1,843 @@ +(* + Copyright 2008-2022 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Reflection.V2.Embeddings + +open FStarC.Compiler.Effect +open FStarC.Reflection.V2.Data +open FStarC.Syntax.Syntax +open FStarC.Syntax.Embeddings +open FStar.Order +open FStarC.Errors + +module BU = FStarC.Compiler.Util +module EMB = FStarC.Syntax.Embeddings +module Env = FStarC.TypeChecker.Env +module Err = FStarC.Errors +module I = FStarC.Ident +module List = FStarC.Compiler.List +module NBETerm = FStarC.TypeChecker.NBETerm +module O = FStarC.Options +module PC = FStarC.Parser.Const +module Print = FStarC.Syntax.Print +module Range = FStarC.Compiler.Range +module RD = FStarC.Reflection.V2.Data +module S = FStarC.Syntax.Syntax // TODO: remove, it's open +module SS = FStarC.Syntax.Subst +module U = FStarC.Syntax.Util +module Z = FStarC.BigInt + +open FStarC.Reflection.V2.Builtins //needed for inspect_fv, but that feels wrong +open FStarC.Dyn +open FStarC.Syntax.Embeddings.AppEmb +open FStarC.Class.Monad + +(* We only use simple embeddings here *) +let mk_emb f g t = + mk_emb (fun x r _topt _norm -> f r x) + (fun x _norm -> g x) + (term_as_fv t) +let embed {|embedding 'a|} r (x:'a) = embed x r None id_norm_cb +let try_unembed {|embedding 'a|} x : option 'a = try_unembed x id_norm_cb + +open FStarC.Reflection.V2.Constants + +let curry f x y = f (x,y) +let curry3 f x y z = f (x,y,z) +let curry4 f x y z w = f (x,y,z,w) +let curry5 f x y z w v = f (x,y,z,w,v) + +let head_fv_and_args (t : term) : option (fv & args) = + let t = U.unascribe t in + let hd, args = U.head_and_args t in + match (U.un_uinst hd).n with + | Tm_fvar fv -> Some (fv, args) + | _ -> None + +let noaqs : antiquotations = (0, []) + +(* -------------------------------------------------------------------------------------- *) +(* ------------------------------------- EMBEDDINGS ------------------------------------- *) +(* -------------------------------------------------------------------------------------- *) + +(* The lazy embeddings: just embedding whatever value as a blob inside a Tm_Lazy node. *) +let e_bv : embedding bv = EMB.e_lazy Lazy_bv fstar_refl_bv +let e_namedv : embedding namedv = EMB.e_lazy Lazy_namedv fstar_refl_namedv +let e_binder : embedding binder = EMB.e_lazy Lazy_binder fstar_refl_binder +let e_fv : embedding fv = EMB.e_lazy Lazy_fvar fstar_refl_fv +let e_comp : embedding comp = EMB.e_lazy Lazy_comp fstar_refl_comp +let e_universe : embedding universe = EMB.e_lazy Lazy_universe fstar_refl_universe +let e_ident : embedding I.ident = EMB.e_lazy Lazy_ident fstar_refl_ident +let e_env : embedding env = EMB.e_lazy Lazy_env fstar_refl_env +let e_sigelt : embedding sigelt = EMB.e_lazy Lazy_sigelt fstar_refl_sigelt +let e_letbinding : embedding letbinding = EMB.e_lazy Lazy_letbinding fstar_refl_letbinding + +instance e_ctx_uvar_and_subst : embedding ctx_uvar_and_subst = EMB.e_lazy Lazy_uvar fstar_refl_ctx_uvar_and_subst +instance e_universe_uvar : embedding universe_uvar = EMB.e_lazy Lazy_universe_uvar fstar_refl_universe_uvar + +let rec mapM_opt (f : ('a -> option 'b)) (l : list 'a) : option (list 'b) = + match l with + | [] -> Some [] + | x::xs -> + BU.bind_opt (f x) (fun x -> + BU.bind_opt (mapM_opt f xs) (fun xs -> + Some (x :: xs))) + +let e_term_aq aq = + let embed_term (rng:Range.range) (t:term) : term = + let qi = { qkind = Quote_static; antiquotations = aq } in + S.mk (Tm_quoted (t, qi)) rng + in + let rec unembed_term (t:term) : option term = + let apply_antiquotations (t:term) (aq:antiquotations) : option term = + let shift, aqs = aq in + let aqs = List.rev aqs in + // Try to unembed all antiquotations + BU.bind_opt (mapM_opt unembed_term aqs) (fun aq_ts -> + // Create a substitution of the DB indices of t for the antiquotations + (* let n = List.length aq_ts - 1 in *) + let subst_open, subst = + aq_ts + |> List.mapi (fun i at -> + let x = S.new_bv None S.t_term in + DB(shift+i, x), NT (x, at)) + |> List.unzip + in + + // Substitute and return + Some (SS.subst subst <| SS.subst subst_open t)) + in + let t = U.unmeta t in + match (SS.compress t).n with + | Tm_quoted (tm, qi) -> + apply_antiquotations tm qi.antiquotations + | _ -> None + in + mk_emb embed_term unembed_term S.t_term + +let e_term = e_term_aq noaqs + +let e_sort : embedding (Sealed.sealed term) = e_sealed e_term +let e_ppname : embedding ppname_t = e_sealed e_string + +let e_aqualv = + let embed_aqualv (rng:Range.range) (q : aqualv) : term = + let r = + match q with + | Data.Q_Explicit -> ref_Q_Explicit.t + | Data.Q_Implicit -> ref_Q_Implicit.t + | Data.Q_Equality -> ref_Q_Equality.t + | Data.Q_Meta t -> + S.mk_Tm_app ref_Q_Meta.t [S.as_arg (embed #_ #e_term rng t)] + Range.dummyRange + in { r with pos = rng } + in + let unembed_aqualv (t : term) : option aqualv = + let? fv, args = head_fv_and_args t in + match () with + | _ when S.fv_eq_lid fv ref_Q_Explicit.lid -> run args (pure Data.Q_Explicit) + | _ when S.fv_eq_lid fv ref_Q_Implicit.lid -> run args (pure Data.Q_Implicit) + | _ when S.fv_eq_lid fv ref_Q_Equality.lid -> run args (pure Data.Q_Equality) + | _ when S.fv_eq_lid fv ref_Q_Meta.lid -> run args (Data.Q_Meta <$$> e_term) + | _ -> None + in + mk_emb embed_aqualv unembed_aqualv fstar_refl_aqualv + +let e_binders = e_list e_binder + +let e_universe_view = + let embed_universe_view (rng:Range.range) (uv:universe_view) : term = + match uv with + | Uv_Zero -> ref_Uv_Zero.t + | Uv_Succ u -> + S.mk_Tm_app + ref_Uv_Succ.t + [S.as_arg (embed rng u)] + rng + | Uv_Max us -> + S.mk_Tm_app + ref_Uv_Max.t + [S.as_arg (embed rng us)] + rng + | Uv_BVar n -> + S.mk_Tm_app + ref_Uv_BVar.t + [S.as_arg (embed rng n)] + rng + | Uv_Name i -> + S.mk_Tm_app + ref_Uv_Name.t + [S.as_arg (embed rng i)] + rng + | Uv_Unif u -> + S.mk_Tm_app + ref_Uv_Unif.t + [S.as_arg (embed rng u)] + rng + | Uv_Unk -> + ref_Uv_Unk.t in + + let unembed_universe_view (t:term) : option universe_view = + let? fv, args = head_fv_and_args t in + match () with + | _ when S.fv_eq_lid fv ref_Uv_Zero.lid -> run args (pure Uv_Zero) + | _ when S.fv_eq_lid fv ref_Uv_Succ.lid -> run args (Uv_Succ <$$> e_universe) + | _ when S.fv_eq_lid fv ref_Uv_Max.lid -> run args (Uv_Max <$$> e_list e_universe) + | _ when S.fv_eq_lid fv ref_Uv_BVar.lid -> run args (Uv_BVar <$$> e_int) + | _ when S.fv_eq_lid fv ref_Uv_Name.lid -> run args (Uv_Name <$$> e_ident) + | _ when S.fv_eq_lid fv ref_Uv_Unif.lid -> run args (Uv_Unif <$$> e_universe_uvar) + | _ when S.fv_eq_lid fv ref_Uv_Unk.lid -> run args (pure Uv_Unk) + | _ -> None + in + + mk_emb embed_universe_view unembed_universe_view fstar_refl_universe_view + +let e_vconst = + let embed_const (rng:Range.range) (c:vconst) : term = + let r = + match c with + | C_Unit -> ref_C_Unit.t + | C_True -> ref_C_True.t + | C_False -> ref_C_False.t + + | C_Int i -> + S.mk_Tm_app ref_C_Int.t [S.as_arg (U.exp_int (Z.string_of_big_int i))] + Range.dummyRange + | C_String s -> + S.mk_Tm_app ref_C_String.t [S.as_arg (embed rng s)] + Range.dummyRange + + | C_Range r -> + S.mk_Tm_app ref_C_Range.t [S.as_arg (embed rng r)] + Range.dummyRange + + | C_Reify -> ref_C_Reify.t + + | C_Reflect ns -> + S.mk_Tm_app ref_C_Reflect.t [S.as_arg (embed rng ns)] + Range.dummyRange + + | C_Real s -> + S.mk_Tm_app ref_C_Real.t [S.as_arg (embed rng s)] + Range.dummyRange + + in { r with pos = rng } + in + let unembed_const (t:term) : option vconst = + let? fv, args = head_fv_and_args t in + match () with + | _ when S.fv_eq_lid fv ref_C_Unit.lid -> run args (pure C_Unit) + | _ when S.fv_eq_lid fv ref_C_True.lid -> run args (pure C_True) + | _ when S.fv_eq_lid fv ref_C_False.lid -> run args (pure C_False) + | _ when S.fv_eq_lid fv ref_C_Int.lid -> run args (C_Int <$$> e_int) + | _ when S.fv_eq_lid fv ref_C_String.lid -> run args (C_String <$$> e_string) + | _ when S.fv_eq_lid fv ref_C_Range.lid -> run args (C_Range <$$> e_range) + | _ when S.fv_eq_lid fv ref_C_Reify.lid -> run args (pure C_Reify) + | _ when S.fv_eq_lid fv ref_C_Reflect.lid -> run args (C_Reflect <$$> e_string_list) + | _ when S.fv_eq_lid fv ref_C_Real.lid -> run args (C_Real <$$> e_string) + | _ -> None + in + mk_emb embed_const unembed_const fstar_refl_vconst + +let rec e_pattern_aq aq = + let rec embed_pattern (rng:Range.range) (p : pattern) : term = + match p with + | Pat_Constant c -> + S.mk_Tm_app ref_Pat_Constant.t [S.as_arg (embed rng c)] rng + | Pat_Cons head univs subpats -> + S.mk_Tm_app ref_Pat_Cons.t + [S.as_arg (embed rng head); + S.as_arg (embed rng univs); + S.as_arg (embed #_ #(e_list (e_tuple2 (e_pattern_aq aq) e_bool)) rng subpats)] rng + | Pat_Var sort ppname -> + S.mk_Tm_app ref_Pat_Var.t [ + S.as_arg (embed #_ #e_sort rng sort); + S.as_arg (embed rng ppname); + ] rng + | Pat_Dot_Term eopt -> + S.mk_Tm_app ref_Pat_Dot_Term.t [S.as_arg (embed #_ #(e_option e_term) rng eopt)] + rng + in + let rec unembed_pattern (t : term) : option pattern = + let? fv, args = head_fv_and_args t in + match () with + | _ when S.fv_eq_lid fv ref_Pat_Constant.lid -> + run args (Pat_Constant <$$> e_vconst) + + | _ when S.fv_eq_lid fv ref_Pat_Cons.lid -> + run args (Pat_Cons <$$> e_fv <**> e_option (e_list e_universe) <**> e_list (e_tuple2 (e_pattern_aq aq) e_bool)) + + | _ when S.fv_eq_lid fv ref_Pat_Var.lid -> + run args (Pat_Var <$$> e_sort <**> e_ppname) + + | _ when S.fv_eq_lid fv ref_Pat_Dot_Term.lid -> + run args (Pat_Dot_Term <$$> e_option e_term) + + | _ -> None + in + mk_emb embed_pattern unembed_pattern fstar_refl_pattern + +let e_pattern = e_pattern_aq noaqs + +let e_branch = e_tuple2 e_pattern e_term +let e_argv = e_tuple2 e_term e_aqualv + +let e_args = e_list e_argv + +let e_branch_aq aq = e_tuple2 (e_pattern_aq aq) (e_term_aq aq) +let e_argv_aq aq = e_tuple2 (e_term_aq aq) e_aqualv + +instance e_match_returns_annotation = + e_option (e_tuple2 e_binder + (e_tuple3 (e_either e_term e_comp) (e_option e_term) e_bool)) + +let e_term_view_aq aq = + let push (s, aq) = (s+1, aq) in + let embed_term_view (rng:Range.range) (t:term_view) : term = + match t with + | Tv_FVar fv -> + S.mk_Tm_app ref_Tv_FVar.t [S.as_arg (embed rng fv)] + rng + + | Tv_BVar fv -> + S.mk_Tm_app ref_Tv_BVar.t [S.as_arg (embed #_ #e_bv rng fv)] + rng + + | Tv_Var bv -> + S.mk_Tm_app ref_Tv_Var.t [S.as_arg (embed #_ #e_namedv rng bv)] + rng + + | Tv_UInst (fv, us) -> + S.mk_Tm_app + ref_Tv_UInst.t + [S.as_arg (embed rng fv); + S.as_arg (embed rng us)] + rng + + | Tv_App (hd, a) -> + S.mk_Tm_app ref_Tv_App.t [S.as_arg (embed #_ #(e_term_aq aq) rng hd); S.as_arg (embed #_ #(e_argv_aq aq) rng a)] + rng + + | Tv_Abs (b, t) -> + S.mk_Tm_app ref_Tv_Abs.t [S.as_arg (embed rng b); S.as_arg (embed #_ #(e_term_aq (push aq)) rng t)] + rng + + | Tv_Arrow (b, c) -> + S.mk_Tm_app ref_Tv_Arrow.t [S.as_arg (embed rng b); S.as_arg (embed rng c)] + rng + + | Tv_Type u -> + S.mk_Tm_app ref_Tv_Type.t [S.as_arg (embed rng u)] + rng + + | Tv_Refine (b, t) -> + S.mk_Tm_app ref_Tv_Refine.t [S.as_arg (embed rng b); + S.as_arg (embed #_ #(e_term_aq (push aq)) rng t)] + rng + + | Tv_Const c -> + S.mk_Tm_app ref_Tv_Const.t [S.as_arg (embed rng c)] + rng + + | Tv_Uvar (u, ctx_u) -> + S.mk_Tm_app ref_Tv_Uvar.t + [S.as_arg (embed rng u); + S.as_arg (embed rng ctx_u)] + rng + + | Tv_Let (r, attrs, b, t1, t2) -> + S.mk_Tm_app ref_Tv_Let.t [S.as_arg (embed rng r); + S.as_arg (embed #_ #(e_list e_term) rng attrs); + S.as_arg (embed rng b); + S.as_arg (embed #_ #(e_term_aq aq) rng t1); + S.as_arg (embed #_ #(e_term_aq (push aq)) rng t2)] + rng + + | Tv_Match (t, ret_opt, brs) -> + S.mk_Tm_app ref_Tv_Match.t [S.as_arg (embed #_ #(e_term_aq aq) rng t); + S.as_arg (embed rng ret_opt); + S.as_arg (embed #_ #(e_list (e_branch_aq aq)) rng brs)] + rng + + | Tv_AscribedT (e, t, tacopt, use_eq) -> + S.mk_Tm_app ref_Tv_AscT.t + [S.as_arg (embed #_ #(e_term_aq aq) rng e); + S.as_arg (embed #_ #(e_term_aq aq) rng t); + S.as_arg (embed #_ #(e_option (e_term_aq aq)) rng tacopt); + S.as_arg (embed rng use_eq)] + rng + + | Tv_AscribedC (e, c, tacopt, use_eq) -> + S.mk_Tm_app ref_Tv_AscC.t + [S.as_arg (embed #_ #(e_term_aq aq) rng e); + S.as_arg (embed rng c); + S.as_arg (embed #_ #(e_option (e_term_aq aq)) rng tacopt); + S.as_arg (embed rng use_eq)] + rng + + | Tv_Unknown -> + { ref_Tv_Unknown.t with pos = rng } + + | Tv_Unsupp -> + { ref_Tv_Unsupp.t with pos = rng } + in + let unembed_term_view (t:term) : option term_view = + let? fv, args = head_fv_and_args t in + let xTv_Let a b c d e = Tv_Let (a,b,c,d,e) in + match () with + | _ when S.fv_eq_lid fv ref_Tv_FVar.lid -> run args (Tv_FVar <$$> e_fv) + | _ when S.fv_eq_lid fv ref_Tv_BVar.lid -> run args (Tv_BVar <$$> e_bv) + | _ when S.fv_eq_lid fv ref_Tv_Var.lid -> run args (Tv_Var <$$> e_namedv) + | _ when S.fv_eq_lid fv ref_Tv_UInst.lid -> run args (curry Tv_UInst <$$> e_fv <**> e_list e_universe) + | _ when S.fv_eq_lid fv ref_Tv_App.lid -> run args (curry Tv_App <$$> e_term_aq aq <**> e_argv_aq aq) + | _ when S.fv_eq_lid fv ref_Tv_Abs.lid -> run args (curry Tv_Abs <$$> e_binder <**> e_term_aq (push aq)) + | _ when S.fv_eq_lid fv ref_Tv_Arrow.lid -> run args (curry Tv_Arrow <$$> e_binder <**> e_comp) + | _ when S.fv_eq_lid fv ref_Tv_Type.lid -> run args (Tv_Type <$$> e_universe) + | _ when S.fv_eq_lid fv ref_Tv_Refine.lid -> run args (curry Tv_Refine <$$> e_binder <**> e_term_aq (push aq)) + | _ when S.fv_eq_lid fv ref_Tv_Const.lid -> run args (Tv_Const <$$> e_vconst) + | _ when S.fv_eq_lid fv ref_Tv_Uvar.lid -> run args (curry Tv_Uvar <$$> e_int <**> e_ctx_uvar_and_subst) + | _ when S.fv_eq_lid fv ref_Tv_Let.lid -> run args (xTv_Let <$$> e_bool <**> e_list e_term <**> e_binder <**> e_term_aq aq <**> e_term_aq (push aq)) + | _ when S.fv_eq_lid fv ref_Tv_Match.lid -> run args (curry3 Tv_Match <$$> e_term_aq aq <**> e_match_returns_annotation <**> e_list (e_branch_aq aq)) + | _ when S.fv_eq_lid fv ref_Tv_AscT.lid -> run args (curry4 Tv_AscribedT <$$> e_term_aq aq <**> e_term_aq aq <**> e_option (e_term_aq aq) <**> e_bool) + | _ when S.fv_eq_lid fv ref_Tv_AscC.lid -> run args (curry4 Tv_AscribedC <$$> e_term_aq aq <**> e_comp <**> e_option (e_term_aq aq) <**> e_bool) + | _ when S.fv_eq_lid fv ref_Tv_Unknown.lid -> run args (pure Tv_Unknown) + | _ when S.fv_eq_lid fv ref_Tv_Unsupp.lid -> run args (pure Tv_Unsupp) + | _ -> None + in + mk_emb embed_term_view unembed_term_view fstar_refl_term_view + +let e_term_view = e_term_view_aq noaqs + +let e_name = e_list e_string + +(* embeds as a string list *) +// instance e_name : embedding I.lid = +// let embed rng lid : term = +// embed rng (I.path_of_lid lid) +// in +// let uu t _norm : option I.lid = +// BU.map_opt (try_unembed t) (fun p -> I.lid_of_path p t.pos) +// in +// EMB.mk_emb_full (fun x r _ _ -> embed r x) +// uu +// (fun () -> t_list_of t_string) +// I.string_of_lid +// (fun () -> ET_abstract) + + +instance e_namedv_view = + let embed_namedv_view (rng:Range.range) (namedvv:namedv_view) : term = + S.mk_Tm_app ref_Mk_namedv_view.t [ + S.as_arg (embed rng namedvv.uniq); + S.as_arg (embed #_ #e_sort rng namedvv.sort); + S.as_arg (embed rng namedvv.ppname); + ] + rng + in + let unembed_namedv_view (t : term) : option namedv_view = + let? fv, args = head_fv_and_args t in + match () with + | _ when S.fv_eq_lid fv ref_Mk_namedv_view.lid -> + run args (Mknamedv_view <$$> e_int <**> e_sort <**> e_ppname) + | _ -> None + in + mk_emb embed_namedv_view unembed_namedv_view fstar_refl_namedv_view + +instance e_bv_view = + let embed_bv_view (rng:Range.range) (bvv:bv_view) : term = + S.mk_Tm_app ref_Mk_bv_view.t [ + S.as_arg (embed rng bvv.index); + S.as_arg (embed #_ #e_sort rng bvv.sort); + S.as_arg (embed rng bvv.ppname); + ] + rng + in + let unembed_bv_view (t : term) : option bv_view = + let? fv, args = head_fv_and_args t in + match () with + | _ when S.fv_eq_lid fv ref_Mk_bv_view.lid -> + run args (Mkbv_view <$$> e_int <**> e_sort <**> e_ppname) + | _ -> None + in + mk_emb embed_bv_view unembed_bv_view fstar_refl_bv_view + +instance e_binding = + let embed (rng:Range.range) (bindingv:RD.binding) : term = + S.mk_Tm_app ref_Mk_binding.t [ + S.as_arg (embed rng bindingv.uniq); + S.as_arg (embed #_ #e_term rng bindingv.sort); + S.as_arg (embed rng bindingv.ppname); + ] + rng + in + let unembed (t : term) : option RD.binding = + let? fv, args = head_fv_and_args t in + match () with + | _ when S.fv_eq_lid fv ref_Mk_binding.lid -> + run args (Mkbinding <$$> e_int <**> e_term <**> e_ppname) + | _ -> None + in + mk_emb embed unembed fstar_refl_binding + +let e_attribute = e_term +let e_attributes = e_list e_attribute + +let e_binder_view = + let embed_binder_view (rng:Range.range) (bview:binder_view) : term = + S.mk_Tm_app ref_Mk_binder_view.t [ + S.as_arg (embed #_ #e_term rng bview.sort); + S.as_arg (embed rng bview.qual); + S.as_arg (embed #_ #e_attributes rng bview.attrs); + S.as_arg (embed rng bview.ppname); + ] + rng in + + let unembed_binder_view (t:term) : option binder_view = + let? fv, args = head_fv_and_args t in + match () with + | _ when S.fv_eq_lid fv ref_Mk_binder_view.lid -> + run args (Mkbinder_view <$$> e_term <**> e_aqualv <**> e_list e_term <**> e_ppname) + | _ -> None + in + mk_emb embed_binder_view unembed_binder_view fstar_refl_binder_view + +let e_comp_view = + let embed_comp_view (rng:Range.range) (cv : comp_view) : term = + match cv with + | C_Total t -> + S.mk_Tm_app ref_C_Total.t [S.as_arg (embed #_ #e_term rng t)] + rng + + | C_GTotal t -> + S.mk_Tm_app ref_C_GTotal.t [S.as_arg (embed #_ #e_term rng t)] + rng + + | C_Lemma (pre, post, pats) -> + S.mk_Tm_app ref_C_Lemma.t [S.as_arg (embed #_ #e_term rng pre); + S.as_arg (embed #_ #e_term rng post); + S.as_arg (embed #_ #e_term rng pats)] + rng + + | C_Eff (us, eff, res, args, decrs) -> + S.mk_Tm_app ref_C_Eff.t + [ S.as_arg (embed rng us) + ; S.as_arg (embed rng eff) + ; S.as_arg (embed #_ #e_term rng res) + ; S.as_arg (embed #_ #(e_list e_argv) rng args) + ; S.as_arg (embed #_ #(e_list e_term) rng decrs)] rng + + + in + let unembed_comp_view (t : term) : option comp_view = + let? fv, args = head_fv_and_args t in + match () with + | _ when S.fv_eq_lid fv ref_C_Total.lid -> run args (C_Total <$$> e_term) + | _ when S.fv_eq_lid fv ref_C_GTotal.lid -> run args (C_GTotal <$$> e_term) + | _ when S.fv_eq_lid fv ref_C_Lemma.lid -> + run args (curry3 C_Lemma <$$> e_term <**> e_term <**> e_term) + | _ when S.fv_eq_lid fv ref_C_Eff.lid -> + run args (curry5 C_Eff <$$> e_list e_universe <**> e_string_list <**> e_term <**> e_list e_argv <**> e_list e_term) + | _ -> None + in + mk_emb embed_comp_view unembed_comp_view fstar_refl_comp_view + +let e_univ_name = e_ident +let e_univ_names = e_list e_univ_name + +let e_subst_elt = + let ee (rng:Range.range) (e:subst_elt) : term = + match e with + | DB (i, x) -> + S.mk_Tm_app ref_DB.t [ + S.as_arg (embed rng i); + S.as_arg (embed #_ #e_namedv rng x); + ] + rng + + | DT (i, t) -> + S.mk_Tm_app ref_DT.t [ + S.as_arg (embed rng i); + S.as_arg (embed #_ #e_term rng t); + ] + rng + + | NM (x, i) -> + S.mk_Tm_app ref_NM.t [ + S.as_arg (embed #_ #e_namedv rng x); + S.as_arg (embed rng i); + ] + rng + + | NT (x, t) -> + S.mk_Tm_app ref_NT.t [ + S.as_arg (embed #_ #e_namedv rng x); + S.as_arg (embed #_ #e_term rng t); + ] + rng + + | UN (i, u) -> + S.mk_Tm_app ref_UN.t [ + S.as_arg (embed rng i); + S.as_arg (embed rng u); + ] + rng + + | UD (u, i) -> + S.mk_Tm_app ref_UD.t [ + S.as_arg (embed rng u); + S.as_arg (embed rng i); + ] + rng + in + let uu (t:term) : option subst_elt = + let? fv, args = head_fv_and_args t in + match () with + | _ when S.fv_eq_lid fv ref_DB.lid -> + run args (curry DB <$$> e_fsint <**> e_namedv) + | _ when S.fv_eq_lid fv ref_DT.lid -> + run args (curry DT <$$> e_fsint <**> e_term) + | _ when S.fv_eq_lid fv ref_NM.lid -> + run args (curry NM <$$> e_namedv <**> e_fsint) + | _ when S.fv_eq_lid fv ref_NT.lid -> + run args (curry NT <$$> e_namedv <**> e_term) + | _ when S.fv_eq_lid fv ref_UN.lid -> + run args (curry UN <$$> e_fsint <**> e_universe) + | _ when S.fv_eq_lid fv ref_UD.lid -> + run args (curry UD <$$> e_ident <**> e_fsint) + | _ -> None + in + mk_emb ee uu fstar_refl_subst_elt + +let e_subst = e_list e_subst_elt +let e_ctor = e_tuple2 (e_string_list) e_term + +let e_lb_view = + let embed_lb_view (rng:Range.range) (lbv:lb_view) : term = + S.mk_Tm_app ref_Mk_lb.t [S.as_arg (embed rng lbv.lb_fv); + S.as_arg (embed rng lbv.lb_us); + S.as_arg (embed #_ #e_term rng lbv.lb_typ); + S.as_arg (embed #_ #e_term rng lbv.lb_def)] + rng + in + let unembed_lb_view (t : term) : option lb_view = + let? fv, args = head_fv_and_args t in + match () with + | _ when S.fv_eq_lid fv ref_Mk_lb.lid -> + run args (Mklb_view <$$> e_fv <**> e_univ_names <**> e_term <**> e_term) + | _ -> None + in + mk_emb embed_lb_view unembed_lb_view fstar_refl_lb_view + +let e_sigelt_view = + let embed_sigelt_view (rng:Range.range) (sev:sigelt_view) : term = + match sev with + | Sg_Let (r, lbs) -> + S.mk_Tm_app ref_Sg_Let.t + [S.as_arg (embed rng r); + S.as_arg (embed rng lbs)] + rng + + | Sg_Inductive (nm, univs, bs, t, dcs) -> + S.mk_Tm_app ref_Sg_Inductive.t + [S.as_arg (embed rng nm); + S.as_arg (embed rng univs); + S.as_arg (embed rng bs); + S.as_arg (embed #_ #e_term rng t); + S.as_arg (embed #_ #(e_list e_ctor) rng dcs)] + rng + + | Sg_Val (nm, univs, t) -> + S.mk_Tm_app ref_Sg_Val.t + [S.as_arg (embed rng nm); + S.as_arg (embed rng univs); + S.as_arg (embed #_ #e_term rng t)] + rng + + | Unk -> + { ref_Unk.t with pos = rng } + in + let unembed_sigelt_view (t:term) : option sigelt_view = + let? fv, args = head_fv_and_args t in + match () with + | _ when S.fv_eq_lid fv ref_Sg_Inductive.lid -> + run args (curry5 Sg_Inductive <$$> e_string_list <**> e_univ_names <**> e_binders <**> e_term <**> e_list e_ctor) + | _ when S.fv_eq_lid fv ref_Sg_Let.lid -> + run args (curry Sg_Let <$$> e_bool <**> e_list e_letbinding) + | _ when S.fv_eq_lid fv ref_Sg_Val.lid -> + run args (curry3 Sg_Val <$$> e_string_list <**> e_univ_names <**> e_term) + | _ when S.fv_eq_lid fv ref_Unk.lid -> + run args (pure Unk) + | _ -> None + in + mk_emb embed_sigelt_view unembed_sigelt_view fstar_refl_sigelt_view + +let e_qualifier = + let embed (rng:Range.range) (q:RD.qualifier) : term = + let r = + match q with + | RD.Assumption -> ref_qual_Assumption.t + | RD.InternalAssumption -> ref_qual_InternalAssumption.t + | RD.New -> ref_qual_New.t + | RD.Private -> ref_qual_Private.t + | RD.Unfold_for_unification_and_vcgen -> ref_qual_Unfold_for_unification_and_vcgen.t + | RD.Visible_default -> ref_qual_Visible_default.t + | RD.Irreducible -> ref_qual_Irreducible.t + | RD.Inline_for_extraction -> ref_qual_Inline_for_extraction.t + | RD.NoExtract -> ref_qual_NoExtract.t + | RD.Noeq -> ref_qual_Noeq.t + | RD.Unopteq -> ref_qual_Unopteq.t + | RD.TotalEffect -> ref_qual_TotalEffect.t + | RD.Logic -> ref_qual_Logic.t + | RD.Reifiable -> ref_qual_Reifiable.t + | RD.ExceptionConstructor -> ref_qual_ExceptionConstructor.t + | RD.HasMaskedEffect -> ref_qual_HasMaskedEffect.t + | RD.Effect -> ref_qual_Effect.t + | RD.OnlyName -> ref_qual_OnlyName.t + | RD.Reflectable l -> + S.mk_Tm_app ref_qual_Reflectable.t [S.as_arg (embed rng l)] + Range.dummyRange + + | RD.Discriminator l -> + S.mk_Tm_app ref_qual_Discriminator.t [S.as_arg (embed rng l)] + Range.dummyRange + + | RD.Action l -> + S.mk_Tm_app ref_qual_Action.t [S.as_arg (embed rng l)] + Range.dummyRange + + | RD.Projector (l, i) -> + S.mk_Tm_app ref_qual_Projector.t [S.as_arg (embed rng (l, i))] + Range.dummyRange + + | RD.RecordType (ids1, ids2) -> + S.mk_Tm_app ref_qual_RecordType.t [S.as_arg (embed rng (ids1, ids2))] + Range.dummyRange + + | RD.RecordConstructor (ids1, ids2) -> + S.mk_Tm_app ref_qual_RecordConstructor.t [S.as_arg (embed rng (ids1, ids2))] + Range.dummyRange + + in { r with pos = rng } + in + let unembed (t: term) : option RD.qualifier = + let? fv, args = head_fv_and_args t in + match () with + | _ when S.fv_eq_lid fv ref_qual_Assumption.lid -> run args (pure RD.Assumption) + | _ when S.fv_eq_lid fv ref_qual_InternalAssumption.lid -> run args (pure RD.InternalAssumption) + | _ when S.fv_eq_lid fv ref_qual_New.lid -> run args (pure RD.New) + | _ when S.fv_eq_lid fv ref_qual_Private.lid -> run args (pure RD.Private) + | _ when S.fv_eq_lid fv ref_qual_Unfold_for_unification_and_vcgen.lid -> run args (pure RD.Unfold_for_unification_and_vcgen) + | _ when S.fv_eq_lid fv ref_qual_Visible_default.lid -> run args (pure RD.Visible_default) + | _ when S.fv_eq_lid fv ref_qual_Irreducible.lid -> run args (pure RD.Irreducible) + | _ when S.fv_eq_lid fv ref_qual_Inline_for_extraction.lid -> run args (pure RD.Inline_for_extraction) + | _ when S.fv_eq_lid fv ref_qual_NoExtract.lid -> run args (pure RD.NoExtract) + | _ when S.fv_eq_lid fv ref_qual_Noeq.lid -> run args (pure RD.Noeq) + | _ when S.fv_eq_lid fv ref_qual_Unopteq.lid -> run args (pure RD.Unopteq) + | _ when S.fv_eq_lid fv ref_qual_TotalEffect.lid -> run args (pure RD.TotalEffect) + | _ when S.fv_eq_lid fv ref_qual_Logic.lid -> run args (pure RD.Logic) + | _ when S.fv_eq_lid fv ref_qual_Reifiable.lid -> run args (pure RD.Reifiable) + | _ when S.fv_eq_lid fv ref_qual_ExceptionConstructor.lid -> run args (pure RD.ExceptionConstructor) + | _ when S.fv_eq_lid fv ref_qual_HasMaskedEffect.lid -> run args (pure RD.HasMaskedEffect) + | _ when S.fv_eq_lid fv ref_qual_Effect.lid -> run args (pure RD.Effect) + | _ when S.fv_eq_lid fv ref_qual_OnlyName.lid -> run args (pure RD.OnlyName) + | _ when S.fv_eq_lid fv ref_qual_Reflectable.lid -> + run args (RD.Reflectable <$$> e_name) + | _ when S.fv_eq_lid fv ref_qual_Discriminator.lid -> + run args (RD.Discriminator <$$> e_name) + | _ when S.fv_eq_lid fv ref_qual_Action.lid -> + run args (RD.Action <$$> e_name) + | _ when S.fv_eq_lid fv ref_qual_Projector.lid -> + run args (RD.Projector <$$> e_tuple2 e_name e_ident) + | _ when S.fv_eq_lid fv ref_qual_RecordType.lid -> + run args (RD.RecordType <$$> e_tuple2 (e_list e_ident) (e_list e_ident)) + | _ when S.fv_eq_lid fv ref_qual_RecordConstructor.lid -> + run args (RD.RecordConstructor <$$> e_tuple2 (e_list e_ident) (e_list e_ident)) + | _ -> None + in + mk_emb embed unembed fstar_refl_qualifier + +let e_qualifiers = e_list e_qualifier + +(* -------------------------------------------------------------------------------------- *) +(* ------------------------------------- UNFOLDINGS ------------------------------------- *) +(* -------------------------------------------------------------------------------------- *) + + +(* Note that most of these are never needed during normalization, since + * the types are abstract. + *) + +let unfold_lazy_bv (i : lazyinfo) : term = + let bv : bv = undyn i.blob in + S.mk_Tm_app fstar_refl_pack_bv.t [S.as_arg (embed i.rng (inspect_bv bv))] + i.rng + +let unfold_lazy_namedv (i : lazyinfo) : term = + let namedv : namedv = undyn i.blob in + S.mk_Tm_app fstar_refl_pack_namedv.t [S.as_arg (embed i.rng (inspect_namedv namedv))] + i.rng + +let unfold_lazy_binder (i : lazyinfo) : term = + let binder : binder = undyn i.blob in + S.mk_Tm_app fstar_refl_pack_binder.t [S.as_arg (embed i.rng (inspect_binder binder))] + i.rng + +let unfold_lazy_letbinding (i : lazyinfo) : term = + let lb : letbinding = undyn i.blob in + let lbv = inspect_lb lb in + S.mk_Tm_app fstar_refl_pack_lb.t + [ + S.as_arg (embed i.rng lbv.lb_fv); + S.as_arg (embed i.rng lbv.lb_us); + S.as_arg (embed #_ #e_term i.rng lbv.lb_typ); + S.as_arg (embed #_ #e_term i.rng lbv.lb_def) + ] + i.rng + +let unfold_lazy_fvar (i : lazyinfo) : term = + let fv : fv = undyn i.blob in + S.mk_Tm_app fstar_refl_pack_fv.t [S.as_arg (embed i.rng (inspect_fv fv))] + i.rng + +let unfold_lazy_comp (i : lazyinfo) : term = + let comp : comp = undyn i.blob in + S.mk_Tm_app fstar_refl_pack_comp.t [S.as_arg (embed i.rng (inspect_comp comp))] + i.rng + +let unfold_lazy_env (i : lazyinfo) : term = + (* Not needed, metaprograms never see concrete environments. *) + U.exp_unit + +let unfold_lazy_optionstate (i : lazyinfo) : term = + (* Not needed, metaprograms never see concrete optionstates . *) + U.exp_unit + +let unfold_lazy_sigelt (i : lazyinfo) : term = + let sigelt : sigelt = undyn i.blob in + S.mk_Tm_app fstar_refl_pack_sigelt.t [S.as_arg (embed i.rng (inspect_sigelt sigelt))] + i.rng + +let unfold_lazy_universe (i : lazyinfo) : term = + let u : universe = undyn i.blob in + S.mk_Tm_app fstar_refl_pack_universe.t [S.as_arg (embed i.rng (inspect_universe u))] + i.rng + +let unfold_lazy_doc (i : lazyinfo) : term = + let open FStarC.Pprint in + let d : Pprint.document = undyn i.blob in + let lid = Ident.lid_of_str "FStar.Stubs.Pprint.arbitrary_string" in + let s = Pprint.render d in + S.mk_Tm_app (S.fvar lid None) [S.as_arg (embed i.rng s)] + i.rng diff --git a/src/reflection/FStarC.Reflection.V2.Embeddings.fsti b/src/reflection/FStarC.Reflection.V2.Embeddings.fsti new file mode 100644 index 00000000000..f266e362a06 --- /dev/null +++ b/src/reflection/FStarC.Reflection.V2.Embeddings.fsti @@ -0,0 +1,80 @@ +(* + Copyright 2008-2022 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Reflection.V2.Embeddings + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Syntax.Syntax +open FStarC.Syntax.Embeddings +open FStar.Order +open FStarC.TypeChecker.Env +open FStarC.Reflection.V2.Data +module O = FStarC.Options +module RD = FStarC.Reflection.V2.Data + +(* FIXME: create a Reflection.Types module internally? *) +type namedv = bv + +(* Embeddings *) +val e_bv : embedding bv +val e_namedv : embedding namedv +(* Sadly these two cannot be instances: they are the same type! *) +instance val e_binding : embedding RD.binding +instance val e_binder : embedding binder +instance val e_binder_view : embedding binder_view +instance val e_binders : embedding binders +(* not instance *) val e_term : embedding term +instance val e_term_view : embedding term_view +instance val e_fv : embedding fv +instance val e_comp : embedding comp +instance val e_comp_view : embedding comp_view +instance val e_vconst : embedding vconst +instance val e_env : embedding FStarC.TypeChecker.Env.env +instance val e_pattern : embedding pattern +instance val e_branch : embedding Data.branch +instance val e_aqualv : embedding aqualv +instance val e_argv : embedding argv +instance val e_sigelt : embedding sigelt +instance val e_letbinding : embedding letbinding +instance val e_lb_view : embedding lb_view +instance val e_sigelt_view : embedding sigelt_view +instance val e_namedv_view : embedding namedv_view +instance val e_bv_view : embedding bv_view + val e_attribute : embedding attribute +instance val e_qualifier : embedding RD.qualifier +instance val e_ident : embedding Ident.ident +instance val e_univ_name : embedding univ_name +instance val e_universe : embedding universe +instance val e_universe_view : embedding universe_view +instance val e_subst_elt : embedding subst_elt + +(* Useful for embedding antiquoted terms. They are only used for the embedding part, + * so this is a bit hackish. *) +val e_term_aq : antiquotations -> embedding term +val e_term_view_aq : antiquotations -> embedding term_view + +(* Lazy unfoldings *) +val unfold_lazy_bv : lazyinfo -> term +val unfold_lazy_namedv : lazyinfo -> term +val unfold_lazy_fvar : lazyinfo -> term +val unfold_lazy_binder : lazyinfo -> term +val unfold_lazy_optionstate : lazyinfo -> term +val unfold_lazy_comp : lazyinfo -> term +val unfold_lazy_env : lazyinfo -> term +val unfold_lazy_sigelt : lazyinfo -> term +val unfold_lazy_letbinding : lazyinfo -> term +val unfold_lazy_universe : lazyinfo -> term +val unfold_lazy_doc : lazyinfo -> term diff --git a/src/reflection/FStarC.Reflection.V2.Interpreter.fst b/src/reflection/FStarC.Reflection.V2.Interpreter.fst new file mode 100644 index 00000000000..2791e708557 --- /dev/null +++ b/src/reflection/FStarC.Reflection.V2.Interpreter.fst @@ -0,0 +1,206 @@ +(* + Copyright 2008-2022 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Reflection.V2.Interpreter + +module EMB = FStarC.Syntax.Embeddings +module NBET = FStarC.TypeChecker.NBETerm +module NRE = FStarC.Reflection.V2.NBEEmbeddings +module PO = FStarC.TypeChecker.Primops +module RB = FStarC.Reflection.V2.Builtins +module RE = FStarC.Reflection.V2.Embeddings +open FStarC.Syntax.Syntax +open FStarC.Reflection.V2.Constants + +let solve (#a: Type) {| ev: a |} : Tot a = ev + +(* NB: assuming uarity = 0 for these three. Also, they are homogenous in KAM and NBE. *) + +val mk1 : + string -> + {| EMB.embedding 't1 |} -> + {| EMB.embedding 'res |} -> + {| NBET.embedding 't1 |} -> + {| NBET.embedding 'res |} -> + ('t1 -> 'res) -> + PO.primitive_step +let mk1 nm f = + let lid = fstar_refl_builtins_lid nm in + PO.mk1' 0 lid + (fun x -> f x |> Some) + (fun x -> f x |> Some) + +val mk2 : + string -> + {| EMB.embedding 't1 |} -> + {| EMB.embedding 't2 |} -> + {| EMB.embedding 'res |} -> + {| NBET.embedding 't1 |} -> + {| NBET.embedding 't2 |} -> + {| NBET.embedding 'res |} -> + ('t1 -> 't2 -> 'res) -> + PO.primitive_step +let mk2 nm f = + let lid = fstar_refl_builtins_lid nm in + PO.mk2' 0 lid + (fun x y -> f x y |> Some) + (fun x y -> f x y |> Some) + +val mk3 : + string -> + {| EMB.embedding 't1 |} -> + {| EMB.embedding 't2 |} -> + {| EMB.embedding 't3 |} -> + {| EMB.embedding 'res |} -> + {| NBET.embedding 't1 |} -> + {| NBET.embedding 't2 |} -> + {| NBET.embedding 't3 |} -> + {| NBET.embedding 'res |} -> + ('t1 -> 't2 -> 't3 -> 'res) -> + PO.primitive_step +let mk3 nm f = + let lid = fstar_refl_builtins_lid nm in + PO.mk3' 0 lid + (fun x y z -> f x y z |> Some) + (fun x y z -> f x y z |> Some) + +(* + * NOTE: all primitives must be carefully inspected to make sure they + * do not break the abstraction barrier imposed by the term_view. + * Otherwise, the pack_inspect_inv and inspect_pack_inv lemmas could + * likely be used to derive a contradiction. + * + * The way to go about adding new primitives is to implement them in the + * FStarC.Reflection.V2.Builtins module and implement them using the (internal) + * inspect_ln and pack_ln functions, which means they should not break + * the view abstraction. + * + * _Any_ call to functions elsewhere, say term_to_string or + * Util.term_eq, will _very likely_ be inconsistent with the view. + * Exceptions to the "way to go" above should be well justified. + *) +let reflection_primops : list PO.primitive_step = [ + (****** Inspecting/packing various kinds of syntax ******) + mk1 "inspect_ln" + #RE.e_term #_ + #NRE.e_term #_ + RB.inspect_ln; + + mk1 "pack_ln" + #_ #RE.e_term + #_ #NRE.e_term + RB.pack_ln; + + mk1 "inspect_fv" RB.inspect_fv; + mk1 "pack_fv" RB.pack_fv; + mk1 "inspect_comp" RB.inspect_comp; + mk1 "pack_comp" RB.pack_comp; + mk1 "inspect_universe" RB.inspect_universe; + mk1 "pack_universe" RB.pack_universe; + mk1 "inspect_sigelt" RB.inspect_sigelt; + mk1 "pack_sigelt" RB.pack_sigelt; + mk1 "inspect_lb" RB.inspect_lb; + mk1 "pack_lb" RB.pack_lb; + mk1 "inspect_namedv" + #RE.e_namedv #RE.e_namedv_view + #NRE.e_namedv #NRE.e_namedv_view + RB.inspect_namedv; + mk1 "pack_namedv" + #RE.e_namedv_view #RE.e_namedv + #NRE.e_namedv_view #NRE.e_namedv + RB.pack_namedv; + mk1 "inspect_bv" + #RE.e_bv #RE.e_bv_view + #NRE.e_bv #NRE.e_bv_view + RB.inspect_bv; + mk1 "pack_bv" + #RE.e_bv_view #RE.e_bv + #NRE.e_bv_view #NRE.e_bv + RB.pack_bv; + mk1 "inspect_binder" RB.inspect_binder; + mk1 "pack_binder" RB.pack_binder; + + (****** Actual primitives ******) + + mk1 "sigelt_opts" RB.sigelt_opts; + mk1 "embed_vconfig" + #_ #RE.e_term + RB.embed_vconfig; + + mk1 "sigelt_attrs" + #_ #(EMB.e_list RE.e_term) + RB.sigelt_attrs; + + mk2 "set_sigelt_attrs" + #(EMB.e_list RE.e_term) + RB.set_sigelt_attrs; + + mk1 "sigelt_quals" RB.sigelt_quals; + mk2 "set_sigelt_quals" RB.set_sigelt_quals; + mk2 "subst_term" + #_ #RE.e_term #RE.e_term + RB.subst_term; + + mk2 "subst_comp" RB.subst_comp; + mk2 "compare_bv" + #RE.e_bv #RE.e_bv #_ + #NRE.e_bv #NRE.e_bv #_ + RB.compare_bv; + mk2 "compare_namedv" + #RE.e_namedv #RE.e_namedv #_ + #NRE.e_namedv #NRE.e_namedv #_ + RB.compare_namedv; + + mk2 "lookup_attr_ses" + #RE.e_term + RB.lookup_attr_ses; + + mk2 "lookup_attr" + #RE.e_term + RB.lookup_attr; + + mk1 "all_defs_in_env" RB.all_defs_in_env; + mk2 "defs_in_module" RB.defs_in_module; + + mk2 "term_eq" + #RE.e_term #RE.e_term + RB.term_eq; + + mk1 "moduleof" RB.moduleof; + mk1 "vars_of_env" RB.vars_of_env; + mk2 "lookup_typ" RB.lookup_typ; + mk1 "env_open_modules" RB.env_open_modules; + + (* See note in ulib/FStarC.Reflection.V2.Builints.fsti: we expose these + three to reduce dependencies. *) + mk1 "implode_qn" RB.implode_qn; + + mk1 "explode_qn" RB.explode_qn; + mk2 "compare_string" RB.compare_string; + mk2 "push_namedv" + #_ #RE.e_namedv #_ + #_ #NRE.e_namedv #_ + RB.push_namedv; + + mk1 "range_of_term" + #RE.e_term + RB.range_of_term; + + mk1 "range_of_sigelt" RB.range_of_sigelt; + mk1 "inspect_ident" RB.inspect_ident; + mk1 "pack_ident" RB.pack_ident; +] + +let _ = List.iter FStarC.TypeChecker.Cfg.register_extra_step reflection_primops diff --git a/src/reflection/FStarC.Reflection.V2.Interpreter.fsti b/src/reflection/FStarC.Reflection.V2.Interpreter.fsti new file mode 100644 index 00000000000..76c43f46272 --- /dev/null +++ b/src/reflection/FStarC.Reflection.V2.Interpreter.fsti @@ -0,0 +1,19 @@ +(* + Copyright 2008-2022 Microsof Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Reflection.V2.Interpreter + +(* This module only has an initialization effect of registering +many primitive steps in the normalizer. *) diff --git a/src/reflection/FStarC.Reflection.V2.NBEEmbeddings.fst b/src/reflection/FStarC.Reflection.V2.NBEEmbeddings.fst new file mode 100644 index 00000000000..e4340f339f7 --- /dev/null +++ b/src/reflection/FStarC.Reflection.V2.NBEEmbeddings.fst @@ -0,0 +1,988 @@ +(* + Copyright 2008-2022 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Reflection.V2.NBEEmbeddings +open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStar.Pervasives +open FStarC.Reflection.V2.Data +open FStarC.Syntax.Syntax +open FStarC.TypeChecker.NBETerm +open FStarC.Compiler.Order +open FStarC.Errors +open FStarC.Dyn +open FStarC.Reflection.V2.Constants + +module BU = FStarC.Compiler.Util +module Env = FStarC.TypeChecker.Env +module Err = FStarC.Errors +module I = FStarC.Ident +module NBETerm = FStarC.TypeChecker.NBETerm +module O = FStarC.Options +module PC = FStarC.Parser.Const +module Range = FStarC.Compiler.Range +module S = FStarC.Syntax.Syntax // TODO: remove, it's open +module SS = FStarC.Syntax.Subst +module U = FStarC.Syntax.Util +module Z = FStarC.BigInt + +(* + * embed : from compiler to user + * unembed : from user to compiler + *) + +let noaqs : antiquotations = (0, []) + +(* -------------------------------------------------------------------------------------- *) +(* ------------------------------------- EMBEDDINGS ------------------------------------- *) +(* -------------------------------------------------------------------------------------- *) + +(* PLEASE NOTE: Construct and FV accumulate their arguments BACKWARDS. That is, + * the expression (f 1 2) is stored as FV (f, [], [Constant (Int 2); Constant (Int 1)]. + * So be careful when calling mkFV/mkConstruct and matching on them. *) + +(* On that note, we use this (inefficient, FIXME) hack in this module *) +let mkFV fv us ts = mkFV fv (List.rev us) (List.rev ts) +let mkConstruct fv us ts = mkConstruct fv (List.rev us) (List.rev ts) +(* ^ We still need to match on them in reverse order though, so this is pretty dumb *) + +let fv_as_emb_typ fv = S.ET_app (FStarC.Ident.string_of_lid fv.fv_name.v, []) +let mk_emb' x y fv = mk_emb x y (fun () -> mkFV fv [] []) (fun () -> fv_as_emb_typ fv) + +let mk_lazy cb obj ty kind = + let li = { + blob = FStarC.Dyn.mkdyn obj + ; lkind = kind + ; ltyp = ty + ; rng = Range.dummyRange + } + in + let thunk = Thunk.mk (fun () -> translate_cb cb (U.unfold_lazy li)) in + mk_t (Lazy (Inl li, thunk)) + +let e_bv = + let embed_bv cb (bv:bv) : t = + mk_lazy cb bv fstar_refl_bv Lazy_bv + in + let unembed_bv cb (t:t) : option bv = + match t.nbe_t with + | Lazy (Inl {blob=b; lkind=Lazy_bv}, _) -> + Some <| FStarC.Dyn.undyn b + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded bv: %s" (t_to_string t)); + None + in + mk_emb' embed_bv unembed_bv fstar_refl_bv_fv + +let e_namedv = + let embed_namedv cb (namedv:namedv) : t = + mk_lazy cb namedv fstar_refl_namedv Lazy_namedv + in + let unembed_namedv cb (t:t) : option namedv = + match t.nbe_t with + | Lazy (Inl {blob=b; lkind=Lazy_namedv}, _) -> + Some <| FStarC.Dyn.undyn b + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded namedv: %s" (t_to_string t)); + None + in + mk_emb' embed_namedv unembed_namedv fstar_refl_namedv_fv + +let e_binder = + let embed_binder cb (b:binder) : t = + mk_lazy cb b fstar_refl_binder Lazy_binder + in + let unembed_binder cb (t:t) : option binder = + match t.nbe_t with + | Lazy (Inl {blob=b; lkind=Lazy_binder}, _) -> + Some (undyn b) + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded binder: %s" (t_to_string t)); + None + in + mk_emb' embed_binder unembed_binder fstar_refl_binder_fv + +let rec mapM_opt (f : ('a -> option 'b)) (l : list 'a) : option (list 'b) = + match l with + | [] -> Some [] + | x::xs -> + BU.bind_opt (f x) (fun x -> + BU.bind_opt (mapM_opt f xs) (fun xs -> + Some (x :: xs))) + +let e_term_aq aq = + let embed_term cb (t:term) : NBETerm.t = + let qi = { qkind = Quote_static; antiquotations = aq } in + mk_t (NBETerm.Quote (t, qi)) + in + let unembed_term cb (t:NBETerm.t) : option term = + match t.nbe_t with + | NBETerm.Quote (tm, qi) -> + (* Just reuse the code from Reflection *) + Syntax.Embeddings.unembed #_ #(Reflection.V2.Embeddings.e_term_aq (0, [])) (S.mk (Tm_quoted (tm, qi)) Range.dummyRange) Syntax.Embeddings.id_norm_cb + | _ -> + None + in + { NBETerm.em = embed_term + ; NBETerm.un = unembed_term + ; NBETerm.typ = (fun () -> mkFV fstar_refl_term_fv [] []) + ; NBETerm.e_typ = (fun () -> fv_as_emb_typ fstar_refl_term_fv ) + } + +let e_term = e_term_aq (0, []) + +let e_sort = e_sealed e_term +let e_ppname = e_sealed e_string + +let e_aqualv = + let embed_aqualv cb (q : aqualv) : t = + match q with + | Data.Q_Explicit -> mkConstruct ref_Q_Explicit.fv [] [] + | Data.Q_Implicit -> mkConstruct ref_Q_Implicit.fv [] [] + | Data.Q_Meta t -> mkConstruct ref_Q_Meta.fv [] [as_arg (embed e_term cb t)] + in + let unembed_aqualv cb (t : t) : option aqualv = + match t.nbe_t with + | Construct (fv, [], []) when S.fv_eq_lid fv ref_Q_Explicit.lid -> Some Data.Q_Explicit + | Construct (fv, [], []) when S.fv_eq_lid fv ref_Q_Implicit.lid -> Some Data.Q_Implicit + | Construct (fv, [], [(t, _)]) when S.fv_eq_lid fv ref_Q_Meta.lid -> + BU.bind_opt (unembed e_term cb t) (fun t -> + Some (Data.Q_Meta t)) + + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded aqualv: %s" (t_to_string t)); + None + in + mk_emb embed_aqualv unembed_aqualv + (fun () -> mkConstruct fstar_refl_aqualv_fv [] []) + (fun () -> fv_as_emb_typ fstar_refl_aqualv_fv) + +let e_binders = e_list e_binder + +let e_fv = + let embed_fv cb (fv:fv) : t = + mk_lazy cb fv fstar_refl_fv Lazy_fvar + in + let unembed_fv cb (t:t) : option fv = + match t.nbe_t with + | Lazy (Inl {blob=b; lkind=Lazy_fvar}, _) -> + Some (undyn b) + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded fvar: %s" (t_to_string t)); + None + in + mk_emb' embed_fv unembed_fv fstar_refl_fv_fv + +let e_comp = + let embed_comp cb (c:S.comp) : t = + mk_lazy cb c fstar_refl_comp Lazy_comp + in + let unembed_comp cb (t:t) : option S.comp = + match t.nbe_t with + | Lazy (Inl {blob=b; lkind=Lazy_comp}, _) -> + Some (undyn b) + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded comp: %s" (t_to_string t)); + None + in + mk_emb' embed_comp unembed_comp fstar_refl_comp_fv + +let e_env = + let embed_env cb (e:Env.env) : t = + mk_lazy cb e fstar_refl_env Lazy_env + in + let unembed_env cb (t:t) : option Env.env = + match t.nbe_t with + | Lazy (Inl {blob=b; lkind=Lazy_env}, _) -> + Some (undyn b) + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded env: %s" (t_to_string t)); + None + in + mk_emb' embed_env unembed_env fstar_refl_env_fv + +let e_vconst = + let embed_const cb (c:vconst) : t = + match c with + | C_Unit -> mkConstruct ref_C_Unit.fv [] [] + | C_True -> mkConstruct ref_C_True.fv [] [] + | C_False -> mkConstruct ref_C_False.fv [] [] + | C_Int i -> mkConstruct ref_C_Int.fv [] [as_arg (mk_t <| Constant (Int i))] + | C_String s -> mkConstruct ref_C_String.fv [] [as_arg (embed e_string cb s)] + | C_Range r -> mkConstruct ref_C_Range.fv [] [as_arg (embed e_range cb r)] + | C_Reify -> mkConstruct ref_C_Reify.fv [] [] + | C_Reflect ns -> mkConstruct ref_C_Reflect.fv [] [as_arg (embed e_string_list cb ns)] + in + let unembed_const cb (t:t) : option vconst = + match t.nbe_t with + | Construct (fv, [], []) when S.fv_eq_lid fv ref_C_Unit.lid -> + Some C_Unit + + | Construct (fv, [], []) when S.fv_eq_lid fv ref_C_True.lid -> + Some C_True + + | Construct (fv, [], []) when S.fv_eq_lid fv ref_C_False.lid -> + Some C_False + + | Construct (fv, [], [(i, _)]) when S.fv_eq_lid fv ref_C_Int.lid -> + BU.bind_opt (unembed e_int cb i) (fun i -> + Some <| C_Int i) + + | Construct (fv, [], [(s, _)]) when S.fv_eq_lid fv ref_C_String.lid -> + BU.bind_opt (unembed e_string cb s) (fun s -> + Some <| C_String s) + + | Construct (fv, [], [(r, _)]) when S.fv_eq_lid fv ref_C_Range.lid -> + BU.bind_opt (unembed e_range cb r) (fun r -> + Some <| C_Range r) + + | Construct (fv, [], []) when S.fv_eq_lid fv ref_C_Reify.lid -> + Some C_Reify + + | Construct (fv, [], [(ns, _)]) when S.fv_eq_lid fv ref_C_Reflect.lid -> + BU.bind_opt (unembed e_string_list cb ns) (fun ns -> + Some <| C_Reflect ns) + + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded vconst: %s" (t_to_string t)); + None + in + mk_emb' embed_const unembed_const fstar_refl_vconst_fv + +let e_universe = + let embed_universe cb (u:universe) : t = + mk_lazy cb u fstar_refl_universe Lazy_universe in + let unembed_universe cb (t:t) : option S.universe = + match t.nbe_t with + | Lazy (Inl {blob=b; lkind=Lazy_universe}, _) -> + Some (undyn b) + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded + (BU.format1 "Not an embedded universe: %s" (t_to_string t)); + None + in + mk_emb' embed_universe unembed_universe fstar_refl_universe_fv + +let rec e_pattern_aq aq = + let embed_pattern cb (p : pattern) : t = + match p with + | Pat_Constant c -> + mkConstruct ref_Pat_Constant.fv [] [as_arg (embed e_vconst cb c)] + | Pat_Cons fv us_opt ps -> + mkConstruct ref_Pat_Cons.fv [] + [as_arg (embed e_fv cb fv); + as_arg (embed (e_option (e_list e_universe)) cb us_opt); + as_arg (embed (e_list (e_tuple2 (e_pattern_aq aq) e_bool)) cb ps)] + | Pat_Var sort ppname -> + mkConstruct ref_Pat_Var.fv [] [as_arg (embed e_sort cb sort); as_arg (embed e_ppname cb ppname)] + | Pat_Dot_Term eopt -> + mkConstruct ref_Pat_Dot_Term.fv [] [as_arg (embed (e_option e_term) cb eopt)] + in + let unembed_pattern cb (t : t) : option pattern = + match t.nbe_t with + | Construct (fv, [], [(c, _)]) when S.fv_eq_lid fv ref_Pat_Constant.lid -> + BU.bind_opt (unembed e_vconst cb c) (fun c -> + Some <| Pat_Constant c) + + | Construct (fv, [], [(ps, _); (us_opt, _); (f, _)]) when S.fv_eq_lid fv ref_Pat_Cons.lid -> + BU.bind_opt (unembed e_fv cb f) (fun f -> + BU.bind_opt (unembed (e_option (e_list e_universe)) cb us_opt) (fun us -> + BU.bind_opt (unembed (e_list (e_tuple2 (e_pattern_aq aq) e_bool)) cb ps) (fun ps -> + Some <| Pat_Cons f us ps))) + + | Construct (fv, [], [(ppname, _); (sort, _)]) when S.fv_eq_lid fv ref_Pat_Var.lid -> + BU.bind_opt (unembed e_sort cb sort) (fun sort -> + BU.bind_opt (unembed e_ppname cb ppname) (fun ppname -> + Some <| Pat_Var sort ppname)) + + | Construct (fv, [], [(eopt, _)]) when S.fv_eq_lid fv ref_Pat_Dot_Term.lid -> + BU.bind_opt (unembed (e_option e_term) cb eopt) (fun eopt -> + Some <| Pat_Dot_Term eopt) + + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded pattern: %s" (t_to_string t)); + None + in + mk_emb' embed_pattern unembed_pattern fstar_refl_pattern_fv + +let e_pattern = e_pattern_aq noaqs + +let e_branch = e_tuple2 e_pattern e_term +let e_argv = e_tuple2 e_term e_aqualv + +let e_branch_aq aq = e_tuple2 (e_pattern_aq aq) (e_term_aq aq) +let e_argv_aq aq = e_tuple2 (e_term_aq aq) e_aqualv + +let e_match_returns_annotation = + e_option (e_tuple2 e_binder + (e_tuple3 (e_either e_term e_comp) (e_option e_term) e_bool)) + +let unlazy_as_t k t = + let open FStarC.Class.Deq in + match t.nbe_t with + | Lazy (Inl {lkind=k'; blob=v}, _) + when k =? k' -> + FStarC.Dyn.undyn v + | _ -> + failwith "Not a Lazy of the expected kind (NBE)" + +let e_ident : embedding I.ident = + let embed_ident cb (se:I.ident) : t = + mk_lazy cb se fstar_refl_ident Lazy_ident + in + let unembed_ident cb (t:t) : option I.ident = + match t.nbe_t with + | Lazy (Inl {blob=b; lkind=Lazy_ident}, _) -> + Some (undyn b) + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded ident: %s" (t_to_string t)); + None + in + mk_emb' embed_ident unembed_ident fstar_refl_ident_fv +let e_univ_name = e_ident +let e_univ_names = e_list e_univ_name + +let e_universe_view = + let embed_universe_view cb (uv:universe_view) : t = + match uv with + | Uv_Zero -> mkConstruct ref_Uv_Zero.fv [] [] + | Uv_Succ u -> + mkConstruct + ref_Uv_Succ.fv + [] + [as_arg (embed e_universe cb u)] + | Uv_Max us -> + mkConstruct + ref_Uv_Max.fv + [] + [as_arg (embed (e_list e_universe) cb us)] + | Uv_BVar n -> + mkConstruct + ref_Uv_BVar.fv + [] + [as_arg (embed e_int cb n)] + | Uv_Name i -> + mkConstruct + ref_Uv_Name.fv + [] + [as_arg (embed e_ident cb i)] + | Uv_Unif u -> + mkConstruct + ref_Uv_Unif.fv + [] + [as_arg (mk_lazy cb u U.t_universe_uvar Lazy_universe_uvar)] + | Uv_Unk -> mkConstruct ref_Uv_Unk.fv [] [] in + + let unembed_universe_view cb (t:t) : option universe_view = + match t.nbe_t with + | Construct (fv, _, []) when S.fv_eq_lid fv ref_Uv_Zero.lid -> Some Uv_Zero + | Construct (fv, _, [u, _]) when S.fv_eq_lid fv ref_Uv_Succ.lid -> + BU.bind_opt (unembed e_universe cb u) (fun u -> u |> Uv_Succ |> Some) + | Construct (fv, _, [us, _]) when S.fv_eq_lid fv ref_Uv_Max.lid -> + BU.bind_opt (unembed (e_list e_universe) cb us) (fun us -> us |> Uv_Max |> Some) + | Construct (fv, _, [n, _]) when S.fv_eq_lid fv ref_Uv_BVar.lid -> + BU.bind_opt (unembed e_int cb n) (fun n -> n |> Uv_BVar |> Some) + | Construct (fv, _, [i, _]) when S.fv_eq_lid fv ref_Uv_Name.lid -> + BU.bind_opt (unembed e_ident cb i) (fun i -> i |> Uv_Name |> Some) + | Construct (fv, _, [u, _]) when S.fv_eq_lid fv ref_Uv_Unif.lid -> + let u : universe_uvar = unlazy_as_t Lazy_universe_uvar u in + u |> Uv_Unif |> Some + | Construct (fv, _, []) when S.fv_eq_lid fv ref_Uv_Unk.lid -> Some Uv_Unk + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded + (BU.format1 "Not an embedded universe view: %s" (t_to_string t)); + None in + + mk_emb' embed_universe_view unembed_universe_view fstar_refl_universe_view_fv + +let e_subst_elt = + let embed_const cb (e:subst_elt) : t = + match e with + | DB (i, x) -> mkConstruct ref_DB.fv [] [as_arg (embed e_int cb (Z.of_int_fs i)); as_arg (embed e_namedv cb x)] + | NM (x, i) -> mkConstruct ref_NM.fv [] [as_arg (embed e_namedv cb x); as_arg (embed e_int cb (Z.of_int_fs i))] + | NT (x, t) -> mkConstruct ref_NT.fv [] [as_arg (embed e_namedv cb x); as_arg (embed e_term cb t)] + | UN (i, u) -> mkConstruct ref_UN.fv [] [as_arg (embed e_int cb (Z.of_int_fs i)); as_arg (embed e_universe cb u)] + | UD (n, i) -> mkConstruct ref_UD.fv [] [as_arg (embed e_univ_name cb n); as_arg (embed e_int cb (Z.of_int_fs i))] + in + let unembed_const cb (t:t) : option subst_elt = + match t.nbe_t with + | Construct (fv, [], [(x, _); (i, _)]) when S.fv_eq_lid fv ref_DB.lid -> + BU.bind_opt (unembed e_int cb i) (fun i -> + BU.bind_opt (unembed e_namedv cb x) (fun x -> + Some <| DB (Z.to_int_fs i, x))) + | Construct (fv, [], [(i, _); (x, _)]) when S.fv_eq_lid fv ref_NM.lid -> + BU.bind_opt (unembed e_namedv cb x) (fun x -> + BU.bind_opt (unembed e_int cb i) (fun i -> + Some <| NM (x, Z.to_int_fs i))) + | Construct (fv, [], [(t, _); (x, _)]) when S.fv_eq_lid fv ref_NT.lid -> + BU.bind_opt (unembed e_namedv cb x) (fun x -> + BU.bind_opt (unembed e_term cb t) (fun t -> + Some <| NT (x, t))) + | Construct (fv, [], [(u, _); (i, _)]) when S.fv_eq_lid fv ref_UN.lid -> + BU.bind_opt (unembed e_int cb i) (fun i -> + BU.bind_opt (unembed e_universe cb u) (fun u -> + Some <| UN (Z.to_int_fs i, u))) + | Construct (fv, [], [(i, _); (n, _)]) when S.fv_eq_lid fv ref_UD.lid -> + BU.bind_opt (unembed e_univ_name cb n) (fun n -> + BU.bind_opt (unembed e_int cb i) (fun i -> + Some <| UD (n, Z.to_int_fs i))) + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded vconst: %s" (t_to_string t)); + None + in + mk_emb' embed_const unembed_const fstar_refl_subst_elt_fv + +let e_subst = e_list e_subst_elt + +let e_term_view_aq aq = + let shift (s, aqs) = (s + 1, aqs) in + let embed_term_view cb (tv:term_view) : t = + match tv with + | Tv_FVar fv -> + mkConstruct ref_Tv_FVar.fv [] [as_arg (embed e_fv cb fv)] + + | Tv_BVar bv -> + mkConstruct ref_Tv_BVar.fv [] [as_arg (embed e_bv cb bv)] + + | Tv_Var bv -> + mkConstruct ref_Tv_Var.fv [] [as_arg (embed e_bv cb bv)] + + | Tv_UInst (fv, us) -> + mkConstruct ref_Tv_UInst.fv [] + [as_arg (embed e_fv cb fv); + as_arg (embed (e_list e_universe) cb us)] + + | Tv_App (hd, a) -> + mkConstruct ref_Tv_App.fv [] [as_arg (embed (e_term_aq aq) cb hd); as_arg (embed (e_argv_aq aq) cb a)] + + | Tv_Abs (b, t) -> + mkConstruct ref_Tv_Abs.fv [] [as_arg (embed e_binder cb b); as_arg (embed (e_term_aq (shift aq)) cb t)] + + | Tv_Arrow (b, c) -> + mkConstruct ref_Tv_Arrow.fv [] [as_arg (embed e_binder cb b); as_arg (embed e_comp cb c)] + + | Tv_Type u -> + mkConstruct ref_Tv_Type.fv [] [as_arg (embed e_universe cb u)] + + | Tv_Refine (b, t) -> + mkConstruct ref_Tv_Refine.fv [] [as_arg (embed e_binder cb b); + as_arg (embed (e_term_aq (shift aq)) cb t)] + + | Tv_Const c -> + mkConstruct ref_Tv_Const.fv [] [as_arg (embed e_vconst cb c)] + + | Tv_Uvar (u, d) -> + mkConstruct ref_Tv_Uvar.fv [] [as_arg (embed e_int cb u); as_arg (mk_lazy cb (u,d) U.t_ctx_uvar_and_sust Lazy_uvar)] + + | Tv_Let (r, attrs, b, t1, t2) -> + mkConstruct ref_Tv_Let.fv [] [as_arg (embed e_bool cb r); + as_arg (embed (e_list e_term) cb attrs); + as_arg (embed e_binder cb b); + as_arg (embed (e_term_aq aq) cb t1); + as_arg (embed (e_term_aq (shift aq)) cb t2)] + + | Tv_Match (t, ret_opt, brs) -> + mkConstruct ref_Tv_Match.fv [] [ + as_arg (embed (e_term_aq aq) cb t); + as_arg (embed e_match_returns_annotation cb ret_opt); + as_arg (embed (e_list (e_branch_aq aq)) cb brs)] + + | Tv_AscribedT (e, t, tacopt, use_eq) -> + mkConstruct ref_Tv_AscT.fv [] + [as_arg (embed (e_term_aq aq) cb e); + as_arg (embed (e_term_aq aq) cb t); + as_arg (embed (e_option (e_term_aq aq)) cb tacopt); + as_arg (embed e_bool cb use_eq)] + + | Tv_AscribedC (e, c, tacopt, use_eq) -> + mkConstruct ref_Tv_AscT.fv [] + [as_arg (embed (e_term_aq aq) cb e); + as_arg (embed e_comp cb c); + as_arg (embed (e_option (e_term_aq aq)) cb tacopt); + as_arg (embed e_bool cb use_eq)] + + | Tv_Unknown -> mkConstruct ref_Tv_Unknown.fv [] [] + + | Tv_Unsupp -> mkConstruct ref_Tv_Unsupp.fv [] [] + in + let unembed_term_view cb (t:t) : option term_view = + match t.nbe_t with + | Construct (fv, _, [(b, _)]) when S.fv_eq_lid fv ref_Tv_Var.lid -> + BU.bind_opt (unembed e_bv cb b) (fun b -> + Some <| Tv_Var b) + + | Construct (fv, _, [(b, _)]) when S.fv_eq_lid fv ref_Tv_BVar.lid -> + BU.bind_opt (unembed e_bv cb b) (fun b -> + Some <| Tv_BVar b) + + | Construct (fv, _, [(f, _)]) when S.fv_eq_lid fv ref_Tv_FVar.lid -> + BU.bind_opt (unembed e_fv cb f) (fun f -> + Some <| Tv_FVar f) + + | Construct (fv, _, [(f, _); (us, _)]) when S.fv_eq_lid fv ref_Tv_UInst.lid -> + BU.bind_opt (unembed e_fv cb f) (fun f -> + BU.bind_opt (unembed (e_list e_universe) cb us) (fun us -> + Some <| Tv_UInst (f, us))) + + | Construct (fv, _, [(r, _); (l, _)]) when S.fv_eq_lid fv ref_Tv_App.lid -> + BU.bind_opt (unembed e_term cb l) (fun l -> + BU.bind_opt (unembed e_argv cb r) (fun r -> + Some <| Tv_App (l, r))) + + | Construct (fv, _, [(t, _); (b, _)]) when S.fv_eq_lid fv ref_Tv_Abs.lid -> + BU.bind_opt (unembed e_binder cb b) (fun b -> + BU.bind_opt (unembed e_term cb t) (fun t -> + Some <| Tv_Abs (b, t))) + + | Construct (fv, _, [(t, _); (b, _)]) when S.fv_eq_lid fv ref_Tv_Arrow.lid -> + BU.bind_opt (unembed e_binder cb b) (fun b -> + BU.bind_opt (unembed e_comp cb t) (fun c -> + Some <| Tv_Arrow (b, c))) + + | Construct (fv, _, [(u, _)]) when S.fv_eq_lid fv ref_Tv_Type.lid -> + BU.bind_opt (unembed e_universe cb u) (fun u -> + Some <| Tv_Type u) + + | Construct (fv, _, [(t, _); (b, _)]) when S.fv_eq_lid fv ref_Tv_Refine.lid -> + BU.bind_opt (unembed e_binder cb b) (fun b -> + BU.bind_opt (unembed e_term cb t) (fun t -> + Some <| Tv_Refine (b, t))) + + | Construct (fv, _, [(c, _)]) when S.fv_eq_lid fv ref_Tv_Const.lid -> + BU.bind_opt (unembed e_vconst cb c) (fun c -> + Some <| Tv_Const c) + + | Construct (fv, _, [(l, _); (u, _)]) when S.fv_eq_lid fv ref_Tv_Uvar.lid -> + BU.bind_opt (unembed e_int cb u) (fun u -> + let ctx_u_s : ctx_uvar_and_subst = unlazy_as_t Lazy_uvar l in + Some <| Tv_Uvar (u, ctx_u_s)) + + | Construct (fv, _, [(t2, _); (t1, _); (b, _); (attrs, _); (r, _)]) when S.fv_eq_lid fv ref_Tv_Let.lid -> + BU.bind_opt (unembed e_bool cb r) (fun r -> + BU.bind_opt (unembed (e_list e_term) cb attrs) (fun attrs -> + BU.bind_opt (unembed e_binder cb b) (fun b -> + BU.bind_opt (unembed e_term cb t1) (fun t1 -> + BU.bind_opt (unembed e_term cb t2) (fun t2 -> + Some <| Tv_Let (r, attrs, b, t1, t2)))))) + + | Construct (fv, _, [(brs, _); (ret_opt, _); (t, _)]) when S.fv_eq_lid fv ref_Tv_Match.lid -> + BU.bind_opt (unembed e_term cb t) (fun t -> + BU.bind_opt (unembed (e_list e_branch) cb brs) (fun brs -> + BU.bind_opt (unembed e_match_returns_annotation cb ret_opt) (fun ret_opt -> + Some <| Tv_Match (t, ret_opt, brs)))) + + | Construct (fv, _, [(tacopt, _); (t, _); (e, _); (use_eq, _)]) when S.fv_eq_lid fv ref_Tv_AscT.lid -> + BU.bind_opt (unembed e_term cb e) (fun e -> + BU.bind_opt (unembed e_term cb t) (fun t -> + BU.bind_opt (unembed (e_option e_term) cb tacopt) (fun tacopt -> + BU.bind_opt (unembed e_bool cb use_eq) (fun use_eq -> + Some <| Tv_AscribedT (e, t, tacopt, use_eq))))) + + | Construct (fv, _, [(tacopt, _); (c, _); (e, _); (use_eq, _)]) when S.fv_eq_lid fv ref_Tv_AscC.lid -> + BU.bind_opt (unembed e_term cb e) (fun e -> + BU.bind_opt (unembed e_comp cb c) (fun c -> + BU.bind_opt (unembed (e_option e_term) cb tacopt) (fun tacopt -> + BU.bind_opt (unembed e_bool cb use_eq) (fun use_eq -> + Some <| Tv_AscribedC (e, c, tacopt, use_eq))))) + + | Construct (fv, _, []) when S.fv_eq_lid fv ref_Tv_Unknown.lid -> + Some <| Tv_Unknown + + | Construct (fv, _, []) when S.fv_eq_lid fv ref_Tv_Unsupp.lid -> + Some <| Tv_Unsupp + + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded term_view: %s" (t_to_string t)); + None + in + mk_emb' embed_term_view unembed_term_view fstar_refl_term_view_fv + +let e_term_view = e_term_view_aq (0, []) + +let e_namedv_view = + let embed_namedv_view cb (namedvv:namedv_view) : t = + mkConstruct ref_Mk_namedv_view.fv [] [ + as_arg (embed e_int cb namedvv.uniq); + as_arg (embed e_ppname cb namedvv.ppname); + as_arg (embed e_sort cb namedvv.sort); + ] + in + let unembed_namedv_view cb (t : t) : option namedv_view = + match t.nbe_t with + | Construct (fv, _, [(sort, _); (ppname, _); (uniq, _)]) when S.fv_eq_lid fv ref_Mk_namedv_view.lid -> + BU.bind_opt (unembed e_int cb uniq) (fun uniq -> + BU.bind_opt (unembed e_ppname cb ppname) (fun ppname -> + BU.bind_opt (unembed e_sort cb sort) (fun sort -> + let r : namedv_view = { ppname = ppname; uniq = uniq ; sort=sort } in + Some r))) + + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded namedv_view: %s" (t_to_string t)); + None + in + mk_emb' embed_namedv_view unembed_namedv_view fstar_refl_namedv_view_fv + +let e_bv_view = + let embed_bv_view cb (bvv:bv_view) : t = + mkConstruct ref_Mk_bv_view.fv [] [ + as_arg (embed e_int cb bvv.index); + as_arg (embed e_ppname cb bvv.ppname); + as_arg (embed e_sort cb bvv.sort); + ] + in + let unembed_bv_view cb (t : t) : option bv_view = + match t.nbe_t with + | Construct (fv, _, [(sort, _); (ppname, _); (idx, _)]) when S.fv_eq_lid fv ref_Mk_bv_view.lid -> + BU.bind_opt (unembed e_int cb idx) (fun idx -> + BU.bind_opt (unembed e_ppname cb ppname) (fun ppname -> + BU.bind_opt (unembed e_sort cb sort) (fun sort -> + let r : bv_view = { ppname = ppname; index = idx; sort=sort } in + Some r))) + + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded bv_view: %s" (t_to_string t)); + None + in + mk_emb' embed_bv_view unembed_bv_view fstar_refl_bv_view_fv + +let e_attribute = e_term +let e_attributes = e_list e_attribute + +let e_binding = + let embed cb (b:RD.binding) : t = + mkConstruct ref_Mk_binding.fv [] [ + as_arg (embed e_int cb b.uniq); + as_arg (embed e_term cb b.sort); + as_arg (embed e_ppname cb b.ppname); + ] + in + let unembed cb (t:t) : option RD.binding = + match t.nbe_t with + | Construct (fv, _, [(ppname, _); (sort, _); (uniq, _)]) + when S.fv_eq_lid fv ref_Mk_binding.lid -> + BU.bind_opt (unembed e_int cb uniq) (fun uniq -> + BU.bind_opt (unembed e_term cb sort) (fun sort -> + BU.bind_opt (unembed e_ppname cb ppname) (fun ppname -> + let r : RD.binding = {uniq=uniq; ppname=ppname; sort=sort} in + Some r))) + in + mk_emb' embed unembed fstar_refl_binding_fv + +let e_binder_view = + let embed_binder_view cb (bview:binder_view) : t = + mkConstruct ref_Mk_binder_view.fv [] [ + as_arg (embed e_term cb bview.sort); + as_arg (embed e_aqualv cb bview.qual); + as_arg (embed e_attributes cb bview.attrs); + as_arg (embed e_ppname cb bview.ppname); + ] in + + let unembed_binder_view cb (t:t) : option binder_view = + match t.nbe_t with + | Construct (fv, _, [(ppname, _); (attrs, _); (q, _); (sort, _)]) + when S.fv_eq_lid fv ref_Mk_binder_view.lid -> + BU.bind_opt (unembed e_term cb sort) (fun sort -> + BU.bind_opt (unembed e_aqualv cb q) (fun q -> + BU.bind_opt (unembed e_attributes cb attrs) (fun attrs -> + BU.bind_opt (unembed e_ppname cb ppname) (fun ppname -> + let r : binder_view = {ppname=ppname; qual=q; attrs=attrs; sort=sort} in + Some r)))) + + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded binder_view: %s" (t_to_string t)); + None + in + mk_emb' embed_binder_view unembed_binder_view fstar_refl_binder_view_fv + +let e_comp_view = + let embed_comp_view cb (cv : comp_view) : t = + match cv with + | C_Total t -> + mkConstruct ref_C_Total.fv [] [ + as_arg (embed e_term cb t)] + + | C_GTotal t -> + mkConstruct ref_C_GTotal.fv [] [ + as_arg (embed e_term cb t)] + + | C_Lemma (pre, post, pats) -> + mkConstruct ref_C_Lemma.fv [] [as_arg (embed e_term cb pre); as_arg (embed e_term cb post); as_arg (embed e_term cb pats)] + + | C_Eff (us, eff, res, args, decrs) -> + mkConstruct ref_C_Eff.fv [] + [ as_arg (embed (e_list e_universe) cb us) + ; as_arg (embed e_string_list cb eff) + ; as_arg (embed e_term cb res) + ; as_arg (embed (e_list e_argv) cb args) + ; as_arg (embed (e_list e_term) cb decrs)] + in + let unembed_comp_view cb (t : t) : option comp_view = + match t.nbe_t with + | Construct (fv, _, [(t, _)]) + when S.fv_eq_lid fv ref_C_Total.lid -> + BU.bind_opt (unembed e_term cb t) (fun t -> + Some <| C_Total t) + + | Construct (fv, _, [(t, _)]) + when S.fv_eq_lid fv ref_C_GTotal.lid -> + BU.bind_opt (unembed e_term cb t) (fun t -> + Some <| C_GTotal t) + + | Construct (fv, _, [(post, _); (pre, _); (pats, _)]) when S.fv_eq_lid fv ref_C_Lemma.lid -> + BU.bind_opt (unembed e_term cb pre) (fun pre -> + BU.bind_opt (unembed e_term cb post) (fun post -> + BU.bind_opt (unembed e_term cb pats) (fun pats -> + Some <| C_Lemma (pre, post, pats)))) + + | Construct (fv, _, [(decrs, _); (args, _); (res, _); (eff, _); (us, _)]) + when S.fv_eq_lid fv ref_C_Eff.lid -> + BU.bind_opt (unembed (e_list e_universe) cb us) (fun us -> + BU.bind_opt (unembed e_string_list cb eff) (fun eff -> + BU.bind_opt (unembed e_term cb res) (fun res-> + BU.bind_opt (unembed (e_list e_argv) cb args) (fun args -> + BU.bind_opt (unembed (e_list e_term) cb decrs) (fun decrs -> + Some <| C_Eff (us, eff, res, args, decrs)))))) + + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded comp_view: %s" (t_to_string t)); + None + in + mk_emb' embed_comp_view unembed_comp_view fstar_refl_comp_view_fv + +let e_sigelt = + let embed_sigelt cb (se:sigelt) : t = + mk_lazy cb se fstar_refl_sigelt Lazy_sigelt + in + let unembed_sigelt cb (t:t) : option sigelt = + match t.nbe_t with + | Lazy (Inl {blob=b; lkind=Lazy_sigelt}, _) -> + Some (undyn b) + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded sigelt: %s" (t_to_string t)); + None + in + mk_emb' embed_sigelt unembed_sigelt fstar_refl_sigelt_fv + +let e_string_list = e_list e_string + +let e_ctor = e_tuple2 e_string_list e_term + +let e_lb_view = + let embed_lb_view cb (lbv:lb_view) : t = + mkConstruct ref_Mk_lb.fv [] [as_arg (embed e_fv cb lbv.lb_fv); + as_arg (embed e_univ_names cb lbv.lb_us); + as_arg (embed e_term cb lbv.lb_typ); + as_arg (embed e_term cb lbv.lb_def)] + in + let unembed_lb_view cb (t : t) : option lb_view = + match t.nbe_t with + | Construct (fv, _, [(fv', _); (us, _); (typ, _); (def,_)]) + when S.fv_eq_lid fv ref_Mk_lb.lid -> + BU.bind_opt (unembed e_fv cb fv') (fun fv' -> + BU.bind_opt (unembed e_univ_names cb us) (fun us -> + BU.bind_opt (unembed e_term cb typ) (fun typ -> + BU.bind_opt (unembed e_term cb def) (fun def -> + Some <| + { lb_fv = fv'; lb_us = us; lb_typ = typ; lb_def = def })))) + + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded lb_view: %s" (t_to_string t)); + None + in + mk_emb' embed_lb_view unembed_lb_view fstar_refl_lb_view_fv + +(* embeds as a string list *) +let e_lid : embedding I.lid = + let embed rng lid : t = + embed e_string_list rng (I.path_of_lid lid) + in + let unembed cb (t : t) : option I.lid = + BU.map_opt (unembed e_string_list cb t) (fun p -> I.lid_of_path p Range.dummyRange) + in + mk_emb embed unembed + (fun () -> mkConstruct fstar_refl_aqualv_fv [] []) + (fun () -> fv_as_emb_typ fstar_refl_aqualv_fv) + +let e_letbinding = + let embed_letbinding cb (lb:letbinding) : t = + mk_lazy cb lb fstar_refl_letbinding Lazy_letbinding + in + let unembed_letbinding cb (t : t) : option letbinding = + match t.nbe_t with + | Lazy (Inl {blob=lb; lkind=Lazy_letbinding}, _) -> + Some (undyn lb) + + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded letbinding: %s" (t_to_string t)); + None + in + mk_emb' embed_letbinding unembed_letbinding fstar_refl_letbinding_fv + +let e_sigelt_view = + let embed_sigelt_view cb (sev:sigelt_view) : t = + match sev with + | Sg_Let (r, lbs) -> + mkConstruct ref_Sg_Let.fv [] [as_arg (embed e_bool cb r); + as_arg (embed (e_list e_letbinding) cb lbs)] + + | Sg_Inductive (nm, univs, bs, t, dcs) -> + mkConstruct ref_Sg_Inductive.fv [] [as_arg (embed e_string_list cb nm); + as_arg (embed e_univ_names cb univs); + as_arg (embed e_binders cb bs); + as_arg (embed e_term cb t); + as_arg (embed (e_list e_ctor) cb dcs)] + + | Sg_Val (nm, univs, t) -> + mkConstruct ref_Sg_Val.fv [] + [as_arg (embed e_string_list cb nm); + as_arg (embed e_univ_names cb univs); + as_arg (embed e_term cb t)] + + | Unk -> + mkConstruct ref_Unk.fv [] [] + in + let unembed_sigelt_view cb (t:t) : option sigelt_view = + match t.nbe_t with + | Construct (fv, _, [(dcs, _); (t, _); (bs, _); (us, _); (nm, _)]) when S.fv_eq_lid fv ref_Sg_Inductive.lid -> + BU.bind_opt (unembed e_string_list cb nm) (fun nm -> + BU.bind_opt (unembed e_univ_names cb us) (fun us -> + BU.bind_opt (unembed e_binders cb bs) (fun bs -> + BU.bind_opt (unembed e_term cb t) (fun t -> + BU.bind_opt (unembed (e_list e_ctor) cb dcs) (fun dcs -> + Some <| Sg_Inductive (nm, us, bs, t, dcs)))))) + + | Construct (fv, _, [(lbs, _); (r, _)]) when S.fv_eq_lid fv ref_Sg_Let.lid -> + BU.bind_opt (unembed e_bool cb r) (fun r -> + BU.bind_opt (unembed (e_list e_letbinding) cb lbs) (fun lbs -> + Some <| Sg_Let (r, lbs))) + + | Construct (fv, _, [(t, _); (us, _); (nm, _)]) when S.fv_eq_lid fv ref_Sg_Val.lid -> + BU.bind_opt (unembed e_string_list cb nm) (fun nm -> + BU.bind_opt (unembed e_univ_names cb us) (fun us -> + BU.bind_opt (unembed e_term cb t) (fun t -> + Some <| Sg_Val(nm, us, t)))) + + | Construct (fv, _, []) when S.fv_eq_lid fv ref_Unk.lid -> + Some Unk + + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded sigelt_view: %s" (t_to_string t)); + None + in + mk_emb' embed_sigelt_view unembed_sigelt_view fstar_refl_sigelt_view_fv + +let e_name : embedding name = e_list e_string + +let e_qualifier = + let embed cb (q:RD.qualifier) : t = + match q with + | RD.Assumption -> mkConstruct ref_qual_Assumption.fv [] [] + | RD.New -> mkConstruct ref_qual_New.fv [] [] + | RD.Private -> mkConstruct ref_qual_Private.fv [] [] + | RD.Unfold_for_unification_and_vcgen -> mkConstruct ref_qual_Unfold_for_unification_and_vcgen.fv [] [] + | RD.Visible_default -> mkConstruct ref_qual_Visible_default.fv [] [] + | RD.Irreducible -> mkConstruct ref_qual_Irreducible.fv [] [] + | RD.Inline_for_extraction -> mkConstruct ref_qual_Inline_for_extraction.fv [] [] + | RD.NoExtract -> mkConstruct ref_qual_NoExtract.fv [] [] + | RD.Noeq -> mkConstruct ref_qual_Noeq.fv [] [] + | RD.Unopteq -> mkConstruct ref_qual_Unopteq.fv [] [] + | RD.TotalEffect -> mkConstruct ref_qual_TotalEffect.fv [] [] + | RD.Logic -> mkConstruct ref_qual_Logic.fv [] [] + | RD.Reifiable -> mkConstruct ref_qual_Reifiable.fv [] [] + | RD.ExceptionConstructor -> mkConstruct ref_qual_ExceptionConstructor.fv [] [] + | RD.HasMaskedEffect -> mkConstruct ref_qual_HasMaskedEffect.fv [] [] + | RD.Effect -> mkConstruct ref_qual_Effect.fv [] [] + | RD.OnlyName -> mkConstruct ref_qual_OnlyName.fv [] [] + | RD.Reflectable l -> + mkConstruct ref_qual_Reflectable.fv [] [as_arg (embed e_name cb l)] + + | RD.Discriminator l -> + mkConstruct ref_qual_Discriminator.fv [] [as_arg (embed e_name cb l)] + + | RD.Action l -> + mkConstruct ref_qual_Action.fv [] [as_arg (embed e_name cb l)] + + | RD.Projector li -> + mkConstruct ref_qual_Projector.fv [] [as_arg (embed (e_tuple2 e_name e_ident) cb li)] + + | RD.RecordType ids12 -> + mkConstruct ref_qual_RecordType.fv [] [as_arg (embed (e_tuple2 (e_list e_ident) (e_list e_ident)) cb ids12)] + + | RD.RecordConstructor ids12 -> + mkConstruct ref_qual_RecordConstructor.fv [] [as_arg (embed (e_tuple2 (e_list e_ident) (e_list e_ident)) cb ids12)] + in + let unembed cb (t:t) : option RD.qualifier = + match t.nbe_t with + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Assumption.lid -> Some RD.Assumption + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_New.lid -> Some RD.New + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Private.lid -> Some RD.Private + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Unfold_for_unification_and_vcgen.lid -> Some RD.Unfold_for_unification_and_vcgen + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Visible_default.lid -> Some RD.Visible_default + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Irreducible.lid -> Some RD.Irreducible + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Inline_for_extraction.lid -> Some RD.Inline_for_extraction + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_NoExtract.lid -> Some RD.NoExtract + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Noeq.lid -> Some RD.Noeq + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Unopteq.lid -> Some RD.Unopteq + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_TotalEffect.lid -> Some RD.TotalEffect + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Logic.lid -> Some RD.Logic + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Reifiable.lid -> Some RD.Reifiable + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_ExceptionConstructor.lid -> Some RD.ExceptionConstructor + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_HasMaskedEffect.lid -> Some RD.HasMaskedEffect + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_Effect.lid -> Some RD.Effect + | Construct (fv, [], []) when S.fv_eq_lid fv ref_qual_OnlyName.lid -> Some RD.OnlyName + + | Construct (fv, [], [(l, _)]) when S.fv_eq_lid fv ref_qual_Reflectable.lid -> + BU.bind_opt (unembed e_name cb l) (fun l -> + Some (RD.Reflectable l)) + + | Construct (fv, [], [(l, _)]) when S.fv_eq_lid fv ref_qual_Discriminator.lid -> + BU.bind_opt (unembed e_name cb l) (fun l -> + Some (RD.Discriminator l)) + + | Construct (fv, [], [(l, _)]) when S.fv_eq_lid fv ref_qual_Action.lid -> + BU.bind_opt (unembed e_name cb l) (fun l -> + Some (RD.Action l)) + + | Construct (fv, [], [(li, _)]) when S.fv_eq_lid fv ref_qual_Projector.lid -> + BU.bind_opt (unembed (e_tuple2 e_name e_ident) cb li) (fun li -> + Some (RD.Projector li)) + + | Construct (fv, [], [(ids12, _)]) when S.fv_eq_lid fv ref_qual_RecordType.lid -> + BU.bind_opt (unembed (e_tuple2 (e_list e_ident) (e_list e_ident)) cb ids12) (fun ids12 -> + Some (RD.RecordType ids12)) + + | Construct (fv, [], [(ids12, _)]) when S.fv_eq_lid fv ref_qual_RecordConstructor.lid -> + BU.bind_opt (unembed (e_tuple2 (e_list e_ident) (e_list e_ident)) cb ids12) (fun ids12 -> + Some (RD.RecordConstructor ids12)) + + | _ -> + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded qualifier: %s" (t_to_string t)); + None + in + mk_emb embed unembed + (fun () -> mkConstruct fstar_refl_qualifier_fv [] []) + (fun () -> fv_as_emb_typ fstar_refl_qualifier_fv) + +let e_qualifiers = e_list e_qualifier + +let e_vconfig = + let emb cb (o:order) : t = + failwith "emb vconfig NBE" + in + let unemb cb (t:t) : option order = + failwith "unemb vconfig NBE" + in + mk_emb' emb unemb (lid_as_fv PC.vconfig_lid None) diff --git a/src/reflection/FStarC.Reflection.V2.NBEEmbeddings.fsti b/src/reflection/FStarC.Reflection.V2.NBEEmbeddings.fsti new file mode 100644 index 00000000000..316b4622c8a --- /dev/null +++ b/src/reflection/FStarC.Reflection.V2.NBEEmbeddings.fsti @@ -0,0 +1,60 @@ +(* + Copyright 2008-2022 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Reflection.V2.NBEEmbeddings + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Syntax.Syntax +open FStarC.TypeChecker.NBETerm +open FStarC.Reflection.V2.Data +module RD = FStarC.Reflection.V2.Data + +(* Embeddings *) +val e_bv : embedding bv +val e_namedv : embedding namedv +instance val e_binder : embedding binder +instance val e_binder_view : embedding binder_view +instance val e_binders : embedding binders +instance val e_binding : embedding RD.binding +instance val e_term : embedding term +instance val e_term_view : embedding term_view +instance val e_fv : embedding fv +instance val e_comp : embedding FStarC.Syntax.Syntax.comp +instance val e_comp_view : embedding comp_view +instance val e_vconst : embedding vconst +instance val e_env : embedding FStarC.TypeChecker.Env.env +instance val e_pattern : embedding pattern +instance val e_branch : embedding Data.branch +instance val e_aqualv : embedding aqualv +instance val e_argv : embedding argv +instance val e_sigelt : embedding sigelt +instance val e_letbinding : embedding letbinding +instance val e_lb_view : embedding lb_view +instance val e_sigelt_view : embedding sigelt_view +instance val e_bv_view : embedding bv_view +instance val e_namedv_view : embedding namedv_view +instance val e_attribute : embedding attribute +instance val e_attributes : embedding (list attribute) (* This seems rather silly, but `attributes` is a keyword *) +instance val e_qualifier : embedding RD.qualifier +instance val e_qualifiers : embedding (list RD.qualifier) +instance val e_ident : embedding Ident.ident +instance val e_univ_name : embedding univ_name +instance val e_univ_names : embedding (list univ_name) +instance val e_universe : embedding universe +instance val e_universe_view : embedding universe_view +instance val e_subst_elt : embedding subst_elt +instance val e_subst : embedding (list subst_elt) diff --git a/src/smtencoding/FStar.SMTEncoding.Encode.fst b/src/smtencoding/FStar.SMTEncoding.Encode.fst deleted file mode 100644 index fe0d3bdcc20..00000000000 --- a/src/smtencoding/FStar.SMTEncoding.Encode.fst +++ /dev/null @@ -1,2037 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.SMTEncoding.Encode -open Prims -open FStar -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Compiler -open FStar.TypeChecker.Env -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.TypeChecker -open FStar.SMTEncoding.Term -open FStar.Ident -open FStar.Const -open FStar.SMTEncoding -open FStar.SMTEncoding.Util -open FStar.SMTEncoding.Env -open FStar.SMTEncoding.EncodeTerm -open FStar.Class.Show - -module BU = FStar.Compiler.Util -module Const = FStar.Parser.Const -module Env = FStar.TypeChecker.Env -module N = FStar.TypeChecker.Normalize -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module TcUtil = FStar.TypeChecker.Util -module UF = FStar.Syntax.Unionfind -module U = FStar.Syntax.Util -module TEQ = FStar.TypeChecker.TermEqAndSimplify - -let dbg_SMTEncoding = Debug.get_toggle "SMTEncoding" -let dbg_SMTQuery = Debug.get_toggle "SMTQuery" -let dbg_Time = Debug.get_toggle "Time" - -let norm_before_encoding env t = - let steps = [Env.Eager_unfolding; - Env.Simplify; - Env.Primops; - Env.AllowUnboundUniverses; - Env.EraseUniverses; - Env.Exclude Env.Zeta] in - Profiling.profile - (fun () -> N.normalize steps env.tcenv t) - (Some (Ident.string_of_lid (Env.current_module env.tcenv))) - "FStar.SMTEncoding.Encode.norm_before_encoding" - -let norm_before_encoding_us env us (t:S.term) = - let env_u = {env with tcenv = Env.push_univ_vars env.tcenv us} in - let us, t = SS.open_univ_vars us t in - let t = norm_before_encoding env_u t in - SS.close_univ_vars us t - -let norm_with_steps steps env t = - Profiling.profile - (fun () -> N.normalize steps env t) - (Some (Ident.string_of_lid (Env.current_module env))) - "FStar.SMTEncoding.Encode.norm" - -type prims_t = { - mk:lident -> string -> term & int & list decl; - is:lident -> bool; -} - -(* Only for the definitions of prims below *) -type defn_rel_type = | Eq | ValidIff -let rel_type_f = function - | Eq -> mkEq - | ValidIff -> fun (x, y) -> - mkEq (mk_Valid x, y) - -let prims = - let module_name = "Prims" in - let asym, a = fresh_fvar module_name "a" Term_sort in - let xsym, x = fresh_fvar module_name "x" Term_sort in - let ysym, y = fresh_fvar module_name "y" Term_sort in - let quant_with_pre (rel:defn_rel_type) vars precondition body : Range.range -> string -> term & int & list decl = fun rng x -> - let xname_decl = Term.DeclFun(x, vars |> List.map fv_sort, Term_sort, None) in - let xtok = x ^ "@tok" in - let xtok_decl = Term.DeclFun(xtok, [], Term_sort, None) in - let xapp = mkApp(x, List.map mkFreeV vars) in //arity ok, see decl (#1383) - let xtok = mkApp(xtok, []) in //arity ok, see decl (#1383) - let xtok_app = mk_Apply xtok vars in - - (* - * AR: adding IsTotFun axioms for the symbol itself, and its partial applications - * NOTE: there are no typing guards here, but then there are no typing guards in - * any of the other axioms too - *) - let tot_fun_axioms = - let all_vars_but_one = BU.prefix vars |> fst in - let axiom_name = "primitive_tot_fun_" ^ x in - //IsTotFun axiom for the symbol itself - let tot_fun_axiom_for_x = Util.mkAssume (mk_IsTotFun xtok, None, axiom_name) in - let axioms, _, _ = //collect other axioms for partial applications - List.fold_left (fun (axioms, app, vars) var -> - let app = mk_Apply app [var] in - let vars = vars @ [var] in - let axiom_name = axiom_name ^ "." ^ (string_of_int (vars |> List.length)) in - axioms @ [Util.mkAssume (mkForall rng ([[app]], vars, mk_IsTotFun app), None, axiom_name)], - app, - vars - ) ([tot_fun_axiom_for_x], xtok, []) all_vars_but_one - in - axioms - in - - let rel_body = - let rel_body = (rel_type_f rel) (xapp, body) in - match precondition with - | None -> rel_body - | Some pre -> mkImp(pre, rel_body) - in - - xtok, - List.length vars, - ([xname_decl; - xtok_decl; - Util.mkAssume(mkForall rng ([[xapp]], vars, rel_body), None, "primitive_" ^x)] @ - tot_fun_axioms @ - [Util.mkAssume(mkForall rng ([[xtok_app]], - vars, - mkEq(xtok_app, xapp)), - Some "Name-token correspondence", - "token_correspondence_"^x)]) - in - let quant rel vars body = quant_with_pre rel vars None body in - let axy = List.map mk_fv [(asym, Term_sort); (xsym, Term_sort); (ysym, Term_sort)] in - let xy = List.map mk_fv [(xsym, Term_sort); (ysym, Term_sort)] in - let qx = List.map mk_fv [(xsym, Term_sort)] in - let prims = [ - //equality - (Const.op_Eq, (quant Eq axy (boxBool <| mkEq(x,y)))); - (Const.op_notEq, (quant Eq axy (boxBool <| mkNot(mkEq(x,y))))); - //boolean ops - (Const.op_And, (quant Eq xy (boxBool <| mkAnd(unboxBool x, unboxBool y)))); - (Const.op_Or, (quant Eq xy (boxBool <| mkOr(unboxBool x, unboxBool y)))); - (Const.op_Negation, (quant Eq qx (boxBool <| mkNot(unboxBool x)))); - //integer ops - (Const.op_LT, (quant Eq xy (boxBool <| mkLT(unboxInt x, unboxInt y)))); - (Const.op_LTE, (quant Eq xy (boxBool <| mkLTE(unboxInt x, unboxInt y)))); - (Const.op_GT, (quant Eq xy (boxBool <| mkGT(unboxInt x, unboxInt y)))); - (Const.op_GTE, (quant Eq xy (boxBool <| mkGTE(unboxInt x, unboxInt y)))); - (Const.op_Subtraction, (quant Eq xy (boxInt <| mkSub(unboxInt x, unboxInt y)))); - (Const.op_Minus, (quant Eq qx (boxInt <| mkMinus(unboxInt x)))); - (Const.op_Addition, (quant Eq xy (boxInt <| mkAdd(unboxInt x, unboxInt y)))); - (Const.op_Multiply, (quant Eq xy (boxInt <| mkMul(unboxInt x, unboxInt y)))); - (Const.op_Division, (quant_with_pre Eq xy (Some (mkNot (mkEq (unboxInt y, mkInteger "0")))) (boxInt <| mkDiv(unboxInt x, unboxInt y)))); - (Const.op_Modulus, (quant_with_pre Eq xy (Some (mkNot (mkEq (unboxInt y, mkInteger "0")))) (boxInt <| mkMod(unboxInt x, unboxInt y)))); - //real ops - (Const.real_op_LT, (quant ValidIff xy (mkLT(unboxReal x, unboxReal y)))); - (Const.real_op_LTE, (quant ValidIff xy (mkLTE(unboxReal x, unboxReal y)))); - (Const.real_op_GT, (quant ValidIff xy (mkGT(unboxReal x, unboxReal y)))); - (Const.real_op_GTE, (quant ValidIff xy (mkGTE(unboxReal x, unboxReal y)))); - (Const.real_op_Subtraction, (quant Eq xy (boxReal <| mkSub(unboxReal x, unboxReal y)))); - (Const.real_op_Addition, (quant Eq xy (boxReal <| mkAdd(unboxReal x, unboxReal y)))); - (Const.real_op_Multiply, (quant Eq xy (boxReal <| mkMul(unboxReal x, unboxReal y)))); - (Const.real_op_Division, (quant_with_pre Eq xy (Some (mkNot (mkEq (unboxReal y, mkReal "0")))) (boxReal <| mkRealDiv(unboxReal x, unboxReal y)))); - (Const.real_of_int, (quant Eq qx (boxReal <| mkRealOfInt (unboxInt x) Range.dummyRange))) - ] - in - let mk : lident -> string -> term & int & list decl = - fun l v -> - prims |> - List.find (fun (l', _) -> lid_equals l l') |> - Option.map (fun (_, b) -> b (Ident.range_of_lid l) v) |> - Option.get in - let is : lident -> bool = - fun l -> prims |> BU.for_some (fun (l', _) -> lid_equals l l') in - {mk=mk; - is=is} - -let pretype_axiom term_constr_eq rng env tapp vars = - let xxsym, xx = fresh_fvar env.current_module_name "x" Term_sort in - let ffsym, ff = fresh_fvar env.current_module_name "f" Fuel_sort in - let xx_has_type = mk_HasTypeFuel ff xx tapp in - let tapp_hash = Term.hash_of_term tapp in - let module_name = env.current_module_name in - Util.mkAssume(mkForall rng ([[xx_has_type]], mk_fv (xxsym, Term_sort)::mk_fv (ffsym, Fuel_sort)::vars, - mkImp(xx_has_type, - (if term_constr_eq - then mkEq(mkApp ("Term_constr_id", [tapp]), - mkApp ("Term_constr_id", [mkApp("PreType", [xx])])) - else mkEq(tapp, - mkApp("PreType", [xx]))))), - Some "pretyping", - (varops.mk_unique (module_name ^ "_pretyping_" ^ (BU.digest_of_string tapp_hash)))) - -let primitive_type_axioms : env -> lident -> string -> term -> list decl = - let xx = mk_fv ("x", Term_sort) in - let x = mkFreeV xx in - - let yy = mk_fv ("y", Term_sort) in - let y = mkFreeV yy in - - let mkForall_fuel env = mkForall_fuel (Ident.string_of_lid (Env.current_module env)) in - - let mk_unit : env -> string -> term -> list decl = fun env nm tt -> - let typing_pred = mk_HasType x tt in - [Util.mkAssume(mk_HasType mk_Term_unit tt, Some "unit typing", "unit_typing"); - Util.mkAssume(mkForall_fuel env (Env.get_range env) - ([[typing_pred]], [xx], mkImp(typing_pred, mkEq(x, mk_Term_unit))), Some "unit inversion", "unit_inversion");] in - let mk_bool : env -> string -> term -> list decl = fun env nm tt -> - let typing_pred = mk_HasType x tt in - let bb = mk_fv ("b", Bool_sort) in - let b = mkFreeV bb in - [Util.mkAssume(mkForall (Env.get_range env) - ([[Term.boxBool b]], [bb], mk_HasType (Term.boxBool b) tt), Some "bool typing", "bool_typing"); - Util.mkAssume(mkForall_fuel env (Env.get_range env) - ([[typing_pred]], [xx], mkImp(typing_pred, mk_tester (fst boxBoolFun) x)), Some "bool inversion", "bool_inversion")] in - let mk_int : env -> string -> term -> list decl = fun env nm tt -> - let lex_t = mkFreeV <| mk_fv (string_of_lid Const.lex_t_lid, Term_sort) in - let typing_pred = mk_HasType x tt in - let typing_pred_y = mk_HasType y tt in - let aa = mk_fv ("a", Int_sort) in - let a = mkFreeV aa in - let bb = mk_fv ("b", Int_sort) in - let b = mkFreeV bb in - let precedes_y_x = mk_Valid <| mkApp("Prims.precedes", [lex_t; lex_t;y;x]) in - [Util.mkAssume(mkForall (Env.get_range env) ([[Term.boxInt b]], [bb], mk_HasType (Term.boxInt b) tt), Some "int typing", "int_typing"); - Util.mkAssume(mkForall_fuel env (Env.get_range env) ([[typing_pred]], [xx], mkImp(typing_pred, mk_tester (fst boxIntFun) x)), Some "int inversion", "int_inversion"); - Util.mkAssume(mkForall_fuel env (Env.get_range env) ([[typing_pred; typing_pred_y;precedes_y_x]], - [xx;yy], - mkImp(mk_and_l [typing_pred; - typing_pred_y; - mkGT (Term.unboxInt x, mkInteger' 0); - mkGTE (Term.unboxInt y, mkInteger' 0); - mkLT (Term.unboxInt y, Term.unboxInt x)], - precedes_y_x)), - Some "well-founded ordering on nat (alt)", "well-founded-ordering-on-nat")] in - let mk_real : env -> string -> term -> list decl = fun env nm tt -> - let typing_pred = mk_HasType x tt in - let aa = mk_fv ("a", Sort "Real") in - let a = mkFreeV aa in - let bb = mk_fv ("b", Sort "Real") in - let b = mkFreeV bb in - [Util.mkAssume(mkForall - (Env.get_range env) - ([[Term.boxReal b]], - [bb], - mk_HasType (Term.boxReal b) tt), - Some "real typing", - "real_typing"); - Util.mkAssume(mkForall_fuel - env - (Env.get_range env) - ([[typing_pred]], - [xx], - mkImp(typing_pred, - mk_tester (fst boxRealFun) x)), - Some "real inversion", - "real_inversion")] - in - let mk_str : env -> string -> term -> list decl = fun env nm tt -> - let typing_pred = mk_HasType x tt in - let bb = mk_fv ("b", String_sort) in - let b = mkFreeV bb in - [Util.mkAssume(mkForall (Env.get_range env) ([[Term.boxString b]], [bb], mk_HasType (Term.boxString b) tt), Some "string typing", "string_typing"); - Util.mkAssume(mkForall_fuel env (Env.get_range env) ([[typing_pred]], [xx], mkImp(typing_pred, mk_tester (fst boxStringFun) x)), Some "string inversion", "string_inversion")] in - let mk_true_interp : env -> string -> term -> list decl = fun env nm true_tm -> - let valid = mkApp("Valid", [true_tm]) in - [Util.mkAssume(valid, Some "True interpretation", "true_interp")] in - let mk_false_interp : env -> string -> term -> list decl = fun env nm false_tm -> - let valid = mkApp("Valid", [false_tm]) in - [Util.mkAssume(mkIff(mkFalse, valid), Some "False interpretation", "false_interp")] in - let mk_and_interp : env -> string -> term -> list decl = fun env conj _ -> - let aa = mk_fv ("a", Term_sort) in - let bb = mk_fv ("b", Term_sort) in - let a = mkFreeV aa in - let b = mkFreeV bb in - let l_and_a_b = mkApp(conj, [a;b]) in - let valid = mkApp("Valid", [l_and_a_b]) in - let valid_a = mkApp("Valid", [a]) in - let valid_b = mkApp("Valid", [b]) in - [Util.mkAssume(mkForall (Env.get_range env) ([[l_and_a_b]], [aa;bb], mkIff(mkAnd(valid_a, valid_b), valid)), Some "/\ interpretation", "l_and-interp")] in - let mk_or_interp : env -> string -> term -> list decl = fun env disj _ -> - let aa = mk_fv ("a", Term_sort) in - let bb = mk_fv ("b", Term_sort) in - let a = mkFreeV aa in - let b = mkFreeV bb in - let l_or_a_b = mkApp(disj, [a;b]) in - let valid = mkApp("Valid", [l_or_a_b]) in - let valid_a = mkApp("Valid", [a]) in - let valid_b = mkApp("Valid", [b]) in - [Util.mkAssume(mkForall (Env.get_range env) ([[l_or_a_b]], [aa;bb], mkIff(mkOr(valid_a, valid_b), valid)), Some "\/ interpretation", "l_or-interp")] in - let mk_eq2_interp : env -> string -> term -> list decl = fun env eq2 tt -> - let aa = mk_fv ("a", Term_sort) in - let xx = mk_fv ("x", Term_sort) in - let yy = mk_fv ("y", Term_sort) in - let a = mkFreeV aa in - let x = mkFreeV xx in - let y = mkFreeV yy in - let eq2_x_y = mkApp(eq2, [a;x;y]) in - let valid = mkApp("Valid", [eq2_x_y]) in - [Util.mkAssume(mkForall (Env.get_range env) ([[eq2_x_y]], [aa;xx;yy], mkIff(mkEq(x, y), valid)), Some "Eq2 interpretation", "eq2-interp")] in - let mk_imp_interp : env -> string -> term -> list decl = fun env imp tt -> - let aa = mk_fv ("a", Term_sort) in - let bb = mk_fv ("b", Term_sort) in - let a = mkFreeV aa in - let b = mkFreeV bb in - let l_imp_a_b = mkApp(imp, [a;b]) in - let valid = mkApp("Valid", [l_imp_a_b]) in - let valid_a = mkApp("Valid", [a]) in - let valid_b = mkApp("Valid", [b]) in - [Util.mkAssume(mkForall (Env.get_range env) ([[l_imp_a_b]], [aa;bb], mkIff(mkImp(valid_a, valid_b), valid)), Some "==> interpretation", "l_imp-interp")] in - let mk_iff_interp : env -> string -> term -> list decl = fun env iff tt -> - let aa = mk_fv ("a", Term_sort) in - let bb = mk_fv ("b", Term_sort) in - let a = mkFreeV aa in - let b = mkFreeV bb in - let l_iff_a_b = mkApp(iff, [a;b]) in - let valid = mkApp("Valid", [l_iff_a_b]) in - let valid_a = mkApp("Valid", [a]) in - let valid_b = mkApp("Valid", [b]) in - [Util.mkAssume(mkForall (Env.get_range env) ([[l_iff_a_b]], [aa;bb], mkIff(mkIff(valid_a, valid_b), valid)), Some "<==> interpretation", "l_iff-interp")] in - let mk_not_interp : env -> string -> term -> list decl = fun env l_not tt -> - let aa = mk_fv ("a", Term_sort) in - let a = mkFreeV aa in - let l_not_a = mkApp(l_not, [a]) in - let valid = mkApp("Valid", [l_not_a]) in - let not_valid_a = mkNot <| mkApp("Valid", [a]) in - [Util.mkAssume(mkForall (Env.get_range env) ([[l_not_a]], [aa], mkIff(not_valid_a, valid)), Some "not interpretation", "l_not-interp")] in - let mk_range_interp : env -> string -> term -> list decl = fun env range tt -> - let range_ty = mkApp(range, []) in - [Util.mkAssume(mk_HasTypeZ (mk_Range_const ()) range_ty, Some "Range_const typing", (varops.mk_unique "typing_range_const"))] in - let mk_inversion_axiom : env -> string -> term -> list decl = fun env inversion tt -> - // (assert (forall ((t Term)) - // (! (implies (Valid (FStar.Pervasives.inversion t)) - // (forall ((x Term)) - // (! (implies (HasTypeFuel ZFuel x t) - // (HasTypeFuel (SFuel ZFuel) x t)) - // :pattern ((HasTypeFuel ZFuel x t))))) - // :pattern ((FStar.Pervasives.inversion t))))) - let tt = mk_fv ("t", Term_sort) in - let t = mkFreeV tt in - let xx = mk_fv ("x", Term_sort) in - let x = mkFreeV xx in - let inversion_t = mkApp(inversion, [t]) in - let valid = mkApp("Valid", [inversion_t]) in - let body = - let hastypeZ = mk_HasTypeZ x t in - let hastypeS = mk_HasTypeFuel (n_fuel 1) x t in - mkForall (Env.get_range env) ([[hastypeZ]], [xx], mkImp(hastypeZ, hastypeS)) - in - [Util.mkAssume(mkForall (Env.get_range env) ([[inversion_t]], [tt], mkImp(valid, body)), Some "inversion interpretation", "inversion-interp")] - in - let prims = [(Const.unit_lid, mk_unit); - (Const.bool_lid, mk_bool); - (Const.int_lid, mk_int); - (Const.real_lid, mk_real); - (Const.string_lid, mk_str); - (Const.true_lid, mk_true_interp); - (Const.false_lid, mk_false_interp); - (Const.and_lid, mk_and_interp); - (Const.or_lid, mk_or_interp); - (Const.eq2_lid, mk_eq2_interp); - (Const.imp_lid, mk_imp_interp); - (Const.iff_lid, mk_iff_interp); - (Const.not_lid, mk_not_interp); - //(Const.forall_lid, mk_forall_interp); - //(Const.exists_lid, mk_exists_interp); - (Const.range_lid, mk_range_interp); - (Const.inversion_lid,mk_inversion_axiom); - ] in - (fun (env:env) (t:lident) (s:string) (tt:term) -> - match BU.find_opt (fun (l, _) -> lid_equals l t) prims with - | None -> [] - | Some(_, f) -> f env s tt) - -let encode_smt_lemma env fv t = - let lid = fv.fv_name.v in - let form, decls = encode_function_type_as_formula t env in - decls@([Util.mkAssume(form, Some ("Lemma: " ^ (string_of_lid lid)), ("lemma_"^(string_of_lid lid)))] - |> mk_decls_trivial) - -let encode_free_var uninterpreted env fv tt t_norm quals :decls_t & env_t = - let lid = fv.fv_name.v in - if not <| (U.is_pure_or_ghost_function t_norm || is_smt_reifiable_function env.tcenv t_norm) - || U.is_lemma t_norm - || uninterpreted - then let arg_sorts = match (SS.compress t_norm).n with - | Tm_arrow {bs=binders} -> binders |> List.map (fun _ -> Term_sort) - | _ -> [] in - let arity = List.length arg_sorts in - let vname, vtok, env = new_term_constant_and_tok_from_lid env lid arity in - let d = Term.DeclFun(vname, arg_sorts, Term_sort, Some "Uninterpreted function symbol for impure function") in - let dd = Term.DeclFun(vtok, [], Term_sort, Some "Uninterpreted name for impure function") in - [d;dd] |> mk_decls_trivial, env - else if prims.is lid - then let vname = varops.new_fvar lid in - let tok, arity, definition = prims.mk lid vname in - let env = push_free_var env lid arity vname (Some tok) in - definition |> mk_decls_trivial, env - else let encode_non_total_function_typ = nsstr lid <> "Prims" in - let formals, (pre_opt, res_t) = - let args, comp = curried_arrow_formals_comp t_norm in - let tcenv_comp = Env.push_binders env.tcenv args in - let comp = - if is_smt_reifiable_comp env.tcenv comp - then S.mk_Total (reify_comp ({tcenv_comp with admit=true}) comp U_unknown) - else comp - in - if encode_non_total_function_typ - then args, TypeChecker.Util.pure_or_ghost_pre_and_post tcenv_comp comp - else args, (None, U.comp_result comp) - in - let mk_disc_proj_axioms guard encoded_res_t vapp (vars:fvs) = quals |> List.collect (function - | Discriminator d -> - let _, xxv = BU.prefix vars in - let xx = mkFreeV <| mk_fv (fv_name xxv, Term_sort) in - [Util.mkAssume(mkForall (S.range_of_fv fv) ([[vapp]], vars, - mkEq(vapp, Term.boxBool <| mk_tester (escape (string_of_lid d)) xx)), - Some "Discriminator equation", - ("disc_equation_"^escape (string_of_lid d)))] - - | Projector(d, f) -> - let _, xxv = BU.prefix vars in - let xx = mkFreeV <| mk_fv (fv_name xxv, Term_sort) in - let f = {ppname=f; index=0; sort=tun} in - let tp_name = mk_term_projector_name d f in //arity ok, primitive projector (#1383) - let prim_app = mkApp(tp_name, [xx]) in - [Util.mkAssume(mkForall (S.range_of_fv fv) ([[vapp]], vars, - mkEq(vapp, prim_app)), Some "Projector equation", ("proj_equation_"^tp_name))] - | _ -> []) in - let vars, guards, env', decls1, _ = encode_binders None formals env in - let guard, decls1 = match pre_opt with - | None -> mk_and_l guards, decls1 - | Some p -> let g, ds = encode_formula p env' in mk_and_l (g::guards), decls1@ds in - let dummy_var = mk_fv ("@dummy", dummy_sort) in - let dummy_tm = Term.mkFreeV dummy_var Range.dummyRange in - let should_thunk () = - //See note [Thunking Nullary Constants] in FStar.SMTEncoding.Term.fs - let is_type t = - match (SS.compress t).n with - | Tm_type _ -> true - | _ -> false - in - let is_squash t = - let head, _ = U.head_and_args t in - match (U.un_uinst head).n with - | Tm_fvar fv -> - Syntax.fv_eq_lid fv FStar.Parser.Const.squash_lid - - | Tm_refine {b={sort={n=Tm_fvar fv}}} -> - Syntax.fv_eq_lid fv FStar.Parser.Const.unit_lid - - | _ -> false - in - //Do not thunk ... - nsstr lid <> "Prims" //things in prims - && not (quals |> List.contains Logic) //logic qualified terms - && not (is_squash t_norm) //ambient squashed properties - && not (is_type t_norm) // : Type terms, since ambient typing hypotheses for these are cheap - in - let thunked, vars = - match vars with - | [] when should_thunk () -> - true, [dummy_var] - | _ -> false, vars - in - let arity = List.length formals in - let vname, vtok_opt, env = new_term_constant_and_tok_from_lid_maybe_thunked env lid arity thunked in - let get_vtok () = Option.get vtok_opt in - let vtok_tm = - match formals with - | [] when not thunked -> mkApp(vname, []) //mkFreeV <| mk_fv (vname, Term_sort) - | [] when thunked -> mkApp(vname, [dummy_tm]) - | _ -> mkApp(get_vtok(), []) //not thunked - in - let vtok_app = mk_Apply vtok_tm vars in - let vapp = mkApp(vname, List.map mkFreeV vars) in //arity ok, see decl below, arity is |vars| (#1383) - let decls2, env = - let vname_decl = Term.DeclFun(vname, vars |> List.map fv_sort, Term_sort, None) in - let tok_typing, decls2 = - let env = {env with encode_non_total_function_typ=encode_non_total_function_typ} in - if not(head_normal env tt) - then encode_term_pred None tt env vtok_tm - else encode_term_pred None t_norm env vtok_tm - in //NS:Unfortunately, this is duplicated work --- we effectively encode the function type twice - let tok_decl, env = - match vars with - | [] -> - let tok_typing = - Util.mkAssume(tok_typing, Some "function token typing", ("function_token_typing_"^vname)) - in - decls2@([tok_typing] |> mk_decls_trivial), - push_free_var env lid arity vname (Some <| mkApp(vname, [])) //mkFreeV (mk_fv (vname, Term_sort))) - - | _ when thunked -> decls2, env - - | _ -> - (* Generate a token and a function symbol; - equate the two, and use the function symbol for full applications *) - let vtok = get_vtok() in - let vtok_decl = Term.DeclFun(vtok, [], Term_sort, None) in - let name_tok_corr_formula pat = - mkForall (S.range_of_fv fv) ([[pat]], vars, mkEq(vtok_app, vapp)) - in - //See issue #613 for the choice of patterns here - let name_tok_corr = - //this allows rewriting (ApplyTT tok ... x1..xn) to f x1...xn - Util.mkAssume(name_tok_corr_formula vtok_app, - Some "Name-token correspondence", - ("token_correspondence_"^vname)) in - let tok_typing = - let ff = mk_fv ("ty", Term_sort) in - let f = mkFreeV ff in - let vtok_app_r = mk_Apply f [mk_fv (vtok, Term_sort)] in - //guard the token typing assumption with a Apply(f, tok), where f is typically __uu__PartialApp - //Additionally, the body of the term becomes - // NoHoist f (and (HasType tok ...) - // (forall (x1..xn).{:pattern (f x1..xn)} f x1..xn=ApplyTT (ApplyTT tok x1) ... xn - //which provides a typing hypothesis for the token - //and a rule to rewrite f x1..xn to ApplyTT tok ... x1..xn - //The NoHoist prevents the Z3 simplifier from hoisting the (HasType tok ...) part out - //Since the top-levels of modules are full of function typed terms - //not guarding it this way causes every typing assumption of an arrow type to be fired immediately - //regardless of whether or not the function is used ... leading to bloat - //these patterns aim to restrict the use of the typing assumption until such point as it is actually needed - let guarded_tok_typing = - mkForall (S.range_of_fv fv) - ([[vtok_app_r]], - [ff], - mkAnd(Term.mk_NoHoist f tok_typing, - name_tok_corr_formula vapp)) in - Util.mkAssume(guarded_tok_typing, Some "function token typing", ("function_token_typing_"^vname)) - in - decls2@([vtok_decl;name_tok_corr;tok_typing] |> mk_decls_trivial), - env - in - ([vname_decl] |> mk_decls_trivial)@tok_decl, env - in - let encoded_res_t, ty_pred, decls3 = - let res_t = SS.compress res_t in - let encoded_res_t, decls = encode_term res_t env' in - encoded_res_t, mk_HasType vapp encoded_res_t, decls in //occurs positively, so add fuel - let typingAx = Util.mkAssume(mkForall (S.range_of_fv fv) ([[vapp]], vars, mkImp(guard, ty_pred)), - Some "free var typing", - ("typing_"^vname)) in - let freshness = - if quals |> List.contains New - then [Term.fresh_constructor (S.range_of_fv fv) (vname, vars |> List.map fv_sort, Term_sort, varops.next_id()); - pretype_axiom false (S.range_of_fv fv) env vapp vars] - else [] in - let g = decls1@decls2@decls3@(freshness@typingAx::mk_disc_proj_axioms guard encoded_res_t vapp vars - |> mk_decls_trivial) in - g, env - - -let declare_top_level_let env x t t_norm : fvar_binding & decls_t & env_t = - match lookup_fvar_binding env x.fv_name.v with - (* Need to introduce a new name decl *) - | None -> - let decls, env = encode_free_var false env x t t_norm [] in - let fvb = lookup_lid env x.fv_name.v in - fvb, decls, env - - (* already declared, only need an equation *) - | Some fvb -> - fvb, [], env - - -let encode_top_level_val uninterpreted env us fv t quals = - let tt = - if FStar.Ident.nsstr (lid_of_fv fv) = "FStar.Ghost" - then norm_with_steps //no primops for FStar.Ghost, otherwise things like reveal/hide get simplified away too early - [Env.Eager_unfolding; - Env.Simplify; - Env.AllowUnboundUniverses; - Env.EraseUniverses; - Env.Exclude Env.Zeta] - env.tcenv t - else norm_before_encoding_us env us t - in - // if !dbg_SMTEncoding - // then BU.print3 "Encoding top-level val %s : %s\Normalized to is %s\n" - // (show fv) - // (show t) - // (show tt); - let decls, env = encode_free_var uninterpreted env fv t tt quals in - if U.is_smt_lemma t - then decls@encode_smt_lemma env fv tt, env - else decls, env - -let encode_top_level_vals env bindings quals = - bindings |> List.fold_left (fun (decls, env) lb -> - let decls', env = encode_top_level_val false env lb.lbunivs (BU.right lb.lbname) lb.lbtyp quals in - decls@decls', env) ([], env) - -exception Let_rec_unencodeable - -let copy_env (en:env_t) = { en with global_cache = BU.smap_copy en.global_cache} //Make a copy of all the mutable state of env_t, central place for keeping track of mutable fields in env_t - -let encode_top_level_let : - env_t -> (bool & list letbinding) -> list qualifier -> decls_t & env_t = - fun env (is_rec, bindings) quals -> - - let eta_expand binders formals body t = - let nbinders = List.length binders in - let formals, extra_formals = BU.first_N nbinders formals in - let subst = - List.map2 (fun ({binder_bv=formal}) ({binder_bv=binder}) -> - NT(formal, S.bv_to_name binder) - ) formals binders in - let extra_formals = - extra_formals - |> List.map (fun b -> - {b with - binder_bv={b.binder_bv with - sort=SS.subst subst b.binder_bv.sort}}) - |> U.name_binders in - let body = Syntax.extend_app_n - (SS.compress body) - (snd <| U.args_of_binders extra_formals) body.pos in - binders@extra_formals, body - in - - let destruct_bound_function t e - : (S.binders //arguments of the (possibly reified) lambda abstraction - & S.term //body of the (possibly reified) lambda abstraction - & S.comp) //result comp -// * bool //if set, we should generate a curried application of f - = - (* The input type [t_norm] might contain reifiable computation type which must be reified at this point *) - - let tcenv = {env.tcenv with admit=true} in - - let subst_comp formals actuals comp = - let subst = List.map2 (fun ({binder_bv=x}) ({binder_bv=b}) -> NT(x, S.bv_to_name b)) formals actuals in - SS.subst_comp subst comp - in - - let rec arrow_formals_comp_norm norm t = - //NS: tried using U.arrow_formals_comp here - // but that flattens Tot effects quite aggressively - let t = U.unascribe <| SS.compress t in - match t.n with - | Tm_arrow {bs=formals; comp} -> - SS.open_comp formals comp - - | Tm_refine _ -> - arrow_formals_comp_norm norm (U.unrefine t) - - | _ when not norm -> - let t_norm = norm_with_steps [Env.AllowUnboundUniverses; Env.Beta; Env.Weak; Env.HNF; - (* we don't know if this will terminate; so don't do recursive steps *) - Env.Exclude Env.Zeta; - Env.UnfoldUntil delta_constant; Env.EraseUniverses] - tcenv t - in - arrow_formals_comp_norm true t_norm - - | _ -> - [], S.mk_Total t - in - - let aux t e = - let binders, body, lopt = U.abs_formals e in - let formals, comp = - match binders with - | [] -> arrow_formals_comp_norm true t - //don't normalize t to avoid poorly encoding points-free code - //see, e.g., Benton2004.RHL.Example2 - | _ -> arrow_formals_comp_norm false t - in - let nformals = List.length formals in - let nbinders = List.length binders in - let binders, body, comp = - if nformals < nbinders (* explicit currying *) - then let bs0, rest = BU.first_N nformals binders in - let body = U.abs rest body lopt in - bs0, body, subst_comp formals bs0 comp - else if nformals > nbinders (* eta-expand before translating it *) - then let binders, body = eta_expand binders formals body (U.comp_result comp) in - binders, body, subst_comp formals binders comp - else binders, body, subst_comp formals binders comp - in - binders, body, comp - in - let binders, body, comp = aux t e in - let binders, body, comp = - let tcenv = Env.push_binders tcenv binders in - if is_smt_reifiable_comp tcenv comp - then let eff_name = comp |> U.comp_effect_name in - let comp = reify_comp tcenv comp U_unknown in - let body = TcUtil.norm_reify tcenv [] - (U.mk_reify body (Some eff_name)) in - let more_binders, body, comp = aux comp body in - binders@more_binders, body, comp - else binders, body, comp - in - binders, - //setting the use_eq ascription flag to false, - // doesn't matter since the flag is irrelevant outside the typechecker - U.ascribe body (Inl (U.comp_result comp), None, false), - comp - in - - - try - if bindings |> BU.for_all (fun lb -> U.is_lemma lb.lbtyp) - then encode_top_level_vals env bindings quals - else - let toks, typs, decls, env = - bindings |> List.fold_left (fun (toks, typs, decls, env) lb -> - (* some, but not all are lemmas; impossible *) - if U.is_lemma lb.lbtyp then raise Let_rec_unencodeable; - (* #2894: If this is a recursive definition, make sure to unfold the type - until the arrow structure is evident (we use whnf for it). Otherwise - there will be thunking inconsistencies in the encoding. *) - let t_norm = - if is_rec - then N.unfold_whnf' [Env.AllowUnboundUniverses] env.tcenv lb.lbtyp - else norm_before_encoding env lb.lbtyp - in - (* We are declaring the top_level_let with t_norm which might contain *) - (* non-reified reifiable computation type. *) - (* TODO : clear this mess, the declaration should have a type corresponding to *) - (* the encoded term *) - let tok, decl, env = declare_top_level_let env (BU.right lb.lbname) lb.lbtyp t_norm in - tok::toks, t_norm::typs, decl::decls, env) - ([], [], [], env) - in - let toks_fvbs = List.rev toks in - let decls = List.rev decls |> List.flatten in - (* - * AR: decls are the declarations for the top-level lets - * if one of the let body contains a let rec (inner let rec), we simply return decls at that point, inner let recs are not encoded to the solver yet (see Inner_let_rec below) - * the way it is implemented currently is that, the call to encode the let body throws an exception Inner_let_rec which is caught below in this function - * and the exception handler simply returns decls - * however, it seems to mess up the env cache - * basically, the let rec can be quite deep in the body, and then traversing the body before it, we might encode new decls, add them to the cache etc. - * since the cache is stateful, this would mean that there would be some symbols in the cache but not in the returned decls list (which only contains the top-level lets) - * this results in z3 errors - * so, taking a snapshot of the env, and return this env in handling of the Inner_let_rec (see also #1502) - *) - let env_decls = copy_env env in - let typs = List.rev typs in - - let encode_non_rec_lbdef - (bindings:list letbinding) - (typs:list S.term) - (toks:list fvar_binding) - (env:env_t) = - match bindings, typs, toks with - | [{lbunivs=uvs;lbdef=e;lbname=lbn}], [t_norm], [fvb] -> - - (* Open universes *) - let flid = fvb.fvar_lid in - let env', e, t_norm = - let tcenv', _, e_t = - Env.open_universes_in env.tcenv uvs [e; t_norm] in - let e, t_norm = - match e_t with - | [e; t_norm] -> e, t_norm - | _ -> failwith "Impossible" in - {env with tcenv=tcenv'}, e, t_norm - in - - (* Open binders *) - let (binders, body, t_body_comp) = destruct_bound_function t_norm e in - let t_body = U.comp_result t_body_comp in - if !dbg_SMTEncoding - then BU.print2 "Encoding let : binders=[%s], body=%s\n" - (show binders) - (show body); - (* Encode binders *) - let vars, binder_guards, env', binder_decls, _ = encode_binders None binders env' in - let vars, app = - if fvb.fvb_thunked && vars = [] - then let dummy_var = mk_fv ("@dummy", dummy_sort) in - let dummy_tm = Term.mkFreeV dummy_var Range.dummyRange in - let app = Term.mkApp (fvb.smt_id, [dummy_tm]) (S.range_of_lbname lbn) in - [dummy_var], app - else vars, maybe_curry_fvb (S.range_of_lbname lbn) fvb (List.map mkFreeV vars) - in - let is_logical = - match (SS.compress t_body).n with - | Tm_fvar fv when S.fv_eq_lid fv FStar.Parser.Const.logical_lid -> true - | _ -> false - in - let is_smt_theory_symbol = - let fv = FStar.Compiler.Util.right lbn in - Env.fv_has_attr env.tcenv fv FStar.Parser.Const.smt_theory_symbol_attr_lid - in - let is_sub_singleton = U.is_sub_singleton body in - let should_encode_logical = - not is_smt_theory_symbol - && (quals |> List.contains Logic || is_logical) - in - let make_eqn name pat app body = - //NS 05.25: This used to be mkImp(mk_and_l guards, mkEq(app, body))), - //But the guard is unnecessary given the pattern - Util.mkAssume(mkForall (S.range_of_lbname lbn) - ([[pat]], vars, mkEq(app,body)), - Some (BU.format1 "Equation for %s" (string_of_lid flid)), - (name ^ "_" ^ fvb.smt_id)) - in - let eqns,decls2 = - let basic_eqn_name = - if should_encode_logical - then "defn_equation" - else "equation" - in - let basic_eqn, decls = - let app_is_prop = Term.mk_subtype_of_unit app in - if should_encode_logical - then ( - if is_sub_singleton && Options.Ext.get "retain_old_prop_typing" = "" - then ( - Util.mkAssume(mkForall (S.range_of_lbname lbn) - ([[app_is_prop]], vars, mkImp(mk_and_l binder_guards, mk_Valid <| app_is_prop)), - Some (BU.format1 "Prop-typing for %s" (string_of_lid flid)), - (basic_eqn_name ^ "_" ^ fvb.smt_id)), - [] - ) - else ( - let body, decls = encode_term body env' in - make_eqn basic_eqn_name app_is_prop app body, - decls - ) - ) - else ( - let body, decls = encode_term body env' in - make_eqn basic_eqn_name app app body, decls - ) - in - if should_encode_logical - then let pat, app, (body, decls2) = - app, mk_Valid app, encode_formula body env' - in - let logical_eqn = make_eqn "equation" pat app body in - [logical_eqn; basic_eqn], decls@decls2 - else [basic_eqn], decls - in - decls@binder_decls@decls2@((eqns@primitive_type_axioms env.tcenv flid fvb.smt_id app) - |> mk_decls_trivial), - env - | _ -> failwith "Impossible" - in - - let encode_rec_lbdefs (bindings:list letbinding) - (typs:list S.term) - (toks:list fvar_binding) - (env:env_t) = - (* encoding recursive definitions using fuel to throttle unfoldings *) - (* We create a new variable corresponding to the current fuel *) - let fuel = mk_fv (varops.fresh env.current_module_name "fuel", Fuel_sort) in - let fuel_tm = mkFreeV fuel in - let env0 = env in - (* For each declaration, we push in the environment its fuel-guarded copy (using current fuel) *) - let gtoks, env = toks |> List.fold_left (fun (gtoks, env) fvb -> //(flid_fv, (f, ftok)) -> - let flid = fvb.fvar_lid in - let g = varops.new_fvar (Ident.lid_add_suffix flid "fuel_instrumented") in - let gtok = varops.new_fvar (Ident.lid_add_suffix flid "fuel_instrumented_token") in - let env = push_free_var env flid fvb.smt_arity gtok (Some <| mkApp(g, [fuel_tm])) in - (fvb, g, gtok)::gtoks, env) ([], env) - in - let gtoks = List.rev gtoks in - - let encode_one_binding env0 (fvb, g, gtok) t_norm ({lbunivs=uvs;lbname=lbn; lbdef=e}) = - - (* Open universes *) - let env', e, t_norm = - let tcenv', _, e_t = - Env.open_universes_in env.tcenv uvs [e; t_norm] in - let e, t_norm = - match e_t with - | [e; t_norm] -> e, t_norm - | _ -> failwith "Impossible" in - {env with tcenv=tcenv'}, e, t_norm - in - if !dbg_SMTEncoding - then BU.print3 "Encoding let rec %s : %s = %s\n" - (show lbn) - (show t_norm) - (show e); - - (* Open binders *) - let (binders, body, tres_comp) = destruct_bound_function t_norm e in - let curry = fvb.smt_arity <> List.length binders in - let pre_opt, tres = TcUtil.pure_or_ghost_pre_and_post env.tcenv tres_comp in - if !dbg_SMTEncoding - then BU.print4 "Encoding let rec %s: \n\tbinders=[%s], \n\tbody=%s, \n\ttres=%s\n" - (show lbn) - (show binders) - (show body) - (show tres_comp); - //let _ = - // if curry - // then failwith "Unexpected type of let rec in SMT Encoding; \ - // expected it to be annotated with an arrow type" - //in - - - let vars, guards, env', binder_decls, _ = encode_binders None binders env' in - - let guard, guard_decls = - match pre_opt with - | None -> mk_and_l guards, [] - | Some pre -> - let guard, decls0 = encode_formula pre env' in - mk_and_l (guards@[guard]), decls0 - in - let binder_decls = binder_decls @ guard_decls in - let decl_g = Term.DeclFun(g, Fuel_sort::List.map fv_sort (fst (BU.first_N fvb.smt_arity vars)), Term_sort, Some "Fuel-instrumented function name") in - let decl_g_tok = Term.DeclFun(gtok, [], Term_sort, Some "Token for fuel-instrumented partial applications") in - let env0 = push_zfuel_name env0 fvb.fvar_lid g gtok in - let vars_tm = List.map mkFreeV vars in - let rng = (S.range_of_lbname lbn) in - let app = maybe_curry_fvb rng fvb (List.map mkFreeV vars) in - let mk_g_app args = maybe_curry_app rng (Inl (Var g)) (fvb.smt_arity + 1) args in - let gsapp = mk_g_app (mkApp("SFuel", [fuel_tm])::vars_tm) in - let gmax = mk_g_app (mkApp("MaxFuel", [])::vars_tm) in - let body_tm, decls2 = encode_term body env' in - - //NS 05.25: This used to be mkImp(mk_and_l guards, mkEq(gsapp, body_tm) - //But, the pattern ensures that this only applies to well-typed terms - //NS 08/10: Setting the weight of this quantifier to 0, since its instantiations are controlled by F* fuel - //NS 11/28/2018: Restoring the mkImp (mk_and_l guards, mkEq(gsapp, body_tm)) - // 11/29/2018: Also guarding by the precondition of a Pure/Ghost function in addition to typing guards - let eqn_g = - Util.mkAssume - (mkForall' (S.range_of_lbname lbn) - ([[gsapp]], Some 0, fuel::vars, mkImp(guard, mkEq(gsapp, body_tm))), - Some (BU.format1 "Equation for fuel-instrumented recursive function: %s" (string_of_lid fvb.fvar_lid)), - "equation_with_fuel_" ^g) in - let eqn_f = Util.mkAssume(mkForall (S.range_of_lbname lbn) ([[app]], vars, mkEq(app, gmax)), - Some "Correspondence of recursive function to instrumented version", - ("@fuel_correspondence_"^g)) in - let eqn_g' = Util.mkAssume(mkForall (S.range_of_lbname lbn) ([[gsapp]], fuel::vars, mkEq(gsapp, mk_g_app (Term.n_fuel 0::vars_tm))), - Some "Fuel irrelevance", - ("@fuel_irrelevance_" ^g)) in - let aux_decls, g_typing = - let gapp = mk_g_app (fuel_tm::vars_tm) in - let tok_corr = - let tok_app = mk_Apply (mkFreeV <| mk_fv (gtok, Term_sort)) (fuel::vars) in - let tot_fun_axioms = - let head = mkFreeV <| mk_fv (gtok, Term_sort) in - let vars = fuel :: vars in - //the guards are trivial here since this tot_fun_axioms - //should never appear in a goal (see Bug1750.fst, test_currying) - let guards = List.map (fun _ -> mkTrue) vars in - EncodeTerm.isTotFun_axioms rng head vars guards (U.is_pure_comp tres_comp) - in - Util.mkAssume(mkAnd(mkForall (S.range_of_lbname lbn) ([[tok_app]], fuel::vars, mkEq(tok_app, gapp)), - tot_fun_axioms), - Some "Fuel token correspondence", - ("fuel_token_correspondence_"^gtok)) - in - let aux_decls, typing_corr = - let g_typing, d3 = encode_term_pred None tres env' gapp in - d3, [Util.mkAssume(mkForall (S.range_of_lbname lbn) - ([[gapp]], fuel::vars, mkImp(guard, g_typing)), - Some "Typing correspondence of token to term", - ("token_correspondence_"^g))] - in - aux_decls, typing_corr@[tok_corr] - in - - binder_decls@decls2@aux_decls@([decl_g;decl_g_tok] |> mk_decls_trivial), - [eqn_g;eqn_g';eqn_f]@g_typing |> mk_decls_trivial, env0 - in - - let decls, eqns, env0 = List.fold_left (fun (decls, eqns, env0) (gtok, ty, lb) -> - let decls', eqns', env0 = encode_one_binding env0 gtok ty lb in - decls'::decls, eqns'@eqns, env0) - ([decls], [], env0) - (List.zip3 gtoks typs bindings) - in - (* Function declarations must come first to be defined in all recursive definitions *) - let prefix_decls, elts, rest = - let isDeclFun = function | DeclFun _ -> true | _ -> false in - decls |> List.flatten |> (fun decls -> - //decls is a list of decls_elt ... each of which contains a list decl in it - //we need to go through each of those, accumulate DeclFuns and remove them from there - let prefix_decls, elts, rest = List.fold_left (fun (prefix_decls, elts, rest) elt -> - if elt.key |> BU.is_some && List.existsb isDeclFun elt.decls - then prefix_decls, elts@[elt], rest - else let elt_decl_funs, elt_rest = List.partition isDeclFun elt.decls in - prefix_decls @ elt_decl_funs, elts, rest @ [{ elt with decls = elt_rest }] - ) ([], [], []) decls in - prefix_decls |> mk_decls_trivial, elts, rest) - in - let eqns = List.rev eqns in - prefix_decls@elts@rest@eqns, env0 - in - - if quals |> BU.for_some (function HasMaskedEffect -> true | _ -> false) - || typs |> BU.for_some (fun t -> not <| (U.is_pure_or_ghost_function t || - is_smt_reifiable_function env.tcenv t)) - then decls, env_decls - else - try - if not is_rec - then - (* Encoding non-recursive definitions *) - encode_non_rec_lbdef bindings typs toks_fvbs env - else - encode_rec_lbdefs bindings typs toks_fvbs env - with - | Inner_let_rec names -> - let plural = List.length names > 1 in - let r = List.hd names |> snd in - FStar.TypeChecker.Err.add_errors - env.tcenv - [(Errors.Warning_DefinitionNotTranslated, - // FIXME - [Errors.text <| BU.format3 - "Definitions of inner let-rec%s %s and %s enclosing top-level letbinding are not encoded to the solver, you will only be able to reason with their types" - (if plural then "s" else "") - (List.map fst names |> String.concat ",") - (if plural then "their" else "its")], - r, - Errors.get_ctx () // TODO: fix this, leaking abstraction - )]; - decls, env_decls //decls are type declarations for the lets, if there is an inner let rec, only those are encoded to the solver - - with Let_rec_unencodeable -> - let msg = bindings |> List.map (fun lb -> show lb.lbname) |> String.concat " and " in - let decl = Caption ("let rec unencodeable: Skipping: " ^msg) in - [decl] |> mk_decls_trivial, env - -let encode_sig_inductive (env:env_t) (se:sigelt) -: decls_t & env_t -= let Sig_inductive_typ - { lid=t; us=universe_names; params=tps; - t=k; ds=datas; injective_type_params } = se.sigel in - let t_lid = t in - let tcenv = env.tcenv in - let quals = se.sigquals in - let is_logical = quals |> BU.for_some (function Logic | Assumption -> true | _ -> false) in - let constructor_or_logic_type_decl (c:constructor_t) = - if is_logical - then [Term.DeclFun(c.constr_name, c.constr_fields |> List.map (fun f -> f.field_sort), Term_sort, None)] - else constructor_to_decl (Ident.range_of_lid t) c in - let inversion_axioms env tapp vars = - if datas |> BU.for_some (fun l -> Env.try_lookup_lid env.tcenv l |> Option.isNone) //Q: Why would this happen? - then [] - else ( - let xxsym, xx = fresh_fvar env.current_module_name "x" Term_sort in - let data_ax, decls = - datas |> - List.fold_left - (fun (out, decls) l -> - let is_l = mk_data_tester env l xx in - let inversion_case, decls' = - if injective_type_params - || Options.Ext.get "compat:injectivity" <> "" - then ( - let _, data_t = Env.lookup_datacon env.tcenv l in - let args, res = U.arrow_formals data_t in - let indices = res |> U.head_and_args_full |> snd in - let env = args |> List.fold_left - (fun env ({binder_bv=x}) -> push_term_var env x (mkApp(mk_term_projector_name l x, [xx]))) - env in - let indices, decls' = encode_args indices env in - if List.length indices <> List.length vars - then failwith "Impossible"; - let eqs = List.map2 (fun v a -> mkEq(mkFreeV v, a)) vars indices in - mkAnd(is_l, mk_and_l eqs), decls' - ) - else is_l, [] - in - mkOr(out, inversion_case), decls@decls') - (mkFalse, []) - in - let ffsym, ff = fresh_fvar env.current_module_name "f" Fuel_sort in - let fuel_guarded_inversion = - let xx_has_type_sfuel = - if List.length datas > 1 - then mk_HasTypeFuel (mkApp("SFuel", [ff])) xx tapp - else mk_HasTypeFuel ff xx tapp //no point requiring non-zero fuel if there are no disjunctions - in - Util.mkAssume( - mkForall - (Ident.range_of_lid t) - ([[xx_has_type_sfuel]], - add_fuel (mk_fv (ffsym, Fuel_sort)) (mk_fv (xxsym, Term_sort)::vars), - mkImp(xx_has_type_sfuel, data_ax)), - Some "inversion axiom", //this name matters! see Sig_bundle case near line 1493 - (varops.mk_unique ("fuel_guarded_inversion_"^(string_of_lid t)))) - in - decls - @([fuel_guarded_inversion] |> mk_decls_trivial) - ) - in - let formals, res = - let k = - match tps with - | [] -> k - | _ -> S.mk (Tm_arrow {bs=tps; comp=S.mk_Total k}) k.pos - in - let k = norm_before_encoding env k in - U.arrow_formals k - in - let vars, guards, env', binder_decls, _ = encode_binders None formals env in - let arity = List.length vars in - let tname, ttok, env = new_term_constant_and_tok_from_lid env t arity in - let ttok_tm = mkApp(ttok, []) in - let guard = mk_and_l guards in - let tapp = mkApp(tname, List.map mkFreeV vars) in //arity ok - let decls, env = - //See: https://github.com/FStarLang/FStar/commit/b75225bfbe427c8aef5b59f70ff6d79aa014f0b4 - //See: https://github.com/FStarLang/FStar/issues/349 - let tname_decl = - constructor_or_logic_type_decl - { - constr_name = tname; - constr_fields = vars |> List.map (fun fv -> {field_name=tname^fv_name fv; field_sort=fv_sort fv; field_projectible=false}) ; - //The field_projectible=false above is extremely important; it makes sure that type-formers are not injective - constr_sort=Term_sort; - constr_id=Some (varops.next_id()); - constr_base=false - } - in - let tok_decls, env = - match vars with - | [] -> [], push_free_var env t arity tname (Some <| mkApp(tname, [])) - | _ -> - let ttok_decl = Term.DeclFun(ttok, [], Term_sort, Some "token") in - let ttok_fresh = Term.fresh_token (ttok, Term_sort) (varops.next_id()) in - let ttok_app = mk_Apply ttok_tm vars in - let pats = [[ttok_app]; [tapp]] in - // These patterns allow rewriting (ApplyT T@tok args) to (T args) and vice versa - // This seems necessary for some proofs, but the bidirectional rewriting may be inefficient - let name_tok_corr = - Util.mkAssume(mkForall' (Ident.range_of_lid t) (pats, None, vars, mkEq(ttok_app, tapp)), - Some "name-token correspondence", - ("token_correspondence_"^ttok)) in - [ttok_decl; ttok_fresh; name_tok_corr], env - in - tname_decl@tok_decls, env - in - let kindingAx = - let k, decls = encode_term_pred None res env' tapp in - let karr = - if List.length formals > 0 - then [Util.mkAssume(mk_tester "Tm_arrow" (mk_PreType ttok_tm), Some "kinding", ("pre_kinding_"^ttok))] - else [] - in - let rng = Ident.range_of_lid t in - let tot_fun_axioms = EncodeTerm.isTotFun_axioms rng ttok_tm vars (List.map (fun _ -> mkTrue) vars) true in - decls@(karr@[Util.mkAssume(mkAnd(tot_fun_axioms, mkForall rng ([[tapp]], vars, mkImp(guard, k))), - None, - ("kinding_"^ttok))] |> mk_decls_trivial) - in - let aux = - kindingAx - @(inversion_axioms env tapp vars) - @([pretype_axiom (not injective_type_params) (Ident.range_of_lid t) env tapp vars] |> mk_decls_trivial) - in - (decls |> mk_decls_trivial)@binder_decls@aux, env - -let encode_datacon (env:env_t) (se:sigelt) -: decls_t & env_t -= let Sig_datacon {lid=d; us; t; num_ty_params=n_tps; mutuals; injective_type_params } = se.sigel in - let quals = se.sigquals in - let t = norm_before_encoding_us env us t in - let formals, t_res = U.arrow_formals t in - let arity = List.length formals in - let ddconstrsym, ddtok, env = new_term_constant_and_tok_from_lid env d arity in - let ddtok_tm = mkApp(ddtok, []) in - let fuel_var, fuel_tm = fresh_fvar env.current_module_name "f" Fuel_sort in - let s_fuel_tm = mkApp("SFuel", [fuel_tm]) in - let vars, guards, env', binder_decls, names = encode_binders (Some fuel_tm) formals env in - let injective_type_params = - injective_type_params || Options.Ext.get "compat:injectivity" <> "" - in - let fields = - names |> - List.mapi - (fun n x -> - let field_projectible = - n >= n_tps || //either this field is not a type parameter - injective_type_params //or we are allowed to be injective on parameters - in - { field_name=mk_term_projector_name d x; - field_sort=Term_sort; - field_projectible }) - in - let datacons = { - constr_name=ddconstrsym; - constr_fields=fields; - constr_sort=Term_sort; - constr_id=Some (varops.next_id()); - constr_base=not injective_type_params - } |> Term.constructor_to_decl (Ident.range_of_lid d) in - let app = mk_Apply ddtok_tm vars in - let guard = mk_and_l guards in - let xvars = List.map mkFreeV vars in - let dapp = mkApp(ddconstrsym, xvars) in //arity ok; |xvars| = |formals| = arity - - let tok_typing, decls3 = encode_term_pred None t env ddtok_tm in - let tok_typing = - match fields with - | _::_ -> - let ff = mk_fv ("ty", Term_sort) in - let f = mkFreeV ff in - let vtok_app_l = mk_Apply ddtok_tm [ff] in - let vtok_app_r = mk_Apply f [mk_fv (ddtok, Term_sort)] in - //guard the token typing assumption with a Apply(tok, f) or Apply(f, tok) - //Additionally, the body of the term becomes NoHoist f (HasType tok ...) - // to prevent the Z3 simplifier from hoisting the (HasType tok ...) part out - //Since the top-levels of modules are full of function typed terms - //not guarding it this way causes every typing assumption of an arrow type to be fired immediately - //regardless of whether or not the function is used ... leading to bloat - //these patterns aim to restrict the use of the typing assumption until such point as it is actually needed - mkForall (Ident.range_of_lid d) - ([[vtok_app_l]; [vtok_app_r]], - [ff], - Term.mk_NoHoist f tok_typing) - | _ -> tok_typing in - let ty_pred', t_res_tm, decls_pred = - let t_res_tm, t_res_decls = encode_term t_res env' in - mk_HasTypeWithFuel (Some fuel_tm) dapp t_res_tm, t_res_tm, t_res_decls in - let proxy_fresh = match formals with - | [] -> [] - | _ -> [Term.fresh_token (ddtok, Term_sort) (varops.next_id())] in - - let encode_elim () = - let head, args = U.head_and_args t_res in - match (SS.compress head).n with - | Tm_uinst({n=Tm_fvar fv}, _) - | Tm_fvar fv -> - let encoded_head_fvb = lookup_free_var_name env' fv.fv_name in - let encoded_args, arg_decls = encode_args args env' in - let _, arg_vars, elim_eqns_or_guards, _ = - List.fold_left - (fun (env, arg_vars, eqns_or_guards, i) (orig_arg, arg) -> - let _, xv, env = gen_term_var env (S.new_bv None tun) in - (* we only get equations induced on the type indices, not parameters; *) - (* Also see https://github.com/FStarLang/FStar/issues/349 *) - let eqns = - if i < n_tps - then eqns_or_guards - else mkEq(arg, xv)::eqns_or_guards - in - (env, xv::arg_vars, eqns, i + 1)) - (env', [], [], 0) - (FStar.Compiler.List.zip args encoded_args) - in - let arg_vars = List.rev arg_vars in - let arg_params, _ = List.splitAt n_tps arg_vars in - let data_arg_params, _ = List.splitAt n_tps vars in - //Express the guards in terms of the parameters of the type constructor - //not the arguments of the data constructor - let elim_eqns_and_guards = - List.fold_left2 - (fun elim_eqns_and_guards data_arg_param arg_param -> - Term.subst elim_eqns_and_guards data_arg_param arg_param) - (mk_and_l (elim_eqns_or_guards@guards)) - data_arg_params - arg_params - in - let ty = maybe_curry_fvb fv.fv_name.p encoded_head_fvb arg_vars in - let xvars = List.map mkFreeV vars in - let dapp = mkApp(ddconstrsym, xvars) in //arity ok; |xvars| = |formals| = arity - let ty_pred = mk_HasTypeWithFuel (Some s_fuel_tm) dapp ty in - let arg_binders = List.map fv_of_term arg_vars in - let typing_inversion = - Util.mkAssume(mkForall (Ident.range_of_lid d) ([[ty_pred]], - add_fuel (mk_fv (fuel_var, Fuel_sort)) (vars@arg_binders), - mkImp(ty_pred, elim_eqns_and_guards)), - Some "data constructor typing elim", - ("data_elim_" ^ ddconstrsym)) in - let lex_t = mkFreeV <| mk_fv (string_of_lid Const.lex_t_lid, Term_sort) in - let subterm_ordering = - (* subterm ordering *) - let prec = - vars - |> List.mapi (fun i v -> - (* it's a parameter, so it's inaccessible and no need for a sub-term ordering on it *) - if i < n_tps - then [] - else [mk_Precedes lex_t lex_t (mkFreeV v) dapp]) - |> List.flatten - in - Util.mkAssume(mkForall (Ident.range_of_lid d) - ([[ty_pred]], - add_fuel (mk_fv (fuel_var, Fuel_sort)) (vars@arg_binders), - mkImp(ty_pred, mk_and_l prec)), - Some "subterm ordering", - ("subterm_ordering_"^ddconstrsym)) - in - let codomain_ordering, codomain_decls = - let _, formals' = BU.first_N n_tps formals in (* no codomain ordering for the parameters *) - let _, vars' = BU.first_N n_tps vars in - let norm t = - N.unfold_whnf' [Env.AllowUnboundUniverses; - Env.EraseUniverses; - Env.Unascribe; - //we don't know if this will terminate; so don't do recursive steps - Env.Exclude Env.Zeta] - env'.tcenv - t - in - let warn_compat () = - FStar.Errors.log_issue fv FStar.Errors.Warning_DeprecatedGeneric [ - Errors.Msg.text "Using 'compat:2954' to use a permissive encoding of the subterm ordering on the codomain of a constructor."; - Errors.Msg.text "This is deprecated and will be removed in a future version of F*." - ] - in - let codomain_prec_l, cod_decls = - List.fold_left2 - (fun (codomain_prec_l, cod_decls) formal var -> - let rec binder_and_codomain_type t = - let t = U.unrefine t in - match (SS.compress t).n with - | Tm_arrow _ -> - let bs, c = U.arrow_formals_comp (U.unrefine t) in - begin - match bs with - | [] -> None - | _ when not (U.is_tot_or_gtot_comp c) -> None - | _ -> - if U.is_lemma_comp c - then None //not useful for lemmas - else - let t = U.unrefine (U.comp_result c) in - let t = norm t in - if is_type t || U.is_sub_singleton t - then None //ordering on Type and squashed values is not useful - else ( - let head, _ = U.head_and_args_full t in - match (U.un_uinst head).n with - | Tm_fvar fv -> - if BU.for_some (S.fv_eq_lid fv) mutuals - then Some (bs, c) - else if Options.Ext.get "compat:2954" <> "" - then (warn_compat(); Some (bs, c)) //compatibility mode - else None - | _ -> - if Options.Ext.get "compat:2954" <> "" - then (warn_compat(); Some (bs, c)) //compatibility mode - else None - ) - end - | _ -> - let head, _ = U.head_and_args t in - let t' = norm t in - let head', _ = U.head_and_args t' in - match TEQ.eq_tm env.tcenv head head' with - | TEQ.Equal -> None //no progress after whnf - | TEQ.NotEqual -> binder_and_codomain_type t' - | _ -> - //Did we actually make progress? Be conservative to avoid an infinite loop - match (SS.compress head).n with - | Tm_fvar _ - | Tm_name _ - | Tm_uinst _ -> - //The underlying name must have changed, otherwise we would have got Equal - //so, we made some progress - binder_and_codomain_type t' - | _ -> - //unclear if we made progress or not - None - - in - match binder_and_codomain_type formal.binder_bv.sort with - | None -> - codomain_prec_l, cod_decls - | Some (bs, c) -> - //var bs << D ... var ... - let bs', guards', _env', bs_decls, _ = encode_binders None bs env' in - let fun_app = mk_Apply (mkFreeV var) bs' in - mkForall (Ident.range_of_lid d) - ([[mk_Precedes lex_t lex_t fun_app dapp]], - bs', - //need to use ty_pred' here, to avoid variable capture - //Note, ty_pred' is indexed by fuel, not S_fuel - //That's ok, since the outer pattern is guarded on S_fuel - mkImp (mk_and_l (ty_pred'::guards'), - mk_Precedes lex_t lex_t fun_app dapp)) - :: codomain_prec_l, - bs_decls @ cod_decls) - ([],[]) - formals' - vars' - in - match codomain_prec_l with - | [] -> - [], cod_decls - | _ -> - [Util.mkAssume(mkForall (Ident.range_of_lid d) - ([[ty_pred]],//we use ty_pred here as the pattern, which has an S_fuel guard - add_fuel (mk_fv (fuel_var, Fuel_sort)) (vars@arg_binders), - mk_and_l codomain_prec_l), - Some "well-founded ordering on codomain", - ("well_founded_ordering_on_codomain_"^ddconstrsym))], - cod_decls - in - arg_decls @ codomain_decls, - [typing_inversion; subterm_ordering] @ codomain_ordering - - | _ -> - Errors.log_issue se Errors.Warning_ConstructorBuildsUnexpectedType - (BU.format2 "Constructor %s builds an unexpected type %s" (show d) (show head)); - [], [] - in - let decls2, elim = encode_elim () in - let data_cons_typing_intro_decl = - // - //AR: - // - //Typing intro for the data constructor - // - //We do a bit of manipulation for type indices - //Consider the Cons data constructor of a length-indexed vector type: - // type vector : nat -> Type = | Emp : vector 0 - // | Cons: n:nat -> hd:nat -> tl:vec n -> vec (n+1) - // - //So far we have - // ty_pred' = HasTypeFuel f (Cons n hd tl) (vector (n+1)) - // vars = n, hd, tl - // guard = And of typing guards for n, hd, tl (i.e. (HasType n nat) etc.) - // - //If we emitted the straightforward typing axiom: - // forall n hd tl. HasTypeFuel f (Cons n hd tl) (vector (n+1)) - //with pattern - // HasTypeFuel f (Cons n hd tl) (vecor (n+1)) - // - //It results in too restrictive a pattern, - //Specifically, if we need to prove HasTypeFuel f (Cons 0 1 Emp) (vector 1), - // the axiom will not fire, since the pattern is specifically looking for - // (n+1) in the resulting vector type, whereas here we have a term 1, - // which is not addition syntactically - // - //So we do a little bit of surgery below to emit an axiom of the form: - // forall n hd tl m. m = n + 1 ==> HasTypeFuel f (Cons n hd tl) (vector m) - //where m is a fresh variable - // - //Also see #2456 - // - let ty_pred', vars, guard = - match t_res_tm.tm with - | App (op, args) -> - //iargs are index arguments in the return type of the data constructor - let targs, iargs = List.splitAt n_tps args in - //fresh vars for iargs - let fresh_ivars, fresh_iargs = - iargs |> List.map (fun _ -> fresh_fvar env.current_module_name "i" Term_sort) - |> List.split in - //equality guards - let additional_guards = - mk_and_l (List.map2 (fun a fresh_a -> mkEq (a, fresh_a)) iargs fresh_iargs) in - - mk_HasTypeWithFuel - (Some fuel_tm) - dapp - ({t_res_tm with tm = App (op, targs@fresh_iargs)}), - - vars@(fresh_ivars |> List.map (fun s -> mk_fv (s, Term_sort))), - - mkAnd (guard, additional_guards) - - | _ -> ty_pred', vars, guard in //When will this case arise? - - Util.mkAssume(mkForall (Ident.range_of_lid d) - ([[ty_pred']],add_fuel (mk_fv (fuel_var, Fuel_sort)) vars, mkImp(guard, ty_pred')), - Some "data constructor typing intro", - ("data_typing_intro_"^ddtok)) in - - let g = binder_decls - @decls2 - @decls3 - @([Term.DeclFun(ddtok, [], Term_sort, Some (BU.format1 "data constructor proxy: %s" (show d)))] - @proxy_fresh |> mk_decls_trivial) - @decls_pred - @([Util.mkAssume(tok_typing, Some "typing for data constructor proxy", ("typing_tok_"^ddtok)); - Util.mkAssume(mkForall (Ident.range_of_lid d) - ([[app]], vars, - mkEq(app, dapp)), Some "equality for proxy", ("equality_tok_"^ddtok)); - data_cons_typing_intro_decl; - ]@elim |> mk_decls_trivial) in - (datacons |> mk_decls_trivial) @ g, env - - -let rec encode_sigelt (env:env_t) (se:sigelt) : (decls_t & env_t) = - let nm = Print.sigelt_to_string_short se in - let g, env = Errors.with_ctx (BU.format1 "While encoding top-level declaration `%s`" - (Print.sigelt_to_string_short se)) - (fun () -> encode_sigelt' env se) - in - let g = - match g with - | [] -> - begin - if !dbg_SMTEncoding then - BU.print1 "Skipped encoding of %s\n" nm; - [Caption (BU.format1 "" nm)] |> mk_decls_trivial - end - - | _ -> ([Caption (BU.format1 "" nm)] |> mk_decls_trivial) - @g - @([Caption (BU.format1 "" nm)] |> mk_decls_trivial) in - g, env - -and encode_sigelt' (env:env_t) (se:sigelt) : (decls_t & env_t) = - if !dbg_SMTEncoding - then (BU.print1 "@@@Encoding sigelt %s\n" (show se)); - - let is_opaque_to_smt (t:S.term) = - match (SS.compress t).n with - | Tm_constant (Const_string(s, _)) -> s = "opaque_to_smt" - | _ -> false - in - let is_uninterpreted_by_smt (t:S.term) = - match (SS.compress t).n with - | Tm_constant (Const_string(s, _)) -> s = "uninterpreted_by_smt" - | _ -> false - in - match se.sigel with - | Sig_splice _ -> - failwith "impossible -- splice should have been removed by Tc.fs" - | Sig_fail _ -> - failwith "impossible -- Sig_fail should have been removed by Tc.fs" - | Sig_pragma _ - | Sig_effect_abbrev _ - | Sig_sub_effect _ - | Sig_polymonadic_bind _ - | Sig_polymonadic_subcomp _ -> [], env - - | Sig_new_effect(ed) -> - if not (is_smt_reifiable_effect env.tcenv ed.mname) - then [], env - else (* The basic idea: - 1. Encode M.bind_repr: a:Type -> b:Type -> wp_a -> wp_b -> f:st_repr a wp_a -> g:(a -> st_repr b) : st_repr b - = e - by encoding a function (erasing type arguments) - M.bind_repr (f Term) (g Term) : [[e]]] - - 2. Likewise for M.return_repr - - 3. For each action, a : x1:n -> ... -> xn:tn -> st_repr t wp = fun x1..xn -> e - encode forall x1..xn. Reify (Apply a x1 ... xn) = [[e]] - *) - let close_effect_params tm = - match ed.binders with - | [] -> tm - | _ -> S.mk (Tm_abs {bs=ed.binders; - body=tm; - rc_opt=Some (U.mk_residual_comp Const.effect_Tot_lid None [TOTAL])}) tm.pos - in - - let encode_action env (a:S.action) = - let action_defn = norm_before_encoding env (close_effect_params a.action_defn) in - let formals, _ = U.arrow_formals_comp a.action_typ in - let arity = List.length formals in - let aname, atok, env = new_term_constant_and_tok_from_lid env a.action_name arity in - let tm, decls = encode_term action_defn env in - let a_decls = - [Term.DeclFun(aname, formals |> List.map (fun _ -> Term_sort), Term_sort, Some "Action"); - Term.DeclFun(atok, [], Term_sort, Some "Action token")] - in - let _, xs_sorts, xs = - let aux ({binder_bv=bv}) (env, acc_sorts, acc) = - let xxsym, xx, env = gen_term_var env bv in - env, mk_fv (xxsym, Term_sort)::acc_sorts, xx::acc - in - List.fold_right aux formals (env, [], []) - in - (* let app = mkApp("Reify", [mkApp(aname, xs)]) in *) - let app = mkApp(aname, xs) in //arity ok; length xs = length formals = arity - let a_eq = - Util.mkAssume(mkForall (Ident.range_of_lid a.action_name) ([[app]], xs_sorts, mkEq(app, mk_Apply tm xs_sorts)), - Some "Action equality", - (aname ^"_equality")) - in - let tok_correspondence = - let tok_term = mkFreeV <| mk_fv (atok,Term_sort) in - let tok_app = mk_Apply tok_term xs_sorts in - Util.mkAssume(mkForall (Ident.range_of_lid a.action_name) ([[tok_app]], xs_sorts, mkEq(tok_app, app)), - Some "Action token correspondence", (aname ^ "_token_correspondence")) - in - env, decls@(a_decls@[a_eq; tok_correspondence] |> mk_decls_trivial) - in - - let env, decls2 = BU.fold_map encode_action env ed.actions in - List.flatten decls2, env - - | Sig_declare_typ {lid} when (lid_equals lid Const.precedes_lid) -> - //precedes is added in the prelude, see FStar.SMTEncoding.Term.fs - let tname, ttok, env = new_term_constant_and_tok_from_lid env lid 4 in - [], env - - | Sig_declare_typ {lid; us; t} -> - let quals = se.sigquals in - let will_encode_definition = not (quals |> BU.for_some (function - | Assumption | Projector _ | Discriminator _ | Irreducible -> true - | _ -> false)) in - if will_encode_definition - then [], env //nothing to do at the declaration; wait to encode the definition - else let fv = S.lid_as_fv lid None in - let decls, env = - encode_top_level_val - (se.sigattrs |> BU.for_some is_uninterpreted_by_smt) - env us fv t quals in - let tname = (string_of_lid lid) in - let tsym = Option.get (try_lookup_free_var env lid) in - decls - @ (primitive_type_axioms env.tcenv lid tname tsym |> mk_decls_trivial), - env - - | Sig_assume {lid=l; us; phi=f} -> - let uvs, f = SS.open_univ_vars us f in - let env = { env with tcenv = Env.push_univ_vars env.tcenv uvs } in - let f = norm_before_encoding env f in - let f, decls = encode_formula f env in - let g = [Util.mkAssume(f, Some (BU.format1 "Assumption: %s" (show l)), (varops.mk_unique ("assumption_"^(string_of_lid l))))] - |> mk_decls_trivial in - decls@g, env - - (* Irreducible and opaque lets. Replace the definitions by a dummy val decl (if none - exists) and re-run. *) - | Sig_let {lbs} - when se.sigquals |> List.contains S.Irreducible - || se.sigattrs |> BU.for_some is_opaque_to_smt -> - let attrs = se.sigattrs in - let env, decls = BU.fold_map (fun env lb -> - let lid = (BU.right lb.lbname).fv_name.v in - if Option.isNone <| Env.try_lookup_val_decl env.tcenv lid - then let val_decl = { se with sigel = Sig_declare_typ {lid; us=lb.lbunivs; t=lb.lbtyp}; - sigquals = S.Irreducible :: se.sigquals } in - let decls, env = encode_sigelt' env val_decl in - env, decls - else env, []) env (snd lbs) in - List.flatten decls, env - - (* Special encoding for b2t *) - | Sig_let {lbs=(_, [{lbname=Inr b2t}])} when S.fv_eq_lid b2t Const.b2t_lid -> - let tname, ttok, env = new_term_constant_and_tok_from_lid env b2t.fv_name.v 1 in - let xx = mk_fv ("x", Term_sort) in - let x = mkFreeV xx in - let b2t_x = mkApp("Prims.b2t", [x]) in - let valid_b2t_x = mkApp("Valid", [b2t_x]) in //NS: Explicitly avoid the Vaild(b2t t) inlining - let bool_ty = lookup_free_var env (withsort Const.bool_lid) in - let decls = [Term.DeclFun(tname, [Term_sort], Term_sort, None); - Util.mkAssume(mkForall (S.range_of_fv b2t) ([[b2t_x]], [xx], - mkEq(valid_b2t_x, mkApp(snd boxBoolFun, [x]))), - Some "b2t def", - "b2t_def"); - Util.mkAssume(mkForall (S.range_of_fv b2t) ([[b2t_x]], [xx], - mkImp(mk_HasType x bool_ty, - mk_HasType b2t_x mk_Term_type)), - Some "b2t typing", - "b2t_typing")] in - decls |> mk_decls_trivial, env - - (* Discriminators *) - | Sig_let _ when (se.sigquals |> BU.for_some (function Discriminator _ -> true | _ -> false)) -> - //Discriminators are encoded directly via (our encoding of) theory of datatypes - if !dbg_SMTEncoding then - BU.print1 "Not encoding discriminator '%s'\n" (Print.sigelt_to_string_short se); - [], env - - (* `unfold let` definitions in prims do not get encoded. *) - | Sig_let {lids} when (lids |> BU.for_some (fun (l:lident) -> string_of_id (List.hd (ns_of_lid l)) = "Prims") - && se.sigquals |> BU.for_some (function Unfold_for_unification_and_vcgen -> true | _ -> false)) -> - //inline lets from prims are never encoded as definitions --- since they will be inlined - if !dbg_SMTEncoding then - BU.print1 "Not encoding unfold let from Prims '%s'\n" (Print.sigelt_to_string_short se); - [], env - - (* Projectors *) - | Sig_let {lbs=(false, [lb])} - when (se.sigquals |> BU.for_some (function Projector _ -> true | _ -> false)) -> - //Projectors are also are encoded directly via (our encoding of) theory of datatypes - //Except in some cases where the front-end does not emit a declare_typ for some projector, because it doesn't know how to compute it - let fv = BU.right lb.lbname in - let l = fv.fv_name.v in - begin match try_lookup_free_var env l with - | Some _ -> - [], env //already encoded - | None -> - let se = {se with sigel = Sig_declare_typ {lid=l; us=lb.lbunivs; t=lb.lbtyp}; sigrng = Ident.range_of_lid l } in - encode_sigelt env se - end - - (* A normal let, perhaps recursive. *) - | Sig_let {lbs=(is_rec, bindings)} -> - let bindings = - List.map - (fun lb -> - let def = norm_before_encoding_us env lb.lbunivs lb.lbdef in - let typ = norm_before_encoding_us env lb.lbunivs lb.lbtyp in - {lb with lbdef=def; lbtyp=typ}) - bindings - in - encode_top_level_let env (is_rec, bindings) se.sigquals - - | Sig_bundle {ses} -> - let g, env = - ses |> - List.fold_left - (fun (g, env) se -> - let g', env = - match se.sigel with - | Sig_inductive_typ _ -> - encode_sig_inductive env se - | Sig_datacon _ -> - encode_datacon env se - | _ -> - encode_sigelt env se - in - g@g', env) - ([], env) - in - //reorder the generated decls in proper def-use order, - //i.e, declare all the function symbols first - //1. move the inversions last; they rely on all the symbols - let g', inversions = - List.fold_left - (fun (g', inversions) elt -> - let elt_g', elt_inversions = - elt.decls |> - List.partition - (function - | Term.Assume({assumption_caption=Some "inversion axiom"}) -> false - | _ -> true) - in - g' @ [ { elt with decls = elt_g' } ], - inversions @ elt_inversions) - ([], []) - g - in - //2. decls are all the function symbol declarations - // elts: all elements that have a key and which contain function declarations (not sure why this class is important to pull out) - // rest: all the non-declarations, excepting the inversion axiom which is already identified above - let decls, elts, rest = - List.fold_left - (fun (decls, elts, rest) elt -> - if BU.is_some elt.key //NS: Not sure what this case is for - && List.existsb (function | Term.DeclFun _ -> true | _ -> false) elt.decls - then decls, elts@[elt], rest - else ( //Pull the function symbol decls to the front - let elt_decls, elt_rest = - elt.decls |> - List.partition - (function - | Term.DeclFun _ -> true - | _ -> false) - in - decls @ elt_decls, elts, rest @ [ { elt with decls = elt_rest }] - )) - ([], [], []) g' - in - (decls |> mk_decls_trivial) @ elts @ rest @ (inversions |> mk_decls_trivial), env - -let encode_env_bindings (env:env_t) (bindings:list S.binding) : (decls_t & env_t) = - (* Encoding Binding_var and Binding_typ as local constants leads to breakages in hash consing. - - Consider: - - type t - type Good : nat -> Type - type s (ps:nat) = m:t{Good ps} - let f (ps':nat) (pi:(s ps' * unit)) = e - - When encoding a goal formula derived from e, ps' and pi are Binding_var in the environment. - They get encoded to constants, declare-fun ps', pi etc. - Now, when encoding the type of pi, we encode the (s ps') as a refinement type (m:t{Good ps'}). - So far so good. - But, the trouble is that since ps' is a constant, we build a formula for the refinement type that does not - close over ps'---constants are not subject to closure. - So, we get a formula that is syntactically different than what we get when encoding the type s, where (ps:nat) is - a locally bound free variable and _is_ subject to closure. - The syntactic difference leads to the hash consing lookup failing. - - So: - Instead of encoding Binding_vars as declare-funs, we can try to close the query formula over the vars in the context, - thus demoting them to free variables subject to closure. - - *) - let encode_binding b (i, decls, env) = match b with - | S.Binding_univ _ -> - i+1, decls, env - - | S.Binding_var x -> - let t1 = norm_before_encoding env x.sort in - if !dbg_SMTEncoding - then (BU.print3 "Normalized %s : %s to %s\n" (show x) (show x.sort) (show t1)); - let t, decls' = encode_term t1 env in - let t_hash = Term.hash_of_term t in - let xxsym, xx, env' = - new_term_constant_from_string env x - ("x_" ^ BU.digest_of_string t_hash ^ "_" ^ (string_of_int i)) in - let t = mk_HasTypeWithFuel None xx t in - let caption = - if Options.log_queries() - then Some (BU.format3 "%s : %s (%s)" (show x) (show x.sort) (show t1)) - else None in - let ax = - let a_name = ("binder_"^xxsym) in - Util.mkAssume(t, Some a_name, a_name) in - let g = ([Term.DeclFun(xxsym, [], Term_sort, caption)] |> mk_decls_trivial) - @decls' - @([ax] |> mk_decls_trivial) in - i+1, decls@g, env' - - | S.Binding_lid(x, (_, t)) -> - let t_norm = norm_before_encoding env t in - let fv = S.lid_as_fv x None in -// Printf.printf "Encoding %s at type %s\n" (show x) (show t); - let g, env' = encode_free_var false env fv t t_norm [] in - i+1, decls@g, env' - in - let _, decls, env = List.fold_right encode_binding bindings (0, [], env) in - decls, env - -let encode_labels (labs:list error_label) = - let prefix = labs |> List.map (fun (l, _, _) -> Term.DeclFun(fv_name l, [], Bool_sort, None)) in - let suffix = labs |> List.collect (fun (l, _, _) -> [Echo <| fv_name l; Eval (mkFreeV l)]) in - prefix, suffix - -(* caching encodings of the environment and the top-level API to the encoding *) -let last_env : ref (list env_t) = BU.mk_ref [] -let init_env tcenv = last_env := [{bvar_bindings=BU.psmap_empty (); - fvar_bindings=(BU.psmap_empty (), []); - tcenv=tcenv; warn=true; depth=0; - nolabels=false; use_zfuel_name=false; - encode_non_total_function_typ=true; encoding_quantifier=false; - current_module_name=Env.current_module tcenv |> Ident.string_of_lid; - global_cache = BU.smap_create 100}] -let get_env cmn tcenv = match !last_env with - | [] -> failwith "No env; call init first!" - | e::_ -> {e with tcenv=tcenv; current_module_name=Ident.string_of_lid cmn} -let set_env env = match !last_env with - | [] -> failwith "Empty env stack" - | _::tl -> last_env := env::tl -let get_current_env tcenv = get_env (Env.current_module tcenv) tcenv -let push_env () = match !last_env with - | [] -> failwith "Empty env stack" - | hd::tl -> - let top = copy_env hd in - last_env := top::hd::tl -let pop_env () = match !last_env with - | [] -> failwith "Popping an empty stack" - | _::tl -> last_env := tl -let snapshot_env () = FStar.Common.snapshot push_env last_env () -let rollback_env depth = FStar.Common.rollback pop_env last_env depth -(* TOP-LEVEL API *) - -let init tcenv = - init_env tcenv; - Z3.giveZ3 [DefPrelude] -let snapshot_encoding msg = BU.atomically (fun () -> - let env_depth, () = snapshot_env () in - let varops_depth, () = varops.snapshot () in - (env_depth, varops_depth)) -let rollback_encoding msg (depth:option encoding_depth) = BU.atomically (fun () -> - let env_depth, varops_depth = match depth with - | Some (s1, s2) -> Some s1, Some s2 - | None -> None, None in - rollback_env env_depth; - varops.rollback varops_depth) -let push_encoding_state msg = let _ = snapshot_encoding msg in () -let pop_encoding_state msg = rollback_encoding msg None - -////////////////////////////////////////////////////////////////////////// -//guarding top-level terms with fact database triggers -////////////////////////////////////////////////////////////////////////// -let open_fact_db_tags (env:env_t) : list fact_db_id = [] //TODO - -let place_decl_in_fact_dbs (env:env_t) (fact_db_ids:list fact_db_id) (d:decl) : decl = - match fact_db_ids, d with - | _::_, Assume a -> - Assume ({a with assumption_fact_ids=fact_db_ids}) - | _ -> d - -let place_decl_elt_in_fact_dbs (env:env_t) (fact_db_ids:list fact_db_id) (elt:decls_elt) :decls_elt = - { elt with decls = elt.decls |> List.map (place_decl_in_fact_dbs env fact_db_ids) } - -let fact_dbs_for_lid (env:env_t) (lid:Ident.lid) = - Name lid - ::Namespace (Ident.lid_of_ids (ns_of_lid lid)) - ::open_fact_db_tags env - -let encode_top_level_facts (env:env_t) (se:sigelt) = - let fact_db_ids = - U.lids_of_sigelt se |> List.collect (fact_dbs_for_lid env) - in - let g, env = encode_sigelt env se in - let g = g |> List.map (place_decl_elt_in_fact_dbs env fact_db_ids) in - g, env -////////////////////////////////////////////////////////////////////////// -//end: guarding top-level terms with fact database triggers -////////////////////////////////////////////////////////////////////////// - - -(* - * AR: Recover hashconsing of decls -- both within a module and across modules - * Using and updating env.global_cache - *) -let recover_caching_and_update_env (env:env_t) (decls:decls_t) :decls_t = - decls |> List.collect (fun elt -> - if elt.key = None then [elt] //not meant to be hashconsed, keep it - else ( - match BU.smap_try_find env.global_cache (elt.key |> BU.must) with - | Some cache_elt -> [Term.RetainAssumptions cache_elt.a_names] |> mk_decls_trivial //hit, retain a_names from the hit entry - //AND drop elt - | None -> //no hit, update cache and retain elt - BU.smap_add env.global_cache (elt.key |> BU.must) elt; - [elt] - ) - ) - -let encode_sig tcenv se = - let caption decls = - if Options.log_queries() - then Term.Caption ("encoding sigelt " ^ Print.sigelt_to_string_short se)::decls - else decls in - if Debug.medium () - then BU.print1 "+++++++++++Encoding sigelt %s\n" (show se); - let env = get_env (Env.current_module tcenv) tcenv in - let decls, env = encode_top_level_facts env se in - set_env env; - Z3.giveZ3 (caption (decls |> recover_caching_and_update_env env |> decls_list_of)) - -let give_decls_to_z3_and_set_env (env:env_t) (name:string) (decls:decls_t) :unit = - let caption decls = - if Options.log_queries() - then let msg = "Externals for " ^ name in - [Module(name, Caption msg::decls@[Caption ("End " ^ msg)])] - else [Module(name, decls)] in - set_env ({env with warn=true}); - //recover caching and flatten before giving to Z3 - let z3_decls = caption (decls |> recover_caching_and_update_env env |> decls_list_of) in - Z3.giveZ3 z3_decls - -let encode_modul tcenv modul = - if Options.lax() && Options.ml_ish() then [], [] - else begin - let tcenv = Env.set_current_module tcenv modul.name in - UF.with_uf_enabled (fun () -> - varops.reset_fresh (); - let name = BU.format2 "%s %s" (if modul.is_interface then "interface" else "module") (string_of_lid modul.name) in - if Debug.medium () - then BU.print2 "+++++++++++Encoding externals for %s ... %s declarations\n" name (List.length modul.declarations |> string_of_int); - let env = get_env modul.name tcenv |> reset_current_module_fvbs in - let encode_signature (env:env_t) (ses:sigelts) = - ses |> List.fold_left (fun (g, env) se -> - let g', env = encode_top_level_facts env se in - g@g', env) ([], env) - in - let decls, env = encode_signature ({env with warn=false}) modul.declarations in - give_decls_to_z3_and_set_env env name decls; - if Debug.medium () then BU.print1 "Done encoding externals for %s\n" name; - decls, env |> get_current_module_fvbs - ) end - -let encode_modul_from_cache tcenv tcmod (decls, fvbs) = - if Options.lax () && Options.ml_ish () then () - else - let tcenv = Env.set_current_module tcenv tcmod.name in - let name = BU.format2 "%s %s" (if tcmod.is_interface then "interface" else "module") (string_of_lid tcmod.name) in - if Debug.medium () - then BU.print2 "+++++++++++Encoding externals from cache for %s ... %s decls\n" name (List.length decls |> string_of_int); - let env = get_env tcmod.name tcenv |> reset_current_module_fvbs in - let env = - fvbs |> List.rev |> List.fold_left (fun env fvb -> - add_fvar_binding_to_env fvb env - ) env in - give_decls_to_z3_and_set_env env name decls; - if Debug.medium () then BU.print1 "Done encoding externals from cache for %s\n" name - -open FStar.SMTEncoding.Z3 -let encode_query use_env_msg (tcenv:Env.env) (q:S.term) - : list decl //prelude, translation of tcenv - & list ErrorReporting.label //labels in the query - & decl //the query itself - & list decl //suffix, evaluating labels in the model, etc. - = - Errors.with_ctx "While encoding a query" (fun () -> - Z3.query_logging.set_module_name (string_of_lid (TypeChecker.Env.current_module tcenv)); - let env = get_env (Env.current_module tcenv) tcenv in - let q, bindings = - let rec aux bindings = match bindings with - | S.Binding_var x::rest -> - let out, rest = aux rest in - let t = - match (Syntax.Formula.destruct_typ_as_formula x.sort) with - | Some _ -> - U.refine (S.new_bv None t_unit) x.sort - //add a squash to trigger the shallow embedding, - //if the assumption is of the form x:(forall y. P) etc. - | _ -> - x.sort in - let t = norm_with_steps [Env.Eager_unfolding; Env.Beta; Env.Simplify; Env.Primops; Env.EraseUniverses] env.tcenv t in - Syntax.mk_binder ({x with sort=t})::out, rest - | _ -> [], bindings in - let closing, bindings = aux tcenv.gamma in - U.close_forall_no_univs (List.rev closing) q, bindings - in - let env_decls, env = encode_env_bindings env bindings in - if Debug.medium () || !dbg_SMTEncoding || !dbg_SMTQuery - then BU.print1 "Encoding query formula {: %s\n" (show q); - let (phi, qdecls), ms = BU.record_time (fun () -> encode_formula q env) in - let labels, phi = ErrorReporting.label_goals use_env_msg (Env.get_range tcenv) phi in - let label_prefix, label_suffix = encode_labels labels in - let caption = - (* If these options are off, the Captions will be dropped anyway, - but by checking here we can skip the printing. *) - if Options.log_queries () || Options.log_failing_queries () - then [Caption ("Encoding query formula : " ^ (show q)); - Caption ("Context: " ^ String.concat "\n" (Errors.get_ctx ()))] - else [] - in - let query_prelude = - env_decls - @(label_prefix |> mk_decls_trivial) - @qdecls - @(caption |> mk_decls_trivial) |> recover_caching_and_update_env env |> decls_list_of in //recover caching and flatten - - let qry = Util.mkAssume(mkNot phi, Some "query", (varops.mk_unique "@query")) in - let suffix = [Term.Echo ""] @ label_suffix @ [Term.Echo ""; Term.Echo "Done!"] in - if Debug.medium () || !dbg_SMTEncoding || !dbg_SMTQuery - then BU.print_string "} Done encoding\n"; - if Debug.medium () || !dbg_SMTEncoding || !dbg_Time - then BU.print1 "Encoding took %sms\n" (string_of_int ms); - query_prelude, labels, qry, suffix - ) diff --git a/src/smtencoding/FStar.SMTEncoding.Encode.fsti b/src/smtencoding/FStar.SMTEncoding.Encode.fsti deleted file mode 100644 index f4cf5c76d7e..00000000000 --- a/src/smtencoding/FStar.SMTEncoding.Encode.fsti +++ /dev/null @@ -1,39 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.SMTEncoding.Encode -open FStar.Compiler.Effect -open FStar.SMTEncoding.Term -module ErrorReporting = FStar.SMTEncoding.ErrorReporting -module S = FStar.Syntax.Syntax -module Env = FStar.TypeChecker.Env -type encoding_depth = int & int -val push_encoding_state: string -> unit -val pop_encoding_state: string -> unit -val snapshot_encoding: string -> encoding_depth -val rollback_encoding: string -> option encoding_depth -> unit -val init: Env.env -> unit -val get_current_env: Env.env -> FStar.SMTEncoding.Env.env_t -val encode_sig: Env.env -> S.sigelt -> unit -val encode_modul: Env.env -> S.modul -> decls_t & list FStar.SMTEncoding.Env.fvar_binding -//the lident is the module name -val encode_modul_from_cache: Env.env -> S.modul -> (decls_t & list FStar.SMTEncoding.Env.fvar_binding) -> unit -val encode_query: option (unit -> string) - -> Env.env - -> S.term - -> list decl //prelude, translation of tcenv - & list ErrorReporting.label //labels in the query - & decl //the query itself - & list decl //suffix, evaluating labels in the model, etc \ No newline at end of file diff --git a/src/smtencoding/FStar.SMTEncoding.EncodeTerm.fst b/src/smtencoding/FStar.SMTEncoding.EncodeTerm.fst deleted file mode 100644 index 2a806efeef3..00000000000 --- a/src/smtencoding/FStar.SMTEncoding.EncodeTerm.fst +++ /dev/null @@ -1,1687 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.SMTEncoding.EncodeTerm -open Prims -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.Defensive -open FStar.TypeChecker.Env -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.TypeChecker -open FStar.SMTEncoding.Term -open FStar.Ident -open FStar.Const -open FStar.SMTEncoding -open FStar.SMTEncoding.Util -open FStar.SMTEncoding.Env - -module BU = FStar.Compiler.Util -module Const = FStar.Parser.Const -module EMB = FStar.Syntax.Embeddings -module Env = FStar.TypeChecker.Env -module N = FStar.TypeChecker.Normalize -module RC = FStar.Reflection.V2.Constants -module RE = FStar.Reflection.V2.Embeddings -module R = FStar.Reflection.V2.Builtins -module SE = FStar.Syntax.Embeddings -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module TcUtil = FStar.TypeChecker.Util -module U = FStar.Syntax.Util - -open FStar.Class.Show -open FStar.Class.Tagged -open FStar.Class.Setlike - -let dbg_PartialApp = Debug.get_toggle "PartialApp" -let dbg_SMTEncoding = Debug.get_toggle "SMTEncoding" -let dbg_SMTEncodingReify = Debug.get_toggle "SMTEncodingReify" - -(*---------------------------------------------------------------------------------*) -(* *) - -let mkForall_fuel' mname r n (pats, vars, body) = - let fallback () = mkForall r (pats, vars, body) in - if (Options.unthrottle_inductives()) - then fallback () - else let fsym, fterm = fresh_fvar mname "f" Fuel_sort in - let add_fuel tms = - tms |> List.map (fun p -> match p.tm with - | Term.App(Var "HasType", args) -> mkApp("HasTypeFuel", fterm::args) - | _ -> p) in - let pats = List.map add_fuel pats in - let body = match body.tm with - | Term.App(Imp, [guard; body']) -> - let guard = match guard.tm with - | App(And, guards) -> mk_and_l (add_fuel guards) - | _ -> add_fuel [guard] |> List.hd in - mkImp(guard,body') - | _ -> body in - let vars = mk_fv (fsym, Fuel_sort)::vars in - mkForall r (pats, vars, body) - -let mkForall_fuel mname r = mkForall_fuel' mname r 1 - -let head_normal env t = - let t = U.unmeta t in - match t.n with - | Tm_arrow _ - | Tm_refine _ - | Tm_bvar _ - | Tm_uvar _ - | Tm_abs _ - | Tm_constant _ -> true - | Tm_fvar fv - | Tm_app {hd={n=Tm_fvar fv}} -> Env.lookup_definition [Env.Eager_unfolding_only] env.tcenv fv.fv_name.v |> Option.isNone - | _ -> false - -let head_redex env t = - match (U.un_uinst t).n with - | Tm_abs {rc_opt=Some rc} -> - Ident.lid_equals rc.residual_effect Const.effect_Tot_lid - || Ident.lid_equals rc.residual_effect Const.effect_GTot_lid - || List.existsb (function TOTAL -> true | _ -> false) rc.residual_flags - - | Tm_fvar fv -> - Env.lookup_definition [Env.Eager_unfolding_only] env.tcenv fv.fv_name.v |> Option.isSome - - | _ -> false - -let norm_with_steps steps env t = - Profiling.profile - (fun () -> N.normalize steps env t) - (Some (Ident.string_of_lid (Env.current_module env))) - "FStar.SMTEncoding.EncodeTerm.norm_with_steps" - -let normalize_refinement steps env t = - Profiling.profile - (fun () -> N.normalize_refinement steps env t) - (Some (Ident.string_of_lid (Env.current_module env))) - "FStar.SMTEncoding.EncodeTerm.normalize_refinement" - -let whnf env t = - if head_normal env t then t - else norm_with_steps [Env.Beta; Env.Weak; Env.HNF; Env.Exclude Env.Zeta; //we don't know if it will terminate, so no recursion - Env.Eager_unfolding; Env.EraseUniverses] env.tcenv t -let norm env t = norm_with_steps [Env.Beta; Env.Exclude Env.Zeta; //we don't know if it will terminate, so no recursion - Env.Eager_unfolding; Env.EraseUniverses] env.tcenv t - -(* `maybe_whnf env t` attempts to reduce t to weak-head normal form. - * It is called when `t` is a head redex, e.g., if its head symbol is marked for unfolding. - * However, if its head symbol is also marked as `strict_on_arguments`, then if it is applied - * to non-constant arguments, then it may actually not be unfolded. - * In those cases `maybe_whnf env t` may not reduce `t` at all. - * In callers of this code, we need to be careful to check that if `t` was not reduced, then - * we do not enter into infinite loops by recursing on `t` itself. - *) - -let maybe_whnf env t = - let t' = whnf env t in - let head', _ = U.head_and_args t' in - if head_redex env head' //this wasn't reducible for some reason, e.g., not applied to strict arguments - then None - else Some t' - -let trivial_post t : Syntax.term = - U.abs [null_binder t] - (Syntax.fvar Const.true_lid None) - None - -let mk_Apply e (vars:fvs) = - vars |> List.fold_left (fun out var -> - match fv_sort var with - | Fuel_sort -> mk_ApplyTF out (mkFreeV var) - | s -> - // let _ = if s <> Term_sort then (printfn "Expected Term_sort; got %A" s; failwith "DIE!") in - mk_ApplyTT out (mkFreeV var)) e -let mk_Apply_args e args = args |> List.fold_left mk_ApplyTT e -let raise_arity_mismatch head arity n_args rng = - Errors.raise_error rng Errors.Fatal_SMTEncodingArityMismatch - (BU.format3 "Head symbol %s expects at least %s arguments; got only %s" - head - (show arity) - (show n_args)) - -//See issue #1750 and tests/bug-reports/Bug1750.fst -let isTotFun_axioms pos head vars guards is_pure = - let maybe_mkForall pat vars body = - match vars with - | [] -> body - | _ -> mkForall pos (pat, vars, body) - in - let rec is_tot_fun_axioms ctx ctx_guard head vars guards = - match vars, guards with - | [], [] -> - mkTrue - - | [_], _ -> - //last arrow, the effect label tells us if its pure or not - if is_pure - then maybe_mkForall [[head]] ctx (mkImp (ctx_guard, mk_IsTotFun head)) - else mkTrue - - | x::vars, g_x::guards -> - //curried arrow with more than 1 argument - //head is definitely Tot - let is_tot_fun_head = - maybe_mkForall [[head]] ctx (mkImp (ctx_guard, mk_IsTotFun head)) - in - let app = mk_Apply head [x] in - let ctx = ctx @ [x] in - let ctx_guard = mkAnd (ctx_guard, g_x) in - let rest = is_tot_fun_axioms ctx ctx_guard app vars guards in - mkAnd (is_tot_fun_head, rest) - - | _ -> - failwith "impossible: isTotFun_axioms" - in - is_tot_fun_axioms [] mkTrue head vars guards - -let maybe_curry_app rng (head:either op term) (arity:int) (args:list term) : term = - let n_args = List.length args in - match head with - | Inr head -> //must curry - mk_Apply_args head args - - | Inl head -> - if n_args = arity - then Util.mkApp'(head, args) - else if n_args > arity - then let args, rest = BU.first_N arity args in - let head = Util.mkApp'(head, args) in - mk_Apply_args head rest - else raise_arity_mismatch (Term.op_to_string head) arity n_args rng - -let maybe_curry_fvb rng fvb args = - if fvb.fvb_thunked - then mk_Apply_args (force_thunk fvb) args - else maybe_curry_app rng (Inl (Var fvb.smt_id)) fvb.smt_arity args - -let is_app = function - | Var "ApplyTT" - | Var "ApplyTF" -> true - | _ -> false - -let check_pattern_vars env vars pats = - let pats = - pats |> List.map (fun (x, _) -> - norm_with_steps [Env.Beta;Env.AllowUnboundUniverses;Env.EraseUniverses] env.tcenv x) - in - match pats with - | [] -> () - | hd::tl -> - let pat_vars = List.fold_left (fun out x -> union out (Free.names x)) (Free.names hd) tl in - match vars |> BU.find_opt (fun ({binder_bv=b}) -> not (mem b pat_vars)) with - | None -> () - | Some ({binder_bv=x}) -> - let pos = List.fold_left (fun out t -> Range.union_ranges out t.pos) hd.pos tl in - Errors.log_issue pos Errors.Warning_SMTPatternIllFormed - (BU.format1 "SMT pattern misses at least one bound variable: %s" (show x)) - -(* *) - -(**********************************************************************************) -(* The main encoding of terms and formulae: mutually recursive *) -(* see fstar-priv/papers/mm/encoding.txt for a semi-formal sketch of the encoding *) -(**********************************************************************************) - -(* Abstractly: - - ctx = (bvvdef -> term(Term_sort)) - ex = set (var x term(Bool)) existentially bound variables - [[e]] : ctx -> term(Term_sort) * ex - [[f]] : ctx -> term(Bool) - [[bs]] : ctx -> (vars - * term(Bool) <-- guard on bound vars - * ctx) <-- context extended with bound vars - - Concretely, [[*]] are the encode_* functions, for exp, formula, binders - ctx is implemented using env_t - and term( * ) is just term - *) - -type label = (fv & string & Range.range) -type labels = list label -type pattern = { - pat_vars: list (bv & fv); - pat_term: unit -> (term & decls_t); (* the pattern as a term(exp) *) - guard: term -> term; (* the guard condition of the pattern, as applied to a particular scrutinee term(exp) *) - projections: term -> list (bv & term) (* bound variables of the pattern, and the corresponding projected components of the scrutinee *) - } - -let as_function_typ env t0 = - let rec aux norm t = - let t = SS.compress t in - match t.n with - | Tm_arrow _ -> t - | Tm_refine _ -> aux true (U.unrefine t) - | _ -> if norm - then aux false (whnf env t) - else failwith (BU.format2 "(%s) Expected a function typ; got %s" (Range.string_of_range t0.pos) (show t0)) - in aux true t0 - -let rec curried_arrow_formals_comp k = - let k = Subst.compress k in - match k.n with - | Tm_arrow {bs; comp=c} -> Subst.open_comp bs c - | Tm_refine {b=bv} -> - let args, res = curried_arrow_formals_comp bv.sort in - begin - match args with - | [] -> [], Syntax.mk_Total k - | _ -> args, res - end - | _ -> [], Syntax.mk_Total k - -let is_arithmetic_primitive head args = - match head.n, args with - | Tm_fvar fv, [_;_]-> - S.fv_eq_lid fv Const.op_Addition - || S.fv_eq_lid fv Const.op_Subtraction - || S.fv_eq_lid fv Const.op_Multiply - || S.fv_eq_lid fv Const.op_Division - || S.fv_eq_lid fv Const.op_Modulus - || S.fv_eq_lid fv Const.real_op_LT - || S.fv_eq_lid fv Const.real_op_LTE - || S.fv_eq_lid fv Const.real_op_GT - || S.fv_eq_lid fv Const.real_op_GTE - || S.fv_eq_lid fv Const.real_op_Addition - || S.fv_eq_lid fv Const.real_op_Subtraction - || S.fv_eq_lid fv Const.real_op_Multiply - || S.fv_eq_lid fv Const.real_op_Division - - | Tm_fvar fv, [_] -> - S.fv_eq_lid fv Const.op_Minus - - | _ -> false - -let isInteger (tm: Syntax.term') : bool = - match tm with - | Tm_constant (Const_int (n,None)) -> true - | _ -> false - -let getInteger (tm : Syntax.term') = - match tm with - | Tm_constant (Const_int (n,None)) -> FStar.Compiler.Util.int_of_string n - | _ -> failwith "Expected an Integer term" - -(* We only want to encode a term as a bitvector term (not an uninterpreted function) - if there is a concrete/constant size argument given*) -let is_BitVector_primitive head args = - match head.n, args with - | Tm_fvar fv, [(sz_arg, _);_;_] -> - (S.fv_eq_lid fv Const.bv_and_lid - || S.fv_eq_lid fv Const.bv_xor_lid - || S.fv_eq_lid fv Const.bv_or_lid - || S.fv_eq_lid fv Const.bv_add_lid - || S.fv_eq_lid fv Const.bv_sub_lid - || S.fv_eq_lid fv Const.bv_shift_left_lid - || S.fv_eq_lid fv Const.bv_shift_right_lid - || S.fv_eq_lid fv Const.bv_udiv_lid - || S.fv_eq_lid fv Const.bv_mod_lid - || S.fv_eq_lid fv Const.bv_mul_lid - || S.fv_eq_lid fv Const.bv_shift_left'_lid - || S.fv_eq_lid fv Const.bv_shift_right'_lid - || S.fv_eq_lid fv Const.bv_udiv_unsafe_lid - || S.fv_eq_lid fv Const.bv_mod_unsafe_lid - || S.fv_eq_lid fv Const.bv_mul'_lid - || S.fv_eq_lid fv Const.bv_ult_lid - || S.fv_eq_lid fv Const.bv_uext_lid) && - (isInteger sz_arg.n) - | Tm_fvar fv, [(sz_arg, _); _] -> - (S.fv_eq_lid fv Const.nat_to_bv_lid - || S.fv_eq_lid fv Const.bv_to_nat_lid) && - (isInteger sz_arg.n) - - | _ -> false - -let rec encode_const c env = - Errors.with_ctx "While encoding a constant to SMT" (fun () -> - match c with - | Const_unit -> mk_Term_unit, [] - | Const_bool true -> boxBool mkTrue, [] - | Const_bool false -> boxBool mkFalse, [] - | Const_char c -> mkApp("FStar.Char.__char_of_int", [boxInt (mkInteger' (BU.int_of_char c))]), [] - | Const_int (i, None) -> boxInt (mkInteger i), [] - | Const_int (repr, Some sw) -> - let syntax_term = FStar.ToSyntax.ToSyntax.desugar_machine_integer env.tcenv.dsenv repr sw Range.dummyRange in - encode_term syntax_term env - | Const_string(s, _) -> Term.boxString <| mk_String_const s, [] - | Const_range _ -> mk_Range_const (), [] - | Const_effect -> mk_Term_type, [] - | Const_real r -> boxReal (mkReal r), [] - | c -> failwith (BU.format1 "Unhandled constant: %s" (show c)) - ) -and encode_binders (fuel_opt:option term) (bs:Syntax.binders) (env:env_t) : - (list fv (* translated bound variables *) - & list term (* guards *) - & env_t (* extended context *) - & decls_t (* top-level decls to be emitted *) - & list bv) (* names *) = - - if Debug.medium () then BU.print1 "Encoding binders %s\n" (show bs); - - let vars, guards, env, decls, names = - bs |> List.fold_left - (fun (vars, guards, env, decls, names) b -> - let v, g, env, decls', n = - let x = b.binder_bv in - let xxsym, xx, env' = gen_term_var env x in - let guard_x_t, decls' = - encode_term_pred fuel_opt (norm env x.sort) env xx - in //if we had polarities, we could generate a mkHasTypeZ here in the negative case - mk_fv (xxsym, Term_sort), - guard_x_t, - env', - decls', - x - in - v::vars, g::guards, env, decls@decls', n::names) - ([], [], env, [], []) - in - List.rev vars, - List.rev guards, - env, - decls, - List.rev names - -and encode_term_pred (fuel_opt:option term) (t:typ) (env:env_t) (e:term) : term & decls_t = - let t, decls = encode_term t env in - mk_HasTypeWithFuel fuel_opt e t, decls - -and encode_arith_term env head args_e = - let arg_tms, decls = encode_args args_e env in - let head_fv = - match head.n with - | Tm_fvar fv -> fv - | _ -> failwith "Impossible" - in - let unary unbox arg_tms = - unbox (List.hd arg_tms) - in - let binary unbox arg_tms = - unbox (List.hd arg_tms), - unbox (List.hd (List.tl arg_tms)) - in - let mk_default () = - let fname, fuel_args, arity = lookup_free_var_sym env head_fv.fv_name in - let args = fuel_args@arg_tms in - maybe_curry_app head.pos fname arity args - in - let mk_l : (term -> term) -> ('a -> term) -> (list term -> 'a) -> list term -> term = - fun box op mk_args ts -> - if Options.smtencoding_l_arith_native () then - op (mk_args ts) |> box - else mk_default () - in - let mk_nl box unbox nm op ts = - if Options.smtencoding_nl_arith_wrapped () then - let t1, t2 = binary unbox ts in - Util.mkApp(nm, [t1;t2]) |> box - else if Options.smtencoding_nl_arith_native () then - op (binary unbox ts) |> box - else mk_default () - in - let add box unbox = mk_l box Util.mkAdd (binary unbox) in - let sub box unbox = mk_l box Util.mkSub (binary unbox) in - let minus box unbox = mk_l box Util.mkMinus (unary unbox) in - let mul box unbox nm = mk_nl box unbox nm Util.mkMul in - let div box unbox nm = mk_nl box unbox nm Util.mkDiv in - let modulus box unbox = mk_nl box unbox "_mod" Util.mkMod in - let ops = - [(Const.op_Addition, add Term.boxInt Term.unboxInt); - (Const.op_Subtraction, sub Term.boxInt Term.unboxInt); - (Const.op_Multiply, mul Term.boxInt Term.unboxInt "_mul"); - (Const.op_Division, div Term.boxInt Term.unboxInt "_div"); - (Const.op_Modulus, modulus Term.boxInt Term.unboxInt); - (Const.op_Minus, minus Term.boxInt Term.unboxInt); - (Const.real_op_Addition, add Term.boxReal Term.unboxReal); - (Const.real_op_Subtraction, sub Term.boxReal Term.unboxReal); - (Const.real_op_Multiply, mul Term.boxReal Term.unboxReal "_rmul"); - (Const.real_op_Division, mk_nl Term.boxReal Term.unboxReal "_rdiv" Util.mkRealDiv); - (Const.real_op_LT, mk_l Term.boxBool Util.mkLT (binary Term.unboxReal)); - (Const.real_op_LTE, mk_l Term.boxBool Util.mkLTE (binary Term.unboxReal)); - (Const.real_op_GT, mk_l Term.boxBool Util.mkGT (binary Term.unboxReal)); - (Const.real_op_GTE, mk_l Term.boxBool Util.mkGTE (binary Term.unboxReal))] - in - let _, op = - List.tryFind (fun (l, _) -> S.fv_eq_lid head_fv l) ops |> - BU.must - in - op arg_tms, decls - - and encode_BitVector_term env head args_e = - (*first argument should be the implicit vector size - we do not want to encode this*) - let (tm_sz, _) : arg = List.hd args_e in - let sz = getInteger tm_sz.n in - let sz_key = FStar.Compiler.Util.format1 "BitVector_%s" (string_of_int sz) in - let sz_decls = - let t_decls, constr_name, discriminator_name = mkBvConstructor sz in - //Typing inversion for bv_t n - let decls, typing_inversion = - (* forall (x:Term). HasType x (bv_t n) ==> is-BoxVec#n x *) - let bv_t_n, decls = - let head = S.lid_as_fv FStar.Parser.Const.bv_t_lid None in - let t = U.mk_app (S.fv_to_tm head) [tm_sz, None] in - encode_term t env - in - let xsym = mk_fv (varops.fresh env.current_module_name "x", Term_sort) in - let x = mkFreeV xsym in - let x_has_type_bv_t_n = mk_HasType x bv_t_n in - let ax = mkForall head.pos ([[x_has_type_bv_t_n]], - [xsym], - mkImp(x_has_type_bv_t_n, mkApp (discriminator_name, [x]))) in - let name = "typing_inversion_for_" ^constr_name in - decls, mkAssume(ax, Some name, name) - in - decls@mk_decls "" sz_key (t_decls@[typing_inversion]) [] - in - (* we need to treat the size argument for zero_extend specially*) - let arg_tms, ext_sz = - match head.n, args_e with - | Tm_fvar fv, [_;(sz_arg, _);_] when - (S.fv_eq_lid fv Const.bv_uext_lid && - (isInteger sz_arg.n)) -> - (List.tail (List.tail args_e), Some (getInteger sz_arg.n)) - | Tm_fvar fv, [_;(sz_arg, _);_] when - (S.fv_eq_lid fv Const.bv_uext_lid) -> - (*fail if extension size is not a constant*) - failwith (FStar.Compiler.Util.format1 "Not a constant bitvector extend size: %s" - (show sz_arg)) - | _ -> (List.tail args_e, None) - in - - let arg_tms, decls = encode_args arg_tms env in - let head_fv = - match head.n with - | Tm_fvar fv -> fv - | _ -> failwith "Impossible" - in - let unary arg_tms = - Term.unboxBitVec sz (List.hd arg_tms) - in - let unary_arith arg_tms = - Term.unboxInt (List.hd arg_tms) - in - let binary arg_tms = - Term.unboxBitVec sz (List.hd arg_tms), - Term.unboxBitVec sz (List.hd (List.tl arg_tms)) - in - let binary_arith arg_tms = - Term.unboxBitVec sz (List.hd arg_tms), - Term.unboxInt (List.hd (List.tl arg_tms)) - in - let mk_bv : ('a -> term) -> (list term -> 'a) -> (term -> term) -> list term -> term = - fun op mk_args resBox ts -> - op (mk_args ts) |> resBox - in - let bv_and = mk_bv Util.mkBvAnd binary (Term.boxBitVec sz) in - let bv_xor = mk_bv Util.mkBvXor binary (Term.boxBitVec sz) in - let bv_or = mk_bv Util.mkBvOr binary (Term.boxBitVec sz) in - let bv_add = mk_bv Util.mkBvAdd binary (Term.boxBitVec sz) in - let bv_sub = mk_bv Util.mkBvSub binary (Term.boxBitVec sz) in - let bv_shl = mk_bv (Util.mkBvShl sz) binary_arith (Term.boxBitVec sz) in - let bv_shr = mk_bv (Util.mkBvShr sz) binary_arith (Term.boxBitVec sz) in - let bv_udiv = mk_bv (Util.mkBvUdiv sz) binary_arith (Term.boxBitVec sz) in - let bv_mod = mk_bv (Util.mkBvMod sz) binary_arith (Term.boxBitVec sz) in - let bv_mul = mk_bv (Util.mkBvMul sz) binary_arith (Term.boxBitVec sz) in - - // Binary bv_t -> bv_t -> bv_t variants - let bv_shl' = mk_bv (Util.mkBvShl' sz) binary (Term.boxBitVec sz) in - let bv_shr' = mk_bv (Util.mkBvShr' sz) binary (Term.boxBitVec sz) in - let bv_udiv_unsafe = mk_bv (Util.mkBvUdivUnsafe sz) binary (Term.boxBitVec sz) in - let bv_mod_unsafe = mk_bv (Util.mkBvModUnsafe sz) binary (Term.boxBitVec sz) in - let bv_mul' = mk_bv (Util.mkBvMul' sz) binary (Term.boxBitVec sz) in - - let bv_ult = mk_bv Util.mkBvUlt binary Term.boxBool in - let bv_uext arg_tms = - mk_bv (Util.mkBvUext (match ext_sz with | Some x -> x | None -> failwith "impossible")) unary - (Term.boxBitVec (sz + (match ext_sz with | Some x -> x | None -> failwith "impossible"))) arg_tms in - let to_int = mk_bv Util.mkBvToNat unary Term.boxInt in - let bv_to = mk_bv (Util.mkNatToBv sz) unary_arith (Term.boxBitVec sz) in - let ops = - [(Const.bv_and_lid, bv_and); - (Const.bv_xor_lid, bv_xor); - (Const.bv_or_lid, bv_or); - (Const.bv_add_lid, bv_add); - (Const.bv_sub_lid, bv_sub); - (Const.bv_shift_left_lid, bv_shl); - (Const.bv_shift_right_lid, bv_shr); - (Const.bv_udiv_lid, bv_udiv); - (Const.bv_mod_lid, bv_mod); - (Const.bv_mul_lid, bv_mul); - (Const.bv_shift_left'_lid, bv_shl'); - (Const.bv_shift_right'_lid, bv_shr'); - (Const.bv_udiv_unsafe_lid, bv_udiv_unsafe); - (Const.bv_mod_unsafe_lid, bv_mod_unsafe); - (Const.bv_mul'_lid, bv_mul'); - (Const.bv_ult_lid, bv_ult); - (Const.bv_uext_lid, bv_uext); - (Const.bv_to_nat_lid, to_int); - (Const.nat_to_bv_lid, bv_to)] - in - let _, op = - List.tryFind (fun (l, _) -> S.fv_eq_lid head_fv l) ops |> - BU.must - in - op arg_tms, sz_decls @ decls - -and encode_deeply_embedded_quantifier (t:S.term) (env:env_t) : term & decls_t = - let env = {env with encoding_quantifier=true} in - let tm, decls = encode_term t env in - let vars = Term.free_variables tm in - let valid_tm = mk_Valid tm in - let key = mkForall t.pos ([], vars, valid_tm) in - let tkey_hash = hash_of_term key in - match tm.tm with - | App(_, [{tm=FreeV _}; {tm=FreeV _}]) -> - FStar.Errors.log_issue t Errors.Warning_QuantifierWithoutPattern - "Not encoding deeply embedded, unguarded quantifier to SMT"; - tm, decls - - | _ -> - let phi, decls' = encode_formula t env in - let interp = - match vars with - | [] -> mkIff(mk_Valid tm, phi) - | _ -> mkForall t.pos ([[valid_tm]], vars, mkIff(mk_Valid tm, phi)) - in - let ax = mkAssume(interp, - Some "Interpretation of deeply embedded quantifier", - "l_quant_interp_" ^ (BU.digest_of_string tkey_hash)) in - tm, decls@decls'@(mk_decls "" tkey_hash [ax] (decls@decls')) - -(* - * AR: no hashconsing in this function now - * it returns a list of decls blocks that may be duplicate - * for example, for two occurrences of x:int{x > 2} - * deduplication of these happens in Encode.fs - * just before giving the decls to Z3 (see Encode.fs.recover_caching_and_update_env) - *) -and encode_term (t:typ) (env:env_t) : (term (* encoding of t, expects t to be in normal form already *) - & decls_t) (* top-level declarations to be emitted (for shared representations of existentially bound terms *) = - - def_check_scoped t.pos "encode_term" env.tcenv t; - let t = SS.compress t in - let t0 = t in - if !dbg_SMTEncoding - then BU.print2 "(%s) %s\n" (tag_of t) (show t); - match t.n with - | Tm_delayed _ - | Tm_unknown -> - failwith (BU.format3 "(%s) Impossible: %s\n%s\n" - (Range.string_of_range <| t.pos) - (tag_of t) - (show t)) - - | Tm_lazy i -> - let e = U.unfold_lazy i in - if !dbg_SMTEncoding then - BU.print2 ">> Unfolded (%s) ~> (%s)\n" (show t) - (show e); - encode_term e env - - | Tm_bvar x -> - failwith (BU.format1 "Impossible: locally nameless; got %s" (show x)) - - | Tm_ascribed {tm=t; asc=(k,_,_)} -> - if (match k with Inl t -> U.is_unit t | _ -> false) - then Term.mk_Term_unit, [] - else encode_term t env - - | Tm_quoted (qt, _) -> - // Inspect the term and encode its view, recursively. - // Quoted terms are, in a way, simply an optimization. - // They should be equivalent to a fully spelled out view. - // - // Actual encoding: `q ~> pack qv where qv is the view of q - let tv = EMB.embed (R.inspect_ln qt) t.pos None EMB.id_norm_cb in - if !dbg_SMTEncoding then - BU.print2 ">> Inspected (%s) ~> (%s)\n" (show t0) - (show tv); - let t = U.mk_app (RC.refl_constant_term RC.fstar_refl_pack_ln) [S.as_arg tv] in - encode_term t env - - | Tm_meta {tm=t; meta=Meta_pattern _} -> - encode_term t ({env with encoding_quantifier=false}) - - | Tm_meta {tm=t} -> - encode_term t env - - | Tm_name x -> - let t = lookup_term_var env x in - t, [] - - | Tm_fvar v -> - let encode_freev () = - let fvb = lookup_free_var_name env v.fv_name in - let tok = lookup_free_var env v.fv_name in - let tkey_hash = Term.hash_of_term tok in - let aux_decls, sym_name = - if fvb.smt_arity > 0 - then //kick partial application axioms if arity > 0; see #613 - //and if the head symbol is just a variable - //rather than maybe a fuel-instrumented name (cf. #1433) - match tok.tm with - | FreeV _ - | App(_, []) -> - let sym_name = "@kick_partial_app_" ^ (BU.digest_of_string tkey_hash) in //the '@' retains this for hints - [Util.mkAssume(kick_partial_app tok, - Some "kick_partial_app", - sym_name)], sym_name - | _ -> [], "" - else [], "" in - tok, (if aux_decls = [] - then ([] |> mk_decls_trivial) - else mk_decls sym_name tkey_hash aux_decls []) - in - if head_redex env t - then match maybe_whnf env t with - | None -> encode_freev() - | Some t -> encode_term t env - else encode_freev () - - | Tm_type _ -> - mk_Term_type, [] - - | Tm_uinst(t, _) -> - encode_term t env - - | Tm_constant c -> - encode_const c env - - | Tm_arrow {bs=binders; comp=c} -> - let module_name = env.current_module_name in - let binders, res = SS.open_comp binders c in - if (env.encode_non_total_function_typ - && U.is_pure_or_ghost_comp res) - || U.is_tot_or_gtot_comp res - then let vars, guards_l, env', decls, _ = encode_binders None binders env in - let fsym = mk_fv (varops.fresh module_name "f", Term_sort) in - let f = mkFreeV fsym in - let app = mk_Apply f vars in - let tcenv_bs = { env'.tcenv with admit=true } in - let pre_opt, res_t = TcUtil.pure_or_ghost_pre_and_post tcenv_bs res in - let res_pred, decls' = encode_term_pred None res_t env' app in - let guards, guard_decls = match pre_opt with - | None -> mk_and_l guards_l, [] - | Some pre -> - let guard, decls0 = encode_formula pre env' in - mk_and_l (guard::guards_l), decls0 in - //AR: promote ghost to pure for non-informative types - let is_pure = res |> N.maybe_ghost_to_pure env.tcenv |> U.is_pure_comp in - //cf. Bug #1750 - //We need to distinguish pure and ghost functions in the encoding - //both in hash consing, producing different type constructors for them. - //Tot functions get an additional predicate IsTotFun in their interpretation - let t_interp = - mkForall t.pos - ([[app]], - vars, - mkImp(guards, res_pred)) - in - - (* - * AR/NS: For an arrow like int -> int -> int -> GTot int, t_interp is of the form: - * forall x0. - * HasType x0 (int -> int -> int -> GTot int) - * <==> - * (forall (x1:int) (x2:int) (x3:int). - * HasType (ApplyTT (ApplyTT (ApplyTT (x0 x1)) x2) x3) int) - * /\ IsTotFun x0 - * /\ (forall x1. IsTotFun (ApplyTT x0 x1) - * - * I.e, we add IsTotFun axioms for every total partial application. - * Importantly, in the example above, the axiom is omitted for - * (x0 x1 x2 : int -> GTot int), since this function is not total - *) - - - //finally add the IsTotFun for the function term itself - let t_interp = - let tot_fun_axioms = isTotFun_axioms t.pos f vars guards_l is_pure in - mkAnd (t_interp, tot_fun_axioms) - in - let cvars = - Term.free_variables t_interp - |> List.filter (fun x -> fv_name x <> fv_name fsym) - in - let tkey = - mkForall t.pos ([], fsym::cvars, t_interp) - in - let prefix = - if is_pure - then "Tm_arrow_" - else "Tm_ghost_arrow_" - in - let tkey_hash = - prefix ^ hash_of_term tkey in - let tsym = - prefix ^ BU.digest_of_string tkey_hash - in - let cvar_sorts = List.map fv_sort cvars in - let caption = - if Options.log_queries() - then Some (BU.replace_char (N.term_to_string env.tcenv t0) '\n' ' ') - else None in - - let tdecl = Term.DeclFun(tsym, cvar_sorts, Term_sort, caption) in - - let t = mkApp(tsym, List.map mkFreeV cvars) in //arity ok - let t_has_kind = mk_HasType t mk_Term_type in - - let k_assumption = - let a_name = "kinding_"^tsym in - Util.mkAssume (mkForall t0.pos ([[t_has_kind]], cvars, t_has_kind), Some a_name, a_name) in - - let f_has_t = mk_HasType f t in - let f_has_t_z = mk_HasTypeZ f t in - let pre_typing = - let a_name = "pre_typing_"^tsym in - Util.mkAssume(mkForall_fuel module_name t0.pos ([[f_has_t]], fsym::cvars, - mkImp(f_has_t, mk_tester "Tm_arrow" (mk_PreType f))), - Some "pre-typing for functions", - module_name ^ "_" ^ a_name) in - let t_interp = - let a_name = "interpretation_"^tsym in - Util.mkAssume(mkForall t0.pos ([[f_has_t_z]], - fsym::cvars, - mkIff (f_has_t_z, t_interp)), - Some a_name, - module_name ^ "_" ^ a_name) - in - let t_decls = [tdecl; k_assumption; pre_typing; t_interp] in - t, decls@decls'@guard_decls@(mk_decls tsym tkey_hash t_decls (decls@decls'@guard_decls)) - - else - (* - * AR: compute a hash for the Non total arrow, - * that we will use in the name of the arrow - * so that we can get some hashconsing - *) - let tkey_hash = - (* - * AR: any decls computed here are ignored - * we encode terms in this let-scope just to compute a hash - *) - let vars, guards_l, env_bs, _, _ = encode_binders None binders env in - let c = Env.unfold_effect_abbrev (Env.push_binders env.tcenv binders) res |> S.mk_Comp in - let ct, _ = encode_term (c |> U.comp_result) env_bs in - let effect_args, _ = encode_args (c |> U.comp_effect_args) env_bs in - let tkey = mkForall t.pos - ([], vars, mk_and_l (guards_l@[ct]@effect_args)) in - let tkey_hash = "Non_total_Tm_arrow" ^ (hash_of_term tkey) ^ "@Effect=" ^ - (c |> U.comp_effect_name |> string_of_lid) in - BU.digest_of_string tkey_hash - in - - let tsym = "Non_total_Tm_arrow_" ^ tkey_hash in - (* We need to compute all free variables of this arrow - expression and parametrize the encoding wrt to them. See - issue #3028 *) - let env0 = env in - let fstar_fvs, (env, fv_decls, fv_vars, fv_tms, fv_guards) = - let fvs = Free.names t0 |> elems in - - let getfreeV (t:term) : fv = - match t.tm with - | FreeV fv -> fv - | _ -> failwith "Impossible: getfreeV: gen_term_var should always returns a FreeV" - in - - fvs, - List.fold_left (fun (env, decls, vars, tms, guards) bv -> - (* Get the sort from the environment, do not trust .sort field *) - let (sort, _) = Env.lookup_bv env.tcenv bv in - (* Generate a fresh SMT variable for this bv *) - let sym, smt_tm, env = gen_term_var env bv in - let fv = getfreeV smt_tm in - (* Generate typing predicate for it at the sort type *) - let guard, decls' = encode_term_pred None (norm env sort) env smt_tm in - (env, decls'@decls, fv::vars, smt_tm::tms, guard::guards) - ) (env, [], [], [], []) fvs - in - (* Putting in "correct" order... but does it matter? *) - let fv_decls = List.rev fv_decls in - let fv_vars = List.rev fv_vars in - let fv_tms = List.rev fv_tms in - let fv_guards = List.rev fv_guards in - - let arg_sorts = List.map (fun _ -> Term_sort) fv_tms in - let tdecl = Term.DeclFun(tsym, arg_sorts, Term_sort, None) in - let tapp = mkApp(tsym, fv_tms) in - let t_kinding = - let a_name = "non_total_function_typing_" ^tsym in - let axiom = - (* We generate: - forall v1 .. vn, (v1 hasType t1 /\ ... vn hasType tn) ==> tapp hasType Type *) - (* NB: we use the conlusion (HasType tapp Type) as the pattern. Though Z3 - will probably pick the same one if left empty. *) - mkForall t0.pos ([[mk_HasType tapp mk_Term_type]], fv_vars, - mkImp (mk_and_l fv_guards, mk_HasType tapp mk_Term_type)) - in - (* We furthermore must close over any variable that is - still free in the axiom. This can happen since the types - of the fvs we are closing over above may not be closed - in the current env. *) - let svars = Term.free_variables axiom in - let axiom = mkForall t0.pos ([], svars, axiom) in - Util.mkAssume (axiom, Some "Typing for non-total arrows", a_name) - in - - (* The axiom above is generated over a universal quantification of - the free variables, but the actual encoding of this instance of the - arrow is applied to (the encoding of) the actual free variables at - this point. *) - - let tapp_concrete = mkApp(tsym, List.map (lookup_term_var env0) fstar_fvs) in - tapp_concrete, fv_decls @ mk_decls tsym tkey_hash [tdecl ; t_kinding ] [] - - | Tm_refine _ -> - let x, f = - let steps = [ - Env.Weak; - Env.HNF; - Env.EraseUniverses - ] in - match normalize_refinement steps env.tcenv t0 with - | {n=Tm_refine {b=x; phi=f}} -> - let b, f = SS.open_term [S.mk_binder x] f in - (List.hd b).binder_bv, f - | _ -> failwith "impossible" - in - - let base_t, decls = encode_term x.sort env in - let x, xtm, env' = gen_term_var env x in - let refinement, decls' = encode_formula f env' in - - let fsym, fterm = fresh_fvar env.current_module_name "f" Fuel_sort in - - let tm_has_type_with_fuel = mk_HasTypeWithFuel (Some fterm) xtm base_t in - - (* `encoding` includes `x.sort` via `tm_has_type_with_fuel` *) - let encoding = mkAnd(tm_has_type_with_fuel, refinement) in - - //earlier we used to get cvars from encoding - //but mkAnd is optimized and when refinement is False, it returns False - //in that case, cvars was turning out to be empty, resulting in non well-formed encoding (e.g. of hasEq, since free variables of base_t are not captured in cvars) - //to get around that, computing cvars separately from the components of the encoding variable - let cvars = BU.remove_dups fv_eq (Term.free_variables refinement @ Term.free_variables tm_has_type_with_fuel) in - let cvars = cvars |> List.filter (fun y -> fv_name y <> x && fv_name y <> fsym) in - - let xfv = mk_fv (x, Term_sort) in - let ffv = mk_fv (fsym, Fuel_sort) in - let tkey = mkForall t0.pos ([], ffv::xfv::cvars, encoding) in - let tkey_hash = Term.hash_of_term tkey in - - if !dbg_SMTEncoding - then BU.print3 "Encoding Tm_refine %s with tkey_hash %s and digest %s\n" - (show f) tkey_hash (BU.digest_of_string tkey_hash) - else (); - - let tsym = "Tm_refine_" ^ (BU.digest_of_string tkey_hash) in - let cvar_sorts = List.map fv_sort cvars in - let tdecl = Term.DeclFun(tsym, cvar_sorts, Term_sort, None) in - let t = mkApp(tsym, List.map mkFreeV cvars) in - - let x_has_base_t = mk_HasType xtm base_t in - let x_has_t = mk_HasTypeWithFuel (Some fterm) xtm t in - let t_has_kind = mk_HasType t mk_Term_type in - - //add hasEq axiom for this refinement type - let t_haseq_base = mk_haseq base_t in - let t_haseq_ref = mk_haseq t in - - let t_haseq = - Util.mkAssume(mkForall t0.pos ([[t_haseq_ref]], cvars, (mkIff (t_haseq_ref, t_haseq_base))), - Some ("haseq for " ^ tsym), - "haseq" ^ tsym) in - // let t_valid = - // let xx = (x, Term_sort) in - // let valid_t = mkApp ("Valid", [t]) in - // Util.mkAssume(mkForall ([[valid_t]], cvars, - // mkIff (mkExists ([], [xx], mkAnd (x_has_base_t, refinement)), valid_t)), - // Some ("validity axiom for refinement"), - // "ref_valid_" ^ tsym) - // in - - let t_kinding = - //TODO: guard by typing of cvars?; not necessary since we have pattern-guarded - Util.mkAssume(mkForall t0.pos ([[t_has_kind]], cvars, t_has_kind), - Some "refinement kinding", - "refinement_kinding_" ^tsym) - in - let t_interp = - Util.mkAssume(mkForall t0.pos ([[x_has_t]], ffv::xfv::cvars, mkIff(x_has_t, encoding)), - Some "refinement_interpretation", - "refinement_interpretation_"^tsym) in - - let t_decls = [tdecl; - t_kinding; //t_valid; - t_interp; t_haseq] in - t, decls@decls'@mk_decls tsym tkey_hash t_decls (decls@decls') - - | Tm_uvar (uv, _) -> - let ttm = mk_Term_uvar (Unionfind.uvar_id uv.ctx_uvar_head) in - let t_has_k, decls = encode_term_pred None (U.ctx_uvar_typ uv) env ttm in //TODO: skip encoding this if it has already been encoded before - let d = - Util.mkAssume(t_has_k, - Some "Uvar typing", - varops.mk_unique - (BU.format1 "uvar_typing_%s" - (BU.string_of_int - (Unionfind.uvar_id uv.ctx_uvar_head)))) - in - ttm, decls@([d] |> mk_decls_trivial) - - | Tm_app _ -> - let head, args_e = U.head_and_args t0 in - let head, args_e = - if head_redex env head - then match maybe_whnf env t0 with - | None -> head, args_e - | Some t -> U.head_and_args t - else head, args_e - in - begin - match (SS.compress head).n, args_e with - | _ when is_arithmetic_primitive head args_e -> - encode_arith_term env head args_e - - | _ when is_BitVector_primitive head args_e -> - encode_BitVector_term env head args_e - - | Tm_fvar fv, [(arg, _)] - | Tm_uinst({n=Tm_fvar fv}, _), [(arg, _)] - when - (S.fv_eq_lid fv Const.squash_lid - || S.fv_eq_lid fv Const.auto_squash_lid) - && Option.isSome (Syntax.Formula.destruct_typ_as_formula arg) -> - let dummy = S.new_bv None t_unit in - let t = U.refine dummy arg in (* so that `squash f`, when f is a formula, benefits from shallow embedding *) - encode_term t env - - | Tm_fvar fv, _ - | Tm_uinst({n=Tm_fvar fv}, _), _ - when (not env.encoding_quantifier) - && (S.fv_eq_lid fv Const.forall_lid - || S.fv_eq_lid fv Const.exists_lid) -> - encode_deeply_embedded_quantifier t0 env - - | Tm_constant Const_range_of, [(arg, _)] -> - encode_const (Const_range arg.pos) env - - | Tm_constant Const_set_range_of, [(arg, _); (rng, _)] -> - encode_term arg env - - | Tm_constant (Const_reify lopt), _ -> - let fallback () = - let f = varops.fresh env.current_module_name "Tm_reify" in - let decl = - Term.DeclFun (f, [], Term_sort, Some "Imprecise reify") in - mkFreeV <| mk_fv (f, Term_sort), [decl] |> mk_decls_trivial in - - (match lopt with - | None -> fallback () - | Some l - when l |> Env.norm_eff_name env.tcenv - |> Env.is_layered_effect env.tcenv -> fallback () - | _ -> - let e0 = TcUtil.norm_reify env.tcenv [] - (U.mk_reify (args_e |> List.hd |> fst) lopt) in - if !dbg_SMTEncodingReify - then BU.print1 "Result of normalization %s\n" (show e0); - let e = S.mk_Tm_app (TcUtil.remove_reify e0) (List.tl args_e) t0.pos in - encode_term e env) - - | Tm_constant (Const_reflect _), [(arg, _)] -> - encode_term arg env - - | Tm_fvar fv, [_; (phi, _)] - | Tm_uinst ({n=Tm_fvar fv}, _), [_; (phi, _)] - when S.fv_eq_lid fv Const.by_tactic_lid -> - encode_term phi env - - | Tm_fvar fv, [_; _; (phi, _)] - | Tm_uinst ({n=Tm_fvar fv}, _), [_; _; (phi, _)] - when S.fv_eq_lid fv Const.rewrite_by_tactic_lid -> - encode_term phi env - - | _ -> - let args, decls = encode_args args_e env in - - let encode_partial_app (ht_opt:option (S.typ & S.binders & S.comp)) = - let smt_head, decls' = encode_term head env in - let app_tm = mk_Apply_args smt_head args in - match ht_opt with - | _ when 1=1 -> app_tm, decls@decls' //NS: Intentionally using a default case here to disable the axiom below - | Some (head_type, formals, c) -> - if !dbg_PartialApp - then BU.print5 "Encoding partial application:\n\thead=%s\n\thead_type=%s\n\tformals=%s\n\tcomp=%s\n\tactual args=%s\n" - (show head) - (show head_type) - (show formals) - (show c) - (show args_e); - let formals, rest = BU.first_N (List.length args_e) formals in - let subst = List.map2 (fun ({binder_bv=bv}) (a, _) -> Syntax.NT(bv, a)) formals args_e in - let ty = U.arrow rest c |> SS.subst subst in - if !dbg_PartialApp - then BU.print1 "Encoding partial application, after subst:\n\tty=%s\n" - (show ty); - let vars, pattern, has_type, decls'' = - let t_hyps, decls = - List.fold_left2 (fun (t_hyps, decls) ({binder_bv=bv}) e -> - let t = SS.subst subst bv.sort in - let t_hyp, decls' = encode_term_pred None t env e in - if !dbg_PartialApp - then BU.print2 "Encoded typing hypothesis for %s ... got %s\n" - (show t) - (Term.print_smt_term t_hyp); - t_hyp::t_hyps, decls@decls') - ([], []) - formals - args - in - let t_head_hyp, decls' = - match smt_head.tm with - | FreeV _ -> - encode_term_pred None head_type env smt_head - | _ -> - mkTrue, [] - in - let hyp = Term.mk_and_l (t_head_hyp::t_hyps) Range.dummyRange in - let has_type_conclusion, decls'' = - encode_term_pred None ty env app_tm - in - let has_type = mkImp (hyp, has_type_conclusion) in - let cvars = Term.free_variables has_type in - let app_tm_vars = Term.free_variables app_tm in - let pattern, vars = - if Term.fvs_subset_of cvars app_tm_vars - then [app_tm], app_tm_vars - else if Term.fvs_subset_of cvars (Term.free_variables has_type_conclusion) - then [has_type_conclusion], cvars - else begin - Errors.log_issue t0 Errors.Warning_SMTPatternIllFormed - (BU.format1 "No SMT pattern for partial application %s" (show t0)); - [], cvars //no pattern! - end - in - vars, - pattern, - has_type, - decls@decls'@decls'' - in - if !dbg_PartialApp - then BU.print1 "Encoding partial application, after SMT encoded predicate:\n\t=%s\n" - (Term.print_smt_term has_type); - let tkey_hash = Term.hash_of_term app_tm in - let e_typing = Util.mkAssume(mkForall t0.pos ([pattern], vars, has_type), - Some "Partial app typing", - ("partial_app_typing_" ^ - (BU.digest_of_string (Term.hash_of_term app_tm)))) in - app_tm, decls@decls'@decls''@(mk_decls "" tkey_hash [e_typing] (decls@decls'@decls'')) - | None -> failwith "impossible" - in - - let encode_full_app fv = - let fname, fuel_args, arity = lookup_free_var_sym env fv in - let tm = maybe_curry_app t0.pos fname arity (fuel_args@args) in - tm, decls - in - - let head = SS.compress head in - - let head_type = - match head.n with - | Tm_uinst({n=Tm_name x}, _) - | Tm_name x -> Some x.sort - | Tm_uinst({n=Tm_fvar fv}, _) - | Tm_fvar fv -> Some (Env.lookup_lid env.tcenv fv.fv_name.v |> fst |> snd) - | Tm_ascribed {asc=(Inl t, _, _)} -> Some t - | Tm_ascribed {asc=(Inr c, _, _)} -> Some (U.comp_result c) - | _ -> None - in - - match head_type with - | None -> encode_partial_app None - | Some head_type -> - let head_type, formals, c = - let head_type = U.unrefine <| normalize_refinement [Env.Weak; Env.HNF; Env.EraseUniverses] env.tcenv head_type in - let formals, c = curried_arrow_formals_comp head_type in - if List.length formals < List.length args - then let head_type = - U.unrefine - <| normalize_refinement - [Env.Weak; Env.HNF; Env.EraseUniverses; Env.UnfoldUntil delta_constant] - env.tcenv - head_type - in - let formals, c = curried_arrow_formals_comp head_type in - head_type, formals, c - else head_type, formals, c - in - if !dbg_PartialApp - then BU.print3 "Encoding partial application, head_type = %s, formals = %s, args = %s\n" - (show head_type) - (show formals) - (show args_e); - - begin - match head.n with - | Tm_uinst({n=Tm_fvar fv}, _) - | Tm_fvar fv when (List.length formals = List.length args) -> encode_full_app fv.fv_name - | _ -> - if List.length formals > List.length args - then encode_partial_app (Some (head_type, formals, c)) - else encode_partial_app None - end - - end - - | Tm_abs {bs; body; rc_opt=lopt} -> - let bs, body, opening = SS.open_term' bs body in - let fallback () = - let arg_sorts, arg_terms = - (* We need to compute all free variables of this lambda - expression and parametrize the encoding wrt to them. See - issue #3028 *) - let fvs = Free.names t0 |> elems in - let tms = List.map (lookup_term_var env) fvs in - (List.map (fun _ -> Term_sort) fvs <: list sort), - tms - in - let f = varops.fresh env.current_module_name "Tm_abs" in - let decl = Term.DeclFun(f, arg_sorts, Term_sort, Some "Imprecise function encoding") in - let fv : term = mkFreeV <| mk_fv (f, Term_sort) in - let fapp = mkApp (f, arg_terms) in - fapp, [decl] |> mk_decls_trivial - in - - let is_impure (rc:S.residual_comp) = - TypeChecker.Util.is_pure_or_ghost_effect env.tcenv rc.residual_effect |> not - in - -// let reify_comp_and_body env body = -// let reified_body = TcUtil.reify_body env.tcenv body in -// let c = match c with -// | Inl lc -> -// let typ = reify_comp ({env.tcenv with admit=true}) (lc.comp ()) U_unknown in -// Inl (U.lcomp_of_comp (S.mk_Total typ)) -// -// (* In this case we don't have enough information to reconstruct the *) -// (* whole computation type and reify it *) -// | Inr (eff_name, _) -> c -// in -// c, reified_body -// in - - let codomain_eff rc = - let res_typ = - match rc.residual_typ with - | None -> - let t, _, _ = - FStar.TypeChecker.Util.new_implicit_var - "SMTEncoding codomain" - (Env.get_range env.tcenv) - env.tcenv - U.ktype0 - false - in - t - | Some t -> t - in - if Ident.lid_equals rc.residual_effect Const.effect_Tot_lid - then Some (S.mk_Total res_typ) - else if Ident.lid_equals rc.residual_effect Const.effect_GTot_lid - then Some (S.mk_GTotal res_typ) - (* TODO (KM) : shouldn't we do something when flags contains TOTAL ? *) - else None - in - - begin match lopt with - | None -> - let open FStar.Class.PP in - let open FStar.Pprint in - let open FStar.Errors.Msg in - //we don't even know if this is a pure function, so give up - Errors.log_issue t0 Errors.Warning_FunctionLiteralPrecisionLoss [ - prefix 2 1 (text "Losing precision when encoding a function literal:") - (pp t0); - text "Unannotated abstraction in the compiler?" - ]; - fallback () - - | Some rc -> - if is_impure rc && not (is_smt_reifiable_rc env.tcenv rc) - then fallback() //we know it's not pure; so don't encode it precisely - else - let vars, guards, envbody, decls, _ = encode_binders None bs env in - let body = if is_smt_reifiable_rc env.tcenv rc - then TcUtil.norm_reify env.tcenv [] - (U.mk_reify body (Some rc.residual_effect)) - else body - in - let body, decls' = encode_term body envbody in - let is_pure = U.is_pure_effect rc.residual_effect in - let arrow_t_opt, decls'' = - match codomain_eff rc with - | None -> None, [] - | Some c -> - let tfun = U.arrow bs c in - let t, decls = encode_term tfun env in - Some t, decls - in - let key_body = mkForall t0.pos ([], vars, mkImp(mk_and_l guards, body)) in - let cvars = Term.free_variables key_body in - //adding free variables of the return type also to cvars - let cvars, key_body = - match arrow_t_opt with - | None -> cvars, key_body - | Some t -> - BU.remove_dups fv_eq (Term.free_variables t @ cvars), - mkAnd (key_body, t) (* we make the encoding depend on the type of the abstraction, see #1595 *) - in - let tkey = mkForall t0.pos ([], cvars, key_body) in - let tkey_hash = Term.hash_of_term tkey in - if !dbg_PartialApp - then BU.print2 "Checking eta expansion of\n\tvars={%s}\n\tbody=%s\n" - (List.map fv_name vars |> String.concat ", ") - (print_smt_term body); - let cvar_sorts = List.map fv_sort cvars in - let fsym = "Tm_abs_" ^ (BU.digest_of_string tkey_hash) in - let fdecl = Term.DeclFun(fsym, cvar_sorts, Term_sort, None) in - let f = mkApp(fsym, List.map mkFreeV cvars) in //arity ok, since introduced at cvar_sorts (#1383) - let app = mk_Apply f vars in - let typing_f = - match arrow_t_opt with - | None -> - let tot_fun_ax = - let ax = (isTotFun_axioms t0.pos f vars (vars |> List.map (fun _ -> mkTrue)) is_pure) in - match cvars with - | [] -> ax - | _ -> mkForall t0.pos ([[f]], cvars, ax) - in - let a_name = "tot_fun_"^fsym in - [Util.mkAssume(tot_fun_ax, Some a_name, a_name)] - //no typing axiom for this lambda, because we don't have enough info - //but we at least mark its partial applications as total (cf. #1750) - | Some t -> - let f_has_t = mk_HasTypeWithFuel None f t in - let a_name = "typing_"^fsym in - [Util.mkAssume(mkForall t0.pos ([[f]], cvars, f_has_t), Some a_name, a_name)] - in - let interp_f = - let a_name = "interpretation_" ^fsym in - Util.mkAssume(mkForall t0.pos ([[app]], vars@cvars, mkEq(app, body)), Some a_name, a_name) - in - let f_decls = (fdecl::typing_f)@[interp_f] in - f, decls@decls'@decls''@(mk_decls fsym tkey_hash f_decls (decls@decls'@decls'')) - end - - | Tm_let {lbs=(_, {lbname=Inr _}::_)} -> - failwith "Impossible: already handled by encoding of Sig_let" - - | Tm_let {lbs=(false, [{lbname=Inl x; lbtyp=t1; lbdef=e1}]); body=e2} -> - encode_let x t1 e1 e2 env encode_term - - | Tm_let {lbs=(false, _::_)} -> - failwith "Impossible: non-recursive let with multiple bindings" - - | Tm_let {lbs=(_, lbs)} -> - let names = lbs |> List.map (fun lb -> - let {lbname = lbname} = lb in - let x = BU.left lbname in (* has to be Inl *) - (Ident.string_of_id x.ppname, S.range_of_bv x)) in - raise (Inner_let_rec names) - - | Tm_match {scrutinee=e; brs=pats} -> - encode_match e pats mk_Term_unit env encode_term - -and encode_let - : bv -> typ -> S.term -> S.term -> env_t -> (S.term -> env_t -> term & decls_t) - -> term & decls_t - = - fun x t1 e1 e2 env encode_body -> - //setting the use_eq ascription flag to false, - // doesn't matter since the flag is irrelevant outside the typechecker - let ee1, decls1 = encode_term (U.ascribe e1 (Inl t1, None, false)) env in - let xs, e2 = SS.open_term [S.mk_binder x] e2 in - let x = (List.hd xs).binder_bv in - let env' = push_term_var env x ee1 in - let ee2, decls2 = encode_body e2 env' in - ee2, decls1@decls2 - -and encode_match (e:S.term) (pats:list S.branch) (default_case:term) (env:env_t) - (encode_br:S.term -> env_t -> (term & decls_t)) : term & decls_t = - let scrsym, scr', env = gen_term_var env (S.null_bv (S.mk S.Tm_unknown Range.dummyRange)) in - let scr, decls = encode_term e env in - let match_tm, decls = - let encode_branch b (else_case, decls) = - let p, w, br = SS.open_branch b in - let env0, pattern = encode_pat env p in - let guard = pattern.guard scr' in - let projections = pattern.projections scr' in - let env = projections |> List.fold_left (fun env (x, t) -> push_term_var env x t) env in - let guard, decls2 = - match w with - | None -> guard, [] - | Some w -> - let w, decls2 = encode_term w env in - mkAnd(guard, mkEq(w, Term.boxBool mkTrue)), decls2 - in - let br, decls3 = encode_br br env in - mkITE(guard, br, else_case), decls@decls2@decls3 - in - List.fold_right encode_branch pats (default_case (* default; should be unreachable *), decls) - in - mkLet' ([mk_fv (scrsym,Term_sort), scr], match_tm) Range.dummyRange, decls - -and encode_pat (env:env_t) (pat:S.pat) : (env_t & pattern) = - if Debug.medium () then BU.print1 "Encoding pattern %s\n" (show pat); - let vars, pat_term = FStar.TypeChecker.Util.decorated_pattern_as_term pat in - - let env, vars = vars |> List.fold_left (fun (env, vars) v -> - let xx, _, env = gen_term_var env v in - env, (v, mk_fv (xx, Term_sort))::vars) (env, []) in - - let rec mk_guard pat (scrutinee:term) : term = - match pat.v with - | Pat_var _ - | Pat_dot_term _ -> mkTrue - | Pat_constant c -> - let tm, decls = encode_const c env in - let _ = match decls with _::_ -> failwith "Unexpected encoding of constant pattern" | _ -> () in - mkEq(scrutinee, tm) - | Pat_cons(f, _, args) -> - let is_f = - let tc_name = Env.typ_of_datacon env.tcenv f.fv_name.v in - match Env.datacons_of_typ env.tcenv tc_name with - | _, [_] -> mkTrue //single constructor type; no need for a test - | _ -> mk_data_tester env f.fv_name.v scrutinee - in - let sub_term_guards = args |> List.mapi (fun i (arg, _) -> - let proj = primitive_projector_by_pos env.tcenv f.fv_name.v i in - mk_guard arg (mkApp(proj, [scrutinee]))) in //arity ok, primitive projector (#1383) - mk_and_l (is_f::sub_term_guards) - in - - let rec mk_projections pat (scrutinee:term) = - match pat.v with - | Pat_dot_term _ -> [] - | Pat_var x -> [x, scrutinee] - - | Pat_constant _ -> [] - - | Pat_cons(f, _, args) -> - args - |> List.mapi (fun i (arg, _) -> - let proj = primitive_projector_by_pos env.tcenv f.fv_name.v i in - mk_projections arg (mkApp(proj, [scrutinee]))) //arity ok, primitive projector (#1383) - |> List.flatten - in - - let pat_term () = encode_term pat_term env in - - let pattern = { - pat_vars=vars; - pat_term=pat_term; - guard=mk_guard pat; - projections=mk_projections pat; - } in - - env, pattern - -and encode_args (l:args) (env:env_t) : (list term & decls_t) = - let l, decls = l |> List.fold_left - (fun (tms, decls) (t, _) -> let t, decls' = encode_term t env in t::tms, decls@decls') - ([], []) in - List.rev l, decls - -and encode_smt_patterns (pats_l:list (list S.arg)) env : list (list term) & decls_t = - let env = {env with use_zfuel_name=true} in - let encode_smt_pattern t = - let head, args = U.head_and_args t in - let head = U.un_uinst head in - match head.n, args with - | Tm_fvar fv, [_; (x, _); (t, _)] - when S.fv_eq_lid fv Const.has_type_lid -> //interpret Prims.has_type as HasType - let x, decls = encode_term x env in - let t, decls' = encode_term t env in - mk_HasType x t, decls@decls' - - | _ -> - encode_term t env - in - List.fold_right (fun pats (pats_l, decls) -> - let pats, decls = - List.fold_right - (fun (p, _) (pats, decls) -> - let t, d = encode_smt_pattern p in - match check_pattern_ok t with - | None -> - t::pats, d@decls - | Some illegal_subterm -> - Errors.log_issue p Errors.Warning_SMTPatternIllFormed - (BU.format2 "Pattern %s contains illegal sub-term (%s); dropping it" - (show p) - (show illegal_subterm)); - pats, d@decls) - pats ([], decls) - in - pats::pats_l, decls) - pats_l ([], []) - -and encode_formula (phi:typ) (env:env_t) : (term & decls_t) = (* expects phi to be normalized; the existential variables are all labels *) - let debug phi = - if !dbg_SMTEncoding - then BU.print2 "Formula (%s) %s\n" - (tag_of phi) - (show phi) in - let enc (f:list term -> term) : Range.range -> args -> (term & decls_t) = fun r l -> - let decls, args = BU.fold_map (fun decls x -> let t, decls' = encode_term (fst x) env in decls@decls', t) [] l in - ({f args with rng=r}, decls) in - - let const_op f r _ = (f r, []) in - let un_op f l = f <| List.hd l in - let bin_op : ((term & term) -> term) -> list term -> term = fun f -> function - | [t1;t2] -> f(t1,t2) - | _ -> failwith "Impossible" in - - let enc_prop_c f : Range.range -> args -> (term & decls_t) = fun r l -> - let decls, phis = - BU.fold_map (fun decls (t, _) -> - let phi, decls' = encode_formula t env in - decls@decls', phi) - [] l in - ({f phis with rng=r}, decls) in - - // This gets called for - // eq2 : #a:Type -> a -> a -> Type - // equals: #a:Type -> a -> a -> Type - let eq_op r args : (term & decls_t) = - let rf = List.filter (fun (a,q) -> match q with | Some ({ aqual_implicit = true }) -> false | _ -> true) args in - if List.length rf <> 2 - then failwith (BU.format1 "eq_op: got %s non-implicit arguments instead of 2?" (string_of_int (List.length rf))) - else enc (bin_op mkEq) r rf - in - - let mk_imp r : Tot (args -> (term & decls_t)) = function - | [(lhs, _); (rhs, _)] -> - let l1, decls1 = encode_formula rhs env in - begin match l1.tm with - | App(TrueOp, _) -> (l1, decls1) (* Optimization: don't bother encoding the LHS of a trivial implication *) - | _ -> - let l2, decls2 = encode_formula lhs env in - (Term.mkImp(l2, l1) r, decls1@decls2) - end - | _ -> failwith "impossible" in - - let mk_ite r: Tot (args -> (term & decls_t)) = function - | [(guard, _); (_then, _); (_else, _)] -> - let (g, decls1) = encode_formula guard env in - let (t, decls2) = encode_formula _then env in - let (e, decls3) = encode_formula _else env in - - let res = Term.mkITE(g, t, e) r in - res, decls1@decls2@decls3 - | _ -> failwith "impossible" in - - - let unboxInt_l : (list term -> term) -> list term -> term = fun f l -> f (List.map Term.unboxInt l) in - let connectives = [ - (Const.and_lid, enc_prop_c (bin_op mkAnd)); - (Const.or_lid, enc_prop_c (bin_op mkOr)); - (Const.imp_lid, mk_imp); - (Const.iff_lid, enc_prop_c (bin_op mkIff)); - (Const.ite_lid, mk_ite); - (Const.not_lid, enc_prop_c (un_op mkNot)); - (Const.eq2_lid, eq_op); - (Const.c_eq2_lid, eq_op); - (Const.true_lid, const_op Term.mkTrue); - (Const.false_lid, const_op Term.mkFalse); - ] in - - let rec fallback phi = match phi.n with - | Tm_meta {tm=phi'; meta=Meta_labeled(msg, r, b)} -> - let phi, decls = encode_formula phi' env in - mk (Term.Labeled(phi, msg, r)) r, decls - - | Tm_meta _ -> - encode_formula (U.unmeta phi) env - - | Tm_match {scrutinee=e;brs=pats} -> - let t, decls = encode_match e pats mkUnreachable env encode_formula in - t, decls - - | Tm_let {lbs=(false, [{lbname=Inl x; lbtyp=t1; lbdef=e1}]); body=e2} -> - let t, decls = encode_let x t1 e1 e2 env encode_formula in - t, decls - - | Tm_app {hd=head; args} -> - let head = U.un_uinst head in - begin match head.n, args with - | Tm_fvar fv, [_; (x, _); (t, _)] when S.fv_eq_lid fv Const.has_type_lid -> //interpret Prims.has_type as HasType - let x, decls = encode_term x env in - let t, decls' = encode_term t env in - mk_HasType x t, decls@decls' - - | Tm_fvar fv, [_; (phi, _)] - | Tm_uinst ({n=Tm_fvar fv}, _), [_; (phi, _)] - when S.fv_eq_lid fv Const.by_tactic_lid -> - encode_formula phi env - - | Tm_fvar fv, [_; _; (phi, _)] - | Tm_uinst ({n=Tm_fvar fv}, _), [_; _; (phi, _)] - when S.fv_eq_lid fv Const.rewrite_by_tactic_lid -> - encode_formula phi env - - | Tm_fvar fv, [(r, _); (msg, _); (phi, _)] when S.fv_eq_lid fv Const.labeled_lid -> //interpret (labeled r msg t) as Tm_meta(t, Meta_labeled(msg, r, false) - (* NB: below we use Errors.mkmsg since FStar.Range.labeled takes a string, but - the Meta_labeled node needs a list of docs (Errors.error_message). *) - begin match SE.try_unembed r SE.id_norm_cb, - SE.try_unembed msg SE.id_norm_cb with - | Some r, Some s -> - let phi = S.mk (Tm_meta {tm=phi; meta=Meta_labeled(Errors.mkmsg s, r, false)}) r in - fallback phi - - (* If we could not unembed the position, still use the string *) - | None, Some s -> - let phi = S.mk (Tm_meta {tm=phi; meta=Meta_labeled(Errors.mkmsg s, phi.pos, false)}) phi.pos in - fallback phi - - | _ -> - fallback phi - end - - | Tm_fvar fv, [(t, _)] - when S.fv_eq_lid fv Const.squash_lid - || S.fv_eq_lid fv Const.auto_squash_lid -> - encode_formula t env - - | _ -> - let encode_valid () = - let tt, decls = encode_term phi env in - let tt = - if Range.rng_included (Range.use_range tt.rng) (Range.use_range phi.pos) - then tt - else {tt with rng=phi.pos} in - mk_Valid tt, decls - in - if head_redex env head - then match maybe_whnf env head with - | None -> encode_valid() - | Some phi -> encode_formula phi env - else encode_valid() - end - - | _ -> - let tt, decls = encode_term phi env in - let tt = - if Range.rng_included (Range.use_range tt.rng) (Range.use_range phi.pos) - then tt - else {tt with rng=phi.pos} in - mk_Valid tt, decls in - - let encode_q_body env (bs:Syntax.binders) (ps:list args) body = - let vars, guards, env, decls, _ = encode_binders None bs env in - let pats, decls' = encode_smt_patterns ps env in - let body, decls'' = encode_formula body env in - let guards = match pats with - | [[{tm=App(Var gf, [p])}]] when Ident.string_of_lid Const.guard_free = gf -> [] - | _ -> guards in - vars, pats, mk_and_l guards, body, decls@decls'@decls'' in - - debug phi; - - let phi = U.unascribe phi in - let open FStar.Syntax.Formula in - match destruct_typ_as_formula phi with - | None -> fallback phi - - | Some (BaseConn(op, arms)) -> - (match connectives |> List.tryFind (fun (l, _) -> lid_equals op l) with - | None -> fallback phi - | Some (_, f) -> f phi.pos arms) - - | Some (QAll(vars, pats, body)) -> - pats |> List.iter (check_pattern_vars env vars); - let vars, pats, guard, body, decls = encode_q_body env vars pats body in - let tm = mkForall phi.pos (pats, vars, mkImp(guard, body)) in - tm, decls - - | Some (QEx(vars, pats, body)) -> - pats |> List.iter (check_pattern_vars env vars); - let vars, pats, guard, body, decls = encode_q_body env vars pats body in - mkExists phi.pos (pats, vars, mkAnd(guard, body)), decls - -(* this assumes t is a Lemma *) -let encode_function_type_as_formula (t:typ) (env:env_t) : term & decls_t = - let universe_of_binders binders = List.map (fun _ -> U_zero) binders in - let quant = U.smt_lemma_as_forall t universe_of_binders in - let env = {env with use_zfuel_name=true} in //see #1028; SMT lemmas should not violate the fuel instrumentation - encode_formula quant env - -(***************************************************************************************************) -(* end main encoding of kinds/types/exps/formulae *) -(***************************************************************************************************) diff --git a/src/smtencoding/FStar.SMTEncoding.EncodeTerm.fsti b/src/smtencoding/FStar.SMTEncoding.EncodeTerm.fsti deleted file mode 100644 index 0ffb8be24ce..00000000000 --- a/src/smtencoding/FStar.SMTEncoding.EncodeTerm.fsti +++ /dev/null @@ -1,68 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.SMTEncoding.EncodeTerm -open Prims -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar -open FStar.Compiler -open FStar.TypeChecker.Env -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.TypeChecker -open FStar.SMTEncoding.Term -open FStar.Ident -open FStar.Const -open FStar.SMTEncoding -open FStar.SMTEncoding.Util -open FStar.SMTEncoding.Env -module BU = FStar.Compiler.Util -val isTotFun_axioms: Range.range -> head:term -> vars:fvs -> guards:list term -> bool -> term -val mk_Apply : e:term -> vars:fvs -> term -val maybe_curry_app : rng:Range.range -> head:either op term -> arity:int -> args:list term -> term -val maybe_curry_fvb : rng:Range.range -> head:fvar_binding -> args:list term -> term -val mkForall_fuel : string -> Range.range -> (list (list pat) & fvs & term -> term) //first arg is the module name - -val head_normal : env_t -> Syntax.term -> bool - -val whnf: env_t -> Syntax.term -> Syntax.term -val norm: env_t -> Syntax.term -> Syntax.term - -val curried_arrow_formals_comp : k:Syntax.term -> Syntax.binders & comp - -val raise_arity_mismatch : head:string -> arity:int -> n_args:int -> rng:Range.range -> 'a - -val encode_term : t:typ (* expects t to be in normal form already *) - -> env:env_t - -> term & decls_t - -val encode_term_pred: fuel_opt:option term - -> t:typ - -> env:env_t - -> e:term - -> term & decls_t - -val encode_args : l:args -> env:env_t -> list term & decls_t - -val encode_formula : phi:typ -> env:env_t -> term & decls_t - -val encode_function_type_as_formula : t:typ -> env:env_t -> term & decls_t - -val encode_binders : fuel_opt:option term - -> bs:Syntax.binders - -> env:env_t - -> list fv & list term & env_t & decls_t & list bv diff --git a/src/smtencoding/FStar.SMTEncoding.Env.fst b/src/smtencoding/FStar.SMTEncoding.Env.fst deleted file mode 100644 index b42ffd348da..00000000000 --- a/src/smtencoding/FStar.SMTEncoding.Env.fst +++ /dev/null @@ -1,385 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.SMTEncoding.Env -open Prims -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar -open FStar.Compiler -open FStar.TypeChecker.Env -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.TypeChecker -open FStar.SMTEncoding.Term -open FStar.Ident -open FStar.SMTEncoding.Util - -module SS = FStar.Syntax.Subst -module BU = FStar.Compiler.Util -module U = FStar.Syntax.Util - -open FStar.Class.Show - -let dbg_PartialApp = Debug.get_toggle "PartialApp" - -exception Inner_let_rec of list (string & Range.range) //name of the inner let-rec(s) and their locations - -let add_fuel x tl = if (Options.unthrottle_inductives()) then tl else x::tl -let withenv c (a, b) = (a,b,c) -let vargs args = List.filter (function (Inl _, _) -> false | _ -> true) args -(* ------------------------------------ *) -(* Some operations on constants *) -let escape (s:string) = BU.replace_char s '\'' '_' -let mk_term_projector_name lid (a:bv) = - escape <| BU.format2 "%s_%s" (string_of_lid lid) (string_of_id a.ppname) -let primitive_projector_by_pos env lid i = - let fail () = failwith (BU.format2 "Projector %s on data constructor %s not found" (string_of_int i) (string_of_lid lid)) in - let _, t = Env.lookup_datacon env lid in - match (SS.compress t).n with - | Tm_arrow {bs; comp=c} -> - let binders, _ = SS.open_comp bs c in - if ((i < 0) || i >= List.length binders) //this has to be within bounds! - then fail () - else let b = List.nth binders i in - mk_term_projector_name lid b.binder_bv - | _ -> fail () -let mk_term_projector_name_by_pos lid (i:int) = escape <| BU.format2 "%s_%s" (string_of_lid lid) (string_of_int i) -let mk_term_projector (lid:lident) (a:bv) : term = - mkFreeV <| mk_fv (mk_term_projector_name lid a, Arrow(Term_sort, Term_sort)) -let mk_term_projector_by_pos (lid:lident) (i:int) : term = - mkFreeV <| mk_fv (mk_term_projector_name_by_pos lid i, Arrow(Term_sort, Term_sort)) -let mk_data_tester env l x = mk_tester (escape (string_of_lid l)) x -(* ------------------------------------ *) -(* New name generation *) -type varops_t = { - push: unit -> unit; - pop: unit -> unit; - snapshot: unit -> (int & unit); - rollback: option int -> unit; - new_var:ident -> int -> string; (* each name is distinct and has a prefix corresponding to the name used in the program text *) - new_fvar:lident -> string; - fresh:string -> string -> string; (* module name -> prefix -> name *) - reset_fresh:unit -> unit; - next_id: unit -> int; - mk_unique:string -> string; -} -let varops = - let initial_ctr = 100 in - let ctr = BU.mk_ref initial_ctr in - let new_scope () : BU.smap bool = BU.smap_create 100 in (* a scope records all the names used in that scope *) - let scopes = BU.mk_ref [new_scope ()] in - let mk_unique y = - let y = escape y in - let y = match BU.find_map (!scopes) (fun names -> BU.smap_try_find names y) with - | None -> y - | Some _ -> BU.incr ctr; y ^ "__" ^ (string_of_int !ctr) in - let top_scope = List.hd !scopes in - BU.smap_add top_scope y true; y in - let new_var pp rn = mk_unique <| (string_of_id pp) ^ "__" ^ (string_of_int rn) in - let new_fvar lid = mk_unique (string_of_lid lid) in - let next_id () = BU.incr ctr; !ctr in - //AR: adding module name after the prefix, else it interferes for name matching for fuel arguments - // see try_lookup_free_var below - let fresh mname pfx = BU.format3 "%s_%s_%s" pfx mname (string_of_int <| next_id()) in - //the fresh counter is reset after every module - let reset_fresh () = ctr := initial_ctr in - let push () = scopes := new_scope() :: !scopes in // already signal-atomic - let pop () = scopes := List.tl !scopes in // already signal-atomic - let snapshot () = FStar.Common.snapshot push scopes () in - let rollback depth = FStar.Common.rollback pop scopes depth in - {push=push; - pop=pop; - snapshot=snapshot; - rollback=rollback; - new_var=new_var; - new_fvar=new_fvar; - fresh=fresh; - reset_fresh=reset_fresh; - next_id=next_id; - mk_unique=mk_unique} - -(* ---------------------------------------------------- *) -(* *) -(* Each entry maps a Syntax variable to its encoding as a SMT2 term *) -(* free variables, depending on whether or not they are fully applied ... *) -(* ... are mapped either to SMT2 functions, or to nullary tokens *) -type fvar_binding = { - fvar_lid: lident; - smt_arity: int; - smt_id: string; - smt_token: option term; - smt_fuel_partial_app:option (term & term); - fvb_thunked: bool -} -let fvb_to_string fvb = - let term_opt_to_string = function - | None -> "None" - | Some s -> Term.print_smt_term s - in - let term_pair_opt_to_string = function - | None -> "None" - | Some (s0, s1) -> - BU.format2 "(%s, %s)" - (Term.print_smt_term s0) - (Term.print_smt_term s1) - in - BU.format6 "{ lid = %s;\n smt_arity = %s;\n smt_id = %s;\n smt_token = %s;\n smt_fuel_partial_app = %s;\n fvb_thunked = %s }" - (Ident.string_of_lid fvb.fvar_lid) - (string_of_int fvb.smt_arity) - fvb.smt_id - (term_opt_to_string fvb.smt_token) - (term_pair_opt_to_string fvb.smt_fuel_partial_app) - (BU.string_of_bool fvb.fvb_thunked) - -let check_valid_fvb fvb = - if (Option.isSome fvb.smt_token - || Option.isSome fvb.smt_fuel_partial_app) - && fvb.fvb_thunked - then failwith (BU.format1 "Unexpected thunked SMT symbol: %s" (Ident.string_of_lid fvb.fvar_lid)) - else if fvb.fvb_thunked && fvb.smt_arity <> 0 - then failwith (BU.format1 "Unexpected arity of thunked SMT symbol: %s" (Ident.string_of_lid fvb.fvar_lid)); - match fvb.smt_token with - | Some ({tm=FreeV _}) -> - failwith (BU.format1 "bad fvb\n%s" (fvb_to_string fvb)) - | _ -> () - - -let binder_of_eithervar v = (v, None) - -type env_t = { - bvar_bindings: BU.psmap (BU.pimap (bv & term)); - fvar_bindings: (BU.psmap fvar_binding & list fvar_binding); //list of fvar bindings for the current module - //remember them so that we can store them in the checked file - depth:int; //length of local var/tvar bindings - tcenv:Env.env; - warn:bool; - nolabels:bool; - use_zfuel_name:bool; - encode_non_total_function_typ:bool; - current_module_name:string; - encoding_quantifier:bool; - global_cache:BU.smap decls_elt; //cache for hashconsing -- see Encode.fs where it is used and updated -} - -let print_env (e:env_t) : string = - let bvars = BU.psmap_fold e.bvar_bindings (fun _k pi acc -> - BU.pimap_fold pi (fun _i (x, _term) acc -> - show x :: acc) acc) [] in - let allvars = BU.psmap_fold (e.fvar_bindings |> fst) (fun _k fvb acc -> - fvb.fvar_lid :: acc) [] in - let last_fvar = - match List.rev allvars with - | [] -> "" - | l::_ -> "...," ^ show l - in - String.concat ", " (last_fvar :: bvars) - -let lookup_bvar_binding env bv = - match BU.psmap_try_find env.bvar_bindings (string_of_id bv.ppname) with - | Some bvs -> BU.pimap_try_find bvs bv.index - | None -> None - -let lookup_fvar_binding env lid = - BU.psmap_try_find (env.fvar_bindings |> fst) (string_of_lid lid) - -let add_bvar_binding bvb bvbs = - BU.psmap_modify bvbs (string_of_id (fst bvb).ppname) - (fun pimap_opt -> - BU.pimap_add (BU.dflt (BU.pimap_empty ()) pimap_opt) (fst bvb).index bvb) - -let add_fvar_binding fvb (fvb_map, fvb_list) = - (BU.psmap_add fvb_map (string_of_lid fvb.fvar_lid) fvb, fvb::fvb_list) - -let fresh_fvar mname x s = let xsym = varops.fresh mname x in xsym, mkFreeV <| mk_fv (xsym, s) -(* generate terms corresponding to a variable and record the mapping in the environment *) - -(* Bound term variables *) -let gen_term_var (env:env_t) (x:bv) = - let ysym = "@x"^(string_of_int env.depth) in - let y = mkFreeV <| mk_fv (ysym, Term_sort) in - (* Note: the encoding of impure function arrows (among other places - probably) relies on the fact that this is exactly a FreeV. See getfreeV in - FStar.SMTEncoding.EncodeTerm.fst *) - ysym, y, {env with bvar_bindings=add_bvar_binding (x, y) env.bvar_bindings - ; tcenv = Env.push_bv env.tcenv x - ; depth = env.depth + 1 } - -let new_term_constant (env:env_t) (x:bv) = - let ysym = varops.new_var x.ppname x.index in - let y = mkApp(ysym, []) in - ysym, y, {env with bvar_bindings=add_bvar_binding (x, y) env.bvar_bindings - ; tcenv = Env.push_bv env.tcenv x} - -let new_term_constant_from_string (env:env_t) (x:bv) str = - let ysym = varops.mk_unique str in - let y = mkApp(ysym, []) in - ysym, y, {env with bvar_bindings=add_bvar_binding (x, y) env.bvar_bindings - ; tcenv = Env.push_bv env.tcenv x} - -let push_term_var (env:env_t) (x:bv) (t:term) = - {env with bvar_bindings=add_bvar_binding (x,t) env.bvar_bindings - ; tcenv = Env.push_bv env.tcenv x} - -let lookup_term_var env a = - match lookup_bvar_binding env a with - | Some (b,t) -> t - | None -> - failwith (BU.format2 "Bound term variable not found %s in environment: %s" - (show a) - (print_env env)) - -(* Qualified term names *) -let mk_fvb lid fname arity ftok fuel_partial_app thunked = - let fvb = { - fvar_lid = lid; - smt_arity = arity; - smt_id = fname; - smt_token = ftok; - smt_fuel_partial_app = fuel_partial_app; - fvb_thunked = thunked; - } - in - check_valid_fvb fvb; - fvb -let new_term_constant_and_tok_from_lid_aux (env:env_t) (x:lident) arity thunked = - let fname = varops.new_fvar x in - let ftok_name, ftok = - if thunked then None, None - else let ftok_name = fname^"@tok" in - let ftok = mkApp(ftok_name, []) in - Some ftok_name, Some ftok - in - let fvb = mk_fvb x fname arity ftok None thunked in -// Printf.printf "Pushing %A @ %A, %A\n" x fname ftok; - fname, ftok_name, {env with fvar_bindings=add_fvar_binding fvb env.fvar_bindings} -let new_term_constant_and_tok_from_lid (env:env_t) (x:lident) arity = - let fname, ftok_name_opt, env = new_term_constant_and_tok_from_lid_aux env x arity false in - fname, Option.get ftok_name_opt, env -let new_term_constant_and_tok_from_lid_maybe_thunked (env:env_t) (x:lident) arity th = - new_term_constant_and_tok_from_lid_aux env x arity th -let fail_fvar_lookup env a = - let q = Env.lookup_qname env.tcenv a in - match q with - | None -> - failwith (BU.format1 "Name %s not found in the smtencoding and typechecker env" (show a)) - | _ -> - let quals = Env.quals_of_qninfo q in - if BU.is_some quals && - (quals |> BU.must |> List.contains Unfold_for_unification_and_vcgen) - then Errors.raise_error a Errors.Fatal_IdentifierNotFound - (BU.format1 "Name %s not found in the smtencoding env (the symbol is marked unfold, expected it to reduce)" (show a)) - else failwith (BU.format1 "Name %s not found in the smtencoding env" (show a)) -let lookup_lid env a = - match lookup_fvar_binding env a with - | None -> fail_fvar_lookup env a - | Some s -> check_valid_fvb s; s -let push_free_var_maybe_thunked env (x:lident) arity fname ftok thunked = - let fvb = mk_fvb x fname arity ftok None thunked in - {env with fvar_bindings=add_fvar_binding fvb env.fvar_bindings} -let push_free_var env (x:lident) arity fname ftok = - push_free_var_maybe_thunked env x arity fname ftok false -let push_free_var_thunk env (x:lident) arity fname ftok = - push_free_var_maybe_thunked env x arity fname ftok (arity=0) -let push_zfuel_name env (x:lident) f ftok = - let fvb = lookup_lid env x in - let t3 = mkApp(f, [mkApp("ZFuel", [])]) in - let t3' = mk_ApplyTF (mkApp(ftok, [])) (mkApp("ZFuel", [])) in - let fvb = mk_fvb x fvb.smt_id fvb.smt_arity fvb.smt_token (Some (t3, t3')) false in - {env with fvar_bindings=add_fvar_binding fvb env.fvar_bindings} -let force_thunk fvb = - if not (fvb.fvb_thunked) || fvb.smt_arity <> 0 - then failwith "Forcing a non-thunk in the SMT encoding"; - mkFreeV <| FV (fvb.smt_id, Term_sort, true) -module TcEnv = FStar.TypeChecker.Env -let try_lookup_free_var env l = - match lookup_fvar_binding env l with - | None -> None - | Some fvb -> - if !dbg_PartialApp - then BU.print2 "Looked up %s found\n%s\n" - (Ident.string_of_lid l) - (fvb_to_string fvb); - if fvb.fvb_thunked - then Some (force_thunk fvb) - else - begin - match fvb.smt_fuel_partial_app with - | Some (_, f) when env.use_zfuel_name -> Some f - | _ -> - begin - match fvb.smt_token with - | Some t -> - begin - match t.tm with - | App(_, [fuel]) -> - if (BU.starts_with (Term.fv_of_term fuel |> fv_name) "fuel") - then Some <| mk_ApplyTF(mkFreeV <| mk_fv (fvb.smt_id, Term_sort)) fuel - else Some t - | _ -> Some t - end - | _ -> None - end - end -let lookup_free_var env a = - match try_lookup_free_var env a.v with - | Some t -> t - | None -> fail_fvar_lookup env a.v -let lookup_free_var_name env a = lookup_lid env a.v -let lookup_free_var_sym env a = - let fvb = lookup_lid env a.v in - match fvb.smt_fuel_partial_app with - | Some({tm=App(g, zf)}, _) - when env.use_zfuel_name -> - Inl g, zf, fvb.smt_arity + 1 - | _ -> - begin - match fvb.smt_token with - | None when fvb.fvb_thunked -> - Inr (force_thunk fvb), [], fvb.smt_arity - | None -> - Inl (Var fvb.smt_id), [], fvb.smt_arity - | Some sym -> - begin - match sym.tm with - | App(g, [fuel]) -> - Inl g, [fuel], fvb.smt_arity + 1 - | _ -> - Inl (Var fvb.smt_id), [], fvb.smt_arity - end - end - -let tok_of_name env nm = - match - BU.psmap_find_map (env.fvar_bindings |> fst) (fun _ fvb -> - check_valid_fvb fvb; - if fvb.smt_id = nm then fvb.smt_token else None) - with - | Some b -> Some b - | None -> //this must be a bvar - BU.psmap_find_map env.bvar_bindings (fun _ pi -> - BU.pimap_fold pi (fun _ y res -> - match res, y with - | Some _, _ -> res - | None, (_, {tm=App(Var sym, [])}) when sym=nm -> - Some (snd y) - | _ -> None) None) - -let reset_current_module_fvbs env = { env with fvar_bindings = (env.fvar_bindings |> fst, []) } -let get_current_module_fvbs env = env.fvar_bindings |> snd -let add_fvar_binding_to_env fvb env = - { env with fvar_bindings = add_fvar_binding fvb env.fvar_bindings } - -(* *) diff --git a/src/smtencoding/FStar.SMTEncoding.ErrorReporting.fst b/src/smtencoding/FStar.SMTEncoding.ErrorReporting.fst deleted file mode 100644 index f72c6dc5812..00000000000 --- a/src/smtencoding/FStar.SMTEncoding.ErrorReporting.fst +++ /dev/null @@ -1,382 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.SMTEncoding.ErrorReporting -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.BaseTypes -open FStar.Compiler.Util -open FStar.SMTEncoding.Term -open FStar.SMTEncoding.Util -open FStar.SMTEncoding.Z3 -open FStar.SMTEncoding -open FStar.Compiler.Range -open FStar.Class.Setlike -module BU = FStar.Compiler.Util - -exception Not_a_wp_implication of string -let sort_labels (l:(list (error_label & bool))) = List.sortWith (fun ((_, _, r1), _) ((_, _, r2), _) -> Range.compare r1 r2) l -let remove_dups (l:labels) = BU.remove_dups (fun (_, m1, r1) (_, m2, r2) -> r1=r2 && m1=m2) l -type msg = string & Range.range -type ranges = list (option string & Range.range) - -//decorate a term with an error label -let __ctr = BU.mk_ref 0 - -let fresh_label : Errors.error_message -> Range.range -> term -> label & term = - fun message range t -> - let l = incr __ctr; format1 "label_%s" (string_of_int !__ctr) in - let lvar = mk_fv (l, Bool_sort) in - let label = (lvar, message, range) in - let lterm = mkFreeV lvar in - let lt = Term.mkOr(lterm, t) range in - label, lt - -(* - label_goals query : term * labels - traverses the query, finding sub-formulas that are goals to be proven, - and labels each such sub-goal with a distinct label variable - - Returns the labeled query and the label terms that were added -*) -let label_goals use_env_msg //when present, provides an alternate error message, - //usually "could not check implicit argument", - // "could not prove post-condition" - //or something like that - (r:Range.range) //the source range in which this query was asked - q //the query - : labels //the labels themselves - & term //the query, decorated with labels - = - let rec is_a_post_condition post_name_opt tm = - match post_name_opt, tm.tm with - | None, _ -> false - | Some nm, FreeV fv -> - nm=fv_name fv - | _, App (Var "Valid", [tm]) - | _, App (Var "ApplyTT", tm::_) -> - is_a_post_condition post_name_opt tm - | _ -> - false - in - let conjuncts t = - match t.tm with - | App(And, cs) -> cs - | _ -> [t] - in - let is_guard_free tm = - match tm.tm with - | Quant(Forall, [[{tm=App(Var "Prims.guard_free", [p])}]], iopt, _, {tm=App(Imp, [l;r])}) -> - true - | _ -> false - in - let is_a_named_continuation lhs = conjuncts lhs |> BU.for_some is_guard_free in - let flag, msg_prefix = match use_env_msg with - | None -> false, Pprint.empty - | Some f -> true, Pprint.doc_of_string (f()) in - let fresh_label msg ropt rng t = - let open FStar.Pprint in - let msg = if flag - then (Errors.Msg.text "Failed to verify implicit argument: " ^^ msg_prefix) :: msg - else msg in - let rng = match ropt with - | None -> rng - | Some r -> if Range.rng_included (Range.use_range rng) (Range.use_range r) - then rng - else Range.set_def_range r (Range.def_range rng) - in - fresh_label msg rng t - in - let rec aux (default_msg : Errors.error_message) //the error message text to generate at a label - (ropt:option Range.range) //an optional position, if there was an enclosing Labeled node - (post_name_opt:option string) //the name of the current post-condition variable --- it is left uninstrumented - (labels:list label) //the labels accumulated so far - (q:term) //the term being instrumented - = match q.tm with - | BoundV _ - | Integer _ - | String _ - | Real _ -> - labels, q - - | LblPos _ -> failwith "Impossible" //these get added after errorReporting instrumentation only - - | Labeled(arg, [d], label_range) when Errors.Msg.renderdoc d = "Could not prove post-condition" -> - //printfn "GOT A LABELED WP IMPLICATION\n\t%s" - // (Term.print_smt_term q); - let fallback debug_msg = - //printfn "FALLING BACK: %s with range %s" msg - // (match ropt with None -> "None" | Some r -> Range.string_of_range r); - aux default_msg (Some label_range) post_name_opt labels arg - in - begin try - begin match arg.tm with - | Quant(Forall, pats, iopt, post::sorts, {tm=App(Imp, [lhs;rhs]); rng=rng}) -> - let post_name = "^^post_condition_"^ (BU.string_of_int <| GenSym.next_id ()) in - let names = mk_fv (post_name, post) - ::List.map (fun s -> mk_fv ("^^" ^ (string_of_int <| GenSym.next_id()), s)) sorts in - let instantiation = List.map mkFreeV names in - let lhs, rhs = Term.inst instantiation lhs, Term.inst instantiation rhs in - - let labels, lhs = match lhs.tm with - | App(And, clauses_lhs) -> - let req, ens = BU.prefix clauses_lhs in - begin match ens.tm with - | Quant(Forall, pats_ens, iopt_ens, sorts_ens, {tm=App(Imp, [ensures_conjuncts; post]); rng=rng_ens}) -> - if is_a_post_condition (Some post_name) post - then - let labels, ensures_conjuncts = aux (Errors.mkmsg "Could not prove post-condition") None (Some post_name) labels ensures_conjuncts in - let pats_ens = - match pats_ens with - | [] - | [[]] -> [[post]] //make the post-condition formula the pattern, if there isn't one already (usually there isn't) - | _ -> pats_ens in - let ens = Term.mk (Quant(Forall, pats_ens, iopt_ens, sorts_ens, - Term.mk (App(Imp, [ensures_conjuncts; post])) rng_ens)) ens.rng in - let lhs = Term.mk (App(And, req@[ens])) lhs.rng in - labels, Term.abstr names lhs - else raise (Not_a_wp_implication ("Ensures clause doesn't match post name: " - ^ post_name - ^ " ... " - ^ Term.print_smt_term post)) - - | _ -> raise (Not_a_wp_implication ("Ensures clause doesn't have the expected shape for post-condition " - ^ post_name - ^ " ... " - ^ Term.print_smt_term ens)) - end - | _ -> raise (Not_a_wp_implication ("LHS not a conjunct: " ^ (Term.print_smt_term lhs))) in - - let labels, rhs = - let labels, rhs = aux default_msg None (Some post_name) labels rhs in - labels, Term.abstr names rhs in - - let body = Term.mkImp(lhs, rhs) rng in - labels, Term.mk (Quant(Forall, pats, iopt, post::sorts, body)) q.rng - - - | _ -> //not in the form produced by an application of M_stronger - fallback ("arg not a quant: ")// ^ (Term.print_smt_term arg)) - end - with Not_a_wp_implication msg -> fallback msg - end - - | Labeled(arg, reason, r) -> - aux reason (Some r) post_name_opt labels arg - - | Quant(Forall, [], None, sorts, {tm=App(Imp, [lhs;rhs]); rng=rng}) - when is_a_named_continuation lhs -> - let sorts', post = BU.prefix sorts in - let new_post_name = "^^post_condition_"^ (BU.string_of_int <| GenSym.next_id ()) in - //printfn "Got a named continuation with post-condition %s" new_post_name; - let names = List.map (fun s -> mk_fv ("^^" ^ (string_of_int <| GenSym.next_id()), s)) sorts' - @ [mk_fv (new_post_name, post)] in - let instantiation = List.map mkFreeV names in - let lhs, rhs = Term.inst instantiation lhs, Term.inst instantiation rhs in - - let labels, lhs_conjs = - BU.fold_map (fun labels tm -> - match tm.tm with - | Quant(Forall, [[{tm=App(Var "Prims.guard_free", [p])}]], iopt, sorts, {tm=App(Imp, [l0;r])}) -> - if is_a_post_condition (Some new_post_name) r - then begin - //printfn "++++RHS is a post-condition for %s;\n\trhs=%s" - // new_post_name - // (Term.print_smt_term r); - let labels, l = aux default_msg None post_name_opt labels l0 in - //printfn "++++LHS %s\nlabeled as%s" - // (Term.print_smt_term l0) - // (Term.print_smt_term l); - labels, mk (Quant(Forall, [[p]], Some 0, sorts, norng mk (App(Imp, [l;r])))) q.rng - end - else begin - //printfn "----RHS not a post-condition for %s;\n\trhs=%s" - // new_post_name - // (Term.print_smt_term r); - labels, tm - end - | _ -> labels, tm) - labels (conjuncts lhs) in - - let labels, rhs = aux default_msg None (Some new_post_name) labels rhs in - let body = Term.mkImp(Term.mk_and_l lhs_conjs lhs.rng, rhs) rng |> Term.abstr names in - let q = Term.mk (Quant(Forall, [], None, sorts, body)) q.rng in - labels, q - - | App(Imp, [lhs;rhs]) -> - let labels, rhs = aux default_msg ropt post_name_opt labels rhs in - labels, mkImp(lhs, rhs) - - | App(And, conjuncts) -> - let labels, conjuncts = BU.fold_map (aux default_msg ropt post_name_opt) labels conjuncts in - labels, Term.mk_and_l conjuncts q.rng - - | App(ITE, [hd; q1; q2]) -> - let labels, q1 = aux default_msg ropt post_name_opt labels q1 in - let labels, q2 = aux default_msg ropt post_name_opt labels q2 in - labels, Term.mkITE (hd, q1, q2) q.rng - - | Quant(Exists, _, _, _, _) - | App(Iff, _) - | App(Or, _) -> //non-atomic, but can't case split - let lab, q = fresh_label default_msg ropt q.rng q in - lab::labels, q - - | App (Var "Unreachable", _) -> - //ITEs are encoded with an additional else case just to make them well-formed - //These are not real goals and should not be labeled - labels, q - - | App (Var _, _) when is_a_post_condition post_name_opt q -> - //applications of the post-condition variable are never labeled - //only specific conjuncts of an ensures clause are labeled - labels, q - - | FreeV _ - | App(TrueOp, _) - | App(FalseOp, _) - | App(Not, _) - | App(Eq, _) - | App(LT, _) - | App(LTE, _) - | App(GT, _) - | App(GTE, _) - | App(BvUlt, _) - | App(Var _, _) -> //atomic goals - let lab, q = fresh_label default_msg ropt q.rng q in - lab::labels, q - - | App(RealDiv, _) - | App(Add, _) - | App(Sub, _) - | App(Div, _) - | App(Mul, _) - | App(Minus, _) - | App(Mod, _) - | App(BvAnd, _) - | App(BvXor, _) - | App(BvOr, _) - | App(BvAdd, _) - | App(BvSub, _) - | App(BvShl, _) - | App(BvShr, _) - | App(BvUdiv, _) - | App(BvMod, _) - | App(BvMul, _) - | App(BvUext _, _) - | App(BvToNat, _) - | App(NatToBv _, _) -> - failwith "Impossible: non-propositional term" - - | App(ITE, _) - | App(Imp, _) -> - failwith "Impossible: arity mismatch" - - | Quant(Forall, pats, iopt, sorts, body) -> - let labels, body = aux default_msg ropt post_name_opt labels body in - labels, Term.mk (Quant(Forall, pats, iopt, sorts, body)) q.rng - - (* TODO (KM) : I am not sure whether we should label the let-bounded expressions here *) - | Let(es, body) -> - let labels, body = aux default_msg ropt post_name_opt labels body in - labels, Term.mkLet (es, body) q.rng - in - __ctr := 0; - aux (Errors.mkmsg "Assertion failed") None None [] q - - -(* - detail_errors all_labels potential_errors askZ3 - - -- Searching through the list of errors labels to exhaustively list - only those that are definitely not provable given the current - solver parameters. - - -- potential_errors are the labels in the initial counterexample model - *) -let detail_errors hint_replay - env - (all_labels:labels) - (askZ3:list decl -> Z3.z3result) - : unit = - - let print_banner () = - let msg = - BU.format4 - "Detailed %s report follows for %s\nTaking %s seconds per proof obligation (%s proofs in total)\n" - (if hint_replay then "hint replay" else "error") - (Range.string_of_range (TypeChecker.Env.get_range env)) - (BU.string_of_int 5) - (BU.string_of_int (List.length all_labels)) in - BU.print_error msg - in - - let print_result ((_, msg, r), success) = - let open FStar.Pprint in - let open FStar.Errors.Msg in - if success - then BU.print1 "OK: proof obligation at %s was proven in isolation\n" (Range.string_of_range r) - else if hint_replay - then FStar.Errors.log_issue r Errors.Warning_HintFailedToReplayProof - (text "Hint failed to replay this sub-proof" :: msg) - else FStar.Errors.log_issue r Errors.Error_ProofObligationFailed ([ - text <| BU.format1 "XX: proof obligation at %s failed." (Class.Show.show r); - ] @ msg) - in - - let elim labs = //assumes that all the labs are true, effectively removing them from the query - labs - |> List.map (fun (l, _, _) -> - let tm = mkEq(mkFreeV l, mkTrue) in - let a = { - assumption_name="@disable_label_"^fv_name l; //the "@" is important in the name; forces it to be retained when replaying a hint - assumption_caption=Some "Disabling label"; - assumption_term=mkEq(mkFreeV l, mkTrue); - assumption_fact_ids=[]; - assumption_free_names=free_top_level_names tm - } - in - Term.Assume a) in - - //check all active labels linearly and classify as eliminated/error - let rec linear_check eliminated errors active = - FStar.SMTEncoding.Z3.refresh (Some env.proof_ns); - match active with - | [] -> - let results = - List.map (fun x -> x, true) eliminated - @ List.map (fun x -> x, false) errors in - sort_labels results - - | hd::tl -> - BU.print1 "%s, " (BU.string_of_int (List.length active)); - let decls = elim <| (eliminated @ errors @ tl) in - let result = askZ3 decls in //hd is the only thing to prove - match result.z3result_status with - | Z3.UNSAT _ -> //hd is provable - linear_check (hd::eliminated) errors tl - | _ -> linear_check eliminated (hd::errors) tl - in - - print_banner (); - Options.set_option "z3rlimit" (Options.Int 5); - let res = linear_check [] [] all_labels in - BU.print_string "\n"; - res |> List.iter print_result; - if BU.for_all snd res - then BU.print_string "Failed: the heuristic of trying each proof in isolation failed to identify a precise error\n" diff --git a/src/smtencoding/FStar.SMTEncoding.ErrorReporting.fsti b/src/smtencoding/FStar.SMTEncoding.ErrorReporting.fsti deleted file mode 100644 index c342069f24b..00000000000 --- a/src/smtencoding/FStar.SMTEncoding.ErrorReporting.fsti +++ /dev/null @@ -1,38 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.SMTEncoding.ErrorReporting -open FStar.Compiler.Effect -open FStar -open FStar.Compiler -open FStar.BaseTypes -open FStar.Compiler.Util -open FStar.SMTEncoding.Term -open FStar.SMTEncoding.Util -open FStar.SMTEncoding -open FStar.Compiler.Range -module BU = FStar.Compiler.Util - -type label = error_label -type labels = list label - -val label_goals : option (unit -> string) -> range -> q:term -> labels & term - -val detail_errors : bool //detail_hint_replay? - -> TypeChecker.Env.env - -> labels - -> (list decl -> Z3.z3result) - -> unit diff --git a/src/smtencoding/FStar.SMTEncoding.Pruning.fst b/src/smtencoding/FStar.SMTEncoding.Pruning.fst deleted file mode 100644 index b58bcfc7f73..00000000000 --- a/src/smtencoding/FStar.SMTEncoding.Pruning.fst +++ /dev/null @@ -1,468 +0,0 @@ -(* - Copyright 2024 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.SMTEncoding.Pruning -open FStar.Compiler.Effect -open FStar -open FStar.List.Tot -open FStar.Compiler -open FStar.SMTEncoding.Term -open FStar.Class.Setlike -open FStar.Class.Show -open FStar.Class.Monad -module BU = FStar.Compiler.Util -type triggers = list (list string) -type triggers_set = list (RBSet.t string) - -let triggers_as_triggers_set (ts:triggers) : triggers_set = List.map from_list ts - -type pruning_state = { - //A macro is a (define-fun f ... (body)); Maps macro name 'f' to the free names of its body - macro_freenames: BU.psmap (list string); - // Maps trigger symbols to assumptions that have triggers that mention that symbol - // E.g., given `A : forall x. {:pattern (p x; q x) \/ (p' x; q' x)} R` - // trigger_to_assumption maps p -> A, q -> A, p' -> A, q' -> A - trigger_to_assumption: BU.psmap (list assumption); - // Maps assumption name to triggers that "waiting" on it - // E.g., in the example above, assumption_to_trigger contains A -> [[p;q]; [p';q']] - assumption_to_triggers: BU.psmap triggers_set; - // Maps assumption names to the assumptions themselves - assumption_name_map: BU.psmap decl; - //assumptions with no triggers that will always included - ambients: list string; - //extra roots that will be added to the initial set of roots - extra_roots: list assumption -} - -let debug (f: unit -> unit) : unit = - if Options.Ext.get "debug_context_pruning" <> "" - then f() - -let print_pruning_state (p:pruning_state) -: string -= let t_to_a = - BU.psmap_fold - p.trigger_to_assumption - (fun k v (acc:list (string & int)) -> (k, List.length v) :: acc) - [] - in - let t_to_a = BU.sort_with (fun x y -> snd x - snd y) t_to_a in - let a_to_t = - BU.psmap_fold - p.assumption_to_triggers - (fun k v acc -> - BU.format2 "[%s -> %s]" - k - (show v) :: acc) - [] - in - let macros = - BU.psmap_fold - p.macro_freenames - (fun k v acc -> - BU.format2 "[%s -> %s]" - k - (show v) :: acc) - [] - in - BU.format3 "Pruning state:\n\tTriggers to assumptions:\n\t%s\nAssumptions to triggers:\n\t%s\nMacros:\n\t%s\n" - (String.concat "\n\t" (List.map show t_to_a)) - (String.concat "\n\t" a_to_t) - (String.concat "\n\t" macros) - -instance show_pruning_state: showable pruning_state = { show = print_pruning_state } - -(* Initial state: everything is empty *) -let init -: pruning_state -= { macro_freenames = BU.psmap_empty (); - trigger_to_assumption = BU.psmap_empty (); - assumption_to_triggers = BU.psmap_empty (); - assumption_name_map = BU.psmap_empty (); - ambients=[]; - extra_roots=[] } - -(* Add: trig -> a*) -let add_trigger_to_assumption (a:assumption) (p:pruning_state) (trig:string) -: pruning_state -= match BU.psmap_try_find p.trigger_to_assumption trig with - | None -> - { p with trigger_to_assumption = BU.psmap_add p.trigger_to_assumption trig [a] } - | Some l -> { p with trigger_to_assumption = BU.psmap_add p.trigger_to_assumption trig (a::l) } - -// Names that are excluded from the set of free names -// Since they are very common and are not useful to scan as triggers -let exclude_names : RBSet.t string = - from_list [ - "SFuel"; - "ZFuel"; - "HasType"; - "HasTypeZ"; - "HasTypeFuel"; - "Valid"; - "ApplyTT"; - "ApplyTF"; - "Prims.lex_t" - ] - -let free_top_level_names t = diff (Term.free_top_level_names t) exclude_names -let assumption_free_names a = diff a.assumption_free_names exclude_names - -(* Triggers of a universally quantified term *) -let triggers_of_term (t:term) -: triggers_set -= let rec aux (t:term) = - match t.tm with - | Quant(Forall, triggers, _, _, _) -> - triggers |> List.map (fun disjunct -> - disjunct |> List.fold_left (fun out t -> union out (free_top_level_names t)) (empty())) - | Labeled (t, _, _) - | LblPos (t, _) -> aux t - | _ -> [] - in aux t - -(* This function has lots of special cases for F*'s SMT encoding, - particularly its handling of top-level non-quantified assumptions. - - One quirk to note here, that we should probably fix in the SMT encoding - itself: - - - Applications of nullary functions are sometimes encoded as - App(Var "name", []) and sometiems as FreeV(FV("name", _, _)) -*) -let maybe_add_ambient (a:assumption) (p:pruning_state) -: pruning_state -= let add_assumption_with_triggers (triggers:triggers_set) = - (* associate the triggers with the assumption in both directions *) - let p = - { p with - assumption_to_triggers= - BU.psmap_add p.assumption_to_triggers a.assumption_name triggers} - in - List.fold_left (List.fold_left (add_trigger_to_assumption a)) p (List.map elems triggers) - in - let is_empty triggers = - match triggers with - | [] -> true - | [t] -> is_empty t - | _ -> false - in - let is_ambient_refinement ty = - match ty.tm with - | App(Var "Prims.squash", _) -> true - | App(Var name, _) - | FreeV(FV(name, _, _)) -> BU.starts_with name "Tm_refine_" - | _ -> false - in - let ambient_refinement_payload ty = - match ty.tm with - | App(Var "Prims.squash", [t]) -> t - | _ -> ty - in - begin - match a.assumption_term.tm with - // - The top-level assumption `function_token_typing_Prims.__cache_version_number__` - // is always included in the pruned set, since it provides an inhabitation proof - // for int which some proofs rely on - | _ when a.assumption_name = "function_token_typing_Prims.__cache_version_number__" -> - { p with ambients = a.assumption_name::p.ambients } - - // - l_quant_interp assumptions give interpretations to deeply embedded quantifiers - // and have a specific shape of an Iff, where the LHS has a pattern, if the - // user annotated one. - | App(Iff, [t0; t1]) when BU.starts_with a.assumption_name "l_quant_interp" -> ( - let triggers_lhs = free_top_level_names t0 in - add_assumption_with_triggers [triggers_lhs] - ) - - // - Top-level `assume A : t` facts in F* are encoded as "assumption_" named - // declarations, handled similarly to squash and Tm_refine_ assumptions. - | _ when BU.starts_with a.assumption_name "assumption_" -> ( - let triggers = triggers_of_term a.assumption_term in - if is_empty triggers - then ( - let triggers = [free_top_level_names a.assumption_term] in - add_assumption_with_triggers triggers - ) - else - add_assumption_with_triggers triggers - ) - - // - Top-level assumptions of the form `HasType term (squash ty)` - // or `HasType term (Tm_refine_... )` are deemed ambient and are - // always included in the pruned set and added as extra roots. - | App (Var "HasType", [term; ty]) - when is_ambient_refinement ty -> ( - //HasType term (squash ty) is an ambient that should trigger on either the term or the type - let triggers = triggers_of_term (ambient_refinement_payload ty) in - if is_empty triggers - then { p with ambients = a.assumption_name::p.ambients; - extra_roots = a::p.extra_roots } - else add_assumption_with_triggers triggers - ) - - // - Partial applications are triggered with a __uu__PartialApp token; this is - // triggered on either the symbol itself or its nullary token - | App (Var "Valid", - [{tm=App (Var "ApplyTT", [{tm=FreeV (FV("__uu__PartialApp", _, _))}; term])}]) - | App (Var "Valid", - [{tm=App (Var "ApplyTT", [{tm=App(Var "__uu__PartialApp", _)}; term])}]) -> - let triggers = - match term.tm with - | FreeV(FV(token, _, _)) - | App(Var token, []) -> - if BU.ends_with token "@tok" - then [singleton token; singleton (BU.substring token 0 (String.length token - 4))] - else [singleton token] - | _ -> - [] - in - add_assumption_with_triggers triggers - - // HasType, Valid, IsTotFun, and is-Tm_arrow are so common that we exclude them as triggers - // and instead only consider the free names of the underlying terms - | App (Var "Valid", [term]) - | App (Var "HasType", [term; _]) - | App (Var "IsTotFun", [term]) - | App (Var "is-Tm_arrow", [term]) -> - add_assumption_with_triggers [free_top_level_names term] - - // Term_constr_id assumptions trigger on the free names of the underlying term - | App (Eq, [ _; {tm=App (Var "Term_constr_id", [term])}]) -> - add_assumption_with_triggers [free_top_level_names term] - - // Descend into conjunctions and collect their triggers - // Fire if any of the conjuncts have triggers that fire - | App (And, tms) -> - let t1 = List.collect triggers_of_term tms in - add_assumption_with_triggers t1 - - // Assumptions named "equation_" are encodings of F* definitions and are - // equations oriented from left to right - | App (Eq, [t0; t1]) when BU.starts_with a.assumption_name "equation_" -> - let t0 = free_top_level_names t0 in - add_assumption_with_triggers [t0] - - // Other equations and bi-implications are bidirectional - | App (Iff, [t0; t1]) - | App (Eq, [t0; t1]) -> - let t0 = free_top_level_names t0 in - let t1 = free_top_level_names t1 in - add_assumption_with_triggers [t0; t1] - - // we get many vacuous True facts; just drop them - | App (TrueOp, _) -> p - - // Oterwise, add to ambients without scanning them further - | _ -> - { p with ambients = a.assumption_name::p.ambients } - end - -// Add an assumption to the pruning state -// If the assumption has triggers, add it to the trigger map -// Otherwise, use the custom logic for ambients -let add_assumption_to_triggers (a:assumption) (p:pruning_state) (trigs:triggers_set) -: pruning_state -= let p = { p with assumption_name_map = BU.psmap_add p.assumption_name_map a.assumption_name (Assume a) } in - match trigs with - | [] -> maybe_add_ambient a p - | _ -> { p with assumption_to_triggers = BU.psmap_add p.assumption_to_triggers a.assumption_name trigs } - -// Mark a trigger as reached; removing it from the trigger map -let trigger_reached (p:pruning_state) (trig:string) -: pruning_state -= { p with trigger_to_assumption = BU.psmap_remove p.trigger_to_assumption trig } - -// remove one trigger from waiting triggers of aname -// if aname now has an empty set of triggers, return true, marking it as reachable/eligible -let remove_trigger_for_assumption (p:pruning_state) (trig:string) (aname:string) -: pruning_state & bool -= match BU.psmap_try_find p.assumption_to_triggers aname with - | None -> - // debug (fun _ -> BU.print2 "Removing trigger %s for assumption %s---no assumption found\n" trig aname); - p, false - | Some l -> - let remaining_triggers = - l |> List.map (fun ts -> remove trig ts) - in - let eligible = BU.for_some is_empty remaining_triggers in - // debug (fun _ -> - // BU.print5 "Removing trigger %s for assumption %s---eligible? %s, original triggers %s, remaining triggers %s\n" - // trig aname (show eligible) (show l) (show remaining_triggers)); - { p with assumption_to_triggers = BU.psmap_add p.assumption_to_triggers aname remaining_triggers }, - eligible - -let rec assumptions_of_decl (d:decl) -: list assumption -= match d with - | Assume a -> [a] - | Module (_, ds) -> List.collect assumptions_of_decl ds - | d -> [] - -// Add a declaration to the pruning state, updating the trigger and assumption tables -// and macro tables -let rec add_decl (d:decl) (p:pruning_state) -: pruning_state -= match d with - | Assume a -> - let triggers = triggers_of_term a.assumption_term in - let p = List.fold_left (List.fold_left (add_trigger_to_assumption a)) p (List.map elems triggers) in - add_assumption_to_triggers a p triggers - | Module (_, ds) -> List.fold_left (fun p d -> add_decl d p) p ds - | DefineFun(macro, _, _, body, _) -> - let free_names = elems (free_top_level_names body) in - let p = { p with macro_freenames = BU.psmap_add p.macro_freenames macro free_names } in - p - | _ -> p - -let add_decls (ds:list decl) (p:pruning_state) -: pruning_state -= List.fold_left (fun p d -> add_decl d p) p ds - -let sym = string -let reached_assumption_names = FStar.Compiler.RBSet.rbset string - -// The main pruning algorithm is expresses as a state monad over the ctxt -type ctxt = { - p: pruning_state; - reached: reached_assumption_names; -} -let st a = ctxt -> (a & ctxt) -let get : st ctxt = fun s -> (s, s) -let put (c:ctxt) : st unit = fun _ -> ((), c) -instance st_monad: monad st = { - return= (fun (#a:Type) (x:a) -> (fun s -> (x, s)) <: st a); - ( let! ) = (fun (#a #b:Type) (m:st a) (f:a -> st b) (s:ctxt) -> - let (x, s) = m s in - f x s) -} - -// When a trigger as reached, mark it, removing it from the trigger map -let mark_trigger_reached (x:sym) -: st unit -= let! ctxt = get in - put {ctxt with p=trigger_reached ctxt.p x } - -// All assumptions that are waiting on a trigger -let find_assumptions_waiting_on_trigger (x:sym) -: st (list assumption) -= let! ctxt = get in - match BU.psmap_try_find ctxt.p.trigger_to_assumption x with - | None -> return [] - | Some l -> return l - -// Mark an assumption as reached, to include in the resulting pruned set -// Remove it from the assumption map, so that we don't scan it again -let reached_assumption (aname:string) -: st unit -= let! ctxt = get in - let p = { ctxt.p with assumption_to_triggers = BU.psmap_remove ctxt.p.assumption_to_triggers aname } in - put {ctxt with reached=add aname ctxt.reached } - -// Remove trigger x from assumption a, and return true if a is now eligible -let remove_trigger_for (trig:sym) (a:assumption) -: st bool -= let! ctxt = get in - let p, eligible = remove_trigger_for_assumption ctxt.p trig a.assumption_name in - put {ctxt with p} ;! - return eligible - -// Check if an assumption has already been reached -let already_reached (aname:string) -: st bool -= let! ctxt = get in - return (mem aname ctxt.reached) - -// All assumptions that are now eligible given lids are reached -let trigger_pending_assumptions (lids:list sym) -: st (list assumption) -= foldM_left - (fun acc lid -> - match! find_assumptions_waiting_on_trigger lid with - | [] -> return acc - | assumptions -> - // debug (fun _ -> BU.print2 "Found assumptions waiting on trigger %s: %s\n" lid (show <| List.map (fun a -> a.assumption_name) assumptions)); - mark_trigger_reached lid ;! - foldM_left - (fun acc assumption -> - if! remove_trigger_for lid assumption - then return (assumption::acc) - else return acc) - acc - assumptions) - [] - lids - -// The main scanning loop -let rec scan (ds:list assumption) -: st unit -= let! ctxt = get in - let macro_expand (s:sym) : list sym = - match BU.psmap_try_find ctxt.p.macro_freenames s with - | None -> [s] - | Some l -> s::l - in - // Collect the free names of all assumptions and macro expand them - let new_syms = List.collect (fun a -> List.collect macro_expand (elems (assumption_free_names a))) ds in - // debug (fun _ -> - // BU.print1 ">>>Scanning %s\n" - // (ds |> List.map (fun a -> BU.format2 "%s -> [%s]" a.assumption_name (elems (assumption_free_names a) |> show)) |> String.concat "\n\t")); - - // Trigger all assumptions that are waiting on the new symbols - match! trigger_pending_assumptions new_syms with - | [] -> - // Done if no new assumptions are eligible - return () - | triggered -> - // Otherwise, mark them as reached, and scan them - let! to_scan = - foldM_left - (fun acc assumption -> - if! already_reached assumption.assumption_name - then return acc - else ( - reached_assumption assumption.assumption_name ;! - return <| assumption::acc - )) - [] - triggered - in - scan to_scan - - -let prune (p:pruning_state) (roots:list decl) -: list decl -= // debug (fun _ -> BU.print_string (show p)); - // Collect all assumptions from the roots - let roots = List.collect assumptions_of_decl roots in - let init = { p; reached = empty () } in - // Scan to find all reachable assumptions - let _, ctxt = scan (roots@p.extra_roots) init in - // Collect their names - let reached_names = elems ctxt.reached in - // Map them to assumptions, together with ambients - let reached_assumptions = - List.collect - (fun name -> - match BU.psmap_try_find ctxt.p.assumption_name_map name with - | None -> [] - | Some a -> [a]) - (reached_names@p.ambients) - in - // if Options.Ext.get "debug_context_pruning" <> "" - // then ( - // BU.print1 "Retained %s assumptions\n" (show (List.length reached_assumptions)) - // ); - reached_assumptions \ No newline at end of file diff --git a/src/smtencoding/FStar.SMTEncoding.Pruning.fsti b/src/smtencoding/FStar.SMTEncoding.Pruning.fsti deleted file mode 100644 index 9405cb61b1e..00000000000 --- a/src/smtencoding/FStar.SMTEncoding.Pruning.fsti +++ /dev/null @@ -1,62 +0,0 @@ -(* - Copyright 2024 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.SMTEncoding.Pruning -(** - This module provides support for the '--ext context_pruning' feature. - - It maintains a `pruning_state`, a collection of SMT assumptions. - - Given a set of root SMT declarations, it computes the set of assumptions - "reacahable" from those roots, i.e., computing a pruning of the state to only - include the facts that are relevant to the roots. - - The way this works, roughly, is as following: - - The set of all reachable symbols is initially all the free variables of the - roots and the pruned set is empty. - - A given assumption in the context is a quantified fact of the form: - - A: forall x1...xn. {:pattern (p1; ...; pk)} Q - - This assumption A is reachable if all the free variables of the patterns - (p1;...;pk) are reachable. If so, then the free variables of Q are added to - the set of reachable symbols, A is added to the pruned set, and the process is - repeated until fixpoint, returning the pruned set. - - Enhancements to this basic idea support - - quantifiers with disjunctive patterns - - top-level non-quantified facts - - macros - - and some features that are specific to F*'s SMT encoding - - Thanks to Chris Hawblitzel and Guido Martínez for design and discussions. -*) -open FStar.Compiler.Effect -open FStar -open FStar.Compiler -open FStar.SMTEncoding.Term - -(* The main abstract type of this module, representing the set of all assumptions *) -val pruning_state : Type0 - -val init : pruning_state - -(* Adding assumptions to the pruning state *) -val add_decls (ds:list decl) (p:pruning_state) : pruning_state - -(* Pruning the state to only include the assumptions that are reachable from the roots *) -val prune (p:pruning_state) (roots:list decl) : list decl \ No newline at end of file diff --git a/src/smtencoding/FStar.SMTEncoding.Solver.Cache.fst b/src/smtencoding/FStar.SMTEncoding.Solver.Cache.fst deleted file mode 100644 index da72bdb3c7d..00000000000 --- a/src/smtencoding/FStar.SMTEncoding.Solver.Cache.fst +++ /dev/null @@ -1,160 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.SMTEncoding.Solver.Cache - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.TypeChecker.Env -open FStar.Syntax.Syntax - -module BU = FStar.Compiler.Util -open FStar.Compiler.RBSet - -open FStar.Class.Show -open FStar.Class.Hashable - -(* import instances *) -open FStar.Syntax.Hash {} - -instance hashable_lident : hashable Ident.lident = { - hash = (fun l -> hash (show l)); -} - -instance hashable_ident : hashable Ident.ident = { - hash = (fun i -> hash (show i)); -} - -instance hashable_binding : hashable binding = { - hash = (function - | Binding_var bv -> hash bv.sort - | Binding_lid (l, (us, t)) -> hash l `mix` hash us `mix` hash t - | Binding_univ u -> hash u); -} - -instance hashable_bv : hashable bv = { - // hash name? - hash = (fun b -> hash b.sort); -} - -instance hashable_fv : hashable fv = { - hash = (fun f -> hash f.fv_name.v); -} - -instance hashable_binder : hashable binder = { - hash = (fun b -> hash b.binder_bv); -} - -instance hashable_letbinding : hashable letbinding = { - hash = (fun lb -> hash lb.lbname `mix` hash lb.lbtyp `mix` hash lb.lbdef); -} - -instance hashable_pragma : hashable pragma = { - hash = (function - | SetOptions s -> hash 1 `mix` hash s - | ResetOptions s -> hash 2 `mix` hash s - | PushOptions s -> hash 3 `mix` hash s - | PopOptions -> hash 4 - | RestartSolver -> hash 5 - | PrintEffectsGraph -> hash 6); -} - -let rec hash_sigelt (se:sigelt) : hash_code = - hash_sigelt' se.sigel - -and hash_sigelt' (se:sigelt') : hash_code = - match se with - | Sig_inductive_typ {lid; us; params; num_uniform_params; t; mutuals; ds; injective_type_params} -> - hash 0 `mix` - hash lid `mix` - hash us `mix` - hash params `mix` - hash num_uniform_params `mix` - hash t `mix` - hash mutuals `mix` - hash ds `mix` - hash injective_type_params - | Sig_bundle {ses; lids} -> - hash 1 `mix` - (hashable_list #_ {hash=hash_sigelt}).hash ses // sigh, reusing hashable instance when we don't have an instance - `mix` hash lids - | Sig_datacon {lid; us; t; ty_lid; num_ty_params; mutuals; injective_type_params} -> - hash 2 `mix` - hash lid `mix` - hash us `mix` - hash t `mix` - hash ty_lid `mix` - hash num_ty_params `mix` - hash mutuals `mix` - hash injective_type_params - | Sig_declare_typ {lid; us; t} -> - hash 3 `mix` - hash lid `mix` - hash us `mix` - hash t - | Sig_let {lbs; lids} -> - hash 4 `mix` - hash lbs `mix` - hash lids - | Sig_assume {lid; us; phi} -> - hash 5 `mix` - hash lid `mix` - hash us `mix` - hash phi - | Sig_pragma p -> - hash 6 `mix` - hash p - | _ -> - (* FIXME: hash is not completely faithful. In particular - it ignores effect decls and hashes them the same. *) - hash 0 - -instance hashable_sigelt : hashable sigelt = { - hash = hash_sigelt; -} - -(* All that matters for the query cache. *) -instance hashable_env : hashable env = { - hash = (fun e -> - hash e.gamma `mix` - hash e.gamma_sig `mix` - hash e.proof_ns `mix` - hash e.admit - ); -} - -let query_cache_ref : ref (RBSet.t hash_code) = - BU.mk_ref (empty ()) - -let on () = - Options.query_cache () && Options.ide () - -let query_cache_add (g:env) (q:term) : unit = - if on () then ( - let h = hash (g, q) in -// BU.print1 "Adding query cache for %s\n" (show h); - query_cache_ref := add h !query_cache_ref - ) - -let try_find_query_cache (g:env) (q:term) : bool = - if on () then ( - let h = hash (g, q) in - let r = mem h !query_cache_ref in -// BU.print2 "Looked up query cache for %s, r = %s\n" (show h) (show r); - r - ) else - false diff --git a/src/smtencoding/FStar.SMTEncoding.Solver.Cache.fsti b/src/smtencoding/FStar.SMTEncoding.Solver.Cache.fsti deleted file mode 100644 index bbf309847e9..00000000000 --- a/src/smtencoding/FStar.SMTEncoding.Solver.Cache.fsti +++ /dev/null @@ -1,26 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.SMTEncoding.Solver.Cache - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.TypeChecker.Env -open FStar.Syntax.Syntax - -val query_cache_add (g:env) (q:term) : unit -val try_find_query_cache (g:env) (q:term) : bool diff --git a/src/smtencoding/FStar.SMTEncoding.Solver.fst b/src/smtencoding/FStar.SMTEncoding.Solver.fst deleted file mode 100644 index 11506321cde..00000000000 --- a/src/smtencoding/FStar.SMTEncoding.Solver.fst +++ /dev/null @@ -1,1486 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.SMTEncoding.Solver -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.SMTEncoding.Z3 -open FStar.SMTEncoding.Term -open FStar.Compiler.Util -open FStar.Compiler.Hints -open FStar.TypeChecker -open FStar.TypeChecker.Env -open FStar.SMTEncoding -open FStar.SMTEncoding.ErrorReporting -open FStar.SMTEncoding.Util -open FStar.SMTEncoding.Env -open FStar.Class.Show -open FStar.Class.PP -open FStar.Class.Hashable -open FStar.Compiler.RBSet - -module BU = FStar.Compiler.Util -module Env = FStar.TypeChecker.Env -module Err = FStar.Errors -module Print = FStar.Syntax.Print -module Syntax = FStar.Syntax.Syntax -module TcUtil = FStar.TypeChecker.Util -module U = FStar.Syntax.Util -module UC = FStar.SMTEncoding.UnsatCore -exception SplitQueryAndRetry - -let dbg_SMTQuery = Debug.get_toggle "SMTQuery" -let dbg_SMTFail = Debug.get_toggle "SMTFail" - -(****************************************************************************) -(* Hint databases for record and replay (private) *) -(****************************************************************************) - -// The type definition is now in [FStar.Compiler.Util], since it needs to be visible to -// both the F# and OCaml implementations. - -type z3_replay_result = either (option UC.unsat_core), error_labels -let z3_result_as_replay_result = function - | Inl l -> Inl l - | Inr (r, _) -> Inr r -let recorded_hints : ref (option hints) = BU.mk_ref None -let replaying_hints: ref (option hints) = BU.mk_ref None - -(****************************************************************************) -(* Hint databases (public) *) -(****************************************************************************) -let use_hints () = Options.use_hints () && Options.Ext.get "context_pruning" = "" -let initialize_hints_db src_filename format_filename : unit = - if Options.record_hints() then recorded_hints := Some []; - let norm_src_filename = BU.normalize_file_path src_filename in - (* - * Read the hints file into replaying_hints - * But it will only be used when use_hints is on - *) - let val_filename = Options.hint_file_for_src norm_src_filename in - begin match read_hints val_filename with - | HintsOK hints -> - let expected_digest = BU.digest_of_file norm_src_filename in - if Options.hint_info() - then begin - BU.print3 "(%s) digest is %s from %s.\n" norm_src_filename - (if hints.module_digest = expected_digest - then "valid; using hints" - else "invalid; using potentially stale hints") - val_filename - end; - replaying_hints := Some hints.hints - - | MalformedJson -> - if use_hints () then - Err.log_issue0 Err.Warning_CouldNotReadHints [ - Errors.Msg.text <| BU.format1 "Malformed JSON hints file: %s; ran without hints" - val_filename - ]; - () - - | UnableToOpen -> - if use_hints () then - Err.log_issue0 Err.Warning_CouldNotReadHints [ - Errors.Msg.text <| BU.format1 "Unable to open hints file: %s; ran without hints" - val_filename - ]; - () - end - -let finalize_hints_db src_filename :unit = - begin if Options.record_hints () then - let hints = Option.get !recorded_hints in - let hints_db = { - module_digest = BU.digest_of_file src_filename; - hints = hints - } in - let norm_src_filename = BU.normalize_file_path src_filename in - let val_filename = Options.hint_file_for_src norm_src_filename in - write_hints val_filename hints_db - end; - recorded_hints := None; - replaying_hints := None - -let with_hints_db fname f = - initialize_hints_db fname false; - let result = f () in - // for the moment, there should be no need to trap exceptions to finalize the hints db - // no cleanup needs to occur if an error occurs. - finalize_hints_db fname; - result - -(***********************************************************************************) -(* Invoking the SMT solver and extracting an error report from the model, if any *) -(***********************************************************************************) -type errors = { - error_reason:string; - error_rlimit: int; - error_fuel: int; - error_ifuel: int; - error_hint: option (list string); - error_messages: list Errors.error; -} - -let error_to_short_string err = - BU.format5 "%s (rlimit=%s; fuel=%s; ifuel=%s%s)" - err.error_reason - (show err.error_rlimit) - (show err.error_fuel) - (show err.error_ifuel) - (if Option.isSome err.error_hint then "; with hint" else "") - -let error_to_is_timeout err = - if BU.ends_with err.error_reason "canceled" - then [BU.format5 "timeout (rlimit=%s; fuel=%s; ifuel=%s; %s)" - err.error_reason - (show err.error_rlimit) - (show err.error_fuel) - (show err.error_ifuel) - (if Option.isSome err.error_hint then "with hint" else "")] - else [] - -type query_settings = { - query_env:env_t; - query_decl:decl; - query_name:string; - query_index:int; - query_range:Range.range; - query_fuel:int; - query_ifuel:int; - query_rlimit:int; - query_hint:option UC.unsat_core; - query_errors:list errors; - query_all_labels:error_labels; - query_suffix:list decl; - query_hash:option string; - query_can_be_split_and_retried:bool; - query_term: FStar.Syntax.Syntax.term; -} - -(* Translation from F* rlimit units to Z3 rlimit units. - -This used to be defined as exactly 544656 since that roughtly -corresponded to 5 seconds in some "blessed" setting. But rlimit units -are only very roughly correlated to time, and having this very non-round -number makes reading SMT query dumps pretty confusing. So, for new -solvers, we now just make it 500k. *) -let convert_rlimit (r : int) : int = - let open FStar.Mul in - if Misc.version_ge (Options.z3_version ()) "4.12.3" then - 500000 * r - else - 544656 * r - -//surround the query with fuel options and various diagnostics -let with_fuel_and_diagnostics settings label_assumptions = - let n = settings.query_fuel in - let i = settings.query_ifuel in - let rlimit = convert_rlimit settings.query_rlimit in - [ //fuel and ifuel settings - Term.Caption (BU.format2 "" - (string_of_int n) - (string_of_int i)); - Util.mkAssume(mkEq(mkApp("MaxFuel", []), n_fuel n), None, "@MaxFuel_assumption"); - Util.mkAssume(mkEq(mkApp("MaxIFuel", []), n_fuel i), None, "@MaxIFuel_assumption"); - settings.query_decl //the query itself - ] - @label_assumptions //the sub-goals that are currently disabled - @[ Term.SetOption ("rlimit", string_of_int rlimit); //the rlimit setting for the check-sat - Term.CheckSat; //go Z3! - Term.SetOption ("rlimit", "0"); //back to using infinite rlimit - Term.GetReasonUnknown; //explain why it failed - Term.GetUnsatCore; //for proof profiling, recording hints etc - ] - @(if (Options.print_z3_statistics() || - Options.query_stats ()) then [Term.GetStatistics] else []) //stats - @settings.query_suffix //recover error labels and a final "Done!" message - - -let used_hint s = Option.isSome s.query_hint - -let get_hint_for qname qindex = - match !replaying_hints with - | Some hints -> - BU.find_map hints (function - | Some hint when hint.hint_name=qname && hint.hint_index=qindex -> Some hint - | _ -> None) - | _ -> None - -let query_errors settings z3result = - match z3result.z3result_status with - | UNSAT _ -> None - | _ -> - let msg, error_labels = Z3.status_string_and_errors z3result.z3result_status in - let err = { - error_reason = msg; - error_rlimit = settings.query_rlimit; - error_fuel = settings.query_fuel; - error_ifuel = settings.query_ifuel; - error_hint = settings.query_hint; - error_messages = - error_labels |> - List.map (fun (_, x, y) -> Errors.Error_Z3SolverError, - x, - y, - Errors.get_ctx ()) // FIXME: leaking abstraction - } - in - Some err - -let detail_hint_replay settings z3result = - if used_hint settings - && Options.detail_hint_replay () - then match z3result.z3result_status with - | UNSAT _ -> () - | _failed -> - let ask_z3 label_assumptions = - Z3.ask settings.query_range - // (filter_assertions settings.query_env (Some settings) settings.query_hint) - settings.query_hash - settings.query_all_labels - (with_fuel_and_diagnostics settings label_assumptions) - (BU.format2 "(%s, %s)" settings.query_name (string_of_int settings.query_index)) - false - None - // settings.query_hint - in - detail_errors true settings.query_env.tcenv settings.query_all_labels ask_z3 - -let find_localized_errors (errs : list errors) : option errors = - errs |> List.tryFind (fun err -> match err.error_messages with [] -> false | _ -> true) - -let errors_to_report (tried_recovery : bool) (settings : query_settings) : list Errors.error = - let open FStar.Pprint in - let open FStar.Errors in - let format_smt_error (msg:list document) : list document = - (* This creates an error component with the answers from Z3. Only used - for --query_stats. *) - let d = - doc_of_string "SMT solver says:" ^^ - sublist empty msg ^^ - hardline ^^ - doc_of_string "Note:" ^^ - bulleted [ - text "'canceled' or 'resource limits reached' means the SMT query timed out, so you might want to increase the rlimit"; - text "'incomplete quantifiers' means Z3 could not prove the query, so try to spell out your proof out in greater detail, increase fuel or ifuel"; - text "'unknown' means Z3 provided no further reason for the proof failing" - ] - in - [d] // single error component - in - let recovery_failed_msg : Errors.error_message = - if tried_recovery then - [text "This query was retried due to the --proof_recovery option, yet it - still failed on all attempts."] - else - [] - in - let basic_errors = - (* - * smt_error is a single error message containing either a multi-line detailed message - * or a single short component, depending on whether --query_stats is on - *) - let smt_error = - if Options.query_stats () then - settings.query_errors - |> List.map error_to_short_string - |> List.map doc_of_string - |> format_smt_error - else - (* - * AR: --query_stats is not set, we want to give a succint but helpful diagnosis - * - * settings.query_errors is a list of errors, whose field error_reason contains the strings: - * unknown because (incomplete ...) or unknown because (resource ...) or unknown because canceled etc. - * it's a list as it contains one element per config (e.g. fuel options) - * - * in the following code we go through the error reasons in all the configs, - * and if all the error reasons are the same, we provide a hint for that reason - * otherwise we just ask the user to run with --query_stats - * - * as per the smt-lib standard, the possible values of reason-unknown are s-expressions, - * that are either non-space strings, or strings with spaces enclosed in parenthesis - * (I think), so incomplete or resource messages are in parenthesis, whereas - * canceled, timeout, etc. are without - *) - let incomplete_count, canceled_count, unknown_count, z3_overflow_bug_count = - List.fold_left (fun (ic, cc, uc, bc) err -> - let err = BU.substring_from err.error_reason (String.length "unknown because ") in - //err is (incomplete quantifiers), (resource ...), canceled, or unknown etc. - - match () with - | _ when BU.starts_with err "(incomplete" -> - (ic + 1, cc, uc, bc) - | _ when BU.starts_with err "canceled" || BU.starts_with err "(resource" || BU.starts_with err "timeout" -> - (ic, cc + 1, uc, bc) - | _ when BU.starts_with err "Overflow encountered when expanding old_vector" -> - (ic, cc, uc, bc + 1) - | _ -> - (ic, cc, uc + 1, bc) //note this covers unknowns, overflows, etc. - ) (0, 0, 0, 0) settings.query_errors - in - (* If we notice the z3 overflow bug, add a separate error to warn the user. *) - if z3_overflow_bug_count > 0 then - Errors.log_issue settings.query_range Errors.Warning_UnexpectedZ3Stderr [ - text "Z3 ran into an internal overflow while trying to prove this query."; - text "Try breaking it down, or using --split_queries." - ]; - let base = - match incomplete_count, canceled_count, unknown_count with - | _, 0, 0 when incomplete_count > 0 -> [text "The SMT solver could not prove the query. Use --query_stats for more details."] - | 0, _, 0 when canceled_count > 0 -> [text "The SMT query timed out, you might want to increase the rlimit"] - | _, _, _ -> [text "Try with --query_stats to get more details"] - in - base @ recovery_failed_msg - in - match find_localized_errors settings.query_errors, settings.query_all_labels with - | Some err, _ -> - // FStar.Errors.log_issue settings.query_range (FStar.Errors.Warning_SMTErrorReason, smt_error); - FStar.TypeChecker.Err.errors_smt_detail settings.query_env.tcenv err.error_messages smt_error - - | None, [(_, msg, rng)] -> - //we have a unique label already; just report it - FStar.TypeChecker.Err.errors_smt_detail - settings.query_env.tcenv - [(Error_Z3SolverError, msg, rng, get_ctx())] - recovery_failed_msg - - | None, _ -> - //We didn't get a useful countermodel from Z3 to localize an error - //so, split the query into N unique queries and try again - if settings.query_can_be_split_and_retried - then raise SplitQueryAndRetry - else ( - //if it can't be split further, report all its labels as potential failures - //typically there will be only 1 label - let l = List.length settings.query_all_labels in - let labels = - if l = 0 - then ( - //this should really never happen, but if it does, we have a query - //with no labeled sub-goals and so no error location to report. - //So, print the source location and the query term itself - let dummy_fv = Term.mk_fv ("", dummy_sort) in - let msg = [ - Errors.Msg.text "Failed to prove the following goal, although it appears to be trivial:" - ^/^ pp settings.query_term; - ] - in - let range = Env.get_range settings.query_env.tcenv in - [dummy_fv, msg, range] - ) - else if l > 1 - then ( - //we have a non-unique label despite splitting - //this CAN happen, e.g., if the original query term is a `match` - //In this case, we couldn't split it and then if it fails without producing a model, - //we blame all the labels in the query. So warn about the imprecision, unless the - //use opted into --split_queries no. - if Options.split_queries () <> Options.No then - FStar.TypeChecker.Err.log_issue_text - settings.query_env.tcenv - (Env.get_range settings.query_env.tcenv) - (Warning_SplitAndRetryQueries, - "The verification condition was to be split into several atomic sub-goals, \ - but this query has multiple sub-goals---the error report may be inaccurate"); - settings.query_all_labels - ) - else settings.query_all_labels - in - labels |> - List.collect (fun (_, msg, rng) -> - FStar.TypeChecker.Err.errors_smt_detail - settings.query_env.tcenv - [(Error_Z3SolverError, msg, rng, get_ctx())] - recovery_failed_msg - ) - ) - in - let detailed_errors : unit = - if Options.detail_errors() - then let initial_fuel = { - settings with query_fuel=Options.initial_fuel(); - query_ifuel=Options.initial_ifuel(); - query_hint=None - } - in - let ask_z3 label_assumptions = - Z3.ask settings.query_range - // (filter_using_facts_from settings.query_env settings.query_pruned_context) - settings.query_hash - settings.query_all_labels - (with_fuel_and_diagnostics initial_fuel label_assumptions) - (BU.format2 "(%s, %s)" settings.query_name (string_of_int settings.query_index)) - false - None - in - (* GM: This is a bit of hack, we don't return these detailed errors - * (it implies rewriting detail_errors heavily). Returning them - * is only relevant for summarizing errors on --quake, where I don't - * think we care about these. *) - detail_errors false settings.query_env.tcenv settings.query_all_labels ask_z3 - in - basic_errors - -let report_errors tried_recovery qry_settings = - FStar.Errors.add_errors (errors_to_report tried_recovery qry_settings) - - -type unique_string_accumulator = { - add: string -> unit; - get: unit -> list string; - clear: unit -> unit -} - -(* A generic accumulator of unique strings, - extracted in sorted order *) -let mk_unique_string_accumulator () -: unique_string_accumulator -= let strings = BU.mk_ref [] in - let add m = - let ms = !strings in - if List.contains m ms then () - else strings := m :: ms - in - let get () = - !strings |> BU.sort_with String.compare - in - let clear () = strings := [] in - { add ; get; clear } - -let query_info settings z3result = - let process_unsat_core (core:option UC.unsat_core) = - (* Accumulator for module names *) - let { add=add_module_name; get=get_module_names } = - mk_unique_string_accumulator () - in - let add_module_name s = - add_module_name s - in - (* Accumulator for discarded names *) - let { add=add_discarded_name; get=get_discarded_names } = - mk_unique_string_accumulator () - in - (* SMT Axioms are named using an ad hoc naming convention - that includes the F* source name within it. - - This function reversed the naming convention to extract - the source name of the F* entity from `s`, an axiom name - mentioned in an unsat core (but also in smt.qi.profile, etc.) - - The basic structure of the name is - - - - So, the code below strips off the - and any of the reserved suffixes. - - What's left is an F* name, which can be decomposed as usual - into a module name + a top-level identifier - *) - let parse_axiom_name (s:string) = - // BU.print1 "Parsing axiom name <%s>\n" s; - let chars = String.list_of_string s in - let first_upper_index = - BU.try_find_index BU.is_upper chars - in - match first_upper_index with - | None -> - //Has no embedded F* name (discard it, and record it in the discarded set) - add_discarded_name s; - [] - | Some first_upper_index -> - let name_and_suffix = BU.substring_from s first_upper_index in - let components = String.split ['.'] name_and_suffix in - let excluded_suffixes = - [ "fuel_instrumented"; - "_pretyping"; - "_Tm_refine"; - "_Tm_abs"; - "@"; - "_interpretation_Tm_arrow"; - "MaxFuel_assumption"; - "MaxIFuel_assumption"; - ] - in - let exclude_suffix s = - let s = BU.trim_string s in - let sopt = - BU.find_map - excluded_suffixes - (fun sfx -> - if BU.contains s sfx - then Some (List.hd (BU.split s sfx)) - else None) - in - match sopt with - | None -> if s = "" then [] else [s] - | Some s -> if s = "" then [] else [s] - in - let components = - match components with - | [] -> [] - | _ -> - let lident, last = BU.prefix components in - let components = lident @ exclude_suffix last in - let module_name = components |> BU.prefix_until (fun s -> not <| BU.is_upper (BU.char_at s 0)) in - let _ = - match module_name with - | None -> () - | Some (m, _, _) -> add_module_name (String.concat "." m) - in - components - in - if components = [] - then (add_discarded_name s; []) - else [ components |> String.concat "."] - in - let should_log = Options.hint_info () || Options.query_stats () in - let maybe_log (f:unit -> unit) = if should_log then f () in - match core with - | None -> - maybe_log <| (fun _ -> BU.print_string "no unsat core\n") - | Some core -> - let core = List.collect parse_axiom_name core in - maybe_log <| (fun _ -> - BU.print1 "Z3 Proof Stats: Modules relevant to this proof:\nZ3 Proof Stats:\t%s\n" - (get_module_names() |> String.concat "\nZ3 Proof Stats:\t"); - BU.print1 "Z3 Proof Stats (Detail 1): Specifically:\nZ3 Proof Stats (Detail 1):\t%s\n" - (String.concat "\nZ3 Proof Stats (Detail 1):\t" core); - BU.print1 "Z3 Proof Stats (Detail 2): Note, this report ignored the following names in the context: %s\n" - (get_discarded_names() |> String.concat ", ")) - in - if Options.hint_info() - || Options.query_stats() - then begin - let status_string, errs = Z3.status_string_and_errors z3result.z3result_status in - let at_log_file = - match z3result.z3result_log_file with - | None -> "" - | Some s -> "@"^s - in - let tag, core = match z3result.z3result_status with - | UNSAT core -> BU.colorize_green "succeeded", core - | _ -> BU.colorize_red ("failed {reason-unknown=" ^ status_string ^ "}"), None - in - let range = "(" ^ show settings.query_range ^ at_log_file ^ ")" in - let used_hint_tag = if used_hint settings then " (with hint)" else "" in - let stats = - if Options.query_stats() then - let f k v a = a ^ k ^ "=" ^ v ^ " " in - let str = smap_fold z3result.z3result_statistics f "statistics={" in - (substring str 0 ((String.length str) - 1)) ^ "}" - else "" in - BU.print "%s\tQuery-stats (%s, %s)\t%s%s in %s milliseconds with fuel %s and ifuel %s and rlimit %s\n" - [ range; - settings.query_name; - show settings.query_index; - tag; - used_hint_tag; - show z3result.z3result_time; - show settings.query_fuel; - show settings.query_ifuel; - show (settings.query_rlimit); - // stats - ]; - if Options.print_z3_statistics () then process_unsat_core core; - errs |> List.iter (fun (_, msg, range) -> - let msg = if used_hint settings then Pprint.doc_of_string "Hint-replay failed" :: msg else msg in - FStar.Errors.log_issue range FStar.Errors.Warning_HitReplayFailed msg) - end - else if Options.Ext.get "profile_context" <> "" - then match z3result.z3result_status with - | UNSAT core -> process_unsat_core core - | _ -> () - -//caller must ensure that the recorded_hints is already initiailized -let store_hint hint = - match !recorded_hints with - | Some l -> recorded_hints := Some (l@[Some hint]) - | _ -> assert false; () - -let record_hint settings z3result = - if not (Options.record_hints()) then () else - begin - let mk_hint core = { - hint_name=settings.query_name; - hint_index=settings.query_index; - fuel=settings.query_fuel; - ifuel=settings.query_ifuel; - unsat_core=core; - query_elapsed_time=0; //recording the elapsed_time prevents us from reaching a fixed point - hash=(match z3result.z3result_status with - | UNSAT core -> z3result.z3result_query_hash - | _ -> None) - } - in - match z3result.z3result_status with - | UNSAT None -> - // we succeeded by just matching a query hash - store_hint (Option.get (get_hint_for settings.query_name settings.query_index)) - | UNSAT unsat_core -> - if used_hint settings //if we already successfully use a hint - then //just re-use the successful hint, but record the hash of the pruned theory - store_hint (mk_hint settings.query_hint) - else store_hint (mk_hint unsat_core) //else store the new unsat core - | _ -> () //the query failed, so nothing to do - end - -let process_result settings result : option errors = - let errs = query_errors settings result in - query_info settings result; - record_hint settings result; - detail_hint_replay settings result; - errs - -// Attempts to solve each query setting (in `qs`) sequentially until -// one succeeds. If one succeeds, we are done and report no errors. If -// all of them fail, we return the list of errors so they can be displayed -// to the user later. -// Returns Inr cfg if successful, with the succeeding config cfg -// and Inl errs if all options were exhausted -// without a success, where errs is the list of errors each query -// returned. -let fold_queries (qs:list query_settings) - (ask:query_settings -> z3result) - (f:query_settings -> z3result -> option errors) - : either (list errors) query_settings = - let rec aux (acc : list errors) qs : either (list errors) query_settings = - match qs with - | [] -> Inl acc - | q::qs -> - let res = ask q in - begin match f q res with - | None -> Inr q //done - | Some errs -> - aux (errs::acc) qs - end - in - aux [] qs - -let full_query_id settings = - "(" ^ settings.query_name ^ ", " ^ (BU.string_of_int settings.query_index) ^ ")" - -let collect_dups (l : list 'a) : list ('a & int) = - let acc : list ('a & int) = [] in - let rec add_one acc x = - match acc with - | [] -> [(x, 1)] - | (h, n)::t -> - if h = x - then (h, n+1)::t - else (h, n) :: add_one t x - in - List.fold_left add_one acc l - - -(* An answer for an "ask" to the solver. The ok boolean marks whether -it succeeded or not. The rest is only used for error reporting. *) -type answer = { - ok : bool; - (* ^ Query was proven *) - cache_hit : bool; - (* ^ Got result from cache. Currently, this also implies - ok=true (we don't cache failed queries), but don't count - on it. *) - - quaking : bool; - (* ^ Were we quake testing? *) - quaking_or_retrying : bool; - (* ^ Were we quake testing *or* retrying? *) - lo : int; - (* ^ Lower quake bound. *) - hi : int; - (* ^ Higher quake bound. *) - nsuccess : int; - (* ^ Number of successful attempts. Can be >1 when quaking. *) - total_ran : int; - (* ^ Total number of queries made. *) - tried_recovery : bool; - (* ^ Did we try using --proof_recovery for this? *) - - errs : list (list errors); // mmm... list list? - (* ^ Errors from SMT solver. *) -} - -let ans_ok : answer = { - ok = true; - cache_hit = false; - nsuccess = 1; - lo = 1; - hi = 1; - errs = []; - quaking = false; - quaking_or_retrying = false; - total_ran = 1; - tried_recovery = false; -} - -let ans_fail : answer = - { ans_ok with ok = false; nsuccess = 0 } - -instance _ : showable answer = { - show = (fun ans -> BU.format5 "ok=%s nsuccess=%s lo=%s hi=%s tried_recovery=%s" - (show ans.ok) - (show ans.nsuccess) - (show ans.lo) - (show ans.hi) - (show ans.tried_recovery)); -} - -let make_solver_configs - (can_split : bool) - (is_retry : bool) - (env : env_t) - (all_labels : error_labels) - // (prefix : list decl) - (query : decl) - (query_term : Syntax.term) - (suffix : list decl) - : (list query_settings & option hint) - = - (* Fetch the settings. *) - let default_settings, next_hint = - let qname, index = - match env.tcenv.qtbl_name_and_index with - | None, _ -> failwith "No query name set!" - | Some (q, _typ, n), _ -> Ident.string_of_lid q, n - in - let rlimit = - let open FStar.Mul in - Options.z3_rlimit_factor () * Options.z3_rlimit () - in - let next_hint = get_hint_for qname index in - let default_settings = { - query_env=env; - query_decl=query; - query_name=qname; - query_index=index; - query_range=Env.get_range env.tcenv; - query_fuel=Options.initial_fuel(); - query_ifuel=Options.initial_ifuel(); - query_rlimit=rlimit; - query_hint=None; - query_errors=[]; - query_all_labels=all_labels; - query_suffix=suffix; - query_hash=(match next_hint with - | None -> None - | Some {hash=h} -> h); - query_can_be_split_and_retried=can_split; - query_term=query_term; - } in - default_settings, next_hint - in - - (* Fetch hints, if any. *) - let use_hints_setting = - if use_hints () && next_hint |> is_some - then - let ({unsat_core=Some core; fuel=i; ifuel=j; hash=h}) = next_hint |> must in - [{default_settings with query_hint=Some core; - query_fuel=i; - query_ifuel=j}] - else [] - in - - let initial_fuel_max_ifuel = - if Options.max_ifuel() > Options.initial_ifuel() - then [{default_settings with query_ifuel=Options.max_ifuel()}] - else [] - in - - let half_max_fuel_max_ifuel = - if Options.max_fuel() / 2 > Options.initial_fuel() - then [{default_settings with query_fuel=Options.max_fuel() / 2; - query_ifuel=Options.max_ifuel()}] - else [] - in - - let max_fuel_max_ifuel = - if Options.max_fuel() > Options.initial_fuel() - && Options.max_ifuel() >= Options.initial_ifuel() - then [{default_settings with query_fuel=Options.max_fuel(); - query_ifuel=Options.max_ifuel()}] - else [] - in - let cfgs = - if is_retry - then [default_settings] - else - use_hints_setting - @ [default_settings] - @ initial_fuel_max_ifuel - @ half_max_fuel_max_ifuel - @ max_fuel_max_ifuel - in - (cfgs, next_hint) - -(* Returns Inl with errors, or Inr with the stats provided by the solver. -Not to be used directly, see ask_solver below. *) -let __ask_solver - (configs : list query_settings) - : either (list errors) query_settings - = - let check_one_config config : z3result = - if Options.z3_refresh() - then ( - Z3.refresh (Some config.query_env.tcenv.proof_ns) - ); - Z3.ask config.query_range - config.query_hash - config.query_all_labels - (with_fuel_and_diagnostics config []) - (BU.format2 "(%s, %s)" config.query_name (string_of_int config.query_index)) - (used_hint config) - config.query_hint - in - - fold_queries configs check_one_config process_result - -(* Ask a query to the solver, running it potentially multiple times -if --quake is specified. This function is always called, but when ---quake is off, it's really just a call to __ask_solver (and then -creating an [answer] record). *) -let ask_solver_quake - (configs : list query_settings) - : answer - = - let lo = Options.quake_lo () in - let hi = Options.quake_hi () in - let seed = Options.z3_seed () in - - let default_settings = List.hd configs in - let name = full_query_id default_settings in - let quaking = hi > 1 && not (Options.retry ()) in - let quaking_or_retrying = hi > 1 in - let hi = if hi < 1 then 1 else hi in - let lo = - if lo < 1 then 1 - else if lo > hi then hi - else lo - in - let run_one (seed:int) : either (list errors) query_settings = - (* Here's something annoying regarding --quake: - * - * In normal circumstances, we can just run the query again and get - * a slightly different behaviour because of Z3 accumulating some - * internal state that doesn't get erased on a (pop). So we simply repeat - * the query then. - * - * But, if we're doing --z3refresh, we will always get the exact - * same behaviour by doing that, so we do want to set the seed in this case. - * - * Why not always set it? Because it requires restarting the solver, which - * takes a long time. - * - * Why not use the (set-option smt.random_seed ..) command? Because - * it seems to have no effect just before a (check-sat), so it needs to be - * set early, which basically implies restarting. - * - * So we do this horrendous thing. - *) - if Options.z3_refresh () - then Options.with_saved_options (fun () -> - Options.set_option "z3seed" (Options.Int seed); - __ask_solver configs) - else __ask_solver configs - in - let rec fold_nat' (f : 'a -> int -> 'a) (acc : 'a) (lo : int) (hi : int) : 'a = - if lo > hi - then acc - else fold_nat' f (f acc lo) (lo + 1) hi - in - let best_fuel = BU.mk_ref None in - let best_ifuel = BU.mk_ref None in - let maybe_improve (r:ref (option int)) (n:int) : unit = - match !r with - | None -> r := Some n - | Some m -> if n < m then r := Some n - in - let nsuccess, nfailures, rs = - fold_nat' - (fun (nsucc, nfail, rs) n -> - if not (Options.quake_keep ()) - && (nsucc >= lo (* already have enough successes *) - || nfail > hi-lo) (* already have too many failures *) - then (nsucc, nfail, rs) - else begin - if quaking_or_retrying - && (Options.interactive () || Debug.any ()) (* only on emacs or when debugging *) - && n>0 then (* no need to print last *) - BU.print5 "%s: so far query %s %sfailed %s (%s runs remain)\n" - (if quaking then "Quake" else "Retry") - name - (if quaking then BU.format1 "succeeded %s times and " (string_of_int nsucc) else "") - (* ^ if --retrying, it does not make sense to print successes since - * they must be exactly 0 *) - (if quaking then string_of_int nfail else string_of_int nfail ^ " times") - (string_of_int (hi-n)); - let r = run_one (seed+n) in - let nsucc, nfail = - match r with - | Inr cfg -> - (* Maybe update best fuels that worked. *) - maybe_improve best_fuel cfg.query_fuel; - maybe_improve best_ifuel cfg.query_ifuel; - nsucc + 1, nfail - | _ -> nsucc, nfail+1 - in - (nsucc, nfail, r::rs) - end) - (0, 0, []) 0 (hi-1) - in - let total_ran = nsuccess + nfailures in - - (* Print a diagnostic for --quake *) - if quaking then begin - let fuel_msg = - match !best_fuel, !best_ifuel with - | Some f, Some i -> - BU.format2 " (best fuel=%s, best ifuel=%s)" (string_of_int f) (string_of_int i) - | _, _ -> "" - in - BU.print5 "Quake: query %s succeeded %s/%s times%s%s\n" - name - (string_of_int nsuccess) - (string_of_int total_ran) - (if total_ran < hi then " (early finish)" else "") - fuel_msg - end; - let all_errs = List.concatMap (function | Inr _ -> [] - | Inl es -> [es]) rs - in - (* Return answer *) - { ok = nsuccess >= lo - ; cache_hit = false - ; nsuccess = nsuccess - ; lo = lo - ; hi = hi - ; errs = all_errs - ; total_ran = total_ran - ; quaking_or_retrying = quaking_or_retrying - ; quaking = quaking - ; tried_recovery = false (* possibly set by caller *) - } - -(* A very simple command language for recovering, though keep in -mind its execution is stateful in the sense that anything after a -(RestartSolver h) will run in the new solver instance. *) -type recovery_hammer = - | IncreaseRLimit of (*factor : *)int - | RestartAnd of recovery_hammer - -let rec pp_hammer (h : recovery_hammer) : Pprint.document = - let open FStar.Errors.Msg in - let open FStar.Pprint in - match h with - | IncreaseRLimit factor -> - text "increasing its rlimit by" ^/^ pp factor ^^ doc_of_string "x" - | RestartAnd h -> - text "restarting the solver and" ^/^ pp_hammer h - -(* If --proof_recovery is on, then we retry the query multiple -times, increasing rlimits, until we get a success. If not, we just -call ask_solver_quake. *) -let ask_solver_recover - (configs : list query_settings) - : answer - = - let open FStar.Pprint in - let open FStar.Errors.Msg in - let open FStar.Class.PP in - if Options.proof_recovery () then ( - let r = ask_solver_quake configs in - if r.ok then r else ( - let restarted = BU.mk_ref false in - let cfg = List.last configs in - - Errors.diag cfg.query_range [ - text "This query failed to be solved. Will now retry with higher rlimits due to --proof_recovery."; - ]; - - let try_factor (n:int) : answer = - let open FStar.Mul in - Errors.diag cfg.query_range [text "Retrying query with rlimit factor" ^/^ pp n]; - let cfg = { cfg with query_rlimit = n * cfg.query_rlimit } in - ask_solver_quake [cfg] - in - - let rec try_hammer (h : recovery_hammer) : answer = - match h with - | IncreaseRLimit factor -> try_factor factor - | RestartAnd h -> - Errors.diag cfg.query_range [text "Trying a solver restart"]; - cfg.query_env.tcenv.solver.refresh (Some cfg.query_env.tcenv.proof_ns); - try_hammer h - in - - let rec aux (hammers : list recovery_hammer) : answer = - match hammers with - | [] -> { r with tried_recovery = true } - | h::hs -> - let r = try_hammer h in - if r.ok then ( - Errors.log_issue cfg.query_range Errors.Warning_ProofRecovery [ - text "This query succeeded after " ^/^ pp_hammer h; - text "Increase the rlimit in the file or simplify the proof. \ - This is only succeeding due to --proof_recovery being given." - ]; - r - ) else - aux hs - in - aux [ - IncreaseRLimit 2; - IncreaseRLimit 4; - IncreaseRLimit 8; - RestartAnd (IncreaseRLimit 8); - ] - ) - ) else - ask_solver_quake configs - -let failing_query_ctr : ref int = BU.mk_ref 0 - -let maybe_save_failing_query (env:env_t) (qs:query_settings) : unit = - (* Save failing query to a clean file if --log_failing_queries. *) - if Options.log_failing_queries () then ( - let mod = show (Env.current_module env.tcenv) in - let n = (failing_query_ctr := !failing_query_ctr + 1; !failing_query_ctr) in - let file_name = BU.format2 "failedQueries-%s-%s.smt2" mod (show n) in - let query_str = Z3.ask_text - qs.query_range - // (filter_assertions qs.query_env None qs.query_hint) - qs.query_hash - qs.query_all_labels - (with_fuel_and_diagnostics qs []) - (BU.format2 "(%s, %s)" qs.query_name (string_of_int qs.query_index)) - qs.query_hint - in - write_file file_name query_str; - () - ); - (* Also print it out if --debug SMTFail. *) - if !dbg_SMTFail then ( - let open FStar.Pprint in - let open FStar.Class.PP in - let open FStar.Errors.Msg in - Errors.diag qs.query_range [ - text "This query failed:"; - pp qs.query_term; - ] - ); - () - -let ask_solver - (env : FStar.SMTEncoding.Env.env_t) - // (prefix : list decl) - (configs: list query_settings) - (next_hint : option hint) - : list query_settings & answer - = (* The default config is at the head. We distinguish this one since - it includes some metadata that we need, such as the query name, etc. - (Though all other configs also contain it.) *) - let default_settings = List.hd configs in - let skip : bool = - env.tcenv.admit || - Env.too_early_in_prims env.tcenv || - (match Options.admit_except () with - | Some id -> - if BU.starts_with id "(" - then full_query_id default_settings <> id - else default_settings.query_name <> id - | None -> false) - in - let ans = - if skip - then ( - if Options.record_hints () && next_hint |> is_some then - //restore the hint as is, cf. #1651 - next_hint |> must |> store_hint; - ans_ok - ) else ( - // Feed the context of the query to the solver. We do this only - // once for every VC. Every actual query will push and pop - // whatever else they encode. - // Z3.giveZ3 prefix; - let ans = ask_solver_recover configs in - let cfg = List.last configs in - if not ans.ok then - maybe_save_failing_query env cfg; - ans - - ) - in - configs, ans - -(* Reports query errors to the user. The errors are logged, not raised. *) -let report (env:Env.env) (default_settings : query_settings) (a : answer) : unit = - let nsuccess = a.nsuccess in - let name = full_query_id default_settings in - let lo = a.lo in - let hi = a.hi in - let total_ran = a.total_ran in - let all_errs = a.errs in - let quaking_or_retrying = a.quaking_or_retrying in - let quaking = a.quaking in - (* If nsuccess < lo, we have a failure. We report summarized - * information if doing --quake (and not --query_stats) *) - if nsuccess < lo then begin - if quaking_or_retrying && not (Options.query_stats ()) then begin - let errors_to_report errs = - errors_to_report a.tried_recovery ({default_settings with query_errors=errs}) - in - - (* Obtain all errors that would have been reported *) - let errs = List.map errors_to_report all_errs in - (* Summarize them *) - let errs = errs |> List.flatten |> collect_dups in - (* Show the amount on each error *) - let errs = errs |> List.map (fun ((e, m, r, ctx), n) -> - let m = - let open FStar.Pprint in - if n > 1 - then m @ [doc_of_string (format1 "Repeated %s times" (string_of_int n))] - else m - in - (e, m, r, ctx)) - in - (* Now report them *) - FStar.Errors.add_errors errs; - - (* Adding another explanatory error for the threshold if --quake is on - * (but not for --retry) *) - if quaking then begin - (* Get the range of the lid we're checking for the quake error *) - let rng = match fst (env.qtbl_name_and_index) with - | Some (l, _, _) -> Ident.range_of_lid l - | _ -> Range.dummyRange - in - FStar.TypeChecker.Err.log_issue - env rng - (Errors.Error_QuakeFailed, [ - Errors.text <| - BU.format6 - "Query %s failed the quake test, %s out of %s attempts succeded, \ - but the threshold was %s out of %s%s" - name - (string_of_int nsuccess) - (string_of_int total_ran) - (string_of_int lo) - (string_of_int hi) - (if total_ran < hi then " (early abort)" else "")]) - end - - end else begin - (* Not quaking, or we have --query_stats: just report all errors as usual *) - let report errs = report_errors a.tried_recovery ({default_settings with query_errors=errs}) in - List.iter report all_errs - end - end - -(* This type represents the configuration under which the solver was -_started_. If anything changes, the solver should be restarted for these -settings to take effect. See `maybe_refresh` below. *) -type solver_cfg = { - seed : int; - cliopt : list string; - smtopt : list string; - facts : list (list string & bool); - valid_intro : bool; - valid_elim : bool; - z3version : string; - context_pruning : bool -} - -let _last_cfg : ref (option solver_cfg) = BU.mk_ref None - -let get_cfg env : solver_cfg = - { seed = Options.z3_seed () - ; cliopt = Options.z3_cliopt () - ; smtopt = Options.z3_smtopt () - ; facts = env.proof_ns - ; valid_intro = Options.smtencoding_valid_intro () - ; valid_elim = Options.smtencoding_valid_elim () - ; z3version = Options.z3_version () - ; context_pruning = Options.Ext.get "context_pruning" <> "" - } - -let save_cfg env = - _last_cfg := Some (get_cfg env) - -(* If the the solver's configuration has changed, then restart it so -it can take on the new values. *) -let maybe_refresh_solver env = - match !_last_cfg with - | None -> save_cfg env - | Some cfg -> - if cfg <> get_cfg env then ( - save_cfg env; - Z3.refresh (Some env.proof_ns) - ) - -let finally (h : unit -> unit) (f : unit -> 'a) : 'a = - let r = - try f () with - | e -> h(); raise e - in - h (); r - -(* The query_settings list is non-empty unless the query was trivial. *) -let encode_and_ask (can_split:bool) (is_retry:bool) use_env_msg tcenv q : (list query_settings & answer) = - let do () : list query_settings & answer = - maybe_refresh_solver tcenv; - let msg = (BU.format1 "Starting query at %s" (Range.string_of_range <| Env.get_range tcenv)) in - Encode.push_encoding_state msg; - let prefix, labels, qry, suffix = Encode.encode_query use_env_msg tcenv q in - Z3.start_query msg prefix qry; - let finish_query () = - let msg = (BU.format1 "Ending query at %s" (Range.string_of_range <| Env.get_range tcenv)) in - Encode.pop_encoding_state msg; - Z3.finish_query msg - in - finally finish_query (fun () -> - let tcenv = incr_query_index tcenv in - match qry with - (* trivial cases *) - | Assume({assumption_term={tm=App(FalseOp, _)}}) -> ([], ans_ok) - | _ when tcenv.admit -> ([], ans_ok) - - | Assume _ -> - if (is_retry || Options.split_queries() = Options.Always) - && Debug.any() - then ( - let n = List.length labels in - if n <> 1 - then - FStar.Errors.diag - (Env.get_range tcenv) - (BU.format3 "Encoded split query %s\nto %s\nwith %s labels" - (show q) - (Term.declToSmt "" qry) - (BU.string_of_int n)) - ); - let env = FStar.SMTEncoding.Encode.get_current_env tcenv in - let configs, next_hint = - make_solver_configs can_split is_retry env labels qry q suffix - in - ask_solver env configs next_hint - - | _ -> failwith "Impossible" - ) - in - if Solver.Cache.try_find_query_cache tcenv q then ( - ([], { ans_ok with cache_hit = true }) - ) else ( - let (cfgs, ans) = do () in - if ans.ok then - Solver.Cache.query_cache_add tcenv q; - (cfgs, ans) - ) - -(* Asks the solver and reports errors. Does quake if needed. *) -let do_solve (can_split:bool) (is_retry:bool) use_env_msg tcenv q : unit = - let ans_opt = - try Some (encode_and_ask can_split is_retry use_env_msg tcenv q) with - (* Each (potentially splitted) query can fail with this error, raise by encode_query. - * Note, even though this is a log_issue, the error cannot be turned into a warning - * nor ignored. *) - | FStar.SMTEncoding.Env.Inner_let_rec names -> - FStar.TypeChecker.Err.log_issue - tcenv tcenv.range - (Errors.Error_NonTopRecFunctionNotFullyEncoded, [ - Errors.text <| - BU.format1 - "Could not encode the query since F* does not support precise smtencoding of inner let-recs yet (in this case %s)" - (String.concat "," (List.map fst names))]); - None - in - match ans_opt with - | Some (default_settings::_, ans) when not ans.ok -> - report tcenv default_settings ans - - | Some (_, ans) when ans.ok -> - () (* trivial or succeeded *) - - | Some ([], ans) when not ans.ok -> - failwith "impossible: bad answer from encode_and_ask" - - | None -> () (* already logged an error *) - -let split_and_solve (retrying:bool) use_env_msg tcenv q : unit = - if Debug.any () || Options.query_stats () then begin - let range = "(" ^ (Range.string_of_range (Env.get_range tcenv)) ^ ")" in - BU.print2 "%s\tQuery-stats splitting query because %s\n" - range - (if retrying then "retrying failed query" else "--split_queries is always") - end; - let goals = - match Env.split_smt_query tcenv q with - | None -> - failwith "Impossible: split_query callback is not set" - - | Some goals -> - goals - in - - goals |> List.iter (fun (env, goal) -> do_solve false retrying use_env_msg env goal); - - if FStar.Errors.get_err_count() = 0 && retrying - then ( //query succeeded after a retry - FStar.TypeChecker.Err.log_issue - tcenv - tcenv.range - (Errors.Warning_SplitAndRetryQueries, - [Errors.text - "The verification condition succeeded after splitting it to localize potential errors, \ - although the original non-split verification condition failed. \ - If you want to rely on splitting queries for verifying your program \ - please use the '--split_queries always' option rather than relying on it implicitly."]) - ) - -let disable_quake_for (f : unit -> 'a) : 'a = - Options.with_saved_options (fun () -> - Options.set_option "quake_hi" (Options.Int 1); - f ()) - -(* Split queries if needed according to --split_queries option. Note: -sync SMT queries do not pass via this function. *) -let do_solve_maybe_split use_env_msg tcenv q : unit = - (* If we are admiting queries, don't do anything, and bail out - right now to save time/memory *) - if tcenv.admit then () else begin - match Options.split_queries () with - | Options.No -> do_solve false false use_env_msg tcenv q - | Options.OnFailure -> - (* If we are quake testing, disable auto splitting. Note, this implies - * that automatically splitted queries do not ever get quake testing, - * which is good as that would be confusing for the user. *) - let can_split = not (Options.quake_hi () > 1) in - begin try do_solve can_split false use_env_msg tcenv q with - | SplitQueryAndRetry -> - split_and_solve true use_env_msg tcenv q - end - | Options.Always -> - (* Set retrying=false so queries go through the full config list, etc. *) - split_and_solve false use_env_msg tcenv q - end - -(* Attempt to discharge a VC through the SMT solver. Will -automatically retry increasing fuel as needed, and perform quake testing -(repeating the query to make sure it is robust). This function will -_log_ (not raise) an error if the VC could not be proven. *) -let solve use_env_msg tcenv q : unit = - if Options.no_smt () then - let open FStar.Errors.Msg in - let open FStar.Pprint in - let open FStar.Class.PP in - FStar.TypeChecker.Err.log_issue - tcenv tcenv.range - (Errors.Error_NoSMTButNeeded, - [text "A query could not be solved internally, and --no_smt was given."; - text "Query = " ^/^ pp q]) - else - Profiling.profile - (fun () -> do_solve_maybe_split use_env_msg tcenv q) - (Some (Ident.string_of_lid (Env.current_module tcenv))) - "FStar.SMTEncoding.solve_top_level" - -(* This asks the SMT to solve a query, and returns the answer without -logging any kind of error. Mostly useful for the smt_sync tactic -primitive. - -It will NOT split queries -It will NOT do quake testing. -It WILL raise fuel incrementally to attempt to solve the query - -*) -let solve_sync use_env_msg tcenv (q:Syntax.term) : answer = - if Options.no_smt () then ans_fail - else - let go () = - if !dbg_SMTQuery then ( - let open FStar.Errors.Msg in - let open FStar.Pprint in - Errors.diag q.pos [ - prefix 2 1 (text "Running synchronous SMT query. Q =") (pp q); - ] - ); - let _cfgs, ans = disable_quake_for (fun () -> encode_and_ask false false use_env_msg tcenv q) in - ans - in - Profiling.profile - go - (Some (Ident.string_of_lid (Env.current_module tcenv))) - "FStar.SMTEncoding.solve_sync_top_level" - -(* The version actually exported, and used by tactics. *) -let solve_sync_bool use_env_msg tcenv q : bool = - let ans = solve_sync use_env_msg tcenv q in - ans.ok - -(**********************************************************************************************) -(* Top-level interface *) -(**********************************************************************************************) - -let snapshot msg = - let v0, v1 = Encode.snapshot_encoding msg in - let v2 = Z3.snapshot msg in - (v0, v1, v2), () -let rollback msg tok = - let tok01, tok2 = - match tok with - | None -> None, None - | Some (v0, v1, v2) -> Some (v0, v1), Some v2 - in - Encode.rollback_encoding msg tok01; - Z3.rollback msg tok2 - -let solver = { - init=(fun e -> save_cfg e; Encode.init e); - snapshot; - rollback; - encode_sig=Encode.encode_sig; - - (* These three to be overriden by FStar.Universal.init_env *) - preprocess=(fun e g -> (false, [e,g, FStar.Options.peek ()])); - spinoff_strictly_positive_goals = None; - handle_smt_goal=(fun e g -> [e,g]); - - solve=solve; - solve_sync=solve_sync_bool; - finish=(fun () -> ()); - refresh=Z3.refresh; -} - -let dummy = { - init=(fun _ -> ()); - snapshot=(fun _ -> (0, 0, 0), ()); - rollback=(fun _ _ -> ()); - encode_sig=(fun _ _ -> ()); - preprocess=(fun e g -> (false, [e,g, FStar.Options.peek ()])); - spinoff_strictly_positive_goals = None; - handle_smt_goal=(fun e g -> [e,g]); - solve=(fun _ _ _ -> ()); - solve_sync=(fun _ _ _ -> false); - finish=(fun () -> ()); - refresh=(fun _ -> ()); -} diff --git a/src/smtencoding/FStar.SMTEncoding.Solver.fsti b/src/smtencoding/FStar.SMTEncoding.Solver.fsti deleted file mode 100644 index a29ffa78d61..00000000000 --- a/src/smtencoding/FStar.SMTEncoding.Solver.fsti +++ /dev/null @@ -1,22 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.SMTEncoding.Solver -open FStar.Compiler.Effect - -val with_hints_db : string -> (unit -> 'a) -> 'a -val dummy: FStar.TypeChecker.Env.solver_t -val solver: FStar.TypeChecker.Env.solver_t diff --git a/src/smtencoding/FStar.SMTEncoding.SolverState.fst b/src/smtencoding/FStar.SMTEncoding.SolverState.fst deleted file mode 100644 index cfa2f1d0ddb..00000000000 --- a/src/smtencoding/FStar.SMTEncoding.SolverState.fst +++ /dev/null @@ -1,518 +0,0 @@ -(* - Copyright 2024 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.SMTEncoding.SolverState -open FStar.Compiler.Effect -open FStar -open FStar.Compiler -open FStar.SMTEncoding.Term -open FStar.BaseTypes -open FStar.Compiler.Util -open FStar.List.Tot -open FStar.Class.Show -open FStar.Class.Setlike -module BU = FStar.Compiler.Util -module Pruning = FStar.SMTEncoding.Pruning -module U = FStar.SMTEncoding.UnsatCore -module TcEnv = FStar.TypeChecker.Env - -let decl_name_set = BU.psmap bool -let empty_decl_names = BU.psmap_empty #bool () -let decl_names_contains (x:string) (s:decl_name_set) = Some? (BU.psmap_try_find s x) -let add_name (x:string) (s:decl_name_set) = BU.psmap_add s x true - -type decls_at_level = { - pruning_state: Pruning.pruning_state; (* the context pruning state representing all declarations visible at this level and prior levels *) - given_decl_names: decl_name_set; (* all declarations that have been given to the solver at this level *) - all_decls_at_level_rev: list (list decl); (* all decls at this level; in reverse order of pushes *) - given_some_decls: bool; (* Have some declarations been flushed at this level? If not, we can pop this level without needing to flush pop to the solver *) - to_flush_rev: list (list decl); (* declarations to be given to the solver at the next flush, in reverse order, though each nested list is in order *) - named_assumptions: BU.psmap assumption; (* A map from assumption names to assumptions, accumulating all assumptions up to this level *) - pruning_roots:option (list decl); (* When starting a query context, we register the declarations to be used as roots for context pruning *) -} - -let init_given_decls_at_level = { - given_decl_names = empty_decl_names; - all_decls_at_level_rev = []; - pruning_state=Pruning.init; - given_some_decls=false; - to_flush_rev=[]; - named_assumptions = BU.psmap_empty (); - pruning_roots=None -} - -type solver_state = { - levels: list decls_at_level; (* a stack of levels *) - pending_flushes_rev: list decl; (* any declarations to be flushed before flushing the levels, typically a sequence of pops *) - using_facts_from:option using_facts_from_setting; (* The current setting for using_facts_from *) - retain_assumptions: decl_name_set; (* For using_facts_from: some declarations are of the form RetainAssumptions [a1; a2; ...; an]; this records their names *) -} - -let depth (s:solver_state) = List.length s.levels - -(* For debugging: print the solver state *) -let solver_state_to_string (s:solver_state) = - let levels = - List.map - (fun level -> - BU.format3 "Level { all_decls=%s; given_decls=%s; to_flush=%s }" - (show <| List.length level.all_decls_at_level_rev) - (show level.given_some_decls) - (show <| List.length level.to_flush_rev)) - s.levels - in - BU.format2 "Solver state { levels=%s; pending_flushes=%s }" - (show levels) - (show <| List.length s.pending_flushes_rev) - -instance showable_solver_state : showable solver_state = { show = solver_state_to_string } - -let debug (msg:string) (s0 s1:solver_state) = - if Options.Ext.get "debug_solver_state" <> "" - then ( - BU.print3 "Debug (%s):{\n\t before=%s\n\t after=%s\n}" msg - (solver_state_to_string s0) - (solver_state_to_string s1) - ) - -let peek (s:solver_state) = - match s.levels with - | [] -> failwith "Solver state cannot have an empty stack" - | hd::tl -> hd, tl - -let replace_head (hd:decls_at_level) (s:solver_state) = { s with levels = hd :: List.tl s.levels } - -let init (_:unit) -: solver_state -= { levels = [init_given_decls_at_level]; - pending_flushes_rev = []; - using_facts_from = Some (Options.using_facts_from()); - retain_assumptions = empty_decl_names } - -let push (s:solver_state) -: solver_state -= let hd, _ = peek s in - let push = Push (List.length s.levels) in - let next = { given_decl_names = hd.given_decl_names; - all_decls_at_level_rev = []; - pruning_state = hd.pruning_state; - given_some_decls=false; - to_flush_rev=[[push]]; (* push a new context to the solver *) - named_assumptions = hd.named_assumptions; - pruning_roots=None - } in - { s with levels=next::s.levels } - -let pop (s:solver_state) -: solver_state -= let hd, tl = peek s in - if Nil? tl then failwith "Solver state cannot have an empty stack"; - let s1 = - if not hd.given_some_decls //nothing has been given yet at this level - then { s with levels = tl } //so we don't actually have to send a pop - else { s with levels = tl; pending_flushes_rev = Pop (List.length tl) :: s.pending_flushes_rev } - in - s1 - -(* filter ds according to the using_facts_from setting: - - -- This function takes specific fields of the csolver state, rather - than the entire solver state, as it is used as a helper in constructing a - new solver state from a prior one, and some of its arguments are from a - partially new solver state -*) -let filter_using_facts_from - (using_facts_from:option using_facts_from_setting) - (named_assumptions:BU.psmap assumption) - (retain_assumptions:decl_name_set) - (already_given_decl: string -> bool) - (ds:list decl) //flattened decls -: list decl -= match using_facts_from with - | None - | Some [[], true] -> ds - | Some using_facts_from -> - let keep_assumption (a:assumption) - : bool - = match a.assumption_fact_ids with - | [] -> true //retaining `a` because it is not tagged with a fact id - | _ -> - // the assumption is either tagged in a prior RetainAssumptions decl - decl_names_contains a.assumption_name retain_assumptions || - // Or, it is enabled by the using_facts_from setting - a.assumption_fact_ids - |> BU.for_some (function Name lid -> TcEnv.should_enc_lid using_facts_from lid | _ -> false) - in - let already_given_map : BU.smap bool = BU.smap_create 1000 in - let add_assumption a = BU.smap_add already_given_map a.assumption_name true in - let already_given (a:assumption) - : bool - = Some? (BU.smap_try_find already_given_map a.assumption_name) || - already_given_decl a.assumption_name - in - let map_decl (d:decl) - : list decl - = match d with - | Assume a -> ( - if keep_assumption a && not (already_given a) - then (add_assumption a; [d]) - else [] - ) - | RetainAssumptions names -> - // Add all assumptions that are mentioned here, making sure to not add duplicates - let assumptions = - names |> - List.collect (fun name -> - match BU.psmap_try_find named_assumptions name with - | None -> [] - | Some a -> - if already_given a then [] else (add_assumption a; [Assume a])) - in - assumptions - | _ -> - [d] - in - let ds = List.collect map_decl ds in - ds - -let already_given_decl (s:solver_state) (aname:string) -: bool -= s.levels |> BU.for_some (fun level -> decl_names_contains aname level.given_decl_names) - -let rec flatten (d:decl) : list decl = - match d with - | Module (_, ds) -> List.collect flatten ds - | _ -> [d] - -(* Record assumptions with their names *) -let add_named_assumptions (named_assumptions:BU.psmap assumption) (ds:list decl) -: BU.psmap assumption -= List.fold_left - (fun named_assumptions d -> - match d with - | Assume a -> BU.psmap_add named_assumptions a.assumption_name a - | _ -> named_assumptions) - named_assumptions - ds - -(* Record all names that are named in a RetainAssumptions *) -let add_retain_assumptions (ds:list decl) (s:solver_state) -: solver_state -= let ra = - List.fold_left - (fun ra d -> - match d with - | RetainAssumptions names -> - List.fold_left - (fun ra name -> add_name name ra) - ra names - | _ -> ra) - s.retain_assumptions - ds - in - { s with retain_assumptions = ra } - -(* - The main `give` API has two modes: - `give_delay_assumptions` is used when context_pruning is enabled, and - `give_now` is used otherwise. - - In both cases, we have the following parameters: - - - resetting: Is this being called during a reset? If so, we don't need to - update the pruning state---repeatedly building the pruning state on each - reset is expensive and quadratic in the number of declarations loaded so - far. - - ds: The declarations to give to the solver - - s: The current solver state -*) - -(* give_delay_assumptions: - - This updates the top-level of the solver state, and flushes *only* the - non-assumption declarations to the solver. - - The assumptions are retained and a selection of them may be flushed to the - solver later, for a given set of roots of a query. - *) -let give_delay_assumptions (resetting:bool) (ds:list decl) (s:solver_state) -: solver_state -= let decls = List.collect flatten ds in - let assumptions, rest = List.partition Assume? decls in - let hd, tl = peek s in - let hd = { hd with all_decls_at_level_rev = ds::hd.all_decls_at_level_rev; - to_flush_rev = rest :: hd.to_flush_rev } in - if resetting - then { s with levels = hd :: tl } - else ( - let hd = - { hd with - pruning_state = Pruning.add_decls decls hd.pruning_state; - named_assumptions = add_named_assumptions hd.named_assumptions assumptions } - in - add_retain_assumptions decls { s with levels = hd :: tl } - ) - -(* give_now: - - This updates the top-level of the solver state, and flushes *all* - declarations to the solver, after filtering them according to the - using_facts_from setting -*) -let give_now (resetting:bool) (ds:list decl) (s:solver_state) -: solver_state -= let decls = List.collect flatten ds in - let assumptions, _ = List.partition Assume? decls in - let hd, tl = peek s in - let named_assumptions = - if resetting - then hd.named_assumptions - else add_named_assumptions hd.named_assumptions assumptions - in - let ds_to_flush = - filter_using_facts_from - s.using_facts_from - named_assumptions - s.retain_assumptions - (already_given_decl s) - decls - in - let given = - List.fold_left - (fun given d -> - match d with - | Assume a -> add_name a.assumption_name given - | _ -> given) - hd.given_decl_names - ds_to_flush - in - let hd = - { hd with - given_decl_names = given; - all_decls_at_level_rev = ds :: hd.all_decls_at_level_rev; - to_flush_rev = ds_to_flush :: hd.to_flush_rev; } - in - if resetting - then { s with levels = hd :: tl } - else ( - let hd = - { hd with - pruning_state = Pruning.add_decls decls hd.pruning_state; - named_assumptions } - in - add_retain_assumptions decls { s with levels = hd :: tl } - ) - -let give_aux resetting (ds:list decl) (s:solver_state) -: solver_state -= if Options.Ext.get "context_pruning" <> "" - then give_delay_assumptions resetting ds s - else give_now resetting ds s - -(* give: The main API for giving declarations to the solver *) -let give = give_aux false - -(* reset: - - This functions essentially runs the sequence of push/give operations that - have been run so far from the init state, producing the declarations - that should be flushed to the solver from a clean state, while considering - the current option settings. - - E.g., if the value of context_pruning has changed, this will restore the solver - to a state where the new setting is in effect. - -*) -let reset (using_facts_from:option using_facts_from_setting) (s:solver_state) -: solver_state -= let s_new = init () in - let s_new = { s_new with using_facts_from; retain_assumptions = s.retain_assumptions } in - let set_pruning_roots level s = - let hd,tl = peek s in - let hd = { hd with pruning_roots = level.pruning_roots } in - { s with levels = hd :: tl } - in - let rebuild_level now level s_new = - //Rebuild the level from s in the top-most level of the new solver state s_new - let hd, tl = peek s_new in - //1. replace the head of s_new recordingt the pruning state etc. from level - let hd = {hd with pruning_state=level.pruning_state; named_assumptions=level.named_assumptions} in - let s_new = { s_new with levels = hd :: tl } in - //2. Then give all declarations at this level - // The `now` flag is set for levels that "follow" a level - // whose pruning roots have been set, i.e., for the query itself - // Otherwise, we give the declarations either now or delayed, depending on the current value of context_pruning - let s = List.fold_right (if now then give_now true else give_aux true) level.all_decls_at_level_rev s_new in - // 3. If there are pruning roots at this level, set them - set_pruning_roots level s, - Some? level.pruning_roots - in - let rec rebuild levels s_new = - match levels with - | [ last ] -> - rebuild_level false last s_new - | level :: levels -> - //rebuild prior levels - let s_new, now = rebuild levels s_new in - //push a context - let s_new = push s_new in - //rebuild the level - rebuild_level now level s_new - in - fst <| rebuild s.levels s_new - - -let name_of_assumption (d:decl) = - match d with - | Assume a -> a.assumption_name - | _ -> failwith "Expected an assumption" - -(* Prune the context with respect to a set of roots *) -let prune_level (roots:list decl) (hd:decls_at_level) (s:solver_state) -: decls_at_level -= // to_give is the set of assumptions reachable from roots - let to_give = Pruning.prune hd.pruning_state roots in - // Remove any assumptions that have already been given to the solver - // and update the set of given declarations - let given_decl_names, can_give = - List.fold_left - (fun (decl_name_set, can_give) to_give -> - let name = name_of_assumption to_give in - if not (decl_names_contains name decl_name_set) - then ( - add_name name decl_name_set, - to_give::can_give - ) - else decl_name_set, can_give) - (hd.given_decl_names, []) - to_give - in - // Filter the assumptions that can be given to the solver - // according to the using_facts_from setting - let can_give = - filter_using_facts_from - s.using_facts_from - hd.named_assumptions - s.retain_assumptions - (already_given_decl s) - can_give - in - let hd = { hd with given_decl_names; - to_flush_rev = can_give::hd.to_flush_rev } in - hd - -(* Run pruning in a "simulation" mode, where we don't actually prune the context, - but instead return the names of the assumptions that would have been pruned. *) -let prune_sim (roots:list decl) (s:solver_state) -: list string -= let hd, tl = peek s in - let to_give = Pruning.prune hd.pruning_state roots in - let can_give = - filter_using_facts_from - s.using_facts_from - hd.named_assumptions - s.retain_assumptions - (already_given_decl s) - to_give - in - List.map name_of_assumption (List.filter Assume? roots@can_give) - -(* Start a query context, registering and pushing the roots *) -let start_query (msg:string) (roots_to_push:list decl) (qry:decl) (s:solver_state) -: solver_state -= let hd, tl = peek s in - let s = { s with levels = { hd with pruning_roots = Some (qry::roots_to_push) } :: tl } in - let s = push s in - let s = give [Caption msg] s in - give_now false roots_to_push s - -(* Finising a query context, popping and clearing the roots *) -let finish_query (msg:string) (s:solver_state) -: solver_state -= let s = give [Caption msg] s in - let s = pop s in - let hd, tl = peek s in - { s with levels = { hd with pruning_roots = None } :: tl } - -(* Filter all declarations visible with an unsat core *) -let filter_with_unsat_core queryid (core:U.unsat_core) (s:solver_state) -: list decl -= let rec all_decls levels = - match levels with - | [last] -> last.all_decls_at_level_rev - | level :: levels -> - level.all_decls_at_level_rev@[Push <| List.length levels]::all_decls levels - in - let all_decls = all_decls s.levels in - let all_decls = List.flatten <| List.rev all_decls in - U.filter core all_decls - -let would_have_pruned (s:solver_state) = - if Options.Ext.get "context_pruning_sim" = "" - then None - else - (*find the first level with pruning roots, and prune the context with respect to them *) - let rec aux levels = - match levels with - | [] -> None - | level :: levels -> - match level.pruning_roots with - | Some roots -> - Some (prune_sim roots s) - | None -> aux levels - in - aux s.levels - -(* flush: Emit declarations to the solver *) -let flush (s:solver_state) -: list decl & solver_state -= let s = - if Options.Ext.get "context_pruning" <> "" - then ( - (*find the first level with pruning roots, and prune the context with respect to them *) - let rec aux levels = - match levels with - | [] -> [] - | level :: levels -> - match level.pruning_roots with - | Some roots -> - let hd = prune_level roots level s in - hd :: levels - | None -> - level :: aux levels - in - { s with levels = aux s.levels } - ) - else s - in - (* Gather all decls to be flushd per level *) - let to_flush = - List.flatten <| - List.rev <| - List.collect (fun level -> level.to_flush_rev) s.levels - in - (* Update the solver state, clearing the pending flushes per level and recording that some decls were flushed *) - let levels = - List.map - (fun level -> { level with - given_some_decls=(level.given_some_decls || Cons? level.to_flush_rev); - to_flush_rev = [] }) - s.levels - in - let s1 = { s with levels; pending_flushes_rev=[] } in - (* prefix any pending flushes to the list of decls to be flushed *) - let flushed = List.rev s.pending_flushes_rev @ to_flush in - flushed, - s1 \ No newline at end of file diff --git a/src/smtencoding/FStar.SMTEncoding.SolverState.fsti b/src/smtencoding/FStar.SMTEncoding.SolverState.fsti deleted file mode 100644 index d9373e84cc1..00000000000 --- a/src/smtencoding/FStar.SMTEncoding.SolverState.fsti +++ /dev/null @@ -1,106 +0,0 @@ -(* - Copyright 2024 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.SMTEncoding.SolverState -(** - This module is an abstraction of state of the SMT solver, expressed in terms of the facts - that are visible to it currently. - - As such, it also encapsulates the various notions of filtering the facts that - are sent to the solver, including: - - - Filtering with unsat cores - - Context pruning - - Filtering using the using_facts_from setting - - This interface is purely functional: every operation takes the current state and - optionally returns a new one, in case the state changes. - - Note, this module does not directly call the SMT solver itself: That is - handled in FStar.SMTEncoding.Z3.fst. Instead, it buffers all Term.decls to be - sent to the solver and a call to flush returns all the decls to be sent. -*) -open FStar.Compiler.Effect -open FStar -open FStar.Compiler -open FStar.SMTEncoding.Term -open FStar.BaseTypes -open FStar.Compiler.Util -module BU = FStar.Compiler.Util -module U = FStar.SMTEncoding.UnsatCore -type using_facts_from_setting = list (list string & bool) - -// Abstract state of the solver -val solver_state : Type0 - -// Initialize the solver state -val init (_:unit) : solver_state - -// Push a context -val push (s:solver_state) : solver_state - -// Pop a context: All facts added since the last push are removed -val pop (s:solver_state) : solver_state - -// Get the current depth of the context stack: -// Useful in implementing snapshot and rollback, which are used in the IDE -// to restore the state of the solver to a previous point, rather than just -// popping the context one at a time -val depth (s:solver_state) : int - -// Reset the state, so that the next flush will yield all the declarations -// that should be sent to a _fresh_ Z3 process to bring it to a state -// logicallly equivalent to the current solver state -val reset (_:option using_facts_from_setting) (s:solver_state) : solver_state - -// Give the solver some declarations -val give (ds:list decl) (s:solver_state) : solver_state - -// Start a query context: Queries are handled specially, since they trigger -// various kinds of filters. -// -// This function pushes a context, and then adds roots to the solver state. -// -// * msg: A caption to be added to the SMT encoding for this query -// -// * roots: A list of query-specific declarations, e.g, an encoding of the local -// binders of the query -// -// * qry: The query itself: This is NOT given to the solver. Instead, (qry::roots) are -// registered in the solver state as the roots from which to scan for context pruning. -// -val start_query (msg:string) (roots:list decl) (qry:decl) (s:solver_state) : solver_state - -// Pops the context pushed at when starting a query -// Clears any registered roots for context pruning -val finish_query (msg:string) (s:solver_state) : solver_state - -// Filters all declarations visible with an unsat core and returns the result -// Does not change the solver state -// -// Queries filtered with an unsat core are always sent to a fresh Z3 process, -// and if they fail, the query falls back to a background process whose state is `s`. -// Filtering with an unsat core does not change the staet of s. -val filter_with_unsat_core (queryid:string) (_:U.unsat_core) (s:solver_state) : list decl - -// Get all declarations to be given to the solver since the last flush -// and update the solver state. -val flush (s:solver_state) : list decl & solver_state - -// If context_pruning_sim is set, this function returns the names of all declarations -// that would have been given to the solver if the context were pruned. -// This is useful for debugging whether context_pruning removed assumptions that are -// otherwise necessary for a proof. -val would_have_pruned (s:solver_state) : option (list string) \ No newline at end of file diff --git a/src/smtencoding/FStar.SMTEncoding.Term.fst b/src/smtencoding/FStar.SMTEncoding.Term.fst deleted file mode 100644 index d5ebfa24e96..00000000000 --- a/src/smtencoding/FStar.SMTEncoding.Term.fst +++ /dev/null @@ -1,1182 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.SMTEncoding.Term - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect - -module S = FStar.Syntax.Syntax -module BU = FStar.Compiler.Util -module U = FStar.Syntax.Util - -let escape (s:string) = BU.replace_char s '\'' '_' - -let rec strSort x = match x with - | Bool_sort -> "Bool" - | Int_sort -> "Int" - | Term_sort -> "Term" - | String_sort -> "FString" - | Fuel_sort -> "Fuel" - | BitVec_sort n -> format1 "(_ BitVec %s)" (string_of_int n) - | Array(s1, s2) -> format2 "(Array %s %s)" (strSort s1) (strSort s2) - | Arrow(s1, s2) -> format2 "(%s -> %s)" (strSort s1) (strSort s2) - | Sort s -> s - -(** Note [Thunking Nullary Constants] - -### The problem: Top-level nullary constants lead to SMT context - pollution - -Given a top-level nullary constant, say, - -```let n : u32 = 0ul``` - -F* would encode this to SMT as (roughly) - -``` -(declare-fun n () Term) -(assert (HasType n u32)) -(assert (n = U32.uint_to_t 0)) -``` - -i.e., ground facts about the `n`'s typing and definition would be -introduced into the top-level SMT context. - -Now, for a subsequent proof that has nothing to do with `n`, these -facts are still available in the context leading to clutter. E.g., in -this case, the `HasType n u32` leads to Z3 deriving facts like about -`0 <= n < pow2 32`, then potentially unfolding the `pow2 32` recursive -functions ... etc. all for potentially no good reason. - -### The fix: Protect assumptions about nullary constants under a dummy - quantifier - -The change in this PR is to avoid introducing these ground facts into -the SMT context by default. Instead, we now thunk these nullary -constants, adding a dummy argument, like so: - -``` -(declare-fun n (Dummy_sort) Term) -(assert (forall ((x Dummy_sort) (! (HasType (n x) u32) :pattern ((n x))))) -(assert (forall ((x Dummy_sort) (! (= (n x) (U32.uint_to_t 0)) :pattern ((n x))))) -``` - -Now, instead of ground facts, we have quantified formulae that are -triggered on occurrences of `n x`. - -Every occurrence of `n` in the rest of the proof is forced to `(n -Dummy_value)`: so, only when such an occurrence is present, do facts -about `n` become available, not polluting the context otherwise. - -For some proofs in large contexts, this leads to massive SMT -performance gains: e.g., in miTLS with LowParse in context, some -queries in HSL.Common are sped up by 20x; Negotiation.fst has an -end-to-end speed up (full verification time) by 8-9x. etc. So, this -can be a big win. - -#### An implementation detail - -Note, this thunking happens at a very low-level in the SMT -encoding. Basically, the thunks are forced at the very last minute -just before terms are printed to SMT. This is important since it -ensures that things like sharing of SMT terms are not destroyed by -discrepancies in thunking behavior (and earlier attempt did thunking -at a higher level in the encoding, but this led to many regressions). - -The bool in the fv is used in termToSmt to force the thunk before -printing. - **) - -let mk_decls name key decls aux_decls = [{ - sym_name = Some name; - key = Some key; - decls = decls; - a_names = //AR: collect the names of aux_decls and decls to be retained in case of a cache hit - let sm = BU.smap_create 20 in - List.iter (fun elt -> - List.iter (fun s -> BU.smap_add sm s "0") elt.a_names - ) aux_decls; - List.iter (fun d -> match d with - | Assume a -> BU.smap_add sm (a.assumption_name) "0" - | _ -> ()) decls; - BU.smap_keys sm -}] - -let mk_decls_trivial decls = [{ - sym_name = None; - key = None; - decls = decls; - a_names = List.collect (function - | Assume a -> [a.assumption_name] - | _ -> []) decls; -}] - -let decls_list_of l = l |> List.collect (fun elt -> elt.decls) - -let mk_fv (x, y) : fv = FV (x, y, false) - -let fv_name (x:fv) = let FV (nm, _, _) = x in nm - -instance deq_fv : deq fv = { - (=?) = (fun fv1 fv2 -> fv_name fv1 = fv_name fv2); -} -instance ord_fv : ord fv = { - super = deq_fv; - cmp = (fun fv1 fv2 -> Order.order_from_int (BU.compare (fv_name fv1) (fv_name fv2))); -} - -let fv_sort (x:fv) = let FV (_, sort, _) = x in sort -let fv_force (x:fv) = let FV (_, _, force) = x in force -let fv_eq (x:fv) (y:fv) = fv_name x = fv_name y -let fvs_subset_of (x:fvs) (y:fvs) = - let open FStar.Class.Setlike in - subset (from_list x <: RBSet.t fv) (from_list y) - -let freevar_eq x y = match x.tm, y.tm with - | FreeV x, FreeV y -> fv_eq x y - | _ -> false -let freevar_sort = function - | {tm=FreeV x} -> fv_sort x - | _ -> failwith "impossible" -let fv_of_term = function - | {tm=FreeV fv} -> fv - | _ -> failwith "impossible" -let rec freevars t = match t.tm with - | Integer _ - | String _ - | Real _ - | BoundV _ -> [] - | FreeV fv when fv_force fv -> [] //this is actually a top-level constant - | FreeV fv -> [fv] - | App(_, tms) -> List.collect freevars tms - | Quant(_, _, _, _, t) - | Labeled(t, _, _) - | LblPos(t, _) -> freevars t - | Let (es, body) -> List.collect freevars (body::es) - -//memo-ized -let free_variables t = match !t.freevars with - | Some b -> b - | None -> - let fvs = BU.remove_dups fv_eq (freevars t) in - t.freevars := Some fvs; - fvs - -open FStar.Class.Setlike -let free_top_level_names (t:term) -: RBSet.t string -= let rec free_top_level_names acc t = - match t.tm with - | FreeV (FV (nm, _, _)) -> add nm acc - | App (Var s, args) -> - let acc = add s acc in - List.fold_left free_top_level_names acc args - | App (_, args) -> List.fold_left free_top_level_names acc args - | Quant (_, pats, _, _, body) -> - let acc = List.fold_left (fun acc pats -> List.fold_left free_top_level_names acc pats) acc pats in - free_top_level_names acc body - | Let(tms, t) -> - let acc = List.fold_left free_top_level_names acc tms in - free_top_level_names acc t - | Labeled(t, _, _) - | LblPos(t, _) -> free_top_level_names acc t - | _ -> acc - in - free_top_level_names (empty()) t - -(*****************************************************) -(* Pretty printing terms and decls in SMT Lib format *) -(*****************************************************) -let qop_to_string = function - | Forall -> "forall" - | Exists -> "exists" - -let op_to_string = function - | TrueOp -> "true" - | FalseOp -> "false" - | Not -> "not" - | And -> "and" - | Or -> "or" - | Imp -> "implies" - | Iff -> "iff" - | Eq -> "=" - | LT -> "<" - | LTE -> "<=" - | GT -> ">" - | GTE -> ">=" - | Add -> "+" - | Sub -> "-" - | Div -> "div" - | RealDiv -> "/" - | Mul -> "*" - | Minus -> "-" - | Mod -> "mod" - | ITE -> "ite" - | BvAnd -> "bvand" - | BvXor -> "bvxor" - | BvOr -> "bvor" - | BvAdd -> "bvadd" - | BvSub -> "bvsub" - | BvShl -> "bvshl" - | BvShr -> "bvlshr" - | BvUdiv -> "bvudiv" - | BvMod -> "bvurem" - | BvMul -> "bvmul" - | BvUlt -> "bvult" - | BvToNat -> "bv2int" - | BvUext n -> format1 "(_ zero_extend %s)" (string_of_int n) - | NatToBv n -> format1 "(_ int2bv %s)" (string_of_int n) - | Var s -> s - -let weightToSmt = function - | None -> "" - | Some i -> BU.format1 ":weight %s\n" (string_of_int i) - -let rec hash_of_term' t = match t with - | Integer i -> i - | String s -> s - | Real r -> r - | BoundV i -> "@"^string_of_int i - | FreeV x -> fv_name x ^ ":" ^ strSort (fv_sort x) //Question: Why is the sort part of the hash? - | App(op, tms) -> "("^(op_to_string op)^(List.map hash_of_term tms |> String.concat " ")^")" - | Labeled(t, r1, r2) -> hash_of_term t ^ Errors.Msg.rendermsg r1 ^ (Range.string_of_range r2) - | LblPos(t, r) -> "(! " ^hash_of_term t^ " :lblpos " ^r^ ")" - | Quant(qop, pats, wopt, sorts, body) -> - "(" - ^ (qop_to_string qop) - ^ " (" - ^ (List.map strSort sorts |> String.concat " ") - ^ ")(! " - ^ (hash_of_term body) - ^ " " - ^ (weightToSmt wopt) - ^ " " - ^ (pats |> List.map (fun pats -> (List.map hash_of_term pats |> String.concat " ")) |> String.concat "; ") - ^ "))" - | Let (es, body) -> - "(let (" ^ (List.map hash_of_term es |> String.concat " ") ^ ") " ^ hash_of_term body ^ ")" -and hash_of_term tm = hash_of_term' tm.tm - -let mkBoxFunctions s = (s, s ^ "_proj_0") -let boxIntFun = mkBoxFunctions "BoxInt" -let boxBoolFun = mkBoxFunctions "BoxBool" -let boxStringFun = mkBoxFunctions "BoxString" -let boxBitVecFun sz = mkBoxFunctions ("BoxBitVec" ^ (string_of_int sz)) -let boxRealFun = mkBoxFunctions "BoxReal" - -// Assume the Box/Unbox functions to be injective -let isInjective s = - if (FStar.String.length s >= 3) then - String.substring s 0 3 = "Box" && - not (List.existsML (fun c -> c = '.') (FStar.String.list_of_string s)) - else false - -let mk t r = {tm=t; freevars=BU.mk_ref None; rng=r} -let mkTrue r = mk (App(TrueOp, [])) r -let mkFalse r = mk (App(FalseOp, [])) r -let mkUnreachable = mk (App(Var "Unreachable", [])) Range.dummyRange -let mkInteger i r = mk (Integer (ensure_decimal i)) r -let mkInteger' i r = mkInteger (string_of_int i) r -let mkReal i r = mk (Real i) r -let mkBoundV i r = mk (BoundV i) r -let mkFreeV x r = mk (FreeV x) r -let mkApp' f r = mk (App f) r -let mkApp (s, args) r = mk (App (Var s, args)) r -let mkNot t r = match t.tm with - | App(TrueOp, _) -> mkFalse r - | App(FalseOp, _) -> mkTrue r - | _ -> mkApp'(Not, [t]) r -let mkAnd (t1, t2) r = match t1.tm, t2.tm with - | App(TrueOp, _), _ -> t2 - | _, App(TrueOp, _) -> t1 - | App(FalseOp, _), _ - | _, App(FalseOp, _) -> mkFalse r - | App(And, ts1), App(And, ts2) -> mkApp'(And, ts1@ts2) r - | _, App(And, ts2) -> mkApp'(And, t1::ts2) r - | App(And, ts1), _ -> mkApp'(And, ts1@[t2]) r - | _ -> mkApp'(And, [t1;t2]) r -let mkOr (t1, t2) r = match t1.tm, t2.tm with - | App(TrueOp, _), _ - | _, App(TrueOp, _) -> mkTrue r - | App(FalseOp, _), _ -> t2 - | _, App(FalseOp, _) -> t1 - | App(Or, ts1), App(Or, ts2) -> mkApp'(Or, ts1@ts2) r - | _, App(Or, ts2) -> mkApp'(Or, t1::ts2) r - | App(Or, ts1), _ -> mkApp'(Or, ts1@[t2]) r - | _ -> mkApp'(Or, [t1;t2]) r -let mkImp (t1, t2) r = match t1.tm, t2.tm with - | _, App(TrueOp, _) - | App(FalseOp, _), _ -> mkTrue r - | App(TrueOp, _), _ -> t2 - | _, App(Imp, [t1'; t2']) -> mkApp'(Imp, [mkAnd(t1, t1') r; t2']) r - | _ -> mkApp'(Imp, [t1; t2]) r - -let mk_bin_op op (t1,t2) r = mkApp'(op, [t1;t2]) r -let mkMinus t r = mkApp'(Minus, [t]) r -let mkNatToBv sz t r = mkApp'(NatToBv sz, [t]) r -let mkBvUext sz t r = mkApp'(BvUext sz, [t]) r -let mkBvToNat t r = mkApp'(BvToNat, [t]) r -let mkBvAnd = mk_bin_op BvAnd -let mkBvXor = mk_bin_op BvXor -let mkBvOr = mk_bin_op BvOr -let mkBvAdd = mk_bin_op BvAdd -let mkBvSub = mk_bin_op BvSub -let mkBvShl sz (t1, t2) r = mkApp'(BvShl, [t1;(mkNatToBv sz t2 r)]) r -let mkBvShr sz (t1, t2) r = mkApp'(BvShr, [t1;(mkNatToBv sz t2 r)]) r -let mkBvUdiv sz (t1, t2) r = mkApp'(BvUdiv, [t1;(mkNatToBv sz t2 r)]) r -let mkBvMod sz (t1, t2) r = mkApp'(BvMod, [t1;(mkNatToBv sz t2 r)]) r -let mkBvMul sz (t1, t2) r = mkApp' (BvMul, [t1;(mkNatToBv sz t2 r)]) r -let mkBvShl' sz (t1, t2) r = mkApp'(BvShl, [t1;t2]) r -let mkBvShr' sz (t1, t2) r = mkApp'(BvShr, [t1;t2]) r -let mkBvMul' sz (t1, t2) r = mkApp' (BvMul, [t1;t2]) r -let mkBvUdivUnsafe sz (t1, t2) r = mkApp'(BvUdiv, [t1;t2]) r -let mkBvModUnsafe sz (t1, t2) r = mkApp'(BvMod, [t1;t2]) r -let mkBvUlt = mk_bin_op BvUlt -let mkIff = mk_bin_op Iff -let mkEq (t1, t2) r = match t1.tm, t2.tm with - | App (Var f1, [s1]), App (Var f2, [s2]) when f1 = f2 && isInjective f1 -> - mk_bin_op Eq (s1, s2) r - | _ -> mk_bin_op Eq (t1, t2) r -let mkLT = mk_bin_op LT -let mkLTE = mk_bin_op LTE -let mkGT = mk_bin_op GT -let mkGTE = mk_bin_op GTE -let mkAdd = mk_bin_op Add -let mkSub = mk_bin_op Sub -let mkDiv = mk_bin_op Div -let mkRealDiv = mk_bin_op RealDiv -let mkMul = mk_bin_op Mul -let mkMod = mk_bin_op Mod -let mkRealOfInt t r = mkApp ("to_real", [t]) r -let mkITE (t1, t2, t3) r = - match t1.tm with - | App(TrueOp, _) -> t2 - | App(FalseOp, _) -> t3 - | _ -> begin - match t2.tm, t3.tm with - | App(TrueOp,_), App(TrueOp, _) -> mkTrue r - | App(TrueOp,_), _ -> mkImp (mkNot t1 t1.rng, t3) r - | _, App(TrueOp, _) -> mkImp(t1, t2) r - | _, _ -> mkApp'(ITE, [t1; t2; t3]) r - end -let mkCases t r = match t with - | [] -> failwith "Impos" - | hd::tl -> List.fold_left (fun out t -> mkAnd (out, t) r) hd tl - - -let check_pattern_ok (t:term) : option term = - let rec aux t = - match t.tm with - | Integer _ - | String _ - | Real _ - | BoundV _ - | FreeV _ -> None - | Let(tms, tm) -> - aux_l (tm::tms) - | App(head, terms) -> - let head_ok = - match head with - | Var _ -> true - | TrueOp - | FalseOp -> true - | Not - | And - | Or - | Imp - | Iff - | Eq -> false - | LT - | LTE - | GT - | GTE - | Add - | Sub - | Div - | RealDiv - | Mul - | Minus - | Mod -> true - | BvAnd - | BvXor - | BvOr - | BvAdd - | BvSub - | BvShl - | BvShr - | BvUdiv - | BvMod - | BvMul - | BvUlt - | BvUext _ - | NatToBv _ - | BvToNat - | ITE -> false - in - if not head_ok then Some t - else aux_l terms - | Labeled(t, _, _) -> - aux t - | Quant _ - | LblPos _ -> Some t - and aux_l ts = - match ts with - | [] -> None - | t::ts -> - match aux t with - | Some t -> Some t - | None -> aux_l ts - in - aux t - - let rec print_smt_term (t:term) :string = - match t.tm with - | Integer n -> BU.format1 "(Integer %s)" n - | String s -> BU.format1 "(String %s)" s - | Real r -> BU.format1 "(Real %s)" r - | BoundV n -> BU.format1 "(BoundV %s)" (BU.string_of_int n) - | FreeV fv -> BU.format1 "(FreeV %s)" (fv_name fv) - | App (op, l) -> BU.format2 "(%s %s)" (op_to_string op) (print_smt_term_list l) - | Labeled(t, r1, r2) -> BU.format2 "(Labeled '%s' %s)" (Errors.Msg.rendermsg r1) (print_smt_term t) - | LblPos(t, s) -> BU.format2 "(LblPos %s %s)" s (print_smt_term t) - | Quant (qop, l, _, _, t) -> BU.format3 "(%s %s %s)" (qop_to_string qop) (print_smt_term_list_list l) (print_smt_term t) - | Let (es, body) -> BU.format2 "(let %s %s)" (print_smt_term_list es) (print_smt_term body) - -and print_smt_term_list (l:list term) :string = List.map print_smt_term l |> String.concat " " - -and print_smt_term_list_list (l:list (list term)) :string = - List.fold_left (fun s l -> (s ^ "; [ " ^ (print_smt_term_list l) ^ " ] ")) "" l - -let mkQuant r check_pats (qop, pats, wopt, vars, body) = - let all_pats_ok pats = - if not check_pats then pats else - match BU.find_map pats (fun x -> BU.find_map x check_pattern_ok) with - | None -> pats - | Some p -> - begin - Errors.log_issue r Errors.Warning_SMTPatternIllFormed - (BU.format1 "Pattern (%s) contains illegal symbols; dropping it" (print_smt_term p)); - [] - end - in - if List.length vars = 0 then body - else match body.tm with - | App(TrueOp, _) -> body - | _ -> mk (Quant(qop, all_pats_ok pats, wopt, vars, body)) r - -let mkLet (es, body) r = - if List.length es = 0 then body - else mk (Let (es,body)) r - -(*****************************************************) -(* abstracting free names; instantiating bound vars *) -(*****************************************************) -let abstr fvs t = //fvs is a subset of the free vars of t; the result closes over fvs - let nvars = List.length fvs in - let index_of fv = match BU.try_find_index (fv_eq fv) fvs with - | None -> None - | Some i -> Some (nvars - (i + 1)) - in - let rec aux ix t = - match !t.freevars with - | Some [] -> t - | _ -> - begin match t.tm with - | Integer _ - | String _ - | Real _ - | BoundV _ -> t - | FreeV x -> - begin match index_of x with - | None -> t - | Some i -> mkBoundV (i + ix) t.rng - end - | App(op, tms) -> mkApp'(op, List.map (aux ix) tms) t.rng - | Labeled(t, r1, r2) -> mk (Labeled(aux ix t, r1, r2)) t.rng - | LblPos(t, r) -> mk (LblPos(aux ix t, r)) t.rng - | Quant(qop, pats, wopt, vars, body) -> - let n = List.length vars in - mkQuant t.rng false (qop, pats |> List.map (List.map (aux (ix + n))), wopt, vars, aux (ix + n) body) - | Let (es, body) -> - let ix, es_rev = List.fold_left (fun (ix, l) e -> ix+1, aux ix e::l) (ix, []) es in - mkLet (List.rev es_rev, aux ix body) t.rng - end - in - aux 0 t - -let inst tms t = - let tms = List.rev tms in //forall x y . t ... y is an index 0 in t - let n = List.length tms in //instantiate the first n BoundV's with tms, in order - let rec aux shift t = match t.tm with - | Integer _ - | String _ - | Real _ - | FreeV _ -> t - | BoundV i -> - if 0 <= i - shift && i - shift < n - then List.nth tms (i - shift) - else t - | App(op, tms) -> mkApp'(op, List.map (aux shift) tms) t.rng - | Labeled(t, r1, r2) -> mk (Labeled(aux shift t, r1, r2)) t.rng - | LblPos(t, r) -> mk (LblPos(aux shift t, r)) t.rng - | Quant(qop, pats, wopt, vars, body) -> - let m = List.length vars in - let shift = shift + m in - mkQuant t.rng false (qop, pats |> List.map (List.map (aux shift)), wopt, vars, aux shift body) - | Let (es, body) -> - let shift, es_rev = List.fold_left (fun (ix, es) e -> shift+1, aux shift e::es) (shift, []) es in - mkLet (List.rev es_rev, aux shift body) t.rng - in - aux 0 t - -let subst (t:term) (fv:fv) (s:term) = inst [s] (abstr [fv] t) -let mkQuant' r (qop, pats, wopt, vars, body) = - mkQuant r true (qop, pats |> List.map (List.map (abstr vars)), wopt, List.map fv_sort vars, abstr vars body) - -//these are the external facing functions for building quantifiers -let mkForall r (pats, vars, body) = - mkQuant' r (Forall, pats, None, vars, body) -let mkForall'' r (pats, wopt, sorts, body) = - mkQuant r true (Forall, pats, wopt, sorts, body) -let mkForall' r (pats, wopt, vars, body) = - mkQuant' r (Forall, pats, wopt, vars, body) -let mkExists r (pats, vars, body) = - mkQuant' r (Exists, pats, None, vars, body) - -let mkLet' (bindings, body) r = - let vars, es = List.split bindings in - mkLet (es, abstr vars body) r - -let norng = Range.dummyRange -let mkDefineFun (nm, vars, s, tm, c) = DefineFun(nm, List.map fv_sort vars, s, abstr vars tm, c) -let constr_id_of_sort sort = format1 "%s_constr_id" (strSort sort) -let fresh_token (tok_name, sort) id = - let a_name = "fresh_token_" ^tok_name in - let tm = mkEq(mkInteger' id norng, - mkApp(constr_id_of_sort sort, - [mkApp (tok_name,[]) norng]) norng) norng in - let a = {assumption_name=escape a_name; - assumption_caption=Some "fresh token"; - assumption_term=tm; - assumption_fact_ids=[]; - assumption_free_names=free_top_level_names tm} in - Assume a - -let fresh_constructor rng (name, arg_sorts, sort, id) = - let id = string_of_int id in - let bvars = arg_sorts |> List.mapi (fun i s -> mkFreeV(mk_fv ("x_" ^ string_of_int i, s)) norng) in - let bvar_names = List.map fv_of_term bvars in - let capp = mkApp(name, bvars) norng in - let cid_app = mkApp(constr_id_of_sort sort, [capp]) norng in - let a_name = "constructor_distinct_" ^name in - let tm = mkForall rng ([[capp]], bvar_names, mkEq(mkInteger id norng, cid_app) norng) in - let a = { - assumption_name=escape a_name; - assumption_caption=Some "Constructor distinct"; - assumption_term=tm; - assumption_fact_ids=[]; - assumption_free_names=free_top_level_names tm - } in - Assume a - -let injective_constructor - (rng:Range.range) - ((name, fields, sort):(string & list constructor_field & sort)) :list decl = - let n_bvars = List.length fields in - let bvar_name i = "x_" ^ string_of_int i in - let bvar_index i = n_bvars - (i + 1) in - let bvar i s = mkFreeV <| mk_fv (bvar_name i, s) in - let bvars = fields |> List.mapi (fun i f -> bvar i f.field_sort norng) in - let bvar_names = List.map fv_of_term bvars in - let capp = mkApp(name, bvars) norng in - fields - |> List.mapi (fun i {field_projectible=projectible; field_name=name; field_sort=s} -> - if projectible - then - let cproj_app = mkApp(name, [capp]) norng in - let proj_name = DeclFun(name, [sort], s, Some "Projector") in - let tm = mkForall rng ([[capp]], bvar_names, mkEq(cproj_app, bvar i s norng) norng) in - let a = { - assumption_name = escape ("projection_inverse_"^name); - assumption_caption = Some "Projection inverse"; - assumption_term = tm; - assumption_fact_ids = []; - assumption_free_names = free_top_level_names tm - } in - [proj_name; Assume a] - else []) - |> List.flatten - -let discriminator_name constr = "is-"^constr.constr_name - -let constructor_to_decl rng constr = - let sort = constr.constr_sort in - let field_sorts = constr.constr_fields |> List.map (fun f -> f.field_sort) in - let cdecl = DeclFun(constr.constr_name, field_sorts, constr.constr_sort, Some "Constructor") in - let cid = - match constr.constr_id with - | None -> [] - | Some id -> [fresh_constructor rng (constr.constr_name, field_sorts, sort, id)] - in - let disc = - let disc_name = discriminator_name constr in - let xfv = mk_fv ("x", sort) in - let xx = mkFreeV xfv norng in - let proj_terms, ex_vars = - constr.constr_fields - |> List.mapi (fun i {field_projectible=projectible; field_sort=s; field_name=proj} -> - if projectible - then mkApp(proj, [xx]) norng, [] - else let fi = mk_fv ("f_" ^ BU.string_of_int i, s) in - mkFreeV fi norng, [fi]) - |> List.split in - let ex_vars = List.flatten ex_vars in - let disc_inv_body = mkEq(xx, mkApp(constr.constr_name, proj_terms) norng) norng in - let disc_inv_body = match ex_vars with - | [] -> disc_inv_body - | _ -> mkExists norng ([], ex_vars, disc_inv_body) in - let disc_ax = - match constr.constr_id with - | None -> disc_inv_body - | Some id -> - let disc_eq = mkEq(mkApp(constr_id_of_sort constr.constr_sort, [xx]) norng, mkInteger (string_of_int id) norng) norng in - mkAnd(disc_eq, disc_inv_body) norng in - let def = mkDefineFun(disc_name, [xfv], Bool_sort, - disc_ax, - Some "Discriminator definition") in - def in - let projs = injective_constructor rng (constr.constr_name, constr.constr_fields, sort) in - let base = - if not constr.constr_base - then [] - else ( - let arg_sorts = - constr.constr_fields - |> List.filter (fun f -> f.field_projectible) - |> List.map (fun _ -> Term_sort) - in - let base_name = constr.constr_name ^ "@base" in - let decl = DeclFun(base_name, arg_sorts, Term_sort, Some "Constructor base") in - let formals = List.mapi (fun i _ -> mk_fv ("x" ^ string_of_int i, Term_sort)) constr.constr_fields in - let constructed_term = mkApp(constr.constr_name, List.map (fun fv -> mkFreeV fv norng) formals) norng in - let inj_formals = List.flatten <| List.map2 (fun f fld -> if fld.field_projectible then [f] else []) formals constr.constr_fields in - let base_term = mkApp(base_name, List.map (fun fv -> mkFreeV fv norng) inj_formals) norng in - let eq = mkEq(constructed_term, base_term) norng in - let guard = mkApp(discriminator_name constr, [constructed_term]) norng in - let q = mkForall rng ([[constructed_term]], formals, mkImp (guard, eq) norng) in - //forall (x0...xn:Term). {:pattern (C x0 ...xn)} is-C (C x0..xn) ==> C x0..xn == C-base x2 x3..xn - let a = { - assumption_name=escape ("constructor_base_" ^ constr.constr_name); - assumption_caption=Some "Constructor base"; - assumption_term=q; - assumption_fact_ids=[]; - assumption_free_names=free_top_level_names q - } in - [decl; Assume a] - ) - in - Caption (format1 "" constr.constr_name):: - [cdecl]@cid@projs@[disc]@base - @[Caption (format1 "" constr.constr_name)] - -(****************************************************************************) -(* Standard SMTLib prelude for F* and some term constructors *) -(****************************************************************************) -let name_binders_inner prefix_opt (outer_names:list fv) start sorts = - let names, binders, n = sorts |> List.fold_left (fun (names, binders, n) s -> - let prefix = match s with - | Term_sort -> "@x" - | _ -> "@u" in - let prefix = - match prefix_opt with - | None -> prefix - | Some p -> p ^ prefix in - let nm = prefix ^ string_of_int n in - let names = mk_fv (nm,s)::names in - let b = BU.format2 "(%s %s)" nm (strSort s) in - names, b::binders, n+1) - (outer_names, [], start) in - names, List.rev binders, n - -let name_macro_binders sorts = - let names, binders, n = name_binders_inner (Some "__") [] 0 sorts in - List.rev names, binders - -let termToSmt - : print_ranges:bool -> enclosing_name:string -> t:term -> string - = - //a counter and a hash table for string constants to integer ids mapping - let string_id_counter = BU.mk_ref 0 in - let string_cache= BU.smap_create 20 in - - fun print_ranges enclosing_name t -> - let next_qid = - let ctr = BU.mk_ref 0 in - fun depth -> - let n = !ctr in - BU.incr ctr; - if n = 0 then enclosing_name - else BU.format2 "%s.%s" enclosing_name (BU.string_of_int n) - in - let remove_guard_free pats = - pats |> List.map (fun ps -> - ps |> List.map (fun tm -> - match tm.tm with - | App(Var "Prims.guard_free", [{tm=BoundV _}]) -> tm - | App(Var "Prims.guard_free", [p]) -> p - | _ -> tm)) - in - let rec aux' depth n (names:list fv) t = - let aux = aux (depth + 1) in - match t.tm with - | Integer i -> i - | Real r -> r - | String s -> - let id_opt = BU.smap_try_find string_cache s in - (match id_opt with - | Some id -> id - | None -> - let id = !string_id_counter |> string_of_int in - BU.incr string_id_counter; - BU.smap_add string_cache s id; - id) - | BoundV i -> - List.nth names i |> fv_name - | FreeV x when fv_force x -> "(" ^ fv_name x ^ " Dummy_value)" //force a thunked name - | FreeV x -> fv_name x - | App(op, []) -> op_to_string op - | App(op, tms) -> BU.format2 "(%s %s)" (op_to_string op) (List.map (aux n names) tms |> String.concat "\n") - | Labeled(t, _, _) -> aux n names t - | LblPos(t, s) -> BU.format2 "(! %s :lblpos %s)" (aux n names t) s - | Quant(qop, pats, wopt, sorts, body) -> - let qid = next_qid () in - let names, binders, n = name_binders_inner None names n sorts in - let binders = binders |> String.concat " " in - let pats = remove_guard_free pats in - let pats_str = - match pats with - | [[]] - | [] -> if print_ranges then ";;no pats" else "" - | _ -> - pats - |> List.map (fun pats -> - format1 "\n:pattern (%s)" (String.concat " " (List.map (fun p -> - format1 "%s" (aux n names p)) pats))) - |> String.concat "\n" - in - BU.format "(%s (%s)\n (! %s\n %s\n%s\n:qid %s))" - [qop_to_string qop; - binders; - aux n names body; - weightToSmt wopt; - pats_str; - qid] - - | Let (es, body) -> - (* binders are reversed but according to the smt2 standard *) - (* substitution should occur in parallel and order should not matter *) - let names, binders, n = - List.fold_left (fun (names0, binders, n0) e -> - let nm = "@lb" ^ string_of_int n0 in - let names0 = mk_fv (nm, Term_sort)::names0 in - let b = BU.format2 "(%s %s)" nm (aux n names e) in - names0, b::binders, n0+1) - (names, [], n) - es - in - BU.format2 "(let (%s)\n%s)" - (String.concat " " binders) - (aux n names body) - - and aux depth n names t = - let s = aux' depth n names t in - if print_ranges && t.rng <> norng - then BU.format3 "\n;; def=%s; use=%s\n%s\n" (Range.string_of_range t.rng) (Range.string_of_use_range t.rng) s - else s - in - aux 0 0 [] t - -let caption_to_string print_captions = - function - | Some c - when print_captions -> - let c = String.split ['\n'] c |> List.map BU.trim_string |> String.concat " " in - ";;;;;;;;;;;;;;;;" ^ c ^ "\n" - | _ -> "" - - -let rec declToSmt' print_captions z3options decl = - match decl with - | DefPrelude -> - mkPrelude z3options - | Module (s, decls) -> - let res = List.map (declToSmt' print_captions z3options) decls |> String.concat "\n" in - if Options.keep_query_captions() - then BU.format5 "\n;;; Start %s\n%s\n;;; End %s (%s decls; total size %s)" - s - res - s - (BU.string_of_int (List.length decls)) - (BU.string_of_int (String.length res)) - else res - | Caption c -> - if print_captions - then "\n" ^ (BU.splitlines c |> List.map (fun s -> "; " ^ s ^ "\n") |> String.concat "") - else "" - | DeclFun(f,argsorts,retsort,c) -> - let l = List.map strSort argsorts in - format4 "%s(declare-fun %s (%s) %s)" - (caption_to_string print_captions c) - f - (String.concat " " l) - (strSort retsort) - | DefineFun(f,arg_sorts,retsort,body,c) -> - let names, binders = name_macro_binders arg_sorts in - let body = inst (List.map (fun x -> mkFreeV x norng) names) body in - format5 "%s(define-fun %s (%s) %s\n %s)" - (caption_to_string print_captions c) - f - (String.concat " " binders) - (strSort retsort) - (termToSmt print_captions (escape f) body) - | Assume a -> - let fact_ids_to_string ids = - ids |> List.map (function - | Name n -> "Name " ^ Ident.string_of_lid n - | Namespace ns -> "Namespace " ^ Ident.string_of_lid ns - | Tag t -> "Tag " ^t) - in - let fids = - if print_captions - then BU.format1 ";;; Fact-ids: %s\n" - (String.concat "; " (fact_ids_to_string a.assumption_fact_ids)) - else "" in - let n = a.assumption_name in - format4 "%s%s(assert (! %s\n:named %s))" - (caption_to_string print_captions a.assumption_caption) - fids - (termToSmt print_captions n a.assumption_term) - n - | Eval t -> - format1 "(eval %s)" (termToSmt print_captions "eval" t) - | Echo s -> - format1 "(echo \"%s\")" s - | RetainAssumptions _ -> - "" - | CheckSat -> "(echo \"\")\n(check-sat)\n(echo \"\")" - | GetUnsatCore -> "(echo \"\")\n(get-unsat-core)\n(echo \"\")" - | Push n -> BU.format1 "(push) ;; push{%s" (show n) - | Pop n -> BU.format1 "(pop) ;; %s}pop" (show n) - | SetOption (s, v) -> format2 "(set-option :%s %s)" s v - | GetStatistics -> "(echo \"\")\n(get-info :all-statistics)\n(echo \"\")" - | GetReasonUnknown-> "(echo \"\")\n(get-info :reason-unknown)\n(echo \"\")" - -and declToSmt z3options decl = declToSmt' (Options.keep_query_captions()) z3options decl - -and mkPrelude z3options = - let basic = z3options ^ - "(declare-sort FString)\n\ - (declare-fun FString_constr_id (FString) Int)\n\ - \n\ - (declare-sort Term)\n\ - (declare-fun Term_constr_id (Term) Int)\n\ - (declare-sort Dummy_sort)\n\ - (declare-fun Dummy_value () Dummy_sort)\n\ - (declare-datatypes () ((Fuel \n\ - (ZFuel) \n\ - (SFuel (prec Fuel)))))\n\ - (declare-fun MaxIFuel () Fuel)\n\ - (declare-fun MaxFuel () Fuel)\n\ - (declare-fun PreType (Term) Term)\n\ - (declare-fun Valid (Term) Bool)\n\ - (declare-fun HasTypeFuel (Fuel Term Term) Bool)\n\ - (define-fun HasTypeZ ((x Term) (t Term)) Bool\n\ - (HasTypeFuel ZFuel x t))\n\ - (define-fun HasType ((x Term) (t Term)) Bool\n\ - (HasTypeFuel MaxIFuel x t))\n\ - (declare-fun IsTotFun (Term) Bool)\n - ;;fuel irrelevance\n\ - (assert (forall ((f Fuel) (x Term) (t Term))\n\ - (! (= (HasTypeFuel (SFuel f) x t)\n\ - (HasTypeZ x t))\n\ - :pattern ((HasTypeFuel (SFuel f) x t)))))\n\ - (declare-fun NoHoist (Term Bool) Bool)\n\ - ;;no-hoist\n\ - (assert (forall ((dummy Term) (b Bool))\n\ - (! (= (NoHoist dummy b)\n\ - b)\n\ - :pattern ((NoHoist dummy b)))))\n\ - (define-fun IsTyped ((x Term)) Bool\n\ - (exists ((t Term)) (HasTypeZ x t)))\n\ - (declare-fun ApplyTF (Term Fuel) Term)\n\ - (declare-fun ApplyTT (Term Term) Term)\n\ - (declare-fun Prec (Term Term) Bool)\n\ - (assert (forall ((x Term) (y Term) (z Term))\n\ - (! (implies (and (Prec x y) (Prec y z))\n\ - (Prec x z)) - :pattern ((Prec x z) (Prec x y)))))\n\ - (assert (forall ((x Term) (y Term))\n\ - (implies (Prec x y)\n\ - (not (Prec y x)))))\n\ - (declare-fun Closure (Term) Term)\n\ - (declare-fun ConsTerm (Term Term) Term)\n\ - (declare-fun ConsFuel (Fuel Term) Term)\n\ - (declare-fun Tm_uvar (Int) Term)\n\ - (define-fun Reify ((x Term)) Term x)\n\ - (declare-fun Prims.precedes (Term Term Term Term) Term)\n\ - (declare-fun Range_const (Int) Term)\n\ - (declare-fun _mul (Int Int) Int)\n\ - (declare-fun _div (Int Int) Int)\n\ - (declare-fun _mod (Int Int) Int)\n\ - (declare-fun __uu__PartialApp () Term)\n\ - (assert (forall ((x Int) (y Int)) (! (= (_mul x y) (* x y)) :pattern ((_mul x y)))))\n\ - (assert (forall ((x Int) (y Int)) (! (= (_div x y) (div x y)) :pattern ((_div x y)))))\n\ - (assert (forall ((x Int) (y Int)) (! (= (_mod x y) (mod x y)) :pattern ((_mod x y)))))\n\ - (declare-fun _rmul (Real Real) Real)\n\ - (declare-fun _rdiv (Real Real) Real)\n\ - (assert (forall ((x Real) (y Real)) (! (= (_rmul x y) (* x y)) :pattern ((_rmul x y)))))\n\ - (assert (forall ((x Real) (y Real)) (! (= (_rdiv x y) (/ x y)) :pattern ((_rdiv x y)))))\n\ - (define-fun Unreachable () Bool false)" - in - let as_constr (name, fields, sort, id, _injective) - : constructor_t - = { constr_name=name; - constr_fields=List.map (fun (field_name, field_sort, field_projectible) -> {field_name; field_sort; field_projectible}) fields; - constr_sort=sort; - constr_id=Some id; - constr_base=false } - in - let constrs : constructors = - List.map as_constr - [("FString_const", ["FString_const_proj_0", Int_sort, true], String_sort, 0, true); - ("Tm_type", [], Term_sort, 2, true); - ("Tm_arrow", [("Tm_arrow_id", Int_sort, true)], Term_sort, 3, false); - ("Tm_unit", [], Term_sort, 6, true); - (fst boxIntFun, [snd boxIntFun, Int_sort, true], Term_sort, 7, true); - (fst boxBoolFun, [snd boxBoolFun, Bool_sort, true], Term_sort, 8, true); - (fst boxStringFun, [snd boxStringFun, String_sort, true], Term_sort, 9, true); - (fst boxRealFun, [snd boxRealFun, Sort "Real", true], Term_sort, 10, true)] in - let bcons = constrs |> List.collect (constructor_to_decl norng) - |> List.map (declToSmt z3options) |> String.concat "\n" in - - let precedes_partial_app = "\n\ - (declare-fun Prims.precedes@tok () Term)\n\ - (assert\n\ - (forall ((@x0 Term) (@x1 Term) (@x2 Term) (@x3 Term))\n\ - (! (= (ApplyTT (ApplyTT (ApplyTT (ApplyTT Prims.precedes@tok\n\ - @x0)\n\ - @x1)\n\ - @x2)\n\ - @x3)\n\ - (Prims.precedes @x0 @x1 @x2 @x3))\n\ - \n\ - :pattern ((ApplyTT (ApplyTT (ApplyTT (ApplyTT Prims.precedes@tok\n\ - @x0)\n\ - @x1)\n\ - @x2)\n\ - @x3)))))\n" in - - let lex_ordering = "\n(declare-fun Prims.lex_t () Term)\n\ - (assert (forall ((t1 Term) (t2 Term) (e1 Term) (e2 Term))\n\ - (! (iff (Valid (Prims.precedes t1 t2 e1 e2))\n\ - (Valid (Prims.precedes Prims.lex_t Prims.lex_t e1 e2)))\n\ - :pattern (Prims.precedes t1 t2 e1 e2))))\n\ - (assert (forall ((t1 Term) (t2 Term))\n\ - (! (iff (Valid (Prims.precedes Prims.lex_t Prims.lex_t t1 t2)) \n\ - (Prec t1 t2))\n\ - :pattern ((Prims.precedes Prims.lex_t Prims.lex_t t1 t2)))))\n" in - - let valid_intro = - "(assert (forall ((e Term) (t Term))\n\ - (! (implies (HasType e t)\n\ - (Valid t))\n\ - :pattern ((HasType e t)\n\ - (Valid t))\n\ - :qid __prelude_valid_intro)))\n" - in - let valid_elim = - "(assert (forall ((t Term))\n\ - (! (implies (Valid t)\n\ - (exists ((e Term)) (HasType e t)))\n\ - :pattern ((Valid t))\n\ - :qid __prelude_valid_elim)))\n" - in - basic - ^ bcons - ^ precedes_partial_app - ^ lex_ordering - ^ (if FStar.Options.smtencoding_valid_intro() - then valid_intro - else "") - ^ (if FStar.Options.smtencoding_valid_elim() - then valid_elim - else "") - -let declsToSmt z3options decls = List.map (declToSmt z3options) decls |> String.concat "\n" -let declToSmt_no_caps z3options decl = declToSmt' false z3options decl - -(* Generate boxing/unboxing functions for bitvectors of various sizes. *) -(* For ids, to avoid dealing with generation of fresh ids, - I am computing them based on the size in this not very robust way. - z3options are only used by the prelude so passing the empty string should be ok. *) -let mkBvConstructor (sz : int) = - let constr : constructor_t = { - constr_name=fst (boxBitVecFun sz); - constr_sort=Term_sort; - constr_id=None; - constr_fields=[{field_projectible=true; field_name=snd (boxBitVecFun sz); field_sort=BitVec_sort sz }]; - constr_base=false - } in - constructor_to_decl norng constr, - constr.constr_name, - discriminator_name constr - -let __range_c = BU.mk_ref 0 -let mk_Range_const () = - let i = !__range_c in - __range_c := !__range_c + 1; - mkApp("Range_const", [mkInteger' i norng]) norng - -let mk_Term_type = mkApp("Tm_type", []) norng -let mk_Term_app t1 t2 r = mkApp("Tm_app", [t1;t2]) r -let mk_Term_uvar i r = mkApp("Tm_uvar", [mkInteger' i norng]) r -let mk_Term_unit = mkApp("Tm_unit", []) norng -let elim_box cond u v t = - match t.tm with - | App(Var v', [t]) when v=v' && cond -> t - | _ -> mkApp(u, [t]) t.rng -let maybe_elim_box u v t = - elim_box (Options.smtencoding_elim_box()) u v t -let boxInt t = maybe_elim_box (fst boxIntFun) (snd boxIntFun) t -let unboxInt t = maybe_elim_box (snd boxIntFun) (fst boxIntFun) t -let boxBool t = maybe_elim_box (fst boxBoolFun) (snd boxBoolFun) t -let unboxBool t = maybe_elim_box (snd boxBoolFun) (fst boxBoolFun) t -let boxString t = maybe_elim_box (fst boxStringFun) (snd boxStringFun) t -let unboxString t = maybe_elim_box (snd boxStringFun) (fst boxStringFun) t -let boxReal t = maybe_elim_box (fst boxRealFun) (snd boxRealFun) t -let unboxReal t = maybe_elim_box (snd boxRealFun) (fst boxRealFun) t -let boxBitVec (sz:int) t = - elim_box true (fst (boxBitVecFun sz)) (snd (boxBitVecFun sz)) t -let unboxBitVec (sz:int) t = - elim_box true (snd (boxBitVecFun sz)) (fst (boxBitVecFun sz)) t -let boxTerm sort t = match sort with - | Int_sort -> boxInt t - | Bool_sort -> boxBool t - | String_sort -> boxString t - | BitVec_sort sz -> boxBitVec sz t - | Sort "Real" -> boxReal t - | _ -> raise Impos -let unboxTerm sort t = match sort with - | Int_sort -> unboxInt t - | Bool_sort -> unboxBool t - | String_sort -> unboxString t - | BitVec_sort sz -> unboxBitVec sz t - | Sort "Real" -> unboxReal t - | _ -> raise Impos - -let getBoxedInteger (t:term) = - match t.tm with - | App(Var s, [t2]) when s = fst boxIntFun -> - begin - match t2.tm with - | Integer n -> Some (int_of_string n) - | _ -> None - end - | _ -> None - -let mk_PreType t = mkApp("PreType", [t]) t.rng -let mk_Valid t = match t.tm with - | App(Var "Prims.b2t", [{tm=App(Var "Prims.op_Equality", [_; t1; t2])}]) -> mkEq (t1, t2) t.rng - | App(Var "Prims.b2t", [{tm=App(Var "Prims.op_disEquality", [_; t1; t2])}]) -> mkNot (mkEq (t1, t2) norng) t.rng - | App(Var "Prims.b2t", [{tm=App(Var "Prims.op_LessThanOrEqual", [t1; t2])}]) -> mkLTE (unboxInt t1, unboxInt t2) t.rng - | App(Var "Prims.b2t", [{tm=App(Var "Prims.op_LessThan", [t1; t2])}]) -> mkLT (unboxInt t1, unboxInt t2) t.rng - | App(Var "Prims.b2t", [{tm=App(Var "Prims.op_GreaterThanOrEqual", [t1; t2])}]) -> mkGTE (unboxInt t1, unboxInt t2) t.rng - | App(Var "Prims.b2t", [{tm=App(Var "Prims.op_GreaterThan", [t1; t2])}]) -> mkGT (unboxInt t1, unboxInt t2) t.rng - | App(Var "Prims.b2t", [{tm=App(Var "Prims.op_AmpAmp", [t1; t2])}]) -> mkAnd (unboxBool t1, unboxBool t2) t.rng - | App(Var "Prims.b2t", [{tm=App(Var "Prims.op_BarBar", [t1; t2])}]) -> mkOr (unboxBool t1, unboxBool t2) t.rng - | App(Var "Prims.b2t", [{tm=App(Var "Prims.op_Negation", [t])}]) -> mkNot (unboxBool t) t.rng - | App(Var "Prims.b2t", [{tm=App(Var "FStar.BV.bvult", [t0; t1;t2])}]) - | App(Var "Prims.equals", [_; {tm=App(Var "FStar.BV.bvult", [t0; t1;t2])}; _]) - when (FStar.Compiler.Util.is_some (getBoxedInteger t0))-> - // sometimes b2t gets needlessly normalized... - let sz = match getBoxedInteger t0 with | Some sz -> sz | _ -> failwith "impossible" in - mkBvUlt (unboxBitVec sz t1, unboxBitVec sz t2) t.rng - | App(Var "Prims.b2t", [t1]) -> {unboxBool t1 with rng=t.rng} - | _ -> - mkApp("Valid", [t]) t.rng -let mk_unit_type = mkApp("Prims.unit", []) norng -let mk_subtype_of_unit v = mkApp("Prims.subtype_of", [v;mk_unit_type]) v.rng -let mk_HasType v t = mkApp("HasType", [v;t]) t.rng -let mk_HasTypeZ v t = mkApp("HasTypeZ", [v;t]) t.rng -let mk_IsTotFun t = mkApp("IsTotFun", [t]) t.rng -let mk_HasTypeFuel f v t = - if Options.unthrottle_inductives() - then mk_HasType v t - else mkApp("HasTypeFuel", [f;v;t]) t.rng -let mk_HasTypeWithFuel f v t = match f with - | None -> mk_HasType v t - | Some f -> mk_HasTypeFuel f v t -let mk_NoHoist dummy b = mkApp("NoHoist", [dummy;b]) b.rng -let mk_tester n t = mkApp("is-"^n, [t]) t.rng -let mk_ApplyTF t t' = mkApp("ApplyTF", [t;t']) t.rng -let mk_ApplyTT t t' r = mkApp("ApplyTT", [t;t']) r -let kick_partial_app t = mk_ApplyTT (mkApp("__uu__PartialApp", []) t.rng) t t.rng |> mk_Valid -let mk_String_const s r = mkApp ("FString_const", [mk (String s) r]) r -let mk_Precedes x1 x2 x3 x4 r = mkApp("Prims.precedes", [x1;x2;x3;x4]) r|> mk_Valid -let rec n_fuel n = - if n = 0 then mkApp("ZFuel", []) norng - else mkApp("SFuel", [n_fuel (n - 1)]) norng - -let mk_and_l l r = List.fold_right (fun p1 p2 -> mkAnd(p1, p2) r) l (mkTrue r) - -let mk_or_l l r = List.fold_right (fun p1 p2 -> mkOr(p1,p2) r) l (mkFalse r) - -let mk_haseq t = mk_Valid (mkApp ("Prims.hasEq", [t]) t.rng) -let dummy_sort = Sort "Dummy_sort" - -instance showable_smt_term = { - show = print_smt_term; -} - -instance showable_decl = { - show = declToSmt_no_caps ""; -} - -let rec names_of_decl d = - match d with - | Assume a -> [a.assumption_name] - | Module (_, ds) -> List.collect names_of_decl ds - | _ -> [] - -let decl_to_string_short d = - match d with - | DefPrelude -> "prelude" - | DeclFun (s, _, _, _) -> "DeclFun " ^ s - | DefineFun (s, _, _, _, _) -> "DefineFun " ^ s - | Assume a -> "Assumption " ^ a.assumption_name - | Caption s -> "Caption " ^s - | Module (s, _) -> "Module " ^ s - | Eval _ -> "Eval" - | Echo s -> "Echo " ^ s - | RetainAssumptions _ -> "RetainAssumptions" - | Push n -> BU.format1 "push %s" (show n) - | Pop n -> BU.format1 "pop %s" (show n) - | CheckSat -> "check-sat" - | GetUnsatCore -> "get-unsat-core" - | SetOption (s, v) -> "SetOption " ^ s ^ " " ^ v - | GetStatistics -> "get-statistics" - | GetReasonUnknown -> "get-reason-unknown" \ No newline at end of file diff --git a/src/smtencoding/FStar.SMTEncoding.Term.fsti b/src/smtencoding/FStar.SMTEncoding.Term.fsti deleted file mode 100644 index 899086cb4c2..00000000000 --- a/src/smtencoding/FStar.SMTEncoding.Term.fsti +++ /dev/null @@ -1,332 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.SMTEncoding.Term - -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.Util -open FStar.Class.Show -open FStar.Compiler.List -open FStar.Class.Ord - -module S = FStar.Syntax.Syntax - -type sort = - | Bool_sort - | Int_sort - | String_sort - | Term_sort - | Fuel_sort - | BitVec_sort of int - | Array of sort & sort - | Arrow of sort & sort - | Sort of string - -type op = - | TrueOp - | FalseOp - | Not - | And - | Or - | Imp - | Iff - | Eq - | LT - | LTE - | GT - | GTE - | Add - | Sub - | Div - | RealDiv - | Mul - | Minus - | Mod - | BvAnd - | BvXor - | BvOr - | BvAdd - | BvSub - | BvShl - | BvShr - | BvUdiv - | BvMod - | BvMul - | BvUlt - | BvUext of int - | NatToBv of int - | BvToNat - | ITE - | Var of string - -type qop = - | Forall - | Exists - -type term' = - | Integer of string - | String of string - | Real of string - | BoundV of int - | FreeV of fv - | App of op & list term - | Quant of qop & list (list pat) & option int & list sort & term - | Let of list term & term - | Labeled of term & Errors.error_message & Range.range - | LblPos of term & string // FIXME: this case is unused -and pat = term -and term = {tm:term'; freevars:S.memo fvs; rng:Range.range} -and fv = | FV of string & sort & bool (* bool iff variable must be forced/unthunked *) -and fvs = list fv - -type caption = option string -type binders = list (string & sort) -type constructor_field = { - field_name:string; //name of the field - field_sort:sort; //sort of the field - field_projectible:bool//true if the field is projectible -} -type constructor_t = { - constr_name:string; - constr_fields:list constructor_field; - constr_sort:sort; - constr_id:option int; - //Some i, if a term whose head is this constructor is distinct from - //terms with other head constructors - constr_base: bool; //generate a base to eliminate non-injective arguments -} -type constructors = list constructor_t -type fact_db_id = - | Name of Ident.lid - | Namespace of Ident.lid - | Tag of string -type assumption = { - assumption_term: term; - assumption_caption: caption; - assumption_name: string; - assumption_fact_ids:list fact_db_id; - assumption_free_names: RBSet.t string; -} -type decl = - | DefPrelude - | DeclFun of string & list sort & sort & caption - | DefineFun of string & list sort & sort & term & caption - | Assume of assumption - | Caption of string - | Module of string & list decl - | Eval of term - | Echo of string - | RetainAssumptions of list string - | Push of int - | Pop of int - | CheckSat - | GetUnsatCore - | SetOption of string & string - | GetStatistics - | GetReasonUnknown - -(* - * AR: decls_elt captures a block of "related" decls - * For example, for a Tm_refine_ MD5 symbol, - * decls_elt will have its DeclFun, typing axioms, - * hasEq axiom, interpretation, etc. - * - * This allows the encoding of a module to be "stateless" - * in terms of hashconsing -- the encoding may contain - * duplicate such blocks - * - * Deduplication happens when giving the decls to Z3 - * at which point, if the key below -- which is the MD5 string -- - * matches, the whole block is dropped (see Encode.fs.recover_caching_and_update_env) - * - * Alternative way would have been to do some smt name matching - * but that would be sensitive to name strings and hence brittle - * - * Before the declarations are given to Z3, the remaining decls_elt - * left after deduplication are just "flattened" (using decls_list_of) - * - * sym_name and key are options for cases when we don't care about hashconsing - *) -type decls_elt = { - sym_name: option string; //name of the main synbol, e.g. Tm_refine_ MD5 - key: option string; //the MD5 string - decls: list decl; //list of decls, e.g. typing axioms, hasEq, for a Tm_refine - a_names: list string; //assumption names that must be kept IF this entry has a cache hit - //--used to not filter them when using_facts_from -} - -type decls_t = list decls_elt - -val fv_name : fv -> string -val fv_sort : fv -> sort -val fv_force : fv -> bool -val mk_fv : string & sort -> fv - - -(* - * AR: sym_name -> md5 -> auxiliary decls -> decls - * the auxilkiary decls are those that are not directly related to - * the symbol itself, but must be retained in case of cache hits - * for example, decls for argument types in the case of a Tm_arrow - *) -val mk_decls: string -> string -> list decl -> list decls_elt -> decls_t - -(* - * AR: for when we don't hashcons the decls - *) -val mk_decls_trivial: list decl -> decls_t - -(* - * Flatten the decls_t - *) -val decls_list_of: decls_t -> list decl - -type error_label = (fv & Errors.error_message & Range.range) -type error_labels = list error_label - -val escape: string -> string -val abstr: list fv -> term -> term -val inst: list term -> term -> term -val subst: term -> fv -> term -> term -val mk: term' -> Range.range -> term -val hash_of_term: term -> string -val boxIntFun : string & string -val boxBoolFun : string & string -val boxStringFun : string & string -val boxRealFun: string & string -val fv_eq : fv -> fv -> bool -val fv_of_term : term -> fv -val fvs_subset_of: fvs -> fvs -> bool -val free_variables: term -> fvs -val free_top_level_names : term -> RBSet.t string -val mkTrue : (Range.range -> term) -val mkFalse : (Range.range -> term) -val mkUnreachable : term -val mkInteger : string -> Range.range -> term -val mkInteger': int -> Range.range -> term -val mkReal: string -> Range.range -> term -val mkRealOfInt: term -> Range.range -> term -val mkBoundV : int -> Range.range -> term -val mkFreeV : fv -> Range.range -> term -val mkApp' : (op & list term) -> Range.range -> term -val mkApp : (string & list term) -> Range.range -> term -val mkNot : term -> Range.range -> term -val mkMinus: term -> Range.range -> term -val mkAnd : ((term & term) -> Range.range -> term) -val mkOr : ((term & term) -> Range.range -> term) -val mkImp : ((term & term) -> Range.range -> term) -val mkIff : ((term & term) -> Range.range -> term) -val mkEq : ((term & term) -> Range.range -> term) -val mkLT : ((term & term) -> Range.range -> term) -val mkLTE : ((term & term) -> Range.range -> term) -val mkGT: ((term & term) -> Range.range -> term) -val mkGTE: ((term & term) -> Range.range -> term) -val mkAdd: ((term & term) -> Range.range -> term) -val mkSub: ((term & term) -> Range.range -> term) -val mkDiv: ((term & term) -> Range.range -> term) -val mkRealDiv: ((term & term) -> Range.range -> term) -val mkMul: ((term & term) -> Range.range -> term) -val mkMod: ((term & term) -> Range.range -> term) -val mkNatToBv : (int -> term -> Range.range -> term) -val mkBvToNat : (term -> Range.range -> term) -val mkBvAnd : ((term & term) -> Range.range -> term) -val mkBvXor : ((term & term) -> Range.range -> term) -val mkBvOr : ((term & term) -> Range.range -> term) -val mkBvAdd : ((term & term) -> Range.range -> term) -val mkBvSub : ((term & term) -> Range.range -> term) -val mkBvUlt : ((term & term) -> Range.range -> term) -val mkBvUext : (int -> term -> Range.range -> term) -val mkBvShl : (int -> (term & term) -> Range.range -> term) -val mkBvShr : (int -> (term & term) -> Range.range -> term) -val mkBvUdiv : (int -> (term & term) -> Range.range -> term) -val mkBvMod : (int -> (term & term) -> Range.range -> term) -val mkBvMul : (int -> (term & term) -> Range.range -> term) -val mkBvShl' : (int -> (term & term) -> Range.range -> term) -val mkBvShr' : (int -> (term & term) -> Range.range -> term) -val mkBvUdivUnsafe : (int -> (term & term) -> Range.range -> term) -val mkBvModUnsafe : (int -> (term & term) -> Range.range -> term) -val mkBvMul' : (int -> (term & term) -> Range.range -> term) - -val mkITE: (term & term & term) -> Range.range -> term -val mkCases : list term -> Range.range -> term -val check_pattern_ok: term -> option term -val mkForall: Range.range -> (list (list pat) & fvs & term) -> term -val mkForall': Range.range -> (list (list pat) & option int & fvs & term) -> term -val mkForall'': Range.range -> (list (list pat) & option int & list sort & term) -> term -val mkExists: Range.range -> (list (list pat) & fvs & term) -> term -val mkLet: (list term & term) -> Range.range -> term -val mkLet': (list (fv & term) & term) -> Range.range -> term - -val fresh_token: (string & sort) -> int -> decl -val fresh_constructor : Range.range -> (string & list sort & sort & int) -> decl -//val constructor_to_decl_aux: bool -> constructor_t -> decls_t -val constructor_to_decl: Range.range -> constructor_t -> list decl -val mkBvConstructor: int -> list decl & string & string -val declToSmt: string -> decl -> string -val declToSmt_no_caps: string -> decl -> string - -val mk_Term_app : term -> term -> Range.range -> term -val mk_Term_uvar: int -> Range.range -> term -val mk_and_l: list term -> Range.range -> term -val mk_or_l: list term -> Range.range -> term - -val boxInt: term -> term -val unboxInt: term -> term -val boxBool: term -> term -val unboxBool: term -> term -val boxString: term -> term -val unboxString: term -> term -val boxReal: term -> term -val unboxReal: term -> term -val boxBitVec: int -> term -> term -val unboxBitVec: int -> term -> term - -// Thunked, produces a different opaque constant on each call -val mk_Range_const: unit -> term -val mk_Term_unit: term - -val mk_PreType: term -> term -val mk_Valid: term -> term -val mk_subtype_of_unit: term -> term -val mk_HasType: term -> term -> term -val mk_HasTypeZ: term -> term -> term -val mk_IsTotFun: term -> term -val mk_HasTypeFuel: term -> term -> term -> term -val mk_HasTypeWithFuel: option term -> term -> term -> term -val mk_NoHoist: term -> term -> term -val mk_tester: string -> term -> term -val mk_Term_type: term -val mk_ApplyTF: term -> term -> term -val mk_ApplyTT: term -> term -> Range.range -> term -val mk_String_const: string -> Range.range -> term -val mk_Precedes: term -> term -> term -> term -> Range.range -> term -val n_fuel: int -> term - -val mk_haseq: term -> term -val kick_partial_app: term -> term - -val op_to_string: op -> string -val print_smt_term: term -> string -val print_smt_term_list: list term -> string -val print_smt_term_list_list: list (list term) -> string - -val dummy_sort : sort - -instance val showable_smt_term : Class.Show.showable term -instance val showable_decl : showable decl -val names_of_decl (d:decl) : list string -val decl_to_string_short (d:decl) : string \ No newline at end of file diff --git a/src/smtencoding/FStar.SMTEncoding.UnsatCore.fst b/src/smtencoding/FStar.SMTEncoding.UnsatCore.fst deleted file mode 100644 index e612692b5c8..00000000000 --- a/src/smtencoding/FStar.SMTEncoding.UnsatCore.fst +++ /dev/null @@ -1,50 +0,0 @@ -(* - Copyright 2024 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.SMTEncoding.UnsatCore -open FStar.Compiler.Effect -open FStar -open FStar.Compiler -open FStar.SMTEncoding.Term -module BU = FStar.Compiler.Util - -let filter (core:unsat_core) (decls:list decl) -: list decl -= let rec aux theory = - //so that we can use the tail-recursive fold_left - let theory_rev = List.rev theory in - let keep, n_retained, n_pruned = - List.fold_left - (fun (keep, n_retained, n_pruned) d -> - match d with - | Assume a -> - if List.contains a.assumption_name core - then d::keep, n_retained+1, n_pruned - else if BU.starts_with a.assumption_name "@" - then d::keep, n_retained, n_pruned - else keep, n_retained, n_pruned+1 - | Module (name, decls) -> - let keep', n, m = aux decls in - Module(name, keep')::keep, n_retained + n, n_pruned + m - | _ -> d::keep, n_retained, n_pruned) - ([Caption ("UNSAT CORE USED: " ^ (core |> String.concat ", "))],//start with the unsat core caption at the end - 0, - 0) - theory_rev - in - keep, n_retained, n_pruned - in - let keep, _, _ = aux decls in - keep diff --git a/src/smtencoding/FStar.SMTEncoding.UnsatCore.fsti b/src/smtencoding/FStar.SMTEncoding.UnsatCore.fsti deleted file mode 100644 index 82ef8da97f8..00000000000 --- a/src/smtencoding/FStar.SMTEncoding.UnsatCore.fsti +++ /dev/null @@ -1,25 +0,0 @@ -(* - Copyright 2024 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.SMTEncoding.UnsatCore -open FStar.Compiler.Effect -open FStar -open FStar.Compiler -open FStar.SMTEncoding.Term - -type unsat_core = list string - -val filter (s:unsat_core) (decls:list decl) -: list decl \ No newline at end of file diff --git a/src/smtencoding/FStar.SMTEncoding.Util.fst b/src/smtencoding/FStar.SMTEncoding.Util.fst deleted file mode 100644 index ebdcdf26996..00000000000 --- a/src/smtencoding/FStar.SMTEncoding.Util.fst +++ /dev/null @@ -1,142 +0,0 @@ -(* - Copyright 2008-2014 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.SMTEncoding.Util -open FStar.Compiler.Effect - -open FStar -open FStar.Compiler -open FStar.TypeChecker.Env -open FStar.Compiler.Util -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.TypeChecker -open FStar.SMTEncoding.Term -open FStar.Ident -open FStar.Const -open FStar.Class.Setlike -module C = FStar.Parser.Const -module S = FStar.Syntax.Syntax -module U = FStar.Syntax.Util -module SS = FStar.Syntax.Subst -module N = FStar.TypeChecker.Normalize -module TcEnv = FStar.TypeChecker.Env - -let mkAssume (tm, cap, nm) = - Assume ({ - assumption_name=escape nm; - assumption_caption=cap; - assumption_term=tm; - assumption_fact_ids=[]; - assumption_free_names=free_top_level_names tm; - }) -let norng f = fun x -> f x Range.dummyRange -let mkTrue = mkTrue Range.dummyRange -let mkFalse = mkFalse Range.dummyRange -let mkInteger = norng mkInteger -let mkInteger' = norng mkInteger' -let mkReal = norng mkReal -let mkBoundV = norng mkBoundV -let mkFreeV = norng mkFreeV -let mkApp' = norng mkApp' -let mkApp = norng mkApp -let mkNot = norng mkNot -let mkMinus = norng mkMinus -let mkAnd = norng mkAnd -let mkOr = norng mkOr -let mkImp = norng mkImp -let mkIff = norng mkIff -let mkEq = norng mkEq -let mkLT = norng mkLT -let mkLTE = norng mkLTE -let mkGT = norng mkGT -let mkGTE = norng mkGTE -let mkAdd = norng mkAdd -let mkSub = norng mkSub -let mkDiv = norng mkDiv -let mkRealDiv = norng mkRealDiv -let mkMul = norng mkMul -let mkMod = norng mkMod -let mkNatToBv sz = norng (mkNatToBv sz) -let mkBvAnd = norng mkBvAnd -let mkBvXor = norng mkBvXor -let mkBvOr = norng mkBvOr -let mkBvAdd = norng mkBvAdd -let mkBvSub = norng mkBvSub -let mkBvShl sz = norng (mkBvShl sz) -let mkBvShr sz = norng (mkBvShr sz) -let mkBvUdiv sz = norng (mkBvUdiv sz) -let mkBvMod sz = norng (mkBvMod sz) -let mkBvMul sz = norng (mkBvMul sz) -let mkBvShl' sz = norng (mkBvShl' sz) -let mkBvShr' sz = norng (mkBvShr' sz) -let mkBvUdivUnsafe sz = norng (mkBvUdivUnsafe sz) -let mkBvModUnsafe sz = norng (mkBvModUnsafe sz) -let mkBvMul' sz = norng (mkBvMul' sz) -let mkBvUlt = norng mkBvUlt -let mkBvUext sz = norng (mkBvUext sz) -let mkBvToNat = norng mkBvToNat -let mkITE = norng mkITE -let mkCases = norng mkCases - -let norng2 f = fun x y -> f x y Range.dummyRange -let norng3 f = fun x y z -> f x y z Range.dummyRange -let norng4 f = fun x y z w -> f x y z w Range.dummyRange -let mk_Term_app = norng2 mk_Term_app -let mk_Term_uvar = norng mk_Term_uvar -let mk_and_l = norng mk_and_l -let mk_or_l = norng mk_or_l -let mk_ApplyTT = norng2 mk_ApplyTT -let mk_String_const = norng mk_String_const -let mk_Precedes = norng4 mk_Precedes - - -(* - * AR: When encoding abstractions that have a reifiable computation type - * for their bodies, we currently encode their reification - * Earlier this was fine, since the only reifiable effects came from DM4F - * But now layered effects are also reifiable, but I don't think we want - * to encode their reification to smt - * So adding these utils, that are then used in Encode.fs and EncodeTerm.fs - * - * Could revisit - * - * 06/22: reifying if the effect has the smt_reifiable_layered_effect attribute - * 07/02: reverting, until we preserve the indices, no smt reification - *) - -let is_smt_reifiable_effect (en:TcEnv.env) (l:lident) : bool = - let l = TcEnv.norm_eff_name en l in - TcEnv.is_reifiable_effect en l && - not (l |> TcEnv.get_effect_decl en |> U.is_layered) - -let is_smt_reifiable_comp (en:TcEnv.env) (c:S.comp) : bool = - match c.n with - | Comp ct -> is_smt_reifiable_effect en ct.effect_name - | _ -> false - -// -// TAC rc are not smt reifiable -// - -let is_smt_reifiable_rc (en:TcEnv.env) (rc:S.residual_comp) : bool = - rc.residual_effect |> is_smt_reifiable_effect en - -let is_smt_reifiable_function (en:TcEnv.env) (t:S.term) : bool = - match (SS.compress t).n with - | Tm_arrow {comp=c} -> - c |> U.comp_effect_name |> is_smt_reifiable_effect en - | _ -> false diff --git a/src/smtencoding/FStar.SMTEncoding.Z3.fst b/src/smtencoding/FStar.SMTEncoding.Z3.fst deleted file mode 100644 index 6190d285358..00000000000 --- a/src/smtencoding/FStar.SMTEncoding.Z3.fst +++ /dev/null @@ -1,821 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.SMTEncoding.Z3 -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.SMTEncoding.Term -open FStar.BaseTypes -open FStar.Compiler.Util -open FStar.Class.Show -module SolverState = FStar.SMTEncoding.SolverState -module M = FStar.Compiler.Misc -module BU = FStar.Compiler.Util -(****************************************************************************) -(* Z3 Specifics *) -(****************************************************************************) - -(* We only warn once about these things *) -let _already_warned_solver_mismatch : ref bool = BU.mk_ref false -let _already_warned_version_mismatch : ref bool = BU.mk_ref false - -let z3url = "https://github.com/Z3Prover/z3/releases" - -(* Check if [path] is potentially a valid z3, by trying to run -it with -version and checking for non-empty output. Alternatively -we could call [which] on it (if it's not an absolute path), but -we shouldn't rely on the existence of a binary which. *) -let inpath (path:string) : bool = - try - let s = BU.run_process "z3_pathtest" path ["-version"] None in - s <> "" - with - | _ -> false - -(* Find the Z3 executable that we should invoke, according to the -needed version. The logic is as follows: - -- If the user provided the --smt option, use that binary unconditionally. -- If z3-VER (or z3-VER.exe) exists in the PATH (where VER is either - the default version or the user-provided --z3version) use it. -- Otherwise, default to "z3" in the PATH. - -We cache the chosen executable for every Z3 version we've ran. -*) -let z3_exe : unit -> string = - let cache : BU.smap string = BU.smap_create 5 in - let find_or (k:string) (f : string -> string) : string = - match smap_try_find cache k with - | Some v -> v - | None -> - let v = f k in - smap_add cache k v; - v - in - fun () -> - find_or (Options.z3_version()) (fun version -> - let path = - let z3_v = Platform.exe ("z3-" ^ version) in - let smto = Options.smt () in - if Some? smto then Some?.v smto - else if inpath z3_v then z3_v - else Platform.exe "z3" - in - if Debug.any () then - BU.print1 "Chosen Z3 executable: %s\n" path; - path - ) - -type label = string - -let status_tag = function - | SAT _ -> "sat" - | UNSAT _ -> "unsat" - | UNKNOWN _ -> "unknown" - | TIMEOUT _ -> "timeout" - | KILLED -> "killed" - -let status_string_and_errors s = - match s with - | KILLED - | UNSAT _ -> status_tag s, [] - | SAT (errs, msg) - | UNKNOWN (errs, msg) - | TIMEOUT (errs, msg) -> BU.format2 "%s%s" (status_tag s) (match msg with None -> "" | Some msg -> " because " ^ msg), errs - //(match msg with None -> "unknown" | Some msg -> msg), errs - - -let query_logging = - let query_number = BU.mk_ref 0 in - let log_file_opt : ref (option (out_channel & string)) = BU.mk_ref None in - let used_file_names : ref (list (string & int)) = BU.mk_ref [] in - let current_module_name : ref (option string) = BU.mk_ref None in - let current_file_name : ref (option string) = BU.mk_ref None in - let set_module_name n = current_module_name := Some n in - let get_module_name () = - match !current_module_name with - | None -> failwith "Module name not set" - | Some n -> n - in - let next_file_name () = - let n = get_module_name() in - let file_name = - match List.tryFind (fun (m, _) -> n=m) !used_file_names with - | None -> - used_file_names := (n, 0)::!used_file_names; - n - | Some (_, k) -> - used_file_names := (n, k+1)::!used_file_names; - BU.format2 "%s-%s" n (BU.string_of_int (k+1)) - in - BU.format1 "queries-%s.smt2" file_name - in - let new_log_file () = - let file_name = next_file_name() in - current_file_name := Some file_name; - let c = BU.open_file_for_writing file_name in - log_file_opt := Some (c, file_name); - c, file_name - in - let get_log_file () = - match !log_file_opt with - | None -> new_log_file() - | Some c -> c - in - let append_to_log str = - let f, nm = get_log_file () in - BU.append_to_file f str; - nm - in - let write_to_new_log str = - let file_name = next_file_name() in - write_file file_name str; - file_name - in - let write_to_log fresh str = - if fresh - then write_to_new_log str - else append_to_log str - in - let close_log () = - match !log_file_opt with - | None -> () - | Some (c, _) -> - BU.close_out_channel c; log_file_opt := None - in - let log_file_name () = - match !current_file_name with - | None -> failwith "no log file" - | Some n -> n - in - {set_module_name=set_module_name; - get_module_name=get_module_name; - write_to_log=write_to_log; - append_to_log=append_to_log; - close_log=close_log; - } - -(* Z3 background process handling *) -let z3_cmd_and_args () = - let cmd = z3_exe () in - let cmd_args = - List.append ["-smt2"; - "-in"; - Util.format1 "smt.random_seed=%s" (string_of_int (Options.z3_seed ()))] - (Options.z3_cliopt ()) in - (cmd, cmd_args) - -let warn_handler (suf:Errors.error_message) (s:string) : unit = - let open FStar.Errors.Msg in - let open FStar.Pprint in - Errors.log_issue0 Errors.Warning_UnexpectedZ3Output ([ - text "Unexpected output from Z3:" ^^ hardline ^^ - blank 2 ^^ align (dquotes (arbitrary_string s)); - ] @ suf) - -(* Talk to the process to see if it's the correct version of Z3 -(i.e. the one in the optionstate). Also check that it indeed is Z3. By -default, each of these generates an error, but they can be downgraded -into warnings. The warnings are anyway printed only once per F* -invocation. *) -let check_z3version (p:proc) : unit = - let getinfo (arg:string) : string = - let s = BU.ask_process p (Util.format1 "(get-info :%s)\n(echo \"Done!\")\n" arg) (fun _ -> "Killed") (warn_handler []) in - if BU.starts_with s ("(:" ^ arg) then - let ss = String.split ['"'] s in - List.nth ss 1 - else ( - warn_handler [] s; - Errors.raise_error0 Errors.Error_Z3InvocationError (BU.format1 "Could not run Z3 from `%s'" (proc_prog p)) - ) - in - let name = getinfo "name" in - if name <> "Z3" && not (!_already_warned_solver_mismatch) then ( - Errors.log_issue0 Errors.Warning_SolverMismatch - (BU.format3 "Unexpected SMT solver: expected to be talking to Z3, got %s.\n\ - Please download the correct version of Z3 from %s\n\ - and install it into your $PATH as `%s'." - name - z3url (Platform.exe ("z3-" ^ Options.z3_version ()))); - _already_warned_solver_mismatch := true - ); - let ver_found : string = BU.trim_string (List.hd (BU.split (getinfo "version") "-")) in - let ver_conf : string = BU.trim_string (Options.z3_version ()) in - if ver_conf <> ver_found && not (!_already_warned_version_mismatch) then ( - let open FStar.Errors in - let open FStar.Pprint in - Errors.log_issue0 Errors.Warning_SolverMismatch [ - text (BU.format3 "Unexpected Z3 version for '%s': expected '%s', got '%s'." - (proc_prog p) ver_conf ver_found); - prefix 4 1 (text "Please download the correct version of Z3 from") - (url z3url) ^/^ - group (text "and install it into your $PATH as" ^/^ squotes - (doc_of_string (Platform.exe ("z3-" ^ Options.z3_version ()))) ^^ dot); - ]; - Errors.stop_if_err(); (* stop now if this was a hard error *) - _already_warned_version_mismatch := true - ); - () - -let new_z3proc (id:string) (cmd_and_args : string & list string) : BU.proc = - let proc = - try - BU.start_process id (fst cmd_and_args) (snd cmd_and_args) (fun s -> s = "Done!") - with - | e -> - let open FStar.Pprint in - let open FStar.Errors.Msg in - Errors.raise_error0 Errors.Error_Z3InvocationError [ - text "Could not start SMT solver process."; - prefix 2 1 (text "Command:" ) - (fst cmd_and_args |> arbitrary_string |> squotes); - prefix 2 1 (text "Exception:") - (BU.print_exn e |> arbitrary_string); - ] - in - check_z3version proc; - proc - -let new_z3proc_with_id = - let ctr = BU.mk_ref (-1) in - (fun cmd_and_args -> - let p = new_z3proc (BU.format1 "z3-bg-%s" (incr ctr; !ctr |> string_of_int)) cmd_and_args in - p) - -type bgproc = { - ask: string -> string; - refresh: unit -> unit; - restart: unit -> unit; - version: unit -> string; - ctxt: SolverState.solver_state; -} - -let cmd_and_args_to_string cmd_and_args = - String.concat "" [ - "cmd="; (fst cmd_and_args); - " args=["; (String.concat ", " (snd cmd_and_args)); - "]" - ] - -(* the current background process is stored in the_z3proc - the params with which it was started are stored in the_z3proc_params - refresh will kill and restart the process if the params changed or - we have asked the z3 process something - *) -let bg_z3_proc = - let the_z3proc = BU.mk_ref None in - let the_z3proc_params = BU.mk_ref (Some ("", [""])) in - let the_z3proc_ask_count = BU.mk_ref 0 in - let the_z3proc_version = BU.mk_ref "" in - // NOTE: We keep track of the version and restart on changes - // just to be safe: the executable name in the_z3proc_params should - // be enough to distinguish between the different executables. - let make_new_z3_proc cmd_and_args = - the_z3proc := Some (new_z3proc_with_id cmd_and_args); - the_z3proc_params := Some cmd_and_args; - the_z3proc_ask_count := 0 in - the_z3proc_version := Options.z3_version (); - let z3proc () = - if !the_z3proc = None then make_new_z3_proc (z3_cmd_and_args ()); - must (!the_z3proc) - in - let ask input = - incr the_z3proc_ask_count; - let kill_handler () = "\nkilled\n" in - BU.ask_process (z3proc ()) input kill_handler (warn_handler []) - in - let maybe_kill_z3proc () = - if !the_z3proc <> None then begin - BU.kill_process (must (!the_z3proc)); - the_z3proc := None - end - in - let refresh () = - let next_params = z3_cmd_and_args () in - let old_params = must (!the_z3proc_params) in - - let old_version = !the_z3proc_version in - let next_version = Options.z3_version () in - - (* We only refresh the solver if we have used it at all, or if the - parameters/version must be changed. We also force a refresh if log_queries is - on. I (GM 2023/07/23) think this might have been for making sure we get - a new file after checking a dependency, and that it might not be needed - now. However it's not a big performance hit, and it's only when logging - queries, so I'm maintaining this. *) - if Options.log_queries() || - (!the_z3proc_ask_count > 0) || - old_params <> next_params || - old_version <> next_version - then begin - maybe_kill_z3proc(); - if Options.query_stats() - then begin - BU.print3 "Refreshing the z3proc (ask_count=%s old=[%s] new=[%s])\n" - (BU.string_of_int !the_z3proc_ask_count) - (cmd_and_args_to_string old_params) - (cmd_and_args_to_string next_params) - end; - make_new_z3_proc next_params - end; - query_logging.close_log() - in - let restart () = - maybe_kill_z3proc(); - query_logging.close_log(); - let next_params = z3_cmd_and_args () in - make_new_z3_proc next_params - in - let x : list unit = [] in - BU.mk_ref ({ask = BU.with_monitor x ask; - refresh = BU.with_monitor x refresh; - restart = BU.with_monitor x restart; - version = (fun () -> !the_z3proc_version); - ctxt = SolverState.init() }) - - -type smt_output_section = list string -type smt_output = { - smt_result: smt_output_section; - smt_reason_unknown: option smt_output_section; - smt_unsat_core: option smt_output_section; - smt_statistics: option smt_output_section; - smt_labels: option smt_output_section; -} - -let smt_output_sections (log_file:option string) (r:Range.range) (lines:list string) : smt_output = - let rec until tag lines = - match lines with - | [] -> None - | l::lines -> - if tag = l then Some ([], lines) - else BU.map_opt (until tag lines) (fun (until_tag, rest) -> - (l::until_tag, rest)) - in - let start_tag tag = "<" ^ tag ^ ">" in - let end_tag tag = "" in - let find_section tag lines : option (list string) & list string = - match until (start_tag tag) lines with - | None -> None, lines - | Some (prefix, suffix) -> - match until (end_tag tag) suffix with - | None -> failwith ("Parse error: " ^ end_tag tag ^ " not found") - | Some (section, suffix) -> Some section, prefix @ suffix - in - let result_opt, lines = find_section "result" lines in - let result = - match result_opt with - | None -> - failwith - (BU.format1 "Unexpexted output from Z3: no result section found:\n%s" (String.concat "\n" lines)) - | Some result -> result - in - let reason_unknown, lines = find_section "reason-unknown" lines in - let unsat_core, lines = find_section "unsat-core" lines in - let statistics, lines = find_section "statistics" lines in - let labels, lines = find_section "labels" lines in - let remaining = - match until "Done!" lines with - | None -> lines - | Some (prefix, suffix) -> prefix@suffix in - let _ = - match remaining with - | [] -> () - | _ -> - let msg = String.concat "\n" remaining in - let suf = - let open FStar.Errors.Msg in - let open FStar.Pprint in - match log_file with - | Some log_file -> [text "Log file:" ^/^ doc_of_string log_file] - | None -> [] - in - warn_handler suf msg - in - {smt_result = BU.must result_opt; - smt_reason_unknown = reason_unknown; - smt_unsat_core = unsat_core; - smt_statistics = statistics; - smt_labels = labels} - - -let with_solver_state (f: SolverState.solver_state -> 'a & SolverState.solver_state) -: 'a -= let ss = !bg_z3_proc in - let res, ctxt = f ss.ctxt in - bg_z3_proc := { ss with ctxt }; - res -let with_solver_state_unit (f:SolverState.solver_state -> SolverState.solver_state) -: unit -= with_solver_state (fun x -> (), f x) -let reading_solver_state (f:SolverState.solver_state -> 'a) : 'a -= let ss = !bg_z3_proc in - f ss.ctxt -let push msg = - with_solver_state_unit SolverState.push; - with_solver_state_unit (SolverState.give [Caption msg]) -let pop msg = - with_solver_state_unit (SolverState.give [Caption msg]); - with_solver_state_unit SolverState.pop -let snapshot msg = - let d = reading_solver_state SolverState.depth in - push msg; - // let d' = reading_solver_state SolverState.depth in - // BU.print2 "Snapshot moving from %s to %s\n" (show d) (show d'); - d -let rollback msg depth = - let rec rollback_aux msg depth = - let d = reading_solver_state SolverState.depth in - match depth with - | None -> pop msg - | Some n -> - if d = n then () else ( - pop msg; - rollback_aux msg depth - ) - in - // let init = reading_solver_state SolverState.depth in - rollback_aux msg depth - // let final = reading_solver_state SolverState.depth in - // BU.print3 "Rollback(%s) from %s to %s\n" - // (show depth) - // (show init) - // (show final) -let start_query msg roots_to_push qry = - with_solver_state_unit (SolverState.start_query msg roots_to_push qry) -let finish_query msg = - with_solver_state_unit (SolverState.finish_query msg) -let giveZ3 decls = with_solver_state_unit (SolverState.give decls) -let refresh using_facts_from = - (!bg_z3_proc).refresh(); - with_solver_state_unit (SolverState.reset using_facts_from) - -let doZ3Exe (log_file:_) (r:Range.range) (fresh:bool) (input:string) (label_messages:error_labels) (queryid:string) : z3status & z3statistics = - let parse (z3out:string) = - let lines = String.split ['\n'] z3out |> List.map BU.trim_string in - let smt_output = smt_output_sections log_file r lines in - let unsat_core = - match smt_output.smt_unsat_core with - | None -> None - | Some s -> - let s = BU.trim_string (String.concat " " s) in - let s = BU.substring s 1 (String.length s - 2) in - if BU.starts_with s "error" - then None - else Some (BU.split s " " |> BU.sort_with String.compare) - in - let labels = - match smt_output.smt_labels with - | None -> [] - | Some lines -> - let rec lblnegs lines = - match lines with - | lname::"false"::rest when BU.starts_with lname "label_" -> lname::lblnegs rest - | lname::_::rest when BU.starts_with lname "label_" -> lblnegs rest - | _ -> [] in - let lblnegs = lblnegs lines in - lblnegs |> List.collect - (fun l -> match label_messages |> List.tryFind (fun (m, _, _) -> fv_name m = l) with - | None -> [] - | Some (lbl, msg, r) -> [(lbl, msg, r)]) - in - let statistics = - let statistics : z3statistics = BU.smap_create 0 in - match smt_output.smt_statistics with - | None -> statistics - | Some lines -> - let parse_line line = - let pline = BU.split (BU.trim_string line) ":" in - match pline with - | "(" :: entry :: [] - | "" :: entry :: [] -> - let tokens = BU.split entry " " in - let key = List.hd tokens in - let ltok = List.nth tokens ((List.length tokens) - 1) in - let value = if BU.ends_with ltok ")" then (BU.substring ltok 0 ((String.length ltok) - 1)) else ltok in - BU.smap_add statistics key value - | _ -> () - in - List.iter parse_line lines; - statistics - in - let reason_unknown = BU.map_opt smt_output.smt_reason_unknown (fun x -> - let ru = String.concat " " x in - if BU.starts_with ru "(:reason-unknown \"" - then let reason = FStar.Compiler.Util.substring_from ru (String.length "(:reason-unknown \"" ) in - let res = String.substring reason 0 (String.length reason - 2) in //it ends with '")' - res - else ru) in - let status = - if Debug.any() then print_string <| format1 "Z3 says: %s\n" (String.concat "\n" smt_output.smt_result); - match smt_output.smt_result with - | ["unsat"] -> UNSAT unsat_core - | ["sat"] -> SAT (labels, reason_unknown) - | ["unknown"] -> UNKNOWN (labels, reason_unknown) - | ["timeout"] -> TIMEOUT (labels, reason_unknown) - | ["killed"] -> (!bg_z3_proc).restart(); KILLED - | _ -> - failwith (format1 "Unexpected output from Z3: got output result: %s\n" - (String.concat "\n" smt_output.smt_result)) - in - status, statistics - in - let log_result fwrite (res, _stats) = - (* If we are logging, write some more information to the - smt2 file, such as the result of the query and the new unsat - core generated. We take a call back to do so, since for the - bg z3 process we must call query_logging.append_to_log, but for - fresh invocations (such as hints) we must reopen the file to write - to it. *) - begin match log_file with - | Some fname -> - fwrite fname ("; QUERY ID: " ^ queryid); - fwrite fname ("; STATUS: " ^ fst (status_string_and_errors res)); - begin match res with - | UNSAT (Some core) -> - fwrite fname ("; UNSAT CORE GENERATED: " ^ String.concat ", " core) - | _ -> () - end - | None -> () - end; - let log_file_name = - match log_file with - | Some fname -> fname - | _ -> "" - in - let _ = - match reading_solver_state SolverState.would_have_pruned, res with - | Some names, UNSAT (Some core) -> ( - let whitelist = ["BoxInt"; "BoxBool"; "BoxString"; "BoxReal"; "Tm_unit"; "FString_const"] in - let missing = - core |> List.filter (fun name -> - not (BU.for_some (fun wl -> BU.contains name wl) whitelist) && - not (BU.starts_with name "binder_") && - not (BU.starts_with name "@query") && - not (BU.starts_with name "@MaxFuel") && - not (BU.starts_with name "@MaxIFuel") && - not (BU.for_some (fun name' -> name=name') names)) - in - // BU.print2 "Query %s: Pruned theory would keep %s\n" queryid (String.concat ", " names); - match missing with - | [] -> () - | _ -> - BU.print3 "Query %s (%s): Pruned theory would miss %s\n" queryid log_file_name (String.concat ", " missing) - ) - | _ -> () - in - () - in - if fresh then - let proc = new_z3proc_with_id (z3_cmd_and_args ()) in - let kill_handler () = "\nkilled\n" in - let out = BU.ask_process proc input kill_handler (warn_handler []) in - let r = parse (BU.trim_string out) in - log_result (fun fname s -> - let h = BU.open_file_for_appending fname in - BU.append_to_file h s; - BU.close_out_channel h - ) r; - BU.kill_process proc; - r - else - let out = (!bg_z3_proc).ask input in - let r = parse (BU.trim_string out) in - log_result (fun _fname s -> ignore (query_logging.append_to_log s)) r; - r - -let z3_options (ver:string) = - (* Common z3 prefix for all supported versions (at minimum 4.8.5). *) - let opts = [ - "(set-option :global-decls false)"; - "(set-option :smt.mbqi false)"; - "(set-option :auto_config false)"; - "(set-option :produce-unsat-cores true)"; - "(set-option :model true)"; - "(set-option :smt.case_split 3)"; - "(set-option :smt.relevancy 2)"; - ] - in - - (* We need the following options for Z3 >= 4.12.3 *) - let opts = opts @ begin - if M.version_ge ver "4.12.3" then [ - "(set-option :rewriter.enable_der false)"; - "(set-option :rewriter.sort_disjunctions false)"; - "(set-option :pi.decompose_patterns false)"; - "(set-option :smt.arith.solver 6)"; - ] else [ - (* Note: smt.arith.solver defaults to 2 in 4.8.5, but it doesn't hurt to - specify it. *) - "(set-option :smt.arith.solver 2)"; - ] - end - in - String.concat "\n" opts ^ "\n" - -let context_profile (theory:list decl) = - let modules, total_decls = - List.fold_left (fun (out, _total) d -> - match d with - | Module(name, decls) -> - let decls = - List.filter - (function Assume _ -> true - | _ -> false) - decls in - let n : int = List.length decls in - (name, n)::out, n + _total - | _ -> out, _total) - ([], 0) - theory - in - let modules = List.sortWith (fun (_, n) (_, m) -> m - n) modules in - if modules <> [] - then BU.print1 "Z3 Proof Stats: context_profile with %s assertions\n" - (BU.string_of_int total_decls); - List.iter (fun (m, n) -> - if n <> 0 then - BU.print2 "Z3 Proof Stats: %s produced %s SMT decls\n" - m - (string_of_int n)) - modules - -let mk_input (fresh : bool) (theory : list decl) : string & option string & option string = - let ver = Options.z3_version () in - let theory = - (* Add a caption with some version info. *) - ( Caption <| - BU.format3 "Z3 invocation started by F*\n\ - F* version: %s -- commit hash: %s\n\ - Z3 version (according to F*): %s" - (!Options._version) (!Options._commit) ver - ) :: theory - in - let options = z3_options ver in - let options = options ^ (Options.z3_smtopt() |> String.concat "\n") ^ "\n\n" in - if Options.print_z3_statistics() then context_profile theory; - let r, hash = - if Options.record_hints() - || (Options.use_hints() && Options.use_hint_hashes()) then - //the suffix of a "theory" that follows the "CheckSat" call - //contains semantically irrelevant things - //(e.g., get-model, get-statistics etc.) - //that vary depending on some user options (e.g., record_hints etc.) - //They should not be included in the query hash, - //so split the prefix out and use only it for the hash - let prefix, check_sat, suffix = - theory |> - BU.prefix_until (function CheckSat -> true | _ -> false) |> - Option.get - in - let pp = List.map (declToSmt options) in - let suffix = check_sat::suffix in - let ps_lines = pp prefix in - let ss_lines = pp suffix in - let ps = String.concat "\n" ps_lines in - let ss = String.concat "\n" ss_lines in - - (* Ignore captions AND ranges when hashing, otherwise we depend on file names *) - let hs = - if Options.keep_query_captions () - then prefix - |> List.map (declToSmt_no_caps options) - |> String.concat "\n" - else ps - in - (* Add the Z3 version to the string, so we get a mismatch if we switch versions. *) - let hs = hs ^ "Z3 version: " ^ ver in - ps ^ "\n" ^ ss, Some (BU.digest_of_string hs) - else - List.map (declToSmt options) theory |> String.concat "\n", None - in - let log_file_name = - if Options.log_queries() - then Some (query_logging.write_to_log fresh r) - else None - in - r, hash, log_file_name - -let cache_hit - (log_file:option string) - (cache:option string) - (qhash:option string) : option z3result = - if Options.use_hints() && Options.use_hint_hashes() then - match qhash with - | Some (x) when qhash = cache -> - let stats : z3statistics = BU.smap_create 0 in - smap_add stats "fstar_cache_hit" "1"; - let result = { - z3result_status = UNSAT None; - z3result_time = 0; - z3result_statistics = stats; - z3result_query_hash = qhash; - z3result_log_file = log_file - } in - Some result - | _ -> - None - else - None - -let z3_job - (log_file:_) - (r:Range.range) - fresh - (label_messages:error_labels) - input - qhash - queryid -: z3result -= //This code is a little ugly: - //We insert a profiling call to accumulate total time spent in Z3 - //But, we also record the time of this particular call so that we can - //record the elapsed time in the z3result_time field. - //That field is printed out in the query-stats output, which is a separate - //profiling feature. We could try in the future to unify all the different - //kinds of profiling features ... but that's beyond scope for now. - let (status, statistics), elapsed_time = - Profiling.profile - (fun () -> - try - BU.record_time (fun () -> doZ3Exe log_file r fresh input label_messages queryid) - with e -> - refresh None; //refresh the solver but don't handle the exception; it'll be caught upstream - raise e - ) - (Some (query_logging.get_module_name())) - "FStar.SMTEncoding.Z3 (aggregate query time)" - in - { z3result_status = status; - z3result_time = elapsed_time; - z3result_statistics = statistics; - z3result_query_hash = qhash; - z3result_log_file = log_file } - -let ask_text - (r:Range.range) - (cache:option string) - (label_messages:error_labels) - (qry:list decl) - (queryid:string) - (core:option U.unsat_core) - : string - = (* Mimics a fresh ask, and just returns the string that would - be sent to the solver. *) - let theory = - match core with - | None -> with_solver_state SolverState.flush - | Some core -> reading_solver_state (SolverState.filter_with_unsat_core queryid core) - in - let query_tail = Push 0 :: qry@[Pop 0] in - let theory = theory @ query_tail in - let input, qhash, log_file_name = mk_input true theory in - input - -let ask - (r:Range.range) - (cache:option string) - (label_messages:error_labels) - (qry:list decl) - (queryid:string) - (fresh:bool) - (core:option U.unsat_core) -: z3result -= - // push "query"; - // giveZ3 qry; - let theory = - match core with - | None -> with_solver_state SolverState.flush - | Some core -> - if not fresh - then failwith "Unexpected: unsat core must only be used with fresh solvers"; - reading_solver_state (SolverState.filter_with_unsat_core queryid core) - in - let theory = theory @ (Push 0:: qry@[Pop 0]) in - let input, qhash, log_file_name = mk_input fresh theory in - let just_ask () = z3_job log_file_name r fresh label_messages input qhash queryid in - let result = - if fresh then - match cache_hit log_file_name cache qhash with - | Some z3r -> z3r - | None -> just_ask () - else - just_ask () - in - // pop "query"; - result diff --git a/src/smtencoding/FStar.SMTEncoding.Z3.fsti b/src/smtencoding/FStar.SMTEncoding.Z3.fsti deleted file mode 100644 index 92822bd3800..00000000000 --- a/src/smtencoding/FStar.SMTEncoding.Z3.fsti +++ /dev/null @@ -1,80 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.SMTEncoding.Z3 -open FStar.Compiler.Effect -open FStar -open FStar.Compiler -open FStar.SMTEncoding.Term -open FStar.BaseTypes -open FStar.Compiler.Util -module BU = FStar.Compiler.Util -module U = FStar.SMTEncoding.UnsatCore -module SolverState = FStar.SMTEncoding.SolverState - -type z3status = - | UNSAT of option U.unsat_core - | SAT of error_labels & option string //error labels & z3 reason - | UNKNOWN of error_labels & option string //error labels & z3 reason - | TIMEOUT of error_labels & option string //error labels & z3 reason - | KILLED -type z3statistics = BU.smap string - -type z3result = { - z3result_status : z3status; - z3result_time : int; - z3result_statistics : z3statistics; - z3result_query_hash : option string; - z3result_log_file : option string -} - -type query_log = { - get_module_name: unit -> string; - set_module_name: string -> unit; - write_to_log: bool -> string -> string; (* returns name of log file written to *) - append_to_log: string -> string; (* idem *) - close_log: unit -> unit; -} - -val status_string_and_errors : z3status -> string & error_labels - -val giveZ3 : list decl -> unit - -val ask_text - : r:Range.range - -> cache:(option string) // hash - -> label_messages:error_labels - -> qry:list decl - -> queryid:string - -> core:option U.unsat_core - -> string - -val ask: r:Range.range - -> cache:option string // hash - -> label_messages:error_labels - -> qry:list decl - -> queryid:string - -> fresh:bool - -> core:option U.unsat_core - -> z3result - -val refresh: option SolverState.using_facts_from_setting -> unit -val push : msg:string -> unit -val pop : msg:string -> unit -val snapshot : string -> int -val rollback : string -> option int -> unit -val start_query (msg:string) (prefix_to_push:list decl) (query:decl) : unit -val finish_query (msg:string) : unit -val query_logging : query_log \ No newline at end of file diff --git a/src/smtencoding/FStarC.SMTEncoding.Encode.fst b/src/smtencoding/FStarC.SMTEncoding.Encode.fst new file mode 100644 index 00000000000..7d813f53411 --- /dev/null +++ b/src/smtencoding/FStarC.SMTEncoding.Encode.fst @@ -0,0 +1,2037 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.SMTEncoding.Encode +open Prims +open FStar open FStarC +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Compiler +open FStarC.TypeChecker.Env +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.TypeChecker +open FStarC.SMTEncoding.Term +open FStarC.Ident +open FStarC.Const +open FStarC.SMTEncoding +open FStarC.SMTEncoding.Util +open FStarC.SMTEncoding.Env +open FStarC.SMTEncoding.EncodeTerm +open FStarC.Class.Show + +module BU = FStarC.Compiler.Util +module Const = FStarC.Parser.Const +module Env = FStarC.TypeChecker.Env +module N = FStarC.TypeChecker.Normalize +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module TcUtil = FStarC.TypeChecker.Util +module UF = FStarC.Syntax.Unionfind +module U = FStarC.Syntax.Util +module TEQ = FStarC.TypeChecker.TermEqAndSimplify + +let dbg_SMTEncoding = Debug.get_toggle "SMTEncoding" +let dbg_SMTQuery = Debug.get_toggle "SMTQuery" +let dbg_Time = Debug.get_toggle "Time" + +let norm_before_encoding env t = + let steps = [Env.Eager_unfolding; + Env.Simplify; + Env.Primops; + Env.AllowUnboundUniverses; + Env.EraseUniverses; + Env.Exclude Env.Zeta] in + Profiling.profile + (fun () -> N.normalize steps env.tcenv t) + (Some (Ident.string_of_lid (Env.current_module env.tcenv))) + "FStarC.SMTEncoding.Encode.norm_before_encoding" + +let norm_before_encoding_us env us (t:S.term) = + let env_u = {env with tcenv = Env.push_univ_vars env.tcenv us} in + let us, t = SS.open_univ_vars us t in + let t = norm_before_encoding env_u t in + SS.close_univ_vars us t + +let norm_with_steps steps env t = + Profiling.profile + (fun () -> N.normalize steps env t) + (Some (Ident.string_of_lid (Env.current_module env))) + "FStarC.SMTEncoding.Encode.norm" + +type prims_t = { + mk:lident -> string -> term & int & list decl; + is:lident -> bool; +} + +(* Only for the definitions of prims below *) +type defn_rel_type = | Eq | ValidIff +let rel_type_f = function + | Eq -> mkEq + | ValidIff -> fun (x, y) -> + mkEq (mk_Valid x, y) + +let prims = + let module_name = "Prims" in + let asym, a = fresh_fvar module_name "a" Term_sort in + let xsym, x = fresh_fvar module_name "x" Term_sort in + let ysym, y = fresh_fvar module_name "y" Term_sort in + let quant_with_pre (rel:defn_rel_type) vars precondition body : Range.range -> string -> term & int & list decl = fun rng x -> + let xname_decl = Term.DeclFun(x, vars |> List.map fv_sort, Term_sort, None) in + let xtok = x ^ "@tok" in + let xtok_decl = Term.DeclFun(xtok, [], Term_sort, None) in + let xapp = mkApp(x, List.map mkFreeV vars) in //arity ok, see decl (#1383) + let xtok = mkApp(xtok, []) in //arity ok, see decl (#1383) + let xtok_app = mk_Apply xtok vars in + + (* + * AR: adding IsTotFun axioms for the symbol itself, and its partial applications + * NOTE: there are no typing guards here, but then there are no typing guards in + * any of the other axioms too + *) + let tot_fun_axioms = + let all_vars_but_one = BU.prefix vars |> fst in + let axiom_name = "primitive_tot_fun_" ^ x in + //IsTotFun axiom for the symbol itself + let tot_fun_axiom_for_x = Util.mkAssume (mk_IsTotFun xtok, None, axiom_name) in + let axioms, _, _ = //collect other axioms for partial applications + List.fold_left (fun (axioms, app, vars) var -> + let app = mk_Apply app [var] in + let vars = vars @ [var] in + let axiom_name = axiom_name ^ "." ^ (string_of_int (vars |> List.length)) in + axioms @ [Util.mkAssume (mkForall rng ([[app]], vars, mk_IsTotFun app), None, axiom_name)], + app, + vars + ) ([tot_fun_axiom_for_x], xtok, []) all_vars_but_one + in + axioms + in + + let rel_body = + let rel_body = (rel_type_f rel) (xapp, body) in + match precondition with + | None -> rel_body + | Some pre -> mkImp(pre, rel_body) + in + + xtok, + List.length vars, + ([xname_decl; + xtok_decl; + Util.mkAssume(mkForall rng ([[xapp]], vars, rel_body), None, "primitive_" ^x)] @ + tot_fun_axioms @ + [Util.mkAssume(mkForall rng ([[xtok_app]], + vars, + mkEq(xtok_app, xapp)), + Some "Name-token correspondence", + "token_correspondence_"^x)]) + in + let quant rel vars body = quant_with_pre rel vars None body in + let axy = List.map mk_fv [(asym, Term_sort); (xsym, Term_sort); (ysym, Term_sort)] in + let xy = List.map mk_fv [(xsym, Term_sort); (ysym, Term_sort)] in + let qx = List.map mk_fv [(xsym, Term_sort)] in + let prims = [ + //equality + (Const.op_Eq, (quant Eq axy (boxBool <| mkEq(x,y)))); + (Const.op_notEq, (quant Eq axy (boxBool <| mkNot(mkEq(x,y))))); + //boolean ops + (Const.op_And, (quant Eq xy (boxBool <| mkAnd(unboxBool x, unboxBool y)))); + (Const.op_Or, (quant Eq xy (boxBool <| mkOr(unboxBool x, unboxBool y)))); + (Const.op_Negation, (quant Eq qx (boxBool <| mkNot(unboxBool x)))); + //integer ops + (Const.op_LT, (quant Eq xy (boxBool <| mkLT(unboxInt x, unboxInt y)))); + (Const.op_LTE, (quant Eq xy (boxBool <| mkLTE(unboxInt x, unboxInt y)))); + (Const.op_GT, (quant Eq xy (boxBool <| mkGT(unboxInt x, unboxInt y)))); + (Const.op_GTE, (quant Eq xy (boxBool <| mkGTE(unboxInt x, unboxInt y)))); + (Const.op_Subtraction, (quant Eq xy (boxInt <| mkSub(unboxInt x, unboxInt y)))); + (Const.op_Minus, (quant Eq qx (boxInt <| mkMinus(unboxInt x)))); + (Const.op_Addition, (quant Eq xy (boxInt <| mkAdd(unboxInt x, unboxInt y)))); + (Const.op_Multiply, (quant Eq xy (boxInt <| mkMul(unboxInt x, unboxInt y)))); + (Const.op_Division, (quant_with_pre Eq xy (Some (mkNot (mkEq (unboxInt y, mkInteger "0")))) (boxInt <| mkDiv(unboxInt x, unboxInt y)))); + (Const.op_Modulus, (quant_with_pre Eq xy (Some (mkNot (mkEq (unboxInt y, mkInteger "0")))) (boxInt <| mkMod(unboxInt x, unboxInt y)))); + //real ops + (Const.real_op_LT, (quant ValidIff xy (mkLT(unboxReal x, unboxReal y)))); + (Const.real_op_LTE, (quant ValidIff xy (mkLTE(unboxReal x, unboxReal y)))); + (Const.real_op_GT, (quant ValidIff xy (mkGT(unboxReal x, unboxReal y)))); + (Const.real_op_GTE, (quant ValidIff xy (mkGTE(unboxReal x, unboxReal y)))); + (Const.real_op_Subtraction, (quant Eq xy (boxReal <| mkSub(unboxReal x, unboxReal y)))); + (Const.real_op_Addition, (quant Eq xy (boxReal <| mkAdd(unboxReal x, unboxReal y)))); + (Const.real_op_Multiply, (quant Eq xy (boxReal <| mkMul(unboxReal x, unboxReal y)))); + (Const.real_op_Division, (quant_with_pre Eq xy (Some (mkNot (mkEq (unboxReal y, mkReal "0")))) (boxReal <| mkRealDiv(unboxReal x, unboxReal y)))); + (Const.real_of_int, (quant Eq qx (boxReal <| mkRealOfInt (unboxInt x) Range.dummyRange))) + ] + in + let mk : lident -> string -> term & int & list decl = + fun l v -> + prims |> + List.find (fun (l', _) -> lid_equals l l') |> + Option.map (fun (_, b) -> b (Ident.range_of_lid l) v) |> + Option.get in + let is : lident -> bool = + fun l -> prims |> BU.for_some (fun (l', _) -> lid_equals l l') in + {mk=mk; + is=is} + +let pretype_axiom term_constr_eq rng env tapp vars = + let xxsym, xx = fresh_fvar env.current_module_name "x" Term_sort in + let ffsym, ff = fresh_fvar env.current_module_name "f" Fuel_sort in + let xx_has_type = mk_HasTypeFuel ff xx tapp in + let tapp_hash = Term.hash_of_term tapp in + let module_name = env.current_module_name in + Util.mkAssume(mkForall rng ([[xx_has_type]], mk_fv (xxsym, Term_sort)::mk_fv (ffsym, Fuel_sort)::vars, + mkImp(xx_has_type, + (if term_constr_eq + then mkEq(mkApp ("Term_constr_id", [tapp]), + mkApp ("Term_constr_id", [mkApp("PreType", [xx])])) + else mkEq(tapp, + mkApp("PreType", [xx]))))), + Some "pretyping", + (varops.mk_unique (module_name ^ "_pretyping_" ^ (BU.digest_of_string tapp_hash)))) + +let primitive_type_axioms : env -> lident -> string -> term -> list decl = + let xx = mk_fv ("x", Term_sort) in + let x = mkFreeV xx in + + let yy = mk_fv ("y", Term_sort) in + let y = mkFreeV yy in + + let mkForall_fuel env = mkForall_fuel (Ident.string_of_lid (Env.current_module env)) in + + let mk_unit : env -> string -> term -> list decl = fun env nm tt -> + let typing_pred = mk_HasType x tt in + [Util.mkAssume(mk_HasType mk_Term_unit tt, Some "unit typing", "unit_typing"); + Util.mkAssume(mkForall_fuel env (Env.get_range env) + ([[typing_pred]], [xx], mkImp(typing_pred, mkEq(x, mk_Term_unit))), Some "unit inversion", "unit_inversion");] in + let mk_bool : env -> string -> term -> list decl = fun env nm tt -> + let typing_pred = mk_HasType x tt in + let bb = mk_fv ("b", Bool_sort) in + let b = mkFreeV bb in + [Util.mkAssume(mkForall (Env.get_range env) + ([[Term.boxBool b]], [bb], mk_HasType (Term.boxBool b) tt), Some "bool typing", "bool_typing"); + Util.mkAssume(mkForall_fuel env (Env.get_range env) + ([[typing_pred]], [xx], mkImp(typing_pred, mk_tester (fst boxBoolFun) x)), Some "bool inversion", "bool_inversion")] in + let mk_int : env -> string -> term -> list decl = fun env nm tt -> + let lex_t = mkFreeV <| mk_fv (string_of_lid Const.lex_t_lid, Term_sort) in + let typing_pred = mk_HasType x tt in + let typing_pred_y = mk_HasType y tt in + let aa = mk_fv ("a", Int_sort) in + let a = mkFreeV aa in + let bb = mk_fv ("b", Int_sort) in + let b = mkFreeV bb in + let precedes_y_x = mk_Valid <| mkApp("Prims.precedes", [lex_t; lex_t;y;x]) in + [Util.mkAssume(mkForall (Env.get_range env) ([[Term.boxInt b]], [bb], mk_HasType (Term.boxInt b) tt), Some "int typing", "int_typing"); + Util.mkAssume(mkForall_fuel env (Env.get_range env) ([[typing_pred]], [xx], mkImp(typing_pred, mk_tester (fst boxIntFun) x)), Some "int inversion", "int_inversion"); + Util.mkAssume(mkForall_fuel env (Env.get_range env) ([[typing_pred; typing_pred_y;precedes_y_x]], + [xx;yy], + mkImp(mk_and_l [typing_pred; + typing_pred_y; + mkGT (Term.unboxInt x, mkInteger' 0); + mkGTE (Term.unboxInt y, mkInteger' 0); + mkLT (Term.unboxInt y, Term.unboxInt x)], + precedes_y_x)), + Some "well-founded ordering on nat (alt)", "well-founded-ordering-on-nat")] in + let mk_real : env -> string -> term -> list decl = fun env nm tt -> + let typing_pred = mk_HasType x tt in + let aa = mk_fv ("a", Sort "Real") in + let a = mkFreeV aa in + let bb = mk_fv ("b", Sort "Real") in + let b = mkFreeV bb in + [Util.mkAssume(mkForall + (Env.get_range env) + ([[Term.boxReal b]], + [bb], + mk_HasType (Term.boxReal b) tt), + Some "real typing", + "real_typing"); + Util.mkAssume(mkForall_fuel + env + (Env.get_range env) + ([[typing_pred]], + [xx], + mkImp(typing_pred, + mk_tester (fst boxRealFun) x)), + Some "real inversion", + "real_inversion")] + in + let mk_str : env -> string -> term -> list decl = fun env nm tt -> + let typing_pred = mk_HasType x tt in + let bb = mk_fv ("b", String_sort) in + let b = mkFreeV bb in + [Util.mkAssume(mkForall (Env.get_range env) ([[Term.boxString b]], [bb], mk_HasType (Term.boxString b) tt), Some "string typing", "string_typing"); + Util.mkAssume(mkForall_fuel env (Env.get_range env) ([[typing_pred]], [xx], mkImp(typing_pred, mk_tester (fst boxStringFun) x)), Some "string inversion", "string_inversion")] in + let mk_true_interp : env -> string -> term -> list decl = fun env nm true_tm -> + let valid = mkApp("Valid", [true_tm]) in + [Util.mkAssume(valid, Some "True interpretation", "true_interp")] in + let mk_false_interp : env -> string -> term -> list decl = fun env nm false_tm -> + let valid = mkApp("Valid", [false_tm]) in + [Util.mkAssume(mkIff(mkFalse, valid), Some "False interpretation", "false_interp")] in + let mk_and_interp : env -> string -> term -> list decl = fun env conj _ -> + let aa = mk_fv ("a", Term_sort) in + let bb = mk_fv ("b", Term_sort) in + let a = mkFreeV aa in + let b = mkFreeV bb in + let l_and_a_b = mkApp(conj, [a;b]) in + let valid = mkApp("Valid", [l_and_a_b]) in + let valid_a = mkApp("Valid", [a]) in + let valid_b = mkApp("Valid", [b]) in + [Util.mkAssume(mkForall (Env.get_range env) ([[l_and_a_b]], [aa;bb], mkIff(mkAnd(valid_a, valid_b), valid)), Some "/\ interpretation", "l_and-interp")] in + let mk_or_interp : env -> string -> term -> list decl = fun env disj _ -> + let aa = mk_fv ("a", Term_sort) in + let bb = mk_fv ("b", Term_sort) in + let a = mkFreeV aa in + let b = mkFreeV bb in + let l_or_a_b = mkApp(disj, [a;b]) in + let valid = mkApp("Valid", [l_or_a_b]) in + let valid_a = mkApp("Valid", [a]) in + let valid_b = mkApp("Valid", [b]) in + [Util.mkAssume(mkForall (Env.get_range env) ([[l_or_a_b]], [aa;bb], mkIff(mkOr(valid_a, valid_b), valid)), Some "\/ interpretation", "l_or-interp")] in + let mk_eq2_interp : env -> string -> term -> list decl = fun env eq2 tt -> + let aa = mk_fv ("a", Term_sort) in + let xx = mk_fv ("x", Term_sort) in + let yy = mk_fv ("y", Term_sort) in + let a = mkFreeV aa in + let x = mkFreeV xx in + let y = mkFreeV yy in + let eq2_x_y = mkApp(eq2, [a;x;y]) in + let valid = mkApp("Valid", [eq2_x_y]) in + [Util.mkAssume(mkForall (Env.get_range env) ([[eq2_x_y]], [aa;xx;yy], mkIff(mkEq(x, y), valid)), Some "Eq2 interpretation", "eq2-interp")] in + let mk_imp_interp : env -> string -> term -> list decl = fun env imp tt -> + let aa = mk_fv ("a", Term_sort) in + let bb = mk_fv ("b", Term_sort) in + let a = mkFreeV aa in + let b = mkFreeV bb in + let l_imp_a_b = mkApp(imp, [a;b]) in + let valid = mkApp("Valid", [l_imp_a_b]) in + let valid_a = mkApp("Valid", [a]) in + let valid_b = mkApp("Valid", [b]) in + [Util.mkAssume(mkForall (Env.get_range env) ([[l_imp_a_b]], [aa;bb], mkIff(mkImp(valid_a, valid_b), valid)), Some "==> interpretation", "l_imp-interp")] in + let mk_iff_interp : env -> string -> term -> list decl = fun env iff tt -> + let aa = mk_fv ("a", Term_sort) in + let bb = mk_fv ("b", Term_sort) in + let a = mkFreeV aa in + let b = mkFreeV bb in + let l_iff_a_b = mkApp(iff, [a;b]) in + let valid = mkApp("Valid", [l_iff_a_b]) in + let valid_a = mkApp("Valid", [a]) in + let valid_b = mkApp("Valid", [b]) in + [Util.mkAssume(mkForall (Env.get_range env) ([[l_iff_a_b]], [aa;bb], mkIff(mkIff(valid_a, valid_b), valid)), Some "<==> interpretation", "l_iff-interp")] in + let mk_not_interp : env -> string -> term -> list decl = fun env l_not tt -> + let aa = mk_fv ("a", Term_sort) in + let a = mkFreeV aa in + let l_not_a = mkApp(l_not, [a]) in + let valid = mkApp("Valid", [l_not_a]) in + let not_valid_a = mkNot <| mkApp("Valid", [a]) in + [Util.mkAssume(mkForall (Env.get_range env) ([[l_not_a]], [aa], mkIff(not_valid_a, valid)), Some "not interpretation", "l_not-interp")] in + let mk_range_interp : env -> string -> term -> list decl = fun env range tt -> + let range_ty = mkApp(range, []) in + [Util.mkAssume(mk_HasTypeZ (mk_Range_const ()) range_ty, Some "Range_const typing", (varops.mk_unique "typing_range_const"))] in + let mk_inversion_axiom : env -> string -> term -> list decl = fun env inversion tt -> + // (assert (forall ((t Term)) + // (! (implies (Valid (FStar.Pervasives.inversion t)) + // (forall ((x Term)) + // (! (implies (HasTypeFuel ZFuel x t) + // (HasTypeFuel (SFuel ZFuel) x t)) + // :pattern ((HasTypeFuel ZFuel x t))))) + // :pattern ((FStar.Pervasives.inversion t))))) + let tt = mk_fv ("t", Term_sort) in + let t = mkFreeV tt in + let xx = mk_fv ("x", Term_sort) in + let x = mkFreeV xx in + let inversion_t = mkApp(inversion, [t]) in + let valid = mkApp("Valid", [inversion_t]) in + let body = + let hastypeZ = mk_HasTypeZ x t in + let hastypeS = mk_HasTypeFuel (n_fuel 1) x t in + mkForall (Env.get_range env) ([[hastypeZ]], [xx], mkImp(hastypeZ, hastypeS)) + in + [Util.mkAssume(mkForall (Env.get_range env) ([[inversion_t]], [tt], mkImp(valid, body)), Some "inversion interpretation", "inversion-interp")] + in + let prims = [(Const.unit_lid, mk_unit); + (Const.bool_lid, mk_bool); + (Const.int_lid, mk_int); + (Const.real_lid, mk_real); + (Const.string_lid, mk_str); + (Const.true_lid, mk_true_interp); + (Const.false_lid, mk_false_interp); + (Const.and_lid, mk_and_interp); + (Const.or_lid, mk_or_interp); + (Const.eq2_lid, mk_eq2_interp); + (Const.imp_lid, mk_imp_interp); + (Const.iff_lid, mk_iff_interp); + (Const.not_lid, mk_not_interp); + //(Const.forall_lid, mk_forall_interp); + //(Const.exists_lid, mk_exists_interp); + (Const.range_lid, mk_range_interp); + (Const.inversion_lid,mk_inversion_axiom); + ] in + (fun (env:env) (t:lident) (s:string) (tt:term) -> + match BU.find_opt (fun (l, _) -> lid_equals l t) prims with + | None -> [] + | Some(_, f) -> f env s tt) + +let encode_smt_lemma env fv t = + let lid = fv.fv_name.v in + let form, decls = encode_function_type_as_formula t env in + decls@([Util.mkAssume(form, Some ("Lemma: " ^ (string_of_lid lid)), ("lemma_"^(string_of_lid lid)))] + |> mk_decls_trivial) + +let encode_free_var uninterpreted env fv tt t_norm quals :decls_t & env_t = + let lid = fv.fv_name.v in + if not <| (U.is_pure_or_ghost_function t_norm || is_smt_reifiable_function env.tcenv t_norm) + || U.is_lemma t_norm + || uninterpreted + then let arg_sorts = match (SS.compress t_norm).n with + | Tm_arrow {bs=binders} -> binders |> List.map (fun _ -> Term_sort) + | _ -> [] in + let arity = List.length arg_sorts in + let vname, vtok, env = new_term_constant_and_tok_from_lid env lid arity in + let d = Term.DeclFun(vname, arg_sorts, Term_sort, Some "Uninterpreted function symbol for impure function") in + let dd = Term.DeclFun(vtok, [], Term_sort, Some "Uninterpreted name for impure function") in + [d;dd] |> mk_decls_trivial, env + else if prims.is lid + then let vname = varops.new_fvar lid in + let tok, arity, definition = prims.mk lid vname in + let env = push_free_var env lid arity vname (Some tok) in + definition |> mk_decls_trivial, env + else let encode_non_total_function_typ = nsstr lid <> "Prims" in + let formals, (pre_opt, res_t) = + let args, comp = curried_arrow_formals_comp t_norm in + let tcenv_comp = Env.push_binders env.tcenv args in + let comp = + if is_smt_reifiable_comp env.tcenv comp + then S.mk_Total (reify_comp ({tcenv_comp with admit=true}) comp U_unknown) + else comp + in + if encode_non_total_function_typ + then args, TypeChecker.Util.pure_or_ghost_pre_and_post tcenv_comp comp + else args, (None, U.comp_result comp) + in + let mk_disc_proj_axioms guard encoded_res_t vapp (vars:fvs) = quals |> List.collect (function + | Discriminator d -> + let _, xxv = BU.prefix vars in + let xx = mkFreeV <| mk_fv (fv_name xxv, Term_sort) in + [Util.mkAssume(mkForall (S.range_of_fv fv) ([[vapp]], vars, + mkEq(vapp, Term.boxBool <| mk_tester (escape (string_of_lid d)) xx)), + Some "Discriminator equation", + ("disc_equation_"^escape (string_of_lid d)))] + + | Projector(d, f) -> + let _, xxv = BU.prefix vars in + let xx = mkFreeV <| mk_fv (fv_name xxv, Term_sort) in + let f = {ppname=f; index=0; sort=tun} in + let tp_name = mk_term_projector_name d f in //arity ok, primitive projector (#1383) + let prim_app = mkApp(tp_name, [xx]) in + [Util.mkAssume(mkForall (S.range_of_fv fv) ([[vapp]], vars, + mkEq(vapp, prim_app)), Some "Projector equation", ("proj_equation_"^tp_name))] + | _ -> []) in + let vars, guards, env', decls1, _ = encode_binders None formals env in + let guard, decls1 = match pre_opt with + | None -> mk_and_l guards, decls1 + | Some p -> let g, ds = encode_formula p env' in mk_and_l (g::guards), decls1@ds in + let dummy_var = mk_fv ("@dummy", dummy_sort) in + let dummy_tm = Term.mkFreeV dummy_var Range.dummyRange in + let should_thunk () = + //See note [Thunking Nullary Constants] in FStarC.SMTEncoding.Term.fs + let is_type t = + match (SS.compress t).n with + | Tm_type _ -> true + | _ -> false + in + let is_squash t = + let head, _ = U.head_and_args t in + match (U.un_uinst head).n with + | Tm_fvar fv -> + Syntax.fv_eq_lid fv FStarC.Parser.Const.squash_lid + + | Tm_refine {b={sort={n=Tm_fvar fv}}} -> + Syntax.fv_eq_lid fv FStarC.Parser.Const.unit_lid + + | _ -> false + in + //Do not thunk ... + nsstr lid <> "Prims" //things in prims + && not (quals |> List.contains Logic) //logic qualified terms + && not (is_squash t_norm) //ambient squashed properties + && not (is_type t_norm) // : Type terms, since ambient typing hypotheses for these are cheap + in + let thunked, vars = + match vars with + | [] when should_thunk () -> + true, [dummy_var] + | _ -> false, vars + in + let arity = List.length formals in + let vname, vtok_opt, env = new_term_constant_and_tok_from_lid_maybe_thunked env lid arity thunked in + let get_vtok () = Option.get vtok_opt in + let vtok_tm = + match formals with + | [] when not thunked -> mkApp(vname, []) //mkFreeV <| mk_fv (vname, Term_sort) + | [] when thunked -> mkApp(vname, [dummy_tm]) + | _ -> mkApp(get_vtok(), []) //not thunked + in + let vtok_app = mk_Apply vtok_tm vars in + let vapp = mkApp(vname, List.map mkFreeV vars) in //arity ok, see decl below, arity is |vars| (#1383) + let decls2, env = + let vname_decl = Term.DeclFun(vname, vars |> List.map fv_sort, Term_sort, None) in + let tok_typing, decls2 = + let env = {env with encode_non_total_function_typ=encode_non_total_function_typ} in + if not(head_normal env tt) + then encode_term_pred None tt env vtok_tm + else encode_term_pred None t_norm env vtok_tm + in //NS:Unfortunately, this is duplicated work --- we effectively encode the function type twice + let tok_decl, env = + match vars with + | [] -> + let tok_typing = + Util.mkAssume(tok_typing, Some "function token typing", ("function_token_typing_"^vname)) + in + decls2@([tok_typing] |> mk_decls_trivial), + push_free_var env lid arity vname (Some <| mkApp(vname, [])) //mkFreeV (mk_fv (vname, Term_sort))) + + | _ when thunked -> decls2, env + + | _ -> + (* Generate a token and a function symbol; + equate the two, and use the function symbol for full applications *) + let vtok = get_vtok() in + let vtok_decl = Term.DeclFun(vtok, [], Term_sort, None) in + let name_tok_corr_formula pat = + mkForall (S.range_of_fv fv) ([[pat]], vars, mkEq(vtok_app, vapp)) + in + //See issue #613 for the choice of patterns here + let name_tok_corr = + //this allows rewriting (ApplyTT tok ... x1..xn) to f x1...xn + Util.mkAssume(name_tok_corr_formula vtok_app, + Some "Name-token correspondence", + ("token_correspondence_"^vname)) in + let tok_typing = + let ff = mk_fv ("ty", Term_sort) in + let f = mkFreeV ff in + let vtok_app_r = mk_Apply f [mk_fv (vtok, Term_sort)] in + //guard the token typing assumption with a Apply(f, tok), where f is typically __uu__PartialApp + //Additionally, the body of the term becomes + // NoHoist f (and (HasType tok ...) + // (forall (x1..xn).{:pattern (f x1..xn)} f x1..xn=ApplyTT (ApplyTT tok x1) ... xn + //which provides a typing hypothesis for the token + //and a rule to rewrite f x1..xn to ApplyTT tok ... x1..xn + //The NoHoist prevents the Z3 simplifier from hoisting the (HasType tok ...) part out + //Since the top-levels of modules are full of function typed terms + //not guarding it this way causes every typing assumption of an arrow type to be fired immediately + //regardless of whether or not the function is used ... leading to bloat + //these patterns aim to restrict the use of the typing assumption until such point as it is actually needed + let guarded_tok_typing = + mkForall (S.range_of_fv fv) + ([[vtok_app_r]], + [ff], + mkAnd(Term.mk_NoHoist f tok_typing, + name_tok_corr_formula vapp)) in + Util.mkAssume(guarded_tok_typing, Some "function token typing", ("function_token_typing_"^vname)) + in + decls2@([vtok_decl;name_tok_corr;tok_typing] |> mk_decls_trivial), + env + in + ([vname_decl] |> mk_decls_trivial)@tok_decl, env + in + let encoded_res_t, ty_pred, decls3 = + let res_t = SS.compress res_t in + let encoded_res_t, decls = encode_term res_t env' in + encoded_res_t, mk_HasType vapp encoded_res_t, decls in //occurs positively, so add fuel + let typingAx = Util.mkAssume(mkForall (S.range_of_fv fv) ([[vapp]], vars, mkImp(guard, ty_pred)), + Some "free var typing", + ("typing_"^vname)) in + let freshness = + if quals |> List.contains New + then [Term.fresh_constructor (S.range_of_fv fv) (vname, vars |> List.map fv_sort, Term_sort, varops.next_id()); + pretype_axiom false (S.range_of_fv fv) env vapp vars] + else [] in + let g = decls1@decls2@decls3@(freshness@typingAx::mk_disc_proj_axioms guard encoded_res_t vapp vars + |> mk_decls_trivial) in + g, env + + +let declare_top_level_let env x t t_norm : fvar_binding & decls_t & env_t = + match lookup_fvar_binding env x.fv_name.v with + (* Need to introduce a new name decl *) + | None -> + let decls, env = encode_free_var false env x t t_norm [] in + let fvb = lookup_lid env x.fv_name.v in + fvb, decls, env + + (* already declared, only need an equation *) + | Some fvb -> + fvb, [], env + + +let encode_top_level_val uninterpreted env us fv t quals = + let tt = + if FStarC.Ident.nsstr (lid_of_fv fv) = "FStar.Ghost" + then norm_with_steps //no primops for FStar.Ghost, otherwise things like reveal/hide get simplified away too early + [Env.Eager_unfolding; + Env.Simplify; + Env.AllowUnboundUniverses; + Env.EraseUniverses; + Env.Exclude Env.Zeta] + env.tcenv t + else norm_before_encoding_us env us t + in + // if !dbg_SMTEncoding + // then BU.print3 "Encoding top-level val %s : %s\Normalized to is %s\n" + // (show fv) + // (show t) + // (show tt); + let decls, env = encode_free_var uninterpreted env fv t tt quals in + if U.is_smt_lemma t + then decls@encode_smt_lemma env fv tt, env + else decls, env + +let encode_top_level_vals env bindings quals = + bindings |> List.fold_left (fun (decls, env) lb -> + let decls', env = encode_top_level_val false env lb.lbunivs (BU.right lb.lbname) lb.lbtyp quals in + decls@decls', env) ([], env) + +exception Let_rec_unencodeable + +let copy_env (en:env_t) = { en with global_cache = BU.smap_copy en.global_cache} //Make a copy of all the mutable state of env_t, central place for keeping track of mutable fields in env_t + +let encode_top_level_let : + env_t -> (bool & list letbinding) -> list qualifier -> decls_t & env_t = + fun env (is_rec, bindings) quals -> + + let eta_expand binders formals body t = + let nbinders = List.length binders in + let formals, extra_formals = BU.first_N nbinders formals in + let subst = + List.map2 (fun ({binder_bv=formal}) ({binder_bv=binder}) -> + NT(formal, S.bv_to_name binder) + ) formals binders in + let extra_formals = + extra_formals + |> List.map (fun b -> + {b with + binder_bv={b.binder_bv with + sort=SS.subst subst b.binder_bv.sort}}) + |> U.name_binders in + let body = Syntax.extend_app_n + (SS.compress body) + (snd <| U.args_of_binders extra_formals) body.pos in + binders@extra_formals, body + in + + let destruct_bound_function t e + : (S.binders //arguments of the (possibly reified) lambda abstraction + & S.term //body of the (possibly reified) lambda abstraction + & S.comp) //result comp +// * bool //if set, we should generate a curried application of f + = + (* The input type [t_norm] might contain reifiable computation type which must be reified at this point *) + + let tcenv = {env.tcenv with admit=true} in + + let subst_comp formals actuals comp = + let subst = List.map2 (fun ({binder_bv=x}) ({binder_bv=b}) -> NT(x, S.bv_to_name b)) formals actuals in + SS.subst_comp subst comp + in + + let rec arrow_formals_comp_norm norm t = + //NS: tried using U.arrow_formals_comp here + // but that flattens Tot effects quite aggressively + let t = U.unascribe <| SS.compress t in + match t.n with + | Tm_arrow {bs=formals; comp} -> + SS.open_comp formals comp + + | Tm_refine _ -> + arrow_formals_comp_norm norm (U.unrefine t) + + | _ when not norm -> + let t_norm = norm_with_steps [Env.AllowUnboundUniverses; Env.Beta; Env.Weak; Env.HNF; + (* we don't know if this will terminate; so don't do recursive steps *) + Env.Exclude Env.Zeta; + Env.UnfoldUntil delta_constant; Env.EraseUniverses] + tcenv t + in + arrow_formals_comp_norm true t_norm + + | _ -> + [], S.mk_Total t + in + + let aux t e = + let binders, body, lopt = U.abs_formals e in + let formals, comp = + match binders with + | [] -> arrow_formals_comp_norm true t + //don't normalize t to avoid poorly encoding points-free code + //see, e.g., Benton2004.RHL.Example2 + | _ -> arrow_formals_comp_norm false t + in + let nformals = List.length formals in + let nbinders = List.length binders in + let binders, body, comp = + if nformals < nbinders (* explicit currying *) + then let bs0, rest = BU.first_N nformals binders in + let body = U.abs rest body lopt in + bs0, body, subst_comp formals bs0 comp + else if nformals > nbinders (* eta-expand before translating it *) + then let binders, body = eta_expand binders formals body (U.comp_result comp) in + binders, body, subst_comp formals binders comp + else binders, body, subst_comp formals binders comp + in + binders, body, comp + in + let binders, body, comp = aux t e in + let binders, body, comp = + let tcenv = Env.push_binders tcenv binders in + if is_smt_reifiable_comp tcenv comp + then let eff_name = comp |> U.comp_effect_name in + let comp = reify_comp tcenv comp U_unknown in + let body = TcUtil.norm_reify tcenv [] + (U.mk_reify body (Some eff_name)) in + let more_binders, body, comp = aux comp body in + binders@more_binders, body, comp + else binders, body, comp + in + binders, + //setting the use_eq ascription flag to false, + // doesn't matter since the flag is irrelevant outside the typechecker + U.ascribe body (Inl (U.comp_result comp), None, false), + comp + in + + + try + if bindings |> BU.for_all (fun lb -> U.is_lemma lb.lbtyp) + then encode_top_level_vals env bindings quals + else + let toks, typs, decls, env = + bindings |> List.fold_left (fun (toks, typs, decls, env) lb -> + (* some, but not all are lemmas; impossible *) + if U.is_lemma lb.lbtyp then raise Let_rec_unencodeable; + (* #2894: If this is a recursive definition, make sure to unfold the type + until the arrow structure is evident (we use whnf for it). Otherwise + there will be thunking inconsistencies in the encoding. *) + let t_norm = + if is_rec + then N.unfold_whnf' [Env.AllowUnboundUniverses] env.tcenv lb.lbtyp + else norm_before_encoding env lb.lbtyp + in + (* We are declaring the top_level_let with t_norm which might contain *) + (* non-reified reifiable computation type. *) + (* TODO : clear this mess, the declaration should have a type corresponding to *) + (* the encoded term *) + let tok, decl, env = declare_top_level_let env (BU.right lb.lbname) lb.lbtyp t_norm in + tok::toks, t_norm::typs, decl::decls, env) + ([], [], [], env) + in + let toks_fvbs = List.rev toks in + let decls = List.rev decls |> List.flatten in + (* + * AR: decls are the declarations for the top-level lets + * if one of the let body contains a let rec (inner let rec), we simply return decls at that point, inner let recs are not encoded to the solver yet (see Inner_let_rec below) + * the way it is implemented currently is that, the call to encode the let body throws an exception Inner_let_rec which is caught below in this function + * and the exception handler simply returns decls + * however, it seems to mess up the env cache + * basically, the let rec can be quite deep in the body, and then traversing the body before it, we might encode new decls, add them to the cache etc. + * since the cache is stateful, this would mean that there would be some symbols in the cache but not in the returned decls list (which only contains the top-level lets) + * this results in z3 errors + * so, taking a snapshot of the env, and return this env in handling of the Inner_let_rec (see also #1502) + *) + let env_decls = copy_env env in + let typs = List.rev typs in + + let encode_non_rec_lbdef + (bindings:list letbinding) + (typs:list S.term) + (toks:list fvar_binding) + (env:env_t) = + match bindings, typs, toks with + | [{lbunivs=uvs;lbdef=e;lbname=lbn}], [t_norm], [fvb] -> + + (* Open universes *) + let flid = fvb.fvar_lid in + let env', e, t_norm = + let tcenv', _, e_t = + Env.open_universes_in env.tcenv uvs [e; t_norm] in + let e, t_norm = + match e_t with + | [e; t_norm] -> e, t_norm + | _ -> failwith "Impossible" in + {env with tcenv=tcenv'}, e, t_norm + in + + (* Open binders *) + let (binders, body, t_body_comp) = destruct_bound_function t_norm e in + let t_body = U.comp_result t_body_comp in + if !dbg_SMTEncoding + then BU.print2 "Encoding let : binders=[%s], body=%s\n" + (show binders) + (show body); + (* Encode binders *) + let vars, binder_guards, env', binder_decls, _ = encode_binders None binders env' in + let vars, app = + if fvb.fvb_thunked && vars = [] + then let dummy_var = mk_fv ("@dummy", dummy_sort) in + let dummy_tm = Term.mkFreeV dummy_var Range.dummyRange in + let app = Term.mkApp (fvb.smt_id, [dummy_tm]) (S.range_of_lbname lbn) in + [dummy_var], app + else vars, maybe_curry_fvb (S.range_of_lbname lbn) fvb (List.map mkFreeV vars) + in + let is_logical = + match (SS.compress t_body).n with + | Tm_fvar fv when S.fv_eq_lid fv FStarC.Parser.Const.logical_lid -> true + | _ -> false + in + let is_smt_theory_symbol = + let fv = FStarC.Compiler.Util.right lbn in + Env.fv_has_attr env.tcenv fv FStarC.Parser.Const.smt_theory_symbol_attr_lid + in + let is_sub_singleton = U.is_sub_singleton body in + let should_encode_logical = + not is_smt_theory_symbol + && (quals |> List.contains Logic || is_logical) + in + let make_eqn name pat app body = + //NS 05.25: This used to be mkImp(mk_and_l guards, mkEq(app, body))), + //But the guard is unnecessary given the pattern + Util.mkAssume(mkForall (S.range_of_lbname lbn) + ([[pat]], vars, mkEq(app,body)), + Some (BU.format1 "Equation for %s" (string_of_lid flid)), + (name ^ "_" ^ fvb.smt_id)) + in + let eqns,decls2 = + let basic_eqn_name = + if should_encode_logical + then "defn_equation" + else "equation" + in + let basic_eqn, decls = + let app_is_prop = Term.mk_subtype_of_unit app in + if should_encode_logical + then ( + if is_sub_singleton && Options.Ext.get "retain_old_prop_typing" = "" + then ( + Util.mkAssume(mkForall (S.range_of_lbname lbn) + ([[app_is_prop]], vars, mkImp(mk_and_l binder_guards, mk_Valid <| app_is_prop)), + Some (BU.format1 "Prop-typing for %s" (string_of_lid flid)), + (basic_eqn_name ^ "_" ^ fvb.smt_id)), + [] + ) + else ( + let body, decls = encode_term body env' in + make_eqn basic_eqn_name app_is_prop app body, + decls + ) + ) + else ( + let body, decls = encode_term body env' in + make_eqn basic_eqn_name app app body, decls + ) + in + if should_encode_logical + then let pat, app, (body, decls2) = + app, mk_Valid app, encode_formula body env' + in + let logical_eqn = make_eqn "equation" pat app body in + [logical_eqn; basic_eqn], decls@decls2 + else [basic_eqn], decls + in + decls@binder_decls@decls2@((eqns@primitive_type_axioms env.tcenv flid fvb.smt_id app) + |> mk_decls_trivial), + env + | _ -> failwith "Impossible" + in + + let encode_rec_lbdefs (bindings:list letbinding) + (typs:list S.term) + (toks:list fvar_binding) + (env:env_t) = + (* encoding recursive definitions using fuel to throttle unfoldings *) + (* We create a new variable corresponding to the current fuel *) + let fuel = mk_fv (varops.fresh env.current_module_name "fuel", Fuel_sort) in + let fuel_tm = mkFreeV fuel in + let env0 = env in + (* For each declaration, we push in the environment its fuel-guarded copy (using current fuel) *) + let gtoks, env = toks |> List.fold_left (fun (gtoks, env) fvb -> //(flid_fv, (f, ftok)) -> + let flid = fvb.fvar_lid in + let g = varops.new_fvar (Ident.lid_add_suffix flid "fuel_instrumented") in + let gtok = varops.new_fvar (Ident.lid_add_suffix flid "fuel_instrumented_token") in + let env = push_free_var env flid fvb.smt_arity gtok (Some <| mkApp(g, [fuel_tm])) in + (fvb, g, gtok)::gtoks, env) ([], env) + in + let gtoks = List.rev gtoks in + + let encode_one_binding env0 (fvb, g, gtok) t_norm ({lbunivs=uvs;lbname=lbn; lbdef=e}) = + + (* Open universes *) + let env', e, t_norm = + let tcenv', _, e_t = + Env.open_universes_in env.tcenv uvs [e; t_norm] in + let e, t_norm = + match e_t with + | [e; t_norm] -> e, t_norm + | _ -> failwith "Impossible" in + {env with tcenv=tcenv'}, e, t_norm + in + if !dbg_SMTEncoding + then BU.print3 "Encoding let rec %s : %s = %s\n" + (show lbn) + (show t_norm) + (show e); + + (* Open binders *) + let (binders, body, tres_comp) = destruct_bound_function t_norm e in + let curry = fvb.smt_arity <> List.length binders in + let pre_opt, tres = TcUtil.pure_or_ghost_pre_and_post env.tcenv tres_comp in + if !dbg_SMTEncoding + then BU.print4 "Encoding let rec %s: \n\tbinders=[%s], \n\tbody=%s, \n\ttres=%s\n" + (show lbn) + (show binders) + (show body) + (show tres_comp); + //let _ = + // if curry + // then failwith "Unexpected type of let rec in SMT Encoding; \ + // expected it to be annotated with an arrow type" + //in + + + let vars, guards, env', binder_decls, _ = encode_binders None binders env' in + + let guard, guard_decls = + match pre_opt with + | None -> mk_and_l guards, [] + | Some pre -> + let guard, decls0 = encode_formula pre env' in + mk_and_l (guards@[guard]), decls0 + in + let binder_decls = binder_decls @ guard_decls in + let decl_g = Term.DeclFun(g, Fuel_sort::List.map fv_sort (fst (BU.first_N fvb.smt_arity vars)), Term_sort, Some "Fuel-instrumented function name") in + let decl_g_tok = Term.DeclFun(gtok, [], Term_sort, Some "Token for fuel-instrumented partial applications") in + let env0 = push_zfuel_name env0 fvb.fvar_lid g gtok in + let vars_tm = List.map mkFreeV vars in + let rng = (S.range_of_lbname lbn) in + let app = maybe_curry_fvb rng fvb (List.map mkFreeV vars) in + let mk_g_app args = maybe_curry_app rng (Inl (Var g)) (fvb.smt_arity + 1) args in + let gsapp = mk_g_app (mkApp("SFuel", [fuel_tm])::vars_tm) in + let gmax = mk_g_app (mkApp("MaxFuel", [])::vars_tm) in + let body_tm, decls2 = encode_term body env' in + + //NS 05.25: This used to be mkImp(mk_and_l guards, mkEq(gsapp, body_tm) + //But, the pattern ensures that this only applies to well-typed terms + //NS 08/10: Setting the weight of this quantifier to 0, since its instantiations are controlled by F* fuel + //NS 11/28/2018: Restoring the mkImp (mk_and_l guards, mkEq(gsapp, body_tm)) + // 11/29/2018: Also guarding by the precondition of a Pure/Ghost function in addition to typing guards + let eqn_g = + Util.mkAssume + (mkForall' (S.range_of_lbname lbn) + ([[gsapp]], Some 0, fuel::vars, mkImp(guard, mkEq(gsapp, body_tm))), + Some (BU.format1 "Equation for fuel-instrumented recursive function: %s" (string_of_lid fvb.fvar_lid)), + "equation_with_fuel_" ^g) in + let eqn_f = Util.mkAssume(mkForall (S.range_of_lbname lbn) ([[app]], vars, mkEq(app, gmax)), + Some "Correspondence of recursive function to instrumented version", + ("@fuel_correspondence_"^g)) in + let eqn_g' = Util.mkAssume(mkForall (S.range_of_lbname lbn) ([[gsapp]], fuel::vars, mkEq(gsapp, mk_g_app (Term.n_fuel 0::vars_tm))), + Some "Fuel irrelevance", + ("@fuel_irrelevance_" ^g)) in + let aux_decls, g_typing = + let gapp = mk_g_app (fuel_tm::vars_tm) in + let tok_corr = + let tok_app = mk_Apply (mkFreeV <| mk_fv (gtok, Term_sort)) (fuel::vars) in + let tot_fun_axioms = + let head = mkFreeV <| mk_fv (gtok, Term_sort) in + let vars = fuel :: vars in + //the guards are trivial here since this tot_fun_axioms + //should never appear in a goal (see Bug1750.fst, test_currying) + let guards = List.map (fun _ -> mkTrue) vars in + EncodeTerm.isTotFun_axioms rng head vars guards (U.is_pure_comp tres_comp) + in + Util.mkAssume(mkAnd(mkForall (S.range_of_lbname lbn) ([[tok_app]], fuel::vars, mkEq(tok_app, gapp)), + tot_fun_axioms), + Some "Fuel token correspondence", + ("fuel_token_correspondence_"^gtok)) + in + let aux_decls, typing_corr = + let g_typing, d3 = encode_term_pred None tres env' gapp in + d3, [Util.mkAssume(mkForall (S.range_of_lbname lbn) + ([[gapp]], fuel::vars, mkImp(guard, g_typing)), + Some "Typing correspondence of token to term", + ("token_correspondence_"^g))] + in + aux_decls, typing_corr@[tok_corr] + in + + binder_decls@decls2@aux_decls@([decl_g;decl_g_tok] |> mk_decls_trivial), + [eqn_g;eqn_g';eqn_f]@g_typing |> mk_decls_trivial, env0 + in + + let decls, eqns, env0 = List.fold_left (fun (decls, eqns, env0) (gtok, ty, lb) -> + let decls', eqns', env0 = encode_one_binding env0 gtok ty lb in + decls'::decls, eqns'@eqns, env0) + ([decls], [], env0) + (List.zip3 gtoks typs bindings) + in + (* Function declarations must come first to be defined in all recursive definitions *) + let prefix_decls, elts, rest = + let isDeclFun = function | DeclFun _ -> true | _ -> false in + decls |> List.flatten |> (fun decls -> + //decls is a list of decls_elt ... each of which contains a list decl in it + //we need to go through each of those, accumulate DeclFuns and remove them from there + let prefix_decls, elts, rest = List.fold_left (fun (prefix_decls, elts, rest) elt -> + if elt.key |> BU.is_some && List.existsb isDeclFun elt.decls + then prefix_decls, elts@[elt], rest + else let elt_decl_funs, elt_rest = List.partition isDeclFun elt.decls in + prefix_decls @ elt_decl_funs, elts, rest @ [{ elt with decls = elt_rest }] + ) ([], [], []) decls in + prefix_decls |> mk_decls_trivial, elts, rest) + in + let eqns = List.rev eqns in + prefix_decls@elts@rest@eqns, env0 + in + + if quals |> BU.for_some (function HasMaskedEffect -> true | _ -> false) + || typs |> BU.for_some (fun t -> not <| (U.is_pure_or_ghost_function t || + is_smt_reifiable_function env.tcenv t)) + then decls, env_decls + else + try + if not is_rec + then + (* Encoding non-recursive definitions *) + encode_non_rec_lbdef bindings typs toks_fvbs env + else + encode_rec_lbdefs bindings typs toks_fvbs env + with + | Inner_let_rec names -> + let plural = List.length names > 1 in + let r = List.hd names |> snd in + FStarC.TypeChecker.Err.add_errors + env.tcenv + [(Errors.Warning_DefinitionNotTranslated, + // FIXME + [Errors.text <| BU.format3 + "Definitions of inner let-rec%s %s and %s enclosing top-level letbinding are not encoded to the solver, you will only be able to reason with their types" + (if plural then "s" else "") + (List.map fst names |> String.concat ",") + (if plural then "their" else "its")], + r, + Errors.get_ctx () // TODO: fix this, leaking abstraction + )]; + decls, env_decls //decls are type declarations for the lets, if there is an inner let rec, only those are encoded to the solver + + with Let_rec_unencodeable -> + let msg = bindings |> List.map (fun lb -> show lb.lbname) |> String.concat " and " in + let decl = Caption ("let rec unencodeable: Skipping: " ^msg) in + [decl] |> mk_decls_trivial, env + +let encode_sig_inductive (env:env_t) (se:sigelt) +: decls_t & env_t += let Sig_inductive_typ + { lid=t; us=universe_names; params=tps; + t=k; ds=datas; injective_type_params } = se.sigel in + let t_lid = t in + let tcenv = env.tcenv in + let quals = se.sigquals in + let is_logical = quals |> BU.for_some (function Logic | Assumption -> true | _ -> false) in + let constructor_or_logic_type_decl (c:constructor_t) = + if is_logical + then [Term.DeclFun(c.constr_name, c.constr_fields |> List.map (fun f -> f.field_sort), Term_sort, None)] + else constructor_to_decl (Ident.range_of_lid t) c in + let inversion_axioms env tapp vars = + if datas |> BU.for_some (fun l -> Env.try_lookup_lid env.tcenv l |> Option.isNone) //Q: Why would this happen? + then [] + else ( + let xxsym, xx = fresh_fvar env.current_module_name "x" Term_sort in + let data_ax, decls = + datas |> + List.fold_left + (fun (out, decls) l -> + let is_l = mk_data_tester env l xx in + let inversion_case, decls' = + if injective_type_params + || Options.Ext.get "compat:injectivity" <> "" + then ( + let _, data_t = Env.lookup_datacon env.tcenv l in + let args, res = U.arrow_formals data_t in + let indices = res |> U.head_and_args_full |> snd in + let env = args |> List.fold_left + (fun env ({binder_bv=x}) -> push_term_var env x (mkApp(mk_term_projector_name l x, [xx]))) + env in + let indices, decls' = encode_args indices env in + if List.length indices <> List.length vars + then failwith "Impossible"; + let eqs = List.map2 (fun v a -> mkEq(mkFreeV v, a)) vars indices in + mkAnd(is_l, mk_and_l eqs), decls' + ) + else is_l, [] + in + mkOr(out, inversion_case), decls@decls') + (mkFalse, []) + in + let ffsym, ff = fresh_fvar env.current_module_name "f" Fuel_sort in + let fuel_guarded_inversion = + let xx_has_type_sfuel = + if List.length datas > 1 + then mk_HasTypeFuel (mkApp("SFuel", [ff])) xx tapp + else mk_HasTypeFuel ff xx tapp //no point requiring non-zero fuel if there are no disjunctions + in + Util.mkAssume( + mkForall + (Ident.range_of_lid t) + ([[xx_has_type_sfuel]], + add_fuel (mk_fv (ffsym, Fuel_sort)) (mk_fv (xxsym, Term_sort)::vars), + mkImp(xx_has_type_sfuel, data_ax)), + Some "inversion axiom", //this name matters! see Sig_bundle case near line 1493 + (varops.mk_unique ("fuel_guarded_inversion_"^(string_of_lid t)))) + in + decls + @([fuel_guarded_inversion] |> mk_decls_trivial) + ) + in + let formals, res = + let k = + match tps with + | [] -> k + | _ -> S.mk (Tm_arrow {bs=tps; comp=S.mk_Total k}) k.pos + in + let k = norm_before_encoding env k in + U.arrow_formals k + in + let vars, guards, env', binder_decls, _ = encode_binders None formals env in + let arity = List.length vars in + let tname, ttok, env = new_term_constant_and_tok_from_lid env t arity in + let ttok_tm = mkApp(ttok, []) in + let guard = mk_and_l guards in + let tapp = mkApp(tname, List.map mkFreeV vars) in //arity ok + let decls, env = + //See: https://github.com/FStarLang/FStar/commit/b75225bfbe427c8aef5b59f70ff6d79aa014f0b4 + //See: https://github.com/FStarLang/FStar/issues/349 + let tname_decl = + constructor_or_logic_type_decl + { + constr_name = tname; + constr_fields = vars |> List.map (fun fv -> {field_name=tname^fv_name fv; field_sort=fv_sort fv; field_projectible=false}) ; + //The field_projectible=false above is extremely important; it makes sure that type-formers are not injective + constr_sort=Term_sort; + constr_id=Some (varops.next_id()); + constr_base=false + } + in + let tok_decls, env = + match vars with + | [] -> [], push_free_var env t arity tname (Some <| mkApp(tname, [])) + | _ -> + let ttok_decl = Term.DeclFun(ttok, [], Term_sort, Some "token") in + let ttok_fresh = Term.fresh_token (ttok, Term_sort) (varops.next_id()) in + let ttok_app = mk_Apply ttok_tm vars in + let pats = [[ttok_app]; [tapp]] in + // These patterns allow rewriting (ApplyT T@tok args) to (T args) and vice versa + // This seems necessary for some proofs, but the bidirectional rewriting may be inefficient + let name_tok_corr = + Util.mkAssume(mkForall' (Ident.range_of_lid t) (pats, None, vars, mkEq(ttok_app, tapp)), + Some "name-token correspondence", + ("token_correspondence_"^ttok)) in + [ttok_decl; ttok_fresh; name_tok_corr], env + in + tname_decl@tok_decls, env + in + let kindingAx = + let k, decls = encode_term_pred None res env' tapp in + let karr = + if List.length formals > 0 + then [Util.mkAssume(mk_tester "Tm_arrow" (mk_PreType ttok_tm), Some "kinding", ("pre_kinding_"^ttok))] + else [] + in + let rng = Ident.range_of_lid t in + let tot_fun_axioms = EncodeTerm.isTotFun_axioms rng ttok_tm vars (List.map (fun _ -> mkTrue) vars) true in + decls@(karr@[Util.mkAssume(mkAnd(tot_fun_axioms, mkForall rng ([[tapp]], vars, mkImp(guard, k))), + None, + ("kinding_"^ttok))] |> mk_decls_trivial) + in + let aux = + kindingAx + @(inversion_axioms env tapp vars) + @([pretype_axiom (not injective_type_params) (Ident.range_of_lid t) env tapp vars] |> mk_decls_trivial) + in + (decls |> mk_decls_trivial)@binder_decls@aux, env + +let encode_datacon (env:env_t) (se:sigelt) +: decls_t & env_t += let Sig_datacon {lid=d; us; t; num_ty_params=n_tps; mutuals; injective_type_params } = se.sigel in + let quals = se.sigquals in + let t = norm_before_encoding_us env us t in + let formals, t_res = U.arrow_formals t in + let arity = List.length formals in + let ddconstrsym, ddtok, env = new_term_constant_and_tok_from_lid env d arity in + let ddtok_tm = mkApp(ddtok, []) in + let fuel_var, fuel_tm = fresh_fvar env.current_module_name "f" Fuel_sort in + let s_fuel_tm = mkApp("SFuel", [fuel_tm]) in + let vars, guards, env', binder_decls, names = encode_binders (Some fuel_tm) formals env in + let injective_type_params = + injective_type_params || Options.Ext.get "compat:injectivity" <> "" + in + let fields = + names |> + List.mapi + (fun n x -> + let field_projectible = + n >= n_tps || //either this field is not a type parameter + injective_type_params //or we are allowed to be injective on parameters + in + { field_name=mk_term_projector_name d x; + field_sort=Term_sort; + field_projectible }) + in + let datacons = { + constr_name=ddconstrsym; + constr_fields=fields; + constr_sort=Term_sort; + constr_id=Some (varops.next_id()); + constr_base=not injective_type_params + } |> Term.constructor_to_decl (Ident.range_of_lid d) in + let app = mk_Apply ddtok_tm vars in + let guard = mk_and_l guards in + let xvars = List.map mkFreeV vars in + let dapp = mkApp(ddconstrsym, xvars) in //arity ok; |xvars| = |formals| = arity + + let tok_typing, decls3 = encode_term_pred None t env ddtok_tm in + let tok_typing = + match fields with + | _::_ -> + let ff = mk_fv ("ty", Term_sort) in + let f = mkFreeV ff in + let vtok_app_l = mk_Apply ddtok_tm [ff] in + let vtok_app_r = mk_Apply f [mk_fv (ddtok, Term_sort)] in + //guard the token typing assumption with a Apply(tok, f) or Apply(f, tok) + //Additionally, the body of the term becomes NoHoist f (HasType tok ...) + // to prevent the Z3 simplifier from hoisting the (HasType tok ...) part out + //Since the top-levels of modules are full of function typed terms + //not guarding it this way causes every typing assumption of an arrow type to be fired immediately + //regardless of whether or not the function is used ... leading to bloat + //these patterns aim to restrict the use of the typing assumption until such point as it is actually needed + mkForall (Ident.range_of_lid d) + ([[vtok_app_l]; [vtok_app_r]], + [ff], + Term.mk_NoHoist f tok_typing) + | _ -> tok_typing in + let ty_pred', t_res_tm, decls_pred = + let t_res_tm, t_res_decls = encode_term t_res env' in + mk_HasTypeWithFuel (Some fuel_tm) dapp t_res_tm, t_res_tm, t_res_decls in + let proxy_fresh = match formals with + | [] -> [] + | _ -> [Term.fresh_token (ddtok, Term_sort) (varops.next_id())] in + + let encode_elim () = + let head, args = U.head_and_args t_res in + match (SS.compress head).n with + | Tm_uinst({n=Tm_fvar fv}, _) + | Tm_fvar fv -> + let encoded_head_fvb = lookup_free_var_name env' fv.fv_name in + let encoded_args, arg_decls = encode_args args env' in + let _, arg_vars, elim_eqns_or_guards, _ = + List.fold_left + (fun (env, arg_vars, eqns_or_guards, i) (orig_arg, arg) -> + let _, xv, env = gen_term_var env (S.new_bv None tun) in + (* we only get equations induced on the type indices, not parameters; *) + (* Also see https://github.com/FStarLang/FStar/issues/349 *) + let eqns = + if i < n_tps + then eqns_or_guards + else mkEq(arg, xv)::eqns_or_guards + in + (env, xv::arg_vars, eqns, i + 1)) + (env', [], [], 0) + (FStarC.Compiler.List.zip args encoded_args) + in + let arg_vars = List.rev arg_vars in + let arg_params, _ = List.splitAt n_tps arg_vars in + let data_arg_params, _ = List.splitAt n_tps vars in + //Express the guards in terms of the parameters of the type constructor + //not the arguments of the data constructor + let elim_eqns_and_guards = + List.fold_left2 + (fun elim_eqns_and_guards data_arg_param arg_param -> + Term.subst elim_eqns_and_guards data_arg_param arg_param) + (mk_and_l (elim_eqns_or_guards@guards)) + data_arg_params + arg_params + in + let ty = maybe_curry_fvb fv.fv_name.p encoded_head_fvb arg_vars in + let xvars = List.map mkFreeV vars in + let dapp = mkApp(ddconstrsym, xvars) in //arity ok; |xvars| = |formals| = arity + let ty_pred = mk_HasTypeWithFuel (Some s_fuel_tm) dapp ty in + let arg_binders = List.map fv_of_term arg_vars in + let typing_inversion = + Util.mkAssume(mkForall (Ident.range_of_lid d) ([[ty_pred]], + add_fuel (mk_fv (fuel_var, Fuel_sort)) (vars@arg_binders), + mkImp(ty_pred, elim_eqns_and_guards)), + Some "data constructor typing elim", + ("data_elim_" ^ ddconstrsym)) in + let lex_t = mkFreeV <| mk_fv (string_of_lid Const.lex_t_lid, Term_sort) in + let subterm_ordering = + (* subterm ordering *) + let prec = + vars + |> List.mapi (fun i v -> + (* it's a parameter, so it's inaccessible and no need for a sub-term ordering on it *) + if i < n_tps + then [] + else [mk_Precedes lex_t lex_t (mkFreeV v) dapp]) + |> List.flatten + in + Util.mkAssume(mkForall (Ident.range_of_lid d) + ([[ty_pred]], + add_fuel (mk_fv (fuel_var, Fuel_sort)) (vars@arg_binders), + mkImp(ty_pred, mk_and_l prec)), + Some "subterm ordering", + ("subterm_ordering_"^ddconstrsym)) + in + let codomain_ordering, codomain_decls = + let _, formals' = BU.first_N n_tps formals in (* no codomain ordering for the parameters *) + let _, vars' = BU.first_N n_tps vars in + let norm t = + N.unfold_whnf' [Env.AllowUnboundUniverses; + Env.EraseUniverses; + Env.Unascribe; + //we don't know if this will terminate; so don't do recursive steps + Env.Exclude Env.Zeta] + env'.tcenv + t + in + let warn_compat () = + FStarC.Errors.log_issue fv FStarC.Errors.Warning_DeprecatedGeneric [ + Errors.Msg.text "Using 'compat:2954' to use a permissive encoding of the subterm ordering on the codomain of a constructor."; + Errors.Msg.text "This is deprecated and will be removed in a future version of F*." + ] + in + let codomain_prec_l, cod_decls = + List.fold_left2 + (fun (codomain_prec_l, cod_decls) formal var -> + let rec binder_and_codomain_type t = + let t = U.unrefine t in + match (SS.compress t).n with + | Tm_arrow _ -> + let bs, c = U.arrow_formals_comp (U.unrefine t) in + begin + match bs with + | [] -> None + | _ when not (U.is_tot_or_gtot_comp c) -> None + | _ -> + if U.is_lemma_comp c + then None //not useful for lemmas + else + let t = U.unrefine (U.comp_result c) in + let t = norm t in + if is_type t || U.is_sub_singleton t + then None //ordering on Type and squashed values is not useful + else ( + let head, _ = U.head_and_args_full t in + match (U.un_uinst head).n with + | Tm_fvar fv -> + if BU.for_some (S.fv_eq_lid fv) mutuals + then Some (bs, c) + else if Options.Ext.get "compat:2954" <> "" + then (warn_compat(); Some (bs, c)) //compatibility mode + else None + | _ -> + if Options.Ext.get "compat:2954" <> "" + then (warn_compat(); Some (bs, c)) //compatibility mode + else None + ) + end + | _ -> + let head, _ = U.head_and_args t in + let t' = norm t in + let head', _ = U.head_and_args t' in + match TEQ.eq_tm env.tcenv head head' with + | TEQ.Equal -> None //no progress after whnf + | TEQ.NotEqual -> binder_and_codomain_type t' + | _ -> + //Did we actually make progress? Be conservative to avoid an infinite loop + match (SS.compress head).n with + | Tm_fvar _ + | Tm_name _ + | Tm_uinst _ -> + //The underlying name must have changed, otherwise we would have got Equal + //so, we made some progress + binder_and_codomain_type t' + | _ -> + //unclear if we made progress or not + None + + in + match binder_and_codomain_type formal.binder_bv.sort with + | None -> + codomain_prec_l, cod_decls + | Some (bs, c) -> + //var bs << D ... var ... + let bs', guards', _env', bs_decls, _ = encode_binders None bs env' in + let fun_app = mk_Apply (mkFreeV var) bs' in + mkForall (Ident.range_of_lid d) + ([[mk_Precedes lex_t lex_t fun_app dapp]], + bs', + //need to use ty_pred' here, to avoid variable capture + //Note, ty_pred' is indexed by fuel, not S_fuel + //That's ok, since the outer pattern is guarded on S_fuel + mkImp (mk_and_l (ty_pred'::guards'), + mk_Precedes lex_t lex_t fun_app dapp)) + :: codomain_prec_l, + bs_decls @ cod_decls) + ([],[]) + formals' + vars' + in + match codomain_prec_l with + | [] -> + [], cod_decls + | _ -> + [Util.mkAssume(mkForall (Ident.range_of_lid d) + ([[ty_pred]],//we use ty_pred here as the pattern, which has an S_fuel guard + add_fuel (mk_fv (fuel_var, Fuel_sort)) (vars@arg_binders), + mk_and_l codomain_prec_l), + Some "well-founded ordering on codomain", + ("well_founded_ordering_on_codomain_"^ddconstrsym))], + cod_decls + in + arg_decls @ codomain_decls, + [typing_inversion; subterm_ordering] @ codomain_ordering + + | _ -> + Errors.log_issue se Errors.Warning_ConstructorBuildsUnexpectedType + (BU.format2 "Constructor %s builds an unexpected type %s" (show d) (show head)); + [], [] + in + let decls2, elim = encode_elim () in + let data_cons_typing_intro_decl = + // + //AR: + // + //Typing intro for the data constructor + // + //We do a bit of manipulation for type indices + //Consider the Cons data constructor of a length-indexed vector type: + // type vector : nat -> Type = | Emp : vector 0 + // | Cons: n:nat -> hd:nat -> tl:vec n -> vec (n+1) + // + //So far we have + // ty_pred' = HasTypeFuel f (Cons n hd tl) (vector (n+1)) + // vars = n, hd, tl + // guard = And of typing guards for n, hd, tl (i.e. (HasType n nat) etc.) + // + //If we emitted the straightforward typing axiom: + // forall n hd tl. HasTypeFuel f (Cons n hd tl) (vector (n+1)) + //with pattern + // HasTypeFuel f (Cons n hd tl) (vecor (n+1)) + // + //It results in too restrictive a pattern, + //Specifically, if we need to prove HasTypeFuel f (Cons 0 1 Emp) (vector 1), + // the axiom will not fire, since the pattern is specifically looking for + // (n+1) in the resulting vector type, whereas here we have a term 1, + // which is not addition syntactically + // + //So we do a little bit of surgery below to emit an axiom of the form: + // forall n hd tl m. m = n + 1 ==> HasTypeFuel f (Cons n hd tl) (vector m) + //where m is a fresh variable + // + //Also see #2456 + // + let ty_pred', vars, guard = + match t_res_tm.tm with + | App (op, args) -> + //iargs are index arguments in the return type of the data constructor + let targs, iargs = List.splitAt n_tps args in + //fresh vars for iargs + let fresh_ivars, fresh_iargs = + iargs |> List.map (fun _ -> fresh_fvar env.current_module_name "i" Term_sort) + |> List.split in + //equality guards + let additional_guards = + mk_and_l (List.map2 (fun a fresh_a -> mkEq (a, fresh_a)) iargs fresh_iargs) in + + mk_HasTypeWithFuel + (Some fuel_tm) + dapp + ({t_res_tm with tm = App (op, targs@fresh_iargs)}), + + vars@(fresh_ivars |> List.map (fun s -> mk_fv (s, Term_sort))), + + mkAnd (guard, additional_guards) + + | _ -> ty_pred', vars, guard in //When will this case arise? + + Util.mkAssume(mkForall (Ident.range_of_lid d) + ([[ty_pred']],add_fuel (mk_fv (fuel_var, Fuel_sort)) vars, mkImp(guard, ty_pred')), + Some "data constructor typing intro", + ("data_typing_intro_"^ddtok)) in + + let g = binder_decls + @decls2 + @decls3 + @([Term.DeclFun(ddtok, [], Term_sort, Some (BU.format1 "data constructor proxy: %s" (show d)))] + @proxy_fresh |> mk_decls_trivial) + @decls_pred + @([Util.mkAssume(tok_typing, Some "typing for data constructor proxy", ("typing_tok_"^ddtok)); + Util.mkAssume(mkForall (Ident.range_of_lid d) + ([[app]], vars, + mkEq(app, dapp)), Some "equality for proxy", ("equality_tok_"^ddtok)); + data_cons_typing_intro_decl; + ]@elim |> mk_decls_trivial) in + (datacons |> mk_decls_trivial) @ g, env + + +let rec encode_sigelt (env:env_t) (se:sigelt) : (decls_t & env_t) = + let nm = Print.sigelt_to_string_short se in + let g, env = Errors.with_ctx (BU.format1 "While encoding top-level declaration `%s`" + (Print.sigelt_to_string_short se)) + (fun () -> encode_sigelt' env se) + in + let g = + match g with + | [] -> + begin + if !dbg_SMTEncoding then + BU.print1 "Skipped encoding of %s\n" nm; + [Caption (BU.format1 "" nm)] |> mk_decls_trivial + end + + | _ -> ([Caption (BU.format1 "" nm)] |> mk_decls_trivial) + @g + @([Caption (BU.format1 "" nm)] |> mk_decls_trivial) in + g, env + +and encode_sigelt' (env:env_t) (se:sigelt) : (decls_t & env_t) = + if !dbg_SMTEncoding + then (BU.print1 "@@@Encoding sigelt %s\n" (show se)); + + let is_opaque_to_smt (t:S.term) = + match (SS.compress t).n with + | Tm_constant (Const_string(s, _)) -> s = "opaque_to_smt" + | _ -> false + in + let is_uninterpreted_by_smt (t:S.term) = + match (SS.compress t).n with + | Tm_constant (Const_string(s, _)) -> s = "uninterpreted_by_smt" + | _ -> false + in + match se.sigel with + | Sig_splice _ -> + failwith "impossible -- splice should have been removed by Tc.fs" + | Sig_fail _ -> + failwith "impossible -- Sig_fail should have been removed by Tc.fs" + | Sig_pragma _ + | Sig_effect_abbrev _ + | Sig_sub_effect _ + | Sig_polymonadic_bind _ + | Sig_polymonadic_subcomp _ -> [], env + + | Sig_new_effect(ed) -> + if not (is_smt_reifiable_effect env.tcenv ed.mname) + then [], env + else (* The basic idea: + 1. Encode M.bind_repr: a:Type -> b:Type -> wp_a -> wp_b -> f:st_repr a wp_a -> g:(a -> st_repr b) : st_repr b + = e + by encoding a function (erasing type arguments) + M.bind_repr (f Term) (g Term) : [[e]]] + + 2. Likewise for M.return_repr + + 3. For each action, a : x1:n -> ... -> xn:tn -> st_repr t wp = fun x1..xn -> e + encode forall x1..xn. Reify (Apply a x1 ... xn) = [[e]] + *) + let close_effect_params tm = + match ed.binders with + | [] -> tm + | _ -> S.mk (Tm_abs {bs=ed.binders; + body=tm; + rc_opt=Some (U.mk_residual_comp Const.effect_Tot_lid None [TOTAL])}) tm.pos + in + + let encode_action env (a:S.action) = + let action_defn = norm_before_encoding env (close_effect_params a.action_defn) in + let formals, _ = U.arrow_formals_comp a.action_typ in + let arity = List.length formals in + let aname, atok, env = new_term_constant_and_tok_from_lid env a.action_name arity in + let tm, decls = encode_term action_defn env in + let a_decls = + [Term.DeclFun(aname, formals |> List.map (fun _ -> Term_sort), Term_sort, Some "Action"); + Term.DeclFun(atok, [], Term_sort, Some "Action token")] + in + let _, xs_sorts, xs = + let aux ({binder_bv=bv}) (env, acc_sorts, acc) = + let xxsym, xx, env = gen_term_var env bv in + env, mk_fv (xxsym, Term_sort)::acc_sorts, xx::acc + in + List.fold_right aux formals (env, [], []) + in + (* let app = mkApp("Reify", [mkApp(aname, xs)]) in *) + let app = mkApp(aname, xs) in //arity ok; length xs = length formals = arity + let a_eq = + Util.mkAssume(mkForall (Ident.range_of_lid a.action_name) ([[app]], xs_sorts, mkEq(app, mk_Apply tm xs_sorts)), + Some "Action equality", + (aname ^"_equality")) + in + let tok_correspondence = + let tok_term = mkFreeV <| mk_fv (atok,Term_sort) in + let tok_app = mk_Apply tok_term xs_sorts in + Util.mkAssume(mkForall (Ident.range_of_lid a.action_name) ([[tok_app]], xs_sorts, mkEq(tok_app, app)), + Some "Action token correspondence", (aname ^ "_token_correspondence")) + in + env, decls@(a_decls@[a_eq; tok_correspondence] |> mk_decls_trivial) + in + + let env, decls2 = BU.fold_map encode_action env ed.actions in + List.flatten decls2, env + + | Sig_declare_typ {lid} when (lid_equals lid Const.precedes_lid) -> + //precedes is added in the prelude, see FStarC.SMTEncoding.Term.fs + let tname, ttok, env = new_term_constant_and_tok_from_lid env lid 4 in + [], env + + | Sig_declare_typ {lid; us; t} -> + let quals = se.sigquals in + let will_encode_definition = not (quals |> BU.for_some (function + | Assumption | Projector _ | Discriminator _ | Irreducible -> true + | _ -> false)) in + if will_encode_definition + then [], env //nothing to do at the declaration; wait to encode the definition + else let fv = S.lid_as_fv lid None in + let decls, env = + encode_top_level_val + (se.sigattrs |> BU.for_some is_uninterpreted_by_smt) + env us fv t quals in + let tname = (string_of_lid lid) in + let tsym = Option.get (try_lookup_free_var env lid) in + decls + @ (primitive_type_axioms env.tcenv lid tname tsym |> mk_decls_trivial), + env + + | Sig_assume {lid=l; us; phi=f} -> + let uvs, f = SS.open_univ_vars us f in + let env = { env with tcenv = Env.push_univ_vars env.tcenv uvs } in + let f = norm_before_encoding env f in + let f, decls = encode_formula f env in + let g = [Util.mkAssume(f, Some (BU.format1 "Assumption: %s" (show l)), (varops.mk_unique ("assumption_"^(string_of_lid l))))] + |> mk_decls_trivial in + decls@g, env + + (* Irreducible and opaque lets. Replace the definitions by a dummy val decl (if none + exists) and re-run. *) + | Sig_let {lbs} + when se.sigquals |> List.contains S.Irreducible + || se.sigattrs |> BU.for_some is_opaque_to_smt -> + let attrs = se.sigattrs in + let env, decls = BU.fold_map (fun env lb -> + let lid = (BU.right lb.lbname).fv_name.v in + if Option.isNone <| Env.try_lookup_val_decl env.tcenv lid + then let val_decl = { se with sigel = Sig_declare_typ {lid; us=lb.lbunivs; t=lb.lbtyp}; + sigquals = S.Irreducible :: se.sigquals } in + let decls, env = encode_sigelt' env val_decl in + env, decls + else env, []) env (snd lbs) in + List.flatten decls, env + + (* Special encoding for b2t *) + | Sig_let {lbs=(_, [{lbname=Inr b2t}])} when S.fv_eq_lid b2t Const.b2t_lid -> + let tname, ttok, env = new_term_constant_and_tok_from_lid env b2t.fv_name.v 1 in + let xx = mk_fv ("x", Term_sort) in + let x = mkFreeV xx in + let b2t_x = mkApp("Prims.b2t", [x]) in + let valid_b2t_x = mkApp("Valid", [b2t_x]) in //NS: Explicitly avoid the Vaild(b2t t) inlining + let bool_ty = lookup_free_var env (withsort Const.bool_lid) in + let decls = [Term.DeclFun(tname, [Term_sort], Term_sort, None); + Util.mkAssume(mkForall (S.range_of_fv b2t) ([[b2t_x]], [xx], + mkEq(valid_b2t_x, mkApp(snd boxBoolFun, [x]))), + Some "b2t def", + "b2t_def"); + Util.mkAssume(mkForall (S.range_of_fv b2t) ([[b2t_x]], [xx], + mkImp(mk_HasType x bool_ty, + mk_HasType b2t_x mk_Term_type)), + Some "b2t typing", + "b2t_typing")] in + decls |> mk_decls_trivial, env + + (* Discriminators *) + | Sig_let _ when (se.sigquals |> BU.for_some (function Discriminator _ -> true | _ -> false)) -> + //Discriminators are encoded directly via (our encoding of) theory of datatypes + if !dbg_SMTEncoding then + BU.print1 "Not encoding discriminator '%s'\n" (Print.sigelt_to_string_short se); + [], env + + (* `unfold let` definitions in prims do not get encoded. *) + | Sig_let {lids} when (lids |> BU.for_some (fun (l:lident) -> string_of_id (List.hd (ns_of_lid l)) = "Prims") + && se.sigquals |> BU.for_some (function Unfold_for_unification_and_vcgen -> true | _ -> false)) -> + //inline lets from prims are never encoded as definitions --- since they will be inlined + if !dbg_SMTEncoding then + BU.print1 "Not encoding unfold let from Prims '%s'\n" (Print.sigelt_to_string_short se); + [], env + + (* Projectors *) + | Sig_let {lbs=(false, [lb])} + when (se.sigquals |> BU.for_some (function Projector _ -> true | _ -> false)) -> + //Projectors are also are encoded directly via (our encoding of) theory of datatypes + //Except in some cases where the front-end does not emit a declare_typ for some projector, because it doesn't know how to compute it + let fv = BU.right lb.lbname in + let l = fv.fv_name.v in + begin match try_lookup_free_var env l with + | Some _ -> + [], env //already encoded + | None -> + let se = {se with sigel = Sig_declare_typ {lid=l; us=lb.lbunivs; t=lb.lbtyp}; sigrng = Ident.range_of_lid l } in + encode_sigelt env se + end + + (* A normal let, perhaps recursive. *) + | Sig_let {lbs=(is_rec, bindings)} -> + let bindings = + List.map + (fun lb -> + let def = norm_before_encoding_us env lb.lbunivs lb.lbdef in + let typ = norm_before_encoding_us env lb.lbunivs lb.lbtyp in + {lb with lbdef=def; lbtyp=typ}) + bindings + in + encode_top_level_let env (is_rec, bindings) se.sigquals + + | Sig_bundle {ses} -> + let g, env = + ses |> + List.fold_left + (fun (g, env) se -> + let g', env = + match se.sigel with + | Sig_inductive_typ _ -> + encode_sig_inductive env se + | Sig_datacon _ -> + encode_datacon env se + | _ -> + encode_sigelt env se + in + g@g', env) + ([], env) + in + //reorder the generated decls in proper def-use order, + //i.e, declare all the function symbols first + //1. move the inversions last; they rely on all the symbols + let g', inversions = + List.fold_left + (fun (g', inversions) elt -> + let elt_g', elt_inversions = + elt.decls |> + List.partition + (function + | Term.Assume({assumption_caption=Some "inversion axiom"}) -> false + | _ -> true) + in + g' @ [ { elt with decls = elt_g' } ], + inversions @ elt_inversions) + ([], []) + g + in + //2. decls are all the function symbol declarations + // elts: all elements that have a key and which contain function declarations (not sure why this class is important to pull out) + // rest: all the non-declarations, excepting the inversion axiom which is already identified above + let decls, elts, rest = + List.fold_left + (fun (decls, elts, rest) elt -> + if BU.is_some elt.key //NS: Not sure what this case is for + && List.existsb (function | Term.DeclFun _ -> true | _ -> false) elt.decls + then decls, elts@[elt], rest + else ( //Pull the function symbol decls to the front + let elt_decls, elt_rest = + elt.decls |> + List.partition + (function + | Term.DeclFun _ -> true + | _ -> false) + in + decls @ elt_decls, elts, rest @ [ { elt with decls = elt_rest }] + )) + ([], [], []) g' + in + (decls |> mk_decls_trivial) @ elts @ rest @ (inversions |> mk_decls_trivial), env + +let encode_env_bindings (env:env_t) (bindings:list S.binding) : (decls_t & env_t) = + (* Encoding Binding_var and Binding_typ as local constants leads to breakages in hash consing. + + Consider: + + type t + type Good : nat -> Type + type s (ps:nat) = m:t{Good ps} + let f (ps':nat) (pi:(s ps' * unit)) = e + + When encoding a goal formula derived from e, ps' and pi are Binding_var in the environment. + They get encoded to constants, declare-fun ps', pi etc. + Now, when encoding the type of pi, we encode the (s ps') as a refinement type (m:t{Good ps'}). + So far so good. + But, the trouble is that since ps' is a constant, we build a formula for the refinement type that does not + close over ps'---constants are not subject to closure. + So, we get a formula that is syntactically different than what we get when encoding the type s, where (ps:nat) is + a locally bound free variable and _is_ subject to closure. + The syntactic difference leads to the hash consing lookup failing. + + So: + Instead of encoding Binding_vars as declare-funs, we can try to close the query formula over the vars in the context, + thus demoting them to free variables subject to closure. + + *) + let encode_binding b (i, decls, env) = match b with + | S.Binding_univ _ -> + i+1, decls, env + + | S.Binding_var x -> + let t1 = norm_before_encoding env x.sort in + if !dbg_SMTEncoding + then (BU.print3 "Normalized %s : %s to %s\n" (show x) (show x.sort) (show t1)); + let t, decls' = encode_term t1 env in + let t_hash = Term.hash_of_term t in + let xxsym, xx, env' = + new_term_constant_from_string env x + ("x_" ^ BU.digest_of_string t_hash ^ "_" ^ (string_of_int i)) in + let t = mk_HasTypeWithFuel None xx t in + let caption = + if Options.log_queries() + then Some (BU.format3 "%s : %s (%s)" (show x) (show x.sort) (show t1)) + else None in + let ax = + let a_name = ("binder_"^xxsym) in + Util.mkAssume(t, Some a_name, a_name) in + let g = ([Term.DeclFun(xxsym, [], Term_sort, caption)] |> mk_decls_trivial) + @decls' + @([ax] |> mk_decls_trivial) in + i+1, decls@g, env' + + | S.Binding_lid(x, (_, t)) -> + let t_norm = norm_before_encoding env t in + let fv = S.lid_as_fv x None in +// Printf.printf "Encoding %s at type %s\n" (show x) (show t); + let g, env' = encode_free_var false env fv t t_norm [] in + i+1, decls@g, env' + in + let _, decls, env = List.fold_right encode_binding bindings (0, [], env) in + decls, env + +let encode_labels (labs:list error_label) = + let prefix = labs |> List.map (fun (l, _, _) -> Term.DeclFun(fv_name l, [], Bool_sort, None)) in + let suffix = labs |> List.collect (fun (l, _, _) -> [Echo <| fv_name l; Eval (mkFreeV l)]) in + prefix, suffix + +(* caching encodings of the environment and the top-level API to the encoding *) +let last_env : ref (list env_t) = BU.mk_ref [] +let init_env tcenv = last_env := [{bvar_bindings=BU.psmap_empty (); + fvar_bindings=(BU.psmap_empty (), []); + tcenv=tcenv; warn=true; depth=0; + nolabels=false; use_zfuel_name=false; + encode_non_total_function_typ=true; encoding_quantifier=false; + current_module_name=Env.current_module tcenv |> Ident.string_of_lid; + global_cache = BU.smap_create 100}] +let get_env cmn tcenv = match !last_env with + | [] -> failwith "No env; call init first!" + | e::_ -> {e with tcenv=tcenv; current_module_name=Ident.string_of_lid cmn} +let set_env env = match !last_env with + | [] -> failwith "Empty env stack" + | _::tl -> last_env := env::tl +let get_current_env tcenv = get_env (Env.current_module tcenv) tcenv +let push_env () = match !last_env with + | [] -> failwith "Empty env stack" + | hd::tl -> + let top = copy_env hd in + last_env := top::hd::tl +let pop_env () = match !last_env with + | [] -> failwith "Popping an empty stack" + | _::tl -> last_env := tl +let snapshot_env () = FStarC.Common.snapshot push_env last_env () +let rollback_env depth = FStarC.Common.rollback pop_env last_env depth +(* TOP-LEVEL API *) + +let init tcenv = + init_env tcenv; + Z3.giveZ3 [DefPrelude] +let snapshot_encoding msg = BU.atomically (fun () -> + let env_depth, () = snapshot_env () in + let varops_depth, () = varops.snapshot () in + (env_depth, varops_depth)) +let rollback_encoding msg (depth:option encoding_depth) = BU.atomically (fun () -> + let env_depth, varops_depth = match depth with + | Some (s1, s2) -> Some s1, Some s2 + | None -> None, None in + rollback_env env_depth; + varops.rollback varops_depth) +let push_encoding_state msg = let _ = snapshot_encoding msg in () +let pop_encoding_state msg = rollback_encoding msg None + +////////////////////////////////////////////////////////////////////////// +//guarding top-level terms with fact database triggers +////////////////////////////////////////////////////////////////////////// +let open_fact_db_tags (env:env_t) : list fact_db_id = [] //TODO + +let place_decl_in_fact_dbs (env:env_t) (fact_db_ids:list fact_db_id) (d:decl) : decl = + match fact_db_ids, d with + | _::_, Assume a -> + Assume ({a with assumption_fact_ids=fact_db_ids}) + | _ -> d + +let place_decl_elt_in_fact_dbs (env:env_t) (fact_db_ids:list fact_db_id) (elt:decls_elt) :decls_elt = + { elt with decls = elt.decls |> List.map (place_decl_in_fact_dbs env fact_db_ids) } + +let fact_dbs_for_lid (env:env_t) (lid:Ident.lid) = + Name lid + ::Namespace (Ident.lid_of_ids (ns_of_lid lid)) + ::open_fact_db_tags env + +let encode_top_level_facts (env:env_t) (se:sigelt) = + let fact_db_ids = + U.lids_of_sigelt se |> List.collect (fact_dbs_for_lid env) + in + let g, env = encode_sigelt env se in + let g = g |> List.map (place_decl_elt_in_fact_dbs env fact_db_ids) in + g, env +////////////////////////////////////////////////////////////////////////// +//end: guarding top-level terms with fact database triggers +////////////////////////////////////////////////////////////////////////// + + +(* + * AR: Recover hashconsing of decls -- both within a module and across modules + * Using and updating env.global_cache + *) +let recover_caching_and_update_env (env:env_t) (decls:decls_t) :decls_t = + decls |> List.collect (fun elt -> + if elt.key = None then [elt] //not meant to be hashconsed, keep it + else ( + match BU.smap_try_find env.global_cache (elt.key |> BU.must) with + | Some cache_elt -> [Term.RetainAssumptions cache_elt.a_names] |> mk_decls_trivial //hit, retain a_names from the hit entry + //AND drop elt + | None -> //no hit, update cache and retain elt + BU.smap_add env.global_cache (elt.key |> BU.must) elt; + [elt] + ) + ) + +let encode_sig tcenv se = + let caption decls = + if Options.log_queries() + then Term.Caption ("encoding sigelt " ^ Print.sigelt_to_string_short se)::decls + else decls in + if Debug.medium () + then BU.print1 "+++++++++++Encoding sigelt %s\n" (show se); + let env = get_env (Env.current_module tcenv) tcenv in + let decls, env = encode_top_level_facts env se in + set_env env; + Z3.giveZ3 (caption (decls |> recover_caching_and_update_env env |> decls_list_of)) + +let give_decls_to_z3_and_set_env (env:env_t) (name:string) (decls:decls_t) :unit = + let caption decls = + if Options.log_queries() + then let msg = "Externals for " ^ name in + [Module(name, Caption msg::decls@[Caption ("End " ^ msg)])] + else [Module(name, decls)] in + set_env ({env with warn=true}); + //recover caching and flatten before giving to Z3 + let z3_decls = caption (decls |> recover_caching_and_update_env env |> decls_list_of) in + Z3.giveZ3 z3_decls + +let encode_modul tcenv modul = + if Options.lax() && Options.ml_ish() then [], [] + else begin + let tcenv = Env.set_current_module tcenv modul.name in + UF.with_uf_enabled (fun () -> + varops.reset_fresh (); + let name = BU.format2 "%s %s" (if modul.is_interface then "interface" else "module") (string_of_lid modul.name) in + if Debug.medium () + then BU.print2 "+++++++++++Encoding externals for %s ... %s declarations\n" name (List.length modul.declarations |> string_of_int); + let env = get_env modul.name tcenv |> reset_current_module_fvbs in + let encode_signature (env:env_t) (ses:sigelts) = + ses |> List.fold_left (fun (g, env) se -> + let g', env = encode_top_level_facts env se in + g@g', env) ([], env) + in + let decls, env = encode_signature ({env with warn=false}) modul.declarations in + give_decls_to_z3_and_set_env env name decls; + if Debug.medium () then BU.print1 "Done encoding externals for %s\n" name; + decls, env |> get_current_module_fvbs + ) end + +let encode_modul_from_cache tcenv tcmod (decls, fvbs) = + if Options.lax () && Options.ml_ish () then () + else + let tcenv = Env.set_current_module tcenv tcmod.name in + let name = BU.format2 "%s %s" (if tcmod.is_interface then "interface" else "module") (string_of_lid tcmod.name) in + if Debug.medium () + then BU.print2 "+++++++++++Encoding externals from cache for %s ... %s decls\n" name (List.length decls |> string_of_int); + let env = get_env tcmod.name tcenv |> reset_current_module_fvbs in + let env = + fvbs |> List.rev |> List.fold_left (fun env fvb -> + add_fvar_binding_to_env fvb env + ) env in + give_decls_to_z3_and_set_env env name decls; + if Debug.medium () then BU.print1 "Done encoding externals from cache for %s\n" name + +open FStarC.SMTEncoding.Z3 +let encode_query use_env_msg (tcenv:Env.env) (q:S.term) + : list decl //prelude, translation of tcenv + & list ErrorReporting.label //labels in the query + & decl //the query itself + & list decl //suffix, evaluating labels in the model, etc. + = + Errors.with_ctx "While encoding a query" (fun () -> + Z3.query_logging.set_module_name (string_of_lid (TypeChecker.Env.current_module tcenv)); + let env = get_env (Env.current_module tcenv) tcenv in + let q, bindings = + let rec aux bindings = match bindings with + | S.Binding_var x::rest -> + let out, rest = aux rest in + let t = + match (Syntax.Formula.destruct_typ_as_formula x.sort) with + | Some _ -> + U.refine (S.new_bv None t_unit) x.sort + //add a squash to trigger the shallow embedding, + //if the assumption is of the form x:(forall y. P) etc. + | _ -> + x.sort in + let t = norm_with_steps [Env.Eager_unfolding; Env.Beta; Env.Simplify; Env.Primops; Env.EraseUniverses] env.tcenv t in + Syntax.mk_binder ({x with sort=t})::out, rest + | _ -> [], bindings in + let closing, bindings = aux tcenv.gamma in + U.close_forall_no_univs (List.rev closing) q, bindings + in + let env_decls, env = encode_env_bindings env bindings in + if Debug.medium () || !dbg_SMTEncoding || !dbg_SMTQuery + then BU.print1 "Encoding query formula {: %s\n" (show q); + let (phi, qdecls), ms = BU.record_time (fun () -> encode_formula q env) in + let labels, phi = ErrorReporting.label_goals use_env_msg (Env.get_range tcenv) phi in + let label_prefix, label_suffix = encode_labels labels in + let caption = + (* If these options are off, the Captions will be dropped anyway, + but by checking here we can skip the printing. *) + if Options.log_queries () || Options.log_failing_queries () + then [Caption ("Encoding query formula : " ^ (show q)); + Caption ("Context: " ^ String.concat "\n" (Errors.get_ctx ()))] + else [] + in + let query_prelude = + env_decls + @(label_prefix |> mk_decls_trivial) + @qdecls + @(caption |> mk_decls_trivial) |> recover_caching_and_update_env env |> decls_list_of in //recover caching and flatten + + let qry = Util.mkAssume(mkNot phi, Some "query", (varops.mk_unique "@query")) in + let suffix = [Term.Echo ""] @ label_suffix @ [Term.Echo ""; Term.Echo "Done!"] in + if Debug.medium () || !dbg_SMTEncoding || !dbg_SMTQuery + then BU.print_string "} Done encoding\n"; + if Debug.medium () || !dbg_SMTEncoding || !dbg_Time + then BU.print1 "Encoding took %sms\n" (string_of_int ms); + query_prelude, labels, qry, suffix + ) diff --git a/src/smtencoding/FStarC.SMTEncoding.Encode.fsti b/src/smtencoding/FStarC.SMTEncoding.Encode.fsti new file mode 100644 index 00000000000..7923f45d0ae --- /dev/null +++ b/src/smtencoding/FStarC.SMTEncoding.Encode.fsti @@ -0,0 +1,39 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.SMTEncoding.Encode +open FStarC.Compiler.Effect +open FStarC.SMTEncoding.Term +module ErrorReporting = FStarC.SMTEncoding.ErrorReporting +module S = FStarC.Syntax.Syntax +module Env = FStarC.TypeChecker.Env +type encoding_depth = int & int +val push_encoding_state: string -> unit +val pop_encoding_state: string -> unit +val snapshot_encoding: string -> encoding_depth +val rollback_encoding: string -> option encoding_depth -> unit +val init: Env.env -> unit +val get_current_env: Env.env -> FStarC.SMTEncoding.Env.env_t +val encode_sig: Env.env -> S.sigelt -> unit +val encode_modul: Env.env -> S.modul -> decls_t & list FStarC.SMTEncoding.Env.fvar_binding +//the lident is the module name +val encode_modul_from_cache: Env.env -> S.modul -> (decls_t & list FStarC.SMTEncoding.Env.fvar_binding) -> unit +val encode_query: option (unit -> string) + -> Env.env + -> S.term + -> list decl //prelude, translation of tcenv + & list ErrorReporting.label //labels in the query + & decl //the query itself + & list decl //suffix, evaluating labels in the model, etc \ No newline at end of file diff --git a/src/smtencoding/FStarC.SMTEncoding.EncodeTerm.fst b/src/smtencoding/FStarC.SMTEncoding.EncodeTerm.fst new file mode 100644 index 00000000000..a151568d04a --- /dev/null +++ b/src/smtencoding/FStarC.SMTEncoding.EncodeTerm.fst @@ -0,0 +1,1687 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.SMTEncoding.EncodeTerm +open Prims +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.Defensive +open FStarC.TypeChecker.Env +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.TypeChecker +open FStarC.SMTEncoding.Term +open FStarC.Ident +open FStarC.Const +open FStarC.SMTEncoding +open FStarC.SMTEncoding.Util +open FStarC.SMTEncoding.Env + +module BU = FStarC.Compiler.Util +module Const = FStarC.Parser.Const +module EMB = FStarC.Syntax.Embeddings +module Env = FStarC.TypeChecker.Env +module N = FStarC.TypeChecker.Normalize +module RC = FStarC.Reflection.V2.Constants +module RE = FStarC.Reflection.V2.Embeddings +module R = FStarC.Reflection.V2.Builtins +module SE = FStarC.Syntax.Embeddings +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module TcUtil = FStarC.TypeChecker.Util +module U = FStarC.Syntax.Util + +open FStarC.Class.Show +open FStarC.Class.Tagged +open FStarC.Class.Setlike + +let dbg_PartialApp = Debug.get_toggle "PartialApp" +let dbg_SMTEncoding = Debug.get_toggle "SMTEncoding" +let dbg_SMTEncodingReify = Debug.get_toggle "SMTEncodingReify" + +(*---------------------------------------------------------------------------------*) +(* *) + +let mkForall_fuel' mname r n (pats, vars, body) = + let fallback () = mkForall r (pats, vars, body) in + if (Options.unthrottle_inductives()) + then fallback () + else let fsym, fterm = fresh_fvar mname "f" Fuel_sort in + let add_fuel tms = + tms |> List.map (fun p -> match p.tm with + | Term.App(Var "HasType", args) -> mkApp("HasTypeFuel", fterm::args) + | _ -> p) in + let pats = List.map add_fuel pats in + let body = match body.tm with + | Term.App(Imp, [guard; body']) -> + let guard = match guard.tm with + | App(And, guards) -> mk_and_l (add_fuel guards) + | _ -> add_fuel [guard] |> List.hd in + mkImp(guard,body') + | _ -> body in + let vars = mk_fv (fsym, Fuel_sort)::vars in + mkForall r (pats, vars, body) + +let mkForall_fuel mname r = mkForall_fuel' mname r 1 + +let head_normal env t = + let t = U.unmeta t in + match t.n with + | Tm_arrow _ + | Tm_refine _ + | Tm_bvar _ + | Tm_uvar _ + | Tm_abs _ + | Tm_constant _ -> true + | Tm_fvar fv + | Tm_app {hd={n=Tm_fvar fv}} -> Env.lookup_definition [Env.Eager_unfolding_only] env.tcenv fv.fv_name.v |> Option.isNone + | _ -> false + +let head_redex env t = + match (U.un_uinst t).n with + | Tm_abs {rc_opt=Some rc} -> + Ident.lid_equals rc.residual_effect Const.effect_Tot_lid + || Ident.lid_equals rc.residual_effect Const.effect_GTot_lid + || List.existsb (function TOTAL -> true | _ -> false) rc.residual_flags + + | Tm_fvar fv -> + Env.lookup_definition [Env.Eager_unfolding_only] env.tcenv fv.fv_name.v |> Option.isSome + + | _ -> false + +let norm_with_steps steps env t = + Profiling.profile + (fun () -> N.normalize steps env t) + (Some (Ident.string_of_lid (Env.current_module env))) + "FStarC.SMTEncoding.EncodeTerm.norm_with_steps" + +let normalize_refinement steps env t = + Profiling.profile + (fun () -> N.normalize_refinement steps env t) + (Some (Ident.string_of_lid (Env.current_module env))) + "FStarC.SMTEncoding.EncodeTerm.normalize_refinement" + +let whnf env t = + if head_normal env t then t + else norm_with_steps [Env.Beta; Env.Weak; Env.HNF; Env.Exclude Env.Zeta; //we don't know if it will terminate, so no recursion + Env.Eager_unfolding; Env.EraseUniverses] env.tcenv t +let norm env t = norm_with_steps [Env.Beta; Env.Exclude Env.Zeta; //we don't know if it will terminate, so no recursion + Env.Eager_unfolding; Env.EraseUniverses] env.tcenv t + +(* `maybe_whnf env t` attempts to reduce t to weak-head normal form. + * It is called when `t` is a head redex, e.g., if its head symbol is marked for unfolding. + * However, if its head symbol is also marked as `strict_on_arguments`, then if it is applied + * to non-constant arguments, then it may actually not be unfolded. + * In those cases `maybe_whnf env t` may not reduce `t` at all. + * In callers of this code, we need to be careful to check that if `t` was not reduced, then + * we do not enter into infinite loops by recursing on `t` itself. + *) + +let maybe_whnf env t = + let t' = whnf env t in + let head', _ = U.head_and_args t' in + if head_redex env head' //this wasn't reducible for some reason, e.g., not applied to strict arguments + then None + else Some t' + +let trivial_post t : Syntax.term = + U.abs [null_binder t] + (Syntax.fvar Const.true_lid None) + None + +let mk_Apply e (vars:fvs) = + vars |> List.fold_left (fun out var -> + match fv_sort var with + | Fuel_sort -> mk_ApplyTF out (mkFreeV var) + | s -> + // let _ = if s <> Term_sort then (printfn "Expected Term_sort; got %A" s; failwith "DIE!") in + mk_ApplyTT out (mkFreeV var)) e +let mk_Apply_args e args = args |> List.fold_left mk_ApplyTT e +let raise_arity_mismatch head arity n_args rng = + Errors.raise_error rng Errors.Fatal_SMTEncodingArityMismatch + (BU.format3 "Head symbol %s expects at least %s arguments; got only %s" + head + (show arity) + (show n_args)) + +//See issue #1750 and tests/bug-reports/Bug1750.fst +let isTotFun_axioms pos head vars guards is_pure = + let maybe_mkForall pat vars body = + match vars with + | [] -> body + | _ -> mkForall pos (pat, vars, body) + in + let rec is_tot_fun_axioms ctx ctx_guard head vars guards = + match vars, guards with + | [], [] -> + mkTrue + + | [_], _ -> + //last arrow, the effect label tells us if its pure or not + if is_pure + then maybe_mkForall [[head]] ctx (mkImp (ctx_guard, mk_IsTotFun head)) + else mkTrue + + | x::vars, g_x::guards -> + //curried arrow with more than 1 argument + //head is definitely Tot + let is_tot_fun_head = + maybe_mkForall [[head]] ctx (mkImp (ctx_guard, mk_IsTotFun head)) + in + let app = mk_Apply head [x] in + let ctx = ctx @ [x] in + let ctx_guard = mkAnd (ctx_guard, g_x) in + let rest = is_tot_fun_axioms ctx ctx_guard app vars guards in + mkAnd (is_tot_fun_head, rest) + + | _ -> + failwith "impossible: isTotFun_axioms" + in + is_tot_fun_axioms [] mkTrue head vars guards + +let maybe_curry_app rng (head:either op term) (arity:int) (args:list term) : term = + let n_args = List.length args in + match head with + | Inr head -> //must curry + mk_Apply_args head args + + | Inl head -> + if n_args = arity + then Util.mkApp'(head, args) + else if n_args > arity + then let args, rest = BU.first_N arity args in + let head = Util.mkApp'(head, args) in + mk_Apply_args head rest + else raise_arity_mismatch (Term.op_to_string head) arity n_args rng + +let maybe_curry_fvb rng fvb args = + if fvb.fvb_thunked + then mk_Apply_args (force_thunk fvb) args + else maybe_curry_app rng (Inl (Var fvb.smt_id)) fvb.smt_arity args + +let is_app = function + | Var "ApplyTT" + | Var "ApplyTF" -> true + | _ -> false + +let check_pattern_vars env vars pats = + let pats = + pats |> List.map (fun (x, _) -> + norm_with_steps [Env.Beta;Env.AllowUnboundUniverses;Env.EraseUniverses] env.tcenv x) + in + match pats with + | [] -> () + | hd::tl -> + let pat_vars = List.fold_left (fun out x -> union out (Free.names x)) (Free.names hd) tl in + match vars |> BU.find_opt (fun ({binder_bv=b}) -> not (mem b pat_vars)) with + | None -> () + | Some ({binder_bv=x}) -> + let pos = List.fold_left (fun out t -> Range.union_ranges out t.pos) hd.pos tl in + Errors.log_issue pos Errors.Warning_SMTPatternIllFormed + (BU.format1 "SMT pattern misses at least one bound variable: %s" (show x)) + +(* *) + +(**********************************************************************************) +(* The main encoding of terms and formulae: mutually recursive *) +(* see fstar-priv/papers/mm/encoding.txt for a semi-formal sketch of the encoding *) +(**********************************************************************************) + +(* Abstractly: + + ctx = (bvvdef -> term(Term_sort)) + ex = set (var x term(Bool)) existentially bound variables + [[e]] : ctx -> term(Term_sort) * ex + [[f]] : ctx -> term(Bool) + [[bs]] : ctx -> (vars + * term(Bool) <-- guard on bound vars + * ctx) <-- context extended with bound vars + + Concretely, [[*]] are the encode_* functions, for exp, formula, binders + ctx is implemented using env_t + and term( * ) is just term + *) + +type label = (fv & string & Range.range) +type labels = list label +type pattern = { + pat_vars: list (bv & fv); + pat_term: unit -> (term & decls_t); (* the pattern as a term(exp) *) + guard: term -> term; (* the guard condition of the pattern, as applied to a particular scrutinee term(exp) *) + projections: term -> list (bv & term) (* bound variables of the pattern, and the corresponding projected components of the scrutinee *) + } + +let as_function_typ env t0 = + let rec aux norm t = + let t = SS.compress t in + match t.n with + | Tm_arrow _ -> t + | Tm_refine _ -> aux true (U.unrefine t) + | _ -> if norm + then aux false (whnf env t) + else failwith (BU.format2 "(%s) Expected a function typ; got %s" (Range.string_of_range t0.pos) (show t0)) + in aux true t0 + +let rec curried_arrow_formals_comp k = + let k = Subst.compress k in + match k.n with + | Tm_arrow {bs; comp=c} -> Subst.open_comp bs c + | Tm_refine {b=bv} -> + let args, res = curried_arrow_formals_comp bv.sort in + begin + match args with + | [] -> [], Syntax.mk_Total k + | _ -> args, res + end + | _ -> [], Syntax.mk_Total k + +let is_arithmetic_primitive head args = + match head.n, args with + | Tm_fvar fv, [_;_]-> + S.fv_eq_lid fv Const.op_Addition + || S.fv_eq_lid fv Const.op_Subtraction + || S.fv_eq_lid fv Const.op_Multiply + || S.fv_eq_lid fv Const.op_Division + || S.fv_eq_lid fv Const.op_Modulus + || S.fv_eq_lid fv Const.real_op_LT + || S.fv_eq_lid fv Const.real_op_LTE + || S.fv_eq_lid fv Const.real_op_GT + || S.fv_eq_lid fv Const.real_op_GTE + || S.fv_eq_lid fv Const.real_op_Addition + || S.fv_eq_lid fv Const.real_op_Subtraction + || S.fv_eq_lid fv Const.real_op_Multiply + || S.fv_eq_lid fv Const.real_op_Division + + | Tm_fvar fv, [_] -> + S.fv_eq_lid fv Const.op_Minus + + | _ -> false + +let isInteger (tm: Syntax.term') : bool = + match tm with + | Tm_constant (Const_int (n,None)) -> true + | _ -> false + +let getInteger (tm : Syntax.term') = + match tm with + | Tm_constant (Const_int (n,None)) -> FStarC.Compiler.Util.int_of_string n + | _ -> failwith "Expected an Integer term" + +(* We only want to encode a term as a bitvector term (not an uninterpreted function) + if there is a concrete/constant size argument given*) +let is_BitVector_primitive head args = + match head.n, args with + | Tm_fvar fv, [(sz_arg, _);_;_] -> + (S.fv_eq_lid fv Const.bv_and_lid + || S.fv_eq_lid fv Const.bv_xor_lid + || S.fv_eq_lid fv Const.bv_or_lid + || S.fv_eq_lid fv Const.bv_add_lid + || S.fv_eq_lid fv Const.bv_sub_lid + || S.fv_eq_lid fv Const.bv_shift_left_lid + || S.fv_eq_lid fv Const.bv_shift_right_lid + || S.fv_eq_lid fv Const.bv_udiv_lid + || S.fv_eq_lid fv Const.bv_mod_lid + || S.fv_eq_lid fv Const.bv_mul_lid + || S.fv_eq_lid fv Const.bv_shift_left'_lid + || S.fv_eq_lid fv Const.bv_shift_right'_lid + || S.fv_eq_lid fv Const.bv_udiv_unsafe_lid + || S.fv_eq_lid fv Const.bv_mod_unsafe_lid + || S.fv_eq_lid fv Const.bv_mul'_lid + || S.fv_eq_lid fv Const.bv_ult_lid + || S.fv_eq_lid fv Const.bv_uext_lid) && + (isInteger sz_arg.n) + | Tm_fvar fv, [(sz_arg, _); _] -> + (S.fv_eq_lid fv Const.nat_to_bv_lid + || S.fv_eq_lid fv Const.bv_to_nat_lid) && + (isInteger sz_arg.n) + + | _ -> false + +let rec encode_const c env = + Errors.with_ctx "While encoding a constant to SMT" (fun () -> + match c with + | Const_unit -> mk_Term_unit, [] + | Const_bool true -> boxBool mkTrue, [] + | Const_bool false -> boxBool mkFalse, [] + | Const_char c -> mkApp("FStar.Char.__char_of_int", [boxInt (mkInteger' (BU.int_of_char c))]), [] + | Const_int (i, None) -> boxInt (mkInteger i), [] + | Const_int (repr, Some sw) -> + let syntax_term = FStarC.ToSyntax.ToSyntax.desugar_machine_integer env.tcenv.dsenv repr sw Range.dummyRange in + encode_term syntax_term env + | Const_string(s, _) -> Term.boxString <| mk_String_const s, [] + | Const_range _ -> mk_Range_const (), [] + | Const_effect -> mk_Term_type, [] + | Const_real r -> boxReal (mkReal r), [] + | c -> failwith (BU.format1 "Unhandled constant: %s" (show c)) + ) +and encode_binders (fuel_opt:option term) (bs:Syntax.binders) (env:env_t) : + (list fv (* translated bound variables *) + & list term (* guards *) + & env_t (* extended context *) + & decls_t (* top-level decls to be emitted *) + & list bv) (* names *) = + + if Debug.medium () then BU.print1 "Encoding binders %s\n" (show bs); + + let vars, guards, env, decls, names = + bs |> List.fold_left + (fun (vars, guards, env, decls, names) b -> + let v, g, env, decls', n = + let x = b.binder_bv in + let xxsym, xx, env' = gen_term_var env x in + let guard_x_t, decls' = + encode_term_pred fuel_opt (norm env x.sort) env xx + in //if we had polarities, we could generate a mkHasTypeZ here in the negative case + mk_fv (xxsym, Term_sort), + guard_x_t, + env', + decls', + x + in + v::vars, g::guards, env, decls@decls', n::names) + ([], [], env, [], []) + in + List.rev vars, + List.rev guards, + env, + decls, + List.rev names + +and encode_term_pred (fuel_opt:option term) (t:typ) (env:env_t) (e:term) : term & decls_t = + let t, decls = encode_term t env in + mk_HasTypeWithFuel fuel_opt e t, decls + +and encode_arith_term env head args_e = + let arg_tms, decls = encode_args args_e env in + let head_fv = + match head.n with + | Tm_fvar fv -> fv + | _ -> failwith "Impossible" + in + let unary unbox arg_tms = + unbox (List.hd arg_tms) + in + let binary unbox arg_tms = + unbox (List.hd arg_tms), + unbox (List.hd (List.tl arg_tms)) + in + let mk_default () = + let fname, fuel_args, arity = lookup_free_var_sym env head_fv.fv_name in + let args = fuel_args@arg_tms in + maybe_curry_app head.pos fname arity args + in + let mk_l : (term -> term) -> ('a -> term) -> (list term -> 'a) -> list term -> term = + fun box op mk_args ts -> + if Options.smtencoding_l_arith_native () then + op (mk_args ts) |> box + else mk_default () + in + let mk_nl box unbox nm op ts = + if Options.smtencoding_nl_arith_wrapped () then + let t1, t2 = binary unbox ts in + Util.mkApp(nm, [t1;t2]) |> box + else if Options.smtencoding_nl_arith_native () then + op (binary unbox ts) |> box + else mk_default () + in + let add box unbox = mk_l box Util.mkAdd (binary unbox) in + let sub box unbox = mk_l box Util.mkSub (binary unbox) in + let minus box unbox = mk_l box Util.mkMinus (unary unbox) in + let mul box unbox nm = mk_nl box unbox nm Util.mkMul in + let div box unbox nm = mk_nl box unbox nm Util.mkDiv in + let modulus box unbox = mk_nl box unbox "_mod" Util.mkMod in + let ops = + [(Const.op_Addition, add Term.boxInt Term.unboxInt); + (Const.op_Subtraction, sub Term.boxInt Term.unboxInt); + (Const.op_Multiply, mul Term.boxInt Term.unboxInt "_mul"); + (Const.op_Division, div Term.boxInt Term.unboxInt "_div"); + (Const.op_Modulus, modulus Term.boxInt Term.unboxInt); + (Const.op_Minus, minus Term.boxInt Term.unboxInt); + (Const.real_op_Addition, add Term.boxReal Term.unboxReal); + (Const.real_op_Subtraction, sub Term.boxReal Term.unboxReal); + (Const.real_op_Multiply, mul Term.boxReal Term.unboxReal "_rmul"); + (Const.real_op_Division, mk_nl Term.boxReal Term.unboxReal "_rdiv" Util.mkRealDiv); + (Const.real_op_LT, mk_l Term.boxBool Util.mkLT (binary Term.unboxReal)); + (Const.real_op_LTE, mk_l Term.boxBool Util.mkLTE (binary Term.unboxReal)); + (Const.real_op_GT, mk_l Term.boxBool Util.mkGT (binary Term.unboxReal)); + (Const.real_op_GTE, mk_l Term.boxBool Util.mkGTE (binary Term.unboxReal))] + in + let _, op = + List.tryFind (fun (l, _) -> S.fv_eq_lid head_fv l) ops |> + BU.must + in + op arg_tms, decls + + and encode_BitVector_term env head args_e = + (*first argument should be the implicit vector size + we do not want to encode this*) + let (tm_sz, _) : arg = List.hd args_e in + let sz = getInteger tm_sz.n in + let sz_key = FStarC.Compiler.Util.format1 "BitVector_%s" (string_of_int sz) in + let sz_decls = + let t_decls, constr_name, discriminator_name = mkBvConstructor sz in + //Typing inversion for bv_t n + let decls, typing_inversion = + (* forall (x:Term). HasType x (bv_t n) ==> is-BoxVec#n x *) + let bv_t_n, decls = + let head = S.lid_as_fv FStarC.Parser.Const.bv_t_lid None in + let t = U.mk_app (S.fv_to_tm head) [tm_sz, None] in + encode_term t env + in + let xsym = mk_fv (varops.fresh env.current_module_name "x", Term_sort) in + let x = mkFreeV xsym in + let x_has_type_bv_t_n = mk_HasType x bv_t_n in + let ax = mkForall head.pos ([[x_has_type_bv_t_n]], + [xsym], + mkImp(x_has_type_bv_t_n, mkApp (discriminator_name, [x]))) in + let name = "typing_inversion_for_" ^constr_name in + decls, mkAssume(ax, Some name, name) + in + decls@mk_decls "" sz_key (t_decls@[typing_inversion]) [] + in + (* we need to treat the size argument for zero_extend specially*) + let arg_tms, ext_sz = + match head.n, args_e with + | Tm_fvar fv, [_;(sz_arg, _);_] when + (S.fv_eq_lid fv Const.bv_uext_lid && + (isInteger sz_arg.n)) -> + (List.tail (List.tail args_e), Some (getInteger sz_arg.n)) + | Tm_fvar fv, [_;(sz_arg, _);_] when + (S.fv_eq_lid fv Const.bv_uext_lid) -> + (*fail if extension size is not a constant*) + failwith (FStarC.Compiler.Util.format1 "Not a constant bitvector extend size: %s" + (show sz_arg)) + | _ -> (List.tail args_e, None) + in + + let arg_tms, decls = encode_args arg_tms env in + let head_fv = + match head.n with + | Tm_fvar fv -> fv + | _ -> failwith "Impossible" + in + let unary arg_tms = + Term.unboxBitVec sz (List.hd arg_tms) + in + let unary_arith arg_tms = + Term.unboxInt (List.hd arg_tms) + in + let binary arg_tms = + Term.unboxBitVec sz (List.hd arg_tms), + Term.unboxBitVec sz (List.hd (List.tl arg_tms)) + in + let binary_arith arg_tms = + Term.unboxBitVec sz (List.hd arg_tms), + Term.unboxInt (List.hd (List.tl arg_tms)) + in + let mk_bv : ('a -> term) -> (list term -> 'a) -> (term -> term) -> list term -> term = + fun op mk_args resBox ts -> + op (mk_args ts) |> resBox + in + let bv_and = mk_bv Util.mkBvAnd binary (Term.boxBitVec sz) in + let bv_xor = mk_bv Util.mkBvXor binary (Term.boxBitVec sz) in + let bv_or = mk_bv Util.mkBvOr binary (Term.boxBitVec sz) in + let bv_add = mk_bv Util.mkBvAdd binary (Term.boxBitVec sz) in + let bv_sub = mk_bv Util.mkBvSub binary (Term.boxBitVec sz) in + let bv_shl = mk_bv (Util.mkBvShl sz) binary_arith (Term.boxBitVec sz) in + let bv_shr = mk_bv (Util.mkBvShr sz) binary_arith (Term.boxBitVec sz) in + let bv_udiv = mk_bv (Util.mkBvUdiv sz) binary_arith (Term.boxBitVec sz) in + let bv_mod = mk_bv (Util.mkBvMod sz) binary_arith (Term.boxBitVec sz) in + let bv_mul = mk_bv (Util.mkBvMul sz) binary_arith (Term.boxBitVec sz) in + + // Binary bv_t -> bv_t -> bv_t variants + let bv_shl' = mk_bv (Util.mkBvShl' sz) binary (Term.boxBitVec sz) in + let bv_shr' = mk_bv (Util.mkBvShr' sz) binary (Term.boxBitVec sz) in + let bv_udiv_unsafe = mk_bv (Util.mkBvUdivUnsafe sz) binary (Term.boxBitVec sz) in + let bv_mod_unsafe = mk_bv (Util.mkBvModUnsafe sz) binary (Term.boxBitVec sz) in + let bv_mul' = mk_bv (Util.mkBvMul' sz) binary (Term.boxBitVec sz) in + + let bv_ult = mk_bv Util.mkBvUlt binary Term.boxBool in + let bv_uext arg_tms = + mk_bv (Util.mkBvUext (match ext_sz with | Some x -> x | None -> failwith "impossible")) unary + (Term.boxBitVec (sz + (match ext_sz with | Some x -> x | None -> failwith "impossible"))) arg_tms in + let to_int = mk_bv Util.mkBvToNat unary Term.boxInt in + let bv_to = mk_bv (Util.mkNatToBv sz) unary_arith (Term.boxBitVec sz) in + let ops = + [(Const.bv_and_lid, bv_and); + (Const.bv_xor_lid, bv_xor); + (Const.bv_or_lid, bv_or); + (Const.bv_add_lid, bv_add); + (Const.bv_sub_lid, bv_sub); + (Const.bv_shift_left_lid, bv_shl); + (Const.bv_shift_right_lid, bv_shr); + (Const.bv_udiv_lid, bv_udiv); + (Const.bv_mod_lid, bv_mod); + (Const.bv_mul_lid, bv_mul); + (Const.bv_shift_left'_lid, bv_shl'); + (Const.bv_shift_right'_lid, bv_shr'); + (Const.bv_udiv_unsafe_lid, bv_udiv_unsafe); + (Const.bv_mod_unsafe_lid, bv_mod_unsafe); + (Const.bv_mul'_lid, bv_mul'); + (Const.bv_ult_lid, bv_ult); + (Const.bv_uext_lid, bv_uext); + (Const.bv_to_nat_lid, to_int); + (Const.nat_to_bv_lid, bv_to)] + in + let _, op = + List.tryFind (fun (l, _) -> S.fv_eq_lid head_fv l) ops |> + BU.must + in + op arg_tms, sz_decls @ decls + +and encode_deeply_embedded_quantifier (t:S.term) (env:env_t) : term & decls_t = + let env = {env with encoding_quantifier=true} in + let tm, decls = encode_term t env in + let vars = Term.free_variables tm in + let valid_tm = mk_Valid tm in + let key = mkForall t.pos ([], vars, valid_tm) in + let tkey_hash = hash_of_term key in + match tm.tm with + | App(_, [{tm=FreeV _}; {tm=FreeV _}]) -> + FStarC.Errors.log_issue t Errors.Warning_QuantifierWithoutPattern + "Not encoding deeply embedded, unguarded quantifier to SMT"; + tm, decls + + | _ -> + let phi, decls' = encode_formula t env in + let interp = + match vars with + | [] -> mkIff(mk_Valid tm, phi) + | _ -> mkForall t.pos ([[valid_tm]], vars, mkIff(mk_Valid tm, phi)) + in + let ax = mkAssume(interp, + Some "Interpretation of deeply embedded quantifier", + "l_quant_interp_" ^ (BU.digest_of_string tkey_hash)) in + tm, decls@decls'@(mk_decls "" tkey_hash [ax] (decls@decls')) + +(* + * AR: no hashconsing in this function now + * it returns a list of decls blocks that may be duplicate + * for example, for two occurrences of x:int{x > 2} + * deduplication of these happens in Encode.fs + * just before giving the decls to Z3 (see Encode.fs.recover_caching_and_update_env) + *) +and encode_term (t:typ) (env:env_t) : (term (* encoding of t, expects t to be in normal form already *) + & decls_t) (* top-level declarations to be emitted (for shared representations of existentially bound terms *) = + + def_check_scoped t.pos "encode_term" env.tcenv t; + let t = SS.compress t in + let t0 = t in + if !dbg_SMTEncoding + then BU.print2 "(%s) %s\n" (tag_of t) (show t); + match t.n with + | Tm_delayed _ + | Tm_unknown -> + failwith (BU.format3 "(%s) Impossible: %s\n%s\n" + (Range.string_of_range <| t.pos) + (tag_of t) + (show t)) + + | Tm_lazy i -> + let e = U.unfold_lazy i in + if !dbg_SMTEncoding then + BU.print2 ">> Unfolded (%s) ~> (%s)\n" (show t) + (show e); + encode_term e env + + | Tm_bvar x -> + failwith (BU.format1 "Impossible: locally nameless; got %s" (show x)) + + | Tm_ascribed {tm=t; asc=(k,_,_)} -> + if (match k with Inl t -> U.is_unit t | _ -> false) + then Term.mk_Term_unit, [] + else encode_term t env + + | Tm_quoted (qt, _) -> + // Inspect the term and encode its view, recursively. + // Quoted terms are, in a way, simply an optimization. + // They should be equivalent to a fully spelled out view. + // + // Actual encoding: `q ~> pack qv where qv is the view of q + let tv = EMB.embed (R.inspect_ln qt) t.pos None EMB.id_norm_cb in + if !dbg_SMTEncoding then + BU.print2 ">> Inspected (%s) ~> (%s)\n" (show t0) + (show tv); + let t = U.mk_app (RC.refl_constant_term RC.fstar_refl_pack_ln) [S.as_arg tv] in + encode_term t env + + | Tm_meta {tm=t; meta=Meta_pattern _} -> + encode_term t ({env with encoding_quantifier=false}) + + | Tm_meta {tm=t} -> + encode_term t env + + | Tm_name x -> + let t = lookup_term_var env x in + t, [] + + | Tm_fvar v -> + let encode_freev () = + let fvb = lookup_free_var_name env v.fv_name in + let tok = lookup_free_var env v.fv_name in + let tkey_hash = Term.hash_of_term tok in + let aux_decls, sym_name = + if fvb.smt_arity > 0 + then //kick partial application axioms if arity > 0; see #613 + //and if the head symbol is just a variable + //rather than maybe a fuel-instrumented name (cf. #1433) + match tok.tm with + | FreeV _ + | App(_, []) -> + let sym_name = "@kick_partial_app_" ^ (BU.digest_of_string tkey_hash) in //the '@' retains this for hints + [Util.mkAssume(kick_partial_app tok, + Some "kick_partial_app", + sym_name)], sym_name + | _ -> [], "" + else [], "" in + tok, (if aux_decls = [] + then ([] |> mk_decls_trivial) + else mk_decls sym_name tkey_hash aux_decls []) + in + if head_redex env t + then match maybe_whnf env t with + | None -> encode_freev() + | Some t -> encode_term t env + else encode_freev () + + | Tm_type _ -> + mk_Term_type, [] + + | Tm_uinst(t, _) -> + encode_term t env + + | Tm_constant c -> + encode_const c env + + | Tm_arrow {bs=binders; comp=c} -> + let module_name = env.current_module_name in + let binders, res = SS.open_comp binders c in + if (env.encode_non_total_function_typ + && U.is_pure_or_ghost_comp res) + || U.is_tot_or_gtot_comp res + then let vars, guards_l, env', decls, _ = encode_binders None binders env in + let fsym = mk_fv (varops.fresh module_name "f", Term_sort) in + let f = mkFreeV fsym in + let app = mk_Apply f vars in + let tcenv_bs = { env'.tcenv with admit=true } in + let pre_opt, res_t = TcUtil.pure_or_ghost_pre_and_post tcenv_bs res in + let res_pred, decls' = encode_term_pred None res_t env' app in + let guards, guard_decls = match pre_opt with + | None -> mk_and_l guards_l, [] + | Some pre -> + let guard, decls0 = encode_formula pre env' in + mk_and_l (guard::guards_l), decls0 in + //AR: promote ghost to pure for non-informative types + let is_pure = res |> N.maybe_ghost_to_pure env.tcenv |> U.is_pure_comp in + //cf. Bug #1750 + //We need to distinguish pure and ghost functions in the encoding + //both in hash consing, producing different type constructors for them. + //Tot functions get an additional predicate IsTotFun in their interpretation + let t_interp = + mkForall t.pos + ([[app]], + vars, + mkImp(guards, res_pred)) + in + + (* + * AR/NS: For an arrow like int -> int -> int -> GTot int, t_interp is of the form: + * forall x0. + * HasType x0 (int -> int -> int -> GTot int) + * <==> + * (forall (x1:int) (x2:int) (x3:int). + * HasType (ApplyTT (ApplyTT (ApplyTT (x0 x1)) x2) x3) int) + * /\ IsTotFun x0 + * /\ (forall x1. IsTotFun (ApplyTT x0 x1) + * + * I.e, we add IsTotFun axioms for every total partial application. + * Importantly, in the example above, the axiom is omitted for + * (x0 x1 x2 : int -> GTot int), since this function is not total + *) + + + //finally add the IsTotFun for the function term itself + let t_interp = + let tot_fun_axioms = isTotFun_axioms t.pos f vars guards_l is_pure in + mkAnd (t_interp, tot_fun_axioms) + in + let cvars = + Term.free_variables t_interp + |> List.filter (fun x -> fv_name x <> fv_name fsym) + in + let tkey = + mkForall t.pos ([], fsym::cvars, t_interp) + in + let prefix = + if is_pure + then "Tm_arrow_" + else "Tm_ghost_arrow_" + in + let tkey_hash = + prefix ^ hash_of_term tkey in + let tsym = + prefix ^ BU.digest_of_string tkey_hash + in + let cvar_sorts = List.map fv_sort cvars in + let caption = + if Options.log_queries() + then Some (BU.replace_char (N.term_to_string env.tcenv t0) '\n' ' ') + else None in + + let tdecl = Term.DeclFun(tsym, cvar_sorts, Term_sort, caption) in + + let t = mkApp(tsym, List.map mkFreeV cvars) in //arity ok + let t_has_kind = mk_HasType t mk_Term_type in + + let k_assumption = + let a_name = "kinding_"^tsym in + Util.mkAssume (mkForall t0.pos ([[t_has_kind]], cvars, t_has_kind), Some a_name, a_name) in + + let f_has_t = mk_HasType f t in + let f_has_t_z = mk_HasTypeZ f t in + let pre_typing = + let a_name = "pre_typing_"^tsym in + Util.mkAssume(mkForall_fuel module_name t0.pos ([[f_has_t]], fsym::cvars, + mkImp(f_has_t, mk_tester "Tm_arrow" (mk_PreType f))), + Some "pre-typing for functions", + module_name ^ "_" ^ a_name) in + let t_interp = + let a_name = "interpretation_"^tsym in + Util.mkAssume(mkForall t0.pos ([[f_has_t_z]], + fsym::cvars, + mkIff (f_has_t_z, t_interp)), + Some a_name, + module_name ^ "_" ^ a_name) + in + let t_decls = [tdecl; k_assumption; pre_typing; t_interp] in + t, decls@decls'@guard_decls@(mk_decls tsym tkey_hash t_decls (decls@decls'@guard_decls)) + + else + (* + * AR: compute a hash for the Non total arrow, + * that we will use in the name of the arrow + * so that we can get some hashconsing + *) + let tkey_hash = + (* + * AR: any decls computed here are ignored + * we encode terms in this let-scope just to compute a hash + *) + let vars, guards_l, env_bs, _, _ = encode_binders None binders env in + let c = Env.unfold_effect_abbrev (Env.push_binders env.tcenv binders) res |> S.mk_Comp in + let ct, _ = encode_term (c |> U.comp_result) env_bs in + let effect_args, _ = encode_args (c |> U.comp_effect_args) env_bs in + let tkey = mkForall t.pos + ([], vars, mk_and_l (guards_l@[ct]@effect_args)) in + let tkey_hash = "Non_total_Tm_arrow" ^ (hash_of_term tkey) ^ "@Effect=" ^ + (c |> U.comp_effect_name |> string_of_lid) in + BU.digest_of_string tkey_hash + in + + let tsym = "Non_total_Tm_arrow_" ^ tkey_hash in + (* We need to compute all free variables of this arrow + expression and parametrize the encoding wrt to them. See + issue #3028 *) + let env0 = env in + let fstar_fvs, (env, fv_decls, fv_vars, fv_tms, fv_guards) = + let fvs = Free.names t0 |> elems in + + let getfreeV (t:term) : fv = + match t.tm with + | FreeV fv -> fv + | _ -> failwith "Impossible: getfreeV: gen_term_var should always returns a FreeV" + in + + fvs, + List.fold_left (fun (env, decls, vars, tms, guards) bv -> + (* Get the sort from the environment, do not trust .sort field *) + let (sort, _) = Env.lookup_bv env.tcenv bv in + (* Generate a fresh SMT variable for this bv *) + let sym, smt_tm, env = gen_term_var env bv in + let fv = getfreeV smt_tm in + (* Generate typing predicate for it at the sort type *) + let guard, decls' = encode_term_pred None (norm env sort) env smt_tm in + (env, decls'@decls, fv::vars, smt_tm::tms, guard::guards) + ) (env, [], [], [], []) fvs + in + (* Putting in "correct" order... but does it matter? *) + let fv_decls = List.rev fv_decls in + let fv_vars = List.rev fv_vars in + let fv_tms = List.rev fv_tms in + let fv_guards = List.rev fv_guards in + + let arg_sorts = List.map (fun _ -> Term_sort) fv_tms in + let tdecl = Term.DeclFun(tsym, arg_sorts, Term_sort, None) in + let tapp = mkApp(tsym, fv_tms) in + let t_kinding = + let a_name = "non_total_function_typing_" ^tsym in + let axiom = + (* We generate: + forall v1 .. vn, (v1 hasType t1 /\ ... vn hasType tn) ==> tapp hasType Type *) + (* NB: we use the conlusion (HasType tapp Type) as the pattern. Though Z3 + will probably pick the same one if left empty. *) + mkForall t0.pos ([[mk_HasType tapp mk_Term_type]], fv_vars, + mkImp (mk_and_l fv_guards, mk_HasType tapp mk_Term_type)) + in + (* We furthermore must close over any variable that is + still free in the axiom. This can happen since the types + of the fvs we are closing over above may not be closed + in the current env. *) + let svars = Term.free_variables axiom in + let axiom = mkForall t0.pos ([], svars, axiom) in + Util.mkAssume (axiom, Some "Typing for non-total arrows", a_name) + in + + (* The axiom above is generated over a universal quantification of + the free variables, but the actual encoding of this instance of the + arrow is applied to (the encoding of) the actual free variables at + this point. *) + + let tapp_concrete = mkApp(tsym, List.map (lookup_term_var env0) fstar_fvs) in + tapp_concrete, fv_decls @ mk_decls tsym tkey_hash [tdecl ; t_kinding ] [] + + | Tm_refine _ -> + let x, f = + let steps = [ + Env.Weak; + Env.HNF; + Env.EraseUniverses + ] in + match normalize_refinement steps env.tcenv t0 with + | {n=Tm_refine {b=x; phi=f}} -> + let b, f = SS.open_term [S.mk_binder x] f in + (List.hd b).binder_bv, f + | _ -> failwith "impossible" + in + + let base_t, decls = encode_term x.sort env in + let x, xtm, env' = gen_term_var env x in + let refinement, decls' = encode_formula f env' in + + let fsym, fterm = fresh_fvar env.current_module_name "f" Fuel_sort in + + let tm_has_type_with_fuel = mk_HasTypeWithFuel (Some fterm) xtm base_t in + + (* `encoding` includes `x.sort` via `tm_has_type_with_fuel` *) + let encoding = mkAnd(tm_has_type_with_fuel, refinement) in + + //earlier we used to get cvars from encoding + //but mkAnd is optimized and when refinement is False, it returns False + //in that case, cvars was turning out to be empty, resulting in non well-formed encoding (e.g. of hasEq, since free variables of base_t are not captured in cvars) + //to get around that, computing cvars separately from the components of the encoding variable + let cvars = BU.remove_dups fv_eq (Term.free_variables refinement @ Term.free_variables tm_has_type_with_fuel) in + let cvars = cvars |> List.filter (fun y -> fv_name y <> x && fv_name y <> fsym) in + + let xfv = mk_fv (x, Term_sort) in + let ffv = mk_fv (fsym, Fuel_sort) in + let tkey = mkForall t0.pos ([], ffv::xfv::cvars, encoding) in + let tkey_hash = Term.hash_of_term tkey in + + if !dbg_SMTEncoding + then BU.print3 "Encoding Tm_refine %s with tkey_hash %s and digest %s\n" + (show f) tkey_hash (BU.digest_of_string tkey_hash) + else (); + + let tsym = "Tm_refine_" ^ (BU.digest_of_string tkey_hash) in + let cvar_sorts = List.map fv_sort cvars in + let tdecl = Term.DeclFun(tsym, cvar_sorts, Term_sort, None) in + let t = mkApp(tsym, List.map mkFreeV cvars) in + + let x_has_base_t = mk_HasType xtm base_t in + let x_has_t = mk_HasTypeWithFuel (Some fterm) xtm t in + let t_has_kind = mk_HasType t mk_Term_type in + + //add hasEq axiom for this refinement type + let t_haseq_base = mk_haseq base_t in + let t_haseq_ref = mk_haseq t in + + let t_haseq = + Util.mkAssume(mkForall t0.pos ([[t_haseq_ref]], cvars, (mkIff (t_haseq_ref, t_haseq_base))), + Some ("haseq for " ^ tsym), + "haseq" ^ tsym) in + // let t_valid = + // let xx = (x, Term_sort) in + // let valid_t = mkApp ("Valid", [t]) in + // Util.mkAssume(mkForall ([[valid_t]], cvars, + // mkIff (mkExists ([], [xx], mkAnd (x_has_base_t, refinement)), valid_t)), + // Some ("validity axiom for refinement"), + // "ref_valid_" ^ tsym) + // in + + let t_kinding = + //TODO: guard by typing of cvars?; not necessary since we have pattern-guarded + Util.mkAssume(mkForall t0.pos ([[t_has_kind]], cvars, t_has_kind), + Some "refinement kinding", + "refinement_kinding_" ^tsym) + in + let t_interp = + Util.mkAssume(mkForall t0.pos ([[x_has_t]], ffv::xfv::cvars, mkIff(x_has_t, encoding)), + Some "refinement_interpretation", + "refinement_interpretation_"^tsym) in + + let t_decls = [tdecl; + t_kinding; //t_valid; + t_interp; t_haseq] in + t, decls@decls'@mk_decls tsym tkey_hash t_decls (decls@decls') + + | Tm_uvar (uv, _) -> + let ttm = mk_Term_uvar (Unionfind.uvar_id uv.ctx_uvar_head) in + let t_has_k, decls = encode_term_pred None (U.ctx_uvar_typ uv) env ttm in //TODO: skip encoding this if it has already been encoded before + let d = + Util.mkAssume(t_has_k, + Some "Uvar typing", + varops.mk_unique + (BU.format1 "uvar_typing_%s" + (BU.string_of_int + (Unionfind.uvar_id uv.ctx_uvar_head)))) + in + ttm, decls@([d] |> mk_decls_trivial) + + | Tm_app _ -> + let head, args_e = U.head_and_args t0 in + let head, args_e = + if head_redex env head + then match maybe_whnf env t0 with + | None -> head, args_e + | Some t -> U.head_and_args t + else head, args_e + in + begin + match (SS.compress head).n, args_e with + | _ when is_arithmetic_primitive head args_e -> + encode_arith_term env head args_e + + | _ when is_BitVector_primitive head args_e -> + encode_BitVector_term env head args_e + + | Tm_fvar fv, [(arg, _)] + | Tm_uinst({n=Tm_fvar fv}, _), [(arg, _)] + when + (S.fv_eq_lid fv Const.squash_lid + || S.fv_eq_lid fv Const.auto_squash_lid) + && Option.isSome (Syntax.Formula.destruct_typ_as_formula arg) -> + let dummy = S.new_bv None t_unit in + let t = U.refine dummy arg in (* so that `squash f`, when f is a formula, benefits from shallow embedding *) + encode_term t env + + | Tm_fvar fv, _ + | Tm_uinst({n=Tm_fvar fv}, _), _ + when (not env.encoding_quantifier) + && (S.fv_eq_lid fv Const.forall_lid + || S.fv_eq_lid fv Const.exists_lid) -> + encode_deeply_embedded_quantifier t0 env + + | Tm_constant Const_range_of, [(arg, _)] -> + encode_const (Const_range arg.pos) env + + | Tm_constant Const_set_range_of, [(arg, _); (rng, _)] -> + encode_term arg env + + | Tm_constant (Const_reify lopt), _ -> + let fallback () = + let f = varops.fresh env.current_module_name "Tm_reify" in + let decl = + Term.DeclFun (f, [], Term_sort, Some "Imprecise reify") in + mkFreeV <| mk_fv (f, Term_sort), [decl] |> mk_decls_trivial in + + (match lopt with + | None -> fallback () + | Some l + when l |> Env.norm_eff_name env.tcenv + |> Env.is_layered_effect env.tcenv -> fallback () + | _ -> + let e0 = TcUtil.norm_reify env.tcenv [] + (U.mk_reify (args_e |> List.hd |> fst) lopt) in + if !dbg_SMTEncodingReify + then BU.print1 "Result of normalization %s\n" (show e0); + let e = S.mk_Tm_app (TcUtil.remove_reify e0) (List.tl args_e) t0.pos in + encode_term e env) + + | Tm_constant (Const_reflect _), [(arg, _)] -> + encode_term arg env + + | Tm_fvar fv, [_; (phi, _)] + | Tm_uinst ({n=Tm_fvar fv}, _), [_; (phi, _)] + when S.fv_eq_lid fv Const.by_tactic_lid -> + encode_term phi env + + | Tm_fvar fv, [_; _; (phi, _)] + | Tm_uinst ({n=Tm_fvar fv}, _), [_; _; (phi, _)] + when S.fv_eq_lid fv Const.rewrite_by_tactic_lid -> + encode_term phi env + + | _ -> + let args, decls = encode_args args_e env in + + let encode_partial_app (ht_opt:option (S.typ & S.binders & S.comp)) = + let smt_head, decls' = encode_term head env in + let app_tm = mk_Apply_args smt_head args in + match ht_opt with + | _ when 1=1 -> app_tm, decls@decls' //NS: Intentionally using a default case here to disable the axiom below + | Some (head_type, formals, c) -> + if !dbg_PartialApp + then BU.print5 "Encoding partial application:\n\thead=%s\n\thead_type=%s\n\tformals=%s\n\tcomp=%s\n\tactual args=%s\n" + (show head) + (show head_type) + (show formals) + (show c) + (show args_e); + let formals, rest = BU.first_N (List.length args_e) formals in + let subst = List.map2 (fun ({binder_bv=bv}) (a, _) -> Syntax.NT(bv, a)) formals args_e in + let ty = U.arrow rest c |> SS.subst subst in + if !dbg_PartialApp + then BU.print1 "Encoding partial application, after subst:\n\tty=%s\n" + (show ty); + let vars, pattern, has_type, decls'' = + let t_hyps, decls = + List.fold_left2 (fun (t_hyps, decls) ({binder_bv=bv}) e -> + let t = SS.subst subst bv.sort in + let t_hyp, decls' = encode_term_pred None t env e in + if !dbg_PartialApp + then BU.print2 "Encoded typing hypothesis for %s ... got %s\n" + (show t) + (Term.print_smt_term t_hyp); + t_hyp::t_hyps, decls@decls') + ([], []) + formals + args + in + let t_head_hyp, decls' = + match smt_head.tm with + | FreeV _ -> + encode_term_pred None head_type env smt_head + | _ -> + mkTrue, [] + in + let hyp = Term.mk_and_l (t_head_hyp::t_hyps) Range.dummyRange in + let has_type_conclusion, decls'' = + encode_term_pred None ty env app_tm + in + let has_type = mkImp (hyp, has_type_conclusion) in + let cvars = Term.free_variables has_type in + let app_tm_vars = Term.free_variables app_tm in + let pattern, vars = + if Term.fvs_subset_of cvars app_tm_vars + then [app_tm], app_tm_vars + else if Term.fvs_subset_of cvars (Term.free_variables has_type_conclusion) + then [has_type_conclusion], cvars + else begin + Errors.log_issue t0 Errors.Warning_SMTPatternIllFormed + (BU.format1 "No SMT pattern for partial application %s" (show t0)); + [], cvars //no pattern! + end + in + vars, + pattern, + has_type, + decls@decls'@decls'' + in + if !dbg_PartialApp + then BU.print1 "Encoding partial application, after SMT encoded predicate:\n\t=%s\n" + (Term.print_smt_term has_type); + let tkey_hash = Term.hash_of_term app_tm in + let e_typing = Util.mkAssume(mkForall t0.pos ([pattern], vars, has_type), + Some "Partial app typing", + ("partial_app_typing_" ^ + (BU.digest_of_string (Term.hash_of_term app_tm)))) in + app_tm, decls@decls'@decls''@(mk_decls "" tkey_hash [e_typing] (decls@decls'@decls'')) + | None -> failwith "impossible" + in + + let encode_full_app fv = + let fname, fuel_args, arity = lookup_free_var_sym env fv in + let tm = maybe_curry_app t0.pos fname arity (fuel_args@args) in + tm, decls + in + + let head = SS.compress head in + + let head_type = + match head.n with + | Tm_uinst({n=Tm_name x}, _) + | Tm_name x -> Some x.sort + | Tm_uinst({n=Tm_fvar fv}, _) + | Tm_fvar fv -> Some (Env.lookup_lid env.tcenv fv.fv_name.v |> fst |> snd) + | Tm_ascribed {asc=(Inl t, _, _)} -> Some t + | Tm_ascribed {asc=(Inr c, _, _)} -> Some (U.comp_result c) + | _ -> None + in + + match head_type with + | None -> encode_partial_app None + | Some head_type -> + let head_type, formals, c = + let head_type = U.unrefine <| normalize_refinement [Env.Weak; Env.HNF; Env.EraseUniverses] env.tcenv head_type in + let formals, c = curried_arrow_formals_comp head_type in + if List.length formals < List.length args + then let head_type = + U.unrefine + <| normalize_refinement + [Env.Weak; Env.HNF; Env.EraseUniverses; Env.UnfoldUntil delta_constant] + env.tcenv + head_type + in + let formals, c = curried_arrow_formals_comp head_type in + head_type, formals, c + else head_type, formals, c + in + if !dbg_PartialApp + then BU.print3 "Encoding partial application, head_type = %s, formals = %s, args = %s\n" + (show head_type) + (show formals) + (show args_e); + + begin + match head.n with + | Tm_uinst({n=Tm_fvar fv}, _) + | Tm_fvar fv when (List.length formals = List.length args) -> encode_full_app fv.fv_name + | _ -> + if List.length formals > List.length args + then encode_partial_app (Some (head_type, formals, c)) + else encode_partial_app None + end + + end + + | Tm_abs {bs; body; rc_opt=lopt} -> + let bs, body, opening = SS.open_term' bs body in + let fallback () = + let arg_sorts, arg_terms = + (* We need to compute all free variables of this lambda + expression and parametrize the encoding wrt to them. See + issue #3028 *) + let fvs = Free.names t0 |> elems in + let tms = List.map (lookup_term_var env) fvs in + (List.map (fun _ -> Term_sort) fvs <: list sort), + tms + in + let f = varops.fresh env.current_module_name "Tm_abs" in + let decl = Term.DeclFun(f, arg_sorts, Term_sort, Some "Imprecise function encoding") in + let fv : term = mkFreeV <| mk_fv (f, Term_sort) in + let fapp = mkApp (f, arg_terms) in + fapp, [decl] |> mk_decls_trivial + in + + let is_impure (rc:S.residual_comp) = + TypeChecker.Util.is_pure_or_ghost_effect env.tcenv rc.residual_effect |> not + in + +// let reify_comp_and_body env body = +// let reified_body = TcUtil.reify_body env.tcenv body in +// let c = match c with +// | Inl lc -> +// let typ = reify_comp ({env.tcenv with admit=true}) (lc.comp ()) U_unknown in +// Inl (U.lcomp_of_comp (S.mk_Total typ)) +// +// (* In this case we don't have enough information to reconstruct the *) +// (* whole computation type and reify it *) +// | Inr (eff_name, _) -> c +// in +// c, reified_body +// in + + let codomain_eff rc = + let res_typ = + match rc.residual_typ with + | None -> + let t, _, _ = + FStarC.TypeChecker.Util.new_implicit_var + "SMTEncoding codomain" + (Env.get_range env.tcenv) + env.tcenv + U.ktype0 + false + in + t + | Some t -> t + in + if Ident.lid_equals rc.residual_effect Const.effect_Tot_lid + then Some (S.mk_Total res_typ) + else if Ident.lid_equals rc.residual_effect Const.effect_GTot_lid + then Some (S.mk_GTotal res_typ) + (* TODO (KM) : shouldn't we do something when flags contains TOTAL ? *) + else None + in + + begin match lopt with + | None -> + let open FStarC.Class.PP in + let open FStarC.Pprint in + let open FStarC.Errors.Msg in + //we don't even know if this is a pure function, so give up + Errors.log_issue t0 Errors.Warning_FunctionLiteralPrecisionLoss [ + prefix 2 1 (text "Losing precision when encoding a function literal:") + (pp t0); + text "Unannotated abstraction in the compiler?" + ]; + fallback () + + | Some rc -> + if is_impure rc && not (is_smt_reifiable_rc env.tcenv rc) + then fallback() //we know it's not pure; so don't encode it precisely + else + let vars, guards, envbody, decls, _ = encode_binders None bs env in + let body = if is_smt_reifiable_rc env.tcenv rc + then TcUtil.norm_reify env.tcenv [] + (U.mk_reify body (Some rc.residual_effect)) + else body + in + let body, decls' = encode_term body envbody in + let is_pure = U.is_pure_effect rc.residual_effect in + let arrow_t_opt, decls'' = + match codomain_eff rc with + | None -> None, [] + | Some c -> + let tfun = U.arrow bs c in + let t, decls = encode_term tfun env in + Some t, decls + in + let key_body = mkForall t0.pos ([], vars, mkImp(mk_and_l guards, body)) in + let cvars = Term.free_variables key_body in + //adding free variables of the return type also to cvars + let cvars, key_body = + match arrow_t_opt with + | None -> cvars, key_body + | Some t -> + BU.remove_dups fv_eq (Term.free_variables t @ cvars), + mkAnd (key_body, t) (* we make the encoding depend on the type of the abstraction, see #1595 *) + in + let tkey = mkForall t0.pos ([], cvars, key_body) in + let tkey_hash = Term.hash_of_term tkey in + if !dbg_PartialApp + then BU.print2 "Checking eta expansion of\n\tvars={%s}\n\tbody=%s\n" + (List.map fv_name vars |> String.concat ", ") + (print_smt_term body); + let cvar_sorts = List.map fv_sort cvars in + let fsym = "Tm_abs_" ^ (BU.digest_of_string tkey_hash) in + let fdecl = Term.DeclFun(fsym, cvar_sorts, Term_sort, None) in + let f = mkApp(fsym, List.map mkFreeV cvars) in //arity ok, since introduced at cvar_sorts (#1383) + let app = mk_Apply f vars in + let typing_f = + match arrow_t_opt with + | None -> + let tot_fun_ax = + let ax = (isTotFun_axioms t0.pos f vars (vars |> List.map (fun _ -> mkTrue)) is_pure) in + match cvars with + | [] -> ax + | _ -> mkForall t0.pos ([[f]], cvars, ax) + in + let a_name = "tot_fun_"^fsym in + [Util.mkAssume(tot_fun_ax, Some a_name, a_name)] + //no typing axiom for this lambda, because we don't have enough info + //but we at least mark its partial applications as total (cf. #1750) + | Some t -> + let f_has_t = mk_HasTypeWithFuel None f t in + let a_name = "typing_"^fsym in + [Util.mkAssume(mkForall t0.pos ([[f]], cvars, f_has_t), Some a_name, a_name)] + in + let interp_f = + let a_name = "interpretation_" ^fsym in + Util.mkAssume(mkForall t0.pos ([[app]], vars@cvars, mkEq(app, body)), Some a_name, a_name) + in + let f_decls = (fdecl::typing_f)@[interp_f] in + f, decls@decls'@decls''@(mk_decls fsym tkey_hash f_decls (decls@decls'@decls'')) + end + + | Tm_let {lbs=(_, {lbname=Inr _}::_)} -> + failwith "Impossible: already handled by encoding of Sig_let" + + | Tm_let {lbs=(false, [{lbname=Inl x; lbtyp=t1; lbdef=e1}]); body=e2} -> + encode_let x t1 e1 e2 env encode_term + + | Tm_let {lbs=(false, _::_)} -> + failwith "Impossible: non-recursive let with multiple bindings" + + | Tm_let {lbs=(_, lbs)} -> + let names = lbs |> List.map (fun lb -> + let {lbname = lbname} = lb in + let x = BU.left lbname in (* has to be Inl *) + (Ident.string_of_id x.ppname, S.range_of_bv x)) in + raise (Inner_let_rec names) + + | Tm_match {scrutinee=e; brs=pats} -> + encode_match e pats mk_Term_unit env encode_term + +and encode_let + : bv -> typ -> S.term -> S.term -> env_t -> (S.term -> env_t -> term & decls_t) + -> term & decls_t + = + fun x t1 e1 e2 env encode_body -> + //setting the use_eq ascription flag to false, + // doesn't matter since the flag is irrelevant outside the typechecker + let ee1, decls1 = encode_term (U.ascribe e1 (Inl t1, None, false)) env in + let xs, e2 = SS.open_term [S.mk_binder x] e2 in + let x = (List.hd xs).binder_bv in + let env' = push_term_var env x ee1 in + let ee2, decls2 = encode_body e2 env' in + ee2, decls1@decls2 + +and encode_match (e:S.term) (pats:list S.branch) (default_case:term) (env:env_t) + (encode_br:S.term -> env_t -> (term & decls_t)) : term & decls_t = + let scrsym, scr', env = gen_term_var env (S.null_bv (S.mk S.Tm_unknown Range.dummyRange)) in + let scr, decls = encode_term e env in + let match_tm, decls = + let encode_branch b (else_case, decls) = + let p, w, br = SS.open_branch b in + let env0, pattern = encode_pat env p in + let guard = pattern.guard scr' in + let projections = pattern.projections scr' in + let env = projections |> List.fold_left (fun env (x, t) -> push_term_var env x t) env in + let guard, decls2 = + match w with + | None -> guard, [] + | Some w -> + let w, decls2 = encode_term w env in + mkAnd(guard, mkEq(w, Term.boxBool mkTrue)), decls2 + in + let br, decls3 = encode_br br env in + mkITE(guard, br, else_case), decls@decls2@decls3 + in + List.fold_right encode_branch pats (default_case (* default; should be unreachable *), decls) + in + mkLet' ([mk_fv (scrsym,Term_sort), scr], match_tm) Range.dummyRange, decls + +and encode_pat (env:env_t) (pat:S.pat) : (env_t & pattern) = + if Debug.medium () then BU.print1 "Encoding pattern %s\n" (show pat); + let vars, pat_term = FStarC.TypeChecker.Util.decorated_pattern_as_term pat in + + let env, vars = vars |> List.fold_left (fun (env, vars) v -> + let xx, _, env = gen_term_var env v in + env, (v, mk_fv (xx, Term_sort))::vars) (env, []) in + + let rec mk_guard pat (scrutinee:term) : term = + match pat.v with + | Pat_var _ + | Pat_dot_term _ -> mkTrue + | Pat_constant c -> + let tm, decls = encode_const c env in + let _ = match decls with _::_ -> failwith "Unexpected encoding of constant pattern" | _ -> () in + mkEq(scrutinee, tm) + | Pat_cons(f, _, args) -> + let is_f = + let tc_name = Env.typ_of_datacon env.tcenv f.fv_name.v in + match Env.datacons_of_typ env.tcenv tc_name with + | _, [_] -> mkTrue //single constructor type; no need for a test + | _ -> mk_data_tester env f.fv_name.v scrutinee + in + let sub_term_guards = args |> List.mapi (fun i (arg, _) -> + let proj = primitive_projector_by_pos env.tcenv f.fv_name.v i in + mk_guard arg (mkApp(proj, [scrutinee]))) in //arity ok, primitive projector (#1383) + mk_and_l (is_f::sub_term_guards) + in + + let rec mk_projections pat (scrutinee:term) = + match pat.v with + | Pat_dot_term _ -> [] + | Pat_var x -> [x, scrutinee] + + | Pat_constant _ -> [] + + | Pat_cons(f, _, args) -> + args + |> List.mapi (fun i (arg, _) -> + let proj = primitive_projector_by_pos env.tcenv f.fv_name.v i in + mk_projections arg (mkApp(proj, [scrutinee]))) //arity ok, primitive projector (#1383) + |> List.flatten + in + + let pat_term () = encode_term pat_term env in + + let pattern = { + pat_vars=vars; + pat_term=pat_term; + guard=mk_guard pat; + projections=mk_projections pat; + } in + + env, pattern + +and encode_args (l:args) (env:env_t) : (list term & decls_t) = + let l, decls = l |> List.fold_left + (fun (tms, decls) (t, _) -> let t, decls' = encode_term t env in t::tms, decls@decls') + ([], []) in + List.rev l, decls + +and encode_smt_patterns (pats_l:list (list S.arg)) env : list (list term) & decls_t = + let env = {env with use_zfuel_name=true} in + let encode_smt_pattern t = + let head, args = U.head_and_args t in + let head = U.un_uinst head in + match head.n, args with + | Tm_fvar fv, [_; (x, _); (t, _)] + when S.fv_eq_lid fv Const.has_type_lid -> //interpret Prims.has_type as HasType + let x, decls = encode_term x env in + let t, decls' = encode_term t env in + mk_HasType x t, decls@decls' + + | _ -> + encode_term t env + in + List.fold_right (fun pats (pats_l, decls) -> + let pats, decls = + List.fold_right + (fun (p, _) (pats, decls) -> + let t, d = encode_smt_pattern p in + match check_pattern_ok t with + | None -> + t::pats, d@decls + | Some illegal_subterm -> + Errors.log_issue p Errors.Warning_SMTPatternIllFormed + (BU.format2 "Pattern %s contains illegal sub-term (%s); dropping it" + (show p) + (show illegal_subterm)); + pats, d@decls) + pats ([], decls) + in + pats::pats_l, decls) + pats_l ([], []) + +and encode_formula (phi:typ) (env:env_t) : (term & decls_t) = (* expects phi to be normalized; the existential variables are all labels *) + let debug phi = + if !dbg_SMTEncoding + then BU.print2 "Formula (%s) %s\n" + (tag_of phi) + (show phi) in + let enc (f:list term -> term) : Range.range -> args -> (term & decls_t) = fun r l -> + let decls, args = BU.fold_map (fun decls x -> let t, decls' = encode_term (fst x) env in decls@decls', t) [] l in + ({f args with rng=r}, decls) in + + let const_op f r _ = (f r, []) in + let un_op f l = f <| List.hd l in + let bin_op : ((term & term) -> term) -> list term -> term = fun f -> function + | [t1;t2] -> f(t1,t2) + | _ -> failwith "Impossible" in + + let enc_prop_c f : Range.range -> args -> (term & decls_t) = fun r l -> + let decls, phis = + BU.fold_map (fun decls (t, _) -> + let phi, decls' = encode_formula t env in + decls@decls', phi) + [] l in + ({f phis with rng=r}, decls) in + + // This gets called for + // eq2 : #a:Type -> a -> a -> Type + // equals: #a:Type -> a -> a -> Type + let eq_op r args : (term & decls_t) = + let rf = List.filter (fun (a,q) -> match q with | Some ({ aqual_implicit = true }) -> false | _ -> true) args in + if List.length rf <> 2 + then failwith (BU.format1 "eq_op: got %s non-implicit arguments instead of 2?" (string_of_int (List.length rf))) + else enc (bin_op mkEq) r rf + in + + let mk_imp r : Tot (args -> (term & decls_t)) = function + | [(lhs, _); (rhs, _)] -> + let l1, decls1 = encode_formula rhs env in + begin match l1.tm with + | App(TrueOp, _) -> (l1, decls1) (* Optimization: don't bother encoding the LHS of a trivial implication *) + | _ -> + let l2, decls2 = encode_formula lhs env in + (Term.mkImp(l2, l1) r, decls1@decls2) + end + | _ -> failwith "impossible" in + + let mk_ite r: Tot (args -> (term & decls_t)) = function + | [(guard, _); (_then, _); (_else, _)] -> + let (g, decls1) = encode_formula guard env in + let (t, decls2) = encode_formula _then env in + let (e, decls3) = encode_formula _else env in + + let res = Term.mkITE(g, t, e) r in + res, decls1@decls2@decls3 + | _ -> failwith "impossible" in + + + let unboxInt_l : (list term -> term) -> list term -> term = fun f l -> f (List.map Term.unboxInt l) in + let connectives = [ + (Const.and_lid, enc_prop_c (bin_op mkAnd)); + (Const.or_lid, enc_prop_c (bin_op mkOr)); + (Const.imp_lid, mk_imp); + (Const.iff_lid, enc_prop_c (bin_op mkIff)); + (Const.ite_lid, mk_ite); + (Const.not_lid, enc_prop_c (un_op mkNot)); + (Const.eq2_lid, eq_op); + (Const.c_eq2_lid, eq_op); + (Const.true_lid, const_op Term.mkTrue); + (Const.false_lid, const_op Term.mkFalse); + ] in + + let rec fallback phi = match phi.n with + | Tm_meta {tm=phi'; meta=Meta_labeled(msg, r, b)} -> + let phi, decls = encode_formula phi' env in + mk (Term.Labeled(phi, msg, r)) r, decls + + | Tm_meta _ -> + encode_formula (U.unmeta phi) env + + | Tm_match {scrutinee=e;brs=pats} -> + let t, decls = encode_match e pats mkUnreachable env encode_formula in + t, decls + + | Tm_let {lbs=(false, [{lbname=Inl x; lbtyp=t1; lbdef=e1}]); body=e2} -> + let t, decls = encode_let x t1 e1 e2 env encode_formula in + t, decls + + | Tm_app {hd=head; args} -> + let head = U.un_uinst head in + begin match head.n, args with + | Tm_fvar fv, [_; (x, _); (t, _)] when S.fv_eq_lid fv Const.has_type_lid -> //interpret Prims.has_type as HasType + let x, decls = encode_term x env in + let t, decls' = encode_term t env in + mk_HasType x t, decls@decls' + + | Tm_fvar fv, [_; (phi, _)] + | Tm_uinst ({n=Tm_fvar fv}, _), [_; (phi, _)] + when S.fv_eq_lid fv Const.by_tactic_lid -> + encode_formula phi env + + | Tm_fvar fv, [_; _; (phi, _)] + | Tm_uinst ({n=Tm_fvar fv}, _), [_; _; (phi, _)] + when S.fv_eq_lid fv Const.rewrite_by_tactic_lid -> + encode_formula phi env + + | Tm_fvar fv, [(r, _); (msg, _); (phi, _)] when S.fv_eq_lid fv Const.labeled_lid -> //interpret (labeled r msg t) as Tm_meta(t, Meta_labeled(msg, r, false) + (* NB: below we use Errors.mkmsg since FStar.Range.labeled takes a string, but + the Meta_labeled node needs a list of docs (Errors.error_message). *) + begin match SE.try_unembed r SE.id_norm_cb, + SE.try_unembed msg SE.id_norm_cb with + | Some r, Some s -> + let phi = S.mk (Tm_meta {tm=phi; meta=Meta_labeled(Errors.mkmsg s, r, false)}) r in + fallback phi + + (* If we could not unembed the position, still use the string *) + | None, Some s -> + let phi = S.mk (Tm_meta {tm=phi; meta=Meta_labeled(Errors.mkmsg s, phi.pos, false)}) phi.pos in + fallback phi + + | _ -> + fallback phi + end + + | Tm_fvar fv, [(t, _)] + when S.fv_eq_lid fv Const.squash_lid + || S.fv_eq_lid fv Const.auto_squash_lid -> + encode_formula t env + + | _ -> + let encode_valid () = + let tt, decls = encode_term phi env in + let tt = + if Range.rng_included (Range.use_range tt.rng) (Range.use_range phi.pos) + then tt + else {tt with rng=phi.pos} in + mk_Valid tt, decls + in + if head_redex env head + then match maybe_whnf env head with + | None -> encode_valid() + | Some phi -> encode_formula phi env + else encode_valid() + end + + | _ -> + let tt, decls = encode_term phi env in + let tt = + if Range.rng_included (Range.use_range tt.rng) (Range.use_range phi.pos) + then tt + else {tt with rng=phi.pos} in + mk_Valid tt, decls in + + let encode_q_body env (bs:Syntax.binders) (ps:list args) body = + let vars, guards, env, decls, _ = encode_binders None bs env in + let pats, decls' = encode_smt_patterns ps env in + let body, decls'' = encode_formula body env in + let guards = match pats with + | [[{tm=App(Var gf, [p])}]] when Ident.string_of_lid Const.guard_free = gf -> [] + | _ -> guards in + vars, pats, mk_and_l guards, body, decls@decls'@decls'' in + + debug phi; + + let phi = U.unascribe phi in + let open FStarC.Syntax.Formula in + match destruct_typ_as_formula phi with + | None -> fallback phi + + | Some (BaseConn(op, arms)) -> + (match connectives |> List.tryFind (fun (l, _) -> lid_equals op l) with + | None -> fallback phi + | Some (_, f) -> f phi.pos arms) + + | Some (QAll(vars, pats, body)) -> + pats |> List.iter (check_pattern_vars env vars); + let vars, pats, guard, body, decls = encode_q_body env vars pats body in + let tm = mkForall phi.pos (pats, vars, mkImp(guard, body)) in + tm, decls + + | Some (QEx(vars, pats, body)) -> + pats |> List.iter (check_pattern_vars env vars); + let vars, pats, guard, body, decls = encode_q_body env vars pats body in + mkExists phi.pos (pats, vars, mkAnd(guard, body)), decls + +(* this assumes t is a Lemma *) +let encode_function_type_as_formula (t:typ) (env:env_t) : term & decls_t = + let universe_of_binders binders = List.map (fun _ -> U_zero) binders in + let quant = U.smt_lemma_as_forall t universe_of_binders in + let env = {env with use_zfuel_name=true} in //see #1028; SMT lemmas should not violate the fuel instrumentation + encode_formula quant env + +(***************************************************************************************************) +(* end main encoding of kinds/types/exps/formulae *) +(***************************************************************************************************) diff --git a/src/smtencoding/FStarC.SMTEncoding.EncodeTerm.fsti b/src/smtencoding/FStarC.SMTEncoding.EncodeTerm.fsti new file mode 100644 index 00000000000..ba87dffb7f2 --- /dev/null +++ b/src/smtencoding/FStarC.SMTEncoding.EncodeTerm.fsti @@ -0,0 +1,68 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.SMTEncoding.EncodeTerm +open Prims +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStar open FStarC +open FStarC.Compiler +open FStarC.TypeChecker.Env +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.TypeChecker +open FStarC.SMTEncoding.Term +open FStarC.Ident +open FStarC.Const +open FStarC.SMTEncoding +open FStarC.SMTEncoding.Util +open FStarC.SMTEncoding.Env +module BU = FStarC.Compiler.Util +val isTotFun_axioms: Range.range -> head:term -> vars:fvs -> guards:list term -> bool -> term +val mk_Apply : e:term -> vars:fvs -> term +val maybe_curry_app : rng:Range.range -> head:either op term -> arity:int -> args:list term -> term +val maybe_curry_fvb : rng:Range.range -> head:fvar_binding -> args:list term -> term +val mkForall_fuel : string -> Range.range -> (list (list pat) & fvs & term -> term) //first arg is the module name + +val head_normal : env_t -> Syntax.term -> bool + +val whnf: env_t -> Syntax.term -> Syntax.term +val norm: env_t -> Syntax.term -> Syntax.term + +val curried_arrow_formals_comp : k:Syntax.term -> Syntax.binders & comp + +val raise_arity_mismatch : head:string -> arity:int -> n_args:int -> rng:Range.range -> 'a + +val encode_term : t:typ (* expects t to be in normal form already *) + -> env:env_t + -> term & decls_t + +val encode_term_pred: fuel_opt:option term + -> t:typ + -> env:env_t + -> e:term + -> term & decls_t + +val encode_args : l:args -> env:env_t -> list term & decls_t + +val encode_formula : phi:typ -> env:env_t -> term & decls_t + +val encode_function_type_as_formula : t:typ -> env:env_t -> term & decls_t + +val encode_binders : fuel_opt:option term + -> bs:Syntax.binders + -> env:env_t + -> list fv & list term & env_t & decls_t & list bv diff --git a/src/smtencoding/FStarC.SMTEncoding.Env.fst b/src/smtencoding/FStarC.SMTEncoding.Env.fst new file mode 100644 index 00000000000..1bf4d2dbd91 --- /dev/null +++ b/src/smtencoding/FStarC.SMTEncoding.Env.fst @@ -0,0 +1,385 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.SMTEncoding.Env +open Prims +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStar open FStarC +open FStarC.Compiler +open FStarC.TypeChecker.Env +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.TypeChecker +open FStarC.SMTEncoding.Term +open FStarC.Ident +open FStarC.SMTEncoding.Util + +module SS = FStarC.Syntax.Subst +module BU = FStarC.Compiler.Util +module U = FStarC.Syntax.Util + +open FStarC.Class.Show + +let dbg_PartialApp = Debug.get_toggle "PartialApp" + +exception Inner_let_rec of list (string & Range.range) //name of the inner let-rec(s) and their locations + +let add_fuel x tl = if (Options.unthrottle_inductives()) then tl else x::tl +let withenv c (a, b) = (a,b,c) +let vargs args = List.filter (function (Inl _, _) -> false | _ -> true) args +(* ------------------------------------ *) +(* Some operations on constants *) +let escape (s:string) = BU.replace_char s '\'' '_' +let mk_term_projector_name lid (a:bv) = + escape <| BU.format2 "%s_%s" (string_of_lid lid) (string_of_id a.ppname) +let primitive_projector_by_pos env lid i = + let fail () = failwith (BU.format2 "Projector %s on data constructor %s not found" (string_of_int i) (string_of_lid lid)) in + let _, t = Env.lookup_datacon env lid in + match (SS.compress t).n with + | Tm_arrow {bs; comp=c} -> + let binders, _ = SS.open_comp bs c in + if ((i < 0) || i >= List.length binders) //this has to be within bounds! + then fail () + else let b = List.nth binders i in + mk_term_projector_name lid b.binder_bv + | _ -> fail () +let mk_term_projector_name_by_pos lid (i:int) = escape <| BU.format2 "%s_%s" (string_of_lid lid) (string_of_int i) +let mk_term_projector (lid:lident) (a:bv) : term = + mkFreeV <| mk_fv (mk_term_projector_name lid a, Arrow(Term_sort, Term_sort)) +let mk_term_projector_by_pos (lid:lident) (i:int) : term = + mkFreeV <| mk_fv (mk_term_projector_name_by_pos lid i, Arrow(Term_sort, Term_sort)) +let mk_data_tester env l x = mk_tester (escape (string_of_lid l)) x +(* ------------------------------------ *) +(* New name generation *) +type varops_t = { + push: unit -> unit; + pop: unit -> unit; + snapshot: unit -> (int & unit); + rollback: option int -> unit; + new_var:ident -> int -> string; (* each name is distinct and has a prefix corresponding to the name used in the program text *) + new_fvar:lident -> string; + fresh:string -> string -> string; (* module name -> prefix -> name *) + reset_fresh:unit -> unit; + next_id: unit -> int; + mk_unique:string -> string; +} +let varops = + let initial_ctr = 100 in + let ctr = BU.mk_ref initial_ctr in + let new_scope () : BU.smap bool = BU.smap_create 100 in (* a scope records all the names used in that scope *) + let scopes = BU.mk_ref [new_scope ()] in + let mk_unique y = + let y = escape y in + let y = match BU.find_map (!scopes) (fun names -> BU.smap_try_find names y) with + | None -> y + | Some _ -> BU.incr ctr; y ^ "__" ^ (string_of_int !ctr) in + let top_scope = List.hd !scopes in + BU.smap_add top_scope y true; y in + let new_var pp rn = mk_unique <| (string_of_id pp) ^ "__" ^ (string_of_int rn) in + let new_fvar lid = mk_unique (string_of_lid lid) in + let next_id () = BU.incr ctr; !ctr in + //AR: adding module name after the prefix, else it interferes for name matching for fuel arguments + // see try_lookup_free_var below + let fresh mname pfx = BU.format3 "%s_%s_%s" pfx mname (string_of_int <| next_id()) in + //the fresh counter is reset after every module + let reset_fresh () = ctr := initial_ctr in + let push () = scopes := new_scope() :: !scopes in // already signal-atomic + let pop () = scopes := List.tl !scopes in // already signal-atomic + let snapshot () = FStarC.Common.snapshot push scopes () in + let rollback depth = FStarC.Common.rollback pop scopes depth in + {push=push; + pop=pop; + snapshot=snapshot; + rollback=rollback; + new_var=new_var; + new_fvar=new_fvar; + fresh=fresh; + reset_fresh=reset_fresh; + next_id=next_id; + mk_unique=mk_unique} + +(* ---------------------------------------------------- *) +(* *) +(* Each entry maps a Syntax variable to its encoding as a SMT2 term *) +(* free variables, depending on whether or not they are fully applied ... *) +(* ... are mapped either to SMT2 functions, or to nullary tokens *) +type fvar_binding = { + fvar_lid: lident; + smt_arity: int; + smt_id: string; + smt_token: option term; + smt_fuel_partial_app:option (term & term); + fvb_thunked: bool +} +let fvb_to_string fvb = + let term_opt_to_string = function + | None -> "None" + | Some s -> Term.print_smt_term s + in + let term_pair_opt_to_string = function + | None -> "None" + | Some (s0, s1) -> + BU.format2 "(%s, %s)" + (Term.print_smt_term s0) + (Term.print_smt_term s1) + in + BU.format6 "{ lid = %s;\n smt_arity = %s;\n smt_id = %s;\n smt_token = %s;\n smt_fuel_partial_app = %s;\n fvb_thunked = %s }" + (Ident.string_of_lid fvb.fvar_lid) + (string_of_int fvb.smt_arity) + fvb.smt_id + (term_opt_to_string fvb.smt_token) + (term_pair_opt_to_string fvb.smt_fuel_partial_app) + (BU.string_of_bool fvb.fvb_thunked) + +let check_valid_fvb fvb = + if (Option.isSome fvb.smt_token + || Option.isSome fvb.smt_fuel_partial_app) + && fvb.fvb_thunked + then failwith (BU.format1 "Unexpected thunked SMT symbol: %s" (Ident.string_of_lid fvb.fvar_lid)) + else if fvb.fvb_thunked && fvb.smt_arity <> 0 + then failwith (BU.format1 "Unexpected arity of thunked SMT symbol: %s" (Ident.string_of_lid fvb.fvar_lid)); + match fvb.smt_token with + | Some ({tm=FreeV _}) -> + failwith (BU.format1 "bad fvb\n%s" (fvb_to_string fvb)) + | _ -> () + + +let binder_of_eithervar v = (v, None) + +type env_t = { + bvar_bindings: BU.psmap (BU.pimap (bv & term)); + fvar_bindings: (BU.psmap fvar_binding & list fvar_binding); //list of fvar bindings for the current module + //remember them so that we can store them in the checked file + depth:int; //length of local var/tvar bindings + tcenv:Env.env; + warn:bool; + nolabels:bool; + use_zfuel_name:bool; + encode_non_total_function_typ:bool; + current_module_name:string; + encoding_quantifier:bool; + global_cache:BU.smap decls_elt; //cache for hashconsing -- see Encode.fs where it is used and updated +} + +let print_env (e:env_t) : string = + let bvars = BU.psmap_fold e.bvar_bindings (fun _k pi acc -> + BU.pimap_fold pi (fun _i (x, _term) acc -> + show x :: acc) acc) [] in + let allvars = BU.psmap_fold (e.fvar_bindings |> fst) (fun _k fvb acc -> + fvb.fvar_lid :: acc) [] in + let last_fvar = + match List.rev allvars with + | [] -> "" + | l::_ -> "...," ^ show l + in + String.concat ", " (last_fvar :: bvars) + +let lookup_bvar_binding env bv = + match BU.psmap_try_find env.bvar_bindings (string_of_id bv.ppname) with + | Some bvs -> BU.pimap_try_find bvs bv.index + | None -> None + +let lookup_fvar_binding env lid = + BU.psmap_try_find (env.fvar_bindings |> fst) (string_of_lid lid) + +let add_bvar_binding bvb bvbs = + BU.psmap_modify bvbs (string_of_id (fst bvb).ppname) + (fun pimap_opt -> + BU.pimap_add (BU.dflt (BU.pimap_empty ()) pimap_opt) (fst bvb).index bvb) + +let add_fvar_binding fvb (fvb_map, fvb_list) = + (BU.psmap_add fvb_map (string_of_lid fvb.fvar_lid) fvb, fvb::fvb_list) + +let fresh_fvar mname x s = let xsym = varops.fresh mname x in xsym, mkFreeV <| mk_fv (xsym, s) +(* generate terms corresponding to a variable and record the mapping in the environment *) + +(* Bound term variables *) +let gen_term_var (env:env_t) (x:bv) = + let ysym = "@x"^(string_of_int env.depth) in + let y = mkFreeV <| mk_fv (ysym, Term_sort) in + (* Note: the encoding of impure function arrows (among other places + probably) relies on the fact that this is exactly a FreeV. See getfreeV in + FStarC.SMTEncoding.EncodeTerm.fst *) + ysym, y, {env with bvar_bindings=add_bvar_binding (x, y) env.bvar_bindings + ; tcenv = Env.push_bv env.tcenv x + ; depth = env.depth + 1 } + +let new_term_constant (env:env_t) (x:bv) = + let ysym = varops.new_var x.ppname x.index in + let y = mkApp(ysym, []) in + ysym, y, {env with bvar_bindings=add_bvar_binding (x, y) env.bvar_bindings + ; tcenv = Env.push_bv env.tcenv x} + +let new_term_constant_from_string (env:env_t) (x:bv) str = + let ysym = varops.mk_unique str in + let y = mkApp(ysym, []) in + ysym, y, {env with bvar_bindings=add_bvar_binding (x, y) env.bvar_bindings + ; tcenv = Env.push_bv env.tcenv x} + +let push_term_var (env:env_t) (x:bv) (t:term) = + {env with bvar_bindings=add_bvar_binding (x,t) env.bvar_bindings + ; tcenv = Env.push_bv env.tcenv x} + +let lookup_term_var env a = + match lookup_bvar_binding env a with + | Some (b,t) -> t + | None -> + failwith (BU.format2 "Bound term variable not found %s in environment: %s" + (show a) + (print_env env)) + +(* Qualified term names *) +let mk_fvb lid fname arity ftok fuel_partial_app thunked = + let fvb = { + fvar_lid = lid; + smt_arity = arity; + smt_id = fname; + smt_token = ftok; + smt_fuel_partial_app = fuel_partial_app; + fvb_thunked = thunked; + } + in + check_valid_fvb fvb; + fvb +let new_term_constant_and_tok_from_lid_aux (env:env_t) (x:lident) arity thunked = + let fname = varops.new_fvar x in + let ftok_name, ftok = + if thunked then None, None + else let ftok_name = fname^"@tok" in + let ftok = mkApp(ftok_name, []) in + Some ftok_name, Some ftok + in + let fvb = mk_fvb x fname arity ftok None thunked in +// Printf.printf "Pushing %A @ %A, %A\n" x fname ftok; + fname, ftok_name, {env with fvar_bindings=add_fvar_binding fvb env.fvar_bindings} +let new_term_constant_and_tok_from_lid (env:env_t) (x:lident) arity = + let fname, ftok_name_opt, env = new_term_constant_and_tok_from_lid_aux env x arity false in + fname, Option.get ftok_name_opt, env +let new_term_constant_and_tok_from_lid_maybe_thunked (env:env_t) (x:lident) arity th = + new_term_constant_and_tok_from_lid_aux env x arity th +let fail_fvar_lookup env a = + let q = Env.lookup_qname env.tcenv a in + match q with + | None -> + failwith (BU.format1 "Name %s not found in the smtencoding and typechecker env" (show a)) + | _ -> + let quals = Env.quals_of_qninfo q in + if BU.is_some quals && + (quals |> BU.must |> List.contains Unfold_for_unification_and_vcgen) + then Errors.raise_error a Errors.Fatal_IdentifierNotFound + (BU.format1 "Name %s not found in the smtencoding env (the symbol is marked unfold, expected it to reduce)" (show a)) + else failwith (BU.format1 "Name %s not found in the smtencoding env" (show a)) +let lookup_lid env a = + match lookup_fvar_binding env a with + | None -> fail_fvar_lookup env a + | Some s -> check_valid_fvb s; s +let push_free_var_maybe_thunked env (x:lident) arity fname ftok thunked = + let fvb = mk_fvb x fname arity ftok None thunked in + {env with fvar_bindings=add_fvar_binding fvb env.fvar_bindings} +let push_free_var env (x:lident) arity fname ftok = + push_free_var_maybe_thunked env x arity fname ftok false +let push_free_var_thunk env (x:lident) arity fname ftok = + push_free_var_maybe_thunked env x arity fname ftok (arity=0) +let push_zfuel_name env (x:lident) f ftok = + let fvb = lookup_lid env x in + let t3 = mkApp(f, [mkApp("ZFuel", [])]) in + let t3' = mk_ApplyTF (mkApp(ftok, [])) (mkApp("ZFuel", [])) in + let fvb = mk_fvb x fvb.smt_id fvb.smt_arity fvb.smt_token (Some (t3, t3')) false in + {env with fvar_bindings=add_fvar_binding fvb env.fvar_bindings} +let force_thunk fvb = + if not (fvb.fvb_thunked) || fvb.smt_arity <> 0 + then failwith "Forcing a non-thunk in the SMT encoding"; + mkFreeV <| FV (fvb.smt_id, Term_sort, true) +module TcEnv = FStarC.TypeChecker.Env +let try_lookup_free_var env l = + match lookup_fvar_binding env l with + | None -> None + | Some fvb -> + if !dbg_PartialApp + then BU.print2 "Looked up %s found\n%s\n" + (Ident.string_of_lid l) + (fvb_to_string fvb); + if fvb.fvb_thunked + then Some (force_thunk fvb) + else + begin + match fvb.smt_fuel_partial_app with + | Some (_, f) when env.use_zfuel_name -> Some f + | _ -> + begin + match fvb.smt_token with + | Some t -> + begin + match t.tm with + | App(_, [fuel]) -> + if (BU.starts_with (Term.fv_of_term fuel |> fv_name) "fuel") + then Some <| mk_ApplyTF(mkFreeV <| mk_fv (fvb.smt_id, Term_sort)) fuel + else Some t + | _ -> Some t + end + | _ -> None + end + end +let lookup_free_var env a = + match try_lookup_free_var env a.v with + | Some t -> t + | None -> fail_fvar_lookup env a.v +let lookup_free_var_name env a = lookup_lid env a.v +let lookup_free_var_sym env a = + let fvb = lookup_lid env a.v in + match fvb.smt_fuel_partial_app with + | Some({tm=App(g, zf)}, _) + when env.use_zfuel_name -> + Inl g, zf, fvb.smt_arity + 1 + | _ -> + begin + match fvb.smt_token with + | None when fvb.fvb_thunked -> + Inr (force_thunk fvb), [], fvb.smt_arity + | None -> + Inl (Var fvb.smt_id), [], fvb.smt_arity + | Some sym -> + begin + match sym.tm with + | App(g, [fuel]) -> + Inl g, [fuel], fvb.smt_arity + 1 + | _ -> + Inl (Var fvb.smt_id), [], fvb.smt_arity + end + end + +let tok_of_name env nm = + match + BU.psmap_find_map (env.fvar_bindings |> fst) (fun _ fvb -> + check_valid_fvb fvb; + if fvb.smt_id = nm then fvb.smt_token else None) + with + | Some b -> Some b + | None -> //this must be a bvar + BU.psmap_find_map env.bvar_bindings (fun _ pi -> + BU.pimap_fold pi (fun _ y res -> + match res, y with + | Some _, _ -> res + | None, (_, {tm=App(Var sym, [])}) when sym=nm -> + Some (snd y) + | _ -> None) None) + +let reset_current_module_fvbs env = { env with fvar_bindings = (env.fvar_bindings |> fst, []) } +let get_current_module_fvbs env = env.fvar_bindings |> snd +let add_fvar_binding_to_env fvb env = + { env with fvar_bindings = add_fvar_binding fvb env.fvar_bindings } + +(* *) diff --git a/src/smtencoding/FStarC.SMTEncoding.ErrorReporting.fst b/src/smtencoding/FStarC.SMTEncoding.ErrorReporting.fst new file mode 100644 index 00000000000..de156b908c7 --- /dev/null +++ b/src/smtencoding/FStarC.SMTEncoding.ErrorReporting.fst @@ -0,0 +1,382 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.SMTEncoding.ErrorReporting +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.BaseTypes +open FStarC.Compiler.Util +open FStarC.SMTEncoding.Term +open FStarC.SMTEncoding.Util +open FStarC.SMTEncoding.Z3 +open FStarC.SMTEncoding +open FStarC.Compiler.Range +open FStarC.Class.Setlike +module BU = FStarC.Compiler.Util + +exception Not_a_wp_implication of string +let sort_labels (l:(list (error_label & bool))) = List.sortWith (fun ((_, _, r1), _) ((_, _, r2), _) -> Range.compare r1 r2) l +let remove_dups (l:labels) = BU.remove_dups (fun (_, m1, r1) (_, m2, r2) -> r1=r2 && m1=m2) l +type msg = string & Range.range +type ranges = list (option string & Range.range) + +//decorate a term with an error label +let __ctr = BU.mk_ref 0 + +let fresh_label : Errors.error_message -> Range.range -> term -> label & term = + fun message range t -> + let l = incr __ctr; format1 "label_%s" (string_of_int !__ctr) in + let lvar = mk_fv (l, Bool_sort) in + let label = (lvar, message, range) in + let lterm = mkFreeV lvar in + let lt = Term.mkOr(lterm, t) range in + label, lt + +(* + label_goals query : term * labels + traverses the query, finding sub-formulas that are goals to be proven, + and labels each such sub-goal with a distinct label variable + + Returns the labeled query and the label terms that were added +*) +let label_goals use_env_msg //when present, provides an alternate error message, + //usually "could not check implicit argument", + // "could not prove post-condition" + //or something like that + (r:Range.range) //the source range in which this query was asked + q //the query + : labels //the labels themselves + & term //the query, decorated with labels + = + let rec is_a_post_condition post_name_opt tm = + match post_name_opt, tm.tm with + | None, _ -> false + | Some nm, FreeV fv -> + nm=fv_name fv + | _, App (Var "Valid", [tm]) + | _, App (Var "ApplyTT", tm::_) -> + is_a_post_condition post_name_opt tm + | _ -> + false + in + let conjuncts t = + match t.tm with + | App(And, cs) -> cs + | _ -> [t] + in + let is_guard_free tm = + match tm.tm with + | Quant(Forall, [[{tm=App(Var "Prims.guard_free", [p])}]], iopt, _, {tm=App(Imp, [l;r])}) -> + true + | _ -> false + in + let is_a_named_continuation lhs = conjuncts lhs |> BU.for_some is_guard_free in + let flag, msg_prefix = match use_env_msg with + | None -> false, Pprint.empty + | Some f -> true, Pprint.doc_of_string (f()) in + let fresh_label msg ropt rng t = + let open FStarC.Pprint in + let msg = if flag + then (Errors.Msg.text "Failed to verify implicit argument: " ^^ msg_prefix) :: msg + else msg in + let rng = match ropt with + | None -> rng + | Some r -> if Range.rng_included (Range.use_range rng) (Range.use_range r) + then rng + else Range.set_def_range r (Range.def_range rng) + in + fresh_label msg rng t + in + let rec aux (default_msg : Errors.error_message) //the error message text to generate at a label + (ropt:option Range.range) //an optional position, if there was an enclosing Labeled node + (post_name_opt:option string) //the name of the current post-condition variable --- it is left uninstrumented + (labels:list label) //the labels accumulated so far + (q:term) //the term being instrumented + = match q.tm with + | BoundV _ + | Integer _ + | String _ + | Real _ -> + labels, q + + | LblPos _ -> failwith "Impossible" //these get added after errorReporting instrumentation only + + | Labeled(arg, [d], label_range) when Errors.Msg.renderdoc d = "Could not prove post-condition" -> + //printfn "GOT A LABELED WP IMPLICATION\n\t%s" + // (Term.print_smt_term q); + let fallback debug_msg = + //printfn "FALLING BACK: %s with range %s" msg + // (match ropt with None -> "None" | Some r -> Range.string_of_range r); + aux default_msg (Some label_range) post_name_opt labels arg + in + begin try + begin match arg.tm with + | Quant(Forall, pats, iopt, post::sorts, {tm=App(Imp, [lhs;rhs]); rng=rng}) -> + let post_name = "^^post_condition_"^ (BU.string_of_int <| GenSym.next_id ()) in + let names = mk_fv (post_name, post) + ::List.map (fun s -> mk_fv ("^^" ^ (string_of_int <| GenSym.next_id()), s)) sorts in + let instantiation = List.map mkFreeV names in + let lhs, rhs = Term.inst instantiation lhs, Term.inst instantiation rhs in + + let labels, lhs = match lhs.tm with + | App(And, clauses_lhs) -> + let req, ens = BU.prefix clauses_lhs in + begin match ens.tm with + | Quant(Forall, pats_ens, iopt_ens, sorts_ens, {tm=App(Imp, [ensures_conjuncts; post]); rng=rng_ens}) -> + if is_a_post_condition (Some post_name) post + then + let labels, ensures_conjuncts = aux (Errors.mkmsg "Could not prove post-condition") None (Some post_name) labels ensures_conjuncts in + let pats_ens = + match pats_ens with + | [] + | [[]] -> [[post]] //make the post-condition formula the pattern, if there isn't one already (usually there isn't) + | _ -> pats_ens in + let ens = Term.mk (Quant(Forall, pats_ens, iopt_ens, sorts_ens, + Term.mk (App(Imp, [ensures_conjuncts; post])) rng_ens)) ens.rng in + let lhs = Term.mk (App(And, req@[ens])) lhs.rng in + labels, Term.abstr names lhs + else raise (Not_a_wp_implication ("Ensures clause doesn't match post name: " + ^ post_name + ^ " ... " + ^ Term.print_smt_term post)) + + | _ -> raise (Not_a_wp_implication ("Ensures clause doesn't have the expected shape for post-condition " + ^ post_name + ^ " ... " + ^ Term.print_smt_term ens)) + end + | _ -> raise (Not_a_wp_implication ("LHS not a conjunct: " ^ (Term.print_smt_term lhs))) in + + let labels, rhs = + let labels, rhs = aux default_msg None (Some post_name) labels rhs in + labels, Term.abstr names rhs in + + let body = Term.mkImp(lhs, rhs) rng in + labels, Term.mk (Quant(Forall, pats, iopt, post::sorts, body)) q.rng + + + | _ -> //not in the form produced by an application of M_stronger + fallback ("arg not a quant: ")// ^ (Term.print_smt_term arg)) + end + with Not_a_wp_implication msg -> fallback msg + end + + | Labeled(arg, reason, r) -> + aux reason (Some r) post_name_opt labels arg + + | Quant(Forall, [], None, sorts, {tm=App(Imp, [lhs;rhs]); rng=rng}) + when is_a_named_continuation lhs -> + let sorts', post = BU.prefix sorts in + let new_post_name = "^^post_condition_"^ (BU.string_of_int <| GenSym.next_id ()) in + //printfn "Got a named continuation with post-condition %s" new_post_name; + let names = List.map (fun s -> mk_fv ("^^" ^ (string_of_int <| GenSym.next_id()), s)) sorts' + @ [mk_fv (new_post_name, post)] in + let instantiation = List.map mkFreeV names in + let lhs, rhs = Term.inst instantiation lhs, Term.inst instantiation rhs in + + let labels, lhs_conjs = + BU.fold_map (fun labels tm -> + match tm.tm with + | Quant(Forall, [[{tm=App(Var "Prims.guard_free", [p])}]], iopt, sorts, {tm=App(Imp, [l0;r])}) -> + if is_a_post_condition (Some new_post_name) r + then begin + //printfn "++++RHS is a post-condition for %s;\n\trhs=%s" + // new_post_name + // (Term.print_smt_term r); + let labels, l = aux default_msg None post_name_opt labels l0 in + //printfn "++++LHS %s\nlabeled as%s" + // (Term.print_smt_term l0) + // (Term.print_smt_term l); + labels, mk (Quant(Forall, [[p]], Some 0, sorts, norng mk (App(Imp, [l;r])))) q.rng + end + else begin + //printfn "----RHS not a post-condition for %s;\n\trhs=%s" + // new_post_name + // (Term.print_smt_term r); + labels, tm + end + | _ -> labels, tm) + labels (conjuncts lhs) in + + let labels, rhs = aux default_msg None (Some new_post_name) labels rhs in + let body = Term.mkImp(Term.mk_and_l lhs_conjs lhs.rng, rhs) rng |> Term.abstr names in + let q = Term.mk (Quant(Forall, [], None, sorts, body)) q.rng in + labels, q + + | App(Imp, [lhs;rhs]) -> + let labels, rhs = aux default_msg ropt post_name_opt labels rhs in + labels, mkImp(lhs, rhs) + + | App(And, conjuncts) -> + let labels, conjuncts = BU.fold_map (aux default_msg ropt post_name_opt) labels conjuncts in + labels, Term.mk_and_l conjuncts q.rng + + | App(ITE, [hd; q1; q2]) -> + let labels, q1 = aux default_msg ropt post_name_opt labels q1 in + let labels, q2 = aux default_msg ropt post_name_opt labels q2 in + labels, Term.mkITE (hd, q1, q2) q.rng + + | Quant(Exists, _, _, _, _) + | App(Iff, _) + | App(Or, _) -> //non-atomic, but can't case split + let lab, q = fresh_label default_msg ropt q.rng q in + lab::labels, q + + | App (Var "Unreachable", _) -> + //ITEs are encoded with an additional else case just to make them well-formed + //These are not real goals and should not be labeled + labels, q + + | App (Var _, _) when is_a_post_condition post_name_opt q -> + //applications of the post-condition variable are never labeled + //only specific conjuncts of an ensures clause are labeled + labels, q + + | FreeV _ + | App(TrueOp, _) + | App(FalseOp, _) + | App(Not, _) + | App(Eq, _) + | App(LT, _) + | App(LTE, _) + | App(GT, _) + | App(GTE, _) + | App(BvUlt, _) + | App(Var _, _) -> //atomic goals + let lab, q = fresh_label default_msg ropt q.rng q in + lab::labels, q + + | App(RealDiv, _) + | App(Add, _) + | App(Sub, _) + | App(Div, _) + | App(Mul, _) + | App(Minus, _) + | App(Mod, _) + | App(BvAnd, _) + | App(BvXor, _) + | App(BvOr, _) + | App(BvAdd, _) + | App(BvSub, _) + | App(BvShl, _) + | App(BvShr, _) + | App(BvUdiv, _) + | App(BvMod, _) + | App(BvMul, _) + | App(BvUext _, _) + | App(BvToNat, _) + | App(NatToBv _, _) -> + failwith "Impossible: non-propositional term" + + | App(ITE, _) + | App(Imp, _) -> + failwith "Impossible: arity mismatch" + + | Quant(Forall, pats, iopt, sorts, body) -> + let labels, body = aux default_msg ropt post_name_opt labels body in + labels, Term.mk (Quant(Forall, pats, iopt, sorts, body)) q.rng + + (* TODO (KM) : I am not sure whether we should label the let-bounded expressions here *) + | Let(es, body) -> + let labels, body = aux default_msg ropt post_name_opt labels body in + labels, Term.mkLet (es, body) q.rng + in + __ctr := 0; + aux (Errors.mkmsg "Assertion failed") None None [] q + + +(* + detail_errors all_labels potential_errors askZ3 + + -- Searching through the list of errors labels to exhaustively list + only those that are definitely not provable given the current + solver parameters. + + -- potential_errors are the labels in the initial counterexample model + *) +let detail_errors hint_replay + env + (all_labels:labels) + (askZ3:list decl -> Z3.z3result) + : unit = + + let print_banner () = + let msg = + BU.format4 + "Detailed %s report follows for %s\nTaking %s seconds per proof obligation (%s proofs in total)\n" + (if hint_replay then "hint replay" else "error") + (Range.string_of_range (TypeChecker.Env.get_range env)) + (BU.string_of_int 5) + (BU.string_of_int (List.length all_labels)) in + BU.print_error msg + in + + let print_result ((_, msg, r), success) = + let open FStarC.Pprint in + let open FStarC.Errors.Msg in + if success + then BU.print1 "OK: proof obligation at %s was proven in isolation\n" (Range.string_of_range r) + else if hint_replay + then FStarC.Errors.log_issue r Errors.Warning_HintFailedToReplayProof + (text "Hint failed to replay this sub-proof" :: msg) + else FStarC.Errors.log_issue r Errors.Error_ProofObligationFailed ([ + text <| BU.format1 "XX: proof obligation at %s failed." (Class.Show.show r); + ] @ msg) + in + + let elim labs = //assumes that all the labs are true, effectively removing them from the query + labs + |> List.map (fun (l, _, _) -> + let tm = mkEq(mkFreeV l, mkTrue) in + let a = { + assumption_name="@disable_label_"^fv_name l; //the "@" is important in the name; forces it to be retained when replaying a hint + assumption_caption=Some "Disabling label"; + assumption_term=mkEq(mkFreeV l, mkTrue); + assumption_fact_ids=[]; + assumption_free_names=free_top_level_names tm + } + in + Term.Assume a) in + + //check all active labels linearly and classify as eliminated/error + let rec linear_check eliminated errors active = + FStarC.SMTEncoding.Z3.refresh (Some env.proof_ns); + match active with + | [] -> + let results = + List.map (fun x -> x, true) eliminated + @ List.map (fun x -> x, false) errors in + sort_labels results + + | hd::tl -> + BU.print1 "%s, " (BU.string_of_int (List.length active)); + let decls = elim <| (eliminated @ errors @ tl) in + let result = askZ3 decls in //hd is the only thing to prove + match result.z3result_status with + | Z3.UNSAT _ -> //hd is provable + linear_check (hd::eliminated) errors tl + | _ -> linear_check eliminated (hd::errors) tl + in + + print_banner (); + Options.set_option "z3rlimit" (Options.Int 5); + let res = linear_check [] [] all_labels in + BU.print_string "\n"; + res |> List.iter print_result; + if BU.for_all snd res + then BU.print_string "Failed: the heuristic of trying each proof in isolation failed to identify a precise error\n" diff --git a/src/smtencoding/FStarC.SMTEncoding.ErrorReporting.fsti b/src/smtencoding/FStarC.SMTEncoding.ErrorReporting.fsti new file mode 100644 index 00000000000..f9e747a1c63 --- /dev/null +++ b/src/smtencoding/FStarC.SMTEncoding.ErrorReporting.fsti @@ -0,0 +1,38 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.SMTEncoding.ErrorReporting +open FStarC.Compiler.Effect +open FStar open FStarC +open FStarC.Compiler +open FStarC.BaseTypes +open FStarC.Compiler.Util +open FStarC.SMTEncoding.Term +open FStarC.SMTEncoding.Util +open FStarC.SMTEncoding +open FStarC.Compiler.Range +module BU = FStarC.Compiler.Util + +type label = error_label +type labels = list label + +val label_goals : option (unit -> string) -> range -> q:term -> labels & term + +val detail_errors : bool //detail_hint_replay? + -> TypeChecker.Env.env + -> labels + -> (list decl -> Z3.z3result) + -> unit diff --git a/src/smtencoding/FStarC.SMTEncoding.Pruning.fst b/src/smtencoding/FStarC.SMTEncoding.Pruning.fst new file mode 100644 index 00000000000..48a489310db --- /dev/null +++ b/src/smtencoding/FStarC.SMTEncoding.Pruning.fst @@ -0,0 +1,468 @@ +(* + Copyright 2024 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.SMTEncoding.Pruning +open FStarC.Compiler.Effect +open FStar open FStarC +open FStar.List.Tot +open FStarC.Compiler +open FStarC.SMTEncoding.Term +open FStarC.Class.Setlike +open FStarC.Class.Show +open FStarC.Class.Monad +module BU = FStarC.Compiler.Util +type triggers = list (list string) +type triggers_set = list (RBSet.t string) + +let triggers_as_triggers_set (ts:triggers) : triggers_set = List.map from_list ts + +type pruning_state = { + //A macro is a (define-fun f ... (body)); Maps macro name 'f' to the free names of its body + macro_freenames: BU.psmap (list string); + // Maps trigger symbols to assumptions that have triggers that mention that symbol + // E.g., given `A : forall x. {:pattern (p x; q x) \/ (p' x; q' x)} R` + // trigger_to_assumption maps p -> A, q -> A, p' -> A, q' -> A + trigger_to_assumption: BU.psmap (list assumption); + // Maps assumption name to triggers that "waiting" on it + // E.g., in the example above, assumption_to_trigger contains A -> [[p;q]; [p';q']] + assumption_to_triggers: BU.psmap triggers_set; + // Maps assumption names to the assumptions themselves + assumption_name_map: BU.psmap decl; + //assumptions with no triggers that will always included + ambients: list string; + //extra roots that will be added to the initial set of roots + extra_roots: list assumption +} + +let debug (f: unit -> unit) : unit = + if Options.Ext.get "debug_context_pruning" <> "" + then f() + +let print_pruning_state (p:pruning_state) +: string += let t_to_a = + BU.psmap_fold + p.trigger_to_assumption + (fun k v (acc:list (string & int)) -> (k, List.length v) :: acc) + [] + in + let t_to_a = BU.sort_with (fun x y -> snd x - snd y) t_to_a in + let a_to_t = + BU.psmap_fold + p.assumption_to_triggers + (fun k v acc -> + BU.format2 "[%s -> %s]" + k + (show v) :: acc) + [] + in + let macros = + BU.psmap_fold + p.macro_freenames + (fun k v acc -> + BU.format2 "[%s -> %s]" + k + (show v) :: acc) + [] + in + BU.format3 "Pruning state:\n\tTriggers to assumptions:\n\t%s\nAssumptions to triggers:\n\t%s\nMacros:\n\t%s\n" + (String.concat "\n\t" (List.map show t_to_a)) + (String.concat "\n\t" a_to_t) + (String.concat "\n\t" macros) + +instance show_pruning_state: showable pruning_state = { show = print_pruning_state } + +(* Initial state: everything is empty *) +let init +: pruning_state += { macro_freenames = BU.psmap_empty (); + trigger_to_assumption = BU.psmap_empty (); + assumption_to_triggers = BU.psmap_empty (); + assumption_name_map = BU.psmap_empty (); + ambients=[]; + extra_roots=[] } + +(* Add: trig -> a*) +let add_trigger_to_assumption (a:assumption) (p:pruning_state) (trig:string) +: pruning_state += match BU.psmap_try_find p.trigger_to_assumption trig with + | None -> + { p with trigger_to_assumption = BU.psmap_add p.trigger_to_assumption trig [a] } + | Some l -> { p with trigger_to_assumption = BU.psmap_add p.trigger_to_assumption trig (a::l) } + +// Names that are excluded from the set of free names +// Since they are very common and are not useful to scan as triggers +let exclude_names : RBSet.t string = + from_list [ + "SFuel"; + "ZFuel"; + "HasType"; + "HasTypeZ"; + "HasTypeFuel"; + "Valid"; + "ApplyTT"; + "ApplyTF"; + "Prims.lex_t" + ] + +let free_top_level_names t = diff (Term.free_top_level_names t) exclude_names +let assumption_free_names a = diff a.assumption_free_names exclude_names + +(* Triggers of a universally quantified term *) +let triggers_of_term (t:term) +: triggers_set += let rec aux (t:term) = + match t.tm with + | Quant(Forall, triggers, _, _, _) -> + triggers |> List.map (fun disjunct -> + disjunct |> List.fold_left (fun out t -> union out (free_top_level_names t)) (empty())) + | Labeled (t, _, _) + | LblPos (t, _) -> aux t + | _ -> [] + in aux t + +(* This function has lots of special cases for F*'s SMT encoding, + particularly its handling of top-level non-quantified assumptions. + + One quirk to note here, that we should probably fix in the SMT encoding + itself: + + - Applications of nullary functions are sometimes encoded as + App(Var "name", []) and sometiems as FreeV(FV("name", _, _)) +*) +let maybe_add_ambient (a:assumption) (p:pruning_state) +: pruning_state += let add_assumption_with_triggers (triggers:triggers_set) = + (* associate the triggers with the assumption in both directions *) + let p = + { p with + assumption_to_triggers= + BU.psmap_add p.assumption_to_triggers a.assumption_name triggers} + in + List.fold_left (List.fold_left (add_trigger_to_assumption a)) p (List.map elems triggers) + in + let is_empty triggers = + match triggers with + | [] -> true + | [t] -> is_empty t + | _ -> false + in + let is_ambient_refinement ty = + match ty.tm with + | App(Var "Prims.squash", _) -> true + | App(Var name, _) + | FreeV(FV(name, _, _)) -> BU.starts_with name "Tm_refine_" + | _ -> false + in + let ambient_refinement_payload ty = + match ty.tm with + | App(Var "Prims.squash", [t]) -> t + | _ -> ty + in + begin + match a.assumption_term.tm with + // - The top-level assumption `function_token_typing_Prims.__cache_version_number__` + // is always included in the pruned set, since it provides an inhabitation proof + // for int which some proofs rely on + | _ when a.assumption_name = "function_token_typing_Prims.__cache_version_number__" -> + { p with ambients = a.assumption_name::p.ambients } + + // - l_quant_interp assumptions give interpretations to deeply embedded quantifiers + // and have a specific shape of an Iff, where the LHS has a pattern, if the + // user annotated one. + | App(Iff, [t0; t1]) when BU.starts_with a.assumption_name "l_quant_interp" -> ( + let triggers_lhs = free_top_level_names t0 in + add_assumption_with_triggers [triggers_lhs] + ) + + // - Top-level `assume A : t` facts in F* are encoded as "assumption_" named + // declarations, handled similarly to squash and Tm_refine_ assumptions. + | _ when BU.starts_with a.assumption_name "assumption_" -> ( + let triggers = triggers_of_term a.assumption_term in + if is_empty triggers + then ( + let triggers = [free_top_level_names a.assumption_term] in + add_assumption_with_triggers triggers + ) + else + add_assumption_with_triggers triggers + ) + + // - Top-level assumptions of the form `HasType term (squash ty)` + // or `HasType term (Tm_refine_... )` are deemed ambient and are + // always included in the pruned set and added as extra roots. + | App (Var "HasType", [term; ty]) + when is_ambient_refinement ty -> ( + //HasType term (squash ty) is an ambient that should trigger on either the term or the type + let triggers = triggers_of_term (ambient_refinement_payload ty) in + if is_empty triggers + then { p with ambients = a.assumption_name::p.ambients; + extra_roots = a::p.extra_roots } + else add_assumption_with_triggers triggers + ) + + // - Partial applications are triggered with a __uu__PartialApp token; this is + // triggered on either the symbol itself or its nullary token + | App (Var "Valid", + [{tm=App (Var "ApplyTT", [{tm=FreeV (FV("__uu__PartialApp", _, _))}; term])}]) + | App (Var "Valid", + [{tm=App (Var "ApplyTT", [{tm=App(Var "__uu__PartialApp", _)}; term])}]) -> + let triggers = + match term.tm with + | FreeV(FV(token, _, _)) + | App(Var token, []) -> + if BU.ends_with token "@tok" + then [singleton token; singleton (BU.substring token 0 (String.length token - 4))] + else [singleton token] + | _ -> + [] + in + add_assumption_with_triggers triggers + + // HasType, Valid, IsTotFun, and is-Tm_arrow are so common that we exclude them as triggers + // and instead only consider the free names of the underlying terms + | App (Var "Valid", [term]) + | App (Var "HasType", [term; _]) + | App (Var "IsTotFun", [term]) + | App (Var "is-Tm_arrow", [term]) -> + add_assumption_with_triggers [free_top_level_names term] + + // Term_constr_id assumptions trigger on the free names of the underlying term + | App (Eq, [ _; {tm=App (Var "Term_constr_id", [term])}]) -> + add_assumption_with_triggers [free_top_level_names term] + + // Descend into conjunctions and collect their triggers + // Fire if any of the conjuncts have triggers that fire + | App (And, tms) -> + let t1 = List.collect triggers_of_term tms in + add_assumption_with_triggers t1 + + // Assumptions named "equation_" are encodings of F* definitions and are + // equations oriented from left to right + | App (Eq, [t0; t1]) when BU.starts_with a.assumption_name "equation_" -> + let t0 = free_top_level_names t0 in + add_assumption_with_triggers [t0] + + // Other equations and bi-implications are bidirectional + | App (Iff, [t0; t1]) + | App (Eq, [t0; t1]) -> + let t0 = free_top_level_names t0 in + let t1 = free_top_level_names t1 in + add_assumption_with_triggers [t0; t1] + + // we get many vacuous True facts; just drop them + | App (TrueOp, _) -> p + + // Oterwise, add to ambients without scanning them further + | _ -> + { p with ambients = a.assumption_name::p.ambients } + end + +// Add an assumption to the pruning state +// If the assumption has triggers, add it to the trigger map +// Otherwise, use the custom logic for ambients +let add_assumption_to_triggers (a:assumption) (p:pruning_state) (trigs:triggers_set) +: pruning_state += let p = { p with assumption_name_map = BU.psmap_add p.assumption_name_map a.assumption_name (Assume a) } in + match trigs with + | [] -> maybe_add_ambient a p + | _ -> { p with assumption_to_triggers = BU.psmap_add p.assumption_to_triggers a.assumption_name trigs } + +// Mark a trigger as reached; removing it from the trigger map +let trigger_reached (p:pruning_state) (trig:string) +: pruning_state += { p with trigger_to_assumption = BU.psmap_remove p.trigger_to_assumption trig } + +// remove one trigger from waiting triggers of aname +// if aname now has an empty set of triggers, return true, marking it as reachable/eligible +let remove_trigger_for_assumption (p:pruning_state) (trig:string) (aname:string) +: pruning_state & bool += match BU.psmap_try_find p.assumption_to_triggers aname with + | None -> + // debug (fun _ -> BU.print2 "Removing trigger %s for assumption %s---no assumption found\n" trig aname); + p, false + | Some l -> + let remaining_triggers = + l |> List.map (fun ts -> remove trig ts) + in + let eligible = BU.for_some is_empty remaining_triggers in + // debug (fun _ -> + // BU.print5 "Removing trigger %s for assumption %s---eligible? %s, original triggers %s, remaining triggers %s\n" + // trig aname (show eligible) (show l) (show remaining_triggers)); + { p with assumption_to_triggers = BU.psmap_add p.assumption_to_triggers aname remaining_triggers }, + eligible + +let rec assumptions_of_decl (d:decl) +: list assumption += match d with + | Assume a -> [a] + | Module (_, ds) -> List.collect assumptions_of_decl ds + | d -> [] + +// Add a declaration to the pruning state, updating the trigger and assumption tables +// and macro tables +let rec add_decl (d:decl) (p:pruning_state) +: pruning_state += match d with + | Assume a -> + let triggers = triggers_of_term a.assumption_term in + let p = List.fold_left (List.fold_left (add_trigger_to_assumption a)) p (List.map elems triggers) in + add_assumption_to_triggers a p triggers + | Module (_, ds) -> List.fold_left (fun p d -> add_decl d p) p ds + | DefineFun(macro, _, _, body, _) -> + let free_names = elems (free_top_level_names body) in + let p = { p with macro_freenames = BU.psmap_add p.macro_freenames macro free_names } in + p + | _ -> p + +let add_decls (ds:list decl) (p:pruning_state) +: pruning_state += List.fold_left (fun p d -> add_decl d p) p ds + +let sym = string +let reached_assumption_names = FStarC.Compiler.RBSet.rbset string + +// The main pruning algorithm is expresses as a state monad over the ctxt +type ctxt = { + p: pruning_state; + reached: reached_assumption_names; +} +let st a = ctxt -> (a & ctxt) +let get : st ctxt = fun s -> (s, s) +let put (c:ctxt) : st unit = fun _ -> ((), c) +instance st_monad: monad st = { + return= (fun (#a:Type) (x:a) -> (fun s -> (x, s)) <: st a); + ( let! ) = (fun (#a #b:Type) (m:st a) (f:a -> st b) (s:ctxt) -> + let (x, s) = m s in + f x s) +} + +// When a trigger as reached, mark it, removing it from the trigger map +let mark_trigger_reached (x:sym) +: st unit += let! ctxt = get in + put {ctxt with p=trigger_reached ctxt.p x } + +// All assumptions that are waiting on a trigger +let find_assumptions_waiting_on_trigger (x:sym) +: st (list assumption) += let! ctxt = get in + match BU.psmap_try_find ctxt.p.trigger_to_assumption x with + | None -> return [] + | Some l -> return l + +// Mark an assumption as reached, to include in the resulting pruned set +// Remove it from the assumption map, so that we don't scan it again +let reached_assumption (aname:string) +: st unit += let! ctxt = get in + let p = { ctxt.p with assumption_to_triggers = BU.psmap_remove ctxt.p.assumption_to_triggers aname } in + put {ctxt with reached=add aname ctxt.reached } + +// Remove trigger x from assumption a, and return true if a is now eligible +let remove_trigger_for (trig:sym) (a:assumption) +: st bool += let! ctxt = get in + let p, eligible = remove_trigger_for_assumption ctxt.p trig a.assumption_name in + put {ctxt with p} ;! + return eligible + +// Check if an assumption has already been reached +let already_reached (aname:string) +: st bool += let! ctxt = get in + return (mem aname ctxt.reached) + +// All assumptions that are now eligible given lids are reached +let trigger_pending_assumptions (lids:list sym) +: st (list assumption) += foldM_left + (fun acc lid -> + match! find_assumptions_waiting_on_trigger lid with + | [] -> return acc + | assumptions -> + // debug (fun _ -> BU.print2 "Found assumptions waiting on trigger %s: %s\n" lid (show <| List.map (fun a -> a.assumption_name) assumptions)); + mark_trigger_reached lid ;! + foldM_left + (fun acc assumption -> + if! remove_trigger_for lid assumption + then return (assumption::acc) + else return acc) + acc + assumptions) + [] + lids + +// The main scanning loop +let rec scan (ds:list assumption) +: st unit += let! ctxt = get in + let macro_expand (s:sym) : list sym = + match BU.psmap_try_find ctxt.p.macro_freenames s with + | None -> [s] + | Some l -> s::l + in + // Collect the free names of all assumptions and macro expand them + let new_syms = List.collect (fun a -> List.collect macro_expand (elems (assumption_free_names a))) ds in + // debug (fun _ -> + // BU.print1 ">>>Scanning %s\n" + // (ds |> List.map (fun a -> BU.format2 "%s -> [%s]" a.assumption_name (elems (assumption_free_names a) |> show)) |> String.concat "\n\t")); + + // Trigger all assumptions that are waiting on the new symbols + match! trigger_pending_assumptions new_syms with + | [] -> + // Done if no new assumptions are eligible + return () + | triggered -> + // Otherwise, mark them as reached, and scan them + let! to_scan = + foldM_left + (fun acc assumption -> + if! already_reached assumption.assumption_name + then return acc + else ( + reached_assumption assumption.assumption_name ;! + return <| assumption::acc + )) + [] + triggered + in + scan to_scan + + +let prune (p:pruning_state) (roots:list decl) +: list decl += // debug (fun _ -> BU.print_string (show p)); + // Collect all assumptions from the roots + let roots = List.collect assumptions_of_decl roots in + let init = { p; reached = empty () } in + // Scan to find all reachable assumptions + let _, ctxt = scan (roots@p.extra_roots) init in + // Collect their names + let reached_names = elems ctxt.reached in + // Map them to assumptions, together with ambients + let reached_assumptions = + List.collect + (fun name -> + match BU.psmap_try_find ctxt.p.assumption_name_map name with + | None -> [] + | Some a -> [a]) + (reached_names@p.ambients) + in + // if Options.Ext.get "debug_context_pruning" <> "" + // then ( + // BU.print1 "Retained %s assumptions\n" (show (List.length reached_assumptions)) + // ); + reached_assumptions \ No newline at end of file diff --git a/src/smtencoding/FStarC.SMTEncoding.Pruning.fsti b/src/smtencoding/FStarC.SMTEncoding.Pruning.fsti new file mode 100644 index 00000000000..0df08764ec2 --- /dev/null +++ b/src/smtencoding/FStarC.SMTEncoding.Pruning.fsti @@ -0,0 +1,62 @@ +(* + Copyright 2024 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.SMTEncoding.Pruning +(** + This module provides support for the '--ext context_pruning' feature. + + It maintains a `pruning_state`, a collection of SMT assumptions. + + Given a set of root SMT declarations, it computes the set of assumptions + "reacahable" from those roots, i.e., computing a pruning of the state to only + include the facts that are relevant to the roots. + + The way this works, roughly, is as following: + + The set of all reachable symbols is initially all the free variables of the + roots and the pruned set is empty. + + A given assumption in the context is a quantified fact of the form: + + A: forall x1...xn. {:pattern (p1; ...; pk)} Q + + This assumption A is reachable if all the free variables of the patterns + (p1;...;pk) are reachable. If so, then the free variables of Q are added to + the set of reachable symbols, A is added to the pruned set, and the process is + repeated until fixpoint, returning the pruned set. + + Enhancements to this basic idea support + - quantifiers with disjunctive patterns + - top-level non-quantified facts + - macros + - and some features that are specific to F*'s SMT encoding + + Thanks to Chris Hawblitzel and Guido Martínez for design and discussions. +*) +open FStarC.Compiler.Effect +open FStar open FStarC +open FStarC.Compiler +open FStarC.SMTEncoding.Term + +(* The main abstract type of this module, representing the set of all assumptions *) +val pruning_state : Type0 + +val init : pruning_state + +(* Adding assumptions to the pruning state *) +val add_decls (ds:list decl) (p:pruning_state) : pruning_state + +(* Pruning the state to only include the assumptions that are reachable from the roots *) +val prune (p:pruning_state) (roots:list decl) : list decl \ No newline at end of file diff --git a/src/smtencoding/FStarC.SMTEncoding.Solver.Cache.fst b/src/smtencoding/FStarC.SMTEncoding.Solver.Cache.fst new file mode 100644 index 00000000000..94f54b09444 --- /dev/null +++ b/src/smtencoding/FStarC.SMTEncoding.Solver.Cache.fst @@ -0,0 +1,160 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.SMTEncoding.Solver.Cache + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.TypeChecker.Env +open FStarC.Syntax.Syntax + +module BU = FStarC.Compiler.Util +open FStarC.Compiler.RBSet + +open FStarC.Class.Show +open FStarC.Class.Hashable + +(* import instances *) +open FStarC.Syntax.Hash {} + +instance hashable_lident : hashable Ident.lident = { + hash = (fun l -> hash (show l)); +} + +instance hashable_ident : hashable Ident.ident = { + hash = (fun i -> hash (show i)); +} + +instance hashable_binding : hashable binding = { + hash = (function + | Binding_var bv -> hash bv.sort + | Binding_lid (l, (us, t)) -> hash l `mix` hash us `mix` hash t + | Binding_univ u -> hash u); +} + +instance hashable_bv : hashable bv = { + // hash name? + hash = (fun b -> hash b.sort); +} + +instance hashable_fv : hashable fv = { + hash = (fun f -> hash f.fv_name.v); +} + +instance hashable_binder : hashable binder = { + hash = (fun b -> hash b.binder_bv); +} + +instance hashable_letbinding : hashable letbinding = { + hash = (fun lb -> hash lb.lbname `mix` hash lb.lbtyp `mix` hash lb.lbdef); +} + +instance hashable_pragma : hashable pragma = { + hash = (function + | SetOptions s -> hash 1 `mix` hash s + | ResetOptions s -> hash 2 `mix` hash s + | PushOptions s -> hash 3 `mix` hash s + | PopOptions -> hash 4 + | RestartSolver -> hash 5 + | PrintEffectsGraph -> hash 6); +} + +let rec hash_sigelt (se:sigelt) : hash_code = + hash_sigelt' se.sigel + +and hash_sigelt' (se:sigelt') : hash_code = + match se with + | Sig_inductive_typ {lid; us; params; num_uniform_params; t; mutuals; ds; injective_type_params} -> + hash 0 `mix` + hash lid `mix` + hash us `mix` + hash params `mix` + hash num_uniform_params `mix` + hash t `mix` + hash mutuals `mix` + hash ds `mix` + hash injective_type_params + | Sig_bundle {ses; lids} -> + hash 1 `mix` + (hashable_list #_ {hash=hash_sigelt}).hash ses // sigh, reusing hashable instance when we don't have an instance + `mix` hash lids + | Sig_datacon {lid; us; t; ty_lid; num_ty_params; mutuals; injective_type_params} -> + hash 2 `mix` + hash lid `mix` + hash us `mix` + hash t `mix` + hash ty_lid `mix` + hash num_ty_params `mix` + hash mutuals `mix` + hash injective_type_params + | Sig_declare_typ {lid; us; t} -> + hash 3 `mix` + hash lid `mix` + hash us `mix` + hash t + | Sig_let {lbs; lids} -> + hash 4 `mix` + hash lbs `mix` + hash lids + | Sig_assume {lid; us; phi} -> + hash 5 `mix` + hash lid `mix` + hash us `mix` + hash phi + | Sig_pragma p -> + hash 6 `mix` + hash p + | _ -> + (* FIXME: hash is not completely faithful. In particular + it ignores effect decls and hashes them the same. *) + hash 0 + +instance hashable_sigelt : hashable sigelt = { + hash = hash_sigelt; +} + +(* All that matters for the query cache. *) +instance hashable_env : hashable env = { + hash = (fun e -> + hash e.gamma `mix` + hash e.gamma_sig `mix` + hash e.proof_ns `mix` + hash e.admit + ); +} + +let query_cache_ref : ref (RBSet.t hash_code) = + BU.mk_ref (empty ()) + +let on () = + Options.query_cache () && Options.ide () + +let query_cache_add (g:env) (q:term) : unit = + if on () then ( + let h = hash (g, q) in +// BU.print1 "Adding query cache for %s\n" (show h); + query_cache_ref := add h !query_cache_ref + ) + +let try_find_query_cache (g:env) (q:term) : bool = + if on () then ( + let h = hash (g, q) in + let r = mem h !query_cache_ref in +// BU.print2 "Looked up query cache for %s, r = %s\n" (show h) (show r); + r + ) else + false diff --git a/src/smtencoding/FStarC.SMTEncoding.Solver.Cache.fsti b/src/smtencoding/FStarC.SMTEncoding.Solver.Cache.fsti new file mode 100644 index 00000000000..79b00499271 --- /dev/null +++ b/src/smtencoding/FStarC.SMTEncoding.Solver.Cache.fsti @@ -0,0 +1,26 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.SMTEncoding.Solver.Cache + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.TypeChecker.Env +open FStarC.Syntax.Syntax + +val query_cache_add (g:env) (q:term) : unit +val try_find_query_cache (g:env) (q:term) : bool diff --git a/src/smtencoding/FStarC.SMTEncoding.Solver.fst b/src/smtencoding/FStarC.SMTEncoding.Solver.fst new file mode 100644 index 00000000000..d371032b40b --- /dev/null +++ b/src/smtencoding/FStarC.SMTEncoding.Solver.fst @@ -0,0 +1,1486 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.SMTEncoding.Solver +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.SMTEncoding.Z3 +open FStarC.SMTEncoding.Term +open FStarC.Compiler.Util +open FStarC.Compiler.Hints +open FStarC.TypeChecker +open FStarC.TypeChecker.Env +open FStarC.SMTEncoding +open FStarC.SMTEncoding.ErrorReporting +open FStarC.SMTEncoding.Util +open FStarC.SMTEncoding.Env +open FStarC.Class.Show +open FStarC.Class.PP +open FStarC.Class.Hashable +open FStarC.Compiler.RBSet + +module BU = FStarC.Compiler.Util +module Env = FStarC.TypeChecker.Env +module Err = FStarC.Errors +module Print = FStarC.Syntax.Print +module Syntax = FStarC.Syntax.Syntax +module TcUtil = FStarC.TypeChecker.Util +module U = FStarC.Syntax.Util +module UC = FStarC.SMTEncoding.UnsatCore +exception SplitQueryAndRetry + +let dbg_SMTQuery = Debug.get_toggle "SMTQuery" +let dbg_SMTFail = Debug.get_toggle "SMTFail" + +(****************************************************************************) +(* Hint databases for record and replay (private) *) +(****************************************************************************) + +// The type definition is now in [FStarC.Compiler.Util], since it needs to be visible to +// both the F# and OCaml implementations. + +type z3_replay_result = either (option UC.unsat_core), error_labels +let z3_result_as_replay_result = function + | Inl l -> Inl l + | Inr (r, _) -> Inr r +let recorded_hints : ref (option hints) = BU.mk_ref None +let replaying_hints: ref (option hints) = BU.mk_ref None + +(****************************************************************************) +(* Hint databases (public) *) +(****************************************************************************) +let use_hints () = Options.use_hints () && Options.Ext.get "context_pruning" = "" +let initialize_hints_db src_filename format_filename : unit = + if Options.record_hints() then recorded_hints := Some []; + let norm_src_filename = BU.normalize_file_path src_filename in + (* + * Read the hints file into replaying_hints + * But it will only be used when use_hints is on + *) + let val_filename = Options.hint_file_for_src norm_src_filename in + begin match read_hints val_filename with + | HintsOK hints -> + let expected_digest = BU.digest_of_file norm_src_filename in + if Options.hint_info() + then begin + BU.print3 "(%s) digest is %s from %s.\n" norm_src_filename + (if hints.module_digest = expected_digest + then "valid; using hints" + else "invalid; using potentially stale hints") + val_filename + end; + replaying_hints := Some hints.hints + + | MalformedJson -> + if use_hints () then + Err.log_issue0 Err.Warning_CouldNotReadHints [ + Errors.Msg.text <| BU.format1 "Malformed JSON hints file: %s; ran without hints" + val_filename + ]; + () + + | UnableToOpen -> + if use_hints () then + Err.log_issue0 Err.Warning_CouldNotReadHints [ + Errors.Msg.text <| BU.format1 "Unable to open hints file: %s; ran without hints" + val_filename + ]; + () + end + +let finalize_hints_db src_filename :unit = + begin if Options.record_hints () then + let hints = Option.get !recorded_hints in + let hints_db = { + module_digest = BU.digest_of_file src_filename; + hints = hints + } in + let norm_src_filename = BU.normalize_file_path src_filename in + let val_filename = Options.hint_file_for_src norm_src_filename in + write_hints val_filename hints_db + end; + recorded_hints := None; + replaying_hints := None + +let with_hints_db fname f = + initialize_hints_db fname false; + let result = f () in + // for the moment, there should be no need to trap exceptions to finalize the hints db + // no cleanup needs to occur if an error occurs. + finalize_hints_db fname; + result + +(***********************************************************************************) +(* Invoking the SMT solver and extracting an error report from the model, if any *) +(***********************************************************************************) +type errors = { + error_reason:string; + error_rlimit: int; + error_fuel: int; + error_ifuel: int; + error_hint: option (list string); + error_messages: list Errors.error; +} + +let error_to_short_string err = + BU.format5 "%s (rlimit=%s; fuel=%s; ifuel=%s%s)" + err.error_reason + (show err.error_rlimit) + (show err.error_fuel) + (show err.error_ifuel) + (if Option.isSome err.error_hint then "; with hint" else "") + +let error_to_is_timeout err = + if BU.ends_with err.error_reason "canceled" + then [BU.format5 "timeout (rlimit=%s; fuel=%s; ifuel=%s; %s)" + err.error_reason + (show err.error_rlimit) + (show err.error_fuel) + (show err.error_ifuel) + (if Option.isSome err.error_hint then "with hint" else "")] + else [] + +type query_settings = { + query_env:env_t; + query_decl:decl; + query_name:string; + query_index:int; + query_range:Range.range; + query_fuel:int; + query_ifuel:int; + query_rlimit:int; + query_hint:option UC.unsat_core; + query_errors:list errors; + query_all_labels:error_labels; + query_suffix:list decl; + query_hash:option string; + query_can_be_split_and_retried:bool; + query_term: FStarC.Syntax.Syntax.term; +} + +(* Translation from F* rlimit units to Z3 rlimit units. + +This used to be defined as exactly 544656 since that roughtly +corresponded to 5 seconds in some "blessed" setting. But rlimit units +are only very roughly correlated to time, and having this very non-round +number makes reading SMT query dumps pretty confusing. So, for new +solvers, we now just make it 500k. *) +let convert_rlimit (r : int) : int = + let open FStar.Mul in + if Misc.version_ge (Options.z3_version ()) "4.12.3" then + 500000 * r + else + 544656 * r + +//surround the query with fuel options and various diagnostics +let with_fuel_and_diagnostics settings label_assumptions = + let n = settings.query_fuel in + let i = settings.query_ifuel in + let rlimit = convert_rlimit settings.query_rlimit in + [ //fuel and ifuel settings + Term.Caption (BU.format2 "" + (string_of_int n) + (string_of_int i)); + Util.mkAssume(mkEq(mkApp("MaxFuel", []), n_fuel n), None, "@MaxFuel_assumption"); + Util.mkAssume(mkEq(mkApp("MaxIFuel", []), n_fuel i), None, "@MaxIFuel_assumption"); + settings.query_decl //the query itself + ] + @label_assumptions //the sub-goals that are currently disabled + @[ Term.SetOption ("rlimit", string_of_int rlimit); //the rlimit setting for the check-sat + Term.CheckSat; //go Z3! + Term.SetOption ("rlimit", "0"); //back to using infinite rlimit + Term.GetReasonUnknown; //explain why it failed + Term.GetUnsatCore; //for proof profiling, recording hints etc + ] + @(if (Options.print_z3_statistics() || + Options.query_stats ()) then [Term.GetStatistics] else []) //stats + @settings.query_suffix //recover error labels and a final "Done!" message + + +let used_hint s = Option.isSome s.query_hint + +let get_hint_for qname qindex = + match !replaying_hints with + | Some hints -> + BU.find_map hints (function + | Some hint when hint.hint_name=qname && hint.hint_index=qindex -> Some hint + | _ -> None) + | _ -> None + +let query_errors settings z3result = + match z3result.z3result_status with + | UNSAT _ -> None + | _ -> + let msg, error_labels = Z3.status_string_and_errors z3result.z3result_status in + let err = { + error_reason = msg; + error_rlimit = settings.query_rlimit; + error_fuel = settings.query_fuel; + error_ifuel = settings.query_ifuel; + error_hint = settings.query_hint; + error_messages = + error_labels |> + List.map (fun (_, x, y) -> Errors.Error_Z3SolverError, + x, + y, + Errors.get_ctx ()) // FIXME: leaking abstraction + } + in + Some err + +let detail_hint_replay settings z3result = + if used_hint settings + && Options.detail_hint_replay () + then match z3result.z3result_status with + | UNSAT _ -> () + | _failed -> + let ask_z3 label_assumptions = + Z3.ask settings.query_range + // (filter_assertions settings.query_env (Some settings) settings.query_hint) + settings.query_hash + settings.query_all_labels + (with_fuel_and_diagnostics settings label_assumptions) + (BU.format2 "(%s, %s)" settings.query_name (string_of_int settings.query_index)) + false + None + // settings.query_hint + in + detail_errors true settings.query_env.tcenv settings.query_all_labels ask_z3 + +let find_localized_errors (errs : list errors) : option errors = + errs |> List.tryFind (fun err -> match err.error_messages with [] -> false | _ -> true) + +let errors_to_report (tried_recovery : bool) (settings : query_settings) : list Errors.error = + let open FStarC.Pprint in + let open FStarC.Errors in + let format_smt_error (msg:list document) : list document = + (* This creates an error component with the answers from Z3. Only used + for --query_stats. *) + let d = + doc_of_string "SMT solver says:" ^^ + sublist empty msg ^^ + hardline ^^ + doc_of_string "Note:" ^^ + bulleted [ + text "'canceled' or 'resource limits reached' means the SMT query timed out, so you might want to increase the rlimit"; + text "'incomplete quantifiers' means Z3 could not prove the query, so try to spell out your proof out in greater detail, increase fuel or ifuel"; + text "'unknown' means Z3 provided no further reason for the proof failing" + ] + in + [d] // single error component + in + let recovery_failed_msg : Errors.error_message = + if tried_recovery then + [text "This query was retried due to the --proof_recovery option, yet it + still failed on all attempts."] + else + [] + in + let basic_errors = + (* + * smt_error is a single error message containing either a multi-line detailed message + * or a single short component, depending on whether --query_stats is on + *) + let smt_error = + if Options.query_stats () then + settings.query_errors + |> List.map error_to_short_string + |> List.map doc_of_string + |> format_smt_error + else + (* + * AR: --query_stats is not set, we want to give a succint but helpful diagnosis + * + * settings.query_errors is a list of errors, whose field error_reason contains the strings: + * unknown because (incomplete ...) or unknown because (resource ...) or unknown because canceled etc. + * it's a list as it contains one element per config (e.g. fuel options) + * + * in the following code we go through the error reasons in all the configs, + * and if all the error reasons are the same, we provide a hint for that reason + * otherwise we just ask the user to run with --query_stats + * + * as per the smt-lib standard, the possible values of reason-unknown are s-expressions, + * that are either non-space strings, or strings with spaces enclosed in parenthesis + * (I think), so incomplete or resource messages are in parenthesis, whereas + * canceled, timeout, etc. are without + *) + let incomplete_count, canceled_count, unknown_count, z3_overflow_bug_count = + List.fold_left (fun (ic, cc, uc, bc) err -> + let err = BU.substring_from err.error_reason (String.length "unknown because ") in + //err is (incomplete quantifiers), (resource ...), canceled, or unknown etc. + + match () with + | _ when BU.starts_with err "(incomplete" -> + (ic + 1, cc, uc, bc) + | _ when BU.starts_with err "canceled" || BU.starts_with err "(resource" || BU.starts_with err "timeout" -> + (ic, cc + 1, uc, bc) + | _ when BU.starts_with err "Overflow encountered when expanding old_vector" -> + (ic, cc, uc, bc + 1) + | _ -> + (ic, cc, uc + 1, bc) //note this covers unknowns, overflows, etc. + ) (0, 0, 0, 0) settings.query_errors + in + (* If we notice the z3 overflow bug, add a separate error to warn the user. *) + if z3_overflow_bug_count > 0 then + Errors.log_issue settings.query_range Errors.Warning_UnexpectedZ3Stderr [ + text "Z3 ran into an internal overflow while trying to prove this query."; + text "Try breaking it down, or using --split_queries." + ]; + let base = + match incomplete_count, canceled_count, unknown_count with + | _, 0, 0 when incomplete_count > 0 -> [text "The SMT solver could not prove the query. Use --query_stats for more details."] + | 0, _, 0 when canceled_count > 0 -> [text "The SMT query timed out, you might want to increase the rlimit"] + | _, _, _ -> [text "Try with --query_stats to get more details"] + in + base @ recovery_failed_msg + in + match find_localized_errors settings.query_errors, settings.query_all_labels with + | Some err, _ -> + // FStarC.Errors.log_issue settings.query_range (FStarC.Errors.Warning_SMTErrorReason, smt_error); + FStarC.TypeChecker.Err.errors_smt_detail settings.query_env.tcenv err.error_messages smt_error + + | None, [(_, msg, rng)] -> + //we have a unique label already; just report it + FStarC.TypeChecker.Err.errors_smt_detail + settings.query_env.tcenv + [(Error_Z3SolverError, msg, rng, get_ctx())] + recovery_failed_msg + + | None, _ -> + //We didn't get a useful countermodel from Z3 to localize an error + //so, split the query into N unique queries and try again + if settings.query_can_be_split_and_retried + then raise SplitQueryAndRetry + else ( + //if it can't be split further, report all its labels as potential failures + //typically there will be only 1 label + let l = List.length settings.query_all_labels in + let labels = + if l = 0 + then ( + //this should really never happen, but if it does, we have a query + //with no labeled sub-goals and so no error location to report. + //So, print the source location and the query term itself + let dummy_fv = Term.mk_fv ("", dummy_sort) in + let msg = [ + Errors.Msg.text "Failed to prove the following goal, although it appears to be trivial:" + ^/^ pp settings.query_term; + ] + in + let range = Env.get_range settings.query_env.tcenv in + [dummy_fv, msg, range] + ) + else if l > 1 + then ( + //we have a non-unique label despite splitting + //this CAN happen, e.g., if the original query term is a `match` + //In this case, we couldn't split it and then if it fails without producing a model, + //we blame all the labels in the query. So warn about the imprecision, unless the + //use opted into --split_queries no. + if Options.split_queries () <> Options.No then + FStarC.TypeChecker.Err.log_issue_text + settings.query_env.tcenv + (Env.get_range settings.query_env.tcenv) + (Warning_SplitAndRetryQueries, + "The verification condition was to be split into several atomic sub-goals, \ + but this query has multiple sub-goals---the error report may be inaccurate"); + settings.query_all_labels + ) + else settings.query_all_labels + in + labels |> + List.collect (fun (_, msg, rng) -> + FStarC.TypeChecker.Err.errors_smt_detail + settings.query_env.tcenv + [(Error_Z3SolverError, msg, rng, get_ctx())] + recovery_failed_msg + ) + ) + in + let detailed_errors : unit = + if Options.detail_errors() + then let initial_fuel = { + settings with query_fuel=Options.initial_fuel(); + query_ifuel=Options.initial_ifuel(); + query_hint=None + } + in + let ask_z3 label_assumptions = + Z3.ask settings.query_range + // (filter_using_facts_from settings.query_env settings.query_pruned_context) + settings.query_hash + settings.query_all_labels + (with_fuel_and_diagnostics initial_fuel label_assumptions) + (BU.format2 "(%s, %s)" settings.query_name (string_of_int settings.query_index)) + false + None + in + (* GM: This is a bit of hack, we don't return these detailed errors + * (it implies rewriting detail_errors heavily). Returning them + * is only relevant for summarizing errors on --quake, where I don't + * think we care about these. *) + detail_errors false settings.query_env.tcenv settings.query_all_labels ask_z3 + in + basic_errors + +let report_errors tried_recovery qry_settings = + FStarC.Errors.add_errors (errors_to_report tried_recovery qry_settings) + + +type unique_string_accumulator = { + add: string -> unit; + get: unit -> list string; + clear: unit -> unit +} + +(* A generic accumulator of unique strings, + extracted in sorted order *) +let mk_unique_string_accumulator () +: unique_string_accumulator += let strings = BU.mk_ref [] in + let add m = + let ms = !strings in + if List.contains m ms then () + else strings := m :: ms + in + let get () = + !strings |> BU.sort_with String.compare + in + let clear () = strings := [] in + { add ; get; clear } + +let query_info settings z3result = + let process_unsat_core (core:option UC.unsat_core) = + (* Accumulator for module names *) + let { add=add_module_name; get=get_module_names } = + mk_unique_string_accumulator () + in + let add_module_name s = + add_module_name s + in + (* Accumulator for discarded names *) + let { add=add_discarded_name; get=get_discarded_names } = + mk_unique_string_accumulator () + in + (* SMT Axioms are named using an ad hoc naming convention + that includes the F* source name within it. + + This function reversed the naming convention to extract + the source name of the F* entity from `s`, an axiom name + mentioned in an unsat core (but also in smt.qi.profile, etc.) + + The basic structure of the name is + + + + So, the code below strips off the + and any of the reserved suffixes. + + What's left is an F* name, which can be decomposed as usual + into a module name + a top-level identifier + *) + let parse_axiom_name (s:string) = + // BU.print1 "Parsing axiom name <%s>\n" s; + let chars = String.list_of_string s in + let first_upper_index = + BU.try_find_index BU.is_upper chars + in + match first_upper_index with + | None -> + //Has no embedded F* name (discard it, and record it in the discarded set) + add_discarded_name s; + [] + | Some first_upper_index -> + let name_and_suffix = BU.substring_from s first_upper_index in + let components = String.split ['.'] name_and_suffix in + let excluded_suffixes = + [ "fuel_instrumented"; + "_pretyping"; + "_Tm_refine"; + "_Tm_abs"; + "@"; + "_interpretation_Tm_arrow"; + "MaxFuel_assumption"; + "MaxIFuel_assumption"; + ] + in + let exclude_suffix s = + let s = BU.trim_string s in + let sopt = + BU.find_map + excluded_suffixes + (fun sfx -> + if BU.contains s sfx + then Some (List.hd (BU.split s sfx)) + else None) + in + match sopt with + | None -> if s = "" then [] else [s] + | Some s -> if s = "" then [] else [s] + in + let components = + match components with + | [] -> [] + | _ -> + let lident, last = BU.prefix components in + let components = lident @ exclude_suffix last in + let module_name = components |> BU.prefix_until (fun s -> not <| BU.is_upper (BU.char_at s 0)) in + let _ = + match module_name with + | None -> () + | Some (m, _, _) -> add_module_name (String.concat "." m) + in + components + in + if components = [] + then (add_discarded_name s; []) + else [ components |> String.concat "."] + in + let should_log = Options.hint_info () || Options.query_stats () in + let maybe_log (f:unit -> unit) = if should_log then f () in + match core with + | None -> + maybe_log <| (fun _ -> BU.print_string "no unsat core\n") + | Some core -> + let core = List.collect parse_axiom_name core in + maybe_log <| (fun _ -> + BU.print1 "Z3 Proof Stats: Modules relevant to this proof:\nZ3 Proof Stats:\t%s\n" + (get_module_names() |> String.concat "\nZ3 Proof Stats:\t"); + BU.print1 "Z3 Proof Stats (Detail 1): Specifically:\nZ3 Proof Stats (Detail 1):\t%s\n" + (String.concat "\nZ3 Proof Stats (Detail 1):\t" core); + BU.print1 "Z3 Proof Stats (Detail 2): Note, this report ignored the following names in the context: %s\n" + (get_discarded_names() |> String.concat ", ")) + in + if Options.hint_info() + || Options.query_stats() + then begin + let status_string, errs = Z3.status_string_and_errors z3result.z3result_status in + let at_log_file = + match z3result.z3result_log_file with + | None -> "" + | Some s -> "@"^s + in + let tag, core = match z3result.z3result_status with + | UNSAT core -> BU.colorize_green "succeeded", core + | _ -> BU.colorize_red ("failed {reason-unknown=" ^ status_string ^ "}"), None + in + let range = "(" ^ show settings.query_range ^ at_log_file ^ ")" in + let used_hint_tag = if used_hint settings then " (with hint)" else "" in + let stats = + if Options.query_stats() then + let f k v a = a ^ k ^ "=" ^ v ^ " " in + let str = smap_fold z3result.z3result_statistics f "statistics={" in + (substring str 0 ((String.length str) - 1)) ^ "}" + else "" in + BU.print "%s\tQuery-stats (%s, %s)\t%s%s in %s milliseconds with fuel %s and ifuel %s and rlimit %s\n" + [ range; + settings.query_name; + show settings.query_index; + tag; + used_hint_tag; + show z3result.z3result_time; + show settings.query_fuel; + show settings.query_ifuel; + show (settings.query_rlimit); + // stats + ]; + if Options.print_z3_statistics () then process_unsat_core core; + errs |> List.iter (fun (_, msg, range) -> + let msg = if used_hint settings then Pprint.doc_of_string "Hint-replay failed" :: msg else msg in + FStarC.Errors.log_issue range FStarC.Errors.Warning_HitReplayFailed msg) + end + else if Options.Ext.get "profile_context" <> "" + then match z3result.z3result_status with + | UNSAT core -> process_unsat_core core + | _ -> () + +//caller must ensure that the recorded_hints is already initiailized +let store_hint hint = + match !recorded_hints with + | Some l -> recorded_hints := Some (l@[Some hint]) + | _ -> assert false; () + +let record_hint settings z3result = + if not (Options.record_hints()) then () else + begin + let mk_hint core = { + hint_name=settings.query_name; + hint_index=settings.query_index; + fuel=settings.query_fuel; + ifuel=settings.query_ifuel; + unsat_core=core; + query_elapsed_time=0; //recording the elapsed_time prevents us from reaching a fixed point + hash=(match z3result.z3result_status with + | UNSAT core -> z3result.z3result_query_hash + | _ -> None) + } + in + match z3result.z3result_status with + | UNSAT None -> + // we succeeded by just matching a query hash + store_hint (Option.get (get_hint_for settings.query_name settings.query_index)) + | UNSAT unsat_core -> + if used_hint settings //if we already successfully use a hint + then //just re-use the successful hint, but record the hash of the pruned theory + store_hint (mk_hint settings.query_hint) + else store_hint (mk_hint unsat_core) //else store the new unsat core + | _ -> () //the query failed, so nothing to do + end + +let process_result settings result : option errors = + let errs = query_errors settings result in + query_info settings result; + record_hint settings result; + detail_hint_replay settings result; + errs + +// Attempts to solve each query setting (in `qs`) sequentially until +// one succeeds. If one succeeds, we are done and report no errors. If +// all of them fail, we return the list of errors so they can be displayed +// to the user later. +// Returns Inr cfg if successful, with the succeeding config cfg +// and Inl errs if all options were exhausted +// without a success, where errs is the list of errors each query +// returned. +let fold_queries (qs:list query_settings) + (ask:query_settings -> z3result) + (f:query_settings -> z3result -> option errors) + : either (list errors) query_settings = + let rec aux (acc : list errors) qs : either (list errors) query_settings = + match qs with + | [] -> Inl acc + | q::qs -> + let res = ask q in + begin match f q res with + | None -> Inr q //done + | Some errs -> + aux (errs::acc) qs + end + in + aux [] qs + +let full_query_id settings = + "(" ^ settings.query_name ^ ", " ^ (BU.string_of_int settings.query_index) ^ ")" + +let collect_dups (l : list 'a) : list ('a & int) = + let acc : list ('a & int) = [] in + let rec add_one acc x = + match acc with + | [] -> [(x, 1)] + | (h, n)::t -> + if h = x + then (h, n+1)::t + else (h, n) :: add_one t x + in + List.fold_left add_one acc l + + +(* An answer for an "ask" to the solver. The ok boolean marks whether +it succeeded or not. The rest is only used for error reporting. *) +type answer = { + ok : bool; + (* ^ Query was proven *) + cache_hit : bool; + (* ^ Got result from cache. Currently, this also implies + ok=true (we don't cache failed queries), but don't count + on it. *) + + quaking : bool; + (* ^ Were we quake testing? *) + quaking_or_retrying : bool; + (* ^ Were we quake testing *or* retrying? *) + lo : int; + (* ^ Lower quake bound. *) + hi : int; + (* ^ Higher quake bound. *) + nsuccess : int; + (* ^ Number of successful attempts. Can be >1 when quaking. *) + total_ran : int; + (* ^ Total number of queries made. *) + tried_recovery : bool; + (* ^ Did we try using --proof_recovery for this? *) + + errs : list (list errors); // mmm... list list? + (* ^ Errors from SMT solver. *) +} + +let ans_ok : answer = { + ok = true; + cache_hit = false; + nsuccess = 1; + lo = 1; + hi = 1; + errs = []; + quaking = false; + quaking_or_retrying = false; + total_ran = 1; + tried_recovery = false; +} + +let ans_fail : answer = + { ans_ok with ok = false; nsuccess = 0 } + +instance _ : showable answer = { + show = (fun ans -> BU.format5 "ok=%s nsuccess=%s lo=%s hi=%s tried_recovery=%s" + (show ans.ok) + (show ans.nsuccess) + (show ans.lo) + (show ans.hi) + (show ans.tried_recovery)); +} + +let make_solver_configs + (can_split : bool) + (is_retry : bool) + (env : env_t) + (all_labels : error_labels) + // (prefix : list decl) + (query : decl) + (query_term : Syntax.term) + (suffix : list decl) + : (list query_settings & option hint) + = + (* Fetch the settings. *) + let default_settings, next_hint = + let qname, index = + match env.tcenv.qtbl_name_and_index with + | None, _ -> failwith "No query name set!" + | Some (q, _typ, n), _ -> Ident.string_of_lid q, n + in + let rlimit = + let open FStar.Mul in + Options.z3_rlimit_factor () * Options.z3_rlimit () + in + let next_hint = get_hint_for qname index in + let default_settings = { + query_env=env; + query_decl=query; + query_name=qname; + query_index=index; + query_range=Env.get_range env.tcenv; + query_fuel=Options.initial_fuel(); + query_ifuel=Options.initial_ifuel(); + query_rlimit=rlimit; + query_hint=None; + query_errors=[]; + query_all_labels=all_labels; + query_suffix=suffix; + query_hash=(match next_hint with + | None -> None + | Some {hash=h} -> h); + query_can_be_split_and_retried=can_split; + query_term=query_term; + } in + default_settings, next_hint + in + + (* Fetch hints, if any. *) + let use_hints_setting = + if use_hints () && next_hint |> is_some + then + let ({unsat_core=Some core; fuel=i; ifuel=j; hash=h}) = next_hint |> must in + [{default_settings with query_hint=Some core; + query_fuel=i; + query_ifuel=j}] + else [] + in + + let initial_fuel_max_ifuel = + if Options.max_ifuel() > Options.initial_ifuel() + then [{default_settings with query_ifuel=Options.max_ifuel()}] + else [] + in + + let half_max_fuel_max_ifuel = + if Options.max_fuel() / 2 > Options.initial_fuel() + then [{default_settings with query_fuel=Options.max_fuel() / 2; + query_ifuel=Options.max_ifuel()}] + else [] + in + + let max_fuel_max_ifuel = + if Options.max_fuel() > Options.initial_fuel() + && Options.max_ifuel() >= Options.initial_ifuel() + then [{default_settings with query_fuel=Options.max_fuel(); + query_ifuel=Options.max_ifuel()}] + else [] + in + let cfgs = + if is_retry + then [default_settings] + else + use_hints_setting + @ [default_settings] + @ initial_fuel_max_ifuel + @ half_max_fuel_max_ifuel + @ max_fuel_max_ifuel + in + (cfgs, next_hint) + +(* Returns Inl with errors, or Inr with the stats provided by the solver. +Not to be used directly, see ask_solver below. *) +let __ask_solver + (configs : list query_settings) + : either (list errors) query_settings + = + let check_one_config config : z3result = + if Options.z3_refresh() + then ( + Z3.refresh (Some config.query_env.tcenv.proof_ns) + ); + Z3.ask config.query_range + config.query_hash + config.query_all_labels + (with_fuel_and_diagnostics config []) + (BU.format2 "(%s, %s)" config.query_name (string_of_int config.query_index)) + (used_hint config) + config.query_hint + in + + fold_queries configs check_one_config process_result + +(* Ask a query to the solver, running it potentially multiple times +if --quake is specified. This function is always called, but when +--quake is off, it's really just a call to __ask_solver (and then +creating an [answer] record). *) +let ask_solver_quake + (configs : list query_settings) + : answer + = + let lo = Options.quake_lo () in + let hi = Options.quake_hi () in + let seed = Options.z3_seed () in + + let default_settings = List.hd configs in + let name = full_query_id default_settings in + let quaking = hi > 1 && not (Options.retry ()) in + let quaking_or_retrying = hi > 1 in + let hi = if hi < 1 then 1 else hi in + let lo = + if lo < 1 then 1 + else if lo > hi then hi + else lo + in + let run_one (seed:int) : either (list errors) query_settings = + (* Here's something annoying regarding --quake: + * + * In normal circumstances, we can just run the query again and get + * a slightly different behaviour because of Z3 accumulating some + * internal state that doesn't get erased on a (pop). So we simply repeat + * the query then. + * + * But, if we're doing --z3refresh, we will always get the exact + * same behaviour by doing that, so we do want to set the seed in this case. + * + * Why not always set it? Because it requires restarting the solver, which + * takes a long time. + * + * Why not use the (set-option smt.random_seed ..) command? Because + * it seems to have no effect just before a (check-sat), so it needs to be + * set early, which basically implies restarting. + * + * So we do this horrendous thing. + *) + if Options.z3_refresh () + then Options.with_saved_options (fun () -> + Options.set_option "z3seed" (Options.Int seed); + __ask_solver configs) + else __ask_solver configs + in + let rec fold_nat' (f : 'a -> int -> 'a) (acc : 'a) (lo : int) (hi : int) : 'a = + if lo > hi + then acc + else fold_nat' f (f acc lo) (lo + 1) hi + in + let best_fuel = BU.mk_ref None in + let best_ifuel = BU.mk_ref None in + let maybe_improve (r:ref (option int)) (n:int) : unit = + match !r with + | None -> r := Some n + | Some m -> if n < m then r := Some n + in + let nsuccess, nfailures, rs = + fold_nat' + (fun (nsucc, nfail, rs) n -> + if not (Options.quake_keep ()) + && (nsucc >= lo (* already have enough successes *) + || nfail > hi-lo) (* already have too many failures *) + then (nsucc, nfail, rs) + else begin + if quaking_or_retrying + && (Options.interactive () || Debug.any ()) (* only on emacs or when debugging *) + && n>0 then (* no need to print last *) + BU.print5 "%s: so far query %s %sfailed %s (%s runs remain)\n" + (if quaking then "Quake" else "Retry") + name + (if quaking then BU.format1 "succeeded %s times and " (string_of_int nsucc) else "") + (* ^ if --retrying, it does not make sense to print successes since + * they must be exactly 0 *) + (if quaking then string_of_int nfail else string_of_int nfail ^ " times") + (string_of_int (hi-n)); + let r = run_one (seed+n) in + let nsucc, nfail = + match r with + | Inr cfg -> + (* Maybe update best fuels that worked. *) + maybe_improve best_fuel cfg.query_fuel; + maybe_improve best_ifuel cfg.query_ifuel; + nsucc + 1, nfail + | _ -> nsucc, nfail+1 + in + (nsucc, nfail, r::rs) + end) + (0, 0, []) 0 (hi-1) + in + let total_ran = nsuccess + nfailures in + + (* Print a diagnostic for --quake *) + if quaking then begin + let fuel_msg = + match !best_fuel, !best_ifuel with + | Some f, Some i -> + BU.format2 " (best fuel=%s, best ifuel=%s)" (string_of_int f) (string_of_int i) + | _, _ -> "" + in + BU.print5 "Quake: query %s succeeded %s/%s times%s%s\n" + name + (string_of_int nsuccess) + (string_of_int total_ran) + (if total_ran < hi then " (early finish)" else "") + fuel_msg + end; + let all_errs = List.concatMap (function | Inr _ -> [] + | Inl es -> [es]) rs + in + (* Return answer *) + { ok = nsuccess >= lo + ; cache_hit = false + ; nsuccess = nsuccess + ; lo = lo + ; hi = hi + ; errs = all_errs + ; total_ran = total_ran + ; quaking_or_retrying = quaking_or_retrying + ; quaking = quaking + ; tried_recovery = false (* possibly set by caller *) + } + +(* A very simple command language for recovering, though keep in +mind its execution is stateful in the sense that anything after a +(RestartSolver h) will run in the new solver instance. *) +type recovery_hammer = + | IncreaseRLimit of (*factor : *)int + | RestartAnd of recovery_hammer + +let rec pp_hammer (h : recovery_hammer) : Pprint.document = + let open FStarC.Errors.Msg in + let open FStarC.Pprint in + match h with + | IncreaseRLimit factor -> + text "increasing its rlimit by" ^/^ pp factor ^^ doc_of_string "x" + | RestartAnd h -> + text "restarting the solver and" ^/^ pp_hammer h + +(* If --proof_recovery is on, then we retry the query multiple +times, increasing rlimits, until we get a success. If not, we just +call ask_solver_quake. *) +let ask_solver_recover + (configs : list query_settings) + : answer + = + let open FStarC.Pprint in + let open FStarC.Errors.Msg in + let open FStarC.Class.PP in + if Options.proof_recovery () then ( + let r = ask_solver_quake configs in + if r.ok then r else ( + let restarted = BU.mk_ref false in + let cfg = List.last configs in + + Errors.diag cfg.query_range [ + text "This query failed to be solved. Will now retry with higher rlimits due to --proof_recovery."; + ]; + + let try_factor (n:int) : answer = + let open FStar.Mul in + Errors.diag cfg.query_range [text "Retrying query with rlimit factor" ^/^ pp n]; + let cfg = { cfg with query_rlimit = n * cfg.query_rlimit } in + ask_solver_quake [cfg] + in + + let rec try_hammer (h : recovery_hammer) : answer = + match h with + | IncreaseRLimit factor -> try_factor factor + | RestartAnd h -> + Errors.diag cfg.query_range [text "Trying a solver restart"]; + cfg.query_env.tcenv.solver.refresh (Some cfg.query_env.tcenv.proof_ns); + try_hammer h + in + + let rec aux (hammers : list recovery_hammer) : answer = + match hammers with + | [] -> { r with tried_recovery = true } + | h::hs -> + let r = try_hammer h in + if r.ok then ( + Errors.log_issue cfg.query_range Errors.Warning_ProofRecovery [ + text "This query succeeded after " ^/^ pp_hammer h; + text "Increase the rlimit in the file or simplify the proof. \ + This is only succeeding due to --proof_recovery being given." + ]; + r + ) else + aux hs + in + aux [ + IncreaseRLimit 2; + IncreaseRLimit 4; + IncreaseRLimit 8; + RestartAnd (IncreaseRLimit 8); + ] + ) + ) else + ask_solver_quake configs + +let failing_query_ctr : ref int = BU.mk_ref 0 + +let maybe_save_failing_query (env:env_t) (qs:query_settings) : unit = + (* Save failing query to a clean file if --log_failing_queries. *) + if Options.log_failing_queries () then ( + let mod = show (Env.current_module env.tcenv) in + let n = (failing_query_ctr := !failing_query_ctr + 1; !failing_query_ctr) in + let file_name = BU.format2 "failedQueries-%s-%s.smt2" mod (show n) in + let query_str = Z3.ask_text + qs.query_range + // (filter_assertions qs.query_env None qs.query_hint) + qs.query_hash + qs.query_all_labels + (with_fuel_and_diagnostics qs []) + (BU.format2 "(%s, %s)" qs.query_name (string_of_int qs.query_index)) + qs.query_hint + in + write_file file_name query_str; + () + ); + (* Also print it out if --debug SMTFail. *) + if !dbg_SMTFail then ( + let open FStarC.Pprint in + let open FStarC.Class.PP in + let open FStarC.Errors.Msg in + Errors.diag qs.query_range [ + text "This query failed:"; + pp qs.query_term; + ] + ); + () + +let ask_solver + (env : FStarC.SMTEncoding.Env.env_t) + // (prefix : list decl) + (configs: list query_settings) + (next_hint : option hint) + : list query_settings & answer + = (* The default config is at the head. We distinguish this one since + it includes some metadata that we need, such as the query name, etc. + (Though all other configs also contain it.) *) + let default_settings = List.hd configs in + let skip : bool = + env.tcenv.admit || + Env.too_early_in_prims env.tcenv || + (match Options.admit_except () with + | Some id -> + if BU.starts_with id "(" + then full_query_id default_settings <> id + else default_settings.query_name <> id + | None -> false) + in + let ans = + if skip + then ( + if Options.record_hints () && next_hint |> is_some then + //restore the hint as is, cf. #1651 + next_hint |> must |> store_hint; + ans_ok + ) else ( + // Feed the context of the query to the solver. We do this only + // once for every VC. Every actual query will push and pop + // whatever else they encode. + // Z3.giveZ3 prefix; + let ans = ask_solver_recover configs in + let cfg = List.last configs in + if not ans.ok then + maybe_save_failing_query env cfg; + ans + + ) + in + configs, ans + +(* Reports query errors to the user. The errors are logged, not raised. *) +let report (env:Env.env) (default_settings : query_settings) (a : answer) : unit = + let nsuccess = a.nsuccess in + let name = full_query_id default_settings in + let lo = a.lo in + let hi = a.hi in + let total_ran = a.total_ran in + let all_errs = a.errs in + let quaking_or_retrying = a.quaking_or_retrying in + let quaking = a.quaking in + (* If nsuccess < lo, we have a failure. We report summarized + * information if doing --quake (and not --query_stats) *) + if nsuccess < lo then begin + if quaking_or_retrying && not (Options.query_stats ()) then begin + let errors_to_report errs = + errors_to_report a.tried_recovery ({default_settings with query_errors=errs}) + in + + (* Obtain all errors that would have been reported *) + let errs = List.map errors_to_report all_errs in + (* Summarize them *) + let errs = errs |> List.flatten |> collect_dups in + (* Show the amount on each error *) + let errs = errs |> List.map (fun ((e, m, r, ctx), n) -> + let m = + let open FStarC.Pprint in + if n > 1 + then m @ [doc_of_string (format1 "Repeated %s times" (string_of_int n))] + else m + in + (e, m, r, ctx)) + in + (* Now report them *) + FStarC.Errors.add_errors errs; + + (* Adding another explanatory error for the threshold if --quake is on + * (but not for --retry) *) + if quaking then begin + (* Get the range of the lid we're checking for the quake error *) + let rng = match fst (env.qtbl_name_and_index) with + | Some (l, _, _) -> Ident.range_of_lid l + | _ -> Range.dummyRange + in + FStarC.TypeChecker.Err.log_issue + env rng + (Errors.Error_QuakeFailed, [ + Errors.text <| + BU.format6 + "Query %s failed the quake test, %s out of %s attempts succeded, \ + but the threshold was %s out of %s%s" + name + (string_of_int nsuccess) + (string_of_int total_ran) + (string_of_int lo) + (string_of_int hi) + (if total_ran < hi then " (early abort)" else "")]) + end + + end else begin + (* Not quaking, or we have --query_stats: just report all errors as usual *) + let report errs = report_errors a.tried_recovery ({default_settings with query_errors=errs}) in + List.iter report all_errs + end + end + +(* This type represents the configuration under which the solver was +_started_. If anything changes, the solver should be restarted for these +settings to take effect. See `maybe_refresh` below. *) +type solver_cfg = { + seed : int; + cliopt : list string; + smtopt : list string; + facts : list (list string & bool); + valid_intro : bool; + valid_elim : bool; + z3version : string; + context_pruning : bool +} + +let _last_cfg : ref (option solver_cfg) = BU.mk_ref None + +let get_cfg env : solver_cfg = + { seed = Options.z3_seed () + ; cliopt = Options.z3_cliopt () + ; smtopt = Options.z3_smtopt () + ; facts = env.proof_ns + ; valid_intro = Options.smtencoding_valid_intro () + ; valid_elim = Options.smtencoding_valid_elim () + ; z3version = Options.z3_version () + ; context_pruning = Options.Ext.get "context_pruning" <> "" + } + +let save_cfg env = + _last_cfg := Some (get_cfg env) + +(* If the the solver's configuration has changed, then restart it so +it can take on the new values. *) +let maybe_refresh_solver env = + match !_last_cfg with + | None -> save_cfg env + | Some cfg -> + if cfg <> get_cfg env then ( + save_cfg env; + Z3.refresh (Some env.proof_ns) + ) + +let finally (h : unit -> unit) (f : unit -> 'a) : 'a = + let r = + try f () with + | e -> h(); raise e + in + h (); r + +(* The query_settings list is non-empty unless the query was trivial. *) +let encode_and_ask (can_split:bool) (is_retry:bool) use_env_msg tcenv q : (list query_settings & answer) = + let do () : list query_settings & answer = + maybe_refresh_solver tcenv; + let msg = (BU.format1 "Starting query at %s" (Range.string_of_range <| Env.get_range tcenv)) in + Encode.push_encoding_state msg; + let prefix, labels, qry, suffix = Encode.encode_query use_env_msg tcenv q in + Z3.start_query msg prefix qry; + let finish_query () = + let msg = (BU.format1 "Ending query at %s" (Range.string_of_range <| Env.get_range tcenv)) in + Encode.pop_encoding_state msg; + Z3.finish_query msg + in + finally finish_query (fun () -> + let tcenv = incr_query_index tcenv in + match qry with + (* trivial cases *) + | Assume({assumption_term={tm=App(FalseOp, _)}}) -> ([], ans_ok) + | _ when tcenv.admit -> ([], ans_ok) + + | Assume _ -> + if (is_retry || Options.split_queries() = Options.Always) + && Debug.any() + then ( + let n = List.length labels in + if n <> 1 + then + FStarC.Errors.diag + (Env.get_range tcenv) + (BU.format3 "Encoded split query %s\nto %s\nwith %s labels" + (show q) + (Term.declToSmt "" qry) + (BU.string_of_int n)) + ); + let env = FStarC.SMTEncoding.Encode.get_current_env tcenv in + let configs, next_hint = + make_solver_configs can_split is_retry env labels qry q suffix + in + ask_solver env configs next_hint + + | _ -> failwith "Impossible" + ) + in + if Solver.Cache.try_find_query_cache tcenv q then ( + ([], { ans_ok with cache_hit = true }) + ) else ( + let (cfgs, ans) = do () in + if ans.ok then + Solver.Cache.query_cache_add tcenv q; + (cfgs, ans) + ) + +(* Asks the solver and reports errors. Does quake if needed. *) +let do_solve (can_split:bool) (is_retry:bool) use_env_msg tcenv q : unit = + let ans_opt = + try Some (encode_and_ask can_split is_retry use_env_msg tcenv q) with + (* Each (potentially splitted) query can fail with this error, raise by encode_query. + * Note, even though this is a log_issue, the error cannot be turned into a warning + * nor ignored. *) + | FStarC.SMTEncoding.Env.Inner_let_rec names -> + FStarC.TypeChecker.Err.log_issue + tcenv tcenv.range + (Errors.Error_NonTopRecFunctionNotFullyEncoded, [ + Errors.text <| + BU.format1 + "Could not encode the query since F* does not support precise smtencoding of inner let-recs yet (in this case %s)" + (String.concat "," (List.map fst names))]); + None + in + match ans_opt with + | Some (default_settings::_, ans) when not ans.ok -> + report tcenv default_settings ans + + | Some (_, ans) when ans.ok -> + () (* trivial or succeeded *) + + | Some ([], ans) when not ans.ok -> + failwith "impossible: bad answer from encode_and_ask" + + | None -> () (* already logged an error *) + +let split_and_solve (retrying:bool) use_env_msg tcenv q : unit = + if Debug.any () || Options.query_stats () then begin + let range = "(" ^ (Range.string_of_range (Env.get_range tcenv)) ^ ")" in + BU.print2 "%s\tQuery-stats splitting query because %s\n" + range + (if retrying then "retrying failed query" else "--split_queries is always") + end; + let goals = + match Env.split_smt_query tcenv q with + | None -> + failwith "Impossible: split_query callback is not set" + + | Some goals -> + goals + in + + goals |> List.iter (fun (env, goal) -> do_solve false retrying use_env_msg env goal); + + if FStarC.Errors.get_err_count() = 0 && retrying + then ( //query succeeded after a retry + FStarC.TypeChecker.Err.log_issue + tcenv + tcenv.range + (Errors.Warning_SplitAndRetryQueries, + [Errors.text + "The verification condition succeeded after splitting it to localize potential errors, \ + although the original non-split verification condition failed. \ + If you want to rely on splitting queries for verifying your program \ + please use the '--split_queries always' option rather than relying on it implicitly."]) + ) + +let disable_quake_for (f : unit -> 'a) : 'a = + Options.with_saved_options (fun () -> + Options.set_option "quake_hi" (Options.Int 1); + f ()) + +(* Split queries if needed according to --split_queries option. Note: +sync SMT queries do not pass via this function. *) +let do_solve_maybe_split use_env_msg tcenv q : unit = + (* If we are admiting queries, don't do anything, and bail out + right now to save time/memory *) + if tcenv.admit then () else begin + match Options.split_queries () with + | Options.No -> do_solve false false use_env_msg tcenv q + | Options.OnFailure -> + (* If we are quake testing, disable auto splitting. Note, this implies + * that automatically splitted queries do not ever get quake testing, + * which is good as that would be confusing for the user. *) + let can_split = not (Options.quake_hi () > 1) in + begin try do_solve can_split false use_env_msg tcenv q with + | SplitQueryAndRetry -> + split_and_solve true use_env_msg tcenv q + end + | Options.Always -> + (* Set retrying=false so queries go through the full config list, etc. *) + split_and_solve false use_env_msg tcenv q + end + +(* Attempt to discharge a VC through the SMT solver. Will +automatically retry increasing fuel as needed, and perform quake testing +(repeating the query to make sure it is robust). This function will +_log_ (not raise) an error if the VC could not be proven. *) +let solve use_env_msg tcenv q : unit = + if Options.no_smt () then + let open FStarC.Errors.Msg in + let open FStarC.Pprint in + let open FStarC.Class.PP in + FStarC.TypeChecker.Err.log_issue + tcenv tcenv.range + (Errors.Error_NoSMTButNeeded, + [text "A query could not be solved internally, and --no_smt was given."; + text "Query = " ^/^ pp q]) + else + Profiling.profile + (fun () -> do_solve_maybe_split use_env_msg tcenv q) + (Some (Ident.string_of_lid (Env.current_module tcenv))) + "FStarC.SMTEncoding.solve_top_level" + +(* This asks the SMT to solve a query, and returns the answer without +logging any kind of error. Mostly useful for the smt_sync tactic +primitive. + +It will NOT split queries +It will NOT do quake testing. +It WILL raise fuel incrementally to attempt to solve the query + +*) +let solve_sync use_env_msg tcenv (q:Syntax.term) : answer = + if Options.no_smt () then ans_fail + else + let go () = + if !dbg_SMTQuery then ( + let open FStarC.Errors.Msg in + let open FStarC.Pprint in + Errors.diag q.pos [ + prefix 2 1 (text "Running synchronous SMT query. Q =") (pp q); + ] + ); + let _cfgs, ans = disable_quake_for (fun () -> encode_and_ask false false use_env_msg tcenv q) in + ans + in + Profiling.profile + go + (Some (Ident.string_of_lid (Env.current_module tcenv))) + "FStarC.SMTEncoding.solve_sync_top_level" + +(* The version actually exported, and used by tactics. *) +let solve_sync_bool use_env_msg tcenv q : bool = + let ans = solve_sync use_env_msg tcenv q in + ans.ok + +(**********************************************************************************************) +(* Top-level interface *) +(**********************************************************************************************) + +let snapshot msg = + let v0, v1 = Encode.snapshot_encoding msg in + let v2 = Z3.snapshot msg in + (v0, v1, v2), () +let rollback msg tok = + let tok01, tok2 = + match tok with + | None -> None, None + | Some (v0, v1, v2) -> Some (v0, v1), Some v2 + in + Encode.rollback_encoding msg tok01; + Z3.rollback msg tok2 + +let solver = { + init=(fun e -> save_cfg e; Encode.init e); + snapshot; + rollback; + encode_sig=Encode.encode_sig; + + (* These three to be overriden by FStarC.Universal.init_env *) + preprocess=(fun e g -> (false, [e,g, FStarC.Options.peek ()])); + spinoff_strictly_positive_goals = None; + handle_smt_goal=(fun e g -> [e,g]); + + solve=solve; + solve_sync=solve_sync_bool; + finish=(fun () -> ()); + refresh=Z3.refresh; +} + +let dummy = { + init=(fun _ -> ()); + snapshot=(fun _ -> (0, 0, 0), ()); + rollback=(fun _ _ -> ()); + encode_sig=(fun _ _ -> ()); + preprocess=(fun e g -> (false, [e,g, FStarC.Options.peek ()])); + spinoff_strictly_positive_goals = None; + handle_smt_goal=(fun e g -> [e,g]); + solve=(fun _ _ _ -> ()); + solve_sync=(fun _ _ _ -> false); + finish=(fun () -> ()); + refresh=(fun _ -> ()); +} diff --git a/src/smtencoding/FStarC.SMTEncoding.Solver.fsti b/src/smtencoding/FStarC.SMTEncoding.Solver.fsti new file mode 100644 index 00000000000..245e5f2de42 --- /dev/null +++ b/src/smtencoding/FStarC.SMTEncoding.Solver.fsti @@ -0,0 +1,22 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.SMTEncoding.Solver +open FStarC.Compiler.Effect + +val with_hints_db : string -> (unit -> 'a) -> 'a +val dummy: FStarC.TypeChecker.Env.solver_t +val solver: FStarC.TypeChecker.Env.solver_t diff --git a/src/smtencoding/FStarC.SMTEncoding.SolverState.fst b/src/smtencoding/FStarC.SMTEncoding.SolverState.fst new file mode 100644 index 00000000000..7f38f098d06 --- /dev/null +++ b/src/smtencoding/FStarC.SMTEncoding.SolverState.fst @@ -0,0 +1,518 @@ +(* + Copyright 2024 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.SMTEncoding.SolverState +open FStarC.Compiler.Effect +open FStar open FStarC +open FStarC.Compiler +open FStarC.SMTEncoding.Term +open FStarC.BaseTypes +open FStarC.Compiler.Util +open FStar.List.Tot +open FStarC.Class.Show +open FStarC.Class.Setlike +module BU = FStarC.Compiler.Util +module Pruning = FStarC.SMTEncoding.Pruning +module U = FStarC.SMTEncoding.UnsatCore +module TcEnv = FStarC.TypeChecker.Env + +let decl_name_set = BU.psmap bool +let empty_decl_names = BU.psmap_empty #bool () +let decl_names_contains (x:string) (s:decl_name_set) = Some? (BU.psmap_try_find s x) +let add_name (x:string) (s:decl_name_set) = BU.psmap_add s x true + +type decls_at_level = { + pruning_state: Pruning.pruning_state; (* the context pruning state representing all declarations visible at this level and prior levels *) + given_decl_names: decl_name_set; (* all declarations that have been given to the solver at this level *) + all_decls_at_level_rev: list (list decl); (* all decls at this level; in reverse order of pushes *) + given_some_decls: bool; (* Have some declarations been flushed at this level? If not, we can pop this level without needing to flush pop to the solver *) + to_flush_rev: list (list decl); (* declarations to be given to the solver at the next flush, in reverse order, though each nested list is in order *) + named_assumptions: BU.psmap assumption; (* A map from assumption names to assumptions, accumulating all assumptions up to this level *) + pruning_roots:option (list decl); (* When starting a query context, we register the declarations to be used as roots for context pruning *) +} + +let init_given_decls_at_level = { + given_decl_names = empty_decl_names; + all_decls_at_level_rev = []; + pruning_state=Pruning.init; + given_some_decls=false; + to_flush_rev=[]; + named_assumptions = BU.psmap_empty (); + pruning_roots=None +} + +type solver_state = { + levels: list decls_at_level; (* a stack of levels *) + pending_flushes_rev: list decl; (* any declarations to be flushed before flushing the levels, typically a sequence of pops *) + using_facts_from:option using_facts_from_setting; (* The current setting for using_facts_from *) + retain_assumptions: decl_name_set; (* For using_facts_from: some declarations are of the form RetainAssumptions [a1; a2; ...; an]; this records their names *) +} + +let depth (s:solver_state) = List.length s.levels + +(* For debugging: print the solver state *) +let solver_state_to_string (s:solver_state) = + let levels = + List.map + (fun level -> + BU.format3 "Level { all_decls=%s; given_decls=%s; to_flush=%s }" + (show <| List.length level.all_decls_at_level_rev) + (show level.given_some_decls) + (show <| List.length level.to_flush_rev)) + s.levels + in + BU.format2 "Solver state { levels=%s; pending_flushes=%s }" + (show levels) + (show <| List.length s.pending_flushes_rev) + +instance showable_solver_state : showable solver_state = { show = solver_state_to_string } + +let debug (msg:string) (s0 s1:solver_state) = + if Options.Ext.get "debug_solver_state" <> "" + then ( + BU.print3 "Debug (%s):{\n\t before=%s\n\t after=%s\n}" msg + (solver_state_to_string s0) + (solver_state_to_string s1) + ) + +let peek (s:solver_state) = + match s.levels with + | [] -> failwith "Solver state cannot have an empty stack" + | hd::tl -> hd, tl + +let replace_head (hd:decls_at_level) (s:solver_state) = { s with levels = hd :: List.tl s.levels } + +let init (_:unit) +: solver_state += { levels = [init_given_decls_at_level]; + pending_flushes_rev = []; + using_facts_from = Some (Options.using_facts_from()); + retain_assumptions = empty_decl_names } + +let push (s:solver_state) +: solver_state += let hd, _ = peek s in + let push = Push (List.length s.levels) in + let next = { given_decl_names = hd.given_decl_names; + all_decls_at_level_rev = []; + pruning_state = hd.pruning_state; + given_some_decls=false; + to_flush_rev=[[push]]; (* push a new context to the solver *) + named_assumptions = hd.named_assumptions; + pruning_roots=None + } in + { s with levels=next::s.levels } + +let pop (s:solver_state) +: solver_state += let hd, tl = peek s in + if Nil? tl then failwith "Solver state cannot have an empty stack"; + let s1 = + if not hd.given_some_decls //nothing has been given yet at this level + then { s with levels = tl } //so we don't actually have to send a pop + else { s with levels = tl; pending_flushes_rev = Pop (List.length tl) :: s.pending_flushes_rev } + in + s1 + +(* filter ds according to the using_facts_from setting: + + -- This function takes specific fields of the csolver state, rather + than the entire solver state, as it is used as a helper in constructing a + new solver state from a prior one, and some of its arguments are from a + partially new solver state +*) +let filter_using_facts_from + (using_facts_from:option using_facts_from_setting) + (named_assumptions:BU.psmap assumption) + (retain_assumptions:decl_name_set) + (already_given_decl: string -> bool) + (ds:list decl) //flattened decls +: list decl += match using_facts_from with + | None + | Some [[], true] -> ds + | Some using_facts_from -> + let keep_assumption (a:assumption) + : bool + = match a.assumption_fact_ids with + | [] -> true //retaining `a` because it is not tagged with a fact id + | _ -> + // the assumption is either tagged in a prior RetainAssumptions decl + decl_names_contains a.assumption_name retain_assumptions || + // Or, it is enabled by the using_facts_from setting + a.assumption_fact_ids + |> BU.for_some (function Name lid -> TcEnv.should_enc_lid using_facts_from lid | _ -> false) + in + let already_given_map : BU.smap bool = BU.smap_create 1000 in + let add_assumption a = BU.smap_add already_given_map a.assumption_name true in + let already_given (a:assumption) + : bool + = Some? (BU.smap_try_find already_given_map a.assumption_name) || + already_given_decl a.assumption_name + in + let map_decl (d:decl) + : list decl + = match d with + | Assume a -> ( + if keep_assumption a && not (already_given a) + then (add_assumption a; [d]) + else [] + ) + | RetainAssumptions names -> + // Add all assumptions that are mentioned here, making sure to not add duplicates + let assumptions = + names |> + List.collect (fun name -> + match BU.psmap_try_find named_assumptions name with + | None -> [] + | Some a -> + if already_given a then [] else (add_assumption a; [Assume a])) + in + assumptions + | _ -> + [d] + in + let ds = List.collect map_decl ds in + ds + +let already_given_decl (s:solver_state) (aname:string) +: bool += s.levels |> BU.for_some (fun level -> decl_names_contains aname level.given_decl_names) + +let rec flatten (d:decl) : list decl = + match d with + | Module (_, ds) -> List.collect flatten ds + | _ -> [d] + +(* Record assumptions with their names *) +let add_named_assumptions (named_assumptions:BU.psmap assumption) (ds:list decl) +: BU.psmap assumption += List.fold_left + (fun named_assumptions d -> + match d with + | Assume a -> BU.psmap_add named_assumptions a.assumption_name a + | _ -> named_assumptions) + named_assumptions + ds + +(* Record all names that are named in a RetainAssumptions *) +let add_retain_assumptions (ds:list decl) (s:solver_state) +: solver_state += let ra = + List.fold_left + (fun ra d -> + match d with + | RetainAssumptions names -> + List.fold_left + (fun ra name -> add_name name ra) + ra names + | _ -> ra) + s.retain_assumptions + ds + in + { s with retain_assumptions = ra } + +(* + The main `give` API has two modes: + `give_delay_assumptions` is used when context_pruning is enabled, and + `give_now` is used otherwise. + + In both cases, we have the following parameters: + + - resetting: Is this being called during a reset? If so, we don't need to + update the pruning state---repeatedly building the pruning state on each + reset is expensive and quadratic in the number of declarations loaded so + far. + - ds: The declarations to give to the solver + - s: The current solver state +*) + +(* give_delay_assumptions: + + This updates the top-level of the solver state, and flushes *only* the + non-assumption declarations to the solver. + + The assumptions are retained and a selection of them may be flushed to the + solver later, for a given set of roots of a query. + *) +let give_delay_assumptions (resetting:bool) (ds:list decl) (s:solver_state) +: solver_state += let decls = List.collect flatten ds in + let assumptions, rest = List.partition Assume? decls in + let hd, tl = peek s in + let hd = { hd with all_decls_at_level_rev = ds::hd.all_decls_at_level_rev; + to_flush_rev = rest :: hd.to_flush_rev } in + if resetting + then { s with levels = hd :: tl } + else ( + let hd = + { hd with + pruning_state = Pruning.add_decls decls hd.pruning_state; + named_assumptions = add_named_assumptions hd.named_assumptions assumptions } + in + add_retain_assumptions decls { s with levels = hd :: tl } + ) + +(* give_now: + + This updates the top-level of the solver state, and flushes *all* + declarations to the solver, after filtering them according to the + using_facts_from setting +*) +let give_now (resetting:bool) (ds:list decl) (s:solver_state) +: solver_state += let decls = List.collect flatten ds in + let assumptions, _ = List.partition Assume? decls in + let hd, tl = peek s in + let named_assumptions = + if resetting + then hd.named_assumptions + else add_named_assumptions hd.named_assumptions assumptions + in + let ds_to_flush = + filter_using_facts_from + s.using_facts_from + named_assumptions + s.retain_assumptions + (already_given_decl s) + decls + in + let given = + List.fold_left + (fun given d -> + match d with + | Assume a -> add_name a.assumption_name given + | _ -> given) + hd.given_decl_names + ds_to_flush + in + let hd = + { hd with + given_decl_names = given; + all_decls_at_level_rev = ds :: hd.all_decls_at_level_rev; + to_flush_rev = ds_to_flush :: hd.to_flush_rev; } + in + if resetting + then { s with levels = hd :: tl } + else ( + let hd = + { hd with + pruning_state = Pruning.add_decls decls hd.pruning_state; + named_assumptions } + in + add_retain_assumptions decls { s with levels = hd :: tl } + ) + +let give_aux resetting (ds:list decl) (s:solver_state) +: solver_state += if Options.Ext.get "context_pruning" <> "" + then give_delay_assumptions resetting ds s + else give_now resetting ds s + +(* give: The main API for giving declarations to the solver *) +let give = give_aux false + +(* reset: + + This functions essentially runs the sequence of push/give operations that + have been run so far from the init state, producing the declarations + that should be flushed to the solver from a clean state, while considering + the current option settings. + + E.g., if the value of context_pruning has changed, this will restore the solver + to a state where the new setting is in effect. + +*) +let reset (using_facts_from:option using_facts_from_setting) (s:solver_state) +: solver_state += let s_new = init () in + let s_new = { s_new with using_facts_from; retain_assumptions = s.retain_assumptions } in + let set_pruning_roots level s = + let hd,tl = peek s in + let hd = { hd with pruning_roots = level.pruning_roots } in + { s with levels = hd :: tl } + in + let rebuild_level now level s_new = + //Rebuild the level from s in the top-most level of the new solver state s_new + let hd, tl = peek s_new in + //1. replace the head of s_new recordingt the pruning state etc. from level + let hd = {hd with pruning_state=level.pruning_state; named_assumptions=level.named_assumptions} in + let s_new = { s_new with levels = hd :: tl } in + //2. Then give all declarations at this level + // The `now` flag is set for levels that "follow" a level + // whose pruning roots have been set, i.e., for the query itself + // Otherwise, we give the declarations either now or delayed, depending on the current value of context_pruning + let s = List.fold_right (if now then give_now true else give_aux true) level.all_decls_at_level_rev s_new in + // 3. If there are pruning roots at this level, set them + set_pruning_roots level s, + Some? level.pruning_roots + in + let rec rebuild levels s_new = + match levels with + | [ last ] -> + rebuild_level false last s_new + | level :: levels -> + //rebuild prior levels + let s_new, now = rebuild levels s_new in + //push a context + let s_new = push s_new in + //rebuild the level + rebuild_level now level s_new + in + fst <| rebuild s.levels s_new + + +let name_of_assumption (d:decl) = + match d with + | Assume a -> a.assumption_name + | _ -> failwith "Expected an assumption" + +(* Prune the context with respect to a set of roots *) +let prune_level (roots:list decl) (hd:decls_at_level) (s:solver_state) +: decls_at_level += // to_give is the set of assumptions reachable from roots + let to_give = Pruning.prune hd.pruning_state roots in + // Remove any assumptions that have already been given to the solver + // and update the set of given declarations + let given_decl_names, can_give = + List.fold_left + (fun (decl_name_set, can_give) to_give -> + let name = name_of_assumption to_give in + if not (decl_names_contains name decl_name_set) + then ( + add_name name decl_name_set, + to_give::can_give + ) + else decl_name_set, can_give) + (hd.given_decl_names, []) + to_give + in + // Filter the assumptions that can be given to the solver + // according to the using_facts_from setting + let can_give = + filter_using_facts_from + s.using_facts_from + hd.named_assumptions + s.retain_assumptions + (already_given_decl s) + can_give + in + let hd = { hd with given_decl_names; + to_flush_rev = can_give::hd.to_flush_rev } in + hd + +(* Run pruning in a "simulation" mode, where we don't actually prune the context, + but instead return the names of the assumptions that would have been pruned. *) +let prune_sim (roots:list decl) (s:solver_state) +: list string += let hd, tl = peek s in + let to_give = Pruning.prune hd.pruning_state roots in + let can_give = + filter_using_facts_from + s.using_facts_from + hd.named_assumptions + s.retain_assumptions + (already_given_decl s) + to_give + in + List.map name_of_assumption (List.filter Assume? roots@can_give) + +(* Start a query context, registering and pushing the roots *) +let start_query (msg:string) (roots_to_push:list decl) (qry:decl) (s:solver_state) +: solver_state += let hd, tl = peek s in + let s = { s with levels = { hd with pruning_roots = Some (qry::roots_to_push) } :: tl } in + let s = push s in + let s = give [Caption msg] s in + give_now false roots_to_push s + +(* Finising a query context, popping and clearing the roots *) +let finish_query (msg:string) (s:solver_state) +: solver_state += let s = give [Caption msg] s in + let s = pop s in + let hd, tl = peek s in + { s with levels = { hd with pruning_roots = None } :: tl } + +(* Filter all declarations visible with an unsat core *) +let filter_with_unsat_core queryid (core:U.unsat_core) (s:solver_state) +: list decl += let rec all_decls levels = + match levels with + | [last] -> last.all_decls_at_level_rev + | level :: levels -> + level.all_decls_at_level_rev@[Push <| List.length levels]::all_decls levels + in + let all_decls = all_decls s.levels in + let all_decls = List.flatten <| List.rev all_decls in + U.filter core all_decls + +let would_have_pruned (s:solver_state) = + if Options.Ext.get "context_pruning_sim" = "" + then None + else + (*find the first level with pruning roots, and prune the context with respect to them *) + let rec aux levels = + match levels with + | [] -> None + | level :: levels -> + match level.pruning_roots with + | Some roots -> + Some (prune_sim roots s) + | None -> aux levels + in + aux s.levels + +(* flush: Emit declarations to the solver *) +let flush (s:solver_state) +: list decl & solver_state += let s = + if Options.Ext.get "context_pruning" <> "" + then ( + (*find the first level with pruning roots, and prune the context with respect to them *) + let rec aux levels = + match levels with + | [] -> [] + | level :: levels -> + match level.pruning_roots with + | Some roots -> + let hd = prune_level roots level s in + hd :: levels + | None -> + level :: aux levels + in + { s with levels = aux s.levels } + ) + else s + in + (* Gather all decls to be flushd per level *) + let to_flush = + List.flatten <| + List.rev <| + List.collect (fun level -> level.to_flush_rev) s.levels + in + (* Update the solver state, clearing the pending flushes per level and recording that some decls were flushed *) + let levels = + List.map + (fun level -> { level with + given_some_decls=(level.given_some_decls || Cons? level.to_flush_rev); + to_flush_rev = [] }) + s.levels + in + let s1 = { s with levels; pending_flushes_rev=[] } in + (* prefix any pending flushes to the list of decls to be flushed *) + let flushed = List.rev s.pending_flushes_rev @ to_flush in + flushed, + s1 \ No newline at end of file diff --git a/src/smtencoding/FStarC.SMTEncoding.SolverState.fsti b/src/smtencoding/FStarC.SMTEncoding.SolverState.fsti new file mode 100644 index 00000000000..6f3a8666c57 --- /dev/null +++ b/src/smtencoding/FStarC.SMTEncoding.SolverState.fsti @@ -0,0 +1,106 @@ +(* + Copyright 2024 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.SMTEncoding.SolverState +(** + This module is an abstraction of state of the SMT solver, expressed in terms of the facts + that are visible to it currently. + + As such, it also encapsulates the various notions of filtering the facts that + are sent to the solver, including: + + - Filtering with unsat cores + - Context pruning + - Filtering using the using_facts_from setting + + This interface is purely functional: every operation takes the current state and + optionally returns a new one, in case the state changes. + + Note, this module does not directly call the SMT solver itself: That is + handled in FStarC.SMTEncoding.Z3.fst. Instead, it buffers all Term.decls to be + sent to the solver and a call to flush returns all the decls to be sent. +*) +open FStarC.Compiler.Effect +open FStar open FStarC +open FStarC.Compiler +open FStarC.SMTEncoding.Term +open FStarC.BaseTypes +open FStarC.Compiler.Util +module BU = FStarC.Compiler.Util +module U = FStarC.SMTEncoding.UnsatCore +type using_facts_from_setting = list (list string & bool) + +// Abstract state of the solver +val solver_state : Type0 + +// Initialize the solver state +val init (_:unit) : solver_state + +// Push a context +val push (s:solver_state) : solver_state + +// Pop a context: All facts added since the last push are removed +val pop (s:solver_state) : solver_state + +// Get the current depth of the context stack: +// Useful in implementing snapshot and rollback, which are used in the IDE +// to restore the state of the solver to a previous point, rather than just +// popping the context one at a time +val depth (s:solver_state) : int + +// Reset the state, so that the next flush will yield all the declarations +// that should be sent to a _fresh_ Z3 process to bring it to a state +// logicallly equivalent to the current solver state +val reset (_:option using_facts_from_setting) (s:solver_state) : solver_state + +// Give the solver some declarations +val give (ds:list decl) (s:solver_state) : solver_state + +// Start a query context: Queries are handled specially, since they trigger +// various kinds of filters. +// +// This function pushes a context, and then adds roots to the solver state. +// +// * msg: A caption to be added to the SMT encoding for this query +// +// * roots: A list of query-specific declarations, e.g, an encoding of the local +// binders of the query +// +// * qry: The query itself: This is NOT given to the solver. Instead, (qry::roots) are +// registered in the solver state as the roots from which to scan for context pruning. +// +val start_query (msg:string) (roots:list decl) (qry:decl) (s:solver_state) : solver_state + +// Pops the context pushed at when starting a query +// Clears any registered roots for context pruning +val finish_query (msg:string) (s:solver_state) : solver_state + +// Filters all declarations visible with an unsat core and returns the result +// Does not change the solver state +// +// Queries filtered with an unsat core are always sent to a fresh Z3 process, +// and if they fail, the query falls back to a background process whose state is `s`. +// Filtering with an unsat core does not change the staet of s. +val filter_with_unsat_core (queryid:string) (_:U.unsat_core) (s:solver_state) : list decl + +// Get all declarations to be given to the solver since the last flush +// and update the solver state. +val flush (s:solver_state) : list decl & solver_state + +// If context_pruning_sim is set, this function returns the names of all declarations +// that would have been given to the solver if the context were pruned. +// This is useful for debugging whether context_pruning removed assumptions that are +// otherwise necessary for a proof. +val would_have_pruned (s:solver_state) : option (list string) \ No newline at end of file diff --git a/src/smtencoding/FStarC.SMTEncoding.Term.fst b/src/smtencoding/FStarC.SMTEncoding.Term.fst new file mode 100644 index 00000000000..15ad974e570 --- /dev/null +++ b/src/smtencoding/FStarC.SMTEncoding.Term.fst @@ -0,0 +1,1182 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.SMTEncoding.Term + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect + +module S = FStarC.Syntax.Syntax +module BU = FStarC.Compiler.Util +module U = FStarC.Syntax.Util + +let escape (s:string) = BU.replace_char s '\'' '_' + +let rec strSort x = match x with + | Bool_sort -> "Bool" + | Int_sort -> "Int" + | Term_sort -> "Term" + | String_sort -> "FString" + | Fuel_sort -> "Fuel" + | BitVec_sort n -> format1 "(_ BitVec %s)" (string_of_int n) + | Array(s1, s2) -> format2 "(Array %s %s)" (strSort s1) (strSort s2) + | Arrow(s1, s2) -> format2 "(%s -> %s)" (strSort s1) (strSort s2) + | Sort s -> s + +(** Note [Thunking Nullary Constants] + +### The problem: Top-level nullary constants lead to SMT context + pollution + +Given a top-level nullary constant, say, + +```let n : u32 = 0ul``` + +F* would encode this to SMT as (roughly) + +``` +(declare-fun n () Term) +(assert (HasType n u32)) +(assert (n = U32.uint_to_t 0)) +``` + +i.e., ground facts about the `n`'s typing and definition would be +introduced into the top-level SMT context. + +Now, for a subsequent proof that has nothing to do with `n`, these +facts are still available in the context leading to clutter. E.g., in +this case, the `HasType n u32` leads to Z3 deriving facts like about +`0 <= n < pow2 32`, then potentially unfolding the `pow2 32` recursive +functions ... etc. all for potentially no good reason. + +### The fix: Protect assumptions about nullary constants under a dummy + quantifier + +The change in this PR is to avoid introducing these ground facts into +the SMT context by default. Instead, we now thunk these nullary +constants, adding a dummy argument, like so: + +``` +(declare-fun n (Dummy_sort) Term) +(assert (forall ((x Dummy_sort) (! (HasType (n x) u32) :pattern ((n x))))) +(assert (forall ((x Dummy_sort) (! (= (n x) (U32.uint_to_t 0)) :pattern ((n x))))) +``` + +Now, instead of ground facts, we have quantified formulae that are +triggered on occurrences of `n x`. + +Every occurrence of `n` in the rest of the proof is forced to `(n +Dummy_value)`: so, only when such an occurrence is present, do facts +about `n` become available, not polluting the context otherwise. + +For some proofs in large contexts, this leads to massive SMT +performance gains: e.g., in miTLS with LowParse in context, some +queries in HSL.Common are sped up by 20x; Negotiation.fst has an +end-to-end speed up (full verification time) by 8-9x. etc. So, this +can be a big win. + +#### An implementation detail + +Note, this thunking happens at a very low-level in the SMT +encoding. Basically, the thunks are forced at the very last minute +just before terms are printed to SMT. This is important since it +ensures that things like sharing of SMT terms are not destroyed by +discrepancies in thunking behavior (and earlier attempt did thunking +at a higher level in the encoding, but this led to many regressions). + +The bool in the fv is used in termToSmt to force the thunk before +printing. + **) + +let mk_decls name key decls aux_decls = [{ + sym_name = Some name; + key = Some key; + decls = decls; + a_names = //AR: collect the names of aux_decls and decls to be retained in case of a cache hit + let sm = BU.smap_create 20 in + List.iter (fun elt -> + List.iter (fun s -> BU.smap_add sm s "0") elt.a_names + ) aux_decls; + List.iter (fun d -> match d with + | Assume a -> BU.smap_add sm (a.assumption_name) "0" + | _ -> ()) decls; + BU.smap_keys sm +}] + +let mk_decls_trivial decls = [{ + sym_name = None; + key = None; + decls = decls; + a_names = List.collect (function + | Assume a -> [a.assumption_name] + | _ -> []) decls; +}] + +let decls_list_of l = l |> List.collect (fun elt -> elt.decls) + +let mk_fv (x, y) : fv = FV (x, y, false) + +let fv_name (x:fv) = let FV (nm, _, _) = x in nm + +instance deq_fv : deq fv = { + (=?) = (fun fv1 fv2 -> fv_name fv1 = fv_name fv2); +} +instance ord_fv : ord fv = { + super = deq_fv; + cmp = (fun fv1 fv2 -> Order.order_from_int (BU.compare (fv_name fv1) (fv_name fv2))); +} + +let fv_sort (x:fv) = let FV (_, sort, _) = x in sort +let fv_force (x:fv) = let FV (_, _, force) = x in force +let fv_eq (x:fv) (y:fv) = fv_name x = fv_name y +let fvs_subset_of (x:fvs) (y:fvs) = + let open FStarC.Class.Setlike in + subset (from_list x <: RBSet.t fv) (from_list y) + +let freevar_eq x y = match x.tm, y.tm with + | FreeV x, FreeV y -> fv_eq x y + | _ -> false +let freevar_sort = function + | {tm=FreeV x} -> fv_sort x + | _ -> failwith "impossible" +let fv_of_term = function + | {tm=FreeV fv} -> fv + | _ -> failwith "impossible" +let rec freevars t = match t.tm with + | Integer _ + | String _ + | Real _ + | BoundV _ -> [] + | FreeV fv when fv_force fv -> [] //this is actually a top-level constant + | FreeV fv -> [fv] + | App(_, tms) -> List.collect freevars tms + | Quant(_, _, _, _, t) + | Labeled(t, _, _) + | LblPos(t, _) -> freevars t + | Let (es, body) -> List.collect freevars (body::es) + +//memo-ized +let free_variables t = match !t.freevars with + | Some b -> b + | None -> + let fvs = BU.remove_dups fv_eq (freevars t) in + t.freevars := Some fvs; + fvs + +open FStarC.Class.Setlike +let free_top_level_names (t:term) +: RBSet.t string += let rec free_top_level_names acc t = + match t.tm with + | FreeV (FV (nm, _, _)) -> add nm acc + | App (Var s, args) -> + let acc = add s acc in + List.fold_left free_top_level_names acc args + | App (_, args) -> List.fold_left free_top_level_names acc args + | Quant (_, pats, _, _, body) -> + let acc = List.fold_left (fun acc pats -> List.fold_left free_top_level_names acc pats) acc pats in + free_top_level_names acc body + | Let(tms, t) -> + let acc = List.fold_left free_top_level_names acc tms in + free_top_level_names acc t + | Labeled(t, _, _) + | LblPos(t, _) -> free_top_level_names acc t + | _ -> acc + in + free_top_level_names (empty()) t + +(*****************************************************) +(* Pretty printing terms and decls in SMT Lib format *) +(*****************************************************) +let qop_to_string = function + | Forall -> "forall" + | Exists -> "exists" + +let op_to_string = function + | TrueOp -> "true" + | FalseOp -> "false" + | Not -> "not" + | And -> "and" + | Or -> "or" + | Imp -> "implies" + | Iff -> "iff" + | Eq -> "=" + | LT -> "<" + | LTE -> "<=" + | GT -> ">" + | GTE -> ">=" + | Add -> "+" + | Sub -> "-" + | Div -> "div" + | RealDiv -> "/" + | Mul -> "*" + | Minus -> "-" + | Mod -> "mod" + | ITE -> "ite" + | BvAnd -> "bvand" + | BvXor -> "bvxor" + | BvOr -> "bvor" + | BvAdd -> "bvadd" + | BvSub -> "bvsub" + | BvShl -> "bvshl" + | BvShr -> "bvlshr" + | BvUdiv -> "bvudiv" + | BvMod -> "bvurem" + | BvMul -> "bvmul" + | BvUlt -> "bvult" + | BvToNat -> "bv2int" + | BvUext n -> format1 "(_ zero_extend %s)" (string_of_int n) + | NatToBv n -> format1 "(_ int2bv %s)" (string_of_int n) + | Var s -> s + +let weightToSmt = function + | None -> "" + | Some i -> BU.format1 ":weight %s\n" (string_of_int i) + +let rec hash_of_term' t = match t with + | Integer i -> i + | String s -> s + | Real r -> r + | BoundV i -> "@"^string_of_int i + | FreeV x -> fv_name x ^ ":" ^ strSort (fv_sort x) //Question: Why is the sort part of the hash? + | App(op, tms) -> "("^(op_to_string op)^(List.map hash_of_term tms |> String.concat " ")^")" + | Labeled(t, r1, r2) -> hash_of_term t ^ Errors.Msg.rendermsg r1 ^ (Range.string_of_range r2) + | LblPos(t, r) -> "(! " ^hash_of_term t^ " :lblpos " ^r^ ")" + | Quant(qop, pats, wopt, sorts, body) -> + "(" + ^ (qop_to_string qop) + ^ " (" + ^ (List.map strSort sorts |> String.concat " ") + ^ ")(! " + ^ (hash_of_term body) + ^ " " + ^ (weightToSmt wopt) + ^ " " + ^ (pats |> List.map (fun pats -> (List.map hash_of_term pats |> String.concat " ")) |> String.concat "; ") + ^ "))" + | Let (es, body) -> + "(let (" ^ (List.map hash_of_term es |> String.concat " ") ^ ") " ^ hash_of_term body ^ ")" +and hash_of_term tm = hash_of_term' tm.tm + +let mkBoxFunctions s = (s, s ^ "_proj_0") +let boxIntFun = mkBoxFunctions "BoxInt" +let boxBoolFun = mkBoxFunctions "BoxBool" +let boxStringFun = mkBoxFunctions "BoxString" +let boxBitVecFun sz = mkBoxFunctions ("BoxBitVec" ^ (string_of_int sz)) +let boxRealFun = mkBoxFunctions "BoxReal" + +// Assume the Box/Unbox functions to be injective +let isInjective s = + if (FStar.String.length s >= 3) then + String.substring s 0 3 = "Box" && + not (List.existsML (fun c -> c = '.') (FStar.String.list_of_string s)) + else false + +let mk t r = {tm=t; freevars=BU.mk_ref None; rng=r} +let mkTrue r = mk (App(TrueOp, [])) r +let mkFalse r = mk (App(FalseOp, [])) r +let mkUnreachable = mk (App(Var "Unreachable", [])) Range.dummyRange +let mkInteger i r = mk (Integer (ensure_decimal i)) r +let mkInteger' i r = mkInteger (string_of_int i) r +let mkReal i r = mk (Real i) r +let mkBoundV i r = mk (BoundV i) r +let mkFreeV x r = mk (FreeV x) r +let mkApp' f r = mk (App f) r +let mkApp (s, args) r = mk (App (Var s, args)) r +let mkNot t r = match t.tm with + | App(TrueOp, _) -> mkFalse r + | App(FalseOp, _) -> mkTrue r + | _ -> mkApp'(Not, [t]) r +let mkAnd (t1, t2) r = match t1.tm, t2.tm with + | App(TrueOp, _), _ -> t2 + | _, App(TrueOp, _) -> t1 + | App(FalseOp, _), _ + | _, App(FalseOp, _) -> mkFalse r + | App(And, ts1), App(And, ts2) -> mkApp'(And, ts1@ts2) r + | _, App(And, ts2) -> mkApp'(And, t1::ts2) r + | App(And, ts1), _ -> mkApp'(And, ts1@[t2]) r + | _ -> mkApp'(And, [t1;t2]) r +let mkOr (t1, t2) r = match t1.tm, t2.tm with + | App(TrueOp, _), _ + | _, App(TrueOp, _) -> mkTrue r + | App(FalseOp, _), _ -> t2 + | _, App(FalseOp, _) -> t1 + | App(Or, ts1), App(Or, ts2) -> mkApp'(Or, ts1@ts2) r + | _, App(Or, ts2) -> mkApp'(Or, t1::ts2) r + | App(Or, ts1), _ -> mkApp'(Or, ts1@[t2]) r + | _ -> mkApp'(Or, [t1;t2]) r +let mkImp (t1, t2) r = match t1.tm, t2.tm with + | _, App(TrueOp, _) + | App(FalseOp, _), _ -> mkTrue r + | App(TrueOp, _), _ -> t2 + | _, App(Imp, [t1'; t2']) -> mkApp'(Imp, [mkAnd(t1, t1') r; t2']) r + | _ -> mkApp'(Imp, [t1; t2]) r + +let mk_bin_op op (t1,t2) r = mkApp'(op, [t1;t2]) r +let mkMinus t r = mkApp'(Minus, [t]) r +let mkNatToBv sz t r = mkApp'(NatToBv sz, [t]) r +let mkBvUext sz t r = mkApp'(BvUext sz, [t]) r +let mkBvToNat t r = mkApp'(BvToNat, [t]) r +let mkBvAnd = mk_bin_op BvAnd +let mkBvXor = mk_bin_op BvXor +let mkBvOr = mk_bin_op BvOr +let mkBvAdd = mk_bin_op BvAdd +let mkBvSub = mk_bin_op BvSub +let mkBvShl sz (t1, t2) r = mkApp'(BvShl, [t1;(mkNatToBv sz t2 r)]) r +let mkBvShr sz (t1, t2) r = mkApp'(BvShr, [t1;(mkNatToBv sz t2 r)]) r +let mkBvUdiv sz (t1, t2) r = mkApp'(BvUdiv, [t1;(mkNatToBv sz t2 r)]) r +let mkBvMod sz (t1, t2) r = mkApp'(BvMod, [t1;(mkNatToBv sz t2 r)]) r +let mkBvMul sz (t1, t2) r = mkApp' (BvMul, [t1;(mkNatToBv sz t2 r)]) r +let mkBvShl' sz (t1, t2) r = mkApp'(BvShl, [t1;t2]) r +let mkBvShr' sz (t1, t2) r = mkApp'(BvShr, [t1;t2]) r +let mkBvMul' sz (t1, t2) r = mkApp' (BvMul, [t1;t2]) r +let mkBvUdivUnsafe sz (t1, t2) r = mkApp'(BvUdiv, [t1;t2]) r +let mkBvModUnsafe sz (t1, t2) r = mkApp'(BvMod, [t1;t2]) r +let mkBvUlt = mk_bin_op BvUlt +let mkIff = mk_bin_op Iff +let mkEq (t1, t2) r = match t1.tm, t2.tm with + | App (Var f1, [s1]), App (Var f2, [s2]) when f1 = f2 && isInjective f1 -> + mk_bin_op Eq (s1, s2) r + | _ -> mk_bin_op Eq (t1, t2) r +let mkLT = mk_bin_op LT +let mkLTE = mk_bin_op LTE +let mkGT = mk_bin_op GT +let mkGTE = mk_bin_op GTE +let mkAdd = mk_bin_op Add +let mkSub = mk_bin_op Sub +let mkDiv = mk_bin_op Div +let mkRealDiv = mk_bin_op RealDiv +let mkMul = mk_bin_op Mul +let mkMod = mk_bin_op Mod +let mkRealOfInt t r = mkApp ("to_real", [t]) r +let mkITE (t1, t2, t3) r = + match t1.tm with + | App(TrueOp, _) -> t2 + | App(FalseOp, _) -> t3 + | _ -> begin + match t2.tm, t3.tm with + | App(TrueOp,_), App(TrueOp, _) -> mkTrue r + | App(TrueOp,_), _ -> mkImp (mkNot t1 t1.rng, t3) r + | _, App(TrueOp, _) -> mkImp(t1, t2) r + | _, _ -> mkApp'(ITE, [t1; t2; t3]) r + end +let mkCases t r = match t with + | [] -> failwith "Impos" + | hd::tl -> List.fold_left (fun out t -> mkAnd (out, t) r) hd tl + + +let check_pattern_ok (t:term) : option term = + let rec aux t = + match t.tm with + | Integer _ + | String _ + | Real _ + | BoundV _ + | FreeV _ -> None + | Let(tms, tm) -> + aux_l (tm::tms) + | App(head, terms) -> + let head_ok = + match head with + | Var _ -> true + | TrueOp + | FalseOp -> true + | Not + | And + | Or + | Imp + | Iff + | Eq -> false + | LT + | LTE + | GT + | GTE + | Add + | Sub + | Div + | RealDiv + | Mul + | Minus + | Mod -> true + | BvAnd + | BvXor + | BvOr + | BvAdd + | BvSub + | BvShl + | BvShr + | BvUdiv + | BvMod + | BvMul + | BvUlt + | BvUext _ + | NatToBv _ + | BvToNat + | ITE -> false + in + if not head_ok then Some t + else aux_l terms + | Labeled(t, _, _) -> + aux t + | Quant _ + | LblPos _ -> Some t + and aux_l ts = + match ts with + | [] -> None + | t::ts -> + match aux t with + | Some t -> Some t + | None -> aux_l ts + in + aux t + + let rec print_smt_term (t:term) :string = + match t.tm with + | Integer n -> BU.format1 "(Integer %s)" n + | String s -> BU.format1 "(String %s)" s + | Real r -> BU.format1 "(Real %s)" r + | BoundV n -> BU.format1 "(BoundV %s)" (BU.string_of_int n) + | FreeV fv -> BU.format1 "(FreeV %s)" (fv_name fv) + | App (op, l) -> BU.format2 "(%s %s)" (op_to_string op) (print_smt_term_list l) + | Labeled(t, r1, r2) -> BU.format2 "(Labeled '%s' %s)" (Errors.Msg.rendermsg r1) (print_smt_term t) + | LblPos(t, s) -> BU.format2 "(LblPos %s %s)" s (print_smt_term t) + | Quant (qop, l, _, _, t) -> BU.format3 "(%s %s %s)" (qop_to_string qop) (print_smt_term_list_list l) (print_smt_term t) + | Let (es, body) -> BU.format2 "(let %s %s)" (print_smt_term_list es) (print_smt_term body) + +and print_smt_term_list (l:list term) :string = List.map print_smt_term l |> String.concat " " + +and print_smt_term_list_list (l:list (list term)) :string = + List.fold_left (fun s l -> (s ^ "; [ " ^ (print_smt_term_list l) ^ " ] ")) "" l + +let mkQuant r check_pats (qop, pats, wopt, vars, body) = + let all_pats_ok pats = + if not check_pats then pats else + match BU.find_map pats (fun x -> BU.find_map x check_pattern_ok) with + | None -> pats + | Some p -> + begin + Errors.log_issue r Errors.Warning_SMTPatternIllFormed + (BU.format1 "Pattern (%s) contains illegal symbols; dropping it" (print_smt_term p)); + [] + end + in + if List.length vars = 0 then body + else match body.tm with + | App(TrueOp, _) -> body + | _ -> mk (Quant(qop, all_pats_ok pats, wopt, vars, body)) r + +let mkLet (es, body) r = + if List.length es = 0 then body + else mk (Let (es,body)) r + +(*****************************************************) +(* abstracting free names; instantiating bound vars *) +(*****************************************************) +let abstr fvs t = //fvs is a subset of the free vars of t; the result closes over fvs + let nvars = List.length fvs in + let index_of fv = match BU.try_find_index (fv_eq fv) fvs with + | None -> None + | Some i -> Some (nvars - (i + 1)) + in + let rec aux ix t = + match !t.freevars with + | Some [] -> t + | _ -> + begin match t.tm with + | Integer _ + | String _ + | Real _ + | BoundV _ -> t + | FreeV x -> + begin match index_of x with + | None -> t + | Some i -> mkBoundV (i + ix) t.rng + end + | App(op, tms) -> mkApp'(op, List.map (aux ix) tms) t.rng + | Labeled(t, r1, r2) -> mk (Labeled(aux ix t, r1, r2)) t.rng + | LblPos(t, r) -> mk (LblPos(aux ix t, r)) t.rng + | Quant(qop, pats, wopt, vars, body) -> + let n = List.length vars in + mkQuant t.rng false (qop, pats |> List.map (List.map (aux (ix + n))), wopt, vars, aux (ix + n) body) + | Let (es, body) -> + let ix, es_rev = List.fold_left (fun (ix, l) e -> ix+1, aux ix e::l) (ix, []) es in + mkLet (List.rev es_rev, aux ix body) t.rng + end + in + aux 0 t + +let inst tms t = + let tms = List.rev tms in //forall x y . t ... y is an index 0 in t + let n = List.length tms in //instantiate the first n BoundV's with tms, in order + let rec aux shift t = match t.tm with + | Integer _ + | String _ + | Real _ + | FreeV _ -> t + | BoundV i -> + if 0 <= i - shift && i - shift < n + then List.nth tms (i - shift) + else t + | App(op, tms) -> mkApp'(op, List.map (aux shift) tms) t.rng + | Labeled(t, r1, r2) -> mk (Labeled(aux shift t, r1, r2)) t.rng + | LblPos(t, r) -> mk (LblPos(aux shift t, r)) t.rng + | Quant(qop, pats, wopt, vars, body) -> + let m = List.length vars in + let shift = shift + m in + mkQuant t.rng false (qop, pats |> List.map (List.map (aux shift)), wopt, vars, aux shift body) + | Let (es, body) -> + let shift, es_rev = List.fold_left (fun (ix, es) e -> shift+1, aux shift e::es) (shift, []) es in + mkLet (List.rev es_rev, aux shift body) t.rng + in + aux 0 t + +let subst (t:term) (fv:fv) (s:term) = inst [s] (abstr [fv] t) +let mkQuant' r (qop, pats, wopt, vars, body) = + mkQuant r true (qop, pats |> List.map (List.map (abstr vars)), wopt, List.map fv_sort vars, abstr vars body) + +//these are the external facing functions for building quantifiers +let mkForall r (pats, vars, body) = + mkQuant' r (Forall, pats, None, vars, body) +let mkForall'' r (pats, wopt, sorts, body) = + mkQuant r true (Forall, pats, wopt, sorts, body) +let mkForall' r (pats, wopt, vars, body) = + mkQuant' r (Forall, pats, wopt, vars, body) +let mkExists r (pats, vars, body) = + mkQuant' r (Exists, pats, None, vars, body) + +let mkLet' (bindings, body) r = + let vars, es = List.split bindings in + mkLet (es, abstr vars body) r + +let norng = Range.dummyRange +let mkDefineFun (nm, vars, s, tm, c) = DefineFun(nm, List.map fv_sort vars, s, abstr vars tm, c) +let constr_id_of_sort sort = format1 "%s_constr_id" (strSort sort) +let fresh_token (tok_name, sort) id = + let a_name = "fresh_token_" ^tok_name in + let tm = mkEq(mkInteger' id norng, + mkApp(constr_id_of_sort sort, + [mkApp (tok_name,[]) norng]) norng) norng in + let a = {assumption_name=escape a_name; + assumption_caption=Some "fresh token"; + assumption_term=tm; + assumption_fact_ids=[]; + assumption_free_names=free_top_level_names tm} in + Assume a + +let fresh_constructor rng (name, arg_sorts, sort, id) = + let id = string_of_int id in + let bvars = arg_sorts |> List.mapi (fun i s -> mkFreeV(mk_fv ("x_" ^ string_of_int i, s)) norng) in + let bvar_names = List.map fv_of_term bvars in + let capp = mkApp(name, bvars) norng in + let cid_app = mkApp(constr_id_of_sort sort, [capp]) norng in + let a_name = "constructor_distinct_" ^name in + let tm = mkForall rng ([[capp]], bvar_names, mkEq(mkInteger id norng, cid_app) norng) in + let a = { + assumption_name=escape a_name; + assumption_caption=Some "Constructor distinct"; + assumption_term=tm; + assumption_fact_ids=[]; + assumption_free_names=free_top_level_names tm + } in + Assume a + +let injective_constructor + (rng:Range.range) + ((name, fields, sort):(string & list constructor_field & sort)) :list decl = + let n_bvars = List.length fields in + let bvar_name i = "x_" ^ string_of_int i in + let bvar_index i = n_bvars - (i + 1) in + let bvar i s = mkFreeV <| mk_fv (bvar_name i, s) in + let bvars = fields |> List.mapi (fun i f -> bvar i f.field_sort norng) in + let bvar_names = List.map fv_of_term bvars in + let capp = mkApp(name, bvars) norng in + fields + |> List.mapi (fun i {field_projectible=projectible; field_name=name; field_sort=s} -> + if projectible + then + let cproj_app = mkApp(name, [capp]) norng in + let proj_name = DeclFun(name, [sort], s, Some "Projector") in + let tm = mkForall rng ([[capp]], bvar_names, mkEq(cproj_app, bvar i s norng) norng) in + let a = { + assumption_name = escape ("projection_inverse_"^name); + assumption_caption = Some "Projection inverse"; + assumption_term = tm; + assumption_fact_ids = []; + assumption_free_names = free_top_level_names tm + } in + [proj_name; Assume a] + else []) + |> List.flatten + +let discriminator_name constr = "is-"^constr.constr_name + +let constructor_to_decl rng constr = + let sort = constr.constr_sort in + let field_sorts = constr.constr_fields |> List.map (fun f -> f.field_sort) in + let cdecl = DeclFun(constr.constr_name, field_sorts, constr.constr_sort, Some "Constructor") in + let cid = + match constr.constr_id with + | None -> [] + | Some id -> [fresh_constructor rng (constr.constr_name, field_sorts, sort, id)] + in + let disc = + let disc_name = discriminator_name constr in + let xfv = mk_fv ("x", sort) in + let xx = mkFreeV xfv norng in + let proj_terms, ex_vars = + constr.constr_fields + |> List.mapi (fun i {field_projectible=projectible; field_sort=s; field_name=proj} -> + if projectible + then mkApp(proj, [xx]) norng, [] + else let fi = mk_fv ("f_" ^ BU.string_of_int i, s) in + mkFreeV fi norng, [fi]) + |> List.split in + let ex_vars = List.flatten ex_vars in + let disc_inv_body = mkEq(xx, mkApp(constr.constr_name, proj_terms) norng) norng in + let disc_inv_body = match ex_vars with + | [] -> disc_inv_body + | _ -> mkExists norng ([], ex_vars, disc_inv_body) in + let disc_ax = + match constr.constr_id with + | None -> disc_inv_body + | Some id -> + let disc_eq = mkEq(mkApp(constr_id_of_sort constr.constr_sort, [xx]) norng, mkInteger (string_of_int id) norng) norng in + mkAnd(disc_eq, disc_inv_body) norng in + let def = mkDefineFun(disc_name, [xfv], Bool_sort, + disc_ax, + Some "Discriminator definition") in + def in + let projs = injective_constructor rng (constr.constr_name, constr.constr_fields, sort) in + let base = + if not constr.constr_base + then [] + else ( + let arg_sorts = + constr.constr_fields + |> List.filter (fun f -> f.field_projectible) + |> List.map (fun _ -> Term_sort) + in + let base_name = constr.constr_name ^ "@base" in + let decl = DeclFun(base_name, arg_sorts, Term_sort, Some "Constructor base") in + let formals = List.mapi (fun i _ -> mk_fv ("x" ^ string_of_int i, Term_sort)) constr.constr_fields in + let constructed_term = mkApp(constr.constr_name, List.map (fun fv -> mkFreeV fv norng) formals) norng in + let inj_formals = List.flatten <| List.map2 (fun f fld -> if fld.field_projectible then [f] else []) formals constr.constr_fields in + let base_term = mkApp(base_name, List.map (fun fv -> mkFreeV fv norng) inj_formals) norng in + let eq = mkEq(constructed_term, base_term) norng in + let guard = mkApp(discriminator_name constr, [constructed_term]) norng in + let q = mkForall rng ([[constructed_term]], formals, mkImp (guard, eq) norng) in + //forall (x0...xn:Term). {:pattern (C x0 ...xn)} is-C (C x0..xn) ==> C x0..xn == C-base x2 x3..xn + let a = { + assumption_name=escape ("constructor_base_" ^ constr.constr_name); + assumption_caption=Some "Constructor base"; + assumption_term=q; + assumption_fact_ids=[]; + assumption_free_names=free_top_level_names q + } in + [decl; Assume a] + ) + in + Caption (format1 "" constr.constr_name):: + [cdecl]@cid@projs@[disc]@base + @[Caption (format1 "" constr.constr_name)] + +(****************************************************************************) +(* Standard SMTLib prelude for F* and some term constructors *) +(****************************************************************************) +let name_binders_inner prefix_opt (outer_names:list fv) start sorts = + let names, binders, n = sorts |> List.fold_left (fun (names, binders, n) s -> + let prefix = match s with + | Term_sort -> "@x" + | _ -> "@u" in + let prefix = + match prefix_opt with + | None -> prefix + | Some p -> p ^ prefix in + let nm = prefix ^ string_of_int n in + let names = mk_fv (nm,s)::names in + let b = BU.format2 "(%s %s)" nm (strSort s) in + names, b::binders, n+1) + (outer_names, [], start) in + names, List.rev binders, n + +let name_macro_binders sorts = + let names, binders, n = name_binders_inner (Some "__") [] 0 sorts in + List.rev names, binders + +let termToSmt + : print_ranges:bool -> enclosing_name:string -> t:term -> string + = + //a counter and a hash table for string constants to integer ids mapping + let string_id_counter = BU.mk_ref 0 in + let string_cache= BU.smap_create 20 in + + fun print_ranges enclosing_name t -> + let next_qid = + let ctr = BU.mk_ref 0 in + fun depth -> + let n = !ctr in + BU.incr ctr; + if n = 0 then enclosing_name + else BU.format2 "%s.%s" enclosing_name (BU.string_of_int n) + in + let remove_guard_free pats = + pats |> List.map (fun ps -> + ps |> List.map (fun tm -> + match tm.tm with + | App(Var "Prims.guard_free", [{tm=BoundV _}]) -> tm + | App(Var "Prims.guard_free", [p]) -> p + | _ -> tm)) + in + let rec aux' depth n (names:list fv) t = + let aux = aux (depth + 1) in + match t.tm with + | Integer i -> i + | Real r -> r + | String s -> + let id_opt = BU.smap_try_find string_cache s in + (match id_opt with + | Some id -> id + | None -> + let id = !string_id_counter |> string_of_int in + BU.incr string_id_counter; + BU.smap_add string_cache s id; + id) + | BoundV i -> + List.nth names i |> fv_name + | FreeV x when fv_force x -> "(" ^ fv_name x ^ " Dummy_value)" //force a thunked name + | FreeV x -> fv_name x + | App(op, []) -> op_to_string op + | App(op, tms) -> BU.format2 "(%s %s)" (op_to_string op) (List.map (aux n names) tms |> String.concat "\n") + | Labeled(t, _, _) -> aux n names t + | LblPos(t, s) -> BU.format2 "(! %s :lblpos %s)" (aux n names t) s + | Quant(qop, pats, wopt, sorts, body) -> + let qid = next_qid () in + let names, binders, n = name_binders_inner None names n sorts in + let binders = binders |> String.concat " " in + let pats = remove_guard_free pats in + let pats_str = + match pats with + | [[]] + | [] -> if print_ranges then ";;no pats" else "" + | _ -> + pats + |> List.map (fun pats -> + format1 "\n:pattern (%s)" (String.concat " " (List.map (fun p -> + format1 "%s" (aux n names p)) pats))) + |> String.concat "\n" + in + BU.format "(%s (%s)\n (! %s\n %s\n%s\n:qid %s))" + [qop_to_string qop; + binders; + aux n names body; + weightToSmt wopt; + pats_str; + qid] + + | Let (es, body) -> + (* binders are reversed but according to the smt2 standard *) + (* substitution should occur in parallel and order should not matter *) + let names, binders, n = + List.fold_left (fun (names0, binders, n0) e -> + let nm = "@lb" ^ string_of_int n0 in + let names0 = mk_fv (nm, Term_sort)::names0 in + let b = BU.format2 "(%s %s)" nm (aux n names e) in + names0, b::binders, n0+1) + (names, [], n) + es + in + BU.format2 "(let (%s)\n%s)" + (String.concat " " binders) + (aux n names body) + + and aux depth n names t = + let s = aux' depth n names t in + if print_ranges && t.rng <> norng + then BU.format3 "\n;; def=%s; use=%s\n%s\n" (Range.string_of_range t.rng) (Range.string_of_use_range t.rng) s + else s + in + aux 0 0 [] t + +let caption_to_string print_captions = + function + | Some c + when print_captions -> + let c = String.split ['\n'] c |> List.map BU.trim_string |> String.concat " " in + ";;;;;;;;;;;;;;;;" ^ c ^ "\n" + | _ -> "" + + +let rec declToSmt' print_captions z3options decl = + match decl with + | DefPrelude -> + mkPrelude z3options + | Module (s, decls) -> + let res = List.map (declToSmt' print_captions z3options) decls |> String.concat "\n" in + if Options.keep_query_captions() + then BU.format5 "\n;;; Start %s\n%s\n;;; End %s (%s decls; total size %s)" + s + res + s + (BU.string_of_int (List.length decls)) + (BU.string_of_int (String.length res)) + else res + | Caption c -> + if print_captions + then "\n" ^ (BU.splitlines c |> List.map (fun s -> "; " ^ s ^ "\n") |> String.concat "") + else "" + | DeclFun(f,argsorts,retsort,c) -> + let l = List.map strSort argsorts in + format4 "%s(declare-fun %s (%s) %s)" + (caption_to_string print_captions c) + f + (String.concat " " l) + (strSort retsort) + | DefineFun(f,arg_sorts,retsort,body,c) -> + let names, binders = name_macro_binders arg_sorts in + let body = inst (List.map (fun x -> mkFreeV x norng) names) body in + format5 "%s(define-fun %s (%s) %s\n %s)" + (caption_to_string print_captions c) + f + (String.concat " " binders) + (strSort retsort) + (termToSmt print_captions (escape f) body) + | Assume a -> + let fact_ids_to_string ids = + ids |> List.map (function + | Name n -> "Name " ^ Ident.string_of_lid n + | Namespace ns -> "Namespace " ^ Ident.string_of_lid ns + | Tag t -> "Tag " ^t) + in + let fids = + if print_captions + then BU.format1 ";;; Fact-ids: %s\n" + (String.concat "; " (fact_ids_to_string a.assumption_fact_ids)) + else "" in + let n = a.assumption_name in + format4 "%s%s(assert (! %s\n:named %s))" + (caption_to_string print_captions a.assumption_caption) + fids + (termToSmt print_captions n a.assumption_term) + n + | Eval t -> + format1 "(eval %s)" (termToSmt print_captions "eval" t) + | Echo s -> + format1 "(echo \"%s\")" s + | RetainAssumptions _ -> + "" + | CheckSat -> "(echo \"\")\n(check-sat)\n(echo \"\")" + | GetUnsatCore -> "(echo \"\")\n(get-unsat-core)\n(echo \"\")" + | Push n -> BU.format1 "(push) ;; push{%s" (show n) + | Pop n -> BU.format1 "(pop) ;; %s}pop" (show n) + | SetOption (s, v) -> format2 "(set-option :%s %s)" s v + | GetStatistics -> "(echo \"\")\n(get-info :all-statistics)\n(echo \"\")" + | GetReasonUnknown-> "(echo \"\")\n(get-info :reason-unknown)\n(echo \"\")" + +and declToSmt z3options decl = declToSmt' (Options.keep_query_captions()) z3options decl + +and mkPrelude z3options = + let basic = z3options ^ + "(declare-sort FString)\n\ + (declare-fun FString_constr_id (FString) Int)\n\ + \n\ + (declare-sort Term)\n\ + (declare-fun Term_constr_id (Term) Int)\n\ + (declare-sort Dummy_sort)\n\ + (declare-fun Dummy_value () Dummy_sort)\n\ + (declare-datatypes () ((Fuel \n\ + (ZFuel) \n\ + (SFuel (prec Fuel)))))\n\ + (declare-fun MaxIFuel () Fuel)\n\ + (declare-fun MaxFuel () Fuel)\n\ + (declare-fun PreType (Term) Term)\n\ + (declare-fun Valid (Term) Bool)\n\ + (declare-fun HasTypeFuel (Fuel Term Term) Bool)\n\ + (define-fun HasTypeZ ((x Term) (t Term)) Bool\n\ + (HasTypeFuel ZFuel x t))\n\ + (define-fun HasType ((x Term) (t Term)) Bool\n\ + (HasTypeFuel MaxIFuel x t))\n\ + (declare-fun IsTotFun (Term) Bool)\n + ;;fuel irrelevance\n\ + (assert (forall ((f Fuel) (x Term) (t Term))\n\ + (! (= (HasTypeFuel (SFuel f) x t)\n\ + (HasTypeZ x t))\n\ + :pattern ((HasTypeFuel (SFuel f) x t)))))\n\ + (declare-fun NoHoist (Term Bool) Bool)\n\ + ;;no-hoist\n\ + (assert (forall ((dummy Term) (b Bool))\n\ + (! (= (NoHoist dummy b)\n\ + b)\n\ + :pattern ((NoHoist dummy b)))))\n\ + (define-fun IsTyped ((x Term)) Bool\n\ + (exists ((t Term)) (HasTypeZ x t)))\n\ + (declare-fun ApplyTF (Term Fuel) Term)\n\ + (declare-fun ApplyTT (Term Term) Term)\n\ + (declare-fun Prec (Term Term) Bool)\n\ + (assert (forall ((x Term) (y Term) (z Term))\n\ + (! (implies (and (Prec x y) (Prec y z))\n\ + (Prec x z)) + :pattern ((Prec x z) (Prec x y)))))\n\ + (assert (forall ((x Term) (y Term))\n\ + (implies (Prec x y)\n\ + (not (Prec y x)))))\n\ + (declare-fun Closure (Term) Term)\n\ + (declare-fun ConsTerm (Term Term) Term)\n\ + (declare-fun ConsFuel (Fuel Term) Term)\n\ + (declare-fun Tm_uvar (Int) Term)\n\ + (define-fun Reify ((x Term)) Term x)\n\ + (declare-fun Prims.precedes (Term Term Term Term) Term)\n\ + (declare-fun Range_const (Int) Term)\n\ + (declare-fun _mul (Int Int) Int)\n\ + (declare-fun _div (Int Int) Int)\n\ + (declare-fun _mod (Int Int) Int)\n\ + (declare-fun __uu__PartialApp () Term)\n\ + (assert (forall ((x Int) (y Int)) (! (= (_mul x y) (* x y)) :pattern ((_mul x y)))))\n\ + (assert (forall ((x Int) (y Int)) (! (= (_div x y) (div x y)) :pattern ((_div x y)))))\n\ + (assert (forall ((x Int) (y Int)) (! (= (_mod x y) (mod x y)) :pattern ((_mod x y)))))\n\ + (declare-fun _rmul (Real Real) Real)\n\ + (declare-fun _rdiv (Real Real) Real)\n\ + (assert (forall ((x Real) (y Real)) (! (= (_rmul x y) (* x y)) :pattern ((_rmul x y)))))\n\ + (assert (forall ((x Real) (y Real)) (! (= (_rdiv x y) (/ x y)) :pattern ((_rdiv x y)))))\n\ + (define-fun Unreachable () Bool false)" + in + let as_constr (name, fields, sort, id, _injective) + : constructor_t + = { constr_name=name; + constr_fields=List.map (fun (field_name, field_sort, field_projectible) -> {field_name; field_sort; field_projectible}) fields; + constr_sort=sort; + constr_id=Some id; + constr_base=false } + in + let constrs : constructors = + List.map as_constr + [("FString_const", ["FString_const_proj_0", Int_sort, true], String_sort, 0, true); + ("Tm_type", [], Term_sort, 2, true); + ("Tm_arrow", [("Tm_arrow_id", Int_sort, true)], Term_sort, 3, false); + ("Tm_unit", [], Term_sort, 6, true); + (fst boxIntFun, [snd boxIntFun, Int_sort, true], Term_sort, 7, true); + (fst boxBoolFun, [snd boxBoolFun, Bool_sort, true], Term_sort, 8, true); + (fst boxStringFun, [snd boxStringFun, String_sort, true], Term_sort, 9, true); + (fst boxRealFun, [snd boxRealFun, Sort "Real", true], Term_sort, 10, true)] in + let bcons = constrs |> List.collect (constructor_to_decl norng) + |> List.map (declToSmt z3options) |> String.concat "\n" in + + let precedes_partial_app = "\n\ + (declare-fun Prims.precedes@tok () Term)\n\ + (assert\n\ + (forall ((@x0 Term) (@x1 Term) (@x2 Term) (@x3 Term))\n\ + (! (= (ApplyTT (ApplyTT (ApplyTT (ApplyTT Prims.precedes@tok\n\ + @x0)\n\ + @x1)\n\ + @x2)\n\ + @x3)\n\ + (Prims.precedes @x0 @x1 @x2 @x3))\n\ + \n\ + :pattern ((ApplyTT (ApplyTT (ApplyTT (ApplyTT Prims.precedes@tok\n\ + @x0)\n\ + @x1)\n\ + @x2)\n\ + @x3)))))\n" in + + let lex_ordering = "\n(declare-fun Prims.lex_t () Term)\n\ + (assert (forall ((t1 Term) (t2 Term) (e1 Term) (e2 Term))\n\ + (! (iff (Valid (Prims.precedes t1 t2 e1 e2))\n\ + (Valid (Prims.precedes Prims.lex_t Prims.lex_t e1 e2)))\n\ + :pattern (Prims.precedes t1 t2 e1 e2))))\n\ + (assert (forall ((t1 Term) (t2 Term))\n\ + (! (iff (Valid (Prims.precedes Prims.lex_t Prims.lex_t t1 t2)) \n\ + (Prec t1 t2))\n\ + :pattern ((Prims.precedes Prims.lex_t Prims.lex_t t1 t2)))))\n" in + + let valid_intro = + "(assert (forall ((e Term) (t Term))\n\ + (! (implies (HasType e t)\n\ + (Valid t))\n\ + :pattern ((HasType e t)\n\ + (Valid t))\n\ + :qid __prelude_valid_intro)))\n" + in + let valid_elim = + "(assert (forall ((t Term))\n\ + (! (implies (Valid t)\n\ + (exists ((e Term)) (HasType e t)))\n\ + :pattern ((Valid t))\n\ + :qid __prelude_valid_elim)))\n" + in + basic + ^ bcons + ^ precedes_partial_app + ^ lex_ordering + ^ (if FStarC.Options.smtencoding_valid_intro() + then valid_intro + else "") + ^ (if FStarC.Options.smtencoding_valid_elim() + then valid_elim + else "") + +let declsToSmt z3options decls = List.map (declToSmt z3options) decls |> String.concat "\n" +let declToSmt_no_caps z3options decl = declToSmt' false z3options decl + +(* Generate boxing/unboxing functions for bitvectors of various sizes. *) +(* For ids, to avoid dealing with generation of fresh ids, + I am computing them based on the size in this not very robust way. + z3options are only used by the prelude so passing the empty string should be ok. *) +let mkBvConstructor (sz : int) = + let constr : constructor_t = { + constr_name=fst (boxBitVecFun sz); + constr_sort=Term_sort; + constr_id=None; + constr_fields=[{field_projectible=true; field_name=snd (boxBitVecFun sz); field_sort=BitVec_sort sz }]; + constr_base=false + } in + constructor_to_decl norng constr, + constr.constr_name, + discriminator_name constr + +let __range_c = BU.mk_ref 0 +let mk_Range_const () = + let i = !__range_c in + __range_c := !__range_c + 1; + mkApp("Range_const", [mkInteger' i norng]) norng + +let mk_Term_type = mkApp("Tm_type", []) norng +let mk_Term_app t1 t2 r = mkApp("Tm_app", [t1;t2]) r +let mk_Term_uvar i r = mkApp("Tm_uvar", [mkInteger' i norng]) r +let mk_Term_unit = mkApp("Tm_unit", []) norng +let elim_box cond u v t = + match t.tm with + | App(Var v', [t]) when v=v' && cond -> t + | _ -> mkApp(u, [t]) t.rng +let maybe_elim_box u v t = + elim_box (Options.smtencoding_elim_box()) u v t +let boxInt t = maybe_elim_box (fst boxIntFun) (snd boxIntFun) t +let unboxInt t = maybe_elim_box (snd boxIntFun) (fst boxIntFun) t +let boxBool t = maybe_elim_box (fst boxBoolFun) (snd boxBoolFun) t +let unboxBool t = maybe_elim_box (snd boxBoolFun) (fst boxBoolFun) t +let boxString t = maybe_elim_box (fst boxStringFun) (snd boxStringFun) t +let unboxString t = maybe_elim_box (snd boxStringFun) (fst boxStringFun) t +let boxReal t = maybe_elim_box (fst boxRealFun) (snd boxRealFun) t +let unboxReal t = maybe_elim_box (snd boxRealFun) (fst boxRealFun) t +let boxBitVec (sz:int) t = + elim_box true (fst (boxBitVecFun sz)) (snd (boxBitVecFun sz)) t +let unboxBitVec (sz:int) t = + elim_box true (snd (boxBitVecFun sz)) (fst (boxBitVecFun sz)) t +let boxTerm sort t = match sort with + | Int_sort -> boxInt t + | Bool_sort -> boxBool t + | String_sort -> boxString t + | BitVec_sort sz -> boxBitVec sz t + | Sort "Real" -> boxReal t + | _ -> raise Impos +let unboxTerm sort t = match sort with + | Int_sort -> unboxInt t + | Bool_sort -> unboxBool t + | String_sort -> unboxString t + | BitVec_sort sz -> unboxBitVec sz t + | Sort "Real" -> unboxReal t + | _ -> raise Impos + +let getBoxedInteger (t:term) = + match t.tm with + | App(Var s, [t2]) when s = fst boxIntFun -> + begin + match t2.tm with + | Integer n -> Some (int_of_string n) + | _ -> None + end + | _ -> None + +let mk_PreType t = mkApp("PreType", [t]) t.rng +let mk_Valid t = match t.tm with + | App(Var "Prims.b2t", [{tm=App(Var "Prims.op_Equality", [_; t1; t2])}]) -> mkEq (t1, t2) t.rng + | App(Var "Prims.b2t", [{tm=App(Var "Prims.op_disEquality", [_; t1; t2])}]) -> mkNot (mkEq (t1, t2) norng) t.rng + | App(Var "Prims.b2t", [{tm=App(Var "Prims.op_LessThanOrEqual", [t1; t2])}]) -> mkLTE (unboxInt t1, unboxInt t2) t.rng + | App(Var "Prims.b2t", [{tm=App(Var "Prims.op_LessThan", [t1; t2])}]) -> mkLT (unboxInt t1, unboxInt t2) t.rng + | App(Var "Prims.b2t", [{tm=App(Var "Prims.op_GreaterThanOrEqual", [t1; t2])}]) -> mkGTE (unboxInt t1, unboxInt t2) t.rng + | App(Var "Prims.b2t", [{tm=App(Var "Prims.op_GreaterThan", [t1; t2])}]) -> mkGT (unboxInt t1, unboxInt t2) t.rng + | App(Var "Prims.b2t", [{tm=App(Var "Prims.op_AmpAmp", [t1; t2])}]) -> mkAnd (unboxBool t1, unboxBool t2) t.rng + | App(Var "Prims.b2t", [{tm=App(Var "Prims.op_BarBar", [t1; t2])}]) -> mkOr (unboxBool t1, unboxBool t2) t.rng + | App(Var "Prims.b2t", [{tm=App(Var "Prims.op_Negation", [t])}]) -> mkNot (unboxBool t) t.rng + | App(Var "Prims.b2t", [{tm=App(Var "FStar.BV.bvult", [t0; t1;t2])}]) + | App(Var "Prims.equals", [_; {tm=App(Var "FStar.BV.bvult", [t0; t1;t2])}; _]) + when (FStarC.Compiler.Util.is_some (getBoxedInteger t0))-> + // sometimes b2t gets needlessly normalized... + let sz = match getBoxedInteger t0 with | Some sz -> sz | _ -> failwith "impossible" in + mkBvUlt (unboxBitVec sz t1, unboxBitVec sz t2) t.rng + | App(Var "Prims.b2t", [t1]) -> {unboxBool t1 with rng=t.rng} + | _ -> + mkApp("Valid", [t]) t.rng +let mk_unit_type = mkApp("Prims.unit", []) norng +let mk_subtype_of_unit v = mkApp("Prims.subtype_of", [v;mk_unit_type]) v.rng +let mk_HasType v t = mkApp("HasType", [v;t]) t.rng +let mk_HasTypeZ v t = mkApp("HasTypeZ", [v;t]) t.rng +let mk_IsTotFun t = mkApp("IsTotFun", [t]) t.rng +let mk_HasTypeFuel f v t = + if Options.unthrottle_inductives() + then mk_HasType v t + else mkApp("HasTypeFuel", [f;v;t]) t.rng +let mk_HasTypeWithFuel f v t = match f with + | None -> mk_HasType v t + | Some f -> mk_HasTypeFuel f v t +let mk_NoHoist dummy b = mkApp("NoHoist", [dummy;b]) b.rng +let mk_tester n t = mkApp("is-"^n, [t]) t.rng +let mk_ApplyTF t t' = mkApp("ApplyTF", [t;t']) t.rng +let mk_ApplyTT t t' r = mkApp("ApplyTT", [t;t']) r +let kick_partial_app t = mk_ApplyTT (mkApp("__uu__PartialApp", []) t.rng) t t.rng |> mk_Valid +let mk_String_const s r = mkApp ("FString_const", [mk (String s) r]) r +let mk_Precedes x1 x2 x3 x4 r = mkApp("Prims.precedes", [x1;x2;x3;x4]) r|> mk_Valid +let rec n_fuel n = + if n = 0 then mkApp("ZFuel", []) norng + else mkApp("SFuel", [n_fuel (n - 1)]) norng + +let mk_and_l l r = List.fold_right (fun p1 p2 -> mkAnd(p1, p2) r) l (mkTrue r) + +let mk_or_l l r = List.fold_right (fun p1 p2 -> mkOr(p1,p2) r) l (mkFalse r) + +let mk_haseq t = mk_Valid (mkApp ("Prims.hasEq", [t]) t.rng) +let dummy_sort = Sort "Dummy_sort" + +instance showable_smt_term = { + show = print_smt_term; +} + +instance showable_decl = { + show = declToSmt_no_caps ""; +} + +let rec names_of_decl d = + match d with + | Assume a -> [a.assumption_name] + | Module (_, ds) -> List.collect names_of_decl ds + | _ -> [] + +let decl_to_string_short d = + match d with + | DefPrelude -> "prelude" + | DeclFun (s, _, _, _) -> "DeclFun " ^ s + | DefineFun (s, _, _, _, _) -> "DefineFun " ^ s + | Assume a -> "Assumption " ^ a.assumption_name + | Caption s -> "Caption " ^s + | Module (s, _) -> "Module " ^ s + | Eval _ -> "Eval" + | Echo s -> "Echo " ^ s + | RetainAssumptions _ -> "RetainAssumptions" + | Push n -> BU.format1 "push %s" (show n) + | Pop n -> BU.format1 "pop %s" (show n) + | CheckSat -> "check-sat" + | GetUnsatCore -> "get-unsat-core" + | SetOption (s, v) -> "SetOption " ^ s ^ " " ^ v + | GetStatistics -> "get-statistics" + | GetReasonUnknown -> "get-reason-unknown" \ No newline at end of file diff --git a/src/smtencoding/FStarC.SMTEncoding.Term.fsti b/src/smtencoding/FStarC.SMTEncoding.Term.fsti new file mode 100644 index 00000000000..20a295af45f --- /dev/null +++ b/src/smtencoding/FStarC.SMTEncoding.Term.fsti @@ -0,0 +1,333 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.SMTEncoding.Term +open FStarC + +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.Util +open FStarC.Class.Show +open FStarC.Compiler.List +open FStarC.Class.Ord + +module S = FStarC.Syntax.Syntax + +type sort = + | Bool_sort + | Int_sort + | String_sort + | Term_sort + | Fuel_sort + | BitVec_sort of int + | Array of sort & sort + | Arrow of sort & sort + | Sort of string + +type op = + | TrueOp + | FalseOp + | Not + | And + | Or + | Imp + | Iff + | Eq + | LT + | LTE + | GT + | GTE + | Add + | Sub + | Div + | RealDiv + | Mul + | Minus + | Mod + | BvAnd + | BvXor + | BvOr + | BvAdd + | BvSub + | BvShl + | BvShr + | BvUdiv + | BvMod + | BvMul + | BvUlt + | BvUext of int + | NatToBv of int + | BvToNat + | ITE + | Var of string + +type qop = + | Forall + | Exists + +type term' = + | Integer of string + | String of string + | Real of string + | BoundV of int + | FreeV of fv + | App of op & list term + | Quant of qop & list (list pat) & option int & list sort & term + | Let of list term & term + | Labeled of term & Errors.error_message & Range.range + | LblPos of term & string // FIXME: this case is unused +and pat = term +and term = {tm:term'; freevars:S.memo fvs; rng:Range.range} +and fv = | FV of string & sort & bool (* bool iff variable must be forced/unthunked *) +and fvs = list fv + +type caption = option string +type binders = list (string & sort) +type constructor_field = { + field_name:string; //name of the field + field_sort:sort; //sort of the field + field_projectible:bool//true if the field is projectible +} +type constructor_t = { + constr_name:string; + constr_fields:list constructor_field; + constr_sort:sort; + constr_id:option int; + //Some i, if a term whose head is this constructor is distinct from + //terms with other head constructors + constr_base: bool; //generate a base to eliminate non-injective arguments +} +type constructors = list constructor_t +type fact_db_id = + | Name of Ident.lid + | Namespace of Ident.lid + | Tag of string +type assumption = { + assumption_term: term; + assumption_caption: caption; + assumption_name: string; + assumption_fact_ids:list fact_db_id; + assumption_free_names: RBSet.t string; +} +type decl = + | DefPrelude + | DeclFun of string & list sort & sort & caption + | DefineFun of string & list sort & sort & term & caption + | Assume of assumption + | Caption of string + | Module of string & list decl + | Eval of term + | Echo of string + | RetainAssumptions of list string + | Push of int + | Pop of int + | CheckSat + | GetUnsatCore + | SetOption of string & string + | GetStatistics + | GetReasonUnknown + +(* + * AR: decls_elt captures a block of "related" decls + * For example, for a Tm_refine_ MD5 symbol, + * decls_elt will have its DeclFun, typing axioms, + * hasEq axiom, interpretation, etc. + * + * This allows the encoding of a module to be "stateless" + * in terms of hashconsing -- the encoding may contain + * duplicate such blocks + * + * Deduplication happens when giving the decls to Z3 + * at which point, if the key below -- which is the MD5 string -- + * matches, the whole block is dropped (see Encode.fs.recover_caching_and_update_env) + * + * Alternative way would have been to do some smt name matching + * but that would be sensitive to name strings and hence brittle + * + * Before the declarations are given to Z3, the remaining decls_elt + * left after deduplication are just "flattened" (using decls_list_of) + * + * sym_name and key are options for cases when we don't care about hashconsing + *) +type decls_elt = { + sym_name: option string; //name of the main synbol, e.g. Tm_refine_ MD5 + key: option string; //the MD5 string + decls: list decl; //list of decls, e.g. typing axioms, hasEq, for a Tm_refine + a_names: list string; //assumption names that must be kept IF this entry has a cache hit + //--used to not filter them when using_facts_from +} + +type decls_t = list decls_elt + +val fv_name : fv -> string +val fv_sort : fv -> sort +val fv_force : fv -> bool +val mk_fv : string & sort -> fv + + +(* + * AR: sym_name -> md5 -> auxiliary decls -> decls + * the auxilkiary decls are those that are not directly related to + * the symbol itself, but must be retained in case of cache hits + * for example, decls for argument types in the case of a Tm_arrow + *) +val mk_decls: string -> string -> list decl -> list decls_elt -> decls_t + +(* + * AR: for when we don't hashcons the decls + *) +val mk_decls_trivial: list decl -> decls_t + +(* + * Flatten the decls_t + *) +val decls_list_of: decls_t -> list decl + +type error_label = (fv & Errors.error_message & Range.range) +type error_labels = list error_label + +val escape: string -> string +val abstr: list fv -> term -> term +val inst: list term -> term -> term +val subst: term -> fv -> term -> term +val mk: term' -> Range.range -> term +val hash_of_term: term -> string +val boxIntFun : string & string +val boxBoolFun : string & string +val boxStringFun : string & string +val boxRealFun: string & string +val fv_eq : fv -> fv -> bool +val fv_of_term : term -> fv +val fvs_subset_of: fvs -> fvs -> bool +val free_variables: term -> fvs +val free_top_level_names : term -> RBSet.t string +val mkTrue : (Range.range -> term) +val mkFalse : (Range.range -> term) +val mkUnreachable : term +val mkInteger : string -> Range.range -> term +val mkInteger': int -> Range.range -> term +val mkReal: string -> Range.range -> term +val mkRealOfInt: term -> Range.range -> term +val mkBoundV : int -> Range.range -> term +val mkFreeV : fv -> Range.range -> term +val mkApp' : (op & list term) -> Range.range -> term +val mkApp : (string & list term) -> Range.range -> term +val mkNot : term -> Range.range -> term +val mkMinus: term -> Range.range -> term +val mkAnd : ((term & term) -> Range.range -> term) +val mkOr : ((term & term) -> Range.range -> term) +val mkImp : ((term & term) -> Range.range -> term) +val mkIff : ((term & term) -> Range.range -> term) +val mkEq : ((term & term) -> Range.range -> term) +val mkLT : ((term & term) -> Range.range -> term) +val mkLTE : ((term & term) -> Range.range -> term) +val mkGT: ((term & term) -> Range.range -> term) +val mkGTE: ((term & term) -> Range.range -> term) +val mkAdd: ((term & term) -> Range.range -> term) +val mkSub: ((term & term) -> Range.range -> term) +val mkDiv: ((term & term) -> Range.range -> term) +val mkRealDiv: ((term & term) -> Range.range -> term) +val mkMul: ((term & term) -> Range.range -> term) +val mkMod: ((term & term) -> Range.range -> term) +val mkNatToBv : (int -> term -> Range.range -> term) +val mkBvToNat : (term -> Range.range -> term) +val mkBvAnd : ((term & term) -> Range.range -> term) +val mkBvXor : ((term & term) -> Range.range -> term) +val mkBvOr : ((term & term) -> Range.range -> term) +val mkBvAdd : ((term & term) -> Range.range -> term) +val mkBvSub : ((term & term) -> Range.range -> term) +val mkBvUlt : ((term & term) -> Range.range -> term) +val mkBvUext : (int -> term -> Range.range -> term) +val mkBvShl : (int -> (term & term) -> Range.range -> term) +val mkBvShr : (int -> (term & term) -> Range.range -> term) +val mkBvUdiv : (int -> (term & term) -> Range.range -> term) +val mkBvMod : (int -> (term & term) -> Range.range -> term) +val mkBvMul : (int -> (term & term) -> Range.range -> term) +val mkBvShl' : (int -> (term & term) -> Range.range -> term) +val mkBvShr' : (int -> (term & term) -> Range.range -> term) +val mkBvUdivUnsafe : (int -> (term & term) -> Range.range -> term) +val mkBvModUnsafe : (int -> (term & term) -> Range.range -> term) +val mkBvMul' : (int -> (term & term) -> Range.range -> term) + +val mkITE: (term & term & term) -> Range.range -> term +val mkCases : list term -> Range.range -> term +val check_pattern_ok: term -> option term +val mkForall: Range.range -> (list (list pat) & fvs & term) -> term +val mkForall': Range.range -> (list (list pat) & option int & fvs & term) -> term +val mkForall'': Range.range -> (list (list pat) & option int & list sort & term) -> term +val mkExists: Range.range -> (list (list pat) & fvs & term) -> term +val mkLet: (list term & term) -> Range.range -> term +val mkLet': (list (fv & term) & term) -> Range.range -> term + +val fresh_token: (string & sort) -> int -> decl +val fresh_constructor : Range.range -> (string & list sort & sort & int) -> decl +//val constructor_to_decl_aux: bool -> constructor_t -> decls_t +val constructor_to_decl: Range.range -> constructor_t -> list decl +val mkBvConstructor: int -> list decl & string & string +val declToSmt: string -> decl -> string +val declToSmt_no_caps: string -> decl -> string + +val mk_Term_app : term -> term -> Range.range -> term +val mk_Term_uvar: int -> Range.range -> term +val mk_and_l: list term -> Range.range -> term +val mk_or_l: list term -> Range.range -> term + +val boxInt: term -> term +val unboxInt: term -> term +val boxBool: term -> term +val unboxBool: term -> term +val boxString: term -> term +val unboxString: term -> term +val boxReal: term -> term +val unboxReal: term -> term +val boxBitVec: int -> term -> term +val unboxBitVec: int -> term -> term + +// Thunked, produces a different opaque constant on each call +val mk_Range_const: unit -> term +val mk_Term_unit: term + +val mk_PreType: term -> term +val mk_Valid: term -> term +val mk_subtype_of_unit: term -> term +val mk_HasType: term -> term -> term +val mk_HasTypeZ: term -> term -> term +val mk_IsTotFun: term -> term +val mk_HasTypeFuel: term -> term -> term -> term +val mk_HasTypeWithFuel: option term -> term -> term -> term +val mk_NoHoist: term -> term -> term +val mk_tester: string -> term -> term +val mk_Term_type: term +val mk_ApplyTF: term -> term -> term +val mk_ApplyTT: term -> term -> Range.range -> term +val mk_String_const: string -> Range.range -> term +val mk_Precedes: term -> term -> term -> term -> Range.range -> term +val n_fuel: int -> term + +val mk_haseq: term -> term +val kick_partial_app: term -> term + +val op_to_string: op -> string +val print_smt_term: term -> string +val print_smt_term_list: list term -> string +val print_smt_term_list_list: list (list term) -> string + +val dummy_sort : sort + +instance val showable_smt_term : Class.Show.showable term +instance val showable_decl : showable decl +val names_of_decl (d:decl) : list string +val decl_to_string_short (d:decl) : string diff --git a/src/smtencoding/FStarC.SMTEncoding.UnsatCore.fst b/src/smtencoding/FStarC.SMTEncoding.UnsatCore.fst new file mode 100644 index 00000000000..96358574334 --- /dev/null +++ b/src/smtencoding/FStarC.SMTEncoding.UnsatCore.fst @@ -0,0 +1,50 @@ +(* + Copyright 2024 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.SMTEncoding.UnsatCore +open FStarC.Compiler.Effect +open FStar open FStarC +open FStarC.Compiler +open FStarC.SMTEncoding.Term +module BU = FStarC.Compiler.Util + +let filter (core:unsat_core) (decls:list decl) +: list decl += let rec aux theory = + //so that we can use the tail-recursive fold_left + let theory_rev = List.rev theory in + let keep, n_retained, n_pruned = + List.fold_left + (fun (keep, n_retained, n_pruned) d -> + match d with + | Assume a -> + if List.contains a.assumption_name core + then d::keep, n_retained+1, n_pruned + else if BU.starts_with a.assumption_name "@" + then d::keep, n_retained, n_pruned + else keep, n_retained, n_pruned+1 + | Module (name, decls) -> + let keep', n, m = aux decls in + Module(name, keep')::keep, n_retained + n, n_pruned + m + | _ -> d::keep, n_retained, n_pruned) + ([Caption ("UNSAT CORE USED: " ^ (core |> String.concat ", "))],//start with the unsat core caption at the end + 0, + 0) + theory_rev + in + keep, n_retained, n_pruned + in + let keep, _, _ = aux decls in + keep diff --git a/src/smtencoding/FStarC.SMTEncoding.UnsatCore.fsti b/src/smtencoding/FStarC.SMTEncoding.UnsatCore.fsti new file mode 100644 index 00000000000..6aa8daf7891 --- /dev/null +++ b/src/smtencoding/FStarC.SMTEncoding.UnsatCore.fsti @@ -0,0 +1,25 @@ +(* + Copyright 2024 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.SMTEncoding.UnsatCore +open FStarC.Compiler.Effect +open FStar open FStarC +open FStarC.Compiler +open FStarC.SMTEncoding.Term + +type unsat_core = list string + +val filter (s:unsat_core) (decls:list decl) +: list decl \ No newline at end of file diff --git a/src/smtencoding/FStarC.SMTEncoding.Util.fst b/src/smtencoding/FStarC.SMTEncoding.Util.fst new file mode 100644 index 00000000000..06c0a05c7d8 --- /dev/null +++ b/src/smtencoding/FStarC.SMTEncoding.Util.fst @@ -0,0 +1,142 @@ +(* + Copyright 2008-2014 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.SMTEncoding.Util +open FStarC.Compiler.Effect + +open FStar open FStarC +open FStarC.Compiler +open FStarC.TypeChecker.Env +open FStarC.Compiler.Util +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.TypeChecker +open FStarC.SMTEncoding.Term +open FStarC.Ident +open FStarC.Const +open FStarC.Class.Setlike +module C = FStarC.Parser.Const +module S = FStarC.Syntax.Syntax +module U = FStarC.Syntax.Util +module SS = FStarC.Syntax.Subst +module N = FStarC.TypeChecker.Normalize +module TcEnv = FStarC.TypeChecker.Env + +let mkAssume (tm, cap, nm) = + Assume ({ + assumption_name=escape nm; + assumption_caption=cap; + assumption_term=tm; + assumption_fact_ids=[]; + assumption_free_names=free_top_level_names tm; + }) +let norng f = fun x -> f x Range.dummyRange +let mkTrue = mkTrue Range.dummyRange +let mkFalse = mkFalse Range.dummyRange +let mkInteger = norng mkInteger +let mkInteger' = norng mkInteger' +let mkReal = norng mkReal +let mkBoundV = norng mkBoundV +let mkFreeV = norng mkFreeV +let mkApp' = norng mkApp' +let mkApp = norng mkApp +let mkNot = norng mkNot +let mkMinus = norng mkMinus +let mkAnd = norng mkAnd +let mkOr = norng mkOr +let mkImp = norng mkImp +let mkIff = norng mkIff +let mkEq = norng mkEq +let mkLT = norng mkLT +let mkLTE = norng mkLTE +let mkGT = norng mkGT +let mkGTE = norng mkGTE +let mkAdd = norng mkAdd +let mkSub = norng mkSub +let mkDiv = norng mkDiv +let mkRealDiv = norng mkRealDiv +let mkMul = norng mkMul +let mkMod = norng mkMod +let mkNatToBv sz = norng (mkNatToBv sz) +let mkBvAnd = norng mkBvAnd +let mkBvXor = norng mkBvXor +let mkBvOr = norng mkBvOr +let mkBvAdd = norng mkBvAdd +let mkBvSub = norng mkBvSub +let mkBvShl sz = norng (mkBvShl sz) +let mkBvShr sz = norng (mkBvShr sz) +let mkBvUdiv sz = norng (mkBvUdiv sz) +let mkBvMod sz = norng (mkBvMod sz) +let mkBvMul sz = norng (mkBvMul sz) +let mkBvShl' sz = norng (mkBvShl' sz) +let mkBvShr' sz = norng (mkBvShr' sz) +let mkBvUdivUnsafe sz = norng (mkBvUdivUnsafe sz) +let mkBvModUnsafe sz = norng (mkBvModUnsafe sz) +let mkBvMul' sz = norng (mkBvMul' sz) +let mkBvUlt = norng mkBvUlt +let mkBvUext sz = norng (mkBvUext sz) +let mkBvToNat = norng mkBvToNat +let mkITE = norng mkITE +let mkCases = norng mkCases + +let norng2 f = fun x y -> f x y Range.dummyRange +let norng3 f = fun x y z -> f x y z Range.dummyRange +let norng4 f = fun x y z w -> f x y z w Range.dummyRange +let mk_Term_app = norng2 mk_Term_app +let mk_Term_uvar = norng mk_Term_uvar +let mk_and_l = norng mk_and_l +let mk_or_l = norng mk_or_l +let mk_ApplyTT = norng2 mk_ApplyTT +let mk_String_const = norng mk_String_const +let mk_Precedes = norng4 mk_Precedes + + +(* + * AR: When encoding abstractions that have a reifiable computation type + * for their bodies, we currently encode their reification + * Earlier this was fine, since the only reifiable effects came from DM4F + * But now layered effects are also reifiable, but I don't think we want + * to encode their reification to smt + * So adding these utils, that are then used in Encode.fs and EncodeTerm.fs + * + * Could revisit + * + * 06/22: reifying if the effect has the smt_reifiable_layered_effect attribute + * 07/02: reverting, until we preserve the indices, no smt reification + *) + +let is_smt_reifiable_effect (en:TcEnv.env) (l:lident) : bool = + let l = TcEnv.norm_eff_name en l in + TcEnv.is_reifiable_effect en l && + not (l |> TcEnv.get_effect_decl en |> U.is_layered) + +let is_smt_reifiable_comp (en:TcEnv.env) (c:S.comp) : bool = + match c.n with + | Comp ct -> is_smt_reifiable_effect en ct.effect_name + | _ -> false + +// +// TAC rc are not smt reifiable +// + +let is_smt_reifiable_rc (en:TcEnv.env) (rc:S.residual_comp) : bool = + rc.residual_effect |> is_smt_reifiable_effect en + +let is_smt_reifiable_function (en:TcEnv.env) (t:S.term) : bool = + match (SS.compress t).n with + | Tm_arrow {comp=c} -> + c |> U.comp_effect_name |> is_smt_reifiable_effect en + | _ -> false diff --git a/src/smtencoding/FStarC.SMTEncoding.Z3.fst b/src/smtencoding/FStarC.SMTEncoding.Z3.fst new file mode 100644 index 00000000000..de6399816e5 --- /dev/null +++ b/src/smtencoding/FStarC.SMTEncoding.Z3.fst @@ -0,0 +1,821 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.SMTEncoding.Z3 +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.SMTEncoding.Term +open FStarC.BaseTypes +open FStarC.Compiler.Util +open FStarC.Class.Show +module SolverState = FStarC.SMTEncoding.SolverState +module M = FStarC.Compiler.Misc +module BU = FStarC.Compiler.Util +(****************************************************************************) +(* Z3 Specifics *) +(****************************************************************************) + +(* We only warn once about these things *) +let _already_warned_solver_mismatch : ref bool = BU.mk_ref false +let _already_warned_version_mismatch : ref bool = BU.mk_ref false + +let z3url = "https://github.com/Z3Prover/z3/releases" + +(* Check if [path] is potentially a valid z3, by trying to run +it with -version and checking for non-empty output. Alternatively +we could call [which] on it (if it's not an absolute path), but +we shouldn't rely on the existence of a binary which. *) +let inpath (path:string) : bool = + try + let s = BU.run_process "z3_pathtest" path ["-version"] None in + s <> "" + with + | _ -> false + +(* Find the Z3 executable that we should invoke, according to the +needed version. The logic is as follows: + +- If the user provided the --smt option, use that binary unconditionally. +- If z3-VER (or z3-VER.exe) exists in the PATH (where VER is either + the default version or the user-provided --z3version) use it. +- Otherwise, default to "z3" in the PATH. + +We cache the chosen executable for every Z3 version we've ran. +*) +let z3_exe : unit -> string = + let cache : BU.smap string = BU.smap_create 5 in + let find_or (k:string) (f : string -> string) : string = + match smap_try_find cache k with + | Some v -> v + | None -> + let v = f k in + smap_add cache k v; + v + in + fun () -> + find_or (Options.z3_version()) (fun version -> + let path = + let z3_v = Platform.exe ("z3-" ^ version) in + let smto = Options.smt () in + if Some? smto then Some?.v smto + else if inpath z3_v then z3_v + else Platform.exe "z3" + in + if Debug.any () then + BU.print1 "Chosen Z3 executable: %s\n" path; + path + ) + +type label = string + +let status_tag = function + | SAT _ -> "sat" + | UNSAT _ -> "unsat" + | UNKNOWN _ -> "unknown" + | TIMEOUT _ -> "timeout" + | KILLED -> "killed" + +let status_string_and_errors s = + match s with + | KILLED + | UNSAT _ -> status_tag s, [] + | SAT (errs, msg) + | UNKNOWN (errs, msg) + | TIMEOUT (errs, msg) -> BU.format2 "%s%s" (status_tag s) (match msg with None -> "" | Some msg -> " because " ^ msg), errs + //(match msg with None -> "unknown" | Some msg -> msg), errs + + +let query_logging = + let query_number = BU.mk_ref 0 in + let log_file_opt : ref (option (out_channel & string)) = BU.mk_ref None in + let used_file_names : ref (list (string & int)) = BU.mk_ref [] in + let current_module_name : ref (option string) = BU.mk_ref None in + let current_file_name : ref (option string) = BU.mk_ref None in + let set_module_name n = current_module_name := Some n in + let get_module_name () = + match !current_module_name with + | None -> failwith "Module name not set" + | Some n -> n + in + let next_file_name () = + let n = get_module_name() in + let file_name = + match List.tryFind (fun (m, _) -> n=m) !used_file_names with + | None -> + used_file_names := (n, 0)::!used_file_names; + n + | Some (_, k) -> + used_file_names := (n, k+1)::!used_file_names; + BU.format2 "%s-%s" n (BU.string_of_int (k+1)) + in + BU.format1 "queries-%s.smt2" file_name + in + let new_log_file () = + let file_name = next_file_name() in + current_file_name := Some file_name; + let c = BU.open_file_for_writing file_name in + log_file_opt := Some (c, file_name); + c, file_name + in + let get_log_file () = + match !log_file_opt with + | None -> new_log_file() + | Some c -> c + in + let append_to_log str = + let f, nm = get_log_file () in + BU.append_to_file f str; + nm + in + let write_to_new_log str = + let file_name = next_file_name() in + write_file file_name str; + file_name + in + let write_to_log fresh str = + if fresh + then write_to_new_log str + else append_to_log str + in + let close_log () = + match !log_file_opt with + | None -> () + | Some (c, _) -> + BU.close_out_channel c; log_file_opt := None + in + let log_file_name () = + match !current_file_name with + | None -> failwith "no log file" + | Some n -> n + in + {set_module_name=set_module_name; + get_module_name=get_module_name; + write_to_log=write_to_log; + append_to_log=append_to_log; + close_log=close_log; + } + +(* Z3 background process handling *) +let z3_cmd_and_args () = + let cmd = z3_exe () in + let cmd_args = + List.append ["-smt2"; + "-in"; + Util.format1 "smt.random_seed=%s" (string_of_int (Options.z3_seed ()))] + (Options.z3_cliopt ()) in + (cmd, cmd_args) + +let warn_handler (suf:Errors.error_message) (s:string) : unit = + let open FStarC.Errors.Msg in + let open FStarC.Pprint in + Errors.log_issue0 Errors.Warning_UnexpectedZ3Output ([ + text "Unexpected output from Z3:" ^^ hardline ^^ + blank 2 ^^ align (dquotes (arbitrary_string s)); + ] @ suf) + +(* Talk to the process to see if it's the correct version of Z3 +(i.e. the one in the optionstate). Also check that it indeed is Z3. By +default, each of these generates an error, but they can be downgraded +into warnings. The warnings are anyway printed only once per F* +invocation. *) +let check_z3version (p:proc) : unit = + let getinfo (arg:string) : string = + let s = BU.ask_process p (Util.format1 "(get-info :%s)\n(echo \"Done!\")\n" arg) (fun _ -> "Killed") (warn_handler []) in + if BU.starts_with s ("(:" ^ arg) then + let ss = String.split ['"'] s in + List.nth ss 1 + else ( + warn_handler [] s; + Errors.raise_error0 Errors.Error_Z3InvocationError (BU.format1 "Could not run Z3 from `%s'" (proc_prog p)) + ) + in + let name = getinfo "name" in + if name <> "Z3" && not (!_already_warned_solver_mismatch) then ( + Errors.log_issue0 Errors.Warning_SolverMismatch + (BU.format3 "Unexpected SMT solver: expected to be talking to Z3, got %s.\n\ + Please download the correct version of Z3 from %s\n\ + and install it into your $PATH as `%s'." + name + z3url (Platform.exe ("z3-" ^ Options.z3_version ()))); + _already_warned_solver_mismatch := true + ); + let ver_found : string = BU.trim_string (List.hd (BU.split (getinfo "version") "-")) in + let ver_conf : string = BU.trim_string (Options.z3_version ()) in + if ver_conf <> ver_found && not (!_already_warned_version_mismatch) then ( + let open FStarC.Errors in + let open FStarC.Pprint in + Errors.log_issue0 Errors.Warning_SolverMismatch [ + text (BU.format3 "Unexpected Z3 version for '%s': expected '%s', got '%s'." + (proc_prog p) ver_conf ver_found); + prefix 4 1 (text "Please download the correct version of Z3 from") + (url z3url) ^/^ + group (text "and install it into your $PATH as" ^/^ squotes + (doc_of_string (Platform.exe ("z3-" ^ Options.z3_version ()))) ^^ dot); + ]; + Errors.stop_if_err(); (* stop now if this was a hard error *) + _already_warned_version_mismatch := true + ); + () + +let new_z3proc (id:string) (cmd_and_args : string & list string) : BU.proc = + let proc = + try + BU.start_process id (fst cmd_and_args) (snd cmd_and_args) (fun s -> s = "Done!") + with + | e -> + let open FStarC.Pprint in + let open FStarC.Errors.Msg in + Errors.raise_error0 Errors.Error_Z3InvocationError [ + text "Could not start SMT solver process."; + prefix 2 1 (text "Command:" ) + (fst cmd_and_args |> arbitrary_string |> squotes); + prefix 2 1 (text "Exception:") + (BU.print_exn e |> arbitrary_string); + ] + in + check_z3version proc; + proc + +let new_z3proc_with_id = + let ctr = BU.mk_ref (-1) in + (fun cmd_and_args -> + let p = new_z3proc (BU.format1 "z3-bg-%s" (incr ctr; !ctr |> string_of_int)) cmd_and_args in + p) + +type bgproc = { + ask: string -> string; + refresh: unit -> unit; + restart: unit -> unit; + version: unit -> string; + ctxt: SolverState.solver_state; +} + +let cmd_and_args_to_string cmd_and_args = + String.concat "" [ + "cmd="; (fst cmd_and_args); + " args=["; (String.concat ", " (snd cmd_and_args)); + "]" + ] + +(* the current background process is stored in the_z3proc + the params with which it was started are stored in the_z3proc_params + refresh will kill and restart the process if the params changed or + we have asked the z3 process something + *) +let bg_z3_proc = + let the_z3proc = BU.mk_ref None in + let the_z3proc_params = BU.mk_ref (Some ("", [""])) in + let the_z3proc_ask_count = BU.mk_ref 0 in + let the_z3proc_version = BU.mk_ref "" in + // NOTE: We keep track of the version and restart on changes + // just to be safe: the executable name in the_z3proc_params should + // be enough to distinguish between the different executables. + let make_new_z3_proc cmd_and_args = + the_z3proc := Some (new_z3proc_with_id cmd_and_args); + the_z3proc_params := Some cmd_and_args; + the_z3proc_ask_count := 0 in + the_z3proc_version := Options.z3_version (); + let z3proc () = + if !the_z3proc = None then make_new_z3_proc (z3_cmd_and_args ()); + must (!the_z3proc) + in + let ask input = + incr the_z3proc_ask_count; + let kill_handler () = "\nkilled\n" in + BU.ask_process (z3proc ()) input kill_handler (warn_handler []) + in + let maybe_kill_z3proc () = + if !the_z3proc <> None then begin + BU.kill_process (must (!the_z3proc)); + the_z3proc := None + end + in + let refresh () = + let next_params = z3_cmd_and_args () in + let old_params = must (!the_z3proc_params) in + + let old_version = !the_z3proc_version in + let next_version = Options.z3_version () in + + (* We only refresh the solver if we have used it at all, or if the + parameters/version must be changed. We also force a refresh if log_queries is + on. I (GM 2023/07/23) think this might have been for making sure we get + a new file after checking a dependency, and that it might not be needed + now. However it's not a big performance hit, and it's only when logging + queries, so I'm maintaining this. *) + if Options.log_queries() || + (!the_z3proc_ask_count > 0) || + old_params <> next_params || + old_version <> next_version + then begin + maybe_kill_z3proc(); + if Options.query_stats() + then begin + BU.print3 "Refreshing the z3proc (ask_count=%s old=[%s] new=[%s])\n" + (BU.string_of_int !the_z3proc_ask_count) + (cmd_and_args_to_string old_params) + (cmd_and_args_to_string next_params) + end; + make_new_z3_proc next_params + end; + query_logging.close_log() + in + let restart () = + maybe_kill_z3proc(); + query_logging.close_log(); + let next_params = z3_cmd_and_args () in + make_new_z3_proc next_params + in + let x : list unit = [] in + BU.mk_ref ({ask = BU.with_monitor x ask; + refresh = BU.with_monitor x refresh; + restart = BU.with_monitor x restart; + version = (fun () -> !the_z3proc_version); + ctxt = SolverState.init() }) + + +type smt_output_section = list string +type smt_output = { + smt_result: smt_output_section; + smt_reason_unknown: option smt_output_section; + smt_unsat_core: option smt_output_section; + smt_statistics: option smt_output_section; + smt_labels: option smt_output_section; +} + +let smt_output_sections (log_file:option string) (r:Range.range) (lines:list string) : smt_output = + let rec until tag lines = + match lines with + | [] -> None + | l::lines -> + if tag = l then Some ([], lines) + else BU.map_opt (until tag lines) (fun (until_tag, rest) -> + (l::until_tag, rest)) + in + let start_tag tag = "<" ^ tag ^ ">" in + let end_tag tag = "" in + let find_section tag lines : option (list string) & list string = + match until (start_tag tag) lines with + | None -> None, lines + | Some (prefix, suffix) -> + match until (end_tag tag) suffix with + | None -> failwith ("Parse error: " ^ end_tag tag ^ " not found") + | Some (section, suffix) -> Some section, prefix @ suffix + in + let result_opt, lines = find_section "result" lines in + let result = + match result_opt with + | None -> + failwith + (BU.format1 "Unexpexted output from Z3: no result section found:\n%s" (String.concat "\n" lines)) + | Some result -> result + in + let reason_unknown, lines = find_section "reason-unknown" lines in + let unsat_core, lines = find_section "unsat-core" lines in + let statistics, lines = find_section "statistics" lines in + let labels, lines = find_section "labels" lines in + let remaining = + match until "Done!" lines with + | None -> lines + | Some (prefix, suffix) -> prefix@suffix in + let _ = + match remaining with + | [] -> () + | _ -> + let msg = String.concat "\n" remaining in + let suf = + let open FStarC.Errors.Msg in + let open FStarC.Pprint in + match log_file with + | Some log_file -> [text "Log file:" ^/^ doc_of_string log_file] + | None -> [] + in + warn_handler suf msg + in + {smt_result = BU.must result_opt; + smt_reason_unknown = reason_unknown; + smt_unsat_core = unsat_core; + smt_statistics = statistics; + smt_labels = labels} + + +let with_solver_state (f: SolverState.solver_state -> 'a & SolverState.solver_state) +: 'a += let ss = !bg_z3_proc in + let res, ctxt = f ss.ctxt in + bg_z3_proc := { ss with ctxt }; + res +let with_solver_state_unit (f:SolverState.solver_state -> SolverState.solver_state) +: unit += with_solver_state (fun x -> (), f x) +let reading_solver_state (f:SolverState.solver_state -> 'a) : 'a += let ss = !bg_z3_proc in + f ss.ctxt +let push msg = + with_solver_state_unit SolverState.push; + with_solver_state_unit (SolverState.give [Caption msg]) +let pop msg = + with_solver_state_unit (SolverState.give [Caption msg]); + with_solver_state_unit SolverState.pop +let snapshot msg = + let d = reading_solver_state SolverState.depth in + push msg; + // let d' = reading_solver_state SolverState.depth in + // BU.print2 "Snapshot moving from %s to %s\n" (show d) (show d'); + d +let rollback msg depth = + let rec rollback_aux msg depth = + let d = reading_solver_state SolverState.depth in + match depth with + | None -> pop msg + | Some n -> + if d = n then () else ( + pop msg; + rollback_aux msg depth + ) + in + // let init = reading_solver_state SolverState.depth in + rollback_aux msg depth + // let final = reading_solver_state SolverState.depth in + // BU.print3 "Rollback(%s) from %s to %s\n" + // (show depth) + // (show init) + // (show final) +let start_query msg roots_to_push qry = + with_solver_state_unit (SolverState.start_query msg roots_to_push qry) +let finish_query msg = + with_solver_state_unit (SolverState.finish_query msg) +let giveZ3 decls = with_solver_state_unit (SolverState.give decls) +let refresh using_facts_from = + (!bg_z3_proc).refresh(); + with_solver_state_unit (SolverState.reset using_facts_from) + +let doZ3Exe (log_file:_) (r:Range.range) (fresh:bool) (input:string) (label_messages:error_labels) (queryid:string) : z3status & z3statistics = + let parse (z3out:string) = + let lines = String.split ['\n'] z3out |> List.map BU.trim_string in + let smt_output = smt_output_sections log_file r lines in + let unsat_core = + match smt_output.smt_unsat_core with + | None -> None + | Some s -> + let s = BU.trim_string (String.concat " " s) in + let s = BU.substring s 1 (String.length s - 2) in + if BU.starts_with s "error" + then None + else Some (BU.split s " " |> BU.sort_with String.compare) + in + let labels = + match smt_output.smt_labels with + | None -> [] + | Some lines -> + let rec lblnegs lines = + match lines with + | lname::"false"::rest when BU.starts_with lname "label_" -> lname::lblnegs rest + | lname::_::rest when BU.starts_with lname "label_" -> lblnegs rest + | _ -> [] in + let lblnegs = lblnegs lines in + lblnegs |> List.collect + (fun l -> match label_messages |> List.tryFind (fun (m, _, _) -> fv_name m = l) with + | None -> [] + | Some (lbl, msg, r) -> [(lbl, msg, r)]) + in + let statistics = + let statistics : z3statistics = BU.smap_create 0 in + match smt_output.smt_statistics with + | None -> statistics + | Some lines -> + let parse_line line = + let pline = BU.split (BU.trim_string line) ":" in + match pline with + | "(" :: entry :: [] + | "" :: entry :: [] -> + let tokens = BU.split entry " " in + let key = List.hd tokens in + let ltok = List.nth tokens ((List.length tokens) - 1) in + let value = if BU.ends_with ltok ")" then (BU.substring ltok 0 ((String.length ltok) - 1)) else ltok in + BU.smap_add statistics key value + | _ -> () + in + List.iter parse_line lines; + statistics + in + let reason_unknown = BU.map_opt smt_output.smt_reason_unknown (fun x -> + let ru = String.concat " " x in + if BU.starts_with ru "(:reason-unknown \"" + then let reason = FStarC.Compiler.Util.substring_from ru (String.length "(:reason-unknown \"" ) in + let res = String.substring reason 0 (String.length reason - 2) in //it ends with '")' + res + else ru) in + let status = + if Debug.any() then print_string <| format1 "Z3 says: %s\n" (String.concat "\n" smt_output.smt_result); + match smt_output.smt_result with + | ["unsat"] -> UNSAT unsat_core + | ["sat"] -> SAT (labels, reason_unknown) + | ["unknown"] -> UNKNOWN (labels, reason_unknown) + | ["timeout"] -> TIMEOUT (labels, reason_unknown) + | ["killed"] -> (!bg_z3_proc).restart(); KILLED + | _ -> + failwith (format1 "Unexpected output from Z3: got output result: %s\n" + (String.concat "\n" smt_output.smt_result)) + in + status, statistics + in + let log_result fwrite (res, _stats) = + (* If we are logging, write some more information to the + smt2 file, such as the result of the query and the new unsat + core generated. We take a call back to do so, since for the + bg z3 process we must call query_logging.append_to_log, but for + fresh invocations (such as hints) we must reopen the file to write + to it. *) + begin match log_file with + | Some fname -> + fwrite fname ("; QUERY ID: " ^ queryid); + fwrite fname ("; STATUS: " ^ fst (status_string_and_errors res)); + begin match res with + | UNSAT (Some core) -> + fwrite fname ("; UNSAT CORE GENERATED: " ^ String.concat ", " core) + | _ -> () + end + | None -> () + end; + let log_file_name = + match log_file with + | Some fname -> fname + | _ -> "" + in + let _ = + match reading_solver_state SolverState.would_have_pruned, res with + | Some names, UNSAT (Some core) -> ( + let whitelist = ["BoxInt"; "BoxBool"; "BoxString"; "BoxReal"; "Tm_unit"; "FString_const"] in + let missing = + core |> List.filter (fun name -> + not (BU.for_some (fun wl -> BU.contains name wl) whitelist) && + not (BU.starts_with name "binder_") && + not (BU.starts_with name "@query") && + not (BU.starts_with name "@MaxFuel") && + not (BU.starts_with name "@MaxIFuel") && + not (BU.for_some (fun name' -> name=name') names)) + in + // BU.print2 "Query %s: Pruned theory would keep %s\n" queryid (String.concat ", " names); + match missing with + | [] -> () + | _ -> + BU.print3 "Query %s (%s): Pruned theory would miss %s\n" queryid log_file_name (String.concat ", " missing) + ) + | _ -> () + in + () + in + if fresh then + let proc = new_z3proc_with_id (z3_cmd_and_args ()) in + let kill_handler () = "\nkilled\n" in + let out = BU.ask_process proc input kill_handler (warn_handler []) in + let r = parse (BU.trim_string out) in + log_result (fun fname s -> + let h = BU.open_file_for_appending fname in + BU.append_to_file h s; + BU.close_out_channel h + ) r; + BU.kill_process proc; + r + else + let out = (!bg_z3_proc).ask input in + let r = parse (BU.trim_string out) in + log_result (fun _fname s -> ignore (query_logging.append_to_log s)) r; + r + +let z3_options (ver:string) = + (* Common z3 prefix for all supported versions (at minimum 4.8.5). *) + let opts = [ + "(set-option :global-decls false)"; + "(set-option :smt.mbqi false)"; + "(set-option :auto_config false)"; + "(set-option :produce-unsat-cores true)"; + "(set-option :model true)"; + "(set-option :smt.case_split 3)"; + "(set-option :smt.relevancy 2)"; + ] + in + + (* We need the following options for Z3 >= 4.12.3 *) + let opts = opts @ begin + if M.version_ge ver "4.12.3" then [ + "(set-option :rewriter.enable_der false)"; + "(set-option :rewriter.sort_disjunctions false)"; + "(set-option :pi.decompose_patterns false)"; + "(set-option :smt.arith.solver 6)"; + ] else [ + (* Note: smt.arith.solver defaults to 2 in 4.8.5, but it doesn't hurt to + specify it. *) + "(set-option :smt.arith.solver 2)"; + ] + end + in + String.concat "\n" opts ^ "\n" + +let context_profile (theory:list decl) = + let modules, total_decls = + List.fold_left (fun (out, _total) d -> + match d with + | Module(name, decls) -> + let decls = + List.filter + (function Assume _ -> true + | _ -> false) + decls in + let n : int = List.length decls in + (name, n)::out, n + _total + | _ -> out, _total) + ([], 0) + theory + in + let modules = List.sortWith (fun (_, n) (_, m) -> m - n) modules in + if modules <> [] + then BU.print1 "Z3 Proof Stats: context_profile with %s assertions\n" + (BU.string_of_int total_decls); + List.iter (fun (m, n) -> + if n <> 0 then + BU.print2 "Z3 Proof Stats: %s produced %s SMT decls\n" + m + (string_of_int n)) + modules + +let mk_input (fresh : bool) (theory : list decl) : string & option string & option string = + let ver = Options.z3_version () in + let theory = + (* Add a caption with some version info. *) + ( Caption <| + BU.format3 "Z3 invocation started by F*\n\ + F* version: %s -- commit hash: %s\n\ + Z3 version (according to F*): %s" + (!Options._version) (!Options._commit) ver + ) :: theory + in + let options = z3_options ver in + let options = options ^ (Options.z3_smtopt() |> String.concat "\n") ^ "\n\n" in + if Options.print_z3_statistics() then context_profile theory; + let r, hash = + if Options.record_hints() + || (Options.use_hints() && Options.use_hint_hashes()) then + //the suffix of a "theory" that follows the "CheckSat" call + //contains semantically irrelevant things + //(e.g., get-model, get-statistics etc.) + //that vary depending on some user options (e.g., record_hints etc.) + //They should not be included in the query hash, + //so split the prefix out and use only it for the hash + let prefix, check_sat, suffix = + theory |> + BU.prefix_until (function CheckSat -> true | _ -> false) |> + Option.get + in + let pp = List.map (declToSmt options) in + let suffix = check_sat::suffix in + let ps_lines = pp prefix in + let ss_lines = pp suffix in + let ps = String.concat "\n" ps_lines in + let ss = String.concat "\n" ss_lines in + + (* Ignore captions AND ranges when hashing, otherwise we depend on file names *) + let hs = + if Options.keep_query_captions () + then prefix + |> List.map (declToSmt_no_caps options) + |> String.concat "\n" + else ps + in + (* Add the Z3 version to the string, so we get a mismatch if we switch versions. *) + let hs = hs ^ "Z3 version: " ^ ver in + ps ^ "\n" ^ ss, Some (BU.digest_of_string hs) + else + List.map (declToSmt options) theory |> String.concat "\n", None + in + let log_file_name = + if Options.log_queries() + then Some (query_logging.write_to_log fresh r) + else None + in + r, hash, log_file_name + +let cache_hit + (log_file:option string) + (cache:option string) + (qhash:option string) : option z3result = + if Options.use_hints() && Options.use_hint_hashes() then + match qhash with + | Some (x) when qhash = cache -> + let stats : z3statistics = BU.smap_create 0 in + smap_add stats "fstar_cache_hit" "1"; + let result = { + z3result_status = UNSAT None; + z3result_time = 0; + z3result_statistics = stats; + z3result_query_hash = qhash; + z3result_log_file = log_file + } in + Some result + | _ -> + None + else + None + +let z3_job + (log_file:_) + (r:Range.range) + fresh + (label_messages:error_labels) + input + qhash + queryid +: z3result += //This code is a little ugly: + //We insert a profiling call to accumulate total time spent in Z3 + //But, we also record the time of this particular call so that we can + //record the elapsed time in the z3result_time field. + //That field is printed out in the query-stats output, which is a separate + //profiling feature. We could try in the future to unify all the different + //kinds of profiling features ... but that's beyond scope for now. + let (status, statistics), elapsed_time = + Profiling.profile + (fun () -> + try + BU.record_time (fun () -> doZ3Exe log_file r fresh input label_messages queryid) + with e -> + refresh None; //refresh the solver but don't handle the exception; it'll be caught upstream + raise e + ) + (Some (query_logging.get_module_name())) + "FStarC.SMTEncoding.Z3 (aggregate query time)" + in + { z3result_status = status; + z3result_time = elapsed_time; + z3result_statistics = statistics; + z3result_query_hash = qhash; + z3result_log_file = log_file } + +let ask_text + (r:Range.range) + (cache:option string) + (label_messages:error_labels) + (qry:list decl) + (queryid:string) + (core:option U.unsat_core) + : string + = (* Mimics a fresh ask, and just returns the string that would + be sent to the solver. *) + let theory = + match core with + | None -> with_solver_state SolverState.flush + | Some core -> reading_solver_state (SolverState.filter_with_unsat_core queryid core) + in + let query_tail = Push 0 :: qry@[Pop 0] in + let theory = theory @ query_tail in + let input, qhash, log_file_name = mk_input true theory in + input + +let ask + (r:Range.range) + (cache:option string) + (label_messages:error_labels) + (qry:list decl) + (queryid:string) + (fresh:bool) + (core:option U.unsat_core) +: z3result += + // push "query"; + // giveZ3 qry; + let theory = + match core with + | None -> with_solver_state SolverState.flush + | Some core -> + if not fresh + then failwith "Unexpected: unsat core must only be used with fresh solvers"; + reading_solver_state (SolverState.filter_with_unsat_core queryid core) + in + let theory = theory @ (Push 0:: qry@[Pop 0]) in + let input, qhash, log_file_name = mk_input fresh theory in + let just_ask () = z3_job log_file_name r fresh label_messages input qhash queryid in + let result = + if fresh then + match cache_hit log_file_name cache qhash with + | Some z3r -> z3r + | None -> just_ask () + else + just_ask () + in + // pop "query"; + result diff --git a/src/smtencoding/FStarC.SMTEncoding.Z3.fsti b/src/smtencoding/FStarC.SMTEncoding.Z3.fsti new file mode 100644 index 00000000000..9d12fb0c2fb --- /dev/null +++ b/src/smtencoding/FStarC.SMTEncoding.Z3.fsti @@ -0,0 +1,80 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.SMTEncoding.Z3 +open FStarC.Compiler.Effect +open FStar open FStarC +open FStarC.Compiler +open FStarC.SMTEncoding.Term +open FStarC.BaseTypes +open FStarC.Compiler.Util +module BU = FStarC.Compiler.Util +module U = FStarC.SMTEncoding.UnsatCore +module SolverState = FStarC.SMTEncoding.SolverState + +type z3status = + | UNSAT of option U.unsat_core + | SAT of error_labels & option string //error labels & z3 reason + | UNKNOWN of error_labels & option string //error labels & z3 reason + | TIMEOUT of error_labels & option string //error labels & z3 reason + | KILLED +type z3statistics = BU.smap string + +type z3result = { + z3result_status : z3status; + z3result_time : int; + z3result_statistics : z3statistics; + z3result_query_hash : option string; + z3result_log_file : option string +} + +type query_log = { + get_module_name: unit -> string; + set_module_name: string -> unit; + write_to_log: bool -> string -> string; (* returns name of log file written to *) + append_to_log: string -> string; (* idem *) + close_log: unit -> unit; +} + +val status_string_and_errors : z3status -> string & error_labels + +val giveZ3 : list decl -> unit + +val ask_text + : r:Range.range + -> cache:(option string) // hash + -> label_messages:error_labels + -> qry:list decl + -> queryid:string + -> core:option U.unsat_core + -> string + +val ask: r:Range.range + -> cache:option string // hash + -> label_messages:error_labels + -> qry:list decl + -> queryid:string + -> fresh:bool + -> core:option U.unsat_core + -> z3result + +val refresh: option SolverState.using_facts_from_setting -> unit +val push : msg:string -> unit +val pop : msg:string -> unit +val snapshot : string -> int +val rollback : string -> option int -> unit +val start_query (msg:string) (prefix_to_push:list decl) (query:decl) : unit +val finish_query (msg:string) : unit +val query_logging : query_log \ No newline at end of file diff --git a/src/syntax/FStar.Syntax.CheckLN.fst b/src/syntax/FStar.Syntax.CheckLN.fst deleted file mode 100644 index c261898f141..00000000000 --- a/src/syntax/FStar.Syntax.CheckLN.fst +++ /dev/null @@ -1,112 +0,0 @@ -module FStar.Syntax.CheckLN - -open FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module L = FStar.Compiler.List - -(* Computes the binding amount of a pattern. -Anywhere where this is defined already? *) -let rec pat_depth (p:pat) : int = - match p.v with - | Pat_constant _ -> 0 - | Pat_cons (p, _us_opt, ps) -> - L.fold_left (fun d (p, _) -> d + pat_depth p) 0 ps - | Pat_var _ -> 1 - | Pat_dot_term _ -> 0 - -(* Checks if, at most, n indices escape from a term *) -let rec is_ln' (n:int) (t:term) : bool = - match (SS.compress t).n with - | Tm_bvar bv -> bv.index < n - - | Tm_type _ - | Tm_name _ - | Tm_constant _ - | Tm_fvar _ -> true - - (* Should really be an fvar, but being conservative here *) - | Tm_uinst (t, us) -> - is_ln' n t && - is_ln'_univs n us - - | Tm_abs {bs;body;rc_opt} -> - is_ln'_binders n bs && - is_ln' (n + L.length bs) body - - | Tm_arrow {bs;comp} -> - is_ln'_binders n bs && - is_ln'_comp (n + L.length bs) comp - - | Tm_refine {b;phi} -> - is_ln'_bv n b && - is_ln' (n+1) phi - - | Tm_app {hd; args} -> - is_ln' n hd && - L.for_all (fun (t, aq) -> is_ln' n t) args - - | Tm_match {scrutinee; ret_opt; brs; rc_opt} -> - is_ln' n scrutinee && - // TODO: check pats - L.for_all (fun (p, _, t) -> is_ln' (n + pat_depth p) t) brs - - | Tm_ascribed {tm; asc; eff_opt} -> - is_ln' n tm && - true // is_ln' n asc - - | Tm_let {lbs; body} -> - is_ln'_letbindings n lbs && - is_ln' (n + L.length (snd lbs)) body - - | _ -> true - -and is_ln'_letbindings (n:int) (lbs : letbindings) : bool = - let isrec, lbs = lbs in - L.for_all (fun lb -> is_ln'_letbinding n lb) lbs - -and is_ln'_letbinding (n:int) (lb : letbinding) : bool = - let {lbunivs; lbtyp; lbdef} = lb in - let nu = List.length lbunivs in - is_ln' (n+nu) lbtyp && - is_ln' (n+nu) lbdef - -and is_ln'_binders (n:int) (bs : list binder) : bool = - match bs with - | [] -> true - | b::bs -> - is_ln'_binder n b && is_ln'_binders (n+1) bs - -and is_ln'_binder (n:int) (b:binder) : bool = - is_ln'_bv n b.binder_bv - -and is_ln'_bv (n:int) (bv:bv) : bool = - is_ln' n bv.sort - -and is_ln'_comp (n:int) (c:comp) : bool = - match c.n with - | Total t -> is_ln' n t - | GTotal t -> is_ln' n t - | Comp ct -> is_ln'_comp_typ n ct - -and is_ln'_comp_typ (n:nat) (ct:comp_typ) : bool = - is_ln' n ct.result_typ && - L.for_all (fun (t,aq) -> is_ln' n t) ct.effect_args && -// L.for_all (is_ln' n) ct.flags - true - -and is_ln'_univ (n:nat) (u : universe) : bool = - match SS.compress_univ u with - | U_zero -> true - | U_succ u -> is_ln'_univ n u - | U_max us -> L.for_all (is_ln'_univ n) us - | U_unif _ -> true // we're conservative with returning false since that would be an error - | U_bvar i -> i < n - | U_name _ -> true - | U_unknown -> true - -and is_ln'_univs (n:nat) (us : list universe) : bool = - L.for_all (is_ln'_univ n) us - -(* Checks if a term is locally nameless *) -let is_ln (t:term) : bool = - is_ln' 0 t diff --git a/src/syntax/FStar.Syntax.CheckLN.fsti b/src/syntax/FStar.Syntax.CheckLN.fsti deleted file mode 100644 index b526b0664c2..00000000000 --- a/src/syntax/FStar.Syntax.CheckLN.fsti +++ /dev/null @@ -1,10 +0,0 @@ -module FStar.Syntax.CheckLN - -open FStar.Syntax.Syntax - -(* Checks if, at most, n indices escape from a term. -For both term and universe variables. *) -val is_ln' (n:int) (t:term) : bool - -(* Checks if a term is locally nameless. Equal to [is_ln' 0] *) -val is_ln (t:term) : bool diff --git a/src/syntax/FStar.Syntax.Compress.fst b/src/syntax/FStar.Syntax.Compress.fst deleted file mode 100644 index 4e006115b35..00000000000 --- a/src/syntax/FStar.Syntax.Compress.fst +++ /dev/null @@ -1,100 +0,0 @@ -module FStar.Syntax.Compress - -open FStar.Compiler -open FStar.Compiler.Util -open FStar.Compiler.Effect -open FStar.Syntax.Syntax -open FStar.Syntax.Subst -open FStar.Syntax.Visit - -open FStar.Class.Show - -module List = FStar.Compiler.List -module Err = FStar.Errors - -(* This function really just checks for bad(tm) things happening, the -actual `compress` call is done by the visitor, so no need to repeat it -here. Morally, `deep_compress` is just `visit id` with some checks. *) -let compress1_t (allow_uvars: bool) (allow_names: bool) : term -> term = - fun t -> - let mk x = Syntax.mk x t.pos in - match t.n with - | Tm_uvar (uv, s) when not allow_uvars -> - Err.raise_error0 Err.Error_UnexpectedUnresolvedUvar - (format1 "Internal error: unexpected unresolved uvar in deep_compress: %s" (show uv)) - - | Tm_name bv when not allow_names -> - (* This currently happens, and often, but it should not! *) - if Debug.any () then - Errors.log_issue t Err.Warning_NameEscape (format1 "Tm_name %s in deep compress" (show bv)); - mk (Tm_name ({bv with sort = mk Tm_unknown})) - - (* The sorts are not needed. Delete them. *) - | Tm_bvar bv -> mk (Tm_bvar ({bv with sort = mk Tm_unknown})) - | Tm_name bv -> mk (Tm_name ({bv with sort = mk Tm_unknown})) - - | _ -> t - -let compress1_u (allow_uvars:bool) (allow_names:bool) : universe -> universe = - fun u -> - match u with - | U_name bv when not allow_names -> - if Debug.any () then - Errors.log_issue0 Err.Warning_NameEscape (format1 "U_name %s in deep compress" (show bv)); - u - - | U_unif uv when not allow_uvars -> - Err.raise_error0 Err.Error_UnexpectedUnresolvedUvar - (format1 "Internal error: unexpected unresolved (universe) uvar in deep_compress: %s" (show (Unionfind.univ_uvar_id uv))) - | _ -> u - -(* deep_compress_*: eliminating all unification variables and delayed -substitutions in a sigelt. We traverse the entire syntactic structure -to evaluate the explicit lazy substitutions (Tm_delayed) and to replace -uvar nodes (Tm_uvar/U_unif) with their solutions. - -The return value of this function should *never* contain a lambda. This -applies to every component of the term/sigelt: attributes, metadata, BV -sorts, universes, memoized free variables, substitutions, etc. - -This is done to later dump the term/sigelt into a file (via OCaml's -output_value, for instance). This marshalling does not handle -closures[1] and we do not store the UF graph, so we cannot have any -lambdas and every uvar node that must be replaced by its solution (and -hence must have been resolved). - -Eliminating the substitutions and resolving uvars is all done by the -`compress` call in the implementation of Visit.visit_tm, so this all -looks like a big identity function. - -[1] OCaml's Marshal module can actually serialize closures, but this -makes .checked files more brittle, so we don't do it. -*) -let deep_compress (allow_uvars:bool) (allow_names: bool) (tm : term) : term = - Err.with_ctx ("While deep-compressing a term") (fun () -> - Visit.visit_term_univs true - (compress1_t allow_uvars allow_names) - (compress1_u allow_uvars allow_names) - tm - ) - -let deep_compress_uvars = deep_compress false true - -let deep_compress_if_no_uvars (tm : term) : option term = - Err.with_ctx ("While deep-compressing a term") (fun () -> - try - Some (Visit.visit_term_univs true - (compress1_t false true) - (compress1_u false true) - tm) - with - | Errors.Error (Err.Error_UnexpectedUnresolvedUvar, _, _, _) -> None - ) - -let deep_compress_se (allow_uvars:bool) (allow_names:bool) (se : sigelt) : sigelt = - Err.with_ctx (format1 "While deep-compressing %s" (Syntax.Print.sigelt_to_string_short se)) (fun () -> - Visit.visit_sigelt true - (compress1_t allow_uvars allow_names) - (compress1_u allow_uvars allow_names) - se - ) diff --git a/src/syntax/FStar.Syntax.Compress.fsti b/src/syntax/FStar.Syntax.Compress.fsti deleted file mode 100644 index b829a34203f..00000000000 --- a/src/syntax/FStar.Syntax.Compress.fsti +++ /dev/null @@ -1,19 +0,0 @@ -module FStar.Syntax.Compress - -open FStar.Syntax.Syntax - -(* Removes all delayed substitutions and resolved uvar nodes in a term. -if allow_uvars is false, it raises a hard error if an *unresolved* uvar -(term or universe) remains. Resolved uvars are replaced by their -solutions, as in compress. *) -val deep_compress (allow_uvars: bool) (allow_names: bool) (t:term) : term - -(* Alias for deep_compress false true. i.e. allows names but not uvars, -useful to check that a potentially open term does not have any uvars. *) -val deep_compress_uvars (t:term) : term - -(* Similar to `deep_compress false false t`, except instead of a hard error - this returns None in case an unresolved uvar is found. *) -val deep_compress_if_no_uvars (t:term) : option term - -val deep_compress_se (allow_uvars: bool) (allow_names: bool) (se:sigelt) : sigelt diff --git a/src/syntax/FStar.Syntax.DsEnv.fst b/src/syntax/FStar.Syntax.DsEnv.fst deleted file mode 100644 index 255f6c80863..00000000000 --- a/src/syntax/FStar.Syntax.DsEnv.fst +++ /dev/null @@ -1,1523 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Syntax.DsEnv -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.Compiler.Util -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.Syntax.Util -open FStar.Parser -open FStar.Ident -open FStar.Errors - -open FStar.Class.Show -open FStar.Class.Monad -open FStar.Class.Setlike - -let ugly_sigelt_to_string_hook : ref (sigelt -> string) = BU.mk_ref (fun _ -> "") -let ugly_sigelt_to_string (se:sigelt) : string = !ugly_sigelt_to_string_hook se - -module S = FStar.Syntax.Syntax -module U = FStar.Syntax.Util -module BU = FStar.Compiler.Util -module Const = FStar.Parser.Const - -type local_binding = (ident & bv & used_marker) (* local name binding for name resolution, paired with an env-generated unique name *) -type rec_binding = (ident & lid & (* name bound by recursive type and top-level let-bindings definitions only *) - used_marker) (* this ref marks whether it was used, so we can warn if not *) - -type scope_mod = -| Local_binding of local_binding -| Rec_binding of rec_binding -| Module_abbrev of module_abbrev -| Open_module_or_namespace of open_module_or_namespace -| Top_level_def of ident (* top-level definition for an unqualified identifier x to be resolved as curmodule.x. *) -| Record_or_dc of record_or_dc (* to honor interleavings of "open" and record definitions *) - -type string_set = RBSet.t string - -type exported_id_kind = (* kinds of identifiers exported by a module *) -| Exported_id_term_type (* term and type identifiers *) -| Exported_id_field (* field identifiers *) -type exported_id_set = exported_id_kind -> ref string_set - -type env = { - curmodule: option lident; (* name of the module being desugared *) - curmonad: option ident; (* current monad being desugared *) - modules: list (lident & modul); (* previously desugared modules *) - scope_mods: list scope_mod; (* a STACK of toplevel or definition-local scope modifiers *) - exported_ids: BU.smap exported_id_set; (* identifiers (stored as strings for efficiency) - reachable in a module, not shadowed by "include" - declarations. Used only to handle such shadowings, - not "private"/"abstract" definitions which it is - enough to just remove from the sigmap. Formally, - iden is in exported_ids[ModulA] if, and only if, - there is no 'include ModulB' (with ModulB.iden - defined or reachable) after iden in ModulA. *) - trans_exported_ids: BU.smap exported_id_set; (* transitive version of exported_ids along the - "include" relation: an identifier is in this set - for a module if and only if it is defined either - in this module or in one of its included modules. *) - includes: BU.smap (ref (list (lident & restriction))); (* list of "includes" declarations for each module. *) - sigaccum: sigelts; (* type declarations being accumulated for the current module *) - sigmap: BU.smap (sigelt & bool); (* bool indicates that this was declared in an interface file *) - iface: bool; (* whether or not we're desugaring an interface; different scoping rules apply *) - admitted_iface: bool; (* is it an admitted interface; different scoping rules apply *) - expect_typ: bool; (* syntactically, expect a type at this position in the term *) - remaining_iface_decls:list (lident&list Parser.AST.decl); (* A map from interface names to their stil-to-be-processed top-level decls *) - syntax_only: bool; (* Whether next push should skip type-checking *) - ds_hooks: dsenv_hooks; (* hooks that the interactive more relies onto for symbol tracking *) - dep_graph: FStar.Parser.Dep.deps -} -and dsenv_hooks = - { ds_push_open_hook : env -> open_module_or_namespace -> unit; - ds_push_include_hook : env -> lident -> unit; - ds_push_module_abbrev_hook : env -> ident -> lident -> unit } - -let mk_dsenv_hooks open_hook include_hook module_abbrev_hook = - { ds_push_open_hook = open_hook; - ds_push_include_hook = include_hook; - ds_push_module_abbrev_hook = module_abbrev_hook } - -let default_ds_hooks = - { ds_push_open_hook = (fun _ _ -> ()); - ds_push_include_hook = (fun _ _ -> ()); - ds_push_module_abbrev_hook = (fun _ _ _ -> ()) } - -let set_iface env b = {env with iface=b} -let iface e = e.iface -let set_admitted_iface e b = {e with admitted_iface=b} -let admitted_iface e = e.admitted_iface -let set_expect_typ e b = {e with expect_typ=b} -let expect_typ e = e.expect_typ -let all_exported_id_kinds: list exported_id_kind = [ Exported_id_field; Exported_id_term_type ] -let transitive_exported_ids env lid = - let module_name = Ident.string_of_lid lid in - match BU.smap_try_find env.trans_exported_ids module_name with - | None -> [] - | Some exported_id_set -> !(exported_id_set Exported_id_term_type) |> elems -let opens_and_abbrevs env : list (either open_module_or_namespace module_abbrev) = - List.collect - (function - | Open_module_or_namespace payload -> [Inl payload] - | Module_abbrev (id, lid) -> [Inr (id, lid)] - | _ -> []) - env.scope_mods - -let open_modules e = e.modules -let open_modules_and_namespaces env = - List.filter_map (function - | Open_module_or_namespace (lid, _info, _restriction) -> Some lid - | _ -> None) - env.scope_mods -let module_abbrevs env : list (ident & lident)= - List.filter_map (function - | Module_abbrev (l, m) -> Some (l, m) - | _ -> None) - env.scope_mods -let set_current_module e l = {e with curmodule=Some l} -let current_module env = match env.curmodule with - | None -> failwith "Unset current module" - | Some m -> m -let iface_decls env l = - match env.remaining_iface_decls |> - List.tryFind (fun (m, _) -> Ident.lid_equals l m) with - | None -> None - | Some (_, decls) -> Some decls -let set_iface_decls env l ds = - let _, rest = - FStar.Compiler.List.partition - (fun (m, _) -> Ident.lid_equals l m) - env.remaining_iface_decls in - {env with remaining_iface_decls=(l, ds)::rest} -let qual = qual_id -let qualify env id = - match env.curmonad with - | None -> qual (current_module env) id - | Some monad -> mk_field_projector_name_from_ident (qual (current_module env) monad) id -let syntax_only env = env.syntax_only -let set_syntax_only env b = { env with syntax_only = b } -let ds_hooks env = env.ds_hooks -let set_ds_hooks env hooks = { env with ds_hooks = hooks } -let new_sigmap () = BU.smap_create 100 -let empty_env deps = {curmodule=None; - curmonad=None; - modules=[]; - scope_mods=[]; - exported_ids=new_sigmap(); - trans_exported_ids=new_sigmap(); - includes=new_sigmap(); - sigaccum=[]; - sigmap=new_sigmap(); - iface=false; - admitted_iface=false; - expect_typ=false; - remaining_iface_decls=[]; - syntax_only=false; - ds_hooks=default_ds_hooks; - dep_graph=deps} -let dep_graph env = env.dep_graph -let set_dep_graph env ds = {env with dep_graph=ds} -let sigmap env = env.sigmap - -let set_bv_range bv r = - let id = set_id_range r bv.ppname in - {bv with ppname=id} - -let bv_to_name bv r = bv_to_name (set_bv_range bv r) - -let unmangleMap = [("op_ColonColon", "Cons", Some Data_ctor); - ("not", "op_Negation", None)] - -let unmangleOpName (id:ident) : option term = - find_map unmangleMap (fun (x,y,dq) -> - if string_of_id id = x - then Some (S.fvar_with_dd (lid_of_path ["Prims"; y] (range_of_id id)) dq) - else None) - -type cont_t 'a = - | Cont_ok of 'a (* found *) - | Cont_fail (* not found, do not retry *) - | Cont_ignore (* not found, retry *) - -let option_of_cont (k_ignore: unit -> option 'a) = function - | Cont_ok a -> Some a - | Cont_fail -> None - | Cont_ignore -> k_ignore () - -(* Unqualified identifier lookup *) - -let find_in_record ns id record cont = - let typename' = lid_of_ids (ns @ [ident_of_lid record.typename]) in - if lid_equals typename' record.typename - then - let fname = lid_of_ids (ns_of_lid record.typename @ [id]) in - let find = BU.find_map record.fields (fun (f, _) -> - if string_of_id id = string_of_id f - then Some record - else None) - in - match find with - | Some r -> cont r - | None -> Cont_ignore - else - Cont_ignore - -let get_exported_id_set (e: env) (mname: string) : option (exported_id_kind -> ref string_set) = - BU.smap_try_find e.exported_ids mname - -let get_trans_exported_id_set (e: env) (mname: string) : option (exported_id_kind -> ref string_set) = - BU.smap_try_find e.trans_exported_ids mname - -let string_of_exported_id_kind = function - | Exported_id_field -> "field" - | Exported_id_term_type -> "term/type" - -let is_exported_id_termtype = function - | Exported_id_term_type -> true - | _ -> false - -let is_exported_id_field = function - | Exported_id_field -> true - | _ -> false - - -let find_in_module_with_includes - (eikind: exported_id_kind) - (find_in_module: lident -> cont_t 'a) - (find_in_module_default: cont_t 'a) - env - (ns: lident) - (id: ident) - : cont_t 'a = - let rec aux = function - | [] -> - find_in_module_default - | (modul, id) :: q -> - let mname = string_of_lid modul in - let not_shadowed = match get_exported_id_set env mname with - | None -> true - | Some mex -> - let mexports = !(mex eikind) in - mem (string_of_id id) mexports - in - let mincludes = match BU.smap_try_find env.includes mname with - | None -> [] - | Some minc -> - !minc |> filter_map (fun (ns, restriction) -> - let opt = is_ident_allowed_by_restriction id restriction in - map_opt opt (fun id -> (ns, id))) - in - let look_into = - if not_shadowed - then find_in_module (qual modul id) - else Cont_ignore - in - begin match look_into with - | Cont_ignore -> - aux (mincludes @ q) - | _ -> - look_into - end - in aux [ (ns, id) ] - -let try_lookup_id'' - env - (id: ident) - (eikind: exported_id_kind) - (k_local_binding: local_binding -> cont_t 'a) - (k_rec_binding: rec_binding -> cont_t 'a) - (k_record: (record_or_dc) -> cont_t 'a) - (find_in_module: lident -> cont_t 'a) - (lookup_default_id: cont_t 'a -> ident -> cont_t 'a) : option 'a - = - let check_local_binding_id : local_binding -> bool = function - (id', _, _) -> string_of_id id' = string_of_id id - in - let check_rec_binding_id : rec_binding -> bool = function - (id', _, _) -> string_of_id id' = string_of_id id - in - let curmod_ns = ids_of_lid (current_module env) in - let proc = function - | Local_binding l - when check_local_binding_id l -> - let (_, _, used_marker) = l in - used_marker := true; - k_local_binding l - - | Rec_binding r - when check_rec_binding_id r -> - let (_, _, used_marker) = r in - used_marker := true; - k_rec_binding r - - | Open_module_or_namespace (ns, Open_module, restriction) -> - ( match is_ident_allowed_by_restriction id restriction with - | None -> Cont_ignore - | Some id -> find_in_module_with_includes eikind find_in_module Cont_ignore env ns id) - - | Top_level_def id' - when string_of_id id' = string_of_id id -> - (* indicates a global definition shadowing previous - "open"s. If the definition is not actually found by the - [lookup_default_id] finder, then it may mean that we are in a - module and the [val] was already declared, with the actual - [let] not defined yet, so we must not fail, but ignore. *) - lookup_default_id Cont_ignore id - - | Record_or_dc r - when (is_exported_id_field eikind) -> - find_in_module_with_includes Exported_id_field ( - fun lid -> - let id = ident_of_lid lid in - find_in_record (ns_of_lid lid) id r k_record - ) Cont_ignore env (lid_of_ids curmod_ns) id - - | Record_or_dc r - when (is_exported_id_termtype eikind) -> - if ident_equals (ident_of_lid r.typename) id - then k_record r - else Cont_ignore - - | _ -> - Cont_ignore - in - let rec aux = function - | a :: q -> - option_of_cont (fun _ -> aux q) (proc a) - | [] -> - option_of_cont (fun _ -> None) (lookup_default_id Cont_fail id) - - in aux env.scope_mods - -let found_local_binding r (id', x, _) = - (bv_to_name x r) - -let find_in_module env lid k_global_def k_not_found = - begin match BU.smap_try_find (sigmap env) (string_of_lid lid) with - | Some sb -> k_global_def lid sb - | None -> k_not_found - end - -let try_lookup_id env (id:ident) : option term = - match unmangleOpName id with - | Some f -> Some f - | _ -> - try_lookup_id'' env id Exported_id_term_type (fun r -> Cont_ok (found_local_binding (range_of_id id) r)) (fun _ -> Cont_fail) (fun _ -> Cont_ignore) (fun i -> find_in_module env i (fun _ _ -> Cont_fail) Cont_ignore) (fun _ _ -> Cont_fail) - -(* Unqualified identifier lookup, if lookup in all open namespaces failed. *) - -let lookup_default_id - env - (id: ident) - (k_global_def: lident -> sigelt & bool -> cont_t 'a) - (k_not_found: cont_t 'a) - = - let find_in_monad = match env.curmonad with - | Some _ -> - let lid = qualify env id in - begin match BU.smap_try_find (sigmap env) (string_of_lid lid) with - | Some r -> Some (k_global_def lid r) - | None -> None - end - | None -> None - in - match find_in_monad with - | Some v -> v - | None -> - let lid = qual (current_module env) id in - find_in_module env lid k_global_def k_not_found - -let lid_is_curmod env lid = - match env.curmodule with - | None -> false - | Some m -> lid_equals lid m - -let module_is_defined env lid = - lid_is_curmod env lid || - List.existsb (fun x -> lid_equals lid (fst x)) env.modules - -let resolve_module_name env lid (honor_ns: bool) : option lident = - let nslen = List.length (ns_of_lid lid) in - let rec aux = function - | [] -> - if module_is_defined env lid - then Some lid - else None - - | Open_module_or_namespace (ns, Open_namespace, restriction) :: q - when honor_ns -> - let new_lid = lid_of_path (path_of_lid ns @ path_of_lid lid) (range_of_lid lid) - in - if module_is_defined env new_lid - then - Some new_lid - else aux q - - | Module_abbrev (name, modul) :: _ - when nslen = 0 && (string_of_id name) = (string_of_id (ident_of_lid lid)) -> - Some modul - - | _ :: q -> - aux q - - in - aux env.scope_mods - -let is_open env lid open_kind = - List.existsb (function - | Open_module_or_namespace (ns, k, Unrestricted) -> k = open_kind && lid_equals lid ns - | _ -> false) env.scope_mods - -let namespace_is_open env lid = - is_open env lid Open_namespace - -let module_is_open env lid = - lid_is_curmod env lid || is_open env lid Open_module - -// FIXME this could be faster (module_is_open and namespace_is_open are slow) -let shorten_module_path env ids is_full_path = - let rec aux revns id = - let lid = FStar.Ident.lid_of_ns_and_id (List.rev revns) id in - if namespace_is_open env lid - then Some (List.rev (id :: revns), []) - else match revns with - | [] -> None - | ns_last_id :: rev_ns_prefix -> - aux rev_ns_prefix ns_last_id |> - BU.map_option (fun (stripped_ids, rev_kept_ids) -> - (stripped_ids, id :: rev_kept_ids)) in - let do_shorten env ids = - // Do the actual shortening. FIXME This isn't optimal (no includes). - match List.rev ids with - | [] -> ([], []) - | ns_last_id :: ns_rev_prefix -> - match aux ns_rev_prefix ns_last_id with - | None -> ([], ids) - | Some (stripped_ids, rev_kept_ids) -> (stripped_ids, List.rev rev_kept_ids) in - - if is_full_path && List.length ids > 0 then - // Try to strip the entire prefix. This is the cheap common case. - match resolve_module_name env (FStar.Ident.lid_of_ids ids) true with - | Some m when module_is_open env m -> (ids, []) - | _ -> do_shorten env ids - else - do_shorten env ids - -(* Generic name resolution. *) - -let resolve_in_open_namespaces'' - env - lid - (eikind: exported_id_kind) - (k_local_binding: local_binding -> cont_t 'a) - (k_rec_binding: rec_binding -> cont_t 'a) - (k_record: (record_or_dc) -> cont_t 'a) - (f_module: lident -> cont_t 'a) - (l_default: cont_t 'a -> ident -> cont_t 'a) - : option 'a = - match ns_of_lid lid with - | _ :: _ -> - begin match resolve_module_name env (set_lid_range (lid_of_ids (ns_of_lid lid)) (range_of_lid lid)) true with - | None -> None - | Some modul -> - option_of_cont (fun _ -> None) (find_in_module_with_includes eikind f_module Cont_fail env modul (ident_of_lid lid)) - end - | [] -> - try_lookup_id'' env (ident_of_lid lid) eikind k_local_binding k_rec_binding k_record f_module l_default - -let cont_of_option (k_none: cont_t 'a) = function - | Some v -> Cont_ok v - | None -> k_none - -let resolve_in_open_namespaces' - env - lid - (k_local_binding: local_binding -> option 'a) - (k_rec_binding: rec_binding -> option 'a) - (k_global_def: lident -> (sigelt & bool) -> option 'a) - : option 'a = - let k_global_def' k lid def = cont_of_option k (k_global_def lid def) in - let f_module lid' = let k = Cont_ignore in find_in_module env lid' (k_global_def' k) k in - let l_default k i = lookup_default_id env i (k_global_def' k) k in - resolve_in_open_namespaces'' env lid Exported_id_term_type - (fun l -> cont_of_option Cont_fail (k_local_binding l)) - (fun r -> cont_of_option Cont_fail (k_rec_binding r)) - (fun _ -> Cont_ignore) - f_module - l_default - -let fv_qual_of_se = fun se -> match se.sigel with - | Sig_datacon {ty_lid=l} -> - let qopt = BU.find_map se.sigquals (function - | RecordConstructor (_, fs) -> Some (Record_ctor(l, fs)) - | _ -> None) in - begin match qopt with - | None -> Some Data_ctor - | x -> x - end - | Sig_declare_typ _ -> //TODO: record projectors? - None - | _ -> None - -let lb_fv lbs lid = - BU.find_map lbs (fun lb -> - let fv = right lb.lbname in - if S.fv_eq_lid fv lid then Some fv else None) |> must - -let ns_of_lid_equals (lid: lident) (ns: lident) = - List.length (ns_of_lid lid) = List.length (ids_of_lid ns) && - lid_equals (lid_of_ids (ns_of_lid lid)) ns - -let try_lookup_name any_val exclude_interf env (lid:lident) : option foundname = - let occurrence_range = Ident.range_of_lid lid in - - let k_global_def source_lid = function - | (_, true) when exclude_interf -> None - | (se, _) -> - begin match se.sigel with - | Sig_inductive_typ _ -> Some (Term_name (S.fvar_with_dd source_lid None, se.sigattrs)) - | Sig_datacon _ -> Some (Term_name (S.fvar_with_dd source_lid (fv_qual_of_se se), se.sigattrs)) - | Sig_let {lbs=(_, lbs)} -> - let fv = lb_fv lbs source_lid in - Some (Term_name (S.fvar_with_dd source_lid fv.fv_qual, se.sigattrs)) - | Sig_declare_typ {lid} -> - let quals = se.sigquals in - if any_val //only in scope in an interface (any_val is true) or if the val is assumed - || quals |> BU.for_some (function Assumption -> true | _ -> false) - then let lid = Ident.set_lid_range lid (Ident.range_of_lid source_lid) in - begin match BU.find_map quals (function Reflectable refl_monad -> Some refl_monad | _ -> None) with //this is really a M?.reflect - | Some refl_monad -> - let refl_const = S.mk (Tm_constant (FStar.Const.Const_reflect refl_monad)) occurrence_range in - Some (Term_name (refl_const, se.sigattrs)) - | _ -> - Some (Term_name(fvar_with_dd lid (fv_qual_of_se se), se.sigattrs)) - end - else None - | Sig_new_effect(ne) -> Some (Eff_name(se, set_lid_range ne.mname (range_of_lid source_lid))) - | Sig_effect_abbrev _ -> Some (Eff_name(se, source_lid)) - | Sig_splice {lids; tac=t} -> - // TODO: This depth is probably wrong - Some (Term_name (S.fvar_with_dd source_lid None, [])) - | _ -> None - end in - - let k_local_binding r = let t = found_local_binding (range_of_lid lid) r in Some (Term_name (t, [])) - in - - let k_rec_binding (id, l, used_marker) = - used_marker := true; - Some (Term_name(S.fvar_with_dd (set_lid_range l (range_of_lid lid)) None, [])) - in - - let found_unmangled = match ns_of_lid lid with - | [] -> - begin match unmangleOpName (ident_of_lid lid) with - | Some t -> Some (Term_name (t, [])) - | _ -> None - end - | _ -> None - in - - match found_unmangled with - | None -> resolve_in_open_namespaces' env lid k_local_binding k_rec_binding k_global_def - | x -> x - -let try_lookup_effect_name' exclude_interf env (lid:lident) : option (sigelt&lident) = - match try_lookup_name true exclude_interf env lid with - | Some (Eff_name(o, l)) -> Some (o,l) - | _ -> None -let try_lookup_effect_name env l = - match try_lookup_effect_name' (not env.iface) env l with - | Some (o, l) -> Some l - | _ -> None -let try_lookup_effect_name_and_attributes env l = - match try_lookup_effect_name' (not env.iface) env l with - | Some ({ sigel = Sig_new_effect(ne) }, l) -> Some (l, ne.cattributes) - | Some ({ sigel = Sig_effect_abbrev {cflags=cattributes} }, l) -> Some (l, cattributes) - | _ -> None -let try_lookup_effect_defn env l = - match try_lookup_effect_name' (not env.iface) env l with - | Some ({ sigel = Sig_new_effect(ne) }, _) -> Some ne - | _ -> None -let is_effect_name env lid = - match try_lookup_effect_name env lid with - | None -> false - | Some _ -> true -(* Same as [try_lookup_effect_name], but also traverses effect -abbrevs. TODO: once indexed effects are in, also track how indices and -other arguments are instantiated. *) -let try_lookup_root_effect_name env l = - match try_lookup_effect_name' (not env.iface) env l with - | Some ({ sigel = Sig_effect_abbrev {lid=l'} }, _) -> - let rec aux new_name = - match BU.smap_try_find (sigmap env) (string_of_lid new_name) with - | None -> None - | Some (s, _) -> - begin match s.sigel with - | Sig_new_effect(ne) - -> Some (set_lid_range ne.mname (range_of_lid l)) - | Sig_effect_abbrev {comp=cmp} -> - let l'' = U.comp_effect_name cmp in - aux l'' - | _ -> None - end - in aux l' - | Some (_, l') -> Some l' - | _ -> None - -let lookup_letbinding_quals_and_attrs env lid = - let k_global_def lid = function - | ({sigel = Sig_declare_typ _; sigquals=quals; sigattrs=attrs }, _) -> - Some (quals, attrs) - | _ -> - None in - match resolve_in_open_namespaces' env lid (fun _ -> None) (fun _ -> None) k_global_def with - | Some qa -> qa - | _ -> [], [] - -let try_lookup_module env path = - match List.tryFind (fun (mlid, modul) -> path_of_lid mlid = path) env.modules with - | Some (_, modul) -> Some modul - | None -> None - -let try_lookup_let env (lid:lident) = - let k_global_def lid = function - | ({ sigel = Sig_let {lbs=(_, lbs)} }, _) -> - let fv = lb_fv lbs lid in - Some (fvar_with_dd lid fv.fv_qual) - | _ -> None in - resolve_in_open_namespaces' env lid (fun _ -> None) (fun _ -> None) k_global_def - -let try_lookup_definition env (lid:lident) = - let k_global_def lid = function - | ({ sigel = Sig_let {lbs} }, _) -> - BU.find_map (snd lbs) (fun lb -> - match lb.lbname with - | Inr fv when S.fv_eq_lid fv lid -> - Some (lb.lbdef) - | _ -> None) - | _ -> None in - resolve_in_open_namespaces' env lid (fun _ -> None) (fun _ -> None) k_global_def - - -let empty_include_smap : BU.smap (ref (list (lident & restriction))) = new_sigmap() -let empty_exported_id_smap : BU.smap exported_id_set = new_sigmap() - -let try_lookup_lid' any_val exclude_interface env (lid:lident) : option (term & list attribute) = - match try_lookup_name any_val exclude_interface env lid with - | Some (Term_name (e, attrs)) -> Some (e, attrs) - | _ -> None - -let drop_attributes (x:option (term & list attribute)) :option (term) = - match x with - | Some (t, _) -> Some t - | None -> None - -let try_lookup_lid_with_attributes (env:env) (l:lident) :(option (term & list attribute)) = try_lookup_lid' env.iface false env l -let try_lookup_lid (env:env) l = try_lookup_lid_with_attributes env l |> drop_attributes - -let resolve_to_fully_qualified_name (env:env) (l:lident) : option lident = - let r = - match try_lookup_name true false env l with - | Some (Term_name (e, attrs)) -> - begin match (Subst.compress e).n with - | Tm_fvar fv -> Some fv.fv_name.v - | _ -> None - end - | Some (Eff_name (o, l)) -> Some l - | None -> None - in - r - -(* Is this module lid abbreviated? If there is a module M = A.B in scope, -then this returns Some M for A.B (but not for its descendants). *) -let is_abbrev env lid : option ipath = - List.tryPick (function - | Module_abbrev (id, ns) when lid_equals lid ns -> - Some [id] - | _ -> None) - env.scope_mods - -(* Abbreviate a module lid. If there is a module M = A.B.C in scope, -then this returns Some (M, C.D) for A.B.C.D (unless there is a more -specific abbrev, such as one for A.B.C or A.B.C.D) *) -let try_shorten_abbrev (env:env) (ns:ipath) : option (ipath & list ident) = - let rec aux (ns : ipath) (rest : list ident) = - match ns with - | [] -> None - | hd::tl -> - match is_abbrev env (lid_of_ids (rev ns)) with - | Some short -> Some (short, rest) - | _ -> - aux tl (hd::rest) - in - aux (rev ns) [] - -let shorten_lid' (env:env) (lid0:lident) : lident = - (* Id and namespace *) - let id0 = ident_of_lid lid0 in - let ns0 = ns_of_lid lid0 in - - (* If this lid is "below" some abbreviation, find it and use it unconditionally. *) - let pref, ns = - match try_shorten_abbrev env ns0 with - | None -> [], ns0 - | Some (ns, rest) -> ns, rest - in - - (* Move to FStar.List.Tot.Base? *) - let rec tails l = match l with - | [] -> [[]] - | _::tl -> l::(tails tl) - in - - (* Namespace suffixes, in increasing order of length *) - let suffs = rev (tails ns) in - - (* Does this shortened lid' resolve to the original lid0? *) - let try1 (lid' : lident) : bool = - match resolve_to_fully_qualified_name env lid' with - | Some lid2 when Ident.lid_equals lid2 lid0 -> true - | _ -> false - in - - let rec go (nss : list (list ident)) : lid = - match nss with - | ns::rest -> - let lid' = lid_of_ns_and_id (pref @ ns) id0 in - if try1 lid' - then lid' - else go rest - - | [] -> - (* This should be unreachable. Warn? *) - lid0 - in - let r = go suffs in - r - -let shorten_lid env lid0 = - match env.curmodule with - | None -> lid0 - | _ -> shorten_lid' env lid0 - -let try_lookup_lid_with_attributes_no_resolve (env: env) l :option (term & list attribute) = - let env' = {env with scope_mods = [] ; exported_ids=empty_exported_id_smap; includes=empty_include_smap } - in - try_lookup_lid_with_attributes env' l - -let try_lookup_lid_no_resolve (env: env) l :option term = try_lookup_lid_with_attributes_no_resolve env l |> drop_attributes - -let try_lookup_datacon env (lid:lident) = - let k_global_def lid se = - match se with - | ({ sigel = Sig_declare_typ _; sigquals = quals }, _) -> - if quals |> BU.for_some (function Assumption -> true | _ -> false) - then Some (lid_and_dd_as_fv lid None) - else None - | ({ sigel = Sig_splice _ }, _) (* A spliced datacon *) - | ({ sigel = Sig_datacon _ }, _) -> - let qual = fv_qual_of_se (fst se) in - Some (lid_and_dd_as_fv lid qual) - | _ -> None in - resolve_in_open_namespaces' env lid (fun _ -> None) (fun _ -> None) k_global_def - -let find_all_datacons env (lid:lident) = - // - // AR: TODO: What's happening here? The function name is find_all_datacons, but - // it is returning mutuals? - // - let k_global_def lid = function - | ({ sigel = Sig_inductive_typ {mutuals=datas} }, _) -> Some datas - | _ -> None in - resolve_in_open_namespaces' env lid (fun _ -> None) (fun _ -> None) k_global_def - -let record_cache_aux_with_filter = - // push, pop, etc. already signal-atomic: no need for BU.atomically - let record_cache : ref (list (list record_or_dc)) = BU.mk_ref [[]] in - let push () = - record_cache := List.hd !record_cache::!record_cache in - let pop () = - record_cache := List.tl !record_cache in - let snapshot () = Common.snapshot push record_cache () in - let rollback depth = Common.rollback pop record_cache depth in - let peek () = List.hd !record_cache in - let insert r = record_cache := (r::peek())::List.tl (!record_cache) in - (* remove private/abstract records *) - let filter () = - let rc = peek () in - let filtered = List.filter (fun r -> not r.is_private) rc in - record_cache := filtered :: List.tl !record_cache - in - let aux = - ((push, pop), ((snapshot, rollback), (peek, insert))) - in (aux, filter) - -let record_cache_aux = fst record_cache_aux_with_filter -let filter_record_cache = snd record_cache_aux_with_filter -let push_record_cache = fst (fst record_cache_aux) -let pop_record_cache = snd (fst record_cache_aux) -let snapshot_record_cache = fst (fst (snd record_cache_aux)) -let rollback_record_cache = snd (fst (snd record_cache_aux)) -let peek_record_cache = fst (snd (snd record_cache_aux)) -let insert_record_cache = snd (snd (snd record_cache_aux)) - -let extract_record (e:env) (new_globs: ref (list scope_mod)) = fun se -> match se.sigel with - | Sig_bundle {ses=sigs} -> - let is_record = BU.for_some (function - | RecordType _ - | RecordConstructor _ -> true - | _ -> false) in - - let find_dc dc = - sigs |> BU.find_opt (function - | { sigel = Sig_datacon {lid} } -> lid_equals dc lid - | _ -> false) in - - sigs |> List.iter (function - | { sigel = Sig_inductive_typ {lid=typename; - us=univs; - params=parms; - ds=[dc]}; sigquals = typename_quals } -> - begin match must <| find_dc dc with - | { sigel = Sig_datacon {lid=constrname; t; num_ty_params=n} } -> - let all_formals, _ = U.arrow_formals t in - (* Ignore parameters, we don't create projectors for them *) - let _params, formals = BU.first_N n all_formals in - let is_rec = is_record typename_quals in - let formals' = formals |> List.collect (fun f -> - if S.is_null_bv f.binder_bv - || (is_rec && S.is_bqual_implicit f.binder_qual) - then [] - else [f] ) - in - let fields' = formals' |> List.map (fun f -> (f.binder_bv.ppname, f.binder_bv.sort)) - in - let fields = fields' - in - let record = {typename=typename; - constrname=ident_of_lid constrname; - parms=parms; - fields=fields; - is_private = List.contains Private typename_quals; - is_record=is_rec} in - (* the record is added to the current list of - top-level definitions, to allow shadowing field names - that were reachable through previous "open"s. *) - let () = new_globs := Record_or_dc record :: !new_globs in - (* the field names are added into the set of exported fields for "include" *) - let () = - let add_field (id, _) = - let modul = string_of_lid (lid_of_ids (ns_of_lid constrname)) in - match get_exported_id_set e modul with - | Some my_ex -> - let my_exported_ids = my_ex Exported_id_field in - let () = my_exported_ids := add (string_of_id id) !my_exported_ids in - (* also add the projector name *) - let projname = mk_field_projector_name_from_ident constrname id - |> ident_of_lid - |> string_of_id - in - let () = my_exported_ids := add projname !my_exported_ids in - () - | None -> () (* current module was not prepared? should not happen *) - in - List.iter add_field fields' - in - insert_record_cache record - | _ -> () - end - | _ -> ()) - - | _ -> () - -let try_lookup_record_or_dc_by_field_name env (fieldname:lident) = - let find_in_cache fieldname = - let ns, id = ns_of_lid fieldname, ident_of_lid fieldname in - BU.find_map - (peek_record_cache()) - (fun record -> - option_of_cont (fun _ -> None) (find_in_record ns id record (fun r -> Cont_ok r))) - in - resolve_in_open_namespaces'' - env - fieldname - Exported_id_field - (fun _ -> Cont_ignore) - (fun _ -> Cont_ignore) - (fun r -> Cont_ok r) - (fun fn -> cont_of_option Cont_ignore (find_in_cache fn)) - (fun k _ -> k) - -let try_lookup_record_by_field_name env (fieldname:lident) = - match try_lookup_record_or_dc_by_field_name env fieldname with - | Some r when r.is_record -> Some r - | _ -> None - -let try_lookup_record_type env (typename:lident) : option record_or_dc = - let find_in_cache (name:lident) : option record_or_dc = - let ns, id = ns_of_lid name, ident_of_lid name in - BU.find_map (peek_record_cache()) (fun record -> - if ident_equals (ident_of_lid record.typename) id - then Some record - else None - ) - in - resolve_in_open_namespaces'' env typename - Exported_id_term_type - (fun _ -> Cont_ignore) - (fun _ -> Cont_ignore) - (fun r -> Cont_ok r) - (fun l -> cont_of_option Cont_ignore (find_in_cache l)) - (fun k _ -> k) - -let belongs_to_record env lid record = - (* first determine whether lid is a valid record field name, and - that it resolves to a record' type in the same module as record - (even though the record types may be different.) *) - match try_lookup_record_by_field_name env lid with - | Some record' - when nsstr record.typename = nsstr record'.typename -> - (* now, check whether field belongs to record *) - begin match find_in_record (ns_of_lid record.typename) (ident_of_lid lid) record (fun _ -> Cont_ok ()) with - | Cont_ok _ -> true - | _ -> false - end - | _ -> false - -let try_lookup_dc_by_field_name env (fieldname:lident) = - match try_lookup_record_or_dc_by_field_name env fieldname with - | Some r -> Some (set_lid_range (lid_of_ids (ns_of_lid r.typename @ [r.constrname])) (range_of_lid fieldname), r.is_record) - | _ -> None - -let string_set_ref_new () : ref string_set = BU.mk_ref (empty ()) -let exported_id_set_new () = - let term_type_set = string_set_ref_new () in - let field_set = string_set_ref_new () in - function - | Exported_id_term_type -> term_type_set - | Exported_id_field -> field_set - -let unique any_val exclude_interface env lid = - (* Disable name resolution altogether, thus lid is assumed to be fully qualified *) - let filter_scope_mods = function - | Rec_binding _ - -> true - | _ -> false - in - let this_env = {env with scope_mods = List.filter filter_scope_mods env.scope_mods; exported_ids=empty_exported_id_smap; includes=empty_include_smap } in - match try_lookup_lid' any_val exclude_interface this_env lid with - | None -> true - | Some _ -> false - -let push_scope_mod env scope_mod = - {env with scope_mods = scope_mod :: env.scope_mods} - -let push_bv' env (x:ident) = - let r = range_of_id x in - let bv = S.gen_bv (string_of_id x) (Some r) ({ tun with pos = r }) in - let used_marker = BU.mk_ref false in - push_scope_mod env (Local_binding (x, bv, used_marker)), bv, used_marker - -let push_bv env x = - let (env, bv, _) = push_bv' env x in - (env, bv) - -let push_top_level_rec_binding env0 (x:ident) : env & ref bool = - let l = qualify env0 x in - if unique false true env0 l || Options.interactive () - then - let used_marker = BU.mk_ref false in - (push_scope_mod env0 (Rec_binding (x,l,used_marker)), used_marker) - else raise_error l Errors.Fatal_DuplicateTopLevelNames - ("Duplicate top-level names " ^ (string_of_lid l)) - -let push_sigelt' fail_on_dup env s = - let err l = - let sopt = BU.smap_try_find (sigmap env) (string_of_lid l) in - let r = match sopt with - | Some (se, _) -> - begin match BU.find_opt (lid_equals l) (lids_of_sigelt se) with - | Some l -> Range.string_of_range <| range_of_lid l - | None -> "" - end - | None -> "" in - raise_error l Errors.Fatal_DuplicateTopLevelNames [ - Errors.text (BU.format1 "Duplicate top-level names [%s]" (string_of_lid l)); - Errors.text (BU.format1 "Previously declared at %s" r) - ] - in - let globals = BU.mk_ref env.scope_mods in - let env = - let any_val, exclude_interface = match s.sigel with - | Sig_let _ - | Sig_bundle _ -> false, true - | _ -> false, false in - let lids = lids_of_sigelt s in - begin match BU.find_map lids (fun l -> if not (unique any_val exclude_interface env l) then Some l else None) with - | Some l when fail_on_dup -> err l - | _ -> extract_record env globals s; {env with sigaccum=s::env.sigaccum} - end in - let env = {env with scope_mods = !globals} in - let env, lss = match s.sigel with - | Sig_bundle {ses} -> env, List.map (fun se -> (lids_of_sigelt se, se)) ses - | _ -> env, [lids_of_sigelt s, s] in - lss |> List.iter (fun (lids, se) -> - lids |> List.iter (fun lid -> - (* the identifier is added into the list of global - declarations, to allow shadowing of definitions that were - formerly reachable by previous "open"s. *) - let () = globals := Top_level_def (ident_of_lid lid) :: !globals in - (* the identifier is added into the list of global identifiers - of the corresponding module to shadow any "include" *) - let modul = string_of_lid (lid_of_ids (ns_of_lid lid)) in - let () = match get_exported_id_set env modul with - | Some f -> - let my_exported_ids = f Exported_id_term_type in - my_exported_ids := add (string_of_id (ident_of_lid lid)) !my_exported_ids - | None -> () (* current module was not prepared? should not happen *) - in - let is_iface = env.iface && not env.admitted_iface in -// printfn "Adding %s at key %s with flag %A" (FStar.Syntax.Print.sigelt_to_string_short se) (string_of_lid lid) is_iface; - BU.smap_add (sigmap env) (string_of_lid lid) (se, env.iface && not env.admitted_iface))); - let env = {env with scope_mods = !globals } in - env - -let push_sigelt env se = push_sigelt' true env se -let push_sigelt_force env se = push_sigelt' false env se - -let find_data_constructors_for_typ env (lid:lident) = - let k_global_def lid = function - | ({ sigel = Sig_inductive_typ {ds} }, _) -> Some ds - | _ -> None in - resolve_in_open_namespaces' env lid (fun _ -> None) (fun _ -> None) k_global_def - -let find_binders_for_datacons env (lid:lident) = - let k_global_def lid = function - | ({ sigel = Sig_datacon {t} }, _) -> - arrow_formals_comp_ln t - |> fst - |> List.map (fun x -> x.binder_bv.ppname) - |> Some - | _ -> None in - resolve_in_open_namespaces' env lid (fun _ -> None) (fun _ -> None) k_global_def - -(** Elaborates a `restriction`: this function adds implicit names -(projectors, discriminators, record fields) that F* generates -automatically. It also checks that all the idents the user added -actually exists in the given namespace. *) -let elab_restriction f env ns restriction = - let open FStar.Class.Deq in - match restriction with - | Unrestricted -> f env ns restriction - | AllowList l -> - let mk_lid (id: ident): lident = set_lid_range (lid_of_ids (ids_of_lid (qual_id ns id))) (range_of_id id) in - let name_exists id = - let lid = mk_lid id in - match try_lookup_lid env lid with - | Some _ -> true - | None -> try_lookup_record_or_dc_by_field_name env lid |> is_some - in - // For every inductive, we include its constructors - let l = List.map (fun (id, renamed) -> - let with_id_range = dflt id renamed |> range_of_id |> set_id_range in - match find_data_constructors_for_typ env (mk_lid id) with - | Some idents -> List.map (fun id -> (ident_of_lid id |> with_id_range, None)) idents - | None -> [] - ) l |> List.flatten |> List.append l in - // For every constructor, we include possible desugared record - // payloads types - let l = - (* A (precomputed) associated list that maps a constructors to - types that comes from a "record-on-a-variant" desugar. E.g. `A` - is mapped to `Mka__A__payload` for a `type a = | A {x:int}`. *) - let constructor_lid_to_desugared_record_lids: list (ident * ident) = - begin let! (_, {declarations}) = env.modules in - let! sigelt = declarations in - let! sigelt = match sigelt.sigel with | Sig_bundle {ses} -> ses | _ -> [] in - let! lid = lids_of_sigelt sigelt in - match U.get_attribute Const.desugar_of_variant_record_lid sigelt.sigattrs with - | Some [({n = Tm_constant (FStar.Const.Const_string (s, _))}, None)] - -> [(lid_of_str s, lid)] - | _ -> [] - end - |> List.filter (fun (cons, lid) -> ns_of_lid cons =? ns_of_lid lid - && ns_of_lid lid =? ids_of_lid ns) - |> List.map (fun (cons, lid) -> (ident_of_lid cons, ident_of_lid lid)) - in constructor_lid_to_desugared_record_lids - |> List.filter (fun (cons, _) -> List.find (fun (lid, _) -> lid =? cons) l |> Some?) - |> List.map (fun (_, lid) -> (lid, None)) - |> List.append l - in - let l = List.map (fun (id, renamed) -> - let with_renamed_range = dflt id renamed |> range_of_id |> set_id_range in - let with_id_range = dflt id renamed |> range_of_id |> set_id_range in - let lid = mk_lid id in - begin - // If `id` is a datatype, we include its projections - ((match find_binders_for_datacons env lid with | None -> [] | Some l -> l) - |> List.map (fun binder -> - ( mk_field_projector_name_from_ident lid binder - |> ident_of_lid - , map_opt renamed (fun renamed -> - mk_field_projector_name_from_ident (lid_of_ids [renamed]) binder - |> ident_of_lid - ) - ) - )) - // If `id` is a datatype, we include its discriminator - // (actually, we always include a discriminator, it will be - // removed if it doesn't exist) - @ ( [ mk_discriminator (lid_of_ids [id]) - , map_opt renamed (fun renamed -> mk_discriminator (lid_of_ids [renamed])) - ] |> List.map (fun (x, y) -> (ident_of_lid x, map_opt y ident_of_lid)) - |> List.filter (fun (x, _) -> name_exists x)) - // If `id` is a record, we include its fields - @ ( match try_lookup_record_type env lid with - | Some {constrname; fields} -> List.map (fun (id, _) -> (id, None)) fields - | None -> []) - end |> List.map (fun (id, renamed) -> (with_id_range id, map_opt renamed with_renamed_range)) - ) l |> List.flatten |> List.append l in - let _error_on_duplicates = - let final_idents = List.mapi (fun i (id, renamed) -> (dflt id renamed, i)) l in - match final_idents |> find_dup (fun (x, _) (y, _) -> x =? y) with - | Some (id, i) -> - let others = List.filter (fun (id', i') -> id =? id' && not (i =? i')) final_idents in - List.mapi (fun nth (other, _) -> - let nth = match nth with | 0 -> "first" | 1 -> "second" | 2 -> "third" | nth -> show (nth + 1) ^ "th" in - { - issue_msg = [show other ^ " " ^ nth ^ " occurence comes from this declaration" |> FStar.Errors.Msg.text]; - issue_level = EError; - issue_range = Some (range_of_id other); - issue_number = None; - issue_ctx = []; - } - ) others |> add_issues; - raise_error id Errors.Fatal_DuplicateTopLevelNames - (BU.format1 ("The name %s was imported " ^ show (List.length others + 1) ^ " times") (string_of_id id)) - | None -> () - in - l |> List.iter (fun (id, _renamed) -> - if name_exists id |> not - then raise_error id Errors.Fatal_NameNotFound - (BU.format1 "Definition %s cannot be found" (mk_lid id |> string_of_lid))); - f env ns (AllowList l) - -let push_namespace' env ns restriction = - (* namespace resolution disabled, but module abbrevs enabled *) - (* GM: What's the rationale for this? *) - let (ns', kd) = - match resolve_module_name env ns false with - | None -> ( - let module_names = List.map fst env.modules in - let module_names = - match env.curmodule with - | None -> module_names - | Some l -> l::module_names - in - if module_names |> - BU.for_some - (fun m -> - BU.starts_with (Ident.string_of_lid m ^ ".") - (Ident.string_of_lid ns ^ ".")) - then (ns, Open_namespace) - else raise_error ns Errors.Fatal_NameSpaceNotFound - (BU.format1 "Namespace %s cannot be found" (Ident.string_of_lid ns)) - ) - | Some ns' -> - (ns', Open_module) - in - env.ds_hooks.ds_push_open_hook env (ns', kd, restriction); - push_scope_mod env (Open_module_or_namespace (ns', kd, restriction)) - -let push_include' env ns restriction = - (* similarly to push_namespace in the case of modules, we allow - module abbrevs, but not namespace resolution *) - let ns0 = ns in - match resolve_module_name env ns false with - | Some ns -> - env.ds_hooks.ds_push_include_hook env ns; - (* from within the current module, include is equivalent to open *) - let env = push_scope_mod env (Open_module_or_namespace (ns, Open_module, restriction)) in - (* update the list of includes *) - let curmod = string_of_lid (current_module env) in - let () = match BU.smap_try_find env.includes curmod with - | None -> () - | Some incl -> incl := (ns, restriction) :: !incl - in - (* the names of the included module and its transitively - included modules shadow the names of the current module *) - begin match get_trans_exported_id_set env (string_of_lid ns) with - | Some ns_trans_exports -> - let () = match (get_exported_id_set env curmod, get_trans_exported_id_set env curmod) with - | (Some cur_exports, Some cur_trans_exports) -> - let update_exports (k: exported_id_kind) = - let ns_ex = ! (ns_trans_exports k) in - let ex = cur_exports k in - let () = ex := diff (!ex) ns_ex in - let trans_ex = cur_trans_exports k in - let () = trans_ex := union (!trans_ex) ns_ex in - () - in - List.iter update_exports all_exported_id_kinds - | _ -> () (* current module was not prepared? should not happen *) - in - env - | None -> - (* module to be included was not prepared, so forbid the 'include'. It may be the case for modules such as FStar.Compiler.Effect, etc. *) - raise_error ns Errors.Fatal_IncludeModuleNotPrepared - (BU.format1 "include: Module %s was not prepared" (string_of_lid ns)) - end - | _ -> - raise_error ns Errors.Fatal_ModuleNotFound - (BU.format1 "include: Module %s cannot be found" (string_of_lid ns)) - -let push_namespace = elab_restriction push_namespace' -let push_include = elab_restriction push_include' - -let push_module_abbrev env x l = - (* both namespace resolution and module abbrevs disabled: - in 'module A = B', B must be fully qualified *) - if module_is_defined env l - then begin - env.ds_hooks.ds_push_module_abbrev_hook env x l; - push_scope_mod env (Module_abbrev (x,l)) - end else raise_error l Errors.Fatal_ModuleNotFound - (BU.format1 "Module %s cannot be found" (Ident.string_of_lid l)) - -let check_admits env m = - let admitted_sig_lids = - env.sigaccum |> List.fold_left (fun lids se -> - match se.sigel with - | Sig_declare_typ {lid=l; us=u; t} when not (se.sigquals |> List.contains Assumption) -> - // l is already fully qualified, so no name resolution - begin match BU.smap_try_find (sigmap env) (string_of_lid l) with - | Some ({sigel=Sig_let _}, _) - | Some ({sigel=Sig_inductive_typ _}, _) - | Some ({sigel=Sig_splice _}, _) -> - (* ok *) - lids - | _ -> - if not (Options.interactive ()) then begin - let open FStar.Pprint in - let open FStar.Class.PP in - FStar.Errors.log_issue l Errors.Error_AdmitWithoutDefinition [ - doc_of_string (show l) ^/^ text "is declared but no definition was found"; - text "Add an 'assume' if this is intentional" - ] - end; - let quals = Assumption :: se.sigquals in - BU.smap_add (sigmap env) (string_of_lid l) ({ se with sigquals = quals }, false); - l::lids - end - | _ -> lids) [] - in - m - -let finish env modul = - modul.declarations |> List.iter (fun se -> - let quals = se.sigquals in - match se.sigel with - | Sig_bundle {ses} -> - if List.contains Private quals - then ses |> List.iter (fun se -> match se.sigel with - | Sig_datacon {lid} -> - BU.smap_remove (sigmap env) (string_of_lid lid) - | Sig_inductive_typ {lid;us=univ_names;params=binders;t=typ} -> - BU.smap_remove (sigmap env) (string_of_lid lid); - if not (List.contains Private quals) - then //it's only abstract; add it back to the environment as an abstract type - let sigel = Sig_declare_typ {lid;us=univ_names;t=S.mk (Tm_arrow {bs=binders; comp=S.mk_Total typ}) (Ident.range_of_lid lid)} in - let se = {se with sigel=sigel; sigquals=Assumption::quals} in - BU.smap_add (sigmap env) (string_of_lid lid) (se, false) - | _ -> ()) - - | Sig_declare_typ {lid} -> - if List.contains Private quals - then BU.smap_remove (sigmap env) (string_of_lid lid) - - | Sig_let {lbs=(_,lbs)} -> - if List.contains Private quals - then begin - lbs |> List.iter (fun lb -> BU.smap_remove (sigmap env) (string_of_lid (right lb.lbname).fv_name.v)) - end - - | _ -> ()); - (* update the sets of transitively exported names of this module by - adding the unshadowed names defined only in the current module. *) - let curmod = string_of_lid (current_module env) in - let () = match (get_exported_id_set env curmod, get_trans_exported_id_set env curmod) with - | (Some cur_ex, Some cur_trans_ex) -> - let update_exports eikind = - let cur_ex_set = ! (cur_ex eikind) in - let cur_trans_ex_set_ref = cur_trans_ex eikind in - cur_trans_ex_set_ref := union cur_ex_set (!cur_trans_ex_set_ref) - in - List.iter update_exports all_exported_id_kinds - | _ -> () - in - (* remove abstract/private records *) - let () = filter_record_cache () in - {env with - curmodule=None; - modules=(modul.name, modul)::env.modules; - scope_mods = []; - sigaccum=[]; - } - -let stack: ref (list env) = BU.mk_ref [] -let push env = BU.atomically (fun () -> - push_record_cache(); - stack := env::!stack; - {env with exported_ids = BU.smap_copy env.exported_ids; - trans_exported_ids = BU.smap_copy env.trans_exported_ids; - includes = BU.smap_copy env.includes; - sigmap = BU.smap_copy env.sigmap }) - -let pop () = BU.atomically (fun () -> - match !stack with - | env::tl -> - pop_record_cache(); - stack := tl; - env - | _ -> failwith "Impossible: Too many pops") - -let snapshot env = Common.snapshot push stack env -let rollback depth = Common.rollback pop stack depth - -let export_interface (m:lident) env = -// printfn "Exporting interface %s" (string_of_lid m); - let sigelt_in_m se = - match U.lids_of_sigelt se with - | l::_ -> (nsstr l)=(string_of_lid m) - | _ -> false in - let sm = sigmap env in - let env = pop () in // FIXME PUSH POP - let keys = BU.smap_keys sm in - let sm' = sigmap env in - keys |> List.iter (fun k -> - match BU.smap_try_find sm' k with - | Some (se, true) when sigelt_in_m se -> - BU.smap_remove sm' k; -// printfn "Exporting %s" k; - let se = match se.sigel with - | Sig_declare_typ {lid=l; us=u; t} -> - { se with sigquals = Assumption::se.sigquals } - | _ -> se in - BU.smap_add sm' k (se, false) - | _ -> ()); - env - -let finish_module_or_interface env modul = - let modul = if not modul.is_interface then check_admits env modul else modul in - finish env modul, modul - -type exported_ids = { - exported_id_terms : string_set; - exported_id_fields: string_set; -} -let as_exported_ids (e:exported_id_set) = - let terms = (!(e Exported_id_term_type)) in - let fields = (!(e Exported_id_field)) in - {exported_id_terms=terms; - exported_id_fields=fields} - -let as_exported_id_set (e:option exported_ids) = - match e with - | None -> exported_id_set_new () - | Some e -> - let terms = - BU.mk_ref (e.exported_id_terms) in - let fields = - BU.mk_ref (e.exported_id_fields) in - function - | Exported_id_term_type -> terms - | Exported_id_field -> fields - - -type module_inclusion_info = { - mii_exported_ids:option exported_ids; - mii_trans_exported_ids:option exported_ids; - mii_includes:option (list (lident & restriction)) -} - -let default_mii = { - mii_exported_ids=None; - mii_trans_exported_ids=None; - mii_includes=None -} - -let as_includes = function - | None -> BU.mk_ref [] - | Some l -> BU.mk_ref l - -let inclusion_info env (l:lident) = - let mname = FStar.Ident.string_of_lid l in - let as_ids_opt m = - BU.map_opt (BU.smap_try_find m mname) as_exported_ids - in - { - mii_exported_ids = as_ids_opt env.exported_ids; - mii_trans_exported_ids = as_ids_opt env.trans_exported_ids; - mii_includes = BU.map_opt (BU.smap_try_find env.includes mname) (fun r -> !r) - } - -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 = FStar.Parser.Dep.hard_coded_dependencies filename in - let auto_open = - let convert_kind = function - | FStar.Parser.Dep.Open_namespace -> Open_namespace - | FStar.Parser.Dep.Open_module -> Open_module - in - List.map (fun (lid, kind) -> (lid, convert_kind kind, Unrestricted)) auto_open - in - let namespace_of_module = if List.length (ns_of_lid mname) > 0 then [ (lid_of_ids (ns_of_lid mname), Open_namespace, Unrestricted) ] else [] in - (* [scope_mods] is a stack, so reverse the order *) - let auto_open = namespace_of_module @ List.rev auto_open in - - (* Create new empty set of exported identifiers for the current module, for 'include' *) - let () = BU.smap_add env.exported_ids (string_of_lid mname) (as_exported_id_set mii.mii_exported_ids) in - (* Create new empty set of transitively exported identifiers for the current module, for 'include' *) - let () = BU.smap_add env.trans_exported_ids (string_of_lid mname) (as_exported_id_set mii.mii_trans_exported_ids) in - (* Create new empty list of includes for the current module *) - let () = BU.smap_add env.includes (string_of_lid mname) (as_includes mii.mii_includes) in - let env' = { - env with curmodule=Some mname; - sigmap=env.sigmap; - scope_mods = List.map (fun x -> Open_module_or_namespace x) auto_open; - iface=intf; - admitted_iface=admitted } in - List.iter (fun op -> env.ds_hooks.ds_push_open_hook env' op) (List.rev auto_open); - env' - in - - match env.modules |> BU.find_opt (fun (l, _) -> lid_equals l mname) with - | None -> - prep env, false - | Some (_, m) -> - if not (Options.interactive ()) && (not m.is_interface || intf) - then raise_error mname Errors.Fatal_DuplicateModuleOrInterface - (BU.format1 "Duplicate module or interface name: %s" (string_of_lid mname)); - //we have an interface for this module already; if we're not interactive then do not export any symbols from this module - prep (push env), true //push a context so that we can pop it when we're done // FIXME PUSH POP - -let enter_monad_scope env mname = - match env.curmonad with - | Some mname' -> - raise_error mname Errors.Fatal_MonadAlreadyDefined - ("Trying to define monad " ^ (show mname) ^ ", but already in monad scope " ^ (show mname')) - | None -> {env with curmonad = Some mname} - -let fail_or env lookup lid = - match lookup lid with - | Some r -> r - | None -> - (* try to report a nice error *) - let opened_modules = List.map (fun (lid, _) -> string_of_lid lid) env.modules in - let msg = Errors.mkmsg (BU.format1 "Identifier not found: [%s]" (string_of_lid lid)) in - let msg = - if List.length (ns_of_lid lid) = 0 - then - msg - else - let modul = set_lid_range (lid_of_ids (ns_of_lid lid)) (range_of_lid lid) in - let open FStar.Pprint in - let subdoc d = - nest 2 (hardline ^^ align d) - in - match resolve_module_name env modul true with - | None -> - let opened_modules = String.concat ", " opened_modules |> Errors.text in - msg @ [Errors.text (BU.format1 "Could not resolve module name %s" - (string_of_lid modul))] - | Some modul' when (not (List.existsb (fun m -> m = (string_of_lid modul')) opened_modules)) -> - let opened_modules = String.concat ", " opened_modules |> Errors.text in - msg @ [Errors.text (BU.format2 "Module %s resolved into %s, which does not belong to the list of modules in scope, namely:" - (string_of_lid modul) - (string_of_lid modul')) ^^ subdoc opened_modules] - | Some modul' -> - msg @ [Errors.text (BU.format3 - "Module %s resolved into %s, definition %s not found" - (string_of_lid modul) - (string_of_lid modul') - (string_of_id (ident_of_lid lid)))] - in - raise_error lid Errors.Fatal_IdentifierNotFound msg - -let fail_or2 lookup id = match lookup id with - | None -> raise_error id Errors.Fatal_IdentifierNotFound ("Identifier not found [" ^(string_of_id id)^"]") - | Some r -> r - -let resolve_name (e:env) (name:lident) - : option (either bv fv) - = match try_lookup_name false false e name with - | None -> None - | Some (Term_name (e, attrs)) -> ( - match (Subst.compress e).n with - | Tm_name n -> Some (Inl n) - | Tm_fvar fv -> Some (Inr fv) - | _ -> None - ) - | Some (Eff_name(se, l)) -> - Some (Inr (S.lid_and_dd_as_fv l None)) diff --git a/src/syntax/FStar.Syntax.DsEnv.fsti b/src/syntax/FStar.Syntax.DsEnv.fsti deleted file mode 100644 index 08d7cc57a7f..00000000000 --- a/src/syntax/FStar.Syntax.DsEnv.fsti +++ /dev/null @@ -1,145 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Syntax.DsEnv -open FStar.Compiler.Effect - -open FStar -open FStar.Compiler -open FStar.Compiler.Util -open FStar.Compiler.Effect -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.Syntax.Util -open FStar.Parser -open FStar.Ident -module BU = FStar.Compiler.Util -module S = FStar.Syntax.Syntax -module U = FStar.Syntax.Util - -val ugly_sigelt_to_string_hook : ref (sigelt -> string) - -let open_module_or_namespace = S.open_module_or_namespace -type used_marker = ref bool - (* opens the whole namespace *) -type record_or_dc = { - typename: lident; (* the namespace part applies to the constructor and fields as well *) - constrname: ident; - parms: binders; - fields: list (ident & typ); - is_private: bool; - is_record:bool -} - -val env : Type0 -val dsenv_hooks : Type0 - -val mk_dsenv_hooks - (open_hook:env -> open_module_or_namespace -> unit) - (include_hook:env -> lident -> unit) - (module_abbrev_hook:env -> ident -> lident -> unit) - : dsenv_hooks - -type withenv 'a = env -> 'a & env - -type foundname = - | Term_name of typ & list attribute - | Eff_name of sigelt & lident - -val fail_or: env -> (lident -> option 'a) -> lident -> 'a -val fail_or2: (ident -> option 'a) -> ident -> 'a - -val opens_and_abbrevs :env -> list (either open_module_or_namespace module_abbrev) -val dep_graph: env -> FStar.Parser.Dep.deps -val set_dep_graph: env -> FStar.Parser.Dep.deps -> env -val ds_hooks : env -> dsenv_hooks -val set_ds_hooks: env -> dsenv_hooks -> env -val syntax_only: env -> bool -val set_syntax_only: env -> bool -> env -val qualify: env -> ident -> lident -val set_iface: env -> bool -> env -val iface: env -> bool -val set_admitted_iface: env -> bool -> env -val admitted_iface: env -> bool -val expect_typ: env -> bool -val set_expect_typ: env -> bool -> env -val empty_env: FStar.Parser.Dep.deps -> env -val current_module: env -> lident -val set_current_module: env -> lident -> env -val open_modules: env -> list (lident & modul) -val open_modules_and_namespaces: env -> list lident -val module_abbrevs: env -> list (ident & lident) -val iface_decls : env -> lident -> option (list Parser.AST.decl) -val set_iface_decls: env -> lident -> list Parser.AST.decl -> env -val try_lookup_id: env -> ident -> option term -val shorten_module_path: env -> list ident -> bool -> (list ident & list ident) -val shorten_lid: env -> lid -> lid -val try_lookup_lid: env -> lident -> option term -val try_lookup_lid_with_attributes: env -> lident -> option (term & list attribute) -val try_lookup_lid_with_attributes_no_resolve: env -> lident -> option (term & list attribute) -val try_lookup_lid_no_resolve: env -> lident -> option term -val try_lookup_effect_name: env -> lident -> option lident -val try_lookup_effect_name_and_attributes: env -> lident -> option (lident & list cflag) -val try_lookup_effect_defn: env -> lident -> option eff_decl -(* [try_lookup_root_effect_name] is the same as -[try_lookup_effect_name], but also traverses effect abbrevs. TODO: -once indexed effects are in, also track how indices and other -arguments are instantiated. *) -val try_lookup_root_effect_name: env -> lident -> option lident -val try_lookup_datacon: env -> lident -> option fv -val try_lookup_record_by_field_name: env -> lident -> option record_or_dc -val try_lookup_record_type: env -> lident -> option record_or_dc -val belongs_to_record: env -> lident -> record_or_dc -> bool -val try_lookup_dc_by_field_name: env -> lident -> option (lident & bool) -val try_lookup_definition: env -> lident -> option term -val is_effect_name: env -> lident -> bool -val find_all_datacons: env -> lident -> option (list lident) -val lookup_letbinding_quals_and_attrs: env -> lident -> list qualifier & list attribute -val resolve_module_name: env:env -> lid:lident -> honor_ns:bool -> option lident -val resolve_to_fully_qualified_name : env:env -> l:lident -> option lident -val fv_qual_of_se : sigelt -> option fv_qual - -val push_bv': env -> ident -> env & bv & used_marker -val push_bv: env -> ident -> env & bv -val push_top_level_rec_binding: env -> ident -> env & ref bool -val push_sigelt: env -> sigelt -> env -val push_namespace: env -> lident -> restriction -> env -val push_include: env -> lident -> restriction -> env -val push_module_abbrev : env -> ident -> lident -> env -val resolve_name: env -> lident -> option (either bv fv) - -(* Won't fail on duplicates, use with caution *) -val push_sigelt_force : env -> sigelt -> env - -val pop: unit -> env -val push: env -> env -val rollback: option int -> env -val snapshot: env -> (int & env) - -val finish_module_or_interface: env -> modul -> (env & modul) -val enter_monad_scope: env -> ident -> env -val export_interface: lident -> env -> env - -val transitive_exported_ids: env -> lident -> list string -val module_inclusion_info : Type0 -val default_mii : module_inclusion_info -val inclusion_info: env -> lident -> module_inclusion_info -val prepare_module_or_interface: bool -> bool -> env -> lident -> module_inclusion_info -> env & bool //pop the context when done desugaring - -(* private *) val try_lookup_lid': bool -> bool -> env -> lident -> option (term & list attribute) -(* private *) val unique: bool -> bool -> env -> lident -> bool -(* private *) val check_admits: env -> modul -> modul -(* private *) val finish: env -> modul -> env diff --git a/src/syntax/FStar.Syntax.Embeddings.AppEmb.fst b/src/syntax/FStar.Syntax.Embeddings.AppEmb.fst deleted file mode 100644 index 172c605c0ab..00000000000 --- a/src/syntax/FStar.Syntax.Embeddings.AppEmb.fst +++ /dev/null @@ -1,51 +0,0 @@ -module FStar.Syntax.Embeddings.AppEmb - -open FStar.Syntax.Syntax -open FStar.Syntax.Embeddings.Base - -type appemb 'a = - args -> option ('a & args) - -let one (e : embedding 'a) : appemb 'a = - fun args -> - match args with - | (t,_)::xs -> - match try_unembed t id_norm_cb with - | None -> None - | Some v -> Some (v, xs) - -let (let?) o f = match o with | None -> None | Some v -> f v - -val (<*>) : appemb ('a -> 'b) -> appemb 'a -> appemb 'b -let (<*>) u1 u2 = - fun args -> - let? f, args' = u1 args in - let? v, args'' = u2 args' in - Some (f v, args'') - -val (<**>) : appemb ('a -> 'b) -> embedding 'a -> appemb 'b -let (<**>) u1 u2 = u1 <*> one u2 - -let pure (x : 'a) : appemb 'a = - fun args -> Some (x, args) - -val (<$>) : ('a -> 'b) -> appemb 'a -> appemb 'b -let (<$>) u1 u2 = pure u1 <*> u2 - -val (<$$>) : ('a -> 'b) -> embedding 'a -> appemb 'b -let (<$$>) u1 u2 = pure u1 <*> one u2 - -val run : args -> appemb 'a -> option 'a -let run args u = - match u args with - | Some (r, []) -> Some r - | _ -> None - -val wrap : (term -> option 'a) -> appemb 'a -let wrap f = - fun args -> - match args with - | (t,_)::xs -> - match f t with - | None -> None - | Some v -> Some (v, xs) diff --git a/src/syntax/FStar.Syntax.Embeddings.Base.fst b/src/syntax/FStar.Syntax.Embeddings.Base.fst deleted file mode 100644 index 64389dc798c..00000000000 --- a/src/syntax/FStar.Syntax.Embeddings.Base.fst +++ /dev/null @@ -1,301 +0,0 @@ -(* - Copyright 2008-2014 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Syntax.Embeddings.Base - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.Range -open FStar.Pervasives -open FStar.Syntax.Syntax -open FStar.Class.Show -open FStar.Class.PP -open FStar.Class.Deq - -module BU = FStar.Compiler.Util -module Err = FStar.Errors -module Ident = FStar.Ident -module PC = FStar.Parser.Const -module Print = FStar.Syntax.Print -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module U = FStar.Syntax.Util - -(********************************************************************* - - A NOTE ON FUNCTIONS AND SHADOW TERMS - -Shadow terms exist to acomodate strong reduction of plugins. - -Suppose we have this function, marked as a plugin to accelerate it -during typechecking: - - [@@plugin] - let sort (l : list int) : list int = ... - -(Plugins are usually tactics, but do not have to be. This discussion -is actually not so relevant for tactics as they do not run in open -contexts.) - -Compilation will generate a version that works on _real_ concrete -lists of integers. To call it on a term, as we have to do during -typechecking, we need to wrap it with embeddings: - - sort_term t = embed_intlist (sort (unembed_intlist t)) - -This turns the term `t` into an actual `list int`, calls the native -sort function, and then reconstructs a term for the resulting list. - -After loading the compiled version of that file, `sort_term` is now -loaded as a primitive step in the normalizer (under the name `sort`, of -course), and will be called everytime we find this symbol applied to an -argument. While its argument must have already been reduced (CBV), there -is no guarantee that it is an actual _value_ as we may be in an open -context, e.g. we may be typechecking this formula: - - forall l. sum (sort l) == sum l - -or it can be applied to some abstract lid even in a closed -context, or to a Tm_let that we are not currently reducing (e.g. DIV), -etc. So, we may fail (and often do) to unembed the argument term -to obtain a concrete list, hence sort_term is closer to: - - sort_term t = match unembed_intlist t with - | None -> None - | Some l -> embed_intlist (sort l) - -But, instead of stopping reduction with the None, we can instead -use the definition of sort itself, and call the normalizer with -the unfolded definition applied to the symbolic argument. Shadow -terms are term representations of whatever the embedded thing is, -which can be defaulted to when the embedding does not work. - -(TODO: what does this do for recursive functions? sounds - like it would not unfold? Actually, it seems broken: - - [@@plugin] - let rec mylen (l : list int) : int = - match l with - | [] -> 0 - | x::xs -> 1 + mylen xs - - let test (a b c : int) = - assert (mylen [a;b;c] == mylen [c;b;a]) by begin - dump "1"; - compute (); - dump "2"; - trefl (); - () - end - -this file works when mylen is not loaded as a plugin, but fails -otherwise since reduction is blocked.) - - -*********************************************************************) - -let id_norm_cb : norm_cb = function - | Inr x -> x - | Inl l -> S.fv_to_tm (S.lid_as_fv l None) -exception Embedding_failure -exception Unembedding_failure - -let map_shadow (s:shadow_term) (f:term -> term) : shadow_term = - BU.map_opt s (Thunk.map f) -let force_shadow (s:shadow_term) = BU.map_opt s Thunk.force - -class embedding (a:Type0) = { - em : a -> embed_t; - un : term -> unembed_t a; - print : printer a; - - (* These are thunked so we can create Tot instances. *) - typ : unit -> typ; - e_typ : unit -> emb_typ; -} - -let emb_typ_of a #e () = e.e_typ () - -let unknown_printer (typ : term) (_ : 'a) : string = - BU.format1 "unknown %s" (show typ) - -let term_as_fv t = - match (SS.compress t).n with - | Tm_fvar fv -> fv - | _ -> failwith (BU.format1 "Embeddings not defined for type %s" (show t)) - -let mk_emb em un fv : Tot _ = - { - em = em; - un = un; - print = (fun x -> let typ = S.fv_to_tm fv in unknown_printer typ x); - typ = (fun () -> S.fv_to_tm fv); - e_typ= (fun () -> ET_app (S.lid_of_fv fv |> Ident.string_of_lid, [])); - } - -let mk_emb_full em un typ printe emb_typ : Tot _ = { - em = em ; - un = un ; - typ = typ; - print = printe; - e_typ = emb_typ; -} -// -// -// AR/NS: 04/22/2022: -// In the case of metaprograms, we reduce divergent terms in -// the normalizer, therefore, the final result that we get -// may be wrapped in a Meta_monadic node (e.g. lift, app, etc.) -// Before unembedding the result of such a computation, -// we strip those meta nodes -// In case the term inside is not a result, unembedding would -// anyway fail -// And we strip down only DIV -// Can we get any other effect? Not today, since from the client -// code, we enforce terms to be normalized to be PURE -// - -let rec unmeta_div_results t = - let open FStar.Ident in - match (SS.compress t).n with - | Tm_meta {tm=t'; meta=Meta_monadic_lift (src, dst, _)} -> - if lid_equals src PC.effect_PURE_lid && - lid_equals dst PC.effect_DIV_lid - then unmeta_div_results t' - else t - - | Tm_meta {tm=t'; meta=Meta_monadic (m, _)} -> - if lid_equals m PC.effect_DIV_lid - then unmeta_div_results t' - else t - - | Tm_meta {tm=t'} -> unmeta_div_results t' - - | Tm_ascribed {tm=t'} -> unmeta_div_results t' - - | _ -> t - -let type_of (e:embedding 'a) = e.typ () -let printer_of (e:embedding 'a) = e.print -let set_type ty (e:embedding 'a) = { e with typ = (fun () -> ty) } - -let embed {| e:embedding 'a |} = e.em -let try_unembed {| e:embedding 'a |} t n = - (* Unembed always receives a term without the meta_monadics above, - and also already compressed. *) - let t = unmeta_div_results t in - e.un (SS.compress t) n - -let unembed #a {| e:embedding a |} t n = - let r = try_unembed t n in - let open FStar.Errors.Msg in - let open FStar.Pprint in - if None? r then - Err.log_issue t Err.Warning_NotEmbedded [ - text "Unembedding failed for type" ^/^ pp (type_of e); - text "emb_typ = " ^/^ doc_of_string (show (emb_typ_of a ())); - text "Term =" ^/^ pp t; - ]; - r - - -let embed_as (ea:embedding 'a) (ab : 'a -> 'b) (ba : 'b -> 'a) (o:option S.typ) : Tot (embedding 'b) = - mk_emb_full (fun (x:'b) -> embed (ba x)) - (fun (t:term) cb -> BU.map_opt (try_unembed t cb) ab) - (fun () -> match o with | Some t -> t | _ -> type_of ea) - (fun (x:'b) -> BU.format1 "(embed_as>> %s)\n" (ea.print (ba x))) - ea.e_typ - -(* A simple lazy embedding, without cancellations nor an expressive type. *) -let e_lazy #a (k:lazy_kind) (ty : S.typ) : embedding a = - let ee (x:a) rng _topt _norm : term = U.mk_lazy x ty k (Some rng) in - let uu (t:term) _norm : option a = - let t0 = t in - match (SS.compress t).n with - | Tm_lazy {blob=b; lkind=lkind} when lkind =? k -> Some (Dyn.undyn b) - | Tm_lazy {blob=b; lkind=lkind} -> - (* This is very likely a bug, warn! *) - Err.log_issue t0 Err.Warning_NotEmbedded - (BU.format3 "Warning, lazy unembedding failed, tag mismatch.\n\t\ - Expected %s, got %s\n\t\ - t = %s." - (show k) (show lkind) (show t0)); - None - | _ -> - None - in - mk_emb ee uu (term_as_fv ty) - -let lazy_embed (pa:printer 'a) (et:emb_typ) rng (ta:term) (x:'a) (f:unit -> term) = - if !Options.debug_embedding - then BU.print3 "Embedding a %s\n\temb_typ=%s\n\tvalue is %s\n" - (show ta) - (show et) - (pa x); - if !Options.eager_embedding - then f() - else let thunk = Thunk.mk f in - U.mk_lazy x S.tun (Lazy_embedding (et, thunk)) (Some rng) - -let lazy_unembed (pa:printer 'a) (et:emb_typ) (x:term) (ta:term) (f:term -> option 'a) : option 'a = - let x = SS.compress x in - match x.n with - | Tm_lazy {blob=b; lkind=Lazy_embedding (et', t)} -> - if et <> et' - || !Options.eager_embedding - then let res = f (Thunk.force t) in - let _ = if !Options.debug_embedding - then BU.print3 "Unembed cancellation failed\n\t%s <> %s\nvalue is %s\n" - (show et) - (show et') - (match res with None -> "None" | Some x -> "Some " ^ (pa x)) - in - res - else let a = Dyn.undyn b in - let _ = if !Options.debug_embedding - then BU.print2 "Unembed cancelled for %s\n\tvalue is %s\n" - (show et) (pa a) - in - Some a - | _ -> - let aopt = f x in - let _ = if !Options.debug_embedding - then BU.print3 "Unembedding:\n\temb_typ=%s\n\tterm is %s\n\tvalue is %s\n" - (show et) (show x) - (match aopt with None -> "None" | Some a -> "Some " ^ pa a) in - aopt - -let (let?) o f = BU.bind_opt o f - -let mk_extracted_embedding (name: string) (u: string & list term -> option 'a) (e: 'a -> term) : embedding 'a = - let uu (t:term) _norm : option 'a = - let hd, args = U.head_and_args t in - let? hd_lid = - match (SS.compress (U.un_uinst hd)).n with - | Tm_fvar fv -> Some fv.fv_name.v - | _ -> None - in - u (Ident.string_of_lid hd_lid, List.map fst args) - in - let ee (x:'a) rng _topt _norm : term = e x in - mk_emb ee uu (S.lid_as_fv (Ident.lid_of_str name) None) - -let extracted_embed (e: embedding 'a) (x: 'a) : term = - embed x Range.dummyRange None id_norm_cb - -let extracted_unembed (e: embedding 'a) (t: term) : option 'a = - try_unembed t id_norm_cb diff --git a/src/syntax/FStar.Syntax.Embeddings.Base.fsti b/src/syntax/FStar.Syntax.Embeddings.Base.fsti deleted file mode 100644 index aa0afa6c44d..00000000000 --- a/src/syntax/FStar.Syntax.Embeddings.Base.fsti +++ /dev/null @@ -1,115 +0,0 @@ -(* - Copyright 2008-2014 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Syntax.Embeddings.Base - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Pervasives -open FStar.Syntax.Syntax -module S = FStar.Syntax.Syntax - -module Range = FStar.Compiler.Range - -type norm_cb = either Ident.lident term -> term // a callback to the normalizer - -type shadow_term = option (Thunk.t term) - -type embed_t = Range.range -> shadow_term -> norm_cb -> term - -type unembed_t 'a = norm_cb -> option 'a // bool = whether we should warn on a failure - -type raw_embedder 'a = 'a -> embed_t -type raw_unembedder 'a = term -> unembed_t 'a -type printer 'a = 'a -> string - -(* - * Unmbedding functions return an option because they might fail - * to interpret the given term as valid data. The `try_` version will - * simply return None in that case, but the unsafe one will also raise a - * warning, and should be used only where we really expect to always be - * able to unembed. - *) - -val id_norm_cb : norm_cb -exception Embedding_failure -exception Unembedding_failure - -[@@Tactics.Typeclasses.tcclass] -val embedding (a:Type0) : Type0 - -// FIXME: unit to trigger instantiation -val emb_typ_of: a:Type -> {|embedding a|} -> unit -> emb_typ - -val term_as_fv: term -> fv //partial! -val mk_emb : raw_embedder 'a -> raw_unembedder 'a -> fv -> embedding 'a -val mk_emb_full: raw_embedder 'a - -> raw_unembedder 'a - -> (unit -> S.typ) - -> ('a -> string) - -> (unit -> emb_typ) - -> Tot (embedding 'a) - - -(* - * embed: turning a value into a term (compiler internals -> userland) - * unembed: interpreting a term as a value, which can fail (userland -> compiler internals) - * - * Unmbedding functions return an option because they might fail - * to interpret the given term as valid data. The `try_` version will - * simply return None in that case, but the unsafe one will also raise a - * warning, and should be used only where we really expect to always be - * able to unembed. - *) -val embed : {| embedding 'a |} -> 'a -> embed_t -val try_unembed : {| embedding 'a |} -> term -> norm_cb -> option 'a -val unembed : {| embedding 'a |} -> term -> norm_cb -> option 'a - -val type_of : embedding 'a -> S.typ -val printer_of : embedding 'a -> printer 'a -val set_type : S.typ -> embedding 'a -> embedding 'a - -val embed_as : embedding 'a -> - ('a -> 'b) -> - ('b -> 'a) -> - option S.typ -> (* optionally change the type *) - Tot (embedding 'b) - -(* Construct a simple lazy embedding as a blob. *) -val e_lazy : lazy_kind -> - ty:term -> - embedding 'a - - -(* used from Syntax.Embeddings *) -val unmeta_div_results : term -> term - -(* Helpers for extracted embeddings of inductive types. -Do not use internally. *) -val mk_extracted_embedding : - string -> (* name *) - (string & list term -> option 'a) -> (* unembedding specialized to an applied fvar *) - ('a -> term) -> (* embedding *) - embedding 'a -val extracted_embed : - embedding 'a -> - 'a -> - term -val extracted_unembed : - embedding 'a -> - term -> - option 'a diff --git a/src/syntax/FStar.Syntax.Embeddings.fst b/src/syntax/FStar.Syntax.Embeddings.fst deleted file mode 100644 index 1525bcc847a..00000000000 --- a/src/syntax/FStar.Syntax.Embeddings.fst +++ /dev/null @@ -1,1311 +0,0 @@ -(* - Copyright 2008-2014 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Syntax.Embeddings - -open FStar -open FStar.Compiler -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Syntax.Syntax -open FStar.Compiler.Range -open FStar.VConfig - -open FStar.Class.Show - -module BU = FStar.Compiler.Util -module C = FStar.Const -module Err = FStar.Errors -module Ident = FStar.Ident -module PC = FStar.Parser.Const -module Print = FStar.Syntax.Print -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module U = FStar.Syntax.Util -module UF = FStar.Syntax.Unionfind -module Z = FStar.BigInt - -open FStar.Syntax.Embeddings.Base -module AE = FStar.Syntax.Embeddings.AppEmb - -friend FStar.Pervasives (* To expose norm_step *) - -(********************************************************************* - - A NOTE ON FUNCTIONS AND SHADOW TERMS - -Shadow terms exist to acomodate strong reduction of plugins. - -Suppose we have this function, marked as a plugin to accelerate it -during typechecking: - - [@@plugin] - let sort (l : list int) : list int = ... - -(Plugins are usually tactics, but do not have to be. This discussion -is actually not so relevant for tactics as they do not run in open -contexts.) - -Compilation will generate a version that works on _real_ concrete -lists of integers. To call it on a term, as we have to do during -typechecking, we need to wrap it with embeddings: - - sort_term t = embed_intlist (sort (unembed_intlist t)) - -This turns the term `t` into an actual `list int`, calls the native -sort function, and then reconstructs a term for the resulting list. - -After loading the compiled version of that file, `sort_term` is now -loaded as a primitive step in the normalizer (under the name `sort`, of -course), and will be called everytime we find this symbol applied to an -argument. While its argument must have already been reduced (CBV), there -is no guarantee that it is an actual _value_ as we may be in an open -context, e.g. we may be typechecking this formula: - - forall l. sum (sort l) == sum l - -or it can be applied to some abstract lid even in a closed -context, or to a Tm_let that we are not currently reducing (e.g. DIV), -etc. So, we may fail (and often do) to unembed the argument term -to obtain a concrete list, hence sort_term is closer to: - - sort_term t = match unembed_intlist t with - | None -> None - | Some l -> embed_intlist (sort l) - -But, instead of stopping reduction with the None, we can instead -use the definition of sort itself, and call the normalizer with -the unfolded definition applied to the symbolic argument. Shadow -terms are term representations of whatever the embedded thing is, -which can be defaulted to when the embedding does not work. - -(TODO: what does this do for recursive functions? sounds - like it would not unfold? Actually, it seems broken: - - [@@plugin] - let rec mylen (l : list int) : int = - match l with - | [] -> 0 - | x::xs -> 1 + mylen xs - - let test (a b c : int) = - assert (mylen [a;b;c] == mylen [c;b;a]) by begin - dump "1"; - compute (); - dump "2"; - trefl (); - () - end - -this file works when mylen is not loaded as a plugin, but fails -otherwise since reduction is blocked.) - - -*********************************************************************) - -let id_norm_cb : norm_cb = function - | Inr x -> x - | Inl l -> S.fv_to_tm (S.lid_as_fv l None) -exception Embedding_failure -exception Unembedding_failure - -let map_shadow (s:shadow_term) (f:term -> term) : shadow_term = - BU.map_opt s (Thunk.map f) -let force_shadow (s:shadow_term) = BU.map_opt s Thunk.force - -type printer 'a = 'a -> string - -let unknown_printer (typ:typ) _ = - BU.format1 "unknown %s" (show typ) - -let term_as_fv t = - match (SS.compress t).n with - | Tm_fvar fv -> fv - | _ -> failwith (BU.format1 "Embeddings not defined for type %s" (show t)) - -let lazy_embed (pa:printer 'a) (et:unit -> emb_typ) rng (ta: unit -> term) (x:'a) (f:unit -> term) = - if !Options.debug_embedding - then BU.print3 "Embedding a %s\n\temb_typ=%s\n\tvalue is %s\n" - (show (ta ())) - (show (et ())) - (pa x); - if !Options.eager_embedding - then f() - else let thunk = Thunk.mk f in - U.mk_lazy x S.tun (Lazy_embedding (et (), thunk)) (Some rng) - -let lazy_unembed (pa:printer 'a) (et: unit -> emb_typ) (x:term) (ta: unit -> term) (f:term -> option 'a) : option 'a = - let et = et () in - let x = unmeta_div_results x in - match x.n with - | Tm_lazy {blob=b; lkind=Lazy_embedding (et', t)} -> - if et <> et' - || !Options.eager_embedding - then let res = f (Thunk.force t) in - let _ = if !Options.debug_embedding - then BU.print3 "Unembed cancellation failed\n\t%s <> %s\nvalue is %s\n" - (show et) - (show et') - (match res with None -> "None" | Some x -> "Some " ^ (pa x)) - in - res - else let a = Dyn.undyn b in - let _ = if !Options.debug_embedding - then BU.print2 "Unembed cancelled for %s\n\tvalue is %s\n" - (show et) - (pa a) - in - Some a - | _ -> - let aopt = f x in - let _ = if !Options.debug_embedding - then BU.print3 "Unembedding:\n\temb_typ=%s\n\tterm is %s\n\tvalue is %s\n" - (show et) - (show x) - (match aopt with None -> "None" | Some a -> "Some " ^ pa a) in - aopt - - -let mk_any_emb typ = - let em = fun t _r _shadow _norm -> - if !Options.debug_embedding then - BU.print1 "Embedding abstract: %s\n" (unknown_printer typ t); - t - in - let un = fun t _n -> - if !Options.debug_embedding then - BU.print1 "Unembedding abstract: %s\n" (unknown_printer typ t); - Some t - in - mk_emb_full - em - un - (fun () -> typ) - (unknown_printer typ) - (fun () -> ET_abstract) - -let e_any = - let em = fun t r _shadow _norm -> { t with pos = r} in - let un = fun t _n -> Some t in - mk_emb_full - em - un - (fun () -> S.t_term) // not correct - show - (fun () -> ET_app (PC.term_lid |> Ident.string_of_lid, [])) - -let e_unit = - let em (u:unit) rng _shadow _norm : term = { U.exp_unit with pos = rng } in - let un (t0:term) _norm : option unit = - let t = U.unascribe t0 in - match t.n with - | S.Tm_constant C.Const_unit -> Some () - | _ -> None - in - mk_emb_full - em - un - (fun () -> S.t_unit) - (fun _ -> "()") - (fun () -> ET_app(PC.unit_lid |> Ident.string_of_lid, [])) - -let e_bool = - let em (b:bool) rng _shadow _norm : term = - let t = if b then U.exp_true_bool else U.exp_false_bool in - { t with pos = rng } - in - let un (t:term) _norm : option bool = - match (SS.compress t).n with - | Tm_constant(FStar.Const.Const_bool b) -> Some b - | _ -> None - in - mk_emb_full - em - un - (fun () -> S.t_bool) - BU.string_of_bool - (fun () -> ET_app(PC.bool_lid |> Ident.string_of_lid, [])) - -let e_char = - let em (c:char) (rng:range) _shadow _norm : term = - let t = U.exp_char c in - { t with pos = rng } - in - let un (t:term) _norm : option char = - match (SS.compress t).n with - | Tm_constant(FStar.Const.Const_char c) -> Some c - | _ -> None - in - mk_emb_full - em - un - (fun () -> S.t_char) - BU.string_of_char - (fun () -> ET_app(PC.char_lid |> Ident.string_of_lid, [])) - -let e_int = - let ty = S.t_int in - let emb_t_int = ET_app(PC.int_lid |> Ident.string_of_lid, []) in - let em (i:Z.t) (rng:range) _shadow _norm : term = - lazy_embed - BigInt.string_of_big_int - (fun () -> emb_t_int) - rng - (fun () -> ty) - i - (fun () -> U.exp_int (Z.string_of_big_int i)) - in - let un (t:term) _norm : option Z.t = - lazy_unembed - BigInt.string_of_big_int - (fun () -> emb_t_int) - t - (fun () -> ty) - (fun t -> - match t.n with - | Tm_constant(FStar.Const.Const_int (s, _)) -> Some (Z.big_int_of_string s) - | _ -> None) - in - mk_emb_full - em - un - (fun () -> ty) - BigInt.string_of_big_int - (fun () -> emb_t_int) - -let e_fsint = embed_as e_int Z.to_int_fs Z.of_int_fs None - -let e_string = - let emb_t_string = ET_app(PC.string_lid |> Ident.string_of_lid, []) in - let em (s:string) (rng:range) _shadow _norm : term = - S.mk (Tm_constant(FStar.Const.Const_string(s, rng))) - rng - in - let un (t:term) _norm : option string = - match (SS.compress t).n with - | Tm_constant(FStar.Const.Const_string(s, _)) -> Some s - | _ -> None - in - mk_emb_full - em - un - (fun () -> S.t_string) - (fun x -> "\"" ^ x ^ "\"") - (fun () -> emb_t_string) - -let e_real = - let open FStar.Compiler.Real in - let ty = S.t_real in - let emb_t_real = ET_app(PC.real_lid |> Ident.string_of_lid, []) in - let em (r:real) (rng:range) _shadow _norm : term = - let Real s = r in - mk (Tm_constant (Const.Const_real s)) rng - in - let un (t:term) _norm : option real = - match (unmeta_div_results t).n with - | Tm_constant (Const.Const_real s) -> Some (Real s) - | _ -> None - in - mk_emb_full - em - un - (fun () -> ty) - (fun _ -> "") - (fun () -> emb_t_real) - -let e_option (ea : embedding 'a) : Tot _ = - let typ () = S.t_option_of (type_of ea) in - let emb_t_option_a () = - ET_app(PC.option_lid |> Ident.string_of_lid, [emb_typ_of 'a ()]) - in - let printer x = FStar.Common.string_of_option (printer_of ea) x in - let em (o:option 'a) (rng:range) shadow norm : term = - lazy_embed - printer - emb_t_option_a - rng - (fun () -> S.t_option_of (type_of ea)) - o - (fun () -> - match o with - | None -> - S.mk_Tm_app (S.mk_Tm_uinst (S.tdataconstr PC.none_lid) [U_zero]) - [S.iarg (type_of ea)] - rng - | Some a -> - let shadow_a = map_shadow shadow (fun t -> - let v = Ident.mk_ident ("v", rng) in - let some_v = U.mk_field_projector_name_from_ident PC.some_lid v in - let some_v_tm = S.fv_to_tm (lid_as_fv some_v None) in - S.mk_Tm_app (S.mk_Tm_uinst some_v_tm [U_zero]) - [S.iarg (type_of ea); S.as_arg t] - rng) - in - S.mk_Tm_app (S.mk_Tm_uinst (S.tdataconstr PC.some_lid) [U_zero]) - [S.iarg (type_of ea); S.as_arg (embed a rng shadow_a norm)] - rng) - in - let un (t:term) norm : option (option 'a) = - lazy_unembed - printer - emb_t_option_a - t - (fun () -> S.t_option_of (type_of ea)) - (fun t -> - let hd, args = U.head_and_args_full t in - match (U.un_uinst hd).n, args with - | Tm_fvar fv, _ when S.fv_eq_lid fv PC.none_lid -> Some None - | Tm_fvar fv, [_; (a, _)] when S.fv_eq_lid fv PC.some_lid -> - BU.bind_opt (try_unembed a norm) (fun a -> Some (Some a)) - | _ -> None) - in - mk_emb_full - em - un - typ - printer - emb_t_option_a - -let e_tuple2 (ea:embedding 'a) (eb:embedding 'b) = - let typ () = S.t_tuple2_of (type_of ea) (type_of eb) in - let emb_t_pair () = - ET_app(PC.lid_tuple2 |> Ident.string_of_lid, [emb_typ_of 'a (); emb_typ_of 'b ()]) - in - let printer (x, y) = - BU.format2 "(%s, %s)" (printer_of ea x) (printer_of eb y) - in - let em (x:('a & 'b)) (rng:range) shadow norm : term = - lazy_embed - printer - emb_t_pair - rng - typ - x - (fun () -> - let proj i ab = - let proj_1 = U.mk_field_projector_name (PC.mk_tuple_data_lid 2 rng) (S.null_bv S.tun) i in - let proj_1_tm = S.fv_to_tm (lid_as_fv proj_1 None) in - S.mk_Tm_app (S.mk_Tm_uinst proj_1_tm [U_zero]) - [S.iarg (type_of ea); - S.iarg (type_of eb); - S.as_arg ab] // ab == shadow - rng - in - let shadow_a = map_shadow shadow (proj 1) in - let shadow_b = map_shadow shadow (proj 2) in - S.mk_Tm_app (S.mk_Tm_uinst (S.tdataconstr PC.lid_Mktuple2) [U_zero;U_zero]) - [S.iarg (type_of ea); - S.iarg (type_of eb); - S.as_arg (embed (fst x) rng shadow_a norm); - S.as_arg (embed (snd x) rng shadow_b norm)] - rng) - in - let un (t:term) norm : option ('a & 'b) = - lazy_unembed - printer - emb_t_pair - t - typ - (fun t -> - let hd, args = U.head_and_args_full t in - match (U.un_uinst hd).n, args with - | Tm_fvar fv, [_; _; (a, _); (b, _)] when S.fv_eq_lid fv PC.lid_Mktuple2 -> - let open FStar.Class.Monad in - let! a = try_unembed a norm in - let! b = try_unembed b norm in - Some (a, b) - | _ -> None) - in - mk_emb_full - em - un - typ - printer - emb_t_pair - -let e_tuple3 (ea:embedding 'a) (eb:embedding 'b) (ec:embedding 'c) = - let typ () = S.t_tuple3_of (type_of ea) (type_of eb) (type_of ec) in - let emb_t_pair () = - ET_app(PC.lid_tuple3 |> Ident.string_of_lid, [emb_typ_of 'a (); emb_typ_of 'b (); emb_typ_of 'c ()]) - in - let printer (x, y, z) = - BU.format3 "(%s, %s, %s)" (printer_of ea x) (printer_of eb y) (printer_of ec z) - in - let em ((x1, x2, x3):('a & 'b & 'c)) (rng:range) shadow norm : term = - lazy_embed - printer - emb_t_pair - rng - typ - (x1, x2, x3) - (fun () -> - let proj i abc = - let proj_i = U.mk_field_projector_name (PC.mk_tuple_data_lid 3 rng) (S.null_bv S.tun) i in - let proj_i_tm = S.fv_to_tm (lid_as_fv proj_i None) in - S.mk_Tm_app (S.mk_Tm_uinst proj_i_tm [U_zero]) - [S.iarg (type_of ea); - S.iarg (type_of eb); - S.iarg (type_of ec); - S.as_arg abc] // abc == shadow - rng - in - let shadow_a = map_shadow shadow (proj 1) in - let shadow_b = map_shadow shadow (proj 2) in - let shadow_c = map_shadow shadow (proj 3) in - S.mk_Tm_app (S.mk_Tm_uinst (S.tdataconstr PC.lid_Mktuple3) [U_zero;U_zero;U_zero]) - [S.iarg (type_of ea); - S.iarg (type_of eb); - S.iarg (type_of ec); - S.as_arg (embed x1 rng shadow_a norm); - S.as_arg (embed x2 rng shadow_b norm); - S.as_arg (embed x3 rng shadow_c norm)] - rng) - in - let un (t:term) norm : option ('a & 'b & 'c) = - lazy_unembed - printer - emb_t_pair - t - typ - (fun t -> - let hd, args = U.head_and_args_full t in - match (U.un_uinst hd).n, args with - | Tm_fvar fv, [_; _; _; (a, _); (b, _); (c, _)] when S.fv_eq_lid fv PC.lid_Mktuple3 -> - let open FStar.Class.Monad in - let! a = try_unembed a norm in - let! b = try_unembed b norm in - let! c = try_unembed c norm in - Some (a, b, c) - | _ -> None) - in - mk_emb_full - em - un - typ - printer - emb_t_pair - -let e_tuple4 (ea:embedding 'a) (eb:embedding 'b) (ec:embedding 'c) (ed:embedding 'd) = - let typ () = S.t_tuple4_of (type_of ea) (type_of eb) (type_of ec) (type_of ed) in - let emb_t_pair () = - ET_app(PC.lid_tuple4 |> Ident.string_of_lid, [emb_typ_of 'a (); emb_typ_of 'b (); emb_typ_of 'c (); emb_typ_of 'd ()]) - in - let printer (x, y, z, w) = - BU.format4 "(%s, %s, %s, %s)" (printer_of ea x) (printer_of eb y) (printer_of ec z) (printer_of ed w) - in - let em (x1, x2, x3, x4) (rng:range) shadow norm : term = - lazy_embed - printer - emb_t_pair - rng - typ - (x1, x2, x3, x4) - (fun () -> - let proj i abcd = - let proj_i = U.mk_field_projector_name (PC.mk_tuple_data_lid 4 rng) (S.null_bv S.tun) i in - let proj_i_tm = S.fv_to_tm (lid_as_fv proj_i None) in - S.mk_Tm_app (S.mk_Tm_uinst proj_i_tm [U_zero]) - [S.iarg (type_of ea); - S.iarg (type_of eb); - S.iarg (type_of ec); - S.iarg (type_of ed); - S.as_arg abcd] // abc == shadow - rng - in - let shadow_a = map_shadow shadow (proj 1) in - let shadow_b = map_shadow shadow (proj 2) in - let shadow_c = map_shadow shadow (proj 3) in - let shadow_d = map_shadow shadow (proj 4) in - S.mk_Tm_app (S.mk_Tm_uinst (S.tdataconstr PC.lid_Mktuple4) [U_zero;U_zero;U_zero;U_zero]) - [S.iarg (type_of ea); - S.iarg (type_of eb); - S.iarg (type_of ec); - S.iarg (type_of ed); - S.as_arg (embed x1 rng shadow_a norm); - S.as_arg (embed x2 rng shadow_b norm); - S.as_arg (embed x3 rng shadow_c norm); - S.as_arg (embed x4 rng shadow_d norm)] - rng) - in - let un (t:term) norm : option ('a & 'b & 'c & 'd) = - lazy_unembed - printer - emb_t_pair - t - typ - (fun t -> - let hd, args = U.head_and_args_full t in - match (U.un_uinst hd).n, args with - | Tm_fvar fv, [_; _; _; _; (a, _); (b, _); (c, _); (d, _)] when S.fv_eq_lid fv PC.lid_Mktuple4 -> - let open FStar.Class.Monad in - let! a = try_unembed a norm in - let! b = try_unembed b norm in - let! c = try_unembed c norm in - let! d = try_unembed d norm in - Some (a, b, c, d) - | _ -> None) - in - mk_emb_full - em - un - typ - printer - emb_t_pair - -let e_tuple5 (ea:embedding 'a) (eb:embedding 'b) (ec:embedding 'c) (ed:embedding 'd) (ee:embedding 'e) = - let typ () = S.t_tuple5_of (type_of ea) (type_of eb) (type_of ec) (type_of ed) (type_of ee) in - let emb_t_pair () = - ET_app(PC.lid_tuple5 |> Ident.string_of_lid, [emb_typ_of 'a (); emb_typ_of 'b (); emb_typ_of 'c (); emb_typ_of 'd (); emb_typ_of 'e ()]) - in - let printer (x, y, z, w, v) = - BU.format5 "(%s, %s, %s, %s, %s)" (printer_of ea x) (printer_of eb y) (printer_of ec z) (printer_of ed w) (printer_of ee v) - in - let em (x1, x2, x3, x4, x5) (rng:range) shadow norm : term = - lazy_embed - printer - emb_t_pair - rng - typ - (x1, x2, x3, x4, x5) - (fun () -> - let proj i abcde = - let proj_i = U.mk_field_projector_name (PC.mk_tuple_data_lid 5 rng) (S.null_bv S.tun) i in - let proj_i_tm = S.fv_to_tm (lid_as_fv proj_i None) in - S.mk_Tm_app (S.mk_Tm_uinst proj_i_tm [U_zero]) - [S.iarg (type_of ea); - S.iarg (type_of eb); - S.iarg (type_of ec); - S.iarg (type_of ed); - S.iarg (type_of ee); - S.as_arg abcde] // abc == shadow - rng - in - let shadow_a = map_shadow shadow (proj 1) in - let shadow_b = map_shadow shadow (proj 2) in - let shadow_c = map_shadow shadow (proj 3) in - let shadow_d = map_shadow shadow (proj 4) in - let shadow_e = map_shadow shadow (proj 5) in - S.mk_Tm_app (S.mk_Tm_uinst (S.tdataconstr PC.lid_Mktuple5) [U_zero;U_zero;U_zero;U_zero;U_zero]) - [S.iarg (type_of ea); - S.iarg (type_of eb); - S.iarg (type_of ec); - S.iarg (type_of ed); - S.iarg (type_of ee); - S.as_arg (embed x1 rng shadow_a norm); - S.as_arg (embed x2 rng shadow_b norm); - S.as_arg (embed x3 rng shadow_c norm); - S.as_arg (embed x4 rng shadow_d norm); - S.as_arg (embed x5 rng shadow_e norm)] - rng) - in - let un (t:term) norm : option ('a & 'b & 'c & 'd & 'e) = - lazy_unembed - printer - emb_t_pair - t - typ - (fun t -> - let hd, args = U.head_and_args_full t in - match (U.un_uinst hd).n, args with - | Tm_fvar fv, [_; _; _; _; _; (a, _); (b, _); (c, _); (d, _); (e, _)] when S.fv_eq_lid fv PC.lid_Mktuple5 -> - let open FStar.Class.Monad in - let! a = try_unembed a norm in - let! b = try_unembed b norm in - let! c = try_unembed c norm in - let! d = try_unembed d norm in - let! e = try_unembed e norm in - Some (a, b, c, d, e) - | _ -> None) - in - mk_emb_full - em - un - typ - printer - emb_t_pair - -let e_either (ea:embedding 'a) (eb:embedding 'b) = - let typ () = S.t_either_of (type_of ea) (type_of eb) in - let emb_t_sum_a_b () = - ET_app(PC.either_lid |> Ident.string_of_lid, [emb_typ_of 'a (); emb_typ_of 'b ()]) - in - let printer s = - match s with - | Inl a -> BU.format1 "Inl %s" (printer_of ea a) - | Inr b -> BU.format1 "Inr %s" (printer_of eb b) - in - let em (s:either 'a 'b) (rng:range) shadow norm : term = - lazy_embed - printer - emb_t_sum_a_b - rng - typ - s - (* Eagerly compute which closure we want, but thunk the actual embedding *) - (match s with - | Inl a -> - (fun () -> - let shadow_a = map_shadow shadow (fun t -> - let v = Ident.mk_ident ("v", rng) in - let some_v = U.mk_field_projector_name_from_ident PC.inl_lid v in - let some_v_tm = S.fv_to_tm (lid_as_fv some_v None) in - S.mk_Tm_app (S.mk_Tm_uinst some_v_tm [U_zero]) - [S.iarg (type_of ea); S.iarg (type_of eb); S.as_arg t] - rng) - in - S.mk_Tm_app (S.mk_Tm_uinst (S.tdataconstr PC.inl_lid) [U_zero;U_zero]) - [S.iarg (type_of ea); - S.iarg (type_of eb); - S.as_arg (embed a rng shadow_a norm)] - rng) - | Inr b -> - (fun () -> - let shadow_b = map_shadow shadow (fun t -> - let v = Ident.mk_ident ("v", rng) in - let some_v = U.mk_field_projector_name_from_ident PC.inr_lid v in - let some_v_tm = S.fv_to_tm (lid_as_fv some_v None) in - S.mk_Tm_app (S.mk_Tm_uinst some_v_tm [U_zero]) - [S.iarg (type_of ea); S.iarg (type_of eb); S.as_arg t] - rng) - in - S.mk_Tm_app (S.mk_Tm_uinst (S.tdataconstr PC.inr_lid) [U_zero;U_zero]) - [S.iarg (type_of ea); - S.iarg (type_of eb); - S.as_arg (embed b rng shadow_b norm)] - rng) - ) - in - let un (t:term) norm : option (either 'a 'b) = - lazy_unembed - printer - emb_t_sum_a_b - t - typ - (fun t -> - let hd, args = U.head_and_args_full t in - match (U.un_uinst hd).n, args with - | Tm_fvar fv, [_; _; (a, _)] when S.fv_eq_lid fv PC.inl_lid -> - BU.bind_opt (try_unembed a norm) (fun a -> - Some (Inl a)) - | Tm_fvar fv, [_; _; (b, _)] when S.fv_eq_lid fv PC.inr_lid -> - BU.bind_opt (try_unembed b norm) (fun b -> - Some (Inr b)) - | _ -> - None) - in - mk_emb_full - em - un - typ - printer - emb_t_sum_a_b - -let e_list (ea:embedding 'a) = - let typ () = S.t_list_of (type_of ea) in - let emb_t_list_a () = - ET_app(PC.list_lid |> Ident.string_of_lid, [emb_typ_of 'a ()]) - in - let printer = - (fun (l:list 'a) -> "[" ^ (List.map (printer_of ea) l |> String.concat "; ") ^ "]") - in - let rec em (l:list 'a) (rng:range) shadow_l norm : term = - lazy_embed - printer - emb_t_list_a - rng - typ - l - (fun () -> - let t = S.iarg (type_of ea) in - match l with - | [] -> - S.mk_Tm_app (S.mk_Tm_uinst (S.tdataconstr PC.nil_lid) [U_zero]) //NS: the universe here is bogus - [t] - rng - | hd::tl -> - let cons = - S.mk_Tm_uinst (S.tdataconstr PC.cons_lid) [U_zero] - in - let proj f cons_tm = - let fid = Ident.mk_ident (f, rng) in - let proj = U.mk_field_projector_name_from_ident PC.cons_lid fid in - let proj_tm = S.fv_to_tm (lid_as_fv proj None) in - S.mk_Tm_app (S.mk_Tm_uinst proj_tm [U_zero]) - [S.iarg (type_of ea); - S.as_arg cons_tm] - rng - in - let shadow_hd = map_shadow shadow_l (proj "hd") in - let shadow_tl = map_shadow shadow_l (proj "tl") in - S.mk_Tm_app cons - [t; - S.as_arg (embed hd rng shadow_hd norm); - S.as_arg (em tl rng shadow_tl norm)] - rng) - in - let rec un (t:term) norm : option (list 'a) = - lazy_unembed - printer - emb_t_list_a - t - typ - (fun t -> - let hd, args = U.head_and_args_full t in - match (U.un_uinst hd).n, args with - | Tm_fvar fv, _ - when S.fv_eq_lid fv PC.nil_lid -> Some [] - - | Tm_fvar fv, [(_, Some ({aqual_implicit=true})); (hd, None); (tl, None)] - | Tm_fvar fv, [(hd, None); (tl, None)] - when S.fv_eq_lid fv PC.cons_lid -> - BU.bind_opt (try_unembed hd norm) (fun hd -> - BU.bind_opt (un tl norm) (fun tl -> - Some (hd :: tl))) - | _ -> - None) - in - mk_emb_full - em - un - typ - printer - emb_t_list_a - -let e_string_list = e_list e_string - -(* the steps as terms *) -let steps_Simpl = tconst PC.steps_simpl -let steps_Weak = tconst PC.steps_weak -let steps_HNF = tconst PC.steps_hnf -let steps_Primops = tconst PC.steps_primops -let steps_Delta = tconst PC.steps_delta -let steps_Zeta = tconst PC.steps_zeta -let steps_ZetaFull = tconst PC.steps_zeta_full -let steps_Iota = tconst PC.steps_iota -let steps_Reify = tconst PC.steps_reify -let steps_NormDebug = tconst PC.steps_norm_debug -let steps_UnfoldOnly = tconst PC.steps_unfoldonly -let steps_UnfoldFully = tconst PC.steps_unfoldonly -let steps_UnfoldAttr = tconst PC.steps_unfoldattr -let steps_UnfoldQual = tconst PC.steps_unfoldqual -let steps_UnfoldNamespace = tconst PC.steps_unfoldnamespace -let steps_Unascribe = tconst PC.steps_unascribe -let steps_NBE = tconst PC.steps_nbe -let steps_Unmeta = tconst PC.steps_unmeta - -let e_norm_step : embedding Pervasives.norm_step = - let typ () = S.t_norm_step in - let emb_t_norm_step () = ET_app (PC.norm_step_lid |> Ident.string_of_lid, []) in - let printer _ = "norm_step" in - let em (n:Pervasives.norm_step) (rng:range) _shadow norm : term = - lazy_embed - printer - emb_t_norm_step - rng - typ - n - (fun () -> - match n with - | Simpl -> - steps_Simpl - | Weak -> - steps_Weak - | HNF -> - steps_HNF - | Primops -> - steps_Primops - | Delta -> - steps_Delta - | Zeta -> - steps_Zeta - | ZetaFull -> - steps_ZetaFull - | Iota -> - steps_Iota - | Unascribe -> - steps_Unascribe - | NBE -> - steps_NBE - | Unmeta -> - steps_Unmeta - | Reify -> - steps_Reify - | NormDebug -> - steps_NormDebug - | UnfoldOnly l -> - S.mk_Tm_app steps_UnfoldOnly [S.as_arg (embed l rng None norm)] - rng - | UnfoldFully l -> - S.mk_Tm_app steps_UnfoldFully [S.as_arg (embed l rng None norm)] - rng - | UnfoldAttr l -> - S.mk_Tm_app steps_UnfoldAttr [S.as_arg (embed l rng None norm)] - rng - | UnfoldQual l -> - S.mk_Tm_app steps_UnfoldQual [S.as_arg (embed l rng None norm)] - rng - | UnfoldNamespace l -> - S.mk_Tm_app steps_UnfoldNamespace [S.as_arg (embed l rng None norm)] - rng - - - ) - in - let un (t:term) norm : option Pervasives.norm_step = - lazy_unembed - printer - emb_t_norm_step - t - typ - (fun t -> - let hd, args = U.head_and_args t in - match (U.un_uinst hd).n, args with - | Tm_fvar fv, [] when S.fv_eq_lid fv PC.steps_simpl -> - Some Simpl - | Tm_fvar fv, [] when S.fv_eq_lid fv PC.steps_weak -> - Some Weak - | Tm_fvar fv, [] when S.fv_eq_lid fv PC.steps_hnf -> - Some HNF - | Tm_fvar fv, [] when S.fv_eq_lid fv PC.steps_primops -> - Some Primops - | Tm_fvar fv, [] when S.fv_eq_lid fv PC.steps_delta -> - Some Delta - | Tm_fvar fv, [] when S.fv_eq_lid fv PC.steps_zeta -> - Some Zeta - | Tm_fvar fv, [] when S.fv_eq_lid fv PC.steps_zeta_full -> - Some ZetaFull - | Tm_fvar fv, [] when S.fv_eq_lid fv PC.steps_iota -> - Some Iota - | Tm_fvar fv, [] when S.fv_eq_lid fv PC.steps_unascribe -> - Some Unascribe - | Tm_fvar fv, [] when S.fv_eq_lid fv PC.steps_nbe -> - Some NBE - | Tm_fvar fv, [] when S.fv_eq_lid fv PC.steps_unmeta -> - Some Unmeta - | Tm_fvar fv, [] when S.fv_eq_lid fv PC.steps_reify -> - Some Reify - | Tm_fvar fv, [] when S.fv_eq_lid fv PC.steps_norm_debug -> - Some NormDebug - | Tm_fvar fv, [(l, _)] when S.fv_eq_lid fv PC.steps_unfoldonly -> - BU.bind_opt (try_unembed l norm) (fun ss -> - Some <| UnfoldOnly ss) - | Tm_fvar fv, [(l, _)] when S.fv_eq_lid fv PC.steps_unfoldfully -> - BU.bind_opt (try_unembed l norm) (fun ss -> - Some <| UnfoldFully ss) - | Tm_fvar fv, [(l, _)] when S.fv_eq_lid fv PC.steps_unfoldattr -> - BU.bind_opt (try_unembed l norm) (fun ss -> - Some <| UnfoldAttr ss) - | Tm_fvar fv, [(l, _)] when S.fv_eq_lid fv PC.steps_unfoldqual -> - BU.bind_opt (try_unembed l norm) (fun ss -> - Some <| UnfoldQual ss) - | Tm_fvar fv, [(l, _)] when S.fv_eq_lid fv PC.steps_unfoldnamespace -> - BU.bind_opt (try_unembed l norm) (fun ss -> - Some <| UnfoldNamespace ss) - | _ -> None) - in - mk_emb_full - em - un - typ - printer - emb_t_norm_step - -let e_vconfig = - let em (vcfg:vconfig) (rng:Range.range) _shadow norm : term = - (* The order is very important here, even if this is a record. *) - S.mk_Tm_app (tdataconstr PC.mkvconfig_lid) // TODO: should this be a record constructor? does it matter? - [S.as_arg (embed vcfg.initial_fuel rng None norm); - S.as_arg (embed vcfg.max_fuel rng None norm); - S.as_arg (embed vcfg.initial_ifuel rng None norm); - S.as_arg (embed vcfg.max_ifuel rng None norm); - S.as_arg (embed vcfg.detail_errors rng None norm); - S.as_arg (embed vcfg.detail_hint_replay rng None norm); - S.as_arg (embed vcfg.no_smt rng None norm); - S.as_arg (embed vcfg.quake_lo rng None norm); - S.as_arg (embed vcfg.quake_hi rng None norm); - S.as_arg (embed vcfg.quake_keep rng None norm); - S.as_arg (embed vcfg.retry rng None norm); - S.as_arg (embed vcfg.smtencoding_elim_box rng None norm); - S.as_arg (embed vcfg.smtencoding_nl_arith_repr rng None norm); - S.as_arg (embed vcfg.smtencoding_l_arith_repr rng None norm); - S.as_arg (embed vcfg.smtencoding_valid_intro rng None norm); - S.as_arg (embed vcfg.smtencoding_valid_elim rng None norm); - S.as_arg (embed vcfg.tcnorm rng None norm); - S.as_arg (embed vcfg.no_plugins rng None norm); - S.as_arg (embed vcfg.no_tactics rng None norm); - S.as_arg (embed vcfg.z3cliopt rng None norm); - S.as_arg (embed vcfg.z3smtopt rng None norm); - S.as_arg (embed vcfg.z3refresh rng None norm); - S.as_arg (embed vcfg.z3rlimit rng None norm); - S.as_arg (embed vcfg.z3rlimit_factor rng None norm); - S.as_arg (embed vcfg.z3seed rng None norm); - S.as_arg (embed vcfg.z3version rng None norm); - S.as_arg (embed vcfg.trivial_pre_for_unannotated_effectful_fns rng None norm); - S.as_arg (embed vcfg.reuse_hint_for rng None norm); - ] - rng - in - let un (t:term) norm : option vconfig = - let hd, args = U.head_and_args t in - match (U.un_uinst hd).n, args with - (* Sigh *) - | Tm_fvar fv, [ - (initial_fuel, _); - (max_fuel, _); - (initial_ifuel, _); - (max_ifuel, _); - (detail_errors, _); - (detail_hint_replay, _); - (no_smt, _); - (quake_lo, _); - (quake_hi, _); - (quake_keep, _); - (retry, _); - (smtencoding_elim_box, _); - (smtencoding_nl_arith_repr, _); - (smtencoding_l_arith_repr, _); - (smtencoding_valid_intro, _); - (smtencoding_valid_elim, _); - (tcnorm, _); - (no_plugins, _); - (no_tactics, _); - (z3cliopt, _); - (z3smtopt, _); - (z3refresh, _); - (z3rlimit, _); - (z3rlimit_factor, _); - (z3seed, _); - (z3version, _); - (trivial_pre_for_unannotated_effectful_fns, _); - (reuse_hint_for, _) - ] when S.fv_eq_lid fv PC.mkvconfig_lid -> - BU.bind_opt (try_unembed initial_fuel norm) (fun initial_fuel -> - BU.bind_opt (try_unembed max_fuel norm) (fun max_fuel -> - BU.bind_opt (try_unembed initial_ifuel norm) (fun initial_ifuel -> - BU.bind_opt (try_unembed max_ifuel norm) (fun max_ifuel -> - BU.bind_opt (try_unembed detail_errors norm) (fun detail_errors -> - BU.bind_opt (try_unembed detail_hint_replay norm) (fun detail_hint_replay -> - BU.bind_opt (try_unembed no_smt norm) (fun no_smt -> - BU.bind_opt (try_unembed quake_lo norm) (fun quake_lo -> - BU.bind_opt (try_unembed quake_hi norm) (fun quake_hi -> - BU.bind_opt (try_unembed quake_keep norm) (fun quake_keep -> - BU.bind_opt (try_unembed retry norm) (fun retry -> - BU.bind_opt (try_unembed smtencoding_elim_box norm) (fun smtencoding_elim_box -> - BU.bind_opt (try_unembed smtencoding_nl_arith_repr norm) (fun smtencoding_nl_arith_repr -> - BU.bind_opt (try_unembed smtencoding_l_arith_repr norm) (fun smtencoding_l_arith_repr -> - BU.bind_opt (try_unembed smtencoding_valid_intro norm) (fun smtencoding_valid_intro -> - BU.bind_opt (try_unembed smtencoding_valid_elim norm) (fun smtencoding_valid_elim -> - BU.bind_opt (try_unembed tcnorm norm) (fun tcnorm -> - BU.bind_opt (try_unembed no_plugins norm) (fun no_plugins -> - BU.bind_opt (try_unembed no_tactics norm) (fun no_tactics -> - BU.bind_opt (try_unembed z3cliopt norm) (fun z3cliopt -> - BU.bind_opt (try_unembed z3smtopt norm) (fun z3smtopt -> - BU.bind_opt (try_unembed z3refresh norm) (fun z3refresh -> - BU.bind_opt (try_unembed z3rlimit norm) (fun z3rlimit -> - BU.bind_opt (try_unembed z3rlimit_factor norm) (fun z3rlimit_factor -> - BU.bind_opt (try_unembed z3seed norm) (fun z3seed -> - BU.bind_opt (try_unembed z3version norm) (fun z3version -> - BU.bind_opt (try_unembed trivial_pre_for_unannotated_effectful_fns norm) (fun trivial_pre_for_unannotated_effectful_fns -> - BU.bind_opt (try_unembed reuse_hint_for norm) (fun reuse_hint_for -> - Some ({ - initial_fuel = initial_fuel; - max_fuel = max_fuel; - initial_ifuel = initial_ifuel; - max_ifuel = max_ifuel; - detail_errors = detail_errors; - detail_hint_replay = detail_hint_replay; - no_smt = no_smt; - quake_lo = quake_lo; - quake_hi = quake_hi; - quake_keep = quake_keep; - retry = retry; - smtencoding_elim_box = smtencoding_elim_box; - smtencoding_nl_arith_repr = smtencoding_nl_arith_repr; - smtencoding_l_arith_repr = smtencoding_l_arith_repr; - smtencoding_valid_intro = smtencoding_valid_intro; - smtencoding_valid_elim = smtencoding_valid_elim; - tcnorm = tcnorm; - no_plugins = no_plugins; - no_tactics = no_tactics; - z3cliopt = z3cliopt; - z3smtopt = z3smtopt; - z3refresh = z3refresh; - z3rlimit = z3rlimit; - z3rlimit_factor = z3rlimit_factor; - z3seed = z3seed; - z3version = z3version; - trivial_pre_for_unannotated_effectful_fns = trivial_pre_for_unannotated_effectful_fns; - reuse_hint_for = reuse_hint_for; - }))))))))))))))))))))))))))))) - | _ -> - None - in - mk_emb_full - em - un - (fun () -> S.t_vconfig) - (fun _ -> "vconfig") - (fun () -> ET_app (PC.vconfig_lid |> Ident.string_of_lid, [])) - -let e_order = - let ord_Lt_lid = Ident.lid_of_path (["FStar"; "Order"; "Lt"]) Range.dummyRange in - let ord_Eq_lid = Ident.lid_of_path (["FStar"; "Order"; "Eq"]) Range.dummyRange in - let ord_Gt_lid = Ident.lid_of_path (["FStar"; "Order"; "Gt"]) Range.dummyRange in - let ord_Lt = tdataconstr ord_Lt_lid in - let ord_Eq = tdataconstr ord_Eq_lid in - let ord_Gt = tdataconstr ord_Gt_lid in - let ord_Lt_fv = lid_as_fv ord_Lt_lid (Some Data_ctor) in - let ord_Eq_fv = lid_as_fv ord_Eq_lid (Some Data_ctor) in - let ord_Gt_fv = lid_as_fv ord_Gt_lid (Some Data_ctor) in - let open FStar.Order in - let embed_order (o:order) rng shadow cb : term = - let r = - match o with - | Lt -> ord_Lt - | Eq -> ord_Eq - | Gt -> ord_Gt - in { r with pos = rng } - in - let unembed_order (t:term) cb : option order = - let t = U.unascribe t in - let hd, args = U.head_and_args t in - match (U.un_uinst hd).n, args with - | Tm_fvar fv, [] when S.fv_eq_lid fv ord_Lt_lid -> Some Lt - | Tm_fvar fv, [] when S.fv_eq_lid fv ord_Eq_lid -> Some Eq - | Tm_fvar fv, [] when S.fv_eq_lid fv ord_Gt_lid -> Some Gt - | _ -> - None - in - mk_emb embed_order unembed_order (lid_as_fv PC.order_lid None) - -let or_else (f: option 'a) (g:unit -> 'a) = - match f with - | Some x -> x - | None -> g () - -let e_arrow (ea:embedding 'a) (eb:embedding 'b) : Tot (embedding ('a -> 'b)) = - let typ () = - S.mk (Tm_arrow {bs=[S.mk_binder (S.null_bv (type_of ea))]; - comp=S.mk_Total (type_of eb)}) - Range.dummyRange - in - let emb_t_arr_a_b () = ET_fun(emb_typ_of 'a (), emb_typ_of 'b ()) in - let printer (f:'a -> 'b) = "" in - let em (f:'a -> 'b) rng shadow_f norm = - // let f_wrapped (x:term) = - // let shadow_app = map_shadow shadow_f (fun f -> - // S.mk_Tm_app f [S.as_arg x] None rng) - // in - // or_else - // (BU.map_opt (unembed ea x true norm) (fun x -> - // embed eb (f x) rng shadow_app norm)) - // (fun () -> - // match force_shadow shadow_app with - // | None -> raise Embedding_failure - // | Some app -> norm (BU.Inr app)) - // in - lazy_embed - printer - emb_t_arr_a_b - rng - typ - f //f_wrapped - (fun () -> - match force_shadow shadow_f with - | None -> raise Embedding_failure //TODO: dodgy - | Some repr_f -> - if !Options.debug_embedding then - BU.print2 "e_arrow forced back to term using shadow %s; repr=%s\n" - (show repr_f) - (BU.stack_dump()); - let res = norm (Inr repr_f) in - if !Options.debug_embedding then - BU.print3 "e_arrow forced back to term using shadow %s; repr=%s\n\t%s\n" - (show repr_f) - (show res) - (BU.stack_dump()); - res) - in - let un (f:term) norm : option ('a -> 'b) = - lazy_unembed - printer - emb_t_arr_a_b - f - typ - (fun f -> - let f_wrapped (a:'a) : 'b = - if !Options.debug_embedding then - BU.print2 "Calling back into normalizer for %s\n%s\n" - (show f) - (BU.stack_dump()); - let a_tm = embed a f.pos None norm in - let b_tm = norm (Inr (S.mk_Tm_app f [S.as_arg a_tm] f.pos)) in - match unembed b_tm norm with - | None -> raise Unembedding_failure - | Some b -> b - in - Some f_wrapped) - in - mk_emb_full - em - un - typ - printer - emb_t_arr_a_b - -let e_sealed (ea : embedding 'a) : Tot (embedding (Sealed.sealed 'a)) = - let typ () = S.t_sealed_of (type_of ea) in - let emb_ty_a () = - ET_app(PC.sealed_lid |> Ident.string_of_lid, [emb_typ_of 'a ()]) - in - let printer x = "(seal " ^ printer_of ea (Sealed.unseal x) ^ ")" in - let em (a:Sealed.sealed 'a) (rng:range) shadow norm : term = - let shadow_a = - (* TODO: this application below is in TAC.. OK? *) - map_shadow shadow (fun t -> - let unseal = U.fvar_const PC.unseal_lid in - S.mk_Tm_app (S.mk_Tm_uinst unseal [U_zero]) - [S.iarg (type_of ea); S.as_arg t] - rng) - in - S.mk_Tm_app (S.mk_Tm_uinst (U.fvar_const PC.seal_lid) [U_zero]) - [S.iarg (type_of ea); S.as_arg (embed (Sealed.unseal a) rng shadow_a norm)] - rng - in - let un (t:term) norm : option (Sealed.sealed 'a) = - let hd, args = U.head_and_args_full t in - match (U.un_uinst hd).n, args with - | Tm_fvar fv, [_; (a, _)] when S.fv_eq_lid fv PC.seal_lid -> - // Just relay it - Class.Monad.fmap Sealed.seal <| try_unembed a norm - | _ -> - None - in - mk_emb_full - em - un - typ - printer - emb_ty_a - -(* - * Embed a range as a FStar.Range.__range - * The user usually manipulates a FStar.Range.range = sealed __range - * For embedding an actual FStar.Range.range, we compose this (automatically - * via typeclass resolution) with e_sealed. - *) -let e___range = - let em (r:range) (rng:range) _shadow _norm : term = - S.mk (Tm_constant (C.Const_range r)) rng - in - let un (t:term) _norm : option range = - match (SS.compress t).n with - | Tm_constant (C.Const_range r) -> Some r - | _ -> None - in - mk_emb_full - em - un - (fun () -> S.t___range) - Range.string_of_range - (fun () -> ET_app (PC.range_lid |> Ident.string_of_lid, [])) - -(* This is an odd one. We embed ranges as sealed, but we don't want to use the Sealed.sealed -type internally, so we "hack" it like this. *) -let e_range : embedding Range.range = - embed_as (e_sealed e___range) Sealed.unseal Sealed.seal None - -let e_issue : embedding Err.issue = e_lazy Lazy_issue (S.fvar PC.issue_lid None) -let e_document : embedding Pprint.document = e_lazy Lazy_doc (S.fvar PC.document_lid None) - - ///////////////////////////////////////////////////////////////////// - //Registering top-level functions - ///////////////////////////////////////////////////////////////////// - -let arrow_as_prim_step_1 (ea:embedding 'a) (eb:embedding 'b) - (f:'a -> 'b) (fv_lid:Ident.lid) norm - : universes -> args -> option term = - let rng = Ident.range_of_lid fv_lid in - let f_wrapped _us args = - //arity mismatches are handled by the caller - let [(x, _)] = args in - let shadow_app = - Some (Thunk.mk (fun () -> S.mk_Tm_app (norm (Inl fv_lid)) args rng)) - in - match - (BU.map_opt (try_unembed x norm) (fun x -> - embed (f x) rng shadow_app norm)) - with - // NB: this always returns a Some - | Some x -> Some x - | None -> force_shadow shadow_app - in - f_wrapped - -let arrow_as_prim_step_2 (ea:embedding 'a) (eb:embedding 'b) (ec:embedding 'c) - (f:'a -> 'b -> 'c) fv_lid norm - : universes -> args -> option term = - let rng = Ident.range_of_lid fv_lid in - let f_wrapped _us args = - //arity mismatches are handled by the caller - let [(x, _); (y, _)] = args in - let shadow_app = - Some (Thunk.mk (fun () -> S.mk_Tm_app (norm (Inl fv_lid)) args rng)) - in - match - (BU.bind_opt (try_unembed x norm) (fun x -> - BU.bind_opt (try_unembed y norm) (fun y -> - Some (embed (f x y) rng shadow_app norm)))) - with - // NB: this always returns a Some - | Some x -> Some x - | None -> force_shadow shadow_app - in - f_wrapped - -let arrow_as_prim_step_3 (ea:embedding 'a) (eb:embedding 'b) - (ec:embedding 'c) (ed:embedding 'd) - (f:'a -> 'b -> 'c -> 'd) fv_lid norm - : universes -> args -> option term = - let rng = Ident.range_of_lid fv_lid in - let f_wrapped _us args = - //arity mismatches are handled by the caller - let [(x, _); (y, _); (z, _)] = args in - let shadow_app = - Some (Thunk.mk (fun () -> S.mk_Tm_app (norm (Inl fv_lid)) args rng)) - in - match - (BU.bind_opt (try_unembed x norm) (fun x -> - BU.bind_opt (try_unembed y norm) (fun y -> - BU.bind_opt (try_unembed z norm) (fun z -> - Some (embed (f x y z) rng shadow_app norm))))) - with - // NB: this always returns a Some - | Some x -> Some x - | None -> force_shadow shadow_app - in - f_wrapped - -let debug_wrap (s:string) (f:unit -> 'a) = - if !Options.debug_embedding - then BU.print1 "++++starting %s\n" s; - let res = f () in - if !Options.debug_embedding - then BU.print1 "------ending %s\n" s; - res - -instance e_abstract_term : embedding abstract_term = - embed_as e_any (fun x -> Abstract x) (fun x -> match x with Abstract x -> x) None diff --git a/src/syntax/FStar.Syntax.Embeddings.fsti b/src/syntax/FStar.Syntax.Embeddings.fsti deleted file mode 100644 index 940a1d5bb0a..00000000000 --- a/src/syntax/FStar.Syntax.Embeddings.fsti +++ /dev/null @@ -1,98 +0,0 @@ -(* - Copyright 2008-2014 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Syntax.Embeddings - -open FStar -open FStar.Compiler -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Syntax.Syntax -open FStar.Char -open FStar.VConfig - -include FStar.Syntax.Embeddings.Base - -module Range = FStar.Compiler.Range -module Z = FStar.BigInt -module BU = FStar.Compiler.Util - -(* Embeddings, both ways and containing type information *) -val e_any : embedding term -// An identity. Not an instance as sometimes -// we make different choices for embedding a term - -instance val e_unit : embedding unit -instance val e_bool : embedding bool -instance val e_char : embedding char -instance val e_int : embedding Z.t -instance val e_fsint : embedding int -instance val e_string : embedding string -instance val e_real : embedding Compiler.Real.real -instance val e_norm_step : embedding Pervasives.norm_step -instance val e_vconfig : embedding vconfig -instance val e_order : embedding FStar.Order.order - -instance val e_option : embedding 'a -> Tot (embedding (option 'a)) -instance val e_list : embedding 'a -> Tot (embedding (list 'a)) -instance val e_tuple2 : embedding 'a -> embedding 'b -> Tot (embedding ('a & 'b)) -instance val e_tuple3 : embedding 'a -> embedding 'b -> embedding 'c -> Tot (embedding ('a & 'b & 'c)) -instance val e_tuple4 : embedding 'a -> embedding 'b -> embedding 'c -> embedding 'd -> Tot (embedding ('a & 'b & 'c & 'd)) -instance val e_tuple5 : embedding 'a -> embedding 'b -> embedding 'c -> embedding 'd -> embedding 'e -> Tot (embedding ('a & 'b & 'c & 'd & 'e)) -instance val e_either : embedding 'a -> embedding 'b -> Tot (embedding (either 'a 'b)) -instance val e_string_list : embedding (list string) -val e_arrow : embedding 'a -> embedding 'b -> Tot (embedding ('a -> 'b)) -instance val e_sealed : embedding 'a -> Tot (embedding (Sealed.sealed 'a)) - -val e___range : embedding Range.range (* unsealed *) -instance val e_range : embedding Range.range (* sealed *) -instance val e_document : embedding FStar.Pprint.document -instance val e_issue : embedding FStar.Errors.issue - -type abstract_term = | Abstract : t:term -> abstract_term -instance val e_abstract_term : embedding abstract_term - -val mk_any_emb : typ -> embedding term - -(* Arity specific raw_embeddings of arrows; used to generate top-level - registrations of compiled functions in FStar.Extraction.ML.Util - - See also FStar.TypeChecker.NBETerm.fsi *) -val arrow_as_prim_step_1: embedding 'a - -> embedding 'b - -> ('a -> 'b) - -> repr_f:Ident.lid - -> norm_cb - -> (universes -> args -> option term) - -val arrow_as_prim_step_2: embedding 'a - -> embedding 'b - -> embedding 'c - -> ('a -> 'b -> 'c) - -> repr_f:Ident.lid - -> norm_cb - -> (universes -> args -> option term) - -val arrow_as_prim_step_3: embedding 'a - -> embedding 'b - -> embedding 'c - -> embedding 'd - -> ('a -> 'b -> 'c -> 'd) - -> repr_f:Ident.lid - -> norm_cb - -> (universes -> args -> option term) - -val debug_wrap : string -> (unit -> 'a) -> 'a diff --git a/src/syntax/FStar.Syntax.Formula.fst b/src/syntax/FStar.Syntax.Formula.fst deleted file mode 100644 index e35fe43aaed..00000000000 --- a/src/syntax/FStar.Syntax.Formula.fst +++ /dev/null @@ -1,203 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Syntax.Formula - -open Prims -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List - -open FStar -open FStar.Compiler -open FStar.Ident -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.Syntax.Print - -module BU = FStar.Compiler.Util -module PC = FStar.Parser.Const -module U = FStar.Syntax.Util -module SS = FStar.Syntax.Subst - -open FStar.Class.Show -open FStar.Class.Monad - -let connective_to_string c = - match c with - | QAll p -> "QAll " ^ show p - | QEx p -> "QEx " ^ show p - | BaseConn p -> "BaseConn" ^ show p - -instance showable_connective = { - show = connective_to_string; -} - -(* destruct_typ_as_formula can be hot; these tables are defined - here to ensure they are constructed only once in the executing - binary - - the tables encode arity -> match_lid -> output_lid - *) -let destruct_base_table = let f x = (x,x) in [ - (0, [f PC.true_lid; f PC.false_lid]); - (1, [f PC.not_lid]); - (2, [f PC.and_lid; f PC.or_lid; f PC.imp_lid; f PC.iff_lid; f PC.eq2_lid]); - (3, [f PC.ite_lid; f PC.eq2_lid]); -] - -let destruct_sq_base_table = [ - (0, [(PC.c_true_lid, PC.true_lid); (PC.empty_type_lid, PC.false_lid)]); - (2, [(PC.c_and_lid, PC.and_lid); - (PC.c_or_lid, PC.or_lid); - (PC.c_eq2_lid, PC.eq2_lid)]); - (3, [(PC.c_eq2_lid, PC.eq2_lid)]); -] - -let rec unmeta_monadic f = - let f = Subst.compress f in - match f.n with - | Tm_meta {tm=t; meta=Meta_monadic _} - | Tm_meta {tm=t; meta=Meta_monadic_lift _} -> unmeta_monadic t - | _ -> f - -let lookup_arity_lid table target_lid args = - let arg_len : int = List.length args in - let aux (arity, lids) = - if arg_len = arity - then BU.find_map lids - (fun (lid, out_lid) -> - if lid_equals target_lid lid - then Some (BaseConn (out_lid, args)) - else None) - else None - in - BU.find_map table aux - -let destruct_base_conn t = - let hd, args = U.head_and_args t in - match (U.un_uinst hd).n with - | Tm_fvar fv -> lookup_arity_lid destruct_base_table fv.fv_name.v args - | _ -> None - -let destruct_sq_base_conn t = - let! t = U.un_squash t in - let t = U.unmeta t in - let hd, args = U.head_and_args_full t in - match (U.un_uinst hd).n with - | Tm_fvar fv -> lookup_arity_lid destruct_sq_base_table fv.fv_name.v args - | _ -> None - -let patterns t = - let t = SS.compress t in - match t.n with - | Tm_meta {tm=t; meta=Meta_pattern (_, pats)} -> pats, SS.compress t - | _ -> [], t - -let destruct_q_conn t = - let is_q (fa:bool) (fv:fv) : bool = - if fa - then U.is_forall fv.fv_name.v - else U.is_exists fv.fv_name.v - in - let flat t = - let t, args = U.head_and_args t in - U.un_uinst t, args |> List.map (fun (t, imp) -> U.unascribe t, imp) - in - let rec aux qopt out t = match qopt, flat t with - | Some fa, ({n=Tm_fvar tc}, [({n=Tm_abs {bs=[b]; body=t2}}, _)]) - | Some fa, ({n=Tm_fvar tc}, [_; ({n=Tm_abs {bs=[b]; body=t2}}, _)]) - when (is_q fa tc) -> - aux qopt (b::out) t2 - - | None, ({n=Tm_fvar tc}, [({n=Tm_abs {bs=[b]; body=t2}}, _)]) - | None, ({n=Tm_fvar tc}, [_; ({n=Tm_abs {bs=[b]; body=t2}}, _)]) - when (U.is_qlid tc.fv_name.v) -> - aux (Some (U.is_forall tc.fv_name.v)) (b::out) t2 - - | Some b, _ -> - let bs = List.rev out in - let bs, t = Subst.open_term bs t in - let pats, body = patterns t in - if b - then Some (QAll(bs, pats, body)) - else Some (QEx(bs, pats, body)) - - | _ -> None in - aux None [] t - -let rec destruct_sq_forall t = - let! t = U.un_squash t in - let t = U.unmeta t in - match U.arrow_one t with - | Some (b, c) -> - if not (U.is_tot_or_gtot_comp c) - then None - else - let q = U.comp_result c in - if U.is_free_in b.binder_bv q - then ( - let pats, q = patterns q in - maybe_collect <| Some (QAll([b], pats, q)) - ) else ( - // Since we know it's not free, we can just open and discard the binder - Some (BaseConn (PC.imp_lid, [as_arg b.binder_bv.sort; as_arg q])) - ) - | _ -> None -and destruct_sq_exists t = - let! t = U.un_squash t in - let t = U.unmeta t in - let hd, args = U.head_and_args_full t in - match (U.un_uinst hd).n, args with - | Tm_fvar fv, [(a1, _); (a2, _)] - when fv_eq_lid fv PC.dtuple2_lid -> - begin match (SS.compress a2).n with - | Tm_abs {bs=[b]; body=q} -> - let bs, q = SS.open_term [b] q in - let b = match bs with // coverage... - | [b] -> b - | _ -> failwith "impossible" - in - let pats, q = patterns q in - maybe_collect <| Some (QEx ([b], pats, q)) - | _ -> None - end - | _ -> None -and maybe_collect f = - match f with - | Some (QAll (bs, pats, phi)) -> - begin match destruct_sq_forall phi with - | Some (QAll (bs', pats', psi)) -> Some <| QAll(bs@bs', pats@pats', psi) - | _ -> f - end - | Some (QEx (bs, pats, phi)) -> - begin match destruct_sq_exists phi with - | Some (QEx (bs', pats', psi)) -> Some <| QEx(bs@bs', pats@pats', psi) - | _ -> f - end - | _ -> f - -let destruct_typ_as_formula f : option connective = - let phi = unmeta_monadic f in - let r = - // Try all possibilities, stopping at the first - BU.catch_opt (destruct_base_conn phi) (fun () -> - BU.catch_opt (destruct_q_conn phi) (fun () -> - BU.catch_opt (destruct_sq_base_conn phi) (fun () -> - BU.catch_opt (destruct_sq_forall phi) (fun () -> - BU.catch_opt (destruct_sq_exists phi) (fun () -> - None))))) - in - r diff --git a/src/syntax/FStar.Syntax.Formula.fsti b/src/syntax/FStar.Syntax.Formula.fsti deleted file mode 100644 index 80d36c83770..00000000000 --- a/src/syntax/FStar.Syntax.Formula.fsti +++ /dev/null @@ -1,35 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Syntax.Formula - -open FStar.Compiler.Effect -open FStar.Ident -open FStar.Syntax.Syntax -open FStar.Class.Show - -(**************************************************************************************) -(* Destructing a type as a formula *) -(**************************************************************************************) - -type qpats = list args -type connective = - | QAll of binders & qpats & typ - | QEx of binders & qpats & typ - | BaseConn of lident & args - -instance val showable_connective : showable connective - -val destruct_typ_as_formula (f:term) : option connective diff --git a/src/syntax/FStar.Syntax.Free.fst b/src/syntax/FStar.Syntax.Free.fst deleted file mode 100644 index 9f0e5709b74..00000000000 --- a/src/syntax/FStar.Syntax.Free.fst +++ /dev/null @@ -1,324 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Syntax.Free -open Prims -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List - -open FStar -open FStar.Compiler -open FStar.Compiler.Util -open FStar.Syntax -open FStar.Syntax.Syntax -module Util = FStar.Compiler.Util -module UF = FStar.Syntax.Unionfind - -open FStar.Class.Ord -open FStar.Class.Show -open FStar.Class.Setlike - -let compare_uv uv1 uv2 = UF.uvar_id uv1.ctx_uvar_head - UF.uvar_id uv2.ctx_uvar_head -let compare_universe_uvar x y = UF.univ_uvar_id x - UF.univ_uvar_id y - -instance deq_ctx_uvar : deq ctx_uvar = { - (=?) = (fun u v -> UF.uvar_id u.ctx_uvar_head =? UF.uvar_id v.ctx_uvar_head); -} -instance ord_ctx_uvar : ord ctx_uvar = { - super = Tactics.Typeclasses.solve; - cmp = (fun u v -> UF.uvar_id u.ctx_uvar_head `cmp` UF.uvar_id v.ctx_uvar_head); -} -instance deq_univ_uvar : deq universe_uvar = { - (=?) = (fun u v -> UF.univ_uvar_id u =? UF.univ_uvar_id v); -} -instance ord_univ_uvar : ord universe_uvar = { - super = Tactics.Typeclasses.solve; - cmp = (fun u v -> UF.univ_uvar_id u `cmp` UF.univ_uvar_id v); -} - -let ctx_uvar_typ (u:ctx_uvar) = - (UF.find_decoration u.ctx_uvar_head).uvar_decoration_typ - - -(********************************************************************************) -(************************* Free names and unif variables ************************) -(********************************************************************************) - -type use_cache_t = - | Def - | NoCache - | Full - -(* We use an RBSet for the fvars, as order definitely does not matter here -and it's faster. *) -type free_vars_and_fvars = free_vars & RBSet.t Ident.lident - -(* Snoc without duplicates *) -val snoc : #a:Type -> {| deq a |} -> list a -> a -> list a -let rec snoc xx y = - match xx with - | [] -> [y] - | x::xx' -> if x =? y then xx - else x :: snoc xx' y - -(* Concatenation without duplicates *) -val (@@) : #a:Type -> {| deq a |} -> list a -> list a -> list a -let (@@) xs ys = List.fold_left (fun xs y -> snoc xs y) xs ys - -let no_free_vars : free_vars_and_fvars = { - free_names = empty(); - free_uvars = empty(); - free_univs = empty(); - free_univ_names = empty(); -}, empty () - -let singleton_fvar fv : free_vars_and_fvars = - fst no_free_vars, - add fv.fv_name.v (empty ()) - -let singleton_bv x = - {fst no_free_vars with free_names = singleton x}, snd no_free_vars -let singleton_uv x = - {fst no_free_vars with free_uvars = singleton x}, snd no_free_vars -let singleton_univ x = - {fst no_free_vars with free_univs = singleton x}, snd no_free_vars -let singleton_univ_name x = - {fst no_free_vars with free_univ_names = singleton x}, snd no_free_vars - -(* Union of free vars *) -let ( ++ ) (f1 : free_vars_and_fvars) (f2 : free_vars_and_fvars) = { - free_names=(fst f1).free_names `union` (fst f2).free_names; - free_uvars=(fst f1).free_uvars `union` (fst f2).free_uvars; - free_univs=(fst f1).free_univs `union` (fst f2).free_univs; - free_univ_names=(fst f1).free_univ_names `union` (fst f2).free_univ_names; //THE ORDER HERE IS IMPORTANT! - //We expect the free_univ_names list to be in fifo order to get the right order of universe generalization -}, union (snd f1) (snd f2) - -let rec free_univs u = match Subst.compress_univ u with - | U_zero - | U_bvar _ - | U_unknown -> no_free_vars - | U_name uname -> singleton_univ_name uname - | U_succ u -> free_univs u - | U_max us -> List.fold_left (fun out x -> out ++ free_univs x) no_free_vars us - | U_unif u -> singleton_univ u - -//the interface of Syntax.Free now supports getting fvars in a term also -//however, fvars are added unlike free names, free uvars, etc. which are part of a record free_vars, that is memoized at **every** AST node -//if we added fvars also to the record, it would affect every AST node -//instead of doing that, the functions below compute a tuple, free_vars * set lident, where the second component is the fvars lids -//but this raises a compilication, what should happen when the functions below just return from the cache from the AST nodes -//to handle that, use_cache flag is UNSET when asking for free_fvars, so that all the terms are traversed completely -//on the other hand, for earlier interface use_cache is true -//this flag is propagated, and is used in the function should_invalidate_cache below -let rec free_names_and_uvs' tm (use_cache:use_cache_t) : free_vars_and_fvars = - let aux_binders (bs : binders) (from_body : free_vars_and_fvars) = - let from_binders = free_names_and_uvars_binders bs use_cache in - from_binders ++ from_body - in - let t = Subst.compress tm in - match t.n with - | Tm_delayed _ -> failwith "Impossible" - - | Tm_name x -> - singleton_bv x - - | Tm_uvar (uv, (s, _)) -> - singleton_uv uv ++ - (if use_cache = Full - then free_names_and_uvars (ctx_uvar_typ uv) use_cache - else no_free_vars) - - | Tm_type u -> - free_univs u - - | Tm_bvar _ -> no_free_vars - | Tm_fvar fv -> singleton_fvar fv - - | Tm_constant _ - | Tm_lazy _ - | Tm_unknown -> - no_free_vars - - | Tm_uinst(t, us) -> - let f = free_names_and_uvars t use_cache in - List.fold_left (fun out u -> out ++ free_univs u) f us - - | Tm_abs {bs; body=t; rc_opt=ropt} -> - aux_binders bs (free_names_and_uvars t use_cache) ++ - (match ropt with - | Some { residual_typ = Some t } -> free_names_and_uvars t use_cache - | _ -> no_free_vars) - - | Tm_arrow {bs; comp=c} -> - aux_binders bs (free_names_and_uvars_comp c use_cache) - - | Tm_refine {b=bv; phi=t} -> - aux_binders [mk_binder bv] (free_names_and_uvars t use_cache) - - | Tm_app {hd=t; args} -> - free_names_and_uvars_args args (free_names_and_uvars t use_cache) use_cache - - | Tm_match {scrutinee=t; ret_opt=asc_opt; brs=pats; rc_opt} -> - (match rc_opt with - | Some { residual_typ = Some t } -> free_names_and_uvars t use_cache - | _ -> no_free_vars) ++ - begin - pats |> List.fold_left (fun n (p, wopt, t) -> - let n1 = match wopt with - | None -> no_free_vars - | Some w -> free_names_and_uvars w use_cache - in - let n2 = free_names_and_uvars t use_cache in - let n = - pat_bvs p |> List.fold_left (fun n x -> n ++ free_names_and_uvars x.sort use_cache) n - in - n ++ n1 ++ n2) - (free_names_and_uvars t use_cache - ++ (match asc_opt with - | None -> no_free_vars - | Some (b, asc) -> - free_names_and_uvars_binders [b] use_cache ++ - free_names_and_uvars_ascription asc use_cache)) - end - - | Tm_ascribed {tm=t1; asc} -> - free_names_and_uvars t1 use_cache ++ - free_names_and_uvars_ascription asc use_cache - - | Tm_let {lbs; body=t} -> - snd lbs |> List.fold_left (fun n lb -> - n ++ - free_names_and_uvars lb.lbtyp use_cache ++ - free_names_and_uvars lb.lbdef use_cache) - (free_names_and_uvars t use_cache) - - | Tm_quoted (tm, qi) -> - begin match qi.qkind with - | Quote_static -> List.fold_left (fun n t -> n ++ free_names_and_uvars t use_cache) no_free_vars (snd qi.antiquotations) - | Quote_dynamic -> free_names_and_uvars tm use_cache - end - - | Tm_meta {tm=t; meta=m} -> - let u1 = free_names_and_uvars t use_cache in - begin match m with - | Meta_pattern (_, args) -> - List.fold_right (fun a acc -> free_names_and_uvars_args a acc use_cache) args u1 - - | Meta_monadic(_, t') -> - u1 ++ free_names_and_uvars t' use_cache - - | Meta_monadic_lift(_, _, t') -> - u1 ++ free_names_and_uvars t' use_cache - - | Meta_labeled _ - | Meta_desugared _ - | Meta_named _ -> u1 - end - - -and free_names_and_uvars_binders bs use_cache = - bs |> List.fold_left (fun n b -> - n ++ free_names_and_uvars b.binder_bv.sort use_cache) no_free_vars - - -and free_names_and_uvars_ascription asc use_cache = - let asc, tacopt, _ = asc in - (match asc with - | Inl t -> free_names_and_uvars t use_cache - | Inr c -> free_names_and_uvars_comp c use_cache) ++ - (match tacopt with - | None -> no_free_vars - | Some tac -> free_names_and_uvars tac use_cache) - -and free_names_and_uvars t use_cache = - let t = Subst.compress t in - match !t.vars with - | Some n when not (should_invalidate_cache n use_cache) -> n, empty () - | _ -> - t.vars := None; - let n = free_names_and_uvs' t use_cache in - if use_cache <> Full then t.vars := Some (fst n); - n - -and free_names_and_uvars_args args (acc : free_vars_and_fvars) use_cache = - args |> List.fold_left (fun n (x, _) -> n ++ (free_names_and_uvars x use_cache)) acc - -and free_names_and_uvars_comp c use_cache = - match !c.vars with - | Some n -> - if should_invalidate_cache n use_cache - then (c.vars := None; free_names_and_uvars_comp c use_cache) - else n, empty () - | _ -> - let n = match c.n with - | GTotal t - | Total t -> - free_names_and_uvars t use_cache - - | Comp ct -> - //collect from the decreases clause - let decreases_vars = - match List.tryFind (function DECREASES _ -> true | _ -> false) ct.flags with - | None -> no_free_vars - | Some (DECREASES dec_order) -> - free_names_and_uvars_dec_order dec_order use_cache - in - //decreases clause + return type - let us = free_names_and_uvars ct.result_typ use_cache ++ decreases_vars in - //decreases clause + return type + effect args - let us = free_names_and_uvars_args ct.effect_args us use_cache in - //decreases clause + return type + effect args + comp_univs - List.fold_left (fun us u -> us ++ free_univs u) us ct.comp_univs - in - c.vars := Some (fst n); - n - -and free_names_and_uvars_dec_order dec_order use_cache = - match dec_order with - | Decreases_lex l -> - l |> List.fold_left (fun acc t -> acc ++ free_names_and_uvars t use_cache) no_free_vars - | Decreases_wf (rel, e) -> - free_names_and_uvars rel use_cache ++ - free_names_and_uvars e use_cache - -and should_invalidate_cache n use_cache = - (use_cache <> Def) || - (n.free_uvars |> for_any (fun u -> - match UF.find u.ctx_uvar_head with - | Some _ -> true - | _ -> false)) || - (n.free_univs |> for_any (fun u -> - match UF.univ_find u with - | Some _ -> true - | None -> false)) - -//note use_cache is set false ONLY for fvars, which is not maintained at each AST node -//see the comment above - -let names t = (fst (free_names_and_uvars t Def)).free_names -let uvars t = (fst (free_names_and_uvars t Def)).free_uvars -let univs t = (fst (free_names_and_uvars t Def)).free_univs - -let univnames t = (fst (free_names_and_uvars t Def)).free_univ_names -let univnames_comp c = (fst (free_names_and_uvars_comp c Def)).free_univ_names - -let fvars t = snd (free_names_and_uvars t NoCache) -let names_of_binders (bs:binders) = - ((fst (free_names_and_uvars_binders bs Def)).free_names) - -let uvars_uncached t = (fst (free_names_and_uvars t NoCache)).free_uvars -let uvars_full t = (fst (free_names_and_uvars t Full)).free_uvars diff --git a/src/syntax/FStar.Syntax.Free.fsti b/src/syntax/FStar.Syntax.Free.fsti deleted file mode 100644 index 77bae21698e..00000000000 --- a/src/syntax/FStar.Syntax.Free.fsti +++ /dev/null @@ -1,43 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Syntax.Free -open FStar.Compiler.Effect -open Prims -open FStar -open FStar.Compiler -open FStar.Compiler.Util -open FStar.Compiler.FlatSet -open FStar.Syntax -open FStar.Syntax.Syntax - -val names : term -> FlatSet.t bv -val names_of_binders : binders -> FlatSet.t bv - -val fvars : term -> RBSet.t Ident.lident - -val uvars : term -> FlatSet.t ctx_uvar -val uvars_uncached : term -> FlatSet.t ctx_uvar -val uvars_full : term -> FlatSet.t ctx_uvar - -val univs : term -> FlatSet.t universe_uvar - -val univnames : term -> FlatSet.t univ_name -val univnames_comp : comp -> FlatSet.t univ_name - -(* Bad place for these instances. But they cannot be instance -Syntax.Syntax since they reference the UF graph. *) -instance val ord_ctx_uvar : Class.Ord.ord ctx_uvar -instance val ord_univ_uvar : Class.Ord.ord universe_uvar diff --git a/src/syntax/FStar.Syntax.Hash.fst b/src/syntax/FStar.Syntax.Hash.fst deleted file mode 100644 index 4815b4b70c3..00000000000 --- a/src/syntax/FStar.Syntax.Hash.fst +++ /dev/null @@ -1,614 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or impliedmk_ - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Syntax.Hash -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.Util -open FStar.Syntax.Syntax -open FStar.Const -module SS = FStar.Syntax.Subst -module UU = FStar.Syntax.Unionfind -module BU = FStar.Compiler.Util - -(* maybe memo *) -let mm (t:Type) = bool -> t & bool - -let (let?) (f:mm 't) (g: 't -> mm 's) : mm 's = - fun b -> - let t, b = f b in - g t b - -let ret (x:'t) : mm 't = fun b -> x, b - -let should_memo : mm bool = fun b -> b, b - -let no_memo : mm unit = fun _ -> (), false - -module H = FStar.Hash - -let maybe_memoize (h:syntax 'a) (f:syntax 'a -> mm H.hash_code) : mm H.hash_code = - fun should_memo -> - if should_memo - then ( - match !h.hash_code with - | Some c -> c, should_memo - | None -> - let c, should_memo = f h should_memo in - if should_memo - then h.hash_code := Some c; - c, should_memo - ) - else f h should_memo - -let of_int (i:int) : mm H.hash_code = ret (H.of_int i) - -let of_string (s:string) : mm H.hash_code = ret (H.of_string s) - -let mix (f:mm H.hash_code) (g:mm H.hash_code) : mm H.hash_code = - fun b -> let x, b0 = f b in - let y, b1 = g b in - H.mix x y, b0 && b1 - -let nil_hc : mm H.hash_code = of_int 1229 -let cons_hc : mm H.hash_code = of_int 1231 - -let mix_list (l:list (mm H.hash_code)) : mm H.hash_code = - List.fold_right mix l nil_hc - -let mix_list_lit = mix_list - -let hash_list (h:'a -> mm H.hash_code) (ts:list 'a) : mm H.hash_code = mix_list (List.map h ts) - -let hash_option (h:'a -> mm H.hash_code) (o:option 'a) : mm H.hash_code = - match o with - | None -> ret (H.of_int 1237) - | Some o -> mix (ret (H.of_int 1249)) (h o) - -// hash the string. -let hash_doc (d : Pprint.document) : mm H.hash_code = - of_string (Pprint.pretty_string (float_of_string "1.0") 80 d) - -let hash_doc_list (ds : list Pprint.document) : mm H.hash_code = - hash_list hash_doc ds - -let hash_pair (h:'a -> mm H.hash_code) (i:'b -> mm H.hash_code) (x:('a & 'b)) - : mm H.hash_code - = mix (h (fst x)) (i (snd x)) - -let rec hash_term (t:term) - : mm H.hash_code - = maybe_memoize t hash_term' - -and hash_comp c - : mm H.hash_code - = maybe_memoize c hash_comp' - -and hash_term' (t:term) - : mm H.hash_code - = // if Debug.any () - // then FStar.Compiler.Util.print1 "Hash_term %s\n" (FStar.Syntax.show t); - match (SS.compress t).n with - | Tm_bvar bv -> mix (of_int 3) (of_int bv.index) - | Tm_name bv -> mix (of_int 5) (of_int bv.index) - | Tm_fvar fv -> mix (of_int 7) (hash_fv fv) - | Tm_uinst(t, us) -> mix (of_int 11) - (mix (hash_term t) - (hash_list hash_universe us)) - | Tm_constant sc -> mix (of_int 13) (hash_constant sc) - | Tm_type u -> mix (of_int 17) (hash_universe u) - | Tm_abs {bs; body=t; rc_opt=rcopt} -> mix (of_int 19) - (mix (hash_list hash_binder bs) - (mix (hash_term t) - (hash_option hash_rc rcopt))) - | Tm_arrow {bs; comp=c} -> mix (of_int 23) (mix (hash_list hash_binder bs) (hash_comp c)) - | Tm_refine {b; phi=t} -> mix (of_int 29) (mix (hash_bv b) (hash_term t)) - | Tm_app {hd=t; args} -> mix (of_int 31) (mix (hash_term t) (hash_list hash_arg args)) - | Tm_match {scrutinee=t; ret_opt=asc_opt; brs=branches; rc_opt=rcopt} -> - mix (of_int 37) - (mix (hash_option hash_match_returns asc_opt) - (mix (mix (hash_term t) (hash_list hash_branch branches)) - (hash_option hash_rc rcopt))) - | Tm_ascribed {tm=t; asc=a; eff_opt=lopt} -> mix (of_int 43) (mix (hash_term t) (mix (hash_ascription a) (hash_option hash_lid lopt))) - | Tm_let {lbs=(false, [lb]); body=t} -> mix (of_int 47) (mix (hash_lb lb) (hash_term t)) - | Tm_let {lbs=(_, lbs); body=t} -> mix (of_int 51) (mix (hash_list hash_lb lbs) (hash_term t)) - | Tm_uvar uv -> mix (of_int 53) (hash_uvar uv) - | Tm_meta {tm=t; meta=m} -> mix (of_int 61) (mix (hash_term t) (hash_meta m)) - | Tm_lazy li -> mix (of_int 67) (hash_lazyinfo li) - | Tm_quoted (t, qi) -> mix (of_int 71) (mix (hash_term t) (hash_quoteinfo qi)) - | Tm_unknown -> of_int 73 - | Tm_delayed _ -> failwith "Impossible" - -and hash_comp' (c:comp) - : mm H.hash_code - = match c.n with - | Total t -> - mix_list_lit - [of_int 811; - hash_term t] - | GTotal t -> - mix_list_lit - [of_int 821; - hash_term t] - | Comp ct -> - mix_list_lit - [of_int 823; - hash_list hash_universe ct.comp_univs; - hash_lid ct.effect_name; - hash_term ct.result_typ; - hash_list hash_arg ct.effect_args; - hash_list hash_flag ct.flags] - -and hash_lb lb = - mix_list_lit - [ of_int 79; - hash_lbname lb.lbname; - hash_list hash_ident lb.lbunivs; - hash_term lb.lbtyp; - hash_lid lb.lbeff; - hash_term lb.lbdef; - hash_list hash_term lb.lbattrs] - -and hash_match_returns (b, asc) = - mix (hash_binder b) - (hash_ascription asc) - -and hash_branch b = - let p, topt, t = b in - mix_list_lit - [of_int 83; - hash_pat p; - hash_option hash_term topt; - hash_term t] - -and hash_pat p = - match p.v with - | Pat_constant c -> mix (of_int 89) (hash_constant c) - | Pat_cons(fv, us, args) -> - mix_list_lit - [of_int 97; - hash_fv fv; - hash_option (hash_list hash_universe) us; - hash_list (hash_pair hash_pat hash_bool) args] - | Pat_var bv -> mix (of_int 101) (hash_bv bv) - | Pat_dot_term t -> mix_list_lit [of_int 107; hash_option hash_term t] - - -and hash_bv b = hash_term b.sort -and hash_fv fv = of_string (Ident.string_of_lid fv.fv_name.v) -and hash_binder (b:binder) = - mix_list_lit - [hash_bv b.binder_bv; - hash_option hash_bqual b.binder_qual; - hash_list hash_term b.binder_attrs] - -and hash_universe = - function - | U_zero -> of_int 179 - | U_succ u -> mix (of_int 181) (hash_universe u) - | U_max us -> mix (of_int 191) (hash_list hash_universe us) - | U_bvar i -> mix (of_int 193) (of_int i) - | U_name i -> mix (of_int 197) (hash_ident i) - | U_unif uv -> mix (of_int 199) (hash_universe_uvar uv) - | U_unknown -> of_int 211 - -and hash_arg (t, aq) = - mix (hash_term t) (hash_option hash_arg_qualifier aq) - -and hash_arg_qualifier aq = - mix (hash_bool aq.aqual_implicit) - (hash_list hash_term aq.aqual_attributes) - -and hash_bqual = - function - | Implicit true -> of_int 419 - | Implicit false -> of_int 421 - | Meta t -> mix (of_int 431) (hash_term t) - | Equality -> of_int 433 - -and hash_uvar (u, _) = of_int (UU.uvar_id u.ctx_uvar_head) - -and hash_universe_uvar u = of_int (UU.univ_uvar_id u) - -and hash_ascription (a, to, b) = - mix - (match a with - | Inl t -> hash_term t - | Inr c -> hash_comp c) - (hash_option hash_term to) - -and hash_bool b = - if b then of_int 307 - else of_int 311 - -and hash_constant = - function - | Const_effect -> of_int 283 - | Const_unit -> of_int 293 - | Const_bool b -> hash_bool b - | Const_int (s, o) -> mix (of_int 313) - (mix (of_string s) - (hash_option hash_sw o)) - | Const_char c -> mix (of_int 317) (of_int (Char.int_of_char c)) - | Const_real s -> mix (of_int 337) (of_string s) - | Const_string (s, _) -> mix (of_int 349) (of_string s) - | Const_range_of -> of_int 353 - | Const_set_range_of -> of_int 359 - | Const_range r -> mix (of_int 367) (of_string (Range.string_of_range r)) - | Const_reify _ -> of_int 367 - | Const_reflect l -> mix (of_int 373) (hash_lid l) - -and hash_sw (s, w) = - mix - (match s with - | Unsigned -> of_int 547 - | Signed -> of_int 557) - (match w with - | Int8 -> of_int 563 - | Int16 -> of_int 569 - | Int32 -> of_int 571 - | Int64 -> of_int 577 - | Sizet -> of_int 583) - -and hash_ident i = of_string (Ident.string_of_id i) -and hash_lid l = of_string (Ident.string_of_lid l) -and hash_lbname l = - match l with - | Inl bv -> hash_bv bv - | Inr fv -> hash_fv fv -and hash_rc rc = - mix_list_lit - [ hash_lid rc.residual_effect; - hash_option hash_term rc.residual_typ; - hash_list hash_flag rc.residual_flags ] - -and hash_flag = - function - | TOTAL -> of_int 947 - | MLEFFECT -> of_int 953 - | LEMMA -> of_int 967 - | RETURN -> of_int 971 - | PARTIAL_RETURN -> of_int 977 - | SOMETRIVIAL -> of_int 983 - | TRIVIAL_POSTCONDITION -> of_int 991 - | SHOULD_NOT_INLINE -> of_int 997 - | CPS -> of_int 1009 - | DECREASES (Decreases_lex ts) -> mix (of_int 1013) (hash_list hash_term ts) - | DECREASES (Decreases_wf (t0, t1)) -> mix (of_int 2341) (hash_list hash_term [t0;t1]) - -and hash_meta m = - match m with - | Meta_pattern (ts, args) -> - mix_list_lit - [ of_int 1019; - hash_list hash_term ts; - hash_list (hash_list hash_arg) args ] - | Meta_named l -> - mix_list_lit - [ of_int 1021; - hash_lid l ] - | Meta_labeled (s, r, _) -> - mix_list_lit - [ of_int 1031; - hash_doc_list s; - of_string (Range.string_of_range r) ] - | Meta_desugared msi -> - mix_list_lit - [ of_int 1033; - hash_meta_source_info msi ] - | Meta_monadic(m, t) -> - mix_list_lit - [ of_int 1039; - hash_lid m; - hash_term t ] - | Meta_monadic_lift (m0, m1, t) -> - mix_list_lit - [of_int 1069; - hash_lid m0; - hash_lid m1; - hash_term t] - -and hash_meta_source_info m = - match m with - | Sequence -> of_int 1049 - | Primop -> of_int 1051 - | Masked_effect -> of_int 1061 - | Meta_smt_pat -> of_int 1063 - | Machine_integer sw -> mix (of_int 1069) (hash_sw sw) - -and hash_lazyinfo li = of_int 0 //no meaningful way to hash the blob - -and hash_quoteinfo qi = - mix - (hash_bool (qi.qkind = Quote_static)) - (hash_list hash_term (snd qi.antiquotations)) - -//////////////////////////////////////////////////////////////////////////////// -let rec equal_list f l1 l2 = - match l1, l2 with - | [], [] -> true - | h1::t1, h2::t2 -> f h1 h2 && equal_list f t1 t2 - | _ -> false - -let equal_opt f o1 o2 = - match o1, o2 with - | None, None -> true - | Some a, Some b -> f a b - | _ -> false - -let equal_pair f g (x1, y1) (x2, y2) = f x1 x2 && g y1 y2 - -let equal_poly x y = x=y - -let ext_hash_term (t:term) = fst (hash_term t true) -let ext_hash_term_no_memo (t:term) = fst (hash_term t false) - -let rec equal_term (t1 t2:term) - : bool - = if physical_equality t1 t2 then true else - if physical_equality t1.n t2.n then true else - if ext_hash_term t1 <> ext_hash_term t2 then false else - match (SS.compress t1).n, (SS.compress t2).n with - | Tm_bvar x, Tm_bvar y -> x.index = y.index - | Tm_name x, Tm_name y -> x.index = y.index - | Tm_fvar f, Tm_fvar g -> equal_fv f g - | Tm_uinst (t1, u1), Tm_uinst (t2, u2) -> - equal_term t1 t2 && - equal_list equal_universe u1 u2 - | Tm_constant c1, Tm_constant c2 -> equal_constant c1 c2 - | Tm_type u1, Tm_type u2 -> equal_universe u1 u2 - | Tm_abs {bs=bs1; body=t1; rc_opt=rc1}, Tm_abs {bs=bs2; body=t2; rc_opt=rc2} -> - equal_list equal_binder bs1 bs2 && - equal_term t1 t2 && - equal_opt equal_rc rc1 rc2 - | Tm_arrow {bs=bs1; comp=c1}, Tm_arrow {bs=bs2; comp=c2} -> - equal_list equal_binder bs1 bs2 && - equal_comp c1 c2 - | Tm_refine {b=b1; phi=t1}, Tm_refine {b=b2; phi=t2} -> - equal_bv b1 b2 && - equal_term t1 t2 - | Tm_app {hd=t1; args=as1}, Tm_app {hd=t2; args=as2} -> - equal_term t1 t2 && - equal_list equal_arg as1 as2 - | Tm_match {scrutinee=t1; ret_opt=asc_opt1; brs=bs1; rc_opt=ropt1}, - Tm_match {scrutinee=t2; ret_opt=asc_opt2; brs=bs2; rc_opt=ropt2} -> - equal_term t1 t2 && - equal_opt equal_match_returns asc_opt1 asc_opt2 && - equal_list equal_branch bs1 bs2 && - equal_opt equal_rc ropt1 ropt2 - | Tm_ascribed {tm=t1; asc=a1; eff_opt=l1}, - Tm_ascribed {tm=t2; asc=a2; eff_opt=l2} -> - equal_term t1 t2 && - equal_ascription a1 a2 && - equal_opt Ident.lid_equals l1 l2 - | Tm_let {lbs=(r1, lbs1); body=t1}, Tm_let {lbs=(r2, lbs2); body=t2} -> - r1 = r2 && - equal_list equal_letbinding lbs1 lbs2 && - equal_term t1 t2 - | Tm_uvar u1, Tm_uvar u2 -> - equal_uvar u1 u2 - | Tm_meta {tm=t1; meta=m1}, Tm_meta {tm=t2; meta=m2} -> - equal_term t1 t2 && - equal_meta m1 m2 - | Tm_lazy l1, Tm_lazy l2 -> - equal_lazyinfo l1 l2 - | Tm_quoted (t1, q1), Tm_quoted (t2, q2) -> - equal_term t1 t2 && - equal_quoteinfo q1 q2 - | Tm_unknown, Tm_unknown -> - true - | _ -> false - -and equal_comp c1 c2 = - if physical_equality c1 c2 then true else - match c1.n, c2.n with - | Total t1, Total t2 - | GTotal t1, GTotal t2 -> - equal_term t1 t2 - | Comp ct1, Comp ct2 -> - Ident.lid_equals ct1.effect_name ct2.effect_name && - equal_list equal_universe ct1.comp_univs ct2.comp_univs && - equal_term ct1.result_typ ct2.result_typ && - equal_list equal_arg ct1.effect_args ct2.effect_args && - equal_list equal_flag ct1.flags ct2.flags - -and equal_binder b1 b2 = - if physical_equality b1 b2 then true else - equal_bv b1.binder_bv b2.binder_bv && - equal_bqual b1.binder_qual b2.binder_qual && - equal_list equal_term b1.binder_attrs b2.binder_attrs - -and equal_match_returns (b1, asc1) (b2, asc2) = - equal_binder b1 b2 && - equal_ascription asc1 asc2 - -and equal_ascription x1 x2 = - if physical_equality x1 x2 then true else - let a1, t1, b1 = x1 in - let a2, t2, b2 = x2 in - (match a1, a2 with - | Inl t1, Inl t2 -> equal_term t1 t2 - | Inr c1, Inr c2 -> equal_comp c1 c2 - | _ -> false) && - equal_opt equal_term t1 t2 && - b1 = b2 - -and equal_letbinding l1 l2 = - if physical_equality l1 l2 then true else - equal_lbname l1.lbname l2.lbname && - equal_list Ident.ident_equals l1.lbunivs l2.lbunivs && - equal_term l1.lbtyp l2.lbtyp && - Ident.lid_equals l1.lbeff l2.lbeff && - equal_term l1.lbdef l2.lbdef && - equal_list equal_term l1.lbattrs l2.lbattrs - -and equal_uvar (u1, (s1, _)) (u2, (s2, _)) = - UU.equiv u1.ctx_uvar_head u2.ctx_uvar_head && - equal_list (equal_list equal_subst_elt) s1 s2 - -and equal_bv b1 b2 = - if physical_equality b1 b2 then true else - Ident.ident_equals b1.ppname b2.ppname && - equal_term b1.sort b2.sort - -and equal_fv f1 f2 = - if physical_equality f1 f2 then true else - Ident.lid_equals f1.fv_name.v f2.fv_name.v - -and equal_universe u1 u2 = - if physical_equality u1 u2 then true else - match (SS.compress_univ u1), (SS.compress_univ u2) with - | U_zero, U_zero -> true - | U_succ u1, U_succ u2 -> equal_universe u1 u2 - | U_max us1, U_max us2 -> equal_list equal_universe us1 us2 - | U_bvar i1, U_bvar i2 -> i1 = i2 - | U_name x1, U_name x2 -> Ident.ident_equals x1 x2 - | U_unif u1, U_unif u2 -> UU.univ_equiv u1 u2 - | U_unknown, U_unknown -> true - | _ -> false - -and equal_constant c1 c2 = - if physical_equality c1 c2 then true else - match c1, c2 with - | Const_effect, Const_effect - | Const_unit, Const_unit -> true - | Const_bool b1, Const_bool b2 -> b1 = b2 - | Const_int (s1, o1), Const_int(s2, o2) -> s1=s2 && o1=o2 - | Const_char c1, Const_char c2 -> c1=c2 - | Const_real s1, Const_real s2 -> s1=s2 - | Const_string (s1, _), Const_string (s2, _) -> s1=s2 - | Const_range_of, Const_range_of - | Const_set_range_of, Const_set_range_of -> true - | Const_range r1, Const_range r2 -> Range.compare r1 r2 = 0 - | Const_reify _, Const_reify _ -> true - | Const_reflect l1, Const_reflect l2 -> Ident.lid_equals l1 l2 - | _ -> false - -and equal_arg arg1 arg2 = - if physical_equality arg1 arg2 then true else - let t1, a1 = arg1 in - let t2, a2 = arg2 in - equal_term t1 t2 && - equal_opt equal_arg_qualifier a1 a2 - -and equal_bqual b1 b2 = - equal_opt equal_binder_qualifier b1 b2 - -and equal_binder_qualifier b1 b2 = - match b1, b2 with - | Implicit b1, Implicit b2 -> b1 = b2 - | Equality, Equality -> true - | Meta t1, Meta t2 -> equal_term t1 t2 - | _ -> false - -and equal_branch (p1, w1, t1) (p2, w2, t2) = - equal_pat p1 p2 && - equal_opt equal_term w1 w2 && - equal_term t1 t2 - -and equal_pat p1 p2 = - if physical_equality p1 p2 then true else - match p1.v, p2.v with - | Pat_constant c1, Pat_constant c2 -> - equal_constant c1 c2 - | Pat_cons(fv1, us1, args1), Pat_cons(fv2, us2, args2) -> - equal_fv fv1 fv2 && - equal_opt (equal_list equal_universe) us1 us2 && - equal_list (equal_pair equal_pat equal_poly) args1 args2 - | Pat_var bv1, Pat_var bv2 -> - equal_bv bv1 bv2 - | Pat_dot_term t1, Pat_dot_term t2 -> - equal_opt equal_term t1 t2 - | _ -> false - -and equal_meta m1 m2 = - match m1, m2 with - | Meta_pattern (ts1, args1), Meta_pattern (ts2, args2) -> - equal_list equal_term ts1 ts2 && - equal_list (equal_list equal_arg) args1 args2 - | Meta_named l1, Meta_named l2 -> - Ident.lid_equals l1 l2 - | Meta_labeled (s1, r1, _), Meta_labeled (s2, r2, _) -> - s1 = s2 && - Range.compare r1 r2 = 0 - | Meta_desugared msi1, Meta_desugared msi2 -> - msi1 = msi2 - | Meta_monadic(m1, t1), Meta_monadic(m2, t2) -> - Ident.lid_equals m1 m2 && - equal_term t1 t2 - | Meta_monadic_lift (m1, n1, t1), Meta_monadic_lift (m2, n2, t2) -> - Ident.lid_equals m1 m2 && - Ident.lid_equals n1 n2 && - equal_term t1 t2 - -and equal_lazyinfo l1 l2 = - (* We cannot really compare the blobs. Just try physical - equality (first matching kinds). *) - l1.lkind = l1.lkind && BU.physical_equality l1.blob l2.blob - -and equal_quoteinfo q1 q2 = - q1.qkind = q2.qkind && - (fst q1.antiquotations) = (fst q2.antiquotations) && - equal_list equal_term (snd q1.antiquotations) (snd q2.antiquotations) - -and equal_rc r1 r2 = - Ident.lid_equals r1.residual_effect r2.residual_effect && - equal_opt equal_term r1.residual_typ r2.residual_typ && - equal_list equal_flag r1.residual_flags r2.residual_flags - -and equal_flag f1 f2 = - match f1, f2 with - | DECREASES t1, DECREASES t2 -> - equal_decreases_order t1 t2 - - | _ -> f1 = f2 - -and equal_decreases_order d1 d2 = - match d1, d2 with - | Decreases_lex ts1, Decreases_lex ts2 -> - equal_list equal_term ts1 ts2 - - | Decreases_wf (t1, t1'), Decreases_wf (t2, t2') -> - equal_term t1 t2 && - equal_term t1' t2' - -and equal_arg_qualifier a1 a2 = - a1.aqual_implicit = a2.aqual_implicit && - equal_list equal_term a1.aqual_attributes a2.aqual_attributes - -and equal_lbname l1 l2 = - match l1, l2 with - | Inl b1, Inl b2 -> Ident.ident_equals b1.ppname b2.ppname - | Inr f1, Inr f2 -> Ident.lid_equals f1.fv_name.v f2.fv_name.v - -and equal_subst_elt s1 s2 = - match s1, s2 with - | DB (i1, bv1), DB(i2, bv2) - | NM (bv1, i1), NM (bv2, i2) -> - i1=i2 && equal_bv bv1 bv2 - | NT (bv1, t1), NT (bv2, t2) -> - equal_bv bv1 bv2 && - equal_term t1 t2 - | UN (i1, u1), UN (i2, u2) -> - i1 = i2 && - equal_universe u1 u2 - | UD (un1, i1), UD (un2, i2) -> - i1 = i2 && - Ident.ident_equals un1 un2 - -instance hashable_term : hashable term = { - hash = ext_hash_term; -} diff --git a/src/syntax/FStar.Syntax.Hash.fsti b/src/syntax/FStar.Syntax.Hash.fsti deleted file mode 100644 index 8d4bb8c35e0..00000000000 --- a/src/syntax/FStar.Syntax.Hash.fsti +++ /dev/null @@ -1,33 +0,0 @@ -(* - Copyright 2022 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or impliedmk_ - See the License for the specific language governing permissions and - limitations under the License. - - Author: N. Swamy -*) -module FStar.Syntax.Hash -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.Util -open FStar.Syntax.Syntax -open FStar.Const -module H = FStar.Hash -open FStar.Class.Hashable - -val ext_hash_term (t:term) : H.hash_code -val ext_hash_term_no_memo (t:term) : H.hash_code -val equal_term (t0 t1:term) : bool - -(* uses ext_hash_term (with memo) *) -instance val hashable_term : hashable term diff --git a/src/syntax/FStar.Syntax.InstFV.fst b/src/syntax/FStar.Syntax.InstFV.fst deleted file mode 100644 index 4a9f22fc333..00000000000 --- a/src/syntax/FStar.Syntax.InstFV.fst +++ /dev/null @@ -1,148 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Syntax.InstFV -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Syntax.Syntax -open FStar.Ident -open FStar.Compiler.Util -open FStar.Compiler - -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module U = FStar.Compiler.Util - -let mk t s = S.mk s t.pos - -let rec inst (s:term -> fv -> term) t = - let t = SS.compress t in - let mk = mk t in - match t.n with - | Tm_delayed _ -> failwith "Impossible" - - | Tm_name _ - | Tm_uvar _ - | Tm_uvar _ - | Tm_type _ - | Tm_bvar _ - | Tm_constant _ - | Tm_quoted _ - | Tm_unknown - | Tm_uinst _ -> t - - | Tm_lazy _ -> t - - | Tm_fvar fv -> - s t fv - - | Tm_abs {bs; body; rc_opt=lopt} -> - let bs = inst_binders s bs in - let body = inst s body in - mk (Tm_abs {bs; body; rc_opt=inst_lcomp_opt s lopt}) - - | Tm_arrow {bs; comp=c} -> - let bs = inst_binders s bs in - let c = inst_comp s c in - mk (Tm_arrow {bs; comp=c}) - - | Tm_refine {b=bv; phi=t} -> - let bv = {bv with sort=inst s bv.sort} in - let t = inst s t in - mk (Tm_refine {b=bv; phi=t}) - - | Tm_app {hd=t; args} -> - mk (Tm_app {hd=inst s t; args=inst_args s args}) - - | Tm_match {scrutinee=t; ret_opt=asc_opt; brs=pats; rc_opt=lopt} -> - let pats = pats |> List.map (fun (p, wopt, t) -> - let wopt = match wopt with - | None -> None - | Some w -> Some (inst s w) in - let t = inst s t in - (p, wopt, t)) in - let asc_opt = - match asc_opt with - | None -> None - | Some (b, asc) -> - Some (inst_binder s b, inst_ascription s asc) in - mk (Tm_match {scrutinee=inst s t; - ret_opt=asc_opt; - brs=pats; - rc_opt=inst_lcomp_opt s lopt}) - - | Tm_ascribed {tm=t1; asc; eff_opt=f} -> - mk (Tm_ascribed {tm=inst s t1; asc=inst_ascription s asc; eff_opt=f}) - - | Tm_let {lbs; body=t} -> - let lbs = fst lbs, snd lbs |> List.map (fun lb -> {lb with lbtyp=inst s lb.lbtyp; lbdef=inst s lb.lbdef}) in - mk (Tm_let {lbs; body=inst s t}) - - | Tm_meta {tm=t; meta=Meta_pattern (bvs, args)} -> - mk (Tm_meta {tm=inst s t; meta=Meta_pattern (bvs, args |> List.map (inst_args s))}) - - | Tm_meta {tm=t; meta=Meta_monadic (m, t')} -> - mk (Tm_meta {tm=inst s t; meta=Meta_monadic(m, inst s t')}) - - | Tm_meta {tm=t; meta=tag} -> - mk (Tm_meta {tm=inst s t; meta=tag}) - -and inst_binder s b = - { b with - binder_bv = { b.binder_bv with sort = inst s b.binder_bv.sort }; - binder_attrs = b.binder_attrs |> List.map (inst s) } - -and inst_binders s bs = bs |> List.map (inst_binder s) - -and inst_args s args = args |> List.map (fun (a, imp) -> inst s a, imp) - -and inst_comp s c = match c.n with - | Total t -> S.mk_Total (inst s t) - | GTotal t -> S.mk_GTotal (inst s t) - | Comp ct -> let ct = {ct with result_typ=inst s ct.result_typ; - effect_args=inst_args s ct.effect_args; - flags=ct.flags |> List.map (function - | DECREASES dec_order -> - DECREASES (inst_decreases_order s dec_order) - | f -> f)} in - S.mk_Comp ct - -and inst_decreases_order s = function - | Decreases_lex l -> Decreases_lex (l |> List.map (inst s)) - | Decreases_wf (rel, e) -> Decreases_wf (inst s rel, inst s e) - -and inst_lcomp_opt s l = match l with - | None -> None - | Some rc -> Some ({rc with residual_typ = FStar.Compiler.Util.map_opt rc.residual_typ (inst s)}) - -and inst_ascription s (asc:ascription) = - let annot, topt, use_eq = asc in - let annot = - match annot with - | Inl t -> Inl (inst s t) - | Inr c -> Inr (inst_comp s c) in - let topt = FStar.Compiler.Util.map_opt topt (inst s) in - annot, topt, use_eq - -let instantiate i t = match i with - | [] -> t - | _ -> - let inst_fv (t: term) (fv: S.fv) : term = - begin match U.find_opt (fun (x, _) -> lid_equals x fv.fv_name.v) i with - | None -> t - | Some (_, us) -> mk t (Tm_uinst(t, us)) - end - in - inst inst_fv t diff --git a/src/syntax/FStar.Syntax.InstFV.fsti b/src/syntax/FStar.Syntax.InstFV.fsti deleted file mode 100644 index 711324ca93b..00000000000 --- a/src/syntax/FStar.Syntax.InstFV.fsti +++ /dev/null @@ -1,23 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Syntax.InstFV -open FStar.Compiler.Effect -open FStar.Syntax.Syntax -open FStar.Ident -type inst_t = list (lident & universes) -val inst: (term -> fv -> term) -> term -> term -val inst_binders: (term -> fv -> term) -> binders -> binders -val instantiate: inst_t -> term -> term diff --git a/src/syntax/FStar.Syntax.MutRecTy.fst b/src/syntax/FStar.Syntax.MutRecTy.fst deleted file mode 100644 index cee70efd725..00000000000 --- a/src/syntax/FStar.Syntax.MutRecTy.fst +++ /dev/null @@ -1,247 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Syntax.MutRecTy -open FStar -open FStar.Compiler -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Syntax.Syntax -open FStar.Ident -open FStar.Compiler.Util -open FStar.Errors -open FStar.Syntax.InstFV -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module U = FStar.Compiler.Util - - - - -(* Given a list of bundled type declarations potentially with type - abbreviations, construct the new bundle without type abbreviations - or lets (where they have been all unfolded) and the list of type - abbreviations or lets separated away from the bundle (and sorted in - dependency order, in such a way that they are no longer mutually - recursive.) *) - -let disentangle_abbrevs_from_bundle - (sigelts: list sigelt) - (quals: list qualifier) - (members: list lident) - (rng: FStar.Compiler.Range.range) - : sigelt & list sigelt = - - (* NS: Attributes on the type constructors and abbreviation are gathered, - and placed on the bundle. - Attributes on the data constructors do not propagate to the bundle. *) - let sigattrs = - List.collect - (fun s -> - match s.sigel with - | Sig_inductive_typ _ - | Sig_let _ -> s.sigattrs - | _ -> []) - sigelts - in - let sigattrs = FStar.Syntax.Util.deduplicate_terms sigattrs in - - (* Gather the list of type abbrevs *) - let type_abbrev_sigelts = sigelts |> List.collect begin fun x -> match x.sigel with - | Sig_let {lbs=(false, [ { lbname= Inr _ } ])} -> [x] - | Sig_let _ -> - failwith "mutrecty: disentangle_abbrevs_from_bundle: type_abbrev_sigelts: impossible" - | _ -> [] - end - in - - match type_abbrev_sigelts with - | [] -> - (* if there are no type abbreviations, then do not change anything. *) - { sigel = Sig_bundle {ses=sigelts; lids=members}; - sigrng = rng; - sigquals = quals; - sigmeta = default_sigmeta; - sigattrs = sigattrs; - sigopts = None; - sigopens_and_abbrevs = [] }, [] - | _ -> - - let type_abbrevs = type_abbrev_sigelts |> List.map begin fun x -> match x.sigel with - | Sig_let {lbs=(_, [ { lbname = Inr fv } ] )} -> fv.fv_name.v - | _ -> failwith "mutrecty: disentangle_abbrevs_from_bundle: type_abbrevs: impossible" - end - in - - (* First, unfold type abbrevs among themselves *) - let unfolded_type_abbrevs = - - (* List of type abbreviations that have been unfolded, in - reverse order (from most recent to most ancient: the head - depends on the tail.) *) - let rev_unfolded_type_abbrevs : ref (list sigelt) = U.mk_ref [] in - - (* List of names of type abbreviations whose unfolding has - started. If they occur during renaming of the current type - abbreviation, then there is a cycle. Follows a stack - discipline. *) - let in_progress : ref (list lident) = U.mk_ref [] in - - (* List of type abbreviations that have not been unfolded - yet. Their order can change, since anyway they will be - reordered after being unfolded. *) - let not_unfolded_yet = U.mk_ref type_abbrev_sigelts in - - let remove_not_unfolded lid = - not_unfolded_yet := !not_unfolded_yet |> List.filter begin fun x -> match x.sigel with - | Sig_let {lbs=(_, [ { lbname = Inr fv } ] )} -> - not (lid_equals lid fv.fv_name.v) - | _ -> true - end - in - - (* Replace a free variable corresponding to a type - abbreviation, with memoization. *) - let rec unfold_abbrev_fv (t: term) (fv : S.fv) : term = - let replacee (x: sigelt) = match x.sigel with - | Sig_let {lbs=(_, [ { lbname = Inr fv' } ] )} - when lid_equals fv'.fv_name.v fv.fv_name.v -> - Some x - | _ -> None - in - let replacee_term (x: sigelt) = match replacee x with - | Some { sigel = Sig_let {lbs=(_, [ { lbdef = tm } ] )} } -> Some tm - | _ -> None - in - match U.find_map !rev_unfolded_type_abbrevs replacee_term with - | Some x -> x - | None -> - begin match U.find_map type_abbrev_sigelts replacee with - | Some se -> - if FStar.Compiler.List.existsb (fun x -> lid_equals x fv.fv_name.v) !in_progress - then let msg = U.format1 "Cycle on %s in mutually recursive type abbreviations" (string_of_lid fv.fv_name.v) in - raise_error fv.fv_name.v Errors.Fatal_CycleInRecTypeAbbreviation msg - else unfold_abbrev se - | _ -> t - end - - (* Start unfolding in a type abbreviation that has not occurred before. *) - and unfold_abbrev (x: sigelt) = match x.sigel with - | Sig_let {lbs=(false, [lb])} -> - (* eliminate some qualifiers for definitions *) - let quals = x.sigquals |> List.filter begin function - | Noeq -> false - | _ -> true - end in - let lid = match lb.lbname with - | Inr fv -> fv.fv_name.v - | _ -> failwith "mutrecty: disentangle_abbrevs_from_bundle: rename_abbrev: lid: impossible" - in - let () = in_progress := lid :: !in_progress in (* push *) - let () = remove_not_unfolded lid in - let ty' = inst unfold_abbrev_fv lb.lbtyp in - let tm' = inst unfold_abbrev_fv lb.lbdef in - let lb' = { lb with lbtyp = ty' ; lbdef = tm' } in - let sigelt' = Sig_let {lbs=(false, [lb']); lids=[lid]} in - let () = rev_unfolded_type_abbrevs := { x with sigel = sigelt'; sigquals = quals } :: !rev_unfolded_type_abbrevs in - let () = in_progress := List.tl !in_progress in (* pop *) - tm' - | _ -> failwith "mutrecty: disentangle_abbrevs_from_bundle: rename_abbrev: impossible" - in - - let rec aux () = match !not_unfolded_yet with - | x :: _ -> let _unused = unfold_abbrev x in aux () - | _ -> List.rev !rev_unfolded_type_abbrevs - - in - - aux () - in - - (* Now, unfold in inductive types and data constructors *) - - let filter_out_type_abbrevs l = - List.filter (fun lid -> FStar.Compiler.List.for_all (fun lid' -> not (lid_equals lid lid')) type_abbrevs) l - in - - let inductives_with_abbrevs_unfolded = - - let find_in_unfolded fv = U.find_map unfolded_type_abbrevs begin fun x -> match x.sigel with - | Sig_let {lbs=(_, [ { lbname = Inr fv' ; lbdef = tm } ] )} when (lid_equals fv'.fv_name.v fv.fv_name.v) -> - Some tm - | _ -> None - end - in - - let unfold_fv (t: term) (fv: S.fv) : term = match find_in_unfolded fv with - | Some t' -> t' - | _ -> t - in - - let unfold_in_sig (x: sigelt) = match x.sigel with - | Sig_inductive_typ {lid; us=univs; params=bnd; - num_uniform_params=num_uniform; - t=ty; mutuals=mut; ds=dc; - injective_type_params } -> - let bnd' = inst_binders unfold_fv bnd in - let ty' = inst unfold_fv ty in - let mut' = filter_out_type_abbrevs mut in - [{ x with sigel = Sig_inductive_typ {lid=lid; - us=univs; - params=bnd'; - num_uniform_params=num_uniform; - t=ty'; - mutuals=mut'; - ds=dc; - injective_type_params } }] - - | Sig_datacon {lid; us=univs; t=ty; ty_lid=res; - num_ty_params=npars; mutuals=mut; - injective_type_params } -> - let ty' = inst unfold_fv ty in - let mut' = filter_out_type_abbrevs mut in - [{ x with sigel = Sig_datacon {lid; - us=univs; - t=ty'; - ty_lid=res; - num_ty_params=npars; - mutuals=mut'; - injective_type_params } }] - - | Sig_let _ -> - [] - - | _ -> failwith "mutrecty: inductives_with_abbrevs_unfolded: unfold_in_sig: impossible" - in - - List.collect unfold_in_sig sigelts - in - - (* Finally, construct a new bundle separate from type abbrevs *) - - let new_members = filter_out_type_abbrevs members - in - - let new_bundle = { sigel = Sig_bundle {ses=inductives_with_abbrevs_unfolded; lids=new_members}; - sigrng = rng; - sigquals = quals; - sigmeta = default_sigmeta; - sigattrs = sigattrs; - sigopts = None; - sigopens_and_abbrevs = [] } - in - - (new_bundle, unfolded_type_abbrevs) diff --git a/src/syntax/FStar.Syntax.MutRecTy.fsti b/src/syntax/FStar.Syntax.MutRecTy.fsti deleted file mode 100644 index 4dcb26fbdeb..00000000000 --- a/src/syntax/FStar.Syntax.MutRecTy.fsti +++ /dev/null @@ -1,23 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -// (c) Microsoft Corporation. All rights reserved -module FStar.Syntax.MutRecTy -open FStar.Compiler.Effect -open FStar.Syntax.Syntax -open FStar.Ident - -val disentangle_abbrevs_from_bundle: list sigelt -> list qualifier -> list lident -> - FStar.Compiler.Range.range -> sigelt & list sigelt diff --git a/src/syntax/FStar.Syntax.Resugar.fst b/src/syntax/FStar.Syntax.Resugar.fst deleted file mode 100644 index 8bae037ff93..00000000000 --- a/src/syntax/FStar.Syntax.Resugar.fst +++ /dev/null @@ -1,1629 +0,0 @@ -(* - Copyright 2008-2014 Microsoft Research - - Authors: Qunyan Mangus, Nikhil Swamy - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Syntax.Resugar //we should rename FStar.ToSyntax to something else -open FStar -open FStar.Compiler -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Syntax.Syntax -open FStar.Ident -open FStar.Compiler.Util -open FStar.Const -open FStar.Compiler.List -open FStar.Parser.AST -open FStar.Class.Monad -open FStar.Class.Setlike -open FStar.Class.Show - -module I = FStar.Ident -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module A = FStar.Parser.AST -module C = FStar.Parser.Const -module U = FStar.Syntax.Util -module BU = FStar.Compiler.Util -module D = FStar.Parser.ToDocument -module UF = FStar.Syntax.Unionfind -module E = FStar.Errors -module DsEnv = FStar.Syntax.DsEnv - -(* Helpers to print/debug the resugaring phase *) -let doc_to_string doc = FStar.Pprint.pretty_string (float_of_string "1.0") 100 doc -let parser_term_to_string t = doc_to_string (D.term_to_document t) -let parser_pat_to_string t = doc_to_string (D.pat_to_document t) - -(* A callback into FStar.Syntax.show. Careful, it's mutually recursive - * with this module and could loop, so only use it for debugging. *) -let tts (t:S.term) : string = U.tts t - -let map_opt = List.filter_map - -let bv_as_unique_ident (x:S.bv) : I.ident = - let unique_name = - if starts_with reserved_prefix (string_of_id x.ppname) - || Options.print_real_names () then - (string_of_id x.ppname) ^ (string_of_int x.index) - else - (string_of_id x.ppname) - in - I.mk_ident (unique_name, (range_of_id x.ppname)) - -(* true if argument is implicit and should be filtered without --print_implicits. -Typeclass args are not considered implicit for printing. *) -let is_imp_bqual a = - match a with - | Some (S.Meta t) when U.is_fvar C.tcresolve_lid t -> false - | Some (S.Implicit _) - | Some (S.Meta _) -> true - | _ -> false - -let no_imp_args (args:S.args) : S.args = - args |> List.filter (function (_, None) -> true | (_, Some arg) -> not (arg.aqual_implicit)) - -let no_imp_bs bs = - bs |> List.filter (fun b -> not (is_imp_bqual b.binder_qual)) - -let filter_imp_args (args:S.args) : S.args = - if Options.print_implicits () - then args - else no_imp_args args - -let filter_imp_bs bs = - if Options.print_implicits () - then bs - else no_imp_bs bs - -let filter_pattern_imp xs = - if Options.print_implicits () - then xs - else List.filter (fun (_, is_implicit) -> not is_implicit) xs - -let label s t = - if s = "" then t - else A.mk_term (A.Labeled (t,s,true)) t.range A.Un - -let rec universe_to_int n u = - match Subst.compress_univ u with - | U_succ u -> universe_to_int (n+1) u - | _ -> (n, u) - -let universe_to_string univs = - if (Options.print_universes()) then - List.map (fun x -> (string_of_id x)) univs |> String.concat ", " - else "" - -let rec resugar_universe (u:S.universe) r: A.term = - let mk (a:A.term') r: A.term = - //augment `a` an Unknown level (the level is unimportant ... we should maybe remove it altogether) - A.mk_term a r A.Un - in - let u = Subst.compress_univ u in - begin match u with - | U_zero -> - mk (A.Const(Const_int ("0", None))) r - - | U_succ _ -> - let (n, u) = universe_to_int 0 u in - begin match u with - | U_zero -> - mk (A.Const(Const_int(string_of_int n, None))) r - - | _ -> - let e1 = mk (A.Const(Const_int(string_of_int n, None))) r in - let e2 = resugar_universe u r in - mk (A.Op(Ident.id_of_text "+", [e1; e2])) r - end - - | U_max l -> - begin match l with - | [] -> failwith "Impossible: U_max without arguments" - | _ -> - let t = mk (A.Var(lid_of_path ["max"] r)) r in - List.fold_left(fun acc x -> mk (A.App(acc, resugar_universe x r, A.Nothing)) r) t l - end - - | U_name u -> mk (A.Uvar(u)) r - | U_unif _ -> mk A.Wild r - | U_bvar x -> - (* This case can happen when trying to print a subterm of a term that is not opened.*) - let id = I.mk_ident (strcat "uu__univ_bvar_" (string_of_int x), r) in - mk (A.Uvar(id)) r - - | U_unknown -> mk A.Wild r (* not sure what to resugar to since it is not created by desugar *) - end - -// resugar_universe' included for consistency (it doesn't use its environment) -let resugar_universe' (env: DsEnv.env) (u:S.universe) r: A.term = - resugar_universe u r - -type expected_arity = option int - -(* GM: This almost never actually returns an expected arity. It does so -only for subtraction, I think. *) -let rec resugar_term_as_op (t:S.term) : option (string&expected_arity) = - let infix_prim_ops = [ - (C.op_Addition , "+" ); - (C.op_Subtraction , "-" ); - (C.op_Minus , "-" ); - (C.op_Multiply , "*" ); - (C.op_Division , "/" ); - (C.op_Modulus , "%" ); - (C.read_lid , "!" ); - (C.list_append_lid, "@" ); - (C.list_tot_append_lid,"@"); - (C.op_Eq , "=" ); - (C.op_ColonEq , ":="); - (C.op_notEq , "<>"); - (C.not_lid , "~" ); - (C.op_And , "&&"); - (C.op_Or , "||"); - (C.op_LTE , "<="); - (C.op_GTE , ">="); - (C.op_LT , "<" ); - (C.op_GT , ">" ); - (C.op_Modulus , "mod"); - (C.and_lid , "/\\"); - (C.or_lid , "\\/"); - (C.imp_lid , "==>"); - (C.iff_lid , "<==>"); - (C.precedes_lid, "<<"); - (C.eq2_lid , "=="); - (C.forall_lid , "forall"); - (C.exists_lid , "exists"); - (C.salloc_lid , "alloc"); - (C.calc_finish_lid, "calc_finish"); - ] in - let fallback fv = - match infix_prim_ops |> BU.find_opt (fun d -> fv_eq_lid fv (fst d)) with - | Some op -> - Some (snd op, None) - | _ -> - let length = String.length (nsstr fv.fv_name.v) in - let str = if length=0 then (string_of_lid fv.fv_name.v) - else BU.substring_from (string_of_lid fv.fv_name.v) (length+1) in - (* Check that it is of the shape dtuple int, and return that arity *) - if BU.starts_with str "dtuple" - && Option.isSome (BU.safe_int_of_string (BU.substring_from str 6)) - then Some ("dtuple", BU.safe_int_of_string (BU.substring_from str 6)) - else if BU.starts_with str "tuple" - && Option.isSome (BU.safe_int_of_string (BU.substring_from str 5)) - then Some ("tuple", BU.safe_int_of_string (BU.substring_from str 5)) - else if BU.starts_with str "try_with" then Some ("try_with", None) - else if fv_eq_lid fv C.sread_lid then Some (string_of_lid fv.fv_name.v, None) - else None - in - match (SS.compress t).n with - | Tm_fvar fv -> - let length = String.length (nsstr fv.fv_name.v) in - let s = if length=0 then string_of_lid fv.fv_name.v - else BU.substring_from (string_of_lid fv.fv_name.v) (length+1) in - begin match string_to_op s with - | Some t -> Some t - | _ -> fallback fv - end - | Tm_uinst(e, us) -> - resugar_term_as_op e - | _ -> None - -let is_true_pat (p:S.pat) : bool = match p.v with - | Pat_constant (Const_bool true) -> true - | _ -> false - -let is_tuple_constructor_lid lid = - C.is_tuple_data_lid' lid - || C.is_dtuple_data_lid' lid - -let may_shorten lid = - if Options.print_real_names () then false - else - match string_of_lid lid with - | "Prims.Nil" - | "Prims.Cons" -> false - | _ -> not (is_tuple_constructor_lid lid) - -let maybe_shorten_lid env lid : lident = - if may_shorten lid then DsEnv.shorten_lid env lid else lid - -let maybe_shorten_fv env fv : lident = - let lid = fv.fv_name.v in - maybe_shorten_lid env lid - -(* Sizet handled below *) -let serialize_machine_integer_desc (s,w) : list string = - let sU = match s with | Unsigned -> "U" | Signed -> "" in - let sW = - match w with - | Int8 -> "8" - | Int16 -> "16" - | Int32 -> "32" - | Int64 -> "64" - in - let su = match s with | Unsigned -> "u" | Signed -> "" in - [ BU.format3 "FStar.%sInt%s.__%sint_to_t" sU sW su; - BU.format3 "FStar.%sInt%s.%sint_to_t" sU sW su ] - -let parse_machine_integer_desc = - let signs = [Unsigned; Signed] in - let widths = [Int8; Int16; Int32; Int64] in - let descs = - ((Unsigned, Sizet), "FStar.SizeT.__uint_to_t") :: - (let! s = signs in - let! w = widths in - let! desc = serialize_machine_integer_desc (s, w) in - [((s, w), desc)]) - in - fun (fv:fv) -> - List.tryFind (fun (_, d) -> d = Ident.string_of_lid (lid_of_fv fv)) descs - -let can_resugar_machine_integer_fv fv = - Option.isSome (parse_machine_integer_desc fv) - -let resugar_machine_integer fv (i:string) pos = - match parse_machine_integer_desc fv with - | None -> failwith "Impossible: should be guarded by can_resugar_machine_integer" - | Some (sw, _) -> A.mk_term (A.Const (Const_int(i, Some sw))) pos A.Un - -let rec __is_list_literal cons_lid nil_lid (t:S.term) : option (list S.term) = - let open FStar.Class.Monad in - let hd, args = U.head_and_args_full t in - let hd = hd |> U.un_uinst |> SS.compress in - let args = args |> filter_imp_args in - match hd.n, args with - | Tm_fvar fv, [(hd, None); (tl, None)] when fv_eq_lid fv cons_lid -> - let! tl = __is_list_literal cons_lid nil_lid tl in - return (hd :: tl) - | Tm_fvar fv, [] when fv_eq_lid fv nil_lid -> - return [] - | _, _ -> - None - -let is_list_literal = __is_list_literal C.cons_lid C.nil_lid -let is_seq_literal = __is_list_literal C.seq_cons_lid C.seq_empty_lid - -let can_resugar_machine_integer (hd : S.term) (args : S.args) : option (fv & string) = - match (SS.compress hd).n with - | Tm_fvar fv when can_resugar_machine_integer_fv fv -> ( - match args with - | [(a, None)] -> ( - match (SS.compress a).n with - | Tm_constant (Const_int (i, None)) -> - Some (fv, i) - | _ -> None - ) - | _ -> None - ) - | _ -> None - -let rec resugar_term' (env: DsEnv.env) (t : S.term) : A.term = - (* Cannot resugar term back to NamedTyp or Paren *) - let mk (a:A.term') : A.term = - //augment `a` with its source position - //and an Unknown level (the level is unimportant ... we should maybe remove it altogether) - A.mk_term a t.pos A.Un - in - let name a r = - // make a Name term' - A.Name (lid_of_path [a] r) - in - match (SS.compress t).n with //always call compress before case-analyzing a S.term - | Tm_delayed _ -> - failwith "Tm_delayed is impossible after compress" - - | Tm_lazy i -> - resugar_term' env (U.unfold_lazy i) - - | Tm_bvar x -> - (* this case can happen when printing a subterm of a term that is not opened *) - let l = FStar.Ident.lid_of_ids [bv_as_unique_ident x] in - mk (A.Var l) - - | Tm_name x -> //a lower-case identifier - //this is is too simplistic - //the resulting unique_name is very ugly - //it would be better to try to use x.ppname alone, unless the suffix is deemed semantically necessary - let l = FStar.Ident.lid_of_ids [bv_as_unique_ident x] in - mk (A.Var l) - - | Tm_fvar fv -> //a top-level identifier, may be lowercase or upper case - //should be A.Var if lowercase - //and A.Name if uppercase - let a = fv.fv_name.v in - let length = String.length (nsstr fv.fv_name.v) in - let s = if length=0 then string_of_lid a - else BU.substring_from (string_of_lid a) (length+1) in - let is_prefix = I.reserved_prefix ^ "is_" in - if BU.starts_with s is_prefix then - let rest = BU.substring_from s (String.length is_prefix) in - mk (A.Discrim(lid_of_path [rest] t.pos)) - else if BU.starts_with s U.field_projector_prefix then - let rest = BU.substring_from s (String.length U.field_projector_prefix) in - let r = BU.split rest U.field_projector_sep in - begin match r with - | [fst; snd] -> - let l = lid_of_path [fst] t.pos in - let r = I.mk_ident (snd, t.pos) in - mk (A.Projector(l, r )) - | _ -> - failwith "wrong projector format" - end - else if (lid_equals a C.smtpat_lid) then - mk (A.Tvar (I.mk_ident ("SMTPat", I.range_of_lid a))) - else if (lid_equals a C.smtpatOr_lid) then - mk (A.Tvar (I.mk_ident ("SMTPatOr", I.range_of_lid a))) - else if (lid_equals a C.assert_lid || lid_equals a C.assume_lid - || Char.uppercase (String.get s 0) <> String.get s 0) then - mk (A.Var (maybe_shorten_fv env fv)) - else // FIXME check in environment instead of checking case - mk (A.Construct (maybe_shorten_fv env fv, [])) - - | Tm_uinst(e, universes) -> - let e = resugar_term' env e in - if Options.print_universes() then - let univs = List.map (fun x -> resugar_universe x t.pos) universes in - match e with - | { tm = A.Construct (hd, args); range = r; level = l } -> - let args = args @ (List.map (fun u -> (u, A.UnivApp)) univs) in - A.mk_term (A.Construct (hd, args)) r l - | _ -> - List.fold_left (fun acc u -> mk (A.App (acc, u, A.UnivApp))) e univs - else - e - - | Tm_constant c -> - if is_teff t - then mk (name "Effect" t.pos) - else mk (A.Const c) - - | Tm_type u -> - let nm, needs_app = - match u with - | U_zero -> "Type0", false - | U_unknown -> "Type", false - | _ -> "Type", true in - let typ = mk (name nm t.pos) in - if needs_app && Options.print_universes () - then mk (A.App (typ, resugar_universe u t.pos, UnivApp)) - else typ - - | Tm_abs {bs=xs; body} -> //fun x1 .. xn -> body - //before inspecting any syntactic form that has binding structure - //you must call SS.open_* to replace de Bruijn indexes with names - let xs, body = SS.open_term xs body in - let xs = filter_imp_bs xs in - let body_bv = FStar.Syntax.Free.names body in - let patterns = xs |> List.map (fun x -> - //x.sort contains a type annotation for the bound variable - //the pattern `p` below only contains the variable, not the annotation - //but, if the user wrote the annotation, then we should record that and print it back - //additionally, if we're in verbose mode, e.g., if --print_bound_var_types is set - // then we should print the annotation too - resugar_bv_as_pat env x.binder_bv x.binder_qual body_bv) - in - let body = resugar_term' env body in - (* If no binders/patterns remain after filtering, drop the Abs node *) - if List.isEmpty patterns - then body - else mk (A.Abs(patterns, body)) - - | Tm_arrow _ -> - (* Flatten the arrow *) - let xs, body = - match (SS.compress (U.canon_arrow t)).n with - | Tm_arrow {bs=xs; comp=body} -> xs, body - | _ -> failwith "impossible: Tm_arrow in resugar_term" - in - let xs, body = SS.open_comp xs body in - let xs = filter_imp_bs xs in - let body = resugar_comp' env body in - let xs = xs |> map (fun b -> resugar_binder' env b t.pos) |> List.rev in - let rec aux body = function - | [] -> body - | hd::tl -> - let body = mk (A.Product([hd], body)) in - aux body tl in - aux body xs - - | Tm_refine {b=x; phi} -> - (* bv * term -> binder * term *) - let x, phi = SS.open_term [S.mk_binder x] phi in - let b = resugar_binder' env (List.hd x) t.pos in - mk (A.Refine(b, resugar_term' env phi)) - - (* Drop b2t unless --print_implicits() *) - | Tm_app {hd={n=Tm_fvar fv}; args=[(e, _)]} - when not (Options.print_implicits()) - && S.fv_eq_lid fv C.b2t_lid -> - resugar_term' env e - - | Tm_app {hd; args} - when Some? (can_resugar_machine_integer hd args) -> - let Some (fv, i) = can_resugar_machine_integer hd args in - resugar_machine_integer fv i t.pos - - | Tm_app _ -> - let t = U.canon_app t in - let Tm_app {hd=e; args} = t.n in - let is_hide_or_reveal e = - match U.un_uinst e with - | {n=Tm_fvar fv} -> - S.fv_eq_lid fv C.hide || S.fv_eq_lid fv C.reveal - | _ -> false - in - (* NB: This cannot fail since U.canon_app constructs a Tm_app. *) - - (* Op("=!=", args) is desugared into Op("~", Op("==") and not resugared back as "=!=" *) - let rec last = function - | hd :: [] -> [hd] - | hd :: tl -> last tl - | _ -> failwith "last of an empty list" - in - let first_two_explicit args = - let rec drop_implicits args = - match args with - | (_, Some ({aqual_implicit=true}))::tl -> drop_implicits tl - | _ -> args - in - match drop_implicits args with - | [] - | [_] -> failwith "not_enough explicit_arguments" - | a1::a2::_ -> [a1;a2] - in - let resugar_as_app e args = - let args = - List.map (fun (e, qual) -> (resugar_term' env e, resugar_aqual env qual)) args in - match resugar_term' env e with - | { tm = A.Construct (hd, previous_args); range = r; level = l } -> - A.mk_term (A.Construct (hd, previous_args @ args)) r l - | e -> - List.fold_left (fun acc (x, qual) -> mk (A.App (acc, x, qual))) e args - in - let args = filter_imp_args args in - - let is_projector (t:S.term) : option (lident & ident) = - (* Detect projectors and resugar them as t.x instead of Mkt?.x t *) - match (U.un_uinst (SS.compress t)).n with - | Tm_fvar fv -> - let a = fv.fv_name.v in - let length = String.length (nsstr fv.fv_name.v) in - let s = if length=0 then string_of_lid a - else BU.substring_from (string_of_lid a) (length+1) in - if BU.starts_with s U.field_projector_prefix then - let rest = BU.substring_from s (String.length U.field_projector_prefix) in - let r = BU.split rest U.field_projector_sep in - begin match r with - | [fst; snd] -> - let l = lid_of_path [fst] t.pos in - let r = I.mk_ident (snd, t.pos) in - Some (l, r) - | _ -> - failwith "wrong projector format" - end - else None - | _ -> None - in - (* We have a projector, applied to at least one argument, and the first argument - is explicit (so not one of the parameters of the type). In this case we resugar nicely. *) - if Some? (is_projector e) && List.length args >= 1 && None? (snd (List.hd args)) then - let arg1 :: rest_args = args in - let (_, fi) = Some?.v (is_projector e) in - let arg = resugar_term' env (fst arg1) in - let h = mk <| Project (arg, Ident.lid_of_ids [fi]) in - (* Add remaining args if any. *) - rest_args |> List.fold_left (fun acc (a, q) -> - let aa = resugar_term' env a in - let qq = resugar_aqual env q in - mk (A.App (acc, aa, qq))) - h - else if not (Options.print_implicits ()) - && Options.Ext.get "show_hide_reveal" = "" - && is_hide_or_reveal e - && List.length args = 1 //args already filtered - then ( - let [(e, _)] = args in - resugar_term' env e - ) - else - let unsnoc (#a:Type) (l : list a) : (list a & a) = - let rec unsnoc' acc = function - | [] -> failwith "unsnoc: empty list" - | [x] -> (List.rev acc, x) - | x::xs -> unsnoc' (x::acc) xs - in - unsnoc' [] l - in - let resugar_tuple_type env (args : S.args) : A.term = - let typs = args |> List.map (fun (x,_) -> resugar_term' env x) in - let pre, last = unsnoc typs in - mk (A.Sum (List.map Inr pre, last)) - in - let resugar_dtuple_type env (hd:S.term) (args : S.args) : A.term = - (* We will resugar a dtuple type like: - - dtuple3 int (fun i -> vector i) (fun i v -> vec_ok i v) - - as - (i : int & v : vector i & vec_ok i v) - - but only if every component is a lambda of that shape, defaulting - back to just an appication of dtupleN if not. *) - let fancy_resugar () : option A.term = - let open FStar.Class.Monad in - let n = List.length args in - let take (#a:Type) (n:int) (l : list a) : list a = - List.splitAt n l |> fst - in - let bs, _, _ = U.abs_formals (fst <| List.last args) in - if List.length bs < n-1 then ( - (* This can definitely happen: we could have (dtuple2 int p) where p - is some int function, for example. In that case, we abort. *) - None - ) else Some ();! - let bs = take (n-1) bs in (* make sure to not take too many, shouldn't happen for anything well-typed but we do not know that *) - let concatM (#a:Type) (#m:Type -> Type) {| monad m |} - (l : list (m a)) : m (list a) = mapM id l - in - let rec open_lambda_binders (t : S.term) (bs: list S.binder) : option S.term = - match bs with - | [] -> Some t - | b::bs -> - let! (_, body) = U.abs_one_ln t in - let _, body = SS.open_term [b] body in - open_lambda_binders body bs - in - let! opened_bs_types : list S.term = - args |> mapMi (fun i (t, _) -> - open_lambda_binders t (take i bs)) - in - let set_binder_sort t b = - { b with binder_bv = { b.binder_bv with sort = t } } - in - let pre_bs_types, last_type = unsnoc opened_bs_types in - let bs = List.map2 (fun b t -> - let b = set_binder_sort t b in - resugar_binder' env b t.pos) - bs pre_bs_types - in - Some <| mk (A.Sum (List.map Inl bs, resugar_term' env last_type)) - in - match fancy_resugar () with - | Some r -> r - | None -> resugar_as_app hd args - in - begin match is_list_literal t with - | Some ts -> mk (A.ListLiteral (List.map (resugar_term' env) ts)) - | None -> - match is_seq_literal t with - | Some ts -> mk (A.SeqLiteral (List.map (resugar_term' env) ts)) - | None -> - match resugar_term_as_op e with - | None-> - resugar_as_app e args - - | Some ("calc_finish", _) -> - begin match resugar_calc env t with - | Some r -> r - | _ -> resugar_as_app e args - end - - | Some ("tuple", n) when Some (List.length args <: int) = n -> - resugar_tuple_type env args - - | Some ("dtuple", n) when Some (List.length args <: int) = n -> - resugar_dtuple_type env e args - - | Some (ref_read, _) when (ref_read = string_of_lid C.sread_lid) -> - let (t, _) = List.hd args in - begin match (SS.compress t).n with - | Tm_fvar fv when (U.field_projector_contains_constructor (string_of_lid fv.fv_name.v)) -> - let f = lid_of_path [string_of_lid fv.fv_name.v] t.pos in - mk (A.Project(resugar_term' env t, f)) - | _ -> resugar_term' env t - end - - | Some ("try_with", _) when List.length args > 1 -> - (* attempt to resugar as `try .. with | ...`, but otherwise just resugar normally *) - begin try - (* only the first two explicit args are from original AST terms, - * others are added by typechecker *) - (* TODO: we need a place to store the information in the args added by the typechecker *) - let new_args = first_two_explicit args in - let body, handler = match new_args with - | [(a1, _);(a2, _)] -> a1, a2 (* where a1 and a1 is Tm_abs(Tm_match)) *) - | _ -> - failwith("wrong arguments to try_with") - in - let decomp term = match (SS.compress term).n with - | Tm_abs {bs=x; body=e} -> - let x, e = SS.open_term x e in - e - | _ -> failwith("wrong argument format to try_with: " ^ term_to_string (resugar_term' env term)) in - let body = resugar_term' env (decomp body) in - let handler = resugar_term' env (decomp handler) in - let rec resugar_body t = match (t.tm) with - | A.Match(e, None, None, [(_,_,b)]) -> b - | A.Let(_, _, b) -> b // One branch Match that is resugared as Let - | A.Ascribed(t1, t2, t3, use_eq) -> - (* this case happens when the match is wrapped in Meta_Monadic which is resugared to Ascribe*) - mk (A.Ascribed(resugar_body t1, t2, t3, use_eq)) - | _ -> failwith("unexpected body format to try_with") in - let e = resugar_body body in - let rec resugar_branches t = match (t.tm) with - | A.Match(e, None, None, branches) -> branches - | A.Ascribed(t1, t2, t3, _) -> - (* this case happens when the match is wrapped in Meta_Monadic which is resugared to Ascribe*) - (* TODO: where should we keep the information stored in Ascribed? *) - resugar_branches t1 - | _ -> - (* TODO: forall created by close_forall doesn't follow the normal forall format, not sure how to resugar back *) - [] - in - let branches = resugar_branches handler in - mk (A.TryWith(e, branches)) - with - | _ -> - resugar_as_app e args - end - - | Some ("try_with", _) -> - resugar_as_app e args - - (* These have implicits, don't do the fancy printing when --print_implicits is on *) - | Some (op, _) when (op = "=" - || op = "==" - || op = "===" - || op = "@" - || op = ":=" - || op = "|>" - || op = "<<") - && Options.print_implicits () -> - resugar_as_app e args - - | Some (op, _) - when starts_with op "forall" - || starts_with op "exists" -> - (* desugared from QForall(binders * patterns * body) to Tm_app(forall, Tm_abs(binders, Tm_meta(body, meta_pattern(list args)*) - let rec uncurry xs pats (t:A.term) flavor_matches = - match t.tm with - | A.QExists(xs', (_, pats'), body) - | A.QForall(xs', (_, pats'), body) - | A.QuantOp(_, xs', (_, pats'), body) when flavor_matches t -> - uncurry (xs@xs') (pats@pats') body flavor_matches - | _ -> - xs, pats, t - in - let resugar_forall_body body = match (SS.compress body).n with - | Tm_abs {bs=xs; body} -> - let xs, body = SS.open_term xs body in - let xs = filter_imp_bs xs in - let xs = xs |> map (fun b -> resugar_binder' env b t.pos) in - let pats, body = match (SS.compress body).n with - | Tm_meta {tm=e; meta=m} -> - let body = resugar_term' env e in - let pats, body = match m with - | Meta_pattern (_, pats) -> - List.map (fun es -> es |> List.map (fun (e, _) -> resugar_term' env e)) pats, - body - | Meta_labeled (s, r, p) -> - // this case can occur in typechecker when a failure is wrapped in meta_labeled - [], mk (A.Labeled (body, Errors.Msg.rendermsg s, p)) - | _ -> failwith "wrong pattern format for QForall/QExists" - in - pats, body - | _ -> [], resugar_term' env body - in - let decompile_op op = - match FStar.Parser.AST.string_to_op op with - | None -> op - | Some (op, _) -> op - in - let flavor_matches t = - match t.tm, op with - | A.QExists _, "exists" - | A.QForall _, "forall" -> true - | A.QuantOp(id, _, _, _), _ -> - Ident.string_of_id id = op - | _ -> false - in - let xs, pats, body = uncurry xs pats body flavor_matches in - let binders = A.idents_of_binders xs t.pos in - if op = "forall" - then mk (A.QForall(xs, (binders, pats), body)) - else if op = "exists" - then mk (A.QExists(xs, (binders, pats), body)) - else mk (A.QuantOp(Ident.id_of_text op, xs, (binders, pats), body)) - - | _ -> - (*forall added by typechecker.normalize doesn't not have Tm_abs as body*) - (*TODO: should we resugar them back as forall/exists or just as the term of the body *) - if op = "forall" then mk (A.QForall([], ([], []), resugar_term' env body)) - else mk (A.QExists([], ([], []), resugar_term' env body)) - in - (* only the last arg is from original AST terms, others are added by typechecker *) - (* TODO: we need a place to store the information in the args added by the typechecker *) - if List.length args > 0 then - let args = last args in - begin match args with - | [(b, _)] -> resugar_forall_body b - | _ -> failwith "wrong args format to QForall" - end - else - resugar_as_app e args - - | Some ("alloc", _) -> - let (e, _ ) = List.hd args in - resugar_term' env e - - | Some (op, expected_arity) -> - let op = Ident.id_of_text op in - let resugar args = args |> List.map (fun (e, qual) -> - resugar_term' env e, resugar_aqual env qual) - in - (* ignore the arguments added by typechecker *) - (* TODO: we need a place to store the information in the args added by the typechecker *) - //NS: this seems to produce the wrong output on things like - begin - match expected_arity with - | None -> - let resugared_args = resugar args in - let expect_n = D.handleable_args_length op in - if List.length resugared_args >= expect_n - then let op_args, rest = BU.first_N expect_n resugared_args in - let head = mk (A.Op(op, List.map fst op_args)) in - List.fold_left - (fun head (arg, qual) -> mk (A.App (head, arg, qual))) - head - rest - else resugar_as_app e args - | Some n when List.length args = n -> mk (A.Op(op, List.map fst (resugar args))) - | _ -> resugar_as_app e args - end - end - - | Tm_match {scrutinee=e; ret_opt=None; brs=[(pat, wopt, t)]} -> - (* for match expressions that have exactly 1 branch, instead of printing them as `match e with | P -> e1` - it would be better to print it as `let P = e in e1`. *) - (* only do it when pat is not Pat_disj since ToDocument only expects disjunctivePattern in Match and TryWith *) - let pat, wopt, t = SS.open_branch (pat, wopt, t) in - let branch_bv = FStar.Syntax.Free.names t in - let bnds = [None, (resugar_pat' env pat branch_bv, resugar_term' env e)] in - let body = resugar_term' env t in - mk (A.Let(A.NoLetQualifier, bnds, body)) - - (* | Tm_match(e, asc_opt, [(pat1, _, t1); (pat2, _, t2)], _) *) - (* when is_true_pat pat1 && is_wild_pat pat2 -> *) - (* let asc_opt = resugar_match_returns env e t.pos asc_opt in *) - (* mk (A.If(resugar_term' env e, *) - (* None, *) - (* asc_opt, *) - (* resugar_term' env t1, *) - (* resugar_term' env t2)) *) - - | Tm_match {scrutinee=e; ret_opt=asc_opt; brs=branches} -> - let resugar_branch (pat, wopt,b) = - let pat, wopt, b = SS.open_branch (pat, wopt, b) in - let branch_bv = FStar.Syntax.Free.names b in - let pat = resugar_pat' env pat branch_bv in - let wopt = match wopt with - | None -> None - | Some e -> Some (resugar_term' env e) in - let b = resugar_term' env b in - (pat, wopt, b) in - let asc_opt = resugar_match_returns env e t.pos asc_opt in - mk (A.Match(resugar_term' env e, - None, asc_opt, - List.map resugar_branch branches)) - - | Tm_ascribed {tm=e; asc} -> - let asc, tac_opt, b = resugar_ascription env asc in - mk (A.Ascribed (resugar_term' env e, asc, tac_opt, b)) - - | Tm_let {lbs=(is_rec, source_lbs); body} -> - let mk_pat a = A.mk_pattern a t.pos in - let source_lbs, body = SS.open_let_rec source_lbs body in - let resugar_one_binding bnd = - (* TODO : some stuff are open twice there ! (may have already been opened in open_let_rec) *) - let attrs_opt = - match bnd.lbattrs with - | [] -> None - | tms -> Some (List.map (resugar_term' env) tms) - in - let univs, td = SS.open_univ_vars bnd.lbunivs (U.mk_conj bnd.lbtyp bnd.lbdef) in - let typ, def = match (SS.compress td).n with - | Tm_app {args=[(t, _); (d, _)]} -> t, d - | _ -> failwith "wrong let binding format" - in - let binders, term, is_pat_app = match (SS.compress def).n with - | Tm_abs {bs=b; body=t} -> - let b, t = SS.open_term b t in - let b = filter_imp_bs b in - b, t, true - | _ -> [], def, false - in - let pat, term = match bnd.lbname with - | Inr fv -> mk_pat (A.PatName fv.fv_name.v), term - | Inl bv -> - mk_pat (A.PatVar (bv_as_unique_ident bv, None, [])), term - in - attrs_opt, - (if is_pat_app then - // let binders = filter_imp binders in - let args = binders |> map (fun b -> - let q = resugar_bqual env b.binder_qual in - mk_pat(A.PatVar (bv_as_unique_ident b.binder_bv, - q, - b.binder_attrs |> List.map (resugar_term' env)))) in - (mk_pat (A.PatApp (pat, args)), resugar_term' env term), (universe_to_string univs) - else - (pat, resugar_term' env term), (universe_to_string univs)) - in - let r = List.map resugar_one_binding source_lbs in - let bnds = - let f (attrs, (pb, univs)) = - if not (Options.print_universes ()) then attrs, pb - (* Print bound universes as a comment *) - else attrs, (fst pb, label univs (snd pb)) - in - List.map f r - in - let body = resugar_term' env body in - mk (A.Let((if is_rec then A.Rec else A.NoLetQualifier), bnds, body)) - - | Tm_uvar (u, _) -> - let s = "?u" ^ (UF.uvar_id u.ctx_uvar_head |> string_of_int) in - (* TODO : should we put a pretty_non_parseable option for these cases ? *) - label s (mk A.Wild) - - | Tm_quoted (tm, qi) -> - let qi = match qi.qkind with - | Quote_static -> Static - | Quote_dynamic -> Dynamic - in - mk (A.Quote (resugar_term' env tm, qi)) - - | Tm_meta {tm=e; meta=m} -> - let resugar_meta_desugared = function - | Sequence -> - let term = resugar_term' env e in - let rec resugar_seq t = match t.tm with - | A.Let(_, [_, (p, t1)], t2) -> - mk (A.Seq(t1, t2)) - | A.Ascribed(t1, t2, t3, use_eq) -> - (* this case happens when the let is wrapped in Meta_Monadic which is resugared to Ascribe*) - mk (A.Ascribed(resugar_seq t1, t2, t3, use_eq)) - | _ -> - (* this case happens in typechecker.normalize when Tm_let is_pure_effect, then - only the body of Tm_let is used. *) - (* TODO: How should it be resugared *) - t - in - resugar_seq term - | Machine_integer (_,_) - | Primop (* doesn't seem to be generated by desugar *) - | Masked_effect (* doesn't seem to be generated by desugar *) - | Meta_smt_pat -> (* nothing special, just resugar the term *) - resugar_term' env e - in - begin match m with - | Meta_labeled _ -> - (* Ignore the label, we don't want to print it *) - resugar_term' env e - | Meta_desugared i -> - resugar_meta_desugared i - | Meta_named t -> - mk (A.Name t) - | Meta_pattern _ // stray pattern, ignore - | Meta_monadic _ - | Meta_monadic_lift _ -> resugar_term' env e - end - - | Tm_unknown -> mk A.Wild - -and resugar_ascription env (asc, tac_opt, b) = - (match asc with - | Inl n -> (* term *) - resugar_term' env n - | Inr n -> (* comp *) - resugar_comp' env n), - BU.map_opt tac_opt (resugar_term' env), - b - -(* This entire function is of course very tied to the the desugaring -of calc expressions in ToSyntax. This only really works for fully -elaborated terms, sorry. *) -and resugar_calc (env:DsEnv.env) (t0:S.term) : option A.term = - let mk (a:A.term') : A.term = - A.mk_term a t0.pos A.Un - in - (* Returns the non-resugared final relation and the calc_pack *) - let resugar_calc_finish (t:S.term) : option (S.term & S.term) = - let hd, args = U.head_and_args t in - match (SS.compress (U.un_uinst hd)).n, args with - | Tm_fvar fv, [(_, Some { aqual_implicit = true }); // type - (rel, None); // top relation - (_, Some { aqual_implicit = true }); // x - (_, Some { aqual_implicit = true }); // y - (_, Some { aqual_implicit = true }); // rs - (pf, None)] // pf : unit -> Tot (calc_pack rs x y) - when S.fv_eq_lid fv C.calc_finish_lid -> - let pf = U.unthunk pf in - Some (rel, pf) - - | _ -> - None - in - (* Un-eta expand a relation. Return it as-is if cannot be done. *) - let un_eta_rel (rel:S.term) : option S.term = - let bv_eq_tm (b:bv) (t:S.term) : bool = - match (SS.compress t).n with - | Tm_name b' when S.bv_eq b b' -> true - | _ -> false - in - match (SS.compress rel).n with - | Tm_abs {bs=[b1;b2]; body} -> - let ([b1;b2], body) = SS.open_term [b1;b2] body in - let body = U.unascribe body in - let body = match (U.unb2t body) with - | Some body -> body - | None -> body - in - begin match (SS.compress body).n with - | Tm_app {hd=e; args} when List.length args >= 2 -> - begin match List.rev args with - | (a1, None)::(a2, None)::rest -> - if bv_eq_tm b1.binder_bv a2 && bv_eq_tm b2.binder_bv a1 // mind the flip - then Some <| U.mk_app e (List.rev rest) - else Some rel - | _ -> - Some rel - end - | _ -> Some rel - end - - | _ -> - Some rel - in - (* Resugars an application of calc_step, returning the term, the relation, - * the justifcation, and the rest of the proof. *) - let resugar_step (pack:S.term) : option (S.term & S.term & S.term & S.term) = - let hd, args = U.head_and_args pack in - match (SS.compress (U.un_uinst hd)).n, args with - | Tm_fvar fv, [(_, Some ({ aqual_implicit = true })); // type - (_, Some ({ aqual_implicit = true })); // x - (_, Some ({ aqual_implicit = true })); // y - (rel, None); // relation - (z, None); // z, next val - (_, Some ({ aqual_implicit = true })); //rs - (pf, None); // pf, rest of proof (thunked) - (j, None)] // justification (thunked) - when S.fv_eq_lid fv C.calc_step_lid -> - let pf = U.unthunk pf in - let j = U.unthunk j in - Some (z, rel, j, pf) - - | _ -> - None - in - (* Resugar an application of calc_init *) - let resugar_init (pack:S.term) : option S.term = - let hd, args = U.head_and_args pack in - match (SS.compress (U.un_uinst hd)).n, args with - | Tm_fvar fv, [(_, Some ({ aqual_implicit = true })); // type - (x, None)] // initial value - when S.fv_eq_lid fv C.calc_init_lid -> - Some x - - | _ -> - None - in - (* Repeats the above function until it returns none; what remains should be a calc_init *) - let rec resugar_all_steps (pack:S.term) : option (list (S.term & S.term & S.term) & S.term) = - match resugar_step pack with - | Some (t, r, j, k) -> - BU.bind_opt (resugar_all_steps k) (fun (steps, k) -> - Some ((t, r, j)::steps, k)) - | None -> - Some ([], pack) - in - let resugar_rel (rel:S.term) : A.term = - (* Try to un-eta, don't worry if not *) - let rel = match un_eta_rel rel with - | Some rel -> rel - | None -> rel - in - let fallback () = - mk (A.Paren (resugar_term' env rel)) - in - begin match resugar_term_as_op rel with - | Some (s, None) - | Some (s, Some 2) -> mk (A.Op (Ident.id_of_text s, [])) - | _ -> fallback () - end - in - let build_calc (rel:S.term) (x0:S.term) (steps : list (S.term & S.term & S.term)) : A.term = - let r = resugar_term' env in - mk (CalcProof (resugar_rel rel, r x0, - List.map (fun (z, rel, j) -> CalcStep (resugar_rel rel, r j, r z)) steps)) - in - let! (rel, pack) = resugar_calc_finish t0 in - let! (steps, k) = resugar_all_steps pack in - let! x0 = resugar_init k in - Some <| build_calc rel x0 (List.rev steps) - -and resugar_match_returns env scrutinee r asc_opt = - match asc_opt with - | None -> None - | Some (b, asc) -> - let bopt, asc = - let bs, asc = SS.open_ascription [b] asc in - let b = List.hd bs in - //trying to be a little smart, - // if the binder name is the reserved prefix, then don't emit it - //but we need to substitute binder with scrutinee, - // basically reverse of what ToSyntax does - if string_of_id b.binder_bv.ppname = C.match_returns_def_name - then match (SS.compress scrutinee |> U.unascribe).n with - | Tm_name sbv -> - None, SS.subst_ascription [NT (b.binder_bv, S.bv_to_name sbv)] asc - | _ -> None, asc - else Some b, asc in - let bopt = BU.map_option (fun b -> - resugar_binder' env b r - |> A.ident_of_binder r) bopt in - let asc, use_eq = - match resugar_ascription env asc with - | asc, None, use_eq -> asc, use_eq - | _ -> failwith "resugaring does not support match return annotation with a tactic" in - Some (bopt, asc, use_eq) - - -and resugar_comp' (env: DsEnv.env) (c:S.comp) : A.term = - let mk (a:A.term') : A.term = - //augment `a` with its source position - //and an Unknown level (the level is unimportant ... we should maybe remove it altogether) - A.mk_term a c.pos A.Un - in - match (c.n) with - | Total typ -> - let t = resugar_term' env typ in - (* If --print_implicits, we print the Tot *) - if Options.print_implicits() - then mk (A.Construct(C.effect_Tot_lid, [(t, A.Nothing)])) - else t - - | GTotal typ -> - let t = resugar_term' env typ in - mk (A.Construct(C.effect_GTot_lid, [(t, A.Nothing)])) - - | Comp c -> - let result = (resugar_term' env c.result_typ, A.Nothing) in - let mk_decreases (fl : list cflag) : list A.term = - let rec aux l = function - | [] -> l - | hd::tl -> - match hd with - | DECREASES dec_order -> - let d = - match dec_order with - | Decreases_lex [t] -> // special casing for single term - resugar_term' env t - | Decreases_lex ts -> - mk (LexList (ts |> List.map (resugar_term' env))) - | Decreases_wf (rel, e) -> - mk (WFOrder (resugar_term' env rel, resugar_term' env e)) in - let e = mk (Decreases (d, None)) in - aux (e::l) tl - | _ -> aux l tl - in - aux [] fl - in - if lid_equals c.effect_name C.effect_Lemma_lid && List.length c.effect_args = 3 then - let args = List.map(fun (e,_) -> (resugar_term' env e, A.Nothing)) c.effect_args in - let pre, post, pats = - match c.effect_args with - | (pre, _)::(post, _)::(pats, _)::[] -> - pre, post, pats - | _ -> failwith "impossible" - in - let pre = (if U.is_fvar C.true_lid pre then [] else [pre]) in - let post = U.unthunk_lemma_post post in - let pats = if U.is_fvar C.nil_lid (U.head_of pats) then [] else [pats] in - - let pre = List.map (fun t -> mk (Requires (resugar_term' env t, None))) pre in - let post = mk (Ensures (resugar_term' env post, None)) in - let pats = List.map (resugar_term' env) pats in - let decrease = mk_decreases c.flags in - - mk (A.Construct(maybe_shorten_lid env c.effect_name, List.map (fun t -> (t, A.Nothing)) (pre@post::decrease@pats))) - - else if (Options.print_effect_args()) then - (* let universe = List.map (fun u -> resugar_universe u) c.comp_univs in *) - let args = List.map(fun (e,_) -> (resugar_term' env e, A.Nothing)) c.effect_args in - let decrease = List.map (fun t -> (t, A.Nothing)) (mk_decreases c.flags) in - mk (A.Construct(maybe_shorten_lid env c.effect_name, result::decrease@args)) - else - mk (A.Construct(maybe_shorten_lid env c.effect_name, [result])) - -and resugar_binder' env (b:S.binder) r : A.binder = - let imp = resugar_bqual env b.binder_qual in - let e = resugar_term' env b.binder_bv.sort in - let attrs = List.map (resugar_term' env) b.binder_attrs in - let b' = - match (e.tm) with - | A.Wild -> - A.Variable (bv_as_unique_ident b.binder_bv) - | _ -> - if S.is_null_bv b.binder_bv then - A.NoName e - else - A.Annotated (bv_as_unique_ident b.binder_bv, e) - in - A.mk_binder_with_attrs b' r A.Type_level imp attrs - -and resugar_bv_as_pat' env (v: S.bv) aqual (body_bv: FlatSet.t bv) typ_opt = - let mk a = A.mk_pattern a (S.range_of_bv v) in - let used = mem v body_bv in - let pat = - mk (if used - then A.PatVar (bv_as_unique_ident v, aqual, []) - else A.PatWild (aqual, [])) in - match typ_opt with - | None | Some { n = Tm_unknown } -> pat - | Some typ -> if Options.print_bound_var_types () - then mk (A.PatAscribed (pat, (resugar_term' env typ, None))) - else pat - -and resugar_bv_as_pat env (x:S.bv) qual body_bv: A.pattern = - let bq = resugar_bqual env qual in - resugar_bv_as_pat' env x bq body_bv (Some <| SS.compress x.sort) - -and resugar_pat' env (p:S.pat) (branch_bv: FlatSet.t bv) : A.pattern = - (* We lose information when desugar PatAscribed to able to resugar it back *) - let mk a = A.mk_pattern a p.p in - let to_arg_qual bopt = // FIXME do (Some false) and None mean the same thing? - BU.bind_opt bopt (fun b -> if b then Some A.Implicit else None) in - let must_print args = - args |> List.existsML (fun (pattern, is_implicit) -> - match pattern.v with - | Pat_var bv -> is_implicit && mem bv branch_bv - | _ -> false) - in - let resugar_plain_pat_cons' fv args = - mk (A.PatApp (mk (A.PatName fv.fv_name.v), args)) in - let rec resugar_plain_pat_cons fv args = - let args = - (* Special check here: if any of the args binds a variable used in - branch, we force printing implicits. *) - if not (must_print args) - then filter_pattern_imp args - else args - in - let args = List.map (fun (p, b) -> aux p (Some b)) args in - resugar_plain_pat_cons' fv args - and aux (p:S.pat) (imp_opt:option bool)= - match p.v with - | Pat_constant c -> mk (A.PatConst c) - - (* List patterns. *) - | Pat_cons(fv, _, args) - when lid_equals fv.fv_name.v C.nil_lid -> ( - match filter_pattern_imp args with - | [] -> mk (A.PatList []) - | _ -> resugar_plain_pat_cons fv args - ) - - | Pat_cons(fv, _, args) - when lid_equals fv.fv_name.v C.cons_lid -> ( - match filter_pattern_imp args with - | [(hd, false); (tl, false)] -> - let hd' = aux hd (Some false) in - (match aux tl (Some false) with - | { pat = A.PatList tl'; prange = p } -> A.mk_pattern (A.PatList (hd' :: tl')) p - | tl' -> resugar_plain_pat_cons' fv [hd'; tl']) - - | _ -> resugar_plain_pat_cons fv args - ) - - | Pat_cons (fv, _, []) -> - mk (A.PatName fv.fv_name.v) - - - | Pat_cons(fv, _, args) when (is_tuple_constructor_lid fv.fv_name.v - && not (must_print args)) -> - let args = - args |> - List.filter_map (fun (p, is_implicit) -> - if is_implicit then None else Some (aux p (Some false))) in - let is_dependent_tuple = C.is_dtuple_data_lid' fv.fv_name.v in - mk (A.PatTuple (args, is_dependent_tuple)) - - | Pat_cons({fv_qual=Some (Record_ctor(name, fields))}, _, args) -> - // reverse the fields and args list to match them since the args added by the type checker - // are inserted in the front of the args list. - let fields = fields |> List.map (fun f -> FStar.Ident.lid_of_ids [f]) |> List.rev in - let args = args |> List.map (fun (p, b) -> aux p (Some b)) |> List.rev in - // make sure the fields and args are of the same length. - let rec map2 l1 l2 = match (l1, l2) with - | ([], []) -> [] - | ([], hd::tl) -> [] (* new args could be added by the type checker *) - | (hd::tl, []) -> (hd, mk (A.PatWild (None, []))) :: map2 tl [] (* no new fields should be added*) - | (hd1::tl1, hd2::tl2) -> (hd1, hd2) :: map2 tl1 tl2 - in - // reverse back the args list - let args = map2 fields args |> List.rev in - mk (A.PatRecord(args)) - - | Pat_cons (fv, _, args) -> - resugar_plain_pat_cons fv args - - | Pat_var v -> - // both A.PatTvar and A.PatVar are desugared to S.Pat_var. A PatTvar in the original file coresponds - // to some type variable which is implicitly bound to the enclosing toplevel declaration. - // When resugaring it will be just a normal (explicitly bound) variable. - begin match string_to_op (string_of_id v.ppname) with - | Some (op, _) -> mk (A.PatOp (Ident.mk_ident (op, (range_of_id v.ppname)))) - | None -> resugar_bv_as_pat' env v (to_arg_qual imp_opt) branch_bv None - end - - // FIXME: detect unused patterns - (* | Pat_wild _ -> mk (A.PatWild (to_arg_qual imp_opt, [])) *) - - | Pat_dot_term _ -> mk (A.PatWild (Some A.Implicit, [])) - in - aux p None -// FIXME inspect uses of resugar_arg_qual and resugar_imp -(* If resugar_arg_qual returns None, the corresponding binder should *not* be resugared *) -and resugar_bqual env (q:S.bqual) : option A.arg_qualifier = - match q with - | None -> None - | Some (S.Implicit b) -> Some A.Implicit - | Some S.Equality -> Some A.Equality - | Some (S.Meta t) when U.is_fvar C.tcresolve_lid t -> Some (A.TypeClassArg) - | Some (S.Meta t) -> Some (A.Meta (resugar_term' env t)) - -and resugar_aqual env (q:S.aqual) : A.imp = - match q with - | None -> A.Nothing - | Some a -> if a.aqual_implicit then A.Hash else A.Nothing - -let resugar_qualifier : S.qualifier -> option A.qualifier = function - | S.Assumption -> Some A.Assumption - | S.InternalAssumption -> None - | S.New -> Some A.New - | S.Private -> Some A.Private - | S.Unfold_for_unification_and_vcgen -> Some A.Unfold_for_unification_and_vcgen - (* TODO : Find the correct option to display this *) - | Visible_default -> if true then None else Some A.Visible - | S.Irreducible -> Some A.Irreducible - | S.Inline_for_extraction -> Some A.Inline_for_extraction - | S.NoExtract -> Some A.NoExtract - | S.Noeq -> Some A.Noeq - | S.Unopteq -> Some A.Unopteq - | S.TotalEffect -> Some A.TotalEffect - (* TODO : Find the correct option to display this *) - | S.Logic -> if true then None else Some A.Logic - | S.Reifiable -> Some A.Reifiable - | S.Reflectable _ -> Some A.Reflectable - | S.Discriminator _ -> None - | S.Projector _ -> None - | S.RecordType _ -> None - | S.RecordConstructor _ -> None - | S.Action _ -> None - | S.ExceptionConstructor -> None - | S.HasMaskedEffect -> None - | S.Effect -> Some A.Effect_qual - | S.OnlyName -> None - - -let resugar_pragma = function - | S.ShowOptions -> A.ShowOptions - | S.SetOptions s -> A.SetOptions s - | S.ResetOptions s -> A.ResetOptions s - | S.PushOptions s -> A.PushOptions s - | S.PopOptions -> A.PopOptions - | S.RestartSolver -> A.RestartSolver - | S.PrintEffectsGraph -> A.PrintEffectsGraph - -(* drop the first n binders (implicit or explicit) from an arrow type *) -let drop_n_bs (n:int) (t:S.term) : S.term = - let bs, c = U.arrow_formals_comp_ln t in - let bs = List.splitAt n bs |> snd in - U.arrow bs c - -let resugar_typ env datacon_ses se : sigelts & A.tycon = - match se.sigel with - | Sig_inductive_typ {lid=tylid;us=uvs;params=bs;t;ds=datacons} -> - let current_datacons, other_datacons = datacon_ses |> List.partition (fun se -> match se.sigel with - | Sig_datacon {ty_lid=inductive_lid} -> lid_equals inductive_lid tylid - | _ -> failwith "unexpected" ) - in - assert (List.length current_datacons = List.length datacons) ; - let bs = filter_imp_bs bs in - let bs = bs |> map (fun b -> resugar_binder' env b t.pos) in - let tyc = - if se.sigquals |> BU.for_some RecordType? && List.length current_datacons = 1 then - (* Resugar as a record. There must be a single constructor *) - let [dc] = current_datacons in - match dc.sigel with - | Sig_datacon {lid=l; us=univs; t=typ; num_ty_params=num} -> - let typ = drop_n_bs num typ in - let fields = - let bs, _ = U.arrow_formals_comp_ln typ in - let bs = filter_imp_bs bs in - bs |> List.map (fun b -> - let q = resugar_bqual env b.binder_qual in - (bv_as_unique_ident b.binder_bv, q, b.binder_attrs |> List.map (resugar_term' env), resugar_term' env b.binder_bv.sort) - ) - in - A.TyconRecord (ident_of_lid tylid, bs, None, map (resugar_term' env) se.sigattrs, fields) - | _ -> failwith "ggg1" - else - (* Resugar as a variant *) - let resugar_datacon constructors se = match se.sigel with - | Sig_datacon {lid=l; us=univs; t=typ; num_ty_params=num} -> - let typ = drop_n_bs num typ in - (* Todo: resugar univs *) - let c = (ident_of_lid l, Some (VpArbitrary (resugar_term' env typ)), map (resugar_term' env) se.sigattrs) in - c::constructors - | _ -> failwith "unexpected" - in - let constructors = List.fold_left resugar_datacon [] current_datacons in - A.TyconVariant (ident_of_lid tylid, bs, None, constructors) - in - other_datacons, tyc - | _ -> failwith "Impossible : only Sig_inductive_typ can be resugared as types" - -let mk_decl r q d' = - { - d = d' ; - drange = r ; - quals = List.choose resugar_qualifier q ; - attrs = [] ; // We fill in the attrs in resugar_sigelt' - interleaved = false; - } - -let decl'_to_decl se d' = - mk_decl se.sigrng se.sigquals d' - -let resugar_tscheme'' env name (ts:S.tscheme) = - let (univs, typ) = ts in - let name = I.mk_ident (name, typ.pos) in - mk_decl typ.pos [] (A.Tycon(false, false, [(A.TyconAbbrev(name, [], None, resugar_term' env typ))])) - -let resugar_tscheme' env (ts:S.tscheme) = - resugar_tscheme'' env "tscheme" ts - -let resugar_wp_eff_combinators env for_free combs = - let resugar_opt name tsopt = - match tsopt with - | Some ts -> [resugar_tscheme'' env name ts] - | None -> [] in - - let repr = resugar_opt "repr" combs.repr in - let return_repr = resugar_opt "return_repr" combs.return_repr in - let bind_repr = resugar_opt "bind_repr" combs.bind_repr in - - if for_free then repr@return_repr@bind_repr - else - (resugar_tscheme'' env "ret_wp" combs.ret_wp):: - (resugar_tscheme'' env "bind_wp" combs.bind_wp):: - (resugar_tscheme'' env "stronger" combs.stronger):: - (resugar_tscheme'' env "if_then_else" combs.if_then_else):: - (resugar_tscheme'' env "ite_wp" combs.ite_wp):: - (resugar_tscheme'' env "close_wp" combs.close_wp):: - (resugar_tscheme'' env "trivial" combs.trivial):: - (repr@return_repr@bind_repr) - -let resugar_layered_eff_combinators env combs = - let resugar name (ts, _, _) = resugar_tscheme'' env name ts in - let resugar2 name (ts, _) = resugar_tscheme'' env name ts in - - (resugar2 "repr" combs.l_repr):: - (resugar2 "return" combs.l_return):: - (resugar "bind" combs.l_bind):: - (resugar "subcomp" combs.l_subcomp):: - (resugar "if_then_else" combs.l_if_then_else)::[] - -let resugar_combinators env combs = - match combs with - | Primitive_eff combs -> resugar_wp_eff_combinators env false combs - | DM4F_eff combs -> resugar_wp_eff_combinators env true combs - | Layered_eff combs -> resugar_layered_eff_combinators env combs - -let resugar_eff_decl' env ed = - let r = Range.dummyRange in - let q = [] in - let resugar_action d for_free = - let action_params = SS.open_binders d.action_params in - let bs, action_defn = SS.open_term action_params d.action_defn in - let bs, action_typ = SS.open_term action_params d.action_typ in - let action_params = filter_imp_bs action_params in - let action_params = action_params |> map (fun b -> resugar_binder' env b r) |> List.rev in - let action_defn = resugar_term' env action_defn in - let action_typ = resugar_term' env action_typ in - if for_free then - let a = A.Construct ((I.lid_of_str "construct"), [(action_defn, A.Nothing);(action_typ, A.Nothing)]) in - let t = A.mk_term a r A.Un in - mk_decl r q (A.Tycon(false, false, [(A.TyconAbbrev(ident_of_lid d.action_name, action_params, None, t ))])) - else - mk_decl r q (A.Tycon(false, false, [(A.TyconAbbrev(ident_of_lid d.action_name, action_params, None, action_defn))])) - in - let eff_name = ident_of_lid ed.mname in - let eff_binders, eff_typ = - let sig_ts = U.effect_sig_ts ed.signature in - SS.open_term ed.binders (sig_ts |> snd) in - let eff_binders = filter_imp_bs eff_binders in - let eff_binders = eff_binders |> map (fun b -> resugar_binder' env b r) |> List.rev in - let eff_typ = resugar_term' env eff_typ in - - let mandatory_members_decls = resugar_combinators env ed.combinators in - - let actions = ed.actions |> List.map (fun a -> resugar_action a false) in - let decls = mandatory_members_decls@actions in - mk_decl r q (A.NewEffect(DefineEffect(eff_name, eff_binders, eff_typ, decls))) - -let resugar_sigelt' env se : option A.decl = - let d = (match se.sigel with - | Sig_bundle {ses} -> - let decl_typ_ses, datacon_ses = ses |> List.partition - (fun se -> match se.sigel with - | Sig_inductive_typ _ | Sig_declare_typ _ -> true - | Sig_datacon _ -> false - | _ -> failwith "Found a sigelt which is neither a type declaration or a data constructor in a sigelt" - ) - in - let retrieve_datacons_and_resugar (datacon_ses, tycons) se = - let datacon_ses, tyc = resugar_typ env datacon_ses se in - datacon_ses, tyc::tycons - in - let leftover_datacons, tycons = List.fold_left retrieve_datacons_and_resugar (datacon_ses, []) decl_typ_ses in - begin match leftover_datacons with - | [] -> //true - (* TODO : documentation should be retrieved from the desugaring environment at some point *) - Some (decl'_to_decl se (Tycon (false, false, tycons))) - | [se] -> - //assert (se.sigquals |> BU.for_some (function | ExceptionConstructor -> true | _ -> false)); - (* Exception constructor declaration case *) - begin match se.sigel with - | Sig_datacon {lid=l} -> - Some (decl'_to_decl se (A.Exception (ident_of_lid l, None))) - | _ -> failwith "wrong format for resguar to Exception" - end - | _ -> - failwith "Should not happen hopefully" - end - - | Sig_fail _ -> - None - - | Sig_let {lbs} -> - if (se.sigquals |> BU.for_some (function S.Projector(_,_) | S.Discriminator _ -> true | _ -> false)) then - None - else - let mk e = S.mk e se.sigrng in - let dummy = mk Tm_unknown in - (* This function turns each resolved top-level lid being defined into an - * ident without a path, so it gets printed correctly. *) - let nopath_lbs ((is_rec, lbs) : letbindings) : letbindings = - let nopath fv = lid_as_fv (lid_of_ids [ident_of_lid (lid_of_fv fv)]) None in - let lbs = List.map (fun lb -> { lb with lbname = Inr (nopath <| right lb.lbname)} ) lbs in - (is_rec, lbs) - in - let lbs = nopath_lbs lbs in - let desugared_let = mk (Tm_let {lbs; body=dummy}) in - let t = resugar_term' env desugared_let in - begin match t.tm with - | A.Let(isrec, lets, _) -> - Some (decl'_to_decl se (TopLevelLet (isrec, List.map snd lets))) - | _ -> failwith "Should not happen hopefully" - end - - | Sig_assume {lid; phi=fml} -> - Some (decl'_to_decl se (Assume (ident_of_lid lid, resugar_term' env fml))) - - | Sig_new_effect ed -> - let a_decl = resugar_eff_decl' env ed in - let q = List.choose resugar_qualifier se.sigquals in - Some { a_decl with quals = q } - - | Sig_sub_effect e -> - let src = e.source in - let dst = e.target in - let lift_wp = match e.lift_wp with - | Some (_, t) -> - Some (resugar_term' env t) - | _ -> None - in - let lift = match e.lift with - | Some (_, t) -> - Some (resugar_term' env t) - | _ -> None - in - let op = match (lift_wp, lift) with - | Some t, None -> A.NonReifiableLift t - | Some wp, Some t -> A.ReifiableLift (wp, t) - | None, Some t -> A.LiftForFree t - | _ -> failwith "Should not happen hopefully" - in - Some (decl'_to_decl se (A.SubEffect({msource=src; mdest=dst; lift_op=op; braced=false}))) - - | Sig_effect_abbrev {lid; us=vs; bs; comp=c; cflags=flags} -> - let bs, c = SS.open_comp bs c in - let bs = filter_imp_bs bs in - let bs = bs |> map (fun b -> resugar_binder' env b se.sigrng) in - Some (decl'_to_decl se (A.Tycon(false, false, [A.TyconAbbrev(ident_of_lid lid, bs, None, resugar_comp' env c)]))) - - | Sig_pragma p -> - Some (decl'_to_decl se (A.Pragma (resugar_pragma p))) - - | Sig_declare_typ {lid; us=uvs; t} -> - if (se.sigquals |> BU.for_some (function S.Projector(_,_) | S.Discriminator _ -> true | _ -> false)) then - None - else - let t' = - if not (Options.print_universes ()) || isEmpty uvs then resugar_term' env t - else - let uvs, t = SS.open_univ_vars uvs t in - let universes = universe_to_string uvs in - label universes (resugar_term' env t) - in - Some (decl'_to_decl se (A.Val (ident_of_lid lid,t'))) - - | Sig_splice {is_typed; lids=ids; tac=t} -> - Some (decl'_to_decl se (A.Splice (is_typed, List.map (fun l -> ident_of_lid l) ids, resugar_term' env t))) - - (* Already desugared in one of the above case or non-relevant *) - | Sig_inductive_typ _ - | Sig_datacon _ -> None - - | Sig_polymonadic_bind {m_lid=m; n_lid=n; p_lid=p; tm=(_, t)} -> - Some (decl'_to_decl se (A.Polymonadic_bind (m, n, p, resugar_term' env t))) - - | Sig_polymonadic_subcomp {m_lid=m; n_lid=n; tm=(_, t)} -> - Some (decl'_to_decl se (A.Polymonadic_subcomp (m, n, resugar_term' env t)))) in - - match d with - | Some d -> Some { d with attrs = List.map (resugar_term' env) se.sigattrs } - | None -> None - -(* Old interface: no envs *) - -let empty_env = DsEnv.empty_env FStar.Parser.Dep.empty_deps //dep graph not needed for resugaring - -let noenv (f: DsEnv.env -> 'a) : 'a = - f empty_env - -let resugar_term (t : S.term) : A.term = - noenv resugar_term' t - -let resugar_sigelt se : option A.decl = - noenv resugar_sigelt' se - -let resugar_comp (c:S.comp) : A.term = - noenv resugar_comp' c - -let resugar_pat (p:S.pat) (branch_bv: FlatSet.t bv) : A.pattern = - noenv resugar_pat' p branch_bv - -let resugar_binder (b:S.binder) r : A.binder = - noenv resugar_binder' b r - -let resugar_tscheme (ts:S.tscheme) = - noenv resugar_tscheme' ts - -let resugar_eff_decl ed = - noenv resugar_eff_decl' ed diff --git a/src/syntax/FStar.Syntax.Resugar.fsti b/src/syntax/FStar.Syntax.Resugar.fsti deleted file mode 100644 index 99789b2f174..00000000000 --- a/src/syntax/FStar.Syntax.Resugar.fsti +++ /dev/null @@ -1,52 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Syntax.Resugar //we should rename FStar.ToSyntax to something else - -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Syntax.Syntax -open FStar.Ident -open FStar.Compiler.Util -open FStar.Const -open FStar.Compiler.Range - -module I = FStar.Ident -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module A = FStar.Parser.AST -module C = FStar.Parser.Const -module U = FStar.Syntax.Util -module BU = FStar.Compiler.Util -module Range = FStar.Compiler.Range -module DsEnv = FStar.Syntax.DsEnv - -val resugar_term: S.term -> A.term -val resugar_sigelt: S.sigelt -> option A.decl -val resugar_comp: S.comp -> A.term -val resugar_pat: S.pat -> FlatSet.t S.bv -> A.pattern -val resugar_universe: S.universe -> Range.range -> A.term -val resugar_binder: S.binder -> Range.range -> A.binder -val resugar_tscheme: S.tscheme -> A.decl -val resugar_eff_decl: eff_decl -> A.decl - -val resugar_term': DsEnv.env -> S.term -> A.term -val resugar_sigelt': DsEnv.env -> S.sigelt -> option A.decl -val resugar_comp': DsEnv.env -> S.comp -> A.term -val resugar_pat': DsEnv.env -> S.pat -> FlatSet.t S.bv -> A.pattern -val resugar_universe': DsEnv.env -> S.universe -> Range.range -> A.term -val resugar_binder': DsEnv.env -> S.binder -> Range.range -> A.binder -val resugar_tscheme': DsEnv.env -> S.tscheme -> A.decl -val resugar_eff_decl': DsEnv.env -> eff_decl -> A.decl diff --git a/src/syntax/FStar.Syntax.Subst.fst b/src/syntax/FStar.Syntax.Subst.fst deleted file mode 100644 index 9929af5cbb0..00000000000 --- a/src/syntax/FStar.Syntax.Subst.fst +++ /dev/null @@ -1,813 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Syntax.Subst -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List - -open FStar -open FStar.Compiler -open FStar.Compiler.Range -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.Compiler.Util -open FStar.Ident - -module Err = FStar.Errors -module U = FStar.Compiler.Util -module S = FStar.Syntax.Syntax - -/////////////////////////////////////////////////////////////////////////// -// A few utility functions for working with lists of parallel substitutions -/////////////////////////////////////////////////////////////////////////// - -(* A subst_t is a composition of parallel substitutions, expressed as a list of lists *) -let subst_to_string s = - s |> List.map (fun (b, _) -> (string_of_id b.ppname)) |> String.concat ", " - -(* apply_until_some f s - applies f to each element of s until it returns (Some t) -*) -let rec apply_until_some f s = - match s with - | [] -> None - | s0::rest -> - match f s0 with - | None -> apply_until_some f rest - | Some st -> Some (rest, st) - -let map_some_curry f x = function - | None -> x - | Some (a, b) -> f a b - -let apply_until_some_then_map f s g t = - apply_until_some f s - |> map_some_curry g t -///////////////////////////////////////////////////////////////////////// - - -//s1 is the subsitution already associated with this node; -//s2 is the new subsitution to add to it -//compose substitutions by concatenating them -//the order of concatenation is important! -//the range of s2 take precedence, if present -let compose_subst s1 s2 = - let s = fst s1 @ fst s2 in - let ropt = match snd s2 with - | SomeUseRange _ -> snd s2 - | _ -> snd s1 in - (s, ropt) - -//apply a delayed substitution s to t, -//composing it with any other delayed substitution that may already be there -let delay t s = - match t.n with - | Tm_delayed {tm=t'; substs=s'} -> - //s' is the subsitution already associated with this node; - //s is the new subsitution to add to it - //compose substitutions by concatenating them - //the order of concatenation is important! - mk_Tm_delayed (t', compose_subst s' s) t.pos - | _ -> - mk_Tm_delayed (t, s) t.pos - -(* - force_uvar' (t:term) : term * bool - replaces any unification variable at the head of t - with the term that it has been fixed to, if any. - - Also returns `true`, if it actually resolved the uvar at the head - `false` otherwise - - Warning: if force_uvar changes to operate on inputs other - than Tm_uvar then the fastpath out match in compress will - need to be updated. -*) -let rec force_uvar' t = - match t.n with - | Tm_uvar ({ctx_uvar_head=uv}, s) -> - (match Unionfind.find uv with - | Some t' -> fst (force_uvar' (delay t' s)), true - | _ -> t, false) - | _ -> t, false - -//wraps force_uvar' to propagate any position information -//from the uvar to anything it may have been resolved to -let force_uvar t = - let t', forced = force_uvar' t in - if forced - then delay t' ([], SomeUseRange t.pos) - else t - -let rec compress_univ u = match u with - | U_unif u' -> - begin match Unionfind.univ_find u' with - | Some u -> compress_univ u - | _ -> u - end - | _ -> u - -(********************************************************************************) -(*************************** Delayed substitutions ******************************) -(********************************************************************************) - -//Lookup a bound var or a name in a parallel substitution -let subst_bv a s = U.find_map s (function - | DB (i, x) when (i=a.index) -> - Some (bv_to_name (Syntax.set_range_of_bv x (Syntax.range_of_bv a))) - | DT (i, t) when (i=a.index) -> - Some t - | _ -> None) -let subst_nm a s = U.find_map s (function - | NM (x, i) when bv_eq a x -> Some (bv_to_tm ({a with index=i})) - | NT (x, t) when bv_eq a x -> Some t - | _ -> None) -let subst_univ_bv x s = U.find_map s (function - | UN(y, t) when (x=y) -> Some t - | _ -> None) -let subst_univ_nm (x:univ_name) s = U.find_map s (function - | UD(y, i) when (ident_equals x y) -> Some (U_bvar i) - | _ -> None) - -let rec subst_univ s u = - let u = compress_univ u in - match u with - | U_bvar x -> - apply_until_some_then_map (subst_univ_bv x) s subst_univ u - - | U_name x -> - apply_until_some_then_map (subst_univ_nm x) s subst_univ u - - | U_zero - | U_unknown - | U_unif _ -> u - | U_succ u -> U_succ (subst_univ s u) - | U_max us -> U_max (List.map (subst_univ s) us) - -let tag_with_range t s = - match snd s with - | NoUseRange -> t - | SomeUseRange r -> - if Range.rng_included (Range.use_range t.pos) (Range.use_range r) - then t - else begin - let r = Range.set_use_range t.pos (Range.use_range r) in - let t' = match t.n with - | Tm_bvar bv -> Tm_bvar (Syntax.set_range_of_bv bv r) - | Tm_name bv -> Tm_name (Syntax.set_range_of_bv bv r) - | Tm_fvar fv -> let l = Syntax.lid_of_fv fv in - let v = {fv.fv_name with v=Ident.set_lid_range l r} in - let fv = {fv with fv_name=v} in - Tm_fvar fv - | t' -> t' in - {t with n=t'; pos=r} - end - -let tag_lid_with_range l s = - match (snd s) with - | NoUseRange -> l - | SomeUseRange r -> - if Range.rng_included (Range.use_range (Ident.range_of_lid l)) (Range.use_range r) - then l - else Ident.set_lid_range l (Range.set_use_range (Ident.range_of_lid l) (Range.use_range r)) - -let mk_range r (s:subst_ts) = - match snd s with - | NoUseRange -> r - | SomeUseRange r' -> - if Range.rng_included (Range.use_range r) (Range.use_range r') - then r - else Range.set_use_range r (Range.use_range r') - -(* Applies a substitution to a node, - immediately if it is a variable - or builds a delayed node otherwise *) -let rec subst' (s:subst_ts) (t:term) : term = - let subst_tail (tl:list (list subst_elt)) = subst' (tl, snd s) in - match s with - | [], NoUseRange - | [[]], NoUseRange -> t - | _ -> - let t0 = t in - match t0.n with - | Tm_unknown - | Tm_constant _ //a constant cannot be substituted - | Tm_fvar _ -> tag_with_range t0 s //fvars are never subject to substitution - - | Tm_delayed {tm=t';substs=s'} -> - //s' is the subsitution already associated with this node; - //s is the new subsitution to add to it - //compose substitutions by concatenating them - //the order of concatenation is important! - mk_Tm_delayed (t', compose_subst s' s) t.pos - - | Tm_bvar a -> - apply_until_some_then_map (subst_bv a) (fst s) subst_tail t0 - - | Tm_name a -> - apply_until_some_then_map (subst_nm a) (fst s) subst_tail t0 - - | Tm_type u -> - mk (Tm_type (subst_univ (fst s) u)) (mk_range t0.pos s) - - | _ -> - //NS: 04/12/2018 - // Substitutions on Tm_uvar just gets delayed - // since its solution may eventually end up being an open term - mk_Tm_delayed (t0, s) (mk_range t.pos s) - -let subst_dec_order' s = function - | Decreases_lex l -> Decreases_lex (l |> List.map (subst' s)) - | Decreases_wf (rel, e) -> Decreases_wf (subst' s rel, subst' s e) - -let subst_flags' s flags = - flags |> List.map (function - | DECREASES dec_order -> DECREASES (subst_dec_order' s dec_order) - | f -> f) - -let subst_bqual' s i = - match i with - | Some (Meta t) -> Some (Meta (subst' s t)) - | _ -> i - -let subst_aqual' s (i:aqual) : aqual = - match i with - | None -> None - | Some a -> Some ({a with aqual_attributes = List.map (subst' s) a.aqual_attributes }) - -let subst_comp_typ' s t = - match s with - | [], NoUseRange - | [[]], NoUseRange -> t - | _ -> - {t with effect_name=tag_lid_with_range t.effect_name s; - comp_univs=List.map (subst_univ (fst s)) t.comp_univs; - result_typ=subst' s t.result_typ; - flags=subst_flags' s t.flags; - effect_args=List.map (fun (t, imp) -> subst' s t, subst_aqual' s imp) t.effect_args} - -let subst_comp' s t = - match s with - | [], NoUseRange - | [[]], NoUseRange -> t - | _ -> - match t.n with - | Total t -> mk_Total (subst' s t) - | GTotal t -> mk_GTotal (subst' s t) - | Comp ct -> mk_Comp(subst_comp_typ' s ct) - -let subst_ascription' s (asc:ascription) = - let annot, topt, use_eq = asc in - let annot = match annot with - | Inl t -> Inl (subst' s t) - | Inr c -> Inr (subst_comp' s c) in - annot, - U.map_opt topt (subst' s), - use_eq - -let shift n s = match s with - | DB(i, t) -> DB(i+n, t) - | DT(i, t) -> DT(i+n, t) - | UN(i, t) -> UN(i+n, t) - | NM(x, i) -> NM(x, i+n) - | UD(x, i) -> UD(x, i+n) - | NT _ -> s -let shift_subst n s = List.map (shift n) s -let shift_subst' n s = fst s |> List.map (shift_subst n), snd s -let subst_binder' s b = - S.mk_binder_with_attrs - ({ b.binder_bv with sort = subst' s b.binder_bv.sort }) - (subst_bqual' s b.binder_qual) - b.binder_positivity - (b.binder_attrs |> List.map (subst' s)) - -let subst_binder s (b:binder) = subst_binder' ([s], NoUseRange) b - -let subst_binders' s bs = - bs |> List.mapi (fun i b -> - if i=0 then subst_binder' s b - else subst_binder' (shift_subst' i s) b) -let subst_binders s (bs:binders) = subst_binders' ([s], NoUseRange) bs - - -// NOTE: We don't descend into `imp` here since one cannot *apply* a -// `Meta t` argument, so this would always be a no-op -let subst_arg' s (t, imp) = (subst' s t, imp) - -let subst_args' s = List.map (subst_arg' s) - -let subst_univs_opt sub us_opt = - match us_opt with - | None -> None - | Some us -> Some (List.map (subst_univ sub) us) - -let subst_pat' s p : (pat & int) = - let rec aux n p : (pat & int) = match p.v with - | Pat_constant _ -> p, n - - | Pat_cons(fv, us_opt, pats) -> - let us_opt = subst_univs_opt (fst (shift_subst' n s)) us_opt in - let pats, n = pats |> List.fold_left (fun (pats, n) (p, imp) -> - let p, m = aux n p in - ((p,imp)::pats, m)) ([], n) in - {p with v=Pat_cons(fv, us_opt, List.rev pats)}, n - - | Pat_var x -> - let s = shift_subst' n s in - let x = {x with sort=subst' s x.sort} in - {p with v=Pat_var x}, n + 1 - - | Pat_dot_term eopt -> - let s = shift_subst' n s in - let eopt = U.map_option (subst' s) eopt in - {p with v=Pat_dot_term eopt}, n - in aux 0 p - -let push_subst_lcomp s lopt = match lopt with - | None -> None - | Some rc -> - let residual_typ = U.map_opt rc.residual_typ (subst' s) in - (* NB: residual flags MUST be closed. DECREASES cannot - appear there *) - let rc = { residual_effect = rc.residual_effect - ; residual_typ = residual_typ - ; residual_flags = rc.residual_flags } in - Some rc - -let compose_uvar_subst (u:ctx_uvar) (s0:subst_ts) (s:subst_ts) : subst_ts = - let should_retain x = - u.ctx_uvar_binders |> U.for_some (fun b -> S.bv_eq x b.binder_bv) - in - let rec aux = function - | [] -> [] - | hd_subst::rest -> - let hd = - hd_subst |> List.collect (function - | NT(x, t) -> - if should_retain x - then [NT(x, delay t (rest, NoUseRange))] - else [] - | NM(x, i) -> - if should_retain x - then let x_i = S.bv_to_tm ({x with index=i}) in - let t = subst' (rest, NoUseRange) x_i in - match t.n with - | Tm_bvar x_j -> [NM(x, x_j.index)] - | _ -> [NT(x, t)] - else [] - | _ -> []) - in - hd @ aux rest - in - match aux (fst s0 @ fst s) with - | [] -> [], snd s - | s' -> [s'], snd s - -// -// If resolve_uvars is true, it will lookup the unionfind graph -// and use uvar solution, if it has already been solved -// see the Tm_uvar case in this function -// Otherwise it will just compose s with the uvar subst -// -let rec push_subst_aux (resolve_uvars:bool) s t = - //makes a syntax node, setting it's use range as appropriate from s - let mk t' = Syntax.mk t' (mk_range t.pos s) in - match t.n with - | Tm_delayed _ -> failwith "Impossible (delayed node in push_subst)" - - | Tm_lazy i -> - begin match i.lkind with - | Lazy_embedding _ -> - (* These might be open! Just unfold and descend. - * The hope is that this does not occur often and so - * we still get good performance. *) - let t = must !lazy_chooser i.lkind i in // Can't call Syntax.Util from here - push_subst_aux resolve_uvars s t - | _ -> - (* All others must be closed, so don't bother *) - tag_with_range t s - end - - | Tm_constant _ - | Tm_fvar _ - | Tm_unknown -> tag_with_range t s //these are always closed - - | Tm_uvar (uv, s0) -> - let fallback () = - tag_with_range ({t with n = Tm_uvar(uv, compose_uvar_subst uv s0 s)}) s - in - if not resolve_uvars - then fallback () - else (match (Unionfind.find uv.ctx_uvar_head) with - | None -> fallback () - | Some t -> push_subst_aux resolve_uvars (compose_subst s0 s) t) - - | Tm_type _ - | Tm_bvar _ - | Tm_name _ -> subst' s t - - | Tm_uinst(t', us) -> - //t' must be an fvar---it cannot be substituted - //but the universes may be substituted - let us = List.map (subst_univ (fst s)) us in - tag_with_range (mk (Tm_uinst (t', us))) s - - | Tm_app {hd=t0; args} -> mk (Tm_app {hd=subst' s t0; args=subst_args' s args}) - - | Tm_ascribed {tm=t0; asc; eff_opt=lopt} -> - mk (Tm_ascribed {tm=subst' s t0; asc=subst_ascription' s asc; eff_opt=lopt}) - - | Tm_abs {bs; body; rc_opt=lopt} -> - let n = List.length bs in - let s' = shift_subst' n s in - mk (Tm_abs {bs=subst_binders' s bs; body=subst' s' body; rc_opt=push_subst_lcomp s' lopt}) - - | Tm_arrow {bs; comp} -> - let n = List.length bs in - mk (Tm_arrow {bs=subst_binders' s bs;comp=subst_comp' (shift_subst' n s) comp}) - - | Tm_refine {b=x; phi} -> - let x = {x with sort=subst' s x.sort} in - let phi = subst' (shift_subst' 1 s) phi in - mk (Tm_refine {b=x; phi}) - - | Tm_match {scrutinee=t0; ret_opt=asc_opt; brs=pats; rc_opt=lopt} -> - let t0 = subst' s t0 in - let pats = pats |> List.map (fun (pat, wopt, branch) -> - let pat, n = subst_pat' s pat in - let s = shift_subst' n s in - let wopt = match wopt with - | None -> None - | Some w -> Some (subst' s w) in - let branch = subst' s branch in - (pat, wopt, branch)) in - let asc_opt = - match asc_opt with - | None -> None - | Some (b, asc) -> - let b = subst_binder' s b in - let asc = subst_ascription' (shift_subst' 1 s) asc in - Some (b, asc) in - mk (Tm_match {scrutinee=t0; ret_opt=asc_opt; brs=pats; rc_opt=push_subst_lcomp s lopt}) - - | Tm_let {lbs=(is_rec, lbs); body} -> - let n = List.length lbs in - let sn = shift_subst' n s in - let body = subst' sn body in - let lbs = lbs |> List.map (fun lb -> - let lbt = subst' s lb.lbtyp in - let lbd = if is_rec && U.is_left (lb.lbname) //if it is a recursive local let, then all the let bound names are in scope for the body - then subst' sn lb.lbdef - else subst' s lb.lbdef in - let lbname = match lb.lbname with - | Inl x -> Inl ({x with sort=lbt}) - | Inr fv -> Inr fv - in - let lbattrs = List.map (subst' s) lb.lbattrs in - {lb with lbname=lbname; lbtyp=lbt; lbdef=lbd; lbattrs=lbattrs}) in - mk (Tm_let {lbs=(is_rec, lbs); body}) - - | Tm_meta {tm=t0; meta=Meta_pattern (bs, ps)} -> - mk (Tm_meta {tm=subst' s t0; meta=Meta_pattern (List.map (subst' s) bs, ps |> List.map (subst_args' s))}) - - | Tm_meta {tm=t0; meta=Meta_monadic (m, t)} -> - mk (Tm_meta {tm=subst' s t0; meta=Meta_monadic(m, subst' s t)}) - - | Tm_meta {tm=t0; meta=Meta_monadic_lift (m1, m2, t)} -> - mk (Tm_meta {tm=subst' s t0; meta=Meta_monadic_lift (m1, m2, subst' s t)}) - - | Tm_quoted (tm, qi) -> - begin match qi.qkind with - | Quote_dynamic -> mk (Tm_quoted (subst' s tm, qi)) - | Quote_static -> - let qi = on_antiquoted (subst' s) qi in - mk (Tm_quoted (tm, qi)) - end - - | Tm_meta {tm=t; meta=m} -> - mk (Tm_meta {tm=subst' s t; meta=m}) - -let push_subst s t = push_subst_aux true s t - -// -// Only push the pending substitution down, -// no resolving uvars -// -let compress_subst t = - match t.n with - | Tm_delayed {tm=t; substs=s} -> - let resolve_uvars = false in - push_subst_aux resolve_uvars s t - | _ -> t - -(* compress: - This is used pervasively, throughout the codebase - - The recommended use for inspecting a term - is to first call compress on it, which should - 1. push delayed substitutions down one level - - 2. eliminate any top-level (Tm_uvar uv) node, - when uv has been assigned a solution already - - `compress` should will *not* memoize the result of uvar - solutions (since those could be reverted), nor the result - of `push_subst` (since it internally uses the unionfind - graph too). - - The function is broken into a fast-path where the - result can be easily determined and a recursive slow - path. - - Warning: if force_uvar changes to operate on inputs other than - Tm_uvar then the fastpath out match in compress will need to be - updated. - - This function should NEVER return a Tm_delayed. If you do any - non-trivial change to it, it would be wise to uncomment the check - below and run a full regression build. -*) -let rec compress_slow (t:term) = - let t = force_uvar t in - match t.n with - | Tm_delayed {tm=t'; substs=s} -> - compress (push_subst s t') - | _ -> - t -and compress (t:term) = - match t.n with - | Tm_delayed _ | Tm_uvar _ -> - let r = compress_slow t in - (* begin match r.n with *) - (* | Tm_delayed _ -> failwith "compress attempting to return a Tm_delayed" *) - (* | _ -> () *) - (* end; *) - r - | _ -> - t - -let subst s t = subst' ([s], NoUseRange) t -let set_use_range r t = subst' ([], SomeUseRange (Range.set_def_range r (Range.use_range r))) t -let subst_comp s t = subst_comp' ([s], NoUseRange) t -let subst_bqual s imp = subst_bqual' ([s], NoUseRange) imp -let subst_aqual s imp = subst_aqual' ([s], NoUseRange) imp -let subst_ascription s (asc:ascription) = subst_ascription' ([s], NoUseRange) asc -let subst_decreasing_order s dec = subst_dec_order' ([s], NoUseRange) dec -let subst_residual_comp s rc = - match rc.residual_typ with - | None -> rc - | Some t -> {rc with residual_typ=subst s t |> Some} -let closing_subst (bs:binders) = - List.fold_right (fun b (subst, n) -> (NM(b.binder_bv, n)::subst, n+1)) bs ([], 0) |> fst -let open_binders' bs = - let rec aux bs o = match bs with - | [] -> [], o - | b::bs' -> - let x' = {freshen_bv b.binder_bv with sort=subst o b.binder_bv.sort} in - let imp = subst_bqual o b.binder_qual in - let attrs = b.binder_attrs |> List.map (subst o) in - let o = DB(0, x')::shift_subst 1 o in - let bs', o = aux bs' o in - (S.mk_binder_with_attrs x' imp b.binder_positivity attrs)::bs', o in - aux bs [] -let open_binders (bs:binders) = fst (open_binders' bs) -let open_term' (bs:binders) t = - let bs', opening = open_binders' bs in - bs', subst opening t, opening -let open_term (bs:binders) t = - let b, t, _ = open_term' bs t in - b, t -let open_comp (bs:binders) t = - let bs', opening = open_binders' bs in - bs', subst_comp opening t -let open_ascription bs asc = - let bs', opening = open_binders' bs in - bs', subst_ascription opening asc - -let open_pat (p:pat) : pat & subst_t = - let rec open_pat_aux sub p = - match p.v with - | Pat_constant _ -> p, sub - - | Pat_cons(fv, us_opt, pats) -> - let us_opt = subst_univs_opt [sub] us_opt in - let pats, sub = pats |> List.fold_left (fun (pats, sub) (p, imp) -> - let p, sub = open_pat_aux sub p in - ((p,imp)::pats, sub)) ([], sub) in - {p with v=Pat_cons(fv, us_opt, List.rev pats)}, sub - - | Pat_var x -> - let x' = {freshen_bv x with sort=subst sub x.sort} in - let sub = DB(0, x')::shift_subst 1 sub in - {p with v=Pat_var x'}, sub - - | Pat_dot_term eopt -> - let eopt = U.map_option (subst sub) eopt in - {p with v=Pat_dot_term eopt}, sub - in - open_pat_aux [] p - -let open_branch' (p, wopt, e) = - let p, opening = open_pat p in - let wopt = match wopt with - | None -> None - | Some w -> Some (subst opening w) in - let e = subst opening e in - (p, wopt, e), opening - -let open_branch br = - let br, _ = open_branch' br in - br - -let close (bs:binders) t = subst (closing_subst bs) t -let close_comp (bs:binders) (c:comp) = subst_comp (closing_subst bs) c -let close_binders (bs:binders) : binders = - let rec aux s (bs:binders) = match bs with - | [] -> [] - | b::tl -> - let x = {b.binder_bv with sort=subst s b.binder_bv.sort} in - let imp = subst_bqual s b.binder_qual in - let attrs = b.binder_attrs |> List.map (subst s) in - let s' = NM(x, 0)::shift_subst 1 s in - (S.mk_binder_with_attrs x imp b.binder_positivity attrs)::aux s' tl in - aux [] bs -let close_ascription (bs:binders) (asc:ascription) = - subst_ascription (closing_subst bs) asc - -let close_pat p = - let rec aux sub p = match p.v with - | Pat_constant _ -> p, sub - - | Pat_cons(fv, us_opt, pats) -> - let us_opt = subst_univs_opt [sub] us_opt in - let pats, sub = pats |> List.fold_left (fun (pats, sub) (p, imp) -> - let p, sub = aux sub p in - ((p,imp)::pats, sub)) ([], sub) in - {p with v=Pat_cons(fv, us_opt, List.rev pats)}, sub - - | Pat_var x -> - let x = {x with sort=subst sub x.sort} in - let sub = NM(x, 0)::shift_subst 1 sub in - {p with v=Pat_var x}, sub - - | Pat_dot_term eopt -> - let eopt = U.map_option (subst sub) eopt in - {p with v=Pat_dot_term eopt}, sub in - aux [] p - -let close_branch (p, wopt, e) = - let p, closing = close_pat p in - let wopt = match wopt with - | None -> None - | Some w -> Some (subst closing w) in - let e = subst closing e in - (p, wopt, e) - -let univ_var_opening (us:univ_names) = - let n = List.length us - 1 in - let s = us |> List.mapi (fun i u -> UN(n - i, U_name u)) in - s, us - -let univ_var_closing (us:univ_names) = - let n = List.length us - 1 in - us |> List.mapi (fun i u -> UD(u, n - i)) - -let open_univ_vars (us:univ_names) (t:term) : univ_names & term = - let s, us' = univ_var_opening us in - let t = subst s t in - us', t - -let open_univ_vars_comp (us:univ_names) (c:comp) : univ_names & comp = - let s, us' = univ_var_opening us in - us', subst_comp s c - -let close_univ_vars (us:univ_names) (t:term) : term = - let s = univ_var_closing us in - subst s t - -let close_univ_vars_comp (us:univ_names) (c:comp) : comp = - let n = List.length us - 1 in - let s = us |> List.mapi (fun i u -> UD(u, n - i)) in - subst_comp s c - -let open_let_rec lbs (t:term) = - let n_let_recs, lbs, let_rec_opening = - if is_top_level lbs - then 0, lbs, [] //top-level let recs are not opened, - //but we still have to open their universe binders, - //if any (see below) - else List.fold_right - (fun lb (i, lbs, out) -> - let x = Syntax.freshen_bv (left lb.lbname) in - i+1, {lb with lbname=Inl x}::lbs, DB(i, x)::out) - lbs - (0, [], []) - in - (* Consider - let rec f x = g x - and g y = f y in - f 0, g 0 - In de Bruijn notation, this is - let rec f x = g@1 x@0 - and g y = f@2 y@0 in - f@1 0, g@0 0 - i.e., the recursive environment for f is, in order: - u, f, g, x - for g is - u, f, g, y - and for the body is - f, g - - See FStar.Util.check_mutual_universes - - We maintain an invariant that all the letbindings - in a mutually recursive nest abstract over the - same sequence of universes - *) - let _, us, u_let_rec_opening = - List.fold_right - (fun u (i, us, out) -> - let u = Syntax.new_univ_name None in - i+1, u::us, UN(i, U_name u)::out) - (List.hd lbs).lbunivs - (n_let_recs, [], let_rec_opening) - in - let lbs = lbs |> List.map (fun lb -> - {lb with lbunivs=us; - lbdef=subst u_let_rec_opening lb.lbdef; - lbtyp=subst u_let_rec_opening lb.lbtyp}) - in - let t = subst let_rec_opening t in - lbs, t - -let close_let_rec lbs (t:term) = - let n_let_recs, let_rec_closing = - if is_top_level lbs - then 0, [] //top-level let recs do not have to be closed - //except for their universe binders, if any (see below) - else List.fold_right - (fun lb (i, out) -> i+1, NM(left lb.lbname, i)::out) - lbs - (0, []) - in - let _, u_let_rec_closing = - List.fold_right - (fun u (i, out) -> i+1, UD(u, i)::out) - (List.hd lbs).lbunivs - (n_let_recs, let_rec_closing) - in - let lbs = lbs |> List.map (fun lb -> - {lb with lbdef=subst u_let_rec_closing lb.lbdef; - lbtyp=subst u_let_rec_closing lb.lbtyp}) - in - let t = subst let_rec_closing t in - lbs, t - -let close_tscheme (binders:binders) ((us, t) : tscheme) = - let n = List.length binders - 1 in - let k = List.length us in - let s = List.mapi (fun i b -> NM(b.binder_bv, k + (n - i))) binders in - let t = subst s t in - (us, t) - -let close_univ_vars_tscheme (us:univ_names) ((us', t):tscheme) = - let n = List.length us - 1 in - let k = List.length us' in - let s = List.mapi (fun i x -> UD(x, k + (n - i))) us in - (us', subst s t) - -let subst_tscheme (s:list subst_elt) ((us, t):tscheme) = - let s = shift_subst (List.length us) s in - (us, subst s t) - -let opening_of_binders (bs:binders) = - let n = List.length bs - 1 in - bs |> List.mapi (fun i b -> DB(n - i, b.binder_bv)) - -let closing_of_binders (bs:binders) = closing_subst bs - -let open_term_1 b t = - match open_term [b] t with - | [b], t -> b, t - | _ -> failwith "impossible: open_term_1" - -let open_term_bvs bvs t = - let bs, t = open_term (List.map mk_binder bvs) t in - List.map (fun b -> b.binder_bv) bs, t - -let open_term_bv bv t = - match open_term_bvs [bv] t with - | [bv], t -> bv, t - | _ -> failwith "impossible: open_term_bv" diff --git a/src/syntax/FStar.Syntax.Subst.fsti b/src/syntax/FStar.Syntax.Subst.fsti deleted file mode 100644 index 647898fba76..00000000000 --- a/src/syntax/FStar.Syntax.Subst.fsti +++ /dev/null @@ -1,83 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Syntax.Subst -open FStar.Compiler.Effect - -open FStar -open FStar.Compiler -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.Compiler.Util - -val shift_subst: int -> subst_t -> subst_t -val subst: list subst_elt -> term -> term -val subst': subst_ts -> term -> term -val subst_comp: list subst_elt -> comp -> comp -val subst_bqual: list subst_elt -> bqual -> bqual -val subst_aqual: list subst_elt -> aqual -> aqual -val subst_ascription: list subst_elt -> ascription -> ascription -val subst_decreasing_order: - list subst_elt -> decreases_order -> decreases_order -val subst_binder: list subst_elt -> binder -> binder -val subst_binders: list subst_elt -> binders -> binders -val subst_residual_comp:list subst_elt -> residual_comp -> residual_comp -val compress: term -> term -val compress_univ: universe -> universe - -// -// It pushes delayed substitutions down, -// but does not resolve uvars -// -// Whereas compress does both -// -val compress_subst: term -> term - -val close: binders -> term -> term -val close_comp: binders -> comp -> comp -val close_binders: binders -> binders -val close_ascription: binders -> ascription -> ascription -val close_branch: branch -> branch -val close_univ_vars: univ_names -> term -> term -val close_univ_vars_comp: univ_names -> comp -> comp -val close_let_rec: list letbinding -> term -> list letbinding & term -val closing_of_binders: binders -> subst_t - -val open_binders': binders -> binders & subst_t -val open_binders: binders -> binders -val open_term: binders -> term -> binders & term -val open_term': binders -> term -> binders & term & subst_t -val open_comp: binders -> comp -> binders & comp -val open_ascription: binders -> ascription -> binders & ascription -val open_branch: branch -> branch -val open_branch': branch -> branch & subst_t -val open_let_rec: list letbinding -> term -> list letbinding & term -val open_univ_vars: univ_names -> term -> univ_names & term -val open_univ_vars_comp:univ_names -> comp -> univ_names & comp -val opening_of_binders: binders -> subst_t - -val subst_tscheme: list subst_elt -> tscheme -> tscheme -val close_tscheme: binders -> tscheme -> tscheme -val close_univ_vars_tscheme: univ_names -> tscheme -> tscheme - -val univ_var_opening: univ_names -> list subst_elt & list univ_name -val univ_var_closing: univ_names -> list subst_elt - -val set_use_range: Range.range -> term -> term - -(* Helpers *) -val open_term_1 : binder -> term -> binder & term -val open_term_bvs : list bv -> term -> list bv & term -val open_term_bv : bv -> term -> bv & term diff --git a/src/syntax/FStar.Syntax.Syntax.fst b/src/syntax/FStar.Syntax.Syntax.fst deleted file mode 100644 index ac634477c63..00000000000 --- a/src/syntax/FStar.Syntax.Syntax.fst +++ /dev/null @@ -1,667 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or impliedmk_ - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Syntax.Syntax -open FStar.Compiler.Effect -open FStar.Compiler.List -(* Type definitions for the core AST *) - -open FStar -open FStar.Compiler -open FStar.Compiler.Util -open FStar.Compiler.Range -open FStar.Ident -open FStar.Const -open FStar.Dyn -open FStar.VConfig - -open FStar.Class.Ord -open FStar.Class.HasRange -open FStar.Class.Setlike - -module O = FStar.Options -module PC = FStar.Parser.Const -module Err = FStar.Errors -module GS = FStar.GenSym -module FlatSet = FStar.Compiler.FlatSet - -let pragma_to_string (p:pragma) : string = - match p with - | ShowOptions -> "#show-options" - | ResetOptions None -> "#reset-options" - | ResetOptions (Some s) -> format1 "#reset-options \"%s\"" s - | SetOptions s -> format1 "#set-options \"%s\"" s - | PushOptions None -> "#push-options" - | PushOptions (Some s) -> format1 "#push-options \"%s\"" s - | RestartSolver -> "#restart-solver" - | PrintEffectsGraph -> "#print-effects-graph" - | PopOptions -> "#pop-options" - -instance showable_pragma = { - show = pragma_to_string; -} - -let rec emb_typ_to_string = function - | ET_abstract -> "abstract" - | ET_app (h, []) -> h - | ET_app(h, args) -> "(" ^h^ " " ^ (List.map emb_typ_to_string args |> String.concat " ") ^")" - | ET_fun(a, b) -> "(" ^ emb_typ_to_string a ^ ") -> " ^ emb_typ_to_string b - -instance showable_emb_typ = { - show = emb_typ_to_string; -} - - -let rec delta_depth_to_string = function - | Delta_constant_at_level i -> "Delta_constant_at_level " ^ string_of_int i - | Delta_equational_at_level i -> "Delta_equational_at_level " ^ string_of_int i - | Delta_abstract d -> "Delta_abstract (" ^ delta_depth_to_string d ^ ")" - -instance showable_delta_depth = { - show = delta_depth_to_string; -} - -instance showable_should_check_uvar = { - show = (function - | Allow_unresolved s -> "Allow_unresolved " ^ s - | Allow_untyped s -> "Allow_untyped " ^ s - | Allow_ghost s -> "Allow_ghost " ^ s - | Strict -> "Strict" - | Already_checked -> "Already_checked"); -} - -// This is set in FStar.Main.main, where all modules are in-scope. -let lazy_chooser : ref (option (lazy_kind -> lazyinfo -> term)) = mk_ref None - -let is_internal_qualifier (q:qualifier) : bool = - match q with - | Visible_default - | Discriminator _ - | Projector _ - | RecordType _ - | RecordConstructor _ - | Action _ - | ExceptionConstructor - | HasMaskedEffect - | Effect - | OnlyName - | InternalAssumption -> - true - | _ -> - false - -instance showable_indexed_effect_binder_kind : showable indexed_effect_binder_kind = { - show = (function - | Type_binder -> "Type_binder" - | Substitutive_binder -> "Substitutive_binder" - | BindCont_no_abstraction_binder -> "BindCont_no_abstraction_binder" - | Range_binder -> "Range_binder" - | Repr_binder -> "Repr_binder" - | Ad_hoc_binder -> "Ad_hoc_binder" - ); -} - -instance tagged_indexed_effect_binder_kind : tagged indexed_effect_binder_kind = { - tag_of = (function - | Type_binder -> "Type_binder" - | Substitutive_binder -> "Substitutive_binder" - | BindCont_no_abstraction_binder -> "BindCont_no_abstraction_binder" - | Range_binder -> "Range_binder" - | Repr_binder -> "Repr_binder" - | Ad_hoc_binder -> "Ad_hoc_binder" - ); -} - -instance showable_indexed_effect_combinator_kind : showable indexed_effect_combinator_kind = { - show = (function - | Substitutive_combinator ks -> "Substitutive_combinator " ^ show ks - | Substitutive_invariant_combinator -> "Substitutive_invariant_combinator" - | Ad_hoc_combinator -> "Ad_hoc_combinator" - ); -} - -instance tagged_indexed_effect_combinator_kind : tagged indexed_effect_combinator_kind = { - tag_of = (function - | Substitutive_combinator _ -> "Substitutive_combinator" - | Substitutive_invariant_combinator -> "Substitutive_invariant_combinator" - | Ad_hoc_combinator -> "Ad_hoc_combinator" - ); -} - -instance showable_eff_extraction_mode : showable eff_extraction_mode = { - show = (function - | Extract_none s -> "Extract_none " ^ s - | Extract_reify -> "Extract_reify" - | Extract_primitive -> "Extract_primitive" - ); -} - -instance tagged_eff_extraction_mode : tagged eff_extraction_mode = { - tag_of = (function - | Extract_none _ -> "Extract_none" - | Extract_reify -> "Extract_reify" - | Extract_primitive -> "Extract_primitive" - ); -} - -let mod_name (m: modul) = m.name - -let contains_reflectable (l: list qualifier): bool = - Util.for_some (function Reflectable _ -> true | _ -> false) l - -(*********************************************************************************) -(* Identifiers to/from strings *) -(*********************************************************************************) -let withinfo v r = {v=v; p=r} -let withsort v = withinfo v dummyRange - -let order_bv (x y : bv) : int = x.index - y.index -let bv_eq (x y : bv) : bool = order_bv x y = 0 - -let order_ident x y = String.compare (string_of_id x) (string_of_id y) -let order_fv x y = String.compare (string_of_lid x) (string_of_lid y) - -let range_of_lbname (l:lbname) = match l with - | Inl x -> range_of_id x.ppname - | Inr fv -> range_of_lid fv.fv_name.v -let range_of_bv x = range_of_id x.ppname - -let set_range_of_bv x r = {x with ppname = set_id_range r x.ppname } - - -(* Helpers *) -let on_antiquoted (f : (term -> term)) (qi : quoteinfo) : quoteinfo = - let (s, aqs) = qi.antiquotations in - let aqs' = List.map f aqs in - { qi with antiquotations = (s, aqs') } - -(* Requires that bv.index is in scope. *) -let lookup_aq (bv : bv) (aq : antiquotations) : term = - try List.nth (snd aq) (List.length (snd aq) - 1 - bv.index + fst aq) // subtract shift - with - | _ -> - failwith "antiquotation out of bounds" - -(*********************************************************************************) -(* Syntax builders *) -(*********************************************************************************) - -// Cleanup this mess please -let deq_instance_from_cmp f = { - (=?) = (fun x y -> Order.eq (f x y)); -} -let ord_instance_from_cmp f = { - super = deq_instance_from_cmp f; - cmp = f; -} -let order_univ_name x y = String.compare (Ident.string_of_id x) (Ident.string_of_id y) - -instance deq_bv : deq bv = - deq_instance_from_cmp (fun x y -> Order.order_from_int (order_bv x y)) -instance deq_ident : deq ident = - deq_instance_from_cmp (fun x y -> Order.order_from_int (order_ident x y)) -instance deq_fv : deq lident = - deq_instance_from_cmp (fun x y -> Order.order_from_int (order_fv x y)) -instance deq_univ_name : deq univ_name = - deq_instance_from_cmp (fun x y -> Order.order_from_int (order_univ_name x y)) -instance deq_delta_depth : deq delta_depth = { - (=?) = (fun x y -> x = y); -} - -instance ord_bv : ord bv = - ord_instance_from_cmp (fun x y -> Order.order_from_int (order_bv x y)) -instance ord_ident : ord ident = - ord_instance_from_cmp (fun x y -> Order.order_from_int (order_ident x y)) -instance ord_fv : ord lident = - ord_instance_from_cmp (fun x y -> Order.order_from_int (order_fv x y)) - -let syn p k f = f k p -let mk_fvs () = Util.mk_ref None -let mk_uvs () = Util.mk_ref None - -//let memo_no_uvs = Util.mk_ref (Some no_uvs) -//let memo_no_names = Util.mk_ref (Some no_names) -let list_of_freenames (fvs:freenames) = elems fvs - -(* Constructors for each term form; NO HASH CONSING; just makes all the auxiliary data at each node *) -let mk (t:'a) r = { - n=t; - pos=r; - vars=Util.mk_ref None; - hash_code=Util.mk_ref None; -} - -let bv_to_tm bv :term = mk (Tm_bvar bv) (range_of_bv bv) -let bv_to_name bv :term = mk (Tm_name bv) (range_of_bv bv) -let binders_to_names (bs:binders) : list term = bs |> List.map (fun b -> bv_to_name b.binder_bv) -let mk_Tm_app (t1:typ) (args:list arg) p = - match args with - | [] -> t1 - | _ -> mk (Tm_app {hd=t1; args}) p -let mk_Tm_uinst (t:term) (us:universes) = - match t.n with - | Tm_fvar _ -> - begin match us with - | [] -> t - | us -> mk (Tm_uinst(t, us)) t.pos - end - | _ -> failwith "Unexpected universe instantiation" - -let extend_app_n t args' r = match t.n with - | Tm_app {hd; args} -> mk_Tm_app hd (args@args') r - | _ -> mk_Tm_app t args' r -let extend_app t arg r = extend_app_n t [arg] r -let mk_Tm_delayed lr pos : term = mk (Tm_delayed {tm=fst lr; substs=snd lr}) pos -let mk_Total t = mk (Total t) t.pos -let mk_GTotal t : comp = mk (GTotal t) t.pos -let mk_Comp (ct:comp_typ) : comp = mk (Comp ct) ct.result_typ.pos -let mk_lb (x, univs, eff, t, e, attrs, pos) = { - lbname=x; - lbunivs=univs; - lbtyp=t; - lbeff=eff; - lbdef=e; - lbattrs=attrs; - lbpos=pos; - } - -let mk_Tac t = - mk_Comp ({ comp_univs = [U_zero]; - effect_name = PC.effect_Tac_lid; - result_typ = t; - effect_args = []; - flags = [SOMETRIVIAL; TRIVIAL_POSTCONDITION]; - }) - -let default_sigmeta = { - sigmeta_active=true; - sigmeta_fact_db_ids=[]; - sigmeta_spliced=false; - sigmeta_admit=false; - sigmeta_already_checked=false; - sigmeta_extension_data=[] -} -let mk_sigelt (e: sigelt') = { - sigel = e; - sigrng = Range.dummyRange; - sigquals=[]; - sigmeta=default_sigmeta; - sigattrs = [] ; - sigopts = None; - sigopens_and_abbrevs = [] } -let mk_subst (s:subst_t) = s -let extend_subst x s : subst_t = x::s -let argpos (x:arg) = (fst x).pos - -let tun : term = mk (Tm_unknown) dummyRange -let teff : term = mk (Tm_constant Const_effect) dummyRange - -(* no compress call? *) -let is_teff (t:term) = match t.n with - | Tm_constant Const_effect -> true - | _ -> false -(* no compress call? *) -let is_type (t:term) = match t.n with - | Tm_type _ -> true - | _ -> false - -(* Gen sym *) -let null_id = mk_ident("_", dummyRange) -let null_bv k = {ppname=null_id; index=GS.next_id(); sort=k} - -let is_null_bv (b:bv) = string_of_id b.ppname = string_of_id null_id -let is_null_binder (b:binder) = is_null_bv b.binder_bv -let range_of_ropt = function - | None -> dummyRange - | Some r -> r - -let gen_bv' (id : ident) (r : option Range.range) (t : typ) : bv = - {ppname=id; index=GS.next_id(); sort=t} - -let gen_bv (s : string) (r : option Range.range) (t : typ) : bv = - let id = mk_ident(s, range_of_ropt r) in - gen_bv' id r t - -let new_bv ropt t = gen_bv Ident.reserved_prefix ropt t -let freshen_bv bv = - if is_null_bv bv - then new_bv (Some (range_of_bv bv)) bv.sort - else {bv with index=GS.next_id()} -let mk_binder_with_attrs bv aqual pqual attrs = { - binder_bv = bv; - binder_qual = aqual; - binder_positivity = pqual; - binder_attrs = attrs -} -let mk_binder a = mk_binder_with_attrs a None None [] -let null_binder t : binder = mk_binder (null_bv t) -let imp_tag = Implicit false -let iarg t : arg = t, Some ({ aqual_implicit = true; aqual_attributes = [] }) -let as_arg t : arg = t, None - - -let is_top_level = function - | {lbname=Inr _}::_ -> true - | _ -> false - -let freenames_of_binders (bs:binders) : freenames = - List.fold_right (fun b out -> add b.binder_bv out) bs (empty ()) - -let binders_of_list fvs : binders = (fvs |> List.map (fun t -> mk_binder t)) -let binders_of_freenames (fvs:freenames) = elems fvs |> binders_of_list -let is_bqual_implicit = function Some (Implicit _) -> true | _ -> false -let is_aqual_implicit = function Some { aqual_implicit = b } -> b | _ -> false -let is_bqual_implicit_or_meta = function Some (Implicit _) | Some (Meta _) -> true | _ -> false -let as_bqual_implicit = function true -> Some imp_tag | _ -> None -let as_aqual_implicit = function true -> Some ({aqual_implicit=true; aqual_attributes=[]}) | _ -> None -let pat_bvs (p:pat) : list bv = - let rec aux b p = match p.v with - | Pat_dot_term _ - | Pat_constant _ -> b - | Pat_var x -> x::b - | Pat_cons(_, _, pats) -> List.fold_left (fun b (p, _) -> aux b p) b pats - in - List.rev <| aux [] p - - -let freshen_binder (b:binder) = { b with binder_bv = freshen_bv b.binder_bv } - -let new_univ_name ropt = - let id = GS.next_id() in - mk_ident (Ident.reserved_prefix ^ Util.string_of_int id, range_of_ropt ropt) -let lbname_eq l1 l2 = match l1, l2 with - | Inl x, Inl y -> bv_eq x y - | Inr l, Inr m -> lid_equals l m - | _ -> false -let fv_eq fv1 fv2 = lid_equals fv1.fv_name.v fv2.fv_name.v -let fv_eq_lid fv lid = lid_equals fv.fv_name.v lid - -let set_bv_range bv r = {bv with ppname = set_id_range r bv.ppname} - -let lid_and_dd_as_fv l dq : fv = { - fv_name=withinfo l (range_of_lid l); - fv_qual =dq; -} -let lid_as_fv l dq : fv = { - fv_name=withinfo l (range_of_lid l); - fv_qual =dq; -} -let fv_to_tm (fv:fv) : term = mk (Tm_fvar fv) (range_of_lid fv.fv_name.v) -let fvar_with_dd l dq = fv_to_tm (lid_and_dd_as_fv l dq) -let fvar l dq = fv_to_tm (lid_as_fv l dq) -let lid_of_fv (fv:fv) = fv.fv_name.v -let range_of_fv (fv:fv) = range_of_lid (lid_of_fv fv) -let set_range_of_fv (fv:fv) (r:Range.range) = - {fv with fv_name={fv.fv_name with v=Ident.set_lid_range (lid_of_fv fv) r}} -let has_simple_attribute (l: list term) s = - List.existsb (function - | { n = Tm_constant (Const_string (data, _)) } when data = s -> - true - | _ -> - false - ) l - -// Compares the SHAPE of the patterns, *ignoring bound variables and universes* -let rec eq_pat (p1 : pat) (p2 : pat) : bool = - match p1.v, p2.v with - | Pat_constant c1, Pat_constant c2 -> eq_const c1 c2 - | Pat_cons (fv1, us1, as1), Pat_cons (fv2, us2, as2) -> - if fv_eq fv1 fv2 - && List.length as1 = List.length as2 - then List.forall2 (fun (p1, b1) (p2, b2) -> b1 = b2 && eq_pat p1 p2) as1 as2 - && (match us1, us2 with - | None, None -> true - | Some us1, Some us2 -> - List.length us1 = List.length us2 - | _ -> false) - else false - | Pat_var _, Pat_var _ -> true - | Pat_dot_term _, Pat_dot_term _ -> true - | _, _ -> false - -/////////////////////////////////////////////////////////////////////// -//Some common constants -/////////////////////////////////////////////////////////////////////// -let delta_constant = Delta_constant_at_level 0 -let delta_equational = Delta_equational_at_level 0 -let fvconst l = lid_and_dd_as_fv l None -let tconst l = mk (Tm_fvar (fvconst l)) Range.dummyRange -let tabbrev l = mk (Tm_fvar(lid_and_dd_as_fv l None)) Range.dummyRange -let tdataconstr l = fv_to_tm (lid_and_dd_as_fv l (Some Data_ctor)) -let t_unit = tconst PC.unit_lid -let t_bool = tconst PC.bool_lid -let t_int = tconst PC.int_lid -let t_string = tconst PC.string_lid -let t_exn = tconst PC.exn_lid -let t_real = tconst PC.real_lid -let t_float = tconst PC.float_lid -let t_char = tabbrev PC.char_lid -let t_range = tconst PC.range_lid -let t___range = tconst PC.__range_lid -let t_vconfig = tconst PC.vconfig_lid -let t_term = tconst PC.term_lid -let t_term_view = tabbrev PC.term_view_lid -let t_order = tconst PC.order_lid -let t_decls = tabbrev PC.decls_lid -let t_binder = tconst PC.binder_lid -let t_binders = tconst PC.binders_lid -let t_bv = tconst PC.bv_lid -let t_fv = tconst PC.fv_lid -let t_norm_step = tconst PC.norm_step_lid -let t_tac_of a b = - mk_Tm_app (mk_Tm_uinst (tabbrev PC.tac_lid) [U_zero; U_zero]) - [as_arg a; as_arg b] Range.dummyRange -let t_tactic_of t = - mk_Tm_app (mk_Tm_uinst (tabbrev PC.tactic_lid) [U_zero]) - [as_arg t] Range.dummyRange - -let t_tactic_unit = t_tactic_of t_unit - -(* - * AR: what's up with all the U_zero below? - *) -let t_list_of t = mk_Tm_app - (mk_Tm_uinst (tabbrev PC.list_lid) [U_zero]) - [as_arg t] - Range.dummyRange -let t_option_of t = mk_Tm_app - (mk_Tm_uinst (tabbrev PC.option_lid) [U_zero]) - [as_arg t] - Range.dummyRange -let t_tuple2_of t1 t2 = mk_Tm_app - (mk_Tm_uinst (tabbrev PC.lid_tuple2) [U_zero;U_zero]) - [as_arg t1; as_arg t2] - Range.dummyRange -let t_tuple3_of t1 t2 t3 = mk_Tm_app - (mk_Tm_uinst (tabbrev PC.lid_tuple3) [U_zero;U_zero;U_zero]) - [as_arg t1; as_arg t2; as_arg t3] - Range.dummyRange -let t_tuple4_of t1 t2 t3 t4 = mk_Tm_app - (mk_Tm_uinst (tabbrev PC.lid_tuple4) [U_zero;U_zero;U_zero;U_zero]) - [as_arg t1; as_arg t2; as_arg t3; as_arg t4] - Range.dummyRange -let t_tuple5_of t1 t2 t3 t4 t5 = mk_Tm_app - (mk_Tm_uinst (tabbrev PC.lid_tuple5) [U_zero;U_zero;U_zero;U_zero;U_zero]) - [as_arg t1; as_arg t2; as_arg t3; as_arg t4; as_arg t5] - Range.dummyRange -let t_either_of t1 t2 = mk_Tm_app - (mk_Tm_uinst (tabbrev PC.either_lid) [U_zero;U_zero]) - [as_arg t1; as_arg t2] - Range.dummyRange -let t_sealed_of t = mk_Tm_app - (mk_Tm_uinst (tabbrev PC.sealed_lid) [U_zero]) - [as_arg t] - Range.dummyRange -let t_erased_of t = mk_Tm_app - (mk_Tm_uinst (tabbrev PC.erased_lid) [U_zero]) - [as_arg t] - Range.dummyRange - -let unit_const_with_range r = mk (Tm_constant FStar.Const.Const_unit) r -let unit_const = unit_const_with_range Range.dummyRange - -instance show_restriction: showable restriction = { - show = (function - | Unrestricted -> "Unrestricted" - | AllowList allow_list -> "(AllowList " ^ show allow_list ^ ")") -} - -let is_ident_allowed_by_restriction' id - = function | Unrestricted -> Some id - | AllowList allow_list -> - map_opt (find FStar.Class.Deq.(fun (dest_id, renamed_id) -> - dflt dest_id renamed_id =? id - ) allow_list) fst - -let is_ident_allowed_by_restriction - = let debug = FStar.Compiler.Debug.get_toggle "open_include_restrictions" in - fun id restriction -> - let result = is_ident_allowed_by_restriction' id restriction in - if !debug then print_endline ( "is_ident_allowed_by_restriction(" ^ show id ^ ", " - ^ show restriction ^ ") = " - ^ show result ); - result - -instance has_range_syntax #a (_:unit) : Tot (hasRange (syntax a)) = { - pos = (fun (t:syntax a) -> t.pos); - setPos = (fun r t -> { t with pos = r }); -} - -instance has_range_withinfo #a (_:unit) : Tot (hasRange (withinfo_t a)) = { - pos = (fun t -> t.p); - setPos = (fun r t -> { t with p = r }); -} - -instance has_range_sigelt : hasRange sigelt = { - pos = (fun t -> t.sigrng); - setPos = (fun r t -> { t with sigrng = r }); -} - -instance hasRange_fv : hasRange fv = { - pos = range_of_fv; - setPos = (fun r f -> set_range_of_fv f r); -} - -instance hasRange_bv : hasRange bv = { - pos = range_of_bv; - setPos = (fun r f -> set_range_of_bv f r); -} - -instance hasRange_binder : hasRange binder = { - pos = (fun b -> pos b.binder_bv); - setPos = (fun r b -> { b with binder_bv = setPos r b.binder_bv }); -} - -instance showable_lazy_kind = { - show = (function - | BadLazy -> "BadLazy" - | Lazy_bv -> "Lazy_bv" - | Lazy_namedv -> "Lazy_namedv" - | Lazy_binder -> "Lazy_binder" - | Lazy_optionstate -> "Lazy_optionstate" - | Lazy_fvar -> "Lazy_fvar" - | Lazy_comp -> "Lazy_comp" - | Lazy_env -> "Lazy_env" - | Lazy_proofstate -> "Lazy_proofstate" - | Lazy_goal -> "Lazy_goal" - | Lazy_sigelt -> "Lazy_sigelt" - | Lazy_letbinding -> "Lazy_letbinding" - | Lazy_uvar -> "Lazy_uvar" - | Lazy_universe -> "Lazy_universe" - | Lazy_universe_uvar -> "Lazy_universe_uvar" - | Lazy_issue -> "Lazy_issue" - | Lazy_doc -> "Lazy_doc" - | Lazy_ident -> "Lazy_ident" - | Lazy_tref -> "Lazy_tref" - | Lazy_embedding _ -> "Lazy_embedding _" - | Lazy_extension s -> "Lazy_extension " ^ s - | _ -> failwith "FIXME! lazy_kind_to_string must be complete" - ); -} - -instance deq_lazy_kind : deq lazy_kind = { - (=?) = (fun k k' -> -(* NOTE: Lazy_embedding compares false to itself, by design. *) - match k, k' with - | BadLazy, BadLazy - | Lazy_bv, Lazy_bv - | Lazy_namedv, Lazy_namedv - | Lazy_binder, Lazy_binder - | Lazy_optionstate, Lazy_optionstate - | Lazy_fvar, Lazy_fvar - | Lazy_comp, Lazy_comp - | Lazy_env, Lazy_env - | Lazy_proofstate, Lazy_proofstate - | Lazy_goal, Lazy_goal - | Lazy_sigelt, Lazy_sigelt - | Lazy_letbinding, Lazy_letbinding - | Lazy_uvar, Lazy_uvar - | Lazy_universe, Lazy_universe - | Lazy_universe_uvar, Lazy_universe_uvar - | Lazy_issue, Lazy_issue - | Lazy_ident, Lazy_ident - | Lazy_doc, Lazy_doc - | Lazy_tref, Lazy_tref - -> true - | Lazy_extension s, Lazy_extension t -> - s = t - | Lazy_embedding _, _ - | _, Lazy_embedding _ -> false - | _ -> false); -} - -instance tagged_term : tagged term = { - tag_of = (fun t -> match t.n with - | Tm_bvar {} -> "Tm_bvar" - | Tm_name {} -> "Tm_name" - | Tm_fvar {} -> "Tm_fvar" - | Tm_uinst {} -> "Tm_uinst" - | Tm_constant _ -> "Tm_constant" - | Tm_type _ -> "Tm_type" - | Tm_quoted (_, {qkind=Quote_static}) -> "Tm_quoted(static)" - | Tm_quoted (_, {qkind=Quote_dynamic}) -> "Tm_quoted(dynamic)" - | Tm_abs {} -> "Tm_abs" - | Tm_arrow {} -> "Tm_arrow" - | Tm_refine {} -> "Tm_refine" - | Tm_app {} -> "Tm_app" - | Tm_match {} -> "Tm_match" - | Tm_ascribed {} -> "Tm_ascribed" - | Tm_let {} -> "Tm_let" - | Tm_uvar {} -> "Tm_uvar" - | Tm_delayed {} -> "Tm_delayed" - | Tm_meta {} -> "Tm_meta" - | Tm_unknown -> "Tm_unknown" - | Tm_lazy {} -> "Tm_lazy" - ); -} - -instance tagged_sigelt : tagged sigelt = { - tag_of = (fun se -> match se.sigel with - | Sig_inductive_typ {} -> "Sig_inductive_typ" - | Sig_bundle {} -> "Sig_bundle" - | Sig_datacon {} -> "Sig_datacon" - | Sig_declare_typ {} -> "Sig_declare_typ" - | Sig_let {} -> "Sig_let" - | Sig_assume {} -> "Sig_assume" - | Sig_new_effect {} -> "Sig_new_effect" - | Sig_sub_effect {} -> "Sig_sub_effect" - | Sig_effect_abbrev {} -> "Sig_effect_abbrev" - | Sig_pragma _ -> "Sig_pragma" - | Sig_splice {} -> "Sig_splice" - | Sig_polymonadic_bind {} -> "Sig_polymonadic_bind" - | Sig_polymonadic_subcomp {} -> "Sig_polymonadic_subcomp" - | Sig_fail {} -> "Sig_fail" - ); -} diff --git a/src/syntax/FStar.Syntax.Syntax.fsti b/src/syntax/FStar.Syntax.Syntax.fsti deleted file mode 100644 index 481970edd56..00000000000 --- a/src/syntax/FStar.Syntax.Syntax.fsti +++ /dev/null @@ -1,960 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Syntax.Syntax -open FStar.Compiler.Effect -(* Type definitions for the core AST *) - -open FStar -open FStar.Compiler -open FStar.Compiler.Util -open FStar.Compiler.Range -open FStar.Ident -open FStar.Dyn -open FStar.Const -module O = FStar.Options -open FStar.VConfig - -include FStar.Class.HasRange -open FStar.Class.Show -open FStar.Class.Deq -open FStar.Class.Ord -open FStar.Class.Tagged - -(* Objects with metadata *) -[@@ PpxDerivingYoJson; PpxDerivingShow ] -type withinfo_t 'a = { - v: 'a; - p: Range.range; -} - -(* Free term and type variables *) -[@@ PpxDerivingYoJson; PpxDerivingShow ] -type var = withinfo_t lident - -(* Term language *) -[@@ PpxDerivingYoJson; PpxDerivingShow ] -type sconst = FStar.Const.sconst - -[@@ PpxDerivingYoJson; PpxDerivingShow ] -type pragma = - | ShowOptions - | SetOptions of string - | ResetOptions of option string - | PushOptions of option string - | PopOptions - | RestartSolver - | PrintEffectsGraph //#print-effects-graph dumps the current effects graph in a dot file named "effects.graph" - -instance val showable_pragma : showable pragma - -[@@ PpxDerivingYoJson; PpxDerivingShowConstant "None" ] -type memo 'a = ref (option 'a) - -(* Simple types used in native compilation - * to record the types of lazily embedded terms - *) -type emb_typ = - | ET_abstract - | ET_fun of emb_typ & emb_typ - | ET_app of string & list emb_typ - -//versioning for unification variables -[@@ PpxDerivingYoJson; PpxDerivingShow ] -type version = { - major:int; - minor:int -} - -[@@ PpxDerivingYoJson; PpxDerivingShow ] -type universe = - | U_zero - | U_succ of universe - | U_max of list universe - | U_bvar of int - | U_name of univ_name - | U_unif of universe_uvar - | U_unknown -and univ_name = ident -and universe_uvar = Unionfind.p_uvar (option universe) & version & Range.range - -[@@ PpxDerivingYoJson; PpxDerivingShow ] -type univ_names = list univ_name - -[@@ PpxDerivingYoJson; PpxDerivingShow ] -type universes = list universe - -[@@ PpxDerivingYoJson; PpxDerivingShow ] -type monad_name = lident - -[@@ PpxDerivingYoJson; PpxDerivingShow ] -type quote_kind = - | Quote_static - | Quote_dynamic - -[@@ PpxDerivingYoJson; PpxDerivingShow ] -type maybe_set_use_range = - | NoUseRange - | SomeUseRange of range - -[@@ PpxDerivingYoJson; PpxDerivingShow ] -type delta_depth = - | Delta_constant_at_level of int - // ^ A symbol that can be unfolded n times to a term whose head is a - // constant, e.g., nat is (Delta_constant_at_level 1) to int, level 0 - // is a literal constant. - | Delta_equational_at_level of int - // ^ Level 0 is a symbol that may be equated to another by - // extensional reasoning, n > 0 can be unfolded n times to a - // Delta_equational_at_level 0 term. - | Delta_abstract of delta_depth - // ^ A symbol marked abstract whose depth is the argument d. - -[@@ PpxDerivingYoJson; PpxDerivingShow ] -type should_check_uvar = - | Allow_unresolved of string (* Escape hatch for uvars in logical guards that are sometimes left unresolved *) - | Allow_untyped of string (* Escape hatch to not re-typecheck guards in WPs and types of pattern bound vars *) - | Allow_ghost of string (* In some cases, e.g., in ctrl_rewrite, we introduce uvars in Ghost context *) - | Strict (* Strict uvar that must be typechecked *) - | Already_checked (* A uvar whose solution has already been checked *) - -type positivity_qualifier = - | BinderStrictlyPositive - | BinderUnused - -type term' = - | Tm_bvar of bv //bound variable, referenced by de Bruijn index - | Tm_name of bv //local constant, referenced by a unique name derived from bv.ppname and bv.index - | Tm_fvar of fv //fully qualified reference to a top-level symbol from a module - | Tm_uinst of term & universes //universe instantiation; the first argument must be one of the three constructors above - | Tm_constant of sconst - | Tm_type of universe - | Tm_abs { (* fun (xi:ti) -> t : (M t' wp | N) *) - bs:binders; - body:term; - rc_opt:option residual_comp - } - | Tm_arrow { (* (xi:ti) -> M t' wp *) - bs:binders; - comp:comp - } - | Tm_refine { (* x:t{phi} *) - b:bv; - phi:term - } - | Tm_app { (* h tau_1 ... tau_n, args in order from left to right *) - hd:term; - args:args - } - | Tm_match { (* (match e (as x returns asc)? with b1 ... bn) : (C | N)) *) - scrutinee:term; - ret_opt:option match_returns_ascription; - brs:list branch; - rc_opt:option residual_comp - } - | Tm_ascribed { (* an effect label is the third arg, filled in by the type-checker *) - tm:term; - asc:ascription; - eff_opt:option lident - } - | Tm_let { (* let (rec?) x1 = e1 AND ... AND xn = en in e *) - lbs:letbindings; - body:term - } - | Tm_uvar of ctx_uvar_and_subst (* A unification variable ?u (aka meta-variable) - and a delayed substitution of only NM or NT elements *) - | Tm_delayed { (* A delayed substitution --- always force it; never inspect it directly *) - tm:term; - substs:subst_ts - } - | Tm_meta { (* Some terms carry metadata, for better code generation, SMT encoding etc. *) - tm:term; - meta:metadata - } - | Tm_lazy of lazyinfo (* A lazily encoded term *) - | Tm_quoted of term & quoteinfo (* A quoted term, in one of its many variants *) - | Tm_unknown (* only present initially while desugaring a term *) -and ctx_uvar = { (* (G |- ?u : t), a uvar introduced in context G at type t *) - ctx_uvar_head:uvar; (* ?u *) - ctx_uvar_gamma:gamma; (* G: a cons list of bindings (most recent at the head) *) - ctx_uvar_binders:binders; (* All the Tm_name bindings in G, a snoc list (most recent at the tail) *) - ctx_uvar_reason:string; - ctx_uvar_range:Range.range; - ctx_uvar_meta: option ctx_uvar_meta_t; -} -and ctx_uvar_meta_t = - | Ctx_uvar_meta_tac of term - | Ctx_uvar_meta_attr of term (* An attribute associated with an implicit argument using the #[@@@ defer_to ...] notation *) -and ctx_uvar_and_subst = ctx_uvar & subst_ts - -and uvar_decoration = { - uvar_decoration_typ:typ; - uvar_decoration_typedness_depends_on:list ctx_uvar; - uvar_decoration_should_check:should_check_uvar; - uvar_decoration_should_unrefine:bool; -} - -and uvar = Unionfind.p_uvar (option term & uvar_decoration) & version & Range.range -and uvars = FlatSet.t ctx_uvar -and match_returns_ascription = binder & ascription (* as x returns C|t *) -and branch = pat & option term & term (* optional when clause in each branch *) -and ascription = either term comp & option term & bool (* e <: t [by tac] or e <: C [by tac] *) - (* the bool says whether the ascription is an equality ascription, i.e. $: *) -and pat' = - | Pat_constant of sconst - | Pat_cons of fv & option universes & list (pat & bool) (* flag marks an explicitly provided implicit *) - | Pat_var of bv (* a pattern bound variable (linear in a pattern) *) - | Pat_dot_term of option term (* dot patterns: determined by other elements in the pattern *) - (* the option term is the optionally resolved pat dot term *) -and letbinding = { //let f : forall u1..un. M t = e - lbname :lbname; // f - lbunivs:list univ_name; // u1..un - lbtyp :typ; // t - lbeff :lident; // M - lbdef :term; // e - lbattrs:list attribute; // attrs - lbpos :range; // original position of 'e' -} -and antiquotations = int & list term -and quoteinfo = { - qkind : quote_kind; - antiquotations : antiquotations; -(************************************************************************* - ANTIQUOTATIONS and shifting - - The antiquotations of a quoted term (Tm_quoted) are kept in the - antiquotations list above. The terms inside that list are not scoped by - any binder *inside* the quoted term, but are affected by substitutions - on the full term as usual. Inside the quoted terms, the points where - antiquotations are spliced in Tm_bvar nodes, where the index of the - bv indexes into the antiquotations list above, where the rightmost - elements is closer in scope. I.e., a term like - - Tm_quoted (Tm_bvar 2, {antiquotations = [a;b;c]}) - - is really just `a`. This makes the representation of antiquotations - more canonical (we previously had freshly-named Tm_names instead). - - Unembedding a Tm_quoted(tm, aq) term will simply take tm and substitute - it appropriately with the information from aq. Every antiquotation must - be a literal term for this to work, and not a variable or an expression - computing a quoted term. - - When extracting or encoding a quoted term to SMT, then, we cannot - simply unembed as the antiquotations are most likely undetermined. For - instance, the extraction of a term like - - Tm_quoted(1 + bvar 0, aq = [ compute_some_term() ]} - - should be something like - - pack_ln (Tv_App (pack_ln (Tv_App (plus, Tv_Const 1)), compute_some_term()). - - To implement this conveniently, we allow _embedding_ terms with - antiquotations, so we can implement extraction basically by: - - extract (Tm_quoted (Tm_bvar i, aq)) = - aq `index` (length aq - 1 - i) - - extract (Tm_quoted (t, aq)) = - let tv = inspect_ln t in - let tv_e = embed_term_view tv aq in - let t' = mk_app pack_ln tv_e in - extract t' - - That is, unfolding one level of the view, enclosing it with a - pack_ln call, and recursing. For this to work, however, we need the - antiquotations to be preserved, hence we pass them to embed_term_view. - The term_view embedding will also take care of *shifting* the - antiquotations (see the int there) when traversing a binder in the - quoted term. Hence, a term like: - - Tm_quoted (fun x -> 1 + x + bvar 1, aqs = [t]), - - will be unfolded to - - Tv_Abs (x, Tm_quoted(1 + bvar0 + bvar1, aqs = [t], shift=1)) - - where the shift is needed to make the bvar1 actually point to t. - -*************************************************************************) -} -and comp_typ = { - comp_univs:universes; - effect_name:lident; - result_typ:typ; - effect_args:args; - flags:list cflag -} -and comp' = - | Total of typ - | GTotal of typ - | Comp of comp_typ -and term = syntax term' -and typ = term (* sometimes we use typ to emphasize that a term is a type *) -and pat = withinfo_t pat' -and comp = syntax comp' -and arg = term & aqual (* marks an explicitly provided implicit arg *) -and args = list arg -and binder = { - binder_bv : bv; - binder_qual : bqual; - binder_positivity : option positivity_qualifier; - binder_attrs : list attribute -} (* f: #[@@ attr] n:nat -> vector n int -> T; f #17 v *) -and binders = list binder (* bool marks implicit binder *) -and decreases_order = - | Decreases_lex of list term (* a decreases clause may either specify a lexicographic ordered list of terms, *) - | Decreases_wf of term & term (* or a well-founded relation and a term *) -and cflag = (* flags applicable to computation types, usually for optimizations *) - | TOTAL (* computation has no real effect, can be reduced safely *) - | MLEFFECT (* the effect is ML (Parser.Const.effect_ML_lid) *) - | LEMMA (* the effect is Lemma (Parser.Const.effect_Lemma_lid) *) - | RETURN (* the WP is return_wp of something *) - | PARTIAL_RETURN (* the WP is return_wp of something, possibly strengthened with some precondition *) - | SOMETRIVIAL (* the WP is the null wp *) - | TRIVIAL_POSTCONDITION (* the computation has no meaningful postcondition *) - | SHOULD_NOT_INLINE (* a stopgap, see issue #1362, removing it revives the failure *) - | CPS (* computation is marked with attribute `cps`, for DM4F, seems useless, see #1557 *) - | DECREASES of decreases_order -and metadata = - | Meta_pattern of list term & list args (* Patterns for SMT quantifier instantiation; the first arg instantiation *) - | Meta_named of lident (* Useful for pretty printing to keep the type abbreviation around *) - | Meta_labeled of list Pprint.document & Range.range & bool (* Sub-terms in a VC are labeled with error messages to be reported, used in SMT encoding *) - | Meta_desugared of meta_source_info (* Node tagged with some information about source term before desugaring *) - | Meta_monadic of monad_name & typ (* Annotation on a Tm_app or Tm_let node in case it is monadic for m not in {Pure, Ghost, Div} *) - (* Contains the name of the monadic effect and the type of the subterm *) - | Meta_monadic_lift of monad_name & monad_name & typ (* Sub-effecting: lift the subterm of type typ *) - (* from the first monad_name m1 to the second monad name m2 *) -and meta_source_info = - | Sequence (* used when resugaring *) - | Primop (* ... add more cases here as needed for better code generation *) - | Masked_effect - | Meta_smt_pat - | Machine_integer of signedness & width -and fv_qual = - | Data_ctor - | Record_projector of (lident & ident) (* the fully qualified (unmangled) name of the data constructor and the field being projected *) - | Record_ctor of lident & list ident (* the type of the record being constructed and its (unmangled) fields in order *) - | Unresolved_projector of option fv (* ToSyntax's best guess at what the projector is (based only on scoping rules) *) - | Unresolved_constructor of unresolved_constructor (* ToSyntax's best guess at what the constructor is (based only on scoping rules) *) -and unresolved_constructor = { - uc_base_term : bool; // The base term is `e` when the user writes `{ e with f1=v1; ... }` - uc_typename: option lident; // The constructed type, as determined by the ToSyntax's scoping rules - uc_fields : list lident // The fields names as written in the source -} -and lbname = either bv fv -and letbindings = bool & list letbinding (* let recs may have more than one element; top-level lets have lidents *) - (* boolean true indicates rec *) -and subst_ts = list (list subst_elt) (* A composition of parallel substitutions *) - & maybe_set_use_range (* and a maybe range update, Some r, to set the use_range of subterms to r.def_range *) -and subst_elt = - | DB of int & bv (* DB i bv: replace a bound variable with index i with name bv *) - | DT of int & term (* DT i t: replace a bound variable with index i for term *) - | NM of bv & int (* NM x i: replace a local name with a bound variable i *) - | NT of bv & term (* NT x t: replace a local name with a term t *) - | UN of int & universe (* UN u v: replace universes variable u with universe term v *) - | UD of univ_name & int (* UD x i: replace universe name x with de Bruijn index i *) -and freenames = FlatSet.t bv -and syntax 'a = { - n:'a; - pos:Range.range; - vars:memo free_vars; - hash_code:memo FStar.Hash.hash_code -} -and bv = { - ppname:ident; //programmer-provided name for pretty-printing - index:int; //de Bruijn index 0-based, counting up from the binder - sort:term -} -and fv = { - fv_name :var; - fv_qual :option fv_qual -} -and free_vars = { - free_names : FlatSet.t bv; - free_uvars : uvars; - free_univs : FlatSet.t universe_uvar; - free_univ_names : FlatSet.t univ_name; //fifo -} - -(* Residual of a computation type after typechecking *) -and residual_comp = { - residual_effect:lident; (* first component is the effect name *) - residual_typ :option typ; (* second component: result type *) - residual_flags :list cflag (* third component: contains (an approximation of) the cflags *) -} - -and attribute = term - -and lazyinfo = { - blob : dyn; - lkind : lazy_kind; - ltyp : typ; - rng : Range.range; -} -// Different kinds of lazy terms. These are used to decide the unfolding -// function, instead of keeping the closure inside the lazy node, since -// that means we cannot have equality on terms (not serious) nor call -// output_value on them (serious). -and lazy_kind = - | BadLazy - | Lazy_bv - | Lazy_namedv - | Lazy_binder - | Lazy_optionstate - | Lazy_fvar - | Lazy_comp - | Lazy_env - | Lazy_proofstate - | Lazy_goal - | Lazy_sigelt - | Lazy_uvar - | Lazy_letbinding - | Lazy_embedding of emb_typ & Thunk.t term - | Lazy_universe - | Lazy_universe_uvar - | Lazy_issue - | Lazy_ident - | Lazy_doc - | Lazy_extension of string - | Lazy_tref -and binding = - | Binding_var of bv - | Binding_lid of lident & (univ_names & typ) - (* ^ Not a tscheme: the universe names must be taken - * as fixed (and opened in the type). This is important since - * we do not support universe-polymorphic recursion. - * See #2106. *) - | Binding_univ of univ_name -and tscheme = list univ_name & typ -and gamma = list binding -and binder_qualifier = - | Implicit of bool //boolean marks an inaccessible implicit argument of a data constructor - | Meta of term //meta-argument that specifies a tactic term - | Equality -and bqual = option binder_qualifier -and arg_qualifier = { - aqual_implicit : bool; - aqual_attributes : list attribute -} -and aqual = option arg_qualifier - -type freenames_l = list bv -type formula = typ -type formulae = list typ - -type qualifier = - | Assumption //no definition provided, just a declaration - | New //a fresh type constant, distinct from all prior type constructors - | Private //name is invisible outside the module - | Unfold_for_unification_and_vcgen //a definition that *should* always be unfolded by the normalizer - | Irreducible //a definition that can never be unfolded by the normalizer - | Inline_for_extraction //a symbol whose definition must be unfolded when compiling the program - | NoExtract // a definition whose contents won't be extracted (currently, by KaRaMeL only) - | Noeq //for this type, don't generate HasEq - | Unopteq //for this type, use the unoptimized HasEq scheme - | TotalEffect //an effect that forbids non-termination - | Logic //a symbol whose intended usage is in the refinement logic - | Reifiable - | Reflectable of lident // with fully qualified effect name - - //the remaining qualifiers are internal: the programmer cannot write them - | Visible_default //a definition that may be unfolded by the normalizer, but only if necessary (default) - | Discriminator of lident //discriminator for a datacon l - | Projector of lident & ident //projector for datacon l's argument x - | RecordType of (list ident & list ident) //record type whose namespace is fst and unmangled field names are snd - | RecordConstructor of (list ident & list ident) //record constructor whose namespace is fst and unmangled field names are snd - | Action of lident //action of some effect - | ExceptionConstructor //a constructor of Prims.exn - | HasMaskedEffect //a let binding that may have a top-level effect - | Effect //qualifier on a name that corresponds to an effect constructor - | OnlyName //qualifier internal to the compiler indicating a dummy declaration which - //is present only for name resolution and will be elaborated at typechecking - | InternalAssumption //an assumption internally generated by F*, e.g. hasEq axioms, not to be reported with --report_assumes - -(* Checks if the qualifer is internal, and should not be written by users. *) -val is_internal_qualifier (q:qualifier) : bool - -type tycon = lident & binders & typ (* I (x1:t1) ... (xn:tn) : t *) -type monad_abbrev = { - mabbrev:lident; - parms:binders; - def:typ - } - -// -// Kind of a binder in an indexed effect combinator -// -type indexed_effect_binder_kind = - | Type_binder - | Substitutive_binder - | BindCont_no_abstraction_binder // a g computation (the continuation) binder in bind that's not abstracted over x:a - | Range_binder - | Repr_binder - | Ad_hoc_binder -instance val showable_indexed_effect_binder_kind : showable indexed_effect_binder_kind -instance val tagged_indexed_effect_binder_kind : tagged indexed_effect_binder_kind - -// -// Kind of an indexed effect combinator -// -// Substitutive invariant applies only to subcomp and ite combinators, -// where the effect indices of the two computations could be the same, -// and hence bound only once in the combinator definitions -// -type indexed_effect_combinator_kind = - | Substitutive_combinator of list indexed_effect_binder_kind - | Substitutive_invariant_combinator - | Ad_hoc_combinator -instance val showable_indexed_effect_combinator_kind : showable indexed_effect_combinator_kind -instance val tagged_indexed_effect_combinator_kind : tagged indexed_effect_combinator_kind - -type sub_eff = { - source:lident; - target:lident; - lift_wp:option tscheme; - lift:option tscheme; - kind:option indexed_effect_combinator_kind - } - -type action = { - action_name:lident; - action_unqualified_name: ident; // necessary for effect redefinitions, this name shall not contain the name of the effect - action_univs:univ_names; - action_params : binders; - action_defn:term; - action_typ: typ -} - -(* - * Effect combinators for wp-based effects - * - * This includes both primitive effects (such as PURE, DIV) - * as well as user-defined DM4F effects - * - * repr, return_repr, and bind_repr are optional, and are set only for reifiable effects - * - * For DM4F effects, ret_wp, bind_wp, and other wp combinators are derived and populated by the typechecker - * These fields are dummy ts ([], Tm_unknown) after desugaring - * - * We could add another boolean, elaborated somewhere - *) - -type wp_eff_combinators = { - ret_wp : tscheme; - bind_wp : tscheme; - stronger : tscheme; - if_then_else : tscheme; - ite_wp : tscheme; - close_wp : tscheme; - trivial : tscheme; - - repr : option tscheme; - return_repr : option tscheme; - bind_repr : option tscheme -} - - -(* - * Layered effects combinators - * - * All of these have pairs of type schemes, - * where the first component is the term ts and the second component is the type ts - * - * Before typechecking the effect declaration, the second component is a dummy ts - * In other words, desugaring sets the first component only, and typechecker then fills up the second one - * - * Additionally, bind, subcomp, and if_then_else have a combinator kind, - * this is also set to None in desugaring and set during typechecking the effect - * - * The close combinator is optional - * If it is not provided as part of the effect declaration, - * the typechecker also does not synthesize it (unlike if-then-else and subcomp) - *) -type layered_eff_combinators = { - l_repr : (tscheme & tscheme); - l_return : (tscheme & tscheme); - l_bind : (tscheme & tscheme & option indexed_effect_combinator_kind); - l_subcomp : (tscheme & tscheme & option indexed_effect_combinator_kind); - l_if_then_else : (tscheme & tscheme & option indexed_effect_combinator_kind); - l_close : option (tscheme & tscheme) -} - -type eff_combinators = - | Primitive_eff of wp_eff_combinators - | DM4F_eff of wp_eff_combinators - | Layered_eff of layered_eff_combinators - -type effect_signature = - | Layered_eff_sig of int & tscheme // (n, ts) where n is the number of effect parameters (all upfront) in the effect signature - | WP_eff_sig of tscheme - -// -// For primitive and DM4F effects, this is set in ToSyntax -// For indexed effects, typechecker sets it (in TcEffect) -// -type eff_extraction_mode = - | Extract_none of string // Effect cannot be extracted - | Extract_reify // Effect can be extracted with reification - | Extract_primitive // Effect is primitive - -instance val showable_eff_extraction_mode : showable eff_extraction_mode -instance val tagged_eff_extraction_mode : tagged eff_extraction_mode - -(* - new_effect { - STATE_h (heap:Type) : result:Type -> wp:st_wp_h heap result -> Effect - with return .... - } -*) -type eff_decl = { - mname : lident; // STATE_h - - cattributes : list cflag; - - univs : univ_names; // u#heap - binders : binders; // (heap:Type u#heap), univs and binders are in the scope of the rest of the combinators - - signature : effect_signature; - - combinators : eff_combinators; - - actions : list action; - - eff_attrs : list attribute; - - extraction_mode : eff_extraction_mode; -} - - -type sig_metadata = { - sigmeta_active:bool; - sigmeta_fact_db_ids:list string; - sigmeta_admit:bool; //An internal flag to record that a sigelt's SMT proof should be admitted - //Used in DM4Free - sigmeta_spliced:bool; - sigmeta_already_checked:bool; - // ^ This sigelt was created from a splice_t with a proof of well-typing, - // and does not need to be checked again. - sigmeta_extension_data: list (string & dyn) //each extension can register some data with a sig -} - - -type open_kind = (* matters only for resolving names with some module qualifier *) -| Open_module (* only opens the module, not the namespace *) -| Open_namespace - -type ident_alias = option ident - -(** A restriction imposed on a `open` or `include` declaration. *) -type restriction = - (** No restriction, the entire module is opened or included. *) - | Unrestricted - (** Only a specific subset of the exported definition of a module is opened or included. *) - | AllowList of list (ident & ident_alias) - -type open_module_or_namespace = (lident & open_kind & restriction) (* lident fully qualified name, already resolved. *) -type module_abbrev = (ident & lident) (* module X = A.B.C, where A.B.C is fully qualified and already resolved *) - -(* - * AR: we no longer have Sig_new_effect_for_free - * Sig_new_effect, with an eff_decl that has DM4F_eff combinators, with dummy wps plays its part - *) -type sigelt' = - | Sig_inductive_typ { //type l forall u1..un. (x1:t1) ... (xn:tn) : t - lid:lident; - us:univ_names; //u1..un - params:binders; //(x1:t1) ... (xn:tn) - num_uniform_params:option int; //number of recursively uniform type parameters - t:typ; //t - mutuals:list lident; //mutually defined types - ds:list lident; //data constructors for this type - injective_type_params:bool //is this type injective in its type parameters? - } -(* a datatype definition is a Sig_bundle of all mutually defined `Sig_inductive_typ`s and `Sig_datacon`s. - perhaps it would be nicer to let this have a 2-level structure, e.g. list list sigelt, - where each higher level list represents one of the inductive types and its constructors. - However, the current order is convenient as it matches the type-checking order for the mutuals; - i.e., all the type constructors first; then all the data which may refer to the type constructors *) - | Sig_bundle { - ses:list sigelt; //the set of mutually defined type and data constructors - lids:list lident; //all the inductive types and data constructor names in this bundle - } - | Sig_datacon { - lid:lident; //name of the datacon - us:univ_names; //universe variables of the inductive type it belongs to - t:typ; //the constructor's type as an arrow (including parameters) - ty_lid:lident; //the inductive type of the value this constructs - num_ty_params:int; //and the number of parameters of the inductive - mutuals:list lident; //mutually defined types - injective_type_params:bool //is this type injective in its type parameters? - } - | Sig_declare_typ { - lid:lident; - us:univ_names; - t:typ - } - | Sig_let { - lbs:letbindings; - lids:list lident; //mutually defined - } - | Sig_assume { - lid:lident; - us:univ_names; - phi:formula; - } - | Sig_new_effect of eff_decl - | Sig_sub_effect of sub_eff - | Sig_effect_abbrev { - lid:lident; - us:univ_names; - bs:binders; - comp:comp; - cflags:list cflag; - } - | Sig_pragma of pragma - | Sig_splice { - is_typed:bool; // true indicates a typed splice that does not re-typecheck the generated sigelt - // it is an experimental feature added as part of the meta DSL framework - lids:list lident; - tac:term; - } - - | Sig_polymonadic_bind { //(m, n) |> p, the polymonadic term, and its type - m_lid:lident; - n_lid:lident; - p_lid:lident; - tm:tscheme; - typ:tscheme; - kind:option indexed_effect_combinator_kind; - } - | Sig_polymonadic_subcomp { //m <: n, the polymonadic subcomp term, and its type - m_lid:lident; - n_lid:lident; - tm:tscheme; - typ:tscheme; - kind:option indexed_effect_combinator_kind; - } - | Sig_fail { - errs:list int; // Expected errors (empty for 'any') - fail_in_lax:bool; // true if should fail in --lax - ses:list sigelt; // The sigelts to be checked - } - -and sigelt = { - sigel: sigelt'; - sigrng: Range.range; - sigquals: list qualifier; - sigmeta: sig_metadata; - sigattrs: list attribute; - sigopens_and_abbrevs: list (either open_module_or_namespace module_abbrev); - sigopts: option vconfig; (* Saving the option context where this sigelt was checked in *) -} - - -type sigelts = list sigelt - -type modul = { - name: lident; - declarations: sigelts; - is_interface:bool; -} - -val on_antiquoted : (term -> term) -> quoteinfo -> quoteinfo - -(* Requires that bv.index is in scope for the antiquotation list. *) -val lookup_aq : bv -> antiquotations -> term - -// This is set in FStar.Main.main, where all modules are in-scope. -val lazy_chooser : ref (option (lazy_kind -> lazyinfo -> term)) - -val mod_name: modul -> lident - -type path = list string -type subst_t = list subst_elt - -val contains_reflectable: list qualifier -> bool - -val withsort: 'a -> withinfo_t 'a -val withinfo: 'a -> Range.range -> withinfo_t 'a - -(* Constructors for each term form; NO HASH CONSING; just makes all the auxiliary data at each node *) -val mk: 'a -> range -> syntax 'a - -val mk_lb : (lbname & list univ_name & lident & typ & term & list attribute & range) -> letbinding -val default_sigmeta: sig_metadata -val mk_sigelt: sigelt' -> sigelt // FIXME check uses -val mk_Tm_app: term -> args -> range -> term - -(* This raises an exception if the term is not a Tm_fvar, - * use with care. It has to be an Tm_fvar *immediately*, - * there is no solving of Tm_delayed nor Tm_uvar. If it's - * possible that it is not a Tm_fvar, which can be the case - * for non-typechecked terms, just use `mk`. *) -val mk_Tm_uinst: term -> universes -> term - -val extend_app: term -> arg -> range -> term -val extend_app_n: term -> args -> range -> term -val mk_Tm_delayed: (term & subst_ts) -> Range.range -> term -val mk_Total: typ -> comp -val mk_GTotal: typ -> comp -val mk_Tac : typ -> comp -val mk_Comp: comp_typ -> comp -val bv_to_tm: bv -> term -val bv_to_name: bv -> term -val binders_to_names: binders -> list term - -val bv_eq: bv -> bv -> bool -val order_bv: bv -> bv -> int -val range_of_lbname: lbname -> range -val range_of_bv: bv -> range -val set_range_of_bv: bv -> range -> bv -val order_univ_name: univ_name -> univ_name -> int - -val tun: term -val teff: term -val is_teff: term -> bool -val is_type: term -> bool - -val freenames_of_binders: binders -> freenames -val binders_of_freenames: freenames -> binders -val binders_of_list: list bv -> binders - -val null_bv: term -> bv -val mk_binder_with_attrs - : bv -> bqual -> option positivity_qualifier -> list attribute -> binder -val mk_binder: bv -> binder -val null_binder: term -> binder -val as_arg: term -> arg -val imp_tag: binder_qualifier -val iarg: term -> arg -val is_null_bv: bv -> bool -val is_null_binder: binder -> bool -val argpos: arg -> Range.range -val pat_bvs: pat -> list bv -val is_bqual_implicit: bqual -> bool -val is_aqual_implicit: aqual -> bool -val is_bqual_implicit_or_meta: bqual -> bool -val as_bqual_implicit: bool -> bqual -val as_aqual_implicit: bool -> aqual -val is_top_level: list letbinding -> bool - -(* gensym *) -val freshen_bv : bv -> bv -val freshen_binder : binder -> binder -val gen_bv : string -> option Range.range -> typ -> bv -val gen_bv' : ident -> option Range.range -> typ -> bv -val new_bv : option range -> typ -> bv -val new_univ_name : option range -> univ_name -val lid_and_dd_as_fv : lident -> option fv_qual -> fv -val lid_as_fv : lident -> option fv_qual -> fv -val fv_to_tm : fv -> term -val fvar_with_dd : lident -> option fv_qual -> term -val fvar : lident -> option fv_qual -> term -val fv_eq : fv -> fv -> bool -val fv_eq_lid : fv -> lident -> bool -val range_of_fv : fv -> range -val lid_of_fv : fv -> lid -val set_range_of_fv : fv -> range -> fv - -(* attributes *) -val has_simple_attribute: list term -> string -> bool - -val eq_pat : pat -> pat -> bool - -/////////////////////////////////////////////////////////////////////// -//Some common constants -/////////////////////////////////////////////////////////////////////// -module C = FStar.Parser.Const -val delta_constant : delta_depth -val delta_equational: delta_depth -val fvconst : lident -> fv -val tconst : lident -> term -val tabbrev : lident -> term -val tdataconstr : lident -> term -val t_unit : term -val t_bool : term -val t_int : term -val t_string : term -val t_exn : term -val t_real : term -val t_float : term -val t_char : term -val t_range : term -val t___range : term -val t_vconfig : term -val t_norm_step : term -val t_term : term -val t_term_view : term -val t_order : term -val t_decls : term -val t_binder : term -val t_bv : term -val t_tac_of : term -> term -> term -val t_tactic_of : term -> term -val t_tactic_unit : term -val t_list_of : term -> term -val t_option_of : term -> term -val t_tuple2_of : term -> term -> term -val t_tuple3_of : term -> term -> term -> term -val t_tuple4_of : term -> term -> term -> term -> term -val t_tuple5_of : term -> term -> term -> term -> term -> term -val t_either_of : term -> term -> term -val t_sealed_of : term -> term -val t_erased_of : term -> term - -val unit_const_with_range : Range.range -> term -val unit_const : term - -(** Checks wether an identity `id` is allowed by a include/open -restriction `r`. If it is not allowed, -`is_ident_allowed_by_restriction id r` returns `None`, otherwise it -returns `Some renamed`, where `renamed` is either `id` (when no there -is no `as` clause) or another identity pointing to the actual source -identity in the source module. - -For example, if we have `open Foo { my_type as the_type }`, -`is_ident_allowed_by_restriction <{ my_type as the_type }>` -will return `Some `. -*) -val is_ident_allowed_by_restriction: ident -> restriction -> option ident - -instance val has_range_syntax #a : unit -> Tot (hasRange (syntax a)) -instance val has_range_withinfo #a : unit -> Tot (hasRange (withinfo_t a)) -instance val has_range_sigelt : hasRange sigelt -instance val hasRange_fv : hasRange fv -instance val hasRange_bv : hasRange bv -instance val hasRange_binder : hasRange binder - -instance val showable_emb_typ : showable emb_typ -instance val showable_delta_depth : showable delta_depth -instance val showable_should_check_uvar : showable should_check_uvar - -instance val showable_lazy_kind : showable lazy_kind - -instance val deq_lazy_kind : deq lazy_kind -instance val deq_bv : deq bv -instance val deq_ident : deq ident -instance val deq_fv : deq lident -instance val deq_univ_name : deq univ_name -instance val deq_delta_depth : deq delta_depth - -instance val ord_bv : ord bv -instance val ord_ident : ord ident -instance val ord_fv : ord lident - -instance val tagged_term : tagged term -instance val tagged_sigelt : tagged sigelt diff --git a/src/syntax/FStar.Syntax.TermHashTable.fsti b/src/syntax/FStar.Syntax.TermHashTable.fsti deleted file mode 100644 index 870c06e86f8..00000000000 --- a/src/syntax/FStar.Syntax.TermHashTable.fsti +++ /dev/null @@ -1,18 +0,0 @@ -module FStar.Syntax.TermHashTable -open FStar.Compiler.Effect -open FStar.Syntax.Syntax -module H = FStar.Hash - -type hashtable 'a - -val create (size:int) : hashtable 'a - -val insert (key:term) (value:'a) (ht:hashtable 'a) : unit - -val lookup (key:term) (ht:hashtable 'a) : option 'a - -val clear (ht:hashtable 'a) : unit - -val reset_counters (x:hashtable 'a) : unit - -val print_stats (x:hashtable 'a) : unit diff --git a/src/syntax/FStar.Syntax.Unionfind.fst b/src/syntax/FStar.Syntax.Unionfind.fst deleted file mode 100644 index cd9d471f527..00000000000 --- a/src/syntax/FStar.Syntax.Unionfind.fst +++ /dev/null @@ -1,211 +0,0 @@ -(* - Copyright 2008-2014 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Syntax.Unionfind -open FStar.Compiler.Effect -open FStar.Errors -open FStar.Syntax.Syntax - -module Range = FStar.Compiler.Range -module S = FStar.Syntax.Syntax -module PU = FStar.Unionfind -module BU = FStar.Compiler.Util -module L = FStar.Compiler.List -module O = FStar.Options - -type vops_t = { - next_major : unit -> S.version; - next_minor : unit -> S.version -} - -let vops = - let major = BU.mk_ref 0 in - let minor = BU.mk_ref 0 in - let next_major () = - minor := 0; - {major=(BU.incr major; !major); - minor=0} - in - let next_minor () = - {major=(!major); - minor=(BU.incr minor; !minor)} - in - {next_major=next_major; - next_minor=next_minor} - -(* private *) -type tgraph = PU.puf (option S.term & S.uvar_decoration) -(* private *) -type ugraph = PU.puf (option S.universe) - -(* The type of the current unionfind graph *) -type uf = { - term_graph: tgraph; - univ_graph: ugraph; - version:version; - ro:bool; -} - -let empty (v:version) = { - term_graph = PU.puf_empty(); - univ_graph = PU.puf_empty(); - version = v; - ro = false; - } - -(*private*) -let version_to_string v = BU.format2 "%s.%s" (BU.string_of_int v.major) (BU.string_of_int v.minor) - -(* private *) -let state : ref uf = - BU.mk_ref (empty (vops.next_major())) - -type tx = - | TX of uf - -(* getting and setting the current unionfind graph - -- used during backtracking in the tactics engine *) -let get () = !state - - -let set_ro () = - let s = get () in - state := { s with ro = true } - -let set_rw () = - let s = get () in - state := { s with ro = false } - -let with_uf_enabled (f : unit -> 'a) : 'a = - let s = get () in - set_rw (); - let restore () = if s.ro then set_ro () in - - let r = - if O.trace_error () - then f () - else try f () - with | e -> begin - restore (); - raise e - end - in - restore (); - r - -let fail_if_ro () = - if (get ()).ro then - raise_error0 Fatal_BadUvar "Internal error: UF graph was in read-only mode" - -let set (u:uf) = - fail_if_ro (); - state := u - -let reset () = - fail_if_ro (); - let v = vops.next_major () in -// printfn "UF version = %s" (version_to_string v); - set ({ empty v with ro = false }) - -//////////////////////////////////////////////////////////////////////////////// -//Transacational interface, used in FStar.TypeChecker.Rel -//////////////////////////////////////////////////////////////////////////////// -let new_transaction () = - let tx = TX (get ()) in - set ({get() with version=vops.next_minor()}); - tx -let commit (tx:tx) = () -let rollback (TX uf) = set uf -let update_in_tx (r:ref 'a) (x:'a) = () - -//////////////////////////////////////////////////////////////////////////////// -//Interface for term unification -//////////////////////////////////////////////////////////////////////////////// -(* private *) -let get_term_graph () = (get()).term_graph -let get_version () = (get()).version - -(* private *) -let set_term_graph tg = - set ({get() with term_graph = tg}) - -(*private*) -let chk_v_t (su:S.uvar) = - let u, v, rng = su in - let uvar_to_string u = "?" ^ (PU.puf_unique_id u |> BU.string_of_int) in - let expected = get_version () in - if v.major = expected.major - && v.minor <= expected.minor - then u - else - let open FStar.Pprint in - raise_error rng Fatal_BadUvar [ - text "Internal error: incompatible version for term unification variable" - ^/^ doc_of_string (uvar_to_string u); - text "Current version: " ^/^ doc_of_string (version_to_string expected); - text "Got version: " ^/^ doc_of_string (version_to_string v); - ] - -let uvar_id u = PU.puf_id (get_term_graph()) (chk_v_t u) -let uvar_unique_id u = PU.puf_unique_id (chk_v_t u) -let fresh decoration (rng:Range.range) = - fail_if_ro (); - PU.puf_fresh (get_term_graph()) (None, decoration), get_version(), rng - -let find_core u = PU.puf_find (get_term_graph()) (chk_v_t u) -let find u = fst (find_core u) -let find_decoration u = snd (find_core u) -let change u t = let _, dec = find_core u in set_term_graph (PU.puf_change (get_term_graph()) (chk_v_t u) (Some t, dec)) -let change_decoration u d = let t, _ = find_core u in set_term_graph (PU.puf_change (get_term_graph()) (chk_v_t u) (t, d)) -let equiv u v = PU.puf_equivalent (get_term_graph()) (chk_v_t u) (chk_v_t v) -let union u v = set_term_graph (PU.puf_union (get_term_graph()) (chk_v_t u) (chk_v_t v)) - -//////////////////////////////////////////////////////////////////////////////// -//Interface for universe unification -//////////////////////////////////////////////////////////////////////////////// - -(*private*) -let get_univ_graph () = (get()).univ_graph - -(*private*) -let chk_v_u (u, v, rng) = - let uvar_to_string u = "?" ^ (PU.puf_unique_id u |> BU.string_of_int) in - let expected = get_version () in - if v.major = expected.major - && v.minor <= expected.minor - then u - else - let open FStar.Pprint in - raise_error (rng <: Range.range) Fatal_BadUvar [ - text "Internal error: incompatible version for universe unification variable" - ^/^ doc_of_string (uvar_to_string u); - text "Current version: " ^/^ doc_of_string (version_to_string expected); - text "Got version: " ^/^ doc_of_string (version_to_string v); - ] - -(*private*) -let set_univ_graph (ug:ugraph) = - set ({get() with univ_graph = ug}) - -let univ_uvar_id u = PU.puf_id (get_univ_graph()) (chk_v_u u) -let univ_fresh (rng:Range.range) = - fail_if_ro (); - PU.puf_fresh (get_univ_graph()) None, get_version(), rng - -let univ_find u = PU.puf_find (get_univ_graph()) (chk_v_u u) -let univ_change u t = set_univ_graph (PU.puf_change (get_univ_graph()) (chk_v_u u) (Some t)) -let univ_equiv u v = PU.puf_equivalent (get_univ_graph()) (chk_v_u u) (chk_v_u v) -let univ_union u v = set_univ_graph (PU.puf_union (get_univ_graph()) (chk_v_u u) (chk_v_u v)) diff --git a/src/syntax/FStar.Syntax.Unionfind.fsti b/src/syntax/FStar.Syntax.Unionfind.fsti deleted file mode 100644 index ad6af2e8fcf..00000000000 --- a/src/syntax/FStar.Syntax.Unionfind.fsti +++ /dev/null @@ -1,61 +0,0 @@ -(* - Copyright 2008-2014 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Syntax.Unionfind - -(* This module offers a transactional interface specialized for terms and - * universes on top of the existing union-find implementation. *) - -open FStar.Compiler.Effect -module Range = FStar.Compiler.Range -module S = FStar.Syntax.Syntax - -val uf : Type0 -val get : unit -> uf -val set : uf -> unit -val reset : unit -> unit - -(* Set read-only mode *) -val set_ro : unit -> unit - -(* Set read-write mode *) -val set_rw : unit -> unit - -(* Run a function with rw mode enabled *) -val with_uf_enabled : (unit -> 'a) -> 'a - -val tx : Type0 -val new_transaction : (unit -> tx) -val rollback : tx -> unit -val commit : tx -> unit -val update_in_tx : ref 'a -> 'a -> unit - -val fresh : S.uvar_decoration -> Range.range -> S.uvar -val uvar_id : S.uvar -> int -val uvar_unique_id : S.uvar -> int -val find : S.uvar -> option S.term -val find_decoration : S.uvar -> S.uvar_decoration -val change : S.uvar -> S.term -> unit -val change_decoration : S.uvar -> S.uvar_decoration -> unit -val equiv : S.uvar -> S.uvar -> bool -val union : S.uvar -> S.uvar -> unit - -val univ_fresh : Range.range -> S.universe_uvar -val univ_uvar_id : S.universe_uvar -> int -val univ_find : S.universe_uvar -> option S.universe -val univ_change : S.universe_uvar -> S.universe -> unit -val univ_equiv : S.universe_uvar -> S.universe_uvar -> bool -val univ_union : S.universe_uvar -> S.universe_uvar -> unit diff --git a/src/syntax/FStar.Syntax.Util.fst b/src/syntax/FStar.Syntax.Util.fst deleted file mode 100644 index 85c56cda831..00000000000 --- a/src/syntax/FStar.Syntax.Util.fst +++ /dev/null @@ -1,2152 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Syntax.Util -open Prims -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List - -open FStar -open FStar.Compiler -open FStar.Compiler.Util -open FStar.Ident -open FStar.Compiler.Range -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.Const -open FStar.Dyn -module U = FStar.Compiler.Util -module List = FStar.Compiler.List -module PC = FStar.Parser.Const - -open FStar.Class.Show -open FStar.Class.Monad -open FStar.Class.Setlike - -(********************************************************************************) -(**************************Utilities for identifiers ****************************) -(********************************************************************************) - -(* A hook into FStar.Syntax.Print, only for debugging and error messages. - * The reference is set in FStar.Main *) -let tts_f : ref (option (term -> string)) = U.mk_ref None -let tts t : string = - match !tts_f with - | None -> "<>" - | Some f -> f t - -let ttd_f : ref (option (term -> Pprint.document)) = U.mk_ref None -let ttd t : Pprint.document = - match !ttd_f with - | None -> Pprint.doc_of_string "<>" - | Some f -> f t - -let mk_discriminator lid = - lid_of_ids (ns_of_lid lid - @ [mk_ident (Ident.reserved_prefix ^ "is_" ^ (string_of_id (ident_of_lid lid)), - range_of_lid lid)]) - -let is_name (lid:lident) = - let c = U.char_at (string_of_id (ident_of_lid lid)) 0 in - U.is_upper c - -let aqual_of_binder (b:binder) - : aqual - = match b.binder_qual, b.binder_attrs with - | Some (Implicit _), _ - | Some (Meta _), _ -> - Some ({ aqual_implicit = true; - aqual_attributes = b.binder_attrs }) - | _, _::_ -> - Some ({ aqual_implicit = false; - aqual_attributes = b.binder_attrs }) - | _ -> None - -let bqual_and_attrs_of_aqual (a:aqual) - : bqual & list attribute - = match a with - | None -> None, [] - | Some a -> (if a.aqual_implicit then Some imp_tag else None), - a.aqual_attributes - -let arg_of_non_null_binder b = (bv_to_name b.binder_bv, aqual_of_binder b) - -let args_of_non_null_binders (binders:binders) = - binders |> List.collect (fun b -> - if is_null_binder b then [] - else [arg_of_non_null_binder b]) - -let args_of_binders (binders:Syntax.binders) : (Syntax.binders & args) = - binders |> List.map (fun b -> - if is_null_binder b - then let b = { b with binder_bv = new_bv None b.binder_bv.sort } in - b, arg_of_non_null_binder b - else b, arg_of_non_null_binder b) |> List.unzip - -let name_binders binders = - binders |> List.mapi (fun i b -> - if is_null_binder b - then let bname = id_of_text ("_" ^ string_of_int i) in - let bv = {ppname=bname; index=0; sort=b.binder_bv.sort} in - { b with binder_bv = bv } - else b) - -let name_function_binders t = match t.n with - | Tm_arrow {bs=binders; comp} -> mk (Tm_arrow {bs=name_binders binders; comp}) t.pos - | _ -> t - -let null_binders_of_tks (tks:list (typ & bqual)) : binders = - tks |> List.map (fun (t, imp) -> { null_binder t with binder_qual = imp }) - -let binders_of_tks (tks:list (typ & bqual)) : binders = - tks |> List.map (fun (t, imp) -> mk_binder_with_attrs (new_bv (Some t.pos) t) imp None []) - -let mk_subst s = [s] - -let subst_of_list (formals:binders) (actuals:args) : subst_t = - if (List.length formals = List.length actuals) - then List.fold_right2 (fun f a out -> NT(f.binder_bv, fst a)::out) formals actuals [] - else failwith "Ill-formed substitution" - -let rename_binders (replace_xs:binders) (with_ys:binders) : subst_t = - if List.length replace_xs = List.length with_ys - then List.map2 (fun x y -> NT(x.binder_bv, bv_to_name y.binder_bv)) replace_xs with_ys - else failwith "Ill-formed substitution" - -open FStar.Syntax.Subst - -let rec unmeta e = - let e = compress e in - match e.n with - | Tm_meta {tm=e} - | Tm_ascribed {tm=e} -> unmeta e - | _ -> e - -let rec unmeta_safe e = - let e = compress e in - match e.n with - | Tm_meta {tm=e'; meta=m} -> - begin match m with - | Meta_monadic _ - | Meta_monadic_lift _ -> - e // don't remove the metas that really matter - | _ -> unmeta_safe e' - end - | Tm_ascribed {tm=e} -> unmeta_safe e - | _ -> e - -let unmeta_lift (t:term) : term = - match (compress t).n with - | Tm_meta {tm=t; meta=Meta_monadic_lift _} -> t - | _ -> t - -(********************************************************************************) -(*************************** Utilities for universes ****************************) -(********************************************************************************) -(* kernel u = (k_u, n) - where u is of the form S^n k_u - i.e., k_u is the "kernel" and n is the offset *) -let rec univ_kernel u = match Subst.compress_univ u with - | U_unknown - | U_name _ - | U_unif _ - | U_max _ - | U_zero -> u, 0 - | U_succ u -> let k, n = univ_kernel u in k, n+1 - | U_bvar i -> failwith ("Imposible: univ_kernel (U_bvar " ^ show i ^ ")") - -//requires: kernel u = U_zero, n -//returns: n -let constant_univ_as_nat u = snd (univ_kernel u) - -//ordering on universes: -// constants come first, in order of their size -// named universes come next, in lexical order of their kernels and their offsets -// unification variables next, in lexical order of their kernels and their offsets -// max terms come last -//e.g, [Z; S Z; S S Z; u1; S u1; u2; S u2; S S u2; ?v1; S ?v1; ?v2] -let rec compare_univs (u1:universe) (u2:universe) : int = - let rec compare_kernel (uk1:universe) (uk2:universe) : int = - match Subst.compress_univ uk1, Subst.compress_univ uk2 with - | U_bvar _, _ - | _, U_bvar _ -> failwith "Impossible: compare_kernel bvar" - - | U_succ _, _ - | _, U_succ _ -> failwith "Impossible: compare_kernel succ" - - | U_unknown, U_unknown -> 0 - | U_unknown, _ -> -1 - | _, U_unknown -> 1 - - | U_zero, U_zero -> 0 - | U_zero, _ -> -1 - | _, U_zero -> 1 - - | U_name u1 , U_name u2 -> String.compare (string_of_id u1) (string_of_id u2) - | U_name _, _ -> -1 - | _, U_name _ -> 1 - - | U_unif u1, U_unif u2 -> Unionfind.univ_uvar_id u1 - Unionfind.univ_uvar_id u2 - | U_unif _, _ -> -1 - | _, U_unif _ -> 1 - - (* Only remaining case *) - | U_max us1, U_max us2 -> - let n1 = List.length us1 in - let n2 = List.length us2 in - if n1 <> n2 - then n1 - n2 (* first order by increasing length *) - else - (* for same length, order lexicographically *) - let copt = U.find_map (List.zip us1 us2) (fun (u1, u2) -> - let c = compare_univs u1 u2 in - if c<>0 then Some c - else None) in - begin match copt with - | None -> 0 - | Some c -> c - end - in - let uk1, n1 = univ_kernel u1 in - let uk2, n2 = univ_kernel u2 in - match compare_kernel uk1 uk2 with - | 0 -> n1 - n2 - | n -> n - -let eq_univs u1 u2 = compare_univs u1 u2 = 0 - -let eq_univs_list (us:universes) (vs:universes) : bool = - List.length us = List.length vs - && List.forall2 eq_univs us vs - -(********************************************************************************) -(*********************** Utilities for computation types ************************) -(********************************************************************************) - -let ml_comp t r = - mk_Comp ({comp_univs=[U_zero]; - effect_name=set_lid_range (PC.effect_ML_lid()) r; - result_typ=t; - effect_args=[]; - flags=[MLEFFECT]}) - -let comp_effect_name c = match c.n with - | Comp c -> c.effect_name - | Total _ -> PC.effect_Tot_lid - | GTotal _ -> PC.effect_GTot_lid - -let comp_flags c = match c.n with - | Total _ -> [TOTAL] - | GTotal _ -> [SOMETRIVIAL] - | Comp ct -> ct.flags - -let comp_eff_name_res_and_args (c:comp) : lident & typ & args = - match c.n with - | Total t -> PC.effect_Tot_lid, t, [] - | GTotal t -> PC.effect_GTot_lid, t, [] - | Comp c -> c.effect_name, c.result_typ, c.effect_args - -(* - * For layered effects, given a (repr a is), return is - * For wp effects, given a (unit -> M a wp), return wp - * - * The pattern matching is very syntactic inside this function - * It is called from the computation types in the layered effect combinators - * e.g. f and g in bind - * Layered effects typechecking code already makes sure that those types - * have this exact shape - *) -let effect_indices_from_repr (repr:term) (is_layered:bool) (r:Range.range) (err:string) -: list term = - let err () = Errors.raise_error r Errors.Fatal_UnexpectedEffect err in - let repr = compress repr in - if is_layered - then match repr.n with - | Tm_app {args=_::is} -> is |> List.map fst - | _ -> err () - else match repr.n with - | Tm_arrow {comp=c} -> c |> comp_eff_name_res_and_args |> (fun (_, _, args) -> args |> List.map fst) - | _ -> err () - -let destruct_comp c : (universe & typ & typ) = - let wp = match c.effect_args with - | [(wp, _)] -> wp - | _ -> - failwith (U.format2 - "Impossible: Got a computation %s with %s effect args" - (string_of_lid c.effect_name) - (c.effect_args |> List.length |> string_of_int)) in - List.hd c.comp_univs, c.result_typ, wp - -let is_named_tot c = - match c.n with - | Comp c -> lid_equals c.effect_name PC.effect_Tot_lid - | Total _ -> true - | GTotal _ -> false - -let is_total_comp c = - lid_equals (comp_effect_name c) PC.effect_Tot_lid - || comp_flags c |> U.for_some (function TOTAL | RETURN -> true | _ -> false) - -let is_partial_return c = comp_flags c |> U.for_some (function RETURN | PARTIAL_RETURN -> true | _ -> false) - -let is_tot_or_gtot_comp c = - is_total_comp c - || lid_equals PC.effect_GTot_lid (comp_effect_name c) - -let is_pure_effect l = - lid_equals l PC.effect_Tot_lid - || lid_equals l PC.effect_PURE_lid - || lid_equals l PC.effect_Pure_lid - -let is_pure_comp c = match c.n with - | Total _ -> true - | GTotal _ -> false - | Comp ct -> is_total_comp c - || is_pure_effect ct.effect_name - || ct.flags |> U.for_some (function LEMMA -> true | _ -> false) - -let is_ghost_effect l = - lid_equals PC.effect_GTot_lid l - || lid_equals PC.effect_GHOST_lid l - || lid_equals PC.effect_Ghost_lid l - -let is_div_effect l = - lid_equals l PC.effect_DIV_lid - || lid_equals l PC.effect_Div_lid - || lid_equals l PC.effect_Dv_lid - -let is_pure_or_ghost_comp c = is_pure_comp c || is_ghost_effect (comp_effect_name c) - -let is_pure_or_ghost_effect l = is_pure_effect l || is_ghost_effect l - -let is_pure_or_ghost_function t = match (compress t).n with - | Tm_arrow {comp=c} -> is_pure_or_ghost_comp c - | _ -> true - -let is_lemma_comp c = - match c.n with - | Comp ct -> lid_equals ct.effect_name PC.effect_Lemma_lid - | _ -> false - -let is_lemma t = - match (compress t).n with - | Tm_arrow {comp=c} -> is_lemma_comp c - | _ -> false - -let rec head_of (t : term) : term = - match (compress t).n with - | Tm_app {hd=t} - | Tm_match {scrutinee=t} - | Tm_abs {body=t} - | Tm_ascribed {tm=t} - | Tm_meta {tm=t} -> head_of t - | _ -> t - -let head_and_args t = - let t = compress t in - match t.n with - | Tm_app {hd=head; args} -> head, args - | _ -> t, [] - -let rec __head_and_args_full acc unmeta t = - let t = compress t in - match t.n with - | Tm_app {hd=head; args} -> - __head_and_args_full (args@acc) unmeta head - | Tm_meta {tm} when unmeta -> - __head_and_args_full acc unmeta tm - | _ -> t, acc - -let head_and_args_full t = __head_and_args_full [] false t -let head_and_args_full_unmeta t = __head_and_args_full [] true t - -let rec leftmost_head t = - let t = compress t in - match t.n with - | Tm_app {hd=t0} - | Tm_meta {tm=t0; meta=Meta_pattern _} - | Tm_meta {tm=t0; meta= Meta_named _} - | Tm_meta {tm=t0; meta=Meta_labeled _} - | Tm_meta {tm=t0; meta=Meta_desugared _} - | Tm_ascribed {tm=t0} -> - leftmost_head t0 - | _ -> t - - -let leftmost_head_and_args t = - let rec aux t args = - let t = compress t in - match t.n with - | Tm_app {hd=t0; args=args'} -> aux t0 (args'@args) - | Tm_meta {tm=t0; meta=Meta_pattern _} - | Tm_meta {tm=t0; meta=Meta_named _} - | Tm_meta {tm=t0; meta=Meta_labeled _} - | Tm_meta {tm=t0; meta=Meta_desugared _} - | Tm_ascribed {tm=t0} -> aux t0 args - | _ -> t, args - in - aux t [] - - -let un_uinst t = - let t = Subst.compress t in - match t.n with - | Tm_uinst (t, _) -> Subst.compress t - | _ -> t - -let is_ml_comp c = match c.n with - | Comp c -> lid_equals c.effect_name (PC.effect_ML_lid()) - || c.flags |> U.for_some (function MLEFFECT -> true | _ -> false) - - | _ -> false - -let comp_result c = match c.n with - | Total t - | GTotal t -> t - | Comp ct -> ct.result_typ - -let set_result_typ c t = match c.n with - | Total _ -> mk_Total t - | GTotal _ -> mk_GTotal t - | Comp ct -> mk_Comp({ct with result_typ=t}) - -let is_trivial_wp c = - comp_flags c |> U.for_some (function TOTAL | RETURN -> true | _ -> false) - -let comp_effect_args (c:comp) :args = - match c.n with - | Total _ - | GTotal _ -> [] - | Comp ct -> ct.effect_args - -(********************************************************************************) -(* Simple utils on the structure of a term *) -(********************************************************************************) -let primops = - [PC.op_Eq; - PC.op_notEq; - PC.op_LT; - PC.op_LTE; - PC.op_GT; - PC.op_GTE; - PC.op_Subtraction; - PC.op_Minus; - PC.op_Addition; - PC.op_Multiply; - PC.op_Division; - PC.op_Modulus; - PC.op_And; - PC.op_Or; - PC.op_Negation;] -let is_primop_lid l = primops |> U.for_some (lid_equals l) - -let is_primop f = match f.n with - | Tm_fvar fv -> is_primop_lid fv.fv_name.v - | _ -> false - -let rec unascribe e = - let e = Subst.compress e in - match e.n with - | Tm_ascribed {tm=e} -> unascribe e - | _ -> e - -let rec ascribe t k = match t.n with - | Tm_ascribed {tm=t'} -> ascribe t' k - | _ -> mk (Tm_ascribed {tm=t; asc=k; eff_opt=None}) t.pos - -let unfold_lazy i = must !lazy_chooser i.lkind i - -let rec unlazy t = - match (compress t).n with - | Tm_lazy i -> unlazy <| unfold_lazy i - | _ -> t - -let unlazy_emb t = - match (compress t).n with - | Tm_lazy i -> - begin match i.lkind with - | Lazy_embedding _ -> unlazy <| unfold_lazy i - | _ -> t - end - | _ -> t - -let unlazy_as_t k t = - let open FStar.Class.Show in - let open FStar.Class.Deq in - match (compress t).n with - | Tm_lazy ({lkind=k'; blob=v}) -> - if k =? k' - then Dyn.undyn v - else failwith (U.format2 "Expected Tm_lazy of kind %s, got %s" - (show k) (show k')) - | _ -> - failwith "Not a Tm_lazy of the expected kind" - -let mk_lazy (t : 'a) (typ : typ) (k : lazy_kind) (r : option range) : term = - let rng = (match r with | Some r -> r | None -> dummyRange) in - let i = { - lkind = k; - blob = mkdyn t; - ltyp = typ; - rng = rng; - } in - mk (Tm_lazy i) rng - -let canon_app t = - let hd, args = head_and_args_full (unascribe t) in - mk_Tm_app hd args t.pos - -let rec unrefine t = - let t = compress t in - match t.n with - | Tm_refine {b=x} -> unrefine x.sort - | Tm_ascribed {tm=t} -> unrefine t - | _ -> t - -let rec is_uvar t = - match (compress t).n with - | Tm_uvar _ -> true - | Tm_uinst (t, _) -> is_uvar t - | Tm_app _ -> t |> head_and_args |> fst |> is_uvar - | Tm_ascribed {tm=t} -> is_uvar t - | _ -> false - -let rec is_unit t = - match (unrefine t).n with - | Tm_fvar fv -> - fv_eq_lid fv PC.unit_lid - || fv_eq_lid fv PC.squash_lid - || fv_eq_lid fv PC.auto_squash_lid - | Tm_app {hd=head} -> is_unit head - | Tm_uinst (t, _) -> is_unit t - | _ -> false - -let is_eqtype_no_unrefine (t:term) = - match (Subst.compress t).n with - | Tm_fvar fv -> fv_eq_lid fv PC.eqtype_lid - | _ -> false - -let is_fun e = match (compress e).n with - | Tm_abs _ -> true - | _ -> false - -let is_function_typ t = match (compress t).n with - | Tm_arrow _ -> true - | _ -> false - -let rec pre_typ t = - let t = compress t in - match t.n with - | Tm_refine {b=x} -> pre_typ x.sort - | Tm_ascribed {tm=t} -> pre_typ t - | _ -> t - -let destruct typ lid = - let typ = compress typ in - match (un_uinst typ).n with - | Tm_app {hd=head; args} -> - let head = un_uinst head in - begin match head.n with - | Tm_fvar tc when fv_eq_lid tc lid -> Some args - | _ -> None - end - | Tm_fvar tc when fv_eq_lid tc lid -> Some [] - | _ -> None - -let lids_of_sigelt (se: sigelt) = match se.sigel with - | Sig_let {lids} - | Sig_splice {lids} - | Sig_bundle {lids} -> lids - | Sig_inductive_typ {lid} - | Sig_effect_abbrev {lid} - | Sig_datacon {lid} - | Sig_declare_typ {lid} - | Sig_assume {lid} -> [lid] - | Sig_new_effect d -> [d.mname] - | Sig_sub_effect _ - | Sig_pragma _ - | Sig_fail _ - | Sig_polymonadic_bind _ -> [] - | Sig_polymonadic_subcomp _ -> [] - -let lid_of_sigelt se : option lident = match lids_of_sigelt se with - | [l] -> Some l - | _ -> None - -let quals_of_sigelt (x: sigelt) = x.sigquals - -let range_of_sigelt (x: sigelt) = x.sigrng - -let range_of_arg (hd, _) = hd.pos - -let range_of_args args r = - args |> List.fold_left (fun r a -> Range.union_ranges r (range_of_arg a)) r - -let mk_app f args = - match args with - | [] -> f - | _ -> - let r = range_of_args args f.pos in - mk (Tm_app {hd=f; args}) r - -let mk_app_binders f bs = - mk_app f (List.map (fun b -> (bv_to_name b.binder_bv, aqual_of_binder b)) bs) - -(***********************************************************************************************) -(* Combining an effect name with the name of one of its actions, or a - data constructor name with the name of one of its formal parameters - - NOTE: the conventions defined here must be in sync with manually - linked ML files, such as ulib/ml/prims.ml - *) -(***********************************************************************************************) - -let field_projector_prefix = "__proj__" - -(* NOTE: the following would have been desirable: - -<< -let field_projector_prefix = Ident.reserved_prefix ^ "proj__" ->> - - but it DOES NOT work with --use_hints on - examples/preorders/MRefHeap.fst (even after regenerating hints), it - will produce the following error: - - fstar.exe --use_hints MRefHeap.fst - ./MRefHeap.fst(55,51-58,27): (Error) Unknown assertion failed - Verified module: MRefHeap (2150 milliseconds) - 1 error was reported (see above) - - In fact, any naming convention that DOES NOT start with - Ident.reserved_prefix seems to work. -*) - -let field_projector_sep = "__item__" - -let field_projector_contains_constructor s = U.starts_with s field_projector_prefix - -let mk_field_projector_name_from_string constr field = - field_projector_prefix ^ constr ^ field_projector_sep ^ field - -let mk_field_projector_name_from_ident lid (i : ident) = - let itext = (string_of_id i) in - let newi = - if field_projector_contains_constructor itext - then i - else mk_ident (mk_field_projector_name_from_string (string_of_id (ident_of_lid lid)) itext, range_of_id i) - in - lid_of_ids (ns_of_lid lid @ [newi]) - -let mk_field_projector_name lid (x:bv) i = - let nm = if Syntax.is_null_bv x - then mk_ident("_" ^ U.string_of_int i, Syntax.range_of_bv x) - else x.ppname in - mk_field_projector_name_from_ident lid nm - -let ses_of_sigbundle (se:sigelt) :list sigelt = - match se.sigel with - | Sig_bundle {ses} -> ses - | _ -> failwith "ses_of_sigbundle: not a Sig_bundle" - -let set_uvar uv t = - match Unionfind.find uv with - | Some t' -> - failwith (U.format3 "Changing a fixed uvar! ?%s to %s but \ - it is already set to %s\n" (U.string_of_int <| Unionfind.uvar_id uv) - (tts t) - (tts t')) - | _ -> Unionfind.change uv t - -let qualifier_equal q1 q2 = match q1, q2 with - | Discriminator l1, Discriminator l2 -> lid_equals l1 l2 - | Projector (l1a, l1b), Projector (l2a, l2b) -> lid_equals l1a l2a && (string_of_id l1b = string_of_id l2b) - | RecordType (ns1, f1), RecordType (ns2, f2) - | RecordConstructor (ns1, f1), RecordConstructor (ns2, f2) -> - List.length ns1 = List.length ns2 && List.forall2 (fun x1 x2 -> (string_of_id x1) = (string_of_id x2)) f1 f2 && - List.length f1 = List.length f2 && List.forall2 (fun x1 x2 -> (string_of_id x1) = (string_of_id x2)) f1 f2 - | _ -> q1=q2 - - -(***********************************************************************************************) -(* closing types and terms *) -(***********************************************************************************************) -let abs bs t lopt = - let close_lopt lopt = match lopt with - | None -> None - | Some rc -> Some ({rc with residual_typ=FStar.Compiler.Util.map_opt rc.residual_typ (close bs)}) - in - match bs with - | [] -> t - | _ -> - let body = compress (Subst.close bs t) in - match body.n with - | Tm_abs {bs=bs'; body=t; rc_opt=lopt'} -> //AR: if the body is an Tm_abs, we can combine the binders and use lopt', ignoring lopt, since lopt will be Tot (non-informative anyway) - mk (Tm_abs {bs=close_binders bs@bs'; body=t; rc_opt=close_lopt lopt'}) t.pos - | _ -> - mk (Tm_abs {bs=close_binders bs; body; rc_opt=close_lopt lopt}) t.pos - -let arrow_ln bs c = match bs with - | [] -> comp_result c - | _ -> mk (Tm_arrow {bs; comp=c}) - (List.fold_left (fun a b -> Range.union_ranges a b.binder_bv.sort.pos) c.pos bs) - -let arrow bs c = - let c = Subst.close_comp bs c in - let bs = close_binders bs in - arrow_ln bs c - -let flat_arrow bs c = - let t = arrow bs c in - match (Subst.compress t).n with - | Tm_arrow {bs; comp=c} -> - begin match c.n with - | Total tres -> - begin match (Subst.compress tres).n with - | Tm_arrow {bs=bs'; comp=c'} -> mk (Tm_arrow {bs=bs@bs'; comp=c'}) t.pos - | _ -> t - end - | _ -> t - end - | _ -> t - -let rec canon_arrow t = - match (compress t).n with - | Tm_arrow {bs; comp=c} -> - let cn = match c.n with - | Total t -> Total (canon_arrow t) - | _ -> c.n - in - let c = { c with n = cn } in - flat_arrow bs c - | _ -> t - -let refine b t = mk (Tm_refine {b; phi=Subst.close [mk_binder b] t}) (Range.union_ranges (range_of_bv b) t.pos) -let branch b = Subst.close_branch b - -let has_decreases (c:comp) : bool = - match c.n with - | Comp ct -> - begin match ct.flags |> U.find_opt (function DECREASES _ -> true | _ -> false) with - | Some (DECREASES _) -> true - | _ -> false - end - | _ -> false - -(* - * AR: this function returns the binders and comp result type of an arrow type, - * flattening arrows of the form t -> Tot (t1 -> C), so that it returns two binders in this example - * the function also descends under the refinements (e.g. t -> Tot (f:(t1 -> C){phi})) - *) -let rec arrow_formals_comp_ln (k:term) = - let k = Subst.compress k in - match k.n with - | Tm_arrow {bs; comp=c} -> - if is_total_comp c && not (has_decreases c) - then let bs', k = arrow_formals_comp_ln (comp_result c) in - bs@bs', k - else bs, c - | Tm_refine {b={ sort = s }} -> - (* - * AR: start descending into s, but if s does not turn out to be an arrow later, we want to return k itself - *) - let rec aux (s:term) (k:term) = - match (Subst.compress s).n with - | Tm_arrow _ -> arrow_formals_comp_ln s //found an arrow, go to the main function - | Tm_refine {b={ sort = s }} -> aux s k //another refinement, descend into it, but with the same def - | _ -> [], Syntax.mk_Total k //return def - in - aux s k - | _ -> [], Syntax.mk_Total k - -let arrow_formals_comp k = - let bs, c = arrow_formals_comp_ln k in - Subst.open_comp bs c - -let arrow_formals_ln k = - let bs, c = arrow_formals_comp_ln k in - bs, comp_result c - -let arrow_formals k = - let bs, c = arrow_formals_comp k in - bs, comp_result c - -(* let_rec_arity e f: - if `f` is a let-rec bound name in e - then this function returns - 1. f's type - 2. the natural arity of f, i.e., the number of arguments including universes on which the let rec is defined - 3. a list of booleans, one for each argument above, where the boolean is true iff the variable appears in the f's decreases clause - This is used by NBE for detecting potential non-terminating loops -*) -let let_rec_arity (lb:letbinding) : int & option (list bool) = - let rec arrow_until_decreases (k:term) = - let k = Subst.compress k in - match k.n with - | Tm_arrow {bs; comp=c} -> - let bs, c = Subst.open_comp bs c in - (match - c |> comp_flags |> U.find_opt (function DECREASES _ -> true | _ -> false) - with - | Some (DECREASES d) -> - bs, Some d - | _ -> - if is_total_comp c - then let bs', d = arrow_until_decreases (comp_result c) in - bs@bs', d - else bs, None) - - | Tm_refine {b={ sort = k }} -> - arrow_until_decreases k - - | _ -> [], None - in - let bs, dopt = arrow_until_decreases lb.lbtyp in - let n_univs = List.length lb.lbunivs in - n_univs + List.length bs, - U.map_opt dopt (fun d -> - let d_bvs = - match d with - | Decreases_lex l -> - l |> List.fold_left (fun s t -> - union s (FStar.Syntax.Free.names t)) (empty #bv ()) - | Decreases_wf (rel, e) -> - union (Free.names rel) (Free.names e) in - Common.tabulate n_univs (fun _ -> false) - @ (bs |> List.map (fun b -> mem b.binder_bv d_bvs))) - -let abs_formals_maybe_unascribe_body maybe_unascribe t = - let subst_lcomp_opt s l = match l with - | Some rc -> - Some ({rc with residual_typ=FStar.Compiler.Util.map_opt rc.residual_typ (Subst.subst s)}) - | _ -> l - in - let rec aux t abs_body_lcomp = - match (unmeta_safe t).n with - | Tm_abs {bs; body=t; rc_opt=what} -> - if maybe_unascribe - then let bs',t, what = aux t what in - bs@bs', t, what - else bs, t, what - | _ -> [], t, abs_body_lcomp - in - let bs, t, abs_body_lcomp = aux t None in - let bs, t, opening = Subst.open_term' bs t in - let abs_body_lcomp = subst_lcomp_opt opening abs_body_lcomp in - bs, t, abs_body_lcomp - -let abs_formals t = abs_formals_maybe_unascribe_body true t - -let remove_inacc (t:term) : term = - let no_acc (b : binder) : binder = - let aq = - match b.binder_qual with - | Some (Implicit true) -> Some (Implicit false) - | aq -> aq - in - { b with binder_qual = aq } - in - let bs, c = arrow_formals_comp_ln t in - match bs with - | [] -> t - | _ -> mk (Tm_arrow {bs=List.map no_acc bs; comp=c}) t.pos - -let mk_letbinding (lbname : either bv fv) univ_vars typ eff def lbattrs pos = - {lbname=lbname; - lbunivs=univ_vars; - lbtyp=typ; - lbeff=eff; - lbdef=def; - lbattrs=lbattrs; - lbpos=pos; - } - - -let close_univs_and_mk_letbinding recs lbname univ_vars typ eff def attrs pos = - let def = match recs, univ_vars with - | None, _ - | _, [] -> def - | Some fvs, _ -> - let universes = univ_vars |> List.map U_name in - let inst = fvs |> List.map (fun fv -> fv.fv_name.v, universes) in - FStar.Syntax.InstFV.instantiate inst def - in - let typ = Subst.close_univ_vars univ_vars typ in - let def = Subst.close_univ_vars univ_vars def in - mk_letbinding lbname univ_vars typ eff def attrs pos - -let open_univ_vars_binders_and_comp uvs binders c = - match binders with - | [] -> - let uvs, c = Subst.open_univ_vars_comp uvs c in - uvs, [], c - | _ -> - let t' = arrow binders c in - let uvs, t' = Subst.open_univ_vars uvs t' in - match (Subst.compress t').n with - | Tm_arrow {bs=binders; comp=c} -> uvs, binders, c - | _ -> failwith "Impossible" - -(********************************************************************************) -(*********************** Various tests on constants ****************************) -(********************************************************************************) - -let is_tuple_constructor (t:typ) = match t.n with - | Tm_fvar fv -> PC.is_tuple_constructor_string (string_of_lid fv.fv_name.v) - | _ -> false - -let is_dtuple_constructor (t:typ) = match t.n with - | Tm_fvar fv -> PC.is_dtuple_constructor_lid fv.fv_name.v - | _ -> false - -let is_lid_equality x = lid_equals x PC.eq2_lid - -let is_forall lid = lid_equals lid PC.forall_lid -let is_exists lid = lid_equals lid PC.exists_lid -let is_qlid lid = is_forall lid || is_exists lid -let is_equality x = is_lid_equality x.v - -let lid_is_connective = - let lst = [PC.and_lid; PC.or_lid; PC.not_lid; - PC.iff_lid; PC.imp_lid] in - fun lid -> U.for_some (lid_equals lid) lst - -let is_constructor t lid = - match (pre_typ t).n with - | Tm_fvar tc -> lid_equals tc.fv_name.v lid - | _ -> false - -let rec is_constructed_typ t lid = - match (pre_typ t).n with - | Tm_fvar _ -> is_constructor t lid - | Tm_app {hd=t} - | Tm_uinst(t, _) -> is_constructed_typ t lid - | _ -> false - -let rec get_tycon t = - let t = pre_typ t in - match t.n with - | Tm_bvar _ - | Tm_name _ - | Tm_fvar _ -> Some t - | Tm_app {hd=t} -> get_tycon t - | _ -> None - -let is_fstar_tactics_by_tactic t = - match (un_uinst t).n with - | Tm_fvar fv -> fv_eq_lid fv PC.by_tactic_lid - | _ -> false - -(********************************************************************************) -(*********************** Constructors of common terms **************************) -(********************************************************************************) - -let ktype : term = mk (Tm_type(U_unknown)) dummyRange -let ktype0 : term = mk (Tm_type(U_zero)) dummyRange - -//Type(u), where u is a new universe unification variable -let type_u () : typ & universe = - let u = U_unif <| Unionfind.univ_fresh Range.dummyRange in - mk (Tm_type u) dummyRange, u - -let type_with_u (u:universe) : typ = mk (Tm_type u) dummyRange - -// // works on anything, really -// let attr_eq a a' = -// match eq_tm a a' with -// | Equal -> true -// | _ -> false - -let attr_substitute = - mk (Tm_fvar (lid_as_fv PC.attr_substitute_lid None)) Range.dummyRange - -let exp_bool (b:bool) : term = mk (Tm_constant (Const_bool b)) dummyRange -let exp_true_bool : term = exp_bool true -let exp_false_bool : term = exp_bool false -let exp_unit : term = mk (Tm_constant (Const_unit)) dummyRange -(* Makes an (unbounded) integer from its string repr. *) -let exp_int s : term = mk (Tm_constant (Const_int (s,None))) dummyRange -let exp_char c : term = mk (Tm_constant (Const_char c)) dummyRange -let exp_string s : term = mk (Tm_constant (Const_string (s, dummyRange))) dummyRange - -let fvar_const l = fvar_with_dd l None -let tand = fvar_const PC.and_lid -let tor = fvar_const PC.or_lid -let timp = fvar_with_dd PC.imp_lid None -let tiff = fvar_with_dd PC.iff_lid None -let t_bool = fvar_const PC.bool_lid -let b2t_v = fvar_const PC.b2t_lid -let t_not = fvar_const PC.not_lid -// These are `True` and `False`, not the booleans -let t_false = fvar_const PC.false_lid -let t_true = fvar_const PC.true_lid -let tac_opaque_attr = exp_string "tac_opaque" -let dm4f_bind_range_attr = fvar_const PC.dm4f_bind_range_attr -let tcdecltime_attr = fvar_const PC.tcdecltime_attr -let inline_let_attr = fvar_const PC.inline_let_attr -let rename_let_attr = fvar_const PC.rename_let_attr - -let t_ctx_uvar_and_sust = fvar_const PC.ctx_uvar_and_subst_lid -let t_universe_uvar = fvar_const PC.universe_uvar_lid - -let t_dsl_tac_typ = fvar PC.dsl_tac_typ_lid None - - -let mk_conj_opt phi1 phi2 = match phi1 with - | None -> Some phi2 - | Some phi1 -> Some (mk (Tm_app {hd=tand; args=[as_arg phi1; as_arg phi2]}) (Range.union_ranges phi1.pos phi2.pos)) -let mk_binop op_t phi1 phi2 = mk (Tm_app {hd=op_t; args=[as_arg phi1; as_arg phi2]}) (Range.union_ranges phi1.pos phi2.pos) -let mk_neg phi = mk (Tm_app {hd=t_not; args=[as_arg phi]}) phi.pos -let mk_conj phi1 phi2 = mk_binop tand phi1 phi2 -let mk_conj_l phi = match phi with - | [] -> fvar_with_dd PC.true_lid None - | hd::tl -> List.fold_right mk_conj tl hd -let mk_disj phi1 phi2 = mk_binop tor phi1 phi2 -let mk_disj_l phi = match phi with - | [] -> t_false - | hd::tl -> List.fold_right mk_disj tl hd -let mk_imp phi1 phi2 : term = mk_binop timp phi1 phi2 -let mk_iff phi1 phi2 : term = mk_binop tiff phi1 phi2 -let b2t e = mk (Tm_app {hd=b2t_v; args=[as_arg e]}) e.pos//implicitly coerce a boolean to a type -let unb2t (e:term) : option term = - let hd, args = head_and_args e in - match (compress hd).n, args with - | Tm_fvar fv, [(e, _)] when fv_eq_lid fv PC.b2t_lid -> Some e - | _ -> None - -let is_t_true t = - match (unmeta t).n with - | Tm_fvar fv -> fv_eq_lid fv PC.true_lid - | _ -> false -let mk_conj_simp t1 t2 = - if is_t_true t1 then t2 - else if is_t_true t2 then t1 - else mk_conj t1 t2 -let mk_disj_simp t1 t2 = - if is_t_true t1 then t_true - else if is_t_true t2 then t_true - else mk_disj t1 t2 - -let teq = fvar_const PC.eq2_lid -let mk_untyped_eq2 e1 e2 = mk (Tm_app {hd=teq; args=[as_arg e1; as_arg e2]}) (Range.union_ranges e1.pos e2.pos) -let mk_eq2 (u:universe) (t:typ) (e1:term) (e2:term) : term = - let eq_inst = mk_Tm_uinst teq [u] in - mk (Tm_app {hd=eq_inst; args=[iarg t; as_arg e1; as_arg e2]}) (Range.union_ranges e1.pos e2.pos) - -let mk_eq3_no_univ = - let teq3 = fvar_const PC.eq3_lid in - fun t1 t2 e1 e2 -> - mk (Tm_app {hd=teq3; args=[iarg t1; iarg t2; as_arg e1; as_arg e2]}) - (Range.union_ranges e1.pos e2.pos) - -let mk_has_type t x t' = - let t_has_type = fvar_const PC.has_type_lid in //TODO: Fix the U_zeroes below! - let t_has_type = mk (Tm_uinst(t_has_type, [U_zero; U_zero])) dummyRange in - mk (Tm_app {hd=t_has_type; args=[iarg t; as_arg x; as_arg t']}) dummyRange - -let tforall = fvar_with_dd PC.forall_lid None -let texists = fvar_with_dd PC.exists_lid None -let t_haseq = fvar_with_dd PC.haseq_lid None - -let decidable_eq = fvar_const PC.op_Eq -let mk_decidable_eq t e1 e2 = - mk (Tm_app {hd=decidable_eq; args=[iarg t; as_arg e1; as_arg e2]}) (Range.union_ranges e1.pos e2.pos) -let b_and = fvar_const PC.op_And -let mk_and e1 e2 = - mk (Tm_app {hd=b_and; args=[as_arg e1; as_arg e2]}) (Range.union_ranges e1.pos e2.pos) -let mk_and_l l = match l with - | [] -> exp_true_bool - | hd::tl -> List.fold_left mk_and hd tl -let mk_boolean_negation b = - mk (Tm_app {hd=fvar_const PC.op_Negation; args=[as_arg b]}) b.pos -let mk_residual_comp l t f = { - residual_effect=l; - residual_typ=t; - residual_flags=f - } -let residual_tot t = { - residual_effect=PC.effect_Tot_lid; - residual_typ=Some t; - residual_flags=[TOTAL] - } -let residual_gtot t = { - residual_effect=PC.effect_GTot_lid; - residual_typ=Some t; - residual_flags=[TOTAL] - } -let residual_comp_of_comp (c:comp) = { - residual_effect=comp_effect_name c; - residual_typ=Some (comp_result c); - residual_flags=List.filter (function DECREASES _ -> false | _ -> true) <| comp_flags c; - } - -let mk_forall_aux fa x body = - mk (Tm_app {hd=fa; - args=[ iarg (x.sort); - as_arg (abs [mk_binder x] body (Some (residual_tot ktype0)))]}) dummyRange - -let mk_forall_no_univ (x:bv) (body:typ) : typ = - mk_forall_aux tforall x body - -let mk_forall (u:universe) (x:bv) (body:typ) : typ = - let tforall = mk_Tm_uinst tforall [u] in - mk_forall_aux tforall x body - -let close_forall_no_univs bs f = - List.fold_right (fun b f -> if Syntax.is_null_binder b then f else mk_forall_no_univ b.binder_bv f) bs f - -let mk_exists_aux fa x body = - mk (Tm_app {hd=fa; - args=[ iarg (x.sort); - as_arg (abs [mk_binder x] body (Some (residual_tot ktype0)))]}) dummyRange - -let mk_exists_no_univ (x:bv) (body:typ) : typ = - mk_exists_aux texists x body - -let mk_exists (u:universe) (x:bv) (body:typ) : typ = - let texists = mk_Tm_uinst texists [u] in - mk_exists_aux texists x body - -let close_exists_no_univs bs f = - List.fold_right (fun b f -> if Syntax.is_null_binder b then f else mk_exists_no_univ b.binder_bv f) bs f - -let if_then_else b t1 t2 = - let then_branch = (withinfo (Pat_constant (Const_bool true)) t1.pos, None, t1) in - let else_branch = (withinfo (Pat_constant (Const_bool false)) t2.pos, None, t2) in - mk (Tm_match {scrutinee=b; ret_opt=None; brs=[then_branch; else_branch]; rc_opt=None}) - (Range.union_ranges b.pos (Range.union_ranges t1.pos t2.pos)) - -////////////////////////////////////////////////////////////////////////////////////// -// Operations on squashed and other irrelevant/sub-singleton types -////////////////////////////////////////////////////////////////////////////////////// -let mk_squash u p = - let sq = fvar_with_dd PC.squash_lid None in - mk_app (mk_Tm_uinst sq [u]) [as_arg p] - -let mk_auto_squash u p = - let sq = fvar_with_dd PC.auto_squash_lid None in - mk_app (mk_Tm_uinst sq [u]) [as_arg p] - -let un_squash t = - let head, args = head_and_args t in - let head = unascribe head in - let head = un_uinst head in - match (compress head).n, args with - | Tm_fvar fv, [(p, _)] - when fv_eq_lid fv PC.squash_lid -> - Some p - | Tm_refine {b; phi=p}, [] -> - begin match b.sort.n with - | Tm_fvar fv when fv_eq_lid fv PC.unit_lid -> - let bs, p = Subst.open_term [mk_binder b] p in - let b = match bs with - | [b] -> b - | _ -> failwith "impossible" - in - // A bit paranoid, but need this check for terms like `u:unit{u == ()}` - if mem b.binder_bv (Free.names p) - then None - else Some p - | _ -> None - end - | _ -> - None - -let is_squash t = - let head, args = head_and_args t in - match (Subst.compress head).n, args with - | Tm_uinst({n=Tm_fvar fv}, [u]), [(t, _)] - when Syntax.fv_eq_lid fv PC.squash_lid -> - Some (u, t) - | _ -> None - - -let is_auto_squash t = - let head, args = head_and_args t in - match (Subst.compress head).n, args with - | Tm_uinst({n=Tm_fvar fv}, [u]), [(t, _)] - when Syntax.fv_eq_lid fv PC.auto_squash_lid -> - Some (u, t) - | _ -> None - -let is_sub_singleton t = - let head, _ = head_and_args (unmeta t) in - match (un_uinst head).n with - | Tm_fvar fv -> - Syntax.fv_eq_lid fv PC.unit_lid - || Syntax.fv_eq_lid fv PC.squash_lid - || Syntax.fv_eq_lid fv PC.auto_squash_lid - || Syntax.fv_eq_lid fv PC.and_lid - || Syntax.fv_eq_lid fv PC.or_lid - || Syntax.fv_eq_lid fv PC.not_lid - || Syntax.fv_eq_lid fv PC.imp_lid - || Syntax.fv_eq_lid fv PC.iff_lid - || Syntax.fv_eq_lid fv PC.ite_lid - || Syntax.fv_eq_lid fv PC.exists_lid - || Syntax.fv_eq_lid fv PC.forall_lid - || Syntax.fv_eq_lid fv PC.true_lid - || Syntax.fv_eq_lid fv PC.false_lid - || Syntax.fv_eq_lid fv PC.eq2_lid - || Syntax.fv_eq_lid fv PC.b2t_lid - //these are an uninterpreted predicates - //which we are better off treating as sub-singleton - || Syntax.fv_eq_lid fv PC.haseq_lid - || Syntax.fv_eq_lid fv PC.has_type_lid - || Syntax.fv_eq_lid fv PC.precedes_lid - | _ -> false - -let arrow_one_ln (t:typ) : option (binder & comp) = - match (compress t).n with - | Tm_arrow {bs=[]} -> - failwith "fatal: empty binders on arrow?" - | Tm_arrow {bs=[b]; comp=c} -> - Some (b, c) - | Tm_arrow {bs=b::bs; comp=c} -> - (* NB: bs are closed, so we just repackage the node *) - let rng' = List.fold_left (fun a b -> Range.union_ranges a b.binder_bv.sort.pos) c.pos bs in - let c' = mk_Total (mk (Tm_arrow {bs; comp=c}) rng') in - Some (b, c') - | _ -> - None - -let arrow_one (t:typ) : option (binder & comp) = - bind_opt (arrow_one_ln t) (fun (b, c) -> - let bs, c = Subst.open_comp [b] c in - let b = match bs with - | [b] -> b - | _ -> failwith "impossible: open_comp returned different amount of binders" - in - Some (b, c)) - -let abs_one_ln (t:typ) : option (binder & term) = - match (compress t).n with - | Tm_abs {bs=[]} -> - failwith "fatal: empty binders on abs?" - | Tm_abs {bs=[b]; body} -> - Some (b, body) - | Tm_abs {bs=b::bs; body; rc_opt} -> - Some (b, abs bs body rc_opt) - | _ -> - None - -let is_free_in (bv:bv) (t:term) : bool = - mem bv (FStar.Syntax.Free.names t) - -let action_as_lb eff_lid a pos = - let lb = - close_univs_and_mk_letbinding None - (Inr (lid_and_dd_as_fv a.action_name None)) - a.action_univs - (arrow a.action_params (mk_Total a.action_typ)) - PC.effect_Tot_lid - (abs a.action_params a.action_defn None) - [] - pos - in - { sigel = Sig_let {lbs=(false, [lb]); lids=[a.action_name]}; - sigrng = a.action_defn.pos; - sigquals = [Visible_default ; Action eff_lid]; - sigmeta = default_sigmeta; - sigattrs = []; - sigopts = None; - sigopens_and_abbrevs = []; - } - -(* Some reification utilities *) -let mk_reify t (lopt:option Ident.lident) = - let reify_ = mk (Tm_constant (FStar.Const.Const_reify lopt)) t.pos in - mk (Tm_app {hd=reify_; args=[as_arg t]}) t.pos - -let mk_reflect t = - let reflect_ = mk (Tm_constant(FStar.Const.Const_reflect (Ident.lid_of_str "Bogus.Effect"))) t.pos in - mk (Tm_app {hd=reflect_; args=[as_arg t]}) t.pos - -(* Some utilities for clients who wish to build top-level bindings and keep - * their delta-qualifiers correct (e.g. dmff). *) - -let rec incr_delta_depth d = - match d with - | Delta_constant_at_level i -> Delta_constant_at_level (i + 1) - | Delta_equational_at_level i -> Delta_equational_at_level (i + 1) - | Delta_abstract d -> incr_delta_depth d - -let is_unknown t = match (Subst.compress t).n with | Tm_unknown -> true | _ -> false - -let rec apply_last f l = match l with - | [] -> failwith "apply_last: got empty list" - | [a] -> [f a] - | (x::xs) -> x :: (apply_last f xs) - -let dm4f_lid ed name : lident = - let p = path_of_lid ed.mname in - let p' = apply_last (fun s -> "_dm4f_" ^ s ^ "_" ^ name) p in - lid_of_path p' Range.dummyRange - -let mk_list (typ:term) (rng:range) (l:list term) : term = - let ctor l = mk (Tm_fvar (lid_as_fv l (Some Data_ctor))) rng in - let cons args pos = mk_Tm_app (mk_Tm_uinst (ctor PC.cons_lid) [U_zero]) args pos in - let nil args pos = mk_Tm_app (mk_Tm_uinst (ctor PC.nil_lid) [U_zero]) args pos in - List.fold_right (fun t a -> cons [iarg typ; as_arg t; as_arg a] t.pos) l (nil [iarg typ] rng) - -// Some generic equalities -let rec eqlist (eq : 'a -> 'a -> bool) (xs : list 'a) (ys : list 'a) : bool = - match xs, ys with - | [], [] -> true - | x::xs, y::ys -> eq x y && eqlist eq xs ys - | _ -> false - -let eqsum (e1 : 'a -> 'a -> bool) (e2 : 'b -> 'b -> bool) (x : either 'a 'b) (y : either 'a 'b) : bool = - match x, y with - | Inl x, Inl y -> e1 x y - | Inr x, Inr y -> e2 x y - | _ -> false - -let eqprod (e1 : 'a -> 'a -> bool) (e2 : 'b -> 'b -> bool) (x : 'a & 'b) (y : 'a & 'b) : bool = - match x, y with - | (x1,x2), (y1,y2) -> e1 x1 y1 && e2 x2 y2 - -let eqopt (e : 'a -> 'a -> bool) (x : option 'a) (y : option 'a) : bool = - match x, y with - | Some x, Some y -> e x y - | None, None -> true - | _ -> false - -// Checks for syntactic equality. A returned false doesn't guarantee anything. -// We DO NOT OPEN TERMS as we descend on them, and just compare their bound variable -// indices. We also ignore some parts of the syntax such universes and most annotations. - -// Setting this ref to `true` causes messages to appear when -// some discrepancy was found. This is useful when trying to debug -// why term_eq is returning `false`. This reference is `one shot`, -// it will disable itself when term_eq returns, but in that single run -// it will provide a (backwards) trace of where the discrepancy apperared. -// -// Use at your own peril, and please keep it if there's no good -// reason against it, so I don't have to go crazy again. -let debug_term_eq = U.mk_ref false - -let check dbg msg cond = - if cond - then true - else (if dbg then U.print1 ">>> term_eq failing: %s\n" msg; false) - -let fail dbg msg = check dbg msg false - -let rec term_eq_dbg (dbg : bool) t1 t2 = - let t1 = canon_app (unmeta_safe t1) in - let t2 = canon_app (unmeta_safe t2) in - let check = check dbg in - let fail = fail dbg in - match (compress (un_uinst t1)).n, (compress (un_uinst t2)).n with - | Tm_uinst _, _ - | _, Tm_uinst _ - (* -> eqlist eq_univs us1 us2 && term_eq_dbg dbg t1 t2 *) - | Tm_delayed _, _ - | _, Tm_delayed _ - | Tm_ascribed _, _ - | _, Tm_ascribed _ -> - failwith "term_eq: impossible, should have been removed" - - | Tm_bvar x , Tm_bvar y -> check "bvar" (x.index = y.index) - | Tm_name x , Tm_name y -> check "name" (x.index = y.index) - | Tm_fvar x , Tm_fvar y -> check "fvar" (fv_eq x y) - | Tm_constant c1 , Tm_constant c2 -> check "const" (eq_const c1 c2) - | Tm_type _, Tm_type _ -> true // x = y - - | Tm_abs {bs=b1;body=t1;rc_opt=k1}, Tm_abs {bs=b2;body=t2;rc_opt=k2} -> - (check "abs binders" (eqlist (binder_eq_dbg dbg) b1 b2)) && - (check "abs bodies" (term_eq_dbg dbg t1 t2)) - //&& eqopt (eqsum lcomp_eq_dbg dbg residual_eq) k1 k2 - - | Tm_arrow {bs=b1;comp=c1}, Tm_arrow {bs=b2;comp=c2} -> - (check "arrow binders" (eqlist (binder_eq_dbg dbg) b1 b2)) && - (check "arrow comp" (comp_eq_dbg dbg c1 c2)) - - | Tm_refine {b=b1;phi=t1}, Tm_refine {b=b2;phi=t2} -> - (check "refine bv sort" (term_eq_dbg dbg b1.sort b2.sort)) && - (check "refine formula" (term_eq_dbg dbg t1 t2)) - - | Tm_app {hd=f1; args=a1}, Tm_app {hd=f2; args=a2} -> - (check "app head" (term_eq_dbg dbg f1 f2)) && - (check "app args" (eqlist (arg_eq_dbg dbg) a1 a2)) - - | Tm_match {scrutinee=t1;ret_opt=None;brs=bs1}, - Tm_match {scrutinee=t2;ret_opt=None;brs=bs2} -> //AR: note: no return annotations - (check "match head" (term_eq_dbg dbg t1 t2)) && - (check "match branches" (eqlist (branch_eq_dbg dbg) bs1 bs2)) - - | Tm_lazy _, _ -> check "lazy_l" (term_eq_dbg dbg (unlazy t1) t2) - | _, Tm_lazy _ -> check "lazy_r" (term_eq_dbg dbg t1 (unlazy t2)) - - | Tm_let {lbs=(b1, lbs1); body=t1}, Tm_let {lbs=(b2, lbs2); body=t2} -> - (check "let flag" (b1 = b2)) && - (check "let lbs" (eqlist (letbinding_eq_dbg dbg) lbs1 lbs2)) && - (check "let body" (term_eq_dbg dbg t1 t2)) - - | Tm_uvar (u1, _), Tm_uvar (u2, _) -> - (* These must have alreade been resolved, so we check that - * they are indeed the same uvar *) - check "uvar" (u1.ctx_uvar_head = u2.ctx_uvar_head) - - | Tm_quoted (qt1, qi1), Tm_quoted (qt2, qi2) -> - (check "tm_quoted qi" (quote_info_eq_dbg dbg qi1 qi2)) && - (check "tm_quoted payload" (term_eq_dbg dbg qt1 qt2)) - - | Tm_meta {tm=t1; meta=m1}, Tm_meta {tm=t2; meta=m2} -> - begin match m1, m2 with - | Meta_monadic (n1, ty1), Meta_monadic (n2, ty2) -> - (check "meta_monadic lid" (lid_equals n1 n2)) && - (check "meta_monadic type" (term_eq_dbg dbg ty1 ty2)) - - | Meta_monadic_lift (s1, t1, ty1), Meta_monadic_lift (s2, t2, ty2) -> - (check "meta_monadic_lift src" (lid_equals s1 s2)) && - (check "meta_monadic_lift tgt" (lid_equals t1 t2)) && - (check "meta_monadic_lift type" (term_eq_dbg dbg ty1 ty2)) - - | _ -> fail "metas" - end - - // ? - | Tm_unknown, _ - | _, Tm_unknown -> fail "unk" - - | Tm_bvar _, _ - | Tm_name _, _ - | Tm_fvar _, _ - | Tm_constant _, _ - | Tm_type _, _ - | Tm_abs _, _ - | Tm_arrow _, _ - | Tm_refine _, _ - | Tm_app _, _ - | Tm_match _, _ - | Tm_let _, _ - | Tm_uvar _, _ - | Tm_meta _, _ - | _, Tm_bvar _ - | _, Tm_name _ - | _, Tm_fvar _ - | _, Tm_constant _ - | _, Tm_type _ - | _, Tm_abs _ - | _, Tm_arrow _ - | _, Tm_refine _ - | _, Tm_app _ - | _, Tm_match _ - | _, Tm_let _ - | _, Tm_uvar _ - | _, Tm_meta _ -> fail "bottom" - -and arg_eq_dbg (dbg : bool) a1 a2 = - eqprod (fun t1 t2 -> check dbg "arg tm" (term_eq_dbg dbg t1 t2)) - (fun q1 q2 -> check dbg "arg qual" (aqual_eq_dbg dbg q1 q2)) - a1 a2 -and binder_eq_dbg (dbg : bool) b1 b2 = - (check dbg "binder_sort" (term_eq_dbg dbg b1.binder_bv.sort b2.binder_bv.sort)) && - (check dbg "binder qual" (bqual_eq_dbg dbg b1.binder_qual b2.binder_qual)) && //AR: not checking attributes, should we? - (check dbg "binder attrs" (eqlist (term_eq_dbg dbg) b1.binder_attrs b2.binder_attrs)) - -and comp_eq_dbg (dbg : bool) c1 c2 = - let eff1, res1, args1 = comp_eff_name_res_and_args c1 in - let eff2, res2, args2 = comp_eff_name_res_and_args c2 in - (check dbg "comp eff" (lid_equals eff1 eff2)) && - //(check "comp univs" (c1.comp_univs = c2.comp_univs)) && - (check dbg "comp result typ" (term_eq_dbg dbg res1 res2)) && - (* (check "comp args" (eqlist arg_eq_dbg dbg c1.effect_args c2.effect_args)) && *) - true //eq_flags c1.flags c2.flags -and branch_eq_dbg (dbg : bool) (p1,w1,t1) (p2,w2,t2) = - (check dbg "branch pat" (eq_pat p1 p2)) && - (check dbg "branch body" (term_eq_dbg dbg t1 t2)) - && (check dbg "branch when" ( - match w1, w2 with - | Some x, Some y -> term_eq_dbg dbg x y - | None, None -> true - | _ -> false)) - -and letbinding_eq_dbg (dbg : bool) (lb1 : letbinding) lb2 = - // bvars have no meaning here, so we just check they have the same name - (check dbg "lb bv" (eqsum (fun bv1 bv2 -> true) fv_eq lb1.lbname lb2.lbname)) && - (* (check "lb univs" (lb1.lbunivs = lb2.lbunivs)) *) - (check dbg "lb typ" (term_eq_dbg dbg lb1.lbtyp lb2.lbtyp)) && - (check dbg "lb def" (term_eq_dbg dbg lb1.lbdef lb2.lbdef)) - // Ignoring eff and attrs.. - -and quote_info_eq_dbg (dbg:bool) q1 q2 = - if q1.qkind <> q2.qkind - then false - else antiquotations_eq_dbg dbg (snd q1.antiquotations) (snd q2.antiquotations) - -and antiquotations_eq_dbg (dbg:bool) a1 a2 = - // Basically this; - // List.fold_left2 (fun acc t1 t2 -> eq_inj acc (eq_tm t1 t2)) Equal a1 a2 - // but lazy and handling lists of different size - match a1, a2 with - | [], [] -> true - | [], _ - | _, [] -> false - | t1::a1, t2::a2 -> - if not <| term_eq_dbg dbg t1 t2 - then false - else antiquotations_eq_dbg dbg a1 a2 - -and bqual_eq_dbg dbg a1 a2 = - match a1, a2 with - | None, None -> true - | None, _ - | _, None -> false - | Some (Implicit b1), Some (Implicit b2) when b1=b2 -> true - | Some (Meta t1), Some (Meta t2) -> term_eq_dbg dbg t1 t2 - | Some Equality, Some Equality -> true - | _ -> false - -and aqual_eq_dbg dbg a1 a2 = - match a1, a2 with - | Some a1, Some a2 -> - if a1.aqual_implicit = a2.aqual_implicit - && List.length a1.aqual_attributes = List.length a2.aqual_attributes - then List.fold_left2 - (fun out t1 t2 -> - if not out - then false - else term_eq_dbg dbg t1 t2) - true - a1.aqual_attributes - a2.aqual_attributes - else false - | None, None -> - true - | _ -> - false - -let eq_aqual a1 a2 = aqual_eq_dbg false a1 a2 -let eq_bqual b1 b2 = bqual_eq_dbg false b1 b2 - -let term_eq t1 t2 = - let r = term_eq_dbg !debug_term_eq t1 t2 in - debug_term_eq := false; - r - -// An estimation of the size of a term, only for debugging -let rec sizeof (t:term) : int = - match t.n with - | Tm_delayed _ -> 1 + sizeof (compress t) - | Tm_bvar bv - | Tm_name bv -> 1 + sizeof bv.sort - | Tm_uinst (t,us) -> List.length us + sizeof t - | Tm_abs {bs; body=t} -> sizeof t + List.fold_left (fun acc b -> acc + sizeof b.binder_bv.sort) 0 bs - | Tm_app {hd; args} -> sizeof hd + List.fold_left (fun acc (arg, _) -> acc + sizeof arg) 0 args - // TODO: obviously want much more - | _ -> 1 - -let is_fvar lid t = - match (un_uinst t).n with - | Tm_fvar fv -> fv_eq_lid fv lid - | _ -> false - -let is_synth_by_tactic t = - is_fvar PC.synth_lid t - -let has_attribute (attrs:list Syntax.attribute) (attr:lident) = - FStar.Compiler.Util.for_some (is_fvar attr) attrs - -(* Checks whether the list of attrs contains an application of `attr`, and - * returns the arguments if so. If there's more than one, the first one - * takes precedence. *) -let get_attribute (attr : lident) (attrs:list Syntax.attribute) : option args = - List.tryPick (fun t -> - let head, args = head_and_args t in - match (Subst.compress head).n with - | Tm_fvar fv when fv_eq_lid fv attr -> Some args - | _ -> None) attrs - -let remove_attr (attr : lident) (attrs:list attribute) : list attribute = - List.filter (fun a -> not (is_fvar attr a)) attrs - -/////////////////////////////////////////// -// Setting pragmas -/////////////////////////////////////////// -let process_pragma p r = - FStar.Errors.set_option_warning_callback_range (Some r); - let set_options s = - match Options.set_options s with - | Getopt.Success -> () - | Getopt.Help -> - Errors.raise_error r Errors.Fatal_FailToProcessPragma - "Failed to process pragma: use 'fstar --help' to see which options are available" - | Getopt.Error s -> - Errors.raise_error r Errors.Fatal_FailToProcessPragma - ("Failed to process pragma: " ^ s) - in - match p with - | ShowOptions -> - () - - | SetOptions o -> - set_options o - - | ResetOptions sopt -> - Options.restore_cmd_line_options false |> ignore; - begin match sopt with - | None -> () - | Some s -> set_options s - end - - | PushOptions sopt -> - Options.internal_push (); - begin match sopt with - | None -> () - | Some s -> set_options s - end - - | RestartSolver -> - () - - | PopOptions -> - if not (Options.internal_pop ()) then - Errors.raise_error r Errors.Fatal_FailToProcessPragma - "Cannot #pop-options, stack would become empty" - - | PrintEffectsGraph -> () //Typechecker handles it - -/////////////////////////////////////////////////////////////////////////////////////////////// -let rec unbound_variables tm : list bv = - let t = Subst.compress tm in - match t.n with - | Tm_delayed _ -> failwith "Impossible" - - | Tm_name x -> - [] - - | Tm_uvar _ -> - [] - - | Tm_type u -> - [] - - | Tm_bvar x -> - [x] - - | Tm_fvar _ - | Tm_constant _ - | Tm_lazy _ - | Tm_unknown -> - [] - - | Tm_uinst(t, us) -> - unbound_variables t - - | Tm_abs {bs; body=t} -> - let bs, t = Subst.open_term bs t in - List.collect (fun b -> unbound_variables b.binder_bv.sort) bs - @ unbound_variables t - - | Tm_arrow {bs; comp=c} -> - let bs, c = Subst.open_comp bs c in - List.collect (fun b -> unbound_variables b.binder_bv.sort) bs - @ unbound_variables_comp c - - | Tm_refine {b; phi=t} -> - let bs, t = Subst.open_term [mk_binder b] t in - List.collect (fun b -> unbound_variables b.binder_bv.sort) bs - @ unbound_variables t - - | Tm_app {hd=t; args} -> - List.collect (fun (x, _) -> unbound_variables x) args - @ unbound_variables t - - | Tm_match {scrutinee=t; ret_opt=asc_opt; brs=pats} -> - unbound_variables t - @ (match asc_opt with - | None -> [] - | Some (b, asc) -> - let bs, asc = Subst.open_ascription [b] asc in - List.collect (fun b -> unbound_variables b.binder_bv.sort) bs - @ unbound_variables_ascription asc) - @ (pats |> List.collect (fun br -> - let p, wopt, t = Subst.open_branch br in - unbound_variables t - @ (match wopt with None -> [] | Some t -> unbound_variables t))) - - | Tm_ascribed {tm=t1; asc} -> - unbound_variables t1 @ (unbound_variables_ascription asc) - - | Tm_let {lbs=(false, [lb]); body=t} -> - unbound_variables lb.lbtyp - @ unbound_variables lb.lbdef - @ (match lb.lbname with - | Inr _ -> unbound_variables t - | Inl bv -> let _, t= Subst.open_term [mk_binder bv] t in - unbound_variables t) - - | Tm_let {lbs=(_, lbs); body=t} -> - let lbs, t = Subst.open_let_rec lbs t in - unbound_variables t - @ List.collect (fun lb -> unbound_variables lb.lbtyp @ unbound_variables lb.lbdef) lbs - - | Tm_quoted (tm, qi) -> - begin match qi.qkind with - | Quote_static -> [] - | Quote_dynamic -> unbound_variables tm - end - - | Tm_meta {tm=t; meta=m} -> - unbound_variables t - @ (match m with - | Meta_pattern (_, args) -> - List.collect (List.collect (fun (a, _) -> unbound_variables a)) args - - | Meta_monadic_lift(_, _, t') - | Meta_monadic(_, t') -> - unbound_variables t' - - | Meta_labeled _ - | Meta_desugared _ - | Meta_named _ -> []) - -and unbound_variables_ascription asc = - let asc, topt, _ = asc in - (match asc with - | Inl t2 -> unbound_variables t2 - | Inr c2 -> unbound_variables_comp c2) @ - (match topt with - | None -> [] - | Some tac -> unbound_variables tac) - -and unbound_variables_comp c = - match c.n with - | Total t - | GTotal t -> - unbound_variables t - - | Comp ct -> - unbound_variables ct.result_typ - @ List.collect (fun (a, _) -> unbound_variables a) ct.effect_args - -let extract_attr' (attr_lid:lid) (attrs:list term) : option (list term & args) = - let rec aux acc attrs = - match attrs with - | [] -> None - | h::t -> - let head, args = head_and_args h in - begin match (compress head).n with - | Tm_fvar fv when fv_eq_lid fv attr_lid -> - let attrs' = List.rev_acc acc t in - Some (attrs', args) - | _ -> - aux (h::acc) t - end - in - aux [] attrs - -let extract_attr (attr_lid:lid) (se:sigelt) : option (sigelt & args) = - match extract_attr' attr_lid se.sigattrs with - | None -> None - | Some (attrs', t) -> Some ({ se with sigattrs = attrs' }, t) - -(* Utilities for working with Lemma's decorated with SMTPat *) -let is_smt_lemma t = match (compress t).n with - | Tm_arrow {comp=c} -> - begin match c.n with - | Comp ct when lid_equals ct.effect_name PC.effect_Lemma_lid -> - begin match ct.effect_args with - | _req::_ens::(pats, _)::_ -> - let pats' = unmeta pats in - let head, _ = head_and_args pats' in - begin match (un_uinst head).n with - | Tm_fvar fv -> fv_eq_lid fv PC.cons_lid - | _ -> false - end - | _ -> false - end - | _ -> false - end - | _ -> false - -let rec list_elements (e:term) : option (list term) = - let head, args = head_and_args (unmeta e) in - match (un_uinst head).n, args with - | Tm_fvar fv, _ when fv_eq_lid fv PC.nil_lid -> - Some [] - | Tm_fvar fv, [_; (hd, _); (tl, _)] when fv_eq_lid fv PC.cons_lid -> - Some (hd::must (list_elements tl)) - | _ -> - None - -let destruct_lemma_with_smt_patterns (t:term) -: option (binders & term & term & list (list arg)) -//binders, pre, post, patterns -= let lemma_pats p = - let smt_pat_or t = - let head, args = unmeta t |> head_and_args in - match (un_uinst head).n, args with - | Tm_fvar fv, [(e, _)] - when fv_eq_lid fv PC.smtpatOr_lid -> - Some e - | _ -> None - in - let one_pat p = - let head, args = unmeta p |> head_and_args in - match (un_uinst head).n, args with - | Tm_fvar fv, [(_, _); arg] when fv_eq_lid fv PC.smtpat_lid -> - arg - | _ -> - let open FStar.Class.PP in - let open FStar.Errors.Msg in - let open FStar.Pprint in - Errors.raise_error p Errors.Error_IllSMTPat [ - prefix 2 1 (text "Not an atomic SMT pattern:") - (ttd p); - text "Patterns on lemmas must be a list of simple SMTPat's;\ - or a single SMTPatOr containing a list;\ - of lists of patterns." - ] - in - let list_literal_elements (e:term) : list term = - match list_elements e with - | Some l -> l - | None -> - Errors.log_issue e Errors.Warning_NonListLiteralSMTPattern - "SMT pattern is not a list literal; ignoring the pattern"; - [] - in - let elts = list_literal_elements p in - match elts with - | [t] -> ( - match smt_pat_or t with - | Some e -> - list_literal_elements e |> - List.map (fun branch -> (list_literal_elements branch) |> List.map one_pat) - | _ -> [elts |> List.map one_pat] - ) - | _ -> [elts |> List.map one_pat] - in - match (Subst.compress t).n with - | Tm_arrow {bs=binders; comp=c} -> - let binders, c = Subst.open_comp binders c in - begin match c.n with - | Comp ({effect_args=[(pre, _); (post, _); (pats, _)]}) -> - Some (binders, pre, post, lemma_pats pats) - | _ -> failwith "impos" - end - - | _ -> None - -let triggers_of_smt_lemma (t:term) -: list (list lident) //for each disjunctive pattern - //for each conjunct - //triggers in a conjunt -= //is_smt_lemma t - match destruct_lemma_with_smt_patterns t with - | None -> [] - | Some (_, _, _, pats) -> - List.map (List.collect (fun (t, _) -> elems <| FStar.Syntax.Free.fvars t)) pats - -(* Takes a term of shape `fun x -> e` and returns `e` when -`x` is not free in it. If it is free or the term -has some other shape just apply it to `()`. *) -let unthunk (t:term) : term = - match (compress t).n with - | Tm_abs {bs=[b]; body=e} -> - let bs, e = open_term [b] e in - let b = List.hd bs in - if is_free_in b.binder_bv e - then mk_app t [as_arg exp_unit] - else e - | _ -> - mk_app t [as_arg exp_unit] - -let unthunk_lemma_post t = - unthunk t - -let smt_lemma_as_forall (t:term) (universe_of_binders: binders -> list universe) -: term -= let binders, pre, post, patterns = - match destruct_lemma_with_smt_patterns t with - | None -> failwith "impos" - | Some res -> res - in - (* Postcondition is thunked, c.f. #57 *) - let post = unthunk_lemma_post post in - let body = mk (Tm_meta {tm=mk_imp pre post; - meta=Meta_pattern (binders_to_names binders, patterns)}) t.pos in - let quant = - List.fold_right2 - (fun b u out -> mk_forall u b.binder_bv out) - binders - (universe_of_binders binders) - body - in - quant - -(* End SMT Lemma utilities *) - - -(* Effect utilities *) - -(* - * Mainly reading the combinators out of the eff_decl record - * - * For combinators that are present only in either wp or layered effects, - * their getters return option tscheme - * Leaving it to the callers to deal with it - *) - -let effect_sig_ts (sig:effect_signature) : tscheme = - match sig with - | Layered_eff_sig (_, ts) - | WP_eff_sig ts -> ts - -let apply_eff_sig (f:tscheme -> tscheme) = function - | Layered_eff_sig (n, ts) -> Layered_eff_sig (n, f ts) - | WP_eff_sig ts -> WP_eff_sig (f ts) - -let eff_decl_of_new_effect (se:sigelt) :eff_decl = - match se.sigel with - | Sig_new_effect ne -> ne - | _ -> failwith "eff_decl_of_new_effect: not a Sig_new_effect" - -let is_layered (ed:eff_decl) : bool = - match ed.combinators with - | Layered_eff _ -> true - | _ -> false - -let is_dm4f (ed:eff_decl) : bool = - match ed.combinators with - | DM4F_eff _ -> true - | _ -> false - -let apply_wp_eff_combinators (f:tscheme -> tscheme) (combs:wp_eff_combinators) -: wp_eff_combinators -= { ret_wp = f combs.ret_wp; - bind_wp = f combs.bind_wp; - stronger = f combs.stronger; - if_then_else = f combs.if_then_else; - ite_wp = f combs.ite_wp; - close_wp = f combs.close_wp; - trivial = f combs.trivial; - - repr = map_option f combs.repr; - return_repr = map_option f combs.return_repr; - bind_repr = map_option f combs.bind_repr } - -let apply_layered_eff_combinators (f:tscheme -> tscheme) (combs:layered_eff_combinators) -: layered_eff_combinators -= let map2 (ts1, ts2) = (f ts1, f ts2) in - let map3 (ts1, ts2, k) = (f ts1, f ts2, k) in - { l_repr = map2 combs.l_repr; - l_return = map2 combs.l_return; - l_bind = map3 combs.l_bind; - l_subcomp = map3 combs.l_subcomp; - l_if_then_else = map3 combs.l_if_then_else; - l_close = map_option map2 combs.l_close; } - -let apply_eff_combinators (f:tscheme -> tscheme) (combs:eff_combinators) : eff_combinators = - match combs with - | Primitive_eff combs -> Primitive_eff (apply_wp_eff_combinators f combs) - | DM4F_eff combs -> DM4F_eff (apply_wp_eff_combinators f combs) - | Layered_eff combs -> Layered_eff (apply_layered_eff_combinators f combs) - -let get_layered_close_combinator (ed:eff_decl) : option tscheme = - match ed.combinators with - | Layered_eff {l_close=None} -> None - | Layered_eff {l_close=Some (ts, _)} -> Some ts - | _ -> None - -let get_wp_close_combinator (ed:eff_decl) : option tscheme = - match ed.combinators with - | Primitive_eff combs - | DM4F_eff combs -> Some combs.close_wp - | _ -> None - -let get_eff_repr (ed:eff_decl) : option tscheme = - match ed.combinators with - | Primitive_eff combs - | DM4F_eff combs -> combs.repr - | Layered_eff combs -> fst combs.l_repr |> Some - -let get_bind_vc_combinator (ed:eff_decl) : tscheme & option indexed_effect_combinator_kind = - match ed.combinators with - | Primitive_eff combs - | DM4F_eff combs -> combs.bind_wp, None - | Layered_eff combs -> Mktuple3?._2 combs.l_bind, Mktuple3?._3 combs.l_bind - -let get_return_vc_combinator (ed:eff_decl) : tscheme = - match ed.combinators with - | Primitive_eff combs - | DM4F_eff combs -> combs.ret_wp - | Layered_eff combs -> snd combs.l_return - -let get_bind_repr (ed:eff_decl) : option tscheme = - match ed.combinators with - | Primitive_eff combs - | DM4F_eff combs -> combs.bind_repr - | Layered_eff combs -> Mktuple3?._1 combs.l_bind |> Some - -let get_return_repr (ed:eff_decl) : option tscheme = - match ed.combinators with - | Primitive_eff combs - | DM4F_eff combs -> combs.return_repr - | Layered_eff combs -> fst combs.l_return |> Some - -let get_wp_trivial_combinator (ed:eff_decl) : option tscheme = - match ed.combinators with - | Primitive_eff combs - | DM4F_eff combs -> combs.trivial |> Some - | _ -> None - -let get_layered_if_then_else_combinator (ed:eff_decl) : option (tscheme & option indexed_effect_combinator_kind) = - match ed.combinators with - | Layered_eff combs -> Some (Mktuple3?._1 combs.l_if_then_else, Mktuple3?._3 combs.l_if_then_else) - | _ -> None - -let get_wp_if_then_else_combinator (ed:eff_decl) : option tscheme = - match ed.combinators with - | Primitive_eff combs - | DM4F_eff combs -> combs.if_then_else |> Some - | _ -> None - -let get_wp_ite_combinator (ed:eff_decl) : option tscheme = - match ed.combinators with - | Primitive_eff combs - | DM4F_eff combs -> combs.ite_wp |> Some - | _ -> None - -let get_stronger_vc_combinator (ed:eff_decl) : tscheme & option indexed_effect_combinator_kind = - match ed.combinators with - | Primitive_eff combs - | DM4F_eff combs -> combs.stronger, None - | Layered_eff combs -> Mktuple3?._2 combs.l_subcomp, Mktuple3?._3 combs.l_subcomp - -let get_stronger_repr (ed:eff_decl) : option tscheme = - match ed.combinators with - | Primitive_eff _ - | DM4F_eff _ -> None - | Layered_eff combs -> Mktuple3?._1 combs.l_subcomp |> Some - -let aqual_is_erasable (aq:aqual) = - match aq with - | None -> false - | Some aq -> U.for_some (is_fvar PC.erasable_attr) aq.aqual_attributes - -let is_erased_head (t:term) : option (universe & term) = - let head, args = head_and_args t in - match head.n, args with - | Tm_uinst({n=Tm_fvar fv}, [u]), [(ty, _)] - when fv_eq_lid fv PC.erased_lid -> - Some (u, ty) - | _ -> - None - -let apply_reveal (u:universe) (ty:term) (v:term) = - let head = fvar (Ident.set_lid_range PC.reveal v.pos) None in - mk_Tm_app (mk_Tm_uinst head [u]) - [iarg ty; as_arg v] - v.pos - -let check_mutual_universes (lbs:list letbinding) - : unit - = let lb::lbs = lbs in - let expected = lb.lbunivs in - let expected_len = List.length expected in - List.iter - (fun lb -> - if List.length lb.lbunivs <> expected_len - || not (List.forall2 Ident.ident_equals lb.lbunivs expected) - then FStar.Errors.raise_error lb.lbpos Errors.Fatal_IncompatibleUniverse - "Mutually recursive definitions do not abstract over the same universes") - lbs - -let ctx_uvar_should_check (u:ctx_uvar) = - (Unionfind.find_decoration u.ctx_uvar_head).uvar_decoration_should_check - -let ctx_uvar_typ (u:ctx_uvar) = - (Unionfind.find_decoration u.ctx_uvar_head).uvar_decoration_typ - -let ctx_uvar_typedness_deps (u:ctx_uvar) = - (Unionfind.find_decoration u.ctx_uvar_head).uvar_decoration_typedness_depends_on - -let flatten_refinement t = - let rec aux t unascribe = - let t = compress t in - match t.n with - | Tm_ascribed {tm=t} when unascribe -> - aux t true - | Tm_refine {b=x; phi} -> ( - let t0 = aux x.sort true in - match t0.n with - | Tm_refine {b=y; phi=phi1} -> - //NB: this is working on de Bruijn - // representations; so no need - // to substitute y/x in phi - mk (Tm_refine {b=y; phi=mk_conj_simp phi1 phi}) t0.pos - | _ -> t - ) - | _ -> t - in - aux t false - -let contains_strictly_positive_attribute (attrs:list attribute) -: bool -= has_attribute attrs PC.binder_strictly_positive_attr - -let contains_unused_attribute (attrs:list attribute) -: bool -= has_attribute attrs PC.binder_unused_attr - -//retains the original attributes as is, while deciding if they contains -//the "strictly_positive" attribute -//we retain the attributes since they will then be carried in arguments -//that are applied to the corresponding binder, which is used in embeddings -//and Rel to construct binders from arguments alone -let parse_positivity_attributes (attrs:list attribute) -: option positivity_qualifier & list attribute -= if contains_unused_attribute attrs - then Some BinderUnused, attrs - else if contains_strictly_positive_attribute attrs - then Some BinderStrictlyPositive, attrs - else None, attrs - -let encode_positivity_attributes (pqual:option positivity_qualifier) (attrs:list attribute) -: list attribute -= match pqual with - | None -> attrs - | Some BinderStrictlyPositive -> - if contains_strictly_positive_attribute attrs - then attrs - else FStar.Syntax.Syntax.fv_to_tm (lid_as_fv PC.binder_strictly_positive_attr None) - :: attrs - | Some BinderUnused -> - if contains_unused_attribute attrs - then attrs - else FStar.Syntax.Syntax.fv_to_tm (lid_as_fv PC.binder_unused_attr None) - :: attrs - -let is_binder_strictly_positive (b:binder) = - b.binder_positivity = Some BinderStrictlyPositive - -let is_binder_unused (b:binder) = - b.binder_positivity = Some BinderUnused - -let deduplicate_terms (l:list term) = - FStar.Compiler.List.deduplicate (fun x y -> term_eq x y) l - -let eq_binding b1 b2 = - match b1, b2 with - | Binding_var bv1, Binding_var bv2 -> bv_eq bv1 bv2 && term_eq bv1.sort bv2.sort - | Binding_lid (lid1, _), Binding_lid (lid2, _) -> lid_equals lid1 lid2 - | Binding_univ u1, Binding_univ u2 -> ident_equals u1 u2 - | _ -> false diff --git a/src/syntax/FStar.Syntax.Visit.fst b/src/syntax/FStar.Syntax.Visit.fst deleted file mode 100644 index 0bad92241b8..00000000000 --- a/src/syntax/FStar.Syntax.Visit.fst +++ /dev/null @@ -1,28 +0,0 @@ -module FStar.Syntax.Visit - -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Compiler.Util - -open FStar.Syntax.VisitM -open FStar.Class.Monad - -type id (a:Type) = | I : run:a -> id a - -(* We just reuse VisitM with the identity monad to implement this module. *) - -instance _ : monad id = { - return = (fun a -> I a); - ( let! ) = (fun (I a) f -> f a); -} - -let (<<) f g = fun x -> f (g x) - -let visit_term pq vt t = - I?.run (visitM_term pq (I << vt) t) - -let visit_term_univs pq vt vu t = - I?.run (visitM_term_univs pq (I << vt) (I << vu) t) - -let visit_sigelt pq vt vu se = - I?.run (visitM_sigelt pq (I << vt) (I << vu) se) diff --git a/src/syntax/FStar.Syntax.Visit.fsti b/src/syntax/FStar.Syntax.Visit.fsti deleted file mode 100644 index 79afc0ebfc3..00000000000 --- a/src/syntax/FStar.Syntax.Visit.fsti +++ /dev/null @@ -1,59 +0,0 @@ -module FStar.Syntax.Visit - -open FStar.Syntax.Syntax - -(* This is a `map` visitor over terms, `visit f t` returns a version of -`t` "adjusted" by applying `f` on every node. The traversal is bottom up -(and there is no shortcircuit/cancel mechanism). Every `term` included -in `t` is visited and transformed, (function bodies, head and args of -application, binder types, bv sorts, effect args, decreases clauses, -etc). If something is not covered, that is a bug. - -NOTE: no binders are opened nor closed in this traversal. The traversal -preserves ranges but discards memoized info (vars and hash_code). - -The `f` function should handle only the cases are interesting to it, -defaulting to returning the original term elsewhere. For instance, this -(only slightly ficticious) call - - visit (fun t -> - match head_and_args t with - | (Tm_fvar plus, [a1;a2]) where fv_eq_lid plus PC.op_Addition -> - let n1 = unembed a1 in - let n2 = unembed a2 in - mk (Tm_const (C_int n2)) - - | (Tm_fvar plus, _) where fv_eq_lid plus PC.op_Addition -> - raise BadApplication - - | _ -> t - ) tm - -Will fold additions of two constants, raise an exception if the addition -operator is applied to anything but constants, and leave everything else -unchanged. As the traversal is bottom-up, this should fold expressions -like (1+2)+(3+4) in a single call. -*) -val visit_term - (proc_quotes : bool) - (f : term -> term) - (t : term) - : term - -(* As above, but a callback for universes can also be provided that works -in the same manner. In visit_term, it just defaults to the identity. *) -val visit_term_univs - (proc_quotes : bool) - (ft : term -> term) - (fu : universe -> universe) - (t : term) - : term - -(* As above, but works on any sigelt, visiting all of its underlying -terms and universes. *) -val visit_sigelt - (proc_quotes : bool) - (vt : term -> term) - (vu : universe -> universe) - (t : sigelt) - : sigelt diff --git a/src/syntax/FStar.Syntax.VisitM.fst b/src/syntax/FStar.Syntax.VisitM.fst deleted file mode 100644 index ab125b3234d..00000000000 --- a/src/syntax/FStar.Syntax.VisitM.fst +++ /dev/null @@ -1,540 +0,0 @@ -module FStar.Syntax.VisitM - -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Compiler.Util - -open FStar.Class.Monad - -open FStar.Syntax -open FStar.Syntax.Syntax - -type endo (m:Type -> Type) a = a -> m a - -(* local visitor monad, this class is not exposed, it's just -a local shortcut. *) -class lvm (m:Type->Type) : Type = { - lvm_monad : monad m; - - f_term : endo m term; - f_binder : endo m binder; - f_binding_bv : endo m bv; - f_br : endo m branch; - f_comp : endo m comp; - f_residual_comp : endo m residual_comp; - f_univ : endo m universe; - - proc_quotes : bool; -} - -instance _lvm_monad (#m:_) (_ : lvm m) : Tot (monad m) = lvm_monad - -let novfs (#m:Type->Type) {| monad m |} : lvm m = { - lvm_monad = FStar.Tactics.Typeclasses.solve; - f_term = return; - f_binder = return; - f_binding_bv = return; - f_br = return; - f_comp = return; - f_residual_comp = return; - f_univ = return; - - proc_quotes = false; -} - -let f_aqual #m {|_ : lvm m|} aq : m _ = - let {aqual_implicit=i; aqual_attributes=attrs} = aq in - let! attrs = mapM f_term attrs in - return {aqual_implicit=i; aqual_attributes=attrs} - -let on_sub_arg #m {|_ : lvm m|} (a : arg) : m arg = - let (t, q) = a in - let! t = t |> f_term in - let! q = q |> map_optM f_aqual in - return (t, q) - -let on_sub_tscheme #m {| monad m |} {|_ : lvm m|} (ts : tscheme) : m tscheme = - let (us, t) = ts in - let! t = t |> f_term in // FIXME: push univs - return (us, t) - -(* Homeomorphic calls... for now *) -let f_arg #m {|_ : lvm m|} : _ -> m _ = on_sub_arg -let f_args #m {|d : lvm m|} : _ -> m _ = mapM (f_arg #m #d) // FIXME: why instantiate? -let f_tscheme #m {|_ : lvm m|} : tscheme -> m tscheme = on_sub_tscheme - -let on_sub_meta #m {| d : lvm m |} (md : metadata) : m metadata = - match md with - | Meta_pattern (pats, args) -> - let! pats = pats |> mapM f_term in - let! args = args |> mapM (f_args #m #d) in // FIXME: idem - return <| Meta_pattern (pats, args) - - | Meta_monadic (m, typ) -> - let! typ = typ |> f_term in - return <| Meta_monadic (m, typ) - - | Meta_monadic_lift (m1, m2, typ) -> - let! typ = typ |> f_term in - return <| Meta_monadic_lift (m1, m2, typ) - - (* no subterms *) - | Meta_named lid -> return <| Meta_named lid - | Meta_labeled (s,r,b) -> return <|Meta_labeled (s,r,b) - | Meta_desugared i -> return <| Meta_desugared i - -let on_sub_letbinding #m {|lvm m|} (lb : letbinding) : m letbinding = - let! lbname = - match lb.lbname with - | Inl bv -> Inl <$> f_binding_bv bv - | Inr fv -> return (Inr fv) - in - let lbunivs = lb.lbunivs in - let! lbtyp = f_term lb.lbtyp in - let lbeff = lb.lbeff in - let! lbattrs = mapM f_term lb.lbattrs in - let lbpos = lb.lbpos in - let! lbdef = f_term lb.lbdef in // FIXME: push binder - return <| { lbname; lbunivs; lbtyp; lbeff; lbattrs; lbpos; lbdef; } - -let on_sub_ascription #m {| lvm m |} (a : ascription) : m ascription = - let (tc, tacopt, b) = a in - let! tc = match tc with - | Inl t -> Inl <$> f_term t - | Inr c -> Inr <$> f_comp c - in - let! tacopt = map_optM f_term tacopt in - return (tc, tacopt, b) - -(* Compress+unlazy *) -let rec compress (tm:term) : term = - let tm = Subst.compress tm in - match tm.n with - (* unfold and retry *) - | Tm_lazy li -> - let tm' = must !lazy_chooser li.lkind li in - compress tm' - - | _ -> tm - -(* Not recursive itself! This does not apply anything deeply! The -recursion on deep subterms comes from the knot being tied below. *) -let on_sub_term #m {|d : lvm m |} (tm : term) : m term = - let mk t = Syntax.mk t tm.pos in - let tm = compress tm in - match tm.n with - | Tm_lazy _ - | Tm_delayed _ -> - failwith "impos" - - (* no subterms *) - | Tm_fvar _ - | Tm_constant _ - | Tm_unknown - | Tm_bvar _ - | Tm_name _ - | Tm_uvar _ -> - return tm - - | Tm_uinst (f, us) -> - let! f = f_term f in - let! us = mapM f_univ us in - return <| mk (Tm_uinst (f, us)) - - | Tm_type u -> - let! u = u |> f_univ in - return <| mk (Tm_type u) - - | Tm_app {hd; args} -> - let! hd = f_term hd in - let! args = mapM (f_arg #m #d) args in - return <| mk (Tm_app {hd; args}) - - | Tm_abs {bs; body=t; rc_opt} -> - let! bs = mapM f_binder bs in - let! t = f_term t in - let! rc_opt = map_optM f_residual_comp rc_opt in - return <| mk (Tm_abs {bs; body=t; rc_opt}) - - | Tm_arrow {bs; comp=c} -> - let! bs = mapM f_binder bs in - let! c = f_comp c in - return <| mk (Tm_arrow {bs; comp=c}) - - | Tm_refine {b=bv; phi} -> - let! bv = f_binding_bv bv in - let! phi = f_term phi in - return <| mk (Tm_refine {b=bv; phi}) - - | Tm_match {scrutinee=sc; ret_opt=asc_opt; brs; rc_opt} -> - let! sc = f_term sc in - let! asc_opt = asc_opt |> map_optM (fun (b, asc) -> Mktuple2 <$> f_binder b <*> on_sub_ascription asc <: m _) in - let! brs = mapM f_br brs in - let! rc_opt = rc_opt |> map_optM f_residual_comp in - return <| mk (Tm_match {scrutinee=sc; ret_opt=asc_opt; brs; rc_opt}) - - | Tm_ascribed {tm=e; asc=a; eff_opt=lopt} -> - let! e = f_term e in - let! a = a |> on_sub_ascription in - return <| mk (Tm_ascribed {tm=e; asc=a; eff_opt=lopt}) - - | Tm_let {lbs=(is_rec, lbs); body=t} -> - let! lbs = lbs |> mapM on_sub_letbinding in - let! t = t |> f_term in - return <| mk (Tm_let {lbs=(is_rec, lbs); body=t}) - - | Tm_quoted (qtm, qi) -> - if d.proc_quotes || qi.qkind = Quote_dynamic then - let! qtm = qtm |> f_term in - // let! qi = Syntax.on_antiquoted (f_term vfs) qi in - // FIXME ^ no monadic variant - return <| mk (Tm_quoted (qtm, qi)) - else - return tm - - | Tm_meta {tm=t; meta=md} -> - let! t = t |> f_term in - let! md = md |> on_sub_meta in - return <| mk (Tm_meta {tm=t; meta=md}) - -let on_sub_binding_bv #m {|d : lvm m |} (x : bv) : m bv = - let! sort = x.sort |> f_term in - return { x with sort = sort } - -let on_sub_binder #m {|d : lvm m |} (b : binder) : m binder = - let! binder_bv = b.binder_bv |> f_binding_bv in - let! binder_qual = b.binder_qual |> map_optM (function Meta t -> Meta <$> f_term t - | q -> return q) in - let binder_positivity = b.binder_positivity in - let! binder_attrs = b.binder_attrs |> mapM f_term in - return <| { - binder_bv; - binder_qual; - binder_positivity; - binder_attrs; - } - -let rec on_sub_pat #m {|d : lvm m |} (p0 : pat) : m pat = - let mk p = { v=p; p=p0.p } in - match p0.v with - | Pat_constant _ -> - return p0 - - | Pat_cons (fv, us, subpats) -> - let! us = us |> map_optM (mapM #m f_univ) in - let! subpats = subpats |> mapM (fun (p, b) -> Mktuple2 <$> on_sub_pat p <*> return b <: m _) in - return <| mk (Pat_cons (fv, us, subpats)) - - | Pat_var bv -> - let! bv = bv |> f_binding_bv in - return <| mk (Pat_var bv) - - | Pat_dot_term t -> - let! t = t |> map_optM f_term in - return <| mk (Pat_dot_term t) - -let on_sub_br #m {|d : lvm m |} br : m _ = - let (pat, wopt, body) = br in - let! pat = pat |> on_sub_pat in - let! wopt = wopt |> map_optM f_term in - let! body = body |> f_term in - return (pat, wopt, body) - -let on_sub_comp_typ #m {|d : lvm m |} ct : m _ = - let! comp_univs = ct.comp_univs |> mapM f_univ in - let effect_name = ct.effect_name in - let! result_typ = ct.result_typ |> f_term in - let! effect_args = ct.effect_args |> mapM (f_arg #m #d) in - let flags = ct.flags in - return <| { - comp_univs; - effect_name; - result_typ; - effect_args; - flags; - } - -let on_sub_comp #m {|d : lvm m |} c : m comp = - let! cn = - match c.n with - | Total typ -> Total <$> f_term typ - | GTotal typ -> GTotal <$> f_term typ - | Comp ct -> Comp <$> on_sub_comp_typ ct - in - return <| Syntax.mk cn c.pos - -let __on_decreases #m {|d : lvm m |} f : cflag -> m cflag = function - | DECREASES (Decreases_lex l) -> DECREASES <$> (Decreases_lex <$> mapM f l) - | DECREASES (Decreases_wf (r, t)) -> DECREASES <$> (Decreases_wf <$> (Mktuple2 <$> f r <*> f t)) - | f -> return f - -let on_sub_residual_comp #m {|d : lvm m |} (rc : residual_comp) : m residual_comp = - let residual_effect = rc.residual_effect in - let! residual_typ = rc.residual_typ |> map_optM f_term in - let! residual_flags = rc.residual_flags |> mapM (__on_decreases f_term) in - // ^ review: residual flags should not have terms - return <| { - residual_effect; - residual_typ; - residual_flags; - } - -let on_sub_univ #m {|d : lvm m |} (u : universe) : m universe = - let u = Subst.compress_univ u in - match u with - | U_max us -> - U_max <$> mapM f_univ us - | U_succ u -> - U_succ <$> f_univ u - - | U_zero - | U_bvar _ - | U_name _ - | U_unknown - | U_unif _ -> - return u - -let on_sub_wp_eff_combinators #m {|d : lvm m |} (wpcs : wp_eff_combinators) : m wp_eff_combinators = - let! ret_wp = wpcs.ret_wp |> f_tscheme in - let! bind_wp = wpcs.bind_wp |> f_tscheme in - let! stronger = wpcs.stronger |> f_tscheme in - let! if_then_else = wpcs.if_then_else |> f_tscheme in - let! ite_wp = wpcs.ite_wp |> f_tscheme in - let! close_wp = wpcs.close_wp |> f_tscheme in - let! trivial = wpcs.trivial |> f_tscheme in - - let! repr = wpcs.repr |> map_optM (f_tscheme #m #d) in // FIXME: implicits - let! return_repr = wpcs.return_repr |> map_optM (f_tscheme #m #d) in - let! bind_repr = wpcs.bind_repr |> map_optM (f_tscheme #m #d) in - return <| { - ret_wp; - bind_wp; - stronger; - if_then_else; - ite_wp; - close_wp; - trivial; - - repr; - return_repr; - bind_repr; - } - -let mapTuple2 #m {| monad m |} (f : 'a -> m 'b) (g : 'c -> m 'd) (t : 'a & 'c) : m ('b & 'd) = - Mktuple2 <$> f t._1 <*> g t._2 - -let mapTuple3 #m {| monad m |} (f : 'a -> m 'b) (g : 'c -> m 'd) (h : 'e -> m 'f) (t : 'a & 'c & 'e) : m ('b & 'd & 'f) = - Mktuple3 <$> f t._1 <*> g t._2 <*> h t._3 - -let on_sub_layered_eff_combinators #m {|d : lvm m |} (lecs : layered_eff_combinators) : m layered_eff_combinators = - let! l_repr = lecs.l_repr |> mapTuple2 (f_tscheme #m #d) (f_tscheme #m #d) in - let! l_return = lecs.l_return |> mapTuple2 (f_tscheme #m #d) (f_tscheme #m #d) in - let! l_bind = lecs.l_bind |> mapTuple3 (f_tscheme #m #d) (f_tscheme #m #d) return in - let! l_subcomp = lecs.l_subcomp |> mapTuple3 (f_tscheme #m #d) (f_tscheme #m #d) return in - let! l_if_then_else = lecs.l_if_then_else |> mapTuple3 (f_tscheme #m #d) (f_tscheme #m #d) return in - let! l_close = lecs.l_close |> map_optM (mapTuple2 (f_tscheme #m #d) (f_tscheme #m #d)) in - return <| { - l_repr; - l_return; - l_bind; - l_subcomp; - l_if_then_else; - l_close; - } - -let on_sub_combinators #m {|d : lvm m |} (cbs : eff_combinators) : m eff_combinators = - match cbs with - | Primitive_eff wpcs -> - let! wpcs = on_sub_wp_eff_combinators wpcs in - return <| Primitive_eff wpcs - - | DM4F_eff wpcs -> - let! wpcs = on_sub_wp_eff_combinators wpcs in - return <| DM4F_eff wpcs - - | Layered_eff lecs -> - let! lecs = on_sub_layered_eff_combinators lecs in - return <| Layered_eff lecs - -let on_sub_effect_signature #m {|d : lvm m |} (es : effect_signature) : m effect_signature = - match es with - | Layered_eff_sig (n, (us, t)) -> - let! t = f_term t in - return <| Layered_eff_sig (n, (us, t)) - - | WP_eff_sig (us, t) -> - let! t = f_term t in - return <| WP_eff_sig (us, t) - -let on_sub_action #m {|d : lvm m |} (a : action) : m action = - let action_name = a.action_name in - let action_unqualified_name = a.action_unqualified_name in - let action_univs = a.action_univs in - let! action_params = a.action_params |> mapM f_binder in - let! action_defn = a.action_defn |> f_term in - let! action_typ = a.action_typ |> f_term in - return <| { - action_name; - action_unqualified_name; - action_univs; - action_params; - action_defn; - action_typ; - } - -let rec on_sub_sigelt' #m {|d : lvm m |} (se : sigelt') : m sigelt' = - match se with - | Sig_inductive_typ {lid; us; params; num_uniform_params; t; mutuals; ds; injective_type_params } -> - let! params = params |> mapM f_binder in - let! t = t |> f_term in - return <| Sig_inductive_typ {lid; us; params; num_uniform_params; t; mutuals; ds; injective_type_params } - - | Sig_bundle {ses; lids} -> - let! ses = ses |> mapM on_sub_sigelt in - return <| Sig_bundle {ses; lids} - - | Sig_datacon {lid; us; t; ty_lid; num_ty_params; mutuals; injective_type_params } -> - let! t = t |> f_term in - return <| Sig_datacon {lid; us; t; ty_lid; num_ty_params; mutuals; injective_type_params } - - | Sig_declare_typ {lid; us; t} -> - let! t = t |> f_term in - return <| Sig_declare_typ {lid; us; t} - - | Sig_let {lbs=(is_rec, lbs); lids} -> - let! lbs = lbs |> mapM on_sub_letbinding in - return <| Sig_let {lbs=(is_rec, lbs); lids} - - | Sig_assume {lid; us; phi} -> - let! phi = phi |> f_term in - return <| Sig_assume {lid; us; phi} - - | Sig_new_effect ed -> - let mname = ed.mname in - let cattributes = ed.cattributes in - let univs = ed.univs in - let! binders = ed.binders |> mapM f_binder in - let! signature = ed.signature |> on_sub_effect_signature in - let! combinators = ed.combinators |> on_sub_combinators in - let! actions = ed.actions |> mapM on_sub_action in - let! eff_attrs = ed.eff_attrs |> mapM f_term in - let extraction_mode = ed.extraction_mode in - let ed = { mname; cattributes; univs; binders; signature; combinators; actions; eff_attrs; extraction_mode; } in - return <| Sig_new_effect ed - - | Sig_sub_effect se -> - let source = se.source in - let target = se.target in - let! lift_wp = se.lift_wp |> map_optM (f_tscheme #m #d) in - let! lift = se.lift |> map_optM (f_tscheme #m #d) in - let kind = se.kind in - return <| Sig_sub_effect { source; target; lift_wp; lift; kind; } - - | Sig_effect_abbrev {lid; us; bs; comp; cflags} -> - let! binders = bs |> mapM f_binder in - let! comp = comp |> f_comp in - let! cflags = cflags |> mapM (__on_decreases f_term) in - // ^ review: residual flags should not have terms - return <| Sig_effect_abbrev {lid; us; bs; comp; cflags} - - (* No content *) - | Sig_pragma _ -> return se - - | Sig_polymonadic_bind {m_lid; n_lid; p_lid; tm; typ; kind} -> - let! tm = f_tscheme tm in - let! typ = f_tscheme typ in - return <| Sig_polymonadic_bind {m_lid; n_lid; p_lid; tm; typ; kind} - - | Sig_polymonadic_subcomp {m_lid; - n_lid; - tm; - typ; - kind} -> - let! tm = f_tscheme tm in - let! typ = f_tscheme typ in - return <| Sig_polymonadic_subcomp {m_lid; n_lid; tm; typ; kind} - - (* These two below are hardly used, since they disappear after - typechecking, but are still useful so the desugarer can make use of - deep_compress_se. *) - | Sig_fail {errs; fail_in_lax; ses} -> - let! ses = ses |> mapM on_sub_sigelt in - return <| Sig_fail {errs; fail_in_lax; ses} - - | Sig_splice {is_typed; lids; tac} -> - let! tac = tac |> f_term in - return <| Sig_splice {is_typed; lids; tac} - - | _ -> failwith "on_sub_sigelt: missing case" - -and on_sub_sigelt #m {|d : lvm m |} (se : sigelt) : m sigelt = - let! sigel = se.sigel |> on_sub_sigelt' in - let sigrng = se.sigrng in - let sigquals = se.sigquals in - let sigmeta = se.sigmeta in - let! sigattrs = se.sigattrs |> mapM f_term in - let sigopts = se.sigopts in - let sigopens_and_abbrevs = se.sigopens_and_abbrevs in - return <| { sigel; sigrng; sigquals; sigmeta; sigattrs; sigopts; sigopens_and_abbrevs; } - -let (>>=) (#m:_) {|monad m|} #a #b (c : m a) (f : a -> m b) = - let! x = c in f x - -let (<<|) (#m:_) {|monad m|} #a #b (f : a -> m b) (c : m a) : m b= - let! x = c in f x - -// Bottom up. The record is a reference so it can be easily cyclic. -let tie_bu (#m : Type -> Type) {| md : monad m |} (d : lvm m) : lvm m = - // needs explicit eta to not loop? - let r : ref (lvm m) = mk_ref (novfs #m #md) in // FIXME implicits - r := - { - lvm_monad = (!r).lvm_monad; - - f_term = (fun x -> f_term #_ #d <<| on_sub_term #_ #!r x); - f_binding_bv = (fun x -> f_binding_bv #_ #d <<| on_sub_binding_bv #_ #!r x); - f_binder = (fun x -> f_binder #_ #d <<| on_sub_binder #_ #!r x); - f_br = (fun x -> f_br #_ #d <<| on_sub_br #_ #!r x); - f_comp = (fun x -> f_comp #_ #d <<| on_sub_comp #_ #!r x); - f_residual_comp = (fun x -> f_residual_comp #_ #d <<| on_sub_residual_comp #_ #!r x); - f_univ = (fun x -> f_univ #_ #d <<| on_sub_univ #_ #!r x); - - proc_quotes = d.proc_quotes; - }; - !r - -let visitM_term_univs #m {| md : monad m |} (proc_quotes : bool) vt vu (tm : term) : m term = - let dict : lvm m = - tie_bu #m #md { novfs #m #md with f_term = vt; f_univ = vu; proc_quotes = proc_quotes } - in - f_term #_ #dict tm - -let visitM_term #m {| md : monad m |} (proc_quotes : bool) vt (tm : term) : m term = - visitM_term_univs true vt return tm - -let visitM_sigelt #m {| md : monad m |} (proc_quotes : bool) vt vu (tm : sigelt) : m sigelt = - let dict : lvm m = - tie_bu #m #md { novfs #m #md with f_term = vt; f_univ = vu; proc_quotes = proc_quotes } - in - on_sub_sigelt #_ #dict tm - - -(* Example: compute all lidents appearing in a sigelt: - -let open FStar.Class.Show in -let open FStar.Class.Monad in -let open FStar.Compiler.Writer in - -type mymon = writer (list lident) - -let m = VisitM.visitM_sigelt - (fun t -> (match t.n with - | Tm_fvar fv -> Writer.emit [lid_of_fv fv] - | _ -> return ());! - return t) - (fun #a b c -> c) se -in -let lids, _ = Writer.run_writer m in -BU.print1 "Lids = %s\n" (show lids); - -*) \ No newline at end of file diff --git a/src/syntax/FStar.Syntax.VisitM.fsti b/src/syntax/FStar.Syntax.VisitM.fsti deleted file mode 100644 index d700683152d..00000000000 --- a/src/syntax/FStar.Syntax.VisitM.fsti +++ /dev/null @@ -1,31 +0,0 @@ -module FStar.Syntax.VisitM - -open FStar.Syntax.Syntax -open FStar.Class.Monad - -// TODO: add a way to specify what happens when we traverse a binder, -// hopefully allowing the user to choose whether we open/close or not, -// and know the binding depth at each point. - -val visitM_term - (#m:_) {| monad m |} - (proc_quotes : bool) - (v : term -> m term) - (t : term) - : m term - -val visitM_term_univs - (#m:_) {| monad m |} - (proc_quotes : bool) - (vt : term -> m term) - (vu : universe -> m universe) - (t : term) - : m term - -val visitM_sigelt - (#m:_) {| monad m |} - (proc_quotes : bool) - (vt : term -> m term) - (vu : universe -> m universe) - (t : sigelt) - : m sigelt diff --git a/src/syntax/FStarC.Syntax.CheckLN.fst b/src/syntax/FStarC.Syntax.CheckLN.fst new file mode 100644 index 00000000000..6789ee5eb13 --- /dev/null +++ b/src/syntax/FStarC.Syntax.CheckLN.fst @@ -0,0 +1,112 @@ +module FStarC.Syntax.CheckLN + +open FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module L = FStarC.Compiler.List + +(* Computes the binding amount of a pattern. +Anywhere where this is defined already? *) +let rec pat_depth (p:pat) : int = + match p.v with + | Pat_constant _ -> 0 + | Pat_cons (p, _us_opt, ps) -> + L.fold_left (fun d (p, _) -> d + pat_depth p) 0 ps + | Pat_var _ -> 1 + | Pat_dot_term _ -> 0 + +(* Checks if, at most, n indices escape from a term *) +let rec is_ln' (n:int) (t:term) : bool = + match (SS.compress t).n with + | Tm_bvar bv -> bv.index < n + + | Tm_type _ + | Tm_name _ + | Tm_constant _ + | Tm_fvar _ -> true + + (* Should really be an fvar, but being conservative here *) + | Tm_uinst (t, us) -> + is_ln' n t && + is_ln'_univs n us + + | Tm_abs {bs;body;rc_opt} -> + is_ln'_binders n bs && + is_ln' (n + L.length bs) body + + | Tm_arrow {bs;comp} -> + is_ln'_binders n bs && + is_ln'_comp (n + L.length bs) comp + + | Tm_refine {b;phi} -> + is_ln'_bv n b && + is_ln' (n+1) phi + + | Tm_app {hd; args} -> + is_ln' n hd && + L.for_all (fun (t, aq) -> is_ln' n t) args + + | Tm_match {scrutinee; ret_opt; brs; rc_opt} -> + is_ln' n scrutinee && + // TODO: check pats + L.for_all (fun (p, _, t) -> is_ln' (n + pat_depth p) t) brs + + | Tm_ascribed {tm; asc; eff_opt} -> + is_ln' n tm && + true // is_ln' n asc + + | Tm_let {lbs; body} -> + is_ln'_letbindings n lbs && + is_ln' (n + L.length (snd lbs)) body + + | _ -> true + +and is_ln'_letbindings (n:int) (lbs : letbindings) : bool = + let isrec, lbs = lbs in + L.for_all (fun lb -> is_ln'_letbinding n lb) lbs + +and is_ln'_letbinding (n:int) (lb : letbinding) : bool = + let {lbunivs; lbtyp; lbdef} = lb in + let nu = List.length lbunivs in + is_ln' (n+nu) lbtyp && + is_ln' (n+nu) lbdef + +and is_ln'_binders (n:int) (bs : list binder) : bool = + match bs with + | [] -> true + | b::bs -> + is_ln'_binder n b && is_ln'_binders (n+1) bs + +and is_ln'_binder (n:int) (b:binder) : bool = + is_ln'_bv n b.binder_bv + +and is_ln'_bv (n:int) (bv:bv) : bool = + is_ln' n bv.sort + +and is_ln'_comp (n:int) (c:comp) : bool = + match c.n with + | Total t -> is_ln' n t + | GTotal t -> is_ln' n t + | Comp ct -> is_ln'_comp_typ n ct + +and is_ln'_comp_typ (n:nat) (ct:comp_typ) : bool = + is_ln' n ct.result_typ && + L.for_all (fun (t,aq) -> is_ln' n t) ct.effect_args && +// L.for_all (is_ln' n) ct.flags + true + +and is_ln'_univ (n:nat) (u : universe) : bool = + match SS.compress_univ u with + | U_zero -> true + | U_succ u -> is_ln'_univ n u + | U_max us -> L.for_all (is_ln'_univ n) us + | U_unif _ -> true // we're conservative with returning false since that would be an error + | U_bvar i -> i < n + | U_name _ -> true + | U_unknown -> true + +and is_ln'_univs (n:nat) (us : list universe) : bool = + L.for_all (is_ln'_univ n) us + +(* Checks if a term is locally nameless *) +let is_ln (t:term) : bool = + is_ln' 0 t diff --git a/src/syntax/FStarC.Syntax.CheckLN.fsti b/src/syntax/FStarC.Syntax.CheckLN.fsti new file mode 100644 index 00000000000..f12ccb06cac --- /dev/null +++ b/src/syntax/FStarC.Syntax.CheckLN.fsti @@ -0,0 +1,10 @@ +module FStarC.Syntax.CheckLN + +open FStarC.Syntax.Syntax + +(* Checks if, at most, n indices escape from a term. +For both term and universe variables. *) +val is_ln' (n:int) (t:term) : bool + +(* Checks if a term is locally nameless. Equal to [is_ln' 0] *) +val is_ln (t:term) : bool diff --git a/src/syntax/FStarC.Syntax.Compress.fst b/src/syntax/FStarC.Syntax.Compress.fst new file mode 100644 index 00000000000..ed1e4497320 --- /dev/null +++ b/src/syntax/FStarC.Syntax.Compress.fst @@ -0,0 +1,102 @@ +module FStarC.Syntax.Compress +open FStarC + +open FStarC +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.Compiler.Effect +open FStarC.Syntax.Syntax +open FStarC.Syntax.Subst +open FStarC.Syntax.Visit + +open FStarC.Class.Show + +module List = FStarC.Compiler.List +module Err = FStarC.Errors + +(* This function really just checks for bad(tm) things happening, the +actual `compress` call is done by the visitor, so no need to repeat it +here. Morally, `deep_compress` is just `visit id` with some checks. *) +let compress1_t (allow_uvars: bool) (allow_names: bool) : term -> term = + fun t -> + let mk x = Syntax.mk x t.pos in + match t.n with + | Tm_uvar (uv, s) when not allow_uvars -> + Err.raise_error0 Err.Error_UnexpectedUnresolvedUvar + (format1 "Internal error: unexpected unresolved uvar in deep_compress: %s" (show uv)) + + | Tm_name bv when not allow_names -> + (* This currently happens, and often, but it should not! *) + if Debug.any () then + Errors.log_issue t Err.Warning_NameEscape (format1 "Tm_name %s in deep compress" (show bv)); + mk (Tm_name ({bv with sort = mk Tm_unknown})) + + (* The sorts are not needed. Delete them. *) + | Tm_bvar bv -> mk (Tm_bvar ({bv with sort = mk Tm_unknown})) + | Tm_name bv -> mk (Tm_name ({bv with sort = mk Tm_unknown})) + + | _ -> t + +let compress1_u (allow_uvars:bool) (allow_names:bool) : universe -> universe = + fun u -> + match u with + | U_name bv when not allow_names -> + if Debug.any () then + Errors.log_issue0 Err.Warning_NameEscape (format1 "U_name %s in deep compress" (show bv)); + u + + | U_unif uv when not allow_uvars -> + Err.raise_error0 Err.Error_UnexpectedUnresolvedUvar + (format1 "Internal error: unexpected unresolved (universe) uvar in deep_compress: %s" (show (Syntax.Unionfind.univ_uvar_id uv))) + | _ -> u + +(* deep_compress_*: eliminating all unification variables and delayed +substitutions in a sigelt. We traverse the entire syntactic structure +to evaluate the explicit lazy substitutions (Tm_delayed) and to replace +uvar nodes (Tm_uvar/U_unif) with their solutions. + +The return value of this function should *never* contain a lambda. This +applies to every component of the term/sigelt: attributes, metadata, BV +sorts, universes, memoized free variables, substitutions, etc. + +This is done to later dump the term/sigelt into a file (via OCaml's +output_value, for instance). This marshalling does not handle +closures[1] and we do not store the UF graph, so we cannot have any +lambdas and every uvar node that must be replaced by its solution (and +hence must have been resolved). + +Eliminating the substitutions and resolving uvars is all done by the +`compress` call in the implementation of Visit.visit_tm, so this all +looks like a big identity function. + +[1] OCaml's Marshal module can actually serialize closures, but this +makes .checked files more brittle, so we don't do it. +*) +let deep_compress (allow_uvars:bool) (allow_names: bool) (tm : term) : term = + Err.with_ctx ("While deep-compressing a term") (fun () -> + Visit.visit_term_univs true + (compress1_t allow_uvars allow_names) + (compress1_u allow_uvars allow_names) + tm + ) + +let deep_compress_uvars = deep_compress false true + +let deep_compress_if_no_uvars (tm : term) : option term = + Err.with_ctx ("While deep-compressing a term") (fun () -> + try + Some (Visit.visit_term_univs true + (compress1_t false true) + (compress1_u false true) + tm) + with + | Errors.Error (Err.Error_UnexpectedUnresolvedUvar, _, _, _) -> None + ) + +let deep_compress_se (allow_uvars:bool) (allow_names:bool) (se : sigelt) : sigelt = + Err.with_ctx (format1 "While deep-compressing %s" (Syntax.Print.sigelt_to_string_short se)) (fun () -> + Visit.visit_sigelt true + (compress1_t allow_uvars allow_names) + (compress1_u allow_uvars allow_names) + se + ) diff --git a/src/syntax/FStarC.Syntax.Compress.fsti b/src/syntax/FStarC.Syntax.Compress.fsti new file mode 100644 index 00000000000..c604f04bd3c --- /dev/null +++ b/src/syntax/FStarC.Syntax.Compress.fsti @@ -0,0 +1,19 @@ +module FStarC.Syntax.Compress + +open FStarC.Syntax.Syntax + +(* Removes all delayed substitutions and resolved uvar nodes in a term. +if allow_uvars is false, it raises a hard error if an *unresolved* uvar +(term or universe) remains. Resolved uvars are replaced by their +solutions, as in compress. *) +val deep_compress (allow_uvars: bool) (allow_names: bool) (t:term) : term + +(* Alias for deep_compress false true. i.e. allows names but not uvars, +useful to check that a potentially open term does not have any uvars. *) +val deep_compress_uvars (t:term) : term + +(* Similar to `deep_compress false false t`, except instead of a hard error + this returns None in case an unresolved uvar is found. *) +val deep_compress_if_no_uvars (t:term) : option term + +val deep_compress_se (allow_uvars: bool) (allow_names: bool) (se:sigelt) : sigelt diff --git a/src/syntax/FStarC.Syntax.DsEnv.fst b/src/syntax/FStarC.Syntax.DsEnv.fst new file mode 100644 index 00000000000..d9aef097e73 --- /dev/null +++ b/src/syntax/FStarC.Syntax.DsEnv.fst @@ -0,0 +1,1523 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Syntax.DsEnv +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.Syntax.Util +open FStarC.Parser +open FStarC.Ident +open FStarC.Errors + +open FStarC.Class.Show +open FStarC.Class.Monad +open FStarC.Class.Setlike + +let ugly_sigelt_to_string_hook : ref (sigelt -> string) = BU.mk_ref (fun _ -> "") +let ugly_sigelt_to_string (se:sigelt) : string = !ugly_sigelt_to_string_hook se + +module S = FStarC.Syntax.Syntax +module U = FStarC.Syntax.Util +module BU = FStarC.Compiler.Util +module Const = FStarC.Parser.Const + +type local_binding = (ident & bv & used_marker) (* local name binding for name resolution, paired with an env-generated unique name *) +type rec_binding = (ident & lid & (* name bound by recursive type and top-level let-bindings definitions only *) + used_marker) (* this ref marks whether it was used, so we can warn if not *) + +type scope_mod = +| Local_binding of local_binding +| Rec_binding of rec_binding +| Module_abbrev of module_abbrev +| Open_module_or_namespace of open_module_or_namespace +| Top_level_def of ident (* top-level definition for an unqualified identifier x to be resolved as curmodule.x. *) +| Record_or_dc of record_or_dc (* to honor interleavings of "open" and record definitions *) + +type string_set = RBSet.t string + +type exported_id_kind = (* kinds of identifiers exported by a module *) +| Exported_id_term_type (* term and type identifiers *) +| Exported_id_field (* field identifiers *) +type exported_id_set = exported_id_kind -> ref string_set + +type env = { + curmodule: option lident; (* name of the module being desugared *) + curmonad: option ident; (* current monad being desugared *) + modules: list (lident & modul); (* previously desugared modules *) + scope_mods: list scope_mod; (* a STACK of toplevel or definition-local scope modifiers *) + exported_ids: BU.smap exported_id_set; (* identifiers (stored as strings for efficiency) + reachable in a module, not shadowed by "include" + declarations. Used only to handle such shadowings, + not "private"/"abstract" definitions which it is + enough to just remove from the sigmap. Formally, + iden is in exported_ids[ModulA] if, and only if, + there is no 'include ModulB' (with ModulB.iden + defined or reachable) after iden in ModulA. *) + trans_exported_ids: BU.smap exported_id_set; (* transitive version of exported_ids along the + "include" relation: an identifier is in this set + for a module if and only if it is defined either + in this module or in one of its included modules. *) + includes: BU.smap (ref (list (lident & restriction))); (* list of "includes" declarations for each module. *) + sigaccum: sigelts; (* type declarations being accumulated for the current module *) + sigmap: BU.smap (sigelt & bool); (* bool indicates that this was declared in an interface file *) + iface: bool; (* whether or not we're desugaring an interface; different scoping rules apply *) + admitted_iface: bool; (* is it an admitted interface; different scoping rules apply *) + expect_typ: bool; (* syntactically, expect a type at this position in the term *) + remaining_iface_decls:list (lident&list Parser.AST.decl); (* A map from interface names to their stil-to-be-processed top-level decls *) + syntax_only: bool; (* Whether next push should skip type-checking *) + ds_hooks: dsenv_hooks; (* hooks that the interactive more relies onto for symbol tracking *) + dep_graph: FStarC.Parser.Dep.deps +} +and dsenv_hooks = + { ds_push_open_hook : env -> open_module_or_namespace -> unit; + ds_push_include_hook : env -> lident -> unit; + ds_push_module_abbrev_hook : env -> ident -> lident -> unit } + +let mk_dsenv_hooks open_hook include_hook module_abbrev_hook = + { ds_push_open_hook = open_hook; + ds_push_include_hook = include_hook; + ds_push_module_abbrev_hook = module_abbrev_hook } + +let default_ds_hooks = + { ds_push_open_hook = (fun _ _ -> ()); + ds_push_include_hook = (fun _ _ -> ()); + ds_push_module_abbrev_hook = (fun _ _ _ -> ()) } + +let set_iface env b = {env with iface=b} +let iface e = e.iface +let set_admitted_iface e b = {e with admitted_iface=b} +let admitted_iface e = e.admitted_iface +let set_expect_typ e b = {e with expect_typ=b} +let expect_typ e = e.expect_typ +let all_exported_id_kinds: list exported_id_kind = [ Exported_id_field; Exported_id_term_type ] +let transitive_exported_ids env lid = + let module_name = Ident.string_of_lid lid in + match BU.smap_try_find env.trans_exported_ids module_name with + | None -> [] + | Some exported_id_set -> !(exported_id_set Exported_id_term_type) |> elems +let opens_and_abbrevs env : list (either open_module_or_namespace module_abbrev) = + List.collect + (function + | Open_module_or_namespace payload -> [Inl payload] + | Module_abbrev (id, lid) -> [Inr (id, lid)] + | _ -> []) + env.scope_mods + +let open_modules e = e.modules +let open_modules_and_namespaces env = + List.filter_map (function + | Open_module_or_namespace (lid, _info, _restriction) -> Some lid + | _ -> None) + env.scope_mods +let module_abbrevs env : list (ident & lident)= + List.filter_map (function + | Module_abbrev (l, m) -> Some (l, m) + | _ -> None) + env.scope_mods +let set_current_module e l = {e with curmodule=Some l} +let current_module env = match env.curmodule with + | None -> failwith "Unset current module" + | Some m -> m +let iface_decls env l = + match env.remaining_iface_decls |> + List.tryFind (fun (m, _) -> Ident.lid_equals l m) with + | None -> None + | Some (_, decls) -> Some decls +let set_iface_decls env l ds = + let _, rest = + FStarC.Compiler.List.partition + (fun (m, _) -> Ident.lid_equals l m) + env.remaining_iface_decls in + {env with remaining_iface_decls=(l, ds)::rest} +let qual = qual_id +let qualify env id = + match env.curmonad with + | None -> qual (current_module env) id + | Some monad -> mk_field_projector_name_from_ident (qual (current_module env) monad) id +let syntax_only env = env.syntax_only +let set_syntax_only env b = { env with syntax_only = b } +let ds_hooks env = env.ds_hooks +let set_ds_hooks env hooks = { env with ds_hooks = hooks } +let new_sigmap () = BU.smap_create 100 +let empty_env deps = {curmodule=None; + curmonad=None; + modules=[]; + scope_mods=[]; + exported_ids=new_sigmap(); + trans_exported_ids=new_sigmap(); + includes=new_sigmap(); + sigaccum=[]; + sigmap=new_sigmap(); + iface=false; + admitted_iface=false; + expect_typ=false; + remaining_iface_decls=[]; + syntax_only=false; + ds_hooks=default_ds_hooks; + dep_graph=deps} +let dep_graph env = env.dep_graph +let set_dep_graph env ds = {env with dep_graph=ds} +let sigmap env = env.sigmap + +let set_bv_range bv r = + let id = set_id_range r bv.ppname in + {bv with ppname=id} + +let bv_to_name bv r = bv_to_name (set_bv_range bv r) + +let unmangleMap = [("op_ColonColon", "Cons", Some Data_ctor); + ("not", "op_Negation", None)] + +let unmangleOpName (id:ident) : option term = + find_map unmangleMap (fun (x,y,dq) -> + if string_of_id id = x + then Some (S.fvar_with_dd (lid_of_path ["Prims"; y] (range_of_id id)) dq) + else None) + +type cont_t 'a = + | Cont_ok of 'a (* found *) + | Cont_fail (* not found, do not retry *) + | Cont_ignore (* not found, retry *) + +let option_of_cont (k_ignore: unit -> option 'a) = function + | Cont_ok a -> Some a + | Cont_fail -> None + | Cont_ignore -> k_ignore () + +(* Unqualified identifier lookup *) + +let find_in_record ns id record cont = + let typename' = lid_of_ids (ns @ [ident_of_lid record.typename]) in + if lid_equals typename' record.typename + then + let fname = lid_of_ids (ns_of_lid record.typename @ [id]) in + let find = BU.find_map record.fields (fun (f, _) -> + if string_of_id id = string_of_id f + then Some record + else None) + in + match find with + | Some r -> cont r + | None -> Cont_ignore + else + Cont_ignore + +let get_exported_id_set (e: env) (mname: string) : option (exported_id_kind -> ref string_set) = + BU.smap_try_find e.exported_ids mname + +let get_trans_exported_id_set (e: env) (mname: string) : option (exported_id_kind -> ref string_set) = + BU.smap_try_find e.trans_exported_ids mname + +let string_of_exported_id_kind = function + | Exported_id_field -> "field" + | Exported_id_term_type -> "term/type" + +let is_exported_id_termtype = function + | Exported_id_term_type -> true + | _ -> false + +let is_exported_id_field = function + | Exported_id_field -> true + | _ -> false + + +let find_in_module_with_includes + (eikind: exported_id_kind) + (find_in_module: lident -> cont_t 'a) + (find_in_module_default: cont_t 'a) + env + (ns: lident) + (id: ident) + : cont_t 'a = + let rec aux = function + | [] -> + find_in_module_default + | (modul, id) :: q -> + let mname = string_of_lid modul in + let not_shadowed = match get_exported_id_set env mname with + | None -> true + | Some mex -> + let mexports = !(mex eikind) in + mem (string_of_id id) mexports + in + let mincludes = match BU.smap_try_find env.includes mname with + | None -> [] + | Some minc -> + !minc |> filter_map (fun (ns, restriction) -> + let opt = is_ident_allowed_by_restriction id restriction in + map_opt opt (fun id -> (ns, id))) + in + let look_into = + if not_shadowed + then find_in_module (qual modul id) + else Cont_ignore + in + begin match look_into with + | Cont_ignore -> + aux (mincludes @ q) + | _ -> + look_into + end + in aux [ (ns, id) ] + +let try_lookup_id'' + env + (id: ident) + (eikind: exported_id_kind) + (k_local_binding: local_binding -> cont_t 'a) + (k_rec_binding: rec_binding -> cont_t 'a) + (k_record: (record_or_dc) -> cont_t 'a) + (find_in_module: lident -> cont_t 'a) + (lookup_default_id: cont_t 'a -> ident -> cont_t 'a) : option 'a + = + let check_local_binding_id : local_binding -> bool = function + (id', _, _) -> string_of_id id' = string_of_id id + in + let check_rec_binding_id : rec_binding -> bool = function + (id', _, _) -> string_of_id id' = string_of_id id + in + let curmod_ns = ids_of_lid (current_module env) in + let proc = function + | Local_binding l + when check_local_binding_id l -> + let (_, _, used_marker) = l in + used_marker := true; + k_local_binding l + + | Rec_binding r + when check_rec_binding_id r -> + let (_, _, used_marker) = r in + used_marker := true; + k_rec_binding r + + | Open_module_or_namespace (ns, Open_module, restriction) -> + ( match is_ident_allowed_by_restriction id restriction with + | None -> Cont_ignore + | Some id -> find_in_module_with_includes eikind find_in_module Cont_ignore env ns id) + + | Top_level_def id' + when string_of_id id' = string_of_id id -> + (* indicates a global definition shadowing previous + "open"s. If the definition is not actually found by the + [lookup_default_id] finder, then it may mean that we are in a + module and the [val] was already declared, with the actual + [let] not defined yet, so we must not fail, but ignore. *) + lookup_default_id Cont_ignore id + + | Record_or_dc r + when (is_exported_id_field eikind) -> + find_in_module_with_includes Exported_id_field ( + fun lid -> + let id = ident_of_lid lid in + find_in_record (ns_of_lid lid) id r k_record + ) Cont_ignore env (lid_of_ids curmod_ns) id + + | Record_or_dc r + when (is_exported_id_termtype eikind) -> + if ident_equals (ident_of_lid r.typename) id + then k_record r + else Cont_ignore + + | _ -> + Cont_ignore + in + let rec aux = function + | a :: q -> + option_of_cont (fun _ -> aux q) (proc a) + | [] -> + option_of_cont (fun _ -> None) (lookup_default_id Cont_fail id) + + in aux env.scope_mods + +let found_local_binding r (id', x, _) = + (bv_to_name x r) + +let find_in_module env lid k_global_def k_not_found = + begin match BU.smap_try_find (sigmap env) (string_of_lid lid) with + | Some sb -> k_global_def lid sb + | None -> k_not_found + end + +let try_lookup_id env (id:ident) : option term = + match unmangleOpName id with + | Some f -> Some f + | _ -> + try_lookup_id'' env id Exported_id_term_type (fun r -> Cont_ok (found_local_binding (range_of_id id) r)) (fun _ -> Cont_fail) (fun _ -> Cont_ignore) (fun i -> find_in_module env i (fun _ _ -> Cont_fail) Cont_ignore) (fun _ _ -> Cont_fail) + +(* Unqualified identifier lookup, if lookup in all open namespaces failed. *) + +let lookup_default_id + env + (id: ident) + (k_global_def: lident -> sigelt & bool -> cont_t 'a) + (k_not_found: cont_t 'a) + = + let find_in_monad = match env.curmonad with + | Some _ -> + let lid = qualify env id in + begin match BU.smap_try_find (sigmap env) (string_of_lid lid) with + | Some r -> Some (k_global_def lid r) + | None -> None + end + | None -> None + in + match find_in_monad with + | Some v -> v + | None -> + let lid = qual (current_module env) id in + find_in_module env lid k_global_def k_not_found + +let lid_is_curmod env lid = + match env.curmodule with + | None -> false + | Some m -> lid_equals lid m + +let module_is_defined env lid = + lid_is_curmod env lid || + List.existsb (fun x -> lid_equals lid (fst x)) env.modules + +let resolve_module_name env lid (honor_ns: bool) : option lident = + let nslen = List.length (ns_of_lid lid) in + let rec aux = function + | [] -> + if module_is_defined env lid + then Some lid + else None + + | Open_module_or_namespace (ns, Open_namespace, restriction) :: q + when honor_ns -> + let new_lid = lid_of_path (path_of_lid ns @ path_of_lid lid) (range_of_lid lid) + in + if module_is_defined env new_lid + then + Some new_lid + else aux q + + | Module_abbrev (name, modul) :: _ + when nslen = 0 && (string_of_id name) = (string_of_id (ident_of_lid lid)) -> + Some modul + + | _ :: q -> + aux q + + in + aux env.scope_mods + +let is_open env lid open_kind = + List.existsb (function + | Open_module_or_namespace (ns, k, Unrestricted) -> k = open_kind && lid_equals lid ns + | _ -> false) env.scope_mods + +let namespace_is_open env lid = + is_open env lid Open_namespace + +let module_is_open env lid = + lid_is_curmod env lid || is_open env lid Open_module + +// FIXME this could be faster (module_is_open and namespace_is_open are slow) +let shorten_module_path env ids is_full_path = + let rec aux revns id = + let lid = FStarC.Ident.lid_of_ns_and_id (List.rev revns) id in + if namespace_is_open env lid + then Some (List.rev (id :: revns), []) + else match revns with + | [] -> None + | ns_last_id :: rev_ns_prefix -> + aux rev_ns_prefix ns_last_id |> + BU.map_option (fun (stripped_ids, rev_kept_ids) -> + (stripped_ids, id :: rev_kept_ids)) in + let do_shorten env ids = + // Do the actual shortening. FIXME This isn't optimal (no includes). + match List.rev ids with + | [] -> ([], []) + | ns_last_id :: ns_rev_prefix -> + match aux ns_rev_prefix ns_last_id with + | None -> ([], ids) + | Some (stripped_ids, rev_kept_ids) -> (stripped_ids, List.rev rev_kept_ids) in + + if is_full_path && List.length ids > 0 then + // Try to strip the entire prefix. This is the cheap common case. + match resolve_module_name env (FStarC.Ident.lid_of_ids ids) true with + | Some m when module_is_open env m -> (ids, []) + | _ -> do_shorten env ids + else + do_shorten env ids + +(* Generic name resolution. *) + +let resolve_in_open_namespaces'' + env + lid + (eikind: exported_id_kind) + (k_local_binding: local_binding -> cont_t 'a) + (k_rec_binding: rec_binding -> cont_t 'a) + (k_record: (record_or_dc) -> cont_t 'a) + (f_module: lident -> cont_t 'a) + (l_default: cont_t 'a -> ident -> cont_t 'a) + : option 'a = + match ns_of_lid lid with + | _ :: _ -> + begin match resolve_module_name env (set_lid_range (lid_of_ids (ns_of_lid lid)) (range_of_lid lid)) true with + | None -> None + | Some modul -> + option_of_cont (fun _ -> None) (find_in_module_with_includes eikind f_module Cont_fail env modul (ident_of_lid lid)) + end + | [] -> + try_lookup_id'' env (ident_of_lid lid) eikind k_local_binding k_rec_binding k_record f_module l_default + +let cont_of_option (k_none: cont_t 'a) = function + | Some v -> Cont_ok v + | None -> k_none + +let resolve_in_open_namespaces' + env + lid + (k_local_binding: local_binding -> option 'a) + (k_rec_binding: rec_binding -> option 'a) + (k_global_def: lident -> (sigelt & bool) -> option 'a) + : option 'a = + let k_global_def' k lid def = cont_of_option k (k_global_def lid def) in + let f_module lid' = let k = Cont_ignore in find_in_module env lid' (k_global_def' k) k in + let l_default k i = lookup_default_id env i (k_global_def' k) k in + resolve_in_open_namespaces'' env lid Exported_id_term_type + (fun l -> cont_of_option Cont_fail (k_local_binding l)) + (fun r -> cont_of_option Cont_fail (k_rec_binding r)) + (fun _ -> Cont_ignore) + f_module + l_default + +let fv_qual_of_se = fun se -> match se.sigel with + | Sig_datacon {ty_lid=l} -> + let qopt = BU.find_map se.sigquals (function + | RecordConstructor (_, fs) -> Some (Record_ctor(l, fs)) + | _ -> None) in + begin match qopt with + | None -> Some Data_ctor + | x -> x + end + | Sig_declare_typ _ -> //TODO: record projectors? + None + | _ -> None + +let lb_fv lbs lid = + BU.find_map lbs (fun lb -> + let fv = right lb.lbname in + if S.fv_eq_lid fv lid then Some fv else None) |> must + +let ns_of_lid_equals (lid: lident) (ns: lident) = + List.length (ns_of_lid lid) = List.length (ids_of_lid ns) && + lid_equals (lid_of_ids (ns_of_lid lid)) ns + +let try_lookup_name any_val exclude_interf env (lid:lident) : option foundname = + let occurrence_range = Ident.range_of_lid lid in + + let k_global_def source_lid = function + | (_, true) when exclude_interf -> None + | (se, _) -> + begin match se.sigel with + | Sig_inductive_typ _ -> Some (Term_name (S.fvar_with_dd source_lid None, se.sigattrs)) + | Sig_datacon _ -> Some (Term_name (S.fvar_with_dd source_lid (fv_qual_of_se se), se.sigattrs)) + | Sig_let {lbs=(_, lbs)} -> + let fv = lb_fv lbs source_lid in + Some (Term_name (S.fvar_with_dd source_lid fv.fv_qual, se.sigattrs)) + | Sig_declare_typ {lid} -> + let quals = se.sigquals in + if any_val //only in scope in an interface (any_val is true) or if the val is assumed + || quals |> BU.for_some (function Assumption -> true | _ -> false) + then let lid = Ident.set_lid_range lid (Ident.range_of_lid source_lid) in + begin match BU.find_map quals (function Reflectable refl_monad -> Some refl_monad | _ -> None) with //this is really a M?.reflect + | Some refl_monad -> + let refl_const = S.mk (Tm_constant (FStarC.Const.Const_reflect refl_monad)) occurrence_range in + Some (Term_name (refl_const, se.sigattrs)) + | _ -> + Some (Term_name(fvar_with_dd lid (fv_qual_of_se se), se.sigattrs)) + end + else None + | Sig_new_effect(ne) -> Some (Eff_name(se, set_lid_range ne.mname (range_of_lid source_lid))) + | Sig_effect_abbrev _ -> Some (Eff_name(se, source_lid)) + | Sig_splice {lids; tac=t} -> + // TODO: This depth is probably wrong + Some (Term_name (S.fvar_with_dd source_lid None, [])) + | _ -> None + end in + + let k_local_binding r = let t = found_local_binding (range_of_lid lid) r in Some (Term_name (t, [])) + in + + let k_rec_binding (id, l, used_marker) = + used_marker := true; + Some (Term_name(S.fvar_with_dd (set_lid_range l (range_of_lid lid)) None, [])) + in + + let found_unmangled = match ns_of_lid lid with + | [] -> + begin match unmangleOpName (ident_of_lid lid) with + | Some t -> Some (Term_name (t, [])) + | _ -> None + end + | _ -> None + in + + match found_unmangled with + | None -> resolve_in_open_namespaces' env lid k_local_binding k_rec_binding k_global_def + | x -> x + +let try_lookup_effect_name' exclude_interf env (lid:lident) : option (sigelt&lident) = + match try_lookup_name true exclude_interf env lid with + | Some (Eff_name(o, l)) -> Some (o,l) + | _ -> None +let try_lookup_effect_name env l = + match try_lookup_effect_name' (not env.iface) env l with + | Some (o, l) -> Some l + | _ -> None +let try_lookup_effect_name_and_attributes env l = + match try_lookup_effect_name' (not env.iface) env l with + | Some ({ sigel = Sig_new_effect(ne) }, l) -> Some (l, ne.cattributes) + | Some ({ sigel = Sig_effect_abbrev {cflags=cattributes} }, l) -> Some (l, cattributes) + | _ -> None +let try_lookup_effect_defn env l = + match try_lookup_effect_name' (not env.iface) env l with + | Some ({ sigel = Sig_new_effect(ne) }, _) -> Some ne + | _ -> None +let is_effect_name env lid = + match try_lookup_effect_name env lid with + | None -> false + | Some _ -> true +(* Same as [try_lookup_effect_name], but also traverses effect +abbrevs. TODO: once indexed effects are in, also track how indices and +other arguments are instantiated. *) +let try_lookup_root_effect_name env l = + match try_lookup_effect_name' (not env.iface) env l with + | Some ({ sigel = Sig_effect_abbrev {lid=l'} }, _) -> + let rec aux new_name = + match BU.smap_try_find (sigmap env) (string_of_lid new_name) with + | None -> None + | Some (s, _) -> + begin match s.sigel with + | Sig_new_effect(ne) + -> Some (set_lid_range ne.mname (range_of_lid l)) + | Sig_effect_abbrev {comp=cmp} -> + let l'' = U.comp_effect_name cmp in + aux l'' + | _ -> None + end + in aux l' + | Some (_, l') -> Some l' + | _ -> None + +let lookup_letbinding_quals_and_attrs env lid = + let k_global_def lid = function + | ({sigel = Sig_declare_typ _; sigquals=quals; sigattrs=attrs }, _) -> + Some (quals, attrs) + | _ -> + None in + match resolve_in_open_namespaces' env lid (fun _ -> None) (fun _ -> None) k_global_def with + | Some qa -> qa + | _ -> [], [] + +let try_lookup_module env path = + match List.tryFind (fun (mlid, modul) -> path_of_lid mlid = path) env.modules with + | Some (_, modul) -> Some modul + | None -> None + +let try_lookup_let env (lid:lident) = + let k_global_def lid = function + | ({ sigel = Sig_let {lbs=(_, lbs)} }, _) -> + let fv = lb_fv lbs lid in + Some (fvar_with_dd lid fv.fv_qual) + | _ -> None in + resolve_in_open_namespaces' env lid (fun _ -> None) (fun _ -> None) k_global_def + +let try_lookup_definition env (lid:lident) = + let k_global_def lid = function + | ({ sigel = Sig_let {lbs} }, _) -> + BU.find_map (snd lbs) (fun lb -> + match lb.lbname with + | Inr fv when S.fv_eq_lid fv lid -> + Some (lb.lbdef) + | _ -> None) + | _ -> None in + resolve_in_open_namespaces' env lid (fun _ -> None) (fun _ -> None) k_global_def + + +let empty_include_smap : BU.smap (ref (list (lident & restriction))) = new_sigmap() +let empty_exported_id_smap : BU.smap exported_id_set = new_sigmap() + +let try_lookup_lid' any_val exclude_interface env (lid:lident) : option (term & list attribute) = + match try_lookup_name any_val exclude_interface env lid with + | Some (Term_name (e, attrs)) -> Some (e, attrs) + | _ -> None + +let drop_attributes (x:option (term & list attribute)) :option (term) = + match x with + | Some (t, _) -> Some t + | None -> None + +let try_lookup_lid_with_attributes (env:env) (l:lident) :(option (term & list attribute)) = try_lookup_lid' env.iface false env l +let try_lookup_lid (env:env) l = try_lookup_lid_with_attributes env l |> drop_attributes + +let resolve_to_fully_qualified_name (env:env) (l:lident) : option lident = + let r = + match try_lookup_name true false env l with + | Some (Term_name (e, attrs)) -> + begin match (Subst.compress e).n with + | Tm_fvar fv -> Some fv.fv_name.v + | _ -> None + end + | Some (Eff_name (o, l)) -> Some l + | None -> None + in + r + +(* Is this module lid abbreviated? If there is a module M = A.B in scope, +then this returns Some M for A.B (but not for its descendants). *) +let is_abbrev env lid : option ipath = + List.tryPick (function + | Module_abbrev (id, ns) when lid_equals lid ns -> + Some [id] + | _ -> None) + env.scope_mods + +(* Abbreviate a module lid. If there is a module M = A.B.C in scope, +then this returns Some (M, C.D) for A.B.C.D (unless there is a more +specific abbrev, such as one for A.B.C or A.B.C.D) *) +let try_shorten_abbrev (env:env) (ns:ipath) : option (ipath & list ident) = + let rec aux (ns : ipath) (rest : list ident) = + match ns with + | [] -> None + | hd::tl -> + match is_abbrev env (lid_of_ids (rev ns)) with + | Some short -> Some (short, rest) + | _ -> + aux tl (hd::rest) + in + aux (rev ns) [] + +let shorten_lid' (env:env) (lid0:lident) : lident = + (* Id and namespace *) + let id0 = ident_of_lid lid0 in + let ns0 = ns_of_lid lid0 in + + (* If this lid is "below" some abbreviation, find it and use it unconditionally. *) + let pref, ns = + match try_shorten_abbrev env ns0 with + | None -> [], ns0 + | Some (ns, rest) -> ns, rest + in + + (* Move to FStar.List.Tot.Base? *) + let rec tails l = match l with + | [] -> [[]] + | _::tl -> l::(tails tl) + in + + (* Namespace suffixes, in increasing order of length *) + let suffs = rev (tails ns) in + + (* Does this shortened lid' resolve to the original lid0? *) + let try1 (lid' : lident) : bool = + match resolve_to_fully_qualified_name env lid' with + | Some lid2 when Ident.lid_equals lid2 lid0 -> true + | _ -> false + in + + let rec go (nss : list (list ident)) : lid = + match nss with + | ns::rest -> + let lid' = lid_of_ns_and_id (pref @ ns) id0 in + if try1 lid' + then lid' + else go rest + + | [] -> + (* This should be unreachable. Warn? *) + lid0 + in + let r = go suffs in + r + +let shorten_lid env lid0 = + match env.curmodule with + | None -> lid0 + | _ -> shorten_lid' env lid0 + +let try_lookup_lid_with_attributes_no_resolve (env: env) l :option (term & list attribute) = + let env' = {env with scope_mods = [] ; exported_ids=empty_exported_id_smap; includes=empty_include_smap } + in + try_lookup_lid_with_attributes env' l + +let try_lookup_lid_no_resolve (env: env) l :option term = try_lookup_lid_with_attributes_no_resolve env l |> drop_attributes + +let try_lookup_datacon env (lid:lident) = + let k_global_def lid se = + match se with + | ({ sigel = Sig_declare_typ _; sigquals = quals }, _) -> + if quals |> BU.for_some (function Assumption -> true | _ -> false) + then Some (lid_and_dd_as_fv lid None) + else None + | ({ sigel = Sig_splice _ }, _) (* A spliced datacon *) + | ({ sigel = Sig_datacon _ }, _) -> + let qual = fv_qual_of_se (fst se) in + Some (lid_and_dd_as_fv lid qual) + | _ -> None in + resolve_in_open_namespaces' env lid (fun _ -> None) (fun _ -> None) k_global_def + +let find_all_datacons env (lid:lident) = + // + // AR: TODO: What's happening here? The function name is find_all_datacons, but + // it is returning mutuals? + // + let k_global_def lid = function + | ({ sigel = Sig_inductive_typ {mutuals=datas} }, _) -> Some datas + | _ -> None in + resolve_in_open_namespaces' env lid (fun _ -> None) (fun _ -> None) k_global_def + +let record_cache_aux_with_filter = + // push, pop, etc. already signal-atomic: no need for BU.atomically + let record_cache : ref (list (list record_or_dc)) = BU.mk_ref [[]] in + let push () = + record_cache := List.hd !record_cache::!record_cache in + let pop () = + record_cache := List.tl !record_cache in + let snapshot () = Common.snapshot push record_cache () in + let rollback depth = Common.rollback pop record_cache depth in + let peek () = List.hd !record_cache in + let insert r = record_cache := (r::peek())::List.tl (!record_cache) in + (* remove private/abstract records *) + let filter () = + let rc = peek () in + let filtered = List.filter (fun r -> not r.is_private) rc in + record_cache := filtered :: List.tl !record_cache + in + let aux = + ((push, pop), ((snapshot, rollback), (peek, insert))) + in (aux, filter) + +let record_cache_aux = fst record_cache_aux_with_filter +let filter_record_cache = snd record_cache_aux_with_filter +let push_record_cache = fst (fst record_cache_aux) +let pop_record_cache = snd (fst record_cache_aux) +let snapshot_record_cache = fst (fst (snd record_cache_aux)) +let rollback_record_cache = snd (fst (snd record_cache_aux)) +let peek_record_cache = fst (snd (snd record_cache_aux)) +let insert_record_cache = snd (snd (snd record_cache_aux)) + +let extract_record (e:env) (new_globs: ref (list scope_mod)) = fun se -> match se.sigel with + | Sig_bundle {ses=sigs} -> + let is_record = BU.for_some (function + | RecordType _ + | RecordConstructor _ -> true + | _ -> false) in + + let find_dc dc = + sigs |> BU.find_opt (function + | { sigel = Sig_datacon {lid} } -> lid_equals dc lid + | _ -> false) in + + sigs |> List.iter (function + | { sigel = Sig_inductive_typ {lid=typename; + us=univs; + params=parms; + ds=[dc]}; sigquals = typename_quals } -> + begin match must <| find_dc dc with + | { sigel = Sig_datacon {lid=constrname; t; num_ty_params=n} } -> + let all_formals, _ = U.arrow_formals t in + (* Ignore parameters, we don't create projectors for them *) + let _params, formals = BU.first_N n all_formals in + let is_rec = is_record typename_quals in + let formals' = formals |> List.collect (fun f -> + if S.is_null_bv f.binder_bv + || (is_rec && S.is_bqual_implicit f.binder_qual) + then [] + else [f] ) + in + let fields' = formals' |> List.map (fun f -> (f.binder_bv.ppname, f.binder_bv.sort)) + in + let fields = fields' + in + let record = {typename=typename; + constrname=ident_of_lid constrname; + parms=parms; + fields=fields; + is_private = List.contains Private typename_quals; + is_record=is_rec} in + (* the record is added to the current list of + top-level definitions, to allow shadowing field names + that were reachable through previous "open"s. *) + let () = new_globs := Record_or_dc record :: !new_globs in + (* the field names are added into the set of exported fields for "include" *) + let () = + let add_field (id, _) = + let modul = string_of_lid (lid_of_ids (ns_of_lid constrname)) in + match get_exported_id_set e modul with + | Some my_ex -> + let my_exported_ids = my_ex Exported_id_field in + let () = my_exported_ids := add (string_of_id id) !my_exported_ids in + (* also add the projector name *) + let projname = mk_field_projector_name_from_ident constrname id + |> ident_of_lid + |> string_of_id + in + let () = my_exported_ids := add projname !my_exported_ids in + () + | None -> () (* current module was not prepared? should not happen *) + in + List.iter add_field fields' + in + insert_record_cache record + | _ -> () + end + | _ -> ()) + + | _ -> () + +let try_lookup_record_or_dc_by_field_name env (fieldname:lident) = + let find_in_cache fieldname = + let ns, id = ns_of_lid fieldname, ident_of_lid fieldname in + BU.find_map + (peek_record_cache()) + (fun record -> + option_of_cont (fun _ -> None) (find_in_record ns id record (fun r -> Cont_ok r))) + in + resolve_in_open_namespaces'' + env + fieldname + Exported_id_field + (fun _ -> Cont_ignore) + (fun _ -> Cont_ignore) + (fun r -> Cont_ok r) + (fun fn -> cont_of_option Cont_ignore (find_in_cache fn)) + (fun k _ -> k) + +let try_lookup_record_by_field_name env (fieldname:lident) = + match try_lookup_record_or_dc_by_field_name env fieldname with + | Some r when r.is_record -> Some r + | _ -> None + +let try_lookup_record_type env (typename:lident) : option record_or_dc = + let find_in_cache (name:lident) : option record_or_dc = + let ns, id = ns_of_lid name, ident_of_lid name in + BU.find_map (peek_record_cache()) (fun record -> + if ident_equals (ident_of_lid record.typename) id + then Some record + else None + ) + in + resolve_in_open_namespaces'' env typename + Exported_id_term_type + (fun _ -> Cont_ignore) + (fun _ -> Cont_ignore) + (fun r -> Cont_ok r) + (fun l -> cont_of_option Cont_ignore (find_in_cache l)) + (fun k _ -> k) + +let belongs_to_record env lid record = + (* first determine whether lid is a valid record field name, and + that it resolves to a record' type in the same module as record + (even though the record types may be different.) *) + match try_lookup_record_by_field_name env lid with + | Some record' + when nsstr record.typename = nsstr record'.typename -> + (* now, check whether field belongs to record *) + begin match find_in_record (ns_of_lid record.typename) (ident_of_lid lid) record (fun _ -> Cont_ok ()) with + | Cont_ok _ -> true + | _ -> false + end + | _ -> false + +let try_lookup_dc_by_field_name env (fieldname:lident) = + match try_lookup_record_or_dc_by_field_name env fieldname with + | Some r -> Some (set_lid_range (lid_of_ids (ns_of_lid r.typename @ [r.constrname])) (range_of_lid fieldname), r.is_record) + | _ -> None + +let string_set_ref_new () : ref string_set = BU.mk_ref (empty ()) +let exported_id_set_new () = + let term_type_set = string_set_ref_new () in + let field_set = string_set_ref_new () in + function + | Exported_id_term_type -> term_type_set + | Exported_id_field -> field_set + +let unique any_val exclude_interface env lid = + (* Disable name resolution altogether, thus lid is assumed to be fully qualified *) + let filter_scope_mods = function + | Rec_binding _ + -> true + | _ -> false + in + let this_env = {env with scope_mods = List.filter filter_scope_mods env.scope_mods; exported_ids=empty_exported_id_smap; includes=empty_include_smap } in + match try_lookup_lid' any_val exclude_interface this_env lid with + | None -> true + | Some _ -> false + +let push_scope_mod env scope_mod = + {env with scope_mods = scope_mod :: env.scope_mods} + +let push_bv' env (x:ident) = + let r = range_of_id x in + let bv = S.gen_bv (string_of_id x) (Some r) ({ tun with pos = r }) in + let used_marker = BU.mk_ref false in + push_scope_mod env (Local_binding (x, bv, used_marker)), bv, used_marker + +let push_bv env x = + let (env, bv, _) = push_bv' env x in + (env, bv) + +let push_top_level_rec_binding env0 (x:ident) : env & ref bool = + let l = qualify env0 x in + if unique false true env0 l || Options.interactive () + then + let used_marker = BU.mk_ref false in + (push_scope_mod env0 (Rec_binding (x,l,used_marker)), used_marker) + else raise_error l Errors.Fatal_DuplicateTopLevelNames + ("Duplicate top-level names " ^ (string_of_lid l)) + +let push_sigelt' fail_on_dup env s = + let err l = + let sopt = BU.smap_try_find (sigmap env) (string_of_lid l) in + let r = match sopt with + | Some (se, _) -> + begin match BU.find_opt (lid_equals l) (lids_of_sigelt se) with + | Some l -> Range.string_of_range <| range_of_lid l + | None -> "" + end + | None -> "" in + raise_error l Errors.Fatal_DuplicateTopLevelNames [ + Errors.text (BU.format1 "Duplicate top-level names [%s]" (string_of_lid l)); + Errors.text (BU.format1 "Previously declared at %s" r) + ] + in + let globals = BU.mk_ref env.scope_mods in + let env = + let any_val, exclude_interface = match s.sigel with + | Sig_let _ + | Sig_bundle _ -> false, true + | _ -> false, false in + let lids = lids_of_sigelt s in + begin match BU.find_map lids (fun l -> if not (unique any_val exclude_interface env l) then Some l else None) with + | Some l when fail_on_dup -> err l + | _ -> extract_record env globals s; {env with sigaccum=s::env.sigaccum} + end in + let env = {env with scope_mods = !globals} in + let env, lss = match s.sigel with + | Sig_bundle {ses} -> env, List.map (fun se -> (lids_of_sigelt se, se)) ses + | _ -> env, [lids_of_sigelt s, s] in + lss |> List.iter (fun (lids, se) -> + lids |> List.iter (fun lid -> + (* the identifier is added into the list of global + declarations, to allow shadowing of definitions that were + formerly reachable by previous "open"s. *) + let () = globals := Top_level_def (ident_of_lid lid) :: !globals in + (* the identifier is added into the list of global identifiers + of the corresponding module to shadow any "include" *) + let modul = string_of_lid (lid_of_ids (ns_of_lid lid)) in + let () = match get_exported_id_set env modul with + | Some f -> + let my_exported_ids = f Exported_id_term_type in + my_exported_ids := add (string_of_id (ident_of_lid lid)) !my_exported_ids + | None -> () (* current module was not prepared? should not happen *) + in + let is_iface = env.iface && not env.admitted_iface in +// printfn "Adding %s at key %s with flag %A" (FStarC.Syntax.Print.sigelt_to_string_short se) (string_of_lid lid) is_iface; + BU.smap_add (sigmap env) (string_of_lid lid) (se, env.iface && not env.admitted_iface))); + let env = {env with scope_mods = !globals } in + env + +let push_sigelt env se = push_sigelt' true env se +let push_sigelt_force env se = push_sigelt' false env se + +let find_data_constructors_for_typ env (lid:lident) = + let k_global_def lid = function + | ({ sigel = Sig_inductive_typ {ds} }, _) -> Some ds + | _ -> None in + resolve_in_open_namespaces' env lid (fun _ -> None) (fun _ -> None) k_global_def + +let find_binders_for_datacons env (lid:lident) = + let k_global_def lid = function + | ({ sigel = Sig_datacon {t} }, _) -> + arrow_formals_comp_ln t + |> fst + |> List.map (fun x -> x.binder_bv.ppname) + |> Some + | _ -> None in + resolve_in_open_namespaces' env lid (fun _ -> None) (fun _ -> None) k_global_def + +(** Elaborates a `restriction`: this function adds implicit names +(projectors, discriminators, record fields) that F* generates +automatically. It also checks that all the idents the user added +actually exists in the given namespace. *) +let elab_restriction f env ns restriction = + let open FStarC.Class.Deq in + match restriction with + | Unrestricted -> f env ns restriction + | AllowList l -> + let mk_lid (id: ident): lident = set_lid_range (lid_of_ids (ids_of_lid (qual_id ns id))) (range_of_id id) in + let name_exists id = + let lid = mk_lid id in + match try_lookup_lid env lid with + | Some _ -> true + | None -> try_lookup_record_or_dc_by_field_name env lid |> is_some + in + // For every inductive, we include its constructors + let l = List.map (fun (id, renamed) -> + let with_id_range = dflt id renamed |> range_of_id |> set_id_range in + match find_data_constructors_for_typ env (mk_lid id) with + | Some idents -> List.map (fun id -> (ident_of_lid id |> with_id_range, None)) idents + | None -> [] + ) l |> List.flatten |> List.append l in + // For every constructor, we include possible desugared record + // payloads types + let l = + (* A (precomputed) associated list that maps a constructors to + types that comes from a "record-on-a-variant" desugar. E.g. `A` + is mapped to `Mka__A__payload` for a `type a = | A {x:int}`. *) + let constructor_lid_to_desugared_record_lids: list (ident * ident) = + begin let! (_, {declarations}) = env.modules in + let! sigelt = declarations in + let! sigelt = match sigelt.sigel with | Sig_bundle {ses} -> ses | _ -> [] in + let! lid = lids_of_sigelt sigelt in + match U.get_attribute Const.desugar_of_variant_record_lid sigelt.sigattrs with + | Some [({n = Tm_constant (FStarC.Const.Const_string (s, _))}, None)] + -> [(lid_of_str s, lid)] + | _ -> [] + end + |> List.filter (fun (cons, lid) -> ns_of_lid cons =? ns_of_lid lid + && ns_of_lid lid =? ids_of_lid ns) + |> List.map (fun (cons, lid) -> (ident_of_lid cons, ident_of_lid lid)) + in constructor_lid_to_desugared_record_lids + |> List.filter (fun (cons, _) -> List.find (fun (lid, _) -> lid =? cons) l |> Some?) + |> List.map (fun (_, lid) -> (lid, None)) + |> List.append l + in + let l = List.map (fun (id, renamed) -> + let with_renamed_range = dflt id renamed |> range_of_id |> set_id_range in + let with_id_range = dflt id renamed |> range_of_id |> set_id_range in + let lid = mk_lid id in + begin + // If `id` is a datatype, we include its projections + ((match find_binders_for_datacons env lid with | None -> [] | Some l -> l) + |> List.map (fun binder -> + ( mk_field_projector_name_from_ident lid binder + |> ident_of_lid + , map_opt renamed (fun renamed -> + mk_field_projector_name_from_ident (lid_of_ids [renamed]) binder + |> ident_of_lid + ) + ) + )) + // If `id` is a datatype, we include its discriminator + // (actually, we always include a discriminator, it will be + // removed if it doesn't exist) + @ ( [ mk_discriminator (lid_of_ids [id]) + , map_opt renamed (fun renamed -> mk_discriminator (lid_of_ids [renamed])) + ] |> List.map (fun (x, y) -> (ident_of_lid x, map_opt y ident_of_lid)) + |> List.filter (fun (x, _) -> name_exists x)) + // If `id` is a record, we include its fields + @ ( match try_lookup_record_type env lid with + | Some {constrname; fields} -> List.map (fun (id, _) -> (id, None)) fields + | None -> []) + end |> List.map (fun (id, renamed) -> (with_id_range id, map_opt renamed with_renamed_range)) + ) l |> List.flatten |> List.append l in + let _error_on_duplicates = + let final_idents = List.mapi (fun i (id, renamed) -> (dflt id renamed, i)) l in + match final_idents |> find_dup (fun (x, _) (y, _) -> x =? y) with + | Some (id, i) -> + let others = List.filter (fun (id', i') -> id =? id' && not (i =? i')) final_idents in + List.mapi (fun nth (other, _) -> + let nth = match nth with | 0 -> "first" | 1 -> "second" | 2 -> "third" | nth -> show (nth + 1) ^ "th" in + { + issue_msg = [show other ^ " " ^ nth ^ " occurence comes from this declaration" |> FStarC.Errors.Msg.text]; + issue_level = EError; + issue_range = Some (range_of_id other); + issue_number = None; + issue_ctx = []; + } + ) others |> add_issues; + raise_error id Errors.Fatal_DuplicateTopLevelNames + (BU.format1 ("The name %s was imported " ^ show (List.length others + 1) ^ " times") (string_of_id id)) + | None -> () + in + l |> List.iter (fun (id, _renamed) -> + if name_exists id |> not + then raise_error id Errors.Fatal_NameNotFound + (BU.format1 "Definition %s cannot be found" (mk_lid id |> string_of_lid))); + f env ns (AllowList l) + +let push_namespace' env ns restriction = + (* namespace resolution disabled, but module abbrevs enabled *) + (* GM: What's the rationale for this? *) + let (ns', kd) = + match resolve_module_name env ns false with + | None -> ( + let module_names = List.map fst env.modules in + let module_names = + match env.curmodule with + | None -> module_names + | Some l -> l::module_names + in + if module_names |> + BU.for_some + (fun m -> + BU.starts_with (Ident.string_of_lid m ^ ".") + (Ident.string_of_lid ns ^ ".")) + then (ns, Open_namespace) + else raise_error ns Errors.Fatal_NameSpaceNotFound + (BU.format1 "Namespace %s cannot be found" (Ident.string_of_lid ns)) + ) + | Some ns' -> + (ns', Open_module) + in + env.ds_hooks.ds_push_open_hook env (ns', kd, restriction); + push_scope_mod env (Open_module_or_namespace (ns', kd, restriction)) + +let push_include' env ns restriction = + (* similarly to push_namespace in the case of modules, we allow + module abbrevs, but not namespace resolution *) + let ns0 = ns in + match resolve_module_name env ns false with + | Some ns -> + env.ds_hooks.ds_push_include_hook env ns; + (* from within the current module, include is equivalent to open *) + let env = push_scope_mod env (Open_module_or_namespace (ns, Open_module, restriction)) in + (* update the list of includes *) + let curmod = string_of_lid (current_module env) in + let () = match BU.smap_try_find env.includes curmod with + | None -> () + | Some incl -> incl := (ns, restriction) :: !incl + in + (* the names of the included module and its transitively + included modules shadow the names of the current module *) + begin match get_trans_exported_id_set env (string_of_lid ns) with + | Some ns_trans_exports -> + let () = match (get_exported_id_set env curmod, get_trans_exported_id_set env curmod) with + | (Some cur_exports, Some cur_trans_exports) -> + let update_exports (k: exported_id_kind) = + let ns_ex = ! (ns_trans_exports k) in + let ex = cur_exports k in + let () = ex := diff (!ex) ns_ex in + let trans_ex = cur_trans_exports k in + let () = trans_ex := union (!trans_ex) ns_ex in + () + in + List.iter update_exports all_exported_id_kinds + | _ -> () (* current module was not prepared? should not happen *) + in + env + | None -> + (* module to be included was not prepared, so forbid the 'include'. It may be the case for modules such as FStarC.Compiler.Effect, etc. *) + raise_error ns Errors.Fatal_IncludeModuleNotPrepared + (BU.format1 "include: Module %s was not prepared" (string_of_lid ns)) + end + | _ -> + raise_error ns Errors.Fatal_ModuleNotFound + (BU.format1 "include: Module %s cannot be found" (string_of_lid ns)) + +let push_namespace = elab_restriction push_namespace' +let push_include = elab_restriction push_include' + +let push_module_abbrev env x l = + (* both namespace resolution and module abbrevs disabled: + in 'module A = B', B must be fully qualified *) + if module_is_defined env l + then begin + env.ds_hooks.ds_push_module_abbrev_hook env x l; + push_scope_mod env (Module_abbrev (x,l)) + end else raise_error l Errors.Fatal_ModuleNotFound + (BU.format1 "Module %s cannot be found" (Ident.string_of_lid l)) + +let check_admits env m = + let admitted_sig_lids = + env.sigaccum |> List.fold_left (fun lids se -> + match se.sigel with + | Sig_declare_typ {lid=l; us=u; t} when not (se.sigquals |> List.contains Assumption) -> + // l is already fully qualified, so no name resolution + begin match BU.smap_try_find (sigmap env) (string_of_lid l) with + | Some ({sigel=Sig_let _}, _) + | Some ({sigel=Sig_inductive_typ _}, _) + | Some ({sigel=Sig_splice _}, _) -> + (* ok *) + lids + | _ -> + if not (Options.interactive ()) then begin + let open FStarC.Pprint in + let open FStarC.Class.PP in + FStarC.Errors.log_issue l Errors.Error_AdmitWithoutDefinition [ + doc_of_string (show l) ^/^ text "is declared but no definition was found"; + text "Add an 'assume' if this is intentional" + ] + end; + let quals = Assumption :: se.sigquals in + BU.smap_add (sigmap env) (string_of_lid l) ({ se with sigquals = quals }, false); + l::lids + end + | _ -> lids) [] + in + m + +let finish env modul = + modul.declarations |> List.iter (fun se -> + let quals = se.sigquals in + match se.sigel with + | Sig_bundle {ses} -> + if List.contains Private quals + then ses |> List.iter (fun se -> match se.sigel with + | Sig_datacon {lid} -> + BU.smap_remove (sigmap env) (string_of_lid lid) + | Sig_inductive_typ {lid;us=univ_names;params=binders;t=typ} -> + BU.smap_remove (sigmap env) (string_of_lid lid); + if not (List.contains Private quals) + then //it's only abstract; add it back to the environment as an abstract type + let sigel = Sig_declare_typ {lid;us=univ_names;t=S.mk (Tm_arrow {bs=binders; comp=S.mk_Total typ}) (Ident.range_of_lid lid)} in + let se = {se with sigel=sigel; sigquals=Assumption::quals} in + BU.smap_add (sigmap env) (string_of_lid lid) (se, false) + | _ -> ()) + + | Sig_declare_typ {lid} -> + if List.contains Private quals + then BU.smap_remove (sigmap env) (string_of_lid lid) + + | Sig_let {lbs=(_,lbs)} -> + if List.contains Private quals + then begin + lbs |> List.iter (fun lb -> BU.smap_remove (sigmap env) (string_of_lid (right lb.lbname).fv_name.v)) + end + + | _ -> ()); + (* update the sets of transitively exported names of this module by + adding the unshadowed names defined only in the current module. *) + let curmod = string_of_lid (current_module env) in + let () = match (get_exported_id_set env curmod, get_trans_exported_id_set env curmod) with + | (Some cur_ex, Some cur_trans_ex) -> + let update_exports eikind = + let cur_ex_set = ! (cur_ex eikind) in + let cur_trans_ex_set_ref = cur_trans_ex eikind in + cur_trans_ex_set_ref := union cur_ex_set (!cur_trans_ex_set_ref) + in + List.iter update_exports all_exported_id_kinds + | _ -> () + in + (* remove abstract/private records *) + let () = filter_record_cache () in + {env with + curmodule=None; + modules=(modul.name, modul)::env.modules; + scope_mods = []; + sigaccum=[]; + } + +let stack: ref (list env) = BU.mk_ref [] +let push env = BU.atomically (fun () -> + push_record_cache(); + stack := env::!stack; + {env with exported_ids = BU.smap_copy env.exported_ids; + trans_exported_ids = BU.smap_copy env.trans_exported_ids; + includes = BU.smap_copy env.includes; + sigmap = BU.smap_copy env.sigmap }) + +let pop () = BU.atomically (fun () -> + match !stack with + | env::tl -> + pop_record_cache(); + stack := tl; + env + | _ -> failwith "Impossible: Too many pops") + +let snapshot env = Common.snapshot push stack env +let rollback depth = Common.rollback pop stack depth + +let export_interface (m:lident) env = +// printfn "Exporting interface %s" (string_of_lid m); + let sigelt_in_m se = + match U.lids_of_sigelt se with + | l::_ -> (nsstr l)=(string_of_lid m) + | _ -> false in + let sm = sigmap env in + let env = pop () in // FIXME PUSH POP + let keys = BU.smap_keys sm in + let sm' = sigmap env in + keys |> List.iter (fun k -> + match BU.smap_try_find sm' k with + | Some (se, true) when sigelt_in_m se -> + BU.smap_remove sm' k; +// printfn "Exporting %s" k; + let se = match se.sigel with + | Sig_declare_typ {lid=l; us=u; t} -> + { se with sigquals = Assumption::se.sigquals } + | _ -> se in + BU.smap_add sm' k (se, false) + | _ -> ()); + env + +let finish_module_or_interface env modul = + let modul = if not modul.is_interface then check_admits env modul else modul in + finish env modul, modul + +type exported_ids = { + exported_id_terms : string_set; + exported_id_fields: string_set; +} +let as_exported_ids (e:exported_id_set) = + let terms = (!(e Exported_id_term_type)) in + let fields = (!(e Exported_id_field)) in + {exported_id_terms=terms; + exported_id_fields=fields} + +let as_exported_id_set (e:option exported_ids) = + match e with + | None -> exported_id_set_new () + | Some e -> + let terms = + BU.mk_ref (e.exported_id_terms) in + let fields = + BU.mk_ref (e.exported_id_fields) in + function + | Exported_id_term_type -> terms + | Exported_id_field -> fields + + +type module_inclusion_info = { + mii_exported_ids:option exported_ids; + mii_trans_exported_ids:option exported_ids; + mii_includes:option (list (lident & restriction)) +} + +let default_mii = { + mii_exported_ids=None; + mii_trans_exported_ids=None; + mii_includes=None +} + +let as_includes = function + | None -> BU.mk_ref [] + | Some l -> BU.mk_ref l + +let inclusion_info env (l:lident) = + let mname = FStarC.Ident.string_of_lid l in + let as_ids_opt m = + BU.map_opt (BU.smap_try_find m mname) as_exported_ids + in + { + mii_exported_ids = as_ids_opt env.exported_ids; + mii_trans_exported_ids = as_ids_opt env.trans_exported_ids; + mii_includes = BU.map_opt (BU.smap_try_find env.includes mname) (fun r -> !r) + } + +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 = FStarC.Parser.Dep.hard_coded_dependencies filename in + let auto_open = + let convert_kind = function + | FStarC.Parser.Dep.Open_namespace -> Open_namespace + | FStarC.Parser.Dep.Open_module -> Open_module + in + List.map (fun (lid, kind) -> (lid, convert_kind kind, Unrestricted)) auto_open + in + let namespace_of_module = if List.length (ns_of_lid mname) > 0 then [ (lid_of_ids (ns_of_lid mname), Open_namespace, Unrestricted) ] else [] in + (* [scope_mods] is a stack, so reverse the order *) + let auto_open = namespace_of_module @ List.rev auto_open in + + (* Create new empty set of exported identifiers for the current module, for 'include' *) + let () = BU.smap_add env.exported_ids (string_of_lid mname) (as_exported_id_set mii.mii_exported_ids) in + (* Create new empty set of transitively exported identifiers for the current module, for 'include' *) + let () = BU.smap_add env.trans_exported_ids (string_of_lid mname) (as_exported_id_set mii.mii_trans_exported_ids) in + (* Create new empty list of includes for the current module *) + let () = BU.smap_add env.includes (string_of_lid mname) (as_includes mii.mii_includes) in + let env' = { + env with curmodule=Some mname; + sigmap=env.sigmap; + scope_mods = List.map (fun x -> Open_module_or_namespace x) auto_open; + iface=intf; + admitted_iface=admitted } in + List.iter (fun op -> env.ds_hooks.ds_push_open_hook env' op) (List.rev auto_open); + env' + in + + match env.modules |> BU.find_opt (fun (l, _) -> lid_equals l mname) with + | None -> + prep env, false + | Some (_, m) -> + if not (Options.interactive ()) && (not m.is_interface || intf) + then raise_error mname Errors.Fatal_DuplicateModuleOrInterface + (BU.format1 "Duplicate module or interface name: %s" (string_of_lid mname)); + //we have an interface for this module already; if we're not interactive then do not export any symbols from this module + prep (push env), true //push a context so that we can pop it when we're done // FIXME PUSH POP + +let enter_monad_scope env mname = + match env.curmonad with + | Some mname' -> + raise_error mname Errors.Fatal_MonadAlreadyDefined + ("Trying to define monad " ^ (show mname) ^ ", but already in monad scope " ^ (show mname')) + | None -> {env with curmonad = Some mname} + +let fail_or env lookup lid = + match lookup lid with + | Some r -> r + | None -> + (* try to report a nice error *) + let opened_modules = List.map (fun (lid, _) -> string_of_lid lid) env.modules in + let msg = Errors.mkmsg (BU.format1 "Identifier not found: [%s]" (string_of_lid lid)) in + let msg = + if List.length (ns_of_lid lid) = 0 + then + msg + else + let modul = set_lid_range (lid_of_ids (ns_of_lid lid)) (range_of_lid lid) in + let open FStarC.Pprint in + let subdoc d = + nest 2 (hardline ^^ align d) + in + match resolve_module_name env modul true with + | None -> + let opened_modules = String.concat ", " opened_modules |> Errors.text in + msg @ [Errors.text (BU.format1 "Could not resolve module name %s" + (string_of_lid modul))] + | Some modul' when (not (List.existsb (fun m -> m = (string_of_lid modul')) opened_modules)) -> + let opened_modules = String.concat ", " opened_modules |> Errors.text in + msg @ [Errors.text (BU.format2 "Module %s resolved into %s, which does not belong to the list of modules in scope, namely:" + (string_of_lid modul) + (string_of_lid modul')) ^^ subdoc opened_modules] + | Some modul' -> + msg @ [Errors.text (BU.format3 + "Module %s resolved into %s, definition %s not found" + (string_of_lid modul) + (string_of_lid modul') + (string_of_id (ident_of_lid lid)))] + in + raise_error lid Errors.Fatal_IdentifierNotFound msg + +let fail_or2 lookup id = match lookup id with + | None -> raise_error id Errors.Fatal_IdentifierNotFound ("Identifier not found [" ^(string_of_id id)^"]") + | Some r -> r + +let resolve_name (e:env) (name:lident) + : option (either bv fv) + = match try_lookup_name false false e name with + | None -> None + | Some (Term_name (e, attrs)) -> ( + match (Subst.compress e).n with + | Tm_name n -> Some (Inl n) + | Tm_fvar fv -> Some (Inr fv) + | _ -> None + ) + | Some (Eff_name(se, l)) -> + Some (Inr (S.lid_and_dd_as_fv l None)) diff --git a/src/syntax/FStarC.Syntax.DsEnv.fsti b/src/syntax/FStarC.Syntax.DsEnv.fsti new file mode 100644 index 00000000000..a22483432fa --- /dev/null +++ b/src/syntax/FStarC.Syntax.DsEnv.fsti @@ -0,0 +1,145 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Syntax.DsEnv +open FStarC.Compiler.Effect + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.Compiler.Effect +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.Syntax.Util +open FStarC.Parser +open FStarC.Ident +module BU = FStarC.Compiler.Util +module S = FStarC.Syntax.Syntax +module U = FStarC.Syntax.Util + +val ugly_sigelt_to_string_hook : ref (sigelt -> string) + +let open_module_or_namespace = S.open_module_or_namespace +type used_marker = ref bool + (* opens the whole namespace *) +type record_or_dc = { + typename: lident; (* the namespace part applies to the constructor and fields as well *) + constrname: ident; + parms: binders; + fields: list (ident & typ); + is_private: bool; + is_record:bool +} + +val env : Type0 +val dsenv_hooks : Type0 + +val mk_dsenv_hooks + (open_hook:env -> open_module_or_namespace -> unit) + (include_hook:env -> lident -> unit) + (module_abbrev_hook:env -> ident -> lident -> unit) + : dsenv_hooks + +type withenv 'a = env -> 'a & env + +type foundname = + | Term_name of typ & list attribute + | Eff_name of sigelt & lident + +val fail_or: env -> (lident -> option 'a) -> lident -> 'a +val fail_or2: (ident -> option 'a) -> ident -> 'a + +val opens_and_abbrevs :env -> list (either open_module_or_namespace module_abbrev) +val dep_graph: env -> FStarC.Parser.Dep.deps +val set_dep_graph: env -> FStarC.Parser.Dep.deps -> env +val ds_hooks : env -> dsenv_hooks +val set_ds_hooks: env -> dsenv_hooks -> env +val syntax_only: env -> bool +val set_syntax_only: env -> bool -> env +val qualify: env -> ident -> lident +val set_iface: env -> bool -> env +val iface: env -> bool +val set_admitted_iface: env -> bool -> env +val admitted_iface: env -> bool +val expect_typ: env -> bool +val set_expect_typ: env -> bool -> env +val empty_env: FStarC.Parser.Dep.deps -> env +val current_module: env -> lident +val set_current_module: env -> lident -> env +val open_modules: env -> list (lident & modul) +val open_modules_and_namespaces: env -> list lident +val module_abbrevs: env -> list (ident & lident) +val iface_decls : env -> lident -> option (list Parser.AST.decl) +val set_iface_decls: env -> lident -> list Parser.AST.decl -> env +val try_lookup_id: env -> ident -> option term +val shorten_module_path: env -> list ident -> bool -> (list ident & list ident) +val shorten_lid: env -> lid -> lid +val try_lookup_lid: env -> lident -> option term +val try_lookup_lid_with_attributes: env -> lident -> option (term & list attribute) +val try_lookup_lid_with_attributes_no_resolve: env -> lident -> option (term & list attribute) +val try_lookup_lid_no_resolve: env -> lident -> option term +val try_lookup_effect_name: env -> lident -> option lident +val try_lookup_effect_name_and_attributes: env -> lident -> option (lident & list cflag) +val try_lookup_effect_defn: env -> lident -> option eff_decl +(* [try_lookup_root_effect_name] is the same as +[try_lookup_effect_name], but also traverses effect abbrevs. TODO: +once indexed effects are in, also track how indices and other +arguments are instantiated. *) +val try_lookup_root_effect_name: env -> lident -> option lident +val try_lookup_datacon: env -> lident -> option fv +val try_lookup_record_by_field_name: env -> lident -> option record_or_dc +val try_lookup_record_type: env -> lident -> option record_or_dc +val belongs_to_record: env -> lident -> record_or_dc -> bool +val try_lookup_dc_by_field_name: env -> lident -> option (lident & bool) +val try_lookup_definition: env -> lident -> option term +val is_effect_name: env -> lident -> bool +val find_all_datacons: env -> lident -> option (list lident) +val lookup_letbinding_quals_and_attrs: env -> lident -> list qualifier & list attribute +val resolve_module_name: env:env -> lid:lident -> honor_ns:bool -> option lident +val resolve_to_fully_qualified_name : env:env -> l:lident -> option lident +val fv_qual_of_se : sigelt -> option fv_qual + +val push_bv': env -> ident -> env & bv & used_marker +val push_bv: env -> ident -> env & bv +val push_top_level_rec_binding: env -> ident -> env & ref bool +val push_sigelt: env -> sigelt -> env +val push_namespace: env -> lident -> restriction -> env +val push_include: env -> lident -> restriction -> env +val push_module_abbrev : env -> ident -> lident -> env +val resolve_name: env -> lident -> option (either bv fv) + +(* Won't fail on duplicates, use with caution *) +val push_sigelt_force : env -> sigelt -> env + +val pop: unit -> env +val push: env -> env +val rollback: option int -> env +val snapshot: env -> (int & env) + +val finish_module_or_interface: env -> modul -> (env & modul) +val enter_monad_scope: env -> ident -> env +val export_interface: lident -> env -> env + +val transitive_exported_ids: env -> lident -> list string +val module_inclusion_info : Type0 +val default_mii : module_inclusion_info +val inclusion_info: env -> lident -> module_inclusion_info +val prepare_module_or_interface: bool -> bool -> env -> lident -> module_inclusion_info -> env & bool //pop the context when done desugaring + +(* private *) val try_lookup_lid': bool -> bool -> env -> lident -> option (term & list attribute) +(* private *) val unique: bool -> bool -> env -> lident -> bool +(* private *) val check_admits: env -> modul -> modul +(* private *) val finish: env -> modul -> env diff --git a/src/syntax/FStarC.Syntax.Embeddings.AppEmb.fst b/src/syntax/FStarC.Syntax.Embeddings.AppEmb.fst new file mode 100644 index 00000000000..8ae82157366 --- /dev/null +++ b/src/syntax/FStarC.Syntax.Embeddings.AppEmb.fst @@ -0,0 +1,51 @@ +module FStarC.Syntax.Embeddings.AppEmb + +open FStarC.Syntax.Syntax +open FStarC.Syntax.Embeddings.Base + +type appemb 'a = + args -> option ('a & args) + +let one (e : embedding 'a) : appemb 'a = + fun args -> + match args with + | (t,_)::xs -> + match try_unembed t id_norm_cb with + | None -> None + | Some v -> Some (v, xs) + +let (let?) o f = match o with | None -> None | Some v -> f v + +val (<*>) : appemb ('a -> 'b) -> appemb 'a -> appemb 'b +let (<*>) u1 u2 = + fun args -> + let? f, args' = u1 args in + let? v, args'' = u2 args' in + Some (f v, args'') + +val (<**>) : appemb ('a -> 'b) -> embedding 'a -> appemb 'b +let (<**>) u1 u2 = u1 <*> one u2 + +let pure (x : 'a) : appemb 'a = + fun args -> Some (x, args) + +val (<$>) : ('a -> 'b) -> appemb 'a -> appemb 'b +let (<$>) u1 u2 = pure u1 <*> u2 + +val (<$$>) : ('a -> 'b) -> embedding 'a -> appemb 'b +let (<$$>) u1 u2 = pure u1 <*> one u2 + +val run : args -> appemb 'a -> option 'a +let run args u = + match u args with + | Some (r, []) -> Some r + | _ -> None + +val wrap : (term -> option 'a) -> appemb 'a +let wrap f = + fun args -> + match args with + | (t,_)::xs -> + match f t with + | None -> None + | Some v -> Some (v, xs) diff --git a/src/syntax/FStarC.Syntax.Embeddings.Base.fst b/src/syntax/FStarC.Syntax.Embeddings.Base.fst new file mode 100644 index 00000000000..7e9816e13ce --- /dev/null +++ b/src/syntax/FStarC.Syntax.Embeddings.Base.fst @@ -0,0 +1,301 @@ +(* + Copyright 2008-2014 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Syntax.Embeddings.Base + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.Range +open FStar.Pervasives +open FStarC.Syntax.Syntax +open FStarC.Class.Show +open FStarC.Class.PP +open FStarC.Class.Deq + +module BU = FStarC.Compiler.Util +module Err = FStarC.Errors +module Ident = FStarC.Ident +module PC = FStarC.Parser.Const +module Print = FStarC.Syntax.Print +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module U = FStarC.Syntax.Util + +(********************************************************************* + + A NOTE ON FUNCTIONS AND SHADOW TERMS + +Shadow terms exist to acomodate strong reduction of plugins. + +Suppose we have this function, marked as a plugin to accelerate it +during typechecking: + + [@@plugin] + let sort (l : list int) : list int = ... + +(Plugins are usually tactics, but do not have to be. This discussion +is actually not so relevant for tactics as they do not run in open +contexts.) + +Compilation will generate a version that works on _real_ concrete +lists of integers. To call it on a term, as we have to do during +typechecking, we need to wrap it with embeddings: + + sort_term t = embed_intlist (sort (unembed_intlist t)) + +This turns the term `t` into an actual `list int`, calls the native +sort function, and then reconstructs a term for the resulting list. + +After loading the compiled version of that file, `sort_term` is now +loaded as a primitive step in the normalizer (under the name `sort`, of +course), and will be called everytime we find this symbol applied to an +argument. While its argument must have already been reduced (CBV), there +is no guarantee that it is an actual _value_ as we may be in an open +context, e.g. we may be typechecking this formula: + + forall l. sum (sort l) == sum l + +or it can be applied to some abstract lid even in a closed +context, or to a Tm_let that we are not currently reducing (e.g. DIV), +etc. So, we may fail (and often do) to unembed the argument term +to obtain a concrete list, hence sort_term is closer to: + + sort_term t = match unembed_intlist t with + | None -> None + | Some l -> embed_intlist (sort l) + +But, instead of stopping reduction with the None, we can instead +use the definition of sort itself, and call the normalizer with +the unfolded definition applied to the symbolic argument. Shadow +terms are term representations of whatever the embedded thing is, +which can be defaulted to when the embedding does not work. + +(TODO: what does this do for recursive functions? sounds + like it would not unfold? Actually, it seems broken: + + [@@plugin] + let rec mylen (l : list int) : int = + match l with + | [] -> 0 + | x::xs -> 1 + mylen xs + + let test (a b c : int) = + assert (mylen [a;b;c] == mylen [c;b;a]) by begin + dump "1"; + compute (); + dump "2"; + trefl (); + () + end + +this file works when mylen is not loaded as a plugin, but fails +otherwise since reduction is blocked.) + + +*********************************************************************) + +let id_norm_cb : norm_cb = function + | Inr x -> x + | Inl l -> S.fv_to_tm (S.lid_as_fv l None) +exception Embedding_failure +exception Unembedding_failure + +let map_shadow (s:shadow_term) (f:term -> term) : shadow_term = + BU.map_opt s (Thunk.map f) +let force_shadow (s:shadow_term) = BU.map_opt s Thunk.force + +class embedding (a:Type0) = { + em : a -> embed_t; + un : term -> unembed_t a; + print : printer a; + + (* These are thunked so we can create Tot instances. *) + typ : unit -> typ; + e_typ : unit -> emb_typ; +} + +let emb_typ_of a #e () = e.e_typ () + +let unknown_printer (typ : term) (_ : 'a) : string = + BU.format1 "unknown %s" (show typ) + +let term_as_fv t = + match (SS.compress t).n with + | Tm_fvar fv -> fv + | _ -> failwith (BU.format1 "Embeddings not defined for type %s" (show t)) + +let mk_emb em un fv : Tot _ = + { + em = em; + un = un; + print = (fun x -> let typ = S.fv_to_tm fv in unknown_printer typ x); + typ = (fun () -> S.fv_to_tm fv); + e_typ= (fun () -> ET_app (S.lid_of_fv fv |> Ident.string_of_lid, [])); + } + +let mk_emb_full em un typ printe emb_typ : Tot _ = { + em = em ; + un = un ; + typ = typ; + print = printe; + e_typ = emb_typ; +} +// +// +// AR/NS: 04/22/2022: +// In the case of metaprograms, we reduce divergent terms in +// the normalizer, therefore, the final result that we get +// may be wrapped in a Meta_monadic node (e.g. lift, app, etc.) +// Before unembedding the result of such a computation, +// we strip those meta nodes +// In case the term inside is not a result, unembedding would +// anyway fail +// And we strip down only DIV +// Can we get any other effect? Not today, since from the client +// code, we enforce terms to be normalized to be PURE +// + +let rec unmeta_div_results t = + let open FStarC.Ident in + match (SS.compress t).n with + | Tm_meta {tm=t'; meta=Meta_monadic_lift (src, dst, _)} -> + if lid_equals src PC.effect_PURE_lid && + lid_equals dst PC.effect_DIV_lid + then unmeta_div_results t' + else t + + | Tm_meta {tm=t'; meta=Meta_monadic (m, _)} -> + if lid_equals m PC.effect_DIV_lid + then unmeta_div_results t' + else t + + | Tm_meta {tm=t'} -> unmeta_div_results t' + + | Tm_ascribed {tm=t'} -> unmeta_div_results t' + + | _ -> t + +let type_of (e:embedding 'a) = e.typ () +let printer_of (e:embedding 'a) = e.print +let set_type ty (e:embedding 'a) = { e with typ = (fun () -> ty) } + +let embed {| e:embedding 'a |} = e.em +let try_unembed {| e:embedding 'a |} t n = + (* Unembed always receives a term without the meta_monadics above, + and also already compressed. *) + let t = unmeta_div_results t in + e.un (SS.compress t) n + +let unembed #a {| e:embedding a |} t n = + let r = try_unembed t n in + let open FStarC.Errors.Msg in + let open FStarC.Pprint in + if None? r then + Err.log_issue t Err.Warning_NotEmbedded [ + text "Unembedding failed for type" ^/^ pp (type_of e); + text "emb_typ = " ^/^ doc_of_string (show (emb_typ_of a ())); + text "Term =" ^/^ pp t; + ]; + r + + +let embed_as (ea:embedding 'a) (ab : 'a -> 'b) (ba : 'b -> 'a) (o:option S.typ) : Tot (embedding 'b) = + mk_emb_full (fun (x:'b) -> embed (ba x)) + (fun (t:term) cb -> BU.map_opt (try_unembed t cb) ab) + (fun () -> match o with | Some t -> t | _ -> type_of ea) + (fun (x:'b) -> BU.format1 "(embed_as>> %s)\n" (ea.print (ba x))) + ea.e_typ + +(* A simple lazy embedding, without cancellations nor an expressive type. *) +let e_lazy #a (k:lazy_kind) (ty : S.typ) : embedding a = + let ee (x:a) rng _topt _norm : term = U.mk_lazy x ty k (Some rng) in + let uu (t:term) _norm : option a = + let t0 = t in + match (SS.compress t).n with + | Tm_lazy {blob=b; lkind=lkind} when lkind =? k -> Some (Dyn.undyn b) + | Tm_lazy {blob=b; lkind=lkind} -> + (* This is very likely a bug, warn! *) + Err.log_issue t0 Err.Warning_NotEmbedded + (BU.format3 "Warning, lazy unembedding failed, tag mismatch.\n\t\ + Expected %s, got %s\n\t\ + t = %s." + (show k) (show lkind) (show t0)); + None + | _ -> + None + in + mk_emb ee uu (term_as_fv ty) + +let lazy_embed (pa:printer 'a) (et:emb_typ) rng (ta:term) (x:'a) (f:unit -> term) = + if !Options.debug_embedding + then BU.print3 "Embedding a %s\n\temb_typ=%s\n\tvalue is %s\n" + (show ta) + (show et) + (pa x); + if !Options.eager_embedding + then f() + else let thunk = Thunk.mk f in + U.mk_lazy x S.tun (Lazy_embedding (et, thunk)) (Some rng) + +let lazy_unembed (pa:printer 'a) (et:emb_typ) (x:term) (ta:term) (f:term -> option 'a) : option 'a = + let x = SS.compress x in + match x.n with + | Tm_lazy {blob=b; lkind=Lazy_embedding (et', t)} -> + if et <> et' + || !Options.eager_embedding + then let res = f (Thunk.force t) in + let _ = if !Options.debug_embedding + then BU.print3 "Unembed cancellation failed\n\t%s <> %s\nvalue is %s\n" + (show et) + (show et') + (match res with None -> "None" | Some x -> "Some " ^ (pa x)) + in + res + else let a = Dyn.undyn b in + let _ = if !Options.debug_embedding + then BU.print2 "Unembed cancelled for %s\n\tvalue is %s\n" + (show et) (pa a) + in + Some a + | _ -> + let aopt = f x in + let _ = if !Options.debug_embedding + then BU.print3 "Unembedding:\n\temb_typ=%s\n\tterm is %s\n\tvalue is %s\n" + (show et) (show x) + (match aopt with None -> "None" | Some a -> "Some " ^ pa a) in + aopt + +let (let?) o f = BU.bind_opt o f + +let mk_extracted_embedding (name: string) (u: string & list term -> option 'a) (e: 'a -> term) : embedding 'a = + let uu (t:term) _norm : option 'a = + let hd, args = U.head_and_args t in + let? hd_lid = + match (SS.compress (U.un_uinst hd)).n with + | Tm_fvar fv -> Some fv.fv_name.v + | _ -> None + in + u (Ident.string_of_lid hd_lid, List.map fst args) + in + let ee (x:'a) rng _topt _norm : term = e x in + mk_emb ee uu (S.lid_as_fv (Ident.lid_of_str name) None) + +let extracted_embed (e: embedding 'a) (x: 'a) : term = + embed x Range.dummyRange None id_norm_cb + +let extracted_unembed (e: embedding 'a) (t: term) : option 'a = + try_unembed t id_norm_cb diff --git a/src/syntax/FStarC.Syntax.Embeddings.Base.fsti b/src/syntax/FStarC.Syntax.Embeddings.Base.fsti new file mode 100644 index 00000000000..53e6c27a529 --- /dev/null +++ b/src/syntax/FStarC.Syntax.Embeddings.Base.fsti @@ -0,0 +1,115 @@ +(* + Copyright 2008-2014 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Syntax.Embeddings.Base + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStar.Pervasives +open FStarC.Syntax.Syntax +module S = FStarC.Syntax.Syntax + +module Range = FStarC.Compiler.Range + +type norm_cb = either Ident.lident term -> term // a callback to the normalizer + +type shadow_term = option (Thunk.t term) + +type embed_t = Range.range -> shadow_term -> norm_cb -> term + +type unembed_t 'a = norm_cb -> option 'a // bool = whether we should warn on a failure + +type raw_embedder 'a = 'a -> embed_t +type raw_unembedder 'a = term -> unembed_t 'a +type printer 'a = 'a -> string + +(* + * Unmbedding functions return an option because they might fail + * to interpret the given term as valid data. The `try_` version will + * simply return None in that case, but the unsafe one will also raise a + * warning, and should be used only where we really expect to always be + * able to unembed. + *) + +val id_norm_cb : norm_cb +exception Embedding_failure +exception Unembedding_failure + +[@@Tactics.Typeclasses.tcclass] +val embedding (a:Type0) : Type0 + +// FIXME: unit to trigger instantiation +val emb_typ_of: a:Type -> {|embedding a|} -> unit -> emb_typ + +val term_as_fv: term -> fv //partial! +val mk_emb : raw_embedder 'a -> raw_unembedder 'a -> fv -> embedding 'a +val mk_emb_full: raw_embedder 'a + -> raw_unembedder 'a + -> (unit -> S.typ) + -> ('a -> string) + -> (unit -> emb_typ) + -> Tot (embedding 'a) + + +(* + * embed: turning a value into a term (compiler internals -> userland) + * unembed: interpreting a term as a value, which can fail (userland -> compiler internals) + * + * Unmbedding functions return an option because they might fail + * to interpret the given term as valid data. The `try_` version will + * simply return None in that case, but the unsafe one will also raise a + * warning, and should be used only where we really expect to always be + * able to unembed. + *) +val embed : {| embedding 'a |} -> 'a -> embed_t +val try_unembed : {| embedding 'a |} -> term -> norm_cb -> option 'a +val unembed : {| embedding 'a |} -> term -> norm_cb -> option 'a + +val type_of : embedding 'a -> S.typ +val printer_of : embedding 'a -> printer 'a +val set_type : S.typ -> embedding 'a -> embedding 'a + +val embed_as : embedding 'a -> + ('a -> 'b) -> + ('b -> 'a) -> + option S.typ -> (* optionally change the type *) + Tot (embedding 'b) + +(* Construct a simple lazy embedding as a blob. *) +val e_lazy : lazy_kind -> + ty:term -> + embedding 'a + + +(* used from Syntax.Embeddings *) +val unmeta_div_results : term -> term + +(* Helpers for extracted embeddings of inductive types. +Do not use internally. *) +val mk_extracted_embedding : + string -> (* name *) + (string & list term -> option 'a) -> (* unembedding specialized to an applied fvar *) + ('a -> term) -> (* embedding *) + embedding 'a +val extracted_embed : + embedding 'a -> + 'a -> + term +val extracted_unembed : + embedding 'a -> + term -> + option 'a diff --git a/src/syntax/FStarC.Syntax.Embeddings.fst b/src/syntax/FStarC.Syntax.Embeddings.fst new file mode 100644 index 00000000000..e3a90fbd00b --- /dev/null +++ b/src/syntax/FStarC.Syntax.Embeddings.fst @@ -0,0 +1,1311 @@ +(* + Copyright 2008-2014 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Syntax.Embeddings + +open FStar open FStarC +open FStarC.Compiler +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Syntax.Syntax +open FStarC.Compiler.Range +open FStarC.VConfig + +open FStarC.Class.Show + +module BU = FStarC.Compiler.Util +module C = FStarC.Const +module Err = FStarC.Errors +module Ident = FStarC.Ident +module PC = FStarC.Parser.Const +module Print = FStarC.Syntax.Print +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module U = FStarC.Syntax.Util +module UF = FStarC.Syntax.Unionfind +module Z = FStarC.BigInt + +open FStarC.Syntax.Embeddings.Base +module AE = FStarC.Syntax.Embeddings.AppEmb + +friend FStar.Pervasives (* To expose norm_step *) + +(********************************************************************* + + A NOTE ON FUNCTIONS AND SHADOW TERMS + +Shadow terms exist to acomodate strong reduction of plugins. + +Suppose we have this function, marked as a plugin to accelerate it +during typechecking: + + [@@plugin] + let sort (l : list int) : list int = ... + +(Plugins are usually tactics, but do not have to be. This discussion +is actually not so relevant for tactics as they do not run in open +contexts.) + +Compilation will generate a version that works on _real_ concrete +lists of integers. To call it on a term, as we have to do during +typechecking, we need to wrap it with embeddings: + + sort_term t = embed_intlist (sort (unembed_intlist t)) + +This turns the term `t` into an actual `list int`, calls the native +sort function, and then reconstructs a term for the resulting list. + +After loading the compiled version of that file, `sort_term` is now +loaded as a primitive step in the normalizer (under the name `sort`, of +course), and will be called everytime we find this symbol applied to an +argument. While its argument must have already been reduced (CBV), there +is no guarantee that it is an actual _value_ as we may be in an open +context, e.g. we may be typechecking this formula: + + forall l. sum (sort l) == sum l + +or it can be applied to some abstract lid even in a closed +context, or to a Tm_let that we are not currently reducing (e.g. DIV), +etc. So, we may fail (and often do) to unembed the argument term +to obtain a concrete list, hence sort_term is closer to: + + sort_term t = match unembed_intlist t with + | None -> None + | Some l -> embed_intlist (sort l) + +But, instead of stopping reduction with the None, we can instead +use the definition of sort itself, and call the normalizer with +the unfolded definition applied to the symbolic argument. Shadow +terms are term representations of whatever the embedded thing is, +which can be defaulted to when the embedding does not work. + +(TODO: what does this do for recursive functions? sounds + like it would not unfold? Actually, it seems broken: + + [@@plugin] + let rec mylen (l : list int) : int = + match l with + | [] -> 0 + | x::xs -> 1 + mylen xs + + let test (a b c : int) = + assert (mylen [a;b;c] == mylen [c;b;a]) by begin + dump "1"; + compute (); + dump "2"; + trefl (); + () + end + +this file works when mylen is not loaded as a plugin, but fails +otherwise since reduction is blocked.) + + +*********************************************************************) + +let id_norm_cb : norm_cb = function + | Inr x -> x + | Inl l -> S.fv_to_tm (S.lid_as_fv l None) +exception Embedding_failure +exception Unembedding_failure + +let map_shadow (s:shadow_term) (f:term -> term) : shadow_term = + BU.map_opt s (Thunk.map f) +let force_shadow (s:shadow_term) = BU.map_opt s Thunk.force + +type printer 'a = 'a -> string + +let unknown_printer (typ:typ) _ = + BU.format1 "unknown %s" (show typ) + +let term_as_fv t = + match (SS.compress t).n with + | Tm_fvar fv -> fv + | _ -> failwith (BU.format1 "Embeddings not defined for type %s" (show t)) + +let lazy_embed (pa:printer 'a) (et:unit -> emb_typ) rng (ta: unit -> term) (x:'a) (f:unit -> term) = + if !Options.debug_embedding + then BU.print3 "Embedding a %s\n\temb_typ=%s\n\tvalue is %s\n" + (show (ta ())) + (show (et ())) + (pa x); + if !Options.eager_embedding + then f() + else let thunk = Thunk.mk f in + U.mk_lazy x S.tun (Lazy_embedding (et (), thunk)) (Some rng) + +let lazy_unembed (pa:printer 'a) (et: unit -> emb_typ) (x:term) (ta: unit -> term) (f:term -> option 'a) : option 'a = + let et = et () in + let x = unmeta_div_results x in + match x.n with + | Tm_lazy {blob=b; lkind=Lazy_embedding (et', t)} -> + if et <> et' + || !Options.eager_embedding + then let res = f (Thunk.force t) in + let _ = if !Options.debug_embedding + then BU.print3 "Unembed cancellation failed\n\t%s <> %s\nvalue is %s\n" + (show et) + (show et') + (match res with None -> "None" | Some x -> "Some " ^ (pa x)) + in + res + else let a = Dyn.undyn b in + let _ = if !Options.debug_embedding + then BU.print2 "Unembed cancelled for %s\n\tvalue is %s\n" + (show et) + (pa a) + in + Some a + | _ -> + let aopt = f x in + let _ = if !Options.debug_embedding + then BU.print3 "Unembedding:\n\temb_typ=%s\n\tterm is %s\n\tvalue is %s\n" + (show et) + (show x) + (match aopt with None -> "None" | Some a -> "Some " ^ pa a) in + aopt + + +let mk_any_emb typ = + let em = fun t _r _shadow _norm -> + if !Options.debug_embedding then + BU.print1 "Embedding abstract: %s\n" (unknown_printer typ t); + t + in + let un = fun t _n -> + if !Options.debug_embedding then + BU.print1 "Unembedding abstract: %s\n" (unknown_printer typ t); + Some t + in + mk_emb_full + em + un + (fun () -> typ) + (unknown_printer typ) + (fun () -> ET_abstract) + +let e_any = + let em = fun t r _shadow _norm -> { t with pos = r} in + let un = fun t _n -> Some t in + mk_emb_full + em + un + (fun () -> S.t_term) // not correct + show + (fun () -> ET_app (PC.term_lid |> Ident.string_of_lid, [])) + +let e_unit = + let em (u:unit) rng _shadow _norm : term = { U.exp_unit with pos = rng } in + let un (t0:term) _norm : option unit = + let t = U.unascribe t0 in + match t.n with + | S.Tm_constant C.Const_unit -> Some () + | _ -> None + in + mk_emb_full + em + un + (fun () -> S.t_unit) + (fun _ -> "()") + (fun () -> ET_app(PC.unit_lid |> Ident.string_of_lid, [])) + +let e_bool = + let em (b:bool) rng _shadow _norm : term = + let t = if b then U.exp_true_bool else U.exp_false_bool in + { t with pos = rng } + in + let un (t:term) _norm : option bool = + match (SS.compress t).n with + | Tm_constant(FStarC.Const.Const_bool b) -> Some b + | _ -> None + in + mk_emb_full + em + un + (fun () -> S.t_bool) + BU.string_of_bool + (fun () -> ET_app(PC.bool_lid |> Ident.string_of_lid, [])) + +let e_char = + let em (c:char) (rng:range) _shadow _norm : term = + let t = U.exp_char c in + { t with pos = rng } + in + let un (t:term) _norm : option char = + match (SS.compress t).n with + | Tm_constant(FStarC.Const.Const_char c) -> Some c + | _ -> None + in + mk_emb_full + em + un + (fun () -> S.t_char) + BU.string_of_char + (fun () -> ET_app(PC.char_lid |> Ident.string_of_lid, [])) + +let e_int = + let ty = S.t_int in + let emb_t_int = ET_app(PC.int_lid |> Ident.string_of_lid, []) in + let em (i:Z.t) (rng:range) _shadow _norm : term = + lazy_embed + BigInt.string_of_big_int + (fun () -> emb_t_int) + rng + (fun () -> ty) + i + (fun () -> U.exp_int (Z.string_of_big_int i)) + in + let un (t:term) _norm : option Z.t = + lazy_unembed + BigInt.string_of_big_int + (fun () -> emb_t_int) + t + (fun () -> ty) + (fun t -> + match t.n with + | Tm_constant(FStarC.Const.Const_int (s, _)) -> Some (Z.big_int_of_string s) + | _ -> None) + in + mk_emb_full + em + un + (fun () -> ty) + BigInt.string_of_big_int + (fun () -> emb_t_int) + +let e_fsint = embed_as e_int Z.to_int_fs Z.of_int_fs None + +let e_string = + let emb_t_string = ET_app(PC.string_lid |> Ident.string_of_lid, []) in + let em (s:string) (rng:range) _shadow _norm : term = + S.mk (Tm_constant(FStarC.Const.Const_string(s, rng))) + rng + in + let un (t:term) _norm : option string = + match (SS.compress t).n with + | Tm_constant(FStarC.Const.Const_string(s, _)) -> Some s + | _ -> None + in + mk_emb_full + em + un + (fun () -> S.t_string) + (fun x -> "\"" ^ x ^ "\"") + (fun () -> emb_t_string) + +let e_real = + let open FStarC.Compiler.Real in + let ty = S.t_real in + let emb_t_real = ET_app(PC.real_lid |> Ident.string_of_lid, []) in + let em (r:real) (rng:range) _shadow _norm : term = + let Real s = r in + mk (Tm_constant (Const.Const_real s)) rng + in + let un (t:term) _norm : option real = + match (unmeta_div_results t).n with + | Tm_constant (Const.Const_real s) -> Some (Real s) + | _ -> None + in + mk_emb_full + em + un + (fun () -> ty) + (fun _ -> "") + (fun () -> emb_t_real) + +let e_option (ea : embedding 'a) : Tot _ = + let typ () = S.t_option_of (type_of ea) in + let emb_t_option_a () = + ET_app(PC.option_lid |> Ident.string_of_lid, [emb_typ_of 'a ()]) + in + let printer x = FStarC.Common.string_of_option (printer_of ea) x in + let em (o:option 'a) (rng:range) shadow norm : term = + lazy_embed + printer + emb_t_option_a + rng + (fun () -> S.t_option_of (type_of ea)) + o + (fun () -> + match o with + | None -> + S.mk_Tm_app (S.mk_Tm_uinst (S.tdataconstr PC.none_lid) [U_zero]) + [S.iarg (type_of ea)] + rng + | Some a -> + let shadow_a = map_shadow shadow (fun t -> + let v = Ident.mk_ident ("v", rng) in + let some_v = U.mk_field_projector_name_from_ident PC.some_lid v in + let some_v_tm = S.fv_to_tm (lid_as_fv some_v None) in + S.mk_Tm_app (S.mk_Tm_uinst some_v_tm [U_zero]) + [S.iarg (type_of ea); S.as_arg t] + rng) + in + S.mk_Tm_app (S.mk_Tm_uinst (S.tdataconstr PC.some_lid) [U_zero]) + [S.iarg (type_of ea); S.as_arg (embed a rng shadow_a norm)] + rng) + in + let un (t:term) norm : option (option 'a) = + lazy_unembed + printer + emb_t_option_a + t + (fun () -> S.t_option_of (type_of ea)) + (fun t -> + let hd, args = U.head_and_args_full t in + match (U.un_uinst hd).n, args with + | Tm_fvar fv, _ when S.fv_eq_lid fv PC.none_lid -> Some None + | Tm_fvar fv, [_; (a, _)] when S.fv_eq_lid fv PC.some_lid -> + BU.bind_opt (try_unembed a norm) (fun a -> Some (Some a)) + | _ -> None) + in + mk_emb_full + em + un + typ + printer + emb_t_option_a + +let e_tuple2 (ea:embedding 'a) (eb:embedding 'b) = + let typ () = S.t_tuple2_of (type_of ea) (type_of eb) in + let emb_t_pair () = + ET_app(PC.lid_tuple2 |> Ident.string_of_lid, [emb_typ_of 'a (); emb_typ_of 'b ()]) + in + let printer (x, y) = + BU.format2 "(%s, %s)" (printer_of ea x) (printer_of eb y) + in + let em (x:('a & 'b)) (rng:range) shadow norm : term = + lazy_embed + printer + emb_t_pair + rng + typ + x + (fun () -> + let proj i ab = + let proj_1 = U.mk_field_projector_name (PC.mk_tuple_data_lid 2 rng) (S.null_bv S.tun) i in + let proj_1_tm = S.fv_to_tm (lid_as_fv proj_1 None) in + S.mk_Tm_app (S.mk_Tm_uinst proj_1_tm [U_zero]) + [S.iarg (type_of ea); + S.iarg (type_of eb); + S.as_arg ab] // ab == shadow + rng + in + let shadow_a = map_shadow shadow (proj 1) in + let shadow_b = map_shadow shadow (proj 2) in + S.mk_Tm_app (S.mk_Tm_uinst (S.tdataconstr PC.lid_Mktuple2) [U_zero;U_zero]) + [S.iarg (type_of ea); + S.iarg (type_of eb); + S.as_arg (embed (fst x) rng shadow_a norm); + S.as_arg (embed (snd x) rng shadow_b norm)] + rng) + in + let un (t:term) norm : option ('a & 'b) = + lazy_unembed + printer + emb_t_pair + t + typ + (fun t -> + let hd, args = U.head_and_args_full t in + match (U.un_uinst hd).n, args with + | Tm_fvar fv, [_; _; (a, _); (b, _)] when S.fv_eq_lid fv PC.lid_Mktuple2 -> + let open FStarC.Class.Monad in + let! a = try_unembed a norm in + let! b = try_unembed b norm in + Some (a, b) + | _ -> None) + in + mk_emb_full + em + un + typ + printer + emb_t_pair + +let e_tuple3 (ea:embedding 'a) (eb:embedding 'b) (ec:embedding 'c) = + let typ () = S.t_tuple3_of (type_of ea) (type_of eb) (type_of ec) in + let emb_t_pair () = + ET_app(PC.lid_tuple3 |> Ident.string_of_lid, [emb_typ_of 'a (); emb_typ_of 'b (); emb_typ_of 'c ()]) + in + let printer (x, y, z) = + BU.format3 "(%s, %s, %s)" (printer_of ea x) (printer_of eb y) (printer_of ec z) + in + let em ((x1, x2, x3):('a & 'b & 'c)) (rng:range) shadow norm : term = + lazy_embed + printer + emb_t_pair + rng + typ + (x1, x2, x3) + (fun () -> + let proj i abc = + let proj_i = U.mk_field_projector_name (PC.mk_tuple_data_lid 3 rng) (S.null_bv S.tun) i in + let proj_i_tm = S.fv_to_tm (lid_as_fv proj_i None) in + S.mk_Tm_app (S.mk_Tm_uinst proj_i_tm [U_zero]) + [S.iarg (type_of ea); + S.iarg (type_of eb); + S.iarg (type_of ec); + S.as_arg abc] // abc == shadow + rng + in + let shadow_a = map_shadow shadow (proj 1) in + let shadow_b = map_shadow shadow (proj 2) in + let shadow_c = map_shadow shadow (proj 3) in + S.mk_Tm_app (S.mk_Tm_uinst (S.tdataconstr PC.lid_Mktuple3) [U_zero;U_zero;U_zero]) + [S.iarg (type_of ea); + S.iarg (type_of eb); + S.iarg (type_of ec); + S.as_arg (embed x1 rng shadow_a norm); + S.as_arg (embed x2 rng shadow_b norm); + S.as_arg (embed x3 rng shadow_c norm)] + rng) + in + let un (t:term) norm : option ('a & 'b & 'c) = + lazy_unembed + printer + emb_t_pair + t + typ + (fun t -> + let hd, args = U.head_and_args_full t in + match (U.un_uinst hd).n, args with + | Tm_fvar fv, [_; _; _; (a, _); (b, _); (c, _)] when S.fv_eq_lid fv PC.lid_Mktuple3 -> + let open FStarC.Class.Monad in + let! a = try_unembed a norm in + let! b = try_unembed b norm in + let! c = try_unembed c norm in + Some (a, b, c) + | _ -> None) + in + mk_emb_full + em + un + typ + printer + emb_t_pair + +let e_tuple4 (ea:embedding 'a) (eb:embedding 'b) (ec:embedding 'c) (ed:embedding 'd) = + let typ () = S.t_tuple4_of (type_of ea) (type_of eb) (type_of ec) (type_of ed) in + let emb_t_pair () = + ET_app(PC.lid_tuple4 |> Ident.string_of_lid, [emb_typ_of 'a (); emb_typ_of 'b (); emb_typ_of 'c (); emb_typ_of 'd ()]) + in + let printer (x, y, z, w) = + BU.format4 "(%s, %s, %s, %s)" (printer_of ea x) (printer_of eb y) (printer_of ec z) (printer_of ed w) + in + let em (x1, x2, x3, x4) (rng:range) shadow norm : term = + lazy_embed + printer + emb_t_pair + rng + typ + (x1, x2, x3, x4) + (fun () -> + let proj i abcd = + let proj_i = U.mk_field_projector_name (PC.mk_tuple_data_lid 4 rng) (S.null_bv S.tun) i in + let proj_i_tm = S.fv_to_tm (lid_as_fv proj_i None) in + S.mk_Tm_app (S.mk_Tm_uinst proj_i_tm [U_zero]) + [S.iarg (type_of ea); + S.iarg (type_of eb); + S.iarg (type_of ec); + S.iarg (type_of ed); + S.as_arg abcd] // abc == shadow + rng + in + let shadow_a = map_shadow shadow (proj 1) in + let shadow_b = map_shadow shadow (proj 2) in + let shadow_c = map_shadow shadow (proj 3) in + let shadow_d = map_shadow shadow (proj 4) in + S.mk_Tm_app (S.mk_Tm_uinst (S.tdataconstr PC.lid_Mktuple4) [U_zero;U_zero;U_zero;U_zero]) + [S.iarg (type_of ea); + S.iarg (type_of eb); + S.iarg (type_of ec); + S.iarg (type_of ed); + S.as_arg (embed x1 rng shadow_a norm); + S.as_arg (embed x2 rng shadow_b norm); + S.as_arg (embed x3 rng shadow_c norm); + S.as_arg (embed x4 rng shadow_d norm)] + rng) + in + let un (t:term) norm : option ('a & 'b & 'c & 'd) = + lazy_unembed + printer + emb_t_pair + t + typ + (fun t -> + let hd, args = U.head_and_args_full t in + match (U.un_uinst hd).n, args with + | Tm_fvar fv, [_; _; _; _; (a, _); (b, _); (c, _); (d, _)] when S.fv_eq_lid fv PC.lid_Mktuple4 -> + let open FStarC.Class.Monad in + let! a = try_unembed a norm in + let! b = try_unembed b norm in + let! c = try_unembed c norm in + let! d = try_unembed d norm in + Some (a, b, c, d) + | _ -> None) + in + mk_emb_full + em + un + typ + printer + emb_t_pair + +let e_tuple5 (ea:embedding 'a) (eb:embedding 'b) (ec:embedding 'c) (ed:embedding 'd) (ee:embedding 'e) = + let typ () = S.t_tuple5_of (type_of ea) (type_of eb) (type_of ec) (type_of ed) (type_of ee) in + let emb_t_pair () = + ET_app(PC.lid_tuple5 |> Ident.string_of_lid, [emb_typ_of 'a (); emb_typ_of 'b (); emb_typ_of 'c (); emb_typ_of 'd (); emb_typ_of 'e ()]) + in + let printer (x, y, z, w, v) = + BU.format5 "(%s, %s, %s, %s, %s)" (printer_of ea x) (printer_of eb y) (printer_of ec z) (printer_of ed w) (printer_of ee v) + in + let em (x1, x2, x3, x4, x5) (rng:range) shadow norm : term = + lazy_embed + printer + emb_t_pair + rng + typ + (x1, x2, x3, x4, x5) + (fun () -> + let proj i abcde = + let proj_i = U.mk_field_projector_name (PC.mk_tuple_data_lid 5 rng) (S.null_bv S.tun) i in + let proj_i_tm = S.fv_to_tm (lid_as_fv proj_i None) in + S.mk_Tm_app (S.mk_Tm_uinst proj_i_tm [U_zero]) + [S.iarg (type_of ea); + S.iarg (type_of eb); + S.iarg (type_of ec); + S.iarg (type_of ed); + S.iarg (type_of ee); + S.as_arg abcde] // abc == shadow + rng + in + let shadow_a = map_shadow shadow (proj 1) in + let shadow_b = map_shadow shadow (proj 2) in + let shadow_c = map_shadow shadow (proj 3) in + let shadow_d = map_shadow shadow (proj 4) in + let shadow_e = map_shadow shadow (proj 5) in + S.mk_Tm_app (S.mk_Tm_uinst (S.tdataconstr PC.lid_Mktuple5) [U_zero;U_zero;U_zero;U_zero;U_zero]) + [S.iarg (type_of ea); + S.iarg (type_of eb); + S.iarg (type_of ec); + S.iarg (type_of ed); + S.iarg (type_of ee); + S.as_arg (embed x1 rng shadow_a norm); + S.as_arg (embed x2 rng shadow_b norm); + S.as_arg (embed x3 rng shadow_c norm); + S.as_arg (embed x4 rng shadow_d norm); + S.as_arg (embed x5 rng shadow_e norm)] + rng) + in + let un (t:term) norm : option ('a & 'b & 'c & 'd & 'e) = + lazy_unembed + printer + emb_t_pair + t + typ + (fun t -> + let hd, args = U.head_and_args_full t in + match (U.un_uinst hd).n, args with + | Tm_fvar fv, [_; _; _; _; _; (a, _); (b, _); (c, _); (d, _); (e, _)] when S.fv_eq_lid fv PC.lid_Mktuple5 -> + let open FStarC.Class.Monad in + let! a = try_unembed a norm in + let! b = try_unembed b norm in + let! c = try_unembed c norm in + let! d = try_unembed d norm in + let! e = try_unembed e norm in + Some (a, b, c, d, e) + | _ -> None) + in + mk_emb_full + em + un + typ + printer + emb_t_pair + +let e_either (ea:embedding 'a) (eb:embedding 'b) = + let typ () = S.t_either_of (type_of ea) (type_of eb) in + let emb_t_sum_a_b () = + ET_app(PC.either_lid |> Ident.string_of_lid, [emb_typ_of 'a (); emb_typ_of 'b ()]) + in + let printer s = + match s with + | Inl a -> BU.format1 "Inl %s" (printer_of ea a) + | Inr b -> BU.format1 "Inr %s" (printer_of eb b) + in + let em (s:either 'a 'b) (rng:range) shadow norm : term = + lazy_embed + printer + emb_t_sum_a_b + rng + typ + s + (* Eagerly compute which closure we want, but thunk the actual embedding *) + (match s with + | Inl a -> + (fun () -> + let shadow_a = map_shadow shadow (fun t -> + let v = Ident.mk_ident ("v", rng) in + let some_v = U.mk_field_projector_name_from_ident PC.inl_lid v in + let some_v_tm = S.fv_to_tm (lid_as_fv some_v None) in + S.mk_Tm_app (S.mk_Tm_uinst some_v_tm [U_zero]) + [S.iarg (type_of ea); S.iarg (type_of eb); S.as_arg t] + rng) + in + S.mk_Tm_app (S.mk_Tm_uinst (S.tdataconstr PC.inl_lid) [U_zero;U_zero]) + [S.iarg (type_of ea); + S.iarg (type_of eb); + S.as_arg (embed a rng shadow_a norm)] + rng) + | Inr b -> + (fun () -> + let shadow_b = map_shadow shadow (fun t -> + let v = Ident.mk_ident ("v", rng) in + let some_v = U.mk_field_projector_name_from_ident PC.inr_lid v in + let some_v_tm = S.fv_to_tm (lid_as_fv some_v None) in + S.mk_Tm_app (S.mk_Tm_uinst some_v_tm [U_zero]) + [S.iarg (type_of ea); S.iarg (type_of eb); S.as_arg t] + rng) + in + S.mk_Tm_app (S.mk_Tm_uinst (S.tdataconstr PC.inr_lid) [U_zero;U_zero]) + [S.iarg (type_of ea); + S.iarg (type_of eb); + S.as_arg (embed b rng shadow_b norm)] + rng) + ) + in + let un (t:term) norm : option (either 'a 'b) = + lazy_unembed + printer + emb_t_sum_a_b + t + typ + (fun t -> + let hd, args = U.head_and_args_full t in + match (U.un_uinst hd).n, args with + | Tm_fvar fv, [_; _; (a, _)] when S.fv_eq_lid fv PC.inl_lid -> + BU.bind_opt (try_unembed a norm) (fun a -> + Some (Inl a)) + | Tm_fvar fv, [_; _; (b, _)] when S.fv_eq_lid fv PC.inr_lid -> + BU.bind_opt (try_unembed b norm) (fun b -> + Some (Inr b)) + | _ -> + None) + in + mk_emb_full + em + un + typ + printer + emb_t_sum_a_b + +let e_list (ea:embedding 'a) = + let typ () = S.t_list_of (type_of ea) in + let emb_t_list_a () = + ET_app(PC.list_lid |> Ident.string_of_lid, [emb_typ_of 'a ()]) + in + let printer = + (fun (l:list 'a) -> "[" ^ (List.map (printer_of ea) l |> String.concat "; ") ^ "]") + in + let rec em (l:list 'a) (rng:range) shadow_l norm : term = + lazy_embed + printer + emb_t_list_a + rng + typ + l + (fun () -> + let t = S.iarg (type_of ea) in + match l with + | [] -> + S.mk_Tm_app (S.mk_Tm_uinst (S.tdataconstr PC.nil_lid) [U_zero]) //NS: the universe here is bogus + [t] + rng + | hd::tl -> + let cons = + S.mk_Tm_uinst (S.tdataconstr PC.cons_lid) [U_zero] + in + let proj f cons_tm = + let fid = Ident.mk_ident (f, rng) in + let proj = U.mk_field_projector_name_from_ident PC.cons_lid fid in + let proj_tm = S.fv_to_tm (lid_as_fv proj None) in + S.mk_Tm_app (S.mk_Tm_uinst proj_tm [U_zero]) + [S.iarg (type_of ea); + S.as_arg cons_tm] + rng + in + let shadow_hd = map_shadow shadow_l (proj "hd") in + let shadow_tl = map_shadow shadow_l (proj "tl") in + S.mk_Tm_app cons + [t; + S.as_arg (embed hd rng shadow_hd norm); + S.as_arg (em tl rng shadow_tl norm)] + rng) + in + let rec un (t:term) norm : option (list 'a) = + lazy_unembed + printer + emb_t_list_a + t + typ + (fun t -> + let hd, args = U.head_and_args_full t in + match (U.un_uinst hd).n, args with + | Tm_fvar fv, _ + when S.fv_eq_lid fv PC.nil_lid -> Some [] + + | Tm_fvar fv, [(_, Some ({aqual_implicit=true})); (hd, None); (tl, None)] + | Tm_fvar fv, [(hd, None); (tl, None)] + when S.fv_eq_lid fv PC.cons_lid -> + BU.bind_opt (try_unembed hd norm) (fun hd -> + BU.bind_opt (un tl norm) (fun tl -> + Some (hd :: tl))) + | _ -> + None) + in + mk_emb_full + em + un + typ + printer + emb_t_list_a + +let e_string_list = e_list e_string + +(* the steps as terms *) +let steps_Simpl = tconst PC.steps_simpl +let steps_Weak = tconst PC.steps_weak +let steps_HNF = tconst PC.steps_hnf +let steps_Primops = tconst PC.steps_primops +let steps_Delta = tconst PC.steps_delta +let steps_Zeta = tconst PC.steps_zeta +let steps_ZetaFull = tconst PC.steps_zeta_full +let steps_Iota = tconst PC.steps_iota +let steps_Reify = tconst PC.steps_reify +let steps_NormDebug = tconst PC.steps_norm_debug +let steps_UnfoldOnly = tconst PC.steps_unfoldonly +let steps_UnfoldFully = tconst PC.steps_unfoldonly +let steps_UnfoldAttr = tconst PC.steps_unfoldattr +let steps_UnfoldQual = tconst PC.steps_unfoldqual +let steps_UnfoldNamespace = tconst PC.steps_unfoldnamespace +let steps_Unascribe = tconst PC.steps_unascribe +let steps_NBE = tconst PC.steps_nbe +let steps_Unmeta = tconst PC.steps_unmeta + +let e_norm_step : embedding Pervasives.norm_step = + let typ () = S.t_norm_step in + let emb_t_norm_step () = ET_app (PC.norm_step_lid |> Ident.string_of_lid, []) in + let printer _ = "norm_step" in + let em (n:Pervasives.norm_step) (rng:range) _shadow norm : term = + lazy_embed + printer + emb_t_norm_step + rng + typ + n + (fun () -> + match n with + | Simpl -> + steps_Simpl + | Weak -> + steps_Weak + | HNF -> + steps_HNF + | Primops -> + steps_Primops + | Delta -> + steps_Delta + | Zeta -> + steps_Zeta + | ZetaFull -> + steps_ZetaFull + | Iota -> + steps_Iota + | Unascribe -> + steps_Unascribe + | NBE -> + steps_NBE + | Unmeta -> + steps_Unmeta + | Reify -> + steps_Reify + | NormDebug -> + steps_NormDebug + | UnfoldOnly l -> + S.mk_Tm_app steps_UnfoldOnly [S.as_arg (embed l rng None norm)] + rng + | UnfoldFully l -> + S.mk_Tm_app steps_UnfoldFully [S.as_arg (embed l rng None norm)] + rng + | UnfoldAttr l -> + S.mk_Tm_app steps_UnfoldAttr [S.as_arg (embed l rng None norm)] + rng + | UnfoldQual l -> + S.mk_Tm_app steps_UnfoldQual [S.as_arg (embed l rng None norm)] + rng + | UnfoldNamespace l -> + S.mk_Tm_app steps_UnfoldNamespace [S.as_arg (embed l rng None norm)] + rng + + + ) + in + let un (t:term) norm : option Pervasives.norm_step = + lazy_unembed + printer + emb_t_norm_step + t + typ + (fun t -> + let hd, args = U.head_and_args t in + match (U.un_uinst hd).n, args with + | Tm_fvar fv, [] when S.fv_eq_lid fv PC.steps_simpl -> + Some Simpl + | Tm_fvar fv, [] when S.fv_eq_lid fv PC.steps_weak -> + Some Weak + | Tm_fvar fv, [] when S.fv_eq_lid fv PC.steps_hnf -> + Some HNF + | Tm_fvar fv, [] when S.fv_eq_lid fv PC.steps_primops -> + Some Primops + | Tm_fvar fv, [] when S.fv_eq_lid fv PC.steps_delta -> + Some Delta + | Tm_fvar fv, [] when S.fv_eq_lid fv PC.steps_zeta -> + Some Zeta + | Tm_fvar fv, [] when S.fv_eq_lid fv PC.steps_zeta_full -> + Some ZetaFull + | Tm_fvar fv, [] when S.fv_eq_lid fv PC.steps_iota -> + Some Iota + | Tm_fvar fv, [] when S.fv_eq_lid fv PC.steps_unascribe -> + Some Unascribe + | Tm_fvar fv, [] when S.fv_eq_lid fv PC.steps_nbe -> + Some NBE + | Tm_fvar fv, [] when S.fv_eq_lid fv PC.steps_unmeta -> + Some Unmeta + | Tm_fvar fv, [] when S.fv_eq_lid fv PC.steps_reify -> + Some Reify + | Tm_fvar fv, [] when S.fv_eq_lid fv PC.steps_norm_debug -> + Some NormDebug + | Tm_fvar fv, [(l, _)] when S.fv_eq_lid fv PC.steps_unfoldonly -> + BU.bind_opt (try_unembed l norm) (fun ss -> + Some <| UnfoldOnly ss) + | Tm_fvar fv, [(l, _)] when S.fv_eq_lid fv PC.steps_unfoldfully -> + BU.bind_opt (try_unembed l norm) (fun ss -> + Some <| UnfoldFully ss) + | Tm_fvar fv, [(l, _)] when S.fv_eq_lid fv PC.steps_unfoldattr -> + BU.bind_opt (try_unembed l norm) (fun ss -> + Some <| UnfoldAttr ss) + | Tm_fvar fv, [(l, _)] when S.fv_eq_lid fv PC.steps_unfoldqual -> + BU.bind_opt (try_unembed l norm) (fun ss -> + Some <| UnfoldQual ss) + | Tm_fvar fv, [(l, _)] when S.fv_eq_lid fv PC.steps_unfoldnamespace -> + BU.bind_opt (try_unembed l norm) (fun ss -> + Some <| UnfoldNamespace ss) + | _ -> None) + in + mk_emb_full + em + un + typ + printer + emb_t_norm_step + +let e_vconfig = + let em (vcfg:vconfig) (rng:Range.range) _shadow norm : term = + (* The order is very important here, even if this is a record. *) + S.mk_Tm_app (tdataconstr PC.mkvconfig_lid) // TODO: should this be a record constructor? does it matter? + [S.as_arg (embed vcfg.initial_fuel rng None norm); + S.as_arg (embed vcfg.max_fuel rng None norm); + S.as_arg (embed vcfg.initial_ifuel rng None norm); + S.as_arg (embed vcfg.max_ifuel rng None norm); + S.as_arg (embed vcfg.detail_errors rng None norm); + S.as_arg (embed vcfg.detail_hint_replay rng None norm); + S.as_arg (embed vcfg.no_smt rng None norm); + S.as_arg (embed vcfg.quake_lo rng None norm); + S.as_arg (embed vcfg.quake_hi rng None norm); + S.as_arg (embed vcfg.quake_keep rng None norm); + S.as_arg (embed vcfg.retry rng None norm); + S.as_arg (embed vcfg.smtencoding_elim_box rng None norm); + S.as_arg (embed vcfg.smtencoding_nl_arith_repr rng None norm); + S.as_arg (embed vcfg.smtencoding_l_arith_repr rng None norm); + S.as_arg (embed vcfg.smtencoding_valid_intro rng None norm); + S.as_arg (embed vcfg.smtencoding_valid_elim rng None norm); + S.as_arg (embed vcfg.tcnorm rng None norm); + S.as_arg (embed vcfg.no_plugins rng None norm); + S.as_arg (embed vcfg.no_tactics rng None norm); + S.as_arg (embed vcfg.z3cliopt rng None norm); + S.as_arg (embed vcfg.z3smtopt rng None norm); + S.as_arg (embed vcfg.z3refresh rng None norm); + S.as_arg (embed vcfg.z3rlimit rng None norm); + S.as_arg (embed vcfg.z3rlimit_factor rng None norm); + S.as_arg (embed vcfg.z3seed rng None norm); + S.as_arg (embed vcfg.z3version rng None norm); + S.as_arg (embed vcfg.trivial_pre_for_unannotated_effectful_fns rng None norm); + S.as_arg (embed vcfg.reuse_hint_for rng None norm); + ] + rng + in + let un (t:term) norm : option vconfig = + let hd, args = U.head_and_args t in + match (U.un_uinst hd).n, args with + (* Sigh *) + | Tm_fvar fv, [ + (initial_fuel, _); + (max_fuel, _); + (initial_ifuel, _); + (max_ifuel, _); + (detail_errors, _); + (detail_hint_replay, _); + (no_smt, _); + (quake_lo, _); + (quake_hi, _); + (quake_keep, _); + (retry, _); + (smtencoding_elim_box, _); + (smtencoding_nl_arith_repr, _); + (smtencoding_l_arith_repr, _); + (smtencoding_valid_intro, _); + (smtencoding_valid_elim, _); + (tcnorm, _); + (no_plugins, _); + (no_tactics, _); + (z3cliopt, _); + (z3smtopt, _); + (z3refresh, _); + (z3rlimit, _); + (z3rlimit_factor, _); + (z3seed, _); + (z3version, _); + (trivial_pre_for_unannotated_effectful_fns, _); + (reuse_hint_for, _) + ] when S.fv_eq_lid fv PC.mkvconfig_lid -> + BU.bind_opt (try_unembed initial_fuel norm) (fun initial_fuel -> + BU.bind_opt (try_unembed max_fuel norm) (fun max_fuel -> + BU.bind_opt (try_unembed initial_ifuel norm) (fun initial_ifuel -> + BU.bind_opt (try_unembed max_ifuel norm) (fun max_ifuel -> + BU.bind_opt (try_unembed detail_errors norm) (fun detail_errors -> + BU.bind_opt (try_unembed detail_hint_replay norm) (fun detail_hint_replay -> + BU.bind_opt (try_unembed no_smt norm) (fun no_smt -> + BU.bind_opt (try_unembed quake_lo norm) (fun quake_lo -> + BU.bind_opt (try_unembed quake_hi norm) (fun quake_hi -> + BU.bind_opt (try_unembed quake_keep norm) (fun quake_keep -> + BU.bind_opt (try_unembed retry norm) (fun retry -> + BU.bind_opt (try_unembed smtencoding_elim_box norm) (fun smtencoding_elim_box -> + BU.bind_opt (try_unembed smtencoding_nl_arith_repr norm) (fun smtencoding_nl_arith_repr -> + BU.bind_opt (try_unembed smtencoding_l_arith_repr norm) (fun smtencoding_l_arith_repr -> + BU.bind_opt (try_unembed smtencoding_valid_intro norm) (fun smtencoding_valid_intro -> + BU.bind_opt (try_unembed smtencoding_valid_elim norm) (fun smtencoding_valid_elim -> + BU.bind_opt (try_unembed tcnorm norm) (fun tcnorm -> + BU.bind_opt (try_unembed no_plugins norm) (fun no_plugins -> + BU.bind_opt (try_unembed no_tactics norm) (fun no_tactics -> + BU.bind_opt (try_unembed z3cliopt norm) (fun z3cliopt -> + BU.bind_opt (try_unembed z3smtopt norm) (fun z3smtopt -> + BU.bind_opt (try_unembed z3refresh norm) (fun z3refresh -> + BU.bind_opt (try_unembed z3rlimit norm) (fun z3rlimit -> + BU.bind_opt (try_unembed z3rlimit_factor norm) (fun z3rlimit_factor -> + BU.bind_opt (try_unembed z3seed norm) (fun z3seed -> + BU.bind_opt (try_unembed z3version norm) (fun z3version -> + BU.bind_opt (try_unembed trivial_pre_for_unannotated_effectful_fns norm) (fun trivial_pre_for_unannotated_effectful_fns -> + BU.bind_opt (try_unembed reuse_hint_for norm) (fun reuse_hint_for -> + Some ({ + initial_fuel = initial_fuel; + max_fuel = max_fuel; + initial_ifuel = initial_ifuel; + max_ifuel = max_ifuel; + detail_errors = detail_errors; + detail_hint_replay = detail_hint_replay; + no_smt = no_smt; + quake_lo = quake_lo; + quake_hi = quake_hi; + quake_keep = quake_keep; + retry = retry; + smtencoding_elim_box = smtencoding_elim_box; + smtencoding_nl_arith_repr = smtencoding_nl_arith_repr; + smtencoding_l_arith_repr = smtencoding_l_arith_repr; + smtencoding_valid_intro = smtencoding_valid_intro; + smtencoding_valid_elim = smtencoding_valid_elim; + tcnorm = tcnorm; + no_plugins = no_plugins; + no_tactics = no_tactics; + z3cliopt = z3cliopt; + z3smtopt = z3smtopt; + z3refresh = z3refresh; + z3rlimit = z3rlimit; + z3rlimit_factor = z3rlimit_factor; + z3seed = z3seed; + z3version = z3version; + trivial_pre_for_unannotated_effectful_fns = trivial_pre_for_unannotated_effectful_fns; + reuse_hint_for = reuse_hint_for; + }))))))))))))))))))))))))))))) + | _ -> + None + in + mk_emb_full + em + un + (fun () -> S.t_vconfig) + (fun _ -> "vconfig") + (fun () -> ET_app (PC.vconfig_lid |> Ident.string_of_lid, [])) + +let e_order = + let open FStar.Order in + let ord_Lt_lid = Ident.lid_of_path (["FStar"; "Order"; "Lt"]) Range.dummyRange in + let ord_Eq_lid = Ident.lid_of_path (["FStar"; "Order"; "Eq"]) Range.dummyRange in + let ord_Gt_lid = Ident.lid_of_path (["FStar"; "Order"; "Gt"]) Range.dummyRange in + let ord_Lt = tdataconstr ord_Lt_lid in + let ord_Eq = tdataconstr ord_Eq_lid in + let ord_Gt = tdataconstr ord_Gt_lid in + let ord_Lt_fv = lid_as_fv ord_Lt_lid (Some Data_ctor) in + let ord_Eq_fv = lid_as_fv ord_Eq_lid (Some Data_ctor) in + let ord_Gt_fv = lid_as_fv ord_Gt_lid (Some Data_ctor) in + let embed_order (o:order) rng shadow cb : term = + let r = + match o with + | Lt -> ord_Lt + | Eq -> ord_Eq + | Gt -> ord_Gt + in { r with pos = rng } + in + let unembed_order (t:term) cb : option order = + let t = U.unascribe t in + let hd, args = U.head_and_args t in + match (U.un_uinst hd).n, args with + | Tm_fvar fv, [] when S.fv_eq_lid fv ord_Lt_lid -> Some Lt + | Tm_fvar fv, [] when S.fv_eq_lid fv ord_Eq_lid -> Some Eq + | Tm_fvar fv, [] when S.fv_eq_lid fv ord_Gt_lid -> Some Gt + | _ -> + None + in + mk_emb embed_order unembed_order (lid_as_fv PC.order_lid None) + +let or_else (f: option 'a) (g:unit -> 'a) = + match f with + | Some x -> x + | None -> g () + +let e_arrow (ea:embedding 'a) (eb:embedding 'b) : Tot (embedding ('a -> 'b)) = + let typ () = + S.mk (Tm_arrow {bs=[S.mk_binder (S.null_bv (type_of ea))]; + comp=S.mk_Total (type_of eb)}) + Range.dummyRange + in + let emb_t_arr_a_b () = ET_fun(emb_typ_of 'a (), emb_typ_of 'b ()) in + let printer (f:'a -> 'b) = "" in + let em (f:'a -> 'b) rng shadow_f norm = + // let f_wrapped (x:term) = + // let shadow_app = map_shadow shadow_f (fun f -> + // S.mk_Tm_app f [S.as_arg x] None rng) + // in + // or_else + // (BU.map_opt (unembed ea x true norm) (fun x -> + // embed eb (f x) rng shadow_app norm)) + // (fun () -> + // match force_shadow shadow_app with + // | None -> raise Embedding_failure + // | Some app -> norm (BU.Inr app)) + // in + lazy_embed + printer + emb_t_arr_a_b + rng + typ + f //f_wrapped + (fun () -> + match force_shadow shadow_f with + | None -> raise Embedding_failure //TODO: dodgy + | Some repr_f -> + if !Options.debug_embedding then + BU.print2 "e_arrow forced back to term using shadow %s; repr=%s\n" + (show repr_f) + (BU.stack_dump()); + let res = norm (Inr repr_f) in + if !Options.debug_embedding then + BU.print3 "e_arrow forced back to term using shadow %s; repr=%s\n\t%s\n" + (show repr_f) + (show res) + (BU.stack_dump()); + res) + in + let un (f:term) norm : option ('a -> 'b) = + lazy_unembed + printer + emb_t_arr_a_b + f + typ + (fun f -> + let f_wrapped (a:'a) : 'b = + if !Options.debug_embedding then + BU.print2 "Calling back into normalizer for %s\n%s\n" + (show f) + (BU.stack_dump()); + let a_tm = embed a f.pos None norm in + let b_tm = norm (Inr (S.mk_Tm_app f [S.as_arg a_tm] f.pos)) in + match unembed b_tm norm with + | None -> raise Unembedding_failure + | Some b -> b + in + Some f_wrapped) + in + mk_emb_full + em + un + typ + printer + emb_t_arr_a_b + +let e_sealed (ea : embedding 'a) : Tot (embedding (Sealed.sealed 'a)) = + let typ () = S.t_sealed_of (type_of ea) in + let emb_ty_a () = + ET_app(PC.sealed_lid |> Ident.string_of_lid, [emb_typ_of 'a ()]) + in + let printer x = "(seal " ^ printer_of ea (Sealed.unseal x) ^ ")" in + let em (a:Sealed.sealed 'a) (rng:range) shadow norm : term = + let shadow_a = + (* TODO: this application below is in TAC.. OK? *) + map_shadow shadow (fun t -> + let unseal = U.fvar_const PC.unseal_lid in + S.mk_Tm_app (S.mk_Tm_uinst unseal [U_zero]) + [S.iarg (type_of ea); S.as_arg t] + rng) + in + S.mk_Tm_app (S.mk_Tm_uinst (U.fvar_const PC.seal_lid) [U_zero]) + [S.iarg (type_of ea); S.as_arg (embed (Sealed.unseal a) rng shadow_a norm)] + rng + in + let un (t:term) norm : option (Sealed.sealed 'a) = + let hd, args = U.head_and_args_full t in + match (U.un_uinst hd).n, args with + | Tm_fvar fv, [_; (a, _)] when S.fv_eq_lid fv PC.seal_lid -> + // Just relay it + Class.Monad.fmap Sealed.seal <| try_unembed a norm + | _ -> + None + in + mk_emb_full + em + un + typ + printer + emb_ty_a + +(* + * Embed a range as a FStar.Range.__range + * The user usually manipulates a FStar.Range.range = sealed __range + * For embedding an actual FStar.Range.range, we compose this (automatically + * via typeclass resolution) with e_sealed. + *) +let e___range = + let em (r:range) (rng:range) _shadow _norm : term = + S.mk (Tm_constant (C.Const_range r)) rng + in + let un (t:term) _norm : option range = + match (SS.compress t).n with + | Tm_constant (C.Const_range r) -> Some r + | _ -> None + in + mk_emb_full + em + un + (fun () -> S.t___range) + Range.string_of_range + (fun () -> ET_app (PC.range_lid |> Ident.string_of_lid, [])) + +(* This is an odd one. We embed ranges as sealed, but we don't want to use the Sealed.sealed +type internally, so we "hack" it like this. *) +let e_range : embedding Range.range = + embed_as (e_sealed e___range) Sealed.unseal Sealed.seal None + +let e_issue : embedding Err.issue = e_lazy Lazy_issue (S.fvar PC.issue_lid None) +let e_document : embedding Pprint.document = e_lazy Lazy_doc (S.fvar PC.document_lid None) + + ///////////////////////////////////////////////////////////////////// + //Registering top-level functions + ///////////////////////////////////////////////////////////////////// + +let arrow_as_prim_step_1 (ea:embedding 'a) (eb:embedding 'b) + (f:'a -> 'b) (fv_lid:Ident.lid) norm + : universes -> args -> option term = + let rng = Ident.range_of_lid fv_lid in + let f_wrapped _us args = + //arity mismatches are handled by the caller + let [(x, _)] = args in + let shadow_app = + Some (Thunk.mk (fun () -> S.mk_Tm_app (norm (Inl fv_lid)) args rng)) + in + match + (BU.map_opt (try_unembed x norm) (fun x -> + embed (f x) rng shadow_app norm)) + with + // NB: this always returns a Some + | Some x -> Some x + | None -> force_shadow shadow_app + in + f_wrapped + +let arrow_as_prim_step_2 (ea:embedding 'a) (eb:embedding 'b) (ec:embedding 'c) + (f:'a -> 'b -> 'c) fv_lid norm + : universes -> args -> option term = + let rng = Ident.range_of_lid fv_lid in + let f_wrapped _us args = + //arity mismatches are handled by the caller + let [(x, _); (y, _)] = args in + let shadow_app = + Some (Thunk.mk (fun () -> S.mk_Tm_app (norm (Inl fv_lid)) args rng)) + in + match + (BU.bind_opt (try_unembed x norm) (fun x -> + BU.bind_opt (try_unembed y norm) (fun y -> + Some (embed (f x y) rng shadow_app norm)))) + with + // NB: this always returns a Some + | Some x -> Some x + | None -> force_shadow shadow_app + in + f_wrapped + +let arrow_as_prim_step_3 (ea:embedding 'a) (eb:embedding 'b) + (ec:embedding 'c) (ed:embedding 'd) + (f:'a -> 'b -> 'c -> 'd) fv_lid norm + : universes -> args -> option term = + let rng = Ident.range_of_lid fv_lid in + let f_wrapped _us args = + //arity mismatches are handled by the caller + let [(x, _); (y, _); (z, _)] = args in + let shadow_app = + Some (Thunk.mk (fun () -> S.mk_Tm_app (norm (Inl fv_lid)) args rng)) + in + match + (BU.bind_opt (try_unembed x norm) (fun x -> + BU.bind_opt (try_unembed y norm) (fun y -> + BU.bind_opt (try_unembed z norm) (fun z -> + Some (embed (f x y z) rng shadow_app norm))))) + with + // NB: this always returns a Some + | Some x -> Some x + | None -> force_shadow shadow_app + in + f_wrapped + +let debug_wrap (s:string) (f:unit -> 'a) = + if !Options.debug_embedding + then BU.print1 "++++starting %s\n" s; + let res = f () in + if !Options.debug_embedding + then BU.print1 "------ending %s\n" s; + res + +instance e_abstract_term : embedding abstract_term = + embed_as e_any (fun x -> Abstract x) (fun x -> match x with Abstract x -> x) None diff --git a/src/syntax/FStarC.Syntax.Embeddings.fsti b/src/syntax/FStarC.Syntax.Embeddings.fsti new file mode 100644 index 00000000000..b1c13049f8e --- /dev/null +++ b/src/syntax/FStarC.Syntax.Embeddings.fsti @@ -0,0 +1,98 @@ +(* + Copyright 2008-2014 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Syntax.Embeddings + +open FStar open FStarC +open FStarC.Compiler +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Syntax.Syntax +open FStar.Char +open FStarC.VConfig + +include FStarC.Syntax.Embeddings.Base + +module Range = FStarC.Compiler.Range +module Z = FStarC.BigInt +module BU = FStarC.Compiler.Util + +(* Embeddings, both ways and containing type information *) +val e_any : embedding term +// An identity. Not an instance as sometimes +// we make different choices for embedding a term + +instance val e_unit : embedding unit +instance val e_bool : embedding bool +instance val e_char : embedding char +instance val e_int : embedding Z.t +instance val e_fsint : embedding int +instance val e_string : embedding string +instance val e_real : embedding Compiler.Real.real +instance val e_norm_step : embedding Pervasives.norm_step +instance val e_vconfig : embedding FStarC.VConfig.vconfig +instance val e_order : embedding FStar.Order.order + +instance val e_option : embedding 'a -> Tot (embedding (option 'a)) +instance val e_list : embedding 'a -> Tot (embedding (list 'a)) +instance val e_tuple2 : embedding 'a -> embedding 'b -> Tot (embedding ('a & 'b)) +instance val e_tuple3 : embedding 'a -> embedding 'b -> embedding 'c -> Tot (embedding ('a & 'b & 'c)) +instance val e_tuple4 : embedding 'a -> embedding 'b -> embedding 'c -> embedding 'd -> Tot (embedding ('a & 'b & 'c & 'd)) +instance val e_tuple5 : embedding 'a -> embedding 'b -> embedding 'c -> embedding 'd -> embedding 'e -> Tot (embedding ('a & 'b & 'c & 'd & 'e)) +instance val e_either : embedding 'a -> embedding 'b -> Tot (embedding (either 'a 'b)) +instance val e_string_list : embedding (list string) +val e_arrow : embedding 'a -> embedding 'b -> Tot (embedding ('a -> 'b)) +instance val e_sealed : embedding 'a -> Tot (embedding (Sealed.sealed 'a)) + +val e___range : embedding Range.range (* unsealed *) +instance val e_range : embedding Range.range (* sealed *) +instance val e_document : embedding FStarC.Pprint.document +instance val e_issue : embedding FStarC.Errors.issue + +type abstract_term = | Abstract : t:term -> abstract_term +instance val e_abstract_term : embedding abstract_term + +val mk_any_emb : typ -> embedding term + +(* Arity specific raw_embeddings of arrows; used to generate top-level + registrations of compiled functions in FStarC.Extraction.ML.Util + + See also FStarC.TypeChecker.NBETerm.fsi *) +val arrow_as_prim_step_1: embedding 'a + -> embedding 'b + -> ('a -> 'b) + -> repr_f:Ident.lid + -> norm_cb + -> (universes -> args -> option term) + +val arrow_as_prim_step_2: embedding 'a + -> embedding 'b + -> embedding 'c + -> ('a -> 'b -> 'c) + -> repr_f:Ident.lid + -> norm_cb + -> (universes -> args -> option term) + +val arrow_as_prim_step_3: embedding 'a + -> embedding 'b + -> embedding 'c + -> embedding 'd + -> ('a -> 'b -> 'c -> 'd) + -> repr_f:Ident.lid + -> norm_cb + -> (universes -> args -> option term) + +val debug_wrap : string -> (unit -> 'a) -> 'a diff --git a/src/syntax/FStarC.Syntax.Formula.fst b/src/syntax/FStarC.Syntax.Formula.fst new file mode 100644 index 00000000000..452b64ee0ca --- /dev/null +++ b/src/syntax/FStarC.Syntax.Formula.fst @@ -0,0 +1,203 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Syntax.Formula + +open Prims +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Ident +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.Syntax.Print + +module BU = FStarC.Compiler.Util +module PC = FStarC.Parser.Const +module U = FStarC.Syntax.Util +module SS = FStarC.Syntax.Subst + +open FStarC.Class.Show +open FStarC.Class.Monad + +let connective_to_string c = + match c with + | QAll p -> "QAll " ^ show p + | QEx p -> "QEx " ^ show p + | BaseConn p -> "BaseConn" ^ show p + +instance showable_connective = { + show = connective_to_string; +} + +(* destruct_typ_as_formula can be hot; these tables are defined + here to ensure they are constructed only once in the executing + binary + + the tables encode arity -> match_lid -> output_lid + *) +let destruct_base_table = let f x = (x,x) in [ + (0, [f PC.true_lid; f PC.false_lid]); + (1, [f PC.not_lid]); + (2, [f PC.and_lid; f PC.or_lid; f PC.imp_lid; f PC.iff_lid; f PC.eq2_lid]); + (3, [f PC.ite_lid; f PC.eq2_lid]); +] + +let destruct_sq_base_table = [ + (0, [(PC.c_true_lid, PC.true_lid); (PC.empty_type_lid, PC.false_lid)]); + (2, [(PC.c_and_lid, PC.and_lid); + (PC.c_or_lid, PC.or_lid); + (PC.c_eq2_lid, PC.eq2_lid)]); + (3, [(PC.c_eq2_lid, PC.eq2_lid)]); +] + +let rec unmeta_monadic f = + let f = Subst.compress f in + match f.n with + | Tm_meta {tm=t; meta=Meta_monadic _} + | Tm_meta {tm=t; meta=Meta_monadic_lift _} -> unmeta_monadic t + | _ -> f + +let lookup_arity_lid table target_lid args = + let arg_len : int = List.length args in + let aux (arity, lids) = + if arg_len = arity + then BU.find_map lids + (fun (lid, out_lid) -> + if lid_equals target_lid lid + then Some (BaseConn (out_lid, args)) + else None) + else None + in + BU.find_map table aux + +let destruct_base_conn t = + let hd, args = U.head_and_args t in + match (U.un_uinst hd).n with + | Tm_fvar fv -> lookup_arity_lid destruct_base_table fv.fv_name.v args + | _ -> None + +let destruct_sq_base_conn t = + let! t = U.un_squash t in + let t = U.unmeta t in + let hd, args = U.head_and_args_full t in + match (U.un_uinst hd).n with + | Tm_fvar fv -> lookup_arity_lid destruct_sq_base_table fv.fv_name.v args + | _ -> None + +let patterns t = + let t = SS.compress t in + match t.n with + | Tm_meta {tm=t; meta=Meta_pattern (_, pats)} -> pats, SS.compress t + | _ -> [], t + +let destruct_q_conn t = + let is_q (fa:bool) (fv:fv) : bool = + if fa + then U.is_forall fv.fv_name.v + else U.is_exists fv.fv_name.v + in + let flat t = + let t, args = U.head_and_args t in + U.un_uinst t, args |> List.map (fun (t, imp) -> U.unascribe t, imp) + in + let rec aux qopt out t = match qopt, flat t with + | Some fa, ({n=Tm_fvar tc}, [({n=Tm_abs {bs=[b]; body=t2}}, _)]) + | Some fa, ({n=Tm_fvar tc}, [_; ({n=Tm_abs {bs=[b]; body=t2}}, _)]) + when (is_q fa tc) -> + aux qopt (b::out) t2 + + | None, ({n=Tm_fvar tc}, [({n=Tm_abs {bs=[b]; body=t2}}, _)]) + | None, ({n=Tm_fvar tc}, [_; ({n=Tm_abs {bs=[b]; body=t2}}, _)]) + when (U.is_qlid tc.fv_name.v) -> + aux (Some (U.is_forall tc.fv_name.v)) (b::out) t2 + + | Some b, _ -> + let bs = List.rev out in + let bs, t = Subst.open_term bs t in + let pats, body = patterns t in + if b + then Some (QAll(bs, pats, body)) + else Some (QEx(bs, pats, body)) + + | _ -> None in + aux None [] t + +let rec destruct_sq_forall t = + let! t = U.un_squash t in + let t = U.unmeta t in + match U.arrow_one t with + | Some (b, c) -> + if not (U.is_tot_or_gtot_comp c) + then None + else + let q = U.comp_result c in + if U.is_free_in b.binder_bv q + then ( + let pats, q = patterns q in + maybe_collect <| Some (QAll([b], pats, q)) + ) else ( + // Since we know it's not free, we can just open and discard the binder + Some (BaseConn (PC.imp_lid, [as_arg b.binder_bv.sort; as_arg q])) + ) + | _ -> None +and destruct_sq_exists t = + let! t = U.un_squash t in + let t = U.unmeta t in + let hd, args = U.head_and_args_full t in + match (U.un_uinst hd).n, args with + | Tm_fvar fv, [(a1, _); (a2, _)] + when fv_eq_lid fv PC.dtuple2_lid -> + begin match (SS.compress a2).n with + | Tm_abs {bs=[b]; body=q} -> + let bs, q = SS.open_term [b] q in + let b = match bs with // coverage... + | [b] -> b + | _ -> failwith "impossible" + in + let pats, q = patterns q in + maybe_collect <| Some (QEx ([b], pats, q)) + | _ -> None + end + | _ -> None +and maybe_collect f = + match f with + | Some (QAll (bs, pats, phi)) -> + begin match destruct_sq_forall phi with + | Some (QAll (bs', pats', psi)) -> Some <| QAll(bs@bs', pats@pats', psi) + | _ -> f + end + | Some (QEx (bs, pats, phi)) -> + begin match destruct_sq_exists phi with + | Some (QEx (bs', pats', psi)) -> Some <| QEx(bs@bs', pats@pats', psi) + | _ -> f + end + | _ -> f + +let destruct_typ_as_formula f : option connective = + let phi = unmeta_monadic f in + let r = + // Try all possibilities, stopping at the first + BU.catch_opt (destruct_base_conn phi) (fun () -> + BU.catch_opt (destruct_q_conn phi) (fun () -> + BU.catch_opt (destruct_sq_base_conn phi) (fun () -> + BU.catch_opt (destruct_sq_forall phi) (fun () -> + BU.catch_opt (destruct_sq_exists phi) (fun () -> + None))))) + in + r diff --git a/src/syntax/FStarC.Syntax.Formula.fsti b/src/syntax/FStarC.Syntax.Formula.fsti new file mode 100644 index 00000000000..d4860e3f187 --- /dev/null +++ b/src/syntax/FStarC.Syntax.Formula.fsti @@ -0,0 +1,35 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Syntax.Formula + +open FStarC.Compiler.Effect +open FStarC.Ident +open FStarC.Syntax.Syntax +open FStarC.Class.Show + +(**************************************************************************************) +(* Destructing a type as a formula *) +(**************************************************************************************) + +type qpats = list args +type connective = + | QAll of binders & qpats & typ + | QEx of binders & qpats & typ + | BaseConn of lident & args + +instance val showable_connective : showable connective + +val destruct_typ_as_formula (f:term) : option connective diff --git a/src/syntax/FStarC.Syntax.Free.fst b/src/syntax/FStarC.Syntax.Free.fst new file mode 100644 index 00000000000..a63daf253ef --- /dev/null +++ b/src/syntax/FStarC.Syntax.Free.fst @@ -0,0 +1,324 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Syntax.Free +open Prims +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.Syntax +open FStarC.Syntax.Syntax +module Util = FStarC.Compiler.Util +module UF = FStarC.Syntax.Unionfind + +open FStarC.Class.Ord +open FStarC.Class.Show +open FStarC.Class.Setlike + +let compare_uv uv1 uv2 = UF.uvar_id uv1.ctx_uvar_head - UF.uvar_id uv2.ctx_uvar_head +let compare_universe_uvar x y = UF.univ_uvar_id x - UF.univ_uvar_id y + +instance deq_ctx_uvar : deq ctx_uvar = { + (=?) = (fun u v -> UF.uvar_id u.ctx_uvar_head =? UF.uvar_id v.ctx_uvar_head); +} +instance ord_ctx_uvar : ord ctx_uvar = { + super = Tactics.Typeclasses.solve; + cmp = (fun u v -> UF.uvar_id u.ctx_uvar_head `cmp` UF.uvar_id v.ctx_uvar_head); +} +instance deq_univ_uvar : deq universe_uvar = { + (=?) = (fun u v -> UF.univ_uvar_id u =? UF.univ_uvar_id v); +} +instance ord_univ_uvar : ord universe_uvar = { + super = Tactics.Typeclasses.solve; + cmp = (fun u v -> UF.univ_uvar_id u `cmp` UF.univ_uvar_id v); +} + +let ctx_uvar_typ (u:ctx_uvar) = + (UF.find_decoration u.ctx_uvar_head).uvar_decoration_typ + + +(********************************************************************************) +(************************* Free names and unif variables ************************) +(********************************************************************************) + +type use_cache_t = + | Def + | NoCache + | Full + +(* We use an RBSet for the fvars, as order definitely does not matter here +and it's faster. *) +type free_vars_and_fvars = free_vars & RBSet.t Ident.lident + +(* Snoc without duplicates *) +val snoc : #a:Type -> {| deq a |} -> list a -> a -> list a +let rec snoc xx y = + match xx with + | [] -> [y] + | x::xx' -> if x =? y then xx + else x :: snoc xx' y + +(* Concatenation without duplicates *) +val (@@) : #a:Type -> {| deq a |} -> list a -> list a -> list a +let (@@) xs ys = List.fold_left (fun xs y -> snoc xs y) xs ys + +let no_free_vars : free_vars_and_fvars = { + free_names = empty(); + free_uvars = empty(); + free_univs = empty(); + free_univ_names = empty(); +}, empty () + +let singleton_fvar fv : free_vars_and_fvars = + fst no_free_vars, + add fv.fv_name.v (empty ()) + +let singleton_bv x = + {fst no_free_vars with free_names = singleton x}, snd no_free_vars +let singleton_uv x = + {fst no_free_vars with free_uvars = singleton x}, snd no_free_vars +let singleton_univ x = + {fst no_free_vars with free_univs = singleton x}, snd no_free_vars +let singleton_univ_name x = + {fst no_free_vars with free_univ_names = singleton x}, snd no_free_vars + +(* Union of free vars *) +let ( ++ ) (f1 : free_vars_and_fvars) (f2 : free_vars_and_fvars) = { + free_names=(fst f1).free_names `union` (fst f2).free_names; + free_uvars=(fst f1).free_uvars `union` (fst f2).free_uvars; + free_univs=(fst f1).free_univs `union` (fst f2).free_univs; + free_univ_names=(fst f1).free_univ_names `union` (fst f2).free_univ_names; //THE ORDER HERE IS IMPORTANT! + //We expect the free_univ_names list to be in fifo order to get the right order of universe generalization +}, union (snd f1) (snd f2) + +let rec free_univs u = match Subst.compress_univ u with + | U_zero + | U_bvar _ + | U_unknown -> no_free_vars + | U_name uname -> singleton_univ_name uname + | U_succ u -> free_univs u + | U_max us -> List.fold_left (fun out x -> out ++ free_univs x) no_free_vars us + | U_unif u -> singleton_univ u + +//the interface of Syntax.Free now supports getting fvars in a term also +//however, fvars are added unlike free names, free uvars, etc. which are part of a record free_vars, that is memoized at **every** AST node +//if we added fvars also to the record, it would affect every AST node +//instead of doing that, the functions below compute a tuple, free_vars * set lident, where the second component is the fvars lids +//but this raises a compilication, what should happen when the functions below just return from the cache from the AST nodes +//to handle that, use_cache flag is UNSET when asking for free_fvars, so that all the terms are traversed completely +//on the other hand, for earlier interface use_cache is true +//this flag is propagated, and is used in the function should_invalidate_cache below +let rec free_names_and_uvs' tm (use_cache:use_cache_t) : free_vars_and_fvars = + let aux_binders (bs : binders) (from_body : free_vars_and_fvars) = + let from_binders = free_names_and_uvars_binders bs use_cache in + from_binders ++ from_body + in + let t = Subst.compress tm in + match t.n with + | Tm_delayed _ -> failwith "Impossible" + + | Tm_name x -> + singleton_bv x + + | Tm_uvar (uv, (s, _)) -> + singleton_uv uv ++ + (if use_cache = Full + then free_names_and_uvars (ctx_uvar_typ uv) use_cache + else no_free_vars) + + | Tm_type u -> + free_univs u + + | Tm_bvar _ -> no_free_vars + | Tm_fvar fv -> singleton_fvar fv + + | Tm_constant _ + | Tm_lazy _ + | Tm_unknown -> + no_free_vars + + | Tm_uinst(t, us) -> + let f = free_names_and_uvars t use_cache in + List.fold_left (fun out u -> out ++ free_univs u) f us + + | Tm_abs {bs; body=t; rc_opt=ropt} -> + aux_binders bs (free_names_and_uvars t use_cache) ++ + (match ropt with + | Some { residual_typ = Some t } -> free_names_and_uvars t use_cache + | _ -> no_free_vars) + + | Tm_arrow {bs; comp=c} -> + aux_binders bs (free_names_and_uvars_comp c use_cache) + + | Tm_refine {b=bv; phi=t} -> + aux_binders [mk_binder bv] (free_names_and_uvars t use_cache) + + | Tm_app {hd=t; args} -> + free_names_and_uvars_args args (free_names_and_uvars t use_cache) use_cache + + | Tm_match {scrutinee=t; ret_opt=asc_opt; brs=pats; rc_opt} -> + (match rc_opt with + | Some { residual_typ = Some t } -> free_names_and_uvars t use_cache + | _ -> no_free_vars) ++ + begin + pats |> List.fold_left (fun n (p, wopt, t) -> + let n1 = match wopt with + | None -> no_free_vars + | Some w -> free_names_and_uvars w use_cache + in + let n2 = free_names_and_uvars t use_cache in + let n = + pat_bvs p |> List.fold_left (fun n x -> n ++ free_names_and_uvars x.sort use_cache) n + in + n ++ n1 ++ n2) + (free_names_and_uvars t use_cache + ++ (match asc_opt with + | None -> no_free_vars + | Some (b, asc) -> + free_names_and_uvars_binders [b] use_cache ++ + free_names_and_uvars_ascription asc use_cache)) + end + + | Tm_ascribed {tm=t1; asc} -> + free_names_and_uvars t1 use_cache ++ + free_names_and_uvars_ascription asc use_cache + + | Tm_let {lbs; body=t} -> + snd lbs |> List.fold_left (fun n lb -> + n ++ + free_names_and_uvars lb.lbtyp use_cache ++ + free_names_and_uvars lb.lbdef use_cache) + (free_names_and_uvars t use_cache) + + | Tm_quoted (tm, qi) -> + begin match qi.qkind with + | Quote_static -> List.fold_left (fun n t -> n ++ free_names_and_uvars t use_cache) no_free_vars (snd qi.antiquotations) + | Quote_dynamic -> free_names_and_uvars tm use_cache + end + + | Tm_meta {tm=t; meta=m} -> + let u1 = free_names_and_uvars t use_cache in + begin match m with + | Meta_pattern (_, args) -> + List.fold_right (fun a acc -> free_names_and_uvars_args a acc use_cache) args u1 + + | Meta_monadic(_, t') -> + u1 ++ free_names_and_uvars t' use_cache + + | Meta_monadic_lift(_, _, t') -> + u1 ++ free_names_and_uvars t' use_cache + + | Meta_labeled _ + | Meta_desugared _ + | Meta_named _ -> u1 + end + + +and free_names_and_uvars_binders bs use_cache = + bs |> List.fold_left (fun n b -> + n ++ free_names_and_uvars b.binder_bv.sort use_cache) no_free_vars + + +and free_names_and_uvars_ascription asc use_cache = + let asc, tacopt, _ = asc in + (match asc with + | Inl t -> free_names_and_uvars t use_cache + | Inr c -> free_names_and_uvars_comp c use_cache) ++ + (match tacopt with + | None -> no_free_vars + | Some tac -> free_names_and_uvars tac use_cache) + +and free_names_and_uvars t use_cache = + let t = Subst.compress t in + match !t.vars with + | Some n when not (should_invalidate_cache n use_cache) -> n, empty () + | _ -> + t.vars := None; + let n = free_names_and_uvs' t use_cache in + if use_cache <> Full then t.vars := Some (fst n); + n + +and free_names_and_uvars_args args (acc : free_vars_and_fvars) use_cache = + args |> List.fold_left (fun n (x, _) -> n ++ (free_names_and_uvars x use_cache)) acc + +and free_names_and_uvars_comp c use_cache = + match !c.vars with + | Some n -> + if should_invalidate_cache n use_cache + then (c.vars := None; free_names_and_uvars_comp c use_cache) + else n, empty () + | _ -> + let n = match c.n with + | GTotal t + | Total t -> + free_names_and_uvars t use_cache + + | Comp ct -> + //collect from the decreases clause + let decreases_vars = + match List.tryFind (function DECREASES _ -> true | _ -> false) ct.flags with + | None -> no_free_vars + | Some (DECREASES dec_order) -> + free_names_and_uvars_dec_order dec_order use_cache + in + //decreases clause + return type + let us = free_names_and_uvars ct.result_typ use_cache ++ decreases_vars in + //decreases clause + return type + effect args + let us = free_names_and_uvars_args ct.effect_args us use_cache in + //decreases clause + return type + effect args + comp_univs + List.fold_left (fun us u -> us ++ free_univs u) us ct.comp_univs + in + c.vars := Some (fst n); + n + +and free_names_and_uvars_dec_order dec_order use_cache = + match dec_order with + | Decreases_lex l -> + l |> List.fold_left (fun acc t -> acc ++ free_names_and_uvars t use_cache) no_free_vars + | Decreases_wf (rel, e) -> + free_names_and_uvars rel use_cache ++ + free_names_and_uvars e use_cache + +and should_invalidate_cache n use_cache = + (use_cache <> Def) || + (n.free_uvars |> for_any (fun u -> + match UF.find u.ctx_uvar_head with + | Some _ -> true + | _ -> false)) || + (n.free_univs |> for_any (fun u -> + match UF.univ_find u with + | Some _ -> true + | None -> false)) + +//note use_cache is set false ONLY for fvars, which is not maintained at each AST node +//see the comment above + +let names t = (fst (free_names_and_uvars t Def)).free_names +let uvars t = (fst (free_names_and_uvars t Def)).free_uvars +let univs t = (fst (free_names_and_uvars t Def)).free_univs + +let univnames t = (fst (free_names_and_uvars t Def)).free_univ_names +let univnames_comp c = (fst (free_names_and_uvars_comp c Def)).free_univ_names + +let fvars t = snd (free_names_and_uvars t NoCache) +let names_of_binders (bs:binders) = + ((fst (free_names_and_uvars_binders bs Def)).free_names) + +let uvars_uncached t = (fst (free_names_and_uvars t NoCache)).free_uvars +let uvars_full t = (fst (free_names_and_uvars t Full)).free_uvars diff --git a/src/syntax/FStarC.Syntax.Free.fsti b/src/syntax/FStarC.Syntax.Free.fsti new file mode 100644 index 00000000000..2ecd0934308 --- /dev/null +++ b/src/syntax/FStarC.Syntax.Free.fsti @@ -0,0 +1,43 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Syntax.Free +open FStarC.Compiler.Effect +open Prims +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.Compiler.FlatSet +open FStarC.Syntax +open FStarC.Syntax.Syntax + +val names : term -> FlatSet.t bv +val names_of_binders : binders -> FlatSet.t bv + +val fvars : term -> RBSet.t Ident.lident + +val uvars : term -> FlatSet.t ctx_uvar +val uvars_uncached : term -> FlatSet.t ctx_uvar +val uvars_full : term -> FlatSet.t ctx_uvar + +val univs : term -> FlatSet.t universe_uvar + +val univnames : term -> FlatSet.t univ_name +val univnames_comp : comp -> FlatSet.t univ_name + +(* Bad place for these instances. But they cannot be instance +Syntax.Syntax since they reference the UF graph. *) +instance val ord_ctx_uvar : Class.Ord.ord ctx_uvar +instance val ord_univ_uvar : Class.Ord.ord universe_uvar diff --git a/src/syntax/FStarC.Syntax.Hash.fst b/src/syntax/FStarC.Syntax.Hash.fst new file mode 100644 index 00000000000..f30b387de46 --- /dev/null +++ b/src/syntax/FStarC.Syntax.Hash.fst @@ -0,0 +1,614 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or impliedmk_ + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Syntax.Hash +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.Util +open FStarC.Syntax.Syntax +open FStarC.Const +module SS = FStarC.Syntax.Subst +module UU = FStarC.Syntax.Unionfind +module BU = FStarC.Compiler.Util + +(* maybe memo *) +let mm (t:Type) = bool -> t & bool + +let (let?) (f:mm 't) (g: 't -> mm 's) : mm 's = + fun b -> + let t, b = f b in + g t b + +let ret (x:'t) : mm 't = fun b -> x, b + +let should_memo : mm bool = fun b -> b, b + +let no_memo : mm unit = fun _ -> (), false + +module H = FStarC.Hash + +let maybe_memoize (h:syntax 'a) (f:syntax 'a -> mm H.hash_code) : mm H.hash_code = + fun should_memo -> + if should_memo + then ( + match !h.hash_code with + | Some c -> c, should_memo + | None -> + let c, should_memo = f h should_memo in + if should_memo + then h.hash_code := Some c; + c, should_memo + ) + else f h should_memo + +let of_int (i:int) : mm H.hash_code = ret (H.of_int i) + +let of_string (s:string) : mm H.hash_code = ret (H.of_string s) + +let mix (f:mm H.hash_code) (g:mm H.hash_code) : mm H.hash_code = + fun b -> let x, b0 = f b in + let y, b1 = g b in + H.mix x y, b0 && b1 + +let nil_hc : mm H.hash_code = of_int 1229 +let cons_hc : mm H.hash_code = of_int 1231 + +let mix_list (l:list (mm H.hash_code)) : mm H.hash_code = + List.fold_right mix l nil_hc + +let mix_list_lit = mix_list + +let hash_list (h:'a -> mm H.hash_code) (ts:list 'a) : mm H.hash_code = mix_list (List.map h ts) + +let hash_option (h:'a -> mm H.hash_code) (o:option 'a) : mm H.hash_code = + match o with + | None -> ret (H.of_int 1237) + | Some o -> mix (ret (H.of_int 1249)) (h o) + +// hash the string. +let hash_doc (d : Pprint.document) : mm H.hash_code = + of_string (Pprint.pretty_string (float_of_string "1.0") 80 d) + +let hash_doc_list (ds : list Pprint.document) : mm H.hash_code = + hash_list hash_doc ds + +let hash_pair (h:'a -> mm H.hash_code) (i:'b -> mm H.hash_code) (x:('a & 'b)) + : mm H.hash_code + = mix (h (fst x)) (i (snd x)) + +let rec hash_term (t:term) + : mm H.hash_code + = maybe_memoize t hash_term' + +and hash_comp c + : mm H.hash_code + = maybe_memoize c hash_comp' + +and hash_term' (t:term) + : mm H.hash_code + = // if Debug.any () + // then FStarC.Compiler.Util.print1 "Hash_term %s\n" (FStarC.Syntax.show t); + match (SS.compress t).n with + | Tm_bvar bv -> mix (of_int 3) (of_int bv.index) + | Tm_name bv -> mix (of_int 5) (of_int bv.index) + | Tm_fvar fv -> mix (of_int 7) (hash_fv fv) + | Tm_uinst(t, us) -> mix (of_int 11) + (mix (hash_term t) + (hash_list hash_universe us)) + | Tm_constant sc -> mix (of_int 13) (hash_constant sc) + | Tm_type u -> mix (of_int 17) (hash_universe u) + | Tm_abs {bs; body=t; rc_opt=rcopt} -> mix (of_int 19) + (mix (hash_list hash_binder bs) + (mix (hash_term t) + (hash_option hash_rc rcopt))) + | Tm_arrow {bs; comp=c} -> mix (of_int 23) (mix (hash_list hash_binder bs) (hash_comp c)) + | Tm_refine {b; phi=t} -> mix (of_int 29) (mix (hash_bv b) (hash_term t)) + | Tm_app {hd=t; args} -> mix (of_int 31) (mix (hash_term t) (hash_list hash_arg args)) + | Tm_match {scrutinee=t; ret_opt=asc_opt; brs=branches; rc_opt=rcopt} -> + mix (of_int 37) + (mix (hash_option hash_match_returns asc_opt) + (mix (mix (hash_term t) (hash_list hash_branch branches)) + (hash_option hash_rc rcopt))) + | Tm_ascribed {tm=t; asc=a; eff_opt=lopt} -> mix (of_int 43) (mix (hash_term t) (mix (hash_ascription a) (hash_option hash_lid lopt))) + | Tm_let {lbs=(false, [lb]); body=t} -> mix (of_int 47) (mix (hash_lb lb) (hash_term t)) + | Tm_let {lbs=(_, lbs); body=t} -> mix (of_int 51) (mix (hash_list hash_lb lbs) (hash_term t)) + | Tm_uvar uv -> mix (of_int 53) (hash_uvar uv) + | Tm_meta {tm=t; meta=m} -> mix (of_int 61) (mix (hash_term t) (hash_meta m)) + | Tm_lazy li -> mix (of_int 67) (hash_lazyinfo li) + | Tm_quoted (t, qi) -> mix (of_int 71) (mix (hash_term t) (hash_quoteinfo qi)) + | Tm_unknown -> of_int 73 + | Tm_delayed _ -> failwith "Impossible" + +and hash_comp' (c:comp) + : mm H.hash_code + = match c.n with + | Total t -> + mix_list_lit + [of_int 811; + hash_term t] + | GTotal t -> + mix_list_lit + [of_int 821; + hash_term t] + | Comp ct -> + mix_list_lit + [of_int 823; + hash_list hash_universe ct.comp_univs; + hash_lid ct.effect_name; + hash_term ct.result_typ; + hash_list hash_arg ct.effect_args; + hash_list hash_flag ct.flags] + +and hash_lb lb = + mix_list_lit + [ of_int 79; + hash_lbname lb.lbname; + hash_list hash_ident lb.lbunivs; + hash_term lb.lbtyp; + hash_lid lb.lbeff; + hash_term lb.lbdef; + hash_list hash_term lb.lbattrs] + +and hash_match_returns (b, asc) = + mix (hash_binder b) + (hash_ascription asc) + +and hash_branch b = + let p, topt, t = b in + mix_list_lit + [of_int 83; + hash_pat p; + hash_option hash_term topt; + hash_term t] + +and hash_pat p = + match p.v with + | Pat_constant c -> mix (of_int 89) (hash_constant c) + | Pat_cons(fv, us, args) -> + mix_list_lit + [of_int 97; + hash_fv fv; + hash_option (hash_list hash_universe) us; + hash_list (hash_pair hash_pat hash_bool) args] + | Pat_var bv -> mix (of_int 101) (hash_bv bv) + | Pat_dot_term t -> mix_list_lit [of_int 107; hash_option hash_term t] + + +and hash_bv b = hash_term b.sort +and hash_fv fv = of_string (Ident.string_of_lid fv.fv_name.v) +and hash_binder (b:binder) = + mix_list_lit + [hash_bv b.binder_bv; + hash_option hash_bqual b.binder_qual; + hash_list hash_term b.binder_attrs] + +and hash_universe = + function + | U_zero -> of_int 179 + | U_succ u -> mix (of_int 181) (hash_universe u) + | U_max us -> mix (of_int 191) (hash_list hash_universe us) + | U_bvar i -> mix (of_int 193) (of_int i) + | U_name i -> mix (of_int 197) (hash_ident i) + | U_unif uv -> mix (of_int 199) (hash_universe_uvar uv) + | U_unknown -> of_int 211 + +and hash_arg (t, aq) = + mix (hash_term t) (hash_option hash_arg_qualifier aq) + +and hash_arg_qualifier aq = + mix (hash_bool aq.aqual_implicit) + (hash_list hash_term aq.aqual_attributes) + +and hash_bqual = + function + | Implicit true -> of_int 419 + | Implicit false -> of_int 421 + | Meta t -> mix (of_int 431) (hash_term t) + | Equality -> of_int 433 + +and hash_uvar (u, _) = of_int (UU.uvar_id u.ctx_uvar_head) + +and hash_universe_uvar u = of_int (UU.univ_uvar_id u) + +and hash_ascription (a, to, b) = + mix + (match a with + | Inl t -> hash_term t + | Inr c -> hash_comp c) + (hash_option hash_term to) + +and hash_bool b = + if b then of_int 307 + else of_int 311 + +and hash_constant = + function + | Const_effect -> of_int 283 + | Const_unit -> of_int 293 + | Const_bool b -> hash_bool b + | Const_int (s, o) -> mix (of_int 313) + (mix (of_string s) + (hash_option hash_sw o)) + | Const_char c -> mix (of_int 317) (of_int (FStar.Char.int_of_char c)) + | Const_real s -> mix (of_int 337) (of_string s) + | Const_string (s, _) -> mix (of_int 349) (of_string s) + | Const_range_of -> of_int 353 + | Const_set_range_of -> of_int 359 + | Const_range r -> mix (of_int 367) (of_string (Range.string_of_range r)) + | Const_reify _ -> of_int 367 + | Const_reflect l -> mix (of_int 373) (hash_lid l) + +and hash_sw (s, w) = + mix + (match s with + | Unsigned -> of_int 547 + | Signed -> of_int 557) + (match w with + | Int8 -> of_int 563 + | Int16 -> of_int 569 + | Int32 -> of_int 571 + | Int64 -> of_int 577 + | Sizet -> of_int 583) + +and hash_ident i = of_string (Ident.string_of_id i) +and hash_lid l = of_string (Ident.string_of_lid l) +and hash_lbname l = + match l with + | Inl bv -> hash_bv bv + | Inr fv -> hash_fv fv +and hash_rc rc = + mix_list_lit + [ hash_lid rc.residual_effect; + hash_option hash_term rc.residual_typ; + hash_list hash_flag rc.residual_flags ] + +and hash_flag = + function + | TOTAL -> of_int 947 + | MLEFFECT -> of_int 953 + | LEMMA -> of_int 967 + | RETURN -> of_int 971 + | PARTIAL_RETURN -> of_int 977 + | SOMETRIVIAL -> of_int 983 + | TRIVIAL_POSTCONDITION -> of_int 991 + | SHOULD_NOT_INLINE -> of_int 997 + | CPS -> of_int 1009 + | DECREASES (Decreases_lex ts) -> mix (of_int 1013) (hash_list hash_term ts) + | DECREASES (Decreases_wf (t0, t1)) -> mix (of_int 2341) (hash_list hash_term [t0;t1]) + +and hash_meta m = + match m with + | Meta_pattern (ts, args) -> + mix_list_lit + [ of_int 1019; + hash_list hash_term ts; + hash_list (hash_list hash_arg) args ] + | Meta_named l -> + mix_list_lit + [ of_int 1021; + hash_lid l ] + | Meta_labeled (s, r, _) -> + mix_list_lit + [ of_int 1031; + hash_doc_list s; + of_string (Range.string_of_range r) ] + | Meta_desugared msi -> + mix_list_lit + [ of_int 1033; + hash_meta_source_info msi ] + | Meta_monadic(m, t) -> + mix_list_lit + [ of_int 1039; + hash_lid m; + hash_term t ] + | Meta_monadic_lift (m0, m1, t) -> + mix_list_lit + [of_int 1069; + hash_lid m0; + hash_lid m1; + hash_term t] + +and hash_meta_source_info m = + match m with + | Sequence -> of_int 1049 + | Primop -> of_int 1051 + | Masked_effect -> of_int 1061 + | Meta_smt_pat -> of_int 1063 + | Machine_integer sw -> mix (of_int 1069) (hash_sw sw) + +and hash_lazyinfo li = of_int 0 //no meaningful way to hash the blob + +and hash_quoteinfo qi = + mix + (hash_bool (qi.qkind = Quote_static)) + (hash_list hash_term (snd qi.antiquotations)) + +//////////////////////////////////////////////////////////////////////////////// +let rec equal_list f l1 l2 = + match l1, l2 with + | [], [] -> true + | h1::t1, h2::t2 -> f h1 h2 && equal_list f t1 t2 + | _ -> false + +let equal_opt f o1 o2 = + match o1, o2 with + | None, None -> true + | Some a, Some b -> f a b + | _ -> false + +let equal_pair f g (x1, y1) (x2, y2) = f x1 x2 && g y1 y2 + +let equal_poly x y = x=y + +let ext_hash_term (t:term) = fst (hash_term t true) +let ext_hash_term_no_memo (t:term) = fst (hash_term t false) + +let rec equal_term (t1 t2:term) + : bool + = if physical_equality t1 t2 then true else + if physical_equality t1.n t2.n then true else + if ext_hash_term t1 <> ext_hash_term t2 then false else + match (SS.compress t1).n, (SS.compress t2).n with + | Tm_bvar x, Tm_bvar y -> x.index = y.index + | Tm_name x, Tm_name y -> x.index = y.index + | Tm_fvar f, Tm_fvar g -> equal_fv f g + | Tm_uinst (t1, u1), Tm_uinst (t2, u2) -> + equal_term t1 t2 && + equal_list equal_universe u1 u2 + | Tm_constant c1, Tm_constant c2 -> equal_constant c1 c2 + | Tm_type u1, Tm_type u2 -> equal_universe u1 u2 + | Tm_abs {bs=bs1; body=t1; rc_opt=rc1}, Tm_abs {bs=bs2; body=t2; rc_opt=rc2} -> + equal_list equal_binder bs1 bs2 && + equal_term t1 t2 && + equal_opt equal_rc rc1 rc2 + | Tm_arrow {bs=bs1; comp=c1}, Tm_arrow {bs=bs2; comp=c2} -> + equal_list equal_binder bs1 bs2 && + equal_comp c1 c2 + | Tm_refine {b=b1; phi=t1}, Tm_refine {b=b2; phi=t2} -> + equal_bv b1 b2 && + equal_term t1 t2 + | Tm_app {hd=t1; args=as1}, Tm_app {hd=t2; args=as2} -> + equal_term t1 t2 && + equal_list equal_arg as1 as2 + | Tm_match {scrutinee=t1; ret_opt=asc_opt1; brs=bs1; rc_opt=ropt1}, + Tm_match {scrutinee=t2; ret_opt=asc_opt2; brs=bs2; rc_opt=ropt2} -> + equal_term t1 t2 && + equal_opt equal_match_returns asc_opt1 asc_opt2 && + equal_list equal_branch bs1 bs2 && + equal_opt equal_rc ropt1 ropt2 + | Tm_ascribed {tm=t1; asc=a1; eff_opt=l1}, + Tm_ascribed {tm=t2; asc=a2; eff_opt=l2} -> + equal_term t1 t2 && + equal_ascription a1 a2 && + equal_opt Ident.lid_equals l1 l2 + | Tm_let {lbs=(r1, lbs1); body=t1}, Tm_let {lbs=(r2, lbs2); body=t2} -> + r1 = r2 && + equal_list equal_letbinding lbs1 lbs2 && + equal_term t1 t2 + | Tm_uvar u1, Tm_uvar u2 -> + equal_uvar u1 u2 + | Tm_meta {tm=t1; meta=m1}, Tm_meta {tm=t2; meta=m2} -> + equal_term t1 t2 && + equal_meta m1 m2 + | Tm_lazy l1, Tm_lazy l2 -> + equal_lazyinfo l1 l2 + | Tm_quoted (t1, q1), Tm_quoted (t2, q2) -> + equal_term t1 t2 && + equal_quoteinfo q1 q2 + | Tm_unknown, Tm_unknown -> + true + | _ -> false + +and equal_comp c1 c2 = + if physical_equality c1 c2 then true else + match c1.n, c2.n with + | Total t1, Total t2 + | GTotal t1, GTotal t2 -> + equal_term t1 t2 + | Comp ct1, Comp ct2 -> + Ident.lid_equals ct1.effect_name ct2.effect_name && + equal_list equal_universe ct1.comp_univs ct2.comp_univs && + equal_term ct1.result_typ ct2.result_typ && + equal_list equal_arg ct1.effect_args ct2.effect_args && + equal_list equal_flag ct1.flags ct2.flags + +and equal_binder b1 b2 = + if physical_equality b1 b2 then true else + equal_bv b1.binder_bv b2.binder_bv && + equal_bqual b1.binder_qual b2.binder_qual && + equal_list equal_term b1.binder_attrs b2.binder_attrs + +and equal_match_returns (b1, asc1) (b2, asc2) = + equal_binder b1 b2 && + equal_ascription asc1 asc2 + +and equal_ascription x1 x2 = + if physical_equality x1 x2 then true else + let a1, t1, b1 = x1 in + let a2, t2, b2 = x2 in + (match a1, a2 with + | Inl t1, Inl t2 -> equal_term t1 t2 + | Inr c1, Inr c2 -> equal_comp c1 c2 + | _ -> false) && + equal_opt equal_term t1 t2 && + b1 = b2 + +and equal_letbinding l1 l2 = + if physical_equality l1 l2 then true else + equal_lbname l1.lbname l2.lbname && + equal_list Ident.ident_equals l1.lbunivs l2.lbunivs && + equal_term l1.lbtyp l2.lbtyp && + Ident.lid_equals l1.lbeff l2.lbeff && + equal_term l1.lbdef l2.lbdef && + equal_list equal_term l1.lbattrs l2.lbattrs + +and equal_uvar (u1, (s1, _)) (u2, (s2, _)) = + UU.equiv u1.ctx_uvar_head u2.ctx_uvar_head && + equal_list (equal_list equal_subst_elt) s1 s2 + +and equal_bv b1 b2 = + if physical_equality b1 b2 then true else + Ident.ident_equals b1.ppname b2.ppname && + equal_term b1.sort b2.sort + +and equal_fv f1 f2 = + if physical_equality f1 f2 then true else + Ident.lid_equals f1.fv_name.v f2.fv_name.v + +and equal_universe u1 u2 = + if physical_equality u1 u2 then true else + match (SS.compress_univ u1), (SS.compress_univ u2) with + | U_zero, U_zero -> true + | U_succ u1, U_succ u2 -> equal_universe u1 u2 + | U_max us1, U_max us2 -> equal_list equal_universe us1 us2 + | U_bvar i1, U_bvar i2 -> i1 = i2 + | U_name x1, U_name x2 -> Ident.ident_equals x1 x2 + | U_unif u1, U_unif u2 -> UU.univ_equiv u1 u2 + | U_unknown, U_unknown -> true + | _ -> false + +and equal_constant c1 c2 = + if physical_equality c1 c2 then true else + match c1, c2 with + | Const_effect, Const_effect + | Const_unit, Const_unit -> true + | Const_bool b1, Const_bool b2 -> b1 = b2 + | Const_int (s1, o1), Const_int(s2, o2) -> s1=s2 && o1=o2 + | Const_char c1, Const_char c2 -> c1=c2 + | Const_real s1, Const_real s2 -> s1=s2 + | Const_string (s1, _), Const_string (s2, _) -> s1=s2 + | Const_range_of, Const_range_of + | Const_set_range_of, Const_set_range_of -> true + | Const_range r1, Const_range r2 -> Range.compare r1 r2 = 0 + | Const_reify _, Const_reify _ -> true + | Const_reflect l1, Const_reflect l2 -> Ident.lid_equals l1 l2 + | _ -> false + +and equal_arg arg1 arg2 = + if physical_equality arg1 arg2 then true else + let t1, a1 = arg1 in + let t2, a2 = arg2 in + equal_term t1 t2 && + equal_opt equal_arg_qualifier a1 a2 + +and equal_bqual b1 b2 = + equal_opt equal_binder_qualifier b1 b2 + +and equal_binder_qualifier b1 b2 = + match b1, b2 with + | Implicit b1, Implicit b2 -> b1 = b2 + | Equality, Equality -> true + | Meta t1, Meta t2 -> equal_term t1 t2 + | _ -> false + +and equal_branch (p1, w1, t1) (p2, w2, t2) = + equal_pat p1 p2 && + equal_opt equal_term w1 w2 && + equal_term t1 t2 + +and equal_pat p1 p2 = + if physical_equality p1 p2 then true else + match p1.v, p2.v with + | Pat_constant c1, Pat_constant c2 -> + equal_constant c1 c2 + | Pat_cons(fv1, us1, args1), Pat_cons(fv2, us2, args2) -> + equal_fv fv1 fv2 && + equal_opt (equal_list equal_universe) us1 us2 && + equal_list (equal_pair equal_pat equal_poly) args1 args2 + | Pat_var bv1, Pat_var bv2 -> + equal_bv bv1 bv2 + | Pat_dot_term t1, Pat_dot_term t2 -> + equal_opt equal_term t1 t2 + | _ -> false + +and equal_meta m1 m2 = + match m1, m2 with + | Meta_pattern (ts1, args1), Meta_pattern (ts2, args2) -> + equal_list equal_term ts1 ts2 && + equal_list (equal_list equal_arg) args1 args2 + | Meta_named l1, Meta_named l2 -> + Ident.lid_equals l1 l2 + | Meta_labeled (s1, r1, _), Meta_labeled (s2, r2, _) -> + s1 = s2 && + Range.compare r1 r2 = 0 + | Meta_desugared msi1, Meta_desugared msi2 -> + msi1 = msi2 + | Meta_monadic(m1, t1), Meta_monadic(m2, t2) -> + Ident.lid_equals m1 m2 && + equal_term t1 t2 + | Meta_monadic_lift (m1, n1, t1), Meta_monadic_lift (m2, n2, t2) -> + Ident.lid_equals m1 m2 && + Ident.lid_equals n1 n2 && + equal_term t1 t2 + +and equal_lazyinfo l1 l2 = + (* We cannot really compare the blobs. Just try physical + equality (first matching kinds). *) + l1.lkind = l1.lkind && BU.physical_equality l1.blob l2.blob + +and equal_quoteinfo q1 q2 = + q1.qkind = q2.qkind && + (fst q1.antiquotations) = (fst q2.antiquotations) && + equal_list equal_term (snd q1.antiquotations) (snd q2.antiquotations) + +and equal_rc r1 r2 = + Ident.lid_equals r1.residual_effect r2.residual_effect && + equal_opt equal_term r1.residual_typ r2.residual_typ && + equal_list equal_flag r1.residual_flags r2.residual_flags + +and equal_flag f1 f2 = + match f1, f2 with + | DECREASES t1, DECREASES t2 -> + equal_decreases_order t1 t2 + + | _ -> f1 = f2 + +and equal_decreases_order d1 d2 = + match d1, d2 with + | Decreases_lex ts1, Decreases_lex ts2 -> + equal_list equal_term ts1 ts2 + + | Decreases_wf (t1, t1'), Decreases_wf (t2, t2') -> + equal_term t1 t2 && + equal_term t1' t2' + +and equal_arg_qualifier a1 a2 = + a1.aqual_implicit = a2.aqual_implicit && + equal_list equal_term a1.aqual_attributes a2.aqual_attributes + +and equal_lbname l1 l2 = + match l1, l2 with + | Inl b1, Inl b2 -> Ident.ident_equals b1.ppname b2.ppname + | Inr f1, Inr f2 -> Ident.lid_equals f1.fv_name.v f2.fv_name.v + +and equal_subst_elt s1 s2 = + match s1, s2 with + | DB (i1, bv1), DB(i2, bv2) + | NM (bv1, i1), NM (bv2, i2) -> + i1=i2 && equal_bv bv1 bv2 + | NT (bv1, t1), NT (bv2, t2) -> + equal_bv bv1 bv2 && + equal_term t1 t2 + | UN (i1, u1), UN (i2, u2) -> + i1 = i2 && + equal_universe u1 u2 + | UD (un1, i1), UD (un2, i2) -> + i1 = i2 && + Ident.ident_equals un1 un2 + +instance hashable_term : hashable term = { + hash = ext_hash_term; +} diff --git a/src/syntax/FStarC.Syntax.Hash.fsti b/src/syntax/FStarC.Syntax.Hash.fsti new file mode 100644 index 00000000000..db196cd92be --- /dev/null +++ b/src/syntax/FStarC.Syntax.Hash.fsti @@ -0,0 +1,33 @@ +(* + Copyright 2022 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or impliedmk_ + See the License for the specific language governing permissions and + limitations under the License. + + Author: N. Swamy +*) +module FStarC.Syntax.Hash +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.Util +open FStarC.Syntax.Syntax +open FStarC.Const +module H = FStarC.Hash +open FStarC.Class.Hashable + +val ext_hash_term (t:term) : H.hash_code +val ext_hash_term_no_memo (t:term) : H.hash_code +val equal_term (t0 t1:term) : bool + +(* uses ext_hash_term (with memo) *) +instance val hashable_term : hashable term diff --git a/src/syntax/FStarC.Syntax.InstFV.fst b/src/syntax/FStarC.Syntax.InstFV.fst new file mode 100644 index 00000000000..d4464a577b3 --- /dev/null +++ b/src/syntax/FStarC.Syntax.InstFV.fst @@ -0,0 +1,148 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Syntax.InstFV +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Syntax.Syntax +open FStarC.Ident +open FStarC.Compiler.Util +open FStarC.Compiler + +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module U = FStarC.Compiler.Util + +let mk t s = S.mk s t.pos + +let rec inst (s:term -> fv -> term) t = + let t = SS.compress t in + let mk = mk t in + match t.n with + | Tm_delayed _ -> failwith "Impossible" + + | Tm_name _ + | Tm_uvar _ + | Tm_uvar _ + | Tm_type _ + | Tm_bvar _ + | Tm_constant _ + | Tm_quoted _ + | Tm_unknown + | Tm_uinst _ -> t + + | Tm_lazy _ -> t + + | Tm_fvar fv -> + s t fv + + | Tm_abs {bs; body; rc_opt=lopt} -> + let bs = inst_binders s bs in + let body = inst s body in + mk (Tm_abs {bs; body; rc_opt=inst_lcomp_opt s lopt}) + + | Tm_arrow {bs; comp=c} -> + let bs = inst_binders s bs in + let c = inst_comp s c in + mk (Tm_arrow {bs; comp=c}) + + | Tm_refine {b=bv; phi=t} -> + let bv = {bv with sort=inst s bv.sort} in + let t = inst s t in + mk (Tm_refine {b=bv; phi=t}) + + | Tm_app {hd=t; args} -> + mk (Tm_app {hd=inst s t; args=inst_args s args}) + + | Tm_match {scrutinee=t; ret_opt=asc_opt; brs=pats; rc_opt=lopt} -> + let pats = pats |> List.map (fun (p, wopt, t) -> + let wopt = match wopt with + | None -> None + | Some w -> Some (inst s w) in + let t = inst s t in + (p, wopt, t)) in + let asc_opt = + match asc_opt with + | None -> None + | Some (b, asc) -> + Some (inst_binder s b, inst_ascription s asc) in + mk (Tm_match {scrutinee=inst s t; + ret_opt=asc_opt; + brs=pats; + rc_opt=inst_lcomp_opt s lopt}) + + | Tm_ascribed {tm=t1; asc; eff_opt=f} -> + mk (Tm_ascribed {tm=inst s t1; asc=inst_ascription s asc; eff_opt=f}) + + | Tm_let {lbs; body=t} -> + let lbs = fst lbs, snd lbs |> List.map (fun lb -> {lb with lbtyp=inst s lb.lbtyp; lbdef=inst s lb.lbdef}) in + mk (Tm_let {lbs; body=inst s t}) + + | Tm_meta {tm=t; meta=Meta_pattern (bvs, args)} -> + mk (Tm_meta {tm=inst s t; meta=Meta_pattern (bvs, args |> List.map (inst_args s))}) + + | Tm_meta {tm=t; meta=Meta_monadic (m, t')} -> + mk (Tm_meta {tm=inst s t; meta=Meta_monadic(m, inst s t')}) + + | Tm_meta {tm=t; meta=tag} -> + mk (Tm_meta {tm=inst s t; meta=tag}) + +and inst_binder s b = + { b with + binder_bv = { b.binder_bv with sort = inst s b.binder_bv.sort }; + binder_attrs = b.binder_attrs |> List.map (inst s) } + +and inst_binders s bs = bs |> List.map (inst_binder s) + +and inst_args s args = args |> List.map (fun (a, imp) -> inst s a, imp) + +and inst_comp s c = match c.n with + | Total t -> S.mk_Total (inst s t) + | GTotal t -> S.mk_GTotal (inst s t) + | Comp ct -> let ct = {ct with result_typ=inst s ct.result_typ; + effect_args=inst_args s ct.effect_args; + flags=ct.flags |> List.map (function + | DECREASES dec_order -> + DECREASES (inst_decreases_order s dec_order) + | f -> f)} in + S.mk_Comp ct + +and inst_decreases_order s = function + | Decreases_lex l -> Decreases_lex (l |> List.map (inst s)) + | Decreases_wf (rel, e) -> Decreases_wf (inst s rel, inst s e) + +and inst_lcomp_opt s l = match l with + | None -> None + | Some rc -> Some ({rc with residual_typ = FStarC.Compiler.Util.map_opt rc.residual_typ (inst s)}) + +and inst_ascription s (asc:ascription) = + let annot, topt, use_eq = asc in + let annot = + match annot with + | Inl t -> Inl (inst s t) + | Inr c -> Inr (inst_comp s c) in + let topt = FStarC.Compiler.Util.map_opt topt (inst s) in + annot, topt, use_eq + +let instantiate i t = match i with + | [] -> t + | _ -> + let inst_fv (t: term) (fv: S.fv) : term = + begin match U.find_opt (fun (x, _) -> lid_equals x fv.fv_name.v) i with + | None -> t + | Some (_, us) -> mk t (Tm_uinst(t, us)) + end + in + inst inst_fv t diff --git a/src/syntax/FStarC.Syntax.InstFV.fsti b/src/syntax/FStarC.Syntax.InstFV.fsti new file mode 100644 index 00000000000..8f0e30fda6f --- /dev/null +++ b/src/syntax/FStarC.Syntax.InstFV.fsti @@ -0,0 +1,23 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Syntax.InstFV +open FStarC.Compiler.Effect +open FStarC.Syntax.Syntax +open FStarC.Ident +type inst_t = list (lident & universes) +val inst: (term -> fv -> term) -> term -> term +val inst_binders: (term -> fv -> term) -> binders -> binders +val instantiate: inst_t -> term -> term diff --git a/src/syntax/FStarC.Syntax.MutRecTy.fst b/src/syntax/FStarC.Syntax.MutRecTy.fst new file mode 100644 index 00000000000..5b39115b397 --- /dev/null +++ b/src/syntax/FStarC.Syntax.MutRecTy.fst @@ -0,0 +1,247 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Syntax.MutRecTy +open FStar open FStarC +open FStarC.Compiler +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Syntax.Syntax +open FStarC.Ident +open FStarC.Compiler.Util +open FStarC.Errors +open FStarC.Syntax.InstFV +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module U = FStarC.Compiler.Util + + + + +(* Given a list of bundled type declarations potentially with type + abbreviations, construct the new bundle without type abbreviations + or lets (where they have been all unfolded) and the list of type + abbreviations or lets separated away from the bundle (and sorted in + dependency order, in such a way that they are no longer mutually + recursive.) *) + +let disentangle_abbrevs_from_bundle + (sigelts: list sigelt) + (quals: list qualifier) + (members: list lident) + (rng: FStarC.Compiler.Range.range) + : sigelt & list sigelt = + + (* NS: Attributes on the type constructors and abbreviation are gathered, + and placed on the bundle. + Attributes on the data constructors do not propagate to the bundle. *) + let sigattrs = + List.collect + (fun s -> + match s.sigel with + | Sig_inductive_typ _ + | Sig_let _ -> s.sigattrs + | _ -> []) + sigelts + in + let sigattrs = FStarC.Syntax.Util.deduplicate_terms sigattrs in + + (* Gather the list of type abbrevs *) + let type_abbrev_sigelts = sigelts |> List.collect begin fun x -> match x.sigel with + | Sig_let {lbs=(false, [ { lbname= Inr _ } ])} -> [x] + | Sig_let _ -> + failwith "mutrecty: disentangle_abbrevs_from_bundle: type_abbrev_sigelts: impossible" + | _ -> [] + end + in + + match type_abbrev_sigelts with + | [] -> + (* if there are no type abbreviations, then do not change anything. *) + { sigel = Sig_bundle {ses=sigelts; lids=members}; + sigrng = rng; + sigquals = quals; + sigmeta = default_sigmeta; + sigattrs = sigattrs; + sigopts = None; + sigopens_and_abbrevs = [] }, [] + | _ -> + + let type_abbrevs = type_abbrev_sigelts |> List.map begin fun x -> match x.sigel with + | Sig_let {lbs=(_, [ { lbname = Inr fv } ] )} -> fv.fv_name.v + | _ -> failwith "mutrecty: disentangle_abbrevs_from_bundle: type_abbrevs: impossible" + end + in + + (* First, unfold type abbrevs among themselves *) + let unfolded_type_abbrevs = + + (* List of type abbreviations that have been unfolded, in + reverse order (from most recent to most ancient: the head + depends on the tail.) *) + let rev_unfolded_type_abbrevs : ref (list sigelt) = U.mk_ref [] in + + (* List of names of type abbreviations whose unfolding has + started. If they occur during renaming of the current type + abbreviation, then there is a cycle. Follows a stack + discipline. *) + let in_progress : ref (list lident) = U.mk_ref [] in + + (* List of type abbreviations that have not been unfolded + yet. Their order can change, since anyway they will be + reordered after being unfolded. *) + let not_unfolded_yet = U.mk_ref type_abbrev_sigelts in + + let remove_not_unfolded lid = + not_unfolded_yet := !not_unfolded_yet |> List.filter begin fun x -> match x.sigel with + | Sig_let {lbs=(_, [ { lbname = Inr fv } ] )} -> + not (lid_equals lid fv.fv_name.v) + | _ -> true + end + in + + (* Replace a free variable corresponding to a type + abbreviation, with memoization. *) + let rec unfold_abbrev_fv (t: term) (fv : S.fv) : term = + let replacee (x: sigelt) = match x.sigel with + | Sig_let {lbs=(_, [ { lbname = Inr fv' } ] )} + when lid_equals fv'.fv_name.v fv.fv_name.v -> + Some x + | _ -> None + in + let replacee_term (x: sigelt) = match replacee x with + | Some { sigel = Sig_let {lbs=(_, [ { lbdef = tm } ] )} } -> Some tm + | _ -> None + in + match U.find_map !rev_unfolded_type_abbrevs replacee_term with + | Some x -> x + | None -> + begin match U.find_map type_abbrev_sigelts replacee with + | Some se -> + if FStarC.Compiler.List.existsb (fun x -> lid_equals x fv.fv_name.v) !in_progress + then let msg = U.format1 "Cycle on %s in mutually recursive type abbreviations" (string_of_lid fv.fv_name.v) in + raise_error fv.fv_name.v Errors.Fatal_CycleInRecTypeAbbreviation msg + else unfold_abbrev se + | _ -> t + end + + (* Start unfolding in a type abbreviation that has not occurred before. *) + and unfold_abbrev (x: sigelt) = match x.sigel with + | Sig_let {lbs=(false, [lb])} -> + (* eliminate some qualifiers for definitions *) + let quals = x.sigquals |> List.filter begin function + | Noeq -> false + | _ -> true + end in + let lid = match lb.lbname with + | Inr fv -> fv.fv_name.v + | _ -> failwith "mutrecty: disentangle_abbrevs_from_bundle: rename_abbrev: lid: impossible" + in + let () = in_progress := lid :: !in_progress in (* push *) + let () = remove_not_unfolded lid in + let ty' = inst unfold_abbrev_fv lb.lbtyp in + let tm' = inst unfold_abbrev_fv lb.lbdef in + let lb' = { lb with lbtyp = ty' ; lbdef = tm' } in + let sigelt' = Sig_let {lbs=(false, [lb']); lids=[lid]} in + let () = rev_unfolded_type_abbrevs := { x with sigel = sigelt'; sigquals = quals } :: !rev_unfolded_type_abbrevs in + let () = in_progress := List.tl !in_progress in (* pop *) + tm' + | _ -> failwith "mutrecty: disentangle_abbrevs_from_bundle: rename_abbrev: impossible" + in + + let rec aux () = match !not_unfolded_yet with + | x :: _ -> let _unused = unfold_abbrev x in aux () + | _ -> List.rev !rev_unfolded_type_abbrevs + + in + + aux () + in + + (* Now, unfold in inductive types and data constructors *) + + let filter_out_type_abbrevs l = + List.filter (fun lid -> FStarC.Compiler.List.for_all (fun lid' -> not (lid_equals lid lid')) type_abbrevs) l + in + + let inductives_with_abbrevs_unfolded = + + let find_in_unfolded fv = U.find_map unfolded_type_abbrevs begin fun x -> match x.sigel with + | Sig_let {lbs=(_, [ { lbname = Inr fv' ; lbdef = tm } ] )} when (lid_equals fv'.fv_name.v fv.fv_name.v) -> + Some tm + | _ -> None + end + in + + let unfold_fv (t: term) (fv: S.fv) : term = match find_in_unfolded fv with + | Some t' -> t' + | _ -> t + in + + let unfold_in_sig (x: sigelt) = match x.sigel with + | Sig_inductive_typ {lid; us=univs; params=bnd; + num_uniform_params=num_uniform; + t=ty; mutuals=mut; ds=dc; + injective_type_params } -> + let bnd' = inst_binders unfold_fv bnd in + let ty' = inst unfold_fv ty in + let mut' = filter_out_type_abbrevs mut in + [{ x with sigel = Sig_inductive_typ {lid=lid; + us=univs; + params=bnd'; + num_uniform_params=num_uniform; + t=ty'; + mutuals=mut'; + ds=dc; + injective_type_params } }] + + | Sig_datacon {lid; us=univs; t=ty; ty_lid=res; + num_ty_params=npars; mutuals=mut; + injective_type_params } -> + let ty' = inst unfold_fv ty in + let mut' = filter_out_type_abbrevs mut in + [{ x with sigel = Sig_datacon {lid; + us=univs; + t=ty'; + ty_lid=res; + num_ty_params=npars; + mutuals=mut'; + injective_type_params } }] + + | Sig_let _ -> + [] + + | _ -> failwith "mutrecty: inductives_with_abbrevs_unfolded: unfold_in_sig: impossible" + in + + List.collect unfold_in_sig sigelts + in + + (* Finally, construct a new bundle separate from type abbrevs *) + + let new_members = filter_out_type_abbrevs members + in + + let new_bundle = { sigel = Sig_bundle {ses=inductives_with_abbrevs_unfolded; lids=new_members}; + sigrng = rng; + sigquals = quals; + sigmeta = default_sigmeta; + sigattrs = sigattrs; + sigopts = None; + sigopens_and_abbrevs = [] } + in + + (new_bundle, unfolded_type_abbrevs) diff --git a/src/syntax/FStarC.Syntax.MutRecTy.fsti b/src/syntax/FStarC.Syntax.MutRecTy.fsti new file mode 100644 index 00000000000..e4786f19688 --- /dev/null +++ b/src/syntax/FStarC.Syntax.MutRecTy.fsti @@ -0,0 +1,23 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +// (c) Microsoft Corporation. All rights reserved +module FStarC.Syntax.MutRecTy +open FStarC.Compiler.Effect +open FStarC.Syntax.Syntax +open FStarC.Ident + +val disentangle_abbrevs_from_bundle: list sigelt -> list qualifier -> list lident -> + FStarC.Compiler.Range.range -> sigelt & list sigelt diff --git a/src/syntax/FStarC.Syntax.Resugar.fst b/src/syntax/FStarC.Syntax.Resugar.fst new file mode 100644 index 00000000000..b00f874ebf2 --- /dev/null +++ b/src/syntax/FStarC.Syntax.Resugar.fst @@ -0,0 +1,1629 @@ +(* + Copyright 2008-2014 Microsoft Research + + Authors: Qunyan Mangus, Nikhil Swamy + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Syntax.Resugar //we should rename FStarC.ToSyntax to something else +open FStar open FStarC +open FStarC.Compiler +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Syntax.Syntax +open FStarC.Ident +open FStarC.Compiler.Util +open FStarC.Const +open FStarC.Compiler.List +open FStarC.Parser.AST +open FStarC.Class.Monad +open FStarC.Class.Setlike +open FStarC.Class.Show + +module I = FStarC.Ident +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module A = FStarC.Parser.AST +module C = FStarC.Parser.Const +module U = FStarC.Syntax.Util +module BU = FStarC.Compiler.Util +module D = FStarC.Parser.ToDocument +module UF = FStarC.Syntax.Unionfind +module E = FStarC.Errors +module DsEnv = FStarC.Syntax.DsEnv + +(* Helpers to print/debug the resugaring phase *) +let doc_to_string doc = FStarC.Pprint.pretty_string (float_of_string "1.0") 100 doc +let parser_term_to_string t = doc_to_string (D.term_to_document t) +let parser_pat_to_string t = doc_to_string (D.pat_to_document t) + +(* A callback into FStarC.Syntax.show. Careful, it's mutually recursive + * with this module and could loop, so only use it for debugging. *) +let tts (t:S.term) : string = U.tts t + +let map_opt = List.filter_map + +let bv_as_unique_ident (x:S.bv) : I.ident = + let unique_name = + if starts_with reserved_prefix (string_of_id x.ppname) + || Options.print_real_names () then + (string_of_id x.ppname) ^ (string_of_int x.index) + else + (string_of_id x.ppname) + in + I.mk_ident (unique_name, (range_of_id x.ppname)) + +(* true if argument is implicit and should be filtered without --print_implicits. +Typeclass args are not considered implicit for printing. *) +let is_imp_bqual a = + match a with + | Some (S.Meta t) when U.is_fvar C.tcresolve_lid t -> false + | Some (S.Implicit _) + | Some (S.Meta _) -> true + | _ -> false + +let no_imp_args (args:S.args) : S.args = + args |> List.filter (function (_, None) -> true | (_, Some arg) -> not (arg.aqual_implicit)) + +let no_imp_bs bs = + bs |> List.filter (fun b -> not (is_imp_bqual b.binder_qual)) + +let filter_imp_args (args:S.args) : S.args = + if Options.print_implicits () + then args + else no_imp_args args + +let filter_imp_bs bs = + if Options.print_implicits () + then bs + else no_imp_bs bs + +let filter_pattern_imp xs = + if Options.print_implicits () + then xs + else List.filter (fun (_, is_implicit) -> not is_implicit) xs + +let label s t = + if s = "" then t + else A.mk_term (A.Labeled (t,s,true)) t.range A.Un + +let rec universe_to_int n u = + match Subst.compress_univ u with + | U_succ u -> universe_to_int (n+1) u + | _ -> (n, u) + +let universe_to_string univs = + if (Options.print_universes()) then + List.map (fun x -> (string_of_id x)) univs |> String.concat ", " + else "" + +let rec resugar_universe (u:S.universe) r: A.term = + let mk (a:A.term') r: A.term = + //augment `a` an Unknown level (the level is unimportant ... we should maybe remove it altogether) + A.mk_term a r A.Un + in + let u = Subst.compress_univ u in + begin match u with + | U_zero -> + mk (A.Const(Const_int ("0", None))) r + + | U_succ _ -> + let (n, u) = universe_to_int 0 u in + begin match u with + | U_zero -> + mk (A.Const(Const_int(string_of_int n, None))) r + + | _ -> + let e1 = mk (A.Const(Const_int(string_of_int n, None))) r in + let e2 = resugar_universe u r in + mk (A.Op(Ident.id_of_text "+", [e1; e2])) r + end + + | U_max l -> + begin match l with + | [] -> failwith "Impossible: U_max without arguments" + | _ -> + let t = mk (A.Var(lid_of_path ["max"] r)) r in + List.fold_left(fun acc x -> mk (A.App(acc, resugar_universe x r, A.Nothing)) r) t l + end + + | U_name u -> mk (A.Uvar(u)) r + | U_unif _ -> mk A.Wild r + | U_bvar x -> + (* This case can happen when trying to print a subterm of a term that is not opened.*) + let id = I.mk_ident (strcat "uu__univ_bvar_" (string_of_int x), r) in + mk (A.Uvar(id)) r + + | U_unknown -> mk A.Wild r (* not sure what to resugar to since it is not created by desugar *) + end + +// resugar_universe' included for consistency (it doesn't use its environment) +let resugar_universe' (env: DsEnv.env) (u:S.universe) r: A.term = + resugar_universe u r + +type expected_arity = option int + +(* GM: This almost never actually returns an expected arity. It does so +only for subtraction, I think. *) +let rec resugar_term_as_op (t:S.term) : option (string&expected_arity) = + let infix_prim_ops = [ + (C.op_Addition , "+" ); + (C.op_Subtraction , "-" ); + (C.op_Minus , "-" ); + (C.op_Multiply , "*" ); + (C.op_Division , "/" ); + (C.op_Modulus , "%" ); + (C.read_lid , "!" ); + (C.list_append_lid, "@" ); + (C.list_tot_append_lid,"@"); + (C.op_Eq , "=" ); + (C.op_ColonEq , ":="); + (C.op_notEq , "<>"); + (C.not_lid , "~" ); + (C.op_And , "&&"); + (C.op_Or , "||"); + (C.op_LTE , "<="); + (C.op_GTE , ">="); + (C.op_LT , "<" ); + (C.op_GT , ">" ); + (C.op_Modulus , "mod"); + (C.and_lid , "/\\"); + (C.or_lid , "\\/"); + (C.imp_lid , "==>"); + (C.iff_lid , "<==>"); + (C.precedes_lid, "<<"); + (C.eq2_lid , "=="); + (C.forall_lid , "forall"); + (C.exists_lid , "exists"); + (C.salloc_lid , "alloc"); + (C.calc_finish_lid, "calc_finish"); + ] in + let fallback fv = + match infix_prim_ops |> BU.find_opt (fun d -> fv_eq_lid fv (fst d)) with + | Some op -> + Some (snd op, None) + | _ -> + let length = String.length (nsstr fv.fv_name.v) in + let str = if length=0 then (string_of_lid fv.fv_name.v) + else BU.substring_from (string_of_lid fv.fv_name.v) (length+1) in + (* Check that it is of the shape dtuple int, and return that arity *) + if BU.starts_with str "dtuple" + && Option.isSome (BU.safe_int_of_string (BU.substring_from str 6)) + then Some ("dtuple", BU.safe_int_of_string (BU.substring_from str 6)) + else if BU.starts_with str "tuple" + && Option.isSome (BU.safe_int_of_string (BU.substring_from str 5)) + then Some ("tuple", BU.safe_int_of_string (BU.substring_from str 5)) + else if BU.starts_with str "try_with" then Some ("try_with", None) + else if fv_eq_lid fv C.sread_lid then Some (string_of_lid fv.fv_name.v, None) + else None + in + match (SS.compress t).n with + | Tm_fvar fv -> + let length = String.length (nsstr fv.fv_name.v) in + let s = if length=0 then string_of_lid fv.fv_name.v + else BU.substring_from (string_of_lid fv.fv_name.v) (length+1) in + begin match string_to_op s with + | Some t -> Some t + | _ -> fallback fv + end + | Tm_uinst(e, us) -> + resugar_term_as_op e + | _ -> None + +let is_true_pat (p:S.pat) : bool = match p.v with + | Pat_constant (Const_bool true) -> true + | _ -> false + +let is_tuple_constructor_lid lid = + C.is_tuple_data_lid' lid + || C.is_dtuple_data_lid' lid + +let may_shorten lid = + if Options.print_real_names () then false + else + match string_of_lid lid with + | "Prims.Nil" + | "Prims.Cons" -> false + | _ -> not (is_tuple_constructor_lid lid) + +let maybe_shorten_lid env lid : lident = + if may_shorten lid then DsEnv.shorten_lid env lid else lid + +let maybe_shorten_fv env fv : lident = + let lid = fv.fv_name.v in + maybe_shorten_lid env lid + +(* Sizet handled below *) +let serialize_machine_integer_desc (s,w) : list string = + let sU = match s with | Unsigned -> "U" | Signed -> "" in + let sW = + match w with + | Int8 -> "8" + | Int16 -> "16" + | Int32 -> "32" + | Int64 -> "64" + in + let su = match s with | Unsigned -> "u" | Signed -> "" in + [ BU.format3 "FStar.%sInt%s.__%sint_to_t" sU sW su; + BU.format3 "FStar.%sInt%s.%sint_to_t" sU sW su ] + +let parse_machine_integer_desc = + let signs = [Unsigned; Signed] in + let widths = [Int8; Int16; Int32; Int64] in + let descs = + ((Unsigned, Sizet), "FStar.SizeT.__uint_to_t") :: + (let! s = signs in + let! w = widths in + let! desc = serialize_machine_integer_desc (s, w) in + [((s, w), desc)]) + in + fun (fv:fv) -> + List.tryFind (fun (_, d) -> d = Ident.string_of_lid (lid_of_fv fv)) descs + +let can_resugar_machine_integer_fv fv = + Option.isSome (parse_machine_integer_desc fv) + +let resugar_machine_integer fv (i:string) pos = + match parse_machine_integer_desc fv with + | None -> failwith "Impossible: should be guarded by can_resugar_machine_integer" + | Some (sw, _) -> A.mk_term (A.Const (Const_int(i, Some sw))) pos A.Un + +let rec __is_list_literal cons_lid nil_lid (t:S.term) : option (list S.term) = + let open FStarC.Class.Monad in + let hd, args = U.head_and_args_full t in + let hd = hd |> U.un_uinst |> SS.compress in + let args = args |> filter_imp_args in + match hd.n, args with + | Tm_fvar fv, [(hd, None); (tl, None)] when fv_eq_lid fv cons_lid -> + let! tl = __is_list_literal cons_lid nil_lid tl in + return (hd :: tl) + | Tm_fvar fv, [] when fv_eq_lid fv nil_lid -> + return [] + | _, _ -> + None + +let is_list_literal = __is_list_literal C.cons_lid C.nil_lid +let is_seq_literal = __is_list_literal C.seq_cons_lid C.seq_empty_lid + +let can_resugar_machine_integer (hd : S.term) (args : S.args) : option (fv & string) = + match (SS.compress hd).n with + | Tm_fvar fv when can_resugar_machine_integer_fv fv -> ( + match args with + | [(a, None)] -> ( + match (SS.compress a).n with + | Tm_constant (Const_int (i, None)) -> + Some (fv, i) + | _ -> None + ) + | _ -> None + ) + | _ -> None + +let rec resugar_term' (env: DsEnv.env) (t : S.term) : A.term = + (* Cannot resugar term back to NamedTyp or Paren *) + let mk (a:A.term') : A.term = + //augment `a` with its source position + //and an Unknown level (the level is unimportant ... we should maybe remove it altogether) + A.mk_term a t.pos A.Un + in + let name a r = + // make a Name term' + A.Name (lid_of_path [a] r) + in + match (SS.compress t).n with //always call compress before case-analyzing a S.term + | Tm_delayed _ -> + failwith "Tm_delayed is impossible after compress" + + | Tm_lazy i -> + resugar_term' env (U.unfold_lazy i) + + | Tm_bvar x -> + (* this case can happen when printing a subterm of a term that is not opened *) + let l = FStarC.Ident.lid_of_ids [bv_as_unique_ident x] in + mk (A.Var l) + + | Tm_name x -> //a lower-case identifier + //this is is too simplistic + //the resulting unique_name is very ugly + //it would be better to try to use x.ppname alone, unless the suffix is deemed semantically necessary + let l = FStarC.Ident.lid_of_ids [bv_as_unique_ident x] in + mk (A.Var l) + + | Tm_fvar fv -> //a top-level identifier, may be lowercase or upper case + //should be A.Var if lowercase + //and A.Name if uppercase + let a = fv.fv_name.v in + let length = String.length (nsstr fv.fv_name.v) in + let s = if length=0 then string_of_lid a + else BU.substring_from (string_of_lid a) (length+1) in + let is_prefix = I.reserved_prefix ^ "is_" in + if BU.starts_with s is_prefix then + let rest = BU.substring_from s (String.length is_prefix) in + mk (A.Discrim(lid_of_path [rest] t.pos)) + else if BU.starts_with s U.field_projector_prefix then + let rest = BU.substring_from s (String.length U.field_projector_prefix) in + let r = BU.split rest U.field_projector_sep in + begin match r with + | [fst; snd] -> + let l = lid_of_path [fst] t.pos in + let r = I.mk_ident (snd, t.pos) in + mk (A.Projector(l, r )) + | _ -> + failwith "wrong projector format" + end + else if (lid_equals a C.smtpat_lid) then + mk (A.Tvar (I.mk_ident ("SMTPat", I.range_of_lid a))) + else if (lid_equals a C.smtpatOr_lid) then + mk (A.Tvar (I.mk_ident ("SMTPatOr", I.range_of_lid a))) + else if (lid_equals a C.assert_lid || lid_equals a C.assume_lid + || FStar.Char.uppercase (String.get s 0) <> String.get s 0) then + mk (A.Var (maybe_shorten_fv env fv)) + else // FIXME check in environment instead of checking case + mk (A.Construct (maybe_shorten_fv env fv, [])) + + | Tm_uinst(e, universes) -> + let e = resugar_term' env e in + if Options.print_universes() then + let univs = List.map (fun x -> resugar_universe x t.pos) universes in + match e with + | { tm = A.Construct (hd, args); range = r; level = l } -> + let args = args @ (List.map (fun u -> (u, A.UnivApp)) univs) in + A.mk_term (A.Construct (hd, args)) r l + | _ -> + List.fold_left (fun acc u -> mk (A.App (acc, u, A.UnivApp))) e univs + else + e + + | Tm_constant c -> + if is_teff t + then mk (name "Effect" t.pos) + else mk (A.Const c) + + | Tm_type u -> + let nm, needs_app = + match u with + | U_zero -> "Type0", false + | U_unknown -> "Type", false + | _ -> "Type", true in + let typ = mk (name nm t.pos) in + if needs_app && Options.print_universes () + then mk (A.App (typ, resugar_universe u t.pos, UnivApp)) + else typ + + | Tm_abs {bs=xs; body} -> //fun x1 .. xn -> body + //before inspecting any syntactic form that has binding structure + //you must call SS.open_* to replace de Bruijn indexes with names + let xs, body = SS.open_term xs body in + let xs = filter_imp_bs xs in + let body_bv = FStarC.Syntax.Free.names body in + let patterns = xs |> List.map (fun x -> + //x.sort contains a type annotation for the bound variable + //the pattern `p` below only contains the variable, not the annotation + //but, if the user wrote the annotation, then we should record that and print it back + //additionally, if we're in verbose mode, e.g., if --print_bound_var_types is set + // then we should print the annotation too + resugar_bv_as_pat env x.binder_bv x.binder_qual body_bv) + in + let body = resugar_term' env body in + (* If no binders/patterns remain after filtering, drop the Abs node *) + if List.isEmpty patterns + then body + else mk (A.Abs(patterns, body)) + + | Tm_arrow _ -> + (* Flatten the arrow *) + let xs, body = + match (SS.compress (U.canon_arrow t)).n with + | Tm_arrow {bs=xs; comp=body} -> xs, body + | _ -> failwith "impossible: Tm_arrow in resugar_term" + in + let xs, body = SS.open_comp xs body in + let xs = filter_imp_bs xs in + let body = resugar_comp' env body in + let xs = xs |> map (fun b -> resugar_binder' env b t.pos) |> List.rev in + let rec aux body = function + | [] -> body + | hd::tl -> + let body = mk (A.Product([hd], body)) in + aux body tl in + aux body xs + + | Tm_refine {b=x; phi} -> + (* bv * term -> binder * term *) + let x, phi = SS.open_term [S.mk_binder x] phi in + let b = resugar_binder' env (List.hd x) t.pos in + mk (A.Refine(b, resugar_term' env phi)) + + (* Drop b2t unless --print_implicits() *) + | Tm_app {hd={n=Tm_fvar fv}; args=[(e, _)]} + when not (Options.print_implicits()) + && S.fv_eq_lid fv C.b2t_lid -> + resugar_term' env e + + | Tm_app {hd; args} + when Some? (can_resugar_machine_integer hd args) -> + let Some (fv, i) = can_resugar_machine_integer hd args in + resugar_machine_integer fv i t.pos + + | Tm_app _ -> + let t = U.canon_app t in + let Tm_app {hd=e; args} = t.n in + let is_hide_or_reveal e = + match U.un_uinst e with + | {n=Tm_fvar fv} -> + S.fv_eq_lid fv C.hide || S.fv_eq_lid fv C.reveal + | _ -> false + in + (* NB: This cannot fail since U.canon_app constructs a Tm_app. *) + + (* Op("=!=", args) is desugared into Op("~", Op("==") and not resugared back as "=!=" *) + let rec last = function + | hd :: [] -> [hd] + | hd :: tl -> last tl + | _ -> failwith "last of an empty list" + in + let first_two_explicit args = + let rec drop_implicits args = + match args with + | (_, Some ({aqual_implicit=true}))::tl -> drop_implicits tl + | _ -> args + in + match drop_implicits args with + | [] + | [_] -> failwith "not_enough explicit_arguments" + | a1::a2::_ -> [a1;a2] + in + let resugar_as_app e args = + let args = + List.map (fun (e, qual) -> (resugar_term' env e, resugar_aqual env qual)) args in + match resugar_term' env e with + | { tm = A.Construct (hd, previous_args); range = r; level = l } -> + A.mk_term (A.Construct (hd, previous_args @ args)) r l + | e -> + List.fold_left (fun acc (x, qual) -> mk (A.App (acc, x, qual))) e args + in + let args = filter_imp_args args in + + let is_projector (t:S.term) : option (lident & ident) = + (* Detect projectors and resugar them as t.x instead of Mkt?.x t *) + match (U.un_uinst (SS.compress t)).n with + | Tm_fvar fv -> + let a = fv.fv_name.v in + let length = String.length (nsstr fv.fv_name.v) in + let s = if length=0 then string_of_lid a + else BU.substring_from (string_of_lid a) (length+1) in + if BU.starts_with s U.field_projector_prefix then + let rest = BU.substring_from s (String.length U.field_projector_prefix) in + let r = BU.split rest U.field_projector_sep in + begin match r with + | [fst; snd] -> + let l = lid_of_path [fst] t.pos in + let r = I.mk_ident (snd, t.pos) in + Some (l, r) + | _ -> + failwith "wrong projector format" + end + else None + | _ -> None + in + (* We have a projector, applied to at least one argument, and the first argument + is explicit (so not one of the parameters of the type). In this case we resugar nicely. *) + if Some? (is_projector e) && List.length args >= 1 && None? (snd (List.hd args)) then + let arg1 :: rest_args = args in + let (_, fi) = Some?.v (is_projector e) in + let arg = resugar_term' env (fst arg1) in + let h = mk <| Project (arg, Ident.lid_of_ids [fi]) in + (* Add remaining args if any. *) + rest_args |> List.fold_left (fun acc (a, q) -> + let aa = resugar_term' env a in + let qq = resugar_aqual env q in + mk (A.App (acc, aa, qq))) + h + else if not (Options.print_implicits ()) + && Options.Ext.get "show_hide_reveal" = "" + && is_hide_or_reveal e + && List.length args = 1 //args already filtered + then ( + let [(e, _)] = args in + resugar_term' env e + ) + else + let unsnoc (#a:Type) (l : list a) : (list a & a) = + let rec unsnoc' acc = function + | [] -> failwith "unsnoc: empty list" + | [x] -> (List.rev acc, x) + | x::xs -> unsnoc' (x::acc) xs + in + unsnoc' [] l + in + let resugar_tuple_type env (args : S.args) : A.term = + let typs = args |> List.map (fun (x,_) -> resugar_term' env x) in + let pre, last = unsnoc typs in + mk (A.Sum (List.map Inr pre, last)) + in + let resugar_dtuple_type env (hd:S.term) (args : S.args) : A.term = + (* We will resugar a dtuple type like: + + dtuple3 int (fun i -> vector i) (fun i v -> vec_ok i v) + + as + (i : int & v : vector i & vec_ok i v) + + but only if every component is a lambda of that shape, defaulting + back to just an appication of dtupleN if not. *) + let fancy_resugar () : option A.term = + let open FStarC.Class.Monad in + let n = List.length args in + let take (#a:Type) (n:int) (l : list a) : list a = + List.splitAt n l |> fst + in + let bs, _, _ = U.abs_formals (fst <| List.last args) in + if List.length bs < n-1 then ( + (* This can definitely happen: we could have (dtuple2 int p) where p + is some int function, for example. In that case, we abort. *) + None + ) else Some ();! + let bs = take (n-1) bs in (* make sure to not take too many, shouldn't happen for anything well-typed but we do not know that *) + let concatM (#a:Type) (#m:Type -> Type) {| monad m |} + (l : list (m a)) : m (list a) = mapM id l + in + let rec open_lambda_binders (t : S.term) (bs: list S.binder) : option S.term = + match bs with + | [] -> Some t + | b::bs -> + let! (_, body) = U.abs_one_ln t in + let _, body = SS.open_term [b] body in + open_lambda_binders body bs + in + let! opened_bs_types : list S.term = + args |> mapMi (fun i (t, _) -> + open_lambda_binders t (take i bs)) + in + let set_binder_sort t b = + { b with binder_bv = { b.binder_bv with sort = t } } + in + let pre_bs_types, last_type = unsnoc opened_bs_types in + let bs = List.map2 (fun b t -> + let b = set_binder_sort t b in + resugar_binder' env b t.pos) + bs pre_bs_types + in + Some <| mk (A.Sum (List.map Inl bs, resugar_term' env last_type)) + in + match fancy_resugar () with + | Some r -> r + | None -> resugar_as_app hd args + in + begin match is_list_literal t with + | Some ts -> mk (A.ListLiteral (List.map (resugar_term' env) ts)) + | None -> + match is_seq_literal t with + | Some ts -> mk (A.SeqLiteral (List.map (resugar_term' env) ts)) + | None -> + match resugar_term_as_op e with + | None-> + resugar_as_app e args + + | Some ("calc_finish", _) -> + begin match resugar_calc env t with + | Some r -> r + | _ -> resugar_as_app e args + end + + | Some ("tuple", n) when Some (List.length args <: int) = n -> + resugar_tuple_type env args + + | Some ("dtuple", n) when Some (List.length args <: int) = n -> + resugar_dtuple_type env e args + + | Some (ref_read, _) when (ref_read = string_of_lid C.sread_lid) -> + let (t, _) = List.hd args in + begin match (SS.compress t).n with + | Tm_fvar fv when (U.field_projector_contains_constructor (string_of_lid fv.fv_name.v)) -> + let f = lid_of_path [string_of_lid fv.fv_name.v] t.pos in + mk (A.Project(resugar_term' env t, f)) + | _ -> resugar_term' env t + end + + | Some ("try_with", _) when List.length args > 1 -> + (* attempt to resugar as `try .. with | ...`, but otherwise just resugar normally *) + begin try + (* only the first two explicit args are from original AST terms, + * others are added by typechecker *) + (* TODO: we need a place to store the information in the args added by the typechecker *) + let new_args = first_two_explicit args in + let body, handler = match new_args with + | [(a1, _);(a2, _)] -> a1, a2 (* where a1 and a1 is Tm_abs(Tm_match)) *) + | _ -> + failwith("wrong arguments to try_with") + in + let decomp term = match (SS.compress term).n with + | Tm_abs {bs=x; body=e} -> + let x, e = SS.open_term x e in + e + | _ -> failwith("wrong argument format to try_with: " ^ term_to_string (resugar_term' env term)) in + let body = resugar_term' env (decomp body) in + let handler = resugar_term' env (decomp handler) in + let rec resugar_body t = match (t.tm) with + | A.Match(e, None, None, [(_,_,b)]) -> b + | A.Let(_, _, b) -> b // One branch Match that is resugared as Let + | A.Ascribed(t1, t2, t3, use_eq) -> + (* this case happens when the match is wrapped in Meta_Monadic which is resugared to Ascribe*) + mk (A.Ascribed(resugar_body t1, t2, t3, use_eq)) + | _ -> failwith("unexpected body format to try_with") in + let e = resugar_body body in + let rec resugar_branches t = match (t.tm) with + | A.Match(e, None, None, branches) -> branches + | A.Ascribed(t1, t2, t3, _) -> + (* this case happens when the match is wrapped in Meta_Monadic which is resugared to Ascribe*) + (* TODO: where should we keep the information stored in Ascribed? *) + resugar_branches t1 + | _ -> + (* TODO: forall created by close_forall doesn't follow the normal forall format, not sure how to resugar back *) + [] + in + let branches = resugar_branches handler in + mk (A.TryWith(e, branches)) + with + | _ -> + resugar_as_app e args + end + + | Some ("try_with", _) -> + resugar_as_app e args + + (* These have implicits, don't do the fancy printing when --print_implicits is on *) + | Some (op, _) when (op = "=" + || op = "==" + || op = "===" + || op = "@" + || op = ":=" + || op = "|>" + || op = "<<") + && Options.print_implicits () -> + resugar_as_app e args + + | Some (op, _) + when starts_with op "forall" + || starts_with op "exists" -> + (* desugared from QForall(binders * patterns * body) to Tm_app(forall, Tm_abs(binders, Tm_meta(body, meta_pattern(list args)*) + let rec uncurry xs pats (t:A.term) flavor_matches = + match t.tm with + | A.QExists(xs', (_, pats'), body) + | A.QForall(xs', (_, pats'), body) + | A.QuantOp(_, xs', (_, pats'), body) when flavor_matches t -> + uncurry (xs@xs') (pats@pats') body flavor_matches + | _ -> + xs, pats, t + in + let resugar_forall_body body = match (SS.compress body).n with + | Tm_abs {bs=xs; body} -> + let xs, body = SS.open_term xs body in + let xs = filter_imp_bs xs in + let xs = xs |> map (fun b -> resugar_binder' env b t.pos) in + let pats, body = match (SS.compress body).n with + | Tm_meta {tm=e; meta=m} -> + let body = resugar_term' env e in + let pats, body = match m with + | Meta_pattern (_, pats) -> + List.map (fun es -> es |> List.map (fun (e, _) -> resugar_term' env e)) pats, + body + | Meta_labeled (s, r, p) -> + // this case can occur in typechecker when a failure is wrapped in meta_labeled + [], mk (A.Labeled (body, Errors.Msg.rendermsg s, p)) + | _ -> failwith "wrong pattern format for QForall/QExists" + in + pats, body + | _ -> [], resugar_term' env body + in + let decompile_op op = + match FStarC.Parser.AST.string_to_op op with + | None -> op + | Some (op, _) -> op + in + let flavor_matches t = + match t.tm, op with + | A.QExists _, "exists" + | A.QForall _, "forall" -> true + | A.QuantOp(id, _, _, _), _ -> + Ident.string_of_id id = op + | _ -> false + in + let xs, pats, body = uncurry xs pats body flavor_matches in + let binders = A.idents_of_binders xs t.pos in + if op = "forall" + then mk (A.QForall(xs, (binders, pats), body)) + else if op = "exists" + then mk (A.QExists(xs, (binders, pats), body)) + else mk (A.QuantOp(Ident.id_of_text op, xs, (binders, pats), body)) + + | _ -> + (*forall added by typechecker.normalize doesn't not have Tm_abs as body*) + (*TODO: should we resugar them back as forall/exists or just as the term of the body *) + if op = "forall" then mk (A.QForall([], ([], []), resugar_term' env body)) + else mk (A.QExists([], ([], []), resugar_term' env body)) + in + (* only the last arg is from original AST terms, others are added by typechecker *) + (* TODO: we need a place to store the information in the args added by the typechecker *) + if List.length args > 0 then + let args = last args in + begin match args with + | [(b, _)] -> resugar_forall_body b + | _ -> failwith "wrong args format to QForall" + end + else + resugar_as_app e args + + | Some ("alloc", _) -> + let (e, _ ) = List.hd args in + resugar_term' env e + + | Some (op, expected_arity) -> + let op = Ident.id_of_text op in + let resugar args = args |> List.map (fun (e, qual) -> + resugar_term' env e, resugar_aqual env qual) + in + (* ignore the arguments added by typechecker *) + (* TODO: we need a place to store the information in the args added by the typechecker *) + //NS: this seems to produce the wrong output on things like + begin + match expected_arity with + | None -> + let resugared_args = resugar args in + let expect_n = D.handleable_args_length op in + if List.length resugared_args >= expect_n + then let op_args, rest = BU.first_N expect_n resugared_args in + let head = mk (A.Op(op, List.map fst op_args)) in + List.fold_left + (fun head (arg, qual) -> mk (A.App (head, arg, qual))) + head + rest + else resugar_as_app e args + | Some n when List.length args = n -> mk (A.Op(op, List.map fst (resugar args))) + | _ -> resugar_as_app e args + end + end + + | Tm_match {scrutinee=e; ret_opt=None; brs=[(pat, wopt, t)]} -> + (* for match expressions that have exactly 1 branch, instead of printing them as `match e with | P -> e1` + it would be better to print it as `let P = e in e1`. *) + (* only do it when pat is not Pat_disj since ToDocument only expects disjunctivePattern in Match and TryWith *) + let pat, wopt, t = SS.open_branch (pat, wopt, t) in + let branch_bv = FStarC.Syntax.Free.names t in + let bnds = [None, (resugar_pat' env pat branch_bv, resugar_term' env e)] in + let body = resugar_term' env t in + mk (A.Let(A.NoLetQualifier, bnds, body)) + + (* | Tm_match(e, asc_opt, [(pat1, _, t1); (pat2, _, t2)], _) *) + (* when is_true_pat pat1 && is_wild_pat pat2 -> *) + (* let asc_opt = resugar_match_returns env e t.pos asc_opt in *) + (* mk (A.If(resugar_term' env e, *) + (* None, *) + (* asc_opt, *) + (* resugar_term' env t1, *) + (* resugar_term' env t2)) *) + + | Tm_match {scrutinee=e; ret_opt=asc_opt; brs=branches} -> + let resugar_branch (pat, wopt,b) = + let pat, wopt, b = SS.open_branch (pat, wopt, b) in + let branch_bv = FStarC.Syntax.Free.names b in + let pat = resugar_pat' env pat branch_bv in + let wopt = match wopt with + | None -> None + | Some e -> Some (resugar_term' env e) in + let b = resugar_term' env b in + (pat, wopt, b) in + let asc_opt = resugar_match_returns env e t.pos asc_opt in + mk (A.Match(resugar_term' env e, + None, asc_opt, + List.map resugar_branch branches)) + + | Tm_ascribed {tm=e; asc} -> + let asc, tac_opt, b = resugar_ascription env asc in + mk (A.Ascribed (resugar_term' env e, asc, tac_opt, b)) + + | Tm_let {lbs=(is_rec, source_lbs); body} -> + let mk_pat a = A.mk_pattern a t.pos in + let source_lbs, body = SS.open_let_rec source_lbs body in + let resugar_one_binding bnd = + (* TODO : some stuff are open twice there ! (may have already been opened in open_let_rec) *) + let attrs_opt = + match bnd.lbattrs with + | [] -> None + | tms -> Some (List.map (resugar_term' env) tms) + in + let univs, td = SS.open_univ_vars bnd.lbunivs (U.mk_conj bnd.lbtyp bnd.lbdef) in + let typ, def = match (SS.compress td).n with + | Tm_app {args=[(t, _); (d, _)]} -> t, d + | _ -> failwith "wrong let binding format" + in + let binders, term, is_pat_app = match (SS.compress def).n with + | Tm_abs {bs=b; body=t} -> + let b, t = SS.open_term b t in + let b = filter_imp_bs b in + b, t, true + | _ -> [], def, false + in + let pat, term = match bnd.lbname with + | Inr fv -> mk_pat (A.PatName fv.fv_name.v), term + | Inl bv -> + mk_pat (A.PatVar (bv_as_unique_ident bv, None, [])), term + in + attrs_opt, + (if is_pat_app then + // let binders = filter_imp binders in + let args = binders |> map (fun b -> + let q = resugar_bqual env b.binder_qual in + mk_pat(A.PatVar (bv_as_unique_ident b.binder_bv, + q, + b.binder_attrs |> List.map (resugar_term' env)))) in + (mk_pat (A.PatApp (pat, args)), resugar_term' env term), (universe_to_string univs) + else + (pat, resugar_term' env term), (universe_to_string univs)) + in + let r = List.map resugar_one_binding source_lbs in + let bnds = + let f (attrs, (pb, univs)) = + if not (Options.print_universes ()) then attrs, pb + (* Print bound universes as a comment *) + else attrs, (fst pb, label univs (snd pb)) + in + List.map f r + in + let body = resugar_term' env body in + mk (A.Let((if is_rec then A.Rec else A.NoLetQualifier), bnds, body)) + + | Tm_uvar (u, _) -> + let s = "?u" ^ (UF.uvar_id u.ctx_uvar_head |> string_of_int) in + (* TODO : should we put a pretty_non_parseable option for these cases ? *) + label s (mk A.Wild) + + | Tm_quoted (tm, qi) -> + let qi = match qi.qkind with + | Quote_static -> Static + | Quote_dynamic -> Dynamic + in + mk (A.Quote (resugar_term' env tm, qi)) + + | Tm_meta {tm=e; meta=m} -> + let resugar_meta_desugared = function + | Sequence -> + let term = resugar_term' env e in + let rec resugar_seq t = match t.tm with + | A.Let(_, [_, (p, t1)], t2) -> + mk (A.Seq(t1, t2)) + | A.Ascribed(t1, t2, t3, use_eq) -> + (* this case happens when the let is wrapped in Meta_Monadic which is resugared to Ascribe*) + mk (A.Ascribed(resugar_seq t1, t2, t3, use_eq)) + | _ -> + (* this case happens in typechecker.normalize when Tm_let is_pure_effect, then + only the body of Tm_let is used. *) + (* TODO: How should it be resugared *) + t + in + resugar_seq term + | Machine_integer (_,_) + | Primop (* doesn't seem to be generated by desugar *) + | Masked_effect (* doesn't seem to be generated by desugar *) + | Meta_smt_pat -> (* nothing special, just resugar the term *) + resugar_term' env e + in + begin match m with + | Meta_labeled _ -> + (* Ignore the label, we don't want to print it *) + resugar_term' env e + | Meta_desugared i -> + resugar_meta_desugared i + | Meta_named t -> + mk (A.Name t) + | Meta_pattern _ // stray pattern, ignore + | Meta_monadic _ + | Meta_monadic_lift _ -> resugar_term' env e + end + + | Tm_unknown -> mk A.Wild + +and resugar_ascription env (asc, tac_opt, b) = + (match asc with + | Inl n -> (* term *) + resugar_term' env n + | Inr n -> (* comp *) + resugar_comp' env n), + BU.map_opt tac_opt (resugar_term' env), + b + +(* This entire function is of course very tied to the the desugaring +of calc expressions in ToSyntax. This only really works for fully +elaborated terms, sorry. *) +and resugar_calc (env:DsEnv.env) (t0:S.term) : option A.term = + let mk (a:A.term') : A.term = + A.mk_term a t0.pos A.Un + in + (* Returns the non-resugared final relation and the calc_pack *) + let resugar_calc_finish (t:S.term) : option (S.term & S.term) = + let hd, args = U.head_and_args t in + match (SS.compress (U.un_uinst hd)).n, args with + | Tm_fvar fv, [(_, Some { aqual_implicit = true }); // type + (rel, None); // top relation + (_, Some { aqual_implicit = true }); // x + (_, Some { aqual_implicit = true }); // y + (_, Some { aqual_implicit = true }); // rs + (pf, None)] // pf : unit -> Tot (calc_pack rs x y) + when S.fv_eq_lid fv C.calc_finish_lid -> + let pf = U.unthunk pf in + Some (rel, pf) + + | _ -> + None + in + (* Un-eta expand a relation. Return it as-is if cannot be done. *) + let un_eta_rel (rel:S.term) : option S.term = + let bv_eq_tm (b:bv) (t:S.term) : bool = + match (SS.compress t).n with + | Tm_name b' when S.bv_eq b b' -> true + | _ -> false + in + match (SS.compress rel).n with + | Tm_abs {bs=[b1;b2]; body} -> + let ([b1;b2], body) = SS.open_term [b1;b2] body in + let body = U.unascribe body in + let body = match (U.unb2t body) with + | Some body -> body + | None -> body + in + begin match (SS.compress body).n with + | Tm_app {hd=e; args} when List.length args >= 2 -> + begin match List.rev args with + | (a1, None)::(a2, None)::rest -> + if bv_eq_tm b1.binder_bv a2 && bv_eq_tm b2.binder_bv a1 // mind the flip + then Some <| U.mk_app e (List.rev rest) + else Some rel + | _ -> + Some rel + end + | _ -> Some rel + end + + | _ -> + Some rel + in + (* Resugars an application of calc_step, returning the term, the relation, + * the justifcation, and the rest of the proof. *) + let resugar_step (pack:S.term) : option (S.term & S.term & S.term & S.term) = + let hd, args = U.head_and_args pack in + match (SS.compress (U.un_uinst hd)).n, args with + | Tm_fvar fv, [(_, Some ({ aqual_implicit = true })); // type + (_, Some ({ aqual_implicit = true })); // x + (_, Some ({ aqual_implicit = true })); // y + (rel, None); // relation + (z, None); // z, next val + (_, Some ({ aqual_implicit = true })); //rs + (pf, None); // pf, rest of proof (thunked) + (j, None)] // justification (thunked) + when S.fv_eq_lid fv C.calc_step_lid -> + let pf = U.unthunk pf in + let j = U.unthunk j in + Some (z, rel, j, pf) + + | _ -> + None + in + (* Resugar an application of calc_init *) + let resugar_init (pack:S.term) : option S.term = + let hd, args = U.head_and_args pack in + match (SS.compress (U.un_uinst hd)).n, args with + | Tm_fvar fv, [(_, Some ({ aqual_implicit = true })); // type + (x, None)] // initial value + when S.fv_eq_lid fv C.calc_init_lid -> + Some x + + | _ -> + None + in + (* Repeats the above function until it returns none; what remains should be a calc_init *) + let rec resugar_all_steps (pack:S.term) : option (list (S.term & S.term & S.term) & S.term) = + match resugar_step pack with + | Some (t, r, j, k) -> + BU.bind_opt (resugar_all_steps k) (fun (steps, k) -> + Some ((t, r, j)::steps, k)) + | None -> + Some ([], pack) + in + let resugar_rel (rel:S.term) : A.term = + (* Try to un-eta, don't worry if not *) + let rel = match un_eta_rel rel with + | Some rel -> rel + | None -> rel + in + let fallback () = + mk (A.Paren (resugar_term' env rel)) + in + begin match resugar_term_as_op rel with + | Some (s, None) + | Some (s, Some 2) -> mk (A.Op (Ident.id_of_text s, [])) + | _ -> fallback () + end + in + let build_calc (rel:S.term) (x0:S.term) (steps : list (S.term & S.term & S.term)) : A.term = + let r = resugar_term' env in + mk (CalcProof (resugar_rel rel, r x0, + List.map (fun (z, rel, j) -> CalcStep (resugar_rel rel, r j, r z)) steps)) + in + let! (rel, pack) = resugar_calc_finish t0 in + let! (steps, k) = resugar_all_steps pack in + let! x0 = resugar_init k in + Some <| build_calc rel x0 (List.rev steps) + +and resugar_match_returns env scrutinee r asc_opt = + match asc_opt with + | None -> None + | Some (b, asc) -> + let bopt, asc = + let bs, asc = SS.open_ascription [b] asc in + let b = List.hd bs in + //trying to be a little smart, + // if the binder name is the reserved prefix, then don't emit it + //but we need to substitute binder with scrutinee, + // basically reverse of what ToSyntax does + if string_of_id b.binder_bv.ppname = C.match_returns_def_name + then match (SS.compress scrutinee |> U.unascribe).n with + | Tm_name sbv -> + None, SS.subst_ascription [NT (b.binder_bv, S.bv_to_name sbv)] asc + | _ -> None, asc + else Some b, asc in + let bopt = BU.map_option (fun b -> + resugar_binder' env b r + |> A.ident_of_binder r) bopt in + let asc, use_eq = + match resugar_ascription env asc with + | asc, None, use_eq -> asc, use_eq + | _ -> failwith "resugaring does not support match return annotation with a tactic" in + Some (bopt, asc, use_eq) + + +and resugar_comp' (env: DsEnv.env) (c:S.comp) : A.term = + let mk (a:A.term') : A.term = + //augment `a` with its source position + //and an Unknown level (the level is unimportant ... we should maybe remove it altogether) + A.mk_term a c.pos A.Un + in + match (c.n) with + | Total typ -> + let t = resugar_term' env typ in + (* If --print_implicits, we print the Tot *) + if Options.print_implicits() + then mk (A.Construct(C.effect_Tot_lid, [(t, A.Nothing)])) + else t + + | GTotal typ -> + let t = resugar_term' env typ in + mk (A.Construct(C.effect_GTot_lid, [(t, A.Nothing)])) + + | Comp c -> + let result = (resugar_term' env c.result_typ, A.Nothing) in + let mk_decreases (fl : list cflag) : list A.term = + let rec aux l = function + | [] -> l + | hd::tl -> + match hd with + | DECREASES dec_order -> + let d = + match dec_order with + | Decreases_lex [t] -> // special casing for single term + resugar_term' env t + | Decreases_lex ts -> + mk (LexList (ts |> List.map (resugar_term' env))) + | Decreases_wf (rel, e) -> + mk (WFOrder (resugar_term' env rel, resugar_term' env e)) in + let e = mk (Decreases (d, None)) in + aux (e::l) tl + | _ -> aux l tl + in + aux [] fl + in + if lid_equals c.effect_name C.effect_Lemma_lid && List.length c.effect_args = 3 then + let args = List.map(fun (e,_) -> (resugar_term' env e, A.Nothing)) c.effect_args in + let pre, post, pats = + match c.effect_args with + | (pre, _)::(post, _)::(pats, _)::[] -> + pre, post, pats + | _ -> failwith "impossible" + in + let pre = (if U.is_fvar C.true_lid pre then [] else [pre]) in + let post = U.unthunk_lemma_post post in + let pats = if U.is_fvar C.nil_lid (U.head_of pats) then [] else [pats] in + + let pre = List.map (fun t -> mk (Requires (resugar_term' env t, None))) pre in + let post = mk (Ensures (resugar_term' env post, None)) in + let pats = List.map (resugar_term' env) pats in + let decrease = mk_decreases c.flags in + + mk (A.Construct(maybe_shorten_lid env c.effect_name, List.map (fun t -> (t, A.Nothing)) (pre@post::decrease@pats))) + + else if (Options.print_effect_args()) then + (* let universe = List.map (fun u -> resugar_universe u) c.comp_univs in *) + let args = List.map(fun (e,_) -> (resugar_term' env e, A.Nothing)) c.effect_args in + let decrease = List.map (fun t -> (t, A.Nothing)) (mk_decreases c.flags) in + mk (A.Construct(maybe_shorten_lid env c.effect_name, result::decrease@args)) + else + mk (A.Construct(maybe_shorten_lid env c.effect_name, [result])) + +and resugar_binder' env (b:S.binder) r : A.binder = + let imp = resugar_bqual env b.binder_qual in + let e = resugar_term' env b.binder_bv.sort in + let attrs = List.map (resugar_term' env) b.binder_attrs in + let b' = + match (e.tm) with + | A.Wild -> + A.Variable (bv_as_unique_ident b.binder_bv) + | _ -> + if S.is_null_bv b.binder_bv then + A.NoName e + else + A.Annotated (bv_as_unique_ident b.binder_bv, e) + in + A.mk_binder_with_attrs b' r A.Type_level imp attrs + +and resugar_bv_as_pat' env (v: S.bv) aqual (body_bv: FlatSet.t bv) typ_opt = + let mk a = A.mk_pattern a (S.range_of_bv v) in + let used = mem v body_bv in + let pat = + mk (if used + then A.PatVar (bv_as_unique_ident v, aqual, []) + else A.PatWild (aqual, [])) in + match typ_opt with + | None | Some { n = Tm_unknown } -> pat + | Some typ -> if Options.print_bound_var_types () + then mk (A.PatAscribed (pat, (resugar_term' env typ, None))) + else pat + +and resugar_bv_as_pat env (x:S.bv) qual body_bv: A.pattern = + let bq = resugar_bqual env qual in + resugar_bv_as_pat' env x bq body_bv (Some <| SS.compress x.sort) + +and resugar_pat' env (p:S.pat) (branch_bv: FlatSet.t bv) : A.pattern = + (* We lose information when desugar PatAscribed to able to resugar it back *) + let mk a = A.mk_pattern a p.p in + let to_arg_qual bopt = // FIXME do (Some false) and None mean the same thing? + BU.bind_opt bopt (fun b -> if b then Some A.Implicit else None) in + let must_print args = + args |> List.existsML (fun (pattern, is_implicit) -> + match pattern.v with + | Pat_var bv -> is_implicit && mem bv branch_bv + | _ -> false) + in + let resugar_plain_pat_cons' fv args = + mk (A.PatApp (mk (A.PatName fv.fv_name.v), args)) in + let rec resugar_plain_pat_cons fv args = + let args = + (* Special check here: if any of the args binds a variable used in + branch, we force printing implicits. *) + if not (must_print args) + then filter_pattern_imp args + else args + in + let args = List.map (fun (p, b) -> aux p (Some b)) args in + resugar_plain_pat_cons' fv args + and aux (p:S.pat) (imp_opt:option bool)= + match p.v with + | Pat_constant c -> mk (A.PatConst c) + + (* List patterns. *) + | Pat_cons(fv, _, args) + when lid_equals fv.fv_name.v C.nil_lid -> ( + match filter_pattern_imp args with + | [] -> mk (A.PatList []) + | _ -> resugar_plain_pat_cons fv args + ) + + | Pat_cons(fv, _, args) + when lid_equals fv.fv_name.v C.cons_lid -> ( + match filter_pattern_imp args with + | [(hd, false); (tl, false)] -> + let hd' = aux hd (Some false) in + (match aux tl (Some false) with + | { pat = A.PatList tl'; prange = p } -> A.mk_pattern (A.PatList (hd' :: tl')) p + | tl' -> resugar_plain_pat_cons' fv [hd'; tl']) + + | _ -> resugar_plain_pat_cons fv args + ) + + | Pat_cons (fv, _, []) -> + mk (A.PatName fv.fv_name.v) + + + | Pat_cons(fv, _, args) when (is_tuple_constructor_lid fv.fv_name.v + && not (must_print args)) -> + let args = + args |> + List.filter_map (fun (p, is_implicit) -> + if is_implicit then None else Some (aux p (Some false))) in + let is_dependent_tuple = C.is_dtuple_data_lid' fv.fv_name.v in + mk (A.PatTuple (args, is_dependent_tuple)) + + | Pat_cons({fv_qual=Some (Record_ctor(name, fields))}, _, args) -> + // reverse the fields and args list to match them since the args added by the type checker + // are inserted in the front of the args list. + let fields = fields |> List.map (fun f -> FStarC.Ident.lid_of_ids [f]) |> List.rev in + let args = args |> List.map (fun (p, b) -> aux p (Some b)) |> List.rev in + // make sure the fields and args are of the same length. + let rec map2 l1 l2 = match (l1, l2) with + | ([], []) -> [] + | ([], hd::tl) -> [] (* new args could be added by the type checker *) + | (hd::tl, []) -> (hd, mk (A.PatWild (None, []))) :: map2 tl [] (* no new fields should be added*) + | (hd1::tl1, hd2::tl2) -> (hd1, hd2) :: map2 tl1 tl2 + in + // reverse back the args list + let args = map2 fields args |> List.rev in + mk (A.PatRecord(args)) + + | Pat_cons (fv, _, args) -> + resugar_plain_pat_cons fv args + + | Pat_var v -> + // both A.PatTvar and A.PatVar are desugared to S.Pat_var. A PatTvar in the original file coresponds + // to some type variable which is implicitly bound to the enclosing toplevel declaration. + // When resugaring it will be just a normal (explicitly bound) variable. + begin match string_to_op (string_of_id v.ppname) with + | Some (op, _) -> mk (A.PatOp (Ident.mk_ident (op, (range_of_id v.ppname)))) + | None -> resugar_bv_as_pat' env v (to_arg_qual imp_opt) branch_bv None + end + + // FIXME: detect unused patterns + (* | Pat_wild _ -> mk (A.PatWild (to_arg_qual imp_opt, [])) *) + + | Pat_dot_term _ -> mk (A.PatWild (Some A.Implicit, [])) + in + aux p None +// FIXME inspect uses of resugar_arg_qual and resugar_imp +(* If resugar_arg_qual returns None, the corresponding binder should *not* be resugared *) +and resugar_bqual env (q:S.bqual) : option A.arg_qualifier = + match q with + | None -> None + | Some (S.Implicit b) -> Some A.Implicit + | Some S.Equality -> Some A.Equality + | Some (S.Meta t) when U.is_fvar C.tcresolve_lid t -> Some (A.TypeClassArg) + | Some (S.Meta t) -> Some (A.Meta (resugar_term' env t)) + +and resugar_aqual env (q:S.aqual) : A.imp = + match q with + | None -> A.Nothing + | Some a -> if a.aqual_implicit then A.Hash else A.Nothing + +let resugar_qualifier : S.qualifier -> option A.qualifier = function + | S.Assumption -> Some A.Assumption + | S.InternalAssumption -> None + | S.New -> Some A.New + | S.Private -> Some A.Private + | S.Unfold_for_unification_and_vcgen -> Some A.Unfold_for_unification_and_vcgen + (* TODO : Find the correct option to display this *) + | Visible_default -> if true then None else Some A.Visible + | S.Irreducible -> Some A.Irreducible + | S.Inline_for_extraction -> Some A.Inline_for_extraction + | S.NoExtract -> Some A.NoExtract + | S.Noeq -> Some A.Noeq + | S.Unopteq -> Some A.Unopteq + | S.TotalEffect -> Some A.TotalEffect + (* TODO : Find the correct option to display this *) + | S.Logic -> if true then None else Some A.Logic + | S.Reifiable -> Some A.Reifiable + | S.Reflectable _ -> Some A.Reflectable + | S.Discriminator _ -> None + | S.Projector _ -> None + | S.RecordType _ -> None + | S.RecordConstructor _ -> None + | S.Action _ -> None + | S.ExceptionConstructor -> None + | S.HasMaskedEffect -> None + | S.Effect -> Some A.Effect_qual + | S.OnlyName -> None + + +let resugar_pragma = function + | S.ShowOptions -> A.ShowOptions + | S.SetOptions s -> A.SetOptions s + | S.ResetOptions s -> A.ResetOptions s + | S.PushOptions s -> A.PushOptions s + | S.PopOptions -> A.PopOptions + | S.RestartSolver -> A.RestartSolver + | S.PrintEffectsGraph -> A.PrintEffectsGraph + +(* drop the first n binders (implicit or explicit) from an arrow type *) +let drop_n_bs (n:int) (t:S.term) : S.term = + let bs, c = U.arrow_formals_comp_ln t in + let bs = List.splitAt n bs |> snd in + U.arrow bs c + +let resugar_typ env datacon_ses se : sigelts & A.tycon = + match se.sigel with + | Sig_inductive_typ {lid=tylid;us=uvs;params=bs;t;ds=datacons} -> + let current_datacons, other_datacons = datacon_ses |> List.partition (fun se -> match se.sigel with + | Sig_datacon {ty_lid=inductive_lid} -> lid_equals inductive_lid tylid + | _ -> failwith "unexpected" ) + in + assert (List.length current_datacons = List.length datacons) ; + let bs = filter_imp_bs bs in + let bs = bs |> map (fun b -> resugar_binder' env b t.pos) in + let tyc = + if se.sigquals |> BU.for_some RecordType? && List.length current_datacons = 1 then + (* Resugar as a record. There must be a single constructor *) + let [dc] = current_datacons in + match dc.sigel with + | Sig_datacon {lid=l; us=univs; t=typ; num_ty_params=num} -> + let typ = drop_n_bs num typ in + let fields = + let bs, _ = U.arrow_formals_comp_ln typ in + let bs = filter_imp_bs bs in + bs |> List.map (fun b -> + let q = resugar_bqual env b.binder_qual in + (bv_as_unique_ident b.binder_bv, q, b.binder_attrs |> List.map (resugar_term' env), resugar_term' env b.binder_bv.sort) + ) + in + A.TyconRecord (ident_of_lid tylid, bs, None, map (resugar_term' env) se.sigattrs, fields) + | _ -> failwith "ggg1" + else + (* Resugar as a variant *) + let resugar_datacon constructors se = match se.sigel with + | Sig_datacon {lid=l; us=univs; t=typ; num_ty_params=num} -> + let typ = drop_n_bs num typ in + (* Todo: resugar univs *) + let c = (ident_of_lid l, Some (VpArbitrary (resugar_term' env typ)), map (resugar_term' env) se.sigattrs) in + c::constructors + | _ -> failwith "unexpected" + in + let constructors = List.fold_left resugar_datacon [] current_datacons in + A.TyconVariant (ident_of_lid tylid, bs, None, constructors) + in + other_datacons, tyc + | _ -> failwith "Impossible : only Sig_inductive_typ can be resugared as types" + +let mk_decl r q d' = + { + d = d' ; + drange = r ; + quals = List.choose resugar_qualifier q ; + attrs = [] ; // We fill in the attrs in resugar_sigelt' + interleaved = false; + } + +let decl'_to_decl se d' = + mk_decl se.sigrng se.sigquals d' + +let resugar_tscheme'' env name (ts:S.tscheme) = + let (univs, typ) = ts in + let name = I.mk_ident (name, typ.pos) in + mk_decl typ.pos [] (A.Tycon(false, false, [(A.TyconAbbrev(name, [], None, resugar_term' env typ))])) + +let resugar_tscheme' env (ts:S.tscheme) = + resugar_tscheme'' env "tscheme" ts + +let resugar_wp_eff_combinators env for_free combs = + let resugar_opt name tsopt = + match tsopt with + | Some ts -> [resugar_tscheme'' env name ts] + | None -> [] in + + let repr = resugar_opt "repr" combs.repr in + let return_repr = resugar_opt "return_repr" combs.return_repr in + let bind_repr = resugar_opt "bind_repr" combs.bind_repr in + + if for_free then repr@return_repr@bind_repr + else + (resugar_tscheme'' env "ret_wp" combs.ret_wp):: + (resugar_tscheme'' env "bind_wp" combs.bind_wp):: + (resugar_tscheme'' env "stronger" combs.stronger):: + (resugar_tscheme'' env "if_then_else" combs.if_then_else):: + (resugar_tscheme'' env "ite_wp" combs.ite_wp):: + (resugar_tscheme'' env "close_wp" combs.close_wp):: + (resugar_tscheme'' env "trivial" combs.trivial):: + (repr@return_repr@bind_repr) + +let resugar_layered_eff_combinators env combs = + let resugar name (ts, _, _) = resugar_tscheme'' env name ts in + let resugar2 name (ts, _) = resugar_tscheme'' env name ts in + + (resugar2 "repr" combs.l_repr):: + (resugar2 "return" combs.l_return):: + (resugar "bind" combs.l_bind):: + (resugar "subcomp" combs.l_subcomp):: + (resugar "if_then_else" combs.l_if_then_else)::[] + +let resugar_combinators env combs = + match combs with + | Primitive_eff combs -> resugar_wp_eff_combinators env false combs + | DM4F_eff combs -> resugar_wp_eff_combinators env true combs + | Layered_eff combs -> resugar_layered_eff_combinators env combs + +let resugar_eff_decl' env ed = + let r = Range.dummyRange in + let q = [] in + let resugar_action d for_free = + let action_params = SS.open_binders d.action_params in + let bs, action_defn = SS.open_term action_params d.action_defn in + let bs, action_typ = SS.open_term action_params d.action_typ in + let action_params = filter_imp_bs action_params in + let action_params = action_params |> map (fun b -> resugar_binder' env b r) |> List.rev in + let action_defn = resugar_term' env action_defn in + let action_typ = resugar_term' env action_typ in + if for_free then + let a = A.Construct ((I.lid_of_str "construct"), [(action_defn, A.Nothing);(action_typ, A.Nothing)]) in + let t = A.mk_term a r A.Un in + mk_decl r q (A.Tycon(false, false, [(A.TyconAbbrev(ident_of_lid d.action_name, action_params, None, t ))])) + else + mk_decl r q (A.Tycon(false, false, [(A.TyconAbbrev(ident_of_lid d.action_name, action_params, None, action_defn))])) + in + let eff_name = ident_of_lid ed.mname in + let eff_binders, eff_typ = + let sig_ts = U.effect_sig_ts ed.signature in + SS.open_term ed.binders (sig_ts |> snd) in + let eff_binders = filter_imp_bs eff_binders in + let eff_binders = eff_binders |> map (fun b -> resugar_binder' env b r) |> List.rev in + let eff_typ = resugar_term' env eff_typ in + + let mandatory_members_decls = resugar_combinators env ed.combinators in + + let actions = ed.actions |> List.map (fun a -> resugar_action a false) in + let decls = mandatory_members_decls@actions in + mk_decl r q (A.NewEffect(DefineEffect(eff_name, eff_binders, eff_typ, decls))) + +let resugar_sigelt' env se : option A.decl = + let d = (match se.sigel with + | Sig_bundle {ses} -> + let decl_typ_ses, datacon_ses = ses |> List.partition + (fun se -> match se.sigel with + | Sig_inductive_typ _ | Sig_declare_typ _ -> true + | Sig_datacon _ -> false + | _ -> failwith "Found a sigelt which is neither a type declaration or a data constructor in a sigelt" + ) + in + let retrieve_datacons_and_resugar (datacon_ses, tycons) se = + let datacon_ses, tyc = resugar_typ env datacon_ses se in + datacon_ses, tyc::tycons + in + let leftover_datacons, tycons = List.fold_left retrieve_datacons_and_resugar (datacon_ses, []) decl_typ_ses in + begin match leftover_datacons with + | [] -> //true + (* TODO : documentation should be retrieved from the desugaring environment at some point *) + Some (decl'_to_decl se (Tycon (false, false, tycons))) + | [se] -> + //assert (se.sigquals |> BU.for_some (function | ExceptionConstructor -> true | _ -> false)); + (* Exception constructor declaration case *) + begin match se.sigel with + | Sig_datacon {lid=l} -> + Some (decl'_to_decl se (A.Exception (ident_of_lid l, None))) + | _ -> failwith "wrong format for resguar to Exception" + end + | _ -> + failwith "Should not happen hopefully" + end + + | Sig_fail _ -> + None + + | Sig_let {lbs} -> + if (se.sigquals |> BU.for_some (function S.Projector(_,_) | S.Discriminator _ -> true | _ -> false)) then + None + else + let mk e = S.mk e se.sigrng in + let dummy = mk Tm_unknown in + (* This function turns each resolved top-level lid being defined into an + * ident without a path, so it gets printed correctly. *) + let nopath_lbs ((is_rec, lbs) : letbindings) : letbindings = + let nopath fv = lid_as_fv (lid_of_ids [ident_of_lid (lid_of_fv fv)]) None in + let lbs = List.map (fun lb -> { lb with lbname = Inr (nopath <| right lb.lbname)} ) lbs in + (is_rec, lbs) + in + let lbs = nopath_lbs lbs in + let desugared_let = mk (Tm_let {lbs; body=dummy}) in + let t = resugar_term' env desugared_let in + begin match t.tm with + | A.Let(isrec, lets, _) -> + Some (decl'_to_decl se (TopLevelLet (isrec, List.map snd lets))) + | _ -> failwith "Should not happen hopefully" + end + + | Sig_assume {lid; phi=fml} -> + Some (decl'_to_decl se (Assume (ident_of_lid lid, resugar_term' env fml))) + + | Sig_new_effect ed -> + let a_decl = resugar_eff_decl' env ed in + let q = List.choose resugar_qualifier se.sigquals in + Some { a_decl with quals = q } + + | Sig_sub_effect e -> + let src = e.source in + let dst = e.target in + let lift_wp = match e.lift_wp with + | Some (_, t) -> + Some (resugar_term' env t) + | _ -> None + in + let lift = match e.lift with + | Some (_, t) -> + Some (resugar_term' env t) + | _ -> None + in + let op = match (lift_wp, lift) with + | Some t, None -> A.NonReifiableLift t + | Some wp, Some t -> A.ReifiableLift (wp, t) + | None, Some t -> A.LiftForFree t + | _ -> failwith "Should not happen hopefully" + in + Some (decl'_to_decl se (A.SubEffect({msource=src; mdest=dst; lift_op=op; braced=false}))) + + | Sig_effect_abbrev {lid; us=vs; bs; comp=c; cflags=flags} -> + let bs, c = SS.open_comp bs c in + let bs = filter_imp_bs bs in + let bs = bs |> map (fun b -> resugar_binder' env b se.sigrng) in + Some (decl'_to_decl se (A.Tycon(false, false, [A.TyconAbbrev(ident_of_lid lid, bs, None, resugar_comp' env c)]))) + + | Sig_pragma p -> + Some (decl'_to_decl se (A.Pragma (resugar_pragma p))) + + | Sig_declare_typ {lid; us=uvs; t} -> + if (se.sigquals |> BU.for_some (function S.Projector(_,_) | S.Discriminator _ -> true | _ -> false)) then + None + else + let t' = + if not (Options.print_universes ()) || isEmpty uvs then resugar_term' env t + else + let uvs, t = SS.open_univ_vars uvs t in + let universes = universe_to_string uvs in + label universes (resugar_term' env t) + in + Some (decl'_to_decl se (A.Val (ident_of_lid lid,t'))) + + | Sig_splice {is_typed; lids=ids; tac=t} -> + Some (decl'_to_decl se (A.Splice (is_typed, List.map (fun l -> ident_of_lid l) ids, resugar_term' env t))) + + (* Already desugared in one of the above case or non-relevant *) + | Sig_inductive_typ _ + | Sig_datacon _ -> None + + | Sig_polymonadic_bind {m_lid=m; n_lid=n; p_lid=p; tm=(_, t)} -> + Some (decl'_to_decl se (A.Polymonadic_bind (m, n, p, resugar_term' env t))) + + | Sig_polymonadic_subcomp {m_lid=m; n_lid=n; tm=(_, t)} -> + Some (decl'_to_decl se (A.Polymonadic_subcomp (m, n, resugar_term' env t)))) in + + match d with + | Some d -> Some { d with attrs = List.map (resugar_term' env) se.sigattrs } + | None -> None + +(* Old interface: no envs *) + +let empty_env = DsEnv.empty_env FStarC.Parser.Dep.empty_deps //dep graph not needed for resugaring + +let noenv (f: DsEnv.env -> 'a) : 'a = + f empty_env + +let resugar_term (t : S.term) : A.term = + noenv resugar_term' t + +let resugar_sigelt se : option A.decl = + noenv resugar_sigelt' se + +let resugar_comp (c:S.comp) : A.term = + noenv resugar_comp' c + +let resugar_pat (p:S.pat) (branch_bv: FlatSet.t bv) : A.pattern = + noenv resugar_pat' p branch_bv + +let resugar_binder (b:S.binder) r : A.binder = + noenv resugar_binder' b r + +let resugar_tscheme (ts:S.tscheme) = + noenv resugar_tscheme' ts + +let resugar_eff_decl ed = + noenv resugar_eff_decl' ed diff --git a/src/syntax/FStarC.Syntax.Resugar.fsti b/src/syntax/FStarC.Syntax.Resugar.fsti new file mode 100644 index 00000000000..b0b15b5ce92 --- /dev/null +++ b/src/syntax/FStarC.Syntax.Resugar.fsti @@ -0,0 +1,52 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Syntax.Resugar //we should rename FStarC.ToSyntax to something else + +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Syntax.Syntax +open FStarC.Ident +open FStarC.Compiler.Util +open FStarC.Const +open FStarC.Compiler.Range + +module I = FStarC.Ident +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module A = FStarC.Parser.AST +module C = FStarC.Parser.Const +module U = FStarC.Syntax.Util +module BU = FStarC.Compiler.Util +module Range = FStarC.Compiler.Range +module DsEnv = FStarC.Syntax.DsEnv + +val resugar_term: S.term -> A.term +val resugar_sigelt: S.sigelt -> option A.decl +val resugar_comp: S.comp -> A.term +val resugar_pat: S.pat -> FlatSet.t S.bv -> A.pattern +val resugar_universe: S.universe -> Range.range -> A.term +val resugar_binder: S.binder -> Range.range -> A.binder +val resugar_tscheme: S.tscheme -> A.decl +val resugar_eff_decl: eff_decl -> A.decl + +val resugar_term': DsEnv.env -> S.term -> A.term +val resugar_sigelt': DsEnv.env -> S.sigelt -> option A.decl +val resugar_comp': DsEnv.env -> S.comp -> A.term +val resugar_pat': DsEnv.env -> S.pat -> FlatSet.t S.bv -> A.pattern +val resugar_universe': DsEnv.env -> S.universe -> Range.range -> A.term +val resugar_binder': DsEnv.env -> S.binder -> Range.range -> A.binder +val resugar_tscheme': DsEnv.env -> S.tscheme -> A.decl +val resugar_eff_decl': DsEnv.env -> eff_decl -> A.decl diff --git a/src/syntax/FStarC.Syntax.Subst.fst b/src/syntax/FStarC.Syntax.Subst.fst new file mode 100644 index 00000000000..80bf56d443e --- /dev/null +++ b/src/syntax/FStarC.Syntax.Subst.fst @@ -0,0 +1,813 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Syntax.Subst +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Range +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.Compiler.Util +open FStarC.Ident + +module Err = FStarC.Errors +module U = FStarC.Compiler.Util +module S = FStarC.Syntax.Syntax + +/////////////////////////////////////////////////////////////////////////// +// A few utility functions for working with lists of parallel substitutions +/////////////////////////////////////////////////////////////////////////// + +(* A subst_t is a composition of parallel substitutions, expressed as a list of lists *) +let subst_to_string s = + s |> List.map (fun (b, _) -> (string_of_id b.ppname)) |> String.concat ", " + +(* apply_until_some f s + applies f to each element of s until it returns (Some t) +*) +let rec apply_until_some f s = + match s with + | [] -> None + | s0::rest -> + match f s0 with + | None -> apply_until_some f rest + | Some st -> Some (rest, st) + +let map_some_curry f x = function + | None -> x + | Some (a, b) -> f a b + +let apply_until_some_then_map f s g t = + apply_until_some f s + |> map_some_curry g t +///////////////////////////////////////////////////////////////////////// + + +//s1 is the subsitution already associated with this node; +//s2 is the new subsitution to add to it +//compose substitutions by concatenating them +//the order of concatenation is important! +//the range of s2 take precedence, if present +let compose_subst s1 s2 = + let s = fst s1 @ fst s2 in + let ropt = match snd s2 with + | SomeUseRange _ -> snd s2 + | _ -> snd s1 in + (s, ropt) + +//apply a delayed substitution s to t, +//composing it with any other delayed substitution that may already be there +let delay t s = + match t.n with + | Tm_delayed {tm=t'; substs=s'} -> + //s' is the subsitution already associated with this node; + //s is the new subsitution to add to it + //compose substitutions by concatenating them + //the order of concatenation is important! + mk_Tm_delayed (t', compose_subst s' s) t.pos + | _ -> + mk_Tm_delayed (t, s) t.pos + +(* + force_uvar' (t:term) : term * bool + replaces any unification variable at the head of t + with the term that it has been fixed to, if any. + + Also returns `true`, if it actually resolved the uvar at the head + `false` otherwise + + Warning: if force_uvar changes to operate on inputs other + than Tm_uvar then the fastpath out match in compress will + need to be updated. +*) +let rec force_uvar' t = + match t.n with + | Tm_uvar ({ctx_uvar_head=uv}, s) -> + (match Unionfind.find uv with + | Some t' -> fst (force_uvar' (delay t' s)), true + | _ -> t, false) + | _ -> t, false + +//wraps force_uvar' to propagate any position information +//from the uvar to anything it may have been resolved to +let force_uvar t = + let t', forced = force_uvar' t in + if forced + then delay t' ([], SomeUseRange t.pos) + else t + +let rec compress_univ u = match u with + | U_unif u' -> + begin match Unionfind.univ_find u' with + | Some u -> compress_univ u + | _ -> u + end + | _ -> u + +(********************************************************************************) +(*************************** Delayed substitutions ******************************) +(********************************************************************************) + +//Lookup a bound var or a name in a parallel substitution +let subst_bv a s = U.find_map s (function + | DB (i, x) when (i=a.index) -> + Some (bv_to_name (Syntax.set_range_of_bv x (Syntax.range_of_bv a))) + | DT (i, t) when (i=a.index) -> + Some t + | _ -> None) +let subst_nm a s = U.find_map s (function + | NM (x, i) when bv_eq a x -> Some (bv_to_tm ({a with index=i})) + | NT (x, t) when bv_eq a x -> Some t + | _ -> None) +let subst_univ_bv x s = U.find_map s (function + | UN(y, t) when (x=y) -> Some t + | _ -> None) +let subst_univ_nm (x:univ_name) s = U.find_map s (function + | UD(y, i) when (ident_equals x y) -> Some (U_bvar i) + | _ -> None) + +let rec subst_univ s u = + let u = compress_univ u in + match u with + | U_bvar x -> + apply_until_some_then_map (subst_univ_bv x) s subst_univ u + + | U_name x -> + apply_until_some_then_map (subst_univ_nm x) s subst_univ u + + | U_zero + | U_unknown + | U_unif _ -> u + | U_succ u -> U_succ (subst_univ s u) + | U_max us -> U_max (List.map (subst_univ s) us) + +let tag_with_range t s = + match snd s with + | NoUseRange -> t + | SomeUseRange r -> + if Range.rng_included (Range.use_range t.pos) (Range.use_range r) + then t + else begin + let r = Range.set_use_range t.pos (Range.use_range r) in + let t' = match t.n with + | Tm_bvar bv -> Tm_bvar (Syntax.set_range_of_bv bv r) + | Tm_name bv -> Tm_name (Syntax.set_range_of_bv bv r) + | Tm_fvar fv -> let l = Syntax.lid_of_fv fv in + let v = {fv.fv_name with v=Ident.set_lid_range l r} in + let fv = {fv with fv_name=v} in + Tm_fvar fv + | t' -> t' in + {t with n=t'; pos=r} + end + +let tag_lid_with_range l s = + match (snd s) with + | NoUseRange -> l + | SomeUseRange r -> + if Range.rng_included (Range.use_range (Ident.range_of_lid l)) (Range.use_range r) + then l + else Ident.set_lid_range l (Range.set_use_range (Ident.range_of_lid l) (Range.use_range r)) + +let mk_range r (s:subst_ts) = + match snd s with + | NoUseRange -> r + | SomeUseRange r' -> + if Range.rng_included (Range.use_range r) (Range.use_range r') + then r + else Range.set_use_range r (Range.use_range r') + +(* Applies a substitution to a node, + immediately if it is a variable + or builds a delayed node otherwise *) +let rec subst' (s:subst_ts) (t:term) : term = + let subst_tail (tl:list (list subst_elt)) = subst' (tl, snd s) in + match s with + | [], NoUseRange + | [[]], NoUseRange -> t + | _ -> + let t0 = t in + match t0.n with + | Tm_unknown + | Tm_constant _ //a constant cannot be substituted + | Tm_fvar _ -> tag_with_range t0 s //fvars are never subject to substitution + + | Tm_delayed {tm=t';substs=s'} -> + //s' is the subsitution already associated with this node; + //s is the new subsitution to add to it + //compose substitutions by concatenating them + //the order of concatenation is important! + mk_Tm_delayed (t', compose_subst s' s) t.pos + + | Tm_bvar a -> + apply_until_some_then_map (subst_bv a) (fst s) subst_tail t0 + + | Tm_name a -> + apply_until_some_then_map (subst_nm a) (fst s) subst_tail t0 + + | Tm_type u -> + mk (Tm_type (subst_univ (fst s) u)) (mk_range t0.pos s) + + | _ -> + //NS: 04/12/2018 + // Substitutions on Tm_uvar just gets delayed + // since its solution may eventually end up being an open term + mk_Tm_delayed (t0, s) (mk_range t.pos s) + +let subst_dec_order' s = function + | Decreases_lex l -> Decreases_lex (l |> List.map (subst' s)) + | Decreases_wf (rel, e) -> Decreases_wf (subst' s rel, subst' s e) + +let subst_flags' s flags = + flags |> List.map (function + | DECREASES dec_order -> DECREASES (subst_dec_order' s dec_order) + | f -> f) + +let subst_bqual' s i = + match i with + | Some (Meta t) -> Some (Meta (subst' s t)) + | _ -> i + +let subst_aqual' s (i:aqual) : aqual = + match i with + | None -> None + | Some a -> Some ({a with aqual_attributes = List.map (subst' s) a.aqual_attributes }) + +let subst_comp_typ' s t = + match s with + | [], NoUseRange + | [[]], NoUseRange -> t + | _ -> + {t with effect_name=tag_lid_with_range t.effect_name s; + comp_univs=List.map (subst_univ (fst s)) t.comp_univs; + result_typ=subst' s t.result_typ; + flags=subst_flags' s t.flags; + effect_args=List.map (fun (t, imp) -> subst' s t, subst_aqual' s imp) t.effect_args} + +let subst_comp' s t = + match s with + | [], NoUseRange + | [[]], NoUseRange -> t + | _ -> + match t.n with + | Total t -> mk_Total (subst' s t) + | GTotal t -> mk_GTotal (subst' s t) + | Comp ct -> mk_Comp(subst_comp_typ' s ct) + +let subst_ascription' s (asc:ascription) = + let annot, topt, use_eq = asc in + let annot = match annot with + | Inl t -> Inl (subst' s t) + | Inr c -> Inr (subst_comp' s c) in + annot, + U.map_opt topt (subst' s), + use_eq + +let shift n s = match s with + | DB(i, t) -> DB(i+n, t) + | DT(i, t) -> DT(i+n, t) + | UN(i, t) -> UN(i+n, t) + | NM(x, i) -> NM(x, i+n) + | UD(x, i) -> UD(x, i+n) + | NT _ -> s +let shift_subst n s = List.map (shift n) s +let shift_subst' n s = fst s |> List.map (shift_subst n), snd s +let subst_binder' s b = + S.mk_binder_with_attrs + ({ b.binder_bv with sort = subst' s b.binder_bv.sort }) + (subst_bqual' s b.binder_qual) + b.binder_positivity + (b.binder_attrs |> List.map (subst' s)) + +let subst_binder s (b:binder) = subst_binder' ([s], NoUseRange) b + +let subst_binders' s bs = + bs |> List.mapi (fun i b -> + if i=0 then subst_binder' s b + else subst_binder' (shift_subst' i s) b) +let subst_binders s (bs:binders) = subst_binders' ([s], NoUseRange) bs + + +// NOTE: We don't descend into `imp` here since one cannot *apply* a +// `Meta t` argument, so this would always be a no-op +let subst_arg' s (t, imp) = (subst' s t, imp) + +let subst_args' s = List.map (subst_arg' s) + +let subst_univs_opt sub us_opt = + match us_opt with + | None -> None + | Some us -> Some (List.map (subst_univ sub) us) + +let subst_pat' s p : (pat & int) = + let rec aux n p : (pat & int) = match p.v with + | Pat_constant _ -> p, n + + | Pat_cons(fv, us_opt, pats) -> + let us_opt = subst_univs_opt (fst (shift_subst' n s)) us_opt in + let pats, n = pats |> List.fold_left (fun (pats, n) (p, imp) -> + let p, m = aux n p in + ((p,imp)::pats, m)) ([], n) in + {p with v=Pat_cons(fv, us_opt, List.rev pats)}, n + + | Pat_var x -> + let s = shift_subst' n s in + let x = {x with sort=subst' s x.sort} in + {p with v=Pat_var x}, n + 1 + + | Pat_dot_term eopt -> + let s = shift_subst' n s in + let eopt = U.map_option (subst' s) eopt in + {p with v=Pat_dot_term eopt}, n + in aux 0 p + +let push_subst_lcomp s lopt = match lopt with + | None -> None + | Some rc -> + let residual_typ = U.map_opt rc.residual_typ (subst' s) in + (* NB: residual flags MUST be closed. DECREASES cannot + appear there *) + let rc = { residual_effect = rc.residual_effect + ; residual_typ = residual_typ + ; residual_flags = rc.residual_flags } in + Some rc + +let compose_uvar_subst (u:ctx_uvar) (s0:subst_ts) (s:subst_ts) : subst_ts = + let should_retain x = + u.ctx_uvar_binders |> U.for_some (fun b -> S.bv_eq x b.binder_bv) + in + let rec aux = function + | [] -> [] + | hd_subst::rest -> + let hd = + hd_subst |> List.collect (function + | NT(x, t) -> + if should_retain x + then [NT(x, delay t (rest, NoUseRange))] + else [] + | NM(x, i) -> + if should_retain x + then let x_i = S.bv_to_tm ({x with index=i}) in + let t = subst' (rest, NoUseRange) x_i in + match t.n with + | Tm_bvar x_j -> [NM(x, x_j.index)] + | _ -> [NT(x, t)] + else [] + | _ -> []) + in + hd @ aux rest + in + match aux (fst s0 @ fst s) with + | [] -> [], snd s + | s' -> [s'], snd s + +// +// If resolve_uvars is true, it will lookup the unionfind graph +// and use uvar solution, if it has already been solved +// see the Tm_uvar case in this function +// Otherwise it will just compose s with the uvar subst +// +let rec push_subst_aux (resolve_uvars:bool) s t = + //makes a syntax node, setting it's use range as appropriate from s + let mk t' = Syntax.mk t' (mk_range t.pos s) in + match t.n with + | Tm_delayed _ -> failwith "Impossible (delayed node in push_subst)" + + | Tm_lazy i -> + begin match i.lkind with + | Lazy_embedding _ -> + (* These might be open! Just unfold and descend. + * The hope is that this does not occur often and so + * we still get good performance. *) + let t = must !lazy_chooser i.lkind i in // Can't call Syntax.Util from here + push_subst_aux resolve_uvars s t + | _ -> + (* All others must be closed, so don't bother *) + tag_with_range t s + end + + | Tm_constant _ + | Tm_fvar _ + | Tm_unknown -> tag_with_range t s //these are always closed + + | Tm_uvar (uv, s0) -> + let fallback () = + tag_with_range ({t with n = Tm_uvar(uv, compose_uvar_subst uv s0 s)}) s + in + if not resolve_uvars + then fallback () + else (match (Unionfind.find uv.ctx_uvar_head) with + | None -> fallback () + | Some t -> push_subst_aux resolve_uvars (compose_subst s0 s) t) + + | Tm_type _ + | Tm_bvar _ + | Tm_name _ -> subst' s t + + | Tm_uinst(t', us) -> + //t' must be an fvar---it cannot be substituted + //but the universes may be substituted + let us = List.map (subst_univ (fst s)) us in + tag_with_range (mk (Tm_uinst (t', us))) s + + | Tm_app {hd=t0; args} -> mk (Tm_app {hd=subst' s t0; args=subst_args' s args}) + + | Tm_ascribed {tm=t0; asc; eff_opt=lopt} -> + mk (Tm_ascribed {tm=subst' s t0; asc=subst_ascription' s asc; eff_opt=lopt}) + + | Tm_abs {bs; body; rc_opt=lopt} -> + let n = List.length bs in + let s' = shift_subst' n s in + mk (Tm_abs {bs=subst_binders' s bs; body=subst' s' body; rc_opt=push_subst_lcomp s' lopt}) + + | Tm_arrow {bs; comp} -> + let n = List.length bs in + mk (Tm_arrow {bs=subst_binders' s bs;comp=subst_comp' (shift_subst' n s) comp}) + + | Tm_refine {b=x; phi} -> + let x = {x with sort=subst' s x.sort} in + let phi = subst' (shift_subst' 1 s) phi in + mk (Tm_refine {b=x; phi}) + + | Tm_match {scrutinee=t0; ret_opt=asc_opt; brs=pats; rc_opt=lopt} -> + let t0 = subst' s t0 in + let pats = pats |> List.map (fun (pat, wopt, branch) -> + let pat, n = subst_pat' s pat in + let s = shift_subst' n s in + let wopt = match wopt with + | None -> None + | Some w -> Some (subst' s w) in + let branch = subst' s branch in + (pat, wopt, branch)) in + let asc_opt = + match asc_opt with + | None -> None + | Some (b, asc) -> + let b = subst_binder' s b in + let asc = subst_ascription' (shift_subst' 1 s) asc in + Some (b, asc) in + mk (Tm_match {scrutinee=t0; ret_opt=asc_opt; brs=pats; rc_opt=push_subst_lcomp s lopt}) + + | Tm_let {lbs=(is_rec, lbs); body} -> + let n = List.length lbs in + let sn = shift_subst' n s in + let body = subst' sn body in + let lbs = lbs |> List.map (fun lb -> + let lbt = subst' s lb.lbtyp in + let lbd = if is_rec && U.is_left (lb.lbname) //if it is a recursive local let, then all the let bound names are in scope for the body + then subst' sn lb.lbdef + else subst' s lb.lbdef in + let lbname = match lb.lbname with + | Inl x -> Inl ({x with sort=lbt}) + | Inr fv -> Inr fv + in + let lbattrs = List.map (subst' s) lb.lbattrs in + {lb with lbname=lbname; lbtyp=lbt; lbdef=lbd; lbattrs=lbattrs}) in + mk (Tm_let {lbs=(is_rec, lbs); body}) + + | Tm_meta {tm=t0; meta=Meta_pattern (bs, ps)} -> + mk (Tm_meta {tm=subst' s t0; meta=Meta_pattern (List.map (subst' s) bs, ps |> List.map (subst_args' s))}) + + | Tm_meta {tm=t0; meta=Meta_monadic (m, t)} -> + mk (Tm_meta {tm=subst' s t0; meta=Meta_monadic(m, subst' s t)}) + + | Tm_meta {tm=t0; meta=Meta_monadic_lift (m1, m2, t)} -> + mk (Tm_meta {tm=subst' s t0; meta=Meta_monadic_lift (m1, m2, subst' s t)}) + + | Tm_quoted (tm, qi) -> + begin match qi.qkind with + | Quote_dynamic -> mk (Tm_quoted (subst' s tm, qi)) + | Quote_static -> + let qi = on_antiquoted (subst' s) qi in + mk (Tm_quoted (tm, qi)) + end + + | Tm_meta {tm=t; meta=m} -> + mk (Tm_meta {tm=subst' s t; meta=m}) + +let push_subst s t = push_subst_aux true s t + +// +// Only push the pending substitution down, +// no resolving uvars +// +let compress_subst t = + match t.n with + | Tm_delayed {tm=t; substs=s} -> + let resolve_uvars = false in + push_subst_aux resolve_uvars s t + | _ -> t + +(* compress: + This is used pervasively, throughout the codebase + + The recommended use for inspecting a term + is to first call compress on it, which should + 1. push delayed substitutions down one level + + 2. eliminate any top-level (Tm_uvar uv) node, + when uv has been assigned a solution already + + `compress` should will *not* memoize the result of uvar + solutions (since those could be reverted), nor the result + of `push_subst` (since it internally uses the unionfind + graph too). + + The function is broken into a fast-path where the + result can be easily determined and a recursive slow + path. + + Warning: if force_uvar changes to operate on inputs other than + Tm_uvar then the fastpath out match in compress will need to be + updated. + + This function should NEVER return a Tm_delayed. If you do any + non-trivial change to it, it would be wise to uncomment the check + below and run a full regression build. +*) +let rec compress_slow (t:term) = + let t = force_uvar t in + match t.n with + | Tm_delayed {tm=t'; substs=s} -> + compress (push_subst s t') + | _ -> + t +and compress (t:term) = + match t.n with + | Tm_delayed _ | Tm_uvar _ -> + let r = compress_slow t in + (* begin match r.n with *) + (* | Tm_delayed _ -> failwith "compress attempting to return a Tm_delayed" *) + (* | _ -> () *) + (* end; *) + r + | _ -> + t + +let subst s t = subst' ([s], NoUseRange) t +let set_use_range r t = subst' ([], SomeUseRange (Range.set_def_range r (Range.use_range r))) t +let subst_comp s t = subst_comp' ([s], NoUseRange) t +let subst_bqual s imp = subst_bqual' ([s], NoUseRange) imp +let subst_aqual s imp = subst_aqual' ([s], NoUseRange) imp +let subst_ascription s (asc:ascription) = subst_ascription' ([s], NoUseRange) asc +let subst_decreasing_order s dec = subst_dec_order' ([s], NoUseRange) dec +let subst_residual_comp s rc = + match rc.residual_typ with + | None -> rc + | Some t -> {rc with residual_typ=subst s t |> Some} +let closing_subst (bs:binders) = + List.fold_right (fun b (subst, n) -> (NM(b.binder_bv, n)::subst, n+1)) bs ([], 0) |> fst +let open_binders' bs = + let rec aux bs o = match bs with + | [] -> [], o + | b::bs' -> + let x' = {freshen_bv b.binder_bv with sort=subst o b.binder_bv.sort} in + let imp = subst_bqual o b.binder_qual in + let attrs = b.binder_attrs |> List.map (subst o) in + let o = DB(0, x')::shift_subst 1 o in + let bs', o = aux bs' o in + (S.mk_binder_with_attrs x' imp b.binder_positivity attrs)::bs', o in + aux bs [] +let open_binders (bs:binders) = fst (open_binders' bs) +let open_term' (bs:binders) t = + let bs', opening = open_binders' bs in + bs', subst opening t, opening +let open_term (bs:binders) t = + let b, t, _ = open_term' bs t in + b, t +let open_comp (bs:binders) t = + let bs', opening = open_binders' bs in + bs', subst_comp opening t +let open_ascription bs asc = + let bs', opening = open_binders' bs in + bs', subst_ascription opening asc + +let open_pat (p:pat) : pat & subst_t = + let rec open_pat_aux sub p = + match p.v with + | Pat_constant _ -> p, sub + + | Pat_cons(fv, us_opt, pats) -> + let us_opt = subst_univs_opt [sub] us_opt in + let pats, sub = pats |> List.fold_left (fun (pats, sub) (p, imp) -> + let p, sub = open_pat_aux sub p in + ((p,imp)::pats, sub)) ([], sub) in + {p with v=Pat_cons(fv, us_opt, List.rev pats)}, sub + + | Pat_var x -> + let x' = {freshen_bv x with sort=subst sub x.sort} in + let sub = DB(0, x')::shift_subst 1 sub in + {p with v=Pat_var x'}, sub + + | Pat_dot_term eopt -> + let eopt = U.map_option (subst sub) eopt in + {p with v=Pat_dot_term eopt}, sub + in + open_pat_aux [] p + +let open_branch' (p, wopt, e) = + let p, opening = open_pat p in + let wopt = match wopt with + | None -> None + | Some w -> Some (subst opening w) in + let e = subst opening e in + (p, wopt, e), opening + +let open_branch br = + let br, _ = open_branch' br in + br + +let close (bs:binders) t = subst (closing_subst bs) t +let close_comp (bs:binders) (c:comp) = subst_comp (closing_subst bs) c +let close_binders (bs:binders) : binders = + let rec aux s (bs:binders) = match bs with + | [] -> [] + | b::tl -> + let x = {b.binder_bv with sort=subst s b.binder_bv.sort} in + let imp = subst_bqual s b.binder_qual in + let attrs = b.binder_attrs |> List.map (subst s) in + let s' = NM(x, 0)::shift_subst 1 s in + (S.mk_binder_with_attrs x imp b.binder_positivity attrs)::aux s' tl in + aux [] bs +let close_ascription (bs:binders) (asc:ascription) = + subst_ascription (closing_subst bs) asc + +let close_pat p = + let rec aux sub p = match p.v with + | Pat_constant _ -> p, sub + + | Pat_cons(fv, us_opt, pats) -> + let us_opt = subst_univs_opt [sub] us_opt in + let pats, sub = pats |> List.fold_left (fun (pats, sub) (p, imp) -> + let p, sub = aux sub p in + ((p,imp)::pats, sub)) ([], sub) in + {p with v=Pat_cons(fv, us_opt, List.rev pats)}, sub + + | Pat_var x -> + let x = {x with sort=subst sub x.sort} in + let sub = NM(x, 0)::shift_subst 1 sub in + {p with v=Pat_var x}, sub + + | Pat_dot_term eopt -> + let eopt = U.map_option (subst sub) eopt in + {p with v=Pat_dot_term eopt}, sub in + aux [] p + +let close_branch (p, wopt, e) = + let p, closing = close_pat p in + let wopt = match wopt with + | None -> None + | Some w -> Some (subst closing w) in + let e = subst closing e in + (p, wopt, e) + +let univ_var_opening (us:univ_names) = + let n = List.length us - 1 in + let s = us |> List.mapi (fun i u -> UN(n - i, U_name u)) in + s, us + +let univ_var_closing (us:univ_names) = + let n = List.length us - 1 in + us |> List.mapi (fun i u -> UD(u, n - i)) + +let open_univ_vars (us:univ_names) (t:term) : univ_names & term = + let s, us' = univ_var_opening us in + let t = subst s t in + us', t + +let open_univ_vars_comp (us:univ_names) (c:comp) : univ_names & comp = + let s, us' = univ_var_opening us in + us', subst_comp s c + +let close_univ_vars (us:univ_names) (t:term) : term = + let s = univ_var_closing us in + subst s t + +let close_univ_vars_comp (us:univ_names) (c:comp) : comp = + let n = List.length us - 1 in + let s = us |> List.mapi (fun i u -> UD(u, n - i)) in + subst_comp s c + +let open_let_rec lbs (t:term) = + let n_let_recs, lbs, let_rec_opening = + if is_top_level lbs + then 0, lbs, [] //top-level let recs are not opened, + //but we still have to open their universe binders, + //if any (see below) + else List.fold_right + (fun lb (i, lbs, out) -> + let x = Syntax.freshen_bv (left lb.lbname) in + i+1, {lb with lbname=Inl x}::lbs, DB(i, x)::out) + lbs + (0, [], []) + in + (* Consider + let rec f x = g x + and g y = f y in + f 0, g 0 + In de Bruijn notation, this is + let rec f x = g@1 x@0 + and g y = f@2 y@0 in + f@1 0, g@0 0 + i.e., the recursive environment for f is, in order: + u, f, g, x + for g is + u, f, g, y + and for the body is + f, g + + See FStar.Util.check_mutual_universes + - We maintain an invariant that all the letbindings + in a mutually recursive nest abstract over the + same sequence of universes + *) + let _, us, u_let_rec_opening = + List.fold_right + (fun u (i, us, out) -> + let u = Syntax.new_univ_name None in + i+1, u::us, UN(i, U_name u)::out) + (List.hd lbs).lbunivs + (n_let_recs, [], let_rec_opening) + in + let lbs = lbs |> List.map (fun lb -> + {lb with lbunivs=us; + lbdef=subst u_let_rec_opening lb.lbdef; + lbtyp=subst u_let_rec_opening lb.lbtyp}) + in + let t = subst let_rec_opening t in + lbs, t + +let close_let_rec lbs (t:term) = + let n_let_recs, let_rec_closing = + if is_top_level lbs + then 0, [] //top-level let recs do not have to be closed + //except for their universe binders, if any (see below) + else List.fold_right + (fun lb (i, out) -> i+1, NM(left lb.lbname, i)::out) + lbs + (0, []) + in + let _, u_let_rec_closing = + List.fold_right + (fun u (i, out) -> i+1, UD(u, i)::out) + (List.hd lbs).lbunivs + (n_let_recs, let_rec_closing) + in + let lbs = lbs |> List.map (fun lb -> + {lb with lbdef=subst u_let_rec_closing lb.lbdef; + lbtyp=subst u_let_rec_closing lb.lbtyp}) + in + let t = subst let_rec_closing t in + lbs, t + +let close_tscheme (binders:binders) ((us, t) : tscheme) = + let n = List.length binders - 1 in + let k = List.length us in + let s = List.mapi (fun i b -> NM(b.binder_bv, k + (n - i))) binders in + let t = subst s t in + (us, t) + +let close_univ_vars_tscheme (us:univ_names) ((us', t):tscheme) = + let n = List.length us - 1 in + let k = List.length us' in + let s = List.mapi (fun i x -> UD(x, k + (n - i))) us in + (us', subst s t) + +let subst_tscheme (s:list subst_elt) ((us, t):tscheme) = + let s = shift_subst (List.length us) s in + (us, subst s t) + +let opening_of_binders (bs:binders) = + let n = List.length bs - 1 in + bs |> List.mapi (fun i b -> DB(n - i, b.binder_bv)) + +let closing_of_binders (bs:binders) = closing_subst bs + +let open_term_1 b t = + match open_term [b] t with + | [b], t -> b, t + | _ -> failwith "impossible: open_term_1" + +let open_term_bvs bvs t = + let bs, t = open_term (List.map mk_binder bvs) t in + List.map (fun b -> b.binder_bv) bs, t + +let open_term_bv bv t = + match open_term_bvs [bv] t with + | [bv], t -> bv, t + | _ -> failwith "impossible: open_term_bv" diff --git a/src/syntax/FStarC.Syntax.Subst.fsti b/src/syntax/FStarC.Syntax.Subst.fsti new file mode 100644 index 00000000000..48701cb7225 --- /dev/null +++ b/src/syntax/FStarC.Syntax.Subst.fsti @@ -0,0 +1,83 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Syntax.Subst +open FStarC.Compiler.Effect + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.Compiler.Util + +val shift_subst: int -> subst_t -> subst_t +val subst: list subst_elt -> term -> term +val subst': subst_ts -> term -> term +val subst_comp: list subst_elt -> comp -> comp +val subst_bqual: list subst_elt -> bqual -> bqual +val subst_aqual: list subst_elt -> aqual -> aqual +val subst_ascription: list subst_elt -> ascription -> ascription +val subst_decreasing_order: + list subst_elt -> decreases_order -> decreases_order +val subst_binder: list subst_elt -> binder -> binder +val subst_binders: list subst_elt -> binders -> binders +val subst_residual_comp:list subst_elt -> residual_comp -> residual_comp +val compress: term -> term +val compress_univ: universe -> universe + +// +// It pushes delayed substitutions down, +// but does not resolve uvars +// +// Whereas compress does both +// +val compress_subst: term -> term + +val close: binders -> term -> term +val close_comp: binders -> comp -> comp +val close_binders: binders -> binders +val close_ascription: binders -> ascription -> ascription +val close_branch: branch -> branch +val close_univ_vars: univ_names -> term -> term +val close_univ_vars_comp: univ_names -> comp -> comp +val close_let_rec: list letbinding -> term -> list letbinding & term +val closing_of_binders: binders -> subst_t + +val open_binders': binders -> binders & subst_t +val open_binders: binders -> binders +val open_term: binders -> term -> binders & term +val open_term': binders -> term -> binders & term & subst_t +val open_comp: binders -> comp -> binders & comp +val open_ascription: binders -> ascription -> binders & ascription +val open_branch: branch -> branch +val open_branch': branch -> branch & subst_t +val open_let_rec: list letbinding -> term -> list letbinding & term +val open_univ_vars: univ_names -> term -> univ_names & term +val open_univ_vars_comp:univ_names -> comp -> univ_names & comp +val opening_of_binders: binders -> subst_t + +val subst_tscheme: list subst_elt -> tscheme -> tscheme +val close_tscheme: binders -> tscheme -> tscheme +val close_univ_vars_tscheme: univ_names -> tscheme -> tscheme + +val univ_var_opening: univ_names -> list subst_elt & list univ_name +val univ_var_closing: univ_names -> list subst_elt + +val set_use_range: Range.range -> term -> term + +(* Helpers *) +val open_term_1 : binder -> term -> binder & term +val open_term_bvs : list bv -> term -> list bv & term +val open_term_bv : bv -> term -> bv & term diff --git a/src/syntax/FStarC.Syntax.Syntax.fst b/src/syntax/FStarC.Syntax.Syntax.fst new file mode 100644 index 00000000000..f909b5866b9 --- /dev/null +++ b/src/syntax/FStarC.Syntax.Syntax.fst @@ -0,0 +1,667 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or impliedmk_ + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Syntax.Syntax +open FStarC.Compiler.Effect +open FStarC.Compiler.List +(* Type definitions for the core AST *) + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.Compiler.Range +open FStarC.Ident +open FStarC.Const +open FStarC.Dyn +open FStarC.VConfig + +open FStarC.Class.Ord +open FStarC.Class.HasRange +open FStarC.Class.Setlike + +module O = FStarC.Options +module PC = FStarC.Parser.Const +module Err = FStarC.Errors +module GS = FStarC.GenSym +module FlatSet = FStarC.Compiler.FlatSet + +let pragma_to_string (p:pragma) : string = + match p with + | ShowOptions -> "#show-options" + | ResetOptions None -> "#reset-options" + | ResetOptions (Some s) -> format1 "#reset-options \"%s\"" s + | SetOptions s -> format1 "#set-options \"%s\"" s + | PushOptions None -> "#push-options" + | PushOptions (Some s) -> format1 "#push-options \"%s\"" s + | RestartSolver -> "#restart-solver" + | PrintEffectsGraph -> "#print-effects-graph" + | PopOptions -> "#pop-options" + +instance showable_pragma = { + show = pragma_to_string; +} + +let rec emb_typ_to_string = function + | ET_abstract -> "abstract" + | ET_app (h, []) -> h + | ET_app(h, args) -> "(" ^h^ " " ^ (List.map emb_typ_to_string args |> String.concat " ") ^")" + | ET_fun(a, b) -> "(" ^ emb_typ_to_string a ^ ") -> " ^ emb_typ_to_string b + +instance showable_emb_typ = { + show = emb_typ_to_string; +} + + +let rec delta_depth_to_string = function + | Delta_constant_at_level i -> "Delta_constant_at_level " ^ string_of_int i + | Delta_equational_at_level i -> "Delta_equational_at_level " ^ string_of_int i + | Delta_abstract d -> "Delta_abstract (" ^ delta_depth_to_string d ^ ")" + +instance showable_delta_depth = { + show = delta_depth_to_string; +} + +instance showable_should_check_uvar = { + show = (function + | Allow_unresolved s -> "Allow_unresolved " ^ s + | Allow_untyped s -> "Allow_untyped " ^ s + | Allow_ghost s -> "Allow_ghost " ^ s + | Strict -> "Strict" + | Already_checked -> "Already_checked"); +} + +// This is set in FStarC.Main.main, where all modules are in-scope. +let lazy_chooser : ref (option (lazy_kind -> lazyinfo -> term)) = mk_ref None + +let is_internal_qualifier (q:qualifier) : bool = + match q with + | Visible_default + | Discriminator _ + | Projector _ + | RecordType _ + | RecordConstructor _ + | Action _ + | ExceptionConstructor + | HasMaskedEffect + | Effect + | OnlyName + | InternalAssumption -> + true + | _ -> + false + +instance showable_indexed_effect_binder_kind : showable indexed_effect_binder_kind = { + show = (function + | Type_binder -> "Type_binder" + | Substitutive_binder -> "Substitutive_binder" + | BindCont_no_abstraction_binder -> "BindCont_no_abstraction_binder" + | Range_binder -> "Range_binder" + | Repr_binder -> "Repr_binder" + | Ad_hoc_binder -> "Ad_hoc_binder" + ); +} + +instance tagged_indexed_effect_binder_kind : tagged indexed_effect_binder_kind = { + tag_of = (function + | Type_binder -> "Type_binder" + | Substitutive_binder -> "Substitutive_binder" + | BindCont_no_abstraction_binder -> "BindCont_no_abstraction_binder" + | Range_binder -> "Range_binder" + | Repr_binder -> "Repr_binder" + | Ad_hoc_binder -> "Ad_hoc_binder" + ); +} + +instance showable_indexed_effect_combinator_kind : showable indexed_effect_combinator_kind = { + show = (function + | Substitutive_combinator ks -> "Substitutive_combinator " ^ show ks + | Substitutive_invariant_combinator -> "Substitutive_invariant_combinator" + | Ad_hoc_combinator -> "Ad_hoc_combinator" + ); +} + +instance tagged_indexed_effect_combinator_kind : tagged indexed_effect_combinator_kind = { + tag_of = (function + | Substitutive_combinator _ -> "Substitutive_combinator" + | Substitutive_invariant_combinator -> "Substitutive_invariant_combinator" + | Ad_hoc_combinator -> "Ad_hoc_combinator" + ); +} + +instance showable_eff_extraction_mode : showable eff_extraction_mode = { + show = (function + | Extract_none s -> "Extract_none " ^ s + | Extract_reify -> "Extract_reify" + | Extract_primitive -> "Extract_primitive" + ); +} + +instance tagged_eff_extraction_mode : tagged eff_extraction_mode = { + tag_of = (function + | Extract_none _ -> "Extract_none" + | Extract_reify -> "Extract_reify" + | Extract_primitive -> "Extract_primitive" + ); +} + +let mod_name (m: modul) = m.name + +let contains_reflectable (l: list qualifier): bool = + Util.for_some (function Reflectable _ -> true | _ -> false) l + +(*********************************************************************************) +(* Identifiers to/from strings *) +(*********************************************************************************) +let withinfo v r = {v=v; p=r} +let withsort v = withinfo v dummyRange + +let order_bv (x y : bv) : int = x.index - y.index +let bv_eq (x y : bv) : bool = order_bv x y = 0 + +let order_ident x y = String.compare (string_of_id x) (string_of_id y) +let order_fv x y = String.compare (string_of_lid x) (string_of_lid y) + +let range_of_lbname (l:lbname) = match l with + | Inl x -> range_of_id x.ppname + | Inr fv -> range_of_lid fv.fv_name.v +let range_of_bv x = range_of_id x.ppname + +let set_range_of_bv x r = {x with ppname = set_id_range r x.ppname } + + +(* Helpers *) +let on_antiquoted (f : (term -> term)) (qi : quoteinfo) : quoteinfo = + let (s, aqs) = qi.antiquotations in + let aqs' = List.map f aqs in + { qi with antiquotations = (s, aqs') } + +(* Requires that bv.index is in scope. *) +let lookup_aq (bv : bv) (aq : antiquotations) : term = + try List.nth (snd aq) (List.length (snd aq) - 1 - bv.index + fst aq) // subtract shift + with + | _ -> + failwith "antiquotation out of bounds" + +(*********************************************************************************) +(* Syntax builders *) +(*********************************************************************************) + +// Cleanup this mess please +let deq_instance_from_cmp f = { + (=?) = (fun x y -> Order.eq (f x y)); +} +let ord_instance_from_cmp f = { + super = deq_instance_from_cmp f; + cmp = f; +} +let order_univ_name x y = String.compare (Ident.string_of_id x) (Ident.string_of_id y) + +instance deq_bv : deq bv = + deq_instance_from_cmp (fun x y -> Order.order_from_int (order_bv x y)) +instance deq_ident : deq ident = + deq_instance_from_cmp (fun x y -> Order.order_from_int (order_ident x y)) +instance deq_fv : deq lident = + deq_instance_from_cmp (fun x y -> Order.order_from_int (order_fv x y)) +instance deq_univ_name : deq univ_name = + deq_instance_from_cmp (fun x y -> Order.order_from_int (order_univ_name x y)) +instance deq_delta_depth : deq delta_depth = { + (=?) = (fun x y -> x = y); +} + +instance ord_bv : ord bv = + ord_instance_from_cmp (fun x y -> Order.order_from_int (order_bv x y)) +instance ord_ident : ord ident = + ord_instance_from_cmp (fun x y -> Order.order_from_int (order_ident x y)) +instance ord_fv : ord lident = + ord_instance_from_cmp (fun x y -> Order.order_from_int (order_fv x y)) + +let syn p k f = f k p +let mk_fvs () = Util.mk_ref None +let mk_uvs () = Util.mk_ref None + +//let memo_no_uvs = Util.mk_ref (Some no_uvs) +//let memo_no_names = Util.mk_ref (Some no_names) +let list_of_freenames (fvs:freenames) = elems fvs + +(* Constructors for each term form; NO HASH CONSING; just makes all the auxiliary data at each node *) +let mk (t:'a) r = { + n=t; + pos=r; + vars=Util.mk_ref None; + hash_code=Util.mk_ref None; +} + +let bv_to_tm bv :term = mk (Tm_bvar bv) (range_of_bv bv) +let bv_to_name bv :term = mk (Tm_name bv) (range_of_bv bv) +let binders_to_names (bs:binders) : list term = bs |> List.map (fun b -> bv_to_name b.binder_bv) +let mk_Tm_app (t1:typ) (args:list arg) p = + match args with + | [] -> t1 + | _ -> mk (Tm_app {hd=t1; args}) p +let mk_Tm_uinst (t:term) (us:universes) = + match t.n with + | Tm_fvar _ -> + begin match us with + | [] -> t + | us -> mk (Tm_uinst(t, us)) t.pos + end + | _ -> failwith "Unexpected universe instantiation" + +let extend_app_n t args' r = match t.n with + | Tm_app {hd; args} -> mk_Tm_app hd (args@args') r + | _ -> mk_Tm_app t args' r +let extend_app t arg r = extend_app_n t [arg] r +let mk_Tm_delayed lr pos : term = mk (Tm_delayed {tm=fst lr; substs=snd lr}) pos +let mk_Total t = mk (Total t) t.pos +let mk_GTotal t : comp = mk (GTotal t) t.pos +let mk_Comp (ct:comp_typ) : comp = mk (Comp ct) ct.result_typ.pos +let mk_lb (x, univs, eff, t, e, attrs, pos) = { + lbname=x; + lbunivs=univs; + lbtyp=t; + lbeff=eff; + lbdef=e; + lbattrs=attrs; + lbpos=pos; + } + +let mk_Tac t = + mk_Comp ({ comp_univs = [U_zero]; + effect_name = PC.effect_Tac_lid; + result_typ = t; + effect_args = []; + flags = [SOMETRIVIAL; TRIVIAL_POSTCONDITION]; + }) + +let default_sigmeta = { + sigmeta_active=true; + sigmeta_fact_db_ids=[]; + sigmeta_spliced=false; + sigmeta_admit=false; + sigmeta_already_checked=false; + sigmeta_extension_data=[] +} +let mk_sigelt (e: sigelt') = { + sigel = e; + sigrng = Range.dummyRange; + sigquals=[]; + sigmeta=default_sigmeta; + sigattrs = [] ; + sigopts = None; + sigopens_and_abbrevs = [] } +let mk_subst (s:subst_t) = s +let extend_subst x s : subst_t = x::s +let argpos (x:arg) = (fst x).pos + +let tun : term = mk (Tm_unknown) dummyRange +let teff : term = mk (Tm_constant Const_effect) dummyRange + +(* no compress call? *) +let is_teff (t:term) = match t.n with + | Tm_constant Const_effect -> true + | _ -> false +(* no compress call? *) +let is_type (t:term) = match t.n with + | Tm_type _ -> true + | _ -> false + +(* Gen sym *) +let null_id = mk_ident("_", dummyRange) +let null_bv k = {ppname=null_id; index=GS.next_id(); sort=k} + +let is_null_bv (b:bv) = string_of_id b.ppname = string_of_id null_id +let is_null_binder (b:binder) = is_null_bv b.binder_bv +let range_of_ropt = function + | None -> dummyRange + | Some r -> r + +let gen_bv' (id : ident) (r : option Range.range) (t : typ) : bv = + {ppname=id; index=GS.next_id(); sort=t} + +let gen_bv (s : string) (r : option Range.range) (t : typ) : bv = + let id = mk_ident(s, range_of_ropt r) in + gen_bv' id r t + +let new_bv ropt t = gen_bv Ident.reserved_prefix ropt t +let freshen_bv bv = + if is_null_bv bv + then new_bv (Some (range_of_bv bv)) bv.sort + else {bv with index=GS.next_id()} +let mk_binder_with_attrs bv aqual pqual attrs = { + binder_bv = bv; + binder_qual = aqual; + binder_positivity = pqual; + binder_attrs = attrs +} +let mk_binder a = mk_binder_with_attrs a None None [] +let null_binder t : binder = mk_binder (null_bv t) +let imp_tag = Implicit false +let iarg t : arg = t, Some ({ aqual_implicit = true; aqual_attributes = [] }) +let as_arg t : arg = t, None + + +let is_top_level = function + | {lbname=Inr _}::_ -> true + | _ -> false + +let freenames_of_binders (bs:binders) : freenames = + List.fold_right (fun b out -> add b.binder_bv out) bs (empty ()) + +let binders_of_list fvs : binders = (fvs |> List.map (fun t -> mk_binder t)) +let binders_of_freenames (fvs:freenames) = elems fvs |> binders_of_list +let is_bqual_implicit = function Some (Implicit _) -> true | _ -> false +let is_aqual_implicit = function Some { aqual_implicit = b } -> b | _ -> false +let is_bqual_implicit_or_meta = function Some (Implicit _) | Some (Meta _) -> true | _ -> false +let as_bqual_implicit = function true -> Some imp_tag | _ -> None +let as_aqual_implicit = function true -> Some ({aqual_implicit=true; aqual_attributes=[]}) | _ -> None +let pat_bvs (p:pat) : list bv = + let rec aux b p = match p.v with + | Pat_dot_term _ + | Pat_constant _ -> b + | Pat_var x -> x::b + | Pat_cons(_, _, pats) -> List.fold_left (fun b (p, _) -> aux b p) b pats + in + List.rev <| aux [] p + + +let freshen_binder (b:binder) = { b with binder_bv = freshen_bv b.binder_bv } + +let new_univ_name ropt = + let id = GS.next_id() in + mk_ident (Ident.reserved_prefix ^ Util.string_of_int id, range_of_ropt ropt) +let lbname_eq l1 l2 = match l1, l2 with + | Inl x, Inl y -> bv_eq x y + | Inr l, Inr m -> lid_equals l m + | _ -> false +let fv_eq fv1 fv2 = lid_equals fv1.fv_name.v fv2.fv_name.v +let fv_eq_lid fv lid = lid_equals fv.fv_name.v lid + +let set_bv_range bv r = {bv with ppname = set_id_range r bv.ppname} + +let lid_and_dd_as_fv l dq : fv = { + fv_name=withinfo l (range_of_lid l); + fv_qual =dq; +} +let lid_as_fv l dq : fv = { + fv_name=withinfo l (range_of_lid l); + fv_qual =dq; +} +let fv_to_tm (fv:fv) : term = mk (Tm_fvar fv) (range_of_lid fv.fv_name.v) +let fvar_with_dd l dq = fv_to_tm (lid_and_dd_as_fv l dq) +let fvar l dq = fv_to_tm (lid_as_fv l dq) +let lid_of_fv (fv:fv) = fv.fv_name.v +let range_of_fv (fv:fv) = range_of_lid (lid_of_fv fv) +let set_range_of_fv (fv:fv) (r:Range.range) = + {fv with fv_name={fv.fv_name with v=Ident.set_lid_range (lid_of_fv fv) r}} +let has_simple_attribute (l: list term) s = + List.existsb (function + | { n = Tm_constant (Const_string (data, _)) } when data = s -> + true + | _ -> + false + ) l + +// Compares the SHAPE of the patterns, *ignoring bound variables and universes* +let rec eq_pat (p1 : pat) (p2 : pat) : bool = + match p1.v, p2.v with + | Pat_constant c1, Pat_constant c2 -> eq_const c1 c2 + | Pat_cons (fv1, us1, as1), Pat_cons (fv2, us2, as2) -> + if fv_eq fv1 fv2 + && List.length as1 = List.length as2 + then List.forall2 (fun (p1, b1) (p2, b2) -> b1 = b2 && eq_pat p1 p2) as1 as2 + && (match us1, us2 with + | None, None -> true + | Some us1, Some us2 -> + List.length us1 = List.length us2 + | _ -> false) + else false + | Pat_var _, Pat_var _ -> true + | Pat_dot_term _, Pat_dot_term _ -> true + | _, _ -> false + +/////////////////////////////////////////////////////////////////////// +//Some common constants +/////////////////////////////////////////////////////////////////////// +let delta_constant = Delta_constant_at_level 0 +let delta_equational = Delta_equational_at_level 0 +let fvconst l = lid_and_dd_as_fv l None +let tconst l = mk (Tm_fvar (fvconst l)) Range.dummyRange +let tabbrev l = mk (Tm_fvar(lid_and_dd_as_fv l None)) Range.dummyRange +let tdataconstr l = fv_to_tm (lid_and_dd_as_fv l (Some Data_ctor)) +let t_unit = tconst PC.unit_lid +let t_bool = tconst PC.bool_lid +let t_int = tconst PC.int_lid +let t_string = tconst PC.string_lid +let t_exn = tconst PC.exn_lid +let t_real = tconst PC.real_lid +let t_float = tconst PC.float_lid +let t_char = tabbrev PC.char_lid +let t_range = tconst PC.range_lid +let t___range = tconst PC.__range_lid +let t_vconfig = tconst PC.vconfig_lid +let t_term = tconst PC.term_lid +let t_term_view = tabbrev PC.term_view_lid +let t_order = tconst PC.order_lid +let t_decls = tabbrev PC.decls_lid +let t_binder = tconst PC.binder_lid +let t_binders = tconst PC.binders_lid +let t_bv = tconst PC.bv_lid +let t_fv = tconst PC.fv_lid +let t_norm_step = tconst PC.norm_step_lid +let t_tac_of a b = + mk_Tm_app (mk_Tm_uinst (tabbrev PC.tac_lid) [U_zero; U_zero]) + [as_arg a; as_arg b] Range.dummyRange +let t_tactic_of t = + mk_Tm_app (mk_Tm_uinst (tabbrev PC.tactic_lid) [U_zero]) + [as_arg t] Range.dummyRange + +let t_tactic_unit = t_tactic_of t_unit + +(* + * AR: what's up with all the U_zero below? + *) +let t_list_of t = mk_Tm_app + (mk_Tm_uinst (tabbrev PC.list_lid) [U_zero]) + [as_arg t] + Range.dummyRange +let t_option_of t = mk_Tm_app + (mk_Tm_uinst (tabbrev PC.option_lid) [U_zero]) + [as_arg t] + Range.dummyRange +let t_tuple2_of t1 t2 = mk_Tm_app + (mk_Tm_uinst (tabbrev PC.lid_tuple2) [U_zero;U_zero]) + [as_arg t1; as_arg t2] + Range.dummyRange +let t_tuple3_of t1 t2 t3 = mk_Tm_app + (mk_Tm_uinst (tabbrev PC.lid_tuple3) [U_zero;U_zero;U_zero]) + [as_arg t1; as_arg t2; as_arg t3] + Range.dummyRange +let t_tuple4_of t1 t2 t3 t4 = mk_Tm_app + (mk_Tm_uinst (tabbrev PC.lid_tuple4) [U_zero;U_zero;U_zero;U_zero]) + [as_arg t1; as_arg t2; as_arg t3; as_arg t4] + Range.dummyRange +let t_tuple5_of t1 t2 t3 t4 t5 = mk_Tm_app + (mk_Tm_uinst (tabbrev PC.lid_tuple5) [U_zero;U_zero;U_zero;U_zero;U_zero]) + [as_arg t1; as_arg t2; as_arg t3; as_arg t4; as_arg t5] + Range.dummyRange +let t_either_of t1 t2 = mk_Tm_app + (mk_Tm_uinst (tabbrev PC.either_lid) [U_zero;U_zero]) + [as_arg t1; as_arg t2] + Range.dummyRange +let t_sealed_of t = mk_Tm_app + (mk_Tm_uinst (tabbrev PC.sealed_lid) [U_zero]) + [as_arg t] + Range.dummyRange +let t_erased_of t = mk_Tm_app + (mk_Tm_uinst (tabbrev PC.erased_lid) [U_zero]) + [as_arg t] + Range.dummyRange + +let unit_const_with_range r = mk (Tm_constant FStarC.Const.Const_unit) r +let unit_const = unit_const_with_range Range.dummyRange + +instance show_restriction: showable restriction = { + show = (function + | Unrestricted -> "Unrestricted" + | AllowList allow_list -> "(AllowList " ^ show allow_list ^ ")") +} + +let is_ident_allowed_by_restriction' id + = function | Unrestricted -> Some id + | AllowList allow_list -> + map_opt (find FStarC.Class.Deq.(fun (dest_id, renamed_id) -> + dflt dest_id renamed_id =? id + ) allow_list) fst + +let is_ident_allowed_by_restriction + = let debug = FStarC.Compiler.Debug.get_toggle "open_include_restrictions" in + fun id restriction -> + let result = is_ident_allowed_by_restriction' id restriction in + if !debug then print_endline ( "is_ident_allowed_by_restriction(" ^ show id ^ ", " + ^ show restriction ^ ") = " + ^ show result ); + result + +instance has_range_syntax #a (_:unit) : Tot (hasRange (syntax a)) = { + pos = (fun (t:syntax a) -> t.pos); + setPos = (fun r t -> { t with pos = r }); +} + +instance has_range_withinfo #a (_:unit) : Tot (hasRange (withinfo_t a)) = { + pos = (fun t -> t.p); + setPos = (fun r t -> { t with p = r }); +} + +instance has_range_sigelt : hasRange sigelt = { + pos = (fun t -> t.sigrng); + setPos = (fun r t -> { t with sigrng = r }); +} + +instance hasRange_fv : hasRange fv = { + pos = range_of_fv; + setPos = (fun r f -> set_range_of_fv f r); +} + +instance hasRange_bv : hasRange bv = { + pos = range_of_bv; + setPos = (fun r f -> set_range_of_bv f r); +} + +instance hasRange_binder : hasRange binder = { + pos = (fun b -> pos b.binder_bv); + setPos = (fun r b -> { b with binder_bv = setPos r b.binder_bv }); +} + +instance showable_lazy_kind = { + show = (function + | BadLazy -> "BadLazy" + | Lazy_bv -> "Lazy_bv" + | Lazy_namedv -> "Lazy_namedv" + | Lazy_binder -> "Lazy_binder" + | Lazy_optionstate -> "Lazy_optionstate" + | Lazy_fvar -> "Lazy_fvar" + | Lazy_comp -> "Lazy_comp" + | Lazy_env -> "Lazy_env" + | Lazy_proofstate -> "Lazy_proofstate" + | Lazy_goal -> "Lazy_goal" + | Lazy_sigelt -> "Lazy_sigelt" + | Lazy_letbinding -> "Lazy_letbinding" + | Lazy_uvar -> "Lazy_uvar" + | Lazy_universe -> "Lazy_universe" + | Lazy_universe_uvar -> "Lazy_universe_uvar" + | Lazy_issue -> "Lazy_issue" + | Lazy_doc -> "Lazy_doc" + | Lazy_ident -> "Lazy_ident" + | Lazy_tref -> "Lazy_tref" + | Lazy_embedding _ -> "Lazy_embedding _" + | Lazy_extension s -> "Lazy_extension " ^ s + | _ -> failwith "FIXME! lazy_kind_to_string must be complete" + ); +} + +instance deq_lazy_kind : deq lazy_kind = { + (=?) = (fun k k' -> +(* NOTE: Lazy_embedding compares false to itself, by design. *) + match k, k' with + | BadLazy, BadLazy + | Lazy_bv, Lazy_bv + | Lazy_namedv, Lazy_namedv + | Lazy_binder, Lazy_binder + | Lazy_optionstate, Lazy_optionstate + | Lazy_fvar, Lazy_fvar + | Lazy_comp, Lazy_comp + | Lazy_env, Lazy_env + | Lazy_proofstate, Lazy_proofstate + | Lazy_goal, Lazy_goal + | Lazy_sigelt, Lazy_sigelt + | Lazy_letbinding, Lazy_letbinding + | Lazy_uvar, Lazy_uvar + | Lazy_universe, Lazy_universe + | Lazy_universe_uvar, Lazy_universe_uvar + | Lazy_issue, Lazy_issue + | Lazy_ident, Lazy_ident + | Lazy_doc, Lazy_doc + | Lazy_tref, Lazy_tref + -> true + | Lazy_extension s, Lazy_extension t -> + s = t + | Lazy_embedding _, _ + | _, Lazy_embedding _ -> false + | _ -> false); +} + +instance tagged_term : tagged term = { + tag_of = (fun t -> match t.n with + | Tm_bvar {} -> "Tm_bvar" + | Tm_name {} -> "Tm_name" + | Tm_fvar {} -> "Tm_fvar" + | Tm_uinst {} -> "Tm_uinst" + | Tm_constant _ -> "Tm_constant" + | Tm_type _ -> "Tm_type" + | Tm_quoted (_, {qkind=Quote_static}) -> "Tm_quoted(static)" + | Tm_quoted (_, {qkind=Quote_dynamic}) -> "Tm_quoted(dynamic)" + | Tm_abs {} -> "Tm_abs" + | Tm_arrow {} -> "Tm_arrow" + | Tm_refine {} -> "Tm_refine" + | Tm_app {} -> "Tm_app" + | Tm_match {} -> "Tm_match" + | Tm_ascribed {} -> "Tm_ascribed" + | Tm_let {} -> "Tm_let" + | Tm_uvar {} -> "Tm_uvar" + | Tm_delayed {} -> "Tm_delayed" + | Tm_meta {} -> "Tm_meta" + | Tm_unknown -> "Tm_unknown" + | Tm_lazy {} -> "Tm_lazy" + ); +} + +instance tagged_sigelt : tagged sigelt = { + tag_of = (fun se -> match se.sigel with + | Sig_inductive_typ {} -> "Sig_inductive_typ" + | Sig_bundle {} -> "Sig_bundle" + | Sig_datacon {} -> "Sig_datacon" + | Sig_declare_typ {} -> "Sig_declare_typ" + | Sig_let {} -> "Sig_let" + | Sig_assume {} -> "Sig_assume" + | Sig_new_effect {} -> "Sig_new_effect" + | Sig_sub_effect {} -> "Sig_sub_effect" + | Sig_effect_abbrev {} -> "Sig_effect_abbrev" + | Sig_pragma _ -> "Sig_pragma" + | Sig_splice {} -> "Sig_splice" + | Sig_polymonadic_bind {} -> "Sig_polymonadic_bind" + | Sig_polymonadic_subcomp {} -> "Sig_polymonadic_subcomp" + | Sig_fail {} -> "Sig_fail" + ); +} diff --git a/src/syntax/FStarC.Syntax.Syntax.fsti b/src/syntax/FStarC.Syntax.Syntax.fsti new file mode 100644 index 00000000000..fd68cfb11e9 --- /dev/null +++ b/src/syntax/FStarC.Syntax.Syntax.fsti @@ -0,0 +1,960 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Syntax.Syntax +open FStarC.Compiler.Effect +(* Type definitions for the core AST *) + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.Compiler.Range +open FStarC.Ident +open FStarC.Dyn +open FStarC.Const +module O = FStarC.Options +open FStarC.VConfig + +include FStarC.Class.HasRange +open FStarC.Class.Show +open FStarC.Class.Deq +open FStarC.Class.Ord +open FStarC.Class.Tagged + +(* Objects with metadata *) +[@@ PpxDerivingYoJson; PpxDerivingShow ] +type withinfo_t 'a = { + v: 'a; + p: Range.range; +} + +(* Free term and type variables *) +[@@ PpxDerivingYoJson; PpxDerivingShow ] +type var = withinfo_t lident + +(* Term language *) +[@@ PpxDerivingYoJson; PpxDerivingShow ] +type sconst = FStarC.Const.sconst + +[@@ PpxDerivingYoJson; PpxDerivingShow ] +type pragma = + | ShowOptions + | SetOptions of string + | ResetOptions of option string + | PushOptions of option string + | PopOptions + | RestartSolver + | PrintEffectsGraph //#print-effects-graph dumps the current effects graph in a dot file named "effects.graph" + +instance val showable_pragma : showable pragma + +[@@ PpxDerivingYoJson; PpxDerivingShowConstant "None" ] +type memo 'a = ref (option 'a) + +(* Simple types used in native compilation + * to record the types of lazily embedded terms + *) +type emb_typ = + | ET_abstract + | ET_fun of emb_typ & emb_typ + | ET_app of string & list emb_typ + +//versioning for unification variables +[@@ PpxDerivingYoJson; PpxDerivingShow ] +type version = { + major:int; + minor:int +} + +[@@ PpxDerivingYoJson; PpxDerivingShow ] +type universe = + | U_zero + | U_succ of universe + | U_max of list universe + | U_bvar of int + | U_name of univ_name + | U_unif of universe_uvar + | U_unknown +and univ_name = ident +and universe_uvar = Unionfind.p_uvar (option universe) & version & Range.range + +[@@ PpxDerivingYoJson; PpxDerivingShow ] +type univ_names = list univ_name + +[@@ PpxDerivingYoJson; PpxDerivingShow ] +type universes = list universe + +[@@ PpxDerivingYoJson; PpxDerivingShow ] +type monad_name = lident + +[@@ PpxDerivingYoJson; PpxDerivingShow ] +type quote_kind = + | Quote_static + | Quote_dynamic + +[@@ PpxDerivingYoJson; PpxDerivingShow ] +type maybe_set_use_range = + | NoUseRange + | SomeUseRange of range + +[@@ PpxDerivingYoJson; PpxDerivingShow ] +type delta_depth = + | Delta_constant_at_level of int + // ^ A symbol that can be unfolded n times to a term whose head is a + // constant, e.g., nat is (Delta_constant_at_level 1) to int, level 0 + // is a literal constant. + | Delta_equational_at_level of int + // ^ Level 0 is a symbol that may be equated to another by + // extensional reasoning, n > 0 can be unfolded n times to a + // Delta_equational_at_level 0 term. + | Delta_abstract of delta_depth + // ^ A symbol marked abstract whose depth is the argument d. + +[@@ PpxDerivingYoJson; PpxDerivingShow ] +type should_check_uvar = + | Allow_unresolved of string (* Escape hatch for uvars in logical guards that are sometimes left unresolved *) + | Allow_untyped of string (* Escape hatch to not re-typecheck guards in WPs and types of pattern bound vars *) + | Allow_ghost of string (* In some cases, e.g., in ctrl_rewrite, we introduce uvars in Ghost context *) + | Strict (* Strict uvar that must be typechecked *) + | Already_checked (* A uvar whose solution has already been checked *) + +type positivity_qualifier = + | BinderStrictlyPositive + | BinderUnused + +type term' = + | Tm_bvar of bv //bound variable, referenced by de Bruijn index + | Tm_name of bv //local constant, referenced by a unique name derived from bv.ppname and bv.index + | Tm_fvar of fv //fully qualified reference to a top-level symbol from a module + | Tm_uinst of term & universes //universe instantiation; the first argument must be one of the three constructors above + | Tm_constant of sconst + | Tm_type of universe + | Tm_abs { (* fun (xi:ti) -> t : (M t' wp | N) *) + bs:binders; + body:term; + rc_opt:option residual_comp + } + | Tm_arrow { (* (xi:ti) -> M t' wp *) + bs:binders; + comp:comp + } + | Tm_refine { (* x:t{phi} *) + b:bv; + phi:term + } + | Tm_app { (* h tau_1 ... tau_n, args in order from left to right *) + hd:term; + args:args + } + | Tm_match { (* (match e (as x returns asc)? with b1 ... bn) : (C | N)) *) + scrutinee:term; + ret_opt:option match_returns_ascription; + brs:list branch; + rc_opt:option residual_comp + } + | Tm_ascribed { (* an effect label is the third arg, filled in by the type-checker *) + tm:term; + asc:ascription; + eff_opt:option lident + } + | Tm_let { (* let (rec?) x1 = e1 AND ... AND xn = en in e *) + lbs:letbindings; + body:term + } + | Tm_uvar of ctx_uvar_and_subst (* A unification variable ?u (aka meta-variable) + and a delayed substitution of only NM or NT elements *) + | Tm_delayed { (* A delayed substitution --- always force it; never inspect it directly *) + tm:term; + substs:subst_ts + } + | Tm_meta { (* Some terms carry metadata, for better code generation, SMT encoding etc. *) + tm:term; + meta:metadata + } + | Tm_lazy of lazyinfo (* A lazily encoded term *) + | Tm_quoted of term & quoteinfo (* A quoted term, in one of its many variants *) + | Tm_unknown (* only present initially while desugaring a term *) +and ctx_uvar = { (* (G |- ?u : t), a uvar introduced in context G at type t *) + ctx_uvar_head:uvar; (* ?u *) + ctx_uvar_gamma:gamma; (* G: a cons list of bindings (most recent at the head) *) + ctx_uvar_binders:binders; (* All the Tm_name bindings in G, a snoc list (most recent at the tail) *) + ctx_uvar_reason:string; + ctx_uvar_range:Range.range; + ctx_uvar_meta: option ctx_uvar_meta_t; +} +and ctx_uvar_meta_t = + | Ctx_uvar_meta_tac of term + | Ctx_uvar_meta_attr of term (* An attribute associated with an implicit argument using the #[@@@ defer_to ...] notation *) +and ctx_uvar_and_subst = ctx_uvar & subst_ts + +and uvar_decoration = { + uvar_decoration_typ:typ; + uvar_decoration_typedness_depends_on:list ctx_uvar; + uvar_decoration_should_check:should_check_uvar; + uvar_decoration_should_unrefine:bool; +} + +and uvar = Unionfind.p_uvar (option term & uvar_decoration) & version & Range.range +and uvars = FlatSet.t ctx_uvar +and match_returns_ascription = binder & ascription (* as x returns C|t *) +and branch = pat & option term & term (* optional when clause in each branch *) +and ascription = either term comp & option term & bool (* e <: t [by tac] or e <: C [by tac] *) + (* the bool says whether the ascription is an equality ascription, i.e. $: *) +and pat' = + | Pat_constant of sconst + | Pat_cons of fv & option universes & list (pat & bool) (* flag marks an explicitly provided implicit *) + | Pat_var of bv (* a pattern bound variable (linear in a pattern) *) + | Pat_dot_term of option term (* dot patterns: determined by other elements in the pattern *) + (* the option term is the optionally resolved pat dot term *) +and letbinding = { //let f : forall u1..un. M t = e + lbname :lbname; // f + lbunivs:list univ_name; // u1..un + lbtyp :typ; // t + lbeff :lident; // M + lbdef :term; // e + lbattrs:list attribute; // attrs + lbpos :range; // original position of 'e' +} +and antiquotations = int & list term +and quoteinfo = { + qkind : quote_kind; + antiquotations : antiquotations; +(************************************************************************* + ANTIQUOTATIONS and shifting + + The antiquotations of a quoted term (Tm_quoted) are kept in the + antiquotations list above. The terms inside that list are not scoped by + any binder *inside* the quoted term, but are affected by substitutions + on the full term as usual. Inside the quoted terms, the points where + antiquotations are spliced in Tm_bvar nodes, where the index of the + bv indexes into the antiquotations list above, where the rightmost + elements is closer in scope. I.e., a term like + + Tm_quoted (Tm_bvar 2, {antiquotations = [a;b;c]}) + + is really just `a`. This makes the representation of antiquotations + more canonical (we previously had freshly-named Tm_names instead). + + Unembedding a Tm_quoted(tm, aq) term will simply take tm and substitute + it appropriately with the information from aq. Every antiquotation must + be a literal term for this to work, and not a variable or an expression + computing a quoted term. + + When extracting or encoding a quoted term to SMT, then, we cannot + simply unembed as the antiquotations are most likely undetermined. For + instance, the extraction of a term like + + Tm_quoted(1 + bvar 0, aq = [ compute_some_term() ]} + + should be something like + + pack_ln (Tv_App (pack_ln (Tv_App (plus, Tv_Const 1)), compute_some_term()). + + To implement this conveniently, we allow _embedding_ terms with + antiquotations, so we can implement extraction basically by: + + extract (Tm_quoted (Tm_bvar i, aq)) = + aq `index` (length aq - 1 - i) + + extract (Tm_quoted (t, aq)) = + let tv = inspect_ln t in + let tv_e = embed_term_view tv aq in + let t' = mk_app pack_ln tv_e in + extract t' + + That is, unfolding one level of the view, enclosing it with a + pack_ln call, and recursing. For this to work, however, we need the + antiquotations to be preserved, hence we pass them to embed_term_view. + The term_view embedding will also take care of *shifting* the + antiquotations (see the int there) when traversing a binder in the + quoted term. Hence, a term like: + + Tm_quoted (fun x -> 1 + x + bvar 1, aqs = [t]), + + will be unfolded to + + Tv_Abs (x, Tm_quoted(1 + bvar0 + bvar1, aqs = [t], shift=1)) + + where the shift is needed to make the bvar1 actually point to t. + +*************************************************************************) +} +and comp_typ = { + comp_univs:universes; + effect_name:lident; + result_typ:typ; + effect_args:args; + flags:list cflag +} +and comp' = + | Total of typ + | GTotal of typ + | Comp of comp_typ +and term = syntax term' +and typ = term (* sometimes we use typ to emphasize that a term is a type *) +and pat = withinfo_t pat' +and comp = syntax comp' +and arg = term & aqual (* marks an explicitly provided implicit arg *) +and args = list arg +and binder = { + binder_bv : bv; + binder_qual : bqual; + binder_positivity : option positivity_qualifier; + binder_attrs : list attribute +} (* f: #[@@ attr] n:nat -> vector n int -> T; f #17 v *) +and binders = list binder (* bool marks implicit binder *) +and decreases_order = + | Decreases_lex of list term (* a decreases clause may either specify a lexicographic ordered list of terms, *) + | Decreases_wf of term & term (* or a well-founded relation and a term *) +and cflag = (* flags applicable to computation types, usually for optimizations *) + | TOTAL (* computation has no real effect, can be reduced safely *) + | MLEFFECT (* the effect is ML (Parser.Const.effect_ML_lid) *) + | LEMMA (* the effect is Lemma (Parser.Const.effect_Lemma_lid) *) + | RETURN (* the WP is return_wp of something *) + | PARTIAL_RETURN (* the WP is return_wp of something, possibly strengthened with some precondition *) + | SOMETRIVIAL (* the WP is the null wp *) + | TRIVIAL_POSTCONDITION (* the computation has no meaningful postcondition *) + | SHOULD_NOT_INLINE (* a stopgap, see issue #1362, removing it revives the failure *) + | CPS (* computation is marked with attribute `cps`, for DM4F, seems useless, see #1557 *) + | DECREASES of decreases_order +and metadata = + | Meta_pattern of list term & list args (* Patterns for SMT quantifier instantiation; the first arg instantiation *) + | Meta_named of lident (* Useful for pretty printing to keep the type abbreviation around *) + | Meta_labeled of list Pprint.document & Range.range & bool (* Sub-terms in a VC are labeled with error messages to be reported, used in SMT encoding *) + | Meta_desugared of meta_source_info (* Node tagged with some information about source term before desugaring *) + | Meta_monadic of monad_name & typ (* Annotation on a Tm_app or Tm_let node in case it is monadic for m not in {Pure, Ghost, Div} *) + (* Contains the name of the monadic effect and the type of the subterm *) + | Meta_monadic_lift of monad_name & monad_name & typ (* Sub-effecting: lift the subterm of type typ *) + (* from the first monad_name m1 to the second monad name m2 *) +and meta_source_info = + | Sequence (* used when resugaring *) + | Primop (* ... add more cases here as needed for better code generation *) + | Masked_effect + | Meta_smt_pat + | Machine_integer of signedness & width +and fv_qual = + | Data_ctor + | Record_projector of (lident & ident) (* the fully qualified (unmangled) name of the data constructor and the field being projected *) + | Record_ctor of lident & list ident (* the type of the record being constructed and its (unmangled) fields in order *) + | Unresolved_projector of option fv (* ToSyntax's best guess at what the projector is (based only on scoping rules) *) + | Unresolved_constructor of unresolved_constructor (* ToSyntax's best guess at what the constructor is (based only on scoping rules) *) +and unresolved_constructor = { + uc_base_term : bool; // The base term is `e` when the user writes `{ e with f1=v1; ... }` + uc_typename: option lident; // The constructed type, as determined by the ToSyntax's scoping rules + uc_fields : list lident // The fields names as written in the source +} +and lbname = either bv fv +and letbindings = bool & list letbinding (* let recs may have more than one element; top-level lets have lidents *) + (* boolean true indicates rec *) +and subst_ts = list (list subst_elt) (* A composition of parallel substitutions *) + & maybe_set_use_range (* and a maybe range update, Some r, to set the use_range of subterms to r.def_range *) +and subst_elt = + | DB of int & bv (* DB i bv: replace a bound variable with index i with name bv *) + | DT of int & term (* DT i t: replace a bound variable with index i for term *) + | NM of bv & int (* NM x i: replace a local name with a bound variable i *) + | NT of bv & term (* NT x t: replace a local name with a term t *) + | UN of int & universe (* UN u v: replace universes variable u with universe term v *) + | UD of univ_name & int (* UD x i: replace universe name x with de Bruijn index i *) +and freenames = FlatSet.t bv +and syntax 'a = { + n:'a; + pos:Range.range; + vars:memo free_vars; + hash_code:memo FStarC.Hash.hash_code +} +and bv = { + ppname:ident; //programmer-provided name for pretty-printing + index:int; //de Bruijn index 0-based, counting up from the binder + sort:term +} +and fv = { + fv_name :var; + fv_qual :option fv_qual +} +and free_vars = { + free_names : FlatSet.t bv; + free_uvars : uvars; + free_univs : FlatSet.t universe_uvar; + free_univ_names : FlatSet.t univ_name; //fifo +} + +(* Residual of a computation type after typechecking *) +and residual_comp = { + residual_effect:lident; (* first component is the effect name *) + residual_typ :option typ; (* second component: result type *) + residual_flags :list cflag (* third component: contains (an approximation of) the cflags *) +} + +and attribute = term + +and lazyinfo = { + blob : dyn; + lkind : lazy_kind; + ltyp : typ; + rng : Range.range; +} +// Different kinds of lazy terms. These are used to decide the unfolding +// function, instead of keeping the closure inside the lazy node, since +// that means we cannot have equality on terms (not serious) nor call +// output_value on them (serious). +and lazy_kind = + | BadLazy + | Lazy_bv + | Lazy_namedv + | Lazy_binder + | Lazy_optionstate + | Lazy_fvar + | Lazy_comp + | Lazy_env + | Lazy_proofstate + | Lazy_goal + | Lazy_sigelt + | Lazy_uvar + | Lazy_letbinding + | Lazy_embedding of emb_typ & Thunk.t term + | Lazy_universe + | Lazy_universe_uvar + | Lazy_issue + | Lazy_ident + | Lazy_doc + | Lazy_extension of string + | Lazy_tref +and binding = + | Binding_var of bv + | Binding_lid of lident & (univ_names & typ) + (* ^ Not a tscheme: the universe names must be taken + * as fixed (and opened in the type). This is important since + * we do not support universe-polymorphic recursion. + * See #2106. *) + | Binding_univ of univ_name +and tscheme = list univ_name & typ +and gamma = list binding +and binder_qualifier = + | Implicit of bool //boolean marks an inaccessible implicit argument of a data constructor + | Meta of term //meta-argument that specifies a tactic term + | Equality +and bqual = option binder_qualifier +and arg_qualifier = { + aqual_implicit : bool; + aqual_attributes : list attribute +} +and aqual = option arg_qualifier + +type freenames_l = list bv +type formula = typ +type formulae = list typ + +type qualifier = + | Assumption //no definition provided, just a declaration + | New //a fresh type constant, distinct from all prior type constructors + | Private //name is invisible outside the module + | Unfold_for_unification_and_vcgen //a definition that *should* always be unfolded by the normalizer + | Irreducible //a definition that can never be unfolded by the normalizer + | Inline_for_extraction //a symbol whose definition must be unfolded when compiling the program + | NoExtract // a definition whose contents won't be extracted (currently, by KaRaMeL only) + | Noeq //for this type, don't generate HasEq + | Unopteq //for this type, use the unoptimized HasEq scheme + | TotalEffect //an effect that forbids non-termination + | Logic //a symbol whose intended usage is in the refinement logic + | Reifiable + | Reflectable of lident // with fully qualified effect name + + //the remaining qualifiers are internal: the programmer cannot write them + | Visible_default //a definition that may be unfolded by the normalizer, but only if necessary (default) + | Discriminator of lident //discriminator for a datacon l + | Projector of lident & ident //projector for datacon l's argument x + | RecordType of (list ident & list ident) //record type whose namespace is fst and unmangled field names are snd + | RecordConstructor of (list ident & list ident) //record constructor whose namespace is fst and unmangled field names are snd + | Action of lident //action of some effect + | ExceptionConstructor //a constructor of Prims.exn + | HasMaskedEffect //a let binding that may have a top-level effect + | Effect //qualifier on a name that corresponds to an effect constructor + | OnlyName //qualifier internal to the compiler indicating a dummy declaration which + //is present only for name resolution and will be elaborated at typechecking + | InternalAssumption //an assumption internally generated by F*, e.g. hasEq axioms, not to be reported with --report_assumes + +(* Checks if the qualifer is internal, and should not be written by users. *) +val is_internal_qualifier (q:qualifier) : bool + +type tycon = lident & binders & typ (* I (x1:t1) ... (xn:tn) : t *) +type monad_abbrev = { + mabbrev:lident; + parms:binders; + def:typ + } + +// +// Kind of a binder in an indexed effect combinator +// +type indexed_effect_binder_kind = + | Type_binder + | Substitutive_binder + | BindCont_no_abstraction_binder // a g computation (the continuation) binder in bind that's not abstracted over x:a + | Range_binder + | Repr_binder + | Ad_hoc_binder +instance val showable_indexed_effect_binder_kind : showable indexed_effect_binder_kind +instance val tagged_indexed_effect_binder_kind : tagged indexed_effect_binder_kind + +// +// Kind of an indexed effect combinator +// +// Substitutive invariant applies only to subcomp and ite combinators, +// where the effect indices of the two computations could be the same, +// and hence bound only once in the combinator definitions +// +type indexed_effect_combinator_kind = + | Substitutive_combinator of list indexed_effect_binder_kind + | Substitutive_invariant_combinator + | Ad_hoc_combinator +instance val showable_indexed_effect_combinator_kind : showable indexed_effect_combinator_kind +instance val tagged_indexed_effect_combinator_kind : tagged indexed_effect_combinator_kind + +type sub_eff = { + source:lident; + target:lident; + lift_wp:option tscheme; + lift:option tscheme; + kind:option indexed_effect_combinator_kind + } + +type action = { + action_name:lident; + action_unqualified_name: ident; // necessary for effect redefinitions, this name shall not contain the name of the effect + action_univs:univ_names; + action_params : binders; + action_defn:term; + action_typ: typ +} + +(* + * Effect combinators for wp-based effects + * + * This includes both primitive effects (such as PURE, DIV) + * as well as user-defined DM4F effects + * + * repr, return_repr, and bind_repr are optional, and are set only for reifiable effects + * + * For DM4F effects, ret_wp, bind_wp, and other wp combinators are derived and populated by the typechecker + * These fields are dummy ts ([], Tm_unknown) after desugaring + * + * We could add another boolean, elaborated somewhere + *) + +type wp_eff_combinators = { + ret_wp : tscheme; + bind_wp : tscheme; + stronger : tscheme; + if_then_else : tscheme; + ite_wp : tscheme; + close_wp : tscheme; + trivial : tscheme; + + repr : option tscheme; + return_repr : option tscheme; + bind_repr : option tscheme +} + + +(* + * Layered effects combinators + * + * All of these have pairs of type schemes, + * where the first component is the term ts and the second component is the type ts + * + * Before typechecking the effect declaration, the second component is a dummy ts + * In other words, desugaring sets the first component only, and typechecker then fills up the second one + * + * Additionally, bind, subcomp, and if_then_else have a combinator kind, + * this is also set to None in desugaring and set during typechecking the effect + * + * The close combinator is optional + * If it is not provided as part of the effect declaration, + * the typechecker also does not synthesize it (unlike if-then-else and subcomp) + *) +type layered_eff_combinators = { + l_repr : (tscheme & tscheme); + l_return : (tscheme & tscheme); + l_bind : (tscheme & tscheme & option indexed_effect_combinator_kind); + l_subcomp : (tscheme & tscheme & option indexed_effect_combinator_kind); + l_if_then_else : (tscheme & tscheme & option indexed_effect_combinator_kind); + l_close : option (tscheme & tscheme) +} + +type eff_combinators = + | Primitive_eff of wp_eff_combinators + | DM4F_eff of wp_eff_combinators + | Layered_eff of layered_eff_combinators + +type effect_signature = + | Layered_eff_sig of int & tscheme // (n, ts) where n is the number of effect parameters (all upfront) in the effect signature + | WP_eff_sig of tscheme + +// +// For primitive and DM4F effects, this is set in ToSyntax +// For indexed effects, typechecker sets it (in TcEffect) +// +type eff_extraction_mode = + | Extract_none of string // Effect cannot be extracted + | Extract_reify // Effect can be extracted with reification + | Extract_primitive // Effect is primitive + +instance val showable_eff_extraction_mode : showable eff_extraction_mode +instance val tagged_eff_extraction_mode : tagged eff_extraction_mode + +(* + new_effect { + STATE_h (heap:Type) : result:Type -> wp:st_wp_h heap result -> Effect + with return .... + } +*) +type eff_decl = { + mname : lident; // STATE_h + + cattributes : list cflag; + + univs : univ_names; // u#heap + binders : binders; // (heap:Type u#heap), univs and binders are in the scope of the rest of the combinators + + signature : effect_signature; + + combinators : eff_combinators; + + actions : list action; + + eff_attrs : list attribute; + + extraction_mode : eff_extraction_mode; +} + + +type sig_metadata = { + sigmeta_active:bool; + sigmeta_fact_db_ids:list string; + sigmeta_admit:bool; //An internal flag to record that a sigelt's SMT proof should be admitted + //Used in DM4Free + sigmeta_spliced:bool; + sigmeta_already_checked:bool; + // ^ This sigelt was created from a splice_t with a proof of well-typing, + // and does not need to be checked again. + sigmeta_extension_data: list (string & dyn) //each extension can register some data with a sig +} + + +type open_kind = (* matters only for resolving names with some module qualifier *) +| Open_module (* only opens the module, not the namespace *) +| Open_namespace + +type ident_alias = option ident + +(** A restriction imposed on a `open` or `include` declaration. *) +type restriction = + (** No restriction, the entire module is opened or included. *) + | Unrestricted + (** Only a specific subset of the exported definition of a module is opened or included. *) + | AllowList of list (ident & ident_alias) + +type open_module_or_namespace = (lident & open_kind & restriction) (* lident fully qualified name, already resolved. *) +type module_abbrev = (ident & lident) (* module X = A.B.C, where A.B.C is fully qualified and already resolved *) + +(* + * AR: we no longer have Sig_new_effect_for_free + * Sig_new_effect, with an eff_decl that has DM4F_eff combinators, with dummy wps plays its part + *) +type sigelt' = + | Sig_inductive_typ { //type l forall u1..un. (x1:t1) ... (xn:tn) : t + lid:lident; + us:univ_names; //u1..un + params:binders; //(x1:t1) ... (xn:tn) + num_uniform_params:option int; //number of recursively uniform type parameters + t:typ; //t + mutuals:list lident; //mutually defined types + ds:list lident; //data constructors for this type + injective_type_params:bool //is this type injective in its type parameters? + } +(* a datatype definition is a Sig_bundle of all mutually defined `Sig_inductive_typ`s and `Sig_datacon`s. + perhaps it would be nicer to let this have a 2-level structure, e.g. list list sigelt, + where each higher level list represents one of the inductive types and its constructors. + However, the current order is convenient as it matches the type-checking order for the mutuals; + i.e., all the type constructors first; then all the data which may refer to the type constructors *) + | Sig_bundle { + ses:list sigelt; //the set of mutually defined type and data constructors + lids:list lident; //all the inductive types and data constructor names in this bundle + } + | Sig_datacon { + lid:lident; //name of the datacon + us:univ_names; //universe variables of the inductive type it belongs to + t:typ; //the constructor's type as an arrow (including parameters) + ty_lid:lident; //the inductive type of the value this constructs + num_ty_params:int; //and the number of parameters of the inductive + mutuals:list lident; //mutually defined types + injective_type_params:bool //is this type injective in its type parameters? + } + | Sig_declare_typ { + lid:lident; + us:univ_names; + t:typ + } + | Sig_let { + lbs:letbindings; + lids:list lident; //mutually defined + } + | Sig_assume { + lid:lident; + us:univ_names; + phi:formula; + } + | Sig_new_effect of eff_decl + | Sig_sub_effect of sub_eff + | Sig_effect_abbrev { + lid:lident; + us:univ_names; + bs:binders; + comp:comp; + cflags:list cflag; + } + | Sig_pragma of pragma + | Sig_splice { + is_typed:bool; // true indicates a typed splice that does not re-typecheck the generated sigelt + // it is an experimental feature added as part of the meta DSL framework + lids:list lident; + tac:term; + } + + | Sig_polymonadic_bind { //(m, n) |> p, the polymonadic term, and its type + m_lid:lident; + n_lid:lident; + p_lid:lident; + tm:tscheme; + typ:tscheme; + kind:option indexed_effect_combinator_kind; + } + | Sig_polymonadic_subcomp { //m <: n, the polymonadic subcomp term, and its type + m_lid:lident; + n_lid:lident; + tm:tscheme; + typ:tscheme; + kind:option indexed_effect_combinator_kind; + } + | Sig_fail { + errs:list int; // Expected errors (empty for 'any') + fail_in_lax:bool; // true if should fail in --lax + ses:list sigelt; // The sigelts to be checked + } + +and sigelt = { + sigel: sigelt'; + sigrng: Range.range; + sigquals: list qualifier; + sigmeta: sig_metadata; + sigattrs: list attribute; + sigopens_and_abbrevs: list (either open_module_or_namespace module_abbrev); + sigopts: option vconfig; (* Saving the option context where this sigelt was checked in *) +} + + +type sigelts = list sigelt + +type modul = { + name: lident; + declarations: sigelts; + is_interface:bool; +} + +val on_antiquoted : (term -> term) -> quoteinfo -> quoteinfo + +(* Requires that bv.index is in scope for the antiquotation list. *) +val lookup_aq : bv -> antiquotations -> term + +// This is set in FStarC.Main.main, where all modules are in-scope. +val lazy_chooser : ref (option (lazy_kind -> lazyinfo -> term)) + +val mod_name: modul -> lident + +type path = list string +type subst_t = list subst_elt + +val contains_reflectable: list qualifier -> bool + +val withsort: 'a -> withinfo_t 'a +val withinfo: 'a -> Range.range -> withinfo_t 'a + +(* Constructors for each term form; NO HASH CONSING; just makes all the auxiliary data at each node *) +val mk: 'a -> range -> syntax 'a + +val mk_lb : (lbname & list univ_name & lident & typ & term & list attribute & range) -> letbinding +val default_sigmeta: sig_metadata +val mk_sigelt: sigelt' -> sigelt // FIXME check uses +val mk_Tm_app: term -> args -> range -> term + +(* This raises an exception if the term is not a Tm_fvar, + * use with care. It has to be an Tm_fvar *immediately*, + * there is no solving of Tm_delayed nor Tm_uvar. If it's + * possible that it is not a Tm_fvar, which can be the case + * for non-typechecked terms, just use `mk`. *) +val mk_Tm_uinst: term -> universes -> term + +val extend_app: term -> arg -> range -> term +val extend_app_n: term -> args -> range -> term +val mk_Tm_delayed: (term & subst_ts) -> Range.range -> term +val mk_Total: typ -> comp +val mk_GTotal: typ -> comp +val mk_Tac : typ -> comp +val mk_Comp: comp_typ -> comp +val bv_to_tm: bv -> term +val bv_to_name: bv -> term +val binders_to_names: binders -> list term + +val bv_eq: bv -> bv -> bool +val order_bv: bv -> bv -> int +val range_of_lbname: lbname -> range +val range_of_bv: bv -> range +val set_range_of_bv: bv -> range -> bv +val order_univ_name: univ_name -> univ_name -> int + +val tun: term +val teff: term +val is_teff: term -> bool +val is_type: term -> bool + +val freenames_of_binders: binders -> freenames +val binders_of_freenames: freenames -> binders +val binders_of_list: list bv -> binders + +val null_bv: term -> bv +val mk_binder_with_attrs + : bv -> bqual -> option positivity_qualifier -> list attribute -> binder +val mk_binder: bv -> binder +val null_binder: term -> binder +val as_arg: term -> arg +val imp_tag: binder_qualifier +val iarg: term -> arg +val is_null_bv: bv -> bool +val is_null_binder: binder -> bool +val argpos: arg -> Range.range +val pat_bvs: pat -> list bv +val is_bqual_implicit: bqual -> bool +val is_aqual_implicit: aqual -> bool +val is_bqual_implicit_or_meta: bqual -> bool +val as_bqual_implicit: bool -> bqual +val as_aqual_implicit: bool -> aqual +val is_top_level: list letbinding -> bool + +(* gensym *) +val freshen_bv : bv -> bv +val freshen_binder : binder -> binder +val gen_bv : string -> option Range.range -> typ -> bv +val gen_bv' : ident -> option Range.range -> typ -> bv +val new_bv : option range -> typ -> bv +val new_univ_name : option range -> univ_name +val lid_and_dd_as_fv : lident -> option fv_qual -> fv +val lid_as_fv : lident -> option fv_qual -> fv +val fv_to_tm : fv -> term +val fvar_with_dd : lident -> option fv_qual -> term +val fvar : lident -> option fv_qual -> term +val fv_eq : fv -> fv -> bool +val fv_eq_lid : fv -> lident -> bool +val range_of_fv : fv -> range +val lid_of_fv : fv -> lid +val set_range_of_fv : fv -> range -> fv + +(* attributes *) +val has_simple_attribute: list term -> string -> bool + +val eq_pat : pat -> pat -> bool + +/////////////////////////////////////////////////////////////////////// +//Some common constants +/////////////////////////////////////////////////////////////////////// +module C = FStarC.Parser.Const +val delta_constant : delta_depth +val delta_equational: delta_depth +val fvconst : lident -> fv +val tconst : lident -> term +val tabbrev : lident -> term +val tdataconstr : lident -> term +val t_unit : term +val t_bool : term +val t_int : term +val t_string : term +val t_exn : term +val t_real : term +val t_float : term +val t_char : term +val t_range : term +val t___range : term +val t_vconfig : term +val t_norm_step : term +val t_term : term +val t_term_view : term +val t_order : term +val t_decls : term +val t_binder : term +val t_bv : term +val t_tac_of : term -> term -> term +val t_tactic_of : term -> term +val t_tactic_unit : term +val t_list_of : term -> term +val t_option_of : term -> term +val t_tuple2_of : term -> term -> term +val t_tuple3_of : term -> term -> term -> term +val t_tuple4_of : term -> term -> term -> term -> term +val t_tuple5_of : term -> term -> term -> term -> term -> term +val t_either_of : term -> term -> term +val t_sealed_of : term -> term +val t_erased_of : term -> term + +val unit_const_with_range : Range.range -> term +val unit_const : term + +(** Checks wether an identity `id` is allowed by a include/open +restriction `r`. If it is not allowed, +`is_ident_allowed_by_restriction id r` returns `None`, otherwise it +returns `Some renamed`, where `renamed` is either `id` (when no there +is no `as` clause) or another identity pointing to the actual source +identity in the source module. + +For example, if we have `open Foo { my_type as the_type }`, +`is_ident_allowed_by_restriction <{ my_type as the_type }>` +will return `Some `. +*) +val is_ident_allowed_by_restriction: ident -> restriction -> option ident + +instance val has_range_syntax #a : unit -> Tot (hasRange (syntax a)) +instance val has_range_withinfo #a : unit -> Tot (hasRange (withinfo_t a)) +instance val has_range_sigelt : hasRange sigelt +instance val hasRange_fv : hasRange fv +instance val hasRange_bv : hasRange bv +instance val hasRange_binder : hasRange binder + +instance val showable_emb_typ : showable emb_typ +instance val showable_delta_depth : showable delta_depth +instance val showable_should_check_uvar : showable should_check_uvar + +instance val showable_lazy_kind : showable lazy_kind + +instance val deq_lazy_kind : deq lazy_kind +instance val deq_bv : deq bv +instance val deq_ident : deq ident +instance val deq_fv : deq lident +instance val deq_univ_name : deq univ_name +instance val deq_delta_depth : deq delta_depth + +instance val ord_bv : ord bv +instance val ord_ident : ord ident +instance val ord_fv : ord lident + +instance val tagged_term : tagged term +instance val tagged_sigelt : tagged sigelt diff --git a/src/syntax/FStarC.Syntax.TermHashTable.fsti b/src/syntax/FStarC.Syntax.TermHashTable.fsti new file mode 100644 index 00000000000..f4d0c88a9f6 --- /dev/null +++ b/src/syntax/FStarC.Syntax.TermHashTable.fsti @@ -0,0 +1,18 @@ +module FStarC.Syntax.TermHashTable +open FStarC.Compiler.Effect +open FStarC.Syntax.Syntax +module H = FStarC.Hash + +type hashtable 'a + +val create (size:int) : hashtable 'a + +val insert (key:term) (value:'a) (ht:hashtable 'a) : unit + +val lookup (key:term) (ht:hashtable 'a) : option 'a + +val clear (ht:hashtable 'a) : unit + +val reset_counters (x:hashtable 'a) : unit + +val print_stats (x:hashtable 'a) : unit diff --git a/src/syntax/FStarC.Syntax.Unionfind.fst b/src/syntax/FStarC.Syntax.Unionfind.fst new file mode 100644 index 00000000000..91f9d5453d2 --- /dev/null +++ b/src/syntax/FStarC.Syntax.Unionfind.fst @@ -0,0 +1,211 @@ +(* + Copyright 2008-2014 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Syntax.Unionfind +open FStarC.Compiler.Effect +open FStarC.Errors +open FStarC.Syntax.Syntax + +module Range = FStarC.Compiler.Range +module S = FStarC.Syntax.Syntax +module PU = FStarC.Unionfind +module BU = FStarC.Compiler.Util +module L = FStarC.Compiler.List +module O = FStarC.Options + +type vops_t = { + next_major : unit -> S.version; + next_minor : unit -> S.version +} + +let vops = + let major = BU.mk_ref 0 in + let minor = BU.mk_ref 0 in + let next_major () = + minor := 0; + {major=(BU.incr major; !major); + minor=0} + in + let next_minor () = + {major=(!major); + minor=(BU.incr minor; !minor)} + in + {next_major=next_major; + next_minor=next_minor} + +(* private *) +type tgraph = PU.puf (option S.term & S.uvar_decoration) +(* private *) +type ugraph = PU.puf (option S.universe) + +(* The type of the current unionfind graph *) +type uf = { + term_graph: tgraph; + univ_graph: ugraph; + version:version; + ro:bool; +} + +let empty (v:version) = { + term_graph = PU.puf_empty(); + univ_graph = PU.puf_empty(); + version = v; + ro = false; + } + +(*private*) +let version_to_string v = BU.format2 "%s.%s" (BU.string_of_int v.major) (BU.string_of_int v.minor) + +(* private *) +let state : ref uf = + BU.mk_ref (empty (vops.next_major())) + +type tx = + | TX of uf + +(* getting and setting the current unionfind graph + -- used during backtracking in the tactics engine *) +let get () = !state + + +let set_ro () = + let s = get () in + state := { s with ro = true } + +let set_rw () = + let s = get () in + state := { s with ro = false } + +let with_uf_enabled (f : unit -> 'a) : 'a = + let s = get () in + set_rw (); + let restore () = if s.ro then set_ro () in + + let r = + if O.trace_error () + then f () + else try f () + with | e -> begin + restore (); + raise e + end + in + restore (); + r + +let fail_if_ro () = + if (get ()).ro then + raise_error0 Fatal_BadUvar "Internal error: UF graph was in read-only mode" + +let set (u:uf) = + fail_if_ro (); + state := u + +let reset () = + fail_if_ro (); + let v = vops.next_major () in +// printfn "UF version = %s" (version_to_string v); + set ({ empty v with ro = false }) + +//////////////////////////////////////////////////////////////////////////////// +//Transacational interface, used in FStarC.TypeChecker.Rel +//////////////////////////////////////////////////////////////////////////////// +let new_transaction () = + let tx = TX (get ()) in + set ({get() with version=vops.next_minor()}); + tx +let commit (tx:tx) = () +let rollback (TX uf) = set uf +let update_in_tx (r:ref 'a) (x:'a) = () + +//////////////////////////////////////////////////////////////////////////////// +//Interface for term unification +//////////////////////////////////////////////////////////////////////////////// +(* private *) +let get_term_graph () = (get()).term_graph +let get_version () = (get()).version + +(* private *) +let set_term_graph tg = + set ({get() with term_graph = tg}) + +(*private*) +let chk_v_t (su:S.uvar) = + let u, v, rng = su in + let uvar_to_string u = "?" ^ (PU.puf_unique_id u |> BU.string_of_int) in + let expected = get_version () in + if v.major = expected.major + && v.minor <= expected.minor + then u + else + let open FStarC.Pprint in + raise_error rng Fatal_BadUvar [ + text "Internal error: incompatible version for term unification variable" + ^/^ doc_of_string (uvar_to_string u); + text "Current version: " ^/^ doc_of_string (version_to_string expected); + text "Got version: " ^/^ doc_of_string (version_to_string v); + ] + +let uvar_id u = PU.puf_id (get_term_graph()) (chk_v_t u) +let uvar_unique_id u = PU.puf_unique_id (chk_v_t u) +let fresh decoration (rng:Range.range) = + fail_if_ro (); + PU.puf_fresh (get_term_graph()) (None, decoration), get_version(), rng + +let find_core u = PU.puf_find (get_term_graph()) (chk_v_t u) +let find u = fst (find_core u) +let find_decoration u = snd (find_core u) +let change u t = let _, dec = find_core u in set_term_graph (PU.puf_change (get_term_graph()) (chk_v_t u) (Some t, dec)) +let change_decoration u d = let t, _ = find_core u in set_term_graph (PU.puf_change (get_term_graph()) (chk_v_t u) (t, d)) +let equiv u v = PU.puf_equivalent (get_term_graph()) (chk_v_t u) (chk_v_t v) +let union u v = set_term_graph (PU.puf_union (get_term_graph()) (chk_v_t u) (chk_v_t v)) + +//////////////////////////////////////////////////////////////////////////////// +//Interface for universe unification +//////////////////////////////////////////////////////////////////////////////// + +(*private*) +let get_univ_graph () = (get()).univ_graph + +(*private*) +let chk_v_u (u, v, rng) = + let uvar_to_string u = "?" ^ (PU.puf_unique_id u |> BU.string_of_int) in + let expected = get_version () in + if v.major = expected.major + && v.minor <= expected.minor + then u + else + let open FStarC.Pprint in + raise_error (rng <: Range.range) Fatal_BadUvar [ + text "Internal error: incompatible version for universe unification variable" + ^/^ doc_of_string (uvar_to_string u); + text "Current version: " ^/^ doc_of_string (version_to_string expected); + text "Got version: " ^/^ doc_of_string (version_to_string v); + ] + +(*private*) +let set_univ_graph (ug:ugraph) = + set ({get() with univ_graph = ug}) + +let univ_uvar_id u = PU.puf_id (get_univ_graph()) (chk_v_u u) +let univ_fresh (rng:Range.range) = + fail_if_ro (); + PU.puf_fresh (get_univ_graph()) None, get_version(), rng + +let univ_find u = PU.puf_find (get_univ_graph()) (chk_v_u u) +let univ_change u t = set_univ_graph (PU.puf_change (get_univ_graph()) (chk_v_u u) (Some t)) +let univ_equiv u v = PU.puf_equivalent (get_univ_graph()) (chk_v_u u) (chk_v_u v) +let univ_union u v = set_univ_graph (PU.puf_union (get_univ_graph()) (chk_v_u u) (chk_v_u v)) diff --git a/src/syntax/FStarC.Syntax.Unionfind.fsti b/src/syntax/FStarC.Syntax.Unionfind.fsti new file mode 100644 index 00000000000..7ddcae88b3c --- /dev/null +++ b/src/syntax/FStarC.Syntax.Unionfind.fsti @@ -0,0 +1,61 @@ +(* + Copyright 2008-2014 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Syntax.Unionfind + +(* This module offers a transactional interface specialized for terms and + * universes on top of the existing union-find implementation. *) + +open FStarC.Compiler.Effect +module Range = FStarC.Compiler.Range +module S = FStarC.Syntax.Syntax + +val uf : Type0 +val get : unit -> uf +val set : uf -> unit +val reset : unit -> unit + +(* Set read-only mode *) +val set_ro : unit -> unit + +(* Set read-write mode *) +val set_rw : unit -> unit + +(* Run a function with rw mode enabled *) +val with_uf_enabled : (unit -> 'a) -> 'a + +val tx : Type0 +val new_transaction : (unit -> tx) +val rollback : tx -> unit +val commit : tx -> unit +val update_in_tx : ref 'a -> 'a -> unit + +val fresh : S.uvar_decoration -> Range.range -> S.uvar +val uvar_id : S.uvar -> int +val uvar_unique_id : S.uvar -> int +val find : S.uvar -> option S.term +val find_decoration : S.uvar -> S.uvar_decoration +val change : S.uvar -> S.term -> unit +val change_decoration : S.uvar -> S.uvar_decoration -> unit +val equiv : S.uvar -> S.uvar -> bool +val union : S.uvar -> S.uvar -> unit + +val univ_fresh : Range.range -> S.universe_uvar +val univ_uvar_id : S.universe_uvar -> int +val univ_find : S.universe_uvar -> option S.universe +val univ_change : S.universe_uvar -> S.universe -> unit +val univ_equiv : S.universe_uvar -> S.universe_uvar -> bool +val univ_union : S.universe_uvar -> S.universe_uvar -> unit diff --git a/src/syntax/FStarC.Syntax.Util.fst b/src/syntax/FStarC.Syntax.Util.fst new file mode 100644 index 00000000000..bd7dc1d2627 --- /dev/null +++ b/src/syntax/FStarC.Syntax.Util.fst @@ -0,0 +1,2152 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Syntax.Util +open Prims +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.Ident +open FStarC.Compiler.Range +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.Const +open FStarC.Dyn +module U = FStarC.Compiler.Util +module List = FStarC.Compiler.List +module PC = FStarC.Parser.Const + +open FStarC.Class.Show +open FStarC.Class.Monad +open FStarC.Class.Setlike + +(********************************************************************************) +(**************************Utilities for identifiers ****************************) +(********************************************************************************) + +(* A hook into FStarC.Syntax.Print, only for debugging and error messages. + * The reference is set in FStarC.Main *) +let tts_f : ref (option (term -> string)) = U.mk_ref None +let tts t : string = + match !tts_f with + | None -> "<>" + | Some f -> f t + +let ttd_f : ref (option (term -> Pprint.document)) = U.mk_ref None +let ttd t : Pprint.document = + match !ttd_f with + | None -> Pprint.doc_of_string "<>" + | Some f -> f t + +let mk_discriminator lid = + lid_of_ids (ns_of_lid lid + @ [mk_ident (Ident.reserved_prefix ^ "is_" ^ (string_of_id (ident_of_lid lid)), + range_of_lid lid)]) + +let is_name (lid:lident) = + let c = U.char_at (string_of_id (ident_of_lid lid)) 0 in + U.is_upper c + +let aqual_of_binder (b:binder) + : aqual + = match b.binder_qual, b.binder_attrs with + | Some (Implicit _), _ + | Some (Meta _), _ -> + Some ({ aqual_implicit = true; + aqual_attributes = b.binder_attrs }) + | _, _::_ -> + Some ({ aqual_implicit = false; + aqual_attributes = b.binder_attrs }) + | _ -> None + +let bqual_and_attrs_of_aqual (a:aqual) + : bqual & list attribute + = match a with + | None -> None, [] + | Some a -> (if a.aqual_implicit then Some imp_tag else None), + a.aqual_attributes + +let arg_of_non_null_binder b = (bv_to_name b.binder_bv, aqual_of_binder b) + +let args_of_non_null_binders (binders:binders) = + binders |> List.collect (fun b -> + if is_null_binder b then [] + else [arg_of_non_null_binder b]) + +let args_of_binders (binders:Syntax.binders) : (Syntax.binders & args) = + binders |> List.map (fun b -> + if is_null_binder b + then let b = { b with binder_bv = new_bv None b.binder_bv.sort } in + b, arg_of_non_null_binder b + else b, arg_of_non_null_binder b) |> List.unzip + +let name_binders binders = + binders |> List.mapi (fun i b -> + if is_null_binder b + then let bname = id_of_text ("_" ^ string_of_int i) in + let bv = {ppname=bname; index=0; sort=b.binder_bv.sort} in + { b with binder_bv = bv } + else b) + +let name_function_binders t = match t.n with + | Tm_arrow {bs=binders; comp} -> mk (Tm_arrow {bs=name_binders binders; comp}) t.pos + | _ -> t + +let null_binders_of_tks (tks:list (typ & bqual)) : binders = + tks |> List.map (fun (t, imp) -> { null_binder t with binder_qual = imp }) + +let binders_of_tks (tks:list (typ & bqual)) : binders = + tks |> List.map (fun (t, imp) -> mk_binder_with_attrs (new_bv (Some t.pos) t) imp None []) + +let mk_subst s = [s] + +let subst_of_list (formals:binders) (actuals:args) : subst_t = + if (List.length formals = List.length actuals) + then List.fold_right2 (fun f a out -> NT(f.binder_bv, fst a)::out) formals actuals [] + else failwith "Ill-formed substitution" + +let rename_binders (replace_xs:binders) (with_ys:binders) : subst_t = + if List.length replace_xs = List.length with_ys + then List.map2 (fun x y -> NT(x.binder_bv, bv_to_name y.binder_bv)) replace_xs with_ys + else failwith "Ill-formed substitution" + +open FStarC.Syntax.Subst + +let rec unmeta e = + let e = compress e in + match e.n with + | Tm_meta {tm=e} + | Tm_ascribed {tm=e} -> unmeta e + | _ -> e + +let rec unmeta_safe e = + let e = compress e in + match e.n with + | Tm_meta {tm=e'; meta=m} -> + begin match m with + | Meta_monadic _ + | Meta_monadic_lift _ -> + e // don't remove the metas that really matter + | _ -> unmeta_safe e' + end + | Tm_ascribed {tm=e} -> unmeta_safe e + | _ -> e + +let unmeta_lift (t:term) : term = + match (compress t).n with + | Tm_meta {tm=t; meta=Meta_monadic_lift _} -> t + | _ -> t + +(********************************************************************************) +(*************************** Utilities for universes ****************************) +(********************************************************************************) +(* kernel u = (k_u, n) + where u is of the form S^n k_u + i.e., k_u is the "kernel" and n is the offset *) +let rec univ_kernel u = match Subst.compress_univ u with + | U_unknown + | U_name _ + | U_unif _ + | U_max _ + | U_zero -> u, 0 + | U_succ u -> let k, n = univ_kernel u in k, n+1 + | U_bvar i -> failwith ("Imposible: univ_kernel (U_bvar " ^ show i ^ ")") + +//requires: kernel u = U_zero, n +//returns: n +let constant_univ_as_nat u = snd (univ_kernel u) + +//ordering on universes: +// constants come first, in order of their size +// named universes come next, in lexical order of their kernels and their offsets +// unification variables next, in lexical order of their kernels and their offsets +// max terms come last +//e.g, [Z; S Z; S S Z; u1; S u1; u2; S u2; S S u2; ?v1; S ?v1; ?v2] +let rec compare_univs (u1:universe) (u2:universe) : int = + let rec compare_kernel (uk1:universe) (uk2:universe) : int = + match Subst.compress_univ uk1, Subst.compress_univ uk2 with + | U_bvar _, _ + | _, U_bvar _ -> failwith "Impossible: compare_kernel bvar" + + | U_succ _, _ + | _, U_succ _ -> failwith "Impossible: compare_kernel succ" + + | U_unknown, U_unknown -> 0 + | U_unknown, _ -> -1 + | _, U_unknown -> 1 + + | U_zero, U_zero -> 0 + | U_zero, _ -> -1 + | _, U_zero -> 1 + + | U_name u1 , U_name u2 -> String.compare (string_of_id u1) (string_of_id u2) + | U_name _, _ -> -1 + | _, U_name _ -> 1 + + | U_unif u1, U_unif u2 -> Unionfind.univ_uvar_id u1 - Unionfind.univ_uvar_id u2 + | U_unif _, _ -> -1 + | _, U_unif _ -> 1 + + (* Only remaining case *) + | U_max us1, U_max us2 -> + let n1 = List.length us1 in + let n2 = List.length us2 in + if n1 <> n2 + then n1 - n2 (* first order by increasing length *) + else + (* for same length, order lexicographically *) + let copt = U.find_map (List.zip us1 us2) (fun (u1, u2) -> + let c = compare_univs u1 u2 in + if c<>0 then Some c + else None) in + begin match copt with + | None -> 0 + | Some c -> c + end + in + let uk1, n1 = univ_kernel u1 in + let uk2, n2 = univ_kernel u2 in + match compare_kernel uk1 uk2 with + | 0 -> n1 - n2 + | n -> n + +let eq_univs u1 u2 = compare_univs u1 u2 = 0 + +let eq_univs_list (us:universes) (vs:universes) : bool = + List.length us = List.length vs + && List.forall2 eq_univs us vs + +(********************************************************************************) +(*********************** Utilities for computation types ************************) +(********************************************************************************) + +let ml_comp t r = + mk_Comp ({comp_univs=[U_zero]; + effect_name=set_lid_range (PC.effect_ML_lid()) r; + result_typ=t; + effect_args=[]; + flags=[MLEFFECT]}) + +let comp_effect_name c = match c.n with + | Comp c -> c.effect_name + | Total _ -> PC.effect_Tot_lid + | GTotal _ -> PC.effect_GTot_lid + +let comp_flags c = match c.n with + | Total _ -> [TOTAL] + | GTotal _ -> [SOMETRIVIAL] + | Comp ct -> ct.flags + +let comp_eff_name_res_and_args (c:comp) : lident & typ & args = + match c.n with + | Total t -> PC.effect_Tot_lid, t, [] + | GTotal t -> PC.effect_GTot_lid, t, [] + | Comp c -> c.effect_name, c.result_typ, c.effect_args + +(* + * For layered effects, given a (repr a is), return is + * For wp effects, given a (unit -> M a wp), return wp + * + * The pattern matching is very syntactic inside this function + * It is called from the computation types in the layered effect combinators + * e.g. f and g in bind + * Layered effects typechecking code already makes sure that those types + * have this exact shape + *) +let effect_indices_from_repr (repr:term) (is_layered:bool) (r:Range.range) (err:string) +: list term = + let err () = Errors.raise_error r Errors.Fatal_UnexpectedEffect err in + let repr = compress repr in + if is_layered + then match repr.n with + | Tm_app {args=_::is} -> is |> List.map fst + | _ -> err () + else match repr.n with + | Tm_arrow {comp=c} -> c |> comp_eff_name_res_and_args |> (fun (_, _, args) -> args |> List.map fst) + | _ -> err () + +let destruct_comp c : (universe & typ & typ) = + let wp = match c.effect_args with + | [(wp, _)] -> wp + | _ -> + failwith (U.format2 + "Impossible: Got a computation %s with %s effect args" + (string_of_lid c.effect_name) + (c.effect_args |> List.length |> string_of_int)) in + List.hd c.comp_univs, c.result_typ, wp + +let is_named_tot c = + match c.n with + | Comp c -> lid_equals c.effect_name PC.effect_Tot_lid + | Total _ -> true + | GTotal _ -> false + +let is_total_comp c = + lid_equals (comp_effect_name c) PC.effect_Tot_lid + || comp_flags c |> U.for_some (function TOTAL | RETURN -> true | _ -> false) + +let is_partial_return c = comp_flags c |> U.for_some (function RETURN | PARTIAL_RETURN -> true | _ -> false) + +let is_tot_or_gtot_comp c = + is_total_comp c + || lid_equals PC.effect_GTot_lid (comp_effect_name c) + +let is_pure_effect l = + lid_equals l PC.effect_Tot_lid + || lid_equals l PC.effect_PURE_lid + || lid_equals l PC.effect_Pure_lid + +let is_pure_comp c = match c.n with + | Total _ -> true + | GTotal _ -> false + | Comp ct -> is_total_comp c + || is_pure_effect ct.effect_name + || ct.flags |> U.for_some (function LEMMA -> true | _ -> false) + +let is_ghost_effect l = + lid_equals PC.effect_GTot_lid l + || lid_equals PC.effect_GHOST_lid l + || lid_equals PC.effect_Ghost_lid l + +let is_div_effect l = + lid_equals l PC.effect_DIV_lid + || lid_equals l PC.effect_Div_lid + || lid_equals l PC.effect_Dv_lid + +let is_pure_or_ghost_comp c = is_pure_comp c || is_ghost_effect (comp_effect_name c) + +let is_pure_or_ghost_effect l = is_pure_effect l || is_ghost_effect l + +let is_pure_or_ghost_function t = match (compress t).n with + | Tm_arrow {comp=c} -> is_pure_or_ghost_comp c + | _ -> true + +let is_lemma_comp c = + match c.n with + | Comp ct -> lid_equals ct.effect_name PC.effect_Lemma_lid + | _ -> false + +let is_lemma t = + match (compress t).n with + | Tm_arrow {comp=c} -> is_lemma_comp c + | _ -> false + +let rec head_of (t : term) : term = + match (compress t).n with + | Tm_app {hd=t} + | Tm_match {scrutinee=t} + | Tm_abs {body=t} + | Tm_ascribed {tm=t} + | Tm_meta {tm=t} -> head_of t + | _ -> t + +let head_and_args t = + let t = compress t in + match t.n with + | Tm_app {hd=head; args} -> head, args + | _ -> t, [] + +let rec __head_and_args_full acc unmeta t = + let t = compress t in + match t.n with + | Tm_app {hd=head; args} -> + __head_and_args_full (args@acc) unmeta head + | Tm_meta {tm} when unmeta -> + __head_and_args_full acc unmeta tm + | _ -> t, acc + +let head_and_args_full t = __head_and_args_full [] false t +let head_and_args_full_unmeta t = __head_and_args_full [] true t + +let rec leftmost_head t = + let t = compress t in + match t.n with + | Tm_app {hd=t0} + | Tm_meta {tm=t0; meta=Meta_pattern _} + | Tm_meta {tm=t0; meta= Meta_named _} + | Tm_meta {tm=t0; meta=Meta_labeled _} + | Tm_meta {tm=t0; meta=Meta_desugared _} + | Tm_ascribed {tm=t0} -> + leftmost_head t0 + | _ -> t + + +let leftmost_head_and_args t = + let rec aux t args = + let t = compress t in + match t.n with + | Tm_app {hd=t0; args=args'} -> aux t0 (args'@args) + | Tm_meta {tm=t0; meta=Meta_pattern _} + | Tm_meta {tm=t0; meta=Meta_named _} + | Tm_meta {tm=t0; meta=Meta_labeled _} + | Tm_meta {tm=t0; meta=Meta_desugared _} + | Tm_ascribed {tm=t0} -> aux t0 args + | _ -> t, args + in + aux t [] + + +let un_uinst t = + let t = Subst.compress t in + match t.n with + | Tm_uinst (t, _) -> Subst.compress t + | _ -> t + +let is_ml_comp c = match c.n with + | Comp c -> lid_equals c.effect_name (PC.effect_ML_lid()) + || c.flags |> U.for_some (function MLEFFECT -> true | _ -> false) + + | _ -> false + +let comp_result c = match c.n with + | Total t + | GTotal t -> t + | Comp ct -> ct.result_typ + +let set_result_typ c t = match c.n with + | Total _ -> mk_Total t + | GTotal _ -> mk_GTotal t + | Comp ct -> mk_Comp({ct with result_typ=t}) + +let is_trivial_wp c = + comp_flags c |> U.for_some (function TOTAL | RETURN -> true | _ -> false) + +let comp_effect_args (c:comp) :args = + match c.n with + | Total _ + | GTotal _ -> [] + | Comp ct -> ct.effect_args + +(********************************************************************************) +(* Simple utils on the structure of a term *) +(********************************************************************************) +let primops = + [PC.op_Eq; + PC.op_notEq; + PC.op_LT; + PC.op_LTE; + PC.op_GT; + PC.op_GTE; + PC.op_Subtraction; + PC.op_Minus; + PC.op_Addition; + PC.op_Multiply; + PC.op_Division; + PC.op_Modulus; + PC.op_And; + PC.op_Or; + PC.op_Negation;] +let is_primop_lid l = primops |> U.for_some (lid_equals l) + +let is_primop f = match f.n with + | Tm_fvar fv -> is_primop_lid fv.fv_name.v + | _ -> false + +let rec unascribe e = + let e = Subst.compress e in + match e.n with + | Tm_ascribed {tm=e} -> unascribe e + | _ -> e + +let rec ascribe t k = match t.n with + | Tm_ascribed {tm=t'} -> ascribe t' k + | _ -> mk (Tm_ascribed {tm=t; asc=k; eff_opt=None}) t.pos + +let unfold_lazy i = must !lazy_chooser i.lkind i + +let rec unlazy t = + match (compress t).n with + | Tm_lazy i -> unlazy <| unfold_lazy i + | _ -> t + +let unlazy_emb t = + match (compress t).n with + | Tm_lazy i -> + begin match i.lkind with + | Lazy_embedding _ -> unlazy <| unfold_lazy i + | _ -> t + end + | _ -> t + +let unlazy_as_t k t = + let open FStarC.Class.Show in + let open FStarC.Class.Deq in + match (compress t).n with + | Tm_lazy ({lkind=k'; blob=v}) -> + if k =? k' + then Dyn.undyn v + else failwith (U.format2 "Expected Tm_lazy of kind %s, got %s" + (show k) (show k')) + | _ -> + failwith "Not a Tm_lazy of the expected kind" + +let mk_lazy (t : 'a) (typ : typ) (k : lazy_kind) (r : option range) : term = + let rng = (match r with | Some r -> r | None -> dummyRange) in + let i = { + lkind = k; + blob = mkdyn t; + ltyp = typ; + rng = rng; + } in + mk (Tm_lazy i) rng + +let canon_app t = + let hd, args = head_and_args_full (unascribe t) in + mk_Tm_app hd args t.pos + +let rec unrefine t = + let t = compress t in + match t.n with + | Tm_refine {b=x} -> unrefine x.sort + | Tm_ascribed {tm=t} -> unrefine t + | _ -> t + +let rec is_uvar t = + match (compress t).n with + | Tm_uvar _ -> true + | Tm_uinst (t, _) -> is_uvar t + | Tm_app _ -> t |> head_and_args |> fst |> is_uvar + | Tm_ascribed {tm=t} -> is_uvar t + | _ -> false + +let rec is_unit t = + match (unrefine t).n with + | Tm_fvar fv -> + fv_eq_lid fv PC.unit_lid + || fv_eq_lid fv PC.squash_lid + || fv_eq_lid fv PC.auto_squash_lid + | Tm_app {hd=head} -> is_unit head + | Tm_uinst (t, _) -> is_unit t + | _ -> false + +let is_eqtype_no_unrefine (t:term) = + match (Subst.compress t).n with + | Tm_fvar fv -> fv_eq_lid fv PC.eqtype_lid + | _ -> false + +let is_fun e = match (compress e).n with + | Tm_abs _ -> true + | _ -> false + +let is_function_typ t = match (compress t).n with + | Tm_arrow _ -> true + | _ -> false + +let rec pre_typ t = + let t = compress t in + match t.n with + | Tm_refine {b=x} -> pre_typ x.sort + | Tm_ascribed {tm=t} -> pre_typ t + | _ -> t + +let destruct typ lid = + let typ = compress typ in + match (un_uinst typ).n with + | Tm_app {hd=head; args} -> + let head = un_uinst head in + begin match head.n with + | Tm_fvar tc when fv_eq_lid tc lid -> Some args + | _ -> None + end + | Tm_fvar tc when fv_eq_lid tc lid -> Some [] + | _ -> None + +let lids_of_sigelt (se: sigelt) = match se.sigel with + | Sig_let {lids} + | Sig_splice {lids} + | Sig_bundle {lids} -> lids + | Sig_inductive_typ {lid} + | Sig_effect_abbrev {lid} + | Sig_datacon {lid} + | Sig_declare_typ {lid} + | Sig_assume {lid} -> [lid] + | Sig_new_effect d -> [d.mname] + | Sig_sub_effect _ + | Sig_pragma _ + | Sig_fail _ + | Sig_polymonadic_bind _ -> [] + | Sig_polymonadic_subcomp _ -> [] + +let lid_of_sigelt se : option lident = match lids_of_sigelt se with + | [l] -> Some l + | _ -> None + +let quals_of_sigelt (x: sigelt) = x.sigquals + +let range_of_sigelt (x: sigelt) = x.sigrng + +let range_of_arg (hd, _) = hd.pos + +let range_of_args args r = + args |> List.fold_left (fun r a -> Range.union_ranges r (range_of_arg a)) r + +let mk_app f args = + match args with + | [] -> f + | _ -> + let r = range_of_args args f.pos in + mk (Tm_app {hd=f; args}) r + +let mk_app_binders f bs = + mk_app f (List.map (fun b -> (bv_to_name b.binder_bv, aqual_of_binder b)) bs) + +(***********************************************************************************************) +(* Combining an effect name with the name of one of its actions, or a + data constructor name with the name of one of its formal parameters + + NOTE: the conventions defined here must be in sync with manually + linked ML files, such as ulib/ml/prims.ml + *) +(***********************************************************************************************) + +let field_projector_prefix = "__proj__" + +(* NOTE: the following would have been desirable: + +<< +let field_projector_prefix = Ident.reserved_prefix ^ "proj__" +>> + + but it DOES NOT work with --use_hints on + examples/preorders/MRefHeap.fst (even after regenerating hints), it + will produce the following error: + + fstar.exe --use_hints MRefHeap.fst + ./MRefHeap.fst(55,51-58,27): (Error) Unknown assertion failed + Verified module: MRefHeap (2150 milliseconds) + 1 error was reported (see above) + + In fact, any naming convention that DOES NOT start with + Ident.reserved_prefix seems to work. +*) + +let field_projector_sep = "__item__" + +let field_projector_contains_constructor s = U.starts_with s field_projector_prefix + +let mk_field_projector_name_from_string constr field = + field_projector_prefix ^ constr ^ field_projector_sep ^ field + +let mk_field_projector_name_from_ident lid (i : ident) = + let itext = (string_of_id i) in + let newi = + if field_projector_contains_constructor itext + then i + else mk_ident (mk_field_projector_name_from_string (string_of_id (ident_of_lid lid)) itext, range_of_id i) + in + lid_of_ids (ns_of_lid lid @ [newi]) + +let mk_field_projector_name lid (x:bv) i = + let nm = if Syntax.is_null_bv x + then mk_ident("_" ^ U.string_of_int i, Syntax.range_of_bv x) + else x.ppname in + mk_field_projector_name_from_ident lid nm + +let ses_of_sigbundle (se:sigelt) :list sigelt = + match se.sigel with + | Sig_bundle {ses} -> ses + | _ -> failwith "ses_of_sigbundle: not a Sig_bundle" + +let set_uvar uv t = + match Unionfind.find uv with + | Some t' -> + failwith (U.format3 "Changing a fixed uvar! ?%s to %s but \ + it is already set to %s\n" (U.string_of_int <| Unionfind.uvar_id uv) + (tts t) + (tts t')) + | _ -> Unionfind.change uv t + +let qualifier_equal q1 q2 = match q1, q2 with + | Discriminator l1, Discriminator l2 -> lid_equals l1 l2 + | Projector (l1a, l1b), Projector (l2a, l2b) -> lid_equals l1a l2a && (string_of_id l1b = string_of_id l2b) + | RecordType (ns1, f1), RecordType (ns2, f2) + | RecordConstructor (ns1, f1), RecordConstructor (ns2, f2) -> + List.length ns1 = List.length ns2 && List.forall2 (fun x1 x2 -> (string_of_id x1) = (string_of_id x2)) f1 f2 && + List.length f1 = List.length f2 && List.forall2 (fun x1 x2 -> (string_of_id x1) = (string_of_id x2)) f1 f2 + | _ -> q1=q2 + + +(***********************************************************************************************) +(* closing types and terms *) +(***********************************************************************************************) +let abs bs t lopt = + let close_lopt lopt = match lopt with + | None -> None + | Some rc -> Some ({rc with residual_typ=FStarC.Compiler.Util.map_opt rc.residual_typ (close bs)}) + in + match bs with + | [] -> t + | _ -> + let body = compress (Subst.close bs t) in + match body.n with + | Tm_abs {bs=bs'; body=t; rc_opt=lopt'} -> //AR: if the body is an Tm_abs, we can combine the binders and use lopt', ignoring lopt, since lopt will be Tot (non-informative anyway) + mk (Tm_abs {bs=close_binders bs@bs'; body=t; rc_opt=close_lopt lopt'}) t.pos + | _ -> + mk (Tm_abs {bs=close_binders bs; body; rc_opt=close_lopt lopt}) t.pos + +let arrow_ln bs c = match bs with + | [] -> comp_result c + | _ -> mk (Tm_arrow {bs; comp=c}) + (List.fold_left (fun a b -> Range.union_ranges a b.binder_bv.sort.pos) c.pos bs) + +let arrow bs c = + let c = Subst.close_comp bs c in + let bs = close_binders bs in + arrow_ln bs c + +let flat_arrow bs c = + let t = arrow bs c in + match (Subst.compress t).n with + | Tm_arrow {bs; comp=c} -> + begin match c.n with + | Total tres -> + begin match (Subst.compress tres).n with + | Tm_arrow {bs=bs'; comp=c'} -> mk (Tm_arrow {bs=bs@bs'; comp=c'}) t.pos + | _ -> t + end + | _ -> t + end + | _ -> t + +let rec canon_arrow t = + match (compress t).n with + | Tm_arrow {bs; comp=c} -> + let cn = match c.n with + | Total t -> Total (canon_arrow t) + | _ -> c.n + in + let c = { c with n = cn } in + flat_arrow bs c + | _ -> t + +let refine b t = mk (Tm_refine {b; phi=Subst.close [mk_binder b] t}) (Range.union_ranges (range_of_bv b) t.pos) +let branch b = Subst.close_branch b + +let has_decreases (c:comp) : bool = + match c.n with + | Comp ct -> + begin match ct.flags |> U.find_opt (function DECREASES _ -> true | _ -> false) with + | Some (DECREASES _) -> true + | _ -> false + end + | _ -> false + +(* + * AR: this function returns the binders and comp result type of an arrow type, + * flattening arrows of the form t -> Tot (t1 -> C), so that it returns two binders in this example + * the function also descends under the refinements (e.g. t -> Tot (f:(t1 -> C){phi})) + *) +let rec arrow_formals_comp_ln (k:term) = + let k = Subst.compress k in + match k.n with + | Tm_arrow {bs; comp=c} -> + if is_total_comp c && not (has_decreases c) + then let bs', k = arrow_formals_comp_ln (comp_result c) in + bs@bs', k + else bs, c + | Tm_refine {b={ sort = s }} -> + (* + * AR: start descending into s, but if s does not turn out to be an arrow later, we want to return k itself + *) + let rec aux (s:term) (k:term) = + match (Subst.compress s).n with + | Tm_arrow _ -> arrow_formals_comp_ln s //found an arrow, go to the main function + | Tm_refine {b={ sort = s }} -> aux s k //another refinement, descend into it, but with the same def + | _ -> [], Syntax.mk_Total k //return def + in + aux s k + | _ -> [], Syntax.mk_Total k + +let arrow_formals_comp k = + let bs, c = arrow_formals_comp_ln k in + Subst.open_comp bs c + +let arrow_formals_ln k = + let bs, c = arrow_formals_comp_ln k in + bs, comp_result c + +let arrow_formals k = + let bs, c = arrow_formals_comp k in + bs, comp_result c + +(* let_rec_arity e f: + if `f` is a let-rec bound name in e + then this function returns + 1. f's type + 2. the natural arity of f, i.e., the number of arguments including universes on which the let rec is defined + 3. a list of booleans, one for each argument above, where the boolean is true iff the variable appears in the f's decreases clause + This is used by NBE for detecting potential non-terminating loops +*) +let let_rec_arity (lb:letbinding) : int & option (list bool) = + let rec arrow_until_decreases (k:term) = + let k = Subst.compress k in + match k.n with + | Tm_arrow {bs; comp=c} -> + let bs, c = Subst.open_comp bs c in + (match + c |> comp_flags |> U.find_opt (function DECREASES _ -> true | _ -> false) + with + | Some (DECREASES d) -> + bs, Some d + | _ -> + if is_total_comp c + then let bs', d = arrow_until_decreases (comp_result c) in + bs@bs', d + else bs, None) + + | Tm_refine {b={ sort = k }} -> + arrow_until_decreases k + + | _ -> [], None + in + let bs, dopt = arrow_until_decreases lb.lbtyp in + let n_univs = List.length lb.lbunivs in + n_univs + List.length bs, + U.map_opt dopt (fun d -> + let d_bvs = + match d with + | Decreases_lex l -> + l |> List.fold_left (fun s t -> + union s (FStarC.Syntax.Free.names t)) (empty #bv ()) + | Decreases_wf (rel, e) -> + union (Free.names rel) (Free.names e) in + Common.tabulate n_univs (fun _ -> false) + @ (bs |> List.map (fun b -> mem b.binder_bv d_bvs))) + +let abs_formals_maybe_unascribe_body maybe_unascribe t = + let subst_lcomp_opt s l = match l with + | Some rc -> + Some ({rc with residual_typ=FStarC.Compiler.Util.map_opt rc.residual_typ (Subst.subst s)}) + | _ -> l + in + let rec aux t abs_body_lcomp = + match (unmeta_safe t).n with + | Tm_abs {bs; body=t; rc_opt=what} -> + if maybe_unascribe + then let bs',t, what = aux t what in + bs@bs', t, what + else bs, t, what + | _ -> [], t, abs_body_lcomp + in + let bs, t, abs_body_lcomp = aux t None in + let bs, t, opening = Subst.open_term' bs t in + let abs_body_lcomp = subst_lcomp_opt opening abs_body_lcomp in + bs, t, abs_body_lcomp + +let abs_formals t = abs_formals_maybe_unascribe_body true t + +let remove_inacc (t:term) : term = + let no_acc (b : binder) : binder = + let aq = + match b.binder_qual with + | Some (Implicit true) -> Some (Implicit false) + | aq -> aq + in + { b with binder_qual = aq } + in + let bs, c = arrow_formals_comp_ln t in + match bs with + | [] -> t + | _ -> mk (Tm_arrow {bs=List.map no_acc bs; comp=c}) t.pos + +let mk_letbinding (lbname : either bv fv) univ_vars typ eff def lbattrs pos = + {lbname=lbname; + lbunivs=univ_vars; + lbtyp=typ; + lbeff=eff; + lbdef=def; + lbattrs=lbattrs; + lbpos=pos; + } + + +let close_univs_and_mk_letbinding recs lbname univ_vars typ eff def attrs pos = + let def = match recs, univ_vars with + | None, _ + | _, [] -> def + | Some fvs, _ -> + let universes = univ_vars |> List.map U_name in + let inst = fvs |> List.map (fun fv -> fv.fv_name.v, universes) in + FStarC.Syntax.InstFV.instantiate inst def + in + let typ = Subst.close_univ_vars univ_vars typ in + let def = Subst.close_univ_vars univ_vars def in + mk_letbinding lbname univ_vars typ eff def attrs pos + +let open_univ_vars_binders_and_comp uvs binders c = + match binders with + | [] -> + let uvs, c = Subst.open_univ_vars_comp uvs c in + uvs, [], c + | _ -> + let t' = arrow binders c in + let uvs, t' = Subst.open_univ_vars uvs t' in + match (Subst.compress t').n with + | Tm_arrow {bs=binders; comp=c} -> uvs, binders, c + | _ -> failwith "Impossible" + +(********************************************************************************) +(*********************** Various tests on constants ****************************) +(********************************************************************************) + +let is_tuple_constructor (t:typ) = match t.n with + | Tm_fvar fv -> PC.is_tuple_constructor_string (string_of_lid fv.fv_name.v) + | _ -> false + +let is_dtuple_constructor (t:typ) = match t.n with + | Tm_fvar fv -> PC.is_dtuple_constructor_lid fv.fv_name.v + | _ -> false + +let is_lid_equality x = lid_equals x PC.eq2_lid + +let is_forall lid = lid_equals lid PC.forall_lid +let is_exists lid = lid_equals lid PC.exists_lid +let is_qlid lid = is_forall lid || is_exists lid +let is_equality x = is_lid_equality x.v + +let lid_is_connective = + let lst = [PC.and_lid; PC.or_lid; PC.not_lid; + PC.iff_lid; PC.imp_lid] in + fun lid -> U.for_some (lid_equals lid) lst + +let is_constructor t lid = + match (pre_typ t).n with + | Tm_fvar tc -> lid_equals tc.fv_name.v lid + | _ -> false + +let rec is_constructed_typ t lid = + match (pre_typ t).n with + | Tm_fvar _ -> is_constructor t lid + | Tm_app {hd=t} + | Tm_uinst(t, _) -> is_constructed_typ t lid + | _ -> false + +let rec get_tycon t = + let t = pre_typ t in + match t.n with + | Tm_bvar _ + | Tm_name _ + | Tm_fvar _ -> Some t + | Tm_app {hd=t} -> get_tycon t + | _ -> None + +let is_fstar_tactics_by_tactic t = + match (un_uinst t).n with + | Tm_fvar fv -> fv_eq_lid fv PC.by_tactic_lid + | _ -> false + +(********************************************************************************) +(*********************** Constructors of common terms **************************) +(********************************************************************************) + +let ktype : term = mk (Tm_type(U_unknown)) dummyRange +let ktype0 : term = mk (Tm_type(U_zero)) dummyRange + +//Type(u), where u is a new universe unification variable +let type_u () : typ & universe = + let u = U_unif <| Unionfind.univ_fresh Range.dummyRange in + mk (Tm_type u) dummyRange, u + +let type_with_u (u:universe) : typ = mk (Tm_type u) dummyRange + +// // works on anything, really +// let attr_eq a a' = +// match eq_tm a a' with +// | Equal -> true +// | _ -> false + +let attr_substitute = + mk (Tm_fvar (lid_as_fv PC.attr_substitute_lid None)) Range.dummyRange + +let exp_bool (b:bool) : term = mk (Tm_constant (Const_bool b)) dummyRange +let exp_true_bool : term = exp_bool true +let exp_false_bool : term = exp_bool false +let exp_unit : term = mk (Tm_constant (Const_unit)) dummyRange +(* Makes an (unbounded) integer from its string repr. *) +let exp_int s : term = mk (Tm_constant (Const_int (s,None))) dummyRange +let exp_char c : term = mk (Tm_constant (Const_char c)) dummyRange +let exp_string s : term = mk (Tm_constant (Const_string (s, dummyRange))) dummyRange + +let fvar_const l = fvar_with_dd l None +let tand = fvar_const PC.and_lid +let tor = fvar_const PC.or_lid +let timp = fvar_with_dd PC.imp_lid None +let tiff = fvar_with_dd PC.iff_lid None +let t_bool = fvar_const PC.bool_lid +let b2t_v = fvar_const PC.b2t_lid +let t_not = fvar_const PC.not_lid +// These are `True` and `False`, not the booleans +let t_false = fvar_const PC.false_lid +let t_true = fvar_const PC.true_lid +let tac_opaque_attr = exp_string "tac_opaque" +let dm4f_bind_range_attr = fvar_const PC.dm4f_bind_range_attr +let tcdecltime_attr = fvar_const PC.tcdecltime_attr +let inline_let_attr = fvar_const PC.inline_let_attr +let rename_let_attr = fvar_const PC.rename_let_attr + +let t_ctx_uvar_and_sust = fvar_const PC.ctx_uvar_and_subst_lid +let t_universe_uvar = fvar_const PC.universe_uvar_lid + +let t_dsl_tac_typ = fvar PC.dsl_tac_typ_lid None + + +let mk_conj_opt phi1 phi2 = match phi1 with + | None -> Some phi2 + | Some phi1 -> Some (mk (Tm_app {hd=tand; args=[as_arg phi1; as_arg phi2]}) (Range.union_ranges phi1.pos phi2.pos)) +let mk_binop op_t phi1 phi2 = mk (Tm_app {hd=op_t; args=[as_arg phi1; as_arg phi2]}) (Range.union_ranges phi1.pos phi2.pos) +let mk_neg phi = mk (Tm_app {hd=t_not; args=[as_arg phi]}) phi.pos +let mk_conj phi1 phi2 = mk_binop tand phi1 phi2 +let mk_conj_l phi = match phi with + | [] -> fvar_with_dd PC.true_lid None + | hd::tl -> List.fold_right mk_conj tl hd +let mk_disj phi1 phi2 = mk_binop tor phi1 phi2 +let mk_disj_l phi = match phi with + | [] -> t_false + | hd::tl -> List.fold_right mk_disj tl hd +let mk_imp phi1 phi2 : term = mk_binop timp phi1 phi2 +let mk_iff phi1 phi2 : term = mk_binop tiff phi1 phi2 +let b2t e = mk (Tm_app {hd=b2t_v; args=[as_arg e]}) e.pos//implicitly coerce a boolean to a type +let unb2t (e:term) : option term = + let hd, args = head_and_args e in + match (compress hd).n, args with + | Tm_fvar fv, [(e, _)] when fv_eq_lid fv PC.b2t_lid -> Some e + | _ -> None + +let is_t_true t = + match (unmeta t).n with + | Tm_fvar fv -> fv_eq_lid fv PC.true_lid + | _ -> false +let mk_conj_simp t1 t2 = + if is_t_true t1 then t2 + else if is_t_true t2 then t1 + else mk_conj t1 t2 +let mk_disj_simp t1 t2 = + if is_t_true t1 then t_true + else if is_t_true t2 then t_true + else mk_disj t1 t2 + +let teq = fvar_const PC.eq2_lid +let mk_untyped_eq2 e1 e2 = mk (Tm_app {hd=teq; args=[as_arg e1; as_arg e2]}) (Range.union_ranges e1.pos e2.pos) +let mk_eq2 (u:universe) (t:typ) (e1:term) (e2:term) : term = + let eq_inst = mk_Tm_uinst teq [u] in + mk (Tm_app {hd=eq_inst; args=[iarg t; as_arg e1; as_arg e2]}) (Range.union_ranges e1.pos e2.pos) + +let mk_eq3_no_univ = + let teq3 = fvar_const PC.eq3_lid in + fun t1 t2 e1 e2 -> + mk (Tm_app {hd=teq3; args=[iarg t1; iarg t2; as_arg e1; as_arg e2]}) + (Range.union_ranges e1.pos e2.pos) + +let mk_has_type t x t' = + let t_has_type = fvar_const PC.has_type_lid in //TODO: Fix the U_zeroes below! + let t_has_type = mk (Tm_uinst(t_has_type, [U_zero; U_zero])) dummyRange in + mk (Tm_app {hd=t_has_type; args=[iarg t; as_arg x; as_arg t']}) dummyRange + +let tforall = fvar_with_dd PC.forall_lid None +let texists = fvar_with_dd PC.exists_lid None +let t_haseq = fvar_with_dd PC.haseq_lid None + +let decidable_eq = fvar_const PC.op_Eq +let mk_decidable_eq t e1 e2 = + mk (Tm_app {hd=decidable_eq; args=[iarg t; as_arg e1; as_arg e2]}) (Range.union_ranges e1.pos e2.pos) +let b_and = fvar_const PC.op_And +let mk_and e1 e2 = + mk (Tm_app {hd=b_and; args=[as_arg e1; as_arg e2]}) (Range.union_ranges e1.pos e2.pos) +let mk_and_l l = match l with + | [] -> exp_true_bool + | hd::tl -> List.fold_left mk_and hd tl +let mk_boolean_negation b = + mk (Tm_app {hd=fvar_const PC.op_Negation; args=[as_arg b]}) b.pos +let mk_residual_comp l t f = { + residual_effect=l; + residual_typ=t; + residual_flags=f + } +let residual_tot t = { + residual_effect=PC.effect_Tot_lid; + residual_typ=Some t; + residual_flags=[TOTAL] + } +let residual_gtot t = { + residual_effect=PC.effect_GTot_lid; + residual_typ=Some t; + residual_flags=[TOTAL] + } +let residual_comp_of_comp (c:comp) = { + residual_effect=comp_effect_name c; + residual_typ=Some (comp_result c); + residual_flags=List.filter (function DECREASES _ -> false | _ -> true) <| comp_flags c; + } + +let mk_forall_aux fa x body = + mk (Tm_app {hd=fa; + args=[ iarg (x.sort); + as_arg (abs [mk_binder x] body (Some (residual_tot ktype0)))]}) dummyRange + +let mk_forall_no_univ (x:bv) (body:typ) : typ = + mk_forall_aux tforall x body + +let mk_forall (u:universe) (x:bv) (body:typ) : typ = + let tforall = mk_Tm_uinst tforall [u] in + mk_forall_aux tforall x body + +let close_forall_no_univs bs f = + List.fold_right (fun b f -> if Syntax.is_null_binder b then f else mk_forall_no_univ b.binder_bv f) bs f + +let mk_exists_aux fa x body = + mk (Tm_app {hd=fa; + args=[ iarg (x.sort); + as_arg (abs [mk_binder x] body (Some (residual_tot ktype0)))]}) dummyRange + +let mk_exists_no_univ (x:bv) (body:typ) : typ = + mk_exists_aux texists x body + +let mk_exists (u:universe) (x:bv) (body:typ) : typ = + let texists = mk_Tm_uinst texists [u] in + mk_exists_aux texists x body + +let close_exists_no_univs bs f = + List.fold_right (fun b f -> if Syntax.is_null_binder b then f else mk_exists_no_univ b.binder_bv f) bs f + +let if_then_else b t1 t2 = + let then_branch = (withinfo (Pat_constant (Const_bool true)) t1.pos, None, t1) in + let else_branch = (withinfo (Pat_constant (Const_bool false)) t2.pos, None, t2) in + mk (Tm_match {scrutinee=b; ret_opt=None; brs=[then_branch; else_branch]; rc_opt=None}) + (Range.union_ranges b.pos (Range.union_ranges t1.pos t2.pos)) + +////////////////////////////////////////////////////////////////////////////////////// +// Operations on squashed and other irrelevant/sub-singleton types +////////////////////////////////////////////////////////////////////////////////////// +let mk_squash u p = + let sq = fvar_with_dd PC.squash_lid None in + mk_app (mk_Tm_uinst sq [u]) [as_arg p] + +let mk_auto_squash u p = + let sq = fvar_with_dd PC.auto_squash_lid None in + mk_app (mk_Tm_uinst sq [u]) [as_arg p] + +let un_squash t = + let head, args = head_and_args t in + let head = unascribe head in + let head = un_uinst head in + match (compress head).n, args with + | Tm_fvar fv, [(p, _)] + when fv_eq_lid fv PC.squash_lid -> + Some p + | Tm_refine {b; phi=p}, [] -> + begin match b.sort.n with + | Tm_fvar fv when fv_eq_lid fv PC.unit_lid -> + let bs, p = Subst.open_term [mk_binder b] p in + let b = match bs with + | [b] -> b + | _ -> failwith "impossible" + in + // A bit paranoid, but need this check for terms like `u:unit{u == ()}` + if mem b.binder_bv (Free.names p) + then None + else Some p + | _ -> None + end + | _ -> + None + +let is_squash t = + let head, args = head_and_args t in + match (Subst.compress head).n, args with + | Tm_uinst({n=Tm_fvar fv}, [u]), [(t, _)] + when Syntax.fv_eq_lid fv PC.squash_lid -> + Some (u, t) + | _ -> None + + +let is_auto_squash t = + let head, args = head_and_args t in + match (Subst.compress head).n, args with + | Tm_uinst({n=Tm_fvar fv}, [u]), [(t, _)] + when Syntax.fv_eq_lid fv PC.auto_squash_lid -> + Some (u, t) + | _ -> None + +let is_sub_singleton t = + let head, _ = head_and_args (unmeta t) in + match (un_uinst head).n with + | Tm_fvar fv -> + Syntax.fv_eq_lid fv PC.unit_lid + || Syntax.fv_eq_lid fv PC.squash_lid + || Syntax.fv_eq_lid fv PC.auto_squash_lid + || Syntax.fv_eq_lid fv PC.and_lid + || Syntax.fv_eq_lid fv PC.or_lid + || Syntax.fv_eq_lid fv PC.not_lid + || Syntax.fv_eq_lid fv PC.imp_lid + || Syntax.fv_eq_lid fv PC.iff_lid + || Syntax.fv_eq_lid fv PC.ite_lid + || Syntax.fv_eq_lid fv PC.exists_lid + || Syntax.fv_eq_lid fv PC.forall_lid + || Syntax.fv_eq_lid fv PC.true_lid + || Syntax.fv_eq_lid fv PC.false_lid + || Syntax.fv_eq_lid fv PC.eq2_lid + || Syntax.fv_eq_lid fv PC.b2t_lid + //these are an uninterpreted predicates + //which we are better off treating as sub-singleton + || Syntax.fv_eq_lid fv PC.haseq_lid + || Syntax.fv_eq_lid fv PC.has_type_lid + || Syntax.fv_eq_lid fv PC.precedes_lid + | _ -> false + +let arrow_one_ln (t:typ) : option (binder & comp) = + match (compress t).n with + | Tm_arrow {bs=[]} -> + failwith "fatal: empty binders on arrow?" + | Tm_arrow {bs=[b]; comp=c} -> + Some (b, c) + | Tm_arrow {bs=b::bs; comp=c} -> + (* NB: bs are closed, so we just repackage the node *) + let rng' = List.fold_left (fun a b -> Range.union_ranges a b.binder_bv.sort.pos) c.pos bs in + let c' = mk_Total (mk (Tm_arrow {bs; comp=c}) rng') in + Some (b, c') + | _ -> + None + +let arrow_one (t:typ) : option (binder & comp) = + bind_opt (arrow_one_ln t) (fun (b, c) -> + let bs, c = Subst.open_comp [b] c in + let b = match bs with + | [b] -> b + | _ -> failwith "impossible: open_comp returned different amount of binders" + in + Some (b, c)) + +let abs_one_ln (t:typ) : option (binder & term) = + match (compress t).n with + | Tm_abs {bs=[]} -> + failwith "fatal: empty binders on abs?" + | Tm_abs {bs=[b]; body} -> + Some (b, body) + | Tm_abs {bs=b::bs; body; rc_opt} -> + Some (b, abs bs body rc_opt) + | _ -> + None + +let is_free_in (bv:bv) (t:term) : bool = + mem bv (FStarC.Syntax.Free.names t) + +let action_as_lb eff_lid a pos = + let lb = + close_univs_and_mk_letbinding None + (Inr (lid_and_dd_as_fv a.action_name None)) + a.action_univs + (arrow a.action_params (mk_Total a.action_typ)) + PC.effect_Tot_lid + (abs a.action_params a.action_defn None) + [] + pos + in + { sigel = Sig_let {lbs=(false, [lb]); lids=[a.action_name]}; + sigrng = a.action_defn.pos; + sigquals = [Visible_default ; Action eff_lid]; + sigmeta = default_sigmeta; + sigattrs = []; + sigopts = None; + sigopens_and_abbrevs = []; + } + +(* Some reification utilities *) +let mk_reify t (lopt:option Ident.lident) = + let reify_ = mk (Tm_constant (FStarC.Const.Const_reify lopt)) t.pos in + mk (Tm_app {hd=reify_; args=[as_arg t]}) t.pos + +let mk_reflect t = + let reflect_ = mk (Tm_constant(FStarC.Const.Const_reflect (Ident.lid_of_str "Bogus.Effect"))) t.pos in + mk (Tm_app {hd=reflect_; args=[as_arg t]}) t.pos + +(* Some utilities for clients who wish to build top-level bindings and keep + * their delta-qualifiers correct (e.g. dmff). *) + +let rec incr_delta_depth d = + match d with + | Delta_constant_at_level i -> Delta_constant_at_level (i + 1) + | Delta_equational_at_level i -> Delta_equational_at_level (i + 1) + | Delta_abstract d -> incr_delta_depth d + +let is_unknown t = match (Subst.compress t).n with | Tm_unknown -> true | _ -> false + +let rec apply_last f l = match l with + | [] -> failwith "apply_last: got empty list" + | [a] -> [f a] + | (x::xs) -> x :: (apply_last f xs) + +let dm4f_lid ed name : lident = + let p = path_of_lid ed.mname in + let p' = apply_last (fun s -> "_dm4f_" ^ s ^ "_" ^ name) p in + lid_of_path p' Range.dummyRange + +let mk_list (typ:term) (rng:range) (l:list term) : term = + let ctor l = mk (Tm_fvar (lid_as_fv l (Some Data_ctor))) rng in + let cons args pos = mk_Tm_app (mk_Tm_uinst (ctor PC.cons_lid) [U_zero]) args pos in + let nil args pos = mk_Tm_app (mk_Tm_uinst (ctor PC.nil_lid) [U_zero]) args pos in + List.fold_right (fun t a -> cons [iarg typ; as_arg t; as_arg a] t.pos) l (nil [iarg typ] rng) + +// Some generic equalities +let rec eqlist (eq : 'a -> 'a -> bool) (xs : list 'a) (ys : list 'a) : bool = + match xs, ys with + | [], [] -> true + | x::xs, y::ys -> eq x y && eqlist eq xs ys + | _ -> false + +let eqsum (e1 : 'a -> 'a -> bool) (e2 : 'b -> 'b -> bool) (x : either 'a 'b) (y : either 'a 'b) : bool = + match x, y with + | Inl x, Inl y -> e1 x y + | Inr x, Inr y -> e2 x y + | _ -> false + +let eqprod (e1 : 'a -> 'a -> bool) (e2 : 'b -> 'b -> bool) (x : 'a & 'b) (y : 'a & 'b) : bool = + match x, y with + | (x1,x2), (y1,y2) -> e1 x1 y1 && e2 x2 y2 + +let eqopt (e : 'a -> 'a -> bool) (x : option 'a) (y : option 'a) : bool = + match x, y with + | Some x, Some y -> e x y + | None, None -> true + | _ -> false + +// Checks for syntactic equality. A returned false doesn't guarantee anything. +// We DO NOT OPEN TERMS as we descend on them, and just compare their bound variable +// indices. We also ignore some parts of the syntax such universes and most annotations. + +// Setting this ref to `true` causes messages to appear when +// some discrepancy was found. This is useful when trying to debug +// why term_eq is returning `false`. This reference is `one shot`, +// it will disable itself when term_eq returns, but in that single run +// it will provide a (backwards) trace of where the discrepancy apperared. +// +// Use at your own peril, and please keep it if there's no good +// reason against it, so I don't have to go crazy again. +let debug_term_eq = U.mk_ref false + +let check dbg msg cond = + if cond + then true + else (if dbg then U.print1 ">>> term_eq failing: %s\n" msg; false) + +let fail dbg msg = check dbg msg false + +let rec term_eq_dbg (dbg : bool) t1 t2 = + let t1 = canon_app (unmeta_safe t1) in + let t2 = canon_app (unmeta_safe t2) in + let check = check dbg in + let fail = fail dbg in + match (compress (un_uinst t1)).n, (compress (un_uinst t2)).n with + | Tm_uinst _, _ + | _, Tm_uinst _ + (* -> eqlist eq_univs us1 us2 && term_eq_dbg dbg t1 t2 *) + | Tm_delayed _, _ + | _, Tm_delayed _ + | Tm_ascribed _, _ + | _, Tm_ascribed _ -> + failwith "term_eq: impossible, should have been removed" + + | Tm_bvar x , Tm_bvar y -> check "bvar" (x.index = y.index) + | Tm_name x , Tm_name y -> check "name" (x.index = y.index) + | Tm_fvar x , Tm_fvar y -> check "fvar" (fv_eq x y) + | Tm_constant c1 , Tm_constant c2 -> check "const" (eq_const c1 c2) + | Tm_type _, Tm_type _ -> true // x = y + + | Tm_abs {bs=b1;body=t1;rc_opt=k1}, Tm_abs {bs=b2;body=t2;rc_opt=k2} -> + (check "abs binders" (eqlist (binder_eq_dbg dbg) b1 b2)) && + (check "abs bodies" (term_eq_dbg dbg t1 t2)) + //&& eqopt (eqsum lcomp_eq_dbg dbg residual_eq) k1 k2 + + | Tm_arrow {bs=b1;comp=c1}, Tm_arrow {bs=b2;comp=c2} -> + (check "arrow binders" (eqlist (binder_eq_dbg dbg) b1 b2)) && + (check "arrow comp" (comp_eq_dbg dbg c1 c2)) + + | Tm_refine {b=b1;phi=t1}, Tm_refine {b=b2;phi=t2} -> + (check "refine bv sort" (term_eq_dbg dbg b1.sort b2.sort)) && + (check "refine formula" (term_eq_dbg dbg t1 t2)) + + | Tm_app {hd=f1; args=a1}, Tm_app {hd=f2; args=a2} -> + (check "app head" (term_eq_dbg dbg f1 f2)) && + (check "app args" (eqlist (arg_eq_dbg dbg) a1 a2)) + + | Tm_match {scrutinee=t1;ret_opt=None;brs=bs1}, + Tm_match {scrutinee=t2;ret_opt=None;brs=bs2} -> //AR: note: no return annotations + (check "match head" (term_eq_dbg dbg t1 t2)) && + (check "match branches" (eqlist (branch_eq_dbg dbg) bs1 bs2)) + + | Tm_lazy _, _ -> check "lazy_l" (term_eq_dbg dbg (unlazy t1) t2) + | _, Tm_lazy _ -> check "lazy_r" (term_eq_dbg dbg t1 (unlazy t2)) + + | Tm_let {lbs=(b1, lbs1); body=t1}, Tm_let {lbs=(b2, lbs2); body=t2} -> + (check "let flag" (b1 = b2)) && + (check "let lbs" (eqlist (letbinding_eq_dbg dbg) lbs1 lbs2)) && + (check "let body" (term_eq_dbg dbg t1 t2)) + + | Tm_uvar (u1, _), Tm_uvar (u2, _) -> + (* These must have alreade been resolved, so we check that + * they are indeed the same uvar *) + check "uvar" (u1.ctx_uvar_head = u2.ctx_uvar_head) + + | Tm_quoted (qt1, qi1), Tm_quoted (qt2, qi2) -> + (check "tm_quoted qi" (quote_info_eq_dbg dbg qi1 qi2)) && + (check "tm_quoted payload" (term_eq_dbg dbg qt1 qt2)) + + | Tm_meta {tm=t1; meta=m1}, Tm_meta {tm=t2; meta=m2} -> + begin match m1, m2 with + | Meta_monadic (n1, ty1), Meta_monadic (n2, ty2) -> + (check "meta_monadic lid" (lid_equals n1 n2)) && + (check "meta_monadic type" (term_eq_dbg dbg ty1 ty2)) + + | Meta_monadic_lift (s1, t1, ty1), Meta_monadic_lift (s2, t2, ty2) -> + (check "meta_monadic_lift src" (lid_equals s1 s2)) && + (check "meta_monadic_lift tgt" (lid_equals t1 t2)) && + (check "meta_monadic_lift type" (term_eq_dbg dbg ty1 ty2)) + + | _ -> fail "metas" + end + + // ? + | Tm_unknown, _ + | _, Tm_unknown -> fail "unk" + + | Tm_bvar _, _ + | Tm_name _, _ + | Tm_fvar _, _ + | Tm_constant _, _ + | Tm_type _, _ + | Tm_abs _, _ + | Tm_arrow _, _ + | Tm_refine _, _ + | Tm_app _, _ + | Tm_match _, _ + | Tm_let _, _ + | Tm_uvar _, _ + | Tm_meta _, _ + | _, Tm_bvar _ + | _, Tm_name _ + | _, Tm_fvar _ + | _, Tm_constant _ + | _, Tm_type _ + | _, Tm_abs _ + | _, Tm_arrow _ + | _, Tm_refine _ + | _, Tm_app _ + | _, Tm_match _ + | _, Tm_let _ + | _, Tm_uvar _ + | _, Tm_meta _ -> fail "bottom" + +and arg_eq_dbg (dbg : bool) a1 a2 = + eqprod (fun t1 t2 -> check dbg "arg tm" (term_eq_dbg dbg t1 t2)) + (fun q1 q2 -> check dbg "arg qual" (aqual_eq_dbg dbg q1 q2)) + a1 a2 +and binder_eq_dbg (dbg : bool) b1 b2 = + (check dbg "binder_sort" (term_eq_dbg dbg b1.binder_bv.sort b2.binder_bv.sort)) && + (check dbg "binder qual" (bqual_eq_dbg dbg b1.binder_qual b2.binder_qual)) && //AR: not checking attributes, should we? + (check dbg "binder attrs" (eqlist (term_eq_dbg dbg) b1.binder_attrs b2.binder_attrs)) + +and comp_eq_dbg (dbg : bool) c1 c2 = + let eff1, res1, args1 = comp_eff_name_res_and_args c1 in + let eff2, res2, args2 = comp_eff_name_res_and_args c2 in + (check dbg "comp eff" (lid_equals eff1 eff2)) && + //(check "comp univs" (c1.comp_univs = c2.comp_univs)) && + (check dbg "comp result typ" (term_eq_dbg dbg res1 res2)) && + (* (check "comp args" (eqlist arg_eq_dbg dbg c1.effect_args c2.effect_args)) && *) + true //eq_flags c1.flags c2.flags +and branch_eq_dbg (dbg : bool) (p1,w1,t1) (p2,w2,t2) = + (check dbg "branch pat" (eq_pat p1 p2)) && + (check dbg "branch body" (term_eq_dbg dbg t1 t2)) + && (check dbg "branch when" ( + match w1, w2 with + | Some x, Some y -> term_eq_dbg dbg x y + | None, None -> true + | _ -> false)) + +and letbinding_eq_dbg (dbg : bool) (lb1 : letbinding) lb2 = + // bvars have no meaning here, so we just check they have the same name + (check dbg "lb bv" (eqsum (fun bv1 bv2 -> true) fv_eq lb1.lbname lb2.lbname)) && + (* (check "lb univs" (lb1.lbunivs = lb2.lbunivs)) *) + (check dbg "lb typ" (term_eq_dbg dbg lb1.lbtyp lb2.lbtyp)) && + (check dbg "lb def" (term_eq_dbg dbg lb1.lbdef lb2.lbdef)) + // Ignoring eff and attrs.. + +and quote_info_eq_dbg (dbg:bool) q1 q2 = + if q1.qkind <> q2.qkind + then false + else antiquotations_eq_dbg dbg (snd q1.antiquotations) (snd q2.antiquotations) + +and antiquotations_eq_dbg (dbg:bool) a1 a2 = + // Basically this; + // List.fold_left2 (fun acc t1 t2 -> eq_inj acc (eq_tm t1 t2)) Equal a1 a2 + // but lazy and handling lists of different size + match a1, a2 with + | [], [] -> true + | [], _ + | _, [] -> false + | t1::a1, t2::a2 -> + if not <| term_eq_dbg dbg t1 t2 + then false + else antiquotations_eq_dbg dbg a1 a2 + +and bqual_eq_dbg dbg a1 a2 = + match a1, a2 with + | None, None -> true + | None, _ + | _, None -> false + | Some (Implicit b1), Some (Implicit b2) when b1=b2 -> true + | Some (Meta t1), Some (Meta t2) -> term_eq_dbg dbg t1 t2 + | Some Equality, Some Equality -> true + | _ -> false + +and aqual_eq_dbg dbg a1 a2 = + match a1, a2 with + | Some a1, Some a2 -> + if a1.aqual_implicit = a2.aqual_implicit + && List.length a1.aqual_attributes = List.length a2.aqual_attributes + then List.fold_left2 + (fun out t1 t2 -> + if not out + then false + else term_eq_dbg dbg t1 t2) + true + a1.aqual_attributes + a2.aqual_attributes + else false + | None, None -> + true + | _ -> + false + +let eq_aqual a1 a2 = aqual_eq_dbg false a1 a2 +let eq_bqual b1 b2 = bqual_eq_dbg false b1 b2 + +let term_eq t1 t2 = + let r = term_eq_dbg !debug_term_eq t1 t2 in + debug_term_eq := false; + r + +// An estimation of the size of a term, only for debugging +let rec sizeof (t:term) : int = + match t.n with + | Tm_delayed _ -> 1 + sizeof (compress t) + | Tm_bvar bv + | Tm_name bv -> 1 + sizeof bv.sort + | Tm_uinst (t,us) -> List.length us + sizeof t + | Tm_abs {bs; body=t} -> sizeof t + List.fold_left (fun acc b -> acc + sizeof b.binder_bv.sort) 0 bs + | Tm_app {hd; args} -> sizeof hd + List.fold_left (fun acc (arg, _) -> acc + sizeof arg) 0 args + // TODO: obviously want much more + | _ -> 1 + +let is_fvar lid t = + match (un_uinst t).n with + | Tm_fvar fv -> fv_eq_lid fv lid + | _ -> false + +let is_synth_by_tactic t = + is_fvar PC.synth_lid t + +let has_attribute (attrs:list Syntax.attribute) (attr:lident) = + FStarC.Compiler.Util.for_some (is_fvar attr) attrs + +(* Checks whether the list of attrs contains an application of `attr`, and + * returns the arguments if so. If there's more than one, the first one + * takes precedence. *) +let get_attribute (attr : lident) (attrs:list Syntax.attribute) : option args = + List.tryPick (fun t -> + let head, args = head_and_args t in + match (Subst.compress head).n with + | Tm_fvar fv when fv_eq_lid fv attr -> Some args + | _ -> None) attrs + +let remove_attr (attr : lident) (attrs:list attribute) : list attribute = + List.filter (fun a -> not (is_fvar attr a)) attrs + +/////////////////////////////////////////// +// Setting pragmas +/////////////////////////////////////////// +let process_pragma p r = + FStarC.Errors.set_option_warning_callback_range (Some r); + let set_options s = + match Options.set_options s with + | Getopt.Success -> () + | Getopt.Help -> + Errors.raise_error r Errors.Fatal_FailToProcessPragma + "Failed to process pragma: use 'fstar --help' to see which options are available" + | Getopt.Error s -> + Errors.raise_error r Errors.Fatal_FailToProcessPragma + ("Failed to process pragma: " ^ s) + in + match p with + | ShowOptions -> + () + + | SetOptions o -> + set_options o + + | ResetOptions sopt -> + Options.restore_cmd_line_options false |> ignore; + begin match sopt with + | None -> () + | Some s -> set_options s + end + + | PushOptions sopt -> + Options.internal_push (); + begin match sopt with + | None -> () + | Some s -> set_options s + end + + | RestartSolver -> + () + + | PopOptions -> + if not (Options.internal_pop ()) then + Errors.raise_error r Errors.Fatal_FailToProcessPragma + "Cannot #pop-options, stack would become empty" + + | PrintEffectsGraph -> () //Typechecker handles it + +/////////////////////////////////////////////////////////////////////////////////////////////// +let rec unbound_variables tm : list bv = + let t = Subst.compress tm in + match t.n with + | Tm_delayed _ -> failwith "Impossible" + + | Tm_name x -> + [] + + | Tm_uvar _ -> + [] + + | Tm_type u -> + [] + + | Tm_bvar x -> + [x] + + | Tm_fvar _ + | Tm_constant _ + | Tm_lazy _ + | Tm_unknown -> + [] + + | Tm_uinst(t, us) -> + unbound_variables t + + | Tm_abs {bs; body=t} -> + let bs, t = Subst.open_term bs t in + List.collect (fun b -> unbound_variables b.binder_bv.sort) bs + @ unbound_variables t + + | Tm_arrow {bs; comp=c} -> + let bs, c = Subst.open_comp bs c in + List.collect (fun b -> unbound_variables b.binder_bv.sort) bs + @ unbound_variables_comp c + + | Tm_refine {b; phi=t} -> + let bs, t = Subst.open_term [mk_binder b] t in + List.collect (fun b -> unbound_variables b.binder_bv.sort) bs + @ unbound_variables t + + | Tm_app {hd=t; args} -> + List.collect (fun (x, _) -> unbound_variables x) args + @ unbound_variables t + + | Tm_match {scrutinee=t; ret_opt=asc_opt; brs=pats} -> + unbound_variables t + @ (match asc_opt with + | None -> [] + | Some (b, asc) -> + let bs, asc = Subst.open_ascription [b] asc in + List.collect (fun b -> unbound_variables b.binder_bv.sort) bs + @ unbound_variables_ascription asc) + @ (pats |> List.collect (fun br -> + let p, wopt, t = Subst.open_branch br in + unbound_variables t + @ (match wopt with None -> [] | Some t -> unbound_variables t))) + + | Tm_ascribed {tm=t1; asc} -> + unbound_variables t1 @ (unbound_variables_ascription asc) + + | Tm_let {lbs=(false, [lb]); body=t} -> + unbound_variables lb.lbtyp + @ unbound_variables lb.lbdef + @ (match lb.lbname with + | Inr _ -> unbound_variables t + | Inl bv -> let _, t= Subst.open_term [mk_binder bv] t in + unbound_variables t) + + | Tm_let {lbs=(_, lbs); body=t} -> + let lbs, t = Subst.open_let_rec lbs t in + unbound_variables t + @ List.collect (fun lb -> unbound_variables lb.lbtyp @ unbound_variables lb.lbdef) lbs + + | Tm_quoted (tm, qi) -> + begin match qi.qkind with + | Quote_static -> [] + | Quote_dynamic -> unbound_variables tm + end + + | Tm_meta {tm=t; meta=m} -> + unbound_variables t + @ (match m with + | Meta_pattern (_, args) -> + List.collect (List.collect (fun (a, _) -> unbound_variables a)) args + + | Meta_monadic_lift(_, _, t') + | Meta_monadic(_, t') -> + unbound_variables t' + + | Meta_labeled _ + | Meta_desugared _ + | Meta_named _ -> []) + +and unbound_variables_ascription asc = + let asc, topt, _ = asc in + (match asc with + | Inl t2 -> unbound_variables t2 + | Inr c2 -> unbound_variables_comp c2) @ + (match topt with + | None -> [] + | Some tac -> unbound_variables tac) + +and unbound_variables_comp c = + match c.n with + | Total t + | GTotal t -> + unbound_variables t + + | Comp ct -> + unbound_variables ct.result_typ + @ List.collect (fun (a, _) -> unbound_variables a) ct.effect_args + +let extract_attr' (attr_lid:lid) (attrs:list term) : option (list term & args) = + let rec aux acc attrs = + match attrs with + | [] -> None + | h::t -> + let head, args = head_and_args h in + begin match (compress head).n with + | Tm_fvar fv when fv_eq_lid fv attr_lid -> + let attrs' = List.rev_acc acc t in + Some (attrs', args) + | _ -> + aux (h::acc) t + end + in + aux [] attrs + +let extract_attr (attr_lid:lid) (se:sigelt) : option (sigelt & args) = + match extract_attr' attr_lid se.sigattrs with + | None -> None + | Some (attrs', t) -> Some ({ se with sigattrs = attrs' }, t) + +(* Utilities for working with Lemma's decorated with SMTPat *) +let is_smt_lemma t = match (compress t).n with + | Tm_arrow {comp=c} -> + begin match c.n with + | Comp ct when lid_equals ct.effect_name PC.effect_Lemma_lid -> + begin match ct.effect_args with + | _req::_ens::(pats, _)::_ -> + let pats' = unmeta pats in + let head, _ = head_and_args pats' in + begin match (un_uinst head).n with + | Tm_fvar fv -> fv_eq_lid fv PC.cons_lid + | _ -> false + end + | _ -> false + end + | _ -> false + end + | _ -> false + +let rec list_elements (e:term) : option (list term) = + let head, args = head_and_args (unmeta e) in + match (un_uinst head).n, args with + | Tm_fvar fv, _ when fv_eq_lid fv PC.nil_lid -> + Some [] + | Tm_fvar fv, [_; (hd, _); (tl, _)] when fv_eq_lid fv PC.cons_lid -> + Some (hd::must (list_elements tl)) + | _ -> + None + +let destruct_lemma_with_smt_patterns (t:term) +: option (binders & term & term & list (list arg)) +//binders, pre, post, patterns += let lemma_pats p = + let smt_pat_or t = + let head, args = unmeta t |> head_and_args in + match (un_uinst head).n, args with + | Tm_fvar fv, [(e, _)] + when fv_eq_lid fv PC.smtpatOr_lid -> + Some e + | _ -> None + in + let one_pat p = + let head, args = unmeta p |> head_and_args in + match (un_uinst head).n, args with + | Tm_fvar fv, [(_, _); arg] when fv_eq_lid fv PC.smtpat_lid -> + arg + | _ -> + let open FStarC.Class.PP in + let open FStarC.Errors.Msg in + let open FStarC.Pprint in + Errors.raise_error p Errors.Error_IllSMTPat [ + prefix 2 1 (text "Not an atomic SMT pattern:") + (ttd p); + text "Patterns on lemmas must be a list of simple SMTPat's;\ + or a single SMTPatOr containing a list;\ + of lists of patterns." + ] + in + let list_literal_elements (e:term) : list term = + match list_elements e with + | Some l -> l + | None -> + Errors.log_issue e Errors.Warning_NonListLiteralSMTPattern + "SMT pattern is not a list literal; ignoring the pattern"; + [] + in + let elts = list_literal_elements p in + match elts with + | [t] -> ( + match smt_pat_or t with + | Some e -> + list_literal_elements e |> + List.map (fun branch -> (list_literal_elements branch) |> List.map one_pat) + | _ -> [elts |> List.map one_pat] + ) + | _ -> [elts |> List.map one_pat] + in + match (Subst.compress t).n with + | Tm_arrow {bs=binders; comp=c} -> + let binders, c = Subst.open_comp binders c in + begin match c.n with + | Comp ({effect_args=[(pre, _); (post, _); (pats, _)]}) -> + Some (binders, pre, post, lemma_pats pats) + | _ -> failwith "impos" + end + + | _ -> None + +let triggers_of_smt_lemma (t:term) +: list (list lident) //for each disjunctive pattern + //for each conjunct + //triggers in a conjunt += //is_smt_lemma t + match destruct_lemma_with_smt_patterns t with + | None -> [] + | Some (_, _, _, pats) -> + List.map (List.collect (fun (t, _) -> elems <| FStarC.Syntax.Free.fvars t)) pats + +(* Takes a term of shape `fun x -> e` and returns `e` when +`x` is not free in it. If it is free or the term +has some other shape just apply it to `()`. *) +let unthunk (t:term) : term = + match (compress t).n with + | Tm_abs {bs=[b]; body=e} -> + let bs, e = open_term [b] e in + let b = List.hd bs in + if is_free_in b.binder_bv e + then mk_app t [as_arg exp_unit] + else e + | _ -> + mk_app t [as_arg exp_unit] + +let unthunk_lemma_post t = + unthunk t + +let smt_lemma_as_forall (t:term) (universe_of_binders: binders -> list universe) +: term += let binders, pre, post, patterns = + match destruct_lemma_with_smt_patterns t with + | None -> failwith "impos" + | Some res -> res + in + (* Postcondition is thunked, c.f. #57 *) + let post = unthunk_lemma_post post in + let body = mk (Tm_meta {tm=mk_imp pre post; + meta=Meta_pattern (binders_to_names binders, patterns)}) t.pos in + let quant = + List.fold_right2 + (fun b u out -> mk_forall u b.binder_bv out) + binders + (universe_of_binders binders) + body + in + quant + +(* End SMT Lemma utilities *) + + +(* Effect utilities *) + +(* + * Mainly reading the combinators out of the eff_decl record + * + * For combinators that are present only in either wp or layered effects, + * their getters return option tscheme + * Leaving it to the callers to deal with it + *) + +let effect_sig_ts (sig:effect_signature) : tscheme = + match sig with + | Layered_eff_sig (_, ts) + | WP_eff_sig ts -> ts + +let apply_eff_sig (f:tscheme -> tscheme) = function + | Layered_eff_sig (n, ts) -> Layered_eff_sig (n, f ts) + | WP_eff_sig ts -> WP_eff_sig (f ts) + +let eff_decl_of_new_effect (se:sigelt) :eff_decl = + match se.sigel with + | Sig_new_effect ne -> ne + | _ -> failwith "eff_decl_of_new_effect: not a Sig_new_effect" + +let is_layered (ed:eff_decl) : bool = + match ed.combinators with + | Layered_eff _ -> true + | _ -> false + +let is_dm4f (ed:eff_decl) : bool = + match ed.combinators with + | DM4F_eff _ -> true + | _ -> false + +let apply_wp_eff_combinators (f:tscheme -> tscheme) (combs:wp_eff_combinators) +: wp_eff_combinators += { ret_wp = f combs.ret_wp; + bind_wp = f combs.bind_wp; + stronger = f combs.stronger; + if_then_else = f combs.if_then_else; + ite_wp = f combs.ite_wp; + close_wp = f combs.close_wp; + trivial = f combs.trivial; + + repr = map_option f combs.repr; + return_repr = map_option f combs.return_repr; + bind_repr = map_option f combs.bind_repr } + +let apply_layered_eff_combinators (f:tscheme -> tscheme) (combs:layered_eff_combinators) +: layered_eff_combinators += let map2 (ts1, ts2) = (f ts1, f ts2) in + let map3 (ts1, ts2, k) = (f ts1, f ts2, k) in + { l_repr = map2 combs.l_repr; + l_return = map2 combs.l_return; + l_bind = map3 combs.l_bind; + l_subcomp = map3 combs.l_subcomp; + l_if_then_else = map3 combs.l_if_then_else; + l_close = map_option map2 combs.l_close; } + +let apply_eff_combinators (f:tscheme -> tscheme) (combs:eff_combinators) : eff_combinators = + match combs with + | Primitive_eff combs -> Primitive_eff (apply_wp_eff_combinators f combs) + | DM4F_eff combs -> DM4F_eff (apply_wp_eff_combinators f combs) + | Layered_eff combs -> Layered_eff (apply_layered_eff_combinators f combs) + +let get_layered_close_combinator (ed:eff_decl) : option tscheme = + match ed.combinators with + | Layered_eff {l_close=None} -> None + | Layered_eff {l_close=Some (ts, _)} -> Some ts + | _ -> None + +let get_wp_close_combinator (ed:eff_decl) : option tscheme = + match ed.combinators with + | Primitive_eff combs + | DM4F_eff combs -> Some combs.close_wp + | _ -> None + +let get_eff_repr (ed:eff_decl) : option tscheme = + match ed.combinators with + | Primitive_eff combs + | DM4F_eff combs -> combs.repr + | Layered_eff combs -> fst combs.l_repr |> Some + +let get_bind_vc_combinator (ed:eff_decl) : tscheme & option indexed_effect_combinator_kind = + match ed.combinators with + | Primitive_eff combs + | DM4F_eff combs -> combs.bind_wp, None + | Layered_eff combs -> Mktuple3?._2 combs.l_bind, Mktuple3?._3 combs.l_bind + +let get_return_vc_combinator (ed:eff_decl) : tscheme = + match ed.combinators with + | Primitive_eff combs + | DM4F_eff combs -> combs.ret_wp + | Layered_eff combs -> snd combs.l_return + +let get_bind_repr (ed:eff_decl) : option tscheme = + match ed.combinators with + | Primitive_eff combs + | DM4F_eff combs -> combs.bind_repr + | Layered_eff combs -> Mktuple3?._1 combs.l_bind |> Some + +let get_return_repr (ed:eff_decl) : option tscheme = + match ed.combinators with + | Primitive_eff combs + | DM4F_eff combs -> combs.return_repr + | Layered_eff combs -> fst combs.l_return |> Some + +let get_wp_trivial_combinator (ed:eff_decl) : option tscheme = + match ed.combinators with + | Primitive_eff combs + | DM4F_eff combs -> combs.trivial |> Some + | _ -> None + +let get_layered_if_then_else_combinator (ed:eff_decl) : option (tscheme & option indexed_effect_combinator_kind) = + match ed.combinators with + | Layered_eff combs -> Some (Mktuple3?._1 combs.l_if_then_else, Mktuple3?._3 combs.l_if_then_else) + | _ -> None + +let get_wp_if_then_else_combinator (ed:eff_decl) : option tscheme = + match ed.combinators with + | Primitive_eff combs + | DM4F_eff combs -> combs.if_then_else |> Some + | _ -> None + +let get_wp_ite_combinator (ed:eff_decl) : option tscheme = + match ed.combinators with + | Primitive_eff combs + | DM4F_eff combs -> combs.ite_wp |> Some + | _ -> None + +let get_stronger_vc_combinator (ed:eff_decl) : tscheme & option indexed_effect_combinator_kind = + match ed.combinators with + | Primitive_eff combs + | DM4F_eff combs -> combs.stronger, None + | Layered_eff combs -> Mktuple3?._2 combs.l_subcomp, Mktuple3?._3 combs.l_subcomp + +let get_stronger_repr (ed:eff_decl) : option tscheme = + match ed.combinators with + | Primitive_eff _ + | DM4F_eff _ -> None + | Layered_eff combs -> Mktuple3?._1 combs.l_subcomp |> Some + +let aqual_is_erasable (aq:aqual) = + match aq with + | None -> false + | Some aq -> U.for_some (is_fvar PC.erasable_attr) aq.aqual_attributes + +let is_erased_head (t:term) : option (universe & term) = + let head, args = head_and_args t in + match head.n, args with + | Tm_uinst({n=Tm_fvar fv}, [u]), [(ty, _)] + when fv_eq_lid fv PC.erased_lid -> + Some (u, ty) + | _ -> + None + +let apply_reveal (u:universe) (ty:term) (v:term) = + let head = fvar (Ident.set_lid_range PC.reveal v.pos) None in + mk_Tm_app (mk_Tm_uinst head [u]) + [iarg ty; as_arg v] + v.pos + +let check_mutual_universes (lbs:list letbinding) + : unit + = let lb::lbs = lbs in + let expected = lb.lbunivs in + let expected_len = List.length expected in + List.iter + (fun lb -> + if List.length lb.lbunivs <> expected_len + || not (List.forall2 Ident.ident_equals lb.lbunivs expected) + then FStarC.Errors.raise_error lb.lbpos Errors.Fatal_IncompatibleUniverse + "Mutually recursive definitions do not abstract over the same universes") + lbs + +let ctx_uvar_should_check (u:ctx_uvar) = + (Unionfind.find_decoration u.ctx_uvar_head).uvar_decoration_should_check + +let ctx_uvar_typ (u:ctx_uvar) = + (Unionfind.find_decoration u.ctx_uvar_head).uvar_decoration_typ + +let ctx_uvar_typedness_deps (u:ctx_uvar) = + (Unionfind.find_decoration u.ctx_uvar_head).uvar_decoration_typedness_depends_on + +let flatten_refinement t = + let rec aux t unascribe = + let t = compress t in + match t.n with + | Tm_ascribed {tm=t} when unascribe -> + aux t true + | Tm_refine {b=x; phi} -> ( + let t0 = aux x.sort true in + match t0.n with + | Tm_refine {b=y; phi=phi1} -> + //NB: this is working on de Bruijn + // representations; so no need + // to substitute y/x in phi + mk (Tm_refine {b=y; phi=mk_conj_simp phi1 phi}) t0.pos + | _ -> t + ) + | _ -> t + in + aux t false + +let contains_strictly_positive_attribute (attrs:list attribute) +: bool += has_attribute attrs PC.binder_strictly_positive_attr + +let contains_unused_attribute (attrs:list attribute) +: bool += has_attribute attrs PC.binder_unused_attr + +//retains the original attributes as is, while deciding if they contains +//the "strictly_positive" attribute +//we retain the attributes since they will then be carried in arguments +//that are applied to the corresponding binder, which is used in embeddings +//and Rel to construct binders from arguments alone +let parse_positivity_attributes (attrs:list attribute) +: option positivity_qualifier & list attribute += if contains_unused_attribute attrs + then Some BinderUnused, attrs + else if contains_strictly_positive_attribute attrs + then Some BinderStrictlyPositive, attrs + else None, attrs + +let encode_positivity_attributes (pqual:option positivity_qualifier) (attrs:list attribute) +: list attribute += match pqual with + | None -> attrs + | Some BinderStrictlyPositive -> + if contains_strictly_positive_attribute attrs + then attrs + else FStarC.Syntax.Syntax.fv_to_tm (lid_as_fv PC.binder_strictly_positive_attr None) + :: attrs + | Some BinderUnused -> + if contains_unused_attribute attrs + then attrs + else FStarC.Syntax.Syntax.fv_to_tm (lid_as_fv PC.binder_unused_attr None) + :: attrs + +let is_binder_strictly_positive (b:binder) = + b.binder_positivity = Some BinderStrictlyPositive + +let is_binder_unused (b:binder) = + b.binder_positivity = Some BinderUnused + +let deduplicate_terms (l:list term) = + FStarC.Compiler.List.deduplicate (fun x y -> term_eq x y) l + +let eq_binding b1 b2 = + match b1, b2 with + | Binding_var bv1, Binding_var bv2 -> bv_eq bv1 bv2 && term_eq bv1.sort bv2.sort + | Binding_lid (lid1, _), Binding_lid (lid2, _) -> lid_equals lid1 lid2 + | Binding_univ u1, Binding_univ u2 -> ident_equals u1 u2 + | _ -> false diff --git a/src/syntax/FStarC.Syntax.Visit.fst b/src/syntax/FStarC.Syntax.Visit.fst new file mode 100644 index 00000000000..e9c9cb332c9 --- /dev/null +++ b/src/syntax/FStarC.Syntax.Visit.fst @@ -0,0 +1,28 @@ +module FStarC.Syntax.Visit + +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Compiler.Util + +open FStarC.Syntax.VisitM +open FStarC.Class.Monad + +type id (a:Type) = | I : run:a -> id a + +(* We just reuse VisitM with the identity monad to implement this module. *) + +instance _ : monad id = { + return = (fun a -> I a); + ( let! ) = (fun (I a) f -> f a); +} + +let (<<) f g = fun x -> f (g x) + +let visit_term pq vt t = + I?.run (visitM_term pq (I << vt) t) + +let visit_term_univs pq vt vu t = + I?.run (visitM_term_univs pq (I << vt) (I << vu) t) + +let visit_sigelt pq vt vu se = + I?.run (visitM_sigelt pq (I << vt) (I << vu) se) diff --git a/src/syntax/FStarC.Syntax.Visit.fsti b/src/syntax/FStarC.Syntax.Visit.fsti new file mode 100644 index 00000000000..b075b1cb1eb --- /dev/null +++ b/src/syntax/FStarC.Syntax.Visit.fsti @@ -0,0 +1,59 @@ +module FStarC.Syntax.Visit + +open FStarC.Syntax.Syntax + +(* This is a `map` visitor over terms, `visit f t` returns a version of +`t` "adjusted" by applying `f` on every node. The traversal is bottom up +(and there is no shortcircuit/cancel mechanism). Every `term` included +in `t` is visited and transformed, (function bodies, head and args of +application, binder types, bv sorts, effect args, decreases clauses, +etc). If something is not covered, that is a bug. + +NOTE: no binders are opened nor closed in this traversal. The traversal +preserves ranges but discards memoized info (vars and hash_code). + +The `f` function should handle only the cases are interesting to it, +defaulting to returning the original term elsewhere. For instance, this +(only slightly ficticious) call + + visit (fun t -> + match head_and_args t with + | (Tm_fvar plus, [a1;a2]) where fv_eq_lid plus PC.op_Addition -> + let n1 = unembed a1 in + let n2 = unembed a2 in + mk (Tm_const (C_int n2)) + + | (Tm_fvar plus, _) where fv_eq_lid plus PC.op_Addition -> + raise BadApplication + + | _ -> t + ) tm + +Will fold additions of two constants, raise an exception if the addition +operator is applied to anything but constants, and leave everything else +unchanged. As the traversal is bottom-up, this should fold expressions +like (1+2)+(3+4) in a single call. +*) +val visit_term + (proc_quotes : bool) + (f : term -> term) + (t : term) + : term + +(* As above, but a callback for universes can also be provided that works +in the same manner. In visit_term, it just defaults to the identity. *) +val visit_term_univs + (proc_quotes : bool) + (ft : term -> term) + (fu : universe -> universe) + (t : term) + : term + +(* As above, but works on any sigelt, visiting all of its underlying +terms and universes. *) +val visit_sigelt + (proc_quotes : bool) + (vt : term -> term) + (vu : universe -> universe) + (t : sigelt) + : sigelt diff --git a/src/syntax/FStarC.Syntax.VisitM.fst b/src/syntax/FStarC.Syntax.VisitM.fst new file mode 100644 index 00000000000..1eadbd49fd0 --- /dev/null +++ b/src/syntax/FStarC.Syntax.VisitM.fst @@ -0,0 +1,540 @@ +module FStarC.Syntax.VisitM + +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Compiler.Util + +open FStarC.Class.Monad + +open FStarC.Syntax +open FStarC.Syntax.Syntax + +type endo (m:Type -> Type) a = a -> m a + +(* local visitor monad, this class is not exposed, it's just +a local shortcut. *) +class lvm (m:Type->Type) : Type = { + lvm_monad : monad m; + + f_term : endo m term; + f_binder : endo m binder; + f_binding_bv : endo m bv; + f_br : endo m branch; + f_comp : endo m comp; + f_residual_comp : endo m residual_comp; + f_univ : endo m universe; + + proc_quotes : bool; +} + +instance _lvm_monad (#m:_) (_ : lvm m) : Tot (monad m) = lvm_monad + +let novfs (#m:Type->Type) {| monad m |} : lvm m = { + lvm_monad = FStar.Tactics.Typeclasses.solve; + f_term = return; + f_binder = return; + f_binding_bv = return; + f_br = return; + f_comp = return; + f_residual_comp = return; + f_univ = return; + + proc_quotes = false; +} + +let f_aqual #m {|_ : lvm m|} aq : m _ = + let {aqual_implicit=i; aqual_attributes=attrs} = aq in + let! attrs = mapM f_term attrs in + return {aqual_implicit=i; aqual_attributes=attrs} + +let on_sub_arg #m {|_ : lvm m|} (a : arg) : m arg = + let (t, q) = a in + let! t = t |> f_term in + let! q = q |> map_optM f_aqual in + return (t, q) + +let on_sub_tscheme #m {| monad m |} {|_ : lvm m|} (ts : tscheme) : m tscheme = + let (us, t) = ts in + let! t = t |> f_term in // FIXME: push univs + return (us, t) + +(* Homeomorphic calls... for now *) +let f_arg #m {|_ : lvm m|} : _ -> m _ = on_sub_arg +let f_args #m {|d : lvm m|} : _ -> m _ = mapM (f_arg #m #d) // FIXME: why instantiate? +let f_tscheme #m {|_ : lvm m|} : tscheme -> m tscheme = on_sub_tscheme + +let on_sub_meta #m {| d : lvm m |} (md : metadata) : m metadata = + match md with + | Meta_pattern (pats, args) -> + let! pats = pats |> mapM f_term in + let! args = args |> mapM (f_args #m #d) in // FIXME: idem + return <| Meta_pattern (pats, args) + + | Meta_monadic (m, typ) -> + let! typ = typ |> f_term in + return <| Meta_monadic (m, typ) + + | Meta_monadic_lift (m1, m2, typ) -> + let! typ = typ |> f_term in + return <| Meta_monadic_lift (m1, m2, typ) + + (* no subterms *) + | Meta_named lid -> return <| Meta_named lid + | Meta_labeled (s,r,b) -> return <|Meta_labeled (s,r,b) + | Meta_desugared i -> return <| Meta_desugared i + +let on_sub_letbinding #m {|lvm m|} (lb : letbinding) : m letbinding = + let! lbname = + match lb.lbname with + | Inl bv -> Inl <$> f_binding_bv bv + | Inr fv -> return (Inr fv) + in + let lbunivs = lb.lbunivs in + let! lbtyp = f_term lb.lbtyp in + let lbeff = lb.lbeff in + let! lbattrs = mapM f_term lb.lbattrs in + let lbpos = lb.lbpos in + let! lbdef = f_term lb.lbdef in // FIXME: push binder + return <| { lbname; lbunivs; lbtyp; lbeff; lbattrs; lbpos; lbdef; } + +let on_sub_ascription #m {| lvm m |} (a : ascription) : m ascription = + let (tc, tacopt, b) = a in + let! tc = match tc with + | Inl t -> Inl <$> f_term t + | Inr c -> Inr <$> f_comp c + in + let! tacopt = map_optM f_term tacopt in + return (tc, tacopt, b) + +(* Compress+unlazy *) +let rec compress (tm:term) : term = + let tm = Subst.compress tm in + match tm.n with + (* unfold and retry *) + | Tm_lazy li -> + let tm' = must !lazy_chooser li.lkind li in + compress tm' + + | _ -> tm + +(* Not recursive itself! This does not apply anything deeply! The +recursion on deep subterms comes from the knot being tied below. *) +let on_sub_term #m {|d : lvm m |} (tm : term) : m term = + let mk t = Syntax.mk t tm.pos in + let tm = compress tm in + match tm.n with + | Tm_lazy _ + | Tm_delayed _ -> + failwith "impos" + + (* no subterms *) + | Tm_fvar _ + | Tm_constant _ + | Tm_unknown + | Tm_bvar _ + | Tm_name _ + | Tm_uvar _ -> + return tm + + | Tm_uinst (f, us) -> + let! f = f_term f in + let! us = mapM f_univ us in + return <| mk (Tm_uinst (f, us)) + + | Tm_type u -> + let! u = u |> f_univ in + return <| mk (Tm_type u) + + | Tm_app {hd; args} -> + let! hd = f_term hd in + let! args = mapM (f_arg #m #d) args in + return <| mk (Tm_app {hd; args}) + + | Tm_abs {bs; body=t; rc_opt} -> + let! bs = mapM f_binder bs in + let! t = f_term t in + let! rc_opt = map_optM f_residual_comp rc_opt in + return <| mk (Tm_abs {bs; body=t; rc_opt}) + + | Tm_arrow {bs; comp=c} -> + let! bs = mapM f_binder bs in + let! c = f_comp c in + return <| mk (Tm_arrow {bs; comp=c}) + + | Tm_refine {b=bv; phi} -> + let! bv = f_binding_bv bv in + let! phi = f_term phi in + return <| mk (Tm_refine {b=bv; phi}) + + | Tm_match {scrutinee=sc; ret_opt=asc_opt; brs; rc_opt} -> + let! sc = f_term sc in + let! asc_opt = asc_opt |> map_optM (fun (b, asc) -> Mktuple2 <$> f_binder b <*> on_sub_ascription asc <: m _) in + let! brs = mapM f_br brs in + let! rc_opt = rc_opt |> map_optM f_residual_comp in + return <| mk (Tm_match {scrutinee=sc; ret_opt=asc_opt; brs; rc_opt}) + + | Tm_ascribed {tm=e; asc=a; eff_opt=lopt} -> + let! e = f_term e in + let! a = a |> on_sub_ascription in + return <| mk (Tm_ascribed {tm=e; asc=a; eff_opt=lopt}) + + | Tm_let {lbs=(is_rec, lbs); body=t} -> + let! lbs = lbs |> mapM on_sub_letbinding in + let! t = t |> f_term in + return <| mk (Tm_let {lbs=(is_rec, lbs); body=t}) + + | Tm_quoted (qtm, qi) -> + if d.proc_quotes || qi.qkind = Quote_dynamic then + let! qtm = qtm |> f_term in + // let! qi = Syntax.on_antiquoted (f_term vfs) qi in + // FIXME ^ no monadic variant + return <| mk (Tm_quoted (qtm, qi)) + else + return tm + + | Tm_meta {tm=t; meta=md} -> + let! t = t |> f_term in + let! md = md |> on_sub_meta in + return <| mk (Tm_meta {tm=t; meta=md}) + +let on_sub_binding_bv #m {|d : lvm m |} (x : bv) : m bv = + let! sort = x.sort |> f_term in + return { x with sort = sort } + +let on_sub_binder #m {|d : lvm m |} (b : binder) : m binder = + let! binder_bv = b.binder_bv |> f_binding_bv in + let! binder_qual = b.binder_qual |> map_optM (function Meta t -> Meta <$> f_term t + | q -> return q) in + let binder_positivity = b.binder_positivity in + let! binder_attrs = b.binder_attrs |> mapM f_term in + return <| { + binder_bv; + binder_qual; + binder_positivity; + binder_attrs; + } + +let rec on_sub_pat #m {|d : lvm m |} (p0 : pat) : m pat = + let mk p = { v=p; p=p0.p } in + match p0.v with + | Pat_constant _ -> + return p0 + + | Pat_cons (fv, us, subpats) -> + let! us = us |> map_optM (mapM #m f_univ) in + let! subpats = subpats |> mapM (fun (p, b) -> Mktuple2 <$> on_sub_pat p <*> return b <: m _) in + return <| mk (Pat_cons (fv, us, subpats)) + + | Pat_var bv -> + let! bv = bv |> f_binding_bv in + return <| mk (Pat_var bv) + + | Pat_dot_term t -> + let! t = t |> map_optM f_term in + return <| mk (Pat_dot_term t) + +let on_sub_br #m {|d : lvm m |} br : m _ = + let (pat, wopt, body) = br in + let! pat = pat |> on_sub_pat in + let! wopt = wopt |> map_optM f_term in + let! body = body |> f_term in + return (pat, wopt, body) + +let on_sub_comp_typ #m {|d : lvm m |} ct : m _ = + let! comp_univs = ct.comp_univs |> mapM f_univ in + let effect_name = ct.effect_name in + let! result_typ = ct.result_typ |> f_term in + let! effect_args = ct.effect_args |> mapM (f_arg #m #d) in + let flags = ct.flags in + return <| { + comp_univs; + effect_name; + result_typ; + effect_args; + flags; + } + +let on_sub_comp #m {|d : lvm m |} c : m comp = + let! cn = + match c.n with + | Total typ -> Total <$> f_term typ + | GTotal typ -> GTotal <$> f_term typ + | Comp ct -> Comp <$> on_sub_comp_typ ct + in + return <| Syntax.mk cn c.pos + +let __on_decreases #m {|d : lvm m |} f : cflag -> m cflag = function + | DECREASES (Decreases_lex l) -> DECREASES <$> (Decreases_lex <$> mapM f l) + | DECREASES (Decreases_wf (r, t)) -> DECREASES <$> (Decreases_wf <$> (Mktuple2 <$> f r <*> f t)) + | f -> return f + +let on_sub_residual_comp #m {|d : lvm m |} (rc : residual_comp) : m residual_comp = + let residual_effect = rc.residual_effect in + let! residual_typ = rc.residual_typ |> map_optM f_term in + let! residual_flags = rc.residual_flags |> mapM (__on_decreases f_term) in + // ^ review: residual flags should not have terms + return <| { + residual_effect; + residual_typ; + residual_flags; + } + +let on_sub_univ #m {|d : lvm m |} (u : universe) : m universe = + let u = Subst.compress_univ u in + match u with + | U_max us -> + U_max <$> mapM f_univ us + | U_succ u -> + U_succ <$> f_univ u + + | U_zero + | U_bvar _ + | U_name _ + | U_unknown + | U_unif _ -> + return u + +let on_sub_wp_eff_combinators #m {|d : lvm m |} (wpcs : wp_eff_combinators) : m wp_eff_combinators = + let! ret_wp = wpcs.ret_wp |> f_tscheme in + let! bind_wp = wpcs.bind_wp |> f_tscheme in + let! stronger = wpcs.stronger |> f_tscheme in + let! if_then_else = wpcs.if_then_else |> f_tscheme in + let! ite_wp = wpcs.ite_wp |> f_tscheme in + let! close_wp = wpcs.close_wp |> f_tscheme in + let! trivial = wpcs.trivial |> f_tscheme in + + let! repr = wpcs.repr |> map_optM (f_tscheme #m #d) in // FIXME: implicits + let! return_repr = wpcs.return_repr |> map_optM (f_tscheme #m #d) in + let! bind_repr = wpcs.bind_repr |> map_optM (f_tscheme #m #d) in + return <| { + ret_wp; + bind_wp; + stronger; + if_then_else; + ite_wp; + close_wp; + trivial; + + repr; + return_repr; + bind_repr; + } + +let mapTuple2 #m {| monad m |} (f : 'a -> m 'b) (g : 'c -> m 'd) (t : 'a & 'c) : m ('b & 'd) = + Mktuple2 <$> f t._1 <*> g t._2 + +let mapTuple3 #m {| monad m |} (f : 'a -> m 'b) (g : 'c -> m 'd) (h : 'e -> m 'f) (t : 'a & 'c & 'e) : m ('b & 'd & 'f) = + Mktuple3 <$> f t._1 <*> g t._2 <*> h t._3 + +let on_sub_layered_eff_combinators #m {|d : lvm m |} (lecs : layered_eff_combinators) : m layered_eff_combinators = + let! l_repr = lecs.l_repr |> mapTuple2 (f_tscheme #m #d) (f_tscheme #m #d) in + let! l_return = lecs.l_return |> mapTuple2 (f_tscheme #m #d) (f_tscheme #m #d) in + let! l_bind = lecs.l_bind |> mapTuple3 (f_tscheme #m #d) (f_tscheme #m #d) return in + let! l_subcomp = lecs.l_subcomp |> mapTuple3 (f_tscheme #m #d) (f_tscheme #m #d) return in + let! l_if_then_else = lecs.l_if_then_else |> mapTuple3 (f_tscheme #m #d) (f_tscheme #m #d) return in + let! l_close = lecs.l_close |> map_optM (mapTuple2 (f_tscheme #m #d) (f_tscheme #m #d)) in + return <| { + l_repr; + l_return; + l_bind; + l_subcomp; + l_if_then_else; + l_close; + } + +let on_sub_combinators #m {|d : lvm m |} (cbs : eff_combinators) : m eff_combinators = + match cbs with + | Primitive_eff wpcs -> + let! wpcs = on_sub_wp_eff_combinators wpcs in + return <| Primitive_eff wpcs + + | DM4F_eff wpcs -> + let! wpcs = on_sub_wp_eff_combinators wpcs in + return <| DM4F_eff wpcs + + | Layered_eff lecs -> + let! lecs = on_sub_layered_eff_combinators lecs in + return <| Layered_eff lecs + +let on_sub_effect_signature #m {|d : lvm m |} (es : effect_signature) : m effect_signature = + match es with + | Layered_eff_sig (n, (us, t)) -> + let! t = f_term t in + return <| Layered_eff_sig (n, (us, t)) + + | WP_eff_sig (us, t) -> + let! t = f_term t in + return <| WP_eff_sig (us, t) + +let on_sub_action #m {|d : lvm m |} (a : action) : m action = + let action_name = a.action_name in + let action_unqualified_name = a.action_unqualified_name in + let action_univs = a.action_univs in + let! action_params = a.action_params |> mapM f_binder in + let! action_defn = a.action_defn |> f_term in + let! action_typ = a.action_typ |> f_term in + return <| { + action_name; + action_unqualified_name; + action_univs; + action_params; + action_defn; + action_typ; + } + +let rec on_sub_sigelt' #m {|d : lvm m |} (se : sigelt') : m sigelt' = + match se with + | Sig_inductive_typ {lid; us; params; num_uniform_params; t; mutuals; ds; injective_type_params } -> + let! params = params |> mapM f_binder in + let! t = t |> f_term in + return <| Sig_inductive_typ {lid; us; params; num_uniform_params; t; mutuals; ds; injective_type_params } + + | Sig_bundle {ses; lids} -> + let! ses = ses |> mapM on_sub_sigelt in + return <| Sig_bundle {ses; lids} + + | Sig_datacon {lid; us; t; ty_lid; num_ty_params; mutuals; injective_type_params } -> + let! t = t |> f_term in + return <| Sig_datacon {lid; us; t; ty_lid; num_ty_params; mutuals; injective_type_params } + + | Sig_declare_typ {lid; us; t} -> + let! t = t |> f_term in + return <| Sig_declare_typ {lid; us; t} + + | Sig_let {lbs=(is_rec, lbs); lids} -> + let! lbs = lbs |> mapM on_sub_letbinding in + return <| Sig_let {lbs=(is_rec, lbs); lids} + + | Sig_assume {lid; us; phi} -> + let! phi = phi |> f_term in + return <| Sig_assume {lid; us; phi} + + | Sig_new_effect ed -> + let mname = ed.mname in + let cattributes = ed.cattributes in + let univs = ed.univs in + let! binders = ed.binders |> mapM f_binder in + let! signature = ed.signature |> on_sub_effect_signature in + let! combinators = ed.combinators |> on_sub_combinators in + let! actions = ed.actions |> mapM on_sub_action in + let! eff_attrs = ed.eff_attrs |> mapM f_term in + let extraction_mode = ed.extraction_mode in + let ed = { mname; cattributes; univs; binders; signature; combinators; actions; eff_attrs; extraction_mode; } in + return <| Sig_new_effect ed + + | Sig_sub_effect se -> + let source = se.source in + let target = se.target in + let! lift_wp = se.lift_wp |> map_optM (f_tscheme #m #d) in + let! lift = se.lift |> map_optM (f_tscheme #m #d) in + let kind = se.kind in + return <| Sig_sub_effect { source; target; lift_wp; lift; kind; } + + | Sig_effect_abbrev {lid; us; bs; comp; cflags} -> + let! binders = bs |> mapM f_binder in + let! comp = comp |> f_comp in + let! cflags = cflags |> mapM (__on_decreases f_term) in + // ^ review: residual flags should not have terms + return <| Sig_effect_abbrev {lid; us; bs; comp; cflags} + + (* No content *) + | Sig_pragma _ -> return se + + | Sig_polymonadic_bind {m_lid; n_lid; p_lid; tm; typ; kind} -> + let! tm = f_tscheme tm in + let! typ = f_tscheme typ in + return <| Sig_polymonadic_bind {m_lid; n_lid; p_lid; tm; typ; kind} + + | Sig_polymonadic_subcomp {m_lid; + n_lid; + tm; + typ; + kind} -> + let! tm = f_tscheme tm in + let! typ = f_tscheme typ in + return <| Sig_polymonadic_subcomp {m_lid; n_lid; tm; typ; kind} + + (* These two below are hardly used, since they disappear after + typechecking, but are still useful so the desugarer can make use of + deep_compress_se. *) + | Sig_fail {errs; fail_in_lax; ses} -> + let! ses = ses |> mapM on_sub_sigelt in + return <| Sig_fail {errs; fail_in_lax; ses} + + | Sig_splice {is_typed; lids; tac} -> + let! tac = tac |> f_term in + return <| Sig_splice {is_typed; lids; tac} + + | _ -> failwith "on_sub_sigelt: missing case" + +and on_sub_sigelt #m {|d : lvm m |} (se : sigelt) : m sigelt = + let! sigel = se.sigel |> on_sub_sigelt' in + let sigrng = se.sigrng in + let sigquals = se.sigquals in + let sigmeta = se.sigmeta in + let! sigattrs = se.sigattrs |> mapM f_term in + let sigopts = se.sigopts in + let sigopens_and_abbrevs = se.sigopens_and_abbrevs in + return <| { sigel; sigrng; sigquals; sigmeta; sigattrs; sigopts; sigopens_and_abbrevs; } + +let (>>=) (#m:_) {|monad m|} #a #b (c : m a) (f : a -> m b) = + let! x = c in f x + +let (<<|) (#m:_) {|monad m|} #a #b (f : a -> m b) (c : m a) : m b= + let! x = c in f x + +// Bottom up. The record is a reference so it can be easily cyclic. +let tie_bu (#m : Type -> Type) {| md : monad m |} (d : lvm m) : lvm m = + // needs explicit eta to not loop? + let r : ref (lvm m) = mk_ref (novfs #m #md) in // FIXME implicits + r := + { + lvm_monad = (!r).lvm_monad; + + f_term = (fun x -> f_term #_ #d <<| on_sub_term #_ #!r x); + f_binding_bv = (fun x -> f_binding_bv #_ #d <<| on_sub_binding_bv #_ #!r x); + f_binder = (fun x -> f_binder #_ #d <<| on_sub_binder #_ #!r x); + f_br = (fun x -> f_br #_ #d <<| on_sub_br #_ #!r x); + f_comp = (fun x -> f_comp #_ #d <<| on_sub_comp #_ #!r x); + f_residual_comp = (fun x -> f_residual_comp #_ #d <<| on_sub_residual_comp #_ #!r x); + f_univ = (fun x -> f_univ #_ #d <<| on_sub_univ #_ #!r x); + + proc_quotes = d.proc_quotes; + }; + !r + +let visitM_term_univs #m {| md : monad m |} (proc_quotes : bool) vt vu (tm : term) : m term = + let dict : lvm m = + tie_bu #m #md { novfs #m #md with f_term = vt; f_univ = vu; proc_quotes = proc_quotes } + in + f_term #_ #dict tm + +let visitM_term #m {| md : monad m |} (proc_quotes : bool) vt (tm : term) : m term = + visitM_term_univs true vt return tm + +let visitM_sigelt #m {| md : monad m |} (proc_quotes : bool) vt vu (tm : sigelt) : m sigelt = + let dict : lvm m = + tie_bu #m #md { novfs #m #md with f_term = vt; f_univ = vu; proc_quotes = proc_quotes } + in + on_sub_sigelt #_ #dict tm + + +(* Example: compute all lidents appearing in a sigelt: + +let open FStarC.Class.Show in +let open FStarC.Class.Monad in +let open FStarC.Compiler.Writer in + +type mymon = writer (list lident) + +let m = VisitM.visitM_sigelt + (fun t -> (match t.n with + | Tm_fvar fv -> Writer.emit [lid_of_fv fv] + | _ -> return ());! + return t) + (fun #a b c -> c) se +in +let lids, _ = Writer.run_writer m in +BU.print1 "Lids = %s\n" (show lids); + +*) \ No newline at end of file diff --git a/src/syntax/FStarC.Syntax.VisitM.fsti b/src/syntax/FStarC.Syntax.VisitM.fsti new file mode 100644 index 00000000000..03f12e82c9c --- /dev/null +++ b/src/syntax/FStarC.Syntax.VisitM.fsti @@ -0,0 +1,31 @@ +module FStarC.Syntax.VisitM + +open FStarC.Syntax.Syntax +open FStarC.Class.Monad + +// TODO: add a way to specify what happens when we traverse a binder, +// hopefully allowing the user to choose whether we open/close or not, +// and know the binding depth at each point. + +val visitM_term + (#m:_) {| monad m |} + (proc_quotes : bool) + (v : term -> m term) + (t : term) + : m term + +val visitM_term_univs + (#m:_) {| monad m |} + (proc_quotes : bool) + (vt : term -> m term) + (vu : universe -> m universe) + (t : term) + : m term + +val visitM_sigelt + (#m:_) {| monad m |} + (proc_quotes : bool) + (vt : term -> m term) + (vu : universe -> m universe) + (t : sigelt) + : m sigelt diff --git a/src/syntax/print/FStar.Syntax.Print.Pretty.fst b/src/syntax/print/FStar.Syntax.Print.Pretty.fst deleted file mode 100644 index ea28b99c0b8..00000000000 --- a/src/syntax/print/FStar.Syntax.Print.Pretty.fst +++ /dev/null @@ -1,143 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Syntax.Print.Pretty - -open FStar.Compiler -open FStar.Syntax.Syntax -open FStar.Compiler.Util -module Resugar = FStar.Syntax.Resugar -module ToDocument = FStar.Parser.ToDocument -module Pp = FStar.Pprint - -let rfrac = float_of_string "1.0" -let width = 100 -let pp d = Pp.pretty_string rfrac width d - -let term_to_doc' env (tm:term) : Pprint.document = GenSym.with_frozen_gensym (fun () -> - let e = Resugar.resugar_term' env tm in - ToDocument.term_to_document e -) - -let univ_to_doc' env (u:universe) : Pprint.document = GenSym.with_frozen_gensym (fun () -> - let e = Resugar.resugar_universe' env u Range.dummyRange in - ToDocument.term_to_document e -) - -let term_to_string' env (tm:term) : string = GenSym.with_frozen_gensym (fun () -> - let d = term_to_doc' env tm in - pp d -) - -let univ_to_string' env (u:universe) : string = GenSym.with_frozen_gensym (fun () -> - let d = univ_to_doc' env u in - pp d -) - -let comp_to_doc' env (c:comp) : Pprint.document = GenSym.with_frozen_gensym (fun () -> - let e = Resugar.resugar_comp' env c in - ToDocument.term_to_document e -) - -let comp_to_string' env (c:comp) : string = GenSym.with_frozen_gensym (fun () -> - let d = comp_to_doc' env c in - pp d -) - -let sigelt_to_doc' env (se:sigelt) : Pprint.document = GenSym.with_frozen_gensym (fun () -> - match Resugar.resugar_sigelt' env se with - | None -> Pprint.empty - | Some d -> ToDocument.decl_to_document d -) - -let sigelt_to_string' env (se:sigelt) : string = GenSym.with_frozen_gensym (fun () -> - let d = sigelt_to_doc' env se in - pp d -) - -(* These are duplicated instead of being a special case -of the above so we can reuse the empty_env created at module -load time for DsEnv. Otherwise we need to create another empty -DsEnv.env here. *) -let term_to_doc (tm:term) : Pprint.document = GenSym.with_frozen_gensym (fun () -> - let e = Resugar.resugar_term tm in - ToDocument.term_to_document e -) - -let univ_to_doc (u:universe) : Pprint.document = GenSym.with_frozen_gensym (fun () -> - let e = Resugar.resugar_universe u Range.dummyRange in - ToDocument.term_to_document e -) - -let comp_to_doc (c:comp) : Pprint.document = GenSym.with_frozen_gensym (fun () -> - let e = Resugar.resugar_comp c in - ToDocument.term_to_document e -) - -let sigelt_to_doc (se:sigelt) : Pprint.document = GenSym.with_frozen_gensym (fun () -> - match Resugar.resugar_sigelt se with - | None -> Pprint.empty - | Some d -> ToDocument.decl_to_document d -) - -let term_to_string (tm:term) : string = GenSym.with_frozen_gensym (fun () -> - let d = term_to_doc tm in - pp d -) - -let comp_to_string (c:comp) : string = GenSym.with_frozen_gensym (fun () -> - let e = Resugar.resugar_comp c in - let d = ToDocument.term_to_document e in - pp d -) - -let sigelt_to_string (se:sigelt) : string = GenSym.with_frozen_gensym (fun () -> - match Resugar.resugar_sigelt se with - | None -> "" - | Some d -> - let d = ToDocument.decl_to_document d in - pp d -) - -let univ_to_string (u:universe) : string = GenSym.with_frozen_gensym (fun () -> - let e = Resugar.resugar_universe u Range.dummyRange in - let d = ToDocument.term_to_document e in - pp d -) - -let tscheme_to_string (ts:tscheme) : string = GenSym.with_frozen_gensym (fun () -> - let d = Resugar.resugar_tscheme ts in - let d = ToDocument.decl_to_document d in - pp d -) - -let pat_to_string (p:pat) : string = GenSym.with_frozen_gensym (fun () -> - let e = Resugar.resugar_pat p (Class.Setlike.empty ()) in - let d = ToDocument.pat_to_document e in - pp d -) - -let binder_to_string' is_arrow (b:binder) : string = GenSym.with_frozen_gensym (fun () -> - let e = Resugar.resugar_binder b Range.dummyRange in - let d = ToDocument.binder_to_document e in - pp d -) - -let eff_decl_to_string ed = GenSym.with_frozen_gensym (fun () -> - let d = Resugar.resugar_eff_decl ed in - let d = ToDocument.decl_to_document d in - pp d -) diff --git a/src/syntax/print/FStar.Syntax.Print.Pretty.fsti b/src/syntax/print/FStar.Syntax.Print.Pretty.fsti deleted file mode 100644 index 81f820ab547..00000000000 --- a/src/syntax/print/FStar.Syntax.Print.Pretty.fsti +++ /dev/null @@ -1,49 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Syntax.Print.Pretty - -open FStar.Compiler -open FStar.Syntax -open FStar.Syntax.Syntax - -(* Use the 'primed' versions if possible: they abbreviate lidents *) - -val term_to_doc' : DsEnv.env -> term -> Pprint.document -val univ_to_doc' : DsEnv.env -> universe -> Pprint.document -val comp_to_doc' : DsEnv.env -> comp -> Pprint.document -val sigelt_to_doc' : DsEnv.env -> sigelt -> Pprint.document - -val term_to_string' : DsEnv.env -> term -> string -val univ_to_string' : DsEnv.env -> universe -> string -val comp_to_string' : DsEnv.env -> comp -> string -val sigelt_to_string' : DsEnv.env -> sigelt -> string - -(* If no DsEnv.env is at hand, these can be used instead. *) -val term_to_doc : term -> Pprint.document -val univ_to_doc : universe -> Pprint.document -val comp_to_doc : comp -> Pprint.document -val sigelt_to_doc : sigelt -> Pprint.document - -val term_to_string : term -> string -val univ_to_string : universe -> string -val comp_to_string : comp -> string -val sigelt_to_string : sigelt -> string - -val tscheme_to_string : tscheme -> string -val pat_to_string : pat -> string -val binder_to_string' : bool -> binder -> string -val eff_decl_to_string : eff_decl -> string diff --git a/src/syntax/print/FStar.Syntax.Print.Ugly.fst b/src/syntax/print/FStar.Syntax.Print.Ugly.fst deleted file mode 100644 index ee61e8e0f03..00000000000 --- a/src/syntax/print/FStar.Syntax.Print.Ugly.fst +++ /dev/null @@ -1,693 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Syntax.Print.Ugly -open FStar.Pervasives -open FStar.Compiler.Effect - -open FStar -open FStar.Compiler -open FStar.Syntax -open FStar.Compiler.Util -open FStar.Syntax.Syntax -open FStar.Syntax.Subst -open FStar.Ident -open FStar.Const -open FStar.Json - -open FStar.Class.Tagged -open FStar.Class.Show - -module Errors = FStar.Errors -module U = FStar.Compiler.Util -module A = FStar.Parser.AST -module Unionfind = FStar.Syntax.Unionfind -module C = FStar.Parser.Const -module SU = FStar.Syntax.Util - -let sli (l:lident) : string = - if Options.print_real_names() - then string_of_lid l - else string_of_id (ident_of_lid l) -// Util.format3 "%s@{def=%s;use=%s}" s -// (Range.string_of_range (Ident.range_of_lid l)) -// (Range.string_of_use_range (Ident.range_of_lid l)) - -let lid_to_string (l:lid) = sli l - -// let fv_to_string fv = Printf.sprintf "%s@%A" (lid_to_string fv.fv_name.v) fv.fv_delta -let fv_to_string fv = lid_to_string fv.fv_name.v //^ "(@@" ^ showfv.fv_delta ^ ")" -let bv_to_string bv = (string_of_id bv.ppname) ^ "#" ^ (string_of_int bv.index) - -let nm_to_string bv = - if Options.print_real_names() - then bv_to_string bv - else (string_of_id bv.ppname) - -let db_to_string bv = (string_of_id bv.ppname) ^ "@" ^ string_of_int bv.index - -let filter_imp aq = - (* keep typeclass args *) - match aq with - | Some (Meta t) when SU.is_fvar C.tcresolve_lid t -> true - | Some (Implicit _) - | Some (Meta _) -> false - | _ -> true -let filter_imp_args args = - args |> List.filter (function (_, None) -> true | (_, Some a) -> not a.aqual_implicit) -let filter_imp_binders bs = - bs |> List.filter (fun b -> b.binder_qual |> filter_imp) - -let const_to_string = C.const_to_string - -let lbname_to_string = function - | Inl l -> bv_to_string l - | Inr l -> lid_to_string l.fv_name.v - -let uvar_to_string u = if (Options.hide_uvar_nums()) then "?" else "?" ^ (Unionfind.uvar_id u |> string_of_int) -let version_to_string v = U.format2 "%s.%s" (U.string_of_int v.major) (U.string_of_int v.minor) -let univ_uvar_to_string u = - if (Options.hide_uvar_nums()) - then "?" - else "?" ^ (Unionfind.univ_uvar_id u |> string_of_int) - ^ ":" ^ (u |> (fun (_, u, _) -> version_to_string u)) - -let rec int_of_univ n u = match Subst.compress_univ u with - | U_zero -> n, None - | U_succ u -> int_of_univ (n+1) u - | _ -> n, Some u - -let rec univ_to_string u = -Errors.with_ctx "While printing universe" (fun () -> - match Subst.compress_univ u with - | U_unif u -> "U_unif "^univ_uvar_to_string u - | U_name x -> "U_name "^(string_of_id x) - | U_bvar x -> "@"^string_of_int x - | U_zero -> "0" - | U_succ u -> - begin match int_of_univ 1 u with - | n, None -> string_of_int n - | n, Some u -> U.format2 "(%s + %s)" (univ_to_string u) (string_of_int n) - end - | U_max us -> U.format1 "(max %s)" (List.map univ_to_string us |> String.concat ", ") - | U_unknown -> "unknown" -) - -let univs_to_string us = List.map univ_to_string us |> String.concat ", " - -let univ_names_to_string us = List.map (fun x -> (string_of_id x)) us |> String.concat ", " - -let qual_to_string = function - | Assumption -> "assume" - | InternalAssumption -> "internal_assume" - | New -> "new" - | Private -> "private" - | Unfold_for_unification_and_vcgen -> "unfold" - | Inline_for_extraction -> "inline_for_extraction" - | NoExtract -> "noextract" - | Visible_default -> "visible" - | Irreducible -> "irreducible" - | Noeq -> "noeq" - | Unopteq -> "unopteq" - | Logic -> "logic" - | TotalEffect -> "total" - | Discriminator l -> U.format1 "(Discriminator %s)" (lid_to_string l) - | Projector (l, x) -> U.format2 "(Projector %s %s)" (lid_to_string l) (string_of_id x) - | RecordType (ns, fns) -> U.format2 "(RecordType %s %s)" (text_of_path (path_of_ns ns)) (fns |> List.map string_of_id |> String.concat ", ") - | RecordConstructor (ns, fns) -> U.format2 "(RecordConstructor %s %s)" (text_of_path (path_of_ns ns)) (fns |> List.map string_of_id |> String.concat ", ") - | Action eff_lid -> U.format1 "(Action %s)" (lid_to_string eff_lid) - | ExceptionConstructor -> "ExceptionConstructor" - | HasMaskedEffect -> "HasMaskedEffect" - | Effect -> "Effect" - | Reifiable -> "reify" - | Reflectable l -> U.format1 "(reflect %s)" (string_of_lid l) - | OnlyName -> "OnlyName" - -let quals_to_string quals = - match quals with - | [] -> "" - | _ -> quals |> List.map qual_to_string |> String.concat " " - -let quals_to_string' quals = - match quals with - | [] -> "" - | _ -> quals_to_string quals ^ " " - -let paren s = "(" ^ s ^ ")" - -let rec term_to_string x = - Errors.with_ctx "While ugly-printing a term" (fun () -> - let x = Subst.compress x in - let x = if Options.print_implicits() then x else SU.unmeta x in - match x.n with - | Tm_delayed _ -> failwith "impossible" - | Tm_app {args=[]} -> failwith "Empty args!" - - // TODO: add an option to mark where this happens - | Tm_lazy ({blob=b; lkind=Lazy_embedding (_, thunk)}) -> - "[LAZYEMB:" ^ - term_to_string (Thunk.force thunk) ^ "]" - | Tm_lazy i -> - "[lazy:" ^ - term_to_string (must !lazy_chooser i.lkind i) // can't call into Syntax.Util here.. - ^"]" - - | Tm_quoted (tm, qi) -> - begin match qi.qkind with - | Quote_static -> - U.format2 "`(%s)%s" (term_to_string tm) - (FStar.Common.string_of_list term_to_string (snd qi.antiquotations)) - | Quote_dynamic -> - U.format1 "quote (%s)" (term_to_string tm) - end - - | Tm_meta {tm=t; meta=Meta_pattern (_, ps)} -> - let pats = ps |> List.map (fun args -> args |> List.map (fun (t, _) -> term_to_string t) |> String.concat "; ") |> String.concat "\/" in - U.format2 "{:pattern %s} %s" pats (term_to_string t) - - | Tm_meta {tm=t; meta=Meta_monadic (m, t')} -> U.format4 ("(MetaMonadic-{%s %s} (%s) %s)") (sli m) (term_to_string t') (tag_of t) (term_to_string t) - - | Tm_meta {tm=t; meta=Meta_monadic_lift(m0, m1, t')} -> U.format4 ("(MetaMonadicLift-{%s : %s -> %s} %s)") (term_to_string t') (sli m0) (sli m1) (term_to_string t) - - | Tm_meta {tm=t; meta=Meta_labeled(l,r,b)} -> - U.format3 "Meta_labeled(%s, %s){%s}" (Errors.Msg.rendermsg l) (Range.string_of_range r) (term_to_string t) - - | Tm_meta {tm=t; meta=Meta_named(l)} -> - U.format3 "Meta_named(%s, %s){%s}" (lid_to_string l) (Range.string_of_range t.pos) (term_to_string t) - - | Tm_meta {tm=t; meta=Meta_desugared _} -> - U.format1 "Meta_desugared{%s}" (term_to_string t) - - | Tm_bvar x -> db_to_string x ^ ":(" ^ (tag_of x.sort) ^ ")" - | Tm_name x -> nm_to_string x // ^ "@@(" ^ term_to_string x.sort ^ ")" - | Tm_fvar f -> - // Add a prefix to unresolved constructors/projectors, otherwise - // we print a unqualified fvar, which looks exactly like a Tm_name - let pref = - match f.fv_qual with - | Some (Unresolved_projector _) -> "(Unresolved_projector)" - | Some (Unresolved_constructor _) -> "(Unresolved_constructor)" - | _ -> "" - in - pref ^ fv_to_string f - | Tm_uvar (u, ([], _)) -> - if Options.print_bound_var_types() - && Options.print_effect_args() - then ctx_uvar_to_string_aux true u - else "?" ^ (string_of_int <| Unionfind.uvar_id u.ctx_uvar_head) - | Tm_uvar (u, s) -> - if Options.print_bound_var_types() - && Options.print_effect_args() - then U.format2 "(%s @ %s)" (ctx_uvar_to_string_aux true u) (List.map subst_to_string (fst s) |> String.concat "; ") - else "?" ^ (string_of_int <| Unionfind.uvar_id u.ctx_uvar_head) - | Tm_constant c -> const_to_string c - | Tm_type u -> if (Options.print_universes()) then U.format1 "Type u#(%s)" (univ_to_string u) else "Type" - | Tm_arrow {bs; comp=c} -> U.format2 "(%s -> %s)" (binders_to_string " -> " bs) (comp_to_string c) - | Tm_abs {bs; body=t2; rc_opt=lc} -> - begin match lc with - | Some rc when (Options.print_implicits()) -> - U.format4 "(fun %s -> (%s $$ (residual) %s %s))" - (binders_to_string " " bs) - (term_to_string t2) - (string_of_lid rc.residual_effect) - (if Option.isNone rc.residual_typ then "None" else term_to_string (Option.get rc.residual_typ)) - | _ -> - U.format2 "(fun %s -> %s)" (binders_to_string " " bs) (term_to_string t2) - end - | Tm_refine {b=xt; phi=f} -> U.format3 "(%s:%s{%s})" (bv_to_string xt) (xt.sort |> term_to_string) (f |> formula_to_string) - | Tm_app {hd=t; args} -> U.format2 "(%s %s)" (term_to_string t) (args_to_string args) - | Tm_let {lbs; body=e} -> U.format2 "%s\nin\n%s" (lbs_to_string [] lbs) (term_to_string e) - | Tm_ascribed {tm=e;asc=(annot, topt, b);eff_opt=eff_name} -> - let annot = match annot with - | Inl t -> U.format2 "[%s] %s" (map_opt eff_name Ident.string_of_lid |> dflt "default") (term_to_string t) - | Inr c -> comp_to_string c in - let topt = match topt with - | None -> "" - | Some t -> U.format1 "by %s" (term_to_string t) in - let s = if b then "ascribed_eq" else "ascribed" in - U.format4 "(%s <%s: %s %s)" (term_to_string e) s annot topt - | Tm_match {scrutinee=head; ret_opt=asc_opt; brs=branches; rc_opt=lc} -> - let lc_str = - match lc with - | Some lc when (Options.print_implicits ()) -> - U.format1 " (residual_comp:%s)" - (if Option.isNone lc.residual_typ then "None" else term_to_string (Option.get lc.residual_typ)) - | _ -> "" in - U.format4 "(match %s %swith\n\t| %s%s)" - (term_to_string head) - (match asc_opt with - | None -> "" - | Some (b, (asc, tacopt, use_eq)) -> - let s = if use_eq then "returns$" else "returns" in - U.format4 "as %s %s %s%s " - (binder_to_string b) - s - (match asc with - | Inl t -> term_to_string t - | Inr c -> comp_to_string c) - (match tacopt with - | None -> "" - | Some tac -> U.format1 " by %s" (term_to_string tac))) - (U.concat_l "\n\t|" (branches |> List.map branch_to_string)) - lc_str - | Tm_uinst(t, us) -> - if (Options.print_universes()) - then U.format2 "%s<%s>" (term_to_string t) (univs_to_string us) - else term_to_string t - - | Tm_unknown -> "_" - ) - -and branch_to_string (p, wopt, e) : string = - U.format3 "%s %s -> %s" - (p |> pat_to_string) - (match wopt with | None -> "" | Some w -> U.format1 "when %s" (w |> term_to_string)) - (e |> term_to_string) -and ctx_uvar_to_string_aux print_reason ctx_uvar = - let reason_string = - if print_reason - then U.format1 "(* %s *)\n" ctx_uvar.ctx_uvar_reason - else U.format2 "(%s-%s) " - (Range.string_of_pos (Range.start_of_range ctx_uvar.ctx_uvar_range)) - (Range.string_of_pos (Range.end_of_range ctx_uvar.ctx_uvar_range)) in - format5 "%s(%s |- %s : %s) %s" - reason_string - (binders_to_string ", " ctx_uvar.ctx_uvar_binders) - (uvar_to_string ctx_uvar.ctx_uvar_head) - (term_to_string (SU.ctx_uvar_typ ctx_uvar)) - (match SU.ctx_uvar_should_check ctx_uvar with - | Allow_unresolved s -> "Allow_unresolved " ^s - | Allow_untyped s -> "Allow_untyped " ^s - | Allow_ghost s -> "Allow_ghost " ^s - | Strict -> "Strict" - | Already_checked -> "Already_checked") - - -and subst_elt_to_string = function - | DB(i, x) -> U.format2 "DB (%s, %s)" (string_of_int i) (bv_to_string x) - | DT(i, t) -> U.format2 "DT (%s, %s)" (string_of_int i) (term_to_string t) - | NM(x, i) -> U.format2 "NM (%s, %s)" (bv_to_string x) (string_of_int i) - | NT(x, t) -> U.format2 "NT (%s, %s)" (bv_to_string x) (term_to_string t) - | UN(i, u) -> U.format2 "UN (%s, %s)" (string_of_int i) (univ_to_string u) - | UD(u, i) -> U.format2 "UD (%s, %s)" (string_of_id u) (string_of_int i) - -and subst_to_string s = s |> List.map subst_elt_to_string |> String.concat "; " - -and pat_to_string x = - match x.v with - | Pat_cons(l, us_opt, pats) -> - U.format3 "(%s%s%s)" - (fv_to_string l) - (if not (Options.print_universes()) - then " " - else - match us_opt with - | None -> " " - | Some us -> - U.format1 " %s " (List.map univ_to_string us |> String.concat " ")) - (List.map (fun (x, b) -> let p = pat_to_string x in if b then "#"^p else p) pats |> String.concat " ") - | Pat_dot_term topt -> - if Options.print_bound_var_types() - then U.format1 ".%s" (if topt = None then "_" else topt |> U.must |> term_to_string) - else "._" - | Pat_var x -> - if Options.print_bound_var_types() - then U.format2 "%s:%s" (bv_to_string x) (term_to_string x.sort) - else bv_to_string x - | Pat_constant c -> const_to_string c - - -and lbs_to_string quals lbs = -// let lbs = -// if (Options.print_universes()) -// then (fst lbs, snd lbs |> List.map (fun lb -> let us, td = Subst.open_univ_vars lb.lbunivs (Util.mk_conj lb.lbtyp lb.lbdef) in -// let t, d = match (Subst.compress td).n with -// | Tm_app(_, [(t, _); (d, _)]) -> t, d -// | _ -> failwith "Impossibe" in -// {lb with lbunivs=us; lbtyp=t; lbdef=d})) -// else lbs in - U.format3 "%slet %s %s" - (quals_to_string' quals) - (if fst lbs then "rec" else "") - (U.concat_l "\n and " (snd lbs |> List.map (fun lb -> - U.format5 "%s%s %s : %s = %s" - (attrs_to_string lb.lbattrs) - (lbname_to_string lb.lbname) - (if (Options.print_universes()) - then "<"^univ_names_to_string lb.lbunivs^">" - else "") - (term_to_string lb.lbtyp) - (lb.lbdef |> term_to_string)))) -and attrs_to_string = function - | [] -> "" - | tms -> U.format1 "[@ %s]" (List.map (fun t -> paren (term_to_string t)) tms |> String.concat "; ") - -and binder_attrs_to_string = function - | _ when Options.any_dump_module () -> "" - (* ^ VALE HACK: Vale does not properly parse attributes on binders (yet). - Just don't print them. *) - - | [] -> "" - | tms -> U.format1 "[@@@ %s]" (List.map (fun t -> paren (term_to_string t)) tms |> String.concat "; ") - -and bqual_to_string' s = function - | Some (Implicit false) -> "#" ^ s - | Some (Implicit true) -> "#." ^ s - | Some Equality -> "$" ^ s - | Some (Meta t) when SU.is_fvar C.tcresolve_lid t -> "{|" ^ s ^ "|}" - | Some (Meta t) -> "#[" ^ term_to_string t ^ "]" ^ s - | None -> s - -and aqual_to_string' s = function - | Some { aqual_implicit=true } -> "#" ^ s - | _ -> s - -and binder_to_string' is_arrow b = - let attrs = binder_attrs_to_string b.binder_attrs in - if is_null_binder b - then (attrs ^ "_:" ^ term_to_string b.binder_bv.sort) - else if not is_arrow && not (Options.print_bound_var_types()) - then bqual_to_string' (attrs ^ nm_to_string b.binder_bv) b.binder_qual - else bqual_to_string' (attrs ^ nm_to_string b.binder_bv ^ ":" ^ term_to_string b.binder_bv.sort) b.binder_qual - -and binder_to_string b = binder_to_string' false b - -and arrow_binder_to_string b = binder_to_string' true b - -and binders_to_string sep bs = - let bs = - if (Options.print_implicits()) - then bs - else filter_imp_binders bs in - if sep = " -> " - then bs |> List.map arrow_binder_to_string |> String.concat sep - else bs |> List.map binder_to_string |> String.concat sep - -and arg_to_string = function - | a, imp -> aqual_to_string' (term_to_string a) imp - -and args_to_string args = - let args = - if (Options.print_implicits()) - then args - else filter_imp_args args in - args |> List.map arg_to_string |> String.concat " " - -and comp_to_string c = - Errors.with_ctx "While ugly-printing a computation" (fun () -> - match c.n with - | Total t -> - begin match (compress t).n with - | Tm_type _ when not (Options.print_implicits() || Options.print_universes()) -> term_to_string t - | _ -> U.format1 "Tot %s" (term_to_string t) - end - | GTotal t -> - begin match (compress t).n with - | Tm_type _ when not (Options.print_implicits() || Options.print_universes()) -> term_to_string t - | _ -> U.format1 "GTot %s" (term_to_string t) - end - | Comp c -> - let basic = - if (Options.print_effect_args()) - then U.format5 "%s<%s> (%s) %s (attributes %s)" - (sli c.effect_name) - (c.comp_univs |> List.map univ_to_string |> String.concat ", ") - (term_to_string c.result_typ) - (c.effect_args |> List.map arg_to_string |> String.concat ", ") - (cflags_to_string c.flags) - else if c.flags |> U.for_some (function TOTAL -> true | _ -> false) - && not (Options.print_effect_args()) - then U.format1 "Tot %s" (term_to_string c.result_typ) - else if not (Options.print_effect_args()) - && not (Options.print_implicits()) - && lid_equals c.effect_name (C.effect_ML_lid()) - then term_to_string c.result_typ - else if not (Options.print_effect_args()) - && c.flags |> U.for_some (function MLEFFECT -> true | _ -> false) - then U.format1 "ALL %s" (term_to_string c.result_typ) - else U.format2 "%s (%s)" (sli c.effect_name) (term_to_string c.result_typ) in - let dec = c.flags - |> List.collect (function DECREASES dec_order -> - (match dec_order with - | Decreases_lex l -> - [U.format1 " (decreases [%s])" - (match l with - | [] -> "" - | hd::tl -> - tl |> List.fold_left (fun s t -> - s ^ ";" ^ term_to_string t) (term_to_string hd))] - | Decreases_wf (rel, e) -> - [U.format2 "(decreases {:well-founded %s %s})" (term_to_string rel) (term_to_string e)]) - | _ -> []) - - |> String.concat " " in - U.format2 "%s%s" basic dec - ) - -(* NB: this is reduced version of the one in Print *) -and cflag_to_string c = - match c with - | TOTAL -> "total" - | MLEFFECT -> "ml" - | RETURN -> "return" - | PARTIAL_RETURN -> "partial_return" - | SOMETRIVIAL -> "sometrivial" - | TRIVIAL_POSTCONDITION -> "trivial_postcondition" - | SHOULD_NOT_INLINE -> "should_not_inline" - | LEMMA -> "lemma" - | CPS -> "cps" - | DECREASES _ -> "" (* TODO : already printed for now *) - -and cflags_to_string fs = FStar.Common.string_of_list cflag_to_string fs - -(* CH: at this point not even trying to detect if something looks like a formula, - only locally detecting certain patterns *) -and formula_to_string phi = term_to_string phi - -let aqual_to_string aq = aqual_to_string' "" aq -let bqual_to_string bq = bqual_to_string' "" bq -let lb_to_string lb = lbs_to_string [] (false, [lb]) - -let comp_to_string' env c = comp_to_string c - -let term_to_string' env x = term_to_string x - - -//let subst_to_string subst = -// U.format1 "{%s}" <| -// (List.map (function -// | Inl (a, t) -> U.format2 "(%s -> %s)" (strBvd a) (typ_to_string t) -// | Inr (x, e) -> U.format2 "(%s -> %s)" (strBvd x) (exp_to_string e)) subst |> String.concat ", ") -//let freevars_to_string (fvs:freevars) = -// let f (l:set (bvar 'a 'b)) = l |> U.set_elements |> List.map (fun t -> strBvd t.v) |> String.concat ", " in -// U.format2 "ftvs={%s}, fxvs={%s}" (f fvs.ftvs) (f fvs.fxvs) - - -let enclose_universes s = - if Options.print_universes () - then "<" ^ s ^ ">" - else "" - -let tscheme_to_string s = - let (us, t) = s in - U.format2 "%s%s" (enclose_universes <| univ_names_to_string us) (term_to_string t) - -let action_to_string a = - U.format5 "%s%s %s : %s = %s" - (sli a.action_name) - (binders_to_string " " a.action_params) - (enclose_universes <| univ_names_to_string a.action_univs) - (term_to_string a.action_typ) - (term_to_string a.action_defn) - -let wp_eff_combinators_to_string combs = - let tscheme_opt_to_string = function - | Some ts -> tscheme_to_string ts - | None -> "None" in - - U.format "{\n\ - ret_wp = %s\n\ - ; bind_wp = %s\n\ - ; stronger = %s\n\ - ; if_then_else = %s\n\ - ; ite_wp = %s\n\ - ; close_wp = %s\n\ - ; trivial = %s\n\ - ; repr = %s\n\ - ; return_repr = %s\n\ - ; bind_repr = %s\n\ - }\n" - [ tscheme_to_string combs.ret_wp; - tscheme_to_string combs.bind_wp; - tscheme_to_string combs.stronger; - tscheme_to_string combs.if_then_else; - tscheme_to_string combs.ite_wp; - tscheme_to_string combs.close_wp; - tscheme_to_string combs.trivial; - tscheme_opt_to_string combs.repr; - tscheme_opt_to_string combs.return_repr; - tscheme_opt_to_string combs.bind_repr ] - -let sub_eff_to_string se = - let tsopt_to_string ts_opt = - if is_some ts_opt then ts_opt |> must |> tscheme_to_string - else "" in - U.format4 "sub_effect %s ~> %s : lift = %s ;; lift_wp = %s" - (lid_to_string se.source) (lid_to_string se.target) - (tsopt_to_string se.lift) (tsopt_to_string se.lift_wp) - -let layered_eff_combinators_to_string combs = - let to_str (ts_t, ts_ty, kopt) = - U.format3 "(%s) : (%s)<%s>" - (tscheme_to_string ts_t) (tscheme_to_string ts_ty) - (show kopt) in - - let to_str2 (ts_t, ts_ty) = - U.format2 "(%s) : (%s)" - (tscheme_to_string ts_t) (tscheme_to_string ts_ty) in - - U.format "{\n\ - ; l_repr = %s\n\ - ; l_return = %s\n\ - ; l_bind = %s\n\ - ; l_subcomp = %s\n\ - ; l_if_then_else = %s\n - %s - }\n" - [ to_str2 combs.l_repr; - to_str2 combs.l_return; - to_str combs.l_bind; - to_str combs.l_subcomp; - to_str combs.l_if_then_else; - - (if None? combs.l_close then "" - else U.format1 "; l_close = %s\n" (combs.l_close |> must |> to_str2)); - ] - -let eff_combinators_to_string = function - | Primitive_eff combs - | DM4F_eff combs -> wp_eff_combinators_to_string combs - | Layered_eff combs -> layered_eff_combinators_to_string combs - -let eff_extraction_mode_to_string = function - | Extract_none s -> U.format1 "none (%s)" s - | Extract_reify -> "reify" - | Extract_primitive -> "primitive" - -let eff_decl_to_string ed = - let actions_to_string actions = - actions |> - List.map action_to_string |> - String.concat ",\n\t" in - let eff_name = if SU.is_layered ed then "layered_effect" else "new_effect" in - U.format "%s%s { \ - %s%s %s : %s \n \ - %s\n\ - and effect_actions\n\t%s\n}\n" - [eff_name; - "" ; //(if for_free then "_for_free " else ""); - lid_to_string ed.mname; - enclose_universes <| univ_names_to_string ed.univs; - binders_to_string " " ed.binders; - ed.signature |> SU.effect_sig_ts |> tscheme_to_string; - eff_combinators_to_string ed.combinators; - actions_to_string ed.actions] - - -let rec sigelt_to_string (x: sigelt) = - let basic = - match x.sigel with - | Sig_pragma p -> show p - | Sig_inductive_typ {lid; us=univs; params=tps; t=k} -> - let quals_str = quals_to_string' x.sigquals in - let binders_str = binders_to_string " " tps in - let term_str = term_to_string k in - if Options.print_universes () then U.format5 "%stype %s<%s> %s : %s" quals_str (string_of_lid lid) (univ_names_to_string univs) binders_str term_str - else U.format4 "%stype %s %s : %s" quals_str (string_of_lid lid) binders_str term_str - | Sig_datacon {lid; us=univs; t} -> - if (Options.print_universes()) - then //let univs, t = Subst.open_univ_vars univs t in (* AR: don't open the universes, else it's a bit confusing *) - U.format3 "datacon<%s> %s : %s" (univ_names_to_string univs) (string_of_lid lid) (term_to_string t) - else U.format2 "datacon %s : %s" (string_of_lid lid) (term_to_string t) - | Sig_declare_typ {lid; us=univs; t} -> - //let univs, t = Subst.open_univ_vars univs t in - U.format4 "%sval %s %s : %s" (quals_to_string' x.sigquals) (string_of_lid lid) - (if (Options.print_universes()) - then U.format1 "<%s>" (univ_names_to_string univs) - else "") - (term_to_string t) - | Sig_assume {lid; us; phi=f} -> - if Options.print_universes () then U.format3 "assume %s<%s> : %s" (string_of_lid lid) (univ_names_to_string us) (term_to_string f) - else U.format2 "assume %s : %s" (string_of_lid lid) (term_to_string f) - | Sig_let {lbs} -> - (* FIXME: do not print the propagated qualifiers on top-level letbindings, - vale fails when parsing them. *) - let lbs = (fst lbs, List.map (fun lb -> { lb with lbattrs = [] }) (snd lbs)) in - lbs_to_string x.sigquals lbs - | Sig_bundle {ses} -> "(* Sig_bundle *)" ^ (List.map sigelt_to_string ses |> String.concat "\n") - | Sig_fail {errs; fail_in_lax=lax; ses} -> - U.format3 "(* Sig_fail %s %s *)\n%s\n(* / Sig_fail*)\n" - (string_of_bool lax) - (FStar.Common.string_of_list string_of_int errs) - (List.map sigelt_to_string ses |> String.concat "\n") - - | Sig_new_effect(ed) -> - (if SU.is_dm4f ed then "(* DM4F *)" else "") - ^ quals_to_string' x.sigquals - ^ eff_decl_to_string ed - - | Sig_sub_effect (se) -> sub_eff_to_string se - | Sig_effect_abbrev {lid=l; us=univs; bs=tps; comp=c; cflags=flags} -> - if (Options.print_universes()) - then let univs, t = Subst.open_univ_vars univs (mk (Tm_arrow {bs=tps; comp=c}) Range.dummyRange) in - let tps, c = match (Subst.compress t).n with - | Tm_arrow {bs; comp=c} -> bs, c - | _ -> failwith "impossible" in - U.format4 "effect %s<%s> %s = %s" (sli l) (univ_names_to_string univs) (binders_to_string " " tps) (comp_to_string c) - else U.format3 "effect %s %s = %s" (sli l) (binders_to_string " " tps) (comp_to_string c) - | Sig_splice {is_typed; lids; tac=t} -> - U.format3 "splice%s[%s] (%s)" - (if is_typed then "_t" else "") - (String.concat "; " <| List.map show lids) - (term_to_string t) - | Sig_polymonadic_bind {m_lid=m; - n_lid=n; - p_lid=p; - tm=t; - typ=ty; - kind=k} -> - U.format6 "polymonadic_bind (%s, %s) |> %s = (%s, %s)<%s>" - (show m) - (show n) - (show p) - (tscheme_to_string t) - (tscheme_to_string ty) - (show k) - | Sig_polymonadic_subcomp {m_lid=m; - n_lid=n; - tm=t; - typ=ty; - kind=k} -> - U.format5 "polymonadic_subcomp %s <: %s = (%s, %s)<%s>" - (show m) - (show n) - (tscheme_to_string t) - (tscheme_to_string ty) - (show k) - in - match x.sigattrs with - | [] -> "[@ ]" ^ "\n" ^ basic //It is important to keep this empty attribute marker since the Vale type extractor uses it as a delimiter - | _ -> attrs_to_string x.sigattrs ^ "\n" ^ basic diff --git a/src/syntax/print/FStar.Syntax.Print.Ugly.fsti b/src/syntax/print/FStar.Syntax.Print.Ugly.fsti deleted file mode 100644 index 8ad85f37fde..00000000000 --- a/src/syntax/print/FStar.Syntax.Print.Ugly.fsti +++ /dev/null @@ -1,34 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Syntax.Print.Ugly - -open FStar.Compiler.Effect -open FStar.Compiler -open FStar.Syntax.Syntax - -val term_to_string : term -> string -val univ_to_string : universe -> string -val comp_to_string : comp -> string -val sigelt_to_string : sigelt -> string -val binder_to_string : binder -> string - -val tscheme_to_string : tscheme -> string - -val lb_to_string : letbinding -> string -val branch_to_string : FStar.Syntax.Syntax.branch -> string -val pat_to_string : pat -> string - -val eff_decl_to_string : eff_decl -> string diff --git a/src/syntax/print/FStar.Syntax.Print.fst b/src/syntax/print/FStar.Syntax.Print.fst deleted file mode 100644 index e9c0ac7085e..00000000000 --- a/src/syntax/print/FStar.Syntax.Print.fst +++ /dev/null @@ -1,502 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Syntax.Print -open FStar.Pervasives -open FStar.Compiler.Effect - -open FStar -open FStar.Compiler -open FStar.Compiler.Range -open FStar.Syntax -open FStar.Compiler.Util -open FStar.Syntax.Syntax -open FStar.Syntax.Subst -open FStar.Ident -open FStar.Const -open FStar.Json - -module Errors = FStar.Errors -module U = FStar.Compiler.Util -module A = FStar.Parser.AST -module Unionfind = FStar.Syntax.Unionfind -module C = FStar.Parser.Const -module SU = FStar.Syntax.Util - -module Pretty = FStar.Syntax.Print.Pretty -module Ugly = FStar.Syntax.Print.Ugly - -let sli (l:lident) : string = - if Options.print_real_names() - then string_of_lid l - else string_of_id (ident_of_lid l) -// Util.format3 "%s@{def=%s;use=%s}" s -// (Range.string_of_range (Ident.range_of_lid l)) -// (Range.string_of_use_range (Ident.range_of_lid l)) - -let lid_to_string (l:lid) = sli l - -// let fv_to_string fv = Printf.sprintf "%s@%A" (lid_to_string fv.fv_name.v) fv.fv_delta -let fv_to_string fv = lid_to_string fv.fv_name.v //^ "(@@" ^ showfv.fv_delta ^ ")" -let bv_to_string bv = - if Options.print_real_names () - then show bv.ppname ^ "#" ^ show bv.index - else show bv.ppname - -let nm_to_string bv = - if Options.print_real_names() - then bv_to_string bv - else (string_of_id bv.ppname) - -let db_to_string bv = (string_of_id bv.ppname) ^ "@" ^ string_of_int bv.index - -let filter_imp aq = - (* keep typeclass args *) - match aq with - | Some (Meta t) when SU.is_fvar C.tcresolve_lid t -> true - | Some (Implicit _) - | Some (Meta _) -> false - | _ -> true -let filter_imp_args args = - args |> List.filter (function (_, None) -> true | (_, Some a) -> not a.aqual_implicit) -let filter_imp_binders bs = - bs |> List.filter (fun b -> b.binder_qual |> filter_imp) - -let const_to_string = C.const_to_string - -let lbname_to_string = function - | Inl l -> bv_to_string l - | Inr l -> lid_to_string l.fv_name.v - -let uvar_to_string u = if (Options.hide_uvar_nums()) then "?" else "?" ^ (Unionfind.uvar_id u |> string_of_int) -let version_to_string v = U.format2 "%s.%s" (U.string_of_int v.major) (U.string_of_int v.minor) -let univ_uvar_to_string u = - if (Options.hide_uvar_nums()) - then "?" - else "?" ^ (Unionfind.univ_uvar_id u |> string_of_int) - ^ ":" ^ (u |> (fun (_, u, _) -> version_to_string u)) - -let rec int_of_univ n u = match Subst.compress_univ u with - | U_zero -> n, None - | U_succ u -> int_of_univ (n+1) u - | _ -> n, Some u - -let rec univ_to_string u = -Errors.with_ctx "While printing universe" (fun () -> - // VD: commented out for testing NBE - // if not (Options.ugly()) then - // Pretty.univ_to_string u - // else - match Subst.compress_univ u with - | U_unif u -> "U_unif "^univ_uvar_to_string u - | U_name x -> "U_name "^(string_of_id x) - | U_bvar x -> "@"^string_of_int x - | U_zero -> "0" - | U_succ u -> - begin match int_of_univ 1 u with - | n, None -> string_of_int n - | n, Some u -> U.format2 "(%s + %s)" (univ_to_string u) (string_of_int n) - end - | U_max us -> U.format1 "(max %s)" (List.map univ_to_string us |> String.concat ", ") - | U_unknown -> "unknown" -) - -let univs_to_string us = List.map univ_to_string us |> String.concat ", " - -let qual_to_string = function - | Assumption -> "assume" - | InternalAssumption -> "internal_assume" - | New -> "new" - | Private -> "private" - | Unfold_for_unification_and_vcgen -> "unfold" - | Inline_for_extraction -> "inline_for_extraction" - | NoExtract -> "noextract" - | Visible_default -> "visible" - | Irreducible -> "irreducible" - | Noeq -> "noeq" - | Unopteq -> "unopteq" - | Logic -> "logic" - | TotalEffect -> "total" - | Discriminator l -> U.format1 "(Discriminator %s)" (lid_to_string l) - | Projector (l, x) -> U.format2 "(Projector %s %s)" (lid_to_string l) (string_of_id x) - | RecordType (ns, fns) -> U.format2 "(RecordType %s %s)" (text_of_path (path_of_ns ns)) (fns |> List.map string_of_id |> String.concat ", ") - | RecordConstructor (ns, fns) -> U.format2 "(RecordConstructor %s %s)" (text_of_path (path_of_ns ns)) (fns |> List.map string_of_id |> String.concat ", ") - | Action eff_lid -> U.format1 "(Action %s)" (lid_to_string eff_lid) - | ExceptionConstructor -> "ExceptionConstructor" - | HasMaskedEffect -> "HasMaskedEffect" - | Effect -> "Effect" - | Reifiable -> "reify" - | Reflectable l -> U.format1 "(reflect %s)" (string_of_lid l) - | OnlyName -> "OnlyName" - -let quals_to_string quals = - match quals with - | [] -> "" - | _ -> quals |> List.map qual_to_string |> String.concat " " - -let quals_to_string' quals = - match quals with - | [] -> "" - | _ -> quals_to_string quals ^ " " - -let paren s = "(" ^ s ^ ")" - -let lkind_to_string = function - | BadLazy -> "BadLazy" - | Lazy_bv -> "Lazy_bv" - | Lazy_namedv -> "Lazy_namedv" - | Lazy_binder -> "Lazy_binder" - | Lazy_optionstate -> "Lazy_optionstate" - | Lazy_fvar -> "Lazy_fvar" - | Lazy_comp -> "Lazy_comp" - | Lazy_env -> "Lazy_env" - | Lazy_proofstate -> "Lazy_proofstate" - | Lazy_goal -> "Lazy_goal" - | Lazy_sigelt -> "Lazy_sigelt" - | Lazy_uvar -> "Lazy_uvar" - | Lazy_letbinding -> "Lazy_letbinding" - | Lazy_embedding (e, _) -> "Lazy_embedding(" ^ show e ^ ")" - | Lazy_universe -> "Lazy_universe" - | Lazy_universe_uvar -> "Lazy_universe_uvar" - | Lazy_issue -> "Lazy_issue" - | Lazy_ident -> "Lazy_ident" - | Lazy_doc -> "Lazy_doc" - | Lazy_extension s -> "Lazy_extension:" ^ s - -let term_to_string x = - if Options.ugly () - then Ugly.term_to_string x - else Pretty.term_to_string x - -let term_to_string' env x = - if Options.ugly () - then Ugly.term_to_string x - else Pretty.term_to_string' env x - -let comp_to_string c = - if Options.ugly () - then Ugly.comp_to_string c - else Pretty.comp_to_string c - -let comp_to_string' env c = - if Options.ugly () - then Ugly.comp_to_string c - else Pretty.comp_to_string' env c - -let sigelt_to_string x = - if Options.ugly () - then Ugly.sigelt_to_string x - else Pretty.sigelt_to_string x - -let sigelt_to_string' env x = - if Options.ugly () - then Ugly.sigelt_to_string x - else Pretty.sigelt_to_string' env x - -let pat_to_string x = - if Options.ugly () - then Ugly.pat_to_string x - else Pretty.pat_to_string x - -let term_to_doc' dsenv t = - if Options.ugly () - then Pprint.arbitrary_string (Ugly.term_to_string t) - else Pretty.term_to_doc' dsenv t - -let univ_to_doc' dsenv t = - if Options.ugly () - then Pprint.arbitrary_string (Ugly.univ_to_string t) - else Pretty.univ_to_doc' dsenv t - -let comp_to_doc' dsenv t = - if Options.ugly () - then Pprint.arbitrary_string (Ugly.comp_to_string t) - else Pretty.comp_to_doc' dsenv t - -let sigelt_to_doc' dsenv t = - if Options.ugly () - then Pprint.arbitrary_string (Ugly.sigelt_to_string t) - else Pretty.sigelt_to_doc' dsenv t - -let term_to_doc t = - if Options.ugly () - then Pprint.arbitrary_string (Ugly.term_to_string t) - else Pretty.term_to_doc t - -let univ_to_doc t = - if Options.ugly () - then Pprint.arbitrary_string (Ugly.univ_to_string t) - else Pretty.univ_to_doc t - -let comp_to_doc t = - if Options.ugly () - then Pprint.arbitrary_string (Ugly.comp_to_string t) - else Pretty.comp_to_doc t - -let sigelt_to_doc t = - if Options.ugly () - then Pprint.arbitrary_string (Ugly.sigelt_to_string t) - else Pretty.sigelt_to_doc t - -let binder_to_string b = - if Options.ugly () - then Pretty.binder_to_string' false b - else Ugly.binder_to_string b - -let aqual_to_string (q:aqual) : string = - match q with - | Some { aqual_implicit=true } -> "#" - | _ -> "" - -let bqual_to_string' (s:string) (b:bqual) : string = - match b with - | Some (Implicit false) -> "#" ^ s - | Some (Implicit true) -> "#." ^ s - | Some Equality -> "$" ^ s - | Some (Meta t) when SU.is_fvar C.tcresolve_lid t -> "{|" ^ s ^ "|}" - | Some (Meta t) -> "#[" ^ term_to_string t ^ "]" ^ s - | None -> s - -let bqual_to_string (q:bqual) : string = - bqual_to_string' "" q - -let subst_elt_to_string = function - | DB(i, x) -> U.format2 "DB (%s, %s)" (string_of_int i) (bv_to_string x) - | DT(i, t) -> U.format2 "DT (%s, %s)" (string_of_int i) (term_to_string t) - | NM(x, i) -> U.format2 "NM (%s, %s)" (bv_to_string x) (string_of_int i) - | NT(x, t) -> U.format2 "NT (%s, %s)" (bv_to_string x) (term_to_string t) - | UN(i, u) -> U.format2 "UN (%s, %s)" (string_of_int i) (univ_to_string u) - | UD(u, i) -> U.format2 "UD (%s, %s)" (string_of_id u) (string_of_int i) - -(* - * AR: 07/19: exports is redundant, keeping it here until vale is fixed to not parse it - *) -let modul_to_string (m:modul) = - U.format2 "module %s\nDeclarations: [\n%s\n]\n" - (show m.name) (List.map sigelt_to_string m.declarations |> String.concat "\n") - -let metadata_to_string = function - | Meta_pattern (_, ps) -> - let pats = ps |> List.map (fun args -> args |> List.map (fun (t, _) -> term_to_string t) |> String.concat "; ") |> String.concat "\/" in - U.format1 "{Meta_pattern %s}" pats - - | Meta_named lid -> - U.format1 "{Meta_named %s}" (sli lid) - - | Meta_labeled (l, r, _) -> - U.format2 "{Meta_labeled (%s, %s)}" (Errors.Msg.rendermsg l) (Range.string_of_range r) - - | Meta_desugared msi -> - "{Meta_desugared}" - - | Meta_monadic (m, t) -> - U.format2 "{Meta_monadic(%s @ %s)}" (sli m) (term_to_string t) - - | Meta_monadic_lift (m, m', t) -> - U.format3 "{Meta_monadic_lift(%s -> %s @ %s)}" (sli m) (sli m') (term_to_string t) - - -instance showable_term = { show = term_to_string; } -instance showable_univ = { show = univ_to_string; } -instance showable_comp = { show = comp_to_string; } -instance showable_sigelt = { show = sigelt_to_string; } -instance showable_bv = { show = bv_to_string; } -instance showable_fv = { show = fv_to_string; } -instance showable_binder = { show = binder_to_string; } -instance showable_uvar = { show = uvar_to_string; } -let ctx_uvar_to_string ctx_uvar = - let reason_string = U.format1 "(* %s *)\n" ctx_uvar.ctx_uvar_reason in - format5 "%s(%s |- %s : %s) %s" - reason_string - (String.concat ", " <| List.map show ctx_uvar.ctx_uvar_binders) - (uvar_to_string ctx_uvar.ctx_uvar_head) - (term_to_string (SU.ctx_uvar_typ ctx_uvar)) - (match SU.ctx_uvar_should_check ctx_uvar with - | Allow_unresolved s -> "Allow_unresolved " ^s - | Allow_untyped s -> "Allow_untyped " ^s - | Allow_ghost s -> "Allow_ghost " ^s - | Strict -> "Strict" - | Already_checked -> "Already_checked") - -instance showable_ctxu = { show = ctx_uvar_to_string; } -instance showable_binding = { - show = (function - | Binding_var x -> "Binding_var " ^ show x - | Binding_lid x -> "Binding_lid " ^ show x - | Binding_univ x -> "Binding_univ " ^ show x); -} -instance showable_subst_elt = { show = subst_elt_to_string; } -instance showable_branch = { show = Ugly.branch_to_string; } -instance showable_qualifier = { show = qual_to_string; } -instance showable_pat = { show = pat_to_string; } -instance showable_const = { show = const_to_string; } -instance showable_letbinding = { show = Ugly.lb_to_string; } -instance showable_modul = { show = modul_to_string; } -instance showable_metadata = { show = metadata_to_string; } -instance showable_ctx_uvar_meta = { - show = (function - | Ctx_uvar_meta_attr attr -> "Ctx_uvar_meta_attr " ^ show attr - | Ctx_uvar_meta_tac r -> "Ctx_uvar_meta_tac " ^ show r); -} -instance showable_aqual = { show = aqual_to_string; } - -let tscheme_to_string ts = - if Options.ugly () - then Ugly.tscheme_to_string ts - else Pretty.tscheme_to_string ts - -let sub_eff_to_string se = - let tsopt_to_string ts_opt = - if is_some ts_opt then ts_opt |> must |> tscheme_to_string - else "" in - U.format4 "sub_effect %s ~> %s : lift = %s ;; lift_wp = %s" - (lid_to_string se.source) (lid_to_string se.target) - (tsopt_to_string se.lift) (tsopt_to_string se.lift_wp) - -instance showable_sub_eff = { show = sub_eff_to_string; } - -instance pretty_term = { pp = term_to_doc; } -instance pretty_univ = { pp = univ_to_doc; } -instance pretty_sigelt = { pp = sigelt_to_doc; } -instance pretty_comp = { pp = comp_to_doc; } -instance pretty_ctxu = { pp = (fun x -> Pprint.doc_of_string (show x)); } -instance pretty_uvar = { pp = (fun x -> Pprint.doc_of_string (show x)); } -instance pretty_binder = { pp = (fun x -> Pprint.doc_of_string (show x)); } -instance pretty_bv = { pp = (fun x -> Pprint.doc_of_string (show x)); } - -open FStar.Pprint - -instance pretty_binding : pretty binding = { - pp = (function Binding_var bv -> pp bv - | Binding_lid (l, (us, t)) -> pp l ^^ colon ^^ pp t - | Binding_univ u -> pp u); -} - -let rec sigelt_to_string_short (x: sigelt) = match x.sigel with - | Sig_pragma p -> - show p - - | Sig_let {lbs=(false, [{lbname=lb}])} -> - U.format1 "let %s" (lbname_to_string lb) - - | Sig_let {lbs=(true, [{lbname=lb}])} -> - U.format1 "let rec %s" (lbname_to_string lb) - - | Sig_let {lbs=(true, lbs)} -> - U.format1 "let rec %s" (String.concat " and " (List.map (fun lb -> lbname_to_string lb.lbname) lbs)) - - | Sig_let _ -> - failwith "Impossible: sigelt_to_string_short, ill-formed let" - - | Sig_declare_typ {lid} -> - U.format1 "val %s" (string_of_lid lid) - - | Sig_inductive_typ {lid} -> - U.format1 "type %s" (string_of_lid lid) - - | Sig_datacon {lid; ty_lid=t_lid} -> - U.format2 "datacon %s for type %s" (string_of_lid lid) (string_of_lid t_lid) - - | Sig_assume {lid} -> - U.format1 "assume %s" (string_of_lid lid) - - | Sig_bundle {ses} -> List.hd ses |> sigelt_to_string_short - - | Sig_fail {ses} -> - U.format1 "[@@expect_failure] %s" (ses |> List.hd |> sigelt_to_string_short) - - | Sig_new_effect ed -> - let kw = - if SU.is_layered ed then "layered_effect" - else if SU.is_dm4f ed then "new_effect_for_free" - else "new_effect" - in - U.format2 "%s { %s ... }" kw (lid_to_string ed.mname) - - | Sig_sub_effect se -> - U.format2 "sub_effect %s ~> %s" (lid_to_string se.source) (lid_to_string se.target) - - | Sig_effect_abbrev {lid=l; bs=tps; comp=c} -> - U.format3 "effect %s %s = %s" (sli l) - (String.concat " " <| List.map show tps) - (show c) - - | Sig_splice {is_typed; lids} -> - U.format3 "%splice%s[%s] (...)" - "%s" // sigh, no escape for format - (if is_typed then "_t" else "") - (String.concat "; " <| List.map Ident.string_of_lid lids) - - | Sig_polymonadic_bind {m_lid=m; n_lid=n; p_lid=p} -> - U.format3 "polymonadic_bind (%s, %s) |> %s" - (Ident.string_of_lid m) (Ident.string_of_lid n) (Ident.string_of_lid p) - - | Sig_polymonadic_subcomp {m_lid=m; n_lid=n} -> - U.format2 "polymonadic_subcomp %s <: %s" (Ident.string_of_lid m) (Ident.string_of_lid n) - -let binder_to_json env b = - let n = JsonStr (bqual_to_string' (nm_to_string b.binder_bv) b.binder_qual) in - let t = JsonStr (term_to_string' env b.binder_bv.sort) in - JsonAssoc [("name", n); ("type", t)] - -let binders_to_json env bs = - JsonList (List.map (binder_to_json env) bs) - -let eff_decl_to_string ed = - if Options.ugly () - then Ugly.eff_decl_to_string ed - else Pretty.eff_decl_to_string ed - -instance showable_eff_decl = { show = eff_decl_to_string; } - -let args_to_string (args:Syntax.args) : string = - String.concat " " <| - List.map (fun (a, q) -> - aqual_to_string q ^ term_to_string a) args - -instance showable_decreases_order = { - show = (function - | Decreases_lex l -> "Decreases_lex " ^ show l - | Decreases_wf l -> "Decreases_wf " ^ show l); -} - -let cflag_to_string (c:cflag) : string = - match c with - | TOTAL -> "total" - | MLEFFECT -> "ml" - | RETURN -> "return" - | PARTIAL_RETURN -> "partial_return" - | SOMETRIVIAL -> "sometrivial" - | TRIVIAL_POSTCONDITION -> "trivial_postcondition" - | SHOULD_NOT_INLINE -> "should_not_inline" - | LEMMA -> "lemma" - | CPS -> "cps" - | DECREASES do -> "decreases " ^ show do - -instance showable_cflag = { show = cflag_to_string; } - -let binder_to_string_with_type b = - if Options.ugly () then - let attrs = - match b.binder_attrs with - | [] -> "" - | ts -> "[@@@" ^ (String.concat ", " (List.map show ts)) ^ "] " - in - if is_null_binder b - then attrs ^ "_:" ^ term_to_string b.binder_bv.sort - else bqual_to_string' (attrs ^ nm_to_string b.binder_bv ^ ": " ^ term_to_string b.binder_bv.sort) b.binder_qual - else - Pretty.binder_to_string' false b diff --git a/src/syntax/print/FStar.Syntax.Print.fsti b/src/syntax/print/FStar.Syntax.Print.fsti deleted file mode 100644 index 24b5a805b65..00000000000 --- a/src/syntax/print/FStar.Syntax.Print.fsti +++ /dev/null @@ -1,90 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Syntax.Print - -open FStar.Compiler.Effect -open FStar.Syntax.Syntax -open FStar.Class.Show -open FStar.Class.PP - -module DsEnv = FStar.Syntax.DsEnv -module Json = FStar.Json - -(* Use the instances if possible! *) - -instance val showable_term : showable term -instance val showable_univ : showable universe -instance val showable_comp : showable comp -instance val showable_sigelt : showable sigelt -instance val showable_bv : showable bv -instance val showable_fv : showable fv -instance val showable_binder : showable binder -instance val showable_uvar : showable uvar -instance val showable_ctxu : showable ctx_uvar -instance val showable_binding : showable binding -instance val showable_subst_elt : showable subst_elt -instance val showable_branch : showable branch -instance val showable_aqual : showable aqual -instance val showable_qualifier : showable qualifier -instance val showable_pat : showable pat -instance val showable_const : showable sconst -instance val showable_letbinding : showable letbinding -instance val showable_modul : showable modul -instance val showable_ctx_uvar_meta : showable ctx_uvar_meta_t -instance val showable_metadata : showable metadata -instance val showable_decreases_order : showable decreases_order -instance val showable_cflag : showable cflag -instance val showable_sub_eff : showable sub_eff -instance val showable_eff_decl : showable eff_decl - -instance val pretty_term : pretty term -instance val pretty_univ : pretty universe -instance val pretty_comp : pretty comp -instance val pretty_sigelt : pretty sigelt -instance val pretty_uvar : pretty uvar -instance val pretty_ctxu : pretty ctx_uvar -instance val pretty_binder : pretty binder -instance val pretty_bv : pretty bv -instance val pretty_binding : pretty binding - -(* A "short" version of printing a sigelt. Meant to (usually) be a small string -suitable to embed in an error message. No need to be fully faithful to -printing universes, etc, it should just make it clear enough to which -sigelt it refers to. *) -val sigelt_to_string_short: sigelt -> string - -(* These versions take in a DsEnv to abbreviate names. *) -val term_to_string' : DsEnv.env -> term -> string -val comp_to_string' : DsEnv.env -> comp -> string -val sigelt_to_string' : DsEnv.env -> sigelt -> string -val term_to_doc' : DsEnv.env -> term -> Pprint.document -val comp_to_doc' : DsEnv.env -> comp -> Pprint.document -val sigelt_to_doc' : DsEnv.env -> sigelt -> Pprint.document - -(* Prints as ty instead of a pair. *) -val tscheme_to_string : tscheme -> string - -(* Prints sugar, 'Implicit _' prints as '#', etc *) -val bqual_to_string : bqual -> string - -(* Prints arguments as they show up in the source, useful -for error messages. *) -val args_to_string : args -> string - -(* This should really go elsewhere. *) -val binders_to_json : DsEnv.env -> binders -> Json.json - -val binder_to_string_with_type : binder -> string diff --git a/src/syntax/print/FStarC.Syntax.Print.Pretty.fst b/src/syntax/print/FStarC.Syntax.Print.Pretty.fst new file mode 100644 index 00000000000..778945bc81b --- /dev/null +++ b/src/syntax/print/FStarC.Syntax.Print.Pretty.fst @@ -0,0 +1,144 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Syntax.Print.Pretty +open FStarC + +open FStarC.Compiler +open FStarC.Syntax.Syntax +open FStarC.Compiler.Util +module Resugar = FStarC.Syntax.Resugar +module ToDocument = FStarC.Parser.ToDocument +module Pp = FStarC.Pprint + +let rfrac = float_of_string "1.0" +let width = 100 +let pp d = Pp.pretty_string rfrac width d + +let term_to_doc' env (tm:term) : Pprint.document = GenSym.with_frozen_gensym (fun () -> + let e = Resugar.resugar_term' env tm in + ToDocument.term_to_document e +) + +let univ_to_doc' env (u:universe) : Pprint.document = GenSym.with_frozen_gensym (fun () -> + let e = Resugar.resugar_universe' env u Range.dummyRange in + ToDocument.term_to_document e +) + +let term_to_string' env (tm:term) : string = GenSym.with_frozen_gensym (fun () -> + let d = term_to_doc' env tm in + pp d +) + +let univ_to_string' env (u:universe) : string = GenSym.with_frozen_gensym (fun () -> + let d = univ_to_doc' env u in + pp d +) + +let comp_to_doc' env (c:comp) : Pprint.document = GenSym.with_frozen_gensym (fun () -> + let e = Resugar.resugar_comp' env c in + ToDocument.term_to_document e +) + +let comp_to_string' env (c:comp) : string = GenSym.with_frozen_gensym (fun () -> + let d = comp_to_doc' env c in + pp d +) + +let sigelt_to_doc' env (se:sigelt) : Pprint.document = GenSym.with_frozen_gensym (fun () -> + match Resugar.resugar_sigelt' env se with + | None -> Pprint.empty + | Some d -> ToDocument.decl_to_document d +) + +let sigelt_to_string' env (se:sigelt) : string = GenSym.with_frozen_gensym (fun () -> + let d = sigelt_to_doc' env se in + pp d +) + +(* These are duplicated instead of being a special case +of the above so we can reuse the empty_env created at module +load time for DsEnv. Otherwise we need to create another empty +DsEnv.env here. *) +let term_to_doc (tm:term) : Pprint.document = GenSym.with_frozen_gensym (fun () -> + let e = Resugar.resugar_term tm in + ToDocument.term_to_document e +) + +let univ_to_doc (u:universe) : Pprint.document = GenSym.with_frozen_gensym (fun () -> + let e = Resugar.resugar_universe u Range.dummyRange in + ToDocument.term_to_document e +) + +let comp_to_doc (c:comp) : Pprint.document = GenSym.with_frozen_gensym (fun () -> + let e = Resugar.resugar_comp c in + ToDocument.term_to_document e +) + +let sigelt_to_doc (se:sigelt) : Pprint.document = GenSym.with_frozen_gensym (fun () -> + match Resugar.resugar_sigelt se with + | None -> Pprint.empty + | Some d -> ToDocument.decl_to_document d +) + +let term_to_string (tm:term) : string = GenSym.with_frozen_gensym (fun () -> + let d = term_to_doc tm in + pp d +) + +let comp_to_string (c:comp) : string = GenSym.with_frozen_gensym (fun () -> + let e = Resugar.resugar_comp c in + let d = ToDocument.term_to_document e in + pp d +) + +let sigelt_to_string (se:sigelt) : string = GenSym.with_frozen_gensym (fun () -> + match Resugar.resugar_sigelt se with + | None -> "" + | Some d -> + let d = ToDocument.decl_to_document d in + pp d +) + +let univ_to_string (u:universe) : string = GenSym.with_frozen_gensym (fun () -> + let e = Resugar.resugar_universe u Range.dummyRange in + let d = ToDocument.term_to_document e in + pp d +) + +let tscheme_to_string (ts:tscheme) : string = GenSym.with_frozen_gensym (fun () -> + let d = Resugar.resugar_tscheme ts in + let d = ToDocument.decl_to_document d in + pp d +) + +let pat_to_string (p:pat) : string = GenSym.with_frozen_gensym (fun () -> + let e = Resugar.resugar_pat p (Class.Setlike.empty ()) in + let d = ToDocument.pat_to_document e in + pp d +) + +let binder_to_string' is_arrow (b:binder) : string = GenSym.with_frozen_gensym (fun () -> + let e = Resugar.resugar_binder b Range.dummyRange in + let d = ToDocument.binder_to_document e in + pp d +) + +let eff_decl_to_string ed = GenSym.with_frozen_gensym (fun () -> + let d = Resugar.resugar_eff_decl ed in + let d = ToDocument.decl_to_document d in + pp d +) diff --git a/src/syntax/print/FStarC.Syntax.Print.Pretty.fsti b/src/syntax/print/FStarC.Syntax.Print.Pretty.fsti new file mode 100644 index 00000000000..6a1c088a7fd --- /dev/null +++ b/src/syntax/print/FStarC.Syntax.Print.Pretty.fsti @@ -0,0 +1,50 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Syntax.Print.Pretty + +open FStarC +open FStarC.Compiler +open FStarC.Syntax +open FStarC.Syntax.Syntax + +(* Use the 'primed' versions if possible: they abbreviate lidents *) + +val term_to_doc' : DsEnv.env -> term -> Pprint.document +val univ_to_doc' : DsEnv.env -> universe -> Pprint.document +val comp_to_doc' : DsEnv.env -> comp -> Pprint.document +val sigelt_to_doc' : DsEnv.env -> sigelt -> Pprint.document + +val term_to_string' : DsEnv.env -> term -> string +val univ_to_string' : DsEnv.env -> universe -> string +val comp_to_string' : DsEnv.env -> comp -> string +val sigelt_to_string' : DsEnv.env -> sigelt -> string + +(* If no DsEnv.env is at hand, these can be used instead. *) +val term_to_doc : term -> Pprint.document +val univ_to_doc : universe -> Pprint.document +val comp_to_doc : comp -> Pprint.document +val sigelt_to_doc : sigelt -> Pprint.document + +val term_to_string : term -> string +val univ_to_string : universe -> string +val comp_to_string : comp -> string +val sigelt_to_string : sigelt -> string + +val tscheme_to_string : tscheme -> string +val pat_to_string : pat -> string +val binder_to_string' : bool -> binder -> string +val eff_decl_to_string : eff_decl -> string diff --git a/src/syntax/print/FStarC.Syntax.Print.Ugly.fst b/src/syntax/print/FStarC.Syntax.Print.Ugly.fst new file mode 100644 index 00000000000..7230d159f1e --- /dev/null +++ b/src/syntax/print/FStarC.Syntax.Print.Ugly.fst @@ -0,0 +1,693 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Syntax.Print.Ugly +open FStar.Pervasives +open FStarC.Compiler.Effect + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Syntax +open FStarC.Compiler.Util +open FStarC.Syntax.Syntax +open FStarC.Syntax.Subst +open FStarC.Ident +open FStarC.Const +open FStarC.Json + +open FStarC.Class.Tagged +open FStarC.Class.Show + +module Errors = FStarC.Errors +module U = FStarC.Compiler.Util +module A = FStarC.Parser.AST +module Unionfind = FStarC.Syntax.Unionfind +module C = FStarC.Parser.Const +module SU = FStarC.Syntax.Util + +let sli (l:lident) : string = + if Options.print_real_names() + then string_of_lid l + else string_of_id (ident_of_lid l) +// Util.format3 "%s@{def=%s;use=%s}" s +// (Range.string_of_range (Ident.range_of_lid l)) +// (Range.string_of_use_range (Ident.range_of_lid l)) + +let lid_to_string (l:lid) = sli l + +// let fv_to_string fv = Printf.sprintf "%s@%A" (lid_to_string fv.fv_name.v) fv.fv_delta +let fv_to_string fv = lid_to_string fv.fv_name.v //^ "(@@" ^ showfv.fv_delta ^ ")" +let bv_to_string bv = (string_of_id bv.ppname) ^ "#" ^ (string_of_int bv.index) + +let nm_to_string bv = + if Options.print_real_names() + then bv_to_string bv + else (string_of_id bv.ppname) + +let db_to_string bv = (string_of_id bv.ppname) ^ "@" ^ string_of_int bv.index + +let filter_imp aq = + (* keep typeclass args *) + match aq with + | Some (Meta t) when SU.is_fvar C.tcresolve_lid t -> true + | Some (Implicit _) + | Some (Meta _) -> false + | _ -> true +let filter_imp_args args = + args |> List.filter (function (_, None) -> true | (_, Some a) -> not a.aqual_implicit) +let filter_imp_binders bs = + bs |> List.filter (fun b -> b.binder_qual |> filter_imp) + +let const_to_string = C.const_to_string + +let lbname_to_string = function + | Inl l -> bv_to_string l + | Inr l -> lid_to_string l.fv_name.v + +let uvar_to_string u = if (Options.hide_uvar_nums()) then "?" else "?" ^ (Unionfind.uvar_id u |> string_of_int) +let version_to_string v = U.format2 "%s.%s" (U.string_of_int v.major) (U.string_of_int v.minor) +let univ_uvar_to_string u = + if (Options.hide_uvar_nums()) + then "?" + else "?" ^ (Unionfind.univ_uvar_id u |> string_of_int) + ^ ":" ^ (u |> (fun (_, u, _) -> version_to_string u)) + +let rec int_of_univ n u = match Subst.compress_univ u with + | U_zero -> n, None + | U_succ u -> int_of_univ (n+1) u + | _ -> n, Some u + +let rec univ_to_string u = +Errors.with_ctx "While printing universe" (fun () -> + match Subst.compress_univ u with + | U_unif u -> "U_unif "^univ_uvar_to_string u + | U_name x -> "U_name "^(string_of_id x) + | U_bvar x -> "@"^string_of_int x + | U_zero -> "0" + | U_succ u -> + begin match int_of_univ 1 u with + | n, None -> string_of_int n + | n, Some u -> U.format2 "(%s + %s)" (univ_to_string u) (string_of_int n) + end + | U_max us -> U.format1 "(max %s)" (List.map univ_to_string us |> String.concat ", ") + | U_unknown -> "unknown" +) + +let univs_to_string us = List.map univ_to_string us |> String.concat ", " + +let univ_names_to_string us = List.map (fun x -> (string_of_id x)) us |> String.concat ", " + +let qual_to_string = function + | Assumption -> "assume" + | InternalAssumption -> "internal_assume" + | New -> "new" + | Private -> "private" + | Unfold_for_unification_and_vcgen -> "unfold" + | Inline_for_extraction -> "inline_for_extraction" + | NoExtract -> "noextract" + | Visible_default -> "visible" + | Irreducible -> "irreducible" + | Noeq -> "noeq" + | Unopteq -> "unopteq" + | Logic -> "logic" + | TotalEffect -> "total" + | Discriminator l -> U.format1 "(Discriminator %s)" (lid_to_string l) + | Projector (l, x) -> U.format2 "(Projector %s %s)" (lid_to_string l) (string_of_id x) + | RecordType (ns, fns) -> U.format2 "(RecordType %s %s)" (text_of_path (path_of_ns ns)) (fns |> List.map string_of_id |> String.concat ", ") + | RecordConstructor (ns, fns) -> U.format2 "(RecordConstructor %s %s)" (text_of_path (path_of_ns ns)) (fns |> List.map string_of_id |> String.concat ", ") + | Action eff_lid -> U.format1 "(Action %s)" (lid_to_string eff_lid) + | ExceptionConstructor -> "ExceptionConstructor" + | HasMaskedEffect -> "HasMaskedEffect" + | Effect -> "Effect" + | Reifiable -> "reify" + | Reflectable l -> U.format1 "(reflect %s)" (string_of_lid l) + | OnlyName -> "OnlyName" + +let quals_to_string quals = + match quals with + | [] -> "" + | _ -> quals |> List.map qual_to_string |> String.concat " " + +let quals_to_string' quals = + match quals with + | [] -> "" + | _ -> quals_to_string quals ^ " " + +let paren s = "(" ^ s ^ ")" + +let rec term_to_string x = + Errors.with_ctx "While ugly-printing a term" (fun () -> + let x = Subst.compress x in + let x = if Options.print_implicits() then x else SU.unmeta x in + match x.n with + | Tm_delayed _ -> failwith "impossible" + | Tm_app {args=[]} -> failwith "Empty args!" + + // TODO: add an option to mark where this happens + | Tm_lazy ({blob=b; lkind=Lazy_embedding (_, thunk)}) -> + "[LAZYEMB:" ^ + term_to_string (Thunk.force thunk) ^ "]" + | Tm_lazy i -> + "[lazy:" ^ + term_to_string (must !lazy_chooser i.lkind i) // can't call into Syntax.Util here.. + ^"]" + + | Tm_quoted (tm, qi) -> + begin match qi.qkind with + | Quote_static -> + U.format2 "`(%s)%s" (term_to_string tm) + (FStarC.Common.string_of_list term_to_string (snd qi.antiquotations)) + | Quote_dynamic -> + U.format1 "quote (%s)" (term_to_string tm) + end + + | Tm_meta {tm=t; meta=Meta_pattern (_, ps)} -> + let pats = ps |> List.map (fun args -> args |> List.map (fun (t, _) -> term_to_string t) |> String.concat "; ") |> String.concat "\/" in + U.format2 "{:pattern %s} %s" pats (term_to_string t) + + | Tm_meta {tm=t; meta=Meta_monadic (m, t')} -> U.format4 ("(MetaMonadic-{%s %s} (%s) %s)") (sli m) (term_to_string t') (tag_of t) (term_to_string t) + + | Tm_meta {tm=t; meta=Meta_monadic_lift(m0, m1, t')} -> U.format4 ("(MetaMonadicLift-{%s : %s -> %s} %s)") (term_to_string t') (sli m0) (sli m1) (term_to_string t) + + | Tm_meta {tm=t; meta=Meta_labeled(l,r,b)} -> + U.format3 "Meta_labeled(%s, %s){%s}" (Errors.Msg.rendermsg l) (Range.string_of_range r) (term_to_string t) + + | Tm_meta {tm=t; meta=Meta_named(l)} -> + U.format3 "Meta_named(%s, %s){%s}" (lid_to_string l) (Range.string_of_range t.pos) (term_to_string t) + + | Tm_meta {tm=t; meta=Meta_desugared _} -> + U.format1 "Meta_desugared{%s}" (term_to_string t) + + | Tm_bvar x -> db_to_string x ^ ":(" ^ (tag_of x.sort) ^ ")" + | Tm_name x -> nm_to_string x // ^ "@@(" ^ term_to_string x.sort ^ ")" + | Tm_fvar f -> + // Add a prefix to unresolved constructors/projectors, otherwise + // we print a unqualified fvar, which looks exactly like a Tm_name + let pref = + match f.fv_qual with + | Some (Unresolved_projector _) -> "(Unresolved_projector)" + | Some (Unresolved_constructor _) -> "(Unresolved_constructor)" + | _ -> "" + in + pref ^ fv_to_string f + | Tm_uvar (u, ([], _)) -> + if Options.print_bound_var_types() + && Options.print_effect_args() + then ctx_uvar_to_string_aux true u + else "?" ^ (string_of_int <| Unionfind.uvar_id u.ctx_uvar_head) + | Tm_uvar (u, s) -> + if Options.print_bound_var_types() + && Options.print_effect_args() + then U.format2 "(%s @ %s)" (ctx_uvar_to_string_aux true u) (List.map subst_to_string (fst s) |> String.concat "; ") + else "?" ^ (string_of_int <| Unionfind.uvar_id u.ctx_uvar_head) + | Tm_constant c -> const_to_string c + | Tm_type u -> if (Options.print_universes()) then U.format1 "Type u#(%s)" (univ_to_string u) else "Type" + | Tm_arrow {bs; comp=c} -> U.format2 "(%s -> %s)" (binders_to_string " -> " bs) (comp_to_string c) + | Tm_abs {bs; body=t2; rc_opt=lc} -> + begin match lc with + | Some rc when (Options.print_implicits()) -> + U.format4 "(fun %s -> (%s $$ (residual) %s %s))" + (binders_to_string " " bs) + (term_to_string t2) + (string_of_lid rc.residual_effect) + (if Option.isNone rc.residual_typ then "None" else term_to_string (Option.get rc.residual_typ)) + | _ -> + U.format2 "(fun %s -> %s)" (binders_to_string " " bs) (term_to_string t2) + end + | Tm_refine {b=xt; phi=f} -> U.format3 "(%s:%s{%s})" (bv_to_string xt) (xt.sort |> term_to_string) (f |> formula_to_string) + | Tm_app {hd=t; args} -> U.format2 "(%s %s)" (term_to_string t) (args_to_string args) + | Tm_let {lbs; body=e} -> U.format2 "%s\nin\n%s" (lbs_to_string [] lbs) (term_to_string e) + | Tm_ascribed {tm=e;asc=(annot, topt, b);eff_opt=eff_name} -> + let annot = match annot with + | Inl t -> U.format2 "[%s] %s" (map_opt eff_name Ident.string_of_lid |> dflt "default") (term_to_string t) + | Inr c -> comp_to_string c in + let topt = match topt with + | None -> "" + | Some t -> U.format1 "by %s" (term_to_string t) in + let s = if b then "ascribed_eq" else "ascribed" in + U.format4 "(%s <%s: %s %s)" (term_to_string e) s annot topt + | Tm_match {scrutinee=head; ret_opt=asc_opt; brs=branches; rc_opt=lc} -> + let lc_str = + match lc with + | Some lc when (Options.print_implicits ()) -> + U.format1 " (residual_comp:%s)" + (if Option.isNone lc.residual_typ then "None" else term_to_string (Option.get lc.residual_typ)) + | _ -> "" in + U.format4 "(match %s %swith\n\t| %s%s)" + (term_to_string head) + (match asc_opt with + | None -> "" + | Some (b, (asc, tacopt, use_eq)) -> + let s = if use_eq then "returns$" else "returns" in + U.format4 "as %s %s %s%s " + (binder_to_string b) + s + (match asc with + | Inl t -> term_to_string t + | Inr c -> comp_to_string c) + (match tacopt with + | None -> "" + | Some tac -> U.format1 " by %s" (term_to_string tac))) + (U.concat_l "\n\t|" (branches |> List.map branch_to_string)) + lc_str + | Tm_uinst(t, us) -> + if (Options.print_universes()) + then U.format2 "%s<%s>" (term_to_string t) (univs_to_string us) + else term_to_string t + + | Tm_unknown -> "_" + ) + +and branch_to_string (p, wopt, e) : string = + U.format3 "%s %s -> %s" + (p |> pat_to_string) + (match wopt with | None -> "" | Some w -> U.format1 "when %s" (w |> term_to_string)) + (e |> term_to_string) +and ctx_uvar_to_string_aux print_reason ctx_uvar = + let reason_string = + if print_reason + then U.format1 "(* %s *)\n" ctx_uvar.ctx_uvar_reason + else U.format2 "(%s-%s) " + (Range.string_of_pos (Range.start_of_range ctx_uvar.ctx_uvar_range)) + (Range.string_of_pos (Range.end_of_range ctx_uvar.ctx_uvar_range)) in + format5 "%s(%s |- %s : %s) %s" + reason_string + (binders_to_string ", " ctx_uvar.ctx_uvar_binders) + (uvar_to_string ctx_uvar.ctx_uvar_head) + (term_to_string (SU.ctx_uvar_typ ctx_uvar)) + (match SU.ctx_uvar_should_check ctx_uvar with + | Allow_unresolved s -> "Allow_unresolved " ^s + | Allow_untyped s -> "Allow_untyped " ^s + | Allow_ghost s -> "Allow_ghost " ^s + | Strict -> "Strict" + | Already_checked -> "Already_checked") + + +and subst_elt_to_string = function + | DB(i, x) -> U.format2 "DB (%s, %s)" (string_of_int i) (bv_to_string x) + | DT(i, t) -> U.format2 "DT (%s, %s)" (string_of_int i) (term_to_string t) + | NM(x, i) -> U.format2 "NM (%s, %s)" (bv_to_string x) (string_of_int i) + | NT(x, t) -> U.format2 "NT (%s, %s)" (bv_to_string x) (term_to_string t) + | UN(i, u) -> U.format2 "UN (%s, %s)" (string_of_int i) (univ_to_string u) + | UD(u, i) -> U.format2 "UD (%s, %s)" (string_of_id u) (string_of_int i) + +and subst_to_string s = s |> List.map subst_elt_to_string |> String.concat "; " + +and pat_to_string x = + match x.v with + | Pat_cons(l, us_opt, pats) -> + U.format3 "(%s%s%s)" + (fv_to_string l) + (if not (Options.print_universes()) + then " " + else + match us_opt with + | None -> " " + | Some us -> + U.format1 " %s " (List.map univ_to_string us |> String.concat " ")) + (List.map (fun (x, b) -> let p = pat_to_string x in if b then "#"^p else p) pats |> String.concat " ") + | Pat_dot_term topt -> + if Options.print_bound_var_types() + then U.format1 ".%s" (if topt = None then "_" else topt |> U.must |> term_to_string) + else "._" + | Pat_var x -> + if Options.print_bound_var_types() + then U.format2 "%s:%s" (bv_to_string x) (term_to_string x.sort) + else bv_to_string x + | Pat_constant c -> const_to_string c + + +and lbs_to_string quals lbs = +// let lbs = +// if (Options.print_universes()) +// then (fst lbs, snd lbs |> List.map (fun lb -> let us, td = Subst.open_univ_vars lb.lbunivs (Util.mk_conj lb.lbtyp lb.lbdef) in +// let t, d = match (Subst.compress td).n with +// | Tm_app(_, [(t, _); (d, _)]) -> t, d +// | _ -> failwith "Impossibe" in +// {lb with lbunivs=us; lbtyp=t; lbdef=d})) +// else lbs in + U.format3 "%slet %s %s" + (quals_to_string' quals) + (if fst lbs then "rec" else "") + (U.concat_l "\n and " (snd lbs |> List.map (fun lb -> + U.format5 "%s%s %s : %s = %s" + (attrs_to_string lb.lbattrs) + (lbname_to_string lb.lbname) + (if (Options.print_universes()) + then "<"^univ_names_to_string lb.lbunivs^">" + else "") + (term_to_string lb.lbtyp) + (lb.lbdef |> term_to_string)))) +and attrs_to_string = function + | [] -> "" + | tms -> U.format1 "[@ %s]" (List.map (fun t -> paren (term_to_string t)) tms |> String.concat "; ") + +and binder_attrs_to_string = function + | _ when Options.any_dump_module () -> "" + (* ^ VALE HACK: Vale does not properly parse attributes on binders (yet). + Just don't print them. *) + + | [] -> "" + | tms -> U.format1 "[@@@ %s]" (List.map (fun t -> paren (term_to_string t)) tms |> String.concat "; ") + +and bqual_to_string' s = function + | Some (Implicit false) -> "#" ^ s + | Some (Implicit true) -> "#." ^ s + | Some Equality -> "$" ^ s + | Some (Meta t) when SU.is_fvar C.tcresolve_lid t -> "{|" ^ s ^ "|}" + | Some (Meta t) -> "#[" ^ term_to_string t ^ "]" ^ s + | None -> s + +and aqual_to_string' s = function + | Some { aqual_implicit=true } -> "#" ^ s + | _ -> s + +and binder_to_string' is_arrow b = + let attrs = binder_attrs_to_string b.binder_attrs in + if is_null_binder b + then (attrs ^ "_:" ^ term_to_string b.binder_bv.sort) + else if not is_arrow && not (Options.print_bound_var_types()) + then bqual_to_string' (attrs ^ nm_to_string b.binder_bv) b.binder_qual + else bqual_to_string' (attrs ^ nm_to_string b.binder_bv ^ ":" ^ term_to_string b.binder_bv.sort) b.binder_qual + +and binder_to_string b = binder_to_string' false b + +and arrow_binder_to_string b = binder_to_string' true b + +and binders_to_string sep bs = + let bs = + if (Options.print_implicits()) + then bs + else filter_imp_binders bs in + if sep = " -> " + then bs |> List.map arrow_binder_to_string |> String.concat sep + else bs |> List.map binder_to_string |> String.concat sep + +and arg_to_string = function + | a, imp -> aqual_to_string' (term_to_string a) imp + +and args_to_string args = + let args = + if (Options.print_implicits()) + then args + else filter_imp_args args in + args |> List.map arg_to_string |> String.concat " " + +and comp_to_string c = + Errors.with_ctx "While ugly-printing a computation" (fun () -> + match c.n with + | Total t -> + begin match (compress t).n with + | Tm_type _ when not (Options.print_implicits() || Options.print_universes()) -> term_to_string t + | _ -> U.format1 "Tot %s" (term_to_string t) + end + | GTotal t -> + begin match (compress t).n with + | Tm_type _ when not (Options.print_implicits() || Options.print_universes()) -> term_to_string t + | _ -> U.format1 "GTot %s" (term_to_string t) + end + | Comp c -> + let basic = + if (Options.print_effect_args()) + then U.format5 "%s<%s> (%s) %s (attributes %s)" + (sli c.effect_name) + (c.comp_univs |> List.map univ_to_string |> String.concat ", ") + (term_to_string c.result_typ) + (c.effect_args |> List.map arg_to_string |> String.concat ", ") + (cflags_to_string c.flags) + else if c.flags |> U.for_some (function TOTAL -> true | _ -> false) + && not (Options.print_effect_args()) + then U.format1 "Tot %s" (term_to_string c.result_typ) + else if not (Options.print_effect_args()) + && not (Options.print_implicits()) + && lid_equals c.effect_name (C.effect_ML_lid()) + then term_to_string c.result_typ + else if not (Options.print_effect_args()) + && c.flags |> U.for_some (function MLEFFECT -> true | _ -> false) + then U.format1 "ALL %s" (term_to_string c.result_typ) + else U.format2 "%s (%s)" (sli c.effect_name) (term_to_string c.result_typ) in + let dec = c.flags + |> List.collect (function DECREASES dec_order -> + (match dec_order with + | Decreases_lex l -> + [U.format1 " (decreases [%s])" + (match l with + | [] -> "" + | hd::tl -> + tl |> List.fold_left (fun s t -> + s ^ ";" ^ term_to_string t) (term_to_string hd))] + | Decreases_wf (rel, e) -> + [U.format2 "(decreases {:well-founded %s %s})" (term_to_string rel) (term_to_string e)]) + | _ -> []) + + |> String.concat " " in + U.format2 "%s%s" basic dec + ) + +(* NB: this is reduced version of the one in Print *) +and cflag_to_string c = + match c with + | TOTAL -> "total" + | MLEFFECT -> "ml" + | RETURN -> "return" + | PARTIAL_RETURN -> "partial_return" + | SOMETRIVIAL -> "sometrivial" + | TRIVIAL_POSTCONDITION -> "trivial_postcondition" + | SHOULD_NOT_INLINE -> "should_not_inline" + | LEMMA -> "lemma" + | CPS -> "cps" + | DECREASES _ -> "" (* TODO : already printed for now *) + +and cflags_to_string fs = FStarC.Common.string_of_list cflag_to_string fs + +(* CH: at this point not even trying to detect if something looks like a formula, + only locally detecting certain patterns *) +and formula_to_string phi = term_to_string phi + +let aqual_to_string aq = aqual_to_string' "" aq +let bqual_to_string bq = bqual_to_string' "" bq +let lb_to_string lb = lbs_to_string [] (false, [lb]) + +let comp_to_string' env c = comp_to_string c + +let term_to_string' env x = term_to_string x + + +//let subst_to_string subst = +// U.format1 "{%s}" <| +// (List.map (function +// | Inl (a, t) -> U.format2 "(%s -> %s)" (strBvd a) (typ_to_string t) +// | Inr (x, e) -> U.format2 "(%s -> %s)" (strBvd x) (exp_to_string e)) subst |> String.concat ", ") +//let freevars_to_string (fvs:freevars) = +// let f (l:set (bvar 'a 'b)) = l |> U.set_elements |> List.map (fun t -> strBvd t.v) |> String.concat ", " in +// U.format2 "ftvs={%s}, fxvs={%s}" (f fvs.ftvs) (f fvs.fxvs) + + +let enclose_universes s = + if Options.print_universes () + then "<" ^ s ^ ">" + else "" + +let tscheme_to_string s = + let (us, t) = s in + U.format2 "%s%s" (enclose_universes <| univ_names_to_string us) (term_to_string t) + +let action_to_string a = + U.format5 "%s%s %s : %s = %s" + (sli a.action_name) + (binders_to_string " " a.action_params) + (enclose_universes <| univ_names_to_string a.action_univs) + (term_to_string a.action_typ) + (term_to_string a.action_defn) + +let wp_eff_combinators_to_string combs = + let tscheme_opt_to_string = function + | Some ts -> tscheme_to_string ts + | None -> "None" in + + U.format "{\n\ + ret_wp = %s\n\ + ; bind_wp = %s\n\ + ; stronger = %s\n\ + ; if_then_else = %s\n\ + ; ite_wp = %s\n\ + ; close_wp = %s\n\ + ; trivial = %s\n\ + ; repr = %s\n\ + ; return_repr = %s\n\ + ; bind_repr = %s\n\ + }\n" + [ tscheme_to_string combs.ret_wp; + tscheme_to_string combs.bind_wp; + tscheme_to_string combs.stronger; + tscheme_to_string combs.if_then_else; + tscheme_to_string combs.ite_wp; + tscheme_to_string combs.close_wp; + tscheme_to_string combs.trivial; + tscheme_opt_to_string combs.repr; + tscheme_opt_to_string combs.return_repr; + tscheme_opt_to_string combs.bind_repr ] + +let sub_eff_to_string se = + let tsopt_to_string ts_opt = + if is_some ts_opt then ts_opt |> must |> tscheme_to_string + else "" in + U.format4 "sub_effect %s ~> %s : lift = %s ;; lift_wp = %s" + (lid_to_string se.source) (lid_to_string se.target) + (tsopt_to_string se.lift) (tsopt_to_string se.lift_wp) + +let layered_eff_combinators_to_string combs = + let to_str (ts_t, ts_ty, kopt) = + U.format3 "(%s) : (%s)<%s>" + (tscheme_to_string ts_t) (tscheme_to_string ts_ty) + (show kopt) in + + let to_str2 (ts_t, ts_ty) = + U.format2 "(%s) : (%s)" + (tscheme_to_string ts_t) (tscheme_to_string ts_ty) in + + U.format "{\n\ + ; l_repr = %s\n\ + ; l_return = %s\n\ + ; l_bind = %s\n\ + ; l_subcomp = %s\n\ + ; l_if_then_else = %s\n + %s + }\n" + [ to_str2 combs.l_repr; + to_str2 combs.l_return; + to_str combs.l_bind; + to_str combs.l_subcomp; + to_str combs.l_if_then_else; + + (if None? combs.l_close then "" + else U.format1 "; l_close = %s\n" (combs.l_close |> must |> to_str2)); + ] + +let eff_combinators_to_string = function + | Primitive_eff combs + | DM4F_eff combs -> wp_eff_combinators_to_string combs + | Layered_eff combs -> layered_eff_combinators_to_string combs + +let eff_extraction_mode_to_string = function + | Extract_none s -> U.format1 "none (%s)" s + | Extract_reify -> "reify" + | Extract_primitive -> "primitive" + +let eff_decl_to_string ed = + let actions_to_string actions = + actions |> + List.map action_to_string |> + String.concat ",\n\t" in + let eff_name = if SU.is_layered ed then "layered_effect" else "new_effect" in + U.format "%s%s { \ + %s%s %s : %s \n \ + %s\n\ + and effect_actions\n\t%s\n}\n" + [eff_name; + "" ; //(if for_free then "_for_free " else ""); + lid_to_string ed.mname; + enclose_universes <| univ_names_to_string ed.univs; + binders_to_string " " ed.binders; + ed.signature |> SU.effect_sig_ts |> tscheme_to_string; + eff_combinators_to_string ed.combinators; + actions_to_string ed.actions] + + +let rec sigelt_to_string (x: sigelt) = + let basic = + match x.sigel with + | Sig_pragma p -> show p + | Sig_inductive_typ {lid; us=univs; params=tps; t=k} -> + let quals_str = quals_to_string' x.sigquals in + let binders_str = binders_to_string " " tps in + let term_str = term_to_string k in + if Options.print_universes () then U.format5 "%stype %s<%s> %s : %s" quals_str (string_of_lid lid) (univ_names_to_string univs) binders_str term_str + else U.format4 "%stype %s %s : %s" quals_str (string_of_lid lid) binders_str term_str + | Sig_datacon {lid; us=univs; t} -> + if (Options.print_universes()) + then //let univs, t = Subst.open_univ_vars univs t in (* AR: don't open the universes, else it's a bit confusing *) + U.format3 "datacon<%s> %s : %s" (univ_names_to_string univs) (string_of_lid lid) (term_to_string t) + else U.format2 "datacon %s : %s" (string_of_lid lid) (term_to_string t) + | Sig_declare_typ {lid; us=univs; t} -> + //let univs, t = Subst.open_univ_vars univs t in + U.format4 "%sval %s %s : %s" (quals_to_string' x.sigquals) (string_of_lid lid) + (if (Options.print_universes()) + then U.format1 "<%s>" (univ_names_to_string univs) + else "") + (term_to_string t) + | Sig_assume {lid; us; phi=f} -> + if Options.print_universes () then U.format3 "assume %s<%s> : %s" (string_of_lid lid) (univ_names_to_string us) (term_to_string f) + else U.format2 "assume %s : %s" (string_of_lid lid) (term_to_string f) + | Sig_let {lbs} -> + (* FIXME: do not print the propagated qualifiers on top-level letbindings, + vale fails when parsing them. *) + let lbs = (fst lbs, List.map (fun lb -> { lb with lbattrs = [] }) (snd lbs)) in + lbs_to_string x.sigquals lbs + | Sig_bundle {ses} -> "(* Sig_bundle *)" ^ (List.map sigelt_to_string ses |> String.concat "\n") + | Sig_fail {errs; fail_in_lax=lax; ses} -> + U.format3 "(* Sig_fail %s %s *)\n%s\n(* / Sig_fail*)\n" + (string_of_bool lax) + (FStarC.Common.string_of_list string_of_int errs) + (List.map sigelt_to_string ses |> String.concat "\n") + + | Sig_new_effect(ed) -> + (if SU.is_dm4f ed then "(* DM4F *)" else "") + ^ quals_to_string' x.sigquals + ^ eff_decl_to_string ed + + | Sig_sub_effect (se) -> sub_eff_to_string se + | Sig_effect_abbrev {lid=l; us=univs; bs=tps; comp=c; cflags=flags} -> + if (Options.print_universes()) + then let univs, t = Subst.open_univ_vars univs (mk (Tm_arrow {bs=tps; comp=c}) Range.dummyRange) in + let tps, c = match (Subst.compress t).n with + | Tm_arrow {bs; comp=c} -> bs, c + | _ -> failwith "impossible" in + U.format4 "effect %s<%s> %s = %s" (sli l) (univ_names_to_string univs) (binders_to_string " " tps) (comp_to_string c) + else U.format3 "effect %s %s = %s" (sli l) (binders_to_string " " tps) (comp_to_string c) + | Sig_splice {is_typed; lids; tac=t} -> + U.format3 "splice%s[%s] (%s)" + (if is_typed then "_t" else "") + (String.concat "; " <| List.map show lids) + (term_to_string t) + | Sig_polymonadic_bind {m_lid=m; + n_lid=n; + p_lid=p; + tm=t; + typ=ty; + kind=k} -> + U.format6 "polymonadic_bind (%s, %s) |> %s = (%s, %s)<%s>" + (show m) + (show n) + (show p) + (tscheme_to_string t) + (tscheme_to_string ty) + (show k) + | Sig_polymonadic_subcomp {m_lid=m; + n_lid=n; + tm=t; + typ=ty; + kind=k} -> + U.format5 "polymonadic_subcomp %s <: %s = (%s, %s)<%s>" + (show m) + (show n) + (tscheme_to_string t) + (tscheme_to_string ty) + (show k) + in + match x.sigattrs with + | [] -> "[@ ]" ^ "\n" ^ basic //It is important to keep this empty attribute marker since the Vale type extractor uses it as a delimiter + | _ -> attrs_to_string x.sigattrs ^ "\n" ^ basic diff --git a/src/syntax/print/FStarC.Syntax.Print.Ugly.fsti b/src/syntax/print/FStarC.Syntax.Print.Ugly.fsti new file mode 100644 index 00000000000..81a131bfb09 --- /dev/null +++ b/src/syntax/print/FStarC.Syntax.Print.Ugly.fsti @@ -0,0 +1,34 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Syntax.Print.Ugly + +open FStarC.Compiler.Effect +open FStarC.Compiler +open FStarC.Syntax.Syntax + +val term_to_string : term -> string +val univ_to_string : universe -> string +val comp_to_string : comp -> string +val sigelt_to_string : sigelt -> string +val binder_to_string : binder -> string + +val tscheme_to_string : tscheme -> string + +val lb_to_string : letbinding -> string +val branch_to_string : FStarC.Syntax.Syntax.branch -> string +val pat_to_string : pat -> string + +val eff_decl_to_string : eff_decl -> string diff --git a/src/syntax/print/FStarC.Syntax.Print.fst b/src/syntax/print/FStarC.Syntax.Print.fst new file mode 100644 index 00000000000..ba76e292a0a --- /dev/null +++ b/src/syntax/print/FStarC.Syntax.Print.fst @@ -0,0 +1,502 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Syntax.Print +open FStar.Pervasives +open FStarC.Compiler.Effect + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Range +open FStarC.Syntax +open FStarC.Compiler.Util +open FStarC.Syntax.Syntax +open FStarC.Syntax.Subst +open FStarC.Ident +open FStarC.Const +open FStarC.Json + +module Errors = FStarC.Errors +module U = FStarC.Compiler.Util +module A = FStarC.Parser.AST +module Unionfind = FStarC.Syntax.Unionfind +module C = FStarC.Parser.Const +module SU = FStarC.Syntax.Util + +module Pretty = FStarC.Syntax.Print.Pretty +module Ugly = FStarC.Syntax.Print.Ugly + +let sli (l:lident) : string = + if Options.print_real_names() + then string_of_lid l + else string_of_id (ident_of_lid l) +// Util.format3 "%s@{def=%s;use=%s}" s +// (Range.string_of_range (Ident.range_of_lid l)) +// (Range.string_of_use_range (Ident.range_of_lid l)) + +let lid_to_string (l:lid) = sli l + +// let fv_to_string fv = Printf.sprintf "%s@%A" (lid_to_string fv.fv_name.v) fv.fv_delta +let fv_to_string fv = lid_to_string fv.fv_name.v //^ "(@@" ^ showfv.fv_delta ^ ")" +let bv_to_string bv = + if Options.print_real_names () + then show bv.ppname ^ "#" ^ show bv.index + else show bv.ppname + +let nm_to_string bv = + if Options.print_real_names() + then bv_to_string bv + else (string_of_id bv.ppname) + +let db_to_string bv = (string_of_id bv.ppname) ^ "@" ^ string_of_int bv.index + +let filter_imp aq = + (* keep typeclass args *) + match aq with + | Some (Meta t) when SU.is_fvar C.tcresolve_lid t -> true + | Some (Implicit _) + | Some (Meta _) -> false + | _ -> true +let filter_imp_args args = + args |> List.filter (function (_, None) -> true | (_, Some a) -> not a.aqual_implicit) +let filter_imp_binders bs = + bs |> List.filter (fun b -> b.binder_qual |> filter_imp) + +let const_to_string = C.const_to_string + +let lbname_to_string = function + | Inl l -> bv_to_string l + | Inr l -> lid_to_string l.fv_name.v + +let uvar_to_string u = if (Options.hide_uvar_nums()) then "?" else "?" ^ (Unionfind.uvar_id u |> string_of_int) +let version_to_string v = U.format2 "%s.%s" (U.string_of_int v.major) (U.string_of_int v.minor) +let univ_uvar_to_string u = + if (Options.hide_uvar_nums()) + then "?" + else "?" ^ (Unionfind.univ_uvar_id u |> string_of_int) + ^ ":" ^ (u |> (fun (_, u, _) -> version_to_string u)) + +let rec int_of_univ n u = match Subst.compress_univ u with + | U_zero -> n, None + | U_succ u -> int_of_univ (n+1) u + | _ -> n, Some u + +let rec univ_to_string u = +Errors.with_ctx "While printing universe" (fun () -> + // VD: commented out for testing NBE + // if not (Options.ugly()) then + // Pretty.univ_to_string u + // else + match Subst.compress_univ u with + | U_unif u -> "U_unif "^univ_uvar_to_string u + | U_name x -> "U_name "^(string_of_id x) + | U_bvar x -> "@"^string_of_int x + | U_zero -> "0" + | U_succ u -> + begin match int_of_univ 1 u with + | n, None -> string_of_int n + | n, Some u -> U.format2 "(%s + %s)" (univ_to_string u) (string_of_int n) + end + | U_max us -> U.format1 "(max %s)" (List.map univ_to_string us |> String.concat ", ") + | U_unknown -> "unknown" +) + +let univs_to_string us = List.map univ_to_string us |> String.concat ", " + +let qual_to_string = function + | Assumption -> "assume" + | InternalAssumption -> "internal_assume" + | New -> "new" + | Private -> "private" + | Unfold_for_unification_and_vcgen -> "unfold" + | Inline_for_extraction -> "inline_for_extraction" + | NoExtract -> "noextract" + | Visible_default -> "visible" + | Irreducible -> "irreducible" + | Noeq -> "noeq" + | Unopteq -> "unopteq" + | Logic -> "logic" + | TotalEffect -> "total" + | Discriminator l -> U.format1 "(Discriminator %s)" (lid_to_string l) + | Projector (l, x) -> U.format2 "(Projector %s %s)" (lid_to_string l) (string_of_id x) + | RecordType (ns, fns) -> U.format2 "(RecordType %s %s)" (text_of_path (path_of_ns ns)) (fns |> List.map string_of_id |> String.concat ", ") + | RecordConstructor (ns, fns) -> U.format2 "(RecordConstructor %s %s)" (text_of_path (path_of_ns ns)) (fns |> List.map string_of_id |> String.concat ", ") + | Action eff_lid -> U.format1 "(Action %s)" (lid_to_string eff_lid) + | ExceptionConstructor -> "ExceptionConstructor" + | HasMaskedEffect -> "HasMaskedEffect" + | Effect -> "Effect" + | Reifiable -> "reify" + | Reflectable l -> U.format1 "(reflect %s)" (string_of_lid l) + | OnlyName -> "OnlyName" + +let quals_to_string quals = + match quals with + | [] -> "" + | _ -> quals |> List.map qual_to_string |> String.concat " " + +let quals_to_string' quals = + match quals with + | [] -> "" + | _ -> quals_to_string quals ^ " " + +let paren s = "(" ^ s ^ ")" + +let lkind_to_string = function + | BadLazy -> "BadLazy" + | Lazy_bv -> "Lazy_bv" + | Lazy_namedv -> "Lazy_namedv" + | Lazy_binder -> "Lazy_binder" + | Lazy_optionstate -> "Lazy_optionstate" + | Lazy_fvar -> "Lazy_fvar" + | Lazy_comp -> "Lazy_comp" + | Lazy_env -> "Lazy_env" + | Lazy_proofstate -> "Lazy_proofstate" + | Lazy_goal -> "Lazy_goal" + | Lazy_sigelt -> "Lazy_sigelt" + | Lazy_uvar -> "Lazy_uvar" + | Lazy_letbinding -> "Lazy_letbinding" + | Lazy_embedding (e, _) -> "Lazy_embedding(" ^ show e ^ ")" + | Lazy_universe -> "Lazy_universe" + | Lazy_universe_uvar -> "Lazy_universe_uvar" + | Lazy_issue -> "Lazy_issue" + | Lazy_ident -> "Lazy_ident" + | Lazy_doc -> "Lazy_doc" + | Lazy_extension s -> "Lazy_extension:" ^ s + +let term_to_string x = + if Options.ugly () + then Ugly.term_to_string x + else Pretty.term_to_string x + +let term_to_string' env x = + if Options.ugly () + then Ugly.term_to_string x + else Pretty.term_to_string' env x + +let comp_to_string c = + if Options.ugly () + then Ugly.comp_to_string c + else Pretty.comp_to_string c + +let comp_to_string' env c = + if Options.ugly () + then Ugly.comp_to_string c + else Pretty.comp_to_string' env c + +let sigelt_to_string x = + if Options.ugly () + then Ugly.sigelt_to_string x + else Pretty.sigelt_to_string x + +let sigelt_to_string' env x = + if Options.ugly () + then Ugly.sigelt_to_string x + else Pretty.sigelt_to_string' env x + +let pat_to_string x = + if Options.ugly () + then Ugly.pat_to_string x + else Pretty.pat_to_string x + +let term_to_doc' dsenv t = + if Options.ugly () + then Pprint.arbitrary_string (Ugly.term_to_string t) + else Pretty.term_to_doc' dsenv t + +let univ_to_doc' dsenv t = + if Options.ugly () + then Pprint.arbitrary_string (Ugly.univ_to_string t) + else Pretty.univ_to_doc' dsenv t + +let comp_to_doc' dsenv t = + if Options.ugly () + then Pprint.arbitrary_string (Ugly.comp_to_string t) + else Pretty.comp_to_doc' dsenv t + +let sigelt_to_doc' dsenv t = + if Options.ugly () + then Pprint.arbitrary_string (Ugly.sigelt_to_string t) + else Pretty.sigelt_to_doc' dsenv t + +let term_to_doc t = + if Options.ugly () + then Pprint.arbitrary_string (Ugly.term_to_string t) + else Pretty.term_to_doc t + +let univ_to_doc t = + if Options.ugly () + then Pprint.arbitrary_string (Ugly.univ_to_string t) + else Pretty.univ_to_doc t + +let comp_to_doc t = + if Options.ugly () + then Pprint.arbitrary_string (Ugly.comp_to_string t) + else Pretty.comp_to_doc t + +let sigelt_to_doc t = + if Options.ugly () + then Pprint.arbitrary_string (Ugly.sigelt_to_string t) + else Pretty.sigelt_to_doc t + +let binder_to_string b = + if Options.ugly () + then Pretty.binder_to_string' false b + else Ugly.binder_to_string b + +let aqual_to_string (q:aqual) : string = + match q with + | Some { aqual_implicit=true } -> "#" + | _ -> "" + +let bqual_to_string' (s:string) (b:bqual) : string = + match b with + | Some (Implicit false) -> "#" ^ s + | Some (Implicit true) -> "#." ^ s + | Some Equality -> "$" ^ s + | Some (Meta t) when SU.is_fvar C.tcresolve_lid t -> "{|" ^ s ^ "|}" + | Some (Meta t) -> "#[" ^ term_to_string t ^ "]" ^ s + | None -> s + +let bqual_to_string (q:bqual) : string = + bqual_to_string' "" q + +let subst_elt_to_string = function + | DB(i, x) -> U.format2 "DB (%s, %s)" (string_of_int i) (bv_to_string x) + | DT(i, t) -> U.format2 "DT (%s, %s)" (string_of_int i) (term_to_string t) + | NM(x, i) -> U.format2 "NM (%s, %s)" (bv_to_string x) (string_of_int i) + | NT(x, t) -> U.format2 "NT (%s, %s)" (bv_to_string x) (term_to_string t) + | UN(i, u) -> U.format2 "UN (%s, %s)" (string_of_int i) (univ_to_string u) + | UD(u, i) -> U.format2 "UD (%s, %s)" (string_of_id u) (string_of_int i) + +(* + * AR: 07/19: exports is redundant, keeping it here until vale is fixed to not parse it + *) +let modul_to_string (m:modul) = + U.format2 "module %s\nDeclarations: [\n%s\n]\n" + (show m.name) (List.map sigelt_to_string m.declarations |> String.concat "\n") + +let metadata_to_string = function + | Meta_pattern (_, ps) -> + let pats = ps |> List.map (fun args -> args |> List.map (fun (t, _) -> term_to_string t) |> String.concat "; ") |> String.concat "\/" in + U.format1 "{Meta_pattern %s}" pats + + | Meta_named lid -> + U.format1 "{Meta_named %s}" (sli lid) + + | Meta_labeled (l, r, _) -> + U.format2 "{Meta_labeled (%s, %s)}" (Errors.Msg.rendermsg l) (Range.string_of_range r) + + | Meta_desugared msi -> + "{Meta_desugared}" + + | Meta_monadic (m, t) -> + U.format2 "{Meta_monadic(%s @ %s)}" (sli m) (term_to_string t) + + | Meta_monadic_lift (m, m', t) -> + U.format3 "{Meta_monadic_lift(%s -> %s @ %s)}" (sli m) (sli m') (term_to_string t) + + +instance showable_term = { show = term_to_string; } +instance showable_univ = { show = univ_to_string; } +instance showable_comp = { show = comp_to_string; } +instance showable_sigelt = { show = sigelt_to_string; } +instance showable_bv = { show = bv_to_string; } +instance showable_fv = { show = fv_to_string; } +instance showable_binder = { show = binder_to_string; } +instance showable_uvar = { show = uvar_to_string; } +let ctx_uvar_to_string ctx_uvar = + let reason_string = U.format1 "(* %s *)\n" ctx_uvar.ctx_uvar_reason in + format5 "%s(%s |- %s : %s) %s" + reason_string + (String.concat ", " <| List.map show ctx_uvar.ctx_uvar_binders) + (uvar_to_string ctx_uvar.ctx_uvar_head) + (term_to_string (SU.ctx_uvar_typ ctx_uvar)) + (match SU.ctx_uvar_should_check ctx_uvar with + | Allow_unresolved s -> "Allow_unresolved " ^s + | Allow_untyped s -> "Allow_untyped " ^s + | Allow_ghost s -> "Allow_ghost " ^s + | Strict -> "Strict" + | Already_checked -> "Already_checked") + +instance showable_ctxu = { show = ctx_uvar_to_string; } +instance showable_binding = { + show = (function + | Binding_var x -> "Binding_var " ^ show x + | Binding_lid x -> "Binding_lid " ^ show x + | Binding_univ x -> "Binding_univ " ^ show x); +} +instance showable_subst_elt = { show = subst_elt_to_string; } +instance showable_branch = { show = Ugly.branch_to_string; } +instance showable_qualifier = { show = qual_to_string; } +instance showable_pat = { show = pat_to_string; } +instance showable_const = { show = const_to_string; } +instance showable_letbinding = { show = Ugly.lb_to_string; } +instance showable_modul = { show = modul_to_string; } +instance showable_metadata = { show = metadata_to_string; } +instance showable_ctx_uvar_meta = { + show = (function + | Ctx_uvar_meta_attr attr -> "Ctx_uvar_meta_attr " ^ show attr + | Ctx_uvar_meta_tac r -> "Ctx_uvar_meta_tac " ^ show r); +} +instance showable_aqual = { show = aqual_to_string; } + +let tscheme_to_string ts = + if Options.ugly () + then Ugly.tscheme_to_string ts + else Pretty.tscheme_to_string ts + +let sub_eff_to_string se = + let tsopt_to_string ts_opt = + if is_some ts_opt then ts_opt |> must |> tscheme_to_string + else "" in + U.format4 "sub_effect %s ~> %s : lift = %s ;; lift_wp = %s" + (lid_to_string se.source) (lid_to_string se.target) + (tsopt_to_string se.lift) (tsopt_to_string se.lift_wp) + +instance showable_sub_eff = { show = sub_eff_to_string; } + +instance pretty_term = { pp = term_to_doc; } +instance pretty_univ = { pp = univ_to_doc; } +instance pretty_sigelt = { pp = sigelt_to_doc; } +instance pretty_comp = { pp = comp_to_doc; } +instance pretty_ctxu = { pp = (fun x -> Pprint.doc_of_string (show x)); } +instance pretty_uvar = { pp = (fun x -> Pprint.doc_of_string (show x)); } +instance pretty_binder = { pp = (fun x -> Pprint.doc_of_string (show x)); } +instance pretty_bv = { pp = (fun x -> Pprint.doc_of_string (show x)); } + +open FStarC.Pprint + +instance pretty_binding : pretty binding = { + pp = (function Binding_var bv -> pp bv + | Binding_lid (l, (us, t)) -> pp l ^^ colon ^^ pp t + | Binding_univ u -> pp u); +} + +let rec sigelt_to_string_short (x: sigelt) = match x.sigel with + | Sig_pragma p -> + show p + + | Sig_let {lbs=(false, [{lbname=lb}])} -> + U.format1 "let %s" (lbname_to_string lb) + + | Sig_let {lbs=(true, [{lbname=lb}])} -> + U.format1 "let rec %s" (lbname_to_string lb) + + | Sig_let {lbs=(true, lbs)} -> + U.format1 "let rec %s" (String.concat " and " (List.map (fun lb -> lbname_to_string lb.lbname) lbs)) + + | Sig_let _ -> + failwith "Impossible: sigelt_to_string_short, ill-formed let" + + | Sig_declare_typ {lid} -> + U.format1 "val %s" (string_of_lid lid) + + | Sig_inductive_typ {lid} -> + U.format1 "type %s" (string_of_lid lid) + + | Sig_datacon {lid; ty_lid=t_lid} -> + U.format2 "datacon %s for type %s" (string_of_lid lid) (string_of_lid t_lid) + + | Sig_assume {lid} -> + U.format1 "assume %s" (string_of_lid lid) + + | Sig_bundle {ses} -> List.hd ses |> sigelt_to_string_short + + | Sig_fail {ses} -> + U.format1 "[@@expect_failure] %s" (ses |> List.hd |> sigelt_to_string_short) + + | Sig_new_effect ed -> + let kw = + if SU.is_layered ed then "layered_effect" + else if SU.is_dm4f ed then "new_effect_for_free" + else "new_effect" + in + U.format2 "%s { %s ... }" kw (lid_to_string ed.mname) + + | Sig_sub_effect se -> + U.format2 "sub_effect %s ~> %s" (lid_to_string se.source) (lid_to_string se.target) + + | Sig_effect_abbrev {lid=l; bs=tps; comp=c} -> + U.format3 "effect %s %s = %s" (sli l) + (String.concat " " <| List.map show tps) + (show c) + + | Sig_splice {is_typed; lids} -> + U.format3 "%splice%s[%s] (...)" + "%s" // sigh, no escape for format + (if is_typed then "_t" else "") + (String.concat "; " <| List.map Ident.string_of_lid lids) + + | Sig_polymonadic_bind {m_lid=m; n_lid=n; p_lid=p} -> + U.format3 "polymonadic_bind (%s, %s) |> %s" + (Ident.string_of_lid m) (Ident.string_of_lid n) (Ident.string_of_lid p) + + | Sig_polymonadic_subcomp {m_lid=m; n_lid=n} -> + U.format2 "polymonadic_subcomp %s <: %s" (Ident.string_of_lid m) (Ident.string_of_lid n) + +let binder_to_json env b = + let n = JsonStr (bqual_to_string' (nm_to_string b.binder_bv) b.binder_qual) in + let t = JsonStr (term_to_string' env b.binder_bv.sort) in + JsonAssoc [("name", n); ("type", t)] + +let binders_to_json env bs = + JsonList (List.map (binder_to_json env) bs) + +let eff_decl_to_string ed = + if Options.ugly () + then Ugly.eff_decl_to_string ed + else Pretty.eff_decl_to_string ed + +instance showable_eff_decl = { show = eff_decl_to_string; } + +let args_to_string (args:Syntax.args) : string = + String.concat " " <| + List.map (fun (a, q) -> + aqual_to_string q ^ term_to_string a) args + +instance showable_decreases_order = { + show = (function + | Decreases_lex l -> "Decreases_lex " ^ show l + | Decreases_wf l -> "Decreases_wf " ^ show l); +} + +let cflag_to_string (c:cflag) : string = + match c with + | TOTAL -> "total" + | MLEFFECT -> "ml" + | RETURN -> "return" + | PARTIAL_RETURN -> "partial_return" + | SOMETRIVIAL -> "sometrivial" + | TRIVIAL_POSTCONDITION -> "trivial_postcondition" + | SHOULD_NOT_INLINE -> "should_not_inline" + | LEMMA -> "lemma" + | CPS -> "cps" + | DECREASES do -> "decreases " ^ show do + +instance showable_cflag = { show = cflag_to_string; } + +let binder_to_string_with_type b = + if Options.ugly () then + let attrs = + match b.binder_attrs with + | [] -> "" + | ts -> "[@@@" ^ (String.concat ", " (List.map show ts)) ^ "] " + in + if is_null_binder b + then attrs ^ "_:" ^ term_to_string b.binder_bv.sort + else bqual_to_string' (attrs ^ nm_to_string b.binder_bv ^ ": " ^ term_to_string b.binder_bv.sort) b.binder_qual + else + Pretty.binder_to_string' false b diff --git a/src/syntax/print/FStarC.Syntax.Print.fsti b/src/syntax/print/FStarC.Syntax.Print.fsti new file mode 100644 index 00000000000..903d9142531 --- /dev/null +++ b/src/syntax/print/FStarC.Syntax.Print.fsti @@ -0,0 +1,91 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Syntax.Print + +open FStarC +open FStarC.Compiler.Effect +open FStarC.Syntax.Syntax +open FStarC.Class.Show +open FStarC.Class.PP + +module DsEnv = FStarC.Syntax.DsEnv +module Json = FStarC.Json + +(* Use the instances if possible! *) + +instance val showable_term : showable term +instance val showable_univ : showable universe +instance val showable_comp : showable comp +instance val showable_sigelt : showable sigelt +instance val showable_bv : showable bv +instance val showable_fv : showable fv +instance val showable_binder : showable binder +instance val showable_uvar : showable uvar +instance val showable_ctxu : showable ctx_uvar +instance val showable_binding : showable binding +instance val showable_subst_elt : showable subst_elt +instance val showable_branch : showable branch +instance val showable_aqual : showable aqual +instance val showable_qualifier : showable qualifier +instance val showable_pat : showable pat +instance val showable_const : showable sconst +instance val showable_letbinding : showable letbinding +instance val showable_modul : showable modul +instance val showable_ctx_uvar_meta : showable ctx_uvar_meta_t +instance val showable_metadata : showable metadata +instance val showable_decreases_order : showable decreases_order +instance val showable_cflag : showable cflag +instance val showable_sub_eff : showable sub_eff +instance val showable_eff_decl : showable eff_decl + +instance val pretty_term : pretty term +instance val pretty_univ : pretty universe +instance val pretty_comp : pretty comp +instance val pretty_sigelt : pretty sigelt +instance val pretty_uvar : pretty uvar +instance val pretty_ctxu : pretty ctx_uvar +instance val pretty_binder : pretty binder +instance val pretty_bv : pretty bv +instance val pretty_binding : pretty binding + +(* A "short" version of printing a sigelt. Meant to (usually) be a small string +suitable to embed in an error message. No need to be fully faithful to +printing universes, etc, it should just make it clear enough to which +sigelt it refers to. *) +val sigelt_to_string_short: sigelt -> string + +(* These versions take in a DsEnv to abbreviate names. *) +val term_to_string' : DsEnv.env -> term -> string +val comp_to_string' : DsEnv.env -> comp -> string +val sigelt_to_string' : DsEnv.env -> sigelt -> string +val term_to_doc' : DsEnv.env -> term -> Pprint.document +val comp_to_doc' : DsEnv.env -> comp -> Pprint.document +val sigelt_to_doc' : DsEnv.env -> sigelt -> Pprint.document + +(* Prints as ty instead of a pair. *) +val tscheme_to_string : tscheme -> string + +(* Prints sugar, 'Implicit _' prints as '#', etc *) +val bqual_to_string : bqual -> string + +(* Prints arguments as they show up in the source, useful +for error messages. *) +val args_to_string : args -> string + +(* This should really go elsewhere. *) +val binders_to_json : DsEnv.env -> binders -> Json.json + +val binder_to_string_with_type : binder -> string diff --git a/src/tactics/FStar.Tactics.Common.fst b/src/tactics/FStar.Tactics.Common.fst deleted file mode 100644 index 41e60406a38..00000000000 --- a/src/tactics/FStar.Tactics.Common.fst +++ /dev/null @@ -1,15 +0,0 @@ -module FStar.Tactics.Common - -(* NOTE: This file is exactly the same as its .fs/.fsi counterpart. -It is only here so the equally-named interface file in ulib/ is not -taken by the dependency analysis to be the interface of the .fs. We also -cannot ditch the .fs, since out bootstrapping process does not extract -any .ml file from an interface. Hence we keep both, exactly equal to -each other. *) - -open FStar.Syntax.Syntax - -exception NotAListLiteral -exception TacticFailure of FStar.Errors.Msg.error_message & option FStar.Compiler.Range.range -exception EExn of term -exception SKIP (* used by ctrl_rewrite *) diff --git a/src/tactics/FStar.Tactics.Common.fsti b/src/tactics/FStar.Tactics.Common.fsti deleted file mode 100644 index 41e60406a38..00000000000 --- a/src/tactics/FStar.Tactics.Common.fsti +++ /dev/null @@ -1,15 +0,0 @@ -module FStar.Tactics.Common - -(* NOTE: This file is exactly the same as its .fs/.fsi counterpart. -It is only here so the equally-named interface file in ulib/ is not -taken by the dependency analysis to be the interface of the .fs. We also -cannot ditch the .fs, since out bootstrapping process does not extract -any .ml file from an interface. Hence we keep both, exactly equal to -each other. *) - -open FStar.Syntax.Syntax - -exception NotAListLiteral -exception TacticFailure of FStar.Errors.Msg.error_message & option FStar.Compiler.Range.range -exception EExn of term -exception SKIP (* used by ctrl_rewrite *) diff --git a/src/tactics/FStar.Tactics.CtrlRewrite.fst b/src/tactics/FStar.Tactics.CtrlRewrite.fst deleted file mode 100644 index 2369893b4f0..00000000000 --- a/src/tactics/FStar.Tactics.CtrlRewrite.fst +++ /dev/null @@ -1,457 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Tactics.CtrlRewrite - -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Compiler -open FStar.Compiler.Util -open FStar.Reflection.V2.Data -open FStar.Reflection.V2.Builtins -open FStar.Tactics.Result -open FStar.TypeChecker.Common -open FStar.TypeChecker.Env -open FStar.Tactics.Types -open FStar.Tactics.Monad -open FStar.Tactics.Common -open FStar.Syntax.Syntax -open FStar.Class.Show -open FStar.Class.Monad - -module Print = FStar.Syntax.Print -module BU = FStar.Compiler.Util -module S = FStar.Syntax.Syntax -module U = FStar.Syntax.Util -module SS = FStar.Syntax.Subst -module Z = FStar.BigInt -module Env = FStar.TypeChecker.Env -module TcComm = FStar.TypeChecker.Common -module N = FStar.TypeChecker.Normalize -module Const = FStar.Const -module Errors = FStar.Errors - -let rangeof g = g.goal_ctx_uvar.ctx_uvar_range - -let __do_rewrite - (g0:goal) - (rewriter : rewriter_ty) - (env : env) - (tm : term) - : tac term -= - (* - * We skip certain terms. In particular if the term is a constant - * which must have an argument (reify, reflect, range_of, - * set_range_of), since typechecking will then fail, and the tactic - * will also not be able to do anything useful. Morally, `reify` is - * not a term, so it's fine to skip it. - * - * This is not perfect since if we have any other node wrapping the - * `reify` (metadata?) this will still fail. But I don't think that - * ever happens currently. - *) - let should_skip = - match (SS.compress tm).n with - | S.Tm_constant (Const.Const_reify _) - | S.Tm_constant (Const.Const_reflect _) - | S.Tm_constant Const.Const_range_of - | S.Tm_constant Const.Const_set_range_of -> - true - | _ -> false - in - if should_skip then return tm else begin - - (* It's important to keep the original term if we want to do - * nothing, (hence the underscore below) since after the call to - * the typechecker, t can be elaborated and have more structure. In - * particular, it can be abscribed and hence CONTAIN t AS A SUBTERM! - * Which would cause an infinite loop between this function and - * ctrl_fold_env. - * - * If we got an error about a layered effect missing an annotation, - * we just skip the term, for reasons similar to unapplied constants - * above. Other exceptions are re-raised. - *) - let res = - try - Errors.with_ctx "While typechecking a subterm for ctrl_rewrite" (fun () -> - (* NS: Should we use Core here? *) - - Some (env.tc_term ({ env with admit = true }) tm)) - with - | Errors.Error (Errors.Error_LayeredMissingAnnot, _, _, _) -> None - | e -> raise e - in - match res with - | None -> return tm - | Some (_, lcomp, g) -> - - if not (TcComm.is_pure_or_ghost_lcomp lcomp) then - return tm (* SHOULD THIS CHECK BE IN maybe_rewrite INSTEAD? *) - else - let g = FStar.TypeChecker.Rel.solve_deferred_constraints env g in - let typ = lcomp.res_typ in - - (* unrefine typ as is done for the type arg of eq2 *) - let typ = - if Options.Ext.get "__unrefine" <> "" then - let typ_norm = N.unfold_whnf' [Env.DontUnfoldAttr [Parser.Const.do_not_unrefine_attr]] env typ in - if Tm_refine? (SS.compress typ_norm).n then - (* It is indeed a refinement, normalize again to remove them. *) - let typ' = N.unfold_whnf' [Env.DontUnfoldAttr [Parser.Const.do_not_unrefine_attr]; Env.Unrefine] env typ_norm in - typ' - else - typ - else - typ - in - - let should_check = - if FStar.TypeChecker.Common.is_total_lcomp lcomp - then None - else Some (Allow_ghost "do_rewrite.lhs") - in - let! ut, uvar_t = - new_uvar "do_rewrite.rhs" env typ - should_check - (goal_typedness_deps g0) - (rangeof g0) - in - if_verbose (fun () -> - BU.print2 "do_rewrite: making equality\n\t%s ==\n\t%s\n" - (show tm) (show ut)) ;! - add_irrelevant_goal - g0 - "do_rewrite.eq" - env - (U.mk_eq2 (env.universe_of env typ) typ tm ut) - None ;! - (* v1 and v2 match *) - focus rewriter ;! - // Try to get rid of all the unification lambdas - let ut = N.reduce_uvar_solutions env ut in - if_verbose (fun () -> - BU.print2 "rewrite_rec: succeeded rewriting\n\t%s to\n\t%s\n" - (show tm) - (show ut)) ;! - return ut - end - -(* If __do_rewrite fails with the SKIP exception we do nothing *) -let do_rewrite - (g0:goal) - (rewriter : rewriter_ty) - (env : env) - (tm : term) - : tac term - = match! catch (__do_rewrite g0 rewriter env tm) with - | Inl SKIP -> return tm - | Inl e -> traise e - | Inr tm' -> return tm' - -type ctac 'a = 'a -> tac ('a & ctrl_flag) - -(* Transform a value x with c1, and continue with c2 if needed *) -let seq_ctac (c1 : ctac 'a) (c2 : ctac 'a) - : ctac 'a - = fun (x:'a) -> - let! x', flag = c1 x in - match flag with - | Abort -> return (x', Abort) - | Skip -> return (x', Skip) - | Continue -> c2 x' - -let par_combine = function - | Abort, _ - | _, Abort -> Abort - | Skip, _ - | _, Skip -> Skip - | Continue, Continue -> Continue - -(* Transform a value (x, y) with cl and cr respectively. - * Skip on x will still run c2 on y, but Abort will abort. *) -let par_ctac (cl : ctac 'a) (cr : ctac 'b) - : ctac ('a & 'b) - = fun (x, y) -> - let! x, flag = cl x in - match flag with - | Abort -> return ((x, y), Abort) - | fa -> - let! y, flag = cr y in - match flag with - | Abort -> return ((x, y),Abort) - | fb -> - return ((x, y), par_combine (fa, fb)) - -let rec map_ctac (c : ctac 'a) - : ctac (list 'a) - = fun xs -> - match xs with - | [] -> return ([], Continue) - | x::xs -> - let! ((x, xs), flag) = par_ctac c (map_ctac c) (x, xs) in - return (x::xs, flag) - -(* let bind_ctac *) -(* (t : ctac 'a) *) -(* (f : 'a -> ctac 'b) *) -(* : ctac 'b *) -(* = fun b -> failwith "" *) - -let ctac_id : #a:Type -> ctac a = - fun #a (x:a) -> return (x, Continue) - -let ctac_args (c : ctac term) : ctac args = - map_ctac (par_ctac c (ctac_id #_)) - -let maybe_rewrite - (g0 : goal) - (controller : controller_ty) - (rewriter : rewriter_ty) - (env : env) - (tm : term) - : tac (term & ctrl_flag) - = let! (rw, ctrl_flag) = controller tm in - let! tm' = - if rw - then do_rewrite g0 rewriter env tm - else return tm - in - return (tm', ctrl_flag) - -let rec ctrl_fold_env - (g0 : goal) - (d : direction) - (controller : controller_ty) - (rewriter : rewriter_ty) - (env : env) - (tm : term) - : tac (term & ctrl_flag) - = let recurse tm = - ctrl_fold_env g0 d controller rewriter env tm - in - match d with - | TopDown -> - seq_ctac (maybe_rewrite g0 controller rewriter env) - (on_subterms g0 d controller rewriter env) tm - - | BottomUp -> - seq_ctac (on_subterms g0 d controller rewriter env) - (maybe_rewrite g0 controller rewriter env) tm - -and recurse_option_residual_comp (env:env) (retyping_subst:list subst_elt) (rc_opt:option residual_comp) recurse - : tac (option residual_comp & ctrl_flag) - = // return (None, Continue) - match rc_opt with - | None -> return (None, Continue) - | Some rc -> - match rc.residual_typ with - | None -> return (Some rc, Continue) - | Some t -> - let t = SS.subst retyping_subst t in - let! t, flag = recurse env t in - return (Some ({rc with residual_typ=Some t}), flag) - -and on_subterms - (g0 : goal) - (d : direction) - (controller : controller_ty) - (rewriter : rewriter_ty) - (env : env) - (tm : term) - : tac (term & ctrl_flag) - = let recurse env tm = ctrl_fold_env g0 d controller rewriter env tm in - let rr = recurse env in (* recurse on current env *) - - // - // t is the body and k is the option residual comp - // - // Note, the type of the binder sorts may change as we rewrite them - // The retyping_subst is an identity substitution that replaces the bound vars - // in the term with their new variants tagged with the rewritten bv sorts - // - let rec descend_binders orig accum_binders retyping_subst accum_flag env bs t k rebuild = - match bs with - | [] -> - let t = SS.subst retyping_subst t in - let! t, t_flag = recurse env t in - begin - match t_flag with - | Abort -> return (orig.n, t_flag) //if anything aborts, just return the original abs - | _ -> - let! k, k_flag = recurse_option_residual_comp env retyping_subst k recurse in - let bs = List.rev accum_binders in - let subst = SS.closing_of_binders bs in - // For dependent binders, we need to re-compute the substitution incrementally; applying subst to bs doesn't work - let bs = SS.close_binders bs in - let t = SS.subst subst t in - let k = BU.map_option (SS.subst_residual_comp subst) k in - return (rebuild bs t k, - par_combine (accum_flag, (par_combine (t_flag, k_flag)))) - end - - | b::bs -> - let s = SS.subst retyping_subst b.binder_bv.sort in - let! s, flag = recurse env s in - match flag with - | Abort -> return (orig.n, flag) //if anything aborts, just return the original abs - | _ -> - let bv = {b.binder_bv with sort = s} in - let b = {b with binder_bv = bv} in - let env = Env.push_binders env [b] in - let retyping_subst = NT(bv, bv_to_name bv) :: retyping_subst in - descend_binders orig (b::accum_binders) retyping_subst (par_combine (accum_flag, flag)) env bs t k rebuild - in - let go () : tac (term' & ctrl_flag) = - let tm = SS.compress tm in - match tm.n with - (* Run on hd and args in parallel *) - | Tm_app {hd; args} -> - let! ((hd, args), flag) = par_ctac rr (ctac_args rr) (hd, args) in - return (Tm_app {hd; args}, flag) - - (* Open, descend, rebuild *) - | Tm_abs {bs; body=t; rc_opt=k} -> - let bs_orig, t, subst = SS.open_term' bs t in - let k = k |> BU.map_option (SS.subst_residual_comp subst) in - descend_binders tm [] [] Continue env bs_orig t k - (fun bs t k -> Tm_abs {bs; body=t; rc_opt=k}) - - | Tm_refine {b=x; phi} -> - let bs, phi = SS.open_term [S.mk_binder x] phi in - descend_binders tm [] [] Continue env bs phi None //no residual comp - (fun bs phi _ -> - let x = - match bs with - | [x] -> x.binder_bv - | _ -> failwith "Impossible" - in - Tm_refine {b=x; phi}) - - | Tm_arrow { bs = bs; comp = comp } -> - (match comp.n with - | Total t -> - let bs_orig, t = SS.open_term bs t in - descend_binders tm [] [] Continue env bs_orig t None - (fun bs t _ -> Tm_arrow {bs; comp = {comp with n = Total t}}) - | GTotal t -> - let bs_orig, t = SS.open_term bs t in - descend_binders tm [] [] Continue env bs_orig t None - (fun bs t _ -> Tm_arrow {bs; comp = {comp with n = GTotal t}}) - | _ -> - (* Do nothing (FIXME). - What should we do for effectful computations? *) - return (tm.n, Continue)) - - (* Descend on head and branches in parallel. Branches - * are opened with their contexts extended. Ignore the when clause, - * and do not go into patterns. - * also ignoring the return annotations *) - | Tm_match {scrutinee=hd; ret_opt=asc_opt; brs; rc_opt=lopt} -> - let c_branch (br:S.branch) : tac (S.branch & ctrl_flag) = - let (pat, w, e) = SS.open_branch br in - let bvs = S.pat_bvs pat in - let! e, flag = recurse (Env.push_bvs env bvs) e in - let br = SS.close_branch (pat, w, e) in - return (br, flag) - in - let! ((hd, brs), flag) = par_ctac rr (map_ctac c_branch) (hd, brs) in - return (Tm_match {scrutinee=hd; ret_opt=asc_opt; brs; rc_opt=lopt}, flag) - - (* Descend, in parallel, in the definiens and the body, where - * the body is extended with the bv. Do not go into the type. *) - | Tm_let {lbs=(false, [{ lbname = Inl bv; lbdef = def }]); body=e} -> - (* ugh *) - let lb = match (SS.compress tm).n with - | Tm_let {lbs=(false, [lb])} -> lb - | _ -> failwith "impossible" - in - let bv, e = SS.open_term_bv bv e in - let! ((lbdef, e), flag) = - par_ctac rr (recurse (Env.push_bv env bv)) (lb.lbdef, e) - in - let lb = { lb with lbdef = lbdef } in - let e = SS.close [S.mk_binder bv] e in - return (Tm_let {lbs=(false, [lb]); body=e}, flag) - - (* Descend, in parallel, in *every* definiens and the body. - * Again body is properly opened, and we don't go into types. *) - | Tm_let {lbs=(true, lbs); body=e} -> - let c_lb (lb:S.letbinding) : tac (S.letbinding & ctrl_flag) = - let! (def, flag) = rr lb.lbdef in - return ({lb with lbdef = def }, flag) - in - let lbs, e = SS.open_let_rec lbs e in - (* TODO: the `rr` has to be wrong, we need more binders *) - let! ((lbs, e), flag) = par_ctac (map_ctac c_lb) rr (lbs, e) in - let lbs, e = SS.close_let_rec lbs e in - return (Tm_let {lbs=(true, lbs); body=e}, flag) - - (* Descend into the ascripted term, ignore all else *) - | Tm_ascribed {tm=t; asc; eff_opt=eff} -> - let! t, flag = rr t in - return (Tm_ascribed {tm=t; asc; eff_opt=eff}, flag) - - (* Ditto *) - | Tm_meta {tm=t; meta=m} -> - let! (t, flag) = rr t in - return (Tm_meta {tm=t; meta=m}, flag) - - | _ -> - (* BU.print1 "GG ignoring %s\n" (tag_of tm); *) - return (tm.n, Continue) - in - let! (tmn', flag) = go () in - return ({tm with n = tmn'}, flag) - -let do_ctrl_rewrite - (g0 : goal) - (dir : direction) - (controller : controller_ty) - (rewriter : rewriter_ty) - (env : env) - (tm : term) - : tac term - = let! tm', _ = ctrl_fold_env g0 dir controller rewriter env tm in - return tm' - -let ctrl_rewrite - (dir : direction) - (controller : controller_ty) - (rewriter : rewriter_ty) - : tac unit - = wrap_err "ctrl_rewrite" <| ( - let! ps = get in - let g, gs = match ps.goals with - | g::gs -> g, gs - | [] -> failwith "no goals" - in - dismiss_all ;! - let gt = (goal_type g) in - if_verbose (fun () -> - BU.print1 "ctrl_rewrite starting with %s\n" (show gt)) ;! - - let! gt' = do_ctrl_rewrite g dir controller rewriter (goal_env g) gt in - - if_verbose (fun () -> - BU.print1 "ctrl_rewrite seems to have succeded with %s\n" (show gt')) ;! - - push_goals gs ;! - let g = goal_with_type g gt' in - add_goals [g] - ) diff --git a/src/tactics/FStar.Tactics.CtrlRewrite.fsti b/src/tactics/FStar.Tactics.CtrlRewrite.fsti deleted file mode 100644 index 06cd84d3391..00000000000 --- a/src/tactics/FStar.Tactics.CtrlRewrite.fsti +++ /dev/null @@ -1,29 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Tactics.CtrlRewrite - -open FStar.Tactics.Types -open FStar.Tactics.Monad -open FStar.Syntax.Syntax - -module Z = FStar.BigInt - -(* TODO: allow to pass information from ctrl_tac to rewriter? *) -type controller_ty = term -> tac (bool & ctrl_flag) -type rewriter_ty = tac unit - -val ctrl_rewrite: direction -> controller_ty -> rewriter_ty -> tac unit diff --git a/src/tactics/FStar.Tactics.Embedding.fst b/src/tactics/FStar.Tactics.Embedding.fst deleted file mode 100644 index dab1d8d0b1b..00000000000 --- a/src/tactics/FStar.Tactics.Embedding.fst +++ /dev/null @@ -1,615 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Tactics.Embedding - -open FStar -open FStar.Compiler -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Syntax.Syntax -open FStar.Syntax.Embeddings -open FStar.Compiler.Util -open FStar.Compiler.List -open FStar.Class.Show - -open FStar.Tactics.Common -open FStar.Tactics.Types -open FStar.Tactics.Result - -module BU = FStar.Compiler.Util -module Err = FStar.Errors -module NBE = FStar.TypeChecker.NBE -module NBETerm = FStar.TypeChecker.NBETerm -module NBET = FStar.TypeChecker.NBETerm -module PC = FStar.Parser.Const -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module U = FStar.Syntax.Util - -type name = bv - -let fstar_tactics_lid' s = PC.fstar_tactics_lid' s -let fstar_stubs_tactics_lid' s = PC.fstar_stubs_tactics_lid' s -let lid_as_tm l = S.lid_as_fv l None |> S.fv_to_tm -let mk_tactic_lid_as_term (s:string) = lid_as_tm (fstar_tactics_lid' ["Effect"; s]) - - -type tac_constant = { - lid : Ident.lid; - fv : fv; - t : term; -} - -let lid_as_data_fv l = S.lid_as_fv l (Some Data_ctor) -let lid_as_data_tm l = S.fv_to_tm (lid_as_data_fv l) - -let fstar_tactics_data ns = - let lid = fstar_stubs_tactics_lid' ns in - { lid = lid; - fv = lid_as_data_fv lid; - t = lid_as_data_tm lid } - -let fstar_tactics_const ns = - let lid = fstar_stubs_tactics_lid' ns in - { lid = lid; - fv = S.fvconst lid; - t = S.tconst lid } - -let fstar_tc_core_lid s : lid = - FStar.Ident.lid_of_path (["FStar"; "Stubs"; "TypeChecker"; "Core"]@[s]) Range.dummyRange - -let fstar_tc_core_data s = - let lid = fstar_tc_core_lid s in - { lid = lid; - fv = lid_as_data_fv lid; - t = lid_as_data_tm lid } - -let fstar_tc_core_const s = - let lid = fstar_tc_core_lid s in - { lid = lid; - fv = S.fvconst lid; - t = S.tconst lid } - - -let fstar_tactics_proofstate = fstar_tactics_const ["Types"; "proofstate"] -let fstar_tactics_goal = fstar_tactics_const ["Types"; "goal"] - -let fstar_tactics_TacticFailure = fstar_tactics_data ["Common"; "TacticFailure"] -let fstar_tactics_SKIP = fstar_tactics_data ["Common"; "SKIP"] - -let fstar_tactics_result = fstar_tactics_const ["Result"; "__result"] -let fstar_tactics_Success = fstar_tactics_data ["Result"; "Success"] -let fstar_tactics_Failed = fstar_tactics_data ["Result"; "Failed"] - -let fstar_tactics_direction = fstar_tactics_const ["Types"; "direction"] -let fstar_tactics_topdown = fstar_tactics_data ["Types"; "TopDown"] -let fstar_tactics_bottomup = fstar_tactics_data ["Types"; "BottomUp"] - -let fstar_tactics_ctrl_flag = fstar_tactics_const ["Types"; "ctrl_flag"] -let fstar_tactics_Continue = fstar_tactics_data ["Types"; "Continue"] -let fstar_tactics_Skip = fstar_tactics_data ["Types"; "Skip"] -let fstar_tactics_Abort = fstar_tactics_data ["Types"; "Abort"] - -let fstar_tc_core_unfold_side = fstar_tc_core_const "unfold_side" -let fstar_tc_core_unfold_side_Left = fstar_tc_core_data "Left" -let fstar_tc_core_unfold_side_Right = fstar_tc_core_data "Right" -let fstar_tc_core_unfold_side_Both = fstar_tc_core_data "Both" -let fstar_tc_core_unfold_side_Neither = fstar_tc_core_data "Neither" - -let fstar_tc_core_tot_or_ghost = fstar_tc_core_const "tot_or_ghost" -let fstar_tc_core_tot_or_ghost_ETotal = fstar_tc_core_data "E_Total" -let fstar_tc_core_tot_or_ghost_EGhost = fstar_tc_core_data "E_Ghost" - -let fstar_tactics_guard_policy = fstar_tactics_const ["Types"; "guard_policy"] -let fstar_tactics_SMT = fstar_tactics_data ["Types"; "SMT"] -let fstar_tactics_SMTSync = fstar_tactics_data ["Types"; "SMTSync"] -let fstar_tactics_Goal = fstar_tactics_data ["Types"; "Goal"] -let fstar_tactics_Drop = fstar_tactics_data ["Types"; "Drop"] -let fstar_tactics_Force = fstar_tactics_data ["Types"; "Force"] - - -let mk_emb (em: Range.range -> 'a -> term) - (un: term -> option 'a) - (t: term) = - mk_emb (fun x r _topt _norm -> em r x) - (fun x _norm -> un x) - (FStar.Syntax.Embeddings.term_as_fv t) -let embed {|embedding 'a|} r (x:'a) = FStar.Syntax.Embeddings.embed x r None id_norm_cb -let unembed' {|embedding 'a|} x : option 'a = FStar.Syntax.Embeddings.unembed x id_norm_cb - -let t_result_of t = U.mk_app fstar_tactics_result.t [S.as_arg t] // TODO: uinst on t_result? - -let hd'_and_args tm = - let tm = U.unascribe tm in - let hd, args = U.head_and_args tm in - (U.un_uinst hd).n, args - -instance e_proofstate : embedding proofstate = e_lazy Lazy_proofstate fstar_tactics_proofstate.t -instance e_goal : embedding goal = e_lazy Lazy_goal fstar_tactics_goal.t - -let unfold_lazy_proofstate (i : lazyinfo) : term = - U.exp_string "(((proofstate)))" - -let unfold_lazy_goal (i : lazyinfo) : term = - U.exp_string "(((goal)))" - -(* PLEASE NOTE: Construct and FV accumulate their arguments BACKWARDS. That is, - * the expression (f 1 2) is stored as FV (f, [], [Constant (Int 2); Constant (Int 1)]. - * So be careful when calling mkFV/mkConstruct and matching on them. *) - -(* On that note, we use this (inefficient, FIXME) hack in this module *) -let mkFV fv us ts = NBETerm.mkFV fv (List.rev us) (List.rev ts) -let mkConstruct fv us ts = NBETerm.mkConstruct fv (List.rev us) (List.rev ts) -let fv_as_emb_typ fv = S.ET_app (show fv.fv_name.v, []) - -let e_proofstate_nbe = - let embed_proofstate _cb (ps:proofstate) : NBETerm.t = - let li = { lkind = Lazy_proofstate - ; blob = FStar.Dyn.mkdyn ps - ; ltyp = fstar_tactics_proofstate.t - ; rng = Range.dummyRange } - in - let thunk = Thunk.mk (fun () -> NBETerm.mk_t <| NBETerm.Constant (NBETerm.String ("(((proofstate.nbe)))", Range.dummyRange))) in - NBETerm.mk_t (NBETerm.Lazy (Inl li, thunk)) - in - let unembed_proofstate _cb (t:NBETerm.t) : option proofstate = - match NBETerm.nbe_t_of_t t with - | NBETerm.Lazy (Inl {blob=b; lkind = Lazy_proofstate}, _) -> - Some <| FStar.Dyn.undyn b - | _ -> - if !Options.debug_embedding then - Err.log_issue0 - Err.Warning_NotEmbedded - (BU.format1 "Not an embedded NBE proofstate: %s\n" - (NBETerm.t_to_string t)); - None - in - { NBETerm.em = embed_proofstate - ; NBETerm.un = unembed_proofstate - ; NBETerm.typ = (fun () -> mkFV fstar_tactics_proofstate.fv [] []) - ; NBETerm.e_typ = (fun () -> fv_as_emb_typ fstar_tactics_proofstate.fv) - } - -let e_goal_nbe = - let embed_goal _cb (ps:goal) : NBETerm.t = - let li = { lkind = Lazy_goal - ; blob = FStar.Dyn.mkdyn ps - ; ltyp = fstar_tactics_goal.t - ; rng = Range.dummyRange } - in - let thunk = Thunk.mk (fun () -> NBETerm.mk_t <| NBETerm.Constant (NBETerm.String ("(((goal.nbe)))", Range.dummyRange))) in - NBETerm.mk_t <| NBETerm.Lazy (Inl li, thunk) - in - let unembed_goal _cb (t:NBETerm.t) : option goal = - match NBETerm.nbe_t_of_t t with - | NBETerm.Lazy (Inl {blob=b; lkind = Lazy_goal}, _) -> - Some <| FStar.Dyn.undyn b - | _ -> - if !Options.debug_embedding then - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded NBE goal: %s" (NBETerm.t_to_string t)); - None - in - { NBETerm.em = embed_goal - ; NBETerm.un = unembed_goal - ; NBETerm.typ = (fun () -> mkFV fstar_tactics_goal.fv [] []) - ; NBETerm.e_typ = (fun () -> fv_as_emb_typ fstar_tactics_goal.fv) - } - -instance e_exn : embedding exn = - let embed_exn (e:exn) (rng:Range.range) _ _ : term = - match e with - | TacticFailure s -> - S.mk_Tm_app fstar_tactics_TacticFailure.t - [S.as_arg (embed rng s)] - rng - | SKIP -> - { fstar_tactics_SKIP.t with pos = rng } - - | EExn t -> - { t with pos = rng } - - | e -> - let open FStar.Pprint in - let open FStar.Class.PP in - let open FStar.Errors.Msg in - let msg : error_message = [ - text "Uncaught exception"; - arbitrary_string (BU.message_of_exn e); - ] - in - S.mk_Tm_app fstar_tactics_TacticFailure.t - [S.as_arg (embed rng (msg, None #Range.range))] - rng - in - let unembed_exn (t:term) _ : option exn = - match hd'_and_args t with - | Tm_fvar fv, [(s, _)] when S.fv_eq_lid fv fstar_tactics_TacticFailure.lid -> - BU.bind_opt (unembed' s) (fun s -> - Some (TacticFailure s)) - - | Tm_fvar fv, [] when S.fv_eq_lid fv fstar_tactics_SKIP.lid -> - Some SKIP - - | _ -> - (* Anything else, we just pass-through *) - Some (EExn t) - in - mk_emb_full - embed_exn - unembed_exn - (fun () -> t_exn) - (fun _ -> "(exn)") - (fun () -> ET_app (show PC.exn_lid, [])) - -let e_exn_nbe = - let embed_exn cb (e:exn) : NBET.t = - match e with - | TacticFailure s -> - mkConstruct fstar_tactics_TacticFailure.fv - [] - [ NBETerm.as_arg (NBETerm.embed FStar.Tactics.Typeclasses.solve cb s) ] - - | SKIP -> - mkConstruct fstar_tactics_SKIP.fv [] [] - - | _ -> - failwith (BU.format1 "cannot embed exn (NBE) : %s" (BU.message_of_exn e)) - in - let unembed_exn cb (t:NBET.t) : option exn = - match NBETerm.nbe_t_of_t t with - | NBETerm.Construct (fv, _, [(s, _)]) when S.fv_eq_lid fv fstar_tactics_TacticFailure.lid -> - BU.bind_opt (NBETerm.unembed FStar.Tactics.Typeclasses.solve cb s) (fun s -> - Some (TacticFailure s)) - - | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tactics_SKIP.lid -> - Some SKIP - - | _ -> - None - in - let fv_exn = S.fvconst PC.exn_lid in - { NBETerm.em = embed_exn - ; NBETerm.un = unembed_exn - ; NBETerm.typ = (fun () -> mkFV fv_exn [] []) - ; NBETerm.e_typ = (fun () -> fv_as_emb_typ fv_exn) } - -let e_result (ea : embedding 'a) : Tot _ = - let embed_result (res:__result 'a) (rng:Range.range) (sh:shadow_term) (cbs:norm_cb) : term = - match res with - | Success (a, ps) -> - S.mk_Tm_app (S.mk_Tm_uinst fstar_tactics_Success.t [U_zero]) - [S.iarg (type_of ea); - S.as_arg (embed rng a); - S.as_arg (embed rng ps)] - rng - | Failed (e, ps) -> - S.mk_Tm_app (S.mk_Tm_uinst fstar_tactics_Failed.t [U_zero]) - [S.iarg (type_of ea); - S.as_arg (embed rng e); - S.as_arg (embed rng ps)] - rng - in - let unembed_result (t:term) _ : option (__result 'a) = - match hd'_and_args t with - | Tm_fvar fv, [_t; (a, _); (ps, _)] when S.fv_eq_lid fv fstar_tactics_Success.lid -> - BU.bind_opt (unembed' a) (fun a -> - BU.bind_opt (unembed' ps) (fun ps -> - Some (Success (a, ps)))) - - | Tm_fvar fv, [_t; (e, _); (ps, _)] when S.fv_eq_lid fv fstar_tactics_Failed.lid -> - BU.bind_opt (unembed' e) (fun e -> - BU.bind_opt (unembed' ps) (fun ps -> - Some (Failed (e, ps)))) - - | _ -> None - in - mk_emb_full #(__result 'a) - embed_result - unembed_result - (fun () -> t_result_of (type_of ea)) - (fun _ -> "") - (fun () -> ET_app (show fstar_tactics_result.lid, [emb_typ_of 'a ()])) - -let e_result_nbe (ea : NBET.embedding 'a) = - let embed_result cb (res:__result 'a) : NBET.t = - match res with - | Failed (e, ps) -> - mkConstruct fstar_tactics_Failed.fv - [U_zero] - [ NBETerm.as_iarg (NBETerm.type_of ea) - ; NBETerm.as_arg (NBETerm.embed e_exn_nbe cb e) - ; NBETerm.as_arg (NBETerm.embed e_proofstate_nbe cb ps) ] - | Success (a, ps) -> - mkConstruct fstar_tactics_Success.fv - [U_zero] - [ NBETerm.as_iarg (NBETerm.type_of ea) - ; NBETerm.as_arg (NBETerm.embed ea cb a) - ; NBETerm.as_arg (NBETerm.embed e_proofstate_nbe cb ps) ] - in - let unembed_result cb (t:NBET.t) : option (__result 'a) = - match NBETerm.nbe_t_of_t t with - | NBETerm.Construct (fv, _, [(ps, _); (a, _); _t]) when S.fv_eq_lid fv fstar_tactics_Success.lid -> - BU.bind_opt (NBETerm.unembed ea cb a) (fun a -> - BU.bind_opt (NBETerm.unembed e_proofstate_nbe cb ps) (fun ps -> - Some (Success (a, ps)))) - - | NBETerm.Construct (fv, _, [(ps, _); (e, _); _t]) when S.fv_eq_lid fv fstar_tactics_Failed.lid -> - BU.bind_opt (NBETerm.unembed e_exn_nbe cb e) (fun e -> - BU.bind_opt (NBETerm.unembed e_proofstate_nbe cb ps) (fun ps -> - Some (Failed (e, ps)))) - | _ -> - None - in - { NBETerm.em = embed_result - ; NBETerm.un = unembed_result - ; NBETerm.typ = (fun () -> mkFV fstar_tactics_result.fv [] []) - ; NBETerm.e_typ = (fun () -> fv_as_emb_typ fstar_tactics_result.fv) } - -let e_direction = - let embed_direction (rng:Range.range) (d : direction) : term = - match d with - | TopDown -> fstar_tactics_topdown.t - | BottomUp -> fstar_tactics_bottomup.t - in - let unembed_direction (t : term) : option direction = - match (SS.compress t).n with - | Tm_fvar fv when S.fv_eq_lid fv fstar_tactics_topdown.lid -> Some TopDown - | Tm_fvar fv when S.fv_eq_lid fv fstar_tactics_bottomup.lid -> Some BottomUp - | _ -> None - in - mk_emb embed_direction unembed_direction fstar_tactics_direction.t - -let e_direction_nbe = - let embed_direction cb (res:direction) : NBET.t = - match res with - | TopDown -> mkConstruct fstar_tactics_topdown.fv [] [] - | BottomUp -> mkConstruct fstar_tactics_bottomup.fv [] [] - in - let unembed_direction cb (t:NBET.t) : option direction = - match NBETerm.nbe_t_of_t t with - | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tactics_topdown.lid -> Some TopDown - | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tactics_bottomup.lid -> Some BottomUp - | _ -> - if !Options.debug_embedding then - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded direction: %s" (NBETerm.t_to_string t)); - None - in - { NBETerm.em = embed_direction - ; NBETerm.un = unembed_direction - ; NBETerm.typ = (fun () ->mkFV fstar_tactics_direction.fv [] []) - ; NBETerm.e_typ = (fun () -> fv_as_emb_typ fstar_tactics_direction.fv) } - -let e_ctrl_flag = - let embed_ctrl_flag (rng:Range.range) (d : ctrl_flag) : term = - match d with - | Continue -> fstar_tactics_Continue.t - | Skip -> fstar_tactics_Skip.t - | Abort -> fstar_tactics_Abort.t - in - let unembed_ctrl_flag (t : term) : option ctrl_flag = - match (SS.compress t).n with - | Tm_fvar fv when S.fv_eq_lid fv fstar_tactics_Continue.lid -> Some Continue - | Tm_fvar fv when S.fv_eq_lid fv fstar_tactics_Skip.lid -> Some Skip - | Tm_fvar fv when S.fv_eq_lid fv fstar_tactics_Abort.lid -> Some Abort - | _ -> None - in - mk_emb embed_ctrl_flag unembed_ctrl_flag fstar_tactics_ctrl_flag.t - -let e_ctrl_flag_nbe = - let embed_ctrl_flag cb (res:ctrl_flag) : NBET.t = - match res with - | Continue -> mkConstruct fstar_tactics_Continue.fv [] [] - | Skip -> mkConstruct fstar_tactics_Skip.fv [] [] - | Abort -> mkConstruct fstar_tactics_Abort.fv [] [] - in - let unembed_ctrl_flag cb (t:NBET.t) : option ctrl_flag = - match NBETerm.nbe_t_of_t t with - | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tactics_Continue.lid -> Some Continue - | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tactics_Skip.lid -> Some Skip - | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tactics_Abort.lid -> Some Abort - | _ -> - if !Options.debug_embedding then - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded ctrl_flag: %s" (NBETerm.t_to_string t)); - None - in - { NBETerm.em = embed_ctrl_flag - ; NBETerm.un = unembed_ctrl_flag - ; NBETerm.typ = (fun () -> mkFV fstar_tactics_ctrl_flag.fv [] []) - ; NBETerm.e_typ = (fun () -> fv_as_emb_typ fstar_tactics_ctrl_flag.fv) } - -let e_unfold_side = - let open FStar.TypeChecker.Core in - let embed_unfold_side (rng:Range.range) (s:side) : term = - match s with - | Left -> fstar_tc_core_unfold_side_Left.t - | Right -> fstar_tc_core_unfold_side_Right.t - | Both -> fstar_tc_core_unfold_side_Both.t - | Neither -> fstar_tc_core_unfold_side_Neither.t - in - let unembed_unfold_side (t : term) : option side = - match (SS.compress t).n with - | Tm_fvar fv when S.fv_eq_lid fv fstar_tc_core_unfold_side_Left.lid -> Some Left - | Tm_fvar fv when S.fv_eq_lid fv fstar_tc_core_unfold_side_Right.lid -> Some Right - | Tm_fvar fv when S.fv_eq_lid fv fstar_tc_core_unfold_side_Both.lid -> Some Both - | Tm_fvar fv when S.fv_eq_lid fv fstar_tc_core_unfold_side_Neither.lid -> Some Neither - | _ -> - None - in - mk_emb embed_unfold_side unembed_unfold_side fstar_tc_core_unfold_side.t - -let e_unfold_side_nbe = - let open FStar.TypeChecker.Core in - let embed_unfold_side cb (res:side) : NBET.t = - match res with - | Left -> mkConstruct fstar_tc_core_unfold_side_Left.fv [] [] - | Right -> mkConstruct fstar_tc_core_unfold_side_Right.fv [] [] - | Both -> mkConstruct fstar_tc_core_unfold_side_Both.fv [] [] - | Neither -> mkConstruct fstar_tc_core_unfold_side_Neither.fv [] [] - in - let unembed_unfold_side cb (t:NBET.t) : option side = - match NBETerm.nbe_t_of_t t with - | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tc_core_unfold_side_Left.lid -> - Some Left - | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tc_core_unfold_side_Right.lid -> - Some Right - | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tc_core_unfold_side_Both.lid -> - Some Both - | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tc_core_unfold_side_Neither.lid -> - Some Neither - | _ -> - if !Options.debug_embedding then - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded unfold_side: %s" (NBETerm.t_to_string t)); - None - in - { NBETerm.em = embed_unfold_side - ; NBETerm.un = unembed_unfold_side - ; NBETerm.typ = (fun () -> mkFV fstar_tc_core_unfold_side.fv [] []) - ; NBETerm.e_typ = (fun () -> fv_as_emb_typ fstar_tc_core_unfold_side.fv) } - -let e_tot_or_ghost = - let open FStar.TypeChecker.Core in - let embed_tot_or_ghost (rng:Range.range) (s:tot_or_ghost) : term = - match s with - | E_Total -> fstar_tc_core_tot_or_ghost_ETotal.t - | E_Ghost -> fstar_tc_core_tot_or_ghost_EGhost.t - in - let unembed_tot_or_ghost (t : term) : option tot_or_ghost = - match (SS.compress t).n with - | Tm_fvar fv when S.fv_eq_lid fv fstar_tc_core_tot_or_ghost_ETotal.lid -> - Some E_Total - | Tm_fvar fv when S.fv_eq_lid fv fstar_tc_core_tot_or_ghost_EGhost.lid -> - Some E_Ghost - | _ -> None - in - mk_emb embed_tot_or_ghost unembed_tot_or_ghost fstar_tc_core_tot_or_ghost.t - -let e_tot_or_ghost_nbe = - let open FStar.TypeChecker.Core in - let embed_tot_or_ghost cb (res:tot_or_ghost) : NBET.t = - match res with - | E_Total -> mkConstruct fstar_tc_core_tot_or_ghost_ETotal.fv [] [] - | E_Ghost -> mkConstruct fstar_tc_core_tot_or_ghost_EGhost.fv [] [] - in - let unembed_tot_or_ghost cb (t:NBET.t) : option tot_or_ghost = - match NBETerm.nbe_t_of_t t with - | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tc_core_tot_or_ghost_ETotal.lid -> - Some E_Total - | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tc_core_tot_or_ghost_EGhost.lid -> - Some E_Ghost - | _ -> - if !Options.debug_embedding then - Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded tot_or_ghost: %s" (NBETerm.t_to_string t)); - None - in - { NBETerm.em = embed_tot_or_ghost - ; NBETerm.un = unembed_tot_or_ghost - ; NBETerm.typ = (fun () -> mkFV fstar_tc_core_tot_or_ghost.fv [] []) - ; NBETerm.e_typ = (fun () -> fv_as_emb_typ fstar_tc_core_tot_or_ghost.fv) } - -let t_tref = S.lid_as_fv PC.tref_lid None - |> S.fv_to_tm - |> (fun tm -> S.mk_Tm_uinst tm [U_zero]) - |> (fun head -> S.mk_Tm_app head [S.iarg S.t_term] Range.dummyRange) - -let e_tref #a = - let em (r:tref a) (rng:Range.range) _shadow _norm : term = - U.mk_lazy r t_tref Lazy_tref (Some rng) - in - let un (t:term) _ : option (tref a) = - match (SS.compress t).n with - | Tm_lazy { lkind = Lazy_tref; blob } -> Some (Dyn.undyn blob) - | _ -> None - in - mk_emb_full - em - un - (fun () -> t_tref) - (fun i -> "tref") - (fun () -> ET_app (PC.tref_lid |> Ident.string_of_lid, [ET_abstract])) - -let e_tref_nbe #a = - let embed_tref _cb (r:tref a) : NBETerm.t = - let li = { lkind = Lazy_tref - ; blob = FStar.Dyn.mkdyn r - ; ltyp = t_tref - ; rng = Range.dummyRange } - in - let thunk = Thunk.mk (fun () -> NBETerm.mk_t <| NBETerm.Constant (NBETerm.String ("(((tref.nbe)))", Range.dummyRange))) in - NBETerm.mk_t (NBETerm.Lazy (Inl li, thunk)) - in - let unembed_tref _cb (t:NBETerm.t) : option (tref a) = - match NBETerm.nbe_t_of_t t with - | NBETerm.Lazy (Inl {blob=b; lkind = Lazy_tref}, _) -> - Some <| FStar.Dyn.undyn b - | _ -> - if !Options.debug_embedding then - Err.log_issue0 - Err.Warning_NotEmbedded - (BU.format1 "Not an embedded NBE tref: %s\n" - (NBETerm.t_to_string t)); - None - in - { NBETerm.em = embed_tref - ; NBETerm.un = unembed_tref - ; NBETerm.typ = - (fun () -> - let term_t = mkFV (S.lid_as_fv PC.fstar_syntax_syntax_term None) [] [] in - mkFV (S.lid_as_fv PC.tref_lid None) [U_zero] [NBETerm.as_arg term_t]) - ; NBETerm.e_typ = (fun () -> ET_app (PC.tref_lid |> Ident.string_of_lid, [ET_abstract])) } - -let e_guard_policy = - let embed_guard_policy (rng:Range.range) (p : guard_policy) : term = - match p with - | SMT -> fstar_tactics_SMT.t - | SMTSync -> fstar_tactics_SMTSync.t - | Goal -> fstar_tactics_Goal.t - | Force -> fstar_tactics_Force.t - | Drop -> fstar_tactics_Drop.t - in - let unembed_guard_policy (t : term) : option guard_policy = - match (SS.compress t).n with - | Tm_fvar fv when S.fv_eq_lid fv fstar_tactics_SMT.lid -> Some SMT - | Tm_fvar fv when S.fv_eq_lid fv fstar_tactics_SMTSync.lid -> Some SMTSync - | Tm_fvar fv when S.fv_eq_lid fv fstar_tactics_Goal.lid -> Some Goal - | Tm_fvar fv when S.fv_eq_lid fv fstar_tactics_Force.lid -> Some Force - | Tm_fvar fv when S.fv_eq_lid fv fstar_tactics_Drop.lid -> Some Drop - | _ -> None - in - mk_emb embed_guard_policy unembed_guard_policy fstar_tactics_guard_policy.t - -let e_guard_policy_nbe = - let embed_guard_policy cb (p:guard_policy) : NBET.t = - match p with - | SMT -> mkConstruct fstar_tactics_SMT.fv [] [] - | SMTSync -> mkConstruct fstar_tactics_SMTSync.fv [] [] - | Goal -> mkConstruct fstar_tactics_Goal.fv [] [] - | Force -> mkConstruct fstar_tactics_Force.fv [] [] - | Drop -> mkConstruct fstar_tactics_Drop.fv [] [] - in - let unembed_guard_policy cb (t:NBET.t) : option guard_policy = - match NBETerm.nbe_t_of_t t with - | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tactics_SMT.lid -> Some SMT - | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tactics_SMTSync.lid -> Some SMTSync - | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tactics_Goal.lid -> Some Goal - | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tactics_Force.lid -> Some Force - | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tactics_Drop.lid -> Some Drop - | _ -> None - in - { NBETerm.em = embed_guard_policy - ; NBETerm.un = unembed_guard_policy - ; NBETerm.typ = (fun () -> mkFV fstar_tactics_guard_policy.fv [] []) - ; NBETerm.e_typ = (fun () -> fv_as_emb_typ fstar_tactics_guard_policy.fv) } diff --git a/src/tactics/FStar.Tactics.Embedding.fsti b/src/tactics/FStar.Tactics.Embedding.fsti deleted file mode 100644 index bdadac9f0a1..00000000000 --- a/src/tactics/FStar.Tactics.Embedding.fsti +++ /dev/null @@ -1,52 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Tactics.Embedding - -open FStar.Ident -open FStar.Syntax.Syntax -open FStar.Syntax.Embeddings -open FStar.Tactics.Types -open FStar.Tactics.Result - -module Core = FStar.TypeChecker.Core - -module NBETerm = FStar.TypeChecker.NBETerm - -instance val e_exn : embedding exn -instance val e_proofstate : embedding proofstate -instance val e_goal : embedding goal -instance val e_result : embedding 'a -> Tot (embedding (__result 'a)) -instance val e_direction : embedding direction -instance val e_ctrl_flag : embedding ctrl_flag -instance val e_guard_policy : embedding guard_policy -instance val e_unfold_side : embedding Core.side -instance val e_tot_or_ghost : embedding Core.tot_or_ghost -instance val e_tref (#a:Type) : Tot (embedding (tref a)) - -instance val e_exn_nbe : NBETerm.embedding exn -instance val e_proofstate_nbe : NBETerm.embedding proofstate -instance val e_goal_nbe : NBETerm.embedding goal -instance val e_result_nbe : NBETerm.embedding 'a -> Tot (NBETerm.embedding (__result 'a)) -instance val e_direction_nbe : NBETerm.embedding direction -instance val e_ctrl_flag_nbe : NBETerm.embedding ctrl_flag -instance val e_guard_policy_nbe : NBETerm.embedding guard_policy -instance val e_unfold_side_nbe : NBETerm.embedding Core.side -instance val e_tot_or_ghost_nbe : NBETerm.embedding Core.tot_or_ghost -instance val e_tref_nbe (#a:Type) : Tot (NBETerm.embedding (tref a)) - -val unfold_lazy_proofstate : lazyinfo -> term -val unfold_lazy_goal : lazyinfo -> term diff --git a/src/tactics/FStar.Tactics.Hooks.fst b/src/tactics/FStar.Tactics.Hooks.fst deleted file mode 100644 index b48fc940fc6..00000000000 --- a/src/tactics/FStar.Tactics.Hooks.fst +++ /dev/null @@ -1,1029 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Tactics.Hooks - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Compiler.Util -open FStar.Compiler.Range -open FStar.Syntax.Syntax -open FStar.Syntax.Embeddings -open FStar.TypeChecker.Env -open FStar.TypeChecker.Common -open FStar.Tactics.Types -open FStar.Tactics.Interpreter -open FStar.Class.Show -module Listlike = FStar.Class.Listlike - -module BU = FStar.Compiler.Util -module Range = FStar.Compiler.Range -module Err = FStar.Errors -module O = FStar.Options -module PC = FStar.Parser.Const -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module U = FStar.Syntax.Util -module Print = FStar.Syntax.Print -module N = FStar.TypeChecker.Normalize -module Env = FStar.TypeChecker.Env -module TcUtil = FStar.TypeChecker.Util -module TcRel = FStar.TypeChecker.Rel -module TcTerm = FStar.TypeChecker.TcTerm -module TEQ = FStar.TypeChecker.TermEqAndSimplify - -(* We only use the _abstract_ embeddings from this module, -hence there is no v1/v2 distinction. *) -module RE = FStar.Reflection.V2.Embeddings - -let dbg_Tac = Debug.get_toggle "Tac" -let dbg_SpinoffAll = Debug.get_toggle "SpinoffAll" - -let run_tactic_on_typ - (rng_tac : Range.range) (rng_goal : Range.range) - (tactic:term) (env:Env.env) (typ:term) - : list goal // remaining goals - & term // witness - = - let rng = range_of_rng (use_range rng_tac) (use_range rng_goal) in - let ps, w = FStar.Tactics.V2.Basic.proofstate_of_goal_ty rng env typ in - let tactic_already_typed = false in - let gs, _res = run_tactic_on_ps rng_tac rng_goal false e_unit () e_unit tactic tactic_already_typed ps in - gs, w - -let run_tactic_on_all_implicits - (rng_tac : Range.range) (rng_goal : Range.range) - (tactic:term) (env:Env.env) (imps:Env.implicits) - : list goal // remaining goals - = - let ps, _ = FStar.Tactics.V2.Basic.proofstate_of_all_implicits rng_goal env imps in - let tactic_already_typed = false in - let goals, () = - run_tactic_on_ps - (Env.get_range env) - rng_goal - true - e_unit - () - e_unit - tactic - tactic_already_typed - ps - in - goals - -// Polarity -type pol = - | StrictlyPositive - | Pos - | Neg - | Both // traversing both polarities at once - -// Result of traversal -type tres_m 'a = - | Unchanged of 'a - | Simplified of 'a & list goal - | Dual of 'a & 'a & list goal - -type tres = tres_m term - -let tpure x = Unchanged x - -let flip p = match p with - | StrictlyPositive -> Neg - | Pos -> Neg - | Neg -> Pos - | Both -> Both - -let getprop (e:Env.env) (t:term) : option term = - let tn = N.normalize [Env.Weak; Env.HNF; Env.UnfoldUntil delta_constant] e t in - U.un_squash tn - -let by_tactic_interp (pol:pol) (e:Env.env) (t:term) : tres = - let hd, args = U.head_and_args t in - match (U.un_uinst hd).n, args with - - // with_tactic marker - | Tm_fvar fv, [(tactic, None); (assertion, None)] - when S.fv_eq_lid fv PC.by_tactic_lid -> - begin match pol with - | StrictlyPositive - | Pos -> - let gs, _ = run_tactic_on_typ tactic.pos assertion.pos tactic e assertion in - Simplified (FStar.Syntax.Util.t_true, gs) - - | Both -> - let gs, _ = run_tactic_on_typ tactic.pos assertion.pos tactic e assertion in - Dual (assertion, FStar.Syntax.Util.t_true, gs) - - | Neg -> - // Peel away tactics in negative positions, they're assumptions! - Simplified (assertion, []) - end - - // spinoff marker: simply spin off a query independently. - // So, equivalent to `with_tactic idtac` without importing the (somewhat heavy) tactics module - | Tm_fvar fv, [(assertion, None)] - when S.fv_eq_lid fv PC.spinoff_lid -> - begin match pol with - | StrictlyPositive - | Pos -> - let g = fst <| goal_of_goal_ty e assertion in - let g = set_label "spun-off assertion" g in - Simplified (FStar.Syntax.Util.t_true, [g]) - - | Both -> - let g = fst <| goal_of_goal_ty e assertion in - let g = set_label "spun-off assertion" g in - Dual (assertion, FStar.Syntax.Util.t_true, [g]) - - | Neg -> - Simplified (assertion, []) - end - - // rewrite_with_tactic marker - | Tm_fvar fv, [(tactic, None); (typ, Some ({ aqual_implicit = true } )); (tm, None)] - when S.fv_eq_lid fv PC.rewrite_by_tactic_lid -> - - // Create a new uvar that must be equal to the initial term - let uvtm, _, g_imp = Env.new_implicit_var_aux "rewrite_with_tactic RHS" tm.pos e typ Strict None false in - - let u = e.universe_of e typ in - // eq2 is squashed already, so it's in Type0 - let goal = U.mk_squash U_zero (U.mk_eq2 u typ tm uvtm) in - let gs, _ = run_tactic_on_typ tactic.pos tm.pos tactic e goal in - - // abort if the uvar was not solved - let tagged_imps = TcRel.resolve_implicits_tac e g_imp in - report_implicits tm.pos tagged_imps; - - // If the rewriting succeeded, we return the generated uvar, which is now - // a synthesized term. Any unsolved goals (gs) are spun off. - Simplified (uvtm, gs) - - | _ -> - Unchanged t - -let explode (t : tres_m 'a) : 'a & 'a & list goal = - match t with - | Unchanged t -> (t, t, []) - | Simplified (t, gs) -> (t, t, gs) - | Dual (tn, tp, gs) -> (tn, tp, gs) - -let comb1 (f : 'a -> 'b) : tres_m 'a -> tres_m 'b = function - | Unchanged t -> Unchanged (f t) - | Simplified (t, gs) -> Simplified (f t, gs) - | Dual (tn, tp, gs) -> Dual (f tn, f tp, gs) - -let comb2 (f : 'a -> 'b -> 'c ) (x : tres_m 'a) (y : tres_m 'b) : tres_m 'c = - match x, y with - | Unchanged t1, Unchanged t2 -> - Unchanged (f t1 t2) - - | Unchanged t1, Simplified (t2, gs) - | Simplified (t1, gs), Unchanged t2 -> - Simplified (f t1 t2, gs) - - | Simplified (t1, gs1), Simplified (t2, gs2) -> - Simplified (f t1 t2, gs1@gs2) - - | _ -> - let (n1, p1, gs1) = explode x in - let (n2, p2, gs2) = explode y in - Dual (f n1 n2, f p1 p2, gs1@gs2) - -let comb_list (rs : list (tres_m 'a)) : tres_m (list 'a) = - let rec aux rs acc = - match rs with - | [] -> acc - | hd::tl -> aux tl (comb2 (fun l r -> l::r) hd acc) - in - aux (List.rev rs) (tpure []) - -let emit (gs : list goal) (m : tres_m 'a) : tres_m 'a = - comb2 (fun () x -> x) (Simplified ((), gs)) m - -let rec traverse (f: pol -> Env.env -> term -> tres) (pol:pol) (e:Env.env) (t:term) : tres = - let r = - match (SS.compress t).n with - | Tm_uinst (t,us) -> let tr = traverse f pol e t in - comb1 (fun t' -> Tm_uinst (t', us)) tr - - | Tm_meta {tm=t; meta=m} -> let tr = traverse f pol e t in - comb1 (fun t' -> Tm_meta {tm=t'; meta=m}) tr - - | Tm_app {hd={ n = Tm_fvar fv }; args=[(p,_); (q,_)]} when S.fv_eq_lid fv PC.imp_lid -> - // ==> is specialized to U_zero - let x = S.new_bv None p in - let r1 = traverse f (flip pol) e p in - let r2 = traverse f pol (Env.push_bv e x) q in - comb2 (fun l r -> (U.mk_imp l r).n) r1 r2 - - (* p <==> q is special, each side is bipolar *) - (* So we traverse its arguments with pol = Both, and negative and positive versions *) - (* of p and q *) - (* then we return (in general) (p- ==> q+) /\ (q- ==> p+) *) - (* But if neither side ran tactics, we just keep p <==> q *) - | Tm_app {hd={ n = Tm_fvar fv }; args=[(p,_); (q,_)]} when S.fv_eq_lid fv PC.iff_lid -> - // <==> is specialized to U_zero - let xp = S.new_bv None p in - let xq = S.new_bv None q in - let r1 = traverse f Both (Env.push_bv e xq) p in - let r2 = traverse f Both (Env.push_bv e xp) q in - // Should be flipping the tres, I think - begin match r1, r2 with - | Unchanged _, Unchanged _ -> - comb2 (fun l r -> (U.mk_iff l r).n) r1 r2 - | _ -> - let (pn, pp, gs1) = explode r1 in - let (qn, qp, gs2) = explode r2 in - let t = U.mk_conj (U.mk_imp pn qp) (U.mk_imp qn pp) in - Simplified (t.n, gs1@gs2) - end - - | Tm_app {hd; args} -> - let r0 = traverse f pol e hd in - let r1 = List.fold_right (fun (a, q) r -> - let r' = traverse f pol e a in - comb2 (fun a args -> (a, q)::args) r' r) - args (tpure []) in - comb2 (fun hd args -> Tm_app {hd; args}) r0 r1 - - | Tm_abs {bs; body=t; rc_opt=k} -> - // TODO: traverse k? - let bs, topen = SS.open_term bs t in - let e' = Env.push_binders e bs in - let r0 = List.map (fun b -> - let r = traverse f (flip pol) e b.binder_bv.sort in - comb1 (fun s' -> ({b with binder_bv={ b.binder_bv with sort = s' }})) r - ) bs - in - let rbs = comb_list r0 in - let rt = traverse f pol e' topen in - comb2 (fun bs t -> (U.abs bs t k).n) rbs rt - - | Tm_ascribed {tm=t;asc;eff_opt=ef} -> - // TODO: traverse the types? - comb1 (fun t -> Tm_ascribed {tm=t; asc; eff_opt=ef}) (traverse f pol e t) - - | Tm_match {scrutinee=sc; ret_opt=asc_opt; brs; rc_opt=lopt} -> //AR: not traversing the return annotation - comb2 (fun sc brs -> Tm_match {scrutinee=sc; ret_opt=asc_opt; brs; rc_opt=lopt}) - (traverse f pol e sc) - (comb_list (List.map (fun br -> let (pat, w, exp) = SS.open_branch br in - let bvs = S.pat_bvs pat in - let e = Env.push_bvs e bvs in - let r = traverse f pol e exp in - comb1 (fun exp -> SS.close_branch (pat, w, exp)) r) brs)) - - | x -> - tpure x in - match r with - | Unchanged tn' -> - f pol e ({ t with n = tn' }) - - | Simplified (tn', gs) -> - emit gs (f pol e ({ t with n = tn' })) - - | Dual (tn, tp, gs) -> - let rp = f pol e ({ t with n = tp }) in - let (_, p', gs') = explode rp in - Dual ({t with n = tn}, p', gs@gs') - -let preprocess (env:Env.env) (goal:term) - : bool & list (Env.env & term & O.optionstate) - (* bool=true iff any tactic actually ran *) -= - Errors.with_ctx "While preprocessing VC with a tactic" (fun () -> - if !dbg_Tac then - BU.print2 "About to preprocess %s |= %s\n" - (show <| Env.all_binders env) - (show goal); - let initial = (1, []) in - // This match should never fail - let did_anything, (t', gs) = - match traverse by_tactic_interp Pos env goal with - | Unchanged t' -> false, (t', []) - | Simplified (t', gs) -> true, (t', gs) - | _ -> failwith "preprocess: impossible, traverse returned a Dual" - in - if !dbg_Tac then - BU.print2 "Main goal simplified to: %s |- %s\n" - (show <| Env.all_binders env) - (show t'); - let s = initial in - let s = List.fold_left (fun (n,gs) g -> - let phi = match getprop (goal_env g) (goal_type g) with - | None -> - Err.raise_error env Err.Fatal_TacticProofRelevantGoal - (BU.format1 "Tactic returned proof-relevant goal: %s" (show (goal_type g))) - | Some phi -> phi - in - if !dbg_Tac then - BU.print2 "Got goal #%s: %s\n" (show n) (show (goal_type g)); - let label = - let open FStar.Pprint in - let open FStar.Class.PP in - [ - doc_of_string "Could not prove goal #" ^^ pp n ^/^ - (if get_label g = "" then empty else parens (doc_of_string <| get_label g)) - ] - in - let gt' = TcUtil.label label (goal_range g) phi in - (n+1, (goal_env g, gt', goal_opts g)::gs)) s gs in - let (_, gs) = s in - let gs = List.rev gs in (* Return new VCs in same order as goals *) - // Use default opts for main goal - did_anything, (env, t', O.peek ()) :: gs - ) - -let rec traverse_for_spinoff - (pol:pol) - (label_ctx:option (list Pprint.document & Range.range)) - (e:Env.env) - (t:term) : tres = - let debug_any = Debug.any () in - let traverse pol e t = traverse_for_spinoff pol label_ctx e t in - let traverse_ctx pol (ctx : list Pprint.document & Range.range) (e:Env.env) (t:term) : tres = - let print_lc (msg, rng) = - BU.format3 "(%s,%s) : %s" - (Range.string_of_def_range rng) - (Range.string_of_use_range rng) - (Errors.Msg.rendermsg msg) - in - if !dbg_SpinoffAll - then BU.print2 "Changing label context from %s to %s" - (match label_ctx with - | None -> "None" - | Some lc -> print_lc lc) - (print_lc ctx); - traverse_for_spinoff pol (Some ctx) e t - in - let should_descend (t:term) = - //descend only into the following connectives - let hd, args = U.head_and_args t in - let res = - match (U.un_uinst hd).n with - | Tm_fvar fv -> - S.fv_eq_lid fv PC.and_lid || - S.fv_eq_lid fv PC.imp_lid || - S.fv_eq_lid fv PC.forall_lid || - S.fv_eq_lid fv PC.auto_squash_lid || - S.fv_eq_lid fv PC.squash_lid - - | Tm_meta _ - | Tm_ascribed _ - | Tm_abs _ -> - true - - | _ -> - false - in - res - in - let maybe_spinoff pol - (label_ctx:option (list Pprint.document & Range.range)) - (e:Env.env) - (t:term) - : tres = - let label_goal (env, t) = - let t = - match (SS.compress t).n, label_ctx with - | Tm_meta {meta=Meta_labeled _}, _ -> t - | _, Some (msg, r) -> TcUtil.label msg r t - | _ -> t - in - let t = - if U.is_sub_singleton t - then t - else U.mk_auto_squash U_zero t - in - fst (goal_of_goal_ty env t) - in - let spinoff t = - match pol with - | StrictlyPositive -> - if !dbg_SpinoffAll then BU.print1 "Spinning off %s\n" (show t); - Simplified (FStar.Syntax.Util.t_true, [label_goal (e,t)]) - - | _ -> - Unchanged t - in - let t = SS.compress t in - if not (should_descend t) - then spinoff t - else Unchanged t - in - let rewrite_boolean_conjunction t = - let hd, args = U.head_and_args t in - match (U.un_uinst hd).n, args with - | Tm_fvar fv, [(t, _)] - when S.fv_eq_lid fv PC.b2t_lid -> ( - let hd, args = U.head_and_args t in - match (U.un_uinst hd).n, args with - | Tm_fvar fv, [(t0, _); (t1, _)] - when S.fv_eq_lid fv PC.op_And -> - let t = U.mk_conj (U.b2t t0) (U.b2t t1) in - Some t - | _ -> - None - ) - | _ -> None - in - let try_rewrite_match env t = - let rec pat_as_exp env p = - match FStar.TypeChecker.PatternUtils.raw_pat_as_exp env p with - | None -> None - | Some (e, _) -> - let env, _ = Env.clear_expected_typ env in - let e, lc = - FStar.TypeChecker.TcTerm.tc_trivial_guard ({env with FStar.TypeChecker.Env.admit=true}) e in - let u = - FStar.TypeChecker.TcTerm.universe_of env lc.res_typ in - Some (e, lc.res_typ, u) - in - let bv_universes env bvs = - List.map (fun x -> x, FStar.TypeChecker.TcTerm.universe_of env x.sort) bvs - in - let mk_forall_l bv_univs term = - List.fold_right - (fun (x,u) out -> U.mk_forall u x out) - bv_univs - term - in - let mk_exists_l bv_univs term = - List.fold_right - (fun (x,u) out -> U.mk_exists u x out) - bv_univs - term - in - if pol <> StrictlyPositive then None - else ( - match (SS.compress t).n with - | Tm_match {scrutinee=sc; ret_opt=asc_opt; brs; rc_opt=lopt} -> //AR: not traversing the return annotation - let rec rewrite_branches path_condition branches = - match branches with - | [] -> Inr (U.mk_imp path_condition U.t_false) - | br::branches -> - let pat, w, body = SS.open_branch br in - match w with - | Some _ -> - Inl "when clause" //don't handle when clauses - | _ -> - let bvs = S.pat_bvs pat in - let env = Env.push_bvs env bvs in - let bvs_univs = bv_universes env bvs in - match pat_as_exp env pat with - | None -> Inl "Ill-typed pattern" - | Some (p_e, t, u) -> - let eqn = U.mk_eq2 u t sc p_e in - let branch_goal = mk_forall_l bvs_univs (U.mk_imp eqn body) in - let branch_goal = U.mk_imp path_condition branch_goal in - let next_path_condition = U.mk_conj path_condition (U.mk_neg (mk_exists_l bvs_univs eqn)) in - match rewrite_branches next_path_condition branches with - | Inl msg -> Inl msg - | Inr rest -> Inr (U.mk_conj branch_goal rest) - in - let res = rewrite_branches U.t_true brs in - (match res with - | Inl msg -> - if debug_any - then FStar.Errors.diag - (Env.get_range env) - (BU.format2 "Failed to split match term because %s (%s)" msg (show t)); - None - | Inr res -> - if debug_any - then FStar.Errors.diag - (Env.get_range env) - (BU.format2 "Rewrote match term\n%s\ninto %s\n" - (show t) - (show res)); - - Some res) - | _ -> None - ) - in - let maybe_rewrite_term t = - if pol <> StrictlyPositive then None - else - match rewrite_boolean_conjunction t with - | Some t -> Some t - | None -> try_rewrite_match e t - in - match maybe_rewrite_term t with - | Some t -> - traverse pol e t - | _ -> - let r = - let t = SS.compress t in - if not (should_descend t) then tpure t.n - else begin - match t.n with - | Tm_uinst (t,us) -> - let tr = traverse pol e t in - comb1 (fun t' -> Tm_uinst (t', us)) tr - - | Tm_meta {tm=t; meta=Meta_labeled(msg, r, _)} -> - let tr = traverse_ctx pol (msg, r) e t in - comb1 (fun t' -> Tm_meta {tm=t'; meta=Meta_labeled(msg, r, false)}) tr - - | Tm_meta {tm=t; meta=m} -> - let tr = traverse pol e t in - comb1 (fun t' -> Tm_meta {tm=t'; meta=m}) tr - - | Tm_ascribed {tm=t; asc; eff_opt=ef} -> - // TODO: traverse the types? - comb1 (fun t -> Tm_ascribed {tm=t; asc; eff_opt=ef}) (traverse pol e t) - - | Tm_app {hd={ n = Tm_fvar fv }; args=[(p,_); (q,_)]} when S.fv_eq_lid fv PC.imp_lid -> - // ==> is specialized to U_zero - let x = S.new_bv None p in - let r1 = traverse (flip pol) e p in - let r2 = traverse pol (Env.push_bv e x) q in - comb2 (fun l r -> (U.mk_imp l r).n) r1 r2 - - | Tm_app {hd; args} -> - begin - match (U.un_uinst hd).n, args with - | Tm_fvar fv, [(t, Some aq0); (body, aq)] - when (S.fv_eq_lid fv PC.forall_lid || - S.fv_eq_lid fv PC.exists_lid) && - aq0.aqual_implicit -> - let r0 = traverse pol e hd in - let rt = traverse (flip pol) e t in - let rbody = traverse pol e body in - let rargs = comb2 (fun t body -> [(t, Some aq0); (body, aq)]) rt rbody in - comb2 (fun hd args -> Tm_app {hd; args}) r0 rargs - - | _ -> - let r0 = traverse pol e hd in - let r1 = - List.fold_right - (fun (a, q) r -> - let r' = traverse pol e a in - comb2 (fun a args -> (a, q)::args) r' r) - args - (tpure []) - in - let simplified = Simplified? r0 || Simplified? r1 in - comb2 - (fun hd args -> - match (U.un_uinst hd).n, args with - | Tm_fvar fv, [(t, _)] - when simplified && - S.fv_eq_lid fv PC.squash_lid && - TEQ.eq_tm e t U.t_true = TEQ.Equal -> - //simplify squash True to True - //important for simplifying queries to Trivial - if !dbg_SpinoffAll then BU.print_string "Simplified squash True to True"; - U.t_true.n - - | _ -> - let t' = Tm_app {hd; args} in - t') - r0 r1 - end - - | Tm_abs {bs; body=t; rc_opt=k} -> - // TODO: traverse k? - let bs, topen = SS.open_term bs t in - let e' = Env.push_binders e bs in - let r0 = List.map (fun b -> - let r = traverse (flip pol) e b.binder_bv.sort in - comb1 (fun s' -> ({b with binder_bv={ b.binder_bv with sort = s' }})) r - ) bs - in - let rbs = comb_list r0 in - let rt = traverse pol e' topen in - comb2 (fun bs t -> (U.abs bs t k).n) rbs rt - - | x -> - tpure x - end - in - match r with - | Unchanged tn' -> - maybe_spinoff pol label_ctx e ({ t with n = tn' }) - - | Simplified (tn', gs) -> - emit gs (maybe_spinoff pol label_ctx e ({ t with n = tn' })) - - | Dual (tn, tp, gs) -> - let rp = maybe_spinoff pol label_ctx e ({ t with n = tp }) in - let (_, p', gs') = explode rp in - Dual ({t with n = tn}, p', gs@gs') - -let pol_to_string = function - | StrictlyPositive -> "StrictlyPositive" - | Pos -> "Positive" - | Neg -> "Negative" - | Both -> "Both" - -let spinoff_strictly_positive_goals (env:Env.env) (goal:term) - : list (Env.env & term) - = if !dbg_SpinoffAll then BU.print1 "spinoff_all called with %s\n" (show goal); - Errors.with_ctx "While spinning off all goals" (fun () -> - let initial = (1, []) in - // This match should never fail - let (t', gs) = - match traverse_for_spinoff StrictlyPositive None env goal with - | Unchanged t' -> (t', []) - | Simplified (t', gs) -> (t', gs) - | _ -> failwith "preprocess: impossible, traverse returned a Dual" - in - let t' = - N.normalize [Env.Eager_unfolding; Env.Simplify; Env.Primops] env t' - in - let main_goal = - let t = FStar.TypeChecker.Common.check_trivial t' in - match t with - | Trivial -> [] - | NonTrivial t -> - if !dbg_SpinoffAll - then ( - let msg = BU.format2 "Main goal simplified to: %s |- %s\n" - (show <| Env.all_binders env) - (show t) in - FStar.Errors.diag - (Env.get_range env) - (BU.format1 - "Verification condition was to be split into several atomic sub-goals, \ - but this query had some sub-goals that couldn't be split---the error report, if any, may be \ - inaccurate.\n%s\n" - msg) - ); - [(env, t)] - in - let s = initial in - let s = - List.fold_left - (fun (n,gs) g -> - let phi = goal_type g in - (n+1, (goal_env g, phi)::gs)) - s - gs - in - let (_, gs) = s in - let gs = List.rev gs in (* Return new VCs in same order as goals *) - let gs = - gs |> - List.filter_map - (fun (env, t) -> - let t = N.normalize [Env.Eager_unfolding; Env.Simplify; Env.Primops] env t in - match FStar.TypeChecker.Common.check_trivial t with - | Trivial -> None - | NonTrivial t -> - if !dbg_SpinoffAll - then BU.print1 "Got goal: %s\n" (show t); - Some (env, t)) - in - - FStar.Errors.diag (Env.get_range env) - (BU.format1 "Split query into %s sub-goals" (show (List.length gs))); - - main_goal@gs - ) - - -let synthesize (env:Env.env) (typ:typ) (tau:term) : term = - Errors.with_ctx "While synthesizing term with a tactic" (fun () -> - // Don't run the tactic (and end with a magic) when flychecking is set, cf. issue #73 in fstar-mode.el - if env.flychecking - then mk_Tm_app (TcUtil.fvar_env env PC.magic_lid) [S.as_arg U.exp_unit] typ.pos - else begin - - let gs, w = run_tactic_on_typ tau.pos typ.pos tau env typ in - // Check that all goals left are irrelevant and provable - // TODO: It would be nicer to combine all of these into a guard and return - // that to TcTerm, but the varying environments make it awkward. - gs |> List.iter (fun g -> - match getprop (goal_env g) (goal_type g) with - | Some vc -> - begin - if !dbg_Tac then - BU.print1 "Synthesis left a goal: %s\n" (show vc); - let guard = guard_of_guard_formula (NonTrivial vc) in - TcRel.force_trivial_guard (goal_env g) guard - end - | None -> - Err.raise_error typ Err.Fatal_OpenGoalsInSynthesis "synthesis left open goals"); - w - end - ) - -let solve_implicits (env:Env.env) (tau:term) (imps:Env.implicits) : unit = - Errors.with_ctx "While solving implicits with a tactic" (fun () -> - if env.flychecking then () else - begin - - let gs = run_tactic_on_all_implicits tau.pos (Env.get_range env) tau env imps in - // Check that all goals left are irrelevant and provable - // TODO: It would be nicer to combine all of these into a guard and return - // that to TcTerm, but the varying environments make it awkward. - if Options.profile_enabled None "FStar.TypeChecker" - then BU.print1 "solve_implicits produced %s goals\n" (show (List.length gs)); - - Options.with_saved_options (fun () -> - let _ = Options.set_options "--no_tactics" in - gs |> List.iter (fun g -> - Options.set (goal_opts g); - match getprop (goal_env g) (goal_type g) with - | Some vc -> - begin - if !dbg_Tac then - BU.print1 "Synthesis left a goal: %s\n" (show vc); - if not env.admit - then ( - let guard = guard_of_guard_formula (NonTrivial vc) in - Profiling.profile (fun () -> - TcRel.force_trivial_guard (goal_env g) guard) - None - "FStar.TypeChecker.Hooks.force_trivial_guard" - ) - end - | None -> - Err.raise_error env Err.Fatal_OpenGoalsInSynthesis "synthesis left open goals" - )) - end - ) - -(* Retrieves a tactic associated to a given attribute, if any *) -let find_user_tac_for_attr env (a:term) : option sigelt = - let hooks = Env.lookup_attr env PC.handle_smt_goals_attr_string in - hooks |> BU.try_find (fun _ -> true) - -(* This function takes an environment [env] and a goal [goal], and tries to run - the tactic registered with the (handle_smt_goal) attribute, if any. - If such a tactic exists, all the unresolved goals must be propositions, - that will be directly encoded to SMT inside Rel.discharge_guard. - If such a tactic does not exist, this function is a no-op. *) -let handle_smt_goal env goal = - match check_trivial goal with - (* No need to pass the term to the tactic if trivial *) - | Trivial -> [env, goal] - | NonTrivial goal -> - (* Attempt to retrieve a tactic corresponding to the (handle_smt_goals) attribute *) - match find_user_tac_for_attr env (S.tconst PC.handle_smt_goals_attr) with - | Some tac -> - (* There is a tactic registered with the handle_smt_goals attribute, - we retrieve the corresponding term *) - let tau = - match tac.sigel with - | Sig_let {lids=[lid]} -> - let qn = Env.lookup_qname env lid in - let fv = S.lid_as_fv lid None in - S.fv_to_tm (S.lid_as_fv lid None) - | _ -> failwith "Resolve_tac not found" - in - - let gs = Errors.with_ctx "While handling an SMT goal with a tactic" (fun () -> - - (* Executing the tactic on the goal. *) - let gs, _ = run_tactic_on_typ tau.pos (Env.get_range env) tau env (U.mk_squash U_zero goal) in - // Check that all goals left are irrelevant and provable - gs |> List.map (fun g -> - match getprop (goal_env g) (goal_type g) with - | Some vc -> - if !dbg_Tac then - BU.print1 "handle_smt_goals left a goal: %s\n" (show vc); - (goal_env g), vc - | None -> - Err.raise_error env Err.Fatal_OpenGoalsInSynthesis "Handling an SMT goal by tactic left non-prop open goals") - ) in - - gs - - (* No such tactic was available in the current context *) - | None -> [env, goal] - -// TODO: this is somehow needed for tcresolve to infer the embeddings in run_tactic_on_ps below -instance _ = RE.e_term - -type blob_t = option (string & term) -type dsl_typed_sigelt_t = bool & sigelt & blob_t -type dsl_tac_result_t = - list dsl_typed_sigelt_t & - dsl_typed_sigelt_t & - list dsl_typed_sigelt_t - -let splice - (env:Env.env) - (is_typed:bool) - (lids:list Ident.lident) - (tau:term) - (rng:Range.range) : list sigelt = - - Errors.with_ctx "While running splice with a tactic" (fun () -> - if env.flychecking then [] else begin - - let tau, _, g = - if is_typed - then TcTerm.tc_check_tot_or_gtot_term env tau U.t_dsl_tac_typ None - else TcTerm.tc_tactic t_unit S.t_decls env tau - in - - TcRel.force_trivial_guard env g; - - let ps = FStar.Tactics.V2.Basic.proofstate_of_goals tau.pos env [] [] in - let tactic_already_typed = true in - let gs, sigelts = - if is_typed then - begin - // - // See if there is a val for the lid - // - if List.length lids > 1 - then Err.raise_error rng Errors.Error_BadSplice - (BU.format1 "Typed splice: unexpected lids length (> 1) (%s)" (show lids)) - else begin - let val_t : option typ = // val type, if any, for the lid - // - // For spliced vals, their lids is set to [] - // (see ToSyntax.fst:desugar_decl, splice case) - // - if List.length lids = 0 - then None - else - match Env.try_lookup_val_decl env (List.hd lids) with - | None -> None - | Some ((uvs, tval), _) -> - // - // No universe polymorphic typed splice yet - // - if List.length uvs <> 0 - then - Err.raise_error rng Errors.Error_BadSplice - (BU.format1 "Typed splice: val declaration for %s is universe polymorphic in %s universes, expected 0" - (show (List.length uvs))) - else Some tval in - - // - // The arguments to run_tactic_on_ps here are in sync with ulib/FStar.Tactics.dsl_tac_t - // - let (gs, (sig_blobs_before, sig_blob, sig_blobs_after)) - : list goal & dsl_tac_result_t = - run_tactic_on_ps tau.pos tau.pos false - FStar.Tactics.Typeclasses.solve - ({env with admit=false; gamma=[]}, val_t) - FStar.Tactics.Typeclasses.solve - tau - tactic_already_typed - ps - in - let sig_blobs = sig_blobs_before@(sig_blob::sig_blobs_after) in - let sigelts = sig_blobs |> map (fun (checked, se, blob_opt) -> - { se with - sigmeta = { se.sigmeta with - sigmeta_extension_data = - (match blob_opt with - | Some (s, blob) -> [s, Dyn.mkdyn blob] - | None -> []); - sigmeta_already_checked = checked; } - } - ) - in - gs, sigelts - end - end - else run_tactic_on_ps tau.pos tau.pos false - e_unit () - (e_list RE.e_sigelt) tau tactic_already_typed ps - in - - // set delta depths in the sigelts fvs - let sigelts = - let set_lb_dd lb = - let {lbname=Inr fv; lbdef} = lb in - {lb with lbname=Inr fv} in - List.map (fun se -> - match se.sigel with - | Sig_let {lbs=(is_rec, lbs); lids} -> - {se with sigel=Sig_let {lbs=(is_rec, List.map set_lb_dd lbs); lids}} - | _ -> se - ) sigelts - in - - // Check that all goals left are irrelevant and solve them. - Options.with_saved_options (fun () -> - List.iter (fun g -> - Options.set (goal_opts g); - match getprop (goal_env g) (goal_type g) with - | Some vc -> - begin - if !dbg_Tac then - BU.print1 "Splice left a goal: %s\n" (show vc); - let guard = guard_of_guard_formula (NonTrivial vc) in - TcRel.force_trivial_guard (goal_env g) guard - end - | None -> - Err.raise_error rng Err.Fatal_OpenGoalsInSynthesis "splice left open goals") gs); - - let lids' = List.collect U.lids_of_sigelt sigelts in - List.iter (fun lid -> - match List.tryFind (Ident.lid_equals lid) lids' with - (* If env.flychecking is on, nothing will be generated, so don't raise an error - * so flycheck does spuriously not mark the line red *) - | None when not env.flychecking -> - Err.raise_error rng Errors.Fatal_SplicedUndef - (BU.format2 "Splice declared the name %s but it was not defined.\nThose defined were: %s" - (show lid) (show lids')) - | _ -> () - ) lids; - - if !dbg_Tac then - BU.print1 "splice: got decls = {\n\n%s\n\n}\n" (show sigelts); - - (* Check for bare Sig_datacon and Sig_inductive_typ, and abort if so. Also set range. *) - let sigelts = sigelts |> List.map (fun se -> - begin match se.sigel with - | Sig_datacon _ - | Sig_inductive_typ _ -> - let open FStar.Pprint in - let open FStar.Errors.Msg in - Err.raise_error rng Err.Error_BadSplice [ - text "Tactic returned bad sigelt:" ^/^ doc_of_string (Print.sigelt_to_string_short se); - text "If you wanted to splice an inductive type, call `pack` providing a `Sg_Inductive` to get a proper sigelt." - ] - | _ -> () - end; - { se with sigrng = rng }) - in - - (* Check there are no internal qualifiers *) - let () = - if is_typed then () - else - sigelts |> List.iter (fun se -> - se.sigquals |> List.iter (fun q -> - (* NOTE: Assumption is OK, a tactic can generate an axiom, but - * it will be reported with --report_assumes. *) - if is_internal_qualifier q then - let open FStar.Errors.Msg in - let open FStar.Pprint in - Err.raise_error rng Err.Error_InternalQualifier [ - text <| BU.format1 "The qualifier %s is internal." (show q); - prefix 2 1 (text "It cannot be attached to spliced declaration:") - (arbitrary_string (Print.sigelt_to_string_short se)); - ] - )) - in - sigelts - end - ) - -let mpreprocess (env:Env.env) (tau:term) (tm:term) : term = - Errors.with_ctx "While preprocessing a definition with a tactic" (fun () -> - if env.flychecking then tm else begin - let ps = FStar.Tactics.V2.Basic.proofstate_of_goals tm.pos env [] [] in - let tactic_already_typed = false in - let gs, tm = run_tactic_on_ps tau.pos tm.pos false RE.e_term tm RE.e_term tau tactic_already_typed ps in - tm - end - ) - -let postprocess (env:Env.env) (tau:term) (typ:term) (tm:term) : term = - Errors.with_ctx "While postprocessing a definition with a tactic" (fun () -> - if env.flychecking then tm else begin - //we know that tm:typ - //and we have a goal that u == tm - //so if we solve that equality, we don't need to retype the solution of `u : typ` - let uvtm, _, g_imp = Env.new_implicit_var_aux "postprocess RHS" tm.pos env typ (Allow_untyped "postprocess") None false in - - let u = env.universe_of env typ in - // eq2 is squashed already, so it's in Type0 - let goal = U.mk_squash U_zero (U.mk_eq2 u typ tm uvtm) in - let gs, w = run_tactic_on_typ tau.pos tm.pos tau env goal in - // see comment in `synthesize` - List.iter (fun g -> - match getprop (goal_env g) (goal_type g) with - | Some vc -> - begin - if !dbg_Tac then - BU.print1 "Postprocessing left a goal: %s\n" (show vc); - let guard = guard_of_guard_formula (NonTrivial vc) in - TcRel.force_trivial_guard (goal_env g) guard - end - | None -> - Err.raise_error typ Err.Fatal_OpenGoalsInSynthesis "postprocessing left open goals") gs; - (* abort if the uvar was not solved *) - let tagged_imps = TcRel.resolve_implicits_tac env g_imp in - report_implicits tm.pos tagged_imps; - - uvtm - end - ) diff --git a/src/tactics/FStar.Tactics.Hooks.fsti b/src/tactics/FStar.Tactics.Hooks.fsti deleted file mode 100644 index f1c36e7a127..00000000000 --- a/src/tactics/FStar.Tactics.Hooks.fsti +++ /dev/null @@ -1,32 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Tactics.Hooks - -open FStar.Syntax.Syntax -open FStar.Compiler.Range - -module O = FStar.Options -module Env = FStar.TypeChecker.Env - -val preprocess : Env.env -> term -> bool & list (Env.env & term & O.optionstate) -val spinoff_strictly_positive_goals : Env.env -> term -> list (Env.env & term) -val handle_smt_goal : Env.env -> Env.goal -> list (Env.env & term) -val synthesize : Env.env -> typ -> term -> term -val solve_implicits : Env.env -> term -> Env.implicits -> unit -val splice : Env.env -> is_typed:bool -> list Ident.lident -> term -> range -> list sigelt -val mpreprocess : Env.env -> term -> term -> term -val postprocess : Env.env -> term -> typ -> term -> term diff --git a/src/tactics/FStar.Tactics.InterpFuns.fst b/src/tactics/FStar.Tactics.InterpFuns.fst deleted file mode 100644 index 3bedc1a9ed5..00000000000 --- a/src/tactics/FStar.Tactics.InterpFuns.fst +++ /dev/null @@ -1,3178 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Tactics.InterpFuns - -(* This module is awful, don't even look at it please. *) - -open FStar open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Syntax.Syntax -open FStar.Compiler.Range - -open FStar.Tactics.Types -open FStar.Tactics.Result -open FStar.Syntax.Embeddings -open FStar.Tactics.Native -open FStar.Tactics.Monad - -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module PC = FStar.Parser.Const -module BU = FStar.Compiler.Util -module Print = FStar.Syntax.Print -module Cfg = FStar.TypeChecker.Cfg -module E = FStar.Tactics.Embedding -module NBETerm = FStar.TypeChecker.NBETerm -module NBET = FStar.TypeChecker.NBETerm -module PO = FStar.TypeChecker.Primops - -let solve (#a:Type) {| ev : a |} : Tot a = ev - -(* This module does not use typeclasses *) -let embed (e:embedding 'a) rng (t:'a) n = FStar.Syntax.Embeddings.embed #_ #e t rng None n -let unembed (e:embedding 'a) t n : option 'a = FStar.Syntax.Embeddings.unembed #_ #e t n - -let interp_ctx s f = Errors.with_ctx ("While running primitive " ^ s) f - -let run_wrap (label : string) (t : tac 'a) ps : __result 'a = - interp_ctx label (fun () -> run_safe t ps) - -let builtin_lid nm = PC.fstar_stubs_tactics_lid' ["V2"; "Builtins"; nm] -let types_lid nm = PC.fstar_stubs_tactics_lid' ["Types"; nm] - -let set_auto_reflect arity (p:PO.primitive_step) : PO.primitive_step = - { p with auto_reflect = Some arity } - -let mk_tot_step_1 uarity nm f nbe_f = - let lid = types_lid nm in - PO.mk1' uarity lid - (fun x -> f x |> Some) - (fun x -> nbe_f x |> Some) - -let mk_tot_step_2 uarity nm f nbe_f = - let lid = types_lid nm in - PO.mk2' uarity lid - (fun x y -> f x y |> Some) - (fun x y -> nbe_f x y |> Some) - -let mk_tot_step_1_psc us nm f nbe_f = - let lid = types_lid nm in - PO.mk1_psc' us lid - (fun psc x -> f psc x |> Some) - (fun psc x -> nbe_f psc x |> Some) - -let mk_tac_step_1 univ_arity nm f nbe_f : PO.primitive_step = - let lid = builtin_lid nm in - set_auto_reflect 1 <| - PO.mk2' univ_arity lid - (fun a ps -> Some (run_wrap nm (f a) ps)) - (fun a ps -> Some (run_wrap nm (nbe_f a) ps)) - -let mk_tac_step_2 univ_arity nm f nbe_f : PO.primitive_step = - let lid = builtin_lid nm in - set_auto_reflect 2 <| - PO.mk3' univ_arity lid - (fun a b ps -> Some (run_wrap nm (f a b) ps)) - (fun a b ps -> Some (run_wrap nm (nbe_f a b) ps)) - -let mk_tac_step_3 univ_arity nm f nbe_f : PO.primitive_step = - let lid = builtin_lid nm in - set_auto_reflect 3 <| - PO.mk4' univ_arity lid - (fun a b c ps -> Some (run_wrap nm (f a b c) ps)) - (fun a b c ps -> Some (run_wrap nm (nbe_f a b c) ps)) - -let mk_tac_step_4 univ_arity nm f nbe_f : PO.primitive_step = - let lid = builtin_lid nm in - set_auto_reflect 4 <| - PO.mk5' univ_arity lid - (fun a b c d ps -> Some (run_wrap nm (f a b c d) ps)) - (fun a b c d ps -> Some (run_wrap nm (nbe_f a b c d) ps)) - -let mk_tac_step_5 univ_arity nm f nbe_f : PO.primitive_step = - let lid = builtin_lid nm in - set_auto_reflect 5 <| - PO.mk6' univ_arity lid - (fun a b c d e ps -> Some (run_wrap nm (f a b c d e) ps)) - (fun a b c d e ps -> Some (run_wrap nm (nbe_f a b c d e) ps)) - -let max_tac_arity = 20 - -(* NOTE: THE REST OF THIS MODULE IS AUTOGENERATED - * and here only for plugins to call into. The rest of the compiler - * makes no use of these functions. - * See .scripts/mk_tac_interps.sh *) - -let mk_tactic_interpretation_1 - (name : string) - (t : 't1 -> tac 'r) - (e1:embedding 't1) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed E.e_proofstate a2 ncb) (fun ps -> - let ps = set_ps_psc psc ps in - let r = interp_ctx name (fun () -> run_safe (t a1) ps) in - Some (embed (E.e_result er) (PO.psc_range psc) r ncb))) - | _ -> - None - -let mk_tactic_interpretation_2 - (name : string) - (t : 't1 -> 't2 -> tac 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed E.e_proofstate a3 ncb) (fun ps -> - let ps = set_ps_psc psc ps in - let r = interp_ctx name (fun () -> run_safe (t a1 a2) ps) in - Some (embed (E.e_result er) (PO.psc_range psc) r ncb)))) - | _ -> - None - -let mk_tactic_interpretation_3 - (name : string) - (t : 't1 -> 't2 -> 't3 -> tac 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed E.e_proofstate a4 ncb) (fun ps -> - let ps = set_ps_psc psc ps in - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3) ps) in - Some (embed (E.e_result er) (PO.psc_range psc) r ncb))))) - | _ -> - None - -let mk_tactic_interpretation_4 - (name : string) - (t : 't1 -> 't2 -> 't3 -> 't4 -> tac 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed E.e_proofstate a5 ncb) (fun ps -> - let ps = set_ps_psc psc ps in - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4) ps) in - Some (embed (E.e_result er) (PO.psc_range psc) r ncb)))))) - | _ -> - None - -let mk_tactic_interpretation_5 - (name : string) - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> tac 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - BU.bind_opt (unembed E.e_proofstate a6 ncb) (fun ps -> - let ps = set_ps_psc psc ps in - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5) ps) in - Some (embed (E.e_result er) (PO.psc_range psc) r ncb))))))) - | _ -> - None - -let mk_tactic_interpretation_6 - (name : string) - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> tac 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (e6:embedding 't6) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> - BU.bind_opt (unembed E.e_proofstate a7 ncb) (fun ps -> - let ps = set_ps_psc psc ps in - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6) ps) in - Some (embed (E.e_result er) (PO.psc_range psc) r ncb)))))))) - | _ -> - None - -let mk_tactic_interpretation_7 - (name : string) - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> tac 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (e6:embedding 't6) - (e7:embedding 't7) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> - BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> - BU.bind_opt (unembed E.e_proofstate a8 ncb) (fun ps -> - let ps = set_ps_psc psc ps in - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7) ps) in - Some (embed (E.e_result er) (PO.psc_range psc) r ncb))))))))) - | _ -> - None - -let mk_tactic_interpretation_8 - (name : string) - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> tac 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (e6:embedding 't6) - (e7:embedding 't7) - (e8:embedding 't8) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> - BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> - BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> - BU.bind_opt (unembed E.e_proofstate a9 ncb) (fun ps -> - let ps = set_ps_psc psc ps in - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8) ps) in - Some (embed (E.e_result er) (PO.psc_range psc) r ncb)))))))))) - | _ -> - None - -let mk_tactic_interpretation_9 - (name : string) - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> tac 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (e6:embedding 't6) - (e7:embedding 't7) - (e8:embedding 't8) - (e9:embedding 't9) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> - BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> - BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> - BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> - BU.bind_opt (unembed E.e_proofstate a10 ncb) (fun ps -> - let ps = set_ps_psc psc ps in - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9) ps) in - Some (embed (E.e_result er) (PO.psc_range psc) r ncb))))))))))) - | _ -> - None - -let mk_tactic_interpretation_10 - (name : string) - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> tac 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (e6:embedding 't6) - (e7:embedding 't7) - (e8:embedding 't8) - (e9:embedding 't9) - (e10:embedding 't10) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> - BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> - BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> - BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> - BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> - BU.bind_opt (unembed E.e_proofstate a11 ncb) (fun ps -> - let ps = set_ps_psc psc ps in - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) ps) in - Some (embed (E.e_result er) (PO.psc_range psc) r ncb)))))))))))) - | _ -> - None - -let mk_tactic_interpretation_11 - (name : string) - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> tac 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (e6:embedding 't6) - (e7:embedding 't7) - (e8:embedding 't8) - (e9:embedding 't9) - (e10:embedding 't10) - (e11:embedding 't11) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> - BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> - BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> - BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> - BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> - BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> - BU.bind_opt (unembed E.e_proofstate a12 ncb) (fun ps -> - let ps = set_ps_psc psc ps in - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) ps) in - Some (embed (E.e_result er) (PO.psc_range psc) r ncb))))))))))))) - | _ -> - None - -let mk_tactic_interpretation_12 - (name : string) - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> tac 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (e6:embedding 't6) - (e7:embedding 't7) - (e8:embedding 't8) - (e9:embedding 't9) - (e10:embedding 't10) - (e11:embedding 't11) - (e12:embedding 't12) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> - BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> - BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> - BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> - BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> - BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> - BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> - BU.bind_opt (unembed E.e_proofstate a13 ncb) (fun ps -> - let ps = set_ps_psc psc ps in - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12) ps) in - Some (embed (E.e_result er) (PO.psc_range psc) r ncb)))))))))))))) - | _ -> - None - -let mk_tactic_interpretation_13 - (name : string) - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> tac 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (e6:embedding 't6) - (e7:embedding 't7) - (e8:embedding 't8) - (e9:embedding 't9) - (e10:embedding 't10) - (e11:embedding 't11) - (e12:embedding 't12) - (e13:embedding 't13) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> - BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> - BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> - BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> - BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> - BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> - BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> - BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> - BU.bind_opt (unembed E.e_proofstate a14 ncb) (fun ps -> - let ps = set_ps_psc psc ps in - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13) ps) in - Some (embed (E.e_result er) (PO.psc_range psc) r ncb))))))))))))))) - | _ -> - None - -let mk_tactic_interpretation_14 - (name : string) - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> tac 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (e6:embedding 't6) - (e7:embedding 't7) - (e8:embedding 't8) - (e9:embedding 't9) - (e10:embedding 't10) - (e11:embedding 't11) - (e12:embedding 't12) - (e13:embedding 't13) - (e14:embedding 't14) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> - BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> - BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> - BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> - BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> - BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> - BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> - BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> - BU.bind_opt (unembed e14 a14 ncb) (fun a14 -> - BU.bind_opt (unembed E.e_proofstate a15 ncb) (fun ps -> - let ps = set_ps_psc psc ps in - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14) ps) in - Some (embed (E.e_result er) (PO.psc_range psc) r ncb)))))))))))))))) - | _ -> - None - -let mk_tactic_interpretation_15 - (name : string) - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> tac 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (e6:embedding 't6) - (e7:embedding 't7) - (e8:embedding 't8) - (e9:embedding 't9) - (e10:embedding 't10) - (e11:embedding 't11) - (e12:embedding 't12) - (e13:embedding 't13) - (e14:embedding 't14) - (e15:embedding 't15) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> - BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> - BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> - BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> - BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> - BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> - BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> - BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> - BU.bind_opt (unembed e14 a14 ncb) (fun a14 -> - BU.bind_opt (unembed e15 a15 ncb) (fun a15 -> - BU.bind_opt (unembed E.e_proofstate a16 ncb) (fun ps -> - let ps = set_ps_psc psc ps in - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15) ps) in - Some (embed (E.e_result er) (PO.psc_range psc) r ncb))))))))))))))))) - | _ -> - None - -let mk_tactic_interpretation_16 - (name : string) - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> tac 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (e6:embedding 't6) - (e7:embedding 't7) - (e8:embedding 't8) - (e9:embedding 't9) - (e10:embedding 't10) - (e11:embedding 't11) - (e12:embedding 't12) - (e13:embedding 't13) - (e14:embedding 't14) - (e15:embedding 't15) - (e16:embedding 't16) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> - BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> - BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> - BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> - BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> - BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> - BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> - BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> - BU.bind_opt (unembed e14 a14 ncb) (fun a14 -> - BU.bind_opt (unembed e15 a15 ncb) (fun a15 -> - BU.bind_opt (unembed e16 a16 ncb) (fun a16 -> - BU.bind_opt (unembed E.e_proofstate a17 ncb) (fun ps -> - let ps = set_ps_psc psc ps in - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16) ps) in - Some (embed (E.e_result er) (PO.psc_range psc) r ncb)))))))))))))))))) - | _ -> - None - -let mk_tactic_interpretation_17 - (name : string) - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> tac 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (e6:embedding 't6) - (e7:embedding 't7) - (e8:embedding 't8) - (e9:embedding 't9) - (e10:embedding 't10) - (e11:embedding 't11) - (e12:embedding 't12) - (e13:embedding 't13) - (e14:embedding 't14) - (e15:embedding 't15) - (e16:embedding 't16) - (e17:embedding 't17) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _); (a18, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> - BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> - BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> - BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> - BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> - BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> - BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> - BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> - BU.bind_opt (unembed e14 a14 ncb) (fun a14 -> - BU.bind_opt (unembed e15 a15 ncb) (fun a15 -> - BU.bind_opt (unembed e16 a16 ncb) (fun a16 -> - BU.bind_opt (unembed e17 a17 ncb) (fun a17 -> - BU.bind_opt (unembed E.e_proofstate a18 ncb) (fun ps -> - let ps = set_ps_psc psc ps in - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17) ps) in - Some (embed (E.e_result er) (PO.psc_range psc) r ncb))))))))))))))))))) - | _ -> - None - -let mk_tactic_interpretation_18 - (name : string) - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 't18 -> tac 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (e6:embedding 't6) - (e7:embedding 't7) - (e8:embedding 't8) - (e9:embedding 't9) - (e10:embedding 't10) - (e11:embedding 't11) - (e12:embedding 't12) - (e13:embedding 't13) - (e14:embedding 't14) - (e15:embedding 't15) - (e16:embedding 't16) - (e17:embedding 't17) - (e18:embedding 't18) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _); (a18, _); (a19, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> - BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> - BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> - BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> - BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> - BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> - BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> - BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> - BU.bind_opt (unembed e14 a14 ncb) (fun a14 -> - BU.bind_opt (unembed e15 a15 ncb) (fun a15 -> - BU.bind_opt (unembed e16 a16 ncb) (fun a16 -> - BU.bind_opt (unembed e17 a17 ncb) (fun a17 -> - BU.bind_opt (unembed e18 a18 ncb) (fun a18 -> - BU.bind_opt (unembed E.e_proofstate a19 ncb) (fun ps -> - let ps = set_ps_psc psc ps in - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18) ps) in - Some (embed (E.e_result er) (PO.psc_range psc) r ncb)))))))))))))))))))) - | _ -> - None - -let mk_tactic_interpretation_19 - (name : string) - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 't18 -> 't19 -> tac 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (e6:embedding 't6) - (e7:embedding 't7) - (e8:embedding 't8) - (e9:embedding 't9) - (e10:embedding 't10) - (e11:embedding 't11) - (e12:embedding 't12) - (e13:embedding 't13) - (e14:embedding 't14) - (e15:embedding 't15) - (e16:embedding 't16) - (e17:embedding 't17) - (e18:embedding 't18) - (e19:embedding 't19) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _); (a18, _); (a19, _); (a20, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> - BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> - BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> - BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> - BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> - BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> - BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> - BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> - BU.bind_opt (unembed e14 a14 ncb) (fun a14 -> - BU.bind_opt (unembed e15 a15 ncb) (fun a15 -> - BU.bind_opt (unembed e16 a16 ncb) (fun a16 -> - BU.bind_opt (unembed e17 a17 ncb) (fun a17 -> - BU.bind_opt (unembed e18 a18 ncb) (fun a18 -> - BU.bind_opt (unembed e19 a19 ncb) (fun a19 -> - BU.bind_opt (unembed E.e_proofstate a20 ncb) (fun ps -> - let ps = set_ps_psc psc ps in - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19) ps) in - Some (embed (E.e_result er) (PO.psc_range psc) r ncb))))))))))))))))))))) - | _ -> - None - -let mk_tactic_interpretation_20 - (name : string) - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 't18 -> 't19 -> 't20 -> tac 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (e6:embedding 't6) - (e7:embedding 't7) - (e8:embedding 't8) - (e9:embedding 't9) - (e10:embedding 't10) - (e11:embedding 't11) - (e12:embedding 't12) - (e13:embedding 't13) - (e14:embedding 't14) - (e15:embedding 't15) - (e16:embedding 't16) - (e17:embedding 't17) - (e18:embedding 't18) - (e19:embedding 't19) - (e20:embedding 't20) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _); (a18, _); (a19, _); (a20, _); (a21, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> - BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> - BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> - BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> - BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> - BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> - BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> - BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> - BU.bind_opt (unembed e14 a14 ncb) (fun a14 -> - BU.bind_opt (unembed e15 a15 ncb) (fun a15 -> - BU.bind_opt (unembed e16 a16 ncb) (fun a16 -> - BU.bind_opt (unembed e17 a17 ncb) (fun a17 -> - BU.bind_opt (unembed e18 a18 ncb) (fun a18 -> - BU.bind_opt (unembed e19 a19 ncb) (fun a19 -> - BU.bind_opt (unembed e20 a20 ncb) (fun a20 -> - BU.bind_opt (unembed E.e_proofstate a21 ncb) (fun ps -> - let ps = set_ps_psc psc ps in - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20) ps) in - Some (embed (E.e_result er) (PO.psc_range psc) r ncb)))))))))))))))))))))) - | _ -> - None - -let mk_tactic_nbe_interpretation_1 - (name : string) - cb - (t : 't1 -> tac 'r) - (e1:NBET.embedding 't1) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a2) (fun ps -> - let r = interp_ctx name (fun () -> run_safe (t a1) ps) in - Some (NBET.embed (E.e_result_nbe er) cb r))) - | _ -> - None - -let mk_tactic_nbe_interpretation_2 - (name : string) - cb - (t : 't1 -> 't2 -> tac 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a3) (fun ps -> - let r = interp_ctx name (fun () -> run_safe (t a1 a2) ps) in - Some (NBET.embed (E.e_result_nbe er) cb r)))) - | _ -> - None - -let mk_tactic_nbe_interpretation_3 - (name : string) - cb - (t : 't1 -> 't2 -> 't3 -> tac 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a4) (fun ps -> - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3) ps) in - Some (NBET.embed (E.e_result_nbe er) cb r))))) - | _ -> - None - -let mk_tactic_nbe_interpretation_4 - (name : string) - cb - (t : 't1 -> 't2 -> 't3 -> 't4 -> tac 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a5) (fun ps -> - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4) ps) in - Some (NBET.embed (E.e_result_nbe er) cb r)))))) - | _ -> - None - -let mk_tactic_nbe_interpretation_5 - (name : string) - cb - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> tac 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a6) (fun ps -> - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5) ps) in - Some (NBET.embed (E.e_result_nbe er) cb r))))))) - | _ -> - None - -let mk_tactic_nbe_interpretation_6 - (name : string) - cb - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> tac 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (e6:NBET.embedding 't6) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> - BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a7) (fun ps -> - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6) ps) in - Some (NBET.embed (E.e_result_nbe er) cb r)))))))) - | _ -> - None - -let mk_tactic_nbe_interpretation_7 - (name : string) - cb - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> tac 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (e6:NBET.embedding 't6) - (e7:NBET.embedding 't7) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> - BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> - BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a8) (fun ps -> - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7) ps) in - Some (NBET.embed (E.e_result_nbe er) cb r))))))))) - | _ -> - None - -let mk_tactic_nbe_interpretation_8 - (name : string) - cb - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> tac 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (e6:NBET.embedding 't6) - (e7:NBET.embedding 't7) - (e8:NBET.embedding 't8) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> - BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> - BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> - BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a9) (fun ps -> - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8) ps) in - Some (NBET.embed (E.e_result_nbe er) cb r)))))))))) - | _ -> - None - -let mk_tactic_nbe_interpretation_9 - (name : string) - cb - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> tac 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (e6:NBET.embedding 't6) - (e7:NBET.embedding 't7) - (e8:NBET.embedding 't8) - (e9:NBET.embedding 't9) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> - BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> - BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> - BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> - BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a10) (fun ps -> - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9) ps) in - Some (NBET.embed (E.e_result_nbe er) cb r))))))))))) - | _ -> - None - -let mk_tactic_nbe_interpretation_10 - (name : string) - cb - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> tac 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (e6:NBET.embedding 't6) - (e7:NBET.embedding 't7) - (e8:NBET.embedding 't8) - (e9:NBET.embedding 't9) - (e10:NBET.embedding 't10) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> - BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> - BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> - BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> - BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> - BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a11) (fun ps -> - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) ps) in - Some (NBET.embed (E.e_result_nbe er) cb r)))))))))))) - | _ -> - None - -let mk_tactic_nbe_interpretation_11 - (name : string) - cb - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> tac 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (e6:NBET.embedding 't6) - (e7:NBET.embedding 't7) - (e8:NBET.embedding 't8) - (e9:NBET.embedding 't9) - (e10:NBET.embedding 't10) - (e11:NBET.embedding 't11) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> - BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> - BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> - BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> - BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> - BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> - BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a12) (fun ps -> - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) ps) in - Some (NBET.embed (E.e_result_nbe er) cb r))))))))))))) - | _ -> - None - -let mk_tactic_nbe_interpretation_12 - (name : string) - cb - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> tac 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (e6:NBET.embedding 't6) - (e7:NBET.embedding 't7) - (e8:NBET.embedding 't8) - (e9:NBET.embedding 't9) - (e10:NBET.embedding 't10) - (e11:NBET.embedding 't11) - (e12:NBET.embedding 't12) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> - BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> - BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> - BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> - BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> - BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> - BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> - BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a13) (fun ps -> - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12) ps) in - Some (NBET.embed (E.e_result_nbe er) cb r)))))))))))))) - | _ -> - None - -let mk_tactic_nbe_interpretation_13 - (name : string) - cb - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> tac 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (e6:NBET.embedding 't6) - (e7:NBET.embedding 't7) - (e8:NBET.embedding 't8) - (e9:NBET.embedding 't9) - (e10:NBET.embedding 't10) - (e11:NBET.embedding 't11) - (e12:NBET.embedding 't12) - (e13:NBET.embedding 't13) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> - BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> - BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> - BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> - BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> - BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> - BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> - BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> - BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a14) (fun ps -> - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13) ps) in - Some (NBET.embed (E.e_result_nbe er) cb r))))))))))))))) - | _ -> - None - -let mk_tactic_nbe_interpretation_14 - (name : string) - cb - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> tac 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (e6:NBET.embedding 't6) - (e7:NBET.embedding 't7) - (e8:NBET.embedding 't8) - (e9:NBET.embedding 't9) - (e10:NBET.embedding 't10) - (e11:NBET.embedding 't11) - (e12:NBET.embedding 't12) - (e13:NBET.embedding 't13) - (e14:NBET.embedding 't14) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> - BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> - BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> - BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> - BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> - BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> - BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> - BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> - BU.bind_opt (NBET.unembed e14 cb a14) (fun a14 -> - BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a15) (fun ps -> - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14) ps) in - Some (NBET.embed (E.e_result_nbe er) cb r)))))))))))))))) - | _ -> - None - -let mk_tactic_nbe_interpretation_15 - (name : string) - cb - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> tac 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (e6:NBET.embedding 't6) - (e7:NBET.embedding 't7) - (e8:NBET.embedding 't8) - (e9:NBET.embedding 't9) - (e10:NBET.embedding 't10) - (e11:NBET.embedding 't11) - (e12:NBET.embedding 't12) - (e13:NBET.embedding 't13) - (e14:NBET.embedding 't14) - (e15:NBET.embedding 't15) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> - BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> - BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> - BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> - BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> - BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> - BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> - BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> - BU.bind_opt (NBET.unembed e14 cb a14) (fun a14 -> - BU.bind_opt (NBET.unembed e15 cb a15) (fun a15 -> - BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a16) (fun ps -> - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15) ps) in - Some (NBET.embed (E.e_result_nbe er) cb r))))))))))))))))) - | _ -> - None - -let mk_tactic_nbe_interpretation_16 - (name : string) - cb - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> tac 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (e6:NBET.embedding 't6) - (e7:NBET.embedding 't7) - (e8:NBET.embedding 't8) - (e9:NBET.embedding 't9) - (e10:NBET.embedding 't10) - (e11:NBET.embedding 't11) - (e12:NBET.embedding 't12) - (e13:NBET.embedding 't13) - (e14:NBET.embedding 't14) - (e15:NBET.embedding 't15) - (e16:NBET.embedding 't16) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> - BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> - BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> - BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> - BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> - BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> - BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> - BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> - BU.bind_opt (NBET.unembed e14 cb a14) (fun a14 -> - BU.bind_opt (NBET.unembed e15 cb a15) (fun a15 -> - BU.bind_opt (NBET.unembed e16 cb a16) (fun a16 -> - BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a17) (fun ps -> - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16) ps) in - Some (NBET.embed (E.e_result_nbe er) cb r)))))))))))))))))) - | _ -> - None - -let mk_tactic_nbe_interpretation_17 - (name : string) - cb - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> tac 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (e6:NBET.embedding 't6) - (e7:NBET.embedding 't7) - (e8:NBET.embedding 't8) - (e9:NBET.embedding 't9) - (e10:NBET.embedding 't10) - (e11:NBET.embedding 't11) - (e12:NBET.embedding 't12) - (e13:NBET.embedding 't13) - (e14:NBET.embedding 't14) - (e15:NBET.embedding 't15) - (e16:NBET.embedding 't16) - (e17:NBET.embedding 't17) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _); (a18, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> - BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> - BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> - BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> - BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> - BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> - BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> - BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> - BU.bind_opt (NBET.unembed e14 cb a14) (fun a14 -> - BU.bind_opt (NBET.unembed e15 cb a15) (fun a15 -> - BU.bind_opt (NBET.unembed e16 cb a16) (fun a16 -> - BU.bind_opt (NBET.unembed e17 cb a17) (fun a17 -> - BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a18) (fun ps -> - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17) ps) in - Some (NBET.embed (E.e_result_nbe er) cb r))))))))))))))))))) - | _ -> - None - -let mk_tactic_nbe_interpretation_18 - (name : string) - cb - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 't18 -> tac 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (e6:NBET.embedding 't6) - (e7:NBET.embedding 't7) - (e8:NBET.embedding 't8) - (e9:NBET.embedding 't9) - (e10:NBET.embedding 't10) - (e11:NBET.embedding 't11) - (e12:NBET.embedding 't12) - (e13:NBET.embedding 't13) - (e14:NBET.embedding 't14) - (e15:NBET.embedding 't15) - (e16:NBET.embedding 't16) - (e17:NBET.embedding 't17) - (e18:NBET.embedding 't18) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _); (a18, _); (a19, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> - BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> - BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> - BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> - BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> - BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> - BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> - BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> - BU.bind_opt (NBET.unembed e14 cb a14) (fun a14 -> - BU.bind_opt (NBET.unembed e15 cb a15) (fun a15 -> - BU.bind_opt (NBET.unembed e16 cb a16) (fun a16 -> - BU.bind_opt (NBET.unembed e17 cb a17) (fun a17 -> - BU.bind_opt (NBET.unembed e18 cb a18) (fun a18 -> - BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a19) (fun ps -> - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18) ps) in - Some (NBET.embed (E.e_result_nbe er) cb r)))))))))))))))))))) - | _ -> - None - -let mk_tactic_nbe_interpretation_19 - (name : string) - cb - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 't18 -> 't19 -> tac 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (e6:NBET.embedding 't6) - (e7:NBET.embedding 't7) - (e8:NBET.embedding 't8) - (e9:NBET.embedding 't9) - (e10:NBET.embedding 't10) - (e11:NBET.embedding 't11) - (e12:NBET.embedding 't12) - (e13:NBET.embedding 't13) - (e14:NBET.embedding 't14) - (e15:NBET.embedding 't15) - (e16:NBET.embedding 't16) - (e17:NBET.embedding 't17) - (e18:NBET.embedding 't18) - (e19:NBET.embedding 't19) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _); (a18, _); (a19, _); (a20, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> - BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> - BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> - BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> - BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> - BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> - BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> - BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> - BU.bind_opt (NBET.unembed e14 cb a14) (fun a14 -> - BU.bind_opt (NBET.unembed e15 cb a15) (fun a15 -> - BU.bind_opt (NBET.unembed e16 cb a16) (fun a16 -> - BU.bind_opt (NBET.unembed e17 cb a17) (fun a17 -> - BU.bind_opt (NBET.unembed e18 cb a18) (fun a18 -> - BU.bind_opt (NBET.unembed e19 cb a19) (fun a19 -> - BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a20) (fun ps -> - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19) ps) in - Some (NBET.embed (E.e_result_nbe er) cb r))))))))))))))))))))) - | _ -> - None - -let mk_tactic_nbe_interpretation_20 - (name : string) - cb - (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 't18 -> 't19 -> 't20 -> tac 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (e6:NBET.embedding 't6) - (e7:NBET.embedding 't7) - (e8:NBET.embedding 't8) - (e9:NBET.embedding 't9) - (e10:NBET.embedding 't10) - (e11:NBET.embedding 't11) - (e12:NBET.embedding 't12) - (e13:NBET.embedding 't13) - (e14:NBET.embedding 't14) - (e15:NBET.embedding 't15) - (e16:NBET.embedding 't16) - (e17:NBET.embedding 't17) - (e18:NBET.embedding 't18) - (e19:NBET.embedding 't19) - (e20:NBET.embedding 't20) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _); (a18, _); (a19, _); (a20, _); (a21, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> - BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> - BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> - BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> - BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> - BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> - BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> - BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> - BU.bind_opt (NBET.unembed e14 cb a14) (fun a14 -> - BU.bind_opt (NBET.unembed e15 cb a15) (fun a15 -> - BU.bind_opt (NBET.unembed e16 cb a16) (fun a16 -> - BU.bind_opt (NBET.unembed e17 cb a17) (fun a17 -> - BU.bind_opt (NBET.unembed e18 cb a18) (fun a18 -> - BU.bind_opt (NBET.unembed e19 cb a19) (fun a19 -> - BU.bind_opt (NBET.unembed e20 cb a20) (fun a20 -> - BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a21) (fun ps -> - let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20) ps) in - Some (NBET.embed (E.e_result_nbe er) cb r)))))))))))))))))))))) - | _ -> - None - -let mk_total_interpretation_1 - (name : string) - (f : 't1 -> 'r) - (e1:embedding 't1) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - let r = interp_ctx name (fun () -> f a1) in - Some (embed er (PO.psc_range psc) r ncb)) - | _ -> - None - -let mk_total_interpretation_2 - (name : string) - (f : 't1 -> 't2 -> 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - let r = interp_ctx name (fun () -> f a1 a2) in - Some (embed er (PO.psc_range psc) r ncb))) - | _ -> - None - -let mk_total_interpretation_3 - (name : string) - (f : 't1 -> 't2 -> 't3 -> 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - let r = interp_ctx name (fun () -> f a1 a2 a3) in - Some (embed er (PO.psc_range psc) r ncb)))) - | _ -> - None - -let mk_total_interpretation_4 - (name : string) - (f : 't1 -> 't2 -> 't3 -> 't4 -> 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4) in - Some (embed er (PO.psc_range psc) r ncb))))) - | _ -> - None - -let mk_total_interpretation_5 - (name : string) - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5) in - Some (embed er (PO.psc_range psc) r ncb)))))) - | _ -> - None - -let mk_total_interpretation_6 - (name : string) - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (e6:embedding 't6) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6) in - Some (embed er (PO.psc_range psc) r ncb))))))) - | _ -> - None - -let mk_total_interpretation_7 - (name : string) - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (e6:embedding 't6) - (e7:embedding 't7) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> - BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7) in - Some (embed er (PO.psc_range psc) r ncb)))))))) - | _ -> - None - -let mk_total_interpretation_8 - (name : string) - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (e6:embedding 't6) - (e7:embedding 't7) - (e8:embedding 't8) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> - BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> - BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8) in - Some (embed er (PO.psc_range psc) r ncb))))))))) - | _ -> - None - -let mk_total_interpretation_9 - (name : string) - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (e6:embedding 't6) - (e7:embedding 't7) - (e8:embedding 't8) - (e9:embedding 't9) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> - BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> - BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> - BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9) in - Some (embed er (PO.psc_range psc) r ncb)))))))))) - | _ -> - None - -let mk_total_interpretation_10 - (name : string) - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (e6:embedding 't6) - (e7:embedding 't7) - (e8:embedding 't8) - (e9:embedding 't9) - (e10:embedding 't10) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> - BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> - BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> - BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> - BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) in - Some (embed er (PO.psc_range psc) r ncb))))))))))) - | _ -> - None - -let mk_total_interpretation_11 - (name : string) - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (e6:embedding 't6) - (e7:embedding 't7) - (e8:embedding 't8) - (e9:embedding 't9) - (e10:embedding 't10) - (e11:embedding 't11) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> - BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> - BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> - BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> - BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> - BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) in - Some (embed er (PO.psc_range psc) r ncb)))))))))))) - | _ -> - None - -let mk_total_interpretation_12 - (name : string) - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (e6:embedding 't6) - (e7:embedding 't7) - (e8:embedding 't8) - (e9:embedding 't9) - (e10:embedding 't10) - (e11:embedding 't11) - (e12:embedding 't12) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> - BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> - BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> - BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> - BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> - BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> - BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12) in - Some (embed er (PO.psc_range psc) r ncb))))))))))))) - | _ -> - None - -let mk_total_interpretation_13 - (name : string) - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (e6:embedding 't6) - (e7:embedding 't7) - (e8:embedding 't8) - (e9:embedding 't9) - (e10:embedding 't10) - (e11:embedding 't11) - (e12:embedding 't12) - (e13:embedding 't13) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> - BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> - BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> - BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> - BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> - BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> - BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> - BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13) in - Some (embed er (PO.psc_range psc) r ncb)))))))))))))) - | _ -> - None - -let mk_total_interpretation_14 - (name : string) - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (e6:embedding 't6) - (e7:embedding 't7) - (e8:embedding 't8) - (e9:embedding 't9) - (e10:embedding 't10) - (e11:embedding 't11) - (e12:embedding 't12) - (e13:embedding 't13) - (e14:embedding 't14) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> - BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> - BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> - BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> - BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> - BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> - BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> - BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> - BU.bind_opt (unembed e14 a14 ncb) (fun a14 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14) in - Some (embed er (PO.psc_range psc) r ncb))))))))))))))) - | _ -> - None - -let mk_total_interpretation_15 - (name : string) - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (e6:embedding 't6) - (e7:embedding 't7) - (e8:embedding 't8) - (e9:embedding 't9) - (e10:embedding 't10) - (e11:embedding 't11) - (e12:embedding 't12) - (e13:embedding 't13) - (e14:embedding 't14) - (e15:embedding 't15) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> - BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> - BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> - BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> - BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> - BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> - BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> - BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> - BU.bind_opt (unembed e14 a14 ncb) (fun a14 -> - BU.bind_opt (unembed e15 a15 ncb) (fun a15 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15) in - Some (embed er (PO.psc_range psc) r ncb)))))))))))))))) - | _ -> - None - -let mk_total_interpretation_16 - (name : string) - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (e6:embedding 't6) - (e7:embedding 't7) - (e8:embedding 't8) - (e9:embedding 't9) - (e10:embedding 't10) - (e11:embedding 't11) - (e12:embedding 't12) - (e13:embedding 't13) - (e14:embedding 't14) - (e15:embedding 't15) - (e16:embedding 't16) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> - BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> - BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> - BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> - BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> - BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> - BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> - BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> - BU.bind_opt (unembed e14 a14 ncb) (fun a14 -> - BU.bind_opt (unembed e15 a15 ncb) (fun a15 -> - BU.bind_opt (unembed e16 a16 ncb) (fun a16 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16) in - Some (embed er (PO.psc_range psc) r ncb))))))))))))))))) - | _ -> - None - -let mk_total_interpretation_17 - (name : string) - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (e6:embedding 't6) - (e7:embedding 't7) - (e8:embedding 't8) - (e9:embedding 't9) - (e10:embedding 't10) - (e11:embedding 't11) - (e12:embedding 't12) - (e13:embedding 't13) - (e14:embedding 't14) - (e15:embedding 't15) - (e16:embedding 't16) - (e17:embedding 't17) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> - BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> - BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> - BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> - BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> - BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> - BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> - BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> - BU.bind_opt (unembed e14 a14 ncb) (fun a14 -> - BU.bind_opt (unembed e15 a15 ncb) (fun a15 -> - BU.bind_opt (unembed e16 a16 ncb) (fun a16 -> - BU.bind_opt (unembed e17 a17 ncb) (fun a17 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17) in - Some (embed er (PO.psc_range psc) r ncb)))))))))))))))))) - | _ -> - None - -let mk_total_interpretation_18 - (name : string) - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 't18 -> 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (e6:embedding 't6) - (e7:embedding 't7) - (e8:embedding 't8) - (e9:embedding 't9) - (e10:embedding 't10) - (e11:embedding 't11) - (e12:embedding 't12) - (e13:embedding 't13) - (e14:embedding 't14) - (e15:embedding 't15) - (e16:embedding 't16) - (e17:embedding 't17) - (e18:embedding 't18) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _); (a18, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> - BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> - BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> - BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> - BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> - BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> - BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> - BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> - BU.bind_opt (unembed e14 a14 ncb) (fun a14 -> - BU.bind_opt (unembed e15 a15 ncb) (fun a15 -> - BU.bind_opt (unembed e16 a16 ncb) (fun a16 -> - BU.bind_opt (unembed e17 a17 ncb) (fun a17 -> - BU.bind_opt (unembed e18 a18 ncb) (fun a18 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18) in - Some (embed er (PO.psc_range psc) r ncb))))))))))))))))))) - | _ -> - None - -let mk_total_interpretation_19 - (name : string) - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 't18 -> 't19 -> 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (e6:embedding 't6) - (e7:embedding 't7) - (e8:embedding 't8) - (e9:embedding 't9) - (e10:embedding 't10) - (e11:embedding 't11) - (e12:embedding 't12) - (e13:embedding 't13) - (e14:embedding 't14) - (e15:embedding 't15) - (e16:embedding 't16) - (e17:embedding 't17) - (e18:embedding 't18) - (e19:embedding 't19) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _); (a18, _); (a19, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> - BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> - BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> - BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> - BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> - BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> - BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> - BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> - BU.bind_opt (unembed e14 a14 ncb) (fun a14 -> - BU.bind_opt (unembed e15 a15 ncb) (fun a15 -> - BU.bind_opt (unembed e16 a16 ncb) (fun a16 -> - BU.bind_opt (unembed e17 a17 ncb) (fun a17 -> - BU.bind_opt (unembed e18 a18 ncb) (fun a18 -> - BU.bind_opt (unembed e19 a19 ncb) (fun a19 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19) in - Some (embed er (PO.psc_range psc) r ncb)))))))))))))))))))) - | _ -> - None - -let mk_total_interpretation_20 - (name : string) - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 't18 -> 't19 -> 't20 -> 'r) - (e1:embedding 't1) - (e2:embedding 't2) - (e3:embedding 't3) - (e4:embedding 't4) - (e5:embedding 't5) - (e6:embedding 't6) - (e7:embedding 't7) - (e8:embedding 't8) - (e9:embedding 't9) - (e10:embedding 't10) - (e11:embedding 't11) - (e12:embedding 't12) - (e13:embedding 't13) - (e14:embedding 't14) - (e15:embedding 't15) - (e16:embedding 't16) - (e17:embedding 't17) - (e18:embedding 't18) - (e19:embedding 't19) - (e20:embedding 't20) - (er:embedding 'r) - (psc:PO.psc) - (ncb:norm_cb) - (us:universes) - (args:args) - : option term - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _); (a18, _); (a19, _); (a20, _)] -> - BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> - BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> - BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> - BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> - BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> - BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> - BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> - BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> - BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> - BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> - BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> - BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> - BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> - BU.bind_opt (unembed e14 a14 ncb) (fun a14 -> - BU.bind_opt (unembed e15 a15 ncb) (fun a15 -> - BU.bind_opt (unembed e16 a16 ncb) (fun a16 -> - BU.bind_opt (unembed e17 a17 ncb) (fun a17 -> - BU.bind_opt (unembed e18 a18 ncb) (fun a18 -> - BU.bind_opt (unembed e19 a19 ncb) (fun a19 -> - BU.bind_opt (unembed e20 a20 ncb) (fun a20 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20) in - Some (embed er (PO.psc_range psc) r ncb))))))))))))))))))))) - | _ -> - None - -let mk_total_nbe_interpretation_1 - (name : string) - cb - (f : 't1 -> 'r) - (e1:NBET.embedding 't1) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - let r = interp_ctx name (fun () -> f a1) in - Some (NBET.embed er cb r)) - | _ -> - None - -let mk_total_nbe_interpretation_2 - (name : string) - cb - (f : 't1 -> 't2 -> 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - let r = interp_ctx name (fun () -> f a1 a2) in - Some (NBET.embed er cb r))) - | _ -> - None - -let mk_total_nbe_interpretation_3 - (name : string) - cb - (f : 't1 -> 't2 -> 't3 -> 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - let r = interp_ctx name (fun () -> f a1 a2 a3) in - Some (NBET.embed er cb r)))) - | _ -> - None - -let mk_total_nbe_interpretation_4 - (name : string) - cb - (f : 't1 -> 't2 -> 't3 -> 't4 -> 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4) in - Some (NBET.embed er cb r))))) - | _ -> - None - -let mk_total_nbe_interpretation_5 - (name : string) - cb - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5) in - Some (NBET.embed er cb r)))))) - | _ -> - None - -let mk_total_nbe_interpretation_6 - (name : string) - cb - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (e6:NBET.embedding 't6) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6) in - Some (NBET.embed er cb r))))))) - | _ -> - None - -let mk_total_nbe_interpretation_7 - (name : string) - cb - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (e6:NBET.embedding 't6) - (e7:NBET.embedding 't7) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> - BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7) in - Some (NBET.embed er cb r)))))))) - | _ -> - None - -let mk_total_nbe_interpretation_8 - (name : string) - cb - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (e6:NBET.embedding 't6) - (e7:NBET.embedding 't7) - (e8:NBET.embedding 't8) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> - BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> - BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8) in - Some (NBET.embed er cb r))))))))) - | _ -> - None - -let mk_total_nbe_interpretation_9 - (name : string) - cb - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (e6:NBET.embedding 't6) - (e7:NBET.embedding 't7) - (e8:NBET.embedding 't8) - (e9:NBET.embedding 't9) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> - BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> - BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> - BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9) in - Some (NBET.embed er cb r)))))))))) - | _ -> - None - -let mk_total_nbe_interpretation_10 - (name : string) - cb - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (e6:NBET.embedding 't6) - (e7:NBET.embedding 't7) - (e8:NBET.embedding 't8) - (e9:NBET.embedding 't9) - (e10:NBET.embedding 't10) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> - BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> - BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> - BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> - BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) in - Some (NBET.embed er cb r))))))))))) - | _ -> - None - -let mk_total_nbe_interpretation_11 - (name : string) - cb - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (e6:NBET.embedding 't6) - (e7:NBET.embedding 't7) - (e8:NBET.embedding 't8) - (e9:NBET.embedding 't9) - (e10:NBET.embedding 't10) - (e11:NBET.embedding 't11) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> - BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> - BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> - BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> - BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> - BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) in - Some (NBET.embed er cb r)))))))))))) - | _ -> - None - -let mk_total_nbe_interpretation_12 - (name : string) - cb - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (e6:NBET.embedding 't6) - (e7:NBET.embedding 't7) - (e8:NBET.embedding 't8) - (e9:NBET.embedding 't9) - (e10:NBET.embedding 't10) - (e11:NBET.embedding 't11) - (e12:NBET.embedding 't12) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> - BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> - BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> - BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> - BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> - BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> - BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12) in - Some (NBET.embed er cb r))))))))))))) - | _ -> - None - -let mk_total_nbe_interpretation_13 - (name : string) - cb - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (e6:NBET.embedding 't6) - (e7:NBET.embedding 't7) - (e8:NBET.embedding 't8) - (e9:NBET.embedding 't9) - (e10:NBET.embedding 't10) - (e11:NBET.embedding 't11) - (e12:NBET.embedding 't12) - (e13:NBET.embedding 't13) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> - BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> - BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> - BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> - BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> - BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> - BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> - BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13) in - Some (NBET.embed er cb r)))))))))))))) - | _ -> - None - -let mk_total_nbe_interpretation_14 - (name : string) - cb - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (e6:NBET.embedding 't6) - (e7:NBET.embedding 't7) - (e8:NBET.embedding 't8) - (e9:NBET.embedding 't9) - (e10:NBET.embedding 't10) - (e11:NBET.embedding 't11) - (e12:NBET.embedding 't12) - (e13:NBET.embedding 't13) - (e14:NBET.embedding 't14) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> - BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> - BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> - BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> - BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> - BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> - BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> - BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> - BU.bind_opt (NBET.unembed e14 cb a14) (fun a14 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14) in - Some (NBET.embed er cb r))))))))))))))) - | _ -> - None - -let mk_total_nbe_interpretation_15 - (name : string) - cb - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (e6:NBET.embedding 't6) - (e7:NBET.embedding 't7) - (e8:NBET.embedding 't8) - (e9:NBET.embedding 't9) - (e10:NBET.embedding 't10) - (e11:NBET.embedding 't11) - (e12:NBET.embedding 't12) - (e13:NBET.embedding 't13) - (e14:NBET.embedding 't14) - (e15:NBET.embedding 't15) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> - BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> - BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> - BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> - BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> - BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> - BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> - BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> - BU.bind_opt (NBET.unembed e14 cb a14) (fun a14 -> - BU.bind_opt (NBET.unembed e15 cb a15) (fun a15 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15) in - Some (NBET.embed er cb r)))))))))))))))) - | _ -> - None - -let mk_total_nbe_interpretation_16 - (name : string) - cb - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (e6:NBET.embedding 't6) - (e7:NBET.embedding 't7) - (e8:NBET.embedding 't8) - (e9:NBET.embedding 't9) - (e10:NBET.embedding 't10) - (e11:NBET.embedding 't11) - (e12:NBET.embedding 't12) - (e13:NBET.embedding 't13) - (e14:NBET.embedding 't14) - (e15:NBET.embedding 't15) - (e16:NBET.embedding 't16) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> - BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> - BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> - BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> - BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> - BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> - BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> - BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> - BU.bind_opt (NBET.unembed e14 cb a14) (fun a14 -> - BU.bind_opt (NBET.unembed e15 cb a15) (fun a15 -> - BU.bind_opt (NBET.unembed e16 cb a16) (fun a16 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16) in - Some (NBET.embed er cb r))))))))))))))))) - | _ -> - None - -let mk_total_nbe_interpretation_17 - (name : string) - cb - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (e6:NBET.embedding 't6) - (e7:NBET.embedding 't7) - (e8:NBET.embedding 't8) - (e9:NBET.embedding 't9) - (e10:NBET.embedding 't10) - (e11:NBET.embedding 't11) - (e12:NBET.embedding 't12) - (e13:NBET.embedding 't13) - (e14:NBET.embedding 't14) - (e15:NBET.embedding 't15) - (e16:NBET.embedding 't16) - (e17:NBET.embedding 't17) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> - BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> - BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> - BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> - BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> - BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> - BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> - BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> - BU.bind_opt (NBET.unembed e14 cb a14) (fun a14 -> - BU.bind_opt (NBET.unembed e15 cb a15) (fun a15 -> - BU.bind_opt (NBET.unembed e16 cb a16) (fun a16 -> - BU.bind_opt (NBET.unembed e17 cb a17) (fun a17 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17) in - Some (NBET.embed er cb r)))))))))))))))))) - | _ -> - None - -let mk_total_nbe_interpretation_18 - (name : string) - cb - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 't18 -> 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (e6:NBET.embedding 't6) - (e7:NBET.embedding 't7) - (e8:NBET.embedding 't8) - (e9:NBET.embedding 't9) - (e10:NBET.embedding 't10) - (e11:NBET.embedding 't11) - (e12:NBET.embedding 't12) - (e13:NBET.embedding 't13) - (e14:NBET.embedding 't14) - (e15:NBET.embedding 't15) - (e16:NBET.embedding 't16) - (e17:NBET.embedding 't17) - (e18:NBET.embedding 't18) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _); (a18, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> - BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> - BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> - BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> - BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> - BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> - BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> - BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> - BU.bind_opt (NBET.unembed e14 cb a14) (fun a14 -> - BU.bind_opt (NBET.unembed e15 cb a15) (fun a15 -> - BU.bind_opt (NBET.unembed e16 cb a16) (fun a16 -> - BU.bind_opt (NBET.unembed e17 cb a17) (fun a17 -> - BU.bind_opt (NBET.unembed e18 cb a18) (fun a18 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18) in - Some (NBET.embed er cb r))))))))))))))))))) - | _ -> - None - -let mk_total_nbe_interpretation_19 - (name : string) - cb - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 't18 -> 't19 -> 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (e6:NBET.embedding 't6) - (e7:NBET.embedding 't7) - (e8:NBET.embedding 't8) - (e9:NBET.embedding 't9) - (e10:NBET.embedding 't10) - (e11:NBET.embedding 't11) - (e12:NBET.embedding 't12) - (e13:NBET.embedding 't13) - (e14:NBET.embedding 't14) - (e15:NBET.embedding 't15) - (e16:NBET.embedding 't16) - (e17:NBET.embedding 't17) - (e18:NBET.embedding 't18) - (e19:NBET.embedding 't19) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _); (a18, _); (a19, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> - BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> - BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> - BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> - BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> - BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> - BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> - BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> - BU.bind_opt (NBET.unembed e14 cb a14) (fun a14 -> - BU.bind_opt (NBET.unembed e15 cb a15) (fun a15 -> - BU.bind_opt (NBET.unembed e16 cb a16) (fun a16 -> - BU.bind_opt (NBET.unembed e17 cb a17) (fun a17 -> - BU.bind_opt (NBET.unembed e18 cb a18) (fun a18 -> - BU.bind_opt (NBET.unembed e19 cb a19) (fun a19 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19) in - Some (NBET.embed er cb r)))))))))))))))))))) - | _ -> - None - -let mk_total_nbe_interpretation_20 - (name : string) - cb - (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 't18 -> 't19 -> 't20 -> 'r) - (e1:NBET.embedding 't1) - (e2:NBET.embedding 't2) - (e3:NBET.embedding 't3) - (e4:NBET.embedding 't4) - (e5:NBET.embedding 't5) - (e6:NBET.embedding 't6) - (e7:NBET.embedding 't7) - (e8:NBET.embedding 't8) - (e9:NBET.embedding 't9) - (e10:NBET.embedding 't10) - (e11:NBET.embedding 't11) - (e12:NBET.embedding 't12) - (e13:NBET.embedding 't13) - (e14:NBET.embedding 't14) - (e15:NBET.embedding 't15) - (e16:NBET.embedding 't16) - (e17:NBET.embedding 't17) - (e18:NBET.embedding 't18) - (e19:NBET.embedding 't19) - (e20:NBET.embedding 't20) - (er:NBET.embedding 'r) - (us:universes) - (args:NBET.args) - : option NBET.t - = - match args with - | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _); (a18, _); (a19, _); (a20, _)] -> - BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> - BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> - BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> - BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> - BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> - BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> - BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> - BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> - BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> - BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> - BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> - BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> - BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> - BU.bind_opt (NBET.unembed e14 cb a14) (fun a14 -> - BU.bind_opt (NBET.unembed e15 cb a15) (fun a15 -> - BU.bind_opt (NBET.unembed e16 cb a16) (fun a16 -> - BU.bind_opt (NBET.unembed e17 cb a17) (fun a17 -> - BU.bind_opt (NBET.unembed e18 cb a18) (fun a18 -> - BU.bind_opt (NBET.unembed e19 cb a19) (fun a19 -> - BU.bind_opt (NBET.unembed e20 cb a20) (fun a20 -> - let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20) in - Some (NBET.embed er cb r))))))))))))))))))))) - | _ -> - None diff --git a/src/tactics/FStar.Tactics.InterpFuns.fsti b/src/tactics/FStar.Tactics.InterpFuns.fsti deleted file mode 100644 index a1d40c37d64..00000000000 --- a/src/tactics/FStar.Tactics.InterpFuns.fsti +++ /dev/null @@ -1,148 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Tactics.InterpFuns - -(* This module is awful, don't even look at it please. *) - -open FStar open FStar.Compiler -open FStar.Compiler.Effect - -open FStar.Syntax.Embeddings -open FStar.Tactics.Monad - -module Cfg = FStar.TypeChecker.Cfg -module NBET = FStar.TypeChecker.NBETerm -module PO = FStar.TypeChecker.Primops - -val max_tac_arity : int // = 20 - -val interp_ctx : string -> (unit -> 'a) -> 'a - -// The mk_tot_step functions use lids in FStar.Stubs.Tactics.Types, -// while mk_tac_step ones go to FStar.Stubs.Tactics.V2.Builtins. -// For V1 there's a pass over the result to change the V2 to V1. - -val mk_tot_step_1 : - univ_arity:int -> - string -> - {| embedding 't1 |} -> - {| embedding 'res |} -> - {| NBET.embedding 'nt1 |} -> - {| NBET.embedding 'nres |} -> - ('t1 -> 'res) -> - ('nt1 -> 'nres) -> - PO.primitive_step - -val mk_tot_step_2 : - univ_arity:int -> - string -> - {| embedding 't1 |} -> - {| embedding 't2 |} -> - {| embedding 'res |} -> - {| NBET.embedding 'nt1 |} -> - {| NBET.embedding 'nt2 |} -> - {| NBET.embedding 'nres |} -> - ('t1 -> 't2 -> 'res) -> - ('nt1 -> 'nt2 -> 'nres) -> - PO.primitive_step - -// Step with access to normalizer PSC -val mk_tot_step_1_psc : - univ_arity:int -> - string -> - {| embedding 't1 |} -> - {| embedding 'res |} -> - {| NBET.embedding 'nt1 |} -> - {| NBET.embedding 'nres |} -> - (PO.psc -> 't1 -> 'res) -> - (PO.psc -> 'nt1 -> 'nres) -> - PO.primitive_step - -val mk_tac_step_1 : - univ_arity:int -> - string -> - {| embedding 't1 |} -> - {| embedding 'res |} -> - {| NBET.embedding 'nt1 |} -> - {| NBET.embedding 'nres |} -> - ('t1 -> tac 'res) -> - ('nt1 -> tac 'nres) -> - PO.primitive_step - -val mk_tac_step_2 : - univ_arity:int -> - string -> - {| embedding 't1 |} -> - {| embedding 't2 |} -> - {| embedding 'res |} -> - {| NBET.embedding 'nt1 |} -> - {| NBET.embedding 'nt2 |} -> - {| NBET.embedding 'nres |} -> - ('t1 -> 't2 -> tac 'res) -> - ('nt1 -> 'nt2 -> tac 'nres) -> - PO.primitive_step - -val mk_tac_step_3 : - univ_arity:int -> - string -> - {| embedding 't1 |} -> - {| embedding 't2 |} -> - {| embedding 't3 |} -> - {| embedding 'res |} -> - {| NBET.embedding 'nt1 |} -> - {| NBET.embedding 'nt2 |} -> - {| NBET.embedding 'nt3 |} -> - {| NBET.embedding 'nres |} -> - ('t1 -> 't2 -> 't3 -> tac 'res) -> - ('nt1 -> 'nt2 -> 'nt3 -> tac 'nres) -> - PO.primitive_step - -val mk_tac_step_4 : - univ_arity:int -> - string -> - {| embedding 't1 |} -> - {| embedding 't2 |} -> - {| embedding 't3 |} -> - {| embedding 't4 |} -> - {| embedding 'res |} -> - {| NBET.embedding 'nt1 |} -> - {| NBET.embedding 'nt2 |} -> - {| NBET.embedding 'nt3 |} -> - {| NBET.embedding 'nt4 |} -> - {| NBET.embedding 'nres |} -> - ('t1 -> 't2 -> 't3 -> 't4 -> tac 'res) -> - ('nt1 -> 'nt2 -> 'nt3 -> 'nt4 -> tac 'nres) -> - PO.primitive_step - -val mk_tac_step_5 : - univ_arity:int -> - string -> - {| embedding 't1 |} -> - {| embedding 't2 |} -> - {| embedding 't3 |} -> - {| embedding 't4 |} -> - {| embedding 't5 |} -> - {| embedding 'res |} -> - {| NBET.embedding 'nt1 |} -> - {| NBET.embedding 'nt2 |} -> - {| NBET.embedding 'nt3 |} -> - {| NBET.embedding 'nt4 |} -> - {| NBET.embedding 'nt5 |} -> - {| NBET.embedding 'nres |} -> - ('t1 -> 't2 -> 't3 -> 't4 -> 't5 -> tac 'res) -> - ('nt1 -> 'nt2 -> 'nt3 -> 'nt4 -> 'nt5 -> tac 'nres) -> - PO.primitive_step diff --git a/src/tactics/FStar.Tactics.Interpreter.fst b/src/tactics/FStar.Tactics.Interpreter.fst deleted file mode 100644 index 20fabb3c877..00000000000 --- a/src/tactics/FStar.Tactics.Interpreter.fst +++ /dev/null @@ -1,448 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Tactics.Interpreter - -(* Most of the tactic running logic is here. V1.Interpreter calls -into this module for all of that. *) - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Compiler.Range -open FStar.Compiler.Util -open FStar.Syntax.Syntax -open FStar.Syntax.Embeddings -open FStar.TypeChecker.Common -open FStar.TypeChecker.Env -open FStar.Tactics.Result -open FStar.Tactics.Types -open FStar.Tactics.Printing -open FStar.Tactics.Monad -open FStar.Tactics.CtrlRewrite -open FStar.Tactics.Native -open FStar.Tactics.Common -open FStar.Class.Show -open FStar.Class.PP -open FStar.Class.Monad -module Listlike = FStar.Class.Listlike - -module BU = FStar.Compiler.Util -module Cfg = FStar.TypeChecker.Cfg -module E = FStar.Tactics.Embedding -module Env = FStar.TypeChecker.Env -module Err = FStar.Errors -module IFuns = FStar.Tactics.InterpFuns -module NBE = FStar.TypeChecker.NBE -module NBET = FStar.TypeChecker.NBETerm -module N = FStar.TypeChecker.Normalize -module NRE = FStar.Reflection.V2.NBEEmbeddings -module PC = FStar.Parser.Const -module PO = FStar.TypeChecker.Primops -module Print = FStar.Syntax.Print -module RE = FStar.Reflection.V2.Embeddings -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module TcComm = FStar.TypeChecker.Common -module TcRel = FStar.TypeChecker.Rel -module TcTerm = FStar.TypeChecker.TcTerm -module U = FStar.Syntax.Util - -let dbg_Tac = Debug.get_toggle "Tac" - -let solve (#a:Type) {| ev : a |} : Tot a = ev - -let embed {|embedding 'a|} r (x:'a) norm_cb = embed x r None norm_cb -let unembed {|embedding 'a|} a norm_cb : option 'a = unembed a norm_cb - -let native_tactics_steps () = - let step_from_native_step (s: native_primitive_step) : PO.primitive_step = - { name = s.name - ; arity = s.arity - ; univ_arity = 0 // Zoe : We might need to change that - ; auto_reflect = Some (s.arity - 1) - ; strong_reduction_ok = s.strong_reduction_ok - ; requires_binder_substitution = false // GM: Don't think we care about pretty-printing on native - ; renorm_after = false - ; interpretation = s.tactic - ; interpretation_nbe = fun _cb _us -> NBET.dummy_interp s.name - } - in - List.map step_from_native_step (FStar.Tactics.Native.list_all ()) - -(* This reference keeps all of the tactic primitives. *) -let __primitive_steps_ref : ref (list PO.primitive_step) = - BU.mk_ref [] - -let primitive_steps () : list PO.primitive_step = - (native_tactics_steps ()) - @ (!__primitive_steps_ref) - -let register_tactic_primitive_step (s : PO.primitive_step) : unit = - __primitive_steps_ref := s :: !__primitive_steps_ref - -(* This function attempts to reconstruct the reduction head of a -stuck tactic term, to provide a better error message for the user. *) -let rec t_head_of (t : term) : term = - match (SS.compress t).n with - | Tm_app _ -> - (* If the head is a ctor, or an uninterpreted fv, do not shrink - further. Otherwise we will get failures saying that 'Success' - or 'dump' got stuck, which is not helpful. *) - let h, args = U.head_and_args_full t in - let h = U.unmeta h in - begin match (SS.compress h).n with - | Tm_uinst _ - | Tm_fvar _ - | Tm_bvar _ // should not occur - | Tm_name _ - | Tm_constant _ -> t - | _ -> t_head_of h - end - | Tm_match {scrutinee=t} - | Tm_ascribed {tm=t} - | Tm_meta {tm=t} -> t_head_of t - | _ -> t - -let unembed_tactic_0 (eb:embedding 'b) (embedded_tac_b:term) (ncb:norm_cb) : tac 'b = - let! proof_state = get in - let rng = embedded_tac_b.pos in - - (* First, reify it from Tac a into __tac a *) - let embedded_tac_b = U.mk_reify embedded_tac_b (Some PC.effect_TAC_lid) in - - let tm = S.mk_Tm_app embedded_tac_b - [S.as_arg (embed rng proof_state ncb)] - rng in - - - // Why not HNF? While we don't care about strong reduction we need more than head - // normal form due to primitive steps. Consider `norm (steps 2)`: we need to normalize - // `steps 2` before caling norm, or it will fail to unembed the set of steps. Further, - // at this moment at least, the normalizer will not call into any step of arity > 1. - let steps = [Env.Weak; - Env.Reify; - Env.UnfoldUntil delta_constant; Env.DontUnfoldAttr [PC.tac_opaque_attr]; - Env.Primops; Env.Unascribe; - Env.Tactics] in - - // Maybe use NBE if the user asked for it - let norm_f = if Options.tactics_nbe () - then NBE.normalize - else N.normalize_with_primitive_steps - in - (* if proof_state.tac_verb_dbg then *) - (* BU.print1 "Starting normalizer with %s\n" (show tm); *) - let result = norm_f (primitive_steps ()) steps proof_state.main_context tm in - (* if proof_state.tac_verb_dbg then *) - (* BU.print1 "Reduced tactic: got %s\n" (show result); *) - - let res = unembed result ncb in - - match res with - | Some (Success (b, ps)) -> - set ps;! - return b - - | Some (Failed (e, ps)) -> - set ps;! - traise e - - | None -> - (* The tactic got stuck, try to provide a helpful error message. *) - let h_result = t_head_of result in - let open FStar.Pprint in - let maybe_admit_tip : document = - (* Use the monadic visitor to check whether the reduced head - contains an admit, which is a common error *) - let r : option term = - Syntax.VisitM.visitM_term false (fun t -> - match t.n with - | Tm_fvar fv when fv_eq_lid fv PC.admit_lid -> None - | _ -> Some t) h_result - in - if None? r - then doc_of_string "The term contains an `admit`, which will not reduce. Did you mean `tadmit()`?" - else empty - in - Errors.raise_error proof_state.main_context Errors.Fatal_TacticGotStuck [ - doc_of_string "Tactic got stuck!"; - doc_of_string "Reduction stopped at: " ^^ pp h_result; - maybe_admit_tip - ] - -let unembed_tactic_nbe_0 (eb:NBET.embedding 'b) (cb:NBET.nbe_cbs) (embedded_tac_b:NBET.t) : tac 'b = - let! proof_state = get in - - (* Applying is normalizing!!! *) - let result = NBET.iapp_cb cb embedded_tac_b [NBET.as_arg (NBET.embed E.e_proofstate_nbe cb proof_state)] in - let res = NBET.unembed (E.e_result_nbe eb) cb result in - - match res with - | Some (Success (b, ps)) -> - set ps;! - return b - - | Some (Failed (e, ps)) -> - set ps;! - traise e - - | None -> - let open FStar.Pprint in - Errors.raise_error proof_state.main_context Errors.Fatal_TacticGotStuck [ - doc_of_string "Tactic got stuck (in NBE)!"; - Errors.Msg.text "Please file a bug report with a minimal reproduction of this issue."; - doc_of_string "Result = " ^^ arbitrary_string (NBET.t_to_string result) - ] - -let unembed_tactic_1 (ea:embedding 'a) (er:embedding 'r) (f:term) (ncb:norm_cb) : 'a -> tac 'r = - fun x -> - let rng = FStar.Compiler.Range.dummyRange in - let x_tm = embed rng x ncb in - let app = S.mk_Tm_app f [as_arg x_tm] rng in - unembed_tactic_0 er app ncb - -let unembed_tactic_nbe_1 (ea:NBET.embedding 'a) (er:NBET.embedding 'r) (cb:NBET.nbe_cbs) (f:NBET.t) : 'a -> tac 'r = - fun x -> - let x_tm = NBET.embed ea cb x in - let app = NBET.iapp_cb cb f [NBET.as_arg x_tm] in - unembed_tactic_nbe_0 er cb app - -let e_tactic_thunk (er : embedding 'r) : embedding (tac 'r) - = - mk_emb (fun _ _ _ _ -> failwith "Impossible: embedding tactic (thunk)?") - (fun t cb -> Some (unembed_tactic_1 e_unit er t cb ())) - (FStar.Syntax.Embeddings.term_as_fv S.t_unit) - -let e_tactic_nbe_thunk (er : NBET.embedding 'r) : NBET.embedding (tac 'r) - = - NBET.mk_emb - (fun cb _ -> failwith "Impossible: NBE embedding tactic (thunk)?") - (fun cb t -> Some (unembed_tactic_nbe_1 NBET.e_unit er cb t ())) - (fun () -> NBET.mk_t (NBET.Constant NBET.Unit)) - (emb_typ_of unit) - -let e_tactic_1 (ea : embedding 'a) (er : embedding 'r) : embedding ('a -> tac 'r) - = - mk_emb (fun _ _ _ _ -> failwith "Impossible: embedding tactic (1)?") - (fun t cb -> Some (unembed_tactic_1 ea er t cb)) - (FStar.Syntax.Embeddings.term_as_fv S.t_unit) - -let e_tactic_nbe_1 (ea : NBET.embedding 'a) (er : NBET.embedding 'r) : NBET.embedding ('a -> tac 'r) - = - NBET.mk_emb - (fun cb _ -> failwith "Impossible: NBE embedding tactic (1)?") - (fun cb t -> Some (unembed_tactic_nbe_1 ea er cb t)) - (fun () -> NBET.mk_t (NBET.Constant NBET.Unit)) - (emb_typ_of unit) - -let unembed_tactic_1_alt (ea:embedding 'a) (er:embedding 'r) (f:term) (ncb:norm_cb) : option ('a -> tac 'r) = - Some (fun x -> - let rng = FStar.Compiler.Range.dummyRange in - let x_tm = embed rng x ncb in - let app = S.mk_Tm_app f [as_arg x_tm] rng in - unembed_tactic_0 er app ncb) - -let e_tactic_1_alt (ea: embedding 'a) (er:embedding 'r): embedding ('a -> (proofstate -> __result 'r)) = - let em = (fun _ _ _ _ -> failwith "Impossible: embedding tactic (1)?") in - let un (t0: term) (n: norm_cb): option ('a -> (proofstate -> __result 'r)) = - match unembed_tactic_1_alt ea er t0 n with - | Some f -> Some (fun x -> run (f x)) - | None -> None - in - mk_emb em un (FStar.Syntax.Embeddings.term_as_fv t_unit) - -let report_implicits rng (is : TcRel.tagged_implicits) : unit = - let open FStar.Pprint in - let open FStar.Errors.Msg in - let open FStar.Class.PP in - is |> List.iter - (fun (imp, tag) -> - match tag with - | TcRel.Implicit_unresolved - | TcRel.Implicit_checking_defers_univ_constraint -> - Errors.log_issue rng Err.Error_UninstantiatedUnificationVarInTactic [ - text "Tactic left uninstantiated unification variable:" ^/^ pp (imp.imp_uvar.ctx_uvar_head); - text "Type:" ^/^ pp (U.ctx_uvar_typ imp.imp_uvar); - text "Reason:" ^/^ dquotes (doc_of_string imp.imp_reason); - ] - | TcRel.Implicit_has_typing_guard (tm, ty) -> - Errors.log_issue rng Err.Error_UninstantiatedUnificationVarInTactic [ - text "Tactic solved goal:" ^/^ pp (imp.imp_uvar.ctx_uvar_head); - text "Type:" ^/^ pp (U.ctx_uvar_typ imp.imp_uvar); - text "To the term:" ^/^ pp tm; - text "But it has a non-trivial typing guard. Use gather_or_solve_explicit_guards_for_resolved_goals to inspect and prove these goals"; - ] - ); - Err.stop_if_err () - -let run_unembedded_tactic_on_ps - (rng_call : Range.range) - (rng_goal : Range.range) - (background : bool) - (arg : 'a) - (tau: 'a -> tac 'b) - (ps:proofstate) - : list goal // remaining goals - & 'b // return value - = - let ps = { ps with main_context = { ps.main_context with intactics = true } } in - let ps = { ps with main_context = { ps.main_context with range = rng_goal } } in - let env = ps.main_context in - (* if !dbg_Tac then *) - (* BU.print1 "Running tactic with goal = (%s) {\n" (show typ); *) - let res = - Profiling.profile - (fun () -> run_safe (tau arg) ps) - (Some (Ident.string_of_lid (Env.current_module ps.main_context))) - "FStar.Tactics.Interpreter.run_safe" - in - if !dbg_Tac then - BU.print_string "}\n"; - - match res with - | Success (ret, ps) -> - if !dbg_Tac then - do_dump_proofstate ps "at the finish line"; - - (* if !dbg_Tac || Options.tactics_info () then *) - (* BU.print1 "Tactic generated proofterm %s\n" (show w); *) - let remaining_smt_goals = ps.goals@ps.smt_goals in - List.iter - (fun g -> - mark_goal_implicit_already_checked g;//all of these will be fed to SMT anyway - if is_irrelevant g - then ( - if !dbg_Tac then BU.print1 "Assigning irrelevant goal %s\n" (show (goal_witness g)); - if TcRel.teq_nosmt_force (goal_env g) (goal_witness g) U.exp_unit - then () - else failwith (BU.format1 "Irrelevant tactic witness does not unify with (): %s" - (show (goal_witness g))) - )) - remaining_smt_goals; - - // Check that all implicits were instantiated - Errors.with_ctx "While checking implicits left by a tactic" (fun () -> - if !dbg_Tac then - BU.print1 "About to check tactic implicits: %s\n" (FStar.Common.string_of_list - (fun imp -> show imp.imp_uvar) - ps.all_implicits); - - let g = {Env.trivial_guard with TcComm.implicits=Listlike.from_list ps.all_implicits} in - let g = TcRel.solve_deferred_constraints env g in - if !dbg_Tac then - BU.print2 "Checked %s implicits (1): %s\n" - (show (List.length ps.all_implicits)) - (show ps.all_implicits); - let tagged_implicits = TcRel.resolve_implicits_tac env g in - if !dbg_Tac then - BU.print2 "Checked %s implicits (2): %s\n" - (show (List.length ps.all_implicits)) - (show ps.all_implicits); - report_implicits rng_goal tagged_implicits - ); - - (remaining_smt_goals, ret) - - (* Catch normal errors to add a "Tactic failed" at the top. *) - | Failed (Errors.Error (code, msg, rng, ctx), ps) -> - let msg = FStar.Pprint.doc_of_string "Tactic failed" :: msg in - raise (Errors.Error (code, msg, rng, ctx)) - - (* Any other error, including exceptions being raised by the metaprograms. *) - | Failed (e, ps) -> - if ps.dump_on_failure then - do_dump_proofstate ps "at the time of failure"; - let open FStar.Pprint in - let texn_to_doc e = - match e with - | TacticFailure msg -> - msg - | EExn t -> - [doc_of_string <| "Uncaught exception: " ^ (show t)], - None - | e -> - raise e - in - let doc, rng = texn_to_doc e in - let rng = - if background - then match ps.goals with - | g::_ -> g.goal_ctx_uvar.ctx_uvar_range - | _ -> rng_call - else match rng with - | Some r -> r - | _ -> ps.entry_range - in - let open FStar.Pprint in - Err.raise_error rng Err.Fatal_UserTacticFailure - ((if ps.dump_on_failure then [doc_of_string "Tactic failed"] else []) @ doc) - -let run_tactic_on_ps' - (rng_call : Range.range) - (rng_goal : Range.range) - (background : bool) - (e_arg : embedding 'a) - (arg : 'a) - (e_res : embedding 'b) - (tactic:term) - (tactic_already_typed:bool) - (ps:proofstate) - : list goal // remaining goals - & 'b // return value - = - let env = ps.main_context in - if !dbg_Tac then - BU.print2 "Typechecking tactic: (%s) (already_typed: %s) {\n" - (show tactic) - (show tactic_already_typed); - - (* Do NOT use the returned tactic, the typechecker is not idempotent and - * will mess up the monadic lifts. We're just making sure it's well-typed - * so it won't get stuck. c.f #1307 *) - let g = - if tactic_already_typed - then Env.trivial_guard - else let _, _, g = TcTerm.tc_tactic (type_of e_arg) (type_of e_res) env tactic in - g - in - - if !dbg_Tac then - BU.print_string "}\n"; - - TcRel.force_trivial_guard env g; - Err.stop_if_err (); - let tau = unembed_tactic_1 e_arg e_res tactic FStar.Syntax.Embeddings.id_norm_cb in - - run_unembedded_tactic_on_ps - rng_call rng_goal background - arg tau ps - -let run_tactic_on_ps - (rng_call : Range.range) - (rng_goal : Range.range) - (background : bool) - (e_arg : embedding 'a) - (arg : 'a) - (e_res : embedding 'b) - (tactic:term) - (tactic_already_typed:bool) - (ps:proofstate) = - Profiling.profile - (fun () -> run_tactic_on_ps' rng_call rng_goal background e_arg arg e_res tactic tactic_already_typed ps) - (Some (Ident.string_of_lid (Env.current_module ps.main_context))) - "FStar.Tactics.Interpreter.run_tactic_on_ps" diff --git a/src/tactics/FStar.Tactics.Interpreter.fsti b/src/tactics/FStar.Tactics.Interpreter.fsti deleted file mode 100644 index b8a1e6a0697..00000000000 --- a/src/tactics/FStar.Tactics.Interpreter.fsti +++ /dev/null @@ -1,64 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Tactics.Interpreter - -open FStar.Compiler.Effect -open FStar.Compiler.Range -open FStar.Syntax.Syntax -open FStar.Syntax.Embeddings -open FStar.Tactics.Types -module Env = FStar.TypeChecker.Env - -(* Run a `tac` *) -val run_unembedded_tactic_on_ps : - range -> (* position on the tactic call *) - range -> (* position for the goal *) - bool -> (* whether this call is in the "background", like resolve_implicits *) - 'a -> - ('a -> Monad.tac 'b) -> (* a term representing an `'a -> tac 'b` *) - proofstate -> (* proofstate *) - list goal & 'b (* goals and return value *) - -(* Run a term of type `a -> Tac b` *) -val run_tactic_on_ps : - range -> (* position on the tactic call *) - range -> (* position for the goal *) - bool -> (* whether this call is in the "background", like resolve_implicits *) - embedding 'a -> - 'a -> - embedding 'b -> - term -> (* a term representing an `'a -> tac 'b` *) - bool -> (* true if the tactic term is already typechecked *) - proofstate -> (* proofstate *) - list goal & 'b (* goals and return value *) - -(* Only plugins *) -val native_tactics_steps : unit -> list FStar.TypeChecker.Primops.primitive_step - -(* Plugins + primitives. *) -val primitive_steps : unit -> list FStar.TypeChecker.Primops.primitive_step - -val report_implicits : range -> FStar.TypeChecker.Rel.tagged_implicits -> unit - -(* Called by Main *) -val register_tactic_primitive_step : FStar.TypeChecker.Primops.primitive_step -> unit - -open FStar.Tactics.Monad -module NBET = FStar.TypeChecker.NBETerm -val e_tactic_thunk (er : embedding 'r) : embedding (tac 'r) -val e_tactic_nbe_thunk (er : NBET.embedding 'r) : NBET.embedding (tac 'r) -val e_tactic_1 (ea : embedding 'a) (er : embedding 'r) : embedding ('a -> tac 'r) -val e_tactic_nbe_1 (ea : NBET.embedding 'a) (er : NBET.embedding 'r) : NBET.embedding ('a -> tac 'r) diff --git a/src/tactics/FStar.Tactics.Monad.fst b/src/tactics/FStar.Tactics.Monad.fst deleted file mode 100644 index de0e4557679..00000000000 --- a/src/tactics/FStar.Tactics.Monad.fst +++ /dev/null @@ -1,464 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Tactics.Monad - -open FStar -open FStar.Compiler -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Syntax.Syntax -open FStar.TypeChecker.Common -open FStar.TypeChecker.Env -open FStar.Tactics.Types -open FStar.Tactics.Result -open FStar.Tactics.Printing -open FStar.Tactics.Common -open FStar.Errors.Msg - -open FStar.Class.Show -open FStar.Class.Setlike -open FStar.Class.Listlike -module Setlike = FStar.Class.Setlike -module Listlike = FStar.Class.Listlike - -module O = FStar.Options -module BU = FStar.Compiler.Util -module Err = FStar.Errors -module Range = FStar.Compiler.Range -module S = FStar.Syntax.Syntax -module U = FStar.Syntax.Util -module UF = FStar.Syntax.Unionfind -module Print = FStar.Syntax.Print -module Env = FStar.TypeChecker.Env -module Rel = FStar.TypeChecker.Rel -module Core = FStar.TypeChecker.Core - -let dbg_Core = Debug.get_toggle "Core" -let dbg_CoreEq = Debug.get_toggle "CoreEq" -let dbg_RegisterGoal = Debug.get_toggle "RegisterGoal" -let dbg_TacFail = Debug.get_toggle "TacFail" - -let goal_ctr = BU.mk_ref 0 -let get_goal_ctr () = !goal_ctr -let incr_goal_ctr () = let v = !goal_ctr in goal_ctr := v + 1; v - -let is_goal_safe_as_well_typed (g:goal) = - let uv = g.goal_ctx_uvar in - let all_deps_resolved = - List.for_all - (fun uv -> - match UF.find uv.ctx_uvar_head with - | Some t -> Setlike.is_empty (FStar.Syntax.Free.uvars t) - | _ -> false) - (U.ctx_uvar_typedness_deps uv) - in - all_deps_resolved - -let register_goal (g:goal) = - if not (Options.compat_pre_core_should_register()) then () else - let env = goal_env g in - if env.phase1 || Options.lax () then () else - let uv = g.goal_ctx_uvar in - let i = Core.incr_goal_ctr () in - if Allow_untyped? (U.ctx_uvar_should_check g.goal_ctx_uvar) then () else - let env = {env with gamma = uv.ctx_uvar_gamma } in - if !dbg_CoreEq - then BU.print1 "(%s) Registering goal\n" (show i); - let should_register = is_goal_safe_as_well_typed g in - if not should_register - then ( - if !dbg_Core || !dbg_RegisterGoal - then BU.print1 "(%s) Not registering goal since it has unresolved uvar deps\n" - (show i); - - () - ) - else ( - if !dbg_Core || !dbg_RegisterGoal - then BU.print2 "(%s) Registering goal for %s\n" - (show i) - (show uv); - let goal_ty = U.ctx_uvar_typ uv in - match FStar.TypeChecker.Core.compute_term_type_handle_guards env goal_ty (fun _ _ -> true) - with - | Inl _ -> () // ghost is ok - | Inr err -> - let msg = - BU.format2 "Failed to check initial tactic goal %s because %s" - (show (U.ctx_uvar_typ uv)) - (FStar.TypeChecker.Core.print_error_short err) - in - Errors.log_issue uv.ctx_uvar_range Err.Warning_FailedToCheckInitialTacticGoal msg - ) - -(* - * A record, so we can keep it somewhat encapsulated and - * can more easily add things to it if need be. - *) -type tac (a:Type0) = { - tac_f : proofstate -> __result a; -} - -let mk_tac (f : proofstate -> __result 'a) : tac 'a = - { tac_f = f } - -let run (t:tac 'a) (ps:proofstate) : __result 'a = - t.tac_f ps - -let run_safe t ps = - if Options.tactics_failhard () - then run t ps - else try run t ps - with | e -> Failed (e, ps) - -let ret (x:'a) : tac 'a = - mk_tac (fun ps -> Success (x, ps)) - -let bind (t1:tac 'a) (t2:'a -> tac 'b) : tac 'b = - mk_tac (fun ps -> - match run t1 ps with - | Success (a, q) -> run (t2 a) q - | Failed (msg, q) -> Failed (msg, q)) - -instance monad_tac : monad tac = { - return = ret; - ( let! ) = bind; -} - -(* Set the current proofstate *) -let set (ps:proofstate) : tac unit = - mk_tac (fun _ -> Success ((), ps)) - -(* Get the current proof state *) -let get : tac proofstate = - mk_tac (fun ps -> Success (ps, ps)) - -let traise e = - mk_tac (fun ps -> Failed (e, ps)) - -let do_log ps (f : unit -> unit) : unit = - if ps.tac_verb_dbg then - f () - -let log (f : unit -> unit) : tac unit = - mk_tac (fun ps -> - do_log ps f; - Success ((), ps)) - -let fail_doc (msg:error_message) = - mk_tac (fun ps -> - if !dbg_TacFail then - do_dump_proofstate ps ("TACTIC FAILING: " ^ renderdoc (hd msg)); - Failed (TacticFailure (msg, None), ps) - ) - -let fail msg = fail_doc [text msg] - -let catch (t : tac 'a) : tac (either exn 'a) = - mk_tac (fun ps -> - let idtable = !ps.main_context.identifier_info in - let tx = UF.new_transaction () in - match run t ps with - | Success (a, q) -> - UF.commit tx; - Success (Inr a, q) - | Failed (m, q) -> - UF.rollback tx; - ps.main_context.identifier_info := idtable; - let ps = { ps with freshness = q.freshness } in //propagate the freshness even on failures - Success (Inl m, ps) - ) - -let recover (t : tac 'a) : tac (either exn 'a) = - mk_tac (fun ps -> - match run t ps with - | Success (a, q) -> Success (Inr a, q) - | Failed (m, q) -> Success (Inl m, q) - ) - -let trytac (t : tac 'a) : tac (option 'a) = - bind (catch t) (fun r -> - match r with - | Inr v -> ret (Some v) - | Inl _ -> ret None) - -let trytac_exn (t : tac 'a) : tac (option 'a) = - mk_tac (fun ps -> - try run (trytac t) ps - with | Errors.Error (_, msg, _, _) -> - do_log ps (fun () -> BU.print1 "trytac_exn error: (%s)" (Errors.rendermsg msg)); - Success (None, ps)) - -let rec iter_tac f l = - match l with - | [] -> ret () - | hd::tl -> f hd ;! iter_tac f tl - -exception Bad of string - -(* private *) -let nwarn = BU.mk_ref 0 -let check_valid_goal g = - if Options.defensive () then begin - try - let env = (goal_env g) in - if not (Env.closed env (goal_witness g)) then - raise (Bad "witness"); - if not (Env.closed env (goal_type g)) then - raise (Bad "goal type"); - let rec aux e = - match Env.pop_bv e with - | None -> () - | Some (bv, e) -> - if not (Env.closed e bv.sort) then - raise (Bad ("bv: " ^ show bv)); - aux e - in - aux env - with - | Bad culprit -> - if !nwarn < 5 then begin - Err.log_issue (goal_type g) - Errors.Warning_IllFormedGoal - (BU.format2 "The following goal is ill-formed (%s). Keeping calm and carrying on...\n<%s>\n\n" culprit (goal_to_string_verbose g)); - nwarn := !nwarn + 1 - end - end - -let check_valid_goals (gs:list goal) : unit = - if Options.defensive () then - List.iter check_valid_goal gs - -let set_goals (gs:list goal) : tac unit = - bind get (fun ps -> - set ({ ps with goals = gs })) - -let set_smt_goals (gs:list goal) : tac unit = - bind get (fun ps -> - set ({ ps with smt_goals = gs })) - -let cur_goals : tac (list goal) = - bind get (fun ps -> - ret ps.goals) - -let cur_goal_maybe_solved - : tac goal - = bind cur_goals (function - | [] -> fail "No more goals" - | hd::tl -> ret hd) - -let cur_goal : tac goal = - bind cur_goals (function - | [] -> fail "No more goals" - | hd::tl -> - match check_goal_solved' hd with - | None -> ret hd - | Some t -> - BU.print2 "!!!!!!!!!!!! GOAL IS ALREADY SOLVED! %s\nsol is %s\n" - (goal_to_string_verbose hd) - (show t); - ret hd) - -let remove_solved_goals : tac unit = - bind cur_goals (fun gs -> - let gs = List.filter (fun g -> not (check_goal_solved g)) gs in - set_goals gs) - -let dismiss_all : tac unit = set_goals [] - -let dismiss : tac unit = - bind get (fun ps -> - set ({ps with goals=List.tl ps.goals})) - -let replace_cur (g:goal) : tac unit = - bind get (fun ps -> - check_valid_goal g; - set ({ps with goals=g::(List.tl ps.goals)})) - -let getopts : tac FStar.Options.optionstate = - bind (trytac cur_goal_maybe_solved) (function - | Some g -> ret g.opts - | None -> ret (FStar.Options.peek ())) - -(* Some helpers to add goals, while also perhaps checking - * that they are well formed (see check_valid_goal and - * the --defensive debugging option. *) -let add_goals (gs:list goal) : tac unit = - bind get (fun ps -> - check_valid_goals gs; - set ({ps with goals=gs@ps.goals})) - -let add_smt_goals (gs:list goal) : tac unit = - bind get (fun ps -> - check_valid_goals gs; - set ({ps with smt_goals=gs@ps.smt_goals})) - -let push_goals (gs:list goal) : tac unit = - bind get (fun ps -> - check_valid_goals gs; - set ({ps with goals=ps.goals@gs})) - -let push_smt_goals (gs:list goal) : tac unit = - bind get (fun ps -> - check_valid_goals gs; - set ({ps with smt_goals=ps.smt_goals@gs})) -(* /helpers *) - -let add_implicits (i:implicits) : tac unit = - bind get (fun ps -> - set ({ps with all_implicits=i@ps.all_implicits})) - -let new_uvar (reason:string) (env:env) (typ:typ) - (sc_opt:option should_check_uvar) - (uvar_typedness_deps:list ctx_uvar) - (rng:Range.range) - : tac (term & ctx_uvar) = - let should_check = - match sc_opt with - | Some sc -> sc - | _ -> Strict - in - let u, ctx_uvar, g_u = - Env.new_tac_implicit_var reason rng env typ should_check uvar_typedness_deps None false - in - bind (add_implicits (Listlike.to_list g_u.implicits)) (fun _ -> - ret (u, fst ctx_uvar)) - -let mk_irrelevant_goal (reason:string) (env:env) (phi:typ) (sc_opt:option should_check_uvar) (rng:Range.range) opts label : tac goal = - let typ = U.mk_squash (env.universe_of env phi) phi in - bind (new_uvar reason env typ sc_opt [] rng) (fun (_, ctx_uvar) -> - let goal = mk_goal env ctx_uvar opts false label in - ret goal) - -let add_irrelevant_goal' (reason:string) (env:Env.env) - (phi:term) - (sc_opt:option should_check_uvar) - (rng:Range.range) - (opts:FStar.Options.optionstate) - (label:string) : tac unit = - bind (mk_irrelevant_goal reason env phi sc_opt rng opts label) (fun goal -> - add_goals [goal]) - -let add_irrelevant_goal (base_goal:goal) (reason:string) - (env:Env.env) (phi:term) - (sc_opt:option should_check_uvar) : tac unit = - add_irrelevant_goal' reason env phi sc_opt - base_goal.goal_ctx_uvar.ctx_uvar_range - base_goal.opts base_goal.label - -let goal_of_guard (reason:string) (e:Env.env) - (f:term) (sc_opt:option should_check_uvar) - (rng:Range.range) : tac goal = - bind getopts (fun opts -> - bind (mk_irrelevant_goal reason e f sc_opt rng opts "") (fun goal -> - let goal = { goal with is_guard = true } in - ret goal)) - -let wrap_err_doc (pref:error_message) (t : tac 'a) : tac 'a = - mk_tac (fun ps -> - match run t ps with - | Success (a, q) -> - Success (a, q) - - | Failed (TacticFailure (msg, r), q) -> - Failed (TacticFailure (pref @ msg, r), q) - - | Failed (e, q) -> - Failed (e, q) - ) - -let wrap_err (pref:string) (t : tac 'a) : tac 'a = - wrap_err_doc [text ("'" ^ pref ^ "' failed")] t - -let mlog f (cont : unit -> tac 'a) : tac 'a = - log f;! - cont () - -let if_verbose_tac f = - let! ps = get in - if ps.tac_verb_dbg - then f () - else ret () - -let if_verbose f = if_verbose_tac (fun _ -> f(); ret ()) - -let compress_implicits : tac unit = - bind get (fun ps -> - let imps = ps.all_implicits in - let g = { Env.trivial_guard with implicits = Listlike.from_list imps } in - let imps = Rel.resolve_implicits_tac ps.main_context g in - let ps' = { ps with all_implicits = List.map fst imps } in - set ps') - -module N = FStar.TypeChecker.Normalize -let get_phi (g:goal) : option term = U.un_squash (N.unfold_whnf (goal_env g) (goal_type g)) -let is_irrelevant (g:goal) : bool = Option.isSome (get_phi g) -let goal_typedness_deps (g:goal) = U.ctx_uvar_typedness_deps g.goal_ctx_uvar - -let set_uvar_expected_typ (u:ctx_uvar) (t:typ) - : unit - = let dec = UF.find_decoration u.ctx_uvar_head in - UF.change_decoration u.ctx_uvar_head ({dec with uvar_decoration_typ = t }) - -let mark_uvar_with_should_check_tag (u:ctx_uvar) (sc:should_check_uvar) - : unit - = let dec = UF.find_decoration u.ctx_uvar_head in - UF.change_decoration u.ctx_uvar_head ({dec with uvar_decoration_should_check = sc }) - -let mark_uvar_as_already_checked (u:ctx_uvar) - : unit - = mark_uvar_with_should_check_tag u Already_checked - -let mark_goal_implicit_already_checked (g:goal) - : unit - = mark_uvar_as_already_checked g.goal_ctx_uvar - -let goal_with_type g t - : goal - = let u = g.goal_ctx_uvar in - set_uvar_expected_typ u t; - g - -module Z = FStar.BigInt - -let divide (n:Z.t) (l : tac 'a) (r : tac 'b) : tac ('a & 'b) = - let! p = get in - let! lgs, rgs = - try return (List.splitAt (Z.to_int_fs n) p.goals) with - | _ -> fail "divide: not enough goals" - in - let lp = { p with goals = lgs; smt_goals = [] } in - set lp;! - let! a = l in - let! lp' = get in - let rp = { lp' with goals = rgs; smt_goals = [] } in - set rp;! - let! b = r in - let! rp' = get in - let p' = { rp' with goals = lp'.goals @ rp'.goals; - smt_goals = lp'.smt_goals @ rp'.smt_goals @ p.smt_goals } - in - set p';! - remove_solved_goals;! - return (a, b) - -(* focus: runs f on the current goal only, and then restores all the goals *) -(* There is a user defined version as well, we just use this one internally, but can't mark it as private *) -let focus (f:tac 'a) : tac 'a = - let! (a, _) = divide FStar.BigInt.one f (return ()) in - return a diff --git a/src/tactics/FStar.Tactics.Monad.fsti b/src/tactics/FStar.Tactics.Monad.fsti deleted file mode 100644 index eb15a334ee0..00000000000 --- a/src/tactics/FStar.Tactics.Monad.fsti +++ /dev/null @@ -1,172 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Tactics.Monad -open FStar.Pervasives -open FStar.Syntax.Syntax -open FStar.TypeChecker.Env -open FStar.Tactics.Result -open FStar.Tactics.Types -open FStar.Class.Monad -open FStar.Errors.Msg - -module Range = FStar.Compiler.Range -module BU = FStar.Compiler.Util -module O = FStar.Options - -(* Type of tactics *) -val tac (a:Type0) : Type0 - -instance val monad_tac : monad tac - -(* Simply unpack and run *) -val run : tac 'a -> proofstate -> __result 'a - -(* Run, but catch exceptions as errors within the monad *) -val run_safe : tac 'a -> proofstate -> __result 'a - -(* Get current proofstate *) -val get : tac proofstate - -(* Get first goal *) -val cur_goal : tac goal - -(* Raise an exception *) -val traise : exn -> tac 'a - -(* A common failure. *) -val fail_doc : error_message -> tac 'a - -(* A common failure. *) -val fail : string -> tac 'a - -(* Catch exceptions, restore UF graph on a failure *) -val catch : tac 'a -> tac (either exn 'a) - -(* Catch exceptions, but keep UF graph at the time of the failure *) -val recover : tac 'a -> tac (either exn 'a) - -(* Try running a tactic. If it fails, return None. *) -val trytac : tac 'a -> tac (option 'a) - -(* As [trytac], but also catches exceptions and turns them into [None]. *) -val trytac_exn : tac 'a -> tac (option 'a) - -(* iter combinator *) -val iter_tac (f: 'a -> tac unit) (l:list 'a) : tac unit - -(* Defensive checks. Will only do anything if --defensive is on. If so, -and some goal is ill-scoped, they will log a warning. *) -val check_valid_goal (g:goal) : unit -val check_valid_goals (gs:list goal) : unit - -(* Set the current set of goals / SMT goals *) -val set_goals : list goal -> tac unit -val set_smt_goals : list goal -> tac unit - -(* Add goals to the beginning of the list *) -val add_goals : list goal -> tac unit -val add_smt_goals : list goal -> tac unit - -(* Add goals to the end of the list *) -val push_goals : list goal -> tac unit -val push_smt_goals : list goal -> tac unit - -(* Drop the first goal *) -val dismiss : tac unit - -(* Drop all (non-SMT) goals *) -val dismiss_all : tac unit - -(* Replace the current goal with another *) -val replace_cur : goal -> tac unit - -(* Get the option state for the current goal, or the global one -if there are no goals. *) -val getopts : tac FStar.Options.optionstate - -(* Add an implicit to the proofstate. The [all_implicits] field - * is the only place where we keep track of open goals that need - * to be solved. The [goals] and [smt_goals] fields are user-facing, - * and do not really matter for correctness. *) -val add_implicits : implicits -> tac unit - -(* Create a new uvar, and keep track of it in the proofstate to - * ensure we solve it. *) -val new_uvar : string -> env -> typ -> option should_check_uvar -> list ctx_uvar -> Range.range -> tac (term & ctx_uvar) - -(* Create a squashed goal from a given formula *) -val mk_irrelevant_goal : string -> env -> typ -> option should_check_uvar -> Range.range -> O.optionstate -> string -> tac goal - -(* Create an add an irrelevant goal, allows to set options and label *) -val add_irrelevant_goal' : string -> env -> typ -> option should_check_uvar -> Range.range -> O.optionstate -> string -> tac unit - -(* Create an add an irrelevant goal, taking a [base_goal] as a template for - * options and label (which seldom need to be changed) *) -val add_irrelevant_goal : goal -> string -> env -> typ -> option should_check_uvar -> tac unit - -(* Create a goal from a typechecking guard. *) -val goal_of_guard : string -> env -> term -> option should_check_uvar -> Range.range -> tac goal - -(* Run a tactic [t], and if it fails with a [TacticFailure] exception, - * add a prefix to the error message. *) -val wrap_err_doc : pref:error_message -> tac 'a -> tac 'a - -(* Run a tactic [t], and if it fails with a [TacticFailure] exception, - * add a small string prefix to the first component of the error. *) -val wrap_err : pref:string -> tac 'a -> tac 'a - -(* Call a (logging) function is verbose debugging is on *) -val log : (unit -> unit) -> tac unit - -(* As above, but as a tac<> with an implicit bind for brevity (in code that does use -monadic notation...) *) -val mlog : (unit -> unit) -> (unit -> tac 'a) -> tac 'a - -val if_verbose_tac: (unit -> tac unit) -> tac unit -val if_verbose: (unit -> unit) -> tac unit - -(* Discard the implicits in the proofstate that are already - * solved, only matters for performance. *) -val compress_implicits : tac unit - -(* Only leave goals that are unsolved in the main list *) -val remove_solved_goals : tac unit - -val is_goal_safe_as_well_typed (g:goal) : bool - -(* DANGER AHEAD, DO NOT USE *) - -(* Set the proofstate *) -val set : proofstate -> tac unit - -(* Create a tactic *) -val mk_tac : (proofstate -> __result 'a) -> tac 'a - -(* inform the core of a well-typed goal *) -val register_goal (g:goal) : unit - -val divide (n:BigInt.t) (l : tac 'a) (r : tac 'b) : tac ('a & 'b) -val focus (f:tac 'a) : tac 'a - -(* Internal utilities *) -val get_phi : goal -> option term -val is_irrelevant : goal -> bool -val goal_typedness_deps : goal -> list ctx_uvar -val set_uvar_expected_typ (u:ctx_uvar) (t:typ) : unit -val mark_uvar_with_should_check_tag (u:ctx_uvar) (sc:should_check_uvar) : unit -val mark_uvar_as_already_checked (u:ctx_uvar) : unit -val mark_goal_implicit_already_checked (g:goal) : unit -val goal_with_type : goal -> typ -> goal diff --git a/src/tactics/FStar.Tactics.Native.fsti b/src/tactics/FStar.Tactics.Native.fsti deleted file mode 100644 index d2024c304fb..00000000000 --- a/src/tactics/FStar.Tactics.Native.fsti +++ /dev/null @@ -1,35 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Tactics.Native - -open FStar.Compiler.Range -open FStar.Syntax.Syntax -open FStar.Tactics.Types - -module Cfg = FStar.TypeChecker.Cfg -module N = FStar.TypeChecker.Normalize -module PO = FStar.TypeChecker.Primops - -type itac = PO.psc -> FStar.Syntax.Embeddings.norm_cb -> universes -> args -> option term - -type native_primitive_step = - { name: FStar.Ident.lid; - arity: Prims.int; - strong_reduction_ok: bool; - tactic: itac} - -val list_all : unit -> list native_primitive_step diff --git a/src/tactics/FStar.Tactics.Printing.fst b/src/tactics/FStar.Tactics.Printing.fst deleted file mode 100644 index 011b55d20f9..00000000000 --- a/src/tactics/FStar.Tactics.Printing.fst +++ /dev/null @@ -1,176 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Tactics.Printing - -open FStar -open FStar.Compiler -open FStar.Compiler.Util -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Ident -open FStar.Syntax.Syntax -open FStar.TypeChecker.Common -open FStar.TypeChecker.Env -open FStar.Tactics.Types -open FStar.Class.Show - -module BU = FStar.Compiler.Util -module Range = FStar.Compiler.Range -module Options = FStar.Options -module Print = FStar.Syntax.Print -module SS = FStar.Syntax.Subst -module S = FStar.Syntax.Syntax -module Env = FStar.TypeChecker.Env -module U = FStar.Syntax.Util -module Cfg = FStar.TypeChecker.Cfg -module PO = FStar.TypeChecker.Primops - -let dbg_Imp = Debug.get_toggle "Imp" - -let term_to_string (e:Env.env) (t:term) : string = - Print.term_to_string' e.dsenv t - -let goal_to_string_verbose (g:goal) : string = - BU.format2 "%s%s\n" - (show g.goal_ctx_uvar) - (match check_goal_solved' g with - | None -> "" - | Some t -> BU.format1 "\tGOAL ALREADY SOLVED!: %s" (term_to_string (goal_env g) t)) - -let unshadow (bs : binders) (t : term) : binders & term = - (* string name of a bv *) - let sset bv s = S.gen_bv s (Some (range_of_id bv.ppname)) bv.sort in - let fresh_until b f = - let rec aux i = - let t = b ^ "'" ^ show i in - if f t then t else aux (i+1) - in - if f b then b else aux 0 - in - let rec go seen subst bs bs' t = - match bs with - | [] -> List.rev bs', SS.subst subst t - | b::bs -> begin - let b = match SS.subst_binders subst [b] with - | [b] -> b - | _ -> failwith "impossible: unshadow subst_binders" - in - let (bv0, q) = b.binder_bv, b.binder_qual in - let nbs = fresh_until (show bv0.ppname) (fun s -> not (List.mem s seen)) in - let bv = sset bv0 nbs in - let b = S.mk_binder_with_attrs bv q b.binder_positivity b.binder_attrs in - go (nbs::seen) (subst @ [NT (bv0, S.bv_to_name bv)]) bs (b :: bs') t - end - in - go [] [] bs [] t - -let goal_to_string (kind : string) (maybe_num : option (int & int)) (ps:proofstate) (g:goal) : string = - let w = - if Options.print_implicits () - then term_to_string (goal_env g) (goal_witness g) - else match check_goal_solved' g with - | None -> "_" - | Some t -> term_to_string (goal_env g) (goal_witness g) (* shouldn't really happen that we print a solved goal *) - in - let num = match maybe_num with - | None -> "" - | Some (i, n) -> BU.format2 " %s/%s" (show i) (show n) - in - let maybe_label = - match g.label with - | "" -> "" - | l -> " (" ^ l ^ ")" - in - let goal_binders, goal_ty = - let rename_binders subst bs = - bs |> List.map (function b -> - let x = b.binder_bv in - let y = SS.subst subst (S.bv_to_name x) in - match (SS.compress y).n with - | Tm_name y -> - // We don't want to change the type - { b with binder_bv = { b.binder_bv with sort = SS.subst subst x.sort } } - | _ -> failwith "Not a renaming") - in - let goal_binders = g.goal_ctx_uvar.ctx_uvar_binders in - let goal_ty = goal_type g in - if Options.tactic_raw_binders() - then goal_binders, goal_ty - else ( - let subst = PO.psc_subst ps.psc in - let binders = rename_binders subst goal_binders in - let ty = SS.subst subst goal_ty in - binders, ty - ) - in - let goal_binders, goal_ty = unshadow goal_binders goal_ty in - let actual_goal = - if ps.tac_verb_dbg - then goal_to_string_verbose g - else BU.format3 "%s |- %s : %s\n" (String.concat ", " (map Print.binder_to_string_with_type goal_binders)) - w - (term_to_string (goal_env g) goal_ty) - in - BU.format4 "%s%s%s:\n%s\n" kind num maybe_label actual_goal - -(* Note: we use def ranges. In tactics we keep the position in there, while the - * use range is the original position of the assertion / synth / splice. *) -let ps_to_string (msg, ps) = - let p_imp imp = show imp.imp_uvar.ctx_uvar_head in - let n_active = List.length ps.goals in - let n_smt = List.length ps.smt_goals in - let n = n_active + n_smt in - String.concat "" - ([BU.format2 "State dump @ depth %s (%s):\n" (show ps.depth) msg; - (if ps.entry_range <> Range.dummyRange - then BU.format1 "Location: %s\n" (Range.string_of_def_range ps.entry_range) - else ""); - (if !dbg_Imp - then BU.format1 "Imps: %s\n" (FStar.Common.string_of_list p_imp ps.all_implicits) - else "")] - @ (List.mapi (fun i g -> goal_to_string "Goal" (Some (1 + i, n)) ps g) ps.goals) - @ (List.mapi (fun i g -> goal_to_string "SMT Goal" (Some (1 + n_active + i, n)) ps g) ps.smt_goals)) - -let goal_to_json g = - let open FStar.Json in - let g_binders = g.goal_ctx_uvar.ctx_uvar_binders in - let g_type = goal_type g in - let g_binders, g_type = unshadow g_binders g_type in - let j_binders = Print.binders_to_json (Env.dsenv (goal_env g)) g_binders in - JsonAssoc [("hyps", j_binders); - ("goal", JsonAssoc [("witness", JsonStr (term_to_string (goal_env g) (goal_witness g))); - ("type", JsonStr (term_to_string (goal_env g) g_type)); - ("label", JsonStr g.label) - ])] - -let ps_to_json (msg, ps) = - let open FStar.Json in - JsonAssoc ([("label", JsonStr msg); - ("depth", JsonInt ps.depth); - ("urgency", JsonInt ps.urgency); - ("goals", JsonList (List.map goal_to_json ps.goals)); - ("smt-goals", JsonList (List.map goal_to_json ps.smt_goals))] @ - (if ps.entry_range <> Range.dummyRange - then [("location", Range.json_of_def_range ps.entry_range)] - else [])) - -let do_dump_proofstate ps msg = - if not (Options.silent ()) then - Options.with_saved_options (fun () -> - Options.set_option "print_effect_args" (Options.Bool true); - print_generic "proof-state" ps_to_string ps_to_json (msg, ps); - BU.flush_stdout () (* in case this is going to stdout, flush it immediately *) - ) diff --git a/src/tactics/FStar.Tactics.Printing.fsti b/src/tactics/FStar.Tactics.Printing.fsti deleted file mode 100644 index 4bbd38d1769..00000000000 --- a/src/tactics/FStar.Tactics.Printing.fsti +++ /dev/null @@ -1,26 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Tactics.Printing - -open FStar.Tactics.Types - -(* Dump a proofstate into the CLI or Emacs *) -val do_dump_proofstate : proofstate -> string -> unit - -(* Only for deubgging *) -val goal_to_string : string -> option (int & int) -> proofstate -> goal -> string -val goal_to_string_verbose : goal -> string diff --git a/src/tactics/FStar.Tactics.Result.fst b/src/tactics/FStar.Tactics.Result.fst deleted file mode 100644 index 0db7ce2e5cf..00000000000 --- a/src/tactics/FStar.Tactics.Result.fst +++ /dev/null @@ -1,33 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Tactics.Result - -(* NOTE: This file is exactly the same as its .fs/.fsi counterpart. -It is only here so the equally-named interface file in ulib/ is not -taken by the dependency analysis to be the interface of the .fs. We also -cannot ditch the .fs, since out bootstrapping process does not extract -any .ml file from an interface. Hence we keep both, exactly equal to -each other. *) - -// This file *is* extracted (unlike its twin in ulib). - -// This refers to FStar.Tactics.Types.fsi in the current folder, which has the -// full definition of all relevant types (from ulib, we use an different -// interface that hides those definitions). -open FStar.Tactics.Types - -let proofstate = FStar.Tactics.Types.proofstate diff --git a/src/tactics/FStar.Tactics.Result.fsti b/src/tactics/FStar.Tactics.Result.fsti deleted file mode 100644 index f5734ec907e..00000000000 --- a/src/tactics/FStar.Tactics.Result.fsti +++ /dev/null @@ -1,35 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Tactics.Result - -(* NOTE: This file is exactly the same as its .fs/.fsi counterpart. -It is only here so the equally-named interface file in ulib/ is not -taken by the dependency analysis to be the interface of the .fs. We also -cannot ditch the .fs, since out bootstrapping process does not extract -any .ml file from an interface. Hence we keep both, exactly equal to -each other. *) - -// This file *is* extracted (unlike its twin in ulib). - -// This refers to FStar.Tactics.Types.fsi in the current folder, which has the -// full definition of all relevant types (from ulib, we use an different -// interface that hides those definitions). -open FStar.Tactics.Types - -type __result 'a = - | Success of 'a & proofstate - | Failed of exn //error - & proofstate //the proofstate at time of failure diff --git a/src/tactics/FStar.Tactics.Types.fst b/src/tactics/FStar.Tactics.Types.fst deleted file mode 100644 index 4530729499f..00000000000 --- a/src/tactics/FStar.Tactics.Types.fst +++ /dev/null @@ -1,108 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Tactics.Types - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Syntax.Syntax -open FStar.TypeChecker.Env -open FStar.TypeChecker.Common - -module Env = FStar.TypeChecker.Env -module O = FStar.Options -module Range = FStar.Compiler.Range -module U = FStar.Syntax.Util - -let goal_env g = g.goal_main_env -let goal_range g = g.goal_main_env.range -let goal_witness g = - FStar.Syntax.Syntax.mk (Tm_uvar (g.goal_ctx_uvar, ([], NoUseRange))) Range.dummyRange -let goal_type g = U.ctx_uvar_typ g.goal_ctx_uvar -let goal_opts g = g.opts - -let goal_with_env g env : goal = - let c = g.goal_ctx_uvar in - let c' = {c with ctx_uvar_gamma = env.gamma ; ctx_uvar_binders = Env.all_binders env } in - { g with goal_main_env=env; goal_ctx_uvar = c' } - -(* Unsafe? *) -let goal_of_ctx_uvar (g:goal) (ctx_u : ctx_uvar) : goal = - { g with goal_ctx_uvar = ctx_u } - -let mk_goal env u o b l = { - goal_main_env=env; - goal_ctx_uvar=u; - opts=o; - is_guard=b; - label=l; -} - -let goal_of_goal_ty env typ : goal & guard_t = - let u, (ctx_uvar, _) , g_u = - Env.new_implicit_var_aux "proofstate_of_goal_ty" typ.pos env typ Strict None false - in - let g = mk_goal env ctx_uvar (FStar.Options.peek()) false "" in - g, g_u - -let goal_of_implicit env (i:Env.implicit) : goal = - mk_goal ({env with gamma=i.imp_uvar.ctx_uvar_gamma}) i.imp_uvar (FStar.Options.peek()) false i.imp_reason - -let decr_depth (ps:proofstate) : proofstate = - { ps with depth = ps.depth - 1 } - -let incr_depth (ps:proofstate) : proofstate = - { ps with depth = ps.depth + 1 } - -let set_ps_psc psc ps = { ps with psc = psc } - -let tracepoint_with_psc psc ps : bool = - if O.tactic_trace () || (ps.depth <= O.tactic_trace_d ()) then begin - let ps = set_ps_psc psc ps in - ps.__dump ps "TRACE" - end; - true - -let tracepoint ps : bool = - if O.tactic_trace () || (ps.depth <= O.tactic_trace_d ()) then begin - ps.__dump ps "TRACE" - end; - true - -let set_proofstate_range ps r = - { ps with entry_range = Range.set_def_range ps.entry_range (Range.def_range r) } - -let goals_of ps : list goal = ps.goals -let smt_goals_of ps : list goal = ps.smt_goals - -let is_guard g = g.is_guard - -let get_label g = g.label -let set_label l g = { g with label = l } - -let check_goal_solved' goal = - match FStar.Syntax.Unionfind.find goal.goal_ctx_uvar.ctx_uvar_head with - | Some t -> Some t - | None -> None - -let check_goal_solved goal = - Option.isSome (check_goal_solved' goal) - -let non_informative_token (g:env) (t:typ) = unit -let subtyping_token (g:env) (t0 t1:typ) = unit -let equiv_token (g:env) (t0 t1:typ) = unit -let typing_token (g:env) (e:term) (c:Core.tot_or_ghost & typ) = unit -let match_complete_token (g:env) (sc:term) (t:typ) (pats:list pattern) = unit diff --git a/src/tactics/FStar.Tactics.Types.fsti b/src/tactics/FStar.Tactics.Types.fsti deleted file mode 100644 index 8f71dd22900..00000000000 --- a/src/tactics/FStar.Tactics.Types.fsti +++ /dev/null @@ -1,132 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Tactics.Types - -open FStar.Compiler.Effect -open FStar.Syntax.Syntax -open FStar.TypeChecker.Env -open FStar.Tactics.Common - -module BU = FStar.Compiler.Util -module Cfg = FStar.TypeChecker.Cfg -module Core = FStar.TypeChecker.Core -module PO = FStar.TypeChecker.Primops -module Range = FStar.Compiler.Range - -(* - f: x:int -> P - ================== - P - *) -//A goal is typically of the form -// G |- ?u : t -// where context = G -// witness = ?u, although, more generally, witness is a partial solution and can be any term -// goal_ty = t -type goal = { - goal_main_env: env; - goal_ctx_uvar : ctx_uvar; - opts : FStar.Options.optionstate; // option state for this particular goal - is_guard : bool; // Marks whether this goal arose from a guard during tactic runtime - // We make the distinction to be more user-friendly at times - label : string; // A user-defined description -} -type guard_policy = - | Goal - | SMT - | SMTSync - | Force - | ForceSMT - | Drop // unsound - -type proofstate = { - main_context : env; //the shared top-level context for all goals - all_implicits: implicits ; //all the implicits currently open, partially resolved - - // NOTE: Goals are user-settable, the "goals" we mean in - // the paper are the implicits above, these are simply a - // way for primitives to take/give goals, and a way - // to have the SMT goal set. What we should really do - // is go full-LCF and take them as arguments, returning them - // as values. This goal stack should be user-level. - goals : list goal; //all the goals remaining to be solved - smt_goals : list goal; //goals that have been deferred to SMT - - depth : int; //depth for tracing and debugging - __dump : proofstate -> string -> unit; // callback to dump_proofstate, to avoid an annoying circularity - psc : PO.psc; //primitive step context where we started execution - entry_range : Range.range; //position of entry, set by the use - guard_policy : guard_policy; //guard policy: what to do with guards arising during tactic exec - freshness : int; //a simple freshness counter for the fresh tactic - tac_verb_dbg : bool; //whether to print verbose debugging messages - - local_state : BU.psmap term; // local metaprogram state - - urgency : int; // When printing a proofstate due to an error, this - // is used by emacs to decide whether it should pop - // open a buffer or not (default: 1). - - dump_on_failure : bool; // Whether to dump the proofstate to the user when a failure occurs. -} - -val decr_depth : proofstate -> proofstate -val incr_depth : proofstate -> proofstate -val tracepoint_with_psc : PO.psc -> proofstate -> bool -val tracepoint : proofstate -> bool -val set_proofstate_range : proofstate -> Range.range -> proofstate - -val set_ps_psc : PO.psc -> proofstate -> proofstate -val goal_env: goal -> env -val goal_range: goal -> Range.range -val goal_witness: goal -> term -val goal_type: goal -> term -val goal_opts: goal -> Options.optionstate -val goal_with_env: goal -> env -> goal -val is_guard : goal -> bool - -val get_label : goal -> string -val set_label : string -> goal -> goal - -val goals_of : proofstate -> list goal -val smt_goals_of : proofstate -> list goal - -val mk_goal: env -> ctx_uvar -> FStar.Options.optionstate -> bool -> string -> goal - -val goal_of_goal_ty : env -> typ -> goal & guard_t -val goal_of_implicit : env -> implicit -> goal -val goal_of_ctx_uvar: goal -> ctx_uvar -> goal - -type ctrl_flag = - | Continue - | Skip - | Abort - -type direction = - | TopDown - | BottomUp - -val check_goal_solved' : goal -> option term -val check_goal_solved : goal -> bool - -type tref (a:Type) = ref a - -(*** These are here for userspace, the library has an interface into this module. *) -(* Typing reflection *) -val non_informative_token (g:env) (t:typ) : Type0 -val subtyping_token (g:env) (t0 t1:typ) : Type0 -val equiv_token (g:env) (t0 t1:typ) : Type0 -val typing_token (g:env) (e:term) (c:Core.tot_or_ghost & typ) : Type0 -val match_complete_token (g:env) (sc:term) (t:typ) (pats:list pattern) : Type0 diff --git a/src/tactics/FStar.Tactics.V1.Basic.fst b/src/tactics/FStar.Tactics.V1.Basic.fst deleted file mode 100644 index 750d1eedd75..00000000000 --- a/src/tactics/FStar.Tactics.V1.Basic.fst +++ /dev/null @@ -1,2342 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Tactics.V1.Basic - -open FStar -open FStar.Compiler -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Compiler.Util -open FStar.Ident -open FStar.TypeChecker.Env -open FStar.TypeChecker.Common -open FStar.Reflection.V1.Data -open FStar.Reflection.V1.Builtins -open FStar.Tactics.Result -open FStar.Tactics.Types -open FStar.Tactics.Monad -open FStar.Tactics.Printing -open FStar.Syntax.Syntax -open FStar.VConfig -open FStar.Class.Show -open FStar.Class.Tagged -module Listlike = FStar.Class.Listlike - -friend FStar.Pervasives (* to use Delta below *) - -module BU = FStar.Compiler.Util -module Cfg = FStar.TypeChecker.Cfg -module EMB = FStar.Syntax.Embeddings -module Env = FStar.TypeChecker.Env -module Err = FStar.Errors -module N = FStar.TypeChecker.Normalize -module PC = FStar.Parser.Const -module Print = FStar.Syntax.Print -module Free = FStar.Syntax.Free -module Rel = FStar.TypeChecker.Rel -module SF = FStar.Syntax.Free -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module SC = FStar.Syntax.Compress -module TcComm = FStar.TypeChecker.Common -module TcTerm = FStar.TypeChecker.TcTerm -module TcUtil = FStar.TypeChecker.Util -module UF = FStar.Syntax.Unionfind -module U = FStar.Syntax.Util -module Z = FStar.BigInt -module Core = FStar.TypeChecker.Core -module PO = FStar.TypeChecker.Primops - -open FStar.Class.Monad -open FStar.Class.Setlike - -let dbg_2635 = Debug.get_toggle "2635" -let dbg_ReflTc = Debug.get_toggle "ReflTc" -let dbg_Tac = Debug.get_toggle "Tac" -let dbg_TacUnify = Debug.get_toggle "TacUnify" - -let ret #a (x:a) : tac a = return x -let bind #a #b : tac a -> (a -> tac b) -> tac b = ( let! ) -let idtac : tac unit = return () -(* This is so we can use the monad class. But we don't want to -rewrite this whole (deprecated) file. *) - -(* Internal, repeated from V2 too. Could be in Types, but that -constrains dependencies and F* claims a cycle. *) -let get_phi (g:goal) : option term = U.un_squash (N.unfold_whnf (goal_env g) (goal_type g)) -let is_irrelevant (g:goal) : bool = Option.isSome (get_phi g) - -let core_check env sol t must_tot - : either (option typ) Core.error - = if not (Options.compat_pre_core_should_check()) then Inl None else - let debug f = - if Debug.any() - then f () - else () - in - match FStar.TypeChecker.Core.check_term env sol t must_tot with - | Inl None -> - Inl None - - | Inl (Some g) -> - if Options.compat_pre_core_set () //core check the solution, but drop the guard, pre_core - then Inl None - else Inl (Some g) - - - | Inr err -> - debug (fun _ -> - BU.print5 "(%s) Core checking failed (%s) on term %s and type %s\n%s\n" - (show (Env.get_range env)) - (Core.print_error_short err) - (show sol) - (show t) - (Core.print_error err)); - Inr err - -type name = bv -type env = Env.env -type implicits = Env.implicits - -let rangeof g = g.goal_ctx_uvar.ctx_uvar_range - -// Beta reduce -let normalize s e t = N.normalize s e t -let bnorm e t = normalize [] e t -let whnf e t = N.unfold_whnf e t - -(* Use this one for everything the user is supposed to see, EXCEPT - * STATE DUMPS, as it does resugaring. For debug messages, just use plain - * term_to_string, we don't want to cause normalization with debug - * flags. *) -let tts = N.term_to_string - -let set_uvar_expected_typ (u:ctx_uvar) (t:typ) - : unit - = let dec = UF.find_decoration u.ctx_uvar_head in - UF.change_decoration u.ctx_uvar_head ({dec with uvar_decoration_typ = t }) - -let mark_uvar_with_should_check_tag (u:ctx_uvar) (sc:should_check_uvar) - : unit - = let dec = UF.find_decoration u.ctx_uvar_head in - UF.change_decoration u.ctx_uvar_head ({dec with uvar_decoration_should_check = sc }) - -let mark_uvar_as_already_checked (u:ctx_uvar) - : unit - = mark_uvar_with_should_check_tag u Already_checked - -let mark_goal_implicit_already_checked (g:goal) - : unit - = mark_uvar_as_already_checked g.goal_ctx_uvar - -let goal_with_type g t - : goal - = let u = g.goal_ctx_uvar in - set_uvar_expected_typ u t; - g - -let bnorm_goal g = goal_with_type g (bnorm (goal_env g) (goal_type g)) - -let tacprint (s:string) = BU.print1 "TAC>> %s\n" s -let tacprint1 (s:string) x = BU.print1 "TAC>> %s\n" (BU.format1 s x) -let tacprint2 (s:string) x y = BU.print1 "TAC>> %s\n" (BU.format2 s x y) -let tacprint3 (s:string) x y z = BU.print1 "TAC>> %s\n" (BU.format3 s x y z) - -let print (msg:string) : tac unit = - if not (Options.silent ()) then - tacprint msg; - ret () - -let debugging () : tac bool = - bind get (fun ps -> - ret !dbg_Tac) - -let do_dump_ps (msg:string) (ps:proofstate) : unit = - let psc = ps.psc in - let subst = PO.psc_subst psc in - do_dump_proofstate ps msg - -let dump (msg:string) : tac unit = - mk_tac (fun ps -> - do_dump_ps msg ps; - Success ((), ps)) - -let dump_all (print_resolved:bool) (msg:string) : tac unit = - mk_tac (fun ps -> - (* Make a new proofstate with goals for each implicit, - * print it, and return original proofstate unchanged. *) - let gs = List.map (fun i -> goal_of_implicit ps.main_context i) ps.all_implicits in - let gs = - if print_resolved - then gs - else List.filter (fun g -> not (check_goal_solved g)) gs - in - let ps' = { ps with smt_goals = [] ; goals = gs } in - do_dump_ps msg ps'; - Success ((), ps)) - -let dump_uvars_of (g:goal) (msg:string) : tac unit = - mk_tac (fun ps -> - let uvs = SF.uvars (goal_type g) |> elems in - let gs = List.map (goal_of_ctx_uvar g) uvs in - let gs = List.filter (fun g -> not (check_goal_solved g)) gs in - let ps' = { ps with smt_goals = [] ; goals = gs } in - do_dump_ps msg ps'; - Success ((), ps)) - -let fail1 msg x = fail (BU.format1 msg x) -let fail2 msg x y = fail (BU.format2 msg x y) -let fail3 msg x y z = fail (BU.format3 msg x y z) -let fail4 msg x y z w = fail (BU.format4 msg x y z w) - -let destruct_eq' (typ : typ) : option (term & term) = - let open FStar.Syntax.Formula in - match destruct_typ_as_formula typ with - | Some (BaseConn(l, [_; (e1, None); (e2, None)])) - when Ident.lid_equals l PC.eq2_lid - || Ident.lid_equals l PC.c_eq2_lid - -> - Some (e1, e2) - | _ -> - match U.unb2t typ with - | None -> None - | Some t -> - begin - let hd, args = U.head_and_args t in - match (SS.compress hd).n, args with - | Tm_fvar fv, [(_, Some ({ aqual_implicit = true })); (e1, None); (e2, None)] when S.fv_eq_lid fv PC.op_Eq -> - Some (e1, e2) - | _ -> None - end - -let destruct_eq (env : Env.env) (typ : typ) : option (term & term) = -// TODO: unascribe? - let typ = whnf env typ in - match destruct_eq' typ with - | Some t -> Some t - | None -> - // Retry for a squashed one - begin match U.un_squash typ with - | Some typ -> - let typ = whnf env typ in - destruct_eq' typ - | None -> None - end - - -let get_guard_policy () : tac guard_policy = - bind get (fun ps -> ret ps.guard_policy) - -let set_guard_policy (pol : guard_policy) : tac unit = - bind get (fun ps -> set ({ ps with guard_policy = pol })) - -let with_policy pol (t : tac 'a) : tac 'a = - bind (get_guard_policy ()) (fun old_pol -> - bind (set_guard_policy pol) (fun () -> - bind t (fun r -> - bind (set_guard_policy old_pol) (fun () -> - ret r)))) - -let proc_guard' (simplify:bool) (reason:string) (e : env) (g : guard_t) (sc_opt:option should_check_uvar) (rng:Range.range) : tac unit = - mlog (fun () -> - BU.print2 "Processing guard (%s:%s)\n" reason (Rel.guard_to_string e g)) (fun () -> - let imps = Listlike.to_list g.implicits in - let _ = - match sc_opt with - | Some (Allow_untyped r) -> - List.iter - (fun imp -> mark_uvar_with_should_check_tag imp.imp_uvar (Allow_untyped r)) - imps - | _ -> () - in - add_implicits imps ;! - let guard_f = - if simplify - then (Rel.simplify_guard e g).guard_f - else g.guard_f - in - match guard_f with - | TcComm.Trivial -> ret () - | TcComm.NonTrivial f -> - let! ps = get in - match ps.guard_policy with - | Drop -> - // should somehow taint the state instead of just printing a warning - Err.log_issue e Errors.Warning_TacAdmit - (BU.format1 "Tactics admitted guard <%s>\n\n" (Rel.guard_to_string e g)); - ret () - - | Goal -> - mlog (fun () -> BU.print2 "Making guard (%s:%s) into a goal\n" reason (Rel.guard_to_string e g)) (fun () -> - let! g = goal_of_guard reason e f sc_opt rng in - push_goals [g]) - - | SMT -> - mlog (fun () -> BU.print2 "Pushing guard (%s:%s) as SMT goal\n" reason (show f)) (fun () -> - let! g = goal_of_guard reason e f sc_opt rng in - push_smt_goals [g]) - - | SMTSync -> - mlog (fun () -> BU.print2 "Sending guard (%s:%s) to SMT Synchronously\n" reason (show f)) (fun () -> - Rel.force_trivial_guard e g; - ret ()) - - | Force -> - mlog (fun () -> BU.print2 "Forcing guard (%s:%s)\n" reason (Rel.guard_to_string e g)) (fun () -> - try if not (Env.is_trivial <| Rel.discharge_guard_no_smt e g) - then - mlog (fun () -> BU.print1 "guard = %s\n" (Rel.guard_to_string e g)) (fun () -> - fail1 "Forcing the guard failed (%s)" reason) - else ret () - with - | _ -> mlog (fun () -> BU.print1 "guard = %s\n" (Rel.guard_to_string e g)) (fun () -> - fail1 "Forcing the guard failed (%s)" reason))) - -let proc_guard = proc_guard' true - -// -// See if any of the implicits in uvs were solved in a Rel call, -// if so, core check them -// -let tc_unifier_solved_implicits env (must_tot:bool) (allow_guards:bool) (uvs:list ctx_uvar) : tac unit = - let aux (u:ctx_uvar) : tac unit = - let dec = UF.find_decoration u.ctx_uvar_head in - let sc = dec.uvar_decoration_should_check in - match sc with - | Allow_untyped _ -> - ret () - | Already_checked -> - ret () - | _ -> - match UF.find u.ctx_uvar_head with - | None -> - ret () //not solved yet - | Some sol -> //solved, check it - let env = {env with gamma=u.ctx_uvar_gamma} in - let must_tot = must_tot && not (Allow_ghost? dec.uvar_decoration_should_check) in - match core_check env sol (U.ctx_uvar_typ u) must_tot with - | Inl None -> - //checked with no guard - //no need to check it again - mark_uvar_as_already_checked u; - ret () - - | Inl (Some g) -> - let guard = { Env.trivial_guard with guard_f = NonTrivial g } in - let guard = Rel.simplify_guard env guard in - if Options.disallow_unification_guards () - && not allow_guards - && NonTrivial? guard.guard_f - then ( - fail3 "Could not typecheck unifier solved implicit %s to %s since it produced a guard and guards were not allowed;guard is\n%s" - (show u.ctx_uvar_head) - (show sol) - (show g) - ) - else ( - proc_guard' false "guard for implicit" env guard (Some sc) u.ctx_uvar_range ;! - mark_uvar_as_already_checked u; - ret () - ) - - | Inr failed -> - fail3 "Could not typecheck unifier solved implicit %s to %s because %s" - (show u.ctx_uvar_head) - (show sol) - (Core.print_error failed) - in - if env.phase1 //phase1 is untrusted - then ret () - else uvs |> iter_tac aux - -// -// When calling Rel for t1 `rel` t2, caller can choose to tc -// implicits solved during this unification -// With side argument they can control, which side args to check -// E.g. do_match will choose only Right, -// since it fails if some uvar on the left is instantiated -// -type check_unifier_solved_implicits_side = - | Check_none - | Check_left_only - | Check_right_only - | Check_both - -let __do_unify_wflags - (dbg:bool) - (allow_guards:bool) - (must_tot:bool) - (check_side:check_unifier_solved_implicits_side) - (env:env) (t1:term) (t2:term) - : tac (option guard_t) = - if dbg then - BU.print2 "%%%%%%%%do_unify %s =? %s\n" (show t1) - (show t2); - - let all_uvars = - (match check_side with - | Check_none -> empty () - | Check_left_only -> Free.uvars t1 - | Check_right_only -> Free.uvars t2 - | Check_both -> union (Free.uvars t1) (Free.uvars t2)) - |> elems in - - match! - catch (//restore UF graph in case anything fails - bind (trytac cur_goal) (fun gopt -> - try - let res = - if allow_guards - then Rel.try_teq true env t1 t2 - else Rel.teq_nosmt env t1 t2 - in - if dbg then - BU.print3 "%%%%%%%%do_unify (RESULT %s) %s =? %s\n" - (FStar.Common.string_of_option (Rel.guard_to_string env) res) - (show t1) - (show t2); - - match res with - | None -> - ret None - | Some g -> - tc_unifier_solved_implicits env must_tot allow_guards all_uvars;! - add_implicits (Listlike.to_list g.implicits);! - ret (Some g) - - with | Errors.Error (_, msg, r, _) -> begin - mlog (fun () -> BU.print2 ">> do_unify error, (%s) at (%s)\n" - (Errors.rendermsg msg) (show r)) (fun _ -> - ret None) - end - ) - ) - with - | Inl exn -> traise exn - | Inr v -> ret v - -(* Just a wrapper over __do_unify_wflags to better debug *) -let __do_unify - (allow_guards:bool) - (must_tot:bool) - (check_side:check_unifier_solved_implicits_side) - (env:env) (t1:term) (t2:term) - : tac (option guard_t) = - bind idtac (fun () -> - if !dbg_TacUnify then begin - Options.push (); - let _ = Options.set_options "--debug Rel,RelCheck" in - () - end; - bind (__do_unify_wflags !dbg_TacUnify allow_guards must_tot check_side env t1 t2) (fun r -> - if !dbg_TacUnify then Options.pop (); - ret r)) - -(* SMT-free unification. *) -let do_unify_aux - (must_tot:bool) - (check_side:check_unifier_solved_implicits_side) - (env:env) (t1:term) (t2:term) - : tac bool = - bind (__do_unify false must_tot check_side env t1 t2) (function - | None -> ret false - | Some g -> - (* g has to be trivial and we have already added its implicits *) - if not (Env.is_trivial_guard_formula g) then - failwith "internal error: do_unify: guard is not trivial"; - ret true - ) - -let do_unify (must_tot:bool) (env:env) (t1:term) (t2:term) : tac bool = - do_unify_aux must_tot Check_both env t1 t2 - -let do_unify_maybe_guards (allow_guards:bool) (must_tot:bool) - (env:env) (t1:term) (t2:term) - : tac (option guard_t) = - __do_unify allow_guards must_tot Check_both env t1 t2 - -(* Does t1 match t2? That is, do they unify without instantiating/changing t1? *) -let do_match (must_tot:bool) (env:Env.env) (t1:term) (t2:term) : tac bool = - bind (mk_tac (fun ps -> let tx = UF.new_transaction () in - Success (tx, ps))) (fun tx -> - let uvs1 = SF.uvars_uncached t1 in - bind (do_unify_aux must_tot Check_right_only env t1 t2) (fun r -> - if r then begin - let uvs2 = SF.uvars_uncached t1 in - if not (equal uvs1 uvs2) - then (UF.rollback tx; ret false) - else ret true - end - else ret false - )) - -(* This is a bandaid. It's similar to do_match but checks that the -LHS of the equality in [t1] is not instantiated, but the RHS might be. -It is a pain to expose the whole logic to tactics, so we just do it -here for now. *) -let do_match_on_lhs (must_tot:bool) (env:Env.env) (t1:term) (t2:term) : tac bool = - bind (mk_tac (fun ps -> let tx = UF.new_transaction () in - Success (tx, ps))) (fun tx -> - match destruct_eq env t1 with - | None -> fail "do_match_on_lhs: not an eq" - | Some (lhs, _) -> - let uvs1 = SF.uvars_uncached lhs in - bind (do_unify_aux must_tot Check_right_only env t1 t2) (fun r -> - if r then begin - let uvs2 = SF.uvars_uncached lhs in - if not (equal uvs1 uvs2) - then (UF.rollback tx; ret false) - else ret true - end - else ret false - )) - -(* - set_solution: - - Sometimes the witness of a goal is solved by - using a low-level assignment of the unification variable - provided by set_solution. - - The general discipline is that when a trusted primitive tactic - constructs a term to solve the current goal, then it should be - able to just do a set_solution. - - OTOH, if it's a user-provided term to solve the goal, then trysolve is safer - - Note, set_solution is not just an optimization. In cases like `intro` - it is actually important to get the right shape of goal. See the comment there. -*) -let set_solution goal solution : tac unit = - match FStar.Syntax.Unionfind.find goal.goal_ctx_uvar.ctx_uvar_head with - | Some _ -> - fail (BU.format1 "Goal %s is already solved" (goal_to_string_verbose goal)) - | None -> - FStar.Syntax.Unionfind.change goal.goal_ctx_uvar.ctx_uvar_head solution; - mark_goal_implicit_already_checked goal; - ret () - -let trysolve (goal : goal) (solution : term) : tac bool = - let must_tot = true in - do_unify must_tot (goal_env goal) solution (goal_witness goal) - -let solve (goal : goal) (solution : term) : tac unit = - let e = goal_env goal in - mlog (fun () -> BU.print2 "solve %s := %s\n" (show (goal_witness goal)) - (show solution)) (fun () -> - bind (trysolve goal solution) (fun b -> - if b - then bind dismiss (fun () -> remove_solved_goals) - else fail (BU.format3 "%s does not solve %s : %s" - (tts (goal_env goal) solution) - (tts (goal_env goal) (goal_witness goal)) - (tts (goal_env goal) (goal_type goal))))) - - -let solve' (goal : goal) (solution : term) : tac unit = - bind (set_solution goal solution) (fun () -> - bind dismiss (fun () -> - remove_solved_goals)) - -//Any function that directly calls these utilities is also trusted -//End: Trusted utilities -//////////////////////////////////////////////////////////////////// - -//////////////////////////////////////////////////////////////////// -(* Some utilities on goals *) -let is_true t = - let t = U.unascribe t in - match U.un_squash t with - | Some t' -> - let t' = U.unascribe t' in - begin match (SS.compress t').n with - | Tm_fvar fv -> S.fv_eq_lid fv PC.true_lid - | _ -> false - end - | _ -> false - -let is_false t = - match U.un_squash t with - | Some t' -> - begin match (SS.compress t').n with - | Tm_fvar fv -> S.fv_eq_lid fv PC.false_lid - | _ -> false - end - | _ -> false -//////////////////////////////////////////////////////////////////// - - -let tadmit_t (t:term) : tac unit = wrap_err "tadmit_t" <| - bind get (fun ps -> - bind cur_goal (fun g -> - // should somehow taint the state instead of just printing a warning - Err.log_issue (goal_type g) Errors.Warning_TacAdmit - (BU.format1 "Tactics admitted goal <%s>\n\n" (goal_to_string "" None ps g)); - solve' g t)) - -let fresh () : tac Z.t = - bind get (fun ps -> - let n = ps.freshness in - let ps = { ps with freshness = n + 1 } in - bind (set ps) (fun () -> - ret (Z.of_int_fs n))) - -let curms () : tac Z.t = - ret (BU.now_ms () |> Z.of_int_fs) - -(* Annoying duplication here *) -let __tc (e : env) (t : term) : tac (term & typ & guard_t) = - bind get (fun ps -> - mlog (fun () -> BU.print1 "Tac> __tc(%s)\n" (show t)) (fun () -> - let e = {e with uvar_subtyping=false} in - try ret (TcTerm.typeof_tot_or_gtot_term e t true) - with | Errors.Error (_, msg, _, _) -> begin - fail3 "Cannot type (1) %s in context (%s). Error = (%s)" (tts e t) - (Env.all_binders e |> show) - (Errors.rendermsg msg) // FIXME - end)) - -let __tc_ghost (e : env) (t : term) : tac (term & typ & guard_t) = - bind get (fun ps -> - mlog (fun () -> BU.print1 "Tac> __tc_ghost(%s)\n" (show t)) (fun () -> - let e = {e with uvar_subtyping=false} in - let e = {e with letrecs=[]} in - try let t, lc, g = TcTerm.tc_tot_or_gtot_term e t in - ret (t, lc.res_typ, g) - with | Errors.Error (_, msg, _ ,_) -> begin - fail3 "Cannot type (2) %s in context (%s). Error = (%s)" (tts e t) - (Env.all_binders e |> show) - (Errors.rendermsg msg) // FIXME - end)) - -let __tc_lax (e : env) (t : term) : tac (term & lcomp & guard_t) = - bind get (fun ps -> - mlog (fun () -> BU.print2 "Tac> __tc_lax(%s)(Context:%s)\n" - (show t) - (Env.all_binders e |> show)) (fun () -> - let e = {e with uvar_subtyping=false} in - let e = {e with admit = true} in - let e = {e with letrecs=[]} in - try ret (TcTerm.tc_term e t) - with | Errors.Error (_, msg, _, _) -> begin - fail3 "Cannot type (3) %s in context (%s). Error = (%s)" (tts e t) - (Env.all_binders e |> show) - (Errors.rendermsg msg) // FIXME - end)) - -let tcc (e : env) (t : term) : tac comp = wrap_err "tcc" <| - bind (__tc_lax e t) (fun (_, lc, _) -> - (* Why lax? What about the guard? It doesn't matter! tc is only - * a way for metaprograms to query the typechecker, but - * the result has no effect on the proofstate and nor is it - * taken for a fact that the typing is correct. *) - ret (TcComm.lcomp_comp lc |> fst) //dropping the guard from lcomp_comp too! - ) - -let tc (e : env) (t : term) : tac typ = wrap_err "tc" <| - bind (tcc e t) (fun c -> ret (U.comp_result c)) - -let divide (n:Z.t) (l : tac 'a) (r : tac 'b) : tac ('a & 'b) = - bind get (fun p -> - bind (try ret (List.splitAt (Z.to_int_fs n) p.goals) with | _ -> fail "divide: not enough goals") (fun (lgs, rgs) -> - let lp = { p with goals = lgs; smt_goals = [] } in - bind (set lp) (fun _ -> - bind l (fun a -> - bind get (fun lp' -> - let rp = { lp' with goals = rgs; smt_goals = [] } in - bind (set rp) (fun _ -> - bind r (fun b -> - bind get (fun rp' -> - let p' = { rp' with goals=lp'.goals @ rp'.goals; smt_goals = lp'.smt_goals @ rp'.smt_goals @ p.smt_goals } in - bind (set p') (fun _ -> - bind remove_solved_goals (fun () -> - ret (a, b))))))))))) - -(* focus: runs f on the current goal only, and then restores all the goals *) -(* There is a user defined version as well, we just use this one internally, but can't mark it as private *) -let focus (f:tac 'a) : tac 'a = - bind (divide Z.one f idtac) (fun (a, ()) -> ret a) - -(* Applies t to each of the current goals - fails if t fails on any of the goals - collects each result in the output list *) -let rec map (tau:tac 'a): tac (list 'a) = - bind get (fun p -> - match p.goals with - | [] -> ret [] - | _::_ -> - bind (divide Z.one tau (map tau)) (fun (h,t) -> ret (h :: t)) - ) - -(* Applies t1 to the current head goal - And t2 to all the the sub-goals produced by t1 - - Collects the resulting goals of t2 along with the initial auxiliary goals - *) -let seq (t1:tac unit) (t2:tac unit) : tac unit = - focus ( - bind t1 (fun _ -> - bind (map t2) (fun _ -> ret ())) - ) - -let should_check_goal_uvar (g:goal) = U.ctx_uvar_should_check g.goal_ctx_uvar -let goal_typedness_deps (g:goal) = U.ctx_uvar_typedness_deps g.goal_ctx_uvar - -let bnorm_and_replace g = replace_cur (bnorm_goal g) - -let arrow_one (env:Env.env) (t:term) = - match U.arrow_one_ln t with - | None -> None - | Some (b, c) -> - let env, [b], c = FStar.TypeChecker.Core.open_binders_in_comp env [b] c in - Some (env, b, c) - -(* - [intro]: - - Initial goal: G |- ?u : (t -> t') - - Now we do an `intro`: - - Next goal: `G, x:t |- ?v : t'` - - with `?u := (fun (x:t) -> ?v @ [NM(x, 0)])` -*) -let intro () : tac binder = wrap_err "intro" <| ( - let! goal = cur_goal in - match arrow_one (goal_env goal) (whnf (goal_env goal) (goal_type goal)) with - | Some (env', b, c) -> - if not (U.is_total_comp c) - then fail "Codomain is effectful" - else let typ' = U.comp_result c in - //BU.print1 "[intro]: current goal is %s" (goal_to_string goal); - //BU.print1 "[intro]: current goal witness is %s" (show (goal_witness goal)); - //BU.print1 "[intro]: with goal type %s" (show (goal_type goal)); - //BU.print2 "[intro]: with binder = %s, new goal = %s" - // (Print.binders_to_string ", " [b]) - // (show typ'); - let! body, ctx_uvar = - new_uvar "intro" env' typ' - (Some (should_check_goal_uvar goal)) - (goal_typedness_deps goal) - (rangeof goal) in - let sol = U.abs [b] body (Some (U.residual_comp_of_comp c)) in - //BU.print1 "[intro]: solution is %s" - // (show sol); - //BU.print1 "[intro]: old goal is %s" (goal_to_string goal); - //BU.print1 "[intro]: new goal is %s" - // (show ctx_uvar); - //ignore (FStar.Options.set_options "--debug Rel"); - (* Suppose if instead of simply assigning `?u` to the lambda term on - the RHS, we tried to unify `?u` with the `(fun (x:t) -> ?v @ [NM(x, 0)])`. - - Then, this would defeat the purpose of the delayed substitution, since - the unification engine would solve it by doing something like - - `(fun (y:t) -> ?u y) ~ (fun (x:t) -> ?v @ [NM(x, 0)])` - - And then solving - - `?u z ~ ?v @ [NT(x, z)]` - - which would then proceed by solving `?v` to `?w z` and then unifying - `?u` and `?w`. - - I.e., this immediately destroys the nice shape of the next goal. - *) - set_solution goal sol ;! - let g = mk_goal env' ctx_uvar goal.opts goal.is_guard goal.label in - bnorm_and_replace g ;! - ret b - | None -> - fail1 "goal is not an arrow (%s)" (tts (goal_env goal) (goal_type goal)) - ) - - -// TODO: missing: precedes clause, and somehow disabling fixpoints only as needed -let intro_rec () : tac (binder & binder) = - let! goal = cur_goal in - BU.print_string "WARNING (intro_rec): calling this is known to cause normalizer loops\n"; - BU.print_string "WARNING (intro_rec): proceed at your own risk...\n"; - match arrow_one (goal_env goal) (whnf (goal_env goal) (goal_type goal)) with - | Some (env', b, c) -> - if not (U.is_total_comp c) - then fail "Codomain is effectful" - else let bv = gen_bv "__recf" None (goal_type goal) in - let! u, ctx_uvar_u = - new_uvar "intro_rec" env' - (U.comp_result c) - (Some (should_check_goal_uvar goal)) - (goal_typedness_deps goal) - (rangeof goal) in - let lb = U.mk_letbinding (Inl bv) [] (goal_type goal) PC.effect_Tot_lid (U.abs [b] u None) [] Range.dummyRange in - let body = S.bv_to_name bv in - let lbs, body = SS.close_let_rec [lb] body in - let tm = mk (Tm_let {lbs=(true, lbs); body}) (goal_witness goal).pos in - set_solution goal tm ;! - bnorm_and_replace { goal with goal_ctx_uvar=ctx_uvar_u} ;! - ret (S.mk_binder bv, b) - | None -> - fail1 "intro_rec: goal is not an arrow (%s)" (tts (goal_env goal) (goal_type goal)) - -let norm (s : list Pervasives.norm_step) : tac unit = - let! goal = cur_goal in - if_verbose (fun () -> BU.print1 "norm: witness = %s\n" (show (goal_witness goal))) ;! - // Translate to actual normalizer steps - let steps = [Env.Reify; Env.DontUnfoldAttr [PC.tac_opaque_attr]]@(Cfg.translate_norm_steps s) in - //let w = normalize steps (goal_env goal) (goal_witness goal) in - let t = normalize steps (goal_env goal) (goal_type goal) in - replace_cur (goal_with_type goal t) - - -let norm_term_env (e : env) (s : list Pervasives.norm_step) (t : term) : tac term = wrap_err "norm_term" <| ( - let! ps = get in - if_verbose (fun () -> BU.print1 "norm_term_env: t = %s\n" (show t)) ;! - // only for elaborating lifts and all that, we don't care if it's actually well-typed - let! t, _, _ = __tc_lax e t in - let steps = [Env.Reify; Env.DontUnfoldAttr [PC.tac_opaque_attr]]@(Cfg.translate_norm_steps s) in - let t = normalize steps ps.main_context t in - if_verbose (fun () -> BU.print1 "norm_term_env: t' = %s\n" (show t)) ;! - ret t - ) - - -let refine_intro () : tac unit = wrap_err "refine_intro" <| ( - let! g = cur_goal in - match Rel.base_and_refinement (goal_env g) (goal_type g) with - | _, None -> fail "not a refinement" - | t, Some (bv, phi) -> - //Mark goal as untyped, since we're adding its refinement as a separate goal - mark_goal_implicit_already_checked g; - let g1 = goal_with_type g t in - let bv, phi = - let bvs, phi = SS.open_term [S.mk_binder bv] phi in - (List.hd bvs).binder_bv, phi - in - let! g2 = mk_irrelevant_goal "refine_intro refinement" (goal_env g) - (SS.subst [S.NT (bv, (goal_witness g))] phi) - (Some (should_check_goal_uvar g)) - (rangeof g) - g.opts - g.label in - dismiss ;! - add_goals [g1;g2] - ) - -let __exact_now set_expected_typ (t:term) : tac unit = - let! goal = cur_goal in - let env = if set_expected_typ - then Env.set_expected_typ (goal_env goal) (goal_type goal) - else (goal_env goal) - in - let! t, typ, guard = __tc env t in - if_verbose (fun () -> BU.print2 "__exact_now: got type %s\n__exact_now: and guard %s\n" - (show typ) - (Rel.guard_to_string (goal_env goal) guard)) ;! - proc_guard "__exact typing" (goal_env goal) guard (Some (should_check_goal_uvar goal)) (rangeof goal) ;! - if_verbose (fun () -> BU.print2 "__exact_now: unifying %s and %s\n" (show typ) - (show (goal_type goal))) ;! - let! b = do_unify true (goal_env goal) typ (goal_type goal) in - if b - then ( // do unify succeeded with a trivial guard; so the goal is solved and we don't have to check it again - mark_goal_implicit_already_checked goal; - solve goal t - ) - else - let typ, goalt = TypeChecker.Err.print_discrepancy (tts (goal_env goal)) typ (goal_type goal) in - fail4 "%s : %s does not exactly solve the goal %s (witness = %s)" - (tts (goal_env goal) t) - typ - goalt - (tts (goal_env goal) (goal_witness goal)) - -let t_exact try_refine set_expected_typ tm : tac unit = wrap_err "exact" <| ( - if_verbose (fun () -> BU.print1 "t_exact: tm = %s\n" (show tm)) ;! - match! catch (__exact_now set_expected_typ tm) with - | Inr r -> ret r - | Inl e when not (try_refine) -> traise e - | Inl e -> - if_verbose (fun () -> BU.print_string "__exact_now failed, trying refine...\n") ;! - match! catch (norm [Pervasives.Delta] ;! refine_intro () ;! __exact_now set_expected_typ tm) with - | Inr r -> - if_verbose (fun () -> BU.print_string "__exact_now: failed after refining too\n") ;! - ret r - | Inl _ -> - if_verbose (fun () -> BU.print_string "__exact_now: was not a refinement\n") ;! - traise e) - -(* Can t1 unify t2 if it's applied to arguments? If so return uvars for them *) -(* NB: Result is reversed, which helps so we use fold_right instead of fold_left *) -let try_unify_by_application (should_check:option should_check_uvar) - (only_match:bool) - (e : env) - (ty1 : term) - (ty2 : term) - (rng:Range.range) - : tac (list (term & aqual & ctx_uvar)) - = let f = if only_match then do_match else do_unify in - let must_tot = true in - let rec aux (acc : list (term & aqual & ctx_uvar)) - (typedness_deps : list ctx_uvar) //map proj_3 acc - (ty1:term) - : tac (list (term & aqual & ctx_uvar)) - = match! f must_tot e ty2 ty1 with - | true -> ret acc (* Done! *) - | false -> - (* Not a match, try instantiating the first type by application *) - match U.arrow_one ty1 with - | None -> - fail2 "Could not instantiate, %s to %s" (tts e ty1) (tts e ty2) - - | Some (b, c) -> - if not (U.is_total_comp c) then fail "Codomain is effectful" else - let! uvt, uv = new_uvar "apply arg" e b.binder_bv.sort should_check typedness_deps rng in - if_verbose (fun () -> BU.print1 "t_apply: generated uvar %s\n" (show uv)) ;! - let typ = U.comp_result c in - let typ' = SS.subst [S.NT (b.binder_bv, uvt)] typ in - aux ((uvt, U.aqual_of_binder b, uv)::acc) (uv::typedness_deps) typ' - in - aux [] [] ty1 - -// -// Goals for implicits created during apply -// -let apply_implicits_as_goals - (env:Env.env) - (gl:option goal) - (imps:list (term & ctx_uvar)) - : tac (list (list goal)) = - - let one_implicit_as_goal (term, ctx_uvar) = - let hd, _ = U.head_and_args term in - match (SS.compress hd).n with - | Tm_uvar (ctx_uvar, _) -> - let gl = - match gl with - | None -> mk_goal env ctx_uvar (FStar.Options.peek()) true "goal for unsolved implicit" - | Some gl -> { gl with goal_ctx_uvar = ctx_uvar } in //TODO: AR: what's happening here? - let gl = bnorm_goal gl in - ret [gl] - | _ -> - // - // This implicits has already been solved - // We would have typechecked its solution already, - // just after the Rel call - // - ret [] - in - imps |> mapM one_implicit_as_goal - -// uopt: Don't add goals for implicits that appear free in posterior goals. -// This is very handy for users, allowing to turn -// -// |- a = c -// -// by applying transivity to -// -// |- a = ?u -// |- ?u = c -// -// without asking for |- ?u : Type first, which will most likely be instantiated when -// solving any of these two goals. In any case, if ?u is not solved, we will later fail. -// TODO: this should probably be made into a user tactic -let t_apply (uopt:bool) (only_match:bool) (tc_resolved_uvars:bool) (tm:term) : tac unit = wrap_err "apply" <| ( - let tc_resolved_uvars = true in - if_verbose - (fun () -> BU.print4 "t_apply: uopt %s, only_match %s, tc_resolved_uvars %s, tm = %s\n" - (show uopt) - (show only_match) - (show tc_resolved_uvars) - (show tm)) ;! - let! ps = get in - let! goal = cur_goal in - let e = goal_env goal in - let should_check = should_check_goal_uvar goal in - Tactics.Monad.register_goal goal; - let! tm, typ, guard = __tc e tm in - if_verbose - (fun () -> BU.print5 "t_apply: tm = %s\nt_apply: goal = %s\nenv.gamma=%s\ntyp=%s\nguard=%s\n" - (show tm) - (goal_to_string_verbose goal) - (show e.gamma) - (show typ) - (Rel.guard_to_string e guard)) ;! - // Focus helps keep the goal order - let typ = bnorm e typ in - let! uvs = try_unify_by_application (Some should_check) only_match e typ (goal_type goal) (rangeof goal) in - if_verbose - (fun () -> BU.print1 "t_apply: found args = %s\n" - (FStar.Common.string_of_list (fun (t, _, _) -> show t) uvs)) ;! - let w = List.fold_right (fun (uvt, q, _) w -> U.mk_app w [(uvt, q)]) uvs tm in - let uvset = - List.fold_right - (fun (_, _, uv) s -> union s (SF.uvars (U.ctx_uvar_typ uv))) - uvs - (empty ()) - in - let free_in_some_goal uv = mem uv uvset in - solve' goal w ;! - // - //process uvs - //first, if some of them are solved already, perhaps during unification, - // typecheck them if tc_resolved_uvars is on - //then, if uopt is on, filter out those that appear in other goals - //add the rest as goals - // - let uvt_uv_l = uvs |> List.map (fun (uvt, _q, uv) -> (uvt, uv)) in - let! sub_goals = - apply_implicits_as_goals e (Some goal) uvt_uv_l in - let sub_goals = List.flatten sub_goals - |> List.filter (fun g -> - //if uopt is on, we don't keep uvars that - // appear in some other goals - not (uopt && free_in_some_goal g.goal_ctx_uvar)) - |> List.map bnorm_goal - |> List.rev in - add_goals sub_goals ;! - proc_guard "apply guard" e guard (Some should_check) (rangeof goal) - ) - -// returns pre and post -let lemma_or_sq (c : comp) : option (term & term) = - let eff_name, res, args = U.comp_eff_name_res_and_args c in - if lid_equals eff_name PC.effect_Lemma_lid then - let pre, post = match args with - | pre::post::_ -> fst pre, fst post - | _ -> failwith "apply_lemma: impossible: not a lemma" - in - // Lemma post is thunked - let post = U.mk_app post [S.as_arg U.exp_unit] in - Some (pre, post) - else if U.is_pure_effect eff_name - || U.is_ghost_effect eff_name then - map_opt (U.un_squash res) (fun post -> (U.t_true, post)) - else - None - -let rec fold_left (f : ('a -> 'b -> tac 'b)) (e : 'b) (xs : list 'a) : tac 'b = - match xs with - | [] -> ret e - | x::xs -> bind (f x e) (fun e' -> fold_left f e' xs) - -let t_apply_lemma (noinst:bool) (noinst_lhs:bool) - (tm:term) : tac unit = wrap_err "apply_lemma" <| focus ( - let! ps = get in - if_verbose (fun () -> BU.print1 "apply_lemma: tm = %s\n" (show tm)) ;! - let is_unit_t t = - match (SS.compress t).n with - | Tm_fvar fv when S.fv_eq_lid fv PC.unit_lid -> true - | _ -> false - in - let! goal = cur_goal in - let env = goal_env goal in - Tactics.Monad.register_goal goal; - let! tm, t, guard = __tc env tm in - let bs, comp = U.arrow_formals_comp t in - match lemma_or_sq comp with - | None -> fail "not a lemma or squashed function" - | Some (pre, post) -> - let! uvs, _, implicits, subst = - fold_left - (fun ({binder_bv=b;binder_qual=aq}) (uvs, deps, imps, subst) -> - let b_t = SS.subst subst b.sort in - if is_unit_t b_t - then - // Simplification: if the argument is simply unit, then don't ask for it - ret <| ((U.exp_unit, aq)::uvs, deps, imps, S.NT(b, U.exp_unit)::subst) - else - let! t, u = new_uvar "apply_lemma" env b_t - (goal - |> should_check_goal_uvar - |> (function | Strict -> Allow_ghost "apply lemma uvar" - | x -> x) - |> Some) - deps - (rangeof goal) in - if Debug.medium () || !dbg_2635 - then - BU.print2 "Apply lemma created a new uvar %s while applying %s\n" - (show u) - (show tm); - ret ((t, aq)::uvs, u::deps, (t, u)::imps, S.NT(b, t)::subst)) - ([], [], [], []) - bs - in - let implicits = List.rev implicits in - let uvs = List.rev uvs in - let pre = SS.subst subst pre in - let post = SS.subst subst post in - let post_u = env.universe_of env post in - let cmp_func = - if noinst then do_match - else if noinst_lhs then do_match_on_lhs - else do_unify - in - let! b = - let must_tot = false in - cmp_func must_tot env (goal_type goal) (U.mk_squash post_u post) in - if not b - then ( - let post, goalt = TypeChecker.Err.print_discrepancy (tts env) - (U.mk_squash post_u post) - (goal_type goal) in - fail3 "Cannot instantiate lemma %s (with postcondition: %s) to match goal (%s)" - (tts env tm) post goalt - ) - else ( - // We solve with (), we don't care about the witness if applying a lemma - let goal_sc = should_check_goal_uvar goal in - solve' goal U.exp_unit ;! - let is_free_uvar uv t = - let free_uvars = List.map (fun x -> x.ctx_uvar_head) (elems (SF.uvars t)) in - List.existsML (fun u -> UF.equiv u uv) free_uvars - in - let appears uv goals = List.existsML (fun g' -> is_free_uvar uv (goal_type g')) goals in - let checkone t goals = - let hd, _ = U.head_and_args t in - begin match hd.n with - | Tm_uvar (uv, _) -> appears uv.ctx_uvar_head goals - | _ -> false - end - in - let must_tot = false in - let! sub_goals = - apply_implicits_as_goals env (Some goal) implicits in - let sub_goals = List.flatten sub_goals in - // Optimization: if a uvar appears in a later goal, don't ask for it, since - // it will be instantiated later. It is tracked anyway in ps.implicits - let rec filter' (f : 'a -> list 'a -> bool) (xs : list 'a) : list 'a = - match xs with - | [] -> [] - | x::xs -> if f x xs then x::(filter' f xs) else filter' f xs - in - let sub_goals = filter' (fun g goals -> not (checkone (goal_witness g) goals)) sub_goals in - proc_guard "apply_lemma guard" env guard (Some goal_sc) (rangeof goal) ;! - let pre_u = env.universe_of env pre in - (match (Rel.simplify_guard env (Env.guard_of_guard_formula (NonTrivial pre))).guard_f with - | Trivial -> ret () - | NonTrivial _ -> add_irrelevant_goal goal "apply_lemma precondition" env pre (Some goal_sc)) ;!//AR: should we use the normalized pre instead? - add_goals sub_goals - ) - ) - -let split_env (bvar : bv) (e : env) : option (env & bv & list bv) = - let rec aux e = - match Env.pop_bv e with - | None -> None - | Some (bv', e') -> - if S.bv_eq bvar bv' - then Some (e', bv', []) - else map_opt (aux e') (fun (e'', bv, bvs) -> (e'', bv, bv'::bvs )) - in - map_opt (aux e) (fun (e', bv, bvs) -> (e', bv, List.rev bvs)) - -let subst_goal (b1 : bv) (b2 : bv) (g:goal) : tac (option (bv & goal)) = - match split_env b1 (goal_env g) with - | Some (e0, b1, bvs) -> - let bs = List.map S.mk_binder (b1::bvs) in - - let t = goal_type g in - - (* Close the binders and t *) - let bs', t' = SS.close_binders bs, SS.close bs t in - - (* Replace b1 (the head) by b2 *) - let bs' = S.mk_binder b2 :: List.tail bs' in - - (* Re-open, all done for renaming *) - let new_env, bs'', t'' = Core.open_binders_in_term e0 bs' t' in - - // (* b2 has been freshened *) - let b2 = (List.hd bs'').binder_bv in - - // (* Make a new goal in the new env (with new binders) *) - let! uvt, uv = new_uvar "subst_goal" new_env t'' - (Some (should_check_goal_uvar g)) - (goal_typedness_deps g) - (rangeof g) in - - let goal' = mk_goal new_env uv g.opts g.is_guard g.label in - - (* Solve the old goal with an application of the new witness *) - let sol = U.mk_app (U.abs bs'' uvt None) - (List.map (fun ({binder_bv=bv;binder_qual=q}) -> S.as_arg (S.bv_to_name bv)) bs) in - - set_solution g sol ;! - - ret (Some (b2, goal')) - - | None -> - ret None - -let rewrite (h:binder) : tac unit = wrap_err "rewrite" <| ( - let! goal = cur_goal in - let bv = h.binder_bv in - if_verbose (fun _ -> BU.print2 "+++Rewrite %s : %s\n" (show bv) (show bv.sort)) ;! - match split_env bv (goal_env goal) with - | None -> fail "binder not found in environment" - | Some (e0, bv, bvs) -> - begin - match destruct_eq e0 bv.sort with - | Some (x, e) -> - begin - match (SS.compress x).n with - | Tm_name x -> - let s = [NT(x, e)] in - - (* See subst_goal for an explanation *) - let t = goal_type goal in - let bs = List.map S.mk_binder bvs in - - let bs', t' = SS.close_binders bs, SS.close bs t in - let bs', t' = SS.subst_binders s bs', SS.subst s t' in - let e0 = Env.push_bvs e0 [bv] in - let new_env, bs'', t'' = Core.open_binders_in_term e0 bs' t' in - - let! uvt, uv = - new_uvar "rewrite" new_env t'' - (Some (should_check_goal_uvar goal)) - (goal_typedness_deps goal) - (rangeof goal) - in - let goal' = mk_goal new_env uv goal.opts goal.is_guard goal.label in - let sol = U.mk_app (U.abs bs'' uvt None) - (List.map (fun ({binder_bv=bv}) -> S.as_arg (S.bv_to_name bv)) bs) in - - (* See comment in subst_goal *) - set_solution goal sol ;! - replace_cur goal' - - | _ -> - fail "Not an equality hypothesis with a variable on the LHS" - end - | _ -> fail "Not an equality hypothesis" - end - ) - -let rename_to (b : binder) (s : string) : tac binder = wrap_err "rename_to" <| ( - let! goal = cur_goal in - let bv = b.binder_bv in - let bv' = freshen_bv ({ bv with ppname = mk_ident (s, (range_of_id bv.ppname)) }) in - match! subst_goal bv bv' goal with - | None -> fail "binder not found in environment" - | Some (bv', goal) -> - replace_cur goal ;! - ret {b with binder_bv=bv'} - ) - -let binder_retype (b : binder) : tac unit = wrap_err "binder_retype" <| ( - let! goal = cur_goal in - let bv = b.binder_bv in - match split_env bv (goal_env goal) with - | None -> fail "binder is not present in environment" - | Some (e0, bv, bvs) -> - let (ty, u) = U.type_u () in - let goal_sc = should_check_goal_uvar goal in - let! t', u_t' = - new_uvar "binder_retype" e0 ty - (Some goal_sc) - (goal_typedness_deps goal) - (rangeof goal) - in - let bv'' = {bv with sort = t'} in - let s = [S.NT (bv, S.bv_to_name bv'')] in - let bvs = List.map (fun b -> { b with sort = SS.subst s b.sort }) bvs in - let env' = Env.push_bvs e0 (bv''::bvs) in - dismiss ;! - let new_goal = - goal_with_type - (goal_with_env goal env') - (SS.subst s (goal_type goal)) - in - add_goals [new_goal] ;! - add_irrelevant_goal goal "binder_retype equation" e0 - (U.mk_eq2 (U_succ u) ty bv.sort t') - (Some goal_sc) - ) - -(* TODO: move to bv *) -let norm_binder_type (s : list Pervasives.norm_step) (b : binder) : tac unit = wrap_err "norm_binder_type" <| ( - let! goal = cur_goal in - let bv = b.binder_bv in - match split_env bv (goal_env goal) with - | None -> fail "binder is not present in environment" - | Some (e0, bv, bvs) -> - let steps = [Env.Reify; Env.DontUnfoldAttr [PC.tac_opaque_attr]]@(Cfg.translate_norm_steps s) in - let sort' = normalize steps e0 bv.sort in - let bv' = { bv with sort = sort' } in - let env' = Env.push_bvs e0 (bv'::bvs) in - replace_cur (goal_with_env goal env') - ) - -let revert () : tac unit = - let! goal = cur_goal in - match Env.pop_bv (goal_env goal) with - | None -> fail "Cannot revert; empty context" - | Some (x, env') -> - let typ' = U.arrow [S.mk_binder x] (mk_Total (goal_type goal)) in - let! r, u_r = - new_uvar "revert" env' typ' - (Some (should_check_goal_uvar goal)) - (goal_typedness_deps goal) - (rangeof goal) in - set_solution goal (S.mk_Tm_app r [S.as_arg (S.bv_to_name x)] (goal_type goal).pos) ;! - let g = mk_goal env' u_r goal.opts goal.is_guard goal.label in - replace_cur g - -let free_in bv t = mem bv (SF.names t) - -let clear (b : binder) : tac unit = - let bv = b.binder_bv in - let! goal = cur_goal in - if_verbose (fun () -> BU.print2 "Clear of (%s), env has %s binders\n" - (show b) - (Env.all_binders (goal_env goal) |> List.length |> show)) ;! - match split_env bv (goal_env goal) with - | None -> fail "Cannot clear; binder not in environment" - | Some (e', bv, bvs) -> - let rec check bvs = - match bvs with - | [] -> ret () - | bv'::bvs -> - if free_in bv bv'.sort - then fail (BU.format1 "Cannot clear; binder present in the type of %s" - (show bv')) - else check bvs - in - if free_in bv (goal_type goal) then - fail "Cannot clear; binder present in goal" - else ( - check bvs ;! - let env' = Env.push_bvs e' bvs in - let! ut, uvar_ut = - new_uvar "clear.witness" env' (goal_type goal) - (Some (should_check_goal_uvar goal)) - (goal_typedness_deps goal) - (rangeof goal) in - set_solution goal ut ;! - replace_cur (mk_goal env' uvar_ut goal.opts goal.is_guard goal.label) - ) - -let clear_top () : tac unit = - let! goal = cur_goal in - match Env.pop_bv (goal_env goal) with - | None -> fail "Cannot clear; empty context" - | Some (x, _) -> clear (S.mk_binder x) // we ignore the qualifier anyway - -let prune (s:string) : tac unit = - let! g = cur_goal in - let ctx = goal_env g in - let ctx' = Env.rem_proof_ns ctx (path_of_text s) in - let g' = goal_with_env g ctx' in - replace_cur g' - -let addns (s:string) : tac unit = - let! g = cur_goal in - let ctx = goal_env g in - let ctx' = Env.add_proof_ns ctx (path_of_text s) in - let g' = goal_with_env g ctx' in - replace_cur g' - -let guard_formula (g:guard_t) : term = - match g.guard_f with - | Trivial -> U.t_true - | NonTrivial f -> f - -let _t_trefl (allow_guards:bool) (l : term) (r : term) : tac unit = - let should_register_trefl g = - let should_register = true in - let skip_register = false in - if not (Options.compat_pre_core_should_register()) then skip_register else - //Sending a goal t1 == t2 to the core for registration can be expensive - //particularly if the terms are big, e.g., when they are WPs etc - //This function decides which goals to register, using two criteria - //1. If the uvars in the goal are Allow_untyped or Already_checked - // then don't bother registering, since we will not recheck the solution. - // - //2. If the goal is of the form `eq2 #ty ?u t` (or vice versa) - // and we can prove that ty <: ?u.t - // then the assignment of `?u := t` is going to be well-typed - // without needing to recompute the type of `t` - let is_uvar_untyped_or_already_checked u = - let dec = UF.find_decoration u.ctx_uvar_head in - match dec.uvar_decoration_should_check with - | Allow_untyped _ - | Already_checked -> true - | _ -> false - in - let is_uvar t = - let head = U.leftmost_head t in - match (SS.compress head).n with - | Tm_uvar (u, _) -> Inl (u, head, t) - | _ -> Inr t - in - let is_allow_untyped_uvar t = - match is_uvar t with - | Inr _ -> false - | Inl (u, _, _) -> is_uvar_untyped_or_already_checked u - in - let t = U.ctx_uvar_typ g.goal_ctx_uvar in - let uvars = elems (FStar.Syntax.Free.uvars t) in - if BU.for_all is_uvar_untyped_or_already_checked uvars - then skip_register //all the uvars are already checked or untyped - else ( - let head, args = - let t = - match U.un_squash t with - | None -> t - | Some t -> t - in - U.leftmost_head_and_args t - in - match (SS.compress (U.un_uinst head)).n, args with - | Tm_fvar fv, [(ty, _); (t1, _); (t2, _)] - when S.fv_eq_lid fv PC.eq2_lid -> - if is_allow_untyped_uvar t1 || is_allow_untyped_uvar t2 - then skip_register //if we have ?u=t or t=?u and ?u is allow_untyped, then skip - else if Tactics.Monad.is_goal_safe_as_well_typed g //o.w., if the goal is well typed - then ( - //and the goal is of the shape - // eq2 #ty ?u t or - // eq2 #ty t ?u - // Then solving this, if it succeeds, is going to assign ?u := t - // If we know that `ty <: ?u.ty` then this is well-typed already - // without needing to recheck the assignment - // Note, from well-typedness of the goal, we already know ?u.ty <: ty - let check_uvar_subtype u t = - let env = { goal_env g with gamma = g.goal_ctx_uvar.ctx_uvar_gamma } in - match Core.compute_term_type_handle_guards env t (fun _ _ -> true) - with - | Inr _ -> false - | Inl (_, t_ty) -> ( // ignoring the effect, ghost is ok - match Core.check_term_subtyping true true env ty t_ty with - | Inl None -> //unconditional subtype - mark_uvar_as_already_checked u; - true - | _ -> - false - ) - in - match is_uvar t1, is_uvar t2 with - | Inl (u, _, tu), Inr _ - | Inr _, Inl (u, _, tu) -> - //if the condition fails, then return true to register this goal - //since the assignment will have to be rechecked - if check_uvar_subtype u tu - then skip_register - else should_register - | _ -> - should_register - ) - else should_register - | _ -> - should_register - ) - in - let! g = cur_goal in - let should_check = should_check_goal_uvar g in - if should_register_trefl g - then Tactics.Monad.register_goal g; - let must_tot = true in - let attempt (l : term) (r : term) : tac bool = - match! do_unify_maybe_guards allow_guards must_tot (goal_env g) l r with - | None -> ret false - | Some guard -> - solve' g U.exp_unit ;! - if allow_guards - then - let! goal = goal_of_guard "t_trefl" (goal_env g) (guard_formula guard) (Some should_check) (rangeof g) in - push_goals [goal] ;! - ret true - else - // If allow_guards is false, this guard must be trivial and we don't - // add it, but we check its triviality for sanity. - if Env.is_trivial_guard_formula guard - then ret true - else failwith "internal error: _t_refl: guard is not trivial" - in - match! attempt l r with - | true -> ret () - | false -> - (* if that didn't work, normalize and retry *) - let norm = N.normalize [Env.UnfoldUntil delta_constant; Env.Primops; Env.DontUnfoldAttr [PC.tac_opaque_attr]] (goal_env g) in - match! attempt (norm l) (norm r) with - | true -> ret () - | false -> - let ls, rs = TypeChecker.Err.print_discrepancy (tts (goal_env g)) l r in - fail2 "cannot unify (%s) and (%s)" ls rs - -let t_trefl (allow_guards:bool) : tac unit = wrap_err "t_trefl" <| ( - match! - catch (//restore UF graph, including any Already_checked markers, if anything fails - let! g = cur_goal in - match destruct_eq (goal_env g) (goal_type g) with - | Some (l, r) -> - _t_trefl allow_guards l r - | None -> - fail1 "not an equality (%s)" (tts (goal_env g) (goal_type g)) - ) - with - | Inr v -> ret v - | Inl exn -> traise exn - ) - -let dup () : tac unit = - let! g = cur_goal in - let goal_sc = should_check_goal_uvar g in - let env = goal_env g in - let! u, u_uvar = - new_uvar "dup" env (goal_type g) - (Some (should_check_goal_uvar g)) - (goal_typedness_deps g) - (rangeof g) in - //the new uvar is just as Strict as the original one. So, its assignement will be checked - //and we have a goal that requires us to prove it equal to the original uvar - //so we can clear the should_check status of the current uvar - mark_uvar_as_already_checked g.goal_ctx_uvar; - let g' = { g with goal_ctx_uvar = u_uvar } in - dismiss ;! - let t_eq = U.mk_eq2 (env.universe_of env (goal_type g)) (goal_type g) u (goal_witness g) in - add_irrelevant_goal g "dup equation" env t_eq (Some goal_sc) ;! - add_goals [g'] - -// longest_prefix f l1 l2 = (p, r1, r2) ==> l1 = p@r1 /\ l2 = p@r2 -let longest_prefix (f : 'a -> 'a -> bool) (l1 : list 'a) (l2 : list 'a) : list 'a & list 'a & list 'a = - let rec aux acc l1 l2 = - match l1, l2 with - | x::xs, y::ys -> - if f x y - then aux (x::acc) xs ys - else acc, x::xs, y::ys - | _ -> - acc, l1, l2 - in - let pr, t1, t2 = aux [] l1 l2 in - List.rev pr, t1, t2 - -// NOTE: duplicated from V2.Basic. Should remove this whole module eventually. -let eq_binding b1 b2 = - match b1, b2 with - | S.Binding_var bv1, Binding_var bv2 -> bv_eq bv1 bv2 && U.term_eq bv1.sort bv2.sort - | S.Binding_lid (lid1, _), Binding_lid (lid2, _) -> lid_equals lid1 lid2 - | S.Binding_univ u1, Binding_univ u2 -> ident_equals u1 u2 - | _ -> false - -// fix universes -let join_goals g1 g2 : tac goal = - (* The one in Syntax.Util ignores null_binders, why? *) - let close_forall_no_univs bs f = - List.fold_right (fun b f -> U.mk_forall_no_univ b.binder_bv f) bs f - in - match get_phi g1 with - | None -> fail "goal 1 is not irrelevant" - | Some phi1 -> - match get_phi g2 with - | None -> fail "goal 2 is not irrelevant" - | Some phi2 -> - - let gamma1 = g1.goal_ctx_uvar.ctx_uvar_gamma in - let gamma2 = g2.goal_ctx_uvar.ctx_uvar_gamma in - let gamma, r1, r2 = longest_prefix eq_binding (List.rev gamma1) (List.rev gamma2) in - - let t1 = close_forall_no_univs (Env.binders_of_bindings (List.rev r1)) phi1 in - let t2 = close_forall_no_univs (Env.binders_of_bindings (List.rev r2)) phi2 in - - let goal_sc = - match should_check_goal_uvar g1, should_check_goal_uvar g2 with - | Allow_untyped reason1, Allow_untyped _ -> Some (Allow_untyped reason1) - | _ -> None - in - set_solution g1 U.exp_unit ;! - set_solution g2 U.exp_unit ;! - - let ng = U.mk_conj t1 t2 in - let nenv = { goal_env g1 with gamma = List.rev gamma } in - let! goal = mk_irrelevant_goal "joined" nenv ng goal_sc (rangeof g1) g1.opts g1.label in - if_verbose (fun () -> BU.print3 "join_goals of\n(%s)\nand\n(%s)\n= (%s)\n" - (goal_to_string_verbose g1) - (goal_to_string_verbose g2) - (goal_to_string_verbose goal)) ;! - ret goal - -let join () : tac unit = - let! ps = get in - match ps.goals with - | g1::g2::gs -> - set { ps with goals = gs } ;! - let! g12 = join_goals g1 g2 in - add_goals [g12] - - | _ -> fail "join: less than 2 goals" - - -let set_options (s : string) : tac unit = wrap_err "set_options" <| ( - let! g = cur_goal in - FStar.Options.push (); - FStar.Options.set g.opts; - let res = FStar.Options.set_options s in - let opts' = FStar.Options.peek () in - FStar.Options.pop (); - match res with - | FStar.Getopt.Success -> - let g' = { g with opts = opts' } in - replace_cur g' - | FStar.Getopt.Error err -> - fail2 "Setting options `%s` failed: %s" s err - | FStar.Getopt.Help -> - fail1 "Setting options `%s` failed (got `Help`?)" s - ) - -let top_env () : tac env = bind get (fun ps -> ret <| ps.main_context) - -let lax_on () : tac bool = - let! g = cur_goal in - ret (Options.lax () || (goal_env g).admit) - -let unquote (ty : term) (tm : term) : tac term = wrap_err "unquote" <| ( - if_verbose (fun () -> BU.print1 "unquote: tm = %s\n" (show tm)) ;! - let! goal = cur_goal in - let env = Env.set_expected_typ (goal_env goal) ty in - let! tm, typ, guard = __tc_ghost env tm in - if_verbose (fun () -> BU.print1 "unquote: tm' = %s\n" (show tm)) ;! - if_verbose (fun () -> BU.print1 "unquote: typ = %s\n" (show typ)) ;! - proc_guard "unquote" env guard (Some (should_check_goal_uvar goal)) (rangeof goal) ;! - ret tm - ) - -let uvar_env (env : env) (ty : option typ) : tac term = - let! ps = get in - // If no type was given, add a uvar for it too! - let! typ, g, r = - match ty with - | Some ty -> - let env = Env.set_expected_typ env (U.type_u () |> fst) in - let! ty, _, g = __tc_ghost env ty in - ret (ty, g, ty.pos) - - | None -> - //the type of this uvar is just Type; so it's typedness deps is [] - let! typ, uvar_typ = new_uvar "uvar_env.2" env (fst <| U.type_u ()) None [] ps.entry_range in - ret (typ, Env.trivial_guard, Range.dummyRange) - in - proc_guard "uvar_env_typ" env g None r;! - //the guard is an explicit goal; so the typedness deps of this new uvar is [] - let! t, uvar_t = new_uvar "uvar_env" env typ None [] ps.entry_range in - ret t - -let ghost_uvar_env (env : env) (ty : typ) : tac term = - let! ps = get in - // If no type was given, add a uvar for it too! - let! typ, _, g = __tc_ghost env ty in - proc_guard "ghost_uvar_env_typ" env g None ty.pos ;! - //the guard is an explicit goal; so the typedness deps of this new uvar is [] - let! t, uvar_t = new_uvar "uvar_env" env typ (Some (Allow_ghost "User ghost uvar")) [] ps.entry_range in - ret t - -let fresh_universe_uvar () : tac term = - U.type_u () |> fst |> ret - -let unshelve (t : term) : tac unit = wrap_err "unshelve" <| ( - let! ps = get in - let env = ps.main_context in - (* We need a set of options, but there might be no goals, so do this *) - let opts = match ps.goals with - | g::_ -> g.opts - | _ -> FStar.Options.peek () - in - match U.head_and_args t with - | { n = Tm_uvar (ctx_uvar, _) }, _ -> - let env = {env with gamma=ctx_uvar.ctx_uvar_gamma} in - let g = mk_goal env ctx_uvar opts false "" in - let g = bnorm_goal g in - add_goals [g] - | _ -> fail "not a uvar" - ) - -let tac_and (t1 : tac bool) (t2 : tac bool) : tac bool = - match! t1 with - | false -> return false - | true -> t2 - -let default_if_err (def : 'a) (t : tac 'a) : tac 'a = - let! r = catch t in - match r with - | Inl _ -> return def - | Inr v -> return v - -let match_env (e:env) (t1 : term) (t2 : term) : tac bool = wrap_err "match_env" <| ( - let! ps = get in - let! t1, ty1, g1 = __tc e t1 in - let! t2, ty2, g2 = __tc e t2 in - proc_guard "match_env g1" e g1 None ps.entry_range ;! - proc_guard "match_env g2" e g2 None ps.entry_range ;! - let must_tot = true in - default_if_err false <| - tac_and (do_match must_tot e ty1 ty2) - (do_match must_tot e t1 t2) - ) - -let unify_env (e:env) (t1 : term) (t2 : term) : tac bool = wrap_err "unify_env" <| ( - let! ps = get in - let! t1, ty1, g1 = __tc e t1 in - let! t2, ty2, g2 = __tc e t2 in - proc_guard "unify_env g1" e g1 None ps.entry_range ;! - proc_guard "unify_env g2" e g2 None ps.entry_range ;! - let must_tot = true in - default_if_err false <| - tac_and (do_unify must_tot e ty1 ty2) - (do_unify must_tot e t1 t2) - ) - -let unify_guard_env (e:env) (t1 : term) (t2 : term) : tac bool = wrap_err "unify_guard_env" <| ( - let! ps = get in - let! t1, ty1, g1 = __tc e t1 in - let! t2, ty2, g2 = __tc e t2 in - proc_guard "unify_guard_env g1" e g1 None ps.entry_range ;! - proc_guard "unify_guard_env g2" e g2 None ps.entry_range ;! - let must_tot = true in - match! do_unify_maybe_guards true must_tot e ty1 ty2 with - | None -> ret false - | Some g1 -> - match! do_unify_maybe_guards true must_tot e t1 t2 with - | None -> ret false - | Some g2 -> - let formula : term = U.mk_conj (guard_formula g1) (guard_formula g2) in - let! goal = goal_of_guard "unify_guard_env.g2" e formula None ps.entry_range in - push_goals [goal] ;! - ret true - ) - -let launch_process (prog : string) (args : list string) (input : string) : tac string = - // The `bind idtac` thunks the tactic - idtac ;! - if Options.unsafe_tactic_exec () then - let s = BU.run_process "tactic_launch" prog args (Some input) in - ret s - else - fail "launch_process: will not run anything unless --unsafe_tactic_exec is provided" - -let fresh_bv_named (nm : string) : tac bv = - // The `bind idtac` thunks the tactic. Not really needed, just being paranoid - idtac ;! ret (gen_bv nm None S.tun) - -let change (ty : typ) : tac unit = wrap_err "change" <| ( - if_verbose (fun () -> BU.print1 "change: ty = %s\n" (show ty)) ;! - let! g = cur_goal in - let! ty, _, guard = __tc (goal_env g) ty in - proc_guard "change" (goal_env g) guard (Some (should_check_goal_uvar g)) (rangeof g) ;! - let must_tot = true in - let! bb = do_unify must_tot (goal_env g) (goal_type g) ty in - if bb - then replace_cur (goal_with_type g ty) - else begin - (* Give it a second try, fully normalize the term the user gave - * and unify it with the fully normalized goal. If that succeeds, - * we use the original one as the new goal. This is sometimes needed - * since the unifier has some bugs. *) - let steps = [Env.AllowUnboundUniverses; Env.UnfoldUntil delta_constant; Env.Primops] in - let ng = normalize steps (goal_env g) (goal_type g) in - let nty = normalize steps (goal_env g) ty in - let! b = do_unify must_tot (goal_env g) ng nty in - if b - then replace_cur (goal_with_type g ty) - else fail "not convertible" - end - ) - -let failwhen (b:bool) (msg:string) : tac unit = - if b - then fail msg - else ret () - -let t_destruct (s_tm : term) : tac (list (fv & Z.t)) = wrap_err "destruct" <| ( - let! g = cur_goal in - let! s_tm, s_ty, guard = __tc (goal_env g) s_tm in - proc_guard "destruct" (goal_env g) guard (Some (should_check_goal_uvar g)) (rangeof g) ;! - let s_ty = N.normalize [Env.DontUnfoldAttr [PC.tac_opaque_attr]; Env.Weak; Env.HNF; Env.UnfoldUntil delta_constant] - (goal_env g) s_ty in - let h, args = U.head_and_args_full (U.unrefine s_ty) in - let! fv, a_us = - match (SS.compress h).n with - | Tm_fvar fv -> ret (fv, []) - | Tm_uinst (h', us) -> - begin match (SS.compress h').n with - | Tm_fvar fv -> ret (fv, us) - | _ -> failwith "impossible: uinst over something that's not an fvar" - end - | _ -> fail "type is not an fv" - in - let t_lid = lid_of_fv fv in - match Env.lookup_sigelt (goal_env g) t_lid with - | None -> fail "type not found in environment" - | Some se -> - match se.sigel with - | Sig_inductive_typ {us=t_us; params=t_ps; t=t_ty; mutuals=mut; ds=c_lids} -> - (* High-level idea of this huge function: - * For Gamma |- w : phi and | C : ps -> bs -> t, we generate a new goal - * Gamma |- w' : bs -> phi - * with - * w = match tm with ... | C .ps' bs' -> w' bs' ... - * i.e., we do not intro the matched binders and let the - * user do that (with the returned arity). `.ps` represents inaccesible patterns - * for the type's parameters. - *) - let erasable = U.has_attribute se.sigattrs FStar.Parser.Const.erasable_attr in - failwhen (erasable && not (is_irrelevant g)) "cannot destruct erasable type to solve proof-relevant goal" ;! - - (* Instantiate formal universes to the actuals, - * and substitute accordingly in binders and types *) - failwhen (List.length a_us <> List.length t_us) "t_us don't match?" ;! - - - (* Not needed currently? *) - (* let s = Env.mk_univ_subst t_us a_us in *) - (* let t_ps = SS.subst_binders s t_ps in *) - (* let t_ty = SS.subst s t_ty in *) - let t_ps, t_ty = SS.open_term t_ps t_ty in - - let! goal_brs = - mapM (fun c_lid -> - match Env.lookup_sigelt (goal_env g) c_lid with - | None -> fail "ctor not found?" - | Some se -> - match se.sigel with - | Sig_datacon {us=c_us; t=c_ty; num_ty_params=nparam; mutuals=mut} -> - (* BU.print2 "ty of %s = %s\n" (show c_lid) *) - (* (show c_ty); *) - let fv = S.lid_as_fv c_lid (Some Data_ctor) in - - - failwhen (List.length a_us <> List.length c_us) "t_us don't match?" ;! - let s = Env.mk_univ_subst c_us a_us in - let c_ty = SS.subst s c_ty in - - (* The constructor might be universe-polymorphic, just use - * fresh univ_uvars for its universes. *) - let c_us, c_ty = Env.inst_tscheme (c_us, c_ty) in - - (* BU.print2 "ty(2) of %s = %s\n" (show c_lid) *) - (* (show c_ty); *) - - (* Deconstruct its type, separating the parameters from the - * actual arguments (indices do not matter here). *) - let bs, comp = U.arrow_formals_comp c_ty in - - (* More friendly names: 'a_i' instead of '_i' *) - let bs, comp = - let rename_bv bv = - let ppname = bv.ppname in - let ppname = mk_ident ("a" ^ show ppname, range_of_id ppname) in - // freshen just to be extra safe.. probably not needed - freshen_bv ({ bv with ppname = ppname }) - in - let bs' = List.map (fun b -> {b with binder_bv=rename_bv b.binder_bv}) bs in - let subst = List.map2 (fun ({binder_bv=bv}) ({binder_bv=bv'}) -> NT (bv, bv_to_name bv')) bs bs' in - SS.subst_binders subst bs', SS.subst_comp subst comp - in - - (* BU.print1 "bs = (%s)\n" (Print.binders_to_string ", " bs); *) - let d_ps, bs = List.splitAt nparam bs in - failwhen (not (U.is_total_comp comp)) "not total?" ;! - let mk_pat p = { v = p; p = s_tm.pos } in - (* TODO: This is silly, why don't we just keep aq in the Pat_cons? *) - let is_imp = function | Some (Implicit _) -> true - | _ -> false - in - let a_ps, a_is = List.splitAt nparam args in - failwhen (List.length a_ps <> List.length d_ps) "params not match?" ;! - let d_ps_a_ps = List.zip d_ps a_ps in - let subst = List.map (fun (({binder_bv=bv}), (t, _)) -> NT (bv, t)) d_ps_a_ps in - let bs = SS.subst_binders subst bs in - let subpats_1 = List.map (fun (({binder_bv=bv}), (t, _)) -> - (mk_pat (Pat_dot_term (Some t)), true)) d_ps_a_ps in - let subpats_2 = List.map (fun ({binder_bv=bv;binder_qual=bq}) -> - (mk_pat (Pat_var bv), is_imp bq)) bs in - let subpats = subpats_1 @ subpats_2 in - let pat = mk_pat (Pat_cons (fv, Some a_us, subpats)) in - let env = (goal_env g) in - - - (* Add an argument stating the equality between the scrutinee - * and the pattern, in-scope for this branch. *) - let cod = goal_type g in - let equ = env.universe_of env s_ty in - (* Typecheck the pattern, to fill-in the universes and get an expression out of it *) - let _ , _, _, _, pat_t, _, _guard_pat, _erasable = TcTerm.tc_pat ({ env with admit = true }) s_ty pat in - let eq_b = S.gen_bv "breq" None (U.mk_squash S.U_zero (U.mk_eq2 equ s_ty s_tm pat_t)) in - let cod = U.arrow [S.mk_binder eq_b] (mk_Total cod) in - - let nty = U.arrow bs (mk_Total cod) in - let! uvt, uv = new_uvar "destruct branch" env nty None (goal_typedness_deps g) (rangeof g) in - let g' = mk_goal env uv g.opts false g.label in - let brt = U.mk_app_binders uvt bs in - (* Provide the scrutinee equality, which is trivially provable *) - let brt = U.mk_app brt [S.as_arg U.exp_unit] in - let br = SS.close_branch (pat, None, brt) in - ret (g', br, (fv, Z.of_int_fs (List.length bs))) - | _ -> - fail "impossible: not a ctor") - c_lids - in - let goals, brs, infos = List.unzip3 goal_brs in - let w = mk (Tm_match {scrutinee=s_tm;ret_opt=None;brs;rc_opt=None}) s_tm.pos in - solve' g w ;! - //we constructed a well-typed term to solve g; no need to recheck it - mark_goal_implicit_already_checked g; - add_goals goals ;! - ret infos - - | _ -> fail "not an inductive type" - ) - -let gather_explicit_guards_for_resolved_goals () - : tac unit - = ret () - -// TODO: move to library? -let rec last (l:list 'a) : 'a = - match l with - | [] -> failwith "last: empty list" - | [x] -> x - | _::xs -> last xs - -let rec init (l:list 'a) : list 'a = - match l with - | [] -> failwith "init: empty list" - | [x] -> [] - | x::xs -> x :: init xs - -(* TODO: to avoid the duplication with inspect_ln (and the same -for pack), we could instead have an `open_view` function (maybe even -user-facing?) that takes care of opening the needed binders in the rest -of the term. Similarly, a `close_view`. Then: - - inspect = open_view . inspect_ln - pack = pack_ln . close_view - -which would be nice. But.. patterns in matches and recursive -letbindings make that complicated, since we need to duplicate a bunch of -logic from Syntax.Subst here, so I dropped that idea for now. -Everything else goes surprisingly smooth though! - --- GM 2022/Oct/05 -*) - -let rec inspect (t:term) : tac term_view = wrap_err "inspect" ( - let! e = top_env () in - let t = U.unlazy_emb t in - let t = SS.compress t in - match t.n with - | Tm_meta {tm=t} -> - inspect t - - | Tm_name bv -> - ret <| Tv_Var bv - - | Tm_bvar bv -> - ret <| Tv_BVar bv - - | Tm_fvar fv -> - ret <| Tv_FVar fv - - | Tm_uinst (t, us) -> - (match (t |> SS.compress |> U.unascribe).n with - | Tm_fvar fv -> ret <| Tv_UInst (fv, us) - | _ -> failwith "Tac::inspect: Tm_uinst head not an fvar") - - | Tm_ascribed {tm=t; asc=(Inl ty, tacopt, eq)} -> - ret <| Tv_AscribedT (t, ty, tacopt, eq) - - | Tm_ascribed {tm=t; asc=(Inr cty, tacopt, eq)} -> - ret <| Tv_AscribedC (t, cty, tacopt, eq) - - | Tm_app {args=[]} -> - failwith "empty arguments on Tm_app" - - | Tm_app {hd; args} -> - // We split at the last argument, since the term_view does not - // expose n-ary lambdas buy unary ones. - let (a, q) = last args in - let q' = inspect_aqual q in - ret <| Tv_App (S.mk_Tm_app hd (init args) t.pos, (a, q')) // TODO: The range and tk are probably wrong. Fix - - | Tm_abs {bs=[]} -> - failwith "empty arguments on Tm_abs" - - | Tm_abs {bs; body=t; rc_opt=k} -> - let bs, t = SS.open_term bs t in - // `let b::bs = bs` gives a coverage warning, avoid it - begin match bs with - | [] -> failwith "impossible" - | b::bs -> ret <| Tv_Abs (b, U.abs bs t k) - end - - | Tm_type u -> - ret <| Tv_Type u - - | Tm_arrow {bs=[]} -> - failwith "empty binders on arrow" - - | Tm_arrow _ -> - begin match U.arrow_one t with - | Some (b, c) -> ret <| Tv_Arrow (b, c) - | None -> failwith "impossible" - end - - | Tm_refine {b=bv; phi=t} -> - let b = S.mk_binder bv in - let b', t = SS.open_term [b] t in - // `let [b] = b'` gives a coverage warning, avoid it - let b = (match b' with - | [b'] -> b' - | _ -> failwith "impossible") in - ret <| Tv_Refine (b.binder_bv, b.binder_bv.sort, t) - - | Tm_constant c -> - ret <| Tv_Const (inspect_const c) - - | Tm_uvar (ctx_u, s) -> - ret <| Tv_Uvar (Z.of_int_fs (UF.uvar_unique_id ctx_u.ctx_uvar_head), (ctx_u, s)) - - | Tm_let {lbs=(false, [lb]); body=t2} -> - if lb.lbunivs <> [] then ret <| Tv_Unsupp else - begin match lb.lbname with - | Inr _ -> ret <| Tv_Unsupp // no top level lets - | Inl bv -> - // The type of `bv` should match `lb.lbtyp` - let b = S.mk_binder bv in - let bs, t2 = SS.open_term [b] t2 in - let b = match bs with - | [b] -> b - | _ -> failwith "impossible: open_term returned different amount of binders" - in - ret <| Tv_Let (false, lb.lbattrs, b.binder_bv, bv.sort, lb.lbdef, t2) - end - - | Tm_let {lbs=(true, [lb]); body=t2} -> - if lb.lbunivs <> [] then ret <| Tv_Unsupp else - begin match lb.lbname with - | Inr _ -> ret <| Tv_Unsupp // no top level lets - | Inl bv -> - let lbs, t2 = SS.open_let_rec [lb] t2 in - match lbs with - | [lb] -> - (match lb.lbname with - | Inr _ -> ret Tv_Unsupp - | Inl bv -> ret <| Tv_Let (true, lb.lbattrs, bv, bv.sort, lb.lbdef, t2)) - | _ -> failwith "impossible: open_term returned different amount of binders" - end - - | Tm_match {scrutinee=t; ret_opt; brs} -> - let rec inspect_pat p = - match p.v with - | Pat_constant c -> Pat_Constant (inspect_const c) - | Pat_cons (fv, us_opt, ps) -> Pat_Cons (fv, us_opt, List.map (fun (p, b) -> inspect_pat p, b) ps) - | Pat_var bv -> Pat_Var (bv, Sealed.seal bv.sort) - | Pat_dot_term eopt -> Pat_Dot_Term eopt - in - let brs = List.map SS.open_branch brs in - let brs = List.map (function (pat, _, t) -> (inspect_pat pat, t)) brs in - ret <| Tv_Match (t, ret_opt, brs) - - | Tm_unknown -> - ret <| Tv_Unknown - - | _ -> - Err.log_issue t Err.Warning_CantInspect - (BU.format2 "inspect: outside of expected syntax (%s, %s)\n" (tag_of t) (show t)); - ret <| Tv_Unsupp - ) - -(* This function could actually be pure, it doesn't need freshness - * like `inspect` does, but we mark it as Tac for uniformity. *) -let pack' (tv:term_view) (leave_curried:bool) : tac term = - match tv with - | Tv_Var bv -> - ret <| S.bv_to_name bv - - | Tv_BVar bv -> - ret <| S.bv_to_tm bv - - | Tv_FVar fv -> - ret <| S.fv_to_tm fv - - | Tv_UInst (fv, us) -> - ret <| S.mk_Tm_uinst (S.fv_to_tm fv) us - - | Tv_App (l, (r, q)) -> - let q' = pack_aqual q in - ret <| U.mk_app l [(r, q')] - - | Tv_Abs (b, t) -> - ret <| U.abs [b] t None // TODO: effect? - - | Tv_Arrow (b, c) -> - ret <| (if leave_curried then U.arrow [b] c else U.canon_arrow (U.arrow [b] c)) - - | Tv_Type u -> - ret <| S.mk (Tm_type u) Range.dummyRange - - | Tv_Refine (bv, sort, t) -> - let bv = { bv with sort = sort } in - ret <| U.refine bv t - - | Tv_Const c -> - ret <| S.mk (Tm_constant (pack_const c)) Range.dummyRange - - | Tv_Uvar (_u, ctx_u_s) -> - ret <| S.mk (Tm_uvar ctx_u_s) Range.dummyRange - - | Tv_Let (false, attrs, bv, ty, t1, t2) -> - let bv = { bv with sort = ty } in - let lb = U.mk_letbinding (Inl bv) [] bv.sort PC.effect_Tot_lid t1 attrs Range.dummyRange in - ret <| S.mk (Tm_let {lbs=(false, [lb]); body=SS.close [S.mk_binder bv] t2}) Range.dummyRange - - | Tv_Let (true, attrs, bv, ty, t1, t2) -> - let bv = { bv with sort = ty } in - let lb = U.mk_letbinding (Inl bv) [] bv.sort PC.effect_Tot_lid t1 attrs Range.dummyRange in - let lbs, body = SS.close_let_rec [lb] t2 in - ret <| S.mk (Tm_let {lbs=(true, lbs); body}) Range.dummyRange - - | Tv_Match (t, ret_opt, brs) -> - let wrap v = {v=v;p=Range.dummyRange} in - let rec pack_pat p : S.pat = - match p with - | Pat_Constant c -> wrap <| Pat_constant (pack_const c) - | Pat_Cons (fv, us_opt, ps) -> wrap <| Pat_cons (fv, us_opt, List.map (fun (p, b) -> pack_pat p, b) ps) - | Pat_Var (bv, _sort) -> wrap <| Pat_var bv - | Pat_Dot_Term eopt -> wrap <| Pat_dot_term eopt - in - let brs = List.map (function (pat, t) -> (pack_pat pat, None, t)) brs in - let brs = List.map SS.close_branch brs in - ret <| S.mk (Tm_match {scrutinee=t; ret_opt; brs; rc_opt=None}) Range.dummyRange - - | Tv_AscribedT(e, t, tacopt, use_eq) -> - ret <| S.mk (Tm_ascribed {tm=e;asc=(Inl t, tacopt, use_eq);eff_opt=None}) Range.dummyRange - - | Tv_AscribedC(e, c, tacopt, use_eq) -> - ret <| S.mk (Tm_ascribed {tm=e;asc=(Inr c, tacopt, use_eq);eff_opt=None}) Range.dummyRange - - | Tv_Unknown -> - ret <| S.mk Tm_unknown Range.dummyRange - - | Tv_Unsupp -> - fail "cannot pack Tv_Unsupp" - -let pack (tv:term_view) : tac term = pack' tv false -let pack_curried (tv:term_view) : tac term = pack' tv true - -let lget (ty:term) (k:string) : tac term = wrap_err "lget" <| ( - let! ps = get in - match BU.psmap_try_find ps.local_state k with - | None -> fail "not found" - | Some t -> unquote ty t - ) - -let lset (_ty:term) (k:string) (t:term) : tac unit = wrap_err "lset" <| ( - let! ps = get in - let ps = { ps with local_state = BU.psmap_add ps.local_state k t } in - set ps - ) - -let set_urgency (u:Z.t) : tac unit = - let! ps = get in - let ps = { ps with urgency = Z.to_int_fs u } in - set ps - -let t_commute_applied_match () : tac unit = wrap_err "t_commute_applied_match" <| ( - let! g = cur_goal in - match destruct_eq (goal_env g) (goal_type g) with - | Some (l, r) -> begin - let lh, las = U.head_and_args_full l in - match (SS.compress (U.unascribe lh)).n with - | Tm_match {scrutinee=e;ret_opt=asc_opt;brs;rc_opt=lopt} -> - let brs' = List.map (fun (p, w, e) -> p, w, U.mk_app e las) brs in - // - // If residual comp is set, apply arguments to it - // - let lopt' = lopt |> BU.map_option (fun rc -> {rc with residual_typ= - rc.residual_typ |> BU.map_option (fun t -> - let bs, c = N.get_n_binders (goal_env g) (List.length las) t in - let bs, c = SS.open_comp bs c in - let ss = List.map2 (fun b a -> NT (b.binder_bv, fst a)) bs las in - let c = SS.subst_comp ss c in - U.comp_result c)}) in - let l' = mk (Tm_match {scrutinee=e;ret_opt=asc_opt;brs=brs';rc_opt=lopt'}) l.pos in - let must_tot = true in - begin match! do_unify_maybe_guards false must_tot (goal_env g) l' r with - | None -> fail "discharging the equality failed" - | Some guard -> - if Env.is_trivial_guard_formula guard - then ( - //we just checked that its guard is trivial; so no need to check again - mark_uvar_as_already_checked g.goal_ctx_uvar; - solve g U.exp_unit - ) - else failwith "internal error: _t_refl: guard is not trivial" - end - | _ -> - fail "lhs is not a match" - end - | None -> - fail "not an equality" - ) - -let string_to_term (e: Env.env) (s: string): tac term - = let open FStar.Parser.ParseIt in - let frag_of_text s = { frag_fname= "" - ; frag_line = 1 ; frag_col = 0 - ; frag_text = s } in - match parse None (Fragment (frag_of_text s)) with - | Term t -> - let dsenv = FStar.Syntax.DsEnv.set_current_module e.dsenv (current_module e) in - begin try ret (FStar.ToSyntax.ToSyntax.desugar_term dsenv t) with - | FStar.Errors.Error (_, e, _, _) -> fail ("string_to_term: " ^ Errors.rendermsg e) - | _ -> fail ("string_to_term: Unknown error") - end - | ASTFragment _ -> fail ("string_to_term: expected a Term as a result, got an ASTFragment") - | ParseError (_, err, _) -> fail ("string_to_term: got error " ^ Errors.rendermsg err) // FIXME - -let push_bv_dsenv (e: Env.env) (i: string): tac (env & bv) - = let ident = Ident.mk_ident (i, FStar.Compiler.Range.dummyRange) in - let dsenv, bv = FStar.Syntax.DsEnv.push_bv e.dsenv ident in - ret ({ e with dsenv }, bv) - -let term_to_string (t:term) : tac string - = let s = show t in - ret s - -let comp_to_string (c:comp) : tac string - = let s = show c in - ret s - -let range_to_string (r:FStar.Compiler.Range.range) : tac string - = ret (show r) - -let term_eq_old (t1:term) (t2:term) : tac bool - = idtac ;! - ret (Syntax.Util.term_eq t1 t2) - -let with_compat_pre_core (n:Z.t) (f:tac 'a) : tac 'a = - mk_tac (fun ps -> - Options.with_saved_options (fun () -> - let _res = FStar.Options.set_options ("--compat_pre_core 0") in - run f ps)) - -let get_vconfig () : tac vconfig = - let! g = cur_goal in - (* Restore goal's optionstate (a copy is needed) and read vconfig. - * This is an artifact of the options API being stateful in many places, - * morally this is just (get_vconfig g.opts) *) - let vcfg = Options.with_saved_options (fun () -> - FStar.Options.set g.opts; - Options.get_vconfig ()) - in - ret vcfg - -let set_vconfig (vcfg : vconfig) : tac unit = - (* Same comment as for get_vconfig applies, this is really just - * let g' = { g with opts = set_vconfig vcfg g.opts } *) - let! g = cur_goal in - let opts' = Options.with_saved_options (fun () -> - FStar.Options.set g.opts; - Options.set_vconfig vcfg; - Options.peek ()) - in - let g' = { g with opts = opts' } in - replace_cur g' - -let t_smt_sync (vcfg : vconfig) : tac unit = wrap_err "t_smt_sync" <| ( - let! goal = cur_goal in - match get_phi goal with - | None -> fail "Goal is not irrelevant" - | Some phi -> - let e = goal_env goal in - let ans : bool = - (* Set goal's optionstate before asking solver, to respect - * its vconfig among other things. *) - Options.with_saved_options (fun () -> - (* NOTE: we ignore the goal's options, the rationale is that - * any verification-relevant option is inside the vconfig, so we - * should not need read the optionstate. Of course this vconfig - * will probably come in large part from a get_vconfig, which does - * read the goal's options. *) - Options.set_vconfig vcfg; - e.solver.solve_sync None e phi - ) - in - if ans - then ( - mark_uvar_as_already_checked goal.goal_ctx_uvar; - solve goal U.exp_unit - ) else fail "SMT did not solve this goal" -) - -let free_uvars (tm : term) : tac (list Z.t) - = idtac ;! - let uvs = Syntax.Free.uvars_uncached tm |> elems |> List.map (fun u -> Z.of_int_fs (UF.uvar_id u.ctx_uvar_head)) in - ret uvs - -(***** Builtins used in the meta DSL framework *****) - -let dbg_refl (g:env) (msg:unit -> string) = - if !dbg_ReflTc - then BU.print_string (msg ()) - -let issues = list Errors.issue -let refl_typing_builtin_wrapper (f:unit -> 'a) : tac (option 'a & issues) = - let tx = UF.new_transaction () in - let errs, r = - try Errors.catch_errors_and_ignore_rest f - with exn -> //catch everything - let issue = FStar.Errors.({ - issue_msg = Errors.mkmsg (BU.print_exn exn); - issue_level = EError; - issue_range = None; - issue_number = (Some 17); - issue_ctx = get_ctx () - }) in - [issue], None - in - UF.rollback tx; - if List.length errs > 0 - then ret (None, errs) - else ret (r, errs) - -let no_uvars_in_term (t:term) : bool = - t |> Free.uvars |> is_empty && - t |> Free.univs |> is_empty - -let no_uvars_in_g (g:env) : bool = - g.gamma |> BU.for_all (function - | Binding_var bv -> no_uvars_in_term bv.sort - | _ -> true) - -type relation = - | Subtyping - | Equality - -let unexpected_uvars_issue r = - let open FStar.Errors in - let i = { - issue_level = EError; - issue_range = Some r; - issue_msg = Errors.mkmsg "Cannot check relation with uvars"; - issue_number = Some (errno Error_UnexpectedUnresolvedUvar); - issue_ctx = [] - } in - i diff --git a/src/tactics/FStar.Tactics.V1.Basic.fsti b/src/tactics/FStar.Tactics.V1.Basic.fsti deleted file mode 100644 index 87899fd08b2..00000000000 --- a/src/tactics/FStar.Tactics.V1.Basic.fsti +++ /dev/null @@ -1,117 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Tactics.V1.Basic - -(* This module implements the primitives in - * ulib/FStar.Tactics.Builtins. It would be named - * the same, but there needs to be a thin adapter - * layer since the tac monad representation differs - * between compiler and userspace (and a few other - * annoyances too). *) - -open FStar.Syntax.Syntax -open FStar.TypeChecker.Env -open FStar.Reflection.V1.Data -open FStar.Tactics.Types -open FStar.Tactics.Monad - -module BU = FStar.Compiler.Util -module O = FStar.Options -module Range = FStar.Compiler.Range -module Z = FStar.BigInt -module TcComm = FStar.TypeChecker.Common -module Core = FStar.TypeChecker.Core - -(* Internal utilities *) -val goal_typedness_deps : goal -> list ctx_uvar - -(* Helper *) -val focus : tac 'a -> tac 'a - -(* Metaprogramming primitives (not all of them). - * Documented in `ulib/FStar.Tactics.Builtins.fst` *) - -val top_env : unit -> tac env -val fresh : unit -> tac Z.t -val refine_intro : unit -> tac unit -val tc : env -> term -> tac typ -val tcc : env -> term -> tac comp -val unshelve : term -> tac unit -val unquote : typ -> term -> tac term -val norm : list Pervasives.norm_step -> tac unit -val norm_term_env : env -> list Pervasives.norm_step -> term -> tac term -val norm_binder_type : list Pervasives.norm_step -> binder -> tac unit -val intro : unit -> tac binder -val intro_rec : unit -> tac (binder & binder) -val rename_to : binder -> string -> tac binder -val revert : unit -> tac unit -val binder_retype : binder -> tac unit -val clear_top : unit -> tac unit -val clear : binder -> tac unit -val rewrite : binder -> tac unit -val t_exact : bool -> bool -> term -> tac unit -val t_apply : bool -> bool -> bool -> term -> tac unit -val t_apply_lemma : bool -> bool -> term -> tac unit -val print : string -> tac unit -val debugging : unit -> tac bool -val dump : string -> tac unit -val dump_all : bool -> string -> tac unit -val dump_uvars_of : goal -> string -> tac unit -val t_trefl : (*allow_guards:*)bool -> tac unit -val dup : unit -> tac unit -val prune : string -> tac unit -val addns : string -> tac unit -val t_destruct : term -> tac (list (fv & Z.t)) -val gather_explicit_guards_for_resolved_goals : unit -> tac unit -val set_options : string -> tac unit -val uvar_env : env -> option typ -> tac term -val ghost_uvar_env : env -> typ -> tac term -val fresh_universe_uvar : unit -> tac term -val unify_env : env -> term -> term -> tac bool -val unify_guard_env : env -> term -> term -> tac bool -val match_env : env -> term -> term -> tac bool -val launch_process : string -> list string -> string -> tac string -val fresh_bv_named : string -> tac bv -val change : typ -> tac unit -val get_guard_policy : unit -> tac guard_policy -val set_guard_policy : guard_policy -> tac unit -val lax_on : unit -> tac bool -val tadmit_t : term -> tac unit -val inspect : term -> tac term_view -val pack : term_view -> tac term -val pack_curried : term_view -> tac term -val join : unit -> tac unit -val lget : typ -> string -> tac term -val lset : typ -> string -> term -> tac unit -val curms : unit -> tac Z.t -val set_urgency : Z.t -> tac unit -val t_commute_applied_match : unit -> tac unit -val goal_with_type : goal -> typ -> goal -val mark_goal_implicit_already_checked : goal -> unit -val string_to_term : env -> string -> tac term -val push_bv_dsenv : env -> string -> tac (env & bv) -val term_to_string : term -> tac string -val comp_to_string : comp -> tac string -val range_to_string : Range.range -> tac string - -val term_eq_old : term -> term -> tac bool -val with_compat_pre_core : Z.t -> tac 'a -> tac 'a - -val get_vconfig : unit -> tac VConfig.vconfig -val set_vconfig : VConfig.vconfig -> tac unit -val t_smt_sync : VConfig.vconfig -> tac unit -val free_uvars : term -> tac (list Z.t) diff --git a/src/tactics/FStar.Tactics.V1.Primops.fst b/src/tactics/FStar.Tactics.V1.Primops.fst deleted file mode 100644 index 5ce722afced..00000000000 --- a/src/tactics/FStar.Tactics.V1.Primops.fst +++ /dev/null @@ -1,266 +0,0 @@ -module FStar.Tactics.V1.Primops - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Compiler.Range -open FStar.Compiler.Util -open FStar.Syntax.Syntax -open FStar.Syntax.Embeddings -open FStar.TypeChecker.Common -open FStar.TypeChecker.Env -open FStar.Tactics.Result -open FStar.Tactics.Types -open FStar.Tactics.Printing -open FStar.Tactics.Monad -open FStar.Tactics.V1.Basic -open FStar.Tactics.CtrlRewrite -open FStar.Tactics.Native -open FStar.Tactics.Common -open FStar.Tactics.InterpFuns -open FStar.Class.Show -open FStar.Class.Monad -open FStar.Class.HasRange - -module BU = FStar.Compiler.Util -module Cfg = FStar.TypeChecker.Cfg -module E = FStar.Tactics.Embedding -module Env = FStar.TypeChecker.Env -module Err = FStar.Errors -module N = FStar.TypeChecker.Normalize -module NBE = FStar.TypeChecker.NBE -module NBET = FStar.TypeChecker.NBETerm -module NRE = FStar.Reflection.V1.NBEEmbeddings -module PC = FStar.Parser.Const -module PO = FStar.TypeChecker.Primops -module Print = FStar.Syntax.Print -module RE = FStar.Reflection.V1.Embeddings -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module TcComm = FStar.TypeChecker.Common -module TcRel = FStar.TypeChecker.Rel -module TcTerm = FStar.TypeChecker.TcTerm -module TI = FStar.Tactics.Interpreter -module U = FStar.Syntax.Util - -(* Bring instances *) -open FStar.Reflection.V2.Embeddings {} -open FStar.Reflection.V2.NBEEmbeddings {} - -let solve (#a:Type) {| ev : a |} : Tot a = ev - -instance _ : embedding term = RE.e_term (* REMOVE ME *) - -let fix_module (ps : PO.primitive_step) : PO.primitive_step = - let p : Path.path string = Ident.path_of_lid ps.name in - if p `Path.is_under` ["FStar"; "Stubs"; "Tactics"; "V2"; "Builtins"] then - let p' = ["FStar"; "Stubs"; "Tactics"; "V1"; "Builtins"] @ (p |> List.tl |> List.tl |> List.tl |> List.tl |> List.tl) in - { ps with name = Ident.lid_of_path p' (pos ps.name) } - else - failwith "huh?" - -let ops = - List.map fix_module <| -[ - (* Total steps defined in V2 *) - - mk_tac_step_1 0 "set_goals" set_goals set_goals; - mk_tac_step_1 0 "set_smt_goals" set_smt_goals set_smt_goals; - - mk_tac_step_2 1 "catch" - #e_any #(TI.e_tactic_thunk e_any) #(e_either E.e_exn e_any) - #NBET.e_any #(TI.e_tactic_nbe_thunk NBET.e_any) #(NBET.e_either E.e_exn_nbe NBET.e_any) - (fun _ -> catch) - (fun _ -> catch); - - mk_tac_step_2 1 "recover" - #e_any #(TI.e_tactic_thunk e_any) #(e_either E.e_exn e_any) - #NBET.e_any #(TI.e_tactic_nbe_thunk NBET.e_any) #(NBET.e_either E.e_exn_nbe NBET.e_any) - (fun _ -> recover) - (fun _ -> recover); - - mk_tac_step_1 0 "intro" intro intro ; - mk_tac_step_1 0 "intro_rec" intro_rec intro_rec ; - mk_tac_step_1 0 "norm" norm norm ; - mk_tac_step_3 0 "norm_term_env" norm_term_env norm_term_env ; - mk_tac_step_2 0 "norm_binder_type" norm_binder_type norm_binder_type; - mk_tac_step_2 0 "rename_to" rename_to rename_to ; - - mk_tac_step_1 0 "binder_retype" binder_retype binder_retype ; - mk_tac_step_1 0 "revert" revert revert ; - mk_tac_step_1 0 "clear_top" clear_top clear_top ; - mk_tac_step_1 0 "clear" clear clear ; - mk_tac_step_1 0 "rewrite" rewrite rewrite ; - mk_tac_step_1 0 "refine_intro" refine_intro refine_intro ; - mk_tac_step_3 0 "t_exact" t_exact t_exact ; - mk_tac_step_4 0 "t_apply" t_apply t_apply ; - mk_tac_step_3 0 "t_apply_lemma" t_apply_lemma t_apply_lemma ; - mk_tac_step_1 0 "set_options" set_options set_options ; - mk_tac_step_2 0 "tcc" tcc tcc ; - mk_tac_step_2 0 "tc" tc tc ; - - mk_tac_step_1 0 "unshelve" unshelve unshelve; - - mk_tac_step_2 1 "unquote" - #e_any #RE.e_term #e_any - #NBET.e_any #NRE.e_term #NBET.e_any - unquote - (fun _ _ -> failwith "NBE unquote"); - - mk_tac_step_1 0 "prune" prune prune ; - mk_tac_step_1 0 "addns" addns addns ; - mk_tac_step_1 0 "print" print print ; - mk_tac_step_1 0 "debugging" debugging debugging ; - mk_tac_step_1 0 "dump" dump dump ; - mk_tac_step_2 0 "dump_all" dump_all dump_all ; - mk_tac_step_2 0 "dump_uvars_of" dump_uvars_of dump_uvars_of ; - - mk_tac_step_3 0 "ctrl_rewrite" - #E.e_direction #(TI.e_tactic_1 RE.e_term (e_tuple2 e_bool E.e_ctrl_flag)) #(TI.e_tactic_thunk e_unit) #e_unit - #E.e_direction_nbe #(TI.e_tactic_nbe_1 NRE.e_term (NBET.e_tuple2 NBET.e_bool E.e_ctrl_flag_nbe)) #(TI.e_tactic_nbe_thunk NBET.e_unit) #NBET.e_unit - ctrl_rewrite - ctrl_rewrite; - - mk_tac_step_1 0 "t_trefl" t_trefl t_trefl ; - mk_tac_step_1 0 "dup" dup dup ; - - mk_tac_step_1 0 "tadmit_t" #RE.e_term #_ #NRE.e_term #_ tadmit_t tadmit_t ; - mk_tac_step_1 0 "join" join join ; - - mk_tac_step_1 0 "t_destruct" - #RE.e_term #_ - #NRE.e_term #_ - t_destruct t_destruct; - - mk_tac_step_1 0 "top_env" - top_env - top_env ; - - mk_tac_step_1 0 "inspect" - #RE.e_term #_ - #NRE.e_term #_ - inspect inspect ; - - mk_tac_step_1 0 "pack" - #_ #RE.e_term - #_ #NRE.e_term - pack pack ; - - mk_tac_step_1 0 "pack_curried" - #_ #RE.e_term - #_ #NRE.e_term - pack_curried pack_curried; - - mk_tac_step_1 0 "fresh" fresh fresh ; - mk_tac_step_1 0 "curms" curms curms ; - mk_tac_step_2 0 "uvar_env" - #_ #(e_option RE.e_term) #RE.e_term - #_ #(NBET.e_option NRE.e_term) #NRE.e_term - uvar_env uvar_env ; - - mk_tac_step_2 0 "ghost_uvar_env" - #_ #RE.e_term #RE.e_term - #_ #NRE.e_term #NRE.e_term - ghost_uvar_env ghost_uvar_env ; - - mk_tac_step_1 0 "fresh_universe_uvar" - #_ #RE.e_term - #_ #NRE.e_term - fresh_universe_uvar - fresh_universe_uvar ; - - mk_tac_step_3 0 "unify_env" - #RE.e_env #RE.e_term #RE.e_term #e_bool - #NRE.e_env #NRE.e_term #NRE.e_term #NBET.e_bool - unify_env unify_env ; - - mk_tac_step_3 0 "unify_guard_env" - #RE.e_env #RE.e_term #RE.e_term #e_bool - #NRE.e_env #NRE.e_term #NRE.e_term #NBET.e_bool - unify_guard_env unify_guard_env ; - - mk_tac_step_3 0 "match_env" - #RE.e_env #RE.e_term #RE.e_term #e_bool - #NRE.e_env #NRE.e_term #NRE.e_term #NBET.e_bool - match_env match_env ; - - mk_tac_step_3 0 "launch_process" launch_process launch_process ; - - mk_tac_step_1 0 "fresh_bv_named" - #e_string #RE.e_bv - #NBET.e_string #NRE.e_bv - fresh_bv_named fresh_bv_named ; - - mk_tac_step_1 0 "change" - #RE.e_term #e_unit - #NRE.e_term #NBET.e_unit - change change ; - - mk_tac_step_1 0 "get_guard_policy" get_guard_policy get_guard_policy ; - mk_tac_step_1 0 "set_guard_policy" set_guard_policy set_guard_policy ; - mk_tac_step_1 0 "lax_on" lax_on lax_on ; - - mk_tac_step_2 1 "lget" - #e_any #e_string #e_any - #NBET.e_any #NBET.e_string #NBET.e_any - lget - (fun _ _ -> fail "sorry, `lget` does not work in NBE") ; - - mk_tac_step_3 1 "lset" - #e_any #e_string #e_any #e_unit - #NBET.e_any #NBET.e_string #NBET.e_any #NBET.e_unit - lset - (fun _ _ _ -> fail "sorry, `lset` does not work in NBE") ; - - mk_tac_step_1 0 "set_urgency" set_urgency set_urgency ; - - mk_tac_step_1 0 "t_commute_applied_match" - t_commute_applied_match - t_commute_applied_match ; - - mk_tac_step_1 0 "gather_or_solve_explicit_guards_for_resolved_goals" - gather_explicit_guards_for_resolved_goals - gather_explicit_guards_for_resolved_goals ; - - mk_tac_step_2 0 "string_to_term" - #RE.e_env #e_string #RE.e_term - #NRE.e_env #NBET.e_string #NRE.e_term - string_to_term string_to_term ; - - mk_tac_step_2 0 "push_bv_dsenv" - #RE.e_env #e_string #(e_tuple2 RE.e_env RE.e_bv) - #NRE.e_env #NBET.e_string #(NBET.e_tuple2 NRE.e_env NRE.e_bv) - push_bv_dsenv push_bv_dsenv ; - - mk_tac_step_1 0 "term_to_string" - #RE.e_term #e_string - #NRE.e_term #NBET.e_string - term_to_string term_to_string ; - - mk_tac_step_1 0 "comp_to_string" - comp_to_string - comp_to_string ; - - mk_tac_step_1 0 "range_to_string" range_to_string range_to_string ; - mk_tac_step_2 0 "term_eq_old" - #RE.e_term #RE.e_term #e_bool - #NRE.e_term #NRE.e_term #NBET.e_bool - term_eq_old - term_eq_old ; - - mk_tac_step_3 1 "with_compat_pre_core" - #e_any #e_int #(TI.e_tactic_thunk e_any) #e_any - #NBET.e_any #NBET.e_int #(TI.e_tactic_nbe_thunk NBET.e_any) #NBET.e_any - (fun _ -> with_compat_pre_core) (fun _ -> with_compat_pre_core) ; - - mk_tac_step_1 0 "get_vconfig" get_vconfig get_vconfig ; - mk_tac_step_1 0 "set_vconfig" set_vconfig set_vconfig ; - mk_tac_step_1 0 "t_smt_sync" t_smt_sync t_smt_sync ; - - mk_tac_step_1 0 "free_uvars" - #RE.e_term #_ - #NRE.e_term #_ - free_uvars free_uvars ; - -] diff --git a/src/tactics/FStar.Tactics.V1.Primops.fsti b/src/tactics/FStar.Tactics.V1.Primops.fsti deleted file mode 100644 index e2fefb94ee1..00000000000 --- a/src/tactics/FStar.Tactics.V1.Primops.fsti +++ /dev/null @@ -1,20 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Tactics.V1.Primops - -open FStar.TypeChecker.Primops.Base - -val ops : list primitive_step diff --git a/src/tactics/FStar.Tactics.V2.Basic.fst b/src/tactics/FStar.Tactics.V2.Basic.fst deleted file mode 100644 index 5108454cd51..00000000000 --- a/src/tactics/FStar.Tactics.V2.Basic.fst +++ /dev/null @@ -1,2996 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Tactics.V2.Basic - -open FStar -open FStar.Compiler -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Compiler.Util -open FStar.Ident -open FStar.TypeChecker.Env -open FStar.TypeChecker.Common -open FStar.Pprint -open FStar.Reflection.V2.Data -open FStar.Reflection.V2.Builtins -open FStar.Tactics.Result -open FStar.Tactics.Types -open FStar.Tactics.Monad -open FStar.Tactics.Printing -open FStar.Syntax.Syntax -open FStar.VConfig -open FStar.Errors.Msg -module Listlike = FStar.Class.Listlike - -friend FStar.Pervasives (* to expose norm_step *) - -module BU = FStar.Compiler.Util -module Cfg = FStar.TypeChecker.Cfg -module Env = FStar.TypeChecker.Env -module Err = FStar.Errors -module N = FStar.TypeChecker.Normalize -module PC = FStar.Parser.Const -module Print = FStar.Syntax.Print -module Free = FStar.Syntax.Free -module RD = FStar.Reflection.V2.Data -module Rel = FStar.TypeChecker.Rel -module SF = FStar.Syntax.Free -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module SC = FStar.Syntax.Compress -module TcComm = FStar.TypeChecker.Common -module TcTerm = FStar.TypeChecker.TcTerm -module TcUtil = FStar.TypeChecker.Util -module UF = FStar.Syntax.Unionfind -module U = FStar.Syntax.Util -module Z = FStar.BigInt -module Core = FStar.TypeChecker.Core -module PO = FStar.TypeChecker.Primops -module TC = FStar.Tactics.Typeclasses - -let dbg_Tac = Debug.get_toggle "Tac" -let dbg_TacUnify = Debug.get_toggle "TacUnify" -let dbg_2635 = Debug.get_toggle "2635" -let dbg_ReflTc = Debug.get_toggle "ReflTc" -let dbg_TacVerbose = Debug.get_toggle "TacVerbose" - -open FStar.Class.Show -open FStar.Class.Monad -open FStar.Class.PP -open FStar.Class.Setlike - -let compress (t:term) : tac term = - return ();! - return (SS.compress t) - -let core_check env sol t must_tot - : either (option typ) Core.error - = if not (Options.compat_pre_core_should_check()) then Inl None else - let debug f = - if Debug.any() - then f () - else () - in - match FStar.TypeChecker.Core.check_term env sol t must_tot with - | Inl None -> - Inl None - - | Inl (Some g) -> - if Options.compat_pre_core_set () //core check the solution, but drop the guard, pre_core - then Inl None - else Inl (Some g) - - - | Inr err -> - debug (fun _ -> - BU.print5 "(%s) Core checking failed (%s) on term %s and type %s\n%s\n" - (show (Env.get_range env)) - (Core.print_error_short err) - (show sol) - (show t) - (Core.print_error err)); - Inr err - -type name = bv -type env = Env.env -type implicits = Env.implicits - -let rangeof g = g.goal_ctx_uvar.ctx_uvar_range - -// Beta reduce -let normalize s e t = N.normalize s e t -let bnorm e t = normalize [] e t -let whnf e t = N.unfold_whnf e t - -(* Use this one for everything the user is supposed to see, EXCEPT - * STATE DUMPS, as it does resugaring. For debug messages, just use plain - * term_to_string, we don't want to cause normalization with debug - * flags. *) -let tts = N.term_to_string -let ttd = N.term_to_doc - -let bnorm_goal g = goal_with_type g (bnorm (goal_env g) (goal_type g)) - -let tacprint (s:string) = BU.print1 "TAC>> %s\n" s -let tacprint1 (s:string) x = BU.print1 "TAC>> %s\n" (BU.format1 s x) -let tacprint2 (s:string) x y = BU.print1 "TAC>> %s\n" (BU.format2 s x y) -let tacprint3 (s:string) x y z = BU.print1 "TAC>> %s\n" (BU.format3 s x y z) - -let print (msg:string) : tac unit = - if not (Options.silent ()) then - tacprint msg; - return () - -let debugging () : tac bool = - return ();! (* thunk *) - return !dbg_Tac - -let ide () : tac bool = - return ();! (* thunk *) - return (Options.ide ()) - -let do_dump_ps (msg:string) (ps:proofstate) : unit = - let psc = ps.psc in - let subst = PO.psc_subst psc in - do_dump_proofstate ps msg - -let dump (msg:string) : tac unit = - mk_tac (fun ps -> - do_dump_ps msg ps; - Success ((), ps)) - -let dump_all (print_resolved:bool) (msg:string) : tac unit = - mk_tac (fun ps -> - (* Make a new proofstate with goals for each implicit, - * print it, and return original proofstate unchanged. *) - let gs = List.map (fun i -> goal_of_implicit ps.main_context i) ps.all_implicits in - let gs = - if print_resolved - then gs - else List.filter (fun g -> not (check_goal_solved g)) gs - in - let ps' = { ps with smt_goals = [] ; goals = gs } in - do_dump_ps msg ps'; - Success ((), ps)) - -let dump_uvars_of (g:goal) (msg:string) : tac unit = - mk_tac (fun ps -> - let uvs = SF.uvars (goal_type g) |> elems in // elems order dependent but OK - let gs = List.map (goal_of_ctx_uvar g) uvs in - let gs = List.filter (fun g -> not (check_goal_solved g)) gs in - let ps' = { ps with smt_goals = [] ; goals = gs } in - do_dump_ps msg ps'; - Success ((), ps)) - -let fail1 msg x = fail (BU.format1 msg x) -let fail2 msg x y = fail (BU.format2 msg x y) -let fail3 msg x y z = fail (BU.format3 msg x y z) -let fail4 msg x y z w = fail (BU.format4 msg x y z w) - -let destruct_eq' (typ : typ) : option (term & term) = - let open FStar.Syntax.Formula in - match destruct_typ_as_formula typ with - | Some (BaseConn(l, [_; (e1, None); (e2, None)])) - when Ident.lid_equals l PC.eq2_lid - || Ident.lid_equals l PC.c_eq2_lid - -> - Some (e1, e2) - | _ -> - match U.unb2t typ with - | None -> None - | Some t -> - begin - let hd, args = U.head_and_args t in - match (SS.compress hd).n, args with - | Tm_fvar fv, [(_, Some ({ aqual_implicit = true })); (e1, None); (e2, None)] when S.fv_eq_lid fv PC.op_Eq -> - Some (e1, e2) - | _ -> None - end - -let destruct_eq (env : Env.env) (typ : typ) : option (term & term) = -// TODO: unascribe? - (* let typ = whnf env typ in *) - match destruct_eq' typ with - | Some t -> Some t - | None -> - // Retry for a squashed one - begin match U.un_squash typ with - | Some typ -> - (* let typ = whnf env typ in *) - destruct_eq' typ - | None -> None - end - - -let get_guard_policy () : tac guard_policy = - let! ps = get in - return ps.guard_policy - -let set_guard_policy (pol : guard_policy) : tac unit = - let! ps = get in - set ({ ps with guard_policy = pol }) - -let with_policy pol (t : tac 'a) : tac 'a = - let! old_pol = get_guard_policy () in - set_guard_policy pol;! - let! r = t in - set_guard_policy old_pol;! - return r - -let proc_guard_formula - (reason:string) (e : env) (f : term) (sc_opt : option should_check_uvar) - (rng:Range.range) -: tac unit -= let! ps = get in - match ps.guard_policy with - | Drop -> - // should somehow taint the state instead of just printing a warning - Err.log_issue e Errors.Warning_TacAdmit - (BU.format1 "Tactics admitted guard <%s>\n\n" (show f)); - return () - - | Goal -> - log (fun () -> BU.print2 "Making guard (%s:%s) into a goal\n" reason (show f));! - let! g = goal_of_guard reason e f sc_opt rng in - push_goals [g] - - | SMT -> - log (fun () -> BU.print2 "Pushing guard (%s:%s) as SMT goal\n" reason (show f));! - let! g = goal_of_guard reason e f sc_opt rng in - push_smt_goals [g] - - | SMTSync -> - log (fun () -> BU.print2 "Sending guard (%s:%s) to SMT Synchronously\n" reason (show f));! - let g = { Env.trivial_guard with guard_f = NonTrivial f } in - Rel.force_trivial_guard e g; - return () - - | Force -> - log (fun () -> BU.print2 "Forcing guard (%s:%s)\n" reason (show f));! - let g = { Env.trivial_guard with guard_f = NonTrivial f } in - begin try - if not (Env.is_trivial <| Rel.discharge_guard_no_smt e g) - then fail1 "Forcing the guard failed (%s)" reason - else return () - with - | _ -> - log (fun () -> BU.print1 "guard = %s\n" (show f));! - fail1 "Forcing the guard failed (%s)" reason - end - - | ForceSMT -> - log (fun () -> BU.print2 "Forcing guard WITH SMT (%s:%s)\n" reason (show f));! - let g = { Env.trivial_guard with guard_f = NonTrivial f } in - try if not (Env.is_trivial <| Rel.discharge_guard e g) - then fail1 "Forcing the guard failed (%s)" reason - else return () - with - | _ -> - log (fun () -> BU.print1 "guard = %s\n" (show f));! - fail1 "Forcing the guard failed (%s)" reason - -let proc_guard' (simplify:bool) (reason:string) (e : env) (g : guard_t) (sc_opt:option should_check_uvar) (rng:Range.range) : tac unit = - log (fun () -> BU.print2 "Processing guard (%s:%s)\n" reason (Rel.guard_to_string e g));! - let imps = Listlike.to_list g.implicits in - let _ = - match sc_opt with - | Some (Allow_untyped r) -> - List.iter - (fun imp -> mark_uvar_with_should_check_tag imp.imp_uvar (Allow_untyped r)) - imps - | _ -> () - in - add_implicits imps ;! - let guard_f = - if simplify - then (Rel.simplify_guard e g).guard_f - else g.guard_f - in - match guard_f with - | TcComm.Trivial -> return () - | TcComm.NonTrivial f -> - proc_guard_formula reason e f sc_opt rng - -let proc_guard = proc_guard' true - -// -// See if any of the implicits in uvs were solved in a Rel call, -// if so, core check them -// -let tc_unifier_solved_implicits env (must_tot:bool) (allow_guards:bool) (uvs:list ctx_uvar) : tac unit = - let aux (u:ctx_uvar) : tac unit = - let dec = UF.find_decoration u.ctx_uvar_head in - let sc = dec.uvar_decoration_should_check in - match sc with - | Allow_untyped _ -> - return () - | Already_checked -> - return () - | _ -> - match UF.find u.ctx_uvar_head with - | None -> - return () //not solved yet - | Some sol -> //solved, check it - let env = {env with gamma=u.ctx_uvar_gamma} in - let must_tot = must_tot && not (Allow_ghost? dec.uvar_decoration_should_check) in - match core_check env sol (U.ctx_uvar_typ u) must_tot with - | Inl None -> - //checked with no guard - //no need to check it again - mark_uvar_as_already_checked u; - return () - - | Inl (Some g) -> - let guard = { Env.trivial_guard with guard_f = NonTrivial g } in - let guard = Rel.simplify_guard env guard in - if Options.disallow_unification_guards () - && not allow_guards - && NonTrivial? guard.guard_f - then ( - fail_doc [ - text "Could not typecheck unifier solved implicit" ^/^ pp u.ctx_uvar_head ^/^ - text "to" ^/^ pp sol ^/^ text "since it produced a guard and guards were not allowed"; - text "Guard =" ^/^ pp g - ] - ) - else ( - proc_guard' false "guard for implicit" env guard (Some sc) u.ctx_uvar_range ;! - mark_uvar_as_already_checked u; - return () - ) - - | Inr failed -> - fail_doc [ - text "Could not typecheck unifier solved implicit" ^/^ pp u.ctx_uvar_head ^/^ - text "to" ^/^ pp sol ^/^ text "because" ^/^ doc_of_string (Core.print_error failed) - ] - in - if env.phase1 //phase1 is untrusted - then return () - else uvs |> iter_tac aux - -// -// When calling Rel for t1 `rel` t2, caller can choose to tc -// implicits solved during this unification -// With side argument they can control, which side args to check -// E.g. do_match will choose only Right, -// since it fails if some uvar on the left is instantiated -// -type check_unifier_solved_implicits_side = - | Check_none - | Check_left_only - | Check_right_only - | Check_both - -let __do_unify_wflags - (dbg:bool) - (allow_guards:bool) - (must_tot:bool) - (check_side:check_unifier_solved_implicits_side) - (env:env) (t1:term) (t2:term) - : tac (option guard_t) = - if dbg then - BU.print2 "%%%%%%%%do_unify %s =? %s\n" (show t1) - (show t2); - - let all_uvars = - (match check_side with - | Check_none -> empty () - | Check_left_only -> Free.uvars t1 - | Check_right_only -> Free.uvars t2 - | Check_both -> union (Free.uvars t1) (Free.uvars t2)) - |> elems /// GGG order dependent but does not seem too bad - in - - match! - catch (//restore UF graph in case anything fails - let! gopt = trytac cur_goal in - try - let res = - if allow_guards - then Rel.try_teq true env t1 t2 - else Rel.teq_nosmt env t1 t2 - in - if dbg then - BU.print3 "%%%%%%%%do_unify (RESULT %s) %s =? %s\n" - (FStar.Common.string_of_option (Rel.guard_to_string env) res) - (show t1) - (show t2); - - match res with - | None -> - return None - | Some g -> - tc_unifier_solved_implicits env must_tot allow_guards all_uvars;! - add_implicits (Listlike.to_list g.implicits);! - return (Some g) - - with | Errors.Error (_, msg, r, _) -> - log (fun () -> BU.print2 ">> do_unify error, (%s) at (%s)\n" (Errors.rendermsg msg) (show r));! - return None - ) - with - | Inl exn -> traise exn - | Inr v -> return v - -(* Just a wrapper over __do_unify_wflags to better debug *) -let __do_unify - (allow_guards:bool) - (must_tot:bool) - (check_side:check_unifier_solved_implicits_side) - (env:env) (t1:term) (t2:term) - : tac (option guard_t) = - return ();! - if !dbg_TacUnify then begin - Options.push (); - let _ = Options.set_options "--debug Rel,RelCheck" in - () - end; - let! r = __do_unify_wflags !dbg_TacUnify allow_guards must_tot check_side env t1 t2 in - if !dbg_TacUnify then Options.pop (); - return r - -(* SMT-free unification. *) -let do_unify_aux - (must_tot:bool) - (check_side:check_unifier_solved_implicits_side) - (env:env) (t1:term) (t2:term) - : tac bool = - match! __do_unify false must_tot check_side env t1 t2 with - | None -> return false - | Some g -> - (* g has to be trivial and we have already added its implicits *) - if not (Env.is_trivial_guard_formula g) then - failwith "internal error: do_unify: guard is not trivial" - else - return ();! - return true - -let do_unify (must_tot:bool) (env:env) (t1:term) (t2:term) : tac bool = - do_unify_aux must_tot Check_both env t1 t2 - -let do_unify_maybe_guards (allow_guards:bool) (must_tot:bool) - (env:env) (t1:term) (t2:term) - : tac (option guard_t) = - __do_unify allow_guards must_tot Check_both env t1 t2 - -(* Does t1 match t2? That is, do they unify without instantiating/changing t1? *) -let do_match (must_tot:bool) (env:Env.env) (t1:term) (t2:term) : tac bool = - let! tx = mk_tac (fun ps -> let tx = UF.new_transaction () in - Success (tx, ps)) in - let uvs1 = SF.uvars_uncached t1 in - let! r = do_unify_aux must_tot Check_right_only env t1 t2 in - if r then begin - let uvs2 = SF.uvars_uncached t1 in - if not (equal uvs1 uvs2) - then (UF.rollback tx; return false) - else return true - end - else return false - -(* This is a bandaid. It's similar to do_match but checks that the -LHS of the equality in [t1] is not instantiated, but the RHS might be. -It is a pain to expose the whole logic to tactics, so we just do it -here for now. *) -let do_match_on_lhs (must_tot:bool) (env:Env.env) (t1:term) (t2:term) : tac bool = - let! tx = mk_tac (fun ps -> let tx = UF.new_transaction () in - Success (tx, ps)) in - match destruct_eq env t1 with - | None -> fail "do_match_on_lhs: not an eq" - | Some (lhs, _) -> - let uvs1 = SF.uvars_uncached lhs in - let! r = do_unify_aux must_tot Check_right_only env t1 t2 in - if r then begin - let uvs2 = SF.uvars_uncached lhs in - if not (equal uvs1 uvs2) - then (UF.rollback tx; return false) - else return true - end - else return false - -(* - set_solution: - - Sometimes the witness of a goal is solved by - using a low-level assignment of the unification variable - provided by set_solution. - - The general discipline is that when a trusted primitive tactic - constructs a term to solve the current goal, then it should be - able to just do a set_solution. - - OTOH, if it's a user-provided term to solve the goal, then trysolve is safer - - Note, set_solution is not just an optimization. In cases like `intro` - it is actually important to get the right shape of goal. See the comment there. -*) -let set_solution goal solution : tac unit = - match FStar.Syntax.Unionfind.find goal.goal_ctx_uvar.ctx_uvar_head with - | Some _ -> - fail (BU.format1 "Goal %s is already solved" (goal_to_string_verbose goal)) - | None -> - FStar.Syntax.Unionfind.change goal.goal_ctx_uvar.ctx_uvar_head solution; - mark_goal_implicit_already_checked goal; - return () - -let trysolve (goal : goal) (solution : term) : tac bool = - let must_tot = true in - do_unify must_tot (goal_env goal) solution (goal_witness goal) - -let solve (goal : goal) (solution : term) : tac unit = - let e = goal_env goal in - log (fun () -> BU.print2 "solve %s := %s\n" (show (goal_witness goal)) (show solution));! - let! b = trysolve goal solution in - if b - then (dismiss;! remove_solved_goals) - else - fail_doc [ - ttd (goal_env goal) solution ^/^ - text "does not solve" ^/^ - ttd (goal_env goal) (goal_witness goal) ^/^ text ":" ^/^ ttd (goal_env goal) (goal_type goal) - ] - -let solve' (goal : goal) (solution : term) : tac unit = - set_solution goal solution;! - dismiss;! - remove_solved_goals - -//Any function that directly calls these utilities is also trusted -//End: Trusted utilities -//////////////////////////////////////////////////////////////////// - -//////////////////////////////////////////////////////////////////// -(* Some utilities on goals *) -let is_true t = - let t = U.unascribe t in - match U.un_squash t with - | Some t' -> - let t' = U.unascribe t' in - begin match (SS.compress t').n with - | Tm_fvar fv -> S.fv_eq_lid fv PC.true_lid - | _ -> false - end - | _ -> false - -let is_false t = - match U.un_squash t with - | Some t' -> - begin match (SS.compress t').n with - | Tm_fvar fv -> S.fv_eq_lid fv PC.false_lid - | _ -> false - end - | _ -> false -//////////////////////////////////////////////////////////////////// - -let meas (s:string) (f : tac 'a) : tac 'a = - mk_tac (fun ps -> - let (r, ms) = BU.record_time (fun () -> Tactics.Monad.run f ps) in - BU.print2 "++ Tactic %s ran in \t\t%sms\n" s (show ms); - r) - -(* Nuclear option to benchmark every primitive. *) -(* let wrap_err s f = meas s (wrap_err s f) *) - -let tadmit_t (t:term) : tac unit = wrap_err "tadmit_t" <| ( - let! ps = get in - let! g = cur_goal in - // should somehow taint the state instead of just printing a warning - let open FStar.Errors.Msg in - let open FStar.Pprint in - Err.log_issue (pos (goal_type g)) Errors.Warning_TacAdmit [ - text "Tactics admitted goal."; - prefix 2 1 (text "Goal") - (arbitrary_string <| goal_to_string "" None ps g); - ]; - solve' g t) - -let fresh () : tac Z.t = - let! ps = get in - let n = ps.freshness in - let ps = { ps with freshness = n + 1 } in - set ps;! - return (Z.of_int_fs n) - -let curms () : tac Z.t = - return (BU.now_ms () |> Z.of_int_fs) - -(* Annoying duplication here *) -let __tc (e : env) (t : term) : tac (term & typ & guard_t) = - let! ps = get in - log (fun () -> BU.print1 "Tac> __tc(%s)\n" (show t));! - try return (TcTerm.typeof_tot_or_gtot_term e t true) - with | Errors.Error (_, msg, _, _) -> - fail_doc ([ - prefix 2 1 (text "Cannot type") (ttd e t) ^/^ - prefix 2 1 (text "in context") (pp (Env.all_binders e)) - ] @ msg) - -let __tc_ghost (e : env) (t : term) : tac (term & typ & guard_t) = - let! ps = get in - log (fun () -> BU.print1 "Tac> __tc_ghost(%s)\n" (show t));! - let e = {e with letrecs=[]} in - try let t, lc, g = TcTerm.tc_tot_or_gtot_term e t in - return (t, lc.res_typ, g) - with | Errors.Error (_, msg, _ ,_) -> - fail_doc ([ - prefix 2 1 (text "Cannot type") (ttd e t) ^/^ - prefix 2 1 (text "in context") (pp (Env.all_binders e)) - ] @ msg) - -let __tc_lax (e : env) (t : term) : tac (term & lcomp & guard_t) = - let! ps = get in - log (fun () -> BU.print2 "Tac> __tc_lax(%s)(Context:%s)\n" - (show t) - (Env.all_binders e |> show));! - let e = {e with admit = true} in - let e = {e with letrecs=[]} in - try return (TcTerm.tc_term e t) - with | Errors.Error (_, msg, _, _) -> - fail_doc ([ - prefix 2 1 (text "Cannot type") (ttd e t) ^/^ - prefix 2 1 (text "in context") (pp (Env.all_binders e)) - ] @ msg) - -let tcc (e : env) (t : term) : tac comp = wrap_err "tcc" <| ( - let! (_, lc, _) = __tc_lax e t in - (* Why lax? What about the guard? It doesn't matter! tc is only - * a way for metaprograms to query the typechecker, but - * the result has no effect on the proofstate and nor is it - * taken for a fact that the typing is correct. *) - return (TcComm.lcomp_comp lc |> fst) //dropping the guard from lcomp_comp too! -) - -let tc (e : env) (t : term) : tac typ = wrap_err "tc" <| ( - let! c = tcc e t in - return (U.comp_result c) -) - -(* Applies t to each of the current goals - fails if t fails on any of the goals - collects each result in the output list *) -let rec map (tau:tac 'a): tac (list 'a) = - let! ps = get in - match ps.goals with - | [] -> return [] - | _::_ -> - let! (h,t) = divide Z.one tau (map tau) in - return (h :: t) - -(* Applies t1 to the current head goal - And t2 to all the the sub-goals produced by t1 - - Collects the resulting goals of t2 along with the initial auxiliary goals - *) -let seq (t1:tac unit) (t2:tac unit) : tac unit = - focus (t1 ;! map t2 ;! return ()) - -let should_check_goal_uvar (g:goal) = U.ctx_uvar_should_check g.goal_ctx_uvar - -let bnorm_and_replace g = replace_cur (bnorm_goal g) - -let bv_to_binding (bv : bv) : RD.binding = - { - uniq = Z.of_int_fs bv.index; - sort = bv.sort; - ppname = Sealed.seal (show bv.ppname); - } - -let binder_to_binding (b:binder) : RD.binding = - bv_to_binding b.binder_bv - -let binding_to_string (b : RD.binding) : string = - Sealed.unseal b.ppname ^ "#" ^ show (Z.to_int_fs b.uniq) - - -let binding_to_bv (b : RD.binding) : bv = - { - sort = b.sort; - ppname = mk_ident (Sealed.unseal b.ppname, Range.dummyRange); - index = Z.to_int_fs b.uniq; - } - -let binding_to_binder (b:RD.binding) : S.binder = - let bv = binding_to_bv b in - S.mk_binder bv - -let arrow_one (env:Env.env) (t:term) = - match U.arrow_one_ln t with - | None -> None - | Some (b, c) -> - let env, [b], c = FStar.TypeChecker.Core.open_binders_in_comp env [b] c in - Some (env, b, c) - -let arrow_one_whnf (env:Env.env) (t:term) = - match arrow_one env t with - | Some r -> Some r - | None -> arrow_one env (whnf env t) - -(* - [intro]: - - Initial goal: G |- ?u : (t -> t') - - Now we do an `intro`: - - Next goal: `G, x:t |- ?v : t'` - - with `?u := (fun (x:t) -> ?v @ [NM(x, 0)])` -*) -let intro () : tac RD.binding = wrap_err "intro" <| ( - let! goal = cur_goal in - match arrow_one_whnf (goal_env goal) (goal_type goal) with - | Some (_, _, c) when not (U.is_total_comp c) -> - fail "Codomain is effectful" - - | Some (env', b, c) -> - let typ' = U.comp_result c in - //BU.print1 "[intro]: current goal is %s" (goal_to_string goal); - //BU.print1 "[intro]: current goal witness is %s" (show (goal_witness goal)); - //BU.print1 "[intro]: with goal type %s" (show (goal_type goal)); - //BU.print2 "[intro]: with binder = %s, new goal = %s" - // (Print.binders_to_string ", " [b]) - // (show typ'); - let! body, ctx_uvar = - new_uvar "intro" env' typ' - (Some (should_check_goal_uvar goal)) - (goal_typedness_deps goal) - (rangeof goal) in - let sol = U.abs [b] body (Some (U.residual_comp_of_comp c)) in - //BU.print1 "[intro]: solution is %s" - // (show sol); - //BU.print1 "[intro]: old goal is %s" (goal_to_string goal); - //BU.print1 "[intro]: new goal is %s" - // (show ctx_uvar); - //ignore (FStar.Options.set_options "--debug Rel"); - (* Suppose if instead of simply assigning `?u` to the lambda term on - the RHS, we tried to unify `?u` with the `(fun (x:t) -> ?v @ [NM(x, 0)])`. - - Then, this would defeat the purpose of the delayed substitution, since - the unification engine would solve it by doing something like - - `(fun (y:t) -> ?u y) ~ (fun (x:t) -> ?v @ [NM(x, 0)])` - - And then solving - - `?u z ~ ?v @ [NT(x, z)]` - - which would then proceed by solving `?v` to `?w z` and then unifying - `?u` and `?w`. - - I.e., this immediately destroys the nice shape of the next goal. - *) - set_solution goal sol ;! - let g = mk_goal env' ctx_uvar goal.opts goal.is_guard goal.label in - replace_cur g ;! - return (binder_to_binding b) - | None -> - fail1 "goal is not an arrow (%s)" (tts (goal_env goal) (goal_type goal)) - ) - -(* As [intro], but will introduce n binders at once when the expected type is a -literal arrow. *) -let intros (max:Z.t) : tac (list RD.binding) = wrap_err "intros" <| ( - let max = Z.to_int_fs max in - let! goal = cur_goal in - let bs, c = U.arrow_formals_comp_ln (goal_type goal) in - let bs, c = - (* if user specified a max, maybe trim the bs list and repackage into c *) - if max >= 0 - then ( - let bs0, bs1 = List.splitAt max bs in - let c = S.mk_Total (U.arrow_ln bs1 c) in - bs0, c - ) else bs, c - in - let env', bs, c = FStar.TypeChecker.Core.open_binders_in_comp (goal_env goal) bs c in - if not (U.is_pure_comp c) then - fail ("Codomain is effectful: " ^ show c) - else return ();! - let typ' = U.comp_result c in - let! body, ctx_uvar = - new_uvar "intros" env' typ' - (Some (should_check_goal_uvar goal)) - (goal_typedness_deps goal) - (rangeof goal) in - let sol = U.abs bs body (Some (U.residual_comp_of_comp c)) in - set_solution goal sol ;! - let g = mk_goal env' ctx_uvar goal.opts goal.is_guard goal.label in - replace_cur g ;! - return (List.map binder_to_binding bs) -) - -// TODO: missing: precedes clause, and somehow disabling fixpoints only as needed -let intro_rec () : tac (RD.binding & RD.binding) = - let! goal = cur_goal in - BU.print_string "WARNING (intro_rec): calling this is known to cause normalizer loops\n"; - BU.print_string "WARNING (intro_rec): proceed at your own risk...\n"; - match arrow_one (goal_env goal) (whnf (goal_env goal) (goal_type goal)) with - | Some (env', b, c) -> - if not (U.is_total_comp c) - then fail "Codomain is effectful" - else let bv = gen_bv "__recf" None (goal_type goal) in - let! u, ctx_uvar_u = - new_uvar "intro_rec" env' - (U.comp_result c) - (Some (should_check_goal_uvar goal)) - (goal_typedness_deps goal) - (rangeof goal) in - let lb = U.mk_letbinding (Inl bv) [] (goal_type goal) PC.effect_Tot_lid (U.abs [b] u None) [] Range.dummyRange in - let body = S.bv_to_name bv in - let lbs, body = SS.close_let_rec [lb] body in - let tm = mk (Tm_let {lbs=(true, lbs); body}) (goal_witness goal).pos in - set_solution goal tm ;! - bnorm_and_replace { goal with goal_ctx_uvar=ctx_uvar_u} ;! - return (binder_to_binding (S.mk_binder bv), binder_to_binding b) - | None -> - fail1 "intro_rec: goal is not an arrow (%s)" (tts (goal_env goal) (goal_type goal)) - -let norm (s : list Pervasives.norm_step) : tac unit = - let! goal = cur_goal in - if_verbose (fun () -> BU.print1 "norm: witness = %s\n" (show (goal_witness goal))) ;! - // Translate to actual normalizer steps - let steps = [Env.Reify; Env.DontUnfoldAttr [PC.tac_opaque_attr]]@(Cfg.translate_norm_steps s) in - //let w = normalize steps (goal_env goal) (goal_witness goal) in - let t = normalize steps (goal_env goal) (goal_type goal) in - replace_cur (goal_with_type goal t) - -let __norm_term_env - (well_typed:bool) (e : env) (s : list Pervasives.norm_step) (t : term) - : tac term -= wrap_err "norm_term" <| ( - let! ps = get in - if_verbose (fun () -> BU.print1 "norm_term_env: t = %s\n" (show t)) ;! - // only for elaborating lifts and all that, we don't care if it's actually well-typed - let! t = - if well_typed - then return t - else let! t, _, _ = __tc_lax e t in return t - in - let steps = [Env.Reify; Env.DontUnfoldAttr [PC.tac_opaque_attr]]@(Cfg.translate_norm_steps s) in - let t = normalize steps ps.main_context t in - if_verbose (fun () -> BU.print1 "norm_term_env: t' = %s\n" (show t)) ;! - return t - ) - -let norm_term_env e s t = __norm_term_env false e s t -let refl_norm_well_typed_term e s t = __norm_term_env true e s t - -let refine_intro () : tac unit = wrap_err "refine_intro" <| ( - let! g = cur_goal in - match Rel.base_and_refinement (goal_env g) (goal_type g) with - | _, None -> fail "not a refinement" - | t, Some (bv, phi) -> - //Mark goal as untyped, since we're adding its refinement as a separate goal - mark_goal_implicit_already_checked g; - let g1 = goal_with_type g t in - let bv, phi = - let bvs, phi = SS.open_term [S.mk_binder bv] phi in - (List.hd bvs).binder_bv, phi - in - let! g2 = mk_irrelevant_goal "refine_intro refinement" (goal_env g) - (SS.subst [S.NT (bv, (goal_witness g))] phi) - (Some (should_check_goal_uvar g)) - (rangeof g) - g.opts - g.label in - dismiss ;! - add_goals [g1;g2] - ) - -let __exact_now set_expected_typ (t:term) : tac unit = - let! goal = cur_goal in - let env = if set_expected_typ - then Env.set_expected_typ (goal_env goal) (goal_type goal) - else (goal_env goal) - in - let env = {env with uvar_subtyping=false} in - let! t, typ, guard = __tc env t in - if_verbose (fun () -> BU.print2 "__exact_now: got type %s\n__exact_now: and guard %s\n" - (show typ) - (Rel.guard_to_string (goal_env goal) guard)) ;! - proc_guard "__exact typing" (goal_env goal) guard (Some (should_check_goal_uvar goal)) (rangeof goal) ;! - if_verbose (fun () -> BU.print2 "__exact_now: unifying %s and %s\n" (show typ) - (show (goal_type goal))) ;! - let! b = do_unify true (goal_env goal) typ (goal_type goal) in - if b - then ( // do unify succeeded with a trivial guard; so the goal is solved and we don't have to check it again - mark_goal_implicit_already_checked goal; - solve goal t - ) - else - let typ, goalt = TypeChecker.Err.print_discrepancy (ttd (goal_env goal)) typ (goal_type goal) in - fail_doc [ - prefix 2 1 (text "Term") (ttd (goal_env goal) t) ^/^ - prefix 2 1 (text "of type") typ ^/^ - prefix 2 1 (text "does not exactly solve the goal") goalt; - ] - -let t_exact try_refine set_expected_typ tm : tac unit = wrap_err "exact" <| ( - if_verbose (fun () -> BU.print1 "t_exact: tm = %s\n" (show tm)) ;! - match! catch (__exact_now set_expected_typ tm) with - | Inr r -> return r - | Inl e when not (try_refine) -> traise e - | Inl e -> - if_verbose (fun () -> BU.print_string "__exact_now failed, trying refine...\n") ;! - match! catch (norm [Pervasives.Delta] ;! refine_intro () ;! __exact_now set_expected_typ tm) with - | Inr r -> - if_verbose (fun () -> BU.print_string "__exact_now: failed after refining too\n") ;! - return r - | Inl _ -> - if_verbose (fun () -> BU.print_string "__exact_now: was not a refinement\n") ;! - traise e) - -(* Can t1 unify t2 if it's applied to arguments? If so return uvars for them *) -(* NB: Result is reversed, which helps so we use fold_right instead of fold_left *) -let try_unify_by_application (should_check:option should_check_uvar) - (only_match:bool) - (e : env) - (ty1 : term) - (ty2 : term) - (rng:Range.range) - : tac (list (term & aqual & ctx_uvar)) - = let f = if only_match then do_match else do_unify in - let must_tot = true in - let rec aux (acc : list (term & aqual & ctx_uvar)) - (typedness_deps : list ctx_uvar) //map proj_3 acc - (ty1:term) - : tac (list (term & aqual & ctx_uvar)) - = match! f must_tot e ty2 ty1 with - | true -> return acc (* Done! *) - | false -> - (* Not a match, try instantiating the first type by application *) - match U.arrow_one ty1 with - | None -> - fail_doc [ - prefix 2 1 (text "Could not instantiate") - (ttd e ty1) ^/^ - prefix 2 1 (text "to") - (ttd e ty2) - ] - - | Some (b, c) -> - if not (U.is_total_comp c) then fail "Codomain is effectful" else - let! uvt, uv = new_uvar "apply arg" e b.binder_bv.sort should_check typedness_deps rng in - if_verbose (fun () -> BU.print1 "t_apply: generated uvar %s\n" (show uv)) ;! - let typ = U.comp_result c in - let typ' = SS.subst [S.NT (b.binder_bv, uvt)] typ in - aux ((uvt, U.aqual_of_binder b, uv)::acc) (uv::typedness_deps) typ' - in - aux [] [] ty1 - -// -// Goals for implicits created during apply -// -let apply_implicits_as_goals - (env:Env.env) - (gl:option goal) - (imps:list (term & ctx_uvar)) - : tac (list (list goal)) = - - let one_implicit_as_goal (term, ctx_uvar) = - let hd, _ = U.head_and_args term in - match (SS.compress hd).n with - | Tm_uvar (ctx_uvar, _) -> - let gl = - match gl with - | None -> mk_goal env ctx_uvar (FStar.Options.peek()) true "goal for unsolved implicit" - | Some gl -> { gl with goal_ctx_uvar = ctx_uvar } in //TODO: AR: what's happening here? - let gl = bnorm_goal gl in - return #tac [gl] // FIXME: inference failure! - | _ -> - // - // This implicits has already been solved - // We would have typechecked its solution already, - // just after the Rel call - // - return [] - in - imps |> mapM one_implicit_as_goal - -// uopt: Don't add goals for implicits that appear free in posterior goals. -// This is very handy for users, allowing to turn -// -// |- a = c -// -// by applying transivity to -// -// |- a = ?u -// |- ?u = c -// -// without asking for |- ?u : Type first, which will most likely be instantiated when -// solving any of these two goals. In any case, if ?u is not solved, we will later fail. -// TODO: this should probably be made into a user tactic -let t_apply (uopt:bool) (only_match:bool) (tc_resolved_uvars:bool) (tm:term) : tac unit = wrap_err "apply" <| ( - let tc_resolved_uvars = true in - if_verbose - (fun () -> BU.print4 "t_apply: uopt %s, only_match %s, tc_resolved_uvars %s, tm = %s\n" - (show uopt) - (show only_match) - (show tc_resolved_uvars) - (show tm)) ;! - let! ps = get in - let! goal = cur_goal in - let e = goal_env goal in - let should_check = should_check_goal_uvar goal in - Tactics.Monad.register_goal goal; - let! tm, typ, guard = __tc e tm in - if_verbose - (fun () -> BU.print5 "t_apply: tm = %s\nt_apply: goal = %s\nenv.gamma=%s\ntyp=%s\nguard=%s\n" - (show tm) - (goal_to_string_verbose goal) - (show e.gamma) - (show typ) - (Rel.guard_to_string e guard)) ;! - // Focus helps keep the goal order - let typ = bnorm e typ in - if only_match && not (is_empty (Free.uvars_uncached typ)) then - fail "t_apply: only_match is on, but the type of the term to apply is not a uvar" - else return ();! - let! uvs = try_unify_by_application (Some should_check) only_match e typ (goal_type goal) (rangeof goal) in - if_verbose - (fun () -> BU.print1 "t_apply: found args = %s\n" - (FStar.Common.string_of_list (fun (t, _, _) -> show t) uvs)) ;! - let w = List.fold_right (fun (uvt, q, _) w -> U.mk_app w [(uvt, q)]) uvs tm in - let uvset = - List.fold_right - (fun (_, _, uv) s -> union s (SF.uvars (U.ctx_uvar_typ uv))) - uvs - (empty ()) - in - let free_in_some_goal uv = mem uv uvset in - solve' goal w ;! - // - //process uvs - //first, if some of them are solved already, perhaps during unification, - // typecheck them if tc_resolved_uvars is on - //then, if uopt is on, filter out those that appear in other goals - //add the rest as goals - // - let uvt_uv_l = uvs |> List.map (fun (uvt, _q, uv) -> (uvt, uv)) in - let! sub_goals = - apply_implicits_as_goals e (Some goal) uvt_uv_l in - let sub_goals = List.flatten sub_goals - |> List.filter (fun g -> - //if uopt is on, we don't keep uvars that - // appear in some other goals - not (uopt && free_in_some_goal g.goal_ctx_uvar)) - |> List.map bnorm_goal - |> List.rev in - add_goals sub_goals ;! - proc_guard "apply guard" e guard (Some should_check) (rangeof goal) - ) - -// returns pre and post -let lemma_or_sq (c : comp) : option (term & term) = - let eff_name, res, args = U.comp_eff_name_res_and_args c in - if lid_equals eff_name PC.effect_Lemma_lid then - let pre, post = match args with - | pre::post::_ -> fst pre, fst post - | _ -> failwith "apply_lemma: impossible: not a lemma" - in - // Lemma post is thunked - let post = U.mk_app post [S.as_arg U.exp_unit] in - Some (pre, post) - else if U.is_pure_effect eff_name - || U.is_ghost_effect eff_name then - map_opt (U.un_squash res) (fun post -> (U.t_true, post)) - else - None - -let t_apply_lemma (noinst:bool) (noinst_lhs:bool) - (tm:term) : tac unit = wrap_err "apply_lemma" <| focus ( - let! ps = get in - if_verbose (fun () -> BU.print1 "apply_lemma: tm = %s\n" (show tm)) ;! - let is_unit_t t = - match (SS.compress t).n with - | Tm_fvar fv when S.fv_eq_lid fv PC.unit_lid -> true - | _ -> false - in - let! goal = cur_goal in - let env = goal_env goal in - Tactics.Monad.register_goal goal; - let! tm, t, guard = - let env = {env with uvar_subtyping=false} in - __tc env tm - in - let bs, comp = U.arrow_formals_comp t in - match lemma_or_sq comp with - | None -> fail "not a lemma or squashed function" - | Some (pre, post) -> - let! uvs, _, implicits, subst = - foldM_left - (fun (uvs, deps, imps, subst) ({binder_bv=b;binder_qual=aq}) -> - let b_t = SS.subst subst b.sort in - if is_unit_t b_t - then - // Simplification: if the argument is simply unit, then don't ask for it - return <| ((U.exp_unit, aq)::uvs, deps, imps, S.NT(b, U.exp_unit)::subst) - else - let! t, u = new_uvar "apply_lemma" env b_t - (goal - |> should_check_goal_uvar - |> (function | Strict -> Allow_ghost "apply lemma uvar" - | x -> x) - |> Some) - deps - (rangeof goal) in - if !dbg_2635 - then - BU.print2 "Apply lemma created a new uvar %s while applying %s\n" - (show u) - (show tm); - return ((t, aq)::uvs, u::deps, (t, u)::imps, S.NT(b, t)::subst)) - ([], [], [], []) - bs - in - let implicits = List.rev implicits in - let uvs = List.rev uvs in - let pre = SS.subst subst pre in - let post = SS.subst subst post in - let post_u = env.universe_of env post in - let cmp_func = - if noinst then do_match - else if noinst_lhs then do_match_on_lhs - else do_unify - in - let! b = - let must_tot = false in - cmp_func must_tot env (goal_type goal) (U.mk_squash post_u post) in - if not b - then ( - let open FStar.Class.PP in - let open FStar.Pprint in - let open FStar.Errors.Msg in - // let post, goalt = TypeChecker.Err.print_discrepancy (tts env) - // (U.mk_squash post_u post) - // (goal_type goal) in - fail_doc [ - prefix 2 1 (text "Cannot instantiate lemma:") (pp tm) ^/^ - prefix 2 1 (text "with postcondition:") (N.term_to_doc env post) ^/^ - prefix 2 1 (text "to match goal:") (pp (goal_type goal)) - ] - ) - else ( - // We solve with (), we don't care about the witness if applying a lemma - let goal_sc = should_check_goal_uvar goal in - solve' goal U.exp_unit ;! - let is_free_uvar uv t = - for_any (fun u -> UF.equiv u.ctx_uvar_head uv) (SF.uvars t) - in - let appears uv goals = List.existsML (fun g' -> is_free_uvar uv (goal_type g')) goals in - let checkone t goals = - let hd, _ = U.head_and_args t in - begin match hd.n with - | Tm_uvar (uv, _) -> appears uv.ctx_uvar_head goals - | _ -> false - end - in - let must_tot = false in - let! sub_goals = - apply_implicits_as_goals env (Some goal) implicits in - let sub_goals = List.flatten sub_goals in - // Optimization: if a uvar appears in a later goal, don't ask for it, since - // it will be instantiated later. It is tracked anyway in ps.implicits - let rec filter' (f : 'a -> list 'a -> bool) (xs : list 'a) : list 'a = - match xs with - | [] -> [] - | x::xs -> if f x xs then x::(filter' f xs) else filter' f xs - in - let sub_goals = filter' (fun g goals -> not (checkone (goal_witness g) goals)) sub_goals in - proc_guard "apply_lemma guard" env guard (Some goal_sc) (rangeof goal) ;! - let pre_u = env.universe_of env pre in - (match (Rel.simplify_guard env (Env.guard_of_guard_formula (NonTrivial pre))).guard_f with - | Trivial -> return () - | NonTrivial _ -> add_irrelevant_goal goal "apply_lemma precondition" env pre (Some goal_sc)) ;!//AR: should we use the normalized pre instead? - add_goals sub_goals - ) - ) - -let split_env (bvar : bv) (e : env) : option (env & bv & list bv) = - let rec aux e = - match Env.pop_bv e with - | None -> None - | Some (bv', e') -> - if S.bv_eq bvar bv' - then Some (e', bv', []) - else map_opt (aux e') (fun (e'', bv, bvs) -> (e'', bv, bv'::bvs )) - in - map_opt (aux e) (fun (e', bv, bvs) -> (e', bv, List.rev bvs)) - -let subst_goal (b1 : bv) (b2 : bv) (g:goal) : tac (option (bv & goal)) = - match split_env b1 (goal_env g) with - | Some (e0, b1, bvs) -> - let bs = List.map S.mk_binder (b1::bvs) in - - let t = goal_type g in - - (* Close the binders and t *) - let bs', t' = SS.close_binders bs, SS.close bs t in - - (* Replace b1 (the head) by b2 *) - let bs' = S.mk_binder b2 :: List.tail bs' in - - (* Re-open, all done for renaming *) - let new_env, bs'', t'' = Core.open_binders_in_term e0 bs' t' in - - // (* b2 has been freshened *) - let b2 = (List.hd bs'').binder_bv in - - // (* Make a new goal in the new env (with new binders) *) - let! uvt, uv = new_uvar "subst_goal" new_env t'' - (Some (should_check_goal_uvar g)) - (goal_typedness_deps g) - (rangeof g) in - - let goal' = mk_goal new_env uv g.opts g.is_guard g.label in - - (* Solve the old goal with an application of the new witness *) - let sol = U.mk_app (U.abs bs'' uvt None) - (List.map (fun ({binder_bv=bv;binder_qual=q}) -> S.as_arg (S.bv_to_name bv)) bs) in - - set_solution g sol ;! - - return (Some (b2, goal')) - - | None -> - return None - -let rewrite (hh:RD.binding) : tac unit = wrap_err "rewrite" <| ( - let! goal = cur_goal in - let h = binding_to_binder hh in - let bv = h.binder_bv in - if_verbose (fun _ -> BU.print2 "+++Rewrite %s : %s\n" (show bv) (show bv.sort)) ;! - match split_env bv (goal_env goal) with - | None -> fail "binder not found in environment" - | Some (e0, bv, bvs) -> - begin - match destruct_eq e0 bv.sort with - | Some (x, e) -> - begin - match (SS.compress x).n with - | Tm_name x -> - let s = [NT(x, e)] in - - (* See subst_goal for an explanation *) - let t = goal_type goal in - let bs = List.map S.mk_binder bvs in - - let bs', t' = SS.close_binders bs, SS.close bs t in - let bs', t' = SS.subst_binders s bs', SS.subst s t' in - let e0 = Env.push_bvs e0 [bv] in - let new_env, bs'', t'' = Core.open_binders_in_term e0 bs' t' in - - let! uvt, uv = - new_uvar "rewrite" new_env t'' - (Some (should_check_goal_uvar goal)) - (goal_typedness_deps goal) - (rangeof goal) - in - let goal' = mk_goal new_env uv goal.opts goal.is_guard goal.label in - let sol = U.mk_app (U.abs bs'' uvt None) - (List.map (fun ({binder_bv=bv}) -> S.as_arg (S.bv_to_name bv)) bs) in - - (* See comment in subst_goal *) - set_solution goal sol ;! - replace_cur goal' - - | _ -> - fail "Not an equality hypothesis with a variable on the LHS" - end - | _ -> fail "Not an equality hypothesis" - end - ) - -let replace (t1 t2 : term) (s : term) : term = - Syntax.Visit.visit_term false (fun t -> - if U.term_eq t t1 - then t2 - else t) s - -let grewrite (t1 t2 : term) : tac unit = wrap_err "grewrite" <| (focus ( - let! goal = cur_goal in - let goal_t = goal_type goal in - let env = goal_env goal in - let! t1, typ1, g1 = __tc env t1 in - let! t2, typ2, g2 = __tc env t2 in - - (* Remove top level refinements. We just need to create an equality between t1 and t2,, - one of them could have a refined type and that should not matter. *) - let typ1' = N.unfold_whnf' [Env.Unrefine] env typ1 in - let typ2' = N.unfold_whnf' [Env.Unrefine] env typ2 in - if! do_unify false env typ1' typ2' then - return () - else ( - fail_doc [ - text "Types do not match for grewrite"; - text "Type of" ^/^ parens (pp t1) ^/^ equals ^/^ pp typ1; - text "Type of" ^/^ parens (pp t2) ^/^ equals ^/^ pp typ2; - ] - );! - let u = env.universe_of env typ1 in - let goal_t' = replace t1 t2 goal_t in - - let! g_eq = - (* However, retain the original, possibly refined, of t1 for this equality. *) - mk_irrelevant_goal "grewrite.eq" env (U.mk_eq2 u typ1 t1 t2) None - goal.goal_ctx_uvar.ctx_uvar_range goal.opts goal.label - in - - replace_cur (goal_with_type goal goal_t');! - push_goals [g_eq];! - - return () -)) - -let rename_to (b : RD.binding) (s : string) : tac RD.binding = wrap_err "rename_to" <| ( - let! goal = cur_goal in - let bv = binding_to_bv b in - let bv' = freshen_bv ({ bv with ppname = mk_ident (s, (range_of_id bv.ppname)) }) in - match! subst_goal bv bv' goal with - | None -> fail "binder not found in environment" - | Some (bv', goal) -> - replace_cur goal ;! - let uniq = Z.of_int_fs bv'.index in - return {b with uniq=uniq; ppname = Sealed.seal s} - ) - -let var_retype (b : RD.binding) : tac unit = wrap_err "binder_retype" <| ( - let! goal = cur_goal in - let bv = binding_to_bv b in - match split_env bv (goal_env goal) with - | None -> fail "binder is not present in environment" - | Some (e0, bv, bvs) -> - let (ty, u) = U.type_u () in - let goal_sc = should_check_goal_uvar goal in - let! t', u_t' = - new_uvar "binder_retype" e0 ty - (Some goal_sc) - (goal_typedness_deps goal) - (rangeof goal) - in - let bv'' = {bv with sort = t'} in - let s = [S.NT (bv, S.bv_to_name bv'')] in - let bvs = List.map (fun b -> { b with sort = SS.subst s b.sort }) bvs in - let env' = Env.push_bvs e0 (bv''::bvs) in - dismiss ;! - let new_goal = - goal_with_type - (goal_with_env goal env') - (SS.subst s (goal_type goal)) - in - add_goals [new_goal] ;! - add_irrelevant_goal goal "binder_retype equation" e0 - (U.mk_eq2 (U_succ u) ty bv.sort t') - (Some goal_sc) - ) - -let norm_binding_type (s : list Pervasives.norm_step) (b : RD.binding) : tac unit = wrap_err "norm_binding_type" <| ( - let! goal = cur_goal in - let bv = binding_to_bv b in - match split_env bv (goal_env goal) with - | None -> fail "binder is not present in environment" - | Some (e0, bv, bvs) -> - let steps = [Env.Reify; Env.DontUnfoldAttr [PC.tac_opaque_attr]]@(Cfg.translate_norm_steps s) in - let sort' = normalize steps e0 bv.sort in - let bv' = { bv with sort = sort' } in - let env' = Env.push_bvs e0 (bv'::bvs) in - replace_cur (goal_with_env goal env') - ) - -let revert () : tac unit = - let! goal = cur_goal in - match Env.pop_bv (goal_env goal) with - | None -> fail "Cannot revert; empty context" - | Some (x, env') -> - let typ' = U.arrow [S.mk_binder x] (mk_Total (goal_type goal)) in - let! r, u_r = - new_uvar "revert" env' typ' - (Some (should_check_goal_uvar goal)) - (goal_typedness_deps goal) - (rangeof goal) in - set_solution goal (S.mk_Tm_app r [S.as_arg (S.bv_to_name x)] (goal_type goal).pos) ;! - let g = mk_goal env' u_r goal.opts goal.is_guard goal.label in - replace_cur g - -let free_in bv t = mem bv (SF.names t) - -let clear (b : RD.binding) : tac unit = - let bv = binding_to_bv b in - let! goal = cur_goal in - if_verbose (fun () -> BU.print2 "Clear of (%s), env has %s binders\n" - (binding_to_string b) - (Env.all_binders (goal_env goal) |> List.length |> show)) ;! - match split_env bv (goal_env goal) with - | None -> fail "Cannot clear; binder not in environment" - | Some (e', bv, bvs) -> - let rec check bvs = - match bvs with - | [] -> return () - | bv'::bvs -> - if free_in bv bv'.sort - then fail (BU.format1 "Cannot clear; binder present in the type of %s" - (show bv')) - else check bvs - in - if free_in bv (goal_type goal) then - fail "Cannot clear; binder present in goal" - else ( - check bvs ;! - let env' = Env.push_bvs e' bvs in - let! ut, uvar_ut = - new_uvar "clear.witness" env' (goal_type goal) - (Some (should_check_goal_uvar goal)) - (goal_typedness_deps goal) - (rangeof goal) in - set_solution goal ut ;! - replace_cur (mk_goal env' uvar_ut goal.opts goal.is_guard goal.label) - ) - -let clear_top () : tac unit = - let! goal = cur_goal in - match Env.pop_bv (goal_env goal) with - | None -> fail "Cannot clear; empty context" - | Some (x, _) -> clear (bv_to_binding x) // we ignore the qualifier anyway - -let prune (s:string) : tac unit = - let! g = cur_goal in - let ctx = goal_env g in - let ctx' = Env.rem_proof_ns ctx (path_of_text s) in - let g' = goal_with_env g ctx' in - replace_cur g' - -let addns (s:string) : tac unit = - let! g = cur_goal in - let ctx = goal_env g in - let ctx' = Env.add_proof_ns ctx (path_of_text s) in - let g' = goal_with_env g ctx' in - replace_cur g' - -let guard_formula (g:guard_t) : term = - match g.guard_f with - | Trivial -> U.t_true - | NonTrivial f -> f - -let _t_trefl (allow_guards:bool) (l : term) (r : term) : tac unit = - let should_register_trefl g = - let should_register = true in - let skip_register = false in - if not (Options.compat_pre_core_should_register()) then skip_register else - //Sending a goal t1 == t2 to the core for registration can be expensive - //particularly if the terms are big, e.g., when they are WPs etc - //This function decides which goals to register, using two criteria - //1. If the uvars in the goal are Allow_untyped or Already_checked - // then don't bother registering, since we will not recheck the solution. - // - //2. If the goal is of the form `eq2 #ty ?u t` (or vice versa) - // and we can prove that ty <: ?u.t - // then the assignment of `?u := t` is going to be well-typed - // without needing to recompute the type of `t` - let is_uvar_untyped_or_already_checked u = - let dec = UF.find_decoration u.ctx_uvar_head in - match dec.uvar_decoration_should_check with - | Allow_untyped _ - | Already_checked -> true - | _ -> false - in - let is_uvar t = - let head = U.leftmost_head t in - match (SS.compress head).n with - | Tm_uvar (u, _) -> Inl (u, head, t) - | _ -> Inr t - in - let is_allow_untyped_uvar t = - match is_uvar t with - | Inr _ -> false - | Inl (u, _, _) -> is_uvar_untyped_or_already_checked u - in - let t = U.ctx_uvar_typ g.goal_ctx_uvar in - let uvars = FStar.Syntax.Free.uvars t in - if for_all is_uvar_untyped_or_already_checked uvars - then skip_register //all the uvars are already checked or untyped - else ( - let head, args = - let t = - match U.un_squash t with - | None -> t - | Some t -> t - in - U.leftmost_head_and_args t - in - match (SS.compress (U.un_uinst head)).n, args with - | Tm_fvar fv, [(ty, _); (t1, _); (t2, _)] - when S.fv_eq_lid fv PC.eq2_lid -> - if is_allow_untyped_uvar t1 || is_allow_untyped_uvar t2 - then skip_register //if we have ?u=t or t=?u and ?u is allow_untyped, then skip - else if Tactics.Monad.is_goal_safe_as_well_typed g //o.w., if the goal is well typed - then ( - //and the goal is of the shape - // eq2 #ty ?u t or - // eq2 #ty t ?u - // Then solving this, if it succeeds, is going to assign ?u := t - // If we know that `ty <: ?u.ty` then this is well-typed already - // without needing to recheck the assignment - // Note, from well-typedness of the goal, we already know ?u.ty <: ty - let check_uvar_subtype u t = - let env = { goal_env g with gamma = g.goal_ctx_uvar.ctx_uvar_gamma } in - match Core.compute_term_type_handle_guards env t (fun _ _ -> true) - with - | Inr _ -> false - | Inl (_, t_ty) -> ( // ignoring effect, ghost is ok - match Core.check_term_subtyping true true env ty t_ty with - | Inl None -> //unconditional subtype - mark_uvar_as_already_checked u; - true - | _ -> - false - ) - in - match is_uvar t1, is_uvar t2 with - | Inl (u, _, tu), Inr _ - | Inr _, Inl (u, _, tu) -> - //if the condition fails, then return true to register this goal - //since the assignment will have to be rechecked - if check_uvar_subtype u tu - then skip_register - else should_register - | _ -> - should_register - ) - else should_register - | _ -> - should_register - ) - in - let! g = cur_goal in - let should_check = should_check_goal_uvar g in - if should_register_trefl g - then Tactics.Monad.register_goal g; - let must_tot = true in - let attempt (l : term) (r : term) : tac bool = - match! do_unify_maybe_guards allow_guards must_tot (goal_env g) l r with - | None -> return false - | Some guard -> - solve' g U.exp_unit ;! - if allow_guards - then - let! goal = goal_of_guard "t_trefl" (goal_env g) (guard_formula guard) (Some should_check) (rangeof g) in - push_goals [goal] ;! - return true - else - // If allow_guards is false, this guard must be trivial and we don't - // add it, but we check its triviality for sanity. - if Env.is_trivial_guard_formula guard - then return true - else failwith "internal error: _t_refl: guard is not trivial" - in - match! attempt l r with - | true -> return () - | false -> - (* if that didn't work, normalize and retry *) - let norm = N.normalize [Env.UnfoldUntil delta_constant; Env.Primops; Env.DontUnfoldAttr [PC.tac_opaque_attr]] (goal_env g) in - match! attempt (norm l) (norm r) with - | true -> return () - | false -> - let ls, rs = TypeChecker.Err.print_discrepancy (tts (goal_env g)) l r in - fail2 "cannot unify (%s) and (%s)" ls rs - -let t_trefl (allow_guards:bool) : tac unit = wrap_err "t_trefl" <| ( - match! - catch (//restore UF graph, including any Already_checked markers, if anything fails - let! g = cur_goal in - match destruct_eq (goal_env g) (goal_type g) with - | Some (l, r) -> - _t_trefl allow_guards l r - | None -> - fail1 "not an equality (%s)" (tts (goal_env g) (goal_type g)) - ) - with - | Inr v -> return v - | Inl exn -> traise exn - ) - -let dup () : tac unit = - let! g = cur_goal in - let goal_sc = should_check_goal_uvar g in - let env = goal_env g in - let! u, u_uvar = - new_uvar "dup" env (goal_type g) - (Some (should_check_goal_uvar g)) - (goal_typedness_deps g) - (rangeof g) in - //the new uvar is just as Strict as the original one. So, its assignement will be checked - //and we have a goal that requires us to prove it equal to the original uvar - //so we can clear the should_check status of the current uvar - mark_uvar_as_already_checked g.goal_ctx_uvar; - let g' = { g with goal_ctx_uvar = u_uvar } in - dismiss ;! - let t_eq = U.mk_eq2 (env.universe_of env (goal_type g)) (goal_type g) u (goal_witness g) in - add_irrelevant_goal g "dup equation" env t_eq (Some goal_sc) ;! - add_goals [g'] - -// longest_prefix f l1 l2 = (p, r1, r2) ==> l1 = p@r1 /\ l2 = p@r2 ; and p is maximal -let longest_prefix (f : 'a -> 'a -> bool) (l1 : list 'a) (l2 : list 'a) : list 'a & list 'a & list 'a = - let rec aux acc l1 l2 = - match l1, l2 with - | x::xs, y::ys -> - if f x y - then aux (x::acc) xs ys - else acc, x::xs, y::ys - | _ -> - acc, l1, l2 - in - let pr, t1, t2 = aux [] l1 l2 in - List.rev pr, t1, t2 - -let eq_binding b1 b2 = - match b1, b2 with - | _ -> false - | S.Binding_var bv1, Binding_var bv2 -> bv_eq bv1 bv2 && U.term_eq bv1.sort bv2.sort - | S.Binding_lid (lid1, _), Binding_lid (lid2, _) -> lid_equals lid1 lid2 - | S.Binding_univ u1, Binding_univ u2 -> ident_equals u1 u2 - | _ -> false - -// fix universes -let join_goals g1 g2 : tac goal = - (* The one in Syntax.Util ignores null_binders, why? *) - let close_forall_no_univs bs f = - List.fold_right (fun b f -> U.mk_forall_no_univ b.binder_bv f) bs f - in - match get_phi g1 with - | None -> fail "goal 1 is not irrelevant" - | Some phi1 -> - match get_phi g2 with - | None -> fail "goal 2 is not irrelevant" - | Some phi2 -> - - let gamma1 = g1.goal_ctx_uvar.ctx_uvar_gamma in - let gamma2 = g2.goal_ctx_uvar.ctx_uvar_gamma in - let gamma, r1, r2 = longest_prefix eq_binding (List.rev gamma1) (List.rev gamma2) in - - let t1 = close_forall_no_univs (Env.binders_of_bindings (List.rev r1)) phi1 in - let t2 = close_forall_no_univs (Env.binders_of_bindings (List.rev r2)) phi2 in - - let goal_sc = - match should_check_goal_uvar g1, should_check_goal_uvar g2 with - | Allow_untyped reason1, Allow_untyped _ -> Some (Allow_untyped reason1) - | _ -> None - in - - let ng = U.mk_conj t1 t2 in - let nenv = { goal_env g1 with gamma = List.rev gamma } in - let! goal = mk_irrelevant_goal "joined" nenv ng goal_sc (rangeof g1) g1.opts g1.label in - if_verbose (fun () -> BU.print3 "join_goals of\n(%s)\nand\n(%s)\n= (%s)\n" - (goal_to_string_verbose g1) - (goal_to_string_verbose g2) - (goal_to_string_verbose goal)) ;! - set_solution g1 U.exp_unit ;! - set_solution g2 U.exp_unit ;! - return goal - -let join () : tac unit = - let! ps = get in - match ps.goals with - | g1::g2::gs -> - set { ps with goals = gs } ;! - let! g12 = join_goals g1 g2 in - add_goals [g12] - - | _ -> fail "join: less than 2 goals" - - -let set_options (s : string) : tac unit = wrap_err "set_options" <| ( - let! g = cur_goal in - FStar.Options.push (); - FStar.Options.set g.opts; - let res = FStar.Options.set_options s in - let opts' = FStar.Options.peek () in - FStar.Options.pop (); - match res with - | FStar.Getopt.Success -> - let g' = { g with opts = opts' } in - replace_cur g' - | FStar.Getopt.Error err -> - fail2 "Setting options `%s` failed: %s" s err - | FStar.Getopt.Help -> - fail1 "Setting options `%s` failed (got `Help`?)" s - ) - -let top_env () : tac env = let! ps = get in return <| ps.main_context - -let lax_on () : tac bool = - (* Check the goal if any??? *) - let! ps = get in - return ps.main_context.admit - -let unquote (ty : term) (tm : term) : tac term = wrap_err "unquote" <| ( - if_verbose (fun () -> BU.print1 "unquote: tm = %s\n" (show tm)) ;! - let! goal = cur_goal in - let env = Env.set_expected_typ (goal_env goal) ty in - let! tm, typ, guard = __tc_ghost env tm in - if_verbose (fun () -> BU.print1 "unquote: tm' = %s\n" (show tm)) ;! - if_verbose (fun () -> BU.print1 "unquote: typ = %s\n" (show typ)) ;! - proc_guard "unquote" env guard (Some (should_check_goal_uvar goal)) (rangeof goal) ;! - return tm - ) - -let uvar_env (env : env) (ty : option typ) : tac term = - let! ps = get in - // If no type was given, add a uvar for it too! - let! typ, g, r = - match ty with - | Some ty -> - let env = Env.set_expected_typ env (U.type_u () |> fst) in - let! ty, _, g = __tc_ghost env ty in - return (ty, g, ty.pos) - - | None -> - //the type of this uvar is just Type; so it's typedness deps is [] - let! typ, uvar_typ = new_uvar "uvar_env.2" env (fst <| U.type_u ()) None [] ps.entry_range in - return (typ, Env.trivial_guard, Range.dummyRange) - in - proc_guard "uvar_env_typ" env g None r;! - //the guard is an explicit goal; so the typedness deps of this new uvar is [] - let! t, uvar_t = new_uvar "uvar_env" env typ None [] ps.entry_range in - return t - -let ghost_uvar_env (env : env) (ty : typ) : tac term = - let! ps = get in - // If no type was given, add a uvar for it too! - let! typ, _, g = __tc_ghost env ty in - proc_guard "ghost_uvar_env_typ" env g None ty.pos ;! - //the guard is an explicit goal; so the typedness deps of this new uvar is [] - let! t, uvar_t = new_uvar "uvar_env" env typ (Some (Allow_ghost "User ghost uvar")) [] ps.entry_range in - return t - -let fresh_universe_uvar () : tac term = - U.type_u () |> fst |> return - -let unshelve (t : term) : tac unit = wrap_err "unshelve" <| ( - let! ps = get in - let env = ps.main_context in - (* We need a set of options, but there might be no goals, so do this *) - let opts = match ps.goals with - | g::_ -> g.opts - | _ -> FStar.Options.peek () - in - match U.head_and_args t with - | { n = Tm_uvar (ctx_uvar, _) }, _ -> - let env = {env with gamma=ctx_uvar.ctx_uvar_gamma} in - let g = mk_goal env ctx_uvar opts false "" in - let g = bnorm_goal g in - add_goals [g] - | _ -> fail "not a uvar" - ) - -let tac_and (t1 : tac bool) (t2 : tac bool) : tac bool = - match! t1 with - | false -> return false - | true -> t2 - -let default_if_err (def : 'a) (t : tac 'a) : tac 'a = - let! r = catch t in - match r with - | Inl _ -> return def - | Inr v -> return v - -let match_env (e:env) (t1 : term) (t2 : term) : tac bool = wrap_err "match_env" <| ( - let! ps = get in - let! t1, ty1, g1 = __tc e t1 in - let! t2, ty2, g2 = __tc e t2 in - proc_guard "match_env g1" e g1 None ps.entry_range ;! - proc_guard "match_env g2" e g2 None ps.entry_range ;! - let must_tot = true in - default_if_err false <| - tac_and (do_match must_tot e ty1 ty2) - (do_match must_tot e t1 t2) - ) - -let unify_env (e:env) (t1 : term) (t2 : term) : tac bool = wrap_err "unify_env" <| ( - let! ps = get in - let! t1, ty1, g1 = __tc e t1 in - let! t2, ty2, g2 = __tc e t2 in - proc_guard "unify_env g1" e g1 None ps.entry_range ;! - proc_guard "unify_env g2" e g2 None ps.entry_range ;! - let must_tot = true in - default_if_err false <| - tac_and (do_unify must_tot e ty1 ty2) - (do_unify must_tot e t1 t2) - ) - -let unify_guard_env (e:env) (t1 : term) (t2 : term) : tac bool = wrap_err "unify_guard_env" <| ( - let! ps = get in - let! t1, ty1, g1 = __tc e t1 in - let! t2, ty2, g2 = __tc e t2 in - proc_guard "unify_guard_env g1" e g1 None ps.entry_range ;! - proc_guard "unify_guard_env g2" e g2 None ps.entry_range ;! - let must_tot = true in - match! do_unify_maybe_guards true must_tot e ty1 ty2 with - | None -> return false - | Some g1 -> - match! do_unify_maybe_guards true must_tot e t1 t2 with - | None -> return false - | Some g2 -> - let formula : term = U.mk_conj (guard_formula g1) (guard_formula g2) in - let! goal = goal_of_guard "unify_guard_env.g2" e formula None ps.entry_range in - push_goals [goal] ;! - return true - ) - -let launch_process (prog : string) (args : list string) (input : string) : tac string = - // The `bind return ()` thunks the tactic - return ();! - if Options.unsafe_tactic_exec () then - let s = BU.run_process "tactic_launch" prog args (Some input) in - return s - else - fail "launch_process: will not run anything unless --unsafe_tactic_exec is provided" - -let fresh_bv_named (nm : string) : tac bv = - // The `bind return ()` thunks the tactic. Not really needed, just being paranoid - return ();! return (gen_bv nm None S.tun) - -let change (ty : typ) : tac unit = wrap_err "change" <| ( - if_verbose (fun () -> BU.print1 "change: ty = %s\n" (show ty)) ;! - let! g = cur_goal in - let! ty, _, guard = __tc (goal_env g) ty in - proc_guard "change" (goal_env g) guard (Some (should_check_goal_uvar g)) (rangeof g) ;! - let must_tot = true in - let! bb = do_unify must_tot (goal_env g) (goal_type g) ty in - if bb - then replace_cur (goal_with_type g ty) - else begin - (* Give it a second try, fully normalize the term the user gave - * and unify it with the fully normalized goal. If that succeeds, - * we use the original one as the new goal. This is sometimes needed - * since the unifier has some bugs. *) - let steps = [Env.AllowUnboundUniverses; Env.UnfoldUntil delta_constant; Env.Primops] in - let ng = normalize steps (goal_env g) (goal_type g) in - let nty = normalize steps (goal_env g) ty in - let! b = do_unify must_tot (goal_env g) ng nty in - if b - then replace_cur (goal_with_type g ty) - else fail "not convertible" - end - ) - -let failwhen (b:bool) (msg:string) : tac unit = - if b - then fail msg - else return () - -let t_destruct (s_tm : term) : tac (list (fv & Z.t)) = wrap_err "destruct" <| ( - let! g = cur_goal in - let! s_tm, s_ty, guard = __tc (goal_env g) s_tm in - proc_guard "destruct" (goal_env g) guard (Some (should_check_goal_uvar g)) (rangeof g) ;! - let s_ty = N.normalize [Env.DontUnfoldAttr [PC.tac_opaque_attr]; Env.Weak; Env.HNF; Env.UnfoldUntil delta_constant] - (goal_env g) s_ty in - let h, args = U.head_and_args_full (U.unrefine s_ty) in - let! fv, a_us = - match (SS.compress h).n with - | Tm_fvar fv -> return (fv, []) - | Tm_uinst (h', us) -> - begin match (SS.compress h').n with - | Tm_fvar fv -> return (fv, us) - | _ -> failwith "impossible: uinst over something that's not an fvar" - end - | _ -> fail "type is not an fv" - in - let t_lid = lid_of_fv fv in - match Env.lookup_sigelt (goal_env g) t_lid with - | None -> fail "type not found in environment" - | Some se -> - match se.sigel with - | Sig_inductive_typ {us=t_us; params=t_ps; t=t_ty; mutuals=mut; ds=c_lids} -> - (* High-level idea of this huge function: - * For Gamma |- w : phi and | C : ps -> bs -> t, we generate a new goal - * Gamma |- w' : bs -> phi - * with - * w = match tm with ... | C .ps' bs' -> w' bs' ... - * i.e., we do not intro the matched binders and let the - * user do that (with the returned arity). `.ps` represents inaccesible patterns - * for the type's parameters. - *) - let erasable = U.has_attribute se.sigattrs FStar.Parser.Const.erasable_attr in - failwhen (erasable && not (is_irrelevant g)) "cannot destruct erasable type to solve proof-relevant goal" ;! - - (* Instantiate formal universes to the actuals, - * and substitute accordingly in binders and types *) - failwhen (List.length a_us <> List.length t_us) "t_us don't match?" ;! - - - (* Not needed currently? *) - (* let s = Env.mk_univ_subst t_us a_us in *) - (* let t_ps = SS.subst_binders s t_ps in *) - (* let t_ty = SS.subst s t_ty in *) - let t_ps, t_ty = SS.open_term t_ps t_ty in - - let! goal_brs = - mapM (fun c_lid -> - match Env.lookup_sigelt (goal_env g) c_lid with - | None -> fail "ctor not found?" - | Some se -> - match se.sigel with - | Sig_datacon {us=c_us; t=c_ty; num_ty_params=nparam; mutuals=mut} -> - (* BU.print2 "ty of %s = %s\n" (show c_lid) *) - (* (show c_ty); *) - (* Make sure to preserve qualifiers if possible. - This is mostly so we retain Record_projector quals, which - are meaningful for extraction. *) - let qual = - let fallback () = Some Data_ctor in - let qninfo = Env.lookup_qname (goal_env g) c_lid in - match qninfo with - | Some (Inr (se, _us), _rng) -> - Syntax.DsEnv.fv_qual_of_se se - | _ -> - fallback () - in - let fv = S.lid_as_fv c_lid qual in - - failwhen (List.length a_us <> List.length c_us) "t_us don't match?" ;! - let s = Env.mk_univ_subst c_us a_us in - let c_ty = SS.subst s c_ty in - - (* The constructor might be universe-polymorphic, just use - * fresh univ_uvars for its universes. *) - let c_us, c_ty = Env.inst_tscheme (c_us, c_ty) in - - (* BU.print2 "ty(2) of %s = %s\n" (show c_lid) *) - (* (show c_ty); *) - - (* Deconstruct its type, separating the parameters from the - * actual arguments (indices do not matter here). *) - let bs, comp = U.arrow_formals_comp c_ty in - - (* More friendly names: 'a_i' instead of '_i' *) - let bs, comp = - let rename_bv bv = - let ppname = bv.ppname in - let ppname = mk_ident ("a" ^ show ppname, range_of_id ppname) in - // freshen just to be extra safe.. probably not needed - freshen_bv ({ bv with ppname = ppname }) - in - let bs' = List.map (fun b -> {b with binder_bv=rename_bv b.binder_bv}) bs in - let subst = List.map2 (fun ({binder_bv=bv}) ({binder_bv=bv'}) -> NT (bv, bv_to_name bv')) bs bs' in - SS.subst_binders subst bs', SS.subst_comp subst comp - in - - (* BU.print1 "bs = (%s)\n" (Print.binders_to_string ", " bs); *) - let d_ps, bs = List.splitAt nparam bs in - failwhen (not (U.is_total_comp comp)) "not total?" ;! - let mk_pat p = { v = p; p = s_tm.pos } in - (* TODO: This is silly, why don't we just keep aq in the Pat_cons? *) - let is_imp = function | Some (Implicit _) -> true - | _ -> false - in - let a_ps, a_is = List.splitAt nparam args in - failwhen (List.length a_ps <> List.length d_ps) "params not match?" ;! - let d_ps_a_ps = List.zip d_ps a_ps in - let subst = List.map (fun (({binder_bv=bv}), (t, _)) -> NT (bv, t)) d_ps_a_ps in - let bs = SS.subst_binders subst bs in - let subpats_1 = List.map (fun (({binder_bv=bv}), (t, _)) -> - (mk_pat (Pat_dot_term (Some t)), true)) d_ps_a_ps in - let subpats_2 = List.map (fun ({binder_bv=bv;binder_qual=bq}) -> - (mk_pat (Pat_var bv), is_imp bq)) bs in - let subpats = subpats_1 @ subpats_2 in - let pat = mk_pat (Pat_cons (fv, Some a_us, subpats)) in - let env = (goal_env g) in - - - (* Add an argument stating the equality between the scrutinee - * and the pattern, in-scope for this branch. *) - let cod = goal_type g in - let equ = env.universe_of env s_ty in - (* Typecheck the pattern, to fill-in the universes and get an expression out of it *) - let _ , _, _, _, pat_t, _, _guard_pat, _erasable = TcTerm.tc_pat ({ env with admit = true }) s_ty pat in - let eq_b = S.gen_bv "breq" None (U.mk_squash S.U_zero (U.mk_eq2 equ s_ty s_tm pat_t)) in - let cod = U.arrow [S.mk_binder eq_b] (mk_Total cod) in - - let nty = U.arrow bs (mk_Total cod) in - let! uvt, uv = new_uvar "destruct branch" env nty None (goal_typedness_deps g) (rangeof g) in - let g' = mk_goal env uv g.opts false g.label in - let brt = U.mk_app_binders uvt bs in - (* Provide the scrutinee equality, which is trivially provable *) - let brt = U.mk_app brt [S.as_arg U.exp_unit] in - let br = SS.close_branch (pat, None, brt) in - return (g', br, (fv, Z.of_int_fs (List.length bs))) - | _ -> - fail "impossible: not a ctor") - c_lids - in - let goals, brs, infos = List.unzip3 goal_brs in - let w = mk (Tm_match {scrutinee=s_tm;ret_opt=None;brs;rc_opt=None}) s_tm.pos in - solve' g w ;! - //we constructed a well-typed term to solve g; no need to recheck it - mark_goal_implicit_already_checked g; - add_goals goals ;! - return infos - - | _ -> fail "not an inductive type" - ) - -let gather_explicit_guards_for_resolved_goals () - : tac unit - = return () - -// TODO: move to library? -let rec last (l:list 'a) : 'a = - match l with - | [] -> failwith "last: empty list" - | [x] -> x - | _::xs -> last xs - -let rec init (l:list 'a) : list 'a = - match l with - | [] -> failwith "init: empty list" - | [x] -> [] - | x::xs -> x :: init xs - -let lget (ty:term) (k:string) : tac term = wrap_err "lget" <| ( - let! ps = get in - match BU.psmap_try_find ps.local_state k with - | None -> fail "not found" - | Some t -> unquote ty t - ) - -let lset (_ty:term) (k:string) (t:term) : tac unit = wrap_err "lset" <| ( - let! ps = get in - let ps = { ps with local_state = BU.psmap_add ps.local_state k t } in - set ps - ) - -let set_urgency (u:Z.t) : tac unit = - let! ps = get in - let ps = { ps with urgency = Z.to_int_fs u } in - set ps - -let set_dump_on_failure (b:bool) : tac unit = - let! ps = get in - let ps = { ps with dump_on_failure = b } in - set ps - -let t_commute_applied_match () : tac unit = wrap_err "t_commute_applied_match" <| ( - let! g = cur_goal in - match destruct_eq (goal_env g) (goal_type g) with - | Some (l, r) -> begin - let lh, las = U.head_and_args_full l in - match (SS.compress (U.unascribe lh)).n with - | Tm_match {scrutinee=e;ret_opt=asc_opt;brs;rc_opt=lopt} -> - let brs' = List.map (fun (p, w, e) -> p, w, U.mk_app e las) brs in - // - // If residual comp is set, apply arguments to it - // - let lopt' = lopt |> BU.map_option (fun rc -> {rc with residual_typ= - rc.residual_typ |> BU.map_option (fun t -> - let bs, c = N.get_n_binders (goal_env g) (List.length las) t in - let bs, c = SS.open_comp bs c in - let ss = List.map2 (fun b a -> NT (b.binder_bv, fst a)) bs las in - let c = SS.subst_comp ss c in - U.comp_result c)}) in - let l' = mk (Tm_match {scrutinee=e;ret_opt=asc_opt;brs=brs';rc_opt=lopt'}) l.pos in - let must_tot = true in - begin match! do_unify_maybe_guards false must_tot (goal_env g) l' r with - | None -> fail "discharging the equality failed" - | Some guard -> - if Env.is_trivial_guard_formula guard - then ( - //we just checked that its guard is trivial; so no need to check again - mark_uvar_as_already_checked g.goal_ctx_uvar; - solve g U.exp_unit - ) - else failwith "internal error: _t_refl: guard is not trivial" - end - | _ -> - fail "lhs is not a match" - end - | None -> - fail "not an equality" - ) - -let string_to_term (e: Env.env) (s: string): tac term - = let open FStar.Parser.ParseIt in - let frag_of_text s = { frag_fname= "" - ; frag_line = 1 ; frag_col = 0 - ; frag_text = s } in - match parse None (Fragment (frag_of_text s)) with - | Term t -> - let dsenv = FStar.Syntax.DsEnv.set_current_module e.dsenv (current_module e) in - begin try return (FStar.ToSyntax.ToSyntax.desugar_term dsenv t) with - | FStar.Errors.Error (_, e, _, _) -> - fail ("string_to_term: " ^ Errors.rendermsg e) - | _ -> fail ("string_to_term: Unknown error") - end - | ASTFragment _ -> fail ("string_to_term: expected a Term as a result, got an ASTFragment") - | ParseError (_, err, _) -> fail ("string_to_term: got error " ^ Errors.rendermsg err) // FIXME - -let push_bv_dsenv (e: Env.env) (i: string): tac (env & RD.binding) - = let ident = Ident.mk_ident (i, FStar.Compiler.Range.dummyRange) in - let dsenv, bv = FStar.Syntax.DsEnv.push_bv e.dsenv ident in - return ({ e with dsenv }, bv_to_binding bv) - -let term_to_string (t:term) : tac string - = let! g = top_env () in - let s = Print.term_to_string' g.dsenv t in - return s - -let comp_to_string (c:comp) : tac string - = let! g = top_env () in - let s = Print.comp_to_string' g.dsenv c in - return s - -let term_to_doc (t:term) : tac Pprint.document - = let! g = top_env () in - let s = Print.term_to_doc' g.dsenv t in - return s - -let comp_to_doc (c:comp) : tac Pprint.document - = let! g = top_env () in - let s = Print.comp_to_doc' g.dsenv c in - return s - -let range_to_string (r:FStar.Compiler.Range.range) : tac string - = return (show r) - -let term_eq_old (t1:term) (t2:term) : tac bool - = return ();! - return (Syntax.Util.term_eq t1 t2) - -let with_compat_pre_core (n:Z.t) (f:tac 'a) : tac 'a = - mk_tac (fun ps -> - Options.with_saved_options (fun () -> - let _res = FStar.Options.set_options ("--compat_pre_core 0") in - run f ps)) - -let get_vconfig () : tac vconfig = - let! g = cur_goal in - (* Restore goal's optionstate (a copy is needed) and read vconfig. - * This is an artifact of the options API being stateful in many places, - * morally this is just (get_vconfig g.opts) *) - let vcfg = Options.with_saved_options (fun () -> - FStar.Options.set g.opts; - Options.get_vconfig ()) - in - return vcfg - -let set_vconfig (vcfg : vconfig) : tac unit = - (* Same comment as for get_vconfig applies, this is really just - * let g' = { g with opts = set_vconfig vcfg g.opts } *) - let! g = cur_goal in - let opts' = Options.with_saved_options (fun () -> - FStar.Options.set g.opts; - Options.set_vconfig vcfg; - Options.peek ()) - in - let g' = { g with opts = opts' } in - replace_cur g' - -let t_smt_sync (vcfg : vconfig) : tac unit = wrap_err "t_smt_sync" <| ( - let! goal = cur_goal in - match get_phi goal with - | None -> fail "Goal is not irrelevant" - | Some phi -> - let e = goal_env goal in - let ans : bool = - (* Set goal's optionstate before asking solver, to respect - * its vconfig among other things. *) - Options.with_saved_options (fun () -> - (* NOTE: we ignore the goal's options, the rationale is that - * any verification-relevant option is inside the vconfig, so we - * should not need read the optionstate. Of course this vconfig - * will probably come in large part from a get_vconfig, which does - * read the goal's options. *) - Options.set_vconfig vcfg; - e.solver.solve_sync None e phi - ) - in - if ans - then ( - mark_uvar_as_already_checked goal.goal_ctx_uvar; - solve goal U.exp_unit - ) else fail "SMT did not solve this goal" -) - -let free_uvars (tm : term) : tac (list Z.t) - = return ();! - let uvs = Free.uvars_uncached tm - |> elems // GGG bad, order dependent, but userspace does not have sets - |> List.map (fun u -> Z.of_int_fs (UF.uvar_id u.ctx_uvar_head)) - in - return uvs - -let all_ext_options () : tac (list (string & string)) - = return () ;! - return (Options.Ext.all ()) - -let ext_getv (k:string) : tac string - = return () ;! - return (Options.Ext.get k) - -let ext_getns (ns:string) : tac (list (string & string)) - = return () ;! - return (Options.Ext.getns ns) - -let alloc (x:'a) : tac (tref 'a) = - return ();! - return (BU.mk_ref x) - -let read (r:tref 'a) : tac 'a = - return ();! - return (!r) - -let write (r:tref 'a) (x:'a) : tac unit = - return ();! - r := x; - return () - -(***** Builtins used in the meta DSL framework *****) - -let dbg_refl (g:env) (msg:unit -> string) = - if !dbg_ReflTc - then BU.print_string (msg ()) - -let issues = list Errors.issue - -let refl_typing_guard (e:env) (g:typ) : tac unit = - let reason = "refl_typing_guard" in - proc_guard_formula "refl_typing_guard" e g None (Env.get_range e) - -let uncurry f (x, y) = f x y - -let __refl_typing_builtin_wrapper (f:unit -> 'a & list (env & typ)) : tac (option 'a & issues) = - (* We ALWAYS rollback the state. This wrapper is meant to ensure that - the UF graph is not affected by whatever we are wrapping. This means - any returned term must be deeply-compressed. The guards are compressed by - this wrapper, and handled according to the guard policy, so no action is needed - in the wrapped function `f`. *) - let tx = UF.new_transaction () in - let errs, r = - try Errors.catch_errors_and_ignore_rest f - with exn -> //catch everything - let issue = FStar.Errors.({ - issue_msg = Errors.mkmsg (BU.print_exn exn); - issue_level = EError; - issue_range = None; - issue_number = (Some 17); - issue_ctx = get_ctx () - }) in - [issue], None - in - - (* Deep compress the guards since we are about to roll back the UF. - The caller will discharge them if needed. *) - let gs = - if Some? r then - let allow_uvars = false in - let allow_names = true in (* terms are potentially open, names are OK *) - List.map (fun (e,g) -> e, SC.deep_compress allow_uvars allow_names g) (snd (Some?.v r)) - else - [] - in - - (* If r is Some, extract the result, that's what we return *) - let r = BU.map_opt r fst in - - (* Compress the id info table. *) - let! ps = get in - Env.promote_id_info ps.main_context (FStar.TypeChecker.Tc.compress_and_norm ps.main_context); - - UF.rollback tx; - - (* Make sure to return None if any error was logged. *) - if List.length errs > 0 - then return (None, errs) - else ( - iter_tac (uncurry refl_typing_guard) gs;! - return (r, errs) - ) - -(* This runs the tactic `f` in the current proofstate, and returns an -Inl if any error was raised or logged by the execution. Returns Inr with -the result otherwise. It only advances the proofstate on a success. *) -let catch_all (f : tac 'a) : tac (either issues 'a) = - mk_tac (fun ps -> - match Errors.catch_errors_and_ignore_rest (fun () -> Tactics.Monad.run f ps) with - | [], Some (Success (v, ps')) -> Success (Inr v, ps') - | errs, _ -> Success (Inl errs, ps)) - -(* A *second* wrapper for typing builtin primitives. The wrapper -above (__refl_typing_builtin_wrapper) is meant to catch errors in the -execution of the primitive we are calling. This second is meant to catch -errors in the tactic execution, e.g. those related to discharging the -guards if a synchronous mode (SMTSync/Force) was used. - -This also adds the label to the messages. *) -let refl_typing_builtin_wrapper (label:string) (f:unit -> 'a & list (env & typ)) : tac (option 'a & issues) = - let open FStar.Errors in - let! o, errs = - match! catch_all (__refl_typing_builtin_wrapper f) with - | Inl errs -> return (None, errs) - | Inr r -> return r - in - let errs = errs |> List.map (fun is -> { is with issue_msg = is.issue_msg @ [text ("Raised within Tactics." ^ label)] }) in - return (o, errs) - -let no_uvars_in_term (t:term) : bool = - t |> Free.uvars |> is_empty && - t |> Free.univs |> is_empty - -let no_univ_uvars_in_term (t:term) : bool = - t |> Free.univs |> is_empty - -let no_uvars_in_g (g:env) : bool = - g.gamma |> BU.for_all (function - | Binding_var bv -> no_uvars_in_term bv.sort - | _ -> true) - -type relation = - | Subtyping - | Equality - -let unexpected_uvars_issue r = - let open FStar.Errors in - let i = { - issue_level = EError; - issue_range = Some r; - issue_msg = Errors.mkmsg "Cannot check relation with uvars"; - issue_number = Some (errno Error_UnexpectedUnresolvedUvar); - issue_ctx = [] - } in - i - -let refl_is_non_informative (g:env) (t:typ) : tac (option unit & issues) = - if no_uvars_in_g g && - no_uvars_in_term t - then refl_typing_builtin_wrapper "refl_is_non_informative" (fun _ -> - let g = Env.set_range g t.pos in - dbg_refl g (fun _ -> - BU.format1 "refl_is_non_informative: %s\n" - (show t)); - let b = Core.is_non_informative g t in - dbg_refl g (fun _ -> BU.format1 "refl_is_non_informative: returned %s" - (show b)); - if b then ((), []) - else Errors.raise_error g Errors.Fatal_UnexpectedTerm - "is_non_informative returned false" - ) else ( - return (None, [unexpected_uvars_issue (Env.get_range g)]) - ) - -let refl_check_relation (rel:relation) (smt_ok:bool) (unfolding_ok:bool) (g:env) (t0 t1:typ) - : tac (option unit & issues) = - - if no_uvars_in_g g && - no_uvars_in_term t0 && - no_uvars_in_term t1 - then refl_typing_builtin_wrapper "refl_check_relation" (fun _ -> - let g = Env.set_range g t0.pos in - dbg_refl g (fun _ -> - BU.format3 "refl_check_relation: %s %s %s\n" - (show t0) - (if rel = Subtyping then "<:?" else "=?=") - (show t1)); - let f = - if rel = Subtyping - then Core.check_term_subtyping - else Core.check_term_equality in - match f smt_ok unfolding_ok g t0 t1 with - | Inl None -> - dbg_refl g (fun _ -> "refl_check_relation: succeeded (no guard)\n"); - ((), []) - | Inl (Some guard_f) -> - dbg_refl g (fun _ -> "refl_check_relation: succeeded\n"); - ((), [(g, guard_f)]) - | Inr err -> - dbg_refl g (fun _ -> BU.format1 "refl_check_relation failed: %s\n" (Core.print_error err)); - Errors.raise_error g Errors.Fatal_IllTyped - ("check_relation failed: " ^ (Core.print_error err))) - else ( - return (None, [unexpected_uvars_issue (Env.get_range g)]) - ) - -let refl_check_subtyping (g:env) (t0 t1:typ) : tac (option unit & issues) = - refl_check_relation Subtyping true true g t0 t1 - -let t_refl_check_equiv = refl_check_relation Equality - -let to_must_tot (eff:Core.tot_or_ghost) : bool = - match eff with - | Core.E_Total -> true - | Core.E_Ghost -> false - -let tot_or_ghost_to_string = function - | Core.E_Total -> "E_Total" - | Core.E_Ghost -> "E_Ghost" - -let refl_norm_type (g:env) (t:typ) : typ = - N.normalize [Env.Beta; Env.Exclude Zeta] g t - -let refl_core_compute_term_type (g:env) (e:term) : tac (option (Core.tot_or_ghost & typ) & issues) = - if no_uvars_in_g g && - no_uvars_in_term e - then refl_typing_builtin_wrapper "refl_core_compute_term_type" (fun _ -> - let g = Env.set_range g e.pos in - dbg_refl g (fun _ -> - BU.format1 "refl_core_compute_term_type: %s\n" (show e)); - let guards : ref (list (env & typ)) = BU.mk_ref [] in - let gh = fun g guard -> - (* FIXME: this is kinda ugly, we store all the guards - in a local ref and fetch them at the end. *) - guards := (g, guard) :: !guards; - true - in - match Core.compute_term_type_handle_guards g e gh with - | Inl (eff, t) -> - let t = refl_norm_type g t in - dbg_refl g (fun _ -> - BU.format2 "refl_core_compute_term_type for %s computed type %s\n" - (show e) - (show t)); - ((eff, t), !guards) - | Inr err -> - dbg_refl g (fun _ -> BU.format1 "refl_core_compute_term_type: %s\n" (Core.print_error err)); - Errors.raise_error g Errors.Fatal_IllTyped - ("core_compute_term_type failed: " ^ (Core.print_error err))) - else return (None, [unexpected_uvars_issue (Env.get_range g)]) - -let refl_core_check_term (g:env) (e:term) (t:typ) (eff:Core.tot_or_ghost) - : tac (option unit & issues) = - - if no_uvars_in_g g && - no_uvars_in_term e && - no_uvars_in_term t - then refl_typing_builtin_wrapper "refl_core_check_term" (fun _ -> - let g = Env.set_range g e.pos in - dbg_refl g (fun _ -> - BU.format3 "refl_core_check_term: term: %s, type: %s, eff: %s\n" - (show e) (show t) - (tot_or_ghost_to_string eff)); - let must_tot = to_must_tot eff in - match Core.check_term g e t must_tot with - | Inl None -> - dbg_refl g (fun _ -> "refl_core_check_term: succeeded with no guard\n"); - ((), []) - | Inl (Some guard) -> - dbg_refl g (fun _ -> "refl_core_check_term: succeeded with guard\n"); - ((), [(g, guard)]) - | Inr err -> - dbg_refl g (fun _ -> BU.format1 "refl_core_check_term failed: %s\n" (Core.print_error err)); - Errors.raise_error g Errors.Fatal_IllTyped - ("refl_core_check_term failed: " ^ (Core.print_error err))) - else return (None, [unexpected_uvars_issue (Env.get_range g)]) - -let refl_core_check_term_at_type (g:env) (e:term) (t:typ) - : tac (option Core.tot_or_ghost & issues) = - - if no_uvars_in_g g && - no_uvars_in_term e && - no_uvars_in_term t - then refl_typing_builtin_wrapper "refl_core_check_term_at_type" (fun _ -> - let g = Env.set_range g e.pos in - dbg_refl g (fun _ -> - BU.format2 "refl_core_check_term_at_type: term: %s, type: %s\n" - (show e) (show t)); - match Core.check_term_at_type g e t with - | Inl (eff, None) -> - dbg_refl g (fun _ -> - BU.format1 "refl_core_check_term_at_type: succeeded with eff %s and no guard\n" - (tot_or_ghost_to_string eff)); - (eff, []) - | Inl (eff, Some guard) -> - dbg_refl g (fun _ -> - BU.format1 "refl_core_check_term_at_type: succeeded with eff %s and guard\n" - (tot_or_ghost_to_string eff)); - (eff, [(g, guard)]) - | Inr err -> - dbg_refl g (fun _ -> BU.format1 "refl_core_check_term_at_type failed: %s\n" (Core.print_error err)); - Errors.raise_error g Errors.Fatal_IllTyped - ("refl_core_check_term failed: " ^ (Core.print_error err))) - else return (None, [unexpected_uvars_issue (Env.get_range g)]) - -let refl_tc_term (g:env) (e:term) : tac (option (term & (Core.tot_or_ghost & typ)) & issues) = - if no_uvars_in_g g && - no_uvars_in_term e - then refl_typing_builtin_wrapper "refl_tc_term" (fun _ -> - let g = Env.set_range g e.pos in - dbg_refl g (fun _ -> - BU.format2 "refl_tc_term@%s: %s\n" (show e.pos) (show e)); - dbg_refl g (fun _ -> "refl_tc_term: starting tc {\n"); - // - // we don't instantiate implicits at the end of e - // it is unlikely that we will be able to resolve them, - // and refl typechecking API will fail if there are unresolved uvars - // - // note that this will still try to resolve implicits within e - // the typechecker does not check for this env flag for such implicits - // - let g = {g with instantiate_imp=false} in - // - // lax check to elaborate - // - let e = - let g = {g with phase1 = true; admit = true} in - // - // AR: we are lax checking to infer implicits, - // ghost is ok - // - let must_tot = false in - let e, _, guard = g.typeof_tot_or_gtot_term g e must_tot in - Rel.force_trivial_guard g guard; - e in - try - begin - if not (no_uvars_in_term e) - then ( - Errors.raise_error e Errors.Error_UnexpectedUnresolvedUvar - (BU.format1 "Elaborated term has unresolved implicits: %s" (show e)) - ) - else ( - let allow_uvars = false in - let allow_names = true in (* terms are potentially open, names are OK *) - let e = SC.deep_compress allow_uvars allow_names e in - // TODO: may be should we check here that e has no unresolved implicits? - dbg_refl g (fun _ -> - BU.format1 "} finished tc with e = %s\n" - (show e)); - let guards : ref (list (env & typ)) = BU.mk_ref [] in - let gh = fun g guard -> - (* collect guards and return them *) - dbg_refl g (fun _ -> - BU.format3 "Got guard in Env@%s |- %s@%s\n" - (Env.get_range g |> show) - (show guard) - (show guard.pos) - ); - guards := (g, guard) :: !guards; - true - in - match Core.compute_term_type_handle_guards g e gh with - | Inl (eff, t) -> - let t = refl_norm_type g t in - dbg_refl g (fun _ -> - BU.format3 "refl_tc_term@%s for %s computed type %s\n" - (show e.pos) - (show e) - (show t)); - ((e, (eff, t)), !guards) - | Inr err -> - dbg_refl g (fun _ -> BU.format1 "refl_tc_term failed: %s\n" (Core.print_error err)); - Errors.raise_error e Errors.Fatal_IllTyped ("tc_term callback failed: " ^ Core.print_error err) - ) - end - with - | Errors.Error (Errors.Error_UnexpectedUnresolvedUvar, _, _, _) -> - Errors.raise_error e Errors.Fatal_IllTyped "UVars remaing in term after tc_term callback") - else - return (None, [unexpected_uvars_issue (Env.get_range g)]) - -let refl_universe_of (g:env) (e:term) : tac (option universe & issues) = - let check_univ_var_resolved g u = - match SS.compress_univ u with - | S.U_unif _ -> Errors.raise_error g Errors.Fatal_IllTyped "Unresolved variable in universe_of callback" - | u -> u in - - if no_uvars_in_g g && - no_uvars_in_term e - then refl_typing_builtin_wrapper "refl_universe_of" (fun _ -> - let g = Env.set_range g e.pos in - let t, u = U.type_u () in - let must_tot = false in - match Core.check_term g e t must_tot with - | Inl None -> (check_univ_var_resolved g u, []) - | Inl (Some guard) -> - (check_univ_var_resolved g u, [(g, guard)]) - | Inr err -> - dbg_refl g (fun _ -> BU.format1 "refl_universe_of failed: %s\n" (Core.print_error err)); - Errors.raise_error g Errors.Fatal_IllTyped ("universe_of failed: " ^ Core.print_error err)) - else return (None, [unexpected_uvars_issue (Env.get_range g)]) - -let refl_check_prop_validity (g:env) (e:term) : tac (option unit & issues) = - if no_uvars_in_g g && - no_uvars_in_term e - then refl_typing_builtin_wrapper "refl_check_prop_validity" (fun _ -> - let g = Env.set_range g e.pos in - dbg_refl g (fun _ -> - BU.format1 "refl_check_prop_validity: %s\n" (show e)); - let must_tot = false in - let _ = - match Core.check_term g e (U.fvar_const PC.prop_lid) must_tot with - | Inl None -> () - | Inl (Some guard) -> - Rel.force_trivial_guard g - {Env.trivial_guard with guard_f=NonTrivial guard} - | Inr err -> - let msg = BU.format1 "refl_check_prop_validity failed (not a prop): %s\n" - (Core.print_error err) in - dbg_refl g (fun _ -> msg); - Errors.raise_error g Errors.Fatal_IllTyped msg - in - ((), [(g, e)]) - ) - else return (None, [unexpected_uvars_issue (Env.get_range g)]) - -let refl_check_match_complete (g:env) (sc:term) (scty:typ) (pats : list RD.pattern) -: tac (option (list RD.pattern & list (list RD.binding))) -= - return () ;! - (* We just craft a match with the sc and patterns, using `1` in every - branch, and check it against type int. *) - let one = U.exp_int "1" in - let brs = List.map (fun p -> let p = pack_pat p in (p, None, one)) pats in - let mm = mk (Tm_match {scrutinee=sc; ret_opt=None; brs=brs; rc_opt=None}) sc.pos in - let env = g in - let env = Env.set_expected_typ env S.t_int in - let! mm, _, g = __tc env mm in - - let errs, b = Errors.catch_errors_and_ignore_rest (fun () -> Env.is_trivial <| Rel.discharge_guard env g) in - match errs, b with - | [], Some true -> - let get_pats t = - match (U.unmeta t).n with - | Tm_match {brs} -> List.map (fun (p,_,_) -> p) brs - | _ -> failwith "refl_check_match_complete: not a match?" - in - let pats = get_pats mm in - let rec bnds_for_pat (p:pat) : list RD.binding = - match p.v with - | Pat_constant _ -> [] - | Pat_cons (fv, _, pats) -> List.concatMap (fun (p, _) -> bnds_for_pat p) pats - | Pat_var bv -> [bv_to_binding bv] - | Pat_dot_term _ -> [] - in - return (Some (List.map inspect_pat pats, List.map bnds_for_pat pats)) - | _ -> return None - -let refl_instantiate_implicits (g:env) (e:term) (expected_typ : option term) - : tac (option (list (bv & typ) & term & typ) & issues) = - if no_uvars_in_g g && - no_uvars_in_term e - then refl_typing_builtin_wrapper "refl_instantiate_implicits" (fun _ -> - let g = Env.set_range g e.pos in - dbg_refl g (fun _ -> - BU.format1 "refl_instantiate_implicits: %s\n" (show e)); - dbg_refl g (fun _ -> "refl_instantiate_implicits: starting tc {\n"); - // AR: ghost is ok for instantiating implicits - let must_tot = false in - let g = - match expected_typ with - | None -> Env.clear_expected_typ g |> fst - | Some typ -> Env.set_expected_typ g typ - in - let g = {g with instantiate_imp=false; phase1=true; admit=true} in - let e, t, guard = g.typeof_tot_or_gtot_term g e must_tot in - // - // We don't worry about the logical payload, - // since this API does not return proof of typing - // - let guard = guard |> Rel.solve_deferred_constraints g |> Rel.resolve_implicits g in - let bvs_and_ts : list (bv & typ) = - match Listlike.to_list guard.implicits with - | [] -> [] - | imps -> - // - // We could not solve all implicits - // - // Create fresh names for the unsolved uvars, and - // set the solution for the uvars to these names - // This way when we compress the terms later, - // the uvars will be substituted with the names - // - let l : list (uvar & typ & bv) = - imps - |> List.map (fun {imp_uvar} -> - (imp_uvar.ctx_uvar_head, - U.ctx_uvar_typ imp_uvar, - S.new_bv None (S.mk Tm_unknown Range.dummyRange))) - in - l |> List.iter (fun (uv, _, bv) -> U.set_uvar uv (S.bv_to_name bv)); - List.map (fun (_, t, bv) -> bv, t) l - in - - dbg_refl g (fun _ -> BU.format2 "refl_instantiate_implicits: inferred %s : %s" (show e) (show t)); - - if not (no_univ_uvars_in_term e) - then Errors.raise_error e Errors.Error_UnexpectedUnresolvedUvar - (BU.format1 "Elaborated term has unresolved univ uvars: %s" (show e)); - if not (no_univ_uvars_in_term t) - then Errors.raise_error e Errors.Error_UnexpectedUnresolvedUvar - (BU.format1 "Inferred type has unresolved univ uvars: %s" (show t)); - bvs_and_ts |> List.iter (fun (x, t) -> - if not (no_univ_uvars_in_term t) - then Errors.raise_error e Errors.Error_UnexpectedUnresolvedUvar - (BU.format2 "Inferred type has unresolved univ uvars: %s:%s" (show x) (show t))); - let g = Env.push_bvs g (List.map (fun (bv, t) -> {bv with sort=t}) bvs_and_ts) in - let allow_uvars = false in - let allow_names = true in (* terms are potentially open, names are OK *) - let e = SC.deep_compress allow_uvars allow_names e in - let t = t |> refl_norm_type g |> SC.deep_compress allow_uvars allow_names in - let bvs_and_ts = - bvs_and_ts |> List.map (fun (bv, t) -> bv, SC.deep_compress allow_uvars allow_names t) in - - dbg_refl g (fun _ -> - BU.format2 "} finished tc with e = %s and t = %s\n" - (show e) - (show t)); - ((bvs_and_ts, e, t), []) - ) - else return (None, [unexpected_uvars_issue (Env.get_range g)]) - -let refl_try_unify (g:env) (uvs:list (bv & typ)) (t0 t1:term) - : tac (option (list (bv & term)) & issues) = - - if no_uvars_in_g g && - no_uvars_in_term t0 && - no_uvars_in_term t1 && - List.for_all no_uvars_in_term (List.map snd uvs) - then refl_typing_builtin_wrapper "refl_try_unify" (fun _ -> - dbg_refl g (fun _ -> BU.format3 "refl_try_unify %s and %s, with uvs: %s {\n" - (show t0) - (show t1) - (show uvs)); - let g = Env.set_range g t0.pos in - // - // create uvars for the bvs in uvs, - // and maintain a mapping from uvars to bvs in tbl - // we apply substitutions to uvs accordingly (replacing uvs names with newly created uvars) - // - let guard_uvs, ss, tbl = List.fold_left (fun (guard_uvs, ss, tbl) (bv, t) -> - let t = SS.subst ss t in - let uv_t, (ctx_u, _), guard_uv = - // the API doesn't promise well-typedness of the solutions - let reason = BU.format1 "refl_try_unify for %s" (show bv) in - let should_check_uvar = Allow_untyped "refl_try_unify" in - Env.new_implicit_var_aux reason t0.pos g t should_check_uvar None false - in - let uv_id = Syntax.Unionfind.uvar_unique_id ctx_u.ctx_uvar_head in - Env.conj_guard guard_uvs guard_uv, - (NT (bv, uv_t))::ss, - BU.pimap_add tbl uv_id (ctx_u.ctx_uvar_head, bv) - ) (Env.trivial_guard, [], (BU.pimap_empty ())) uvs in - let t0, t1 = SS.subst ss t0, SS.subst ss t1 in - let g = { g with phase1=true; admit=true } in - let guard_eq = - let smt_ok = true in - Rel.try_teq smt_ok g t0 t1 in - let l = - match guard_eq with - | None -> [] // could not unify - | Some guard -> - let guard = Env.conj_guard guard_uvs guard in - let guard = guard |> Rel.solve_deferred_constraints g |> Rel.resolve_implicits g in - - // - // if there is some unresolved implicit that was not part of uvs, - // e.g., created as part of Rel.try_teq, return [] - // - let b = List.existsb (fun {imp_uvar = {ctx_uvar_head = (uv, _, _)}} -> - BU.pimap_try_find tbl (Unionfind.puf_unique_id uv) = None) (Listlike.to_list guard.implicits) in - if b then [] - else - // - // iterate over the tbl - // return uvs that could be solved fully - // - BU.pimap_fold tbl (fun id (uvar, bv) l -> - match Syntax.Unionfind.find uvar with - | Some t -> - let allow_uvars = true in - let allow_names = true in - let t = SC.deep_compress allow_uvars allow_names t in - if t |> Syntax.Free.uvars_full |> is_empty - then (bv, t)::l - else l - | None -> l - ) [] in - dbg_refl g (fun _ -> BU.format1 "} refl_try_unify, substitution is: %s\n" (show l)); - l, [] - ) - else return (None, [unexpected_uvars_issue (Env.get_range g)]) - - -let refl_maybe_relate_after_unfolding (g:env) (t0 t1:typ) - : tac (option Core.side & issues) = - - if no_uvars_in_g g && - no_uvars_in_term t0 && - no_uvars_in_term t1 - then refl_typing_builtin_wrapper "refl_maybe_relate_after_unfolding" (fun _ -> - let g = Env.set_range g t0.pos in - dbg_refl g (fun _ -> - BU.format2 "refl_maybe_relate_after_unfolding: %s and %s {\n" - (show t0) - (show t1)); - let s = Core.maybe_relate_after_unfolding g t0 t1 in - dbg_refl g (fun _ -> - BU.format1 "} returning side: %s\n" (show s)); - s, []) - else return (None, [unexpected_uvars_issue (Env.get_range g)]) - -let refl_maybe_unfold_head (g:env) (e:term) : tac (option term & issues) = - if no_uvars_in_g g && - no_uvars_in_term e - then refl_typing_builtin_wrapper "refl_maybe_unfold_head" (fun _ -> - let g = Env.set_range g e.pos in - dbg_refl g (fun _ -> - BU.format1 "refl_maybe_unfold_head: %s {\n" (show e)); - let eopt = N.maybe_unfold_head g e in - dbg_refl g (fun _ -> - BU.format1 "} eopt = %s\n" - (match eopt with - | None -> "none" - | Some e -> show e)); - if eopt = None - then Errors.raise_error e Errors.Fatal_UnexpectedTerm - (BU.format1 "Could not unfold head: %s\n" (show e)) - else (eopt |> must, [])) - else return (None, [unexpected_uvars_issue (Env.get_range g)]) - -let push_open_namespace (e:env) (ns:list string) = - let lid = Ident.lid_of_path ns Range.dummyRange in - return { e with dsenv = FStar.Syntax.DsEnv.push_namespace e.dsenv lid Unrestricted } - -let push_module_abbrev (e:env) (n:string) (m:list string) = - let mlid = Ident.lid_of_path m Range.dummyRange in - let ident = Ident.id_of_text n in - return { e with dsenv = FStar.Syntax.DsEnv.push_module_abbrev e.dsenv ident mlid } - -let resolve_name (e:env) (n:list string) = - let l = Ident.lid_of_path n Range.dummyRange in - return (FStar.Syntax.DsEnv.resolve_name e.dsenv l) - -let log_issues (is : list Errors.issue) : tac unit = - let open FStar.Errors in - let! ps = get in - (* Prepend an error component, unless the tactic handles its own errors. *) - let is = - if ps.dump_on_failure - then - is |> - List.map (fun i -> { i with issue_msg = (Errors.text "Tactic logged issue:")::i.issue_msg }) - else - is - in - add_issues is; - return () - -(**** Creating proper environments and proofstates ****) - -let tac_env (env:Env.env) : Env.env = - let env, _ = Env.clear_expected_typ env in - let env = { env with Env.instantiate_imp = false } in - let env = { env with failhard = true } in - let env = { env with enable_defer_to_tac = false } in - env - -let proofstate_of_goals rng env goals imps = - let env = tac_env env in - let ps = { - main_context = env; - all_implicits = imps; - goals = goals; - smt_goals = []; - depth = 0; - __dump = do_dump_proofstate; - psc = PO.null_psc; - entry_range = rng; - guard_policy = SMT; - freshness = 0; - tac_verb_dbg = !dbg_TacVerbose; - local_state = BU.psmap_empty (); - urgency = 1; - dump_on_failure = true; - } - in - ps - -let proofstate_of_goal_ty rng env typ = - let env = { env with range = rng } in - let env = tac_env env in - let g, g_u = goal_of_goal_ty env typ in - let ps = proofstate_of_goals rng env [g] (Listlike.to_list g_u.implicits) in - (ps, goal_witness g) - -let proofstate_of_all_implicits rng env imps = - let env = tac_env env in - let goals = List.map (goal_of_implicit env) imps in - let w = goal_witness (List.hd goals) in - let ps = { - main_context = env; - all_implicits = imps; - goals = goals; - smt_goals = []; - depth = 0; - __dump = do_dump_proofstate; - psc = PO.null_psc; - entry_range = rng; - guard_policy = SMT; - freshness = 0; - tac_verb_dbg = !dbg_TacVerbose; - local_state = BU.psmap_empty (); - urgency = 1; - dump_on_failure = true; - } - in - (ps, w) - -let getprop (e:Env.env) (t:term) : option term = - let tn = N.normalize [Env.Weak; Env.HNF; Env.UnfoldUntil delta_constant] e t in - U.un_squash tn - -let run_unembedded_tactic_on_ps_and_solve_remaining - (t_range g_range : Range.range) - (background : bool) - (t : 'a) - (f : 'a -> tac 'b) - (ps : proofstate) - : 'b -= - let remaining_goals, r = FStar.Tactics.Interpreter.run_unembedded_tactic_on_ps t_range g_range background t f ps in - // Check that all goals left are irrelevant and provable - remaining_goals |> List.iter (fun g -> - match getprop (goal_env g) (goal_type g) with - | Some vc -> - let guard = guard_of_guard_formula (NonTrivial vc) in - Rel.force_trivial_guard (goal_env g) guard - | None -> - Err.raise_error g_range Err.Fatal_OpenGoalsInSynthesis "tactic left a computationally-relevant goal unsolved"); - r - -let call_subtac (g:env) (f : tac unit) (_u:universe) (goal_ty : typ) : tac (option term & issues) = - return ();! // thunk - let rng = Env.get_range g in - let ps, w = proofstate_of_goal_ty rng g goal_ty in - let ps = { ps with dump_on_failure = false } in // subtacs can fail gracefully, do not dump the failed proofstate. - match Errors.catch_errors_and_ignore_rest (fun () -> - run_unembedded_tactic_on_ps_and_solve_remaining rng rng false () (fun () -> f) ps) - with - | [], Some () -> - return (Some w, []) - | issues, _ -> - return (None, issues) - -let run_tactic_on_ps_and_solve_remaining - (#a #b : Type) - (t_range g_range : Range.range) - (background : bool) - (t : a) - (f_tm : term) - (ps : proofstate) - : unit -= - let remaining_goals, r = FStar.Tactics.Interpreter.run_tactic_on_ps #unit #unit t_range g_range background TC.solve () TC.solve f_tm false ps in - // Check that all goals left are irrelevant and provable - remaining_goals |> List.iter (fun g -> - match getprop (goal_env g) (goal_type g) with - | Some vc -> - let guard = guard_of_guard_formula (NonTrivial vc) in - Rel.force_trivial_guard (goal_env g) guard - | None -> - Err.raise_error g_range Err.Fatal_OpenGoalsInSynthesis "tactic left a computationally-relevant goal unsolved"); - r - -let call_subtac_tm (g:env) (f_tm : term) (_u:universe) (goal_ty : typ) : tac (option term & issues) = - return ();! // thunk - let rng = Env.get_range g in - let ps, w = proofstate_of_goal_ty rng g goal_ty in - let ps = { ps with dump_on_failure = false } in // subtacs can fail gracefully, do not dump the failed proofstate. - match Errors.catch_errors_and_ignore_rest (fun () -> - run_tactic_on_ps_and_solve_remaining #unit #unit rng rng false () f_tm ps) - with - | [], Some () -> - return (Some w, []) - | issues, _ -> - return (None, issues) diff --git a/src/tactics/FStar.Tactics.V2.Basic.fsti b/src/tactics/FStar.Tactics.V2.Basic.fsti deleted file mode 100644 index 0b38ca5f242..00000000000 --- a/src/tactics/FStar.Tactics.V2.Basic.fsti +++ /dev/null @@ -1,153 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Tactics.V2.Basic - -(* This module implements the primitives in - * ulib/FStar.Tactics.Builtins. It would be named - * the same, but there needs to be a thin adapter - * layer since the tac monad representation differs - * between compiler and userspace (and a few other - * annoyances too). *) - -open FStar.Syntax.Syntax -open FStar.TypeChecker.Env -open FStar.Reflection.V2.Data -open FStar.Tactics.Types -open FStar.Tactics.Monad - -module BU = FStar.Compiler.Util -module O = FStar.Options -module Range = FStar.Compiler.Range -module Z = FStar.BigInt -module TcComm = FStar.TypeChecker.Common -module Core = FStar.TypeChecker.Core -module RD = FStar.Reflection.V2.Data - -val proofstate_of_goals : Range.range -> env -> list goal -> list implicit -> proofstate -(* Returns proofstate and uvar for main witness *) -val proofstate_of_goal_ty : Range.range -> env -> typ -> proofstate & term - -val proofstate_of_all_implicits: Range.range -> env -> implicits -> proofstate & term - -(* Metaprogramming primitives (not all of them). - * Documented in `ulib/FStar.Tactics.Builtins.fst` *) - -val compress : term -> tac term -val top_env : unit -> tac env -val fresh : unit -> tac Z.t -val refine_intro : unit -> tac unit -val tc : env -> term -> tac typ -val tcc : env -> term -> tac comp -val unshelve : term -> tac unit -val unquote : typ -> term -> tac term -val norm : list Pervasives.norm_step -> tac unit -val norm_term_env : env -> list Pervasives.norm_step -> term -> tac term -val norm_binding_type : list Pervasives.norm_step -> RD.binding -> tac unit -val intro : unit -> tac RD.binding -val intros : (max:Z.t) -> tac (list RD.binding) -val intro_rec : unit -> tac (RD.binding & RD.binding) -val rename_to : RD.binding -> string -> tac RD.binding -val revert : unit -> tac unit -val var_retype : RD.binding -> tac unit -val clear_top : unit -> tac unit -val clear : RD.binding -> tac unit -val rewrite : RD.binding -> tac unit -val grewrite : term -> term -> tac unit -val t_exact : bool -> bool -> term -> tac unit -val t_apply : bool -> bool -> bool -> term -> tac unit -val t_apply_lemma : bool -> bool -> term -> tac unit -val print : string -> tac unit -val debugging : unit -> tac bool -val ide : unit -> tac bool -val dump : string -> tac unit -val dump_all : bool -> string -> tac unit -val dump_uvars_of : goal -> string -> tac unit -val t_trefl : (*allow_guards:*)bool -> tac unit -val dup : unit -> tac unit -val prune : string -> tac unit -val addns : string -> tac unit -val t_destruct : term -> tac (list (fv & Z.t)) -val gather_explicit_guards_for_resolved_goals : unit -> tac unit -val set_options : string -> tac unit -val uvar_env : env -> option typ -> tac term -val ghost_uvar_env : env -> typ -> tac term -val fresh_universe_uvar : unit -> tac term -val unify_env : env -> term -> term -> tac bool -val unify_guard_env : env -> term -> term -> tac bool -val match_env : env -> term -> term -> tac bool -val launch_process : string -> list string -> string -> tac string -val fresh_bv_named : string -> tac bv -val change : typ -> tac unit -val get_guard_policy : unit -> tac guard_policy -val set_guard_policy : guard_policy -> tac unit -val lax_on : unit -> tac bool -val tadmit_t : term -> tac unit -val join : unit -> tac unit -val lget : typ -> string -> tac term -val lset : typ -> string -> term -> tac unit -val curms : unit -> tac Z.t -val set_urgency : Z.t -> tac unit -val set_dump_on_failure : bool -> tac unit -val t_commute_applied_match : unit -> tac unit -val string_to_term : env -> string -> tac term -val push_bv_dsenv : env -> string -> tac (env & RD.binding) -val term_to_string : term -> tac string -val comp_to_string : comp -> tac string -val term_to_doc : term -> tac Pprint.document -val comp_to_doc : comp -> tac Pprint.document -val range_to_string : Range.range -> tac string -val term_eq_old : term -> term -> tac bool -val with_compat_pre_core : Z.t -> tac 'a -> tac 'a - -val get_vconfig : unit -> tac VConfig.vconfig -val set_vconfig : VConfig.vconfig -> tac unit -val t_smt_sync : VConfig.vconfig -> tac unit -val free_uvars : term -> tac (list Z.t) - -val all_ext_options : unit -> tac (list (string & string)) -val ext_getv : string -> tac string -val ext_getns : string -> tac (list (string & string)) - -val alloc : 'a -> tac (tref 'a) -val read : tref 'a -> tac 'a -val write : tref 'a -> 'a -> tac unit - -(***** Callbacks for the meta DSL framework *****) -let issues = list FStar.Errors.issue -val refl_is_non_informative : env -> typ -> tac (option unit & issues) -val refl_check_subtyping : env -> typ -> typ -> tac (option unit & issues) -val t_refl_check_equiv : smt_ok:bool -> unfolding_ok:bool -> env -> typ -> typ -> tac (option unit & issues) -val refl_core_compute_term_type : env -> term -> tac (option (Core.tot_or_ghost & typ) & issues) -val refl_core_check_term : env -> term -> typ -> Core.tot_or_ghost -> tac (option unit & issues) -val refl_core_check_term_at_type : env -> term -> typ -> tac (option Core.tot_or_ghost & issues) -val refl_tc_term : env -> term -> tac (option (term & (Core.tot_or_ghost & typ)) & issues) -val refl_universe_of : env -> term -> tac (option universe & issues) -val refl_check_prop_validity : env -> term -> tac (option unit & issues) -val refl_check_match_complete : env -> term -> term -> list pattern -> tac (option (list pattern & list (list RD.binding))) -val refl_instantiate_implicits : env -> term -> expected_typ:option term -> tac (option (list (bv & typ) & term & typ) & issues) -val refl_try_unify : env -> list (bv & typ) -> term -> term -> tac (option (list (bv & term)) & issues) -val refl_maybe_relate_after_unfolding : env -> term -> term -> tac (option Core.side & issues) -val refl_maybe_unfold_head : env -> term -> tac (option term & issues) -val refl_norm_well_typed_term : env -> list norm_step -> term -> tac term - -val push_open_namespace : env -> list string -> tac env -val push_module_abbrev : env -> string -> list string -> tac env -val resolve_name : env -> list string -> tac (option (either bv fv)) -val log_issues : list Errors.issue -> tac unit - -val call_subtac : env -> tac unit -> universe -> typ -> tac (option term & issues) -val call_subtac_tm : env -> term -> universe -> typ -> tac (option term & issues) diff --git a/src/tactics/FStar.Tactics.V2.Primops.fst b/src/tactics/FStar.Tactics.V2.Primops.fst deleted file mode 100644 index 60a9d7db8ca..00000000000 --- a/src/tactics/FStar.Tactics.V2.Primops.fst +++ /dev/null @@ -1,283 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.Tactics.V2.Primops - -(* Most of the tactic running logic is here. V1.Interpreter calls -into this module for all of that. *) - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Compiler.Range -open FStar.Compiler.Util -open FStar.Syntax.Syntax -open FStar.Syntax.Embeddings -open FStar.TypeChecker.Common -open FStar.TypeChecker.Env -open FStar.Tactics.Result -open FStar.Tactics.Types -open FStar.Tactics.Printing -open FStar.Tactics.Monad -open FStar.Tactics.V2.Basic -open FStar.Tactics.CtrlRewrite -open FStar.Tactics.Native -open FStar.Tactics.Common -open FStar.Tactics.InterpFuns -open FStar.Class.Show -open FStar.Class.Monad - -module BU = FStar.Compiler.Util -module Cfg = FStar.TypeChecker.Cfg -module E = FStar.Tactics.Embedding -module Env = FStar.TypeChecker.Env -module Err = FStar.Errors -module NBE = FStar.TypeChecker.NBE -module NBET = FStar.TypeChecker.NBETerm -module N = FStar.TypeChecker.Normalize -module NRE = FStar.Reflection.V2.NBEEmbeddings -module PC = FStar.Parser.Const -module PO = FStar.TypeChecker.Primops -module Print = FStar.Syntax.Print -module RE = FStar.Reflection.V2.Embeddings -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module TcComm = FStar.TypeChecker.Common -module TcRel = FStar.TypeChecker.Rel -module TcTerm = FStar.TypeChecker.TcTerm -module TI = FStar.Tactics.Interpreter -module U = FStar.Syntax.Util - -let solve (#a:Type) {| ev : a |} : Tot a = ev - -instance _ = RE.e_term (* REMOVE ME *) - -(* Takes a `sealed a`, but that's just a userspace abstraction. *) -let unseal (_typ:_) (x:Sealed.sealed 'a) : tac 'a = return (Sealed.unseal x) -let unseal_step = - (* Unseal is not in builtins. *) - let s = - mk_tac_step_2 1 "unseal" - #e_any #(e_sealed e_any) #e_any - #NBET.e_any #(NBET.e_sealed NBET.e_any) #NBET.e_any - unseal unseal - in - { s with name = PC.unseal_lid } - -let e_ret_t #a (d : embedding a) : embedding (option a & issues) = solve -let nbe_e_ret_t #a (d : NBET.embedding a) : NBET.embedding (option a & issues) = solve - -let ops = [ - (* Total steps *) - mk_tot_step_1_psc 0 "tracepoint" tracepoint_with_psc tracepoint_with_psc; - mk_tot_step_2 0 "set_proofstate_range" set_proofstate_range set_proofstate_range; - mk_tot_step_1 0 "incr_depth" incr_depth incr_depth; - mk_tot_step_1 0 "decr_depth" decr_depth decr_depth; - mk_tot_step_1 0 "goals_of" goals_of goals_of; - mk_tot_step_1 0 "smt_goals_of" smt_goals_of smt_goals_of; - mk_tot_step_1 0 "goal_env" goal_env goal_env; - mk_tot_step_1 0 "goal_type" goal_type goal_type; - mk_tot_step_1 0 "goal_witness" goal_witness goal_witness; - mk_tot_step_1 0 "is_guard" is_guard is_guard; - mk_tot_step_1 0 "get_label" get_label get_label; - mk_tot_step_2 0 "set_label" set_label set_label; - - (* Tactic builtin steps *) - - unseal_step; - - mk_tac_step_1 0 "compress" compress compress; - mk_tac_step_1 0 "set_goals" set_goals set_goals; - mk_tac_step_1 0 "set_smt_goals" set_smt_goals set_smt_goals; - - mk_tac_step_2 1 "catch" - #e_any #(TI.e_tactic_thunk e_any) #(e_either E.e_exn e_any) - #NBET.e_any #(TI.e_tactic_nbe_thunk NBET.e_any) #(NBET.e_either E.e_exn_nbe NBET.e_any) - (fun _ -> catch) - (fun _ -> catch); - - mk_tac_step_2 1 "recover" - #e_any #(TI.e_tactic_thunk e_any) #(e_either E.e_exn e_any) - #NBET.e_any #(TI.e_tactic_nbe_thunk NBET.e_any) #(NBET.e_either E.e_exn_nbe NBET.e_any) - (fun _ -> recover) - (fun _ -> recover); - - mk_tac_step_1 0 "intro" intro intro; - mk_tac_step_1 0 "intros" intros intros; - mk_tac_step_1 0 "intro_rec" intro_rec intro_rec; - mk_tac_step_1 0 "norm" norm norm; - mk_tac_step_3 0 "norm_term_env" norm_term_env norm_term_env; - mk_tac_step_2 0 "norm_binding_type" norm_binding_type norm_binding_type; - mk_tac_step_2 0 "rename_to" rename_to rename_to; - mk_tac_step_1 0 "var_retype" var_retype var_retype; - mk_tac_step_1 0 "revert" revert revert; - mk_tac_step_1 0 "clear_top" clear_top clear_top; - mk_tac_step_1 0 "clear" clear clear; - mk_tac_step_1 0 "rewrite" rewrite rewrite; - mk_tac_step_2 0 "grewrite" grewrite grewrite; - mk_tac_step_1 0 "refine_intro" refine_intro refine_intro; - mk_tac_step_3 0 "t_exact" t_exact t_exact; - mk_tac_step_4 0 "t_apply" t_apply t_apply; - mk_tac_step_3 0 "t_apply_lemma" t_apply_lemma t_apply_lemma; - mk_tac_step_1 0 "set_options" set_options set_options; - mk_tac_step_2 0 "tcc" tcc tcc; - mk_tac_step_2 0 "tc" tc tc; - mk_tac_step_1 0 "unshelve" unshelve unshelve; - - mk_tac_step_2 1 "unquote" - #e_any #RE.e_term #e_any - #NBET.e_any #NRE.e_term #NBET.e_any - unquote - (fun _ _ -> failwith "NBE unquote"); - - mk_tac_step_1 0 "prune" prune prune; - mk_tac_step_1 0 "addns" addns addns; - mk_tac_step_1 0 "print" print print; - mk_tac_step_1 0 "debugging" debugging debugging; - mk_tac_step_1 0 "ide" ide ide; - mk_tac_step_1 0 "dump" dump dump; - mk_tac_step_2 0 "dump_all" dump_all dump_all; - mk_tac_step_2 0 "dump_uvars_of" dump_uvars_of dump_uvars_of; - - mk_tac_step_3 0 "ctrl_rewrite" - #E.e_direction #(TI.e_tactic_1 RE.e_term (e_tuple2 e_bool E.e_ctrl_flag)) - #(TI.e_tactic_thunk e_unit) - #e_unit - #E.e_direction_nbe #(TI.e_tactic_nbe_1 NRE.e_term (NBET.e_tuple2 NBET.e_bool E.e_ctrl_flag_nbe)) - #(TI.e_tactic_nbe_thunk NBET.e_unit) - #NBET.e_unit - ctrl_rewrite - ctrl_rewrite; - - mk_tac_step_1 0 "t_trefl" t_trefl t_trefl; - mk_tac_step_1 0 "dup" dup dup; - mk_tac_step_1 0 "tadmit_t" tadmit_t tadmit_t; - mk_tac_step_1 0 "join" join join; - mk_tac_step_1 0 "t_destruct" t_destruct t_destruct; - mk_tac_step_1 0 "top_env" top_env top_env; - mk_tac_step_1 0 "fresh" fresh fresh; - mk_tac_step_1 0 "curms" curms curms; - mk_tac_step_2 0 "uvar_env" uvar_env uvar_env; - mk_tac_step_2 0 "ghost_uvar_env" ghost_uvar_env ghost_uvar_env; - mk_tac_step_1 0 "fresh_universe_uvar" fresh_universe_uvar fresh_universe_uvar; - mk_tac_step_3 0 "unify_env" unify_env unify_env; - mk_tac_step_3 0 "unify_guard_env" unify_guard_env unify_guard_env; - mk_tac_step_3 0 "match_env" match_env match_env; - mk_tac_step_3 0 "launch_process" launch_process launch_process; - mk_tac_step_1 0 "change" change change; - mk_tac_step_1 0 "get_guard_policy" get_guard_policy get_guard_policy; - mk_tac_step_1 0 "set_guard_policy" set_guard_policy set_guard_policy; - mk_tac_step_1 0 "lax_on" lax_on lax_on; - - mk_tac_step_2 1 "lget" - #e_any #e_string #e_any - #NBET.e_any #NBET.e_string #NBET.e_any - lget - (fun _ _ -> fail "sorry, `lget` does not work in NBE"); - - mk_tac_step_3 1 "lset" - #e_any #e_string #e_any #e_unit - #NBET.e_any #NBET.e_string #NBET.e_any #NBET.e_unit - lset - (fun _ _ _ -> fail "sorry, `lset` does not work in NBE"); - - mk_tac_step_1 1 "set_urgency" set_urgency set_urgency; - mk_tac_step_1 1 "set_dump_on_failure" set_dump_on_failure set_dump_on_failure; - mk_tac_step_1 1 "t_commute_applied_match" t_commute_applied_match t_commute_applied_match; - mk_tac_step_1 0 "gather_or_solve_explicit_guards_for_resolved_goals" - gather_explicit_guards_for_resolved_goals - gather_explicit_guards_for_resolved_goals; - mk_tac_step_2 0 "string_to_term" string_to_term string_to_term; - mk_tac_step_2 0 "push_bv_dsenv" push_bv_dsenv push_bv_dsenv; - mk_tac_step_1 0 "term_to_string" term_to_string term_to_string; - mk_tac_step_1 0 "comp_to_string" comp_to_string comp_to_string; - mk_tac_step_1 0 "term_to_doc" term_to_doc term_to_doc; - mk_tac_step_1 0 "comp_to_doc" comp_to_doc comp_to_doc; - mk_tac_step_1 0 "range_to_string" range_to_string range_to_string; - mk_tac_step_2 0 "term_eq_old" term_eq_old term_eq_old; - - mk_tac_step_3 1 "with_compat_pre_core" - #e_any #e_int #(TI.e_tactic_thunk e_any) #e_any - #NBET.e_any #NBET.e_int #(TI.e_tactic_nbe_thunk NBET.e_any) #NBET.e_any - (fun _ -> with_compat_pre_core) - (fun _ -> with_compat_pre_core); - - mk_tac_step_1 0 "get_vconfig" get_vconfig get_vconfig; - mk_tac_step_1 0 "set_vconfig" set_vconfig set_vconfig; - mk_tac_step_1 0 "t_smt_sync" t_smt_sync t_smt_sync; - mk_tac_step_1 0 "free_uvars" free_uvars free_uvars; - mk_tac_step_1 0 "all_ext_options" all_ext_options all_ext_options; - mk_tac_step_1 0 "ext_getv" ext_getv ext_getv; - mk_tac_step_1 0 "ext_getns" ext_getns ext_getns; - - mk_tac_step_2 1 "alloc" - #e_any #e_any #(E.e_tref #S.term) - #NBET.e_any #NBET.e_any #(E.e_tref_nbe #NBET.t) - (fun _ -> alloc) - (fun _ -> alloc); - - mk_tac_step_2 1 "read" - #e_any #(E.e_tref #S.term) #e_any - #NBET.e_any #(E.e_tref_nbe #NBET.t) #NBET.e_any - (fun _ -> read) - (fun _ -> read); - - mk_tac_step_3 1 "write" - #e_any #(E.e_tref #S.term) #e_any #e_unit - #NBET.e_any #(E.e_tref_nbe #NBET.t) #NBET.e_any #NBET.e_unit - (fun _ -> write) - (fun _ -> write); - - // reflection typechecker callbacks (part of the DSL framework) - - mk_tac_step_2 0 "is_non_informative" refl_is_non_informative refl_is_non_informative; - mk_tac_step_3 0 "check_subtyping" refl_check_subtyping refl_check_subtyping; - mk_tac_step_5 0 "t_check_equiv" t_refl_check_equiv t_refl_check_equiv; - mk_tac_step_2 0 "core_compute_term_type" refl_core_compute_term_type refl_core_compute_term_type; - mk_tac_step_4 0 "core_check_term" refl_core_check_term refl_core_check_term; - mk_tac_step_3 0 "core_check_term_at_type" refl_core_check_term_at_type refl_core_check_term_at_type; - mk_tac_step_2 0 "tc_term" refl_tc_term refl_tc_term; - mk_tac_step_2 0 "universe_of" refl_universe_of refl_universe_of; - mk_tac_step_2 0 "check_prop_validity" refl_check_prop_validity refl_check_prop_validity; - mk_tac_step_4 0 "check_match_complete" refl_check_match_complete refl_check_match_complete; - mk_tac_step_3 0 "instantiate_implicits" - #_ #_ #_ #(e_ret_t (e_tuple3 (e_list (e_tuple2 RE.e_namedv solve)) solve solve)) - #_ #_ #_ #(nbe_e_ret_t (NBET.e_tuple3 (NBET.e_list (NBET.e_tuple2 NRE.e_namedv solve)) solve solve)) - refl_instantiate_implicits refl_instantiate_implicits; - mk_tac_step_4 0 "try_unify" - #_ #(e_list (e_tuple2 RE.e_namedv RE.e_term)) #_ #_ #(e_ret_t (e_list (e_tuple2 RE.e_namedv RE.e_term))) - #_ #(NBET.e_list (NBET.e_tuple2 NRE.e_namedv NRE.e_term)) #_ #_ #(nbe_e_ret_t (NBET.e_list (NBET.e_tuple2 NRE.e_namedv NRE.e_term))) - refl_try_unify refl_try_unify; - mk_tac_step_3 0 "maybe_relate_after_unfolding" refl_maybe_relate_after_unfolding refl_maybe_relate_after_unfolding; - mk_tac_step_2 0 "maybe_unfold_head" refl_maybe_unfold_head refl_maybe_unfold_head; - mk_tac_step_3 0 "norm_well_typed_term" refl_norm_well_typed_term refl_norm_well_typed_term; - - mk_tac_step_2 0 "push_open_namespace" push_open_namespace push_open_namespace; - mk_tac_step_3 0 "push_module_abbrev" push_module_abbrev push_module_abbrev; - mk_tac_step_2 0 "resolve_name" - #_ #_ #(e_option (e_either RE.e_bv solve)) // disambiguate bv/namedv - #_ #_ #(NBET.e_option (NBET.e_either NRE.e_bv solve)) - resolve_name resolve_name; - mk_tac_step_1 0 "log_issues" log_issues log_issues; - mk_tac_step_4 0 "call_subtac" - #_ #(TI.e_tactic_thunk e_unit) #_ #_ #_ - #_ #(TI.e_tactic_nbe_thunk NBET.e_unit) #_ #_ #_ - call_subtac call_subtac; - - mk_tac_step_4 0 "call_subtac_tm" - call_subtac_tm call_subtac_tm; -] diff --git a/src/tactics/FStar.Tactics.V2.Primops.fsti b/src/tactics/FStar.Tactics.V2.Primops.fsti deleted file mode 100644 index f0f1ca3321f..00000000000 --- a/src/tactics/FStar.Tactics.V2.Primops.fsti +++ /dev/null @@ -1,20 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Tactics.V2.Primops - -open FStar.TypeChecker.Primops.Base - -val ops : list primitive_step diff --git a/src/tactics/FStarC.Tactics.Common.fst b/src/tactics/FStarC.Tactics.Common.fst new file mode 100644 index 00000000000..ed075f9c7e0 --- /dev/null +++ b/src/tactics/FStarC.Tactics.Common.fst @@ -0,0 +1,15 @@ +module FStarC.Tactics.Common + +(* NOTE: This file is exactly the same as its .fs/.fsi counterpart. +It is only here so the equally-named interface file in ulib/ is not +taken by the dependency analysis to be the interface of the .fs. We also +cannot ditch the .fs, since out bootstrapping process does not extract +any .ml file from an interface. Hence we keep both, exactly equal to +each other. *) + +open FStarC.Syntax.Syntax + +exception NotAListLiteral +exception TacticFailure of FStarC.Errors.Msg.error_message & option FStarC.Compiler.Range.range +exception EExn of term +exception SKIP (* used by ctrl_rewrite *) diff --git a/src/tactics/FStarC.Tactics.Common.fsti b/src/tactics/FStarC.Tactics.Common.fsti new file mode 100644 index 00000000000..ed075f9c7e0 --- /dev/null +++ b/src/tactics/FStarC.Tactics.Common.fsti @@ -0,0 +1,15 @@ +module FStarC.Tactics.Common + +(* NOTE: This file is exactly the same as its .fs/.fsi counterpart. +It is only here so the equally-named interface file in ulib/ is not +taken by the dependency analysis to be the interface of the .fs. We also +cannot ditch the .fs, since out bootstrapping process does not extract +any .ml file from an interface. Hence we keep both, exactly equal to +each other. *) + +open FStarC.Syntax.Syntax + +exception NotAListLiteral +exception TacticFailure of FStarC.Errors.Msg.error_message & option FStarC.Compiler.Range.range +exception EExn of term +exception SKIP (* used by ctrl_rewrite *) diff --git a/src/tactics/FStarC.Tactics.CtrlRewrite.fst b/src/tactics/FStarC.Tactics.CtrlRewrite.fst new file mode 100644 index 00000000000..1cd38b4541d --- /dev/null +++ b/src/tactics/FStarC.Tactics.CtrlRewrite.fst @@ -0,0 +1,457 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Tactics.CtrlRewrite + +open FStarC +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.Reflection.V2.Data +open FStarC.Reflection.V2.Builtins +open FStarC.Tactics.Result +open FStarC.TypeChecker.Common +open FStarC.TypeChecker.Env +open FStarC.Tactics.Types +open FStarC.Tactics.Monad +open FStarC.Tactics.Common +open FStarC.Syntax.Syntax +open FStarC.Class.Show +open FStarC.Class.Monad + +module Print = FStarC.Syntax.Print +module BU = FStarC.Compiler.Util +module S = FStarC.Syntax.Syntax +module U = FStarC.Syntax.Util +module SS = FStarC.Syntax.Subst +module Z = FStarC.BigInt +module Env = FStarC.TypeChecker.Env +module TcComm = FStarC.TypeChecker.Common +module N = FStarC.TypeChecker.Normalize +module Const = FStarC.Const +module Errors = FStarC.Errors + +let rangeof g = g.goal_ctx_uvar.ctx_uvar_range + +let __do_rewrite + (g0:goal) + (rewriter : rewriter_ty) + (env : env) + (tm : term) + : tac term += + (* + * We skip certain terms. In particular if the term is a constant + * which must have an argument (reify, reflect, range_of, + * set_range_of), since typechecking will then fail, and the tactic + * will also not be able to do anything useful. Morally, `reify` is + * not a term, so it's fine to skip it. + * + * This is not perfect since if we have any other node wrapping the + * `reify` (metadata?) this will still fail. But I don't think that + * ever happens currently. + *) + let should_skip = + match (SS.compress tm).n with + | S.Tm_constant (Const.Const_reify _) + | S.Tm_constant (Const.Const_reflect _) + | S.Tm_constant Const.Const_range_of + | S.Tm_constant Const.Const_set_range_of -> + true + | _ -> false + in + if should_skip then return tm else begin + + (* It's important to keep the original term if we want to do + * nothing, (hence the underscore below) since after the call to + * the typechecker, t can be elaborated and have more structure. In + * particular, it can be abscribed and hence CONTAIN t AS A SUBTERM! + * Which would cause an infinite loop between this function and + * ctrl_fold_env. + * + * If we got an error about a layered effect missing an annotation, + * we just skip the term, for reasons similar to unapplied constants + * above. Other exceptions are re-raised. + *) + let res = + try + Errors.with_ctx "While typechecking a subterm for ctrl_rewrite" (fun () -> + (* NS: Should we use Core here? *) + + Some (env.tc_term ({ env with admit = true }) tm)) + with + | Errors.Error (Errors.Error_LayeredMissingAnnot, _, _, _) -> None + | e -> raise e + in + match res with + | None -> return tm + | Some (_, lcomp, g) -> + + if not (TcComm.is_pure_or_ghost_lcomp lcomp) then + return tm (* SHOULD THIS CHECK BE IN maybe_rewrite INSTEAD? *) + else + let g = FStarC.TypeChecker.Rel.solve_deferred_constraints env g in + let typ = lcomp.res_typ in + + (* unrefine typ as is done for the type arg of eq2 *) + let typ = + if Options.Ext.get "__unrefine" <> "" then + let typ_norm = N.unfold_whnf' [Env.DontUnfoldAttr [Parser.Const.do_not_unrefine_attr]] env typ in + if Tm_refine? (SS.compress typ_norm).n then + (* It is indeed a refinement, normalize again to remove them. *) + let typ' = N.unfold_whnf' [Env.DontUnfoldAttr [Parser.Const.do_not_unrefine_attr]; Env.Unrefine] env typ_norm in + typ' + else + typ + else + typ + in + + let should_check = + if FStarC.TypeChecker.Common.is_total_lcomp lcomp + then None + else Some (Allow_ghost "do_rewrite.lhs") + in + let! ut, uvar_t = + new_uvar "do_rewrite.rhs" env typ + should_check + (goal_typedness_deps g0) + (rangeof g0) + in + if_verbose (fun () -> + BU.print2 "do_rewrite: making equality\n\t%s ==\n\t%s\n" + (show tm) (show ut)) ;! + add_irrelevant_goal + g0 + "do_rewrite.eq" + env + (U.mk_eq2 (env.universe_of env typ) typ tm ut) + None ;! + (* v1 and v2 match *) + focus rewriter ;! + // Try to get rid of all the unification lambdas + let ut = N.reduce_uvar_solutions env ut in + if_verbose (fun () -> + BU.print2 "rewrite_rec: succeeded rewriting\n\t%s to\n\t%s\n" + (show tm) + (show ut)) ;! + return ut + end + +(* If __do_rewrite fails with the SKIP exception we do nothing *) +let do_rewrite + (g0:goal) + (rewriter : rewriter_ty) + (env : env) + (tm : term) + : tac term + = match! catch (__do_rewrite g0 rewriter env tm) with + | Inl SKIP -> return tm + | Inl e -> traise e + | Inr tm' -> return tm' + +type ctac 'a = 'a -> tac ('a & ctrl_flag) + +(* Transform a value x with c1, and continue with c2 if needed *) +let seq_ctac (c1 : ctac 'a) (c2 : ctac 'a) + : ctac 'a + = fun (x:'a) -> + let! x', flag = c1 x in + match flag with + | Abort -> return (x', Abort) + | Skip -> return (x', Skip) + | Continue -> c2 x' + +let par_combine = function + | Abort, _ + | _, Abort -> Abort + | Skip, _ + | _, Skip -> Skip + | Continue, Continue -> Continue + +(* Transform a value (x, y) with cl and cr respectively. + * Skip on x will still run c2 on y, but Abort will abort. *) +let par_ctac (cl : ctac 'a) (cr : ctac 'b) + : ctac ('a & 'b) + = fun (x, y) -> + let! x, flag = cl x in + match flag with + | Abort -> return ((x, y), Abort) + | fa -> + let! y, flag = cr y in + match flag with + | Abort -> return ((x, y),Abort) + | fb -> + return ((x, y), par_combine (fa, fb)) + +let rec map_ctac (c : ctac 'a) + : ctac (list 'a) + = fun xs -> + match xs with + | [] -> return ([], Continue) + | x::xs -> + let! ((x, xs), flag) = par_ctac c (map_ctac c) (x, xs) in + return (x::xs, flag) + +(* let bind_ctac *) +(* (t : ctac 'a) *) +(* (f : 'a -> ctac 'b) *) +(* : ctac 'b *) +(* = fun b -> failwith "" *) + +let ctac_id : #a:Type -> ctac a = + fun #a (x:a) -> return (x, Continue) + +let ctac_args (c : ctac term) : ctac args = + map_ctac (par_ctac c (ctac_id #_)) + +let maybe_rewrite + (g0 : goal) + (controller : controller_ty) + (rewriter : rewriter_ty) + (env : env) + (tm : term) + : tac (term & ctrl_flag) + = let! (rw, ctrl_flag) = controller tm in + let! tm' = + if rw + then do_rewrite g0 rewriter env tm + else return tm + in + return (tm', ctrl_flag) + +let rec ctrl_fold_env + (g0 : goal) + (d : direction) + (controller : controller_ty) + (rewriter : rewriter_ty) + (env : env) + (tm : term) + : tac (term & ctrl_flag) + = let recurse tm = + ctrl_fold_env g0 d controller rewriter env tm + in + match d with + | TopDown -> + seq_ctac (maybe_rewrite g0 controller rewriter env) + (on_subterms g0 d controller rewriter env) tm + + | BottomUp -> + seq_ctac (on_subterms g0 d controller rewriter env) + (maybe_rewrite g0 controller rewriter env) tm + +and recurse_option_residual_comp (env:env) (retyping_subst:list subst_elt) (rc_opt:option residual_comp) recurse + : tac (option residual_comp & ctrl_flag) + = // return (None, Continue) + match rc_opt with + | None -> return (None, Continue) + | Some rc -> + match rc.residual_typ with + | None -> return (Some rc, Continue) + | Some t -> + let t = SS.subst retyping_subst t in + let! t, flag = recurse env t in + return (Some ({rc with residual_typ=Some t}), flag) + +and on_subterms + (g0 : goal) + (d : direction) + (controller : controller_ty) + (rewriter : rewriter_ty) + (env : env) + (tm : term) + : tac (term & ctrl_flag) + = let recurse env tm = ctrl_fold_env g0 d controller rewriter env tm in + let rr = recurse env in (* recurse on current env *) + + // + // t is the body and k is the option residual comp + // + // Note, the type of the binder sorts may change as we rewrite them + // The retyping_subst is an identity substitution that replaces the bound vars + // in the term with their new variants tagged with the rewritten bv sorts + // + let rec descend_binders orig accum_binders retyping_subst accum_flag env bs t k rebuild = + match bs with + | [] -> + let t = SS.subst retyping_subst t in + let! t, t_flag = recurse env t in + begin + match t_flag with + | Abort -> return (orig.n, t_flag) //if anything aborts, just return the original abs + | _ -> + let! k, k_flag = recurse_option_residual_comp env retyping_subst k recurse in + let bs = List.rev accum_binders in + let subst = SS.closing_of_binders bs in + // For dependent binders, we need to re-compute the substitution incrementally; applying subst to bs doesn't work + let bs = SS.close_binders bs in + let t = SS.subst subst t in + let k = BU.map_option (SS.subst_residual_comp subst) k in + return (rebuild bs t k, + par_combine (accum_flag, (par_combine (t_flag, k_flag)))) + end + + | b::bs -> + let s = SS.subst retyping_subst b.binder_bv.sort in + let! s, flag = recurse env s in + match flag with + | Abort -> return (orig.n, flag) //if anything aborts, just return the original abs + | _ -> + let bv = {b.binder_bv with sort = s} in + let b = {b with binder_bv = bv} in + let env = Env.push_binders env [b] in + let retyping_subst = NT(bv, bv_to_name bv) :: retyping_subst in + descend_binders orig (b::accum_binders) retyping_subst (par_combine (accum_flag, flag)) env bs t k rebuild + in + let go () : tac (term' & ctrl_flag) = + let tm = SS.compress tm in + match tm.n with + (* Run on hd and args in parallel *) + | Tm_app {hd; args} -> + let! ((hd, args), flag) = par_ctac rr (ctac_args rr) (hd, args) in + return (Tm_app {hd; args}, flag) + + (* Open, descend, rebuild *) + | Tm_abs {bs; body=t; rc_opt=k} -> + let bs_orig, t, subst = SS.open_term' bs t in + let k = k |> BU.map_option (SS.subst_residual_comp subst) in + descend_binders tm [] [] Continue env bs_orig t k + (fun bs t k -> Tm_abs {bs; body=t; rc_opt=k}) + + | Tm_refine {b=x; phi} -> + let bs, phi = SS.open_term [S.mk_binder x] phi in + descend_binders tm [] [] Continue env bs phi None //no residual comp + (fun bs phi _ -> + let x = + match bs with + | [x] -> x.binder_bv + | _ -> failwith "Impossible" + in + Tm_refine {b=x; phi}) + + | Tm_arrow { bs = bs; comp = comp } -> + (match comp.n with + | Total t -> + let bs_orig, t = SS.open_term bs t in + descend_binders tm [] [] Continue env bs_orig t None + (fun bs t _ -> Tm_arrow {bs; comp = {comp with n = Total t}}) + | GTotal t -> + let bs_orig, t = SS.open_term bs t in + descend_binders tm [] [] Continue env bs_orig t None + (fun bs t _ -> Tm_arrow {bs; comp = {comp with n = GTotal t}}) + | _ -> + (* Do nothing (FIXME). + What should we do for effectful computations? *) + return (tm.n, Continue)) + + (* Descend on head and branches in parallel. Branches + * are opened with their contexts extended. Ignore the when clause, + * and do not go into patterns. + * also ignoring the return annotations *) + | Tm_match {scrutinee=hd; ret_opt=asc_opt; brs; rc_opt=lopt} -> + let c_branch (br:S.branch) : tac (S.branch & ctrl_flag) = + let (pat, w, e) = SS.open_branch br in + let bvs = S.pat_bvs pat in + let! e, flag = recurse (Env.push_bvs env bvs) e in + let br = SS.close_branch (pat, w, e) in + return (br, flag) + in + let! ((hd, brs), flag) = par_ctac rr (map_ctac c_branch) (hd, brs) in + return (Tm_match {scrutinee=hd; ret_opt=asc_opt; brs; rc_opt=lopt}, flag) + + (* Descend, in parallel, in the definiens and the body, where + * the body is extended with the bv. Do not go into the type. *) + | Tm_let {lbs=(false, [{ lbname = Inl bv; lbdef = def }]); body=e} -> + (* ugh *) + let lb = match (SS.compress tm).n with + | Tm_let {lbs=(false, [lb])} -> lb + | _ -> failwith "impossible" + in + let bv, e = SS.open_term_bv bv e in + let! ((lbdef, e), flag) = + par_ctac rr (recurse (Env.push_bv env bv)) (lb.lbdef, e) + in + let lb = { lb with lbdef = lbdef } in + let e = SS.close [S.mk_binder bv] e in + return (Tm_let {lbs=(false, [lb]); body=e}, flag) + + (* Descend, in parallel, in *every* definiens and the body. + * Again body is properly opened, and we don't go into types. *) + | Tm_let {lbs=(true, lbs); body=e} -> + let c_lb (lb:S.letbinding) : tac (S.letbinding & ctrl_flag) = + let! (def, flag) = rr lb.lbdef in + return ({lb with lbdef = def }, flag) + in + let lbs, e = SS.open_let_rec lbs e in + (* TODO: the `rr` has to be wrong, we need more binders *) + let! ((lbs, e), flag) = par_ctac (map_ctac c_lb) rr (lbs, e) in + let lbs, e = SS.close_let_rec lbs e in + return (Tm_let {lbs=(true, lbs); body=e}, flag) + + (* Descend into the ascripted term, ignore all else *) + | Tm_ascribed {tm=t; asc; eff_opt=eff} -> + let! t, flag = rr t in + return (Tm_ascribed {tm=t; asc; eff_opt=eff}, flag) + + (* Ditto *) + | Tm_meta {tm=t; meta=m} -> + let! (t, flag) = rr t in + return (Tm_meta {tm=t; meta=m}, flag) + + | _ -> + (* BU.print1 "GG ignoring %s\n" (tag_of tm); *) + return (tm.n, Continue) + in + let! (tmn', flag) = go () in + return ({tm with n = tmn'}, flag) + +let do_ctrl_rewrite + (g0 : goal) + (dir : direction) + (controller : controller_ty) + (rewriter : rewriter_ty) + (env : env) + (tm : term) + : tac term + = let! tm', _ = ctrl_fold_env g0 dir controller rewriter env tm in + return tm' + +let ctrl_rewrite + (dir : direction) + (controller : controller_ty) + (rewriter : rewriter_ty) + : tac unit + = wrap_err "ctrl_rewrite" <| ( + let! ps = get in + let g, gs = match ps.goals with + | g::gs -> g, gs + | [] -> failwith "no goals" + in + dismiss_all ;! + let gt = (goal_type g) in + if_verbose (fun () -> + BU.print1 "ctrl_rewrite starting with %s\n" (show gt)) ;! + + let! gt' = do_ctrl_rewrite g dir controller rewriter (goal_env g) gt in + + if_verbose (fun () -> + BU.print1 "ctrl_rewrite seems to have succeded with %s\n" (show gt')) ;! + + push_goals gs ;! + let g = goal_with_type g gt' in + add_goals [g] + ) diff --git a/src/tactics/FStarC.Tactics.CtrlRewrite.fsti b/src/tactics/FStarC.Tactics.CtrlRewrite.fsti new file mode 100644 index 00000000000..2ead5c9f5dc --- /dev/null +++ b/src/tactics/FStarC.Tactics.CtrlRewrite.fsti @@ -0,0 +1,29 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Tactics.CtrlRewrite + +open FStarC.Tactics.Types +open FStarC.Tactics.Monad +open FStarC.Syntax.Syntax + +module Z = FStarC.BigInt + +(* TODO: allow to pass information from ctrl_tac to rewriter? *) +type controller_ty = term -> tac (bool & ctrl_flag) +type rewriter_ty = tac unit + +val ctrl_rewrite: direction -> controller_ty -> rewriter_ty -> tac unit diff --git a/src/tactics/FStarC.Tactics.Embedding.fst b/src/tactics/FStarC.Tactics.Embedding.fst new file mode 100644 index 00000000000..9a7d7dfa362 --- /dev/null +++ b/src/tactics/FStarC.Tactics.Embedding.fst @@ -0,0 +1,615 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Tactics.Embedding + +open FStar open FStarC +open FStarC.Compiler +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Syntax.Syntax +open FStarC.Syntax.Embeddings +open FStarC.Compiler.Util +open FStarC.Compiler.List +open FStarC.Class.Show + +open FStarC.Tactics.Common +open FStarC.Tactics.Types +open FStarC.Tactics.Result + +module BU = FStarC.Compiler.Util +module Err = FStarC.Errors +module NBE = FStarC.TypeChecker.NBE +module NBETerm = FStarC.TypeChecker.NBETerm +module NBET = FStarC.TypeChecker.NBETerm +module PC = FStarC.Parser.Const +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module U = FStarC.Syntax.Util + +type name = bv + +let fstar_tactics_lid' s = PC.fstar_tactics_lid' s +let fstar_stubs_tactics_lid' s = PC.fstar_stubs_tactics_lid' s +let lid_as_tm l = S.lid_as_fv l None |> S.fv_to_tm +let mk_tactic_lid_as_term (s:string) = lid_as_tm (fstar_tactics_lid' ["Effect"; s]) + + +type tac_constant = { + lid : Ident.lid; + fv : fv; + t : term; +} + +let lid_as_data_fv l = S.lid_as_fv l (Some Data_ctor) +let lid_as_data_tm l = S.fv_to_tm (lid_as_data_fv l) + +let fstar_tactics_data ns = + let lid = fstar_stubs_tactics_lid' ns in + { lid = lid; + fv = lid_as_data_fv lid; + t = lid_as_data_tm lid } + +let fstar_tactics_const ns = + let lid = fstar_stubs_tactics_lid' ns in + { lid = lid; + fv = S.fvconst lid; + t = S.tconst lid } + +let fstar_tc_core_lid s : lid = + FStarC.Ident.lid_of_path (["FStar"; "Stubs"; "TypeChecker"; "Core"]@[s]) Range.dummyRange + +let fstar_tc_core_data s = + let lid = fstar_tc_core_lid s in + { lid = lid; + fv = lid_as_data_fv lid; + t = lid_as_data_tm lid } + +let fstar_tc_core_const s = + let lid = fstar_tc_core_lid s in + { lid = lid; + fv = S.fvconst lid; + t = S.tconst lid } + + +let fstar_tactics_proofstate = fstar_tactics_const ["Types"; "proofstate"] +let fstar_tactics_goal = fstar_tactics_const ["Types"; "goal"] + +let fstar_tactics_TacticFailure = fstar_tactics_data ["Common"; "TacticFailure"] +let fstar_tactics_SKIP = fstar_tactics_data ["Common"; "SKIP"] + +let fstar_tactics_result = fstar_tactics_const ["Result"; "__result"] +let fstar_tactics_Success = fstar_tactics_data ["Result"; "Success"] +let fstar_tactics_Failed = fstar_tactics_data ["Result"; "Failed"] + +let fstar_tactics_direction = fstar_tactics_const ["Types"; "direction"] +let fstar_tactics_topdown = fstar_tactics_data ["Types"; "TopDown"] +let fstar_tactics_bottomup = fstar_tactics_data ["Types"; "BottomUp"] + +let fstar_tactics_ctrl_flag = fstar_tactics_const ["Types"; "ctrl_flag"] +let fstar_tactics_Continue = fstar_tactics_data ["Types"; "Continue"] +let fstar_tactics_Skip = fstar_tactics_data ["Types"; "Skip"] +let fstar_tactics_Abort = fstar_tactics_data ["Types"; "Abort"] + +let fstar_tc_core_unfold_side = fstar_tc_core_const "unfold_side" +let fstar_tc_core_unfold_side_Left = fstar_tc_core_data "Left" +let fstar_tc_core_unfold_side_Right = fstar_tc_core_data "Right" +let fstar_tc_core_unfold_side_Both = fstar_tc_core_data "Both" +let fstar_tc_core_unfold_side_Neither = fstar_tc_core_data "Neither" + +let fstar_tc_core_tot_or_ghost = fstar_tc_core_const "tot_or_ghost" +let fstar_tc_core_tot_or_ghost_ETotal = fstar_tc_core_data "E_Total" +let fstar_tc_core_tot_or_ghost_EGhost = fstar_tc_core_data "E_Ghost" + +let fstar_tactics_guard_policy = fstar_tactics_const ["Types"; "guard_policy"] +let fstar_tactics_SMT = fstar_tactics_data ["Types"; "SMT"] +let fstar_tactics_SMTSync = fstar_tactics_data ["Types"; "SMTSync"] +let fstar_tactics_Goal = fstar_tactics_data ["Types"; "Goal"] +let fstar_tactics_Drop = fstar_tactics_data ["Types"; "Drop"] +let fstar_tactics_Force = fstar_tactics_data ["Types"; "Force"] + + +let mk_emb (em: Range.range -> 'a -> term) + (un: term -> option 'a) + (t: term) = + mk_emb (fun x r _topt _norm -> em r x) + (fun x _norm -> un x) + (FStarC.Syntax.Embeddings.term_as_fv t) +let embed {|embedding 'a|} r (x:'a) = FStarC.Syntax.Embeddings.embed x r None id_norm_cb +let unembed' {|embedding 'a|} x : option 'a = FStarC.Syntax.Embeddings.unembed x id_norm_cb + +let t_result_of t = U.mk_app fstar_tactics_result.t [S.as_arg t] // TODO: uinst on t_result? + +let hd'_and_args tm = + let tm = U.unascribe tm in + let hd, args = U.head_and_args tm in + (U.un_uinst hd).n, args + +instance e_proofstate : embedding proofstate = e_lazy Lazy_proofstate fstar_tactics_proofstate.t +instance e_goal : embedding goal = e_lazy Lazy_goal fstar_tactics_goal.t + +let unfold_lazy_proofstate (i : lazyinfo) : term = + U.exp_string "(((proofstate)))" + +let unfold_lazy_goal (i : lazyinfo) : term = + U.exp_string "(((goal)))" + +(* PLEASE NOTE: Construct and FV accumulate their arguments BACKWARDS. That is, + * the expression (f 1 2) is stored as FV (f, [], [Constant (Int 2); Constant (Int 1)]. + * So be careful when calling mkFV/mkConstruct and matching on them. *) + +(* On that note, we use this (inefficient, FIXME) hack in this module *) +let mkFV fv us ts = NBETerm.mkFV fv (List.rev us) (List.rev ts) +let mkConstruct fv us ts = NBETerm.mkConstruct fv (List.rev us) (List.rev ts) +let fv_as_emb_typ fv = S.ET_app (show fv.fv_name.v, []) + +let e_proofstate_nbe = + let embed_proofstate _cb (ps:proofstate) : NBETerm.t = + let li = { lkind = Lazy_proofstate + ; blob = FStarC.Dyn.mkdyn ps + ; ltyp = fstar_tactics_proofstate.t + ; rng = Range.dummyRange } + in + let thunk = Thunk.mk (fun () -> NBETerm.mk_t <| NBETerm.Constant (NBETerm.String ("(((proofstate.nbe)))", Range.dummyRange))) in + NBETerm.mk_t (NBETerm.Lazy (Inl li, thunk)) + in + let unembed_proofstate _cb (t:NBETerm.t) : option proofstate = + match NBETerm.nbe_t_of_t t with + | NBETerm.Lazy (Inl {blob=b; lkind = Lazy_proofstate}, _) -> + Some <| FStarC.Dyn.undyn b + | _ -> + if !Options.debug_embedding then + Err.log_issue0 + Err.Warning_NotEmbedded + (BU.format1 "Not an embedded NBE proofstate: %s\n" + (NBETerm.t_to_string t)); + None + in + { NBETerm.em = embed_proofstate + ; NBETerm.un = unembed_proofstate + ; NBETerm.typ = (fun () -> mkFV fstar_tactics_proofstate.fv [] []) + ; NBETerm.e_typ = (fun () -> fv_as_emb_typ fstar_tactics_proofstate.fv) + } + +let e_goal_nbe = + let embed_goal _cb (ps:goal) : NBETerm.t = + let li = { lkind = Lazy_goal + ; blob = FStarC.Dyn.mkdyn ps + ; ltyp = fstar_tactics_goal.t + ; rng = Range.dummyRange } + in + let thunk = Thunk.mk (fun () -> NBETerm.mk_t <| NBETerm.Constant (NBETerm.String ("(((goal.nbe)))", Range.dummyRange))) in + NBETerm.mk_t <| NBETerm.Lazy (Inl li, thunk) + in + let unembed_goal _cb (t:NBETerm.t) : option goal = + match NBETerm.nbe_t_of_t t with + | NBETerm.Lazy (Inl {blob=b; lkind = Lazy_goal}, _) -> + Some <| FStarC.Dyn.undyn b + | _ -> + if !Options.debug_embedding then + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded NBE goal: %s" (NBETerm.t_to_string t)); + None + in + { NBETerm.em = embed_goal + ; NBETerm.un = unembed_goal + ; NBETerm.typ = (fun () -> mkFV fstar_tactics_goal.fv [] []) + ; NBETerm.e_typ = (fun () -> fv_as_emb_typ fstar_tactics_goal.fv) + } + +instance e_exn : embedding exn = + let embed_exn (e:exn) (rng:Range.range) _ _ : term = + match e with + | TacticFailure s -> + S.mk_Tm_app fstar_tactics_TacticFailure.t + [S.as_arg (embed rng s)] + rng + | SKIP -> + { fstar_tactics_SKIP.t with pos = rng } + + | EExn t -> + { t with pos = rng } + + | e -> + let open FStarC.Pprint in + let open FStarC.Class.PP in + let open FStarC.Errors.Msg in + let msg : error_message = [ + text "Uncaught exception"; + arbitrary_string (BU.message_of_exn e); + ] + in + S.mk_Tm_app fstar_tactics_TacticFailure.t + [S.as_arg (embed rng (msg, None #Range.range))] + rng + in + let unembed_exn (t:term) _ : option exn = + match hd'_and_args t with + | Tm_fvar fv, [(s, _)] when S.fv_eq_lid fv fstar_tactics_TacticFailure.lid -> + BU.bind_opt (unembed' s) (fun s -> + Some (TacticFailure s)) + + | Tm_fvar fv, [] when S.fv_eq_lid fv fstar_tactics_SKIP.lid -> + Some SKIP + + | _ -> + (* Anything else, we just pass-through *) + Some (EExn t) + in + mk_emb_full + embed_exn + unembed_exn + (fun () -> t_exn) + (fun _ -> "(exn)") + (fun () -> ET_app (show PC.exn_lid, [])) + +let e_exn_nbe = + let embed_exn cb (e:exn) : NBET.t = + match e with + | TacticFailure s -> + mkConstruct fstar_tactics_TacticFailure.fv + [] + [ NBETerm.as_arg (NBETerm.embed FStar.Tactics.Typeclasses.solve cb s) ] + + | SKIP -> + mkConstruct fstar_tactics_SKIP.fv [] [] + + | _ -> + failwith (BU.format1 "cannot embed exn (NBE) : %s" (BU.message_of_exn e)) + in + let unembed_exn cb (t:NBET.t) : option exn = + match NBETerm.nbe_t_of_t t with + | NBETerm.Construct (fv, _, [(s, _)]) when S.fv_eq_lid fv fstar_tactics_TacticFailure.lid -> + BU.bind_opt (NBETerm.unembed FStar.Tactics.Typeclasses.solve cb s) (fun s -> + Some (TacticFailure s)) + + | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tactics_SKIP.lid -> + Some SKIP + + | _ -> + None + in + let fv_exn = S.fvconst PC.exn_lid in + { NBETerm.em = embed_exn + ; NBETerm.un = unembed_exn + ; NBETerm.typ = (fun () -> mkFV fv_exn [] []) + ; NBETerm.e_typ = (fun () -> fv_as_emb_typ fv_exn) } + +let e_result (ea : embedding 'a) : Tot _ = + let embed_result (res:__result 'a) (rng:Range.range) (sh:shadow_term) (cbs:norm_cb) : term = + match res with + | Success (a, ps) -> + S.mk_Tm_app (S.mk_Tm_uinst fstar_tactics_Success.t [U_zero]) + [S.iarg (type_of ea); + S.as_arg (embed rng a); + S.as_arg (embed rng ps)] + rng + | Failed (e, ps) -> + S.mk_Tm_app (S.mk_Tm_uinst fstar_tactics_Failed.t [U_zero]) + [S.iarg (type_of ea); + S.as_arg (embed rng e); + S.as_arg (embed rng ps)] + rng + in + let unembed_result (t:term) _ : option (__result 'a) = + match hd'_and_args t with + | Tm_fvar fv, [_t; (a, _); (ps, _)] when S.fv_eq_lid fv fstar_tactics_Success.lid -> + BU.bind_opt (unembed' a) (fun a -> + BU.bind_opt (unembed' ps) (fun ps -> + Some (Success (a, ps)))) + + | Tm_fvar fv, [_t; (e, _); (ps, _)] when S.fv_eq_lid fv fstar_tactics_Failed.lid -> + BU.bind_opt (unembed' e) (fun e -> + BU.bind_opt (unembed' ps) (fun ps -> + Some (Failed (e, ps)))) + + | _ -> None + in + mk_emb_full #(__result 'a) + embed_result + unembed_result + (fun () -> t_result_of (type_of ea)) + (fun _ -> "") + (fun () -> ET_app (show fstar_tactics_result.lid, [emb_typ_of 'a ()])) + +let e_result_nbe (ea : NBET.embedding 'a) = + let embed_result cb (res:__result 'a) : NBET.t = + match res with + | Failed (e, ps) -> + mkConstruct fstar_tactics_Failed.fv + [U_zero] + [ NBETerm.as_iarg (NBETerm.type_of ea) + ; NBETerm.as_arg (NBETerm.embed e_exn_nbe cb e) + ; NBETerm.as_arg (NBETerm.embed e_proofstate_nbe cb ps) ] + | Success (a, ps) -> + mkConstruct fstar_tactics_Success.fv + [U_zero] + [ NBETerm.as_iarg (NBETerm.type_of ea) + ; NBETerm.as_arg (NBETerm.embed ea cb a) + ; NBETerm.as_arg (NBETerm.embed e_proofstate_nbe cb ps) ] + in + let unembed_result cb (t:NBET.t) : option (__result 'a) = + match NBETerm.nbe_t_of_t t with + | NBETerm.Construct (fv, _, [(ps, _); (a, _); _t]) when S.fv_eq_lid fv fstar_tactics_Success.lid -> + BU.bind_opt (NBETerm.unembed ea cb a) (fun a -> + BU.bind_opt (NBETerm.unembed e_proofstate_nbe cb ps) (fun ps -> + Some (Success (a, ps)))) + + | NBETerm.Construct (fv, _, [(ps, _); (e, _); _t]) when S.fv_eq_lid fv fstar_tactics_Failed.lid -> + BU.bind_opt (NBETerm.unembed e_exn_nbe cb e) (fun e -> + BU.bind_opt (NBETerm.unembed e_proofstate_nbe cb ps) (fun ps -> + Some (Failed (e, ps)))) + | _ -> + None + in + { NBETerm.em = embed_result + ; NBETerm.un = unembed_result + ; NBETerm.typ = (fun () -> mkFV fstar_tactics_result.fv [] []) + ; NBETerm.e_typ = (fun () -> fv_as_emb_typ fstar_tactics_result.fv) } + +let e_direction = + let embed_direction (rng:Range.range) (d : direction) : term = + match d with + | TopDown -> fstar_tactics_topdown.t + | BottomUp -> fstar_tactics_bottomup.t + in + let unembed_direction (t : term) : option direction = + match (SS.compress t).n with + | Tm_fvar fv when S.fv_eq_lid fv fstar_tactics_topdown.lid -> Some TopDown + | Tm_fvar fv when S.fv_eq_lid fv fstar_tactics_bottomup.lid -> Some BottomUp + | _ -> None + in + mk_emb embed_direction unembed_direction fstar_tactics_direction.t + +let e_direction_nbe = + let embed_direction cb (res:direction) : NBET.t = + match res with + | TopDown -> mkConstruct fstar_tactics_topdown.fv [] [] + | BottomUp -> mkConstruct fstar_tactics_bottomup.fv [] [] + in + let unembed_direction cb (t:NBET.t) : option direction = + match NBETerm.nbe_t_of_t t with + | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tactics_topdown.lid -> Some TopDown + | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tactics_bottomup.lid -> Some BottomUp + | _ -> + if !Options.debug_embedding then + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded direction: %s" (NBETerm.t_to_string t)); + None + in + { NBETerm.em = embed_direction + ; NBETerm.un = unembed_direction + ; NBETerm.typ = (fun () ->mkFV fstar_tactics_direction.fv [] []) + ; NBETerm.e_typ = (fun () -> fv_as_emb_typ fstar_tactics_direction.fv) } + +let e_ctrl_flag = + let embed_ctrl_flag (rng:Range.range) (d : ctrl_flag) : term = + match d with + | Continue -> fstar_tactics_Continue.t + | Skip -> fstar_tactics_Skip.t + | Abort -> fstar_tactics_Abort.t + in + let unembed_ctrl_flag (t : term) : option ctrl_flag = + match (SS.compress t).n with + | Tm_fvar fv when S.fv_eq_lid fv fstar_tactics_Continue.lid -> Some Continue + | Tm_fvar fv when S.fv_eq_lid fv fstar_tactics_Skip.lid -> Some Skip + | Tm_fvar fv when S.fv_eq_lid fv fstar_tactics_Abort.lid -> Some Abort + | _ -> None + in + mk_emb embed_ctrl_flag unembed_ctrl_flag fstar_tactics_ctrl_flag.t + +let e_ctrl_flag_nbe = + let embed_ctrl_flag cb (res:ctrl_flag) : NBET.t = + match res with + | Continue -> mkConstruct fstar_tactics_Continue.fv [] [] + | Skip -> mkConstruct fstar_tactics_Skip.fv [] [] + | Abort -> mkConstruct fstar_tactics_Abort.fv [] [] + in + let unembed_ctrl_flag cb (t:NBET.t) : option ctrl_flag = + match NBETerm.nbe_t_of_t t with + | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tactics_Continue.lid -> Some Continue + | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tactics_Skip.lid -> Some Skip + | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tactics_Abort.lid -> Some Abort + | _ -> + if !Options.debug_embedding then + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded ctrl_flag: %s" (NBETerm.t_to_string t)); + None + in + { NBETerm.em = embed_ctrl_flag + ; NBETerm.un = unembed_ctrl_flag + ; NBETerm.typ = (fun () -> mkFV fstar_tactics_ctrl_flag.fv [] []) + ; NBETerm.e_typ = (fun () -> fv_as_emb_typ fstar_tactics_ctrl_flag.fv) } + +let e_unfold_side = + let open FStarC.TypeChecker.Core in + let embed_unfold_side (rng:Range.range) (s:side) : term = + match s with + | Left -> fstar_tc_core_unfold_side_Left.t + | Right -> fstar_tc_core_unfold_side_Right.t + | Both -> fstar_tc_core_unfold_side_Both.t + | Neither -> fstar_tc_core_unfold_side_Neither.t + in + let unembed_unfold_side (t : term) : option side = + match (SS.compress t).n with + | Tm_fvar fv when S.fv_eq_lid fv fstar_tc_core_unfold_side_Left.lid -> Some Left + | Tm_fvar fv when S.fv_eq_lid fv fstar_tc_core_unfold_side_Right.lid -> Some Right + | Tm_fvar fv when S.fv_eq_lid fv fstar_tc_core_unfold_side_Both.lid -> Some Both + | Tm_fvar fv when S.fv_eq_lid fv fstar_tc_core_unfold_side_Neither.lid -> Some Neither + | _ -> + None + in + mk_emb embed_unfold_side unembed_unfold_side fstar_tc_core_unfold_side.t + +let e_unfold_side_nbe = + let open FStarC.TypeChecker.Core in + let embed_unfold_side cb (res:side) : NBET.t = + match res with + | Left -> mkConstruct fstar_tc_core_unfold_side_Left.fv [] [] + | Right -> mkConstruct fstar_tc_core_unfold_side_Right.fv [] [] + | Both -> mkConstruct fstar_tc_core_unfold_side_Both.fv [] [] + | Neither -> mkConstruct fstar_tc_core_unfold_side_Neither.fv [] [] + in + let unembed_unfold_side cb (t:NBET.t) : option side = + match NBETerm.nbe_t_of_t t with + | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tc_core_unfold_side_Left.lid -> + Some Left + | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tc_core_unfold_side_Right.lid -> + Some Right + | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tc_core_unfold_side_Both.lid -> + Some Both + | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tc_core_unfold_side_Neither.lid -> + Some Neither + | _ -> + if !Options.debug_embedding then + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded unfold_side: %s" (NBETerm.t_to_string t)); + None + in + { NBETerm.em = embed_unfold_side + ; NBETerm.un = unembed_unfold_side + ; NBETerm.typ = (fun () -> mkFV fstar_tc_core_unfold_side.fv [] []) + ; NBETerm.e_typ = (fun () -> fv_as_emb_typ fstar_tc_core_unfold_side.fv) } + +let e_tot_or_ghost = + let open FStarC.TypeChecker.Core in + let embed_tot_or_ghost (rng:Range.range) (s:tot_or_ghost) : term = + match s with + | E_Total -> fstar_tc_core_tot_or_ghost_ETotal.t + | E_Ghost -> fstar_tc_core_tot_or_ghost_EGhost.t + in + let unembed_tot_or_ghost (t : term) : option tot_or_ghost = + match (SS.compress t).n with + | Tm_fvar fv when S.fv_eq_lid fv fstar_tc_core_tot_or_ghost_ETotal.lid -> + Some E_Total + | Tm_fvar fv when S.fv_eq_lid fv fstar_tc_core_tot_or_ghost_EGhost.lid -> + Some E_Ghost + | _ -> None + in + mk_emb embed_tot_or_ghost unembed_tot_or_ghost fstar_tc_core_tot_or_ghost.t + +let e_tot_or_ghost_nbe = + let open FStarC.TypeChecker.Core in + let embed_tot_or_ghost cb (res:tot_or_ghost) : NBET.t = + match res with + | E_Total -> mkConstruct fstar_tc_core_tot_or_ghost_ETotal.fv [] [] + | E_Ghost -> mkConstruct fstar_tc_core_tot_or_ghost_EGhost.fv [] [] + in + let unembed_tot_or_ghost cb (t:NBET.t) : option tot_or_ghost = + match NBETerm.nbe_t_of_t t with + | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tc_core_tot_or_ghost_ETotal.lid -> + Some E_Total + | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tc_core_tot_or_ghost_EGhost.lid -> + Some E_Ghost + | _ -> + if !Options.debug_embedding then + Err.log_issue0 Err.Warning_NotEmbedded (BU.format1 "Not an embedded tot_or_ghost: %s" (NBETerm.t_to_string t)); + None + in + { NBETerm.em = embed_tot_or_ghost + ; NBETerm.un = unembed_tot_or_ghost + ; NBETerm.typ = (fun () -> mkFV fstar_tc_core_tot_or_ghost.fv [] []) + ; NBETerm.e_typ = (fun () -> fv_as_emb_typ fstar_tc_core_tot_or_ghost.fv) } + +let t_tref = S.lid_as_fv PC.tref_lid None + |> S.fv_to_tm + |> (fun tm -> S.mk_Tm_uinst tm [U_zero]) + |> (fun head -> S.mk_Tm_app head [S.iarg S.t_term] Range.dummyRange) + +let e_tref #a = + let em (r:tref a) (rng:Range.range) _shadow _norm : term = + U.mk_lazy r t_tref Lazy_tref (Some rng) + in + let un (t:term) _ : option (tref a) = + match (SS.compress t).n with + | Tm_lazy { lkind = Lazy_tref; blob } -> Some (Dyn.undyn blob) + | _ -> None + in + mk_emb_full + em + un + (fun () -> t_tref) + (fun i -> "tref") + (fun () -> ET_app (PC.tref_lid |> Ident.string_of_lid, [ET_abstract])) + +let e_tref_nbe #a = + let embed_tref _cb (r:tref a) : NBETerm.t = + let li = { lkind = Lazy_tref + ; blob = FStarC.Dyn.mkdyn r + ; ltyp = t_tref + ; rng = Range.dummyRange } + in + let thunk = Thunk.mk (fun () -> NBETerm.mk_t <| NBETerm.Constant (NBETerm.String ("(((tref.nbe)))", Range.dummyRange))) in + NBETerm.mk_t (NBETerm.Lazy (Inl li, thunk)) + in + let unembed_tref _cb (t:NBETerm.t) : option (tref a) = + match NBETerm.nbe_t_of_t t with + | NBETerm.Lazy (Inl {blob=b; lkind = Lazy_tref}, _) -> + Some <| FStarC.Dyn.undyn b + | _ -> + if !Options.debug_embedding then + Err.log_issue0 + Err.Warning_NotEmbedded + (BU.format1 "Not an embedded NBE tref: %s\n" + (NBETerm.t_to_string t)); + None + in + { NBETerm.em = embed_tref + ; NBETerm.un = unembed_tref + ; NBETerm.typ = + (fun () -> + let term_t = mkFV (S.lid_as_fv PC.fstar_syntax_syntax_term None) [] [] in + mkFV (S.lid_as_fv PC.tref_lid None) [U_zero] [NBETerm.as_arg term_t]) + ; NBETerm.e_typ = (fun () -> ET_app (PC.tref_lid |> Ident.string_of_lid, [ET_abstract])) } + +let e_guard_policy = + let embed_guard_policy (rng:Range.range) (p : guard_policy) : term = + match p with + | SMT -> fstar_tactics_SMT.t + | SMTSync -> fstar_tactics_SMTSync.t + | Goal -> fstar_tactics_Goal.t + | Force -> fstar_tactics_Force.t + | Drop -> fstar_tactics_Drop.t + in + let unembed_guard_policy (t : term) : option guard_policy = + match (SS.compress t).n with + | Tm_fvar fv when S.fv_eq_lid fv fstar_tactics_SMT.lid -> Some SMT + | Tm_fvar fv when S.fv_eq_lid fv fstar_tactics_SMTSync.lid -> Some SMTSync + | Tm_fvar fv when S.fv_eq_lid fv fstar_tactics_Goal.lid -> Some Goal + | Tm_fvar fv when S.fv_eq_lid fv fstar_tactics_Force.lid -> Some Force + | Tm_fvar fv when S.fv_eq_lid fv fstar_tactics_Drop.lid -> Some Drop + | _ -> None + in + mk_emb embed_guard_policy unembed_guard_policy fstar_tactics_guard_policy.t + +let e_guard_policy_nbe = + let embed_guard_policy cb (p:guard_policy) : NBET.t = + match p with + | SMT -> mkConstruct fstar_tactics_SMT.fv [] [] + | SMTSync -> mkConstruct fstar_tactics_SMTSync.fv [] [] + | Goal -> mkConstruct fstar_tactics_Goal.fv [] [] + | Force -> mkConstruct fstar_tactics_Force.fv [] [] + | Drop -> mkConstruct fstar_tactics_Drop.fv [] [] + in + let unembed_guard_policy cb (t:NBET.t) : option guard_policy = + match NBETerm.nbe_t_of_t t with + | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tactics_SMT.lid -> Some SMT + | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tactics_SMTSync.lid -> Some SMTSync + | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tactics_Goal.lid -> Some Goal + | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tactics_Force.lid -> Some Force + | NBETerm.Construct (fv, _, []) when S.fv_eq_lid fv fstar_tactics_Drop.lid -> Some Drop + | _ -> None + in + { NBETerm.em = embed_guard_policy + ; NBETerm.un = unembed_guard_policy + ; NBETerm.typ = (fun () -> mkFV fstar_tactics_guard_policy.fv [] []) + ; NBETerm.e_typ = (fun () -> fv_as_emb_typ fstar_tactics_guard_policy.fv) } diff --git a/src/tactics/FStarC.Tactics.Embedding.fsti b/src/tactics/FStarC.Tactics.Embedding.fsti new file mode 100644 index 00000000000..a3f42e49053 --- /dev/null +++ b/src/tactics/FStarC.Tactics.Embedding.fsti @@ -0,0 +1,52 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Tactics.Embedding + +open FStarC.Ident +open FStarC.Syntax.Syntax +open FStarC.Syntax.Embeddings +open FStarC.Tactics.Types +open FStarC.Tactics.Result + +module Core = FStarC.TypeChecker.Core + +module NBETerm = FStarC.TypeChecker.NBETerm + +instance val e_exn : embedding exn +instance val e_proofstate : embedding proofstate +instance val e_goal : embedding goal +instance val e_result : embedding 'a -> Tot (embedding (__result 'a)) +instance val e_direction : embedding direction +instance val e_ctrl_flag : embedding ctrl_flag +instance val e_guard_policy : embedding guard_policy +instance val e_unfold_side : embedding Core.side +instance val e_tot_or_ghost : embedding Core.tot_or_ghost +instance val e_tref (#a:Type) : Tot (embedding (tref a)) + +instance val e_exn_nbe : NBETerm.embedding exn +instance val e_proofstate_nbe : NBETerm.embedding proofstate +instance val e_goal_nbe : NBETerm.embedding goal +instance val e_result_nbe : NBETerm.embedding 'a -> Tot (NBETerm.embedding (__result 'a)) +instance val e_direction_nbe : NBETerm.embedding direction +instance val e_ctrl_flag_nbe : NBETerm.embedding ctrl_flag +instance val e_guard_policy_nbe : NBETerm.embedding guard_policy +instance val e_unfold_side_nbe : NBETerm.embedding Core.side +instance val e_tot_or_ghost_nbe : NBETerm.embedding Core.tot_or_ghost +instance val e_tref_nbe (#a:Type) : Tot (NBETerm.embedding (tref a)) + +val unfold_lazy_proofstate : lazyinfo -> term +val unfold_lazy_goal : lazyinfo -> term diff --git a/src/tactics/FStarC.Tactics.Hooks.fst b/src/tactics/FStarC.Tactics.Hooks.fst new file mode 100644 index 00000000000..3c995f7beee --- /dev/null +++ b/src/tactics/FStarC.Tactics.Hooks.fst @@ -0,0 +1,1029 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Tactics.Hooks + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Compiler.Util +open FStarC.Compiler.Range +open FStarC.Syntax.Syntax +open FStarC.Syntax.Embeddings +open FStarC.TypeChecker.Env +open FStarC.TypeChecker.Common +open FStarC.Tactics.Types +open FStarC.Tactics.Interpreter +open FStarC.Class.Show +module Listlike = FStarC.Class.Listlike + +module BU = FStarC.Compiler.Util +module Range = FStarC.Compiler.Range +module Err = FStarC.Errors +module O = FStarC.Options +module PC = FStarC.Parser.Const +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module U = FStarC.Syntax.Util +module Print = FStarC.Syntax.Print +module N = FStarC.TypeChecker.Normalize +module Env = FStarC.TypeChecker.Env +module TcUtil = FStarC.TypeChecker.Util +module TcRel = FStarC.TypeChecker.Rel +module TcTerm = FStarC.TypeChecker.TcTerm +module TEQ = FStarC.TypeChecker.TermEqAndSimplify + +(* We only use the _abstract_ embeddings from this module, +hence there is no v1/v2 distinction. *) +module RE = FStarC.Reflection.V2.Embeddings + +let dbg_Tac = Debug.get_toggle "Tac" +let dbg_SpinoffAll = Debug.get_toggle "SpinoffAll" + +let run_tactic_on_typ + (rng_tac : Range.range) (rng_goal : Range.range) + (tactic:term) (env:Env.env) (typ:term) + : list goal // remaining goals + & term // witness + = + let rng = range_of_rng (use_range rng_tac) (use_range rng_goal) in + let ps, w = FStarC.Tactics.V2.Basic.proofstate_of_goal_ty rng env typ in + let tactic_already_typed = false in + let gs, _res = run_tactic_on_ps rng_tac rng_goal false e_unit () e_unit tactic tactic_already_typed ps in + gs, w + +let run_tactic_on_all_implicits + (rng_tac : Range.range) (rng_goal : Range.range) + (tactic:term) (env:Env.env) (imps:Env.implicits) + : list goal // remaining goals + = + let ps, _ = FStarC.Tactics.V2.Basic.proofstate_of_all_implicits rng_goal env imps in + let tactic_already_typed = false in + let goals, () = + run_tactic_on_ps + (Env.get_range env) + rng_goal + true + e_unit + () + e_unit + tactic + tactic_already_typed + ps + in + goals + +// Polarity +type pol = + | StrictlyPositive + | Pos + | Neg + | Both // traversing both polarities at once + +// Result of traversal +type tres_m 'a = + | Unchanged of 'a + | Simplified of 'a & list goal + | Dual of 'a & 'a & list goal + +type tres = tres_m term + +let tpure x = Unchanged x + +let flip p = match p with + | StrictlyPositive -> Neg + | Pos -> Neg + | Neg -> Pos + | Both -> Both + +let getprop (e:Env.env) (t:term) : option term = + let tn = N.normalize [Env.Weak; Env.HNF; Env.UnfoldUntil delta_constant] e t in + U.un_squash tn + +let by_tactic_interp (pol:pol) (e:Env.env) (t:term) : tres = + let hd, args = U.head_and_args t in + match (U.un_uinst hd).n, args with + + // with_tactic marker + | Tm_fvar fv, [(tactic, None); (assertion, None)] + when S.fv_eq_lid fv PC.by_tactic_lid -> + begin match pol with + | StrictlyPositive + | Pos -> + let gs, _ = run_tactic_on_typ tactic.pos assertion.pos tactic e assertion in + Simplified (FStarC.Syntax.Util.t_true, gs) + + | Both -> + let gs, _ = run_tactic_on_typ tactic.pos assertion.pos tactic e assertion in + Dual (assertion, FStarC.Syntax.Util.t_true, gs) + + | Neg -> + // Peel away tactics in negative positions, they're assumptions! + Simplified (assertion, []) + end + + // spinoff marker: simply spin off a query independently. + // So, equivalent to `with_tactic idtac` without importing the (somewhat heavy) tactics module + | Tm_fvar fv, [(assertion, None)] + when S.fv_eq_lid fv PC.spinoff_lid -> + begin match pol with + | StrictlyPositive + | Pos -> + let g = fst <| goal_of_goal_ty e assertion in + let g = set_label "spun-off assertion" g in + Simplified (FStarC.Syntax.Util.t_true, [g]) + + | Both -> + let g = fst <| goal_of_goal_ty e assertion in + let g = set_label "spun-off assertion" g in + Dual (assertion, FStarC.Syntax.Util.t_true, [g]) + + | Neg -> + Simplified (assertion, []) + end + + // rewrite_with_tactic marker + | Tm_fvar fv, [(tactic, None); (typ, Some ({ aqual_implicit = true } )); (tm, None)] + when S.fv_eq_lid fv PC.rewrite_by_tactic_lid -> + + // Create a new uvar that must be equal to the initial term + let uvtm, _, g_imp = Env.new_implicit_var_aux "rewrite_with_tactic RHS" tm.pos e typ Strict None false in + + let u = e.universe_of e typ in + // eq2 is squashed already, so it's in Type0 + let goal = U.mk_squash U_zero (U.mk_eq2 u typ tm uvtm) in + let gs, _ = run_tactic_on_typ tactic.pos tm.pos tactic e goal in + + // abort if the uvar was not solved + let tagged_imps = TcRel.resolve_implicits_tac e g_imp in + report_implicits tm.pos tagged_imps; + + // If the rewriting succeeded, we return the generated uvar, which is now + // a synthesized term. Any unsolved goals (gs) are spun off. + Simplified (uvtm, gs) + + | _ -> + Unchanged t + +let explode (t : tres_m 'a) : 'a & 'a & list goal = + match t with + | Unchanged t -> (t, t, []) + | Simplified (t, gs) -> (t, t, gs) + | Dual (tn, tp, gs) -> (tn, tp, gs) + +let comb1 (f : 'a -> 'b) : tres_m 'a -> tres_m 'b = function + | Unchanged t -> Unchanged (f t) + | Simplified (t, gs) -> Simplified (f t, gs) + | Dual (tn, tp, gs) -> Dual (f tn, f tp, gs) + +let comb2 (f : 'a -> 'b -> 'c ) (x : tres_m 'a) (y : tres_m 'b) : tres_m 'c = + match x, y with + | Unchanged t1, Unchanged t2 -> + Unchanged (f t1 t2) + + | Unchanged t1, Simplified (t2, gs) + | Simplified (t1, gs), Unchanged t2 -> + Simplified (f t1 t2, gs) + + | Simplified (t1, gs1), Simplified (t2, gs2) -> + Simplified (f t1 t2, gs1@gs2) + + | _ -> + let (n1, p1, gs1) = explode x in + let (n2, p2, gs2) = explode y in + Dual (f n1 n2, f p1 p2, gs1@gs2) + +let comb_list (rs : list (tres_m 'a)) : tres_m (list 'a) = + let rec aux rs acc = + match rs with + | [] -> acc + | hd::tl -> aux tl (comb2 (fun l r -> l::r) hd acc) + in + aux (List.rev rs) (tpure []) + +let emit (gs : list goal) (m : tres_m 'a) : tres_m 'a = + comb2 (fun () x -> x) (Simplified ((), gs)) m + +let rec traverse (f: pol -> Env.env -> term -> tres) (pol:pol) (e:Env.env) (t:term) : tres = + let r = + match (SS.compress t).n with + | Tm_uinst (t,us) -> let tr = traverse f pol e t in + comb1 (fun t' -> Tm_uinst (t', us)) tr + + | Tm_meta {tm=t; meta=m} -> let tr = traverse f pol e t in + comb1 (fun t' -> Tm_meta {tm=t'; meta=m}) tr + + | Tm_app {hd={ n = Tm_fvar fv }; args=[(p,_); (q,_)]} when S.fv_eq_lid fv PC.imp_lid -> + // ==> is specialized to U_zero + let x = S.new_bv None p in + let r1 = traverse f (flip pol) e p in + let r2 = traverse f pol (Env.push_bv e x) q in + comb2 (fun l r -> (U.mk_imp l r).n) r1 r2 + + (* p <==> q is special, each side is bipolar *) + (* So we traverse its arguments with pol = Both, and negative and positive versions *) + (* of p and q *) + (* then we return (in general) (p- ==> q+) /\ (q- ==> p+) *) + (* But if neither side ran tactics, we just keep p <==> q *) + | Tm_app {hd={ n = Tm_fvar fv }; args=[(p,_); (q,_)]} when S.fv_eq_lid fv PC.iff_lid -> + // <==> is specialized to U_zero + let xp = S.new_bv None p in + let xq = S.new_bv None q in + let r1 = traverse f Both (Env.push_bv e xq) p in + let r2 = traverse f Both (Env.push_bv e xp) q in + // Should be flipping the tres, I think + begin match r1, r2 with + | Unchanged _, Unchanged _ -> + comb2 (fun l r -> (U.mk_iff l r).n) r1 r2 + | _ -> + let (pn, pp, gs1) = explode r1 in + let (qn, qp, gs2) = explode r2 in + let t = U.mk_conj (U.mk_imp pn qp) (U.mk_imp qn pp) in + Simplified (t.n, gs1@gs2) + end + + | Tm_app {hd; args} -> + let r0 = traverse f pol e hd in + let r1 = List.fold_right (fun (a, q) r -> + let r' = traverse f pol e a in + comb2 (fun a args -> (a, q)::args) r' r) + args (tpure []) in + comb2 (fun hd args -> Tm_app {hd; args}) r0 r1 + + | Tm_abs {bs; body=t; rc_opt=k} -> + // TODO: traverse k? + let bs, topen = SS.open_term bs t in + let e' = Env.push_binders e bs in + let r0 = List.map (fun b -> + let r = traverse f (flip pol) e b.binder_bv.sort in + comb1 (fun s' -> ({b with binder_bv={ b.binder_bv with sort = s' }})) r + ) bs + in + let rbs = comb_list r0 in + let rt = traverse f pol e' topen in + comb2 (fun bs t -> (U.abs bs t k).n) rbs rt + + | Tm_ascribed {tm=t;asc;eff_opt=ef} -> + // TODO: traverse the types? + comb1 (fun t -> Tm_ascribed {tm=t; asc; eff_opt=ef}) (traverse f pol e t) + + | Tm_match {scrutinee=sc; ret_opt=asc_opt; brs; rc_opt=lopt} -> //AR: not traversing the return annotation + comb2 (fun sc brs -> Tm_match {scrutinee=sc; ret_opt=asc_opt; brs; rc_opt=lopt}) + (traverse f pol e sc) + (comb_list (List.map (fun br -> let (pat, w, exp) = SS.open_branch br in + let bvs = S.pat_bvs pat in + let e = Env.push_bvs e bvs in + let r = traverse f pol e exp in + comb1 (fun exp -> SS.close_branch (pat, w, exp)) r) brs)) + + | x -> + tpure x in + match r with + | Unchanged tn' -> + f pol e ({ t with n = tn' }) + + | Simplified (tn', gs) -> + emit gs (f pol e ({ t with n = tn' })) + + | Dual (tn, tp, gs) -> + let rp = f pol e ({ t with n = tp }) in + let (_, p', gs') = explode rp in + Dual ({t with n = tn}, p', gs@gs') + +let preprocess (env:Env.env) (goal:term) + : bool & list (Env.env & term & O.optionstate) + (* bool=true iff any tactic actually ran *) += + Errors.with_ctx "While preprocessing VC with a tactic" (fun () -> + if !dbg_Tac then + BU.print2 "About to preprocess %s |= %s\n" + (show <| Env.all_binders env) + (show goal); + let initial = (1, []) in + // This match should never fail + let did_anything, (t', gs) = + match traverse by_tactic_interp Pos env goal with + | Unchanged t' -> false, (t', []) + | Simplified (t', gs) -> true, (t', gs) + | _ -> failwith "preprocess: impossible, traverse returned a Dual" + in + if !dbg_Tac then + BU.print2 "Main goal simplified to: %s |- %s\n" + (show <| Env.all_binders env) + (show t'); + let s = initial in + let s = List.fold_left (fun (n,gs) g -> + let phi = match getprop (goal_env g) (goal_type g) with + | None -> + Err.raise_error env Err.Fatal_TacticProofRelevantGoal + (BU.format1 "Tactic returned proof-relevant goal: %s" (show (goal_type g))) + | Some phi -> phi + in + if !dbg_Tac then + BU.print2 "Got goal #%s: %s\n" (show n) (show (goal_type g)); + let label = + let open FStarC.Pprint in + let open FStarC.Class.PP in + [ + doc_of_string "Could not prove goal #" ^^ pp n ^/^ + (if get_label g = "" then empty else parens (doc_of_string <| get_label g)) + ] + in + let gt' = TcUtil.label label (goal_range g) phi in + (n+1, (goal_env g, gt', goal_opts g)::gs)) s gs in + let (_, gs) = s in + let gs = List.rev gs in (* Return new VCs in same order as goals *) + // Use default opts for main goal + did_anything, (env, t', O.peek ()) :: gs + ) + +let rec traverse_for_spinoff + (pol:pol) + (label_ctx:option (list Pprint.document & Range.range)) + (e:Env.env) + (t:term) : tres = + let debug_any = Debug.any () in + let traverse pol e t = traverse_for_spinoff pol label_ctx e t in + let traverse_ctx pol (ctx : list Pprint.document & Range.range) (e:Env.env) (t:term) : tres = + let print_lc (msg, rng) = + BU.format3 "(%s,%s) : %s" + (Range.string_of_def_range rng) + (Range.string_of_use_range rng) + (Errors.Msg.rendermsg msg) + in + if !dbg_SpinoffAll + then BU.print2 "Changing label context from %s to %s" + (match label_ctx with + | None -> "None" + | Some lc -> print_lc lc) + (print_lc ctx); + traverse_for_spinoff pol (Some ctx) e t + in + let should_descend (t:term) = + //descend only into the following connectives + let hd, args = U.head_and_args t in + let res = + match (U.un_uinst hd).n with + | Tm_fvar fv -> + S.fv_eq_lid fv PC.and_lid || + S.fv_eq_lid fv PC.imp_lid || + S.fv_eq_lid fv PC.forall_lid || + S.fv_eq_lid fv PC.auto_squash_lid || + S.fv_eq_lid fv PC.squash_lid + + | Tm_meta _ + | Tm_ascribed _ + | Tm_abs _ -> + true + + | _ -> + false + in + res + in + let maybe_spinoff pol + (label_ctx:option (list Pprint.document & Range.range)) + (e:Env.env) + (t:term) + : tres = + let label_goal (env, t) = + let t = + match (SS.compress t).n, label_ctx with + | Tm_meta {meta=Meta_labeled _}, _ -> t + | _, Some (msg, r) -> TcUtil.label msg r t + | _ -> t + in + let t = + if U.is_sub_singleton t + then t + else U.mk_auto_squash U_zero t + in + fst (goal_of_goal_ty env t) + in + let spinoff t = + match pol with + | StrictlyPositive -> + if !dbg_SpinoffAll then BU.print1 "Spinning off %s\n" (show t); + Simplified (FStarC.Syntax.Util.t_true, [label_goal (e,t)]) + + | _ -> + Unchanged t + in + let t = SS.compress t in + if not (should_descend t) + then spinoff t + else Unchanged t + in + let rewrite_boolean_conjunction t = + let hd, args = U.head_and_args t in + match (U.un_uinst hd).n, args with + | Tm_fvar fv, [(t, _)] + when S.fv_eq_lid fv PC.b2t_lid -> ( + let hd, args = U.head_and_args t in + match (U.un_uinst hd).n, args with + | Tm_fvar fv, [(t0, _); (t1, _)] + when S.fv_eq_lid fv PC.op_And -> + let t = U.mk_conj (U.b2t t0) (U.b2t t1) in + Some t + | _ -> + None + ) + | _ -> None + in + let try_rewrite_match env t = + let rec pat_as_exp env p = + match FStarC.TypeChecker.PatternUtils.raw_pat_as_exp env p with + | None -> None + | Some (e, _) -> + let env, _ = Env.clear_expected_typ env in + let e, lc = + FStarC.TypeChecker.TcTerm.tc_trivial_guard ({env with FStarC.TypeChecker.Env.admit=true}) e in + let u = + FStarC.TypeChecker.TcTerm.universe_of env lc.res_typ in + Some (e, lc.res_typ, u) + in + let bv_universes env bvs = + List.map (fun x -> x, FStarC.TypeChecker.TcTerm.universe_of env x.sort) bvs + in + let mk_forall_l bv_univs term = + List.fold_right + (fun (x,u) out -> U.mk_forall u x out) + bv_univs + term + in + let mk_exists_l bv_univs term = + List.fold_right + (fun (x,u) out -> U.mk_exists u x out) + bv_univs + term + in + if pol <> StrictlyPositive then None + else ( + match (SS.compress t).n with + | Tm_match {scrutinee=sc; ret_opt=asc_opt; brs; rc_opt=lopt} -> //AR: not traversing the return annotation + let rec rewrite_branches path_condition branches = + match branches with + | [] -> Inr (U.mk_imp path_condition U.t_false) + | br::branches -> + let pat, w, body = SS.open_branch br in + match w with + | Some _ -> + Inl "when clause" //don't handle when clauses + | _ -> + let bvs = S.pat_bvs pat in + let env = Env.push_bvs env bvs in + let bvs_univs = bv_universes env bvs in + match pat_as_exp env pat with + | None -> Inl "Ill-typed pattern" + | Some (p_e, t, u) -> + let eqn = U.mk_eq2 u t sc p_e in + let branch_goal = mk_forall_l bvs_univs (U.mk_imp eqn body) in + let branch_goal = U.mk_imp path_condition branch_goal in + let next_path_condition = U.mk_conj path_condition (U.mk_neg (mk_exists_l bvs_univs eqn)) in + match rewrite_branches next_path_condition branches with + | Inl msg -> Inl msg + | Inr rest -> Inr (U.mk_conj branch_goal rest) + in + let res = rewrite_branches U.t_true brs in + (match res with + | Inl msg -> + if debug_any + then FStarC.Errors.diag + (Env.get_range env) + (BU.format2 "Failed to split match term because %s (%s)" msg (show t)); + None + | Inr res -> + if debug_any + then FStarC.Errors.diag + (Env.get_range env) + (BU.format2 "Rewrote match term\n%s\ninto %s\n" + (show t) + (show res)); + + Some res) + | _ -> None + ) + in + let maybe_rewrite_term t = + if pol <> StrictlyPositive then None + else + match rewrite_boolean_conjunction t with + | Some t -> Some t + | None -> try_rewrite_match e t + in + match maybe_rewrite_term t with + | Some t -> + traverse pol e t + | _ -> + let r = + let t = SS.compress t in + if not (should_descend t) then tpure t.n + else begin + match t.n with + | Tm_uinst (t,us) -> + let tr = traverse pol e t in + comb1 (fun t' -> Tm_uinst (t', us)) tr + + | Tm_meta {tm=t; meta=Meta_labeled(msg, r, _)} -> + let tr = traverse_ctx pol (msg, r) e t in + comb1 (fun t' -> Tm_meta {tm=t'; meta=Meta_labeled(msg, r, false)}) tr + + | Tm_meta {tm=t; meta=m} -> + let tr = traverse pol e t in + comb1 (fun t' -> Tm_meta {tm=t'; meta=m}) tr + + | Tm_ascribed {tm=t; asc; eff_opt=ef} -> + // TODO: traverse the types? + comb1 (fun t -> Tm_ascribed {tm=t; asc; eff_opt=ef}) (traverse pol e t) + + | Tm_app {hd={ n = Tm_fvar fv }; args=[(p,_); (q,_)]} when S.fv_eq_lid fv PC.imp_lid -> + // ==> is specialized to U_zero + let x = S.new_bv None p in + let r1 = traverse (flip pol) e p in + let r2 = traverse pol (Env.push_bv e x) q in + comb2 (fun l r -> (U.mk_imp l r).n) r1 r2 + + | Tm_app {hd; args} -> + begin + match (U.un_uinst hd).n, args with + | Tm_fvar fv, [(t, Some aq0); (body, aq)] + when (S.fv_eq_lid fv PC.forall_lid || + S.fv_eq_lid fv PC.exists_lid) && + aq0.aqual_implicit -> + let r0 = traverse pol e hd in + let rt = traverse (flip pol) e t in + let rbody = traverse pol e body in + let rargs = comb2 (fun t body -> [(t, Some aq0); (body, aq)]) rt rbody in + comb2 (fun hd args -> Tm_app {hd; args}) r0 rargs + + | _ -> + let r0 = traverse pol e hd in + let r1 = + List.fold_right + (fun (a, q) r -> + let r' = traverse pol e a in + comb2 (fun a args -> (a, q)::args) r' r) + args + (tpure []) + in + let simplified = Simplified? r0 || Simplified? r1 in + comb2 + (fun hd args -> + match (U.un_uinst hd).n, args with + | Tm_fvar fv, [(t, _)] + when simplified && + S.fv_eq_lid fv PC.squash_lid && + TEQ.eq_tm e t U.t_true = TEQ.Equal -> + //simplify squash True to True + //important for simplifying queries to Trivial + if !dbg_SpinoffAll then BU.print_string "Simplified squash True to True"; + U.t_true.n + + | _ -> + let t' = Tm_app {hd; args} in + t') + r0 r1 + end + + | Tm_abs {bs; body=t; rc_opt=k} -> + // TODO: traverse k? + let bs, topen = SS.open_term bs t in + let e' = Env.push_binders e bs in + let r0 = List.map (fun b -> + let r = traverse (flip pol) e b.binder_bv.sort in + comb1 (fun s' -> ({b with binder_bv={ b.binder_bv with sort = s' }})) r + ) bs + in + let rbs = comb_list r0 in + let rt = traverse pol e' topen in + comb2 (fun bs t -> (U.abs bs t k).n) rbs rt + + | x -> + tpure x + end + in + match r with + | Unchanged tn' -> + maybe_spinoff pol label_ctx e ({ t with n = tn' }) + + | Simplified (tn', gs) -> + emit gs (maybe_spinoff pol label_ctx e ({ t with n = tn' })) + + | Dual (tn, tp, gs) -> + let rp = maybe_spinoff pol label_ctx e ({ t with n = tp }) in + let (_, p', gs') = explode rp in + Dual ({t with n = tn}, p', gs@gs') + +let pol_to_string = function + | StrictlyPositive -> "StrictlyPositive" + | Pos -> "Positive" + | Neg -> "Negative" + | Both -> "Both" + +let spinoff_strictly_positive_goals (env:Env.env) (goal:term) + : list (Env.env & term) + = if !dbg_SpinoffAll then BU.print1 "spinoff_all called with %s\n" (show goal); + Errors.with_ctx "While spinning off all goals" (fun () -> + let initial = (1, []) in + // This match should never fail + let (t', gs) = + match traverse_for_spinoff StrictlyPositive None env goal with + | Unchanged t' -> (t', []) + | Simplified (t', gs) -> (t', gs) + | _ -> failwith "preprocess: impossible, traverse returned a Dual" + in + let t' = + N.normalize [Env.Eager_unfolding; Env.Simplify; Env.Primops] env t' + in + let main_goal = + let t = FStarC.TypeChecker.Common.check_trivial t' in + match t with + | Trivial -> [] + | NonTrivial t -> + if !dbg_SpinoffAll + then ( + let msg = BU.format2 "Main goal simplified to: %s |- %s\n" + (show <| Env.all_binders env) + (show t) in + FStarC.Errors.diag + (Env.get_range env) + (BU.format1 + "Verification condition was to be split into several atomic sub-goals, \ + but this query had some sub-goals that couldn't be split---the error report, if any, may be \ + inaccurate.\n%s\n" + msg) + ); + [(env, t)] + in + let s = initial in + let s = + List.fold_left + (fun (n,gs) g -> + let phi = goal_type g in + (n+1, (goal_env g, phi)::gs)) + s + gs + in + let (_, gs) = s in + let gs = List.rev gs in (* Return new VCs in same order as goals *) + let gs = + gs |> + List.filter_map + (fun (env, t) -> + let t = N.normalize [Env.Eager_unfolding; Env.Simplify; Env.Primops] env t in + match FStarC.TypeChecker.Common.check_trivial t with + | Trivial -> None + | NonTrivial t -> + if !dbg_SpinoffAll + then BU.print1 "Got goal: %s\n" (show t); + Some (env, t)) + in + + FStarC.Errors.diag (Env.get_range env) + (BU.format1 "Split query into %s sub-goals" (show (List.length gs))); + + main_goal@gs + ) + + +let synthesize (env:Env.env) (typ:typ) (tau:term) : term = + Errors.with_ctx "While synthesizing term with a tactic" (fun () -> + // Don't run the tactic (and end with a magic) when flychecking is set, cf. issue #73 in fstar-mode.el + if env.flychecking + then mk_Tm_app (TcUtil.fvar_env env PC.magic_lid) [S.as_arg U.exp_unit] typ.pos + else begin + + let gs, w = run_tactic_on_typ tau.pos typ.pos tau env typ in + // Check that all goals left are irrelevant and provable + // TODO: It would be nicer to combine all of these into a guard and return + // that to TcTerm, but the varying environments make it awkward. + gs |> List.iter (fun g -> + match getprop (goal_env g) (goal_type g) with + | Some vc -> + begin + if !dbg_Tac then + BU.print1 "Synthesis left a goal: %s\n" (show vc); + let guard = guard_of_guard_formula (NonTrivial vc) in + TcRel.force_trivial_guard (goal_env g) guard + end + | None -> + Err.raise_error typ Err.Fatal_OpenGoalsInSynthesis "synthesis left open goals"); + w + end + ) + +let solve_implicits (env:Env.env) (tau:term) (imps:Env.implicits) : unit = + Errors.with_ctx "While solving implicits with a tactic" (fun () -> + if env.flychecking then () else + begin + + let gs = run_tactic_on_all_implicits tau.pos (Env.get_range env) tau env imps in + // Check that all goals left are irrelevant and provable + // TODO: It would be nicer to combine all of these into a guard and return + // that to TcTerm, but the varying environments make it awkward. + if Options.profile_enabled None "FStarC.TypeChecker" + then BU.print1 "solve_implicits produced %s goals\n" (show (List.length gs)); + + Options.with_saved_options (fun () -> + let _ = Options.set_options "--no_tactics" in + gs |> List.iter (fun g -> + Options.set (goal_opts g); + match getprop (goal_env g) (goal_type g) with + | Some vc -> + begin + if !dbg_Tac then + BU.print1 "Synthesis left a goal: %s\n" (show vc); + if not env.admit + then ( + let guard = guard_of_guard_formula (NonTrivial vc) in + Profiling.profile (fun () -> + TcRel.force_trivial_guard (goal_env g) guard) + None + "FStarC.TypeChecker.Hooks.force_trivial_guard" + ) + end + | None -> + Err.raise_error env Err.Fatal_OpenGoalsInSynthesis "synthesis left open goals" + )) + end + ) + +(* Retrieves a tactic associated to a given attribute, if any *) +let find_user_tac_for_attr env (a:term) : option sigelt = + let hooks = Env.lookup_attr env PC.handle_smt_goals_attr_string in + hooks |> BU.try_find (fun _ -> true) + +(* This function takes an environment [env] and a goal [goal], and tries to run + the tactic registered with the (handle_smt_goal) attribute, if any. + If such a tactic exists, all the unresolved goals must be propositions, + that will be directly encoded to SMT inside Rel.discharge_guard. + If such a tactic does not exist, this function is a no-op. *) +let handle_smt_goal env goal = + match check_trivial goal with + (* No need to pass the term to the tactic if trivial *) + | Trivial -> [env, goal] + | NonTrivial goal -> + (* Attempt to retrieve a tactic corresponding to the (handle_smt_goals) attribute *) + match find_user_tac_for_attr env (S.tconst PC.handle_smt_goals_attr) with + | Some tac -> + (* There is a tactic registered with the handle_smt_goals attribute, + we retrieve the corresponding term *) + let tau = + match tac.sigel with + | Sig_let {lids=[lid]} -> + let qn = Env.lookup_qname env lid in + let fv = S.lid_as_fv lid None in + S.fv_to_tm (S.lid_as_fv lid None) + | _ -> failwith "Resolve_tac not found" + in + + let gs = Errors.with_ctx "While handling an SMT goal with a tactic" (fun () -> + + (* Executing the tactic on the goal. *) + let gs, _ = run_tactic_on_typ tau.pos (Env.get_range env) tau env (U.mk_squash U_zero goal) in + // Check that all goals left are irrelevant and provable + gs |> List.map (fun g -> + match getprop (goal_env g) (goal_type g) with + | Some vc -> + if !dbg_Tac then + BU.print1 "handle_smt_goals left a goal: %s\n" (show vc); + (goal_env g), vc + | None -> + Err.raise_error env Err.Fatal_OpenGoalsInSynthesis "Handling an SMT goal by tactic left non-prop open goals") + ) in + + gs + + (* No such tactic was available in the current context *) + | None -> [env, goal] + +// TODO: this is somehow needed for tcresolve to infer the embeddings in run_tactic_on_ps below +instance _ = RE.e_term + +type blob_t = option (string & term) +type dsl_typed_sigelt_t = bool & sigelt & blob_t +type dsl_tac_result_t = + list dsl_typed_sigelt_t & + dsl_typed_sigelt_t & + list dsl_typed_sigelt_t + +let splice + (env:Env.env) + (is_typed:bool) + (lids:list Ident.lident) + (tau:term) + (rng:Range.range) : list sigelt = + + Errors.with_ctx "While running splice with a tactic" (fun () -> + if env.flychecking then [] else begin + + let tau, _, g = + if is_typed + then TcTerm.tc_check_tot_or_gtot_term env tau U.t_dsl_tac_typ None + else TcTerm.tc_tactic t_unit S.t_decls env tau + in + + TcRel.force_trivial_guard env g; + + let ps = FStarC.Tactics.V2.Basic.proofstate_of_goals tau.pos env [] [] in + let tactic_already_typed = true in + let gs, sigelts = + if is_typed then + begin + // + // See if there is a val for the lid + // + if List.length lids > 1 + then Err.raise_error rng Errors.Error_BadSplice + (BU.format1 "Typed splice: unexpected lids length (> 1) (%s)" (show lids)) + else begin + let val_t : option typ = // val type, if any, for the lid + // + // For spliced vals, their lids is set to [] + // (see ToSyntax.fst:desugar_decl, splice case) + // + if List.length lids = 0 + then None + else + match Env.try_lookup_val_decl env (List.hd lids) with + | None -> None + | Some ((uvs, tval), _) -> + // + // No universe polymorphic typed splice yet + // + if List.length uvs <> 0 + then + Err.raise_error rng Errors.Error_BadSplice + (BU.format1 "Typed splice: val declaration for %s is universe polymorphic in %s universes, expected 0" + (show (List.length uvs))) + else Some tval in + + // + // The arguments to run_tactic_on_ps here are in sync with ulib/FStarC.Tactics.dsl_tac_t + // + let (gs, (sig_blobs_before, sig_blob, sig_blobs_after)) + : list goal & dsl_tac_result_t = + run_tactic_on_ps tau.pos tau.pos false + FStar.Tactics.Typeclasses.solve + ({env with admit=false; gamma=[]}, val_t) + FStar.Tactics.Typeclasses.solve + tau + tactic_already_typed + ps + in + let sig_blobs = sig_blobs_before@(sig_blob::sig_blobs_after) in + let sigelts = sig_blobs |> map (fun (checked, se, blob_opt) -> + { se with + sigmeta = { se.sigmeta with + sigmeta_extension_data = + (match blob_opt with + | Some (s, blob) -> [s, Dyn.mkdyn blob] + | None -> []); + sigmeta_already_checked = checked; } + } + ) + in + gs, sigelts + end + end + else run_tactic_on_ps tau.pos tau.pos false + e_unit () + (e_list RE.e_sigelt) tau tactic_already_typed ps + in + + // set delta depths in the sigelts fvs + let sigelts = + let set_lb_dd lb = + let {lbname=Inr fv; lbdef} = lb in + {lb with lbname=Inr fv} in + List.map (fun se -> + match se.sigel with + | Sig_let {lbs=(is_rec, lbs); lids} -> + {se with sigel=Sig_let {lbs=(is_rec, List.map set_lb_dd lbs); lids}} + | _ -> se + ) sigelts + in + + // Check that all goals left are irrelevant and solve them. + Options.with_saved_options (fun () -> + List.iter (fun g -> + Options.set (goal_opts g); + match getprop (goal_env g) (goal_type g) with + | Some vc -> + begin + if !dbg_Tac then + BU.print1 "Splice left a goal: %s\n" (show vc); + let guard = guard_of_guard_formula (NonTrivial vc) in + TcRel.force_trivial_guard (goal_env g) guard + end + | None -> + Err.raise_error rng Err.Fatal_OpenGoalsInSynthesis "splice left open goals") gs); + + let lids' = List.collect U.lids_of_sigelt sigelts in + List.iter (fun lid -> + match List.tryFind (Ident.lid_equals lid) lids' with + (* If env.flychecking is on, nothing will be generated, so don't raise an error + * so flycheck does spuriously not mark the line red *) + | None when not env.flychecking -> + Err.raise_error rng Errors.Fatal_SplicedUndef + (BU.format2 "Splice declared the name %s but it was not defined.\nThose defined were: %s" + (show lid) (show lids')) + | _ -> () + ) lids; + + if !dbg_Tac then + BU.print1 "splice: got decls = {\n\n%s\n\n}\n" (show sigelts); + + (* Check for bare Sig_datacon and Sig_inductive_typ, and abort if so. Also set range. *) + let sigelts = sigelts |> List.map (fun se -> + begin match se.sigel with + | Sig_datacon _ + | Sig_inductive_typ _ -> + let open FStarC.Pprint in + let open FStarC.Errors.Msg in + Err.raise_error rng Err.Error_BadSplice [ + text "Tactic returned bad sigelt:" ^/^ doc_of_string (Print.sigelt_to_string_short se); + text "If you wanted to splice an inductive type, call `pack` providing a `Sg_Inductive` to get a proper sigelt." + ] + | _ -> () + end; + { se with sigrng = rng }) + in + + (* Check there are no internal qualifiers *) + let () = + if is_typed then () + else + sigelts |> List.iter (fun se -> + se.sigquals |> List.iter (fun q -> + (* NOTE: Assumption is OK, a tactic can generate an axiom, but + * it will be reported with --report_assumes. *) + if is_internal_qualifier q then + let open FStarC.Errors.Msg in + let open FStarC.Pprint in + Err.raise_error rng Err.Error_InternalQualifier [ + text <| BU.format1 "The qualifier %s is internal." (show q); + prefix 2 1 (text "It cannot be attached to spliced declaration:") + (arbitrary_string (Print.sigelt_to_string_short se)); + ] + )) + in + sigelts + end + ) + +let mpreprocess (env:Env.env) (tau:term) (tm:term) : term = + Errors.with_ctx "While preprocessing a definition with a tactic" (fun () -> + if env.flychecking then tm else begin + let ps = FStarC.Tactics.V2.Basic.proofstate_of_goals tm.pos env [] [] in + let tactic_already_typed = false in + let gs, tm = run_tactic_on_ps tau.pos tm.pos false RE.e_term tm RE.e_term tau tactic_already_typed ps in + tm + end + ) + +let postprocess (env:Env.env) (tau:term) (typ:term) (tm:term) : term = + Errors.with_ctx "While postprocessing a definition with a tactic" (fun () -> + if env.flychecking then tm else begin + //we know that tm:typ + //and we have a goal that u == tm + //so if we solve that equality, we don't need to retype the solution of `u : typ` + let uvtm, _, g_imp = Env.new_implicit_var_aux "postprocess RHS" tm.pos env typ (Allow_untyped "postprocess") None false in + + let u = env.universe_of env typ in + // eq2 is squashed already, so it's in Type0 + let goal = U.mk_squash U_zero (U.mk_eq2 u typ tm uvtm) in + let gs, w = run_tactic_on_typ tau.pos tm.pos tau env goal in + // see comment in `synthesize` + List.iter (fun g -> + match getprop (goal_env g) (goal_type g) with + | Some vc -> + begin + if !dbg_Tac then + BU.print1 "Postprocessing left a goal: %s\n" (show vc); + let guard = guard_of_guard_formula (NonTrivial vc) in + TcRel.force_trivial_guard (goal_env g) guard + end + | None -> + Err.raise_error typ Err.Fatal_OpenGoalsInSynthesis "postprocessing left open goals") gs; + (* abort if the uvar was not solved *) + let tagged_imps = TcRel.resolve_implicits_tac env g_imp in + report_implicits tm.pos tagged_imps; + + uvtm + end + ) diff --git a/src/tactics/FStarC.Tactics.Hooks.fsti b/src/tactics/FStarC.Tactics.Hooks.fsti new file mode 100644 index 00000000000..4a2512010a2 --- /dev/null +++ b/src/tactics/FStarC.Tactics.Hooks.fsti @@ -0,0 +1,33 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Tactics.Hooks + +open FStarC +open FStarC.Syntax.Syntax +open FStarC.Compiler.Range + +module O = FStarC.Options +module Env = FStarC.TypeChecker.Env + +val preprocess : Env.env -> term -> bool & list (Env.env & term & O.optionstate) +val spinoff_strictly_positive_goals : Env.env -> term -> list (Env.env & term) +val handle_smt_goal : Env.env -> Env.goal -> list (Env.env & term) +val synthesize : Env.env -> typ -> term -> term +val solve_implicits : Env.env -> term -> Env.implicits -> unit +val splice : Env.env -> is_typed:bool -> list Ident.lident -> term -> range -> list sigelt +val mpreprocess : Env.env -> term -> term -> term +val postprocess : Env.env -> term -> typ -> term -> term diff --git a/src/tactics/FStarC.Tactics.InterpFuns.fst b/src/tactics/FStarC.Tactics.InterpFuns.fst new file mode 100644 index 00000000000..d868a1e03db --- /dev/null +++ b/src/tactics/FStarC.Tactics.InterpFuns.fst @@ -0,0 +1,3179 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Tactics.InterpFuns + +(* This module is awful, don't even look at it please. *) + +open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Syntax.Syntax +open FStarC.Compiler.Range + +open FStarC.Tactics.Types +open FStarC.Tactics.Result +open FStarC.Syntax.Embeddings +open FStarC.Tactics.Native +open FStarC.Tactics.Monad + +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module PC = FStarC.Parser.Const +module BU = FStarC.Compiler.Util +module Print = FStarC.Syntax.Print +module Cfg = FStarC.TypeChecker.Cfg +module E = FStarC.Tactics.Embedding +module NBETerm = FStarC.TypeChecker.NBETerm +module NBET = FStarC.TypeChecker.NBETerm +module PO = FStarC.TypeChecker.Primops + +let solve (#a:Type) {| ev : a |} : Tot a = ev + +(* This module does not use typeclasses *) +let embed (e:embedding 'a) rng (t:'a) n = FStarC.Syntax.Embeddings.embed #_ #e t rng None n +let unembed (e:embedding 'a) t n : option 'a = FStarC.Syntax.Embeddings.unembed #_ #e t n + +let interp_ctx s f = Errors.with_ctx ("While running primitive " ^ s) f + +let run_wrap (label : string) (t : tac 'a) ps : __result 'a = + interp_ctx label (fun () -> run_safe t ps) + +let builtin_lid nm = PC.fstar_stubs_tactics_lid' ["V2"; "Builtins"; nm] +let types_lid nm = PC.fstar_stubs_tactics_lid' ["Types"; nm] + +let set_auto_reflect arity (p:PO.primitive_step) : PO.primitive_step = + { p with auto_reflect = Some arity } + +let mk_tot_step_1 uarity nm f nbe_f = + let lid = types_lid nm in + PO.mk1' uarity lid + (fun x -> f x |> Some) + (fun x -> nbe_f x |> Some) + +let mk_tot_step_2 uarity nm f nbe_f = + let lid = types_lid nm in + PO.mk2' uarity lid + (fun x y -> f x y |> Some) + (fun x y -> nbe_f x y |> Some) + +let mk_tot_step_1_psc us nm f nbe_f = + let lid = types_lid nm in + PO.mk1_psc' us lid + (fun psc x -> f psc x |> Some) + (fun psc x -> nbe_f psc x |> Some) + +let mk_tac_step_1 univ_arity nm f nbe_f : PO.primitive_step = + let lid = builtin_lid nm in + set_auto_reflect 1 <| + PO.mk2' univ_arity lid + (fun a ps -> Some (run_wrap nm (f a) ps)) + (fun a ps -> Some (run_wrap nm (nbe_f a) ps)) + +let mk_tac_step_2 univ_arity nm f nbe_f : PO.primitive_step = + let lid = builtin_lid nm in + set_auto_reflect 2 <| + PO.mk3' univ_arity lid + (fun a b ps -> Some (run_wrap nm (f a b) ps)) + (fun a b ps -> Some (run_wrap nm (nbe_f a b) ps)) + +let mk_tac_step_3 univ_arity nm f nbe_f : PO.primitive_step = + let lid = builtin_lid nm in + set_auto_reflect 3 <| + PO.mk4' univ_arity lid + (fun a b c ps -> Some (run_wrap nm (f a b c) ps)) + (fun a b c ps -> Some (run_wrap nm (nbe_f a b c) ps)) + +let mk_tac_step_4 univ_arity nm f nbe_f : PO.primitive_step = + let lid = builtin_lid nm in + set_auto_reflect 4 <| + PO.mk5' univ_arity lid + (fun a b c d ps -> Some (run_wrap nm (f a b c d) ps)) + (fun a b c d ps -> Some (run_wrap nm (nbe_f a b c d) ps)) + +let mk_tac_step_5 univ_arity nm f nbe_f : PO.primitive_step = + let lid = builtin_lid nm in + set_auto_reflect 5 <| + PO.mk6' univ_arity lid + (fun a b c d e ps -> Some (run_wrap nm (f a b c d e) ps)) + (fun a b c d e ps -> Some (run_wrap nm (nbe_f a b c d e) ps)) + +let max_tac_arity = 20 + +(* NOTE: THE REST OF THIS MODULE IS AUTOGENERATED + * and here only for plugins to call into. The rest of the compiler + * makes no use of these functions. + * See .scripts/mk_tac_interps.sh *) + +let mk_tactic_interpretation_1 + (name : string) + (t : 't1 -> tac 'r) + (e1:embedding 't1) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed E.e_proofstate a2 ncb) (fun ps -> + let ps = set_ps_psc psc ps in + let r = interp_ctx name (fun () -> run_safe (t a1) ps) in + Some (embed (E.e_result er) (PO.psc_range psc) r ncb))) + | _ -> + None + +let mk_tactic_interpretation_2 + (name : string) + (t : 't1 -> 't2 -> tac 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed E.e_proofstate a3 ncb) (fun ps -> + let ps = set_ps_psc psc ps in + let r = interp_ctx name (fun () -> run_safe (t a1 a2) ps) in + Some (embed (E.e_result er) (PO.psc_range psc) r ncb)))) + | _ -> + None + +let mk_tactic_interpretation_3 + (name : string) + (t : 't1 -> 't2 -> 't3 -> tac 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed E.e_proofstate a4 ncb) (fun ps -> + let ps = set_ps_psc psc ps in + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3) ps) in + Some (embed (E.e_result er) (PO.psc_range psc) r ncb))))) + | _ -> + None + +let mk_tactic_interpretation_4 + (name : string) + (t : 't1 -> 't2 -> 't3 -> 't4 -> tac 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed E.e_proofstate a5 ncb) (fun ps -> + let ps = set_ps_psc psc ps in + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4) ps) in + Some (embed (E.e_result er) (PO.psc_range psc) r ncb)))))) + | _ -> + None + +let mk_tactic_interpretation_5 + (name : string) + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> tac 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + BU.bind_opt (unembed E.e_proofstate a6 ncb) (fun ps -> + let ps = set_ps_psc psc ps in + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5) ps) in + Some (embed (E.e_result er) (PO.psc_range psc) r ncb))))))) + | _ -> + None + +let mk_tactic_interpretation_6 + (name : string) + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> tac 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (e6:embedding 't6) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> + BU.bind_opt (unembed E.e_proofstate a7 ncb) (fun ps -> + let ps = set_ps_psc psc ps in + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6) ps) in + Some (embed (E.e_result er) (PO.psc_range psc) r ncb)))))))) + | _ -> + None + +let mk_tactic_interpretation_7 + (name : string) + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> tac 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (e6:embedding 't6) + (e7:embedding 't7) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> + BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> + BU.bind_opt (unembed E.e_proofstate a8 ncb) (fun ps -> + let ps = set_ps_psc psc ps in + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7) ps) in + Some (embed (E.e_result er) (PO.psc_range psc) r ncb))))))))) + | _ -> + None + +let mk_tactic_interpretation_8 + (name : string) + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> tac 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (e6:embedding 't6) + (e7:embedding 't7) + (e8:embedding 't8) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> + BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> + BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> + BU.bind_opt (unembed E.e_proofstate a9 ncb) (fun ps -> + let ps = set_ps_psc psc ps in + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8) ps) in + Some (embed (E.e_result er) (PO.psc_range psc) r ncb)))))))))) + | _ -> + None + +let mk_tactic_interpretation_9 + (name : string) + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> tac 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (e6:embedding 't6) + (e7:embedding 't7) + (e8:embedding 't8) + (e9:embedding 't9) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> + BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> + BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> + BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> + BU.bind_opt (unembed E.e_proofstate a10 ncb) (fun ps -> + let ps = set_ps_psc psc ps in + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9) ps) in + Some (embed (E.e_result er) (PO.psc_range psc) r ncb))))))))))) + | _ -> + None + +let mk_tactic_interpretation_10 + (name : string) + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> tac 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (e6:embedding 't6) + (e7:embedding 't7) + (e8:embedding 't8) + (e9:embedding 't9) + (e10:embedding 't10) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> + BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> + BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> + BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> + BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> + BU.bind_opt (unembed E.e_proofstate a11 ncb) (fun ps -> + let ps = set_ps_psc psc ps in + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) ps) in + Some (embed (E.e_result er) (PO.psc_range psc) r ncb)))))))))))) + | _ -> + None + +let mk_tactic_interpretation_11 + (name : string) + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> tac 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (e6:embedding 't6) + (e7:embedding 't7) + (e8:embedding 't8) + (e9:embedding 't9) + (e10:embedding 't10) + (e11:embedding 't11) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> + BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> + BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> + BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> + BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> + BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> + BU.bind_opt (unembed E.e_proofstate a12 ncb) (fun ps -> + let ps = set_ps_psc psc ps in + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) ps) in + Some (embed (E.e_result er) (PO.psc_range psc) r ncb))))))))))))) + | _ -> + None + +let mk_tactic_interpretation_12 + (name : string) + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> tac 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (e6:embedding 't6) + (e7:embedding 't7) + (e8:embedding 't8) + (e9:embedding 't9) + (e10:embedding 't10) + (e11:embedding 't11) + (e12:embedding 't12) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> + BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> + BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> + BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> + BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> + BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> + BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> + BU.bind_opt (unembed E.e_proofstate a13 ncb) (fun ps -> + let ps = set_ps_psc psc ps in + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12) ps) in + Some (embed (E.e_result er) (PO.psc_range psc) r ncb)))))))))))))) + | _ -> + None + +let mk_tactic_interpretation_13 + (name : string) + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> tac 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (e6:embedding 't6) + (e7:embedding 't7) + (e8:embedding 't8) + (e9:embedding 't9) + (e10:embedding 't10) + (e11:embedding 't11) + (e12:embedding 't12) + (e13:embedding 't13) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> + BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> + BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> + BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> + BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> + BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> + BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> + BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> + BU.bind_opt (unembed E.e_proofstate a14 ncb) (fun ps -> + let ps = set_ps_psc psc ps in + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13) ps) in + Some (embed (E.e_result er) (PO.psc_range psc) r ncb))))))))))))))) + | _ -> + None + +let mk_tactic_interpretation_14 + (name : string) + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> tac 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (e6:embedding 't6) + (e7:embedding 't7) + (e8:embedding 't8) + (e9:embedding 't9) + (e10:embedding 't10) + (e11:embedding 't11) + (e12:embedding 't12) + (e13:embedding 't13) + (e14:embedding 't14) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> + BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> + BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> + BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> + BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> + BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> + BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> + BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> + BU.bind_opt (unembed e14 a14 ncb) (fun a14 -> + BU.bind_opt (unembed E.e_proofstate a15 ncb) (fun ps -> + let ps = set_ps_psc psc ps in + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14) ps) in + Some (embed (E.e_result er) (PO.psc_range psc) r ncb)))))))))))))))) + | _ -> + None + +let mk_tactic_interpretation_15 + (name : string) + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> tac 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (e6:embedding 't6) + (e7:embedding 't7) + (e8:embedding 't8) + (e9:embedding 't9) + (e10:embedding 't10) + (e11:embedding 't11) + (e12:embedding 't12) + (e13:embedding 't13) + (e14:embedding 't14) + (e15:embedding 't15) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> + BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> + BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> + BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> + BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> + BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> + BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> + BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> + BU.bind_opt (unembed e14 a14 ncb) (fun a14 -> + BU.bind_opt (unembed e15 a15 ncb) (fun a15 -> + BU.bind_opt (unembed E.e_proofstate a16 ncb) (fun ps -> + let ps = set_ps_psc psc ps in + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15) ps) in + Some (embed (E.e_result er) (PO.psc_range psc) r ncb))))))))))))))))) + | _ -> + None + +let mk_tactic_interpretation_16 + (name : string) + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> tac 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (e6:embedding 't6) + (e7:embedding 't7) + (e8:embedding 't8) + (e9:embedding 't9) + (e10:embedding 't10) + (e11:embedding 't11) + (e12:embedding 't12) + (e13:embedding 't13) + (e14:embedding 't14) + (e15:embedding 't15) + (e16:embedding 't16) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> + BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> + BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> + BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> + BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> + BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> + BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> + BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> + BU.bind_opt (unembed e14 a14 ncb) (fun a14 -> + BU.bind_opt (unembed e15 a15 ncb) (fun a15 -> + BU.bind_opt (unembed e16 a16 ncb) (fun a16 -> + BU.bind_opt (unembed E.e_proofstate a17 ncb) (fun ps -> + let ps = set_ps_psc psc ps in + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16) ps) in + Some (embed (E.e_result er) (PO.psc_range psc) r ncb)))))))))))))))))) + | _ -> + None + +let mk_tactic_interpretation_17 + (name : string) + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> tac 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (e6:embedding 't6) + (e7:embedding 't7) + (e8:embedding 't8) + (e9:embedding 't9) + (e10:embedding 't10) + (e11:embedding 't11) + (e12:embedding 't12) + (e13:embedding 't13) + (e14:embedding 't14) + (e15:embedding 't15) + (e16:embedding 't16) + (e17:embedding 't17) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _); (a18, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> + BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> + BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> + BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> + BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> + BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> + BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> + BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> + BU.bind_opt (unembed e14 a14 ncb) (fun a14 -> + BU.bind_opt (unembed e15 a15 ncb) (fun a15 -> + BU.bind_opt (unembed e16 a16 ncb) (fun a16 -> + BU.bind_opt (unembed e17 a17 ncb) (fun a17 -> + BU.bind_opt (unembed E.e_proofstate a18 ncb) (fun ps -> + let ps = set_ps_psc psc ps in + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17) ps) in + Some (embed (E.e_result er) (PO.psc_range psc) r ncb))))))))))))))))))) + | _ -> + None + +let mk_tactic_interpretation_18 + (name : string) + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 't18 -> tac 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (e6:embedding 't6) + (e7:embedding 't7) + (e8:embedding 't8) + (e9:embedding 't9) + (e10:embedding 't10) + (e11:embedding 't11) + (e12:embedding 't12) + (e13:embedding 't13) + (e14:embedding 't14) + (e15:embedding 't15) + (e16:embedding 't16) + (e17:embedding 't17) + (e18:embedding 't18) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _); (a18, _); (a19, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> + BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> + BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> + BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> + BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> + BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> + BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> + BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> + BU.bind_opt (unembed e14 a14 ncb) (fun a14 -> + BU.bind_opt (unembed e15 a15 ncb) (fun a15 -> + BU.bind_opt (unembed e16 a16 ncb) (fun a16 -> + BU.bind_opt (unembed e17 a17 ncb) (fun a17 -> + BU.bind_opt (unembed e18 a18 ncb) (fun a18 -> + BU.bind_opt (unembed E.e_proofstate a19 ncb) (fun ps -> + let ps = set_ps_psc psc ps in + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18) ps) in + Some (embed (E.e_result er) (PO.psc_range psc) r ncb)))))))))))))))))))) + | _ -> + None + +let mk_tactic_interpretation_19 + (name : string) + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 't18 -> 't19 -> tac 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (e6:embedding 't6) + (e7:embedding 't7) + (e8:embedding 't8) + (e9:embedding 't9) + (e10:embedding 't10) + (e11:embedding 't11) + (e12:embedding 't12) + (e13:embedding 't13) + (e14:embedding 't14) + (e15:embedding 't15) + (e16:embedding 't16) + (e17:embedding 't17) + (e18:embedding 't18) + (e19:embedding 't19) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _); (a18, _); (a19, _); (a20, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> + BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> + BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> + BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> + BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> + BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> + BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> + BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> + BU.bind_opt (unembed e14 a14 ncb) (fun a14 -> + BU.bind_opt (unembed e15 a15 ncb) (fun a15 -> + BU.bind_opt (unembed e16 a16 ncb) (fun a16 -> + BU.bind_opt (unembed e17 a17 ncb) (fun a17 -> + BU.bind_opt (unembed e18 a18 ncb) (fun a18 -> + BU.bind_opt (unembed e19 a19 ncb) (fun a19 -> + BU.bind_opt (unembed E.e_proofstate a20 ncb) (fun ps -> + let ps = set_ps_psc psc ps in + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19) ps) in + Some (embed (E.e_result er) (PO.psc_range psc) r ncb))))))))))))))))))))) + | _ -> + None + +let mk_tactic_interpretation_20 + (name : string) + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 't18 -> 't19 -> 't20 -> tac 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (e6:embedding 't6) + (e7:embedding 't7) + (e8:embedding 't8) + (e9:embedding 't9) + (e10:embedding 't10) + (e11:embedding 't11) + (e12:embedding 't12) + (e13:embedding 't13) + (e14:embedding 't14) + (e15:embedding 't15) + (e16:embedding 't16) + (e17:embedding 't17) + (e18:embedding 't18) + (e19:embedding 't19) + (e20:embedding 't20) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _); (a18, _); (a19, _); (a20, _); (a21, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> + BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> + BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> + BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> + BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> + BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> + BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> + BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> + BU.bind_opt (unembed e14 a14 ncb) (fun a14 -> + BU.bind_opt (unembed e15 a15 ncb) (fun a15 -> + BU.bind_opt (unembed e16 a16 ncb) (fun a16 -> + BU.bind_opt (unembed e17 a17 ncb) (fun a17 -> + BU.bind_opt (unembed e18 a18 ncb) (fun a18 -> + BU.bind_opt (unembed e19 a19 ncb) (fun a19 -> + BU.bind_opt (unembed e20 a20 ncb) (fun a20 -> + BU.bind_opt (unembed E.e_proofstate a21 ncb) (fun ps -> + let ps = set_ps_psc psc ps in + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20) ps) in + Some (embed (E.e_result er) (PO.psc_range psc) r ncb)))))))))))))))))))))) + | _ -> + None + +let mk_tactic_nbe_interpretation_1 + (name : string) + cb + (t : 't1 -> tac 'r) + (e1:NBET.embedding 't1) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a2) (fun ps -> + let r = interp_ctx name (fun () -> run_safe (t a1) ps) in + Some (NBET.embed (E.e_result_nbe er) cb r))) + | _ -> + None + +let mk_tactic_nbe_interpretation_2 + (name : string) + cb + (t : 't1 -> 't2 -> tac 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a3) (fun ps -> + let r = interp_ctx name (fun () -> run_safe (t a1 a2) ps) in + Some (NBET.embed (E.e_result_nbe er) cb r)))) + | _ -> + None + +let mk_tactic_nbe_interpretation_3 + (name : string) + cb + (t : 't1 -> 't2 -> 't3 -> tac 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a4) (fun ps -> + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3) ps) in + Some (NBET.embed (E.e_result_nbe er) cb r))))) + | _ -> + None + +let mk_tactic_nbe_interpretation_4 + (name : string) + cb + (t : 't1 -> 't2 -> 't3 -> 't4 -> tac 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a5) (fun ps -> + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4) ps) in + Some (NBET.embed (E.e_result_nbe er) cb r)))))) + | _ -> + None + +let mk_tactic_nbe_interpretation_5 + (name : string) + cb + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> tac 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a6) (fun ps -> + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5) ps) in + Some (NBET.embed (E.e_result_nbe er) cb r))))))) + | _ -> + None + +let mk_tactic_nbe_interpretation_6 + (name : string) + cb + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> tac 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (e6:NBET.embedding 't6) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> + BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a7) (fun ps -> + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6) ps) in + Some (NBET.embed (E.e_result_nbe er) cb r)))))))) + | _ -> + None + +let mk_tactic_nbe_interpretation_7 + (name : string) + cb + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> tac 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (e6:NBET.embedding 't6) + (e7:NBET.embedding 't7) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> + BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> + BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a8) (fun ps -> + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7) ps) in + Some (NBET.embed (E.e_result_nbe er) cb r))))))))) + | _ -> + None + +let mk_tactic_nbe_interpretation_8 + (name : string) + cb + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> tac 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (e6:NBET.embedding 't6) + (e7:NBET.embedding 't7) + (e8:NBET.embedding 't8) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> + BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> + BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> + BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a9) (fun ps -> + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8) ps) in + Some (NBET.embed (E.e_result_nbe er) cb r)))))))))) + | _ -> + None + +let mk_tactic_nbe_interpretation_9 + (name : string) + cb + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> tac 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (e6:NBET.embedding 't6) + (e7:NBET.embedding 't7) + (e8:NBET.embedding 't8) + (e9:NBET.embedding 't9) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> + BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> + BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> + BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> + BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a10) (fun ps -> + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9) ps) in + Some (NBET.embed (E.e_result_nbe er) cb r))))))))))) + | _ -> + None + +let mk_tactic_nbe_interpretation_10 + (name : string) + cb + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> tac 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (e6:NBET.embedding 't6) + (e7:NBET.embedding 't7) + (e8:NBET.embedding 't8) + (e9:NBET.embedding 't9) + (e10:NBET.embedding 't10) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> + BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> + BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> + BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> + BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> + BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a11) (fun ps -> + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) ps) in + Some (NBET.embed (E.e_result_nbe er) cb r)))))))))))) + | _ -> + None + +let mk_tactic_nbe_interpretation_11 + (name : string) + cb + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> tac 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (e6:NBET.embedding 't6) + (e7:NBET.embedding 't7) + (e8:NBET.embedding 't8) + (e9:NBET.embedding 't9) + (e10:NBET.embedding 't10) + (e11:NBET.embedding 't11) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> + BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> + BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> + BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> + BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> + BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> + BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a12) (fun ps -> + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) ps) in + Some (NBET.embed (E.e_result_nbe er) cb r))))))))))))) + | _ -> + None + +let mk_tactic_nbe_interpretation_12 + (name : string) + cb + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> tac 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (e6:NBET.embedding 't6) + (e7:NBET.embedding 't7) + (e8:NBET.embedding 't8) + (e9:NBET.embedding 't9) + (e10:NBET.embedding 't10) + (e11:NBET.embedding 't11) + (e12:NBET.embedding 't12) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> + BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> + BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> + BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> + BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> + BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> + BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> + BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a13) (fun ps -> + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12) ps) in + Some (NBET.embed (E.e_result_nbe er) cb r)))))))))))))) + | _ -> + None + +let mk_tactic_nbe_interpretation_13 + (name : string) + cb + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> tac 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (e6:NBET.embedding 't6) + (e7:NBET.embedding 't7) + (e8:NBET.embedding 't8) + (e9:NBET.embedding 't9) + (e10:NBET.embedding 't10) + (e11:NBET.embedding 't11) + (e12:NBET.embedding 't12) + (e13:NBET.embedding 't13) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> + BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> + BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> + BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> + BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> + BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> + BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> + BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> + BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a14) (fun ps -> + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13) ps) in + Some (NBET.embed (E.e_result_nbe er) cb r))))))))))))))) + | _ -> + None + +let mk_tactic_nbe_interpretation_14 + (name : string) + cb + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> tac 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (e6:NBET.embedding 't6) + (e7:NBET.embedding 't7) + (e8:NBET.embedding 't8) + (e9:NBET.embedding 't9) + (e10:NBET.embedding 't10) + (e11:NBET.embedding 't11) + (e12:NBET.embedding 't12) + (e13:NBET.embedding 't13) + (e14:NBET.embedding 't14) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> + BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> + BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> + BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> + BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> + BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> + BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> + BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> + BU.bind_opt (NBET.unembed e14 cb a14) (fun a14 -> + BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a15) (fun ps -> + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14) ps) in + Some (NBET.embed (E.e_result_nbe er) cb r)))))))))))))))) + | _ -> + None + +let mk_tactic_nbe_interpretation_15 + (name : string) + cb + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> tac 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (e6:NBET.embedding 't6) + (e7:NBET.embedding 't7) + (e8:NBET.embedding 't8) + (e9:NBET.embedding 't9) + (e10:NBET.embedding 't10) + (e11:NBET.embedding 't11) + (e12:NBET.embedding 't12) + (e13:NBET.embedding 't13) + (e14:NBET.embedding 't14) + (e15:NBET.embedding 't15) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> + BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> + BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> + BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> + BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> + BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> + BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> + BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> + BU.bind_opt (NBET.unembed e14 cb a14) (fun a14 -> + BU.bind_opt (NBET.unembed e15 cb a15) (fun a15 -> + BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a16) (fun ps -> + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15) ps) in + Some (NBET.embed (E.e_result_nbe er) cb r))))))))))))))))) + | _ -> + None + +let mk_tactic_nbe_interpretation_16 + (name : string) + cb + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> tac 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (e6:NBET.embedding 't6) + (e7:NBET.embedding 't7) + (e8:NBET.embedding 't8) + (e9:NBET.embedding 't9) + (e10:NBET.embedding 't10) + (e11:NBET.embedding 't11) + (e12:NBET.embedding 't12) + (e13:NBET.embedding 't13) + (e14:NBET.embedding 't14) + (e15:NBET.embedding 't15) + (e16:NBET.embedding 't16) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> + BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> + BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> + BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> + BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> + BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> + BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> + BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> + BU.bind_opt (NBET.unembed e14 cb a14) (fun a14 -> + BU.bind_opt (NBET.unembed e15 cb a15) (fun a15 -> + BU.bind_opt (NBET.unembed e16 cb a16) (fun a16 -> + BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a17) (fun ps -> + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16) ps) in + Some (NBET.embed (E.e_result_nbe er) cb r)))))))))))))))))) + | _ -> + None + +let mk_tactic_nbe_interpretation_17 + (name : string) + cb + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> tac 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (e6:NBET.embedding 't6) + (e7:NBET.embedding 't7) + (e8:NBET.embedding 't8) + (e9:NBET.embedding 't9) + (e10:NBET.embedding 't10) + (e11:NBET.embedding 't11) + (e12:NBET.embedding 't12) + (e13:NBET.embedding 't13) + (e14:NBET.embedding 't14) + (e15:NBET.embedding 't15) + (e16:NBET.embedding 't16) + (e17:NBET.embedding 't17) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _); (a18, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> + BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> + BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> + BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> + BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> + BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> + BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> + BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> + BU.bind_opt (NBET.unembed e14 cb a14) (fun a14 -> + BU.bind_opt (NBET.unembed e15 cb a15) (fun a15 -> + BU.bind_opt (NBET.unembed e16 cb a16) (fun a16 -> + BU.bind_opt (NBET.unembed e17 cb a17) (fun a17 -> + BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a18) (fun ps -> + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17) ps) in + Some (NBET.embed (E.e_result_nbe er) cb r))))))))))))))))))) + | _ -> + None + +let mk_tactic_nbe_interpretation_18 + (name : string) + cb + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 't18 -> tac 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (e6:NBET.embedding 't6) + (e7:NBET.embedding 't7) + (e8:NBET.embedding 't8) + (e9:NBET.embedding 't9) + (e10:NBET.embedding 't10) + (e11:NBET.embedding 't11) + (e12:NBET.embedding 't12) + (e13:NBET.embedding 't13) + (e14:NBET.embedding 't14) + (e15:NBET.embedding 't15) + (e16:NBET.embedding 't16) + (e17:NBET.embedding 't17) + (e18:NBET.embedding 't18) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _); (a18, _); (a19, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> + BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> + BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> + BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> + BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> + BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> + BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> + BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> + BU.bind_opt (NBET.unembed e14 cb a14) (fun a14 -> + BU.bind_opt (NBET.unembed e15 cb a15) (fun a15 -> + BU.bind_opt (NBET.unembed e16 cb a16) (fun a16 -> + BU.bind_opt (NBET.unembed e17 cb a17) (fun a17 -> + BU.bind_opt (NBET.unembed e18 cb a18) (fun a18 -> + BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a19) (fun ps -> + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18) ps) in + Some (NBET.embed (E.e_result_nbe er) cb r)))))))))))))))))))) + | _ -> + None + +let mk_tactic_nbe_interpretation_19 + (name : string) + cb + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 't18 -> 't19 -> tac 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (e6:NBET.embedding 't6) + (e7:NBET.embedding 't7) + (e8:NBET.embedding 't8) + (e9:NBET.embedding 't9) + (e10:NBET.embedding 't10) + (e11:NBET.embedding 't11) + (e12:NBET.embedding 't12) + (e13:NBET.embedding 't13) + (e14:NBET.embedding 't14) + (e15:NBET.embedding 't15) + (e16:NBET.embedding 't16) + (e17:NBET.embedding 't17) + (e18:NBET.embedding 't18) + (e19:NBET.embedding 't19) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _); (a18, _); (a19, _); (a20, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> + BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> + BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> + BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> + BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> + BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> + BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> + BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> + BU.bind_opt (NBET.unembed e14 cb a14) (fun a14 -> + BU.bind_opt (NBET.unembed e15 cb a15) (fun a15 -> + BU.bind_opt (NBET.unembed e16 cb a16) (fun a16 -> + BU.bind_opt (NBET.unembed e17 cb a17) (fun a17 -> + BU.bind_opt (NBET.unembed e18 cb a18) (fun a18 -> + BU.bind_opt (NBET.unembed e19 cb a19) (fun a19 -> + BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a20) (fun ps -> + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19) ps) in + Some (NBET.embed (E.e_result_nbe er) cb r))))))))))))))))))))) + | _ -> + None + +let mk_tactic_nbe_interpretation_20 + (name : string) + cb + (t : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 't18 -> 't19 -> 't20 -> tac 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (e6:NBET.embedding 't6) + (e7:NBET.embedding 't7) + (e8:NBET.embedding 't8) + (e9:NBET.embedding 't9) + (e10:NBET.embedding 't10) + (e11:NBET.embedding 't11) + (e12:NBET.embedding 't12) + (e13:NBET.embedding 't13) + (e14:NBET.embedding 't14) + (e15:NBET.embedding 't15) + (e16:NBET.embedding 't16) + (e17:NBET.embedding 't17) + (e18:NBET.embedding 't18) + (e19:NBET.embedding 't19) + (e20:NBET.embedding 't20) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _); (a18, _); (a19, _); (a20, _); (a21, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> + BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> + BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> + BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> + BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> + BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> + BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> + BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> + BU.bind_opt (NBET.unembed e14 cb a14) (fun a14 -> + BU.bind_opt (NBET.unembed e15 cb a15) (fun a15 -> + BU.bind_opt (NBET.unembed e16 cb a16) (fun a16 -> + BU.bind_opt (NBET.unembed e17 cb a17) (fun a17 -> + BU.bind_opt (NBET.unembed e18 cb a18) (fun a18 -> + BU.bind_opt (NBET.unembed e19 cb a19) (fun a19 -> + BU.bind_opt (NBET.unembed e20 cb a20) (fun a20 -> + BU.bind_opt (NBET.unembed E.e_proofstate_nbe cb a21) (fun ps -> + let r = interp_ctx name (fun () -> run_safe (t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20) ps) in + Some (NBET.embed (E.e_result_nbe er) cb r)))))))))))))))))))))) + | _ -> + None + +let mk_total_interpretation_1 + (name : string) + (f : 't1 -> 'r) + (e1:embedding 't1) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + let r = interp_ctx name (fun () -> f a1) in + Some (embed er (PO.psc_range psc) r ncb)) + | _ -> + None + +let mk_total_interpretation_2 + (name : string) + (f : 't1 -> 't2 -> 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + let r = interp_ctx name (fun () -> f a1 a2) in + Some (embed er (PO.psc_range psc) r ncb))) + | _ -> + None + +let mk_total_interpretation_3 + (name : string) + (f : 't1 -> 't2 -> 't3 -> 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + let r = interp_ctx name (fun () -> f a1 a2 a3) in + Some (embed er (PO.psc_range psc) r ncb)))) + | _ -> + None + +let mk_total_interpretation_4 + (name : string) + (f : 't1 -> 't2 -> 't3 -> 't4 -> 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4) in + Some (embed er (PO.psc_range psc) r ncb))))) + | _ -> + None + +let mk_total_interpretation_5 + (name : string) + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5) in + Some (embed er (PO.psc_range psc) r ncb)))))) + | _ -> + None + +let mk_total_interpretation_6 + (name : string) + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (e6:embedding 't6) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6) in + Some (embed er (PO.psc_range psc) r ncb))))))) + | _ -> + None + +let mk_total_interpretation_7 + (name : string) + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (e6:embedding 't6) + (e7:embedding 't7) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> + BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7) in + Some (embed er (PO.psc_range psc) r ncb)))))))) + | _ -> + None + +let mk_total_interpretation_8 + (name : string) + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (e6:embedding 't6) + (e7:embedding 't7) + (e8:embedding 't8) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> + BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> + BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8) in + Some (embed er (PO.psc_range psc) r ncb))))))))) + | _ -> + None + +let mk_total_interpretation_9 + (name : string) + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (e6:embedding 't6) + (e7:embedding 't7) + (e8:embedding 't8) + (e9:embedding 't9) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> + BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> + BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> + BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9) in + Some (embed er (PO.psc_range psc) r ncb)))))))))) + | _ -> + None + +let mk_total_interpretation_10 + (name : string) + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (e6:embedding 't6) + (e7:embedding 't7) + (e8:embedding 't8) + (e9:embedding 't9) + (e10:embedding 't10) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> + BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> + BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> + BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> + BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) in + Some (embed er (PO.psc_range psc) r ncb))))))))))) + | _ -> + None + +let mk_total_interpretation_11 + (name : string) + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (e6:embedding 't6) + (e7:embedding 't7) + (e8:embedding 't8) + (e9:embedding 't9) + (e10:embedding 't10) + (e11:embedding 't11) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> + BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> + BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> + BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> + BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> + BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) in + Some (embed er (PO.psc_range psc) r ncb)))))))))))) + | _ -> + None + +let mk_total_interpretation_12 + (name : string) + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (e6:embedding 't6) + (e7:embedding 't7) + (e8:embedding 't8) + (e9:embedding 't9) + (e10:embedding 't10) + (e11:embedding 't11) + (e12:embedding 't12) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> + BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> + BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> + BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> + BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> + BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> + BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12) in + Some (embed er (PO.psc_range psc) r ncb))))))))))))) + | _ -> + None + +let mk_total_interpretation_13 + (name : string) + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (e6:embedding 't6) + (e7:embedding 't7) + (e8:embedding 't8) + (e9:embedding 't9) + (e10:embedding 't10) + (e11:embedding 't11) + (e12:embedding 't12) + (e13:embedding 't13) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> + BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> + BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> + BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> + BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> + BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> + BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> + BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13) in + Some (embed er (PO.psc_range psc) r ncb)))))))))))))) + | _ -> + None + +let mk_total_interpretation_14 + (name : string) + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (e6:embedding 't6) + (e7:embedding 't7) + (e8:embedding 't8) + (e9:embedding 't9) + (e10:embedding 't10) + (e11:embedding 't11) + (e12:embedding 't12) + (e13:embedding 't13) + (e14:embedding 't14) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> + BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> + BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> + BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> + BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> + BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> + BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> + BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> + BU.bind_opt (unembed e14 a14 ncb) (fun a14 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14) in + Some (embed er (PO.psc_range psc) r ncb))))))))))))))) + | _ -> + None + +let mk_total_interpretation_15 + (name : string) + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (e6:embedding 't6) + (e7:embedding 't7) + (e8:embedding 't8) + (e9:embedding 't9) + (e10:embedding 't10) + (e11:embedding 't11) + (e12:embedding 't12) + (e13:embedding 't13) + (e14:embedding 't14) + (e15:embedding 't15) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> + BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> + BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> + BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> + BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> + BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> + BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> + BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> + BU.bind_opt (unembed e14 a14 ncb) (fun a14 -> + BU.bind_opt (unembed e15 a15 ncb) (fun a15 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15) in + Some (embed er (PO.psc_range psc) r ncb)))))))))))))))) + | _ -> + None + +let mk_total_interpretation_16 + (name : string) + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (e6:embedding 't6) + (e7:embedding 't7) + (e8:embedding 't8) + (e9:embedding 't9) + (e10:embedding 't10) + (e11:embedding 't11) + (e12:embedding 't12) + (e13:embedding 't13) + (e14:embedding 't14) + (e15:embedding 't15) + (e16:embedding 't16) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> + BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> + BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> + BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> + BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> + BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> + BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> + BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> + BU.bind_opt (unembed e14 a14 ncb) (fun a14 -> + BU.bind_opt (unembed e15 a15 ncb) (fun a15 -> + BU.bind_opt (unembed e16 a16 ncb) (fun a16 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16) in + Some (embed er (PO.psc_range psc) r ncb))))))))))))))))) + | _ -> + None + +let mk_total_interpretation_17 + (name : string) + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (e6:embedding 't6) + (e7:embedding 't7) + (e8:embedding 't8) + (e9:embedding 't9) + (e10:embedding 't10) + (e11:embedding 't11) + (e12:embedding 't12) + (e13:embedding 't13) + (e14:embedding 't14) + (e15:embedding 't15) + (e16:embedding 't16) + (e17:embedding 't17) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> + BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> + BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> + BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> + BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> + BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> + BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> + BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> + BU.bind_opt (unembed e14 a14 ncb) (fun a14 -> + BU.bind_opt (unembed e15 a15 ncb) (fun a15 -> + BU.bind_opt (unembed e16 a16 ncb) (fun a16 -> + BU.bind_opt (unembed e17 a17 ncb) (fun a17 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17) in + Some (embed er (PO.psc_range psc) r ncb)))))))))))))))))) + | _ -> + None + +let mk_total_interpretation_18 + (name : string) + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 't18 -> 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (e6:embedding 't6) + (e7:embedding 't7) + (e8:embedding 't8) + (e9:embedding 't9) + (e10:embedding 't10) + (e11:embedding 't11) + (e12:embedding 't12) + (e13:embedding 't13) + (e14:embedding 't14) + (e15:embedding 't15) + (e16:embedding 't16) + (e17:embedding 't17) + (e18:embedding 't18) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _); (a18, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> + BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> + BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> + BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> + BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> + BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> + BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> + BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> + BU.bind_opt (unembed e14 a14 ncb) (fun a14 -> + BU.bind_opt (unembed e15 a15 ncb) (fun a15 -> + BU.bind_opt (unembed e16 a16 ncb) (fun a16 -> + BU.bind_opt (unembed e17 a17 ncb) (fun a17 -> + BU.bind_opt (unembed e18 a18 ncb) (fun a18 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18) in + Some (embed er (PO.psc_range psc) r ncb))))))))))))))))))) + | _ -> + None + +let mk_total_interpretation_19 + (name : string) + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 't18 -> 't19 -> 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (e6:embedding 't6) + (e7:embedding 't7) + (e8:embedding 't8) + (e9:embedding 't9) + (e10:embedding 't10) + (e11:embedding 't11) + (e12:embedding 't12) + (e13:embedding 't13) + (e14:embedding 't14) + (e15:embedding 't15) + (e16:embedding 't16) + (e17:embedding 't17) + (e18:embedding 't18) + (e19:embedding 't19) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _); (a18, _); (a19, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> + BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> + BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> + BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> + BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> + BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> + BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> + BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> + BU.bind_opt (unembed e14 a14 ncb) (fun a14 -> + BU.bind_opt (unembed e15 a15 ncb) (fun a15 -> + BU.bind_opt (unembed e16 a16 ncb) (fun a16 -> + BU.bind_opt (unembed e17 a17 ncb) (fun a17 -> + BU.bind_opt (unembed e18 a18 ncb) (fun a18 -> + BU.bind_opt (unembed e19 a19 ncb) (fun a19 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19) in + Some (embed er (PO.psc_range psc) r ncb)))))))))))))))))))) + | _ -> + None + +let mk_total_interpretation_20 + (name : string) + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 't18 -> 't19 -> 't20 -> 'r) + (e1:embedding 't1) + (e2:embedding 't2) + (e3:embedding 't3) + (e4:embedding 't4) + (e5:embedding 't5) + (e6:embedding 't6) + (e7:embedding 't7) + (e8:embedding 't8) + (e9:embedding 't9) + (e10:embedding 't10) + (e11:embedding 't11) + (e12:embedding 't12) + (e13:embedding 't13) + (e14:embedding 't14) + (e15:embedding 't15) + (e16:embedding 't16) + (e17:embedding 't17) + (e18:embedding 't18) + (e19:embedding 't19) + (e20:embedding 't20) + (er:embedding 'r) + (psc:PO.psc) + (ncb:norm_cb) + (us:universes) + (args:args) + : option term + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _); (a18, _); (a19, _); (a20, _)] -> + BU.bind_opt (unembed e1 a1 ncb) (fun a1 -> + BU.bind_opt (unembed e2 a2 ncb) (fun a2 -> + BU.bind_opt (unembed e3 a3 ncb) (fun a3 -> + BU.bind_opt (unembed e4 a4 ncb) (fun a4 -> + BU.bind_opt (unembed e5 a5 ncb) (fun a5 -> + BU.bind_opt (unembed e6 a6 ncb) (fun a6 -> + BU.bind_opt (unembed e7 a7 ncb) (fun a7 -> + BU.bind_opt (unembed e8 a8 ncb) (fun a8 -> + BU.bind_opt (unembed e9 a9 ncb) (fun a9 -> + BU.bind_opt (unembed e10 a10 ncb) (fun a10 -> + BU.bind_opt (unembed e11 a11 ncb) (fun a11 -> + BU.bind_opt (unembed e12 a12 ncb) (fun a12 -> + BU.bind_opt (unembed e13 a13 ncb) (fun a13 -> + BU.bind_opt (unembed e14 a14 ncb) (fun a14 -> + BU.bind_opt (unembed e15 a15 ncb) (fun a15 -> + BU.bind_opt (unembed e16 a16 ncb) (fun a16 -> + BU.bind_opt (unembed e17 a17 ncb) (fun a17 -> + BU.bind_opt (unembed e18 a18 ncb) (fun a18 -> + BU.bind_opt (unembed e19 a19 ncb) (fun a19 -> + BU.bind_opt (unembed e20 a20 ncb) (fun a20 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20) in + Some (embed er (PO.psc_range psc) r ncb))))))))))))))))))))) + | _ -> + None + +let mk_total_nbe_interpretation_1 + (name : string) + cb + (f : 't1 -> 'r) + (e1:NBET.embedding 't1) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + let r = interp_ctx name (fun () -> f a1) in + Some (NBET.embed er cb r)) + | _ -> + None + +let mk_total_nbe_interpretation_2 + (name : string) + cb + (f : 't1 -> 't2 -> 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + let r = interp_ctx name (fun () -> f a1 a2) in + Some (NBET.embed er cb r))) + | _ -> + None + +let mk_total_nbe_interpretation_3 + (name : string) + cb + (f : 't1 -> 't2 -> 't3 -> 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + let r = interp_ctx name (fun () -> f a1 a2 a3) in + Some (NBET.embed er cb r)))) + | _ -> + None + +let mk_total_nbe_interpretation_4 + (name : string) + cb + (f : 't1 -> 't2 -> 't3 -> 't4 -> 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4) in + Some (NBET.embed er cb r))))) + | _ -> + None + +let mk_total_nbe_interpretation_5 + (name : string) + cb + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5) in + Some (NBET.embed er cb r)))))) + | _ -> + None + +let mk_total_nbe_interpretation_6 + (name : string) + cb + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (e6:NBET.embedding 't6) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6) in + Some (NBET.embed er cb r))))))) + | _ -> + None + +let mk_total_nbe_interpretation_7 + (name : string) + cb + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (e6:NBET.embedding 't6) + (e7:NBET.embedding 't7) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> + BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7) in + Some (NBET.embed er cb r)))))))) + | _ -> + None + +let mk_total_nbe_interpretation_8 + (name : string) + cb + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (e6:NBET.embedding 't6) + (e7:NBET.embedding 't7) + (e8:NBET.embedding 't8) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> + BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> + BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8) in + Some (NBET.embed er cb r))))))))) + | _ -> + None + +let mk_total_nbe_interpretation_9 + (name : string) + cb + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (e6:NBET.embedding 't6) + (e7:NBET.embedding 't7) + (e8:NBET.embedding 't8) + (e9:NBET.embedding 't9) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> + BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> + BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> + BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9) in + Some (NBET.embed er cb r)))))))))) + | _ -> + None + +let mk_total_nbe_interpretation_10 + (name : string) + cb + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (e6:NBET.embedding 't6) + (e7:NBET.embedding 't7) + (e8:NBET.embedding 't8) + (e9:NBET.embedding 't9) + (e10:NBET.embedding 't10) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> + BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> + BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> + BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> + BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) in + Some (NBET.embed er cb r))))))))))) + | _ -> + None + +let mk_total_nbe_interpretation_11 + (name : string) + cb + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (e6:NBET.embedding 't6) + (e7:NBET.embedding 't7) + (e8:NBET.embedding 't8) + (e9:NBET.embedding 't9) + (e10:NBET.embedding 't10) + (e11:NBET.embedding 't11) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> + BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> + BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> + BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> + BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> + BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) in + Some (NBET.embed er cb r)))))))))))) + | _ -> + None + +let mk_total_nbe_interpretation_12 + (name : string) + cb + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (e6:NBET.embedding 't6) + (e7:NBET.embedding 't7) + (e8:NBET.embedding 't8) + (e9:NBET.embedding 't9) + (e10:NBET.embedding 't10) + (e11:NBET.embedding 't11) + (e12:NBET.embedding 't12) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> + BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> + BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> + BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> + BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> + BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> + BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12) in + Some (NBET.embed er cb r))))))))))))) + | _ -> + None + +let mk_total_nbe_interpretation_13 + (name : string) + cb + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (e6:NBET.embedding 't6) + (e7:NBET.embedding 't7) + (e8:NBET.embedding 't8) + (e9:NBET.embedding 't9) + (e10:NBET.embedding 't10) + (e11:NBET.embedding 't11) + (e12:NBET.embedding 't12) + (e13:NBET.embedding 't13) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> + BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> + BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> + BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> + BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> + BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> + BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> + BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13) in + Some (NBET.embed er cb r)))))))))))))) + | _ -> + None + +let mk_total_nbe_interpretation_14 + (name : string) + cb + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (e6:NBET.embedding 't6) + (e7:NBET.embedding 't7) + (e8:NBET.embedding 't8) + (e9:NBET.embedding 't9) + (e10:NBET.embedding 't10) + (e11:NBET.embedding 't11) + (e12:NBET.embedding 't12) + (e13:NBET.embedding 't13) + (e14:NBET.embedding 't14) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> + BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> + BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> + BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> + BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> + BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> + BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> + BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> + BU.bind_opt (NBET.unembed e14 cb a14) (fun a14 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14) in + Some (NBET.embed er cb r))))))))))))))) + | _ -> + None + +let mk_total_nbe_interpretation_15 + (name : string) + cb + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (e6:NBET.embedding 't6) + (e7:NBET.embedding 't7) + (e8:NBET.embedding 't8) + (e9:NBET.embedding 't9) + (e10:NBET.embedding 't10) + (e11:NBET.embedding 't11) + (e12:NBET.embedding 't12) + (e13:NBET.embedding 't13) + (e14:NBET.embedding 't14) + (e15:NBET.embedding 't15) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> + BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> + BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> + BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> + BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> + BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> + BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> + BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> + BU.bind_opt (NBET.unembed e14 cb a14) (fun a14 -> + BU.bind_opt (NBET.unembed e15 cb a15) (fun a15 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15) in + Some (NBET.embed er cb r)))))))))))))))) + | _ -> + None + +let mk_total_nbe_interpretation_16 + (name : string) + cb + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (e6:NBET.embedding 't6) + (e7:NBET.embedding 't7) + (e8:NBET.embedding 't8) + (e9:NBET.embedding 't9) + (e10:NBET.embedding 't10) + (e11:NBET.embedding 't11) + (e12:NBET.embedding 't12) + (e13:NBET.embedding 't13) + (e14:NBET.embedding 't14) + (e15:NBET.embedding 't15) + (e16:NBET.embedding 't16) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> + BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> + BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> + BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> + BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> + BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> + BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> + BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> + BU.bind_opt (NBET.unembed e14 cb a14) (fun a14 -> + BU.bind_opt (NBET.unembed e15 cb a15) (fun a15 -> + BU.bind_opt (NBET.unembed e16 cb a16) (fun a16 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16) in + Some (NBET.embed er cb r))))))))))))))))) + | _ -> + None + +let mk_total_nbe_interpretation_17 + (name : string) + cb + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (e6:NBET.embedding 't6) + (e7:NBET.embedding 't7) + (e8:NBET.embedding 't8) + (e9:NBET.embedding 't9) + (e10:NBET.embedding 't10) + (e11:NBET.embedding 't11) + (e12:NBET.embedding 't12) + (e13:NBET.embedding 't13) + (e14:NBET.embedding 't14) + (e15:NBET.embedding 't15) + (e16:NBET.embedding 't16) + (e17:NBET.embedding 't17) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> + BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> + BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> + BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> + BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> + BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> + BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> + BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> + BU.bind_opt (NBET.unembed e14 cb a14) (fun a14 -> + BU.bind_opt (NBET.unembed e15 cb a15) (fun a15 -> + BU.bind_opt (NBET.unembed e16 cb a16) (fun a16 -> + BU.bind_opt (NBET.unembed e17 cb a17) (fun a17 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17) in + Some (NBET.embed er cb r)))))))))))))))))) + | _ -> + None + +let mk_total_nbe_interpretation_18 + (name : string) + cb + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 't18 -> 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (e6:NBET.embedding 't6) + (e7:NBET.embedding 't7) + (e8:NBET.embedding 't8) + (e9:NBET.embedding 't9) + (e10:NBET.embedding 't10) + (e11:NBET.embedding 't11) + (e12:NBET.embedding 't12) + (e13:NBET.embedding 't13) + (e14:NBET.embedding 't14) + (e15:NBET.embedding 't15) + (e16:NBET.embedding 't16) + (e17:NBET.embedding 't17) + (e18:NBET.embedding 't18) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _); (a18, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> + BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> + BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> + BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> + BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> + BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> + BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> + BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> + BU.bind_opt (NBET.unembed e14 cb a14) (fun a14 -> + BU.bind_opt (NBET.unembed e15 cb a15) (fun a15 -> + BU.bind_opt (NBET.unembed e16 cb a16) (fun a16 -> + BU.bind_opt (NBET.unembed e17 cb a17) (fun a17 -> + BU.bind_opt (NBET.unembed e18 cb a18) (fun a18 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18) in + Some (NBET.embed er cb r))))))))))))))))))) + | _ -> + None + +let mk_total_nbe_interpretation_19 + (name : string) + cb + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 't18 -> 't19 -> 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (e6:NBET.embedding 't6) + (e7:NBET.embedding 't7) + (e8:NBET.embedding 't8) + (e9:NBET.embedding 't9) + (e10:NBET.embedding 't10) + (e11:NBET.embedding 't11) + (e12:NBET.embedding 't12) + (e13:NBET.embedding 't13) + (e14:NBET.embedding 't14) + (e15:NBET.embedding 't15) + (e16:NBET.embedding 't16) + (e17:NBET.embedding 't17) + (e18:NBET.embedding 't18) + (e19:NBET.embedding 't19) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _); (a18, _); (a19, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> + BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> + BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> + BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> + BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> + BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> + BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> + BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> + BU.bind_opt (NBET.unembed e14 cb a14) (fun a14 -> + BU.bind_opt (NBET.unembed e15 cb a15) (fun a15 -> + BU.bind_opt (NBET.unembed e16 cb a16) (fun a16 -> + BU.bind_opt (NBET.unembed e17 cb a17) (fun a17 -> + BU.bind_opt (NBET.unembed e18 cb a18) (fun a18 -> + BU.bind_opt (NBET.unembed e19 cb a19) (fun a19 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19) in + Some (NBET.embed er cb r)))))))))))))))))))) + | _ -> + None + +let mk_total_nbe_interpretation_20 + (name : string) + cb + (f : 't1 -> 't2 -> 't3 -> 't4 -> 't5 -> 't6 -> 't7 -> 't8 -> 't9 -> 't10 -> 't11 -> 't12 -> 't13 -> 't14 -> 't15 -> 't16 -> 't17 -> 't18 -> 't19 -> 't20 -> 'r) + (e1:NBET.embedding 't1) + (e2:NBET.embedding 't2) + (e3:NBET.embedding 't3) + (e4:NBET.embedding 't4) + (e5:NBET.embedding 't5) + (e6:NBET.embedding 't6) + (e7:NBET.embedding 't7) + (e8:NBET.embedding 't8) + (e9:NBET.embedding 't9) + (e10:NBET.embedding 't10) + (e11:NBET.embedding 't11) + (e12:NBET.embedding 't12) + (e13:NBET.embedding 't13) + (e14:NBET.embedding 't14) + (e15:NBET.embedding 't15) + (e16:NBET.embedding 't16) + (e17:NBET.embedding 't17) + (e18:NBET.embedding 't18) + (e19:NBET.embedding 't19) + (e20:NBET.embedding 't20) + (er:NBET.embedding 'r) + (us:universes) + (args:NBET.args) + : option NBET.t + = + match args with + | [(a1, _); (a2, _); (a3, _); (a4, _); (a5, _); (a6, _); (a7, _); (a8, _); (a9, _); (a10, _); (a11, _); (a12, _); (a13, _); (a14, _); (a15, _); (a16, _); (a17, _); (a18, _); (a19, _); (a20, _)] -> + BU.bind_opt (NBET.unembed e1 cb a1) (fun a1 -> + BU.bind_opt (NBET.unembed e2 cb a2) (fun a2 -> + BU.bind_opt (NBET.unembed e3 cb a3) (fun a3 -> + BU.bind_opt (NBET.unembed e4 cb a4) (fun a4 -> + BU.bind_opt (NBET.unembed e5 cb a5) (fun a5 -> + BU.bind_opt (NBET.unembed e6 cb a6) (fun a6 -> + BU.bind_opt (NBET.unembed e7 cb a7) (fun a7 -> + BU.bind_opt (NBET.unembed e8 cb a8) (fun a8 -> + BU.bind_opt (NBET.unembed e9 cb a9) (fun a9 -> + BU.bind_opt (NBET.unembed e10 cb a10) (fun a10 -> + BU.bind_opt (NBET.unembed e11 cb a11) (fun a11 -> + BU.bind_opt (NBET.unembed e12 cb a12) (fun a12 -> + BU.bind_opt (NBET.unembed e13 cb a13) (fun a13 -> + BU.bind_opt (NBET.unembed e14 cb a14) (fun a14 -> + BU.bind_opt (NBET.unembed e15 cb a15) (fun a15 -> + BU.bind_opt (NBET.unembed e16 cb a16) (fun a16 -> + BU.bind_opt (NBET.unembed e17 cb a17) (fun a17 -> + BU.bind_opt (NBET.unembed e18 cb a18) (fun a18 -> + BU.bind_opt (NBET.unembed e19 cb a19) (fun a19 -> + BU.bind_opt (NBET.unembed e20 cb a20) (fun a20 -> + let r = interp_ctx name (fun () -> f a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20) in + Some (NBET.embed er cb r))))))))))))))))))))) + | _ -> + None diff --git a/src/tactics/FStarC.Tactics.InterpFuns.fsti b/src/tactics/FStarC.Tactics.InterpFuns.fsti new file mode 100644 index 00000000000..18f408d130f --- /dev/null +++ b/src/tactics/FStarC.Tactics.InterpFuns.fsti @@ -0,0 +1,148 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Tactics.InterpFuns + +(* This module is awful, don't even look at it please. *) + +open FStar open FStarC.Compiler +open FStarC.Compiler.Effect + +open FStarC.Syntax.Embeddings +open FStarC.Tactics.Monad + +module Cfg = FStarC.TypeChecker.Cfg +module NBET = FStarC.TypeChecker.NBETerm +module PO = FStarC.TypeChecker.Primops + +val max_tac_arity : int // = 20 + +val interp_ctx : string -> (unit -> 'a) -> 'a + +// The mk_tot_step functions use lids in FStar.Stubs.Tactics.Types, +// while mk_tac_step ones go to FStar.Stubs.Tactics.V2.Builtins. +// For V1 there's a pass over the result to change the V2 to V1. + +val mk_tot_step_1 : + univ_arity:int -> + string -> + {| embedding 't1 |} -> + {| embedding 'res |} -> + {| NBET.embedding 'nt1 |} -> + {| NBET.embedding 'nres |} -> + ('t1 -> 'res) -> + ('nt1 -> 'nres) -> + PO.primitive_step + +val mk_tot_step_2 : + univ_arity:int -> + string -> + {| embedding 't1 |} -> + {| embedding 't2 |} -> + {| embedding 'res |} -> + {| NBET.embedding 'nt1 |} -> + {| NBET.embedding 'nt2 |} -> + {| NBET.embedding 'nres |} -> + ('t1 -> 't2 -> 'res) -> + ('nt1 -> 'nt2 -> 'nres) -> + PO.primitive_step + +// Step with access to normalizer PSC +val mk_tot_step_1_psc : + univ_arity:int -> + string -> + {| embedding 't1 |} -> + {| embedding 'res |} -> + {| NBET.embedding 'nt1 |} -> + {| NBET.embedding 'nres |} -> + (PO.psc -> 't1 -> 'res) -> + (PO.psc -> 'nt1 -> 'nres) -> + PO.primitive_step + +val mk_tac_step_1 : + univ_arity:int -> + string -> + {| embedding 't1 |} -> + {| embedding 'res |} -> + {| NBET.embedding 'nt1 |} -> + {| NBET.embedding 'nres |} -> + ('t1 -> tac 'res) -> + ('nt1 -> tac 'nres) -> + PO.primitive_step + +val mk_tac_step_2 : + univ_arity:int -> + string -> + {| embedding 't1 |} -> + {| embedding 't2 |} -> + {| embedding 'res |} -> + {| NBET.embedding 'nt1 |} -> + {| NBET.embedding 'nt2 |} -> + {| NBET.embedding 'nres |} -> + ('t1 -> 't2 -> tac 'res) -> + ('nt1 -> 'nt2 -> tac 'nres) -> + PO.primitive_step + +val mk_tac_step_3 : + univ_arity:int -> + string -> + {| embedding 't1 |} -> + {| embedding 't2 |} -> + {| embedding 't3 |} -> + {| embedding 'res |} -> + {| NBET.embedding 'nt1 |} -> + {| NBET.embedding 'nt2 |} -> + {| NBET.embedding 'nt3 |} -> + {| NBET.embedding 'nres |} -> + ('t1 -> 't2 -> 't3 -> tac 'res) -> + ('nt1 -> 'nt2 -> 'nt3 -> tac 'nres) -> + PO.primitive_step + +val mk_tac_step_4 : + univ_arity:int -> + string -> + {| embedding 't1 |} -> + {| embedding 't2 |} -> + {| embedding 't3 |} -> + {| embedding 't4 |} -> + {| embedding 'res |} -> + {| NBET.embedding 'nt1 |} -> + {| NBET.embedding 'nt2 |} -> + {| NBET.embedding 'nt3 |} -> + {| NBET.embedding 'nt4 |} -> + {| NBET.embedding 'nres |} -> + ('t1 -> 't2 -> 't3 -> 't4 -> tac 'res) -> + ('nt1 -> 'nt2 -> 'nt3 -> 'nt4 -> tac 'nres) -> + PO.primitive_step + +val mk_tac_step_5 : + univ_arity:int -> + string -> + {| embedding 't1 |} -> + {| embedding 't2 |} -> + {| embedding 't3 |} -> + {| embedding 't4 |} -> + {| embedding 't5 |} -> + {| embedding 'res |} -> + {| NBET.embedding 'nt1 |} -> + {| NBET.embedding 'nt2 |} -> + {| NBET.embedding 'nt3 |} -> + {| NBET.embedding 'nt4 |} -> + {| NBET.embedding 'nt5 |} -> + {| NBET.embedding 'nres |} -> + ('t1 -> 't2 -> 't3 -> 't4 -> 't5 -> tac 'res) -> + ('nt1 -> 'nt2 -> 'nt3 -> 'nt4 -> 'nt5 -> tac 'nres) -> + PO.primitive_step diff --git a/src/tactics/FStarC.Tactics.Interpreter.fst b/src/tactics/FStarC.Tactics.Interpreter.fst new file mode 100644 index 00000000000..8a25c6fd9d8 --- /dev/null +++ b/src/tactics/FStarC.Tactics.Interpreter.fst @@ -0,0 +1,448 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Tactics.Interpreter + +(* Most of the tactic running logic is here. V1.Interpreter calls +into this module for all of that. *) + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Compiler.Range +open FStarC.Compiler.Util +open FStarC.Syntax.Syntax +open FStarC.Syntax.Embeddings +open FStarC.TypeChecker.Common +open FStarC.TypeChecker.Env +open FStarC.Tactics.Result +open FStarC.Tactics.Types +open FStarC.Tactics.Printing +open FStarC.Tactics.Monad +open FStarC.Tactics.CtrlRewrite +open FStarC.Tactics.Native +open FStarC.Tactics.Common +open FStarC.Class.Show +open FStarC.Class.PP +open FStarC.Class.Monad +module Listlike = FStarC.Class.Listlike + +module BU = FStarC.Compiler.Util +module Cfg = FStarC.TypeChecker.Cfg +module E = FStarC.Tactics.Embedding +module Env = FStarC.TypeChecker.Env +module Err = FStarC.Errors +module IFuns = FStarC.Tactics.InterpFuns +module NBE = FStarC.TypeChecker.NBE +module NBET = FStarC.TypeChecker.NBETerm +module N = FStarC.TypeChecker.Normalize +module NRE = FStarC.Reflection.V2.NBEEmbeddings +module PC = FStarC.Parser.Const +module PO = FStarC.TypeChecker.Primops +module Print = FStarC.Syntax.Print +module RE = FStarC.Reflection.V2.Embeddings +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module TcComm = FStarC.TypeChecker.Common +module TcRel = FStarC.TypeChecker.Rel +module TcTerm = FStarC.TypeChecker.TcTerm +module U = FStarC.Syntax.Util + +let dbg_Tac = Debug.get_toggle "Tac" + +let solve (#a:Type) {| ev : a |} : Tot a = ev + +let embed {|embedding 'a|} r (x:'a) norm_cb = embed x r None norm_cb +let unembed {|embedding 'a|} a norm_cb : option 'a = unembed a norm_cb + +let native_tactics_steps () = + let step_from_native_step (s: native_primitive_step) : PO.primitive_step = + { name = s.name + ; arity = s.arity + ; univ_arity = 0 // Zoe : We might need to change that + ; auto_reflect = Some (s.arity - 1) + ; strong_reduction_ok = s.strong_reduction_ok + ; requires_binder_substitution = false // GM: Don't think we care about pretty-printing on native + ; renorm_after = false + ; interpretation = s.tactic + ; interpretation_nbe = fun _cb _us -> NBET.dummy_interp s.name + } + in + List.map step_from_native_step (FStarC.Tactics.Native.list_all ()) + +(* This reference keeps all of the tactic primitives. *) +let __primitive_steps_ref : ref (list PO.primitive_step) = + BU.mk_ref [] + +let primitive_steps () : list PO.primitive_step = + (native_tactics_steps ()) + @ (!__primitive_steps_ref) + +let register_tactic_primitive_step (s : PO.primitive_step) : unit = + __primitive_steps_ref := s :: !__primitive_steps_ref + +(* This function attempts to reconstruct the reduction head of a +stuck tactic term, to provide a better error message for the user. *) +let rec t_head_of (t : term) : term = + match (SS.compress t).n with + | Tm_app _ -> + (* If the head is a ctor, or an uninterpreted fv, do not shrink + further. Otherwise we will get failures saying that 'Success' + or 'dump' got stuck, which is not helpful. *) + let h, args = U.head_and_args_full t in + let h = U.unmeta h in + begin match (SS.compress h).n with + | Tm_uinst _ + | Tm_fvar _ + | Tm_bvar _ // should not occur + | Tm_name _ + | Tm_constant _ -> t + | _ -> t_head_of h + end + | Tm_match {scrutinee=t} + | Tm_ascribed {tm=t} + | Tm_meta {tm=t} -> t_head_of t + | _ -> t + +let unembed_tactic_0 (eb:embedding 'b) (embedded_tac_b:term) (ncb:norm_cb) : tac 'b = + let! proof_state = get in + let rng = embedded_tac_b.pos in + + (* First, reify it from Tac a into __tac a *) + let embedded_tac_b = U.mk_reify embedded_tac_b (Some PC.effect_TAC_lid) in + + let tm = S.mk_Tm_app embedded_tac_b + [S.as_arg (embed rng proof_state ncb)] + rng in + + + // Why not HNF? While we don't care about strong reduction we need more than head + // normal form due to primitive steps. Consider `norm (steps 2)`: we need to normalize + // `steps 2` before caling norm, or it will fail to unembed the set of steps. Further, + // at this moment at least, the normalizer will not call into any step of arity > 1. + let steps = [Env.Weak; + Env.Reify; + Env.UnfoldUntil delta_constant; Env.DontUnfoldAttr [PC.tac_opaque_attr]; + Env.Primops; Env.Unascribe; + Env.Tactics] in + + // Maybe use NBE if the user asked for it + let norm_f = if Options.tactics_nbe () + then NBE.normalize + else N.normalize_with_primitive_steps + in + (* if proof_state.tac_verb_dbg then *) + (* BU.print1 "Starting normalizer with %s\n" (show tm); *) + let result = norm_f (primitive_steps ()) steps proof_state.main_context tm in + (* if proof_state.tac_verb_dbg then *) + (* BU.print1 "Reduced tactic: got %s\n" (show result); *) + + let res = unembed result ncb in + + match res with + | Some (Success (b, ps)) -> + set ps;! + return b + + | Some (Failed (e, ps)) -> + set ps;! + traise e + + | None -> + (* The tactic got stuck, try to provide a helpful error message. *) + let h_result = t_head_of result in + let open FStarC.Pprint in + let maybe_admit_tip : document = + (* Use the monadic visitor to check whether the reduced head + contains an admit, which is a common error *) + let r : option term = + Syntax.VisitM.visitM_term false (fun t -> + match t.n with + | Tm_fvar fv when fv_eq_lid fv PC.admit_lid -> None + | _ -> Some t) h_result + in + if None? r + then doc_of_string "The term contains an `admit`, which will not reduce. Did you mean `tadmit()`?" + else empty + in + Errors.raise_error proof_state.main_context Errors.Fatal_TacticGotStuck [ + doc_of_string "Tactic got stuck!"; + doc_of_string "Reduction stopped at: " ^^ pp h_result; + maybe_admit_tip + ] + +let unembed_tactic_nbe_0 (eb:NBET.embedding 'b) (cb:NBET.nbe_cbs) (embedded_tac_b:NBET.t) : tac 'b = + let! proof_state = get in + + (* Applying is normalizing!!! *) + let result = NBET.iapp_cb cb embedded_tac_b [NBET.as_arg (NBET.embed E.e_proofstate_nbe cb proof_state)] in + let res = NBET.unembed (E.e_result_nbe eb) cb result in + + match res with + | Some (Success (b, ps)) -> + set ps;! + return b + + | Some (Failed (e, ps)) -> + set ps;! + traise e + + | None -> + let open FStarC.Pprint in + Errors.raise_error proof_state.main_context Errors.Fatal_TacticGotStuck [ + doc_of_string "Tactic got stuck (in NBE)!"; + Errors.Msg.text "Please file a bug report with a minimal reproduction of this issue."; + doc_of_string "Result = " ^^ arbitrary_string (NBET.t_to_string result) + ] + +let unembed_tactic_1 (ea:embedding 'a) (er:embedding 'r) (f:term) (ncb:norm_cb) : 'a -> tac 'r = + fun x -> + let rng = FStarC.Compiler.Range.dummyRange in + let x_tm = embed rng x ncb in + let app = S.mk_Tm_app f [as_arg x_tm] rng in + unembed_tactic_0 er app ncb + +let unembed_tactic_nbe_1 (ea:NBET.embedding 'a) (er:NBET.embedding 'r) (cb:NBET.nbe_cbs) (f:NBET.t) : 'a -> tac 'r = + fun x -> + let x_tm = NBET.embed ea cb x in + let app = NBET.iapp_cb cb f [NBET.as_arg x_tm] in + unembed_tactic_nbe_0 er cb app + +let e_tactic_thunk (er : embedding 'r) : embedding (tac 'r) + = + mk_emb (fun _ _ _ _ -> failwith "Impossible: embedding tactic (thunk)?") + (fun t cb -> Some (unembed_tactic_1 e_unit er t cb ())) + (FStarC.Syntax.Embeddings.term_as_fv S.t_unit) + +let e_tactic_nbe_thunk (er : NBET.embedding 'r) : NBET.embedding (tac 'r) + = + NBET.mk_emb + (fun cb _ -> failwith "Impossible: NBE embedding tactic (thunk)?") + (fun cb t -> Some (unembed_tactic_nbe_1 NBET.e_unit er cb t ())) + (fun () -> NBET.mk_t (NBET.Constant NBET.Unit)) + (emb_typ_of unit) + +let e_tactic_1 (ea : embedding 'a) (er : embedding 'r) : embedding ('a -> tac 'r) + = + mk_emb (fun _ _ _ _ -> failwith "Impossible: embedding tactic (1)?") + (fun t cb -> Some (unembed_tactic_1 ea er t cb)) + (FStarC.Syntax.Embeddings.term_as_fv S.t_unit) + +let e_tactic_nbe_1 (ea : NBET.embedding 'a) (er : NBET.embedding 'r) : NBET.embedding ('a -> tac 'r) + = + NBET.mk_emb + (fun cb _ -> failwith "Impossible: NBE embedding tactic (1)?") + (fun cb t -> Some (unembed_tactic_nbe_1 ea er cb t)) + (fun () -> NBET.mk_t (NBET.Constant NBET.Unit)) + (emb_typ_of unit) + +let unembed_tactic_1_alt (ea:embedding 'a) (er:embedding 'r) (f:term) (ncb:norm_cb) : option ('a -> tac 'r) = + Some (fun x -> + let rng = FStarC.Compiler.Range.dummyRange in + let x_tm = embed rng x ncb in + let app = S.mk_Tm_app f [as_arg x_tm] rng in + unembed_tactic_0 er app ncb) + +let e_tactic_1_alt (ea: embedding 'a) (er:embedding 'r): embedding ('a -> (proofstate -> __result 'r)) = + let em = (fun _ _ _ _ -> failwith "Impossible: embedding tactic (1)?") in + let un (t0: term) (n: norm_cb): option ('a -> (proofstate -> __result 'r)) = + match unembed_tactic_1_alt ea er t0 n with + | Some f -> Some (fun x -> run (f x)) + | None -> None + in + mk_emb em un (FStarC.Syntax.Embeddings.term_as_fv t_unit) + +let report_implicits rng (is : TcRel.tagged_implicits) : unit = + let open FStarC.Pprint in + let open FStarC.Errors.Msg in + let open FStarC.Class.PP in + is |> List.iter + (fun (imp, tag) -> + match tag with + | TcRel.Implicit_unresolved + | TcRel.Implicit_checking_defers_univ_constraint -> + Errors.log_issue rng Err.Error_UninstantiatedUnificationVarInTactic [ + text "Tactic left uninstantiated unification variable:" ^/^ pp (imp.imp_uvar.ctx_uvar_head); + text "Type:" ^/^ pp (U.ctx_uvar_typ imp.imp_uvar); + text "Reason:" ^/^ dquotes (doc_of_string imp.imp_reason); + ] + | TcRel.Implicit_has_typing_guard (tm, ty) -> + Errors.log_issue rng Err.Error_UninstantiatedUnificationVarInTactic [ + text "Tactic solved goal:" ^/^ pp (imp.imp_uvar.ctx_uvar_head); + text "Type:" ^/^ pp (U.ctx_uvar_typ imp.imp_uvar); + text "To the term:" ^/^ pp tm; + text "But it has a non-trivial typing guard. Use gather_or_solve_explicit_guards_for_resolved_goals to inspect and prove these goals"; + ] + ); + Err.stop_if_err () + +let run_unembedded_tactic_on_ps + (rng_call : Range.range) + (rng_goal : Range.range) + (background : bool) + (arg : 'a) + (tau: 'a -> tac 'b) + (ps:proofstate) + : list goal // remaining goals + & 'b // return value + = + let ps = { ps with main_context = { ps.main_context with intactics = true } } in + let ps = { ps with main_context = { ps.main_context with range = rng_goal } } in + let env = ps.main_context in + (* if !dbg_Tac then *) + (* BU.print1 "Running tactic with goal = (%s) {\n" (show typ); *) + let res = + Profiling.profile + (fun () -> run_safe (tau arg) ps) + (Some (Ident.string_of_lid (Env.current_module ps.main_context))) + "FStarC.Tactics.Interpreter.run_safe" + in + if !dbg_Tac then + BU.print_string "}\n"; + + match res with + | Success (ret, ps) -> + if !dbg_Tac then + do_dump_proofstate ps "at the finish line"; + + (* if !dbg_Tac || Options.tactics_info () then *) + (* BU.print1 "Tactic generated proofterm %s\n" (show w); *) + let remaining_smt_goals = ps.goals@ps.smt_goals in + List.iter + (fun g -> + mark_goal_implicit_already_checked g;//all of these will be fed to SMT anyway + if is_irrelevant g + then ( + if !dbg_Tac then BU.print1 "Assigning irrelevant goal %s\n" (show (goal_witness g)); + if TcRel.teq_nosmt_force (goal_env g) (goal_witness g) U.exp_unit + then () + else failwith (BU.format1 "Irrelevant tactic witness does not unify with (): %s" + (show (goal_witness g))) + )) + remaining_smt_goals; + + // Check that all implicits were instantiated + Errors.with_ctx "While checking implicits left by a tactic" (fun () -> + if !dbg_Tac then + BU.print1 "About to check tactic implicits: %s\n" (FStarC.Common.string_of_list + (fun imp -> show imp.imp_uvar) + ps.all_implicits); + + let g = {Env.trivial_guard with TcComm.implicits=Listlike.from_list ps.all_implicits} in + let g = TcRel.solve_deferred_constraints env g in + if !dbg_Tac then + BU.print2 "Checked %s implicits (1): %s\n" + (show (List.length ps.all_implicits)) + (show ps.all_implicits); + let tagged_implicits = TcRel.resolve_implicits_tac env g in + if !dbg_Tac then + BU.print2 "Checked %s implicits (2): %s\n" + (show (List.length ps.all_implicits)) + (show ps.all_implicits); + report_implicits rng_goal tagged_implicits + ); + + (remaining_smt_goals, ret) + + (* Catch normal errors to add a "Tactic failed" at the top. *) + | Failed (Errors.Error (code, msg, rng, ctx), ps) -> + let msg = FStarC.Pprint.doc_of_string "Tactic failed" :: msg in + raise (Errors.Error (code, msg, rng, ctx)) + + (* Any other error, including exceptions being raised by the metaprograms. *) + | Failed (e, ps) -> + if ps.dump_on_failure then + do_dump_proofstate ps "at the time of failure"; + let open FStarC.Pprint in + let texn_to_doc e = + match e with + | TacticFailure msg -> + msg + | EExn t -> + [doc_of_string <| "Uncaught exception: " ^ (show t)], + None + | e -> + raise e + in + let doc, rng = texn_to_doc e in + let rng = + if background + then match ps.goals with + | g::_ -> g.goal_ctx_uvar.ctx_uvar_range + | _ -> rng_call + else match rng with + | Some r -> r + | _ -> ps.entry_range + in + let open FStarC.Pprint in + Err.raise_error rng Err.Fatal_UserTacticFailure + ((if ps.dump_on_failure then [doc_of_string "Tactic failed"] else []) @ doc) + +let run_tactic_on_ps' + (rng_call : Range.range) + (rng_goal : Range.range) + (background : bool) + (e_arg : embedding 'a) + (arg : 'a) + (e_res : embedding 'b) + (tactic:term) + (tactic_already_typed:bool) + (ps:proofstate) + : list goal // remaining goals + & 'b // return value + = + let env = ps.main_context in + if !dbg_Tac then + BU.print2 "Typechecking tactic: (%s) (already_typed: %s) {\n" + (show tactic) + (show tactic_already_typed); + + (* Do NOT use the returned tactic, the typechecker is not idempotent and + * will mess up the monadic lifts. We're just making sure it's well-typed + * so it won't get stuck. c.f #1307 *) + let g = + if tactic_already_typed + then Env.trivial_guard + else let _, _, g = TcTerm.tc_tactic (type_of e_arg) (type_of e_res) env tactic in + g + in + + if !dbg_Tac then + BU.print_string "}\n"; + + TcRel.force_trivial_guard env g; + Err.stop_if_err (); + let tau = unembed_tactic_1 e_arg e_res tactic FStarC.Syntax.Embeddings.id_norm_cb in + + run_unembedded_tactic_on_ps + rng_call rng_goal background + arg tau ps + +let run_tactic_on_ps + (rng_call : Range.range) + (rng_goal : Range.range) + (background : bool) + (e_arg : embedding 'a) + (arg : 'a) + (e_res : embedding 'b) + (tactic:term) + (tactic_already_typed:bool) + (ps:proofstate) = + Profiling.profile + (fun () -> run_tactic_on_ps' rng_call rng_goal background e_arg arg e_res tactic tactic_already_typed ps) + (Some (Ident.string_of_lid (Env.current_module ps.main_context))) + "FStarC.Tactics.Interpreter.run_tactic_on_ps" diff --git a/src/tactics/FStarC.Tactics.Interpreter.fsti b/src/tactics/FStarC.Tactics.Interpreter.fsti new file mode 100644 index 00000000000..afe9dfbd6c6 --- /dev/null +++ b/src/tactics/FStarC.Tactics.Interpreter.fsti @@ -0,0 +1,64 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Tactics.Interpreter + +open FStarC.Compiler.Effect +open FStarC.Compiler.Range +open FStarC.Syntax.Syntax +open FStarC.Syntax.Embeddings +open FStarC.Tactics.Types +module Env = FStarC.TypeChecker.Env + +(* Run a `tac` *) +val run_unembedded_tactic_on_ps : + range -> (* position on the tactic call *) + range -> (* position for the goal *) + bool -> (* whether this call is in the "background", like resolve_implicits *) + 'a -> + ('a -> Monad.tac 'b) -> (* a term representing an `'a -> tac 'b` *) + proofstate -> (* proofstate *) + list goal & 'b (* goals and return value *) + +(* Run a term of type `a -> Tac b` *) +val run_tactic_on_ps : + range -> (* position on the tactic call *) + range -> (* position for the goal *) + bool -> (* whether this call is in the "background", like resolve_implicits *) + embedding 'a -> + 'a -> + embedding 'b -> + term -> (* a term representing an `'a -> tac 'b` *) + bool -> (* true if the tactic term is already typechecked *) + proofstate -> (* proofstate *) + list goal & 'b (* goals and return value *) + +(* Only plugins *) +val native_tactics_steps : unit -> list FStarC.TypeChecker.Primops.primitive_step + +(* Plugins + primitives. *) +val primitive_steps : unit -> list FStarC.TypeChecker.Primops.primitive_step + +val report_implicits : range -> FStarC.TypeChecker.Rel.tagged_implicits -> unit + +(* Called by Main *) +val register_tactic_primitive_step : FStarC.TypeChecker.Primops.primitive_step -> unit + +open FStarC.Tactics.Monad +module NBET = FStarC.TypeChecker.NBETerm +val e_tactic_thunk (er : embedding 'r) : embedding (tac 'r) +val e_tactic_nbe_thunk (er : NBET.embedding 'r) : NBET.embedding (tac 'r) +val e_tactic_1 (ea : embedding 'a) (er : embedding 'r) : embedding ('a -> tac 'r) +val e_tactic_nbe_1 (ea : NBET.embedding 'a) (er : NBET.embedding 'r) : NBET.embedding ('a -> tac 'r) diff --git a/src/tactics/FStarC.Tactics.Monad.fst b/src/tactics/FStarC.Tactics.Monad.fst new file mode 100644 index 00000000000..72c096b7638 --- /dev/null +++ b/src/tactics/FStarC.Tactics.Monad.fst @@ -0,0 +1,464 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Tactics.Monad + +open FStar open FStarC +open FStarC.Compiler +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Syntax.Syntax +open FStarC.TypeChecker.Common +open FStarC.TypeChecker.Env +open FStarC.Tactics.Types +open FStarC.Tactics.Result +open FStarC.Tactics.Printing +open FStarC.Tactics.Common +open FStarC.Errors.Msg + +open FStarC.Class.Show +open FStarC.Class.Setlike +open FStarC.Class.Listlike +module Setlike = FStarC.Class.Setlike +module Listlike = FStarC.Class.Listlike + +module O = FStarC.Options +module BU = FStarC.Compiler.Util +module Err = FStarC.Errors +module Range = FStarC.Compiler.Range +module S = FStarC.Syntax.Syntax +module U = FStarC.Syntax.Util +module UF = FStarC.Syntax.Unionfind +module Print = FStarC.Syntax.Print +module Env = FStarC.TypeChecker.Env +module Rel = FStarC.TypeChecker.Rel +module Core = FStarC.TypeChecker.Core + +let dbg_Core = Debug.get_toggle "Core" +let dbg_CoreEq = Debug.get_toggle "CoreEq" +let dbg_RegisterGoal = Debug.get_toggle "RegisterGoal" +let dbg_TacFail = Debug.get_toggle "TacFail" + +let goal_ctr = BU.mk_ref 0 +let get_goal_ctr () = !goal_ctr +let incr_goal_ctr () = let v = !goal_ctr in goal_ctr := v + 1; v + +let is_goal_safe_as_well_typed (g:goal) = + let uv = g.goal_ctx_uvar in + let all_deps_resolved = + List.for_all + (fun uv -> + match UF.find uv.ctx_uvar_head with + | Some t -> Setlike.is_empty (FStarC.Syntax.Free.uvars t) + | _ -> false) + (U.ctx_uvar_typedness_deps uv) + in + all_deps_resolved + +let register_goal (g:goal) = + if not (Options.compat_pre_core_should_register()) then () else + let env = goal_env g in + if env.phase1 || Options.lax () then () else + let uv = g.goal_ctx_uvar in + let i = Core.incr_goal_ctr () in + if Allow_untyped? (U.ctx_uvar_should_check g.goal_ctx_uvar) then () else + let env = {env with gamma = uv.ctx_uvar_gamma } in + if !dbg_CoreEq + then BU.print1 "(%s) Registering goal\n" (show i); + let should_register = is_goal_safe_as_well_typed g in + if not should_register + then ( + if !dbg_Core || !dbg_RegisterGoal + then BU.print1 "(%s) Not registering goal since it has unresolved uvar deps\n" + (show i); + + () + ) + else ( + if !dbg_Core || !dbg_RegisterGoal + then BU.print2 "(%s) Registering goal for %s\n" + (show i) + (show uv); + let goal_ty = U.ctx_uvar_typ uv in + match FStarC.TypeChecker.Core.compute_term_type_handle_guards env goal_ty (fun _ _ -> true) + with + | Inl _ -> () // ghost is ok + | Inr err -> + let msg = + BU.format2 "Failed to check initial tactic goal %s because %s" + (show (U.ctx_uvar_typ uv)) + (FStarC.TypeChecker.Core.print_error_short err) + in + Errors.log_issue uv.ctx_uvar_range Err.Warning_FailedToCheckInitialTacticGoal msg + ) + +(* + * A record, so we can keep it somewhat encapsulated and + * can more easily add things to it if need be. + *) +type tac (a:Type0) = { + tac_f : proofstate -> __result a; +} + +let mk_tac (f : proofstate -> __result 'a) : tac 'a = + { tac_f = f } + +let run (t:tac 'a) (ps:proofstate) : __result 'a = + t.tac_f ps + +let run_safe t ps = + if Options.tactics_failhard () + then run t ps + else try run t ps + with | e -> Failed (e, ps) + +let ret (x:'a) : tac 'a = + mk_tac (fun ps -> Success (x, ps)) + +let bind (t1:tac 'a) (t2:'a -> tac 'b) : tac 'b = + mk_tac (fun ps -> + match run t1 ps with + | Success (a, q) -> run (t2 a) q + | Failed (msg, q) -> Failed (msg, q)) + +instance monad_tac : monad tac = { + return = ret; + ( let! ) = bind; +} + +(* Set the current proofstate *) +let set (ps:proofstate) : tac unit = + mk_tac (fun _ -> Success ((), ps)) + +(* Get the current proof state *) +let get : tac proofstate = + mk_tac (fun ps -> Success (ps, ps)) + +let traise e = + mk_tac (fun ps -> Failed (e, ps)) + +let do_log ps (f : unit -> unit) : unit = + if ps.tac_verb_dbg then + f () + +let log (f : unit -> unit) : tac unit = + mk_tac (fun ps -> + do_log ps f; + Success ((), ps)) + +let fail_doc (msg:error_message) = + mk_tac (fun ps -> + if !dbg_TacFail then + do_dump_proofstate ps ("TACTIC FAILING: " ^ renderdoc (hd msg)); + Failed (TacticFailure (msg, None), ps) + ) + +let fail msg = fail_doc [text msg] + +let catch (t : tac 'a) : tac (either exn 'a) = + mk_tac (fun ps -> + let idtable = !ps.main_context.identifier_info in + let tx = UF.new_transaction () in + match run t ps with + | Success (a, q) -> + UF.commit tx; + Success (Inr a, q) + | Failed (m, q) -> + UF.rollback tx; + ps.main_context.identifier_info := idtable; + let ps = { ps with freshness = q.freshness } in //propagate the freshness even on failures + Success (Inl m, ps) + ) + +let recover (t : tac 'a) : tac (either exn 'a) = + mk_tac (fun ps -> + match run t ps with + | Success (a, q) -> Success (Inr a, q) + | Failed (m, q) -> Success (Inl m, q) + ) + +let trytac (t : tac 'a) : tac (option 'a) = + bind (catch t) (fun r -> + match r with + | Inr v -> ret (Some v) + | Inl _ -> ret None) + +let trytac_exn (t : tac 'a) : tac (option 'a) = + mk_tac (fun ps -> + try run (trytac t) ps + with | Errors.Error (_, msg, _, _) -> + do_log ps (fun () -> BU.print1 "trytac_exn error: (%s)" (Errors.rendermsg msg)); + Success (None, ps)) + +let rec iter_tac f l = + match l with + | [] -> ret () + | hd::tl -> f hd ;! iter_tac f tl + +exception Bad of string + +(* private *) +let nwarn = BU.mk_ref 0 +let check_valid_goal g = + if Options.defensive () then begin + try + let env = (goal_env g) in + if not (Env.closed env (goal_witness g)) then + raise (Bad "witness"); + if not (Env.closed env (goal_type g)) then + raise (Bad "goal type"); + let rec aux e = + match Env.pop_bv e with + | None -> () + | Some (bv, e) -> + if not (Env.closed e bv.sort) then + raise (Bad ("bv: " ^ show bv)); + aux e + in + aux env + with + | Bad culprit -> + if !nwarn < 5 then begin + Err.log_issue (goal_type g) + Errors.Warning_IllFormedGoal + (BU.format2 "The following goal is ill-formed (%s). Keeping calm and carrying on...\n<%s>\n\n" culprit (goal_to_string_verbose g)); + nwarn := !nwarn + 1 + end + end + +let check_valid_goals (gs:list goal) : unit = + if Options.defensive () then + List.iter check_valid_goal gs + +let set_goals (gs:list goal) : tac unit = + bind get (fun ps -> + set ({ ps with goals = gs })) + +let set_smt_goals (gs:list goal) : tac unit = + bind get (fun ps -> + set ({ ps with smt_goals = gs })) + +let cur_goals : tac (list goal) = + bind get (fun ps -> + ret ps.goals) + +let cur_goal_maybe_solved + : tac goal + = bind cur_goals (function + | [] -> fail "No more goals" + | hd::tl -> ret hd) + +let cur_goal : tac goal = + bind cur_goals (function + | [] -> fail "No more goals" + | hd::tl -> + match check_goal_solved' hd with + | None -> ret hd + | Some t -> + BU.print2 "!!!!!!!!!!!! GOAL IS ALREADY SOLVED! %s\nsol is %s\n" + (goal_to_string_verbose hd) + (show t); + ret hd) + +let remove_solved_goals : tac unit = + bind cur_goals (fun gs -> + let gs = List.filter (fun g -> not (check_goal_solved g)) gs in + set_goals gs) + +let dismiss_all : tac unit = set_goals [] + +let dismiss : tac unit = + bind get (fun ps -> + set ({ps with goals=List.tl ps.goals})) + +let replace_cur (g:goal) : tac unit = + bind get (fun ps -> + check_valid_goal g; + set ({ps with goals=g::(List.tl ps.goals)})) + +let getopts : tac FStarC.Options.optionstate = + bind (trytac cur_goal_maybe_solved) (function + | Some g -> ret g.opts + | None -> ret (FStarC.Options.peek ())) + +(* Some helpers to add goals, while also perhaps checking + * that they are well formed (see check_valid_goal and + * the --defensive debugging option. *) +let add_goals (gs:list goal) : tac unit = + bind get (fun ps -> + check_valid_goals gs; + set ({ps with goals=gs@ps.goals})) + +let add_smt_goals (gs:list goal) : tac unit = + bind get (fun ps -> + check_valid_goals gs; + set ({ps with smt_goals=gs@ps.smt_goals})) + +let push_goals (gs:list goal) : tac unit = + bind get (fun ps -> + check_valid_goals gs; + set ({ps with goals=ps.goals@gs})) + +let push_smt_goals (gs:list goal) : tac unit = + bind get (fun ps -> + check_valid_goals gs; + set ({ps with smt_goals=ps.smt_goals@gs})) +(* /helpers *) + +let add_implicits (i:implicits) : tac unit = + bind get (fun ps -> + set ({ps with all_implicits=i@ps.all_implicits})) + +let new_uvar (reason:string) (env:env) (typ:typ) + (sc_opt:option should_check_uvar) + (uvar_typedness_deps:list ctx_uvar) + (rng:Range.range) + : tac (term & ctx_uvar) = + let should_check = + match sc_opt with + | Some sc -> sc + | _ -> Strict + in + let u, ctx_uvar, g_u = + Env.new_tac_implicit_var reason rng env typ should_check uvar_typedness_deps None false + in + bind (add_implicits (Listlike.to_list g_u.implicits)) (fun _ -> + ret (u, fst ctx_uvar)) + +let mk_irrelevant_goal (reason:string) (env:env) (phi:typ) (sc_opt:option should_check_uvar) (rng:Range.range) opts label : tac goal = + let typ = U.mk_squash (env.universe_of env phi) phi in + bind (new_uvar reason env typ sc_opt [] rng) (fun (_, ctx_uvar) -> + let goal = mk_goal env ctx_uvar opts false label in + ret goal) + +let add_irrelevant_goal' (reason:string) (env:Env.env) + (phi:term) + (sc_opt:option should_check_uvar) + (rng:Range.range) + (opts:FStarC.Options.optionstate) + (label:string) : tac unit = + bind (mk_irrelevant_goal reason env phi sc_opt rng opts label) (fun goal -> + add_goals [goal]) + +let add_irrelevant_goal (base_goal:goal) (reason:string) + (env:Env.env) (phi:term) + (sc_opt:option should_check_uvar) : tac unit = + add_irrelevant_goal' reason env phi sc_opt + base_goal.goal_ctx_uvar.ctx_uvar_range + base_goal.opts base_goal.label + +let goal_of_guard (reason:string) (e:Env.env) + (f:term) (sc_opt:option should_check_uvar) + (rng:Range.range) : tac goal = + bind getopts (fun opts -> + bind (mk_irrelevant_goal reason e f sc_opt rng opts "") (fun goal -> + let goal = { goal with is_guard = true } in + ret goal)) + +let wrap_err_doc (pref:error_message) (t : tac 'a) : tac 'a = + mk_tac (fun ps -> + match run t ps with + | Success (a, q) -> + Success (a, q) + + | Failed (TacticFailure (msg, r), q) -> + Failed (TacticFailure (pref @ msg, r), q) + + | Failed (e, q) -> + Failed (e, q) + ) + +let wrap_err (pref:string) (t : tac 'a) : tac 'a = + wrap_err_doc [text ("'" ^ pref ^ "' failed")] t + +let mlog f (cont : unit -> tac 'a) : tac 'a = + log f;! + cont () + +let if_verbose_tac f = + let! ps = get in + if ps.tac_verb_dbg + then f () + else ret () + +let if_verbose f = if_verbose_tac (fun _ -> f(); ret ()) + +let compress_implicits : tac unit = + bind get (fun ps -> + let imps = ps.all_implicits in + let g = { Env.trivial_guard with implicits = Listlike.from_list imps } in + let imps = Rel.resolve_implicits_tac ps.main_context g in + let ps' = { ps with all_implicits = List.map fst imps } in + set ps') + +module N = FStarC.TypeChecker.Normalize +let get_phi (g:goal) : option term = U.un_squash (N.unfold_whnf (goal_env g) (goal_type g)) +let is_irrelevant (g:goal) : bool = Option.isSome (get_phi g) +let goal_typedness_deps (g:goal) = U.ctx_uvar_typedness_deps g.goal_ctx_uvar + +let set_uvar_expected_typ (u:ctx_uvar) (t:typ) + : unit + = let dec = UF.find_decoration u.ctx_uvar_head in + UF.change_decoration u.ctx_uvar_head ({dec with uvar_decoration_typ = t }) + +let mark_uvar_with_should_check_tag (u:ctx_uvar) (sc:should_check_uvar) + : unit + = let dec = UF.find_decoration u.ctx_uvar_head in + UF.change_decoration u.ctx_uvar_head ({dec with uvar_decoration_should_check = sc }) + +let mark_uvar_as_already_checked (u:ctx_uvar) + : unit + = mark_uvar_with_should_check_tag u Already_checked + +let mark_goal_implicit_already_checked (g:goal) + : unit + = mark_uvar_as_already_checked g.goal_ctx_uvar + +let goal_with_type g t + : goal + = let u = g.goal_ctx_uvar in + set_uvar_expected_typ u t; + g + +module Z = FStarC.BigInt + +let divide (n:Z.t) (l : tac 'a) (r : tac 'b) : tac ('a & 'b) = + let! p = get in + let! lgs, rgs = + try return (List.splitAt (Z.to_int_fs n) p.goals) with + | _ -> fail "divide: not enough goals" + in + let lp = { p with goals = lgs; smt_goals = [] } in + set lp;! + let! a = l in + let! lp' = get in + let rp = { lp' with goals = rgs; smt_goals = [] } in + set rp;! + let! b = r in + let! rp' = get in + let p' = { rp' with goals = lp'.goals @ rp'.goals; + smt_goals = lp'.smt_goals @ rp'.smt_goals @ p.smt_goals } + in + set p';! + remove_solved_goals;! + return (a, b) + +(* focus: runs f on the current goal only, and then restores all the goals *) +(* There is a user defined version as well, we just use this one internally, but can't mark it as private *) +let focus (f:tac 'a) : tac 'a = + let! (a, _) = divide FStarC.BigInt.one f (return ()) in + return a diff --git a/src/tactics/FStarC.Tactics.Monad.fsti b/src/tactics/FStarC.Tactics.Monad.fsti new file mode 100644 index 00000000000..abfd2d0180e --- /dev/null +++ b/src/tactics/FStarC.Tactics.Monad.fsti @@ -0,0 +1,173 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Tactics.Monad +open FStarC +open FStar.Pervasives +open FStarC.Syntax.Syntax +open FStarC.TypeChecker.Env +open FStarC.Tactics.Result +open FStarC.Tactics.Types +open FStarC.Class.Monad +open FStarC.Errors.Msg + +module Range = FStarC.Compiler.Range +module BU = FStarC.Compiler.Util +module O = FStarC.Options + +(* Type of tactics *) +val tac (a:Type0) : Type0 + +instance val monad_tac : monad tac + +(* Simply unpack and run *) +val run : tac 'a -> proofstate -> __result 'a + +(* Run, but catch exceptions as errors within the monad *) +val run_safe : tac 'a -> proofstate -> __result 'a + +(* Get current proofstate *) +val get : tac proofstate + +(* Get first goal *) +val cur_goal : tac goal + +(* Raise an exception *) +val traise : exn -> tac 'a + +(* A common failure. *) +val fail_doc : error_message -> tac 'a + +(* A common failure. *) +val fail : string -> tac 'a + +(* Catch exceptions, restore UF graph on a failure *) +val catch : tac 'a -> tac (either exn 'a) + +(* Catch exceptions, but keep UF graph at the time of the failure *) +val recover : tac 'a -> tac (either exn 'a) + +(* Try running a tactic. If it fails, return None. *) +val trytac : tac 'a -> tac (option 'a) + +(* As [trytac], but also catches exceptions and turns them into [None]. *) +val trytac_exn : tac 'a -> tac (option 'a) + +(* iter combinator *) +val iter_tac (f: 'a -> tac unit) (l:list 'a) : tac unit + +(* Defensive checks. Will only do anything if --defensive is on. If so, +and some goal is ill-scoped, they will log a warning. *) +val check_valid_goal (g:goal) : unit +val check_valid_goals (gs:list goal) : unit + +(* Set the current set of goals / SMT goals *) +val set_goals : list goal -> tac unit +val set_smt_goals : list goal -> tac unit + +(* Add goals to the beginning of the list *) +val add_goals : list goal -> tac unit +val add_smt_goals : list goal -> tac unit + +(* Add goals to the end of the list *) +val push_goals : list goal -> tac unit +val push_smt_goals : list goal -> tac unit + +(* Drop the first goal *) +val dismiss : tac unit + +(* Drop all (non-SMT) goals *) +val dismiss_all : tac unit + +(* Replace the current goal with another *) +val replace_cur : goal -> tac unit + +(* Get the option state for the current goal, or the global one +if there are no goals. *) +val getopts : tac FStarC.Options.optionstate + +(* Add an implicit to the proofstate. The [all_implicits] field + * is the only place where we keep track of open goals that need + * to be solved. The [goals] and [smt_goals] fields are user-facing, + * and do not really matter for correctness. *) +val add_implicits : implicits -> tac unit + +(* Create a new uvar, and keep track of it in the proofstate to + * ensure we solve it. *) +val new_uvar : string -> env -> typ -> option should_check_uvar -> list ctx_uvar -> Range.range -> tac (term & ctx_uvar) + +(* Create a squashed goal from a given formula *) +val mk_irrelevant_goal : string -> env -> typ -> option should_check_uvar -> Range.range -> O.optionstate -> string -> tac goal + +(* Create an add an irrelevant goal, allows to set options and label *) +val add_irrelevant_goal' : string -> env -> typ -> option should_check_uvar -> Range.range -> O.optionstate -> string -> tac unit + +(* Create an add an irrelevant goal, taking a [base_goal] as a template for + * options and label (which seldom need to be changed) *) +val add_irrelevant_goal : goal -> string -> env -> typ -> option should_check_uvar -> tac unit + +(* Create a goal from a typechecking guard. *) +val goal_of_guard : string -> env -> term -> option should_check_uvar -> Range.range -> tac goal + +(* Run a tactic [t], and if it fails with a [TacticFailure] exception, + * add a prefix to the error message. *) +val wrap_err_doc : pref:error_message -> tac 'a -> tac 'a + +(* Run a tactic [t], and if it fails with a [TacticFailure] exception, + * add a small string prefix to the first component of the error. *) +val wrap_err : pref:string -> tac 'a -> tac 'a + +(* Call a (logging) function is verbose debugging is on *) +val log : (unit -> unit) -> tac unit + +(* As above, but as a tac<> with an implicit bind for brevity (in code that does use +monadic notation...) *) +val mlog : (unit -> unit) -> (unit -> tac 'a) -> tac 'a + +val if_verbose_tac: (unit -> tac unit) -> tac unit +val if_verbose: (unit -> unit) -> tac unit + +(* Discard the implicits in the proofstate that are already + * solved, only matters for performance. *) +val compress_implicits : tac unit + +(* Only leave goals that are unsolved in the main list *) +val remove_solved_goals : tac unit + +val is_goal_safe_as_well_typed (g:goal) : bool + +(* DANGER AHEAD, DO NOT USE *) + +(* Set the proofstate *) +val set : proofstate -> tac unit + +(* Create a tactic *) +val mk_tac : (proofstate -> __result 'a) -> tac 'a + +(* inform the core of a well-typed goal *) +val register_goal (g:goal) : unit + +val divide (n:BigInt.t) (l : tac 'a) (r : tac 'b) : tac ('a & 'b) +val focus (f:tac 'a) : tac 'a + +(* Internal utilities *) +val get_phi : goal -> option term +val is_irrelevant : goal -> bool +val goal_typedness_deps : goal -> list ctx_uvar +val set_uvar_expected_typ (u:ctx_uvar) (t:typ) : unit +val mark_uvar_with_should_check_tag (u:ctx_uvar) (sc:should_check_uvar) : unit +val mark_uvar_as_already_checked (u:ctx_uvar) : unit +val mark_goal_implicit_already_checked (g:goal) : unit +val goal_with_type : goal -> typ -> goal diff --git a/src/tactics/FStarC.Tactics.Native.fsti b/src/tactics/FStarC.Tactics.Native.fsti new file mode 100644 index 00000000000..50093086f3f --- /dev/null +++ b/src/tactics/FStarC.Tactics.Native.fsti @@ -0,0 +1,35 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Tactics.Native + +open FStarC.Compiler.Range +open FStarC.Syntax.Syntax +open FStarC.Tactics.Types + +module Cfg = FStarC.TypeChecker.Cfg +module N = FStarC.TypeChecker.Normalize +module PO = FStarC.TypeChecker.Primops + +type itac = PO.psc -> FStarC.Syntax.Embeddings.norm_cb -> universes -> args -> option term + +type native_primitive_step = + { name: FStarC.Ident.lid; + arity: Prims.int; + strong_reduction_ok: bool; + tactic: itac} + +val list_all : unit -> list native_primitive_step diff --git a/src/tactics/FStarC.Tactics.Printing.fst b/src/tactics/FStarC.Tactics.Printing.fst new file mode 100644 index 00000000000..d5b2f6c816c --- /dev/null +++ b/src/tactics/FStarC.Tactics.Printing.fst @@ -0,0 +1,176 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Tactics.Printing + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Ident +open FStarC.Syntax.Syntax +open FStarC.TypeChecker.Common +open FStarC.TypeChecker.Env +open FStarC.Tactics.Types +open FStarC.Class.Show + +module BU = FStarC.Compiler.Util +module Range = FStarC.Compiler.Range +module Options = FStarC.Options +module Print = FStarC.Syntax.Print +module SS = FStarC.Syntax.Subst +module S = FStarC.Syntax.Syntax +module Env = FStarC.TypeChecker.Env +module U = FStarC.Syntax.Util +module Cfg = FStarC.TypeChecker.Cfg +module PO = FStarC.TypeChecker.Primops + +let dbg_Imp = Debug.get_toggle "Imp" + +let term_to_string (e:Env.env) (t:term) : string = + Print.term_to_string' e.dsenv t + +let goal_to_string_verbose (g:goal) : string = + BU.format2 "%s%s\n" + (show g.goal_ctx_uvar) + (match check_goal_solved' g with + | None -> "" + | Some t -> BU.format1 "\tGOAL ALREADY SOLVED!: %s" (term_to_string (goal_env g) t)) + +let unshadow (bs : binders) (t : term) : binders & term = + (* string name of a bv *) + let sset bv s = S.gen_bv s (Some (range_of_id bv.ppname)) bv.sort in + let fresh_until b f = + let rec aux i = + let t = b ^ "'" ^ show i in + if f t then t else aux (i+1) + in + if f b then b else aux 0 + in + let rec go seen subst bs bs' t = + match bs with + | [] -> List.rev bs', SS.subst subst t + | b::bs -> begin + let b = match SS.subst_binders subst [b] with + | [b] -> b + | _ -> failwith "impossible: unshadow subst_binders" + in + let (bv0, q) = b.binder_bv, b.binder_qual in + let nbs = fresh_until (show bv0.ppname) (fun s -> not (List.mem s seen)) in + let bv = sset bv0 nbs in + let b = S.mk_binder_with_attrs bv q b.binder_positivity b.binder_attrs in + go (nbs::seen) (subst @ [NT (bv0, S.bv_to_name bv)]) bs (b :: bs') t + end + in + go [] [] bs [] t + +let goal_to_string (kind : string) (maybe_num : option (int & int)) (ps:proofstate) (g:goal) : string = + let w = + if Options.print_implicits () + then term_to_string (goal_env g) (goal_witness g) + else match check_goal_solved' g with + | None -> "_" + | Some t -> term_to_string (goal_env g) (goal_witness g) (* shouldn't really happen that we print a solved goal *) + in + let num = match maybe_num with + | None -> "" + | Some (i, n) -> BU.format2 " %s/%s" (show i) (show n) + in + let maybe_label = + match g.label with + | "" -> "" + | l -> " (" ^ l ^ ")" + in + let goal_binders, goal_ty = + let rename_binders subst bs = + bs |> List.map (function b -> + let x = b.binder_bv in + let y = SS.subst subst (S.bv_to_name x) in + match (SS.compress y).n with + | Tm_name y -> + // We don't want to change the type + { b with binder_bv = { b.binder_bv with sort = SS.subst subst x.sort } } + | _ -> failwith "Not a renaming") + in + let goal_binders = g.goal_ctx_uvar.ctx_uvar_binders in + let goal_ty = goal_type g in + if Options.tactic_raw_binders() + then goal_binders, goal_ty + else ( + let subst = PO.psc_subst ps.psc in + let binders = rename_binders subst goal_binders in + let ty = SS.subst subst goal_ty in + binders, ty + ) + in + let goal_binders, goal_ty = unshadow goal_binders goal_ty in + let actual_goal = + if ps.tac_verb_dbg + then goal_to_string_verbose g + else BU.format3 "%s |- %s : %s\n" (String.concat ", " (map Print.binder_to_string_with_type goal_binders)) + w + (term_to_string (goal_env g) goal_ty) + in + BU.format4 "%s%s%s:\n%s\n" kind num maybe_label actual_goal + +(* Note: we use def ranges. In tactics we keep the position in there, while the + * use range is the original position of the assertion / synth / splice. *) +let ps_to_string (msg, ps) = + let p_imp imp = show imp.imp_uvar.ctx_uvar_head in + let n_active = List.length ps.goals in + let n_smt = List.length ps.smt_goals in + let n = n_active + n_smt in + String.concat "" + ([BU.format2 "State dump @ depth %s (%s):\n" (show ps.depth) msg; + (if ps.entry_range <> Range.dummyRange + then BU.format1 "Location: %s\n" (Range.string_of_def_range ps.entry_range) + else ""); + (if !dbg_Imp + then BU.format1 "Imps: %s\n" (FStarC.Common.string_of_list p_imp ps.all_implicits) + else "")] + @ (List.mapi (fun i g -> goal_to_string "Goal" (Some (1 + i, n)) ps g) ps.goals) + @ (List.mapi (fun i g -> goal_to_string "SMT Goal" (Some (1 + n_active + i, n)) ps g) ps.smt_goals)) + +let goal_to_json g = + let open FStarC.Json in + let g_binders = g.goal_ctx_uvar.ctx_uvar_binders in + let g_type = goal_type g in + let g_binders, g_type = unshadow g_binders g_type in + let j_binders = Print.binders_to_json (Env.dsenv (goal_env g)) g_binders in + JsonAssoc [("hyps", j_binders); + ("goal", JsonAssoc [("witness", JsonStr (term_to_string (goal_env g) (goal_witness g))); + ("type", JsonStr (term_to_string (goal_env g) g_type)); + ("label", JsonStr g.label) + ])] + +let ps_to_json (msg, ps) = + let open FStarC.Json in + JsonAssoc ([("label", JsonStr msg); + ("depth", JsonInt ps.depth); + ("urgency", JsonInt ps.urgency); + ("goals", JsonList (List.map goal_to_json ps.goals)); + ("smt-goals", JsonList (List.map goal_to_json ps.smt_goals))] @ + (if ps.entry_range <> Range.dummyRange + then [("location", Range.json_of_def_range ps.entry_range)] + else [])) + +let do_dump_proofstate ps msg = + if not (Options.silent ()) then + Options.with_saved_options (fun () -> + Options.set_option "print_effect_args" (Options.Bool true); + print_generic "proof-state" ps_to_string ps_to_json (msg, ps); + BU.flush_stdout () (* in case this is going to stdout, flush it immediately *) + ) diff --git a/src/tactics/FStarC.Tactics.Printing.fsti b/src/tactics/FStarC.Tactics.Printing.fsti new file mode 100644 index 00000000000..026b068bd8b --- /dev/null +++ b/src/tactics/FStarC.Tactics.Printing.fsti @@ -0,0 +1,26 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Tactics.Printing + +open FStarC.Tactics.Types + +(* Dump a proofstate into the CLI or Emacs *) +val do_dump_proofstate : proofstate -> string -> unit + +(* Only for deubgging *) +val goal_to_string : string -> option (int & int) -> proofstate -> goal -> string +val goal_to_string_verbose : goal -> string diff --git a/src/tactics/FStarC.Tactics.Result.fst b/src/tactics/FStarC.Tactics.Result.fst new file mode 100644 index 00000000000..f08c04c1989 --- /dev/null +++ b/src/tactics/FStarC.Tactics.Result.fst @@ -0,0 +1,33 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Tactics.Result + +(* NOTE: This file is exactly the same as its .fs/.fsi counterpart. +It is only here so the equally-named interface file in ulib/ is not +taken by the dependency analysis to be the interface of the .fs. We also +cannot ditch the .fs, since out bootstrapping process does not extract +any .ml file from an interface. Hence we keep both, exactly equal to +each other. *) + +// This file *is* extracted (unlike its twin in ulib). + +// This refers to FStarC.Tactics.Types.fsi in the current folder, which has the +// full definition of all relevant types (from ulib, we use an different +// interface that hides those definitions). +open FStarC.Tactics.Types + +let proofstate = FStarC.Tactics.Types.proofstate diff --git a/src/tactics/FStarC.Tactics.Result.fsti b/src/tactics/FStarC.Tactics.Result.fsti new file mode 100644 index 00000000000..fde2e5eea24 --- /dev/null +++ b/src/tactics/FStarC.Tactics.Result.fsti @@ -0,0 +1,35 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Tactics.Result + +(* NOTE: This file is exactly the same as its .fs/.fsi counterpart. +It is only here so the equally-named interface file in ulib/ is not +taken by the dependency analysis to be the interface of the .fs. We also +cannot ditch the .fs, since out bootstrapping process does not extract +any .ml file from an interface. Hence we keep both, exactly equal to +each other. *) + +// This file *is* extracted (unlike its twin in ulib). + +// This refers to FStarC.Tactics.Types.fsi in the current folder, which has the +// full definition of all relevant types (from ulib, we use an different +// interface that hides those definitions). +open FStarC.Tactics.Types + +type __result 'a = + | Success of 'a & proofstate + | Failed of exn //error + & proofstate //the proofstate at time of failure diff --git a/src/tactics/FStarC.Tactics.Types.fst b/src/tactics/FStarC.Tactics.Types.fst new file mode 100644 index 00000000000..32eede7b62f --- /dev/null +++ b/src/tactics/FStarC.Tactics.Types.fst @@ -0,0 +1,108 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Tactics.Types + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Syntax.Syntax +open FStarC.TypeChecker.Env +open FStarC.TypeChecker.Common + +module Env = FStarC.TypeChecker.Env +module O = FStarC.Options +module Range = FStarC.Compiler.Range +module U = FStarC.Syntax.Util + +let goal_env g = g.goal_main_env +let goal_range g = g.goal_main_env.range +let goal_witness g = + FStarC.Syntax.Syntax.mk (Tm_uvar (g.goal_ctx_uvar, ([], NoUseRange))) Range.dummyRange +let goal_type g = U.ctx_uvar_typ g.goal_ctx_uvar +let goal_opts g = g.opts + +let goal_with_env g env : goal = + let c = g.goal_ctx_uvar in + let c' = {c with ctx_uvar_gamma = env.gamma ; ctx_uvar_binders = Env.all_binders env } in + { g with goal_main_env=env; goal_ctx_uvar = c' } + +(* Unsafe? *) +let goal_of_ctx_uvar (g:goal) (ctx_u : ctx_uvar) : goal = + { g with goal_ctx_uvar = ctx_u } + +let mk_goal env u o b l = { + goal_main_env=env; + goal_ctx_uvar=u; + opts=o; + is_guard=b; + label=l; +} + +let goal_of_goal_ty env typ : goal & guard_t = + let u, (ctx_uvar, _) , g_u = + Env.new_implicit_var_aux "proofstate_of_goal_ty" typ.pos env typ Strict None false + in + let g = mk_goal env ctx_uvar (FStarC.Options.peek()) false "" in + g, g_u + +let goal_of_implicit env (i:Env.implicit) : goal = + mk_goal ({env with gamma=i.imp_uvar.ctx_uvar_gamma}) i.imp_uvar (FStarC.Options.peek()) false i.imp_reason + +let decr_depth (ps:proofstate) : proofstate = + { ps with depth = ps.depth - 1 } + +let incr_depth (ps:proofstate) : proofstate = + { ps with depth = ps.depth + 1 } + +let set_ps_psc psc ps = { ps with psc = psc } + +let tracepoint_with_psc psc ps : bool = + if O.tactic_trace () || (ps.depth <= O.tactic_trace_d ()) then begin + let ps = set_ps_psc psc ps in + ps.__dump ps "TRACE" + end; + true + +let tracepoint ps : bool = + if O.tactic_trace () || (ps.depth <= O.tactic_trace_d ()) then begin + ps.__dump ps "TRACE" + end; + true + +let set_proofstate_range ps r = + { ps with entry_range = Range.set_def_range ps.entry_range (Range.def_range r) } + +let goals_of ps : list goal = ps.goals +let smt_goals_of ps : list goal = ps.smt_goals + +let is_guard g = g.is_guard + +let get_label g = g.label +let set_label l g = { g with label = l } + +let check_goal_solved' goal = + match FStarC.Syntax.Unionfind.find goal.goal_ctx_uvar.ctx_uvar_head with + | Some t -> Some t + | None -> None + +let check_goal_solved goal = + Option.isSome (check_goal_solved' goal) + +let non_informative_token (g:env) (t:typ) = unit +let subtyping_token (g:env) (t0 t1:typ) = unit +let equiv_token (g:env) (t0 t1:typ) = unit +let typing_token (g:env) (e:term) (c:Core.tot_or_ghost & typ) = unit +let match_complete_token (g:env) (sc:term) (t:typ) (pats:list pattern) = unit diff --git a/src/tactics/FStarC.Tactics.Types.fsti b/src/tactics/FStarC.Tactics.Types.fsti new file mode 100644 index 00000000000..e598c4ba5f3 --- /dev/null +++ b/src/tactics/FStarC.Tactics.Types.fsti @@ -0,0 +1,133 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Tactics.Types + +open FStarC +open FStarC.Compiler.Effect +open FStarC.Syntax.Syntax +open FStarC.TypeChecker.Env +open FStarC.Tactics.Common + +module BU = FStarC.Compiler.Util +module Cfg = FStarC.TypeChecker.Cfg +module Core = FStarC.TypeChecker.Core +module PO = FStarC.TypeChecker.Primops +module Range = FStarC.Compiler.Range + +(* + f: x:int -> P + ================== + P + *) +//A goal is typically of the form +// G |- ?u : t +// where context = G +// witness = ?u, although, more generally, witness is a partial solution and can be any term +// goal_ty = t +type goal = { + goal_main_env: env; + goal_ctx_uvar : ctx_uvar; + opts : FStarC.Options.optionstate; // option state for this particular goal + is_guard : bool; // Marks whether this goal arose from a guard during tactic runtime + // We make the distinction to be more user-friendly at times + label : string; // A user-defined description +} +type guard_policy = + | Goal + | SMT + | SMTSync + | Force + | ForceSMT + | Drop // unsound + +type proofstate = { + main_context : env; //the shared top-level context for all goals + all_implicits: implicits ; //all the implicits currently open, partially resolved + + // NOTE: Goals are user-settable, the "goals" we mean in + // the paper are the implicits above, these are simply a + // way for primitives to take/give goals, and a way + // to have the SMT goal set. What we should really do + // is go full-LCF and take them as arguments, returning them + // as values. This goal stack should be user-level. + goals : list goal; //all the goals remaining to be solved + smt_goals : list goal; //goals that have been deferred to SMT + + depth : int; //depth for tracing and debugging + __dump : proofstate -> string -> unit; // callback to dump_proofstate, to avoid an annoying circularity + psc : PO.psc; //primitive step context where we started execution + entry_range : Range.range; //position of entry, set by the use + guard_policy : guard_policy; //guard policy: what to do with guards arising during tactic exec + freshness : int; //a simple freshness counter for the fresh tactic + tac_verb_dbg : bool; //whether to print verbose debugging messages + + local_state : BU.psmap term; // local metaprogram state + + urgency : int; // When printing a proofstate due to an error, this + // is used by emacs to decide whether it should pop + // open a buffer or not (default: 1). + + dump_on_failure : bool; // Whether to dump the proofstate to the user when a failure occurs. +} + +val decr_depth : proofstate -> proofstate +val incr_depth : proofstate -> proofstate +val tracepoint_with_psc : PO.psc -> proofstate -> bool +val tracepoint : proofstate -> bool +val set_proofstate_range : proofstate -> Range.range -> proofstate + +val set_ps_psc : PO.psc -> proofstate -> proofstate +val goal_env: goal -> env +val goal_range: goal -> Range.range +val goal_witness: goal -> term +val goal_type: goal -> term +val goal_opts: goal -> Options.optionstate +val goal_with_env: goal -> env -> goal +val is_guard : goal -> bool + +val get_label : goal -> string +val set_label : string -> goal -> goal + +val goals_of : proofstate -> list goal +val smt_goals_of : proofstate -> list goal + +val mk_goal: env -> ctx_uvar -> FStarC.Options.optionstate -> bool -> string -> goal + +val goal_of_goal_ty : env -> typ -> goal & guard_t +val goal_of_implicit : env -> implicit -> goal +val goal_of_ctx_uvar: goal -> ctx_uvar -> goal + +type ctrl_flag = + | Continue + | Skip + | Abort + +type direction = + | TopDown + | BottomUp + +val check_goal_solved' : goal -> option term +val check_goal_solved : goal -> bool + +type tref (a:Type) = ref a + +(*** These are here for userspace, the library has an interface into this module. *) +(* Typing reflection *) +val non_informative_token (g:env) (t:typ) : Type0 +val subtyping_token (g:env) (t0 t1:typ) : Type0 +val equiv_token (g:env) (t0 t1:typ) : Type0 +val typing_token (g:env) (e:term) (c:Core.tot_or_ghost & typ) : Type0 +val match_complete_token (g:env) (sc:term) (t:typ) (pats:list pattern) : Type0 diff --git a/src/tactics/FStarC.Tactics.V1.Basic.fst b/src/tactics/FStarC.Tactics.V1.Basic.fst new file mode 100644 index 00000000000..d010882ad68 --- /dev/null +++ b/src/tactics/FStarC.Tactics.V1.Basic.fst @@ -0,0 +1,2342 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Tactics.V1.Basic + +open FStar open FStarC +open FStarC.Compiler +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Compiler.Util +open FStarC.Ident +open FStarC.TypeChecker.Env +open FStarC.TypeChecker.Common +open FStarC.Reflection.V1.Data +open FStarC.Reflection.V1.Builtins +open FStarC.Tactics.Result +open FStarC.Tactics.Types +open FStarC.Tactics.Monad +open FStarC.Tactics.Printing +open FStarC.Syntax.Syntax +open FStarC.VConfig +open FStarC.Class.Show +open FStarC.Class.Tagged +module Listlike = FStarC.Class.Listlike + +friend FStar.Pervasives (* to use Delta below *) + +module BU = FStarC.Compiler.Util +module Cfg = FStarC.TypeChecker.Cfg +module EMB = FStarC.Syntax.Embeddings +module Env = FStarC.TypeChecker.Env +module Err = FStarC.Errors +module N = FStarC.TypeChecker.Normalize +module PC = FStarC.Parser.Const +module Print = FStarC.Syntax.Print +module Free = FStarC.Syntax.Free +module Rel = FStarC.TypeChecker.Rel +module SF = FStarC.Syntax.Free +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module SC = FStarC.Syntax.Compress +module TcComm = FStarC.TypeChecker.Common +module TcTerm = FStarC.TypeChecker.TcTerm +module TcUtil = FStarC.TypeChecker.Util +module UF = FStarC.Syntax.Unionfind +module U = FStarC.Syntax.Util +module Z = FStarC.BigInt +module Core = FStarC.TypeChecker.Core +module PO = FStarC.TypeChecker.Primops + +open FStarC.Class.Monad +open FStarC.Class.Setlike + +let dbg_2635 = Debug.get_toggle "2635" +let dbg_ReflTc = Debug.get_toggle "ReflTc" +let dbg_Tac = Debug.get_toggle "Tac" +let dbg_TacUnify = Debug.get_toggle "TacUnify" + +let ret #a (x:a) : tac a = return x +let bind #a #b : tac a -> (a -> tac b) -> tac b = ( let! ) +let idtac : tac unit = return () +(* This is so we can use the monad class. But we don't want to +rewrite this whole (deprecated) file. *) + +(* Internal, repeated from V2 too. Could be in Types, but that +constrains dependencies and F* claims a cycle. *) +let get_phi (g:goal) : option term = U.un_squash (N.unfold_whnf (goal_env g) (goal_type g)) +let is_irrelevant (g:goal) : bool = Option.isSome (get_phi g) + +let core_check env sol t must_tot + : either (option typ) Core.error + = if not (Options.compat_pre_core_should_check()) then Inl None else + let debug f = + if Debug.any() + then f () + else () + in + match FStarC.TypeChecker.Core.check_term env sol t must_tot with + | Inl None -> + Inl None + + | Inl (Some g) -> + if Options.compat_pre_core_set () //core check the solution, but drop the guard, pre_core + then Inl None + else Inl (Some g) + + + | Inr err -> + debug (fun _ -> + BU.print5 "(%s) Core checking failed (%s) on term %s and type %s\n%s\n" + (show (Env.get_range env)) + (Core.print_error_short err) + (show sol) + (show t) + (Core.print_error err)); + Inr err + +type name = bv +type env = Env.env +type implicits = Env.implicits + +let rangeof g = g.goal_ctx_uvar.ctx_uvar_range + +// Beta reduce +let normalize s e t = N.normalize s e t +let bnorm e t = normalize [] e t +let whnf e t = N.unfold_whnf e t + +(* Use this one for everything the user is supposed to see, EXCEPT + * STATE DUMPS, as it does resugaring. For debug messages, just use plain + * term_to_string, we don't want to cause normalization with debug + * flags. *) +let tts = N.term_to_string + +let set_uvar_expected_typ (u:ctx_uvar) (t:typ) + : unit + = let dec = UF.find_decoration u.ctx_uvar_head in + UF.change_decoration u.ctx_uvar_head ({dec with uvar_decoration_typ = t }) + +let mark_uvar_with_should_check_tag (u:ctx_uvar) (sc:should_check_uvar) + : unit + = let dec = UF.find_decoration u.ctx_uvar_head in + UF.change_decoration u.ctx_uvar_head ({dec with uvar_decoration_should_check = sc }) + +let mark_uvar_as_already_checked (u:ctx_uvar) + : unit + = mark_uvar_with_should_check_tag u Already_checked + +let mark_goal_implicit_already_checked (g:goal) + : unit + = mark_uvar_as_already_checked g.goal_ctx_uvar + +let goal_with_type g t + : goal + = let u = g.goal_ctx_uvar in + set_uvar_expected_typ u t; + g + +let bnorm_goal g = goal_with_type g (bnorm (goal_env g) (goal_type g)) + +let tacprint (s:string) = BU.print1 "TAC>> %s\n" s +let tacprint1 (s:string) x = BU.print1 "TAC>> %s\n" (BU.format1 s x) +let tacprint2 (s:string) x y = BU.print1 "TAC>> %s\n" (BU.format2 s x y) +let tacprint3 (s:string) x y z = BU.print1 "TAC>> %s\n" (BU.format3 s x y z) + +let print (msg:string) : tac unit = + if not (Options.silent ()) then + tacprint msg; + ret () + +let debugging () : tac bool = + bind get (fun ps -> + ret !dbg_Tac) + +let do_dump_ps (msg:string) (ps:proofstate) : unit = + let psc = ps.psc in + let subst = PO.psc_subst psc in + do_dump_proofstate ps msg + +let dump (msg:string) : tac unit = + mk_tac (fun ps -> + do_dump_ps msg ps; + Success ((), ps)) + +let dump_all (print_resolved:bool) (msg:string) : tac unit = + mk_tac (fun ps -> + (* Make a new proofstate with goals for each implicit, + * print it, and return original proofstate unchanged. *) + let gs = List.map (fun i -> goal_of_implicit ps.main_context i) ps.all_implicits in + let gs = + if print_resolved + then gs + else List.filter (fun g -> not (check_goal_solved g)) gs + in + let ps' = { ps with smt_goals = [] ; goals = gs } in + do_dump_ps msg ps'; + Success ((), ps)) + +let dump_uvars_of (g:goal) (msg:string) : tac unit = + mk_tac (fun ps -> + let uvs = SF.uvars (goal_type g) |> elems in + let gs = List.map (goal_of_ctx_uvar g) uvs in + let gs = List.filter (fun g -> not (check_goal_solved g)) gs in + let ps' = { ps with smt_goals = [] ; goals = gs } in + do_dump_ps msg ps'; + Success ((), ps)) + +let fail1 msg x = fail (BU.format1 msg x) +let fail2 msg x y = fail (BU.format2 msg x y) +let fail3 msg x y z = fail (BU.format3 msg x y z) +let fail4 msg x y z w = fail (BU.format4 msg x y z w) + +let destruct_eq' (typ : typ) : option (term & term) = + let open FStarC.Syntax.Formula in + match destruct_typ_as_formula typ with + | Some (BaseConn(l, [_; (e1, None); (e2, None)])) + when Ident.lid_equals l PC.eq2_lid + || Ident.lid_equals l PC.c_eq2_lid + -> + Some (e1, e2) + | _ -> + match U.unb2t typ with + | None -> None + | Some t -> + begin + let hd, args = U.head_and_args t in + match (SS.compress hd).n, args with + | Tm_fvar fv, [(_, Some ({ aqual_implicit = true })); (e1, None); (e2, None)] when S.fv_eq_lid fv PC.op_Eq -> + Some (e1, e2) + | _ -> None + end + +let destruct_eq (env : Env.env) (typ : typ) : option (term & term) = +// TODO: unascribe? + let typ = whnf env typ in + match destruct_eq' typ with + | Some t -> Some t + | None -> + // Retry for a squashed one + begin match U.un_squash typ with + | Some typ -> + let typ = whnf env typ in + destruct_eq' typ + | None -> None + end + + +let get_guard_policy () : tac guard_policy = + bind get (fun ps -> ret ps.guard_policy) + +let set_guard_policy (pol : guard_policy) : tac unit = + bind get (fun ps -> set ({ ps with guard_policy = pol })) + +let with_policy pol (t : tac 'a) : tac 'a = + bind (get_guard_policy ()) (fun old_pol -> + bind (set_guard_policy pol) (fun () -> + bind t (fun r -> + bind (set_guard_policy old_pol) (fun () -> + ret r)))) + +let proc_guard' (simplify:bool) (reason:string) (e : env) (g : guard_t) (sc_opt:option should_check_uvar) (rng:Range.range) : tac unit = + mlog (fun () -> + BU.print2 "Processing guard (%s:%s)\n" reason (Rel.guard_to_string e g)) (fun () -> + let imps = Listlike.to_list g.implicits in + let _ = + match sc_opt with + | Some (Allow_untyped r) -> + List.iter + (fun imp -> mark_uvar_with_should_check_tag imp.imp_uvar (Allow_untyped r)) + imps + | _ -> () + in + add_implicits imps ;! + let guard_f = + if simplify + then (Rel.simplify_guard e g).guard_f + else g.guard_f + in + match guard_f with + | TcComm.Trivial -> ret () + | TcComm.NonTrivial f -> + let! ps = get in + match ps.guard_policy with + | Drop -> + // should somehow taint the state instead of just printing a warning + Err.log_issue e Errors.Warning_TacAdmit + (BU.format1 "Tactics admitted guard <%s>\n\n" (Rel.guard_to_string e g)); + ret () + + | Goal -> + mlog (fun () -> BU.print2 "Making guard (%s:%s) into a goal\n" reason (Rel.guard_to_string e g)) (fun () -> + let! g = goal_of_guard reason e f sc_opt rng in + push_goals [g]) + + | SMT -> + mlog (fun () -> BU.print2 "Pushing guard (%s:%s) as SMT goal\n" reason (show f)) (fun () -> + let! g = goal_of_guard reason e f sc_opt rng in + push_smt_goals [g]) + + | SMTSync -> + mlog (fun () -> BU.print2 "Sending guard (%s:%s) to SMT Synchronously\n" reason (show f)) (fun () -> + Rel.force_trivial_guard e g; + ret ()) + + | Force -> + mlog (fun () -> BU.print2 "Forcing guard (%s:%s)\n" reason (Rel.guard_to_string e g)) (fun () -> + try if not (Env.is_trivial <| Rel.discharge_guard_no_smt e g) + then + mlog (fun () -> BU.print1 "guard = %s\n" (Rel.guard_to_string e g)) (fun () -> + fail1 "Forcing the guard failed (%s)" reason) + else ret () + with + | _ -> mlog (fun () -> BU.print1 "guard = %s\n" (Rel.guard_to_string e g)) (fun () -> + fail1 "Forcing the guard failed (%s)" reason))) + +let proc_guard = proc_guard' true + +// +// See if any of the implicits in uvs were solved in a Rel call, +// if so, core check them +// +let tc_unifier_solved_implicits env (must_tot:bool) (allow_guards:bool) (uvs:list ctx_uvar) : tac unit = + let aux (u:ctx_uvar) : tac unit = + let dec = UF.find_decoration u.ctx_uvar_head in + let sc = dec.uvar_decoration_should_check in + match sc with + | Allow_untyped _ -> + ret () + | Already_checked -> + ret () + | _ -> + match UF.find u.ctx_uvar_head with + | None -> + ret () //not solved yet + | Some sol -> //solved, check it + let env = {env with gamma=u.ctx_uvar_gamma} in + let must_tot = must_tot && not (Allow_ghost? dec.uvar_decoration_should_check) in + match core_check env sol (U.ctx_uvar_typ u) must_tot with + | Inl None -> + //checked with no guard + //no need to check it again + mark_uvar_as_already_checked u; + ret () + + | Inl (Some g) -> + let guard = { Env.trivial_guard with guard_f = NonTrivial g } in + let guard = Rel.simplify_guard env guard in + if Options.disallow_unification_guards () + && not allow_guards + && NonTrivial? guard.guard_f + then ( + fail3 "Could not typecheck unifier solved implicit %s to %s since it produced a guard and guards were not allowed;guard is\n%s" + (show u.ctx_uvar_head) + (show sol) + (show g) + ) + else ( + proc_guard' false "guard for implicit" env guard (Some sc) u.ctx_uvar_range ;! + mark_uvar_as_already_checked u; + ret () + ) + + | Inr failed -> + fail3 "Could not typecheck unifier solved implicit %s to %s because %s" + (show u.ctx_uvar_head) + (show sol) + (Core.print_error failed) + in + if env.phase1 //phase1 is untrusted + then ret () + else uvs |> iter_tac aux + +// +// When calling Rel for t1 `rel` t2, caller can choose to tc +// implicits solved during this unification +// With side argument they can control, which side args to check +// E.g. do_match will choose only Right, +// since it fails if some uvar on the left is instantiated +// +type check_unifier_solved_implicits_side = + | Check_none + | Check_left_only + | Check_right_only + | Check_both + +let __do_unify_wflags + (dbg:bool) + (allow_guards:bool) + (must_tot:bool) + (check_side:check_unifier_solved_implicits_side) + (env:env) (t1:term) (t2:term) + : tac (option guard_t) = + if dbg then + BU.print2 "%%%%%%%%do_unify %s =? %s\n" (show t1) + (show t2); + + let all_uvars = + (match check_side with + | Check_none -> empty () + | Check_left_only -> Free.uvars t1 + | Check_right_only -> Free.uvars t2 + | Check_both -> union (Free.uvars t1) (Free.uvars t2)) + |> elems in + + match! + catch (//restore UF graph in case anything fails + bind (trytac cur_goal) (fun gopt -> + try + let res = + if allow_guards + then Rel.try_teq true env t1 t2 + else Rel.teq_nosmt env t1 t2 + in + if dbg then + BU.print3 "%%%%%%%%do_unify (RESULT %s) %s =? %s\n" + (FStarC.Common.string_of_option (Rel.guard_to_string env) res) + (show t1) + (show t2); + + match res with + | None -> + ret None + | Some g -> + tc_unifier_solved_implicits env must_tot allow_guards all_uvars;! + add_implicits (Listlike.to_list g.implicits);! + ret (Some g) + + with | Errors.Error (_, msg, r, _) -> begin + mlog (fun () -> BU.print2 ">> do_unify error, (%s) at (%s)\n" + (Errors.rendermsg msg) (show r)) (fun _ -> + ret None) + end + ) + ) + with + | Inl exn -> traise exn + | Inr v -> ret v + +(* Just a wrapper over __do_unify_wflags to better debug *) +let __do_unify + (allow_guards:bool) + (must_tot:bool) + (check_side:check_unifier_solved_implicits_side) + (env:env) (t1:term) (t2:term) + : tac (option guard_t) = + bind idtac (fun () -> + if !dbg_TacUnify then begin + Options.push (); + let _ = Options.set_options "--debug Rel,RelCheck" in + () + end; + bind (__do_unify_wflags !dbg_TacUnify allow_guards must_tot check_side env t1 t2) (fun r -> + if !dbg_TacUnify then Options.pop (); + ret r)) + +(* SMT-free unification. *) +let do_unify_aux + (must_tot:bool) + (check_side:check_unifier_solved_implicits_side) + (env:env) (t1:term) (t2:term) + : tac bool = + bind (__do_unify false must_tot check_side env t1 t2) (function + | None -> ret false + | Some g -> + (* g has to be trivial and we have already added its implicits *) + if not (Env.is_trivial_guard_formula g) then + failwith "internal error: do_unify: guard is not trivial"; + ret true + ) + +let do_unify (must_tot:bool) (env:env) (t1:term) (t2:term) : tac bool = + do_unify_aux must_tot Check_both env t1 t2 + +let do_unify_maybe_guards (allow_guards:bool) (must_tot:bool) + (env:env) (t1:term) (t2:term) + : tac (option guard_t) = + __do_unify allow_guards must_tot Check_both env t1 t2 + +(* Does t1 match t2? That is, do they unify without instantiating/changing t1? *) +let do_match (must_tot:bool) (env:Env.env) (t1:term) (t2:term) : tac bool = + bind (mk_tac (fun ps -> let tx = UF.new_transaction () in + Success (tx, ps))) (fun tx -> + let uvs1 = SF.uvars_uncached t1 in + bind (do_unify_aux must_tot Check_right_only env t1 t2) (fun r -> + if r then begin + let uvs2 = SF.uvars_uncached t1 in + if not (equal uvs1 uvs2) + then (UF.rollback tx; ret false) + else ret true + end + else ret false + )) + +(* This is a bandaid. It's similar to do_match but checks that the +LHS of the equality in [t1] is not instantiated, but the RHS might be. +It is a pain to expose the whole logic to tactics, so we just do it +here for now. *) +let do_match_on_lhs (must_tot:bool) (env:Env.env) (t1:term) (t2:term) : tac bool = + bind (mk_tac (fun ps -> let tx = UF.new_transaction () in + Success (tx, ps))) (fun tx -> + match destruct_eq env t1 with + | None -> fail "do_match_on_lhs: not an eq" + | Some (lhs, _) -> + let uvs1 = SF.uvars_uncached lhs in + bind (do_unify_aux must_tot Check_right_only env t1 t2) (fun r -> + if r then begin + let uvs2 = SF.uvars_uncached lhs in + if not (equal uvs1 uvs2) + then (UF.rollback tx; ret false) + else ret true + end + else ret false + )) + +(* + set_solution: + + Sometimes the witness of a goal is solved by + using a low-level assignment of the unification variable + provided by set_solution. + + The general discipline is that when a trusted primitive tactic + constructs a term to solve the current goal, then it should be + able to just do a set_solution. + + OTOH, if it's a user-provided term to solve the goal, then trysolve is safer + + Note, set_solution is not just an optimization. In cases like `intro` + it is actually important to get the right shape of goal. See the comment there. +*) +let set_solution goal solution : tac unit = + match FStarC.Syntax.Unionfind.find goal.goal_ctx_uvar.ctx_uvar_head with + | Some _ -> + fail (BU.format1 "Goal %s is already solved" (goal_to_string_verbose goal)) + | None -> + FStarC.Syntax.Unionfind.change goal.goal_ctx_uvar.ctx_uvar_head solution; + mark_goal_implicit_already_checked goal; + ret () + +let trysolve (goal : goal) (solution : term) : tac bool = + let must_tot = true in + do_unify must_tot (goal_env goal) solution (goal_witness goal) + +let solve (goal : goal) (solution : term) : tac unit = + let e = goal_env goal in + mlog (fun () -> BU.print2 "solve %s := %s\n" (show (goal_witness goal)) + (show solution)) (fun () -> + bind (trysolve goal solution) (fun b -> + if b + then bind dismiss (fun () -> remove_solved_goals) + else fail (BU.format3 "%s does not solve %s : %s" + (tts (goal_env goal) solution) + (tts (goal_env goal) (goal_witness goal)) + (tts (goal_env goal) (goal_type goal))))) + + +let solve' (goal : goal) (solution : term) : tac unit = + bind (set_solution goal solution) (fun () -> + bind dismiss (fun () -> + remove_solved_goals)) + +//Any function that directly calls these utilities is also trusted +//End: Trusted utilities +//////////////////////////////////////////////////////////////////// + +//////////////////////////////////////////////////////////////////// +(* Some utilities on goals *) +let is_true t = + let t = U.unascribe t in + match U.un_squash t with + | Some t' -> + let t' = U.unascribe t' in + begin match (SS.compress t').n with + | Tm_fvar fv -> S.fv_eq_lid fv PC.true_lid + | _ -> false + end + | _ -> false + +let is_false t = + match U.un_squash t with + | Some t' -> + begin match (SS.compress t').n with + | Tm_fvar fv -> S.fv_eq_lid fv PC.false_lid + | _ -> false + end + | _ -> false +//////////////////////////////////////////////////////////////////// + + +let tadmit_t (t:term) : tac unit = wrap_err "tadmit_t" <| + bind get (fun ps -> + bind cur_goal (fun g -> + // should somehow taint the state instead of just printing a warning + Err.log_issue (goal_type g) Errors.Warning_TacAdmit + (BU.format1 "Tactics admitted goal <%s>\n\n" (goal_to_string "" None ps g)); + solve' g t)) + +let fresh () : tac Z.t = + bind get (fun ps -> + let n = ps.freshness in + let ps = { ps with freshness = n + 1 } in + bind (set ps) (fun () -> + ret (Z.of_int_fs n))) + +let curms () : tac Z.t = + ret (BU.now_ms () |> Z.of_int_fs) + +(* Annoying duplication here *) +let __tc (e : env) (t : term) : tac (term & typ & guard_t) = + bind get (fun ps -> + mlog (fun () -> BU.print1 "Tac> __tc(%s)\n" (show t)) (fun () -> + let e = {e with uvar_subtyping=false} in + try ret (TcTerm.typeof_tot_or_gtot_term e t true) + with | Errors.Error (_, msg, _, _) -> begin + fail3 "Cannot type (1) %s in context (%s). Error = (%s)" (tts e t) + (Env.all_binders e |> show) + (Errors.rendermsg msg) // FIXME + end)) + +let __tc_ghost (e : env) (t : term) : tac (term & typ & guard_t) = + bind get (fun ps -> + mlog (fun () -> BU.print1 "Tac> __tc_ghost(%s)\n" (show t)) (fun () -> + let e = {e with uvar_subtyping=false} in + let e = {e with letrecs=[]} in + try let t, lc, g = TcTerm.tc_tot_or_gtot_term e t in + ret (t, lc.res_typ, g) + with | Errors.Error (_, msg, _ ,_) -> begin + fail3 "Cannot type (2) %s in context (%s). Error = (%s)" (tts e t) + (Env.all_binders e |> show) + (Errors.rendermsg msg) // FIXME + end)) + +let __tc_lax (e : env) (t : term) : tac (term & lcomp & guard_t) = + bind get (fun ps -> + mlog (fun () -> BU.print2 "Tac> __tc_lax(%s)(Context:%s)\n" + (show t) + (Env.all_binders e |> show)) (fun () -> + let e = {e with uvar_subtyping=false} in + let e = {e with admit = true} in + let e = {e with letrecs=[]} in + try ret (TcTerm.tc_term e t) + with | Errors.Error (_, msg, _, _) -> begin + fail3 "Cannot type (3) %s in context (%s). Error = (%s)" (tts e t) + (Env.all_binders e |> show) + (Errors.rendermsg msg) // FIXME + end)) + +let tcc (e : env) (t : term) : tac comp = wrap_err "tcc" <| + bind (__tc_lax e t) (fun (_, lc, _) -> + (* Why lax? What about the guard? It doesn't matter! tc is only + * a way for metaprograms to query the typechecker, but + * the result has no effect on the proofstate and nor is it + * taken for a fact that the typing is correct. *) + ret (TcComm.lcomp_comp lc |> fst) //dropping the guard from lcomp_comp too! + ) + +let tc (e : env) (t : term) : tac typ = wrap_err "tc" <| + bind (tcc e t) (fun c -> ret (U.comp_result c)) + +let divide (n:Z.t) (l : tac 'a) (r : tac 'b) : tac ('a & 'b) = + bind get (fun p -> + bind (try ret (List.splitAt (Z.to_int_fs n) p.goals) with | _ -> fail "divide: not enough goals") (fun (lgs, rgs) -> + let lp = { p with goals = lgs; smt_goals = [] } in + bind (set lp) (fun _ -> + bind l (fun a -> + bind get (fun lp' -> + let rp = { lp' with goals = rgs; smt_goals = [] } in + bind (set rp) (fun _ -> + bind r (fun b -> + bind get (fun rp' -> + let p' = { rp' with goals=lp'.goals @ rp'.goals; smt_goals = lp'.smt_goals @ rp'.smt_goals @ p.smt_goals } in + bind (set p') (fun _ -> + bind remove_solved_goals (fun () -> + ret (a, b))))))))))) + +(* focus: runs f on the current goal only, and then restores all the goals *) +(* There is a user defined version as well, we just use this one internally, but can't mark it as private *) +let focus (f:tac 'a) : tac 'a = + bind (divide Z.one f idtac) (fun (a, ()) -> ret a) + +(* Applies t to each of the current goals + fails if t fails on any of the goals + collects each result in the output list *) +let rec map (tau:tac 'a): tac (list 'a) = + bind get (fun p -> + match p.goals with + | [] -> ret [] + | _::_ -> + bind (divide Z.one tau (map tau)) (fun (h,t) -> ret (h :: t)) + ) + +(* Applies t1 to the current head goal + And t2 to all the the sub-goals produced by t1 + + Collects the resulting goals of t2 along with the initial auxiliary goals + *) +let seq (t1:tac unit) (t2:tac unit) : tac unit = + focus ( + bind t1 (fun _ -> + bind (map t2) (fun _ -> ret ())) + ) + +let should_check_goal_uvar (g:goal) = U.ctx_uvar_should_check g.goal_ctx_uvar +let goal_typedness_deps (g:goal) = U.ctx_uvar_typedness_deps g.goal_ctx_uvar + +let bnorm_and_replace g = replace_cur (bnorm_goal g) + +let arrow_one (env:Env.env) (t:term) = + match U.arrow_one_ln t with + | None -> None + | Some (b, c) -> + let env, [b], c = FStarC.TypeChecker.Core.open_binders_in_comp env [b] c in + Some (env, b, c) + +(* + [intro]: + + Initial goal: G |- ?u : (t -> t') + + Now we do an `intro`: + + Next goal: `G, x:t |- ?v : t'` + + with `?u := (fun (x:t) -> ?v @ [NM(x, 0)])` +*) +let intro () : tac binder = wrap_err "intro" <| ( + let! goal = cur_goal in + match arrow_one (goal_env goal) (whnf (goal_env goal) (goal_type goal)) with + | Some (env', b, c) -> + if not (U.is_total_comp c) + then fail "Codomain is effectful" + else let typ' = U.comp_result c in + //BU.print1 "[intro]: current goal is %s" (goal_to_string goal); + //BU.print1 "[intro]: current goal witness is %s" (show (goal_witness goal)); + //BU.print1 "[intro]: with goal type %s" (show (goal_type goal)); + //BU.print2 "[intro]: with binder = %s, new goal = %s" + // (Print.binders_to_string ", " [b]) + // (show typ'); + let! body, ctx_uvar = + new_uvar "intro" env' typ' + (Some (should_check_goal_uvar goal)) + (goal_typedness_deps goal) + (rangeof goal) in + let sol = U.abs [b] body (Some (U.residual_comp_of_comp c)) in + //BU.print1 "[intro]: solution is %s" + // (show sol); + //BU.print1 "[intro]: old goal is %s" (goal_to_string goal); + //BU.print1 "[intro]: new goal is %s" + // (show ctx_uvar); + //ignore (FStarC.Options.set_options "--debug Rel"); + (* Suppose if instead of simply assigning `?u` to the lambda term on + the RHS, we tried to unify `?u` with the `(fun (x:t) -> ?v @ [NM(x, 0)])`. + + Then, this would defeat the purpose of the delayed substitution, since + the unification engine would solve it by doing something like + + `(fun (y:t) -> ?u y) ~ (fun (x:t) -> ?v @ [NM(x, 0)])` + + And then solving + + `?u z ~ ?v @ [NT(x, z)]` + + which would then proceed by solving `?v` to `?w z` and then unifying + `?u` and `?w`. + + I.e., this immediately destroys the nice shape of the next goal. + *) + set_solution goal sol ;! + let g = mk_goal env' ctx_uvar goal.opts goal.is_guard goal.label in + bnorm_and_replace g ;! + ret b + | None -> + fail1 "goal is not an arrow (%s)" (tts (goal_env goal) (goal_type goal)) + ) + + +// TODO: missing: precedes clause, and somehow disabling fixpoints only as needed +let intro_rec () : tac (binder & binder) = + let! goal = cur_goal in + BU.print_string "WARNING (intro_rec): calling this is known to cause normalizer loops\n"; + BU.print_string "WARNING (intro_rec): proceed at your own risk...\n"; + match arrow_one (goal_env goal) (whnf (goal_env goal) (goal_type goal)) with + | Some (env', b, c) -> + if not (U.is_total_comp c) + then fail "Codomain is effectful" + else let bv = gen_bv "__recf" None (goal_type goal) in + let! u, ctx_uvar_u = + new_uvar "intro_rec" env' + (U.comp_result c) + (Some (should_check_goal_uvar goal)) + (goal_typedness_deps goal) + (rangeof goal) in + let lb = U.mk_letbinding (Inl bv) [] (goal_type goal) PC.effect_Tot_lid (U.abs [b] u None) [] Range.dummyRange in + let body = S.bv_to_name bv in + let lbs, body = SS.close_let_rec [lb] body in + let tm = mk (Tm_let {lbs=(true, lbs); body}) (goal_witness goal).pos in + set_solution goal tm ;! + bnorm_and_replace { goal with goal_ctx_uvar=ctx_uvar_u} ;! + ret (S.mk_binder bv, b) + | None -> + fail1 "intro_rec: goal is not an arrow (%s)" (tts (goal_env goal) (goal_type goal)) + +let norm (s : list Pervasives.norm_step) : tac unit = + let! goal = cur_goal in + if_verbose (fun () -> BU.print1 "norm: witness = %s\n" (show (goal_witness goal))) ;! + // Translate to actual normalizer steps + let steps = [Env.Reify; Env.DontUnfoldAttr [PC.tac_opaque_attr]]@(Cfg.translate_norm_steps s) in + //let w = normalize steps (goal_env goal) (goal_witness goal) in + let t = normalize steps (goal_env goal) (goal_type goal) in + replace_cur (goal_with_type goal t) + + +let norm_term_env (e : env) (s : list Pervasives.norm_step) (t : term) : tac term = wrap_err "norm_term" <| ( + let! ps = get in + if_verbose (fun () -> BU.print1 "norm_term_env: t = %s\n" (show t)) ;! + // only for elaborating lifts and all that, we don't care if it's actually well-typed + let! t, _, _ = __tc_lax e t in + let steps = [Env.Reify; Env.DontUnfoldAttr [PC.tac_opaque_attr]]@(Cfg.translate_norm_steps s) in + let t = normalize steps ps.main_context t in + if_verbose (fun () -> BU.print1 "norm_term_env: t' = %s\n" (show t)) ;! + ret t + ) + + +let refine_intro () : tac unit = wrap_err "refine_intro" <| ( + let! g = cur_goal in + match Rel.base_and_refinement (goal_env g) (goal_type g) with + | _, None -> fail "not a refinement" + | t, Some (bv, phi) -> + //Mark goal as untyped, since we're adding its refinement as a separate goal + mark_goal_implicit_already_checked g; + let g1 = goal_with_type g t in + let bv, phi = + let bvs, phi = SS.open_term [S.mk_binder bv] phi in + (List.hd bvs).binder_bv, phi + in + let! g2 = mk_irrelevant_goal "refine_intro refinement" (goal_env g) + (SS.subst [S.NT (bv, (goal_witness g))] phi) + (Some (should_check_goal_uvar g)) + (rangeof g) + g.opts + g.label in + dismiss ;! + add_goals [g1;g2] + ) + +let __exact_now set_expected_typ (t:term) : tac unit = + let! goal = cur_goal in + let env = if set_expected_typ + then Env.set_expected_typ (goal_env goal) (goal_type goal) + else (goal_env goal) + in + let! t, typ, guard = __tc env t in + if_verbose (fun () -> BU.print2 "__exact_now: got type %s\n__exact_now: and guard %s\n" + (show typ) + (Rel.guard_to_string (goal_env goal) guard)) ;! + proc_guard "__exact typing" (goal_env goal) guard (Some (should_check_goal_uvar goal)) (rangeof goal) ;! + if_verbose (fun () -> BU.print2 "__exact_now: unifying %s and %s\n" (show typ) + (show (goal_type goal))) ;! + let! b = do_unify true (goal_env goal) typ (goal_type goal) in + if b + then ( // do unify succeeded with a trivial guard; so the goal is solved and we don't have to check it again + mark_goal_implicit_already_checked goal; + solve goal t + ) + else + let typ, goalt = TypeChecker.Err.print_discrepancy (tts (goal_env goal)) typ (goal_type goal) in + fail4 "%s : %s does not exactly solve the goal %s (witness = %s)" + (tts (goal_env goal) t) + typ + goalt + (tts (goal_env goal) (goal_witness goal)) + +let t_exact try_refine set_expected_typ tm : tac unit = wrap_err "exact" <| ( + if_verbose (fun () -> BU.print1 "t_exact: tm = %s\n" (show tm)) ;! + match! catch (__exact_now set_expected_typ tm) with + | Inr r -> ret r + | Inl e when not (try_refine) -> traise e + | Inl e -> + if_verbose (fun () -> BU.print_string "__exact_now failed, trying refine...\n") ;! + match! catch (norm [Pervasives.Delta] ;! refine_intro () ;! __exact_now set_expected_typ tm) with + | Inr r -> + if_verbose (fun () -> BU.print_string "__exact_now: failed after refining too\n") ;! + ret r + | Inl _ -> + if_verbose (fun () -> BU.print_string "__exact_now: was not a refinement\n") ;! + traise e) + +(* Can t1 unify t2 if it's applied to arguments? If so return uvars for them *) +(* NB: Result is reversed, which helps so we use fold_right instead of fold_left *) +let try_unify_by_application (should_check:option should_check_uvar) + (only_match:bool) + (e : env) + (ty1 : term) + (ty2 : term) + (rng:Range.range) + : tac (list (term & aqual & ctx_uvar)) + = let f = if only_match then do_match else do_unify in + let must_tot = true in + let rec aux (acc : list (term & aqual & ctx_uvar)) + (typedness_deps : list ctx_uvar) //map proj_3 acc + (ty1:term) + : tac (list (term & aqual & ctx_uvar)) + = match! f must_tot e ty2 ty1 with + | true -> ret acc (* Done! *) + | false -> + (* Not a match, try instantiating the first type by application *) + match U.arrow_one ty1 with + | None -> + fail2 "Could not instantiate, %s to %s" (tts e ty1) (tts e ty2) + + | Some (b, c) -> + if not (U.is_total_comp c) then fail "Codomain is effectful" else + let! uvt, uv = new_uvar "apply arg" e b.binder_bv.sort should_check typedness_deps rng in + if_verbose (fun () -> BU.print1 "t_apply: generated uvar %s\n" (show uv)) ;! + let typ = U.comp_result c in + let typ' = SS.subst [S.NT (b.binder_bv, uvt)] typ in + aux ((uvt, U.aqual_of_binder b, uv)::acc) (uv::typedness_deps) typ' + in + aux [] [] ty1 + +// +// Goals for implicits created during apply +// +let apply_implicits_as_goals + (env:Env.env) + (gl:option goal) + (imps:list (term & ctx_uvar)) + : tac (list (list goal)) = + + let one_implicit_as_goal (term, ctx_uvar) = + let hd, _ = U.head_and_args term in + match (SS.compress hd).n with + | Tm_uvar (ctx_uvar, _) -> + let gl = + match gl with + | None -> mk_goal env ctx_uvar (FStarC.Options.peek()) true "goal for unsolved implicit" + | Some gl -> { gl with goal_ctx_uvar = ctx_uvar } in //TODO: AR: what's happening here? + let gl = bnorm_goal gl in + ret [gl] + | _ -> + // + // This implicits has already been solved + // We would have typechecked its solution already, + // just after the Rel call + // + ret [] + in + imps |> mapM one_implicit_as_goal + +// uopt: Don't add goals for implicits that appear free in posterior goals. +// This is very handy for users, allowing to turn +// +// |- a = c +// +// by applying transivity to +// +// |- a = ?u +// |- ?u = c +// +// without asking for |- ?u : Type first, which will most likely be instantiated when +// solving any of these two goals. In any case, if ?u is not solved, we will later fail. +// TODO: this should probably be made into a user tactic +let t_apply (uopt:bool) (only_match:bool) (tc_resolved_uvars:bool) (tm:term) : tac unit = wrap_err "apply" <| ( + let tc_resolved_uvars = true in + if_verbose + (fun () -> BU.print4 "t_apply: uopt %s, only_match %s, tc_resolved_uvars %s, tm = %s\n" + (show uopt) + (show only_match) + (show tc_resolved_uvars) + (show tm)) ;! + let! ps = get in + let! goal = cur_goal in + let e = goal_env goal in + let should_check = should_check_goal_uvar goal in + Tactics.Monad.register_goal goal; + let! tm, typ, guard = __tc e tm in + if_verbose + (fun () -> BU.print5 "t_apply: tm = %s\nt_apply: goal = %s\nenv.gamma=%s\ntyp=%s\nguard=%s\n" + (show tm) + (goal_to_string_verbose goal) + (show e.gamma) + (show typ) + (Rel.guard_to_string e guard)) ;! + // Focus helps keep the goal order + let typ = bnorm e typ in + let! uvs = try_unify_by_application (Some should_check) only_match e typ (goal_type goal) (rangeof goal) in + if_verbose + (fun () -> BU.print1 "t_apply: found args = %s\n" + (FStarC.Common.string_of_list (fun (t, _, _) -> show t) uvs)) ;! + let w = List.fold_right (fun (uvt, q, _) w -> U.mk_app w [(uvt, q)]) uvs tm in + let uvset = + List.fold_right + (fun (_, _, uv) s -> union s (SF.uvars (U.ctx_uvar_typ uv))) + uvs + (empty ()) + in + let free_in_some_goal uv = mem uv uvset in + solve' goal w ;! + // + //process uvs + //first, if some of them are solved already, perhaps during unification, + // typecheck them if tc_resolved_uvars is on + //then, if uopt is on, filter out those that appear in other goals + //add the rest as goals + // + let uvt_uv_l = uvs |> List.map (fun (uvt, _q, uv) -> (uvt, uv)) in + let! sub_goals = + apply_implicits_as_goals e (Some goal) uvt_uv_l in + let sub_goals = List.flatten sub_goals + |> List.filter (fun g -> + //if uopt is on, we don't keep uvars that + // appear in some other goals + not (uopt && free_in_some_goal g.goal_ctx_uvar)) + |> List.map bnorm_goal + |> List.rev in + add_goals sub_goals ;! + proc_guard "apply guard" e guard (Some should_check) (rangeof goal) + ) + +// returns pre and post +let lemma_or_sq (c : comp) : option (term & term) = + let eff_name, res, args = U.comp_eff_name_res_and_args c in + if lid_equals eff_name PC.effect_Lemma_lid then + let pre, post = match args with + | pre::post::_ -> fst pre, fst post + | _ -> failwith "apply_lemma: impossible: not a lemma" + in + // Lemma post is thunked + let post = U.mk_app post [S.as_arg U.exp_unit] in + Some (pre, post) + else if U.is_pure_effect eff_name + || U.is_ghost_effect eff_name then + map_opt (U.un_squash res) (fun post -> (U.t_true, post)) + else + None + +let rec fold_left (f : ('a -> 'b -> tac 'b)) (e : 'b) (xs : list 'a) : tac 'b = + match xs with + | [] -> ret e + | x::xs -> bind (f x e) (fun e' -> fold_left f e' xs) + +let t_apply_lemma (noinst:bool) (noinst_lhs:bool) + (tm:term) : tac unit = wrap_err "apply_lemma" <| focus ( + let! ps = get in + if_verbose (fun () -> BU.print1 "apply_lemma: tm = %s\n" (show tm)) ;! + let is_unit_t t = + match (SS.compress t).n with + | Tm_fvar fv when S.fv_eq_lid fv PC.unit_lid -> true + | _ -> false + in + let! goal = cur_goal in + let env = goal_env goal in + Tactics.Monad.register_goal goal; + let! tm, t, guard = __tc env tm in + let bs, comp = U.arrow_formals_comp t in + match lemma_or_sq comp with + | None -> fail "not a lemma or squashed function" + | Some (pre, post) -> + let! uvs, _, implicits, subst = + fold_left + (fun ({binder_bv=b;binder_qual=aq}) (uvs, deps, imps, subst) -> + let b_t = SS.subst subst b.sort in + if is_unit_t b_t + then + // Simplification: if the argument is simply unit, then don't ask for it + ret <| ((U.exp_unit, aq)::uvs, deps, imps, S.NT(b, U.exp_unit)::subst) + else + let! t, u = new_uvar "apply_lemma" env b_t + (goal + |> should_check_goal_uvar + |> (function | Strict -> Allow_ghost "apply lemma uvar" + | x -> x) + |> Some) + deps + (rangeof goal) in + if Debug.medium () || !dbg_2635 + then + BU.print2 "Apply lemma created a new uvar %s while applying %s\n" + (show u) + (show tm); + ret ((t, aq)::uvs, u::deps, (t, u)::imps, S.NT(b, t)::subst)) + ([], [], [], []) + bs + in + let implicits = List.rev implicits in + let uvs = List.rev uvs in + let pre = SS.subst subst pre in + let post = SS.subst subst post in + let post_u = env.universe_of env post in + let cmp_func = + if noinst then do_match + else if noinst_lhs then do_match_on_lhs + else do_unify + in + let! b = + let must_tot = false in + cmp_func must_tot env (goal_type goal) (U.mk_squash post_u post) in + if not b + then ( + let post, goalt = TypeChecker.Err.print_discrepancy (tts env) + (U.mk_squash post_u post) + (goal_type goal) in + fail3 "Cannot instantiate lemma %s (with postcondition: %s) to match goal (%s)" + (tts env tm) post goalt + ) + else ( + // We solve with (), we don't care about the witness if applying a lemma + let goal_sc = should_check_goal_uvar goal in + solve' goal U.exp_unit ;! + let is_free_uvar uv t = + let free_uvars = List.map (fun x -> x.ctx_uvar_head) (elems (SF.uvars t)) in + List.existsML (fun u -> UF.equiv u uv) free_uvars + in + let appears uv goals = List.existsML (fun g' -> is_free_uvar uv (goal_type g')) goals in + let checkone t goals = + let hd, _ = U.head_and_args t in + begin match hd.n with + | Tm_uvar (uv, _) -> appears uv.ctx_uvar_head goals + | _ -> false + end + in + let must_tot = false in + let! sub_goals = + apply_implicits_as_goals env (Some goal) implicits in + let sub_goals = List.flatten sub_goals in + // Optimization: if a uvar appears in a later goal, don't ask for it, since + // it will be instantiated later. It is tracked anyway in ps.implicits + let rec filter' (f : 'a -> list 'a -> bool) (xs : list 'a) : list 'a = + match xs with + | [] -> [] + | x::xs -> if f x xs then x::(filter' f xs) else filter' f xs + in + let sub_goals = filter' (fun g goals -> not (checkone (goal_witness g) goals)) sub_goals in + proc_guard "apply_lemma guard" env guard (Some goal_sc) (rangeof goal) ;! + let pre_u = env.universe_of env pre in + (match (Rel.simplify_guard env (Env.guard_of_guard_formula (NonTrivial pre))).guard_f with + | Trivial -> ret () + | NonTrivial _ -> add_irrelevant_goal goal "apply_lemma precondition" env pre (Some goal_sc)) ;!//AR: should we use the normalized pre instead? + add_goals sub_goals + ) + ) + +let split_env (bvar : bv) (e : env) : option (env & bv & list bv) = + let rec aux e = + match Env.pop_bv e with + | None -> None + | Some (bv', e') -> + if S.bv_eq bvar bv' + then Some (e', bv', []) + else map_opt (aux e') (fun (e'', bv, bvs) -> (e'', bv, bv'::bvs )) + in + map_opt (aux e) (fun (e', bv, bvs) -> (e', bv, List.rev bvs)) + +let subst_goal (b1 : bv) (b2 : bv) (g:goal) : tac (option (bv & goal)) = + match split_env b1 (goal_env g) with + | Some (e0, b1, bvs) -> + let bs = List.map S.mk_binder (b1::bvs) in + + let t = goal_type g in + + (* Close the binders and t *) + let bs', t' = SS.close_binders bs, SS.close bs t in + + (* Replace b1 (the head) by b2 *) + let bs' = S.mk_binder b2 :: List.tail bs' in + + (* Re-open, all done for renaming *) + let new_env, bs'', t'' = Core.open_binders_in_term e0 bs' t' in + + // (* b2 has been freshened *) + let b2 = (List.hd bs'').binder_bv in + + // (* Make a new goal in the new env (with new binders) *) + let! uvt, uv = new_uvar "subst_goal" new_env t'' + (Some (should_check_goal_uvar g)) + (goal_typedness_deps g) + (rangeof g) in + + let goal' = mk_goal new_env uv g.opts g.is_guard g.label in + + (* Solve the old goal with an application of the new witness *) + let sol = U.mk_app (U.abs bs'' uvt None) + (List.map (fun ({binder_bv=bv;binder_qual=q}) -> S.as_arg (S.bv_to_name bv)) bs) in + + set_solution g sol ;! + + ret (Some (b2, goal')) + + | None -> + ret None + +let rewrite (h:binder) : tac unit = wrap_err "rewrite" <| ( + let! goal = cur_goal in + let bv = h.binder_bv in + if_verbose (fun _ -> BU.print2 "+++Rewrite %s : %s\n" (show bv) (show bv.sort)) ;! + match split_env bv (goal_env goal) with + | None -> fail "binder not found in environment" + | Some (e0, bv, bvs) -> + begin + match destruct_eq e0 bv.sort with + | Some (x, e) -> + begin + match (SS.compress x).n with + | Tm_name x -> + let s = [NT(x, e)] in + + (* See subst_goal for an explanation *) + let t = goal_type goal in + let bs = List.map S.mk_binder bvs in + + let bs', t' = SS.close_binders bs, SS.close bs t in + let bs', t' = SS.subst_binders s bs', SS.subst s t' in + let e0 = Env.push_bvs e0 [bv] in + let new_env, bs'', t'' = Core.open_binders_in_term e0 bs' t' in + + let! uvt, uv = + new_uvar "rewrite" new_env t'' + (Some (should_check_goal_uvar goal)) + (goal_typedness_deps goal) + (rangeof goal) + in + let goal' = mk_goal new_env uv goal.opts goal.is_guard goal.label in + let sol = U.mk_app (U.abs bs'' uvt None) + (List.map (fun ({binder_bv=bv}) -> S.as_arg (S.bv_to_name bv)) bs) in + + (* See comment in subst_goal *) + set_solution goal sol ;! + replace_cur goal' + + | _ -> + fail "Not an equality hypothesis with a variable on the LHS" + end + | _ -> fail "Not an equality hypothesis" + end + ) + +let rename_to (b : binder) (s : string) : tac binder = wrap_err "rename_to" <| ( + let! goal = cur_goal in + let bv = b.binder_bv in + let bv' = freshen_bv ({ bv with ppname = mk_ident (s, (range_of_id bv.ppname)) }) in + match! subst_goal bv bv' goal with + | None -> fail "binder not found in environment" + | Some (bv', goal) -> + replace_cur goal ;! + ret {b with binder_bv=bv'} + ) + +let binder_retype (b : binder) : tac unit = wrap_err "binder_retype" <| ( + let! goal = cur_goal in + let bv = b.binder_bv in + match split_env bv (goal_env goal) with + | None -> fail "binder is not present in environment" + | Some (e0, bv, bvs) -> + let (ty, u) = U.type_u () in + let goal_sc = should_check_goal_uvar goal in + let! t', u_t' = + new_uvar "binder_retype" e0 ty + (Some goal_sc) + (goal_typedness_deps goal) + (rangeof goal) + in + let bv'' = {bv with sort = t'} in + let s = [S.NT (bv, S.bv_to_name bv'')] in + let bvs = List.map (fun b -> { b with sort = SS.subst s b.sort }) bvs in + let env' = Env.push_bvs e0 (bv''::bvs) in + dismiss ;! + let new_goal = + goal_with_type + (goal_with_env goal env') + (SS.subst s (goal_type goal)) + in + add_goals [new_goal] ;! + add_irrelevant_goal goal "binder_retype equation" e0 + (U.mk_eq2 (U_succ u) ty bv.sort t') + (Some goal_sc) + ) + +(* TODO: move to bv *) +let norm_binder_type (s : list Pervasives.norm_step) (b : binder) : tac unit = wrap_err "norm_binder_type" <| ( + let! goal = cur_goal in + let bv = b.binder_bv in + match split_env bv (goal_env goal) with + | None -> fail "binder is not present in environment" + | Some (e0, bv, bvs) -> + let steps = [Env.Reify; Env.DontUnfoldAttr [PC.tac_opaque_attr]]@(Cfg.translate_norm_steps s) in + let sort' = normalize steps e0 bv.sort in + let bv' = { bv with sort = sort' } in + let env' = Env.push_bvs e0 (bv'::bvs) in + replace_cur (goal_with_env goal env') + ) + +let revert () : tac unit = + let! goal = cur_goal in + match Env.pop_bv (goal_env goal) with + | None -> fail "Cannot revert; empty context" + | Some (x, env') -> + let typ' = U.arrow [S.mk_binder x] (mk_Total (goal_type goal)) in + let! r, u_r = + new_uvar "revert" env' typ' + (Some (should_check_goal_uvar goal)) + (goal_typedness_deps goal) + (rangeof goal) in + set_solution goal (S.mk_Tm_app r [S.as_arg (S.bv_to_name x)] (goal_type goal).pos) ;! + let g = mk_goal env' u_r goal.opts goal.is_guard goal.label in + replace_cur g + +let free_in bv t = mem bv (SF.names t) + +let clear (b : binder) : tac unit = + let bv = b.binder_bv in + let! goal = cur_goal in + if_verbose (fun () -> BU.print2 "Clear of (%s), env has %s binders\n" + (show b) + (Env.all_binders (goal_env goal) |> List.length |> show)) ;! + match split_env bv (goal_env goal) with + | None -> fail "Cannot clear; binder not in environment" + | Some (e', bv, bvs) -> + let rec check bvs = + match bvs with + | [] -> ret () + | bv'::bvs -> + if free_in bv bv'.sort + then fail (BU.format1 "Cannot clear; binder present in the type of %s" + (show bv')) + else check bvs + in + if free_in bv (goal_type goal) then + fail "Cannot clear; binder present in goal" + else ( + check bvs ;! + let env' = Env.push_bvs e' bvs in + let! ut, uvar_ut = + new_uvar "clear.witness" env' (goal_type goal) + (Some (should_check_goal_uvar goal)) + (goal_typedness_deps goal) + (rangeof goal) in + set_solution goal ut ;! + replace_cur (mk_goal env' uvar_ut goal.opts goal.is_guard goal.label) + ) + +let clear_top () : tac unit = + let! goal = cur_goal in + match Env.pop_bv (goal_env goal) with + | None -> fail "Cannot clear; empty context" + | Some (x, _) -> clear (S.mk_binder x) // we ignore the qualifier anyway + +let prune (s:string) : tac unit = + let! g = cur_goal in + let ctx = goal_env g in + let ctx' = Env.rem_proof_ns ctx (path_of_text s) in + let g' = goal_with_env g ctx' in + replace_cur g' + +let addns (s:string) : tac unit = + let! g = cur_goal in + let ctx = goal_env g in + let ctx' = Env.add_proof_ns ctx (path_of_text s) in + let g' = goal_with_env g ctx' in + replace_cur g' + +let guard_formula (g:guard_t) : term = + match g.guard_f with + | Trivial -> U.t_true + | NonTrivial f -> f + +let _t_trefl (allow_guards:bool) (l : term) (r : term) : tac unit = + let should_register_trefl g = + let should_register = true in + let skip_register = false in + if not (Options.compat_pre_core_should_register()) then skip_register else + //Sending a goal t1 == t2 to the core for registration can be expensive + //particularly if the terms are big, e.g., when they are WPs etc + //This function decides which goals to register, using two criteria + //1. If the uvars in the goal are Allow_untyped or Already_checked + // then don't bother registering, since we will not recheck the solution. + // + //2. If the goal is of the form `eq2 #ty ?u t` (or vice versa) + // and we can prove that ty <: ?u.t + // then the assignment of `?u := t` is going to be well-typed + // without needing to recompute the type of `t` + let is_uvar_untyped_or_already_checked u = + let dec = UF.find_decoration u.ctx_uvar_head in + match dec.uvar_decoration_should_check with + | Allow_untyped _ + | Already_checked -> true + | _ -> false + in + let is_uvar t = + let head = U.leftmost_head t in + match (SS.compress head).n with + | Tm_uvar (u, _) -> Inl (u, head, t) + | _ -> Inr t + in + let is_allow_untyped_uvar t = + match is_uvar t with + | Inr _ -> false + | Inl (u, _, _) -> is_uvar_untyped_or_already_checked u + in + let t = U.ctx_uvar_typ g.goal_ctx_uvar in + let uvars = elems (FStarC.Syntax.Free.uvars t) in + if BU.for_all is_uvar_untyped_or_already_checked uvars + then skip_register //all the uvars are already checked or untyped + else ( + let head, args = + let t = + match U.un_squash t with + | None -> t + | Some t -> t + in + U.leftmost_head_and_args t + in + match (SS.compress (U.un_uinst head)).n, args with + | Tm_fvar fv, [(ty, _); (t1, _); (t2, _)] + when S.fv_eq_lid fv PC.eq2_lid -> + if is_allow_untyped_uvar t1 || is_allow_untyped_uvar t2 + then skip_register //if we have ?u=t or t=?u and ?u is allow_untyped, then skip + else if Tactics.Monad.is_goal_safe_as_well_typed g //o.w., if the goal is well typed + then ( + //and the goal is of the shape + // eq2 #ty ?u t or + // eq2 #ty t ?u + // Then solving this, if it succeeds, is going to assign ?u := t + // If we know that `ty <: ?u.ty` then this is well-typed already + // without needing to recheck the assignment + // Note, from well-typedness of the goal, we already know ?u.ty <: ty + let check_uvar_subtype u t = + let env = { goal_env g with gamma = g.goal_ctx_uvar.ctx_uvar_gamma } in + match Core.compute_term_type_handle_guards env t (fun _ _ -> true) + with + | Inr _ -> false + | Inl (_, t_ty) -> ( // ignoring the effect, ghost is ok + match Core.check_term_subtyping true true env ty t_ty with + | Inl None -> //unconditional subtype + mark_uvar_as_already_checked u; + true + | _ -> + false + ) + in + match is_uvar t1, is_uvar t2 with + | Inl (u, _, tu), Inr _ + | Inr _, Inl (u, _, tu) -> + //if the condition fails, then return true to register this goal + //since the assignment will have to be rechecked + if check_uvar_subtype u tu + then skip_register + else should_register + | _ -> + should_register + ) + else should_register + | _ -> + should_register + ) + in + let! g = cur_goal in + let should_check = should_check_goal_uvar g in + if should_register_trefl g + then Tactics.Monad.register_goal g; + let must_tot = true in + let attempt (l : term) (r : term) : tac bool = + match! do_unify_maybe_guards allow_guards must_tot (goal_env g) l r with + | None -> ret false + | Some guard -> + solve' g U.exp_unit ;! + if allow_guards + then + let! goal = goal_of_guard "t_trefl" (goal_env g) (guard_formula guard) (Some should_check) (rangeof g) in + push_goals [goal] ;! + ret true + else + // If allow_guards is false, this guard must be trivial and we don't + // add it, but we check its triviality for sanity. + if Env.is_trivial_guard_formula guard + then ret true + else failwith "internal error: _t_refl: guard is not trivial" + in + match! attempt l r with + | true -> ret () + | false -> + (* if that didn't work, normalize and retry *) + let norm = N.normalize [Env.UnfoldUntil delta_constant; Env.Primops; Env.DontUnfoldAttr [PC.tac_opaque_attr]] (goal_env g) in + match! attempt (norm l) (norm r) with + | true -> ret () + | false -> + let ls, rs = TypeChecker.Err.print_discrepancy (tts (goal_env g)) l r in + fail2 "cannot unify (%s) and (%s)" ls rs + +let t_trefl (allow_guards:bool) : tac unit = wrap_err "t_trefl" <| ( + match! + catch (//restore UF graph, including any Already_checked markers, if anything fails + let! g = cur_goal in + match destruct_eq (goal_env g) (goal_type g) with + | Some (l, r) -> + _t_trefl allow_guards l r + | None -> + fail1 "not an equality (%s)" (tts (goal_env g) (goal_type g)) + ) + with + | Inr v -> ret v + | Inl exn -> traise exn + ) + +let dup () : tac unit = + let! g = cur_goal in + let goal_sc = should_check_goal_uvar g in + let env = goal_env g in + let! u, u_uvar = + new_uvar "dup" env (goal_type g) + (Some (should_check_goal_uvar g)) + (goal_typedness_deps g) + (rangeof g) in + //the new uvar is just as Strict as the original one. So, its assignement will be checked + //and we have a goal that requires us to prove it equal to the original uvar + //so we can clear the should_check status of the current uvar + mark_uvar_as_already_checked g.goal_ctx_uvar; + let g' = { g with goal_ctx_uvar = u_uvar } in + dismiss ;! + let t_eq = U.mk_eq2 (env.universe_of env (goal_type g)) (goal_type g) u (goal_witness g) in + add_irrelevant_goal g "dup equation" env t_eq (Some goal_sc) ;! + add_goals [g'] + +// longest_prefix f l1 l2 = (p, r1, r2) ==> l1 = p@r1 /\ l2 = p@r2 +let longest_prefix (f : 'a -> 'a -> bool) (l1 : list 'a) (l2 : list 'a) : list 'a & list 'a & list 'a = + let rec aux acc l1 l2 = + match l1, l2 with + | x::xs, y::ys -> + if f x y + then aux (x::acc) xs ys + else acc, x::xs, y::ys + | _ -> + acc, l1, l2 + in + let pr, t1, t2 = aux [] l1 l2 in + List.rev pr, t1, t2 + +// NOTE: duplicated from V2.Basic. Should remove this whole module eventually. +let eq_binding b1 b2 = + match b1, b2 with + | S.Binding_var bv1, Binding_var bv2 -> bv_eq bv1 bv2 && U.term_eq bv1.sort bv2.sort + | S.Binding_lid (lid1, _), Binding_lid (lid2, _) -> lid_equals lid1 lid2 + | S.Binding_univ u1, Binding_univ u2 -> ident_equals u1 u2 + | _ -> false + +// fix universes +let join_goals g1 g2 : tac goal = + (* The one in Syntax.Util ignores null_binders, why? *) + let close_forall_no_univs bs f = + List.fold_right (fun b f -> U.mk_forall_no_univ b.binder_bv f) bs f + in + match get_phi g1 with + | None -> fail "goal 1 is not irrelevant" + | Some phi1 -> + match get_phi g2 with + | None -> fail "goal 2 is not irrelevant" + | Some phi2 -> + + let gamma1 = g1.goal_ctx_uvar.ctx_uvar_gamma in + let gamma2 = g2.goal_ctx_uvar.ctx_uvar_gamma in + let gamma, r1, r2 = longest_prefix eq_binding (List.rev gamma1) (List.rev gamma2) in + + let t1 = close_forall_no_univs (Env.binders_of_bindings (List.rev r1)) phi1 in + let t2 = close_forall_no_univs (Env.binders_of_bindings (List.rev r2)) phi2 in + + let goal_sc = + match should_check_goal_uvar g1, should_check_goal_uvar g2 with + | Allow_untyped reason1, Allow_untyped _ -> Some (Allow_untyped reason1) + | _ -> None + in + set_solution g1 U.exp_unit ;! + set_solution g2 U.exp_unit ;! + + let ng = U.mk_conj t1 t2 in + let nenv = { goal_env g1 with gamma = List.rev gamma } in + let! goal = mk_irrelevant_goal "joined" nenv ng goal_sc (rangeof g1) g1.opts g1.label in + if_verbose (fun () -> BU.print3 "join_goals of\n(%s)\nand\n(%s)\n= (%s)\n" + (goal_to_string_verbose g1) + (goal_to_string_verbose g2) + (goal_to_string_verbose goal)) ;! + ret goal + +let join () : tac unit = + let! ps = get in + match ps.goals with + | g1::g2::gs -> + set { ps with goals = gs } ;! + let! g12 = join_goals g1 g2 in + add_goals [g12] + + | _ -> fail "join: less than 2 goals" + + +let set_options (s : string) : tac unit = wrap_err "set_options" <| ( + let! g = cur_goal in + FStarC.Options.push (); + FStarC.Options.set g.opts; + let res = FStarC.Options.set_options s in + let opts' = FStarC.Options.peek () in + FStarC.Options.pop (); + match res with + | FStarC.Getopt.Success -> + let g' = { g with opts = opts' } in + replace_cur g' + | FStarC.Getopt.Error err -> + fail2 "Setting options `%s` failed: %s" s err + | FStarC.Getopt.Help -> + fail1 "Setting options `%s` failed (got `Help`?)" s + ) + +let top_env () : tac env = bind get (fun ps -> ret <| ps.main_context) + +let lax_on () : tac bool = + let! g = cur_goal in + ret (Options.lax () || (goal_env g).admit) + +let unquote (ty : term) (tm : term) : tac term = wrap_err "unquote" <| ( + if_verbose (fun () -> BU.print1 "unquote: tm = %s\n" (show tm)) ;! + let! goal = cur_goal in + let env = Env.set_expected_typ (goal_env goal) ty in + let! tm, typ, guard = __tc_ghost env tm in + if_verbose (fun () -> BU.print1 "unquote: tm' = %s\n" (show tm)) ;! + if_verbose (fun () -> BU.print1 "unquote: typ = %s\n" (show typ)) ;! + proc_guard "unquote" env guard (Some (should_check_goal_uvar goal)) (rangeof goal) ;! + ret tm + ) + +let uvar_env (env : env) (ty : option typ) : tac term = + let! ps = get in + // If no type was given, add a uvar for it too! + let! typ, g, r = + match ty with + | Some ty -> + let env = Env.set_expected_typ env (U.type_u () |> fst) in + let! ty, _, g = __tc_ghost env ty in + ret (ty, g, ty.pos) + + | None -> + //the type of this uvar is just Type; so it's typedness deps is [] + let! typ, uvar_typ = new_uvar "uvar_env.2" env (fst <| U.type_u ()) None [] ps.entry_range in + ret (typ, Env.trivial_guard, Range.dummyRange) + in + proc_guard "uvar_env_typ" env g None r;! + //the guard is an explicit goal; so the typedness deps of this new uvar is [] + let! t, uvar_t = new_uvar "uvar_env" env typ None [] ps.entry_range in + ret t + +let ghost_uvar_env (env : env) (ty : typ) : tac term = + let! ps = get in + // If no type was given, add a uvar for it too! + let! typ, _, g = __tc_ghost env ty in + proc_guard "ghost_uvar_env_typ" env g None ty.pos ;! + //the guard is an explicit goal; so the typedness deps of this new uvar is [] + let! t, uvar_t = new_uvar "uvar_env" env typ (Some (Allow_ghost "User ghost uvar")) [] ps.entry_range in + ret t + +let fresh_universe_uvar () : tac term = + U.type_u () |> fst |> ret + +let unshelve (t : term) : tac unit = wrap_err "unshelve" <| ( + let! ps = get in + let env = ps.main_context in + (* We need a set of options, but there might be no goals, so do this *) + let opts = match ps.goals with + | g::_ -> g.opts + | _ -> FStarC.Options.peek () + in + match U.head_and_args t with + | { n = Tm_uvar (ctx_uvar, _) }, _ -> + let env = {env with gamma=ctx_uvar.ctx_uvar_gamma} in + let g = mk_goal env ctx_uvar opts false "" in + let g = bnorm_goal g in + add_goals [g] + | _ -> fail "not a uvar" + ) + +let tac_and (t1 : tac bool) (t2 : tac bool) : tac bool = + match! t1 with + | false -> return false + | true -> t2 + +let default_if_err (def : 'a) (t : tac 'a) : tac 'a = + let! r = catch t in + match r with + | Inl _ -> return def + | Inr v -> return v + +let match_env (e:env) (t1 : term) (t2 : term) : tac bool = wrap_err "match_env" <| ( + let! ps = get in + let! t1, ty1, g1 = __tc e t1 in + let! t2, ty2, g2 = __tc e t2 in + proc_guard "match_env g1" e g1 None ps.entry_range ;! + proc_guard "match_env g2" e g2 None ps.entry_range ;! + let must_tot = true in + default_if_err false <| + tac_and (do_match must_tot e ty1 ty2) + (do_match must_tot e t1 t2) + ) + +let unify_env (e:env) (t1 : term) (t2 : term) : tac bool = wrap_err "unify_env" <| ( + let! ps = get in + let! t1, ty1, g1 = __tc e t1 in + let! t2, ty2, g2 = __tc e t2 in + proc_guard "unify_env g1" e g1 None ps.entry_range ;! + proc_guard "unify_env g2" e g2 None ps.entry_range ;! + let must_tot = true in + default_if_err false <| + tac_and (do_unify must_tot e ty1 ty2) + (do_unify must_tot e t1 t2) + ) + +let unify_guard_env (e:env) (t1 : term) (t2 : term) : tac bool = wrap_err "unify_guard_env" <| ( + let! ps = get in + let! t1, ty1, g1 = __tc e t1 in + let! t2, ty2, g2 = __tc e t2 in + proc_guard "unify_guard_env g1" e g1 None ps.entry_range ;! + proc_guard "unify_guard_env g2" e g2 None ps.entry_range ;! + let must_tot = true in + match! do_unify_maybe_guards true must_tot e ty1 ty2 with + | None -> ret false + | Some g1 -> + match! do_unify_maybe_guards true must_tot e t1 t2 with + | None -> ret false + | Some g2 -> + let formula : term = U.mk_conj (guard_formula g1) (guard_formula g2) in + let! goal = goal_of_guard "unify_guard_env.g2" e formula None ps.entry_range in + push_goals [goal] ;! + ret true + ) + +let launch_process (prog : string) (args : list string) (input : string) : tac string = + // The `bind idtac` thunks the tactic + idtac ;! + if Options.unsafe_tactic_exec () then + let s = BU.run_process "tactic_launch" prog args (Some input) in + ret s + else + fail "launch_process: will not run anything unless --unsafe_tactic_exec is provided" + +let fresh_bv_named (nm : string) : tac bv = + // The `bind idtac` thunks the tactic. Not really needed, just being paranoid + idtac ;! ret (gen_bv nm None S.tun) + +let change (ty : typ) : tac unit = wrap_err "change" <| ( + if_verbose (fun () -> BU.print1 "change: ty = %s\n" (show ty)) ;! + let! g = cur_goal in + let! ty, _, guard = __tc (goal_env g) ty in + proc_guard "change" (goal_env g) guard (Some (should_check_goal_uvar g)) (rangeof g) ;! + let must_tot = true in + let! bb = do_unify must_tot (goal_env g) (goal_type g) ty in + if bb + then replace_cur (goal_with_type g ty) + else begin + (* Give it a second try, fully normalize the term the user gave + * and unify it with the fully normalized goal. If that succeeds, + * we use the original one as the new goal. This is sometimes needed + * since the unifier has some bugs. *) + let steps = [Env.AllowUnboundUniverses; Env.UnfoldUntil delta_constant; Env.Primops] in + let ng = normalize steps (goal_env g) (goal_type g) in + let nty = normalize steps (goal_env g) ty in + let! b = do_unify must_tot (goal_env g) ng nty in + if b + then replace_cur (goal_with_type g ty) + else fail "not convertible" + end + ) + +let failwhen (b:bool) (msg:string) : tac unit = + if b + then fail msg + else ret () + +let t_destruct (s_tm : term) : tac (list (fv & Z.t)) = wrap_err "destruct" <| ( + let! g = cur_goal in + let! s_tm, s_ty, guard = __tc (goal_env g) s_tm in + proc_guard "destruct" (goal_env g) guard (Some (should_check_goal_uvar g)) (rangeof g) ;! + let s_ty = N.normalize [Env.DontUnfoldAttr [PC.tac_opaque_attr]; Env.Weak; Env.HNF; Env.UnfoldUntil delta_constant] + (goal_env g) s_ty in + let h, args = U.head_and_args_full (U.unrefine s_ty) in + let! fv, a_us = + match (SS.compress h).n with + | Tm_fvar fv -> ret (fv, []) + | Tm_uinst (h', us) -> + begin match (SS.compress h').n with + | Tm_fvar fv -> ret (fv, us) + | _ -> failwith "impossible: uinst over something that's not an fvar" + end + | _ -> fail "type is not an fv" + in + let t_lid = lid_of_fv fv in + match Env.lookup_sigelt (goal_env g) t_lid with + | None -> fail "type not found in environment" + | Some se -> + match se.sigel with + | Sig_inductive_typ {us=t_us; params=t_ps; t=t_ty; mutuals=mut; ds=c_lids} -> + (* High-level idea of this huge function: + * For Gamma |- w : phi and | C : ps -> bs -> t, we generate a new goal + * Gamma |- w' : bs -> phi + * with + * w = match tm with ... | C .ps' bs' -> w' bs' ... + * i.e., we do not intro the matched binders and let the + * user do that (with the returned arity). `.ps` represents inaccesible patterns + * for the type's parameters. + *) + let erasable = U.has_attribute se.sigattrs FStarC.Parser.Const.erasable_attr in + failwhen (erasable && not (is_irrelevant g)) "cannot destruct erasable type to solve proof-relevant goal" ;! + + (* Instantiate formal universes to the actuals, + * and substitute accordingly in binders and types *) + failwhen (List.length a_us <> List.length t_us) "t_us don't match?" ;! + + + (* Not needed currently? *) + (* let s = Env.mk_univ_subst t_us a_us in *) + (* let t_ps = SS.subst_binders s t_ps in *) + (* let t_ty = SS.subst s t_ty in *) + let t_ps, t_ty = SS.open_term t_ps t_ty in + + let! goal_brs = + mapM (fun c_lid -> + match Env.lookup_sigelt (goal_env g) c_lid with + | None -> fail "ctor not found?" + | Some se -> + match se.sigel with + | Sig_datacon {us=c_us; t=c_ty; num_ty_params=nparam; mutuals=mut} -> + (* BU.print2 "ty of %s = %s\n" (show c_lid) *) + (* (show c_ty); *) + let fv = S.lid_as_fv c_lid (Some Data_ctor) in + + + failwhen (List.length a_us <> List.length c_us) "t_us don't match?" ;! + let s = Env.mk_univ_subst c_us a_us in + let c_ty = SS.subst s c_ty in + + (* The constructor might be universe-polymorphic, just use + * fresh univ_uvars for its universes. *) + let c_us, c_ty = Env.inst_tscheme (c_us, c_ty) in + + (* BU.print2 "ty(2) of %s = %s\n" (show c_lid) *) + (* (show c_ty); *) + + (* Deconstruct its type, separating the parameters from the + * actual arguments (indices do not matter here). *) + let bs, comp = U.arrow_formals_comp c_ty in + + (* More friendly names: 'a_i' instead of '_i' *) + let bs, comp = + let rename_bv bv = + let ppname = bv.ppname in + let ppname = mk_ident ("a" ^ show ppname, range_of_id ppname) in + // freshen just to be extra safe.. probably not needed + freshen_bv ({ bv with ppname = ppname }) + in + let bs' = List.map (fun b -> {b with binder_bv=rename_bv b.binder_bv}) bs in + let subst = List.map2 (fun ({binder_bv=bv}) ({binder_bv=bv'}) -> NT (bv, bv_to_name bv')) bs bs' in + SS.subst_binders subst bs', SS.subst_comp subst comp + in + + (* BU.print1 "bs = (%s)\n" (Print.binders_to_string ", " bs); *) + let d_ps, bs = List.splitAt nparam bs in + failwhen (not (U.is_total_comp comp)) "not total?" ;! + let mk_pat p = { v = p; p = s_tm.pos } in + (* TODO: This is silly, why don't we just keep aq in the Pat_cons? *) + let is_imp = function | Some (Implicit _) -> true + | _ -> false + in + let a_ps, a_is = List.splitAt nparam args in + failwhen (List.length a_ps <> List.length d_ps) "params not match?" ;! + let d_ps_a_ps = List.zip d_ps a_ps in + let subst = List.map (fun (({binder_bv=bv}), (t, _)) -> NT (bv, t)) d_ps_a_ps in + let bs = SS.subst_binders subst bs in + let subpats_1 = List.map (fun (({binder_bv=bv}), (t, _)) -> + (mk_pat (Pat_dot_term (Some t)), true)) d_ps_a_ps in + let subpats_2 = List.map (fun ({binder_bv=bv;binder_qual=bq}) -> + (mk_pat (Pat_var bv), is_imp bq)) bs in + let subpats = subpats_1 @ subpats_2 in + let pat = mk_pat (Pat_cons (fv, Some a_us, subpats)) in + let env = (goal_env g) in + + + (* Add an argument stating the equality between the scrutinee + * and the pattern, in-scope for this branch. *) + let cod = goal_type g in + let equ = env.universe_of env s_ty in + (* Typecheck the pattern, to fill-in the universes and get an expression out of it *) + let _ , _, _, _, pat_t, _, _guard_pat, _erasable = TcTerm.tc_pat ({ env with admit = true }) s_ty pat in + let eq_b = S.gen_bv "breq" None (U.mk_squash S.U_zero (U.mk_eq2 equ s_ty s_tm pat_t)) in + let cod = U.arrow [S.mk_binder eq_b] (mk_Total cod) in + + let nty = U.arrow bs (mk_Total cod) in + let! uvt, uv = new_uvar "destruct branch" env nty None (goal_typedness_deps g) (rangeof g) in + let g' = mk_goal env uv g.opts false g.label in + let brt = U.mk_app_binders uvt bs in + (* Provide the scrutinee equality, which is trivially provable *) + let brt = U.mk_app brt [S.as_arg U.exp_unit] in + let br = SS.close_branch (pat, None, brt) in + ret (g', br, (fv, Z.of_int_fs (List.length bs))) + | _ -> + fail "impossible: not a ctor") + c_lids + in + let goals, brs, infos = List.unzip3 goal_brs in + let w = mk (Tm_match {scrutinee=s_tm;ret_opt=None;brs;rc_opt=None}) s_tm.pos in + solve' g w ;! + //we constructed a well-typed term to solve g; no need to recheck it + mark_goal_implicit_already_checked g; + add_goals goals ;! + ret infos + + | _ -> fail "not an inductive type" + ) + +let gather_explicit_guards_for_resolved_goals () + : tac unit + = ret () + +// TODO: move to library? +let rec last (l:list 'a) : 'a = + match l with + | [] -> failwith "last: empty list" + | [x] -> x + | _::xs -> last xs + +let rec init (l:list 'a) : list 'a = + match l with + | [] -> failwith "init: empty list" + | [x] -> [] + | x::xs -> x :: init xs + +(* TODO: to avoid the duplication with inspect_ln (and the same +for pack), we could instead have an `open_view` function (maybe even +user-facing?) that takes care of opening the needed binders in the rest +of the term. Similarly, a `close_view`. Then: + + inspect = open_view . inspect_ln + pack = pack_ln . close_view + +which would be nice. But.. patterns in matches and recursive +letbindings make that complicated, since we need to duplicate a bunch of +logic from Syntax.Subst here, so I dropped that idea for now. +Everything else goes surprisingly smooth though! + +-- GM 2022/Oct/05 +*) + +let rec inspect (t:term) : tac term_view = wrap_err "inspect" ( + let! e = top_env () in + let t = U.unlazy_emb t in + let t = SS.compress t in + match t.n with + | Tm_meta {tm=t} -> + inspect t + + | Tm_name bv -> + ret <| Tv_Var bv + + | Tm_bvar bv -> + ret <| Tv_BVar bv + + | Tm_fvar fv -> + ret <| Tv_FVar fv + + | Tm_uinst (t, us) -> + (match (t |> SS.compress |> U.unascribe).n with + | Tm_fvar fv -> ret <| Tv_UInst (fv, us) + | _ -> failwith "Tac::inspect: Tm_uinst head not an fvar") + + | Tm_ascribed {tm=t; asc=(Inl ty, tacopt, eq)} -> + ret <| Tv_AscribedT (t, ty, tacopt, eq) + + | Tm_ascribed {tm=t; asc=(Inr cty, tacopt, eq)} -> + ret <| Tv_AscribedC (t, cty, tacopt, eq) + + | Tm_app {args=[]} -> + failwith "empty arguments on Tm_app" + + | Tm_app {hd; args} -> + // We split at the last argument, since the term_view does not + // expose n-ary lambdas buy unary ones. + let (a, q) = last args in + let q' = inspect_aqual q in + ret <| Tv_App (S.mk_Tm_app hd (init args) t.pos, (a, q')) // TODO: The range and tk are probably wrong. Fix + + | Tm_abs {bs=[]} -> + failwith "empty arguments on Tm_abs" + + | Tm_abs {bs; body=t; rc_opt=k} -> + let bs, t = SS.open_term bs t in + // `let b::bs = bs` gives a coverage warning, avoid it + begin match bs with + | [] -> failwith "impossible" + | b::bs -> ret <| Tv_Abs (b, U.abs bs t k) + end + + | Tm_type u -> + ret <| Tv_Type u + + | Tm_arrow {bs=[]} -> + failwith "empty binders on arrow" + + | Tm_arrow _ -> + begin match U.arrow_one t with + | Some (b, c) -> ret <| Tv_Arrow (b, c) + | None -> failwith "impossible" + end + + | Tm_refine {b=bv; phi=t} -> + let b = S.mk_binder bv in + let b', t = SS.open_term [b] t in + // `let [b] = b'` gives a coverage warning, avoid it + let b = (match b' with + | [b'] -> b' + | _ -> failwith "impossible") in + ret <| Tv_Refine (b.binder_bv, b.binder_bv.sort, t) + + | Tm_constant c -> + ret <| Tv_Const (inspect_const c) + + | Tm_uvar (ctx_u, s) -> + ret <| Tv_Uvar (Z.of_int_fs (UF.uvar_unique_id ctx_u.ctx_uvar_head), (ctx_u, s)) + + | Tm_let {lbs=(false, [lb]); body=t2} -> + if lb.lbunivs <> [] then ret <| Tv_Unsupp else + begin match lb.lbname with + | Inr _ -> ret <| Tv_Unsupp // no top level lets + | Inl bv -> + // The type of `bv` should match `lb.lbtyp` + let b = S.mk_binder bv in + let bs, t2 = SS.open_term [b] t2 in + let b = match bs with + | [b] -> b + | _ -> failwith "impossible: open_term returned different amount of binders" + in + ret <| Tv_Let (false, lb.lbattrs, b.binder_bv, bv.sort, lb.lbdef, t2) + end + + | Tm_let {lbs=(true, [lb]); body=t2} -> + if lb.lbunivs <> [] then ret <| Tv_Unsupp else + begin match lb.lbname with + | Inr _ -> ret <| Tv_Unsupp // no top level lets + | Inl bv -> + let lbs, t2 = SS.open_let_rec [lb] t2 in + match lbs with + | [lb] -> + (match lb.lbname with + | Inr _ -> ret Tv_Unsupp + | Inl bv -> ret <| Tv_Let (true, lb.lbattrs, bv, bv.sort, lb.lbdef, t2)) + | _ -> failwith "impossible: open_term returned different amount of binders" + end + + | Tm_match {scrutinee=t; ret_opt; brs} -> + let rec inspect_pat p = + match p.v with + | Pat_constant c -> Pat_Constant (inspect_const c) + | Pat_cons (fv, us_opt, ps) -> Pat_Cons (fv, us_opt, List.map (fun (p, b) -> inspect_pat p, b) ps) + | Pat_var bv -> Pat_Var (bv, Sealed.seal bv.sort) + | Pat_dot_term eopt -> Pat_Dot_Term eopt + in + let brs = List.map SS.open_branch brs in + let brs = List.map (function (pat, _, t) -> (inspect_pat pat, t)) brs in + ret <| Tv_Match (t, ret_opt, brs) + + | Tm_unknown -> + ret <| Tv_Unknown + + | _ -> + Err.log_issue t Err.Warning_CantInspect + (BU.format2 "inspect: outside of expected syntax (%s, %s)\n" (tag_of t) (show t)); + ret <| Tv_Unsupp + ) + +(* This function could actually be pure, it doesn't need freshness + * like `inspect` does, but we mark it as Tac for uniformity. *) +let pack' (tv:term_view) (leave_curried:bool) : tac term = + match tv with + | Tv_Var bv -> + ret <| S.bv_to_name bv + + | Tv_BVar bv -> + ret <| S.bv_to_tm bv + + | Tv_FVar fv -> + ret <| S.fv_to_tm fv + + | Tv_UInst (fv, us) -> + ret <| S.mk_Tm_uinst (S.fv_to_tm fv) us + + | Tv_App (l, (r, q)) -> + let q' = pack_aqual q in + ret <| U.mk_app l [(r, q')] + + | Tv_Abs (b, t) -> + ret <| U.abs [b] t None // TODO: effect? + + | Tv_Arrow (b, c) -> + ret <| (if leave_curried then U.arrow [b] c else U.canon_arrow (U.arrow [b] c)) + + | Tv_Type u -> + ret <| S.mk (Tm_type u) Range.dummyRange + + | Tv_Refine (bv, sort, t) -> + let bv = { bv with sort = sort } in + ret <| U.refine bv t + + | Tv_Const c -> + ret <| S.mk (Tm_constant (pack_const c)) Range.dummyRange + + | Tv_Uvar (_u, ctx_u_s) -> + ret <| S.mk (Tm_uvar ctx_u_s) Range.dummyRange + + | Tv_Let (false, attrs, bv, ty, t1, t2) -> + let bv = { bv with sort = ty } in + let lb = U.mk_letbinding (Inl bv) [] bv.sort PC.effect_Tot_lid t1 attrs Range.dummyRange in + ret <| S.mk (Tm_let {lbs=(false, [lb]); body=SS.close [S.mk_binder bv] t2}) Range.dummyRange + + | Tv_Let (true, attrs, bv, ty, t1, t2) -> + let bv = { bv with sort = ty } in + let lb = U.mk_letbinding (Inl bv) [] bv.sort PC.effect_Tot_lid t1 attrs Range.dummyRange in + let lbs, body = SS.close_let_rec [lb] t2 in + ret <| S.mk (Tm_let {lbs=(true, lbs); body}) Range.dummyRange + + | Tv_Match (t, ret_opt, brs) -> + let wrap v = {v=v;p=Range.dummyRange} in + let rec pack_pat p : S.pat = + match p with + | Pat_Constant c -> wrap <| Pat_constant (pack_const c) + | Pat_Cons (fv, us_opt, ps) -> wrap <| Pat_cons (fv, us_opt, List.map (fun (p, b) -> pack_pat p, b) ps) + | Pat_Var (bv, _sort) -> wrap <| Pat_var bv + | Pat_Dot_Term eopt -> wrap <| Pat_dot_term eopt + in + let brs = List.map (function (pat, t) -> (pack_pat pat, None, t)) brs in + let brs = List.map SS.close_branch brs in + ret <| S.mk (Tm_match {scrutinee=t; ret_opt; brs; rc_opt=None}) Range.dummyRange + + | Tv_AscribedT(e, t, tacopt, use_eq) -> + ret <| S.mk (Tm_ascribed {tm=e;asc=(Inl t, tacopt, use_eq);eff_opt=None}) Range.dummyRange + + | Tv_AscribedC(e, c, tacopt, use_eq) -> + ret <| S.mk (Tm_ascribed {tm=e;asc=(Inr c, tacopt, use_eq);eff_opt=None}) Range.dummyRange + + | Tv_Unknown -> + ret <| S.mk Tm_unknown Range.dummyRange + + | Tv_Unsupp -> + fail "cannot pack Tv_Unsupp" + +let pack (tv:term_view) : tac term = pack' tv false +let pack_curried (tv:term_view) : tac term = pack' tv true + +let lget (ty:term) (k:string) : tac term = wrap_err "lget" <| ( + let! ps = get in + match BU.psmap_try_find ps.local_state k with + | None -> fail "not found" + | Some t -> unquote ty t + ) + +let lset (_ty:term) (k:string) (t:term) : tac unit = wrap_err "lset" <| ( + let! ps = get in + let ps = { ps with local_state = BU.psmap_add ps.local_state k t } in + set ps + ) + +let set_urgency (u:Z.t) : tac unit = + let! ps = get in + let ps = { ps with urgency = Z.to_int_fs u } in + set ps + +let t_commute_applied_match () : tac unit = wrap_err "t_commute_applied_match" <| ( + let! g = cur_goal in + match destruct_eq (goal_env g) (goal_type g) with + | Some (l, r) -> begin + let lh, las = U.head_and_args_full l in + match (SS.compress (U.unascribe lh)).n with + | Tm_match {scrutinee=e;ret_opt=asc_opt;brs;rc_opt=lopt} -> + let brs' = List.map (fun (p, w, e) -> p, w, U.mk_app e las) brs in + // + // If residual comp is set, apply arguments to it + // + let lopt' = lopt |> BU.map_option (fun rc -> {rc with residual_typ= + rc.residual_typ |> BU.map_option (fun t -> + let bs, c = N.get_n_binders (goal_env g) (List.length las) t in + let bs, c = SS.open_comp bs c in + let ss = List.map2 (fun b a -> NT (b.binder_bv, fst a)) bs las in + let c = SS.subst_comp ss c in + U.comp_result c)}) in + let l' = mk (Tm_match {scrutinee=e;ret_opt=asc_opt;brs=brs';rc_opt=lopt'}) l.pos in + let must_tot = true in + begin match! do_unify_maybe_guards false must_tot (goal_env g) l' r with + | None -> fail "discharging the equality failed" + | Some guard -> + if Env.is_trivial_guard_formula guard + then ( + //we just checked that its guard is trivial; so no need to check again + mark_uvar_as_already_checked g.goal_ctx_uvar; + solve g U.exp_unit + ) + else failwith "internal error: _t_refl: guard is not trivial" + end + | _ -> + fail "lhs is not a match" + end + | None -> + fail "not an equality" + ) + +let string_to_term (e: Env.env) (s: string): tac term + = let open FStarC.Parser.ParseIt in + let frag_of_text s = { frag_fname= "" + ; frag_line = 1 ; frag_col = 0 + ; frag_text = s } in + match parse None (Fragment (frag_of_text s)) with + | Term t -> + let dsenv = FStarC.Syntax.DsEnv.set_current_module e.dsenv (current_module e) in + begin try ret (FStarC.ToSyntax.ToSyntax.desugar_term dsenv t) with + | FStarC.Errors.Error (_, e, _, _) -> fail ("string_to_term: " ^ Errors.rendermsg e) + | _ -> fail ("string_to_term: Unknown error") + end + | ASTFragment _ -> fail ("string_to_term: expected a Term as a result, got an ASTFragment") + | ParseError (_, err, _) -> fail ("string_to_term: got error " ^ Errors.rendermsg err) // FIXME + +let push_bv_dsenv (e: Env.env) (i: string): tac (env & bv) + = let ident = Ident.mk_ident (i, FStarC.Compiler.Range.dummyRange) in + let dsenv, bv = FStarC.Syntax.DsEnv.push_bv e.dsenv ident in + ret ({ e with dsenv }, bv) + +let term_to_string (t:term) : tac string + = let s = show t in + ret s + +let comp_to_string (c:comp) : tac string + = let s = show c in + ret s + +let range_to_string (r:FStarC.Compiler.Range.range) : tac string + = ret (show r) + +let term_eq_old (t1:term) (t2:term) : tac bool + = idtac ;! + ret (Syntax.Util.term_eq t1 t2) + +let with_compat_pre_core (n:Z.t) (f:tac 'a) : tac 'a = + mk_tac (fun ps -> + Options.with_saved_options (fun () -> + let _res = FStarC.Options.set_options ("--compat_pre_core 0") in + run f ps)) + +let get_vconfig () : tac vconfig = + let! g = cur_goal in + (* Restore goal's optionstate (a copy is needed) and read vconfig. + * This is an artifact of the options API being stateful in many places, + * morally this is just (get_vconfig g.opts) *) + let vcfg = Options.with_saved_options (fun () -> + FStarC.Options.set g.opts; + Options.get_vconfig ()) + in + ret vcfg + +let set_vconfig (vcfg : vconfig) : tac unit = + (* Same comment as for get_vconfig applies, this is really just + * let g' = { g with opts = set_vconfig vcfg g.opts } *) + let! g = cur_goal in + let opts' = Options.with_saved_options (fun () -> + FStarC.Options.set g.opts; + Options.set_vconfig vcfg; + Options.peek ()) + in + let g' = { g with opts = opts' } in + replace_cur g' + +let t_smt_sync (vcfg : vconfig) : tac unit = wrap_err "t_smt_sync" <| ( + let! goal = cur_goal in + match get_phi goal with + | None -> fail "Goal is not irrelevant" + | Some phi -> + let e = goal_env goal in + let ans : bool = + (* Set goal's optionstate before asking solver, to respect + * its vconfig among other things. *) + Options.with_saved_options (fun () -> + (* NOTE: we ignore the goal's options, the rationale is that + * any verification-relevant option is inside the vconfig, so we + * should not need read the optionstate. Of course this vconfig + * will probably come in large part from a get_vconfig, which does + * read the goal's options. *) + Options.set_vconfig vcfg; + e.solver.solve_sync None e phi + ) + in + if ans + then ( + mark_uvar_as_already_checked goal.goal_ctx_uvar; + solve goal U.exp_unit + ) else fail "SMT did not solve this goal" +) + +let free_uvars (tm : term) : tac (list Z.t) + = idtac ;! + let uvs = Syntax.Free.uvars_uncached tm |> elems |> List.map (fun u -> Z.of_int_fs (UF.uvar_id u.ctx_uvar_head)) in + ret uvs + +(***** Builtins used in the meta DSL framework *****) + +let dbg_refl (g:env) (msg:unit -> string) = + if !dbg_ReflTc + then BU.print_string (msg ()) + +let issues = list Errors.issue +let refl_typing_builtin_wrapper (f:unit -> 'a) : tac (option 'a & issues) = + let tx = UF.new_transaction () in + let errs, r = + try Errors.catch_errors_and_ignore_rest f + with exn -> //catch everything + let issue = FStarC.Errors.({ + issue_msg = Errors.mkmsg (BU.print_exn exn); + issue_level = EError; + issue_range = None; + issue_number = (Some 17); + issue_ctx = get_ctx () + }) in + [issue], None + in + UF.rollback tx; + if List.length errs > 0 + then ret (None, errs) + else ret (r, errs) + +let no_uvars_in_term (t:term) : bool = + t |> Free.uvars |> is_empty && + t |> Free.univs |> is_empty + +let no_uvars_in_g (g:env) : bool = + g.gamma |> BU.for_all (function + | Binding_var bv -> no_uvars_in_term bv.sort + | _ -> true) + +type relation = + | Subtyping + | Equality + +let unexpected_uvars_issue r = + let open FStarC.Errors in + let i = { + issue_level = EError; + issue_range = Some r; + issue_msg = Errors.mkmsg "Cannot check relation with uvars"; + issue_number = Some (errno Error_UnexpectedUnresolvedUvar); + issue_ctx = [] + } in + i diff --git a/src/tactics/FStarC.Tactics.V1.Basic.fsti b/src/tactics/FStarC.Tactics.V1.Basic.fsti new file mode 100644 index 00000000000..ef5e47879e4 --- /dev/null +++ b/src/tactics/FStarC.Tactics.V1.Basic.fsti @@ -0,0 +1,117 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Tactics.V1.Basic + +(* This module implements the primitives in + * ulib/FStarC.Tactics.Builtins. It would be named + * the same, but there needs to be a thin adapter + * layer since the tac monad representation differs + * between compiler and userspace (and a few other + * annoyances too). *) + +open FStarC.Syntax.Syntax +open FStarC.TypeChecker.Env +open FStarC.Reflection.V1.Data +open FStarC.Tactics.Types +open FStarC.Tactics.Monad + +module BU = FStarC.Compiler.Util +module O = FStarC.Options +module Range = FStarC.Compiler.Range +module Z = FStarC.BigInt +module TcComm = FStarC.TypeChecker.Common +module Core = FStarC.TypeChecker.Core + +(* Internal utilities *) +val goal_typedness_deps : goal -> list ctx_uvar + +(* Helper *) +val focus : tac 'a -> tac 'a + +(* Metaprogramming primitives (not all of them). + * Documented in `ulib/FStarC.Tactics.Builtins.fst` *) + +val top_env : unit -> tac env +val fresh : unit -> tac Z.t +val refine_intro : unit -> tac unit +val tc : env -> term -> tac typ +val tcc : env -> term -> tac comp +val unshelve : term -> tac unit +val unquote : typ -> term -> tac term +val norm : list Pervasives.norm_step -> tac unit +val norm_term_env : env -> list Pervasives.norm_step -> term -> tac term +val norm_binder_type : list Pervasives.norm_step -> binder -> tac unit +val intro : unit -> tac binder +val intro_rec : unit -> tac (binder & binder) +val rename_to : binder -> string -> tac binder +val revert : unit -> tac unit +val binder_retype : binder -> tac unit +val clear_top : unit -> tac unit +val clear : binder -> tac unit +val rewrite : binder -> tac unit +val t_exact : bool -> bool -> term -> tac unit +val t_apply : bool -> bool -> bool -> term -> tac unit +val t_apply_lemma : bool -> bool -> term -> tac unit +val print : string -> tac unit +val debugging : unit -> tac bool +val dump : string -> tac unit +val dump_all : bool -> string -> tac unit +val dump_uvars_of : goal -> string -> tac unit +val t_trefl : (*allow_guards:*)bool -> tac unit +val dup : unit -> tac unit +val prune : string -> tac unit +val addns : string -> tac unit +val t_destruct : term -> tac (list (fv & Z.t)) +val gather_explicit_guards_for_resolved_goals : unit -> tac unit +val set_options : string -> tac unit +val uvar_env : env -> option typ -> tac term +val ghost_uvar_env : env -> typ -> tac term +val fresh_universe_uvar : unit -> tac term +val unify_env : env -> term -> term -> tac bool +val unify_guard_env : env -> term -> term -> tac bool +val match_env : env -> term -> term -> tac bool +val launch_process : string -> list string -> string -> tac string +val fresh_bv_named : string -> tac bv +val change : typ -> tac unit +val get_guard_policy : unit -> tac guard_policy +val set_guard_policy : guard_policy -> tac unit +val lax_on : unit -> tac bool +val tadmit_t : term -> tac unit +val inspect : term -> tac term_view +val pack : term_view -> tac term +val pack_curried : term_view -> tac term +val join : unit -> tac unit +val lget : typ -> string -> tac term +val lset : typ -> string -> term -> tac unit +val curms : unit -> tac Z.t +val set_urgency : Z.t -> tac unit +val t_commute_applied_match : unit -> tac unit +val goal_with_type : goal -> typ -> goal +val mark_goal_implicit_already_checked : goal -> unit +val string_to_term : env -> string -> tac term +val push_bv_dsenv : env -> string -> tac (env & bv) +val term_to_string : term -> tac string +val comp_to_string : comp -> tac string +val range_to_string : Range.range -> tac string + +val term_eq_old : term -> term -> tac bool +val with_compat_pre_core : Z.t -> tac 'a -> tac 'a + +val get_vconfig : unit -> tac FStarC.VConfig.vconfig +val set_vconfig : FStarC.VConfig.vconfig -> tac unit +val t_smt_sync : FStarC.VConfig.vconfig -> tac unit +val free_uvars : term -> tac (list Z.t) diff --git a/src/tactics/FStarC.Tactics.V1.Primops.fst b/src/tactics/FStarC.Tactics.V1.Primops.fst new file mode 100644 index 00000000000..adf12d7507a --- /dev/null +++ b/src/tactics/FStarC.Tactics.V1.Primops.fst @@ -0,0 +1,266 @@ +module FStarC.Tactics.V1.Primops + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Compiler.Range +open FStarC.Compiler.Util +open FStarC.Syntax.Syntax +open FStarC.Syntax.Embeddings +open FStarC.TypeChecker.Common +open FStarC.TypeChecker.Env +open FStarC.Tactics.Result +open FStarC.Tactics.Types +open FStarC.Tactics.Printing +open FStarC.Tactics.Monad +open FStarC.Tactics.V1.Basic +open FStarC.Tactics.CtrlRewrite +open FStarC.Tactics.Native +open FStarC.Tactics.Common +open FStarC.Tactics.InterpFuns +open FStarC.Class.Show +open FStarC.Class.Monad +open FStarC.Class.HasRange + +module BU = FStarC.Compiler.Util +module Cfg = FStarC.TypeChecker.Cfg +module E = FStarC.Tactics.Embedding +module Env = FStarC.TypeChecker.Env +module Err = FStarC.Errors +module N = FStarC.TypeChecker.Normalize +module NBE = FStarC.TypeChecker.NBE +module NBET = FStarC.TypeChecker.NBETerm +module NRE = FStarC.Reflection.V1.NBEEmbeddings +module PC = FStarC.Parser.Const +module PO = FStarC.TypeChecker.Primops +module Print = FStarC.Syntax.Print +module RE = FStarC.Reflection.V1.Embeddings +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module TcComm = FStarC.TypeChecker.Common +module TcRel = FStarC.TypeChecker.Rel +module TcTerm = FStarC.TypeChecker.TcTerm +module TI = FStarC.Tactics.Interpreter +module U = FStarC.Syntax.Util + +(* Bring instances *) +open FStarC.Reflection.V2.Embeddings {} +open FStarC.Reflection.V2.NBEEmbeddings {} + +let solve (#a:Type) {| ev : a |} : Tot a = ev + +instance _ : embedding term = RE.e_term (* REMOVE ME *) + +let fix_module (ps : PO.primitive_step) : PO.primitive_step = + let p : Path.path string = Ident.path_of_lid ps.name in + if p `Path.is_under` ["FStar"; "Stubs"; "Tactics"; "V2"; "Builtins"] then + let p' = ["FStar"; "Stubs"; "Tactics"; "V1"; "Builtins"] @ (p |> List.tl |> List.tl |> List.tl |> List.tl |> List.tl) in + { ps with name = Ident.lid_of_path p' (pos ps.name) } + else + failwith "huh?" + +let ops = + List.map fix_module <| +[ + (* Total steps defined in V2 *) + + mk_tac_step_1 0 "set_goals" set_goals set_goals; + mk_tac_step_1 0 "set_smt_goals" set_smt_goals set_smt_goals; + + mk_tac_step_2 1 "catch" + #e_any #(TI.e_tactic_thunk e_any) #(e_either E.e_exn e_any) + #NBET.e_any #(TI.e_tactic_nbe_thunk NBET.e_any) #(NBET.e_either E.e_exn_nbe NBET.e_any) + (fun _ -> catch) + (fun _ -> catch); + + mk_tac_step_2 1 "recover" + #e_any #(TI.e_tactic_thunk e_any) #(e_either E.e_exn e_any) + #NBET.e_any #(TI.e_tactic_nbe_thunk NBET.e_any) #(NBET.e_either E.e_exn_nbe NBET.e_any) + (fun _ -> recover) + (fun _ -> recover); + + mk_tac_step_1 0 "intro" intro intro ; + mk_tac_step_1 0 "intro_rec" intro_rec intro_rec ; + mk_tac_step_1 0 "norm" norm norm ; + mk_tac_step_3 0 "norm_term_env" norm_term_env norm_term_env ; + mk_tac_step_2 0 "norm_binder_type" norm_binder_type norm_binder_type; + mk_tac_step_2 0 "rename_to" rename_to rename_to ; + + mk_tac_step_1 0 "binder_retype" binder_retype binder_retype ; + mk_tac_step_1 0 "revert" revert revert ; + mk_tac_step_1 0 "clear_top" clear_top clear_top ; + mk_tac_step_1 0 "clear" clear clear ; + mk_tac_step_1 0 "rewrite" rewrite rewrite ; + mk_tac_step_1 0 "refine_intro" refine_intro refine_intro ; + mk_tac_step_3 0 "t_exact" t_exact t_exact ; + mk_tac_step_4 0 "t_apply" t_apply t_apply ; + mk_tac_step_3 0 "t_apply_lemma" t_apply_lemma t_apply_lemma ; + mk_tac_step_1 0 "set_options" set_options set_options ; + mk_tac_step_2 0 "tcc" tcc tcc ; + mk_tac_step_2 0 "tc" tc tc ; + + mk_tac_step_1 0 "unshelve" unshelve unshelve; + + mk_tac_step_2 1 "unquote" + #e_any #RE.e_term #e_any + #NBET.e_any #NRE.e_term #NBET.e_any + unquote + (fun _ _ -> failwith "NBE unquote"); + + mk_tac_step_1 0 "prune" prune prune ; + mk_tac_step_1 0 "addns" addns addns ; + mk_tac_step_1 0 "print" print print ; + mk_tac_step_1 0 "debugging" debugging debugging ; + mk_tac_step_1 0 "dump" dump dump ; + mk_tac_step_2 0 "dump_all" dump_all dump_all ; + mk_tac_step_2 0 "dump_uvars_of" dump_uvars_of dump_uvars_of ; + + mk_tac_step_3 0 "ctrl_rewrite" + #E.e_direction #(TI.e_tactic_1 RE.e_term (e_tuple2 e_bool E.e_ctrl_flag)) #(TI.e_tactic_thunk e_unit) #e_unit + #E.e_direction_nbe #(TI.e_tactic_nbe_1 NRE.e_term (NBET.e_tuple2 NBET.e_bool E.e_ctrl_flag_nbe)) #(TI.e_tactic_nbe_thunk NBET.e_unit) #NBET.e_unit + ctrl_rewrite + ctrl_rewrite; + + mk_tac_step_1 0 "t_trefl" t_trefl t_trefl ; + mk_tac_step_1 0 "dup" dup dup ; + + mk_tac_step_1 0 "tadmit_t" #RE.e_term #_ #NRE.e_term #_ tadmit_t tadmit_t ; + mk_tac_step_1 0 "join" join join ; + + mk_tac_step_1 0 "t_destruct" + #RE.e_term #_ + #NRE.e_term #_ + t_destruct t_destruct; + + mk_tac_step_1 0 "top_env" + top_env + top_env ; + + mk_tac_step_1 0 "inspect" + #RE.e_term #_ + #NRE.e_term #_ + inspect inspect ; + + mk_tac_step_1 0 "pack" + #_ #RE.e_term + #_ #NRE.e_term + pack pack ; + + mk_tac_step_1 0 "pack_curried" + #_ #RE.e_term + #_ #NRE.e_term + pack_curried pack_curried; + + mk_tac_step_1 0 "fresh" fresh fresh ; + mk_tac_step_1 0 "curms" curms curms ; + mk_tac_step_2 0 "uvar_env" + #_ #(e_option RE.e_term) #RE.e_term + #_ #(NBET.e_option NRE.e_term) #NRE.e_term + uvar_env uvar_env ; + + mk_tac_step_2 0 "ghost_uvar_env" + #_ #RE.e_term #RE.e_term + #_ #NRE.e_term #NRE.e_term + ghost_uvar_env ghost_uvar_env ; + + mk_tac_step_1 0 "fresh_universe_uvar" + #_ #RE.e_term + #_ #NRE.e_term + fresh_universe_uvar + fresh_universe_uvar ; + + mk_tac_step_3 0 "unify_env" + #RE.e_env #RE.e_term #RE.e_term #e_bool + #NRE.e_env #NRE.e_term #NRE.e_term #NBET.e_bool + unify_env unify_env ; + + mk_tac_step_3 0 "unify_guard_env" + #RE.e_env #RE.e_term #RE.e_term #e_bool + #NRE.e_env #NRE.e_term #NRE.e_term #NBET.e_bool + unify_guard_env unify_guard_env ; + + mk_tac_step_3 0 "match_env" + #RE.e_env #RE.e_term #RE.e_term #e_bool + #NRE.e_env #NRE.e_term #NRE.e_term #NBET.e_bool + match_env match_env ; + + mk_tac_step_3 0 "launch_process" launch_process launch_process ; + + mk_tac_step_1 0 "fresh_bv_named" + #e_string #RE.e_bv + #NBET.e_string #NRE.e_bv + fresh_bv_named fresh_bv_named ; + + mk_tac_step_1 0 "change" + #RE.e_term #e_unit + #NRE.e_term #NBET.e_unit + change change ; + + mk_tac_step_1 0 "get_guard_policy" get_guard_policy get_guard_policy ; + mk_tac_step_1 0 "set_guard_policy" set_guard_policy set_guard_policy ; + mk_tac_step_1 0 "lax_on" lax_on lax_on ; + + mk_tac_step_2 1 "lget" + #e_any #e_string #e_any + #NBET.e_any #NBET.e_string #NBET.e_any + lget + (fun _ _ -> fail "sorry, `lget` does not work in NBE") ; + + mk_tac_step_3 1 "lset" + #e_any #e_string #e_any #e_unit + #NBET.e_any #NBET.e_string #NBET.e_any #NBET.e_unit + lset + (fun _ _ _ -> fail "sorry, `lset` does not work in NBE") ; + + mk_tac_step_1 0 "set_urgency" set_urgency set_urgency ; + + mk_tac_step_1 0 "t_commute_applied_match" + t_commute_applied_match + t_commute_applied_match ; + + mk_tac_step_1 0 "gather_or_solve_explicit_guards_for_resolved_goals" + gather_explicit_guards_for_resolved_goals + gather_explicit_guards_for_resolved_goals ; + + mk_tac_step_2 0 "string_to_term" + #RE.e_env #e_string #RE.e_term + #NRE.e_env #NBET.e_string #NRE.e_term + string_to_term string_to_term ; + + mk_tac_step_2 0 "push_bv_dsenv" + #RE.e_env #e_string #(e_tuple2 RE.e_env RE.e_bv) + #NRE.e_env #NBET.e_string #(NBET.e_tuple2 NRE.e_env NRE.e_bv) + push_bv_dsenv push_bv_dsenv ; + + mk_tac_step_1 0 "term_to_string" + #RE.e_term #e_string + #NRE.e_term #NBET.e_string + term_to_string term_to_string ; + + mk_tac_step_1 0 "comp_to_string" + comp_to_string + comp_to_string ; + + mk_tac_step_1 0 "range_to_string" range_to_string range_to_string ; + mk_tac_step_2 0 "term_eq_old" + #RE.e_term #RE.e_term #e_bool + #NRE.e_term #NRE.e_term #NBET.e_bool + term_eq_old + term_eq_old ; + + mk_tac_step_3 1 "with_compat_pre_core" + #e_any #e_int #(TI.e_tactic_thunk e_any) #e_any + #NBET.e_any #NBET.e_int #(TI.e_tactic_nbe_thunk NBET.e_any) #NBET.e_any + (fun _ -> with_compat_pre_core) (fun _ -> with_compat_pre_core) ; + + mk_tac_step_1 0 "get_vconfig" get_vconfig get_vconfig ; + mk_tac_step_1 0 "set_vconfig" set_vconfig set_vconfig ; + mk_tac_step_1 0 "t_smt_sync" t_smt_sync t_smt_sync ; + + mk_tac_step_1 0 "free_uvars" + #RE.e_term #_ + #NRE.e_term #_ + free_uvars free_uvars ; + +] diff --git a/src/tactics/FStarC.Tactics.V1.Primops.fsti b/src/tactics/FStarC.Tactics.V1.Primops.fsti new file mode 100644 index 00000000000..f61d24ae564 --- /dev/null +++ b/src/tactics/FStarC.Tactics.V1.Primops.fsti @@ -0,0 +1,20 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Tactics.V1.Primops + +open FStarC.TypeChecker.Primops.Base + +val ops : list primitive_step diff --git a/src/tactics/FStarC.Tactics.V2.Basic.fst b/src/tactics/FStarC.Tactics.V2.Basic.fst new file mode 100644 index 00000000000..91ae5ffbb7e --- /dev/null +++ b/src/tactics/FStarC.Tactics.V2.Basic.fst @@ -0,0 +1,2996 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Tactics.V2.Basic + +open FStar open FStarC +open FStarC.Compiler +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Compiler.Util +open FStarC.Ident +open FStarC.TypeChecker.Env +open FStarC.TypeChecker.Common +open FStarC.Pprint +open FStarC.Reflection.V2.Data +open FStarC.Reflection.V2.Builtins +open FStarC.Tactics.Result +open FStarC.Tactics.Types +open FStarC.Tactics.Monad +open FStarC.Tactics.Printing +open FStarC.Syntax.Syntax +open FStarC.VConfig +open FStarC.Errors.Msg +module Listlike = FStarC.Class.Listlike + +friend FStar.Pervasives (* to expose norm_step *) + +module BU = FStarC.Compiler.Util +module Cfg = FStarC.TypeChecker.Cfg +module Env = FStarC.TypeChecker.Env +module Err = FStarC.Errors +module N = FStarC.TypeChecker.Normalize +module PC = FStarC.Parser.Const +module Print = FStarC.Syntax.Print +module Free = FStarC.Syntax.Free +module RD = FStarC.Reflection.V2.Data +module Rel = FStarC.TypeChecker.Rel +module SF = FStarC.Syntax.Free +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module SC = FStarC.Syntax.Compress +module TcComm = FStarC.TypeChecker.Common +module TcTerm = FStarC.TypeChecker.TcTerm +module TcUtil = FStarC.TypeChecker.Util +module UF = FStarC.Syntax.Unionfind +module U = FStarC.Syntax.Util +module Z = FStarC.BigInt +module Core = FStarC.TypeChecker.Core +module PO = FStarC.TypeChecker.Primops +module TC = FStar.Tactics.Typeclasses + +let dbg_Tac = Debug.get_toggle "Tac" +let dbg_TacUnify = Debug.get_toggle "TacUnify" +let dbg_2635 = Debug.get_toggle "2635" +let dbg_ReflTc = Debug.get_toggle "ReflTc" +let dbg_TacVerbose = Debug.get_toggle "TacVerbose" + +open FStarC.Class.Show +open FStarC.Class.Monad +open FStarC.Class.PP +open FStarC.Class.Setlike + +let compress (t:term) : tac term = + return ();! + return (SS.compress t) + +let core_check env sol t must_tot + : either (option typ) Core.error + = if not (Options.compat_pre_core_should_check()) then Inl None else + let debug f = + if Debug.any() + then f () + else () + in + match FStarC.TypeChecker.Core.check_term env sol t must_tot with + | Inl None -> + Inl None + + | Inl (Some g) -> + if Options.compat_pre_core_set () //core check the solution, but drop the guard, pre_core + then Inl None + else Inl (Some g) + + + | Inr err -> + debug (fun _ -> + BU.print5 "(%s) Core checking failed (%s) on term %s and type %s\n%s\n" + (show (Env.get_range env)) + (Core.print_error_short err) + (show sol) + (show t) + (Core.print_error err)); + Inr err + +type name = bv +type env = Env.env +type implicits = Env.implicits + +let rangeof g = g.goal_ctx_uvar.ctx_uvar_range + +// Beta reduce +let normalize s e t = N.normalize s e t +let bnorm e t = normalize [] e t +let whnf e t = N.unfold_whnf e t + +(* Use this one for everything the user is supposed to see, EXCEPT + * STATE DUMPS, as it does resugaring. For debug messages, just use plain + * term_to_string, we don't want to cause normalization with debug + * flags. *) +let tts = N.term_to_string +let ttd = N.term_to_doc + +let bnorm_goal g = goal_with_type g (bnorm (goal_env g) (goal_type g)) + +let tacprint (s:string) = BU.print1 "TAC>> %s\n" s +let tacprint1 (s:string) x = BU.print1 "TAC>> %s\n" (BU.format1 s x) +let tacprint2 (s:string) x y = BU.print1 "TAC>> %s\n" (BU.format2 s x y) +let tacprint3 (s:string) x y z = BU.print1 "TAC>> %s\n" (BU.format3 s x y z) + +let print (msg:string) : tac unit = + if not (Options.silent ()) then + tacprint msg; + return () + +let debugging () : tac bool = + return ();! (* thunk *) + return !dbg_Tac + +let ide () : tac bool = + return ();! (* thunk *) + return (Options.ide ()) + +let do_dump_ps (msg:string) (ps:proofstate) : unit = + let psc = ps.psc in + let subst = PO.psc_subst psc in + do_dump_proofstate ps msg + +let dump (msg:string) : tac unit = + mk_tac (fun ps -> + do_dump_ps msg ps; + Success ((), ps)) + +let dump_all (print_resolved:bool) (msg:string) : tac unit = + mk_tac (fun ps -> + (* Make a new proofstate with goals for each implicit, + * print it, and return original proofstate unchanged. *) + let gs = List.map (fun i -> goal_of_implicit ps.main_context i) ps.all_implicits in + let gs = + if print_resolved + then gs + else List.filter (fun g -> not (check_goal_solved g)) gs + in + let ps' = { ps with smt_goals = [] ; goals = gs } in + do_dump_ps msg ps'; + Success ((), ps)) + +let dump_uvars_of (g:goal) (msg:string) : tac unit = + mk_tac (fun ps -> + let uvs = SF.uvars (goal_type g) |> elems in // elems order dependent but OK + let gs = List.map (goal_of_ctx_uvar g) uvs in + let gs = List.filter (fun g -> not (check_goal_solved g)) gs in + let ps' = { ps with smt_goals = [] ; goals = gs } in + do_dump_ps msg ps'; + Success ((), ps)) + +let fail1 msg x = fail (BU.format1 msg x) +let fail2 msg x y = fail (BU.format2 msg x y) +let fail3 msg x y z = fail (BU.format3 msg x y z) +let fail4 msg x y z w = fail (BU.format4 msg x y z w) + +let destruct_eq' (typ : typ) : option (term & term) = + let open FStarC.Syntax.Formula in + match destruct_typ_as_formula typ with + | Some (BaseConn(l, [_; (e1, None); (e2, None)])) + when Ident.lid_equals l PC.eq2_lid + || Ident.lid_equals l PC.c_eq2_lid + -> + Some (e1, e2) + | _ -> + match U.unb2t typ with + | None -> None + | Some t -> + begin + let hd, args = U.head_and_args t in + match (SS.compress hd).n, args with + | Tm_fvar fv, [(_, Some ({ aqual_implicit = true })); (e1, None); (e2, None)] when S.fv_eq_lid fv PC.op_Eq -> + Some (e1, e2) + | _ -> None + end + +let destruct_eq (env : Env.env) (typ : typ) : option (term & term) = +// TODO: unascribe? + (* let typ = whnf env typ in *) + match destruct_eq' typ with + | Some t -> Some t + | None -> + // Retry for a squashed one + begin match U.un_squash typ with + | Some typ -> + (* let typ = whnf env typ in *) + destruct_eq' typ + | None -> None + end + + +let get_guard_policy () : tac guard_policy = + let! ps = get in + return ps.guard_policy + +let set_guard_policy (pol : guard_policy) : tac unit = + let! ps = get in + set ({ ps with guard_policy = pol }) + +let with_policy pol (t : tac 'a) : tac 'a = + let! old_pol = get_guard_policy () in + set_guard_policy pol;! + let! r = t in + set_guard_policy old_pol;! + return r + +let proc_guard_formula + (reason:string) (e : env) (f : term) (sc_opt : option should_check_uvar) + (rng:Range.range) +: tac unit += let! ps = get in + match ps.guard_policy with + | Drop -> + // should somehow taint the state instead of just printing a warning + Err.log_issue e Errors.Warning_TacAdmit + (BU.format1 "Tactics admitted guard <%s>\n\n" (show f)); + return () + + | Goal -> + log (fun () -> BU.print2 "Making guard (%s:%s) into a goal\n" reason (show f));! + let! g = goal_of_guard reason e f sc_opt rng in + push_goals [g] + + | SMT -> + log (fun () -> BU.print2 "Pushing guard (%s:%s) as SMT goal\n" reason (show f));! + let! g = goal_of_guard reason e f sc_opt rng in + push_smt_goals [g] + + | SMTSync -> + log (fun () -> BU.print2 "Sending guard (%s:%s) to SMT Synchronously\n" reason (show f));! + let g = { Env.trivial_guard with guard_f = NonTrivial f } in + Rel.force_trivial_guard e g; + return () + + | Force -> + log (fun () -> BU.print2 "Forcing guard (%s:%s)\n" reason (show f));! + let g = { Env.trivial_guard with guard_f = NonTrivial f } in + begin try + if not (Env.is_trivial <| Rel.discharge_guard_no_smt e g) + then fail1 "Forcing the guard failed (%s)" reason + else return () + with + | _ -> + log (fun () -> BU.print1 "guard = %s\n" (show f));! + fail1 "Forcing the guard failed (%s)" reason + end + + | ForceSMT -> + log (fun () -> BU.print2 "Forcing guard WITH SMT (%s:%s)\n" reason (show f));! + let g = { Env.trivial_guard with guard_f = NonTrivial f } in + try if not (Env.is_trivial <| Rel.discharge_guard e g) + then fail1 "Forcing the guard failed (%s)" reason + else return () + with + | _ -> + log (fun () -> BU.print1 "guard = %s\n" (show f));! + fail1 "Forcing the guard failed (%s)" reason + +let proc_guard' (simplify:bool) (reason:string) (e : env) (g : guard_t) (sc_opt:option should_check_uvar) (rng:Range.range) : tac unit = + log (fun () -> BU.print2 "Processing guard (%s:%s)\n" reason (Rel.guard_to_string e g));! + let imps = Listlike.to_list g.implicits in + let _ = + match sc_opt with + | Some (Allow_untyped r) -> + List.iter + (fun imp -> mark_uvar_with_should_check_tag imp.imp_uvar (Allow_untyped r)) + imps + | _ -> () + in + add_implicits imps ;! + let guard_f = + if simplify + then (Rel.simplify_guard e g).guard_f + else g.guard_f + in + match guard_f with + | TcComm.Trivial -> return () + | TcComm.NonTrivial f -> + proc_guard_formula reason e f sc_opt rng + +let proc_guard = proc_guard' true + +// +// See if any of the implicits in uvs were solved in a Rel call, +// if so, core check them +// +let tc_unifier_solved_implicits env (must_tot:bool) (allow_guards:bool) (uvs:list ctx_uvar) : tac unit = + let aux (u:ctx_uvar) : tac unit = + let dec = UF.find_decoration u.ctx_uvar_head in + let sc = dec.uvar_decoration_should_check in + match sc with + | Allow_untyped _ -> + return () + | Already_checked -> + return () + | _ -> + match UF.find u.ctx_uvar_head with + | None -> + return () //not solved yet + | Some sol -> //solved, check it + let env = {env with gamma=u.ctx_uvar_gamma} in + let must_tot = must_tot && not (Allow_ghost? dec.uvar_decoration_should_check) in + match core_check env sol (U.ctx_uvar_typ u) must_tot with + | Inl None -> + //checked with no guard + //no need to check it again + mark_uvar_as_already_checked u; + return () + + | Inl (Some g) -> + let guard = { Env.trivial_guard with guard_f = NonTrivial g } in + let guard = Rel.simplify_guard env guard in + if Options.disallow_unification_guards () + && not allow_guards + && NonTrivial? guard.guard_f + then ( + fail_doc [ + text "Could not typecheck unifier solved implicit" ^/^ pp u.ctx_uvar_head ^/^ + text "to" ^/^ pp sol ^/^ text "since it produced a guard and guards were not allowed"; + text "Guard =" ^/^ pp g + ] + ) + else ( + proc_guard' false "guard for implicit" env guard (Some sc) u.ctx_uvar_range ;! + mark_uvar_as_already_checked u; + return () + ) + + | Inr failed -> + fail_doc [ + text "Could not typecheck unifier solved implicit" ^/^ pp u.ctx_uvar_head ^/^ + text "to" ^/^ pp sol ^/^ text "because" ^/^ doc_of_string (Core.print_error failed) + ] + in + if env.phase1 //phase1 is untrusted + then return () + else uvs |> iter_tac aux + +// +// When calling Rel for t1 `rel` t2, caller can choose to tc +// implicits solved during this unification +// With side argument they can control, which side args to check +// E.g. do_match will choose only Right, +// since it fails if some uvar on the left is instantiated +// +type check_unifier_solved_implicits_side = + | Check_none + | Check_left_only + | Check_right_only + | Check_both + +let __do_unify_wflags + (dbg:bool) + (allow_guards:bool) + (must_tot:bool) + (check_side:check_unifier_solved_implicits_side) + (env:env) (t1:term) (t2:term) + : tac (option guard_t) = + if dbg then + BU.print2 "%%%%%%%%do_unify %s =? %s\n" (show t1) + (show t2); + + let all_uvars = + (match check_side with + | Check_none -> empty () + | Check_left_only -> Free.uvars t1 + | Check_right_only -> Free.uvars t2 + | Check_both -> union (Free.uvars t1) (Free.uvars t2)) + |> elems /// GGG order dependent but does not seem too bad + in + + match! + catch (//restore UF graph in case anything fails + let! gopt = trytac cur_goal in + try + let res = + if allow_guards + then Rel.try_teq true env t1 t2 + else Rel.teq_nosmt env t1 t2 + in + if dbg then + BU.print3 "%%%%%%%%do_unify (RESULT %s) %s =? %s\n" + (FStarC.Common.string_of_option (Rel.guard_to_string env) res) + (show t1) + (show t2); + + match res with + | None -> + return None + | Some g -> + tc_unifier_solved_implicits env must_tot allow_guards all_uvars;! + add_implicits (Listlike.to_list g.implicits);! + return (Some g) + + with | Errors.Error (_, msg, r, _) -> + log (fun () -> BU.print2 ">> do_unify error, (%s) at (%s)\n" (Errors.rendermsg msg) (show r));! + return None + ) + with + | Inl exn -> traise exn + | Inr v -> return v + +(* Just a wrapper over __do_unify_wflags to better debug *) +let __do_unify + (allow_guards:bool) + (must_tot:bool) + (check_side:check_unifier_solved_implicits_side) + (env:env) (t1:term) (t2:term) + : tac (option guard_t) = + return ();! + if !dbg_TacUnify then begin + Options.push (); + let _ = Options.set_options "--debug Rel,RelCheck" in + () + end; + let! r = __do_unify_wflags !dbg_TacUnify allow_guards must_tot check_side env t1 t2 in + if !dbg_TacUnify then Options.pop (); + return r + +(* SMT-free unification. *) +let do_unify_aux + (must_tot:bool) + (check_side:check_unifier_solved_implicits_side) + (env:env) (t1:term) (t2:term) + : tac bool = + match! __do_unify false must_tot check_side env t1 t2 with + | None -> return false + | Some g -> + (* g has to be trivial and we have already added its implicits *) + if not (Env.is_trivial_guard_formula g) then + failwith "internal error: do_unify: guard is not trivial" + else + return ();! + return true + +let do_unify (must_tot:bool) (env:env) (t1:term) (t2:term) : tac bool = + do_unify_aux must_tot Check_both env t1 t2 + +let do_unify_maybe_guards (allow_guards:bool) (must_tot:bool) + (env:env) (t1:term) (t2:term) + : tac (option guard_t) = + __do_unify allow_guards must_tot Check_both env t1 t2 + +(* Does t1 match t2? That is, do they unify without instantiating/changing t1? *) +let do_match (must_tot:bool) (env:Env.env) (t1:term) (t2:term) : tac bool = + let! tx = mk_tac (fun ps -> let tx = UF.new_transaction () in + Success (tx, ps)) in + let uvs1 = SF.uvars_uncached t1 in + let! r = do_unify_aux must_tot Check_right_only env t1 t2 in + if r then begin + let uvs2 = SF.uvars_uncached t1 in + if not (equal uvs1 uvs2) + then (UF.rollback tx; return false) + else return true + end + else return false + +(* This is a bandaid. It's similar to do_match but checks that the +LHS of the equality in [t1] is not instantiated, but the RHS might be. +It is a pain to expose the whole logic to tactics, so we just do it +here for now. *) +let do_match_on_lhs (must_tot:bool) (env:Env.env) (t1:term) (t2:term) : tac bool = + let! tx = mk_tac (fun ps -> let tx = UF.new_transaction () in + Success (tx, ps)) in + match destruct_eq env t1 with + | None -> fail "do_match_on_lhs: not an eq" + | Some (lhs, _) -> + let uvs1 = SF.uvars_uncached lhs in + let! r = do_unify_aux must_tot Check_right_only env t1 t2 in + if r then begin + let uvs2 = SF.uvars_uncached lhs in + if not (equal uvs1 uvs2) + then (UF.rollback tx; return false) + else return true + end + else return false + +(* + set_solution: + + Sometimes the witness of a goal is solved by + using a low-level assignment of the unification variable + provided by set_solution. + + The general discipline is that when a trusted primitive tactic + constructs a term to solve the current goal, then it should be + able to just do a set_solution. + + OTOH, if it's a user-provided term to solve the goal, then trysolve is safer + + Note, set_solution is not just an optimization. In cases like `intro` + it is actually important to get the right shape of goal. See the comment there. +*) +let set_solution goal solution : tac unit = + match FStarC.Syntax.Unionfind.find goal.goal_ctx_uvar.ctx_uvar_head with + | Some _ -> + fail (BU.format1 "Goal %s is already solved" (goal_to_string_verbose goal)) + | None -> + FStarC.Syntax.Unionfind.change goal.goal_ctx_uvar.ctx_uvar_head solution; + mark_goal_implicit_already_checked goal; + return () + +let trysolve (goal : goal) (solution : term) : tac bool = + let must_tot = true in + do_unify must_tot (goal_env goal) solution (goal_witness goal) + +let solve (goal : goal) (solution : term) : tac unit = + let e = goal_env goal in + log (fun () -> BU.print2 "solve %s := %s\n" (show (goal_witness goal)) (show solution));! + let! b = trysolve goal solution in + if b + then (dismiss;! remove_solved_goals) + else + fail_doc [ + ttd (goal_env goal) solution ^/^ + text "does not solve" ^/^ + ttd (goal_env goal) (goal_witness goal) ^/^ text ":" ^/^ ttd (goal_env goal) (goal_type goal) + ] + +let solve' (goal : goal) (solution : term) : tac unit = + set_solution goal solution;! + dismiss;! + remove_solved_goals + +//Any function that directly calls these utilities is also trusted +//End: Trusted utilities +//////////////////////////////////////////////////////////////////// + +//////////////////////////////////////////////////////////////////// +(* Some utilities on goals *) +let is_true t = + let t = U.unascribe t in + match U.un_squash t with + | Some t' -> + let t' = U.unascribe t' in + begin match (SS.compress t').n with + | Tm_fvar fv -> S.fv_eq_lid fv PC.true_lid + | _ -> false + end + | _ -> false + +let is_false t = + match U.un_squash t with + | Some t' -> + begin match (SS.compress t').n with + | Tm_fvar fv -> S.fv_eq_lid fv PC.false_lid + | _ -> false + end + | _ -> false +//////////////////////////////////////////////////////////////////// + +let meas (s:string) (f : tac 'a) : tac 'a = + mk_tac (fun ps -> + let (r, ms) = BU.record_time (fun () -> Tactics.Monad.run f ps) in + BU.print2 "++ Tactic %s ran in \t\t%sms\n" s (show ms); + r) + +(* Nuclear option to benchmark every primitive. *) +(* let wrap_err s f = meas s (wrap_err s f) *) + +let tadmit_t (t:term) : tac unit = wrap_err "tadmit_t" <| ( + let! ps = get in + let! g = cur_goal in + // should somehow taint the state instead of just printing a warning + let open FStarC.Errors.Msg in + let open FStarC.Pprint in + Err.log_issue (pos (goal_type g)) Errors.Warning_TacAdmit [ + text "Tactics admitted goal."; + prefix 2 1 (text "Goal") + (arbitrary_string <| goal_to_string "" None ps g); + ]; + solve' g t) + +let fresh () : tac Z.t = + let! ps = get in + let n = ps.freshness in + let ps = { ps with freshness = n + 1 } in + set ps;! + return (Z.of_int_fs n) + +let curms () : tac Z.t = + return (BU.now_ms () |> Z.of_int_fs) + +(* Annoying duplication here *) +let __tc (e : env) (t : term) : tac (term & typ & guard_t) = + let! ps = get in + log (fun () -> BU.print1 "Tac> __tc(%s)\n" (show t));! + try return (TcTerm.typeof_tot_or_gtot_term e t true) + with | Errors.Error (_, msg, _, _) -> + fail_doc ([ + prefix 2 1 (text "Cannot type") (ttd e t) ^/^ + prefix 2 1 (text "in context") (pp (Env.all_binders e)) + ] @ msg) + +let __tc_ghost (e : env) (t : term) : tac (term & typ & guard_t) = + let! ps = get in + log (fun () -> BU.print1 "Tac> __tc_ghost(%s)\n" (show t));! + let e = {e with letrecs=[]} in + try let t, lc, g = TcTerm.tc_tot_or_gtot_term e t in + return (t, lc.res_typ, g) + with | Errors.Error (_, msg, _ ,_) -> + fail_doc ([ + prefix 2 1 (text "Cannot type") (ttd e t) ^/^ + prefix 2 1 (text "in context") (pp (Env.all_binders e)) + ] @ msg) + +let __tc_lax (e : env) (t : term) : tac (term & lcomp & guard_t) = + let! ps = get in + log (fun () -> BU.print2 "Tac> __tc_lax(%s)(Context:%s)\n" + (show t) + (Env.all_binders e |> show));! + let e = {e with admit = true} in + let e = {e with letrecs=[]} in + try return (TcTerm.tc_term e t) + with | Errors.Error (_, msg, _, _) -> + fail_doc ([ + prefix 2 1 (text "Cannot type") (ttd e t) ^/^ + prefix 2 1 (text "in context") (pp (Env.all_binders e)) + ] @ msg) + +let tcc (e : env) (t : term) : tac comp = wrap_err "tcc" <| ( + let! (_, lc, _) = __tc_lax e t in + (* Why lax? What about the guard? It doesn't matter! tc is only + * a way for metaprograms to query the typechecker, but + * the result has no effect on the proofstate and nor is it + * taken for a fact that the typing is correct. *) + return (TcComm.lcomp_comp lc |> fst) //dropping the guard from lcomp_comp too! +) + +let tc (e : env) (t : term) : tac typ = wrap_err "tc" <| ( + let! c = tcc e t in + return (U.comp_result c) +) + +(* Applies t to each of the current goals + fails if t fails on any of the goals + collects each result in the output list *) +let rec map (tau:tac 'a): tac (list 'a) = + let! ps = get in + match ps.goals with + | [] -> return [] + | _::_ -> + let! (h,t) = divide Z.one tau (map tau) in + return (h :: t) + +(* Applies t1 to the current head goal + And t2 to all the the sub-goals produced by t1 + + Collects the resulting goals of t2 along with the initial auxiliary goals + *) +let seq (t1:tac unit) (t2:tac unit) : tac unit = + focus (t1 ;! map t2 ;! return ()) + +let should_check_goal_uvar (g:goal) = U.ctx_uvar_should_check g.goal_ctx_uvar + +let bnorm_and_replace g = replace_cur (bnorm_goal g) + +let bv_to_binding (bv : bv) : RD.binding = + { + uniq = Z.of_int_fs bv.index; + sort = bv.sort; + ppname = Sealed.seal (show bv.ppname); + } + +let binder_to_binding (b:binder) : RD.binding = + bv_to_binding b.binder_bv + +let binding_to_string (b : RD.binding) : string = + Sealed.unseal b.ppname ^ "#" ^ show (Z.to_int_fs b.uniq) + + +let binding_to_bv (b : RD.binding) : bv = + { + sort = b.sort; + ppname = mk_ident (Sealed.unseal b.ppname, Range.dummyRange); + index = Z.to_int_fs b.uniq; + } + +let binding_to_binder (b:RD.binding) : S.binder = + let bv = binding_to_bv b in + S.mk_binder bv + +let arrow_one (env:Env.env) (t:term) = + match U.arrow_one_ln t with + | None -> None + | Some (b, c) -> + let env, [b], c = FStarC.TypeChecker.Core.open_binders_in_comp env [b] c in + Some (env, b, c) + +let arrow_one_whnf (env:Env.env) (t:term) = + match arrow_one env t with + | Some r -> Some r + | None -> arrow_one env (whnf env t) + +(* + [intro]: + + Initial goal: G |- ?u : (t -> t') + + Now we do an `intro`: + + Next goal: `G, x:t |- ?v : t'` + + with `?u := (fun (x:t) -> ?v @ [NM(x, 0)])` +*) +let intro () : tac RD.binding = wrap_err "intro" <| ( + let! goal = cur_goal in + match arrow_one_whnf (goal_env goal) (goal_type goal) with + | Some (_, _, c) when not (U.is_total_comp c) -> + fail "Codomain is effectful" + + | Some (env', b, c) -> + let typ' = U.comp_result c in + //BU.print1 "[intro]: current goal is %s" (goal_to_string goal); + //BU.print1 "[intro]: current goal witness is %s" (show (goal_witness goal)); + //BU.print1 "[intro]: with goal type %s" (show (goal_type goal)); + //BU.print2 "[intro]: with binder = %s, new goal = %s" + // (Print.binders_to_string ", " [b]) + // (show typ'); + let! body, ctx_uvar = + new_uvar "intro" env' typ' + (Some (should_check_goal_uvar goal)) + (goal_typedness_deps goal) + (rangeof goal) in + let sol = U.abs [b] body (Some (U.residual_comp_of_comp c)) in + //BU.print1 "[intro]: solution is %s" + // (show sol); + //BU.print1 "[intro]: old goal is %s" (goal_to_string goal); + //BU.print1 "[intro]: new goal is %s" + // (show ctx_uvar); + //ignore (FStarC.Options.set_options "--debug Rel"); + (* Suppose if instead of simply assigning `?u` to the lambda term on + the RHS, we tried to unify `?u` with the `(fun (x:t) -> ?v @ [NM(x, 0)])`. + + Then, this would defeat the purpose of the delayed substitution, since + the unification engine would solve it by doing something like + + `(fun (y:t) -> ?u y) ~ (fun (x:t) -> ?v @ [NM(x, 0)])` + + And then solving + + `?u z ~ ?v @ [NT(x, z)]` + + which would then proceed by solving `?v` to `?w z` and then unifying + `?u` and `?w`. + + I.e., this immediately destroys the nice shape of the next goal. + *) + set_solution goal sol ;! + let g = mk_goal env' ctx_uvar goal.opts goal.is_guard goal.label in + replace_cur g ;! + return (binder_to_binding b) + | None -> + fail1 "goal is not an arrow (%s)" (tts (goal_env goal) (goal_type goal)) + ) + +(* As [intro], but will introduce n binders at once when the expected type is a +literal arrow. *) +let intros (max:Z.t) : tac (list RD.binding) = wrap_err "intros" <| ( + let max = Z.to_int_fs max in + let! goal = cur_goal in + let bs, c = U.arrow_formals_comp_ln (goal_type goal) in + let bs, c = + (* if user specified a max, maybe trim the bs list and repackage into c *) + if max >= 0 + then ( + let bs0, bs1 = List.splitAt max bs in + let c = S.mk_Total (U.arrow_ln bs1 c) in + bs0, c + ) else bs, c + in + let env', bs, c = FStarC.TypeChecker.Core.open_binders_in_comp (goal_env goal) bs c in + if not (U.is_pure_comp c) then + fail ("Codomain is effectful: " ^ show c) + else return ();! + let typ' = U.comp_result c in + let! body, ctx_uvar = + new_uvar "intros" env' typ' + (Some (should_check_goal_uvar goal)) + (goal_typedness_deps goal) + (rangeof goal) in + let sol = U.abs bs body (Some (U.residual_comp_of_comp c)) in + set_solution goal sol ;! + let g = mk_goal env' ctx_uvar goal.opts goal.is_guard goal.label in + replace_cur g ;! + return (List.map binder_to_binding bs) +) + +// TODO: missing: precedes clause, and somehow disabling fixpoints only as needed +let intro_rec () : tac (RD.binding & RD.binding) = + let! goal = cur_goal in + BU.print_string "WARNING (intro_rec): calling this is known to cause normalizer loops\n"; + BU.print_string "WARNING (intro_rec): proceed at your own risk...\n"; + match arrow_one (goal_env goal) (whnf (goal_env goal) (goal_type goal)) with + | Some (env', b, c) -> + if not (U.is_total_comp c) + then fail "Codomain is effectful" + else let bv = gen_bv "__recf" None (goal_type goal) in + let! u, ctx_uvar_u = + new_uvar "intro_rec" env' + (U.comp_result c) + (Some (should_check_goal_uvar goal)) + (goal_typedness_deps goal) + (rangeof goal) in + let lb = U.mk_letbinding (Inl bv) [] (goal_type goal) PC.effect_Tot_lid (U.abs [b] u None) [] Range.dummyRange in + let body = S.bv_to_name bv in + let lbs, body = SS.close_let_rec [lb] body in + let tm = mk (Tm_let {lbs=(true, lbs); body}) (goal_witness goal).pos in + set_solution goal tm ;! + bnorm_and_replace { goal with goal_ctx_uvar=ctx_uvar_u} ;! + return (binder_to_binding (S.mk_binder bv), binder_to_binding b) + | None -> + fail1 "intro_rec: goal is not an arrow (%s)" (tts (goal_env goal) (goal_type goal)) + +let norm (s : list Pervasives.norm_step) : tac unit = + let! goal = cur_goal in + if_verbose (fun () -> BU.print1 "norm: witness = %s\n" (show (goal_witness goal))) ;! + // Translate to actual normalizer steps + let steps = [Env.Reify; Env.DontUnfoldAttr [PC.tac_opaque_attr]]@(Cfg.translate_norm_steps s) in + //let w = normalize steps (goal_env goal) (goal_witness goal) in + let t = normalize steps (goal_env goal) (goal_type goal) in + replace_cur (goal_with_type goal t) + +let __norm_term_env + (well_typed:bool) (e : env) (s : list Pervasives.norm_step) (t : term) + : tac term += wrap_err "norm_term" <| ( + let! ps = get in + if_verbose (fun () -> BU.print1 "norm_term_env: t = %s\n" (show t)) ;! + // only for elaborating lifts and all that, we don't care if it's actually well-typed + let! t = + if well_typed + then return t + else let! t, _, _ = __tc_lax e t in return t + in + let steps = [Env.Reify; Env.DontUnfoldAttr [PC.tac_opaque_attr]]@(Cfg.translate_norm_steps s) in + let t = normalize steps ps.main_context t in + if_verbose (fun () -> BU.print1 "norm_term_env: t' = %s\n" (show t)) ;! + return t + ) + +let norm_term_env e s t = __norm_term_env false e s t +let refl_norm_well_typed_term e s t = __norm_term_env true e s t + +let refine_intro () : tac unit = wrap_err "refine_intro" <| ( + let! g = cur_goal in + match Rel.base_and_refinement (goal_env g) (goal_type g) with + | _, None -> fail "not a refinement" + | t, Some (bv, phi) -> + //Mark goal as untyped, since we're adding its refinement as a separate goal + mark_goal_implicit_already_checked g; + let g1 = goal_with_type g t in + let bv, phi = + let bvs, phi = SS.open_term [S.mk_binder bv] phi in + (List.hd bvs).binder_bv, phi + in + let! g2 = mk_irrelevant_goal "refine_intro refinement" (goal_env g) + (SS.subst [S.NT (bv, (goal_witness g))] phi) + (Some (should_check_goal_uvar g)) + (rangeof g) + g.opts + g.label in + dismiss ;! + add_goals [g1;g2] + ) + +let __exact_now set_expected_typ (t:term) : tac unit = + let! goal = cur_goal in + let env = if set_expected_typ + then Env.set_expected_typ (goal_env goal) (goal_type goal) + else (goal_env goal) + in + let env = {env with uvar_subtyping=false} in + let! t, typ, guard = __tc env t in + if_verbose (fun () -> BU.print2 "__exact_now: got type %s\n__exact_now: and guard %s\n" + (show typ) + (Rel.guard_to_string (goal_env goal) guard)) ;! + proc_guard "__exact typing" (goal_env goal) guard (Some (should_check_goal_uvar goal)) (rangeof goal) ;! + if_verbose (fun () -> BU.print2 "__exact_now: unifying %s and %s\n" (show typ) + (show (goal_type goal))) ;! + let! b = do_unify true (goal_env goal) typ (goal_type goal) in + if b + then ( // do unify succeeded with a trivial guard; so the goal is solved and we don't have to check it again + mark_goal_implicit_already_checked goal; + solve goal t + ) + else + let typ, goalt = TypeChecker.Err.print_discrepancy (ttd (goal_env goal)) typ (goal_type goal) in + fail_doc [ + prefix 2 1 (text "Term") (ttd (goal_env goal) t) ^/^ + prefix 2 1 (text "of type") typ ^/^ + prefix 2 1 (text "does not exactly solve the goal") goalt; + ] + +let t_exact try_refine set_expected_typ tm : tac unit = wrap_err "exact" <| ( + if_verbose (fun () -> BU.print1 "t_exact: tm = %s\n" (show tm)) ;! + match! catch (__exact_now set_expected_typ tm) with + | Inr r -> return r + | Inl e when not (try_refine) -> traise e + | Inl e -> + if_verbose (fun () -> BU.print_string "__exact_now failed, trying refine...\n") ;! + match! catch (norm [Pervasives.Delta] ;! refine_intro () ;! __exact_now set_expected_typ tm) with + | Inr r -> + if_verbose (fun () -> BU.print_string "__exact_now: failed after refining too\n") ;! + return r + | Inl _ -> + if_verbose (fun () -> BU.print_string "__exact_now: was not a refinement\n") ;! + traise e) + +(* Can t1 unify t2 if it's applied to arguments? If so return uvars for them *) +(* NB: Result is reversed, which helps so we use fold_right instead of fold_left *) +let try_unify_by_application (should_check:option should_check_uvar) + (only_match:bool) + (e : env) + (ty1 : term) + (ty2 : term) + (rng:Range.range) + : tac (list (term & aqual & ctx_uvar)) + = let f = if only_match then do_match else do_unify in + let must_tot = true in + let rec aux (acc : list (term & aqual & ctx_uvar)) + (typedness_deps : list ctx_uvar) //map proj_3 acc + (ty1:term) + : tac (list (term & aqual & ctx_uvar)) + = match! f must_tot e ty2 ty1 with + | true -> return acc (* Done! *) + | false -> + (* Not a match, try instantiating the first type by application *) + match U.arrow_one ty1 with + | None -> + fail_doc [ + prefix 2 1 (text "Could not instantiate") + (ttd e ty1) ^/^ + prefix 2 1 (text "to") + (ttd e ty2) + ] + + | Some (b, c) -> + if not (U.is_total_comp c) then fail "Codomain is effectful" else + let! uvt, uv = new_uvar "apply arg" e b.binder_bv.sort should_check typedness_deps rng in + if_verbose (fun () -> BU.print1 "t_apply: generated uvar %s\n" (show uv)) ;! + let typ = U.comp_result c in + let typ' = SS.subst [S.NT (b.binder_bv, uvt)] typ in + aux ((uvt, U.aqual_of_binder b, uv)::acc) (uv::typedness_deps) typ' + in + aux [] [] ty1 + +// +// Goals for implicits created during apply +// +let apply_implicits_as_goals + (env:Env.env) + (gl:option goal) + (imps:list (term & ctx_uvar)) + : tac (list (list goal)) = + + let one_implicit_as_goal (term, ctx_uvar) = + let hd, _ = U.head_and_args term in + match (SS.compress hd).n with + | Tm_uvar (ctx_uvar, _) -> + let gl = + match gl with + | None -> mk_goal env ctx_uvar (FStarC.Options.peek()) true "goal for unsolved implicit" + | Some gl -> { gl with goal_ctx_uvar = ctx_uvar } in //TODO: AR: what's happening here? + let gl = bnorm_goal gl in + return #tac [gl] // FIXME: inference failure! + | _ -> + // + // This implicits has already been solved + // We would have typechecked its solution already, + // just after the Rel call + // + return [] + in + imps |> mapM one_implicit_as_goal + +// uopt: Don't add goals for implicits that appear free in posterior goals. +// This is very handy for users, allowing to turn +// +// |- a = c +// +// by applying transivity to +// +// |- a = ?u +// |- ?u = c +// +// without asking for |- ?u : Type first, which will most likely be instantiated when +// solving any of these two goals. In any case, if ?u is not solved, we will later fail. +// TODO: this should probably be made into a user tactic +let t_apply (uopt:bool) (only_match:bool) (tc_resolved_uvars:bool) (tm:term) : tac unit = wrap_err "apply" <| ( + let tc_resolved_uvars = true in + if_verbose + (fun () -> BU.print4 "t_apply: uopt %s, only_match %s, tc_resolved_uvars %s, tm = %s\n" + (show uopt) + (show only_match) + (show tc_resolved_uvars) + (show tm)) ;! + let! ps = get in + let! goal = cur_goal in + let e = goal_env goal in + let should_check = should_check_goal_uvar goal in + Tactics.Monad.register_goal goal; + let! tm, typ, guard = __tc e tm in + if_verbose + (fun () -> BU.print5 "t_apply: tm = %s\nt_apply: goal = %s\nenv.gamma=%s\ntyp=%s\nguard=%s\n" + (show tm) + (goal_to_string_verbose goal) + (show e.gamma) + (show typ) + (Rel.guard_to_string e guard)) ;! + // Focus helps keep the goal order + let typ = bnorm e typ in + if only_match && not (is_empty (Free.uvars_uncached typ)) then + fail "t_apply: only_match is on, but the type of the term to apply is not a uvar" + else return ();! + let! uvs = try_unify_by_application (Some should_check) only_match e typ (goal_type goal) (rangeof goal) in + if_verbose + (fun () -> BU.print1 "t_apply: found args = %s\n" + (FStarC.Common.string_of_list (fun (t, _, _) -> show t) uvs)) ;! + let w = List.fold_right (fun (uvt, q, _) w -> U.mk_app w [(uvt, q)]) uvs tm in + let uvset = + List.fold_right + (fun (_, _, uv) s -> union s (SF.uvars (U.ctx_uvar_typ uv))) + uvs + (empty ()) + in + let free_in_some_goal uv = mem uv uvset in + solve' goal w ;! + // + //process uvs + //first, if some of them are solved already, perhaps during unification, + // typecheck them if tc_resolved_uvars is on + //then, if uopt is on, filter out those that appear in other goals + //add the rest as goals + // + let uvt_uv_l = uvs |> List.map (fun (uvt, _q, uv) -> (uvt, uv)) in + let! sub_goals = + apply_implicits_as_goals e (Some goal) uvt_uv_l in + let sub_goals = List.flatten sub_goals + |> List.filter (fun g -> + //if uopt is on, we don't keep uvars that + // appear in some other goals + not (uopt && free_in_some_goal g.goal_ctx_uvar)) + |> List.map bnorm_goal + |> List.rev in + add_goals sub_goals ;! + proc_guard "apply guard" e guard (Some should_check) (rangeof goal) + ) + +// returns pre and post +let lemma_or_sq (c : comp) : option (term & term) = + let eff_name, res, args = U.comp_eff_name_res_and_args c in + if lid_equals eff_name PC.effect_Lemma_lid then + let pre, post = match args with + | pre::post::_ -> fst pre, fst post + | _ -> failwith "apply_lemma: impossible: not a lemma" + in + // Lemma post is thunked + let post = U.mk_app post [S.as_arg U.exp_unit] in + Some (pre, post) + else if U.is_pure_effect eff_name + || U.is_ghost_effect eff_name then + map_opt (U.un_squash res) (fun post -> (U.t_true, post)) + else + None + +let t_apply_lemma (noinst:bool) (noinst_lhs:bool) + (tm:term) : tac unit = wrap_err "apply_lemma" <| focus ( + let! ps = get in + if_verbose (fun () -> BU.print1 "apply_lemma: tm = %s\n" (show tm)) ;! + let is_unit_t t = + match (SS.compress t).n with + | Tm_fvar fv when S.fv_eq_lid fv PC.unit_lid -> true + | _ -> false + in + let! goal = cur_goal in + let env = goal_env goal in + Tactics.Monad.register_goal goal; + let! tm, t, guard = + let env = {env with uvar_subtyping=false} in + __tc env tm + in + let bs, comp = U.arrow_formals_comp t in + match lemma_or_sq comp with + | None -> fail "not a lemma or squashed function" + | Some (pre, post) -> + let! uvs, _, implicits, subst = + foldM_left + (fun (uvs, deps, imps, subst) ({binder_bv=b;binder_qual=aq}) -> + let b_t = SS.subst subst b.sort in + if is_unit_t b_t + then + // Simplification: if the argument is simply unit, then don't ask for it + return <| ((U.exp_unit, aq)::uvs, deps, imps, S.NT(b, U.exp_unit)::subst) + else + let! t, u = new_uvar "apply_lemma" env b_t + (goal + |> should_check_goal_uvar + |> (function | Strict -> Allow_ghost "apply lemma uvar" + | x -> x) + |> Some) + deps + (rangeof goal) in + if !dbg_2635 + then + BU.print2 "Apply lemma created a new uvar %s while applying %s\n" + (show u) + (show tm); + return ((t, aq)::uvs, u::deps, (t, u)::imps, S.NT(b, t)::subst)) + ([], [], [], []) + bs + in + let implicits = List.rev implicits in + let uvs = List.rev uvs in + let pre = SS.subst subst pre in + let post = SS.subst subst post in + let post_u = env.universe_of env post in + let cmp_func = + if noinst then do_match + else if noinst_lhs then do_match_on_lhs + else do_unify + in + let! b = + let must_tot = false in + cmp_func must_tot env (goal_type goal) (U.mk_squash post_u post) in + if not b + then ( + let open FStarC.Class.PP in + let open FStarC.Pprint in + let open FStarC.Errors.Msg in + // let post, goalt = TypeChecker.Err.print_discrepancy (tts env) + // (U.mk_squash post_u post) + // (goal_type goal) in + fail_doc [ + prefix 2 1 (text "Cannot instantiate lemma:") (pp tm) ^/^ + prefix 2 1 (text "with postcondition:") (N.term_to_doc env post) ^/^ + prefix 2 1 (text "to match goal:") (pp (goal_type goal)) + ] + ) + else ( + // We solve with (), we don't care about the witness if applying a lemma + let goal_sc = should_check_goal_uvar goal in + solve' goal U.exp_unit ;! + let is_free_uvar uv t = + for_any (fun u -> UF.equiv u.ctx_uvar_head uv) (SF.uvars t) + in + let appears uv goals = List.existsML (fun g' -> is_free_uvar uv (goal_type g')) goals in + let checkone t goals = + let hd, _ = U.head_and_args t in + begin match hd.n with + | Tm_uvar (uv, _) -> appears uv.ctx_uvar_head goals + | _ -> false + end + in + let must_tot = false in + let! sub_goals = + apply_implicits_as_goals env (Some goal) implicits in + let sub_goals = List.flatten sub_goals in + // Optimization: if a uvar appears in a later goal, don't ask for it, since + // it will be instantiated later. It is tracked anyway in ps.implicits + let rec filter' (f : 'a -> list 'a -> bool) (xs : list 'a) : list 'a = + match xs with + | [] -> [] + | x::xs -> if f x xs then x::(filter' f xs) else filter' f xs + in + let sub_goals = filter' (fun g goals -> not (checkone (goal_witness g) goals)) sub_goals in + proc_guard "apply_lemma guard" env guard (Some goal_sc) (rangeof goal) ;! + let pre_u = env.universe_of env pre in + (match (Rel.simplify_guard env (Env.guard_of_guard_formula (NonTrivial pre))).guard_f with + | Trivial -> return () + | NonTrivial _ -> add_irrelevant_goal goal "apply_lemma precondition" env pre (Some goal_sc)) ;!//AR: should we use the normalized pre instead? + add_goals sub_goals + ) + ) + +let split_env (bvar : bv) (e : env) : option (env & bv & list bv) = + let rec aux e = + match Env.pop_bv e with + | None -> None + | Some (bv', e') -> + if S.bv_eq bvar bv' + then Some (e', bv', []) + else map_opt (aux e') (fun (e'', bv, bvs) -> (e'', bv, bv'::bvs )) + in + map_opt (aux e) (fun (e', bv, bvs) -> (e', bv, List.rev bvs)) + +let subst_goal (b1 : bv) (b2 : bv) (g:goal) : tac (option (bv & goal)) = + match split_env b1 (goal_env g) with + | Some (e0, b1, bvs) -> + let bs = List.map S.mk_binder (b1::bvs) in + + let t = goal_type g in + + (* Close the binders and t *) + let bs', t' = SS.close_binders bs, SS.close bs t in + + (* Replace b1 (the head) by b2 *) + let bs' = S.mk_binder b2 :: List.tail bs' in + + (* Re-open, all done for renaming *) + let new_env, bs'', t'' = Core.open_binders_in_term e0 bs' t' in + + // (* b2 has been freshened *) + let b2 = (List.hd bs'').binder_bv in + + // (* Make a new goal in the new env (with new binders) *) + let! uvt, uv = new_uvar "subst_goal" new_env t'' + (Some (should_check_goal_uvar g)) + (goal_typedness_deps g) + (rangeof g) in + + let goal' = mk_goal new_env uv g.opts g.is_guard g.label in + + (* Solve the old goal with an application of the new witness *) + let sol = U.mk_app (U.abs bs'' uvt None) + (List.map (fun ({binder_bv=bv;binder_qual=q}) -> S.as_arg (S.bv_to_name bv)) bs) in + + set_solution g sol ;! + + return (Some (b2, goal')) + + | None -> + return None + +let rewrite (hh:RD.binding) : tac unit = wrap_err "rewrite" <| ( + let! goal = cur_goal in + let h = binding_to_binder hh in + let bv = h.binder_bv in + if_verbose (fun _ -> BU.print2 "+++Rewrite %s : %s\n" (show bv) (show bv.sort)) ;! + match split_env bv (goal_env goal) with + | None -> fail "binder not found in environment" + | Some (e0, bv, bvs) -> + begin + match destruct_eq e0 bv.sort with + | Some (x, e) -> + begin + match (SS.compress x).n with + | Tm_name x -> + let s = [NT(x, e)] in + + (* See subst_goal for an explanation *) + let t = goal_type goal in + let bs = List.map S.mk_binder bvs in + + let bs', t' = SS.close_binders bs, SS.close bs t in + let bs', t' = SS.subst_binders s bs', SS.subst s t' in + let e0 = Env.push_bvs e0 [bv] in + let new_env, bs'', t'' = Core.open_binders_in_term e0 bs' t' in + + let! uvt, uv = + new_uvar "rewrite" new_env t'' + (Some (should_check_goal_uvar goal)) + (goal_typedness_deps goal) + (rangeof goal) + in + let goal' = mk_goal new_env uv goal.opts goal.is_guard goal.label in + let sol = U.mk_app (U.abs bs'' uvt None) + (List.map (fun ({binder_bv=bv}) -> S.as_arg (S.bv_to_name bv)) bs) in + + (* See comment in subst_goal *) + set_solution goal sol ;! + replace_cur goal' + + | _ -> + fail "Not an equality hypothesis with a variable on the LHS" + end + | _ -> fail "Not an equality hypothesis" + end + ) + +let replace (t1 t2 : term) (s : term) : term = + Syntax.Visit.visit_term false (fun t -> + if U.term_eq t t1 + then t2 + else t) s + +let grewrite (t1 t2 : term) : tac unit = wrap_err "grewrite" <| (focus ( + let! goal = cur_goal in + let goal_t = goal_type goal in + let env = goal_env goal in + let! t1, typ1, g1 = __tc env t1 in + let! t2, typ2, g2 = __tc env t2 in + + (* Remove top level refinements. We just need to create an equality between t1 and t2,, + one of them could have a refined type and that should not matter. *) + let typ1' = N.unfold_whnf' [Env.Unrefine] env typ1 in + let typ2' = N.unfold_whnf' [Env.Unrefine] env typ2 in + if! do_unify false env typ1' typ2' then + return () + else ( + fail_doc [ + text "Types do not match for grewrite"; + text "Type of" ^/^ parens (pp t1) ^/^ equals ^/^ pp typ1; + text "Type of" ^/^ parens (pp t2) ^/^ equals ^/^ pp typ2; + ] + );! + let u = env.universe_of env typ1 in + let goal_t' = replace t1 t2 goal_t in + + let! g_eq = + (* However, retain the original, possibly refined, of t1 for this equality. *) + mk_irrelevant_goal "grewrite.eq" env (U.mk_eq2 u typ1 t1 t2) None + goal.goal_ctx_uvar.ctx_uvar_range goal.opts goal.label + in + + replace_cur (goal_with_type goal goal_t');! + push_goals [g_eq];! + + return () +)) + +let rename_to (b : RD.binding) (s : string) : tac RD.binding = wrap_err "rename_to" <| ( + let! goal = cur_goal in + let bv = binding_to_bv b in + let bv' = freshen_bv ({ bv with ppname = mk_ident (s, (range_of_id bv.ppname)) }) in + match! subst_goal bv bv' goal with + | None -> fail "binder not found in environment" + | Some (bv', goal) -> + replace_cur goal ;! + let uniq = Z.of_int_fs bv'.index in + return {b with uniq=uniq; ppname = Sealed.seal s} + ) + +let var_retype (b : RD.binding) : tac unit = wrap_err "binder_retype" <| ( + let! goal = cur_goal in + let bv = binding_to_bv b in + match split_env bv (goal_env goal) with + | None -> fail "binder is not present in environment" + | Some (e0, bv, bvs) -> + let (ty, u) = U.type_u () in + let goal_sc = should_check_goal_uvar goal in + let! t', u_t' = + new_uvar "binder_retype" e0 ty + (Some goal_sc) + (goal_typedness_deps goal) + (rangeof goal) + in + let bv'' = {bv with sort = t'} in + let s = [S.NT (bv, S.bv_to_name bv'')] in + let bvs = List.map (fun b -> { b with sort = SS.subst s b.sort }) bvs in + let env' = Env.push_bvs e0 (bv''::bvs) in + dismiss ;! + let new_goal = + goal_with_type + (goal_with_env goal env') + (SS.subst s (goal_type goal)) + in + add_goals [new_goal] ;! + add_irrelevant_goal goal "binder_retype equation" e0 + (U.mk_eq2 (U_succ u) ty bv.sort t') + (Some goal_sc) + ) + +let norm_binding_type (s : list Pervasives.norm_step) (b : RD.binding) : tac unit = wrap_err "norm_binding_type" <| ( + let! goal = cur_goal in + let bv = binding_to_bv b in + match split_env bv (goal_env goal) with + | None -> fail "binder is not present in environment" + | Some (e0, bv, bvs) -> + let steps = [Env.Reify; Env.DontUnfoldAttr [PC.tac_opaque_attr]]@(Cfg.translate_norm_steps s) in + let sort' = normalize steps e0 bv.sort in + let bv' = { bv with sort = sort' } in + let env' = Env.push_bvs e0 (bv'::bvs) in + replace_cur (goal_with_env goal env') + ) + +let revert () : tac unit = + let! goal = cur_goal in + match Env.pop_bv (goal_env goal) with + | None -> fail "Cannot revert; empty context" + | Some (x, env') -> + let typ' = U.arrow [S.mk_binder x] (mk_Total (goal_type goal)) in + let! r, u_r = + new_uvar "revert" env' typ' + (Some (should_check_goal_uvar goal)) + (goal_typedness_deps goal) + (rangeof goal) in + set_solution goal (S.mk_Tm_app r [S.as_arg (S.bv_to_name x)] (goal_type goal).pos) ;! + let g = mk_goal env' u_r goal.opts goal.is_guard goal.label in + replace_cur g + +let free_in bv t = mem bv (SF.names t) + +let clear (b : RD.binding) : tac unit = + let bv = binding_to_bv b in + let! goal = cur_goal in + if_verbose (fun () -> BU.print2 "Clear of (%s), env has %s binders\n" + (binding_to_string b) + (Env.all_binders (goal_env goal) |> List.length |> show)) ;! + match split_env bv (goal_env goal) with + | None -> fail "Cannot clear; binder not in environment" + | Some (e', bv, bvs) -> + let rec check bvs = + match bvs with + | [] -> return () + | bv'::bvs -> + if free_in bv bv'.sort + then fail (BU.format1 "Cannot clear; binder present in the type of %s" + (show bv')) + else check bvs + in + if free_in bv (goal_type goal) then + fail "Cannot clear; binder present in goal" + else ( + check bvs ;! + let env' = Env.push_bvs e' bvs in + let! ut, uvar_ut = + new_uvar "clear.witness" env' (goal_type goal) + (Some (should_check_goal_uvar goal)) + (goal_typedness_deps goal) + (rangeof goal) in + set_solution goal ut ;! + replace_cur (mk_goal env' uvar_ut goal.opts goal.is_guard goal.label) + ) + +let clear_top () : tac unit = + let! goal = cur_goal in + match Env.pop_bv (goal_env goal) with + | None -> fail "Cannot clear; empty context" + | Some (x, _) -> clear (bv_to_binding x) // we ignore the qualifier anyway + +let prune (s:string) : tac unit = + let! g = cur_goal in + let ctx = goal_env g in + let ctx' = Env.rem_proof_ns ctx (path_of_text s) in + let g' = goal_with_env g ctx' in + replace_cur g' + +let addns (s:string) : tac unit = + let! g = cur_goal in + let ctx = goal_env g in + let ctx' = Env.add_proof_ns ctx (path_of_text s) in + let g' = goal_with_env g ctx' in + replace_cur g' + +let guard_formula (g:guard_t) : term = + match g.guard_f with + | Trivial -> U.t_true + | NonTrivial f -> f + +let _t_trefl (allow_guards:bool) (l : term) (r : term) : tac unit = + let should_register_trefl g = + let should_register = true in + let skip_register = false in + if not (Options.compat_pre_core_should_register()) then skip_register else + //Sending a goal t1 == t2 to the core for registration can be expensive + //particularly if the terms are big, e.g., when they are WPs etc + //This function decides which goals to register, using two criteria + //1. If the uvars in the goal are Allow_untyped or Already_checked + // then don't bother registering, since we will not recheck the solution. + // + //2. If the goal is of the form `eq2 #ty ?u t` (or vice versa) + // and we can prove that ty <: ?u.t + // then the assignment of `?u := t` is going to be well-typed + // without needing to recompute the type of `t` + let is_uvar_untyped_or_already_checked u = + let dec = UF.find_decoration u.ctx_uvar_head in + match dec.uvar_decoration_should_check with + | Allow_untyped _ + | Already_checked -> true + | _ -> false + in + let is_uvar t = + let head = U.leftmost_head t in + match (SS.compress head).n with + | Tm_uvar (u, _) -> Inl (u, head, t) + | _ -> Inr t + in + let is_allow_untyped_uvar t = + match is_uvar t with + | Inr _ -> false + | Inl (u, _, _) -> is_uvar_untyped_or_already_checked u + in + let t = U.ctx_uvar_typ g.goal_ctx_uvar in + let uvars = FStarC.Syntax.Free.uvars t in + if for_all is_uvar_untyped_or_already_checked uvars + then skip_register //all the uvars are already checked or untyped + else ( + let head, args = + let t = + match U.un_squash t with + | None -> t + | Some t -> t + in + U.leftmost_head_and_args t + in + match (SS.compress (U.un_uinst head)).n, args with + | Tm_fvar fv, [(ty, _); (t1, _); (t2, _)] + when S.fv_eq_lid fv PC.eq2_lid -> + if is_allow_untyped_uvar t1 || is_allow_untyped_uvar t2 + then skip_register //if we have ?u=t or t=?u and ?u is allow_untyped, then skip + else if Tactics.Monad.is_goal_safe_as_well_typed g //o.w., if the goal is well typed + then ( + //and the goal is of the shape + // eq2 #ty ?u t or + // eq2 #ty t ?u + // Then solving this, if it succeeds, is going to assign ?u := t + // If we know that `ty <: ?u.ty` then this is well-typed already + // without needing to recheck the assignment + // Note, from well-typedness of the goal, we already know ?u.ty <: ty + let check_uvar_subtype u t = + let env = { goal_env g with gamma = g.goal_ctx_uvar.ctx_uvar_gamma } in + match Core.compute_term_type_handle_guards env t (fun _ _ -> true) + with + | Inr _ -> false + | Inl (_, t_ty) -> ( // ignoring effect, ghost is ok + match Core.check_term_subtyping true true env ty t_ty with + | Inl None -> //unconditional subtype + mark_uvar_as_already_checked u; + true + | _ -> + false + ) + in + match is_uvar t1, is_uvar t2 with + | Inl (u, _, tu), Inr _ + | Inr _, Inl (u, _, tu) -> + //if the condition fails, then return true to register this goal + //since the assignment will have to be rechecked + if check_uvar_subtype u tu + then skip_register + else should_register + | _ -> + should_register + ) + else should_register + | _ -> + should_register + ) + in + let! g = cur_goal in + let should_check = should_check_goal_uvar g in + if should_register_trefl g + then Tactics.Monad.register_goal g; + let must_tot = true in + let attempt (l : term) (r : term) : tac bool = + match! do_unify_maybe_guards allow_guards must_tot (goal_env g) l r with + | None -> return false + | Some guard -> + solve' g U.exp_unit ;! + if allow_guards + then + let! goal = goal_of_guard "t_trefl" (goal_env g) (guard_formula guard) (Some should_check) (rangeof g) in + push_goals [goal] ;! + return true + else + // If allow_guards is false, this guard must be trivial and we don't + // add it, but we check its triviality for sanity. + if Env.is_trivial_guard_formula guard + then return true + else failwith "internal error: _t_refl: guard is not trivial" + in + match! attempt l r with + | true -> return () + | false -> + (* if that didn't work, normalize and retry *) + let norm = N.normalize [Env.UnfoldUntil delta_constant; Env.Primops; Env.DontUnfoldAttr [PC.tac_opaque_attr]] (goal_env g) in + match! attempt (norm l) (norm r) with + | true -> return () + | false -> + let ls, rs = TypeChecker.Err.print_discrepancy (tts (goal_env g)) l r in + fail2 "cannot unify (%s) and (%s)" ls rs + +let t_trefl (allow_guards:bool) : tac unit = wrap_err "t_trefl" <| ( + match! + catch (//restore UF graph, including any Already_checked markers, if anything fails + let! g = cur_goal in + match destruct_eq (goal_env g) (goal_type g) with + | Some (l, r) -> + _t_trefl allow_guards l r + | None -> + fail1 "not an equality (%s)" (tts (goal_env g) (goal_type g)) + ) + with + | Inr v -> return v + | Inl exn -> traise exn + ) + +let dup () : tac unit = + let! g = cur_goal in + let goal_sc = should_check_goal_uvar g in + let env = goal_env g in + let! u, u_uvar = + new_uvar "dup" env (goal_type g) + (Some (should_check_goal_uvar g)) + (goal_typedness_deps g) + (rangeof g) in + //the new uvar is just as Strict as the original one. So, its assignement will be checked + //and we have a goal that requires us to prove it equal to the original uvar + //so we can clear the should_check status of the current uvar + mark_uvar_as_already_checked g.goal_ctx_uvar; + let g' = { g with goal_ctx_uvar = u_uvar } in + dismiss ;! + let t_eq = U.mk_eq2 (env.universe_of env (goal_type g)) (goal_type g) u (goal_witness g) in + add_irrelevant_goal g "dup equation" env t_eq (Some goal_sc) ;! + add_goals [g'] + +// longest_prefix f l1 l2 = (p, r1, r2) ==> l1 = p@r1 /\ l2 = p@r2 ; and p is maximal +let longest_prefix (f : 'a -> 'a -> bool) (l1 : list 'a) (l2 : list 'a) : list 'a & list 'a & list 'a = + let rec aux acc l1 l2 = + match l1, l2 with + | x::xs, y::ys -> + if f x y + then aux (x::acc) xs ys + else acc, x::xs, y::ys + | _ -> + acc, l1, l2 + in + let pr, t1, t2 = aux [] l1 l2 in + List.rev pr, t1, t2 + +let eq_binding b1 b2 = + match b1, b2 with + | _ -> false + | S.Binding_var bv1, Binding_var bv2 -> bv_eq bv1 bv2 && U.term_eq bv1.sort bv2.sort + | S.Binding_lid (lid1, _), Binding_lid (lid2, _) -> lid_equals lid1 lid2 + | S.Binding_univ u1, Binding_univ u2 -> ident_equals u1 u2 + | _ -> false + +// fix universes +let join_goals g1 g2 : tac goal = + (* The one in Syntax.Util ignores null_binders, why? *) + let close_forall_no_univs bs f = + List.fold_right (fun b f -> U.mk_forall_no_univ b.binder_bv f) bs f + in + match get_phi g1 with + | None -> fail "goal 1 is not irrelevant" + | Some phi1 -> + match get_phi g2 with + | None -> fail "goal 2 is not irrelevant" + | Some phi2 -> + + let gamma1 = g1.goal_ctx_uvar.ctx_uvar_gamma in + let gamma2 = g2.goal_ctx_uvar.ctx_uvar_gamma in + let gamma, r1, r2 = longest_prefix eq_binding (List.rev gamma1) (List.rev gamma2) in + + let t1 = close_forall_no_univs (Env.binders_of_bindings (List.rev r1)) phi1 in + let t2 = close_forall_no_univs (Env.binders_of_bindings (List.rev r2)) phi2 in + + let goal_sc = + match should_check_goal_uvar g1, should_check_goal_uvar g2 with + | Allow_untyped reason1, Allow_untyped _ -> Some (Allow_untyped reason1) + | _ -> None + in + + let ng = U.mk_conj t1 t2 in + let nenv = { goal_env g1 with gamma = List.rev gamma } in + let! goal = mk_irrelevant_goal "joined" nenv ng goal_sc (rangeof g1) g1.opts g1.label in + if_verbose (fun () -> BU.print3 "join_goals of\n(%s)\nand\n(%s)\n= (%s)\n" + (goal_to_string_verbose g1) + (goal_to_string_verbose g2) + (goal_to_string_verbose goal)) ;! + set_solution g1 U.exp_unit ;! + set_solution g2 U.exp_unit ;! + return goal + +let join () : tac unit = + let! ps = get in + match ps.goals with + | g1::g2::gs -> + set { ps with goals = gs } ;! + let! g12 = join_goals g1 g2 in + add_goals [g12] + + | _ -> fail "join: less than 2 goals" + + +let set_options (s : string) : tac unit = wrap_err "set_options" <| ( + let! g = cur_goal in + FStarC.Options.push (); + FStarC.Options.set g.opts; + let res = FStarC.Options.set_options s in + let opts' = FStarC.Options.peek () in + FStarC.Options.pop (); + match res with + | FStarC.Getopt.Success -> + let g' = { g with opts = opts' } in + replace_cur g' + | FStarC.Getopt.Error err -> + fail2 "Setting options `%s` failed: %s" s err + | FStarC.Getopt.Help -> + fail1 "Setting options `%s` failed (got `Help`?)" s + ) + +let top_env () : tac env = let! ps = get in return <| ps.main_context + +let lax_on () : tac bool = + (* Check the goal if any??? *) + let! ps = get in + return ps.main_context.admit + +let unquote (ty : term) (tm : term) : tac term = wrap_err "unquote" <| ( + if_verbose (fun () -> BU.print1 "unquote: tm = %s\n" (show tm)) ;! + let! goal = cur_goal in + let env = Env.set_expected_typ (goal_env goal) ty in + let! tm, typ, guard = __tc_ghost env tm in + if_verbose (fun () -> BU.print1 "unquote: tm' = %s\n" (show tm)) ;! + if_verbose (fun () -> BU.print1 "unquote: typ = %s\n" (show typ)) ;! + proc_guard "unquote" env guard (Some (should_check_goal_uvar goal)) (rangeof goal) ;! + return tm + ) + +let uvar_env (env : env) (ty : option typ) : tac term = + let! ps = get in + // If no type was given, add a uvar for it too! + let! typ, g, r = + match ty with + | Some ty -> + let env = Env.set_expected_typ env (U.type_u () |> fst) in + let! ty, _, g = __tc_ghost env ty in + return (ty, g, ty.pos) + + | None -> + //the type of this uvar is just Type; so it's typedness deps is [] + let! typ, uvar_typ = new_uvar "uvar_env.2" env (fst <| U.type_u ()) None [] ps.entry_range in + return (typ, Env.trivial_guard, Range.dummyRange) + in + proc_guard "uvar_env_typ" env g None r;! + //the guard is an explicit goal; so the typedness deps of this new uvar is [] + let! t, uvar_t = new_uvar "uvar_env" env typ None [] ps.entry_range in + return t + +let ghost_uvar_env (env : env) (ty : typ) : tac term = + let! ps = get in + // If no type was given, add a uvar for it too! + let! typ, _, g = __tc_ghost env ty in + proc_guard "ghost_uvar_env_typ" env g None ty.pos ;! + //the guard is an explicit goal; so the typedness deps of this new uvar is [] + let! t, uvar_t = new_uvar "uvar_env" env typ (Some (Allow_ghost "User ghost uvar")) [] ps.entry_range in + return t + +let fresh_universe_uvar () : tac term = + U.type_u () |> fst |> return + +let unshelve (t : term) : tac unit = wrap_err "unshelve" <| ( + let! ps = get in + let env = ps.main_context in + (* We need a set of options, but there might be no goals, so do this *) + let opts = match ps.goals with + | g::_ -> g.opts + | _ -> FStarC.Options.peek () + in + match U.head_and_args t with + | { n = Tm_uvar (ctx_uvar, _) }, _ -> + let env = {env with gamma=ctx_uvar.ctx_uvar_gamma} in + let g = mk_goal env ctx_uvar opts false "" in + let g = bnorm_goal g in + add_goals [g] + | _ -> fail "not a uvar" + ) + +let tac_and (t1 : tac bool) (t2 : tac bool) : tac bool = + match! t1 with + | false -> return false + | true -> t2 + +let default_if_err (def : 'a) (t : tac 'a) : tac 'a = + let! r = catch t in + match r with + | Inl _ -> return def + | Inr v -> return v + +let match_env (e:env) (t1 : term) (t2 : term) : tac bool = wrap_err "match_env" <| ( + let! ps = get in + let! t1, ty1, g1 = __tc e t1 in + let! t2, ty2, g2 = __tc e t2 in + proc_guard "match_env g1" e g1 None ps.entry_range ;! + proc_guard "match_env g2" e g2 None ps.entry_range ;! + let must_tot = true in + default_if_err false <| + tac_and (do_match must_tot e ty1 ty2) + (do_match must_tot e t1 t2) + ) + +let unify_env (e:env) (t1 : term) (t2 : term) : tac bool = wrap_err "unify_env" <| ( + let! ps = get in + let! t1, ty1, g1 = __tc e t1 in + let! t2, ty2, g2 = __tc e t2 in + proc_guard "unify_env g1" e g1 None ps.entry_range ;! + proc_guard "unify_env g2" e g2 None ps.entry_range ;! + let must_tot = true in + default_if_err false <| + tac_and (do_unify must_tot e ty1 ty2) + (do_unify must_tot e t1 t2) + ) + +let unify_guard_env (e:env) (t1 : term) (t2 : term) : tac bool = wrap_err "unify_guard_env" <| ( + let! ps = get in + let! t1, ty1, g1 = __tc e t1 in + let! t2, ty2, g2 = __tc e t2 in + proc_guard "unify_guard_env g1" e g1 None ps.entry_range ;! + proc_guard "unify_guard_env g2" e g2 None ps.entry_range ;! + let must_tot = true in + match! do_unify_maybe_guards true must_tot e ty1 ty2 with + | None -> return false + | Some g1 -> + match! do_unify_maybe_guards true must_tot e t1 t2 with + | None -> return false + | Some g2 -> + let formula : term = U.mk_conj (guard_formula g1) (guard_formula g2) in + let! goal = goal_of_guard "unify_guard_env.g2" e formula None ps.entry_range in + push_goals [goal] ;! + return true + ) + +let launch_process (prog : string) (args : list string) (input : string) : tac string = + // The `bind return ()` thunks the tactic + return ();! + if Options.unsafe_tactic_exec () then + let s = BU.run_process "tactic_launch" prog args (Some input) in + return s + else + fail "launch_process: will not run anything unless --unsafe_tactic_exec is provided" + +let fresh_bv_named (nm : string) : tac bv = + // The `bind return ()` thunks the tactic. Not really needed, just being paranoid + return ();! return (gen_bv nm None S.tun) + +let change (ty : typ) : tac unit = wrap_err "change" <| ( + if_verbose (fun () -> BU.print1 "change: ty = %s\n" (show ty)) ;! + let! g = cur_goal in + let! ty, _, guard = __tc (goal_env g) ty in + proc_guard "change" (goal_env g) guard (Some (should_check_goal_uvar g)) (rangeof g) ;! + let must_tot = true in + let! bb = do_unify must_tot (goal_env g) (goal_type g) ty in + if bb + then replace_cur (goal_with_type g ty) + else begin + (* Give it a second try, fully normalize the term the user gave + * and unify it with the fully normalized goal. If that succeeds, + * we use the original one as the new goal. This is sometimes needed + * since the unifier has some bugs. *) + let steps = [Env.AllowUnboundUniverses; Env.UnfoldUntil delta_constant; Env.Primops] in + let ng = normalize steps (goal_env g) (goal_type g) in + let nty = normalize steps (goal_env g) ty in + let! b = do_unify must_tot (goal_env g) ng nty in + if b + then replace_cur (goal_with_type g ty) + else fail "not convertible" + end + ) + +let failwhen (b:bool) (msg:string) : tac unit = + if b + then fail msg + else return () + +let t_destruct (s_tm : term) : tac (list (fv & Z.t)) = wrap_err "destruct" <| ( + let! g = cur_goal in + let! s_tm, s_ty, guard = __tc (goal_env g) s_tm in + proc_guard "destruct" (goal_env g) guard (Some (should_check_goal_uvar g)) (rangeof g) ;! + let s_ty = N.normalize [Env.DontUnfoldAttr [PC.tac_opaque_attr]; Env.Weak; Env.HNF; Env.UnfoldUntil delta_constant] + (goal_env g) s_ty in + let h, args = U.head_and_args_full (U.unrefine s_ty) in + let! fv, a_us = + match (SS.compress h).n with + | Tm_fvar fv -> return (fv, []) + | Tm_uinst (h', us) -> + begin match (SS.compress h').n with + | Tm_fvar fv -> return (fv, us) + | _ -> failwith "impossible: uinst over something that's not an fvar" + end + | _ -> fail "type is not an fv" + in + let t_lid = lid_of_fv fv in + match Env.lookup_sigelt (goal_env g) t_lid with + | None -> fail "type not found in environment" + | Some se -> + match se.sigel with + | Sig_inductive_typ {us=t_us; params=t_ps; t=t_ty; mutuals=mut; ds=c_lids} -> + (* High-level idea of this huge function: + * For Gamma |- w : phi and | C : ps -> bs -> t, we generate a new goal + * Gamma |- w' : bs -> phi + * with + * w = match tm with ... | C .ps' bs' -> w' bs' ... + * i.e., we do not intro the matched binders and let the + * user do that (with the returned arity). `.ps` represents inaccesible patterns + * for the type's parameters. + *) + let erasable = U.has_attribute se.sigattrs FStarC.Parser.Const.erasable_attr in + failwhen (erasable && not (is_irrelevant g)) "cannot destruct erasable type to solve proof-relevant goal" ;! + + (* Instantiate formal universes to the actuals, + * and substitute accordingly in binders and types *) + failwhen (List.length a_us <> List.length t_us) "t_us don't match?" ;! + + + (* Not needed currently? *) + (* let s = Env.mk_univ_subst t_us a_us in *) + (* let t_ps = SS.subst_binders s t_ps in *) + (* let t_ty = SS.subst s t_ty in *) + let t_ps, t_ty = SS.open_term t_ps t_ty in + + let! goal_brs = + mapM (fun c_lid -> + match Env.lookup_sigelt (goal_env g) c_lid with + | None -> fail "ctor not found?" + | Some se -> + match se.sigel with + | Sig_datacon {us=c_us; t=c_ty; num_ty_params=nparam; mutuals=mut} -> + (* BU.print2 "ty of %s = %s\n" (show c_lid) *) + (* (show c_ty); *) + (* Make sure to preserve qualifiers if possible. + This is mostly so we retain Record_projector quals, which + are meaningful for extraction. *) + let qual = + let fallback () = Some Data_ctor in + let qninfo = Env.lookup_qname (goal_env g) c_lid in + match qninfo with + | Some (Inr (se, _us), _rng) -> + Syntax.DsEnv.fv_qual_of_se se + | _ -> + fallback () + in + let fv = S.lid_as_fv c_lid qual in + + failwhen (List.length a_us <> List.length c_us) "t_us don't match?" ;! + let s = Env.mk_univ_subst c_us a_us in + let c_ty = SS.subst s c_ty in + + (* The constructor might be universe-polymorphic, just use + * fresh univ_uvars for its universes. *) + let c_us, c_ty = Env.inst_tscheme (c_us, c_ty) in + + (* BU.print2 "ty(2) of %s = %s\n" (show c_lid) *) + (* (show c_ty); *) + + (* Deconstruct its type, separating the parameters from the + * actual arguments (indices do not matter here). *) + let bs, comp = U.arrow_formals_comp c_ty in + + (* More friendly names: 'a_i' instead of '_i' *) + let bs, comp = + let rename_bv bv = + let ppname = bv.ppname in + let ppname = mk_ident ("a" ^ show ppname, range_of_id ppname) in + // freshen just to be extra safe.. probably not needed + freshen_bv ({ bv with ppname = ppname }) + in + let bs' = List.map (fun b -> {b with binder_bv=rename_bv b.binder_bv}) bs in + let subst = List.map2 (fun ({binder_bv=bv}) ({binder_bv=bv'}) -> NT (bv, bv_to_name bv')) bs bs' in + SS.subst_binders subst bs', SS.subst_comp subst comp + in + + (* BU.print1 "bs = (%s)\n" (Print.binders_to_string ", " bs); *) + let d_ps, bs = List.splitAt nparam bs in + failwhen (not (U.is_total_comp comp)) "not total?" ;! + let mk_pat p = { v = p; p = s_tm.pos } in + (* TODO: This is silly, why don't we just keep aq in the Pat_cons? *) + let is_imp = function | Some (Implicit _) -> true + | _ -> false + in + let a_ps, a_is = List.splitAt nparam args in + failwhen (List.length a_ps <> List.length d_ps) "params not match?" ;! + let d_ps_a_ps = List.zip d_ps a_ps in + let subst = List.map (fun (({binder_bv=bv}), (t, _)) -> NT (bv, t)) d_ps_a_ps in + let bs = SS.subst_binders subst bs in + let subpats_1 = List.map (fun (({binder_bv=bv}), (t, _)) -> + (mk_pat (Pat_dot_term (Some t)), true)) d_ps_a_ps in + let subpats_2 = List.map (fun ({binder_bv=bv;binder_qual=bq}) -> + (mk_pat (Pat_var bv), is_imp bq)) bs in + let subpats = subpats_1 @ subpats_2 in + let pat = mk_pat (Pat_cons (fv, Some a_us, subpats)) in + let env = (goal_env g) in + + + (* Add an argument stating the equality between the scrutinee + * and the pattern, in-scope for this branch. *) + let cod = goal_type g in + let equ = env.universe_of env s_ty in + (* Typecheck the pattern, to fill-in the universes and get an expression out of it *) + let _ , _, _, _, pat_t, _, _guard_pat, _erasable = TcTerm.tc_pat ({ env with admit = true }) s_ty pat in + let eq_b = S.gen_bv "breq" None (U.mk_squash S.U_zero (U.mk_eq2 equ s_ty s_tm pat_t)) in + let cod = U.arrow [S.mk_binder eq_b] (mk_Total cod) in + + let nty = U.arrow bs (mk_Total cod) in + let! uvt, uv = new_uvar "destruct branch" env nty None (goal_typedness_deps g) (rangeof g) in + let g' = mk_goal env uv g.opts false g.label in + let brt = U.mk_app_binders uvt bs in + (* Provide the scrutinee equality, which is trivially provable *) + let brt = U.mk_app brt [S.as_arg U.exp_unit] in + let br = SS.close_branch (pat, None, brt) in + return (g', br, (fv, Z.of_int_fs (List.length bs))) + | _ -> + fail "impossible: not a ctor") + c_lids + in + let goals, brs, infos = List.unzip3 goal_brs in + let w = mk (Tm_match {scrutinee=s_tm;ret_opt=None;brs;rc_opt=None}) s_tm.pos in + solve' g w ;! + //we constructed a well-typed term to solve g; no need to recheck it + mark_goal_implicit_already_checked g; + add_goals goals ;! + return infos + + | _ -> fail "not an inductive type" + ) + +let gather_explicit_guards_for_resolved_goals () + : tac unit + = return () + +// TODO: move to library? +let rec last (l:list 'a) : 'a = + match l with + | [] -> failwith "last: empty list" + | [x] -> x + | _::xs -> last xs + +let rec init (l:list 'a) : list 'a = + match l with + | [] -> failwith "init: empty list" + | [x] -> [] + | x::xs -> x :: init xs + +let lget (ty:term) (k:string) : tac term = wrap_err "lget" <| ( + let! ps = get in + match BU.psmap_try_find ps.local_state k with + | None -> fail "not found" + | Some t -> unquote ty t + ) + +let lset (_ty:term) (k:string) (t:term) : tac unit = wrap_err "lset" <| ( + let! ps = get in + let ps = { ps with local_state = BU.psmap_add ps.local_state k t } in + set ps + ) + +let set_urgency (u:Z.t) : tac unit = + let! ps = get in + let ps = { ps with urgency = Z.to_int_fs u } in + set ps + +let set_dump_on_failure (b:bool) : tac unit = + let! ps = get in + let ps = { ps with dump_on_failure = b } in + set ps + +let t_commute_applied_match () : tac unit = wrap_err "t_commute_applied_match" <| ( + let! g = cur_goal in + match destruct_eq (goal_env g) (goal_type g) with + | Some (l, r) -> begin + let lh, las = U.head_and_args_full l in + match (SS.compress (U.unascribe lh)).n with + | Tm_match {scrutinee=e;ret_opt=asc_opt;brs;rc_opt=lopt} -> + let brs' = List.map (fun (p, w, e) -> p, w, U.mk_app e las) brs in + // + // If residual comp is set, apply arguments to it + // + let lopt' = lopt |> BU.map_option (fun rc -> {rc with residual_typ= + rc.residual_typ |> BU.map_option (fun t -> + let bs, c = N.get_n_binders (goal_env g) (List.length las) t in + let bs, c = SS.open_comp bs c in + let ss = List.map2 (fun b a -> NT (b.binder_bv, fst a)) bs las in + let c = SS.subst_comp ss c in + U.comp_result c)}) in + let l' = mk (Tm_match {scrutinee=e;ret_opt=asc_opt;brs=brs';rc_opt=lopt'}) l.pos in + let must_tot = true in + begin match! do_unify_maybe_guards false must_tot (goal_env g) l' r with + | None -> fail "discharging the equality failed" + | Some guard -> + if Env.is_trivial_guard_formula guard + then ( + //we just checked that its guard is trivial; so no need to check again + mark_uvar_as_already_checked g.goal_ctx_uvar; + solve g U.exp_unit + ) + else failwith "internal error: _t_refl: guard is not trivial" + end + | _ -> + fail "lhs is not a match" + end + | None -> + fail "not an equality" + ) + +let string_to_term (e: Env.env) (s: string): tac term + = let open FStarC.Parser.ParseIt in + let frag_of_text s = { frag_fname= "" + ; frag_line = 1 ; frag_col = 0 + ; frag_text = s } in + match parse None (Fragment (frag_of_text s)) with + | Term t -> + let dsenv = FStarC.Syntax.DsEnv.set_current_module e.dsenv (current_module e) in + begin try return (FStarC.ToSyntax.ToSyntax.desugar_term dsenv t) with + | FStarC.Errors.Error (_, e, _, _) -> + fail ("string_to_term: " ^ Errors.rendermsg e) + | _ -> fail ("string_to_term: Unknown error") + end + | ASTFragment _ -> fail ("string_to_term: expected a Term as a result, got an ASTFragment") + | ParseError (_, err, _) -> fail ("string_to_term: got error " ^ Errors.rendermsg err) // FIXME + +let push_bv_dsenv (e: Env.env) (i: string): tac (env & RD.binding) + = let ident = Ident.mk_ident (i, FStarC.Compiler.Range.dummyRange) in + let dsenv, bv = FStarC.Syntax.DsEnv.push_bv e.dsenv ident in + return ({ e with dsenv }, bv_to_binding bv) + +let term_to_string (t:term) : tac string + = let! g = top_env () in + let s = Print.term_to_string' g.dsenv t in + return s + +let comp_to_string (c:comp) : tac string + = let! g = top_env () in + let s = Print.comp_to_string' g.dsenv c in + return s + +let term_to_doc (t:term) : tac Pprint.document + = let! g = top_env () in + let s = Print.term_to_doc' g.dsenv t in + return s + +let comp_to_doc (c:comp) : tac Pprint.document + = let! g = top_env () in + let s = Print.comp_to_doc' g.dsenv c in + return s + +let range_to_string (r:FStarC.Compiler.Range.range) : tac string + = return (show r) + +let term_eq_old (t1:term) (t2:term) : tac bool + = return ();! + return (Syntax.Util.term_eq t1 t2) + +let with_compat_pre_core (n:Z.t) (f:tac 'a) : tac 'a = + mk_tac (fun ps -> + Options.with_saved_options (fun () -> + let _res = FStarC.Options.set_options ("--compat_pre_core 0") in + run f ps)) + +let get_vconfig () : tac vconfig = + let! g = cur_goal in + (* Restore goal's optionstate (a copy is needed) and read vconfig. + * This is an artifact of the options API being stateful in many places, + * morally this is just (get_vconfig g.opts) *) + let vcfg = Options.with_saved_options (fun () -> + FStarC.Options.set g.opts; + Options.get_vconfig ()) + in + return vcfg + +let set_vconfig (vcfg : vconfig) : tac unit = + (* Same comment as for get_vconfig applies, this is really just + * let g' = { g with opts = set_vconfig vcfg g.opts } *) + let! g = cur_goal in + let opts' = Options.with_saved_options (fun () -> + FStarC.Options.set g.opts; + Options.set_vconfig vcfg; + Options.peek ()) + in + let g' = { g with opts = opts' } in + replace_cur g' + +let t_smt_sync (vcfg : vconfig) : tac unit = wrap_err "t_smt_sync" <| ( + let! goal = cur_goal in + match get_phi goal with + | None -> fail "Goal is not irrelevant" + | Some phi -> + let e = goal_env goal in + let ans : bool = + (* Set goal's optionstate before asking solver, to respect + * its vconfig among other things. *) + Options.with_saved_options (fun () -> + (* NOTE: we ignore the goal's options, the rationale is that + * any verification-relevant option is inside the vconfig, so we + * should not need read the optionstate. Of course this vconfig + * will probably come in large part from a get_vconfig, which does + * read the goal's options. *) + Options.set_vconfig vcfg; + e.solver.solve_sync None e phi + ) + in + if ans + then ( + mark_uvar_as_already_checked goal.goal_ctx_uvar; + solve goal U.exp_unit + ) else fail "SMT did not solve this goal" +) + +let free_uvars (tm : term) : tac (list Z.t) + = return ();! + let uvs = Free.uvars_uncached tm + |> elems // GGG bad, order dependent, but userspace does not have sets + |> List.map (fun u -> Z.of_int_fs (UF.uvar_id u.ctx_uvar_head)) + in + return uvs + +let all_ext_options () : tac (list (string & string)) + = return () ;! + return (Options.Ext.all ()) + +let ext_getv (k:string) : tac string + = return () ;! + return (Options.Ext.get k) + +let ext_getns (ns:string) : tac (list (string & string)) + = return () ;! + return (Options.Ext.getns ns) + +let alloc (x:'a) : tac (tref 'a) = + return ();! + return (BU.mk_ref x) + +let read (r:tref 'a) : tac 'a = + return ();! + return (!r) + +let write (r:tref 'a) (x:'a) : tac unit = + return ();! + r := x; + return () + +(***** Builtins used in the meta DSL framework *****) + +let dbg_refl (g:env) (msg:unit -> string) = + if !dbg_ReflTc + then BU.print_string (msg ()) + +let issues = list Errors.issue + +let refl_typing_guard (e:env) (g:typ) : tac unit = + let reason = "refl_typing_guard" in + proc_guard_formula "refl_typing_guard" e g None (Env.get_range e) + +let uncurry f (x, y) = f x y + +let __refl_typing_builtin_wrapper (f:unit -> 'a & list (env & typ)) : tac (option 'a & issues) = + (* We ALWAYS rollback the state. This wrapper is meant to ensure that + the UF graph is not affected by whatever we are wrapping. This means + any returned term must be deeply-compressed. The guards are compressed by + this wrapper, and handled according to the guard policy, so no action is needed + in the wrapped function `f`. *) + let tx = UF.new_transaction () in + let errs, r = + try Errors.catch_errors_and_ignore_rest f + with exn -> //catch everything + let issue = FStarC.Errors.({ + issue_msg = Errors.mkmsg (BU.print_exn exn); + issue_level = EError; + issue_range = None; + issue_number = (Some 17); + issue_ctx = get_ctx () + }) in + [issue], None + in + + (* Deep compress the guards since we are about to roll back the UF. + The caller will discharge them if needed. *) + let gs = + if Some? r then + let allow_uvars = false in + let allow_names = true in (* terms are potentially open, names are OK *) + List.map (fun (e,g) -> e, SC.deep_compress allow_uvars allow_names g) (snd (Some?.v r)) + else + [] + in + + (* If r is Some, extract the result, that's what we return *) + let r = BU.map_opt r fst in + + (* Compress the id info table. *) + let! ps = get in + Env.promote_id_info ps.main_context (FStarC.TypeChecker.Tc.compress_and_norm ps.main_context); + + UF.rollback tx; + + (* Make sure to return None if any error was logged. *) + if List.length errs > 0 + then return (None, errs) + else ( + iter_tac (uncurry refl_typing_guard) gs;! + return (r, errs) + ) + +(* This runs the tactic `f` in the current proofstate, and returns an +Inl if any error was raised or logged by the execution. Returns Inr with +the result otherwise. It only advances the proofstate on a success. *) +let catch_all (f : tac 'a) : tac (either issues 'a) = + mk_tac (fun ps -> + match Errors.catch_errors_and_ignore_rest (fun () -> Tactics.Monad.run f ps) with + | [], Some (Success (v, ps')) -> Success (Inr v, ps') + | errs, _ -> Success (Inl errs, ps)) + +(* A *second* wrapper for typing builtin primitives. The wrapper +above (__refl_typing_builtin_wrapper) is meant to catch errors in the +execution of the primitive we are calling. This second is meant to catch +errors in the tactic execution, e.g. those related to discharging the +guards if a synchronous mode (SMTSync/Force) was used. + +This also adds the label to the messages. *) +let refl_typing_builtin_wrapper (label:string) (f:unit -> 'a & list (env & typ)) : tac (option 'a & issues) = + let open FStarC.Errors in + let! o, errs = + match! catch_all (__refl_typing_builtin_wrapper f) with + | Inl errs -> return (None, errs) + | Inr r -> return r + in + let errs = errs |> List.map (fun is -> { is with issue_msg = is.issue_msg @ [text ("Raised within Tactics." ^ label)] }) in + return (o, errs) + +let no_uvars_in_term (t:term) : bool = + t |> Free.uvars |> is_empty && + t |> Free.univs |> is_empty + +let no_univ_uvars_in_term (t:term) : bool = + t |> Free.univs |> is_empty + +let no_uvars_in_g (g:env) : bool = + g.gamma |> BU.for_all (function + | Binding_var bv -> no_uvars_in_term bv.sort + | _ -> true) + +type relation = + | Subtyping + | Equality + +let unexpected_uvars_issue r = + let open FStarC.Errors in + let i = { + issue_level = EError; + issue_range = Some r; + issue_msg = Errors.mkmsg "Cannot check relation with uvars"; + issue_number = Some (errno Error_UnexpectedUnresolvedUvar); + issue_ctx = [] + } in + i + +let refl_is_non_informative (g:env) (t:typ) : tac (option unit & issues) = + if no_uvars_in_g g && + no_uvars_in_term t + then refl_typing_builtin_wrapper "refl_is_non_informative" (fun _ -> + let g = Env.set_range g t.pos in + dbg_refl g (fun _ -> + BU.format1 "refl_is_non_informative: %s\n" + (show t)); + let b = Core.is_non_informative g t in + dbg_refl g (fun _ -> BU.format1 "refl_is_non_informative: returned %s" + (show b)); + if b then ((), []) + else Errors.raise_error g Errors.Fatal_UnexpectedTerm + "is_non_informative returned false" + ) else ( + return (None, [unexpected_uvars_issue (Env.get_range g)]) + ) + +let refl_check_relation (rel:relation) (smt_ok:bool) (unfolding_ok:bool) (g:env) (t0 t1:typ) + : tac (option unit & issues) = + + if no_uvars_in_g g && + no_uvars_in_term t0 && + no_uvars_in_term t1 + then refl_typing_builtin_wrapper "refl_check_relation" (fun _ -> + let g = Env.set_range g t0.pos in + dbg_refl g (fun _ -> + BU.format3 "refl_check_relation: %s %s %s\n" + (show t0) + (if rel = Subtyping then "<:?" else "=?=") + (show t1)); + let f = + if rel = Subtyping + then Core.check_term_subtyping + else Core.check_term_equality in + match f smt_ok unfolding_ok g t0 t1 with + | Inl None -> + dbg_refl g (fun _ -> "refl_check_relation: succeeded (no guard)\n"); + ((), []) + | Inl (Some guard_f) -> + dbg_refl g (fun _ -> "refl_check_relation: succeeded\n"); + ((), [(g, guard_f)]) + | Inr err -> + dbg_refl g (fun _ -> BU.format1 "refl_check_relation failed: %s\n" (Core.print_error err)); + Errors.raise_error g Errors.Fatal_IllTyped + ("check_relation failed: " ^ (Core.print_error err))) + else ( + return (None, [unexpected_uvars_issue (Env.get_range g)]) + ) + +let refl_check_subtyping (g:env) (t0 t1:typ) : tac (option unit & issues) = + refl_check_relation Subtyping true true g t0 t1 + +let t_refl_check_equiv = refl_check_relation Equality + +let to_must_tot (eff:Core.tot_or_ghost) : bool = + match eff with + | Core.E_Total -> true + | Core.E_Ghost -> false + +let tot_or_ghost_to_string = function + | Core.E_Total -> "E_Total" + | Core.E_Ghost -> "E_Ghost" + +let refl_norm_type (g:env) (t:typ) : typ = + N.normalize [Env.Beta; Env.Exclude Zeta] g t + +let refl_core_compute_term_type (g:env) (e:term) : tac (option (Core.tot_or_ghost & typ) & issues) = + if no_uvars_in_g g && + no_uvars_in_term e + then refl_typing_builtin_wrapper "refl_core_compute_term_type" (fun _ -> + let g = Env.set_range g e.pos in + dbg_refl g (fun _ -> + BU.format1 "refl_core_compute_term_type: %s\n" (show e)); + let guards : ref (list (env & typ)) = BU.mk_ref [] in + let gh = fun g guard -> + (* FIXME: this is kinda ugly, we store all the guards + in a local ref and fetch them at the end. *) + guards := (g, guard) :: !guards; + true + in + match Core.compute_term_type_handle_guards g e gh with + | Inl (eff, t) -> + let t = refl_norm_type g t in + dbg_refl g (fun _ -> + BU.format2 "refl_core_compute_term_type for %s computed type %s\n" + (show e) + (show t)); + ((eff, t), !guards) + | Inr err -> + dbg_refl g (fun _ -> BU.format1 "refl_core_compute_term_type: %s\n" (Core.print_error err)); + Errors.raise_error g Errors.Fatal_IllTyped + ("core_compute_term_type failed: " ^ (Core.print_error err))) + else return (None, [unexpected_uvars_issue (Env.get_range g)]) + +let refl_core_check_term (g:env) (e:term) (t:typ) (eff:Core.tot_or_ghost) + : tac (option unit & issues) = + + if no_uvars_in_g g && + no_uvars_in_term e && + no_uvars_in_term t + then refl_typing_builtin_wrapper "refl_core_check_term" (fun _ -> + let g = Env.set_range g e.pos in + dbg_refl g (fun _ -> + BU.format3 "refl_core_check_term: term: %s, type: %s, eff: %s\n" + (show e) (show t) + (tot_or_ghost_to_string eff)); + let must_tot = to_must_tot eff in + match Core.check_term g e t must_tot with + | Inl None -> + dbg_refl g (fun _ -> "refl_core_check_term: succeeded with no guard\n"); + ((), []) + | Inl (Some guard) -> + dbg_refl g (fun _ -> "refl_core_check_term: succeeded with guard\n"); + ((), [(g, guard)]) + | Inr err -> + dbg_refl g (fun _ -> BU.format1 "refl_core_check_term failed: %s\n" (Core.print_error err)); + Errors.raise_error g Errors.Fatal_IllTyped + ("refl_core_check_term failed: " ^ (Core.print_error err))) + else return (None, [unexpected_uvars_issue (Env.get_range g)]) + +let refl_core_check_term_at_type (g:env) (e:term) (t:typ) + : tac (option Core.tot_or_ghost & issues) = + + if no_uvars_in_g g && + no_uvars_in_term e && + no_uvars_in_term t + then refl_typing_builtin_wrapper "refl_core_check_term_at_type" (fun _ -> + let g = Env.set_range g e.pos in + dbg_refl g (fun _ -> + BU.format2 "refl_core_check_term_at_type: term: %s, type: %s\n" + (show e) (show t)); + match Core.check_term_at_type g e t with + | Inl (eff, None) -> + dbg_refl g (fun _ -> + BU.format1 "refl_core_check_term_at_type: succeeded with eff %s and no guard\n" + (tot_or_ghost_to_string eff)); + (eff, []) + | Inl (eff, Some guard) -> + dbg_refl g (fun _ -> + BU.format1 "refl_core_check_term_at_type: succeeded with eff %s and guard\n" + (tot_or_ghost_to_string eff)); + (eff, [(g, guard)]) + | Inr err -> + dbg_refl g (fun _ -> BU.format1 "refl_core_check_term_at_type failed: %s\n" (Core.print_error err)); + Errors.raise_error g Errors.Fatal_IllTyped + ("refl_core_check_term failed: " ^ (Core.print_error err))) + else return (None, [unexpected_uvars_issue (Env.get_range g)]) + +let refl_tc_term (g:env) (e:term) : tac (option (term & (Core.tot_or_ghost & typ)) & issues) = + if no_uvars_in_g g && + no_uvars_in_term e + then refl_typing_builtin_wrapper "refl_tc_term" (fun _ -> + let g = Env.set_range g e.pos in + dbg_refl g (fun _ -> + BU.format2 "refl_tc_term@%s: %s\n" (show e.pos) (show e)); + dbg_refl g (fun _ -> "refl_tc_term: starting tc {\n"); + // + // we don't instantiate implicits at the end of e + // it is unlikely that we will be able to resolve them, + // and refl typechecking API will fail if there are unresolved uvars + // + // note that this will still try to resolve implicits within e + // the typechecker does not check for this env flag for such implicits + // + let g = {g with instantiate_imp=false} in + // + // lax check to elaborate + // + let e = + let g = {g with phase1 = true; admit = true} in + // + // AR: we are lax checking to infer implicits, + // ghost is ok + // + let must_tot = false in + let e, _, guard = g.typeof_tot_or_gtot_term g e must_tot in + Rel.force_trivial_guard g guard; + e in + try + begin + if not (no_uvars_in_term e) + then ( + Errors.raise_error e Errors.Error_UnexpectedUnresolvedUvar + (BU.format1 "Elaborated term has unresolved implicits: %s" (show e)) + ) + else ( + let allow_uvars = false in + let allow_names = true in (* terms are potentially open, names are OK *) + let e = SC.deep_compress allow_uvars allow_names e in + // TODO: may be should we check here that e has no unresolved implicits? + dbg_refl g (fun _ -> + BU.format1 "} finished tc with e = %s\n" + (show e)); + let guards : ref (list (env & typ)) = BU.mk_ref [] in + let gh = fun g guard -> + (* collect guards and return them *) + dbg_refl g (fun _ -> + BU.format3 "Got guard in Env@%s |- %s@%s\n" + (Env.get_range g |> show) + (show guard) + (show guard.pos) + ); + guards := (g, guard) :: !guards; + true + in + match Core.compute_term_type_handle_guards g e gh with + | Inl (eff, t) -> + let t = refl_norm_type g t in + dbg_refl g (fun _ -> + BU.format3 "refl_tc_term@%s for %s computed type %s\n" + (show e.pos) + (show e) + (show t)); + ((e, (eff, t)), !guards) + | Inr err -> + dbg_refl g (fun _ -> BU.format1 "refl_tc_term failed: %s\n" (Core.print_error err)); + Errors.raise_error e Errors.Fatal_IllTyped ("tc_term callback failed: " ^ Core.print_error err) + ) + end + with + | Errors.Error (Errors.Error_UnexpectedUnresolvedUvar, _, _, _) -> + Errors.raise_error e Errors.Fatal_IllTyped "UVars remaing in term after tc_term callback") + else + return (None, [unexpected_uvars_issue (Env.get_range g)]) + +let refl_universe_of (g:env) (e:term) : tac (option universe & issues) = + let check_univ_var_resolved g u = + match SS.compress_univ u with + | S.U_unif _ -> Errors.raise_error g Errors.Fatal_IllTyped "Unresolved variable in universe_of callback" + | u -> u in + + if no_uvars_in_g g && + no_uvars_in_term e + then refl_typing_builtin_wrapper "refl_universe_of" (fun _ -> + let g = Env.set_range g e.pos in + let t, u = U.type_u () in + let must_tot = false in + match Core.check_term g e t must_tot with + | Inl None -> (check_univ_var_resolved g u, []) + | Inl (Some guard) -> + (check_univ_var_resolved g u, [(g, guard)]) + | Inr err -> + dbg_refl g (fun _ -> BU.format1 "refl_universe_of failed: %s\n" (Core.print_error err)); + Errors.raise_error g Errors.Fatal_IllTyped ("universe_of failed: " ^ Core.print_error err)) + else return (None, [unexpected_uvars_issue (Env.get_range g)]) + +let refl_check_prop_validity (g:env) (e:term) : tac (option unit & issues) = + if no_uvars_in_g g && + no_uvars_in_term e + then refl_typing_builtin_wrapper "refl_check_prop_validity" (fun _ -> + let g = Env.set_range g e.pos in + dbg_refl g (fun _ -> + BU.format1 "refl_check_prop_validity: %s\n" (show e)); + let must_tot = false in + let _ = + match Core.check_term g e (U.fvar_const PC.prop_lid) must_tot with + | Inl None -> () + | Inl (Some guard) -> + Rel.force_trivial_guard g + {Env.trivial_guard with guard_f=NonTrivial guard} + | Inr err -> + let msg = BU.format1 "refl_check_prop_validity failed (not a prop): %s\n" + (Core.print_error err) in + dbg_refl g (fun _ -> msg); + Errors.raise_error g Errors.Fatal_IllTyped msg + in + ((), [(g, e)]) + ) + else return (None, [unexpected_uvars_issue (Env.get_range g)]) + +let refl_check_match_complete (g:env) (sc:term) (scty:typ) (pats : list RD.pattern) +: tac (option (list RD.pattern & list (list RD.binding))) += + return () ;! + (* We just craft a match with the sc and patterns, using `1` in every + branch, and check it against type int. *) + let one = U.exp_int "1" in + let brs = List.map (fun p -> let p = pack_pat p in (p, None, one)) pats in + let mm = mk (Tm_match {scrutinee=sc; ret_opt=None; brs=brs; rc_opt=None}) sc.pos in + let env = g in + let env = Env.set_expected_typ env S.t_int in + let! mm, _, g = __tc env mm in + + let errs, b = Errors.catch_errors_and_ignore_rest (fun () -> Env.is_trivial <| Rel.discharge_guard env g) in + match errs, b with + | [], Some true -> + let get_pats t = + match (U.unmeta t).n with + | Tm_match {brs} -> List.map (fun (p,_,_) -> p) brs + | _ -> failwith "refl_check_match_complete: not a match?" + in + let pats = get_pats mm in + let rec bnds_for_pat (p:pat) : list RD.binding = + match p.v with + | Pat_constant _ -> [] + | Pat_cons (fv, _, pats) -> List.concatMap (fun (p, _) -> bnds_for_pat p) pats + | Pat_var bv -> [bv_to_binding bv] + | Pat_dot_term _ -> [] + in + return (Some (List.map inspect_pat pats, List.map bnds_for_pat pats)) + | _ -> return None + +let refl_instantiate_implicits (g:env) (e:term) (expected_typ : option term) + : tac (option (list (bv & typ) & term & typ) & issues) = + if no_uvars_in_g g && + no_uvars_in_term e + then refl_typing_builtin_wrapper "refl_instantiate_implicits" (fun _ -> + let g = Env.set_range g e.pos in + dbg_refl g (fun _ -> + BU.format1 "refl_instantiate_implicits: %s\n" (show e)); + dbg_refl g (fun _ -> "refl_instantiate_implicits: starting tc {\n"); + // AR: ghost is ok for instantiating implicits + let must_tot = false in + let g = + match expected_typ with + | None -> Env.clear_expected_typ g |> fst + | Some typ -> Env.set_expected_typ g typ + in + let g = {g with instantiate_imp=false; phase1=true; admit=true} in + let e, t, guard = g.typeof_tot_or_gtot_term g e must_tot in + // + // We don't worry about the logical payload, + // since this API does not return proof of typing + // + let guard = guard |> Rel.solve_deferred_constraints g |> Rel.resolve_implicits g in + let bvs_and_ts : list (bv & typ) = + match Listlike.to_list guard.implicits with + | [] -> [] + | imps -> + // + // We could not solve all implicits + // + // Create fresh names for the unsolved uvars, and + // set the solution for the uvars to these names + // This way when we compress the terms later, + // the uvars will be substituted with the names + // + let l : list (uvar & typ & bv) = + imps + |> List.map (fun {imp_uvar} -> + (imp_uvar.ctx_uvar_head, + U.ctx_uvar_typ imp_uvar, + S.new_bv None (S.mk Tm_unknown Range.dummyRange))) + in + l |> List.iter (fun (uv, _, bv) -> U.set_uvar uv (S.bv_to_name bv)); + List.map (fun (_, t, bv) -> bv, t) l + in + + dbg_refl g (fun _ -> BU.format2 "refl_instantiate_implicits: inferred %s : %s" (show e) (show t)); + + if not (no_univ_uvars_in_term e) + then Errors.raise_error e Errors.Error_UnexpectedUnresolvedUvar + (BU.format1 "Elaborated term has unresolved univ uvars: %s" (show e)); + if not (no_univ_uvars_in_term t) + then Errors.raise_error e Errors.Error_UnexpectedUnresolvedUvar + (BU.format1 "Inferred type has unresolved univ uvars: %s" (show t)); + bvs_and_ts |> List.iter (fun (x, t) -> + if not (no_univ_uvars_in_term t) + then Errors.raise_error e Errors.Error_UnexpectedUnresolvedUvar + (BU.format2 "Inferred type has unresolved univ uvars: %s:%s" (show x) (show t))); + let g = Env.push_bvs g (List.map (fun (bv, t) -> {bv with sort=t}) bvs_and_ts) in + let allow_uvars = false in + let allow_names = true in (* terms are potentially open, names are OK *) + let e = SC.deep_compress allow_uvars allow_names e in + let t = t |> refl_norm_type g |> SC.deep_compress allow_uvars allow_names in + let bvs_and_ts = + bvs_and_ts |> List.map (fun (bv, t) -> bv, SC.deep_compress allow_uvars allow_names t) in + + dbg_refl g (fun _ -> + BU.format2 "} finished tc with e = %s and t = %s\n" + (show e) + (show t)); + ((bvs_and_ts, e, t), []) + ) + else return (None, [unexpected_uvars_issue (Env.get_range g)]) + +let refl_try_unify (g:env) (uvs:list (bv & typ)) (t0 t1:term) + : tac (option (list (bv & term)) & issues) = + + if no_uvars_in_g g && + no_uvars_in_term t0 && + no_uvars_in_term t1 && + List.for_all no_uvars_in_term (List.map snd uvs) + then refl_typing_builtin_wrapper "refl_try_unify" (fun _ -> + dbg_refl g (fun _ -> BU.format3 "refl_try_unify %s and %s, with uvs: %s {\n" + (show t0) + (show t1) + (show uvs)); + let g = Env.set_range g t0.pos in + // + // create uvars for the bvs in uvs, + // and maintain a mapping from uvars to bvs in tbl + // we apply substitutions to uvs accordingly (replacing uvs names with newly created uvars) + // + let guard_uvs, ss, tbl = List.fold_left (fun (guard_uvs, ss, tbl) (bv, t) -> + let t = SS.subst ss t in + let uv_t, (ctx_u, _), guard_uv = + // the API doesn't promise well-typedness of the solutions + let reason = BU.format1 "refl_try_unify for %s" (show bv) in + let should_check_uvar = Allow_untyped "refl_try_unify" in + Env.new_implicit_var_aux reason t0.pos g t should_check_uvar None false + in + let uv_id = Syntax.Unionfind.uvar_unique_id ctx_u.ctx_uvar_head in + Env.conj_guard guard_uvs guard_uv, + (NT (bv, uv_t))::ss, + BU.pimap_add tbl uv_id (ctx_u.ctx_uvar_head, bv) + ) (Env.trivial_guard, [], (BU.pimap_empty ())) uvs in + let t0, t1 = SS.subst ss t0, SS.subst ss t1 in + let g = { g with phase1=true; admit=true } in + let guard_eq = + let smt_ok = true in + Rel.try_teq smt_ok g t0 t1 in + let l = + match guard_eq with + | None -> [] // could not unify + | Some guard -> + let guard = Env.conj_guard guard_uvs guard in + let guard = guard |> Rel.solve_deferred_constraints g |> Rel.resolve_implicits g in + + // + // if there is some unresolved implicit that was not part of uvs, + // e.g., created as part of Rel.try_teq, return [] + // + let b = List.existsb (fun {imp_uvar = {ctx_uvar_head = (uv, _, _)}} -> + BU.pimap_try_find tbl (Unionfind.puf_unique_id uv) = None) (Listlike.to_list guard.implicits) in + if b then [] + else + // + // iterate over the tbl + // return uvs that could be solved fully + // + BU.pimap_fold tbl (fun id (uvar, bv) l -> + match Syntax.Unionfind.find uvar with + | Some t -> + let allow_uvars = true in + let allow_names = true in + let t = SC.deep_compress allow_uvars allow_names t in + if t |> Syntax.Free.uvars_full |> is_empty + then (bv, t)::l + else l + | None -> l + ) [] in + dbg_refl g (fun _ -> BU.format1 "} refl_try_unify, substitution is: %s\n" (show l)); + l, [] + ) + else return (None, [unexpected_uvars_issue (Env.get_range g)]) + + +let refl_maybe_relate_after_unfolding (g:env) (t0 t1:typ) + : tac (option Core.side & issues) = + + if no_uvars_in_g g && + no_uvars_in_term t0 && + no_uvars_in_term t1 + then refl_typing_builtin_wrapper "refl_maybe_relate_after_unfolding" (fun _ -> + let g = Env.set_range g t0.pos in + dbg_refl g (fun _ -> + BU.format2 "refl_maybe_relate_after_unfolding: %s and %s {\n" + (show t0) + (show t1)); + let s = Core.maybe_relate_after_unfolding g t0 t1 in + dbg_refl g (fun _ -> + BU.format1 "} returning side: %s\n" (show s)); + s, []) + else return (None, [unexpected_uvars_issue (Env.get_range g)]) + +let refl_maybe_unfold_head (g:env) (e:term) : tac (option term & issues) = + if no_uvars_in_g g && + no_uvars_in_term e + then refl_typing_builtin_wrapper "refl_maybe_unfold_head" (fun _ -> + let g = Env.set_range g e.pos in + dbg_refl g (fun _ -> + BU.format1 "refl_maybe_unfold_head: %s {\n" (show e)); + let eopt = N.maybe_unfold_head g e in + dbg_refl g (fun _ -> + BU.format1 "} eopt = %s\n" + (match eopt with + | None -> "none" + | Some e -> show e)); + if eopt = None + then Errors.raise_error e Errors.Fatal_UnexpectedTerm + (BU.format1 "Could not unfold head: %s\n" (show e)) + else (eopt |> must, [])) + else return (None, [unexpected_uvars_issue (Env.get_range g)]) + +let push_open_namespace (e:env) (ns:list string) = + let lid = Ident.lid_of_path ns Range.dummyRange in + return { e with dsenv = FStarC.Syntax.DsEnv.push_namespace e.dsenv lid Unrestricted } + +let push_module_abbrev (e:env) (n:string) (m:list string) = + let mlid = Ident.lid_of_path m Range.dummyRange in + let ident = Ident.id_of_text n in + return { e with dsenv = FStarC.Syntax.DsEnv.push_module_abbrev e.dsenv ident mlid } + +let resolve_name (e:env) (n:list string) = + let l = Ident.lid_of_path n Range.dummyRange in + return (FStarC.Syntax.DsEnv.resolve_name e.dsenv l) + +let log_issues (is : list Errors.issue) : tac unit = + let open FStarC.Errors in + let! ps = get in + (* Prepend an error component, unless the tactic handles its own errors. *) + let is = + if ps.dump_on_failure + then + is |> + List.map (fun i -> { i with issue_msg = (Errors.text "Tactic logged issue:")::i.issue_msg }) + else + is + in + add_issues is; + return () + +(**** Creating proper environments and proofstates ****) + +let tac_env (env:Env.env) : Env.env = + let env, _ = Env.clear_expected_typ env in + let env = { env with Env.instantiate_imp = false } in + let env = { env with failhard = true } in + let env = { env with enable_defer_to_tac = false } in + env + +let proofstate_of_goals rng env goals imps = + let env = tac_env env in + let ps = { + main_context = env; + all_implicits = imps; + goals = goals; + smt_goals = []; + depth = 0; + __dump = do_dump_proofstate; + psc = PO.null_psc; + entry_range = rng; + guard_policy = SMT; + freshness = 0; + tac_verb_dbg = !dbg_TacVerbose; + local_state = BU.psmap_empty (); + urgency = 1; + dump_on_failure = true; + } + in + ps + +let proofstate_of_goal_ty rng env typ = + let env = { env with range = rng } in + let env = tac_env env in + let g, g_u = goal_of_goal_ty env typ in + let ps = proofstate_of_goals rng env [g] (Listlike.to_list g_u.implicits) in + (ps, goal_witness g) + +let proofstate_of_all_implicits rng env imps = + let env = tac_env env in + let goals = List.map (goal_of_implicit env) imps in + let w = goal_witness (List.hd goals) in + let ps = { + main_context = env; + all_implicits = imps; + goals = goals; + smt_goals = []; + depth = 0; + __dump = do_dump_proofstate; + psc = PO.null_psc; + entry_range = rng; + guard_policy = SMT; + freshness = 0; + tac_verb_dbg = !dbg_TacVerbose; + local_state = BU.psmap_empty (); + urgency = 1; + dump_on_failure = true; + } + in + (ps, w) + +let getprop (e:Env.env) (t:term) : option term = + let tn = N.normalize [Env.Weak; Env.HNF; Env.UnfoldUntil delta_constant] e t in + U.un_squash tn + +let run_unembedded_tactic_on_ps_and_solve_remaining + (t_range g_range : Range.range) + (background : bool) + (t : 'a) + (f : 'a -> tac 'b) + (ps : proofstate) + : 'b += + let remaining_goals, r = FStarC.Tactics.Interpreter.run_unembedded_tactic_on_ps t_range g_range background t f ps in + // Check that all goals left are irrelevant and provable + remaining_goals |> List.iter (fun g -> + match getprop (goal_env g) (goal_type g) with + | Some vc -> + let guard = guard_of_guard_formula (NonTrivial vc) in + Rel.force_trivial_guard (goal_env g) guard + | None -> + Err.raise_error g_range Err.Fatal_OpenGoalsInSynthesis "tactic left a computationally-relevant goal unsolved"); + r + +let call_subtac (g:env) (f : tac unit) (_u:universe) (goal_ty : typ) : tac (option term & issues) = + return ();! // thunk + let rng = Env.get_range g in + let ps, w = proofstate_of_goal_ty rng g goal_ty in + let ps = { ps with dump_on_failure = false } in // subtacs can fail gracefully, do not dump the failed proofstate. + match Errors.catch_errors_and_ignore_rest (fun () -> + run_unembedded_tactic_on_ps_and_solve_remaining rng rng false () (fun () -> f) ps) + with + | [], Some () -> + return (Some w, []) + | issues, _ -> + return (None, issues) + +let run_tactic_on_ps_and_solve_remaining + (#a #b : Type) + (t_range g_range : Range.range) + (background : bool) + (t : a) + (f_tm : term) + (ps : proofstate) + : unit += + let remaining_goals, r = FStarC.Tactics.Interpreter.run_tactic_on_ps #unit #unit t_range g_range background TC.solve () TC.solve f_tm false ps in + // Check that all goals left are irrelevant and provable + remaining_goals |> List.iter (fun g -> + match getprop (goal_env g) (goal_type g) with + | Some vc -> + let guard = guard_of_guard_formula (NonTrivial vc) in + Rel.force_trivial_guard (goal_env g) guard + | None -> + Err.raise_error g_range Err.Fatal_OpenGoalsInSynthesis "tactic left a computationally-relevant goal unsolved"); + r + +let call_subtac_tm (g:env) (f_tm : term) (_u:universe) (goal_ty : typ) : tac (option term & issues) = + return ();! // thunk + let rng = Env.get_range g in + let ps, w = proofstate_of_goal_ty rng g goal_ty in + let ps = { ps with dump_on_failure = false } in // subtacs can fail gracefully, do not dump the failed proofstate. + match Errors.catch_errors_and_ignore_rest (fun () -> + run_tactic_on_ps_and_solve_remaining #unit #unit rng rng false () f_tm ps) + with + | [], Some () -> + return (Some w, []) + | issues, _ -> + return (None, issues) diff --git a/src/tactics/FStarC.Tactics.V2.Basic.fsti b/src/tactics/FStarC.Tactics.V2.Basic.fsti new file mode 100644 index 00000000000..4bf11e3b8c0 --- /dev/null +++ b/src/tactics/FStarC.Tactics.V2.Basic.fsti @@ -0,0 +1,154 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Tactics.V2.Basic + +(* This module implements the primitives in + * ulib/FStarC.Tactics.Builtins. It would be named + * the same, but there needs to be a thin adapter + * layer since the tac monad representation differs + * between compiler and userspace (and a few other + * annoyances too). *) + +open FStarC +open FStarC.Syntax.Syntax +open FStarC.TypeChecker.Env +open FStarC.Reflection.V2.Data +open FStarC.Tactics.Types +open FStarC.Tactics.Monad + +module BU = FStarC.Compiler.Util +module O = FStarC.Options +module Range = FStarC.Compiler.Range +module Z = FStarC.BigInt +module TcComm = FStarC.TypeChecker.Common +module Core = FStarC.TypeChecker.Core +module RD = FStarC.Reflection.V2.Data + +val proofstate_of_goals : Range.range -> env -> list goal -> list implicit -> proofstate +(* Returns proofstate and uvar for main witness *) +val proofstate_of_goal_ty : Range.range -> env -> typ -> proofstate & term + +val proofstate_of_all_implicits: Range.range -> env -> implicits -> proofstate & term + +(* Metaprogramming primitives (not all of them). + * Documented in `ulib/FStarC.Tactics.Builtins.fst` *) + +val compress : term -> tac term +val top_env : unit -> tac env +val fresh : unit -> tac Z.t +val refine_intro : unit -> tac unit +val tc : env -> term -> tac typ +val tcc : env -> term -> tac comp +val unshelve : term -> tac unit +val unquote : typ -> term -> tac term +val norm : list Pervasives.norm_step -> tac unit +val norm_term_env : env -> list Pervasives.norm_step -> term -> tac term +val norm_binding_type : list Pervasives.norm_step -> RD.binding -> tac unit +val intro : unit -> tac RD.binding +val intros : (max:Z.t) -> tac (list RD.binding) +val intro_rec : unit -> tac (RD.binding & RD.binding) +val rename_to : RD.binding -> string -> tac RD.binding +val revert : unit -> tac unit +val var_retype : RD.binding -> tac unit +val clear_top : unit -> tac unit +val clear : RD.binding -> tac unit +val rewrite : RD.binding -> tac unit +val grewrite : term -> term -> tac unit +val t_exact : bool -> bool -> term -> tac unit +val t_apply : bool -> bool -> bool -> term -> tac unit +val t_apply_lemma : bool -> bool -> term -> tac unit +val print : string -> tac unit +val debugging : unit -> tac bool +val ide : unit -> tac bool +val dump : string -> tac unit +val dump_all : bool -> string -> tac unit +val dump_uvars_of : goal -> string -> tac unit +val t_trefl : (*allow_guards:*)bool -> tac unit +val dup : unit -> tac unit +val prune : string -> tac unit +val addns : string -> tac unit +val t_destruct : term -> tac (list (fv & Z.t)) +val gather_explicit_guards_for_resolved_goals : unit -> tac unit +val set_options : string -> tac unit +val uvar_env : env -> option typ -> tac term +val ghost_uvar_env : env -> typ -> tac term +val fresh_universe_uvar : unit -> tac term +val unify_env : env -> term -> term -> tac bool +val unify_guard_env : env -> term -> term -> tac bool +val match_env : env -> term -> term -> tac bool +val launch_process : string -> list string -> string -> tac string +val fresh_bv_named : string -> tac bv +val change : typ -> tac unit +val get_guard_policy : unit -> tac guard_policy +val set_guard_policy : guard_policy -> tac unit +val lax_on : unit -> tac bool +val tadmit_t : term -> tac unit +val join : unit -> tac unit +val lget : typ -> string -> tac term +val lset : typ -> string -> term -> tac unit +val curms : unit -> tac Z.t +val set_urgency : Z.t -> tac unit +val set_dump_on_failure : bool -> tac unit +val t_commute_applied_match : unit -> tac unit +val string_to_term : env -> string -> tac term +val push_bv_dsenv : env -> string -> tac (env & RD.binding) +val term_to_string : term -> tac string +val comp_to_string : comp -> tac string +val term_to_doc : term -> tac Pprint.document +val comp_to_doc : comp -> tac Pprint.document +val range_to_string : Range.range -> tac string +val term_eq_old : term -> term -> tac bool +val with_compat_pre_core : Z.t -> tac 'a -> tac 'a + +val get_vconfig : unit -> tac FStarC.VConfig.vconfig +val set_vconfig : FStarC.VConfig.vconfig -> tac unit +val t_smt_sync : FStarC.VConfig.vconfig -> tac unit +val free_uvars : term -> tac (list Z.t) + +val all_ext_options : unit -> tac (list (string & string)) +val ext_getv : string -> tac string +val ext_getns : string -> tac (list (string & string)) + +val alloc : 'a -> tac (tref 'a) +val read : tref 'a -> tac 'a +val write : tref 'a -> 'a -> tac unit + +(***** Callbacks for the meta DSL framework *****) +let issues = list FStarC.Errors.issue +val refl_is_non_informative : env -> typ -> tac (option unit & issues) +val refl_check_subtyping : env -> typ -> typ -> tac (option unit & issues) +val t_refl_check_equiv : smt_ok:bool -> unfolding_ok:bool -> env -> typ -> typ -> tac (option unit & issues) +val refl_core_compute_term_type : env -> term -> tac (option (Core.tot_or_ghost & typ) & issues) +val refl_core_check_term : env -> term -> typ -> Core.tot_or_ghost -> tac (option unit & issues) +val refl_core_check_term_at_type : env -> term -> typ -> tac (option Core.tot_or_ghost & issues) +val refl_tc_term : env -> term -> tac (option (term & (Core.tot_or_ghost & typ)) & issues) +val refl_universe_of : env -> term -> tac (option universe & issues) +val refl_check_prop_validity : env -> term -> tac (option unit & issues) +val refl_check_match_complete : env -> term -> term -> list pattern -> tac (option (list pattern & list (list RD.binding))) +val refl_instantiate_implicits : env -> term -> expected_typ:option term -> tac (option (list (bv & typ) & term & typ) & issues) +val refl_try_unify : env -> list (bv & typ) -> term -> term -> tac (option (list (bv & term)) & issues) +val refl_maybe_relate_after_unfolding : env -> term -> term -> tac (option Core.side & issues) +val refl_maybe_unfold_head : env -> term -> tac (option term & issues) +val refl_norm_well_typed_term : env -> list norm_step -> term -> tac term + +val push_open_namespace : env -> list string -> tac env +val push_module_abbrev : env -> string -> list string -> tac env +val resolve_name : env -> list string -> tac (option (either bv fv)) +val log_issues : list Errors.issue -> tac unit + +val call_subtac : env -> tac unit -> universe -> typ -> tac (option term & issues) +val call_subtac_tm : env -> term -> universe -> typ -> tac (option term & issues) diff --git a/src/tactics/FStarC.Tactics.V2.Primops.fst b/src/tactics/FStarC.Tactics.V2.Primops.fst new file mode 100644 index 00000000000..5ddc8c4db72 --- /dev/null +++ b/src/tactics/FStarC.Tactics.V2.Primops.fst @@ -0,0 +1,283 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.Tactics.V2.Primops + +(* Most of the tactic running logic is here. V1.Interpreter calls +into this module for all of that. *) + +open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Compiler.Range +open FStarC.Compiler.Util +open FStarC.Syntax.Syntax +open FStarC.Syntax.Embeddings +open FStarC.TypeChecker.Common +open FStarC.TypeChecker.Env +open FStarC.Tactics.Result +open FStarC.Tactics.Types +open FStarC.Tactics.Printing +open FStarC.Tactics.Monad +open FStarC.Tactics.V2.Basic +open FStarC.Tactics.CtrlRewrite +open FStarC.Tactics.Native +open FStarC.Tactics.Common +open FStarC.Tactics.InterpFuns +open FStarC.Class.Show +open FStarC.Class.Monad + +module BU = FStarC.Compiler.Util +module Cfg = FStarC.TypeChecker.Cfg +module E = FStarC.Tactics.Embedding +module Env = FStarC.TypeChecker.Env +module Err = FStarC.Errors +module NBE = FStarC.TypeChecker.NBE +module NBET = FStarC.TypeChecker.NBETerm +module N = FStarC.TypeChecker.Normalize +module NRE = FStarC.Reflection.V2.NBEEmbeddings +module PC = FStarC.Parser.Const +module PO = FStarC.TypeChecker.Primops +module Print = FStarC.Syntax.Print +module RE = FStarC.Reflection.V2.Embeddings +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module TcComm = FStarC.TypeChecker.Common +module TcRel = FStarC.TypeChecker.Rel +module TcTerm = FStarC.TypeChecker.TcTerm +module TI = FStarC.Tactics.Interpreter +module U = FStarC.Syntax.Util + +let solve (#a:Type) {| ev : a |} : Tot a = ev + +instance _ = RE.e_term (* REMOVE ME *) + +(* Takes a `sealed a`, but that's just a userspace abstraction. *) +let unseal (_typ:_) (x:Sealed.sealed 'a) : tac 'a = return (Sealed.unseal x) +let unseal_step = + (* Unseal is not in builtins. *) + let s = + mk_tac_step_2 1 "unseal" + #e_any #(e_sealed e_any) #e_any + #NBET.e_any #(NBET.e_sealed NBET.e_any) #NBET.e_any + unseal unseal + in + { s with name = PC.unseal_lid } + +let e_ret_t #a (d : embedding a) : embedding (option a & issues) = solve +let nbe_e_ret_t #a (d : NBET.embedding a) : NBET.embedding (option a & issues) = solve + +let ops = [ + (* Total steps *) + mk_tot_step_1_psc 0 "tracepoint" tracepoint_with_psc tracepoint_with_psc; + mk_tot_step_2 0 "set_proofstate_range" set_proofstate_range set_proofstate_range; + mk_tot_step_1 0 "incr_depth" incr_depth incr_depth; + mk_tot_step_1 0 "decr_depth" decr_depth decr_depth; + mk_tot_step_1 0 "goals_of" goals_of goals_of; + mk_tot_step_1 0 "smt_goals_of" smt_goals_of smt_goals_of; + mk_tot_step_1 0 "goal_env" goal_env goal_env; + mk_tot_step_1 0 "goal_type" goal_type goal_type; + mk_tot_step_1 0 "goal_witness" goal_witness goal_witness; + mk_tot_step_1 0 "is_guard" is_guard is_guard; + mk_tot_step_1 0 "get_label" get_label get_label; + mk_tot_step_2 0 "set_label" set_label set_label; + + (* Tactic builtin steps *) + + unseal_step; + + mk_tac_step_1 0 "compress" compress compress; + mk_tac_step_1 0 "set_goals" set_goals set_goals; + mk_tac_step_1 0 "set_smt_goals" set_smt_goals set_smt_goals; + + mk_tac_step_2 1 "catch" + #e_any #(TI.e_tactic_thunk e_any) #(e_either E.e_exn e_any) + #NBET.e_any #(TI.e_tactic_nbe_thunk NBET.e_any) #(NBET.e_either E.e_exn_nbe NBET.e_any) + (fun _ -> catch) + (fun _ -> catch); + + mk_tac_step_2 1 "recover" + #e_any #(TI.e_tactic_thunk e_any) #(e_either E.e_exn e_any) + #NBET.e_any #(TI.e_tactic_nbe_thunk NBET.e_any) #(NBET.e_either E.e_exn_nbe NBET.e_any) + (fun _ -> recover) + (fun _ -> recover); + + mk_tac_step_1 0 "intro" intro intro; + mk_tac_step_1 0 "intros" intros intros; + mk_tac_step_1 0 "intro_rec" intro_rec intro_rec; + mk_tac_step_1 0 "norm" norm norm; + mk_tac_step_3 0 "norm_term_env" norm_term_env norm_term_env; + mk_tac_step_2 0 "norm_binding_type" norm_binding_type norm_binding_type; + mk_tac_step_2 0 "rename_to" rename_to rename_to; + mk_tac_step_1 0 "var_retype" var_retype var_retype; + mk_tac_step_1 0 "revert" revert revert; + mk_tac_step_1 0 "clear_top" clear_top clear_top; + mk_tac_step_1 0 "clear" clear clear; + mk_tac_step_1 0 "rewrite" rewrite rewrite; + mk_tac_step_2 0 "grewrite" grewrite grewrite; + mk_tac_step_1 0 "refine_intro" refine_intro refine_intro; + mk_tac_step_3 0 "t_exact" t_exact t_exact; + mk_tac_step_4 0 "t_apply" t_apply t_apply; + mk_tac_step_3 0 "t_apply_lemma" t_apply_lemma t_apply_lemma; + mk_tac_step_1 0 "set_options" set_options set_options; + mk_tac_step_2 0 "tcc" tcc tcc; + mk_tac_step_2 0 "tc" tc tc; + mk_tac_step_1 0 "unshelve" unshelve unshelve; + + mk_tac_step_2 1 "unquote" + #e_any #RE.e_term #e_any + #NBET.e_any #NRE.e_term #NBET.e_any + unquote + (fun _ _ -> failwith "NBE unquote"); + + mk_tac_step_1 0 "prune" prune prune; + mk_tac_step_1 0 "addns" addns addns; + mk_tac_step_1 0 "print" print print; + mk_tac_step_1 0 "debugging" debugging debugging; + mk_tac_step_1 0 "ide" ide ide; + mk_tac_step_1 0 "dump" dump dump; + mk_tac_step_2 0 "dump_all" dump_all dump_all; + mk_tac_step_2 0 "dump_uvars_of" dump_uvars_of dump_uvars_of; + + mk_tac_step_3 0 "ctrl_rewrite" + #E.e_direction #(TI.e_tactic_1 RE.e_term (e_tuple2 e_bool E.e_ctrl_flag)) + #(TI.e_tactic_thunk e_unit) + #e_unit + #E.e_direction_nbe #(TI.e_tactic_nbe_1 NRE.e_term (NBET.e_tuple2 NBET.e_bool E.e_ctrl_flag_nbe)) + #(TI.e_tactic_nbe_thunk NBET.e_unit) + #NBET.e_unit + ctrl_rewrite + ctrl_rewrite; + + mk_tac_step_1 0 "t_trefl" t_trefl t_trefl; + mk_tac_step_1 0 "dup" dup dup; + mk_tac_step_1 0 "tadmit_t" tadmit_t tadmit_t; + mk_tac_step_1 0 "join" join join; + mk_tac_step_1 0 "t_destruct" t_destruct t_destruct; + mk_tac_step_1 0 "top_env" top_env top_env; + mk_tac_step_1 0 "fresh" fresh fresh; + mk_tac_step_1 0 "curms" curms curms; + mk_tac_step_2 0 "uvar_env" uvar_env uvar_env; + mk_tac_step_2 0 "ghost_uvar_env" ghost_uvar_env ghost_uvar_env; + mk_tac_step_1 0 "fresh_universe_uvar" fresh_universe_uvar fresh_universe_uvar; + mk_tac_step_3 0 "unify_env" unify_env unify_env; + mk_tac_step_3 0 "unify_guard_env" unify_guard_env unify_guard_env; + mk_tac_step_3 0 "match_env" match_env match_env; + mk_tac_step_3 0 "launch_process" launch_process launch_process; + mk_tac_step_1 0 "change" change change; + mk_tac_step_1 0 "get_guard_policy" get_guard_policy get_guard_policy; + mk_tac_step_1 0 "set_guard_policy" set_guard_policy set_guard_policy; + mk_tac_step_1 0 "lax_on" lax_on lax_on; + + mk_tac_step_2 1 "lget" + #e_any #e_string #e_any + #NBET.e_any #NBET.e_string #NBET.e_any + lget + (fun _ _ -> fail "sorry, `lget` does not work in NBE"); + + mk_tac_step_3 1 "lset" + #e_any #e_string #e_any #e_unit + #NBET.e_any #NBET.e_string #NBET.e_any #NBET.e_unit + lset + (fun _ _ _ -> fail "sorry, `lset` does not work in NBE"); + + mk_tac_step_1 1 "set_urgency" set_urgency set_urgency; + mk_tac_step_1 1 "set_dump_on_failure" set_dump_on_failure set_dump_on_failure; + mk_tac_step_1 1 "t_commute_applied_match" t_commute_applied_match t_commute_applied_match; + mk_tac_step_1 0 "gather_or_solve_explicit_guards_for_resolved_goals" + gather_explicit_guards_for_resolved_goals + gather_explicit_guards_for_resolved_goals; + mk_tac_step_2 0 "string_to_term" string_to_term string_to_term; + mk_tac_step_2 0 "push_bv_dsenv" push_bv_dsenv push_bv_dsenv; + mk_tac_step_1 0 "term_to_string" term_to_string term_to_string; + mk_tac_step_1 0 "comp_to_string" comp_to_string comp_to_string; + mk_tac_step_1 0 "term_to_doc" term_to_doc term_to_doc; + mk_tac_step_1 0 "comp_to_doc" comp_to_doc comp_to_doc; + mk_tac_step_1 0 "range_to_string" range_to_string range_to_string; + mk_tac_step_2 0 "term_eq_old" term_eq_old term_eq_old; + + mk_tac_step_3 1 "with_compat_pre_core" + #e_any #e_int #(TI.e_tactic_thunk e_any) #e_any + #NBET.e_any #NBET.e_int #(TI.e_tactic_nbe_thunk NBET.e_any) #NBET.e_any + (fun _ -> with_compat_pre_core) + (fun _ -> with_compat_pre_core); + + mk_tac_step_1 0 "get_vconfig" get_vconfig get_vconfig; + mk_tac_step_1 0 "set_vconfig" set_vconfig set_vconfig; + mk_tac_step_1 0 "t_smt_sync" t_smt_sync t_smt_sync; + mk_tac_step_1 0 "free_uvars" free_uvars free_uvars; + mk_tac_step_1 0 "all_ext_options" all_ext_options all_ext_options; + mk_tac_step_1 0 "ext_getv" ext_getv ext_getv; + mk_tac_step_1 0 "ext_getns" ext_getns ext_getns; + + mk_tac_step_2 1 "alloc" + #e_any #e_any #(E.e_tref #S.term) + #NBET.e_any #NBET.e_any #(E.e_tref_nbe #NBET.t) + (fun _ -> alloc) + (fun _ -> alloc); + + mk_tac_step_2 1 "read" + #e_any #(E.e_tref #S.term) #e_any + #NBET.e_any #(E.e_tref_nbe #NBET.t) #NBET.e_any + (fun _ -> read) + (fun _ -> read); + + mk_tac_step_3 1 "write" + #e_any #(E.e_tref #S.term) #e_any #e_unit + #NBET.e_any #(E.e_tref_nbe #NBET.t) #NBET.e_any #NBET.e_unit + (fun _ -> write) + (fun _ -> write); + + // reflection typechecker callbacks (part of the DSL framework) + + mk_tac_step_2 0 "is_non_informative" refl_is_non_informative refl_is_non_informative; + mk_tac_step_3 0 "check_subtyping" refl_check_subtyping refl_check_subtyping; + mk_tac_step_5 0 "t_check_equiv" t_refl_check_equiv t_refl_check_equiv; + mk_tac_step_2 0 "core_compute_term_type" refl_core_compute_term_type refl_core_compute_term_type; + mk_tac_step_4 0 "core_check_term" refl_core_check_term refl_core_check_term; + mk_tac_step_3 0 "core_check_term_at_type" refl_core_check_term_at_type refl_core_check_term_at_type; + mk_tac_step_2 0 "tc_term" refl_tc_term refl_tc_term; + mk_tac_step_2 0 "universe_of" refl_universe_of refl_universe_of; + mk_tac_step_2 0 "check_prop_validity" refl_check_prop_validity refl_check_prop_validity; + mk_tac_step_4 0 "check_match_complete" refl_check_match_complete refl_check_match_complete; + mk_tac_step_3 0 "instantiate_implicits" + #_ #_ #_ #(e_ret_t (e_tuple3 (e_list (e_tuple2 RE.e_namedv solve)) solve solve)) + #_ #_ #_ #(nbe_e_ret_t (NBET.e_tuple3 (NBET.e_list (NBET.e_tuple2 NRE.e_namedv solve)) solve solve)) + refl_instantiate_implicits refl_instantiate_implicits; + mk_tac_step_4 0 "try_unify" + #_ #(e_list (e_tuple2 RE.e_namedv RE.e_term)) #_ #_ #(e_ret_t (e_list (e_tuple2 RE.e_namedv RE.e_term))) + #_ #(NBET.e_list (NBET.e_tuple2 NRE.e_namedv NRE.e_term)) #_ #_ #(nbe_e_ret_t (NBET.e_list (NBET.e_tuple2 NRE.e_namedv NRE.e_term))) + refl_try_unify refl_try_unify; + mk_tac_step_3 0 "maybe_relate_after_unfolding" refl_maybe_relate_after_unfolding refl_maybe_relate_after_unfolding; + mk_tac_step_2 0 "maybe_unfold_head" refl_maybe_unfold_head refl_maybe_unfold_head; + mk_tac_step_3 0 "norm_well_typed_term" refl_norm_well_typed_term refl_norm_well_typed_term; + + mk_tac_step_2 0 "push_open_namespace" push_open_namespace push_open_namespace; + mk_tac_step_3 0 "push_module_abbrev" push_module_abbrev push_module_abbrev; + mk_tac_step_2 0 "resolve_name" + #_ #_ #(e_option (e_either RE.e_bv solve)) // disambiguate bv/namedv + #_ #_ #(NBET.e_option (NBET.e_either NRE.e_bv solve)) + resolve_name resolve_name; + mk_tac_step_1 0 "log_issues" log_issues log_issues; + mk_tac_step_4 0 "call_subtac" + #_ #(TI.e_tactic_thunk e_unit) #_ #_ #_ + #_ #(TI.e_tactic_nbe_thunk NBET.e_unit) #_ #_ #_ + call_subtac call_subtac; + + mk_tac_step_4 0 "call_subtac_tm" + call_subtac_tm call_subtac_tm; +] diff --git a/src/tactics/FStarC.Tactics.V2.Primops.fsti b/src/tactics/FStarC.Tactics.V2.Primops.fsti new file mode 100644 index 00000000000..852758bcb46 --- /dev/null +++ b/src/tactics/FStarC.Tactics.V2.Primops.fsti @@ -0,0 +1,20 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Tactics.V2.Primops + +open FStarC.TypeChecker.Primops.Base + +val ops : list primitive_step diff --git a/src/tests/FStar.Tests.Data.fst b/src/tests/FStar.Tests.Data.fst deleted file mode 100644 index 01be3b858a2..00000000000 --- a/src/tests/FStar.Tests.Data.fst +++ /dev/null @@ -1,66 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Tests.Data -// tests about data structures - - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -module BU = FStar.Compiler.Util - -module FlatSet = FStar.Compiler.FlatSet -module RBSet = FStar.Compiler.RBSet - -open FStar.Class.Setlike -open FStar.Class.Show - -let rec insert (n:int) {| setlike int 'set |} (s : 'set) = - if n = 0 then s - else insert (n-1) (add n s) - -let rec all_mem (n:int) {| setlike int 'set |} (s : 'set) = - if n = 0 then true - else mem n s && all_mem (n-1) s - -let rec all_remove (n:int) {| setlike int 'set |} (s : 'set) = - if n = 0 then s - else all_remove (n-1) (remove n s) - -let nn = 10000 - -let run_all () = - BU.print_string "data tests\n"; - let (f, ms) = BU.record_time (fun () -> insert nn (empty () <: FlatSet.t int)) in - BU.print1 "FlatSet insert: %s\n" (show ms); - let (f_ok, ms) = BU.record_time (fun () -> all_mem nn f) in - BU.print1 "FlatSet all_mem: %s\n" (show ms); - let (f, ms) = BU.record_time (fun () -> all_remove nn f) in - BU.print1 "FlatSet all_remove: %s\n" (show ms); - - if not f_ok then failwith "FlatSet all_mem failed"; - if not (is_empty f) then failwith "FlatSet all_remove failed"; - - let (rb, ms) = BU.record_time (fun () -> insert nn (empty () <: RBSet.t int)) in - BU.print1 "RBSet insert: %s\n" (show ms); - let (rb_ok, ms) = BU.record_time (fun () -> all_mem nn rb) in - BU.print1 "RBSet all_mem: %s\n" (show ms); - let (rb, ms) = BU.record_time (fun () -> all_remove nn rb) in - BU.print1 "RBSet all_remove: %s\n" (show ms); - - if not rb_ok then failwith "RBSet all_mem failed"; - if not (is_empty rb) then failwith "RBSet all_remove failed"; - () diff --git a/src/tests/FStar.Tests.Norm.fst b/src/tests/FStar.Tests.Norm.fst deleted file mode 100644 index 83d5b36bfde..00000000000 --- a/src/tests/FStar.Tests.Norm.fst +++ /dev/null @@ -1,386 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Tests.Norm -//Normalization tests - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Pervasives -open FStar.Syntax.Syntax -open FStar.Tests.Pars -module S = FStar.Syntax.Syntax -module U = FStar.Syntax.Util -module SS = FStar.Syntax.Subst -module I = FStar.Ident -module P = FStar.Syntax.Print -module Const = FStar.Parser.Const -module BU = FStar.Compiler.Util -module N = FStar.TypeChecker.Normalize -module Env = FStar.TypeChecker.Env -open FStar.Ident -open FStar.Compiler.Range -open FStar.Tests.Util - -open FStar.Class.Show - -let b = mk_binder -let id = pars "fun x -> x" -let apply = pars "fun f x -> f x" -let twice = pars "fun f x -> f (f x)" -let tt = pars "fun x y -> x" -let ff = pars "fun x y -> y" -let z = pars "fun f x -> x" -let one = pars "fun f x -> f x" -let two = pars "fun f x -> f (f x)" -let succ = pars "fun n f x -> f (n f x)" -let pred = pars "fun n f x -> n (fun g h -> h (g f)) (fun y -> x) (fun y -> y)" -let mul = pars "fun m n f -> m (n f)" - - -let rec encode n = - if n = 0 then z - else app succ [encode (n - 1)] -let minus m n = app n [pred; m] -let let_ x e e' : term = app (U.abs [b x] e' None) [e] -let mk_let x e e' : term = - let e' = FStar.Syntax.Subst.subst [NM(x, 0)] e' in - mk (Tm_let {lbs=(false, [{lbname=Inl x; lbunivs=[]; lbtyp=tun; lbdef=e; lbeff=Const.effect_Tot_lid; lbattrs=[];lbpos=dummyRange}]); body=e'}) - dummyRange - -let lid x = lid_of_path ["Test"; x] dummyRange -let znat_l = S.lid_as_fv (lid "Z") (Some Data_ctor) -let snat_l = S.lid_as_fv (lid "S") (Some Data_ctor) -let tm_fv fv = mk (Tm_fvar fv) dummyRange -let znat : term = tm_fv znat_l -let snat s = mk (Tm_app {hd=tm_fv snat_l; args=[as_arg s]}) dummyRange -let pat p = withinfo p dummyRange -let snat_type = tm_fv (S.lid_as_fv (lid "snat") None) -open FStar.Syntax.Subst -module SS=FStar.Syntax.Subst -let mk_match h branches = - let branches = branches |> List.map U.branch in - mk (Tm_match {scrutinee=h; ret_opt=None; brs=branches; rc_opt=None}) dummyRange -let pred_nat s = - let zbranch = pat (Pat_cons(znat_l, None, [])), - None, - znat in - let sbranch = pat (Pat_cons(snat_l, None, [pat (Pat_var x), false])), - None, - mk (Tm_bvar({x with index=0})) dummyRange in - mk_match s [zbranch;sbranch] -let minus_nat t1 t2 = - let minus = m in - let x = { x with sort = snat_type } in - let y = { y with sort = snat_type } in - let zbranch = pat (Pat_cons(znat_l, None, [])), - None, - nm x in - let sbranch = pat (Pat_cons(snat_l, None, [pat (Pat_var n), false])), - None, - app (nm minus) [pred_nat (nm x); nm n] in - let lb = {lbname=Inl minus; lbeff=lid_of_path ["Pure"] dummyRange; lbunivs=[]; lbtyp=tun; - lbdef=subst [NM(minus, 0)] (U.abs [b x; b y] (mk_match (nm y) [zbranch; sbranch]) None); - lbattrs=[]; lbpos=dummyRange} in - mk (Tm_let {lbs=(true, [lb]); body= subst [NM(minus, 0)] (app (nm minus) [t1; t2])}) dummyRange -let encode_nat n = - let rec aux out n = - if n=0 then out - else aux (snat out) (n - 1) in - aux znat n - -let default_tests = - let _ = Pars.pars_and_tc_fragment "let rec copy (x:list int) : Tot (list int) = \ - match x with \ - | [] -> [] \ - | hd::tl -> hd::copy tl" in - let _ = Pars.pars_and_tc_fragment "let recons (x:list 'a) : Tot (list 'a) = \ - match x with \ - | [] -> [] \ - | hd::tl -> hd::tl" in - let _ = Pars.pars_and_tc_fragment "let rev (x:list 'a) : Tot (list 'a) = \ - let rec aux (x:list 'a) (out:list 'a) : Tot (list 'a) = \ - match x with \ - | [] -> out \ - | hd::tl -> aux tl (hd::out) in \ - aux x []" in - let _ = Pars.pars_and_tc_fragment "type t = \ - | A : int -> int -> t \ - | B : int -> int -> t \ - let f = function \ - | A x y \ - | B y x -> y - x" in - let _ = Pars.pars_and_tc_fragment "type snat = | Z | S : snat -> snat" in - let _ = Pars.pars_and_tc_fragment "type tb = | T | F" in - let _ = Pars.pars_and_tc_fragment "type rb = | A1 | A2 | A3" in - let _ = Pars.pars_and_tc_fragment "type hb = | H : tb -> hb" in - let _ = Pars.pars_and_tc_fragment "let select (i:tb) (x:'a) (y:'a) : Tot 'a = \ - match i with \ - | T -> x \ - | F -> y" in - let _ = Pars.pars_and_tc_fragment "let select_int3 (i:int) (x:'a) (y:'a) (z:'a) : Tot 'a = \ - match i with \ - | 0 -> x \ - | 1 -> y \ - | _ -> z" in - let _ = Pars.pars_and_tc_fragment "let select_bool (b:bool) (x:'a) (y:'a) : Tot 'a = \ - if b then x else y" in - let _ = Pars.pars_and_tc_fragment "let select_string3 (s:string) (x:'a) (y:'a) (z:'a) : Tot 'a = \ - match s with \ - | \"abc\" -> x \ - | \"def\" -> y \ - | _ -> z" in - let _ = Pars.pars_and_tc_fragment "let recons_m (x:list tb) = \ - match x with \ - | [] -> [] \ - | hd::tl -> hd::tl" in - let _ = Pars.pars_and_tc_fragment "let rec copy_tb_list_2 (x:list tb) : Tot (list tb) = \ - match x with \ - | [] -> [] \ - | [hd] -> [hd] - | hd1::hd2::tl -> hd1::hd2::copy_tb_list_2 tl" in - let _ = Pars.pars_and_tc_fragment "let rec copy_list_2 (x:list 'a) : Tot (list 'a) = \ - match x with \ - | [] -> [] \ - | [hd] -> [hd] - | hd1::hd2::tl -> hd1::hd2::copy_list_2 tl" in - let _ = Pars.pars_and_tc_fragment "let (x1:int{x1>3}) = 6" in - let _ = Pars.pars_and_tc_fragment "let (x2:int{x2+1>3 /\ not (x2-5>0)}) = 2" in - let _ = Pars.pars_and_tc_fragment "let my_plus (x:int) (y:int) = x + y" in - let _ = Pars.pars_and_tc_fragment "let (x3:int{forall (a:nat). a > x2}) = 7" in - - let _ = Pars.pars_and_tc_fragment "let idd (x: 'a) = x" in - let _ = Pars.pars_and_tc_fragment "let revtb (x: tb) = match x with | T -> F | F -> T" in - let _ = Pars.pars_and_tc_fragment "let id_tb (x: tb) = x" in - let _ = Pars.pars_and_tc_fragment "let fst_a (x: 'a) (y: 'a) = x" in - let _ = Pars.pars_and_tc_fragment "let id_list (x: list 'a) = x" in - let _ = Pars.pars_and_tc_fragment "let id_list_m (x: list tb) = x" in //same as recons_m, but no pattern matching - [ (0, (app apply [one; id; nm n]), (nm n)) - ; (1, (app id [nm x]), (nm x)) - ; (1, (app apply [tt; nm n; nm m]), (nm n)) - ; (2, (app apply [ff; nm n; nm m]), (nm m)) - ; (3, (app apply [apply; apply; apply; apply; apply; ff; nm n; nm m]), (nm m)) - ; (4, (app twice [apply; ff; nm n; nm m]), (nm m)) - ; (5, (minus one z), one) - ; (6, (app pred [one]), z) - ; (7, (minus one one), z) - ; (8, (app mul [one; one]), one) - ; (9, (app mul [two; one]), two) - ; (10, (app mul [app succ [one]; one]), two) - ; (11, (minus (encode 10) (encode 10)), z) - ; (12, (minus (encode 100) (encode 100)), z) - ; (13, (let_ x (encode 100) (minus (nm x) (nm x))), z) - - // ; (14, (let_ x (encode 1000) (minus (nm x) (nm x))), z) //takes ~10s; wasteful for CI - ; (15, (let_ x (app succ [one]) - (let_ y (app mul [nm x; nm x]) - (let_ h (app mul [nm y; nm y]) - (minus (nm h) (nm h))))), z) - ; (16, (mk_let x (app succ [one]) - (mk_let y (app mul [nm x; nm x]) - (mk_let h (app mul [nm y; nm y]) - (minus (nm h) (nm h))))), z) - ; (17, (let_ x (app succ [one]) - (let_ y (app mul [nm x; nm x]) - (let_ h (app mul [nm y; nm y]) - (minus (nm h) (nm h))))), z) - ; (18, (pred_nat (snat (snat znat))), (snat znat)) - ; (19, tc_term (minus_nat (snat (snat znat)) (snat znat)), (snat znat)) // requires local recdef - ; (20, tc_term (minus_nat (encode_nat 10) (encode_nat 10)), znat) - ; (21, tc_term (minus_nat (encode_nat 100) (encode_nat 100)), znat) - // ; (22, tc_term (minus_nat (encode_nat 10000) (encode_nat 10000)), znat) // Stack overflow in Normalizer when run with mono - // ; (23, tc_term (minus_nat (encode_nat 1000000) (encode_nat 1000000)), znat) //this one takes about 30 sec and ~3.5GB of memory. Stack overflow in NBE when run with mono - ; (24, (tc "recons [0;1]"), (tc "[0;1]")) - ; (241, (tc "recons [false;true;false]"), (tc "[false;true;false]")) - ; (25, (tc "copy [0;1]"), (tc "[0;1]")) - ; (26, (tc "rev [0;1;2;3;4;5;6;7;8;9;10]"), (tc "[10;9;8;7;6;5;4;3;2;1;0]")) - // Type defs not yet implemented for NBE - // ; (271, (tc "(FStar.String.substring \"abcdef\" 1 2)"), (tc "\"bc\"")) //VD: Not sure why, but this test fails on the normalizer - // ; (27, (tc "(rev (FStar.String.list_of_string \"abcd\"))"), (tc "['d'; 'c'; 'b'; 'a']"))// -- CH: works up to an unfolding too much (char -> char') - ; (28, (tc "(fun x y z q -> z) T T F T"), (tc "F")) - ; (29, (tc "[T; F]"), (tc "[T; F]")) - ; (31, (tc "id_tb T"), (tc "T")) - ; (32, (tc "(fun #a x -> x) #tb T"), (tc "T")) - ; (33, (tc "revtb T"), (tc "F")) - ; (34, (tc "(fun x y -> x) T F"), (tc "T")) - ; (35, (tc "fst_a T F"), (tc "T")) - ; (36, (tc "idd T"), (tc "T")) - ; (301, (tc "id_list [T]"), (tc "[T]")) - ; (3012, (tc "id_list_m [T]"), (tc "[T]")) - ; (302, (tc "recons_m [T; F]"), (tc "[T; F]")) - ; (303, (tc "select T A1 A3"), (tc "A1")) - ; (3031, (tc "select T 3 4"), (tc "3")) - ; (3032, (tc "select_bool false 3 4"), (tc "4")) - ; (3033, (tc "select_int3 1 7 8 9"), (tc "8")) - ; (3034, (tc "[5]"), (tc "[5]")) - ; (3035, (tc "[\"abcd\"]"), (tc "[\"abcd\"]")) - ; (3036, (tc "select_string3 \"def\" 5 6 7"), (tc "6")) - //; (3037, (tc "['c']"), (tc "['c']")) //VD: Fails unless FStar.Char is imported (see FStar.Tests.Pars) - ; (305, (tc "idd T"), (tc "T")) - ; (306, (tc "recons [T]"), (tc "[T]")) - ; (307, (tc "copy_tb_list_2 [T;F;T;F;T;F;F]"), (tc "[T;F;T;F;T;F;F]")) - ; (308, (tc "copy_list_2 [T;F;T;F;T;F;F]"), (tc "[T;F;T;F;T;F;F]")) - - ; (304, (tc "rev [T; F; F]"), (tc "[F; F; T]")) - ; (305, (tc "rev [[T]; [F; T]]"), (tc "[[F; T]; [T]]")) - - ; (309, (tc "x1"), (tc "6")) - ; (310, (tc "x2"), (tc "2")) - //; (311, (tc "x3"), (tc "7")) // Throws parsing exceptiomn - - // Tests for primops - ; (401, (tc "7 + 3"), (tc "10")) - ; (402, (tc "true && false"), (tc "false")) - ; (403, (tc "3 = 5"), (tc "false")) - ; (404, (tc "\"abc\" ^ \"def\""), (tc "\"abcdef\"")) - ; (405, (tc "(fun (x:list int) -> match x with | [] -> 0 | hd::tl -> 1) []"), (tc "0")) - - // Test for refinements - // ; (501, (tc "fun (x1:int{x1>(3+1)}) -> x1 + (1 + 0)"), (tc "fun (x1:int{x1>4}) -> x1 + 1")) // ZP : Fails because the two functions are not syntactically equal - // ; (502, (tc "x1:int{x1>(3+1)}"), (tc "x1:int{x1>4}")) - ] - - -let run_either i r expected normalizer = -// force_term r; - BU.print1 "%s: ... \n\n" (BU.string_of_int i); - let tcenv = Pars.init() in - FStar.Main.process_args() |> ignore; //set the command line args for debugging - let x = normalizer tcenv r in - Options.init(); //reset them - Options.set_option "print_universes" (Options.Bool true); - Options.set_option "print_implicits" (Options.Bool true); - Options.set_option "ugly" (Options.Bool true); - Options.set_option "print_bound_var_types" (Options.Bool true); - // ignore (Options.set_options "--debug Test --debug univ_norm,NBE"); - always i (term_eq (U.unascribe x) expected) - -let run_whnf i r expected = - let open Env in - let steps = - [ Primops; - Weak; - HNF; - UnfoldUntil delta_constant ] - in - run_either i r expected (N.normalize steps) - -let run_interpreter i r expected = run_either i r expected (N.normalize [Env.Beta; Env.UnfoldUntil delta_constant; Env.Primops]) -let run_nbe i r expected = run_either i r expected (FStar.TypeChecker.NBE.normalize_for_unit_test [FStar.TypeChecker.Env.UnfoldUntil delta_constant]) -let run_interpreter_with_time i r expected = - let interp () = run_interpreter i r expected in - (i, snd (FStar.Compiler.Util.return_execution_time interp)) - -let run_whnf_with_time i r expected = - let whnf () = run_whnf i r expected in - (i, snd (FStar.Compiler.Util.return_execution_time whnf)) - -let run_nbe_with_time i r expected = - let nbe () = run_nbe i r expected in - (i, snd (FStar.Compiler.Util.return_execution_time nbe)) - -let run_tests tests run = - Options.__set_unit_tests(); - let l = List.map (function (no, test, res) -> run no test res) tests in - Options.__clear_unit_tests(); - l - -let whnf_tests = - let _ = Pars.pars_and_tc_fragment "assume val def : Type0" in - let _ = Pars.pars_and_tc_fragment "assume val pred : Type0" in - let _ = Pars.pars_and_tc_fragment "let def0 (y:int) = def" in - let _ = Pars.pars_and_tc_fragment "unfold let def1 (y:int) = x:def0 y { pred }" in - let def_def1 = tc "x:def0 17 { pred }" in - let def_def1_unfolded = tc "x:def { pred }" in - // let tests = //We should expect this ... for 602 - // [(601, tc "def1 17", def_def1); - // (602, def_def1, def_def1)] - // in - let tests = //but the current behavior is this - //if we can fix the normalizer, we should change test 602 - [(601, tc "def1 17", def_def1); - (602, def_def1, def_def1_unfolded)] - in - tests - -let run_all_whnf () = - BU.print_string "Testing Normlizer WHNF\n"; - let _ = run_tests whnf_tests run_whnf in - BU.print_string "Normalizer WHNF ok\n" - -let run_all_nbe () = - BU.print_string "Testing NBE\n"; - let _ = run_tests default_tests run_nbe in - BU.print_string "NBE ok\n" - -let run_all_interpreter () = - BU.print_string "Testing the normalizer\n"; - let _ = run_tests default_tests run_interpreter in - BU.print_string "Normalizer ok\n" - -let run_all_whnf_with_time () = - BU.print_string "Testing WHNF\n"; - let l = run_tests whnf_tests run_whnf_with_time in - BU.print_string "WHNF ok\n"; - l - -let run_all_nbe_with_time () = - BU.print_string "Testing NBE\n"; - let l = run_tests default_tests run_nbe_with_time in - BU.print_string "NBE ok\n"; - l - -let run_all_interpreter_with_time () = - BU.print_string "Testing the normalizer\n"; - let l = run_tests default_tests run_interpreter_with_time in - BU.print_string "Normalizer ok\n"; - l - - -// old compare -let run_both_with_time i r expected = - let nbe () = run_nbe i r expected in - let norm () = run_interpreter i r expected in - FStar.Compiler.Util.measure_execution_time "nbe" nbe; - BU.print_string "\n"; - FStar.Compiler.Util.measure_execution_time "normalizer" norm; - BU.print_string "\n" - -let compare () = - BU.print_string "Comparing times for normalization and nbe\n"; - run_both_with_time 14 (let_ x (encode 1000) (minus (nm x) (nm x))) z - -let compare_times l_int l_nbe = - BU.print_string "Comparing times for normalization and nbe\n"; - List.iter2 (fun res1 res2 -> - let (t1, time_int) = res1 in - let (t2, time_nbe) = res2 in - if (t1 = t2) // sanity check - then - BU.print3 "Test %s\nNBE %s\nInterpreter %s\n" - (BU.string_of_int t1) - (BU.string_of_float time_nbe) - (BU.string_of_float time_int) - else - BU.print_string "Test numbers do not match...\n" - ) l_int l_nbe - -let run_all () = - BU.print1 "%s" (show znat); - let _ = run_all_whnf_with_time () in - let l_int = run_all_interpreter_with_time () in - let l_nbe = run_all_nbe_with_time () in - compare_times l_int l_nbe diff --git a/src/tests/FStar.Tests.Pars.fst b/src/tests/FStar.Tests.Pars.fst deleted file mode 100644 index f9674aa2768..00000000000 --- a/src/tests/FStar.Tests.Pars.fst +++ /dev/null @@ -1,335 +0,0 @@ -(* - Copyright 2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Tests.Pars -open FStar -open FStar.Compiler -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.Range -open FStar.Parser -open FStar.Compiler.Util -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.Errors -open FStar.TypeChecker.Env -open FStar.Parser.ParseIt -module DsEnv = FStar.Syntax.DsEnv -module TcEnv = FStar.TypeChecker.Env -module SMT = FStar.SMTEncoding.Solver -module Tc = FStar.TypeChecker.Tc -module TcTerm = FStar.TypeChecker.TcTerm -module ToSyntax = FStar.ToSyntax.ToSyntax -module BU = FStar.Compiler.Util -module D = FStar.Parser.Driver -module Rel = FStar.TypeChecker.Rel -module NBE = FStar.TypeChecker.NBE - -let test_lid = Ident.lid_of_path ["Test"] Range.dummyRange -let tcenv_ref: ref (option TcEnv.env) = mk_ref None -let test_mod_ref = mk_ref (Some ({name=test_lid; - declarations=[]; - is_interface=false})) - -let parse_mod mod_name dsenv = - match parse None (Filename mod_name) with - | ASTFragment (Inl m, _) -> - let m, env'= ToSyntax.ast_modul_to_modul m dsenv in - let env' , _ = DsEnv.prepare_module_or_interface false false env' (FStar.Ident.lid_of_path ["Test"] (FStar.Compiler.Range.dummyRange)) DsEnv.default_mii in - env', m - | ParseError (err, msg, r) -> - raise (Error(err, msg, r, [])) - | ASTFragment (Inr _, _) -> - let msg = BU.format1 "%s: expected a module\n" mod_name in - raise_error0 Errors.Fatal_ModuleExpected msg - | Term _ -> - failwith "Impossible: parsing a Filename always results in an ASTFragment" - -let add_mods mod_names dsenv env = - List.fold_left (fun (dsenv,env) mod_name -> - let dsenv, string_mod = parse_mod mod_name dsenv in - let _mod, env = Tc.check_module env string_mod false in - (dsenv, env) - ) (dsenv,env) mod_names - -let init_once () : unit = - let solver = SMT.dummy in - let env = TcEnv.initial_env - FStar.Parser.Dep.empty_deps - TcTerm.tc_term - TcTerm.typeof_tot_or_gtot_term - TcTerm.typeof_tot_or_gtot_term_fastpath - TcTerm.universe_of - Rel.teq_nosmt_force - Rel.subtype_nosmt_force - solver - Const.prims_lid - NBE.normalize_for_unit_test - FStar.Universal.core_check - in - env.solver.init env; - let dsenv, prims_mod = parse_mod (Basefiles.prims()) (DsEnv.empty_env FStar.Parser.Dep.empty_deps) in - let env = {env with dsenv=dsenv} in - let _prims_mod, env = Tc.check_module env prims_mod false in - // needed to run tests with chars - // let dsenv, env = add_mods ["FStar.Pervasives.Native.fst"; "FStar.Pervasives.fst"; "FStar.Mul.fst"; "FStar.Squash.fsti"; - // "FStar.Classical.fst"; "FStar.Compiler.List.Tot.Base.fst"; "FStar.Compiler.List.Tot.Properties.fst"; "FStar.Compiler.List.Tot.fst"; - // "FStar.StrongExcludedMiddle.fst"; "FStar.Seq.Base.fst"; "FStar.Seq.Properties.fst"; "FStar.Seq.fst"; - // "FStar.BitVector.fst"; "FStar.Math.Lib.fst"; "FStar.Math.Lemmas.fst"; "FStar.UInt.fst"; "FStar.UInt32.fst"; - // "FStar.Char.fsti"; "FStar.String.fsti"] dsenv env in - - // only needed to test tatic normalization - // let dsenv, env = add_mods ["FStar.Compiler.Range.fsti"; "FStar.Pervasives.Native.fst"; "FStar.Pervasives.fst"; "FStar.Reflection.Types.fsti"; "FStar.Order.fst"; - // "FStar.Reflection.Data.fst"; "FStar.Reflection.Basic.fst"; "FStar.Squash.fsti"; "FStar.Classical.fst"; - // "FStar.Compiler.List.Tot.Base.fst"; "FStar.Compiler.List.Tot.Properties.fst"; "FStar.Compiler.List.Tot.fst"; "FStar.Char.fsti"; - // "FStar.String.fsti"; "FStar.Reflection.Syntax.fst"; "FStar.Reflection.Syntax.Lemmas.fst"; - // "FStar.Reflection.Formula.fst"; "FStar.Tactics.Types.fsti"; "FStar.Tactics.Result.fst"; - // "FStar.Tactics.Effect.fst"; "FStar.Tactics.Builtins.fst"; "FStar.Tactics.Derived.fst"; - // "FStar.Tactics.Logic.fst"; "FStar.Tactics.fst"] dsenv env in - - - let env = {env with dsenv=dsenv} in (* VD: need to propagate add_mods to the dsenv in env *) - - let env = TcEnv.set_current_module env test_lid in - tcenv_ref := Some env - -let _ = - FStar.Main.setup_hooks(); - init_once() - -let init () = - match !tcenv_ref with - | Some f -> f - | _ -> - failwith "Should have already been initialized by the top-level effect" - -let frag_of_text s = {frag_fname=" input"; frag_text=s; frag_line=1; frag_col=0} - -let pars s = - try - let tcenv = init() in - match parse None (Fragment <| frag_of_text s) with - | Term t -> - ToSyntax.desugar_term tcenv.dsenv t - | ParseError (e, msg, r) -> - raise_error r e msg - | ASTFragment _ -> - failwith "Impossible: parsing a Fragment always results in a Term" - with - | Error(err, msg, r, _ctx) when not <| FStar.Options.trace_error() -> - if r = FStar.Compiler.Range.dummyRange - then BU.print_string (Errors.rendermsg msg) - else BU.print2 "%s: %s\n" (FStar.Compiler.Range.string_of_range r) (Errors.rendermsg msg); - exit 1 - - | e when not ((Options.trace_error())) -> raise e - -let tc' s = - let tm = pars s in - let tcenv = init() in - (* We set phase1=true to allow the typechecker to insert - coercions. *) - let tcenv = {tcenv with phase1=true; top_level=false} in - let tm, _, g = TcTerm.tc_tot_or_gtot_term tcenv tm in - Rel.force_trivial_guard tcenv g; - let tm = FStar.Syntax.Compress.deep_compress false false tm in - tm, tcenv - -let tc s = - let tm, _ = tc' s in - tm - -let tc_term tm = - let tcenv = init() in - let tcenv = {tcenv with top_level=false} in - let tm, _, g = TcTerm.tc_tot_or_gtot_term tcenv tm in - Rel.force_trivial_guard tcenv g; - let tm = FStar.Syntax.Compress.deep_compress false false tm in - tm - -let pars_and_tc_fragment (s:string) = - Options.set_option "trace_error" (Options.Bool true); - let report () = FStar.Errors.report_all () |> ignore in - try - let tcenv = init() in - let frag = frag_of_text s in - try - let test_mod', tcenv', _ = FStar.Universal.tc_one_fragment !test_mod_ref tcenv (Inl (frag, [])) in - test_mod_ref := test_mod'; - tcenv_ref := Some tcenv'; - let n = get_err_count () in - if n <> 0 - then (report (); - raise_error0 Errors.Fatal_ErrorsReported (BU.format1 "%s errors were reported" (string_of_int n))) - with e -> report(); raise_error0 Errors.Fatal_TcOneFragmentFailed ("tc_one_fragment failed: " ^s) - with - | e when not ((Options.trace_error())) -> raise e - -let test_hashes () = - FStar.Main.process_args () |> ignore; //set options - let _ = pars_and_tc_fragment "type unary_nat = | U0 | US of unary_nat" in - let test_one_hash (n:int) = - let rec aux n = - if n = 0 then "U0" - else "(US " ^ aux (n - 1) ^ ")" - in - let tm = tc (aux n) in - let hc = FStar.Syntax.Hash.ext_hash_term tm in - BU.print2 "Hash of unary %s is %s\n" - (string_of_int n) - (FStar.Hash.string_of_hash_code hc) - in - let rec aux (n:int) = - if n = 0 then () - else (test_one_hash n; aux (n - 1)) - in - aux 100; - Options.init() - - -let parse_incremental_decls () = - let source0 = - "module Demo\n\ - let f x = match x with | Some x -> true | None -> false\n\ - let test y = if Some? y then f y else true\n\ - ```pulse\n\ - fn f() {}\n\ - ```\n\ - ```pulse\n\ - fn g() {}\n\ - ```\n\ - let something = more\n\ - let >< junk" - in - let source1 = - "module Demo\n\ - let f x = match x with | Some x -> true | None -> false\n\ - let test y = if Some? y then f y else true\n\ - ```pulse\n\ - fn f() {}\n\ - ```\n\n\ - ```pulse\n\ - fn g() {}\n\ - ```\n\ - let something = more\n\ - let >< junk" - in - - let open FStar.Parser.ParseIt in - let input0 = Incremental { frag_fname = "Demo.fst"; - frag_text = source0; - frag_line = 1; - frag_col = 0 } in - let input1 = Incremental { frag_fname = "Demo.fst"; - frag_text = source1; - frag_line = 1; - frag_col = 0 } in - let open FStar.Compiler.Range in - match parse None input0, parse None input1 with - | IncrementalFragment (decls0, _, parse_err0), - IncrementalFragment (decls1, _, parse_err1) -> ( - let check_range r l c = - let p = start_of_range r in - if line_of_pos p = l && col_of_pos p = c - then () - else failwith (format4 "Incremental parsing failed: Expected syntax error at (%s, %s), got error at (%s, %s)" - (string_of_int l) - (string_of_int c) - (string_of_int (line_of_pos p)) - (string_of_int (col_of_pos p))) - in - let _ = - match parse_err0, parse_err1 with - | None, _ -> - failwith "Incremental parsing failed: Expected syntax error at (8, 6), got no error" - | _, None -> - failwith "Incremental parsing failed: Expected syntax error at (9, 6), got no error" - | Some (_, _, rng0), Some (_, _, rng1) -> - check_range rng0 11 6; - check_range rng1 12 6 - in - match decls0, decls1 with - | [d0;d1;d2;d3;d4;d5], - [e0;e1;e2;e3;e4;e5] -> - let open FStar.Parser.AST.Util in - if List.forall2 (fun (x, _) (y, _) -> eq_decl x y) decls0 decls1 - then () - else ( - failwith ("Incremental parsing failed; unexpected change in a decl") - ) - | _ -> failwith (format2 "Incremental parsing failed; expected 6 decls got %s and %s\n" - (string_of_int (List.length decls0)) - (string_of_int (List.length decls1))) - ) - - - | ParseError (code, message, range), _ - | _, ParseError (code, message, range) -> - let msg = - format2 "Incremental parsing failed: Syntax error @ %s: %s" - (Range.string_of_range range) - (Errors.rendermsg message) // FIXME - in - failwith msg - - | _ -> - failwith "Incremental parsing failed: Unexpected output" - - -open FStar.Class.Show - -let parse_incremental_decls_use_lang () = - let source0 = - "module Demo\n\ - let x = 0\n\ - #lang-somelang\n\ - val f : t\n\ - let g x = f x\n\ - #restart-solver" - in - FStar.Parser.AST.Util.register_extension_lang_parser "somelang" FStar.Parser.ParseIt.parse_fstar_incrementally; - let open FStar.Parser.ParseIt in - let input0 = Incremental { frag_fname = "Demo.fst"; - frag_text = source0; - frag_line = 1; - frag_col = 0 } in - let open FStar.Compiler.Range in - match parse None input0 with - | IncrementalFragment (decls0, _, parse_err0) -> ( - let _ = - match parse_err0 with - | None -> () - | Some _ -> - failwith "Incremental parsing failed: ..." - in - let open FStar.Parser.AST in - let ds = List.map fst decls0 in - match ds with - | [{d=TopLevelModule _}; {d=TopLevelLet _}; {d=UseLangDecls _}; {d=Val _}; {d=TopLevelLet _}; {d=Pragma _}] -> () - | _ -> - failwith ("Incremental parsing failed; unexpected decls: " ^ show ds) - ) - - - | ParseError (code, message, range) -> - let msg = - format2 "Incremental parsing failed: Syntax error @ %s: %s" - (Range.string_of_range range) - (Errors.rendermsg message) // FIXME - in - failwith msg - - | _ -> - failwith "Incremental parsing failed: Unexpected output" diff --git a/src/tests/FStar.Tests.Test.fst b/src/tests/FStar.Tests.Test.fst deleted file mode 100644 index 2d7ab17daeb..00000000000 --- a/src/tests/FStar.Tests.Test.fst +++ /dev/null @@ -1,61 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Tests.Test -open FStar.Compiler.Effect -open FStar.Syntax -open FStar.Errors -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module U = FStar.Syntax.Util -module BU = FStar.Compiler.Util -module O = FStar.Options -module G = FStar.Getopt - -let main argv = - BU.print_string "Initializing tests...\n"; - try - let res, fs = O.parse_cmd_line () in - match res with - | G.Help -> - BU.print_string "F* unit tests. This binary can take the same options \ - as F*, but not all of them are meaningful."; - exit 0 - | G.Error msg -> - BU.print_error msg; exit 1 - | G.Empty - | G.Success -> - FStar.Main.setup_hooks(); - Pars.init() |> ignore; - Pars.parse_incremental_decls(); - Pars.parse_incremental_decls_use_lang (); - Norm.run_all (); - if Unif.run_all () then () else exit 1; - Data.run_all (); - - FStar.Errors.report_all () |> ignore; - let nerrs = FStar.Errors.get_err_count() in - if nerrs > 0 then - exit 1; - exit 0 - with - | Error(err, msg, r, _ctx) when not <| O.trace_error() -> - if r = FStar.Compiler.Range.dummyRange - then BU.print_string (Errors.rendermsg msg) - else BU.print2 "%s: %s\n" (FStar.Compiler.Range.string_of_range r) (Errors.rendermsg msg); - exit 1 - | e -> - BU.print2_error "Error\n%s\n%s\n" (BU.message_of_exn e) (BU.trace_of_exn e); - exit 1 diff --git a/src/tests/FStar.Tests.Unif.fst b/src/tests/FStar.Tests.Unif.fst deleted file mode 100644 index 8c235325ab9..00000000000 --- a/src/tests/FStar.Tests.Unif.fst +++ /dev/null @@ -1,335 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Tests.Unif -//Unification tests -//open FSharp.Compatibility.OCaml -open FStar open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Errors -open FStar.Compiler.Util -open FStar.Syntax.Syntax -open FStar.Tests.Pars -module S = FStar.Syntax.Syntax -module U = FStar.Syntax.Util -module SS = FStar.Syntax.Subst -module I = FStar.Ident -module P = FStar.Syntax.Print -module N = FStar.TypeChecker.Normalize -module Rel = FStar.TypeChecker.Rel -module Env = FStar.TypeChecker.Env -module BU = FStar.Compiler.Util -open FStar.TypeChecker.Common -open FStar.TypeChecker.Env -open FStar.Ident -open FStar.Compiler.Range -open FStar.Tests.Util - -open FStar.Class.Show - -let tcenv () = Pars.init() - -let guard_to_string g = match g with - | Trivial -> "trivial" - | NonTrivial f -> - N.term_to_string (tcenv()) f - -let success = BU.mk_ref true - -let fail msg = - BU.print_string msg; - success := false - -let guard_eq i g g' = - let b, g, g' = match g, g' with - | Trivial, Trivial -> true, g, g' - | NonTrivial f, NonTrivial f' -> - let f = N.normalize [Env.EraseUniverses] (tcenv()) f in - let f' = N.normalize [Env.EraseUniverses] (tcenv()) f' in - term_eq f f', NonTrivial f, NonTrivial f' - | _ -> false, g, g' in - if not b - then fail <| BU.format3 "Test %s failed:\n\t\ - Expected guard %s;\n\t\ - Got guard %s\n" (BU.string_of_int i) (guard_to_string g') (guard_to_string g); - success := !success && b - -let unify i bvs x y g' check = - BU.print1 "%s ..." (BU.string_of_int i); - FStar.Main.process_args () |> ignore; //set options - BU.print2 "Unify %s\nand %s\n" (show x) (show y); - let tcenv = tcenv() in - let tcenv = Env.push_bvs tcenv bvs in - let g = Rel.teq tcenv x y |> Rel.solve_deferred_constraints tcenv |> Rel.simplify_guard tcenv in - guard_eq i g.guard_f g'; - check(); - Options.init() //reset them; exceptions are fatal, so don't worry about resetting them in case guard_eq fails - -let should_fail x y = - try - let g = Rel.teq (tcenv()) x y |> Rel.solve_deferred_constraints (tcenv()) in - match g.guard_f with - | Trivial -> fail (BU.format2 "%s and %s should not be unifiable\n" (show x) (show y)) - | NonTrivial f -> BU.print3 "%s and %s are unifiable if %s\n" (show x) (show y) (show f) - with Error(e, msg, r, _ctx) -> BU.print1 "%s\n" (Errors.rendermsg msg) // FIXME? - -let unify' x y = - let x = pars x in - let y = pars y in - let g = Rel.teq (tcenv()) x y |> Rel.solve_deferred_constraints (tcenv()) in - BU.print3 "%s and %s are unifiable with guard %s\n" (show x) (show y) (guard_to_string g.guard_f) - -let norm t = N.normalize [] (tcenv()) t - -let check_core i subtyping guard_ok x y = - FStar.Main.process_args () |> ignore; //set options - let env = tcenv () in - let res = - if subtyping - then FStar.TypeChecker.Core.check_term_subtyping true true env x y - else FStar.TypeChecker.Core.check_term_equality true true env x y - in - let _ = - match res with - | Inl None -> - BU.print1 "%s core check ok\n" (BU.string_of_int i) - | Inl (Some g) -> - BU.print2 "%s core check computed guard %s ok\n" (BU.string_of_int i) (show g); - if not guard_ok - then success := false - | Inr err -> - success := false; - BU.print2 "%s failed\n%s\n" (BU.string_of_int i) (FStar.TypeChecker.Core.print_error err) - in - Options.init() - -let check_core_typing i e t = - FStar.Main.process_args () |> ignore; //set options - let env = tcenv () in - let _ = - match FStar.TypeChecker.Core.check_term env e t true with - | Inl None -> - BU.print1 "%s core typing ok\n" (BU.string_of_int i) - | Inl (Some g) -> - BU.print1 "%s core typing produced a guard\n" (BU.string_of_int i); - success := false - | Inr err -> - success := false; - BU.print2 "%s failed\n%s\n" (BU.string_of_int i) (FStar.TypeChecker.Core.print_error err) - in - Options.init() - -let inst n tm = - let rec aux out n = - if n=0 then out - else let t, _, _ = FStar.TypeChecker.Util.new_implicit_var "" dummyRange (init()) U.ktype0 false in - let u, _, _ = FStar.TypeChecker.Util.new_implicit_var "" dummyRange (init()) t false in - aux (u::out) (n - 1) in - let us = aux [] n in - norm (app tm us), us - -let run_all () = - BU.print_string "Testing the unifier\n"; - - Options.__set_unit_tests(); - let unify_check n bvs x y g f = unify n bvs x y g f in - let unify n bvs x y g = unify n bvs x y g (fun () -> ()) in - let int_t = tc "Prims.int" in - let x_bv = S.gen_bv "x" None int_t in - let y_bv = S.gen_bv "y" None int_t in - let x = S.bv_to_name x_bv in - let y = S.bv_to_name y_bv in - - //syntactic equality of names - unify 0 [x_bv] x x Trivial; - - //different names, equal with a guard - unify 1 [x_bv;y_bv] x y (NonTrivial (U.mk_eq2 U_zero U.t_bool x y)); - - //equal after some reduction - let id = tc "fun (x:bool) -> x" in - unify 2 [x_bv] x (app id [x]) Trivial; - - //physical equality of terms - let id = tc "fun (x:bool) -> x" in - unify 3 [] id id Trivial; - - //alpha equivalence - let id = tc "fun (x:bool) -> x" in - let id' = tc "fun (y:bool) -> y" in - unify 4 [] id id' Trivial; //(NonTrivial (pars "True /\ (forall x. True)")); - - //alpha equivalence 2 - unify 5 [] - (tc "fun (x y:bool) -> x") - (tc "fun (a b:bool) -> a") - Trivial; - - //alpha equivalence 3 - unify 6 [] - (tc "fun (x y z:bool) -> y") - (tc "fun (a b c:bool) -> b") - Trivial; - - //logical equality of distinct lambdas (questionable ... would only work for unit, or inconsistent context) - unify 7 [] - (tc "fun (x:int) (y:int) -> y") - (tc "fun (x:int) (y:int) -> x") - (NonTrivial (tc "(forall (x:int). (forall (y:int). y==x))")); - - //logical equality of distinct lambdas (questionable ... would only work for unit, or inconsistent context) - unify 8 [] - (tc "fun (x:int) (y:int) (z:int) -> y") - (tc "fun (x:int) (y:int) (z:int) -> z") - (NonTrivial (tc "(forall (x:int). (forall (y:int). (forall (z:int). y==z)))")); - - //imitation: unifies u to a constant - FStar.Main.process_args () |> ignore; //set options - let tm, us = inst 1 (tc "fun (u:Type0 -> Type0) (x:Type0) -> u x") in - let sol = tc "fun (x:Type0) -> Prims.pair x x" in - unify_check 9 [] tm - sol - Trivial - (fun () -> - always 9 (term_eq (norm (List.hd us)) - (norm sol))); - - //imitation: unifies u to a lambda - let tm, us = inst 1 (tc "fun (u: int -> int -> int) (x:int) -> u x") in - let sol = tc "fun (x y:int) -> x + y" in - unify_check 10 [] tm - sol - Trivial - (fun () ->always 10 (term_eq (norm (List.hd us)) - (norm sol))); - - let tm1 = tc ("x:int -> y:int{eq2 y x} -> bool") in - let tm2 = tc ("x:int -> y:int -> bool") in - unify 11 [] tm1 tm2 - (NonTrivial (tc "forall (x:int). (forall (y:int). y==x)")); - - let tm1 = tc ("a:Type0 -> b:(a -> Type0) -> x:a -> y:b x -> Tot Type0") in - let tm2 = tc ("a:Type0 -> b:(a -> Type0) -> x:a -> y:b x -> Tot Type0") in - unify 12 [] tm1 tm2 - Trivial; - - let tm1, tm2, bvs_13 = - let int_typ = tc "int" in - let x = FStar.Syntax.Syntax.new_bv None int_typ in - - let typ = tc "unit -> Type0" in - let l = tc ("fun (q:(unit -> Type0)) -> q ()") in - let q = FStar.Syntax.Syntax.new_bv None typ in - let tm1 = norm (app l [FStar.Syntax.Syntax.bv_to_name q]) in - - let l = tc ("fun (p:unit -> Type0) -> p") in - let unit = tc "()" in - let env = Env.push_binders (init()) [S.mk_binder x; S.mk_binder q] in - let u_p, _, _ = FStar.TypeChecker.Util.new_implicit_var "" dummyRange env typ false in - let tm2 = app (norm (app l [u_p])) [unit] in - tm1, tm2, [x;q] - in - - unify 13 bvs_13 tm1 tm2 Trivial; - - let tm1, tm2, bvs_14 = - let int_typ = tc "int" in - let x = FStar.Syntax.Syntax.new_bv None int_typ in - - let typ = tc "pure_post unit" in - let l = tc ("fun (q:pure_post unit) -> q ()") in - let q = FStar.Syntax.Syntax.new_bv None typ in - let tm1 = norm (app l [FStar.Syntax.Syntax.bv_to_name q]) in - - let l = tc ("fun (p:pure_post unit) -> p") in - let unit = tc "()" in - let env = Env.push_binders (init()) [S.mk_binder x; S.mk_binder q] in - let u_p, _, _ = FStar.TypeChecker.Util.new_implicit_var "" dummyRange env typ false in - let tm2 = app (norm (app l [u_p])) [unit] in - tm1, tm2, [x;q] - in - - unify 14 bvs_14 tm1 tm2 Trivial; - - let tm1, tm2 = - let _ = Pars.pars_and_tc_fragment - "let ty0 n = x:int { x >= n }\n\ - let ty1 n = x:ty0 n { x > n }\n\ - assume val tc (t:Type0) : Type0" - in - let t0 = tc "ty1 17" in - let t1 = tc "x:ty0 17 { x > 17 }" in - t0, t1 - in - check_core 15 false false tm1 tm2; - - let tm1, tm2 = - let t0 = tc "x:int { x >= 17 /\ x > 17 }" in - let t1 = tc "x:ty0 17 { x > 17 }" in - t0, t1 - in - check_core 16 false false tm1 tm2; - - let tm1, tm2 = - let _ = Pars.pars_and_tc_fragment - "let defn17_0 (x:nat) : nat -> nat -> Type0 = fun y z -> a:int { a + x == y + z }" - in - let t0 = tc "defn17_0 0 1 2" in - let t1_head = tc "(defn17_0 0)" in - let arg1 = tc "1" in - let arg2 = tc "2" in - let t1 = S.mk_Tm_app t1_head [(arg1, None); (arg2, None)] t0.pos in - t0, t1 - in - check_core 17 false false tm1 tm2; - - let tm1, tm2 = - let t0 = tc "dp:((dtuple2 int (fun (y:int) -> z:int{ z > y })) <: Type0) { let (| x, _ |) = dp in x > 17 }" in - let t1 = tc "(dtuple2 int (fun (y:int) -> z:int{ z > y }))" in - t0, t1 - in - check_core 18 true false tm1 tm2; - - let tm1, tm2 = - let _ = Pars.pars_and_tc_fragment - "type vprop' = { t:Type0 ; n:nat }" - in - let t0 = tc "x:(({ t=bool; n=0 }).t <: Type0) { x == false }" in - let t1 = tc "x:bool{ x == false }" in - t0, t1 - in - check_core 19 false false tm1 tm2; - - - let tm1, tm2 = - let t0 = tc "int" in - let t1 = tc "j:(i:nat{ i > 17 } <: Type0){j > 42}" in - t0, t1 - in - check_core 20 true true tm1 tm2; - - let tm, ty = - let _ = Pars.pars_and_tc_fragment "assume val tstr21 (x:string) : Type0" in - let t0 = tc "(fun (x:bool) (y:int) (z: (fun (x:string) -> tstr21 x) \"hello\") -> x)" in - let ty = tc "bool -> int -> tstr21 \"hello\" -> bool" in - t0, ty - in - check_core_typing 21 tm ty; - - Options.__clear_unit_tests(); - - if !success - then BU.print_string "Unifier ok\n"; - !success diff --git a/src/tests/FStar.Tests.Util.fst b/src/tests/FStar.Tests.Util.fst deleted file mode 100644 index 5a01fca30d2..00000000000 --- a/src/tests/FStar.Tests.Util.fst +++ /dev/null @@ -1,128 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.Tests.Util - -open FStar open FStar.Compiler -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Errors -open FStar.Compiler.Util -open FStar.Syntax -open FStar.Syntax.Syntax -module S = FStar.Syntax.Syntax -module U = FStar.Syntax.Util -module SS = FStar.Syntax.Subst -module I = FStar.Ident -module UF = FStar.Syntax.Unionfind -module Const = FStar.Parser.Const -module BU = FStar.Compiler.Util - -open FStar.Ident -open FStar.Compiler.Range -open FStar.Class.Tagged -open FStar.Class.Show -open FStar.Syntax.Print {} - -let always id b = - if b - then () - else raise_error0 Errors.Fatal_AssertionFailure (BU.format1 "Assertion failed: test %s" (BU.string_of_int id)) - -let x = gen_bv "x" None S.tun -let y = gen_bv "y" None S.tun -let n = gen_bv "n" None S.tun -let h = gen_bv "h" None S.tun -let m = gen_bv "m" None S.tun -let tm t = mk t dummyRange -let nm x = bv_to_name x -let app x ts = mk (Tm_app {hd=x; args=List.map as_arg ts}) dummyRange - -let rec term_eq' t1 t2 = - let t1 = SS.compress t1 in - let t2 = SS.compress t2 in - let binders_eq xs ys = - List.length xs = List.length ys - && List.forall2 (fun (x:binder) (y:binder) -> term_eq' x.binder_bv.sort y.binder_bv.sort) xs ys in - let args_eq xs ys = - List.length xs = List.length ys - && List.forall2 (fun (a, imp) (b, imp') -> term_eq' a b && U.eq_aqual imp imp') xs ys in - let comp_eq (c:S.comp) (d:S.comp) = - match c.n, d.n with - | S.Total t, S.Total s -> term_eq' t s - | S.Comp ct1, S.Comp ct2 -> - I.lid_equals ct1.effect_name ct2.effect_name - && term_eq' ct1.result_typ ct2.result_typ - && args_eq ct1.effect_args ct2.effect_args - | _ -> false in - match t1.n, t2.n with - | Tm_lazy l, _ -> term_eq' (must !lazy_chooser l.lkind l) t2 - | _, Tm_lazy l -> term_eq' t1 (must !lazy_chooser l.lkind l) - | Tm_bvar x, Tm_bvar y -> x.index = y.index - | Tm_name x, Tm_name y -> S.bv_eq x y - | Tm_fvar f, Tm_fvar g -> S.fv_eq f g - | Tm_uinst (t, _), Tm_uinst(s, _) -> term_eq' t s - | Tm_constant c1, Tm_constant c2 -> FStar.Const.eq_const c1 c2 - | Tm_type u, Tm_type v -> u=v - | Tm_abs {bs=xs; body=t}, Tm_abs {bs=ys; body=u} when (List.length xs = List.length ys) -> binders_eq xs ys && term_eq' t u - | Tm_abs {bs=xs; body=t}, Tm_abs {bs=ys; body=u} -> - if List.length xs > List.length ys - then let xs, xs' = BU.first_N (List.length ys) xs in - let t1 = mk (Tm_abs {bs=xs; body=mk (Tm_abs {bs=xs'; body=t; rc_opt=None}) t1.pos; rc_opt=None}) t1.pos in - term_eq' t1 t2 - else let ys, ys' = BU.first_N (List.length xs) ys in - let t2 = mk (Tm_abs {bs=ys; body=mk (Tm_abs {bs=ys'; body=u; rc_opt=None}) t2.pos; rc_opt=None}) t2.pos in - term_eq' t1 t2 - | Tm_arrow {bs=xs; comp=c}, Tm_arrow {bs=ys; comp=d} -> binders_eq xs ys && comp_eq c d - | Tm_refine {b=x; phi=t}, Tm_refine {b=y; phi=u} -> term_eq' x.sort y.sort && term_eq' t u - | Tm_app {hd={n=Tm_fvar fv_eq_1}; - args=[(_, Some ({ aqual_implicit = true })); t1; t2]}, - Tm_app {hd={n=Tm_fvar fv_eq_2}; - args=[(_, Some ({ aqual_implicit = true })); s1; s2]} - when S.fv_eq_lid fv_eq_1 Const.eq2_lid - && S.fv_eq_lid fv_eq_2 Const.eq2_lid -> //Unification produces equality applications that may have unconstrainted implicit arguments - args_eq [s1;s2] [t1;t2] - | Tm_app {hd=t; args}, Tm_app {hd=s; args=args'} -> term_eq' t s && args_eq args args' - | Tm_match {scrutinee=t; ret_opt=None; brs=pats}, - Tm_match {scrutinee=t'; ret_opt=None; brs=pats'} -> - List.length pats = List.length pats' - && List.forall2 (fun (_, _, e) (_, _, e') -> term_eq' e e') pats pats' - && term_eq' t t' - | Tm_ascribed {tm=t1; asc=(Inl t2, _, _)}, - Tm_ascribed {tm=s1; asc=(Inl s2, _, _)} -> - term_eq' t1 s1 && term_eq' t2 s2 - | Tm_let {lbs=(is_rec, lbs); body=t}, - Tm_let {lbs=(is_rec',lbs'); body=s} when is_rec=is_rec' -> - List.length lbs = List.length lbs' - && List.forall2 (fun lb1 lb2 -> term_eq' lb1.lbtyp lb2.lbtyp && term_eq' lb1.lbdef lb2.lbdef) lbs lbs' - && term_eq' t s - | Tm_uvar (u,_), Tm_uvar (u',_) -> UF.equiv u.ctx_uvar_head u'.ctx_uvar_head - | Tm_meta {tm=t1}, _ -> term_eq' t1 t2 - | _, Tm_meta {tm=t2} -> term_eq' t1 t2 - - | Tm_delayed _, _ - | _, Tm_delayed _ -> - failwith (BU.format2 "Impossible: %s and %s" (tag_of t1) (tag_of t2)) - - | Tm_unknown, Tm_unknown -> true - | _ -> false - -let term_eq t1 t2 = -// BU.print2 "Comparing %s and\n\t%s\n" (show t1) (show t2); - let b = term_eq' t1 t2 in - if not b then ( - BU.print2 ">>>>>>>>>>>Term %s is not equal to %s\n" (show t1) (show t2) - ); - b diff --git a/src/tests/FStarC.Tests.Data.fst b/src/tests/FStarC.Tests.Data.fst new file mode 100644 index 00000000000..6e2a6853b9f --- /dev/null +++ b/src/tests/FStarC.Tests.Data.fst @@ -0,0 +1,66 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Tests.Data +// tests about data structures + + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +module BU = FStarC.Compiler.Util + +module FlatSet = FStarC.Compiler.FlatSet +module RBSet = FStarC.Compiler.RBSet + +open FStarC.Class.Setlike +open FStarC.Class.Show + +let rec insert (n:int) {| setlike int 'set |} (s : 'set) = + if n = 0 then s + else insert (n-1) (add n s) + +let rec all_mem (n:int) {| setlike int 'set |} (s : 'set) = + if n = 0 then true + else mem n s && all_mem (n-1) s + +let rec all_remove (n:int) {| setlike int 'set |} (s : 'set) = + if n = 0 then s + else all_remove (n-1) (remove n s) + +let nn = 10000 + +let run_all () = + BU.print_string "data tests\n"; + let (f, ms) = BU.record_time (fun () -> insert nn (empty () <: FlatSet.t int)) in + BU.print1 "FlatSet insert: %s\n" (show ms); + let (f_ok, ms) = BU.record_time (fun () -> all_mem nn f) in + BU.print1 "FlatSet all_mem: %s\n" (show ms); + let (f, ms) = BU.record_time (fun () -> all_remove nn f) in + BU.print1 "FlatSet all_remove: %s\n" (show ms); + + if not f_ok then failwith "FlatSet all_mem failed"; + if not (is_empty f) then failwith "FlatSet all_remove failed"; + + let (rb, ms) = BU.record_time (fun () -> insert nn (empty () <: RBSet.t int)) in + BU.print1 "RBSet insert: %s\n" (show ms); + let (rb_ok, ms) = BU.record_time (fun () -> all_mem nn rb) in + BU.print1 "RBSet all_mem: %s\n" (show ms); + let (rb, ms) = BU.record_time (fun () -> all_remove nn rb) in + BU.print1 "RBSet all_remove: %s\n" (show ms); + + if not rb_ok then failwith "RBSet all_mem failed"; + if not (is_empty rb) then failwith "RBSet all_remove failed"; + () diff --git a/src/tests/FStarC.Tests.Norm.fst b/src/tests/FStarC.Tests.Norm.fst new file mode 100644 index 00000000000..5af23a2e591 --- /dev/null +++ b/src/tests/FStarC.Tests.Norm.fst @@ -0,0 +1,386 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Tests.Norm +//Normalization tests + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStar.Pervasives +open FStarC.Syntax.Syntax +open FStarC.Tests.Pars +module S = FStarC.Syntax.Syntax +module U = FStarC.Syntax.Util +module SS = FStarC.Syntax.Subst +module I = FStarC.Ident +module P = FStarC.Syntax.Print +module Const = FStarC.Parser.Const +module BU = FStarC.Compiler.Util +module N = FStarC.TypeChecker.Normalize +module Env = FStarC.TypeChecker.Env +open FStarC.Ident +open FStarC.Compiler.Range +open FStarC.Tests.Util + +open FStarC.Class.Show + +let b = mk_binder +let id = pars "fun x -> x" +let apply = pars "fun f x -> f x" +let twice = pars "fun f x -> f (f x)" +let tt = pars "fun x y -> x" +let ff = pars "fun x y -> y" +let z = pars "fun f x -> x" +let one = pars "fun f x -> f x" +let two = pars "fun f x -> f (f x)" +let succ = pars "fun n f x -> f (n f x)" +let pred = pars "fun n f x -> n (fun g h -> h (g f)) (fun y -> x) (fun y -> y)" +let mul = pars "fun m n f -> m (n f)" + + +let rec encode n = + if n = 0 then z + else app succ [encode (n - 1)] +let minus m n = app n [pred; m] +let let_ x e e' : term = app (U.abs [b x] e' None) [e] +let mk_let x e e' : term = + let e' = FStarC.Syntax.Subst.subst [NM(x, 0)] e' in + mk (Tm_let {lbs=(false, [{lbname=Inl x; lbunivs=[]; lbtyp=tun; lbdef=e; lbeff=Const.effect_Tot_lid; lbattrs=[];lbpos=dummyRange}]); body=e'}) + dummyRange + +let lid x = lid_of_path ["Test"; x] dummyRange +let znat_l = S.lid_as_fv (lid "Z") (Some Data_ctor) +let snat_l = S.lid_as_fv (lid "S") (Some Data_ctor) +let tm_fv fv = mk (Tm_fvar fv) dummyRange +let znat : term = tm_fv znat_l +let snat s = mk (Tm_app {hd=tm_fv snat_l; args=[as_arg s]}) dummyRange +let pat p = withinfo p dummyRange +let snat_type = tm_fv (S.lid_as_fv (lid "snat") None) +open FStarC.Syntax.Subst +module SS=FStarC.Syntax.Subst +let mk_match h branches = + let branches = branches |> List.map U.branch in + mk (Tm_match {scrutinee=h; ret_opt=None; brs=branches; rc_opt=None}) dummyRange +let pred_nat s = + let zbranch = pat (Pat_cons(znat_l, None, [])), + None, + znat in + let sbranch = pat (Pat_cons(snat_l, None, [pat (Pat_var x), false])), + None, + mk (Tm_bvar({x with index=0})) dummyRange in + mk_match s [zbranch;sbranch] +let minus_nat t1 t2 = + let minus = m in + let x = { x with sort = snat_type } in + let y = { y with sort = snat_type } in + let zbranch = pat (Pat_cons(znat_l, None, [])), + None, + nm x in + let sbranch = pat (Pat_cons(snat_l, None, [pat (Pat_var n), false])), + None, + app (nm minus) [pred_nat (nm x); nm n] in + let lb = {lbname=Inl minus; lbeff=lid_of_path ["Pure"] dummyRange; lbunivs=[]; lbtyp=tun; + lbdef=subst [NM(minus, 0)] (U.abs [b x; b y] (mk_match (nm y) [zbranch; sbranch]) None); + lbattrs=[]; lbpos=dummyRange} in + mk (Tm_let {lbs=(true, [lb]); body= subst [NM(minus, 0)] (app (nm minus) [t1; t2])}) dummyRange +let encode_nat n = + let rec aux out n = + if n=0 then out + else aux (snat out) (n - 1) in + aux znat n + +let default_tests = + let _ = Pars.pars_and_tc_fragment "let rec copy (x:list int) : Tot (list int) = \ + match x with \ + | [] -> [] \ + | hd::tl -> hd::copy tl" in + let _ = Pars.pars_and_tc_fragment "let recons (x:list 'a) : Tot (list 'a) = \ + match x with \ + | [] -> [] \ + | hd::tl -> hd::tl" in + let _ = Pars.pars_and_tc_fragment "let rev (x:list 'a) : Tot (list 'a) = \ + let rec aux (x:list 'a) (out:list 'a) : Tot (list 'a) = \ + match x with \ + | [] -> out \ + | hd::tl -> aux tl (hd::out) in \ + aux x []" in + let _ = Pars.pars_and_tc_fragment "type t = \ + | A : int -> int -> t \ + | B : int -> int -> t \ + let f = function \ + | A x y \ + | B y x -> y - x" in + let _ = Pars.pars_and_tc_fragment "type snat = | Z | S : snat -> snat" in + let _ = Pars.pars_and_tc_fragment "type tb = | T | F" in + let _ = Pars.pars_and_tc_fragment "type rb = | A1 | A2 | A3" in + let _ = Pars.pars_and_tc_fragment "type hb = | H : tb -> hb" in + let _ = Pars.pars_and_tc_fragment "let select (i:tb) (x:'a) (y:'a) : Tot 'a = \ + match i with \ + | T -> x \ + | F -> y" in + let _ = Pars.pars_and_tc_fragment "let select_int3 (i:int) (x:'a) (y:'a) (z:'a) : Tot 'a = \ + match i with \ + | 0 -> x \ + | 1 -> y \ + | _ -> z" in + let _ = Pars.pars_and_tc_fragment "let select_bool (b:bool) (x:'a) (y:'a) : Tot 'a = \ + if b then x else y" in + let _ = Pars.pars_and_tc_fragment "let select_string3 (s:string) (x:'a) (y:'a) (z:'a) : Tot 'a = \ + match s with \ + | \"abc\" -> x \ + | \"def\" -> y \ + | _ -> z" in + let _ = Pars.pars_and_tc_fragment "let recons_m (x:list tb) = \ + match x with \ + | [] -> [] \ + | hd::tl -> hd::tl" in + let _ = Pars.pars_and_tc_fragment "let rec copy_tb_list_2 (x:list tb) : Tot (list tb) = \ + match x with \ + | [] -> [] \ + | [hd] -> [hd] + | hd1::hd2::tl -> hd1::hd2::copy_tb_list_2 tl" in + let _ = Pars.pars_and_tc_fragment "let rec copy_list_2 (x:list 'a) : Tot (list 'a) = \ + match x with \ + | [] -> [] \ + | [hd] -> [hd] + | hd1::hd2::tl -> hd1::hd2::copy_list_2 tl" in + let _ = Pars.pars_and_tc_fragment "let (x1:int{x1>3}) = 6" in + let _ = Pars.pars_and_tc_fragment "let (x2:int{x2+1>3 /\ not (x2-5>0)}) = 2" in + let _ = Pars.pars_and_tc_fragment "let my_plus (x:int) (y:int) = x + y" in + let _ = Pars.pars_and_tc_fragment "let (x3:int{forall (a:nat). a > x2}) = 7" in + + let _ = Pars.pars_and_tc_fragment "let idd (x: 'a) = x" in + let _ = Pars.pars_and_tc_fragment "let revtb (x: tb) = match x with | T -> F | F -> T" in + let _ = Pars.pars_and_tc_fragment "let id_tb (x: tb) = x" in + let _ = Pars.pars_and_tc_fragment "let fst_a (x: 'a) (y: 'a) = x" in + let _ = Pars.pars_and_tc_fragment "let id_list (x: list 'a) = x" in + let _ = Pars.pars_and_tc_fragment "let id_list_m (x: list tb) = x" in //same as recons_m, but no pattern matching + [ (0, (app apply [one; id; nm n]), (nm n)) + ; (1, (app id [nm x]), (nm x)) + ; (1, (app apply [tt; nm n; nm m]), (nm n)) + ; (2, (app apply [ff; nm n; nm m]), (nm m)) + ; (3, (app apply [apply; apply; apply; apply; apply; ff; nm n; nm m]), (nm m)) + ; (4, (app twice [apply; ff; nm n; nm m]), (nm m)) + ; (5, (minus one z), one) + ; (6, (app pred [one]), z) + ; (7, (minus one one), z) + ; (8, (app mul [one; one]), one) + ; (9, (app mul [two; one]), two) + ; (10, (app mul [app succ [one]; one]), two) + ; (11, (minus (encode 10) (encode 10)), z) + ; (12, (minus (encode 100) (encode 100)), z) + ; (13, (let_ x (encode 100) (minus (nm x) (nm x))), z) + + // ; (14, (let_ x (encode 1000) (minus (nm x) (nm x))), z) //takes ~10s; wasteful for CI + ; (15, (let_ x (app succ [one]) + (let_ y (app mul [nm x; nm x]) + (let_ h (app mul [nm y; nm y]) + (minus (nm h) (nm h))))), z) + ; (16, (mk_let x (app succ [one]) + (mk_let y (app mul [nm x; nm x]) + (mk_let h (app mul [nm y; nm y]) + (minus (nm h) (nm h))))), z) + ; (17, (let_ x (app succ [one]) + (let_ y (app mul [nm x; nm x]) + (let_ h (app mul [nm y; nm y]) + (minus (nm h) (nm h))))), z) + ; (18, (pred_nat (snat (snat znat))), (snat znat)) + ; (19, tc_term (minus_nat (snat (snat znat)) (snat znat)), (snat znat)) // requires local recdef + ; (20, tc_term (minus_nat (encode_nat 10) (encode_nat 10)), znat) + ; (21, tc_term (minus_nat (encode_nat 100) (encode_nat 100)), znat) + // ; (22, tc_term (minus_nat (encode_nat 10000) (encode_nat 10000)), znat) // Stack overflow in Normalizer when run with mono + // ; (23, tc_term (minus_nat (encode_nat 1000000) (encode_nat 1000000)), znat) //this one takes about 30 sec and ~3.5GB of memory. Stack overflow in NBE when run with mono + ; (24, (tc "recons [0;1]"), (tc "[0;1]")) + ; (241, (tc "recons [false;true;false]"), (tc "[false;true;false]")) + ; (25, (tc "copy [0;1]"), (tc "[0;1]")) + ; (26, (tc "rev [0;1;2;3;4;5;6;7;8;9;10]"), (tc "[10;9;8;7;6;5;4;3;2;1;0]")) + // Type defs not yet implemented for NBE + // ; (271, (tc "(FStar.String.substring \"abcdef\" 1 2)"), (tc "\"bc\"")) //VD: Not sure why, but this test fails on the normalizer + // ; (27, (tc "(rev (FStar.String.list_of_string \"abcd\"))"), (tc "['d'; 'c'; 'b'; 'a']"))// -- CH: works up to an unfolding too much (char -> char') + ; (28, (tc "(fun x y z q -> z) T T F T"), (tc "F")) + ; (29, (tc "[T; F]"), (tc "[T; F]")) + ; (31, (tc "id_tb T"), (tc "T")) + ; (32, (tc "(fun #a x -> x) #tb T"), (tc "T")) + ; (33, (tc "revtb T"), (tc "F")) + ; (34, (tc "(fun x y -> x) T F"), (tc "T")) + ; (35, (tc "fst_a T F"), (tc "T")) + ; (36, (tc "idd T"), (tc "T")) + ; (301, (tc "id_list [T]"), (tc "[T]")) + ; (3012, (tc "id_list_m [T]"), (tc "[T]")) + ; (302, (tc "recons_m [T; F]"), (tc "[T; F]")) + ; (303, (tc "select T A1 A3"), (tc "A1")) + ; (3031, (tc "select T 3 4"), (tc "3")) + ; (3032, (tc "select_bool false 3 4"), (tc "4")) + ; (3033, (tc "select_int3 1 7 8 9"), (tc "8")) + ; (3034, (tc "[5]"), (tc "[5]")) + ; (3035, (tc "[\"abcd\"]"), (tc "[\"abcd\"]")) + ; (3036, (tc "select_string3 \"def\" 5 6 7"), (tc "6")) + //; (3037, (tc "['c']"), (tc "['c']")) //VD: Fails unless FStar.Char is imported (see FStarC.Tests.Pars) + ; (305, (tc "idd T"), (tc "T")) + ; (306, (tc "recons [T]"), (tc "[T]")) + ; (307, (tc "copy_tb_list_2 [T;F;T;F;T;F;F]"), (tc "[T;F;T;F;T;F;F]")) + ; (308, (tc "copy_list_2 [T;F;T;F;T;F;F]"), (tc "[T;F;T;F;T;F;F]")) + + ; (304, (tc "rev [T; F; F]"), (tc "[F; F; T]")) + ; (305, (tc "rev [[T]; [F; T]]"), (tc "[[F; T]; [T]]")) + + ; (309, (tc "x1"), (tc "6")) + ; (310, (tc "x2"), (tc "2")) + //; (311, (tc "x3"), (tc "7")) // Throws parsing exceptiomn + + // Tests for primops + ; (401, (tc "7 + 3"), (tc "10")) + ; (402, (tc "true && false"), (tc "false")) + ; (403, (tc "3 = 5"), (tc "false")) + ; (404, (tc "\"abc\" ^ \"def\""), (tc "\"abcdef\"")) + ; (405, (tc "(fun (x:list int) -> match x with | [] -> 0 | hd::tl -> 1) []"), (tc "0")) + + // Test for refinements + // ; (501, (tc "fun (x1:int{x1>(3+1)}) -> x1 + (1 + 0)"), (tc "fun (x1:int{x1>4}) -> x1 + 1")) // ZP : Fails because the two functions are not syntactically equal + // ; (502, (tc "x1:int{x1>(3+1)}"), (tc "x1:int{x1>4}")) + ] + + +let run_either i r expected normalizer = +// force_term r; + BU.print1 "%s: ... \n\n" (BU.string_of_int i); + let tcenv = Pars.init() in + FStarC.Main.process_args() |> ignore; //set the command line args for debugging + let x = normalizer tcenv r in + Options.init(); //reset them + Options.set_option "print_universes" (Options.Bool true); + Options.set_option "print_implicits" (Options.Bool true); + Options.set_option "ugly" (Options.Bool true); + Options.set_option "print_bound_var_types" (Options.Bool true); + // ignore (Options.set_options "--debug Test --debug univ_norm,NBE"); + always i (term_eq (U.unascribe x) expected) + +let run_whnf i r expected = + let open Env in + let steps = + [ Primops; + Weak; + HNF; + UnfoldUntil delta_constant ] + in + run_either i r expected (N.normalize steps) + +let run_interpreter i r expected = run_either i r expected (N.normalize [Env.Beta; Env.UnfoldUntil delta_constant; Env.Primops]) +let run_nbe i r expected = run_either i r expected (FStarC.TypeChecker.NBE.normalize_for_unit_test [FStarC.TypeChecker.Env.UnfoldUntil delta_constant]) +let run_interpreter_with_time i r expected = + let interp () = run_interpreter i r expected in + (i, snd (FStarC.Compiler.Util.return_execution_time interp)) + +let run_whnf_with_time i r expected = + let whnf () = run_whnf i r expected in + (i, snd (FStarC.Compiler.Util.return_execution_time whnf)) + +let run_nbe_with_time i r expected = + let nbe () = run_nbe i r expected in + (i, snd (FStarC.Compiler.Util.return_execution_time nbe)) + +let run_tests tests run = + Options.__set_unit_tests(); + let l = List.map (function (no, test, res) -> run no test res) tests in + Options.__clear_unit_tests(); + l + +let whnf_tests = + let _ = Pars.pars_and_tc_fragment "assume val def : Type0" in + let _ = Pars.pars_and_tc_fragment "assume val pred : Type0" in + let _ = Pars.pars_and_tc_fragment "let def0 (y:int) = def" in + let _ = Pars.pars_and_tc_fragment "unfold let def1 (y:int) = x:def0 y { pred }" in + let def_def1 = tc "x:def0 17 { pred }" in + let def_def1_unfolded = tc "x:def { pred }" in + // let tests = //We should expect this ... for 602 + // [(601, tc "def1 17", def_def1); + // (602, def_def1, def_def1)] + // in + let tests = //but the current behavior is this + //if we can fix the normalizer, we should change test 602 + [(601, tc "def1 17", def_def1); + (602, def_def1, def_def1_unfolded)] + in + tests + +let run_all_whnf () = + BU.print_string "Testing Normlizer WHNF\n"; + let _ = run_tests whnf_tests run_whnf in + BU.print_string "Normalizer WHNF ok\n" + +let run_all_nbe () = + BU.print_string "Testing NBE\n"; + let _ = run_tests default_tests run_nbe in + BU.print_string "NBE ok\n" + +let run_all_interpreter () = + BU.print_string "Testing the normalizer\n"; + let _ = run_tests default_tests run_interpreter in + BU.print_string "Normalizer ok\n" + +let run_all_whnf_with_time () = + BU.print_string "Testing WHNF\n"; + let l = run_tests whnf_tests run_whnf_with_time in + BU.print_string "WHNF ok\n"; + l + +let run_all_nbe_with_time () = + BU.print_string "Testing NBE\n"; + let l = run_tests default_tests run_nbe_with_time in + BU.print_string "NBE ok\n"; + l + +let run_all_interpreter_with_time () = + BU.print_string "Testing the normalizer\n"; + let l = run_tests default_tests run_interpreter_with_time in + BU.print_string "Normalizer ok\n"; + l + + +// old compare +let run_both_with_time i r expected = + let nbe () = run_nbe i r expected in + let norm () = run_interpreter i r expected in + FStarC.Compiler.Util.measure_execution_time "nbe" nbe; + BU.print_string "\n"; + FStarC.Compiler.Util.measure_execution_time "normalizer" norm; + BU.print_string "\n" + +let compare () = + BU.print_string "Comparing times for normalization and nbe\n"; + run_both_with_time 14 (let_ x (encode 1000) (minus (nm x) (nm x))) z + +let compare_times l_int l_nbe = + BU.print_string "Comparing times for normalization and nbe\n"; + List.iter2 (fun res1 res2 -> + let (t1, time_int) = res1 in + let (t2, time_nbe) = res2 in + if (t1 = t2) // sanity check + then + BU.print3 "Test %s\nNBE %s\nInterpreter %s\n" + (BU.string_of_int t1) + (BU.string_of_float time_nbe) + (BU.string_of_float time_int) + else + BU.print_string "Test numbers do not match...\n" + ) l_int l_nbe + +let run_all () = + BU.print1 "%s" (show znat); + let _ = run_all_whnf_with_time () in + let l_int = run_all_interpreter_with_time () in + let l_nbe = run_all_nbe_with_time () in + compare_times l_int l_nbe diff --git a/src/tests/FStarC.Tests.Pars.fst b/src/tests/FStarC.Tests.Pars.fst new file mode 100644 index 00000000000..835c2b2ae60 --- /dev/null +++ b/src/tests/FStarC.Tests.Pars.fst @@ -0,0 +1,335 @@ +(* + Copyright 2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Tests.Pars +open FStar open FStarC +open FStarC.Compiler +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.Range +open FStarC.Parser +open FStarC.Compiler.Util +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.Errors +open FStarC.TypeChecker.Env +open FStarC.Parser.ParseIt +module DsEnv = FStarC.Syntax.DsEnv +module TcEnv = FStarC.TypeChecker.Env +module SMT = FStarC.SMTEncoding.Solver +module Tc = FStarC.TypeChecker.Tc +module TcTerm = FStarC.TypeChecker.TcTerm +module ToSyntax = FStarC.ToSyntax.ToSyntax +module BU = FStarC.Compiler.Util +module D = FStarC.Parser.Driver +module Rel = FStarC.TypeChecker.Rel +module NBE = FStarC.TypeChecker.NBE + +let test_lid = Ident.lid_of_path ["Test"] Range.dummyRange +let tcenv_ref: ref (option TcEnv.env) = mk_ref None +let test_mod_ref = mk_ref (Some ({name=test_lid; + declarations=[]; + is_interface=false})) + +let parse_mod mod_name dsenv = + match parse None (Filename mod_name) with + | ASTFragment (Inl m, _) -> + let m, env'= ToSyntax.ast_modul_to_modul m dsenv in + let env' , _ = DsEnv.prepare_module_or_interface false false env' (FStarC.Ident.lid_of_path ["Test"] (FStarC.Compiler.Range.dummyRange)) DsEnv.default_mii in + env', m + | ParseError (err, msg, r) -> + raise (Error(err, msg, r, [])) + | ASTFragment (Inr _, _) -> + let msg = BU.format1 "%s: expected a module\n" mod_name in + raise_error0 Errors.Fatal_ModuleExpected msg + | Term _ -> + failwith "Impossible: parsing a Filename always results in an ASTFragment" + +let add_mods mod_names dsenv env = + List.fold_left (fun (dsenv,env) mod_name -> + let dsenv, string_mod = parse_mod mod_name dsenv in + let _mod, env = Tc.check_module env string_mod false in + (dsenv, env) + ) (dsenv,env) mod_names + +let init_once () : unit = + let solver = SMT.dummy in + let env = TcEnv.initial_env + FStarC.Parser.Dep.empty_deps + TcTerm.tc_term + TcTerm.typeof_tot_or_gtot_term + TcTerm.typeof_tot_or_gtot_term_fastpath + TcTerm.universe_of + Rel.teq_nosmt_force + Rel.subtype_nosmt_force + solver + Const.prims_lid + NBE.normalize_for_unit_test + FStarC.Universal.core_check + in + env.solver.init env; + let dsenv, prims_mod = parse_mod (Basefiles.prims()) (DsEnv.empty_env Parser.Dep.empty_deps) in + let env = {env with dsenv=dsenv} in + let _prims_mod, env = Tc.check_module env prims_mod false in + // needed to run tests with chars + // let dsenv, env = add_mods ["FStar.Pervasives.Native.fst"; "FStar.Pervasives.fst"; "FStar.Mul.fst"; "FStar.Squash.fsti"; + // "FStar.Classical.fst"; "FStarC.Compiler.List.Tot.Base.fst"; "FStarC.Compiler.List.Tot.Properties.fst"; "FStarC.Compiler.List.Tot.fst"; + // "FStar.StrongExcludedMiddle.fst"; "FStar.Seq.Base.fst"; "FStar.Seq.Properties.fst"; "FStar.Seq.fst"; + // "FStar.BitVector.fst"; "FStar.Math.Lib.fst"; "FStar.Math.Lemmas.fst"; "FStar.UInt.fst"; "FStar.UInt32.fst"; + // "FStar.Char.fsti"; "FStar.String.fsti"] dsenv env in + + // only needed to test tatic normalization + // let dsenv, env = add_mods ["FStarC.Compiler.Range.fsti"; "FStar.Pervasives.Native.fst"; "FStar.Pervasives.fst"; "FStarC.Reflection.Types.fsti"; "FStar.Order.fst"; + // "FStarC.Reflection.Data.fst"; "FStarC.Reflection.Basic.fst"; "FStar.Squash.fsti"; "FStar.Classical.fst"; + // "FStarC.Compiler.List.Tot.Base.fst"; "FStarC.Compiler.List.Tot.Properties.fst"; "FStarC.Compiler.List.Tot.fst"; "FStar.Char.fsti"; + // "FStar.String.fsti"; "FStarC.Reflection.Syntax.fst"; "FStarC.Reflection.Syntax.Lemmas.fst"; + // "FStarC.Reflection.Formula.fst"; "FStarC.Tactics.Types.fsti"; "FStarC.Tactics.Result.fst"; + // "FStarC.Tactics.Effect.fst"; "FStarC.Tactics.Builtins.fst"; "FStarC.Tactics.Derived.fst"; + // "FStarC.Tactics.Logic.fst"; "FStarC.Tactics.fst"] dsenv env in + + + let env = {env with dsenv=dsenv} in (* VD: need to propagate add_mods to the dsenv in env *) + + let env = TcEnv.set_current_module env test_lid in + tcenv_ref := Some env + +let _ = + FStarC.Main.setup_hooks(); + init_once() + +let init () = + match !tcenv_ref with + | Some f -> f + | _ -> + failwith "Should have already been initialized by the top-level effect" + +let frag_of_text s = {frag_fname=" input"; frag_text=s; frag_line=1; frag_col=0} + +let pars s = + try + let tcenv = init() in + match parse None (Fragment <| frag_of_text s) with + | Term t -> + ToSyntax.desugar_term tcenv.dsenv t + | ParseError (e, msg, r) -> + raise_error r e msg + | ASTFragment _ -> + failwith "Impossible: parsing a Fragment always results in a Term" + with + | Error(err, msg, r, _ctx) when not <| FStarC.Options.trace_error() -> + if r = FStarC.Compiler.Range.dummyRange + then BU.print_string (Errors.rendermsg msg) + else BU.print2 "%s: %s\n" (FStarC.Compiler.Range.string_of_range r) (Errors.rendermsg msg); + exit 1 + + | e when not ((Options.trace_error())) -> raise e + +let tc' s = + let tm = pars s in + let tcenv = init() in + (* We set phase1=true to allow the typechecker to insert + coercions. *) + let tcenv = {tcenv with phase1=true; top_level=false} in + let tm, _, g = TcTerm.tc_tot_or_gtot_term tcenv tm in + Rel.force_trivial_guard tcenv g; + let tm = FStarC.Syntax.Compress.deep_compress false false tm in + tm, tcenv + +let tc s = + let tm, _ = tc' s in + tm + +let tc_term tm = + let tcenv = init() in + let tcenv = {tcenv with top_level=false} in + let tm, _, g = TcTerm.tc_tot_or_gtot_term tcenv tm in + Rel.force_trivial_guard tcenv g; + let tm = FStarC.Syntax.Compress.deep_compress false false tm in + tm + +let pars_and_tc_fragment (s:string) = + Options.set_option "trace_error" (Options.Bool true); + let report () = FStarC.Errors.report_all () |> ignore in + try + let tcenv = init() in + let frag = frag_of_text s in + try + let test_mod', tcenv', _ = FStarC.Universal.tc_one_fragment !test_mod_ref tcenv (Inl (frag, [])) in + test_mod_ref := test_mod'; + tcenv_ref := Some tcenv'; + let n = get_err_count () in + if n <> 0 + then (report (); + raise_error0 Errors.Fatal_ErrorsReported (BU.format1 "%s errors were reported" (string_of_int n))) + with e -> report(); raise_error0 Errors.Fatal_TcOneFragmentFailed ("tc_one_fragment failed: " ^s) + with + | e when not ((Options.trace_error())) -> raise e + +let test_hashes () = + FStarC.Main.process_args () |> ignore; //set options + let _ = pars_and_tc_fragment "type unary_nat = | U0 | US of unary_nat" in + let test_one_hash (n:int) = + let rec aux n = + if n = 0 then "U0" + else "(US " ^ aux (n - 1) ^ ")" + in + let tm = tc (aux n) in + let hc = FStarC.Syntax.Hash.ext_hash_term tm in + BU.print2 "Hash of unary %s is %s\n" + (string_of_int n) + (FStarC.Hash.string_of_hash_code hc) + in + let rec aux (n:int) = + if n = 0 then () + else (test_one_hash n; aux (n - 1)) + in + aux 100; + Options.init() + + +let parse_incremental_decls () = + let source0 = + "module Demo\n\ + let f x = match x with | Some x -> true | None -> false\n\ + let test y = if Some? y then f y else true\n\ + ```pulse\n\ + fn f() {}\n\ + ```\n\ + ```pulse\n\ + fn g() {}\n\ + ```\n\ + let something = more\n\ + let >< junk" + in + let source1 = + "module Demo\n\ + let f x = match x with | Some x -> true | None -> false\n\ + let test y = if Some? y then f y else true\n\ + ```pulse\n\ + fn f() {}\n\ + ```\n\n\ + ```pulse\n\ + fn g() {}\n\ + ```\n\ + let something = more\n\ + let >< junk" + in + + let open FStarC.Parser.ParseIt in + let input0 = Incremental { frag_fname = "Demo.fst"; + frag_text = source0; + frag_line = 1; + frag_col = 0 } in + let input1 = Incremental { frag_fname = "Demo.fst"; + frag_text = source1; + frag_line = 1; + frag_col = 0 } in + let open FStarC.Compiler.Range in + match parse None input0, parse None input1 with + | IncrementalFragment (decls0, _, parse_err0), + IncrementalFragment (decls1, _, parse_err1) -> ( + let check_range r l c = + let p = start_of_range r in + if line_of_pos p = l && col_of_pos p = c + then () + else failwith (format4 "Incremental parsing failed: Expected syntax error at (%s, %s), got error at (%s, %s)" + (string_of_int l) + (string_of_int c) + (string_of_int (line_of_pos p)) + (string_of_int (col_of_pos p))) + in + let _ = + match parse_err0, parse_err1 with + | None, _ -> + failwith "Incremental parsing failed: Expected syntax error at (8, 6), got no error" + | _, None -> + failwith "Incremental parsing failed: Expected syntax error at (9, 6), got no error" + | Some (_, _, rng0), Some (_, _, rng1) -> + check_range rng0 11 6; + check_range rng1 12 6 + in + match decls0, decls1 with + | [d0;d1;d2;d3;d4;d5], + [e0;e1;e2;e3;e4;e5] -> + let open FStarC.Parser.AST.Util in + if List.forall2 (fun (x, _) (y, _) -> eq_decl x y) decls0 decls1 + then () + else ( + failwith ("Incremental parsing failed; unexpected change in a decl") + ) + | _ -> failwith (format2 "Incremental parsing failed; expected 6 decls got %s and %s\n" + (string_of_int (List.length decls0)) + (string_of_int (List.length decls1))) + ) + + + | ParseError (code, message, range), _ + | _, ParseError (code, message, range) -> + let msg = + format2 "Incremental parsing failed: Syntax error @ %s: %s" + (Range.string_of_range range) + (Errors.rendermsg message) // FIXME + in + failwith msg + + | _ -> + failwith "Incremental parsing failed: Unexpected output" + + +open FStarC.Class.Show + +let parse_incremental_decls_use_lang () = + let source0 = + "module Demo\n\ + let x = 0\n\ + #lang-somelang\n\ + val f : t\n\ + let g x = f x\n\ + #restart-solver" + in + FStarC.Parser.AST.Util.register_extension_lang_parser "somelang" FStarC.Parser.ParseIt.parse_fstar_incrementally; + let open FStarC.Parser.ParseIt in + let input0 = Incremental { frag_fname = "Demo.fst"; + frag_text = source0; + frag_line = 1; + frag_col = 0 } in + let open FStarC.Compiler.Range in + match parse None input0 with + | IncrementalFragment (decls0, _, parse_err0) -> ( + let _ = + match parse_err0 with + | None -> () + | Some _ -> + failwith "Incremental parsing failed: ..." + in + let open FStarC.Parser.AST in + let ds = List.map fst decls0 in + match ds with + | [{d=TopLevelModule _}; {d=TopLevelLet _}; {d=UseLangDecls _}; {d=Val _}; {d=TopLevelLet _}; {d=Pragma _}] -> () + | _ -> + failwith ("Incremental parsing failed; unexpected decls: " ^ show ds) + ) + + + | ParseError (code, message, range) -> + let msg = + format2 "Incremental parsing failed: Syntax error @ %s: %s" + (Range.string_of_range range) + (Errors.rendermsg message) // FIXME + in + failwith msg + + | _ -> + failwith "Incremental parsing failed: Unexpected output" diff --git a/src/tests/FStarC.Tests.Test.fst b/src/tests/FStarC.Tests.Test.fst new file mode 100644 index 00000000000..c2cd6c175b8 --- /dev/null +++ b/src/tests/FStarC.Tests.Test.fst @@ -0,0 +1,62 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Tests.Test +open FStarC +open FStarC.Compiler.Effect +open FStarC.Syntax +open FStarC.Errors +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module U = FStarC.Syntax.Util +module BU = FStarC.Compiler.Util +module O = FStarC.Options +module G = FStarC.Getopt + +let main argv = + BU.print_string "Initializing tests...\n"; + try + let res, fs = O.parse_cmd_line () in + match res with + | G.Help -> + BU.print_string "F* unit tests. This binary can take the same options \ + as F*, but not all of them are meaningful."; + exit 0 + | G.Error msg -> + BU.print_error msg; exit 1 + | G.Empty + | G.Success -> + FStarC.Main.setup_hooks(); + Pars.init() |> ignore; + Pars.parse_incremental_decls(); + Pars.parse_incremental_decls_use_lang (); + Norm.run_all (); + if Unif.run_all () then () else exit 1; + Data.run_all (); + + FStarC.Errors.report_all () |> ignore; + let nerrs = FStarC.Errors.get_err_count() in + if nerrs > 0 then + exit 1; + exit 0 + with + | Error(err, msg, r, _ctx) when not <| O.trace_error() -> + if r = FStarC.Compiler.Range.dummyRange + then BU.print_string (Errors.rendermsg msg) + else BU.print2 "%s: %s\n" (FStarC.Compiler.Range.string_of_range r) (Errors.rendermsg msg); + exit 1 + | e -> + BU.print2_error "Error\n%s\n%s\n" (BU.message_of_exn e) (BU.trace_of_exn e); + exit 1 diff --git a/src/tests/FStarC.Tests.Unif.fst b/src/tests/FStarC.Tests.Unif.fst new file mode 100644 index 00000000000..b1e4fcbb03a --- /dev/null +++ b/src/tests/FStarC.Tests.Unif.fst @@ -0,0 +1,338 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Tests.Unif +//Unification tests +//open FSharp.Compatibility.OCaml + +open FStar +open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Errors +open FStarC.Compiler.Util +open FStarC.Syntax.Syntax +open FStarC.Tests.Pars +module S = FStarC.Syntax.Syntax +module U = FStarC.Syntax.Util +module SS = FStarC.Syntax.Subst +module I = FStarC.Ident +module P = FStarC.Syntax.Print +module N = FStarC.TypeChecker.Normalize +module Rel = FStarC.TypeChecker.Rel +module Env = FStarC.TypeChecker.Env +module BU = FStarC.Compiler.Util +open FStarC.TypeChecker.Common +open FStarC.TypeChecker.Env +open FStarC.Ident +open FStarC.Compiler.Range +open FStarC.Tests.Util + +open FStarC.Class.Show + +let tcenv () = Pars.init() + +let guard_to_string g = match g with + | Trivial -> "trivial" + | NonTrivial f -> + N.term_to_string (tcenv()) f + +let success = BU.mk_ref true + +let fail msg = + BU.print_string msg; + success := false + +let guard_eq i g g' = + let b, g, g' = match g, g' with + | Trivial, Trivial -> true, g, g' + | NonTrivial f, NonTrivial f' -> + let f = N.normalize [Env.EraseUniverses] (tcenv()) f in + let f' = N.normalize [Env.EraseUniverses] (tcenv()) f' in + term_eq f f', NonTrivial f, NonTrivial f' + | _ -> false, g, g' in + if not b + then fail <| BU.format3 "Test %s failed:\n\t\ + Expected guard %s;\n\t\ + Got guard %s\n" (BU.string_of_int i) (guard_to_string g') (guard_to_string g); + success := !success && b + +let unify i bvs x y g' check = + BU.print1 "%s ..." (BU.string_of_int i); + FStarC.Main.process_args () |> ignore; //set options + BU.print2 "Unify %s\nand %s\n" (show x) (show y); + let tcenv = tcenv() in + let tcenv = Env.push_bvs tcenv bvs in + let g = Rel.teq tcenv x y |> Rel.solve_deferred_constraints tcenv |> Rel.simplify_guard tcenv in + guard_eq i g.guard_f g'; + check(); + Options.init() //reset them; exceptions are fatal, so don't worry about resetting them in case guard_eq fails + +let should_fail x y = + try + let g = Rel.teq (tcenv()) x y |> Rel.solve_deferred_constraints (tcenv()) in + match g.guard_f with + | Trivial -> fail (BU.format2 "%s and %s should not be unifiable\n" (show x) (show y)) + | NonTrivial f -> BU.print3 "%s and %s are unifiable if %s\n" (show x) (show y) (show f) + with Error(e, msg, r, _ctx) -> BU.print1 "%s\n" (Errors.rendermsg msg) // FIXME? + +let unify' x y = + let x = pars x in + let y = pars y in + let g = Rel.teq (tcenv()) x y |> Rel.solve_deferred_constraints (tcenv()) in + BU.print3 "%s and %s are unifiable with guard %s\n" (show x) (show y) (guard_to_string g.guard_f) + +let norm t = N.normalize [] (tcenv()) t + +let check_core i subtyping guard_ok x y = + FStarC.Main.process_args () |> ignore; //set options + let env = tcenv () in + let res = + if subtyping + then FStarC.TypeChecker.Core.check_term_subtyping true true env x y + else FStarC.TypeChecker.Core.check_term_equality true true env x y + in + let _ = + match res with + | Inl None -> + BU.print1 "%s core check ok\n" (BU.string_of_int i) + | Inl (Some g) -> + BU.print2 "%s core check computed guard %s ok\n" (BU.string_of_int i) (show g); + if not guard_ok + then success := false + | Inr err -> + success := false; + BU.print2 "%s failed\n%s\n" (BU.string_of_int i) (FStarC.TypeChecker.Core.print_error err) + in + Options.init() + +let check_core_typing i e t = + FStarC.Main.process_args () |> ignore; //set options + let env = tcenv () in + let _ = + match FStarC.TypeChecker.Core.check_term env e t true with + | Inl None -> + BU.print1 "%s core typing ok\n" (BU.string_of_int i) + | Inl (Some g) -> + BU.print1 "%s core typing produced a guard\n" (BU.string_of_int i); + success := false + | Inr err -> + success := false; + BU.print2 "%s failed\n%s\n" (BU.string_of_int i) (FStarC.TypeChecker.Core.print_error err) + in + Options.init() + +let inst n tm = + let rec aux out n = + if n=0 then out + else let t, _, _ = FStarC.TypeChecker.Util.new_implicit_var "" dummyRange (init()) U.ktype0 false in + let u, _, _ = FStarC.TypeChecker.Util.new_implicit_var "" dummyRange (init()) t false in + aux (u::out) (n - 1) in + let us = aux [] n in + norm (app tm us), us + +let run_all () = + BU.print_string "Testing the unifier\n"; + + Options.__set_unit_tests(); + let unify_check n bvs x y g f = unify n bvs x y g f in + let unify n bvs x y g = unify n bvs x y g (fun () -> ()) in + let int_t = tc "Prims.int" in + let x_bv = S.gen_bv "x" None int_t in + let y_bv = S.gen_bv "y" None int_t in + let x = S.bv_to_name x_bv in + let y = S.bv_to_name y_bv in + + //syntactic equality of names + unify 0 [x_bv] x x Trivial; + + //different names, equal with a guard + unify 1 [x_bv;y_bv] x y (NonTrivial (U.mk_eq2 U_zero U.t_bool x y)); + + //equal after some reduction + let id = tc "fun (x:bool) -> x" in + unify 2 [x_bv] x (app id [x]) Trivial; + + //physical equality of terms + let id = tc "fun (x:bool) -> x" in + unify 3 [] id id Trivial; + + //alpha equivalence + let id = tc "fun (x:bool) -> x" in + let id' = tc "fun (y:bool) -> y" in + unify 4 [] id id' Trivial; //(NonTrivial (pars "True /\ (forall x. True)")); + + //alpha equivalence 2 + unify 5 [] + (tc "fun (x y:bool) -> x") + (tc "fun (a b:bool) -> a") + Trivial; + + //alpha equivalence 3 + unify 6 [] + (tc "fun (x y z:bool) -> y") + (tc "fun (a b c:bool) -> b") + Trivial; + + //logical equality of distinct lambdas (questionable ... would only work for unit, or inconsistent context) + unify 7 [] + (tc "fun (x:int) (y:int) -> y") + (tc "fun (x:int) (y:int) -> x") + (NonTrivial (tc "(forall (x:int). (forall (y:int). y==x))")); + + //logical equality of distinct lambdas (questionable ... would only work for unit, or inconsistent context) + unify 8 [] + (tc "fun (x:int) (y:int) (z:int) -> y") + (tc "fun (x:int) (y:int) (z:int) -> z") + (NonTrivial (tc "(forall (x:int). (forall (y:int). (forall (z:int). y==z)))")); + + //imitation: unifies u to a constant + FStarC.Main.process_args () |> ignore; //set options + let tm, us = inst 1 (tc "fun (u:Type0 -> Type0) (x:Type0) -> u x") in + let sol = tc "fun (x:Type0) -> Prims.pair x x" in + unify_check 9 [] tm + sol + Trivial + (fun () -> + always 9 (term_eq (norm (List.hd us)) + (norm sol))); + + //imitation: unifies u to a lambda + let tm, us = inst 1 (tc "fun (u: int -> int -> int) (x:int) -> u x") in + let sol = tc "fun (x y:int) -> x + y" in + unify_check 10 [] tm + sol + Trivial + (fun () ->always 10 (term_eq (norm (List.hd us)) + (norm sol))); + + let tm1 = tc ("x:int -> y:int{eq2 y x} -> bool") in + let tm2 = tc ("x:int -> y:int -> bool") in + unify 11 [] tm1 tm2 + (NonTrivial (tc "forall (x:int). (forall (y:int). y==x)")); + + let tm1 = tc ("a:Type0 -> b:(a -> Type0) -> x:a -> y:b x -> Tot Type0") in + let tm2 = tc ("a:Type0 -> b:(a -> Type0) -> x:a -> y:b x -> Tot Type0") in + unify 12 [] tm1 tm2 + Trivial; + + let tm1, tm2, bvs_13 = + let int_typ = tc "int" in + let x = FStarC.Syntax.Syntax.new_bv None int_typ in + + let typ = tc "unit -> Type0" in + let l = tc ("fun (q:(unit -> Type0)) -> q ()") in + let q = FStarC.Syntax.Syntax.new_bv None typ in + let tm1 = norm (app l [FStarC.Syntax.Syntax.bv_to_name q]) in + + let l = tc ("fun (p:unit -> Type0) -> p") in + let unit = tc "()" in + let env = Env.push_binders (init()) [S.mk_binder x; S.mk_binder q] in + let u_p, _, _ = FStarC.TypeChecker.Util.new_implicit_var "" dummyRange env typ false in + let tm2 = app (norm (app l [u_p])) [unit] in + tm1, tm2, [x;q] + in + + unify 13 bvs_13 tm1 tm2 Trivial; + + let tm1, tm2, bvs_14 = + let int_typ = tc "int" in + let x = FStarC.Syntax.Syntax.new_bv None int_typ in + + let typ = tc "pure_post unit" in + let l = tc ("fun (q:pure_post unit) -> q ()") in + let q = FStarC.Syntax.Syntax.new_bv None typ in + let tm1 = norm (app l [FStarC.Syntax.Syntax.bv_to_name q]) in + + let l = tc ("fun (p:pure_post unit) -> p") in + let unit = tc "()" in + let env = Env.push_binders (init()) [S.mk_binder x; S.mk_binder q] in + let u_p, _, _ = FStarC.TypeChecker.Util.new_implicit_var "" dummyRange env typ false in + let tm2 = app (norm (app l [u_p])) [unit] in + tm1, tm2, [x;q] + in + + unify 14 bvs_14 tm1 tm2 Trivial; + + let tm1, tm2 = + let _ = Pars.pars_and_tc_fragment + "let ty0 n = x:int { x >= n }\n\ + let ty1 n = x:ty0 n { x > n }\n\ + assume val tc (t:Type0) : Type0" + in + let t0 = tc "ty1 17" in + let t1 = tc "x:ty0 17 { x > 17 }" in + t0, t1 + in + check_core 15 false false tm1 tm2; + + let tm1, tm2 = + let t0 = tc "x:int { x >= 17 /\ x > 17 }" in + let t1 = tc "x:ty0 17 { x > 17 }" in + t0, t1 + in + check_core 16 false false tm1 tm2; + + let tm1, tm2 = + let _ = Pars.pars_and_tc_fragment + "let defn17_0 (x:nat) : nat -> nat -> Type0 = fun y z -> a:int { a + x == y + z }" + in + let t0 = tc "defn17_0 0 1 2" in + let t1_head = tc "(defn17_0 0)" in + let arg1 = tc "1" in + let arg2 = tc "2" in + let t1 = S.mk_Tm_app t1_head [(arg1, None); (arg2, None)] t0.pos in + t0, t1 + in + check_core 17 false false tm1 tm2; + + let tm1, tm2 = + let t0 = tc "dp:((dtuple2 int (fun (y:int) -> z:int{ z > y })) <: Type0) { let (| x, _ |) = dp in x > 17 }" in + let t1 = tc "(dtuple2 int (fun (y:int) -> z:int{ z > y }))" in + t0, t1 + in + check_core 18 true false tm1 tm2; + + let tm1, tm2 = + let _ = Pars.pars_and_tc_fragment + "type vprop' = { t:Type0 ; n:nat }" + in + let t0 = tc "x:(({ t=bool; n=0 }).t <: Type0) { x == false }" in + let t1 = tc "x:bool{ x == false }" in + t0, t1 + in + check_core 19 false false tm1 tm2; + + + let tm1, tm2 = + let t0 = tc "int" in + let t1 = tc "j:(i:nat{ i > 17 } <: Type0){j > 42}" in + t0, t1 + in + check_core 20 true true tm1 tm2; + + let tm, ty = + let _ = Pars.pars_and_tc_fragment "assume val tstr21 (x:string) : Type0" in + let t0 = tc "(fun (x:bool) (y:int) (z: (fun (x:string) -> tstr21 x) \"hello\") -> x)" in + let ty = tc "bool -> int -> tstr21 \"hello\" -> bool" in + t0, ty + in + check_core_typing 21 tm ty; + + Options.__clear_unit_tests(); + + if !success + then BU.print_string "Unifier ok\n"; + !success diff --git a/src/tests/FStarC.Tests.Util.fst b/src/tests/FStarC.Tests.Util.fst new file mode 100644 index 00000000000..746caeb675d --- /dev/null +++ b/src/tests/FStarC.Tests.Util.fst @@ -0,0 +1,130 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.Tests.Util + +open FStar +open FStarC +open FStarC.Compiler +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Errors +open FStarC.Compiler.Util +open FStarC.Syntax +open FStarC.Syntax.Syntax +module S = FStarC.Syntax.Syntax +module U = FStarC.Syntax.Util +module SS = FStarC.Syntax.Subst +module I = FStarC.Ident +module UF = FStarC.Syntax.Unionfind +module Const = FStarC.Parser.Const +module BU = FStarC.Compiler.Util + +open FStarC.Ident +open FStarC.Compiler.Range +open FStarC.Class.Tagged +open FStarC.Class.Show +open FStarC.Syntax.Print {} + +let always id b = + if b + then () + else raise_error0 Errors.Fatal_AssertionFailure (BU.format1 "Assertion failed: test %s" (BU.string_of_int id)) + +let x = gen_bv "x" None S.tun +let y = gen_bv "y" None S.tun +let n = gen_bv "n" None S.tun +let h = gen_bv "h" None S.tun +let m = gen_bv "m" None S.tun +let tm t = mk t dummyRange +let nm x = bv_to_name x +let app x ts = mk (Tm_app {hd=x; args=List.map as_arg ts}) dummyRange + +let rec term_eq' t1 t2 = + let t1 = SS.compress t1 in + let t2 = SS.compress t2 in + let binders_eq xs ys = + List.length xs = List.length ys + && List.forall2 (fun (x:binder) (y:binder) -> term_eq' x.binder_bv.sort y.binder_bv.sort) xs ys in + let args_eq xs ys = + List.length xs = List.length ys + && List.forall2 (fun (a, imp) (b, imp') -> term_eq' a b && U.eq_aqual imp imp') xs ys in + let comp_eq (c:S.comp) (d:S.comp) = + match c.n, d.n with + | S.Total t, S.Total s -> term_eq' t s + | S.Comp ct1, S.Comp ct2 -> + I.lid_equals ct1.effect_name ct2.effect_name + && term_eq' ct1.result_typ ct2.result_typ + && args_eq ct1.effect_args ct2.effect_args + | _ -> false in + match t1.n, t2.n with + | Tm_lazy l, _ -> term_eq' (must !lazy_chooser l.lkind l) t2 + | _, Tm_lazy l -> term_eq' t1 (must !lazy_chooser l.lkind l) + | Tm_bvar x, Tm_bvar y -> x.index = y.index + | Tm_name x, Tm_name y -> S.bv_eq x y + | Tm_fvar f, Tm_fvar g -> S.fv_eq f g + | Tm_uinst (t, _), Tm_uinst(s, _) -> term_eq' t s + | Tm_constant c1, Tm_constant c2 -> FStarC.Const.eq_const c1 c2 + | Tm_type u, Tm_type v -> u=v + | Tm_abs {bs=xs; body=t}, Tm_abs {bs=ys; body=u} when (List.length xs = List.length ys) -> binders_eq xs ys && term_eq' t u + | Tm_abs {bs=xs; body=t}, Tm_abs {bs=ys; body=u} -> + if List.length xs > List.length ys + then let xs, xs' = BU.first_N (List.length ys) xs in + let t1 = mk (Tm_abs {bs=xs; body=mk (Tm_abs {bs=xs'; body=t; rc_opt=None}) t1.pos; rc_opt=None}) t1.pos in + term_eq' t1 t2 + else let ys, ys' = BU.first_N (List.length xs) ys in + let t2 = mk (Tm_abs {bs=ys; body=mk (Tm_abs {bs=ys'; body=u; rc_opt=None}) t2.pos; rc_opt=None}) t2.pos in + term_eq' t1 t2 + | Tm_arrow {bs=xs; comp=c}, Tm_arrow {bs=ys; comp=d} -> binders_eq xs ys && comp_eq c d + | Tm_refine {b=x; phi=t}, Tm_refine {b=y; phi=u} -> term_eq' x.sort y.sort && term_eq' t u + | Tm_app {hd={n=Tm_fvar fv_eq_1}; + args=[(_, Some ({ aqual_implicit = true })); t1; t2]}, + Tm_app {hd={n=Tm_fvar fv_eq_2}; + args=[(_, Some ({ aqual_implicit = true })); s1; s2]} + when S.fv_eq_lid fv_eq_1 Const.eq2_lid + && S.fv_eq_lid fv_eq_2 Const.eq2_lid -> //Unification produces equality applications that may have unconstrainted implicit arguments + args_eq [s1;s2] [t1;t2] + | Tm_app {hd=t; args}, Tm_app {hd=s; args=args'} -> term_eq' t s && args_eq args args' + | Tm_match {scrutinee=t; ret_opt=None; brs=pats}, + Tm_match {scrutinee=t'; ret_opt=None; brs=pats'} -> + List.length pats = List.length pats' + && List.forall2 (fun (_, _, e) (_, _, e') -> term_eq' e e') pats pats' + && term_eq' t t' + | Tm_ascribed {tm=t1; asc=(Inl t2, _, _)}, + Tm_ascribed {tm=s1; asc=(Inl s2, _, _)} -> + term_eq' t1 s1 && term_eq' t2 s2 + | Tm_let {lbs=(is_rec, lbs); body=t}, + Tm_let {lbs=(is_rec',lbs'); body=s} when is_rec=is_rec' -> + List.length lbs = List.length lbs' + && List.forall2 (fun lb1 lb2 -> term_eq' lb1.lbtyp lb2.lbtyp && term_eq' lb1.lbdef lb2.lbdef) lbs lbs' + && term_eq' t s + | Tm_uvar (u,_), Tm_uvar (u',_) -> UF.equiv u.ctx_uvar_head u'.ctx_uvar_head + | Tm_meta {tm=t1}, _ -> term_eq' t1 t2 + | _, Tm_meta {tm=t2} -> term_eq' t1 t2 + + | Tm_delayed _, _ + | _, Tm_delayed _ -> + failwith (BU.format2 "Impossible: %s and %s" (tag_of t1) (tag_of t2)) + + | Tm_unknown, Tm_unknown -> true + | _ -> false + +let term_eq t1 t2 = +// BU.print2 "Comparing %s and\n\t%s\n" (show t1) (show t2); + let b = term_eq' t1 t2 in + if not b then ( + BU.print2 ">>>>>>>>>>>Term %s is not equal to %s\n" (show t1) (show t2) + ); + b diff --git a/src/tosyntax/FStar.ToSyntax.Interleave.fst b/src/tosyntax/FStar.ToSyntax.Interleave.fst deleted file mode 100644 index d802469d9c1..00000000000 --- a/src/tosyntax/FStar.ToSyntax.Interleave.fst +++ /dev/null @@ -1,451 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.ToSyntax.Interleave -open FStar.Compiler.Effect -open FStar.Compiler.List -//Reorders the top-level definitions/declarations in a file -//in a proper order for consistent type-checking - -open FStar -open FStar.Compiler -open FStar.Ident -open FStar.Errors -open FStar.Syntax.Syntax -open FStar.Parser.AST -open FStar.Class.Show -open FStar.Pprint -open FStar.Class.PP - -module BU = FStar.Compiler.Util - -(* Some basic utilities *) -let id_eq_lid i (l:lident) = (string_of_id i) = (string_of_id (ident_of_lid l)) - -let is_val x d = match d.d with - | Val(y, _) -> (string_of_id x) = (string_of_id y) - | _ -> false - -let is_type x d = match d.d with - | Tycon(_, _, tys) -> - tys |> Util.for_some (fun t -> id_of_tycon t = (string_of_id x)) - | _ -> false - -// -//is d of of the form 'let x = ...' or 'type x = ...' or 'splice[..., x, ...] tac' -// returns unqualified lids -// -let definition_lids d = - match d.d with - | TopLevelLet(_, defs) -> - lids_of_let defs - | Tycon(_, _, tys) -> - tys |> List.collect (function - | TyconAbbrev (id, _, _, _) - | TyconRecord (id, _, _, _, _) - | TyconVariant(id, _, _, _) -> - [Ident.lid_of_ids [id]] - | _ -> []) - | Splice (_, ids, _) - | DeclToBeDesugared { idents=ids } -> List.map (fun id -> Ident.lid_of_ids [id]) ids - - | DeclSyntaxExtension (extension_name, code, _, range) -> begin - let ext_parser = FStar.Parser.AST.Util.lookup_extension_parser extension_name in - match ext_parser with - | None -> - raise_error d Errors.Fatal_SyntaxError - (BU.format1 "Unknown syntax extension %s" extension_name) - | Some parser -> - match parser.parse_decl_name code range with - | Inl error -> - raise_error error.range Errors.Fatal_SyntaxError error.message - | Inr id -> - [Ident.lid_of_ids [id]] - end - | _ -> [] - -let is_definition_of x d = - Util.for_some (id_eq_lid x) (definition_lids d) - - - -(* The basic idea of interleaving is governed by the following: - - Ordering rule - If a val-declaration for 'a' precedes a val-declaration for 'b', - then the let-definition for 'a' must precede the let-definition for 'b'. - - In effect, this means that - - val a - let x0 - val b - let x1 - - let a - let b - - Is effectively ordered as: - - val a - let x0 - let x1 - let a - - val b - let b - - Essentially, we need to check that the definition of `a` matches - its signature in `val a : ta` before we allow `a` to be used - in the signature `val b : tb` and its corresponding definition - `let b : eb`. - - One wrinkle to deal with is mutual recursion. - - Given: - - val a1 - val a2 - let x0 - val b - let x1 - - let rec a1 - and a2 - let b - - Interleaving produces: - - val a1 : ta1 - val a2 : ta2 - let x0 - let x1 - - let rec a1 - and a2 - - val b - let b - - I.e, the vals and the let-recs "move together" - - One consequence of interleaving is that a program is type-checked - in an order different from the sequential order of the text the - programmer wrote. This may result in potentially unintuitive error - message ordering. - - *) - -let rec prefix_with_iface_decls - (iface:list decl) - (impl:decl) - : list decl //remaining iface decls - & list decl = //d prefixed with relevant bits from iface - let qualify_karamel_private impl = - let karamel_private = - FStar.Parser.AST.mk_term - (Const (FStar.Const.Const_string ("KrmlPrivate", impl.drange))) - impl.drange - FStar.Parser.AST.Expr - in - {impl with attrs=karamel_private::impl.attrs} - in - match iface with - | [] -> [], [qualify_karamel_private impl] - | iface_hd::iface_tl -> begin - match iface_hd.d with - | Tycon(_, _, tys) when (tys |> Util.for_some (function (TyconAbstract _) -> true | _ -> false)) -> - raise_error impl Errors.Fatal_AbstractTypeDeclarationInInterface [ - text "Interface contains an abstract 'type' declaration; use 'val' instead." - ] - - | Splice (_, [x], _) - | Val(x, _) -> - //we have a 'val x' in the interface - //take impl as is, unless it is a - // let x (or a `type abbreviation x`) - //or an inductive type x - //or a splice that defines x - //in which case prefix it with iface_hd - let def_ids = definition_lids impl in - let defines_x = Util.for_some (id_eq_lid x) def_ids in - if not defines_x then ( - if def_ids |> Util.for_some (fun y -> - iface_tl |> Util.for_some (is_val (ident_of_lid y))) - then - raise_error impl Errors.Fatal_WrongDefinitionOrder [ - text "Expected the definition of" ^/^ pp x ^/^ text "to precede" - ^/^ (pp def_ids) - ]; - iface, [qualify_karamel_private impl] - ) else ( - let mutually_defined_with_x = def_ids |> List.filter (fun y -> not (id_eq_lid x y)) in - let rec aux mutuals iface = - match mutuals, iface with - | [], _ -> [], iface - | _::_, [] -> [], [] - | y::ys, iface_hd::iface_tl when is_val (ident_of_lid y) iface_hd -> - let val_ys, iface = aux ys iface_tl in - iface_hd::val_ys, iface - - | y::ys, iface_hd::iface_tl when Option.isSome <| List.tryFind (is_val (ident_of_lid y)) iface_tl -> - raise_error iface_hd Errors.Fatal_WrongDefinitionOrder [ - text (Util.format2 "%s is out of order with the definition of %s" - (show iface_hd) - (Ident.string_of_lid y)) - ] - | y::ys, iface_hd::iface_tl -> - aux ys iface //no val given for 'y'; ok - in - let take_iface, rest_iface = aux mutually_defined_with_x iface_tl in - rest_iface, iface_hd::take_iface@[impl] - ) - - | Pragma _ -> - (* Don't interleave pragmas on interface into implementation *) - prefix_with_iface_decls iface_tl impl - - | _ -> - let iface, ds = prefix_with_iface_decls iface_tl impl in - iface, iface_hd::ds - end - -let check_initial_interface (iface:list decl) = - let rec aux iface = - match iface with - | [] -> () - | hd::tl -> begin - match hd.d with - | Tycon(_, _, tys) when (tys |> Util.for_some (function (TyconAbstract _) -> true | _ -> false)) -> - raise_error hd Errors.Fatal_AbstractTypeDeclarationInInterface - "Interface contains an abstract 'type' declaration; use 'val' instead" - - | Val(x, t) -> //we have a 'val x' in the interface - if Util.for_some (is_definition_of x) tl - then raise_error hd Errors.Fatal_BothValAndLetInInterface - (Util.format2 "'val %s' and 'let %s' cannot both be provided in an interface" (string_of_id x) (string_of_id x)) - else if hd.quals |> List.contains Assumption - then raise_error hd Errors.Fatal_AssumeValInInterface - "Interfaces cannot use `assume val x : t`; just write `val x : t` instead" - else () - - | _ -> () - end - in - aux iface; - iface |> List.filter (fun d -> match d.d with TopLevelModule _ -> false | _ -> true) - -////////////////////////////////////////////////////////////////////// -//A weaker variant, for use only in --MLish mode -////////////////////////////////////////////////////////////////////// -//in --MLish mode: the interleaving rules are WAY more lax -// this is basically only in support of bootstrapping the compiler -// Here, if you have a `let x = e` in the implementation -// Then prefix it with `val x : t`, if any in the interface -// Don't enforce any ordering constraints -let ml_mode_prefix_with_iface_decls - (iface:list decl) - (impl:decl) - : list decl //remaining iface decls - & list decl = //impl prefixed with relevant bits from iface - - - match impl.d with - | TopLevelModule _ - | Open _ - | Friend _ - | Include _ - | ModuleAbbrev _ -> - let iface_prefix_opens, iface = - List.span (fun d -> match d.d with | Open _ | ModuleAbbrev _ -> true | _ -> false) iface - in - let iface = - List.filter - (fun d -> - match d.d with - | Val _ - | Tycon _ -> true //only retain the vals in --MLish mode - | _ -> false) - iface - in - iface, [impl]@iface_prefix_opens - - | _ -> - - let iface_prefix_tycons, iface = - List.span (fun d -> match d.d with | Tycon _ -> true | _ -> false) iface - in - - let maybe_get_iface_vals lids iface = - List.partition - (fun d -> lids |> Util.for_some (fun x -> is_val (ident_of_lid x) d)) - iface in - - match impl.d with - | TopLevelLet _ - | Tycon _ -> - let xs = definition_lids impl in - let val_xs, rest_iface = maybe_get_iface_vals xs iface in - rest_iface, iface_prefix_tycons@val_xs@[impl] - | _ -> - iface, iface_prefix_tycons@[impl] - -let ml_mode_check_initial_interface mname (iface:list decl) = - iface |> List.filter (fun d -> - match d.d with - | Tycon(_, _, tys) - when (tys |> Util.for_some (function (TyconAbstract _) -> true | _ -> false)) -> - raise_error d Errors.Fatal_AbstractTypeDeclarationInInterface - "Interface contains an abstract 'type' declaration; use 'val' instead" - | Tycon _ - | Val _ - | Open _ - | ModuleAbbrev _ -> true - | _ -> false) - -let ulib_modules = [ - "FStar.Calc"; - "FStar.TSet"; - "FStar.Seq.Base"; - "FStar.Seq.Properties"; - "FStar.UInt"; - "FStar.UInt8"; - "FStar.UInt16"; - "FStar.UInt32"; - "FStar.UInt64"; - "FStar.Int"; - "FStar.Int8"; - "FStar.Int16"; - "FStar.Int32"; - "FStar.Int64"; -] - -(* - * AR: ml mode optimizations are only applied in ml mode and only to non-core files - * - * otherwise we skip effect declarations like Lemma from Pervasives.fsti, - * resulting in desugaring failures when typechecking Pervasives.fst - *) -let apply_ml_mode_optimizations (mname:lident) : bool = - (* - * AR: 03/29: - * As we introduce interfaces for modules in ulib/, the interleaving code - * doesn't interact with it too well when bootstrapping - * Essentially we do optimizations here (e.g. not taking any interface decls but vals) - * when bootstrapping - * This doesn't work well for ulib files (but is ok for compiler files) - * A better way to fix this problem would be to make compiler files in a separate namespace - * and then do these optimizations (as well as --MLish etc.) only for them - * But until then ... (sigh) - *) - Options.ml_ish () && - (not (List.contains (Ident.string_of_lid mname) (Parser.Dep.core_modules ()))) && - (not (List.contains (Ident.string_of_lid mname) ulib_modules)) - -let prefix_one_decl mname iface impl = - match impl.d with - | TopLevelModule _ -> iface, [impl] - | _ -> - if apply_ml_mode_optimizations mname - then ml_mode_prefix_with_iface_decls iface impl - else prefix_with_iface_decls iface impl - -////////////////////////////////////////////////////////////////////////// -//Top-level interface -////////////////////////////////////////////////////////////////////////// -module E = FStar.Syntax.DsEnv -let initialize_interface (mname:Ident.lid) (l:list decl) : E.withenv unit = - fun (env:E.env) -> - let decls = - if apply_ml_mode_optimizations mname - then ml_mode_check_initial_interface mname l - else check_initial_interface l in - match E.iface_decls env mname with - | Some _ -> - raise_error mname Errors.Fatal_InterfaceAlreadyProcessed - (Util.format1 "Interface %s has already been processed" (show mname)) - | None -> - (), E.set_iface_decls env mname decls - -let fixup_interleaved_decls (iface : list decl) : list decl = - let fix1 (d : decl) : decl = - let d = { d with interleaved = true } in - d - in - iface |> List.map fix1 - -let prefix_with_interface_decls mname (impl:decl) : E.withenv (list decl) = - fun (env:E.env) -> - let decls, env = - match E.iface_decls env (E.current_module env) with - | None -> - [impl], env - | Some iface -> - let iface = fixup_interleaved_decls iface in - let iface, impl = prefix_one_decl mname iface impl in - let env = E.set_iface_decls env (E.current_module env) iface in - impl, env - in - if Options.dump_module (Ident.string_of_lid mname) - then Util.print1 "Interleaved decls:\n%s\n" (show decls); - decls,env - - -let interleave_module (a:modul) (expect_complete_modul:bool) : E.withenv modul = - fun (env:E.env) -> - match a with - | Interface _ -> a, env - | Module(l, impls) -> begin - match E.iface_decls env l with - | None -> a, env - | Some iface -> - let iface = fixup_interleaved_decls iface in - let iface, impls = - List.fold_left - (fun (iface, impls) impl -> - let iface, impls' = prefix_one_decl l iface impl in - iface, impls@impls') - (iface, []) - impls - in - let iface_lets, remaining_iface_vals = - match FStar.Compiler.Util.prefix_until (function {d=Val _} -> true - | {d=Splice _} -> true - | _ -> false) iface with - | None -> iface, [] - | Some (lets, one_val, rest) -> lets, one_val::rest - in - let impls = impls@iface_lets in - let env = - if Options.interactive() - then E.set_iface_decls env l remaining_iface_vals - else env //if not interactive, then don't consume iface_decls - //since some batch-mode checks, e.g., must_erase_for_extraction - //depend on having all the iface decls around - in - let a = Module(l, impls) in - match remaining_iface_vals with - | _::_ when expect_complete_modul -> - let open FStar.Pprint in - log_issue l Errors.Fatal_InterfaceNotImplementedByModule [ - text (Util.format1 "Some interface elements were not implemented by module %s:" (show l)) - ^^ sublist empty (List.map (fun d -> doc_of_string (show d)) remaining_iface_vals) - ]; - a, env - | _ -> - if Options.dump_module (string_of_lid l) - then Util.print1 "Interleaved module is:\n%s\n" (FStar.Parser.AST.modul_to_string a); - a, env - end diff --git a/src/tosyntax/FStar.ToSyntax.Interleave.fsti b/src/tosyntax/FStar.ToSyntax.Interleave.fsti deleted file mode 100644 index e075c1389e5..00000000000 --- a/src/tosyntax/FStar.ToSyntax.Interleave.fsti +++ /dev/null @@ -1,27 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.ToSyntax.Interleave -open FStar.Compiler.Effect -open FStar.Compiler.Effect -open FStar.Ident -open FStar.Parser.AST -module DsEnv = FStar.Syntax.DsEnv - -(* GM: If I don't use the full name, I cannot bootstrap *) - -val initialize_interface: lident -> list decl -> DsEnv.withenv unit -val prefix_with_interface_decls: lident -> decl -> DsEnv.withenv (list decl) -val interleave_module: modul -> bool -> DsEnv.withenv modul diff --git a/src/tosyntax/FStar.ToSyntax.ToSyntax.fst b/src/tosyntax/FStar.ToSyntax.ToSyntax.fst deleted file mode 100644 index ecf11c20552..00000000000 --- a/src/tosyntax/FStar.ToSyntax.ToSyntax.fst +++ /dev/null @@ -1,4446 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.ToSyntax.ToSyntax -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.Compiler.Util -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.Syntax.Util -open FStar.Parser -open FStar.Syntax.DsEnv -open FStar.Parser.AST -open FStar.Ident -open FStar.Const -open FStar.Errors -open FStar.Syntax -open FStar.Class.Setlike -open FStar.Class.Show - -module C = FStar.Parser.Const -module S = FStar.Syntax.Syntax -module U = FStar.Syntax.Util -module BU = FStar.Compiler.Util -module Env = FStar.Syntax.DsEnv -module P = FStar.Syntax.Print -module EMB = FStar.Syntax.Embeddings -module SS = FStar.Syntax.Subst - -let extension_tosyntax_table -: BU.smap extension_tosyntax_decl_t -= FStar.Compiler.Util.smap_create 20 - -let register_extension_tosyntax - (lang_name:string) - (cb:extension_tosyntax_decl_t) -= FStar.Compiler.Util.smap_add extension_tosyntax_table lang_name cb - -let lookup_extension_tosyntax - (lang_name:string) -= FStar.Compiler.Util.smap_try_find extension_tosyntax_table lang_name - -let dbg_attrs = Debug.get_toggle "attrs" -let dbg_ToSyntax = Debug.get_toggle "ToSyntax" - -type antiquotations_temp = list (bv & S.term) - -let tun_r (r:Range.range) : S.term = { tun with pos = r } - -type annotated_pat = Syntax.pat & list (bv & Syntax.typ & list S.term) - -let mk_thunk e = - let b = S.mk_binder (S.new_bv None S.tun) in - U.abs [b] e None - -let mk_binder_with_attrs bv aq attrs = - let pqual, attrs = U.parse_positivity_attributes attrs in - S.mk_binder_with_attrs bv aq pqual attrs - -(* - If the user wrote { f1=v1; ...; fn=vn }, where `field_names` [f1;..;fn] - then we resolve this, using scoping rules only, to `record`. - - The choice of `record` is not settled, however, since type information - later can be used to resolve any ambiguity. - - However, if any of the field_names, f1...fn, are qualified field names, - like `A.B.f`, then, at this stage, we - - 1. Check that all the field names, if qualified, are qualified in - the same way. I.e., it's ok to write - - { A.f1 = v1; f2 = v2; ... } - - But not - - { A.f1 = v1; B.f2 = v2; ... } - - even if A and B are module aliases. - - 2. If any of the field names are qualified, then qualify all the - field_names to the module in which `record` is defined, since - that's the user-provided qualifier already determines that. - - This is important because at this stage, A, B etc. can refer to - module aliases, included modules, etc. and as we pass the term - to the typechecker, all those module aliases have to be fully - resolved. -*) -let qualify_field_names record_or_dc_lid field_names = - let qualify_to_record l = - let ns = ns_of_lid record_or_dc_lid in - Ident.lid_of_ns_and_id ns (ident_of_lid l) - in - let _, field_names_rev = - List.fold_left - (fun (ns_opt, out) l -> - match nsstr l with - | "" -> - if Option.isSome ns_opt - then (ns_opt, qualify_to_record l::out) - else (ns_opt, l::out) - - | ns -> - match ns_opt with - | Some ns' -> - if ns <> ns' - then raise_error l Errors.Fatal_MissingFieldInRecord - (BU.format2 "Field %s of record type was expected to be scoped to namespace %s" (show l) ns') - else ( - ns_opt, qualify_to_record l :: out - ) - - | None -> - Some ns, qualify_to_record l :: out) - (None, []) - field_names - in - List.rev field_names_rev - -let desugar_disjunctive_pattern annotated_pats when_opt branch = - annotated_pats |> List.map (fun (pat, annots) -> - let branch = List.fold_left (fun br (bv, ty, _) -> - let lb = U.mk_letbinding (Inl bv) [] ty C.effect_Tot_lid (S.bv_to_name bv) [] br.pos in - let branch = SS.close [S.mk_binder bv] branch in - mk (Tm_let {lbs=(false, [lb]); body=branch}) br.pos) branch annots in - U.branch(pat, when_opt, branch) - ) - -let trans_qual (r:Range.range) maybe_effect_id = function - | AST.Private -> S.Private - | AST.Assumption -> S.Assumption - | AST.Unfold_for_unification_and_vcgen -> S.Unfold_for_unification_and_vcgen - | AST.Inline_for_extraction -> S.Inline_for_extraction - | AST.NoExtract -> S.NoExtract - | AST.Irreducible -> S.Irreducible - | AST.Logic -> S.Logic - | AST.TotalEffect -> S.TotalEffect - | AST.Effect_qual -> S.Effect - | AST.New -> S.New - | AST.Opaque -> - Errors.log_issue r Errors.Warning_DeprecatedOpaqueQualifier [ - text "The 'opaque' qualifier is deprecated since its use was strangely schizophrenic."; - text "There were two overloaded uses: (1) Given 'opaque val f : t', the behavior was to exclude the definition of 'f' to the SMT solver. This corresponds roughly to the new 'irreducible' qualifier. (2) Given 'opaque type t = t'', the behavior was to provide the definition of 't' to the SMT solver, but not to inline it, unless absolutely required for unification. This corresponds roughly to the behavior of 'unfoldable' (which is currently the default)." - ]; - S.Visible_default - | AST.Reflectable -> - begin match maybe_effect_id with - | None -> raise_error r Errors.Fatal_ReflectOnlySupportedOnEffects "Qualifier reflect only supported on effects" - | Some effect_id -> S.Reflectable effect_id - end - | AST.Reifiable -> S.Reifiable - | AST.Noeq -> S.Noeq - | AST.Unopteq -> S.Unopteq - | AST.DefaultEffect -> raise_error r Errors.Fatal_DefaultQualifierNotAllowedOnEffects "The 'default' qualifier on effects is no longer supported" - | AST.Inline - | AST.Visible -> - raise_error r Errors.Fatal_UnsupportedQualifier "Unsupported qualifier" - -let trans_pragma = function - | AST.ShowOptions -> S.ShowOptions - | AST.SetOptions s -> S.SetOptions s - | AST.ResetOptions sopt -> S.ResetOptions sopt - | AST.PushOptions sopt -> S.PushOptions sopt - | AST.PopOptions -> S.PopOptions - | AST.RestartSolver -> S.RestartSolver - | AST.PrintEffectsGraph -> S.PrintEffectsGraph - -let as_imp = function - | Hash -> S.as_aqual_implicit true - | _ -> None -let arg_withimp_t imp t = - t, as_imp imp - -let contains_binder binders = - binders |> BU.for_some (fun b -> match b.b with - | Annotated _ -> true - | _ -> false) - -let rec unparen t = match t.tm with - | Paren t -> unparen t - | _ -> t - -let tm_type_z r = mk_term (Name (lid_of_path ["Type0"] r)) r Kind -let tm_type r = mk_term (Name (lid_of_path [ "Type"] r)) r Kind - -//Deciding if the t is a computation type -//based on its head symbol -let rec is_comp_type env t = - match (unparen t).tm with - (* we're right at the beginning of Prims, when (G)Tot isn't yet fully defined *) - | Name l when lid_equals (Env.current_module env) C.prims_lid && - (let s = string_of_id (ident_of_lid l) in - s = "Tot" || s = "GTot") -> - true - - | Name l - | Construct(l, _) -> Env.try_lookup_effect_name env l |> Option.isSome - | App(head, _, _) -> is_comp_type env head - | Paren t -> failwith "impossible" - | Ascribed(t, _, _, _) - | LetOpen(_, t) -> is_comp_type env t - | _ -> false - -let unit_ty rng = mk_term (Name C.unit_lid) rng Type_level - -type env_t = Env.env -type lenv_t = list bv - -let desugar_name' setpos (env: env_t) (resolve: bool) (l: lid) : option S.term = - let tm_attrs_opt = - if resolve - then Env.try_lookup_lid_with_attributes env l - else Env.try_lookup_lid_with_attributes_no_resolve env l - in - match tm_attrs_opt with - | None -> None - | Some (tm, attrs) -> - let tm = setpos tm in - Some tm - -let desugar_name mk setpos env resolve l = - fail_or env (desugar_name' setpos env resolve) l - -let compile_op_lid n s r = [mk_ident(compile_op n s r, r)] |> lid_of_ids - -let op_as_term env arity op : option S.term = - let r l = Some (S.lid_and_dd_as_fv (set_lid_range l (range_of_id op)) None |> S.fv_to_tm) in - let fallback () = - match Ident.string_of_id op with - | "=" -> r C.op_Eq - | "<" -> r C.op_LT - | "<=" -> r C.op_LTE - | ">" -> r C.op_GT - | ">=" -> r C.op_GTE - | "&&" -> r C.op_And - | "||" -> r C.op_Or - | "+" -> r C.op_Addition - | "-" when (arity=1) -> r C.op_Minus - | "-" -> r C.op_Subtraction - | "/" -> r C.op_Division - | "%" -> r C.op_Modulus - | "@" -> - FStar.Errors.log_issue op FStar.Errors.Warning_DeprecatedGeneric [ - Errors.Msg.text "The operator '@' has been resolved to FStar.List.Tot.append even though \ - FStar.List.Tot is not in scope. Please add an 'open FStar.List.Tot' to \ - stop relying on this deprecated, special treatment of '@'."]; - r C.list_tot_append_lid - - | "<>" -> r C.op_notEq - | "~" -> r C.not_lid - | "==" -> r C.eq2_lid - | "<<" -> r C.precedes_lid - | "/\\" -> r C.and_lid - | "\\/" -> r C.or_lid - | "==>" -> r C.imp_lid - | "<==>" -> r C.iff_lid - | _ -> None - in - match desugar_name' (fun t -> {t with pos=(range_of_id op)}) - env true (compile_op_lid arity (string_of_id op) (range_of_id op)) with - | Some t -> Some t - | _ -> fallback() - -let sort_ftv ftv = - BU.sort_with (fun x y -> String.compare (string_of_id x) (string_of_id y)) <| - BU.remove_dups (fun x y -> (string_of_id x) = (string_of_id y)) ftv - -let rec free_vars_b tvars_only env binder : (Env.env & list ident) = - match binder.b with - | Variable x -> - if tvars_only - then env, [] //tvars can't clash with vars - else ( - let env, _ = Env.push_bv env x in - env, [] - ) - | TVariable x -> - let env, _ = Env.push_bv env x in - env, [x] - | Annotated(x, term) -> - if tvars_only //tvars can't clash with vars - then env, free_vars tvars_only env term - else ( - let env', _ = Env.push_bv env x in - env', free_vars tvars_only env term - ) - | TAnnotated(id, term) -> - let env', _ = Env.push_bv env id in - env', free_vars tvars_only env term - | NoName t -> - env, free_vars tvars_only env t - -and free_vars_bs tvars_only env binders = - List.fold_left - (fun (env, free) binder -> - let env, f = free_vars_b tvars_only env binder in - env, f@free) - (env, []) - binders - -and free_vars tvars_only env t = match (unparen t).tm with - | Labeled _ -> failwith "Impossible --- labeled source term" - - | Tvar a -> - (match Env.try_lookup_id env a with - | None -> [a] - | _ -> []) - - | Var x -> - if tvars_only - then [] - else ( - let ids = Ident.ids_of_lid x in - match ids with - | [id] -> ( //unqualified name - if None? (Env.try_lookup_id env id) - && None? (Env.try_lookup_lid env x) - then [id] - else [] - ) - | _ -> [] - ) - - | Wild - | Const _ - | Uvar _ - - | Projector _ - | Discrim _ - | Name _ -> [] - - | Requires (t, _) - | Ensures (t, _) - | Decreases (t, _) - | NamedTyp(_, t) -> free_vars tvars_only env t - - | LexList l -> List.collect (free_vars tvars_only env) l - | WFOrder (rel, e) -> - (free_vars tvars_only env rel) @ (free_vars tvars_only env e) - - | Paren t -> failwith "impossible" - - | Ascribed(t, t', tacopt, _) -> - let ts = t::t'::(match tacopt with None -> [] | Some t -> [t]) in - List.collect (free_vars tvars_only env) ts - - | Construct(_, ts) -> List.collect (fun (t, _) -> free_vars tvars_only env t) ts - - | Op(_, ts) -> List.collect (free_vars tvars_only env) ts - - | App(t1,t2,_) -> free_vars tvars_only env t1@free_vars tvars_only env t2 - - | Refine (b, t) -> - let env, f = free_vars_b tvars_only env b in - f@free_vars tvars_only env t - - | Sum(binders, body) -> - let env, free = List.fold_left (fun (env, free) bt -> - let env, f = - match bt with - | Inl binder -> free_vars_b tvars_only env binder - | Inr t -> env, free_vars tvars_only env t - in - env, f@free) (env, []) binders in - free@free_vars tvars_only env body - - | Product(binders, body) -> - let env, free = free_vars_bs tvars_only env binders in - free@free_vars tvars_only env body - - | Project(t, _) -> free_vars tvars_only env t - - | Attributes cattributes -> - (* attributes should be closed but better safe than sorry *) - List.collect (free_vars tvars_only env) cattributes - - | CalcProof (rel, init, steps) -> - free_vars tvars_only env rel - @ free_vars tvars_only env init - @ List.collect (fun (CalcStep (rel, just, next)) -> - free_vars tvars_only env rel - @ free_vars tvars_only env just - @ free_vars tvars_only env next) steps - - | ElimForall (bs, t, ts) -> - let env', free = free_vars_bs tvars_only env bs in - free@ - free_vars tvars_only env' t@ - List.collect (free_vars tvars_only env') ts - - | ElimExists (binders, p, q, y, e) -> - let env', free = free_vars_bs tvars_only env binders in - let env'', free' = free_vars_b tvars_only env' y in - free@ - free_vars tvars_only env' p@ - free_vars tvars_only env q@ - free'@ - free_vars tvars_only env'' e - - | ElimImplies (p, q, e) -> - free_vars tvars_only env p@ - free_vars tvars_only env q@ - free_vars tvars_only env e - - | ElimOr(p, q, r, x, e, x', e') -> - free_vars tvars_only env p@ - free_vars tvars_only env q@ - free_vars tvars_only env r@ - (let env', free = free_vars_b tvars_only env x in - free@free_vars tvars_only env' e)@ - (let env', free = free_vars_b tvars_only env x' in - free@free_vars tvars_only env' e') - - | ElimAnd(p, q, r, x, y, e) -> - free_vars tvars_only env p@ - free_vars tvars_only env q@ - free_vars tvars_only env r@ - (let env', free = free_vars_bs tvars_only env [x;y] in - free@free_vars tvars_only env' e) - - | ListLiteral ts -> - List.collect (free_vars tvars_only env) ts - - | SeqLiteral ts -> - List.collect (free_vars tvars_only env) ts - - | Abs _ (* not closing implicitly over free vars in all these forms: TODO: Fixme! *) - | Function _ - | Let _ - | LetOpen _ - | If _ - | QForall _ - | QExists _ - | QuantOp _ - | Record _ - | Match _ - | TryWith _ - | Bind _ - | Quote _ - | VQuote _ - | Antiquote _ - | Seq _ -> [] - -let free_type_vars = free_vars true - -let head_and_args t = - let rec aux args t = match (unparen t).tm with - | App(t, arg, imp) -> aux ((arg,imp)::args) t - | Construct(l, args') -> {tm=Name l; range=t.range; level=t.level}, args'@args - | _ -> t, args in - aux [] t - -let close env t = - let ftv = sort_ftv <| free_type_vars env t in - if List.length ftv = 0 - then t - else let binders = ftv |> List.map (fun x -> mk_binder (TAnnotated(x, tm_type (range_of_id x))) (range_of_id x) Type_level (Some Implicit)) in - let result = mk_term (Product(binders, t)) t.range t.level in - result - -let close_fun env t = - let ftv = sort_ftv <| free_type_vars env t in - if List.length ftv = 0 - then t - else let binders = ftv |> List.map (fun x -> mk_binder (TAnnotated(x, tm_type (range_of_id x))) (range_of_id x) Type_level (Some Implicit)) in - let t = match (unparen t).tm with - | Product _ -> t - | _ -> mk_term (App(mk_term (Name C.effect_Tot_lid) t.range t.level, t, Nothing)) t.range t.level in - let result = mk_term (Product(binders, t)) t.range t.level in - result - -let rec uncurry bs t = match t.tm with - | Product(binders, t) -> uncurry (bs@binders) t - | _ -> bs, t - -let rec is_var_pattern p = match p.pat with - | PatWild _ - | PatTvar _ - | PatVar _ -> true - | PatAscribed(p, _) -> is_var_pattern p - | _ -> false - -let rec is_app_pattern p = match p.pat with - | PatAscribed(p,_) -> is_app_pattern p - | PatApp({pat=PatVar _}, _) -> true - | _ -> false - -let replace_unit_pattern p = match p.pat with - | PatConst FStar.Const.Const_unit -> - mk_pattern (PatAscribed (mk_pattern (PatWild (None, [])) p.prange, (unit_ty p.prange, None))) p.prange - | _ -> p - -let rec destruct_app_pattern (env:env_t) (is_top_level:bool) (p:pattern) - : either ident lid // name at the head - & list pattern // arguments the head is applied to - & option (term & option term) // a possible (outermost) ascription on the pattern - = - match p.pat with - | PatAscribed(p,t) -> - let (name, args, _) = destruct_app_pattern env is_top_level p in - (name, args, Some t) - | PatApp({pat=PatVar (id, _, _)}, args) when is_top_level -> - (Inr (qualify env id), args, None) - | PatApp({pat=PatVar (id, _, _)}, args) -> - (Inl id, args, None) - | _ -> - failwith "Not an app pattern" - -let rec gather_pattern_bound_vars_maybe_top (acc : FlatSet.t ident) p = - let gather_pattern_bound_vars_from_list = - List.fold_left gather_pattern_bound_vars_maybe_top acc - in - match p.pat with - | PatWild _ - | PatConst _ - | PatVQuote _ - | PatName _ - | PatOp _ -> acc - | PatApp (phead, pats) -> gather_pattern_bound_vars_from_list (phead::pats) - | PatTvar (x, _, _) - | PatVar (x, _, _) -> add x acc - | PatList pats - | PatTuple (pats, _) - | PatOr pats -> gather_pattern_bound_vars_from_list pats - | PatRecord guarded_pats -> gather_pattern_bound_vars_from_list (List.map snd guarded_pats) - | PatAscribed (pat, _) -> gather_pattern_bound_vars_maybe_top acc pat - -let gather_pattern_bound_vars : pattern -> FlatSet.t Ident.ident = - let acc = empty #ident () in - fun p -> gather_pattern_bound_vars_maybe_top acc p - -type bnd = - | LocalBinder of bv & S.bqual & list S.term //binder attributes - | LetBinder of lident & (S.term & option S.term) - -let is_implicit (b:bnd) : bool = - match b with - | LocalBinder (_, Some (S.Implicit _), _) -> true - | _ -> false - -let binder_of_bnd = function - | LocalBinder (a, aq, attrs) -> a, aq, attrs - | _ -> failwith "Impossible" - -(* TODO : shouldn't this be Tot by default ? *) -let mk_lb (attrs, n, t, e, pos) = { - lbname=n; - lbunivs=[]; - lbeff=C.effect_ALL_lid (); - lbtyp=t; - lbdef=e; - lbattrs=attrs; - lbpos=pos; -} -let no_annot_abs bs t = U.abs bs t None - -(* - * Collect the explicitly annotated universes in the sigelt, close the sigelt with them, and stash them appropriately in the sigelt - *) -let rec generalize_annotated_univs (s:sigelt) :sigelt = - (* NB!! Order is very important here, so a definition like - type t = Type u#a -> Type u#b - gets is two universe parameters in the order in which - they appear. So we do not use a set, and instead just use a mutable - list that we update as we find universes. We also keep a set of 'seen' - universes, whose order we do not care, just for efficiency. *) - let vars : ref (list univ_name) = mk_ref [] in - let seen : ref (RBSet.t univ_name) = mk_ref (empty ()) in - let reg (u:univ_name) : unit = - if not (mem u !seen) then ( - seen := add u !seen; - vars := u::!vars - ) - in - let get () : list univ_name = List.rev !vars in - - (* Visit the sigelt and rely on side effects to capture all - the names. This goes roughly in left-to-right order. *) - let _ = Visit.visit_sigelt false - (fun t -> t) - (fun u -> ignore (match u with - | U_name nm -> reg nm - | _ -> ()); - u) s - in - let unames = get () in - - match s.sigel with - | Sig_inductive_typ _ - | Sig_datacon _ -> failwith "Impossible: collect_annotated_universes: bare data/type constructor" - | Sig_bundle {ses=sigs; lids} -> - let usubst = Subst.univ_var_closing unames in - { s with sigel = Sig_bundle {ses=sigs |> List.map (fun se -> - match se.sigel with - | Sig_inductive_typ {lid; params=bs; num_uniform_params=num_uniform; t; mutuals=lids1; ds=lids2} -> - { se with sigel = Sig_inductive_typ {lid; - us=unames; - params=Subst.subst_binders usubst bs; - num_uniform_params=num_uniform; - t=Subst.subst (Subst.shift_subst (List.length bs) usubst) t; - mutuals=lids1; - ds=lids2; - injective_type_params=false} } - | Sig_datacon {lid;t;ty_lid=tlid;num_ty_params=n;mutuals=lids} -> - { se with sigel = Sig_datacon {lid; - us=unames; - t=Subst.subst usubst t; - ty_lid=tlid; - num_ty_params=n; - mutuals=lids; - injective_type_params=false} } - | _ -> failwith "Impossible: collect_annotated_universes: Sig_bundle should not have a non data/type sigelt" - ); lids} } - | Sig_declare_typ {lid; t} -> - { s with sigel = Sig_declare_typ {lid; us=unames; t=Subst.close_univ_vars unames t} } - | Sig_let {lbs=(b, lbs); lids} -> - let usubst = Subst.univ_var_closing unames in - //This respects the invariant enforced by FStar.Syntax.Util.check_mutual_universes - { s with sigel = Sig_let {lbs=(b, lbs |> List.map (fun lb -> { lb with lbunivs = unames; lbdef = Subst.subst usubst lb.lbdef; lbtyp = Subst.subst usubst lb.lbtyp })); - lids} } - | Sig_assume {lid;phi=fml} -> - { s with sigel = Sig_assume {lid; us=unames; phi=Subst.close_univ_vars unames fml} } - | Sig_effect_abbrev {lid;bs;comp=c;cflags=flags} -> - let usubst = Subst.univ_var_closing unames in - { s with sigel = Sig_effect_abbrev {lid; - us=unames; - bs=Subst.subst_binders usubst bs; - comp=Subst.subst_comp usubst c; - cflags=flags} } - - | Sig_fail {errs; fail_in_lax=lax; ses} -> - { s with sigel = Sig_fail {errs; - fail_in_lax=lax; - ses=List.map generalize_annotated_univs ses} } - - (* Works over the signature only *) - | Sig_new_effect ed -> - let generalize_annotated_univs_signature (s : effect_signature) : effect_signature = - match s with - | Layered_eff_sig (n, (_, t)) -> - let uvs = Free.univnames t |> elems in - let usubst = Subst.univ_var_closing uvs in - Layered_eff_sig (n, (uvs, Subst.subst usubst t)) - | WP_eff_sig (_, t) -> - let uvs = Free.univnames t |> elems in - let usubst = Subst.univ_var_closing uvs in - WP_eff_sig (uvs, Subst.subst usubst t) - in - { s with sigel = Sig_new_effect { ed with signature = generalize_annotated_univs_signature ed.signature } } - - | Sig_sub_effect _ - | Sig_polymonadic_bind _ - | Sig_polymonadic_subcomp _ - | Sig_splice _ - | Sig_pragma _ -> - s - -let is_special_effect_combinator = function - | "lift1" - | "lift2" - | "pure" - | "app" - | "push" - | "wp_if_then_else" - | "wp_assert" - | "wp_assume" - | "wp_close" - | "stronger" - | "ite_wp" - | "wp_trivial" - | "ctx" - | "gctx" - | "lift_from_pure" - | "return_wp" - | "return_elab" - | "bind_wp" - | "bind_elab" - | "repr" - | "post" - | "pre" - | "wp" -> true - | _ -> false - -let rec sum_to_universe u n = - if n = 0 then u else U_succ (sum_to_universe u (n-1)) - -let int_to_universe n = sum_to_universe U_zero n - -let rec desugar_maybe_non_constant_universe t - : either int Syntax.universe (* level of universe or desugared universe *) -= - match (unparen t).tm with - | Wild -> Inr U_unknown - | Uvar u -> Inr (U_name u) - - | Const (Const_int (repr, _)) -> - (* TODO : That might be a little dangerous... *) - let n = int_of_string repr in - if n < 0 - then raise_error t Errors.Fatal_NegativeUniverseConstFatal_NotSupported - ("Negative universe constant are not supported : " ^ repr); - Inl n - | Op (op_plus, [t1 ; t2]) -> - assert (Ident.string_of_id op_plus = "+") ; - let u1 = desugar_maybe_non_constant_universe t1 in - let u2 = desugar_maybe_non_constant_universe t2 in - begin match u1, u2 with - | Inl n1, Inl n2 -> Inl (n1+n2) - | Inl n, Inr u - | Inr u, Inl n -> Inr (sum_to_universe u n) - | Inr u1, Inr u2 -> - raise_error t Errors.Fatal_UniverseMightContainSumOfTwoUnivVars - ("This universe might contain a sum of two universe variables " ^ show t) - end - | App _ -> - let rec aux t univargs = - match (unparen t).tm with - | App(t, targ, _) -> - let uarg = desugar_maybe_non_constant_universe targ in - aux t (uarg::univargs) - | Var max_lid -> - assert (Ident.string_of_lid max_lid = "max") ; - if List.existsb (function Inr _ -> true | _ -> false) univargs - then Inr (U_max (List.map (function Inl n -> int_to_universe n | Inr u -> u) univargs)) - else - let nargs = List.map (function Inl n -> n | Inr _ -> failwith "impossible") univargs in - Inl (List.fold_left (fun m n -> if m > n then m else n) 0 nargs) - (* TODO : Might not be the best place to raise the error... *) - | _ -> raise_error t Errors.Fatal_UnexpectedTermInUniverse ("Unexpected term " ^ term_to_string t ^ " in universe context") - in aux t [] - | _ -> raise_error t Errors.Fatal_UnexpectedTermInUniverse ("Unexpected term " ^ term_to_string t ^ " in universe context") - -let desugar_universe t : Syntax.universe = - let u = desugar_maybe_non_constant_universe t in - match u with - | Inl n -> int_to_universe n - | Inr u -> u - -let check_no_aq (aq : antiquotations_temp) : unit = - match aq with - | [] -> () - | (bv, { n = Tm_quoted (e, { qkind = Quote_dynamic })})::_ -> - raise_error e Errors.Fatal_UnexpectedAntiquotation - (BU.format1 "Unexpected antiquotation: `@(%s)" (show e)) - | (bv, e)::_ -> - raise_error e Errors.Fatal_UnexpectedAntiquotation - (BU.format1 "Unexpected antiquotation: `#(%s)" (show e)) - -let check_linear_pattern_variables pats (r:Range.range) = - // returns the set of pattern variables - let rec pat_vars p : RBSet.t bv = - match p.v with - | Pat_dot_term _ - | Pat_constant _ -> empty () - | Pat_var x -> - (* Only consider variables that actually have names, - not wildcards. *) - if string_of_id x.ppname = Ident.reserved_prefix - then empty () - else singleton x - | Pat_cons(_, _, pats) -> - let aux out (p, _) = - let p_vars = pat_vars p in - let intersection = inter p_vars out in - if is_empty intersection - then union out p_vars - else - let duplicate_bv = List.hd (elems intersection) in - raise_error r Errors.Fatal_NonLinearPatternNotPermitted - (BU.format1 "Non-linear patterns are not permitted: `%s` appears more than once in this pattern." - (show duplicate_bv.ppname)) - in - List.fold_left aux (empty ()) pats - in - - // check that the same variables are bound in each pattern - match pats with - | [] -> () - | [p] -> pat_vars p |> ignore - | p::ps -> - let pvars = pat_vars p in - let aux p = - if equal pvars (pat_vars p) then () else - let symdiff s1 s2 = union (diff s1 s2) (diff s2 s1) in - let nonlinear_vars = symdiff pvars (pat_vars p) in - let first_nonlinear_var = List.hd (elems nonlinear_vars) in - raise_error r Errors.Fatal_IncoherentPatterns - (BU.format1 "Patterns in this match are incoherent, variable %s is bound in some but not all patterns." - (show first_nonlinear_var.ppname)) - in - List.iter aux ps - -let smt_pat_lid (r:Range.range) = Ident.set_lid_range C.smtpat_lid r -let smt_pat_or_lid (r:Range.range) = Ident.set_lid_range C.smtpatOr_lid r - -// [hoist_pat_ascription' pat] pulls [PatAscribed] nodes out of [pat] -// and construct a tuple that consists in a non-ascribed pattern and a -// type abscription. Note [hoist_pat_ascription'] only works with -// patterns whose ascriptions live under tuple or list nodes. This -// function is used for [LetOperator] desugaring in -// [resugar_data_pat], because direct ascriptions in patterns are -// dropped (see issue #2678). -let rec hoist_pat_ascription' (pat: pattern): pattern & option term - = let mk tm = mk_term tm (pat.prange) Type_level in - let handle_list type_lid pat_cons pats = - let pats, terms = List.unzip (List.map hoist_pat_ascription' pats) in - if List.for_all None? terms - then pat, None - else - let terms = List.map (function | Some t -> t | None -> mk Wild) terms in - { pat with pat = pat_cons pats} - , Some (mkApp (mk type_lid) (List.map (fun t -> (t, Nothing)) terms) pat.prange) - in match pat.pat with - | PatList pats -> handle_list (Var C.list_lid) PatList pats - | PatTuple (pats, dep) -> - handle_list - (Var ((if dep then C.mk_dtuple_lid else C.mk_tuple_lid) (List.length pats) pat.prange)) - (fun pats -> PatTuple (pats, dep)) pats - | PatAscribed (pat, (typ, None)) -> pat, Some typ - // if [pat] is not a list, a tuple or an ascription, we cannot - // compose (at least not in a simple way) sub ascriptions, thus we - // return the pattern directly - | _ -> pat, None - -let hoist_pat_ascription (pat: pattern): pattern - = let pat, typ = hoist_pat_ascription' pat in - match typ with - | Some typ -> { pat with pat = PatAscribed (pat, (typ, None)) } - | None -> pat - -(* TODO : Patterns should be checked that there are no incompatible type ascriptions *) -(* and these type ascriptions should not be dropped !!! *) -let rec desugar_data_pat - (top_level_ascr_allowed : bool) - (env:env_t) - (p:pattern) - : (env_t & bnd & list annotated_pat) & antiquotations_temp = - let resolvex (l:lenv_t) e x = - (* This resolution function will be shared across - * the cases of a PatOr, so different ocurrences of - * a same (surface) variable are mapped to exactly the - * same internal variable. *) - match BU.find_opt (fun y -> (string_of_id y.ppname = string_of_id x)) l with - | Some y -> l, e, y - | _ -> - let e, xbv = push_bv e x in - (xbv::l), e, xbv - in - - let rec aux' (top:bool) (loc:lenv_t) (aqs:antiquotations_temp) (env:env_t) (p:pattern) - : lenv_t (* list of all BVs mentioned *) - & antiquotations_temp (* updated antiquotations_temp *) - & env_t (* env updated with the BVs pushed in *) - & bnd (* a binder for the pattern *) - & pat (* elaborated pattern *) - & list (bv & Syntax.typ & list S.term) (* ascripted pattern variables (collected) with attributes *) - = - let pos q = Syntax.withinfo q p.prange in - let pos_r r q = Syntax.withinfo q r in - let orig = p in - match p.pat with - | PatOr _ -> failwith "impossible: PatOr handled below" - - | PatOp op -> - (* Turn into a PatVar and recurse *) - let id_op = mk_ident (compile_op 0 (string_of_id op) (range_of_id op), (range_of_id op)) in - let p = { p with pat = PatVar (id_op, None, []) } in - aux loc aqs env p - - | PatAscribed(p, (t, tacopt)) -> - (* Check that there's no tactic *) - begin match tacopt with - | None -> () - | Some _ -> - raise_error orig Errors.Fatal_TypeWithinPatternsAllowedOnVariablesOnly - "Type ascriptions within patterns cannot be associated with a tactic" - end; - let loc, aqs, env', binder, p, annots = aux loc aqs env p in - let annots', binder, aqs = match binder with - | LetBinder _ -> failwith "impossible" - | LocalBinder(x, aq, attrs) -> - let t, aqs' = desugar_term_aq env (close_fun env t) in - let x = { x with sort = t } in - [(x, t, attrs)], LocalBinder(x, aq, attrs), aqs'@aqs - in - (* Check that the ascription is over a variable, and not something else *) - begin match p.v with - | Pat_var _ -> () - | _ when top && top_level_ascr_allowed -> () - | _ -> - raise_error orig Errors.Fatal_TypeWithinPatternsAllowedOnVariablesOnly - "Type ascriptions within patterns are only allowed on variables" - end; - loc, aqs, env', binder, p, annots'@annots - - | PatWild (aq, attrs) -> - let aq = trans_bqual env aq in - let attrs = attrs |> List.map (desugar_term env) in - let x = S.new_bv (Some p.prange) (tun_r p.prange) in - loc, aqs, env, LocalBinder(x, aq, attrs), pos <| Pat_var x, [] - - | PatConst c -> - let x = S.new_bv (Some p.prange) (tun_r p.prange) in - loc, aqs, env, LocalBinder(x, None, []), pos <| Pat_constant c, [] - - | PatVQuote e -> - // Here, we desugar [PatVQuote e] into a [PatConst s] where - // [s] is the (string represented) lid of [e] (see function - // [desugar_vquote]), then re-run desugaring on [PatConst s]. - let pat = PatConst (Const_string (desugar_vquote env e p.prange, p.prange)) in - aux' top loc aqs env ({ p with pat }) - - | PatTvar(x, aq, attrs) - | PatVar (x, aq, attrs) -> - let aq = trans_bqual env aq in - let attrs = attrs |> List.map (desugar_term env) in - let loc, env, xbv = resolvex loc env x in - loc, aqs, env, LocalBinder(xbv, aq, attrs), pos <| Pat_var xbv, [] - - | PatName l -> - let l = fail_or env (try_lookup_datacon env) l in - let x = S.new_bv (Some p.prange) (tun_r p.prange) in - loc, aqs, env, LocalBinder(x, None, []), pos <| Pat_cons(l, None, []), [] - - | PatApp({pat=PatName l}, args) -> - let loc, aqs, env, annots, args = List.fold_right (fun arg (loc, aqs, env, annots, args) -> - let loc, aqs, env, b, arg, ans = aux loc aqs env arg in - let imp = is_implicit b in - (loc, aqs, env, ans@annots, (arg, imp)::args)) args (loc, aqs, env, [], []) in - let l = fail_or env (try_lookup_datacon env) l in - let x = S.new_bv (Some p.prange) (tun_r p.prange) in - loc, aqs, env, LocalBinder(x, None, []), pos <| Pat_cons(l, None, args), annots - - | PatApp _ -> raise_error p Errors.Fatal_UnexpectedPattern "Unexpected pattern" - - | PatList pats -> - let loc, aqs, env, annots, pats = List.fold_right (fun pat (loc, aqs, env, annots, pats) -> - let loc, aqs, env, _, pat, ans = aux loc aqs env pat in - loc, aqs, env, ans@annots, pat::pats) pats (loc, aqs, env, [], []) in - let pat = List.fold_right (fun hd tl -> - let r = Range.union_ranges hd.p tl.p in - pos_r r <| Pat_cons(S.lid_and_dd_as_fv C.cons_lid (Some Data_ctor), None, [(hd, false);(tl, false)])) pats - (pos_r (Range.end_range p.prange) <| Pat_cons(S.lid_and_dd_as_fv C.nil_lid (Some Data_ctor), None, [])) in - let x = S.new_bv (Some p.prange) (tun_r p.prange) in - loc, aqs, env, LocalBinder(x, None, []), pat, annots - - | PatTuple(args, dep) -> - let loc, aqs, env, annots, args = List.fold_left (fun (loc, aqs, env, annots, pats) p -> - let loc, aqs, env, _, pat, ans = aux loc aqs env p in - loc, aqs, env, ans@annots, (pat, false)::pats) (loc, aqs, env, [], []) args in - let args = List.rev args in - let l = if dep then C.mk_dtuple_data_lid (List.length args) p.prange - else C.mk_tuple_data_lid (List.length args) p.prange in - let constr = fail_or env (Env.try_lookup_lid env) l in - let l = match constr.n with - | Tm_fvar fv -> fv - | _ -> failwith "impossible" in - let x = S.new_bv (Some p.prange) (tun_r p.prange) in - loc, aqs, env, LocalBinder(x, None, []), pos <| Pat_cons(l, None, args), annots - - | PatRecord (fields) -> - (* Record patterns have to wait for type information to be fully resolved *) - let field_names, pats = List.unzip fields in - let typename, field_names = - match fields with - | [] -> None, field_names - | (f, _)::_ -> - match try_lookup_record_by_field_name env f with - | None -> None, field_names - | Some r -> Some r.typename, qualify_field_names r.typename field_names - in - (* Just build a candidate constructor, as we do for Record literals *) - let candidate_constructor = - let lid = lid_of_path ["__dummy__"] p.prange in - S.lid_and_dd_as_fv - lid - (Some - (Unresolved_constructor - ({ uc_base_term = false; - uc_typename = typename; - uc_fields = field_names }))) - in - let loc, aqs, env, annots, pats = - List.fold_left - (fun (loc, aqs, env, annots, pats) p -> - let loc, aqs, env, _, pat, ann = aux loc aqs env p in - loc, aqs, env, ann@annots, (pat, false)::pats) - (loc, aqs, env, [], []) - pats - in - let pats = List.rev pats in - (* TcTerm will look for the Unresolved_constructor qualifier - and resolve the pattern fully in tc_pat *) - let pat = pos <| Pat_cons(candidate_constructor, None, pats) in - let x = S.new_bv (Some p.prange) (tun_r p.prange) in - loc, aqs, env, LocalBinder(x, None, []), pat, annots - and aux loc aqs env p = aux' false loc aqs env p - in - - (* Explode PatOr's and call aux *) - let aux_maybe_or env (p:pattern) = - let loc = [] in - match p.pat with - | PatOr [] -> failwith "impossible" - | PatOr (p::ps) -> - let loc, aqs, env, var, p, ans = aux' true loc [] env p in - let loc, aqs, env, ps = List.fold_left (fun (loc, aqs, env, ps) p -> - let loc, aqs, env, _, p, ans = aux' true loc aqs env p in - loc, aqs, env, (p,ans)::ps) (loc, aqs, env, []) ps in - let pats = ((p,ans)::List.rev ps) in - (env, var, pats), aqs - | _ -> - let loc, aqs, env, var, pat, ans = aux' true loc [] env p in - (env, var, [(pat, ans)]), aqs - in - - let (env, b, pats), aqs = aux_maybe_or env p in - check_linear_pattern_variables (List.map fst pats) p.prange; - (env, b, pats), aqs - -and desugar_binding_pat_maybe_top top env p - : (env_t (* environment with patterns variables pushed in *) - & bnd (* a binder for the pattern *) - & list annotated_pat) (* elaborated patterns with their variable annotations *) - & antiquotations_temp (* antiquotations_temp found in binder types *) - = - - if top then - let mklet x ty (tacopt : option S.term) : (env_t & bnd & list annotated_pat) = - // GM: ^ I seem to need the type annotation here, - // or F* gets confused between tuple2 and tuple3 apparently? - env, LetBinder(qualify env x, (ty, tacopt)), [] - in - let op_to_ident x = mk_ident (compile_op 0 (string_of_id x) (range_of_id x), (range_of_id x)) in - match p.pat with - | PatOp x -> - mklet (op_to_ident x) (tun_r (range_of_id x)) None, [] - | PatVar (x, _, _) -> - mklet x (tun_r (range_of_id x)) None, [] - | PatAscribed({pat=PatOp x}, (t, tacopt)) -> - let tacopt = BU.map_opt tacopt (desugar_term env) in - let t, aq = desugar_term_aq env t in - mklet (op_to_ident x) t tacopt, aq - | PatAscribed({pat=PatVar (x, _, _)}, (t, tacopt)) -> - let tacopt = BU.map_opt tacopt (desugar_term env) in - let t, aq = desugar_term_aq env t in - mklet x t tacopt, aq - | _ -> - raise_error p Errors.Fatal_UnexpectedPattern "Unexpected pattern at the top-level" - else - let (env, binder, p), aq = desugar_data_pat true env p in - let p = match p with - | [{v=Pat_var _}, _] -> [] - | _ -> p in - (env, binder, p), aq - -and desugar_binding_pat_aq env p = desugar_binding_pat_maybe_top false env p - -and desugar_match_pat_maybe_top _ env pat = - let (env, _, pat), aqs = desugar_data_pat false env pat in - (env, pat), aqs - -and desugar_match_pat env p = desugar_match_pat_maybe_top false env p - -and desugar_term_aq env e : S.term & antiquotations_temp = - let env = Env.set_expect_typ env false in - desugar_term_maybe_top false env e - -and desugar_term env e : S.term = - let t, aq = desugar_term_aq env e in - check_no_aq aq; - t - -and desugar_typ_aq env e : S.term & antiquotations_temp = - let env = Env.set_expect_typ env true in - desugar_term_maybe_top false env e - -and desugar_typ env e : S.term = - let t, aq = desugar_typ_aq env e in - check_no_aq aq; - t - -and desugar_machine_integer env repr (signedness, width) range = - let tnm = if width = Sizet then "FStar.SizeT" else - "FStar." ^ - (match signedness with | Unsigned -> "U" | Signed -> "") ^ "Int" ^ - (match width with | Int8 -> "8" | Int16 -> "16" | Int32 -> "32" | Int64 -> "64") - in - //we do a static check of integer constants - //and coerce them to the appropriate type using the internal coercion - // __uint_to_t or __int_to_t - //Rather than relying on a verification condition to check this trivial property - if not (within_bounds repr signedness width) - then FStar.Errors.log_issue range Errors.Error_OutOfRange - (BU.format2 "%s is not in the expected range for %s" repr tnm); - let private_intro_nm = tnm ^ - ".__" ^ (match signedness with | Unsigned -> "u" | Signed -> "") ^ "int_to_t" - in - let intro_nm = tnm ^ - "." ^ (match signedness with | Unsigned -> "u" | Signed -> "") ^ "int_to_t" - in - let lid = lid_of_path (path_of_text intro_nm) range in - let lid = - match Env.try_lookup_lid env lid with - | Some intro_term -> - begin match intro_term.n with - | Tm_fvar fv -> - let private_lid = lid_of_path (path_of_text private_intro_nm) range in - let private_fv = S.lid_and_dd_as_fv private_lid fv.fv_qual in - {intro_term with n=Tm_fvar private_fv} - | _ -> - failwith ("Unexpected non-fvar for " ^ intro_nm) - end - | None -> - raise_error range Errors.Fatal_UnexpectedNumericLiteral - (BU.format1 "Unexpected numeric literal. Restart F* to load %s." tnm) in - let repr' = S.mk (Tm_constant (Const_int (repr, None))) range in - let app = S.mk (Tm_app {hd=lid; args=[repr', S.as_aqual_implicit false]}) range in - S.mk (Tm_meta {tm=app; - meta=Meta_desugared (Machine_integer (signedness, width))}) range - -and desugar_term_maybe_top (top_level:bool) (env:env_t) (top:term) : S.term & antiquotations_temp = - let mk e = S.mk e top.range in - let noaqs = [] in - let join_aqs aqs = List.flatten aqs in - let setpos e = {e with pos=top.range} in - let desugar_binders env binders = - let env, bs_rev = - List.fold_left - (fun (env, bs) b -> - let bb = desugar_binder env b in - let b, env = as_binder env b.aqual bb in - env, b::bs) - (env, []) - binders - in - env, List.rev bs_rev - in - let unqual_bv_of_binder b = - match b with - | {binder_bv=x; binder_qual=None; binder_attrs=[]} -> x - | _ -> - raise_error b Fatal_UnexpectedTerm "Unexpected qualified binder in ELIM_EXISTS" - in - if !dbg_ToSyntax then - BU.print1 "desugaring (%s)\n\n" (show top); - begin match (unparen top).tm with - | Wild -> setpos tun, noaqs - - | Labeled _ -> desugar_formula env top, noaqs - - | Requires (t, lopt) -> - desugar_formula env t, noaqs - - | Ensures (t, lopt) -> - desugar_formula env t, noaqs - - | Attributes ts -> - failwith "Attributes should not be desugared by desugar_term_maybe_top" - // desugar_attributes env ts - - | Const (Const_int (i, Some size)) -> - desugar_machine_integer env i size top.range, noaqs - - | Const c -> - mk (Tm_constant c), noaqs - - | Op(id, args) when string_of_id id = "=!=" -> - let r = range_of_id id in - let e = mk_term (Op(Ident.mk_ident ("==", r), args)) top.range top.level in - desugar_term_aq env (mk_term(Op(Ident.mk_ident ("~",r), [e])) top.range top.level) - - (* if op_Star has not been rebound, then it's reserved for tuples *) - | Op(op_star, [lhs;rhs]) when - (Ident.string_of_id op_star = "*" && - op_as_term env 2 op_star |> Option.isNone) -> - (* See the comment in parse.mly to understand why this implicitly relies - * on the presence of a Paren node in the AST. *) - let rec flatten t = match t.tm with - // * is left-associative - | Op(id, [t1;t2]) when - string_of_id id = "*" && - op_as_term env 2 op_star |> Option.isNone -> - flatten t1 @ [ t2 ] - | _ -> [t] - in - let terms = flatten lhs in - //make the surface syntax for a non-dependent tuple - let t = {top with tm=Sum(List.map Inr terms, rhs)} in - desugar_term_maybe_top top_level env t - - | Tvar a -> - setpos <| (fail_or2 (try_lookup_id env) a), noaqs - - | Uvar u -> - raise_error top Errors.Fatal_UnexpectedUniverseVariable - ("Unexpected universe variable " ^ - string_of_id u ^ - " in non-universe context") - - | Op(s, [f;e]) when Ident.string_of_id s = "<|" -> - desugar_term_maybe_top top_level env (mkApp f [e,Nothing] top.range) - - | Op(s, [e;f]) when Ident.string_of_id s = "|>" -> - desugar_term_maybe_top top_level env (mkApp f [e,Nothing] top.range) - - | Op(s, args) -> - begin - match op_as_term env (List.length args) s with - | None -> - raise_error s Errors.Fatal_UnepxectedOrUnboundOperator - ("Unexpected or unbound operator: " ^ - Ident.string_of_id s) - | Some op -> - if List.length args > 0 then - let args, aqs = args |> List.map (fun t -> let t', s = desugar_term_aq env t in - (t', None), s) |> List.unzip in - mk (Tm_app {hd=op; args}), join_aqs aqs - else - op, noaqs - end - - | Construct (n, [(a, _)]) when (string_of_lid n) = "SMTPat" -> - desugar_term_maybe_top top_level env - ({top with tm = App ({top with tm = Var (smt_pat_lid top.range)}, a, Nothing)}) - - | Construct (n, [(a, _)]) when (string_of_lid n) = "SMTPatT" -> - Errors.log_issue top Errors.Warning_SMTPatTDeprecated "SMTPatT is deprecated; please just use SMTPat"; - desugar_term_maybe_top top_level env - ({top with tm = App ({top with tm = Var (smt_pat_lid top.range) }, a, Nothing)}) - - | Construct (n, [(a, _)]) when (string_of_lid n) = "SMTPatOr" -> - desugar_term_maybe_top top_level env - ({top with tm = App ({top with tm = Var (smt_pat_or_lid top.range)}, a, Nothing)}) - - | Name lid when string_of_lid lid = "Type0" -> - mk (Tm_type U_zero), noaqs - | Name lid when string_of_lid lid = "Type" -> - mk (Tm_type U_unknown), noaqs - | Construct (lid, [t, UnivApp]) when string_of_lid lid = "Type" -> - mk (Tm_type (desugar_universe t)), noaqs - | Name lid when string_of_lid lid = "Effect" -> - mk (Tm_constant Const_effect), noaqs - | Name lid when string_of_lid lid = "True" -> - S.fvar_with_dd (Ident.set_lid_range Const.true_lid top.range) None, - noaqs - | Name lid when string_of_lid lid = "False" -> - S.fvar_with_dd (Ident.set_lid_range Const.false_lid top.range) None, - noaqs - | Projector (eff_name, id) - when is_special_effect_combinator (string_of_id id) && Env.is_effect_name env eff_name -> - (* TODO : would it be possible to normalize the effect name at that point so that *) - (* we get back the original effect definition instead of an effect abbreviation *) - let txt = string_of_id id in - begin match try_lookup_effect_defn env eff_name with - | Some ed -> - let lid = U.dm4f_lid ed txt in - S.fvar_with_dd lid None, noaqs - | None -> - failwith (BU.format2 "Member %s of effect %s is not accessible \ - (using an effect abbreviation instead of the original effect ?)" - (Ident.string_of_lid eff_name) - txt) - end - - | Var l - | Name l -> - desugar_name mk setpos env true l, noaqs - - | Projector (l, i) -> - let name = - match Env.try_lookup_datacon env l with - | Some _ -> Some (true, l) - | None -> - match Env.try_lookup_root_effect_name env l with - | Some new_name -> Some (false, new_name) - | _ -> None - in - begin match name with - | Some (resolve, new_name) -> - desugar_name mk setpos env resolve (mk_field_projector_name_from_ident new_name i), noaqs - | _ -> - raise_error top Errors.Fatal_EffectNotFound (BU.format1 "Data constructor or effect %s not found" (string_of_lid l)) - end - - | Discrim lid -> - begin match Env.try_lookup_datacon env lid with - | None -> - raise_error top Errors.Fatal_DataContructorNotFound (BU.format1 "Data constructor %s not found" (string_of_lid lid)) - | _ -> - let lid' = U.mk_discriminator lid in - desugar_name mk setpos env true lid', noaqs - end - - | Construct(l, args) -> - begin match Env.try_lookup_datacon env l with - | Some head -> - let head = mk (Tm_fvar head) in - begin match args with - | [] -> head, noaqs - | _ -> - let universes, args = BU.take (fun (_, imp) -> imp = UnivApp) args in - let universes = List.map (fun x -> desugar_universe (fst x)) universes in - let args, aqs = List.map (fun (t, imp) -> - let te, aq = desugar_term_aq env t in - arg_withimp_t imp te, aq) args |> List.unzip in - let head = if universes = [] then head else mk (Tm_uinst(head, universes)) in - let tm = - if List.length args = 0 - then head - else mk (Tm_app {hd=head; args}) in - tm, join_aqs aqs - end - | None -> - match Env.try_lookup_effect_name env l with - | None -> - raise_error l Errors.Fatal_ConstructorNotFound - ("Constructor " ^ (string_of_lid l) ^ " not found") - | Some _ -> - raise_error l Errors.Fatal_UnexpectedEffect - ("Effect " ^ (string_of_lid l) ^ " used at an unexpected position") - end - - | Sum(binders, t) - when BU.for_all (function Inr _ -> true | _ -> false) binders -> - //non-dependent tuple - let terms = - (binders |> - List.map (function Inr x -> x | Inl _ -> failwith "Impossible")) - @[t] - in - let targs, aqs = - terms |> - List.map (fun t -> let t', aq = desugar_typ_aq env t in as_arg t', aq) |> - List.unzip - in - let tup = fail_or env (Env.try_lookup_lid env) (C.mk_tuple_lid (List.length targs) top.range) in - mk (Tm_app {hd=tup; args=targs}), join_aqs aqs - - | Sum(binders, t) -> //dependent tuple - let env, _, targs = List.fold_left (fun (env, tparams, typs) b -> - let xopt, t, attrs = - match b with - | Inl b -> desugar_binder env b - | Inr t -> None, desugar_typ env t, [] - in - let env, x = - match xopt with - | None -> env, S.new_bv (Some top.range) (setpos tun) - | Some x -> push_bv env x in - (env, tparams@[mk_binder_with_attrs ({x with sort=t}) None attrs], - typs@[as_arg <| no_annot_abs tparams t])) - (env, [], []) - (binders@[Inl <| mk_binder (NoName t) t.range Type_level None]) in - let tup = fail_or env (try_lookup_lid env) (C.mk_dtuple_lid (List.length targs) top.range) in - mk <| Tm_app {hd=tup; args=targs}, noaqs - - | Product(binders, t) -> - let bs, t = uncurry binders t in - let rec aux env aqs bs = function - | [] -> - let cod = desugar_comp top.range true env t in - setpos <| U.arrow (List.rev bs) cod, aqs - - | hd::tl -> - let bb, aqs' = desugar_binder_aq env hd in - let b, env = as_binder env hd.aqual bb in - aux env (aqs'@aqs) (b::bs) tl - in - aux env [] [] bs - - | Refine(b, f) -> - begin match desugar_binder env b with - | (None, _, _) -> failwith "Missing binder in refinement" - - | b -> - let b, env = as_binder env None b in - let f = desugar_formula env f in - setpos <| U.refine b.binder_bv f, noaqs - end - - | Function (branches, r1) -> - let x = Ident.gen r1 in - let t' = - mk_term (Abs([mk_pattern (PatVar(x,None,[])) r1], - mk_term (Match(mk_term (Var(lid_of_ids [x])) r1 Expr, None, None, branches)) top.range Expr)) - top.range Expr - in - desugar_term_maybe_top top_level env t' - - | Abs(binders, body) -> - (* First of all, forbid definitions such as `f x x = ...` *) - let bvss = List.map gather_pattern_bound_vars binders in - let check_disjoint (sets : list (FlatSet.t ident)) : option ident = - let rec aux acc sets = - match sets with - | [] -> None - | set::sets -> - let i = inter acc set in - if is_empty i - then aux (union acc set) sets - else Some (List.hd (elems i)) - in - aux (empty ()) sets - in - begin match check_disjoint bvss with - | None -> () - | Some id -> - let open FStar.Pprint in - let open FStar.Class.PP in - raise_error id Errors.Fatal_NonLinearPatternNotPermitted [ - text "Non-linear patterns are not permitted."; - text "The variable " ^/^ squotes (pp id) ^/^ text " appears more than once in this function definition." - ] - end; - - let binders = binders |> List.map replace_unit_pattern in - let _, ftv = List.fold_left (fun (env, ftvs) pat -> - match pat.pat with - | PatAscribed(_, (t, None)) -> env, free_type_vars env t@ftvs - | PatAscribed(_, (t, Some tac)) -> env, free_type_vars env t@free_type_vars env tac@ftvs - | _ -> env, ftvs) (env, []) binders in - let ftv = sort_ftv ftv in - let binders = (ftv |> List.map (fun a -> - mk_pattern (PatTvar(a, Some AST.Implicit, [])) top.range)) - @binders in //close over the free type variables - (* - fun (P1 x1) (P2 x2) (P3 x3) -> e - - is desugared to - - fun y1 y2 y3 -> match (y1, y2, y3) with - | (P1 x1, P2 x2, P3 x3) -> [[e]] - *) - let rec aux aqs env bs sc_pat_opt pats : S.term & antiquotations_temp = - match pats with - | [] -> - let body, aq = desugar_term_aq env body in - let body = match sc_pat_opt with - | Some (sc, pat) -> - let body = Subst.close (S.pat_bvs pat |> List.map S.mk_binder) body in - S.mk (Tm_match {scrutinee=sc; - ret_opt=None; - brs=[(pat, None, body)]; - rc_opt=None}) body.pos - | None -> body in - setpos (no_annot_abs (List.rev bs) body), aq@aqs - - | p::rest -> - let (env, b, pat), aq = desugar_binding_pat_aq env p in - let pat = - match pat with - | [] -> None - | [p, _] -> Some p // NB: We ignore the type annotation here, the typechecker catches that anyway in tc_abs - | _ -> - raise_error p Errors.Fatal_UnsupportedDisjuctivePatterns "Disjunctive patterns are not supported in abstractions" - in - let b, sc_pat_opt = - match b with - | LetBinder _ -> failwith "Impossible" - | LocalBinder (x, aq, attrs) -> - let sc_pat_opt = - match pat, sc_pat_opt with - | None, _ -> sc_pat_opt - | Some p, None -> Some (S.bv_to_name x, p) - | Some p, Some (sc, p') -> begin - match sc.n, p'.v with - | Tm_name _, _ -> - let tup2 = S.lid_and_dd_as_fv (C.mk_tuple_data_lid 2 top.range) (Some Data_ctor) in - let sc = S.mk (Tm_app {hd=mk (Tm_fvar tup2); - args=[as_arg sc; as_arg <| S.bv_to_name x]}) top.range in - let p = withinfo (Pat_cons(tup2, None, [(p', false);(p, false)])) (Range.union_ranges p'.p p.p) in - Some(sc, p) - | Tm_app {args}, Pat_cons(_, _, pats) -> - let tupn = S.lid_and_dd_as_fv (C.mk_tuple_data_lid (1 + List.length args) top.range) (Some Data_ctor) in - let sc = mk (Tm_app {hd=mk (Tm_fvar tupn); - args=args@[as_arg <| S.bv_to_name x]}) in - let p = withinfo (Pat_cons(tupn, None, pats@[(p, false)])) (Range.union_ranges p'.p p.p) in - Some(sc, p) - | _ -> failwith "Impossible" - end - in - (mk_binder_with_attrs x aq attrs), sc_pat_opt - in - aux (aq@aqs) env (b::bs) sc_pat_opt rest - in - aux [] env [] None binders - - | App (_, _, UnivApp) -> - let rec aux universes e = match (unparen e).tm with - | App(e, t, UnivApp) -> - let univ_arg = desugar_universe t in - aux (univ_arg::universes) e - | _ -> - let head, aq = desugar_term_aq env e in - mk (Tm_uinst(head, universes)), aq - in aux [] top - - | App (e, t, imp) -> - let head, aq1 = desugar_term_aq env e in - let t, aq2 = desugar_term_aq env t in - let arg = arg_withimp_t imp t in - S.extend_app head arg top.range, aq1@aq2 - - | Bind(x, t1, t2) -> - let xpat = AST.mk_pattern (AST.PatVar(x, None, [])) (range_of_id x) in - let k = AST.mk_term (Abs([xpat], t2)) t2.range t2.level in - let bind_lid = Ident.lid_of_path ["bind"] (range_of_id x) in - let bind = AST.mk_term (AST.Var bind_lid) (range_of_id x) AST.Expr in - desugar_term_aq env (AST.mkExplicitApp bind [t1; k] top.range) - - | Seq(t1, t2) -> - // - // let _ : unit = e1 in e2 - // - let p = mk_pattern (PatWild (None, [])) t1.range in - let p = mk_pattern (PatAscribed (p, (unit_ty p.prange, None))) p.prange in - let t = mk_term (Let(NoLetQualifier, [None, (p, t1)], t2)) top.range Expr in - let tm, s = desugar_term_aq env t in - - // - // keep the Sequence, we will use it for resugaring - // - mk (Tm_meta {tm; meta=Meta_desugared Sequence}), s - - | LetOpen (lid, e) -> - let env = Env.push_namespace env lid Unrestricted in - (if Env.expect_typ env then desugar_typ_aq else desugar_term_aq) env e - - | LetOpenRecord (r, rty, e) -> - let rec head_of (t:term) : term = - match t.tm with - | App (t, _, _) -> head_of t - | _ -> t - in - let tycon = head_of rty in - let tycon_name = - match tycon.tm with - | Var l -> l - | _ -> - raise_error rty Errors.Error_BadLetOpenRecord - (BU.format1 "This type must be a (possibly applied) record name" (term_to_string rty)) - in - let record = - match Env.try_lookup_record_type env tycon_name with - | Some r -> r - | None -> - raise_error rty Errors.Error_BadLetOpenRecord - (BU.format1 "Not a record type: `%s`" (term_to_string rty)) - in - let constrname = lid_of_ns_and_id (ns_of_lid record.typename) record.constrname in - let mk_pattern p = mk_pattern p r.range in - let elab = - let pat = - (* All of the fields are explicit arguments of the constructor, hence the None below *) - mk_pattern (PatApp (mk_pattern (PatName constrname), - List.map (fun (field, _) -> mk_pattern (PatVar (field, None, []))) record.fields)) - in - let branch = (pat, None, e) in - let r = mk_term (Ascribed (r, rty, None, false)) r.range Expr in - { top with tm = Match (r, None, None, [branch]) } - in - desugar_term_maybe_top top_level env elab - - | LetOperator(lets, body) -> - ( match lets with - | [] -> failwith "Impossible: a LetOperator (e.g. let+, let*...) cannot contain zero let binding" - | (letOp, letPat, letDef)::tl -> - let term_of_op op = AST.mk_term (AST.Op (op, [])) (range_of_id op) AST.Expr in - let mproduct_def = fold_left (fun def (andOp, andPat, andDef) -> - AST.mkExplicitApp - (term_of_op andOp) - [def; andDef] top.range - ) letDef tl in - let mproduct_pat = fold_left (fun pat (andOp, andPat, andDef) -> - AST.mk_pattern (AST.PatTuple ([pat; andPat], false)) andPat.prange - ) letPat tl in - let fn = AST.mk_term (Abs([hoist_pat_ascription mproduct_pat], body)) body.range body.level in - let let_op = term_of_op letOp in - let t = AST.mkExplicitApp let_op [mproduct_def; fn] top.range in - desugar_term_aq env t - ) - | Let(qual, lbs, body) -> - let is_rec = qual = Rec in - let ds_let_rec_or_app () = - let bindings = lbs in - let funs = bindings |> List.map (fun (attr_opt, (p, def)) -> - if is_app_pattern p - then attr_opt, destruct_app_pattern env top_level p, def - else match un_function p def with - | Some (p, def) -> attr_opt, destruct_app_pattern env top_level p, def - | _ -> begin match p.pat with - | PatAscribed({pat=PatVar(id,_,_)}, t) -> - if top_level - then attr_opt, (Inr (qualify env id), [], Some t), def - else attr_opt, (Inl id, [], Some t), def - | PatVar(id, _, _) -> - if top_level - then attr_opt, (Inr (qualify env id), [], None), def - else attr_opt, (Inl id, [], None), def - | _ -> raise_error p Errors.Fatal_UnexpectedLetBinding "Unexpected let binding" - end) - in - - //Generate fresh names and populate an env' with recursive bindings - //below, we use env' instead of env, only if is_rec - let env', fnames, rec_bindings, used_markers = - List.fold_left (fun (env, fnames, rec_bindings, used_markers) (_attr_opt, (f, _, _), _) -> - let env, lbname, rec_bindings, used_markers = match f with - | Inl x -> - let env, xx, used_marker = push_bv' env x in - let dummy_ref = BU.mk_ref true in - env, Inl xx, S.mk_binder xx::rec_bindings, used_marker::used_markers - | Inr l -> - let env, used_marker = push_top_level_rec_binding env (ident_of_lid l) in - env, Inr l, rec_bindings, used_marker::used_markers in - env, (lbname::fnames), rec_bindings, used_markers) (env, [], [], []) funs - in - - let fnames = List.rev fnames in - let rec_bindings = List.rev rec_bindings in - let used_markers = List.rev used_markers in - (* This comment is taken from Syntax.Subst.open_let_rec - The desugaring of let recs has to be consistent with their opening - - Consider - let rec f x = g x - and g y = f y in - f 0, g 0 - In de Bruijn notation, this is - let rec f x = g@1 x@0 - and g y = f@2 y@0 in - f@1 0, g@0 0 - i.e., the recursive environment for f is, in order: - u, f, g, x - for g is - u, f, g, y - and for the body is - f, g - *) - let desugar_one_def env lbname (attrs_opt, (_, args, result_t), def) - : letbinding & antiquotations_temp - = - let args = args |> List.map replace_unit_pattern in - let pos = def.range in - let def = - match result_t with - | None -> def - | Some (t, tacopt) -> - let t = - if is_comp_type env t - then let _ = - match args |> List.tryFind (fun x -> not (is_var_pattern x)) with - | None -> () - | Some p -> - raise_error p Errors.Fatal_ComputationTypeNotAllowed - ("Computation type annotations are only permitted on let-bindings \ - without inlined patterns; \ - replace this pattern with a variable") in - t - else if Options.ml_ish () //we're type-checking the compiler itself, e.g. - && Option.isSome (Env.try_lookup_effect_name env (C.effect_ML_lid())) //ML is in scope (not still in prims, e.g) - && (not is_rec || List.length args <> 0) //and we don't have something like `let rec f : t -> t' = fun x -> e` - then AST.ml_comp t - else AST.tot_comp t - in - mk_term (Ascribed(def, t, tacopt, false)) def.range Expr - in - let def = match args with - | [] -> def - | _ -> mk_term (un_curry_abs args def) top.range top.level in - let body, aq = desugar_term_aq env def in - let lbname = match lbname with - | Inl x -> Inl x - | Inr l -> Inr (S.lid_and_dd_as_fv l None) in - let body = if is_rec then Subst.close rec_bindings body else body in - let attrs = match attrs_opt with - | None -> [] - | Some l -> List.map (desugar_term env) l - in - mk_lb (attrs, lbname, setpos tun, body, pos), aq - in - let lbs, aqss = - List.map2 (desugar_one_def (if is_rec then env' else env)) fnames funs - |> List.unzip - in - let body, aq = desugar_term_aq env' body in - if is_rec then begin - List.iter2 (fun (_attr_opt, (f, _, _), _) used_marker -> - if not !used_marker then - let nm, gl, rng = - match f with - | Inl x -> (string_of_id x, "Local binding", range_of_id x) - | Inr l -> (string_of_lid l, "Global binding", range_of_lid l) - in - let open FStar.Errors.Msg in - let open FStar.Pprint in - Errors.log_issue rng Errors.Warning_UnusedLetRec [ - surround 4 1 (text gl) - (squotes (doc_of_string nm)) - (text "is recursive but not used in its body") - ] - ) funs used_markers - end; - mk <| (Tm_let {lbs=(is_rec, lbs); body=Subst.close rec_bindings body}), aq @ List.flatten aqss - in - //end ds_let_rec_or_app - - let ds_non_rec attrs_opt pat t1 t2 = - let attrs = - match attrs_opt with - | None -> [] - | Some l -> List.map (desugar_term env) l - in - let t1, aq0 = desugar_term_aq env t1 in - let (env, binder, pat), aqs = desugar_binding_pat_maybe_top top_level env pat in - check_no_aq aqs; - let tm, aq1 = - match binder with - | LetBinder(l, (t, tacopt)) -> - if tacopt |> is_some - then Errors.log_issue (tacopt |> must) Errors.Warning_DefinitionNotTranslated - "Tactic annotation with a value type is not supported yet, \ - try annotating with a computation type; this tactic annotation will be ignored"; - let body, aq = desugar_term_aq env t2 in - let fv = S.lid_and_dd_as_fv l None in - mk <| Tm_let {lbs=(false, [mk_lb (attrs, Inr fv, t, t1, t1.pos)]); body}, aq - - | LocalBinder (x,_,_) -> - // TODO unsure if keep _ or [] on second comp below - let body, aq = desugar_term_aq env t2 in - let body = match pat with - | [] -> body - | _ -> - S.mk (Tm_match {scrutinee=S.bv_to_name x; - ret_opt=None; - brs=desugar_disjunctive_pattern pat None body; - rc_opt=None}) top.range - in - mk <| Tm_let {lbs=(false, [mk_lb (attrs, Inl x, x.sort, t1, t1.pos)]); - body=Subst.close [S.mk_binder x] body}, aq - in - tm, aq0 @ aq1 - in - - let attrs, (head_pat, defn) = List.hd lbs in - if is_rec - || is_app_pattern head_pat - then ds_let_rec_or_app() - else ds_non_rec attrs head_pat defn body - - | If(e, Some op, asc_opt, t2, t3) -> - // A if operator is desugared into a let operator binding - // with name "uu___if_op_head" followed by a regular if on - // "uu___if_op_head" - let var_id = mk_ident(reserved_prefix ^ "if_op_head", e.range) in - let var = mk_term (Var (lid_of_ids [var_id])) e.range Expr in - let pat = mk_pattern (PatVar (var_id, None, [])) e.range in - let if_ = mk_term (If (var, None, asc_opt, t2, t3)) top.range Expr in - let t = mk_term (LetOperator ([(op, pat, e)], if_)) e.range Expr in - desugar_term_aq env t - - | If(t1, None, asc_opt, t2, t3) -> - let x = Syntax.new_bv (Some t3.range) (tun_r t3.range) in - let t_bool = mk (Tm_fvar(S.lid_and_dd_as_fv C.bool_lid None)) in - let t1', aq1 = desugar_term_aq env t1 in - let t1' = U.ascribe t1' (Inl t_bool, None, false) in - let asc_opt, aq0 = desugar_match_returns env t1' asc_opt in - let t2', aq2 = desugar_term_aq env t2 in - let t3', aq3 = desugar_term_aq env t3 in - mk (Tm_match {scrutinee=t1'; - ret_opt=asc_opt; - brs=[(withinfo (Pat_constant (Const_bool true)) t1.range, None, t2'); - (withinfo (Pat_var x) t1.range, None, t3')]; - rc_opt=None}), join_aqs [aq1;aq0;aq2;aq3] - - | TryWith(e, branches) -> - let r = top.range in - let handler = mk_function branches r r in - let body = mk_function [(mk_pattern (PatConst Const_unit) r, None, e)] r r in - let try_with_lid = Ident.lid_of_path ["try_with"] r in - let try_with = AST.mk_term (AST.Var try_with_lid) r AST.Expr in - let a1 = mk_term (App(try_with, body, Nothing)) r top.level in - let a2 = mk_term (App(a1, handler, Nothing)) r top.level in - desugar_term_aq env a2 - - | Match(e, Some op, topt, branches) -> - // A match operator is desugared into a let operator binding - // with name "uu___match_op_head" followed by a regular match on - // "uu___match_op_head" - let var_id = mk_ident(reserved_prefix ^ "match_op_head", e.range) in - let var = mk_term (Var (lid_of_ids [var_id])) e.range Expr in - let pat = mk_pattern (PatVar (var_id, None, [])) e.range in - let mt = mk_term (Match (var, None, topt, branches)) top.range Expr in - let t = mk_term (LetOperator ([(op, pat, e)], mt)) e.range Expr in - desugar_term_aq env t - | Match(e, None, topt, branches) -> - let desugar_branch (pat, wopt, b) = - let (env, pat), aqP = desugar_match_pat env pat in - let wopt = match wopt with - | None -> None - | Some e -> Some (desugar_term env e) - in - let b, aqB = desugar_term_aq env b in - desugar_disjunctive_pattern pat wopt b, aqP@aqB - in - let e, aq = desugar_term_aq env e in - let asc_opt, aq0 = desugar_match_returns env e topt in - let brs, aqs = List.map desugar_branch branches |> List.unzip |> (fun (x, y) -> (List.flatten x, y)) in - mk <| Tm_match {scrutinee=e;ret_opt=asc_opt;brs;rc_opt=None}, join_aqs (aq::aq0::aqs) - - | Ascribed(e, t, tac_opt, use_eq) -> - let asc, aq0 = desugar_ascription env t tac_opt use_eq in - let e, aq = desugar_term_aq env e in - mk <| Tm_ascribed {tm=e; asc; eff_opt=None}, aq0@aq - - | Record(_, []) -> - raise_error top Errors.Fatal_UnexpectedEmptyRecord "Unexpected empty record" - - | Record(eopt, fields) -> - (* Record literals have to wait for type information to be fully resolved *) - let record_opt = - let (f, _) = List.hd fields in - try_lookup_record_by_field_name env f - in - let fields, aqs = - List.map - (fun (fn, fval) -> - let fval, aq = desugar_term_aq env fval in - (fn, fval), aq) - fields - |> List.unzip - in - (* Note, we have to unzip the fields and maintain the field - names in the qualifier and the field assignments in the term. - - This is because the qualifiers intentionally are not meant to - contain terms (only lidents, fv etc.). - - If they did contain terms, then we'd have to substitute in - them, close, open etc. which I wanted to avoid. - *) - let field_names, assignments = List.unzip fields in - let args = List.map (fun f -> f, None) assignments in - let aqs = List.flatten aqs in - let uc = - match record_opt with - | None -> - { uc_base_term = Option.isSome eopt; - uc_typename = None; - uc_fields = field_names } - | Some record -> - { uc_base_term = Option.isSome eopt; - uc_typename = Some record.typename; - uc_fields = qualify_field_names record.typename field_names } - in - let head = - let lid = lid_of_path ["__dummy__"] top.range in - S.fvar_with_dd lid - (Some (Unresolved_constructor uc)) - in - let mk_result args = S.mk_Tm_app head args top.range in - begin - match eopt with - | None -> mk_result args, aqs - | Some e -> - let e, aq = desugar_term_aq env e in - let tm = - match (SS.compress e).n with - | Tm_name _ - | Tm_fvar _ -> - //no need to hoist - mk_result ((e, None)::args) - | _ -> - (* If the base term is not a name, we hoist it *) - let x = FStar.Ident.gen e.pos in - let env', bv_x = push_bv env x in - let nm = S.bv_to_name bv_x in - let body = mk_result ((nm, None)::args) in - let body = SS.close [S.mk_binder bv_x] body in - let lb = mk_lb ([], Inl bv_x, S.tun, e, e.pos) in - mk (Tm_let {lbs=(false, [lb]); body}) - in - tm, - aq@aqs - end - - | Project(e, f) -> - (* Projections have to wait for type information to be fully resolved *) - let e, s = desugar_term_aq env e in - let head = - match try_lookup_dc_by_field_name env f with - | None -> - S.fvar_with_dd f (Some (Unresolved_projector None)) - - | Some (constrname, is_rec) -> - let projname = mk_field_projector_name_from_ident constrname (ident_of_lid f) in - let qual = if is_rec then Some (Record_projector (constrname, ident_of_lid f)) else None in - let candidate_projector = S.lid_and_dd_as_fv (Ident.set_lid_range projname top.range) qual in - let qual = Unresolved_projector (Some candidate_projector) in - let f = List.hd (qualify_field_names constrname [f]) in - S.fvar_with_dd f (Some qual) - in - //The fvar at the head of the term just records the fieldname that the user wrote - //and in TcTerm, we use that field name combined with type info to disambiguate - mk <| Tm_app {hd=head; args=[as_arg e]}, s - - | NamedTyp(n, e) -> - (* See issue #1905 *) - log_issue n Warning_IgnoredBinding "This name is being ignored"; - desugar_term_aq env e - - | Paren e -> failwith "impossible" - - | VQuote e -> - { U.exp_string (desugar_vquote env e top.range) with pos = e.range }, noaqs - - | Quote (e, Static) -> - let tm, vts = desugar_term_aq env e in - let vt_binders = List.map (fun (bv, _tm) -> S.mk_binder bv) vts in - let vt_tms = List.map snd vts in // not closing these, they are already well-scoped - let tm = SS.close vt_binders tm in // but we need to close the variables in tm - let () = - let fvs = Free.names tm in - if not (is_empty fvs) then - raise_error e Errors.Fatal_MissingFieldInRecord - (BU.format1 "Static quotation refers to external variables: %s" (show fvs)) - in - - let qi = { qkind = Quote_static; antiquotations = (0, vt_tms) } in - mk <| Tm_quoted (tm, qi), noaqs - - | Antiquote e -> - let bv = S.new_bv (Some e.range) S.tun in - (* We use desugar_term, so there can be double antiquotations *) - let tm = desugar_term env e in - S.bv_to_name bv, [(bv, tm)] - - | Quote (e, Dynamic) -> - let qi = { qkind = Quote_dynamic - ; antiquotations = (0, []) - } in - mk <| Tm_quoted (desugar_term env e, qi), noaqs - - | CalcProof (rel, init_expr, steps) -> - (* We elaborate it into surface syntax and recursively desugar it *) - - let is_impl (rel:term) : bool = - let is_impl_t (t:S.term) : bool = - match t.n with - | Tm_fvar fv -> S.fv_eq_lid fv C.imp_lid - | _ -> false - in - match (unparen rel).tm with - | Op (id, _) -> - begin match op_as_term env 2 id with - | Some t -> is_impl_t t - | None -> false - end - - | Var lid -> - begin match desugar_name' (fun x->x) env true lid with - | Some t -> is_impl_t t - | None -> false - end - | Tvar id -> - (* GM: This case does not seem exercised even if the user writes "l_imp" - * as the relation... I thought those are meant to be Tvar nodes but - * it ends up as a Var. Bug? *) - begin match try_lookup_id env id with - | Some t -> is_impl_t t - | None -> false - end - | _ -> false - in - - (* Annoying: (<) is not a preorder since it has type - * `int -> int -> Tot bool`, and it's not subtyped to - * `int -> int -> Tot Type0`, so we eta-expand and annotate - * to make it kick in. *) - let eta_and_annot rel = - let x = Ident.gen' "x" rel.range in - let y = Ident.gen' "y" rel.range in - let xt = mk_term (Tvar x) rel.range Expr in - let yt = mk_term (Tvar y) rel.range Expr in - let pats = [mk_pattern (PatVar (x, None, [])) rel.range; mk_pattern (PatVar (y, None,[])) rel.range] in - mk_term (Abs (pats, - mk_term (Ascribed ( - mkApp rel [(xt, Nothing); (yt, Nothing)] rel.range, - mk_term (Name (Ident.lid_of_str "Type0")) rel.range Expr, - None, false)) rel.range Expr)) rel.range Expr - in - let rel = eta_and_annot rel in - - let wild r = mk_term Wild r Expr in - let init = mk_term (Var C.calc_init_lid) init_expr.range Expr in - let push_impl r = mk_term (Var C.calc_push_impl_lid) r Expr in - let last_expr = match List.last_opt steps with - | Some (CalcStep (_, _, last_expr)) -> last_expr - | None -> init_expr - in - let step r = mk_term (Var C.calc_step_lid) r Expr in - let finish = mkApp (mk_term (Var C.calc_finish_lid) top.range Expr) [(rel, Nothing)] top.range in - - let e = mkApp init [(init_expr, Nothing)] init_expr.range in - let (e, _) = List.fold_left (fun (e, prev) (CalcStep (rel, just, next_expr)) -> - let just = - if is_impl rel - then mkApp (push_impl just.range) [(thunk just, Nothing)] just.range - else just - in - let pf = mkApp (step rel.range) - [(wild rel.range, Hash); - (init_expr, Hash); - (prev, Hash); - (eta_and_annot rel, Nothing); (next_expr, Nothing); - (thunk e, Nothing); (thunk just, Nothing)] - Range.dummyRange // GM: using any other range here - // seems to make things worse, - // see test_1763 in - // tests/error-messages/Calc.fst. - // A mistery for some later day. - in - (pf, next_expr)) - (e, init_expr) steps in - let e = mkApp finish [(init_expr, Hash); (last_expr, Hash); (thunk e, Nothing)] top.range in - desugar_term_maybe_top top_level env e - - | IntroForall (bs, p, e) -> - let env', bs = desugar_binders env bs in - let p = desugar_term env' p in - let e = desugar_term env' e in - (* - forall_intro a0 (fun x0 -> forall xs. p) (fun x0 -> - forall_intro a1 (fun x1 -> forall xs. p) (fun x1 -> - ... - forall_intro an (fun xn -> p) (fun xn -> e))) - *) - let mk_forall_intro t p pf = - let head = S.fv_to_tm (S.lid_and_dd_as_fv C.forall_intro_lid None) in - let args = [(t, None); - (p, None); - (pf, None)] in - S.mk_Tm_app head args top.range - in - let rec aux bs = - match bs with - | [] -> - let sq_p = U.mk_squash U_unknown p in - U.ascribe e (Inl sq_p, None, false) - - | b::bs -> - let tail = aux bs in - let x = unqual_bv_of_binder b in - mk_forall_intro - x.sort - (U.abs [b] (U.close_forall_no_univs bs p) None) - (U.abs [b] tail None) - in - aux bs, noaqs - - | IntroExists (bs, p, vs, e) -> - let env', bs = desugar_binders env bs in - let p = desugar_term env' p in - let vs = List.map (desugar_term env) vs in - let e = desugar_term env e in - (* - (exists_intro a1 (fun x1 -> exists xs. p) - (exists_intro a2 (fun x2 -> exists xs.p[v1/x1]) - ... - (exists_intro an (fun xn -> p[vs/xs]) vn e))) - - *) - let mk_exists_intro t p v e = - let head = S.fv_to_tm (S.lid_and_dd_as_fv C.exists_intro_lid None) in - let args = [(t, None); - (p, None); - (v, None); - (mk_thunk e, None)] in - S.mk_Tm_app head args top.range - in - let rec aux bs vs sub token = - match bs, vs with - | [], [] -> token - | b::bs, v::vs -> - let x = unqual_bv_of_binder b in - let token = aux (SS.subst_binders (NT(x, v)::sub) bs) vs (NT(x, v)::sub) token in - let token = - mk_exists_intro - x.sort - (U.abs [b] (close_exists_no_univs bs (SS.subst sub p)) None) - v - token - in - token - | _ -> - raise_error top Fatal_UnexpectedTerm "Unexpected number of instantiations in _intro_ exists" - in - aux bs vs [] e, noaqs - - | IntroImplies (p, q, x, e) -> - let p = desugar_term env p in - let q = desugar_term env q in - let env', [x] = desugar_binders env [x] in - let e = desugar_term env' e in - let head = S.fv_to_tm (S.lid_and_dd_as_fv C.implies_intro_lid None) in - let args = [(p, None); - (mk_thunk q, None); - (U.abs [x] e None, None)] in - S.mk_Tm_app head args top.range, noaqs - - - | IntroOr (lr, p, q, e) -> - let p = desugar_term env p in - let q = desugar_term env q in - let e = desugar_term env e in - let lid = - if lr - then C.or_intro_left_lid - else C.or_intro_right_lid - in - let head = S.fv_to_tm (S.lid_and_dd_as_fv lid None) in - let args = [(p, None); - (mk_thunk q, None); - (mk_thunk e, None)] in - S.mk_Tm_app head args top.range, noaqs - - | IntroAnd (p, q, e1, e2) -> - let p = desugar_term env p in - let q = desugar_term env q in - let e1 = desugar_term env e1 in - let e2 = desugar_term env e2 in - let head = S.fv_to_tm (S.lid_and_dd_as_fv C.and_intro_lid None) in - let args = [(p, None); - (mk_thunk q, None); - (mk_thunk e1, None); - (mk_thunk e2, None)] in - S.mk_Tm_app head args top.range, noaqs - - | ElimForall (bs, p, vs) -> - let env', bs = desugar_binders env bs in - let p = desugar_term env' p in - let vs = List.map (desugar_term env) vs in - (* - (forall_elim #an #(fun xn -> p[vs/xs]) vn - ... - (forall_elim #a1 #(fun x1 -> forall xs. p[v0/x]) v1 - (forall_elim #a0 #(fun x0 -> forall xs. p) v0 ()))) - *) - let mk_forall_elim a p v tok = - let head = S.fv_to_tm (S.lid_and_dd_as_fv C.forall_elim_lid None) in - let args = [(a, S.as_aqual_implicit true); - (p, S.as_aqual_implicit true); - (v, None); - (tok, None)] in - S.mk_Tm_app head args tok.pos - in - let rec aux bs vs sub token : S.term = - match bs, vs with - | [], [] -> token - | b::bs, v::vs -> - let x = unqual_bv_of_binder b in - let token = - mk_forall_elim - x.sort - (U.abs [b] (U.close_forall_no_univs bs (SS.subst sub p)) None) - v - token - in - let sub = NT(x, v)::sub in - aux (SS.subst_binders sub bs) vs sub token - | _ -> - raise_error top Fatal_UnexpectedTerm "Unexpected number of instantiations in _elim_forall_" - in - let range = List.fold_right (fun bs r -> Range.union_ranges (S.range_of_bv bs.binder_bv) r) bs p.pos in - aux bs vs [] { U.exp_unit with pos = range }, noaqs - - | ElimExists (binders, p, q, binder, e) -> ( - let env', bs = desugar_binders env binders in - let p = desugar_term env' p in - let q = desugar_term env q in - let sq_q = U.mk_squash U_unknown q in - let env'', [b_pf_p] = desugar_binders env' [binder] in - let e = desugar_term env'' e in - let rec mk_exists bs p = - match bs with - | [] -> failwith "Impossible" - | [b] -> - let x = b.binder_bv in - let head = S.fv_to_tm (S.lid_and_dd_as_fv C.exists_lid None) in - let args = [(x.sort, S.as_aqual_implicit true); - (U.abs [List.hd bs] p None, None)] in - S.mk_Tm_app head args p.pos - | b::bs -> - let body = mk_exists bs p in - mk_exists [b] body - in - let mk_exists_elim t x_p s_ex_p f r = - let head = S.fv_to_tm (S.lid_and_dd_as_fv C.exists_elim_lid None) in - let args = [(t, S.as_aqual_implicit true); - (x_p, S.as_aqual_implicit true); - (s_ex_p, None); - (f, None)] in - mk_Tm_app head args r - in - let rec aux binders squash_token = - match binders with - | [] -> raise_error top Fatal_UnexpectedTerm "Empty binders in ELIM_EXISTS" - | [b] -> - let x = unqual_bv_of_binder b in - (* - exists_elim - #(x.sort) - #(fun b -> p) - squash_token - (fun b pf_p -> e) - *) - mk_exists_elim - x.sort - (U.abs [b] p None) - squash_token - (U.abs [b;b_pf_p] (U.ascribe e (Inl sq_q, None, false)) None) - squash_token.pos - - | b::bs -> - let pf_i = - S.gen_bv "pf" - (Some (range_of_bv b.binder_bv)) - S.tun - in - let k = aux bs (S.bv_to_name pf_i) in - let x = unqual_bv_of_binder b in - (* - exists_elim - #(x.sort) - #(fun b -> exists bs. p) - squash_token - (fun b pf_i -> k) - *) - mk_exists_elim - x.sort - (U.abs [b] (mk_exists bs p) None) - squash_token - (U.abs [b; S.mk_binder pf_i] k None) - squash_token.pos - in - let range = List.fold_right (fun bs r -> Range.union_ranges (S.range_of_bv bs.binder_bv) r) bs p.pos in - aux bs { U.exp_unit with pos = range }, noaqs - ) - - | ElimImplies (p, q, e) -> - let p = desugar_term env p in - let q = desugar_term env q in - let e = desugar_term env e in - let head = S.fv_to_tm (S.lid_and_dd_as_fv C.implies_elim_lid None) in - let args = [(p, None); - (q, None); - ({ U.exp_unit with pos = Range.union_ranges p.pos q.pos }, None); - (mk_thunk e, None)] in - mk_Tm_app head args top.range, noaqs - - | ElimOr(p, q, r, x, e1, y, e2) -> - let p = desugar_term env p in - let q = desugar_term env q in - let r = desugar_term env r in - let env_x, [x] = desugar_binders env [x] in - let e1 = desugar_term env_x e1 in - let env_y, [y] = desugar_binders env [y] in - let e2 = desugar_term env_y e2 in - let head = S.fv_to_tm (S.lid_and_dd_as_fv C.or_elim_lid None) in - let extra_binder = S.mk_binder (S.new_bv None S.tun) in - let args = [(p, None); - (mk_thunk q, None); - (r, None); - ({ U.exp_unit with pos = Range.union_ranges p.pos q.pos }, None); - (U.abs [x] e1 None, None); - (U.abs [extra_binder; y] e2 None, None)] in - mk_Tm_app head args top.range, noaqs - - | ElimAnd(p, q, r, x, y, e) -> - let p = desugar_term env p in - let q = desugar_term env q in - let r = desugar_term env r in - let env', [x;y] = desugar_binders env [x;y] in - let e = desugar_term env' e in - let head = S.fv_to_tm (S.lid_and_dd_as_fv C.and_elim_lid None) in - let args = [(p, None); - (mk_thunk q, None); - (r, None); - ({ U.exp_unit with pos = Range.union_ranges p.pos q.pos }, None); - (U.abs [x;y] e None, None)] in - mk_Tm_app head args top.range, noaqs - - | ListLiteral ts -> - let nil r = mk_term (Construct (C.nil_lid, [])) r Expr in - let cons r hd tl= mk_term (Construct (C.cons_lid, [ (hd, Nothing); (tl, Nothing)])) r Expr in - let t' = List.fold_right (cons top.range) ts (nil top.range) in - desugar_term_aq env t' - - | SeqLiteral ts -> - let nil r = mk_term (Var C.seq_empty_lid) r Expr in - let cons r hd tl = mkApp (mk_term (Var C.seq_cons_lid) r Expr) [ (hd, Nothing); (tl, Nothing)] r in - let t' = List.fold_right (cons top.range) ts (nil top.range) in - desugar_term_aq env t' - - | _ when (top.level=Formula) -> desugar_formula env top, noaqs - - | _ -> - raise_error top Fatal_UnexpectedTerm ("Unexpected term: " ^ term_to_string top) - end - -and desugar_match_returns env scrutinee asc_opt = - match asc_opt with - | None -> None, [] - | Some asc -> - let asc_b, asc_tc, asc_use_eq = asc in - let env_asc, b = - match asc_b with - | None -> - //no binder is specified, generate a fresh one - let bv = S.gen_bv C.match_returns_def_name (Some scrutinee.pos) S.tun in - env, S.mk_binder bv - | Some b -> - let env, bv = Env.push_bv env b in - env, S.mk_binder bv in - let asc, aq = desugar_ascription env_asc asc_tc None asc_use_eq in - //if scrutinee is a name, it may appear in the ascription - // substitute it with the (new or annotated) binder - let asc = - match (scrutinee |> U.unascribe).n with - | Tm_name sbv -> SS.subst_ascription [NT (sbv, S.bv_to_name b.binder_bv)] asc - | _ -> asc in - let asc = SS.close_ascription [b] asc in - let b = List.hd (SS.close_binders [b]) in - Some (b, asc), aq - -and desugar_ascription env t tac_opt use_eq : S.ascription & antiquotations_temp = - let annot, aq0 = - if is_comp_type env t - then if use_eq - then raise_error t Errors.Fatal_NotSupported "Equality ascription with computation types is not supported yet" - else let comp = desugar_comp t.range true env t in - (Inr comp, []) - else let tm, aq = desugar_term_aq env t in - (Inl tm, aq) in - (annot, BU.map_opt tac_opt (desugar_term env), use_eq), aq0 - -and desugar_args env args = - args |> List.map (fun (a, imp) -> arg_withimp_t imp (desugar_term env a)) - -and desugar_comp r (allow_type_promotion:bool) env t = - let fail #a code msg : a= raise_error r code msg in - let is_requires (t, _) = match (unparen t).tm with - | Requires _ -> true - | _ -> false - in - let is_ensures (t, _) = match (unparen t).tm with - | Ensures _ -> true - | _ -> false - in - let is_decreases (t, _) = match (unparen t).tm with - | Decreases _ -> true - | _ -> false - in - let is_smt_pat1 (t:term) : bool = - match (unparen t).tm with - // TODO: remove this first match once we fully migrate - | Construct (smtpat, _) -> - BU.for_some (fun s -> (string_of_lid smtpat) = s) - (* the smt pattern does not seem to be disambiguated yet at this point *) - ["SMTPat"; "SMTPatT"; "SMTPatOr"] - (* [C.smtpat_lid ; C.smtpatT_lid ; C.smtpatOr_lid] *) - - | Var smtpat -> - BU.for_some (fun s -> (string_of_lid smtpat) = s) - (* the smt pattern does not seem to be disambiguated yet at this point *) - ["smt_pat" ; "smt_pat_or"] - (* [C.smtpat_lid ; C.smtpatT_lid ; C.smtpatOr_lid] *) - - | _ -> false - in - let is_smt_pat (t,_) : bool = - match (unparen t).tm with - | ListLiteral ts -> BU.for_all is_smt_pat1 ts - | _ -> false - in - let pre_process_comp_typ (t:AST.term) = - let head, args = head_and_args t in - match head.tm with - | Name lemma when ((string_of_id (ident_of_lid lemma)) = "Lemma") -> - (* need to add the unit result type and the empty smt_pat list, if n *) - let unit_tm = mk_term (Name C.unit_lid) t.range Type_level, Nothing in - let nil_pat = mk_term (Name C.nil_lid) t.range Expr, Nothing in - let req_true = - let req = Requires (mk_term (Name C.true_lid) t.range Formula, None) in - mk_term req t.range Type_level, Nothing - in - (* The postcondition for Lemma is thunked, to allow to assume the precondition - * (c.f. #57), so add the thunking here *) - let thunk_ens (e, i) = (thunk e, i) in - let fail_lemma () = - let open FStar.Pprint in - let expected_one_of = ["Lemma post"; - "Lemma (ensures post)"; - "Lemma (requires pre) (ensures post)"; - "Lemma post [SMTPat ...]"; - "Lemma (ensures post) [SMTPat ...]"; - "Lemma (ensures post) (decreases d)"; - "Lemma (ensures post) (decreases d) [SMTPat ...]"; - "Lemma (requires pre) (ensures post) (decreases d)"; - "Lemma (requires pre) (ensures post) [SMTPat ...]"; - "Lemma (requires pre) (ensures post) (decreases d) [SMTPat ...]"] in - raise_error t Errors.Fatal_InvalidLemmaArgument [ - text "Invalid arguments to 'Lemma'; expected one of the following" - ^^ sublist empty (List.map doc_of_string expected_one_of) - ] - in - let args = match args with - | [] -> fail_lemma () - - | [req] //a single requires clause (cf. Issue #1208) - when is_requires req -> - fail_lemma() - - | [smtpat] - when is_smt_pat smtpat -> - fail_lemma() - - | [dec] - when is_decreases dec -> - fail_lemma() - - | [ens] -> //otherwise, a single argument is always treated as just an ensures clause - [unit_tm;req_true;thunk_ens ens;nil_pat] - - | [req;ens] - when is_requires req - && is_ensures ens -> - [unit_tm;req;thunk_ens ens;nil_pat] - - | [ens;smtpat] //either Lemma p [SMTPat ...]; or Lemma (ensures p) [SMTPat ...] - when not (is_requires ens) - && not (is_smt_pat ens) - && not (is_decreases ens) - && is_smt_pat smtpat -> - [unit_tm;req_true;thunk_ens ens;smtpat] - - | [ens;dec] - when is_ensures ens - && is_decreases dec -> - [unit_tm;req_true;thunk_ens ens;nil_pat;dec] - - | [ens;dec;smtpat] - when is_ensures ens - && is_decreases dec - && is_smt_pat smtpat -> - [unit_tm;req_true;thunk_ens ens;smtpat;dec] - - | [req;ens;dec] - when is_requires req - && is_ensures ens - && is_decreases dec -> - [unit_tm;req;thunk_ens ens;nil_pat;dec] - - | [req;ens;smtpat] - when is_requires req - && is_ensures ens - && is_smt_pat smtpat -> - [unit_tm;req;thunk_ens ens;smtpat] - - | [req;ens;dec;smtpat] - when is_requires req - && is_ensures ens - && is_smt_pat smtpat - && is_decreases dec -> - [unit_tm;req;thunk_ens ens;dec;smtpat] - - | _other -> - fail_lemma() - in - let head_and_attributes = fail_or env - (Env.try_lookup_effect_name_and_attributes env) - lemma in - head_and_attributes, args - - | Name l when Env.is_effect_name env l -> - (* we have an explicit effect annotation ... no need to add anything *) - fail_or env (Env.try_lookup_effect_name_and_attributes env) l, args - - - (* we're right at the beginning of Prims, when Tot isn't yet fully defined *) - | Name l when (lid_equals (Env.current_module env) C.prims_lid - && (string_of_id (ident_of_lid l)) = "Tot") -> - (* we have an explicit effect annotation ... no need to add anything *) - (Ident.set_lid_range Const.effect_Tot_lid head.range, []), args - - (* we're right at the beginning of Prims, when GTot isn't yet fully defined *) - | Name l when (lid_equals (Env.current_module env) C.prims_lid - && (string_of_id (ident_of_lid l)) = "GTot") -> - (* we have an explicit effect annotation ... no need to add anything *) - (Ident.set_lid_range Const.effect_GTot_lid head.range, []), args - - | Name l when ((string_of_id (ident_of_lid l))="Type" - || (string_of_id (ident_of_lid l))="Type0" - || (string_of_id (ident_of_lid l))="Effect") -> - (* the default effect for Type is always Tot *) - (Ident.set_lid_range Const.effect_Tot_lid head.range, []), [t, Nothing] - - | _ when allow_type_promotion -> - let default_effect = - if Options.ml_ish () - then Const.effect_ML_lid() - else (if Options.warn_default_effects() - then FStar.Errors.log_issue head Errors.Warning_UseDefaultEffect "Using default effect Tot"; - Const.effect_Tot_lid) in - (Ident.set_lid_range default_effect head.range, []), [t, Nothing] - - | _ -> - raise_error t Errors.Fatal_EffectNotFound "Expected an effect constructor" - in - let (eff, cattributes), args = pre_process_comp_typ t in - if List.length args = 0 then - fail Errors.Fatal_NotEnoughArgsToEffect (BU.format1 "Not enough args to effect %s" (show eff)); - let is_universe (_, imp) = imp = UnivApp in - let universes, args = BU.take is_universe args in - let universes = List.map (fun (u, imp) -> desugar_universe u) universes in - let result_arg, rest = List.hd args, List.tl args in - let result_typ = desugar_typ env (fst result_arg) in - let dec, rest = - let is_decrease t = match (unparen (fst t)).tm with - | Decreases _ -> true - | _ -> false - in - rest |> List.partition is_decrease - in - let rest = desugar_args env rest in - let decreases_clause = dec |> - List.map (fun t -> match (unparen (fst t)).tm with - | Decreases (t, _) -> - let dec_order = - let t = unparen t in - match t.tm with - | LexList l -> l |> List.map (desugar_term env) |> Decreases_lex - | WFOrder (t1, t2) -> (desugar_term env t1, desugar_term env t2) |> Decreases_wf - | _ -> [desugar_term env t] |> Decreases_lex in //by-default a lex list of length 1 - DECREASES dec_order - | _ -> - fail Errors.Fatal_UnexpectedComputationTypeForLetRec "Unexpected decreases clause") in - - let no_additional_args = - (* F# complains about not being able to use = on some types.. *) - let is_empty (l:list 'a) = match l with | [] -> true | _ -> false in - is_empty decreases_clause && - is_empty rest && - is_empty cattributes && - is_empty universes - in - if no_additional_args - && lid_equals eff C.effect_Tot_lid - then mk_Total result_typ - else if no_additional_args - && lid_equals eff C.effect_GTot_lid - then mk_GTotal result_typ - else - let flags = - if lid_equals eff C.effect_Lemma_lid then [LEMMA] - else if lid_equals eff C.effect_Tot_lid then [TOTAL] - else if lid_equals eff (C.effect_ML_lid()) then [MLEFFECT] - else if lid_equals eff C.effect_GTot_lid then [SOMETRIVIAL] - else [] - in - let flags = flags @ cattributes in - let rest = - if lid_equals eff C.effect_Lemma_lid - then - match rest with - | [req;ens;(pat, aq)] -> - let pat = match pat.n with - (* we really want the empty pattern to be in universe 0 rather than generalizing it *) - | Tm_fvar fv when S.fv_eq_lid fv Const.nil_lid -> - let nil = S.mk_Tm_uinst pat [U_zero] in - let pattern = - S.fvar_with_dd (Ident.set_lid_range Const.pattern_lid pat.pos) None - in - S.mk_Tm_app nil [(pattern, S.as_aqual_implicit true)] pat.pos - | _ -> pat - in - [req; ens; (S.mk (Tm_meta {tm=pat;meta=Meta_desugared Meta_smt_pat}) pat.pos, aq)] - | _ -> rest - else rest - in - mk_Comp ({comp_univs=universes; - effect_name=eff; - result_typ=result_typ; - effect_args=rest; - flags=flags@decreases_clause}) - -and desugar_formula env (f:term) : S.term = - let mk t = S.mk t f.range in - let setpos t = {t with pos=f.range} in - let desugar_quant (q_head:S.term) b pats should_wrap_with_pat body = - let tk = desugar_binder env ({b with blevel=Formula}) in - let with_pats env (names, pats) body = - match names, pats with - | [], [] -> body - | [], _::_ -> - //violates an internal invariant - failwith "Impossible: Annotated pattern without binders in scope" - | _ -> - let names = - names |> List.map - (fun i -> - { fail_or2 (try_lookup_id env) i with pos=(range_of_id i) }) - in - let pats = - pats |> List.map - (fun es -> es |> List.map - (fun e -> arg_withimp_t Nothing <| desugar_term env e)) - in - match pats with - | [] when not should_wrap_with_pat -> body - | _ -> mk (Tm_meta {tm=body;meta=Meta_pattern (names, pats)}) - in - match tk with - | Some a, k, _ -> //AR: ignoring the attributes here - let env, a = push_bv env a in - let a = {a with sort=k} in - let body = desugar_formula env body in - let body = with_pats env pats body in - let body = setpos <| no_annot_abs [S.mk_binder a] body in - mk <| Tm_app {hd=q_head; - args=[as_arg body]} - - | _ -> failwith "impossible" in - - let push_quant - (q:(list AST.binder & AST.patterns & AST.term) -> AST.term') - (binders:list AST.binder) - pats (body:term) = - match binders with - | b::(b'::_rest) -> - let rest = b'::_rest in - let body = mk_term (q(rest, pats, body)) (Range.union_ranges b'.brange body.range) Formula in - mk_term (q([b], ([], []), body)) f.range Formula - | _ -> failwith "impossible" in - - match (unparen f).tm with - | Labeled(f, l, p) -> - let f = desugar_formula env f in - // GM: I don't think this case really happens? - mk <| Tm_meta {tm=f; meta=Meta_labeled(Errors.Msg.mkmsg l, f.pos, p)} - - | QForall([], _, _) - | QExists([], _, _) - | QuantOp(_, [], _, _) -> failwith "Impossible: Quantifier without binders" - - | QForall((_1::_2::_3), pats, body) -> - let binders = _1::_2::_3 in - desugar_formula env (push_quant (fun x -> QForall x) binders pats body) - - | QExists((_1::_2::_3), pats, body) -> - let binders = _1::_2::_3 in - desugar_formula env (push_quant (fun x -> QExists x) binders pats body) - - | QuantOp(i, (_1::_2::_3), pats, body) -> - let binders = _1::_2::_3 in - desugar_formula env (push_quant (fun (x,y,z) -> QuantOp(i, x, y, z)) binders pats body) - - | QForall([b], pats, body) -> - let q = C.forall_lid in - let q_head = S.fvar_with_dd (set_lid_range q b.brange) None in - desugar_quant q_head b pats true body - - | QExists([b], pats, body) -> - let q = C.exists_lid in - let q_head = S.fvar_with_dd (set_lid_range q b.brange) None in - desugar_quant q_head b pats true body - - | QuantOp(i, [b], pats, body) -> - let q_head = - match op_as_term env 0 i with - | None -> - raise_error i Errors.Fatal_VariableNotFound - (BU.format1 "quantifier operator %s not found" (Ident.string_of_id i)) - | Some t -> t - in - desugar_quant q_head b pats false body - - | Paren f -> failwith "impossible" - - | _ -> desugar_term env f - -and desugar_binder_aq env b : (option ident & S.term & list S.attribute) & antiquotations_temp = - let attrs = b.battributes |> List.map (desugar_term env) in - match b.b with - | TAnnotated(x, t) - | Annotated(x, t) -> - let ty, aqs = desugar_typ_aq env t in - (Some x, ty, attrs), aqs - - | NoName t -> - let ty, aqs = desugar_typ_aq env t in - (None, ty, attrs), aqs - - | TVariable x -> - (Some x, mk (Tm_type U_unknown) (range_of_id x), attrs), [] - - | Variable x -> - (Some x, tun_r (range_of_id x), attrs), [] - -and desugar_binder env b : option ident & S.term & list S.attribute = - let r, aqs = desugar_binder_aq env b in - check_no_aq aqs; - r - -and desugar_vquote env e r: string = - (* Returns the string representation of the lid behind [e], fails if it is not an FV *) - let tm = desugar_term env e in - match (Subst.compress tm).n with - | Tm_fvar fv -> string_of_lid (lid_of_fv fv) - | _ -> raise_error r Fatal_UnexpectedTermVQuote ("VQuote, expected an fvar, got: " ^ show tm) - -and as_binder env imp = function - | (None, k, attrs) -> - mk_binder_with_attrs (null_bv k) (trans_bqual env imp) attrs, env - | (Some a, k, attrs) -> - let env, a = Env.push_bv env a in - (mk_binder_with_attrs ({a with sort=k}) (trans_bqual env imp) attrs), env - -and trans_bqual env = function - | Some AST.Implicit -> Some S.imp_tag - | Some AST.Equality -> Some S.Equality - | Some (AST.Meta t) -> - Some (S.Meta (desugar_term env t)) - | Some (AST.TypeClassArg) -> - let tcresolve = desugar_term env (mk_term (Var C.tcresolve_lid) Range.dummyRange Expr) in - Some (S.Meta tcresolve) - | None -> None - -let typars_of_binders env bs : _ & binders = - let env, tpars = List.fold_left (fun (env, out) b -> - let tk = desugar_binder env ({b with blevel=Formula}) in (* typars follow the same binding conventions as formulas *) - match tk with - | Some a, k, attrs -> - let env, a = push_bv env a in - let a = {a with sort=k} in - env, (mk_binder_with_attrs a (trans_bqual env b.aqual) attrs)::out - | _ -> raise_error b Errors.Fatal_UnexpectedBinder "Unexpected binder") (env, []) bs in - env, List.rev tpars - - -let desugar_attributes (env:env_t) (cattributes:list term) : list cflag = - let desugar_attribute t = - match (unparen t).tm with - | Var lid when string_of_lid lid = "cps" -> CPS - | _ -> raise_error t Errors.Fatal_UnknownAttribute ("Unknown attribute " ^ term_to_string t) - in List.map desugar_attribute cattributes - -let binder_ident (b:binder) : option ident = - match b.b with - | TAnnotated (x, _) - | Annotated (x, _) - | TVariable x - | Variable x -> Some x - | NoName _ -> None - -let binder_idents (bs:list binder) : list ident = - List.collect (fun b -> FStar.Common.list_of_option (binder_ident b)) bs - - -let mk_data_discriminators quals env datas attrs = - let quals = quals |> List.filter (function - | S.NoExtract - | S.Private -> true - | _ -> false) - in - let quals q = if not (Env.iface env) - || Env.admitted_iface env - then S.Assumption::q@quals - else q@quals - in - datas |> List.map (fun d -> - let disc_name = U.mk_discriminator d in - { sigel = Sig_declare_typ {lid=disc_name; us=[]; t=Syntax.tun}; - sigrng = range_of_lid disc_name;// FIXME: Isn't that range wrong? - sigquals = quals [(* S.Logic ; *) S.OnlyName ; S.Discriminator d]; - sigmeta = default_sigmeta; - sigattrs = attrs; - sigopts = None; - sigopens_and_abbrevs = DsEnv.opens_and_abbrevs env - }) - -let mk_indexed_projector_names iquals fvq attrs env lid (fields:list S.binder) = - let p = range_of_lid lid in - - fields |> List.mapi (fun i fld -> - let x = fld.binder_bv in - let field_name = U.mk_field_projector_name lid x i in - let only_decl = - lid_equals C.prims_lid (Env.current_module env) - || fvq<>Data_ctor - || U.has_attribute attrs C.no_auto_projectors_attr - in - let no_decl = Syntax.is_type x.sort in - let quals q = - if only_decl - then S.Assumption::q - else q - in - let quals = - let iquals = iquals |> List.filter (function - | S.NoExtract - | S.Private -> true - | _ -> false) - in - quals (OnlyName :: S.Projector(lid, x.ppname) :: iquals) - in - let decl = { sigel = Sig_declare_typ {lid=field_name; us=[]; t=Syntax.tun}; - sigquals = quals; - sigrng = range_of_lid field_name; - sigmeta = default_sigmeta ; - sigattrs = attrs; - sigopts = None; - sigopens_and_abbrevs = opens_and_abbrevs env } in - if only_decl - then [decl] //only the signature - else - let lb = { - lbname=Inr (S.lid_and_dd_as_fv field_name None); - lbunivs=[]; - lbtyp=tun; - lbeff=C.effect_Tot_lid; - lbdef=tun; - lbattrs=[]; - lbpos=Range.dummyRange; - } in - let impl = { sigel = Sig_let {lbs=(false, [lb]); - lids=[lb.lbname |> right |> (fun fv -> fv.fv_name.v)]}; - sigquals = quals; - sigrng = p; - sigmeta = default_sigmeta; - sigattrs = attrs; - sigopts = None; - sigopens_and_abbrevs = opens_and_abbrevs env - } in - if no_decl then [impl] else [decl;impl]) |> List.flatten - -let mk_data_projector_names iquals env se : list sigelt = - match se.sigel with - | _ when U.has_attribute se.sigattrs C.no_auto_projectors_decls_attr - || U.has_attribute se.sigattrs C.meta_projectors_attr -> - [] - | Sig_datacon {lid;t;num_ty_params=n} -> - let formals, _ = U.arrow_formals t in - begin match formals with - | [] -> [] //no fields to project - | _ -> - let filter_records = function - | RecordConstructor (_, fns) -> Some (Record_ctor(lid, fns)) - | _ -> None - in - let fv_qual = - match BU.find_map se.sigquals filter_records with - | None -> Data_ctor - | Some q -> q - in - (* ignoring parameters *) - let _, rest = BU.first_N n formals in - mk_indexed_projector_names iquals fv_qual se.sigattrs env lid rest - end - - | _ -> [] - -let mk_typ_abbrev env d lid uvs typars kopt t lids quals rng = - (* fetch attributes here to support `deprecated`, just as for - * TopLevelLet (see comment there) *) - let attrs = U.deduplicate_terms (List.map (desugar_term env) d.attrs) in - let val_attrs = Env.lookup_letbinding_quals_and_attrs env lid |> snd in - let lb = { - lbname=Inr (S.lid_and_dd_as_fv lid None); - lbunivs=uvs; - lbdef=no_annot_abs typars t; - lbtyp=if is_some kopt then U.arrow typars (S.mk_Total (kopt |> must)) else tun; - lbeff=C.effect_Tot_lid; - lbattrs=[]; - lbpos=rng; - } in - { sigel = Sig_let {lbs=(false, [lb]); lids}; - sigquals = quals; - sigrng = rng; - sigmeta = default_sigmeta ; - sigattrs = U.deduplicate_terms (val_attrs @ attrs); - sigopts = None; - sigopens_and_abbrevs = opens_and_abbrevs env - } - -let rec desugar_tycon env (d: AST.decl) (d_attrs_initial:list S.term) quals tcs : (env_t & sigelts) = - let rng = d.drange in - let tycon_id = function - | TyconAbstract(id, _, _) - | TyconAbbrev(id, _, _, _) - | TyconRecord(id, _, _, _, _) - | TyconVariant(id, _, _, _) -> id in - let binder_to_term b = match b.b with - | Annotated (x, _) - | Variable x -> mk_term (Var (lid_of_ids [x])) (range_of_id x) Expr - | TAnnotated(a, _) - | TVariable a -> mk_term (Tvar a) (range_of_id a) Type_level - | NoName t -> t in - let desugar_tycon_variant_record = function - // for every variant, each constructor whose payload is a record - // is desugared into a reference to a _generated_ record type - // declaration - | TyconVariant (id, bds, k, variants) -> - let additional_records, variants = map (fun (cid, payload, attrs) -> - match payload with - | Some (VpRecord (r, k)) -> - let record_id = mk_ident (string_of_id id ^ "__" ^ string_of_id cid ^ "__payload", range_of_id cid) in - let record_id_t = {tm = lid_of_ns_and_id [] record_id |> Var; range = range_of_id cid; level = Type_level} in - let payload_typ = mkApp record_id_t (List.map (fun bd -> binder_to_term bd, Nothing) bds) (range_of_id record_id) in - let desugar_marker = - let range = range_of_id record_id in - let desugar_attr_fv = {fv_name = {v = FStar.Parser.Const.desugar_of_variant_record_lid; p = range}; fv_qual = None} in - let desugar_attr = S.mk (Tm_fvar desugar_attr_fv) range in - let cid_as_constant = EMB.embed (string_of_lid (qualify env cid)) range None EMB.id_norm_cb in - S.mk_Tm_app desugar_attr [(cid_as_constant, None)] range - in - (TyconRecord (record_id, bds, None, attrs, r), desugar_marker::d_attrs_initial) |> Some - , (cid, Some ( match k with - | None -> VpOfNotation payload_typ - | Some k -> - VpArbitrary - { tm = Product ([mk_binder (NoName payload_typ) (range_of_id record_id) Type_level None], k) - ; range = payload_typ.range - ; level = Type_level - } - ), attrs) - | _ -> None, (cid, payload, attrs) - ) variants |> unzip in - // TODO: [concat_options] should live somewhere else - let concat_options = filter_map (fun r -> r) in - concat_options additional_records @ [(TyconVariant (id, bds, k, variants), d_attrs_initial)] - | tycon -> [(tycon, d_attrs_initial)] in - let tcs = concatMap desugar_tycon_variant_record tcs in - let tot rng = mk_term (Name (C.effect_Tot_lid)) rng Expr in - let with_constructor_effect t = mk_term (App(tot t.range, t, Nothing)) t.range t.level in - let apply_binders t binders = - let imp_of_aqual (b:AST.binder) = match b.aqual with - | Some Implicit - | Some (Meta _) - | Some TypeClassArg -> Hash - | _ -> Nothing in - List.fold_left (fun out b -> mk_term (App(out, binder_to_term b, imp_of_aqual b)) out.range out.level) - t binders in - let tycon_record_as_variant = function - | TyconRecord(id, parms, kopt, attrs, fields) -> - let constrName = mk_ident("Mk" ^ (string_of_id id), (range_of_id id)) in - let mfields = List.map (fun (x,q,attrs,t) -> FStar.Parser.AST.mk_binder_with_attrs (Annotated(x,t)) (range_of_id x) Expr q attrs) fields in - let result = apply_binders (mk_term (Var (lid_of_ids [id])) (range_of_id id) Type_level) parms in - let constrTyp = mk_term (Product(mfields, with_constructor_effect result)) (range_of_id id) Type_level in - //let _ = BU.print_string (BU.format2 "Translated record %s to constructor %s\n" ((string_of_id id)) (term_to_string constrTyp)) in - - let names = id :: binder_idents parms in - List.iter (fun (f, _, _, _) -> - if BU.for_some (fun i -> ident_equals f i) names then - raise_error f Errors.Error_FieldShadow - (BU.format1 "Field %s shadows the record's name or a parameter of it, please rename it" (string_of_id f))) - fields; - - TyconVariant(id, parms, kopt, [(constrName, Some (VpArbitrary constrTyp), attrs)]), fields |> List.map (fun (f, _, _, _) -> f) - | _ -> failwith "impossible" in - let desugar_abstract_tc quals _env mutuals d_attrs = function - | TyconAbstract(id, binders, kopt) -> - let _env', typars = typars_of_binders _env binders in - let k = match kopt with - | None -> U.ktype - | Some k -> desugar_term _env' k in - let tconstr = apply_binders (mk_term (Var (lid_of_ids [id])) (range_of_id id) Type_level) binders in - let qlid = qualify _env id in - let typars = Subst.close_binders typars in - let k = Subst.close typars k in - let se = { sigel = Sig_inductive_typ {lid=qlid; - us=[]; - params=typars; - num_uniform_params=None; - t=k; - mutuals; - ds=[]; - injective_type_params=false}; - sigquals = quals; - sigrng = range_of_id id; - sigmeta = default_sigmeta; - sigattrs = d_attrs; - sigopts = None; - sigopens_and_abbrevs = opens_and_abbrevs env - } in - let _env, _ = Env.push_top_level_rec_binding _env id in - let _env2, _ = Env.push_top_level_rec_binding _env' id in - _env, _env2, se, tconstr - | _ -> failwith "Unexpected tycon" in - let push_tparams env bs = - let env, bs = List.fold_left (fun (env, tps) b -> - let env, y = Env.push_bv env b.binder_bv.ppname in - env, (mk_binder_with_attrs y b.binder_qual b.binder_attrs)::tps) (env, []) bs in - env, List.rev bs in - match tcs with - | [(TyconAbstract(id, bs, kopt), d_attrs)] -> - let kopt = match kopt with - | None -> Some (tm_type_z (range_of_id id)) - | _ -> kopt in - let tc = TyconAbstract(id, bs, kopt) in - let _, _, se, _ = desugar_abstract_tc quals env [] d_attrs tc in - let se = match se.sigel with - | Sig_inductive_typ {lid=l; params=typars; t=k; mutuals=[]; ds=[]} -> - let quals = se.sigquals in - let quals = if List.contains S.Assumption quals - then quals - else (if not (Options.ml_ish ()) then - log_issue se Errors.Warning_AddImplicitAssumeNewQualifier - (BU.format1 "Adding an implicit 'assume new' qualifier on %s" (show l)); - S.Assumption :: S.New :: quals) in - let t = match typars with - | [] -> k - | _ -> mk (Tm_arrow {bs=typars; comp=mk_Total k}) se.sigrng in - { se with sigel = Sig_declare_typ {lid=l; us=[]; t}; - sigquals = quals } - | _ -> failwith "Impossible" in - let env = push_sigelt env se in - (* let _ = pr "Pushed %s\n" (string_of_lid (qualify env (tycon_id tc))) in *) - env, [se] - - | [(TyconAbbrev(id, binders, kopt, t), _d_attrs)] -> - let env', typars = typars_of_binders env binders in - let kopt = match kopt with - | None -> - if BU.for_some (function S.Effect -> true | _ -> false) quals - then Some teff - else None - | Some k -> Some (desugar_term env' k) in - let t0 = t in - let quals = if quals |> BU.for_some (function S.Logic -> true | _ -> false) - then quals - else if t0.level = Formula - then S.Logic::quals - else quals in - let qlid = qualify env id in - let se = - if quals |> List.contains S.Effect - then - let t, cattributes = - match (unparen t).tm with - (* TODO : we are only handling the case Effect args (attributes ...) *) - | Construct (head, args) -> - let cattributes, args = - match List.rev args with - | (last_arg, _) :: args_rev -> - begin match (unparen last_arg).tm with - | Attributes ts -> ts, List.rev (args_rev) - | _ -> [], args - end - | _ -> [], args - in - mk_term (Construct (head, args)) t.range t.level, - desugar_attributes env cattributes - | _ -> t, [] - in - let c = desugar_comp t.range false env' t in - let typars = Subst.close_binders typars in - let c = Subst.close_comp typars c in - let quals = quals |> List.filter (function S.Effect -> false | _ -> true) in - { sigel = Sig_effect_abbrev {lid=qlid; us=[]; bs=typars; comp=c; - cflags=cattributes @ comp_flags c}; - sigquals = quals; - sigrng = range_of_id id; - sigmeta = default_sigmeta ; - sigattrs = []; - sigopts = None; - sigopens_and_abbrevs = opens_and_abbrevs env - } - else let t = desugar_typ env' t in - mk_typ_abbrev env d qlid [] typars kopt t [qlid] quals (range_of_id id) in - - let env = push_sigelt env se in - env, [se] - - | [(TyconRecord payload, d_attrs)] -> - let trec = TyconRecord payload in - let t, fs = tycon_record_as_variant trec in - desugar_tycon env d d_attrs (RecordType (ids_of_lid (current_module env), fs)::quals) [t] - - | _::_ -> - let env0 = env in - let mutuals = List.map (fun (x, _) -> qualify env <| tycon_id x) tcs in - let rec collect_tcs quals et (tc, d_attrs) = - let (env, tcs) = et in - match tc with - | TyconRecord _ -> - let trec = tc in - let t, fs = tycon_record_as_variant trec in - collect_tcs (RecordType (ids_of_lid (current_module env), fs)::quals) (env, tcs) (t, d_attrs) - | TyconVariant(id, binders, kopt, constructors) -> - let env, _, se, tconstr = desugar_abstract_tc quals env mutuals d_attrs (TyconAbstract(id, binders, kopt)) in - env, (Inl(se, constructors, tconstr, quals), d_attrs)::tcs - | TyconAbbrev(id, binders, kopt, t) -> - let env, _, se, tconstr = desugar_abstract_tc quals env mutuals d_attrs (TyconAbstract(id, binders, kopt)) in - env, (Inr(se, binders, t, quals), d_attrs)::tcs - | _ -> raise_error rng Errors.Fatal_NonInductiveInMutuallyDefinedType "Mutually defined type contains a non-inductive element" in - let env, tcs = List.fold_left (collect_tcs quals) (env, []) tcs in - let tcs = List.rev tcs in - let tps_sigelts = tcs |> List.collect (fun (tc, d_attrs) -> - match tc with - | Inr ({ sigel = Sig_inductive_typ {lid=id; - us=uvs; - params=tpars; - t=k} }, binders, t, quals) -> //type abbrevs in mutual type definitions - let t = - let env, tpars = typars_of_binders env binders in - let env_tps, tpars = push_tparams env tpars in - let t = desugar_typ env_tps t in - let tpars = Subst.close_binders tpars in - Subst.close tpars t - in - [([], mk_typ_abbrev env d id uvs tpars (Some k) t [id] quals (range_of_lid id))] - - | Inl ({ sigel = Sig_inductive_typ {lid=tname; - us=univs; - params=tpars; - num_uniform_params=num_uniform; - t=k; - mutuals; - injective_type_params}; sigquals = tname_quals }, - constrs, tconstr, quals) -> - let mk_tot t = - let tot = mk_term (Name C.effect_Tot_lid) t.range t.level in - mk_term (App(tot, t, Nothing)) t.range t.level in - let tycon = (tname, tpars, k) in - let env_tps, tps = push_tparams env tpars in - let data_tpars = List.map (fun tp -> { tp with S.binder_qual = Some (S.Implicit true) }) tps in - let tot_tconstr = mk_tot tconstr in - let val_attrs = Env.lookup_letbinding_quals_and_attrs env0 tname |> snd in - let constrNames, constrs = List.split <| - (constrs |> List.map (fun (id, payload, cons_attrs) -> - let t = match payload with - | Some (VpArbitrary t) -> t - | Some (VpOfNotation t) -> mk_term (Product([mk_binder (NoName t) t.range t.level None], tot_tconstr)) t.range t.level - | Some (VpRecord _) -> failwith "Impossible: [VpRecord _] should have disappeared after [desugar_tycon_variant_record]" - | None -> { tconstr with range = range_of_id id } - in - let t = desugar_term env_tps (close env_tps t) in - let name = qualify env id in - let quals = tname_quals |> List.collect (function - | RecordType fns -> [RecordConstructor fns] - | _ -> []) in - let ntps = List.length data_tpars in - (name, (tps, { sigel = Sig_datacon {lid=name; - us=univs; - t=U.arrow data_tpars (mk_Total (t |> U.name_function_binders)); - ty_lid=tname; - num_ty_params=ntps; - mutuals; - injective_type_params}; - sigquals = quals; - sigrng = range_of_lid name; - sigmeta = default_sigmeta ; - sigattrs = U.deduplicate_terms (val_attrs @ d_attrs @ map (desugar_term env) cons_attrs); - sigopts = None; - sigopens_and_abbrevs = opens_and_abbrevs env - })))) - in - if !dbg_attrs - then ( - BU.print3 "Adding attributes to type %s: val_attrs=[@@%s] attrs=[@@%s]\n" - (show tname) (show val_attrs) (show d_attrs) - ); - ([], { sigel = Sig_inductive_typ {lid=tname; - us=univs; - params=tpars; - num_uniform_params=num_uniform; - t=k; - mutuals; - ds=constrNames; - injective_type_params}; - sigquals = tname_quals; - sigrng = range_of_lid tname; - sigmeta = default_sigmeta ; - sigattrs = U.deduplicate_terms (val_attrs @ d_attrs); - sigopts = None; - sigopens_and_abbrevs = opens_and_abbrevs env - })::constrs - | _ -> failwith "impossible") - in - let sigelts = tps_sigelts |> List.map (fun (_, se) -> se) in - let bundle, abbrevs = FStar.Syntax.MutRecTy.disentangle_abbrevs_from_bundle sigelts quals (List.collect U.lids_of_sigelt sigelts) rng in - if !dbg_attrs - then ( - BU.print1 "After disentangling: %s\n" (show bundle) - ); - let env = push_sigelt env0 bundle in - let env = List.fold_left push_sigelt env abbrevs in - (* NOTE: derived operators such as projectors and discriminators are using the type names before unfolding. *) - let data_ops = tps_sigelts |> List.collect (fun (tps, se) -> mk_data_projector_names quals env se) in - let discs = sigelts |> List.collect (fun se -> match se.sigel with - | Sig_inductive_typ {lid=tname; params=tps; t=k; ds=constrs} -> - let quals = se.sigquals in - mk_data_discriminators quals env - (constrs |> List.filter (fun data_lid -> //AR: create data discriminators only for non-record data constructors - let data_quals = - let data_se = sigelts |> List.find (fun se -> match se.sigel with - | Sig_datacon {lid=name} -> lid_equals name data_lid - | _ -> false) |> must in - data_se.sigquals in - not (data_quals |> List.existsb (function | RecordConstructor _ -> true | _ -> false)))) - se.sigattrs - | _ -> []) in - let ops = discs@data_ops in - let env = List.fold_left push_sigelt env ops in - env, [bundle]@abbrevs@ops - - | [] -> failwith "impossible" - -let desugar_binders env binders = - let env, binders = List.fold_left (fun (env,binders) b -> - match desugar_binder env b with - | Some a, k, attrs -> - let binder, env = as_binder env b.aqual (Some a, k, attrs) in - env, binder::binders - - | _ -> raise_error b Errors.Fatal_MissingNameInBinder "Missing name in binder") (env, []) binders in - env, List.rev binders - -let push_reflect_effect env quals (effect_name:Ident.lid) range = - if quals |> BU.for_some (function S.Reflectable _ -> true | _ -> false) - then let monad_env = Env.enter_monad_scope env (ident_of_lid effect_name) in - let reflect_lid = Ident.id_of_text "reflect" |> Env.qualify monad_env in - let quals = [S.Assumption; S.Reflectable effect_name] in - let refl_decl = { sigel = S.Sig_declare_typ {lid=reflect_lid; us=[]; t=S.tun}; - sigrng = range; - sigquals = quals; - sigmeta = default_sigmeta ; - sigattrs = []; - sigopts = None; - sigopens_and_abbrevs = opens_and_abbrevs env - } in - Env.push_sigelt env refl_decl // FIXME: Add docs to refl_decl? - else env - -let parse_attr_with_list warn (at:S.term) (head:lident) : option (list int) & bool = - let warn () = - if warn then - Errors.log_issue at Errors.Warning_UnappliedFail - (BU.format1 "Found ill-applied '%s', argument should be a non-empty list of integer literals" (string_of_lid head)) - in - let hd, args = U.head_and_args at in - match (SS.compress hd).n with - | Tm_fvar fv when S.fv_eq_lid fv head -> - begin - match args with - | [] -> Some [], true - | [(a1, _)] -> - begin - match EMB.unembed a1 EMB.id_norm_cb with - | Some es -> - Some (List.map FStar.BigInt.to_int_fs es), true - | _ -> - warn(); - None, true - end - | _ -> - warn (); - None, true - end - - | _ -> - None, false - - -// If this is an expect_failure attribute, return the listed errors and whether it's a expect_lax_failure or not -let get_fail_attr1 warn (at : S.term) : option (list int & bool) = - let rebind res b = - match res with - | None -> None - | Some l -> Some (l, b) - in - let res, matched = parse_attr_with_list warn at C.fail_attr in - if matched then rebind res false - else let res, _ = parse_attr_with_list warn at C.fail_lax_attr in - rebind res true - -// Traverse a list of attributes to find all expect_failures and combine them -let get_fail_attr warn (ats : list S.term) : option (list int & bool) = - let comb f1 f2 = - match f1, f2 with - | Some (e1, l1), Some (e2, l2) -> - Some (e1@e2, l1 || l2) - - | Some (e, l), None - | None, Some (e, l) -> - Some (e, l) - - | _ -> None - in - List.fold_right (fun at acc -> comb (get_fail_attr1 warn at) acc) ats None - -let lookup_effect_lid env (l:lident) (r:Range.range) : S.eff_decl = - match Env.try_lookup_effect_defn env l with - | None -> - raise_error r Errors.Fatal_EffectNotFound - ("Effect name " ^ show l ^ " not found") - | Some l -> l - -let rec desugar_effect env d (d_attrs:list S.term) (quals: qualifiers) (is_layered:bool) eff_name eff_binders eff_typ eff_decls = - let env0 = env in - // qualified with effect name - let monad_env = Env.enter_monad_scope env eff_name in - let env, binders = desugar_binders monad_env eff_binders in - let eff_t = desugar_term env eff_typ in - - let num_indices = List.length (fst (U.arrow_formals eff_t)) in - - (* An effect for free has a type of the shape "a:Type -> Effect" *) - let for_free = num_indices = 1 && not is_layered in - if for_free - then Errors.log_issue d Errors.Warning_DeprecatedGeneric - (BU.format1 "DM4Free feature is deprecated and will be removed soon, \ - use layered effects to define %s" (Ident.string_of_id eff_name)); - - let mandatory_members = - let rr_members = ["repr" ; "return" ; "bind"] in - if for_free then rr_members - (* - * AR: subcomp, if_then_else, and close are optional - * but adding here so as not to count them as actions - *) - else if is_layered then rr_members @ [ "subcomp"; "if_then_else"; "close" ] - (* the first 3 are optional but must not be counted as actions *) - else rr_members @ [ - "return_wp"; - "bind_wp"; - "if_then_else"; - "ite_wp"; - "stronger"; - "close_wp"; - "trivial" - ] - in - - let name_of_eff_decl decl = - match decl.d with - | Tycon(_, _, [TyconAbbrev(name, _, _, _)]) -> Ident.string_of_id name - | _ -> failwith "Malformed effect member declaration." - in - - let mandatory_members_decls, actions = - List.partition (fun decl -> List.mem (name_of_eff_decl decl) mandatory_members) eff_decls - in - - let env, decls = mandatory_members_decls |> List.fold_left (fun (env, out) decl -> - let env, ses = desugar_decl env decl in - env, List.hd ses::out) - (env, []) - in - let binders = Subst.close_binders binders in - let actions = actions |> List.map (fun d -> - match d.d with - | Tycon(_, _,[TyconAbbrev(name, action_params, _, { tm = Construct (_, [ def, _; cps_type, _ ])})]) when not for_free -> - // When the effect is not for free, user has to provide a pair of - // the definition and its cps'd type. - let env, action_params = desugar_binders env action_params in - let action_params = Subst.close_binders action_params in - { - action_name=Env.qualify env name; - action_unqualified_name = name; - action_univs=[]; - action_params = action_params; - action_defn=Subst.close (binders @ action_params) (desugar_term env def); - action_typ=Subst.close (binders @ action_params) (desugar_typ env cps_type) - } - | Tycon(_, _, [TyconAbbrev(name, action_params, _, defn)]) when for_free || is_layered -> - // When for free, the user just provides the definition and the rest - // is elaborated - // For layered effects also, user just provides the definition - let env, action_params = desugar_binders env action_params in - let action_params = Subst.close_binders action_params in - { - action_name=Env.qualify env name; - action_unqualified_name = name; - action_univs=[]; - action_params = action_params; - action_defn=Subst.close (binders@action_params) (desugar_term env defn); - action_typ=S.tun - } - | _ -> - raise_error d Errors.Fatal_MalformedActionDeclaration - ("Malformed action declaration; if this is an \"effect \ - for free\", just provide the direct-style declaration. If this is \ - not an \"effect for free\", please provide a pair of the definition \ - and its cps-type with arrows inserted in the right place (see \ - examples).") - ) in - let eff_t = Subst.close binders eff_t in - let lookup s = - let l = Env.qualify env (mk_ident(s, d.drange)) in - [], Subst.close binders <| fail_or env (try_lookup_definition env) l in - let mname =qualify env0 eff_name in - let qualifiers =List.map (trans_qual d.drange (Some mname)) quals in - let dummy_tscheme = [], S.tun in - let eff_sig, combinators = - if for_free then - WP_eff_sig ([], eff_t), - DM4F_eff ({ - ret_wp = dummy_tscheme; - bind_wp = dummy_tscheme; - stronger = dummy_tscheme; - if_then_else = dummy_tscheme; - ite_wp = dummy_tscheme; - close_wp = dummy_tscheme; - trivial = dummy_tscheme; - - repr = Some (lookup "repr"); - return_repr = Some (lookup "return"); - bind_repr = Some (lookup "bind"); - }) - else if is_layered then - let has_subcomp = List.existsb (fun decl -> name_of_eff_decl decl = "subcomp") eff_decls in - let has_if_then_else = List.existsb (fun decl -> name_of_eff_decl decl = "if_then_else") eff_decls in - let has_close = List.existsb (fun decl -> name_of_eff_decl decl = "close") eff_decls in - - //setting the second component to dummy_ts, - // and kind to None, typechecker fills them in - let to_comb (us, t) = (us, t), dummy_tscheme, None in - - - let eff_t, num_effect_params = - match (SS.compress eff_t).n with - | Tm_arrow {bs; comp=c} -> - // peel off the first a:Type binder - let a::bs = bs in - // - // allow_param checks that all effect parameters - // are upfront - // it is true initially, and is set to false as soon as - // we see a non-parameter binder - // and if some parameter appears after that, we raise an error - // - let n, _, bs = List.fold_left (fun (n, allow_param, bs) b -> - let b_attrs = b.binder_attrs in - let is_param = U.has_attribute b_attrs C.effect_parameter_attr in - if is_param && not allow_param - then raise_error d Errors.Fatal_UnexpectedEffect "Effect parameters must all be upfront"; - let b_attrs = U.remove_attr C.effect_parameter_attr b_attrs in - (if is_param then n+1 else n), - allow_param && is_param, - bs@[{b with binder_attrs=b_attrs}]) (0, true, []) bs in - {eff_t with n=Tm_arrow {bs=a::bs; comp=c}}, - n - | _ -> failwith "desugaring indexed effect: effect type not an arrow" in - - (* - * AR: if subcomp or if_then_else are not specified, then fill in dummy_tscheme - * typechecker will fill in an appropriate default - *) - - Layered_eff_sig (num_effect_params, ([], eff_t)), - Layered_eff ({ - l_repr = lookup "repr", dummy_tscheme; - l_return = lookup "return", dummy_tscheme; - l_bind = lookup "bind" |> to_comb; - l_subcomp = - if has_subcomp then lookup "subcomp" |> to_comb - else dummy_tscheme, dummy_tscheme, None; - l_if_then_else = - if has_if_then_else then lookup "if_then_else" |> to_comb - else dummy_tscheme, dummy_tscheme, None; - l_close = - if has_close then Some (lookup "close", dummy_tscheme) - else None; // If close is not specified, leave it to None - // The typechecker will also not fill it in - }) - else - let rr = BU.for_some (function S.Reifiable | S.Reflectable _ -> true | _ -> false) qualifiers in - WP_eff_sig ([], eff_t), - Primitive_eff ({ - ret_wp = lookup "return_wp"; - bind_wp = lookup "bind_wp"; - stronger = lookup "stronger"; - if_then_else = lookup "if_then_else"; - ite_wp = lookup "ite_wp"; - close_wp = lookup "close_wp"; - trivial = lookup "trivial"; - - repr = if rr then Some (lookup "repr") else None; - return_repr = if rr then Some (lookup "return") else None; - bind_repr = if rr then Some (lookup "bind") else None - }) in - - let extraction_mode = - if is_layered - then S.Extract_none "" // will be populated by the typechecker - else if for_free - then if BU.for_some (function S.Reifiable -> true | _ -> false) qualifiers - then S.Extract_reify - else S.Extract_primitive - else S.Extract_primitive in - - let sigel = Sig_new_effect ({ - mname = mname; - cattributes = []; - univs = []; - binders = binders; - signature = eff_sig; - combinators = combinators; - actions = actions; - eff_attrs = d_attrs; - extraction_mode - }) in - - let se = ({ - sigel = sigel; - sigquals = qualifiers; - sigrng = d.drange; - sigmeta = default_sigmeta ; - sigattrs = d_attrs; - sigopts = None; - sigopens_and_abbrevs = opens_and_abbrevs env - }) in - - let env = push_sigelt env0 se in - let env = actions |> List.fold_left (fun env a -> - //printfn "Pushing action %s\n" (string_of_lid a.action_name); - push_sigelt env (U.action_as_lb mname a a.action_defn.pos)) env - in - let env = push_reflect_effect env qualifiers mname d.drange in - env, [se] - -and desugar_redefine_effect env d d_attrs trans_qual quals eff_name eff_binders defn = - let env0 = env in - let env = Env.enter_monad_scope env eff_name in - let env, binders = desugar_binders env eff_binders in - let ed_lid, ed, args, cattributes = - let head, args = head_and_args defn in - let lid = match head.tm with - | Name l -> l - | _ -> raise_error d Errors.Fatal_EffectNotFound ("Effect " ^AST.term_to_string head^ " not found") - in - let ed = fail_or env (Env.try_lookup_effect_defn env) lid in - let cattributes, args = - match List.rev args with - | (last_arg, _) :: args_rev -> - begin match (unparen last_arg).tm with - | Attributes ts -> ts, List.rev (args_rev) - | _ -> [], args - end - | _ -> [], args - in - lid, ed, desugar_args env args, desugar_attributes env cattributes in -// printfn "ToSyntax got eff_decl: %s\n" (Print.eff_decl_to_string false ed); - let binders = Subst.close_binders binders in - if List.length args <> List.length ed.binders - then raise_error defn Errors.Fatal_ArgumentLengthMismatch "Unexpected number of arguments to effect constructor"; - let ed_binders, _, ed_binders_opening = Subst.open_term' ed.binders S.t_unit in - let sub' shift_n (us, x) = - let x = Subst.subst (Subst.shift_subst (shift_n + List.length us) ed_binders_opening) x in - let s = U.subst_of_list ed_binders args in - Subst.close_tscheme binders (us, (Subst.subst s x)) - in - let sub = sub' 0 in - let mname=qualify env0 eff_name in - let ed = { - mname = mname; - cattributes = cattributes; - univs = ed.univs; - binders = binders; - signature = U.apply_eff_sig sub ed.signature; - combinators = apply_eff_combinators sub ed.combinators; - actions = List.map (fun action -> - let nparam = List.length action.action_params in - { - // Since we called enter_monad_env before, this is going to generate - // a name of the form FStar.Compiler.Effect.uu___proj__STATE__item__get - action_name = Env.qualify env (action.action_unqualified_name); - action_unqualified_name = action.action_unqualified_name; - action_univs = action.action_univs ; - action_params = action.action_params ; - (* These need to be shifted further since they have the action's parameters also in scope *) - action_defn =snd (sub' nparam ([], action.action_defn)) ; - action_typ =snd (sub' nparam ([], action.action_typ)) - // GM: ^ Although isn't this one always Tm_unknown at this point? - }) - ed.actions; - eff_attrs = ed.eff_attrs; - extraction_mode = ed.extraction_mode; - } in - let se = - { sigel = Sig_new_effect ed; - sigquals = List.map (trans_qual (Some mname)) quals; - sigrng = d.drange; - sigmeta = default_sigmeta ; - sigattrs = d_attrs; - sigopts = None; - sigopens_and_abbrevs = opens_and_abbrevs env - } - in - let monad_env = env in - let env = push_sigelt env0 se in - let env = - ed.actions |> List.fold_left - (fun env a -> push_sigelt env (U.action_as_lb mname a a.action_defn.pos)) - env - in - let env = - if quals |> List.contains Reflectable - then let reflect_lid = Ident.id_of_text "reflect" |> Env.qualify monad_env in - let quals = [S.Assumption; S.Reflectable mname] in - let refl_decl = { sigel = S.Sig_declare_typ {lid=reflect_lid; us=[]; t=S.tun}; - sigquals = quals; - sigrng = d.drange; - sigmeta = default_sigmeta ; - sigattrs = []; - sigopts = None; - sigopens_and_abbrevs = opens_and_abbrevs env - } in - push_sigelt env refl_decl - else env in - env, [se] - - -and desugar_decl_maybe_fail_attr env (d: decl): (env_t & sigelts) = - let no_fail_attrs (ats : list S.term) : list S.term = - List.filter (fun at -> Option.isNone (get_fail_attr1 false at)) ats - in - - // The `fail` attribute behaves - // differentrly! We only keep that one on the first new decl. - let env0 = Env.snapshot env |> snd in (* we need the snapshot since pushing the let - * will shadow a previous val *) - - (* If this is an expect_failure, check to see if it fails. - * If it does, check that the errors match as we normally do. - * If it doesn't fail, leave it alone! The typechecker will check the failure. *) - let env, sigelts = - let attrs = U.deduplicate_terms (List.map (desugar_term env) d.attrs) in - match get_fail_attr false attrs with - | Some (expected_errs, lax) -> - let d = { d with attrs = [] } in - let errs, r = Errors.catch_errors (fun () -> - Options.with_saved_options (fun () -> - desugar_decl_core env attrs d)) in - begin match errs, r with - | [], Some (env, ses) -> - (* Succeeded desugaring, carry on, but make a Sig_fail *) - (* Restore attributes, except for fail *) - let ses = List.map (fun se -> { se with sigattrs = no_fail_attrs attrs }) ses in - let se = { sigel = Sig_fail {errs=expected_errs; fail_in_lax=lax; ses}; - sigquals = []; - sigrng = d.drange; - sigmeta = default_sigmeta; - sigattrs = attrs; - sigopts = None; - sigopens_and_abbrevs = opens_and_abbrevs env - } in - env0, [se] - - | errs, ropt -> (* failed! check that it failed as expected *) - let errnos = List.concatMap (fun i -> FStar.Common.list_of_option i.issue_number) errs in - if Options.print_expected_failures () then ( - (* Print errors if asked for *) - BU.print_string ">> Got issues: [\n"; - List.iter Errors.print_issue errs; - BU.print_string ">>]\n" - ); - if expected_errs = [] then - env0, [] - else begin - match Errors.find_multiset_discrepancy expected_errs errnos with - | None -> env0, [] - | Some (e, n1, n2) -> - let open FStar.Class.PP in - let open FStar.Pprint in - List.iter Errors.print_issue errs; - Errors.log_issue d Errors.Error_DidNotFail [ - prefix 2 1 - (text "This top-level definition was expected to raise error codes") - (pp expected_errs) ^/^ - prefix 2 1 (text "but it raised") - (pp errnos) ^^ text "(at desugaring time)" ^^ dot; - text (BU.format3 "Error #%s was raised %s times, instead of %s." - (show e) (show n2) (show n1)); - ]; - env0, [] - end - end - | None -> - desugar_decl_core env attrs d - in - env, sigelts - -and desugar_decl env (d:decl) :(env_t & sigelts) = - FStar.GenSym.reset_gensym (); - let env, ses = desugar_decl_maybe_fail_attr env d in - env, ses |> List.map generalize_annotated_univs - -and desugar_decl_core env (d_attrs:list S.term) (d:decl) : (env_t & sigelts) = - let trans_qual = trans_qual d.drange in - match d.d with - | Pragma p -> - let p = trans_pragma p in - U.process_pragma p d.drange; - let se = { sigel = Sig_pragma p; - sigquals = []; - sigrng = d.drange; - sigmeta = default_sigmeta; - sigattrs = d_attrs; - sigopts = None; - sigopens_and_abbrevs = opens_and_abbrevs env - } in - env, [se] - - | TopLevelModule id -> env, [] - - | Open (lid, restriction) -> - let env = Env.push_namespace env lid restriction in - env, [] - - | Friend lid -> - if Env.iface env - then raise_error d Errors.Fatal_FriendInterface - "'friend' declarations are not allowed in interfaces" - else if not (FStar.Parser.Dep.module_has_interface (Env.dep_graph env) (Env.current_module env)) - then raise_error d Errors.Fatal_FriendInterface - "'friend' declarations are not allowed in modules that lack interfaces" - else if not (FStar.Parser.Dep.module_has_interface (Env.dep_graph env) lid) - then raise_error d Errors.Fatal_FriendInterface - "'friend' declarations cannot refer to modules that lack interfaces" - else if not (FStar.Parser.Dep.deps_has_implementation (Env.dep_graph env) lid) - then raise_error d Errors.Fatal_FriendInterface - "'friend' module has not been loaded; recompute dependences (C-c C-r) if in interactive mode" - else env, [] - - | Include (lid, restriction) -> - let env = Env.push_include env lid restriction in - env, [] - - | ModuleAbbrev(x, l) -> - Env.push_module_abbrev env x l, [] - - | Tycon(is_effect, typeclass, tcs) -> - let quals = d.quals in - let quals = if is_effect then Effect_qual :: quals else quals in - let quals = - if typeclass then - match tcs with - | [(TyconRecord _)] -> Noeq :: quals - | _ -> raise_error d Errors.Error_BadClassDecl "Ill-formed `class` declaration: definition must be a record type" - else quals - in - let env, ses = desugar_tycon env d d_attrs (List.map (trans_qual None) quals) tcs in - if !dbg_attrs - then ( - BU.print2 "Desugared tycon from {%s} to {%s}\n" (show d) (show ses) - ); - (* Handling typeclasses: we typecheck the tcs as usual, and then need to add - * %splice[new_meth_lids] (mk_class type_lid) - * where the tricky bit is getting the new_meth_lids. To do so, - * we traverse the new declarations marked with "Projector", and get - * the field names. This is pretty ugly. *) - let mkclass lid = - let r = range_of_lid lid in - let body = - if U.has_attribute d_attrs C.meta_projectors_attr then - (* new meta projectors *) - U.mk_app (S.tabbrev C.mk_projs_lid) - [S.as_arg (U.exp_bool true); - S.as_arg (U.exp_string (string_of_lid lid))] - else - (* old mk_class *) - U.mk_app (S.tabbrev C.mk_class_lid) - [S.as_arg (U.exp_string (string_of_lid lid))] - in - U.abs [S.mk_binder (S.new_bv (Some r) (tun_r r))] body None - in - let get_meths se = - let rec get_fname quals = - match quals with - | S.Projector (_, id) :: _ -> Some id - | _ :: quals -> get_fname quals - | [] -> None - in - match get_fname se.sigquals with - | None -> [] - | Some id -> - [qualify env id] - in - let formals = - let bndl = BU.try_find (function {sigel=Sig_bundle _} -> true | _ -> false) ses in - match bndl with - | None -> None - | Some bndl -> - match bndl.sigel with - | Sig_bundle {ses} -> - BU.find_map - ses - (fun se -> - match se.sigel with - | Sig_datacon {t} -> - let formals, _ = U.arrow_formals t in - Some formals - | _ -> None) - | _ -> None - in - let rec splice_decl meths se = - match se.sigel with - | Sig_bundle {ses} -> List.concatMap (splice_decl meths) ses - | Sig_inductive_typ {lid; t=ty} -> - let formals = - match formals with - | None -> [] - | Some formals -> formals - in - let has_no_method_attr (meth:Ident.lident) = - let i = Ident.ident_of_lid meth in - BU.for_some - (fun formal -> - if Ident.ident_equals i formal.binder_bv.ppname - then BU.for_some - (fun attr -> - match (SS.compress attr).n with - | Tm_fvar fv -> S.fv_eq_lid fv FStar.Parser.Const.no_method_lid - | _ -> false) - formal.binder_attrs - else false) - formals - in - let meths = List.filter (fun x -> not (has_no_method_attr x)) meths in - let is_typed = false in - [{ sigel = Sig_splice {is_typed; lids=meths; tac=mkclass lid}; - sigquals = []; - sigrng = d.drange; - sigmeta = default_sigmeta; - sigattrs = []; - sigopts = None; - sigopens_and_abbrevs = opens_and_abbrevs env }] - | _ -> [] - in - let ses, extra = - if typeclass - then let meths = List.concatMap get_meths ses in - let rec add_class_attr se = - match se.sigel with - | Sig_bundle {ses; lids} -> - let ses = List.map add_class_attr ses in - { se with sigel = Sig_bundle {ses; lids} - ; sigattrs = U.deduplicate_terms - (S.fvar_with_dd FStar.Parser.Const.tcclass_lid None - :: se.sigattrs) } - - | Sig_inductive_typ _ -> - { se - with sigattrs = U.deduplicate_terms - (S.fvar_with_dd FStar.Parser.Const.tcclass_lid None - :: se.sigattrs) } - - | _ -> se - in - List.map add_class_attr ses, - List.concatMap (splice_decl meths) ses - else ses, [] - in - let env = List.fold_left push_sigelt env extra in - env, ses @ extra - - | TopLevelLet(isrec, lets) -> - let quals = d.quals in - (* If a toplevel let has a non-trivial pattern it needs to be desugared to a serie of top-level lets *) - let expand_toplevel_pattern = - isrec = NoLetQualifier && - begin match lets with - | [ { pat = PatOp _}, _ ] - | [ { pat = PatVar _}, _ ] - | [ { pat = PatAscribed ({ pat = PatOp _}, _) }, _ ] - | [ { pat = PatAscribed ({ pat = PatVar _}, _) }, _ ] -> false - | [ p, _ ] -> not (is_app_pattern p) - | _ -> false - end - in - if not expand_toplevel_pattern - then begin - let lets = List.map (fun x -> None, x) lets in - let as_inner_let = - mk_term (Let(isrec, lets, mk_term (Const Const_unit) d.drange Expr)) d.drange Expr - in - let ds_lets, aq = desugar_term_maybe_top true env as_inner_let in - check_no_aq aq; - match (Subst.compress <| ds_lets).n with - | Tm_let {lbs} -> - let fvs = snd lbs |> List.map (fun lb -> right lb.lbname) in - let val_quals, val_attrs = - List.fold_right (fun fv (qs, ats) -> - let qs', ats' = Env.lookup_letbinding_quals_and_attrs env fv.fv_name.v in - (qs'@qs, ats'@ats)) - fvs - ([], []) - in - (* Propagate top-level attrs to each lb. The lb.lbattrs field should be empty, - * but just being safe here. *) - let top_attrs = d_attrs in - let lbs = - let (isrec, lbs0) = lbs in - let lbs0 = lbs0 |> List.map (fun lb -> { lb with lbattrs = U.deduplicate_terms (lb.lbattrs @ val_attrs @ top_attrs) }) in - (isrec, lbs0) - in - // BU.print3 "Desugaring %s, val_quals are %s, val_attrs are %s\n" - // (List.map show fvs |> String.concat ", ") - // (show val_quals) - // (List.map show val_attrs |> String.concat ", "); - let quals = - match quals with - | _::_ -> - List.map (trans_qual None) quals - | _ -> - val_quals - in - let quals = - if lets |> BU.for_some (fun (_, (_, t)) -> t.level=Formula) - then S.Logic::quals - else quals in - let names = fvs |> List.map (fun fv -> fv.fv_name.v) in - let s = { sigel = Sig_let {lbs; lids=names}; - sigquals = quals; - sigrng = d.drange; - sigmeta = default_sigmeta; - sigattrs = U.deduplicate_terms (val_attrs @ top_attrs); - sigopts = None; - sigopens_and_abbrevs = opens_and_abbrevs env - } in - let env = push_sigelt env s in - env, [s] - | _ -> failwith "Desugaring a let did not produce a let" - end - else - (* If there is a top-level pattern we first bind the result of the body *) - (* to some private anonymous name then we gather each idents bounded in *) - (* the pattern and introduce one toplevel binding for each of them *) - let (pat, body) = match lets with - | [pat, body] -> pat, body - | _ -> failwith "expand_toplevel_pattern should only allow single definition lets" - in - let rec gen_fresh_toplevel_name () = - let nm = Ident.gen Range.dummyRange in - if Some? <| DsEnv.resolve_name env (Ident.lid_of_ids [nm]) - then gen_fresh_toplevel_name() - else nm - in - let fresh_toplevel_name = gen_fresh_toplevel_name() in - let fresh_pat = - let var_pat = mk_pattern (PatVar (fresh_toplevel_name, None, [])) Range.dummyRange in - (* TODO : What about inner type ascriptions ? Is there any way to retrieve those ? *) - match pat.pat with - | PatAscribed (pat, ty) -> { pat with pat = PatAscribed (var_pat, ty) } - | _ -> var_pat - in - let main_let = - (* GM: I'm not sure why we are even marking this private, - * since it has a reserved name, but anyway keeping it - * and making it not duplicate the qualifier. *) - let quals = if List.mem Private d.quals - then d.quals - else Private :: d.quals - in - desugar_decl env ({ d with - d = TopLevelLet (isrec, [fresh_pat, body]) ; - quals = quals }) - in - - let main : term = mk_term (Var (lid_of_ids [fresh_toplevel_name])) pat.prange Expr in - - let build_generic_projection (env, ses) (id_opt : option ident) = - (* When id_opt = Some id, we build a new toplevel definition - * as follows and then desugar it - * - * let id = match fresh_toplevel_name with | pat -> id - * - * Otherwise, generate a "coverage check" of the shape - * - * let uu___X : unit = match fresh_toplevel_name with | pat -> () - * - *) - let bv_pat, branch = - match id_opt with - | Some id -> - let lid = lid_of_ids [id] in - let branch = mk_term (Var lid) (range_of_lid lid) Expr in - let bv_pat = mk_pattern (PatVar (id, None, [])) (range_of_id id) in - bv_pat, branch - - | None -> - let id = gen_fresh_toplevel_name () in - let branch = mk_term (Const FStar.Const.Const_unit) Range.dummyRange Expr in - let bv_pat = mk_pattern (PatVar (id, None, [])) (range_of_id id) in - let bv_pat = mk_pattern (PatAscribed (bv_pat, (unit_ty (range_of_id id), None))) - (range_of_id id) in - bv_pat, branch - in - let body = mk_term (Match (main, None, None, [pat, None, branch])) main.range Expr in - let id_decl = mk_decl (TopLevelLet(NoLetQualifier, [bv_pat, body])) Range.dummyRange [] in - let id_decl = { id_decl with quals = d.quals } in - let env, ses' = desugar_decl env id_decl in - env, ses @ ses' - in - - let build_projection (env, ses) id = build_generic_projection (env, ses) (Some id) in - let build_coverage_check (env, ses) = build_generic_projection (env, ses) None in - - let bvs = gather_pattern_bound_vars pat |> elems in - - (* If there are no variables in the pattern (and it is not a - * wildcard), we should still check to see that it is complete, - * otherwise things like: - * let false = true - * let Some 42 = None - * would be accepted. To do so, we generate a declaration - * of shape - * let uu___X : unit = match body with | pat -> () - * which will trigger a check for completeness of pat - * wrt the body. (See issues #829 and #1903) - *) - if List.isEmpty bvs && not (is_var_pattern pat) - then build_coverage_check main_let - else List.fold_left build_projection main_let bvs - - | Assume(id, t) -> - let f = desugar_formula env t in - let lid = qualify env id in - env, [{ sigel = Sig_assume {lid; us=[]; phi=f}; - sigquals = [S.Assumption]; - sigrng = d.drange; - sigmeta = default_sigmeta ; - sigattrs = d_attrs; - sigopts = None; - sigopens_and_abbrevs = opens_and_abbrevs env - }] - - | Val(id, t) -> - let quals = d.quals in - let t = desugar_term env (close_fun env t) in - let quals = - if Env.iface env - && Env.admitted_iface env - then Assumption::quals - else quals in - let lid = qualify env id in - let se = { sigel = Sig_declare_typ {lid; us=[]; t}; - sigquals = List.map (trans_qual None) quals; - sigrng = d.drange; - sigmeta = default_sigmeta ; - sigattrs = d_attrs; - sigopts = None; - sigopens_and_abbrevs = opens_and_abbrevs env } in - let env = push_sigelt env se in - env, [se] - - | Exception(id, t_opt) -> - let t = - match t_opt with - | None -> fail_or env (try_lookup_lid env) C.exn_lid - | Some term -> - let t = desugar_term env term in - U.arrow ([null_binder t]) (mk_Total <| fail_or env (try_lookup_lid env) C.exn_lid) - in - let l = qualify env id in - let qual = [ExceptionConstructor] in - let top_attrs = d_attrs in - let se = { sigel = Sig_datacon {lid=l;us=[];t;ty_lid=C.exn_lid;num_ty_params=0;mutuals=[C.exn_lid];injective_type_params=false}; - sigquals = qual; - sigrng = d.drange; - sigmeta = default_sigmeta ; - sigattrs = top_attrs; - sigopts = None; - sigopens_and_abbrevs = opens_and_abbrevs env } in - let se' = { sigel = Sig_bundle {ses=[se]; lids=[l]}; - sigquals = qual; - sigrng = d.drange; - sigmeta = default_sigmeta ; - sigattrs = top_attrs; - sigopts = None; - sigopens_and_abbrevs = opens_and_abbrevs env } in - let env = push_sigelt env se' in - let data_ops = mk_data_projector_names [] env se in - let discs = mk_data_discriminators [] env [l] top_attrs in - let env = List.fold_left push_sigelt env (discs@data_ops) in - env, se'::discs@data_ops - - | NewEffect (RedefineEffect(eff_name, eff_binders, defn)) -> - let quals = d.quals in - desugar_redefine_effect env d d_attrs trans_qual quals eff_name eff_binders defn - - | NewEffect (DefineEffect(eff_name, eff_binders, eff_typ, eff_decls)) -> - let quals = d.quals in - desugar_effect env d d_attrs quals false eff_name eff_binders eff_typ eff_decls - - | LayeredEffect (DefineEffect (eff_name, eff_binders, eff_typ, eff_decls)) -> - let quals = d.quals in - desugar_effect env d d_attrs quals true eff_name eff_binders eff_typ eff_decls - - | LayeredEffect (RedefineEffect _) -> - failwith "Impossible: LayeredEffect (RedefineEffect _) (should not be parseable)" - - | SubEffect l -> - let src_ed = lookup_effect_lid env l.msource d.drange in - let dst_ed = lookup_effect_lid env l.mdest d.drange in - let top_attrs = d_attrs in - if not (U.is_layered src_ed || U.is_layered dst_ed) - then let lift_wp, lift = match l.lift_op with - | NonReifiableLift t -> Some ([],desugar_term env t), None - | ReifiableLift (wp, t) -> Some ([],desugar_term env wp), Some([], desugar_term env t) - | LiftForFree t -> None, Some ([],desugar_term env t) - in - let se = { sigel = Sig_sub_effect({source=src_ed.mname; - target=dst_ed.mname; - lift_wp=lift_wp; - lift=lift; - kind=None}); - sigquals = []; - sigrng = d.drange; - sigmeta = default_sigmeta ; - sigattrs = top_attrs; - sigopts = None; - sigopens_and_abbrevs = opens_and_abbrevs env } in - env, [se] - else - (match l.lift_op with - | NonReifiableLift t -> - let sub_eff = { - source = src_ed.mname; - target = dst_ed.mname; - lift_wp = None; - lift = Some ([], desugar_term env t); - kind = None - } in - env, [{ - sigel = Sig_sub_effect sub_eff; - sigquals = []; - sigrng = d.drange; - sigmeta = default_sigmeta; - sigattrs = top_attrs; - sigopts = None; - sigopens_and_abbrevs = opens_and_abbrevs env}] - | _ -> failwith "Impossible! unexpected lift_op for lift to a layered effect") - - | Polymonadic_bind (m_eff, n_eff, p_eff, bind) -> - let m = lookup_effect_lid env m_eff d.drange in - let n = lookup_effect_lid env n_eff d.drange in - let p = lookup_effect_lid env p_eff d.drange in - let top_attrs = d_attrs in - env, [{ - sigel = Sig_polymonadic_bind { - m_lid=m.mname; - n_lid=n.mname; - p_lid=p.mname; - tm=([], desugar_term env bind); - typ=([], S.tun); - kind=None }; - sigquals = []; - sigrng = d.drange; - sigmeta = default_sigmeta; - sigattrs = top_attrs; - sigopts = None; - sigopens_and_abbrevs = opens_and_abbrevs env }] - - | Polymonadic_subcomp (m_eff, n_eff, subcomp) -> - let m = lookup_effect_lid env m_eff d.drange in - let n = lookup_effect_lid env n_eff d.drange in - let top_attrs = d_attrs in - env, [{ - sigel = Sig_polymonadic_subcomp { - m_lid=m.mname; - n_lid=n.mname; - tm=([], desugar_term env subcomp); - typ=([], S.tun); - kind=None }; - sigquals = []; - sigrng = d.drange; - sigmeta = default_sigmeta; - sigattrs = top_attrs; - sigopts = None; - sigopens_and_abbrevs = opens_and_abbrevs env }] - - | Splice (is_typed, ids, t) -> - let ids = - if d.interleaved - then [] - else ids - in - let t = desugar_term env t in - let top_attrs = d_attrs in - let se = { sigel = Sig_splice {is_typed; lids=List.map (qualify env) ids; tac=t}; - sigquals = List.map (trans_qual None) d.quals; - sigrng = d.drange; - sigmeta = default_sigmeta; - sigattrs = top_attrs; - sigopts = None; - sigopens_and_abbrevs = opens_and_abbrevs env } in - let env = push_sigelt env se in - env, [se] - - | UseLangDecls _ -> - env, [] - - | Unparseable -> - raise_error d Errors.Fatal_SyntaxError "Syntax error" - - | DeclSyntaxExtension (extension_name, code, _, range) -> ( - let extension_parser = FStar.Parser.AST.Util.lookup_extension_parser extension_name in - match extension_parser with - | None -> - raise_error range Errors.Fatal_SyntaxError - (BU.format1 "Unknown syntax extension %s" extension_name) - | Some parser -> - let open FStar.Parser.AST.Util in - let opens = { - open_namespaces = open_modules_and_namespaces env; - module_abbreviations = module_abbrevs env - } in - match parser.parse_decl opens code range with - | Inl error -> - raise_error error.range Errors.Fatal_SyntaxError error.message - | Inr d' -> - let quals = d'.quals @ d.quals in - let attrs = d'.attrs @ d.attrs in - desugar_decl_maybe_fail_attr env { d' with quals; attrs; drange=d.drange; interleaved=d.interleaved } - ) - - | DeclToBeDesugared tbs -> ( - match lookup_extension_tosyntax tbs.lang_name with - | None -> - raise_error d Errors.Fatal_SyntaxError - (BU.format1 "Could not find desugaring callback for extension %s" tbs.lang_name) - | Some desugar -> - let mk_sig sigel = - let top_attrs = d_attrs in - let sigel = - if d.interleaved - then ( - match sigel with - | Sig_splice s -> Sig_splice { s with lids = [] } - | _ -> sigel - ) - else sigel - in - let se = { - sigel; - sigquals = List.map (trans_qual None) d.quals; - sigrng = d.drange; - sigmeta = default_sigmeta; - sigattrs = top_attrs; - sigopts = None; - sigopens_and_abbrevs = opens_and_abbrevs env - } - in - se - in - let lids = List.map (qualify env) tbs.idents in - let sigelts' = desugar env tbs.blob lids d.drange in - let sigelts = List.map mk_sig sigelts' in - let env = List.fold_left push_sigelt env sigelts in - env, sigelts - ) - -let desugar_decls env decls = - let env, sigelts = - List.fold_left (fun (env, sigelts) d -> - let env, se = desugar_decl env d in - env, sigelts@se) (env, []) decls - in - env, sigelts - -(* Top-level functionality: from AST to a module - Keeps track of the name of variables and so on (in the context) - *) -let desugar_modul_common (curmod: option S.modul) env (m:AST.modul) : env_t & Syntax.modul & bool = - let env = match curmod, m with - | None, _ -> - env - | Some ({ name = prev_lid }), Module (current_lid, _) - when lid_equals prev_lid current_lid && Options.interactive () -> - // If we're in the interactive mode reading the contents of an fst after - // desugaring the corresponding fsti, don't finish the fsti - env - | Some prev_mod, _ -> - fst (Env.finish_module_or_interface env prev_mod) in - let (env, pop_when_done), mname, decls, intf = match m with - | Interface(mname, decls, admitted) -> - Env.prepare_module_or_interface true admitted env mname Env.default_mii, mname, decls, true - | Module(mname, decls) -> - Env.prepare_module_or_interface false false env mname Env.default_mii, mname, decls, false in - let env, sigelts = desugar_decls env decls in - let modul = { - name = mname; - declarations = sigelts; - is_interface=intf - } in - env, modul, pop_when_done - -let as_interface (m:AST.modul) : AST.modul = - match m with - | AST.Module(mname, decls) -> AST.Interface(mname, decls, true) - | i -> i - -let desugar_partial_modul curmod (env:env_t) (m:AST.modul) : env_t & Syntax.modul = - let m = - if Options.interactive () && - List.mem (get_file_extension (List.hd (Options.file_list ()))) ["fsti"; "fsi"] - then as_interface m - else m - in - let env, modul, pop_when_done = desugar_modul_common curmod env m in - if pop_when_done then Env.pop (), modul - else env, modul - -let desugar_modul env (m:AST.modul) : env_t & Syntax.modul = - Errors.with_ctx ("While desugaring module " ^ Class.Show.show (lid_of_modul m)) (fun () -> - let env, modul, pop_when_done = desugar_modul_common None env m in - let env, modul = Env.finish_module_or_interface env modul in - if Options.dump_module (string_of_lid modul.name) - then BU.print1 "Module after desugaring:\n%s\n" (show modul); - (if pop_when_done then export_interface modul.name env else env), modul - ) - -///////////////////////////////////////////////////////////////////////////////////////// -//External API for modules -///////////////////////////////////////////////////////////////////////////////////////// -let with_options (f:unit -> 'a) : 'a = - let light, r = - Options.with_saved_options (fun () -> - let r = f () in - let light = Options.ml_ish () in - light, r - ) - in - if light then Options.set_ml_ish (); - r - -let ast_modul_to_modul modul : withenv S.modul = - fun env -> - with_options (fun () -> - let e, m = desugar_modul env modul in - m, e) - -let decls_to_sigelts decls : withenv S.sigelts = - fun env -> - with_options (fun () -> - let env, sigelts = desugar_decls env decls in - sigelts, env) - -let partial_ast_modul_to_modul modul a_modul : withenv S.modul = - fun env -> - with_options (fun () -> - let env, modul = desugar_partial_modul modul env a_modul in - modul, env) - -let add_modul_to_env_core (finish: bool) (m:Syntax.modul) - (mii:module_inclusion_info) - (erase_univs:S.term -> S.term) : withenv unit = - fun en -> - let erase_univs_ed ed = - let erase_binders bs = - match bs with - | [] -> [] - | _ -> - let t = erase_univs (S.mk (Tm_abs {bs; body=S.t_unit; rc_opt=None}) Range.dummyRange) in - match (Subst.compress t).n with - | Tm_abs {bs} -> bs - | _ -> failwith "Impossible" - in - let binders, _, binders_opening = - Subst.open_term' (erase_binders ed.binders) S.t_unit in - let erase_term t = - Subst.close binders (erase_univs (Subst.subst binders_opening t)) - in - let erase_tscheme (us, t) = - let t = Subst.subst (Subst.shift_subst (List.length us) binders_opening) t in - [], Subst.close binders (erase_univs t) - in - let erase_action action = - let opening = Subst.shift_subst (List.length action.action_univs) binders_opening in - let erased_action_params = - match action.action_params with - | [] -> [] - | _ -> - let bs = erase_binders <| Subst.subst_binders opening action.action_params in - let t = S.mk (Tm_abs {bs; body=S.t_unit; rc_opt=None}) Range.dummyRange in - match (Subst.compress (Subst.close binders t)).n with - | Tm_abs {bs} -> bs - | _ -> failwith "Impossible" - in - let erase_term t = - Subst.close binders (erase_univs (Subst.subst opening t)) - in - { action with - action_univs = []; - action_params = erased_action_params; - action_defn = erase_term action.action_defn; - action_typ = erase_term action.action_typ - } - in - { ed with - univs = []; - binders = Subst.close_binders binders; - signature = U.apply_eff_sig erase_tscheme ed.signature; - combinators = apply_eff_combinators erase_tscheme ed.combinators; - actions = List.map erase_action ed.actions - } - in - let push_sigelt env se = - match se.sigel with - | Sig_new_effect ed -> - let se' = {se with sigel=Sig_new_effect (erase_univs_ed ed)} in - let env = Env.push_sigelt env se' in - push_reflect_effect env se.sigquals ed.mname se.sigrng - | _ -> Env.push_sigelt env se - in - let en, pop_when_done = Env.prepare_module_or_interface false false en m.name mii in - let en = List.fold_left - push_sigelt - (Env.set_current_module en m.name) - m.declarations in - let en = if finish then Env.finish en m else en in - (), (if pop_when_done then export_interface m.name en else en) - -let add_partial_modul_to_env = add_modul_to_env_core false -let add_modul_to_env = add_modul_to_env_core true diff --git a/src/tosyntax/FStar.ToSyntax.ToSyntax.fsti b/src/tosyntax/FStar.ToSyntax.ToSyntax.fsti deleted file mode 100644 index 51f66d3c421..00000000000 --- a/src/tosyntax/FStar.ToSyntax.ToSyntax.fsti +++ /dev/null @@ -1,60 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.ToSyntax.ToSyntax -open FStar.Compiler.Effect - -open FStar -open FStar.Compiler -open FStar.Compiler.Util -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.Syntax.Util -open FStar.Parser -open FStar.Syntax.DsEnv -open FStar.Parser.AST -open FStar.Ident - -module S = FStar.Syntax.Syntax -module U = FStar.Syntax.Util - -type extension_tosyntax_decl_t = env -> FStar.Dyn.dyn -> lids:list lident -> Range.range -> list sigelt' -val register_extension_tosyntax (lang_name:string) (cb:extension_tosyntax_decl_t) : unit - -val as_interface: AST.modul -> AST.modul -val desugar_term: env -> term -> S.term -val desugar_machine_integer: env -> repr:string - -> (FStar.Const.signedness & FStar.Const.width) - -> Range.range -> Syntax.term -val free_vars (tvars_only:bool) (e:env) (t:term) : list ident -val close: env -> term -> term - -val ast_modul_to_modul: AST.modul -> withenv Syntax.modul -val decls_to_sigelts: list AST.decl -> withenv sigelts -val partial_ast_modul_to_modul: option S.modul -> AST.modul -> withenv Syntax.modul - -val add_partial_modul_to_env: Syntax.modul - -> module_inclusion_info - -> erase_univs:(S.term -> S.term) - -> withenv unit -val add_modul_to_env: Syntax.modul - -> module_inclusion_info - -> erase_univs:(S.term -> S.term) - -> withenv unit - -val parse_attr_with_list : bool -> S.term -> lident -> option (list int) & bool - -val get_fail_attr1 : bool -> S.term -> option (list int & bool) -val get_fail_attr : bool -> list S.term -> option (list int & bool) diff --git a/src/tosyntax/FStarC.ToSyntax.Interleave.fst b/src/tosyntax/FStarC.ToSyntax.Interleave.fst new file mode 100644 index 00000000000..f9f6e76c971 --- /dev/null +++ b/src/tosyntax/FStarC.ToSyntax.Interleave.fst @@ -0,0 +1,451 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.ToSyntax.Interleave +open FStarC.Compiler.Effect +open FStarC.Compiler.List +//Reorders the top-level definitions/declarations in a file +//in a proper order for consistent type-checking + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Ident +open FStarC.Errors +open FStarC.Syntax.Syntax +open FStarC.Parser.AST +open FStarC.Class.Show +open FStarC.Pprint +open FStarC.Class.PP + +module BU = FStarC.Compiler.Util + +(* Some basic utilities *) +let id_eq_lid i (l:lident) = (string_of_id i) = (string_of_id (ident_of_lid l)) + +let is_val x d = match d.d with + | Val(y, _) -> (string_of_id x) = (string_of_id y) + | _ -> false + +let is_type x d = match d.d with + | Tycon(_, _, tys) -> + tys |> Util.for_some (fun t -> id_of_tycon t = (string_of_id x)) + | _ -> false + +// +//is d of of the form 'let x = ...' or 'type x = ...' or 'splice[..., x, ...] tac' +// returns unqualified lids +// +let definition_lids d = + match d.d with + | TopLevelLet(_, defs) -> + lids_of_let defs + | Tycon(_, _, tys) -> + tys |> List.collect (function + | TyconAbbrev (id, _, _, _) + | TyconRecord (id, _, _, _, _) + | TyconVariant(id, _, _, _) -> + [Ident.lid_of_ids [id]] + | _ -> []) + | Splice (_, ids, _) + | DeclToBeDesugared { idents=ids } -> List.map (fun id -> Ident.lid_of_ids [id]) ids + + | DeclSyntaxExtension (extension_name, code, _, range) -> begin + let ext_parser = FStarC.Parser.AST.Util.lookup_extension_parser extension_name in + match ext_parser with + | None -> + raise_error d Errors.Fatal_SyntaxError + (BU.format1 "Unknown syntax extension %s" extension_name) + | Some parser -> + match parser.parse_decl_name code range with + | Inl error -> + raise_error error.range Errors.Fatal_SyntaxError error.message + | Inr id -> + [Ident.lid_of_ids [id]] + end + | _ -> [] + +let is_definition_of x d = + Util.for_some (id_eq_lid x) (definition_lids d) + + + +(* The basic idea of interleaving is governed by the following: + + Ordering rule + If a val-declaration for 'a' precedes a val-declaration for 'b', + then the let-definition for 'a' must precede the let-definition for 'b'. + + In effect, this means that + + val a + let x0 + val b + let x1 + + let a + let b + + Is effectively ordered as: + + val a + let x0 + let x1 + let a + + val b + let b + + Essentially, we need to check that the definition of `a` matches + its signature in `val a : ta` before we allow `a` to be used + in the signature `val b : tb` and its corresponding definition + `let b : eb`. + + One wrinkle to deal with is mutual recursion. + + Given: + + val a1 + val a2 + let x0 + val b + let x1 + + let rec a1 + and a2 + let b + + Interleaving produces: + + val a1 : ta1 + val a2 : ta2 + let x0 + let x1 + + let rec a1 + and a2 + + val b + let b + + I.e, the vals and the let-recs "move together" + + One consequence of interleaving is that a program is type-checked + in an order different from the sequential order of the text the + programmer wrote. This may result in potentially unintuitive error + message ordering. + + *) + +let rec prefix_with_iface_decls + (iface:list decl) + (impl:decl) + : list decl //remaining iface decls + & list decl = //d prefixed with relevant bits from iface + let qualify_karamel_private impl = + let karamel_private = + FStarC.Parser.AST.mk_term + (Const (FStarC.Const.Const_string ("KrmlPrivate", impl.drange))) + impl.drange + FStarC.Parser.AST.Expr + in + {impl with attrs=karamel_private::impl.attrs} + in + match iface with + | [] -> [], [qualify_karamel_private impl] + | iface_hd::iface_tl -> begin + match iface_hd.d with + | Tycon(_, _, tys) when (tys |> Util.for_some (function (TyconAbstract _) -> true | _ -> false)) -> + raise_error impl Errors.Fatal_AbstractTypeDeclarationInInterface [ + text "Interface contains an abstract 'type' declaration; use 'val' instead." + ] + + | Splice (_, [x], _) + | Val(x, _) -> + //we have a 'val x' in the interface + //take impl as is, unless it is a + // let x (or a `type abbreviation x`) + //or an inductive type x + //or a splice that defines x + //in which case prefix it with iface_hd + let def_ids = definition_lids impl in + let defines_x = Util.for_some (id_eq_lid x) def_ids in + if not defines_x then ( + if def_ids |> Util.for_some (fun y -> + iface_tl |> Util.for_some (is_val (ident_of_lid y))) + then + raise_error impl Errors.Fatal_WrongDefinitionOrder [ + text "Expected the definition of" ^/^ pp x ^/^ text "to precede" + ^/^ (pp def_ids) + ]; + iface, [qualify_karamel_private impl] + ) else ( + let mutually_defined_with_x = def_ids |> List.filter (fun y -> not (id_eq_lid x y)) in + let rec aux mutuals iface = + match mutuals, iface with + | [], _ -> [], iface + | _::_, [] -> [], [] + | y::ys, iface_hd::iface_tl when is_val (ident_of_lid y) iface_hd -> + let val_ys, iface = aux ys iface_tl in + iface_hd::val_ys, iface + + | y::ys, iface_hd::iface_tl when Option.isSome <| List.tryFind (is_val (ident_of_lid y)) iface_tl -> + raise_error iface_hd Errors.Fatal_WrongDefinitionOrder [ + text (Util.format2 "%s is out of order with the definition of %s" + (show iface_hd) + (Ident.string_of_lid y)) + ] + | y::ys, iface_hd::iface_tl -> + aux ys iface //no val given for 'y'; ok + in + let take_iface, rest_iface = aux mutually_defined_with_x iface_tl in + rest_iface, iface_hd::take_iface@[impl] + ) + + | Pragma _ -> + (* Don't interleave pragmas on interface into implementation *) + prefix_with_iface_decls iface_tl impl + + | _ -> + let iface, ds = prefix_with_iface_decls iface_tl impl in + iface, iface_hd::ds + end + +let check_initial_interface (iface:list decl) = + let rec aux iface = + match iface with + | [] -> () + | hd::tl -> begin + match hd.d with + | Tycon(_, _, tys) when (tys |> Util.for_some (function (TyconAbstract _) -> true | _ -> false)) -> + raise_error hd Errors.Fatal_AbstractTypeDeclarationInInterface + "Interface contains an abstract 'type' declaration; use 'val' instead" + + | Val(x, t) -> //we have a 'val x' in the interface + if Util.for_some (is_definition_of x) tl + then raise_error hd Errors.Fatal_BothValAndLetInInterface + (Util.format2 "'val %s' and 'let %s' cannot both be provided in an interface" (string_of_id x) (string_of_id x)) + else if hd.quals |> List.contains Assumption + then raise_error hd Errors.Fatal_AssumeValInInterface + "Interfaces cannot use `assume val x : t`; just write `val x : t` instead" + else () + + | _ -> () + end + in + aux iface; + iface |> List.filter (fun d -> match d.d with TopLevelModule _ -> false | _ -> true) + +////////////////////////////////////////////////////////////////////// +//A weaker variant, for use only in --MLish mode +////////////////////////////////////////////////////////////////////// +//in --MLish mode: the interleaving rules are WAY more lax +// this is basically only in support of bootstrapping the compiler +// Here, if you have a `let x = e` in the implementation +// Then prefix it with `val x : t`, if any in the interface +// Don't enforce any ordering constraints +let ml_mode_prefix_with_iface_decls + (iface:list decl) + (impl:decl) + : list decl //remaining iface decls + & list decl = //impl prefixed with relevant bits from iface + + + match impl.d with + | TopLevelModule _ + | Open _ + | Friend _ + | Include _ + | ModuleAbbrev _ -> + let iface_prefix_opens, iface = + List.span (fun d -> match d.d with | Open _ | ModuleAbbrev _ -> true | _ -> false) iface + in + let iface = + List.filter + (fun d -> + match d.d with + | Val _ + | Tycon _ -> true //only retain the vals in --MLish mode + | _ -> false) + iface + in + iface, [impl]@iface_prefix_opens + + | _ -> + + let iface_prefix_tycons, iface = + List.span (fun d -> match d.d with | Tycon _ -> true | _ -> false) iface + in + + let maybe_get_iface_vals lids iface = + List.partition + (fun d -> lids |> Util.for_some (fun x -> is_val (ident_of_lid x) d)) + iface in + + match impl.d with + | TopLevelLet _ + | Tycon _ -> + let xs = definition_lids impl in + let val_xs, rest_iface = maybe_get_iface_vals xs iface in + rest_iface, iface_prefix_tycons@val_xs@[impl] + | _ -> + iface, iface_prefix_tycons@[impl] + +let ml_mode_check_initial_interface mname (iface:list decl) = + iface |> List.filter (fun d -> + match d.d with + | Tycon(_, _, tys) + when (tys |> Util.for_some (function (TyconAbstract _) -> true | _ -> false)) -> + raise_error d Errors.Fatal_AbstractTypeDeclarationInInterface + "Interface contains an abstract 'type' declaration; use 'val' instead" + | Tycon _ + | Val _ + | Open _ + | ModuleAbbrev _ -> true + | _ -> false) + +let ulib_modules = [ + "FStar.Calc"; + "FStar.TSet"; + "FStar.Seq.Base"; + "FStar.Seq.Properties"; + "FStar.UInt"; + "FStar.UInt8"; + "FStar.UInt16"; + "FStar.UInt32"; + "FStar.UInt64"; + "FStar.Int"; + "FStar.Int8"; + "FStar.Int16"; + "FStar.Int32"; + "FStar.Int64"; +] + +(* + * AR: ml mode optimizations are only applied in ml mode and only to non-core files + * + * otherwise we skip effect declarations like Lemma from Pervasives.fsti, + * resulting in desugaring failures when typechecking Pervasives.fst + *) +let apply_ml_mode_optimizations (mname:lident) : bool = + (* + * AR: 03/29: + * As we introduce interfaces for modules in ulib/, the interleaving code + * doesn't interact with it too well when bootstrapping + * Essentially we do optimizations here (e.g. not taking any interface decls but vals) + * when bootstrapping + * This doesn't work well for ulib files (but is ok for compiler files) + * A better way to fix this problem would be to make compiler files in a separate namespace + * and then do these optimizations (as well as --MLish etc.) only for them + * But until then ... (sigh) + *) + Options.ml_ish () && + (not (List.contains (Ident.string_of_lid mname) (Parser.Dep.core_modules ()))) && + (not (List.contains (Ident.string_of_lid mname) ulib_modules)) + +let prefix_one_decl mname iface impl = + match impl.d with + | TopLevelModule _ -> iface, [impl] + | _ -> + if apply_ml_mode_optimizations mname + then ml_mode_prefix_with_iface_decls iface impl + else prefix_with_iface_decls iface impl + +////////////////////////////////////////////////////////////////////////// +//Top-level interface +////////////////////////////////////////////////////////////////////////// +module E = FStarC.Syntax.DsEnv +let initialize_interface (mname:Ident.lid) (l:list decl) : E.withenv unit = + fun (env:E.env) -> + let decls = + if apply_ml_mode_optimizations mname + then ml_mode_check_initial_interface mname l + else check_initial_interface l in + match E.iface_decls env mname with + | Some _ -> + raise_error mname Errors.Fatal_InterfaceAlreadyProcessed + (Util.format1 "Interface %s has already been processed" (show mname)) + | None -> + (), E.set_iface_decls env mname decls + +let fixup_interleaved_decls (iface : list decl) : list decl = + let fix1 (d : decl) : decl = + let d = { d with interleaved = true } in + d + in + iface |> List.map fix1 + +let prefix_with_interface_decls mname (impl:decl) : E.withenv (list decl) = + fun (env:E.env) -> + let decls, env = + match E.iface_decls env (E.current_module env) with + | None -> + [impl], env + | Some iface -> + let iface = fixup_interleaved_decls iface in + let iface, impl = prefix_one_decl mname iface impl in + let env = E.set_iface_decls env (E.current_module env) iface in + impl, env + in + if Options.dump_module (Ident.string_of_lid mname) + then Util.print1 "Interleaved decls:\n%s\n" (show decls); + decls,env + + +let interleave_module (a:modul) (expect_complete_modul:bool) : E.withenv modul = + fun (env:E.env) -> + match a with + | Interface _ -> a, env + | Module(l, impls) -> begin + match E.iface_decls env l with + | None -> a, env + | Some iface -> + let iface = fixup_interleaved_decls iface in + let iface, impls = + List.fold_left + (fun (iface, impls) impl -> + let iface, impls' = prefix_one_decl l iface impl in + iface, impls@impls') + (iface, []) + impls + in + let iface_lets, remaining_iface_vals = + match FStarC.Compiler.Util.prefix_until (function {d=Val _} -> true + | {d=Splice _} -> true + | _ -> false) iface with + | None -> iface, [] + | Some (lets, one_val, rest) -> lets, one_val::rest + in + let impls = impls@iface_lets in + let env = + if Options.interactive() + then E.set_iface_decls env l remaining_iface_vals + else env //if not interactive, then don't consume iface_decls + //since some batch-mode checks, e.g., must_erase_for_extraction + //depend on having all the iface decls around + in + let a = Module(l, impls) in + match remaining_iface_vals with + | _::_ when expect_complete_modul -> + let open FStarC.Pprint in + log_issue l Errors.Fatal_InterfaceNotImplementedByModule [ + text (Util.format1 "Some interface elements were not implemented by module %s:" (show l)) + ^^ sublist empty (List.map (fun d -> doc_of_string (show d)) remaining_iface_vals) + ]; + a, env + | _ -> + if Options.dump_module (string_of_lid l) + then Util.print1 "Interleaved module is:\n%s\n" (FStarC.Parser.AST.modul_to_string a); + a, env + end diff --git a/src/tosyntax/FStarC.ToSyntax.Interleave.fsti b/src/tosyntax/FStarC.ToSyntax.Interleave.fsti new file mode 100644 index 00000000000..0c84301c9a5 --- /dev/null +++ b/src/tosyntax/FStarC.ToSyntax.Interleave.fsti @@ -0,0 +1,27 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.ToSyntax.Interleave +open FStarC.Compiler.Effect +open FStarC.Compiler.Effect +open FStarC.Ident +open FStarC.Parser.AST +module DsEnv = FStarC.Syntax.DsEnv + +(* GM: If I don't use the full name, I cannot bootstrap *) + +val initialize_interface: lident -> list decl -> DsEnv.withenv unit +val prefix_with_interface_decls: lident -> decl -> DsEnv.withenv (list decl) +val interleave_module: modul -> bool -> DsEnv.withenv modul diff --git a/src/tosyntax/FStarC.ToSyntax.ToSyntax.fst b/src/tosyntax/FStarC.ToSyntax.ToSyntax.fst new file mode 100644 index 00000000000..07f8fabff13 --- /dev/null +++ b/src/tosyntax/FStarC.ToSyntax.ToSyntax.fst @@ -0,0 +1,4446 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.ToSyntax.ToSyntax +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.Syntax.Util +open FStarC.Parser +open FStarC.Syntax.DsEnv +open FStarC.Parser.AST +open FStarC.Ident +open FStarC.Const +open FStarC.Errors +open FStarC.Syntax +open FStarC.Class.Setlike +open FStarC.Class.Show + +module C = FStarC.Parser.Const +module S = FStarC.Syntax.Syntax +module U = FStarC.Syntax.Util +module BU = FStarC.Compiler.Util +module Env = FStarC.Syntax.DsEnv +module P = FStarC.Syntax.Print +module EMB = FStarC.Syntax.Embeddings +module SS = FStarC.Syntax.Subst + +let extension_tosyntax_table +: BU.smap extension_tosyntax_decl_t += FStarC.Compiler.Util.smap_create 20 + +let register_extension_tosyntax + (lang_name:string) + (cb:extension_tosyntax_decl_t) += FStarC.Compiler.Util.smap_add extension_tosyntax_table lang_name cb + +let lookup_extension_tosyntax + (lang_name:string) += FStarC.Compiler.Util.smap_try_find extension_tosyntax_table lang_name + +let dbg_attrs = Debug.get_toggle "attrs" +let dbg_ToSyntax = Debug.get_toggle "ToSyntax" + +type antiquotations_temp = list (bv & S.term) + +let tun_r (r:Range.range) : S.term = { tun with pos = r } + +type annotated_pat = Syntax.pat & list (bv & Syntax.typ & list S.term) + +let mk_thunk e = + let b = S.mk_binder (S.new_bv None S.tun) in + U.abs [b] e None + +let mk_binder_with_attrs bv aq attrs = + let pqual, attrs = U.parse_positivity_attributes attrs in + S.mk_binder_with_attrs bv aq pqual attrs + +(* + If the user wrote { f1=v1; ...; fn=vn }, where `field_names` [f1;..;fn] + then we resolve this, using scoping rules only, to `record`. + + The choice of `record` is not settled, however, since type information + later can be used to resolve any ambiguity. + + However, if any of the field_names, f1...fn, are qualified field names, + like `A.B.f`, then, at this stage, we + + 1. Check that all the field names, if qualified, are qualified in + the same way. I.e., it's ok to write + + { A.f1 = v1; f2 = v2; ... } + + But not + + { A.f1 = v1; B.f2 = v2; ... } + + even if A and B are module aliases. + + 2. If any of the field names are qualified, then qualify all the + field_names to the module in which `record` is defined, since + that's the user-provided qualifier already determines that. + + This is important because at this stage, A, B etc. can refer to + module aliases, included modules, etc. and as we pass the term + to the typechecker, all those module aliases have to be fully + resolved. +*) +let qualify_field_names record_or_dc_lid field_names = + let qualify_to_record l = + let ns = ns_of_lid record_or_dc_lid in + Ident.lid_of_ns_and_id ns (ident_of_lid l) + in + let _, field_names_rev = + List.fold_left + (fun (ns_opt, out) l -> + match nsstr l with + | "" -> + if Option.isSome ns_opt + then (ns_opt, qualify_to_record l::out) + else (ns_opt, l::out) + + | ns -> + match ns_opt with + | Some ns' -> + if ns <> ns' + then raise_error l Errors.Fatal_MissingFieldInRecord + (BU.format2 "Field %s of record type was expected to be scoped to namespace %s" (show l) ns') + else ( + ns_opt, qualify_to_record l :: out + ) + + | None -> + Some ns, qualify_to_record l :: out) + (None, []) + field_names + in + List.rev field_names_rev + +let desugar_disjunctive_pattern annotated_pats when_opt branch = + annotated_pats |> List.map (fun (pat, annots) -> + let branch = List.fold_left (fun br (bv, ty, _) -> + let lb = U.mk_letbinding (Inl bv) [] ty C.effect_Tot_lid (S.bv_to_name bv) [] br.pos in + let branch = SS.close [S.mk_binder bv] branch in + mk (Tm_let {lbs=(false, [lb]); body=branch}) br.pos) branch annots in + U.branch(pat, when_opt, branch) + ) + +let trans_qual (r:Range.range) maybe_effect_id = function + | AST.Private -> S.Private + | AST.Assumption -> S.Assumption + | AST.Unfold_for_unification_and_vcgen -> S.Unfold_for_unification_and_vcgen + | AST.Inline_for_extraction -> S.Inline_for_extraction + | AST.NoExtract -> S.NoExtract + | AST.Irreducible -> S.Irreducible + | AST.Logic -> S.Logic + | AST.TotalEffect -> S.TotalEffect + | AST.Effect_qual -> S.Effect + | AST.New -> S.New + | AST.Opaque -> + Errors.log_issue r Errors.Warning_DeprecatedOpaqueQualifier [ + text "The 'opaque' qualifier is deprecated since its use was strangely schizophrenic."; + text "There were two overloaded uses: (1) Given 'opaque val f : t', the behavior was to exclude the definition of 'f' to the SMT solver. This corresponds roughly to the new 'irreducible' qualifier. (2) Given 'opaque type t = t'', the behavior was to provide the definition of 't' to the SMT solver, but not to inline it, unless absolutely required for unification. This corresponds roughly to the behavior of 'unfoldable' (which is currently the default)." + ]; + S.Visible_default + | AST.Reflectable -> + begin match maybe_effect_id with + | None -> raise_error r Errors.Fatal_ReflectOnlySupportedOnEffects "Qualifier reflect only supported on effects" + | Some effect_id -> S.Reflectable effect_id + end + | AST.Reifiable -> S.Reifiable + | AST.Noeq -> S.Noeq + | AST.Unopteq -> S.Unopteq + | AST.DefaultEffect -> raise_error r Errors.Fatal_DefaultQualifierNotAllowedOnEffects "The 'default' qualifier on effects is no longer supported" + | AST.Inline + | AST.Visible -> + raise_error r Errors.Fatal_UnsupportedQualifier "Unsupported qualifier" + +let trans_pragma = function + | AST.ShowOptions -> S.ShowOptions + | AST.SetOptions s -> S.SetOptions s + | AST.ResetOptions sopt -> S.ResetOptions sopt + | AST.PushOptions sopt -> S.PushOptions sopt + | AST.PopOptions -> S.PopOptions + | AST.RestartSolver -> S.RestartSolver + | AST.PrintEffectsGraph -> S.PrintEffectsGraph + +let as_imp = function + | Hash -> S.as_aqual_implicit true + | _ -> None +let arg_withimp_t imp t = + t, as_imp imp + +let contains_binder binders = + binders |> BU.for_some (fun b -> match b.b with + | Annotated _ -> true + | _ -> false) + +let rec unparen t = match t.tm with + | Paren t -> unparen t + | _ -> t + +let tm_type_z r = mk_term (Name (lid_of_path ["Type0"] r)) r Kind +let tm_type r = mk_term (Name (lid_of_path [ "Type"] r)) r Kind + +//Deciding if the t is a computation type +//based on its head symbol +let rec is_comp_type env t = + match (unparen t).tm with + (* we're right at the beginning of Prims, when (G)Tot isn't yet fully defined *) + | Name l when lid_equals (Env.current_module env) C.prims_lid && + (let s = string_of_id (ident_of_lid l) in + s = "Tot" || s = "GTot") -> + true + + | Name l + | Construct(l, _) -> Env.try_lookup_effect_name env l |> Option.isSome + | App(head, _, _) -> is_comp_type env head + | Paren t -> failwith "impossible" + | Ascribed(t, _, _, _) + | LetOpen(_, t) -> is_comp_type env t + | _ -> false + +let unit_ty rng = mk_term (Name C.unit_lid) rng Type_level + +type env_t = Env.env +type lenv_t = list bv + +let desugar_name' setpos (env: env_t) (resolve: bool) (l: lid) : option S.term = + let tm_attrs_opt = + if resolve + then Env.try_lookup_lid_with_attributes env l + else Env.try_lookup_lid_with_attributes_no_resolve env l + in + match tm_attrs_opt with + | None -> None + | Some (tm, attrs) -> + let tm = setpos tm in + Some tm + +let desugar_name mk setpos env resolve l = + fail_or env (desugar_name' setpos env resolve) l + +let compile_op_lid n s r = [mk_ident(compile_op n s r, r)] |> lid_of_ids + +let op_as_term env arity op : option S.term = + let r l = Some (S.lid_and_dd_as_fv (set_lid_range l (range_of_id op)) None |> S.fv_to_tm) in + let fallback () = + match Ident.string_of_id op with + | "=" -> r C.op_Eq + | "<" -> r C.op_LT + | "<=" -> r C.op_LTE + | ">" -> r C.op_GT + | ">=" -> r C.op_GTE + | "&&" -> r C.op_And + | "||" -> r C.op_Or + | "+" -> r C.op_Addition + | "-" when (arity=1) -> r C.op_Minus + | "-" -> r C.op_Subtraction + | "/" -> r C.op_Division + | "%" -> r C.op_Modulus + | "@" -> + FStarC.Errors.log_issue op FStarC.Errors.Warning_DeprecatedGeneric [ + Errors.Msg.text "The operator '@' has been resolved to FStar.List.Tot.append even though \ + FStar.List.Tot is not in scope. Please add an 'open FStar.List.Tot' to \ + stop relying on this deprecated, special treatment of '@'."]; + r C.list_tot_append_lid + + | "<>" -> r C.op_notEq + | "~" -> r C.not_lid + | "==" -> r C.eq2_lid + | "<<" -> r C.precedes_lid + | "/\\" -> r C.and_lid + | "\\/" -> r C.or_lid + | "==>" -> r C.imp_lid + | "<==>" -> r C.iff_lid + | _ -> None + in + match desugar_name' (fun t -> {t with pos=(range_of_id op)}) + env true (compile_op_lid arity (string_of_id op) (range_of_id op)) with + | Some t -> Some t + | _ -> fallback() + +let sort_ftv ftv = + BU.sort_with (fun x y -> String.compare (string_of_id x) (string_of_id y)) <| + BU.remove_dups (fun x y -> (string_of_id x) = (string_of_id y)) ftv + +let rec free_vars_b tvars_only env binder : (Env.env & list ident) = + match binder.b with + | Variable x -> + if tvars_only + then env, [] //tvars can't clash with vars + else ( + let env, _ = Env.push_bv env x in + env, [] + ) + | TVariable x -> + let env, _ = Env.push_bv env x in + env, [x] + | Annotated(x, term) -> + if tvars_only //tvars can't clash with vars + then env, free_vars tvars_only env term + else ( + let env', _ = Env.push_bv env x in + env', free_vars tvars_only env term + ) + | TAnnotated(id, term) -> + let env', _ = Env.push_bv env id in + env', free_vars tvars_only env term + | NoName t -> + env, free_vars tvars_only env t + +and free_vars_bs tvars_only env binders = + List.fold_left + (fun (env, free) binder -> + let env, f = free_vars_b tvars_only env binder in + env, f@free) + (env, []) + binders + +and free_vars tvars_only env t = match (unparen t).tm with + | Labeled _ -> failwith "Impossible --- labeled source term" + + | Tvar a -> + (match Env.try_lookup_id env a with + | None -> [a] + | _ -> []) + + | Var x -> + if tvars_only + then [] + else ( + let ids = Ident.ids_of_lid x in + match ids with + | [id] -> ( //unqualified name + if None? (Env.try_lookup_id env id) + && None? (Env.try_lookup_lid env x) + then [id] + else [] + ) + | _ -> [] + ) + + | Wild + | Const _ + | Uvar _ + + | Projector _ + | Discrim _ + | Name _ -> [] + + | Requires (t, _) + | Ensures (t, _) + | Decreases (t, _) + | NamedTyp(_, t) -> free_vars tvars_only env t + + | LexList l -> List.collect (free_vars tvars_only env) l + | WFOrder (rel, e) -> + (free_vars tvars_only env rel) @ (free_vars tvars_only env e) + + | Paren t -> failwith "impossible" + + | Ascribed(t, t', tacopt, _) -> + let ts = t::t'::(match tacopt with None -> [] | Some t -> [t]) in + List.collect (free_vars tvars_only env) ts + + | Construct(_, ts) -> List.collect (fun (t, _) -> free_vars tvars_only env t) ts + + | Op(_, ts) -> List.collect (free_vars tvars_only env) ts + + | App(t1,t2,_) -> free_vars tvars_only env t1@free_vars tvars_only env t2 + + | Refine (b, t) -> + let env, f = free_vars_b tvars_only env b in + f@free_vars tvars_only env t + + | Sum(binders, body) -> + let env, free = List.fold_left (fun (env, free) bt -> + let env, f = + match bt with + | Inl binder -> free_vars_b tvars_only env binder + | Inr t -> env, free_vars tvars_only env t + in + env, f@free) (env, []) binders in + free@free_vars tvars_only env body + + | Product(binders, body) -> + let env, free = free_vars_bs tvars_only env binders in + free@free_vars tvars_only env body + + | Project(t, _) -> free_vars tvars_only env t + + | Attributes cattributes -> + (* attributes should be closed but better safe than sorry *) + List.collect (free_vars tvars_only env) cattributes + + | CalcProof (rel, init, steps) -> + free_vars tvars_only env rel + @ free_vars tvars_only env init + @ List.collect (fun (CalcStep (rel, just, next)) -> + free_vars tvars_only env rel + @ free_vars tvars_only env just + @ free_vars tvars_only env next) steps + + | ElimForall (bs, t, ts) -> + let env', free = free_vars_bs tvars_only env bs in + free@ + free_vars tvars_only env' t@ + List.collect (free_vars tvars_only env') ts + + | ElimExists (binders, p, q, y, e) -> + let env', free = free_vars_bs tvars_only env binders in + let env'', free' = free_vars_b tvars_only env' y in + free@ + free_vars tvars_only env' p@ + free_vars tvars_only env q@ + free'@ + free_vars tvars_only env'' e + + | ElimImplies (p, q, e) -> + free_vars tvars_only env p@ + free_vars tvars_only env q@ + free_vars tvars_only env e + + | ElimOr(p, q, r, x, e, x', e') -> + free_vars tvars_only env p@ + free_vars tvars_only env q@ + free_vars tvars_only env r@ + (let env', free = free_vars_b tvars_only env x in + free@free_vars tvars_only env' e)@ + (let env', free = free_vars_b tvars_only env x' in + free@free_vars tvars_only env' e') + + | ElimAnd(p, q, r, x, y, e) -> + free_vars tvars_only env p@ + free_vars tvars_only env q@ + free_vars tvars_only env r@ + (let env', free = free_vars_bs tvars_only env [x;y] in + free@free_vars tvars_only env' e) + + | ListLiteral ts -> + List.collect (free_vars tvars_only env) ts + + | SeqLiteral ts -> + List.collect (free_vars tvars_only env) ts + + | Abs _ (* not closing implicitly over free vars in all these forms: TODO: Fixme! *) + | Function _ + | Let _ + | LetOpen _ + | If _ + | QForall _ + | QExists _ + | QuantOp _ + | Record _ + | Match _ + | TryWith _ + | Bind _ + | Quote _ + | VQuote _ + | Antiquote _ + | Seq _ -> [] + +let free_type_vars = free_vars true + +let head_and_args t = + let rec aux args t = match (unparen t).tm with + | App(t, arg, imp) -> aux ((arg,imp)::args) t + | Construct(l, args') -> {tm=Name l; range=t.range; level=t.level}, args'@args + | _ -> t, args in + aux [] t + +let close env t = + let ftv = sort_ftv <| free_type_vars env t in + if List.length ftv = 0 + then t + else let binders = ftv |> List.map (fun x -> mk_binder (TAnnotated(x, tm_type (range_of_id x))) (range_of_id x) Type_level (Some Implicit)) in + let result = mk_term (Product(binders, t)) t.range t.level in + result + +let close_fun env t = + let ftv = sort_ftv <| free_type_vars env t in + if List.length ftv = 0 + then t + else let binders = ftv |> List.map (fun x -> mk_binder (TAnnotated(x, tm_type (range_of_id x))) (range_of_id x) Type_level (Some Implicit)) in + let t = match (unparen t).tm with + | Product _ -> t + | _ -> mk_term (App(mk_term (Name C.effect_Tot_lid) t.range t.level, t, Nothing)) t.range t.level in + let result = mk_term (Product(binders, t)) t.range t.level in + result + +let rec uncurry bs t = match t.tm with + | Product(binders, t) -> uncurry (bs@binders) t + | _ -> bs, t + +let rec is_var_pattern p = match p.pat with + | PatWild _ + | PatTvar _ + | PatVar _ -> true + | PatAscribed(p, _) -> is_var_pattern p + | _ -> false + +let rec is_app_pattern p = match p.pat with + | PatAscribed(p,_) -> is_app_pattern p + | PatApp({pat=PatVar _}, _) -> true + | _ -> false + +let replace_unit_pattern p = match p.pat with + | PatConst FStarC.Const.Const_unit -> + mk_pattern (PatAscribed (mk_pattern (PatWild (None, [])) p.prange, (unit_ty p.prange, None))) p.prange + | _ -> p + +let rec destruct_app_pattern (env:env_t) (is_top_level:bool) (p:pattern) + : either ident lid // name at the head + & list pattern // arguments the head is applied to + & option (term & option term) // a possible (outermost) ascription on the pattern + = + match p.pat with + | PatAscribed(p,t) -> + let (name, args, _) = destruct_app_pattern env is_top_level p in + (name, args, Some t) + | PatApp({pat=PatVar (id, _, _)}, args) when is_top_level -> + (Inr (qualify env id), args, None) + | PatApp({pat=PatVar (id, _, _)}, args) -> + (Inl id, args, None) + | _ -> + failwith "Not an app pattern" + +let rec gather_pattern_bound_vars_maybe_top (acc : FlatSet.t ident) p = + let gather_pattern_bound_vars_from_list = + List.fold_left gather_pattern_bound_vars_maybe_top acc + in + match p.pat with + | PatWild _ + | PatConst _ + | PatVQuote _ + | PatName _ + | PatOp _ -> acc + | PatApp (phead, pats) -> gather_pattern_bound_vars_from_list (phead::pats) + | PatTvar (x, _, _) + | PatVar (x, _, _) -> add x acc + | PatList pats + | PatTuple (pats, _) + | PatOr pats -> gather_pattern_bound_vars_from_list pats + | PatRecord guarded_pats -> gather_pattern_bound_vars_from_list (List.map snd guarded_pats) + | PatAscribed (pat, _) -> gather_pattern_bound_vars_maybe_top acc pat + +let gather_pattern_bound_vars : pattern -> FlatSet.t Ident.ident = + let acc = empty #ident () in + fun p -> gather_pattern_bound_vars_maybe_top acc p + +type bnd = + | LocalBinder of bv & S.bqual & list S.term //binder attributes + | LetBinder of lident & (S.term & option S.term) + +let is_implicit (b:bnd) : bool = + match b with + | LocalBinder (_, Some (S.Implicit _), _) -> true + | _ -> false + +let binder_of_bnd = function + | LocalBinder (a, aq, attrs) -> a, aq, attrs + | _ -> failwith "Impossible" + +(* TODO : shouldn't this be Tot by default ? *) +let mk_lb (attrs, n, t, e, pos) = { + lbname=n; + lbunivs=[]; + lbeff=C.effect_ALL_lid (); + lbtyp=t; + lbdef=e; + lbattrs=attrs; + lbpos=pos; +} +let no_annot_abs bs t = U.abs bs t None + +(* + * Collect the explicitly annotated universes in the sigelt, close the sigelt with them, and stash them appropriately in the sigelt + *) +let rec generalize_annotated_univs (s:sigelt) :sigelt = + (* NB!! Order is very important here, so a definition like + type t = Type u#a -> Type u#b + gets is two universe parameters in the order in which + they appear. So we do not use a set, and instead just use a mutable + list that we update as we find universes. We also keep a set of 'seen' + universes, whose order we do not care, just for efficiency. *) + let vars : ref (list univ_name) = mk_ref [] in + let seen : ref (RBSet.t univ_name) = mk_ref (empty ()) in + let reg (u:univ_name) : unit = + if not (mem u !seen) then ( + seen := add u !seen; + vars := u::!vars + ) + in + let get () : list univ_name = List.rev !vars in + + (* Visit the sigelt and rely on side effects to capture all + the names. This goes roughly in left-to-right order. *) + let _ = Visit.visit_sigelt false + (fun t -> t) + (fun u -> ignore (match u with + | U_name nm -> reg nm + | _ -> ()); + u) s + in + let unames = get () in + + match s.sigel with + | Sig_inductive_typ _ + | Sig_datacon _ -> failwith "Impossible: collect_annotated_universes: bare data/type constructor" + | Sig_bundle {ses=sigs; lids} -> + let usubst = Subst.univ_var_closing unames in + { s with sigel = Sig_bundle {ses=sigs |> List.map (fun se -> + match se.sigel with + | Sig_inductive_typ {lid; params=bs; num_uniform_params=num_uniform; t; mutuals=lids1; ds=lids2} -> + { se with sigel = Sig_inductive_typ {lid; + us=unames; + params=Subst.subst_binders usubst bs; + num_uniform_params=num_uniform; + t=Subst.subst (Subst.shift_subst (List.length bs) usubst) t; + mutuals=lids1; + ds=lids2; + injective_type_params=false} } + | Sig_datacon {lid;t;ty_lid=tlid;num_ty_params=n;mutuals=lids} -> + { se with sigel = Sig_datacon {lid; + us=unames; + t=Subst.subst usubst t; + ty_lid=tlid; + num_ty_params=n; + mutuals=lids; + injective_type_params=false} } + | _ -> failwith "Impossible: collect_annotated_universes: Sig_bundle should not have a non data/type sigelt" + ); lids} } + | Sig_declare_typ {lid; t} -> + { s with sigel = Sig_declare_typ {lid; us=unames; t=Subst.close_univ_vars unames t} } + | Sig_let {lbs=(b, lbs); lids} -> + let usubst = Subst.univ_var_closing unames in + //This respects the invariant enforced by FStarC.Syntax.Util.check_mutual_universes + { s with sigel = Sig_let {lbs=(b, lbs |> List.map (fun lb -> { lb with lbunivs = unames; lbdef = Subst.subst usubst lb.lbdef; lbtyp = Subst.subst usubst lb.lbtyp })); + lids} } + | Sig_assume {lid;phi=fml} -> + { s with sigel = Sig_assume {lid; us=unames; phi=Subst.close_univ_vars unames fml} } + | Sig_effect_abbrev {lid;bs;comp=c;cflags=flags} -> + let usubst = Subst.univ_var_closing unames in + { s with sigel = Sig_effect_abbrev {lid; + us=unames; + bs=Subst.subst_binders usubst bs; + comp=Subst.subst_comp usubst c; + cflags=flags} } + + | Sig_fail {errs; fail_in_lax=lax; ses} -> + { s with sigel = Sig_fail {errs; + fail_in_lax=lax; + ses=List.map generalize_annotated_univs ses} } + + (* Works over the signature only *) + | Sig_new_effect ed -> + let generalize_annotated_univs_signature (s : effect_signature) : effect_signature = + match s with + | Layered_eff_sig (n, (_, t)) -> + let uvs = Free.univnames t |> elems in + let usubst = Subst.univ_var_closing uvs in + Layered_eff_sig (n, (uvs, Subst.subst usubst t)) + | WP_eff_sig (_, t) -> + let uvs = Free.univnames t |> elems in + let usubst = Subst.univ_var_closing uvs in + WP_eff_sig (uvs, Subst.subst usubst t) + in + { s with sigel = Sig_new_effect { ed with signature = generalize_annotated_univs_signature ed.signature } } + + | Sig_sub_effect _ + | Sig_polymonadic_bind _ + | Sig_polymonadic_subcomp _ + | Sig_splice _ + | Sig_pragma _ -> + s + +let is_special_effect_combinator = function + | "lift1" + | "lift2" + | "pure" + | "app" + | "push" + | "wp_if_then_else" + | "wp_assert" + | "wp_assume" + | "wp_close" + | "stronger" + | "ite_wp" + | "wp_trivial" + | "ctx" + | "gctx" + | "lift_from_pure" + | "return_wp" + | "return_elab" + | "bind_wp" + | "bind_elab" + | "repr" + | "post" + | "pre" + | "wp" -> true + | _ -> false + +let rec sum_to_universe u n = + if n = 0 then u else U_succ (sum_to_universe u (n-1)) + +let int_to_universe n = sum_to_universe U_zero n + +let rec desugar_maybe_non_constant_universe t + : either int Syntax.universe (* level of universe or desugared universe *) += + match (unparen t).tm with + | Wild -> Inr U_unknown + | Uvar u -> Inr (U_name u) + + | Const (Const_int (repr, _)) -> + (* TODO : That might be a little dangerous... *) + let n = int_of_string repr in + if n < 0 + then raise_error t Errors.Fatal_NegativeUniverseConstFatal_NotSupported + ("Negative universe constant are not supported : " ^ repr); + Inl n + | Op (op_plus, [t1 ; t2]) -> + assert (Ident.string_of_id op_plus = "+") ; + let u1 = desugar_maybe_non_constant_universe t1 in + let u2 = desugar_maybe_non_constant_universe t2 in + begin match u1, u2 with + | Inl n1, Inl n2 -> Inl (n1+n2) + | Inl n, Inr u + | Inr u, Inl n -> Inr (sum_to_universe u n) + | Inr u1, Inr u2 -> + raise_error t Errors.Fatal_UniverseMightContainSumOfTwoUnivVars + ("This universe might contain a sum of two universe variables " ^ show t) + end + | App _ -> + let rec aux t univargs = + match (unparen t).tm with + | App(t, targ, _) -> + let uarg = desugar_maybe_non_constant_universe targ in + aux t (uarg::univargs) + | Var max_lid -> + assert (Ident.string_of_lid max_lid = "max") ; + if List.existsb (function Inr _ -> true | _ -> false) univargs + then Inr (U_max (List.map (function Inl n -> int_to_universe n | Inr u -> u) univargs)) + else + let nargs = List.map (function Inl n -> n | Inr _ -> failwith "impossible") univargs in + Inl (List.fold_left (fun m n -> if m > n then m else n) 0 nargs) + (* TODO : Might not be the best place to raise the error... *) + | _ -> raise_error t Errors.Fatal_UnexpectedTermInUniverse ("Unexpected term " ^ term_to_string t ^ " in universe context") + in aux t [] + | _ -> raise_error t Errors.Fatal_UnexpectedTermInUniverse ("Unexpected term " ^ term_to_string t ^ " in universe context") + +let desugar_universe t : Syntax.universe = + let u = desugar_maybe_non_constant_universe t in + match u with + | Inl n -> int_to_universe n + | Inr u -> u + +let check_no_aq (aq : antiquotations_temp) : unit = + match aq with + | [] -> () + | (bv, { n = Tm_quoted (e, { qkind = Quote_dynamic })})::_ -> + raise_error e Errors.Fatal_UnexpectedAntiquotation + (BU.format1 "Unexpected antiquotation: `@(%s)" (show e)) + | (bv, e)::_ -> + raise_error e Errors.Fatal_UnexpectedAntiquotation + (BU.format1 "Unexpected antiquotation: `#(%s)" (show e)) + +let check_linear_pattern_variables pats (r:Range.range) = + // returns the set of pattern variables + let rec pat_vars p : RBSet.t bv = + match p.v with + | Pat_dot_term _ + | Pat_constant _ -> empty () + | Pat_var x -> + (* Only consider variables that actually have names, + not wildcards. *) + if string_of_id x.ppname = Ident.reserved_prefix + then empty () + else singleton x + | Pat_cons(_, _, pats) -> + let aux out (p, _) = + let p_vars = pat_vars p in + let intersection = inter p_vars out in + if is_empty intersection + then union out p_vars + else + let duplicate_bv = List.hd (elems intersection) in + raise_error r Errors.Fatal_NonLinearPatternNotPermitted + (BU.format1 "Non-linear patterns are not permitted: `%s` appears more than once in this pattern." + (show duplicate_bv.ppname)) + in + List.fold_left aux (empty ()) pats + in + + // check that the same variables are bound in each pattern + match pats with + | [] -> () + | [p] -> pat_vars p |> ignore + | p::ps -> + let pvars = pat_vars p in + let aux p = + if equal pvars (pat_vars p) then () else + let symdiff s1 s2 = union (diff s1 s2) (diff s2 s1) in + let nonlinear_vars = symdiff pvars (pat_vars p) in + let first_nonlinear_var = List.hd (elems nonlinear_vars) in + raise_error r Errors.Fatal_IncoherentPatterns + (BU.format1 "Patterns in this match are incoherent, variable %s is bound in some but not all patterns." + (show first_nonlinear_var.ppname)) + in + List.iter aux ps + +let smt_pat_lid (r:Range.range) = Ident.set_lid_range C.smtpat_lid r +let smt_pat_or_lid (r:Range.range) = Ident.set_lid_range C.smtpatOr_lid r + +// [hoist_pat_ascription' pat] pulls [PatAscribed] nodes out of [pat] +// and construct a tuple that consists in a non-ascribed pattern and a +// type abscription. Note [hoist_pat_ascription'] only works with +// patterns whose ascriptions live under tuple or list nodes. This +// function is used for [LetOperator] desugaring in +// [resugar_data_pat], because direct ascriptions in patterns are +// dropped (see issue #2678). +let rec hoist_pat_ascription' (pat: pattern): pattern & option term + = let mk tm = mk_term tm (pat.prange) Type_level in + let handle_list type_lid pat_cons pats = + let pats, terms = List.unzip (List.map hoist_pat_ascription' pats) in + if List.for_all None? terms + then pat, None + else + let terms = List.map (function | Some t -> t | None -> mk Wild) terms in + { pat with pat = pat_cons pats} + , Some (mkApp (mk type_lid) (List.map (fun t -> (t, Nothing)) terms) pat.prange) + in match pat.pat with + | PatList pats -> handle_list (Var C.list_lid) PatList pats + | PatTuple (pats, dep) -> + handle_list + (Var ((if dep then C.mk_dtuple_lid else C.mk_tuple_lid) (List.length pats) pat.prange)) + (fun pats -> PatTuple (pats, dep)) pats + | PatAscribed (pat, (typ, None)) -> pat, Some typ + // if [pat] is not a list, a tuple or an ascription, we cannot + // compose (at least not in a simple way) sub ascriptions, thus we + // return the pattern directly + | _ -> pat, None + +let hoist_pat_ascription (pat: pattern): pattern + = let pat, typ = hoist_pat_ascription' pat in + match typ with + | Some typ -> { pat with pat = PatAscribed (pat, (typ, None)) } + | None -> pat + +(* TODO : Patterns should be checked that there are no incompatible type ascriptions *) +(* and these type ascriptions should not be dropped !!! *) +let rec desugar_data_pat + (top_level_ascr_allowed : bool) + (env:env_t) + (p:pattern) + : (env_t & bnd & list annotated_pat) & antiquotations_temp = + let resolvex (l:lenv_t) e x = + (* This resolution function will be shared across + * the cases of a PatOr, so different ocurrences of + * a same (surface) variable are mapped to exactly the + * same internal variable. *) + match BU.find_opt (fun y -> (string_of_id y.ppname = string_of_id x)) l with + | Some y -> l, e, y + | _ -> + let e, xbv = push_bv e x in + (xbv::l), e, xbv + in + + let rec aux' (top:bool) (loc:lenv_t) (aqs:antiquotations_temp) (env:env_t) (p:pattern) + : lenv_t (* list of all BVs mentioned *) + & antiquotations_temp (* updated antiquotations_temp *) + & env_t (* env updated with the BVs pushed in *) + & bnd (* a binder for the pattern *) + & pat (* elaborated pattern *) + & list (bv & Syntax.typ & list S.term) (* ascripted pattern variables (collected) with attributes *) + = + let pos q = Syntax.withinfo q p.prange in + let pos_r r q = Syntax.withinfo q r in + let orig = p in + match p.pat with + | PatOr _ -> failwith "impossible: PatOr handled below" + + | PatOp op -> + (* Turn into a PatVar and recurse *) + let id_op = mk_ident (compile_op 0 (string_of_id op) (range_of_id op), (range_of_id op)) in + let p = { p with pat = PatVar (id_op, None, []) } in + aux loc aqs env p + + | PatAscribed(p, (t, tacopt)) -> + (* Check that there's no tactic *) + begin match tacopt with + | None -> () + | Some _ -> + raise_error orig Errors.Fatal_TypeWithinPatternsAllowedOnVariablesOnly + "Type ascriptions within patterns cannot be associated with a tactic" + end; + let loc, aqs, env', binder, p, annots = aux loc aqs env p in + let annots', binder, aqs = match binder with + | LetBinder _ -> failwith "impossible" + | LocalBinder(x, aq, attrs) -> + let t, aqs' = desugar_term_aq env (close_fun env t) in + let x = { x with sort = t } in + [(x, t, attrs)], LocalBinder(x, aq, attrs), aqs'@aqs + in + (* Check that the ascription is over a variable, and not something else *) + begin match p.v with + | Pat_var _ -> () + | _ when top && top_level_ascr_allowed -> () + | _ -> + raise_error orig Errors.Fatal_TypeWithinPatternsAllowedOnVariablesOnly + "Type ascriptions within patterns are only allowed on variables" + end; + loc, aqs, env', binder, p, annots'@annots + + | PatWild (aq, attrs) -> + let aq = trans_bqual env aq in + let attrs = attrs |> List.map (desugar_term env) in + let x = S.new_bv (Some p.prange) (tun_r p.prange) in + loc, aqs, env, LocalBinder(x, aq, attrs), pos <| Pat_var x, [] + + | PatConst c -> + let x = S.new_bv (Some p.prange) (tun_r p.prange) in + loc, aqs, env, LocalBinder(x, None, []), pos <| Pat_constant c, [] + + | PatVQuote e -> + // Here, we desugar [PatVQuote e] into a [PatConst s] where + // [s] is the (string represented) lid of [e] (see function + // [desugar_vquote]), then re-run desugaring on [PatConst s]. + let pat = PatConst (Const_string (desugar_vquote env e p.prange, p.prange)) in + aux' top loc aqs env ({ p with pat }) + + | PatTvar(x, aq, attrs) + | PatVar (x, aq, attrs) -> + let aq = trans_bqual env aq in + let attrs = attrs |> List.map (desugar_term env) in + let loc, env, xbv = resolvex loc env x in + loc, aqs, env, LocalBinder(xbv, aq, attrs), pos <| Pat_var xbv, [] + + | PatName l -> + let l = fail_or env (try_lookup_datacon env) l in + let x = S.new_bv (Some p.prange) (tun_r p.prange) in + loc, aqs, env, LocalBinder(x, None, []), pos <| Pat_cons(l, None, []), [] + + | PatApp({pat=PatName l}, args) -> + let loc, aqs, env, annots, args = List.fold_right (fun arg (loc, aqs, env, annots, args) -> + let loc, aqs, env, b, arg, ans = aux loc aqs env arg in + let imp = is_implicit b in + (loc, aqs, env, ans@annots, (arg, imp)::args)) args (loc, aqs, env, [], []) in + let l = fail_or env (try_lookup_datacon env) l in + let x = S.new_bv (Some p.prange) (tun_r p.prange) in + loc, aqs, env, LocalBinder(x, None, []), pos <| Pat_cons(l, None, args), annots + + | PatApp _ -> raise_error p Errors.Fatal_UnexpectedPattern "Unexpected pattern" + + | PatList pats -> + let loc, aqs, env, annots, pats = List.fold_right (fun pat (loc, aqs, env, annots, pats) -> + let loc, aqs, env, _, pat, ans = aux loc aqs env pat in + loc, aqs, env, ans@annots, pat::pats) pats (loc, aqs, env, [], []) in + let pat = List.fold_right (fun hd tl -> + let r = Range.union_ranges hd.p tl.p in + pos_r r <| Pat_cons(S.lid_and_dd_as_fv C.cons_lid (Some Data_ctor), None, [(hd, false);(tl, false)])) pats + (pos_r (Range.end_range p.prange) <| Pat_cons(S.lid_and_dd_as_fv C.nil_lid (Some Data_ctor), None, [])) in + let x = S.new_bv (Some p.prange) (tun_r p.prange) in + loc, aqs, env, LocalBinder(x, None, []), pat, annots + + | PatTuple(args, dep) -> + let loc, aqs, env, annots, args = List.fold_left (fun (loc, aqs, env, annots, pats) p -> + let loc, aqs, env, _, pat, ans = aux loc aqs env p in + loc, aqs, env, ans@annots, (pat, false)::pats) (loc, aqs, env, [], []) args in + let args = List.rev args in + let l = if dep then C.mk_dtuple_data_lid (List.length args) p.prange + else C.mk_tuple_data_lid (List.length args) p.prange in + let constr = fail_or env (Env.try_lookup_lid env) l in + let l = match constr.n with + | Tm_fvar fv -> fv + | _ -> failwith "impossible" in + let x = S.new_bv (Some p.prange) (tun_r p.prange) in + loc, aqs, env, LocalBinder(x, None, []), pos <| Pat_cons(l, None, args), annots + + | PatRecord (fields) -> + (* Record patterns have to wait for type information to be fully resolved *) + let field_names, pats = List.unzip fields in + let typename, field_names = + match fields with + | [] -> None, field_names + | (f, _)::_ -> + match try_lookup_record_by_field_name env f with + | None -> None, field_names + | Some r -> Some r.typename, qualify_field_names r.typename field_names + in + (* Just build a candidate constructor, as we do for Record literals *) + let candidate_constructor = + let lid = lid_of_path ["__dummy__"] p.prange in + S.lid_and_dd_as_fv + lid + (Some + (Unresolved_constructor + ({ uc_base_term = false; + uc_typename = typename; + uc_fields = field_names }))) + in + let loc, aqs, env, annots, pats = + List.fold_left + (fun (loc, aqs, env, annots, pats) p -> + let loc, aqs, env, _, pat, ann = aux loc aqs env p in + loc, aqs, env, ann@annots, (pat, false)::pats) + (loc, aqs, env, [], []) + pats + in + let pats = List.rev pats in + (* TcTerm will look for the Unresolved_constructor qualifier + and resolve the pattern fully in tc_pat *) + let pat = pos <| Pat_cons(candidate_constructor, None, pats) in + let x = S.new_bv (Some p.prange) (tun_r p.prange) in + loc, aqs, env, LocalBinder(x, None, []), pat, annots + and aux loc aqs env p = aux' false loc aqs env p + in + + (* Explode PatOr's and call aux *) + let aux_maybe_or env (p:pattern) = + let loc = [] in + match p.pat with + | PatOr [] -> failwith "impossible" + | PatOr (p::ps) -> + let loc, aqs, env, var, p, ans = aux' true loc [] env p in + let loc, aqs, env, ps = List.fold_left (fun (loc, aqs, env, ps) p -> + let loc, aqs, env, _, p, ans = aux' true loc aqs env p in + loc, aqs, env, (p,ans)::ps) (loc, aqs, env, []) ps in + let pats = ((p,ans)::List.rev ps) in + (env, var, pats), aqs + | _ -> + let loc, aqs, env, var, pat, ans = aux' true loc [] env p in + (env, var, [(pat, ans)]), aqs + in + + let (env, b, pats), aqs = aux_maybe_or env p in + check_linear_pattern_variables (List.map fst pats) p.prange; + (env, b, pats), aqs + +and desugar_binding_pat_maybe_top top env p + : (env_t (* environment with patterns variables pushed in *) + & bnd (* a binder for the pattern *) + & list annotated_pat) (* elaborated patterns with their variable annotations *) + & antiquotations_temp (* antiquotations_temp found in binder types *) + = + + if top then + let mklet x ty (tacopt : option S.term) : (env_t & bnd & list annotated_pat) = + // GM: ^ I seem to need the type annotation here, + // or F* gets confused between tuple2 and tuple3 apparently? + env, LetBinder(qualify env x, (ty, tacopt)), [] + in + let op_to_ident x = mk_ident (compile_op 0 (string_of_id x) (range_of_id x), (range_of_id x)) in + match p.pat with + | PatOp x -> + mklet (op_to_ident x) (tun_r (range_of_id x)) None, [] + | PatVar (x, _, _) -> + mklet x (tun_r (range_of_id x)) None, [] + | PatAscribed({pat=PatOp x}, (t, tacopt)) -> + let tacopt = BU.map_opt tacopt (desugar_term env) in + let t, aq = desugar_term_aq env t in + mklet (op_to_ident x) t tacopt, aq + | PatAscribed({pat=PatVar (x, _, _)}, (t, tacopt)) -> + let tacopt = BU.map_opt tacopt (desugar_term env) in + let t, aq = desugar_term_aq env t in + mklet x t tacopt, aq + | _ -> + raise_error p Errors.Fatal_UnexpectedPattern "Unexpected pattern at the top-level" + else + let (env, binder, p), aq = desugar_data_pat true env p in + let p = match p with + | [{v=Pat_var _}, _] -> [] + | _ -> p in + (env, binder, p), aq + +and desugar_binding_pat_aq env p = desugar_binding_pat_maybe_top false env p + +and desugar_match_pat_maybe_top _ env pat = + let (env, _, pat), aqs = desugar_data_pat false env pat in + (env, pat), aqs + +and desugar_match_pat env p = desugar_match_pat_maybe_top false env p + +and desugar_term_aq env e : S.term & antiquotations_temp = + let env = Env.set_expect_typ env false in + desugar_term_maybe_top false env e + +and desugar_term env e : S.term = + let t, aq = desugar_term_aq env e in + check_no_aq aq; + t + +and desugar_typ_aq env e : S.term & antiquotations_temp = + let env = Env.set_expect_typ env true in + desugar_term_maybe_top false env e + +and desugar_typ env e : S.term = + let t, aq = desugar_typ_aq env e in + check_no_aq aq; + t + +and desugar_machine_integer env repr (signedness, width) range = + let tnm = if width = Sizet then "FStar.SizeT" else + "FStar." ^ + (match signedness with | Unsigned -> "U" | Signed -> "") ^ "Int" ^ + (match width with | Int8 -> "8" | Int16 -> "16" | Int32 -> "32" | Int64 -> "64") + in + //we do a static check of integer constants + //and coerce them to the appropriate type using the internal coercion + // __uint_to_t or __int_to_t + //Rather than relying on a verification condition to check this trivial property + if not (within_bounds repr signedness width) + then FStarC.Errors.log_issue range Errors.Error_OutOfRange + (BU.format2 "%s is not in the expected range for %s" repr tnm); + let private_intro_nm = tnm ^ + ".__" ^ (match signedness with | Unsigned -> "u" | Signed -> "") ^ "int_to_t" + in + let intro_nm = tnm ^ + "." ^ (match signedness with | Unsigned -> "u" | Signed -> "") ^ "int_to_t" + in + let lid = lid_of_path (path_of_text intro_nm) range in + let lid = + match Env.try_lookup_lid env lid with + | Some intro_term -> + begin match intro_term.n with + | Tm_fvar fv -> + let private_lid = lid_of_path (path_of_text private_intro_nm) range in + let private_fv = S.lid_and_dd_as_fv private_lid fv.fv_qual in + {intro_term with n=Tm_fvar private_fv} + | _ -> + failwith ("Unexpected non-fvar for " ^ intro_nm) + end + | None -> + raise_error range Errors.Fatal_UnexpectedNumericLiteral + (BU.format1 "Unexpected numeric literal. Restart F* to load %s." tnm) in + let repr' = S.mk (Tm_constant (Const_int (repr, None))) range in + let app = S.mk (Tm_app {hd=lid; args=[repr', S.as_aqual_implicit false]}) range in + S.mk (Tm_meta {tm=app; + meta=Meta_desugared (Machine_integer (signedness, width))}) range + +and desugar_term_maybe_top (top_level:bool) (env:env_t) (top:term) : S.term & antiquotations_temp = + let mk e = S.mk e top.range in + let noaqs = [] in + let join_aqs aqs = List.flatten aqs in + let setpos e = {e with pos=top.range} in + let desugar_binders env binders = + let env, bs_rev = + List.fold_left + (fun (env, bs) b -> + let bb = desugar_binder env b in + let b, env = as_binder env b.aqual bb in + env, b::bs) + (env, []) + binders + in + env, List.rev bs_rev + in + let unqual_bv_of_binder b = + match b with + | {binder_bv=x; binder_qual=None; binder_attrs=[]} -> x + | _ -> + raise_error b Fatal_UnexpectedTerm "Unexpected qualified binder in ELIM_EXISTS" + in + if !dbg_ToSyntax then + BU.print1 "desugaring (%s)\n\n" (show top); + begin match (unparen top).tm with + | Wild -> setpos tun, noaqs + + | Labeled _ -> desugar_formula env top, noaqs + + | Requires (t, lopt) -> + desugar_formula env t, noaqs + + | Ensures (t, lopt) -> + desugar_formula env t, noaqs + + | Attributes ts -> + failwith "Attributes should not be desugared by desugar_term_maybe_top" + // desugar_attributes env ts + + | Const (Const_int (i, Some size)) -> + desugar_machine_integer env i size top.range, noaqs + + | Const c -> + mk (Tm_constant c), noaqs + + | Op(id, args) when string_of_id id = "=!=" -> + let r = range_of_id id in + let e = mk_term (Op(Ident.mk_ident ("==", r), args)) top.range top.level in + desugar_term_aq env (mk_term(Op(Ident.mk_ident ("~",r), [e])) top.range top.level) + + (* if op_Star has not been rebound, then it's reserved for tuples *) + | Op(op_star, [lhs;rhs]) when + (Ident.string_of_id op_star = "*" && + op_as_term env 2 op_star |> Option.isNone) -> + (* See the comment in parse.mly to understand why this implicitly relies + * on the presence of a Paren node in the AST. *) + let rec flatten t = match t.tm with + // * is left-associative + | Op(id, [t1;t2]) when + string_of_id id = "*" && + op_as_term env 2 op_star |> Option.isNone -> + flatten t1 @ [ t2 ] + | _ -> [t] + in + let terms = flatten lhs in + //make the surface syntax for a non-dependent tuple + let t = {top with tm=Sum(List.map Inr terms, rhs)} in + desugar_term_maybe_top top_level env t + + | Tvar a -> + setpos <| (fail_or2 (try_lookup_id env) a), noaqs + + | Uvar u -> + raise_error top Errors.Fatal_UnexpectedUniverseVariable + ("Unexpected universe variable " ^ + string_of_id u ^ + " in non-universe context") + + | Op(s, [f;e]) when Ident.string_of_id s = "<|" -> + desugar_term_maybe_top top_level env (mkApp f [e,Nothing] top.range) + + | Op(s, [e;f]) when Ident.string_of_id s = "|>" -> + desugar_term_maybe_top top_level env (mkApp f [e,Nothing] top.range) + + | Op(s, args) -> + begin + match op_as_term env (List.length args) s with + | None -> + raise_error s Errors.Fatal_UnepxectedOrUnboundOperator + ("Unexpected or unbound operator: " ^ + Ident.string_of_id s) + | Some op -> + if List.length args > 0 then + let args, aqs = args |> List.map (fun t -> let t', s = desugar_term_aq env t in + (t', None), s) |> List.unzip in + mk (Tm_app {hd=op; args}), join_aqs aqs + else + op, noaqs + end + + | Construct (n, [(a, _)]) when (string_of_lid n) = "SMTPat" -> + desugar_term_maybe_top top_level env + ({top with tm = App ({top with tm = Var (smt_pat_lid top.range)}, a, Nothing)}) + + | Construct (n, [(a, _)]) when (string_of_lid n) = "SMTPatT" -> + Errors.log_issue top Errors.Warning_SMTPatTDeprecated "SMTPatT is deprecated; please just use SMTPat"; + desugar_term_maybe_top top_level env + ({top with tm = App ({top with tm = Var (smt_pat_lid top.range) }, a, Nothing)}) + + | Construct (n, [(a, _)]) when (string_of_lid n) = "SMTPatOr" -> + desugar_term_maybe_top top_level env + ({top with tm = App ({top with tm = Var (smt_pat_or_lid top.range)}, a, Nothing)}) + + | Name lid when string_of_lid lid = "Type0" -> + mk (Tm_type U_zero), noaqs + | Name lid when string_of_lid lid = "Type" -> + mk (Tm_type U_unknown), noaqs + | Construct (lid, [t, UnivApp]) when string_of_lid lid = "Type" -> + mk (Tm_type (desugar_universe t)), noaqs + | Name lid when string_of_lid lid = "Effect" -> + mk (Tm_constant Const_effect), noaqs + | Name lid when string_of_lid lid = "True" -> + S.fvar_with_dd (Ident.set_lid_range Const.true_lid top.range) None, + noaqs + | Name lid when string_of_lid lid = "False" -> + S.fvar_with_dd (Ident.set_lid_range Const.false_lid top.range) None, + noaqs + | Projector (eff_name, id) + when is_special_effect_combinator (string_of_id id) && Env.is_effect_name env eff_name -> + (* TODO : would it be possible to normalize the effect name at that point so that *) + (* we get back the original effect definition instead of an effect abbreviation *) + let txt = string_of_id id in + begin match try_lookup_effect_defn env eff_name with + | Some ed -> + let lid = U.dm4f_lid ed txt in + S.fvar_with_dd lid None, noaqs + | None -> + failwith (BU.format2 "Member %s of effect %s is not accessible \ + (using an effect abbreviation instead of the original effect ?)" + (Ident.string_of_lid eff_name) + txt) + end + + | Var l + | Name l -> + desugar_name mk setpos env true l, noaqs + + | Projector (l, i) -> + let name = + match Env.try_lookup_datacon env l with + | Some _ -> Some (true, l) + | None -> + match Env.try_lookup_root_effect_name env l with + | Some new_name -> Some (false, new_name) + | _ -> None + in + begin match name with + | Some (resolve, new_name) -> + desugar_name mk setpos env resolve (mk_field_projector_name_from_ident new_name i), noaqs + | _ -> + raise_error top Errors.Fatal_EffectNotFound (BU.format1 "Data constructor or effect %s not found" (string_of_lid l)) + end + + | Discrim lid -> + begin match Env.try_lookup_datacon env lid with + | None -> + raise_error top Errors.Fatal_DataContructorNotFound (BU.format1 "Data constructor %s not found" (string_of_lid lid)) + | _ -> + let lid' = U.mk_discriminator lid in + desugar_name mk setpos env true lid', noaqs + end + + | Construct(l, args) -> + begin match Env.try_lookup_datacon env l with + | Some head -> + let head = mk (Tm_fvar head) in + begin match args with + | [] -> head, noaqs + | _ -> + let universes, args = BU.take (fun (_, imp) -> imp = UnivApp) args in + let universes = List.map (fun x -> desugar_universe (fst x)) universes in + let args, aqs = List.map (fun (t, imp) -> + let te, aq = desugar_term_aq env t in + arg_withimp_t imp te, aq) args |> List.unzip in + let head = if universes = [] then head else mk (Tm_uinst(head, universes)) in + let tm = + if List.length args = 0 + then head + else mk (Tm_app {hd=head; args}) in + tm, join_aqs aqs + end + | None -> + match Env.try_lookup_effect_name env l with + | None -> + raise_error l Errors.Fatal_ConstructorNotFound + ("Constructor " ^ (string_of_lid l) ^ " not found") + | Some _ -> + raise_error l Errors.Fatal_UnexpectedEffect + ("Effect " ^ (string_of_lid l) ^ " used at an unexpected position") + end + + | Sum(binders, t) + when BU.for_all (function Inr _ -> true | _ -> false) binders -> + //non-dependent tuple + let terms = + (binders |> + List.map (function Inr x -> x | Inl _ -> failwith "Impossible")) + @[t] + in + let targs, aqs = + terms |> + List.map (fun t -> let t', aq = desugar_typ_aq env t in as_arg t', aq) |> + List.unzip + in + let tup = fail_or env (Env.try_lookup_lid env) (C.mk_tuple_lid (List.length targs) top.range) in + mk (Tm_app {hd=tup; args=targs}), join_aqs aqs + + | Sum(binders, t) -> //dependent tuple + let env, _, targs = List.fold_left (fun (env, tparams, typs) b -> + let xopt, t, attrs = + match b with + | Inl b -> desugar_binder env b + | Inr t -> None, desugar_typ env t, [] + in + let env, x = + match xopt with + | None -> env, S.new_bv (Some top.range) (setpos tun) + | Some x -> push_bv env x in + (env, tparams@[mk_binder_with_attrs ({x with sort=t}) None attrs], + typs@[as_arg <| no_annot_abs tparams t])) + (env, [], []) + (binders@[Inl <| mk_binder (NoName t) t.range Type_level None]) in + let tup = fail_or env (try_lookup_lid env) (C.mk_dtuple_lid (List.length targs) top.range) in + mk <| Tm_app {hd=tup; args=targs}, noaqs + + | Product(binders, t) -> + let bs, t = uncurry binders t in + let rec aux env aqs bs = function + | [] -> + let cod = desugar_comp top.range true env t in + setpos <| U.arrow (List.rev bs) cod, aqs + + | hd::tl -> + let bb, aqs' = desugar_binder_aq env hd in + let b, env = as_binder env hd.aqual bb in + aux env (aqs'@aqs) (b::bs) tl + in + aux env [] [] bs + + | Refine(b, f) -> + begin match desugar_binder env b with + | (None, _, _) -> failwith "Missing binder in refinement" + + | b -> + let b, env = as_binder env None b in + let f = desugar_formula env f in + setpos <| U.refine b.binder_bv f, noaqs + end + + | Function (branches, r1) -> + let x = Ident.gen r1 in + let t' = + mk_term (Abs([mk_pattern (PatVar(x,None,[])) r1], + mk_term (Match(mk_term (Var(lid_of_ids [x])) r1 Expr, None, None, branches)) top.range Expr)) + top.range Expr + in + desugar_term_maybe_top top_level env t' + + | Abs(binders, body) -> + (* First of all, forbid definitions such as `f x x = ...` *) + let bvss = List.map gather_pattern_bound_vars binders in + let check_disjoint (sets : list (FlatSet.t ident)) : option ident = + let rec aux acc sets = + match sets with + | [] -> None + | set::sets -> + let i = inter acc set in + if is_empty i + then aux (union acc set) sets + else Some (List.hd (elems i)) + in + aux (empty ()) sets + in + begin match check_disjoint bvss with + | None -> () + | Some id -> + let open FStarC.Pprint in + let open FStarC.Class.PP in + raise_error id Errors.Fatal_NonLinearPatternNotPermitted [ + text "Non-linear patterns are not permitted."; + text "The variable " ^/^ squotes (pp id) ^/^ text " appears more than once in this function definition." + ] + end; + + let binders = binders |> List.map replace_unit_pattern in + let _, ftv = List.fold_left (fun (env, ftvs) pat -> + match pat.pat with + | PatAscribed(_, (t, None)) -> env, free_type_vars env t@ftvs + | PatAscribed(_, (t, Some tac)) -> env, free_type_vars env t@free_type_vars env tac@ftvs + | _ -> env, ftvs) (env, []) binders in + let ftv = sort_ftv ftv in + let binders = (ftv |> List.map (fun a -> + mk_pattern (PatTvar(a, Some AST.Implicit, [])) top.range)) + @binders in //close over the free type variables + (* + fun (P1 x1) (P2 x2) (P3 x3) -> e + + is desugared to + + fun y1 y2 y3 -> match (y1, y2, y3) with + | (P1 x1, P2 x2, P3 x3) -> [[e]] + *) + let rec aux aqs env bs sc_pat_opt pats : S.term & antiquotations_temp = + match pats with + | [] -> + let body, aq = desugar_term_aq env body in + let body = match sc_pat_opt with + | Some (sc, pat) -> + let body = Subst.close (S.pat_bvs pat |> List.map S.mk_binder) body in + S.mk (Tm_match {scrutinee=sc; + ret_opt=None; + brs=[(pat, None, body)]; + rc_opt=None}) body.pos + | None -> body in + setpos (no_annot_abs (List.rev bs) body), aq@aqs + + | p::rest -> + let (env, b, pat), aq = desugar_binding_pat_aq env p in + let pat = + match pat with + | [] -> None + | [p, _] -> Some p // NB: We ignore the type annotation here, the typechecker catches that anyway in tc_abs + | _ -> + raise_error p Errors.Fatal_UnsupportedDisjuctivePatterns "Disjunctive patterns are not supported in abstractions" + in + let b, sc_pat_opt = + match b with + | LetBinder _ -> failwith "Impossible" + | LocalBinder (x, aq, attrs) -> + let sc_pat_opt = + match pat, sc_pat_opt with + | None, _ -> sc_pat_opt + | Some p, None -> Some (S.bv_to_name x, p) + | Some p, Some (sc, p') -> begin + match sc.n, p'.v with + | Tm_name _, _ -> + let tup2 = S.lid_and_dd_as_fv (C.mk_tuple_data_lid 2 top.range) (Some Data_ctor) in + let sc = S.mk (Tm_app {hd=mk (Tm_fvar tup2); + args=[as_arg sc; as_arg <| S.bv_to_name x]}) top.range in + let p = withinfo (Pat_cons(tup2, None, [(p', false);(p, false)])) (Range.union_ranges p'.p p.p) in + Some(sc, p) + | Tm_app {args}, Pat_cons(_, _, pats) -> + let tupn = S.lid_and_dd_as_fv (C.mk_tuple_data_lid (1 + List.length args) top.range) (Some Data_ctor) in + let sc = mk (Tm_app {hd=mk (Tm_fvar tupn); + args=args@[as_arg <| S.bv_to_name x]}) in + let p = withinfo (Pat_cons(tupn, None, pats@[(p, false)])) (Range.union_ranges p'.p p.p) in + Some(sc, p) + | _ -> failwith "Impossible" + end + in + (mk_binder_with_attrs x aq attrs), sc_pat_opt + in + aux (aq@aqs) env (b::bs) sc_pat_opt rest + in + aux [] env [] None binders + + | App (_, _, UnivApp) -> + let rec aux universes e = match (unparen e).tm with + | App(e, t, UnivApp) -> + let univ_arg = desugar_universe t in + aux (univ_arg::universes) e + | _ -> + let head, aq = desugar_term_aq env e in + mk (Tm_uinst(head, universes)), aq + in aux [] top + + | App (e, t, imp) -> + let head, aq1 = desugar_term_aq env e in + let t, aq2 = desugar_term_aq env t in + let arg = arg_withimp_t imp t in + S.extend_app head arg top.range, aq1@aq2 + + | Bind(x, t1, t2) -> + let xpat = AST.mk_pattern (AST.PatVar(x, None, [])) (range_of_id x) in + let k = AST.mk_term (Abs([xpat], t2)) t2.range t2.level in + let bind_lid = Ident.lid_of_path ["bind"] (range_of_id x) in + let bind = AST.mk_term (AST.Var bind_lid) (range_of_id x) AST.Expr in + desugar_term_aq env (AST.mkExplicitApp bind [t1; k] top.range) + + | Seq(t1, t2) -> + // + // let _ : unit = e1 in e2 + // + let p = mk_pattern (PatWild (None, [])) t1.range in + let p = mk_pattern (PatAscribed (p, (unit_ty p.prange, None))) p.prange in + let t = mk_term (Let(NoLetQualifier, [None, (p, t1)], t2)) top.range Expr in + let tm, s = desugar_term_aq env t in + + // + // keep the Sequence, we will use it for resugaring + // + mk (Tm_meta {tm; meta=Meta_desugared Sequence}), s + + | LetOpen (lid, e) -> + let env = Env.push_namespace env lid Unrestricted in + (if Env.expect_typ env then desugar_typ_aq else desugar_term_aq) env e + + | LetOpenRecord (r, rty, e) -> + let rec head_of (t:term) : term = + match t.tm with + | App (t, _, _) -> head_of t + | _ -> t + in + let tycon = head_of rty in + let tycon_name = + match tycon.tm with + | Var l -> l + | _ -> + raise_error rty Errors.Error_BadLetOpenRecord + (BU.format1 "This type must be a (possibly applied) record name" (term_to_string rty)) + in + let record = + match Env.try_lookup_record_type env tycon_name with + | Some r -> r + | None -> + raise_error rty Errors.Error_BadLetOpenRecord + (BU.format1 "Not a record type: `%s`" (term_to_string rty)) + in + let constrname = lid_of_ns_and_id (ns_of_lid record.typename) record.constrname in + let mk_pattern p = mk_pattern p r.range in + let elab = + let pat = + (* All of the fields are explicit arguments of the constructor, hence the None below *) + mk_pattern (PatApp (mk_pattern (PatName constrname), + List.map (fun (field, _) -> mk_pattern (PatVar (field, None, []))) record.fields)) + in + let branch = (pat, None, e) in + let r = mk_term (Ascribed (r, rty, None, false)) r.range Expr in + { top with tm = Match (r, None, None, [branch]) } + in + desugar_term_maybe_top top_level env elab + + | LetOperator(lets, body) -> + ( match lets with + | [] -> failwith "Impossible: a LetOperator (e.g. let+, let*...) cannot contain zero let binding" + | (letOp, letPat, letDef)::tl -> + let term_of_op op = AST.mk_term (AST.Op (op, [])) (range_of_id op) AST.Expr in + let mproduct_def = fold_left (fun def (andOp, andPat, andDef) -> + AST.mkExplicitApp + (term_of_op andOp) + [def; andDef] top.range + ) letDef tl in + let mproduct_pat = fold_left (fun pat (andOp, andPat, andDef) -> + AST.mk_pattern (AST.PatTuple ([pat; andPat], false)) andPat.prange + ) letPat tl in + let fn = AST.mk_term (Abs([hoist_pat_ascription mproduct_pat], body)) body.range body.level in + let let_op = term_of_op letOp in + let t = AST.mkExplicitApp let_op [mproduct_def; fn] top.range in + desugar_term_aq env t + ) + | Let(qual, lbs, body) -> + let is_rec = qual = Rec in + let ds_let_rec_or_app () = + let bindings = lbs in + let funs = bindings |> List.map (fun (attr_opt, (p, def)) -> + if is_app_pattern p + then attr_opt, destruct_app_pattern env top_level p, def + else match un_function p def with + | Some (p, def) -> attr_opt, destruct_app_pattern env top_level p, def + | _ -> begin match p.pat with + | PatAscribed({pat=PatVar(id,_,_)}, t) -> + if top_level + then attr_opt, (Inr (qualify env id), [], Some t), def + else attr_opt, (Inl id, [], Some t), def + | PatVar(id, _, _) -> + if top_level + then attr_opt, (Inr (qualify env id), [], None), def + else attr_opt, (Inl id, [], None), def + | _ -> raise_error p Errors.Fatal_UnexpectedLetBinding "Unexpected let binding" + end) + in + + //Generate fresh names and populate an env' with recursive bindings + //below, we use env' instead of env, only if is_rec + let env', fnames, rec_bindings, used_markers = + List.fold_left (fun (env, fnames, rec_bindings, used_markers) (_attr_opt, (f, _, _), _) -> + let env, lbname, rec_bindings, used_markers = match f with + | Inl x -> + let env, xx, used_marker = push_bv' env x in + let dummy_ref = BU.mk_ref true in + env, Inl xx, S.mk_binder xx::rec_bindings, used_marker::used_markers + | Inr l -> + let env, used_marker = push_top_level_rec_binding env (ident_of_lid l) in + env, Inr l, rec_bindings, used_marker::used_markers in + env, (lbname::fnames), rec_bindings, used_markers) (env, [], [], []) funs + in + + let fnames = List.rev fnames in + let rec_bindings = List.rev rec_bindings in + let used_markers = List.rev used_markers in + (* This comment is taken from Syntax.Subst.open_let_rec + The desugaring of let recs has to be consistent with their opening + + Consider + let rec f x = g x + and g y = f y in + f 0, g 0 + In de Bruijn notation, this is + let rec f x = g@1 x@0 + and g y = f@2 y@0 in + f@1 0, g@0 0 + i.e., the recursive environment for f is, in order: + u, f, g, x + for g is + u, f, g, y + and for the body is + f, g + *) + let desugar_one_def env lbname (attrs_opt, (_, args, result_t), def) + : letbinding & antiquotations_temp + = + let args = args |> List.map replace_unit_pattern in + let pos = def.range in + let def = + match result_t with + | None -> def + | Some (t, tacopt) -> + let t = + if is_comp_type env t + then let _ = + match args |> List.tryFind (fun x -> not (is_var_pattern x)) with + | None -> () + | Some p -> + raise_error p Errors.Fatal_ComputationTypeNotAllowed + ("Computation type annotations are only permitted on let-bindings \ + without inlined patterns; \ + replace this pattern with a variable") in + t + else if Options.ml_ish () //we're type-checking the compiler itself, e.g. + && Option.isSome (Env.try_lookup_effect_name env (C.effect_ML_lid())) //ML is in scope (not still in prims, e.g) + && (not is_rec || List.length args <> 0) //and we don't have something like `let rec f : t -> t' = fun x -> e` + then AST.ml_comp t + else AST.tot_comp t + in + mk_term (Ascribed(def, t, tacopt, false)) def.range Expr + in + let def = match args with + | [] -> def + | _ -> mk_term (un_curry_abs args def) top.range top.level in + let body, aq = desugar_term_aq env def in + let lbname = match lbname with + | Inl x -> Inl x + | Inr l -> Inr (S.lid_and_dd_as_fv l None) in + let body = if is_rec then Subst.close rec_bindings body else body in + let attrs = match attrs_opt with + | None -> [] + | Some l -> List.map (desugar_term env) l + in + mk_lb (attrs, lbname, setpos tun, body, pos), aq + in + let lbs, aqss = + List.map2 (desugar_one_def (if is_rec then env' else env)) fnames funs + |> List.unzip + in + let body, aq = desugar_term_aq env' body in + if is_rec then begin + List.iter2 (fun (_attr_opt, (f, _, _), _) used_marker -> + if not !used_marker then + let nm, gl, rng = + match f with + | Inl x -> (string_of_id x, "Local binding", range_of_id x) + | Inr l -> (string_of_lid l, "Global binding", range_of_lid l) + in + let open FStarC.Errors.Msg in + let open FStarC.Pprint in + Errors.log_issue rng Errors.Warning_UnusedLetRec [ + surround 4 1 (text gl) + (squotes (doc_of_string nm)) + (text "is recursive but not used in its body") + ] + ) funs used_markers + end; + mk <| (Tm_let {lbs=(is_rec, lbs); body=Subst.close rec_bindings body}), aq @ List.flatten aqss + in + //end ds_let_rec_or_app + + let ds_non_rec attrs_opt pat t1 t2 = + let attrs = + match attrs_opt with + | None -> [] + | Some l -> List.map (desugar_term env) l + in + let t1, aq0 = desugar_term_aq env t1 in + let (env, binder, pat), aqs = desugar_binding_pat_maybe_top top_level env pat in + check_no_aq aqs; + let tm, aq1 = + match binder with + | LetBinder(l, (t, tacopt)) -> + if tacopt |> is_some + then Errors.log_issue (tacopt |> must) Errors.Warning_DefinitionNotTranslated + "Tactic annotation with a value type is not supported yet, \ + try annotating with a computation type; this tactic annotation will be ignored"; + let body, aq = desugar_term_aq env t2 in + let fv = S.lid_and_dd_as_fv l None in + mk <| Tm_let {lbs=(false, [mk_lb (attrs, Inr fv, t, t1, t1.pos)]); body}, aq + + | LocalBinder (x,_,_) -> + // TODO unsure if keep _ or [] on second comp below + let body, aq = desugar_term_aq env t2 in + let body = match pat with + | [] -> body + | _ -> + S.mk (Tm_match {scrutinee=S.bv_to_name x; + ret_opt=None; + brs=desugar_disjunctive_pattern pat None body; + rc_opt=None}) top.range + in + mk <| Tm_let {lbs=(false, [mk_lb (attrs, Inl x, x.sort, t1, t1.pos)]); + body=Subst.close [S.mk_binder x] body}, aq + in + tm, aq0 @ aq1 + in + + let attrs, (head_pat, defn) = List.hd lbs in + if is_rec + || is_app_pattern head_pat + then ds_let_rec_or_app() + else ds_non_rec attrs head_pat defn body + + | If(e, Some op, asc_opt, t2, t3) -> + // A if operator is desugared into a let operator binding + // with name "uu___if_op_head" followed by a regular if on + // "uu___if_op_head" + let var_id = mk_ident(reserved_prefix ^ "if_op_head", e.range) in + let var = mk_term (Var (lid_of_ids [var_id])) e.range Expr in + let pat = mk_pattern (PatVar (var_id, None, [])) e.range in + let if_ = mk_term (If (var, None, asc_opt, t2, t3)) top.range Expr in + let t = mk_term (LetOperator ([(op, pat, e)], if_)) e.range Expr in + desugar_term_aq env t + + | If(t1, None, asc_opt, t2, t3) -> + let x = Syntax.new_bv (Some t3.range) (tun_r t3.range) in + let t_bool = mk (Tm_fvar(S.lid_and_dd_as_fv C.bool_lid None)) in + let t1', aq1 = desugar_term_aq env t1 in + let t1' = U.ascribe t1' (Inl t_bool, None, false) in + let asc_opt, aq0 = desugar_match_returns env t1' asc_opt in + let t2', aq2 = desugar_term_aq env t2 in + let t3', aq3 = desugar_term_aq env t3 in + mk (Tm_match {scrutinee=t1'; + ret_opt=asc_opt; + brs=[(withinfo (Pat_constant (Const_bool true)) t1.range, None, t2'); + (withinfo (Pat_var x) t1.range, None, t3')]; + rc_opt=None}), join_aqs [aq1;aq0;aq2;aq3] + + | TryWith(e, branches) -> + let r = top.range in + let handler = mk_function branches r r in + let body = mk_function [(mk_pattern (PatConst Const_unit) r, None, e)] r r in + let try_with_lid = Ident.lid_of_path ["try_with"] r in + let try_with = AST.mk_term (AST.Var try_with_lid) r AST.Expr in + let a1 = mk_term (App(try_with, body, Nothing)) r top.level in + let a2 = mk_term (App(a1, handler, Nothing)) r top.level in + desugar_term_aq env a2 + + | Match(e, Some op, topt, branches) -> + // A match operator is desugared into a let operator binding + // with name "uu___match_op_head" followed by a regular match on + // "uu___match_op_head" + let var_id = mk_ident(reserved_prefix ^ "match_op_head", e.range) in + let var = mk_term (Var (lid_of_ids [var_id])) e.range Expr in + let pat = mk_pattern (PatVar (var_id, None, [])) e.range in + let mt = mk_term (Match (var, None, topt, branches)) top.range Expr in + let t = mk_term (LetOperator ([(op, pat, e)], mt)) e.range Expr in + desugar_term_aq env t + | Match(e, None, topt, branches) -> + let desugar_branch (pat, wopt, b) = + let (env, pat), aqP = desugar_match_pat env pat in + let wopt = match wopt with + | None -> None + | Some e -> Some (desugar_term env e) + in + let b, aqB = desugar_term_aq env b in + desugar_disjunctive_pattern pat wopt b, aqP@aqB + in + let e, aq = desugar_term_aq env e in + let asc_opt, aq0 = desugar_match_returns env e topt in + let brs, aqs = List.map desugar_branch branches |> List.unzip |> (fun (x, y) -> (List.flatten x, y)) in + mk <| Tm_match {scrutinee=e;ret_opt=asc_opt;brs;rc_opt=None}, join_aqs (aq::aq0::aqs) + + | Ascribed(e, t, tac_opt, use_eq) -> + let asc, aq0 = desugar_ascription env t tac_opt use_eq in + let e, aq = desugar_term_aq env e in + mk <| Tm_ascribed {tm=e; asc; eff_opt=None}, aq0@aq + + | Record(_, []) -> + raise_error top Errors.Fatal_UnexpectedEmptyRecord "Unexpected empty record" + + | Record(eopt, fields) -> + (* Record literals have to wait for type information to be fully resolved *) + let record_opt = + let (f, _) = List.hd fields in + try_lookup_record_by_field_name env f + in + let fields, aqs = + List.map + (fun (fn, fval) -> + let fval, aq = desugar_term_aq env fval in + (fn, fval), aq) + fields + |> List.unzip + in + (* Note, we have to unzip the fields and maintain the field + names in the qualifier and the field assignments in the term. + + This is because the qualifiers intentionally are not meant to + contain terms (only lidents, fv etc.). + + If they did contain terms, then we'd have to substitute in + them, close, open etc. which I wanted to avoid. + *) + let field_names, assignments = List.unzip fields in + let args = List.map (fun f -> f, None) assignments in + let aqs = List.flatten aqs in + let uc = + match record_opt with + | None -> + { uc_base_term = Option.isSome eopt; + uc_typename = None; + uc_fields = field_names } + | Some record -> + { uc_base_term = Option.isSome eopt; + uc_typename = Some record.typename; + uc_fields = qualify_field_names record.typename field_names } + in + let head = + let lid = lid_of_path ["__dummy__"] top.range in + S.fvar_with_dd lid + (Some (Unresolved_constructor uc)) + in + let mk_result args = S.mk_Tm_app head args top.range in + begin + match eopt with + | None -> mk_result args, aqs + | Some e -> + let e, aq = desugar_term_aq env e in + let tm = + match (SS.compress e).n with + | Tm_name _ + | Tm_fvar _ -> + //no need to hoist + mk_result ((e, None)::args) + | _ -> + (* If the base term is not a name, we hoist it *) + let x = FStarC.Ident.gen e.pos in + let env', bv_x = push_bv env x in + let nm = S.bv_to_name bv_x in + let body = mk_result ((nm, None)::args) in + let body = SS.close [S.mk_binder bv_x] body in + let lb = mk_lb ([], Inl bv_x, S.tun, e, e.pos) in + mk (Tm_let {lbs=(false, [lb]); body}) + in + tm, + aq@aqs + end + + | Project(e, f) -> + (* Projections have to wait for type information to be fully resolved *) + let e, s = desugar_term_aq env e in + let head = + match try_lookup_dc_by_field_name env f with + | None -> + S.fvar_with_dd f (Some (Unresolved_projector None)) + + | Some (constrname, is_rec) -> + let projname = mk_field_projector_name_from_ident constrname (ident_of_lid f) in + let qual = if is_rec then Some (Record_projector (constrname, ident_of_lid f)) else None in + let candidate_projector = S.lid_and_dd_as_fv (Ident.set_lid_range projname top.range) qual in + let qual = Unresolved_projector (Some candidate_projector) in + let f = List.hd (qualify_field_names constrname [f]) in + S.fvar_with_dd f (Some qual) + in + //The fvar at the head of the term just records the fieldname that the user wrote + //and in TcTerm, we use that field name combined with type info to disambiguate + mk <| Tm_app {hd=head; args=[as_arg e]}, s + + | NamedTyp(n, e) -> + (* See issue #1905 *) + log_issue n Warning_IgnoredBinding "This name is being ignored"; + desugar_term_aq env e + + | Paren e -> failwith "impossible" + + | VQuote e -> + { U.exp_string (desugar_vquote env e top.range) with pos = e.range }, noaqs + + | Quote (e, Static) -> + let tm, vts = desugar_term_aq env e in + let vt_binders = List.map (fun (bv, _tm) -> S.mk_binder bv) vts in + let vt_tms = List.map snd vts in // not closing these, they are already well-scoped + let tm = SS.close vt_binders tm in // but we need to close the variables in tm + let () = + let fvs = Free.names tm in + if not (is_empty fvs) then + raise_error e Errors.Fatal_MissingFieldInRecord + (BU.format1 "Static quotation refers to external variables: %s" (show fvs)) + in + + let qi = { qkind = Quote_static; antiquotations = (0, vt_tms) } in + mk <| Tm_quoted (tm, qi), noaqs + + | Antiquote e -> + let bv = S.new_bv (Some e.range) S.tun in + (* We use desugar_term, so there can be double antiquotations *) + let tm = desugar_term env e in + S.bv_to_name bv, [(bv, tm)] + + | Quote (e, Dynamic) -> + let qi = { qkind = Quote_dynamic + ; antiquotations = (0, []) + } in + mk <| Tm_quoted (desugar_term env e, qi), noaqs + + | CalcProof (rel, init_expr, steps) -> + (* We elaborate it into surface syntax and recursively desugar it *) + + let is_impl (rel:term) : bool = + let is_impl_t (t:S.term) : bool = + match t.n with + | Tm_fvar fv -> S.fv_eq_lid fv C.imp_lid + | _ -> false + in + match (unparen rel).tm with + | Op (id, _) -> + begin match op_as_term env 2 id with + | Some t -> is_impl_t t + | None -> false + end + + | Var lid -> + begin match desugar_name' (fun x->x) env true lid with + | Some t -> is_impl_t t + | None -> false + end + | Tvar id -> + (* GM: This case does not seem exercised even if the user writes "l_imp" + * as the relation... I thought those are meant to be Tvar nodes but + * it ends up as a Var. Bug? *) + begin match try_lookup_id env id with + | Some t -> is_impl_t t + | None -> false + end + | _ -> false + in + + (* Annoying: (<) is not a preorder since it has type + * `int -> int -> Tot bool`, and it's not subtyped to + * `int -> int -> Tot Type0`, so we eta-expand and annotate + * to make it kick in. *) + let eta_and_annot rel = + let x = Ident.gen' "x" rel.range in + let y = Ident.gen' "y" rel.range in + let xt = mk_term (Tvar x) rel.range Expr in + let yt = mk_term (Tvar y) rel.range Expr in + let pats = [mk_pattern (PatVar (x, None, [])) rel.range; mk_pattern (PatVar (y, None,[])) rel.range] in + mk_term (Abs (pats, + mk_term (Ascribed ( + mkApp rel [(xt, Nothing); (yt, Nothing)] rel.range, + mk_term (Name (Ident.lid_of_str "Type0")) rel.range Expr, + None, false)) rel.range Expr)) rel.range Expr + in + let rel = eta_and_annot rel in + + let wild r = mk_term Wild r Expr in + let init = mk_term (Var C.calc_init_lid) init_expr.range Expr in + let push_impl r = mk_term (Var C.calc_push_impl_lid) r Expr in + let last_expr = match List.last_opt steps with + | Some (CalcStep (_, _, last_expr)) -> last_expr + | None -> init_expr + in + let step r = mk_term (Var C.calc_step_lid) r Expr in + let finish = mkApp (mk_term (Var C.calc_finish_lid) top.range Expr) [(rel, Nothing)] top.range in + + let e = mkApp init [(init_expr, Nothing)] init_expr.range in + let (e, _) = List.fold_left (fun (e, prev) (CalcStep (rel, just, next_expr)) -> + let just = + if is_impl rel + then mkApp (push_impl just.range) [(thunk just, Nothing)] just.range + else just + in + let pf = mkApp (step rel.range) + [(wild rel.range, Hash); + (init_expr, Hash); + (prev, Hash); + (eta_and_annot rel, Nothing); (next_expr, Nothing); + (thunk e, Nothing); (thunk just, Nothing)] + Range.dummyRange // GM: using any other range here + // seems to make things worse, + // see test_1763 in + // tests/error-messages/Calc.fst. + // A mistery for some later day. + in + (pf, next_expr)) + (e, init_expr) steps in + let e = mkApp finish [(init_expr, Hash); (last_expr, Hash); (thunk e, Nothing)] top.range in + desugar_term_maybe_top top_level env e + + | IntroForall (bs, p, e) -> + let env', bs = desugar_binders env bs in + let p = desugar_term env' p in + let e = desugar_term env' e in + (* + forall_intro a0 (fun x0 -> forall xs. p) (fun x0 -> + forall_intro a1 (fun x1 -> forall xs. p) (fun x1 -> + ... + forall_intro an (fun xn -> p) (fun xn -> e))) + *) + let mk_forall_intro t p pf = + let head = S.fv_to_tm (S.lid_and_dd_as_fv C.forall_intro_lid None) in + let args = [(t, None); + (p, None); + (pf, None)] in + S.mk_Tm_app head args top.range + in + let rec aux bs = + match bs with + | [] -> + let sq_p = U.mk_squash U_unknown p in + U.ascribe e (Inl sq_p, None, false) + + | b::bs -> + let tail = aux bs in + let x = unqual_bv_of_binder b in + mk_forall_intro + x.sort + (U.abs [b] (U.close_forall_no_univs bs p) None) + (U.abs [b] tail None) + in + aux bs, noaqs + + | IntroExists (bs, p, vs, e) -> + let env', bs = desugar_binders env bs in + let p = desugar_term env' p in + let vs = List.map (desugar_term env) vs in + let e = desugar_term env e in + (* + (exists_intro a1 (fun x1 -> exists xs. p) + (exists_intro a2 (fun x2 -> exists xs.p[v1/x1]) + ... + (exists_intro an (fun xn -> p[vs/xs]) vn e))) + + *) + let mk_exists_intro t p v e = + let head = S.fv_to_tm (S.lid_and_dd_as_fv C.exists_intro_lid None) in + let args = [(t, None); + (p, None); + (v, None); + (mk_thunk e, None)] in + S.mk_Tm_app head args top.range + in + let rec aux bs vs sub token = + match bs, vs with + | [], [] -> token + | b::bs, v::vs -> + let x = unqual_bv_of_binder b in + let token = aux (SS.subst_binders (NT(x, v)::sub) bs) vs (NT(x, v)::sub) token in + let token = + mk_exists_intro + x.sort + (U.abs [b] (close_exists_no_univs bs (SS.subst sub p)) None) + v + token + in + token + | _ -> + raise_error top Fatal_UnexpectedTerm "Unexpected number of instantiations in _intro_ exists" + in + aux bs vs [] e, noaqs + + | IntroImplies (p, q, x, e) -> + let p = desugar_term env p in + let q = desugar_term env q in + let env', [x] = desugar_binders env [x] in + let e = desugar_term env' e in + let head = S.fv_to_tm (S.lid_and_dd_as_fv C.implies_intro_lid None) in + let args = [(p, None); + (mk_thunk q, None); + (U.abs [x] e None, None)] in + S.mk_Tm_app head args top.range, noaqs + + + | IntroOr (lr, p, q, e) -> + let p = desugar_term env p in + let q = desugar_term env q in + let e = desugar_term env e in + let lid = + if lr + then C.or_intro_left_lid + else C.or_intro_right_lid + in + let head = S.fv_to_tm (S.lid_and_dd_as_fv lid None) in + let args = [(p, None); + (mk_thunk q, None); + (mk_thunk e, None)] in + S.mk_Tm_app head args top.range, noaqs + + | IntroAnd (p, q, e1, e2) -> + let p = desugar_term env p in + let q = desugar_term env q in + let e1 = desugar_term env e1 in + let e2 = desugar_term env e2 in + let head = S.fv_to_tm (S.lid_and_dd_as_fv C.and_intro_lid None) in + let args = [(p, None); + (mk_thunk q, None); + (mk_thunk e1, None); + (mk_thunk e2, None)] in + S.mk_Tm_app head args top.range, noaqs + + | ElimForall (bs, p, vs) -> + let env', bs = desugar_binders env bs in + let p = desugar_term env' p in + let vs = List.map (desugar_term env) vs in + (* + (forall_elim #an #(fun xn -> p[vs/xs]) vn + ... + (forall_elim #a1 #(fun x1 -> forall xs. p[v0/x]) v1 + (forall_elim #a0 #(fun x0 -> forall xs. p) v0 ()))) + *) + let mk_forall_elim a p v tok = + let head = S.fv_to_tm (S.lid_and_dd_as_fv C.forall_elim_lid None) in + let args = [(a, S.as_aqual_implicit true); + (p, S.as_aqual_implicit true); + (v, None); + (tok, None)] in + S.mk_Tm_app head args tok.pos + in + let rec aux bs vs sub token : S.term = + match bs, vs with + | [], [] -> token + | b::bs, v::vs -> + let x = unqual_bv_of_binder b in + let token = + mk_forall_elim + x.sort + (U.abs [b] (U.close_forall_no_univs bs (SS.subst sub p)) None) + v + token + in + let sub = NT(x, v)::sub in + aux (SS.subst_binders sub bs) vs sub token + | _ -> + raise_error top Fatal_UnexpectedTerm "Unexpected number of instantiations in _elim_forall_" + in + let range = List.fold_right (fun bs r -> Range.union_ranges (S.range_of_bv bs.binder_bv) r) bs p.pos in + aux bs vs [] { U.exp_unit with pos = range }, noaqs + + | ElimExists (binders, p, q, binder, e) -> ( + let env', bs = desugar_binders env binders in + let p = desugar_term env' p in + let q = desugar_term env q in + let sq_q = U.mk_squash U_unknown q in + let env'', [b_pf_p] = desugar_binders env' [binder] in + let e = desugar_term env'' e in + let rec mk_exists bs p = + match bs with + | [] -> failwith "Impossible" + | [b] -> + let x = b.binder_bv in + let head = S.fv_to_tm (S.lid_and_dd_as_fv C.exists_lid None) in + let args = [(x.sort, S.as_aqual_implicit true); + (U.abs [List.hd bs] p None, None)] in + S.mk_Tm_app head args p.pos + | b::bs -> + let body = mk_exists bs p in + mk_exists [b] body + in + let mk_exists_elim t x_p s_ex_p f r = + let head = S.fv_to_tm (S.lid_and_dd_as_fv C.exists_elim_lid None) in + let args = [(t, S.as_aqual_implicit true); + (x_p, S.as_aqual_implicit true); + (s_ex_p, None); + (f, None)] in + mk_Tm_app head args r + in + let rec aux binders squash_token = + match binders with + | [] -> raise_error top Fatal_UnexpectedTerm "Empty binders in ELIM_EXISTS" + | [b] -> + let x = unqual_bv_of_binder b in + (* + exists_elim + #(x.sort) + #(fun b -> p) + squash_token + (fun b pf_p -> e) + *) + mk_exists_elim + x.sort + (U.abs [b] p None) + squash_token + (U.abs [b;b_pf_p] (U.ascribe e (Inl sq_q, None, false)) None) + squash_token.pos + + | b::bs -> + let pf_i = + S.gen_bv "pf" + (Some (range_of_bv b.binder_bv)) + S.tun + in + let k = aux bs (S.bv_to_name pf_i) in + let x = unqual_bv_of_binder b in + (* + exists_elim + #(x.sort) + #(fun b -> exists bs. p) + squash_token + (fun b pf_i -> k) + *) + mk_exists_elim + x.sort + (U.abs [b] (mk_exists bs p) None) + squash_token + (U.abs [b; S.mk_binder pf_i] k None) + squash_token.pos + in + let range = List.fold_right (fun bs r -> Range.union_ranges (S.range_of_bv bs.binder_bv) r) bs p.pos in + aux bs { U.exp_unit with pos = range }, noaqs + ) + + | ElimImplies (p, q, e) -> + let p = desugar_term env p in + let q = desugar_term env q in + let e = desugar_term env e in + let head = S.fv_to_tm (S.lid_and_dd_as_fv C.implies_elim_lid None) in + let args = [(p, None); + (q, None); + ({ U.exp_unit with pos = Range.union_ranges p.pos q.pos }, None); + (mk_thunk e, None)] in + mk_Tm_app head args top.range, noaqs + + | ElimOr(p, q, r, x, e1, y, e2) -> + let p = desugar_term env p in + let q = desugar_term env q in + let r = desugar_term env r in + let env_x, [x] = desugar_binders env [x] in + let e1 = desugar_term env_x e1 in + let env_y, [y] = desugar_binders env [y] in + let e2 = desugar_term env_y e2 in + let head = S.fv_to_tm (S.lid_and_dd_as_fv C.or_elim_lid None) in + let extra_binder = S.mk_binder (S.new_bv None S.tun) in + let args = [(p, None); + (mk_thunk q, None); + (r, None); + ({ U.exp_unit with pos = Range.union_ranges p.pos q.pos }, None); + (U.abs [x] e1 None, None); + (U.abs [extra_binder; y] e2 None, None)] in + mk_Tm_app head args top.range, noaqs + + | ElimAnd(p, q, r, x, y, e) -> + let p = desugar_term env p in + let q = desugar_term env q in + let r = desugar_term env r in + let env', [x;y] = desugar_binders env [x;y] in + let e = desugar_term env' e in + let head = S.fv_to_tm (S.lid_and_dd_as_fv C.and_elim_lid None) in + let args = [(p, None); + (mk_thunk q, None); + (r, None); + ({ U.exp_unit with pos = Range.union_ranges p.pos q.pos }, None); + (U.abs [x;y] e None, None)] in + mk_Tm_app head args top.range, noaqs + + | ListLiteral ts -> + let nil r = mk_term (Construct (C.nil_lid, [])) r Expr in + let cons r hd tl= mk_term (Construct (C.cons_lid, [ (hd, Nothing); (tl, Nothing)])) r Expr in + let t' = List.fold_right (cons top.range) ts (nil top.range) in + desugar_term_aq env t' + + | SeqLiteral ts -> + let nil r = mk_term (Var C.seq_empty_lid) r Expr in + let cons r hd tl = mkApp (mk_term (Var C.seq_cons_lid) r Expr) [ (hd, Nothing); (tl, Nothing)] r in + let t' = List.fold_right (cons top.range) ts (nil top.range) in + desugar_term_aq env t' + + | _ when (top.level=Formula) -> desugar_formula env top, noaqs + + | _ -> + raise_error top Fatal_UnexpectedTerm ("Unexpected term: " ^ term_to_string top) + end + +and desugar_match_returns env scrutinee asc_opt = + match asc_opt with + | None -> None, [] + | Some asc -> + let asc_b, asc_tc, asc_use_eq = asc in + let env_asc, b = + match asc_b with + | None -> + //no binder is specified, generate a fresh one + let bv = S.gen_bv C.match_returns_def_name (Some scrutinee.pos) S.tun in + env, S.mk_binder bv + | Some b -> + let env, bv = Env.push_bv env b in + env, S.mk_binder bv in + let asc, aq = desugar_ascription env_asc asc_tc None asc_use_eq in + //if scrutinee is a name, it may appear in the ascription + // substitute it with the (new or annotated) binder + let asc = + match (scrutinee |> U.unascribe).n with + | Tm_name sbv -> SS.subst_ascription [NT (sbv, S.bv_to_name b.binder_bv)] asc + | _ -> asc in + let asc = SS.close_ascription [b] asc in + let b = List.hd (SS.close_binders [b]) in + Some (b, asc), aq + +and desugar_ascription env t tac_opt use_eq : S.ascription & antiquotations_temp = + let annot, aq0 = + if is_comp_type env t + then if use_eq + then raise_error t Errors.Fatal_NotSupported "Equality ascription with computation types is not supported yet" + else let comp = desugar_comp t.range true env t in + (Inr comp, []) + else let tm, aq = desugar_term_aq env t in + (Inl tm, aq) in + (annot, BU.map_opt tac_opt (desugar_term env), use_eq), aq0 + +and desugar_args env args = + args |> List.map (fun (a, imp) -> arg_withimp_t imp (desugar_term env a)) + +and desugar_comp r (allow_type_promotion:bool) env t = + let fail #a code msg : a= raise_error r code msg in + let is_requires (t, _) = match (unparen t).tm with + | Requires _ -> true + | _ -> false + in + let is_ensures (t, _) = match (unparen t).tm with + | Ensures _ -> true + | _ -> false + in + let is_decreases (t, _) = match (unparen t).tm with + | Decreases _ -> true + | _ -> false + in + let is_smt_pat1 (t:term) : bool = + match (unparen t).tm with + // TODO: remove this first match once we fully migrate + | Construct (smtpat, _) -> + BU.for_some (fun s -> (string_of_lid smtpat) = s) + (* the smt pattern does not seem to be disambiguated yet at this point *) + ["SMTPat"; "SMTPatT"; "SMTPatOr"] + (* [C.smtpat_lid ; C.smtpatT_lid ; C.smtpatOr_lid] *) + + | Var smtpat -> + BU.for_some (fun s -> (string_of_lid smtpat) = s) + (* the smt pattern does not seem to be disambiguated yet at this point *) + ["smt_pat" ; "smt_pat_or"] + (* [C.smtpat_lid ; C.smtpatT_lid ; C.smtpatOr_lid] *) + + | _ -> false + in + let is_smt_pat (t,_) : bool = + match (unparen t).tm with + | ListLiteral ts -> BU.for_all is_smt_pat1 ts + | _ -> false + in + let pre_process_comp_typ (t:AST.term) = + let head, args = head_and_args t in + match head.tm with + | Name lemma when ((string_of_id (ident_of_lid lemma)) = "Lemma") -> + (* need to add the unit result type and the empty smt_pat list, if n *) + let unit_tm = mk_term (Name C.unit_lid) t.range Type_level, Nothing in + let nil_pat = mk_term (Name C.nil_lid) t.range Expr, Nothing in + let req_true = + let req = Requires (mk_term (Name C.true_lid) t.range Formula, None) in + mk_term req t.range Type_level, Nothing + in + (* The postcondition for Lemma is thunked, to allow to assume the precondition + * (c.f. #57), so add the thunking here *) + let thunk_ens (e, i) = (thunk e, i) in + let fail_lemma () = + let open FStarC.Pprint in + let expected_one_of = ["Lemma post"; + "Lemma (ensures post)"; + "Lemma (requires pre) (ensures post)"; + "Lemma post [SMTPat ...]"; + "Lemma (ensures post) [SMTPat ...]"; + "Lemma (ensures post) (decreases d)"; + "Lemma (ensures post) (decreases d) [SMTPat ...]"; + "Lemma (requires pre) (ensures post) (decreases d)"; + "Lemma (requires pre) (ensures post) [SMTPat ...]"; + "Lemma (requires pre) (ensures post) (decreases d) [SMTPat ...]"] in + raise_error t Errors.Fatal_InvalidLemmaArgument [ + text "Invalid arguments to 'Lemma'; expected one of the following" + ^^ sublist empty (List.map doc_of_string expected_one_of) + ] + in + let args = match args with + | [] -> fail_lemma () + + | [req] //a single requires clause (cf. Issue #1208) + when is_requires req -> + fail_lemma() + + | [smtpat] + when is_smt_pat smtpat -> + fail_lemma() + + | [dec] + when is_decreases dec -> + fail_lemma() + + | [ens] -> //otherwise, a single argument is always treated as just an ensures clause + [unit_tm;req_true;thunk_ens ens;nil_pat] + + | [req;ens] + when is_requires req + && is_ensures ens -> + [unit_tm;req;thunk_ens ens;nil_pat] + + | [ens;smtpat] //either Lemma p [SMTPat ...]; or Lemma (ensures p) [SMTPat ...] + when not (is_requires ens) + && not (is_smt_pat ens) + && not (is_decreases ens) + && is_smt_pat smtpat -> + [unit_tm;req_true;thunk_ens ens;smtpat] + + | [ens;dec] + when is_ensures ens + && is_decreases dec -> + [unit_tm;req_true;thunk_ens ens;nil_pat;dec] + + | [ens;dec;smtpat] + when is_ensures ens + && is_decreases dec + && is_smt_pat smtpat -> + [unit_tm;req_true;thunk_ens ens;smtpat;dec] + + | [req;ens;dec] + when is_requires req + && is_ensures ens + && is_decreases dec -> + [unit_tm;req;thunk_ens ens;nil_pat;dec] + + | [req;ens;smtpat] + when is_requires req + && is_ensures ens + && is_smt_pat smtpat -> + [unit_tm;req;thunk_ens ens;smtpat] + + | [req;ens;dec;smtpat] + when is_requires req + && is_ensures ens + && is_smt_pat smtpat + && is_decreases dec -> + [unit_tm;req;thunk_ens ens;dec;smtpat] + + | _other -> + fail_lemma() + in + let head_and_attributes = fail_or env + (Env.try_lookup_effect_name_and_attributes env) + lemma in + head_and_attributes, args + + | Name l when Env.is_effect_name env l -> + (* we have an explicit effect annotation ... no need to add anything *) + fail_or env (Env.try_lookup_effect_name_and_attributes env) l, args + + + (* we're right at the beginning of Prims, when Tot isn't yet fully defined *) + | Name l when (lid_equals (Env.current_module env) C.prims_lid + && (string_of_id (ident_of_lid l)) = "Tot") -> + (* we have an explicit effect annotation ... no need to add anything *) + (Ident.set_lid_range Const.effect_Tot_lid head.range, []), args + + (* we're right at the beginning of Prims, when GTot isn't yet fully defined *) + | Name l when (lid_equals (Env.current_module env) C.prims_lid + && (string_of_id (ident_of_lid l)) = "GTot") -> + (* we have an explicit effect annotation ... no need to add anything *) + (Ident.set_lid_range Const.effect_GTot_lid head.range, []), args + + | Name l when ((string_of_id (ident_of_lid l))="Type" + || (string_of_id (ident_of_lid l))="Type0" + || (string_of_id (ident_of_lid l))="Effect") -> + (* the default effect for Type is always Tot *) + (Ident.set_lid_range Const.effect_Tot_lid head.range, []), [t, Nothing] + + | _ when allow_type_promotion -> + let default_effect = + if Options.ml_ish () + then Const.effect_ML_lid() + else (if Options.warn_default_effects() + then FStarC.Errors.log_issue head Errors.Warning_UseDefaultEffect "Using default effect Tot"; + Const.effect_Tot_lid) in + (Ident.set_lid_range default_effect head.range, []), [t, Nothing] + + | _ -> + raise_error t Errors.Fatal_EffectNotFound "Expected an effect constructor" + in + let (eff, cattributes), args = pre_process_comp_typ t in + if List.length args = 0 then + fail Errors.Fatal_NotEnoughArgsToEffect (BU.format1 "Not enough args to effect %s" (show eff)); + let is_universe (_, imp) = imp = UnivApp in + let universes, args = BU.take is_universe args in + let universes = List.map (fun (u, imp) -> desugar_universe u) universes in + let result_arg, rest = List.hd args, List.tl args in + let result_typ = desugar_typ env (fst result_arg) in + let dec, rest = + let is_decrease t = match (unparen (fst t)).tm with + | Decreases _ -> true + | _ -> false + in + rest |> List.partition is_decrease + in + let rest = desugar_args env rest in + let decreases_clause = dec |> + List.map (fun t -> match (unparen (fst t)).tm with + | Decreases (t, _) -> + let dec_order = + let t = unparen t in + match t.tm with + | LexList l -> l |> List.map (desugar_term env) |> Decreases_lex + | WFOrder (t1, t2) -> (desugar_term env t1, desugar_term env t2) |> Decreases_wf + | _ -> [desugar_term env t] |> Decreases_lex in //by-default a lex list of length 1 + DECREASES dec_order + | _ -> + fail Errors.Fatal_UnexpectedComputationTypeForLetRec "Unexpected decreases clause") in + + let no_additional_args = + (* F# complains about not being able to use = on some types.. *) + let is_empty (l:list 'a) = match l with | [] -> true | _ -> false in + is_empty decreases_clause && + is_empty rest && + is_empty cattributes && + is_empty universes + in + if no_additional_args + && lid_equals eff C.effect_Tot_lid + then mk_Total result_typ + else if no_additional_args + && lid_equals eff C.effect_GTot_lid + then mk_GTotal result_typ + else + let flags = + if lid_equals eff C.effect_Lemma_lid then [LEMMA] + else if lid_equals eff C.effect_Tot_lid then [TOTAL] + else if lid_equals eff (C.effect_ML_lid()) then [MLEFFECT] + else if lid_equals eff C.effect_GTot_lid then [SOMETRIVIAL] + else [] + in + let flags = flags @ cattributes in + let rest = + if lid_equals eff C.effect_Lemma_lid + then + match rest with + | [req;ens;(pat, aq)] -> + let pat = match pat.n with + (* we really want the empty pattern to be in universe 0 rather than generalizing it *) + | Tm_fvar fv when S.fv_eq_lid fv Const.nil_lid -> + let nil = S.mk_Tm_uinst pat [U_zero] in + let pattern = + S.fvar_with_dd (Ident.set_lid_range Const.pattern_lid pat.pos) None + in + S.mk_Tm_app nil [(pattern, S.as_aqual_implicit true)] pat.pos + | _ -> pat + in + [req; ens; (S.mk (Tm_meta {tm=pat;meta=Meta_desugared Meta_smt_pat}) pat.pos, aq)] + | _ -> rest + else rest + in + mk_Comp ({comp_univs=universes; + effect_name=eff; + result_typ=result_typ; + effect_args=rest; + flags=flags@decreases_clause}) + +and desugar_formula env (f:term) : S.term = + let mk t = S.mk t f.range in + let setpos t = {t with pos=f.range} in + let desugar_quant (q_head:S.term) b pats should_wrap_with_pat body = + let tk = desugar_binder env ({b with blevel=Formula}) in + let with_pats env (names, pats) body = + match names, pats with + | [], [] -> body + | [], _::_ -> + //violates an internal invariant + failwith "Impossible: Annotated pattern without binders in scope" + | _ -> + let names = + names |> List.map + (fun i -> + { fail_or2 (try_lookup_id env) i with pos=(range_of_id i) }) + in + let pats = + pats |> List.map + (fun es -> es |> List.map + (fun e -> arg_withimp_t Nothing <| desugar_term env e)) + in + match pats with + | [] when not should_wrap_with_pat -> body + | _ -> mk (Tm_meta {tm=body;meta=Meta_pattern (names, pats)}) + in + match tk with + | Some a, k, _ -> //AR: ignoring the attributes here + let env, a = push_bv env a in + let a = {a with sort=k} in + let body = desugar_formula env body in + let body = with_pats env pats body in + let body = setpos <| no_annot_abs [S.mk_binder a] body in + mk <| Tm_app {hd=q_head; + args=[as_arg body]} + + | _ -> failwith "impossible" in + + let push_quant + (q:(list AST.binder & AST.patterns & AST.term) -> AST.term') + (binders:list AST.binder) + pats (body:term) = + match binders with + | b::(b'::_rest) -> + let rest = b'::_rest in + let body = mk_term (q(rest, pats, body)) (Range.union_ranges b'.brange body.range) Formula in + mk_term (q([b], ([], []), body)) f.range Formula + | _ -> failwith "impossible" in + + match (unparen f).tm with + | Labeled(f, l, p) -> + let f = desugar_formula env f in + // GM: I don't think this case really happens? + mk <| Tm_meta {tm=f; meta=Meta_labeled(Errors.Msg.mkmsg l, f.pos, p)} + + | QForall([], _, _) + | QExists([], _, _) + | QuantOp(_, [], _, _) -> failwith "Impossible: Quantifier without binders" + + | QForall((_1::_2::_3), pats, body) -> + let binders = _1::_2::_3 in + desugar_formula env (push_quant (fun x -> QForall x) binders pats body) + + | QExists((_1::_2::_3), pats, body) -> + let binders = _1::_2::_3 in + desugar_formula env (push_quant (fun x -> QExists x) binders pats body) + + | QuantOp(i, (_1::_2::_3), pats, body) -> + let binders = _1::_2::_3 in + desugar_formula env (push_quant (fun (x,y,z) -> QuantOp(i, x, y, z)) binders pats body) + + | QForall([b], pats, body) -> + let q = C.forall_lid in + let q_head = S.fvar_with_dd (set_lid_range q b.brange) None in + desugar_quant q_head b pats true body + + | QExists([b], pats, body) -> + let q = C.exists_lid in + let q_head = S.fvar_with_dd (set_lid_range q b.brange) None in + desugar_quant q_head b pats true body + + | QuantOp(i, [b], pats, body) -> + let q_head = + match op_as_term env 0 i with + | None -> + raise_error i Errors.Fatal_VariableNotFound + (BU.format1 "quantifier operator %s not found" (Ident.string_of_id i)) + | Some t -> t + in + desugar_quant q_head b pats false body + + | Paren f -> failwith "impossible" + + | _ -> desugar_term env f + +and desugar_binder_aq env b : (option ident & S.term & list S.attribute) & antiquotations_temp = + let attrs = b.battributes |> List.map (desugar_term env) in + match b.b with + | TAnnotated(x, t) + | Annotated(x, t) -> + let ty, aqs = desugar_typ_aq env t in + (Some x, ty, attrs), aqs + + | NoName t -> + let ty, aqs = desugar_typ_aq env t in + (None, ty, attrs), aqs + + | TVariable x -> + (Some x, mk (Tm_type U_unknown) (range_of_id x), attrs), [] + + | Variable x -> + (Some x, tun_r (range_of_id x), attrs), [] + +and desugar_binder env b : option ident & S.term & list S.attribute = + let r, aqs = desugar_binder_aq env b in + check_no_aq aqs; + r + +and desugar_vquote env e r: string = + (* Returns the string representation of the lid behind [e], fails if it is not an FV *) + let tm = desugar_term env e in + match (Subst.compress tm).n with + | Tm_fvar fv -> string_of_lid (lid_of_fv fv) + | _ -> raise_error r Fatal_UnexpectedTermVQuote ("VQuote, expected an fvar, got: " ^ show tm) + +and as_binder env imp = function + | (None, k, attrs) -> + mk_binder_with_attrs (null_bv k) (trans_bqual env imp) attrs, env + | (Some a, k, attrs) -> + let env, a = Env.push_bv env a in + (mk_binder_with_attrs ({a with sort=k}) (trans_bqual env imp) attrs), env + +and trans_bqual env = function + | Some AST.Implicit -> Some S.imp_tag + | Some AST.Equality -> Some S.Equality + | Some (AST.Meta t) -> + Some (S.Meta (desugar_term env t)) + | Some (AST.TypeClassArg) -> + let tcresolve = desugar_term env (mk_term (Var C.tcresolve_lid) Range.dummyRange Expr) in + Some (S.Meta tcresolve) + | None -> None + +let typars_of_binders env bs : _ & binders = + let env, tpars = List.fold_left (fun (env, out) b -> + let tk = desugar_binder env ({b with blevel=Formula}) in (* typars follow the same binding conventions as formulas *) + match tk with + | Some a, k, attrs -> + let env, a = push_bv env a in + let a = {a with sort=k} in + env, (mk_binder_with_attrs a (trans_bqual env b.aqual) attrs)::out + | _ -> raise_error b Errors.Fatal_UnexpectedBinder "Unexpected binder") (env, []) bs in + env, List.rev tpars + + +let desugar_attributes (env:env_t) (cattributes:list term) : list cflag = + let desugar_attribute t = + match (unparen t).tm with + | Var lid when string_of_lid lid = "cps" -> CPS + | _ -> raise_error t Errors.Fatal_UnknownAttribute ("Unknown attribute " ^ term_to_string t) + in List.map desugar_attribute cattributes + +let binder_ident (b:binder) : option ident = + match b.b with + | TAnnotated (x, _) + | Annotated (x, _) + | TVariable x + | Variable x -> Some x + | NoName _ -> None + +let binder_idents (bs:list binder) : list ident = + List.collect (fun b -> FStarC.Common.list_of_option (binder_ident b)) bs + + +let mk_data_discriminators quals env datas attrs = + let quals = quals |> List.filter (function + | S.NoExtract + | S.Private -> true + | _ -> false) + in + let quals q = if not (Env.iface env) + || Env.admitted_iface env + then S.Assumption::q@quals + else q@quals + in + datas |> List.map (fun d -> + let disc_name = U.mk_discriminator d in + { sigel = Sig_declare_typ {lid=disc_name; us=[]; t=Syntax.tun}; + sigrng = range_of_lid disc_name;// FIXME: Isn't that range wrong? + sigquals = quals [(* S.Logic ; *) S.OnlyName ; S.Discriminator d]; + sigmeta = default_sigmeta; + sigattrs = attrs; + sigopts = None; + sigopens_and_abbrevs = DsEnv.opens_and_abbrevs env + }) + +let mk_indexed_projector_names iquals fvq attrs env lid (fields:list S.binder) = + let p = range_of_lid lid in + + fields |> List.mapi (fun i fld -> + let x = fld.binder_bv in + let field_name = U.mk_field_projector_name lid x i in + let only_decl = + lid_equals C.prims_lid (Env.current_module env) + || fvq<>Data_ctor + || U.has_attribute attrs C.no_auto_projectors_attr + in + let no_decl = Syntax.is_type x.sort in + let quals q = + if only_decl + then S.Assumption::q + else q + in + let quals = + let iquals = iquals |> List.filter (function + | S.NoExtract + | S.Private -> true + | _ -> false) + in + quals (OnlyName :: S.Projector(lid, x.ppname) :: iquals) + in + let decl = { sigel = Sig_declare_typ {lid=field_name; us=[]; t=Syntax.tun}; + sigquals = quals; + sigrng = range_of_lid field_name; + sigmeta = default_sigmeta ; + sigattrs = attrs; + sigopts = None; + sigopens_and_abbrevs = opens_and_abbrevs env } in + if only_decl + then [decl] //only the signature + else + let lb = { + lbname=Inr (S.lid_and_dd_as_fv field_name None); + lbunivs=[]; + lbtyp=tun; + lbeff=C.effect_Tot_lid; + lbdef=tun; + lbattrs=[]; + lbpos=Range.dummyRange; + } in + let impl = { sigel = Sig_let {lbs=(false, [lb]); + lids=[lb.lbname |> right |> (fun fv -> fv.fv_name.v)]}; + sigquals = quals; + sigrng = p; + sigmeta = default_sigmeta; + sigattrs = attrs; + sigopts = None; + sigopens_and_abbrevs = opens_and_abbrevs env + } in + if no_decl then [impl] else [decl;impl]) |> List.flatten + +let mk_data_projector_names iquals env se : list sigelt = + match se.sigel with + | _ when U.has_attribute se.sigattrs C.no_auto_projectors_decls_attr + || U.has_attribute se.sigattrs C.meta_projectors_attr -> + [] + | Sig_datacon {lid;t;num_ty_params=n} -> + let formals, _ = U.arrow_formals t in + begin match formals with + | [] -> [] //no fields to project + | _ -> + let filter_records = function + | RecordConstructor (_, fns) -> Some (Record_ctor(lid, fns)) + | _ -> None + in + let fv_qual = + match BU.find_map se.sigquals filter_records with + | None -> Data_ctor + | Some q -> q + in + (* ignoring parameters *) + let _, rest = BU.first_N n formals in + mk_indexed_projector_names iquals fv_qual se.sigattrs env lid rest + end + + | _ -> [] + +let mk_typ_abbrev env d lid uvs typars kopt t lids quals rng = + (* fetch attributes here to support `deprecated`, just as for + * TopLevelLet (see comment there) *) + let attrs = U.deduplicate_terms (List.map (desugar_term env) d.attrs) in + let val_attrs = Env.lookup_letbinding_quals_and_attrs env lid |> snd in + let lb = { + lbname=Inr (S.lid_and_dd_as_fv lid None); + lbunivs=uvs; + lbdef=no_annot_abs typars t; + lbtyp=if is_some kopt then U.arrow typars (S.mk_Total (kopt |> must)) else tun; + lbeff=C.effect_Tot_lid; + lbattrs=[]; + lbpos=rng; + } in + { sigel = Sig_let {lbs=(false, [lb]); lids}; + sigquals = quals; + sigrng = rng; + sigmeta = default_sigmeta ; + sigattrs = U.deduplicate_terms (val_attrs @ attrs); + sigopts = None; + sigopens_and_abbrevs = opens_and_abbrevs env + } + +let rec desugar_tycon env (d: AST.decl) (d_attrs_initial:list S.term) quals tcs : (env_t & sigelts) = + let rng = d.drange in + let tycon_id = function + | TyconAbstract(id, _, _) + | TyconAbbrev(id, _, _, _) + | TyconRecord(id, _, _, _, _) + | TyconVariant(id, _, _, _) -> id in + let binder_to_term b = match b.b with + | Annotated (x, _) + | Variable x -> mk_term (Var (lid_of_ids [x])) (range_of_id x) Expr + | TAnnotated(a, _) + | TVariable a -> mk_term (Tvar a) (range_of_id a) Type_level + | NoName t -> t in + let desugar_tycon_variant_record = function + // for every variant, each constructor whose payload is a record + // is desugared into a reference to a _generated_ record type + // declaration + | TyconVariant (id, bds, k, variants) -> + let additional_records, variants = map (fun (cid, payload, attrs) -> + match payload with + | Some (VpRecord (r, k)) -> + let record_id = mk_ident (string_of_id id ^ "__" ^ string_of_id cid ^ "__payload", range_of_id cid) in + let record_id_t = {tm = lid_of_ns_and_id [] record_id |> Var; range = range_of_id cid; level = Type_level} in + let payload_typ = mkApp record_id_t (List.map (fun bd -> binder_to_term bd, Nothing) bds) (range_of_id record_id) in + let desugar_marker = + let range = range_of_id record_id in + let desugar_attr_fv = {fv_name = {v = FStarC.Parser.Const.desugar_of_variant_record_lid; p = range}; fv_qual = None} in + let desugar_attr = S.mk (Tm_fvar desugar_attr_fv) range in + let cid_as_constant = EMB.embed (string_of_lid (qualify env cid)) range None EMB.id_norm_cb in + S.mk_Tm_app desugar_attr [(cid_as_constant, None)] range + in + (TyconRecord (record_id, bds, None, attrs, r), desugar_marker::d_attrs_initial) |> Some + , (cid, Some ( match k with + | None -> VpOfNotation payload_typ + | Some k -> + VpArbitrary + { tm = Product ([mk_binder (NoName payload_typ) (range_of_id record_id) Type_level None], k) + ; range = payload_typ.range + ; level = Type_level + } + ), attrs) + | _ -> None, (cid, payload, attrs) + ) variants |> unzip in + // TODO: [concat_options] should live somewhere else + let concat_options = filter_map (fun r -> r) in + concat_options additional_records @ [(TyconVariant (id, bds, k, variants), d_attrs_initial)] + | tycon -> [(tycon, d_attrs_initial)] in + let tcs = concatMap desugar_tycon_variant_record tcs in + let tot rng = mk_term (Name (C.effect_Tot_lid)) rng Expr in + let with_constructor_effect t = mk_term (App(tot t.range, t, Nothing)) t.range t.level in + let apply_binders t binders = + let imp_of_aqual (b:AST.binder) = match b.aqual with + | Some Implicit + | Some (Meta _) + | Some TypeClassArg -> Hash + | _ -> Nothing in + List.fold_left (fun out b -> mk_term (App(out, binder_to_term b, imp_of_aqual b)) out.range out.level) + t binders in + let tycon_record_as_variant = function + | TyconRecord(id, parms, kopt, attrs, fields) -> + let constrName = mk_ident("Mk" ^ (string_of_id id), (range_of_id id)) in + let mfields = List.map (fun (x,q,attrs,t) -> FStarC.Parser.AST.mk_binder_with_attrs (Annotated(x,t)) (range_of_id x) Expr q attrs) fields in + let result = apply_binders (mk_term (Var (lid_of_ids [id])) (range_of_id id) Type_level) parms in + let constrTyp = mk_term (Product(mfields, with_constructor_effect result)) (range_of_id id) Type_level in + //let _ = BU.print_string (BU.format2 "Translated record %s to constructor %s\n" ((string_of_id id)) (term_to_string constrTyp)) in + + let names = id :: binder_idents parms in + List.iter (fun (f, _, _, _) -> + if BU.for_some (fun i -> ident_equals f i) names then + raise_error f Errors.Error_FieldShadow + (BU.format1 "Field %s shadows the record's name or a parameter of it, please rename it" (string_of_id f))) + fields; + + TyconVariant(id, parms, kopt, [(constrName, Some (VpArbitrary constrTyp), attrs)]), fields |> List.map (fun (f, _, _, _) -> f) + | _ -> failwith "impossible" in + let desugar_abstract_tc quals _env mutuals d_attrs = function + | TyconAbstract(id, binders, kopt) -> + let _env', typars = typars_of_binders _env binders in + let k = match kopt with + | None -> U.ktype + | Some k -> desugar_term _env' k in + let tconstr = apply_binders (mk_term (Var (lid_of_ids [id])) (range_of_id id) Type_level) binders in + let qlid = qualify _env id in + let typars = Subst.close_binders typars in + let k = Subst.close typars k in + let se = { sigel = Sig_inductive_typ {lid=qlid; + us=[]; + params=typars; + num_uniform_params=None; + t=k; + mutuals; + ds=[]; + injective_type_params=false}; + sigquals = quals; + sigrng = range_of_id id; + sigmeta = default_sigmeta; + sigattrs = d_attrs; + sigopts = None; + sigopens_and_abbrevs = opens_and_abbrevs env + } in + let _env, _ = Env.push_top_level_rec_binding _env id in + let _env2, _ = Env.push_top_level_rec_binding _env' id in + _env, _env2, se, tconstr + | _ -> failwith "Unexpected tycon" in + let push_tparams env bs = + let env, bs = List.fold_left (fun (env, tps) b -> + let env, y = Env.push_bv env b.binder_bv.ppname in + env, (mk_binder_with_attrs y b.binder_qual b.binder_attrs)::tps) (env, []) bs in + env, List.rev bs in + match tcs with + | [(TyconAbstract(id, bs, kopt), d_attrs)] -> + let kopt = match kopt with + | None -> Some (tm_type_z (range_of_id id)) + | _ -> kopt in + let tc = TyconAbstract(id, bs, kopt) in + let _, _, se, _ = desugar_abstract_tc quals env [] d_attrs tc in + let se = match se.sigel with + | Sig_inductive_typ {lid=l; params=typars; t=k; mutuals=[]; ds=[]} -> + let quals = se.sigquals in + let quals = if List.contains S.Assumption quals + then quals + else (if not (Options.ml_ish ()) then + log_issue se Errors.Warning_AddImplicitAssumeNewQualifier + (BU.format1 "Adding an implicit 'assume new' qualifier on %s" (show l)); + S.Assumption :: S.New :: quals) in + let t = match typars with + | [] -> k + | _ -> mk (Tm_arrow {bs=typars; comp=mk_Total k}) se.sigrng in + { se with sigel = Sig_declare_typ {lid=l; us=[]; t}; + sigquals = quals } + | _ -> failwith "Impossible" in + let env = push_sigelt env se in + (* let _ = pr "Pushed %s\n" (string_of_lid (qualify env (tycon_id tc))) in *) + env, [se] + + | [(TyconAbbrev(id, binders, kopt, t), _d_attrs)] -> + let env', typars = typars_of_binders env binders in + let kopt = match kopt with + | None -> + if BU.for_some (function S.Effect -> true | _ -> false) quals + then Some teff + else None + | Some k -> Some (desugar_term env' k) in + let t0 = t in + let quals = if quals |> BU.for_some (function S.Logic -> true | _ -> false) + then quals + else if t0.level = Formula + then S.Logic::quals + else quals in + let qlid = qualify env id in + let se = + if quals |> List.contains S.Effect + then + let t, cattributes = + match (unparen t).tm with + (* TODO : we are only handling the case Effect args (attributes ...) *) + | Construct (head, args) -> + let cattributes, args = + match List.rev args with + | (last_arg, _) :: args_rev -> + begin match (unparen last_arg).tm with + | Attributes ts -> ts, List.rev (args_rev) + | _ -> [], args + end + | _ -> [], args + in + mk_term (Construct (head, args)) t.range t.level, + desugar_attributes env cattributes + | _ -> t, [] + in + let c = desugar_comp t.range false env' t in + let typars = Subst.close_binders typars in + let c = Subst.close_comp typars c in + let quals = quals |> List.filter (function S.Effect -> false | _ -> true) in + { sigel = Sig_effect_abbrev {lid=qlid; us=[]; bs=typars; comp=c; + cflags=cattributes @ comp_flags c}; + sigquals = quals; + sigrng = range_of_id id; + sigmeta = default_sigmeta ; + sigattrs = []; + sigopts = None; + sigopens_and_abbrevs = opens_and_abbrevs env + } + else let t = desugar_typ env' t in + mk_typ_abbrev env d qlid [] typars kopt t [qlid] quals (range_of_id id) in + + let env = push_sigelt env se in + env, [se] + + | [(TyconRecord payload, d_attrs)] -> + let trec = TyconRecord payload in + let t, fs = tycon_record_as_variant trec in + desugar_tycon env d d_attrs (RecordType (ids_of_lid (current_module env), fs)::quals) [t] + + | _::_ -> + let env0 = env in + let mutuals = List.map (fun (x, _) -> qualify env <| tycon_id x) tcs in + let rec collect_tcs quals et (tc, d_attrs) = + let (env, tcs) = et in + match tc with + | TyconRecord _ -> + let trec = tc in + let t, fs = tycon_record_as_variant trec in + collect_tcs (RecordType (ids_of_lid (current_module env), fs)::quals) (env, tcs) (t, d_attrs) + | TyconVariant(id, binders, kopt, constructors) -> + let env, _, se, tconstr = desugar_abstract_tc quals env mutuals d_attrs (TyconAbstract(id, binders, kopt)) in + env, (Inl(se, constructors, tconstr, quals), d_attrs)::tcs + | TyconAbbrev(id, binders, kopt, t) -> + let env, _, se, tconstr = desugar_abstract_tc quals env mutuals d_attrs (TyconAbstract(id, binders, kopt)) in + env, (Inr(se, binders, t, quals), d_attrs)::tcs + | _ -> raise_error rng Errors.Fatal_NonInductiveInMutuallyDefinedType "Mutually defined type contains a non-inductive element" in + let env, tcs = List.fold_left (collect_tcs quals) (env, []) tcs in + let tcs = List.rev tcs in + let tps_sigelts = tcs |> List.collect (fun (tc, d_attrs) -> + match tc with + | Inr ({ sigel = Sig_inductive_typ {lid=id; + us=uvs; + params=tpars; + t=k} }, binders, t, quals) -> //type abbrevs in mutual type definitions + let t = + let env, tpars = typars_of_binders env binders in + let env_tps, tpars = push_tparams env tpars in + let t = desugar_typ env_tps t in + let tpars = Subst.close_binders tpars in + Subst.close tpars t + in + [([], mk_typ_abbrev env d id uvs tpars (Some k) t [id] quals (range_of_lid id))] + + | Inl ({ sigel = Sig_inductive_typ {lid=tname; + us=univs; + params=tpars; + num_uniform_params=num_uniform; + t=k; + mutuals; + injective_type_params}; sigquals = tname_quals }, + constrs, tconstr, quals) -> + let mk_tot t = + let tot = mk_term (Name C.effect_Tot_lid) t.range t.level in + mk_term (App(tot, t, Nothing)) t.range t.level in + let tycon = (tname, tpars, k) in + let env_tps, tps = push_tparams env tpars in + let data_tpars = List.map (fun tp -> { tp with S.binder_qual = Some (S.Implicit true) }) tps in + let tot_tconstr = mk_tot tconstr in + let val_attrs = Env.lookup_letbinding_quals_and_attrs env0 tname |> snd in + let constrNames, constrs = List.split <| + (constrs |> List.map (fun (id, payload, cons_attrs) -> + let t = match payload with + | Some (VpArbitrary t) -> t + | Some (VpOfNotation t) -> mk_term (Product([mk_binder (NoName t) t.range t.level None], tot_tconstr)) t.range t.level + | Some (VpRecord _) -> failwith "Impossible: [VpRecord _] should have disappeared after [desugar_tycon_variant_record]" + | None -> { tconstr with range = range_of_id id } + in + let t = desugar_term env_tps (close env_tps t) in + let name = qualify env id in + let quals = tname_quals |> List.collect (function + | RecordType fns -> [RecordConstructor fns] + | _ -> []) in + let ntps = List.length data_tpars in + (name, (tps, { sigel = Sig_datacon {lid=name; + us=univs; + t=U.arrow data_tpars (mk_Total (t |> U.name_function_binders)); + ty_lid=tname; + num_ty_params=ntps; + mutuals; + injective_type_params}; + sigquals = quals; + sigrng = range_of_lid name; + sigmeta = default_sigmeta ; + sigattrs = U.deduplicate_terms (val_attrs @ d_attrs @ map (desugar_term env) cons_attrs); + sigopts = None; + sigopens_and_abbrevs = opens_and_abbrevs env + })))) + in + if !dbg_attrs + then ( + BU.print3 "Adding attributes to type %s: val_attrs=[@@%s] attrs=[@@%s]\n" + (show tname) (show val_attrs) (show d_attrs) + ); + ([], { sigel = Sig_inductive_typ {lid=tname; + us=univs; + params=tpars; + num_uniform_params=num_uniform; + t=k; + mutuals; + ds=constrNames; + injective_type_params}; + sigquals = tname_quals; + sigrng = range_of_lid tname; + sigmeta = default_sigmeta ; + sigattrs = U.deduplicate_terms (val_attrs @ d_attrs); + sigopts = None; + sigopens_and_abbrevs = opens_and_abbrevs env + })::constrs + | _ -> failwith "impossible") + in + let sigelts = tps_sigelts |> List.map (fun (_, se) -> se) in + let bundle, abbrevs = FStarC.Syntax.MutRecTy.disentangle_abbrevs_from_bundle sigelts quals (List.collect U.lids_of_sigelt sigelts) rng in + if !dbg_attrs + then ( + BU.print1 "After disentangling: %s\n" (show bundle) + ); + let env = push_sigelt env0 bundle in + let env = List.fold_left push_sigelt env abbrevs in + (* NOTE: derived operators such as projectors and discriminators are using the type names before unfolding. *) + let data_ops = tps_sigelts |> List.collect (fun (tps, se) -> mk_data_projector_names quals env se) in + let discs = sigelts |> List.collect (fun se -> match se.sigel with + | Sig_inductive_typ {lid=tname; params=tps; t=k; ds=constrs} -> + let quals = se.sigquals in + mk_data_discriminators quals env + (constrs |> List.filter (fun data_lid -> //AR: create data discriminators only for non-record data constructors + let data_quals = + let data_se = sigelts |> List.find (fun se -> match se.sigel with + | Sig_datacon {lid=name} -> lid_equals name data_lid + | _ -> false) |> must in + data_se.sigquals in + not (data_quals |> List.existsb (function | RecordConstructor _ -> true | _ -> false)))) + se.sigattrs + | _ -> []) in + let ops = discs@data_ops in + let env = List.fold_left push_sigelt env ops in + env, [bundle]@abbrevs@ops + + | [] -> failwith "impossible" + +let desugar_binders env binders = + let env, binders = List.fold_left (fun (env,binders) b -> + match desugar_binder env b with + | Some a, k, attrs -> + let binder, env = as_binder env b.aqual (Some a, k, attrs) in + env, binder::binders + + | _ -> raise_error b Errors.Fatal_MissingNameInBinder "Missing name in binder") (env, []) binders in + env, List.rev binders + +let push_reflect_effect env quals (effect_name:Ident.lid) range = + if quals |> BU.for_some (function S.Reflectable _ -> true | _ -> false) + then let monad_env = Env.enter_monad_scope env (ident_of_lid effect_name) in + let reflect_lid = Ident.id_of_text "reflect" |> Env.qualify monad_env in + let quals = [S.Assumption; S.Reflectable effect_name] in + let refl_decl = { sigel = S.Sig_declare_typ {lid=reflect_lid; us=[]; t=S.tun}; + sigrng = range; + sigquals = quals; + sigmeta = default_sigmeta ; + sigattrs = []; + sigopts = None; + sigopens_and_abbrevs = opens_and_abbrevs env + } in + Env.push_sigelt env refl_decl // FIXME: Add docs to refl_decl? + else env + +let parse_attr_with_list warn (at:S.term) (head:lident) : option (list int) & bool = + let warn () = + if warn then + Errors.log_issue at Errors.Warning_UnappliedFail + (BU.format1 "Found ill-applied '%s', argument should be a non-empty list of integer literals" (string_of_lid head)) + in + let hd, args = U.head_and_args at in + match (SS.compress hd).n with + | Tm_fvar fv when S.fv_eq_lid fv head -> + begin + match args with + | [] -> Some [], true + | [(a1, _)] -> + begin + match EMB.unembed a1 EMB.id_norm_cb with + | Some es -> + Some (List.map FStarC.BigInt.to_int_fs es), true + | _ -> + warn(); + None, true + end + | _ -> + warn (); + None, true + end + + | _ -> + None, false + + +// If this is an expect_failure attribute, return the listed errors and whether it's a expect_lax_failure or not +let get_fail_attr1 warn (at : S.term) : option (list int & bool) = + let rebind res b = + match res with + | None -> None + | Some l -> Some (l, b) + in + let res, matched = parse_attr_with_list warn at C.fail_attr in + if matched then rebind res false + else let res, _ = parse_attr_with_list warn at C.fail_lax_attr in + rebind res true + +// Traverse a list of attributes to find all expect_failures and combine them +let get_fail_attr warn (ats : list S.term) : option (list int & bool) = + let comb f1 f2 = + match f1, f2 with + | Some (e1, l1), Some (e2, l2) -> + Some (e1@e2, l1 || l2) + + | Some (e, l), None + | None, Some (e, l) -> + Some (e, l) + + | _ -> None + in + List.fold_right (fun at acc -> comb (get_fail_attr1 warn at) acc) ats None + +let lookup_effect_lid env (l:lident) (r:Range.range) : S.eff_decl = + match Env.try_lookup_effect_defn env l with + | None -> + raise_error r Errors.Fatal_EffectNotFound + ("Effect name " ^ show l ^ " not found") + | Some l -> l + +let rec desugar_effect env d (d_attrs:list S.term) (quals: qualifiers) (is_layered:bool) eff_name eff_binders eff_typ eff_decls = + let env0 = env in + // qualified with effect name + let monad_env = Env.enter_monad_scope env eff_name in + let env, binders = desugar_binders monad_env eff_binders in + let eff_t = desugar_term env eff_typ in + + let num_indices = List.length (fst (U.arrow_formals eff_t)) in + + (* An effect for free has a type of the shape "a:Type -> Effect" *) + let for_free = num_indices = 1 && not is_layered in + if for_free + then Errors.log_issue d Errors.Warning_DeprecatedGeneric + (BU.format1 "DM4Free feature is deprecated and will be removed soon, \ + use layered effects to define %s" (Ident.string_of_id eff_name)); + + let mandatory_members = + let rr_members = ["repr" ; "return" ; "bind"] in + if for_free then rr_members + (* + * AR: subcomp, if_then_else, and close are optional + * but adding here so as not to count them as actions + *) + else if is_layered then rr_members @ [ "subcomp"; "if_then_else"; "close" ] + (* the first 3 are optional but must not be counted as actions *) + else rr_members @ [ + "return_wp"; + "bind_wp"; + "if_then_else"; + "ite_wp"; + "stronger"; + "close_wp"; + "trivial" + ] + in + + let name_of_eff_decl decl = + match decl.d with + | Tycon(_, _, [TyconAbbrev(name, _, _, _)]) -> Ident.string_of_id name + | _ -> failwith "Malformed effect member declaration." + in + + let mandatory_members_decls, actions = + List.partition (fun decl -> List.mem (name_of_eff_decl decl) mandatory_members) eff_decls + in + + let env, decls = mandatory_members_decls |> List.fold_left (fun (env, out) decl -> + let env, ses = desugar_decl env decl in + env, List.hd ses::out) + (env, []) + in + let binders = Subst.close_binders binders in + let actions = actions |> List.map (fun d -> + match d.d with + | Tycon(_, _,[TyconAbbrev(name, action_params, _, { tm = Construct (_, [ def, _; cps_type, _ ])})]) when not for_free -> + // When the effect is not for free, user has to provide a pair of + // the definition and its cps'd type. + let env, action_params = desugar_binders env action_params in + let action_params = Subst.close_binders action_params in + { + action_name=Env.qualify env name; + action_unqualified_name = name; + action_univs=[]; + action_params = action_params; + action_defn=Subst.close (binders @ action_params) (desugar_term env def); + action_typ=Subst.close (binders @ action_params) (desugar_typ env cps_type) + } + | Tycon(_, _, [TyconAbbrev(name, action_params, _, defn)]) when for_free || is_layered -> + // When for free, the user just provides the definition and the rest + // is elaborated + // For layered effects also, user just provides the definition + let env, action_params = desugar_binders env action_params in + let action_params = Subst.close_binders action_params in + { + action_name=Env.qualify env name; + action_unqualified_name = name; + action_univs=[]; + action_params = action_params; + action_defn=Subst.close (binders@action_params) (desugar_term env defn); + action_typ=S.tun + } + | _ -> + raise_error d Errors.Fatal_MalformedActionDeclaration + ("Malformed action declaration; if this is an \"effect \ + for free\", just provide the direct-style declaration. If this is \ + not an \"effect for free\", please provide a pair of the definition \ + and its cps-type with arrows inserted in the right place (see \ + examples).") + ) in + let eff_t = Subst.close binders eff_t in + let lookup s = + let l = Env.qualify env (mk_ident(s, d.drange)) in + [], Subst.close binders <| fail_or env (try_lookup_definition env) l in + let mname =qualify env0 eff_name in + let qualifiers =List.map (trans_qual d.drange (Some mname)) quals in + let dummy_tscheme = [], S.tun in + let eff_sig, combinators = + if for_free then + WP_eff_sig ([], eff_t), + DM4F_eff ({ + ret_wp = dummy_tscheme; + bind_wp = dummy_tscheme; + stronger = dummy_tscheme; + if_then_else = dummy_tscheme; + ite_wp = dummy_tscheme; + close_wp = dummy_tscheme; + trivial = dummy_tscheme; + + repr = Some (lookup "repr"); + return_repr = Some (lookup "return"); + bind_repr = Some (lookup "bind"); + }) + else if is_layered then + let has_subcomp = List.existsb (fun decl -> name_of_eff_decl decl = "subcomp") eff_decls in + let has_if_then_else = List.existsb (fun decl -> name_of_eff_decl decl = "if_then_else") eff_decls in + let has_close = List.existsb (fun decl -> name_of_eff_decl decl = "close") eff_decls in + + //setting the second component to dummy_ts, + // and kind to None, typechecker fills them in + let to_comb (us, t) = (us, t), dummy_tscheme, None in + + + let eff_t, num_effect_params = + match (SS.compress eff_t).n with + | Tm_arrow {bs; comp=c} -> + // peel off the first a:Type binder + let a::bs = bs in + // + // allow_param checks that all effect parameters + // are upfront + // it is true initially, and is set to false as soon as + // we see a non-parameter binder + // and if some parameter appears after that, we raise an error + // + let n, _, bs = List.fold_left (fun (n, allow_param, bs) b -> + let b_attrs = b.binder_attrs in + let is_param = U.has_attribute b_attrs C.effect_parameter_attr in + if is_param && not allow_param + then raise_error d Errors.Fatal_UnexpectedEffect "Effect parameters must all be upfront"; + let b_attrs = U.remove_attr C.effect_parameter_attr b_attrs in + (if is_param then n+1 else n), + allow_param && is_param, + bs@[{b with binder_attrs=b_attrs}]) (0, true, []) bs in + {eff_t with n=Tm_arrow {bs=a::bs; comp=c}}, + n + | _ -> failwith "desugaring indexed effect: effect type not an arrow" in + + (* + * AR: if subcomp or if_then_else are not specified, then fill in dummy_tscheme + * typechecker will fill in an appropriate default + *) + + Layered_eff_sig (num_effect_params, ([], eff_t)), + Layered_eff ({ + l_repr = lookup "repr", dummy_tscheme; + l_return = lookup "return", dummy_tscheme; + l_bind = lookup "bind" |> to_comb; + l_subcomp = + if has_subcomp then lookup "subcomp" |> to_comb + else dummy_tscheme, dummy_tscheme, None; + l_if_then_else = + if has_if_then_else then lookup "if_then_else" |> to_comb + else dummy_tscheme, dummy_tscheme, None; + l_close = + if has_close then Some (lookup "close", dummy_tscheme) + else None; // If close is not specified, leave it to None + // The typechecker will also not fill it in + }) + else + let rr = BU.for_some (function S.Reifiable | S.Reflectable _ -> true | _ -> false) qualifiers in + WP_eff_sig ([], eff_t), + Primitive_eff ({ + ret_wp = lookup "return_wp"; + bind_wp = lookup "bind_wp"; + stronger = lookup "stronger"; + if_then_else = lookup "if_then_else"; + ite_wp = lookup "ite_wp"; + close_wp = lookup "close_wp"; + trivial = lookup "trivial"; + + repr = if rr then Some (lookup "repr") else None; + return_repr = if rr then Some (lookup "return") else None; + bind_repr = if rr then Some (lookup "bind") else None + }) in + + let extraction_mode = + if is_layered + then S.Extract_none "" // will be populated by the typechecker + else if for_free + then if BU.for_some (function S.Reifiable -> true | _ -> false) qualifiers + then S.Extract_reify + else S.Extract_primitive + else S.Extract_primitive in + + let sigel = Sig_new_effect ({ + mname = mname; + cattributes = []; + univs = []; + binders = binders; + signature = eff_sig; + combinators = combinators; + actions = actions; + eff_attrs = d_attrs; + extraction_mode + }) in + + let se = ({ + sigel = sigel; + sigquals = qualifiers; + sigrng = d.drange; + sigmeta = default_sigmeta ; + sigattrs = d_attrs; + sigopts = None; + sigopens_and_abbrevs = opens_and_abbrevs env + }) in + + let env = push_sigelt env0 se in + let env = actions |> List.fold_left (fun env a -> + //printfn "Pushing action %s\n" (string_of_lid a.action_name); + push_sigelt env (U.action_as_lb mname a a.action_defn.pos)) env + in + let env = push_reflect_effect env qualifiers mname d.drange in + env, [se] + +and desugar_redefine_effect env d d_attrs trans_qual quals eff_name eff_binders defn = + let env0 = env in + let env = Env.enter_monad_scope env eff_name in + let env, binders = desugar_binders env eff_binders in + let ed_lid, ed, args, cattributes = + let head, args = head_and_args defn in + let lid = match head.tm with + | Name l -> l + | _ -> raise_error d Errors.Fatal_EffectNotFound ("Effect " ^AST.term_to_string head^ " not found") + in + let ed = fail_or env (Env.try_lookup_effect_defn env) lid in + let cattributes, args = + match List.rev args with + | (last_arg, _) :: args_rev -> + begin match (unparen last_arg).tm with + | Attributes ts -> ts, List.rev (args_rev) + | _ -> [], args + end + | _ -> [], args + in + lid, ed, desugar_args env args, desugar_attributes env cattributes in +// printfn "ToSyntax got eff_decl: %s\n" (Print.eff_decl_to_string false ed); + let binders = Subst.close_binders binders in + if List.length args <> List.length ed.binders + then raise_error defn Errors.Fatal_ArgumentLengthMismatch "Unexpected number of arguments to effect constructor"; + let ed_binders, _, ed_binders_opening = Subst.open_term' ed.binders S.t_unit in + let sub' shift_n (us, x) = + let x = Subst.subst (Subst.shift_subst (shift_n + List.length us) ed_binders_opening) x in + let s = U.subst_of_list ed_binders args in + Subst.close_tscheme binders (us, (Subst.subst s x)) + in + let sub = sub' 0 in + let mname=qualify env0 eff_name in + let ed = { + mname = mname; + cattributes = cattributes; + univs = ed.univs; + binders = binders; + signature = U.apply_eff_sig sub ed.signature; + combinators = apply_eff_combinators sub ed.combinators; + actions = List.map (fun action -> + let nparam = List.length action.action_params in + { + // Since we called enter_monad_env before, this is going to generate + // a name of the form FStarC.Compiler.Effect.uu___proj__STATE__item__get + action_name = Env.qualify env (action.action_unqualified_name); + action_unqualified_name = action.action_unqualified_name; + action_univs = action.action_univs ; + action_params = action.action_params ; + (* These need to be shifted further since they have the action's parameters also in scope *) + action_defn =snd (sub' nparam ([], action.action_defn)) ; + action_typ =snd (sub' nparam ([], action.action_typ)) + // GM: ^ Although isn't this one always Tm_unknown at this point? + }) + ed.actions; + eff_attrs = ed.eff_attrs; + extraction_mode = ed.extraction_mode; + } in + let se = + { sigel = Sig_new_effect ed; + sigquals = List.map (trans_qual (Some mname)) quals; + sigrng = d.drange; + sigmeta = default_sigmeta ; + sigattrs = d_attrs; + sigopts = None; + sigopens_and_abbrevs = opens_and_abbrevs env + } + in + let monad_env = env in + let env = push_sigelt env0 se in + let env = + ed.actions |> List.fold_left + (fun env a -> push_sigelt env (U.action_as_lb mname a a.action_defn.pos)) + env + in + let env = + if quals |> List.contains Reflectable + then let reflect_lid = Ident.id_of_text "reflect" |> Env.qualify monad_env in + let quals = [S.Assumption; S.Reflectable mname] in + let refl_decl = { sigel = S.Sig_declare_typ {lid=reflect_lid; us=[]; t=S.tun}; + sigquals = quals; + sigrng = d.drange; + sigmeta = default_sigmeta ; + sigattrs = []; + sigopts = None; + sigopens_and_abbrevs = opens_and_abbrevs env + } in + push_sigelt env refl_decl + else env in + env, [se] + + +and desugar_decl_maybe_fail_attr env (d: decl): (env_t & sigelts) = + let no_fail_attrs (ats : list S.term) : list S.term = + List.filter (fun at -> Option.isNone (get_fail_attr1 false at)) ats + in + + // The `fail` attribute behaves + // differentrly! We only keep that one on the first new decl. + let env0 = Env.snapshot env |> snd in (* we need the snapshot since pushing the let + * will shadow a previous val *) + + (* If this is an expect_failure, check to see if it fails. + * If it does, check that the errors match as we normally do. + * If it doesn't fail, leave it alone! The typechecker will check the failure. *) + let env, sigelts = + let attrs = U.deduplicate_terms (List.map (desugar_term env) d.attrs) in + match get_fail_attr false attrs with + | Some (expected_errs, lax) -> + let d = { d with attrs = [] } in + let errs, r = Errors.catch_errors (fun () -> + Options.with_saved_options (fun () -> + desugar_decl_core env attrs d)) in + begin match errs, r with + | [], Some (env, ses) -> + (* Succeeded desugaring, carry on, but make a Sig_fail *) + (* Restore attributes, except for fail *) + let ses = List.map (fun se -> { se with sigattrs = no_fail_attrs attrs }) ses in + let se = { sigel = Sig_fail {errs=expected_errs; fail_in_lax=lax; ses}; + sigquals = []; + sigrng = d.drange; + sigmeta = default_sigmeta; + sigattrs = attrs; + sigopts = None; + sigopens_and_abbrevs = opens_and_abbrevs env + } in + env0, [se] + + | errs, ropt -> (* failed! check that it failed as expected *) + let errnos = List.concatMap (fun i -> FStarC.Common.list_of_option i.issue_number) errs in + if Options.print_expected_failures () then ( + (* Print errors if asked for *) + BU.print_string ">> Got issues: [\n"; + List.iter Errors.print_issue errs; + BU.print_string ">>]\n" + ); + if expected_errs = [] then + env0, [] + else begin + match Errors.find_multiset_discrepancy expected_errs errnos with + | None -> env0, [] + | Some (e, n1, n2) -> + let open FStarC.Class.PP in + let open FStarC.Pprint in + List.iter Errors.print_issue errs; + Errors.log_issue d Errors.Error_DidNotFail [ + prefix 2 1 + (text "This top-level definition was expected to raise error codes") + (pp expected_errs) ^/^ + prefix 2 1 (text "but it raised") + (pp errnos) ^^ text "(at desugaring time)" ^^ dot; + text (BU.format3 "Error #%s was raised %s times, instead of %s." + (show e) (show n2) (show n1)); + ]; + env0, [] + end + end + | None -> + desugar_decl_core env attrs d + in + env, sigelts + +and desugar_decl env (d:decl) :(env_t & sigelts) = + FStarC.GenSym.reset_gensym (); + let env, ses = desugar_decl_maybe_fail_attr env d in + env, ses |> List.map generalize_annotated_univs + +and desugar_decl_core env (d_attrs:list S.term) (d:decl) : (env_t & sigelts) = + let trans_qual = trans_qual d.drange in + match d.d with + | Pragma p -> + let p = trans_pragma p in + U.process_pragma p d.drange; + let se = { sigel = Sig_pragma p; + sigquals = []; + sigrng = d.drange; + sigmeta = default_sigmeta; + sigattrs = d_attrs; + sigopts = None; + sigopens_and_abbrevs = opens_and_abbrevs env + } in + env, [se] + + | TopLevelModule id -> env, [] + + | Open (lid, restriction) -> + let env = Env.push_namespace env lid restriction in + env, [] + + | Friend lid -> + if Env.iface env + then raise_error d Errors.Fatal_FriendInterface + "'friend' declarations are not allowed in interfaces" + else if not (FStarC.Parser.Dep.module_has_interface (Env.dep_graph env) (Env.current_module env)) + then raise_error d Errors.Fatal_FriendInterface + "'friend' declarations are not allowed in modules that lack interfaces" + else if not (FStarC.Parser.Dep.module_has_interface (Env.dep_graph env) lid) + then raise_error d Errors.Fatal_FriendInterface + "'friend' declarations cannot refer to modules that lack interfaces" + else if not (FStarC.Parser.Dep.deps_has_implementation (Env.dep_graph env) lid) + then raise_error d Errors.Fatal_FriendInterface + "'friend' module has not been loaded; recompute dependences (C-c C-r) if in interactive mode" + else env, [] + + | Include (lid, restriction) -> + let env = Env.push_include env lid restriction in + env, [] + + | ModuleAbbrev(x, l) -> + Env.push_module_abbrev env x l, [] + + | Tycon(is_effect, typeclass, tcs) -> + let quals = d.quals in + let quals = if is_effect then Effect_qual :: quals else quals in + let quals = + if typeclass then + match tcs with + | [(TyconRecord _)] -> Noeq :: quals + | _ -> raise_error d Errors.Error_BadClassDecl "Ill-formed `class` declaration: definition must be a record type" + else quals + in + let env, ses = desugar_tycon env d d_attrs (List.map (trans_qual None) quals) tcs in + if !dbg_attrs + then ( + BU.print2 "Desugared tycon from {%s} to {%s}\n" (show d) (show ses) + ); + (* Handling typeclasses: we typecheck the tcs as usual, and then need to add + * %splice[new_meth_lids] (mk_class type_lid) + * where the tricky bit is getting the new_meth_lids. To do so, + * we traverse the new declarations marked with "Projector", and get + * the field names. This is pretty ugly. *) + let mkclass lid = + let r = range_of_lid lid in + let body = + if U.has_attribute d_attrs C.meta_projectors_attr then + (* new meta projectors *) + U.mk_app (S.tabbrev C.mk_projs_lid) + [S.as_arg (U.exp_bool true); + S.as_arg (U.exp_string (string_of_lid lid))] + else + (* old mk_class *) + U.mk_app (S.tabbrev C.mk_class_lid) + [S.as_arg (U.exp_string (string_of_lid lid))] + in + U.abs [S.mk_binder (S.new_bv (Some r) (tun_r r))] body None + in + let get_meths se = + let rec get_fname quals = + match quals with + | S.Projector (_, id) :: _ -> Some id + | _ :: quals -> get_fname quals + | [] -> None + in + match get_fname se.sigquals with + | None -> [] + | Some id -> + [qualify env id] + in + let formals = + let bndl = BU.try_find (function {sigel=Sig_bundle _} -> true | _ -> false) ses in + match bndl with + | None -> None + | Some bndl -> + match bndl.sigel with + | Sig_bundle {ses} -> + BU.find_map + ses + (fun se -> + match se.sigel with + | Sig_datacon {t} -> + let formals, _ = U.arrow_formals t in + Some formals + | _ -> None) + | _ -> None + in + let rec splice_decl meths se = + match se.sigel with + | Sig_bundle {ses} -> List.concatMap (splice_decl meths) ses + | Sig_inductive_typ {lid; t=ty} -> + let formals = + match formals with + | None -> [] + | Some formals -> formals + in + let has_no_method_attr (meth:Ident.lident) = + let i = Ident.ident_of_lid meth in + BU.for_some + (fun formal -> + if Ident.ident_equals i formal.binder_bv.ppname + then BU.for_some + (fun attr -> + match (SS.compress attr).n with + | Tm_fvar fv -> S.fv_eq_lid fv FStarC.Parser.Const.no_method_lid + | _ -> false) + formal.binder_attrs + else false) + formals + in + let meths = List.filter (fun x -> not (has_no_method_attr x)) meths in + let is_typed = false in + [{ sigel = Sig_splice {is_typed; lids=meths; tac=mkclass lid}; + sigquals = []; + sigrng = d.drange; + sigmeta = default_sigmeta; + sigattrs = []; + sigopts = None; + sigopens_and_abbrevs = opens_and_abbrevs env }] + | _ -> [] + in + let ses, extra = + if typeclass + then let meths = List.concatMap get_meths ses in + let rec add_class_attr se = + match se.sigel with + | Sig_bundle {ses; lids} -> + let ses = List.map add_class_attr ses in + { se with sigel = Sig_bundle {ses; lids} + ; sigattrs = U.deduplicate_terms + (S.fvar_with_dd FStarC.Parser.Const.tcclass_lid None + :: se.sigattrs) } + + | Sig_inductive_typ _ -> + { se + with sigattrs = U.deduplicate_terms + (S.fvar_with_dd FStarC.Parser.Const.tcclass_lid None + :: se.sigattrs) } + + | _ -> se + in + List.map add_class_attr ses, + List.concatMap (splice_decl meths) ses + else ses, [] + in + let env = List.fold_left push_sigelt env extra in + env, ses @ extra + + | TopLevelLet(isrec, lets) -> + let quals = d.quals in + (* If a toplevel let has a non-trivial pattern it needs to be desugared to a serie of top-level lets *) + let expand_toplevel_pattern = + isrec = NoLetQualifier && + begin match lets with + | [ { pat = PatOp _}, _ ] + | [ { pat = PatVar _}, _ ] + | [ { pat = PatAscribed ({ pat = PatOp _}, _) }, _ ] + | [ { pat = PatAscribed ({ pat = PatVar _}, _) }, _ ] -> false + | [ p, _ ] -> not (is_app_pattern p) + | _ -> false + end + in + if not expand_toplevel_pattern + then begin + let lets = List.map (fun x -> None, x) lets in + let as_inner_let = + mk_term (Let(isrec, lets, mk_term (Const Const_unit) d.drange Expr)) d.drange Expr + in + let ds_lets, aq = desugar_term_maybe_top true env as_inner_let in + check_no_aq aq; + match (Subst.compress <| ds_lets).n with + | Tm_let {lbs} -> + let fvs = snd lbs |> List.map (fun lb -> right lb.lbname) in + let val_quals, val_attrs = + List.fold_right (fun fv (qs, ats) -> + let qs', ats' = Env.lookup_letbinding_quals_and_attrs env fv.fv_name.v in + (qs'@qs, ats'@ats)) + fvs + ([], []) + in + (* Propagate top-level attrs to each lb. The lb.lbattrs field should be empty, + * but just being safe here. *) + let top_attrs = d_attrs in + let lbs = + let (isrec, lbs0) = lbs in + let lbs0 = lbs0 |> List.map (fun lb -> { lb with lbattrs = U.deduplicate_terms (lb.lbattrs @ val_attrs @ top_attrs) }) in + (isrec, lbs0) + in + // BU.print3 "Desugaring %s, val_quals are %s, val_attrs are %s\n" + // (List.map show fvs |> String.concat ", ") + // (show val_quals) + // (List.map show val_attrs |> String.concat ", "); + let quals = + match quals with + | _::_ -> + List.map (trans_qual None) quals + | _ -> + val_quals + in + let quals = + if lets |> BU.for_some (fun (_, (_, t)) -> t.level=Formula) + then S.Logic::quals + else quals in + let names = fvs |> List.map (fun fv -> fv.fv_name.v) in + let s = { sigel = Sig_let {lbs; lids=names}; + sigquals = quals; + sigrng = d.drange; + sigmeta = default_sigmeta; + sigattrs = U.deduplicate_terms (val_attrs @ top_attrs); + sigopts = None; + sigopens_and_abbrevs = opens_and_abbrevs env + } in + let env = push_sigelt env s in + env, [s] + | _ -> failwith "Desugaring a let did not produce a let" + end + else + (* If there is a top-level pattern we first bind the result of the body *) + (* to some private anonymous name then we gather each idents bounded in *) + (* the pattern and introduce one toplevel binding for each of them *) + let (pat, body) = match lets with + | [pat, body] -> pat, body + | _ -> failwith "expand_toplevel_pattern should only allow single definition lets" + in + let rec gen_fresh_toplevel_name () = + let nm = Ident.gen Range.dummyRange in + if Some? <| DsEnv.resolve_name env (Ident.lid_of_ids [nm]) + then gen_fresh_toplevel_name() + else nm + in + let fresh_toplevel_name = gen_fresh_toplevel_name() in + let fresh_pat = + let var_pat = mk_pattern (PatVar (fresh_toplevel_name, None, [])) Range.dummyRange in + (* TODO : What about inner type ascriptions ? Is there any way to retrieve those ? *) + match pat.pat with + | PatAscribed (pat, ty) -> { pat with pat = PatAscribed (var_pat, ty) } + | _ -> var_pat + in + let main_let = + (* GM: I'm not sure why we are even marking this private, + * since it has a reserved name, but anyway keeping it + * and making it not duplicate the qualifier. *) + let quals = if List.mem Private d.quals + then d.quals + else Private :: d.quals + in + desugar_decl env ({ d with + d = TopLevelLet (isrec, [fresh_pat, body]) ; + quals = quals }) + in + + let main : term = mk_term (Var (lid_of_ids [fresh_toplevel_name])) pat.prange Expr in + + let build_generic_projection (env, ses) (id_opt : option ident) = + (* When id_opt = Some id, we build a new toplevel definition + * as follows and then desugar it + * + * let id = match fresh_toplevel_name with | pat -> id + * + * Otherwise, generate a "coverage check" of the shape + * + * let uu___X : unit = match fresh_toplevel_name with | pat -> () + * + *) + let bv_pat, branch = + match id_opt with + | Some id -> + let lid = lid_of_ids [id] in + let branch = mk_term (Var lid) (range_of_lid lid) Expr in + let bv_pat = mk_pattern (PatVar (id, None, [])) (range_of_id id) in + bv_pat, branch + + | None -> + let id = gen_fresh_toplevel_name () in + let branch = mk_term (Const FStarC.Const.Const_unit) Range.dummyRange Expr in + let bv_pat = mk_pattern (PatVar (id, None, [])) (range_of_id id) in + let bv_pat = mk_pattern (PatAscribed (bv_pat, (unit_ty (range_of_id id), None))) + (range_of_id id) in + bv_pat, branch + in + let body = mk_term (Match (main, None, None, [pat, None, branch])) main.range Expr in + let id_decl = mk_decl (TopLevelLet(NoLetQualifier, [bv_pat, body])) Range.dummyRange [] in + let id_decl = { id_decl with quals = d.quals } in + let env, ses' = desugar_decl env id_decl in + env, ses @ ses' + in + + let build_projection (env, ses) id = build_generic_projection (env, ses) (Some id) in + let build_coverage_check (env, ses) = build_generic_projection (env, ses) None in + + let bvs = gather_pattern_bound_vars pat |> elems in + + (* If there are no variables in the pattern (and it is not a + * wildcard), we should still check to see that it is complete, + * otherwise things like: + * let false = true + * let Some 42 = None + * would be accepted. To do so, we generate a declaration + * of shape + * let uu___X : unit = match body with | pat -> () + * which will trigger a check for completeness of pat + * wrt the body. (See issues #829 and #1903) + *) + if List.isEmpty bvs && not (is_var_pattern pat) + then build_coverage_check main_let + else List.fold_left build_projection main_let bvs + + | Assume(id, t) -> + let f = desugar_formula env t in + let lid = qualify env id in + env, [{ sigel = Sig_assume {lid; us=[]; phi=f}; + sigquals = [S.Assumption]; + sigrng = d.drange; + sigmeta = default_sigmeta ; + sigattrs = d_attrs; + sigopts = None; + sigopens_and_abbrevs = opens_and_abbrevs env + }] + + | Val(id, t) -> + let quals = d.quals in + let t = desugar_term env (close_fun env t) in + let quals = + if Env.iface env + && Env.admitted_iface env + then Assumption::quals + else quals in + let lid = qualify env id in + let se = { sigel = Sig_declare_typ {lid; us=[]; t}; + sigquals = List.map (trans_qual None) quals; + sigrng = d.drange; + sigmeta = default_sigmeta ; + sigattrs = d_attrs; + sigopts = None; + sigopens_and_abbrevs = opens_and_abbrevs env } in + let env = push_sigelt env se in + env, [se] + + | Exception(id, t_opt) -> + let t = + match t_opt with + | None -> fail_or env (try_lookup_lid env) C.exn_lid + | Some term -> + let t = desugar_term env term in + U.arrow ([null_binder t]) (mk_Total <| fail_or env (try_lookup_lid env) C.exn_lid) + in + let l = qualify env id in + let qual = [ExceptionConstructor] in + let top_attrs = d_attrs in + let se = { sigel = Sig_datacon {lid=l;us=[];t;ty_lid=C.exn_lid;num_ty_params=0;mutuals=[C.exn_lid];injective_type_params=false}; + sigquals = qual; + sigrng = d.drange; + sigmeta = default_sigmeta ; + sigattrs = top_attrs; + sigopts = None; + sigopens_and_abbrevs = opens_and_abbrevs env } in + let se' = { sigel = Sig_bundle {ses=[se]; lids=[l]}; + sigquals = qual; + sigrng = d.drange; + sigmeta = default_sigmeta ; + sigattrs = top_attrs; + sigopts = None; + sigopens_and_abbrevs = opens_and_abbrevs env } in + let env = push_sigelt env se' in + let data_ops = mk_data_projector_names [] env se in + let discs = mk_data_discriminators [] env [l] top_attrs in + let env = List.fold_left push_sigelt env (discs@data_ops) in + env, se'::discs@data_ops + + | NewEffect (RedefineEffect(eff_name, eff_binders, defn)) -> + let quals = d.quals in + desugar_redefine_effect env d d_attrs trans_qual quals eff_name eff_binders defn + + | NewEffect (DefineEffect(eff_name, eff_binders, eff_typ, eff_decls)) -> + let quals = d.quals in + desugar_effect env d d_attrs quals false eff_name eff_binders eff_typ eff_decls + + | LayeredEffect (DefineEffect (eff_name, eff_binders, eff_typ, eff_decls)) -> + let quals = d.quals in + desugar_effect env d d_attrs quals true eff_name eff_binders eff_typ eff_decls + + | LayeredEffect (RedefineEffect _) -> + failwith "Impossible: LayeredEffect (RedefineEffect _) (should not be parseable)" + + | SubEffect l -> + let src_ed = lookup_effect_lid env l.msource d.drange in + let dst_ed = lookup_effect_lid env l.mdest d.drange in + let top_attrs = d_attrs in + if not (U.is_layered src_ed || U.is_layered dst_ed) + then let lift_wp, lift = match l.lift_op with + | NonReifiableLift t -> Some ([],desugar_term env t), None + | ReifiableLift (wp, t) -> Some ([],desugar_term env wp), Some([], desugar_term env t) + | LiftForFree t -> None, Some ([],desugar_term env t) + in + let se = { sigel = Sig_sub_effect({source=src_ed.mname; + target=dst_ed.mname; + lift_wp=lift_wp; + lift=lift; + kind=None}); + sigquals = []; + sigrng = d.drange; + sigmeta = default_sigmeta ; + sigattrs = top_attrs; + sigopts = None; + sigopens_and_abbrevs = opens_and_abbrevs env } in + env, [se] + else + (match l.lift_op with + | NonReifiableLift t -> + let sub_eff = { + source = src_ed.mname; + target = dst_ed.mname; + lift_wp = None; + lift = Some ([], desugar_term env t); + kind = None + } in + env, [{ + sigel = Sig_sub_effect sub_eff; + sigquals = []; + sigrng = d.drange; + sigmeta = default_sigmeta; + sigattrs = top_attrs; + sigopts = None; + sigopens_and_abbrevs = opens_and_abbrevs env}] + | _ -> failwith "Impossible! unexpected lift_op for lift to a layered effect") + + | Polymonadic_bind (m_eff, n_eff, p_eff, bind) -> + let m = lookup_effect_lid env m_eff d.drange in + let n = lookup_effect_lid env n_eff d.drange in + let p = lookup_effect_lid env p_eff d.drange in + let top_attrs = d_attrs in + env, [{ + sigel = Sig_polymonadic_bind { + m_lid=m.mname; + n_lid=n.mname; + p_lid=p.mname; + tm=([], desugar_term env bind); + typ=([], S.tun); + kind=None }; + sigquals = []; + sigrng = d.drange; + sigmeta = default_sigmeta; + sigattrs = top_attrs; + sigopts = None; + sigopens_and_abbrevs = opens_and_abbrevs env }] + + | Polymonadic_subcomp (m_eff, n_eff, subcomp) -> + let m = lookup_effect_lid env m_eff d.drange in + let n = lookup_effect_lid env n_eff d.drange in + let top_attrs = d_attrs in + env, [{ + sigel = Sig_polymonadic_subcomp { + m_lid=m.mname; + n_lid=n.mname; + tm=([], desugar_term env subcomp); + typ=([], S.tun); + kind=None }; + sigquals = []; + sigrng = d.drange; + sigmeta = default_sigmeta; + sigattrs = top_attrs; + sigopts = None; + sigopens_and_abbrevs = opens_and_abbrevs env }] + + | Splice (is_typed, ids, t) -> + let ids = + if d.interleaved + then [] + else ids + in + let t = desugar_term env t in + let top_attrs = d_attrs in + let se = { sigel = Sig_splice {is_typed; lids=List.map (qualify env) ids; tac=t}; + sigquals = List.map (trans_qual None) d.quals; + sigrng = d.drange; + sigmeta = default_sigmeta; + sigattrs = top_attrs; + sigopts = None; + sigopens_and_abbrevs = opens_and_abbrevs env } in + let env = push_sigelt env se in + env, [se] + + | UseLangDecls _ -> + env, [] + + | Unparseable -> + raise_error d Errors.Fatal_SyntaxError "Syntax error" + + | DeclSyntaxExtension (extension_name, code, _, range) -> ( + let extension_parser = FStarC.Parser.AST.Util.lookup_extension_parser extension_name in + match extension_parser with + | None -> + raise_error range Errors.Fatal_SyntaxError + (BU.format1 "Unknown syntax extension %s" extension_name) + | Some parser -> + let open FStarC.Parser.AST.Util in + let opens = { + open_namespaces = open_modules_and_namespaces env; + module_abbreviations = module_abbrevs env + } in + match parser.parse_decl opens code range with + | Inl error -> + raise_error error.range Errors.Fatal_SyntaxError error.message + | Inr d' -> + let quals = d'.quals @ d.quals in + let attrs = d'.attrs @ d.attrs in + desugar_decl_maybe_fail_attr env { d' with quals; attrs; drange=d.drange; interleaved=d.interleaved } + ) + + | DeclToBeDesugared tbs -> ( + match lookup_extension_tosyntax tbs.lang_name with + | None -> + raise_error d Errors.Fatal_SyntaxError + (BU.format1 "Could not find desugaring callback for extension %s" tbs.lang_name) + | Some desugar -> + let mk_sig sigel = + let top_attrs = d_attrs in + let sigel = + if d.interleaved + then ( + match sigel with + | Sig_splice s -> Sig_splice { s with lids = [] } + | _ -> sigel + ) + else sigel + in + let se = { + sigel; + sigquals = List.map (trans_qual None) d.quals; + sigrng = d.drange; + sigmeta = default_sigmeta; + sigattrs = top_attrs; + sigopts = None; + sigopens_and_abbrevs = opens_and_abbrevs env + } + in + se + in + let lids = List.map (qualify env) tbs.idents in + let sigelts' = desugar env tbs.blob lids d.drange in + let sigelts = List.map mk_sig sigelts' in + let env = List.fold_left push_sigelt env sigelts in + env, sigelts + ) + +let desugar_decls env decls = + let env, sigelts = + List.fold_left (fun (env, sigelts) d -> + let env, se = desugar_decl env d in + env, sigelts@se) (env, []) decls + in + env, sigelts + +(* Top-level functionality: from AST to a module + Keeps track of the name of variables and so on (in the context) + *) +let desugar_modul_common (curmod: option S.modul) env (m:AST.modul) : env_t & Syntax.modul & bool = + let env = match curmod, m with + | None, _ -> + env + | Some ({ name = prev_lid }), Module (current_lid, _) + when lid_equals prev_lid current_lid && Options.interactive () -> + // If we're in the interactive mode reading the contents of an fst after + // desugaring the corresponding fsti, don't finish the fsti + env + | Some prev_mod, _ -> + fst (Env.finish_module_or_interface env prev_mod) in + let (env, pop_when_done), mname, decls, intf = match m with + | Interface(mname, decls, admitted) -> + Env.prepare_module_or_interface true admitted env mname Env.default_mii, mname, decls, true + | Module(mname, decls) -> + Env.prepare_module_or_interface false false env mname Env.default_mii, mname, decls, false in + let env, sigelts = desugar_decls env decls in + let modul = { + name = mname; + declarations = sigelts; + is_interface=intf + } in + env, modul, pop_when_done + +let as_interface (m:AST.modul) : AST.modul = + match m with + | AST.Module(mname, decls) -> AST.Interface(mname, decls, true) + | i -> i + +let desugar_partial_modul curmod (env:env_t) (m:AST.modul) : env_t & Syntax.modul = + let m = + if Options.interactive () && + List.mem (get_file_extension (List.hd (Options.file_list ()))) ["fsti"; "fsi"] + then as_interface m + else m + in + let env, modul, pop_when_done = desugar_modul_common curmod env m in + if pop_when_done then Env.pop (), modul + else env, modul + +let desugar_modul env (m:AST.modul) : env_t & Syntax.modul = + Errors.with_ctx ("While desugaring module " ^ Class.Show.show (lid_of_modul m)) (fun () -> + let env, modul, pop_when_done = desugar_modul_common None env m in + let env, modul = Env.finish_module_or_interface env modul in + if Options.dump_module (string_of_lid modul.name) + then BU.print1 "Module after desugaring:\n%s\n" (show modul); + (if pop_when_done then export_interface modul.name env else env), modul + ) + +///////////////////////////////////////////////////////////////////////////////////////// +//External API for modules +///////////////////////////////////////////////////////////////////////////////////////// +let with_options (f:unit -> 'a) : 'a = + let light, r = + Options.with_saved_options (fun () -> + let r = f () in + let light = Options.ml_ish () in + light, r + ) + in + if light then Options.set_ml_ish (); + r + +let ast_modul_to_modul modul : withenv S.modul = + fun env -> + with_options (fun () -> + let e, m = desugar_modul env modul in + m, e) + +let decls_to_sigelts decls : withenv S.sigelts = + fun env -> + with_options (fun () -> + let env, sigelts = desugar_decls env decls in + sigelts, env) + +let partial_ast_modul_to_modul modul a_modul : withenv S.modul = + fun env -> + with_options (fun () -> + let env, modul = desugar_partial_modul modul env a_modul in + modul, env) + +let add_modul_to_env_core (finish: bool) (m:Syntax.modul) + (mii:module_inclusion_info) + (erase_univs:S.term -> S.term) : withenv unit = + fun en -> + let erase_univs_ed ed = + let erase_binders bs = + match bs with + | [] -> [] + | _ -> + let t = erase_univs (S.mk (Tm_abs {bs; body=S.t_unit; rc_opt=None}) Range.dummyRange) in + match (Subst.compress t).n with + | Tm_abs {bs} -> bs + | _ -> failwith "Impossible" + in + let binders, _, binders_opening = + Subst.open_term' (erase_binders ed.binders) S.t_unit in + let erase_term t = + Subst.close binders (erase_univs (Subst.subst binders_opening t)) + in + let erase_tscheme (us, t) = + let t = Subst.subst (Subst.shift_subst (List.length us) binders_opening) t in + [], Subst.close binders (erase_univs t) + in + let erase_action action = + let opening = Subst.shift_subst (List.length action.action_univs) binders_opening in + let erased_action_params = + match action.action_params with + | [] -> [] + | _ -> + let bs = erase_binders <| Subst.subst_binders opening action.action_params in + let t = S.mk (Tm_abs {bs; body=S.t_unit; rc_opt=None}) Range.dummyRange in + match (Subst.compress (Subst.close binders t)).n with + | Tm_abs {bs} -> bs + | _ -> failwith "Impossible" + in + let erase_term t = + Subst.close binders (erase_univs (Subst.subst opening t)) + in + { action with + action_univs = []; + action_params = erased_action_params; + action_defn = erase_term action.action_defn; + action_typ = erase_term action.action_typ + } + in + { ed with + univs = []; + binders = Subst.close_binders binders; + signature = U.apply_eff_sig erase_tscheme ed.signature; + combinators = apply_eff_combinators erase_tscheme ed.combinators; + actions = List.map erase_action ed.actions + } + in + let push_sigelt env se = + match se.sigel with + | Sig_new_effect ed -> + let se' = {se with sigel=Sig_new_effect (erase_univs_ed ed)} in + let env = Env.push_sigelt env se' in + push_reflect_effect env se.sigquals ed.mname se.sigrng + | _ -> Env.push_sigelt env se + in + let en, pop_when_done = Env.prepare_module_or_interface false false en m.name mii in + let en = List.fold_left + push_sigelt + (Env.set_current_module en m.name) + m.declarations in + let en = if finish then Env.finish en m else en in + (), (if pop_when_done then export_interface m.name en else en) + +let add_partial_modul_to_env = add_modul_to_env_core false +let add_modul_to_env = add_modul_to_env_core true diff --git a/src/tosyntax/FStarC.ToSyntax.ToSyntax.fsti b/src/tosyntax/FStarC.ToSyntax.ToSyntax.fsti new file mode 100644 index 00000000000..8c153e658cb --- /dev/null +++ b/src/tosyntax/FStarC.ToSyntax.ToSyntax.fsti @@ -0,0 +1,60 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.ToSyntax.ToSyntax +open FStarC.Compiler.Effect + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.Syntax.Util +open FStarC.Parser +open FStarC.Syntax.DsEnv +open FStarC.Parser.AST +open FStarC.Ident + +module S = FStarC.Syntax.Syntax +module U = FStarC.Syntax.Util + +type extension_tosyntax_decl_t = env -> FStarC.Dyn.dyn -> lids:list lident -> Range.range -> list sigelt' +val register_extension_tosyntax (lang_name:string) (cb:extension_tosyntax_decl_t) : unit + +val as_interface: AST.modul -> AST.modul +val desugar_term: env -> term -> S.term +val desugar_machine_integer: env -> repr:string + -> (FStarC.Const.signedness & FStarC.Const.width) + -> Range.range -> Syntax.term +val free_vars (tvars_only:bool) (e:env) (t:term) : list ident +val close: env -> term -> term + +val ast_modul_to_modul: AST.modul -> withenv Syntax.modul +val decls_to_sigelts: list AST.decl -> withenv sigelts +val partial_ast_modul_to_modul: option S.modul -> AST.modul -> withenv Syntax.modul + +val add_partial_modul_to_env: Syntax.modul + -> module_inclusion_info + -> erase_univs:(S.term -> S.term) + -> withenv unit +val add_modul_to_env: Syntax.modul + -> module_inclusion_info + -> erase_univs:(S.term -> S.term) + -> withenv unit + +val parse_attr_with_list : bool -> S.term -> lident -> option (list int) & bool + +val get_fail_attr1 : bool -> S.term -> option (list int & bool) +val get_fail_attr : bool -> list S.term -> option (list int & bool) diff --git a/src/typechecker/FStar.TypeChecker.Cfg.fst b/src/typechecker/FStar.TypeChecker.Cfg.fst deleted file mode 100644 index 0d6ea55e3d2..00000000000 --- a/src/typechecker/FStar.TypeChecker.Cfg.fst +++ /dev/null @@ -1,480 +0,0 @@ -module FStar.TypeChecker.Cfg - -open FStar -open FStar.Char -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Compiler.String -open FStar.Const -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.TypeChecker -open FStar.TypeChecker.Env - -open FStar.Class.Show - -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module BU = FStar.Compiler.Util -module FC = FStar.Const -module PC = FStar.Parser.Const -module U = FStar.Syntax.Util -module I = FStar.Ident -module EMB = FStar.Syntax.Embeddings -module Z = FStar.BigInt -module NBE = FStar.TypeChecker.NBETerm - -friend FStar.Pervasives (* to expose norm_step *) - -let steps_to_string f = - let format_opt (f:'a -> string) (o:option 'a) = - match o with - | None -> "None" - | Some x -> "Some ("^ f x ^ ")" - in - let b = BU.string_of_bool in - BU.format - "{\n\ - beta = %s;\n\ - iota = %s;\n\ - zeta = %s;\n\ - zeta_full = %s;\n\ - weak = %s;\n\ - hnf = %s;\n\ - primops = %s;\n\ - do_not_unfold_pure_lets = %s;\n\ - unfold_until = %s;\n\ - unfold_only = %s;\n\ - unfold_fully = %s;\n\ - unfold_attr = %s;\n\ - unfold_qual = %s;\n\ - unfold_namespace = %s;\n\ - dont_unfold_attr = %s;\n\ - pure_subterms_within_computations = %s;\n\ - simplify = %s;\n\ - erase_universes = %s;\n\ - allow_unbound_universes = %s;\n\ - reify_ = %s;\n\ - compress_uvars = %s;\n\ - no_full_norm = %s;\n\ - check_no_uvars = %s;\n\ - unmeta = %s;\n\ - unascribe = %s;\n\ - in_full_norm_request = %s;\n\ - weakly_reduce_scrutinee = %s;\n\ - for_extraction = %s;\n\ - unrefine = %s;\n\ - default_univs_to_zero = %s;\n\ - tactics = %s;\n\ - }" - [ f.beta |> show; - f.iota |> show; - f.zeta |> show; - f.zeta_full |> show; - f.weak |> show; - f.hnf |> show; - f.primops |> show; - f.do_not_unfold_pure_lets |> show; - f.unfold_until |> show; - f.unfold_only |> show; - f.unfold_fully |> show; - f.unfold_attr |> show; - f.unfold_qual |> show; - f.unfold_namespace |> show; - f.dont_unfold_attr |> show; - f.pure_subterms_within_computations |> show; - f.simplify |> show; - f.erase_universes |> show; - f.allow_unbound_universes |> show; - f.reify_ |> show; - f.compress_uvars |> show; - f.no_full_norm |> show; - f.check_no_uvars |> show; - f.unmeta |> show; - f.unascribe |> show; - f.in_full_norm_request |> show; - f.weakly_reduce_scrutinee |> show; - f.for_extraction |> show; - f.unrefine |> show; - f.default_univs_to_zero |> show; - f.tactics |> show; - ] - -instance deq_fsteps : deq fsteps = { - (=?) = (fun f1 f2 -> - f1.beta =? f2.beta && - f1.iota =? f2.iota && - f1.zeta =? f2.zeta && - f1.zeta_full =? f2.zeta_full && - f1.weak =? f2.weak && - f1.hnf =? f2.hnf && - f1.primops =? f2.primops && - f1.do_not_unfold_pure_lets =? f2.do_not_unfold_pure_lets && - f1.unfold_until =? f2.unfold_until && - f1.unfold_only =? f2.unfold_only && - f1.unfold_fully =? f2.unfold_fully && - f1.unfold_attr =? f2.unfold_attr && - f1.unfold_qual =? f2.unfold_qual && - f1.unfold_namespace =? f2.unfold_namespace && - f1.dont_unfold_attr =? f2.dont_unfold_attr && - f1.pure_subterms_within_computations =? f2.pure_subterms_within_computations && - f1.simplify =? f2.simplify && - f1.erase_universes =? f2.erase_universes && - f1.allow_unbound_universes =? f2.allow_unbound_universes && - f1.reify_ =? f2.reify_ && - f1.compress_uvars =? f2.compress_uvars && - f1.no_full_norm =? f2.no_full_norm && - f1.check_no_uvars =? f2.check_no_uvars && - f1.unmeta =? f2.unmeta && - f1.unascribe =? f2.unascribe && - f1.in_full_norm_request =? f2.in_full_norm_request && - f1.weakly_reduce_scrutinee =? f2.weakly_reduce_scrutinee && - f1.nbe_step =? f2.nbe_step && - f1.for_extraction =? f2.for_extraction && - f1.unrefine =? f2.unrefine && - f1.default_univs_to_zero =? f2.default_univs_to_zero && - f1.tactics =? f2.tactics - ); -} - -let default_steps : fsteps = { - beta = true; - iota = true; - zeta = true; - zeta_full = false; - weak = false; - hnf = false; - primops = false; - do_not_unfold_pure_lets = false; - unfold_until = None; - unfold_only = None; - unfold_fully = None; - unfold_attr = None; - unfold_qual = None; - unfold_namespace = None; - dont_unfold_attr = None; - pure_subterms_within_computations = false; - simplify = false; - erase_universes = false; - allow_unbound_universes = false; - reify_ = false; - compress_uvars = false; - no_full_norm = false; - check_no_uvars = false; - unmeta = false; - unascribe = false; - in_full_norm_request = false; - weakly_reduce_scrutinee = true; - nbe_step = false; - for_extraction = false; - unrefine = false; - default_univs_to_zero = false; - tactics = false; -} - -let fstep_add_one s fs = - match s with - | Beta -> { fs with beta = true } - | Iota -> { fs with iota = true } - | Zeta -> { fs with zeta = true } - | ZetaFull -> { fs with zeta_full = true } - | Exclude Beta -> { fs with beta = false } - | Exclude Iota -> { fs with iota = false } - | Exclude Zeta -> { fs with zeta = false } - | Exclude _ -> failwith "Bad exclude" - | Weak -> { fs with weak = true } - | HNF -> { fs with hnf = true } - | Primops -> { fs with primops = true } - | Eager_unfolding -> fs // eager_unfolding is not a step - | Inlining -> fs // not a step // ZP : Adding qualification because of name clash - | DoNotUnfoldPureLets -> { fs with do_not_unfold_pure_lets = true } - | UnfoldUntil d -> { fs with unfold_until = Some d } - | UnfoldOnly lids -> { fs with unfold_only = Some lids } - | UnfoldFully lids -> { fs with unfold_fully = Some lids } - | UnfoldAttr lids -> { fs with unfold_attr = Some lids } - | UnfoldQual strs -> - let fs = { fs with unfold_qual = Some strs } in - if List.contains "pure_subterms_within_computations" strs - then {fs with pure_subterms_within_computations = true} - else fs - | UnfoldNamespace strs -> - { fs with unfold_namespace = - Some (List.map (fun s -> (Ident.path_of_text s, true)) strs, false) } - | DontUnfoldAttr lids -> { fs with dont_unfold_attr = Some lids } - | PureSubtermsWithinComputations -> { fs with pure_subterms_within_computations = true } - | Simplify -> { fs with simplify = true } - | EraseUniverses -> { fs with erase_universes = true } - | AllowUnboundUniverses -> { fs with allow_unbound_universes = true } - | Reify -> { fs with reify_ = true } - | CompressUvars -> { fs with compress_uvars = true } - | NoFullNorm -> { fs with no_full_norm = true } - | CheckNoUvars -> { fs with check_no_uvars = true } - | Unmeta -> { fs with unmeta = true } - | Unascribe -> { fs with unascribe = true } - | NBE -> {fs with nbe_step = true } - | ForExtraction -> {fs with for_extraction = true } - | Unrefine -> {fs with unrefine = true } - | NormDebug -> fs // handled above, affects only dbg flags - | DefaultUnivsToZero -> {fs with default_univs_to_zero = true} - | Tactics -> { fs with tactics = true } - -let to_fsteps (s : list step) : fsteps = - List.fold_right fstep_add_one s default_steps - -let no_debug_switches = { - gen = false; - top = false; - cfg = false; - primop = false; - unfolding = false; - b380 = false; - wpe = false; - norm_delayed = false; - print_normalized = false; - debug_nbe = false; - erase_erasable_args = false; -} - -(* Primitive step sets. They are represented as a persistent string map *) -type prim_step_set = BU.psmap primitive_step - -let empty_prim_steps () : prim_step_set = - BU.psmap_empty () - -let add_step (s : primitive_step) (ss : prim_step_set) = - BU.psmap_add ss (I.string_of_lid s.name) s - -let merge_steps (s1 : prim_step_set) (s2 : prim_step_set) : prim_step_set = - BU.psmap_merge s1 s2 - -let add_steps (m : prim_step_set) (l : list primitive_step) : prim_step_set = - List.fold_right add_step l m - -let prim_from_list (l : list primitive_step) : prim_step_set = - add_steps (empty_prim_steps ()) l -(* / Primitive step sets *) - -(* Turn the lists into psmap sets, for efficiency of lookup *) -let built_in_primitive_steps = prim_from_list built_in_primitive_steps_list -let env_dependent_ops env = prim_from_list (env_dependent_ops env) -let simplification_steps env = prim_from_list (simplification_ops_list env) - -instance showable_cfg : showable cfg = { - show = (fun cfg -> - String.concat "\n" - ["{"; - BU.format1 " steps = %s;" (steps_to_string cfg.steps); - BU.format1 " delta_level = %s;" (show cfg.delta_level); - "}" ]); -} - -let cfg_env cfg = cfg.tcenv - -let find_prim_step cfg fv = - BU.psmap_try_find cfg.primitive_steps (I.string_of_lid fv.fv_name.v) - -let is_prim_step cfg fv = - BU.is_some (BU.psmap_try_find cfg.primitive_steps (I.string_of_lid fv.fv_name.v)) - -let log cfg f = - if cfg.debug.gen then f () else () - -let log_top cfg f = - if cfg.debug.top then f () else () - -let log_cfg cfg f = - if cfg.debug.cfg then f () else () - -let log_primops cfg f = - if cfg.debug.primop then f () else () - -let dbg_unfolding = Debug.get_toggle "Unfolding" -let log_unfolding cfg f = - if !dbg_unfolding then f () else () - -let log_nbe cfg f = - if cfg.debug.debug_nbe then f () - -(* Profiling the time each different primitive step consumes *) -let primop_time_map : BU.smap int = BU.smap_create 50 - -let primop_time_reset () = - BU.smap_clear primop_time_map - -let primop_time_count (nm : string) (ms : int) : unit = - match BU.smap_try_find primop_time_map nm with - | None -> BU.smap_add primop_time_map nm ms - | Some ms0 -> BU.smap_add primop_time_map nm (ms0 + ms) - -let fixto n s = - if String.length s < n - then (make (n - String.length s) ' ') ^ s - else s - -let primop_time_report () : string = - let pairs = BU.smap_fold primop_time_map (fun nm ms rest -> (nm, ms)::rest) [] in - let pairs = BU.sort_with (fun (_, t1) (_, t2) -> t1 - t2) pairs in - List.fold_right (fun (nm, ms) rest -> (BU.format2 "%sms --- %s\n" (fixto 10 (BU.string_of_int ms)) nm) ^ rest) pairs "" - -let extendable_primops_dirty : ref bool = BU.mk_ref true - -type register_prim_step_t = primitive_step -> unit -type retrieve_prim_step_t = unit -> prim_step_set -let mk_extendable_primop_set () - : register_prim_step_t - & retrieve_prim_step_t = - let steps = BU.mk_ref (empty_prim_steps ()) in - let register (p:primitive_step) = - extendable_primops_dirty := true; - steps := add_step p !steps - in - let retrieve () = !steps - in - register, retrieve - -let plugins = mk_extendable_primop_set () -let extra_steps = mk_extendable_primop_set () - -let register_plugin (p:primitive_step) = fst plugins p -let retrieve_plugins () = - if Options.no_plugins () - then empty_prim_steps () - else snd plugins () - -let register_extra_step p = fst extra_steps p -let retrieve_extra_steps () = snd extra_steps () - -let list_plugins () : list primitive_step = - FStar.Common.psmap_values (retrieve_plugins ()) - -let list_extra_steps () : list primitive_step = - FStar.Common.psmap_values (retrieve_extra_steps ()) - -let cached_steps : unit -> prim_step_set = - let memo : ref prim_step_set = BU.mk_ref (empty_prim_steps ()) in - fun () -> - if !extendable_primops_dirty - then - let steps = - merge_steps built_in_primitive_steps - (merge_steps (retrieve_plugins ()) - (retrieve_extra_steps ())) - in - memo := steps; - extendable_primops_dirty := false; - steps - else - !memo - -let add_nbe s = // ZP : Turns nbe flag on, to be used as the default norm strategy - if Options.use_nbe () - then { s with nbe_step = true } - else s - -let dbg_Norm = Debug.get_toggle "Norm" -let dbg_NormTop = Debug.get_toggle "NormTop" -let dbg_NormCfg = Debug.get_toggle "NormCfg" -let dbg_Primops = Debug.get_toggle "Primops" -let dbg_Unfolding = Debug.get_toggle "Unfolding" -let dbg_380 = Debug.get_toggle "380" -let dbg_WPE = Debug.get_toggle "WPE" -let dbg_NormDelayed = Debug.get_toggle "NormDelayed" -let dbg_print_normalized = Debug.get_toggle "print_normalized_terms" -let dbg_NBE = Debug.get_toggle "NBE" -let dbg_UNSOUND_EraseErasableArgs = Debug.get_toggle "UNSOUND_EraseErasableArgs" - -let config' psteps s e = - let d = s |> List.collect (function - | UnfoldUntil k -> [Env.Unfold k] - | Eager_unfolding -> [Env.Eager_unfolding_only] - | UnfoldQual l when List.contains "unfold" l -> - [Env.Eager_unfolding_only] - | Inlining -> [Env.InliningDelta] - | UnfoldQual l when List.contains "inline_for_extraction" l -> - [Env.InliningDelta] - | _ -> []) |> List.unique in - let d = match d with - | [] -> [Env.NoDelta] - | _ -> d in - let steps = to_fsteps s |> add_nbe in - let psteps = add_steps (merge_steps (env_dependent_ops e) (cached_steps ())) psteps in - let dbg_flag = List.contains NormDebug s in - { - tcenv = e; - debug = { - gen = !dbg_Norm || dbg_flag; - top = !dbg_NormTop || dbg_flag; - cfg = !dbg_NormCfg; - primop = !dbg_Primops; - unfolding = !dbg_Unfolding; - b380 = !dbg_380; - wpe = !dbg_WPE; - norm_delayed = !dbg_NormDelayed; - print_normalized = !dbg_print_normalized; - debug_nbe = !dbg_NBE; - erase_erasable_args = ( - if !dbg_UNSOUND_EraseErasableArgs then - Errors.log_issue e Errors.Warning_WarnOnUse - "The 'UNSOUND_EraseErasableArgs' setting is for debugging only; it is not sound"; - !dbg_UNSOUND_EraseErasableArgs); - }; - steps = steps; - delta_level = d; - primitive_steps = psteps; - strong = false; - memoize_lazy = true; - normalize_pure_lets = (not steps.pure_subterms_within_computations) || Options.normalize_pure_terms_for_extraction(); - reifying = false; - compat_memo_ignore_cfg = Options.Ext.get "compat:normalizer_memo_ignore_cfg" <> ""; - } - -let config s e = config' [] s e - -let should_reduce_local_let cfg lb = - if cfg.steps.do_not_unfold_pure_lets - then false //we're not allowed to do any local delta steps - else if cfg.steps.pure_subterms_within_computations && - U.has_attribute lb.lbattrs PC.inline_let_attr - then true //1. we're extracting, and it's marked @inline_let - else - let n = Env.norm_eff_name cfg.tcenv lb.lbeff in - if U.is_pure_effect n && - (cfg.normalize_pure_lets - || U.has_attribute lb.lbattrs PC.inline_let_attr) - then true //Or, 2. it's pure and we either not extracting, or it's marked @inline_let - else U.is_ghost_effect n && //Or, 3. it's ghost and we're not extracting - not (cfg.steps.pure_subterms_within_computations) - -let translate_norm_step = function - | Pervasives.Zeta -> [Zeta] - | Pervasives.ZetaFull -> [ZetaFull] - | Pervasives.Iota -> [Iota] - | Pervasives.Delta -> [UnfoldUntil delta_constant] - | Pervasives.Simpl -> [Simplify] - | Pervasives.Weak -> [Weak] - | Pervasives.HNF -> [HNF] - | Pervasives.Primops -> [Primops] - | Pervasives.Reify -> [Reify] - | Pervasives.NormDebug -> [NormDebug] - | Pervasives.UnfoldOnly names -> - [UnfoldUntil delta_constant; UnfoldOnly (List.map I.lid_of_str names)] - | Pervasives.UnfoldFully names -> - [UnfoldUntil delta_constant; UnfoldFully (List.map I.lid_of_str names)] - | Pervasives.UnfoldAttr names -> - [UnfoldUntil delta_constant; UnfoldAttr (List.map I.lid_of_str names)] - | Pervasives.UnfoldQual names -> - [UnfoldUntil delta_constant; UnfoldQual names] - | Pervasives.UnfoldNamespace names -> - [UnfoldUntil delta_constant; UnfoldNamespace names] - | Pervasives.Unascribe -> [Unascribe] - | Pervasives.NBE -> [NBE] - | Pervasives.Unmeta -> [Unmeta] - -let translate_norm_steps s = - let s = List.concatMap translate_norm_step s in - let add_exclude s z = if BU.for_some ((=?) z) s then s else Exclude z :: s in - let s = Beta::s in - let s = add_exclude s Zeta in - let s = add_exclude s Iota in - s diff --git a/src/typechecker/FStar.TypeChecker.Cfg.fsti b/src/typechecker/FStar.TypeChecker.Cfg.fsti deleted file mode 100644 index 1968cb21c88..00000000000 --- a/src/typechecker/FStar.TypeChecker.Cfg.fsti +++ /dev/null @@ -1,155 +0,0 @@ -(* - Copyright 2008-2014 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.TypeChecker.Cfg -open FStar.Compiler.Effect -open FStar -open FStar.Compiler -open FStar.Compiler.Util -open FStar.String -open FStar.Const -open FStar.Char -open FStar.Errors -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.Syntax.Subst -open FStar.Syntax.Util -open FStar.TypeChecker -open FStar.TypeChecker.Env -open FStar.TypeChecker.Primops - -open FStar.Class.Show -open FStar.Class.Deq - -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module BU = FStar.Compiler.Util -module FC = FStar.Const -module PC = FStar.Parser.Const -module U = FStar.Syntax.Util -module I = FStar.Ident -module EMB = FStar.Syntax.Embeddings -module Z = FStar.BigInt -module NBE = FStar.TypeChecker.NBETerm - -type fsteps = { - beta : bool; - iota : bool; - zeta : bool; - zeta_full : bool; - weak : bool; - hnf : bool; - primops : bool; - do_not_unfold_pure_lets : bool; - unfold_until : option S.delta_depth; - unfold_only : option (list I.lid); - unfold_fully : option (list I.lid); - unfold_attr : option (list I.lid); - unfold_qual : option (list string); - unfold_namespace: option (Path.forest string bool); - dont_unfold_attr : option (list I.lid); - pure_subterms_within_computations : bool; - simplify : bool; - erase_universes : bool; - allow_unbound_universes : bool; - reify_ : bool; // 'reify' is reserved - compress_uvars : bool; - no_full_norm : bool; - check_no_uvars : bool; - unmeta : bool; - unascribe : bool; - in_full_norm_request: bool; - weakly_reduce_scrutinee:bool; - nbe_step:bool; - for_extraction:bool; - unrefine:bool; - default_univs_to_zero:bool; (* Default unresolved universe levels to zero *) - tactics : bool; -} - -instance val deq_fsteps : deq fsteps - -val default_steps : fsteps -val fstep_add_one : step -> fsteps -> fsteps -val to_fsteps : list step -> fsteps - -type debug_switches = { - gen : bool; - top : bool; - cfg : bool; - primop : bool; - unfolding : bool; - b380 : bool; - wpe : bool; - norm_delayed : bool; - print_normalized : bool; - debug_nbe : bool; - erase_erasable_args: bool; -} - -val no_debug_switches : debug_switches - -type cfg = { - steps: fsteps; - tcenv: Env.env; - debug: debug_switches; - delta_level: list Env.delta_level; // Controls how much unfolding of definitions should be performed - primitive_steps:BU.psmap primitive_step; - strong : bool; // under a binder - memoize_lazy : bool; (* What exactly is this? Seems to be always true now. *) - normalize_pure_lets: bool; - reifying : bool; - compat_memo_ignore_cfg:bool; (* See #2155, #2161, #2986 *) -} - -(* Profiling primitive operators *) -val primop_time_reset : unit -> unit -val primop_time_count : string -> int -> unit -val primop_time_report : unit -> string - -val cfg_env: cfg -> Env.env - -instance val showable_cfg : showable cfg - -val log : cfg -> (unit -> unit) -> unit -val log_top : cfg -> (unit -> unit) -> unit -val log_cfg : cfg -> (unit -> unit) -> unit -val log_primops : cfg -> (unit -> unit) -> unit -val log_unfolding : cfg -> (unit -> unit) -> unit -val log_nbe : cfg -> (unit -> unit) -> unit - -val is_prim_step: cfg -> fv -> bool -val find_prim_step: cfg -> fv -> option primitive_step - -// val embed_simple: EMB.embedding 'a -> Range.range -> 'a -> term -// val try_unembed_simple: EMB.embedding 'a -> term -> option 'a - -val built_in_primitive_steps : BU.psmap primitive_step -val simplification_steps (env:Env.env_t): BU.psmap primitive_step - -val register_plugin : primitive_step -> unit -val register_extra_step : primitive_step -> unit - -(* for debugging *) -val list_plugins : unit -> list primitive_step -val list_extra_steps : unit -> list primitive_step - -val config': list primitive_step -> list step -> Env.env -> cfg -val config: list step -> Env.env -> cfg - -val should_reduce_local_let : cfg -> letbinding -> bool - -val translate_norm_steps: list Pervasives.norm_step -> list Env.step diff --git a/src/typechecker/FStar.TypeChecker.Common.fst b/src/typechecker/FStar.TypeChecker.Common.fst deleted file mode 100644 index 9f4fd677701..00000000000 --- a/src/typechecker/FStar.TypeChecker.Common.fst +++ /dev/null @@ -1,367 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.TypeChecker.Common -open Prims -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List - -open FStar -open FStar.Compiler -open FStar.Compiler.Util -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.Ident -module S = FStar.Syntax.Syntax -module Print = FStar.Syntax.Print -module U = FStar.Syntax.Util - -module BU = FStar.Compiler.Util -module PC = FStar.Parser.Const -module C = FStar.Parser.Const - - -let as_tprob = function - | TProb p -> p - | _ -> failwith "Expected a TProb" - -let mk_by_tactic tac f = - let t_by_tactic = S.mk_Tm_uinst (tabbrev C.by_tactic_lid) [U_zero] in - S.mk_Tm_app t_by_tactic [S.as_arg tac; S.as_arg f] Range.dummyRange - -let rec delta_depth_greater_than l m = match l, m with - | Delta_equational_at_level i, Delta_equational_at_level j -> i > j - | Delta_constant_at_level i, Delta_constant_at_level j -> i > j - | Delta_abstract d, _ -> delta_depth_greater_than d m - | _, Delta_abstract d -> delta_depth_greater_than l d - | Delta_equational_at_level _, _ -> true - | _, Delta_equational_at_level _ -> false - -let rec decr_delta_depth = function - | Delta_constant_at_level 0 - | Delta_equational_at_level 0 -> None - | Delta_constant_at_level i -> Some (Delta_constant_at_level (i - 1)) - | Delta_equational_at_level i -> Some (Delta_equational_at_level (i - 1)) - | Delta_abstract d -> decr_delta_depth d - -instance showable_guard_formula : showable guard_formula = { - show = (function - | Trivial -> "Trivial" - | NonTrivial f -> "NonTrivial " ^ show f) -} - -instance showable_deferred_reason : showable deferred_reason = { - show = (function - | Deferred_univ_constraint -> "Deferred_univ_constraint" - | Deferred_occur_check_failed -> "Deferred_occur_check_failed" - | Deferred_first_order_heuristic_failed -> "Deferred_first_order_heuristic_failed" - | Deferred_flex -> "Deferred_flex" - | Deferred_free_names_check_failed -> "Deferred_free_names_check_failed" - | Deferred_not_a_pattern -> "Deferred_not_a_pattern" - | Deferred_flex_flex_nonpattern -> "Deferred_flex_flex_nonpattern" - | Deferred_delay_match_heuristic -> "Deferred_delay_match_heuristic" - | Deferred_to_user_tac -> "Deferred_to_user_tac" - ); -} -(***********************************************************************************) -(* A table of file -> starting row -> starting col -> identifier info *) -(* Used to support querying information about an identifier in interactive mode *) -(* The table provides: *) -(* -- the full name of the identifier *) -(* -- the source range of its use *) -(* -- the source range of its defining occurrence *) -(* -- its type *) -(***********************************************************************************) - -let insert_col_info (col:int) (info:identifier_info) (col_infos:list (int & identifier_info)) = - // Tail recursive helper - let rec __insert aux rest = - match rest with - | [] -> (aux, [col, info]) - | (c,i)::rest' -> - if col < c - then (aux, (col, info)::rest) - else __insert ((c,i)::aux) rest' - in - let l, r = __insert [] col_infos - in (List.rev l) @ r - -let find_nearest_preceding_col_info (col:int) (col_infos:list (int & identifier_info)) = - let rec aux out = function - | [] -> out - | (c, i)::rest -> - if c > col then out - else aux (Some i) rest - in - aux None col_infos - -let id_info_table_empty = - { id_info_enabled = false; - id_info_db = BU.psmap_empty (); - id_info_buffer = [] } - -open FStar.Compiler.Range - -let print_identifier_info info = - BU.format3 "id info { %s, %s : %s}" - (Range.string_of_range info.identifier_range) - (match info.identifier with - | Inl x -> show x - | Inr fv -> show fv) - (show info.identifier_ty) - -let id_info__insert ty_map db info = - let range = info.identifier_range in - let use_range = Range.set_def_range range (Range.use_range range) in - let id_ty = - match info.identifier with - | Inr _ -> - ty_map info.identifier_ty - | Inl x -> - ty_map info.identifier_ty - in - match id_ty with - | None -> db - | Some id_ty -> - let info = { info with identifier_range = use_range; - identifier_ty = id_ty } in - - let fn = file_of_range use_range in - let start = start_of_range use_range in - let row, col = line_of_pos start, col_of_pos start in - - let rows = BU.psmap_find_default db fn (BU.pimap_empty ()) in - let cols = BU.pimap_find_default rows row [] in - - insert_col_info col info cols - |> BU.pimap_add rows row - |> BU.psmap_add db fn - -let id_info_insert table id ty range = - let info = { identifier = id; identifier_ty = ty; identifier_range = range} in - { table with id_info_buffer = info :: table.id_info_buffer } - -let id_info_insert_bv table bv ty = - if table.id_info_enabled then id_info_insert table (Inl bv) ty (range_of_bv bv) - else table - -let id_info_insert_fv table fv ty = - if table.id_info_enabled then id_info_insert table (Inr fv) ty (range_of_fv fv) - else table - -let id_info_toggle table enabled = - { table with id_info_enabled = enabled } - -let id_info_promote table ty_map = - { table with - id_info_buffer = []; - id_info_db = List.fold_left (id_info__insert ty_map) - table.id_info_db table.id_info_buffer } - -let id_info_at_pos (table: id_info_table) (fn:string) (row:int) (col:int) : option identifier_info = - let rows = BU.psmap_find_default table.id_info_db fn (BU.pimap_empty ()) in - let cols = BU.pimap_find_default rows row [] in - - match find_nearest_preceding_col_info col cols with - | None -> None - | Some info -> - let last_col = col_of_pos (end_of_range info.identifier_range) in - if col <= last_col then Some info else None - -let check_uvar_ctx_invariant (reason:string) (r:range) (should_check:bool) (g:gamma) (bs:binders) = - let fail () = - failwith (BU.format5 - "Invariant violation: gamma and binders are out of sync\n\t\ - reason=%s, range=%s, should_check=%s\n\t - gamma=%s\n\t\ - binders=%s\n" - reason - (Range.string_of_range r) - (if should_check then "true" else "false") - (show g) - (show bs)) - in - if not should_check then () - else match BU.prefix_until (function Binding_var _ -> true | _ -> false) g, bs with - | None, [] -> () - | Some (_, hd, gamma_tail), _::_ -> - let _, x = BU.prefix bs in - begin - match hd with - | Binding_var x' when S.bv_eq x.binder_bv x' -> - () - | _ -> fail() - end - | _ -> fail() - -instance showable_implicit : showable implicit = { - show = (fun i -> show i.imp_uvar.ctx_uvar_head); -} - -let implicits_to_string imps = - let imp_to_string i = show i.imp_uvar.ctx_uvar_head in - FStar.Common.string_of_list imp_to_string imps - -let trivial_guard = - let open FStar.Class.Listlike in - { - guard_f=Trivial; - deferred_to_tac=empty; - deferred=empty; - univ_ineqs=(empty, empty); - implicits=empty; - } - -let conj_guard_f g1 g2 = match g1, g2 with - | Trivial, g - | g, Trivial -> g - | NonTrivial f1, NonTrivial f2 -> NonTrivial (U.mk_conj f1 f2) - -let binop_guard f g1 g2 = { - guard_f=f g1.guard_f g2.guard_f; - deferred_to_tac=g1.deferred_to_tac ++ g2.deferred_to_tac; - deferred=g1.deferred ++ g2.deferred; - univ_ineqs=(fst g1.univ_ineqs ++ fst g2.univ_ineqs, - snd g1.univ_ineqs ++ snd g2.univ_ineqs); - implicits=g1.implicits ++ g2.implicits; -} -let conj_guard g1 g2 = binop_guard conj_guard_f g1 g2 - -instance monoid_guard_t : monoid guard_t = { - mzero = trivial_guard; - mplus = conj_guard; -} - -let rec check_trivial (t:term) : guard_formula = - let hd, args = U.head_and_args (U.unmeta t) in - match (U.un_uinst (U.unmeta hd)).n, args with - | Tm_fvar tc, [] - when S.fv_eq_lid tc PC.true_lid -> - Trivial - - | Tm_fvar sq, [v, _] - when S.fv_eq_lid sq PC.squash_lid - || S.fv_eq_lid sq PC.auto_squash_lid -> - (match check_trivial v with - | Trivial -> Trivial - | _ -> NonTrivial t) - - | _ -> NonTrivial t - -let imp_guard_f g1 g2 = match g1, g2 with - | Trivial, g -> g - | g, Trivial -> Trivial - | NonTrivial f1, NonTrivial f2 -> - let imp = U.mk_imp f1 f2 in check_trivial imp - -let imp_guard g1 g2 = binop_guard imp_guard_f g1 g2 - -let conj_guards gs = List.fold_left conj_guard trivial_guard gs -let split_guard g = - {g with guard_f = Trivial}, - {trivial_guard with guard_f = g.guard_f} - -let weaken_guard_formula g fml = - match g.guard_f with - | Trivial -> g - | NonTrivial f -> - { g with guard_f = check_trivial (U.mk_imp fml f) } - - -let mk_lcomp eff_name res_typ cflags comp_thunk = - { eff_name = eff_name; - res_typ = res_typ; - cflags = cflags; - comp_thunk = FStar.Compiler.Util.mk_ref (Inl comp_thunk) } - -let lcomp_comp lc = - match !(lc.comp_thunk) with - | Inl thunk -> - let c, g = thunk () in - lc.comp_thunk := Inr c; - c, g - | Inr c -> c, trivial_guard - -let apply_lcomp fc fg lc = - mk_lcomp - lc.eff_name lc.res_typ lc.cflags - (fun () -> - let (c, g) = lcomp_comp lc in - fc c, fg g) - -let lcomp_to_string lc = - if Options.print_effect_args () then - show (lc |> lcomp_comp |> fst) - else - BU.format2 "%s %s" (show lc.eff_name) (show lc.res_typ) - -let lcomp_set_flags lc fs = - let comp_typ_set_flags (c:comp) = - match c.n with - | Total _ - | GTotal _ -> c - | Comp ct -> - let ct = {ct with flags=fs} in - {c with n=Comp ct} - in - mk_lcomp lc.eff_name - lc.res_typ - fs - (fun () -> lc |> lcomp_comp |> (fun (c, g) -> comp_typ_set_flags c, g)) - -let is_total_lcomp c = lid_equals c.eff_name PC.effect_Tot_lid || c.cflags |> BU.for_some (function TOTAL | RETURN -> true | _ -> false) - -let is_tot_or_gtot_lcomp c = lid_equals c.eff_name PC.effect_Tot_lid - || lid_equals c.eff_name PC.effect_GTot_lid - || c.cflags |> BU.for_some (function TOTAL | RETURN -> true | _ -> false) - -let is_lcomp_partial_return c = c.cflags |> BU.for_some (function RETURN | PARTIAL_RETURN -> true | _ -> false) - -let is_pure_lcomp lc = - is_total_lcomp lc - || U.is_pure_effect lc.eff_name - || lc.cflags |> BU.for_some (function LEMMA -> true | _ -> false) - -let is_pure_or_ghost_lcomp lc = - is_pure_lcomp lc || U.is_ghost_effect lc.eff_name - -let set_result_typ_lc lc t = - mk_lcomp lc.eff_name t lc.cflags (fun () -> lc |> lcomp_comp |> (fun (c, g) -> U.set_result_typ c t, g)) - -let residual_comp_of_lcomp lc = { - residual_effect=lc.eff_name; - residual_typ=Some (lc.res_typ); - residual_flags=lc.cflags - } - -let lcomp_of_comp_guard c0 g = - let eff_name, flags = - match c0.n with - | Total _ -> PC.effect_Tot_lid, [TOTAL] - | GTotal _ -> PC.effect_GTot_lid, [SOMETRIVIAL] - | Comp c -> c.effect_name, c.flags in - mk_lcomp eff_name (U.comp_result c0) flags (fun () -> c0, g) - -let lcomp_of_comp c0 = lcomp_of_comp_guard c0 trivial_guard - -let check_positivity_qual subtyping p0 p1 - = if p0 = p1 then true - else if subtyping - then match p0, p1 with - | Some _, None -> true - | Some BinderUnused, Some BinderStrictlyPositive -> true - | _ -> false - else false diff --git a/src/typechecker/FStar.TypeChecker.Common.fsti b/src/typechecker/FStar.TypeChecker.Common.fsti deleted file mode 100644 index 922ef60c010..00000000000 --- a/src/typechecker/FStar.TypeChecker.Common.fsti +++ /dev/null @@ -1,217 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.TypeChecker.Common -open Prims -open FStar.Pervasives -open FStar.Compiler.Effect - -open FStar -open FStar.Compiler -open FStar.Compiler.Util -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.Ident -open FStar.Class.Show -open FStar.Class.Monoid - -open FStar.Compiler.CList -module CList = FStar.Compiler.CList - -(* Bring instances in scope *) -open FStar.Syntax.Print {} - -module S = FStar.Syntax.Syntax - -module BU = FStar.Compiler.Util - -(* relations on types, kinds, etc. *) -type rel = - | EQ - | SUB - | SUBINV (* sub-typing/sub-kinding, inverted *) - -type rank_t = - | Rigid_rigid - | Flex_rigid_eq - | Flex_flex_pattern_eq - | Flex_rigid - | Rigid_flex - | Flex_flex - -type problem 'a = { //Try to prove: lhs rel rhs ~ guard - pid:int; - lhs:'a; - relation:rel; - rhs:'a; - element:option bv; //where, guard is a predicate on this term (which appears free in/is a subterm of the guard) - logical_guard:term; //the condition under which this problem is solveable; (?u v1..vn) - logical_guard_uvar:ctx_uvar; - reason: list string; //why we generated this problem, for error reporting - loc: Range.range; //and the source location where this arose - rank: option rank_t; - logical : bool; //logical problems cannot unfold connectives -} - -type prob = - | TProb of problem typ - | CProb of problem comp -type prob_t = prob - -val as_tprob : prob -> problem typ - -type probs = list prob - -type guard_formula = - | Trivial - | NonTrivial of formula - -instance val showable_guard_formula : showable guard_formula - -type deferred_reason = - | Deferred_univ_constraint - | Deferred_occur_check_failed - | Deferred_first_order_heuristic_failed - | Deferred_flex - | Deferred_free_names_check_failed - | Deferred_not_a_pattern - | Deferred_flex_flex_nonpattern - | Deferred_delay_match_heuristic - | Deferred_to_user_tac - -instance val showable_deferred_reason : showable deferred_reason - -type deferred = clist (deferred_reason & string & prob) - -type univ_ineq = universe & universe - -(***********************************************************************************) -(* A table of file -> starting row -> starting col -> identifier info *) -(* Used to support querying information about an identifier in interactive mode *) -(* The table provides: *) -(* -- the full name of the identifier *) -(* -- the source range of its use *) -(* -- the source range of its defining occurrence *) -(* -- its type *) -(***********************************************************************************) - -type identifier_info = { - identifier:either bv fv; - identifier_ty:typ; - identifier_range:Range.range; -} - -type id_info_by_col = //sorted in ascending order of columns - list (int & identifier_info) - -type col_info_by_row = - BU.pimap id_info_by_col - -type row_info_by_file = - BU.psmap col_info_by_row - -type id_info_table = { - id_info_enabled: bool; - id_info_db: row_info_by_file; - id_info_buffer: list identifier_info; -} - -val check_uvar_ctx_invariant : string -> Range.range -> bool -> gamma -> binders -> unit - -val mk_by_tactic : term -> term -> term - -val delta_depth_greater_than : delta_depth -> delta_depth -> bool -val decr_delta_depth : delta_depth -> option delta_depth - -val insert_col_info : int -> identifier_info -> list (int & identifier_info) -> list (int & identifier_info) -val find_nearest_preceding_col_info : int -> list (int & identifier_info) -> option identifier_info - -val id_info_table_empty : id_info_table - -val id_info_insert_bv : id_info_table -> bv -> typ -> id_info_table -val id_info_insert_fv : id_info_table -> fv -> typ -> id_info_table -val id_info_toggle : id_info_table -> bool -> id_info_table -val id_info_promote : id_info_table -> (typ -> option typ) -> id_info_table -val id_info_at_pos : id_info_table -> string -> int -> int -> option identifier_info - -// Reason, term and uvar, and (rough) position where it is introduced -// The term is just a Tm_uvar of the ctx_uvar -type implicit = { - imp_reason : string; // Reason (in text) why the implicit was introduced - imp_uvar : ctx_uvar; // The ctx_uvar representing it - imp_tm : term; // The term, made up of the ctx_uvar - imp_range : Range.range; // Position where it was introduced -} - -instance val showable_implicit : showable implicit - -(* Bad naming here *) -type implicits = list implicit -val implicits_to_string : implicits -> string -type implicits_t = CList.t implicit - -type guard_t = { - guard_f: guard_formula; - deferred_to_tac: deferred; //This field maintains problems that are to be dispatched to a tactic - //They are never attempted by the unification engine in Rel - deferred: deferred; - univ_ineqs: clist universe & clist univ_ineq; - implicits: implicits_t; -} - -val trivial_guard : guard_t -val conj_guard : guard_t -> guard_t -> guard_t - -instance val monoid_guard_t : monoid guard_t (* conj_guard, trivial_guard *) - -val check_trivial : term -> guard_formula -val imp_guard : guard_t -> guard_t -> guard_t -val conj_guards : list guard_t -> guard_t - -// splits the guard into the logical component (snd in the returned tuple) -// and the rest (fst in the returned tuple) -val split_guard : guard_t -> guard_t & guard_t - -val weaken_guard_formula: guard_t -> typ -> guard_t -type lcomp = { //a lazy computation - eff_name: lident; - res_typ: typ; - cflags: list cflag; - comp_thunk: ref (either (unit -> (comp & guard_t)) comp) -} - -val mk_lcomp: - eff_name: lident -> - res_typ: typ -> - cflags: list cflag -> - comp_thunk: (unit -> (comp & guard_t)) -> lcomp - -val lcomp_comp: lcomp -> (comp & guard_t) -val apply_lcomp : (comp -> comp) -> (guard_t -> guard_t) -> lcomp -> lcomp -val lcomp_to_string : lcomp -> string (* CAUTION! can have side effects of forcing the lcomp *) -val lcomp_set_flags : lcomp -> list S.cflag -> lcomp -val is_total_lcomp : lcomp -> bool -val is_tot_or_gtot_lcomp : lcomp -> bool -val is_lcomp_partial_return : lcomp -> bool -val is_pure_lcomp : lcomp -> bool -val is_pure_or_ghost_lcomp : lcomp -> bool -val set_result_typ_lc : lcomp -> typ -> lcomp -val residual_comp_of_lcomp : lcomp -> residual_comp -val lcomp_of_comp_guard : comp -> guard_t -> lcomp -//lcomp_of_comp_guard with trivial guard -val lcomp_of_comp : comp -> lcomp - -val check_positivity_qual (subtyping:bool) (p0 p1:option positivity_qualifier) - : bool diff --git a/src/typechecker/FStar.TypeChecker.Core.fst b/src/typechecker/FStar.TypeChecker.Core.fst deleted file mode 100644 index b85c39de4a7..00000000000 --- a/src/typechecker/FStar.TypeChecker.Core.fst +++ /dev/null @@ -1,1980 +0,0 @@ -module FStar.TypeChecker.Core -open FStar.List.Tot -open FStar.Compiler -open FStar.Compiler.Util -open FStar.Compiler.Effect -open FStar.Syntax.Syntax -module Env = FStar.TypeChecker.Env -module S = FStar.Syntax.Syntax -module R = FStar.Compiler.Range -module U = FStar.Syntax.Util -module N = FStar.TypeChecker.Normalize -module PC = FStar.Parser.Const -module I = FStar.Ident -module P = FStar.Syntax.Print -module BU = FStar.Compiler.Util -module TcUtil = FStar.TypeChecker.Util -module Hash = FStar.Syntax.Hash -module Subst = FStar.Syntax.Subst -module TEQ = FStar.TypeChecker.TermEqAndSimplify - -open FStar.Class.Show -open FStar.Class.Setlike -open FStar.Class.Tagged - -let dbg = Debug.get_toggle "Core" -let dbg_Eq = Debug.get_toggle "CoreEq" -let dbg_Top = Debug.get_toggle "CoreTop" -let dbg_Exit = Debug.get_toggle "CoreExit" - -let goal_ctr = BU.mk_ref 0 -let get_goal_ctr () = !goal_ctr -let incr_goal_ctr () = let v = !goal_ctr in goal_ctr := v + 1; v + 1 - -let guard_handler_t = Env.env -> typ -> bool - -type env = { - tcenv : Env.env; - allow_universe_instantiation : bool; - max_binder_index : int; - guard_handler : option guard_handler_t; - should_read_cache: bool -} - -let push_binder g b = - if b.binder_bv.index <= g.max_binder_index - then failwith "Assertion failed: unexpected shadowing in the core environment" - else { g with tcenv = Env.push_binders g.tcenv [b]; max_binder_index = b.binder_bv.index } - -let push_binders = List.fold_left push_binder - -let fresh_binder (g:env) (old:binder) - : env & binder - = let ctr = g.max_binder_index + 1 in - let bv = { old.binder_bv with index = ctr } in - let b = S.mk_binder_with_attrs bv old.binder_qual old.binder_positivity old.binder_attrs in - push_binder g b, b - -let open_binders (g:env) (bs:binders) - = let g, bs_rev, subst = - List.fold_left - (fun (g, bs, subst) b -> - let bv = { b.binder_bv with sort = Subst.subst subst b.binder_bv.sort } in - let b = { binder_bv = bv; - binder_qual = Subst.subst_bqual subst b.binder_qual; - binder_positivity = b.binder_positivity; - binder_attrs = List.map (Subst.subst subst) b.binder_attrs } in - let g, b' = fresh_binder g b in - g, b'::bs, DB(0, b'.binder_bv)::Subst.shift_subst 1 subst) - (g, [], []) - bs - in - g, List.rev bs_rev, subst - -let open_pat (g:env) (p:pat) - : env & pat & subst_t - = let rec open_pat_aux g p sub = - match p.v with - | Pat_constant _ -> g, p, sub - - | Pat_cons(fv, us_opt, pats) -> - let g, pats, sub = - List.fold_left - (fun (g, pats, sub) (p, imp) -> - let g, p, sub = open_pat_aux g p sub in - (g, (p,imp)::pats, sub)) - (g, [], sub) - pats - in - g, {p with v=Pat_cons(fv, us_opt, List.rev pats)}, sub - - | Pat_var x -> - let bx = S.mk_binder {x with sort = Subst.subst sub x.sort} in - let g, bx' = fresh_binder g bx in - let sub = DB(0, bx'.binder_bv)::Subst.shift_subst 1 sub in - g, {p with v=Pat_var bx'.binder_bv}, sub - - | Pat_dot_term eopt -> - let eopt = BU.map_option (Subst.subst sub) eopt in - g, {p with v=Pat_dot_term eopt}, sub - in - open_pat_aux g p [] - - -let open_term (g:env) (b:binder) (t:term) - : env & binder & term - = let g, b' = fresh_binder g b in - let t = FStar.Syntax.Subst.subst [DB(0, b'.binder_bv)] t in - g, b', t - -let open_term_binders (g:env) (bs:binders) (t:term) - : env & binders & term - = let g, bs, subst = open_binders g bs in - g, bs, Subst.subst subst t - -let open_comp (g:env) (b:binder) (c:comp) - : env & binder & comp - = let g, bx = fresh_binder g b in - let c = FStar.Syntax.Subst.subst_comp [DB(0, bx.binder_bv)] c in - g, bx, c - -let open_comp_binders (g:env) (bs:binders) (c:comp) - : env & binders & comp - = let g, bs, s = open_binders g bs in - let c = FStar.Syntax.Subst.subst_comp s c in - g, bs, c - -let arrow_formals_comp g c = - let bs, c = U.arrow_formals_comp_ln c in - let g, bs, subst = open_binders g bs in - g, bs, Subst.subst_comp subst c - -let open_branch (g:env) (br:S.branch) - : env & branch - = let (p, wopt, e) = br in - let g, p, s = open_pat g p in - g, (p, BU.map_option (Subst.subst s) wopt, Subst.subst s e) - -//br0 and br1 are expected to have equal patterns -let open_branches_eq_pat (g:env) (br0 br1:S.branch) - = let (p0, wopt0, e0) = br0 in - let (_, wopt1, e1) = br1 in - let g, p0, s = open_pat g p0 in - g, - (p0, BU.map_option (Subst.subst s) wopt0, Subst.subst s e0), - (p0, BU.map_option (Subst.subst s) wopt1, Subst.subst s e1) - -let precondition = option typ - -let success a = a & precondition - -type relation = - | EQUALITY - | SUBTYPING : option term -> relation - -let relation_to_string = function - | EQUALITY -> "=?=" - | SUBTYPING None -> "<:?" - | SUBTYPING (Some tm) -> BU.format1 "( <:? %s)" (show tm) - -type context_term = - | CtxTerm : term -> context_term - | CtxRel : term -> relation -> term -> context_term - -let context_term_to_string (c:context_term) = - match c with - | CtxTerm term -> show term - | CtxRel t0 r t1 -> - BU.format3 "%s %s %s" - (show t0) - (relation_to_string r) - (show t1) - -type context = { - no_guard : bool; - unfolding_ok : bool; - error_context: list (string & option context_term) -} - -(* The instance prints some brief info on the error_context. `print_context` -below is a full printer. *) -instance showable_context : showable context = { - show = (fun context -> BU.format3 "{no_guard=%s; unfolding_ok=%s; error_context=%s}" - (show context.no_guard) - (show context.unfolding_ok) - (show (List.map fst context.error_context))); -} - -let print_context (ctx:context) - : string = - let rec aux (depth:string) (ctx:_) = - match ctx with - | [] -> "" - | (msg, ctx_term)::tl -> - let hd = - BU.format3 - "%s %s (%s)\n" - depth - msg - (match ctx_term with None -> "" | Some ctx_term -> context_term_to_string ctx_term) - in - let tl = aux (depth ^ ">") tl in - hd ^ tl - in - aux "" (List.rev ctx.error_context) - -let error = context & string - -let print_error (err:error) = - let ctx, msg = err in - BU.format2 "%s%s" (print_context ctx) msg - -let print_error_short (err:error) = snd err - -type __result a = - | Success of a - | Error of error - -instance showable_result #a (_ : showable a) : Tot (showable (__result a)) = { - show = (function - | Success a -> "Success " ^ show a - | Error e -> "Error " ^ print_error_short e); -} - -let result a = context -> __result (success a) - -type hash_entry = { - he_term:term; - he_gamma:list binding; - he_res:success (tot_or_ghost & typ); -} -module THT = FStar.Syntax.TermHashTable -type tc_table = THT.hashtable hash_entry -let equal_term_for_hash t1 t2 = - Profiling.profile (fun _ -> Hash.equal_term t1 t2) None "FStar.TypeChecker.Core.equal_term_for_hash" -let equal_term t1 t2 = - Profiling.profile (fun _ -> Hash.equal_term t1 t2) None "FStar.TypeChecker.Core.equal_term" -let table : tc_table = THT.create 1048576 //2^20 -type cache_stats_t = { hits : int; misses : int } -let cache_stats = Util.mk_ref { hits = 0; misses = 0 } -let record_cache_hit () = - let cs = !cache_stats in - cache_stats := { cs with hits = cs.hits + 1 } -let record_cache_miss () = - let cs = !cache_stats in - cache_stats := { cs with misses = cs.misses + 1 } -let reset_cache_stats () = - cache_stats := { hits = 0; misses = 0 } -let report_cache_stats () = !cache_stats -let clear_memo_table () = THT.clear table -let insert (g:env) (e:term) (res:success (tot_or_ghost & typ)) = - let entry = { - he_term = e; - he_gamma = g.tcenv.gamma; - he_res = res - } - in - THT.insert e entry table - -inline_for_extraction -let return (#a:Type) (x:a) : result a = fun _ -> Success (x, None) - -let and_pre (p1 p2:precondition) = - match p1, p2 with - | None, None -> None - | Some p, None - | None, Some p -> Some p - | Some p1, Some p2 -> Some (U.mk_conj p1 p2) - -inline_for_extraction -let (let!) (#a:Type) (#b:Type) (x:result a) (y:a -> result b) - : result b - = fun ctx0 -> - match x ctx0 with - | Success (x, g1) -> - (match y x ctx0 with - | Success (y, g2) -> Success (y, and_pre g1 g2) - | err -> err) - | Error err -> Error err - -inline_for_extraction -let (and!) (#a:Type) (#b:Type) (x:result a) (y:result b) - : result (a & b) - = let! v = x in - let! u = y in - return (v, u) - -let (let?) (#a:Type) (#b:Type) (x:option a) (f: a -> option b) - : option b - = match x with - | None -> None - | Some x -> f x - -let fail #a msg : result a = fun ctx -> Error (ctx, msg) - -let dump_context - : result unit - = fun ctx -> - BU.print_string (print_context ctx); - return () ctx - -inline_for_extraction -let handle_with (#a:Type) (x:result a) (h: unit -> result a) - : result a - = fun ctx -> - match x ctx with - | Error _ -> h () ctx - | res -> res - -inline_for_extraction -let with_context (#a:Type) (msg:string) (t:option context_term) (x:unit -> result a) - : result a - = fun ctx -> - let ctx = { ctx with error_context=((msg,t)::ctx.error_context) } in - x () ctx - -let mk_type (u:universe) = S.mk (Tm_type u) R.dummyRange - -let is_type (g:env) (t:term) - : result universe - = let aux t = - match (Subst.compress t).n with - | Tm_type u -> - return u - - | _ -> - fail (BU.format1 "Expected a type; got %s" (show t)) - in - with_context "is_type" (Some (CtxTerm t)) (fun _ -> - handle_with - (aux t) - (fun _ -> aux (U.unrefine (N.unfold_whnf g.tcenv t)))) - -let rec is_arrow (g:env) (t:term) - : result (binder & tot_or_ghost & typ) - = let rec aux t = - match (Subst.compress t).n with - | Tm_arrow {bs=[x]; comp=c} -> - if U.is_tot_or_gtot_comp c - then - let g, x, c = open_comp g x c in - let eff = - if U.is_total_comp c - then E_Total - else E_Ghost - in - return (x, eff, U.comp_result c) - else ( - let e_tag = - let Comp ct = c.n in - if Ident.lid_equals ct.effect_name PC.effect_Pure_lid || - Ident.lid_equals ct.effect_name PC.effect_Lemma_lid - then Some E_Total - else if Ident.lid_equals ct.effect_name PC.effect_Ghost_lid - then Some E_Ghost - else None - in - (* Turn x:t -> Pure/Ghost t' pre post - into x:t{pre} -> Tot/GTot (y:t'{post}) - - This is ok for pre. - But, it loses precision for post. - In effect form, the post is in scope for the entire continuation. - Whereas the refinement on the result is not. - *) - match e_tag with - | None -> fail (BU.format1 "Expected total or gtot arrow, got %s" (Ident.string_of_lid (U.comp_effect_name c))) - | Some e_tag -> - let g, [x], c = arrow_formals_comp g t in - let (pre, _)::(post, _)::_ = U.comp_effect_args c in - let arg_typ = U.refine x.binder_bv pre in - let res_typ = - let r = S.new_bv None (U.comp_result c) in - let post = S.mk_Tm_app post [(S.bv_to_name r, None)] post.pos in - U.refine r post - in - let xbv = { x.binder_bv with sort = arg_typ } in - let x = { x with binder_bv = xbv } in - return (x, e_tag, res_typ) - ) - - | Tm_arrow {bs=x::xs; comp=c} -> - let t = S.mk (Tm_arrow {bs=xs; comp=c}) t.pos in - let g, x, t = open_term g x t in - return (x, E_Total, t) - - | Tm_refine {b=x} -> - is_arrow g x.sort - - | Tm_meta {tm=t} - | Tm_ascribed {tm=t} -> - aux t - - | _ -> - fail (BU.format2 "Expected an arrow, got (%s) %s" (tag_of t) (show t)) - in - with_context "is_arrow" None (fun _ -> - handle_with - (aux t) - (fun _ -> aux (N.unfold_whnf g.tcenv t))) - -let check_arg_qual (a:aqual) (b:bqual) - : result unit - = match b with - | Some (Implicit _) - | Some (Meta _) -> - begin - match a with - | Some ({aqual_implicit=true}) -> - return () - | _ -> - fail "missing arg qualifier implicit" - end - - | _ -> - begin - match a with - | Some ({aqual_implicit=true}) -> - fail "extra arg qualifier implicit" - | _ -> return () - end - -let check_bqual (b0 b1:bqual) - : result unit - = match b0, b1 with - | None, None -> return () - | Some (Implicit b0), Some (Implicit b1) -> - //we don't care about the inaccessibility qualifier - //when comparing bquals - return () - | Some Equality, Some Equality -> - return () - | Some (Meta t1), Some (Meta t2) -> - if equal_term t1 t2 - then return () - else fail "Binder qualifier mismatch" - | _ -> - fail "Binder qualifier mismatch" - -let check_aqual (a0 a1:aqual) - : result unit - = match a0, a1 with - | None, None -> return () - | Some ({aqual_implicit=b0}), Some ({aqual_implicit=b1}) -> - if b0 = b1 - then return () - else fail (BU.format2 "Unequal arg qualifiers: lhs implicit=%s and rhs implicit=%s" - (string_of_bool b0) (string_of_bool b1)) - | None, Some { aqual_implicit=false } - | Some { aqual_implicit=false }, None -> - return () - | _ -> - fail (BU.format2 "Unequal arg qualifiers: lhs %s and rhs %s" - (show a0) (show a1)) - -let check_positivity_qual (rel:relation) (p0 p1:option positivity_qualifier) - : result unit - = if FStar.TypeChecker.Common.check_positivity_qual (SUBTYPING? rel) p0 p1 - then return () - else fail "Unequal positivity qualifiers" - -let mk_forall_l (us:universes) (xs:binders) (t:term) - : term - = FStar.Compiler.List.fold_right2 - (fun u x t -> U.mk_forall u x.binder_bv t) - us - xs - t - -let close_guard (xs:binders) (us:universes) (g:precondition) - : precondition - = match g with - | None -> None - | Some t -> Some (mk_forall_l us xs t) - -let close_guard_with_definition (x:binder) (u:universe) (t:term) (g:precondition) - : precondition - = match g with - | None -> None - | Some t -> - Some ( - let t = U.mk_imp (U.mk_eq2 u x.binder_bv.sort (S.bv_to_name x.binder_bv) t) t in - U.mk_forall u x.binder_bv t - ) - -let with_binders (#a:Type) (xs:binders) (us:universes) (f:result a) - : result a - = fun ctx -> - match f ctx with - | Success (t, g) -> Success (t, close_guard xs us g) - | err -> err - -let with_definition (#a:Type) (x:binder) (u:universe) (t:term) (f:result a) - : result a - = fun ctx -> - match f ctx with - | Success (a, g) -> Success (a, close_guard_with_definition x u t g) - | err -> err - -let guard (t:typ) - : result unit - = fun _ -> Success ((), Some t) - -let abs (a:typ) (f: binder -> term) : term = - let x = S.new_bv None a in - let xb = S.mk_binder x in - U.abs [xb] (f xb) None - -let weaken_subtyping_guard (p:term) - (g:precondition) - : precondition - = BU.map_opt g (fun q -> U.mk_imp p q) - -let strengthen_subtyping_guard (p:term) - (g:precondition) - : precondition - = Some (BU.dflt p (BU.map_opt g (fun q -> U.mk_conj p q))) - -let weaken (p:term) (g:result 'a) - = fun ctx -> - match g ctx with - | Success (x, q) -> Success (x, weaken_subtyping_guard p q) - | err -> err - -let weaken_with_guard_formula (p:FStar.TypeChecker.Common.guard_formula) (g:result 'a) - = match p with - | Common.Trivial -> g - | Common.NonTrivial p -> weaken p g - -let push_hypothesis (g:env) (h:term) = - let bv = S.new_bv (Some h.pos) h in - let b = S.mk_binder bv in - fst (fresh_binder g b) - -let strengthen (p:term) (g:result 'a) - = fun ctx -> - match g ctx with - | Success (x, q) -> Success (x, strengthen_subtyping_guard p q) - | err -> err - -let no_guard (g:result 'a) - : result 'a - = fun ctx -> - match g ({ ctx with no_guard = true}) with - | Success (x, None) -> Success (x, None) - | Success (x, Some g) -> fail (BU.format1 "Unexpected guard: %s" (show g)) ctx - | err -> err - -let equatable g t = - t |> U.leftmost_head |> Rel.may_relate_with_logical_guard g.tcenv true - -let apply_predicate x p = fun e -> Subst.subst [NT(x.binder_bv, e)] p - -let curry_arrow (x:binder) (xs:binders) (c:comp) = - let tail = S.mk (Tm_arrow {bs=xs; comp=c}) R.dummyRange in - S.mk (Tm_arrow {bs=[x]; comp=S.mk_Total tail}) R.dummyRange - -let curry_abs (b0:binder) (b1:binder) (bs:binders) (body:term) (ropt: option residual_comp) = - let tail = S.mk (Tm_abs {bs=b1::bs; body; rc_opt=ropt}) body.pos in - S.mk (Tm_abs {bs=[b0]; body=tail; rc_opt=None}) body.pos - -let is_gtot_comp c = U.is_tot_or_gtot_comp c && not (U.is_total_comp c) - -let rec context_included (g0 g1: list binding) = - if BU.physical_equality g0 g1 then true else - match g0, g1 with - | [], _ -> true - - | b0::g0', b1::g1' -> - begin - match b0, b1 with - | Binding_var x0, Binding_var x1 -> - if x0.index = x1.index - then equal_term x0.sort x1.sort - && context_included g0' g1' - else context_included g0 g1' - - | Binding_lid _, Binding_lid _ - | Binding_univ _, Binding_univ _ -> - true - - | _ -> - false - end - - | _ -> false - -let curry_application hd arg args p = - let head = S.mk (Tm_app {hd; args=[arg]}) p in - let t = S.mk (Tm_app {hd=head; args}) p in - t - - -let lookup (g:env) (e:term) : result (tot_or_ghost & typ) = - match THT.lookup e table with - | None -> - record_cache_miss (); - fail "not in cache" - | Some he -> - if he.he_gamma `context_included` g.tcenv.gamma - then ( - record_cache_hit(); - if !dbg then - BU.print4 "cache hit\n %s |- %s : %s\nmatching env %s\n" - (show g.tcenv.gamma) - (show e) - (show (snd (fst he.he_res))) - (show he.he_gamma); - fun _ -> Success he.he_res - ) - else ( - // record_cache_miss(); - fail "not in cache" - ) - -let check_no_escape (bs:binders) t = - let xs = FStar.Syntax.Free.names t in - if BU.for_all (fun b -> not (mem b.binder_bv xs)) bs - then return () - else fail "Name escapes its scope" - -let rec map (#a #b:Type) (f:a -> result b) (l:list a) : result (list b) = - match l with - | [] -> return [] - | hd::tl -> - let! hd = f hd in - let! tl = map f tl in - return (hd::tl) - -let mapi (#a #b:Type) (f:int -> a -> result b) (l:list a) : result (list b) = - let rec aux i l = - match l with - | [] -> return [] - | hd::tl -> - let! hd = f i hd in - let! tl = aux (i + 1) tl in - return (hd::tl) - in - aux 0 l - -let rec map2 (#a #b #c:Type) (f:a -> b -> result c) (l1:list a) (l2:list b) : result (list c) = - match l1, l2 with - | [], [] -> return [] - | hd1::tl1, hd2::tl2 -> - let! hd = f hd1 hd2 in - let! tl = map2 f tl1 tl2 in - return (hd::tl) - -let rec fold (#a #b:Type) (f:a -> b -> result a) (x:a) (l:list b) : result a = - match l with - | [] -> return x - | hd::tl -> - let! x = f x hd in - fold f x tl - -let rec fold2 (#a #b #c:Type) (f:a -> b -> c -> result a) (x:a) (l1:list b) (l2:list c) : result a = - match l1, l2 with - | [], [] -> return x - | hd1::tl1, hd2::tl2 -> - let! x = f x hd1 hd2 in - fold2 f x tl1 tl2 - -let rec iter2 (xs ys:list 'a) (f: 'a -> 'a -> 'b -> result 'b) (b:'b) - : result 'b - = match xs, ys with - | [], [] -> return b - | x::xs, y::ys -> - let! b = f x y b in - iter2 xs ys f b - | _ -> fail "Lists of differing length" - -let is_non_informative g t = N.non_info_norm g t - -let non_informative g t - : bool - = is_non_informative g.tcenv t - -let as_comp (g:env) (et: (tot_or_ghost & typ)) - : comp - = match et with - | E_Total, t -> S.mk_Total t - | E_Ghost, t -> - if non_informative g t - then S.mk_Total t - else S.mk_GTotal t - -let comp_as_tot_or_ghost_and_type (c:comp) - : option (tot_or_ghost & typ) - = if U.is_total_comp c - then Some (E_Total, U.comp_result c) - else if U.is_tot_or_gtot_comp c - then Some (E_Ghost, U.comp_result c) - else None - -let join_eff e0 e1 = - match e0, e1 with - | E_Ghost, _ - | _, E_Ghost -> E_Ghost - | _ -> E_Total - -let join_eff_l es = List.Tot.fold_right join_eff es E_Total - -let guard_not_allowed - : result bool - = fun ctx -> Success (ctx.no_guard, None) - -let unfolding_ok - : result bool - = fun ctx -> Success (ctx.unfolding_ok, None) - -let debug g f = - if !dbg - then f () - -instance showable_side = { - show = (function - | Left -> "Left" - | Right -> "Right" - | Both -> "Both" - | Neither -> "Neither"); -} - -let boolean_negation_simp b = - if Hash.equal_term b U.exp_false_bool - then None - else Some (U.mk_boolean_negation b) - -let combine_path_and_branch_condition (path_condition:term) - (branch_condition:option term) - (branch_equality:term) - : term & term - = let this_path_condition = - let bc = - match branch_condition with - | None -> branch_equality - | Some bc -> U.mk_conj_l [U.b2t bc; branch_equality] - in - U.mk_conj (U.b2t path_condition) bc - in - let next_path_condition = - match branch_condition with - | None -> U.exp_false_bool - | Some bc -> - if Hash.equal_term path_condition U.exp_true_bool - then U.mk_boolean_negation bc - else U.mk_and path_condition (U.mk_boolean_negation bc) - in - this_path_condition, //:Type - next_path_condition //:bool - -let maybe_relate_after_unfolding (g:Env.env) t0 t1 : side = - let dd0 = Env.delta_depth_of_term g t0 in - let dd1 = Env.delta_depth_of_term g t1 in - - if dd0 = dd1 then - Both - else if Common.delta_depth_greater_than dd0 dd1 then - Left - else - Right - -(* - G |- e : t0 <: t1 | p - -or G |- t0 <: t1 | p - - *) -let rec check_relation (g:env) (rel:relation) (t0 t1:typ) - : result unit - = let err () = - match rel with - | EQUALITY -> - fail (BU.format2 "not equal terms: %s <> %s" - (show t0) - (show t1)) - | _ -> - fail (BU.format2 "%s is not a subtype of %s" - (show t0) - (show t1)) - in - let rel_to_string rel = - match rel with - | EQUALITY -> "=?=" - | SUBTYPING _ -> "<:?" - in - if !dbg - then BU.print5 "check_relation (%s) %s %s (%s) %s\n" - (tag_of t0) - (show t0) - (rel_to_string rel) - (tag_of t1) - (show t1); - let! guard_not_ok = guard_not_allowed in - let guard_ok = not guard_not_ok in - let head_matches t0 t1 - : bool - = let head0 = U.leftmost_head t0 in - let head1 = U.leftmost_head t1 in - match (U.un_uinst head0).n, (U.un_uinst head1).n with - | Tm_fvar fv0, Tm_fvar fv1 -> fv_eq fv0 fv1 - | Tm_name x0, Tm_name x1 -> bv_eq x0 x1 - | Tm_constant c0, Tm_constant c1 -> equal_term head0 head1 - | Tm_type _, Tm_type _ - | Tm_arrow _, Tm_arrow _ - | Tm_match _, Tm_match _ -> true - | _ -> false - in - let which_side_to_unfold t0 t1 = - maybe_relate_after_unfolding g.tcenv t0 t1 in - let maybe_unfold_side side t0 t1 - : option (term & term) - = Profiling.profile (fun _ -> - match side with - | Neither -> None - | Both -> ( - match N.maybe_unfold_head g.tcenv t0, - N.maybe_unfold_head g.tcenv t1 - with - | Some t0, Some t1 -> Some (t0, t1) - | Some t0, None -> Some (t0, t1) - | None, Some t1 -> Some (t0, t1) - | _ -> None - ) - | Left -> ( - match N.maybe_unfold_head g.tcenv t0 with - | Some t0 -> Some (t0, t1) - | _ -> None - ) - | Right -> ( - match N.maybe_unfold_head g.tcenv t1 with - | Some t1 -> Some (t0, t1) - | _ -> None - )) - None - "FStar.TypeChecker.Core.maybe_unfold_side" - in - let maybe_unfold t0 t1 - : result (option (term & term)) - = if! unfolding_ok - then return (maybe_unfold_side (which_side_to_unfold t0 t1) t0 t1) - else return None - in - let emit_guard t0 t1 = - let! _, t_typ = with_context "checking lhs while emitting guard" None (fun _ -> do_check g t0) in - let! u = universe_of g t_typ in - guard (U.mk_eq2 u t_typ t0 t1) - in - let fallback t0 t1 = - if guard_ok - then if equatable g t0 - || equatable g t1 - then emit_guard t0 t1 - else err () - else err () - in - let maybe_unfold_side_and_retry side t0 t1 = - if! unfolding_ok then - match maybe_unfold_side side t0 t1 with - | None -> fallback t0 t1 - | Some (t0, t1) -> check_relation g rel t0 t1 - else - fallback t0 t1 - in - let maybe_unfold_and_retry t0 t1 = - maybe_unfold_side_and_retry (which_side_to_unfold t0 t1) t0 t1 - in - let beta_iota_reduce t = - let t = Subst.compress t in - let t = N.normalize [Env.HNF; Env.Weak; Env.Beta; Env.Iota; Env.Primops] g.tcenv t in - match t.n with - | Tm_refine _ -> - U.flatten_refinement t - | _ -> t - in - let beta_iota_reduce t = - Profiling.profile - (fun () -> beta_iota_reduce t) - None - "FStar.TypeChecker.Core.beta_iota_reduce" - in - let t0 = Subst.compress (beta_iota_reduce t0) |> U.unlazy_emb in - let t1 = Subst.compress (beta_iota_reduce t1) |> U.unlazy_emb in - let check_relation g rel t0 t1 = - with_context "check_relation" (Some (CtxRel t0 rel t1)) - (fun _ -> check_relation g rel t0 t1) - in - if equal_term t0 t1 then return () - else - match t0.n, t1.n with - | Tm_type u0, Tm_type u1 -> - // when g.allow_universe_instantiation -> - // See above remark regarding universe instantiations - if Rel.teq_nosmt_force g.tcenv t0 t1 - then return () - else err () - - | Tm_meta {tm=t0; meta=Meta_pattern _}, _ - | Tm_meta {tm=t0; meta=Meta_named _}, _ - | Tm_meta {tm=t0; meta=Meta_labeled _}, _ - | Tm_meta {tm=t0; meta=Meta_desugared _}, _ - | Tm_ascribed {tm=t0}, _ -> - check_relation g rel t0 t1 - - | _, Tm_meta {tm=t1; meta=Meta_pattern _} - | _, Tm_meta {tm=t1; meta=Meta_named _} - | _, Tm_meta {tm=t1; meta=Meta_labeled _} - | _, Tm_meta {tm=t1; meta=Meta_desugared _} - | _, Tm_ascribed {tm=t1} -> - check_relation g rel t0 t1 - - | Tm_uinst (f0, us0), Tm_uinst(f1, us1) -> - if equal_term f0 f1 - then ( //heads are equal, equate universes - if Rel.teq_nosmt_force g.tcenv t0 t1 - then return () - else err () - ) - else maybe_unfold_and_retry t0 t1 - - | Tm_fvar _, Tm_fvar _ -> - maybe_unfold_and_retry t0 t1 - - - | Tm_refine {b=x0; phi=f0}, Tm_refine {b=x1; phi=f1} -> - if head_matches x0.sort x1.sort - then ( - check_relation g EQUALITY x0.sort x1.sort ;! - let! u = universe_of g x0.sort in - let g, b, f0 = open_term g (S.mk_binder x0) f0 in - let f1 = Subst.subst [DB(0, b.binder_bv)] f1 in - (match! guard_not_allowed with - | true -> - with_binders [b] [u] - (check_relation g EQUALITY f0 f1) - - | _ -> - match rel with - | EQUALITY -> - with_binders [b] [u] - (handle_with - (check_relation g EQUALITY f0 f1) - (fun _ -> guard (U.mk_iff f0 f1))) - - | SUBTYPING (Some tm) -> - guard (Subst.subst [NT(b.binder_bv, tm)] (U.mk_imp f0 f1)) - - | SUBTYPING None -> - guard (U.mk_forall u b.binder_bv (U.mk_imp f0 f1))) - ) - else ( - match! maybe_unfold x0.sort x1.sort with - | None -> - if !dbg then - BU.print2 "Cannot match ref heads %s and %s\n" (show x0.sort) (show x1.sort); - fallback t0 t1 - | Some (t0, t1) -> - let lhs = S.mk (Tm_refine {b={x0 with sort = t0}; phi=f0}) t0.pos in - let rhs = S.mk (Tm_refine {b={x1 with sort = t1}; phi=f1}) t1.pos in - check_relation g rel (U.flatten_refinement lhs) (U.flatten_refinement rhs) - ) - - | Tm_refine {b=x0; phi=f0}, _ -> - if head_matches x0.sort t1 - then ( - (* For subtyping, we just check that x0.sort <: t1. But for equality, - we must show that the refinement on the LHS is constantly true. *) - if rel = EQUALITY then ( - let! u0 = universe_of g x0.sort in - let g, b0, f0 = open_term g (S.mk_binder x0) f0 in - if! guard_not_allowed then - with_binders [b0] [u0] - (check_relation g EQUALITY U.t_true f0) - else ( - with_binders [b0] [u0] - (handle_with - (check_relation g EQUALITY U.t_true f0) - (fun _ -> guard f0)) - ) - ) else return ();! - check_relation g rel x0.sort t1 - ) - else ( - match! maybe_unfold x0.sort t1 with - | None -> fallback t0 t1 - | Some (t0, t1) -> - let lhs = S.mk (Tm_refine {b={x0 with sort = t0}; phi=f0}) t0.pos in - check_relation g rel (U.flatten_refinement lhs) t1 - ) - - | _, Tm_refine {b=x1; phi=f1} -> - if head_matches t0 x1.sort - then ( - let! u1 = universe_of g x1.sort in - check_relation g EQUALITY t0 x1.sort ;! - let g, b1, f1 = open_term g (S.mk_binder x1) f1 in - if! guard_not_allowed then - with_binders [b1] [u1] - (check_relation g EQUALITY U.t_true f1) - else ( - match rel with - | EQUALITY -> - with_binders [b1] [u1] - (handle_with - (check_relation g EQUALITY U.t_true f1) - (fun _ -> guard f1)) - - | SUBTYPING (Some tm) -> - guard (Subst.subst [NT(b1.binder_bv, tm)] f1) - - | SUBTYPING None -> - guard (U.mk_forall u1 b1.binder_bv f1) - ) - ) - else ( - match! maybe_unfold t0 x1.sort with - | None -> fallback t0 t1 - | Some (t0, t1) -> - let rhs = S.mk (Tm_refine {b={x1 with sort = t1}; phi=f1}) t1.pos in - check_relation g rel t0 (U.flatten_refinement rhs) - ) - - | Tm_uinst _, _ - | Tm_fvar _, _ - | Tm_app _, _ - | _, Tm_uinst _ - | _, Tm_fvar _ - | _, Tm_app _ -> - let head_matches = head_matches t0 t1 in - let head0, args0 = U.leftmost_head_and_args t0 in - let head1, args1 = U.leftmost_head_and_args t1 in - if not (head_matches && List.length args0 = List.length args1) - then maybe_unfold_and_retry t0 t1 - else ( - (* If we're proving equality, SMT queries are ok, and either head - is equatable: - - first try proving equality structurally, without a guard. - - if that fails, then emit an SMT query - This is designed to be able to prove things like `v.v1 == u.v1` - first by trying to unify `v` and `u` and if it fails - then prove `v.v1 == u.v1` *) - let compare_head_and_args () = - handle_with - (check_relation g EQUALITY head0 head1 ;! - check_relation_args g EQUALITY args0 args1) - (fun _ -> maybe_unfold_side_and_retry Both t0 t1) - in - if guard_ok && - (rel=EQUALITY) && - (equatable g t0 || equatable g t1) - then ( - handle_with - (no_guard (compare_head_and_args ())) - (fun _ -> emit_guard t0 t1) - ) - else compare_head_and_args () - ) - - | Tm_abs {bs=b0::b1::bs; body; rc_opt=ropt}, _ -> - let t0 = curry_abs b0 b1 bs body ropt in - check_relation g rel t0 t1 - - | _, Tm_abs {bs=b0::b1::bs; body; rc_opt=ropt} -> - let t1 = curry_abs b0 b1 bs body ropt in - check_relation g rel t0 t1 - - | Tm_abs {bs=[b0]; body=body0}, Tm_abs {bs=[b1]; body=body1} -> - check_relation g EQUALITY b0.binder_bv.sort b1.binder_bv.sort;! - check_bqual b0.binder_qual b1.binder_qual;! - check_positivity_qual EQUALITY b0.binder_positivity b1.binder_positivity;! - let! u = universe_of g b0.binder_bv.sort in - let g, b0, body0 = open_term g b0 body0 in - let body1 = Subst.subst [DB(0, b0.binder_bv)] body1 in - with_binders [b0] [u] - (check_relation g EQUALITY body0 body1) - - | Tm_arrow {bs=x0::x1::xs; comp=c0}, _ -> - check_relation g rel (curry_arrow x0 (x1::xs) c0) t1 - - | _, Tm_arrow {bs=x0::x1::xs; comp=c1} -> - check_relation g rel t0 (curry_arrow x0 (x1::xs) c1) - - | Tm_arrow {bs=[x0]; comp=c0}, Tm_arrow {bs=[x1]; comp=c1} -> - with_context "subtype arrow" None (fun _ -> - let! _ = check_bqual x0.binder_qual x1.binder_qual in - check_positivity_qual rel x0.binder_positivity x1.binder_positivity;! - let! u1 = universe_of g x1.binder_bv.sort in - let g_x1, x1, c1 = open_comp g x1 c1 in - let c0 = Subst.subst_comp [DB(0, x1.binder_bv)] c0 in - with_binders [x1] [u1] ( - let rel_arg = - match rel with - | EQUALITY -> EQUALITY - | _ -> SUBTYPING (Some (S.bv_to_name x1.binder_bv)) - in - let rel_comp = - match rel with - | EQUALITY -> EQUALITY - | SUBTYPING e -> - SUBTYPING - (if U.is_pure_or_ghost_comp c0 - then let? e in Some (S.mk_Tm_app e (snd (U.args_of_binders [x1])) R.dummyRange) - else None) - in - check_relation g rel x1.binder_bv.sort x0.binder_bv.sort ;! - with_context "check_subcomp" None (fun _ -> - check_relation_comp g_x1 rel_comp c0 c1 - ) - ) - ) - - | Tm_match {scrutinee=e0;brs=brs0}, Tm_match {scrutinee=e1;brs=brs1} -> - let relate_branch br0 br1 (_:unit) - : result unit - = match br0, br1 with - | (p0, None, body0), (p1, None, body1) -> - if not (S.eq_pat p0 p1) - then fail "patterns not equal" - else begin - let g', (p0, _, body0), (p1, _, body1) = open_branches_eq_pat g (p0, None, body0) (p1, None, body1) in - match PatternUtils.raw_pat_as_exp g.tcenv p0 with - | Some (_, bvs0) -> - let bs0 = List.map S.mk_binder bvs0 in - // We need universes for the binders - let! us = check_binders g bs0 in - with_context "relate_branch" None (fun _ -> with_binders bs0 us (check_relation g' rel body0 body1)) - | _ -> fail "raw_pat_as_exp failed in check_equality match rule" - end - | _ -> fail "Core does not support branches with when" - in - handle_with - (check_relation g EQUALITY e0 e1 ;! - iter2 brs0 brs1 relate_branch ()) - (fun _ -> fallback t0 t1) - - | _ -> fallback t0 t1 - -and check_relation_args (g:env) rel (a0 a1:args) - : result unit - = if List.length a0 = List.length a1 - then iter2 a0 a1 - (fun (t0, q0) (t1, q1) _ -> - check_aqual q0 q1;! - check_relation g rel t0 t1) - () - else fail "Unequal number of arguments" - -and check_relation_comp (g:env) rel (c0 c1:comp) - : result unit - = let destruct_comp c = - if U.is_total_comp c - then Some (E_Total, U.comp_result c) - else if U.is_tot_or_gtot_comp c - then Some (E_Ghost, U.comp_result c) - else None - in - match destruct_comp c0, destruct_comp c1 with - | None, _ - | _, None -> - if TEQ.eq_comp g.tcenv c0 c1 = TEQ.Equal - then return () - else ( - let ct_eq res0 args0 res1 args1 = - check_relation g EQUALITY res0 res1 ;! - check_relation_args g EQUALITY args0 args1 - in - let eff0, res0, args0 = U.comp_eff_name_res_and_args c0 in - let eff1, res1, args1 = U.comp_eff_name_res_and_args c1 in - if I.lid_equals eff0 eff1 - then ct_eq res0 args0 res1 args1 - else ( - let ct0 = Env.unfold_effect_abbrev g.tcenv c0 in - let ct1 = Env.unfold_effect_abbrev g.tcenv c1 in - if I.lid_equals ct0.effect_name ct1.effect_name - then ct_eq ct0.result_typ ct0.effect_args ct1.result_typ ct1.effect_args - else fail (BU.format2 "Subcomp failed: Unequal computation types %s and %s" - (Ident.string_of_lid ct0.effect_name) - (Ident.string_of_lid ct1.effect_name)) - ) - ) - - | Some (E_Total, t0), Some (_, t1) // why is this right? what about EQUALITY? - | Some (E_Ghost, t0), Some (E_Ghost, t1) -> - check_relation g rel t0 t1 - - | Some (E_Ghost, t0), Some (E_Total, t1) -> - if non_informative g t1 - then check_relation g rel t0 t1 - else fail "Expected a Total computation, but got Ghost" - - -and check_subtype (g:env) (e:option term) (t0 t1:typ) - = fun ctx -> - Profiling.profile - (fun () -> - let rel = SUBTYPING e in - with_context (if ctx.no_guard then "check_subtype(no_guard)" else "check_subtype") - (Some (CtxRel t0 rel t1)) - (fun _ -> check_relation g rel t0 t1) - ctx) - None - "FStar.TypeChecker.Core.check_subtype" - -and memo_check (g:env) (e:term) - : result (tot_or_ghost & typ) - = let check_then_memo g e ctx = - let r = do_check_and_promote g e ctx in - match r with - | Success (res, None) -> - insert g e (res, None); - r - - | Success (res, Some guard) -> - (match g.guard_handler with - | None -> insert g e (res, Some guard); r - | Some gh -> - if gh g.tcenv guard - then let r = (res, None) in - insert g e r; Success r - else fail "guard handler failed" ctx) - - | _ -> r - in - fun ctx -> - if not g.should_read_cache - then check_then_memo g e ctx - else ( - match lookup g e ctx with - | Error _ -> //cache miss; check and insert - check_then_memo g e ctx - - | Success (et, None) -> //cache hit with no guard; great, just return - Success (et, None) - - | Success (et, Some pre) -> //cache hit with a guard - match g.guard_handler with - | None -> Success (et, Some pre) //if there's no guard handler, then just return - | Some _ -> - //otherwise check then memo, since this can - //repopulate the cache with a "better" entry that has no guard - //But, don't read the cache again, since many subsequent lookups - //are likely to be hits with a guard again - check_then_memo { g with should_read_cache = false } e ctx - ) - -and check (msg:string) (g:env) (e:term) - : result (tot_or_ghost & typ) - = with_context msg (Some (CtxTerm e)) (fun _ -> memo_check g e) - -and do_check_and_promote (g:env) (e:term) - : result (tot_or_ghost & typ) - = let! (eff, t) = do_check g e in - let eff = - match eff with - | E_Total -> E_Total - | E_Ghost -> if non_informative g t then E_Total else E_Ghost in - return (eff, t) - -(* G |- e : Tot t | pre *) -and do_check (g:env) (e:term) - : result (tot_or_ghost & typ) = - let e = Subst.compress e in - match e.n with - | Tm_lazy ({lkind=Lazy_embedding _}) -> - do_check g (U.unlazy e) - - | Tm_lazy i -> - return (E_Total, i.ltyp) - - | Tm_meta {tm=t} -> - memo_check g t - - | Tm_uvar (uv, s) -> - return (E_Total, Subst.subst' s (U.ctx_uvar_typ uv)) - - | Tm_name x -> - begin - match Env.try_lookup_bv g.tcenv x with - | None -> - fail (BU.format1 "Variable not found: %s" (show x)) - | Some (t, _) -> - return (E_Total, t) - end - - | Tm_fvar f -> - begin - match Env.try_lookup_lid g.tcenv f.fv_name.v with - | Some (([], t), _) -> - return (E_Total, t) - - | _ -> //no implicit universe instantiation allowed - fail "Missing universes instantiation" - end - - | Tm_uinst ({n=Tm_fvar f}, us) -> - begin - match Env.try_lookup_and_inst_lid g.tcenv us f.fv_name.v with - | None -> - fail (BU.format1 "Top-level name not found: %s" (Ident.string_of_lid f.fv_name.v)) - - | Some (t, _) -> - return (E_Total, t) - end - - | Tm_constant c -> - begin - let open FStar.Const in - match c with - | Const_range_of - | Const_set_range_of - | Const_reify _ - | Const_reflect _ -> - fail "Unhandled constant" - - | _ -> - let t = FStar.TypeChecker.TcTerm.tc_constant g.tcenv e.pos c in - return (E_Total, t) - end - - | Tm_type u -> - return (E_Total, mk_type (U_succ u)) - - | Tm_refine {b=x; phi} -> - let! _, t = check "refinement head" g x.sort in - let! u = is_type g t in - let g', x, phi = open_term g (S.mk_binder x) phi in - with_binders [x] [u] ( - let! _, t' = check "refinement formula" g' phi in - is_type g' t';! - return (E_Total, t) - ) - - | Tm_abs {bs=xs; body} -> - let g', xs, body = open_term_binders g xs body in - let! us = with_context "abs binders" None (fun _ -> check_binders g xs) in - with_binders xs us ( - let! t = check "abs body" g' body in - return (E_Total, U.arrow xs (as_comp g t)) - ) - - | Tm_arrow {bs=xs; comp=c} -> - let g', xs, c = open_comp_binders g xs c in - let! us = with_context "arrow binders" None (fun _ -> check_binders g xs) in - with_binders xs us ( - let! u = with_context "arrow comp" None (fun _ -> check_comp g' c) in - return (E_Total, mk_type (S.U_max (u::us))) - ) - - | Tm_app _ -> ( - let rec check_app_arg (eff_hd, t_hd) (arg, arg_qual) = - let! x, eff_arr, t' = is_arrow g t_hd in - let! eff_arg, t_arg = check "app arg" g arg in - with_context "app subtyping" None (fun _ -> check_subtype g (Some arg) t_arg x.binder_bv.sort) ;! - with_context "app arg qual" None (fun _ -> check_arg_qual arg_qual x.binder_qual) ;! - return (join_eff eff_hd (join_eff eff_arr eff_arg), Subst.subst [NT(x.binder_bv, arg)] t') - in - let check_app hd args = - let! eff_hd, t = check "app head" g hd in - fold check_app_arg (eff_hd, t) args - in - let hd, args = U.head_and_args_full e in - match args with - | [(t1, None); (t2, None)] when TcUtil.short_circuit_head hd -> - let! eff_hd, t_hd = check "app head" g hd in - let! x, eff_arr1, s1 = is_arrow g t_hd in - let! eff_arg1, t_t1 = check "app arg" g t1 in - with_context "operator arg1" None (fun _ -> check_subtype g (Some t1) t_t1 x.binder_bv.sort) ;! - let s1 = Subst.subst [NT(x.binder_bv, t1)] s1 in - let! y, eff_arr2, s2 = is_arrow g s1 in - let guard_formula = TcUtil.short_circuit hd [(t1, None)] in - let g' = - match guard_formula with - | Common.Trivial -> g - | Common.NonTrivial gf -> push_hypothesis g gf - in - let! eff_arg2, t_t2 = weaken_with_guard_formula guard_formula (check "app arg" g' t2) in - with_context "operator arg2" None (fun _ -> check_subtype g' (Some t2) t_t2 y.binder_bv.sort) ;! - return (join_eff_l [eff_hd; eff_arr1; eff_arr2; eff_arg1; eff_arg2], - Subst.subst [NT(y.binder_bv, t2)] s2) - | _ -> check_app hd args - ) - - | Tm_ascribed {tm=e; asc=(Inl t, _, eq)} -> - let! eff, te = check "ascription head" g e in - let! _, t' = check "ascription type" g t in - is_type g t';! - with_context "ascription subtyping" None (fun _ -> check_subtype g (Some e) te t);! - return (eff, t) - - | Tm_ascribed {tm=e; asc=(Inr c, _, _)} -> - if U.is_tot_or_gtot_comp c - then ( - let! eff, te = check "ascription head" g e in - let! _ = with_context "ascription comp" None (fun _ -> check_comp g c) in - let c_e = as_comp g (eff, te) in - with_context "ascription subtyping (comp)" None (fun _ -> check_relation_comp g (SUBTYPING (Some e)) c_e c);! - let Some (eff, t) = comp_as_tot_or_ghost_and_type c in - return (eff, t) - ) - else fail (BU.format1 "Effect ascriptions are not fully handled yet: %s" (show c)) - - | Tm_let {lbs=(false, [lb]); body} -> - let Inl x = lb.lbname in - let g', x, body = open_term g (S.mk_binder x) body in - if U.is_pure_or_ghost_effect lb.lbeff - then ( - let! eff_def, tdef = check "let definition" g lb.lbdef in - let! _, ttyp = check "let type" g lb.lbtyp in - let! u = is_type g ttyp in - with_context "let subtyping" None (fun _ -> check_subtype g (Some lb.lbdef) tdef lb.lbtyp) ;! - with_definition x u lb.lbdef ( - let! eff_body, t = check "let body" g' body in - check_no_escape [x] t;! - return (join_eff eff_def eff_body, t) - ) - ) - else ( - fail (format1 "Let binding is effectful (lbeff = %s)" (show lb.lbeff)) - ) - - | Tm_match {scrutinee=sc; ret_opt=None; brs=branches; rc_opt} -> - let! eff_sc, t_sc = check "scrutinee" g sc in - let! u_sc = with_context "universe_of" (Some (CtxTerm t_sc)) (fun _ -> universe_of g t_sc) in - let rec check_branches path_condition - branch_typ_opt - branches - : result (tot_or_ghost & typ) - = match branches with - | [] -> - (match branch_typ_opt with - | None -> - fail "could not compute a type for the match" - - | Some et -> - match boolean_negation_simp path_condition with - | None -> - return et - - | Some g -> - guard (U.b2t g) ;! - return et) - - | (p, None, b) :: rest -> - let _, (p, _, b) = open_branch g (p, None, b) in - let! (bs, us) = with_context "check_pat" None (fun _ -> check_pat g p t_sc) in - let! branch_condition = pattern_branch_condition g sc p in - let pat_sc_eq = - U.mk_eq2 u_sc t_sc sc - (PatternUtils.raw_pat_as_exp g.tcenv p |> must |> fst) in - let this_path_condition, next_path_condition = - combine_path_and_branch_condition path_condition branch_condition pat_sc_eq - in - let g' = push_binders g bs in - let g' = push_hypothesis g' this_path_condition in - let! eff_br, tbr = - with_binders bs us - (weaken - this_path_condition - (let! eff_br, tbr = with_context "branch" (Some (CtxTerm b)) (fun _ -> check "branch" g' b) in - match branch_typ_opt with - | None -> - check_no_escape bs tbr;! - return (eff_br, tbr) - - | Some (acc_eff, expect_tbr) -> - with_context "check_branch_subtype" (Some (CtxRel tbr (SUBTYPING (Some b)) expect_tbr)) - (fun _ -> check_subtype g' (Some b) tbr expect_tbr) ;! - return (join_eff eff_br acc_eff, expect_tbr))) in - match p.v with - | Pat_var _ -> - //trivially exhaustive - (match rest with - | _ :: _ -> fail "Redundant branches after wildcard" - | _ -> return (eff_br, tbr)) - - | _ -> - check_branches next_path_condition (Some (eff_br, tbr)) rest - in - - let! branch_typ_opt = - match rc_opt with - | Some ({ residual_typ = Some t }) -> - with_context "residual type" (Some (CtxTerm t)) (fun _ -> universe_of g t) ;! - return (Some (E_Total, t)) - - | _ -> - return None - in - let! eff_br, t_br = - let ctx = - match branch_typ_opt with - | None -> None - | Some (_, t) -> Some (CtxTerm t) - in - with_context "check_branches" ctx - (fun _ -> check_branches U.exp_true_bool branch_typ_opt branches) - in - return (join_eff eff_sc eff_br, t_br) - - | Tm_match {scrutinee=sc; ret_opt=Some (as_x, (Inl returns_ty, None, eq)); brs=branches; rc_opt} -> - let! eff_sc, t_sc = check "scrutinee" g sc in - let! u_sc = with_context "universe_of" (Some (CtxTerm t_sc)) (fun _ -> universe_of g t_sc) in - let as_x = {as_x with binder_bv = { as_x.binder_bv with sort = t_sc } } in - let g_as_x, as_x, returns_ty = open_term g as_x returns_ty in - let! _eff_t, returns_ty_t = - with_binders [as_x] [u_sc] (check "return type" g_as_x returns_ty) in - let! _u_ty = is_type g_as_x returns_ty_t in - let rec check_branches (path_condition: S.term) - (branches: list S.branch) - (acc_eff: tot_or_ghost) - : result tot_or_ghost - = match branches with - | [] -> - (match boolean_negation_simp path_condition with - | None -> - return acc_eff - - | Some g -> - guard (U.b2t g) ;! - return acc_eff) - - | (p, None, b) :: rest -> - let _, (p, _, b) = open_branch g (p, None, b) in - let! (bs, us) = with_context "check_pat" None (fun _ -> check_pat g p t_sc) in - let! branch_condition = pattern_branch_condition g sc p in - let pat_sc_eq = - U.mk_eq2 u_sc t_sc sc - (PatternUtils.raw_pat_as_exp g.tcenv p |> must |> fst) in - let this_path_condition, next_path_condition = - combine_path_and_branch_condition path_condition branch_condition pat_sc_eq - in - let g' = push_binders g bs in - let g' = push_hypothesis g' this_path_condition in - let! eff_br, tbr = - with_binders bs us - (weaken - this_path_condition - (let! eff_br, tbr = check "branch" g' b in - let expect_tbr = Subst.subst [NT(as_x.binder_bv, sc)] returns_ty in - let rel = - if eq - then EQUALITY - else SUBTYPING (Some b) - in - with_context "branch check relation" None (fun _ -> check_relation g' rel tbr expect_tbr);! - return (join_eff eff_br acc_eff, expect_tbr))) in - match p.v with - | Pat_var _ -> - //trivially exhaustive - (match rest with - | _ :: _ -> fail "Redundant branches after wildcard" - | _ -> return eff_br) - - | _ -> - check_branches next_path_condition rest eff_br in - - let! eff = check_branches U.exp_true_bool branches E_Total in - let ty = Subst.subst [NT(as_x.binder_bv, sc)] returns_ty in - return (eff, ty) - - | Tm_match _ -> - fail "Match with effect returns ascription, or tactic handler" - - | _ -> - fail (BU.format1 "Unexpected term: %s" (tag_of e)) - -and check_binders (g_initial:env) (xs:binders) - : result (list universe) - = let rec aux g xs = - match xs with - | [] -> - return [] - - | x ::xs -> - let! _, t = check "binder sort" g x.binder_bv.sort in - let! u = is_type g t in - with_binders [x] [u] ( - let! us = aux (push_binder g x) xs in - return (u::us) - ) - in - aux g_initial xs - -// -// May be called with an effectful comp type, e.g. from within an arrow -// Caller should enforce Tot/GTot if needed -// -and check_comp (g:env) (c:comp) - : result universe - = match c.n with - | Total t - | GTotal t -> - let! _, t = check "(G)Tot comp result" g (U.comp_result c) in - is_type g t - | Comp ct -> - if List.length ct.comp_univs <> 1 - then fail "Unexpected/missing universe instantitation in comp" - else let u = List.hd ct.comp_univs in - let effect_app_tm = - let head = S.mk_Tm_uinst (S.fvar ct.effect_name None) [u] in - S.mk_Tm_app head ((as_arg ct.result_typ)::ct.effect_args) ct.result_typ.pos in - let! _, t = check "effectful comp" g effect_app_tm in - with_context "comp fully applied" None (fun _ -> check_subtype g None t S.teff);! - let c_lid = Env.norm_eff_name g.tcenv ct.effect_name in - let is_total = Env.lookup_effect_quals g.tcenv c_lid |> List.existsb (fun q -> q = S.TotalEffect) in - if not is_total - then return S.U_zero //if it is a non-total effect then u0 - else if U.is_pure_or_ghost_effect c_lid - then return u - else ( - match Env.effect_repr g.tcenv c u with - | None -> fail (BU.format2 "Total effect %s (normalized to %s) does not have a representation" - (Ident.string_of_lid (U.comp_effect_name c)) - (Ident.string_of_lid c_lid)) - | Some tm -> universe_of g tm - ) - -and universe_of (g:env) (t:typ) - : result universe - = let! _, t = check "universe of" g t in - is_type g t - -and check_pat (g:env) (p:pat) (t_sc:typ) : result (binders & universes) = - let unrefine_tsc t_sc = - t_sc |> N.normalize_refinement N.whnf_steps g.tcenv - |> U.unrefine in - - match p.v with - | Pat_constant c -> - let e = - match c with - | FStar.Const.Const_int(repr, Some sw) -> - FStar.ToSyntax.ToSyntax.desugar_machine_integer g.tcenv.dsenv repr sw p.p - | _ -> - mk (Tm_constant c) p.p in - let! _, t_const = check "pat_const" g e in - let! _ = with_context "check_pat constant" None (fun () -> check_subtype g (Some e) t_const (unrefine_tsc t_sc)) in - return ([], []) - - | Pat_var bv -> - let b = S.mk_binder {bv with sort=t_sc} in - let! [u] = with_context "check_pat_binder" None (fun _ -> check_binders g [b]) in - return ([b], [u]) - - | Pat_cons (fv, usopt, pats) -> - let us = if is_none usopt then [] else usopt |> must in - - let formals, t_pat = - Env.lookup_and_inst_datacon g.tcenv us (S.lid_of_fv fv) - |> U.arrow_formals in - - let dot_pats, rest_pats = - let pats = pats |> List.map fst in - pats |> BU.prefix_until (fun p -> match p.v with - | Pat_dot_term _ -> false - | _ -> true) - |> BU.map_option (fun (dot_pats, pat, rest_pats) -> - dot_pats, (pat::rest_pats)) - |> BU.dflt (pats, []) in - - let dot_formals, rest_formals = List.splitAt (List.length dot_pats) formals in - - let! ss = fold2 (fun ss {binder_bv=f} p -> - let expected_t = Subst.subst ss f.sort in - let! pat_dot_t = - match p.v with - | Pat_dot_term (Some t) -> return t - | _ -> fail "check_pat in core has unset dot pattern" in - - let! _, p_t = check "pat dot term" g pat_dot_t in - let!_ = with_context "check_pat cons" None (fun _ -> check_subtype g (Some pat_dot_t) p_t expected_t) in - - return (ss@[NT (f, pat_dot_t)])) [] dot_formals dot_pats in - - let! _, ss, bs, us = fold2 (fun (g, ss, bs, us) {binder_bv=f} p -> - let expected_t = Subst.subst ss f.sort in - let! (bs_p, us_p) = with_binders bs us (check_pat g p expected_t) in - let p_e = PatternUtils.raw_pat_as_exp g.tcenv p |> must |> fst in - return (push_binders g bs_p, - ss@[NT (f, p_e)], - bs@bs_p, - us@us_p)) (g, ss, [], []) rest_formals rest_pats in - - let t_pat = Subst.subst ss t_pat in - - let!_ = no_guard (check_scrutinee_pattern_type_compatible g (unrefine_tsc t_sc) t_pat) in - - return (bs, us) - - | _ -> fail "check_pat called with a dot pattern" - -and check_scrutinee_pattern_type_compatible (g:env) (t_sc t_pat:typ) - : result precondition - = let open Env in - let err (s:string) = - fail (BU.format3 "Scrutinee type %s and Pattern type %s are not compatible because %s" - (show t_sc) - (show t_pat) - s) in - - let head_sc, args_sc = U.head_and_args t_sc in - let head_pat, args_pat = U.head_and_args t_pat in - - let! (t_fv:fv) = - match (Subst.compress head_sc).n, (Subst.compress head_pat).n with - | Tm_fvar (fv_head), Tm_fvar (fv_pat) - when Ident.lid_equals (lid_of_fv fv_head) (lid_of_fv fv_pat) -> return fv_head - | Tm_uinst ({n=Tm_fvar (fv_head)}, us_head), Tm_uinst ({n=Tm_fvar (fv_pat)}, us_pat) - when Ident.lid_equals (lid_of_fv fv_head) (lid_of_fv fv_pat) -> - if Rel.teq_nosmt_force g.tcenv head_sc head_pat - then return fv_head - else err "Incompatible universe instantiations" - | _, _ -> err (BU.format2 "Head constructors(%s and %s) not fvar" - (tag_of head_sc) - (tag_of head_pat)) in - - (if Env.is_type_constructor g.tcenv (lid_of_fv t_fv) - then return t_fv - else err (BU.format1 "%s is not a type constructor" (show t_fv)));! - - (if List.length args_sc = List.length args_pat then return t_fv - else err (BU.format2 "Number of arguments don't match (%s and %s)" - (string_of_int (List.length args_sc)) - (string_of_int (List.length args_pat))));! - - let params_sc, params_pat = - match Env.num_inductive_ty_params g.tcenv (S.lid_of_fv t_fv) with - | None -> args_sc, args_pat - | Some n -> fst (BU.first_N n args_sc), fst (BU.first_N n args_pat) in - - iter2 params_sc params_pat (fun (t_sc, _) (t_pat, _) _ -> - check_relation g EQUALITY t_sc t_pat) () ;! - - // TODO: return equality of indices for the caller to weaken the guard with? - - return None - -and pattern_branch_condition (g:env) - (scrutinee:term) - (pat:pat) - : result (option term) - = match pat.v with - | Pat_var _ -> - return None - | Pat_constant c -> - let const_exp = - match PatternUtils.raw_pat_as_exp g.tcenv pat with - | None -> failwith "Impossible" - | Some (e, _) -> e - in - let! _, t_const = check "constant pattern" g const_exp in - return (Some (U.mk_decidable_eq t_const scrutinee const_exp)) - - | Pat_cons(fv, us_opt, sub_pats) -> - let wild_pat pos = S.withinfo (Pat_var (S.new_bv None S.tun)) pos in - let mk_head_discriminator () = - let pat = S.withinfo (Pat_cons(fv, us_opt, List.map (fun (s, b) -> wild_pat s.p, b) sub_pats)) pat.p in - let branch1 = (pat, None, U.exp_true_bool) in - let branch2 = (S.withinfo (Pat_var (S.new_bv None S.tun)) pat.p, None, U.exp_false_bool) in - S.mk (Tm_match {scrutinee; ret_opt=None; brs=[branch1; branch2]; rc_opt=None}) scrutinee.pos - in - let mk_ith_projector i = - let ith_pat_var, ith_pat = - let bv = S.new_bv None S.tun in - bv, S.withinfo (Pat_var bv) scrutinee.pos - in - let sub_pats = List.mapi (fun j (s,b) -> if i <> j then wild_pat s.p,b else ith_pat,b) sub_pats in - let pat = S.withinfo (Pat_cons(fv, us_opt, sub_pats)) pat.p in - let branch = S.bv_to_name ith_pat_var in - let eqn = Subst.close_branch (pat, None, branch) in - S.mk (Tm_match {scrutinee; ret_opt=None; brs=[eqn]; rc_opt=None}) scrutinee.pos - in - let discrimination = - let is_induc, datacons = Env.datacons_of_typ g.tcenv (Env.typ_of_datacon g.tcenv fv.fv_name.v) in - (* Why the `not is_induc`? We may be checking an exception pattern. See issue #1535. *) - if not is_induc || List.length datacons > 1 - then let discriminator = U.mk_discriminator fv.fv_name.v in - match Env.try_lookup_lid g.tcenv discriminator with - | None -> - // We don't use the discriminator if we are typechecking it - None - | _ -> - Some (mk_head_discriminator()) - else None //single constructor inductives do not need a discriminator - in - let! sub_term_guards = - mapi - (fun i (pi, _) -> - match pi.v with - | Pat_dot_term _ - | Pat_var _ -> - return None - | _ -> - let scrutinee_sub_term = mk_ith_projector i in - pattern_branch_condition g (mk_ith_projector i) pi) - sub_pats - in - let guards = List.collect (function None -> [] | Some t -> [t]) (discrimination :: sub_term_guards) in - match guards with - | [] -> return None - | guards -> return (Some (U.mk_and_l guards)) - -let initial_env g gh = - let max_index = - List.fold_left - (fun index b -> - match b with - | Binding_var x -> - if x.index > index - then x.index - else index - | _ -> index) - 0 g.Env.gamma - in - { tcenv = g; - allow_universe_instantiation = false; - max_binder_index = max_index; - guard_handler = gh; - should_read_cache = true } - -// -// In case the expected type and effect are set, -// they are returned as is -// -let check_term_top g e topt (must_tot:bool) (gh:option guard_handler_t) - : result (tot_or_ghost & typ) - = let g = initial_env g gh in - let! eff_te = check "top" g e in - match topt with - | None -> - // check expected effect - if must_tot - then let eff, t = eff_te in - if eff = E_Ghost && - not (non_informative g t) - then fail "expected total effect, found ghost" - else return (E_Total, t) - else return eff_te - | Some t -> - let target_comp, eff = - if must_tot || fst eff_te = E_Total - then S.mk_Total t, E_Total - else S.mk_GTotal t, E_Ghost - in - with_context "top-level subtyping" None (fun _ -> - check_relation_comp - ({ g with allow_universe_instantiation = true}) - (SUBTYPING (Some e)) - (as_comp g eff_te) - target_comp) ;! - return (eff, t) - -let simplify_steps = - [Env.Beta; - Env.UnfoldUntil delta_constant; - Env.UnfoldQual ["unfold"]; - Env.UnfoldOnly [PC.pure_wp_monotonic_lid; PC.pure_wp_monotonic0_lid]; - Env.Simplify; - Env.Primops; - Env.NoFullNorm] - - -let check_term_top_gh g e topt (must_tot:bool) (gh:option guard_handler_t) - : __result ((tot_or_ghost & S.typ) & precondition) - = if !dbg_Eq - then BU.print1 "(%s) Entering core ... \n" - (show (get_goal_ctr())); - - if !dbg || !dbg_Top - then BU.print3 "(%s) Entering core with %s <: %s\n" - (show (get_goal_ctr())) (show e) (show topt); - THT.reset_counters table; - reset_cache_stats(); - let ctx = { unfolding_ok = true; no_guard = false; error_context = [("Top", None)] } in - let res = - Profiling.profile - (fun () -> - match check_term_top g e topt must_tot gh ctx with - | Success (et, g) -> Success (et, g) - | Error err -> Error err) - None - "FStar.TypeChecker.Core.check_term_top" - in - ( - let res = - match res with - | Success (et, Some guard0) -> - // Options.push(); - // Options.set_option "debug" (Options.List [Options.String "Unfolding"]); - let guard = N.normalize simplify_steps g guard0 in - // Options.pop(); - if !dbg || !dbg_Top || !dbg_Exit - then begin - BU.print3 "(%s) Exiting core: Simplified guard from {{%s}} to {{%s}}\n" - (BU.string_of_int (get_goal_ctr())) - (show guard0) - (show guard); - let guard_names = Syntax.Free.names guard |> elems in - match List.tryFind (fun bv -> List.for_all (fun binding_env -> - match binding_env with - | Binding_var bv_env -> not (S.bv_eq bv_env bv) - | _ -> true) g.gamma) guard_names with - | Some bv -> - BU.print1 "WARNING: %s is free in the core generated guard\n" (show (S.bv_to_name bv)) - | _ -> () - end; - Success (et, Some guard) - - | Success _ -> - if !dbg || !dbg_Top - then BU.print1 "(%s) Exiting core (ok)\n" - (BU.string_of_int (get_goal_ctr())); - res - - | Error _ -> - if !dbg || !dbg_Top - then BU.print1 "(%s) Exiting core (failed)\n" - (BU.string_of_int (get_goal_ctr())); - res - in - if !dbg_Eq - then ( - THT.print_stats table; - let cs = report_cache_stats() in - BU.print2 "Cache_stats { hits = %s; misses = %s }\n" - (BU.string_of_int cs.hits) - (BU.string_of_int cs.misses) - ); - res - ) - -let check_term g e t must_tot = - match check_term_top_gh g e (Some t) must_tot None with - | Success (_, g) -> Inl g - | Error err -> Inr err - -let check_term_at_type g e t = - let must_tot = false in - match check_term_top_gh g e (Some t) must_tot None with - | Success ((eff, _), g) -> Inl (eff, g) - | Error err -> Inr err - -let compute_term_type_handle_guards g e gh = - let e = FStar.Syntax.Compress.deep_compress true true e in - let must_tot = false in - match check_term_top_gh g e None must_tot (Some gh) with - | Success (r, None) -> Inl r - | Success (_, Some _) -> failwith "Impossible: All guards should have been handled already" - | Error err -> Inr err - -let open_binders_in_term (env:Env.env) (bs:binders) (t:term) = - let g = initial_env env None in - let g', bs, t = open_term_binders g bs t in - g'.tcenv, bs, t - -let open_binders_in_comp (env:Env.env) (bs:binders) (c:comp) = - let g = initial_env env None in - let g', bs, c = open_comp_binders g bs c in - g'.tcenv, bs, c - -let check_term_equality guard_ok unfolding_ok g t0 t1 - = let g = initial_env g None in - if !dbg_Top then - BU.print4 "Entering check_term_equality with %s and %s (guard_ok=%s; unfolding_ok=%s) {\n" - (show t0) (show t1) (show guard_ok) (show unfolding_ok); - let ctx = { unfolding_ok = unfolding_ok; no_guard = not guard_ok; error_context = [("Eq", None)] } in - let r = check_relation g EQUALITY t0 t1 ctx in - if !dbg_Top then - BU.print3 "} Exiting check_term_equality (%s, %s). Result = %s.\n" (show t0) (show t1) (show r); - let r = - match r with - | Success (_, g) -> Inl g - | Error err -> Inr err - in - r - -let check_term_subtyping guard_ok unfolding_ok g t0 t1 - = let g = initial_env g None in - let ctx = { unfolding_ok = unfolding_ok; no_guard = not guard_ok; error_context = [("Subtyping", None)] } in - match check_relation g (SUBTYPING None) t0 t1 ctx with - | Success (_, g) -> Inl g - | Error err -> Inr err diff --git a/src/typechecker/FStar.TypeChecker.Core.fsti b/src/typechecker/FStar.TypeChecker.Core.fsti deleted file mode 100644 index 6f05e4fa321..00000000000 --- a/src/typechecker/FStar.TypeChecker.Core.fsti +++ /dev/null @@ -1,60 +0,0 @@ -module FStar.TypeChecker.Core -open FStar.Compiler.Util -open FStar.Syntax.Syntax -module Env = FStar.TypeChecker.Env -module S = FStar.Syntax.Syntax -module R = FStar.Compiler.Range -module U = FStar.Syntax.Util - -type tot_or_ghost = - | E_Total - | E_Ghost - -val clear_memo_table (_:unit) - : unit - -val error : Type0 - -type side = - | Left - | Right - | Both - | Neither - -instance val showable_side : Class.Show.showable side - -val maybe_relate_after_unfolding (g:Env.env) (t0 t1:term) : side - -val is_non_informative (g:Env.env) (t:typ) : bool - -val check_term (g:Env.env) (e:term) (t:typ) (must_tot:bool) - : either (option typ) error - -val check_term_at_type (g:Env.env) (e:term) (t:typ) - : either (tot_or_ghost & option typ) error - -val compute_term_type_handle_guards (g:Env.env) (e:term) - (discharge_guard: Env.env -> typ -> bool) - : either (tot_or_ghost & typ) error - -val open_binders_in_term (g:Env.env) (bs:binders) (t:term) - : Env.env & binders & term - -val open_binders_in_comp (g:Env.env) (bs:binders) (c:comp) - : Env.env & binders & comp - -(* For unit testing, and exposed to tactics *) -val check_term_equality (guard_ok:bool) (unfolding_ok:bool) (g:Env.env) (t0 t1:typ) - : either (option typ) error - -val check_term_subtyping (guard_ok:bool) (unfolding_ok:bool) (g:Env.env) (t0 t1:typ) - : either (option typ) error - -val print_error (err:error) - : string - -val print_error_short (err:error) - : string - -val get_goal_ctr (_:unit) : int -val incr_goal_ctr (_:unit) : int diff --git a/src/typechecker/FStar.TypeChecker.DMFF.fst b/src/typechecker/FStar.TypeChecker.DMFF.fst deleted file mode 100644 index 7407bdcfc6b..00000000000 --- a/src/typechecker/FStar.TypeChecker.DMFF.fst +++ /dev/null @@ -1,1701 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.TypeChecker.DMFF -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.TypeChecker -open FStar.TypeChecker.Common -open FStar.TypeChecker.Env -open FStar.Compiler.Util -open FStar.Ident -open FStar.Errors -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.Syntax.Subst -open FStar.Syntax.Util -open FStar.Const - -open FStar.Class.Show - -type env = { - // The type-checking environment which we abuse to store our DMFF-style types - // when entering a binder. - tcenv: FStar.TypeChecker.Env.env; - // The substitution from every [x: C] to its [x^w: C*]. - subst: list subst_elt; - // Hack to avoid a dependency - tc_const: sconst -> typ; -} - -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module N = FStar.TypeChecker.Normalize -module TcComm = FStar.TypeChecker.Common -module TcUtil = FStar.TypeChecker.Util -module TcTerm = FStar.TypeChecker.TcTerm -module BU = FStar.Compiler.Util //basic util -module U = FStar.Syntax.Util -module PC = FStar.Parser.Const -module TEQ = FStar.TypeChecker.TermEqAndSimplify - -open FStar.Class.Setlike - -let dbg = Debug.get_toggle "ED" - -let d s = BU.print1 "\x1b[01;36m%s\x1b[00m\n" s - -// Takes care of creating the [fv], generating the top-level let-binding, and -// return a term that's a suitable reference (a [Tm_fv]) to the definition -let mk_toplevel_definition (env: env_t) lident (def: term): sigelt & term = - // Debug - if !dbg then begin - d (string_of_lid lident); - BU.print2 "Registering top-level definition: %s\n%s\n" (show lident) (show def) - end; - // Allocate a new top-level name. - let fv = S.lid_and_dd_as_fv lident None in - let lbname: lbname = Inr fv in - let lb: letbindings = - // the effect label will be recomputed correctly - false, [U.mk_letbinding lbname [] S.tun PC.effect_Tot_lid def [] Range.dummyRange] - in - // [Inline] triggers a "Impossible: locally nameless" error // FIXME: Doc? - let sig_ctx = mk_sigelt (Sig_let {lbs=lb; lids=[ lident ]}) in - {sig_ctx with sigquals=[ Unfold_for_unification_and_vcgen ]}, - mk (Tm_fvar fv) Range.dummyRange - -let empty env tc_const = { - tcenv = env; - subst = []; - tc_const = tc_const -} - -// Synthesis of WPs from a partial effect definition (in F*) ------------------ - -let gen_wps_for_free - env (binders: binders) (a: bv) (wp_a: term) (ed: Syntax.eff_decl): - Syntax.sigelts & Syntax.eff_decl -= - // [wp_a] has been type-checked and contains universe unification variables; - // we want to re-use [wp_a] and make it re-generalize accordingly - let wp_a = N.normalize [Env.Beta; Env.EraseUniverses] env wp_a in - let a = { a with sort = N.normalize [ Env.EraseUniverses ] env a.sort } in - - // Debugging - let d s = BU.print1 "\x1b[01;36m%s\x1b[00m\n" s in - if !dbg then begin - d "Elaborating extra WP combinators"; - BU.print1 "wp_a is: %s\n" (show wp_a) - end; - - (* Consider the predicate transformer st_wp: - * let st_pre_h (heap:Type) = heap -> GTot Type0 - * let st_post_h (heap:Type) (a:Type) = a -> heap -> GTot Type0 - * let st_wp_h (heap:Type) (a:Type) = heap -> st_post_h heap a -> GTot Type0 - * after reduction we get: - * let st_wp_h (heap: Type) (a: Type) = heap -> (a -> heap -> GTot Type0) -> GTot Type0 - * we want: - * type st2_gctx (heap: Type) (a:Type) (t:Type) = heap -> (a -> heap -> GTot Type0) -> GTot t - * we thus generate macros parameterized over [e] that build the right - * context. [gamma] is the series of binders the precede the return type of - * the context. *) - let rec collect_binders (t : term) = - let t = U.unascribe t in - match (compress t).n with - | Tm_arrow {bs; comp} -> - // TODO: dubious, assert no nested arrows - let rest = match comp.n with - | Total t -> t - | _ -> raise_error comp Error_UnexpectedDM4FType - (BU.format1 "wp_a contains non-Tot arrow: %s" (show comp)) - in - bs @ (collect_binders rest) - | Tm_type _ -> - [] - | _ -> - raise_error t Error_UnexpectedDM4FType - (BU.format1 "wp_a doesn't end in Type0, but rather in %s" (show t)) - in - let mk_lid name : lident = U.dm4f_lid ed name in - - let gamma = collect_binders wp_a |> U.name_binders in - if !dbg then - d (BU.format1 "Gamma is %s\n" (show gamma)); - let unknown = S.tun in - let mk x = mk x Range.dummyRange in - - // The [register] function accumulates the top-level definitions that are - // generated in the course of producing WP combinators - let sigelts = BU.mk_ref [] in - let register env lident def = - let sigelt, fv = mk_toplevel_definition env lident def in - let sigelt = { sigelt with sigmeta={sigelt.sigmeta with sigmeta_admit=true}} in - sigelts := sigelt :: !sigelts; - fv - in - - (* Some helpers. *) - let binders_of_list = List.map (fun (t, b) -> S.mk_binder_with_attrs t (S.as_bqual_implicit b) None []) in - let mk_all_implicit = List.map (fun t -> { t with binder_qual=S.as_bqual_implicit true }) in - let args_of_binders = List.map (fun bv -> S.as_arg (S.bv_to_name bv.binder_bv)) in - - let env, mk_ctx, mk_gctx = - // Neither [ctx_def] or [gctx_def] take implicit arguments. - let ctx_def, gctx_def = - let mk f: term = - let t = S.gen_bv "t" None U.ktype in - let body = U.arrow gamma (f (S.bv_to_name t)) in - U.abs (binders @ [ S.mk_binder a; S.mk_binder t ]) body None - in - mk mk_Total, - mk mk_GTotal - in - // Register these two top-level bindings in the environment - let ctx_lid = mk_lid "ctx" in - let ctx_fv = register env ctx_lid ctx_def in - - let gctx_lid = mk_lid "gctx" in - let gctx_fv = register env gctx_lid gctx_def in - - let mk_app fv t = - // The [mk_ctx] and [mk_gctx] helpers therefore do not use implicits either - mk (Tm_app {hd=fv; - args=List.map (fun ({binder_bv=bv}) -> S.bv_to_name bv, S.as_aqual_implicit false) binders @ - [ S.bv_to_name a, S.as_aqual_implicit false; - t, S.as_aqual_implicit false ]}) - in - - env, mk_app ctx_fv, mk_app gctx_fv - in - - (* val st2_pure : #heap:Type -> #a:Type -> #t:Type -> x:t -> - Tot (st2_ctx heap a t) - let st2_pure #heap #a #t x = fun _post _h -> x *) - let c_pure = - let t = S.gen_bv "t" None U.ktype in - let x = S.gen_bv "x" None (S.bv_to_name t) in - let ret = Some (U.residual_tot (mk_ctx (S.bv_to_name t))) in - let body = U.abs gamma (S.bv_to_name x) ret in - U.abs (mk_all_implicit binders @ binders_of_list [ a, true; t, true; x, false ]) body ret - in - let c_pure = register env (mk_lid "pure") c_pure in - - (* val st2_app : #heap:Type -> #a:Type -> #t1:Type -> #t2:Type -> - l:st2_gctx heap a (t1 -> GTot t2) -> - r:st2_gctx heap a t1 -> - Tot (st2_gctx heap a t2) - let st2_app #heap #a #t1 #t2 l r = fun p h -> l p h (r p h) *) - let c_app = - let t1 = S.gen_bv "t1" None U.ktype in - let t2 = S.gen_bv "t2" None U.ktype in - let l = S.gen_bv "l" None (mk_gctx - (U.arrow [ S.mk_binder (S.new_bv None (S.bv_to_name t1)) ] (S.mk_GTotal (S.bv_to_name t2)))) - in - let r = S.gen_bv "r" None (mk_gctx (S.bv_to_name t1)) in - let ret = Some (U.residual_tot (mk_gctx (S.bv_to_name t2))) in - let outer_body = - let gamma_as_args = args_of_binders gamma in - let inner_body = - U.mk_app - (S.bv_to_name l) - (gamma_as_args @ [ S.as_arg (U.mk_app (S.bv_to_name r) gamma_as_args)]) - in - U.abs gamma inner_body ret - in - U.abs (mk_all_implicit binders @ binders_of_list [ a, true; t1, true; t2, true; l, false; r, false ]) outer_body ret - in - let c_app = register env (mk_lid "app") c_app in - - (* val st2_liftGA1 : #heap:Type -> #a:Type -> #t1:Type -> #t2:Type -> - f : (t1 -> GTot t2) -> - st2_gctx heap a t1 -> - Tot (st2_gctx heap a t2) - let st2_liftGA1 #heap #a #t1 #t2 f a1 = - st2_app (st2_pure f) a1 - *) - let c_lift1 = - let t1 = S.gen_bv "t1" None U.ktype in - let t2 = S.gen_bv "t2" None U.ktype in - let t_f = U.arrow [ S.null_binder (S.bv_to_name t1) ] (S.mk_GTotal (S.bv_to_name t2)) in - let f = S.gen_bv "f" None t_f in - let a1 = S.gen_bv "a1" None (mk_gctx (S.bv_to_name t1)) in - let ret = Some (residual_tot (mk_gctx (S.bv_to_name t2))) in - U.abs (mk_all_implicit binders @ binders_of_list [ a, true; t1, true; t2, true; f, false; a1, false ]) ( - U.mk_app c_app (List.map S.as_arg [ - U.mk_app c_pure (List.map S.as_arg [ S.bv_to_name f ]); - S.bv_to_name a1 ]) - ) ret - in - let c_lift1 = register env (mk_lid "lift1") c_lift1 in - - - (* val st2_liftGA2 : #heap:Type -> #a:Type -> #t1:Type -> #t2:Type -> #t3:Type -> - f : (t1 -> t2 -> GTot t3) -> - a1: st2_gctx heap a t1 -> - a2: st2_gctx heap a t2 -> - Tot (st2_gctx heap a t3) - let st2_liftGA2 #heap #a #t1 #t2 #t3 f a1 a2 = - st2_app (st2_app (st2_pure f) a1) a2 - *) - let c_lift2 = - let t1 = S.gen_bv "t1" None U.ktype in - let t2 = S.gen_bv "t2" None U.ktype in - let t3 = S.gen_bv "t3" None U.ktype in - let t_f = U.arrow - [ S.null_binder (S.bv_to_name t1); S.null_binder (S.bv_to_name t2) ] - (S.mk_GTotal (S.bv_to_name t3)) - in - let f = S.gen_bv "f" None t_f in - let a1 = S.gen_bv "a1" None (mk_gctx (S.bv_to_name t1)) in - let a2 = S.gen_bv "a2" None (mk_gctx (S.bv_to_name t2)) in - let ret = Some (U.residual_tot (mk_gctx (S.bv_to_name t3))) in - U.abs (mk_all_implicit binders @ binders_of_list [ a, true; t1, true; t2, true; t3, true; f, false; a1, false; a2, false ]) ( - U.mk_app c_app (List.map S.as_arg [ - U.mk_app c_app (List.map S.as_arg [ - U.mk_app c_pure (List.map S.as_arg [ S.bv_to_name f ]); - S.bv_to_name a1 ]); - S.bv_to_name a2 ]) - ) ret - in - let c_lift2 = register env (mk_lid "lift2") c_lift2 in - - (* val st2_push : #heap:Type -> #a:Type -> #t1:Type -> #t2:Type -> - f:(t1 -> Tot (st2_gctx heap a t2)) -> - Tot (st2_ctx heap a (t1->GTot t2)) - let st2_push #heap #a #t1 #t2 f = fun p h e1 -> f e1 p h *) - let c_push = - let t1 = S.gen_bv "t1" None U.ktype in - let t2 = S.gen_bv "t2" None U.ktype in - let t_f = U.arrow - [ S.null_binder (S.bv_to_name t1) ] - (S.mk_Total (mk_gctx (S.bv_to_name t2))) - in - let f = S.gen_bv "f" None t_f in - let ret = Some (U.residual_tot (mk_ctx (U.arrow [ S.null_binder (S.bv_to_name t1) ] (S.mk_GTotal (S.bv_to_name t2))))) in - let e1 = S.gen_bv "e1" None (S.bv_to_name t1) in - let body = U.abs (gamma @ [ S.mk_binder e1 ]) ( - U.mk_app (S.bv_to_name f) (S.as_arg (S.bv_to_name e1) :: args_of_binders gamma) - ) ret in - U.abs (mk_all_implicit binders @ binders_of_list [ a, true; t1, true; t2, true; f, false ]) body ret - in - let c_push = register env (mk_lid "push") c_push in - - let ret_tot_wp_a = Some (U.residual_tot wp_a) in - let mk_generic_app c = - if List.length binders > 0 then - mk (Tm_app {hd=c; args=args_of_binders binders}) - else - c - in - - (* val st2_if_then_else : heap:Type -> a:Type -> c:Type0 -> - st2_wp heap a -> st2_wp heap a -> - Tot (st2_wp heap a) - let st2_if_then_else heap a c = st2_liftGA2 (l_ITE c) *) - let wp_if_then_else = - let result_comp = (mk_Total ((U.arrow [ S.null_binder wp_a; S.null_binder wp_a ] (mk_Total wp_a)))) in - let c = S.gen_bv "c" None U.ktype in - U.abs (binders @ S.binders_of_list [ a; c ]) ( - let l_ite = fvar_with_dd PC.ite_lid None in - U.ascribe ( - U.mk_app c_lift2 (List.map S.as_arg [ - U.mk_app l_ite [S.as_arg (S.bv_to_name c)] - ]) - ) (Inr result_comp, None, false) - ) (Some (U.residual_comp_of_comp result_comp)) - in - let wp_if_then_else = register env (mk_lid "wp_if_then_else") wp_if_then_else in - let wp_if_then_else = mk_generic_app wp_if_then_else in - - (* val st2_close_wp : heap:Type -> a:Type -> b:Type -> - f:(b->Tot (st2_wp heap a)) -> - Tot (st2_wp heap a) - let st2_close_wp heap a b f = st2_app (st2_pure l_Forall) (st2_push f) *) - let wp_close = - let b = S.gen_bv "b" None U.ktype in - let t_f = U.arrow [ S.null_binder (S.bv_to_name b) ] (S.mk_Total wp_a) in - let f = S.gen_bv "f" None t_f in - let body = - U.mk_app c_app (List.map S.as_arg [ - U.mk_app c_pure (List.map S.as_arg [ U.tforall ]); - U.mk_app c_push (List.map S.as_arg [ S.bv_to_name f ])]) - in - U.abs (binders @ S.binders_of_list [ a; b; f ]) body ret_tot_wp_a - in - let wp_close = register env (mk_lid "wp_close") wp_close in - let wp_close = mk_generic_app wp_close in - - let ret_tot_type = Some (U.residual_tot U.ktype) in - let ret_gtot_type = Some (TcComm.residual_comp_of_lcomp (TcComm.lcomp_of_comp <| S.mk_GTotal U.ktype)) in - let mk_forall (x: S.bv) (body: S.term): S.term = - S.mk (Tm_app {hd=U.tforall; args=[ S.as_arg (U.abs [ S.mk_binder x ] body ret_tot_type)]}) Range.dummyRange - in - - (* For each (target) type t, we define a binary relation in t called ≤_t. - - x ≤_t y =def= x = y [t is base type] - x ≤_Type0 y =def= x ==> y - x ≤_{a->b} y =def= ∀a1 : a, x a1 ≤_b y a1 if is_monotonic a - ∀a1 a2, a1 ≤_a a2 ==> x a1 ≤_b y a2 otherwise - *) - (* Invariant: [x] and [y] have type [t] *) - let rec is_discrete t = match (SS.compress t).n with - | Tm_type _ -> false - | Tm_arrow {bs; comp=c} -> List.for_all (fun ({binder_bv=b}) -> is_discrete b.sort) bs && is_discrete (U.comp_result c) - | _ -> true - in - let rec is_monotonic t = match (SS.compress t).n with - | Tm_type _ -> true - | Tm_arrow {bs; comp=c} -> List.for_all (fun ({binder_bv=b}) -> is_discrete b.sort) bs && is_monotonic (U.comp_result c) - | _ -> is_discrete t - in - let rec mk_rel rel t x y = - let mk_rel = mk_rel rel in - let t = N.normalize [ Env.Beta; Env.Eager_unfolding; Env.DontUnfoldAttr [PC.tac_opaque_attr]; Env.UnfoldUntil S.delta_constant ] env t in - match (SS.compress t).n with - | Tm_type _ -> - (* BU.print2 "type0, x=%s, y=%s\n" (show x) (show y); *) - rel x y - | Tm_arrow {bs=[ binder ]; comp={ n = GTotal b }} - | Tm_arrow {bs=[ binder ]; comp={ n = Total b }} -> - let a = binder.binder_bv.sort in - if is_monotonic a || is_monotonic b //this is an important special case; most monads have zero-order results - then let a1 = S.gen_bv "a1" None a in - let body = mk_rel b - (U.mk_app x [ S.as_arg (S.bv_to_name a1) ]) - (U.mk_app y [ S.as_arg (S.bv_to_name a1) ]) in - mk_forall a1 body - else - (* BU.print2 "arrow, a=%s, b=%s\n" (show a) (show b); *) - let a1 = S.gen_bv "a1" None a in - let a2 = S.gen_bv "a2" None a in - let body = U.mk_imp - (mk_rel a (S.bv_to_name a1) (S.bv_to_name a2)) - (mk_rel b - (U.mk_app x [ S.as_arg (S.bv_to_name a1) ]) - (U.mk_app y [ S.as_arg (S.bv_to_name a2) ])) - in - mk_forall a1 (mk_forall a2 body) - | Tm_arrow {bs=binder :: binders; comp} -> - (* split away the first binder and recurse, so we fall in the case above *) - let t = { t with n = Tm_arrow {bs=[ binder ]; comp=S.mk_Total (U.arrow binders comp)} } in - mk_rel t x y - | Tm_arrow {bs=[]} -> - failwith "impossible: arrow with empty binders" - | _ -> - (* TODO: assert that this is a base type. *) - (* BU.print2 "base, x=%s, y=%s\n" (show x) (show y); *) - U.mk_untyped_eq2 x y - in - let stronger = - let wp1 = S.gen_bv "wp1" None wp_a in - let wp2 = S.gen_bv "wp2" None wp_a in - let rec mk_stronger t x y = - let t = N.normalize [ Env.Beta; Env.Eager_unfolding; Env.DontUnfoldAttr [PC.tac_opaque_attr]; Env.UnfoldUntil S.delta_constant ] env t in - match (SS.compress t).n with - | Tm_type _ -> U.mk_imp x y - | Tm_app {hd=head; args} when is_tuple_constructor (SS.compress head) -> - let project i tuple = - (* TODO : I guess a projector shouldn't be handled as a constant... *) - let projector = S.fvar_with_dd (Env.lookup_projector env (PC.mk_tuple_data_lid (List.length args) Range.dummyRange) i) None in - mk_app projector [tuple, None] - in - let (rel0,rels) = - match List.mapi (fun i (t, q) -> mk_stronger t (project i x) (project i y)) args with - | [] -> failwith "Impossible: empty application when creating stronger relation in DM4F" - | rel0 :: rels -> rel0, rels - in - List.fold_left U.mk_conj rel0 rels - | Tm_arrow {bs=binders; comp={ n = GTotal b }} - | Tm_arrow {bs=binders; comp={ n = Total b }} -> - let bvs = List.mapi (fun i ({binder_bv=bv;binder_qual=q}) -> S.gen_bv ("a" ^ string_of_int i) None bv.sort) binders in - let args = List.map (fun ai -> S.as_arg (S.bv_to_name ai)) bvs in - let body = mk_stronger b (U.mk_app x args) (U.mk_app y args) in - List.fold_right (fun bv body -> mk_forall bv body) bvs body - | _ -> - failwith "Not a DM elaborated type" - in - let body = mk_stronger (U.unascribe wp_a) (S.bv_to_name wp1) (S.bv_to_name wp2) in - U.abs (binders @ binders_of_list [ a, false; wp1, false; wp2, false ]) body ret_tot_type - in - let stronger = register env (mk_lid "stronger") stronger in - let stronger = mk_generic_app stronger in - - let ite_wp = - let wp = S.gen_bv "wp" None wp_a in - let wp_args, post = BU.prefix gamma in - // forall k: post a - let k = S.gen_bv "k" None post.binder_bv.sort in - let equiv = - let open FStar.Syntax.Formula in - let k_tm = S.bv_to_name k in - let eq = mk_rel U.mk_iff k.sort - k_tm - (S.bv_to_name post.binder_bv) in - match destruct_typ_as_formula eq with - | Some (QAll (binders, [], body)) -> - let k_app = U.mk_app k_tm (args_of_binders binders) in - let guard_free = S.fv_to_tm (S.lid_and_dd_as_fv PC.guard_free None) in - let pat = U.mk_app guard_free [as_arg k_app] in - let pattern_guarded_body = - mk (Tm_meta {tm=body; meta=Meta_pattern(binders_to_names binders, [[as_arg pat]])}) in - U.close_forall_no_univs binders pattern_guarded_body - | _ -> failwith "Impossible: Expected the equivalence to be a quantified formula" - in - let body = U.abs gamma ( - U.mk_forall_no_univ k (U.mk_imp - equiv - (U.mk_app (S.bv_to_name wp) (args_of_binders wp_args @ [ S.as_arg (S.bv_to_name k) ]))) - ) ret_gtot_type in - U.abs (binders @ S.binders_of_list [ a; wp ]) body ret_gtot_type - in - let ite_wp = register env (mk_lid "ite_wp") ite_wp in - let ite_wp = mk_generic_app ite_wp in - - let null_wp = - let wp = S.gen_bv "wp" None wp_a in - let wp_args, post = BU.prefix gamma in - let x = S.gen_bv "x" None S.tun in - let body = U.mk_forall_no_univ x (U.mk_app (S.bv_to_name <| post.binder_bv) [as_arg (S.bv_to_name x)]) in - U.abs (binders @ S.binders_of_list [ a ] @ gamma) body ret_gtot_type in - - let null_wp = register env (mk_lid "null_wp") null_wp in - let null_wp = mk_generic_app null_wp in - - (* val st2_trivial : heap:Type ->a:Type -> st2_wp heap a -> Tot Type0 - let st2_trivial heap a wp = st2_stronger heap a (st2_null_wp heap a) wp *) - let wp_trivial = - let wp = S.gen_bv "wp" None wp_a in - let body = U.mk_app stronger (List.map S.as_arg [ - S.bv_to_name a; - U.mk_app null_wp [ S.as_arg (S.bv_to_name a) ]; - S.bv_to_name wp - ]) in - U.abs (binders @ S.binders_of_list [ a; wp ]) body ret_tot_type - in - let wp_trivial = register env (mk_lid "wp_trivial") wp_trivial in - let wp_trivial = mk_generic_app wp_trivial in - - if !dbg then - d "End Dijkstra monads for free"; - - let c = close binders in - let ed_combs = match ed.combinators with - | DM4F_eff combs -> - DM4F_eff ({ combs with - stronger = ([], c stronger); - if_then_else = ([], c wp_if_then_else); - ite_wp = ([], c ite_wp); - close_wp = ([], c wp_close); - trivial = ([], c wp_trivial) }) - | _ -> failwith "Impossible! For a DM4F effect combinators must be in DM4f_eff" in - - List.rev !sigelts, { ed with combinators = ed_combs } - - -// Some helpers for... -------------------------------------------------------- -type env_ = env - -let get_env env = env.tcenv -let set_env dmff_env env' = { dmff_env with tcenv = env' } - -type nm = | N of typ | M of typ - -type nm_ = nm - -let nm_of_comp c = match c.n with - | Total t -> - N t - | Comp c when c.flags |> BU.for_some (function CPS -> true | _ -> false) -> - //lid_equals c.effect_name PC.monadic_lid -> - M c.result_typ - | _ -> - raise_error c Error_UnexpectedDM4FType - (BU.format1 "[nm_of_comp]: unexpected computation type %s" (show c)) - -let string_of_nm = function - | N t -> BU.format1 "N[%s]" (show t) - | M t -> BU.format1 "M[%s]" (show t) - -let is_monadic_arrow n = - match n with - | Tm_arrow {comp=c} -> - nm_of_comp c - | _ -> - failwith "unexpected_argument: [is_monadic_arrow]" - -let is_monadic_comp c = - match nm_of_comp c with - | M _ -> true - | N _ -> false - - -exception Not_found - -// ... the _ and * transformations from the definition language to F* --------- - -let double_star typ = - let star_once typ = U.arrow [S.mk_binder <| S.new_bv None typ] (S.mk_Total U.ktype0) in - star_once <| typ |> star_once - -let rec mk_star_to_type mk env a = - mk (Tm_arrow {bs=[S.mk_binder_with_attrs (S.null_bv (star_type' env a)) (S.as_bqual_implicit false) None []]; - comp=mk_Total U.ktype0}) - -// The *-transformation for types, purely syntactic. Has been enriched with the -// [Tm_abs] case to account for parameterized types - -and star_type' env t = - let mk x = mk x t.pos in - let mk_star_to_type = mk_star_to_type mk in - //BU.print1 "[debug]: star_type' %s\n" (show t); - let t = SS.compress t in - match t.n with - | Tm_arrow {bs=binders} -> - // TODO: check that this is not a dependent arrow. - let binders = List.map (fun b -> - {b with binder_bv={b.binder_bv with sort = star_type' env b.binder_bv.sort}} - ) binders in - (* Catch the GTotal case early; it seems relatively innocuous to allow - * GTotal to appear. TODO fix this as a clean, single pattern-matching. *) - begin match t.n with - | Tm_arrow {comp={ n = GTotal hn }} -> - mk (Tm_arrow {bs=binders; comp=mk_GTotal (star_type' env hn)}) - | _ -> - match is_monadic_arrow t.n with - | N hn -> - // Simple case: - // (H_0 -> ... -> H_n)* = H_0* -> ... -> H_n* - mk (Tm_arrow {bs=binders; comp=mk_Total (star_type' env hn)}) - | M a -> - // F*'s arrows are n-ary (and the intermediary arrows are pure), so the rule is: - // (H_0 -> ... -> H_n -t-> A)* = H_0* -> ... -> H_n* -> (A* -> Type) -> Type - mk (Tm_arrow { - bs=binders @ [ S.mk_binder_with_attrs (S.null_bv (mk_star_to_type env a)) - (S.as_bqual_implicit false) None []]; - comp=mk_Total U.ktype0}) - end - - | Tm_app {hd=head; args} -> - // Sums and products. TODO: re-use the cache in [env] to not recompute - // (st a)* every time. - let debug (t : term) (s : FlatSet.t bv) = - Errors.log_issue t Errors.Warning_DependencyFound (BU.format2 "Dependency found in term %s : %s" (show t) (show s)) - in - let rec is_non_dependent_arrow ty n = - match (SS.compress ty).n with - | Tm_arrow {bs=binders; comp=c} -> begin - if not (U.is_tot_or_gtot_comp c) - then false - else - try - let non_dependent_or_raise s ty = - let sinter = inter (Free.names ty) s in - if not (is_empty sinter) - then (debug ty sinter ; raise Not_found) - in - let binders, c = SS.open_comp binders c in - let s = List.fold_left (fun s ({binder_bv=bv}) -> - non_dependent_or_raise s bv.sort ; - add bv s - ) (Class.Setlike.empty ()) binders in - let ct = U.comp_result c in - non_dependent_or_raise s ct ; - let k = n - List.length binders in - if k > 0 then is_non_dependent_arrow ct k else true - with Not_found -> false - end - | _ -> - Errors.log_issue ty Errors.Warning_NotDependentArrow (BU.format1 "Not a dependent arrow : %s" (show ty)); - false - in - let rec is_valid_application head = - match (SS.compress head).n with - | Tm_fvar fv when ( - // TODO: implement a better check (non-dependent, user-defined data type) - fv_eq_lid fv PC.option_lid || - fv_eq_lid fv PC.either_lid || - fv_eq_lid fv PC.eq2_lid || - is_tuple_constructor (SS.compress head) - ) -> - true - | Tm_fvar fv -> - let (_, ty), _ = Env.lookup_lid env.tcenv fv.fv_name.v in - if is_non_dependent_arrow ty (List.length args) - then - // We need to check that the result of the application is a datatype - let res = N.normalize [Env.EraseUniverses; Env.Inlining ; Env.DontUnfoldAttr [PC.tac_opaque_attr]; Env.UnfoldUntil S.delta_constant] env.tcenv t in - begin match (SS.compress res).n with - | Tm_app _ -> true - | _ -> - Errors.log_issue head Errors.Warning_NondependentUserDefinedDataType (BU.format1 "Got a term which might be a non-dependent user-defined data-type %s\n" (show head)); - false - end - else false - | Tm_bvar _ - | Tm_name _ -> - true - | Tm_uinst (t, _) -> - is_valid_application t - | _ -> - false - in - if is_valid_application head then - mk (Tm_app {hd=head; args=List.map (fun (t, qual) -> star_type' env t, qual) args}) - else - raise_error0 Errors.Fatal_WrongTerm - (BU.format1 "For now, only [either], [option] and [eq2] are supported in the definition language (got: %s)" - (show t)) - - | Tm_bvar _ - | Tm_name _ - | Tm_type _ // TODO: does [Tm_type] make sense? - | Tm_fvar _ -> - t - - | Tm_abs {bs=binders; body=repr; rc_opt=something} -> - // For parameterized data types... TODO: check that this only appears at - // top-level - let binders, repr = SS.open_term binders repr in - let env = { env with tcenv = push_binders env.tcenv binders } in - let repr = star_type' env repr in - U.abs binders repr something - - | Tm_refine {b=x; phi=t} when false -> - let x = freshen_bv x in - let sort = star_type' env x.sort in - let subst = [DB(0, x)] in - let t = SS.subst subst t in - let t = star_type' env t in - let subst = [NM(x, 0)] in - let t = SS.subst subst t in - mk (Tm_refine {b={ x with sort = sort }; phi=t}) - - | Tm_meta {tm=t; meta=m} -> - mk (Tm_meta {tm=star_type' env t; meta=m}) - - | Tm_ascribed {tm=e; asc=(Inl t, None, use_eq); eff_opt=something} -> - mk (Tm_ascribed {tm=star_type' env e; asc=(Inl (star_type' env t), None, use_eq); eff_opt=something}) - - | Tm_ascribed {tm=e; asc=(Inr c, None, use_eq); eff_opt=something} -> - mk (Tm_ascribed {tm=star_type' env e; - asc=(Inl (star_type' env (U.comp_result c)), None, use_eq); - eff_opt=something}) //AR: this should effectively be the same, the effect checking for c should have done someplace else? - (*raise_error0 (Errors.Fatal_TermOutsideOfDefLanguage, (BU.format1 "Tm_ascribed is outside of the definition language: %s" - (show t)))*) - - | Tm_ascribed {asc=(_, Some _, _)} -> - raise_error0 Errors.Fatal_TermOutsideOfDefLanguage - (BU.format1 "Ascriptions with tactics are outside of the definition language: %s" (show t)) - | Tm_refine _ - | Tm_uinst _ - | Tm_quoted _ - | Tm_constant _ - | Tm_match _ - | Tm_let _ - | Tm_uvar _ - | Tm_unknown -> - let open FStar.Class.Tagged in - raise_error0 Errors.Fatal_TermOutsideOfDefLanguage - (BU.format2 "%s is outside of the definition language: %s" (tag_of t) (show t)) - - | Tm_lazy i -> star_type' env (U.unfold_lazy i) - - | Tm_delayed _ -> - failwith "impossible" - - -// The bi-directional *-transformation and checker for expressions ------------ - -let is_monadic = function - | None -> - failwith "un-annotated lambda?!" - | Some rc -> - rc.residual_flags |> BU.for_some (function CPS -> true | _ -> false) - -// TODO: this function implements a (partial) check for the well-formedness of -// C-types... -// This function expects its argument [t] to be normalized. -let rec is_C (t: typ): bool = - match (SS.compress t).n with - // TODO: deal with more than tuples? - | Tm_app {hd=head; args} when U.is_tuple_constructor head -> - let r = is_C (fst (List.hd args)) in - if r then begin - if not (List.for_all (fun (h, _) -> is_C h) args) then - raise_error t Error_UnexpectedDM4FType - (BU.format1 "Not a C-type (A * C): %s" (show t)); - true - end else begin - if not (List.for_all (fun (h, _) -> not (is_C h)) args) then - raise_error t Error_UnexpectedDM4FType - (BU.format1 "Not a C-type (C * A): %s" (show t)); - false - end - | Tm_arrow {bs=binders; comp} -> - begin match nm_of_comp comp with - | M t -> - if (is_C t) then - raise_error t Error_UnexpectedDM4FType - (BU.format1 "Not a C-type (C -> C): %s" (show t)); - true - | N t -> - // assert (List.exists is_C binders) ==> is_C comp - is_C t - end - | Tm_meta {tm=t} - | Tm_uinst (t, _) - | Tm_ascribed {tm=t} -> - is_C t - | _ -> - false - - -// This function assumes [e] has been starred already and returns: -// [fun (p: t* -> Type) -> p e] -let mk_return env (t: typ) (e: term) = - let mk x = mk x e.pos in - let p_type = mk_star_to_type mk env t in - let p = S.gen_bv "p'" None p_type in - let body = mk (Tm_app {hd=S.bv_to_name p; args=[ e, S.as_aqual_implicit false ]}) in - U.abs [ S.mk_binder p ] body (Some (U.residual_tot U.ktype0)) - -let is_unknown = function | Tm_unknown -> true | _ -> false - -// [check] takes four kinds of [nm]. -// - [N Tm_unknown] checks that the computation is pure and returns [N t] where -// [t] is the inferred type of the original term; -// - [M Tm_unknown] checks that the computation is monadic and returns [N t] -// where [t] is the inferred type of the original term; -// - [N T] checks that the computation is pure, has type T, and returns [N t]; -// - [M T] checks that the computation is monadic, has type T, and returns [M t]; -// [check] returns two terms: -// - the first is [e*], the CPS'd version of [e] -// - the second is [_e_], the elaborated version of [e] -let rec check (env: env) (e: term) (context_nm: nm): nm & term & term = - // BU.print1 "[debug]: check %s\n" (show e); - // [s_e] as in "starred e"; [u_e] as in "underlined u" (per the paper) - let return_if (rec_nm, s_e, u_e) = - let check t1 t2 = - if not (is_unknown t2.n) && not (Env.is_trivial (Rel.teq env.tcenv t1 t2)) then - raise_error0 Errors.Fatal_TypeMismatch - (BU.format3 "[check]: the expression [%s] has type [%s] but should have type [%s]" (show e) (show t1) (show t2)) - in - match rec_nm, context_nm with - | N t1, N t2 - | M t1, M t2 -> - check t1 t2; - rec_nm, s_e, u_e - | N t1, M t2 -> - check t1 t2; - // no need to wrap [u_e] in an explicit [return]; F* will infer it later on - M t1, mk_return env t1 s_e, u_e - | M t1, N t2 -> - raise_error0 Errors.Fatal_EffectfulAndPureComputationMismatch - (BU.format3 "[check %s]: got an effectful computation [%s] in lieu of a pure computation [%s]" (show e) (show t1) (show t2)) - - in - - let ensure_m (env: env_) (e2: term): term & term & term = - let strip_m = function - | M t, s_e, u_e -> t, s_e, u_e - | _ -> failwith "impossible" - in - match context_nm with - | N t -> raise_error e2 Errors.Fatal_LetBoundMonadicMismatch - ("let-bound monadic body has a non-monadic continuation or a branch of a match is monadic and the others aren't : " ^ show t) - | M _ -> strip_m (check env e2 context_nm) - in - - match (SS.compress e).n with - | Tm_bvar _ - | Tm_name _ - | Tm_fvar _ - | Tm_abs _ - | Tm_constant _ - | Tm_quoted _ - | Tm_app _ -> - return_if (infer env e) - - | Tm_lazy i -> - check env (U.unfold_lazy i) context_nm - - | Tm_let {lbs=(false, [ binding ]); body=e2} -> - mk_let env binding e2 - // Body of the let is pure: just defer the check to the continuation - (fun env e2 -> check env e2 context_nm) - // Body of the let is monadic: this is a bind, and we must strengthen - // the check on the continuation to ensure it is a monadic computation - ensure_m - - | Tm_match {scrutinee=e0; brs=branches} -> - // This is similar to the [let] case above. The [match] checks that the - // types of the branches work; it also demands that the scrutinee be a - // non-monadic computation. - mk_match env e0 branches (fun env body -> check env body context_nm) - - | Tm_meta {tm=e} - | Tm_uinst (e, _) - | Tm_ascribed {tm=e} -> - (* TODO : reinstall the type annotation *) - check env e context_nm - - | Tm_let _ -> - failwith (BU.format1 "[check]: Tm_let %s" (show e)) - | Tm_type _ -> - failwith "impossible (DM stratification)" - | Tm_arrow _ -> - failwith "impossible (DM stratification)" - | Tm_refine _ -> - failwith (BU.format1 "[check]: Tm_refine %s" (show e)) - | Tm_uvar _ -> - failwith (BU.format1 "[check]: Tm_uvar %s" (show e)) - | Tm_delayed _ -> - failwith "impossible (compressed)" - | Tm_unknown -> - failwith (BU.format1 "[check]: Tm_unknown %s" (show e)) - - -and infer (env: env) (e: term): nm & term & term = - // BU.print1 "[debug]: infer %s\n" (show e); - let mk x = mk x e.pos in - let normalize = N.normalize [ Env.Beta; Env.Eager_unfolding; Env.DontUnfoldAttr [PC.tac_opaque_attr]; Env.UnfoldUntil S.delta_constant; Env.EraseUniverses ] env.tcenv in - match (SS.compress e).n with - | Tm_bvar bv -> - failwith "I failed to open a binder... boo" - - | Tm_name bv -> - N bv.sort, e, e - - | Tm_lazy i -> - infer env (U.unfold_lazy i) - - | Tm_abs {bs=binders;body;rc_opt} -> - let subst_rc_opt subst rc_opt = - match rc_opt with - | Some {residual_typ=None} - | None -> rc_opt - | Some rc -> Some ({rc with residual_typ=Some (SS.subst subst (BU.must rc.residual_typ))}) in - - //NS: note, this is explicitly written with opening binders - // rather than U.abs_formals - // since the specific number of binders to open is determined very syntactically - // We do not want to collapse (fun x -> (fun y -> e)) into (fun x y -> e) - // since this changes the way the selectve CPS transform works - let binders = SS.open_binders binders in - let subst = SS.opening_of_binders binders in - let body = SS.subst subst body in - let rc_opt = subst_rc_opt subst rc_opt in - let env = { env with tcenv = push_binders env.tcenv binders } in - - // For the *-translation, [x: t] becomes [x: t*]. - let s_binders = List.map (fun b -> - let sort = star_type' env b.binder_bv.sort in - {b with binder_bv = { b.binder_bv with sort = sort } } - ) binders in - - // For the _-translation, things are a little bit trickier. We need to - // update the substitution, and one binder may turn into two binders. - let env, u_binders = List.fold_left (fun (env, acc) ({binder_bv=bv}) -> - let c = bv.sort in - if is_C c then - let xw = S.gen_bv ((string_of_id bv.ppname) ^ "__w") None (star_type' env c) in - let x = { bv with sort = trans_F_ env c (S.bv_to_name xw) } in - let env = { env with subst = NT (bv, S.bv_to_name xw) :: env.subst } in - env, S.mk_binder x :: S.mk_binder xw :: acc - else - let x = { bv with sort = star_type' env bv.sort } in - env, S.mk_binder x :: acc - ) (env, []) binders in - let u_binders = List.rev u_binders in - - (* - BU.print2_warning "Term %s ::: what %s \n" - (show body) - (Print.abs_ascription_to_string what) ; - *) - - let comp, s_body, u_body = - let check_what = if is_monadic rc_opt then check_m else check_n in - let t, s_body, u_body = check_what env body in - comp_of_nm (if is_monadic rc_opt then M t else N t), s_body, u_body - in - - // From [comp], the inferred computation type for the (original), return - // the inferred type for the original term. - let t = U.arrow binders comp in - - let s_rc_opt = match rc_opt with - | None -> None // That should not happen according to some other comment - | Some rc -> begin - match rc.residual_typ with - | None -> - let rc = - if rc.residual_flags |> BU.for_some (function CPS -> true | _ -> false) - then U.mk_residual_comp PC.effect_Tot_lid None (List.filter (function CPS -> false | _ -> true) rc.residual_flags) - else rc in - Some rc - - | Some rt -> - let rt = N.normalize [ Env.Beta; Env.Eager_unfolding; Env.DontUnfoldAttr [PC.tac_opaque_attr]; Env.UnfoldUntil S.delta_constant; Env.EraseUniverses ] (get_env env) rt in - if rc.residual_flags |> BU.for_some (function CPS -> true | _ -> false) - then - let flags = List.filter (function CPS -> false | _ -> true) rc.residual_flags in - Some (U.mk_residual_comp PC.effect_Tot_lid (Some (double_star rt)) flags) - else Some ({rc with residual_typ = Some (star_type' env rt)}) - end - - in - - let u_body, u_rc_opt = - let comp = trans_G env (U.comp_result comp) (is_monadic rc_opt) (SS.subst env.subst s_body) in - (* TODO : consider removing this ascription *) - U.ascribe u_body (Inr comp, None, false), - Some (U.residual_comp_of_comp comp) - in - - - let s_body = close s_binders s_body in - let s_binders = close_binders s_binders in - let s_term = mk (Tm_abs {bs=s_binders; body=s_body; rc_opt=subst_rc_opt (Subst.closing_of_binders s_binders) s_rc_opt}) in - - let u_body = close u_binders u_body in - let u_binders = close_binders u_binders in - let u_term = mk (Tm_abs {bs=u_binders; body=u_body; rc_opt=subst_rc_opt (Subst.closing_of_binders u_binders) u_rc_opt}) in - - N t, s_term, u_term - - | Tm_fvar { fv_name = { v = lid } } -> - let _, t = fst <| Env.lookup_lid env.tcenv lid in - // Need to erase universes here! This is an F* type that is fully annotated. - N (normalize t), e, e - - (* Unary operators. Explicitly curry extra arguments *) - | Tm_app {hd={n=Tm_constant Const_range_of}; args=a::hd::rest} -> - let rest = hd::rest in //no 'as' clauses in F* yet, so we need to do this ugliness - let unary_op, _ = U.head_and_args e in - let head = mk (Tm_app {hd=unary_op; args=[a]}) in - let t = mk (Tm_app {hd=head; args=rest}) in - infer env t - - (* Binary operators *) - | Tm_app {hd={n=Tm_constant Const_set_range_of}; args=a1::a2::hd::rest} -> - let rest = hd::rest in //no 'as' clauses in F* yet, so we need to do this ugliness - let unary_op, _ = U.head_and_args e in - let head = mk (Tm_app {hd=unary_op; args=[a1; a2]}) in - let t = mk (Tm_app {hd=head; args=rest}) in - infer env t - - | Tm_app {hd={n=Tm_constant Const_range_of}; args=[(a, None)]} -> - let t, s, u = infer env a in - let head,_ = U.head_and_args e in - N (tabbrev PC.range_lid), - mk (Tm_app {hd=head; args=[S.as_arg s]}), - mk (Tm_app {hd=head; args=[S.as_arg u]}) - - | Tm_app {hd={n=Tm_constant Const_set_range_of}; args=(a1, _)::a2::[]} -> - let t, s, u = infer env a1 in - let head,_ = U.head_and_args e in - t, - mk (Tm_app {hd=head; args=[S.as_arg s; a2]}), - mk (Tm_app {hd=head; args=[S.as_arg u; a2]}) - - | Tm_app {hd={n=Tm_constant Const_range_of}} - | Tm_app {hd={n=Tm_constant Const_set_range_of}} -> - raise_error e Errors.Fatal_IllAppliedConstant (BU.format1 "DMFF: Ill-applied constant %s" (show e)) - - | Tm_app {hd=head; args} -> - let t_head, s_head, u_head = check_n env head in - let is_arrow t = match (SS.compress t).n with | Tm_arrow _ -> true | _ -> false in - // TODO: replace with BU.arrow_formals_comp - let rec flatten t = match (SS.compress t).n with - | Tm_arrow {bs=binders; comp={ n = Total t }} when is_arrow t -> - let binders', comp = flatten t in - binders @ binders', comp - | Tm_arrow {bs=binders; comp} -> - binders, comp - | Tm_ascribed {tm=e} -> - flatten e - | _ -> - raise_error0 Errors.Fatal_NotFunctionType (BU.format1 "%s: not a function type" (show t_head)) - in - let binders, comp = flatten t_head in - // BU.print1 "[debug] type of [head] is %s\n" (show t_head); - - // Making the assumption here that [Tm_arrow (..., Tm_arrow ...)] - // implies [is_M comp]. F* should be fixed if it's not the case. - let n = List.length binders in - let n' = List.length args in - if List.length binders < List.length args then - raise_error0 Errors.Fatal_BinderAndArgsLengthMismatch (BU.format3 "The head of this application, after being applied to %s \ - arguments, is an effectful computation (leaving %s arguments to be \ - applied). Please let-bind the head applied to the %s first \ - arguments." (string_of_int n) (string_of_int (n' - n)) (show n)); - // BU.print2 "[debug] length binders=%s, length args=%s\n" - // (string_of_int n) (string_of_int n'); - - let binders, comp = SS.open_comp binders comp in - let rec final_type subst (binders, comp) args = - match binders, args with - | [], [] -> - nm_of_comp (SS.subst_comp subst comp) - | binders, [] -> - begin match (SS.compress (SS.subst subst (mk (Tm_arrow {bs=binders; comp})))).n with - | Tm_arrow {bs=binders; comp} -> N (mk (Tm_arrow {bs=binders; comp=close_comp binders comp})) - | _ -> failwith "wat?" - end - | [], _ :: _ -> - failwith "just checked that?!" - | ({binder_bv=bv}) :: binders, (arg, _) :: args -> - final_type (NT (bv, arg) :: subst) (binders, comp) args - in - let final_type = final_type [] (binders, comp) args in - // BU.print1 "[debug]: final type of application is %s\n" (string_of_nm final_type); - - let binders, _ = List.splitAt n' binders in - - let s_args, u_args = List.split (List.map2 (fun ({binder_bv=bv}) (arg, q) -> - // TODO: implement additional check that the arguments are T-free if - // head is [Tm_fvar ...] with [Mktuple], [Left], etc. - // Note: not enforcing the types of the arguments because 1) it has - // been enforced by the main F* type-checker and 2) it's a hassle with - // binders and stuff - match (SS.compress bv.sort).n with - | Tm_type _ -> - (star_type' env arg, q), [ (arg, q) ] - | _ -> - let _, s_arg, u_arg = check_n env arg in - (s_arg, q), - (if is_C bv.sort - then [ SS.subst env.subst s_arg, q; u_arg, q] - else [ u_arg, q]) - ) binders args) in - let u_args = List.flatten u_args in - - final_type, mk (Tm_app {hd=s_head; args=s_args}), mk (Tm_app {hd=u_head; args=u_args}) - - | Tm_let {lbs=(false, [ binding ]); body=e2} -> - mk_let env binding e2 infer check_m - - | Tm_match {scrutinee=e0; brs=branches} -> - mk_match env e0 branches infer - - | Tm_uinst (e, _) - | Tm_meta {tm=e} - | Tm_ascribed {tm=e} -> - infer env e - - | Tm_constant c -> - N (env.tc_const c), e, e - - | Tm_quoted (tm, qt) -> - N S.t_term, e, e - - | Tm_let _ -> - failwith (BU.format1 "[infer]: Tm_let %s" (show e)) - | Tm_type _ -> - failwith "impossible (DM stratification)" - | Tm_arrow _ -> - failwith "impossible (DM stratification)" - | Tm_refine _ -> - failwith (BU.format1 "[infer]: Tm_refine %s" (show e)) - | Tm_uvar _ -> - failwith (BU.format1 "[infer]: Tm_uvar %s" (show e)) - | Tm_delayed _ -> - failwith "impossible (compressed)" - | Tm_unknown -> - failwith (BU.format1 "[infer]: Tm_unknown %s" (show e)) - -and mk_match env e0 branches f = - let mk x = mk x e0.pos in - - // TODO: automatically [bind] when the scrutinee is monadic? - let _, s_e0, u_e0 = check_n env e0 in - let nms, branches = List.split (List.map (fun b -> - match open_branch b with - | pat, None, body -> - let env = { env with tcenv = List.fold_left push_bv env.tcenv (pat_bvs pat) } in - let nm, s_body, u_body = f env body in - nm, (pat, None, (s_body, u_body, body)) - | _ -> - raise_error0 Errors.Fatal_WhenClauseNotSupported "No when clauses in the definition language" - ) branches) in - let t1 = match List.hd nms with | M t1 | N t1 -> t1 in - let has_m = List.existsb (function | M _ -> true | _ -> false) nms in - let nms, s_branches, u_branches = List.unzip3 (List.map2 (fun nm (pat, guard, (s_body, u_body, original_body)) -> - match nm, has_m with - | N t2, false - | M t2, true -> - nm, (pat, guard, s_body), (pat, guard, u_body) - | N t2, true -> - // In checking mode, all the branches are run through "check"... meaning - // that they're either all N or all M... the lift from N to M can only - // occur in infer mode... instead of calling [mk_return s_body], - // re-check_m everything and get code that's better for z3 - let _, s_body, u_body = check env original_body (M t2) in - M t2, (pat, guard, s_body), (pat, guard, u_body) - | M _, false -> - failwith "impossible" - ) nms branches) in - - if has_m then begin - // if the return type is monadic we add a - // (fun p -> match ... with ... -> branch p) - // in order to help the SMT - // p: A* -> Type - let p_type = mk_star_to_type mk env t1 in - let p = S.gen_bv "p''" None p_type in - let s_branches = List.map (fun (pat, guard, s_body) -> - let s_body = mk (Tm_app {hd=s_body; args=[ S.bv_to_name p, S.as_aqual_implicit false ]}) in - (pat, guard, s_body) - ) s_branches in - let s_branches = List.map close_branch s_branches in - let u_branches = List.map close_branch u_branches in - let s_e = - U.abs [ S.mk_binder p ] - (mk (Tm_match {scrutinee=s_e0; ret_opt=None; brs= s_branches; rc_opt=None})) - (Some (U.residual_tot U.ktype0)) - in - let t1_star = U.arrow [S.mk_binder <| S.new_bv None p_type] (S.mk_Total U.ktype0) in - M t1, - mk (Tm_ascribed {tm=s_e; asc=(Inl t1_star, None, false); eff_opt=None}) , - mk (Tm_match {scrutinee=u_e0; ret_opt=None; brs=u_branches; rc_opt=None}) - end else begin - let s_branches = List.map close_branch s_branches in - let u_branches = List.map close_branch u_branches in - let t1_star = t1 in - N t1, - mk (Tm_ascribed {tm=mk (Tm_match {scrutinee=s_e0; ret_opt=None; brs=s_branches; rc_opt=None}); asc=(Inl t1_star, None, false); eff_opt=None}), - mk (Tm_match {scrutinee=u_e0; ret_opt=None; brs=u_branches; rc_opt=None}) - end - -and mk_let (env: env_) (binding: letbinding) (e2: term) - (proceed: env_ -> term -> nm & term & term) - (ensure_m: env_ -> term -> term & term & term) = - let mk x = mk x e2.pos in - let e1 = binding.lbdef in - // This is [let x = e1 in e2]. Open [x] in [e2]. - let x = BU.left binding.lbname in - let x_binders = [ S.mk_binder x ] in - let x_binders, e2 = SS.open_term x_binders e2 in - begin match infer env e1 with - | N t1, s_e1, u_e1 -> - // BU.print1 "[debug] %s is NOT a monadic let-binding\n" (show binding.lbname); - // TODO : double-check that correct env and lbeff are used - let u_binding = - if is_C t1 - then { binding with lbtyp = trans_F_ env t1 (SS.subst env.subst s_e1) } - else binding - in - // Piggyback on the environment to carry our own special terms - let env = { env with tcenv = push_bv env.tcenv ({ x with sort = t1 }) } in - // Simple case: just a regular let-binding. We defer checks to e2. - let nm_rec, s_e2, u_e2 = proceed env e2 in - let s_binding = { binding with lbtyp = star_type' env binding.lbtyp } in - nm_rec, - mk (Tm_let {lbs=(false, [ { s_binding with lbdef = s_e1 } ]); body=SS.close x_binders s_e2}), - mk (Tm_let {lbs=(false, [ { u_binding with lbdef = u_e1 } ]); body=SS.close x_binders u_e2}) - - | M t1, s_e1, u_e1 -> - // BU.print1 "[debug] %s IS a monadic let-binding\n" (show binding.lbname); - let u_binding = { binding with lbeff = PC.effect_PURE_lid ; lbtyp = t1 } in - let env = { env with tcenv = push_bv env.tcenv ({ x with sort = t1 }) } in - let t2, s_e2, u_e2 = ensure_m env e2 in - // Now, generate the bind. - // p: A* -> Type - let p_type = mk_star_to_type mk env t2 in - let p = S.gen_bv "p''" None p_type in - // e2* p - let s_e2 = mk (Tm_app {hd=s_e2; args=[ S.bv_to_name p, S.as_aqual_implicit false ]}) in - // fun x -> s_e2* p; this takes care of closing [x]. - let s_e2 = U.abs x_binders s_e2 (Some (U.residual_tot U.ktype0)) in - // e1* (fun x -> e2* p) - let body = mk (Tm_app {hd=s_e1; args=[ s_e2, S.as_aqual_implicit false ]}) in - M t2, - U.abs [ S.mk_binder p ] body (Some (U.residual_tot U.ktype0)), - mk (Tm_let {lbs=(false, [ { u_binding with lbdef = u_e1 } ]); body=SS.close x_binders u_e2}) - end - - -and check_n (env: env_) (e: term): typ & term & term = - let mn = N (mk Tm_unknown e.pos) in - match check env e mn with - | N t, s_e, u_e -> t, s_e, u_e - | _ -> failwith "[check_n]: impossible" - -and check_m (env: env_) (e: term): typ & term & term = - let mn = M (mk Tm_unknown e.pos) in - match check env e mn with - | M t, s_e, u_e -> t, s_e, u_e - | _ -> failwith "[check_m]: impossible" - -and comp_of_nm (nm: nm_): comp = - match nm with - | N t -> mk_Total t - | M t -> mk_M t - -and mk_M (t: typ): comp = - mk_Comp ({ - comp_univs=[U_unknown]; - effect_name = PC.monadic_lid; - result_typ = t; - effect_args = []; - flags = [CPS ; TOTAL] - }) - -and type_of_comp t = U.comp_result t - -// This function expects its argument [c] to be normalized and to satisfy [is_C c] -and trans_F_ (env: env_) (c: typ) (wp: term): term = - if not (is_C c) then - raise_error c Error_UnexpectedDM4FType (BU.format1 "Not a DM4F C-type: %s" (show c)); - let mk x = mk x c.pos in - match (SS.compress c).n with - | Tm_app {hd=head; args} -> - // It's a product, the only form of [Tm_app] allowed. - let wp_head, wp_args = head_and_args wp in - if not (List.length wp_args = List.length args) || - not (is_constructor wp_head (PC.mk_tuple_data_lid (List.length wp_args) Range.dummyRange)) then - failwith "mismatch"; - mk (Tm_app {hd=head; args=List.map2 (fun (arg, q) (wp_arg, q') -> - let print_implicit q = if S.is_aqual_implicit q then "implicit" else "explicit" in - if not (eq_aqual q q') - then Errors.log_issue - head.pos - Errors.Warning_IncoherentImplicitQualifier - (BU.format2 "Incoherent implicit qualifiers %s %s\n" - (print_implicit q) - (print_implicit q')); - trans_F_ env arg wp_arg, q) - args wp_args}) - | Tm_arrow {bs=binders; comp} -> - let binders = U.name_binders binders in - let binders_orig, comp = open_comp binders comp in - let bvs, binders = List.split (List.map (fun b -> - let bv, q = b.binder_bv, b.binder_qual in - let h = bv.sort in - if is_C h then - let w' = S.gen_bv ((string_of_id bv.ppname) ^ "__w'") None (star_type' env h) in - w', [ {b with binder_bv=w'}; {b with binder_bv=S.null_bv (trans_F_ env h (S.bv_to_name w'))} ] - else - let x = S.gen_bv ((string_of_id bv.ppname) ^ "__x") None (star_type' env h) in - x, [ {b with binder_bv=x} ] - ) binders_orig) in - let binders = List.flatten binders in - let comp = SS.subst_comp (U.rename_binders binders_orig (S.binders_of_list bvs)) comp in - let app = mk (Tm_app {hd=wp;args=List.map (fun bv -> S.bv_to_name bv, S.as_aqual_implicit false) bvs}) in - let comp = trans_G env (type_of_comp comp) (is_monadic_comp comp) app in - U.arrow binders comp - | Tm_ascribed {tm=e} -> - (* TODO : find a way to recompute the corrected ascription *) - trans_F_ env e wp - | _ -> - failwith "impossible trans_F_" - -and trans_G (env: env_) (h: typ) (is_monadic: bool) (wp: typ): comp = - if is_monadic then - mk_Comp ({ - comp_univs = [U_unknown]; - effect_name = PC.effect_PURE_lid; - result_typ = star_type' env h; - effect_args = [ wp, S.as_aqual_implicit false ]; - flags = [] - }) - else - mk_Total (trans_F_ env h wp) - -// A helper -------------------------------------------------------------------- - -(* KM : why is there both NoDeltaSteps and UnfoldUntil Delta_constant ? *) -let n = N.normalize [ Env.DontUnfoldAttr [PC.tac_opaque_attr]; Env.Beta; Env.UnfoldUntil delta_constant; Env.DoNotUnfoldPureLets; Env.Eager_unfolding; Env.EraseUniverses ] - - -// Exported definitions ------------------------------------------------------- - -let star_type env t = - star_type' env (n env.tcenv t) - -let star_expr env t = - check_n env (n env.tcenv t) - -let trans_F (env: env_) (c: typ) (wp: term): term = - trans_F_ env (n env.tcenv c) (n env.tcenv wp) - -// A helper to check that the terms elaborated by DMFF are well-typed -let recheck_debug (s:string) (env:FStar.TypeChecker.Env.env) (t:S.term) : S.term = - if !dbg then - BU.print2 "Term has been %s-transformed to:\n%s\n----------\n" s (show t); - let t', _, _ = TcTerm.tc_term env t in - if !dbg then - BU.print1 "Re-checked; got:\n%s\n----------\n" (show t'); - t' - - -let cps_and_elaborate (env:FStar.TypeChecker.Env.env) (ed:S.eff_decl) - : list S.sigelt & - S.eff_decl & - option S.sigelt = - // Using [STInt: a:Type -> Effect] as an example... - let effect_binders_un, signature_un = SS.open_term ed.binders (ed.signature |> U.effect_sig_ts |> snd) in - // [binders] is the empty list (for [ST (h: heap)], there would be one binder) - let effect_binders, env, _ = TcTerm.tc_tparams env effect_binders_un in - // [signature] is a:Type -> effect - let signature, _ = TcTerm.tc_trivial_guard env signature_un in - // We will open binders through [open_and_check] - - let raise_error #a code msg : a = Errors.raise_error signature.pos code msg in - - let effect_binders = List.map (fun b -> - {b with binder_bv={b.binder_bv with sort = N.normalize [ Env.EraseUniverses ] env b.binder_bv.sort }} - ) effect_binders in - - // Every combinator found in the effect declaration is parameterized over - // [binders], then [a]. This is a variant of [open_effect_signature] where we - // just extract the binder [a]. - let a, effect_marker = - // TODO: more stringent checks on the shape of the signature; better errors - match (SS.compress signature_un).n with - | Tm_arrow {bs=[({binder_bv=a})]; comp=effect_marker} -> - a, effect_marker - | _ -> - raise_error Errors.Fatal_BadSignatureShape "bad shape for effect-for-free signature" - in - - (* TODO : having "_" as a variable name can create a really strange shadowing - behaviour between uu___ variables in the tcterm ; needs to be investigated *) - let a = - if S.is_null_bv a - then S.gen_bv "a" (Some (S.range_of_bv a)) a.sort - else a - in - - let open_and_check env other_binders t = - let subst = SS.opening_of_binders (effect_binders @ other_binders) in - let t = SS.subst subst t in - let t, comp, _ = TcTerm.tc_term env t in - t, comp - in - let mk x = mk x signature.pos in - - // TODO: check that [_comp] is [Tot Type] - let repr, _comp = open_and_check env [] (ed |> U.get_eff_repr |> must |> snd) in - if !dbg then - BU.print1 "Representation is: %s\n" (show repr); - - let ed_range = Env.get_range env in - - let dmff_env = empty env (TcTerm.tc_constant env Range.dummyRange) in - let wp_type = star_type dmff_env repr in - let _ = recheck_debug "*" env wp_type in - let wp_a = N.normalize [ Env.Beta ] env (mk (Tm_app {hd=wp_type; args=[ (S.bv_to_name a, S.as_aqual_implicit false) ]})) in - - // Building: [a -> wp a -> Effect] - let effect_signature = - let binders = [ S.mk_binder_with_attrs a (S.as_bqual_implicit false) None []; - S.gen_bv "dijkstra_wp" None wp_a |> S.mk_binder ] in - let binders = close_binders binders in - mk (Tm_arrow {bs=binders; comp=effect_marker}) - in - let _ = recheck_debug "turned into the effect signature" env effect_signature in - - let sigelts = BU.mk_ref [] in - let mk_lid name : lident = U.dm4f_lid ed name in - - // TODO: we assume that reading the top-level definitions in the order that - // they come in the effect definition is enough... probably not - let elaborate_and_star dmff_env other_binders item = - let env = get_env dmff_env in - let u_item, item = item in - // TODO: assert no universe polymorphism - let item, item_comp = open_and_check env other_binders item in - if not (TcComm.is_total_lcomp item_comp) then - raise_error0 Errors.Fatal_ComputationNotTotal (BU.format2 "Computation for [%s] is not total : %s !" (show item) (TcComm.lcomp_to_string item_comp)); - let item_t, item_wp, item_elab = star_expr dmff_env item in - let _ = recheck_debug "*" env item_wp in - let _ = recheck_debug "_" env item_elab in - dmff_env, item_t, item_wp, item_elab - in - - let dmff_env, _, bind_wp, bind_elab = - elaborate_and_star dmff_env [] (ed |> U.get_bind_repr |> must) in - let dmff_env, _, return_wp, return_elab = - elaborate_and_star dmff_env [] (ed |> U.get_return_repr |> must) in - let rc_gtot = { - residual_effect = PC.effect_GTot_lid; - residual_typ = None; - residual_flags = [] - } in - - (* Starting from [return_wp (b1:Type) (b2:b1) : M.wp b1 = fun bs -> body <: Type0], we elaborate *) - (* [lift_from_pure (b1:Type) (wp:(b1 -> Type0)-> Type0) : M.wp b1 = fun bs -> wp (fun b2 -> body)] *) - let lift_from_pure_wp = - match (SS.compress return_wp).n with - | Tm_abs {bs=b1 :: b2 :: bs; body; rc_opt=what} -> - let b1,b2, body = - match SS.open_term [b1 ; b2] (U.abs bs body None) with - | [b1 ; b2], body -> b1, b2, body - | _ -> failwith "Impossible : open_term not preserving binders arity" - in - (* WARNING : pushing b1 and b2 in env might break the well-typedness *) - (* invariant but we need them for normalization *) - let env0 = push_binders (get_env dmff_env) [b1 ; b2] in - let wp_b1 = - let raw_wp_b1 = mk (Tm_app {hd=wp_type; args=[ (S.bv_to_name b1.binder_bv, S.as_aqual_implicit false) ]}) in - N.normalize [ Env.Beta ] env0 raw_wp_b1 - in - let bs, body, what' = U.abs_formals <| N.eta_expand_with_type env0 body (U.unascribe wp_b1) in - - (* We check that what' is Tot Type0 *) - let fail () = - let error_msg = - BU.format2 "The body of return_wp (%s) should be of type Type0 but is of type %s" - (show body) - (match what' with - | None -> "None" - | Some rc -> FStar.Ident.string_of_lid rc.residual_effect) - in raise_error Errors.Fatal_WrongBodyTypeForReturnWP error_msg - in - begin match what' with - | None -> fail () - | Some rc -> - if not (U.is_pure_effect rc.residual_effect) then fail (); - BU.map_opt rc.residual_typ (fun rt -> - let g_opt = Rel.try_teq true env rt U.ktype0 in - match g_opt with - | Some g' -> Rel.force_trivial_guard env g' - | None -> fail ()) |> ignore - end ; - - let wp = - let t2 = b2.binder_bv.sort in - let pure_wp_type = double_star t2 in - S.gen_bv "wp" None pure_wp_type - in - - (* fun b1 wp -> (fun bs@bs'-> wp (fun b2 -> body $$ Type0) $$ Type0) $$ wp_a *) - let body = mk_Tm_app (S.bv_to_name wp) [U.abs [b2] body what', None] ed_range in - U.abs ([ b1; S.mk_binder wp ]) - (U.abs (bs) body what) - (Some rc_gtot) - - | _ -> - raise_error Errors.Fatal_UnexpectedReturnShape "unexpected shape for return" - in - - let return_wp = - // TODO: fix [tc_eff_decl] to deal with currying - match (SS.compress return_wp).n with - | Tm_abs {bs=b1 :: b2 :: bs; body; rc_opt=what} -> - U.abs ([ b1; b2 ]) (U.abs bs body what) (Some rc_gtot) - | _ -> - raise_error Errors.Fatal_UnexpectedReturnShape "unexpected shape for return" - in - let bind_wp = - match (SS.compress bind_wp).n with - | Tm_abs {bs=binders; body; rc_opt=what} -> - // TODO: figure out how to deal with ranges - //let r = S.lid_and_dd_as_fv PC.range_lid None in - U.abs binders body what - | _ -> - raise_error Errors.Fatal_UnexpectedBindShape "unexpected shape for bind" - in - - let apply_close t = - if List.length effect_binders = 0 then - t - else - close effect_binders (mk (Tm_app {hd=t; args=snd (U.args_of_binders effect_binders)})) - in - let rec apply_last f l = match l with - | [] -> failwith "impossible: empty path.." - | [a] -> [f a] - | (x::xs) -> x :: (apply_last f xs) - in - let register maybe_admit name item = - let maybe_admit = true in - let p = path_of_lid ed.mname in - let p' = apply_last (fun s -> "__" ^ s ^ "_eff_override_" ^ name) p in - let l' = lid_of_path p' ed_range in - match try_lookup_lid env l' with - | Some (_us,_t) -> begin - if Debug.any () then - BU.print1 "DM4F: Applying override %s\n" (string_of_lid l'); - fv_to_tm (lid_and_dd_as_fv l' None) - end - | None -> - let sigelt, fv = mk_toplevel_definition env (mk_lid name) (U.abs effect_binders item None) in - let sigelt = - if maybe_admit - then { sigelt with sigmeta={sigelt.sigmeta with sigmeta_admit=true}} - else sigelt - in - sigelts := sigelt :: !sigelts; - fv - in - let register_admit = register true in - let register = register false in - let lift_from_pure_wp = register "lift_from_pure" lift_from_pure_wp in - let mk_sigelt se = { mk_sigelt se with sigrng=ed_range } in - // we do not expect the return_elab to verify, - // since that may require internalizing monotonicity of WPs (i.e. continuation monad) - // so we use register_admit which sets sigmeta_admit=true - let return_wp = register "return_wp" return_wp in - let return_elab = register_admit "return_elab" return_elab in - - // we do not expect the bind to verify, since that requires internalizing monotonicity of WPs - let bind_wp = register "bind_wp" bind_wp in - let bind_elab = register_admit "bind_elab" bind_elab in - - let dmff_env, actions = List.fold_left (fun (dmff_env, actions) action -> - let params_un = SS.open_binders action.action_params in - let action_params, env', _ = TcTerm.tc_tparams (get_env dmff_env) params_un in - let action_params = List.map (fun b -> - { b with binder_bv={b.binder_bv with sort= - N.normalize [ Env.EraseUniverses ] env' b.binder_bv.sort } } - ) action_params in - let dmff_env' = set_env dmff_env env' in - // We need to reverse-engineer what tc_eff_decl wants here... - let dmff_env, action_t, action_wp, action_elab = - elaborate_and_star dmff_env' action_params (action.action_univs, action.action_defn) - in - let name = string_of_id (ident_of_lid action.action_name) in - let action_typ_with_wp = trans_F dmff_env' action_t action_wp in - let action_params = SS.close_binders action_params in - let action_elab = SS.close action_params action_elab in - let action_typ_with_wp = SS.close action_params action_typ_with_wp in - let action_elab = abs action_params action_elab None in - let action_typ_with_wp = - match action_params with - | [] -> action_typ_with_wp - | _ -> flat_arrow action_params (S.mk_Total action_typ_with_wp) - in - if !dbg - then BU.print4 "original action_params %s, end action_params %s, type %s, term %s\n" - (show params_un) - (show action_params) - (show action_typ_with_wp) - (show action_elab); - let action_elab = register (name ^ "_elab") action_elab in - let action_typ_with_wp = register (name ^ "_complete_type") action_typ_with_wp in - (* it does not seem that dmff_env' has been modified by elaborate_and_star so it should be okay to return the original env *) - dmff_env, - { action with - action_params = [] ; - action_defn = apply_close action_elab; - action_typ = apply_close action_typ_with_wp - } :: actions - ) (dmff_env, []) ed.actions in - let actions = List.rev actions in - - let repr = - let wp = S.gen_bv "wp_a" None wp_a in - let binders = [ S.mk_binder a; S.mk_binder wp ] in - U.abs binders (trans_F dmff_env (mk (Tm_app {hd=repr; args=[ S.bv_to_name a, S.as_aqual_implicit false ]})) (S.bv_to_name wp)) None - in - let _ = recheck_debug "FC" env repr in - let repr = register "repr" repr in - - (* We are still lacking a principled way to generate pre/post condition *) - (* Current algorithm takes the type of wps : fun (a: Type) -> (t1 -> t2 ... -> tn -> Type0) *) - (* Checks that there is exactly one ti containing the type variable a and returns that ti *) - (* as type of postconditons, the rest as type of preconditions *) - let pre, post = - match (unascribe <| SS.compress wp_type).n with - | Tm_abs {bs=type_param :: effect_param; body=arrow} -> - let type_param , effect_param, arrow = - match SS.open_term (type_param :: effect_param) arrow with - | (b :: bs), body -> b, bs, body - | _ -> failwith "Impossible : open_term nt preserving binders arity" - in - begin match (unascribe <| SS.compress arrow).n with - | Tm_arrow {bs=wp_binders; comp=c} -> - let wp_binders, c = SS.open_comp wp_binders c in - let pre_args, post_args = - List.partition (fun ({binder_bv=bv}) -> - Free.names bv.sort |> mem type_param.binder_bv |> not - ) wp_binders - in - let post = match post_args with - | [post] -> post - | [] -> - let err_msg = - BU.format1 "Impossible to generate DM effect: no post candidate %s (Type variable does not appear)" - (show arrow) - in - raise_error0 Errors.Fatal_ImpossibleToGenerateDMEffect err_msg - | _ -> - let err_msg = - BU.format1 "Impossible to generate DM effect: multiple post candidates %s" (show arrow) - in - raise_error0 Errors.Fatal_ImpossibleToGenerateDMEffect err_msg - in - // Pre-condition does not mention the return type; don't close over it - U.arrow pre_args c, - // Post-condition does, however! - U.abs (type_param :: effect_param) post.binder_bv.sort None - | _ -> - raise_error Errors.Fatal_ImpossiblePrePostArrow (BU.format1 "Impossible: pre/post arrow %s" (show arrow)) - end - | _ -> - raise_error Errors.Fatal_ImpossiblePrePostAbs (BU.format1 "Impossible: pre/post abs %s" (show wp_type)) - in - // Desugaring is aware of these names and generates references to them when - // the user writes something such as [STINT.repr] - ignore (register "pre" pre); - ignore (register "post" post); - ignore (register "wp" wp_type); - - let ed_combs = match ed.combinators with - | DM4F_eff combs -> - DM4F_eff ({ combs with - ret_wp = [], apply_close return_wp; - bind_wp = [], apply_close bind_wp; - repr = Some ([], apply_close repr); - return_repr = Some ([], apply_close return_elab); - bind_repr = Some ([], apply_close bind_elab) }) - | _ -> failwith "Impossible! For a DM4F effect combinators must be in DM4f_eff" in - - let ed = { ed with - signature = WP_eff_sig ([], close effect_binders effect_signature); - binders = close_binders effect_binders; - combinators = ed_combs; - actions = actions; // already went through apply_close - } in - - - // Generate the missing combinators. - let sigelts', ed = gen_wps_for_free env effect_binders a wp_a ed in - if !dbg then - BU.print_string (show ed); - - let lift_from_pure_opt = - if List.length effect_binders = 0 then begin - // Won't work with parameterized effect - let lift_from_pure = { - source = PC.effect_PURE_lid; - target = ed.mname ; - lift_wp = Some ([], apply_close lift_from_pure_wp) ; - lift = None; //Some ([], apply_close return_elab) - kind = None; - } in - Some (mk_sigelt (Sig_sub_effect (lift_from_pure))) - end else None - in - - List.rev !sigelts @ sigelts', ed, lift_from_pure_opt diff --git a/src/typechecker/FStar.TypeChecker.DMFF.fsti b/src/typechecker/FStar.TypeChecker.DMFF.fsti deleted file mode 100644 index c2b7cf23a5f..00000000000 --- a/src/typechecker/FStar.TypeChecker.DMFF.fsti +++ /dev/null @@ -1,34 +0,0 @@ -(* - Copyright 2008-2014 Microsoft Research - - Authors: Jonathan Protzenko, Nikhil Swamy - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.TypeChecker.DMFF -open FStar.Compiler.Effect -open FStar.TypeChecker -open FStar.Syntax.Syntax - -new val env : Type0 - -val empty : Env.env -> (sconst -> typ) -> env -val get_env: env -> Env.env -val set_env : env -> Env.env -> env -val gen_wps_for_free: Env.env -> binders -> bv -> term -> eff_decl -> sigelts & eff_decl -val double_star: typ -> typ -val star_type: env -> typ -> typ -val star_expr: env -> term -> typ & term & term -val trans_F : env -> typ -> term -> term -val recheck_debug : string -> FStar.TypeChecker.Env.env -> term -> term -val cps_and_elaborate : FStar.TypeChecker.Env.env -> eff_decl -> (list sigelt & eff_decl & option sigelt) diff --git a/src/typechecker/FStar.TypeChecker.DeferredImplicits.fst b/src/typechecker/FStar.TypeChecker.DeferredImplicits.fst deleted file mode 100644 index fa74616c2d8..00000000000 --- a/src/typechecker/FStar.TypeChecker.DeferredImplicits.fst +++ /dev/null @@ -1,303 +0,0 @@ -(* - Copyright 2020 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. - - Authors: Nikhil Swamy -*) - -module FStar.TypeChecker.DeferredImplicits -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.Compiler.Util -open FStar.Errors -open FStar.TypeChecker -open FStar.Syntax -open FStar.TypeChecker.Env -open FStar.Syntax.Syntax -open FStar.Syntax.Subst -open FStar.Ident -open FStar.TypeChecker.Common -open FStar.Syntax -module BU = FStar.Compiler.Util -module S = FStar.Syntax.Syntax -module U = FStar.Syntax.Util -module SS = FStar.Syntax.Subst -module TEQ = FStar.TypeChecker.TermEqAndSimplify - -open FStar.Class.Setlike -open FStar.Class.Show -module Listlike = FStar.Class.Listlike - -let is_flex t = - let head, _args = U.head_and_args_full t in - match (SS.compress head).n with - | Tm_uvar _ -> true - | _ -> false - -let flex_uvar_head t = - let head, _args = U.head_and_args_full t in - match (SS.compress head).n with - | Tm_uvar (u, _) -> u - | _ -> failwith "Not a flex-uvar" - -type goal_type = - | FlexRigid of ctx_uvar & term - | FlexFlex of ctx_uvar & ctx_uvar - | Can_be_split_into of term & term & ctx_uvar - | Imp of ctx_uvar - -(* - If [u] is tagged with attribute [a] - - We look in the context for definitions tagged with [@@resolve_implicits; a] - These are the initial [candidates] - - We filter the [candidates] to find a unique candidate [c], such that - [c] is not overridden and it overrides all other all other - [candidates]. - - A candidate [c] overriders [c'] if [c] contains the attribute - - override_resolve_implicits_handler a [l] - - and [l] contains the name of [c] - - If no candidates are found we return None - If no unique [c] exists we warn and return None -*) -let find_user_tac_for_uvar env (u:ctx_uvar) : option sigelt = - (* This tries to unembed a Cons (Tm_constant (Const_string s1)) - ... - Cons (Tm_constant (Const_string sn)) - Nil - to [s1;..;sn] - - It's a bit ugly because the term it is applied to [e] - is just an attribute, and so it is not actually a type-correct term. - - So, the type arguments of the Cons may be missing *) - let rec attr_list_elements (e:term) : option (list string) = - let head, args = U.head_and_args (U.unmeta e) in - match (U.un_uinst head).n, args with - | Tm_fvar fv, _ when fv_eq_lid fv FStar.Parser.Const.nil_lid -> - Some [] - | Tm_fvar fv, [_; (hd, _); (tl, _)] - | Tm_fvar fv, [(hd, _); (tl, _)] - when fv_eq_lid fv FStar.Parser.Const.cons_lid -> - (match hd.n with - | Tm_constant (FStar.Const.Const_string (s, _)) -> - (match attr_list_elements tl with - | None -> None - | Some tl -> Some (s::tl)) - | _ -> None) - | _ -> - None - in - let candidate_names candidates = - List.collect U.lids_of_sigelt candidates - |> List.map string_of_lid - |> String.concat ", " - in - match u.ctx_uvar_meta with - | Some (Ctx_uvar_meta_attr a) -> - (* hooks: all definitions with the resolve_implicits attr *) - let hooks = Env.lookup_attr env FStar.Parser.Const.resolve_implicits_attr_string in - (* candidates: hooks that also have the attribute [a] *) - let candidates = - hooks |> List.filter - (fun hook -> hook.sigattrs |> BU.for_some (TEQ.eq_tm_bool env a)) - in - (* The environment sometimes returns duplicates in the candidate list; filter out dups *) - let candidates = - BU.remove_dups - (fun s0 s1 -> - let l0 = U.lids_of_sigelt s0 in - let l1 = U.lids_of_sigelt s1 in - if List.length l0 = List.length l1 - then List.forall2 (fun l0 l1 -> Ident.lid_equals l0 l1) l0 l1 - else false) - candidates - in - (* Checking if a candidate is overridden, by scanning the list of all - candidates and seeing if any of them override it *) - let is_overridden (candidate:sigelt) - : bool - = (* A candidate may have more than one lid, in case it is a let rec - It is overridden if any of its names are overridden *) - let candidate_lids = U.lids_of_sigelt candidate in - candidates |> - BU.for_some - (fun (other:sigelt) -> - other.sigattrs |> - BU.for_some - (fun attr -> - let head, args = U.head_and_args attr in - match (U.un_uinst head).n, args with - | Tm_fvar fv, [_; (a', _); (overrides, _)] //type argument may be missing, since it is just an attr - | Tm_fvar fv, [(a', _); (overrides, _)] - when fv_eq_lid fv FStar.Parser.Const.override_resolve_implicits_handler_lid - && TEQ.eq_tm_bool env a a' -> - //other has an attribute [@@override_resolve_implicits_handler a overrides] - begin - match attr_list_elements overrides with - | None -> false - | Some names -> - //if the overrides mention one of the candidate's names - //the candidate is overriden - names |> - BU.for_some (fun n -> - candidate_lids |> BU.for_some (fun l -> string_of_lid l = n)) - end - | _ -> false)) - in - let candidates = candidates |> List.filter (fun c -> not (is_overridden c)) in - begin - match candidates with - | [] -> None //no candidates - | [ c ] -> Some c //if there is a unique candidate return it - | _ -> //it is ambiguous; complain - let candidates = candidate_names candidates in - let attr = show a in - FStar.Errors.log_issue u.ctx_uvar_range - FStar.Errors.Warning_AmbiguousResolveImplicitsHook - (BU.format2 - "Multiple resolve_implicits hooks are eligible for attribute %s; \n\ - please resolve the ambiguity by using the `override_resolve_implicits_handler` attribute \ - to choose among these candidates {%s}" - attr candidates); - None - end - - | _ -> None - -let should_defer_uvar_to_user_tac env (u:ctx_uvar) = - if not env.enable_defer_to_tac - then false - else Some? (find_user_tac_for_uvar env u) - -let solve_goals_with_tac env g (deferred_goals:implicits) (tac:sigelt) = - Profiling.profile (fun () -> - let resolve_tac = - match tac.sigel with - | Sig_let {lids=[lid]} -> - let qn = Env.lookup_qname env lid in - let fv = S.lid_as_fv lid None in - let term = S.fv_to_tm (S.lid_as_fv lid None) in - term - | _ -> failwith "Resolve_tac not found" - in - let env = { env with enable_defer_to_tac = false } in - env.try_solve_implicits_hook env resolve_tac deferred_goals) - (Some (Ident.string_of_lid (Env.current_module env))) - "FStar.TypeChecker.DeferredImplicits.solve_goals_with_tac" - -(** This functions is called in Rel.force_trivial_guard to solve all - goals in a guard that were deferred to a tactic *) -let solve_deferred_to_tactic_goals env g = - if not env.enable_defer_to_tac then g else - let deferred = g.deferred_to_tac in - (** A unification problem between two terms is presented to - a tactic as an equality goal between the terms. *) - let prob_as_implicit (_, reason, prob) - : implicit & sigelt = - match prob with - | TProb tp when tp.relation=EQ -> - let env, _ = Env.clear_expected_typ env in - let env = {env with gamma=tp.logical_guard_uvar.ctx_uvar_gamma} in - let env_lax = {env with admit=true; enable_defer_to_tac=false} in - let _, t_eq, _ = - //Prefer to use the type of the flex term to compute the - //type instantiation of the equality, since it is more efficient - let t = - if is_flex tp.lhs then tp.lhs - else tp.rhs - in - env.typeof_tot_or_gtot_term env_lax t true //AR: TODO: can we call type_of_well_typed? - in - let goal_ty = U.mk_eq2 (env.universe_of env_lax t_eq) t_eq tp.lhs tp.rhs in - let goal, ctx_uvar, _ = - Env.new_implicit_var_aux reason tp.lhs.pos env goal_ty Strict None false - in - let imp = - { imp_reason = ""; - imp_uvar = fst ctx_uvar; - imp_tm = goal; - imp_range = tp.lhs.pos - } - in - let sigelt = - if is_flex tp.lhs - then (match find_user_tac_for_uvar env (flex_uvar_head tp.lhs) with - | None -> if is_flex tp.rhs then find_user_tac_for_uvar env (flex_uvar_head tp.rhs) else None - | v -> v) - else if is_flex tp.rhs - then find_user_tac_for_uvar env (flex_uvar_head tp.rhs) - else None - in - begin - match sigelt with - | None -> - //it shouldn't have been deferred - failwith "Impossible: No tactic associated with deferred problem" - | Some se -> imp, se - end - | _ -> - //only equality problems are deferred - failwith "Unexpected problem deferred to tactic" - in - //Turn all the deferred problems into equality goals - let eqs = List.map prob_as_implicit (Listlike.to_list g.deferred_to_tac) in - //Also take any unsolved uvars in the guard implicits that are tagged - //with attributes - let more, imps = - List.fold_right - (fun imp (more, imps) -> - match Unionfind.find imp.imp_uvar.ctx_uvar_head with - | Some _ -> //aleady solved - more, imp::imps - | None -> - let se = find_user_tac_for_uvar env imp.imp_uvar in - match se with - | None -> //no tac for this one - more, imp::imps - | Some se -> - (imp, se)::more, imps) - (Listlike.to_list g.implicits) - ([], []) - in - (** Each implicit is associated with a sigelt. - Group them so that all implicits with the same associated sigelt - are in the same bucket *) - let bucketize (is:list (implicit & sigelt)) : list (implicits & sigelt) = - let map : BU.smap (implicits & sigelt) = BU.smap_create 17 in - List.iter - (fun (i, s) -> - match U.lid_of_sigelt s with - | None -> failwith "Unexpected: tactic without a name" - | Some l -> - let lstr = Ident.string_of_lid l in - match BU.smap_try_find map lstr with - | None -> BU.smap_add map lstr ([i], s) - | Some (is, s) -> - BU.smap_remove map lstr; - BU.smap_add map lstr (i::is, s)) - is; - BU.smap_fold map (fun _ is out -> is::out) [] - in - let buckets = bucketize (eqs@more) in - // Dispatch each bucket of implicits to their respective tactic - List.iter (fun (imps, sigel) -> solve_goals_with_tac env g imps sigel) buckets; - { g with deferred_to_tac=Listlike.empty; implicits = Class.Listlike.from_list imps} diff --git a/src/typechecker/FStar.TypeChecker.DeferredImplicits.fsti b/src/typechecker/FStar.TypeChecker.DeferredImplicits.fsti deleted file mode 100644 index 9f24fe6c493..00000000000 --- a/src/typechecker/FStar.TypeChecker.DeferredImplicits.fsti +++ /dev/null @@ -1,30 +0,0 @@ -(* - Copyright 2020 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. - - Authors: Nikhil Swamy, ... -*) -////////////////////////////////////////////////////////////////////////// -//Refinement subtyping with higher-order unification -//with special treatment for higher-order patterns -////////////////////////////////////////////////////////////////////////// - -module FStar.TypeChecker.DeferredImplicits -open FStar.Compiler.Effect -open FStar.Syntax.Syntax -open FStar.TypeChecker.Env -open FStar.TypeChecker.Common - -val should_defer_uvar_to_user_tac : env -> ctx_uvar -> bool -val solve_deferred_to_tactic_goals: env -> guard_t -> guard_t diff --git a/src/typechecker/FStar.TypeChecker.Env.fst b/src/typechecker/FStar.TypeChecker.Env.fst deleted file mode 100644 index c12032c0da3..00000000000 --- a/src/typechecker/FStar.TypeChecker.Env.fst +++ /dev/null @@ -1,2137 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.TypeChecker.Env -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.Syntax.Subst -open FStar.Syntax.Util -open FStar.Compiler.Util -open FStar.Ident -open FStar.Compiler.Range -open FStar.Errors -open FStar.TypeChecker.Common -open FStar.Class.Setlike - -open FStar.Class.Show -open FStar.Class.PP -module Listlike = FStar.Class.Listlike - -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module BU = FStar.Compiler.Util -module U = FStar.Syntax.Util -module UF = FStar.Syntax.Unionfind -module Const = FStar.Parser.Const -module TcComm = FStar.TypeChecker.Common - -open FStar.Defensive - -let dbg_ImplicitTrace = Debug.get_toggle "ImplicitTrace" -let dbg_LayeredEffectsEqns = Debug.get_toggle "LayeredEffectsEqns" - -let rec eq_step s1 s2 = - match s1, s2 with - | Beta, Beta - | Iota, Iota //pattern matching - | Zeta, Zeta //fixed points - | ZetaFull, ZetaFull //fixed points - | Weak, Weak //Do not descend into binders - | HNF, HNF //Only produce a head normal form - | Primops, Primops //reduce primitive operators like +, -, *, /, etc. - | Eager_unfolding, Eager_unfolding - | Inlining, Inlining - | DoNotUnfoldPureLets, DoNotUnfoldPureLets - | PureSubtermsWithinComputations, PureSubtermsWithinComputations - | Simplify, Simplify - | EraseUniverses, EraseUniverses - | AllowUnboundUniverses, AllowUnboundUniverses - | Reify, Reify - | CompressUvars, CompressUvars - | NoFullNorm, NoFullNorm - | CheckNoUvars, CheckNoUvars - | Unmeta, Unmeta - | Unascribe, Unascribe - | NBE, NBE - | Unrefine, Unrefine -> true - | Exclude s1, Exclude s2 -> eq_step s1 s2 - | UnfoldUntil s1, UnfoldUntil s2 -> s1 = s2 - | UnfoldOnly lids1, UnfoldOnly lids2 - | UnfoldFully lids1, UnfoldFully lids2 - | UnfoldAttr lids1, UnfoldAttr lids2 -> lids1 =? lids2 - | UnfoldQual strs1, UnfoldQual strs2 -> strs1 =? strs2 - | UnfoldNamespace strs1, UnfoldNamespace strs2 -> strs1 =? strs2 - | DontUnfoldAttr lids1, DontUnfoldAttr lids2 -> lids1 =? lids2 - | _ -> false // fixme: others ? - -instance deq_step : deq step = { - (=?) = eq_step; -} - -let rec step_to_string (s:step) : string = - match s with - | Beta -> "Beta" - | Iota -> "Iota" - | Zeta -> "Zeta" - | ZetaFull -> "ZetaFull" - | Exclude s1 -> "Exclude " ^ step_to_string s1 - | Weak -> "Weak" - | HNF -> "HNF" - | Primops -> "Primops" - | Eager_unfolding -> "Eager_unfolding" - | Inlining -> "Inlining" - | DoNotUnfoldPureLets -> "DoNotUnfoldPureLets" - | UnfoldUntil s1 -> "UnfoldUntil " ^ show s1 - | UnfoldOnly lids1 -> "UnfoldOnly " ^ show lids1 - | UnfoldFully lids1 -> "UnfoldFully " ^ show lids1 - | UnfoldAttr lids1 -> "UnfoldAttr " ^ show lids1 - | UnfoldQual strs1 -> "UnfoldQual " ^ show strs1 - | UnfoldNamespace strs1 -> "UnfoldNamespace " ^ show strs1 - | DontUnfoldAttr lids1 -> "DontUnfoldAttr " ^ show lids1 - | PureSubtermsWithinComputations -> "PureSubtermsWithinComputations" - | Simplify -> "Simplify" - | EraseUniverses -> "EraseUniverses" - | AllowUnboundUniverses -> "AllowUnboundUniverses" - | Reify -> "Reify" - | CompressUvars -> "CompressUvars" - | NoFullNorm -> "NoFullNorm" - | CheckNoUvars -> "CheckNoUvars" - | Unmeta -> "Unmeta" - | Unascribe -> "Unascribe" - | NBE -> "NBE" - | ForExtraction -> "ForExtraction" - | Unrefine -> "Unrefine" - | NormDebug -> "NormDebug" - | DefaultUnivsToZero -> "DefaultUnivsToZero" - | Tactics -> "Tactics" - -instance showable_step : showable step = { - show = step_to_string; -} - -instance deq_delta_level : deq delta_level = { - (=?) = (fun x y -> match x, y with - | NoDelta, NoDelta -> true - | InliningDelta, InliningDelta -> true - | Eager_unfolding_only, Eager_unfolding_only -> true - | Unfold x, Unfold y -> x =? y - | _ -> false); -} - -instance showable_delta_level : showable delta_level = { - show = (function - | NoDelta -> "NoDelta" - | InliningDelta -> "Inlining" - | Eager_unfolding_only -> "Eager_unfolding_only" - | Unfold d -> "Unfold " ^ show d); -} - -let preprocess env tau tm = env.mpreprocess env tau tm -let postprocess env tau ty tm = env.postprocess env tau ty tm - -let rename_gamma subst gamma = - gamma |> List.map (function - | Binding_var x -> begin - let y = Subst.subst subst (S.bv_to_name x) in - match (Subst.compress y).n with - | Tm_name y -> - // We don't want to change the type - Binding_var ({ y with sort = Subst.subst subst x.sort }) - | _ -> failwith "Not a renaming" - end - | b -> b) -let rename_env subst env = {env with gamma=rename_gamma subst env.gamma} -let default_tc_hooks = - { tc_push_in_gamma_hook = (fun _ _ -> ()) } -let tc_hooks (env: env) = env.tc_hooks -let set_tc_hooks env hooks = { env with tc_hooks = hooks } - -let set_dep_graph e g = {e with dsenv=DsEnv.set_dep_graph e.dsenv g} -let dep_graph e = DsEnv.dep_graph e.dsenv - -let record_val_for (e:env) (l:lident) : env = - { e with missing_decl = add l e.missing_decl } - -let record_definition_for (e:env) (l:lident) : env = - { e with missing_decl = remove l e.missing_decl } - -let missing_definition_list (e:env) : list lident = - elems e.missing_decl - -type sigtable = BU.smap sigelt - -let should_verify env = - not (Options.lax ()) - && not env.admit - && Options.should_verify (string_of_lid env.curmodule) - -let visible_at d q = match d, q with - | NoDelta, _ - | Eager_unfolding_only, Unfold_for_unification_and_vcgen - | Unfold _, Unfold_for_unification_and_vcgen - | Unfold _, Visible_default -> true - | InliningDelta, Inline_for_extraction -> true - | _ -> false - -let default_table_size = 200 -let new_sigtab () = BU.smap_create default_table_size -let new_gamma_cache () = BU.smap_create 100 - -let initial_env deps - tc_term - typeof_tot_or_gtot_term - typeof_tot_or_gtot_term_fastpath - universe_of - teq_nosmt_force - subtype_nosmt_force - solver module_lid nbe - core_check : env = - { solver=solver; - range=dummyRange; - curmodule=module_lid; - gamma= []; - gamma_sig = []; - gamma_cache=new_gamma_cache(); - modules= []; - expected_typ=None; - sigtab=new_sigtab(); - attrtab=new_sigtab(); - instantiate_imp=true; - effects={decls=[]; order=[]; joins=[]; polymonadic_binds=[]; polymonadic_subcomps=[]}; - generalize=true; - letrecs=[]; - top_level=false; - check_uvars=false; - use_eq_strict=false; - is_iface=false; - admit=false; - lax_universes=false; - phase1=false; - nocoerce=false; - failhard=false; - flychecking=false; - uvar_subtyping=true; - intactics=false; - - tc_term=tc_term; - typeof_tot_or_gtot_term=typeof_tot_or_gtot_term; - typeof_well_typed_tot_or_gtot_term = - (fun env t must_tot -> - match typeof_tot_or_gtot_term_fastpath env t must_tot with - | Some k -> k, trivial_guard - | None -> - let t', k, g = typeof_tot_or_gtot_term env t must_tot in - k, g); - universe_of=universe_of; - teq_nosmt_force=teq_nosmt_force; - subtype_nosmt_force=subtype_nosmt_force; - qtbl_name_and_index=None, BU.smap_create 10; - normalized_eff_names=BU.smap_create 20; //20? - fv_delta_depths = BU.smap_create 50; - proof_ns = Options.using_facts_from (); - synth_hook = (fun e g tau -> failwith "no synthesizer available"); - try_solve_implicits_hook = (fun e tau imps -> failwith "no implicit hook available"); - splice = (fun e is_typed lids tau range -> failwith "no splicer available"); - mpreprocess = (fun e tau tm -> failwith "no preprocessor available"); - postprocess = (fun e tau typ tm -> failwith "no postprocessor available"); - identifier_info=BU.mk_ref FStar.TypeChecker.Common.id_info_table_empty; - tc_hooks = default_tc_hooks; - dsenv = FStar.Syntax.DsEnv.empty_env deps; - nbe = nbe; - strict_args_tab = BU.smap_create 20; - erasable_types_tab = BU.smap_create 20; - enable_defer_to_tac=true; - unif_allow_ref_guards=false; - erase_erasable_args=false; - - core_check; - - missing_decl = empty(); - } - -let dsenv env = env.dsenv -let sigtab env = env.sigtab -let attrtab env = env.attrtab -let gamma_cache env = env.gamma_cache - -(* Marking and resetting the environment, for the interactive mode *) - -let query_indices: ref (list (list (lident & int))) = BU.mk_ref [[]] -let push_query_indices () = match !query_indices with // already signal-atmoic - | [] -> failwith "Empty query indices!" - | _ -> query_indices := (List.hd !query_indices)::!query_indices - -let pop_query_indices () = match !query_indices with // already signal-atmoic - | [] -> failwith "Empty query indices!" - | hd::tl -> query_indices := tl - -let snapshot_query_indices () = Common.snapshot push_query_indices query_indices () -let rollback_query_indices depth = Common.rollback pop_query_indices query_indices depth - -let add_query_index (l, n) = match !query_indices with - | hd::tl -> query_indices := ((l,n)::hd)::tl - | _ -> failwith "Empty query indices" - -let peek_query_indices () = List.hd !query_indices - -let stack: ref (list env) = BU.mk_ref [] -let push_stack env = - stack := env::!stack; - {env with sigtab=BU.smap_copy (sigtab env); - attrtab=BU.smap_copy (attrtab env); - gamma_cache=BU.smap_copy (gamma_cache env); - identifier_info=BU.mk_ref !env.identifier_info; - qtbl_name_and_index=env.qtbl_name_and_index |> fst, BU.smap_copy (env.qtbl_name_and_index |> snd); - normalized_eff_names=BU.smap_copy env.normalized_eff_names; - fv_delta_depths=BU.smap_copy env.fv_delta_depths; - strict_args_tab=BU.smap_copy env.strict_args_tab; - erasable_types_tab=BU.smap_copy env.erasable_types_tab } - -let pop_stack () = - match !stack with - | env::tl -> - stack := tl; - env - | _ -> failwith "Impossible: Too many pops" - -let snapshot_stack env = Common.snapshot push_stack stack env -let rollback_stack depth = Common.rollback pop_stack stack depth - -let snapshot env msg = BU.atomically (fun () -> - let stack_depth, env = snapshot_stack env in - let query_indices_depth, () = snapshot_query_indices () in - let solver_depth, () = env.solver.snapshot msg in - let dsenv_depth, dsenv = DsEnv.snapshot env.dsenv in - (stack_depth, query_indices_depth, solver_depth, dsenv_depth), { env with dsenv=dsenv }) - -let rollback solver msg depth = BU.atomically (fun () -> - let stack_depth, query_indices_depth, solver_depth, dsenv_depth = match depth with - | Some (s1, s2, s3, s4) -> Some s1, Some s2, Some s3, Some s4 - | None -> None, None, None, None in - let () = solver.rollback msg solver_depth in - let () = rollback_query_indices query_indices_depth in - let tcenv = rollback_stack stack_depth in - let dsenv = DsEnv.rollback dsenv_depth in - // Because of the way ``snapshot`` is implemented, the `tcenv` and `dsenv` - // that we rollback to should be consistent: - FStar.Common.runtime_assert - (BU.physical_equality tcenv.dsenv dsenv) - "Inconsistent stack state"; - tcenv) - -let push env msg = snd (snapshot env msg) -let pop env msg = rollback env.solver msg None - -let incr_query_index env = - let qix = peek_query_indices () in - match env.qtbl_name_and_index with - | None, _ -> env - | Some (l, typ, n), tbl -> - match qix |> List.tryFind (fun (m, _) -> Ident.lid_equals l m) with - | None -> - let next = n + 1 in - add_query_index (l, next); - BU.smap_add tbl (string_of_lid l) next; - {env with qtbl_name_and_index=Some (l, typ, next), tbl} - | Some (_, m) -> - let next = m + 1 in - add_query_index (l, next); - BU.smap_add tbl (string_of_lid l) next; - {env with qtbl_name_and_index=Some (l, typ, next), tbl} - -//////////////////////////////////////////////////////////// -// Checking the per-module debug level and position info // -//////////////////////////////////////////////////////////// - -let set_range e r = if r=dummyRange then e else {e with range=r} -let get_range e = e.range - -instance hasRange_env : hasRange env = { - pos = get_range; - setPos = (fun r e -> set_range e r); -} - -let toggle_id_info env enabled = - env.identifier_info := - FStar.TypeChecker.Common.id_info_toggle !env.identifier_info enabled -let insert_bv_info env bv ty = - env.identifier_info := - FStar.TypeChecker.Common.id_info_insert_bv !env.identifier_info bv ty -let insert_fv_info env fv ty = - env.identifier_info := - FStar.TypeChecker.Common.id_info_insert_fv !env.identifier_info fv ty -let promote_id_info env ty_map = - env.identifier_info := - FStar.TypeChecker.Common.id_info_promote !env.identifier_info ty_map - -//////////////////////////////////////////////////////////// -// Private utilities // -//////////////////////////////////////////////////////////// -let modules env = env.modules -let current_module env = env.curmodule -let set_current_module env lid = {env with curmodule=lid} -let has_interface env l = env.modules |> BU.for_some (fun m -> m.is_interface && lid_equals m.name l) -let find_in_sigtab env lid = BU.smap_try_find (sigtab env) (string_of_lid lid) - -//Construct a new universe unification variable -let new_u_univ () = U_unif (UF.univ_fresh Range.dummyRange) - -let mk_univ_subst (formals : list univ_name) (us : universes) : list subst_elt = - assert (List.length us = List.length formals); - let n = List.length formals - 1 in - us |> List.mapi (fun i u -> UN (n - i, u)) - -//Instantiate the universe variables in a type scheme with provided universes -let inst_tscheme_with : tscheme -> universes -> universes & term = fun ts us -> - match ts, us with - | ([], t), [] -> [], t - | (formals, t), _ -> - let vs = mk_univ_subst formals us in - us, Subst.subst vs t - -//Instantiate the universe variables in a type scheme with new unification variables -let inst_tscheme : tscheme -> universes & term = function - | [], t -> [], t - | us, t -> - let us' = us |> List.map (fun _ -> new_u_univ()) in - inst_tscheme_with (us, t) us' - -let inst_tscheme_with_range (r:range) (t:tscheme) = - let us, t = inst_tscheme t in - us, Subst.set_use_range r t - -let check_effect_is_not_a_template (ed:eff_decl) (rng:Range.range) : unit = - if List.length ed.univs <> 0 || List.length ed.binders <> 0 - then - let msg = BU.format2 - "Effect template %s should be applied to arguments for its binders (%s) before it can be used at an effect position" - (show ed.mname) - (String.concat "," <| List.map Print.binder_to_string_with_type ed.binders) in - raise_error rng Errors.Fatal_NotEnoughArgumentsForEffect msg - -let inst_effect_fun_with (insts:universes) (env:env) (ed:eff_decl) (us, t) = - check_effect_is_not_a_template ed env.range; - if List.length insts <> List.length us - then failwith (BU.format4 "Expected %s instantiations; got %s; failed universe instantiation in effect %s\n\t%s\n" - (string_of_int <| List.length us) (string_of_int <| List.length insts) - (show ed.mname) (show t)); - snd (inst_tscheme_with (us, t) insts) - -type tri = - | Yes - | No - | Maybe - -let in_cur_mod env (l:lident) : tri = (* TODO: need a more efficient namespace check! *) - let cur = current_module env in - if nsstr l = (string_of_lid cur) then Yes (* fast case; works for everything except records *) - else if BU.starts_with (nsstr l) (string_of_lid cur) - then let lns = ns_of_lid l @ [ident_of_lid l] in - let cur = ns_of_lid cur @ [ident_of_lid cur] in - let rec aux c l = match c, l with - | [], _ -> Maybe - | _, [] -> No - | hd::tl, hd'::tl' when ((string_of_id hd = string_of_id hd')) -> aux tl tl' - | _ -> No in - aux cur lns - else No - -let lookup_qname env (lid:lident) : qninfo = - let cur_mod = in_cur_mod env lid in - let cache t = BU.smap_add (gamma_cache env) (string_of_lid lid) t; Some t in - let found = - if cur_mod <> No - then match BU.smap_try_find (gamma_cache env) (string_of_lid lid) with - | None -> - BU.catch_opt - (BU.find_map env.gamma (function - | Binding_lid(l, (us_names, t)) when lid_equals lid l-> - (* A recursive definition. - * We must return the exact set of universes on which - * it is being defined, and not instantiate it. - * TODO: could we cache this? *) - let us = List.map U_name us_names in - Some (Inl (us, t), Ident.range_of_lid l) - | _ -> None)) - (fun () -> BU.find_map env.gamma_sig (function - | (_, { sigel = Sig_bundle {ses} }) -> - BU.find_map ses (fun se -> - if lids_of_sigelt se |> BU.for_some (lid_equals lid) - then cache (Inr (se, None), U.range_of_sigelt se) - else None) - | (lids, s) -> - let maybe_cache t = match s.sigel with - | Sig_declare_typ _ -> Some t - | _ -> cache t - in - begin match List.tryFind (lid_equals lid) lids with - | None -> None - | Some l -> maybe_cache (Inr (s, None), Ident.range_of_lid l) - end)) - | se -> se - else None - in - if is_some found - then found - else match find_in_sigtab env lid with - | Some se -> Some (Inr (se, None), U.range_of_sigelt se) - | None -> None - -let lookup_sigelt (env:env) (lid:lid) : option sigelt = - match lookup_qname env lid with - | None -> None - | Some (Inl _, rng) -> None - | Some (Inr (se, us), rng) -> Some se - -let lookup_attr (env:env) (attr:string) : list sigelt = - match BU.smap_try_find (attrtab env) attr with - | Some ses -> ses - | None -> [] - -let add_se_to_attrtab env se = - let add_one env se attr = BU.smap_add (attrtab env) attr (se :: lookup_attr env attr) in - List.iter (fun attr -> - let hd, _ = U.head_and_args attr in - match (Subst.compress hd).n with - | Tm_fvar fv -> add_one env se (string_of_lid (lid_of_fv fv)) - | _ -> ()) se.sigattrs - -(* This adds a sigelt to the sigtab in the environment but checks -that we are not clashing with something that is already defined. -The force flag overrides the check, it's convenient in the checking for -haseq in inductives. *) -let try_add_sigelt force env se l = - let s = string_of_lid l in - if not force && Some? (BU.smap_try_find (sigtab env) s) then ( - let old_se = Some?.v (BU.smap_try_find (sigtab env) s) in - if Sig_declare_typ? old_se.sigel && - (Sig_let? se.sigel || Sig_inductive_typ? se.sigel || Sig_datacon? se.sigel) - then - (* overriding a val with a let, a type, or a datacon is ok *) - () - else ( - (* anything else is an error *) - let open FStar.Errors.Msg in - let open FStar.Pprint in - raise_error l Errors.Fatal_DuplicateTopLevelNames [ - text "Duplicate top-level names" ^/^ arbitrary_string s; - text "Previously declared at" ^/^ arbitrary_string (Range.string_of_range (range_of_lid l)); - // text "New decl = " ^/^ Print.sigelt_to_doc se; - // text "Old decl = " ^/^ Print.sigelt_to_doc old_se; - // backtrace_doc (); - ] - ) - ); - BU.smap_add (sigtab env) s se - -let rec add_sigelt force env se = match se.sigel with - | Sig_bundle {ses} -> add_sigelts force env ses - | _ -> - let lids = lids_of_sigelt se in - List.iter (try_add_sigelt force env se) lids; - add_se_to_attrtab env se - -and add_sigelts force env ses = - ses |> List.iter (add_sigelt force env) - -//////////////////////////////////////////////////////////// -// Lookup up various kinds of identifiers // -//////////////////////////////////////////////////////////// -let try_lookup_bv env (bv:bv) = - BU.find_map env.gamma (function - | Binding_var id when bv_eq id bv -> - Some (id.sort, (range_of_id id.ppname)) - | _ -> None) - -let lookup_type_of_let us_opt se lid = - let inst_tscheme ts = - match us_opt with - | None -> inst_tscheme ts - | Some us -> inst_tscheme_with ts us - in - match se.sigel with - | Sig_let {lbs=(_, [lb])} -> - Some (inst_tscheme (lb.lbunivs, lb.lbtyp), S.range_of_lbname lb.lbname) - - | Sig_let {lbs=(_, lbs)} -> - BU.find_map lbs (fun lb -> match lb.lbname with - | Inl _ -> failwith "impossible" - | Inr fv -> - if fv_eq_lid fv lid - then Some (inst_tscheme (lb.lbunivs, lb.lbtyp), S.range_of_fv fv) - else None) - - | _ -> None - -let effect_signature (us_opt:option universes) (se:sigelt) rng : option ((universes & typ) & Range.range) = - let inst_ts us_opt ts = - match us_opt with - | None -> inst_tscheme ts - | Some us -> inst_tscheme_with ts us - in - match se.sigel with - | Sig_new_effect ne -> - let sig_ts = U.effect_sig_ts ne.signature in - check_effect_is_not_a_template ne rng; - (match us_opt with - | None -> () - | Some us -> - if List.length us <> List.length (fst sig_ts) - then failwith ("effect_signature: incorrect number of universes for the signature of " ^ - (string_of_lid ne.mname) ^ ", expected " ^ (string_of_int (List.length (fst sig_ts))) ^ - ", got " ^ (string_of_int (List.length us))) - else ()); - - Some (inst_ts us_opt sig_ts, se.sigrng) - - | Sig_effect_abbrev {lid; us; bs=binders} -> - Some (inst_ts us_opt (us, U.arrow binders (mk_Total teff)), se.sigrng) - - | _ -> None - -let try_lookup_lid_aux us_opt env lid = - let inst_tscheme ts = - match us_opt with - | None -> inst_tscheme ts - | Some us -> inst_tscheme_with ts us - in - let mapper (lr, rng) = - match lr with - | Inl t -> - Some (t, rng) - - | Inr ({sigel = Sig_datacon {us=uvs; t} }, None) -> - Some (inst_tscheme (uvs, t), rng) - - | Inr ({sigel = Sig_declare_typ {lid=l; us=uvs; t}; sigquals=qs }, None) -> - if in_cur_mod env l = Yes - then if qs |> List.contains Assumption || env.is_iface - then Some (inst_tscheme (uvs, t), rng) - else None - else Some (inst_tscheme (uvs, t), rng) - - | Inr ({sigel = Sig_inductive_typ {lid; us=uvs; params=tps; t=k} }, None) -> - begin match tps with - | [] -> Some (inst_tscheme (uvs, k), rng) - | _ -> Some (inst_tscheme (uvs, U.flat_arrow tps (mk_Total k)), rng) - end - - | Inr ({sigel = Sig_inductive_typ {lid; us=uvs; params=tps; t=k} }, Some us) -> - begin match tps with - | [] -> Some (inst_tscheme_with (uvs, k) us, rng) - | _ -> Some (inst_tscheme_with (uvs, U.flat_arrow tps (mk_Total k)) us, rng) - end - - | Inr se -> - begin match se with // FIXME why does this branch not use rng? - | { sigel = Sig_let _ }, None -> - lookup_type_of_let us_opt (fst se) lid - - | _ -> - effect_signature us_opt (fst se) env.range - end |> BU.map_option (fun (us_t, rng) -> (us_t, rng)) - in - match BU.bind_opt (lookup_qname env lid) mapper with - | Some ((us, t), r) -> Some ((us, {t with pos=range_of_lid lid}), r) - | None -> None - -//////////////////////////////////////////////////////////////// -//External interaface for querying identifiers -//Provides, in order from the interface env.fsi: -// val lid_exists : env -> lident -> bool -// val lookup_bv : env -> bv -> typ -// val try_lookup_lid : env -> lident -> option (universes * typ) -// val lookup_lid : env -> lident -> (universes * typ) -// val lookup_univ : env -> univ_name -> bool -// val try_lookup_val_decl : env -> lident -> option (tscheme * list qualifier) -// val lookup_val_decl : env -> lident -> universes * typ -// val lookup_datacon : env -> lident -> universes * typ -// val datacons_of_typ : env -> lident -> bool * list lident -// val typ_of_datacon : env -> lident -> lident -// val lookup_definition : delta_level -> env -> lident -> option (univ_names * term) -// val lookup_attrs_of_lid : env -> lid -> option list attribute -// val try_lookup_effect_lid : env -> lident -> option term -// val lookup_effect_lid : env -> lident -> term -// val lookup_effect_abbrev : env -> universes -> lident -> option (binders * comp) -// val norm_eff_name : (env -> lident -> lident) -// val lookup_effect_quals : env -> lident -> list qualifier -// val lookup_projector : env -> lident -> int -> lident -// val current_module : env -> lident -// val is_projector : env -> lident -> bool -// val is_datacon : env -> lident -> bool -// val is_record : env -> lident -> bool -// val is_interpreted : (env -> term -> bool) -// val is_type_constructor : env -> lident -> bool -// val num_inductive_ty_params: env -> lident -> int -//Each of these functions that returns a term ensures to update -//the range information on the term with the currrent use-site -//////////////////////////////////////////////////////////////// - -let lid_exists env l = - match lookup_qname env l with - | None -> false - | Some _ -> true - -let lookup_bv env bv = - let bvr = range_of_bv bv in - match try_lookup_bv env bv with - | None -> raise_error bvr Errors.Fatal_VariableNotFound - (format1 "Variable \"%s\" not found" (show bv)) - | Some (t, r) -> Subst.set_use_range bvr t, - Range.set_use_range r (Range.use_range bvr) - -let try_lookup_lid env l = - match try_lookup_lid_aux None env l with - | None -> None - | Some ((us, t), r) -> - let use_range = range_of_lid l in - let r = Range.set_use_range r (Range.use_range use_range) in - Some ((us, Subst.set_use_range use_range t), r) - -let try_lookup_and_inst_lid env us l = - match try_lookup_lid_aux (Some us) env l with - | None -> None - | Some ((_, t), r) -> - let use_range = range_of_lid l in - let r = Range.set_use_range r (Range.use_range use_range) in - Some (Subst.set_use_range use_range t, r) - -let name_not_found (#a:Type) (l:lid) : a = - raise_error l Errors.Fatal_NameNotFound - (format1 "Name \"%s\" not found" (string_of_lid l)) - -let lookup_lid env l = - match try_lookup_lid env l with - | Some v -> v - | None -> name_not_found l - -let lookup_univ env x = - List.find (function - | Binding_univ y -> (string_of_id x = string_of_id y) - | _ -> false) env.gamma - |> Option.isSome - -let try_lookup_val_decl env lid = - //QUESTION: Why does this not inst_tscheme? - match lookup_qname env lid with - | Some (Inr ({ sigel = Sig_declare_typ {us=uvs; t}; sigquals = q }, None), _) -> - Some ((uvs, Subst.set_use_range (range_of_lid lid) t),q) - | _ -> None - -let lookup_val_decl env lid = - match lookup_qname env lid with - | Some (Inr ({ sigel = Sig_declare_typ {us=uvs; t} }, None), _) -> - inst_tscheme_with_range (range_of_lid lid) (uvs, t) - | _ -> name_not_found lid - -let lookup_datacon env lid = - match lookup_qname env lid with - | Some (Inr ({ sigel = Sig_datacon {us=uvs; t} }, None), _) -> - inst_tscheme_with_range (range_of_lid lid) (uvs, t) - | _ -> name_not_found lid - -let lookup_and_inst_datacon env us lid = - match lookup_qname env lid with - | Some (Inr ({ sigel = Sig_datacon {us=uvs; t} }, None), _) -> - inst_tscheme_with (uvs, t) us |> snd - | _ -> name_not_found lid - -let datacons_of_typ env lid = - match lookup_qname env lid with - | Some (Inr ({ sigel = Sig_inductive_typ {ds=dcs} }, _), _) -> true, dcs - | _ -> false, [] - -let typ_of_datacon env lid = - match lookup_qname env lid with - | Some (Inr ({ sigel = Sig_datacon {ty_lid=l} }, _), _) -> l - | _ -> failwith (BU.format1 "Not a datacon: %s" (show lid)) - -let num_datacon_non_injective_ty_params env lid = - match lookup_qname env lid with - | Some (Inr ({ sigel = Sig_datacon {num_ty_params; injective_type_params} }, _), _) -> - if injective_type_params then Some 0 else Some num_ty_params - | _ -> None - -let visible_with delta_levels quals = - delta_levels |> BU.for_some (fun dl -> quals |> BU.for_some (visible_at dl)) - -let lookup_definition_qninfo_aux rec_ok delta_levels lid (qninfo : qninfo) = - match qninfo with - | Some (Inr (se, None), _) -> - begin match se.sigel with - | Sig_let {lbs=(is_rec, lbs)} - when visible_with delta_levels se.sigquals - && (not is_rec || rec_ok) -> - BU.find_map lbs (fun lb -> - let fv = right lb.lbname in - if fv_eq_lid fv lid - then Some (lb.lbunivs, lb.lbdef) - else None) - | _ -> None - end - | _ -> None - -let lookup_definition_qninfo delta_levels lid (qninfo : qninfo) = - lookup_definition_qninfo_aux true delta_levels lid qninfo - -let lookup_definition delta_levels env lid = - lookup_definition_qninfo delta_levels lid <| lookup_qname env lid - -let lookup_nonrec_definition delta_levels env lid = - lookup_definition_qninfo_aux false delta_levels lid <| lookup_qname env lid - -let rec delta_depth_of_qninfo_lid env lid (qn:qninfo) : delta_depth = - match qn with - | None - | Some (Inl _, _) -> delta_constant - | Some (Inr(se, _), _) -> - match se.sigel with - | Sig_inductive_typ _ - | Sig_bundle _ - | Sig_datacon _ -> delta_constant - - | Sig_declare_typ _ -> - let d0 = - if U.is_primop_lid lid - then delta_equational - else delta_constant - in - if se.sigquals |> BU.for_some (Assumption?) - && not (se.sigquals |> BU.for_some (New?)) - then Delta_abstract d0 - else d0 - - | Sig_let {lbs=(_,lbs)} -> - BU.find_map lbs (fun lb -> - let fv = right lb.lbname in - if fv_eq_lid fv lid then - Some (incr_delta_depth <| delta_depth_of_term env lb.lbdef) - else None) |> must - - | Sig_fail _ - | Sig_splice _ -> - failwith "impossible: delta_depth_of_qninfo" - - | Sig_assume _ - | Sig_new_effect _ - | Sig_sub_effect _ - | Sig_effect_abbrev _ (* None? *) - | Sig_pragma _ - | Sig_polymonadic_bind _ - | Sig_polymonadic_subcomp _ -> - delta_constant - -and delta_depth_of_qninfo env (fv:fv) (qn:qninfo) : delta_depth = - delta_depth_of_qninfo_lid env fv.fv_name.v qn - -(* Computes the canonical delta_depth of a given fvar, by looking at its -definition (and recursing) if needed. Results are memoized in the env. - -NB: The cache is never invalidated. A potential problem here would be -if we memoize the delta_depth of a `val` before seeing the corresponding -`let`, but I don't think that can happen. Before seeing the `let`, other code -cannot refer to the name. *) -and delta_depth_of_fv (env:env) (fv:S.fv) : delta_depth = - let lid = fv.fv_name.v in - (string_of_lid lid) |> BU.smap_try_find env.fv_delta_depths |> (function - | Some dd -> dd - | None -> - BU.smap_add env.fv_delta_depths (string_of_lid lid) delta_equational; - // ^ To prevent an infinite loop on recursive functions, we pre-seed the cache with - // a delta_equational. If we run into the same function while computing its delta_depth, - // we will return delta_equational. If not, we override the cache with the correct delta_depth. - let d = delta_depth_of_qninfo env fv (lookup_qname env fv.fv_name.v) in - // if Debug.any () then - // BU.print2_error "Memoizing delta_depth_of_fv %s ->\t%s\n" (show lid) (show d); - BU.smap_add env.fv_delta_depths (string_of_lid lid) d; - d) - -(* Computes the delta_depth of an fv, but taking into account the visibility -in the current module. *) -and fv_delta_depth (env:env) (fv:S.fv) : delta_depth = - let d = delta_depth_of_fv env fv in - match d with - | Delta_abstract (Delta_constant_at_level l) -> - if string_of_lid env.curmodule = nsstr fv.fv_name.v && not env.is_iface - //AR: TODO: this is to prevent unfolding of abstract symbols in the extracted interface - //a better way would be create new fvs with appripriate delta_depth at extraction time - then Delta_constant_at_level l //we're in the defining module - else delta_constant - | d -> d - -(* Computes the delta_depth of a term. This is the single way to compute it. *) -and delta_depth_of_term env t = - let t = U.unmeta t in - match t.n with - | Tm_meta _ - | Tm_delayed _ -> failwith "Impossible (delta depth of term)" - | Tm_lazy i -> delta_depth_of_term env (U.unfold_lazy i) - - | Tm_fvar fv -> fv_delta_depth env fv - - | Tm_bvar _ - | Tm_name _ - | Tm_match _ - | Tm_uvar _ - | Tm_unknown -> delta_equational - - | Tm_type _ - | Tm_quoted _ - | Tm_constant _ - | Tm_arrow _ -> delta_constant - - | Tm_uinst(t, _) - | Tm_refine {b={sort=t}} - | Tm_ascribed {tm=t} - | Tm_app {hd=t} - | Tm_abs {body=t} - | Tm_let {body=t} -> delta_depth_of_term env t - -let quals_of_qninfo (qninfo : qninfo) : option (list qualifier) = - match qninfo with - | Some (Inr (se, _), _) -> Some se.sigquals - | _ -> None - -let attrs_of_qninfo (qninfo : qninfo) : option (list attribute) = - match qninfo with - | Some (Inr (se, _), _) -> Some se.sigattrs - | _ -> None - -let lookup_attrs_of_lid env lid : option (list attribute) = - attrs_of_qninfo <| lookup_qname env lid - -let fv_exists_and_has_attr env fv_lid attr_lid : bool & bool = - match lookup_attrs_of_lid env fv_lid with - | None -> - false, false - | Some attrs -> - true, - attrs |> BU.for_some (fun tm -> - match (U.un_uinst tm).n with - | Tm_fvar fv -> S.fv_eq_lid fv attr_lid - | _ -> false) - -let fv_with_lid_has_attr env fv_lid attr_lid : bool = - snd (fv_exists_and_has_attr env fv_lid attr_lid) - -let fv_has_attr env fv attr_lid = - fv_with_lid_has_attr env fv.fv_name.v attr_lid - -let cache_in_fv_tab (tab:BU.smap 'a) (fv:fv) (f:unit -> (bool & 'a)) : 'a = - let s = string_of_lid (S.lid_of_fv fv) in - match BU.smap_try_find tab s with - | None -> - let should_cache, res = f () in - if should_cache then BU.smap_add tab s res; - res - - | Some r -> - r - -let fv_has_erasable_attr env fv = - let f () = - let ex, erasable = fv_exists_and_has_attr env fv.fv_name.v Const.erasable_attr in - ex,erasable - //unfortunately, treating the Const.must_erase_for_extraction_attr - //in the same way here as erasable_attr leads to regressions in fragile proofs, - //notably in FStar.ModifiesGen, since this expands the class of computation types - //that can be promoted from ghost to tot. That in turn results in slightly different - //smt encodings, leading to breakages. So, sadly, I'm not including must_erase_for_extraction - //here. In any case, must_erase_for_extraction is transitionary and should be removed - in - cache_in_fv_tab env.erasable_types_tab fv f - -let fv_has_strict_args env fv = - let f () = - let attrs = lookup_attrs_of_lid env (S.lid_of_fv fv) in - match attrs with - | None -> false, None - | Some attrs -> - let res = - BU.find_map attrs (fun x -> - fst (FStar.ToSyntax.ToSyntax.parse_attr_with_list - false x FStar.Parser.Const.strict_on_arguments_attr)) - in - true, res - in - cache_in_fv_tab env.strict_args_tab fv f - -let try_lookup_effect_lid env (ftv:lident) : option typ = - match lookup_qname env ftv with - | Some (Inr (se, None), _) -> - begin match effect_signature None se env.range with - | None -> None - | Some ((_, t), r) -> Some (Subst.set_use_range (range_of_lid ftv) t) - end - | _ -> None - -let lookup_effect_lid env (ftv:lident) : typ = - match try_lookup_effect_lid env ftv with - | None -> name_not_found ftv - | Some k -> k - -let lookup_effect_abbrev env (univ_insts:universes) lid0 = - match lookup_qname env lid0 with - | Some (Inr ({ sigel = Sig_effect_abbrev {lid; us=univs; bs=binders; comp=c}; sigquals = quals }, None), _) -> - let lid = Ident.set_lid_range lid (Range.set_use_range (Ident.range_of_lid lid) (Range.use_range (Ident.range_of_lid lid0))) in - if quals |> BU.for_some (function Irreducible -> true | _ -> false) - then None - else let insts = if List.length univ_insts = List.length univs - then univ_insts - else failwith (BU.format3 "(%s) Unexpected instantiation of effect %s with %s universes" - (Range.string_of_range (get_range env)) - (show lid) - (List.length univ_insts |> BU.string_of_int)) in - begin match binders, univs with - | [], _ -> failwith "Unexpected effect abbreviation with no arguments" - | _, _::_::_ -> - failwith (BU.format2 "Unexpected effect abbreviation %s; polymorphic in %s universes" - (show lid) (string_of_int <| List.length univs)) - | _ -> let _, t = inst_tscheme_with (univs, U.arrow binders c) insts in - let t = Subst.set_use_range (range_of_lid lid) t in - begin match (Subst.compress t).n with - | Tm_arrow {bs=binders; comp=c} -> - Some (binders, c) - | _ -> failwith "Impossible" - end - end - | _ -> None - -let norm_eff_name = - fun env (l:lident) -> - let rec find l = - match lookup_effect_abbrev env [U_unknown] l with //universe doesn't matter here; we're just normalizing the name - | None -> None - | Some (_, c) -> - let l = U.comp_effect_name c in - match find l with - | None -> Some l - | Some l' -> Some l' in - let res = match BU.smap_try_find env.normalized_eff_names (string_of_lid l) with - | Some l -> l - | None -> - begin match find l with - | None -> l - | Some m -> BU.smap_add env.normalized_eff_names (string_of_lid l) m; - m - end in - Ident.set_lid_range res (range_of_lid l) - -let is_erasable_effect env l = - l - |> norm_eff_name env - |> (fun l -> lid_equals l Const.effect_GHOST_lid || - S.lid_as_fv l None - |> fv_has_erasable_attr env) - -let rec non_informative env t = - match (U.unrefine t).n with - | Tm_type _ -> true - | Tm_fvar fv -> - fv_eq_lid fv Const.unit_lid - || fv_eq_lid fv Const.squash_lid - || fv_eq_lid fv Const.erased_lid - || fv_has_erasable_attr env fv - | Tm_app {hd=head} -> non_informative env head - | Tm_uinst (t, _) -> non_informative env t - | Tm_arrow {comp=c} -> - (is_pure_or_ghost_comp c && non_informative env (comp_result c)) - || is_erasable_effect env (comp_effect_name c) - | _ -> false - -let num_effect_indices env name r = - let sig_t = name |> lookup_effect_lid env |> SS.compress in - match sig_t.n with - | Tm_arrow {bs=_a::bs} -> List.length bs - | _ -> - raise_error r Errors.Fatal_UnexpectedSignatureForMonad - (BU.format2 "Signature for %s not an arrow (%s)" (show name) (show sig_t)) - -let lookup_effect_quals env l = - let l = norm_eff_name env l in - match lookup_qname env l with - | Some (Inr ({ sigel = Sig_new_effect _; sigquals=q}, _), _) -> - q - | _ -> [] - -let lookup_projector env lid i = - let fail () = failwith (BU.format2 "Impossible: projecting field #%s from constructor %s is undefined" (BU.string_of_int i) (show lid)) in - let _, t = lookup_datacon env lid in - match (compress t).n with - | Tm_arrow {bs=binders} -> - if ((i < 0) || i >= List.length binders) //this has to be within bounds! - then fail () - else let b = List.nth binders i in - U.mk_field_projector_name lid b.binder_bv i - | _ -> fail () - -let is_projector env (l:lident) : bool = - match lookup_qname env l with - | Some (Inr ({ sigel = Sig_declare_typ _; sigquals=quals }, _), _) -> - BU.for_some (function Projector _ -> true | _ -> false) quals - | _ -> false - -let is_datacon env lid = - match lookup_qname env lid with - | Some (Inr ({ sigel = Sig_datacon _ }, _), _) -> true - | _ -> false - -let is_record env lid = - match lookup_qname env lid with - | Some (Inr ({ sigel = Sig_inductive_typ _; sigquals=quals }, _), _) -> - BU.for_some (function RecordType _ | RecordConstructor _ -> true | _ -> false) quals - | _ -> false - -let qninfo_is_action (qninfo : qninfo) = - match qninfo with - | Some (Inr ({ sigel = Sig_let _; sigquals = quals }, _), _) -> - BU.for_some (function Action _ -> true | _ -> false) quals - | _ -> false - -let is_action env lid = - qninfo_is_action <| lookup_qname env lid - -// FIXME? Does not use environment. -let is_interpreted = - let interpreted_symbols = - [Const.op_Eq; - Const.op_notEq; - Const.op_LT; - Const.op_LTE; - Const.op_GT; - Const.op_GTE; - Const.op_Subtraction; - Const.op_Minus; - Const.op_Addition; - Const.op_Multiply; - Const.op_Division; - Const.op_Modulus; - Const.op_And; - Const.op_Or; - Const.op_Negation] in - fun (env:env) head -> - match (U.un_uinst head).n with - | Tm_fvar fv -> - BU.for_some (Ident.lid_equals fv.fv_name.v) interpreted_symbols || - (match delta_depth_of_fv env fv with - | Delta_equational_at_level _ -> true - | _ -> false) - | _ -> false - -let is_irreducible env l = - match lookup_qname env l with - | Some (Inr (se, _), _) -> - BU.for_some (function Irreducible -> true | _ -> false) se.sigquals - | _ -> false - -let is_type_constructor env lid = - let mapper x = - match fst x with - | Inl _ -> Some false - | Inr (se, _) -> - begin match se.sigel with - | Sig_declare_typ _ -> - Some (List.contains New se.sigquals) - | Sig_inductive_typ _ -> - Some true - | _ -> Some false - end in - match BU.bind_opt (lookup_qname env lid) mapper with - | Some b -> b - | None -> false - -let num_inductive_ty_params env lid = - match lookup_qname env lid with - | Some (Inr ({ sigel = Sig_inductive_typ {params=tps} }, _), _) -> - Some (List.length tps) - | _ -> - None - -let num_inductive_uniform_ty_params env lid = - match lookup_qname env lid with - | Some (Inr ({ sigel = Sig_inductive_typ {num_uniform_params=num_uniform} }, _), _) -> - ( - match num_uniform with - | None -> - raise_error lid Errors.Fatal_UnexpectedInductivetype - (BU.format1 "Internal error: Inductive %s is not decorated with its uniform type parameters" - (show lid)) - | Some n -> Some n - ) - | _ -> - None - -//////////////////////////////////////////////////////////// -// Operations on the monad lattice // -//////////////////////////////////////////////////////////// -let effect_decl_opt env l = - env.effects.decls |> BU.find_opt (fun (d, _) -> lid_equals d.mname l) - -let get_effect_decl env l = - match effect_decl_opt env l with - | None -> name_not_found l - | Some md -> fst md - -let get_lid_valued_effect_attr env - (eff_lid attr_name_lid:lident) - (default_if_attr_has_no_arg:option lident) - : option lident - = let attr_args = - eff_lid |> norm_eff_name env - |> lookup_attrs_of_lid env - |> BU.dflt [] - |> U.get_attribute attr_name_lid in - match attr_args with - | None -> None - | Some args -> - if List.length args = 0 - then default_if_attr_has_no_arg - else args - |> List.hd - |> (fun (t, _) -> - match (SS.compress t).n with - | Tm_constant (FStar.Const.Const_string (s, _)) -> s |> Ident.lid_of_str |> Some - | _ -> - raise_error t Errors.Fatal_UnexpectedEffect - (BU.format2 "The argument for the effect attribute for %s is not a constant string, it is %s\n" - (show eff_lid) - (show t))) - -let get_default_effect env lid = - get_lid_valued_effect_attr env lid Const.default_effect_attr None - -let get_top_level_effect env lid = - get_lid_valued_effect_attr env lid Const.top_level_effect_attr (Some lid) - -let is_layered_effect env l = - l |> get_effect_decl env |> U.is_layered - -let identity_mlift : mlift = - { mlift_wp=(fun _ c -> c, trivial_guard); - mlift_term=Some (fun _ _ e -> return_all e) } - -let join_opt env (l1:lident) (l2:lident) : option (lident & mlift & mlift) = - if lid_equals l1 l2 - then Some (l1, identity_mlift, identity_mlift) - else if lid_equals l1 Const.effect_GTot_lid && lid_equals l2 Const.effect_Tot_lid - || lid_equals l2 Const.effect_GTot_lid && lid_equals l1 Const.effect_Tot_lid - then Some (Const.effect_GTot_lid, identity_mlift, identity_mlift) - else match env.effects.joins |> BU.find_opt (fun (m1, m2, _, _, _) -> lid_equals l1 m1 && lid_equals l2 m2) with - | None -> None - | Some (_, _, m3, j1, j2) -> Some (m3, j1, j2) - -let join env l1 l2 : (lident & mlift & mlift) = - match join_opt env l1 l2 with - | None -> - raise_error env Errors.Fatal_EffectsCannotBeComposed - (BU.format2 "Effects %s and %s cannot be composed" (show l1) (show l2)) - | Some t -> t - -let monad_leq env l1 l2 : option edge = - if lid_equals l1 l2 - || (lid_equals l1 Const.effect_Tot_lid && lid_equals l2 Const.effect_GTot_lid) - then Some ({msource=l1; mtarget=l2; mlift=identity_mlift; mpath=[]}) - else env.effects.order |> BU.find_opt (fun e -> lid_equals l1 e.msource && lid_equals l2 e.mtarget) - -let wp_sig_aux decls m = - match decls |> BU.find_opt (fun (d, _) -> lid_equals d.mname m) with - | None -> failwith (BU.format1 "Impossible: declaration for monad %s not found" (string_of_lid m)) - | Some (md, _q) -> - (* - * AR: this code used to be inst_tscheme md.univs md.signature - * i.e. implicitly there was an assumption that ed.binders is empty - * now when signature is itself a tscheme, this just translates to the following - *) - let _, s = md.signature |> U.effect_sig_ts |> inst_tscheme in - let s = Subst.compress s in - match md.binders, s.n with - | [], Tm_arrow {bs=[b; wp_b]; comp=c} when (is_teff (comp_result c)) -> b.binder_bv, wp_b.binder_bv.sort - | _ -> failwith "Impossible" - -let wp_signature env m = wp_sig_aux env.effects.decls m - -let bound_vars_of_bindings bs = - bs |> List.collect (function - | Binding_var x -> [x] - | Binding_lid _ - | Binding_univ _ -> []) - -let binders_of_bindings bs = bound_vars_of_bindings bs |> List.map Syntax.mk_binder |> List.rev -let all_binders env = binders_of_bindings env.gamma -let bound_vars env = bound_vars_of_bindings env.gamma - -instance hasBinders_env : hasBinders env = { - boundNames = (fun e -> FlatSet.from_list (bound_vars e) ); -} - -instance hasNames_lcomp : hasNames lcomp = { - freeNames = (fun lc -> freeNames (fst (lcomp_comp lc))); -} - -instance pretty_lcomp : pretty lcomp = { - pp = (fun lc -> let open FStar.Pprint in empty); -} - -instance hasNames_guard : hasNames guard_t = { - freeNames = (fun g -> match g.guard_f with - | Trivial -> FlatSet.empty () - | NonTrivial f -> freeNames f); -} - -instance pretty_guard : pretty guard_t = { - pp = (fun g -> let open FStar.Pprint in - match g.guard_f with - | Trivial -> doc_of_string "Trivial" - | NonTrivial f -> doc_of_string "NonTrivial" ^/^ pp f); -} - -let comp_to_comp_typ (env:env) c = - def_check_scoped c.pos "comp_to_comp_typ" env c; - match c.n with - | Comp ct -> ct - | _ -> - let effect_name, result_typ = - match c.n with - | Total t -> Const.effect_Tot_lid, t - | GTotal t -> Const.effect_GTot_lid, t in - {comp_univs = [env.universe_of env result_typ]; - effect_name; - result_typ; - effect_args = []; - flags = U.comp_flags c} - -let comp_set_flags env c f = - def_check_scoped c.pos "comp_set_flags.IN" env c; - let r = {c with n=Comp ({comp_to_comp_typ env c with flags=f})} in - def_check_scoped c.pos "comp_set_flags.OUT" env r; - r - -let rec unfold_effect_abbrev env comp = - def_check_scoped comp.pos "unfold_effect_abbrev" env comp; - let c = comp_to_comp_typ env comp in - match lookup_effect_abbrev env c.comp_univs c.effect_name with - | None -> c - | Some (binders, cdef) -> - let binders, cdef = Subst.open_comp binders cdef in - if List.length binders <> List.length c.effect_args + 1 then - raise_error comp Errors.Fatal_ConstructorArgLengthMismatch - (BU.format3 "Effect constructor is not fully applied; expected %s args, got %s args, i.e., %s" - (show (List.length binders)) (show (List.length c.effect_args + 1)) - (show (S.mk_Comp c))); - let inst = List.map2 (fun b (t, _) -> NT(b.binder_bv, t)) binders (as_arg c.result_typ::c.effect_args) in - let c1 = Subst.subst_comp inst cdef in - let c = {comp_to_comp_typ env c1 with flags=c.flags} |> mk_Comp in - unfold_effect_abbrev env c - -let effect_repr_aux only_reifiable env c u_res = - let check_partial_application eff_name (args:args) = - let r = get_range env in - let given, expected = List.length args, num_effect_indices env eff_name r in - if given = expected then () - else - let message = BU.format3 "Not enough arguments for effect %s, \ - This usually happens when you use a partially applied DM4F effect, \ - like [TAC int] instead of [Tac int] (given:%s, expected:%s)." - (Ident.string_of_lid eff_name) (string_of_int given) (string_of_int expected) in - raise_error r Errors.Fatal_NotEnoughArgumentsForEffect message - in - - let effect_name = norm_eff_name env (U.comp_effect_name c) in - match effect_decl_opt env effect_name with - | None -> None - | Some (ed, _) -> - match ed |> U.get_eff_repr with - | None -> None - | Some ts -> - let c = unfold_effect_abbrev env c in - let res_typ = c.result_typ in - let repr = inst_effect_fun_with [u_res] env ed ts in - check_partial_application effect_name c.effect_args; - Some (S.mk (Tm_app {hd=repr; args=((res_typ |> S.as_arg)::c.effect_args)}) (get_range env)) - -let effect_repr env c u_res : option term = effect_repr_aux false env c u_res - -(* [is_reifiable_* env x] returns true if the effect name/computational *) -(* effect (of a body or codomain of an arrow) [x] is reifiable. *) - -(* [is_user_reifiable_* env x] is more restrictive, and only allows *) -(* reifying effects marked with the `reifiable` keyword. (For instance, TAC *) -(* is reifiable but not user-reifiable.) *) - -let is_user_reifiable_effect (env:env) (effect_lid:lident) : bool = - let effect_lid = norm_eff_name env effect_lid in - let quals = lookup_effect_quals env effect_lid in - List.contains Reifiable quals - -let is_user_reflectable_effect (env:env) (effect_lid:lident) : bool = - let effect_lid = norm_eff_name env effect_lid in - let quals = lookup_effect_quals env effect_lid in - quals |> List.existsb (function Reflectable _ -> true | _ -> false) - -let is_total_effect (env:env) (effect_lid:lident) : bool = - let effect_lid = norm_eff_name env effect_lid in - let quals = lookup_effect_quals env effect_lid in - List.contains TotalEffect quals - -let is_reifiable_effect (env:env) (effect_lid:lident) : bool = - let effect_lid = norm_eff_name env effect_lid in - is_user_reifiable_effect env effect_lid - || Ident.lid_equals effect_lid Const.effect_TAC_lid - -let is_reifiable_rc (env:env) (c:S.residual_comp) : bool = - is_reifiable_effect env c.residual_effect - -let is_reifiable_comp (env:env) (c:S.comp) : bool = - match c.n with - | Comp ct -> is_reifiable_effect env ct.effect_name - | _ -> false - -let is_reifiable_function (env:env) (t:S.term) : bool = - match (compress t).n with - | Tm_arrow {comp=c} -> is_reifiable_comp env c - | _ -> false - -let reify_comp env c u_c : term = - let l = U.comp_effect_name c in - if not (is_reifiable_effect env l) then - raise_error env Errors.Fatal_EffectCannotBeReified - (BU.format1 "Effect %s cannot be reified" (Ident.string_of_lid l)); - match effect_repr_aux true env c u_c with - | None -> failwith "internal error: reifiable effect has no repr?" - | Some tm -> tm - - -/////////////////////////////////////////////////////////// -// Introducing identifiers and updating the environment // -//////////////////////////////////////////////////////////// - -// The environment maintains the invariant that gamma is of the form: -// l_1 ... l_n val_1 ... val_n -// where l_i is a local binding and val_i is a top-level binding. -// -//let push_in_gamma env s = -// let rec push x rest = -// match rest with -// | Binding_sig _ :: _ -> -// x :: rest -// | [] -> -// [ x ] -// | local :: rest -> -// local :: push x rest -// in -// env.tc_hooks.tc_push_in_gamma_hook env s; -// { env with gamma = push s env.gamma } - -let rec record_vals_and_defns (g:env) (se:sigelt) : env = - match se.sigel with - | Sig_declare_typ _ - | Sig_let _ - when se.sigquals |> BU.for_some (function OnlyName -> true | _ -> false) -> - g - | Sig_declare_typ {lid} -> - if se.sigquals |> List.contains Assumption || g.is_iface - then g - else record_val_for g lid - | Sig_let {lids} -> - List.fold_left record_definition_for g lids - | Sig_datacon {lid} -> - record_definition_for g lid - | Sig_inductive_typ {lid} -> - record_definition_for g lid - | Sig_bundle {ses} -> - List.fold_left record_vals_and_defns g ses - | _ -> g - -// This function assumes that, in the case that the environment contains local -// bindings _and_ we push a top-level binding, then the top-level binding does -// not capture any of the local bindings (duh). -let push_sigelt' (force:bool) env s = - let sb = (lids_of_sigelt s, s) in - let env = {env with gamma_sig = sb::env.gamma_sig} in - add_sigelt force env s; - env.tc_hooks.tc_push_in_gamma_hook env (Inr sb); - let env = record_vals_and_defns env s in - env - -let push_sigelt = push_sigelt' false -let push_sigelt_force = push_sigelt' true - -let push_new_effect env (ed, quals) = - let effects = {env.effects with decls=env.effects.decls@[(ed, quals)]} in - {env with effects=effects} - -let exists_polymonadic_bind env m n = - match env.effects.polymonadic_binds - |> BU.find_opt (fun (m1, n1, _, _) -> lid_equals m m1 && lid_equals n n1) with - | Some (_, _, p, t) -> Some (p, t) - | _ -> None - -let exists_polymonadic_subcomp env m n = - match env.effects.polymonadic_subcomps - |> BU.find_opt (fun (m1, n1, _, _) -> lid_equals m m1 && lid_equals n n1) with - | Some (_, _, ts, k) -> Some (ts, k) - | _ -> None - -let print_effects_graph env = - let eff_name lid = lid |> ident_of_lid |> string_of_id in - let path_str path = path |> List.map eff_name |> String.concat ";" in - - // - //Right now the values in the map are just "" - // - //But it may be range or something else if we wanted to dump it in the dot graph - // - let pbinds : smap string = smap_create 10 in - - // - //The keys in the map are sources - // - //Each source is mapped to a map, whose keys are targets, and values are the path strings - // - let lifts : smap (smap string) = smap_create 20 in - - //Similar to pbinds - let psubcomps : smap string = smap_create 10 in - - //Populate the maps - - // - //Note that since order, polymonadic_binds, and polymonadic_subcomps are lists, - // they may have duplicates (and the typechecker picks the first one) - // - - env.effects.order |> List.iter (fun ({msource=src; mtarget=tgt; mpath=path}) -> - let key = eff_name src in - let m = - match smap_try_find lifts key with - | None -> - let m = smap_create 10 in - smap_add lifts key m; - m - | Some m -> m in - match smap_try_find m (eff_name tgt) with - | Some _ -> () - | None -> smap_add m (eff_name tgt) (path_str path)); - - env.effects.polymonadic_binds |> List.iter (fun (m, n, p, _) -> - let key = BU.format3 "%s, %s |> %s" (eff_name m) (eff_name n) (eff_name p) in - smap_add pbinds key ""); - - env.effects.polymonadic_subcomps |> List.iter (fun (m, n, _, _) -> - let key = BU.format2 "%s <: %s" (eff_name m) (eff_name n) in - smap_add psubcomps key ""); - - // - //Dump the dot graph - // - //Interesting bit of trivia: - // the cluster_ in the names of the subgraphs is important, - // if the name does not begin like this, dot rendering does not draw boxes - // around subgraphs (!) - // - - BU.format3 "digraph {\n\ - label=\"Effects ordering\"\n\ - subgraph cluster_lifts {\n\ - label = \"Lifts\"\n - %s\n\ - }\n\ - subgraph cluster_polymonadic_binds {\n\ - label = \"Polymonadic binds\"\n\ - %s\n\ - }\n\ - subgraph cluster_polymonadic_subcomps {\n\ - label = \"Polymonadic subcomps\"\n\ - %s\n\ - }}\n" - - ((smap_fold lifts (fun src m s -> - smap_fold m (fun tgt path s -> - (BU.format3 "%s -> %s [label=\"%s\"]" src tgt path)::s) s) []) |> String.concat "\n") - (smap_fold pbinds (fun k _ s -> (BU.format1 "\"%s\" [shape=\"plaintext\"]" k)::s) [] |> String.concat "\n") - (smap_fold psubcomps (fun k _ s -> (BU.format1 "\"%s\" [shape=\"plaintext\"]" k)::s) [] |> String.concat "\n") - -let update_effect_lattice env src tgt st_mlift = - let compose_edges e1 e2 : edge = - let composed_lift = - let mlift_wp env c = - c |> e1.mlift.mlift_wp env - |> (fun (c, g1) -> c |> e2.mlift.mlift_wp env - |> (fun (c, g2) -> c, TcComm.conj_guard g1 g2)) in - let mlift_term = - match e1.mlift.mlift_term, e2.mlift.mlift_term with - | Some l1, Some l2 -> Some (fun u t e -> l2 u t (l1 u t e)) - | _ -> None - in - { mlift_wp=mlift_wp ; mlift_term=mlift_term} - in - { msource=e1.msource; - mtarget=e2.mtarget; - mlift=composed_lift; - mpath=e1.mpath@[e1.mtarget]@e2.mpath} - in - - let edge = { - msource=src; - mtarget=tgt; - mlift=st_mlift; - mpath=[]; - } in - - let id_edge l = { - msource=src; - mtarget=tgt; - mlift=identity_mlift; - mpath=[]; - } in - - let find_edge order (i, j) = - if lid_equals i j - then id_edge i |> Some - else order |> BU.find_opt (fun e -> lid_equals e.msource i && lid_equals e.mtarget j) in - - let ms = env.effects.decls |> List.map (fun (e, _) -> e.mname) in - - (* - * AR: we compute all the new edges induced by the input edge - * and add them to the head of the edges list - * - * in other words, previous paths are overwritten - *) - - //all nodes i such that i <> src and i ~> src is an edge - let all_i_src = ms |> List.fold_left (fun edges i -> - if lid_equals i edge.msource then edges - else match find_edge env.effects.order (i, edge.msource) with - | Some e -> e::edges - | None -> edges) [] in - - //all nodes j such that j <> tgt and tgt ~> j is an edge - let all_tgt_j = ms |> List.fold_left (fun edges j -> - if lid_equals edge.mtarget j then edges - else match find_edge env.effects.order (edge.mtarget, j) with - | Some e -> e::edges - | None -> edges) [] in - - let check_cycle src tgt = - if lid_equals src tgt - then raise_error env Errors.Fatal_Effects_Ordering_Coherence - (BU.format3 "Adding an edge %s~>%s induces a cycle %s" - (show edge.msource) (show edge.mtarget) (show src)) - in - - // - //There are three types of new edges now: - // - // - From i to edge target - // - From edge source to j - // - From i to j - // - - let new_i_edge_target = List.fold_left (fun edges i_src -> - check_cycle i_src.msource edge.mtarget; - (compose_edges i_src edge)::edges) [] all_i_src in - - let new_edge_source_j = List.fold_left (fun edges tgt_j -> - check_cycle edge.msource tgt_j.mtarget; - (compose_edges edge tgt_j)::edges) [] all_tgt_j in - - let new_i_j = List.fold_left (fun edges i_src -> - List.fold_left (fun edges tgt_j -> - check_cycle i_src.msource tgt_j.mtarget; - (compose_edges (compose_edges i_src edge) tgt_j)::edges) edges all_tgt_j) [] all_i_src in - - let new_edges = edge::(new_i_edge_target@new_edge_source_j@new_i_j) in - - //Add new edges to the front of the list, shadowing existing ones - - let order = new_edges@env.effects.order in - - order |> List.iter (fun edge -> - if Ident.lid_equals edge.msource Const.effect_DIV_lid - && lookup_effect_quals env edge.mtarget |> List.contains TotalEffect - then - raise_error env Errors.Fatal_DivergentComputationCannotBeIncludedInTotal - (BU.format1 "Divergent computations cannot be included in an effect %s marked 'total'" - (show edge.mtarget))); - - // - //Compute upper bounds - // - //Addition of an edge may change upper bounds, - // that's ok, as long as it is unique in the new graph - // - let joins = - // - //A map where we populate all upper bounds for each pair of effects - // - let ubs : smap (list (lident & lident & lident & mlift & mlift)) = - BU.smap_create 10 in - let add_ub i j k ik jk = - let key = string_of_lid i ^ ":" ^ string_of_lid j in - let v = - match smap_try_find ubs key with - | Some ubs -> (i, j, k, ik, jk)::ubs - | None -> [i, j, k, ik, jk] in - - smap_add ubs key v in - - //Populate ubs - ms |> List.iter (fun i -> - ms |> List.iter (fun j -> - if lid_equals i j then () - else ms |> List.iter (fun k -> - match find_edge order (i, k), find_edge order (j, k) with - | Some ik, Some jk -> add_ub i j k ik.mlift jk.mlift - | _ -> ()))); - - // - //Fold over the map - // - //For each pair of effects (i.e. key in the ubs map), - // make sure there is a unique lub - // - smap_fold ubs (fun s l joins -> - //Filter entries that have an edge to every other entry - let lubs = List.filter (fun (i, j, k, ik, jk) -> - List.for_all (fun (_, _, k', _, _) -> - find_edge order (k, k') |> is_some) l) l in - //Make sure there is only one such entry - if List.length lubs <> 1 - then - raise_error env Errors.Fatal_Effects_Ordering_Coherence - (BU.format1 "Effects %s have incomparable upper bounds" s) - else lubs@joins) [] in - - let effects = {env.effects with order=order; joins=joins} in - {env with effects=effects} - -(* - * We allow overriding a previously defined poymonadic bind/subcomps - * between the same effects - * - * Also, polymonadic versions always take precedence over the effects graph - *) - -let add_polymonadic_bind env m n p ty = - { env with - effects = ({ env.effects with polymonadic_binds = (m, n, p, ty)::env.effects.polymonadic_binds }) } - -let add_polymonadic_subcomp env m n (ts, k) = - { env with - effects = ({ env.effects with - polymonadic_subcomps = (m, n, ts, k)::env.effects.polymonadic_subcomps }) } - -let push_local_binding env b = - {env with gamma=b::env.gamma} - -let push_bv env x = push_local_binding env (Binding_var x) - -let push_bvs env bvs = - List.fold_left (fun env bv -> push_bv env bv) env bvs - -let pop_bv env = - match env.gamma with - | Binding_var x::rest -> Some (x, {env with gamma=rest}) - | _ -> None - -let push_binders env (bs:binders) = - List.fold_left (fun env b -> push_bv env b.binder_bv) env bs - -let binding_of_lb (x:lbname) t = match x with - | Inl x -> - assert (fst t = []); - let x = {x with sort=snd t} in - Binding_var x - | Inr fv -> - Binding_lid(fv.fv_name.v, t) - -let push_let_binding env lb ts = - push_local_binding env (binding_of_lb lb ts) - -let push_univ_vars (env:env_t) (xs:univ_names) : env_t = - List.fold_left (fun env x -> push_local_binding env (Binding_univ x)) env xs - -let open_universes_in env uvs terms = - let univ_subst, univ_vars = Subst.univ_var_opening uvs in - let env' = push_univ_vars env univ_vars in - env', univ_vars, List.map (Subst.subst univ_subst) terms - -let set_expected_typ env t = - //false bit says that use subtyping - {env with expected_typ = Some (t, false)} - -let set_expected_typ_maybe_eq env t use_eq = - {env with expected_typ = Some (t, use_eq)} - -let expected_typ env = match env.expected_typ with - | None -> None - | Some t -> Some t - -let clear_expected_typ (env_: env): env & option (typ & bool) = - {env_ with expected_typ=None}, expected_typ env_ - -let finish_module = - let empty_lid = lid_of_ids [id_of_text ""] in - fun env m -> - let sigs = - if lid_equals m.name Const.prims_lid - then env.gamma_sig |> List.map snd |> List.rev - else m.declarations in - {env with - curmodule=empty_lid; - gamma=[]; - gamma_sig=[]; - modules=m::env.modules} - -//////////////////////////////////////////////////////////// -// Collections from the environment // -//////////////////////////////////////////////////////////// -let uvars_in_env env = - let no_uvs = empty () in - let rec aux out g = match g with - | [] -> out - | Binding_univ _ :: tl -> aux out tl - | Binding_lid(_, (_, t))::tl - | Binding_var({sort=t})::tl -> aux (union out (Free.uvars t)) tl - in - aux no_uvs env.gamma - -let univ_vars env = - let no_univs = empty () in - let rec aux out g = match g with - | [] -> out - | Binding_univ _ :: tl -> aux out tl - | Binding_lid(_, (_, t))::tl - | Binding_var({sort=t})::tl -> aux (union out (Free.univs t)) tl - in - aux no_univs env.gamma - -let univnames env = - let no_univ_names = empty () in - let rec aux out g = match g with - | [] -> out - | Binding_univ uname :: tl -> aux (add uname out) tl - | Binding_lid(_, (_, t))::tl - | Binding_var({sort=t})::tl -> aux (union out (Free.univnames t)) tl - in - aux no_univ_names env.gamma - -let lidents env : list lident = - let keys = List.collect fst env.gamma_sig in - BU.smap_fold (sigtab env) (fun _ v keys -> U.lids_of_sigelt v@keys) keys - -let should_enc_path proof_ns path = - let rec str_i_prefix xs ys = - match xs, ys with - | [], _ -> true - | x::xs, y::ys -> String.lowercase x = String.lowercase y && str_i_prefix xs ys - | _, _ -> false - in - match FStar.Compiler.List.tryFind (fun (p, _) -> str_i_prefix p path) proof_ns with - | None -> false - | Some (_, b) -> b - -let should_enc_lid proof_ns lid = - should_enc_path proof_ns (path_of_lid lid) - -let cons_proof_ns b e path = - { e with proof_ns = (path,b) :: e.proof_ns } - -// F# forces me to fully apply this... ugh -let add_proof_ns e path = cons_proof_ns true e path -let rem_proof_ns e path = cons_proof_ns false e path -let get_proof_ns e = e.proof_ns -let set_proof_ns ns e = {e with proof_ns = ns} - -let unbound_vars (e : env) (t : term) : FlatSet.t bv = - // FV(t) \ Vars(Γ) - List.fold_left (fun s bv -> remove bv s) (Free.names t) (bound_vars e) - -let closed (e : env) (t : term) = - is_empty (unbound_vars e t) - -let closed' (t : term) = - is_empty (Free.names t) - -let string_of_proof_ns env = - let aux (p,b) = - if p = [] && b then "*" - else (if b then "+" else "-")^Ident.text_of_path p - in - List.map aux env.proof_ns - |> List.rev - |> String.concat " " - - -(* ------------------------------------------------*) -(* Operations on guard_formula *) -(* ------------------------------------------------*) -let guard_of_guard_formula g = - let open FStar.Class.Listlike in - { - guard_f=g; - deferred=empty; - deferred_to_tac=empty; - univ_ineqs=(empty, empty); - implicits=empty; - } - -let guard_form g = g.guard_f - -let is_trivial g = - let open FStar.Class.Listlike in - (* This is cumbersome due to not having view patterns. *) - // match g with - // | {guard_f=Trivial; deferred=[]; univ_ineqs=([], []); implicits=i} -> - if - Trivial? g.guard_f && - is_empty g.deferred && - is_empty (fst g.univ_ineqs) && - is_empty (snd g.univ_ineqs) - then - g.implicits |> CList.for_all (fun imp -> - (Allow_unresolved? (U.ctx_uvar_should_check imp.imp_uvar)) - || (match Unionfind.find imp.imp_uvar.ctx_uvar_head with - | Some _ -> true - | None -> false)) - else - false - -let is_trivial_guard_formula g = match g with - | {guard_f=Trivial} -> true - | _ -> false - -let trivial_guard = TcComm.trivial_guard - -let abstract_guard_n bs g = - match g.guard_f with - | Trivial -> g - | NonTrivial f -> - let f' = U.abs bs f (Some (U.residual_tot U.ktype0)) in - ({ g with guard_f = NonTrivial f' }) - -let abstract_guard b g = - abstract_guard_n [b] g - -let too_early_in_prims env = - not (lid_exists env Const.effect_GTot_lid) - -let apply_guard g e = match g.guard_f with - | Trivial -> g - | NonTrivial f -> {g with guard_f=NonTrivial <| mk (Tm_app {hd=f; args=[as_arg e]}) f.pos} - -let map_guard g map = match g.guard_f with - | Trivial -> g - | NonTrivial f -> {g with guard_f=NonTrivial (map f)} - -let always_map_guard g map = match g.guard_f with - | Trivial -> {g with guard_f=NonTrivial (map U.t_true)} - | NonTrivial f -> {g with guard_f=NonTrivial (map f)} - -let trivial t = match t with - | Trivial -> () - | NonTrivial _ -> failwith "impossible" - -let check_trivial t = TcComm.check_trivial t - -let conj_guard g1 g2 = TcComm.conj_guard g1 g2 -let conj_guards gs = TcComm.conj_guards gs -let imp_guard g1 g2 = TcComm.imp_guard g1 g2 - - -let close_guard_univs us bs g = - match g.guard_f with - | Trivial -> g - | NonTrivial f -> - let f = - List.fold_right2 (fun u b f -> - if Syntax.is_null_binder b then f - else U.mk_forall u b.binder_bv f) - us bs f in - {g with guard_f=NonTrivial f} - -let close_forall (env:env) (bs:binders) (f:formula) : formula = - Errors.with_ctx "While closing a formula" (fun () -> - def_check_scoped f.pos "close_forall" env (U.arrow bs (S.mk_Total f)); - let bvs = List.map (fun b -> b.binder_bv) bs in - (* We start with env_full and pop bvs one-by-one. This way each - * bv sort is always well scoped in the call to universe_of below. *) - let env_full = push_bvs env bvs in - - let (f', e) = - List.fold_right (fun bv (f, e) -> - let e' = pop_bv e |> must |> snd in - def_check_scoped Range.dummyRange "close_forall.sort" e' bv.sort; - let f' = - if Syntax.is_null_bv bv then f - else let u = e'.universe_of e' bv.sort in - U.mk_forall u bv f - in - (f', e') - ) bvs (f, env_full) - in - f' - ) - -let close_guard env binders g = - match g.guard_f with - | Trivial -> g - | NonTrivial f -> - {g with guard_f=NonTrivial (close_forall env binders f)} - -(* ------------------------------------------------*) -(* *) -(* ------------------------------------------------*) - -(* Generating new implicit variables *) -let new_tac_implicit_var - (reason: string) - (r: Range.range) - (env:env) - (uvar_typ:typ) - (should_check:should_check_uvar) - (uvar_typedness_deps:list ctx_uvar) - (meta:option ctx_uvar_meta_t) - (unrefine:bool) -: term & (ctx_uvar & Range.range) & guard_t -= - let binders = all_binders env in - let gamma = env.gamma in - let decoration = { - uvar_decoration_typ = uvar_typ; - uvar_decoration_typedness_depends_on = uvar_typedness_deps; - uvar_decoration_should_check = should_check; - uvar_decoration_should_unrefine = unrefine; - } in - let ctx_uvar = { - ctx_uvar_head=FStar.Syntax.Unionfind.fresh decoration r; - ctx_uvar_gamma=gamma; - ctx_uvar_binders=binders; - ctx_uvar_reason=reason; - ctx_uvar_range=r; - ctx_uvar_meta=meta; - } in - check_uvar_ctx_invariant reason r true gamma binders; - let t = mk (Tm_uvar (ctx_uvar, ([], NoUseRange))) r in - let imp = { imp_reason = reason - ; imp_tm = t - ; imp_uvar = ctx_uvar - ; imp_range = r - } in - if !dbg_ImplicitTrace then - BU.print1 "Just created uvar for implicit {%s}\n" (show ctx_uvar.ctx_uvar_head); - let g = {trivial_guard with implicits = Listlike.cons imp Listlike.empty} in - t, (ctx_uvar, r), g - -let new_implicit_var_aux reason r env k should_check meta unrefine = - new_tac_implicit_var reason r env k should_check [] meta unrefine - -(***************************************************) - -let uvar_meta_for_binder (b:binder) : option ctx_uvar_meta_t & bool= - let should_unrefine = U.has_attribute b.binder_attrs Const.unrefine_binder_attr in - let meta = - match b.binder_qual with - | Some (Meta tau) -> - (* Meta qualifier (e.g typeclass constraints) *) - Some (Ctx_uvar_meta_tac tau) - | _ -> - (* NB: it does not have to be marked Implicit to get a - Ctx_uvar_meta_attr. In practice most of them are (or - the typechecker will not decide to instantiate) but the - layered effects checking code will sometimes call this - function on regular explicit binders. *) - let is_unification_tag (t:term) : option term = - let hd, args = U.head_and_args t in - let hd = U.un_uinst hd in - match (SS.compress hd).n, args with - | Tm_fvar fv, [(_, Some ({aqual_implicit = true})); (a, None)] - when S.fv_eq_lid fv Const.unification_tag_lid -> - Some a - | _ -> None - in - match b.binder_attrs |> List.tryPick is_unification_tag with - | Some tag -> Some (Ctx_uvar_meta_attr tag) - | None -> None - in - meta, should_unrefine -// -// Perhaps this should not return a guard, -// but only a list of implicits, so that callers don't have to -// be cautious about the logical payload of the guard -// -let uvars_for_binders env (bs:S.binders) substs reason r = - bs |> List.fold_left (fun (substs, uvars, g) b -> - let sort = SS.subst substs b.binder_bv.sort in - - let ctx_uvar_meta, should_unrefine = uvar_meta_for_binder b in - - let t, l_ctx_uvars, g_t = new_implicit_var_aux - (reason b) r env sort - (if Options.compat_pre_typed_indexed_effects () - then Allow_untyped "indexed effect uvar in compat mode" - else Strict) - ctx_uvar_meta - should_unrefine - in - - if !dbg_LayeredEffectsEqns then - BU.print1 "Layered Effect uvar: %s\n" (show l_ctx_uvars); - - substs@[NT (b.binder_bv, t)], - uvars@[t], - conj_guards [g; g_t] - ) (substs, [], trivial_guard) |> (fun (_, uvars, g) -> uvars, g) - -let pure_precondition_for_trivial_post env u t wp r = - let trivial_post = - let post_ts = lookup_definition [NoDelta] env Const.trivial_pure_post_lid |> must in - let _, post = inst_tscheme_with post_ts [u] in - S.mk_Tm_app - post - [t |> S.as_arg] - r in - S.mk_Tm_app - wp - [trivial_post |> S.as_arg] - r - -let get_letrec_arity (env:env) (lbname:lbname) : option int = - let compare_either f1 f2 e1 e2 : bool = - match e1, e2 with - | Inl v1, Inl v2 -> f1 v1 v2 - | Inr v1, Inr v2 -> f2 v1 v2 - | _ -> false - in - match BU.find_opt (fun (lbname', _, _, _) -> compare_either S.bv_eq S.fv_eq lbname lbname') - env.letrecs with - | Some (_, arity, _, _) -> Some arity - | None -> None - -let fvar_of_nonqual_lid env lid = - let qn = lookup_qname env lid in - fvar lid None - -let split_smt_query (e:env) (q:term) - : option (list (env & term)) - = match e.solver.spinoff_strictly_positive_goals with - | None -> None - | Some p -> Some (p e q) diff --git a/src/typechecker/FStar.TypeChecker.Env.fsti b/src/typechecker/FStar.TypeChecker.Env.fsti deleted file mode 100644 index c3d130e6933..00000000000 --- a/src/typechecker/FStar.TypeChecker.Env.fsti +++ /dev/null @@ -1,574 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.TypeChecker.Env -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar -open FStar.Compiler -open FStar.Syntax.Syntax -open FStar.Ident -open FStar.TypeChecker.Common -open FStar.Class.Binders -open FStar.Class.Deq -open FStar.Class.Show -open FStar.Class.Setlike - -module BU = FStar.Compiler.Util -module S = FStar.Syntax.Syntax -module TcComm = FStar.TypeChecker.Common - -type step = - | Beta - | Iota //pattern matching - | Zeta //fixed points - | ZetaFull //fixed points, even under blocked matches - | Exclude of step //the first three kinds are included by default, unless Excluded explicity - | Weak //Do not descend into binders - | HNF //Only produce a head normal form: Do not descend into function arguments or into binder types - | Primops //reduce primitive operators like +, -, *, /, etc. - | Eager_unfolding - | Inlining - | DoNotUnfoldPureLets - | UnfoldUntil of delta_depth - | UnfoldOnly of list FStar.Ident.lid - | UnfoldFully of list FStar.Ident.lid - | UnfoldAttr of list FStar.Ident.lid - | UnfoldQual of list string - | UnfoldNamespace of list string - | DontUnfoldAttr of list lid - | PureSubtermsWithinComputations - | Simplify //Simplifies some basic logical tautologies: not part of definitional equality! - | EraseUniverses - | AllowUnboundUniverses //we erase universes as we encode to SMT; so, sometimes when printing, it's ok to have some unbound universe variables - | Reify - | CompressUvars - | NoFullNorm - | CheckNoUvars - | Unmeta //remove all non-monadic metas. - | Unascribe - | NBE - | ForExtraction //marking an invocation of the normalizer for extraction - | Unrefine - | NormDebug //force debugging - | DefaultUnivsToZero // default al unresolved universe uvars to zero - | Tactics -and steps = list step - -instance val deq_step : deq step -instance val showable_step : showable step - -type sig_binding = list lident & sigelt - -type delta_level = - | NoDelta - | InliningDelta // ZP : Trying to resolve name clash - | Eager_unfolding_only - | Unfold of delta_depth - -instance val deq_delta_level : deq delta_level -instance val showable_delta_level : showable delta_level - -// A name prefix, such as ["FStar";"Math"] -type name_prefix = FStar.Ident.path -// A choice of which name prefixes are enabled/disabled -// The leftmost match takes precedence. Empty list means everything is off. -// To turn off everything, one can prepend `([], false)` to this (since [] is a prefix of everything) -type proof_namespace = list (name_prefix & bool) - -type cached_elt = (either (universes & typ) (sigelt & option universes)) & Range.range -type goal = term - -type must_tot = bool - -(* - * AR: The mlift record that maintains functions to lift 'source' computation types - * and terms to 'target' computation types and terms (terms in the case of reifiable effects) - * - * The signature to lift computation types is quite nice: comp to comp - * For the terms, we don't require the indices (wps etc.) anymore since - * they are computationally irrelevant, in the previous code where we needed them - * all the clients were passing Tm_unknown, so what's the point - * Read the signature as: u_a:universe -> a:typ -> e:term -> term - * - * Note that these types compose quite nicely along the effect lattice - *) - -type lift_comp_t = env -> comp -> comp & guard_t - -(* - * AR: Env maintains polymonadic binds as functions of type polymonadic_bind_t - * read as: env -> c1 -> x -> c2 -> flags -> r -> (c * g) - *) -and polymonadic_bind_t = - env -> - comp_typ -> - option bv -> - comp_typ -> - list cflag -> - Range.range -> - comp & guard_t - -and mlift = { - mlift_wp:lift_comp_t; - mlift_term:option (universe -> typ -> term -> term) -} - -(* - * Edge in the effect lattice - * - * May have been computed by composing other "edges" - *) -and edge = { - msource : lident; - mtarget : lident; - mlift : mlift; - mpath : list lident; //this is just for debugging pusposes - //e.g. it is used when printing the effects graph - //it has no other role - //the path is the list of nodes that the "edge" goes through - //not including msource and mtarget -} - -(* - * The effects graph - * - * Each of order, joins, polymonadic binds, subcomps, are lists, - * that may have multiple entries for same nodes, - * e.g. multiple edges between effects M and N - * - * We keep adding the latest ones to the head of the list, - * which is then picked for application - * - * I.e. we don't remove when overriding - *) - -and effects = { - decls :list (eff_decl & list qualifier); - order :list edge; (* transitive closure of the order in the signature *) - joins :list (lident & lident & lident & mlift & mlift); (* least upper bounds *) - polymonadic_binds :list (lident & lident & lident & polymonadic_bind_t); (* (m, n) | p *) - polymonadic_subcomps :list (lident & lident & tscheme & S.indexed_effect_combinator_kind); (* m <: n *) -} - -and env = { - solver :solver_t; (* interface to the SMT solver *) - range :Range.range; (* the source location of the term being checked *) - curmodule :lident; (* Name of this module *) - gamma :list binding; (* Local typing environment *) - gamma_sig :list sig_binding; (* and signature elements *) - gamma_cache :FStar.Compiler.Util.smap cached_elt; (* Memo table for the global gamma_sig environment *) - modules :list modul; (* already fully type checked modules *) - expected_typ :option (typ & bool); (* type expected by the context *) - (* a true bool will check for type equality (else subtyping) *) - sigtab :BU.smap sigelt; (* a dictionary of long-names to sigelts *) - attrtab :BU.smap (list sigelt); (* a dictionary of attribute( name)s to sigelts, mostly in support of typeclasses *) - instantiate_imp:bool; (* instantiate implicit arguments? default=true *) - effects :effects; (* monad lattice *) - generalize :bool; (* should we generalize let bindings? *) - letrecs :list (lbname & int & typ & univ_names); (* mutually recursive names, with recursion arity and their types (for termination checking), adding universes, see the note in TcTerm.fs:build_let_rec_env about usage of this field *) - top_level :bool; (* is this a top-level term? if so, then discharge guards *) - check_uvars :bool; (* paranoid: re-typecheck unification variables *) - use_eq_strict :bool; (* this flag runs the typechecker in non-subtyping mode *) - (* i.e. using type equality instead of subtyping *) - is_iface :bool; (* is the module we're currently checking an interface? *) - admit :bool; (* admit VCs in the current module *) - lax_universes :bool; (* don't check universe constraints *) - phase1 :bool; (* running in phase 1, phase 2 to come after *) - failhard :bool; (* don't try to carry on after a typechecking error *) - flychecking :bool; (* currently flychecking in IDE, used to for example not run synth tactics *) - uvar_subtyping :bool; - intactics :bool; (* we are currently running a tactic *) - nocoerce :bool; (* do not apply any coercions *) - - tc_term :env -> term -> term & lcomp & guard_t; (* typechecker callback; G |- e : C <== g *) - typeof_tot_or_gtot_term :env -> term -> must_tot -> term & typ & guard_t; (* typechecker callback; G |- e : (G)Tot t <== g *) - universe_of :env -> term -> universe; (* typechecker callback; G |- e : Tot (Type u) *) - typeof_well_typed_tot_or_gtot_term :env -> term -> must_tot -> typ & guard_t; (* typechecker callback, uses fast path, with a fallback on the slow path *) - teq_nosmt_force: env -> term -> term -> bool; (* callback to the unifier *) - subtype_nosmt_force: env -> term -> term -> bool; (* callback to the unifier *) - qtbl_name_and_index: option (lident & typ & int) & BU.smap int; - (* ^ the top-level term we're currently processing, its type, and the query counter for it, - in addition we maintain a counter for query index per lid *) - normalized_eff_names:BU.smap lident; (* cache for normalized effect name, used to be captured in the function norm_eff_name, which made it harder to roll back etc. *) - fv_delta_depths:BU.smap delta_depth; (* cache for fv delta depths, its preferable to use Env.delta_depth_of_fv, soon fv.delta_depth should be removed *) - proof_ns :proof_namespace; (* the current names that will be encoded to SMT (a.k.a. hint db) *) - synth_hook :env -> typ -> term -> term; (* hook for synthesizing terms via tactics, third arg is tactic term *) - try_solve_implicits_hook :env -> term -> implicits -> unit; (* *) - splice : env -> is_typed:bool -> list lident -> term -> Range.range -> list sigelt; (* hook for synthesizing top-level sigelts via tactics *) - (* second arg is true for typed splice *) - (* third arg is tactic term *) - mpreprocess :env -> term -> term -> term; (* hook for preprocessing typechecked terms via metaprograms *) - postprocess :env -> term -> typ -> term -> term; (* hook for postprocessing typechecked terms via metaprograms *) - identifier_info: ref FStar.TypeChecker.Common.id_info_table; (* information on identifiers *) - tc_hooks : tcenv_hooks; (* hooks that the interactive more relies onto for symbol tracking *) - dsenv : FStar.Syntax.DsEnv.env; (* The desugaring environment from the front-end *) - nbe : list step -> env -> term -> term; (* Callback to the NBE function *) - strict_args_tab:BU.smap (option (list int)); (* a dictionary of fv names to strict arguments *) - erasable_types_tab:BU.smap bool; (* a dictionary of type names to erasable types *) - enable_defer_to_tac: bool; (* Set by default; unset when running within a tactic itself, since we do not allow - a tactic to defer problems to another tactic via the attribute mechanism *) - unif_allow_ref_guards:bool; (* Allow guards when unifying refinements, even when SMT is disabled *) - erase_erasable_args: bool; (* This flag is set when running normalize_for_extraction, see Extraction.ML.Modul *) - - core_check: core_check_t; - - (* A set of names for which we are missing a declaration. - Every val (Sig_declare_typ) is added here and removed - only when a definition for it is checked. At the of checking a module, - if anything remains here, we fail. *) - missing_decl : RBSet.t lident; -} - -and solver_depth_t = int & int & int -and solver_t = { - init :env -> unit; - // push :string -> unit; - // pop :string -> unit; - snapshot :string -> (solver_depth_t & unit); - rollback :string -> option solver_depth_t -> unit; - encode_sig :env -> sigelt -> unit; - preprocess :env -> goal -> bool & list (env & goal & FStar.Options.optionstate); - spinoff_strictly_positive_goals: option (env -> goal -> list (env & goal)); - handle_smt_goal :env -> goal -> list (env & goal); - solve :option (unit -> string) -> env -> goal -> unit; //call to the smt solver - solve_sync :option (unit -> string) -> env -> goal -> bool; //call to the smt solver - finish :unit -> unit; - refresh :option proof_namespace -> unit; -} -and tcenv_hooks = - { tc_push_in_gamma_hook : (env -> either binding sig_binding -> unit) } - -and core_check_t = - env -> term -> typ -> bool -> either (option typ) (bool -> string) - -(* Keeping track of declarations and definitions. This operates -over the missing_decl field. *) -val record_val_for (e:env) (l:lident) : env -val record_definition_for (e:env) (l:lident) : env -val missing_definition_list (e:env) : list lident - -type implicit = TcComm.implicit -type implicits = TcComm.implicits -type guard_t = TcComm.guard_t -type tcenv_depth_t = int & int & solver_depth_t & int -type qninfo = option ((either (universes & typ) (sigelt & option universes)) & Range.range) - -val tc_hooks : env -> tcenv_hooks -val set_tc_hooks: env -> tcenv_hooks -> env -val preprocess : env -> term -> term -> term -val postprocess : env -> term -> typ -> term -> term - -type env_t = env - -val initial_env : FStar.Parser.Dep.deps -> - (env -> term -> term & lcomp & guard_t) -> - (env -> term -> must_tot -> term & typ & guard_t) -> - (env -> term -> must_tot -> option typ) -> - (env -> term -> universe) -> - (env -> term -> term -> bool) -> - (env -> term -> term -> bool) -> - solver_t -> lident -> - (list step -> env -> term -> term) -> - core_check_t -> env - -(* Some utilities *) -val should_verify : env -> bool -val incr_query_index: env -> env -val rename_gamma : subst_t -> gamma -> gamma -val rename_env : subst_t -> env -> env -val set_dep_graph: env -> FStar.Parser.Dep.deps -> env -val dep_graph: env -> FStar.Parser.Dep.deps - -val dsenv : env -> FStar.Syntax.DsEnv.env - -(* Marking and resetting the environment *) -val push : env -> string -> env -val pop : env -> string -> env - -val snapshot : env -> string -> (tcenv_depth_t & env) -val rollback : solver_t -> string -> option tcenv_depth_t -> env - -(* Checking the per-module debug level and position info *) -val current_module : env -> lident -val set_range : env -> Range.range -> env -val get_range : env -> Range.range - -instance val hasRange_env : hasRange env - -val insert_bv_info : env -> bv -> typ -> unit -val insert_fv_info : env -> fv -> typ -> unit -val toggle_id_info : env -> bool -> unit -val promote_id_info : env -> (typ -> option typ) -> unit - -(* Querying identifiers *) -val lid_exists : env -> lident -> bool -val try_lookup_bv : env -> bv -> option (typ & Range.range) -val lookup_bv : env -> bv -> typ & Range.range -val lookup_qname : env -> lident -> qninfo -val lookup_sigelt : env -> lident -> option sigelt -val try_lookup_lid : env -> lident -> option ((universes & typ) & Range.range) -val try_lookup_and_inst_lid: env -> universes -> lident -> option (typ & Range.range) -val lookup_lid : env -> lident -> (universes & typ) & Range.range -val lookup_univ : env -> univ_name -> bool -val try_lookup_val_decl : env -> lident -> option (tscheme & list qualifier) -val lookup_val_decl : env -> lident -> (universes & typ) -val lookup_datacon : env -> lident -> universes & typ -val lookup_and_inst_datacon: env -> universes -> lident -> typ -(* the boolean tells if the lident was actually a inductive *) -val datacons_of_typ : env -> lident -> (bool & list lident) -val typ_of_datacon : env -> lident -> lident -val visible_with : list delta_level -> list qualifier -> bool -val lookup_definition_qninfo : list delta_level -> lident -> qninfo -> option (univ_names & term) -val lookup_definition : list delta_level -> env -> lident -> option (univ_names & term) -val lookup_nonrec_definition: list delta_level -> env -> lident -> option (univ_names & term) -val quals_of_qninfo : qninfo -> option (list qualifier) -val attrs_of_qninfo : qninfo -> option (list attribute) -val lookup_attrs_of_lid : env -> lid -> option (list attribute) -val fv_with_lid_has_attr : env -> fv_lid:lid -> attr_lid:lid -> bool -val fv_has_attr : env -> fv -> attr_lid:lid -> bool -val fv_has_strict_args : env -> fv -> option (list int) -val fv_has_erasable_attr : env -> fv -> bool -val non_informative : env -> typ -> bool -val try_lookup_effect_lid : env -> lident -> option term -val lookup_effect_lid : env -> lident -> term -val lookup_effect_abbrev : env -> universes -> lident -> option (binders & comp) -val norm_eff_name : (env -> lident -> lident) -val num_effect_indices : env -> lident -> Range.range -> int -val lookup_effect_quals : env -> lident -> list qualifier -val lookup_projector : env -> lident -> int -> lident -val lookup_attr : env -> string -> list sigelt -val is_projector : env -> lident -> bool -val is_datacon : env -> lident -> bool -val is_record : env -> lident -> bool -val qninfo_is_action : qninfo -> bool -val is_action : env -> lident -> bool -val is_interpreted : (env -> term -> bool) -val is_irreducible : env -> lident -> bool -val is_type_constructor : env -> lident -> bool -val num_inductive_ty_params: env -> lident -> option int -val num_inductive_uniform_ty_params: env -> lident -> option int -val num_datacon_non_injective_ty_params : env -> lident -> option int -val delta_depth_of_qninfo : env -> fv -> qninfo -> delta_depth -val delta_depth_of_fv : env -> fv -> delta_depth - -(* Universe instantiation *) - -(* Construct a new universe unification variable *) -val new_u_univ : unit -> universe -val inst_tscheme_with : tscheme -> universes -> universes & term -(* Instantiate the universe variables in a type scheme with new unification variables *) -val inst_tscheme : tscheme -> universes & term -val inst_effect_fun_with : universes -> env -> eff_decl -> tscheme -> term -val mk_univ_subst : list univ_name -> universes -> list subst_elt - -(* Introducing identifiers and updating the environment *) - -(* - * push_sigelt only adds the sigelt to various caches maintained by env - * For semantic changes, such as adding an effect or adding an edge to the effect lattice, - * Tc calls separate functions - *) -val push_sigelt : env -> sigelt -> env -val push_sigelt_force : env -> sigelt -> env (* does not check for repeats *) -val push_new_effect : env -> (eff_decl & list qualifier) -> env - -//client constructs the mlift and gives it to us - -val exists_polymonadic_bind: env -> lident -> lident -> option (lident & polymonadic_bind_t) -val exists_polymonadic_subcomp: env -> lident -> lident -> option (tscheme & S.indexed_effect_combinator_kind) - -//print the effects graph in dot format -val print_effects_graph: env -> string - -val update_effect_lattice : env -> src:lident -> tgt:lident -> mlift -> env - -val join_opt : env -> lident -> lident -> option (lident & mlift & mlift) -val add_polymonadic_bind : env -> m:lident -> n:lident -> p:lident -> polymonadic_bind_t -> env -val add_polymonadic_subcomp: env -> m:lident -> n:lident -> (tscheme & S.indexed_effect_combinator_kind) -> env - -val push_bv : env -> bv -> env -val push_bvs : env -> list bv -> env -val pop_bv : env -> option (bv & env) -val push_let_binding : env -> lbname -> tscheme -> env -val push_binders : env -> binders -> env -val push_univ_vars : env -> univ_names -> env -val open_universes_in : env -> univ_names -> list term -> env & univ_names & list term -val set_expected_typ : env -> typ -> env -val set_expected_typ_maybe_eq - : env -> typ -> bool -> env //boolean true will check for type equality - -//the returns boolean true means check for type equality -val expected_typ : env -> option (typ & bool) -val clear_expected_typ : env -> env&option (typ & bool) - -val set_current_module : env -> lident -> env -val finish_module : (env -> modul -> env) - -(* Collective state of the environment *) -val bound_vars : env -> list bv -val all_binders : env -> binders -val modules : env -> list modul -val uvars_in_env : env -> uvars -val univ_vars : env -> FlatSet.t universe_uvar -val univnames : env -> FlatSet.t univ_name -val lidents : env -> list lident - -(* operations on monads *) -val identity_mlift : mlift -val join : env -> lident -> lident -> lident & mlift & mlift -val monad_leq : env -> lident -> lident -> option edge -val effect_decl_opt : env -> lident -> option (eff_decl & list qualifier) -val get_effect_decl : env -> lident -> eff_decl -val get_default_effect : env -> lident -> option lident -val get_top_level_effect : env -> lident -> option lident -val is_layered_effect : env -> lident -> bool -val wp_signature : env -> lident -> (bv & term) -val comp_to_comp_typ : env -> comp -> comp_typ -val comp_set_flags : env -> comp -> list S.cflag -> comp -val unfold_effect_abbrev : env -> comp -> comp_typ -val effect_repr : env -> comp -> universe -> option term -val reify_comp : env -> comp -> universe -> term - -val is_erasable_effect : env -> lident -> bool - -(* [is_reifiable_* env x] returns true if the effect name/computational effect (of *) -(* a body or codomain of an arrow) [x] is reifiable *) -val is_reifiable_effect : env -> lident -> bool -val is_reifiable_rc : env -> residual_comp -> bool -val is_reifiable_comp : env -> comp -> bool -val is_reifiable_function : env -> term -> bool - -(* [is_user_reifiable_* env x] is more restrictive, and only allows *) -(* reifying effects marked with the `reifiable` keyword. (For instance, TAC *) -(* is reifiable but not user-reifiable.) *) -val is_user_reifiable_effect : env -> lident -> bool -val is_user_reflectable_effect : env -> lident -> bool - -(* Is this effect marked `total`? *) -val is_total_effect : env -> lident -> bool - -(* A coercion *) -val binders_of_bindings : list binding -> binders - -(* Toggling of encoding of namespaces *) -val should_enc_lid : proof_namespace -> lident -> bool -val add_proof_ns : env -> name_prefix -> env -val rem_proof_ns : env -> name_prefix -> env -val get_proof_ns : env -> proof_namespace -val set_proof_ns : proof_namespace -> env -> env -val string_of_proof_ns : env -> string - -(* Check that all free variables of the term are defined in the environment *) -val unbound_vars : env -> term -> FlatSet.t bv -val closed : env -> term -> bool -val closed' : term -> bool - -(* Operations on guard_t *) -val close_guard_univs : universes -> binders -> guard_t -> guard_t -val close_guard : env -> binders -> guard_t -> guard_t //this closes the guard formula with bs -val apply_guard : guard_t -> term -> guard_t -val map_guard : guard_t -> (term -> term) -> guard_t -val always_map_guard : guard_t -> (term -> term) -> guard_t -val trivial_guard : guard_t -val is_trivial : guard_t -> bool -val is_trivial_guard_formula : guard_t -> bool -val conj_guard : guard_t -> guard_t -> guard_t -val conj_guards : list guard_t -> guard_t -val abstract_guard : binder -> guard_t -> guard_t -val abstract_guard_n : list binder -> guard_t -> guard_t -val imp_guard : guard_t -> guard_t -> guard_t -val guard_of_guard_formula : guard_formula -> guard_t -val guard_form : guard_t -> guard_formula -val check_trivial : term -> guard_formula - -(* Other utils *) -val too_early_in_prims : env -> bool - -val close_forall : env -> binders -> term -> term - -val new_tac_implicit_var - (reason: string) - (r: Range.range) - (env:env) - (uvar_typ:typ) - (should_check:should_check_uvar) - (uvar_typedness_deps:list ctx_uvar) - (meta:option ctx_uvar_meta_t) - (unrefine:bool) -: term & (ctx_uvar & Range.range) & guard_t - -val new_implicit_var_aux - (reason: string) - (r: Range.range) - (env:env) - (uvar_typ:typ) - (should_check:should_check_uvar) - (meta:option ctx_uvar_meta_t) - (unrefine:bool) -: term & (ctx_uvar & Range.range) & guard_t - - -val uvar_meta_for_binder (b:binder) : option ctx_uvar_meta_t & (*should_unrefine:*)bool - -(* layered effect utils *) - -(* - * This gadget is used when the typechecker applies the layered effect combinators - * - * Given (opened) bs = x_i:t_i, this function creates uvars ?u_i:t_i - * - * When creating a ?u_i, it performs the substitution substs@[x_j/?u_j] in t_i, forall j < i - * so that the t_i is well-typed in env - * - * It returns the list of the uvars, and combined guard (which essentially contains the uvars as implicits) - *) - -val uvars_for_binders : - env -> - bs:S.binders -> - substs:S.subst_t -> - reason:(S.binder -> string) -> - r:Range.range -> - (list S.term & guard_t) - -val pure_precondition_for_trivial_post : env -> universe -> typ -> typ -> Range.range -> typ - -(* Fetch the arity from the letrecs field. None if not there (happens -for either not a recursive let, or one that does not need the totality -check. *) -val get_letrec_arity : env -> lbname -> option int - -(* Construct a Tm_fvar with the delta_depth metadata populated - -- Note, the delta_qual is not populated, so don't use this with - Data constructors, projectors, record identifiers etc. - - -- Also, don't use this with lidents that refer to Prims, that - still requires special handling -*) -val fvar_of_nonqual_lid : env -> lident -> term - -val split_smt_query : env -> term -> option (list (env & term)) - -(* Binding instances, mostly for defensive checks *) - -instance val hasBinders_env : hasBinders env -instance val hasNames_lcomp : hasNames lcomp -instance val pretty_lcomp : FStar.Class.PP.pretty lcomp -instance val hasNames_guard : hasNames guard_t -instance val pretty_guard : FStar.Class.PP.pretty guard_t - -val fv_delta_depth : env -> fv -> delta_depth -val delta_depth_of_term : env -> term -> delta_depth diff --git a/src/typechecker/FStar.TypeChecker.Err.fst b/src/typechecker/FStar.TypeChecker.Err.fst deleted file mode 100644 index e5682d9413a..00000000000 --- a/src/typechecker/FStar.TypeChecker.Err.fst +++ /dev/null @@ -1,349 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.TypeChecker.Err -open FStar.Pervasives -open FStar.Compiler.Effect - -open FStar -open FStar.Compiler -open FStar.Compiler.List -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.Compiler.Util -open FStar.TypeChecker.Normalize -open FStar.TypeChecker.Env -open FStar.Compiler.Range -open FStar.Ident -open FStar.Pprint -module N = FStar.TypeChecker.Normalize -module BU = FStar.Compiler.Util //basic util -module Env = FStar.TypeChecker.Env -open FStar.TypeChecker.Common - -open FStar.Errors.Msg -open FStar.Class.PP -open FStar.Class.Show - -let info_at_pos env file row col : option (either string lident & typ & Range.range) = - match TypeChecker.Common.id_info_at_pos !env.identifier_info file row col with - | None -> None - | Some info -> - match info.identifier with - | Inl bv -> Some (Inl (show bv.ppname), info.identifier_ty, - FStar.Syntax.Syntax.range_of_bv bv) - | Inr fv -> Some (Inr (FStar.Syntax.Syntax.lid_of_fv fv), info.identifier_ty, - FStar.Syntax.Syntax.range_of_fv fv) - -(* Will attempt to enable certain printing flags to make x and y - * visibly different. It will try to enable the least possible - * subset of implicits, universes, effect_args and full_names. - * It will also prioritize them in that order, prefering to show - * a discrepancy of implicits before one of universes, etc. - *) -let print_discrepancy (#a:Type) (#b:eqtype) (f : a -> b) (x : a) (y : a) : b & b = - let print () : b & b & bool = - let xs = f x in - let ys = f y in - xs, ys, xs <> ys - in - let rec blist_leq (l1 : list bool) (l2 : list bool) = - match l1, l2 with - | h1::t1, h2::t2 -> - (not h1 || h2) && blist_leq t1 t2 - | [], [] -> - true - | _ -> - failwith "print_discrepancy: bad lists" - in - let rec succ (l : list bool) : list bool = - match l with - | false::t -> true::t - | true::t -> false::(succ t) - | [] -> failwith "" - in - let full (l : list bool) : bool = - List.for_all (fun b -> b) l - in - let get_bool_option (s:string) : bool = - match Options.get_option s with - | Options.Bool b -> b - | _ -> failwith "print_discrepancy: impossible" - in - let set_bool_option (s:string) (b:bool) : unit = - Options.set_option s (Options.Bool b) - in - let get () : list bool = - let pi = get_bool_option "print_implicits" in - let pu = get_bool_option "print_universes" in - let pea = get_bool_option "print_effect_args" in - let pf = get_bool_option "print_full_names" in - [pi; pu; pea; pf] - in - let set (l : list bool) : unit = - match l with - | [pi; pu; pea; pf] -> - set_bool_option "print_implicits" pi; - set_bool_option "print_universes" pu; - set_bool_option "print_effect_args" pea; - set_bool_option "print_full_names " pf - | _ -> failwith "impossible: print_discrepancy" - in - let bas = get () in - let rec go (cur : list bool) = - match () with - (* give up, nothing more we can do *) - | () when full cur -> - let xs, ys, _ = print () in - xs, ys - - (* skip this configuration, we do not want to disable any flag - * given by the user *) - | () when not (blist_leq bas cur) -> - go (succ cur) - - | () -> - set cur; - match print () with - (* got a discrepancy! we're done *) - | xs, ys, true -> - xs, ys - - (* keep trying *) - | _ -> - go (succ cur) - in - Options.with_saved_options (fun () -> go bas) - -let errors_smt_detail env - (errs : list Errors.error) - (smt_detail : Errors.error_message) -: list Errors.error -= - let errs = - errs - |> List.map - (fun (e, msg, r, ctx) -> - let e, msg, r, ctx = - let msg = msg @ smt_detail in - if r = dummyRange - then e, msg, Env.get_range env, ctx - else let r' = Range.set_def_range r (Range.use_range r) in - if Range.file_of_range r' <> Range.file_of_range (Env.get_range env) //r points to another file - then - let msg = - let open FStar.Pprint in - msg @ [doc_of_string ("Also see: " ^ Range.string_of_use_range r) - ; (if Range.use_range r <> Range.def_range r - then doc_of_string ("Other related locations: " ^ Range.string_of_def_range r) - else empty)] - in - e, msg, Env.get_range env, ctx - else e, msg, r, ctx - in - e, msg, r, ctx) - in - errs - -let add_errors env errs = - FStar.Errors.add_errors (errors_smt_detail env errs []) - -let log_issue env r (e, m) : unit = - add_errors env [e, m, r, Errors.get_ctx ()] - -let log_issue_text env r (e, m) : unit = - log_issue env r (e, [Errors.text m]) - -let err_msg_type_strings env t1 t2 :(string & string) = - print_discrepancy (N.term_to_string env) t1 t2 - -// let err_msg_type_docs env t1 t2 :(Pprint.document * Pprint.document) = - -// print_discrepancy (N.term_to_doc env) t1 t2 - -let err_msg_comp_strings env c1 c2 :(string & string) = - print_discrepancy (N.comp_to_string env) c1 c2 - -(* Error messages for labels in VCs *) -let exhaustiveness_check = [ - FStar.Errors.Msg.text "Patterns are incomplete" -] - -let subtyping_failed : env -> typ -> typ -> unit -> error_message = - fun env t1 t2 () -> - // let s1, s2 = err_msg_type_strings env t1 t2 in - let ppt = N.term_to_doc env in - [text "Subtyping check failed"; - prefix 2 1 (text "Expected type") (ppt t2) ^/^ - prefix 2 1 (text "got type") (ppt t1); - ] - -let ill_kinded_type = Errors.mkmsg "Ill-kinded type" - -let unexpected_signature_for_monad #a env (rng:Range.range) (m:lident) k : a = - Errors.raise_error rng Errors.Fatal_UnexpectedSignatureForMonad - (format2 "Unexpected signature for monad \"%s\". Expected a signature of the form (a:Type -> WP a -> Effect); got %s" - (show m) (N.term_to_string env k)) - -let expected_a_term_of_type_t_got_a_function env (rng:Range.range) msg (t:typ) (e:term) = - Errors.raise_error rng Errors.Fatal_ExpectTermGotFunction - (format3 "Expected a term of type \"%s\"; got a function \"%s\" (%s)" - (N.term_to_string env t) (show e) msg) - -let unexpected_implicit_argument = - (Errors.Fatal_UnexpectedImplicitArgument, ("Unexpected instantiation of an implicit argument to a function that only expects explicit arguments")) - -let expected_expression_of_type #a env (rng:Range.range) t1 e t2 : a = - // let s1, s2 = err_msg_type_strings env t1 t2 in - // MISSING: print discrepancy! - let d1 = N.term_to_doc env t1 in - let d2 = N.term_to_doc env t2 in - let ed = N.term_to_doc env e in - let open FStar.Errors.Msg in - Errors.raise_error rng Errors.Fatal_UnexpectedExpressionType [ - prefix 4 1 (text "Expected expression of type") d1 ^/^ - prefix 4 1 (text "got expression") ed ^/^ - prefix 4 1 (text "of type") d2 - ] - -let expected_pattern_of_type env (t1 e t2 : term) = - let s1, s2 = err_msg_type_strings env t1 t2 in - (Errors.Fatal_UnexpectedPattern, (format3 "Expected pattern of type \"%s\"; got pattern \"%s\" of type \"%s\"" - s1 (show e) s2)) - -let basic_type_error env (rng:Range.range) eopt t1 t2 = - let s1, s2 = err_msg_type_strings env t1 t2 in - let open FStar.Errors.Msg in - let msg = match eopt with - | None -> [ - prefix 4 1 (text "Expected type") (N.term_to_doc env t1) ^/^ - prefix 4 1 (text "got type") (N.term_to_doc env t2); - ] - | Some e -> [ - prefix 4 1 (text "Expected type") (N.term_to_doc env t1) ^/^ - prefix 4 1 (text "but") (N.term_to_doc env e) ^/^ - prefix 4 1 (text "has type") (N.term_to_doc env t2); - ] - in - Errors.log_issue rng Errors.Error_TypeError msg - -(* It does not make sense to use the same code for a catcheable and uncatcheable -error, but that's what this was doing. *) -let raise_basic_type_error #a env (rng:Range.range) eopt t1 t2 : a = - let s1, s2 = err_msg_type_strings env t1 t2 in - let open FStar.Errors.Msg in - let msg = match eopt with - | None -> [ - prefix 4 1 (text "Expected type") (N.term_to_doc env t1) ^/^ - prefix 4 1 (text "got type") (N.term_to_doc env t2); - ] - | Some e -> [ - prefix 4 1 (text "Expected type") (N.term_to_doc env t1) ^/^ - prefix 4 1 (text "but") (N.term_to_doc env e) ^/^ - prefix 4 1 (text "has type") (N.term_to_doc env t2); - ] - in - Errors.raise_error rng Errors.Error_TypeError msg - -let occurs_check = - (Errors.Fatal_PossibleInfiniteTyp, "Possibly infinite typ (occurs check failed)") - -let constructor_fails_the_positivity_check env (d:term) (l:lid) = - (Errors.Fatal_ConstructorFailedCheck, (format2 "Constructor \"%s\" fails the strict positivity check; the constructed type \"%s\" occurs to the left of a pure function type" - (show d) (show l))) - -let inline_type_annotation_and_val_decl (l:lid) = - (Errors.Fatal_DuplicateTypeAnnotationAndValDecl, (format1 "\"%s\" has a val declaration as well as an inlined type annotation; remove one" (show l))) - -(* CH: unsure if the env is good enough for normalizing t here *) -let inferred_type_causes_variable_to_escape env t (x:bv) = - (Errors.Fatal_InferredTypeCauseVarEscape, (format2 "Inferred type \"%s\" causes variable \"%s\" to escape its scope" - (N.term_to_string env t) (show x))) - -let expected_function_typ #a env (rng:Range.range) t : a = - Errors.raise_error rng Errors.Fatal_FunctionTypeExpected [ - text "Expected a function."; - prefix 2 1 (text "Got an expression of type:") - (N.term_to_doc env t); - ] - -let expected_poly_typ env (f:term) t targ = - (Errors.Fatal_PolyTypeExpected, (format3 "Expected a polymorphic function; got an expression \"%s\" of type \"%s\" applied to a type \"%s\"" - (show f) (N.term_to_string env t) (N.term_to_string env targ))) - -let disjunctive_pattern_vars (v1 v2 : list bv) = - let vars v = - v |> List.map show |> String.concat ", " in - (Errors.Fatal_DisjuctivePatternVarsMismatch, (format2 - "Every alternative of an 'or' pattern must bind the same variables; here one branch binds (\"%s\") and another (\"%s\")" - (vars v1) (vars v2))) - -let name_and_result c = match c.n with - | Total t -> "Tot", t - | GTotal t -> "GTot", t - | Comp ct -> show ct.effect_name, ct.result_typ - // TODO: ^ Use the resugaring environment to possibly shorten the effect name - -let computed_computation_type_does_not_match_annotation #a env (r:Range.range) e c c' : a = - let ppt = N.term_to_doc env in - let f1, r1 = name_and_result c in - let f2, r2 = name_and_result c' in - Errors.raise_error r Errors.Fatal_ComputedTypeNotMatchAnnotation [ - prefix 2 1 (text "Computed type") (ppt r1) ^/^ - prefix 2 1 (text "and effect") (text f1) ^/^ - prefix 2 1 (text "is not compatible with the annotated type") (ppt r2) ^/^ - prefix 2 1 (text "and effect") (text f2) - ] - -let computed_computation_type_does_not_match_annotation_eq #a env (r:Range.range) e c c' : a = - let ppc = N.comp_to_doc env in - Errors.raise_error r Errors.Fatal_ComputedTypeNotMatchAnnotation [ - prefix 2 1 (text "Computed type") (ppc c) ^/^ - prefix 2 1 (text "does not match annotated type") (ppc c') ^/^ - text "and no subtyping was allowed"; - ] - -let unexpected_non_trivial_precondition_on_term #a env f : a = - Errors.raise_error env Errors.Fatal_UnExpectedPreCondition - (format1 "Term has an unexpected non-trivial pre-condition: %s" (N.term_to_string env f)) - -let __expected_eff_expression (effname:string) (rng:Range.range) (e:term) (c:comp) (reason:option string) = - let open FStar.Class.PP in - let open FStar.Pprint in - Errors.raise_error rng Errors.Fatal_ExpectedGhostExpression [ - text ("Expected a " ^ effname ^ " expression."); - (match reason with - | None -> empty - | Some msg -> flow (break_ 1) (doc_of_string "Because:" :: words (msg ^ "."))); - prefix 2 1 (text "Got an expression") (pp e) ^/^ - prefix 2 1 (text "with effect") (squotes (doc_of_string (fst <| name_and_result c))) ^^ dot; - ] - -let expected_pure_expression (rng:Range.range) (e:term) (c:comp) (reason:option string) = - __expected_eff_expression "pure" rng e c reason - -let expected_ghost_expression (rng:Range.range)(e:term) (c:comp) (reason:option string) = - __expected_eff_expression "ghost" rng e c reason - -let expected_effect_1_got_effect_2 (c1:lident) (c2:lident) = - (Errors.Fatal_UnexpectedEffect, (format2 "Expected a computation with effect %s; but it has effect %s" (show c1) (show c2))) - -let failed_to_prove_specification_of (l : lbname) (lbls : list string) = - (Errors.Error_TypeCheckerFailToProve, (format2 "Failed to prove specification of %s; assertions at [%s] may fail" (show l) (lbls |> String.concat ", "))) - -let warn_top_level_effect (rng:Range.range) : unit = - Errors.log_issue rng - Errors.Warning_TopLevelEffect - "Top-level let-bindings must be total; this term may have effects" diff --git a/src/typechecker/FStar.TypeChecker.Generalize.fst b/src/typechecker/FStar.TypeChecker.Generalize.fst deleted file mode 100644 index 4904b0d211f..00000000000 --- a/src/typechecker/FStar.TypeChecker.Generalize.fst +++ /dev/null @@ -1,303 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.TypeChecker.Generalize - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Compiler.Util -open FStar.Errors -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.TypeChecker.Env - -open FStar.Class.Show -open FStar.Class.Setlike - -module BU = FStar.Compiler.Util -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module Free = FStar.Syntax.Free -module U = FStar.Syntax.Util -module Print = FStar.Syntax.Print -module UF = FStar.Syntax.Unionfind -module Env = FStar.TypeChecker.Env -module N = FStar.TypeChecker.Normalize - -let dbg_Gen = Debug.get_toggle "Gen" - -instance showable_univ_var : showable universe_uvar = { - show = (fun u -> show (U_unif u)); -} - -(**************************************************************************************) -(* Generalizing types *) -(**************************************************************************************) - -let gen_univs env (x:FlatSet.t universe_uvar) : list univ_name = - if is_empty x then [] - else let s = diff x (Env.univ_vars env) |> elems in // GGG: bad, order dependent - if !dbg_Gen then - BU.print1 "univ_vars in env: %s\n" (show (Env.univ_vars env)); - let r = Some (Env.get_range env) in - let u_names = s |> List.map (fun u -> - let u_name = Syntax.new_univ_name r in - if !dbg_Gen then - BU.print3 "Setting ?%s (%s) to %s\n" - (string_of_int <| UF.univ_uvar_id u) - (show (U_unif u)) - (show (U_name u_name)); - UF.univ_change u (U_name u_name); - u_name) - in - u_names - -let gather_free_univnames env t : FlatSet.t univ_name = - let ctx_univnames = Env.univnames env in - let tm_univnames = Free.univnames t in - let univnames = diff tm_univnames ctx_univnames in - // BU.print4 "Closing universe variables in term %s : %s in ctx, %s in tm, %s globally\n" - // (show t) - // (Common.string_of_set Ident.string_of_id ctx_univnames) - // (Common.string_of_set Ident.string_of_id tm_univnames) - // (Common.string_of_list Ident.string_of_id univnames); - univnames - -let check_universe_generalization - (explicit_univ_names : list univ_name) - (generalized_univ_names : list univ_name) - (t : term) - : list univ_name -= - match explicit_univ_names, generalized_univ_names with - | [], _ -> generalized_univ_names - | _, [] -> explicit_univ_names - | _ -> raise_error t Errors.Fatal_UnexpectedGeneralizedUniverse - ("Generalized universe in a term containing explicit universe annotation : " ^ show t) - -let generalize_universes (env:env) (t0:term) : tscheme = - Errors.with_ctx "While generalizing universes" (fun () -> - let t = N.normalize [Env.NoFullNorm; Env.Beta; Env.DoNotUnfoldPureLets] env t0 in - let univnames = elems (gather_free_univnames env t) in /// GGG: bad, order dependent - if !dbg_Gen - then BU.print2 "generalizing universes in the term (post norm): %s with univnames: %s\n" (show t) (show univnames); - let univs = Free.univs t in - if !dbg_Gen - then BU.print1 "univs to gen : %s\n" (show univs); - let gen = gen_univs env univs in - if !dbg_Gen - then BU.print2 "After generalization, t: %s and univs: %s\n" (show t) (show gen); - let univs = check_universe_generalization univnames gen t0 in - let t = N.reduce_uvar_solutions env t in - let ts = SS.close_univ_vars univs t in - univs, ts - ) - -let gen env (is_rec:bool) (lecs:list (lbname & term & comp)) : option (list (lbname & list univ_name & term & comp & list binder)) = - if not <| (BU.for_all (fun (_, _, c) -> U.is_pure_or_ghost_comp c) lecs) //No value restriction in F*---generalize the types of pure computations - then None - else - let norm c = - if Debug.medium () - then BU.print1 "Normalizing before generalizing:\n\t %s\n" (show c); - let c = Normalize.normalize_comp [Env.Beta; Env.Exclude Env.Zeta; Env.NoFullNorm; Env.DoNotUnfoldPureLets] env c in - if Debug.medium () then - BU.print1 "Normalized to:\n\t %s\n" (show c); - c in - let env_uvars = Env.uvars_in_env env in - let gen_uvars uvs = diff uvs env_uvars |> elems in /// GGG: bad, order depenedent - let univs_and_uvars_of_lec (lbname, e, c) = - let c = norm c in - let t = U.comp_result c in - let univs = Free.univs t in - let uvt = Free.uvars t in - if !dbg_Gen - then BU.print2 "^^^^\n\tFree univs = %s\n\tFree uvt=%s\n" - (show univs) (show uvt); - let univs = - List.fold_left - (fun univs uv -> union univs (Free.univs (U.ctx_uvar_typ uv))) - univs - (elems uvt) // Bad; order dependent - in - let uvs = gen_uvars uvt in - if !dbg_Gen - then BU.print2 "^^^^\n\tFree univs = %s\n\tgen_uvars = %s\n" - (show univs) (show uvs); - - univs, uvs, (lbname, e, c) - in - let univs, uvs, lec_hd = univs_and_uvars_of_lec (List.hd lecs) in - let force_univs_eq lec2 u1 u2 = - if equal u1 u2 - then () - else let lb1, _, _ = lec_hd in - let lb2, _, _ = lec2 in - let msg = BU.format2 "Generalizing the types of these mutually recursive definitions \ - requires an incompatible set of universes for %s and %s" - (show lb1) - (show lb2) in - raise_error env Errors.Fatal_IncompatibleSetOfUniverse msg - in - let force_uvars_eq lec2 (u1:list ctx_uvar) (u2:list ctx_uvar) = - let uvars_subseteq u1 u2 = - u1 |> BU.for_all (fun u -> - u2 |> BU.for_some (fun u' -> UF.equiv u.ctx_uvar_head u'.ctx_uvar_head)) - in - if uvars_subseteq u1 u2 - && uvars_subseteq u2 u1 - then () - else let lb1, _, _ = lec_hd in - let lb2, _, _ = lec2 in - let msg = BU.format2 "Generalizing the types of these mutually recursive definitions \ - requires an incompatible number of types for %s and %s" - (show lb1) - (show lb2) in - raise_error env Errors.Fatal_IncompatibleNumberOfTypes msg - in - - let lecs = - List.fold_right (fun this_lec lecs -> - let this_univs, this_uvs, this_lec = univs_and_uvars_of_lec this_lec in - force_univs_eq this_lec univs this_univs; - force_uvars_eq this_lec uvs this_uvs; - this_lec::lecs) - (List.tl lecs) - [] - in - - let lecs = lec_hd :: lecs in - - let gen_types (uvs:list ctx_uvar) : list (bv & bqual) = - uvs |> List.concatMap (fun u -> - (* If this implicit has a meta, don't generalize it. Just leave it - unresolved for the resolve_implicits phase to fill it in. *) - if Some? u.ctx_uvar_meta then [] else - - match UF.find u.ctx_uvar_head with - | Some _ -> failwith "Unexpected instantiation of mutually recursive uvar" - | _ -> - let k = N.normalize [Env.Beta; Env.Exclude Env.Zeta] env (U.ctx_uvar_typ u) in - let bs, kres = U.arrow_formals k in - //we only generalize variables at type k = a:Type{phi} - //where k is closed - //this is in support of ML-style polymorphism, while also allowing generalizing - //over things like eqtype, which is a common case - //Otherwise, things go badly wrong: see #1091 - match (U.unrefine (N.unfold_whnf env kres)).n with - | Tm_type _ -> - let free = FStar.Syntax.Free.names kres in - if not (is_empty free) then - [] - else - let a = S.new_bv (Some <| Env.get_range env) kres in - let t = - match bs with - | [] -> S.bv_to_name a - | _ -> U.abs bs (S.bv_to_name a) (Some (U.residual_tot kres)) - in - U.set_uvar u.ctx_uvar_head t; - //t clearly has a free variable; this is the one place we break the - //invariant of a uvar always being resolved to a term well-typed in its given context - [a, S.as_bqual_implicit true] - - | _ -> - (* This uvar was not a type. Do not generalize it and - leave the rest of typechecker attempt solving it, or fail *) - [] - ) - in - - let gen_univs = gen_univs env univs in - let gen_tvars = gen_types uvs in - - let ecs = lecs |> List.map (fun (lbname, e, c) -> - let e, c, gvs = - match gen_tvars, gen_univs with - | [], [] -> - //nothing generalized - e, c, [] - - | _ -> - //before we manipulate the term further, we must normalize it to get rid of the invariant-broken uvars - let e0, c0 = e, c in - let c = N.normalize_comp [Env.Beta; Env.DoNotUnfoldPureLets; Env.CompressUvars; Env.NoFullNorm; Env.Exclude Env.Zeta] env c in - let e = N.reduce_uvar_solutions env e in - let e = - if is_rec - then let tvar_args = List.map (fun (x, _) -> S.iarg (S.bv_to_name x)) gen_tvars in - let instantiate_lbname_with_app tm fv = - if S.fv_eq fv (right lbname) - then S.mk_Tm_app tm tvar_args tm.pos - else tm - in FStar.Syntax.InstFV.inst instantiate_lbname_with_app e - else e - in - //now, with the uvars gone, we can close over the newly introduced type names - let tvars_bs = gen_tvars |> List.map (fun (x, q) -> S.mk_binder_with_attrs x q None []) in - let t = match (SS.compress (U.comp_result c)).n with - | Tm_arrow {bs; comp=cod} -> - let bs, cod = SS.open_comp bs cod in - U.arrow (tvars_bs@bs) cod - - | _ -> - U.arrow tvars_bs c in - let e' = U.abs tvars_bs e (Some (U.residual_comp_of_comp c)) in - e', S.mk_Total t, tvars_bs in - (lbname, gen_univs, e, c, gvs)) - in - Some ecs - -let generalize' env (is_rec:bool) (lecs:list (lbname&term&comp)) : (list (lbname&univ_names&term&comp&list binder)) = - assert (List.for_all (fun (l, _, _) -> is_right l) lecs); //only generalize top-level lets - if Debug.low () then - BU.print1 "Generalizing: %s\n" - (show <| List.map (fun (lb, _, _) -> show lb) lecs); - let univnames_lecs = - let empty = from_list [] in - List.fold_left - (fun out (l, t, c) -> - union out (gather_free_univnames env t)) - empty - lecs - in - let univnames_lecs = elems univnames_lecs in /// GGG: bad, order dependent - let generalized_lecs = - match gen env is_rec lecs with - | None -> lecs |> List.map (fun (l,t,c) -> l,[],t,c,[]) - | Some luecs -> - if Debug.medium () - then luecs |> List.iter - (fun (l, us, e, c, gvs) -> - BU.print5 "(%s) Generalized %s at type %s\n%s\nVars = (%s)\n" - (show e.pos) - (show l) - (show (U.comp_result c)) - (show e) - (show gvs)); - luecs - in - List.map (fun (l, generalized_univs, t, c, gvs) -> - (l, check_universe_generalization univnames_lecs generalized_univs t, t, c, gvs)) - generalized_lecs - -let generalize env is_rec lecs = - Errors.with_ctx "While generalizing" (fun () -> - Profiling.profile (fun () -> generalize' env is_rec lecs) - (Some (Ident.string_of_lid (Env.current_module env))) - "FStar.TypeChecker.Util.generalize" - ) diff --git a/src/typechecker/FStar.TypeChecker.Generalize.fsti b/src/typechecker/FStar.TypeChecker.Generalize.fsti deleted file mode 100644 index 9ee78132208..00000000000 --- a/src/typechecker/FStar.TypeChecker.Generalize.fsti +++ /dev/null @@ -1,32 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.TypeChecker.Generalize - -open FStar open FStar.Compiler -open FStar.Syntax.Syntax -open FStar.TypeChecker.Env - -val generalize: - env -> - bool -> (* is_rec *) - list (lbname & term & comp) -> - list (lbname & univ_names & term & comp & list binder) - -val generalize_universes: - env -> - term -> - tscheme diff --git a/src/typechecker/FStar.TypeChecker.NBE.fst b/src/typechecker/FStar.TypeChecker.NBE.fst deleted file mode 100644 index faf731435b2..00000000000 --- a/src/typechecker/FStar.TypeChecker.NBE.fst +++ /dev/null @@ -1,1541 +0,0 @@ -(* - Copyright 2017-2019 Microsoft Research - - Authors: Zoe Paraskevopoulou, Guido Martinez, Nikhil Swamy - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.TypeChecker.NBE -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.TypeChecker.Cfg -open FStar.TypeChecker -open FStar.TypeChecker.Env -open FStar.Syntax.Syntax -open FStar.Ident -open FStar.Errors -open FStar.TypeChecker.Normalize -open FStar.TypeChecker.NBETerm - -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module Range = FStar.Compiler.Range -module U = FStar.Syntax.Util -module P = FStar.Syntax.Print -module BU = FStar.Compiler.Util -module Env = FStar.TypeChecker.Env -module Z = FStar.BigInt -module C = FStar.Const -module Cfg = FStar.TypeChecker.Cfg -module PO = FStar.TypeChecker.Primops -module NU = FStar.TypeChecker.Normalize.Unfolding -module FC = FStar.Const -module EMB = FStar.Syntax.Embeddings -module PC = FStar.Parser.Const -module TEQ = FStar.TypeChecker.TermEqAndSimplify - -open FStar.Class.Show -open FStar.Class.Tagged - -let dbg_NBE = Debug.get_toggle "NBE" -let dbg_NBETop = Debug.get_toggle "NBETop" - -(* Broadly, the algorithm implemented here is inspired by - - Full Reduction at Full Throttle: - https://dl.acm.org/citation.cfm?id=2178141 - - Except, we don't implement any of the native tricks in the OCaml - runtime for compiling inductives and pattern matching. So, you - could see what we're doing here as, perhaps, "Full Reduction at - Half Throttle". - - More classically, what we have here is a definitional interpreter, - in the tradition of Reynolds' Definitional Interpreters: - https://dl.acm.org/citation.cfm?id=805852 (1972) - A more recent version of that paper is here: - http://homepages.inf.ed.ac.uk/wadler/papers/papers-we-love/reynolds-definitional-interpreters-1998.pdf - - The broad idea of the algorithm is sketched for a tiny lambda - calculus in examples/metatheory/FullReductionInterpreter.fst - - That's a good thing to digest before getting into the complexity of - the module here. - - A lot of the complexity here is in handling all the features of F*, - notably in the handling of inductive datatypes, pattern matching, - recursive definitions, and reified effects. -*) - - -//////////////////////////////////////////////////////////////////////////////// -// Utilities: Many of these should just move to FStar.Compiler.List, if it's -// not already there -//////////////////////////////////////////////////////////////////////////////// - -// VD: This seems necessary for the OCaml build -let max a b = if a > b then a else b - -let map_rev (f : 'a -> 'b) (l : list 'a) : list 'b = - let rec aux (l:list 'a) (acc:list 'b) = //NS: weird, this needs an annotation to type-check in F*; cf issue # - match l with - | [] -> acc - | x :: xs -> aux xs (f x :: acc) - in aux l [] - -let map_rev_append (f : 'a -> 'b) (l1 : list 'a) (l2 : list 'b) : list 'b = - let rec aux (l:list 'a) (acc:list 'b) = - match l with - | [] -> l2 - | x :: xs -> aux xs (f x :: acc) - in aux l1 l2 - -let rec map_append (f : 'a -> 'b) (l1 : list 'a) (l2 : list 'b) : list 'b = - match l1 with - | [] -> l2 - | x :: xs -> (f x) :: map_append f xs l2 - -let rec drop (p: 'a -> bool) (l: list 'a): list 'a = - match l with - | [] -> [] - | x::xs -> if p x then x::xs else drop p xs - -let fmap_opt (f : 'a -> 'b) (x : option 'a) : option 'b = - BU.bind_opt x (fun x -> Some (f x)) - -let drop_until (f : 'a -> bool) (l : list 'a) : list 'a = - let rec aux l = - match l with - | [] -> [] - | x :: xs -> if f x then l else aux xs - in aux l - -let trim (l : list bool) : list bool = (* trim a list of booleans after the last true *) - List.rev (drop_until id (List.rev l)) - - -let implies b1 b2 = - match b1, b2 with - | false, _ -> true - | true, b2 -> b2 - -let let_rec_arity (b:letbinding) : int & list bool = - let (ar, maybe_lst) = U.let_rec_arity b in - match maybe_lst with - | None -> - ar, - FStar.Common.tabulate ar (fun _ -> true) (* treat all arguments as recursive *) - | Some lst -> - ar, lst - // let l = trim lst in - // List.length l, l - -// NBE debuging - -let debug_term (t : term) = - BU.print1 "%s\n" (show t) - -let debug_sigmap (m : BU.smap sigelt) = - BU.smap_fold m (fun k v u -> BU.print2 "%s -> %%s\n" k (P.sigelt_to_string_short v)) () - - -//////////////////////////////////////////////////////////////////////////////// -//End utilities -//////////////////////////////////////////////////////////////////////////////// -type config = { - core_cfg:Cfg.cfg; - fv_cache:BU.smap t -} -let new_config (cfg:Cfg.cfg) = { - core_cfg = cfg; - fv_cache = BU.smap_create 51 -} -let reifying_false (cfg:config) = - if cfg.core_cfg.reifying - then new_config ({cfg.core_cfg with reifying=false}) //blow away cache - else cfg -let reifying_true (cfg:config) = - if not (cfg.core_cfg.reifying) - then new_config ({cfg.core_cfg with reifying=true}) //blow away cache - else cfg -let zeta_false (cfg:config) = - let cfg_core = cfg.core_cfg in - if cfg_core.steps.zeta - then - let cfg_core' = {cfg_core with steps={cfg_core.steps with zeta=false}} in // disable zeta flag - new_config cfg_core' //blow away cache - else cfg -let cache_add (cfg:config) (fv:fv) (v:t) = - let lid = fv.fv_name.v in - BU.smap_add cfg.fv_cache (string_of_lid lid) v -let try_in_cache (cfg:config) (fv:fv) : option t = - let lid = fv.fv_name.v in - BU.smap_try_find cfg.fv_cache (string_of_lid lid) -let debug cfg f = log_nbe cfg.core_cfg f - - -(* GM, Aug 19th 2018: This should not (at least always) be recursive. - * Forcing the thunk on an NBE term (Lazy i) triggers arbitrary - * computation, and it might very well turn out to normalize to another - * (Lazy i') (probably with i=i'). An example, from Meta-F*, is - * (pack_binder (pack_bv .., Q_Explicit)). - *) -let rec unlazy_unmeta t = - match t.nbe_t with - | Lazy (_, t) -> unlazy_unmeta (Thunk.force t) - | Meta(t0, m) -> - begin - match Thunk.force m with - | Meta_monadic(_, _) - | Meta_monadic_lift(_, _, _) -> t - | _ -> unlazy_unmeta t0 - end - | _ -> t - -let pickBranch (cfg:config) (scrut : t) (branches : list branch) : option (term & list t) = - let all_branches = branches in - let rec pickBranch_aux (scrut : t) (branches : list branch) (branches0 : list branch) : option (term & list t) = - //NS: adapted from FStar.TypeChecker.Normalize: rebuild_match - let rec matches_pat (scrutinee0:t) (p:pat) - : either (list t) bool = - (* Inl ts: p matches t and ts are bindings for the branch *) - (* Inr false: p definitely does not match t *) - (* Inr true: p may match t, but p is an open term and we cannot decide for sure *) - debug cfg (fun () -> BU.print2 "matches_pat (%s, %s)\n" (t_to_string scrutinee0) (show p)); - let scrutinee = unlazy_unmeta scrutinee0 in - let r = match p.v with - | Pat_var bv -> - // important to use the non-unfolded variant, some embeddings - // have no decent unfolding (i.e. they cheat) - Inl [scrutinee0] - - | Pat_dot_term _ -> - Inl [] - - | Pat_constant s -> - let matches_const (c: t) (s: S.sconst) = - debug cfg (fun () -> BU.print2 "Testing term %s against pattern %s\n" - (t_to_string c) (show s)); - match c.nbe_t with - | Constant (Unit) -> s = C.Const_unit - | Constant (Bool b) -> (match s with | C.Const_bool p -> b = p | _ -> false) - | Constant (Int i) -> (match s with | C.Const_int (p, None) -> i = Z.big_int_of_string p | _ -> false) - | Constant (String (st, _)) -> (match s with | C.Const_string(p, _) -> st = p | _ -> false) - | Constant (Char c) -> (match s with | C.Const_char p -> c = p | _ -> false) - | _ -> false - in - if matches_const scrutinee s then Inl [] else Inr false - - | Pat_cons(fv, _us_opt, arg_pats) -> - let rec matches_args out (a:list (t & aqual)) (p:list (pat & bool)) - : either (list t) bool = - match a, p with - | [], [] -> Inl out - | (t, _)::rest_a, (p, _)::rest_p -> - (match matches_pat t p with - | Inl s -> matches_args (out@s) rest_a rest_p - | m -> m) - | _ -> - Inr false - in - match scrutinee.nbe_t with - | Construct(fv', _us, args_rev) -> - if fv_eq fv fv' - then matches_args [] (List.rev args_rev) arg_pats - else Inr false - - | _ -> //must be a variable - Inr true - in - let res_to_string = function - | Inr b -> "Inr " ^ BU.string_of_bool b - | Inl bs -> "Inl " ^ BU.string_of_int (List.length bs) - in - debug cfg (fun () -> BU.print3 "matches_pat (%s, %s) = %s\n" (t_to_string scrutinee) (show p) (res_to_string r)); - r - in - match branches with - | [] -> - None - - // TODO: Consider the when clause! - | (p, _wopt, e)::branches -> - match matches_pat scrut p with - | Inl matches -> - debug cfg (fun () -> BU.print1 "Pattern %s matches\n" (show p)); - Some (e, matches) - | Inr false -> //definitely did not match - pickBranch_aux scrut branches branches0 - | Inr true -> //maybe matches; stop - None - in pickBranch_aux scrut branches branches - -// Tests if a recursive function should be reduced based on -// the arguments provided and the arity/decreases clause of the function. -// Returns: -// should_unfold: bool, true, if the application is full and if none of the recursive -// arguments is symbolic. -// arguments : list arg, the arguments to the recursive function in reverse order -// residual args: list arg, any additional arguments, beyond the arity of the function -let should_reduce_recursive_definition - (arguments:args) - (formals_in_decreases:list bool) - : (bool & args & args) (* can unfold x full arg list x residual args *) - = - let rec aux ts ar_list acc = - match ts, ar_list with - | _, [] -> - true, acc, ts - | [], _ :: _ -> - false, acc, [] (* It's partial! *) - | t :: ts, in_decreases_clause :: bs -> - if in_decreases_clause - && isAccu (fst t) //one of the recursive arguments is symbolic, so we shouldn't reduce - then false, List.rev_append ts acc, [] - else aux ts bs (t::acc) - in - aux arguments formals_in_decreases [] - -let find_sigelt_in_gamma cfg (env: Env.env) (lid:lident): option sigelt = - let mapper (lr, rng) = - match lr with - | Inr (elt, None) -> Some elt - | Inr (elt, Some us) -> - debug cfg (fun () -> BU.print1 "Universes in local declaration: %s\n" (show us)); - Some elt - | _ -> None in - BU.bind_opt (Env.lookup_qname env lid) mapper - -let is_univ (tm : t) = - match tm.nbe_t with - | Univ _ -> true - | _ -> false - -let un_univ (tm:t) : universe = - match tm.nbe_t with - | Univ u -> u - | _ -> failwith ("Not a universe: " ^ t_to_string tm) - -let is_constr_fv (fvar : fv) : bool = - fvar.fv_qual = Some Data_ctor - -let is_constr (q : qninfo) : bool = - match q with - | Some (Inr ({ sigel = Sig_datacon _ }, _), _) -> true - | _ -> false - -let translate_univ (cfg:config) (bs:list t) (u:universe) : universe = - let rec aux u = - let u = SS.compress_univ u in - match u with - | U_bvar i -> - if i < List.length bs - then - let u' = List.nth bs i in //it has to be a Univ term at position i - (un_univ u') - else if cfg.core_cfg.steps.allow_unbound_universes - then U_zero - else failwith "Universe index out of bounds" - - | U_succ u -> U_succ (aux u) - - | U_max us -> U_max (List.map aux us) - - | U_unknown | U_name _ | U_unif _ | U_zero -> u - in - aux u - -let find_let (lbs : list letbinding) (fvar : fv) = - BU.find_map lbs (fun lb -> match lb.lbname with - | Inl _ -> failwith "find_let : impossible" - | Inr name -> - if fv_eq name fvar - then Some lb - else None) - -let mk_rt r t = { nbe_t = t; nbe_r = r } -let mk_t t = { nbe_t = t; nbe_r = Range.dummyRange } - -/// Normalization is implemented using two mutually recursive functions, -/// translate and readback, -/// i.e., `norm cfg t = readback cfg (translate cfg [] t)` -/// -/// For `translate`: -/// -/// - `cfg` records various configuration options, e.g., which -/// definitions are to be unfolded -/// -/// - `bs` is an environment for the bound variables in scope, in de -/// Bruijn order (i.e., most recent binders are the head of the list) -/// -/// - `e:term` is the syntax being reduced -/// -/// The main idea is to translate syntactic entities, notably -/// functions, into functions of the host language; and -/// correspondingly, source beta redexes into host language -/// applications. As such, the process of translation triggers -/// call-by-value reduction of the syntax, relying on the reduction -/// strategy of the host. -let rec translate (cfg:config) (bs:list t) (e:term) : t = - let debug = debug cfg in - let mk_t t = mk_rt e.pos t in - debug (fun () -> BU.print2 "Term: %s - %s\n" (tag_of (SS.compress e)) (show (SS.compress e))); -// debug (fun () -> BU.print1 "BS list: %s\n" (String.concat ";; " (List.map (fun x -> t_to_string x) bs))); - match (SS.compress e).n with - | Tm_delayed _ -> - failwith "Tm_delayed: Impossible" - - | Tm_unknown -> - mk_t Unknown - - | Tm_constant c -> - mk_t <| Constant (translate_constant c) - - | Tm_bvar db -> //de Bruijn - if db.index < List.length bs - then - let t = List.nth bs db.index in - debug (fun () -> BU.print2 "Resolved bvar to %s\n\tcontext is [%s]\n" - (t_to_string t) - (List.map t_to_string bs |> String.concat "; ") - ); - t - else failwith "de Bruijn index out of bounds" - - | Tm_uinst(t, us) -> - debug (fun () -> BU.print2 "Uinst term : %s\nUnivs : %s\n" (show t) - (List.map show us |> String.concat ", ")); - iapp cfg (translate cfg bs t) (List.map (fun x -> as_arg (mk_t <| Univ (translate_univ cfg bs x))) us) - - | Tm_type u -> - mk_t <| Type_t (translate_univ cfg bs u) - - | Tm_arrow {bs=xs; comp=c} -> - let norm () = - let ctx, binders_rev = - List.fold_left - (fun (ctx, binders_rev) b -> - let x = b.binder_bv in - let t = readback cfg (translate cfg ctx x.sort) in - let x = { S.freshen_bv x with sort = t } in - let ctx = mkAccuVar x :: ctx in - ctx, ({b with binder_bv=x}) :: binders_rev) - (bs, []) - xs - in - let c = readback_comp cfg (translate_comp cfg ctx c) in - U.arrow (List.rev binders_rev) c - in - mk_t <| Arrow (Inl (Thunk.mk norm)) - - | Tm_refine {b=bv; phi=tm} -> - if cfg.core_cfg.steps.for_extraction - || cfg.core_cfg.steps.unrefine - then translate cfg bs bv.sort //if we're only extracting, then drop the refinement - else mk_t <| Refinement ((fun (y:t) -> translate cfg (y::bs) tm), - (fun () -> as_arg (translate cfg bs bv.sort))) // XXX: Bogus type? - - | Tm_ascribed {tm=t} -> - translate cfg bs t - - | Tm_uvar (u, (subst, set_use_range)) -> - let norm_uvar () = - let norm_subst_elt = function - | NT(x, t) -> - NT(x, readback cfg (translate cfg bs t)) - | NM(x, i) -> - let x_i = S.bv_to_tm ({x with index=i}) in - let t = readback cfg (translate cfg bs x_i) in - (match t.n with - | Tm_bvar x_j -> NM(x, x_j.index) - | _ -> NT(x, t)) - | _ -> failwith "Impossible: subst invariant of uvar nodes" - in - let subst = List.map (List.map norm_subst_elt) subst in - { e with n = Tm_uvar(u, (subst, set_use_range)) } - in - mk_t <| Accu(UVar (Thunk.mk norm_uvar), []) - - | Tm_name x -> - mkAccuVar x - - | Tm_abs {bs=[]} -> failwith "Impossible: abstraction with no binders" - - | Tm_abs {bs=xs; body; rc_opt=resc} -> - mk_t <| Lam { - interp = (fun ys -> translate cfg (List.append (List.map fst ys) bs) body); - shape = Lam_bs (bs, xs, resc); - arity = List.length xs; - } - - | Tm_fvar fvar -> - begin - match try_in_cache cfg fvar with - | Some t -> t - | _ -> translate_fv cfg bs (S.set_range_of_fv fvar e.pos) - end - - | Tm_app {hd={n=Tm_constant (FC.Const_reify _)}; args=arg::more::args} - | Tm_app {hd={n=Tm_constant (FC.Const_reflect _)}; args=arg::more::args} -> - let head, _ = U.head_and_args e in - let head = S.mk_Tm_app head [arg] e.pos in - translate cfg bs (S.mk_Tm_app head (more::args) e.pos) - - | Tm_app {hd={n=Tm_constant (FC.Const_reflect _)}; args=[arg]} when cfg.core_cfg.reifying -> - let cfg = reifying_false cfg in - translate cfg bs (fst arg) - - | Tm_app {hd={n=Tm_constant (FC.Const_reflect _)}; args=[arg]} -> - mk_t <| Reflect (translate cfg bs (fst arg)) - - | Tm_app {hd={n=Tm_constant (FC.Const_reify _)}; args=[arg]} - when cfg.core_cfg.steps.reify_ -> - assert (not cfg.core_cfg.reifying); - let cfg = reifying_true cfg in - translate cfg bs (fst arg) - - | Tm_app {hd={n=Tm_constant (FC.Const_reflect _)}; args=[arg]} -> - mk_t <| Reflect (translate cfg bs (fst arg)) - - | Tm_app {hd={n=Tm_fvar fv}; args=[_]} - when S.fv_eq_lid fv PC.assert_lid || - S.fv_eq_lid fv PC.assert_norm_lid -> - debug (fun () -> BU.print_string "Eliminated assertion\n"); - mk_t (Constant Unit) - - | Tm_app {hd=head; args} - when (Cfg.cfg_env cfg.core_cfg).erase_erasable_args - || cfg.core_cfg.steps.for_extraction - || cfg.core_cfg.debug.erase_erasable_args (* for debugging *) -> - iapp cfg (translate cfg bs head) - (List.map - (fun x -> - if U.aqual_is_erasable (snd x) - then ( - debug (fun () -> BU.print1 "Erasing %s\n" (show (fst x))); - mk_t (Constant Unit), snd x - ) - else translate cfg bs (fst x), snd x) - args) - - | Tm_app {hd=head; args} -> - debug (fun () -> BU.print2 "Application: %s @ %s\n" (show head) (show args)); - iapp cfg (translate cfg bs head) (List.map (fun x -> (translate cfg bs (fst x), snd x)) args) // Zoe : TODO avoid translation pass for args - - | Tm_match {scrutinee=scrut; ret_opt; brs=branches; rc_opt=rc} -> - (* Thunked computation to reconstrct the returns annotation *) - let make_returns () : option match_returns_ascription = - match ret_opt with - | None -> None - | Some (b, asc) -> - let b, bs = - let x = gen_bv' b.binder_bv.ppname None (readback cfg (translate cfg bs b.binder_bv.sort)) in - mk_binder x, mkAccuVar x::bs in - let asc = - match asc with - | Inl t, tacopt, use_eq -> Inl (readback cfg (translate cfg bs t)), tacopt, use_eq - | Inr c, tacopt, use_eq -> Inr (readback_comp cfg (translate_comp cfg bs c)), tacopt, use_eq in - let asc = SS.close_ascription [b] asc in - let b = List.hd (SS.close_binders [b]) in - Some (b, asc) in - - (* Thunked computation to reconstruct residual comp *) - let make_rc () : option S.residual_comp = - match rc with - | None -> None - | Some rc -> Some (readback_residual_comp cfg (translate_residual_comp cfg bs rc)) in - - (* Thunked computation that reconstructs the patterns *) - let make_branches () : list branch = - let cfg = zeta_false cfg in - let rec process_pattern bs (p:pat) : list t & pat = (* returns new environment and pattern *) - let (bs, p_new) = - match p.v with - | Pat_constant c -> (bs, Pat_constant c) - | Pat_cons (fvar, us_opt, args) -> - let (bs', args') = - List.fold_left (fun (bs, args) (arg, b) -> - let (bs', arg') = process_pattern bs arg in - (bs', (arg', b) :: args)) (bs, []) args - in - let us_opt = - match us_opt with - | None -> None - | Some us -> Some (List.map (translate_univ cfg bs) us) - in - (bs', Pat_cons (fvar, us_opt, List.rev args')) - | Pat_var bvar -> - let x = S.gen_bv' bvar.ppname None (readback cfg (translate cfg bs bvar.sort)) in - (mkAccuVar x :: bs, Pat_var x) - | Pat_dot_term eopt -> - (bs, - Pat_dot_term (BU.map_option (fun e -> readback cfg (translate cfg bs e)) eopt)) - in - (bs, {p with v = p_new}) (* keep the info and change the pattern *) - in - List.map (fun (pat, when_clause, e) -> - let (bs', pat') = process_pattern bs pat in - (* TODO : handle when clause *) - U.branch (pat', when_clause, readback cfg (translate cfg bs' e))) branches - in - - let scrut = translate cfg bs scrut in - debug (fun () -> BU.print2 "%s: Translating match %s\n" - (Range.string_of_range e.pos) - (show e)); - let scrut = unlazy_unmeta scrut in - begin - match scrut.nbe_t with - | Construct(c, us, args) -> (* Scrutinee is a constructed value *) - (* Assuming that all the arguments to the pattern constructors - are binders -- i.e. no nested patterns for now *) - debug (fun () -> - BU.print1 "Match args: %s\n" - (args - |> List.map (fun (x, q) -> (if BU.is_some q then "#" else "") ^ t_to_string x) - |> String.concat "; ")); - begin - match pickBranch cfg scrut branches with - | Some (branch, args) -> - translate cfg (List.fold_left (fun bs x -> x::bs) bs args) branch - | None -> //no branch is determined - mkAccuMatch scrut make_returns make_branches make_rc - end - | Constant c -> - debug (fun () -> BU.print1 "Match constant : %s\n" (t_to_string scrut)); - (* same as for construted values, but args are either empty or is a singleton list (for wildcard patterns) *) - (match pickBranch cfg scrut branches with - | Some (branch, []) -> - translate cfg bs branch - | Some (branch, [arg]) -> - translate cfg (arg::bs) branch - | None -> //no branch is determined - mkAccuMatch scrut make_returns make_branches make_rc - | Some (_, hd::tl) -> - failwith "Impossible: Matching on constants cannot bind more than one variable") - - | _ -> - mkAccuMatch scrut make_returns make_branches make_rc - end - - | Tm_meta {tm=e; meta=Meta_monadic(m, t)} - when cfg.core_cfg.reifying -> - translate_monadic (m, t) cfg bs e - - | Tm_meta {tm=e; meta=Meta_monadic_lift(m, m', t)} - when cfg.core_cfg.reifying -> - translate_monadic_lift (m, m', t) cfg bs e - - | Tm_meta {tm=e; meta} -> - let norm_meta () = - let norm t = readback cfg (translate cfg bs t) in - match meta with - | Meta_named _ - | Meta_labeled _ - | Meta_desugared _ -> meta - | Meta_pattern (ts, args) -> - Meta_pattern (List.map norm ts, - List.map (List.map (fun (t, a) -> norm t, a)) args) - | Meta_monadic(m, t) -> - Meta_monadic(m, norm t) - | Meta_monadic_lift(m0, m1, t) -> - Meta_monadic_lift(m0, m1, norm t) - in - mk_t <| Meta(translate cfg bs e, Thunk.mk norm_meta) - - | Tm_let {lbs=(false, [lb]); body} -> // non-recursive let - if Cfg.should_reduce_local_let cfg.core_cfg lb - then if cfg.core_cfg.steps.for_extraction - && U.is_unit lb.lbtyp - && U.is_pure_or_ghost_effect lb.lbeff - then let bs = mk_rt (S.range_of_lbname lb.lbname) (Constant Unit) :: bs in - translate cfg bs body - else let bs = translate_letbinding cfg bs lb :: bs in - translate cfg bs body - else let def () = - if cfg.core_cfg.steps.for_extraction - && U.is_unit lb.lbtyp - && U.is_pure_or_ghost_effect lb.lbeff - then mk_t <| Constant Unit - else translate cfg bs lb.lbdef - in - let typ () = translate cfg bs lb.lbtyp in - let name = freshen_bv (BU.left lb.lbname) in - let bs = mk_rt (S.range_of_bv name) (Accu (Var name, [])) :: bs in - let body () = translate cfg bs body in - mk_t <| Accu(UnreducedLet(name, Thunk.mk typ, Thunk.mk def, Thunk.mk body, lb), []) - - | Tm_let {lbs=(_rec, lbs); body} -> //recursive let - if not cfg.core_cfg.steps.zeta && - cfg.core_cfg.steps.pure_subterms_within_computations - then //can't reduce this let rec - let vars = List.map (fun lb -> freshen_bv (BU.left lb.lbname)) lbs in - let typs = List.map (fun lb -> translate cfg bs lb.lbtyp) lbs in - let rec_bs = List.map (fun v -> mk_rt (S.range_of_bv v) <| Accu (Var v, [])) vars @ bs in - let defs = List.map (fun lb -> translate cfg rec_bs lb.lbdef) lbs in - let body = translate cfg rec_bs body in - mk_t <| Accu(UnreducedLetRec(List.zip3 vars typs defs, body, lbs), []) - else translate cfg (make_rec_env lbs bs) body - - | Tm_quoted (qt, qi) -> - let close t = - let bvs = List.map (fun _ -> S.new_bv None S.tun) bs in - let s1 = List.mapi (fun i bv -> DB (i, bv)) bvs in - let s2 = List.map (fun (bv, t) -> NT (bv, readback cfg t)) (List.zip bvs bs) in - SS.subst s2 (SS.subst s1 t) - in - begin match qi.qkind with - | Quote_dynamic -> - let qt = close qt in - mk_t <| Quote (qt, qi) - | Quote_static -> - let qi = S.on_antiquoted close qi in - mk_t <| Quote (qt, qi) - end - - | Tm_lazy li -> - let f () = - let t = U.unfold_lazy li in - debug (fun () -> BU.print1 ">> Unfolding Tm_lazy to %s\n" (show t)); - translate cfg bs t - in - mk_t <| Lazy (Inl li, Thunk.mk f) - -and translate_comp cfg bs (c:S.comp) : comp = - match c.n with - | S.Total typ -> Tot (translate cfg bs typ) - | S.GTotal typ -> GTot (translate cfg bs typ) - | S.Comp ctyp -> Comp (translate_comp_typ cfg bs ctyp) - -(* uncurried application *) -and iapp (cfg : config) (f:t) (args:args) : t = - // meta and lazy nodes shouldn't block reduction - let mk t = mk_rt f.nbe_r t in - match (unlazy_unmeta f).nbe_t with - | Lam {interp=f; shape; arity=n} -> - let m = List.length args in - if m < n then - // partial application - let arg_values_rev = List.rev args in - let shape = - match shape with - | Lam_args raw_args -> - let _, raw_args = List.splitAt m raw_args in - Lam_args raw_args - - | Lam_bs (ctx, xs, rc) -> - let _, xs = List.splitAt m xs in - let ctx = List.append (List.map fst arg_values_rev) ctx in - Lam_bs (ctx, xs, rc) - - | Lam_primop (f, args_acc) -> - Lam_primop (f, args_acc @ args) - in - mk <| - Lam { - interp = (fun l -> f (List.append l arg_values_rev)); - shape = shape; - arity = n-m; - } - else if m = n then - // full application - let arg_values_rev = List.rev args in - f arg_values_rev - else - // extra arguments - let (args, args') = List.splitAt n args in - iapp cfg (f (List.rev args)) args' - | Accu (a, ts) -> mk <| Accu (a, List.rev_append args ts) - | Construct (i, us, ts) -> - let rec aux args us ts = - match args with - | ({nbe_t=Univ u}, _) :: args -> aux args (u :: us) ts - | a :: args -> aux args us (a :: ts) - | [] -> (us, ts) - in - let (us', ts') = aux args us ts in - mk <| Construct (i, us', ts') - | FV (i, us, ts) -> - let rec aux args us ts = - match args with - | ({nbe_t=Univ u}, _) :: args -> aux args (u :: us) ts - | a :: args -> aux args us (a :: ts) - | [] -> (us, ts) - in - let (us', ts') = aux args us ts in - mk <| FV (i, us', ts') - - | TopLevelLet(lb, arity, args_rev) -> - let args_rev = List.rev_append args args_rev in - let n_args_rev = List.length args_rev in - let n_univs = List.length lb.lbunivs in - debug cfg (fun () -> - BU.print3 "Reached iapp for %s with arity %s and n_args = %s\n" - (show lb.lbname) - (show arity) - (show n_args_rev)); - if n_args_rev >= arity - then let bs, body = - match (U.unascribe lb.lbdef).n with - | Tm_abs {bs; body} -> bs, body - | _ -> [], lb.lbdef - in - if n_univs + List.length bs = arity - then let extra, args_rev = BU.first_N (n_args_rev - arity) args_rev in - debug cfg (fun () -> - BU.print3 "Reducing body of %s = %s,\n\twith args = %s\n" - (show lb.lbname) - (show body) - (show args_rev)); - let t = translate cfg (List.map fst args_rev) body in - match extra with - | [] -> t - | _ -> iapp cfg t (List.rev extra) - else let extra, univs = BU.first_N (n_args_rev - n_univs) args_rev in - iapp cfg (translate cfg (List.map fst univs) lb.lbdef) (List.rev extra) - else mk <| TopLevelLet (lb, arity, args_rev) //not enough args yet - - | TopLevelRec (lb, arity, decreases_list, args') -> - let args = List.append args' args in - if List.length args >= arity - then let should_reduce, _, _ = - should_reduce_recursive_definition args decreases_list - in - if not should_reduce - then begin - let fv = BU.right lb.lbname in - debug cfg (fun () -> BU.print1 "Decided to not unfold recursive definition %s\n" (show fv)); - iapp cfg (mk_rt (S.range_of_fv fv) (FV (fv, [], []))) args - end - else begin - debug cfg (fun () -> BU.print1 "Yes, Decided to unfold recursive definition %s\n" (show (BU.right lb.lbname))); - let univs, rest = BU.first_N (List.length lb.lbunivs) args in - iapp cfg (translate cfg (List.rev (List.map fst univs)) lb.lbdef) rest - end - else //not enough args yet - mk <| TopLevelRec (lb, arity, decreases_list, args) - - | LocalLetRec(i, lb, mutual_lbs, local_env, acc_args, remaining_arity, decreases_list) -> - if remaining_arity = 0 //we've already decided to not unfold this, so just accumulate - then mk <| LocalLetRec(i, lb, mutual_lbs, local_env, acc_args @ args, remaining_arity, decreases_list) - else - let n_args = List.length args in - if n_args < remaining_arity //still a partial application, just accumulate - then mk <| LocalLetRec(i, lb, mutual_lbs, local_env, acc_args @ args, remaining_arity - n_args, decreases_list) - else begin - let args = acc_args @ args in (* Not in reverse order *) - let should_reduce, _, _ = - should_reduce_recursive_definition args decreases_list - in - //local let binding don't have universes - if not should_reduce - then mk <| LocalLetRec(i, lb, mutual_lbs, local_env, args, 0, decreases_list) - else let env = make_rec_env mutual_lbs local_env in - let _ = - debug cfg (fun () -> - BU.print1 "LocalLetRec Env = {\n\t%s\n}\n" (String.concat ",\n\t " (List.map t_to_string env)); - BU.print1 "LocalLetRec Args = {\n\t%s\n}\n" (String.concat ",\n\t " (List.map (fun (t, _) -> t_to_string t) args))) - in - iapp cfg (translate cfg env lb.lbdef) args - end - - | Constant (SConst FStar.Const.Const_range_of) -> - let callbacks = { - iapp = iapp cfg; - translate = translate cfg []; - } in - begin - match args with - | [(a, _)] -> - embed e_range callbacks a.nbe_r - // mk_rt a.nbe_r (Constant (Range a.nbe_r)) - | _ -> failwith ("NBE ill-typed application Const_range_of: " ^ t_to_string f) - end - - | Constant (SConst FStar.Const.Const_set_range_of) -> - begin - let callbacks = { - iapp = iapp cfg; - translate = translate cfg []; - } in - match args with - | [(t, _); (r, _)] -> ( - match unembed e_range callbacks r with - | Some rr -> { t with nbe_r = rr } - | None -> magic() - ) - | _ -> failwith ("NBE ill-typed application Const_set_range_of: " ^ t_to_string f) - end - - | _ -> - failwith ("NBE ill-typed application: " ^ t_to_string f) - - -and translate_fv (cfg: config) (bs:list t) (fvar:fv): t = - let debug = debug cfg in - let qninfo = Env.lookup_qname (Cfg.cfg_env cfg.core_cfg) (S.lid_of_fv fvar) in - if is_constr qninfo || is_constr_fv fvar then mkConstruct fvar [] [] - else - match NU.should_unfold cfg.core_cfg (fun _ -> cfg.core_cfg.reifying) fvar qninfo with - | NU.Should_unfold_fully -> - failwith "Not yet handled" - - | NU.Should_unfold_no -> - debug (fun () -> BU.print1 "(1) Decided to not unfold %s\n" (show fvar)); - begin match Cfg.find_prim_step cfg.core_cfg fvar with - | Some prim_step when prim_step.strong_reduction_ok (* TODO : || not cfg.strong *) -> - let arity = prim_step.arity + prim_step.univ_arity in - debug (fun () -> BU.print1 "Found a primop %s\n" (show fvar)); - mk_t <| Lam { - interp = (fun args_rev -> - let args' = List.rev args_rev in - let callbacks = { - iapp = iapp cfg; - translate = translate cfg bs; - } in - debug (fun () -> BU.print1 "Caling primop with args = [%s]\n" (show args')); - let univs, rest = List.span (function ({nbe_t=Univ _ }, _) -> true | _ -> false) args' in - let univs = List.map (function ({nbe_t=Univ u}, _) -> u | _ -> failwith "Impossible") univs in - match prim_step.interpretation_nbe callbacks univs rest with - | Some x -> - debug (fun () -> BU.print2 "Primitive operator %s returned %s\n" (show fvar) (t_to_string x)); - x - | None -> - debug (fun () -> BU.print1 "Primitive operator %s failed\n" (show fvar)); - iapp cfg (mkFV fvar [] []) args'); - shape = Lam_primop (fvar, []); - arity = arity; - } - - | Some _ -> debug (fun () -> BU.print1 "(2) Decided to not unfold %s\n" (show fvar)); mkFV fvar [] [] - | _ -> debug (fun () -> BU.print1 "(3) Decided to not unfold %s\n" (show fvar)); mkFV fvar [] [] - end - - - | NU.Should_unfold_reify - | NU.Should_unfold_yes -> - let t = - let is_qninfo_visible = - Option.isSome (Env.lookup_definition_qninfo cfg.core_cfg.delta_level fvar.fv_name.v qninfo) - in - if is_qninfo_visible - then begin - match qninfo with - | Some (Inr ({ sigel = Sig_let {lbs=(is_rec, lbs); lids=names} }, _us_opt), _rng) -> - debug (fun () -> BU.print1 "(1) Decided to unfold %s\n" (show fvar)); - let lbm = find_let lbs fvar in - begin match lbm with - | Some lb -> - if is_rec && cfg.core_cfg.steps.zeta - then - let ar, lst = let_rec_arity lb in - mk_rt (S.range_of_fv fvar) <| TopLevelRec(lb, ar, lst, []) - else - translate_letbinding cfg bs lb - | None -> failwith "Could not find let binding" - end - | _ -> - debug (fun () -> BU.print1 "(1) qninfo is None for (%s)\n" (show fvar)); - mkFV fvar [] [] - end - else begin - debug (fun () -> BU.print1 "(1) qninfo is not visible at this level (%s)\n" (show fvar)); - mkFV fvar [] [] - end - in - cache_add cfg fvar t; - t - -(* translate a let-binding - local or global *) -and translate_letbinding (cfg:config) (bs:list t) (lb:letbinding) : t = - let debug = debug cfg in - let us = lb.lbunivs in - let formals, _ = U.arrow_formals lb.lbtyp in - let arity = List.length us + List.length formals in - if arity = 0 - then translate cfg bs lb.lbdef - else if BU.is_right lb.lbname - then let _ = debug (fun () -> BU.print2 "Making TopLevelLet for %s with arity %s\n" (show lb.lbname) (show arity)) in - mk_rt (S.range_of_lbname lb.lbname) <| TopLevelLet(lb, arity, []) - else translate cfg bs lb.lbdef //local let-binding, cannot be universe polymorphic - // Note, we only have universe polymorphic top-level pure terms (i.e., fvars bound to pure terms) - // Thunking them is probably okay, since the common case is really top-level function - // rather than top-level pure computation - - -and mkRec i (b:letbinding) (bs:list letbinding) (env:list t) = - let (ar, ar_lst) = let_rec_arity b in - mk_t <| LocalLetRec(i, b, bs, env, [], ar, ar_lst) - -(* Creates the environment of mutually recursive function definitions *) -and make_rec_env (all_lbs:list letbinding) (all_outer_bs:list t) : list t = - let rec_bindings = List.mapi (fun i lb -> mkRec i lb all_lbs all_outer_bs) all_lbs in - List.rev_append rec_bindings all_outer_bs - -and translate_constant (c : sconst) : constant = - match c with - | C.Const_unit -> Unit - | C.Const_bool b -> Bool b - | C.Const_int (s, None) -> Int (Z.big_int_of_string s) - | C.Const_string (s, r) -> String (s,r) - | C.Const_char c -> Char c - | C.Const_range r -> Range r - | C.Const_real r -> Real r - | _ -> SConst c - -and readback_comp cfg (c: comp) : S.comp = - let c' = - match c with - | Tot typ -> S.Total (readback cfg typ) - | GTot typ -> S.GTotal (readback cfg typ) - | Comp ctyp -> S.Comp (readback_comp_typ cfg ctyp) - in S.mk c' Range.dummyRange - -and translate_comp_typ cfg bs (c:S.comp_typ) : comp_typ = - let { S.comp_univs = comp_univs - ; S.effect_name = effect_name - ; S.result_typ = result_typ - ; S.effect_args = effect_args - ; S.flags = flags } = c in - { comp_univs = List.map (translate_univ cfg bs) comp_univs; - effect_name = effect_name; - result_typ = translate cfg bs result_typ; - effect_args = List.map (fun x -> translate cfg bs (fst x), snd x) effect_args; - flags = List.map (translate_flag cfg bs) flags } - -and readback_comp_typ cfg (c:comp_typ) : S.comp_typ = - { S.comp_univs = c.comp_univs; - S.effect_name = c.effect_name; - S.result_typ = readback cfg c.result_typ; - S.effect_args = List.map (fun x -> readback cfg (fst x), snd x) c.effect_args; - S.flags = List.map (readback_flag cfg) c.flags } - -and translate_residual_comp cfg bs (c:S.residual_comp) : residual_comp = - let { S.residual_effect = residual_effect - ; S.residual_typ = residual_typ - ; S.residual_flags = residual_flags } = c in - { residual_effect = residual_effect; - residual_typ = - (if cfg.core_cfg.steps.for_extraction - then None - else BU.map_opt residual_typ (translate cfg bs)); - residual_flags = List.map (translate_flag cfg bs) residual_flags } - -and readback_residual_comp cfg (c:residual_comp) : S.residual_comp = - { S.residual_effect = c.residual_effect; - S.residual_typ = BU.map_opt c.residual_typ (fun x -> debug cfg (fun () -> BU.print1 "Reading back residualtype %s\n" (t_to_string x)); readback cfg x); - S.residual_flags = List.map (readback_flag cfg) c.residual_flags } - -and translate_flag cfg bs (f : S.cflag) : cflag = - match f with - | S.TOTAL -> TOTAL - | S.MLEFFECT -> MLEFFECT - | S.RETURN -> RETURN - | S.PARTIAL_RETURN -> PARTIAL_RETURN - | S.SOMETRIVIAL -> SOMETRIVIAL - | S.TRIVIAL_POSTCONDITION -> TRIVIAL_POSTCONDITION - | S.SHOULD_NOT_INLINE -> SHOULD_NOT_INLINE - | S.LEMMA -> LEMMA - | S.CPS -> CPS - | S.DECREASES (S.Decreases_lex l) -> DECREASES_lex (l |> List.map (translate cfg bs)) - | S.DECREASES (S.Decreases_wf (rel, e)) -> - DECREASES_wf (translate cfg bs rel, translate cfg bs e) - -and readback_flag cfg (f : cflag) : S.cflag = - match f with - | TOTAL -> S.TOTAL - | MLEFFECT -> S.MLEFFECT - | RETURN -> S.RETURN - | PARTIAL_RETURN -> S.PARTIAL_RETURN - | SOMETRIVIAL -> S.SOMETRIVIAL - | TRIVIAL_POSTCONDITION -> S.TRIVIAL_POSTCONDITION - | SHOULD_NOT_INLINE -> S.SHOULD_NOT_INLINE - | LEMMA -> S.LEMMA - | CPS -> S.CPS - | DECREASES_lex l -> S.DECREASES (S.Decreases_lex (l |> List.map (readback cfg))) - | DECREASES_wf (rel, e) -> - S.DECREASES (S.Decreases_wf (readback cfg rel, readback cfg e)) - -and translate_monadic (m, ty) cfg bs e : t = - let e = U.unascribe e in - match e.n with - | Tm_let {lbs=(false, [lb]); body} -> //elaborate this to M.bind - begin - match Env.effect_decl_opt cfg.core_cfg.tcenv (Env.norm_eff_name cfg.core_cfg.tcenv m) with - | None -> - failwith (BU.format1 "Effect declaration not found: %s" (Ident.string_of_lid m)) - - | Some (ed, q) -> - let cfg' = reifying_false cfg in - let body_lam = - let body_rc = { - S.residual_effect=m; - S.residual_flags=[]; - S.residual_typ=Some ty - } in - S.mk (Tm_abs {bs=[S.mk_binder (BU.left lb.lbname)]; body; rc_opt=Some body_rc}) body.pos - in - let maybe_range_arg = - if BU.for_some (TEQ.eq_tm_bool cfg.core_cfg.tcenv U.dm4f_bind_range_attr) ed.eff_attrs - then [translate cfg [] (PO.embed_simple lb.lbpos lb.lbpos), None; - translate cfg [] (PO.embed_simple body.pos body.pos), None] - else [] - in - let t = - iapp cfg (iapp cfg (translate cfg' [] (U.un_uinst (ed |> U.get_bind_repr |> BU.must |> snd))) - [mk_t <| Univ U_unknown, None; //We are cheating here a bit - mk_t <| Univ U_unknown, None]) //to avoid re-computing the universe of lb.lbtyp - //and ty below; but this should be okay since these - //arguments should not actually appear in the resulting - //term - ( - [(translate cfg' bs lb.lbtyp, None); //translating the type of the bound term - (translate cfg' bs ty, None)] //and the body is sub-optimal; it is often unused - @maybe_range_arg //some effects take two additional range arguments for debugging - @[(mk_t Unknown, None) ; //unknown WP of lb.lbdef; same as the universe argument ... should not appear in the result - (translate cfg bs lb.lbdef, None); - (mk_t Unknown, None) ; //unknown WP of body; ditto - (translate cfg bs body_lam, None)] - ) - in - debug cfg (fun () -> BU.print1 "translate_monadic: %s\n" (t_to_string t)); - t - - end - - | Tm_app {hd={n=Tm_constant (FC.Const_reflect _)}; args=[(e, _)]} -> - translate (reifying_false cfg) bs e - - | Tm_app {hd=head; args} -> - debug cfg (fun () -> BU.print2 "translate_monadic app (%s) @ (%s)\n" (show head) - (show args)); - let fallback1 () = - translate cfg bs e - in - let fallback2 () = - translate (reifying_false cfg) bs (S.mk (Tm_meta {tm=e; meta=Meta_monadic (m, ty)}) e.pos) - in - begin match (U.un_uinst head).n with - | Tm_fvar fv -> - let lid = S.lid_of_fv fv in - let qninfo = Env.lookup_qname cfg.core_cfg.tcenv lid in - if not (Env.is_action cfg.core_cfg.tcenv lid) then fallback1 () else - - (* GM: I think the action *must* be fully applied at this stage - * since we were triggered into this function by a Meta_monadic - * annotation. So we don't check anything. *) - - (* Fallback if it does not have a definition. This happens, - * but I'm not sure why. *) - if Option.isNone (Env.lookup_definition_qninfo cfg.core_cfg.delta_level fv.fv_name.v qninfo) - then fallback2 () - else - - (* Turn it info (reify head) args, then translate_fv will kick in on the head *) - let e = S.mk_Tm_app (U.mk_reify head None) args e.pos in - translate (reifying_false cfg) bs e - | _ -> - fallback1 () - end - - | Tm_match {scrutinee=sc; ret_opt=asc_opt; brs=branches; rc_opt=lopt} -> - (* Commutation of reify with match. See the comment in the normalizer about it. *) - let branches = branches |> List.map (fun (pat, wopt, tm) -> pat, wopt, U.mk_reify tm (Some m)) in - let tm = S.mk (Tm_match {scrutinee=sc; ret_opt=asc_opt; brs=branches; rc_opt=lopt}) e.pos in - translate (reifying_false cfg) bs tm - - | Tm_meta {tm=t; meta=Meta_monadic _} -> - translate_monadic (m, ty) cfg bs e - - | Tm_meta {tm=t; meta=Meta_monadic_lift (msrc, mtgt, ty')} -> - translate_monadic_lift (msrc, mtgt, ty') cfg bs e - - | _ -> failwith (BU.format1 "Unexpected case in translate_monadic: %s" (tag_of e)) - -and translate_monadic_lift (msrc, mtgt, ty) cfg bs e : t = - let e = U.unascribe e in - if U.is_pure_effect msrc || U.is_div_effect msrc - then let ed = Env.get_effect_decl cfg.core_cfg.tcenv (Env.norm_eff_name cfg.core_cfg.tcenv mtgt) in - let ret = match (SS.compress (ed |> U.get_return_repr |> BU.must |> snd)).n with - | Tm_uinst (ret, [_]) -> S.mk (Tm_uinst (ret, [U_unknown])) e.pos - | _ -> failwith "NYI: Reification of indexed effect (NBE)" - in - let cfg' = reifying_false cfg in - let t = - iapp cfg' (iapp cfg' (translate cfg' [] ret) - [mk_t <| Univ U_unknown, None]) - [(translate cfg' bs ty, None); //translating the type of the returned term - (translate cfg' bs e, None)] //translating the returned term itself - in - debug cfg (fun () -> BU.print1 "translate_monadic_lift(1): %s\n" (t_to_string t)); - t - else - match Env.monad_leq cfg.core_cfg.tcenv msrc mtgt with - | None -> - failwith (BU.format2 "Impossible : trying to reify a lift between unrelated effects (%s and %s)" - (Ident.string_of_lid msrc) - (Ident.string_of_lid mtgt)) - | Some {mlift={mlift_term=None}} -> - failwith (BU.format2 "Impossible : trying to reify a non-reifiable lift (from %s to %s)" - (Ident.string_of_lid msrc) - (Ident.string_of_lid mtgt)) - - | Some {mlift={mlift_term=Some lift}} -> - (* We don't have any reasonable wp to provide so we just pass unknown *) - (* The wp is only necessary to typecheck, so this should not create an issue. *) - let lift_lam = - let x = S.new_bv None S.tun in - U.abs [S.mk_binder x] - (lift U_unknown ty (S.bv_to_name x)) - None - in - let cfg' = reifying_false cfg in - let t = - iapp cfg (translate cfg' [] lift_lam) - [(translate cfg bs e, None)] - in - debug cfg (fun () -> BU.print1 "translate_monadic_lift(2): %s\n" (t_to_string t)); - t - -/// `readback` is the other half of the main normalization routine -/// -/// Give a translated term `x:t` we read it back as a syntactic term. -/// -/// The cases where `x:t` is a fully reduced value of base type are -/// easy: We read each host language constant back as a syntactic -/// constant -/// -/// The main work is when we read back terms with binders, e.g., -/// lambdas, unreduced matches, etc. -/// -/// In each of these cases, readback descends under the binder, and -/// recursively normalizes the term (i.e., translates and reads back) -/// in an extended context with a fresh name in scope. -and readback (cfg:config) (x:t) : term = - let debug = debug cfg in - let readback_args cfg args = - map_rev (fun (x, q) -> (readback cfg x, q)) args - in - let with_range t = { t with pos = x.nbe_r } in - let mk t = S.mk t x.nbe_r in - debug (fun () -> BU.print1 "Readback: %s\n" (t_to_string x)); - match x.nbe_t with - | Univ u -> failwith "Readback of universes should not occur" - - | Unknown -> S.mk Tm_unknown x.nbe_r - - | Constant Unit -> with_range S.unit_const - | Constant (Bool true) -> with_range U.exp_true_bool - | Constant (Bool false) -> with_range U.exp_false_bool - | Constant (Int i) -> with_range (U.exp_int (Z.string_of_big_int i)) - | Constant (String (s, r)) -> mk (S.Tm_constant (C.Const_string (s, r))) - | Constant (Char c) -> with_range (U.exp_char c) - | Constant (Range r) -> PO.embed_simple #_ #EMB.e___range x.nbe_r r - | Constant (Real r) -> PO.embed_simple x.nbe_r (Compiler.Real.Real r) - | Constant (SConst c) -> mk (S.Tm_constant c) - - | Meta(t, m) -> - mk (S.Tm_meta {tm=readback cfg t; meta=Thunk.force m}) - - | Type_t u -> - mk (Tm_type u) - - | Lam {interp=f; shape; arity} -> - begin match shape with - | Lam_bs (ctx, binders, rc) -> - let ctx, binders_rev, accus_rev = - List.fold_left - (fun (ctx, binders_rev, accus_rev) b -> - let x = b.binder_bv in - let tnorm = readback cfg (translate cfg ctx x.sort) in - let x = { S.freshen_bv x with sort = tnorm } in - let ax = mkAccuVar x in - let ctx = ax :: ctx in - ctx, ({b with binder_bv=x})::binders_rev, (ax, U.aqual_of_binder b)::accus_rev) - (ctx, [], []) - binders - in - let rc = - match rc with - | None -> None - | Some rc -> - Some (readback_residual_comp cfg (translate_residual_comp cfg ctx rc)) - in - let binders = List.rev binders_rev in - let body = readback cfg (f accus_rev) in - with_range (U.abs binders body rc) - - | Lam_args args -> - let binders, accus_rev = - List.fold_right - (fun (t, aq) (binders, accus) -> - let bqual, battrs = U.bqual_and_attrs_of_aqual aq in - let pqual, battrs = U.parse_positivity_attributes battrs in - let x = S.new_bv None (readback cfg t) in - (S.mk_binder_with_attrs x bqual pqual battrs)::binders, - (mkAccuVar x, aq) :: accus) - args - ([], []) - in - let accus = List.rev accus_rev in - let rc = None in - let body = readback cfg (f accus_rev) in - with_range (U.abs binders body rc) - - | Lam_primop (fv, args) -> - let body = U.mk_app (S.mk (Tm_fvar fv) (S.range_of_fv fv)) (readback_args cfg args) in - with_range body - end - - | Refinement (f, targ) -> - if cfg.core_cfg.steps.for_extraction - then readback cfg (fst (targ ())) - else - let x = S.new_bv None (readback cfg (fst (targ ()))) in - let body = readback cfg (f (mkAccuVar x)) in - let refinement = U.refine x body in - with_range ( - if cfg.core_cfg.steps.simplify - then TEQ.simplify cfg.core_cfg.debug.wpe cfg.core_cfg.tcenv refinement - else refinement - ) - - | Reflect t -> - let tm = readback cfg t in - with_range (U.mk_reflect tm) - - | Arrow (Inl f) -> - with_range (Thunk.force f) - - | Arrow (Inr (args, c)) -> - let binders = - List.map - (fun (t, q) -> - let t = readback cfg t in - let x = S.new_bv None t in - let q, attrs = U.bqual_and_attrs_of_aqual q in - let pqual, attrs = U.parse_positivity_attributes attrs in - S.mk_binder_with_attrs x q pqual attrs) - args - in - let c = readback_comp cfg c in - with_range (U.arrow binders c) - - | Construct (fv, us, args) -> - let args = map_rev (fun (x, q) -> (readback cfg x, q)) args in - let fv = S.mk (Tm_fvar fv) (S.range_of_fv fv) in - let app = U.mk_app (S.mk_Tm_uinst fv (List.rev us)) args in - with_range (app) - - | FV (fv, us, args) -> - let args = map_rev (fun (x, q) -> (readback cfg x, q)) args in - let fv = S.mk (Tm_fvar fv) Range.dummyRange in - let app = U.mk_app (S.mk_Tm_uinst fv (List.rev us)) args in - with_range ( - if cfg.core_cfg.steps.simplify - then TEQ.simplify cfg.core_cfg.debug.wpe cfg.core_cfg.tcenv app - else app - ) - - | Accu (Var bv, []) -> - with_range (S.bv_to_name bv) - - | Accu (Var bv, args) -> - let args = readback_args cfg args in - let app = U.mk_app (S.bv_to_name bv) args in - with_range ( - if cfg.core_cfg.steps.simplify - then TEQ.simplify cfg.core_cfg.debug.wpe cfg.core_cfg.tcenv app - else app - ) - - | Accu (Match (scrut, make_returns, make_branches, make_rc), args) -> - let args = readback_args cfg args in - let head = - let scrut_new = readback cfg scrut in - let returns_new = make_returns () in - let branches_new = make_branches () in - let rc_new = make_rc () in - S.mk (Tm_match {scrutinee=scrut_new; - ret_opt=returns_new; - brs=branches_new; - rc_opt=rc_new}) scrut.nbe_r - in - (* When `cases scrut` returns a Accu(Match ..)) - we need to reconstruct a source match node. - - To do this, we need to decorate that Match node with the - patterns in each branch. - - e.g., Consider this source node: - - (match x with - | Inl (a:ta) -> e1eenv - | Inr (b:tb) -> e2) - - Match([[x]], - (cases: t -> t), - (patterns:[Inl (a:ta); Inr (b:tb)])) - - let branches = - map (fun v -> v, readback (cases (translate v))) - patterns - in - match (readback [[x]]) - branches - *) - let app = U.mk_app head args in - with_range ( - if cfg.core_cfg.steps.simplify - then TEQ.simplify cfg.core_cfg.debug.wpe cfg.core_cfg.tcenv app - else app - ) - - | Accu(UnreducedLet (var, typ, defn, body, lb), args) -> - let typ = readback cfg (Thunk.force typ) in - let defn = readback cfg (Thunk.force defn) in - let body = SS.close [S.mk_binder var] (readback cfg (Thunk.force body)) in - let lbname = Inl ({ BU.left lb.lbname with sort = typ }) in - let lb = { lb with lbname = lbname; lbtyp = typ; lbdef = defn } in - let hd = S.mk (Tm_let {lbs=(false, [lb]); body}) Range.dummyRange in - let args = readback_args cfg args in - with_range (U.mk_app hd args) - - | Accu(UnreducedLetRec (vars_typs_defns, body, lbs), args) -> - let lbs = - List.map2 - (fun (v,t,d) lb -> - let t = readback cfg t in - let def = readback cfg d in - let v = {v with sort = t} in - {lb with lbname = Inl v; - lbtyp = t; - lbdef = def}) - vars_typs_defns - lbs - in - let body = readback cfg body in - let lbs, body = SS.close_let_rec lbs body in - let hd = S.mk (Tm_let {lbs=(true, lbs); body}) Range.dummyRange in - let args = readback_args cfg args in - with_range (U.mk_app hd args) - - | Accu(UVar f, args) -> - let hd = Thunk.force f in - let args = readback_args cfg args in - with_range (U.mk_app hd args) - - | TopLevelLet(lb, arity, args_rev) -> - let n_univs = List.length lb.lbunivs in - let n_args = List.length args_rev in - let args_rev, univs = BU.first_N (n_args - n_univs) args_rev in - readback cfg (iapp cfg (translate cfg (List.map fst univs) lb.lbdef) (List.rev args_rev)) - - | TopLevelRec(lb, _, _, args) -> - let fv = BU.right lb.lbname in - let head = S.mk (Tm_fvar fv) Range.dummyRange in - let args = List.map (fun (t, q) -> readback cfg t, q) args in - with_range (U.mk_app head args) - - | LocalLetRec(i, _, lbs, bs, args, _ar, _ar_lst) -> - (* if this point is reached then the local let rec is unreduced - and we have to read it back as a let rec. - - The idea is to read it back as a ` - ``` - (let rec f0 = e0 - and ... fn = en - in fi) args - ``` - where `e0 ... en` are the normalized bodies of - each arm of the mutually recursive nest, reduced in - context where all the mutually recursive definitions - are just fresh symbolic variables - (so, reducing the e_i will not trigger further - recursive reductions of th f0..fn) - *) - //1. generate fresh symbolic names for the let recs - let lbnames = - List.map (fun lb -> S.gen_bv (Ident.string_of_id (BU.left lb.lbname).ppname) None lb.lbtyp) lbs - in - //2. these names are in scope for all the bodies - // together with whatever other names (bs) that - // are in scope at this point - let let_rec_env = - List.rev_append (List.map (fun x -> mk_rt (S.range_of_bv x) (Accu (Var x, []))) lbnames) bs - in - //3. Reduce each e_i, both its definition (in the rec env) - // and its type, which doesn't have the recursive names in scope - let lbs = - List.map2 - (fun lb lbname -> - let lbdef = readback cfg (translate cfg let_rec_env lb.lbdef) in - let lbtyp = readback cfg (translate cfg bs lb.lbtyp) in - {lb with - lbname = Inl lbname; - lbdef = lbdef; - lbtyp = lbtyp}) - lbs - lbnames - in - //4. Set the body of let rec ... in ... - // to be the name chosen for the ith let rec, the one - // referred to in the LocalLetRec - let body = S.bv_to_name (List.nth lbnames i) in - //5. close everything to switch back to locally nameless - let lbs, body = FStar.Syntax.Subst.close_let_rec lbs body in - //6. Build the head term - let head = S.mk (Tm_let {lbs=(true, lbs); body}) Range.dummyRange in - //7. Readback the arguments and apply it to the head - let args = List.map (fun (x, q) -> readback cfg x, q) args in - with_range (U.mk_app head args) - - | Quote (qt, qi) -> - mk (Tm_quoted (qt, qi)) - - // Need this case for "cheat" embeddings - | Lazy (Inl li, _) -> - mk (Tm_lazy li) - - | Lazy (_, thunk) -> - readback cfg (Thunk.force thunk) - -let reduce_application cfg t args = - iapp (new_config cfg) t args - -let normalize psteps (steps:list Env.step) - (env : Env.env) (e:term) : term = - let cfg = Cfg.config' psteps steps env in - //debug_sigmap env.sigtab; - let cfg = {cfg with steps={cfg.steps with reify_=true}} in - if !dbg_NBETop || !dbg_NBE - then BU.print1 "Calling NBE with (%s) {\n" (show e); - let cfg = new_config cfg in - let r = readback cfg (translate cfg [] e) in - if !dbg_NBETop || !dbg_NBE - then BU.print1 "}\nNBE returned (%s)\n" (show r); - r - -(* ONLY FOR UNIT TESTS! *) -let normalize_for_unit_test (steps:list Env.step) (env : Env.env) (e:term) : term = - let cfg = Cfg.config steps env in - //debug_sigmap env.sigtab; - let cfg = {cfg with steps={cfg.steps with reify_=true}} in - let cfg = new_config cfg in - debug cfg (fun () -> BU.print1 "Calling NBE with (%s) {\n" (show e)); - let r = readback cfg (translate cfg [] e) in - debug cfg (fun () -> BU.print1 "}\nNBE returned (%s)\n" (show r)); - r diff --git a/src/typechecker/FStar.TypeChecker.NBE.fsti b/src/typechecker/FStar.TypeChecker.NBE.fsti deleted file mode 100644 index 8e5862a4e89..00000000000 --- a/src/typechecker/FStar.TypeChecker.NBE.fsti +++ /dev/null @@ -1,42 +0,0 @@ -(* - Copyright 2017-2019 Microsoft Research - - Authors: Zoe Paraskevopoulou, Guido Martinez, Nikhil Swamy - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.TypeChecker.NBE -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar -open FStar.Compiler -open FStar.TypeChecker -open FStar.TypeChecker.Env -open FStar.Syntax.Syntax -open FStar.Ident -open FStar.Errors -open FStar.TypeChecker.Normalize -open FStar.TypeChecker.NBETerm -module Cfg = FStar.TypeChecker.Cfg -module PO = FStar.TypeChecker.Primops - -val normalize_for_unit_test : steps:list Env.step - -> env : Env.env - -> e:term - -> term - -val normalize : list PO.primitive_step - -> list Env.step - -> Env.env - -> term - -> term diff --git a/src/typechecker/FStar.TypeChecker.NBETerm.fst b/src/typechecker/FStar.TypeChecker.NBETerm.fst deleted file mode 100644 index 6b920a6ad4b..00000000000 --- a/src/typechecker/FStar.TypeChecker.NBETerm.fst +++ /dev/null @@ -1,938 +0,0 @@ -(* - Copyright 2017-2019 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.TypeChecker.NBETerm -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Syntax.Syntax -open FStar.Errors -open FStar.Char -open FStar.String - -friend FStar.Pervasives (* To expose norm_step *) - -module PC = FStar.Parser.Const -module S = FStar.Syntax.Syntax -module P = FStar.Syntax.Print -module BU = FStar.Compiler.Util -module C = FStar.Const -module SE = FStar.Syntax.Embeddings -module TEQ = FStar.TypeChecker.TermEqAndSimplify - -open FStar.VConfig - -open FStar.Class.Show - -// NBE term manipulation - -(**** NOTE: Don't say I didn't warn you! ***) -(* FV and Construct accumulate arguments *in reverse order*. - * Therefore the embeddings must be aware of this and match/construct - * them properly - * - * For example, this is how we embed/unembed an `option a`: - * - embed: - match o with - | Some x -> - lid_as_constr PC.some_lid [U_zero] [as_arg (embed ea cb x); as_iarg (type_of ea)] - - unembed: - match t with - | Construct (fvar, us, [(a, _); _]) when S.fv_eq_lid fvar PC.some_lid - BU.bind_opt (unembed ea cb a) (fun a -> Some (Some a)) - * - * Note how the implicit argument is seemingly *after* the explicit one. - *) -let interleave_hack = 123 - -let isAccu (trm:t) = -match trm.nbe_t with -| Accu _ -> true -| _ -> false - -let isNotAccu (x:t) = -match x.nbe_t with -| Accu (_, _) -> false -| _ -> true - -let mk_rt r t = { nbe_t = t; nbe_r = r } -let mk_t t = mk_rt Range.dummyRange t -let nbe_t_of_t t = t.nbe_t -let mkConstruct i us ts = mk_t <| Construct(i, us, ts) -let mkFV i us ts = mk_rt (S.range_of_fv i) (FV(i, us, ts)) - -let mkAccuVar (v:var) = mk_rt (S.range_of_bv v) (Accu(Var v, [])) -let mkAccuMatch (s:t) (ret:(unit -> option match_returns_ascription)) (bs:(unit -> list branch)) - (rc:unit -> option S.residual_comp) = - mk_t <| Accu(Match (s, ret, bs, rc), []) - -// Term equality - -let equal_if = function - | true -> TEQ.Equal - | _ -> TEQ.Unknown - -let equal_iff = function - | true -> TEQ.Equal - | _ -> TEQ.NotEqual - -let eq_inj r1 r2 = - match r1, r2 with - | TEQ.Equal, TEQ.Equal -> TEQ.Equal - | TEQ.NotEqual, _ - | _, TEQ.NotEqual -> TEQ.NotEqual - | TEQ.Unknown, _ - | _, TEQ.Unknown -> TEQ.Unknown - -let eq_and f g = - match f with - | TEQ.Equal -> g() - | _ -> TEQ.Unknown - -let eq_constant (c1 : constant) (c2 : constant) = -match c1, c2 with -| Unit, Unit -> TEQ.Equal -| Bool b1, Bool b2 -> equal_iff (b1 = b2) -| Int i1, Int i2 -> equal_iff (i1 = i2) -| String (s1, _), String (s2, _) -> equal_iff (s1 = s2) -| Char c1, Char c2 -> equal_iff (c1 = c2) -| Range r1, Range r2 -> TEQ.Unknown (* Seems that ranges are opaque *) -| Real r1, Real r2 -> equal_if (r1 = r2) (* conservative, cannot use iff since strings could be 1.0 and 01.0 *) -| _, _ -> TEQ.NotEqual - - -let rec eq_t env (t1 : t) (t2 : t) : TEQ.eq_result = - match t1.nbe_t, t2.nbe_t with - | Lam _, Lam _ -> TEQ.Unknown - | Accu(a1, as1), Accu(a2, as2) -> eq_and (eq_atom a1 a2) (fun () -> eq_args env as1 as2) - | Construct(v1, us1, args1), Construct(v2, us2, args2) -> - if S.fv_eq v1 v2 then begin - if List.length args1 <> List.length args2 then - failwith "eq_t, different number of args on Construct"; - match Env.num_datacon_non_injective_ty_params env (lid_of_fv v1) with - | None -> TEQ.Unknown - | Some n -> - if n <= List.length args1 - then ( - let eq_args as1 as2 = - List.fold_left2 - (fun acc (a1, _) (a2, _) -> eq_inj acc (eq_t env a1 a2)) - TEQ.Equal - as1 as2 - in - let parms1, args1 = List.splitAt n args1 in - let parms2, args2 = List.splitAt n args2 in - eq_args args1 args2 - ) - else TEQ.Unknown - end else TEQ.NotEqual - - | FV(v1, us1, args1), FV(v2, us2, args2) -> - if S.fv_eq v1 v2 then - eq_and (equal_iff (U.eq_univs_list us1 us2)) (fun () -> eq_args env args1 args2) - else TEQ.Unknown - - | Constant c1, Constant c2 -> eq_constant c1 c2 - | Type_t u1, Type_t u2 - | Univ u1, Univ u2 -> equal_iff (U.eq_univs u1 u2) - | Refinement(r1, t1), Refinement(r2, t2) -> - let x = S.new_bv None S.t_unit in (* bogus type *) - eq_and (eq_t env (fst (t1 ())) (fst (t2 ()))) (fun () -> eq_t env (r1 (mkAccuVar x)) (r2 (mkAccuVar x))) - | Unknown, Unknown -> TEQ.Equal - | _, _ -> TEQ.Unknown (* XXX following eq_tm *) - -and eq_atom (a1 : atom) (a2 : atom) : TEQ.eq_result = - match a1, a2 with - | Var bv1, Var bv2 -> equal_if (bv_eq bv1 bv2) (* ZP : TODO if or iff?? *) - | _, _ -> TEQ.Unknown (* XXX Cannot compare suspended matches (?) *) - -and eq_arg env (a1 : arg) (a2 : arg) = eq_t env (fst a1) (fst a2) -and eq_args env (as1 : args) (as2 : args) : TEQ.eq_result = - match as1, as2 with - | [], [] -> TEQ.Equal - | x :: xs, y :: ys -> eq_and (eq_arg env x y) (fun () -> eq_args env xs ys) - | _, _ -> TEQ.Unknown (* ZP: following tm_eq, but why not TEQ.NotEqual? *) - - -// Printing functions - -let constant_to_string (c: constant) = - match c with - | Unit -> "Unit" - | Bool b -> if b then "Bool true" else "Bool false" - | Int i -> Z.string_of_big_int i - | Char c -> BU.format1 "'%s'" (BU.string_of_char c) - | String (s, _) -> BU.format1 "\"%s\"" s - | Range r -> BU.format1 "Range %s" (Range.string_of_range r) - | SConst s -> show s - | Real s -> BU.format1 "Real %s" s - -let rec t_to_string (x:t) = - match x.nbe_t with - | Lam {interp=b; arity} -> BU.format1 "Lam (_, %s args)" (BU.string_of_int arity) - | Accu (a, l) -> - "Accu (" ^ (atom_to_string a) ^ ") (" ^ - (String.concat "; " (List.map (fun x -> t_to_string (fst x)) l)) ^ ")" - | Construct (fv, us, l) -> - "Construct (" ^ (show fv) ^ ") [" ^ - (String.concat "; "(List.map show us)) ^ "] [" ^ - (String.concat "; " (List.map (fun x -> t_to_string (fst x)) l)) ^ "]" - | FV (fv, us, l) -> - "FV (" ^ (show fv) ^ ") [" ^ - (String.concat "; "(List.map show us)) ^ "] [" ^ - (String.concat "; " (List.map (fun x -> t_to_string (fst x)) l)) ^ "]" - | Constant c -> constant_to_string c - | Univ u -> "Universe " ^ (show u) - | Type_t u -> "Type_t " ^ (show u) - | Arrow _ -> "Arrow" // TODO : revisit - | Refinement (f, t) -> - let x = S.new_bv None S.t_unit in (* bogus type *) - let t = fst (t ()) in - "Refinement " ^ (show x) ^ ":" ^ (t_to_string t) ^ "{" ^ (t_to_string (f (mkAccuVar x))) ^ "}" - | Unknown -> "Unknown" - | Reflect t -> "Reflect " ^ t_to_string t - | Quote _ -> "Quote _" - | Lazy (Inl li, _) -> BU.format1 "Lazy (Inl {%s})" (show (U.unfold_lazy li)) - | Lazy (Inr (_, et), _) -> BU.format1 "Lazy (Inr (?, %s))" (show et) - | LocalLetRec (_, l, _, _, _, _, _) -> "LocalLetRec (" ^ (show (true, [l])) ^ ")" - | TopLevelLet (lb, _, _) -> "TopLevelLet (" ^ show (BU.right lb.lbname) ^ ")" - | TopLevelRec (lb, _, _, _) -> "TopLevelRec (" ^ show (BU.right lb.lbname) ^ ")" - | Meta (t, _) -> "Meta " ^ t_to_string t -and atom_to_string (a: atom) = - match a with - | Var v -> "Var " ^ (show v) - | Match (t, _, _, _) -> "Match " ^ (t_to_string t) - | UnreducedLet (var, typ, def, body, lb) -> "UnreducedLet(" ^ (show (false, [lb])) ^ " in ...)" - | UnreducedLetRec (_, body, lbs) -> "UnreducedLetRec(" ^ (show (true, lbs)) ^ " in " ^ (t_to_string body) ^ ")" - | UVar _ -> "UVar" - -let arg_to_string (a : arg) = a |> fst |> t_to_string - -let args_to_string args = args |> List.map arg_to_string |> String.concat " " - -instance showable_t = { - show = t_to_string; -} -instance showable_args = { - show = args_to_string; -} - -// Embedding and de-embedding - -let iapp_cb cbs h a = cbs.iapp h a -let translate_cb cbs t = cbs.translate t - -let embed (#a:Type0) (e:embedding a) (cb:nbe_cbs) (x:a) : t = e.em cb x -let unembed (#a:Type0) (e:embedding a) (cb:nbe_cbs) (trm:t) : option a = e.un cb trm - -let type_of (e:embedding 'a) : t = e.typ () -let set_type (ty:t) (e:embedding 'a) : embedding 'a = { e with typ = (fun () -> ty) } - - -let mk_emb em un typ et = {em = em; un = un; typ = typ; e_typ=et} -let mk_emb' em un = mk_emb (fun cbs t -> mk_t <| em cbs t) (fun cbs t -> un cbs t.nbe_t) - - -let embed_as (ea:embedding 'a) - (ab : 'a -> 'b) - (ba : 'b -> 'a) - (ot:option t) - : embedding 'b - = mk_emb (fun cbs (x:'b) -> embed ea cbs (ba x)) - (fun cbs t -> BU.map_opt (unembed ea cbs t) ab) - (fun () -> match ot with | Some t -> t | None -> ea.typ ()) - ea.e_typ - -let lid_as_constr (l:lident) (us:list universe) (args:args) : t = - mkConstruct (lid_as_fv l (Some Data_ctor)) us args - -let lid_as_typ (l:lident) (us:list universe) (args:args) : t = - mkFV (lid_as_fv l None) us args - -let as_iarg (a:t) : arg = (a, S.as_aqual_implicit true) -let as_arg (a:t) : arg = (a, None) - -// Non-dependent total arrow -let make_arrow1 t1 (a:arg) : t = mk_t <| Arrow (Inr ([a], Tot t1)) - -let lazy_embed (et:unit -> emb_typ) (x:'a) (f:unit -> t) = - if !Options.debug_embedding - then BU.print1 "Embedding\n\temb_typ=%s\n" - (show (et ())); - if !Options.eager_embedding - then f() - else let thunk = Thunk.mk f in - let li = FStar.Dyn.mkdyn x, et () in - mk_t <| Lazy (Inr li, thunk) - -let lazy_unembed (et:unit -> emb_typ) (x:t) (f:t -> option 'a) : option 'a = - match x.nbe_t with - | Lazy (Inl li, thunk) -> - f (Thunk.force thunk) - - | Lazy (Inr (b, et'), thunk) -> - if et () <> et' - || !Options.eager_embedding - then let res = f (Thunk.force thunk) in - let _ = if !Options.debug_embedding - then BU.print2 "Unembed cancellation failed\n\t%s <> %s\n" - (show (et ())) - (show et') - in - res - else let a = FStar.Dyn.undyn b in - let _ = if !Options.debug_embedding - then BU.print1 "Unembed cancelled for %s\n" - (show (et ())) - in - Some a - | _ -> - let aopt = f x in - let _ = if !Options.debug_embedding - then BU.print1 "Unembedding:\n\temb_typ=%s\n" - (show (et ())) in - aopt - -let lazy_unembed_lazy_kind (#a:Type) (k:lazy_kind) (x:t) : option a = - match x.nbe_t with - | Lazy (Inl li, _) -> - if li.lkind = k - then Some (FStar.Dyn.undyn li.blob) - else None - | _ -> None - -// Emdebbing for polymorphic types -let mk_any_emb (ty:t) : embedding t = - let em = (fun _cb a -> a) in - let un = (fun _cb t -> Some t) in - mk_emb em un (fun () -> ty) (fun () -> ET_abstract) - -// Emdebbing at abstract types -let e_any : embedding t = - let em = (fun _cb a -> a) in - let un = (fun _cb t -> Some t) in - mk_emb em un (fun () -> lid_as_typ PC.term_lid [] []) (fun () -> ET_abstract) - -// Emdebbing at type unit -let e_unit : embedding unit = - let em _cb a = Constant Unit in - let un _cb t = Some () in // No runtime typecheck here - mk_emb' em un (fun () -> lid_as_typ PC.unit_lid [] []) (SE.emb_typ_of unit) - -// Embedding at type bool -let e_bool : embedding bool = - let em _cb a = Constant (Bool a) in - let un _cb t = - match t with - | Constant (Bool a) -> Some a - | _ -> None - in - mk_emb' em un (fun () -> lid_as_typ PC.bool_lid [] []) (SE.emb_typ_of bool) - -// Embeddind at type char -let e_char : embedding char = - let em _cb c = Constant (Char c) in - let un _cb c = - match c with - | Constant (Char a) -> Some a - | _ -> None - in - mk_emb' em un (fun () -> lid_as_typ PC.char_lid [] []) (SE.emb_typ_of char) - -// Embeddind at type string -let e_string : embedding string = - let em _cb s = Constant (String (s, Range.dummyRange)) in - let un _cb s = - match s with - | Constant (String (s, _)) -> Some s - | _ -> None - in - mk_emb' em un (fun () -> lid_as_typ PC.string_lid [] []) (SE.emb_typ_of string) - -// Embeddind at type int -let e_int : embedding Z.t = - let em _cb c = Constant (Int c) in - let un _cb c = - match c with - | Constant (Int a) -> Some a - | _ -> None - in - mk_emb' em un (fun () -> lid_as_typ PC.int_lid [] []) (SE.emb_typ_of int) - -let e_real : embedding Compiler.Real.real = - let em _cb (Compiler.Real.Real c) = Constant (Real c) in - let un _cb c = - match c with - | Constant (Real a) -> Some (Compiler.Real.Real a) - | _ -> None - in - mk_emb' em un (fun () -> lid_as_typ PC.real_lid [] []) (SE.emb_typ_of Compiler.Real.real) - -let e_fsint = embed_as e_int Z.to_int_fs Z.of_int_fs None - -// Embedding at option type -let e_option (ea : embedding 'a) : Prims.Tot _ = - let etyp () = - ET_app(PC.option_lid |> Ident.string_of_lid, [ea.e_typ ()]) - in - let em cb (o:option 'a) : t = - lazy_embed etyp o (fun () -> - match o with - | None -> - lid_as_constr PC.none_lid [U_zero] [as_iarg (type_of ea)] - | Some x -> - lid_as_constr PC.some_lid [U_zero] [as_arg (embed ea cb x); - as_iarg (type_of ea)]) - in - let un cb (trm:t) : option (option 'a) = - lazy_unembed etyp trm (fun trm -> - match trm.nbe_t with - | Construct (fvar, us, args) when S.fv_eq_lid fvar PC.none_lid -> - Some None - | Construct (fvar, us, [(a, _); _]) when S.fv_eq_lid fvar PC.some_lid -> - BU.bind_opt (unembed ea cb a) (fun a -> Some (Some a)) - | _ -> None) - in - mk_emb em un (fun () -> lid_as_typ PC.option_lid [U_zero] [as_arg (type_of ea)]) etyp - - -// Emdedding tuples -let e_tuple2 (ea:embedding 'a) (eb:embedding 'b) = - let etyp () = - ET_app(PC.lid_tuple2 |> Ident.string_of_lid, [ea.e_typ (); eb.e_typ ()]) - in - let em cb (x:'a & 'b) : t = - lazy_embed etyp x (fun () -> - lid_as_constr (PC.lid_Mktuple2) - [U_zero; U_zero] - [as_arg (embed eb cb (snd x)); - as_arg (embed ea cb (fst x)); - as_iarg (type_of eb); - as_iarg (type_of ea)]) - in - let un cb (trm:t) : option ('a & 'b) = - lazy_unembed etyp trm (fun trm -> - match trm.nbe_t with - | Construct (fvar, us, [(b, _); (a, _); _; _]) when S.fv_eq_lid fvar PC.lid_Mktuple2 -> - let open FStar.Class.Monad in - let! a = unembed ea cb a in - let! b = unembed eb cb b in - Some (a, b) - | _ -> None) - in - mk_emb em un - (fun () -> lid_as_typ PC.lid_tuple2 [U_zero;U_zero] [as_arg (type_of eb); as_arg (type_of ea)]) - etyp - -let e_tuple3 (ea:embedding 'a) (eb:embedding 'b) (ec:embedding 'c) = - let etyp () = - ET_app(PC.lid_tuple3 |> Ident.string_of_lid, [ea.e_typ (); eb.e_typ (); ec.e_typ ()]) - in - let em cb ((x1, x2, x3):('a & 'b & 'c)) : t = - lazy_embed etyp (x1, x2, x3) (fun () -> - lid_as_constr (PC.lid_Mktuple3) - [U_zero; U_zero; U_zero] - [as_arg (embed ec cb x3); - as_arg (embed eb cb x2); - as_arg (embed ea cb x1); - as_iarg (type_of ec); - as_iarg (type_of eb); - as_iarg (type_of ea)]) - in - let un cb (trm:t) : option ('a & 'b & 'c) = - lazy_unembed etyp trm (fun trm -> - match trm.nbe_t with - | Construct (fvar, us, [(c, _); (b, _); (a, _); _; _; _]) when S.fv_eq_lid fvar PC.lid_Mktuple3 -> - let open FStar.Class.Monad in - let! a = unembed ea cb a in - let! b = unembed eb cb b in - let! c = unembed ec cb c in - Some (a, b, c) - | _ -> None) - in - mk_emb em un (fun () -> lid_as_typ PC.lid_tuple3 [U_zero;U_zero;U_zero] [as_arg (type_of ec); as_arg (type_of eb); as_arg (type_of ea)]) etyp - -let e_tuple4 (ea:embedding 'a) (eb:embedding 'b) (ec:embedding 'c) (ed:embedding 'd) = - let etyp () = - ET_app(PC.lid_tuple4 |> Ident.string_of_lid, [ea.e_typ (); eb.e_typ (); ec.e_typ (); ed.e_typ ()]) - in - let em cb (x1, x2, x3, x4) : t = - lazy_embed etyp (x1, x2, x3, x4) (fun () -> - lid_as_constr (PC.lid_Mktuple4) - [U_zero; U_zero; U_zero; U_zero] - [as_arg (embed ed cb x4); - as_arg (embed ec cb x3); - as_arg (embed eb cb x2); - as_arg (embed ea cb x1); - as_iarg (type_of ed); - as_iarg (type_of ec); - as_iarg (type_of eb); - as_iarg (type_of ea)]) - in - let un cb (trm:t) : option ('a & 'b & 'c & 'd) = - lazy_unembed etyp trm (fun trm -> - match trm.nbe_t with - | Construct (fvar, us, [(d, _); (c, _); (b, _); (a, _); _; _; _; _]) when S.fv_eq_lid fvar PC.lid_Mktuple4 -> - let open FStar.Class.Monad in - let! a = unembed ea cb a in - let! b = unembed eb cb b in - let! c = unembed ec cb c in - let! d = unembed ed cb d in - Some (a, b, c, d) - | _ -> None) - in - mk_emb em un (fun () -> lid_as_typ PC.lid_tuple4 [U_zero;U_zero;U_zero;U_zero] [as_arg (type_of ed); as_arg (type_of ec); as_arg (type_of eb); as_arg (type_of ea)]) etyp - -let e_tuple5 (ea:embedding 'a) (eb:embedding 'b) (ec:embedding 'c) (ed:embedding 'd) (ee:embedding 'e) = - let etyp () = - ET_app(PC.lid_tuple5 |> Ident.string_of_lid, [ea.e_typ (); eb.e_typ (); ec.e_typ (); ed.e_typ (); ee.e_typ ()]) - in - let em cb (x1, x2, x3, x4, x5) : t = - lazy_embed etyp (x1, x2, x3, x4, x5) (fun () -> - lid_as_constr (PC.lid_Mktuple5) - [U_zero; U_zero; U_zero; U_zero;U_zero] - [as_arg (embed ee cb x5); - as_arg (embed ed cb x4); - as_arg (embed ec cb x3); - as_arg (embed eb cb x2); - as_arg (embed ea cb x1); - as_iarg (type_of ee); - as_iarg (type_of ed); - as_iarg (type_of ec); - as_iarg (type_of eb); - as_iarg (type_of ea)]) - in - let un cb (trm:t) : option ('a & 'b & 'c & 'd & 'e) = - lazy_unembed etyp trm (fun trm -> - match trm.nbe_t with - | Construct (fvar, us, [(e, _); (d, _); (c, _); (b, _); (a, _); _; _; _; _; _]) when S.fv_eq_lid fvar PC.lid_Mktuple5 -> - let open FStar.Class.Monad in - let! a = unembed ea cb a in - let! b = unembed eb cb b in - let! c = unembed ec cb c in - let! d = unembed ed cb d in - let! e = unembed ee cb e in - Some (a, b, c, d, e) - | _ -> None) - in - mk_emb em un - (fun () -> lid_as_typ PC.lid_tuple5 [U_zero;U_zero;U_zero;U_zero;U_zero] [as_arg (type_of ee); as_arg (type_of ed); as_arg (type_of ec); as_arg (type_of eb); as_arg (type_of ea)]) - etyp - -let e_either (ea:embedding 'a) (eb:embedding 'b) = - let etyp () = - ET_app(PC.either_lid |> Ident.string_of_lid, [ea.e_typ (); eb.e_typ ()]) - in - let em cb (s:either 'a 'b) : t = - lazy_embed etyp s (fun () -> - match s with - | Inl a -> - lid_as_constr (PC.inl_lid) - [U_zero; U_zero] - [as_arg (embed ea cb a); - as_iarg (type_of eb); - as_iarg (type_of ea)] - | Inr b -> - lid_as_constr (PC.inr_lid) - [U_zero; U_zero] - [as_arg (embed eb cb b); - as_iarg (type_of eb); - as_iarg (type_of ea)]) - in - let un cb (trm:t) : option (either 'a 'b) = - lazy_unembed etyp trm (fun trm -> - match trm.nbe_t with - | Construct (fvar, us, [(a, _); _; _]) when S.fv_eq_lid fvar PC.inl_lid -> - BU.bind_opt (unembed ea cb a) (fun a -> - Some (Inl a)) - | Construct (fvar, us, [(b, _); _; _]) when S.fv_eq_lid fvar PC.inr_lid -> - BU.bind_opt (unembed eb cb b) (fun b -> - Some (Inr b)) - | _ -> None) - in - mk_emb em un (fun () -> lid_as_typ PC.either_lid [U_zero;U_zero] [as_arg (type_of eb); as_arg (type_of ea)]) etyp - -// Embedding range (unsealed) -let e___range : embedding Range.range = - let em cb r = Constant (Range r) in - let un cb t = - match t with - | Constant (Range r) -> Some r - | _ -> - None - in - mk_emb' em un (fun () -> lid_as_typ PC.__range_lid [] []) (SE.emb_typ_of Range.range) - -// Embedding a sealed term. This just calls the embedding for a but also -// adds a `seal` marker to the result. The unembedding removes it. -let e_sealed (ea : embedding 'a) : Prims.Tot (embedding (Sealed.sealed 'a)) = - let etyp () = - ET_app(PC.sealed_lid |> Ident.string_of_lid, [ea.e_typ ()]) - in - let em cb (x: Sealed.sealed 'a) : t = - lazy_embed etyp x (fun () -> - lid_as_constr PC.seal_lid [U_zero] [as_arg (embed ea cb (Sealed.unseal x)); - as_iarg (type_of ea)]) - in - let un cb (trm:t) : option (Sealed.sealed 'a) = - lazy_unembed etyp trm (fun trm -> - match trm.nbe_t with - | Construct (fvar, us, [(a, _); _]) when S.fv_eq_lid fvar PC.seal_lid -> - Class.Monad.fmap Sealed.seal <| unembed ea cb a - | _ -> None) - in - mk_emb em un (fun () -> lid_as_typ PC.sealed_lid [U_zero] [as_arg (type_of ea)]) etyp - -let e_range : embedding Range.range = - embed_as (e_sealed e___range) Sealed.unseal Sealed.seal None - -let e_issue : embedding FStar.Errors.issue = - let t_issue = SE.type_of SE.e_issue in - let li blob rng = { blob=Dyn.mkdyn blob; lkind = Lazy_issue; ltyp = t_issue; rng } in - let em cb iss = Lazy (Inl (li iss Range.dummyRange), (Thunk.mk (fun _ -> failwith "Cannot unembed issue"))) in - let un cb t = - match t with - | Lazy (Inl { lkind=Lazy_issue; blob }, _) -> Some (Dyn.undyn blob) - | _ -> None - in - mk_emb' em un (fun () -> lid_as_typ PC.issue_lid [] []) (SE.emb_typ_of issue) - -let e_document : embedding FStar.Pprint.document = - let t_document = SE.type_of SE.e_document in - let li blob rng = { blob=Dyn.mkdyn blob; lkind = Lazy_doc; ltyp = t_document; rng } in - let em cb doc = Lazy (Inl (li doc Range.dummyRange), (Thunk.mk (fun _ -> failwith "Cannot unembed document"))) in - let un cb t = - match t with - | Lazy (Inl { lkind=Lazy_doc; blob }, _) -> Some (Dyn.undyn blob) - | _ -> None - in - mk_emb' em un (fun () -> lid_as_typ PC.document_lid [] []) (SE.emb_typ_of Pprint.document) - -// vconfig, NYI -let e_vconfig : embedding vconfig = - let em cb r = failwith "e_vconfig NBE" in - let un cb t = failwith "e_vconfig NBE" in - mk_emb' em un (fun () -> lid_as_typ PC.vconfig_lid [] []) (SE.emb_typ_of vconfig) - -// Emdedding lists -let e_list (ea:embedding 'a) = - let etyp () = - ET_app(PC.list_lid |> Ident.string_of_lid, [ea.e_typ ()]) - in - let em cb (l:list 'a) : t = - lazy_embed etyp l (fun () -> - let typ = as_iarg (type_of ea) in - let nil = lid_as_constr PC.nil_lid [U_zero] [typ] in - let cons hd tl = lid_as_constr PC.cons_lid [U_zero] [as_arg tl; as_arg (embed ea cb hd); typ] in - List.fold_right cons l nil) - in - let rec un cb (trm:t) : option (list 'a) = - lazy_unembed etyp trm (fun trm -> - match trm.nbe_t with - | Construct (fv, _, _) when S.fv_eq_lid fv PC.nil_lid -> Some [] - | Construct (fv, _, [(tl, None); (hd, None); (_, Some ({ aqual_implicit = true }))]) - // Zoe: Not sure why this case is need; following Emdeddings.fs - // GM: Maybe it's not, but I'm unsure on whether we can rely on all these terms being type-correct - | Construct (fv, _, [(tl, None); (hd, None)]) - when S.fv_eq_lid fv PC.cons_lid -> - BU.bind_opt (unembed ea cb hd) (fun hd -> - BU.bind_opt (un cb tl) (fun tl -> - Some (hd :: tl))) - | _ -> None) - in - mk_emb em un (fun () -> lid_as_typ PC.list_lid [U_zero] [as_arg (type_of ea)]) etyp - -let e_string_list = e_list e_string - -let e_arrow (ea:embedding 'a) (eb:embedding 'b) : Prims.Tot (embedding ('a -> 'b)) = - let etyp () = ET_fun(ea.e_typ (), eb.e_typ ()) in - let em cb (f : 'a -> 'b) : t = - lazy_embed etyp f (fun () -> - mk_t <| Lam { - interp = (fun tas -> match unembed ea cb (tas |> List.hd |> fst) with - | Some a -> embed eb cb (f a) - | None -> failwith "cannot unembed function argument"); - shape = Lam_args [as_arg (type_of eb)]; - arity = 1; - }) - in - let un cb (lam : t) : option ('a -> 'b) = - let k (lam:t) : option ('a -> 'b) = - Some (fun (x:'a) -> match unembed eb cb (cb.iapp lam [as_arg (embed ea cb x)]) with - | Some y -> y - | None -> failwith "cannot unembed function result") - in - lazy_unembed etyp lam k - in - mk_emb em un (fun () -> make_arrow1 (type_of ea) (as_iarg (type_of eb))) etyp - -let e_abstract_nbe_term = - embed_as e_any (fun x -> AbstractNBE x) (fun x -> match x with AbstractNBE x -> x) None - -let e_unsupported #a : embedding a = - let em = (fun _cb a -> failwith "Unsupported NBE embedding") in - let un = (fun _cb t -> failwith "Unsupported NBE embedding") in - mk_emb em un (fun () -> lid_as_typ PC.term_lid [] []) (fun () -> ET_abstract) - -let e_norm_step = - let em cb (n:Pervasives.norm_step) : t = - match n with - | Pervasives.Simpl -> mkFV (lid_as_fv PC.steps_simpl None) [] [] - | Pervasives.Weak -> mkFV (lid_as_fv PC.steps_weak None) [] [] - | Pervasives.HNF -> mkFV (lid_as_fv PC.steps_hnf None) [] [] - | Pervasives.Primops -> mkFV (lid_as_fv PC.steps_primops None) [] [] - | Pervasives.Delta -> mkFV (lid_as_fv PC.steps_delta None) [] [] - | Pervasives.Zeta -> mkFV (lid_as_fv PC.steps_zeta None) [] [] - | Pervasives.Iota -> mkFV (lid_as_fv PC.steps_iota None) [] [] - | Pervasives.Reify -> mkFV (lid_as_fv PC.steps_reify None) [] [] - | Pervasives.NBE -> mkFV (lid_as_fv PC.steps_nbe None) [] [] - | Pervasives.UnfoldOnly l -> - mkFV (lid_as_fv PC.steps_unfoldonly None) - [] [as_arg (embed (e_list e_string) cb l)] - | Pervasives.UnfoldFully l -> - mkFV (lid_as_fv PC.steps_unfoldfully None) - [] [as_arg (embed (e_list e_string) cb l)] - | Pervasives.UnfoldAttr l -> - mkFV (lid_as_fv PC.steps_unfoldattr None) - [] [as_arg (embed (e_list e_string) cb l)] - | Pervasives.UnfoldQual l -> - mkFV (lid_as_fv PC.steps_unfoldqual None) - [] [as_arg (embed (e_list e_string) cb l)] - | Pervasives.UnfoldNamespace l -> - mkFV (lid_as_fv PC.steps_unfoldnamespace None) - [] [as_arg (embed (e_list e_string) cb l)] - | Pervasives.ZetaFull -> mkFV (lid_as_fv PC.steps_zeta_full None) [] [] - | Pervasives.Unascribe -> mkFV (lid_as_fv PC.steps_unascribe None) [] [] - in - let un cb (t0:t) : option Pervasives.norm_step = - match t0.nbe_t with - | FV (fv, _, []) when S.fv_eq_lid fv PC.steps_simpl -> - Some Pervasives.Simpl - | FV (fv, _, []) when S.fv_eq_lid fv PC.steps_weak -> - Some Pervasives.Weak - | FV (fv, _, []) when S.fv_eq_lid fv PC.steps_hnf -> - Some Pervasives.HNF - | FV (fv, _, []) when S.fv_eq_lid fv PC.steps_primops -> - Some Pervasives.Primops - | FV (fv, _, []) when S.fv_eq_lid fv PC.steps_delta -> - Some Pervasives.Delta - | FV (fv, _, []) when S.fv_eq_lid fv PC.steps_zeta -> - Some Pervasives.Zeta - | FV (fv, _, []) when S.fv_eq_lid fv PC.steps_iota -> - Some Pervasives.Iota - | FV (fv, _, []) when S.fv_eq_lid fv PC.steps_nbe -> - Some Pervasives.NBE - | FV (fv, _, []) when S.fv_eq_lid fv PC.steps_reify -> - Some Pervasives.Reify - | FV (fv, _, []) when S.fv_eq_lid fv PC.steps_zeta_full -> - Some Pervasives.ZetaFull - | FV (fv, _, []) when S.fv_eq_lid fv PC.steps_unascribe -> - Some Pervasives.Unascribe - | FV (fv, _, [(l, _)]) when S.fv_eq_lid fv PC.steps_unfoldonly -> - BU.bind_opt (unembed (e_list e_string) cb l) (fun ss -> - Some <| Pervasives.UnfoldOnly ss) - | FV (fv, _, [(l, _)]) when S.fv_eq_lid fv PC.steps_unfoldfully -> - BU.bind_opt (unembed (e_list e_string) cb l) (fun ss -> - Some <| Pervasives.UnfoldFully ss) - | FV (fv, _, [(l, _)]) when S.fv_eq_lid fv PC.steps_unfoldattr -> - BU.bind_opt (unembed (e_list e_string) cb l) (fun ss -> - Some <| Pervasives.UnfoldAttr ss) - | FV (fv, _, [(l, _)]) when S.fv_eq_lid fv PC.steps_unfoldqual -> - BU.bind_opt (unembed (e_list e_string) cb l) (fun ss -> - Some <| Pervasives.UnfoldQual ss) - | FV (fv, _, [(l, _)]) when S.fv_eq_lid fv PC.steps_unfoldnamespace -> - BU.bind_opt (unembed (e_list e_string) cb l) (fun ss -> - Some <| Pervasives.UnfoldNamespace ss) - | _ -> - Errors.log_issue0 Errors.Warning_NotEmbedded - (BU.format1 "Not an embedded norm_step: %s" (t_to_string t0)); - None - in - mk_emb em un (fun () -> mkFV (lid_as_fv PC.norm_step_lid None) [] []) - (SE.emb_typ_of norm_step) - -(* Interface for building primitive steps *) - -let bogus_cbs = { - iapp = (fun h _args -> h); - translate = (fun _ -> failwith "bogus_cbs translate"); -} - -let arg_as_int (a:arg) = fst a |> unembed e_int bogus_cbs - -let arg_as_bool (a:arg) = fst a |> unembed e_bool bogus_cbs - -let arg_as_list (e:embedding 'a) (a:arg) = fst a |> unembed (e_list e) bogus_cbs - -(* XXX a lot of code duplication. Same code as in cfg.fs *) -let lift_unary (f : 'a -> 'b) (aopts : list (option 'a)) : option 'b = - match aopts with - | [Some a] -> Some (f a) - | _ -> None - - -let lift_binary (f : 'a -> 'a -> 'b) (aopts : list (option 'a)) : option 'b = - match aopts with - | [Some a0; Some a1] -> Some (f a0 a1) - | _ -> None - -let mixed_binary_op (as_a : arg -> option 'a) (as_b : arg -> option 'b) - (embed_c : 'c -> t) (f : universes -> 'a -> 'b -> option 'c) - (us:universes) (args : args) : option t = - match args with - | [a;b] -> - begin - match as_a a, as_b b with - | Some a, Some b -> - (match f us a b with - | Some c -> Some (embed_c c) - | _ -> None) - | _ -> None - end - | _ -> None - -let mixed_ternary_op (as_a : arg -> option 'a) - (as_b : arg -> option 'b) - (as_c : arg -> option 'c) - (embed_d : 'd -> t) - (f : universes -> 'a -> 'b -> 'c -> option 'd) - (us: universes) - (args : args) : option t = - match args with - | [a;b;c] -> - begin - match as_a a, as_b b, as_c c with - | Some a, Some b, Some c -> - (match f us a b c with - | Some d -> Some (embed_d d) - | _ -> None) - | _ -> None - end - | _ -> None - -let dummy_interp (lid : Ident.lid) (args : args) : option t = - failwith ("No interpretation for " ^ (Ident.string_of_lid lid)) - -let and_op (args:args) : option t = - match args with - | [a1; a2] -> begin - match arg_as_bool a1 with - | Some false -> - Some (embed e_bool bogus_cbs false) - | Some true -> - Some (fst a2) - | _ -> None - end - | _ -> failwith "Unexpected number of arguments" - -let or_op (args:args) : option t = - match args with - | [a1; a2] -> begin - match arg_as_bool a1 with - | Some true -> - Some (embed e_bool bogus_cbs true) - | Some false -> - Some (fst a2) - | _ -> None - end - | _ -> failwith "Unexpected number of arguments" - -// let e_arrow2 (ea:embedding 'a) (eb:embedding 'b) (ec:embedding 'c) = -// let em (f : 'a -> 'b -> 'c) : t = Lam((fun (ta:t) -> match unembed ea ta with -// | Some a -> embed eb (f a) -// | None -> failwith "Cannot unembed argument"), -// (fun _ -> type_of ea), None) -// in -// let un (lam : t) : option ('a -> 'b) = -// match lam with -// | Lam (ft, _, _) -> Some (fun (x:'a) -> match unembed eb (ft (embed ea x)) with -// | Some b -> b -// | None -> failwith "Cannot unembed function result") -// | _ -> None -// in -// mk_emb em un (make_arrow1 (type_of ea) (as_iarg (type_of eb))) - - - -let arrow_as_prim_step_1 (ea:embedding 'a) (eb:embedding 'b) - (f:'a -> 'b) (_fv_lid:Ident.lid) cb - : universes -> args -> option t = - let f_wrapped _us args = - let x, _ = List.hd args in //arity mismatches are handled by code that dispatches here - BU.map_opt - (unembed ea cb x) (fun x -> - embed eb cb (f x)) - in - f_wrapped - -let arrow_as_prim_step_2 (ea:embedding 'a) (eb:embedding 'b) (ec:embedding 'c) - (f:'a -> 'b -> 'c) (_fv_lid:Ident.lid) cb - : universes -> args -> option t = - let f_wrapped _us args = - let x, _ = List.hd args in //arity mismatches are handled by code that dispatches here - let y, _ = List.hd (List.tl args) in - BU.bind_opt (unembed ea cb x) (fun x -> - BU.bind_opt (unembed eb cb y) (fun y -> - Some (embed ec cb (f x y)))) - in - f_wrapped - - -let arrow_as_prim_step_3 (ea:embedding 'a) (eb:embedding 'b) - (ec:embedding 'c) (ed:embedding 'd) - (f:'a -> 'b -> 'c -> 'd) (_fv_lid:Ident.lid) cb - : universes -> args -> option t = - let f_wrapped _us args = - let x, _ = List.hd args in //arity mismatches are handled by code that dispatches here - let y, _ = List.hd (List.tl args) in - let z, _ = List.hd (List.tl (List.tl args)) in - BU.bind_opt (unembed ea cb x) (fun x -> - BU.bind_opt (unembed eb cb y) (fun y -> - BU.bind_opt (unembed ec cb z) (fun z -> - Some (embed ed cb (f x y z))))) - in - f_wrapped - -(* TODO: move to, Syntax.Embeddings or somewhere better even *) -let e_order = - let ord_Lt_lid = Ident.lid_of_path (["FStar"; "Order"; "Lt"]) Range.dummyRange in - let ord_Eq_lid = Ident.lid_of_path (["FStar"; "Order"; "Eq"]) Range.dummyRange in - let ord_Gt_lid = Ident.lid_of_path (["FStar"; "Order"; "Gt"]) Range.dummyRange in - let ord_Lt = tdataconstr ord_Lt_lid in - let ord_Eq = tdataconstr ord_Eq_lid in - let ord_Gt = tdataconstr ord_Gt_lid in - let ord_Lt_fv = lid_as_fv ord_Lt_lid (Some Data_ctor) in - let ord_Eq_fv = lid_as_fv ord_Eq_lid (Some Data_ctor) in - let ord_Gt_fv = lid_as_fv ord_Gt_lid (Some Data_ctor) in - let open FStar.Order in - let embed_order cb (o:order) : t = - match o with - | Lt -> mkConstruct ord_Lt_fv [] [] - | Eq -> mkConstruct ord_Eq_fv [] [] - | Gt -> mkConstruct ord_Gt_fv [] [] - in - let unembed_order cb (t:t) : option order = - match t.nbe_t with - | Construct (fv, _, []) when S.fv_eq_lid fv ord_Lt_lid -> Some Lt - | Construct (fv, _, []) when S.fv_eq_lid fv ord_Eq_lid -> Some Eq - | Construct (fv, _, []) when S.fv_eq_lid fv ord_Gt_lid -> Some Gt - | _ -> None - in - let fv_as_emb_typ fv = S.ET_app (FStar.Ident.string_of_lid fv.fv_name.v, []) in - let fv = lid_as_fv PC.order_lid None in - mk_emb embed_order unembed_order (fun () -> mkFV fv [] []) (fun () -> fv_as_emb_typ fv) diff --git a/src/typechecker/FStar.TypeChecker.NBETerm.fsti b/src/typechecker/FStar.TypeChecker.NBETerm.fsti deleted file mode 100644 index f649a8016c9..00000000000 --- a/src/typechecker/FStar.TypeChecker.NBETerm.fsti +++ /dev/null @@ -1,354 +0,0 @@ -(* - Copyright 2017-2019 Microsoft Research - - Authors: Zoe Paraskevopoulou, Guido Martinez, Nikhil Swamy - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.TypeChecker.NBETerm - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Syntax.Syntax -open FStar.Ident -open FStar.VConfig -open FStar.Char - -module S = FStar.Syntax.Syntax -module U = FStar.Syntax.Util -module Z = FStar.BigInt -module TEQ = FStar.TypeChecker.TermEqAndSimplify -open FStar.Class.Show - -val interleave_hack : int - -(* - This module provides the internal term representations used in the - NBE algorithm implemented by FStar.TypeChecker.NBE.fs (see the - comments at the header of that file, for some general context about - the algorithm). - - Although the type provided by this module is mostly of relevance to - the internal of the NBE algorithm, we expose its definitions mainly - so that we can (in FStar.TypeChecker.Cfg and - FStar.Tactics.Interpreter) provide NBE compatible implementations - of primitive computation steps. -*) - -type var = bv -type sort = int - -// This type mostly mirrors the definition of FStar.Const.sconst -// There are several missing cases, however. -// TODO: We should also provide implementations for float, bytearray, -// etc. -type constant = - | Unit - | Bool of bool - | Int of Z.t - | String of string & Range.range - | Char of FStar.Char.char - | Range of Range.range - | SConst of FStar.Const.sconst - | Real of string - -// Atoms represent the head of an irreducible application -// They can either be variables -// Or, un-reduced match terms -type atom - = - | Var of var - | Match of - // 1. the scrutinee - t & - // 2. reconstruct the returns annotation - (unit -> option match_returns_ascription) & - // 3. reconstructs the pattern matching, if it needs to be readback - (unit -> list branch) & - // 4. reconstruct the residual comp if set - (unit -> option S.residual_comp) - | UnreducedLet of - // Especially when extracting, we do not always want to reduce let bindings - // since that can lead to exponential code size blowup. This node represents - // an unreduced let binding which can be read back as an F* let - // 1. The name of the let-bound term - var & - // 2. The type of the let-bound term - Thunk.t t & - // 3. Its definition - Thunk.t t & - // 4. The body of the let binding - Thunk.t t & - // 5. The source letbinding for readback (of attributes etc.) - letbinding - | UnreducedLetRec of - // Same as UnreducedLet, but for local let recs - // 1. list of names of all mutually recursive let-rec-bound terms - // * their types - // * their definitions - list (var & t & t) & - // 2. the body of the let binding - t & - // 3. the source letbinding for readback (of attributes etc.) - // equal in length to the first list - list letbinding - | UVar of Thunk.t S.term - -and lam_shape = - // a context, binders and residual_comp for readback - | Lam_bs of (list t & binders & option S.residual_comp) - - // or a list of arguments, for primitive unembeddings (see e_arrow) - | Lam_args of (list arg) - - // or a partially applied primop - | Lam_primop of (S.fv & list arg) - -and t' = - | Lam { - interp : list (t & aqual) -> t; - //these expect their arguments in binder order (optimized for convenience beta reduction) - //we also maintain aquals so as to reconstruct the application properly for implicits - - shape : lam_shape; - arity : int; - } - - | Accu of atom & args - | Construct of fv & list universe & args - | FV of fv & list universe & args //universes and args in reverse order - | Constant of constant - | Type_t of universe - | Univ of universe - | Unknown - | Arrow of either (Thunk.t S.term) (list arg & comp) - | Refinement of (t -> t) & (unit -> arg) - | Reflect of t - | Quote of S.term & S.quoteinfo - | Lazy of (either S.lazyinfo (Dyn.dyn & emb_typ)) & Thunk.t t - | Meta of t & Thunk.t S.metadata - | TopLevelLet of - // 1. The definition of the fv - letbinding & - // 2. Its natural arity including universes (see Util.let_rec_arity) - int & - // 3. Accumulated arguments in order from left-to-right (unlike Accu, these are not reversed) - args - | TopLevelRec of - // 1. The definition of the fv - letbinding & - // 2. Its natural arity including universes (see Util.let_rec_arity) - int & - // 3. Whether or not each argument appeats in the decreases clause (also see Util.let_rec_arity) - list bool & - // 4. Accumulated arguments in order from left-to-right (unlike Accu, these are not reversed) - args - | LocalLetRec of - // 1. index of the let binding in the mutually recursive list - int & - letbinding & - // 2. Mutally recursive letbindings (only for local mutually recursive let bindings) - list letbinding & - // 3. rec env - list t & - // 4. Argument accumulator - args & - // 5. natural arity (including universes) of the main let binding `f` (see Util.let_rec_arity) - int & - // 6. for each argument, a bool records if that argument appears in the decreases - // This is used to detect potentially non-terminating loops - list bool - -and t = { - nbe_t : t'; - nbe_r : Range.range -} - -and comp = - | Tot of t - | GTot of t - | Comp of comp_typ - -and comp_typ = { - comp_univs:universes; - effect_name:lident; - result_typ:t; - effect_args:args; - flags:list cflag -} - -and residual_comp = { - residual_effect:lident; - residual_typ :option t; - residual_flags :list cflag -} - -and cflag = - | TOTAL - | MLEFFECT - | RETURN - | PARTIAL_RETURN - | SOMETRIVIAL - | TRIVIAL_POSTCONDITION - | SHOULD_NOT_INLINE - | LEMMA - | CPS - | DECREASES_lex of list t - | DECREASES_wf of (t & t) - -and arg = t & aqual -and args = list (arg) - -instance val showable_t : showable t -instance val showable_args : showable args - -val isAccu : t -> bool -val isNotAccu : t -> bool - -val mkConstruct : fv -> list universe -> args -> t -val mkFV : fv -> list universe -> args -> t - -val mkAccuVar : var -> t -val mkAccuMatch : t -> (unit -> option match_returns_ascription) -> (unit -> list branch) -> (unit -> option S.residual_comp) -> t - -type head = t -type annot = option t - -type nbe_cbs = { - iapp : t -> args -> t; - translate : term -> t; -} - -class embedding (a:Type0) = { - em : nbe_cbs -> a -> t; - un : nbe_cbs -> t -> option a; - (* thunking to allow total instances *) - typ : unit -> t; - e_typ : unit -> emb_typ; -} - -val eq_t : Env.env_t -> t -> t -> TEQ.eq_result - -// Printing functions - -val constant_to_string : constant -> string -val t_to_string : t -> string -val atom_to_string : atom -> string -val arg_to_string : arg -> string -val args_to_string : args -> string - -// NBE term manipulation -val mk_t : t' -> t -val nbe_t_of_t : t -> t' - -val as_arg : t -> arg -val as_iarg : t -> arg - -val iapp_cb : nbe_cbs -> t -> args -> t -val translate_cb : nbe_cbs -> term -> t - -val mk_emb : (nbe_cbs -> 'a -> t) -> - (nbe_cbs -> t -> option 'a) -> - (unit -> t) -> - (unit -> emb_typ) -> - Prims.Tot (embedding 'a) - -val embed_as : embedding 'a -> ('a -> 'b) -> ('b -> 'a) -> option t -> embedding 'b - -val embed : embedding 'a -> nbe_cbs -> 'a -> t -val unembed : embedding 'a -> nbe_cbs -> t -> option 'a -val lazy_unembed_lazy_kind (#a:Type) (k:lazy_kind) (x:t) : option a -val type_of : embedding 'a -> t -val set_type : t -> embedding 'a -> embedding 'a - -type abstract_nbe_term = | AbstractNBE : t:t -> abstract_nbe_term - -instance val e_bool : embedding bool -instance val e_string : embedding string -instance val e_char : embedding char -instance val e_int : embedding Z.t -instance val e_real : embedding Compiler.Real.real -instance val e_unit : embedding unit -val e_any : embedding t -val mk_any_emb : t -> embedding t -val e___range : embedding Range.range (* unsealed *) -instance val e_range : embedding Range.range (* sealed *) -instance val e_issue : embedding FStar.Errors.issue -instance val e_document : embedding FStar.Pprint.document -instance val e_vconfig : embedding vconfig -instance val e_norm_step : embedding Pervasives.norm_step -instance val e_list : #a:Type -> embedding a -> Prims.Tot (embedding (list a)) -instance val e_option : embedding 'a -> Prims.Tot (embedding (option 'a)) -instance val e_tuple2 : embedding 'a -> embedding 'b -> Prims.Tot (embedding ('a & 'b)) -instance val e_tuple3 : embedding 'a -> embedding 'b -> embedding 'c -> Prims.Tot (embedding ('a & 'b & 'c)) -instance val e_tuple4 : embedding 'a -> embedding 'b -> embedding 'c -> embedding 'd -> Prims.Tot (embedding ('a & 'b & 'c & 'd)) -instance val e_tuple5 : embedding 'a -> embedding 'b -> embedding 'c -> embedding 'd -> embedding 'e -> Prims.Tot (embedding ('a & 'b & 'c & 'd & 'e)) -instance val e_either : embedding 'a -> embedding 'b -> Prims.Tot (embedding (either 'a 'b)) -instance val e_sealed : embedding 'a -> Prims.Tot (embedding (FStar.Compiler.Sealed.sealed 'a)) -instance val e_string_list : embedding (list string) -val e_arrow : embedding 'a -> embedding 'b -> embedding ('a -> 'b) - -instance val e_abstract_nbe_term : embedding abstract_nbe_term -instance val e_order : embedding FStar.Order.order - -(* Unconditionally fails raising an exception when called *) -val e_unsupported : #a:Type -> embedding a - -(* Arity specific raw_embeddings of arrows; used to generate top-level - registrations of compiled functions in FStar.Extraction.ML.Util *) -val arrow_as_prim_step_1: embedding 'a - -> embedding 'b - -> ('a -> 'b) - -> repr_f:Ident.lid - -> nbe_cbs - -> (universes -> args -> option t) - -val arrow_as_prim_step_2: embedding 'a - -> embedding 'b - -> embedding 'c - -> ('a -> 'b -> 'c) - -> repr_f:Ident.lid - -> nbe_cbs - -> (universes -> args -> option t) - -val arrow_as_prim_step_3: embedding 'a - -> embedding 'b - -> embedding 'c - -> embedding 'd - -> ('a -> 'b -> 'c -> 'd) - -> repr_f:Ident.lid - -> nbe_cbs - -> (universes -> args -> option t) - -// Interface for NBE interpretations - -val arg_as_int : arg -> option Z.t -val arg_as_list : embedding 'a -> arg -> option (list 'a) - -val mixed_binary_op : (arg -> option 'a) -> (arg -> option 'b) -> ('c -> t) -> - (universes -> 'a -> 'b -> option 'c) -> universes -> args -> option t - -val mixed_ternary_op (as_a : arg -> option 'a) - (as_b : arg -> option 'b) - (as_c : arg -> option 'c) - (embed_d : 'd -> t) - (f : universes -> 'a -> 'b -> 'c -> option 'd) - (us:universes) - (args : args) : option t - -val dummy_interp : Ident.lid -> args -> option t - -val and_op : args -> option t -val or_op : args -> option t diff --git a/src/typechecker/FStar.TypeChecker.Normalize.Unfolding.fst b/src/typechecker/FStar.TypeChecker.Normalize.Unfolding.fst deleted file mode 100644 index 5fb9db19425..00000000000 --- a/src/typechecker/FStar.TypeChecker.Normalize.Unfolding.fst +++ /dev/null @@ -1,185 +0,0 @@ -module FStar.TypeChecker.Normalize.Unfolding - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.TypeChecker.Cfg -open FStar.TypeChecker.Env -open FStar.Syntax.Print - -module Common = FStar.TypeChecker.Common -module BU = FStar.Compiler.Util -module Path = FStar.Compiler.Path -module PC = FStar.Parser.Const -module Print = FStar.Syntax.Print -module S = FStar.Syntax.Syntax -module U = FStar.Syntax.Util -module TEQ = FStar.TypeChecker.TermEqAndSimplify - -open FStar.Class.Show - -(* Max number of warnings to print in a single run. -Initialized in Normalize.normalize *) -let plugin_unfold_warn_ctr : ref int = BU.mk_ref 0 - -let should_unfold cfg should_reify fv qninfo : should_unfold_res = - let attrs = - match Env.attrs_of_qninfo qninfo with - | None -> [] - | Some ats -> ats - in - let quals = - match Env.quals_of_qninfo qninfo with - | None -> [] - | Some quals -> quals - in - (* unfold or not, fully or not, reified or not *) - let yes = true , false , false in - let no = false , false , false in - let fully = true , true , false in - let reif = true , false , true in - - let yesno b = if b then yes else no in - let fullyno b = if b then fully else no in - let comb_or l = List.fold_right (fun (a,b,c) (x,y,z) -> (a||x, b||y, c||z)) l (false, false, false) in - - let default_unfolding () = - log_unfolding cfg (fun () -> BU.print3 "should_unfold: Reached a %s with delta_depth = %s\n >> Our delta_level is %s\n" - (show fv) - (show (Env.delta_depth_of_fv cfg.tcenv fv)) - (show cfg.delta_level)); - yesno <| (cfg.delta_level |> BU.for_some (function - | NoDelta -> false - | InliningDelta - | Eager_unfolding_only -> true - | Unfold l -> Common.delta_depth_greater_than (Env.delta_depth_of_fv cfg.tcenv fv) l)) - in - let res = - match qninfo, - cfg.steps.unfold_only, - cfg.steps.unfold_fully, - cfg.steps.unfold_attr, - cfg.steps.unfold_qual, - cfg.steps.unfold_namespace - with - // We unfold dm4f actions if and only if we are reifying - | _ when Env.qninfo_is_action qninfo -> - let b = should_reify cfg in - log_unfolding cfg (fun () -> BU.print2 "should_unfold: For DM4F action %s, should_reify = %s\n" - (show fv) - (show b)); - if b then reif else no - - // If it is handled primitively, then don't unfold - | _ when Option.isSome (find_prim_step cfg fv) -> - log_unfolding cfg (fun () -> BU.print_string " >> It's a primop, not unfolding\n"); - no - - // Don't unfold HasMaskedEffect - | Some (Inr ({sigquals=qs; sigel=Sig_let {lbs=(is_rec, _)}}, _), _), _, _, _, _, _ when - List.contains HasMaskedEffect qs -> - log_unfolding cfg (fun () -> BU.print_string " >> HasMaskedEffect, not unfolding\n"); - no - - // Recursive lets may only be unfolded when Zeta is on - | Some (Inr ({sigquals=qs; sigel=Sig_let {lbs=(is_rec, _)}}, _), _), _, _, _, _, _ when - is_rec && not cfg.steps.zeta && not cfg.steps.zeta_full -> - log_unfolding cfg (fun () -> BU.print_string " >> It's a recursive definition but we're not doing Zeta, not unfolding\n"); - no - - // We're doing selectively unfolding, assume it to not unfold unless it meets the criteria - | _, Some _, _, _, _, _ - | _, _, Some _, _, _, _ - | _, _, _, Some _, _, _ - | _, _, _, _, Some _, _ - | _, _, _, _, _, Some _ -> - log_unfolding cfg (fun () -> BU.print1 "should_unfold: Reached a %s with selective unfolding\n" - (show fv)); - // How does the following code work? - // We are doing selective unfolding so, by default, we assume everything - // should *not* be unfolded unless it meets *at least one* of the criteria. - // So we check exactly that, that this `fv` meets some criteria that is presently - // being used. Note that in `None`, we default to `no`, otherwise everything would - // unfold (unless we had all criteria present at once, which is unlikely) - - let meets_some_criterion = - comb_or [ - (if cfg.steps.for_extraction - then yesno <| Option.isSome (Env.lookup_definition_qninfo [Eager_unfolding_only; InliningDelta] fv.fv_name.v qninfo) - else no) - ;(match cfg.steps.unfold_only with - | None -> no - | Some lids -> yesno <| BU.for_some (fv_eq_lid fv) lids) - ;(match cfg.steps.unfold_attr with - | None -> no - | Some lids -> yesno <| BU.for_some (fun at -> BU.for_some (fun lid -> U.is_fvar lid at) lids) attrs) - ;(match cfg.steps.unfold_fully with - | None -> no - | Some lids -> fullyno <| BU.for_some (fv_eq_lid fv) lids) - ;(match cfg.steps.unfold_qual with - | None -> no - | Some qs -> - yesno <| - BU.for_some - (fun q -> - BU.for_some - (fun qual -> show qual = q) // kinda funny - quals) - qs) - ;(match cfg.steps.unfold_namespace with - | None -> no - | Some namespaces -> - (* Check if the variable is under some of the modules in [ns]. - Essentially we check if there is a component in ns that is a prefix of - the (printed) lid. But, to prevent unfolding `ABCD.def` when we - are trying to unfold `AB`, we append a single `.` to both before checking, - so `AB` only unfold lids under the `AB` module and its submodules. *) - let p : list string = Ident.path_of_lid (lid_of_fv fv) in - let r : bool = Path.search_forest p namespaces in - yesno <| r - ) - ] - in - meets_some_criterion - - // Check for DontUnfoldAttribute: if any attribute of the definitions is blacklisted, - // do not unfold. - // NB: Using specific attributes like UnfoldOnly will override this. This gives more - // control to the user if they *really* want to unfold one of these. - | _, _, _, _, _, _ when Some? cfg.steps.dont_unfold_attr - && List.existsb (fun fa -> U.has_attribute attrs fa) (Some?.v cfg.steps.dont_unfold_attr) -> - log_unfolding cfg (fun () -> BU.print_string " >> forbidden by attribute, not unfolding\n"); - no - - - // Nothing special, just check the depth - | _ -> - default_unfolding() - in - log_unfolding cfg (fun () -> BU.print3 "should_unfold: For %s (%s), unfolding res = %s\n" - (show fv) - (show (S.range_of_fv fv)) - (show res) - ); - let r = - match res with - | false, _, _ -> Should_unfold_no - | true, false, false -> Should_unfold_yes - | true, true, false -> Should_unfold_fully - | true, false, true -> Should_unfold_reify - | _ -> - failwith <| BU.format1 "Unexpected unfolding result: %s" (show res) - in - if Some? cfg.steps.dont_unfold_attr // If we are running a tactic (probably..), - && not (Options.no_plugins ()) // haven't explicitly disabled plugins - && (r <> Should_unfold_no) // actually unfolding this fvar - && BU.for_some (U.is_fvar PC.plugin_attr) attrs // it is a plugin - && !plugin_unfold_warn_ctr > 0 // and we haven't raised too many warnings - then begin - // then warn about it - let msg = BU.format1 "Unfolding name which is marked as a plugin: %s" (show fv) in - Errors.log_issue fv.fv_name.p Errors.Warning_UnfoldPlugin msg; - plugin_unfold_warn_ctr := !plugin_unfold_warn_ctr - 1 - end; - r diff --git a/src/typechecker/FStar.TypeChecker.Normalize.Unfolding.fsti b/src/typechecker/FStar.TypeChecker.Normalize.Unfolding.fsti deleted file mode 100644 index 9b6eddead6e..00000000000 --- a/src/typechecker/FStar.TypeChecker.Normalize.Unfolding.fsti +++ /dev/null @@ -1,23 +0,0 @@ -module FStar.TypeChecker.Normalize.Unfolding - -open FStar.Compiler.Effect -open FStar.TypeChecker -open FStar.Syntax.Syntax -open FStar.TypeChecker.Cfg - -(* This reference stores the max amount of warnings we emit -about unfolding plugins. Set by normalize (0 otherwise). *) -val plugin_unfold_warn_ctr : ref int - -(* Exposed for NBE *) -type should_unfold_res = - | Should_unfold_no - | Should_unfold_yes - | Should_unfold_fully - | Should_unfold_reify - -val should_unfold : cfg - -> should_reify:(cfg -> bool) - -> fv - -> Env.qninfo - -> should_unfold_res diff --git a/src/typechecker/FStar.TypeChecker.Normalize.fst b/src/typechecker/FStar.TypeChecker.Normalize.fst deleted file mode 100644 index b277bffa941..00000000000 --- a/src/typechecker/FStar.TypeChecker.Normalize.fst +++ /dev/null @@ -1,3299 +0,0 @@ -(* - Copyright 2008-2016 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.TypeChecker.Normalize -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.Defensive -open FStar.Compiler.Util -open FStar.String -open FStar.Const -open FStar.Char -open FStar.Errors -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.Syntax.Subst -open FStar.Syntax.Util -open FStar.TypeChecker -open FStar.TypeChecker.Common -open FStar.TypeChecker.Env -open FStar.TypeChecker.Cfg - -open FStar.Class.Show -open FStar.Class.Tagged -open FStar.Class.Deq - -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module BU = FStar.Compiler.Util -module FC = FStar.Const -module PC = FStar.Parser.Const -module U = FStar.Syntax.Util -module I = FStar.Ident -module EMB = FStar.Syntax.Embeddings -module Z = FStar.BigInt -module TcComm = FStar.TypeChecker.Common -module TEQ = FStar.TypeChecker.TermEqAndSimplify -module PO = FStar.TypeChecker.Primops -open FStar.TypeChecker.Normalize.Unfolding - -let dbg_univ_norm = Debug.get_toggle "univ_norm" -let dbg_NormRebuild = Debug.get_toggle "NormRebuild" - -(********************************************************************************************** - * Reduction of types via the Krivine Abstract Machine (KN), with lazy - * reduction and strong reduction (under binders), as described in: - * - * Strongly reducing variants of the Krivine abstract machine - * Pierre Crégut - * Higher-Order Symb Comput (2007) 20: 209–230 - **********************************************************************************************) - -let maybe_debug (cfg:Cfg.cfg) (t:term) (dbg:option (term & BU.time)) = - if cfg.debug.print_normalized - then match dbg with - | Some (tm, time_then) -> - let time_now = BU.now () in - // BU.print1 "Normalizer result timing (%s ms)\n" - // (show (snd (BU.time_diff time_then time_now))) - BU.print4 "Normalizer result timing (%s ms){\nOn term {\n%s\n}\nwith steps {%s}\nresult is{\n\n%s\n}\n}\n" - (show (snd (BU.time_diff time_then time_now))) - (show tm) - (show cfg) - (show t) - | _ -> () - -let cases f d = function - | Some x -> f x - | None -> d - -(* We memoize the normal form of variables in the environment, in - * order to implement call-by-need and avoid an exponential explosion, - * but we take care to only reuse memoized values when the cfg has not - * changed. The main reason is normalization requests, which can "grow" - * the set of allowed computations steps, and hence we may memoize - * something during the request that is used outside of it. This will - * essentially make it invalid. See issue #2155 in Github. - * - * We compare the cfg with physical equality, so it has to be the - * exact same object in memory. See read_memo and set_memo below. *) -type cfg_memo 'a = memo (Cfg.cfg & 'a) - -let fresh_memo (#a:Type) () : memo a = BU.mk_ref None - -type closure = - | Clos of env & term & cfg_memo (env & term) & bool //memo for lazy evaluation; bool marks whether or not this is a fixpoint - | Univ of universe //universe terms do not have free variables - | Dummy //Dummy is a placeholder for a binder when doing strong reduction -and env = list (option binder & closure & memo subst_t) - -instance showable_memo (a:Type) (_ : showable a) : Tot (showable (memo a)) = { - show = (fun m -> match !m with - | None -> "no_memo" - | Some x -> "memo=" ^ show x) -} - -let empty_env : env = [] - -let dummy () : (option binder & closure & memo subst_t) = (None, Dummy, fresh_memo ()) - -type branches = list (pat & option term & term) - -type stack_elt = - | Arg of closure & aqual & Range.range - | UnivArgs of list universe & Range.range // NB: universes must be values already, no bvars allowed - | MemoLazy of cfg_memo (env & term) - | Match of env & option match_returns_ascription & branches & option residual_comp & cfg & Range.range - | Abs of env & binders & env & option residual_comp & Range.range //the second env is the first one extended with the binders, for reducing the option lcomp - | App of env & term & aqual & Range.range - | CBVApp of env & term & aqual & Range.range - | Meta of env & S.metadata & Range.range - | Let of env & binders & letbinding & Range.range -type stack = list stack_elt - -let head_of t = let hd, _ = U.head_and_args_full t in hd - -(* Decides whether a memo taken in config c1 is valid when reducing in config c2. *) -let cfg_equivalent (c1 c2 : Cfg.cfg) : bool = - c1.steps =? c2.steps && - c1.delta_level =? c2.delta_level && - c1.normalize_pure_lets =? c2.normalize_pure_lets - -let read_memo cfg (r:memo (Cfg.cfg & 'a)) : option 'a = - match !r with - (* We only take this memoized value if the cfg matches the current - one, or if we are running in compatibility mode for it. *) - | Some (cfg', a) when cfg.compat_memo_ignore_cfg || BU.physical_equality cfg cfg' || cfg_equivalent cfg' cfg -> - Some a - | _ -> None - -let set_memo cfg (r:memo (Cfg.cfg & 'a)) (t:'a) : unit = - if cfg.memoize_lazy then begin - (* We do this only as a sanity check. The only situation where we - * should set a memo again is when the cfg has changed. *) - if Option.isSome (read_memo cfg r) then - failwith "Unexpected set_memo: thunk already evaluated"; - r := Some (cfg, t) - end - -let closure_to_string = function - | Clos (env, t, _, _) -> BU.format2 "(env=%s elts; %s)" (List.length env |> string_of_int) (show t) - | Univ _ -> "Univ" - | Dummy -> "dummy" - -instance showable_closure : showable closure = { - show = closure_to_string; -} - -instance showable_stack_elt : showable stack_elt = { - show = (function - | Arg (c, _, _) -> BU.format1 "Closure %s" (show c) - | MemoLazy _ -> "MemoLazy" - | Abs (_, bs, _, _, _) -> BU.format1 "Abs %s" (show <| List.length bs) - | UnivArgs _ -> "UnivArgs" - | Match _ -> "Match" - | App (_, t,_,_) -> BU.format1 "App %s" (show t) - | CBVApp (_, t,_,_) -> BU.format1 "CBVApp %s" (show t) - | Meta (_, m,_) -> "Meta" - | Let _ -> "Let"); -} - -let is_empty = function - | [] -> true - | _ -> false - -let lookup_bvar (env : env) x = - try (List.nth env x.index)._2 - with _ -> failwith (BU.format2 "Failed to find %s\nEnv is %s\n" (show x) (show env)) - -let downgrade_ghost_effect_name l = - if Ident.lid_equals l PC.effect_Ghost_lid - then Some PC.effect_Pure_lid - else if Ident.lid_equals l PC.effect_GTot_lid - then Some PC.effect_Tot_lid - else if Ident.lid_equals l PC.effect_GHOST_lid - then Some PC.effect_PURE_lid - else None - -(********************************************************************************************************************) -(* Normal form of a universe u is *) -(* either u, where u <> U_max *) -(* or U_max [k; --constant *) -(* S^n1 u1 ; ...; S^nm um; --offsets of distinct names, in order of the names *) -(* S^p1 ?v1; ...; S^pq ?vq] --offsets of distinct unification variables, in order of the variables *) -(* where the size of the list is at least 2 *) -(********************************************************************************************************************) -let norm_universe cfg (env:env) u = - let norm_univs_for_max us = - let us = BU.sort_with U.compare_univs us in - (* us is in sorted order; *) - (* so, for each sub-sequence in us with a common kernel, just retain the largest one *) - (* e.g., normalize [Z; S Z; S S Z; u1; S u1; u2; S u2; S S u2; ?v1; S ?v1; ?v2] *) - (* to [ S S Z; S u1; S S u2; S ?v1; ?v2] *) - let _, u, out = - List.fold_left (fun (cur_kernel, cur_max, out) u -> - let k_u, n = U.univ_kernel u in - if U.eq_univs cur_kernel k_u //streak continues - then (cur_kernel, u, out) //take u as the current max of the streak - else (k_u, u, cur_max::out)) //streak ends; include cur_max in the output and start a new streak - (U_zero, U_zero, []) us in - List.rev (u::out) in - - (* normalize u by *) - (* 1. flattening all max nodes *) - (* 2. pushing all S nodes under a single top-level max node *) - (* 3. sorting the terms in a max node, and partially evaluate it *) - let rec aux (u:universe) : list universe = - let u = Subst.compress_univ u in - match u with - | U_bvar x -> - begin - try match (List.nth env x)._2 with - | Univ u -> - if !dbg_univ_norm then - BU.print1 "Univ (in norm_universe): %s\n" (show u) - else (); aux u - | Dummy -> [u] - | _ -> failwith (BU.format1 "Impossible: universe variable u@%s bound to a term" - (string_of_int x)) - with _ -> if cfg.steps.allow_unbound_universes - then [U_unknown] - else failwith ("Universe variable not found: u@" ^ string_of_int x) - end - | U_unif _ when cfg.steps.default_univs_to_zero -> - [U_zero] - - | U_unif _ when cfg.steps.check_no_uvars -> - failwith (BU.format2 "(%s) CheckNoUvars: unexpected universes variable remains: %s" - (Range.string_of_range (Env.get_range cfg.tcenv)) - (show u)) - - | U_zero - | U_unif _ - | U_name _ - | U_unknown -> [u] - | U_max [] -> [U_zero] - | U_max us -> - let us = List.collect aux us |> norm_univs_for_max in - begin match us with - | u_k::hd::rest -> - let rest = hd::rest in - begin match U.univ_kernel u_k with - | U_zero, n -> //if the constant term n - if rest |> List.for_all (fun u -> - let _, m = U.univ_kernel u in - n <= m) //is smaller than or equal to all the other terms in the max - then rest //then just exclude it - else us - | _ -> us - end - | _ -> us - end - | U_succ u -> List.map U_succ (aux u) in - - if cfg.steps.erase_universes - then U_unknown - else match aux u with - | [] - | [U_zero] -> U_zero - | [U_zero; u] -> u - | U_zero::us -> U_max us - | [u] -> u - | us -> U_max us - -let memo_or (m : memo 'a) (f : unit -> 'a) : 'a = - match !m with - | Some v -> v - | None -> - let v = f () in - m := Some v; - v - -let rec env_subst (env:env) : subst_t = - let compute () = - let (s, _) = - List.fold_left (fun (s, i) (_, c, _) -> - match c with - | Clos (e, t, memo, (* closed_memo, *) fix) -> - // let es = memo_or closed_memo (fun () -> env_subst e) in - let es = env_subst e in - let t = SS.subst es t |> SS.compress in - (DT (i, t) :: s, i+1) - | Univ u -> (UN (i, u) :: s, i+1) - | Dummy -> (s,i+1) - ) ([], 0) env - in - (* NB: The order of the list does not matter, we are building - a parallel substitution. *) - s - in - match env with - | [] -> [] - | (_, _, memo) :: _ -> - match !memo with - | Some s -> s - | None -> - let s = compute () in - memo := Some s; - s - -let filter_out_lcomp_cflags flags = - (* TODO : lc.comp might have more cflags than lcomp.cflags *) - flags |> List.filter (function DECREASES _ -> false | _ -> true) - -let default_univ_uvars_to_zero (t:term) : term = - Visit.visit_term_univs false (fun t -> t) (fun u -> - match u with - | U_unif _ -> U_zero - | _ -> u) t - -let _erase_universes (t:term) : term = - Visit.visit_term_univs false (fun t -> t) (fun u -> U_unknown) t - -let closure_as_term cfg (env:env) (t:term) : term = - log cfg (fun () -> BU.print3 ">>> %s (env=%s)\nClosure_as_term %s\n" (tag_of t) (show env) (show t)); - let es = env_subst env in - let t = SS.subst es t in - let t = - if cfg.steps.erase_universes - then _erase_universes t - else if cfg.steps.default_univs_to_zero - then default_univ_uvars_to_zero t - else t - in - (* Compress the top only since clients expect a compressed term *) - let t = SS.compress t in - log cfg (fun () -> BU.print3 ">>> %s (env=%s)\nClosure_as_term RESULT %s\n" (tag_of t) (show env) (show t)); - t - -(* A hacky knot, set by FStar.Main *) -let unembed_binder_knot : ref (option (EMB.embedding binder)) = BU.mk_ref None -let unembed_binder (t : term) : option S.binder = - match !unembed_binder_knot with - | Some e -> EMB.try_unembed #_ #e t EMB.id_norm_cb - | None -> - Errors.log_issue t Errors.Warning_UnembedBinderKnot "unembed_binder_knot is unset!"; - None - -let mk_psc_subst cfg (env:env) = - List.fold_right - (fun (binder_opt, closure, _) subst -> - match binder_opt, closure with - | Some b, Clos(env, term, _, _) -> - // BU.print1 "++++++++++++Name in environment is %s" (show b); - let bv = b.binder_bv in - if not (U.is_constructed_typ bv.sort PC.binder_lid) - then subst - else let term = closure_as_term cfg env term in - begin match unembed_binder term with - | None -> subst - | Some x -> - let b = S.freshen_bv ({bv with sort=SS.subst subst x.binder_bv.sort}) in - let b_for_x = S.NT(x.binder_bv, S.bv_to_name b) in - //remove names shadowed by b - let subst = List.filter (function NT(_, {n=Tm_name b'}) -> - not (Ident.ident_equals b.ppname b'.ppname) - | _ -> true) subst in - b_for_x :: subst - end - | _ -> subst) - env [] - -(* Boolean indicates whether further normalization of the result is -required. It is usually false, unless we call into a 'renorm' primitive -step. *) -let reduce_primops norm_cb cfg (env:env) tm : term & bool = - if not cfg.steps.primops - then tm, false - else begin - let head, args = U.head_and_args_full tm in - let head_term, universes = - let head = SS.compress (U.unmeta head) in - match head.n with - | Tm_uinst(fv, us) -> fv, us - | _ -> head, [] - in - match head_term.n with - | Tm_fvar fv -> begin - match find_prim_step cfg fv with - | Some prim_step when prim_step.strong_reduction_ok || not cfg.strong -> - let l = List.length args in - if l < prim_step.arity - then begin log_primops cfg (fun () -> BU.print3 "primop: found partially applied %s (%s/%s args)\n" - (show prim_step.name) - (show l) - (show prim_step.arity)); - tm, false //partial application; can't step - end - else begin - let args_1, args_2 = if l = prim_step.arity - then args, [] - else List.splitAt prim_step.arity args - in - log_primops cfg (fun () -> BU.print1 "primop: trying to reduce <%s>\n" (show tm)); - let psc : PO.psc = { - psc_range = head.pos; - psc_subst = fun () -> if prim_step.requires_binder_substitution - then mk_psc_subst cfg env - else [] - } in - let r = - if false - then begin let (r, ms) = BU.record_time (fun () -> prim_step.interpretation psc norm_cb universes args_1) in - primop_time_count (show fv.fv_name.v) ms; - r - end - else prim_step.interpretation psc norm_cb universes args_1 - in - match r with - | None -> - log_primops cfg (fun () -> BU.print1 "primop: <%s> did not reduce\n" (show tm)); - tm, false - | Some reduced -> - log_primops cfg (fun () -> BU.print2 "primop: <%s> reduced to %s\n" - (show tm) (show reduced)); - (* If prim_step.renorm_after is step, we will later - keep reducing this term. Otherwise we will just - rebuild. *) - U.mk_app reduced args_2, prim_step.renorm_after - end - | Some _ -> - log_primops cfg (fun () -> BU.print1 "primop: not reducing <%s> since we're doing strong reduction\n" - (show tm)); - tm, false - | None -> tm, false - end - - | Tm_constant Const_range_of when not cfg.strong -> - log_primops cfg (fun () -> BU.print1 "primop: reducing <%s>\n" (show tm)); - begin match args with - | [(a1, _)] -> PO.embed_simple a1.pos tm.pos, false - | _ -> tm, false - end - - | Tm_constant Const_set_range_of when not cfg.strong -> - log_primops cfg (fun () -> BU.print1 "primop: reducing <%s>\n" (show tm)); - begin match args with - | [(t, _); (r, _)] -> - begin match PO.try_unembed_simple r with - | Some rng -> Subst.set_use_range rng t, false - | None -> tm, false - end - | _ -> tm, false - end - - | _ -> tm, false - end - -let reduce_equality norm_cb cfg tm = - reduce_primops norm_cb ({cfg with steps = { default_steps with primops = true }; - primitive_steps=simplification_steps cfg.tcenv}) tm - -(********************************************************************************************************************) -(* Main normalization function of the abstract machine *) -(********************************************************************************************************************) - -(* - * AR: norm requests can some times have additional arguments since we flatten the arguments sometimes in the typechecker - * so, a request may look like: normalize_term [a; b; c; d] - * in such cases, we rejig the request to be (normalize_term a) [b; c; d] - *) -type norm_request_t = - | Norm_request_none //not a norm request - | Norm_request_ready //in the form that can be reduced immediately - | Norm_request_requires_rejig //needs rejig - -let is_norm_request (hd:term) (args:args) :norm_request_t = - let aux (min_args:int) :norm_request_t = args |> List.length |> (fun n -> if n < min_args then Norm_request_none - else if n = min_args then Norm_request_ready - else Norm_request_requires_rejig) - in - match (U.un_uinst hd).n with - | Tm_fvar fv when S.fv_eq_lid fv PC.normalize_term -> aux 2 - | Tm_fvar fv when S.fv_eq_lid fv PC.normalize -> aux 1 - | Tm_fvar fv when S.fv_eq_lid fv PC.norm -> aux 3 - | _ -> Norm_request_none - -let should_consider_norm_requests cfg = (not (cfg.steps.no_full_norm)) && (not (Ident.lid_equals cfg.tcenv.curmodule PC.prims_lid)) - -let rejig_norm_request (hd:term) (args:args) :term = - match (U.un_uinst hd).n with - | Tm_fvar fv when S.fv_eq_lid fv PC.normalize_term -> - (match args with - | t1::t2::rest when List.length rest > 0 -> mk_app (mk_app hd [t1; t2]) rest - | _ -> failwith "Impossible! invalid rejig_norm_request for normalize_term") - | Tm_fvar fv when S.fv_eq_lid fv PC.normalize -> - (match args with - | t::rest when List.length rest > 0 -> mk_app (mk_app hd [t]) rest - | _ -> failwith "Impossible! invalid rejig_norm_request for normalize") - | Tm_fvar fv when S.fv_eq_lid fv PC.norm -> - (match args with - | t1::t2::t3::rest when List.length rest > 0 -> mk_app (mk_app hd [t1; t2; t3]) rest - | _ -> failwith "Impossible! invalid rejig_norm_request for norm") - | _ -> failwith ("Impossible! invalid rejig_norm_request for: %s" ^ (show hd)) - -let is_nbe_request s = BU.for_some ((=?) NBE) s - -let get_norm_request cfg (full_norm:term -> term) args = - let parse_steps s = - match PO.try_unembed_simple s with - | Some steps -> Some (Cfg.translate_norm_steps steps) - | None -> None - in - let inherited_steps = - (if cfg.steps.erase_universes then [EraseUniverses] else []) - @ (if cfg.steps.allow_unbound_universes then [AllowUnboundUniverses] else []) - @ (if cfg.steps.nbe_step then [NBE] else []) // ZOE : NBE can be set as the default mode - in - (* We always set UnfoldTac: do not unfold logical connectives *) - match args with - | [_; (tm, _)] - | [(tm, _)] -> - let s = [Beta; Zeta; Iota; Primops; UnfoldUntil delta_constant; Reify] in - Some (DontUnfoldAttr [PC.tac_opaque_attr] :: inherited_steps @ s, tm) - | [(steps, _); _; (tm, _)] -> - begin - match parse_steps (full_norm steps) with - | None -> None - | Some s -> Some (DontUnfoldAttr [PC.tac_opaque_attr] :: inherited_steps @ s, tm) - end - | _ -> - None - -let nbe_eval (cfg:cfg) (s:steps) (tm:term) : term = - let delta_level = - if s |> BU.for_some (function UnfoldUntil _ | UnfoldOnly _ | UnfoldFully _ -> true | _ -> false) - then [Unfold delta_constant] - else [NoDelta] in - log_nbe cfg (fun () -> BU.print1 "Invoking NBE with %s\n" (show tm)); - let tm_norm = (cfg_env cfg).nbe s cfg.tcenv tm in - log_nbe cfg (fun () -> BU.print1 "Result of NBE is %s\n" (show tm_norm)); - tm_norm - -let firstn k l = if List.length l < k then l,[] else first_N k l -let should_reify cfg stack = - let rec drop_irrel = function - | MemoLazy _ :: s - | UnivArgs _ :: s -> - drop_irrel s - | s -> s - in - match drop_irrel stack with - | App (_, {n=Tm_constant (FC.Const_reify _)}, _, _) :: _ -> - // BU.print1 "Found a reify on the stack. %s" "" ; - cfg.steps.reify_ - | _ -> false - -// GM: What is this meant to decide? -let rec maybe_weakly_reduced tm : bool = - let aux_comp c = - match c.n with - | GTotal t - | Total t -> - maybe_weakly_reduced t - - | Comp ct -> - maybe_weakly_reduced ct.result_typ - || BU.for_some (fun (a, _) -> maybe_weakly_reduced a) ct.effect_args - in - let t = Subst.compress tm in - match t.n with - | Tm_delayed _ -> failwith "Impossible" - - | Tm_name _ - | Tm_uvar _ - | Tm_type _ - | Tm_bvar _ - | Tm_fvar _ - | Tm_constant _ - | Tm_lazy _ - | Tm_unknown - | Tm_uinst _ - | Tm_quoted _ -> false - - | Tm_let _ - | Tm_abs _ - | Tm_arrow _ - | Tm_refine _ - | Tm_match _ -> - true - - | Tm_app {hd=t; args} -> - maybe_weakly_reduced t - || (args |> BU.for_some (fun (a, _) -> maybe_weakly_reduced a)) - - | Tm_ascribed {tm=t1; asc} -> - maybe_weakly_reduced t1 - || (let asc_tc, asc_tac, _ = asc in - (match asc_tc with - | Inl t2 -> maybe_weakly_reduced t2 - | Inr c2 -> aux_comp c2) - || - (match asc_tac with - | None -> false - | Some tac -> maybe_weakly_reduced tac)) - - | Tm_meta {tm=t; meta=m} -> - maybe_weakly_reduced t - || (match m with - | Meta_pattern (_, args) -> - BU.for_some (BU.for_some (fun (a, _) -> maybe_weakly_reduced a)) args - - | Meta_monadic_lift(_, _, t') - | Meta_monadic(_, t') -> - maybe_weakly_reduced t' - - | Meta_labeled _ - | Meta_desugared _ - | Meta_named _ -> false) - -let decide_unfolding cfg stack fv qninfo (* : option (option cfg * stack) *) = - let res = - should_unfold cfg (fun cfg -> should_reify cfg stack) fv qninfo - in - match res with - | Should_unfold_no -> - // No unfolding - None - | Should_unfold_yes -> - // Usual unfolding, no change to cfg or stack - Some (None, stack) - | Should_unfold_fully -> - // Unfolding fully, use new cfg with more steps and keep old one in stack - let cfg' = - { cfg with steps = { cfg.steps with - unfold_only = None - ; unfold_fully = None - ; unfold_attr = None - ; unfold_qual = None - ; unfold_namespace = None - ; unfold_until = Some delta_constant } } in - - (* Take care to not change the stack's head if there's a universe - * instantiation, but we do need to keep the old cfg. *) - (* This is ugly, and a recurring problem, but I'm working around it for now *) - Some (Some cfg', stack) - - | Should_unfold_reify -> - // Reifying, adding a reflect on the stack to cancel the reify - // NB: The fv in the Const_reflect is bogus, it'll be ignored anyway - let rec push e s = - match s with - | [] -> [e] - | UnivArgs (us, r) :: t -> UnivArgs (us, r) :: (push e t) - | h :: t -> e :: h :: t - in - let ref = S.mk (Tm_constant (Const_reflect (S.lid_of_fv fv))) - Range.dummyRange in - let stack = push (App (empty_env, ref, None, Range.dummyRange)) stack in - Some (None, stack) - -(* on_domain_lids are constant, so compute them once *) -let on_domain_lids = [ PC.fext_on_domain_lid; PC.fext_on_dom_lid; PC.fext_on_domain_g_lid; PC.fext_on_dom_g_lid ] - -let is_fext_on_domain (t:term) :option term = - let is_on_dom fv = on_domain_lids |> List.existsb (fun l -> S.fv_eq_lid fv l) in - - match (SS.compress t).n with - | Tm_app {hd; args} -> - (match (U.un_uinst hd).n with - | Tm_fvar fv when is_on_dom fv && List.length args = 3 -> //first two are type arguments, third is the function - let f = args |> List.tl |> List.tl |> List.hd |> fst in //get f - Some f - | _ -> None) - | _ -> None - -(* Set below. Used by the simplifier. *) -let __get_n_binders : ref ((env:Env.env) -> list step -> (n:int) -> (t:term) -> list binder & comp) = - BU.mk_ref (fun e s n t -> failwith "Impossible: __get_n_binders unset") - -(* Returns `true` iff the head of `t` is a primop, and -it not applied or only partially applied. *) -let is_partial_primop_app (cfg:Cfg.cfg) (t:term) : bool = - let hd, args = U.head_and_args t in - match (U.un_uinst hd).n with - | Tm_fvar fv -> - begin match find_prim_step cfg fv with - | Some prim_step -> prim_step.arity > List.length args - | None -> false - end - | _ -> false - -let maybe_drop_rc_typ cfg (rc:residual_comp) : residual_comp = - if cfg.steps.for_extraction - then {rc with residual_typ = None} - else rc - -let get_extraction_mode env (m:Ident.lident) = - let norm_m = Env.norm_eff_name env m in - (Env.get_effect_decl env norm_m).extraction_mode - -let can_reify_for_extraction env (m:Ident.lident) = - (get_extraction_mode env m) = S.Extract_reify - -(* Checks if a list of arguments matches some binders exactly *) -let rec args_are_binders args bs : bool = - match args, bs with - | (t, _)::args, b::bs -> - begin match (SS.compress t).n with - | Tm_name bv' -> S.bv_eq b.binder_bv bv' && args_are_binders args bs - | _ -> false - end - | [], [] -> true - | _, _ -> false - -(* Is t a variable applied to exactly bs? If so return it. *) -let is_applied cfg (bs:binders) (t : term) : option bv = - if cfg.debug.wpe then - BU.print2 "WPE> is_applied %s -- %s\n" (show t) (tag_of t); - let hd, args = U.head_and_args_full t in - match (SS.compress hd).n with - | Tm_name bv when args_are_binders args bs -> - if cfg.debug.wpe then - BU.print3 "WPE> got it\n>>>>top = %s\n>>>>b = %s\n>>>>hd = %s\n" - (show t) - (show bv) - (show hd); - Some bv - | _ -> None - -(* As above accounting for squashes *) -let is_applied_maybe_squashed cfg (bs : binders) (t : term) : option bv = - if cfg.debug.wpe then - BU.print2 "WPE> is_applied_maybe_squashed %s -- %s\n" (show t) (tag_of t); - match is_squash t with - | Some (_, t') -> is_applied cfg bs t' - | _ -> begin match is_auto_squash t with - | Some (_, t') -> is_applied cfg bs t' - | _ -> is_applied cfg bs t - end - -let is_quantified_const cfg (bv:bv) (phi : term) : option term = - let open FStar.Syntax.Formula in - let open FStar.Class.Monad in - let guard (b:bool) : option unit = if b then Some () else None in - - let phi0 = phi in - let types_match bs = - (* We need to make sure that the forall above is over the same types - as those in the domain of `f`. See bug #3213. *) - let bs_q, _ = !__get_n_binders cfg.tcenv [AllowUnboundUniverses] (List.length bs) bv.sort in - let rec unrefine_true (t:term) : term = - (* Discard trivial refinements. *) - match (SS.compress t).n with - | Tm_refine {b; phi} when U.term_eq phi U.t_true -> unrefine_true b.sort - | _ -> t - in - List.length bs = List.length bs_q && - List.forall2 (fun b1 b2 -> - let s1 = b1.binder_bv.sort |> unrefine_true in - let s2 = b2.binder_bv.sort |> unrefine_true in - U.term_eq s1 s2) - bs bs_q - in - let is_bv (bv:S.bv) (t:term) = - match (SS.compress t).n with - | Tm_name bv' -> S.bv_eq bv bv' - | _ -> false - in - let replace_full_applications_with (bv:S.bv) (arity:int) (s:term) (t:term) : term & bool = - let chgd = BU.mk_ref false in - let t' = t |> Syntax.Visit.visit_term false (fun t -> - let hd, args = U.head_and_args t in - if List.length args = arity && is_bv bv hd then ( - chgd := true; - s - ) else - t) - in - t', !chgd - in - let! form = destruct_typ_as_formula phi in - match form with - | BaseConn (lid, [(p, _); (q, _)]) when Ident.lid_equals lid PC.imp_lid -> - if cfg.debug.wpe then - BU.print2 "WPE> p = (%s); q = (%s)\n" - (show p) - (show q); - let! q' = - begin match destruct_typ_as_formula p with - (* Case 1 *) - | None -> begin match (SS.compress p).n with - | Tm_bvar bv' when S.bv_eq bv bv' -> - if cfg.debug.wpe then - BU.print_string "WPE> Case 1\n"; - let q' = SS.subst [NT (bv, U.t_true)] q in - Some q' - | _ -> None - end - (* Case 2 *) - | Some (BaseConn (lid, [(p, _)])) when Ident.lid_equals lid PC.not_lid -> - begin match (SS.compress p).n with - | Tm_bvar bv' when S.bv_eq bv bv' -> - if cfg.debug.wpe then - BU.print_string "WPE> Case 2\n"; - let q' = SS.subst [NT (bv, U.t_false)] q in - Some q' - | _ -> None - end - | Some (QAll (bs, pats, phi)) when types_match bs -> - begin match destruct_typ_as_formula phi with - | None -> - let! bv' = is_applied_maybe_squashed cfg bs phi in - guard (S.bv_eq bv bv');! - (* Case 3 *) - if cfg.debug.wpe then - BU.print_string "WPE> Case 3\n"; - let q', chgd = replace_full_applications_with bv (List.length bs) U.t_true q in - guard chgd;! (* If nothing triggered, do not rewrite to itself to avoid infinite loops *) - Some q' - | Some (BaseConn (lid, [(p, _)])) when Ident.lid_equals lid PC.not_lid -> - let! bv' = is_applied_maybe_squashed cfg bs p in - guard (S.bv_eq bv bv');! - if cfg.debug.wpe then - BU.print_string "WPE> Case 4\n"; - let q', chgd = replace_full_applications_with bv (List.length bs) U.t_false q in - guard chgd;! - Some q' - | _ -> - None - end - | _ -> None - end - in - let phi' = U.mk_app (S.fvar PC.imp_lid None) [S.as_arg p; S.as_arg q'] in - Some phi' - | _ -> None - -// A very F*-specific optimization: -// 1) forall f. (f ==> E[f]) ~> E[True] -// 2) forall f. (~f ==> E[f]) ~> E[False] -// -// 3) forall f. (forall j1 ... jn. f j1 ... jn) ==> E -// ~> forall f. (forall j1 ... jn. f j1 ... jn) ==> E', where every full application of `f` to `n` binders is rewritten to true -// -// 4) forall f. (forall j1 ... jn. ~(f j1 ... jn)) ==> E -// ~> forall f. (forall j1 ... jn. ~(f j1 ... jn)) ==> E', idem rewriting to false -// reurns the rewritten formula. -let is_forall_const cfg (phi : term) : option term = - let open FStar.Syntax.Formula in - match Syntax.Formula.destruct_typ_as_formula phi with - | Some (QAll ([b], _, phi')) -> - let open FStar.Class.Monad in - if cfg.debug.wpe then - BU.print2 "WPE> QAll [%s] %s\n" (show b.binder_bv) (show phi'); - let! phi' = is_quantified_const cfg b.binder_bv phi' in - Some (U.mk_forall (cfg.tcenv.universe_of cfg.tcenv b.binder_bv.sort) b.binder_bv phi') - - | _ -> None - -let is_extract_as_attr (attr: attribute) : option term = - let head, args = head_and_args attr in - match (Subst.compress head).n, args with - | Tm_fvar fv, [t, _] when Syntax.fv_eq_lid fv PC.extract_as_lid -> - (match (Subst.compress t).n with - | Tm_quoted(impl, _) -> Some impl - | _ -> None) - | _ -> None - -let has_extract_as_attr (g: Env.env) (lid: I.lid) : option term = - match Env.lookup_attrs_of_lid g lid with - | Some attrs -> find_map attrs is_extract_as_attr - | None -> None - -(* GM: Please consider this function private outside of this recursive - * group, and call `normalize` instead. `normalize` will print timing - * information when --debug NormTop is given, which makes it a - * whole lot easier to find normalization calls that are taking a long - * time. *) -let rec norm : cfg -> env -> stack -> term -> term = - fun cfg env stack t -> - let rec collapse_metas st = - match st with - (* Keep only the outermost Meta_monadic *) - | Meta (_, Meta_monadic _, _) :: Meta(e, Meta_monadic m, r) :: st' -> - collapse_metas (Meta (e, Meta_monadic m, r) :: st') - | _ -> st - in - let stack = collapse_metas stack in - let t = - if cfg.debug.norm_delayed - then (match t.n with - | Tm_delayed _ -> - BU.print1 "NORM delayed: %s\n" (show t) - | _ -> ()); - compress t - in - log cfg (fun () -> - BU.print5 ">>> %s (no_full_norm=%s)\nNorm %s with %s env elements; top of the stack = %s\n" - (tag_of t) - (show cfg.steps.no_full_norm) - (show t) - (show (List.length env)) - (show (fst <| firstn 4 stack))); - log_cfg cfg (fun () -> BU.print1 ">>> cfg = %s\n" (show cfg)); - match t.n with - // Values - | Tm_unknown - | Tm_constant _ - | Tm_name _ - | Tm_lazy _ -> - rebuild cfg empty_env stack t - - // These three are just constructors; no delta steps can apply. - // Note: we drop the environment, no free indices here - | Tm_fvar({ fv_qual = Some Data_ctor }) - | Tm_fvar({ fv_qual = Some (Record_ctor _) }) -> - log_unfolding cfg (fun () -> BU.print1 " >> This is a constructor: %s\n" (show t)); - rebuild cfg empty_env stack t - - // A top-level name, possibly unfold it. - // In either case, also drop the environment, no free indices here. - | Tm_fvar fv -> - let lid = S.lid_of_fv fv in - let qninfo = Env.lookup_qname cfg.tcenv lid in - begin - match Env.delta_depth_of_qninfo cfg.tcenv fv qninfo with - | Delta_constant_at_level 0 -> - log_unfolding cfg (fun () -> BU.print1 " >> This is a constant: %s\n" (show t)); - rebuild cfg empty_env stack t - | _ -> - match decide_unfolding cfg stack fv qninfo with - | Some (None, stack) -> do_unfold_fv cfg stack t qninfo fv - | Some (Some cfg, stack) -> - do_unfold_fv cfg [] t qninfo fv |> rebuild cfg empty_env stack - | None -> rebuild cfg empty_env stack t - end - - | Tm_quoted (qt, qi) -> - let qi = S.on_antiquoted (norm cfg env []) qi in - let t = mk (Tm_quoted (qt, qi)) t.pos in - rebuild cfg env stack (closure_as_term cfg env t) - - | Tm_app {hd; args} - when should_consider_norm_requests cfg && - is_norm_request hd args = Norm_request_requires_rejig -> - if cfg.debug.print_normalized - then BU.print_string "Rejigging norm request ... \n"; - norm cfg env stack (rejig_norm_request hd args) - - | Tm_app {hd; args} - when should_consider_norm_requests cfg && - is_norm_request hd args = Norm_request_ready -> - if cfg.debug.print_normalized - then BU.print2 "Potential norm request with hd = %s and args = %s ... \n" - (show hd) (Print.args_to_string args); - - let cfg' = { cfg with steps = { cfg.steps with unfold_only = None - ; unfold_fully = None - ; do_not_unfold_pure_lets = false }; - delta_level=[Unfold delta_constant]; - normalize_pure_lets=true} in - begin - match get_norm_request cfg (norm cfg' env []) args with - | None -> //just normalize it as a normal application - if cfg.debug.print_normalized - then BU.print_string "Norm request None ... \n"; - let stack = - stack |> - List.fold_right - (fun (a, aq) stack -> Arg (Clos(env, a, fresh_memo (), false),aq,t.pos)::stack) - args - in - log cfg (fun () -> BU.print1 "\tPushed %s arguments\n" (string_of_int <| List.length args)); - norm cfg env stack hd - - | Some (s, tm) when is_nbe_request s -> - let tm' = closure_as_term cfg env tm in - let start = BU.now() in - let tm_norm = nbe_eval cfg s tm' in - let fin = BU.now () in - if cfg.debug.print_normalized - then begin - let cfg' = Cfg.config s cfg.tcenv in - // BU.print1 "NBE result timing (%s ms)\n" - // (show (snd (BU.time_diff start fin))) - BU.print4 "NBE result timing (%s ms){\nOn term {\n%s\n}\nwith steps {%s}\nresult is{\n\n%s\n}\n}\n" - (show (snd (BU.time_diff start fin))) - (show tm') - (show cfg') - (show tm_norm) - end; - rebuild cfg env stack tm_norm - - | Some (s, tm) -> - let open FStar.Errors.Msg in - let open FStar.Pprint in - if cfg.debug.print_normalized then - Errors.diag tm.pos [ - text <| BU.format1 "Starting norm request on `%s`." (show tm); - text "Steps =" ^/^ text (show s); - ]; - let delta_level = - if s |> BU.for_some (function UnfoldUntil _ | UnfoldOnly _ | UnfoldFully _ -> true | _ -> false) - then [Unfold delta_constant] - else if cfg.steps.for_extraction - then [Env.Eager_unfolding_only; Env.InliningDelta] - else [NoDelta] - in - let cfg' = {cfg with steps = ({ to_fsteps s - with in_full_norm_request=true; - for_extraction=cfg.steps.for_extraction}) - ; delta_level = delta_level - ; normalize_pure_lets = true } in - (* We reduce the term in an empty stack to prevent unwanted interactions. - Later, we rebuild the normalized term with the current stack. This is - not a tail-call, but this happens rarely enough that it should not be a problem. *) - let t0 = BU.now () in - let (tm_normed, ms) = BU.record_time (fun () -> norm cfg' env [] tm) in - maybe_debug cfg tm_normed (Some (tm, t0)); - rebuild cfg env stack tm_normed - end - - | Tm_type u -> - let u = norm_universe cfg env u in - rebuild cfg env stack (mk (Tm_type u) t.pos) - - | Tm_uinst(t', us) -> - if cfg.steps.erase_universes - then norm cfg env stack t' - else let us = UnivArgs(List.map (norm_universe cfg env) us, t.pos) in - let stack = us::stack in - norm cfg env stack t' - - | Tm_bvar x -> - begin match lookup_bvar env x with - | Univ _ -> failwith "Impossible: term variable is bound to a universe" - | Dummy -> failwith "Term variable not found" - | Clos(env, t0, r, fix) -> - if not fix - || cfg.steps.zeta - || cfg.steps.zeta_full - then match read_memo cfg r with - | Some (env, t') -> - log cfg (fun () -> BU.print2 "Lazy hit: %s cached to %s\n" (show t) (show t')); - if maybe_weakly_reduced t' - then match stack with - | [] when cfg.steps.weak || cfg.steps.compress_uvars -> - rebuild cfg env stack t' - | _ -> norm cfg env stack t' - else rebuild cfg env stack t' - | None -> norm cfg env (MemoLazy r::stack) t0 - else norm cfg env stack t0 //Fixpoint steps are excluded; so don't take the recursive knot - end - - | Tm_abs {bs; body; rc_opt=rc_opt} -> - // - //AR/NS: 04/26/2022: - // In the case of metaprograms, we reduce DIV computations in the - // normalizer. As a result, it could be that an abs node is - // wrapped in a Meta_monadic (lift or just DIV) - // The following code ensures that such meta wrappers do not - // block reduction - // Specifically, if the stack looks like (from top): - // [Meta; Meta; ..; Meta; Arg; ...] - // Then we remove the meta nodes so that the following argument - // can be applied to the lambda - // We only remove DIV and PURE ~> DIV lifts - // - - // - // Precondition for calling: top of stack should be a Meta - // - // Returns Some st, when st is some meta nodes stripped off from stack - // None, when the stack does not have the shape noted above - // - let rec maybe_strip_meta_divs stack = - let open FStar.Ident in - match stack with - | [] -> None - | Meta (_, Meta_monadic (m, _), _)::tl - when lid_equals m PC.effect_DIV_lid -> - maybe_strip_meta_divs tl - | Meta (_, Meta_monadic_lift (src, tgt, _), _)::tl - when lid_equals src PC.effect_PURE_lid && - lid_equals tgt PC.effect_DIV_lid -> - maybe_strip_meta_divs tl - | Arg _::_ -> Some stack //due to the precondition, this case doesn't arise in the top-level call - | _ -> None - in - - // - // Reducing lambda body if strong reduction, - // rebuild otherwise - // - let fallback () = - if cfg.steps.weak - then let t = closure_as_term cfg env t in - rebuild cfg env stack t - else let bs, body, opening = open_term' bs body in - let env' = bs |> List.fold_left (fun env _ -> dummy () ::env) env in - let rc_opt = - let open FStar.Class.Monad in - let! rc = rc_opt in - let rc = maybe_drop_rc_typ cfg rc in - Some {rc with residual_typ = BU.map_option (SS.subst opening) rc.residual_typ} - in - log cfg (fun () -> BU.print1 "\tShifted %s dummies\n" (string_of_int <| List.length bs)); - let cfg' = { cfg with strong = true } in - let body_norm = norm cfg env' (Abs(env, bs, env', rc_opt, t.pos) :: []) body in - rebuild cfg env stack body_norm - in - begin match stack with - | UnivArgs _::_ -> - failwith "Ill-typed term: universes cannot be applied to term abstraction" - - | Arg (Univ u, _, _)::stack_rest -> - norm cfg ((None, Univ u, fresh_memo ()) :: env) stack_rest t - // universe variables do not have explicit binders - - | Arg (c, _, _)::stack_rest -> - (* Note: we peel off one application at a time. - An optimization to attempt would be to push n-args are once, - and try to pop all of them at once, in the common case of a full application. - *) - begin match bs with - | [] -> failwith "Impossible" - | [b] -> - log cfg (fun () -> BU.print1 "\tShifted %s\n" (show c)); - norm cfg ((Some b, c, fresh_memo()) :: env) stack_rest body - | b::tl -> - log cfg (fun () -> BU.print1 "\tShifted %s\n" (show c)); - let body = mk (Tm_abs {bs=tl; body; rc_opt}) t.pos in - norm cfg ((Some b, c, fresh_memo()) :: env) stack_rest body - end - - | MemoLazy r :: stack -> - set_memo cfg r (env, t); //We intentionally do not memoize the strong normal form; only the WHNF - log cfg (fun () -> BU.print1 "\tSet memo %s\n" (show t)); - norm cfg env stack t - - | Meta _::_ -> - // - //Top of the stack is a meta, try stripping meta DIV nodes that - // may be blocking reduction - // - (match maybe_strip_meta_divs stack with - | None -> fallback () - | Some stack -> norm cfg env stack t) - | Match _::_ - | Let _ :: _ - | App _ :: _ - | CBVApp _ :: _ - | Abs _ :: _ - | [] -> - fallback () - end - - | Tm_app {hd=head; args} -> - let strict_args = - match (head |> U.unascribe |> U.un_uinst).n with - | Tm_fvar fv -> Env.fv_has_strict_args cfg.tcenv fv - | _ -> None - in - begin - match strict_args with - | None -> - let stack = - List.fold_right - (fun (a, aq) stack -> - let a = - if ((Cfg.cfg_env cfg).erase_erasable_args || - cfg.steps.for_extraction || - cfg.debug.erase_erasable_args) //just for experimentation - && U.aqual_is_erasable aq //If we're extracting, then erase erasable arguments eagerly - then U.exp_unit - else a - in - // !! Optimization: if the argument we are pushing is an obvious - // value/closed term, then drop the environment. This can save - // a ton of memory, particularly when running tactics in tight loop. - let env = - match (Subst.compress a).n with - | Tm_name _ - | Tm_constant _ - | Tm_lazy _ - | Tm_fvar _ -> empty_env - | _ -> env - in - Arg (Clos(env, a, fresh_memo (), false),aq,t.pos)::stack) - args - stack - in - log cfg (fun () -> BU.print1 "\tPushed %s arguments\n" (string_of_int <| List.length args)); - norm cfg env stack head - - | Some strict_args -> - // BU.print2 "%s has strict args %s\n" (show head) (show strict_args); - let norm_args = args |> List.map (fun (a, i) -> (norm cfg env [] a, i)) in - let norm_args_len = List.length norm_args in - if strict_args - |> List.for_all (fun i -> - if i >= norm_args_len then false - else - let arg_i, _ = List.nth norm_args i in - let head, _ = arg_i |> U.unmeta_safe |> U.head_and_args in - match (un_uinst head).n with - | Tm_constant _ -> true - | Tm_fvar fv -> Env.is_datacon cfg.tcenv (S.lid_of_fv fv) - | _ -> false) - then //all strict args have constant head symbols - let stack = - stack |> - List.fold_right (fun (a, aq) stack -> - Arg (Clos(env, a, BU.mk_ref (Some (cfg, ([], a))), false),aq,t.pos)::stack) - norm_args - in - log cfg (fun () -> BU.print1 "\tPushed %s arguments\n" (string_of_int <| List.length args)); - norm cfg env stack head - else let head = closure_as_term cfg env head in - let term = S.mk_Tm_app head norm_args t.pos in - // let _ = - // BU.print3 "Rebuilding %s as %s\n%s\n" - // (show t) - // (show term) - // (BU.stack_dump()) - // in - rebuild cfg env stack term - end - - | Tm_refine {b=x} - when cfg.steps.for_extraction - || cfg.steps.unrefine -> - norm cfg env stack x.sort - - | Tm_refine {b=x; phi=f} -> //non tail-recursive; the alternative is to keep marks on the stack to rebuild the term ... but that's very heavy - if cfg.steps.weak - then match env, stack with - | [], [] -> //TODO: Make this work in general! - let t_x = norm cfg env [] x.sort in - let t = mk (Tm_refine {b={x with sort=t_x}; phi=f}) t.pos in - rebuild cfg env stack t - | _ -> rebuild cfg env stack (closure_as_term cfg env t) - else let t_x = norm cfg env [] x.sort in - let closing, f = open_term [mk_binder x] f in - let f = norm cfg (dummy () ::env) [] f in - let t = mk (Tm_refine {b={x with sort=t_x}; phi=close closing f}) t.pos in - rebuild cfg env stack t - - | Tm_arrow {bs; comp=c} -> - if cfg.steps.weak - then rebuild cfg env stack (closure_as_term cfg env t) - else let bs, c = open_comp bs c in - let c = norm_comp cfg (bs |> List.fold_left (fun env _ -> dummy () ::env) env) c in - let close_binders env (bs:binders) : binders = - SS.subst_binders (env_subst env) bs - in - let bs = if cfg.steps.hnf then close_binders env bs else norm_binders cfg env bs in - let t = arrow bs c in - rebuild cfg env stack t - - | Tm_ascribed {tm=t1; eff_opt=l} when cfg.steps.unascribe -> - norm cfg env stack t1 - - | Tm_ascribed {tm=t1; asc; eff_opt=l} -> - let rec stack_may_reduce s = - (* Decides if the ascription would block a reduction that would - otherwise happen. For instance if the stack begins with Arg it's - possible that t1 reduces to a lambda, so we should beta reduce. - Q: This may be better done in the rebuild phase, once we know the normal - form of t1? *) - match s with - | Match _ :: _ - | Arg _ :: _ - | App (_, {n=Tm_constant (FC.Const_reify _)}, _, _) :: _ - | MemoLazy _ :: _ when cfg.steps.beta -> - true - | _ -> - false - in - if stack_may_reduce stack then ( - log cfg (fun () -> BU.print_string "+++ Dropping ascription \n"); - norm cfg env stack t1 // Ascriptions should not block reduction - ) else ( - (* Drops stack *) - log cfg (fun () -> BU.print_string "+++ Keeping ascription \n"); - let t1 = norm cfg env [] t1 in - log cfg (fun () -> BU.print_string "+++ Normalizing ascription \n"); - let asc = norm_ascription cfg env asc in - rebuild cfg env stack (mk (Tm_ascribed {tm=U.unascribe t1; asc; eff_opt=l}) t.pos) - ) - - | Tm_match {scrutinee=head; ret_opt=asc_opt; brs=branches; rc_opt=lopt} -> - let lopt = BU.map_option (maybe_drop_rc_typ cfg) lopt in - let stack = Match(env, asc_opt, branches, lopt, cfg, t.pos)::stack in - if cfg.steps.iota - && cfg.steps.weakly_reduce_scrutinee - && not cfg.steps.weak - then let cfg' = { cfg with steps= { cfg.steps with weak = true } } in - let head_norm = norm cfg' env [] head in - rebuild cfg env stack head_norm - else norm cfg env stack head - - | Tm_let {lbs=(b, lbs); body=lbody} when is_top_level lbs && cfg.steps.compress_uvars -> - let lbs = lbs |> List.map (fun lb -> - let openings, lbunivs = Subst.univ_var_opening lb.lbunivs in - let cfg = { cfg with tcenv = Env.push_univ_vars cfg.tcenv lbunivs } in - let norm t = Subst.close_univ_vars lbunivs (norm cfg env [] (Subst.subst openings t)) in - let lbtyp = norm lb.lbtyp in - let lbdef = norm lb.lbdef in - { lb with lbunivs = lbunivs; lbtyp = lbtyp; lbdef = lbdef } - ) in - - rebuild cfg env stack (mk (Tm_let {lbs=(b, lbs); body=lbody}) t.pos) - - | Tm_let {lbs=(_, {lbname=Inr _}::_)} -> //this is a top-level let binding; nothing to normalize - rebuild cfg env stack t - - | Tm_let {lbs=(false, [lb]); body} -> - if Cfg.should_reduce_local_let cfg lb - then let binder = S.mk_binder (BU.left lb.lbname) in - (* If this let is effectful, and marked with @inline_let - * (and it passed the typechecker), then its definition - * must be pure. But, it will be lifted into an effectful - * computation. We need to remove it to maintain a proper - * term structure. See the discussion in PR #2024. *) - let def = U.unmeta_lift lb.lbdef in - let env = (Some binder, Clos(env, def, fresh_memo(), false), fresh_memo ())::env in - log cfg (fun () -> BU.print_string "+++ Reducing Tm_let\n"); - norm cfg env stack body - - (* If we are reifying, we reduce Div lets faithfully, i.e. in CBV *) - (* This is important for tactics, see issue #1594 *) - else if cfg.steps.tactics - && U.is_div_effect (Env.norm_eff_name cfg.tcenv lb.lbeff) - then let ffun = S.mk (Tm_abs {bs=[S.mk_binder (lb.lbname |> BU.left)]; body; rc_opt=None}) t.pos in - let stack = (CBVApp (env, ffun, None, t.pos)) :: stack in - log cfg (fun () -> BU.print_string "+++ Evaluating DIV Tm_let\n"); - norm cfg env stack lb.lbdef - - else if cfg.steps.weak - then (log cfg (fun () -> BU.print_string "+++ Not touching Tm_let\n"); - rebuild cfg env stack (closure_as_term cfg env t)) - - else let bs, body = Subst.open_term [lb.lbname |> BU.left |> S.mk_binder] body in - log cfg (fun () -> BU.print_string "+++ Normalizing Tm_let -- type"); - let ty = norm cfg env [] lb.lbtyp in - let lbname = - let x = (List.hd bs).binder_bv in - Inl ({x with sort=ty}) in - log cfg (fun () -> BU.print_string "+++ Normalizing Tm_let -- definiens\n"); - let lb = {lb with lbname=lbname; - lbtyp=ty; - lbdef=norm cfg env [] lb.lbdef; - lbattrs=List.map (norm cfg env []) lb.lbattrs} in - let env' = bs |> List.fold_left (fun env _ -> dummy () ::env) env in - log cfg (fun () -> BU.print_string "+++ Normalizing Tm_let -- body\n"); - let cfg' = { cfg with strong = true } in - let body_norm = norm cfg' env' (Let (env, bs, lb, t.pos) :: []) body in - rebuild cfg env stack body_norm - - | Tm_let {lbs=(true, lbs); body} - when cfg.steps.compress_uvars - || (not cfg.steps.zeta && - not cfg.steps.zeta_full && - cfg.steps.pure_subterms_within_computations) -> //no fixpoint reduction allowed - let lbs, body = Subst.open_let_rec lbs body in - let lbs = List.map (fun lb -> - let ty = norm cfg env [] lb.lbtyp in - let lbname = Inl ({BU.left lb.lbname with sort=ty}) in - let xs, def_body, lopt = U.abs_formals lb.lbdef in - let xs = norm_binders cfg env xs in - let env = List.map (fun _ -> dummy ()) xs //first the bound vars for the arguments - @ List.map (fun _ -> dummy ()) lbs //then the recursively bound names - @ env in - let def_body = norm cfg env [] def_body in - let lopt = - match lopt with - | Some rc -> Some ({rc with residual_typ=BU.map_opt rc.residual_typ (norm cfg env [])}) - | _ -> lopt in - let def = U.abs xs def_body lopt in - { lb with lbname = lbname; - lbtyp = ty; - lbdef = def}) lbs in - let env' = List.map (fun _ -> dummy ()) lbs @ env in - let body = norm cfg env' [] body in - let lbs, body = Subst.close_let_rec lbs body in - let t = {t with n=Tm_let {lbs=(true, lbs); body}} in - rebuild cfg env stack t - - | Tm_let {lbs; body} when not cfg.steps.zeta && not cfg.steps.zeta_full -> //no fixpoint reduction allowed - rebuild cfg env stack (closure_as_term cfg env t) - - | Tm_let {lbs; body} -> - //let rec: The basic idea is to reduce the body in an environment that includes recursive bindings for the lbs - //Consider reducing (let rec f x = f x in f 0) in initial environment env - //We build two environments, rec_env and body_env and reduce (f 0) in body_env - //rec_env = Clos(env, let rec f x = f x in f, memo)::env - //body_env = Clos(rec_env, \x. f x, _)::env - //i.e., in body, the bound variable is bound to definition, \x. f x - //Within the definition \x.f x, f is bound to the recursive binding (let rec f x = f x in f), aka, fix f. \x. f x - //Finally, we add one optimization for laziness by tying a knot in rec_env - //i.e., we set memo := Some (rec_env, \x. f x) - - let rec_env, memos, _ = List.fold_right (fun lb (rec_env, memos, i) -> - let bv = {left lb.lbname with index=i} in - let f_i = Syntax.bv_to_tm bv in - let fix_f_i = mk (Tm_let {lbs; body=f_i}) t.pos in - let memo = fresh_memo () in - let rec_env = (None, Clos(env, fix_f_i, memo, true), fresh_memo ())::rec_env in - rec_env, memo::memos, i + 1) (snd lbs) (env, [], 0) in - let _ = List.map2 (fun lb memo -> memo := Some (cfg, (rec_env, lb.lbdef))) (snd lbs) memos in //tying the knot - // NB: fold_left, since the binding structure of lbs is that righmost is closer, while in the env leftmost - // is closer. In other words, the last element of lbs is index 0 for body, hence needs to be pushed last. - let body_env = List.fold_left (fun env lb -> (None, Clos(rec_env, lb.lbdef, fresh_memo(), false), fresh_memo())::env) - env (snd lbs) in - log cfg (fun () -> BU.print1 "reducing with knot %s\n" ""); - norm cfg body_env stack body - - | Tm_meta {tm=head; meta=m} -> - log cfg (fun () -> BU.print1 ">> metadata = %s\n" (show m)); - begin match m with - | Meta_monadic (m_from, ty) -> - if cfg.steps.for_extraction - then ( - //In Extraction, we want to erase sub-terms with erasable effect - //Or pure terms with non-informative return types - if Env.is_erasable_effect cfg.tcenv m_from - || (U.is_pure_effect m_from && Env.non_informative cfg.tcenv ty) - then ( - rebuild cfg env stack (S.mk (Tm_meta {tm=U.exp_unit; meta=m}) t.pos) - ) - else ( - reduce_impure_comp cfg env stack head (Inl m_from) ty - ) - ) - else - reduce_impure_comp cfg env stack head (Inl m_from) ty - - | Meta_monadic_lift (m_from, m_to, ty) -> - if cfg.steps.for_extraction - then ( - //In Extraction, we want to erase sub-terms with erasable effect - //Or pure terms with non-informative return types - if Env.is_erasable_effect cfg.tcenv m_from - || Env.is_erasable_effect cfg.tcenv m_to - || (U.is_pure_effect m_from && Env.non_informative cfg.tcenv ty) - then ( - rebuild cfg env stack (S.mk (Tm_meta {tm=U.exp_unit; meta=m}) t.pos) - ) - else ( - reduce_impure_comp cfg env stack head (Inr (m_from, m_to)) ty - ) - ) - else reduce_impure_comp cfg env stack head (Inr (m_from, m_to)) ty - - | _ -> - if cfg.steps.unmeta - then norm cfg env stack head - else begin match stack with - | _::_ -> - begin match m with - | Meta_labeled(l, r, _) -> - (* meta doesn't block reduction, but we need to put the label back *) - norm cfg env (Meta(env,m,r)::stack) head - - | Meta_pattern (names, args) -> - let args = norm_pattern_args cfg env args in - let names = names |> List.map (norm cfg env []) in - norm cfg env (Meta(env, Meta_pattern(names, args), t.pos)::stack) head - //meta doesn't block reduction, but we need to put the label back - - (* Try to retain Sequence nodes when not normalizing letbindings. *) - | Meta_desugared Sequence when cfg.steps.do_not_unfold_pure_lets -> - norm cfg env (Meta(env,m,t.pos)::stack) head - - | Meta_desugared (Machine_integer (_,_)) -> - (* meta doesn't block reduction, - but we need to put the label back *) - norm cfg env (Meta(env,m,t.pos)::stack) head - - | _ -> - norm cfg env stack head //meta doesn't block reduction - end - | [] -> - let head = norm cfg env [] head in - let m = match m with - | Meta_pattern (names, args) -> - let names = names |> List.map (norm cfg env []) in - Meta_pattern (names, norm_pattern_args cfg env args) - | _ -> m in - let t = mk (Tm_meta {tm=head; meta=m}) t.pos in - rebuild cfg env stack t - end - end //Tm_meta - - | Tm_delayed _ -> - failwith "impossible: Tm_delayed on norm" - - | Tm_uvar _ -> - if cfg.steps.check_no_uvars then - failwith (BU.format2 "(%s) CheckNoUvars: Unexpected unification variable remains: %s" - (show t.pos) (show t)); - let t = Errors.with_ctx "inlining" (fun () -> closure_as_term cfg env t) in - rebuild cfg env stack t - -(* NOTE: we do not need any environment here, since an fv does not - * have any free indices. Hence, we use empty_env as environment when needed. *) -and do_unfold_fv (cfg:Cfg.cfg) stack (t0:term) (qninfo : qninfo) (f:fv) : term = - // Second, try to unfold to the definition itself. - let defn () = Env.lookup_definition_qninfo cfg.delta_level f.fv_name.v qninfo in - // First, try to unfold to the implementation specified in the extract_as attribute (when doing extraction) - let defn () = - if cfg.steps.for_extraction then - match qninfo with - | Some (Inr (se, None), _) when Env.visible_with cfg.delta_level se.sigquals -> - (match find_map se.sigattrs is_extract_as_attr with - | Some impl -> Some ([], impl) - | None -> defn ()) - | _ -> defn () - else - defn () in - match defn () with - | None -> - log_unfolding cfg (fun () -> - BU.print2 " >> No definition found for %s (delta_level = %s)\n" - (show f) (show cfg.delta_level)); - rebuild cfg empty_env stack t0 - - | Some (us, t) -> - begin - log_unfolding cfg (fun () -> BU.print2 " >> Unfolded %s to %s\n" (show t0) (show t)); - // preserve the range info on the returned term - let t = - if cfg.steps.unfold_until = Some delta_constant - //we're really trying to compute here; no point propagating range information - //which can be expensive - then t - else Subst.set_use_range t0.pos t - in - let n = List.length us in - if n > 0 - then match stack with //universe beta reduction - | UnivArgs(us', _)::stack -> - if !dbg_univ_norm then - List.iter (fun x -> BU.print1 "Univ (normalizer) %s\n" (show x)) us' - else (); - let env = us' |> List.fold_left (fun env u -> (None, Univ u, fresh_memo ())::env) empty_env in - norm cfg env stack t - | _ when cfg.steps.erase_universes || cfg.steps.allow_unbound_universes -> - norm cfg empty_env stack t - | _ -> failwith (BU.format1 "Impossible: missing universe instantiation on %s" (show f.fv_name.v)) - else norm cfg empty_env stack t - end - -and reduce_impure_comp cfg env stack (head : term) // monadic term - (m : either monad_name (monad_name & monad_name)) - // relevant monads. - // Inl m - this is a Meta_monadic with monad m - // Inr (m, m') - this is a Meta_monadic_lift with monad m - (t : typ) // annotated type in the Meta - : term = - (* We have an impure computation, and we aim to perform any pure *) - (* steps within that computation. *) - - (* This scenario arises primarily as we extract (impure) programs and *) - (* partially evaluate them before extraction, as an optimization. *) - - (* First, we reduce **the type annotation** t with an empty stack (as *) - (* it's not applied to anything) *) - - (* Then, we reduce the monadic computation `head`, in a stack marked *) - (* with a Meta_monadic, indicating that this reduction should *) - (* not consume any arguments on the stack. `rebuild` will notice *) - (* the Meta_monadic marker and reconstruct the computation after *) - (* normalization. *) - let t = norm cfg env [] t in - (* monadic annotations don't block reduction, but we need to put the label back *) - let metadata = match m with - | Inl m -> Meta_monadic (m, t) - | Inr (m, m') -> Meta_monadic_lift (m, m', t) - in - norm cfg env (Meta(env,metadata, head.pos)::stack) head - -and do_reify_monadic fallback cfg env stack (top : term) (m : monad_name) (t : typ) : term = - (* Precondition: the stack head is an App (reify, ...) *) - begin match stack with - | App (_, {n=Tm_constant (FC.Const_reify _)}, _, _) :: _ -> () - | _ -> failwith (BU.format1 "INTERNAL ERROR: do_reify_monadic: bad stack: %s" (show stack)) - end; - let top0 = top in - let top = U.unascribe top in - log cfg (fun () -> BU.print2 "Reifying: (%s) %s\n" (tag_of top) (show top)); - let top = U.unmeta_safe top in - match (SS.compress top).n with - | Tm_let {lbs=(false, [lb]); body} -> - (* ****************************************************************************) - (* Monadic binding *) - (* *) - (* This is reify (M.bind e1 (fun x -> e2)) which is elaborated to *) - (* *) - (* M.bind_repr (reify e1) (fun x -> reify e2) *) - (* *) - (* ****************************************************************************) - let eff_name = Env.norm_eff_name cfg.tcenv m in - let ed = Env.get_effect_decl cfg.tcenv eff_name in - let _, repr = ed |> U.get_eff_repr |> must in - let _, bind_repr = ed |> U.get_bind_repr |> must in - begin match lb.lbname with - | Inr _ -> failwith "Cannot reify a top-level let binding" - | Inl x -> - - (* [is_return e] returns [Some e'] if [e] is a lift from Pure of [e'], [None] otherwise *) - let is_return e = - match (SS.compress e).n with - | Tm_meta {tm=e; meta=Meta_monadic(_, _)} -> - begin match (SS.compress e).n with - | Tm_meta {tm=e; meta=Meta_monadic_lift(_, msrc, _)} when U.is_pure_effect msrc -> - Some (SS.compress e) - | _ -> None - end - | _ -> None - in - - match is_return lb.lbdef with - (* We are in the case where [top] = [bind (return e) (fun x -> body)] *) - (* which can be optimised to a non-monadic let-binding [let x = e in body] *) - | Some e -> - let lb = {lb with lbeff=PC.effect_PURE_lid; lbdef=e} in - norm cfg env (List.tl stack) (S.mk (Tm_let {lbs=(false, [lb]); body=U.mk_reify body (Some m)}) top.pos) - | None -> - if (match is_return body with Some ({n=Tm_bvar y}) -> S.bv_eq x y | _ -> false) - then - (* We are in the case where [top] = [bind e (fun x -> return x)] *) - (* which can be optimised to just keeping normalizing [e] with a reify on the stack *) - norm cfg env stack lb.lbdef - else ( - (* TODO : optimize [bind (bind e1 e2) e3] into [bind e1 (bind e2 e3)] *) - (* Rewriting binds in that direction would be better for exception-like monad *) - (* since we wouldn't rematch on an already raised exception *) - let rng = top.pos in - - let head = U.mk_reify lb.lbdef (Some m) in - - let body = U.mk_reify body (Some m) in - (* TODO : Check that there is no sensible cflags to pass in the residual_comp *) - let body_rc = { - residual_effect=m; - residual_flags=[]; - residual_typ=Some t - } in - let body = S.mk (Tm_abs {bs=[S.mk_binder x]; body; rc_opt=Some body_rc}) body.pos in - - //the bind term for the effect - let close = closure_as_term cfg env in - let bind_inst = match (SS.compress bind_repr).n with - | Tm_uinst (bind, [_ ; _]) -> - S.mk (Tm_uinst (bind, [ cfg.tcenv.universe_of cfg.tcenv (close lb.lbtyp) - ; cfg.tcenv.universe_of cfg.tcenv (close t)])) - rng - | _ -> failwith "NIY : Reification of indexed effects" in - - //arguments to the bind term, f_arg is the argument for first computation f - let bind_inst_args f_arg = - (* - * Arguments to bind_repr for layered effects are: - * a b ..units for binders that compute indices.. f_arg g_arg - * - * For non-layered effects, as before - *) - if U.is_layered ed then - // - //Bind in the TAC effect, for example, has range args - //This is indicated on the effect using an attribute - // - let bind_has_range_args = - U.has_attribute ed.eff_attrs PC.bind_has_range_args_attr in - let num_fixed_binders = - if bind_has_range_args then 4 //the two ranges, and f and g - else 2 in //f and g - - // - //for bind binders that are not fixed, we apply () - // - let unit_args = - match (ed |> U.get_bind_vc_combinator |> fst |> snd |> SS.compress).n with - | Tm_arrow {bs=_::_::bs} when List.length bs >= num_fixed_binders -> - bs - |> List.splitAt (List.length bs - num_fixed_binders) - |> fst - |> List.map (fun _ -> S.as_arg S.unit_const) - | _ -> - raise_error rng Errors.Fatal_UnexpectedEffect - (BU.format3 "bind_wp for layered effect %s is not an arrow with >= %s arguments (%s)" - (show ed.mname) - (show num_fixed_binders) - (ed |> U.get_bind_vc_combinator |> fst |> snd |> show)) - in - - let range_args = - if bind_has_range_args - then [as_arg (PO.embed_simple lb.lbpos lb.lbpos); - as_arg (PO.embed_simple body.pos body.pos)] - else [] in - - (S.as_arg lb.lbtyp)::(S.as_arg t)::(unit_args@range_args@[S.as_arg f_arg; S.as_arg body]) - else - let maybe_range_arg = - if BU.for_some (TEQ.eq_tm_bool cfg.tcenv U.dm4f_bind_range_attr) ed.eff_attrs - then [as_arg (PO.embed_simple lb.lbpos lb.lbpos); - as_arg (PO.embed_simple body.pos body.pos)] - else [] - in - [ (* a, b *) - as_arg lb.lbtyp; as_arg t] @ - maybe_range_arg @ [ - (* wp_f, f_arg--the term shouldn't depend on wp_f *) - as_arg S.tun; as_arg f_arg; - (* wp_body, body--the term shouldn't depend on wp_body *) - as_arg S.tun; as_arg body] in - - (* - * Construct the reified term - * - * if M is total, then its reification is also Tot, in that case we construct: - * - * bind (reify f) (fun x -> reify g) - * - * however, if M is not total, then (reify f) is Dv, and then we construct: - * - * let uu__ = reify f in - * bind uu_ (fun x -> reify g) - * - * We don't introduce the let-binding in the first case, - * since in some examples, it blocks reductions - *) - let reified = - let is_total_effect = Env.is_total_effect cfg.tcenv eff_name in - if is_total_effect - then S.mk (Tm_app {hd=bind_inst; args=bind_inst_args head}) rng - else - let lb_head, head_bv, head = - let bv = S.new_bv None x.sort in - let lb = - { lbname = Inl bv; - lbunivs = []; - lbtyp = U.mk_app repr [S.as_arg x.sort]; - lbeff = if is_total_effect then PC.effect_Tot_lid - else PC.effect_Dv_lid; - lbdef = head; - lbattrs = []; - lbpos = head.pos; - } - in - lb, bv, S.bv_to_name bv in - S.mk (Tm_let {lbs=(false, [lb_head]); - body=SS.close [S.mk_binder head_bv] <| - S.mk (Tm_app {hd=bind_inst; args=bind_inst_args head}) rng}) rng in - - log cfg (fun () -> BU.print2 "Reified (1) <%s> to %s\n" (show top0) (show reified)); - norm cfg env (List.tl stack) reified - ) - end - | Tm_app {hd=head; args} -> - (* ****************************************************************************) - (* Monadic application *) - (* *) - (* The typechecker should have turned any monadic application into a serie of *) - (* let-bindings (binding explicitly any monadic term) *) - (* let x0 = head in let x1 = arg0 in ... let xn = argn in x0 x1 ... xn *) - (* *) - (* which wil be ultimately reified to *) - (* bind (reify head) (fun x0 -> *) - (* bind (reify arg0) (fun x1 -> ... (fun xn -> x0 x1 .. xn) )) *) - (* *) - (* If head is an action then it is unfolded otherwise the *) - (* resulting application is reified again *) - (* ****************************************************************************) - - (* Checking that the typechecker did its job correctly and hoisted all impure *) - (* terms to explicit let-bindings (see TcTerm, monadic_application) *) - (* GM: Now only when --defensive is on, so we don't waste cycles otherwise *) - if Options.defensive () then begin - let is_arg_impure (e,q) = - match (SS.compress e).n with - | Tm_meta {tm=e0; meta=Meta_monadic_lift(m1, m2, t')} -> not (U.is_pure_effect m1) - | _ -> false - in - if BU.for_some is_arg_impure ((as_arg head)::args) then - Errors.log_issue top - Errors.Warning_Defensive - (BU.format1 "Incompatibility between typechecker and normalizer; \ - this monadic application contains impure terms %s\n" - (show top)) - end; - - (* GM: I'm really suspicious of this code, I tried to change it the least - * when trying to fixing it but these two seem super weird. Why 2 of them? - * Why is it not calling rebuild? I'm gonna keep it for now. *) - let fallback1 () = - log cfg (fun () -> BU.print2 "Reified (2) <%s> to %s\n" (show top0) ""); - norm cfg env (List.tl stack) (U.mk_reify top (Some m)) - in - let fallback2 () = - log cfg (fun () -> BU.print2 "Reified (3) <%s> to %s\n" (show top0) ""); - norm cfg env (List.tl stack) (mk (Tm_meta {tm=top; meta=Meta_monadic(m, t)}) top0.pos) - in - - (* This application case is only interesting for fully-applied dm4f actions. Otherwise, - * we just continue rebuilding. *) - begin match (U.un_uinst head).n with - | Tm_fvar fv -> - let lid = S.lid_of_fv fv in - let qninfo = Env.lookup_qname cfg.tcenv lid in - if not (Env.is_action cfg.tcenv lid) then fallback1 () else - - (* GM: I think the action *must* be fully applied at this stage - * since we were triggered into this function by a Meta_monadic - * annotation. So we don't check anything. *) - - (* Fallback if it does not have a definition. This happens, - * but I'm not sure why. *) - if Option.isNone (Env.lookup_definition_qninfo cfg.delta_level fv.fv_name.v qninfo) - then fallback2 () - else - - (* Turn it info (reify head) args, then do_unfold_fv will kick in on the head *) - let t = S.mk_Tm_app (U.mk_reify head (Some m)) args t.pos in - norm cfg env (List.tl stack) t - - | _ -> - fallback1 () - end - - // Doubly-annotated effect.. just take the outmost one. (unsure..) - | Tm_meta {tm=e; meta=Meta_monadic _} -> - do_reify_monadic fallback cfg env stack e m t - - | Tm_meta {tm=e; meta=Meta_monadic_lift (msrc, mtgt, t')} -> - let lifted = reify_lift cfg e msrc mtgt (closure_as_term cfg env t') in - log cfg (fun () -> BU.print1 "Reified lift to (2): %s\n" (show lifted)); - norm cfg env (List.tl stack) lifted - - | Tm_match {scrutinee=e; ret_opt=asc_opt; brs=branches; rc_opt=lopt} -> - (* Commutation of reify with match, note that the scrutinee should never be effectful *) - (* (should be checked at typechecking and elaborated with an explicit binding if needed) *) - (* reify (match e with p -> e') ~> match e with p -> reify e' *) - let branches = branches |> List.map (fun (pat, wopt, tm) -> pat, wopt, U.mk_reify tm (Some m)) in - let tm = mk (Tm_match {scrutinee=e; ret_opt=asc_opt; brs=branches; rc_opt=lopt}) top.pos in - norm cfg env (List.tl stack) tm - - | _ -> - fallback () - -(* Reifies the lifting of the term [e] of type [t] from computational *) -(* effect [m] to computational effect [m'] using lifting data in [env] *) -and reify_lift cfg e msrc mtgt t : term = - let env = cfg.tcenv in - log cfg (fun () -> BU.print3 "Reifying lift %s -> %s: %s\n" - (Ident.string_of_lid msrc) (Ident.string_of_lid mtgt) (show e)); - (* check if the lift is concrete, if so replace by its definition on terms *) - (* if msrc is PURE or Tot we can use mtgt.return *) - - (* - * AR: Not sure why we should use return, if the programmer has also provided a lift - * This seems like a mismatch, since to verify we use lift (else we give an error) - * but to run, we are relying on return - * Disabling this for layered effects, and using the lift instead - *) - if (U.is_pure_effect msrc || U.is_div_effect msrc) && - not (mtgt |> Env.is_layered_effect env) - then - let ed = Env.get_effect_decl env (Env.norm_eff_name cfg.tcenv mtgt) in - let _, repr = ed |> U.get_eff_repr |> must in - let _, return_repr = ed |> U.get_return_repr |> must in - let return_inst = match (SS.compress return_repr).n with - | Tm_uinst(return_tm, [_]) -> - S.mk (Tm_uinst (return_tm, [env.universe_of env t])) e.pos - | _ -> failwith "NIY : Reification of indexed effects" - in - - let lb_e, e_bv, e = - let bv = S.new_bv None t in - let lb = - { lbname = Inl bv; - lbunivs = []; - lbtyp = U.mk_app repr [S.as_arg t]; - lbeff = msrc; - lbdef = e; - lbattrs = []; - lbpos = e.pos; - } - in - lb, bv, S.bv_to_name bv - in - - S.mk (Tm_let {lbs=(false, [lb_e]); - body=SS.close [S.mk_binder e_bv] <| - S.mk (Tm_app {hd=return_inst; args=[as_arg t ; as_arg e]}) e.pos} - ) e.pos - else - match Env.monad_leq env msrc mtgt with - | None -> - failwith (BU.format2 "Impossible : trying to reify a lift between unrelated effects (%s and %s)" - (Ident.string_of_lid msrc) - (Ident.string_of_lid mtgt)) - | Some {mlift={mlift_term=None}} -> - failwith (BU.format2 "Impossible : trying to reify a non-reifiable lift (from %s to %s)" - (Ident.string_of_lid msrc) - (Ident.string_of_lid mtgt)) - | Some {mlift={mlift_term=Some lift}} -> - (* - * AR: we need to apply the lift combinator to `e` - * if source effect (i.e. e's effect) is reifiable, then we first reify e - * else if it is not, then we thunk e - * this is how lifts are written for layered effects - * not sure what's the convention for DM4F, but DM4F lifts don't come to this point anyway - * they are handled as a `return` in the `then` branch above - *) - let e = - if Env.is_reifiable_effect env msrc - then U.mk_reify e (Some msrc) - else S.mk - (Tm_abs {bs=[S.null_binder S.t_unit]; - body=e; - rc_opt=Some ({ residual_effect = msrc; residual_typ = Some t; residual_flags = [] })}) - e.pos in - lift (env.universe_of env t) t e - - - (* We still eagerly unfold the lift to make sure that the Unknown is not kept stuck on a folded application *) - (* let cfg = *) - (* { steps=[Exclude Iota ; Exclude Zeta; Inlining ; Eager_unfolding ; UnfoldUntil Delta_constant]; *) - (* tcenv=env; *) - (* delta_level=[Env.Unfold Delta_constant ; Env.Eager_unfolding_only ; Env.Inlining ] } *) - (* in *) - (* norm cfg [] [] (lift t S.tun (U.mk_reify e)) *) - -and norm_pattern_args cfg env args = - (* Drops stack *) - args |> List.map (List.map (fun (a, imp) -> norm cfg env [] a, imp)) - -and norm_comp : cfg -> env -> comp -> comp = - fun cfg env comp -> - log cfg (fun () -> BU.print2 ">>> %s\nNormComp with with %s env elements\n" - (show comp) - (show (List.length env))); - match comp.n with - | Total t -> - let t = norm cfg env [] t in - { mk_Total t with pos = comp.pos } - - | GTotal t -> - let t = norm cfg env [] t in - { mk_GTotal t with pos = comp.pos } - - | Comp ct -> - // - // if cfg.for_extraction and the effect extraction is not by reification, - // then drop the effect arguments - // - let effect_args = - ct.effect_args |> - (if cfg.steps.for_extraction && - not (get_extraction_mode cfg.tcenv ct.effect_name = Extract_reify) - then List.map (fun _ -> S.unit_const |> S.as_arg) - else List.mapi (fun idx (a, i) -> (norm cfg env [] a, i))) in - let flags = ct.flags |> List.map (function - | DECREASES (Decreases_lex l) -> - DECREASES (l |> List.map (norm cfg env []) |> Decreases_lex) - | DECREASES (Decreases_wf (rel, e)) -> - DECREASES (Decreases_wf (norm cfg env [] rel, norm cfg env [] e)) - | f -> f) in - let comp_univs = List.map (norm_universe cfg env) ct.comp_univs in - let result_typ = norm cfg env [] ct.result_typ in - { mk_Comp ({ct with comp_univs = comp_univs; - result_typ = result_typ; - effect_args = effect_args; - flags = flags}) with pos = comp.pos } - -and norm_binder (cfg:Cfg.cfg) (env:env) (b:binder) : binder = - let x = { b.binder_bv with sort = norm cfg env [] b.binder_bv.sort } in - let imp = match b.binder_qual with - | Some (S.Meta t) -> Some (S.Meta (closure_as_term cfg env t)) - | i -> i in - let attrs = List.map (norm cfg env []) b.binder_attrs in - S.mk_binder_with_attrs x imp b.binder_positivity attrs - -and norm_binders : cfg -> env -> binders -> binders = - fun cfg env bs -> - let nbs, _ = List.fold_left (fun (nbs', env) b -> - let b = norm_binder cfg env b in - (b::nbs', dummy () ::env) (* crossing a binder, so shift environment *)) - ([], env) - bs in - List.rev nbs - -and maybe_simplify cfg env stack tm = - let tm', renorm = maybe_simplify_aux cfg env stack tm in - if cfg.debug.b380 - then BU.print4 "%sSimplified\n\t%s to\n\t%s\nrenorm = %s\n" - (if cfg.steps.simplify then "" else "NOT ") - (show tm) (show tm') (show renorm); - tm', renorm - -and norm_cb cfg : EMB.norm_cb = function - | Inr x -> norm cfg [] [] x - | Inl l -> - //FStar.Syntax.DsEnv.try_lookup_lid cfg.tcenv.dsenv l |> fst - match - FStar.Syntax.DsEnv.try_lookup_lid cfg.tcenv.dsenv l - with - | Some t -> t - | None -> S.fv_to_tm (S.lid_as_fv l None) - - -(*******************************************************************) -(* Simplification steps are not part of definitional equality *) -(* simplifies True /\ t, t /\ True, t /\ False, False /\ t etc. *) -(* The boolean indicates whether further normalization is required. *) -(*******************************************************************) -and maybe_simplify_aux (cfg:cfg) (env:env) (stack:stack) (tm:term) : term & bool = - let tm, renorm = reduce_primops (norm_cb cfg) cfg env tm in - if not <| cfg.steps.simplify then tm, renorm - else - let w t = {t with pos=tm.pos} in - let simp_t t = - // catch annotated subformulae too - match (U.unmeta t).n with - | Tm_fvar fv when S.fv_eq_lid fv PC.true_lid -> Some true - | Tm_fvar fv when S.fv_eq_lid fv PC.false_lid -> Some false - | _ -> None - in - let is_const_match (phi : term) : option bool = - match (SS.compress phi).n with - (* Trying to be efficient, but just checking if they all agree *) - (* Note, if we wanted to do this for any term instead of just True/False - * we need to open the terms *) - | Tm_match {brs=br::brs} -> - let (_, _, e) = br in - let r = begin match simp_t e with - | None -> None - | Some b -> if List.for_all (fun (_, _, e') -> simp_t e' = Some b) brs - then Some b - else None - end - in - r - | _ -> None - in - let maybe_auto_squash t = - if U.is_sub_singleton t - then t - else U.mk_auto_squash U_zero t - in - let squashed_head_un_auto_squash_args t = - //The head of t is already a squashed operator, e.g. /\ etc. - //no point also squashing its arguments if they're already in U_zero - let maybe_un_auto_squash_arg (t,q) = - match U.is_auto_squash t with - | Some (U_zero, t) -> - //if we're squashing from U_zero to U_zero - // then just remove it - t, q - | _ -> - t,q - in - let head, args = U.head_and_args t in - let args = List.map maybe_un_auto_squash_arg args in - S.mk_Tm_app head args t.pos, false - in - let rec clearly_inhabited (ty : typ) : bool = - match (U.unmeta ty).n with - | Tm_uinst (t, _) -> clearly_inhabited t - | Tm_arrow {comp=c} -> clearly_inhabited (U.comp_result c) - | Tm_fvar fv -> - let l = S.lid_of_fv fv in - (Ident.lid_equals l PC.int_lid) - || (Ident.lid_equals l PC.bool_lid) - || (Ident.lid_equals l PC.string_lid) - || (Ident.lid_equals l PC.exn_lid) - | _ -> false - in - let simplify arg = (simp_t (fst arg), arg) in - match is_forall_const cfg tm with - (* We need to recurse, and maybe reduce further! *) - | Some tm' -> - if cfg.debug.wpe then - BU.print2 "WPE> %s ~> %s\n" (show tm) (show tm'); - maybe_simplify_aux cfg env stack (norm cfg env [] tm') - (* Otherwise try to simplify this point *) - | None -> - match (SS.compress tm).n with - | Tm_app {hd={n=Tm_uinst({n=Tm_fvar fv}, _)}; args} - | Tm_app {hd={n=Tm_fvar fv}; args} -> - if S.fv_eq_lid fv PC.squash_lid - then squashed_head_un_auto_squash_args tm - else if S.fv_eq_lid fv PC.and_lid - then match args |> List.map simplify with - | [(Some true, _); (_, (arg, _))] - | [(_, (arg, _)); (Some true, _)] -> maybe_auto_squash arg, false - | [(Some false, _); _] - | [_; (Some false, _)] -> w U.t_false, false - | _ -> squashed_head_un_auto_squash_args tm - else if S.fv_eq_lid fv PC.or_lid - then match args |> List.map simplify with - | [(Some true, _); _] - | [_; (Some true, _)] -> w U.t_true, false - | [(Some false, _); (_, (arg, _))] - | [(_, (arg, _)); (Some false, _)] -> maybe_auto_squash arg, false - | _ -> squashed_head_un_auto_squash_args tm - else if S.fv_eq_lid fv PC.imp_lid - then match args |> List.map simplify with - | [_; (Some true, _)] - | [(Some false, _); _] -> w U.t_true, false - | [(Some true, _); (_, (arg, _))] -> maybe_auto_squash arg, false - | [(_, (p, _)); (_, (q, _))] -> - if U.term_eq p q - then w U.t_true, false - else squashed_head_un_auto_squash_args tm - | _ -> squashed_head_un_auto_squash_args tm - else if S.fv_eq_lid fv PC.iff_lid - then match args |> List.map simplify with - | [(Some true, _) ; (Some true, _)] - | [(Some false, _) ; (Some false, _)] -> w U.t_true, false - | [(Some true, _) ; (Some false, _)] - | [(Some false, _) ; (Some true, _)] -> w U.t_false, false - | [(_, (arg, _)) ; (Some true, _)] - | [(Some true, _) ; (_, (arg, _))] -> maybe_auto_squash arg, false - | [(_, (arg, _)) ; (Some false, _)] - | [(Some false, _) ; (_, (arg, _))] -> maybe_auto_squash (U.mk_neg arg), false - | [(_, (p, _)); (_, (q, _))] -> - if U.term_eq p q - then w U.t_true, false - else squashed_head_un_auto_squash_args tm - | _ -> squashed_head_un_auto_squash_args tm - else if S.fv_eq_lid fv PC.not_lid - then match args |> List.map simplify with - | [(Some true, _)] -> w U.t_false, false - | [(Some false, _)] -> w U.t_true, false - | _ -> squashed_head_un_auto_squash_args tm - else if S.fv_eq_lid fv PC.forall_lid - then match args with - (* Simplify ∀x. True to True *) - | [(t, _)] -> - begin match (SS.compress t).n with - | Tm_abs {bs=[_]; body} -> - (match simp_t body with - | Some true -> w U.t_true, false - | _ -> tm, false) - | _ -> tm, false - end - (* Simplify ∀x. True to True, and ∀x. False to False, if the domain is not empty *) - | [(ty, Some ({ aqual_implicit = true })); (t, _)] -> - begin match (SS.compress t).n with - | Tm_abs {bs=[_]; body} -> - (match simp_t body with - | Some true -> w U.t_true, false - | Some false when clearly_inhabited ty -> w U.t_false, false - | _ -> tm, false) - | _ -> tm, false - end - | _ -> tm, false - else if S.fv_eq_lid fv PC.exists_lid - then match args with - (* Simplify ∃x. False to False *) - | [(t, _)] -> - begin match (SS.compress t).n with - | Tm_abs {bs=[_]; body} -> - (match simp_t body with - | Some false -> w U.t_false, false - | _ -> tm, false) - | _ -> tm, false - end - (* Simplify ∃x. False to False and ∃x. True to True, if the domain is not empty *) - | [(ty, Some ({ aqual_implicit = true })); (t, _)] -> - begin match (SS.compress t).n with - | Tm_abs {bs=[_]; body} -> - (match simp_t body with - | Some false -> w U.t_false, false - | Some true when clearly_inhabited ty -> w U.t_true, false - | _ -> tm, false) - | _ -> tm, false - end - | _ -> tm, false - else if S.fv_eq_lid fv PC.b2t_lid - then match args with - | [{n=Tm_constant (Const_bool true)}, _] -> w U.t_true, false - | [{n=Tm_constant (Const_bool false)}, _] -> w U.t_false, false - | _ -> tm, false //its arg is a bool, can't unsquash - else if S.fv_eq_lid fv PC.haseq_lid - then begin - (* - * AR: We try to mimic the hasEq related axioms in Prims - * and the axiom related to refinements - * For other types, such as lists, whose hasEq is derived by the typechecker, - * we leave them as is - *) - let t_has_eq_for_sure (t:S.term) :bool = - //Axioms from prims - let haseq_lids = [PC.int_lid; PC.bool_lid; PC.unit_lid; PC.string_lid] in - match (SS.compress t).n with - | Tm_fvar fv when haseq_lids |> List.existsb (fun l -> S.fv_eq_lid fv l) -> true - | _ -> false - in - if List.length args = 1 then - let t = args |> List.hd |> fst in - if t |> t_has_eq_for_sure then w U.t_true, false - else - match (SS.compress t).n with - | Tm_refine _ -> - let t = U.unrefine t in - if t |> t_has_eq_for_sure then w U.t_true, false - else - //get the hasEq term itself - let haseq_tm = - match (SS.compress tm).n with - | Tm_app {hd} -> hd - | _ -> failwith "Impossible! We have already checked that this is a Tm_app" - in - //and apply it to the unrefined type - mk_app (haseq_tm) [t |> as_arg], false - | _ -> tm, false - else tm, false - end - else if S.fv_eq_lid fv PC.subtype_of_lid - then begin - let is_unit ty = - match (SS.compress ty).n with - | Tm_fvar fv -> S.fv_eq_lid fv PC.unit_lid - | _ -> false - in - match args with - | [(t, _); (ty, _)] - when is_unit ty && U.is_sub_singleton t -> - w U.t_true, false - | _ -> tm, false - end - else begin - match U.is_auto_squash tm with - | Some (U_zero, t) - when U.is_sub_singleton t -> - //remove redundant auto_squashes - t, false - | _ -> - reduce_equality (norm_cb cfg) cfg env tm - end - | Tm_refine {b=bv; phi=t} -> - begin match simp_t t with - | Some true -> bv.sort, false - | Some false -> tm, false - | None -> tm, false - end - | Tm_match _ -> - begin match is_const_match tm with - | Some true -> w U.t_true, false - | Some false -> w U.t_false, false - | None -> tm, false - end - | _ -> tm, false - - -and rebuild (cfg:cfg) (env:env) (stack:stack) (t:term) : term = - (* Pre-condition: t is in either weak or strong normal form w.r.t env, depending on *) - (* whether cfg.steps constains WHNF In either case, it has no free de Bruijn *) - (* indices *) - log cfg (fun () -> - BU.print4 ">>> %s\nRebuild %s with %s env elements and top of the stack %s\n" - (tag_of t) - (show t) - (show (List.length env)) - (show (fst <| firstn 4 stack)); - if !dbg_NormRebuild - then match FStar.Syntax.Util.unbound_variables t with - | [] -> () - | bvs -> - BU.print3 "!!! Rebuild (%s) %s, free vars=%s\n" - (tag_of t) - (show t) - (show bvs); - failwith "DIE!"); - - let f_opt = is_fext_on_domain t in - if f_opt |> is_some && (match stack with | Arg _::_ -> true | _ -> false) //AR: it is crucial to check that (on_domain a #b) is actually applied, else it would be unsound to reduce it to f - then f_opt |> must |> norm cfg env stack - else - let t, renorm = maybe_simplify cfg env stack t in - if renorm - then norm cfg env stack t - else do_rebuild cfg env stack t - -and do_rebuild (cfg:cfg) (env:env) (stack:stack) (t:term) : term = - match stack with - | [] -> t - - | Meta(_, m, r)::stack -> - let t = - // - //AR/NS: 04/22/2022: The code below collapses the towers of - // meta monadic nodes, keeping the outermost effect - // We did this optimization during a debugging session - // - match m with - | Meta_monadic _ -> - (match (SS.compress t).n with - | Tm_meta {tm=t'; meta=Meta_monadic _} -> - mk (Tm_meta {tm=t'; meta=m}) r - | _ -> mk (Tm_meta {tm=t; meta=m}) r) - | _ -> mk (Tm_meta {tm=t; meta=m}) r in - rebuild cfg env stack t - - | MemoLazy r::stack -> - set_memo cfg r (env, t); - log cfg (fun () -> BU.print1 "\tSet memo %s\n" (show t)); - rebuild cfg env stack t - - | Let(env', bs, lb, r)::stack -> - let body = SS.close bs t in - let t = S.mk (Tm_let {lbs=(false, [lb]); body}) r in - rebuild cfg env' stack t - - | Abs (env', bs, env'', lopt, r)::stack -> - let bs = norm_binders cfg env' bs in - let lopt = BU.map_option (norm_residual_comp cfg env'') lopt in - rebuild cfg env stack ({abs bs t lopt with pos=r}) - - | Arg (Univ _, _, _)::_ - | Arg (Dummy, _, _)::_ -> failwith "Impossible" - - | UnivArgs(us, r)::stack -> - let t = mk_Tm_uinst t us in - rebuild cfg env stack t - - | Arg (Clos(env_arg, tm, _, _), aq, r) :: stack - when U.is_fstar_tactics_by_tactic (head_of t) -> - let t = S.extend_app t (closure_as_term cfg env_arg tm, aq) r in - rebuild cfg env stack t - - | Arg (Clos(env_arg, tm, m, _), aq, r) :: stack -> - log cfg (fun () -> BU.print1 "Rebuilding with arg %s\n" (show tm)); - - (* If we are doing hnf (and the head is not a primop), then there is - no need to normalize the argument. *) - if cfg.steps.hnf && not (is_partial_primop_app cfg t) then ( - let arg = closure_as_term cfg env_arg tm in - let t = extend_app t (arg, aq) r in - rebuild cfg env_arg stack t - ) else ( - (* If the argument was already normalized+memoized, reuse it. *) - match read_memo cfg m with - | Some (_, a) -> - let t = S.extend_app t (a, aq) r in - rebuild cfg env_arg stack t - - | None when not cfg.steps.iota -> - (* If we are not doing iota, do not memoize the partial solution. - I do not understand exactly why this is needed, but I'm retaining - the logic. Removing this branch in fact leads to a failure, when - trying to typecheck the following: - - private let fa_intro_lem (#a:Type) (#p:a -> Type) (f:(x:a -> squash (p x))) : Lemma (forall (x:a). p x) = - Classical.lemma_forall_intro_gtot - ((fun x -> IndefiniteDescription.elim_squash (f x)) <: (x:a -> GTot (p x))) - - because the ascription gets dropped. I don't see why iota would matter, - perhaps it's a flag that happens to be there. *) - let stack = App(env, t, aq, r)::stack in - norm cfg env_arg stack tm - - | None -> - (* Otherwise normalize the argument and memoize it. *) - let stack = MemoLazy m::App(env, t, aq, r)::stack in - norm cfg env_arg stack tm - ) - - | App(env, head, aq, r)::stack' when should_reify cfg stack -> - let t0 = t in - let fallback msg () = - log cfg (fun () -> BU.print2 "Not reifying%s: %s\n" msg (show t)); - let t = S.extend_app head (t, aq) r in - rebuild cfg env stack' t - in - // - //AR: no non-extraction reification for layered effects, - // unless TAC - // - let is_non_tac_layered_effect m = - let norm_m = m |> Env.norm_eff_name cfg.tcenv in - (not (Ident.lid_equals norm_m PC.effect_TAC_lid)) && - norm_m |> Env.is_layered_effect cfg.tcenv in - - begin match (SS.compress t).n with - | Tm_meta {meta=Meta_monadic (m, _)} - when is_non_tac_layered_effect m && - not cfg.steps.for_extraction -> - fallback (BU.format1 - "Meta_monadic for a non-TAC layered effect %s in non-extraction mode" - (Ident.string_of_lid m)) () - - | Tm_meta {meta=Meta_monadic (m, _)} - when is_non_tac_layered_effect m && - cfg.steps.for_extraction && - S.Extract_none? (get_extraction_mode cfg.tcenv m) -> - // - // If the effect is an indexed effect, that is non-extractable - // - let S.Extract_none msg = get_extraction_mode cfg.tcenv m in - raise_error t Errors.Fatal_UnexpectedEffect - (BU.format2 "Normalizer cannot reify effect %s for extraction since %s" - (Ident.string_of_lid m) msg) - - | Tm_meta {meta=Meta_monadic (m, _)} - when is_non_tac_layered_effect m && - cfg.steps.for_extraction && - get_extraction_mode cfg.tcenv m = S.Extract_primitive -> - - // If primitive extraction, don't reify - fallback (BU.format1 - "Meta_monadic for a non-TAC layered effect %s which is Extract_primtiive" - (Ident.string_of_lid m)) () - - | Tm_meta {meta=Meta_monadic_lift (msrc, mtgt, _)} - when (is_non_tac_layered_effect msrc || - is_non_tac_layered_effect mtgt) && - not cfg.steps.for_extraction -> - fallback (BU.format2 - "Meta_monadic_lift for a non-TAC layered effect %s ~> %s in non extraction mode" - (Ident.string_of_lid msrc) (Ident.string_of_lid mtgt)) () - - | Tm_meta {meta=Meta_monadic_lift (msrc, mtgt, _)} - when cfg.steps.for_extraction && - ((is_non_tac_layered_effect msrc && - S.Extract_none? (get_extraction_mode cfg.tcenv msrc)) || - (is_non_tac_layered_effect mtgt && - S.Extract_none? (get_extraction_mode cfg.tcenv mtgt))) -> - - raise_error t Errors.Fatal_UnexpectedEffect - (BU.format2 "Normalizer cannot reify %s ~> %s for extraction" - (Ident.string_of_lid msrc) - (Ident.string_of_lid mtgt)) - - | Tm_meta {tm=t; meta=Meta_monadic (m, ty)} -> - do_reify_monadic (fallback " (1)") cfg env stack t m ty - - | Tm_meta {tm=t; meta=Meta_monadic_lift (msrc, mtgt, ty)} -> - let lifted = reify_lift cfg t msrc mtgt (closure_as_term cfg env ty) in - log cfg (fun () -> BU.print1 "Reified lift to (1): %s\n" (show lifted)); - norm cfg env (List.tl stack) lifted - - | Tm_app {hd={n = Tm_constant (FC.Const_reflect _)}; args=[(e, _)]} -> - // reify (reflect e) ~> e - // Although shouldn't `e` ALWAYS be marked with a Meta_monadic? - norm cfg env stack' e - - | Tm_app _ when cfg.steps.primops -> - let hd, args = U.head_and_args_full_unmeta t in - (match (U.un_uinst hd).n with - | Tm_fvar fv -> - begin - match find_prim_step cfg fv with - | Some ({auto_reflect=Some n}) - when List.length args = n -> - norm cfg env stack' t - | _ -> fallback " (3)" () - end - | _ -> fallback " (4)" ()) - - | _ -> - fallback " (2)" () - end - - | App(env, head, aq, r)::stack -> - let t = S.extend_app head (t,aq) r in - rebuild cfg env stack t - - | CBVApp(env', head, aq, r)::stack -> - norm cfg env' (Arg (Clos (env, t, fresh_memo (), false), aq, t.pos) :: stack) head - - | Match(env', asc_opt, branches, lopt, cfg, r) :: stack -> - let lopt = BU.map_option (norm_residual_comp cfg env') lopt in - log cfg (fun () -> BU.print1 "Rebuilding with match, scrutinee is %s ...\n" (show t)); - //the scrutinee is always guaranteed to be a pure or ghost term - //see tc.fs, the case of Tm_match and the comment related to issue #594 - let scrutinee_env = env in - let env = env' in - let scrutinee = t in - let norm_and_rebuild_match () = - log cfg (fun () -> - BU.print2 "match is irreducible: scrutinee=%s\nbranches=%s\n" - (show scrutinee) - (branches |> List.map (fun (p, _, _) -> show p) |> String.concat "\n\t")); - // If either Weak or HNF, then don't descend into branch - let whnf = cfg.steps.weak || cfg.steps.hnf in - let cfg_exclude_zeta = - if cfg.steps.zeta_full - then cfg - else - let new_delta = - cfg.delta_level |> List.filter (function - | Env.InliningDelta - | Env.Eager_unfolding_only -> true - | _ -> false) - in - let steps = { - cfg.steps with - zeta = false; - unfold_until = None; - unfold_only = None; - unfold_attr = None; - unfold_qual = None; - unfold_namespace = None; - dont_unfold_attr = None; - } - in - ({cfg with delta_level=new_delta; steps=steps; strong=true}) - in - let norm_or_whnf env t = - if whnf - then closure_as_term cfg_exclude_zeta env t - else norm cfg_exclude_zeta env [] t - in - let rec norm_pat env p = match p.v with - | Pat_constant _ -> p, env - | Pat_cons(fv, us_opt, pats) -> - let us_opt = - if cfg.steps.erase_universes - then None - else ( - match us_opt with - | None -> None - | Some us -> - Some (List.map (norm_universe cfg env) us) - ) - in - let pats, env = pats |> List.fold_left (fun (pats, env) (p, b) -> - let p, env = norm_pat env p in - (p,b)::pats, env) ([], env) in - {p with v=Pat_cons(fv, us_opt, List.rev pats)}, env - | Pat_var x -> - let x = {x with sort=norm_or_whnf env x.sort} in - {p with v=Pat_var x}, dummy () ::env - | Pat_dot_term eopt -> - let eopt = BU.map_option (norm_or_whnf env) eopt in - {p with v=Pat_dot_term eopt}, env - in - let norm_branches () = - match env with - | [] when whnf -> branches //nothing to close over - | _ -> branches |> List.map (fun branch -> - let p, wopt, e = SS.open_branch branch in - //It's important to normalize all the sorts within the pat! - let p, env = norm_pat env p in - let wopt = match wopt with - | None -> None - | Some w -> Some (norm_or_whnf env w) in - let e = norm_or_whnf env e in - U.branch (p, wopt, e)) - in - let maybe_commute_matches () = - let can_commute = - match branches with - | ({v=Pat_cons(fv, _, _)}, _, _)::_ -> - Env.fv_has_attr cfg.tcenv fv FStar.Parser.Const.commute_nested_matches_lid - | _ -> false in - match (U.unascribe scrutinee).n with - | Tm_match {scrutinee=sc0; - ret_opt=asc_opt0; - brs=branches0; - rc_opt=lopt0} when can_commute -> - (* We have a blocked match, because of something like - - (match (match sc0 with P1 -> e1 | ... | Pn -> en) with - | Q1 -> f1 ... | Qm -> fm) - - We'll reduce it as if it was instead - - (match sc0 with - | P1 -> (match e1 with | Q1 -> f1 ... | Qm -> fm) - ... - | Pn -> (match en with | Q1 -> f1 ... | Qm -> fm)) - - if the Qi are constructors from an inductive marked with the - commute_nested_matches attribute - *) - let reduce_branch (b:S.branch) = - //reduce the inner branch `b` while setting the continuation - //stack to be the outer match - let stack = [Match(env', asc_opt, branches, lopt, cfg, r)] in - let p, wopt, e = SS.open_branch b in - //It's important to normalize all the sorts within the pat! - let p, branch_env = norm_pat scrutinee_env p in - let wopt = match wopt with - | None -> None - | Some w -> Some (norm_or_whnf branch_env w) in - let e = norm cfg branch_env stack e in - U.branch (p, wopt, e) - in - let branches0 = List.map reduce_branch branches0 in - rebuild cfg env stack (mk (Tm_match {scrutinee=sc0; - ret_opt=asc_opt0; - brs=branches0; - rc_opt=lopt0}) r) - | _ -> - let scrutinee = - if cfg.steps.iota - && (not cfg.steps.weak) - && (not cfg.steps.compress_uvars) - && cfg.steps.weakly_reduce_scrutinee - && maybe_weakly_reduced scrutinee - then norm ({cfg with steps={cfg.steps with weakly_reduce_scrutinee=false}}) - scrutinee_env - [] - scrutinee //scrutinee was only reduced to wnf; reduce it fully - else scrutinee - in - let asc_opt = norm_match_returns cfg env asc_opt in - let branches = norm_branches() in - rebuild cfg env stack (mk (Tm_match {scrutinee; - ret_opt=asc_opt; - brs=branches; - rc_opt=lopt}) r) - in - maybe_commute_matches() - in - - let rec is_cons head = match (SS.compress head).n with - | Tm_uinst(h, _) -> is_cons h - | Tm_constant _ - | Tm_fvar( {fv_qual=Some Data_ctor} ) - | Tm_fvar( {fv_qual=Some (Record_ctor _)} ) -> true - | _ -> false - in - - let guard_when_clause wopt b rest = - match wopt with - | None -> b - | Some w -> - let then_branch = b in - let else_branch = mk (Tm_match {scrutinee; - ret_opt=asc_opt; - brs=rest; - rc_opt=lopt}) r in - U.if_then_else w then_branch else_branch - in - - - let rec matches_pat (scrutinee_orig:term) (p:pat) - : either (list (bv & term)) bool - (* Inl ts: p matches t and ts are bindings for the branch *) - (* Inr false: p definitely does not match t *) - (* Inr true: p may match t, but p is an open term and we cannot decide for sure *) - = let scrutinee = U.unmeta scrutinee_orig in - let scrutinee = U.unlazy scrutinee in - let head, args = U.head_and_args scrutinee in - match p.v with - | Pat_var bv -> Inl [(bv, scrutinee_orig)] - | Pat_dot_term _ -> Inl [] - | Pat_constant s -> begin - match scrutinee.n with - | Tm_constant s' - when FStar.Const.eq_const s s' -> - Inl [] - | _ -> Inr (not (is_cons head)) //if it's not a constant, it may match - end - | Pat_cons(fv, _, arg_pats) -> begin - match (U.un_uinst head).n with - | Tm_fvar fv' when fv_eq fv fv' -> - matches_args [] args arg_pats - | _ -> Inr (not (is_cons head)) //if it's not a constant, it may match - end - - and matches_args out (a:args) (p:list (pat & bool)) : either (list (bv & term)) bool = match a, p with - | [], [] -> Inl out - | (t, _)::rest_a, (p, _)::rest_p -> - begin match matches_pat t p with - | Inl s -> matches_args (out@s) rest_a rest_p - | m -> m - end - | _ -> Inr false - in - - let rec matches scrutinee p = match p with - | [] -> norm_and_rebuild_match () - | (p, wopt, b)::rest -> - match matches_pat scrutinee p with - | Inr false -> //definite mismatch; safe to consider the remaining patterns - matches scrutinee rest - - | Inr true -> //may match this pattern but t is an open term; block reduction - norm_and_rebuild_match () - - | Inl s -> //definite match - log cfg (fun () -> BU.print2 "Matches pattern %s with subst = %s\n" - (show p) - (List.map (fun (_, t) -> show t) s |> String.concat "; ")); - //the elements of s are sub-terms of t - //the have no free de Bruijn indices; so their env=[]; see pre-condition at the top of rebuild - let env0 = env in - - - // The scrutinee is (at least) in weak normal - // form. This means, it can be of the form (C v1 - // ... (fun x -> e) ... vn) - - //ie., it may have some sub-terms that are lambdas - //with unreduced bodies - - //but, since the memo references are expected to hold - //weakly normal terms, it is safe to set them to the - //sub-terms of the scrutinee - - //otherwise, we will keep reducing them over and over - //again. See, e.g., Issue #2757 - - //Except, if the normalizer is running in HEAD normal form mode, - //then the sub-terms of the scrutinee might not be reduced yet. - //In that case, do not set the memo reference - let env = List.fold_left - (fun env (bv, t) -> (Some (S.mk_binder bv), - Clos([], t, BU.mk_ref (if cfg.steps.hnf then None else Some (cfg, ([], t))), false), - fresh_memo ()) :: env) - env s in - norm cfg env stack (guard_when_clause wopt b rest) - in - - if cfg.steps.iota - then matches scrutinee branches - else norm_and_rebuild_match () - -and norm_match_returns cfg env ret_opt = - match ret_opt with - | None -> None - | Some (b, asc) -> - let b = norm_binder cfg env b in - let subst, asc = SS.open_ascription [b] asc in - let asc = norm_ascription cfg (dummy()::env) asc in - Some (b, SS.close_ascription subst asc) - -and norm_ascription cfg env (tc, tacopt, use_eq) = - (match tc with - | Inl t -> Inl (norm cfg env [] t) - | Inr c -> Inr (norm_comp cfg env c)), - BU.map_opt tacopt (norm cfg env []), - use_eq - -and norm_residual_comp cfg env (rc:residual_comp) : residual_comp = - {rc with residual_typ = BU.map_option (closure_as_term cfg env) rc.residual_typ} - -let reflection_env_hook = BU.mk_ref None - -let normalize_with_primitive_steps ps s e (t:term) = - let is_nbe = is_nbe_request s in - let maybe_nbe = if is_nbe then " (NBE)" else "" in - Errors.with_ctx ("While normalizing a term" ^ maybe_nbe) (fun () -> - Profiling.profile (fun () -> - let c = config' ps s e in - reflection_env_hook := Some e; - plugin_unfold_warn_ctr := 10; - log_top c (fun () -> BU.print2 "\nStarting normalizer%s for (%s) {\n" maybe_nbe (show t)); - log_top c (fun () -> BU.print1 ">>> cfg = %s\n" (show c)); - def_check_scoped t.pos "normalize_with_primitive_steps call" e t; - let (r, ms) = - BU.record_time (fun () -> - if is_nbe - then nbe_eval c s t - else norm c [] [] t - ) - in - log_top c (fun () -> BU.print3 "}\nNormalization%s result = (%s) in %s ms\n" maybe_nbe (show r) (show ms)); - r - ) - (Some (Ident.string_of_lid (Env.current_module e))) - "FStar.TypeChecker.Normalize.normalize_with_primitive_steps" - ) - -let normalize s e t = - Profiling.profile (fun () -> normalize_with_primitive_steps [] s e t) - (Some (Ident.string_of_lid (Env.current_module e))) - "FStar.TypeChecker.Normalize.normalize" - -let normalize_comp s e c = - Profiling.profile (fun () -> - let cfg = config s e in - reflection_env_hook := Some e; - plugin_unfold_warn_ctr := 10; - log_top cfg (fun () -> BU.print1 "Starting normalizer for computation (%s) {\n" (show c)); - log_top cfg (fun () -> BU.print1 ">>> cfg = %s\n" (show cfg)); - def_check_scoped c.pos "normalize_comp call" e c; - let (c, ms) = Errors.with_ctx "While normalizing a computation type" (fun () -> - BU.record_time (fun () -> - norm_comp cfg [] c)) - in - log_top cfg (fun () -> BU.print2 "}\nNormalization result = (%s) in %s ms\n" (show c) (show ms)); - c) - (Some (Ident.string_of_lid (Env.current_module e))) - "FStar.TypeChecker.Normalize.normalize_comp" - -let normalize_universe env u = Errors.with_ctx "While normalizing a universe level" (fun () -> - norm_universe (config [] env) [] u -) - -let non_info_norm env t = - let steps = [UnfoldUntil delta_constant; - AllowUnboundUniverses; - EraseUniverses; - HNF; - (* We could use Weak too were it not that we need - * to descend in the codomain of arrows. *) - Unascribe; //remove ascriptions - ForExtraction //and refinement types - ] - in - non_informative env (normalize steps env t) - -(* - * Ghost T to Pure T promotion - * - * The promotion applies in two scenarios: - * - * One when T is non-informative, where - * Non-informative types T ::= unit | Type u | t -> Tot T | t -> GTot T - * - * Second when Ghost T is being composed with or lifted to another - * erasable effect - *) - -let maybe_promote_t env non_informative_only t = - not non_informative_only || non_info_norm env t - -let ghost_to_pure_aux env non_informative_only c = - match c.n with - | Total _ -> c - | GTotal t -> - if maybe_promote_t env non_informative_only t then {c with n = Total t} else c - | Comp ct -> - let l = Env.norm_eff_name env ct.effect_name in - if U.is_ghost_effect l - && maybe_promote_t env non_informative_only ct.result_typ - then let ct = - match downgrade_ghost_effect_name ct.effect_name with - | Some pure_eff -> - let flags = if Ident.lid_equals pure_eff PC.effect_Tot_lid then TOTAL::ct.flags else ct.flags in - {ct with effect_name=pure_eff; flags=flags} - | None -> - let ct = unfold_effect_abbrev env c in //must be GHOST - {ct with effect_name=PC.effect_PURE_lid} in - {c with n=Comp ct} - else c - | _ -> c - -let ghost_to_pure_lcomp_aux env non_informative_only (lc:lcomp) = - if U.is_ghost_effect lc.eff_name - && maybe_promote_t env non_informative_only lc.res_typ - then match downgrade_ghost_effect_name lc.eff_name with - | Some pure_eff -> - { TcComm.apply_lcomp (ghost_to_pure_aux env non_informative_only) (fun g -> g) lc - with eff_name = pure_eff } - | None -> //can't downgrade, don't know the particular incarnation of PURE to use - lc - else lc - -(* only promote non-informative types *) -let maybe_ghost_to_pure env c = ghost_to_pure_aux env true c -let maybe_ghost_to_pure_lcomp env lc = ghost_to_pure_lcomp_aux env true lc - -(* promote unconditionally *) -let ghost_to_pure env c = ghost_to_pure_aux env false c -let ghost_to_pure_lcomp env lc = ghost_to_pure_lcomp_aux env false lc - -(* - * The following functions implement GHOST to PURE promotion - * when the GHOST effect is being composed with or lifted to - * another erasable effect - * In that case the "ghostness" or erasability of GHOST is already - * accounted for in the erasable effect - *) -let ghost_to_pure2 env (c1, c2) = - let c1, c2 = maybe_ghost_to_pure env c1, maybe_ghost_to_pure env c2 in - - let c1_eff = c1 |> U.comp_effect_name |> Env.norm_eff_name env in - let c2_eff = c2 |> U.comp_effect_name |> Env.norm_eff_name env in - - if Ident.lid_equals c1_eff c2_eff then c1, c2 - else let c1_erasable = Env.is_erasable_effect env c1_eff in - let c2_erasable = Env.is_erasable_effect env c2_eff in - - if c1_erasable && Ident.lid_equals c2_eff PC.effect_GHOST_lid - then c1, ghost_to_pure env c2 - else if c2_erasable && Ident.lid_equals c1_eff PC.effect_GHOST_lid - then ghost_to_pure env c1, c2 - else c1, c2 - -let ghost_to_pure_lcomp2 env (lc1, lc2) = - let lc1, lc2 = maybe_ghost_to_pure_lcomp env lc1, maybe_ghost_to_pure_lcomp env lc2 in - - let lc1_eff = Env.norm_eff_name env lc1.eff_name in - let lc2_eff = Env.norm_eff_name env lc2.eff_name in - - if Ident.lid_equals lc1_eff lc2_eff then lc1, lc2 - else let lc1_erasable = Env.is_erasable_effect env lc1_eff in - let lc2_erasable = Env.is_erasable_effect env lc2_eff in - - if lc1_erasable && Ident.lid_equals lc2_eff PC.effect_GHOST_lid - then lc1, ghost_to_pure_lcomp env lc2 - else if lc2_erasable && Ident.lid_equals lc1_eff PC.effect_GHOST_lid - then ghost_to_pure_lcomp env lc1, lc2 - else lc1, lc2 - -let warn_norm_failure (r:Range.range) (e:exn) : unit = - Errors.log_issue r Errors.Warning_NormalizationFailure (BU.format1 "Normalization failed with error %s\n" (BU.message_of_exn e)) - -let term_to_doc env t = - let t = - try normalize [AllowUnboundUniverses] env t - with e -> - warn_norm_failure t.pos e; - t - in - FStar.Syntax.Print.term_to_doc' (DsEnv.set_current_module env.dsenv env.curmodule) t - -let term_to_string env t = GenSym.with_frozen_gensym (fun () -> - let t = - try normalize [AllowUnboundUniverses] env t - with e -> - warn_norm_failure t.pos e; - t - in - Print.term_to_string' (DsEnv.set_current_module env.dsenv env.curmodule) t) - -let comp_to_string env c = GenSym.with_frozen_gensym (fun () -> - let c = - try norm_comp (config [AllowUnboundUniverses] env) [] c - with e -> - warn_norm_failure c.pos e; - c - in - Print.comp_to_string' (DsEnv.set_current_module env.dsenv env.curmodule) c) - -let comp_to_doc env c = GenSym.with_frozen_gensym (fun () -> - let c = - try norm_comp (config [AllowUnboundUniverses] env) [] c - with e -> - warn_norm_failure c.pos e; - c - in - Print.comp_to_doc' (DsEnv.set_current_module env.dsenv env.curmodule) c) - -let normalize_refinement steps env t0 = - let t = normalize (steps@[Beta]) env t0 in - U.flatten_refinement t - -let whnf_steps = [Primops; Weak; HNF; UnfoldUntil delta_constant; Beta] -let unfold_whnf' steps env t = normalize (steps@whnf_steps) env t -let unfold_whnf env t = unfold_whnf' [] env t - -let reduce_or_remove_uvar_solutions remove env t = - normalize ((if remove then [DefaultUnivsToZero; CheckNoUvars] else []) - @[Beta; DoNotUnfoldPureLets; CompressUvars; Exclude Zeta; Exclude Iota; NoFullNorm;]) - env - t -let reduce_uvar_solutions env t = reduce_or_remove_uvar_solutions false env t -let remove_uvar_solutions env t = reduce_or_remove_uvar_solutions true env t - -let eta_expand_with_type (env:Env.env) (e:term) (t_e:typ) = - //unfold_whnf env t_e in - //It would be nice to eta_expand based on the WHNF of t_e - //except that this triggers a brittleness in the unification algorithm and its interaction with SMT encoding - //in particular, see Rel.u_abs (roughly line 520) - let formals, c = U.arrow_formals_comp t_e in - match formals with - | [] -> e - | _ -> - let actuals, _, _ = U.abs_formals e in - if List.length actuals = List.length formals - then e - else let binders, args = formals |> U.args_of_binders in - U.abs binders (mk_Tm_app e args e.pos) - (Some (U.residual_comp_of_comp c)) - -let eta_expand (env:Env.env) (t:term) : term = - match t.n with - | Tm_name x -> - eta_expand_with_type env t x.sort - | _ -> - let head, args = U.head_and_args t in - begin match (SS.compress head).n with - | Tm_uvar (u,s) -> - let formals, _tres = U.arrow_formals (SS.subst' s (U.ctx_uvar_typ u)) in - if List.length formals = List.length args - then t - else let _, ty, _ = env.typeof_tot_or_gtot_term ({env with admit=true; expected_typ=None}) t true in - eta_expand_with_type env t ty - | _ -> - let _, ty, _ = env.typeof_tot_or_gtot_term ({env with admit=true; expected_typ=None}) t true in - eta_expand_with_type env t ty - end - -let elim_uvars_aux_tc (env:Env.env) (univ_names:univ_names) (binders:binders) (tc:either typ comp) = - let t = - match binders, tc with - | [], Inl t -> t - | [], Inr c -> failwith "Impossible: empty bindes with a comp" - | _ , Inr c -> S.mk (Tm_arrow {bs=binders; comp=c}) c.pos - | _ , Inl t -> S.mk (Tm_arrow {bs=binders; comp=S.mk_Total t}) t.pos - in - let univ_names, t = Subst.open_univ_vars univ_names t in - let t = remove_uvar_solutions env t in - let t = Subst.close_univ_vars univ_names t in - let binders, tc = - match binders with - | [] -> [], Inl t - | _ -> begin - match (SS.compress t).n, tc with - | Tm_arrow {bs=binders; comp=c}, Inr _ -> binders, Inr c - | Tm_arrow {bs=binders; comp=c}, Inl _ -> binders, Inl (U.comp_result c) - | _, Inl _ -> [], Inl t - | _ -> failwith "Impossible" - end - in - univ_names, binders, tc - -let elim_uvars_aux_t env univ_names binders t = - let univ_names, binders, tc = elim_uvars_aux_tc env univ_names binders (Inl t) in - univ_names, binders, BU.left tc - -let elim_uvars_aux_c env univ_names binders c = - let univ_names, binders, tc = elim_uvars_aux_tc env univ_names binders (Inr c) in - univ_names, binders, BU.right tc - -let rec elim_uvars (env:Env.env) (s:sigelt) = - let sigattrs = List.map Mktuple3?._3 <| List.map (elim_uvars_aux_t env [] []) s.sigattrs in - let s = { s with sigattrs } in - match s.sigel with - | Sig_inductive_typ {lid; us=univ_names; params=binders; - num_uniform_params=num_uniform; - t=typ; - mutuals=lids; - ds=lids'; - injective_type_params} -> - let univ_names, binders, typ = elim_uvars_aux_t env univ_names binders typ in - {s with sigel = Sig_inductive_typ {lid; - us=univ_names; - params=binders; - num_uniform_params=num_uniform; - t=typ; - mutuals=lids; - ds=lids'; - injective_type_params}} - - | Sig_bundle {ses=sigs; lids} -> - {s with sigel = Sig_bundle {ses=List.map (elim_uvars env) sigs; lids}} - - | Sig_datacon {lid; us=univ_names; t=typ; ty_lid=lident; num_ty_params=i; mutuals=lids; injective_type_params} -> - let univ_names, _, typ = elim_uvars_aux_t env univ_names [] typ in - {s with sigel = Sig_datacon {lid; - us=univ_names; - t=typ; - ty_lid=lident; - num_ty_params=i; - mutuals=lids; - injective_type_params}} - - | Sig_declare_typ {lid; us=univ_names; t=typ} -> - let univ_names, _, typ = elim_uvars_aux_t env univ_names [] typ in - {s with sigel = Sig_declare_typ {lid; us=univ_names; t=typ}} - - | Sig_let {lbs=(b, lbs); lids} -> - let lbs = lbs |> List.map (fun lb -> - let opening, lbunivs = Subst.univ_var_opening lb.lbunivs in - let elim t = Subst.close_univ_vars lbunivs (remove_uvar_solutions env (Subst.subst opening t)) in - let lbtyp = elim lb.lbtyp in - let lbdef = elim lb.lbdef in - {lb with lbunivs = lbunivs; - lbtyp = lbtyp; - lbdef = lbdef}) - in - {s with sigel = Sig_let {lbs=(b, lbs); lids}} - - | Sig_assume {lid=l; us; phi=t} -> - let us, _, t = elim_uvars_aux_t env us [] t in - {s with sigel = Sig_assume {lid=l; us; phi=t}} - - | Sig_new_effect ed -> - //AR: S.t_unit is just a dummy comp type, we only care about the binders - let univs, binders, _ = elim_uvars_aux_t env ed.univs ed.binders S.t_unit in - let univs_opening, univs_closing = - let univs_opening, univs = SS.univ_var_opening univs in - univs_opening, SS.univ_var_closing univs - in - let b_opening, b_closing = - let binders = SS.open_binders binders in - SS.opening_of_binders binders, - SS.closing_of_binders binders - in - let n = List.length univs in - let n_binders = List.length binders in - let elim_tscheme (us, t) = - let n_us = List.length us in - let us, t = SS.open_univ_vars us t in - let b_opening, b_closing = - b_opening |> SS.shift_subst n_us, - b_closing |> SS.shift_subst n_us in - let univs_opening, univs_closing = - univs_opening |> SS.shift_subst (n_us + n_binders), - univs_closing |> SS.shift_subst (n_us + n_binders) in - let t = SS.subst univs_opening (SS.subst b_opening t) in - let _, _, t = elim_uvars_aux_t env [] [] t in - let t = SS.subst univs_closing (SS.subst b_closing (SS.close_univ_vars us t)) in - us, t - in - let elim_term t = - let _, _, t = elim_uvars_aux_t env univs binders t in - t - in - let elim_action a = - let action_typ_templ = - let body = S.mk (Tm_ascribed {tm=a.action_defn; - asc=(Inl a.action_typ, None, false); - eff_opt=None}) a.action_defn.pos in - match a.action_params with - | [] -> body - | _ -> S.mk (Tm_abs {bs=a.action_params; body; rc_opt=None}) a.action_defn.pos in - let destruct_action_body body = - match (SS.compress body).n with - | Tm_ascribed {tm=defn; asc=(Inl typ, None, _); eff_opt=None} -> defn, typ - | _ -> failwith "Impossible" - in - let destruct_action_typ_templ t = - match (SS.compress t).n with - | Tm_abs {bs=pars; body} -> - let defn, typ = destruct_action_body body in - pars, defn, typ - | _ -> - let defn, typ = destruct_action_body t in - [], defn, typ - in - let action_univs, t = elim_tscheme (a.action_univs, action_typ_templ) in - let action_params, action_defn, action_typ = destruct_action_typ_templ t in - let a' = - {a with action_univs = action_univs; - action_params = action_params; - action_defn = action_defn; - action_typ = action_typ} in - a' - in - let ed = { ed with - univs = univs; - binders = binders; - signature = U.apply_eff_sig elim_tscheme ed.signature; - combinators = apply_eff_combinators elim_tscheme ed.combinators; - actions = List.map elim_action ed.actions } in - {s with sigel=Sig_new_effect ed} - - | Sig_sub_effect sub_eff -> - let elim_tscheme_opt = function - | None -> None - | Some (us, t) -> let us, _, t = elim_uvars_aux_t env us [] t in Some (us, t) - in - let sub_eff = {sub_eff with lift = elim_tscheme_opt sub_eff.lift; - lift_wp = elim_tscheme_opt sub_eff.lift_wp} in - {s with sigel=Sig_sub_effect sub_eff} - - | Sig_effect_abbrev {lid; us=univ_names; bs=binders; comp; cflags=flags} -> - let univ_names, binders, comp = elim_uvars_aux_c env univ_names binders comp in - {s with sigel = Sig_effect_abbrev {lid; us=univ_names; bs=binders; comp; cflags=flags}} - - | Sig_pragma _ -> - s - - (* These should never happen, they should have been elaborated by now *) - | Sig_fail _ - | Sig_splice _ -> - s - - | Sig_polymonadic_bind {m_lid=m; - n_lid=n; - p_lid=p; - tm=(us_t, t); - typ=(us_ty, ty); - kind=k} -> - let us_t, _, t = elim_uvars_aux_t env us_t [] t in - let us_ty, _, ty = elim_uvars_aux_t env us_ty [] ty in - { s with sigel = Sig_polymonadic_bind {m_lid=m; - n_lid=n; - p_lid=p; - tm=(us_t, t); - typ=(us_ty, ty); - kind=k} } - - | Sig_polymonadic_subcomp {m_lid=m; n_lid=n; tm=(us_t, t); typ=(us_ty, ty); kind=k} -> - let us_t, _, t = elim_uvars_aux_t env us_t [] t in - let us_ty, _, ty = elim_uvars_aux_t env us_ty [] ty in - { s with sigel = Sig_polymonadic_subcomp {m_lid=m; - n_lid=n; - tm=(us_t, t); - typ=(us_ty, ty); - kind=k} } - - -let erase_universes env t = - normalize [EraseUniverses; AllowUnboundUniverses] env t - -let unfold_head_once env t = - let aux f us args = - match Env.lookup_nonrec_definition [Env.Unfold delta_constant] env f.fv_name.v with - | None -> None - | Some head_def_ts -> - let _, head_def = Env.inst_tscheme_with head_def_ts us in - let t' = S.mk_Tm_app head_def args t.pos in - let t' = normalize [Env.Beta; Env.Iota] env t' in - Some t' - in - let head, args = U.head_and_args t in - match (SS.compress head).n with - | Tm_fvar fv -> aux fv [] args - | Tm_uinst({n=Tm_fvar fv}, us) -> aux fv us args - | _ -> None - -let get_n_binders' (env:Env.env) (steps : list step) (n:int) (t:term) : list binder & comp = - let rec aux (retry:bool) (n:int) (t:term) : list binder & comp = - let bs, c = U.arrow_formals_comp t in - let len = List.length bs in - match bs, c with - (* Got no binders, maybe retry after normalizing *) - | [], _ when retry -> - aux false n (unfold_whnf' steps env t) - - (* Can't retry, stop *) - | [], _ when not retry -> - (bs, c) - - (* Exactly what we wanted, return *) - | bs, c when len = n -> - (bs, c) - - (* Plenty of binders, grab as many as needed and finish *) - | bs, c when len > n -> - let bs_l, bs_r = List.splitAt n bs in - (bs_l, S.mk_Total (U.arrow bs_r c)) - - (* We need more, descend if `c` is total *) - | bs, c when len < n && U.is_total_comp c && not (U.has_decreases c) -> - let (bs', c') = aux true (n-len) (U.comp_result c) in - (bs@bs', c') - - (* Not enough, but we can't descend, just return *) - | bs, c -> - (bs, c) - in - aux true n t - -let get_n_binders env n t = get_n_binders' env [] n t - -let () = - __get_n_binders := get_n_binders' - -let maybe_unfold_head_fv (env:Env.env) (head:term) - : option term - = let fv_us_opt = - match (SS.compress head).n with - | Tm_uinst ({n=Tm_fvar fv}, us) -> Some (fv, us) - | Tm_fvar fv -> Some (fv, []) - | _ -> None - in - match fv_us_opt with - | None -> None - | Some (fv, us) -> - match Env.lookup_nonrec_definition [Unfold delta_constant] env fv.fv_name.v with - | None -> None - | Some (us_formals, defn) -> - let subst = mk_univ_subst us_formals us in - SS.subst subst defn |> Some - -let rec maybe_unfold_aux (env:Env.env) (t:term) : option term = - match (SS.compress t).n with - | Tm_match {scrutinee=t0; ret_opt; brs; rc_opt} -> - BU.map_option - (fun t0 -> S.mk (Tm_match {scrutinee=t0; ret_opt; brs; rc_opt}) t.pos) - (maybe_unfold_aux env t0) - | Tm_fvar _ - | Tm_uinst _ -> maybe_unfold_head_fv env t - | _ -> - let head, args = U.leftmost_head_and_args t in - if args = [] - then maybe_unfold_head_fv env head - else - match maybe_unfold_aux env head with - | None -> None - | Some head -> S.mk_Tm_app head args t.pos |> Some - -let maybe_unfold_head (env:Env.env) (t:term) : option term = - BU.map_option - (normalize [Beta;Iota;Weak;HNF] env) - (maybe_unfold_aux env t) diff --git a/src/typechecker/FStar.TypeChecker.Normalize.fsti b/src/typechecker/FStar.TypeChecker.Normalize.fsti deleted file mode 100644 index c81195059ea..00000000000 --- a/src/typechecker/FStar.TypeChecker.Normalize.fsti +++ /dev/null @@ -1,79 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.TypeChecker.Normalize -open FStar.Compiler.Effect - -open FStar.TypeChecker -open FStar.Syntax.Syntax -open FStar.TypeChecker.Common -open FStar.TypeChecker.Env -open FStar.TypeChecker.Cfg - -val eta_expand_with_type :Env.env -> term -> typ -> term -val eta_expand: Env.env -> term -> term -val normalize: steps -> Env.env -> term -> term -val normalize_universe: Env.env -> universe -> universe -val normalize_comp: steps -> Env.env -> comp -> comp -val normalize_refinement: steps -> Env.env -> typ -> typ -val whnf_steps: list step -val unfold_whnf': steps -> Env.env -> term -> term -val unfold_whnf: Env.env -> term -> term -val reduce_uvar_solutions:Env.env -> term -> term -val non_info_norm: Env.env -> term -> bool - -(* - * The maybe versions of ghost_to_pure only promote - * when the type of the computation is non-informative - * else the input comp is returned as is - *) -val maybe_ghost_to_pure: Env.env -> comp -> comp -val maybe_ghost_to_pure_lcomp: Env.env -> lcomp -> lcomp - -(* - * The two input computations are to be composed or related by subcomp - * These functions first call the maybe versions of ghost_to_pure, and then - * if one of them is erasable, and the other is GHOST, - * the GHOST one is promoted to PURE, see their implementation for more details - *) -val ghost_to_pure2 : Env.env -> (comp & comp) -> (comp & comp) -val ghost_to_pure_lcomp2 : Env.env -> (lcomp & lcomp) -> (lcomp & lcomp) - -val normalize_with_primitive_steps : list Primops.primitive_step -> steps -> Env.env -> term -> term -val term_to_string: Env.env -> term -> string -val term_to_doc: Env.env -> term -> Pprint.document -val comp_to_string: Env.env -> comp -> string -val comp_to_doc: Env.env -> comp -> Pprint.document -val elim_uvars: Env.env -> sigelt -> sigelt -val erase_universes: Env.env -> term -> term - -(* Note: This will default any unresolved universe variables to U_zero. *) -val remove_uvar_solutions: Env.env -> term -> term - -val unfold_head_once: Env.env -> term -> option term -val unembed_binder_knot : ref (option (FStar.Syntax.Embeddings.embedding binder)) - -val is_extract_as_attr : attribute -> option term -val has_extract_as_attr : Env.env -> Ident.lid -> option term - -val reflection_env_hook : ref (option Env.env) - -(* Destructs the term as an arrow type and returns its binders and -computation type. Only grabs up to [n] binders, and normalizes only as -needed to discover the shape of the arrow. The binders are opened. *) -val get_n_binders : Env.env -> int -> term -> list binder & comp - -val maybe_unfold_head : Env.env -> term -> option term diff --git a/src/typechecker/FStar.TypeChecker.PatternUtils.fst b/src/typechecker/FStar.TypeChecker.PatternUtils.fst deleted file mode 100644 index 5973178a019..00000000000 --- a/src/typechecker/FStar.TypeChecker.PatternUtils.fst +++ /dev/null @@ -1,272 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.TypeChecker.PatternUtils -open FStar.Compiler.Effect -open FStar -open FStar.Compiler -open FStar.Compiler.Util -open FStar.Errors -open FStar.TypeChecker -open FStar.Syntax -open FStar.TypeChecker.Env -open FStar.Syntax.Syntax -open FStar.Ident -open FStar.Syntax.Subst -open FStar.TypeChecker.Common - -type lcomp_with_binder = option bv & lcomp - -module SS = FStar.Syntax.Subst -module S = FStar.Syntax.Syntax -module BU = FStar.Compiler.Util -module U = FStar.Syntax.Util -module P = FStar.Syntax.Print -module C = FStar.Parser.Const - -open FStar.Class.Show - -let dbg_Patterns = Debug.get_toggle "Patterns" - -(************************************************************************) -(* Utilities on patterns *) -(************************************************************************) - -let rec elaborate_pat env p = //Adds missing implicit patterns to constructor patterns - let maybe_dot inaccessible a r = - if inaccessible - then withinfo (Pat_dot_term None) r - else withinfo (Pat_var a) r - in - match p.v with - | Pat_cons({fv_qual=Some (Unresolved_constructor _)}, _, _) -> - (* Unresolved constructors cannot be elaborated yet. - tc_pat has to resolve it first. *) - p - - | Pat_cons(fv, us_opt, pats) -> - let pats = List.map (fun (p, imp) -> elaborate_pat env p, imp) pats in - let _, t = Env.lookup_datacon env fv.fv_name.v in - let f, _ = U.arrow_formals t in - let rec aux formals pats = - match formals, pats with - | [], [] -> [] - | [], _::_ -> - raise_error fv.fv_name.v Errors.Fatal_TooManyPatternArguments "Too many pattern arguments" - | _::_, [] -> //fill the rest with dot patterns, if all the remaining formals are implicit - formals |> - List.map - (fun fml -> - let t, imp = fml.binder_bv, fml.binder_qual in - match imp with - | Some (Implicit inaccessible) -> - let a = Syntax.new_bv (Some (Syntax.range_of_bv t)) tun in - let r = range_of_lid fv.fv_name.v in - maybe_dot inaccessible a r, true - - | _ -> - raise_error fv.fv_name.v Errors.Fatal_InsufficientPatternArguments - (BU.format1 "Insufficient pattern arguments (%s)" - (show p))) - - | f::formals', (p, p_imp)::pats' -> - begin - match f.binder_bv, f.binder_qual with - | (_, Some (Implicit inaccessible)) - when inaccessible && p_imp -> //we have an inaccessible pattern but the user wrote a pattern there explicitly - begin - match p.v with - | Pat_dot_term _ -> - (p, true)::aux formals' pats' - - // Only allow it if it won't be bound - | Pat_var v when string_of_id (v.ppname) = Ident.reserved_prefix -> - let a = Syntax.new_bv (Some p.p) tun in - let p = maybe_dot inaccessible a (range_of_lid fv.fv_name.v) in - (p, true)::aux formals' pats' - - | _ -> - raise_error p.p Errors.Fatal_InsufficientPatternArguments - (BU.format1 "This pattern (%s) binds an inaccesible argument; use a wildcard ('_') pattern" - (show p)) - end - - | (_, Some (Implicit _)) when p_imp -> - (p, true)::aux formals' pats' - - | (_, Some (Implicit inaccessible)) -> - let a = Syntax.new_bv (Some p.p) tun in - let p = maybe_dot inaccessible a (range_of_lid fv.fv_name.v) in - (p, true)::aux formals' pats - - | (_, imp) -> - (p, S.is_bqual_implicit imp)::aux formals' pats' - end - in - {p with v=Pat_cons(fv, us_opt, aux f pats)} - | _ -> p - -exception Raw_pat_cannot_be_translated -let raw_pat_as_exp (env:Env.env) (p:pat) - : option (term & list bv) - = let rec aux bs p = - match p.v with - | Pat_constant c -> - let e = - match c with - | FStar.Const.Const_int(repr, Some sw) -> - FStar.ToSyntax.ToSyntax.desugar_machine_integer env.dsenv repr sw p.p - | _ -> - mk (Tm_constant c) p.p - in - e, bs - - | Pat_dot_term eopt -> - begin - match eopt with - | None -> raise Raw_pat_cannot_be_translated - | Some e -> SS.compress e, bs - end - - | Pat_var x -> - mk (Tm_name x) p.p, x::bs - - | Pat_cons(fv, us_opt, pats) -> - let args, bs = - List.fold_right - (fun (p, i) (args, bs) -> - let ep, bs = aux bs p in - ((ep, as_aqual_implicit i) :: args), bs) - pats - ([], bs) - in - let hd = Syntax.fv_to_tm fv in - let hd = - match us_opt with - | None -> hd - | Some us -> S.mk_Tm_uinst hd us - in - let e = mk_Tm_app hd args p.p in - e, bs - in - try Some (aux [] p) - with Raw_pat_cannot_be_translated -> None - -(* - pat_as_exps allow_implicits env p: - Turns a pattern p into a triple: -*) -let pat_as_exp (introduce_bv_uvars:bool) - (inst_pat_cons_univs:bool) - (env:Env.env) - (p:pat) - : (list bv (* pattern-bound variables (which may appear in the branch of match) *) - & term (* expressions corresponding to the pattern *) - & guard_t (* guard with just the implicit variables introduced in the pattern *) - & pat) = (* decorated pattern, with all the missing implicit args in p filled in *) - let intro_bv (env:Env.env) (x:bv) :(bv & guard_t & Env.env) = - if not introduce_bv_uvars - then {x with sort=S.tun}, Env.trivial_guard, env - else let t, _ = U.type_u() in - let t_x, _, guard = new_implicit_var_aux "pattern bv type" (S.range_of_bv x) env t (Allow_untyped "pattern bv type") None false in - let x = {x with sort=t_x} in - x, guard, Env.push_bv env x - in - // TODO: remove wildcards - let rec pat_as_arg_with_env env (p:pat) : - (list bv //all pattern-bound vars including wild-cards, in proper order - & list bv //just the accessible vars, for the disjunctive pattern test - & list bv //just the wildcards - & Env.env //env extending with the pattern-bound variables - & term //the pattern as a term/typ - & guard_t //guard with all new implicits - & pat) = //the elaborated pattern itself - match p.v with - | Pat_constant c -> - let e = - match c with - | FStar.Const.Const_int(repr, Some sw) -> - FStar.ToSyntax.ToSyntax.desugar_machine_integer env.dsenv repr sw p.p - | _ -> - mk (Tm_constant c) p.p - in - ([], [], [], env, e, trivial_guard, p) - - | Pat_dot_term eopt -> - (match eopt with - | None -> - if !dbg_Patterns - then begin - if not env.phase1 - then BU.print1 "Found a non-instantiated dot pattern in phase2 (%s)\n" - (show p) - end; - let k, _ = U.type_u () in - let t, _, g = new_implicit_var_aux "pat_dot_term type" p.p env k (Allow_ghost "pat dot term type") None false in - let e, _, g' = new_implicit_var_aux "pat_dot_term" p.p env t (Allow_ghost "pat dot term") None false in - let p = {p with v=Pat_dot_term (Some e)} in - [], [], [], env, e, conj_guard g g', p - | Some e -> [], [], [], env, e, Env.trivial_guard, p) - - | Pat_var x -> - let x, g, env = intro_bv env x in - let e = mk (Tm_name x) p.p in - ([x], [x], [], env, e, g, p) - - | Pat_cons(fv, us_opt, pats) -> - let (b, a, w, env, args, guard, pats) = - pats |> - List.fold_left - (fun (b, a, w, env, args, guard, pats) (p, imp) -> - let (b', a', w', env, te, guard', pat) = pat_as_arg_with_env env p in - let arg = if imp then iarg te else as_arg te in - (b'::b, a'::a, w'::w, env, arg::args, conj_guard guard guard', (pat, imp)::pats)) - ([], [], [], env, [], trivial_guard, []) - in - let inst_head hd us_opt = - match us_opt with - | None -> hd - | Some us -> Syntax.mk_Tm_uinst hd us - in - let hd, us_opt = - let hd = Syntax.fv_to_tm fv in - if not inst_pat_cons_univs - || Some? us_opt - then inst_head hd us_opt, us_opt - else let us, _ = Env.lookup_datacon env (Syntax.lid_of_fv fv) in - if List.length us = 0 then hd, Some [] - else Syntax.mk_Tm_uinst hd us, Some us - in - let e = mk_Tm_app hd (args |> List.rev) p.p in - (List.rev b |> List.flatten, - List.rev a |> List.flatten, - List.rev w |> List.flatten, - env, - e, - guard, - {p with v=Pat_cons(fv, us_opt, List.rev pats)}) - in - let one_pat env p = - let p = elaborate_pat env p in - let b, a, w, env, arg, guard, p = pat_as_arg_with_env env p in - match b |> BU.find_dup bv_eq with - | Some x -> - let m = show x in - raise_error p.p Errors.Fatal_NonLinearPatternVars (format1 "The pattern variable \"%s\" was used more than once" m) - | _ -> b, a, w, arg, guard, p - in - let b, _, _, tm, guard, p = one_pat env p in - b, tm, guard, p diff --git a/src/typechecker/FStar.TypeChecker.PatternUtils.fsti b/src/typechecker/FStar.TypeChecker.PatternUtils.fsti deleted file mode 100644 index ff12d177b59..00000000000 --- a/src/typechecker/FStar.TypeChecker.PatternUtils.fsti +++ /dev/null @@ -1,41 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.TypeChecker.PatternUtils -open FStar.Compiler.Effect -open FStar -open FStar.Compiler -open FStar.Compiler.Util -open FStar.Errors -open FStar.TypeChecker -open FStar.Syntax -open FStar.TypeChecker.Env -open FStar.Syntax.Syntax -open FStar.Ident -open FStar.Syntax.Subst -open FStar.TypeChecker.Common - -val elaborate_pat : env -> pat -> pat -val raw_pat_as_exp (_:Env.env) (p:pat) : option (term & list bv) - -val pat_as_exp: introduce_bv_uvars:bool - -> inst_pat_cons_univs:bool (* whether it should instantiate the universes for data constructor patterns, on when called from Rel *) - -> env:Env.env - -> p:pat - -> list bv (* pattern-bound variables (which may appear in the branch of match) *) - & term (* expressions corresponding to the pattern *) - & guard_t (* guard with all implicits introduced in the pattern *) - & pat (* decorated pattern, with all the missing implicit args in p filled in *) diff --git a/src/typechecker/FStar.TypeChecker.Positivity.fst b/src/typechecker/FStar.TypeChecker.Positivity.fst deleted file mode 100644 index 1531c7c0807..00000000000 --- a/src/typechecker/FStar.TypeChecker.Positivity.fst +++ /dev/null @@ -1,1329 +0,0 @@ -(* - Copyright 2008-2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. - - Authors: A. Rastogi, N. Swamy -*) - -module FStar.TypeChecker.Positivity -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.TypeChecker.Env -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.Ident -open FStar.Errors -open FStar.List.Tot -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module BU = FStar.Compiler.Util -module U = FStar.Syntax.Util -module N = FStar.TypeChecker.Normalize -module L = FStar.Compiler.List -module C = FStar.Parser.Const - -open FStar.Class.Setlike -open FStar.Class.Show -open FStar.Class.Tagged - -let dbg_Positivity = Debug.get_toggle "Positivity" -let debug_positivity (env:env_t) (msg:unit -> string) : unit = - if !dbg_Positivity - then BU.print_string ("Positivity::" ^ msg () ^ "\n") - -(** - - This module implements the strict positivity check on inductive type - definitions - - * The idea of strict positivity is broadly described here: - http://fstar-lang.org/tutorial/book/part2/part2_inductive_type_families.html#strictly-positive-definitions - - - * tests/micro-benchmarks/Positivity.fst provides several - small examples to exercises various cases. - - A challenge is that the definition of strict positivity is not - completely settled among the various dependently typed proof - assistants. Notably, Lean, Coq, Agda, all implement slight - variations, all incomparable in permissiveness. - - What is standard is that every occurrence of the type in question - must be strictly positive, i.e., no occurrences allowed to the left - of an arrow. - - However, there is a lot of variation in how the indices and - parameters of an inductive type are handled. - - Here's a summary of what F* supports: - - 1. Non-uniformly recursive parameters - - type t a b c = - | T : t a (b & b) c -> t a b c - - - Here, a is uniformly recursive. - b is non-uniformly recursive. - Since c follows b, which is non-uniform, it is also considered non-uniform - - i.e., only a prefix of the parameters may be considered uniform - - 2. For an inductive type constructor, every non-uniform parameter or index - may be considered to be an _arity_ or not - - An arity is a `Type`, or an arrow `t -> arity` - - A term is indexed by an arity if it has type t0 -> ... -> tn -> Type - and any of the ti are themselves arities - - Given a well-typed term `t v0 ... vn`, we check that if the type of the prefix `t [v0...vi)` - is `ti -> ... Type` - and if `ti` is an arity (and is the type of `vi`) - then the type being defined cannot appear free in `vi` - - - E.g., Consider a term (t : a:Type -> x:a -> x -> (Type -> Type) -> bool -> Type) - applied as (t Type nat 0 option true) - The first index of t is an arity - (t Type : x:Type -> x -> (Type -> Type) -> bool -> Type) is arity indexed - (t Type nat : nat -> ...) is not arity indexed - (t Type nat 0 : (Type -> Type) -> ...) is arity indexed - (t Type nat 0 option : bool -> Type) is not arity indexed - (t Type nat 0 option true : Type) is not arity indexed - - 3. A type t is strictly-positive in the indexing of s, if `t` does - not appear free in any of the arity indexes of s. - - E.g., - - type s (a:Type) : bool -> Type = - | S : s a true - - type t = - | T : f:option t -> s t (Some? #t f) -> t - - The type `t` is well-formed in `s t (Some? #t f)` - since it appears only in a parameter of `s` - and in a non-arity index of s - - - However, this is forbidden: - - type f (a:Type -> Type) : Type - - type t : Type -> Type = - | T : t (f t) - - since although in `f t`, `t` only instantiates a parameter of `f` - in `t (f t)`, `t` appears free in an arity index of `t` itself - - Note, Agda does allow the type `t` above, although it rejects - - type t : Type -> Type - | T : t (t bool) - *) - -//////////////////////////////////////////////////////////////////////////////// -// Some general utilities -//////////////////////////////////////////////////////////////////////////////// - -(* A debugging utility to print a list of lids *) -let string_of_lids lids = - List.map string_of_lid lids |> String.concat ", " - -(* Normalize a term before checking for non-strictly positive occurrences *) -let normalize env t = - N.normalize [Env.Beta; - Env.HNF; - Env.Weak; - Env.Iota; - Env.Exclude Env.Zeta; - Env.UnfoldUntil delta_constant] - env - t - - -(* Given a type or data constructor d : dt - and parameters to an instance of the type - instantiate the arguments of d corresponding to the type parameters - with all_params *) -let apply_constr_arrow (dlid:lident) (dt:term) (all_params:list arg) - : term - = let rec aux t args = - match (SS.compress t).n, args with - | _, [] -> U.canon_arrow t - | Tm_arrow {bs=b::bs; comp=c}, a::args -> - let tail = - match bs with - | [] -> U.comp_result c - | _ -> S.mk (Tm_arrow {bs; comp=c}) t.pos - in - let b, tail = SS.open_term_1 b tail in - let tail = SS.subst [NT(b.binder_bv, fst a)] tail in - aux tail args - | _ -> - raise_error - (Ident.range_of_lid dlid) - Errors.Error_InductiveTypeNotSatisfyPositivityCondition - (BU.format3 "Unexpected application of type parameters %s to a data constructor %s : %s" - (Print.args_to_string all_params) - (show dlid) - (show dt)) - in - aux dt all_params - -(* Checks if ty_lid appears as an fvar in t *) -let ty_occurs_in (ty_lid:lident) - (t:term) - : bool - = mem ty_lid (Free.fvars t) - -(* Checks if `t` is a name or fv and returns it, if so. *) -let rec term_as_fv_or_name (t:term) - : option (either (fv & universes) bv) - = match (SS.compress t).n with - | Tm_name x -> - Some (Inr x) - - | Tm_fvar fv -> - Some (Inl (fv, [])) - - | Tm_uinst (t, us) -> - (match (SS.compress t).n with - | Tm_fvar fv -> Some (Inl (fv, us)) - | _ -> failwith "term_as_fv_or_name: impossible non fvar in uinst") - - | Tm_ascribed {tm=t} -> - term_as_fv_or_name t - - | _ -> None - -let open_sig_inductive_typ env se = - match se.sigel with - | Sig_inductive_typ {lid; us=ty_us; params=ty_params} -> - let ty_usubst, ty_us = SS.univ_var_opening ty_us in - let env = push_univ_vars env ty_us in - let ty_params = SS.subst_binders ty_usubst ty_params in - let ty_params = SS.open_binders ty_params in - let env = push_binders env ty_params in - env, (lid, ty_us, ty_params) - | _ -> failwith "Impossible!" - -(* Map bv to an unqualified long identifier with the same pp_name - just for positivity-checking. - - It cannot clash with any user long identifier, since those - are always qualified to a module -*) -let name_as_fv_in_t (t:term) (bv:bv) - : term & lident - = let fv_lid = set_lid_range (lid_of_str (FStar.Ident.string_of_id bv.ppname)) (range_of_bv bv) in - let fv = S.tconst fv_lid in - let t = SS.subst [NT (bv, fv)] t in - t, fv_lid - -//////////////////////////////////////////////////////////////////////////////// -// Uniformly recursive parameters -//////////////////////////////////////////////////////////////////////////////// - -(* The least value of f on the elements of l, or def if l is empty *) -let rec min_l (#a:Type) (def:int) (l:list a) (f:a -> int) = - match l with - | [] -> def - | hd::tl -> min (f hd) (min_l def tl f) - -(* For each m in mutuals, - find the greatest prefix of (p0...pi) of params such that - every occurrence of m in ty - is of the form (m p0 ... pi) - - The (p0 ... pi) are uniformly recursive in ty. - - If m does not occur in ty, then ALL the params are considered uniformly recursive - *) -let max_uniformly_recursive_parameters (env:env_t) - (mutuals:list lident) - (params:list bv) - (ty:term) - : int - = let max_matching_prefix (longer:list 'a) (shorter:list 'b) (f:'a -> 'b -> bool) - : option int - = let rec aux n ls ms = - match ls, ms with - | _, [] -> Some n - | l::ls, m::ms -> - if f l m then aux (n + 1) ls ms - else Some n - | _ -> None - in - aux 0 longer shorter - in - let ty = normalize env ty in - let n_params = L.length params in - let compare_name_bv (x:arg) (y:bv) = - match (SS.compress (fst x)).n with - | Tm_name x -> S.bv_eq x y - | _ -> false - in - let min_l (#a:Type) f l = min_l #a n_params f l in - let params_to_string () = - (List.map show params |> String.concat ", ") - in - debug_positivity env (fun _ -> - BU.format2 "max_uniformly_recursive_parameters? params=%s in %s" - (params_to_string()) - (show ty)); - let rec aux ty = - debug_positivity env (fun _ -> - BU.format1 "max_uniformly_recursive_parameters.aux? %s" - (show ty)); - if List.for_all (fun mutual -> not (ty_occurs_in mutual ty)) mutuals - then n_params - else ( - match (SS.compress ty).n with - | Tm_name _ - | Tm_fvar _ - | Tm_uinst _ - | Tm_type _ - | Tm_constant _ -> - n_params - | Tm_refine {b=x; phi=f} -> - min (aux x.sort) - (let _, f = SS.open_term [S.mk_binder x] f in - aux f) - | Tm_app _ -> - let head, args = U.head_and_args ty in - begin - match (U.un_uinst head).n with - | Tm_fvar fv -> - if L.existsML (fv_eq_lid fv) mutuals - then ( - debug_positivity env (fun _ -> - BU.format2 "Searching for max matching prefix of params=%s in args=%s" - (params_to_string()) - (Print.args_to_string args)); - match max_matching_prefix args params compare_name_bv with - | None -> 0 - | Some n -> n - ) - else min_l args (fun (arg, _) -> aux arg) - | _ -> - min (aux head) - (min_l args (fun (arg, _) -> aux arg)) - end - | Tm_abs _ -> - let bs, body, _ = U.abs_formals ty in - min (min_l bs (fun b -> aux b.binder_bv.sort)) - (aux body) - | Tm_arrow _ -> - let bs, r = U.arrow_formals ty in - min (min_l bs (fun b -> aux b.binder_bv.sort)) - (aux r) - | Tm_match {scrutinee; brs=branches} -> - min (aux scrutinee) - (min_l branches - (fun (p, _, t) -> - let bs = List.map mk_binder (pat_bvs p) in - let bs, t = SS.open_term bs t in - aux t)) - | Tm_meta {tm=t} - | Tm_ascribed {tm=t} -> - aux t - | _ -> - 0 - ) - in - let res = aux ty in - debug_positivity env (fun _ -> - BU.format3 "result: max_uniformly_recursive_parameters(params=%s in %s) = %s" - (params_to_string()) - (show ty) - (string_of_int res)); - res - -(* The sig : sigelt is a Sig_bundle describing a mutually inductive nest of types - - For every type constructor Sig_inductive_typ, find the greatest prefix of - its parameters that occur uniformly recursively in all its data - constructors. - - This populates the num_uniform_parameters field of the Sig_inductive_typ - - Note: Every parameter marked strictly_positive MUST be uniformly recursive - -*) -let mark_uniform_type_parameters (env:env_t) - (sig:sigelt) - : sigelt - = let mark_tycon_parameters tc datas = - let Sig_inductive_typ {lid=tc_lid; us; params=ty_param_binders; t; mutuals; ds=data_lids; injective_type_params } = tc.sigel in - let env, (tc_lid, us, ty_params) = open_sig_inductive_typ env tc in - let _, ty_param_args = U.args_of_binders ty_params in - let datacon_fields : list (list binder) = - List.filter_map - (fun data -> - match data.sigel with - | Sig_datacon {lid=d_lid; us=d_us; t=dt; ty_lid=tc_lid'} -> - if Ident.lid_equals tc_lid tc_lid' - then ( - let dt = SS.subst (mk_univ_subst d_us (L.map U_name us)) dt in - Some (fst (U.arrow_formals (apply_constr_arrow d_lid dt ty_param_args))) - ) - else None - | _ -> None) - datas - in - let ty_param_bvs = L.map (fun b -> b.binder_bv) ty_params in - let n_params = L.length ty_params in - let min_l #a f l = min_l #a n_params f l in - let max_uniform_prefix = - min_l datacon_fields - (fun (fields_of_one_datacon:list binder) -> - min_l fields_of_one_datacon - (fun (field:binder) -> - max_uniformly_recursive_parameters - env - mutuals - ty_param_bvs - field.binder_bv.sort)) - in - if max_uniform_prefix < n_params - then ( - let _, non_uniform_params = List.splitAt max_uniform_prefix ty_param_binders in - List.iter - (fun param -> - if param.binder_positivity = Some BinderStrictlyPositive - then ( //if marked strictly positive, it must be uniform - raise_error - (range_of_bv param.binder_bv) - Error_InductiveTypeNotSatisfyPositivityCondition - (BU.format1 "Binder %s is marked strictly positive, \ - but it is not uniformly recursive" - (show param)) - )) - non_uniform_params - ); - let sigel = Sig_inductive_typ {lid=tc_lid; - us; - params=ty_param_binders; - num_uniform_params=Some max_uniform_prefix; - t; - mutuals; - ds=data_lids; - injective_type_params} in - { tc with sigel } - in - match sig.sigel with - | Sig_bundle {ses; lids} -> - let tcs, datas = L.partition (fun se -> Sig_inductive_typ? se.sigel) ses in - let tcs = List.map (fun tc -> mark_tycon_parameters tc datas) tcs in - { sig with sigel = Sig_bundle {ses=tcs@datas; lids} } - - | _ -> sig - -//////////////////////////////////////////////////////////////////////////////// -// Arities and indexes -//////////////////////////////////////////////////////////////////////////////// - -(* Decides if t could be an arity? i.e., a Type or a t -> ... -> Type? *) -let may_be_an_arity env (t:term) - : bool - = let t = normalize env t in - let rec aux t = - match (SS.compress t).n with - | Tm_name _ - | Tm_constant _ - | Tm_abs _ - | Tm_lazy _ - | Tm_quoted _ -> false - - | Tm_fvar _ - | Tm_uinst _ - | Tm_app _ -> ( - let head, args = U.head_and_args t in - match (U.un_uinst head).n with - | Tm_fvar fv -> - (match Env.lookup_sigelt env fv.fv_name.v with - | None -> - //We couldn't find it; err conservatively ... this could be an arity - true - | Some se -> - match se.sigel with - | Sig_let _ -> - true //maybe an arity, this definition was not unfolded - | _ -> false - ) - - | _ -> true //maybe - ) - - | Tm_type _ -> true - | Tm_arrow _ -> - let _, t = U.arrow_formals t in - aux t - | Tm_refine {b=x} -> aux x.sort - | Tm_match {brs=branches} -> - List.existsML - (fun (p, _, t) -> - let bs = List.map mk_binder (pat_bvs p) in - let bs, t = SS.open_term bs t in - aux t) - branches - - | Tm_meta {tm=t} - | Tm_ascribed {tm=t} -> - aux t - - (* maybes *) - | Tm_uvar _ - | Tm_let _ -> - true - - | Tm_delayed _ - | Tm_bvar _ - | Tm_unknown -> - failwith "Impossible" - in - aux t - -(* t is an application of a type constructor T ps is - with parameters ps and indexes is. - - Check that the mutuals do not occur in any of the indexes - whose instantiated type may be arity. - - See the comment at the head of the file for some context about - indexes and arities - *) -let check_no_index_occurrences_in_arities env mutuals (t:term) = - debug_positivity env (fun _ -> - BU.format2 "check_no_index_occurrences of (mutuals %s) in arities of %s" - (string_of_lids mutuals) - (show t)); - - (* Check that none of the mutuals appear free in the index term *) - let no_occurrence_in_index fv mutuals (index:arg) = - (* The built-in predicates: - FStar.FunctionalExtensionality.on_domain - FStar.FunctionalExtensionality.on_domain_g - are special. - - Their two type arguments do not count towards positivity, - since they are there only as an artifact of describing the - type of their third argument - *) - let fext_on_domain_index_sub_term index = - let head, args = U.head_and_args index in - match (U.un_uinst head).n, args with - | Tm_fvar fv, [_td; _tr; (f, _)] -> - if S.fv_eq_lid fv C.fext_on_domain_lid - || S.fv_eq_lid fv C.fext_on_domain_g_lid - then f (* if the index is on_domain(_g) #t #s f, - return only f *) - else index - | _ -> index - in - let index, _ = index in - L.iter (fun mutual -> - if ty_occurs_in mutual (fext_on_domain_index_sub_term index) - then raise_error index Errors.Error_InductiveTypeNotSatisfyPositivityCondition - (BU.format3 "Type %s is not strictly positive since it instantiates \ - a non-uniformly recursive parameter or index %s of %s" - (string_of_lid mutual) - (show index) - (string_of_lid fv))) - mutuals - in - let no_occurrence_in_indexes fv mutuals (indexes:list arg) = - L.iter (no_occurrence_in_index fv mutuals) indexes - in - let head, args = U.head_and_args t in - match (U.un_uinst head).n with - | Tm_fvar fv -> - begin - match Env.num_inductive_uniform_ty_params env fv.fv_name.v with - | None -> - //the head is not (visibly) a inductive type; nothing to check - () - | Some n -> - if List.length args <= n - then () //they are all uniform parameters, nothing to check - else ( - match Env.try_lookup_lid env fv.fv_name.v with - | None -> no_occurrence_in_indexes fv.fv_name.v mutuals args - | Some ((_us, i_typ), _) -> - debug_positivity env (fun _ -> - BU.format2 "Checking arity indexes of %s (num uniform params = %s)" - (show t) - (string_of_int n)); - let params, indices = List.splitAt n args in - let inst_i_typ = apply_constr_arrow fv.fv_name.v i_typ params in - let formals, _sort = U.arrow_formals inst_i_typ in - let rec aux subst formals indices = - match formals, indices with - | _, [] -> () - | f::formals, i::indices -> - let f_t = SS.subst subst f.binder_bv.sort in - if may_be_an_arity env f_t - then ( - debug_positivity env (fun _ -> - BU.format2 "Checking %s : %s (arity)" - (show (fst i)) - (show f_t)); - no_occurrence_in_index fv.fv_name.v mutuals i - ) - else ( - debug_positivity env (fun _ -> - BU.format2 "Skipping %s : %s (non-arity)" - (show (fst i)) - (show f_t)) - ); - let subst = NT(f.binder_bv, fst i)::subst in - aux subst formals indices - | [], _ -> - no_occurrence_in_indexes fv.fv_name.v mutuals indices - in - aux [] formals indices - ) - end - | _ -> () - -//////////////////////////////////////////////////////////////////////////////// -// Do the mutuals not occur in t? -// Or, if they do, do they only instantiate unused parameters? -// Expects t to be normalized -//////////////////////////////////////////////////////////////////////////////// -let mutuals_unused_in_type (mutuals:list lident) t = - let mutuals_occur_in t = BU.for_some (fun lid -> ty_occurs_in lid t) mutuals in - let rec ok t = - if not (mutuals_occur_in t) then true else - // fv_lid is used in t - // but we need to check that its occurrences only occur as arguments - // to functions whose corresponding paramaters are marked as unused - match (SS.compress t).n with - | Tm_bvar _ - | Tm_name _ - | Tm_constant _ - | Tm_type _ -> - //these cases violate the precondition that fv_lid is used in t - //so we should never get here - true - | Tm_fvar _ - | Tm_uinst _ -> - //in these cases, fv_lid is used in t - false - | Tm_abs {bs; body=t} -> - binders_ok bs && ok t - | Tm_arrow {bs; comp=c} -> - binders_ok bs && ok_comp c - | Tm_refine {b=bv; phi=t} -> - ok bv.sort && ok t - | Tm_app {hd=head; args} -> - if mutuals_occur_in head - then false - else List.for_all - (fun (a, qual) -> - (match qual with - | None -> false - | Some q -> U.contains_unused_attribute q.aqual_attributes) || - ok a) - args - | Tm_match {scrutinee=t; brs=branches} -> - ok t && - List.for_all - (fun (_, _, br) -> ok br) - branches - | Tm_ascribed {tm=t; asc} -> - ok t - | Tm_let {lbs=(_, lbs); body=t} -> - List.for_all (fun lb -> ok lb.lbtyp && ok lb.lbdef) lbs - && ok t - | Tm_uvar _ -> - false - | Tm_delayed _ -> - false - | Tm_meta {tm=t} -> - ok t - | _ -> - false - and binders_ok bs = - List.for_all (fun b -> ok b.binder_bv.sort) bs - and ok_comp c = - match c.n with - | Total t -> ok t - | GTotal t -> ok t - | Comp c -> - ok c.result_typ && - List.for_all (fun (a, _) -> ok a) c.effect_args - in - ok t - -//////////////////////////////////////////////////////////////////////////////// -// Main strict positivity check -//////////////////////////////////////////////////////////////////////////////// - -(** - unfolded_memo_t: This is a key data structure in the - strict positivity check for inductive types. - - Consider, for example, checking the positivity of - - type t = - | T : list t -> t - - We look at every constructor of the instantiation `list t` - and check that it is positive, after recording in the memo-table - that `list t` is positive. - - When we reach the `tl` field of `Cons : hd:t -> tl:list t -> list t`, - we find `list t` in the memo-table and avoid infinitely recursing - on it. -*) -//A type name, the instantiation, and the number of arguments -type unfolded_memo_elt = list (lident & args & int) -type unfolded_memo_t = ref unfolded_memo_elt - - -(* Check if `ilid args` is in the memo table. - Note: the memo table only constains instantiations of ilid to its parameters - whereas args also includes the indexes. So, we take the prefix of args -*) -let already_unfolded (ilid:lident) - (args:args) - (unfolded:unfolded_memo_t) - (env:env_t) - : bool - = List.existsML - (fun (lid, l, n) -> - Ident.lid_equals lid ilid && - List.length args >= n && - (let args = fst (L.splitAt n args) in - List.fold_left2 - (fun b a a' -> b && Rel.teq_nosmt_force env (fst a) (fst a')) - true - args - l)) - !unfolded - -(** The main check for strict positivity - - A summary of its general structure: - - There are four mutually recursive functions - - 1. ty_strictly_positive_in_type _ mutuals in_type _ - - This is the main function and checks that none of the mutuals - appear in_type in a non-strictly positive position - and in arity indexes of in_type - - 2. ty_strictly_positive_in_args _ mutuals head_t args _ - - Given a head term applied to args, where head is of type - head_t, this checks that if the mutuals appear in a arg, that - it does so strictly positively and the corresponding binder - of head_t is marked strictly positive. - - The head term is not an inductive type constructor - - 3. ty_strictly_positive_in_arguments_to_fvar _ mutuals t fv _ args _ - - fv may or may not be an inductive, and is not one of the - mutuals, and this checks that all the mutuals are strictly - positive in the arguments - - if is is not an inductive, we fall back to 2 - if it is an inductive, we check each of its constructors using 4 - - 4. ty_strictly_positive_in_datacon_of_applied_inductive _ mutuals dlid ilid _ args _ _ - - This considers every field of dlid applied to the type - parameters of the inductive ilid in args, and checks that the - mutuals are strictly positive in all the field types. -*) -let rec ty_strictly_positive_in_type (env:env) - (mutuals:list lident) - (in_type:term) - (unfolded:unfolded_memo_t) - : bool - = //normalize the type to unfold any type abbreviations - let in_type = normalize env in_type in - debug_positivity env (fun _ -> - BU.format2 - "Checking strict positivity of {%s} in type, after normalization %s " - (string_of_lids mutuals) - (show in_type)); - if List.for_all (fun mutual -> not (ty_occurs_in mutual in_type)) mutuals - then true //ty does not occur in in_type, so obviously strictly positive - else ( - debug_positivity env (fun _ -> "ty does occur in this type"); - - match (SS.compress in_type).n with - | Tm_fvar _ - | Tm_uinst _ - | Tm_type _ -> - debug_positivity env (fun _ -> - "Checking strict positivity in an fvar/Tm_uinst/Tm_type, return true"); - true //Type, and fvar constants are fine - - | Tm_ascribed {tm=t} - | Tm_meta {tm=t} -> - ty_strictly_positive_in_type env mutuals t unfolded - - | Tm_app {hd=t; args} -> //the binder type is an application - let fv_or_name_opt = term_as_fv_or_name t in - begin - match fv_or_name_opt with - | None -> - debug_positivity env (fun _ -> - BU.format2 "Failed to check positivity of %s in a term with head %s" - (string_of_lids mutuals) - (show t)); - //The head is not a name or an fv - //conservatively return false - false - - | Some (Inr x) -> //head is an name - begin - let head_ty, _pos = Env.lookup_bv env x in - debug_positivity env (fun _ -> - BU.format3 "Tm_app, head bv, in_type=%s, head_bv=%s, head_ty=%s" - (show in_type) - (show x) - (show head_ty)); - - //The check depends on the strict positivity annotations on the type of the name - ty_strictly_positive_in_args env mutuals head_ty args unfolded - end - - | Some (Inl (fv, us)) -> - begin - if FStar.Compiler.List.existsML (Ident.lid_equals fv.fv_name.v) mutuals - then ( - //if the head is one of the mutually inductive types - //then check that ty_lid does not occur in the arguments - // - //E.g., we forbid `type t a = | T : t (t a) -> t a` - // and `type t a = | T : s (t a) -> t a - // and s a = | S : t a -> s a` - debug_positivity env (fun _ -> - BU.format1 - "Checking strict positivity in the Tm_app node where head lid is %s itself, \ - checking that ty does not occur in the arguments" - (Ident.string_of_lid fv.fv_name.v)); - List.for_all (fun (t, _) -> mutuals_unused_in_type mutuals t) args - ) - else ( - //check that the application is either to an inductive - //that we can show is strictly positive - //or is an fvar whose arguments are suitably decorated - //with strictly_positive attributes - debug_positivity env (fun _ -> - BU.format1 "Checking strict positivity in the Tm_app node, \ - head lid is not in %s, so checking nested positivity" - (string_of_lids mutuals)); - ty_strictly_positive_in_arguments_to_fvar - env - mutuals - in_type - fv.fv_name.v - us - args - unfolded - ) - end - end - - | Tm_arrow {comp=c} -> //in_type is an arrow - debug_positivity env (fun () -> "Checking strict positivity in Tm_arrow"); - let check_comp = - U.is_pure_or_ghost_comp c || - (c |> U.comp_effect_name - |> Env.norm_eff_name env - |> Env.lookup_effect_quals env - |> List.contains S.TotalEffect) in - if not check_comp - then ( - //t -> Dv _ - //is accepted as strictly positive in t - //since it is behind a Dv effect - debug_positivity env (fun _ -> - "Checking strict positivity , the arrow is impure, so return true"); - true - ) - else ( - debug_positivity env (fun _ -> - "Checking strict positivity for an arrow, checking \ - that ty does not occur in the binders, \ - and that it is strictly positive in the return type"); - let sbs, c = U.arrow_formals_comp in_type in - let return_type = FStar.Syntax.Util.comp_result c in - let ty_lid_not_to_left_of_arrow = - List.for_all - (fun ({binder_bv=b}) -> mutuals_unused_in_type mutuals b.sort) - sbs - in - if ty_lid_not_to_left_of_arrow - then ( - (* and is strictly positive also in the return type *) - ty_strictly_positive_in_type - (push_binders env sbs) - mutuals - return_type - unfolded - ) - else false - ) - - - | Tm_refine {b=bv; phi=f} -> - debug_positivity env (fun _ -> - "Checking strict positivity in an Tm_refine, recur in the bv sort)"); - let [b], f = SS.open_term [S.mk_binder bv] f in - if ty_strictly_positive_in_type env mutuals b.binder_bv.sort unfolded - then let env = push_binders env [b] in - ty_strictly_positive_in_type env mutuals f unfolded - else false - - | Tm_match {scrutinee; brs=branches} -> - debug_positivity env (fun _ -> - "Checking strict positivity in an Tm_match, recur in the branches)"); - if L.existsML (fun mutual -> ty_occurs_in mutual scrutinee) mutuals - then ( - // type t = | MkT : match f t with | D x -> e - // is ok if {t,x} are strictly positive in e - List.for_all - (fun (p, _, t) -> - let bs = List.map mk_binder (pat_bvs p) in - let bs, t = SS.open_term bs t in - let t, mutuals = - List.fold_left - (fun (t, lids) b -> - let t, lid = name_as_fv_in_t t b.binder_bv in - t, lid::lids) - (t, mutuals) - bs - in - ty_strictly_positive_in_type env mutuals t unfolded) - branches - ) - else ( - List.for_all - (fun (p, _, t) -> - let bs = List.map mk_binder (pat_bvs p) in - let bs, t = SS.open_term bs t in - ty_strictly_positive_in_type (push_binders env bs) mutuals t unfolded) - branches - ) - - | Tm_abs _ -> - let bs, body, _ = U.abs_formals in_type in - //strictly positive in all the binders and the result - let rec aux env bs = - match bs with - | [] -> ty_strictly_positive_in_type env mutuals body unfolded - | b::bs -> - if ty_strictly_positive_in_type env mutuals b.binder_bv.sort unfolded - then ( - let env = push_binders env [b] in - aux env bs - ) - else false - in - aux env bs - - | _ -> - debug_positivity env (fun _ -> - BU.format2 - "Checking strict positivity, unexpected tag: %s and term %s" - (tag_of in_type) - (show in_type)); - //Reject remaining cases conservatively as non positive - false) - -(* - * We are checking for positive occurrences of mutuals in a term - * (head args), and we know one of the mutuals occurs somewhere in args - * We also have env |- head : Tot t - * - * This function checks that whereever ty_lid appears in the args, - * the corresponding parameter in t is marked strictly positive - *) -and ty_strictly_positive_in_args (env:env) - (mutuals:list lident) - (head_t:typ) - (args:args) - (unfolded:unfolded_memo_t) - : bool - = let bs, _ = U.arrow_formals head_t in - let rec aux (bs:binders) args - : bool - = match bs, args with - | _, [] -> - //A partial application: we've checked all the arguments - true - - | [], _ -> - //More args than binders, e.g., because the remaining arguments - //Are beneath a computation type - //In this case, we just insist that ty_lid simply does not occur - //in the remaining arguments - List.for_all (fun (arg, _) -> mutuals_unused_in_type mutuals arg) args - - | b::bs, (arg, _)::args -> - debug_positivity env (fun _ -> - BU.format3 "Checking positivity of %s in argument %s and binder %s" - (string_of_lids mutuals) - (show arg) - (show b)); - - let this_occurrence_ok = - // either the ty_lid does not occur at all in the argument - mutuals_unused_in_type mutuals arg || - // Or the binder is marked unused - // E.g., val f ([@@@unused] a : Type) : Type - // the binder is ([@@@unused] a : Type) - U.is_binder_unused b || - // Or the binder is marked strictly positive - // and the occurrence of ty_lid in arg is also strictly positive - // E.g., val f ([@@@strictly_positive] a : Type) : Type - // the binder is ([@@@strictly_positive] a : Type) - // and - // type t = | T of f t is okay - // but type t = | T of f (t -> unit) is not okay - (U.is_binder_strictly_positive b && - ty_strictly_positive_in_type env mutuals arg unfolded) - - in - if not this_occurrence_ok - then ( - debug_positivity env (fun _ -> - BU.format3 "Failed checking positivity of %s in argument %s and binder %s" - (string_of_lids mutuals) - (show arg) - (show b)); - false - ) else ( - aux bs args - ) - in - aux bs args - - -(* We are checking that `ty_lid` is strictly positive - in (f args) and ty_lid <> f - - There are two main cases: - - 1. f is itself an inductive type, not defined mutually with ty_lid. - Look at all the constructors of `f` and check that ty_lid - is strictly positive in the types of all those constructors. - - This is to account for the case where `f` has not been decorated - with strictly_positive attributes on its parameters. - - This may involve unfolding `f` for this application, and since `f` - is inductive, we need to prevent infinite unfoldings. For this, the - unfolded:unfolded_memo_t is a memoization table which tracks which - inductives have already been unfolded, so we don't unfold them again - when they are re-encountered. - - 2. f is not an inductive type (or at least not visibly so, e.g., due - to an abstraction boundary). In this case, check that every - ty_lid is strictly_positive in all the args of f, using - check_ty_strictly_positive_in_args - -*) -and ty_strictly_positive_in_arguments_to_fvar - (env:env) - (mutuals:list lident) - (t:term) //t== fv us args - (fv:lident) - (us:universes) - (args:args) - (unfolded:unfolded_memo_t) - : bool - = debug_positivity env (fun _ -> - BU.format4 "Checking positivity of %s in application of fv %s to %s (t=%s)" - (string_of_lids mutuals) - (string_of_lid fv) - (Print.args_to_string args) - (show t)); - if Env.is_datacon env fv - then ( - // If fv is a constructor, then the mutuals must be strictly positive - // in all the arguments - List.for_all - (fun (a, _) -> ty_strictly_positive_in_type env mutuals a unfolded) - args - ) - else ( - let fv_ty = - match Env.try_lookup_lid env fv with - | Some ((_, fv_ty), _) -> fv_ty - | _ -> - raise_error fv Errors.Error_InductiveTypeNotSatisfyPositivityCondition - (BU.format1 "Type of %s not found when checking positivity" - (string_of_lid fv)) - in - let b, idatas = datacons_of_typ env fv in - if not b - then ( - (* - * Check if ilid's corresponding binder is marked "strictly_positive" - *) - ty_strictly_positive_in_args env mutuals fv_ty args unfolded - ) - //if fv has already been unfolded with same arguments, return true - else ( - check_no_index_occurrences_in_arities env mutuals t; - let ilid = fv in //fv is an inductive - //note that num_ibs gives us only the type parameters, - //and not indexes, which is what we need since we will - //substitute them in the data constructor type - let num_uniform_params = - match Env.num_inductive_uniform_ty_params env ilid with - | None -> //impossible; we know that ilid is an inductive - failwith "Unexpected type" - | Some n -> n - in - let params, _rest = List.splitAt num_uniform_params args in - if already_unfolded ilid args unfolded env - then ( - debug_positivity env (fun _ -> - "Checking nested positivity, we have already unfolded this inductive with these args"); - true - ) - else ( - debug_positivity env (fun _ -> - BU.format3 "Checking positivity in datacon, number of type parameters is %s, \ - adding %s %s to the memo table" - (string_of_int num_uniform_params) - (Ident.string_of_lid ilid) - (Print.args_to_string params)); - //update the memo table with the inductive name and the args, - //note we keep only the uniform parameters and not indices - unfolded := !unfolded @ [ilid, params, num_uniform_params]; - List.for_all - (fun d -> ty_strictly_positive_in_datacon_of_applied_inductive - env - mutuals - d - ilid - us - args - num_uniform_params - unfolded) - idatas - ) - ) - ) - -(* dlid is a data constructor of ilid - args are the arguments of the ilid application - num_ibs is the # of type parameters of ilid - us are the universes - - Check that the mutuals - occur strictly positively in every field of dlid *) -and ty_strictly_positive_in_datacon_of_applied_inductive (env:env_t) - (mutuals:list lident) - (dlid:lident) - (ilid:lident) - (us:universes) - (args:args) - (num_ibs:int) - (unfolded:unfolded_memo_t) - : bool - = debug_positivity env (fun _ -> - BU.format3 - "Checking positivity of %s in data constructor %s : %s" - (string_of_lids mutuals) - (string_of_lid dlid) - (string_of_lid ilid)); - let dt = - match Env.try_lookup_and_inst_lid env us dlid with - | Some (t, _) -> t - | None -> - raise_error - (range_of_lid dlid) - Errors.Error_InductiveTypeNotSatisfyPositivityCondition - (BU.format1 "Data constructor %s not found when checking positivity" - (string_of_lid dlid)) - in - - debug_positivity env (fun _ -> - BU.format3 - "Checking positivity in the data constructor type: %s\n\t\ - num_ibs=%s, args=%s," - (show dt) - (string_of_int num_ibs) - (Print.args_to_string args)); - - //get the number of arguments that cover the type parameters num_ibs, - //the rest are indexes and these should not mention the mutuals at all - let args, rest = List.splitAt num_ibs args in - let applied_dt = apply_constr_arrow dlid dt args in - debug_positivity env (fun _ -> - BU.format3 - "Applied data constructor type: %s %s : %s" - (string_of_lid dlid) - (Print.args_to_string args) - (show applied_dt)); - let fields, t = U.arrow_formals applied_dt in - check_no_index_occurrences_in_arities env mutuals t; - let rec strictly_positive_in_all_fields env fields = - match fields with - | [] -> true - | f::fields -> - debug_positivity env (fun _ -> - BU.format2 "Checking field %s : %s for indexes and positivity" - (show f.binder_bv) - (show f.binder_bv.sort)); - check_no_index_occurrences_in_arities env mutuals f.binder_bv.sort; - if ty_strictly_positive_in_type env mutuals f.binder_bv.sort unfolded - then let env = push_binders env [f] in - strictly_positive_in_all_fields env fields - else false - in - strictly_positive_in_all_fields env fields - -//////////////////////////////////////////////////////////////////////////////// -// External API for strict positivity checking -//////////////////////////////////////////////////////////////////////////////// - - -(* - Check that the name bv (a binder annotated with a strictly_positive - attribute) is strictly positive in t -*) -let name_strictly_positive_in_type env (bv:bv) t = - let t, fv_lid = name_as_fv_in_t t bv in - ty_strictly_positive_in_type env [fv_lid] t (BU.mk_ref []) - - -(* - Check that the name bv (a binder annotated with a strictly_positive - attribute) is strictly positive in t -*) -let name_unused_in_type env (bv:bv) t = - let t, fv_lid = name_as_fv_in_t t bv in - not (ty_occurs_in fv_lid t) || - mutuals_unused_in_type [fv_lid] (normalize env t) - -(* Check that the mutuals are - strictly positive in every field of the data constructor dlid - AND - that any parameters of the type annotated with a strictly positive - attribute are also strictly positive in the fields of the constructor - - The env must already contain all the ty_bs - *) -let ty_strictly_positive_in_datacon_decl (env:env_t) - (mutuals:list lident) - (dlid:lident) - (ty_bs:binders) - (us:universes) - (unfolded:unfolded_memo_t) - : bool - = let dt = - match Env.try_lookup_and_inst_lid env us dlid with - | Some (t, _) -> t - | None -> raise_error dlid - Errors.Error_InductiveTypeNotSatisfyPositivityCondition - (BU.format1 "Error looking up data constructor %s when checking positivity" - (string_of_lid dlid)) - in - debug_positivity env (fun () -> "Checking data constructor type: " ^ (show dt)); - let ty_bs, args = U.args_of_binders ty_bs in - let dt = apply_constr_arrow dlid dt args in - let fields, return_type = U.arrow_formals dt in - check_no_index_occurrences_in_arities env mutuals return_type; - let check_annotated_binders_are_strictly_positive_in_field f = - let incorrectly_annotated_binder = - L.tryFind - (fun b -> - (U.is_binder_unused b - && not (name_unused_in_type env b.binder_bv f.binder_bv.sort)) || - (U.is_binder_strictly_positive b - && not (name_strictly_positive_in_type env b.binder_bv f.binder_bv.sort))) - ty_bs - in - match incorrectly_annotated_binder with - | None -> () - | Some b -> - raise_error b Error_InductiveTypeNotSatisfyPositivityCondition - (BU.format2 "Binder %s is marked %s, \ - but its use in the definition is not" - (show b) - (if U.is_binder_strictly_positive b - then "strictly_positive" - else "unused")) - in - let rec check_all_fields env fields = - match fields with - | [] -> true - | field::fields -> - check_annotated_binders_are_strictly_positive_in_field field; - if not (ty_strictly_positive_in_type env mutuals field.binder_bv.sort unfolded) - then false - else ( - let env = push_binders env [field] in - check_all_fields env fields - ) - in - check_all_fields env fields - - -(* An entry point from the interface: - Check that the inductive type ty, defined mutually with mutuals - is strictly positive *) -let check_strict_positivity (env:env_t) - (mutuals:list lident) - (ty:sigelt) - : bool - = //memo table, memoizes the instances of inductives - //that we have recursively already deemed as strictly positive - let unfolded_inductives = BU.mk_ref [] in - - //ty_params are the parameters of ty, it does not include the indexes - let env, (ty_lid, ty_us, ty_params) = open_sig_inductive_typ env ty in - let mutuals = List.filter (fun m -> not (Env.is_datacon env m)) mutuals in - let mutuals = - //make sure that ty_lid itself is part of the mutuals - if List.existsML (Ident.lid_equals ty_lid) mutuals - then mutuals - else ty_lid::mutuals in - let datacons = snd (datacons_of_typ env ty_lid) in - let us = List.map U_name ty_us in - List.for_all - (fun d -> - ty_strictly_positive_in_datacon_decl - env - mutuals - d - ty_params - us - unfolded_inductives) - datacons - -(* Special-casing the check for exceptions, the single open inductive type we handle. *) -let check_exn_strict_positivity (env:env_t) - (data_ctor_lid:lid) - : bool - = let unfolded_inductives = BU.mk_ref [] in - ty_strictly_positive_in_datacon_decl env [C.exn_lid] data_ctor_lid [] [] unfolded_inductives - - diff --git a/src/typechecker/FStar.TypeChecker.Positivity.fsti b/src/typechecker/FStar.TypeChecker.Positivity.fsti deleted file mode 100644 index 637074b0a3f..00000000000 --- a/src/typechecker/FStar.TypeChecker.Positivity.fsti +++ /dev/null @@ -1,29 +0,0 @@ -(* - Copyright 2008-2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. - - Authors: A. Rastogi, N. Swamy -*) - -module FStar.TypeChecker.Positivity -open FStar.Compiler.Effect -open FStar.TypeChecker.Env -open FStar.Syntax.Syntax -open FStar.Ident - -val check_strict_positivity: env -> list lident -> sigelt -> bool -val name_strictly_positive_in_type: env -> bv -> term -> bool -val name_unused_in_type: env -> bv -> term -> bool -val check_exn_strict_positivity: env -> lident -> bool -val mark_uniform_type_parameters: env -> sigelt -> sigelt \ No newline at end of file diff --git a/src/typechecker/FStar.TypeChecker.Primops.Array.fst b/src/typechecker/FStar.TypeChecker.Primops.Array.fst deleted file mode 100644 index 6d23d3314a3..00000000000 --- a/src/typechecker/FStar.TypeChecker.Primops.Array.fst +++ /dev/null @@ -1,183 +0,0 @@ -module FStar.TypeChecker.Primops.Array - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Errors -open FStar.Class.Monad -open FStar.Syntax.Syntax -open FStar.Syntax.Embeddings - -open FStar.TypeChecker.Primops.Base - -module BU = FStar.Compiler.Util -module EMB = FStar.Syntax.Embeddings -module NBETerm = FStar.TypeChecker.NBETerm -module PC = FStar.Parser.Const -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module U = FStar.Syntax.Util -module Z = FStar.BigInt - -let as_primitive_step is_strong (l, arity, u_arity, f, f_nbe) = - FStar.TypeChecker.Primops.Base.as_primitive_step_nbecbs is_strong (l, arity, u_arity, f, (fun cb univs args -> f_nbe univs args)) - -let arg_as_int (a:arg) : option Z.t = fst a |> try_unembed_simple - -let arg_as_list {|e:EMB.embedding 'a|} (a:arg) -: option (list 'a) - = fst a |> try_unembed_simple - -let mixed_binary_op - (as_a : arg -> option 'a) - (as_b : arg -> option 'b) - (embed_c : Range.range -> 'c -> term) - (f : Range.range -> universes -> 'a -> 'b -> option 'c) - (psc : psc) - (norm_cb : EMB.norm_cb) - (univs : universes) - (args : args) - : option term - = match args with - | [a;b] -> - begin - match as_a a, as_b b with - | Some a, Some b -> - (match f psc.psc_range univs a b with - | Some c -> Some (embed_c psc.psc_range c) - | _ -> None) - | _ -> None - end - | _ -> None - -let mixed_ternary_op - (as_a : arg -> option 'a) - (as_b : arg -> option 'b) - (as_c : arg -> option 'c) - (embed_d : Range.range -> 'd -> term) - (f : Range.range -> universes -> 'a -> 'b -> 'c -> option 'd) - (psc : psc) - (norm_cb : EMB.norm_cb) - (univs : universes) - (args : args) - : option term - = match args with - | [a;b;c] -> - begin - match as_a a, as_b b, as_c c with - | Some a, Some b, Some c -> - (match f psc.psc_range univs a b c with - | Some d -> Some (embed_d psc.psc_range d) - | _ -> None) - | _ -> None - end - | _ -> None - - -let bogus_cbs = { - NBETerm.iapp = (fun h _args -> h); - NBETerm.translate = (fun _ -> failwith "bogus_cbs translate"); -} - -let ops : list primitive_step = - let of_list_op = - let emb_typ t = ET_app(PC.immutable_array_t_lid |> Ident.string_of_lid, [t]) in - let un_lazy universes t l r = - S.mk_Tm_app - (S.mk_Tm_uinst (U.fvar_const PC.immutable_array_of_list_lid) universes) - [S.iarg t; S.as_arg l] - r - in - ( PC.immutable_array_of_list_lid, 2, 1, - mixed_binary_op - (fun (elt_t, _) -> Some elt_t) //the first arg of of_list is the element type - (fun (l, q) -> //2nd arg: try_unembed_simple as a list term - match arg_as_list #_ #FStar.Syntax.Embeddings.e_any (l, q) with - | Some lst -> Some (l, lst) - | _ -> None) - (fun r (universes, elt_t, (l, blob)) -> - //embed the result back as a Tm_lazy with the `ImmutableArray.t term` as the blob - //The kind records the type of the blob as IA.t "any" - //and the interesting thing here is that the thunk represents the blob back as pure F* term - //IA.of_list u#universes elt_t l. - //This unreduced representation can be used in a context where the blob doesn't make sense, - //e.g., in the SMT encoding, we represent the blob computed by of_list l - //just as the unreduced term `of_list l` - S.mk (Tm_lazy { blob; - lkind=Lazy_embedding (emb_typ EMB.(emb_typ_of _ #e_any ()), Thunk.mk (fun _ -> un_lazy universes elt_t l r)); - ltyp=S.mk_Tm_app (S.mk_Tm_uinst (U.fvar_const PC.immutable_array_t_lid) universes) [S.as_arg elt_t] r; - rng=r }) r) - (fun r universes elt_t (l, lst) -> - //The actual primitive step computing the IA.t blob - let blob = FStar.ImmutableArray.Base.of_list #term lst in - Some (universes, elt_t, (l, FStar.Dyn.mkdyn blob))), - NBETerm.mixed_binary_op - (fun (elt_t, _) -> Some elt_t) - (fun (l, q) -> - match NBETerm.arg_as_list NBETerm.e_any (l, q) with - | None -> None - | Some lst -> Some (l, lst)) - (fun (universes, elt_t, (l, blob)) -> - //The embedding is similar to the non-NBE case - //But, this time the thunk is the NBE.t representation of `of_list l` - NBETerm.mk_t <| - NBETerm.Lazy (Inr (blob, emb_typ EMB.(emb_typ_of _ #e_any ())), - Thunk.mk (fun _ -> - NBETerm.mk_t <| NBETerm.FV (S.lid_as_fv PC.immutable_array_of_list_lid None, - universes, - [NBETerm.as_arg l])))) - (fun universes elt_t (l, lst) -> - let blob = FStar.ImmutableArray.Base.of_list #NBETerm.t lst in - Some (universes, elt_t, (l, FStar.Dyn.mkdyn blob)))) - in - let arg1_as_elt_t (x:arg) : option term = Some (fst x) in - let arg2_as_blob (x:arg) : option FStar.Dyn.dyn = - //try_unembed_simple an arg as a IA.t blob if the emb_typ - //of the lkind tells us it has the right type - match (SS.compress (fst x)).n with - | Tm_lazy {blob=blob; lkind=Lazy_embedding (ET_app(head, _), _)} - when head=Ident.string_of_lid PC.immutable_array_t_lid -> Some blob - | _ -> None - in - let arg2_as_blob_nbe (x:NBETerm.arg) : option FStar.Dyn.dyn = - //try_unembed_simple an arg as a IA.t blob if the emb_typ - //tells us it has the right type - let open FStar.TypeChecker.NBETerm in - match (fst x).nbe_t with - | Lazy (Inr (blob, ET_app(head, _)), _) - when head=Ident.string_of_lid PC.immutable_array_t_lid -> Some blob - | _ -> None - in - let length_op = - let embed_int (r:Range.range) (i:Z.t) : term = embed_simple r i in - let run_op (blob:FStar.Dyn.dyn) : option Z.t = - Some (BU.array_length #term (FStar.Dyn.undyn blob)) - in - ( PC.immutable_array_length_lid, 2, 1, - mixed_binary_op arg1_as_elt_t //1st arg of length is the type - arg2_as_blob //2nd arg is the IA.t term blob - embed_int //the result is just an int, so embed it back - (fun _r _universes _ blob -> run_op blob), - //NBE case is similar - NBETerm.mixed_binary_op - (fun (elt_t, _) -> Some elt_t) - arg2_as_blob_nbe - (fun (i:Z.t) -> NBETerm.embed NBETerm.e_int bogus_cbs i) - (fun _universes _ blob -> run_op blob) ) - in - let index_op = - (PC.immutable_array_index_lid, 3, 1, - mixed_ternary_op arg1_as_elt_t //1st arg of index is the type - arg2_as_blob //2nd arg is the `IA.t term` blob - arg_as_int //3rd arg is an int - (fun r tm -> tm) //the result is just a term, so the embedding is the identity - (fun r _universes _t blob i -> Some (BU.array_index #term (FStar.Dyn.undyn blob) i)), - NBETerm.mixed_ternary_op - (fun (elt_t, _) -> Some elt_t) - arg2_as_blob_nbe //2nd arg is an `IA.t NBEterm.t` blob - NBETerm.arg_as_int - (fun tm -> tm) //In this case, the result is a NBE.t, so embedding is the identity - (fun _universes _t blob i -> Some (BU.array_index #NBETerm.t (FStar.Dyn.undyn blob) i))) - in - List.map (as_primitive_step true) - [of_list_op; length_op; index_op] diff --git a/src/typechecker/FStar.TypeChecker.Primops.Array.fsti b/src/typechecker/FStar.TypeChecker.Primops.Array.fsti deleted file mode 100644 index 9026f882e67..00000000000 --- a/src/typechecker/FStar.TypeChecker.Primops.Array.fsti +++ /dev/null @@ -1,5 +0,0 @@ -module FStar.TypeChecker.Primops.Array - -open FStar.TypeChecker.Primops.Base - -val ops : list primitive_step diff --git a/src/typechecker/FStar.TypeChecker.Primops.Base.fst b/src/typechecker/FStar.TypeChecker.Primops.Base.fst deleted file mode 100644 index 14efd9337f2..00000000000 --- a/src/typechecker/FStar.TypeChecker.Primops.Base.fst +++ /dev/null @@ -1,459 +0,0 @@ -module FStar.TypeChecker.Primops.Base - -(* This module defines the type of primitive steps and some helpers. *) - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Syntax.Syntax -open FStar.Class.Monad - -module EMB = FStar.Syntax.Embeddings -module NBE = FStar.TypeChecker.NBETerm - -let null_psc = { psc_range = Range.dummyRange ; psc_subst = fun () -> [] } -let psc_range psc = psc.psc_range -let psc_subst psc = psc.psc_subst () - -let embed_simple {| EMB.embedding 'a |} (r:Range.range) (x:'a) : term = - EMB.embed x r None EMB.id_norm_cb - -let try_unembed_simple {| EMB.embedding 'a |} (x:term) : option 'a = - EMB.try_unembed x EMB.id_norm_cb - -let solve (#a:Type) {| ev : a |} : Tot a = ev - -let as_primitive_step_nbecbs is_strong (l, arity, u_arity, f, f_nbe) : primitive_step = { - name = l; - arity = arity; - univ_arity = u_arity; - auto_reflect = None; - strong_reduction_ok = is_strong; - requires_binder_substitution = false; - renorm_after = false; - interpretation = f; - interpretation_nbe = f_nbe; -} - -let mk_interp1 #a #r - {| EMB.embedding a |} - {| EMB.embedding r |} - (f : a -> r) - : interp_t = - fun psc cb us args -> - match args with - | [(a, _)] -> - let! a = try_unembed_simple a in - return (embed_simple psc.psc_range (f a)) - | _ -> failwith "arity" - -let mk_nbe_interp1 #a #r - {| NBE.embedding a |} - {| NBE.embedding r |} - (f : a -> r) - : nbe_interp_t = - fun cbs us args -> - match args with - | [(a, _)] -> - let! r = f <$> NBE.unembed solve cbs a in - return (NBE.embed solve cbs r) - | _ -> - None - -let mk_interp2 #a #b #r - {| EMB.embedding a |} - {| EMB.embedding b |} - {| EMB.embedding r |} - (f : a -> b -> r) - : interp_t = - fun psc cb us args -> - match args with - | [(a, _); (b, _)] -> - let! r = f <$> try_unembed_simple a <*> try_unembed_simple b in - return (embed_simple psc.psc_range r) - | _ -> failwith "arity" - -let mk_nbe_interp2 #a #b #r - {| NBE.embedding a |} - {| NBE.embedding b |} - {| NBE.embedding r |} - (f : a -> b -> r) - : nbe_interp_t = - fun cbs us args -> - match args with - | [(a, _); (b, _)] -> - let! r = f <$> NBE.unembed solve cbs a <*> NBE.unembed solve cbs b in - return (NBE.embed solve cbs r) - | _ -> - None - -let mk_interp3 #a #b #c #r - {| EMB.embedding a |} - {| EMB.embedding b |} - {| EMB.embedding c |} - {| EMB.embedding r |} - (f : a -> b -> c -> r) - : interp_t = - fun psc cb us args -> - match args with - | [(a, _); (b, _); (c, _)] -> - let! r = f <$> try_unembed_simple a <*> try_unembed_simple b <*> try_unembed_simple c in - return (embed_simple psc.psc_range r) - | _ -> failwith "arity" - -let mk_nbe_interp3 #a #b #c #r - {| NBE.embedding a |} - {| NBE.embedding b |} - {| NBE.embedding c |} - {| NBE.embedding r |} - (f : a -> b -> c -> r) - : nbe_interp_t = - fun cbs us args -> - match args with - | [(a, _); (b, _); (c, _)] -> - let! r = f <$> NBE.unembed solve cbs a <*> NBE.unembed solve cbs b <*> NBE.unembed solve cbs c in - return (NBE.embed solve cbs r) - | _ -> - None - -let mk_interp4 #a #b #c #d #r - {| EMB.embedding a |} - {| EMB.embedding b |} - {| EMB.embedding c |} - {| EMB.embedding d |} - {| EMB.embedding r |} - (f : a -> b -> c -> d -> r) - : interp_t = - fun psc cb us args -> - match args with - | [(a, _); (b, _); (c, _); (d, _)] -> - let! r = f <$> try_unembed_simple a <*> try_unembed_simple b <*> try_unembed_simple c <*> try_unembed_simple d in - return (embed_simple psc.psc_range r) - | _ -> failwith "arity" - -let mk_nbe_interp4 #a #b #c #d #r - {| NBE.embedding a |} - {| NBE.embedding b |} - {| NBE.embedding c |} - {| NBE.embedding d |} - {| NBE.embedding r |} - (f : a -> b -> c -> d -> r) - : nbe_interp_t = - fun cbs us args -> - match args with - | [(a, _); (b, _); (c, _); (d, _)] -> - let! r = f <$> NBE.unembed solve cbs a <*> NBE.unembed solve cbs b <*> NBE.unembed solve cbs c <*> NBE.unembed solve cbs d in - return (NBE.embed solve cbs r) - | _ -> - None - -let mk_interp5 #a #b #c #d #e #r - {| EMB.embedding a |} - {| EMB.embedding b |} - {| EMB.embedding c |} - {| EMB.embedding d |} - {| EMB.embedding e |} - {| EMB.embedding r |} - (f : a -> b -> c -> d -> e -> r) - : interp_t = - fun psc cb us args -> - match args with - | [(a, _); (b, _); (c, _); (d, _); (e, _)] -> - let! r = f <$> try_unembed_simple a <*> try_unembed_simple b <*> try_unembed_simple c <*> try_unembed_simple d <*> try_unembed_simple e in - return (embed_simple psc.psc_range r) - | _ -> failwith "arity" - -let mk_nbe_interp5 #a #b #c #d #e #r - {| NBE.embedding a |} - {| NBE.embedding b |} - {| NBE.embedding c |} - {| NBE.embedding d |} - {| NBE.embedding e |} - {| NBE.embedding r |} - (f : a -> b -> c -> d -> e -> r) - : nbe_interp_t = - fun cbs us args -> - match args with - | [(a, _); (b, _); (c, _); (d, _); (e, _)] -> - let! r = f <$> NBE.unembed solve cbs a <*> NBE.unembed solve cbs b <*> NBE.unembed solve cbs c <*> NBE.unembed solve cbs d <*> NBE.unembed solve cbs e in - return (NBE.embed solve cbs r) - | _ -> - None - -let mk1 #a #r - (u_arity : int) - (name : Ident.lid) - {| EMB.embedding a |} {| NBE.embedding a |} - {| EMB.embedding r |} {| NBE.embedding r |} - (f : a -> r) - : primitive_step = - let interp : interp_t = mk_interp1 f in - let nbe_interp : nbe_interp_t = mk_nbe_interp1 f in - as_primitive_step_nbecbs true (name, 1, u_arity, interp, nbe_interp) - -let mk2 #a #b #r - (u_arity : int) - (name : Ident.lid) - {| EMB.embedding a |} {| NBE.embedding a |} - {| EMB.embedding b |} {| NBE.embedding b |} - {| EMB.embedding r |} {| NBE.embedding r |} - (f : a -> b -> r) - : primitive_step = - let interp : interp_t = mk_interp2 f in - let nbe_interp : nbe_interp_t = mk_nbe_interp2 f in - as_primitive_step_nbecbs true (name, 2, u_arity, interp, nbe_interp) - -let mk3 #a #b #c #r - (u_arity : int) - (name : Ident.lid) - {| EMB.embedding a |} {| NBE.embedding a |} - {| EMB.embedding b |} {| NBE.embedding b |} - {| EMB.embedding c |} {| NBE.embedding c |} - {| EMB.embedding r |} {| NBE.embedding r |} - (f : a -> b -> c -> r) - : primitive_step = - let interp : interp_t = mk_interp3 f in - let nbe_interp : nbe_interp_t = mk_nbe_interp3 f in - as_primitive_step_nbecbs true (name, 3, u_arity, interp, nbe_interp) - -let mk4 #a #b #c #d #r - (u_arity : int) - (name : Ident.lid) - {| EMB.embedding a |} {| NBE.embedding a |} - {| EMB.embedding b |} {| NBE.embedding b |} - {| EMB.embedding c |} {| NBE.embedding c |} - {| EMB.embedding d |} {| NBE.embedding d |} - {| EMB.embedding r |} {| NBE.embedding r |} - (f : a -> b -> c -> d -> r) - : primitive_step = - let interp : interp_t = mk_interp4 f in - let nbe_interp : nbe_interp_t = mk_nbe_interp4 f in - as_primitive_step_nbecbs true (name, 4, u_arity, interp, nbe_interp) - -let mk5 #a #b #c #d #e #r - (u_arity : int) - (name : Ident.lid) - {| EMB.embedding a |} {| NBE.embedding a |} - {| EMB.embedding b |} {| NBE.embedding b |} - {| EMB.embedding c |} {| NBE.embedding c |} - {| EMB.embedding d |} {| NBE.embedding d |} - {| EMB.embedding e |} {| NBE.embedding e |} - {| EMB.embedding r |} {| NBE.embedding r |} - (f : a -> b -> c -> d -> e -> r) - : primitive_step = - let interp : interp_t = mk_interp5 f in - let nbe_interp : nbe_interp_t = mk_nbe_interp5 f in - as_primitive_step_nbecbs true (name, 5, u_arity, interp, nbe_interp) - -let mk1' #a #r #na #nr - (u_arity : int) - (name : Ident.lid) - {| EMB.embedding a |} {| NBE.embedding na |} - {| EMB.embedding r |} {| NBE.embedding nr |} - (f : a -> option r) - (nbe_f : na -> option nr) - : primitive_step = - let interp : interp_t = - fun psc cb us args -> - match args with - | [(a, _)] -> - let! r = f <$> try_unembed_simple a in - let! r = r in - return (embed_simple psc.psc_range r) - | _ -> failwith "arity" - in - let nbe_interp : nbe_interp_t = - fun cbs us args -> - match args with - | [(a, _)] -> - let! r = nbe_f <$> NBE.unembed solve cbs a in - let! r = r in - return (NBE.embed solve cbs r) - | _ -> failwith "arity" - in - as_primitive_step_nbecbs true (name, 1, u_arity, interp, nbe_interp) - -let mk1_psc' #a #r #na #nr - (u_arity : int) - (name : Ident.lid) - {| EMB.embedding a |} {| NBE.embedding na |} - {| EMB.embedding r |} {| NBE.embedding nr |} - (f : psc -> a -> option r) - (nbe_f : psc -> na -> option nr) - : primitive_step = - let interp : interp_t = - fun psc cb us args -> - match args with - | [(a, _)] -> - let! r = f psc <$> try_unembed_simple a in - let! r = r in - return (embed_simple psc.psc_range r) - | _ -> failwith "arity" - in - let nbe_interp : nbe_interp_t = - fun cbs us args -> - match args with - | [(a, _)] -> - let! r = nbe_f null_psc <$> NBE.unembed solve cbs a in - let! r = r in - return (NBE.embed solve cbs r) - | _ -> failwith "arity" - in - as_primitive_step_nbecbs true (name, 1, u_arity, interp, nbe_interp) - - -let mk2' #a #b #r #na #nb #nr - (u_arity : int) - (name : Ident.lid) - {| EMB.embedding a |} {| NBE.embedding na |} - {| EMB.embedding b |} {| NBE.embedding nb |} - {| EMB.embedding r |} {| NBE.embedding nr |} - (f : a -> b -> option r) - (nbe_f : na -> nb -> option nr) - : primitive_step = - let interp : interp_t = - fun psc cb us args -> - match args with - | [(a, _); (b, _)] -> - let! r = f <$> try_unembed_simple a <*> try_unembed_simple b in - let! r = r in - return (embed_simple psc.psc_range r) - | _ -> failwith "arity" - in - let nbe_interp : nbe_interp_t = - fun cbs us args -> - match args with - | [(a, _); (b, _)] -> - let! r = nbe_f <$> NBE.unembed solve cbs a <*> NBE.unembed solve cbs b in - let! r = r in - return (NBE.embed solve cbs r) - | _ -> failwith "arity" - in - as_primitive_step_nbecbs true (name, 2, u_arity, interp, nbe_interp) - -let mk3' #a #b #c #r #na #nb #nc #nr - (u_arity : int) - (name : Ident.lid) - {| EMB.embedding a |} {| NBE.embedding na |} - {| EMB.embedding b |} {| NBE.embedding nb |} - {| EMB.embedding c |} {| NBE.embedding nc |} - {| EMB.embedding r |} {| NBE.embedding nr |} - (f : a -> b -> c -> option r) - (nbe_f : na -> nb -> nc -> option nr) - : primitive_step = - let interp : interp_t = - fun psc cb us args -> - match args with - | [(a, _); (b, _); (c, _)] -> - let! r = f <$> try_unembed_simple a <*> try_unembed_simple b <*> try_unembed_simple c in - let! r = r in - return (embed_simple psc.psc_range r) - | _ -> failwith "arity" - in - let nbe_interp : nbe_interp_t = - fun cbs us args -> - match args with - | [(a, _); (b, _); (c, _)] -> - let! r = nbe_f <$> NBE.unembed solve cbs a <*> NBE.unembed solve cbs b <*> NBE.unembed solve cbs c in - let! r = r in - return (NBE.embed solve cbs r) - | _ -> failwith "arity" - in - as_primitive_step_nbecbs true (name, 3, u_arity, interp, nbe_interp) - -let mk4' #a #b #c #d #r #na #nb #nc #nd #nr - (u_arity : int) - (name : Ident.lid) - {| EMB.embedding a |} {| NBE.embedding na |} - {| EMB.embedding b |} {| NBE.embedding nb |} - {| EMB.embedding c |} {| NBE.embedding nc |} - {| EMB.embedding d |} {| NBE.embedding nd |} - {| EMB.embedding r |} {| NBE.embedding nr |} - (f : a -> b -> c -> d -> option r) - (nbe_f : na -> nb -> nc -> nd -> option nr) - : primitive_step = - let interp : interp_t = - fun psc cb us args -> - match args with - | [(a, _); (b, _); (c, _); (d, _)] -> - let! r = f <$> try_unembed_simple a <*> try_unembed_simple b <*> try_unembed_simple c <*> try_unembed_simple d in - let! r = r in - return (embed_simple psc.psc_range r) - | _ -> failwith "arity" - in - let nbe_interp : nbe_interp_t = - fun cbs us args -> - match args with - | [(a, _); (b, _); (c, _); (d, _)] -> - let! r = nbe_f <$> NBE.unembed solve cbs a <*> NBE.unembed solve cbs b <*> NBE.unembed solve cbs c <*> NBE.unembed solve cbs d in - let! r = r in - return (NBE.embed solve cbs r) - | _ -> failwith "arity" - in - as_primitive_step_nbecbs true (name, 4, u_arity, interp, nbe_interp) - -let mk5' #a #b #c #d #e #r #na #nb #nc #nd #ne #nr - (u_arity : int) - (name : Ident.lid) - {| EMB.embedding a |} {| NBE.embedding na |} - {| EMB.embedding b |} {| NBE.embedding nb |} - {| EMB.embedding c |} {| NBE.embedding nc |} - {| EMB.embedding d |} {| NBE.embedding nd |} - {| EMB.embedding e |} {| NBE.embedding ne |} - {| EMB.embedding r |} {| NBE.embedding nr |} - (f : a -> b -> c -> d -> e -> option r) - (nbe_f : na -> nb -> nc -> nd -> ne -> option nr) - : primitive_step = - let interp : interp_t = - fun psc cb us args -> - match args with - | [(a, _); (b, _); (c, _); (d, _); (e, _)] -> - let! r = f <$> try_unembed_simple a <*> try_unembed_simple b <*> try_unembed_simple c <*> try_unembed_simple d <*> try_unembed_simple e in - let! r = r in - return (embed_simple psc.psc_range r) - | _ -> failwith "arity" - in - let nbe_interp : nbe_interp_t = - fun cbs us args -> - match args with - | [(a, _); (b, _); (c, _); (d, _); (e, _)] -> - let! r = nbe_f <$> NBE.unembed solve cbs a <*> NBE.unembed solve cbs b <*> NBE.unembed solve cbs c <*> NBE.unembed solve cbs d <*> NBE.unembed solve cbs e in - let! r = r in - return (NBE.embed solve cbs r) - | _ -> failwith "arity" - in - as_primitive_step_nbecbs true (name, 5, u_arity, interp, nbe_interp) - -let mk6' #a #b #c #d #e #f #r #na #nb #nc #nd #ne #nf #nr - (u_arity : int) - (name : Ident.lid) - {| EMB.embedding a |} {| NBE.embedding na |} - {| EMB.embedding b |} {| NBE.embedding nb |} - {| EMB.embedding c |} {| NBE.embedding nc |} - {| EMB.embedding d |} {| NBE.embedding nd |} - {| EMB.embedding e |} {| NBE.embedding ne |} - {| EMB.embedding f |} {| NBE.embedding nf |} - {| EMB.embedding r |} {| NBE.embedding nr |} - (ff : a -> b -> c -> d -> e -> f -> option r) - (nbe_ff : na -> nb -> nc -> nd -> ne -> nf -> option nr) - : primitive_step = - let interp : interp_t = - fun psc cb us args -> - match args with - | [(a, _); (b, _); (c, _); (d, _); (e, _); (f, _)] -> - let! r = ff <$> try_unembed_simple a <*> try_unembed_simple b <*> try_unembed_simple c <*> try_unembed_simple d <*> try_unembed_simple e <*> try_unembed_simple f in - let! r = r in - return (embed_simple psc.psc_range r) - | _ -> failwith "arity" - in - let nbe_interp : nbe_interp_t = - fun cbs us args -> - match args with - | [(a, _); (b, _); (c, _); (d, _); (e, _); (f, _)] -> - let! r = nbe_ff <$> NBE.unembed solve cbs a <*> NBE.unembed solve cbs b <*> NBE.unembed solve cbs c <*> NBE.unembed solve cbs d <*> NBE.unembed solve cbs e <*> NBE.unembed solve cbs f in - let! r = r in - return (NBE.embed solve cbs r) - | _ -> failwith "arity" - in - as_primitive_step_nbecbs true (name, 6, u_arity, interp, nbe_interp) diff --git a/src/typechecker/FStar.TypeChecker.Primops.Base.fsti b/src/typechecker/FStar.TypeChecker.Primops.Base.fsti deleted file mode 100644 index edac4fb7e8d..00000000000 --- a/src/typechecker/FStar.TypeChecker.Primops.Base.fsti +++ /dev/null @@ -1,238 +0,0 @@ -module FStar.TypeChecker.Primops.Base -(* This module defines the type of primitive steps and some helpers. *) - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Syntax.Syntax -module Env = FStar.TypeChecker.Env -module EMB = FStar.Syntax.Embeddings -module NBE = FStar.TypeChecker.NBETerm - -type psc = { - psc_range : FStar.Compiler.Range.range; - psc_subst : unit -> subst_t // potentially expensive, so thunked -} - -val null_psc : psc -val psc_range : psc -> FStar.Compiler.Range.range -val psc_subst : psc -> subst_t - -type interp_t = - psc -> FStar.Syntax.Embeddings.norm_cb -> universes -> args -> option term -type nbe_interp_t = - NBE.nbe_cbs -> universes -> NBE.args -> option NBE.t - -type primitive_step = { - name:FStar.Ident.lid; - arity:int; - univ_arity:int; // universe arity - auto_reflect:option int; - strong_reduction_ok:bool; - requires_binder_substitution:bool; - renorm_after:bool; // whether the result of this primop must possibly undergo more normalization - interpretation:interp_t; - interpretation_nbe:nbe_interp_t; -} - -val as_primitive_step_nbecbs - (is_strong:bool) - (* (l, arity, u_arity, f, f_nbe) *) - : (Ident.lident & int & int & interp_t & nbe_interp_t) -> primitive_step - -(* Some helpers for the NBE. Does not really belong in this module. *) -val embed_simple: {| EMB.embedding 'a |} -> Range.range -> 'a -> term -val try_unembed_simple: {| EMB.embedding 'a |} -> term -> option 'a - -val mk_interp1 #a #r - {| EMB.embedding a |} - {| EMB.embedding r |} - (f : a -> r) - : interp_t - -val mk_nbe_interp1 #a #r - {| NBE.embedding a |} - {| NBE.embedding r |} - (f : a -> r) - : nbe_interp_t - -val mk_interp2 #a #b #r - {| EMB.embedding a |} {| EMB.embedding b |} - {| EMB.embedding r |} - (f : a -> b -> r) - : interp_t - -val mk_nbe_interp2 #a #b #r - {| NBE.embedding a |} {| NBE.embedding b |} - {| NBE.embedding r |} - (f : a -> b -> r) - : nbe_interp_t - -val mk_interp3 #a #b #c #r - {| EMB.embedding a |} {| EMB.embedding b |} {| EMB.embedding c |} - {| EMB.embedding r |} - (f : a -> b -> c -> r) - : interp_t - -val mk_nbe_interp3 #a #b #c #r - {| NBE.embedding a |} {| NBE.embedding b |} {| NBE.embedding c |} - {| NBE.embedding r |} - (f : a -> b -> c -> r) - : nbe_interp_t - -val mk_interp4 #a #b #c #d #r - {| EMB.embedding a |} {| EMB.embedding b |} {| EMB.embedding c |} {| EMB.embedding d |} - {| EMB.embedding r |} - (f : a -> b -> c -> d -> r) - : interp_t - -val mk_nbe_interp4 #a #b #c #d #r - {| NBE.embedding a |} {| NBE.embedding b |} {| NBE.embedding c |} {| NBE.embedding d |} - {| NBE.embedding r |} - (f : a -> b -> c -> d -> r) - : nbe_interp_t - -val mk_interp5 #a #b #c #d #e #r - {| EMB.embedding a |} {| EMB.embedding b |} {| EMB.embedding c |} {| EMB.embedding d |} {| EMB.embedding e |} - {| EMB.embedding r |} - (f : a -> b -> c -> d -> e -> r) - : interp_t - -val mk_nbe_interp5 #a #b #c #d #e #r - {| NBE.embedding a |} {| NBE.embedding b |} {| NBE.embedding c |} {| NBE.embedding d |} {| NBE.embedding e |} - {| NBE.embedding r |} - (f : a -> b -> c -> d -> e -> r) - : nbe_interp_t - -val mk1 #a #r - (u_arity : int) - (name : Ident.lid) - {| EMB.embedding a |} {| NBE.embedding a |} - {| EMB.embedding r |} {| NBE.embedding r |} - (f : a -> r) - : primitive_step - -val mk2 #a #b #r - (u_arity : int) - (name : Ident.lid) - {| EMB.embedding a |} {| NBE.embedding a |} - {| EMB.embedding b |} {| NBE.embedding b |} - {| EMB.embedding r |} {| NBE.embedding r |} - (f : a -> b -> r) - : primitive_step - -val mk3 #a #b #c #r - (u_arity : int) - (name : Ident.lid) - {| EMB.embedding a |} {| NBE.embedding a |} - {| EMB.embedding b |} {| NBE.embedding b |} - {| EMB.embedding c |} {| NBE.embedding c |} - {| EMB.embedding r |} {| NBE.embedding r |} - (f : a -> b -> c -> r) - : primitive_step - -val mk4 #a #b #c #d #r - (u_arity : int) - (name : Ident.lid) - {| EMB.embedding a |} {| NBE.embedding a |} - {| EMB.embedding b |} {| NBE.embedding b |} - {| EMB.embedding c |} {| NBE.embedding c |} - {| EMB.embedding d |} {| NBE.embedding d |} - {| EMB.embedding r |} {| NBE.embedding r |} - (f : a -> b -> c -> d -> r) - : primitive_step - -val mk5 #a #b #c #d #e #r - (u_arity : int) - (name : Ident.lid) - {| EMB.embedding a |} {| NBE.embedding a |} - {| EMB.embedding b |} {| NBE.embedding b |} - {| EMB.embedding c |} {| NBE.embedding c |} - {| EMB.embedding d |} {| NBE.embedding d |} - {| EMB.embedding e |} {| NBE.embedding e |} - {| EMB.embedding r |} {| NBE.embedding r |} - (f : a -> b -> c -> d -> e -> r) - : primitive_step - -(* Duplication for op_Division / op_Modulus which can prevent reduction. The `f` -already returns something in the option monad, so we add an extra join. Also for -decidable eq which needs different impls in each normalizer *) -val mk1' #a #r #na #nr - (u_arity : int) - (name : Ident.lid) - {| EMB.embedding a |} {| NBE.embedding na |} - {| EMB.embedding r |} {| NBE.embedding nr |} - (f : a -> option r) - (f : na -> option nr) - : primitive_step - -val mk1_psc' #a #r #na #nr - (u_arity : int) - (name : Ident.lid) - {| EMB.embedding a |} {| NBE.embedding na |} - {| EMB.embedding r |} {| NBE.embedding nr |} - (f : psc -> a -> option r) - (f : psc -> na -> option nr) - : primitive_step - -val mk2' #a #b #r #na #nb #nr - (u_arity : int) - (name : Ident.lid) - {| EMB.embedding a |} {| NBE.embedding na |} - {| EMB.embedding b |} {| NBE.embedding nb |} - {| EMB.embedding r |} {| NBE.embedding nr |} - (f : a -> b -> option r) - (f : na -> nb -> option nr) - : primitive_step - -val mk3' #a #b #c #r #na #nb #nc #nr - (u_arity : int) - (name : Ident.lid) - {| EMB.embedding a |} {| NBE.embedding na |} - {| EMB.embedding b |} {| NBE.embedding nb |} - {| EMB.embedding c |} {| NBE.embedding nc |} - {| EMB.embedding r |} {| NBE.embedding nr |} - (f : a -> b -> c -> option r) - (f : na -> nb -> nc -> option nr) - : primitive_step - -val mk4' #a #b #c #d #r #na #nb #nc #nd #nr - (u_arity : int) - (name : Ident.lid) - {| EMB.embedding a |} {| NBE.embedding na |} - {| EMB.embedding b |} {| NBE.embedding nb |} - {| EMB.embedding c |} {| NBE.embedding nc |} - {| EMB.embedding d |} {| NBE.embedding nd |} - {| EMB.embedding r |} {| NBE.embedding nr |} - (f : a -> b -> c -> d -> option r) - (f : na -> nb -> nc -> nd -> option nr) - : primitive_step - - -val mk5' #a #b #c #d #e #r #na #nb #nc #nd #ne #nr - (u_arity : int) - (name : Ident.lid) - {| EMB.embedding a |} {| NBE.embedding na |} - {| EMB.embedding b |} {| NBE.embedding nb |} - {| EMB.embedding c |} {| NBE.embedding nc |} - {| EMB.embedding d |} {| NBE.embedding nd |} - {| EMB.embedding e |} {| NBE.embedding ne |} - {| EMB.embedding r |} {| NBE.embedding nr |} - (f : a -> b -> c -> d -> e -> option r) - (f : na -> nb -> nc -> nd -> ne -> option nr) - : primitive_step - -val mk6' #a #b #c #d #e #f #r #na #nb #nc #nd #ne #nf #nr - (u_arity : int) - (name : Ident.lid) - {| EMB.embedding a |} {| NBE.embedding na |} - {| EMB.embedding b |} {| NBE.embedding nb |} - {| EMB.embedding c |} {| NBE.embedding nc |} - {| EMB.embedding d |} {| NBE.embedding nd |} - {| EMB.embedding e |} {| NBE.embedding ne |} - {| EMB.embedding f |} {| NBE.embedding nf |} - {| EMB.embedding r |} {| NBE.embedding nr |} - (f : a -> b -> c -> d -> e -> f -> option r) - (f : na -> nb -> nc -> nd -> ne -> nf -> option nr) - : primitive_step diff --git a/src/typechecker/FStar.TypeChecker.Primops.Docs.fst b/src/typechecker/FStar.TypeChecker.Primops.Docs.fst deleted file mode 100644 index 3d0f5fbb534..00000000000 --- a/src/typechecker/FStar.TypeChecker.Primops.Docs.fst +++ /dev/null @@ -1,85 +0,0 @@ -module FStar.TypeChecker.Primops.Docs - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Class.Monad - -module Z = FStar.BigInt -module PC = FStar.Parser.Const - -open FStar.TypeChecker.Primops.Base - -(* FIXME: most of these disabled as they would break extraction. -In extracted code, we need to turn the doc into a term representation -for it. I'm actually not sure how to do that since the document -type is abstract even internally. *) - -let ops = - let nm l = PC.p2l ["FStar"; "Stubs"; "Pprint"; l] in - let open FStar.Pprint in - [ - (* mk1 0 (nm "doc_of_char") doc_of_char; *) - (* mk1 0 (nm "doc_of_string") doc_of_string; *) - (* mk1 0 (nm "doc_of_bool") doc_of_bool; *) - (* mk3 0 (nm "substring") (fun s i j -> substring s (Z.to_int_fs i) (Z.to_int_fs j)); *) - (* mk2 0 (nm "fancystring") (fun s i -> fancystring s (Z.to_int_fs i)); *) - (* mk4 0 (nm "fancysubstring") (fun s i j k -> fancysubstring s (Z.to_int_fs i) (Z.to_int_fs j) (Z.to_int_fs k)); *) - (* mk1 0 (nm "utf8string") utf8string; *) - //hardline & others: zero-arity... - (* mk1 0 (nm "blank") (fun i -> blank (Z.to_int_fs i)); *) - (* mk1 0 (nm "break_") (fun i -> break_ (Z.to_int_fs i)); *) - - (* mk2 0 (nm "op_Hat_Hat") (^^); *) - (* mk2 0 (nm "op_Hat_Slash_Hat") (^/^); *) - (* mk2 0 (nm "nest") (fun i d -> nest (Z.to_int_fs i) d); *) - (* mk1 0 (nm "group") group; *) - (* mk2 0 (nm "ifflat") ifflat; *) - - (* mk2 0 (nm "precede") precede; *) - (* mk2 0 (nm "terminate") terminate; *) - (* mk3 0 (nm "enclose") enclose; *) - (* mk1 0 (nm "squotes") squotes; *) - (* mk1 0 (nm "dquotes") dquotes; *) - (* mk1 0 (nm "bquotes") bquotes; *) - (* mk1 0 (nm "braces") braces; *) - (* mk1 0 (nm "parens") parens; *) - (* mk1 0 (nm "angles") angles; *) - (* mk1 0 (nm "brackets") brackets; *) - (* mk1 0 (nm "twice") twice; *) - (* mk2 0 (nm "repeat") (fun i d -> repeat (Z.to_int_fs i) d); *) - (* mk1 0 (nm "concat") concat; *) - (* mk2 0 (nm "separate") separate; *) - - //concat_map: higher-order - //separate_map: higher-order - - (* mk3 0 (nm "separate2") separate2; *) - - //optional: higher-order - - (* mk1 0 (nm "lines") lines; *) - mk1 0 (nm "arbitrary_string") arbitrary_string; - (* mk1 0 (nm "words") words; *) - - //split: higher-order - (* mk2 0 (nm "flow") flow; *) - //flow_map: higher-order - - (* mk1 0 (nm "url") url; *) - (* mk1 0 (nm "align") align; *) - (* mk2 0 (nm "hang") (fun i d -> hang (Z.to_int_fs i) d); *) - (* mk4 0 (nm "prefix") (fun i j d1 d2 -> *) - (* prefix (Z.to_int_fs i) (Z.to_int_fs j) d1 d2); *) - (* mk3 0 (nm "jump") (fun i j d -> jump (Z.to_int_fs i) (Z.to_int_fs j) d); *) - (* mk5 0 (nm "infix") (fun i j d1 d2 d3 -> infix (Z.to_int_fs i) (Z.to_int_fs j) d1 d2 d3); *) - (* mk5 0 (nm "surround") (fun i j d1 d2 d3 -> surround (Z.to_int_fs i) (Z.to_int_fs j) d1 d2 d3); *) - (* mk5 0 (nm "soft_surround") (fun i j d1 d2 d3 -> soft_surround (Z.to_int_fs i) (Z.to_int_fs j) d1 d2 d3); *) - - // surround separate: arity too big :-) - // surroundd_separate_map: higher-order - - // pretty_string: float - mk1 0 (nm "render") render; - ] diff --git a/src/typechecker/FStar.TypeChecker.Primops.Docs.fsti b/src/typechecker/FStar.TypeChecker.Primops.Docs.fsti deleted file mode 100644 index 7dc81c08cb3..00000000000 --- a/src/typechecker/FStar.TypeChecker.Primops.Docs.fsti +++ /dev/null @@ -1,5 +0,0 @@ -module FStar.TypeChecker.Primops.Docs - -open FStar.TypeChecker.Primops.Base - -val ops : list primitive_step diff --git a/src/typechecker/FStar.TypeChecker.Primops.Eq.fst b/src/typechecker/FStar.TypeChecker.Primops.Eq.fst deleted file mode 100644 index ce471a23881..00000000000 --- a/src/typechecker/FStar.TypeChecker.Primops.Eq.fst +++ /dev/null @@ -1,78 +0,0 @@ -module FStar.TypeChecker.Primops.Eq - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Syntax.Syntax -open FStar.TypeChecker -open FStar.Class.Monad -open FStar.Class.Show - -module PC = FStar.Parser.Const -module S = FStar.Syntax.Syntax -module U = FStar.Syntax.Util -module EMB = FStar.Syntax.Embeddings -module NBE = FStar.TypeChecker.NBETerm -module TEQ = FStar.TypeChecker.TermEqAndSimplify -module Env = FStar.TypeChecker.Env - -open FStar.TypeChecker.Primops.Base - -let s_eq (env:Env.env_t) (_typ x y : EMB.abstract_term) : option bool = - match TEQ.eq_tm env x.t y.t with - | TEQ.Equal -> Some true - | TEQ.NotEqual -> Some false - | _ -> None - -let nbe_eq env (_typ x y : NBETerm.abstract_nbe_term) : option bool = - match NBETerm.eq_t env x.t y.t with - | TEQ.Equal -> Some true - | TEQ.NotEqual -> Some false - | _ -> None - -let push3 f g x y z = f (g x y z) -let negopt3 = push3 (fmap #option not) - -let dec_eq_ops env : list primitive_step = [ - mk3' 0 PC.op_Eq (s_eq env) (nbe_eq env); - mk3' 0 PC.op_notEq (negopt3 (s_eq env)) (negopt3 (nbe_eq env)); -] - -(* Propositional equality follows. We use the abstract newtypes to -easily embed exactly the term we want. *) - -let s_eq2 env (_typ x y : EMB.abstract_term) : option EMB.abstract_term = - match TEQ.eq_tm env x.t y.t with - | TEQ.Equal -> Some (EMB.Abstract U.t_true) - | TEQ.NotEqual -> Some (EMB.Abstract U.t_false) - | _ -> None - -let nbe_eq2 env (_typ x y : NBE.abstract_nbe_term) : option NBE.abstract_nbe_term = - let open FStar.TypeChecker.NBETerm in - match NBETerm.eq_t env x.t y.t with - | TEQ.Equal -> Some (AbstractNBE (mkFV (S.lid_as_fv PC.true_lid None) [] [])) - | TEQ.NotEqual -> Some (AbstractNBE (mkFV (S.lid_as_fv PC.false_lid None) [] [])) - | TEQ.Unknown -> None - -let s_eq3 env (typ1 typ2 x y : EMB.abstract_term) : option EMB.abstract_term = - match TEQ.eq_tm env typ1.t typ2.t, TEQ.eq_tm env x.t y.t with - | TEQ.Equal, TEQ.Equal -> Some (EMB.Abstract U.t_true) - | TEQ.NotEqual, _ - | _, TEQ.NotEqual -> - Some (EMB.Abstract U.t_false) - | _ -> None - -let nbe_eq3 env (typ1 typ2 x y : NBE.abstract_nbe_term) : option NBE.abstract_nbe_term = - let open FStar.TypeChecker.NBETerm in - match eq_t env typ1.t typ2.t, eq_t env x.t y.t with - | TEQ.Equal, TEQ.Equal -> Some (AbstractNBE (mkFV (S.lid_as_fv PC.true_lid None) [] [])) - | TEQ.NotEqual, _ - | _, TEQ.NotEqual -> - Some (AbstractNBE (mkFV (S.lid_as_fv PC.false_lid None) [] [])) - | _ -> None - -let prop_eq_ops env : list primitive_step = [ - mk3' 1 PC.eq2_lid (s_eq2 env) (nbe_eq2 env); - mk4' 2 PC.eq3_lid (s_eq3 env) (nbe_eq3 env); -] diff --git a/src/typechecker/FStar.TypeChecker.Primops.Eq.fsti b/src/typechecker/FStar.TypeChecker.Primops.Eq.fsti deleted file mode 100644 index c884d7c6a02..00000000000 --- a/src/typechecker/FStar.TypeChecker.Primops.Eq.fsti +++ /dev/null @@ -1,7 +0,0 @@ -module FStar.TypeChecker.Primops.Eq -module Env = FStar.TypeChecker.Env -open FStar.TypeChecker.Primops.Base - -val dec_eq_ops (_:Env.env_t) : list primitive_step - -val prop_eq_ops (_:Env.env_t) : list primitive_step \ No newline at end of file diff --git a/src/typechecker/FStar.TypeChecker.Primops.Erased.fst b/src/typechecker/FStar.TypeChecker.Primops.Erased.fst deleted file mode 100644 index 36d3f221e87..00000000000 --- a/src/typechecker/FStar.TypeChecker.Primops.Erased.fst +++ /dev/null @@ -1,70 +0,0 @@ -module FStar.TypeChecker.Primops.Erased - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Syntax.Syntax -open FStar.TypeChecker -open FStar.Class.Monad -open FStar.Class.Show - -module PC = FStar.Parser.Const -module S = FStar.Syntax.Syntax -module U = FStar.Syntax.Util -module EMB = FStar.Syntax.Embeddings -module NBE = FStar.TypeChecker.NBETerm - -open FStar.TypeChecker.Primops.Base - -type emb_erased (a:Type) = | Hide : x:a -> emb_erased a - -instance e_erased (a:Type) (d : EMB.embedding a) : Tot (EMB.embedding (emb_erased a)) = - let em (x:emb_erased a) rng shadow cbs = - let Hide x = x in - let h = S.fvar PC.hide None in - U.mk_app h [S.iarg (EMB.type_of d); S.as_arg (EMB.embed x rng shadow cbs)] - in - let un (t:term) cbs : option (emb_erased a) = - let head, args = U.head_and_args t in - match (U.un_uinst head).n, args with - | Tm_fvar fv, [_t; (a, None)] when fv_eq_lid fv PC.hide -> - let! v = EMB.unembed a cbs in - return (Hide v) - | _ -> - None - in - EMB.mk_emb_full em un - (fun () -> S.t_erased_of (EMB.type_of d)) - (fun (Hide x) -> "Hide " ^ EMB.printer_of d x) - (fun () -> ET_abstract) - -instance nbe_e_erased (a:Type) (d : NBE.embedding a) : Tot (NBE.embedding (emb_erased a)) = - let em cbs (x:emb_erased a) = - let Hide x = x in - let fv = S.lid_as_fv PC.hide None in - NBE.mkFV fv [] [NBE.as_arg (NBE.embed d cbs x)] - in - let un cbs (t:NBETerm.t) : option (emb_erased a) = - match NBETerm.nbe_t_of_t t with - | NBETerm.FV (fv, _, [(_t, _); (body, _)]) - when fv_eq_lid fv PC.hide -> - let! v = NBE.unembed d cbs body in - return (Hide v) - | _ -> - None - in - NBETerm.mk_emb em un - (fun () -> magic()) //NBET.t_erased_of (NBE.type_of d)) - (fun () -> ET_abstract) - -let s_reveal (a:EMB.abstract_term) (e : emb_erased EMB.abstract_term) = - let Hide x = e in Some x - -let nbe_reveal (a:NBE.abstract_nbe_term) (e : emb_erased NBE.abstract_nbe_term) = - let Hide x = e in Some x - -let ops = [ - (* unconditionally reduce reveal #t' (hide #t x) to x *) - mk2' 1 PC.reveal s_reveal nbe_reveal -] diff --git a/src/typechecker/FStar.TypeChecker.Primops.Erased.fsti b/src/typechecker/FStar.TypeChecker.Primops.Erased.fsti deleted file mode 100644 index cb83be99dab..00000000000 --- a/src/typechecker/FStar.TypeChecker.Primops.Erased.fsti +++ /dev/null @@ -1,5 +0,0 @@ -module FStar.TypeChecker.Primops.Erased - -open FStar.TypeChecker.Primops.Base - -val ops : list primitive_step \ No newline at end of file diff --git a/src/typechecker/FStar.TypeChecker.Primops.Errors.Msg.fst b/src/typechecker/FStar.TypeChecker.Primops.Errors.Msg.fst deleted file mode 100644 index ad63c52acf1..00000000000 --- a/src/typechecker/FStar.TypeChecker.Primops.Errors.Msg.fst +++ /dev/null @@ -1,26 +0,0 @@ -module FStar.TypeChecker.Primops.Errors.Msg - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Class.Monad - -module Z = FStar.BigInt -module PC = FStar.Parser.Const - -open FStar.TypeChecker.Primops.Base - -let ops = - let nm l = PC.p2l ["FStar"; "Stubs"; "Errors"; "Msg"; l] in - let open FStar.Errors.Msg in - [ - mk1 0 (nm "text") text; - mk2 0 (nm "sublist") sublist; - mk1 0 (nm "bulleted") bulleted; - mk1 0 (nm "mkmsg") mkmsg; - mk1 0 (nm "subdoc") subdoc; - mk1 0 (nm "renderdoc") renderdoc; - mk1 0 (nm "backtrace_doc") backtrace_doc; - mk1 0 (nm "rendermsg") rendermsg; - ] diff --git a/src/typechecker/FStar.TypeChecker.Primops.Errors.Msg.fsti b/src/typechecker/FStar.TypeChecker.Primops.Errors.Msg.fsti deleted file mode 100644 index 80c1f2c4a7d..00000000000 --- a/src/typechecker/FStar.TypeChecker.Primops.Errors.Msg.fsti +++ /dev/null @@ -1,7 +0,0 @@ -module FStar.TypeChecker.Primops.Errors.Msg - -(* Primitive steps for FStar.Stubs.Errors.Msg in ulib *) - -open FStar.TypeChecker.Primops.Base - -val ops : list primitive_step diff --git a/src/typechecker/FStar.TypeChecker.Primops.Issue.fst b/src/typechecker/FStar.TypeChecker.Primops.Issue.fst deleted file mode 100644 index bbea2da7e4b..00000000000 --- a/src/typechecker/FStar.TypeChecker.Primops.Issue.fst +++ /dev/null @@ -1,29 +0,0 @@ -module FStar.TypeChecker.Primops.Issue - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Errors -open FStar.Class.Monad - -open FStar.TypeChecker.Primops.Base - -module PC = FStar.Parser.Const -module Z = FStar.BigInt - -let ops : list primitive_step = - let mk_lid l = PC.p2l ["FStar"; "Issue"; l] in [ - mk1 0 (mk_lid "message_of_issue") Mkissue?.issue_msg; - mk1 0 (mk_lid "level_of_issue") (fun i -> Errors.string_of_issue_level i.issue_level); - mk1 0 (mk_lid "number_of_issue") (fun i -> fmap Z.of_int_fs i.issue_number); - mk1 0 (mk_lid "range_of_issue") Mkissue?.issue_range; - mk1 0 (mk_lid "context_of_issue") Mkissue?.issue_ctx; - mk1 0 (mk_lid "render_issue") Errors.format_issue; - mk5 0 (mk_lid "mk_issue_doc") (fun level msg range number context -> - { issue_level = Errors.issue_level_of_string level; - issue_range = range; - issue_number = fmap Z.to_int_fs number; - issue_msg = msg; - issue_ctx = context} - ); - ] diff --git a/src/typechecker/FStar.TypeChecker.Primops.Issue.fsti b/src/typechecker/FStar.TypeChecker.Primops.Issue.fsti deleted file mode 100644 index 0c00810fca7..00000000000 --- a/src/typechecker/FStar.TypeChecker.Primops.Issue.fsti +++ /dev/null @@ -1,5 +0,0 @@ -module FStar.TypeChecker.Primops.Issue - -open FStar.TypeChecker.Primops.Base - -val ops : list primitive_step diff --git a/src/typechecker/FStar.TypeChecker.Primops.MachineInts.fst b/src/typechecker/FStar.TypeChecker.Primops.MachineInts.fst deleted file mode 100644 index a434f594889..00000000000 --- a/src/typechecker/FStar.TypeChecker.Primops.MachineInts.fst +++ /dev/null @@ -1,94 +0,0 @@ -module FStar.TypeChecker.Primops.MachineInts - -(* Primops about machine integers *) - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Char -open FStar.TypeChecker.Primops.Base -module PC = FStar.Parser.Const -module Z = FStar.BigInt - -(* We're going full Haskell in this module *) -open FStar.Class.Monad -open FStar.Compiler.Writer -open FStar.Class.Show - -open FStar.Compiler.MachineInts - -(* NB: Eta expanding trips typeclass resolution *) -let mymon = writer (list primitive_step) - -let bounded_arith_ops_for (k : machint_kind) : mymon unit = - let mod_name = module_name_for k in - let nm s = (PC.p2l ["FStar"; module_name_for k; s]) in - (* Operators common to all *) - emit [ - mk1 0 (nm "v") (v #k); - - (* basic ops supported by all *) - mk2 0 (nm "add") (fun (x y : machint k) -> make_as x (Z.add_big_int (v x) (v y))); - mk2 0 (nm "sub") (fun (x y : machint k) -> make_as x (Z.sub_big_int (v x) (v y))); - mk2 0 (nm "mul") (fun (x y : machint k) -> make_as x (Z.mult_big_int (v x) (v y))); - - mk2 0 (nm "gt") (fun (x y : machint k) -> Z.gt_big_int (v x) (v y)); - mk2 0 (nm "gte") (fun (x y : machint k) -> Z.ge_big_int (v x) (v y)); - mk2 0 (nm "lt") (fun (x y : machint k) -> Z.lt_big_int (v x) (v y)); - mk2 0 (nm "lte") (fun (x y : machint k) -> Z.le_big_int (v x) (v y)); - ];! - - (* Unsigned ints have more operators *) - let sz = width k in - let modulus = Z.shift_left_big_int Z.one (Z.of_int_fs sz) in - let mod (x : Z.t) : Z.t = Z.mod_big_int x modulus in - if is_unsigned k then - emit [ - (* modulo operators *) - mk2 0 (nm "add_mod") (fun (x y : machint k) -> make_as x (mod (Z.add_big_int (v x) (v y)))); - mk2 0 (nm "sub_mod") (fun (x y : machint k) -> make_as x (mod (Z.sub_big_int (v x) (v y)))); - mk2 0 (nm "div") (fun (x y : machint k) -> make_as x (mod (Z.div_big_int (v x) (v y)))); - mk2 0 (nm "rem") (fun (x y : machint k) -> make_as x (mod (Z.mod_big_int (v x) (v y)))); - - (* bitwise *) - mk2 0 (nm "logor") (fun (x y : machint k) -> make_as x (Z.logor_big_int (v x) (v y))); - mk2 0 (nm "logand") (fun (x y : machint k) -> make_as x (Z.logand_big_int (v x) (v y))); - mk2 0 (nm "logxor") (fun (x y : machint k) -> make_as x (Z.logxor_big_int (v x) (v y))); - mk1 0 (nm "lognot") (fun (x : machint k) -> make_as x (Z.logand_big_int (Z.lognot_big_int (v x)) (mask k))); - - (* NB: shift_{left,right} always take a UInt32 on the right, hence the annotations - to choose the right instances. *) - mk2 0 (nm "shift_left") (fun (x : machint k) (y : machint UInt32) -> - make_as x (Z.logand_big_int (Z.shift_left_big_int (v x) (v y)) (mask k))); - mk2 0 (nm "shift_right") (fun (x : machint k) (y : machint UInt32) -> - make_as x (Z.logand_big_int (Z.shift_right_big_int (v x) (v y)) (mask k))); - ] - else return ();! - - (* Most unsigneds, except SizeT, have underspec ops *) - if is_unsigned k && k <> SizeT then - emit [ - mk2 0 (nm "add_underspec") (fun (x y : machint k) -> make_as x (mod (Z.add_big_int (v x) (v y)))); - mk2 0 (nm "sub_underspec") (fun (x y : machint k) -> make_as x (mod (Z.sub_big_int (v x) (v y)))); - mk2 0 (nm "mul_underspec") (fun (x y : machint k) -> make_as x (mod (Z.mult_big_int (v x) (v y)))); - ] - else return ();! - - (* And except for SizeT and UInt128, they have mul_mod *) - if is_unsigned k && (k <> SizeT && k <> UInt128) then - emit [ - mk2 0 (nm "mul_mod") (fun (x y : machint k) -> make_as x (mod (Z.mult_big_int (v x) (v y)))); - ] - else return ();! - - return () - -let ops : list primitive_step = - fst <| - run_writer <| - (iterM bounded_arith_ops_for all_machint_kinds ;! - emit [ - (* Single extra op that returns a U32 *) - mk1 0 PC.char_u32_of_char (fun (c : char) -> let n = Compiler.Util.int_of_char c |> Z.of_int_fs in - MachineInts.mk #UInt32 n None); - ]) diff --git a/src/typechecker/FStar.TypeChecker.Primops.MachineInts.fsti b/src/typechecker/FStar.TypeChecker.Primops.MachineInts.fsti deleted file mode 100644 index b32c8d48c7f..00000000000 --- a/src/typechecker/FStar.TypeChecker.Primops.MachineInts.fsti +++ /dev/null @@ -1,5 +0,0 @@ -module FStar.TypeChecker.Primops.MachineInts - -open FStar.TypeChecker.Primops.Base - -val ops : list primitive_step diff --git a/src/typechecker/FStar.TypeChecker.Primops.Range.fst b/src/typechecker/FStar.TypeChecker.Primops.Range.fst deleted file mode 100644 index a714f1bd2c3..00000000000 --- a/src/typechecker/FStar.TypeChecker.Primops.Range.fst +++ /dev/null @@ -1,56 +0,0 @@ -module FStar.TypeChecker.Primops.Range - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Class.Monad - -open FStar.TypeChecker.Primops.Base -open FStar.Compiler.Range - -module PC = FStar.Parser.Const -module Z = FStar.BigInt - -(* Range ops *) - -(* this type only here to use typeclass hackery *) -type unsealedRange = | U of Range.range - -let mk_range (fn : string) (from_l from_c to_l to_c : Z.t) : Range.range = - Range.mk_range fn (mk_pos (Z.to_int_fs from_l) (Z.to_int_fs from_c)) - (mk_pos (Z.to_int_fs to_l) (Z.to_int_fs to_c)) - -let __mk_range (fn : string) (from_l from_c to_l to_c : Z.t) : unsealedRange = - U (mk_range fn from_l from_c to_l to_c) - -let explode (r : unsealedRange) : (string & Z.t & Z.t & Z.t & Z.t) = - match r with - | U r -> - let open FStar.Compiler.Range.Type in - (file_of_range r, - Z.of_int_fs (line_of_pos (start_of_range r)), - Z.of_int_fs (col_of_pos (start_of_range r)), - Z.of_int_fs (line_of_pos (end_of_range r)), - Z.of_int_fs (col_of_pos (end_of_range r))) - -instance e_unsealedRange : Syntax.Embeddings.embedding unsealedRange = - let open FStar.Syntax.Embeddings in - embed_as e___range - (fun r -> U r) - (fun (U r) -> r) - None - -instance nbe_e_unsealedRange : FStar.TypeChecker.NBETerm.embedding unsealedRange = - let open FStar.TypeChecker.NBETerm in - embed_as e___range - (fun r -> U r) - (fun (U r) -> r) - None - -let ops = [ - mk5 0 PC.__mk_range_lid __mk_range; - mk5 0 PC.mk_range_lid mk_range; - mk1 0 PC.__explode_range_lid explode; - mk2 0 PC.join_range_lid FStar.Compiler.Range.union_ranges; -] diff --git a/src/typechecker/FStar.TypeChecker.Primops.Range.fsti b/src/typechecker/FStar.TypeChecker.Primops.Range.fsti deleted file mode 100644 index 484e936c99d..00000000000 --- a/src/typechecker/FStar.TypeChecker.Primops.Range.fsti +++ /dev/null @@ -1,5 +0,0 @@ -module FStar.TypeChecker.Primops.Range - -open FStar.TypeChecker.Primops.Base - -val ops : list primitive_step diff --git a/src/typechecker/FStar.TypeChecker.Primops.Real.fst b/src/typechecker/FStar.TypeChecker.Primops.Real.fst deleted file mode 100644 index 5cc57daeb50..00000000000 --- a/src/typechecker/FStar.TypeChecker.Primops.Real.fst +++ /dev/null @@ -1,98 +0,0 @@ -module FStar.TypeChecker.Primops.Real - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.Class.Monad -open FStar.Compiler.Order - -open FStar.TypeChecker.Primops.Base -open FStar.Syntax.Syntax -open FStar.Syntax.Embeddings - -module PC = FStar.Parser.Const -module Z = FStar.BigInt -module S = FStar.Syntax.Syntax -module U = FStar.Syntax.Util - -(* Range ops *) - -type tf = - | T - | F - -instance e_tf : Syntax.Embeddings.embedding tf = - let ty = U.fvar_const PC.prop_lid in - let emb_t_prop = ET_app(PC.prop_lid |> Ident.string_of_lid, []) in - let em (p:tf) (rng:Range.range) _shadow _norm : term = - match p with - | T -> U.t_true - | F -> U.t_false - in - let un (t:term) _norm : option tf = - match (unmeta_div_results t).n with - | Tm_fvar fv when FStar.Syntax.Syntax.fv_eq_lid fv PC.true_lid -> Some T - | Tm_fvar fv when FStar.Syntax.Syntax.fv_eq_lid fv PC.false_lid -> Some F - | _ -> None - in - mk_emb_full - em - un - (fun () -> ty) - (function T -> "T" | F -> "F") - (fun () -> emb_t_prop) - -instance nbe_e_tf : TypeChecker.NBETerm.embedding tf = - let open FStar.TypeChecker.NBETerm in - let lid_as_typ l us args = - mkFV (lid_as_fv l None) us args - in - let em _cb a = - match a with - | T -> lid_as_typ PC.true_lid [] [] - | F -> lid_as_typ PC.false_lid [] [] - in - let un _cb t = - match t.nbe_t with - | FV (fv, [], []) when fv_eq_lid fv PC.true_lid -> Some T - | FV (fv, [], []) when fv_eq_lid fv PC.false_lid -> Some F - | _ -> None - in - mk_emb em un (fun () -> lid_as_typ PC.bool_lid [] []) (Syntax.Embeddings.emb_typ_of tf) - -let cmp (r1 r2 : Compiler.Real.real) : option order = - match r1._0, r2._0 with - | "0.0", "0.0" -> Some Eq - | "0.0", "0.5" -> Some Lt - | "0.0", "1.0" -> Some Lt - | "0.5", "0.0" -> Some Gt - | "0.5", "0.5" -> Some Eq - | "0.5", "1.0" -> Some Lt - | "1.0", "0.0" -> Some Gt - | "1.0", "0.5" -> Some Gt - | "1.0", "1.0" -> Some Eq - | _ -> None - -let lt (r1 r2 : Compiler.Real.real) : option tf = - cmp r1 r2 |> Class.Monad.fmap (function Lt -> T | _ -> F) -let le (r1 r2 : Compiler.Real.real) : option tf = - cmp r1 r2 |> Class.Monad.fmap (function Lt | Eq -> T | _ -> F) -let gt (r1 r2 : Compiler.Real.real) : option tf = - cmp r1 r2 |> Class.Monad.fmap (function Gt -> T | _ -> F) -let ge (r1 r2 : Compiler.Real.real) : option tf = - cmp r1 r2 |> Class.Monad.fmap (function Gt | Eq -> T | _ -> F) - -let of_int (i:Z.t) : Compiler.Real.real = - Compiler.Real.Real (string_of_int (Z.to_int_fs i) ^ ".0") - -let ops = [ - mk1 0 PC.real_of_int of_int; -] - -let simplify_ops = [ - mk2' 0 PC.real_op_LT lt lt; - mk2' 0 PC.real_op_LTE le le; - mk2' 0 PC.real_op_GT gt gt; - mk2' 0 PC.real_op_GTE ge ge; -] diff --git a/src/typechecker/FStar.TypeChecker.Primops.Real.fsti b/src/typechecker/FStar.TypeChecker.Primops.Real.fsti deleted file mode 100644 index 57c56858062..00000000000 --- a/src/typechecker/FStar.TypeChecker.Primops.Real.fsti +++ /dev/null @@ -1,6 +0,0 @@ -module FStar.TypeChecker.Primops.Real - -open FStar.TypeChecker.Primops.Base - -val ops : list primitive_step -val simplify_ops : list primitive_step diff --git a/src/typechecker/FStar.TypeChecker.Primops.Sealed.fst b/src/typechecker/FStar.TypeChecker.Primops.Sealed.fst deleted file mode 100644 index 6e3e0e480ab..00000000000 --- a/src/typechecker/FStar.TypeChecker.Primops.Sealed.fst +++ /dev/null @@ -1,102 +0,0 @@ -module FStar.TypeChecker.Primops.Sealed - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Syntax.Syntax - -open FStar.TypeChecker.Primops.Base - -module EMB = FStar.Syntax.Embeddings -module NBETerm = FStar.TypeChecker.NBETerm -module PC = FStar.Parser.Const -module S = FStar.Syntax.Syntax -module U = FStar.Syntax.Util - -let bogus_cbs = { - NBETerm.iapp = (fun h _args -> h); - NBETerm.translate = (fun _ -> failwith "bogus_cbs translate"); -} - -let ops = - List.map (fun p -> { as_primitive_step_nbecbs true p with renorm_after = true}) [ - (PC.map_seal_lid, 4, 2, - (fun psc univs cbs args -> - match args with - | [(ta, _); (tb, _); (s, _); (f, _)] -> - begin - let open EMB in - let try_unembed (#a:Type) (e:embedding a) (x:term) : option a = - try_unembed x id_norm_cb - in - match try_unembed e_any ta, - try_unembed e_any tb, - try_unembed (e_sealed e_any) s, - try_unembed e_any f with - | Some ta, Some tb, Some s, Some f -> - let r = U.mk_app f [S.as_arg (Sealed.unseal s)] in - let emb = set_type ta e_any in - Some (embed_simple psc.psc_range (Sealed.seal r)) - | _ -> None - end - | _ -> None), - (fun cb univs args -> - match args with - | [(ta, _); (tb, _); (s, _); (f, _)] -> - begin - let open FStar.TypeChecker.NBETerm in - let try_unembed (#a:Type) (e:embedding a) (x:NBETerm.t) : option a = - unembed e bogus_cbs x - in - match try_unembed e_any ta, - try_unembed e_any tb, - try_unembed (e_sealed e_any) s, - try_unembed e_any f with - | Some ta, Some tb, Some s, Some f -> - let r = cb.iapp f [as_arg (Sealed.unseal s)] in - let emb = set_type ta e_any in - Some (embed (e_sealed emb) cb (Sealed.seal r)) - | _ -> None - end - | _ -> None - )); - (PC.bind_seal_lid, 4, 2, - (fun psc univs cbs args -> - match args with - | [(ta, _); (tb, _); (s, _); (f, _)] -> - begin - let open EMB in - let try_unembed (#a:Type) (e:embedding a) (x:term) : option a = - try_unembed x id_norm_cb - in - match try_unembed e_any ta, - try_unembed e_any tb, - try_unembed (e_sealed e_any) s, - try_unembed e_any f with - | Some ta, Some tb, Some s, Some f -> - let r = U.mk_app f [S.as_arg (Sealed.unseal s)] in - Some (embed_simple #_ #e_any psc.psc_range r) - | _ -> None - end - | _ -> None), - (fun cb univs args -> - match args with - | [(ta, _); (tb, _); (s, _); (f, _)] -> - begin - let open FStar.TypeChecker.NBETerm in - let try_unembed (#a:Type) (e:embedding a) (x:NBETerm.t) : option a = - unembed e bogus_cbs x - in - match try_unembed e_any ta, - try_unembed e_any tb, - try_unembed (e_sealed e_any) s, - try_unembed e_any f with - | Some ta, Some tb, Some s, Some f -> - let r = cb.iapp f [as_arg (Sealed.unseal s)] in - let emb = set_type ta e_any in - Some (embed emb cb r) - | _ -> None - end - | _ -> None - )); - ] diff --git a/src/typechecker/FStar.TypeChecker.Primops.Sealed.fsti b/src/typechecker/FStar.TypeChecker.Primops.Sealed.fsti deleted file mode 100644 index 5c590c15a8f..00000000000 --- a/src/typechecker/FStar.TypeChecker.Primops.Sealed.fsti +++ /dev/null @@ -1,5 +0,0 @@ -module FStar.TypeChecker.Primops.Sealed - -open FStar.TypeChecker.Primops.Base - -val ops : list primitive_step diff --git a/src/typechecker/FStar.TypeChecker.Primops.fst b/src/typechecker/FStar.TypeChecker.Primops.fst deleted file mode 100644 index f7019af8e1b..00000000000 --- a/src/typechecker/FStar.TypeChecker.Primops.fst +++ /dev/null @@ -1,134 +0,0 @@ -module FStar.TypeChecker.Primops - -(* This module just contains the list of all builtin primitive steps -with their implementations. *) - -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar.String -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.Class.Monad - -module S = FStar.Syntax.Syntax -module BU = FStar.Compiler.Util -module PC = FStar.Parser.Const -module EMB = FStar.Syntax.Embeddings -module Z = FStar.BigInt - -open FStar.TypeChecker.Primops.Base - -(*******************************************************************) -(* Semantics for primitive operators (+, -, >, &&, ...) *) -(*******************************************************************) - -(* Most primitive steps don't use the NBE cbs, so they can use this wrapper. *) -let as_primitive_step is_strong (l, arity, u_arity, f, f_nbe) = - Primops.Base.as_primitive_step_nbecbs is_strong (l, arity, u_arity, f, (fun cb univs args -> f_nbe univs args)) - -(* and_op and or_op are special cased because they are short-circuting, - * can run without unembedding its second argument. *) -let and_op : psc -> EMB.norm_cb -> universes -> args -> option term - = fun psc _norm_cb _us args -> - match args with - | [(a1, None); (a2, None)] -> - begin match try_unembed_simple a1 with - | Some false -> - Some (embed_simple psc.psc_range false) - | Some true -> - Some a2 - | _ -> None - end - | _ -> failwith "Unexpected number of arguments" - -let or_op : psc -> EMB.norm_cb -> universes -> args -> option term - = fun psc _norm_cb _us args -> - match args with - | [(a1, None); (a2, None)] -> - begin match try_unembed_simple a1 with - | Some true -> - Some (embed_simple psc.psc_range true) - | Some false -> - Some a2 - | _ -> None - end - | _ -> failwith "Unexpected number of arguments" - - -let division_modulus_op (f : Z.t -> Z.t -> Z.t) (x y : Z.t) : option Z.t = - if Z.to_int_fs y <> 0 - then Some (f x y) - else None - -(* Simple primops that are just implemented by some concrete function -over embeddable types. *) -let simple_ops : list primitive_step = [ - (* Basic *) - mk1 0 PC.string_of_int_lid (fun z -> string_of_int (Z.to_int_fs z)); - mk1 0 PC.int_of_string_lid (fun s -> fmap Z.of_int_fs (BU.safe_int_of_string s)); - mk1 0 PC.string_of_bool_lid string_of_bool; - mk1 0 PC.bool_of_string_lid (function "true" -> Some true | "false" -> Some false | _ -> None); - - (* Integer opts *) - mk1 0 PC.op_Minus Z.minus_big_int; - mk2 0 PC.op_Addition Z.add_big_int; - mk2 0 PC.op_Subtraction Z.sub_big_int; - mk2 0 PC.op_Multiply Z.mult_big_int; - mk2 0 PC.op_LT Z.lt_big_int; - mk2 0 PC.op_LTE Z.le_big_int; - mk2 0 PC.op_GT Z.gt_big_int; - mk2 0 PC.op_GTE Z.ge_big_int; - - (* Use ' variant to allow for non-reduction. Impl is the same on each normalizer. *) - mk2' 0 PC.op_Division (division_modulus_op Z.div_big_int) (division_modulus_op Z.div_big_int); - mk2' 0 PC.op_Modulus (division_modulus_op Z.mod_big_int) (division_modulus_op Z.mod_big_int); - - (* Bool opts. NB: && and || are special-cased since they are - short-circuiting, and can run even if their second arg does not - try_unembed_simple. Otherwise the strict variants are defined as below. *) - mk1 0 PC.op_Negation not; - // mk2 0 PC.op_And (&&); - // mk2 0 PC.op_Or ( || ); - - (* Operations from FStar.String *) - mk2 0 PC.string_concat_lid String.concat; - mk2 0 PC.string_split_lid String.split; - mk2 0 PC.prims_strcat_lid (^); - mk2 0 PC.string_compare_lid (fun s1 s2 -> Z.of_int_fs (String.compare s1 s2)); - mk1 0 PC.string_string_of_list_lid string_of_list; - mk2 0 PC.string_make_lid (fun x y -> String.make (Z.to_int_fs x) y); - mk1 0 PC.string_list_of_string_lid list_of_string; - mk1 0 PC.string_lowercase_lid String.lowercase; - mk1 0 PC.string_uppercase_lid String.uppercase; - mk2 0 PC.string_index_lid String.index; - mk2 0 PC.string_index_of_lid String.index_of; - mk3 0 PC.string_sub_lid (fun s o l -> String.substring s (Z.to_int_fs o) (Z.to_int_fs l)); -] - -let short_circuit_ops : list primitive_step = - List.map (as_primitive_step true) - [ - (PC.op_And, 2, 0, and_op, (fun _us -> NBETerm.and_op)); - (PC.op_Or, 2, 0, or_op, (fun _us -> NBETerm.or_op)); - ] - -let built_in_primitive_steps_list : list primitive_step = - simple_ops - @ short_circuit_ops - @ Primops.Issue.ops - @ Primops.Array.ops - @ Primops.Sealed.ops - @ Primops.Erased.ops - @ Primops.Docs.ops - @ Primops.MachineInts.ops - @ Primops.Errors.Msg.ops - @ Primops.Range.ops - @ Primops.Real.ops - -let env_dependent_ops (env:Env.env_t) = Primops.Eq.dec_eq_ops env - -let simplification_ops_list (env:Env.env_t) : list primitive_step = - Primops.Eq.prop_eq_ops env - @ Primops.Real.simplify_ops diff --git a/src/typechecker/FStar.TypeChecker.Primops.fsti b/src/typechecker/FStar.TypeChecker.Primops.fsti deleted file mode 100644 index 629a676c0b1..00000000000 --- a/src/typechecker/FStar.TypeChecker.Primops.fsti +++ /dev/null @@ -1,16 +0,0 @@ -module FStar.TypeChecker.Primops - -open FStar.Compiler.Effect -include FStar.TypeChecker.Primops.Base - -(* This module just contains the list of all builtin primitive steps -with their implementations. *) - -(* Proper primitive steps. Some of them depend on the environment, -we put those in a separate list so the independent set can be -precomputed into a hash table. *) -val built_in_primitive_steps_list : list primitive_step -val env_dependent_ops (env:Env.env_t) : list primitive_step - -(* Simplification rules. *) -val simplification_ops_list (env:Env.env_t) : list primitive_step diff --git a/src/typechecker/FStar.TypeChecker.Quals.fst b/src/typechecker/FStar.TypeChecker.Quals.fst deleted file mode 100644 index 5c513611314..00000000000 --- a/src/typechecker/FStar.TypeChecker.Quals.fst +++ /dev/null @@ -1,321 +0,0 @@ -(* - Copyright 2008-2024 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.TypeChecker.Quals -open FStar -open FStar.Compiler -open FStar.Compiler.Effect -open FStar.Errors -open FStar.Errors.Msg -open FStar.Pprint -open FStar.Syntax.Syntax -open FStar.Ident -open FStar.Syntax -open FStar.Class.Show -open FStar.Class.PP - -module SS = FStar.Syntax.Subst -module S = FStar.Syntax.Syntax -module BU = FStar.Compiler.Util -module U = FStar.Syntax.Util -module N = FStar.TypeChecker.Normalize -module C = FStar.Parser.Const -module TcUtil = FStar.TypeChecker.Util - -let check_sigelt_quals_pre (env:FStar.TypeChecker.Env.env) se = - let visibility = function Private -> true | _ -> false in - let reducibility = function - | Irreducible - | Unfold_for_unification_and_vcgen | Visible_default - | Inline_for_extraction -> true - | _ -> false in - let assumption = function Assumption | New -> true | _ -> false in - let reification = function Reifiable | Reflectable _ -> true | _ -> false in - let inferred = function - | Discriminator _ - | Projector _ - | RecordType _ - | RecordConstructor _ - | ExceptionConstructor - | HasMaskedEffect - | Effect -> true - | _ -> false in - let has_eq = function Noeq | Unopteq -> true | _ -> false in - let quals_combo_ok quals q = - match q with - | Assumption -> - quals - |> List.for_all (fun x -> x=q - || x=Logic - || inferred x - || visibility x - || assumption x - || (env.is_iface && x=Inline_for_extraction) - || x=NoExtract) - - | New -> //no definition provided - quals - |> List.for_all (fun x -> x=q || inferred x || visibility x || assumption x) - - | Inline_for_extraction -> - quals |> List.for_all (fun x -> x=q || x=Logic || visibility x || reducibility x - || reification x || inferred x || has_eq x - || (env.is_iface && x=Assumption) - || x=NoExtract) - - | Unfold_for_unification_and_vcgen - | Visible_default - | Irreducible - | Noeq - | Unopteq -> - quals - |> List.for_all (fun x -> x=q || x=Logic || x=Inline_for_extraction || x=NoExtract || has_eq x || inferred x || visibility x || reification x) - - | TotalEffect -> - quals - |> List.for_all (fun x -> x=q || inferred x || visibility x || reification x) - - | Logic -> - quals - |> List.for_all (fun x -> x=q || x=Assumption || inferred x || visibility x || reducibility x) - - | Reifiable - | Reflectable _ -> - quals - |> List.for_all (fun x -> reification x || inferred x || visibility x || x=TotalEffect || x=Visible_default) - - | Private -> - true //only about visibility; always legal in combination with others - - | _ -> //inferred - true - in - let check_no_subtyping_attribute se = - if U.has_attribute se.sigattrs C.no_subtping_attr_lid && - (match se.sigel with - | Sig_let _ -> false - | _ -> true) - then raise_error se - Errors.Fatal_InconsistentQualifierAnnotation [ - text "Illegal attribute: the `no_subtyping` attribute is allowed only on let-bindings."] - in - check_no_subtyping_attribute se; - let quals = U.quals_of_sigelt se |> List.filter (fun x -> not (x = Logic)) in //drop logic since it is deprecated - if quals |> BU.for_some (function OnlyName -> true | _ -> false) |> not - then - let r = U.range_of_sigelt se in - let no_dup_quals = BU.remove_dups (fun x y -> x=y) quals in - let err msg = raise_error r Errors.Fatal_QulifierListNotPermitted ([ - text "The qualifier list" ^/^ doc_of_string (show quals) ^/^ text "is not permissible for this element" - ] @ msg) - in - if List.length quals <> List.length no_dup_quals - then err [text "Duplicate qualifiers."]; - if not (quals |> List.for_all (quals_combo_ok quals)) - then err [text "Ill-formed combination."]; - match se.sigel with - | Sig_let {lbs=(is_rec, _)} -> //let rec - if is_rec && quals |> List.contains Unfold_for_unification_and_vcgen - then err [text "Recursive definitions cannot be marked inline."]; - if quals |> BU.for_some (fun x -> assumption x || has_eq x) - then err [text "Definitions cannot be assumed or marked with equality qualifiers."] - | Sig_bundle _ -> - if not (quals |> BU.for_all (fun x -> - x=Inline_for_extraction - || x=NoExtract - || inferred x - || visibility x - || has_eq x)) - then err []; - if quals |> List.existsb (function Unopteq -> true | _ -> false) && - U.has_attribute se.sigattrs FStar.Parser.Const.erasable_attr - then err [text "The `unopteq` qualifier is not allowed on erasable inductives since they don't have decidable equality."] - | Sig_declare_typ _ -> - if quals |> BU.for_some has_eq - then err [] - | Sig_assume _ -> - if not (quals |> BU.for_all (fun x -> visibility x || x=Assumption || x=InternalAssumption)) - then err [] - | Sig_new_effect _ -> - if not (quals |> BU.for_all (fun x -> - x=TotalEffect - || inferred x - || visibility x - || reification x)) - then err [] - | Sig_effect_abbrev _ -> - if not (quals |> BU.for_all (fun x -> inferred x || visibility x)) - then err [] - | _ -> () - -let check_erasable env quals (r:Range.range) se = - let lids = U.lids_of_sigelt se in - let val_exists = - lids |> BU.for_some (fun l -> Option.isSome (Env.try_lookup_val_decl env l)) - in - let val_has_erasable_attr = - lids |> BU.for_some (fun l -> - let attrs_opt = Env.lookup_attrs_of_lid env l in - Option.isSome attrs_opt - && U.has_attribute (Option.get attrs_opt) FStar.Parser.Const.erasable_attr) - in - let se_has_erasable_attr = U.has_attribute se.sigattrs FStar.Parser.Const.erasable_attr in - if ((val_exists && val_has_erasable_attr) && not se_has_erasable_attr) - then raise_error r Errors.Fatal_QulifierListNotPermitted [ - text "Mismatch of attributes between declaration and definition."; - text "Declaration is marked `erasable` but the definition is not."; - ]; - if ((val_exists && not val_has_erasable_attr) && se_has_erasable_attr) - then raise_error r Errors.Fatal_QulifierListNotPermitted [ - text "Mismatch of attributes between declaration and definition."; - text "Definition is marked `erasable` but the declaration is not."; - ]; - if se_has_erasable_attr - then begin - match se.sigel with - | Sig_bundle _ -> - if not (quals |> BU.for_some (function Noeq -> true | _ -> false)) - then raise_error r Errors.Fatal_QulifierListNotPermitted [ - text "Incompatible attributes and qualifiers: \ - erasable types do not support decidable equality and must be marked `noeq`." - ] - | Sig_declare_typ _ -> - () - | Sig_fail _ -> - () (* just ignore it, the member ses have the attribute too *) - - | Sig_let {lbs=(false, [lb])} -> - let _, body, _ = U.abs_formals lb.lbdef in - if not (N.non_info_norm env body) - then raise_error body Errors.Fatal_QulifierListNotPermitted [ - text "Illegal attribute: \ - the `erasable` attribute is only permitted on inductive type definitions \ - and abbreviations for non-informative types."; - text "The term" ^/^ pp body ^/^ text "is considered informative."; - ] - - | Sig_new_effect ({mname=eff_name}) -> //AR: allow erasable on total effects - if not (List.contains TotalEffect quals) - then raise_error r Errors.Fatal_QulifierListNotPermitted [ - text "Effect" ^/^ pp eff_name ^/^ text "is marked erasable but only total effects are allowed to be erasable." - ] - - | _ -> - raise_error r Errors.Fatal_QulifierListNotPermitted [ - text "Illegal attribute: \ - the `erasable` attribute is only permitted on inductive type definitions \ - and abbreviations for non-informative types."; - ] - end - -(* - * Given `val t : Type` in an interface - * and `let t = e` in the corresponding implementation - * The val declaration should contains the `must_erase_for_extraction` attribute - * if and only if `e` is a type that's non-informative (e..g., unit, t -> unit, etc.) - *) -let check_must_erase_attribute env se = - if Options.ide() then () else - match se.sigel with - | Sig_let {lbs; lids=l} -> - begin match DsEnv.iface_decls (Env.dsenv env) (Env.current_module env) with - | None -> - () - - | Some iface_decls -> - snd lbs |> List.iter (fun lb -> - let lbname = BU.right lb.lbname in - let has_iface_val = - iface_decls |> BU.for_some (Parser.AST.decl_is_val (ident_of_lid lbname.fv_name.v)) - in - if has_iface_val - then - let must_erase = TcUtil.must_erase_for_extraction env lb.lbdef in - let has_attr = Env.fv_has_attr env lbname C.must_erase_for_extraction_attr in - if must_erase && not has_attr - then log_issue lbname Error_MustEraseMissing [ - text (BU.format2 "Values of type `%s` will be erased during extraction, \ - but its interface hides this fact. Add the `must_erase_for_extraction` \ - attribute to the `val %s` declaration for this symbol in the interface" - (show lbname) (show lbname)); - ] - else if has_attr && not must_erase - then log_issue lbname Error_MustEraseMissing [ - text (BU.format1 "Values of type `%s` cannot be erased during extraction, \ - but the `must_erase_for_extraction` attribute claims that it can. \ - Please remove the attribute." - (show lbname)); - ]) - end - | _ -> () - -let check_typeclass_instance_attribute env (rng:Range.range) se = - let is_tc_instance = - se.sigattrs |> BU.for_some - (fun t -> - match t.n with - | Tm_fvar fv -> S.fv_eq_lid fv FStar.Parser.Const.tcinstance_lid - | _ -> false) - in - let check_instance_typ (ty:typ) : unit = - let _, res = U.arrow_formals_comp ty in - if not (U.is_total_comp res) then - log_issue rng FStar.Errors.Error_UnexpectedTypeclassInstance [ - text "Instances are expected to be total."; - text "This instance has effect" ^^ pp (U.comp_effect_name res); - ]; - - let t = U.comp_result res in - let head, _ = U.head_and_args t in - let err () = - FStar.Errors.log_issue rng FStar.Errors.Error_UnexpectedTypeclassInstance [ - text "Instances must define instances of `class` types."; - text "Type" ^/^ pp t ^/^ text "is not a class."; - ] - in - match (U.un_uinst head).n with - | Tm_fvar fv -> - if not (Env.fv_has_attr env fv FStar.Parser.Const.tcclass_lid) then - err () - | _ -> - err () - in - if is_tc_instance then - match se.sigel with - | Sig_let {lbs=(false, [lb])} -> - check_instance_typ lb.lbtyp - - | Sig_let _ -> - FStar.Errors.log_issue rng FStar.Errors.Error_UnexpectedTypeclassInstance [ - text "An `instance` definition is expected to be non-recursive and of a type that is a `class`." - ] - - | Sig_declare_typ {t} -> - check_instance_typ t - - | _ -> - FStar.Errors.log_issue rng FStar.Errors.Error_UnexpectedTypeclassInstance [ - text "The `instance` attribute is only allowed on `let` and `val` declarations."; - text "It is not allowed for" ^/^ squotes (arbitrary_string <| Print.sigelt_to_string_short se); - ] - -let check_sigelt_quals_post env se = - let quals = se.sigquals in - let r = se.sigrng in - check_erasable env quals r se; - check_must_erase_attribute env se; - check_typeclass_instance_attribute env r se; - () diff --git a/src/typechecker/FStar.TypeChecker.Quals.fsti b/src/typechecker/FStar.TypeChecker.Quals.fsti deleted file mode 100644 index d9f11bfc468..00000000000 --- a/src/typechecker/FStar.TypeChecker.Quals.fsti +++ /dev/null @@ -1,37 +0,0 @@ -(* - Copyright 2008-2024 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.TypeChecker.Quals - -open FStar -open FStar.Compiler -open FStar.Syntax.Syntax -open FStar.TypeChecker.Env - -(* -Checking qualifiers **and attributes**. This is split in two functions, -_pre and _post, as some qualifier/attributes must be checked before the function -is typechecked (or at least it's better/faster to do so) and some can only be checked -after the function is typechecked. - -Currently, the only things that must be checked after the function is typechecked are: -- The erasable attribute, since the defn must be elaborated. See #3253. -- The must_erase attribute -- The instance attribute for typeclasses -*) - -val check_sigelt_quals_pre : env -> sigelt -> unit -val check_sigelt_quals_post : env -> sigelt -> unit diff --git a/src/typechecker/FStar.TypeChecker.Rel.fst b/src/typechecker/FStar.TypeChecker.Rel.fst deleted file mode 100644 index eda6974b3ff..00000000000 --- a/src/typechecker/FStar.TypeChecker.Rel.fst +++ /dev/null @@ -1,5787 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -////////////////////////////////////////////////////////////////////////// -//Refinement subtyping with higher-order unification -//with special treatment for higher-order patterns -////////////////////////////////////////////////////////////////////////// - -module FStar.TypeChecker.Rel -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.Compiler.Util -open FStar.Errors -open FStar.Defensive -open FStar.TypeChecker -open FStar.Syntax -open FStar.TypeChecker.Env -open FStar.Syntax.Syntax -open FStar.Syntax.Subst -open FStar.Ident -open FStar.TypeChecker.Common -open FStar.Syntax -open FStar.Common - -open FStar.Class.Deq -open FStar.Class.Show -open FStar.Class.Tagged -open FStar.Class.Setlike -open FStar.Class.Listlike -open FStar.Class.Monoid -module Setlike = FStar.Class.Setlike -open FStar.Class.Listlike -open FStar.Compiler.CList -module Listlike = FStar.Class.Listlike - -module BU = FStar.Compiler.Util //basic util -module U = FStar.Syntax.Util -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module N = FStar.TypeChecker.Normalize -module UF = FStar.Syntax.Unionfind -module PC = FStar.Parser.Const -module FC = FStar.Const -module TcComm = FStar.TypeChecker.Common -module TEQ = FStar.TypeChecker.TermEqAndSimplify -module CList = FStar.Compiler.CList - -let dbg_Disch = Debug.get_toggle "Disch" -let dbg_Discharge = Debug.get_toggle "Discharge" -let dbg_EQ = Debug.get_toggle "EQ" -let dbg_ExplainRel = Debug.get_toggle "ExplainRel" -let dbg_GenUniverses = Debug.get_toggle "GenUniverses" -let dbg_ImplicitTrace = Debug.get_toggle "ImplicitTrace" -let dbg_Imps = Debug.get_toggle "Imps" -let dbg_LayeredEffectsApp = Debug.get_toggle "LayeredEffectsApp" -let dbg_LayeredEffectsEqns = Debug.get_toggle "LayeredEffectsEqns" -let dbg_Rel = Debug.get_toggle "Rel" -let dbg_RelBench = Debug.get_toggle "RelBench" -let dbg_RelDelta = Debug.get_toggle "RelDelta" -let dbg_RelTop = Debug.get_toggle "RelTop" -let dbg_ResolveImplicitsHook = Debug.get_toggle "ResolveImplicitsHook" -let dbg_Simplification = Debug.get_toggle "Simplification" -let dbg_SMTQuery = Debug.get_toggle "SMTQuery" -let dbg_Tac = Debug.get_toggle "Tac" - -instance showable_implicit_checking_status : showable implicit_checking_status = { - show = (function - | Implicit_unresolved -> "Implicit_unresolved" - | Implicit_checking_defers_univ_constraint -> "Implicit_checking_defers_univ_constraint" - | Implicit_has_typing_guard (tm, typ) -> "Implicit_has_typing_guard"); -} - -let is_base_type env typ = - let t = FStar.TypeChecker.Normalize.unfold_whnf env typ in - let head, args = U.head_and_args t in - match (U.unascribe (U.un_uinst head)).n with - | Tm_name _ - | Tm_fvar _ - | Tm_type _ -> true - | _ -> false - -let term_is_uvar (uv:ctx_uvar) (t:term) : bool = - match (U.unascribe t).n with - | Tm_uvar (uv', _) -> UF.equiv uv.ctx_uvar_head uv'.ctx_uvar_head - | _ -> false - -let binders_as_bv_set (bs:binders) : FlatSet.t bv = - Setlike.from_list (List.map (fun b -> b.binder_bv) bs) - -(* lazy string, for error reporting *) -type lstring = Thunk.t string - -(* Make a thunk for a string, but keep the UF state - * so it can be set before calling the function. This is - * used since most error messages call term_to_string, - * which will resolve uvars and explode if the version is - * wrong. *) -let mklstr (f : unit -> string) = - let uf = UF.get () in - Thunk.mk (fun () -> - let tx = UF.new_transaction () in - UF.set uf; - let r = f () in - UF.rollback tx; - r) - -(* Instantiation of unification variables *) -type uvi = - | TERM of ctx_uvar & term - | UNIV of S.universe_uvar & universe - -type defer_ok_t = - | NoDefer - | DeferAny - | DeferFlexFlexOnly - -instance _ : showable defer_ok_t = { - show = (function | NoDefer -> "NoDefer" | DeferAny -> "DeferAny" | DeferFlexFlexOnly -> "DeferFlexFlexOnly"); -} - -(* The set of problems currently being addressed *) -type worklist = { - attempting: probs; - wl_deferred: clist (int & deferred_reason & lstring & prob); //flex-flex cases, non patterns, and subtyping constraints involving a unification variable, - wl_deferred_to_tac: clist (int & deferred_reason & lstring & prob); //problems that should be dispatched to a user-provided tactics - ctr: int; //a counter incremented each time we extend subst, used to detect if we've made progress - defer_ok: defer_ok_t; //whether or not carrying constraints is ok---at the top-level, this flag is NoDefer - smt_ok: bool; //whether or not falling back to the SMT solver is permitted - umax_heuristic_ok: bool; //whether or not it's ok to apply a structural match on umax us = umax us' - tcenv: Env.env; //the top-level environment on which Rel was called - wl_implicits: implicits_t; //additional uvars introduced - repr_subcomp_allowed:bool; //whether subtyping of effectful computations - //with a representation (which need a monadic lift) - //is allowed; disabled by default, enabled in - //sub_comp which is called by the typechecker, and - //will insert the appropriate lifts. - typeclass_variables: RBSet.t ctx_uvar //variables that will be solved by typeclass instantiation -} - -(* A NOTE ON ENVIRONMENTS - -At many points during unification, we need to produce a typechecking -environment (Env.env) in order to call into functions such as type_of, -universe_of, and normalization. Hence, it is important to respect -scoping, particularly so after the removal of the use_bv_sorts flag. - -Functions in this module used to explicitly pass around an Env.env, and -used that to call into Tc/Norm. However, while some of them pushed -binders as needed, some of them did not, and the result was a flurry of -subtle scoping bugs. And while those were fixed, we decided to just be -more principled. - -The worklist, threaded through almost all functions, contains the -top-level environment on which the unifier was called. Problems -contain a unification variable with a gamma inside. Hence, to get -an environment, we use `p_env` below which reconstructs it from the -worklist's tcenv and a problem's uvar. This makes sure it is in-sync -with the problem being tackled. The uses of push_bv/push_binder should -be few. -*) - -let as_deferred (wl_def:clist (int & deferred_reason & lstring & prob)) : deferred = - CList.map (fun (_, reason, m, p) -> reason, Thunk.force m, p) wl_def - -let as_wl_deferred wl (d:deferred): clist (int & deferred_reason & lstring & prob) = - CList.map (fun (reason, m, p) -> wl.ctr, reason, Thunk.mkv m, p) d - -(* --------------------------------------------------------- *) -(* Generating new unification variables/patterns *) -(* --------------------------------------------------------- *) -let new_uvar reason wl r gamma binders k should_check meta : ctx_uvar & term & worklist = - let decoration = { - uvar_decoration_typ = k; - uvar_decoration_should_check = should_check; - uvar_decoration_typedness_depends_on = []; - uvar_decoration_should_unrefine = false; - } - in - let ctx_uvar = { - ctx_uvar_head=UF.fresh decoration r; - ctx_uvar_gamma=gamma; - ctx_uvar_binders=binders; - ctx_uvar_reason=reason; - ctx_uvar_range=r; - ctx_uvar_meta=meta; - } in - check_uvar_ctx_invariant reason r true gamma binders; - let t = mk (Tm_uvar (ctx_uvar, ([], NoUseRange))) r in - let imp = { imp_reason = reason - ; imp_tm = t - ; imp_uvar = ctx_uvar - ; imp_range = r - } in - if !dbg_ImplicitTrace then - BU.print1 "Just created uvar (Rel) {%s}\n" (show ctx_uvar.ctx_uvar_head); - ctx_uvar, t, {wl with wl_implicits = cons imp wl.wl_implicits} - -let copy_uvar u (bs:binders) t wl = - let env = {wl.tcenv with gamma = u.ctx_uvar_gamma } in - let env = Env.push_binders env bs in - new_uvar ("copy:"^u.ctx_uvar_reason) wl u.ctx_uvar_range env.gamma - (Env.all_binders env) t - (U.ctx_uvar_should_check u) - u.ctx_uvar_meta - -(* --------------------------------------------------------- *) -(* *) -(* --------------------------------------------------------- *) - -(* Types used in the output of the solver *) - -type solution = - | Success of deferred & deferred & implicits_t - | Failed of prob & lstring - -let extend_wl (wl:worklist) (defers:deferred) (defer_to_tac:deferred) (imps:implicits_t) = - {wl with wl_deferred=wl.wl_deferred ++ as_wl_deferred wl defers; - wl_deferred_to_tac=wl.wl_deferred_to_tac ++ as_wl_deferred wl defer_to_tac; - wl_implicits=wl.wl_implicits ++ imps} - -type variance = - | COVARIANT - | CONTRAVARIANT - | INVARIANT - -type tprob = problem typ -type cprob = problem comp -type problem_t 'a = problem 'a - -(* --------------------------------------------------------- *) -(* *) -(* --------------------------------------------------------- *) - -(* ------------------------------------------------*) -(* *) -(* ------------------------------------------------*) -let invert_rel = function - | EQ -> EQ - | SUB -> SUBINV - | SUBINV -> SUB -let invert p = {p with lhs=p.rhs; rhs=p.lhs; relation=invert_rel p.relation} -let maybe_invert p = if p.relation = SUBINV then invert p else p -let maybe_invert_p = function - | TProb p -> maybe_invert p |> TProb - | CProb p -> maybe_invert p |> CProb -let make_prob_eq = function - | TProb p -> TProb ({p with relation=EQ}) - | CProb p -> CProb ({p with relation=EQ}) -let vary_rel rel = function - | INVARIANT -> EQ - | CONTRAVARIANT -> invert_rel rel - | COVARIANT -> rel -let p_pid = function - | TProb p -> p.pid - | CProb p -> p.pid -let p_rel = function - | TProb p -> p.relation - | CProb p -> p.relation -let p_reason = function - | TProb p -> p.reason - | CProb p -> p.reason -let p_loc = function - | TProb p -> p.loc - | CProb p -> p.loc -let p_element = function - | TProb p -> p.element - | CProb p -> p.element -let p_guard = function - | TProb p -> p.logical_guard - | CProb p -> p.logical_guard -let p_scope prob = - let r = match prob with - | TProb p -> p.logical_guard_uvar.ctx_uvar_binders @ (match p_element prob with | None -> [] | Some x -> [S.mk_binder x]) - | CProb p -> p.logical_guard_uvar.ctx_uvar_binders @ (match p_element prob with | None -> [] | Some x -> [S.mk_binder x]) - in - (* def_scope_wf "p_scope" (p_loc prob) r; *) - r -let p_guard_uvar = function - | TProb p -> p.logical_guard_uvar - | CProb p -> p.logical_guard_uvar -let p_env wl prob = - (* Note: ctx_uvar_gamma should be an extension of tcenv.gamma, - * since we created this uvar during this unification run. *) - { wl.tcenv with gamma=(p_guard_uvar prob).ctx_uvar_gamma} - -let p_guard_env wl prob = - { wl.tcenv with gamma=(match p_element prob with | None -> [] | Some x -> [Binding_var x]) @ (p_guard_uvar prob).ctx_uvar_gamma} - -(* ------------------------------------------------*) -(* *) -(* ------------------------------------------------*) - -(* ------------------------------------------------*) -(* *) -(* ------------------------------------------------*) - -let def_scope_wf msg rng r = - if not (Options.defensive ()) then () else - let rec aux prev next = - match next with - | [] -> () - | ({binder_bv=bv})::bs -> - begin - def_check_scoped rng msg prev bv.sort; - aux (prev @ [bv]) bs - end - in aux [] r - -instance hasBinders_prob : Class.Binders.hasBinders prob = { - boundNames = (fun prob -> Setlike.from_list (List.map (fun b -> b.binder_bv) <| p_scope prob)); -} - -let def_check_term_scoped_in_prob msg prob phi = - def_check_scoped #prob_t #term (p_loc prob) msg prob phi - -let def_check_comp_scoped_in_prob msg prob phi = - def_check_scoped #prob_t #comp (p_loc prob) msg prob phi - -let def_check_prob msg prob = - if not (Options.defensive ()) then () else - let msgf m = msg ^ "." ^ string_of_int (p_pid prob) ^ "." ^ m in - def_scope_wf (msgf "scope") (p_loc prob) (p_scope prob); - def_check_term_scoped_in_prob (msgf "guard") prob (p_guard prob); - match prob with - | TProb p -> - begin - def_check_term_scoped_in_prob (msgf "lhs") prob p.lhs; - def_check_term_scoped_in_prob (msgf "rhs") prob p.rhs - end - | CProb p -> - begin - def_check_comp_scoped_in_prob (msgf "lhs") prob p.lhs; - def_check_comp_scoped_in_prob (msgf "rhs") prob p.rhs - end - -(* ------------------------------------------------*) -(* *) -(* ------------------------------------------------*) - -(* ------------------------------------------------*) -(* (mainly for debugging) *) -(* ------------------------------------------------*) -let rel_to_string = function - | EQ -> "=" - | SUB -> "<:" - | SUBINV -> ":>" - -let term_to_string t = - let head, args = U.head_and_args t in - match head.n with - | Tm_uvar (u, s) -> - BU.format3 "%s%s %s" - (show u) - ("@" ^ show (fst s)) - (show args) - | _ -> show t - -let prob_to_string env prob = - match prob with - | TProb p -> - BU.format "\n%s:\t%s \n\t\t%s\n\t%s\n\t(reason:%s) (logical:%s)\n" //\twith guard %s\n\telement= %s\n" // (guard %s)\n\t\t\n\t\t\t%s\n\t\t" - [(BU.string_of_int p.pid); - (term_to_string p.lhs); - (rel_to_string p.relation); - (term_to_string p.rhs); - (match p.reason with | [] -> "" | r::_ -> r); - (show p.logical) - //(term_to_string p.logical_guard); - //(match p.element with None -> "none" | Some t -> term_to_string t) - (* (N.term_to_string env (fst p.logical_guard)); *) - (* (p.reason |> String.concat "\n\t\t\t") *)] - | CProb p -> - BU.format4 "\n%s:\t%s \n\t\t%s\n\t%s" - (BU.string_of_int p.pid) - (N.comp_to_string env p.lhs) - (rel_to_string p.relation) - (N.comp_to_string env p.rhs) - -let prob_to_string' (wl:worklist) (prob:prob) : string = - let env = p_env wl prob in - prob_to_string env prob - -let uvi_to_string env = function - | UNIV (u, t) -> - let x = if (Options.hide_uvar_nums()) then "?" else UF.univ_uvar_id u |> string_of_int in - BU.format2 "UNIV %s <- %s" x (show t) - - | TERM (u, t) -> - let x = if (Options.hide_uvar_nums()) then "?" else UF.uvar_id u.ctx_uvar_head |> string_of_int in - BU.format2 "TERM %s <- %s" x (N.term_to_string env t) -let uvis_to_string env uvis = FStar.Common.string_of_list (uvi_to_string env) uvis - -(* ------------------------------------------------*) -(* *) -(* ------------------------------------------------*) - - -(* ------------------------------------------------*) -(* Operations on worklists *) -(* ------------------------------------------------*) -let empty_worklist env = { - attempting=[]; - wl_deferred=empty; - wl_deferred_to_tac=empty; - ctr=0; - tcenv=env; - defer_ok=DeferAny; - smt_ok=true; - umax_heuristic_ok=true; - wl_implicits=empty; - repr_subcomp_allowed=false; - typeclass_variables = Setlike.empty(); -} - -let giveup wl (reason : lstring) prob = - if !dbg_Rel then - BU.print2 "Failed %s:\n%s\n" (Thunk.force reason) (prob_to_string' wl prob); - Failed (prob, reason) - -let giveup_lit wl (reason : string) prob = - giveup wl (mklstr (fun () -> reason)) prob - -(* ------------------------------------------------*) -(* *) -(* ------------------------------------------------*) - -let singleton wl prob smt_ok = {wl with attempting=[prob]; smt_ok = smt_ok} -let wl_of_guard env g = {empty_worklist env with attempting=List.map (fun (_, _, p) -> p) g} -let defer reason msg prob wl = {wl with wl_deferred= cons (wl.ctr, reason, msg, prob) wl.wl_deferred} -let defer_lit reason msg prob wl = defer reason (Thunk.mkv msg) prob wl -let attempt probs wl = - List.iter (def_check_prob "attempt") probs; - {wl with attempting=probs@wl.attempting} - -let mk_eq2 wl prob t1 t2 : term & worklist = - let env = p_env wl prob in - def_check_scoped t1.pos "mk_eq2.t1" env t1; - def_check_scoped t2.pos "mk_eq2.t2" env t2; - (* NS: Rather than introducing a new variable, it would be much preferable - to simply compute the type of t1 here. - Sadly, it seems to be way too expensive to call env.type_of here. - *) - // let t_type, u = U.type_u () in - // let binders = Env.all_binders env in - // let _, tt, wl = new_uvar "eq2" wl t1.pos env.gamma binders t_type (Allow_unresolved "eq2 type") None in - let tt, _ = env.typeof_well_typed_tot_or_gtot_term env t1 false in - let u = env.universe_of env tt in - U.mk_eq2 u tt t1 t2, wl - -let p_invert = function - | TProb p -> TProb <| invert p - | CProb p -> CProb <| invert p -let p_logical = function - | TProb p -> p.logical - | CProb p -> p.logical -let set_logical (b:bool) = function - | TProb p -> TProb {p with logical=b} - | CProb p -> CProb {p with logical=b} - -let is_top_level_prob p = p_reason p |> List.length = 1 -let next_pid = - let ctr = BU.mk_ref 0 in - fun () -> incr ctr; !ctr - -(* Creates a subproblem of [orig], in a context extended with [scope]. *) -let mk_problem wl scope orig lhs rel rhs elt reason = - let scope = - match elt with - | None -> scope - | Some x -> scope @ [S.mk_binder x] - in - let bs = (p_guard_uvar orig).ctx_uvar_binders @ scope in - let gamma = List.rev (List.map (fun b -> Binding_var b.binder_bv) scope) @ (p_guard_uvar orig).ctx_uvar_gamma in - let ctx_uvar, lg, wl = - new_uvar ("mk_problem: logical guard for " ^ reason) - wl - Range.dummyRange - gamma - bs - U.ktype0 - (Allow_untyped "logical guard") - None - in - let prob = - //logical guards are always squashed; - //their range is intentionally dummy - { - pid=next_pid(); - lhs=lhs; - relation=rel; - rhs=rhs; - element=elt; - logical_guard=lg; - logical_guard_uvar=ctx_uvar; - reason=reason::p_reason orig; - loc=p_loc orig; - rank=None; - logical=p_logical orig; - } - in - (prob, wl) - -let mk_t_problem wl scope orig lhs rel rhs elt reason = - def_check_prob (reason ^ ".mk_t.arg") orig; - let p, wl = mk_problem wl scope orig lhs rel rhs elt reason in - def_check_prob (reason ^ ".mk_t") (TProb p); - TProb p, wl - -let mk_c_problem wl scope orig lhs rel rhs elt reason = - def_check_prob (reason ^ ".mk_c.arg") orig; - let p, wl = mk_problem wl scope orig lhs rel rhs elt reason in - def_check_prob (reason ^ ".mk_c") (CProb p); - CProb p, wl - -let new_problem wl env lhs rel rhs (subject:option bv) loc reason = - let lg_ty = - match subject with - | None -> U.ktype0 - | Some x -> - let bs = [S.mk_binder x] in - U.arrow bs (S.mk_Total U.ktype0) - in - let ctx_uvar, lg, wl = - new_uvar ("new_problem: logical guard for " ^ reason) - ({wl with tcenv=env}) - loc - env.gamma - (Env.all_binders env) - lg_ty - (Allow_untyped "logical guard") - None - in - let lg = - match subject with - | None -> lg - | Some x -> S.mk_Tm_app lg [S.as_arg <| S.bv_to_name x] loc - in - let prob = - { - pid=next_pid(); - lhs=lhs; - relation=rel; - rhs=rhs; - element=subject; - logical_guard=lg; - logical_guard_uvar=ctx_uvar; - reason=[reason]; - loc=loc; - rank=None; - logical=false; (* use set_logical to set this *) - } in - prob, wl - -let problem_using_guard orig lhs rel rhs elt reason = - let p = { - pid=next_pid(); - lhs=lhs; - relation=rel; - rhs=rhs; - element=elt; - logical_guard=p_guard orig; - logical_guard_uvar=p_guard_uvar orig; - reason=reason::p_reason orig; - loc=p_loc orig; - rank=None; - logical = p_logical orig; - } in - def_check_prob reason (TProb p); - p - -let guard_on_element wl problem x phi : term = - match problem.element with - | None -> - let tcenv = p_env wl (TProb problem) in - let u = tcenv.universe_of tcenv x.sort in - U.mk_forall u x phi - | Some e -> Subst.subst [NT(x,S.bv_to_name e)] phi - -let explain wl d (s : lstring) = - if !dbg_ExplainRel || !dbg_Rel - then BU.format4 "(%s) Failed to solve the sub-problem\n%s\nWhich arose because:\n\t%s\nFailed because:%s\n" - (Range.string_of_range <| p_loc d) - (prob_to_string' wl d) - (p_reason d |> String.concat "\n\t>") - (Thunk.force s) - else let d = maybe_invert_p d in - let rel = match p_rel d with - | EQ -> "equal to" - | SUB -> "a subtype of" - | _ -> failwith "impossible" in - let lhs, rhs = match d with - | TProb tp -> Err.print_discrepancy (N.term_to_string (p_env wl d)) tp.lhs tp.rhs - | CProb cp -> Err.print_discrepancy (N.comp_to_string (p_env wl d)) cp.lhs cp.rhs in - BU.format3 "%s is not %s the expected type %s" lhs rel rhs - -(* ------------------------------------------------*) -(* *) -(* ------------------------------------------------*) - - -(* ------------------------------------------------*) -(* Instantiating unification variables *) -(* ------------------------------------------------*) - -let occurs (uk:ctx_uvar) t = - let uvars = - Free.uvars t - |> elems // Bad: order dependent - in - let occurs = - (uvars - |> BU.for_some (fun uv -> - UF.equiv uv.ctx_uvar_head uk.ctx_uvar_head)) - in - uvars, occurs - -let occurs_check (uk:ctx_uvar) t = - let uvars, occurs = occurs uk t in - let msg = - if not occurs then None - else Some (BU.format2 "occurs-check failed (%s occurs in %s)" - (show uk.ctx_uvar_head) - (show t)) in - uvars, not occurs, msg - -let occurs_full (uk:ctx_uvar) t = - let uvars = - Free.uvars_full t - |> elems // Bad: order dependent - in - let occurs = - (uvars - |> BU.for_some (fun uv -> - UF.equiv uv.ctx_uvar_head uk.ctx_uvar_head)) - in - occurs - -let set_uvar env u (should_check_opt:option S.should_check_uvar) t = - // Useful for debugging uvars setting bugs - // if !dbg_Rel - // then ( - // BU.print2 "Setting uvar %s to %s\n" - // (show u) - // (show t); - // match Unionfind.find u.ctx_uvar_head with - // | None -> () - // | Some t -> - // BU.print2 "Uvar already set to %s\n%s\n" - // (show t) - // (BU.stack_dump()); - // failwith "DIE" - // ); - - (match should_check_opt with - | None -> () - | Some should_check -> - UF.change_decoration u.ctx_uvar_head - ({UF.find_decoration u.ctx_uvar_head with uvar_decoration_should_check=should_check})); - - if Options.defensive () then ( - if snd (occurs u t) then - failwith "OCCURS BUG!" - ); - - U.set_uvar u.ctx_uvar_head t - -let commit (env:env_t) (uvis:list uvi) = uvis |> List.iter (function - | UNIV(u, t) -> - begin match t with - | U_unif u' -> UF.univ_union u u' - | _ -> UF.univ_change u t - end - | TERM(u, t) -> - def_check_scoped #(list bv) #term t.pos "commit" (List.map (fun b -> b.binder_bv) u.ctx_uvar_binders) t; - set_uvar env u None t - ) - -let find_term_uvar uv s = BU.find_map s (function - | UNIV _ -> None - | TERM(u, t) -> if UF.equiv uv u.ctx_uvar_head then Some t else None) - -let find_univ_uvar u s = BU.find_map s (function - | UNIV(u', t) -> if UF.univ_equiv u u' then Some t else None - | _ -> None) - -(* ------------------------------------------------*) -(* *) -(* ------------------------------------------------*) - - -(* ------------------------------------------------*) -(* *) -(* ------------------------------------------------*) -let sn' env t = SS.compress (N.normalize [Env.Beta; Env.Reify] env t) |> U.unlazy_emb -let sn env t = - Profiling.profile - (fun () -> - sn' env t) - (Some (Ident.string_of_lid (Env.current_module env))) - "FStar.TypeChecker.Rel.sn" -let norm_with_steps profiling_tag steps env t = - Profiling.profile - (fun () -> - N.normalize steps env t) - (Some (Ident.string_of_lid (Env.current_module env))) - profiling_tag - - -let should_strongly_reduce t = - let h, _ = t |> U.unascribe |> U.head_and_args in - match (SS.compress h).n with - | Tm_constant (FStar.Const.Const_reify _) -> true - | _ -> false - -let whnf env t = - let norm steps t = - t |> U.unmeta - |> N.normalize steps env - |> SS.compress - |> U.unlazy_emb in - - Profiling.profile - (fun () -> - let steps = - (if should_strongly_reduce t - then [Env.Exclude Env.Zeta; Env.UnfoldUntil delta_constant] - else [Env.Weak; Env.HNF]) // GM: an explanation of this bit would be good, I just retained it - @ [Env.Beta; Env.Reify; Env.Primops] - in - norm steps t) - (Some (Ident.string_of_lid (Env.current_module env))) - "FStar.TypeChecker.Rel.whnf" - -let norm_arg env t = sn env (fst t), snd t -let sn_binders env (binders:binders) = - binders |> List.map (fun b -> {b with binder_bv={b.binder_bv with sort=sn env b.binder_bv.sort} }) - -(* norm_univ wl u - Replace all unification variables in u with their solution in wl, if any - And normalize the result -*) -let norm_univ wl u = - let rec aux u = - let u = SS.compress_univ u in - match u with - | U_succ u -> - U_succ (aux u) - - | U_max us -> - U_max (List.map aux us) - - | _ -> u in - N.normalize_universe wl.tcenv (aux u) - -let normalize_refinement steps env t0 : term = - Profiling.profile - (fun () -> N.normalize_refinement steps env t0) - (Some (Ident.string_of_lid (Env.current_module env))) - "FStar.TypeChecker.Rel.normalize_refinement" - -let base_and_refinement_maybe_delta should_delta env t1 = - let norm_refinement env t = - let steps = - if should_delta - then [Env.Weak; Env.HNF; Env.UnfoldUntil delta_constant] - else [Env.Weak; Env.HNF] in - normalize_refinement steps env t - in - let rec aux norm t1 = - let t1 = U.unmeta t1 in - match t1.n with - | Tm_refine {b=x; phi} -> - if norm - then (x.sort, Some(x, phi)) - else (match norm_refinement env t1 with - | {n=Tm_refine {b=x; phi}} -> (x.sort, Some(x, phi)) - | tt -> failwith (BU.format2 "impossible: Got %s ... %s\n" - (show tt) - (tag_of tt)) - ) - - | Tm_lazy i -> aux norm (U.unfold_lazy i) - - | Tm_uinst _ - | Tm_fvar _ - | Tm_app _ -> - if norm - then (t1, None) - else let t1' = norm_refinement env t1 in - begin match (SS.compress t1').n with - | Tm_refine _ -> aux true t1' - | _ -> t1, None - end - - | Tm_type _ - | Tm_constant _ - | Tm_name _ - | Tm_bvar _ - | Tm_arrow _ - | Tm_abs _ - | Tm_quoted _ - | Tm_uvar _ - | Tm_let _ - | Tm_match _ -> (t1, None) - - | Tm_meta _ - | Tm_ascribed _ //NS: Why are the two previous cases excluded? Because of the whnf/unmeta - | Tm_delayed _ - | Tm_unknown -> failwith (BU.format2 "impossible (outer): Got %s ... %s\n" (show t1) (tag_of t1)) in - - aux false (whnf env t1) - -let base_and_refinement env t : term & option (bv & term) = - base_and_refinement_maybe_delta false env t - -let unrefine env t : term = - base_and_refinement env t |> fst - -let trivial_refinement t : bv & term = - S.null_bv t, U.t_true - -let as_refinement delta env t : bv & term = - let t_base, refinement = base_and_refinement_maybe_delta delta env t in - match refinement with - | None -> trivial_refinement t_base - | Some (x, phi) -> x, phi - -let force_refinement (t_base, refopt) : term = - let y, phi = match refopt with - | Some (y, phi) -> y, phi - | None -> trivial_refinement t_base in - mk (Tm_refine {b=y; phi}) t_base.pos - -(* ------------------------------------------------ *) -(* *) -(* ------------------------------------------------ *) - -(* ------------------------------------------------ *) -(* *) -(* ------------------------------------------------ *) - -let wl_to_string wl = - let probs_to_string (ps:list prob) = - List.map (prob_to_string' wl) ps |> String.concat "\n\t" - in - let cprobs_to_string (ps:clist prob) = - (* meh ... *) - CList.map (prob_to_string' wl) ps |> to_list |> String.concat "\n\t" - in - BU.format2 "{ attempting = [ %s ];\n\ - deferred = [ %s ] }\n" - (probs_to_string wl.attempting) - (cprobs_to_string (CList.map (fun (_, _, _, x) -> x) wl.wl_deferred)) - -instance showable_wl : showable worklist = { - show = wl_to_string; -} - -(* ------------------------------------------------ *) -(* *) -(* ------------------------------------------------ *) - -(* A flexible term: the full term, - * its unification variable at the head, - * and the arguments the uvar is applied to. *) -type flex_t = - | Flex of (term & ctx_uvar & args) - -let flex_reason (Flex (_, u, _)) = u.ctx_uvar_reason - -let flex_uvar (Flex (_, u, _)) = u - -let flex_uvar_has_meta_tac u = - match u.ctx_uvar_meta with - | Some (Ctx_uvar_meta_tac _) -> true - | _ -> false - -let flex_t_to_string (Flex (_, c, args)) = - BU.format2 "%s [%s]" (show c) (show args) - -let is_flex t = - let head, _args = U.head_and_args t in - match (SS.compress head).n with - | Tm_uvar _ -> true - | _ -> false - -let flex_uvar_head t = - let head, _args = U.head_and_args t in - match (SS.compress head).n with - | Tm_uvar (u, _) -> u - | _ -> failwith "Not a flex-uvar" - -(* ensure_no_uvar_subst: Make sure the uvar at the head of t0 is not - * affected by a the substitution in the Tm_uvar node. - * - * In the case that it is, first solve it to a new appropriate uvar - * without a substitution. This function returns t again, though it is - * unchanged (the changes only happen in the UF graph). - * - * The way we generate the new uvar is by making a new variable with - * that is "hoisted" and which we apply to the binders of the original - * uvar. There is an optimization in place to hoist as few binders as - * possible. - * - * Example: If we have ((x:a),(y:b),(z:c) |- ?u : ty)[y <- 42], we will - * make ?u' with x in its binders, abstracted over y and z: - * - * (x |- ?u') : b -> c -> ty - * - * (we keep x since it's unaffected by the substitution; z is not since - * it has y in scope) and then solve - * - * ?u <- (?u' y z) - * - * Which means the original term now compresses to ?u' 42 z. The flex - * problem we now return is - * - * ?u', [42 z] - * - * We also return early if the substitution is empty or if the uvar is - * totally unaffected by it. - * - * NB: This function only uses the environment for debugging flags, - * so it's safe to pass wl.tcenv. - *) -let ensure_no_uvar_subst env (t0:term) (wl:worklist) - : term & worklist - = (* Returns true iff the variable x is not affected by substitution s *) - let bv_not_affected_by (s:subst_ts) (x:bv) : bool = - let t_x = S.bv_to_name x in - let t_x' = SS.subst' s t_x in - match (SS.compress t_x').n with - | Tm_name y -> - S.bv_eq x y // Check if substituting returned the same variable - | _ -> false - in - let binding_not_affected_by (s:subst_ts) (b:binding) : bool = - match b with - | Binding_var x -> bv_not_affected_by s x - | _ -> true - in - let head, args = U.head_and_args t0 in - match (SS.compress head).n with - | Tm_uvar (uv, ([], _)) -> - (* No subst, nothing to do *) - t0, wl - - | Tm_uvar (uv, _) when List.isEmpty uv.ctx_uvar_binders -> - (* No binders in scope, also good *) - t0, wl - - | Tm_uvar (uv, s) -> - (* Obtain the maximum prefix of the binders that can remain as-is - * (gamma is a snoc list, so we want a suffix of it. *) - let gamma_aff, new_gamma = FStar.Common.max_suffix (binding_not_affected_by s) - uv.ctx_uvar_gamma - in - begin match gamma_aff with - | [] -> - (* Not affected by the substitution at all, do nothing *) - t0, wl - | _ -> - (* At least one variable is affected, make a new uvar *) - let dom_binders = Env.binders_of_bindings gamma_aff in - let v, t_v, wl = new_uvar (uv.ctx_uvar_reason ^ "; force delayed") - wl - t0.pos - new_gamma - (Env.binders_of_bindings new_gamma) - (U.arrow dom_binders (S.mk_Total (U.ctx_uvar_typ uv))) - (U.ctx_uvar_should_check uv) - uv.ctx_uvar_meta - in - - (* Solve the old variable *) - let args_sol = List.map U.arg_of_non_null_binder dom_binders in - let sol = S.mk_Tm_app t_v args_sol t0.pos in - if !dbg_Rel - then BU.print2 "ensure_no_uvar_subst solving %s with %s\n" - (show uv) - (show sol); - set_uvar env uv (Some Already_checked) sol; - - (* Make a term for the new uvar, applied to the substitutions of - * the abstracted arguments, plus all the original arguments. *) - let args_sol_s = List.map (fun (a, i) -> SS.subst' s a, i) args_sol in - let t = S.mk_Tm_app t_v (args_sol_s @ args) t0.pos in - t, wl - end - | _ -> - failwith (BU.format3 "ensure_no_uvar_subst: expected a uvar at the head (%s-%s-%s)" - (tag_of t0) - (tag_of head) - (tag_of (SS.compress head))) - -let no_free_uvars t = Setlike.is_empty (Free.uvars t) && Setlike.is_empty (Free.univs t) - -(* Deciding when it's okay to issue an SMT query for - * equating a term whose head symbol is `head` with another term - * - * NB: this function only uses env for checking delta_depths, - * so it's fine to use wl.tcenv. - *) -let rec may_relate_with_logical_guard env is_eq head = - match (SS.compress head).n with - | Tm_name _ - | Tm_match _ -> true - | Tm_fvar fv -> - (match Env.delta_depth_of_fv env fv with - | Delta_equational_at_level _ -> - true - | Delta_abstract _ -> - //these may be relatable via a logical theory - //which may provide **equations** among abstract symbols - //Note, this is specifically not applicable for subtyping queries: see issue #1359 - is_eq - | _ -> false) - | Tm_ascribed {tm=t} - | Tm_uinst (t, _) - | Tm_meta {tm=t} -> may_relate_with_logical_guard env is_eq t - | _ -> false - -let may_relate env prel head = may_relate_with_logical_guard env (EQ? prel) head - -(* Only call if ensure_no_uvar_subst was called on t before *) -let destruct_flex_t' t : flex_t = - let head, args = U.head_and_args t in - match (SS.compress head).n with - | Tm_uvar (uv, s) -> - Flex (t, uv, args) - | _ -> failwith "Not a flex-uvar" - -(* Destruct a term into its uvar head and arguments. The wl is only -used to track implicits. *) -let destruct_flex_t (t:term) wl : flex_t & worklist = - (* ensure_no_uvar_subst only uses the environment for debugging - * flags, so it's safe to pass wl.tcenv *) - let t, wl = ensure_no_uvar_subst wl.tcenv t wl in - (* If there's any substitution on the head of t, it must - * have been made trivial by the call above, so - * calling destruct_flex_t' is fine. *) - destruct_flex_t' t, wl - -(* ------------------------------------------------ *) -(* *) -(* ------------------------------------------------ *) - -let u_abs (k : typ) (ys : binders) (t : term) : term = - let (ys, t), (xs, c) = match (SS.compress k).n with - | Tm_arrow {bs; comp=c} -> - if List.length bs = List.length ys - then (ys, t), SS.open_comp bs c - else let ys', t, _ = U.abs_formals t in - (ys@ys', t), U.arrow_formals_comp k - | _ -> (ys, t), ([], S.mk_Total k) in - if List.length xs <> List.length ys - (* TODO : not putting any cflags here on the annotation... *) - then //The annotation is imprecise, due to a discrepancy in currying/eta-expansions etc.; - //causing a loss in precision for the SMT encoding - U.abs ys t (Some (U.mk_residual_comp PC.effect_Tot_lid None [])) - else let c = Subst.subst_comp (U.rename_binders xs ys) c in - U.abs ys t (Some (U.residual_comp_of_comp c)) - -let solve_prob' resolve_ok prob logical_guard uvis wl = - def_check_prob "solve_prob'" prob; - let phi = match logical_guard with - | None -> U.t_true - | Some phi -> phi in - let assign_solution xs uv phi = - if !dbg_Rel - then BU.print3 "Solving %s (%s) with formula %s\n" - (string_of_int (p_pid prob)) - (show uv) - (show phi); - let phi = U.abs xs phi (Some (U.residual_tot U.ktype0)) in - def_check_scoped (p_loc prob) ("solve_prob'.sol." ^ string_of_int (p_pid prob)) - (List.map (fun b -> b.binder_bv) <| p_scope prob) phi; - set_uvar wl.tcenv uv None phi - in - let uv = p_guard_uvar prob in - let fail () = - failwith (BU.format2 "Impossible: this instance %s has already been assigned a solution\n%s\n" - (show uv) - (show (p_guard prob))) - in - let args_as_binders args = - args |> - List.collect (fun (a, i) -> - match (SS.compress a).n with - | Tm_name x -> - let q, attrs = U.bqual_and_attrs_of_aqual i in - let pq, attrs = U.parse_positivity_attributes attrs in - [S.mk_binder_with_attrs x q pq attrs] - | _ -> - fail(); - []) - in - let wl = - let g = whnf (p_guard_env wl prob) (p_guard prob) in - if not (is_flex g) - then if resolve_ok - then wl - else (fail(); wl) - else let (Flex (_, uv, args), wl) = destruct_flex_t g wl in - assign_solution (args_as_binders args) uv phi; - wl - in - commit wl.tcenv uvis; - {wl with ctr=wl.ctr + 1} - -let extend_universe_solution pid sol wl = - if !dbg_Rel - then BU.print2 "Solving %s: with [%s]\n" (string_of_int pid) - (uvis_to_string wl.tcenv sol); - commit wl.tcenv sol; - {wl with ctr=wl.ctr+1} - -let solve_prob (prob : prob) (logical_guard : option term) (uvis : list uvi) (wl:worklist) : worklist = - def_check_prob "solve_prob.prob" prob; - BU.iter_opt logical_guard (def_check_term_scoped_in_prob "solve_prob.guard" prob); - if !dbg_Rel - then BU.print2 "Solving %s: with %s\n" (string_of_int <| p_pid prob) - (uvis_to_string wl.tcenv uvis); - solve_prob' false prob logical_guard uvis wl - -(* ------------------------------------------------ *) -(* *) -(* ------------------------------------------------ *) - - -(* ------------------------------------------------ *) -(* common ops on variables *) -(* ------------------------------------------------ *) - -let rec maximal_prefix (bs:binders) (bs':binders) : binders & (binders & binders) = - match bs, bs' with - | binder1::bs_tail, - ({binder_bv=b';binder_qual=i'})::bs'_tail -> - if S.bv_eq binder1.binder_bv b' - then let pfx, rest = maximal_prefix bs_tail bs'_tail in - binder1::pfx, rest - else [], (bs, bs') - | _ -> [], (bs, bs') - -let extend_gamma (g:gamma) (bs:binders) = - List.fold_left (fun g ({binder_bv=x}) -> Binding_var x::g) g bs - -let gamma_until (g:gamma) (bs:binders) = - match List.last_opt bs with - | None -> [] - | Some ({binder_bv=x}) -> - match BU.prefix_until (function Binding_var x' -> S.bv_eq x x' | _ -> false) g with - | None -> [] - | Some (_, bx, rest) -> bx::rest - -(* - * AR: 07/20: generalizing restrict - * - * Given G_s |- ?u_s bs : t_s and G_t |- ?u_t : t_t, this code restricts G_t to the - * maximal prefix of G_s and G_t, creating a new uvar maximal_prefix(G_s, G_t) |- ?u : t_t, - * and assigning ?u_t = ?u - * - * NS: 03/2022 Question: How do we know that t_t is well-formed in maximal_prefix(G_s, G_t)? - * - * However simply doing this does not allow the solution of ?u to mention the binders bs - * - * Instead, we filter bs that also appear in G_t but not in the maximal prefix and - * allow the solution of G_t to contain them - * - * (The solution of ?u_t is already allowed to contain the ones appearing in the maximal prefix) - * - * So the new uvar that's created is maximal_prefix(G_s, G_t) |- ?u : bs -> t_t - * and assigning ?u_t = ?u bs - * - * This comes in handy for the flex-rigid case, where the arguments of the flex are a pattern - *) -let restrict_ctx env (tgt:ctx_uvar) (bs:binders) (src:ctx_uvar) wl : worklist = - let pfx, _ = maximal_prefix tgt.ctx_uvar_binders src.ctx_uvar_binders in - let g = gamma_until src.ctx_uvar_gamma pfx in - - //t is the type at which new uvar ?u should be created - //f is a function that applied to the new uvar term should return the term that ?u_t should be solved to - let aux (t:typ) (f:term -> term) = - let _, src', wl = new_uvar ("restricted " ^ (show src.ctx_uvar_head)) wl - src.ctx_uvar_range g pfx t - (U.ctx_uvar_should_check src) - src.ctx_uvar_meta in - set_uvar env src (Some Already_checked) (f src'); - wl in - - let bs = bs |> List.filter (fun ({binder_bv=bv1}) -> - src.ctx_uvar_binders |> List.existsb (fun ({binder_bv=bv2}) -> S.bv_eq bv1 bv2) && //binder exists in G_t - not (pfx |> List.existsb (fun ({binder_bv=bv2}) -> S.bv_eq bv1 bv2))) in //but not in the maximal prefix - - if List.length bs = 0 then aux (U.ctx_uvar_typ src) (fun src' -> src') //no abstraction over bs - else begin - aux - (let t = U.ctx_uvar_typ src in t |> S.mk_Total |> U.arrow bs) //bs -> Tot t_t - (fun src' -> S.mk_Tm_app //?u bs - src' - (bs |> S.binders_to_names |> List.map S.as_arg) - src.ctx_uvar_range) - end - -let restrict_all_uvars env (tgt:ctx_uvar) (bs:binders) (sources:list ctx_uvar) wl : worklist = - match bs with - | [] -> - let ctx_tgt = binders_as_bv_set tgt.ctx_uvar_binders in - List.fold_right - (fun (src:ctx_uvar) wl -> - let ctx_src = binders_as_bv_set src.ctx_uvar_binders in - if subset ctx_src ctx_tgt - then wl // no need to restrict source, it's context is included in the context of the tgt - else restrict_ctx env tgt [] src wl) - sources - wl - - | _ -> - List.fold_right (restrict_ctx env tgt bs) sources wl - -let intersect_binders (g:gamma) (v1:binders) (v2:binders) : binders = - let as_set (v:binders) : RBSet.t bv = - v |> List.fold_left (fun out x -> add x.binder_bv out) (Setlike.empty ()) - in - let v1_set = as_set v1 in - let ctx_binders = - List.fold_left (fun out b -> match b with Binding_var x -> add x out | _ -> out) - (Setlike.empty ()) - g - in - let isect, _ = - v2 |> List.fold_left (fun (isect, isect_set) b -> - let x, imp = b.binder_bv, b.binder_qual in - if not <| mem x v1_set - then //definitely not in the intersection - isect, isect_set - else //maybe in the intersect, if its type is only dependent on prior elements in the telescope - let fvs = Free.names x.sort in - if subset fvs isect_set - then b::isect, add x isect_set - else isect, isect_set) - ([], ctx_binders) in - List.rev isect - -let binders_eq v1 v2 = - List.length v1 = List.length v2 - && List.forall2 (fun ({binder_bv=a}) ({binder_bv=b}) -> S.bv_eq a b) v1 v2 - -let name_exists_in_binders x bs = - BU.for_some (fun ({binder_bv=y}) -> S.bv_eq x y) bs - -let pat_vars env ctx args : option binders = - let rec aux seen args = - match args with - | [] -> Some (List.rev seen) - | (arg, i)::args -> - let hd = sn env arg in - match hd.n with - | Tm_name a -> - if name_exists_in_binders a seen - || name_exists_in_binders a ctx - then None - else let bq, attrs = U.bqual_and_attrs_of_aqual i in - let pq, attrs = U.parse_positivity_attributes attrs in - aux ((S.mk_binder_with_attrs a bq pq attrs)::seen) args - | _ -> None - in - aux [] args - -(* ------------------------------------------------ *) -(* *) -(* ------------------------------------------------ *) - -let string_of_match_result = function - | MisMatch (d1, d2) -> "MisMatch " ^ show (d1, d2) - | HeadMatch u -> "HeadMatch " ^ string_of_bool u - | FullMatch -> "FullMatch" - -instance showable_match_result = { show = string_of_match_result; } - -let head_match = function - | MisMatch(i, j) -> MisMatch(i, j) - | HeadMatch true -> HeadMatch true - | _ -> HeadMatch false - -let universe_has_max env u = - let u = N.normalize_universe env u in - match u with - | U_max _ -> true - | _ -> false - -let rec head_matches env t1 t2 : match_result = - let t1 = U.unmeta t1 in - let t2 = U.unmeta t2 in - if !dbg_RelDelta then ( - BU.print2 "head_matches %s %s\n" (show t1) (show t2); - BU.print2 " %s -- %s\n" (tag_of t1) (tag_of t2); - () - ); - match t1.n, t2.n with - | Tm_lazy ({lkind=Lazy_embedding _}), _ -> head_matches env (U.unlazy t1) t2 - | _, Tm_lazy({lkind=Lazy_embedding _}) -> head_matches env t1 (U.unlazy t2) - | Tm_lazy li1, Tm_lazy li2 -> - if li1.lkind =? li2.lkind - then HeadMatch false - else MisMatch(None, None) - - | Tm_name x, Tm_name y -> if S.bv_eq x y then FullMatch else MisMatch(None, None) - | Tm_fvar f, Tm_fvar g -> if S.fv_eq f g then FullMatch else MisMatch(Some (fv_delta_depth env f), Some (fv_delta_depth env g)) - | Tm_uinst (f, _), Tm_uinst(g, _) -> head_matches env f g |> head_match - | Tm_constant (FC.Const_reify _), Tm_constant (FC.Const_reify _) -> FullMatch - | Tm_constant (FC.Const_reify _), _ - | _, Tm_constant (FC.Const_reify _) -> HeadMatch true - | Tm_constant c, Tm_constant d -> if FC.eq_const c d then FullMatch else MisMatch(None, None) - - | Tm_uvar (uv, _), Tm_uvar (uv', _) -> if UF.equiv uv.ctx_uvar_head uv'.ctx_uvar_head then FullMatch else MisMatch(None, None) - - | Tm_refine {b=x}, Tm_refine {b=y} -> head_matches env x.sort y.sort |> head_match - - | Tm_refine {b=x}, _ -> head_matches env x.sort t2 |> head_match - | _, Tm_refine {b=x} -> head_matches env t1 x.sort |> head_match - - | Tm_type _, Tm_type _ - | Tm_arrow _, Tm_arrow _ -> HeadMatch false - - | Tm_app {hd=head}, Tm_app {hd=head'} -> head_matches env head head' |> head_match - | Tm_app {hd=head}, _ -> head_matches env head t2 |> head_match - | _, Tm_app {hd=head} -> head_matches env t1 head |> head_match - - | Tm_let _, Tm_let _ - | Tm_match _, Tm_match _ - | Tm_quoted _, Tm_quoted _ - | Tm_abs _, Tm_abs _ -> HeadMatch true - - | _ -> - (* GM: I am retaining this logic here. I think it is meant to disable - unfolding of possibly-equational terms. This probably deserves a rework now - with the .logical field. *) - let maybe_dd (t:term) : option delta_depth = - match (SS.compress t).n with - | Tm_unknown - | Tm_bvar _ - | Tm_name _ - | Tm_uvar _ - | Tm_let _ - | Tm_match _ -> None - | _ -> Some (delta_depth_of_term env t) - in - MisMatch (maybe_dd t1, maybe_dd t2) - -(* Does t1 head-match t2, after some delta steps? *) -let head_matches_delta env (logical:bool) smt_ok t1 t2 : (match_result & option (typ&typ)) = - let base_steps = - (if logical then [Env.DontUnfoldAttr [PC.tac_opaque_attr]] else []) @ - [Env.Primops; Env.Weak; Env.HNF] - in - let maybe_inline t = - let head = U.head_of (unrefine env t) in - if !dbg_RelDelta then - BU.print2 "Head of %s is %s\n" (show t) (show head); - match (U.un_uinst head).n with - | Tm_fvar fv -> - begin - match Env.lookup_definition - [Env.Unfold delta_constant; - Env.Eager_unfolding_only] - env - fv.fv_name.v - with - | None -> - if !dbg_RelDelta then - BU.print1 "No definition found for %s\n" (show head); - None - | Some _ -> - let basic_steps = - (if logical then [Env.DontUnfoldAttr [PC.tac_opaque_attr]] else []) @ - [Env.UnfoldUntil delta_constant; - Env.Weak; - Env.HNF; - Env.Primops; - Env.Beta; - Env.Eager_unfolding; - Env.Iota] - in - let steps = - if smt_ok then basic_steps - else Env.Exclude Env.Zeta::basic_steps - //NS: added this to prevent unifier looping - //see bug606.fst - //should we always disable Zeta here? - in - let t' = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.1" steps env t in - if TEQ.eq_tm env t t' = TEQ.Equal //if we didn't inline anything - then None - else let _ = if !dbg_RelDelta - then BU.print2 "Inlined %s to %s\n" - (show t) - (show t') in - Some t' - end - | _ -> None - in - let success d r t1 t2 = (r, (if d>0 then Some(t1, t2) else None)) in - let fail d r t1 t2 = (r, (if d>0 then Some(t1, t2) else None)) in - - (* - * AR: When we delta-unfold the terms below, it may happen that application of an fv with - * delta depth say 1 doesn't unfold because it is marked with strict_on_arguments - * To prevent looping in that case, we make sure that we have made progress - * in an unfolding call to the normalizer - * This made_progress function is checking that we have made progress in unfolding t to t' - * See #2184 - * - * GM: Updated 2024/05/18 to check for a discrepancy in syntactic equality, instead of - * eq_tm *not* returning Equal. We can have syntactically equal terms for which eq_tm - * returns unknown, so this code would falsely claim progress. For instance, Tm_let - * nodes are not handled by eq_tm and it always returns unknown. That should probably - * be improved, but in either case I think we want a syntactic check here (which is - * faster too) than eq_tm which is meant for decidable equality. - *) - let made_progress t t' = - let head = U.head_and_args t |> fst in - let head' = U.head_and_args t' |> fst in - not (U.term_eq head head') - in - - let rec aux retry n_delta t1 t2 = - let r = head_matches env t1 t2 in - if !dbg_RelDelta then - BU.print3 "head_matches (%s, %s) = %s\n" - (show t1) - (show t2) - (string_of_match_result r); - let reduce_one_and_try_again (d1:delta_depth) (d2:delta_depth) = - let d1_greater_than_d2 = Common.delta_depth_greater_than d1 d2 in - let t1, t2, made_progress = - if d1_greater_than_d2 - then let t1' = normalize_refinement (Env.UnfoldUntil d2 :: base_steps) env t1 in - t1', t2, made_progress t1 t1' - else let t2' = normalize_refinement (Env.UnfoldUntil d1 :: base_steps) env t2 in - t1, t2', made_progress t2 t2' in - if made_progress - then aux retry (n_delta + 1) t1 t2 - else fail n_delta r t1 t2 - in - - let reduce_both_and_try_again (d:delta_depth) (r:match_result) = - match Common.decr_delta_depth d with - | None -> fail n_delta r t1 t2 - | Some d -> - let t1' = normalize_refinement (Env.UnfoldUntil d :: base_steps) env t1 in - let t2' = normalize_refinement (Env.UnfoldUntil d :: base_steps) env t2 in - if made_progress t1 t1' && - made_progress t2 t2' - then aux retry (n_delta + 1) t1' t2' - else fail n_delta r t1 t2 - in - - match r with - | MisMatch (Some (Delta_equational_at_level i), Some (Delta_equational_at_level j)) when (i > 0 || j > 0) && i <> j -> - reduce_one_and_try_again (Delta_equational_at_level i) (Delta_equational_at_level j) - - | MisMatch(Some (Delta_equational_at_level _), _) - | MisMatch(_, Some (Delta_equational_at_level _)) -> - if not retry then fail n_delta r t1 t2 - else begin match maybe_inline t1, maybe_inline t2 with - | None, None -> fail n_delta r t1 t2 - | Some t1, None -> aux false (n_delta + 1) t1 t2 - | None, Some t2 -> aux false (n_delta + 1) t1 t2 - | Some t1, Some t2 -> aux false (n_delta + 1) t1 t2 - end - - | MisMatch(Some d1, Some d2) when (d1=d2) -> //incompatible - reduce_both_and_try_again d1 r - - | MisMatch(Some d1, Some d2) -> //these may be related after some delta steps - reduce_one_and_try_again d1 d2 - - | MisMatch _ -> - fail n_delta r t1 t2 - - | _ -> - success n_delta r t1 t2 in - let r = aux true 0 t1 t2 in - if !dbg_RelDelta then - BU.print3 "head_matches_delta (%s, %s) = %s\n" - (show t1) (show t2) (show r); - r - -let kind_type (binders:binders) (r:Range.range) = - U.type_u() |> fst - - -(* ----------------------------------------------------- *) -(* Ranking problems for the order in which to solve them *) -(* ----------------------------------------------------- *) -let rank_t_num = function - | Rigid_rigid -> 0 - | Flex_rigid_eq -> 1 - | Flex_flex_pattern_eq -> 2 - | Flex_rigid -> 3 - | Rigid_flex -> 4 - | Flex_flex -> 5 -let rank_leq r1 r2 = rank_t_num r1 <= rank_t_num r2 -let rank_less_than r1 r2 = - r1 <> r2 && - rank_t_num r1 <= rank_t_num r2 -let compress_tprob wl p = - let env = p_env wl (TProb p) in - {p with lhs=whnf env p.lhs; rhs=whnf env p.rhs} - -let compress_cprob wl p = - let whnf_c env c = - match c.n with - | Total ty -> S.mk_Total (whnf env ty) - | _ -> c - in - let env = p_env wl (CProb p) in - {p with lhs = whnf_c env p.lhs; rhs = whnf_c env p.rhs} - -let compress_prob wl p = - match p with - | TProb p -> compress_tprob wl p |> TProb - | CProb p -> compress_cprob wl p |> CProb - -let rank wl pr : rank_t //the rank - & prob //the input problem, pre-processed a bit (the wl is needed for the pre-processing) - = - let prob = compress_prob wl pr |> maybe_invert_p in - match prob with - | TProb tp -> - let lh, lhs_args = U.head_and_args tp.lhs in - let rh, rhs_args = U.head_and_args tp.rhs in - let rank, tp = - match lh.n, rh.n with - | Tm_uvar _, Tm_uvar _ -> - begin - match lhs_args, rhs_args with - | [], [] when tp.relation=EQ -> - Flex_flex_pattern_eq, tp - | _ -> Flex_flex, tp - end - - | Tm_uvar _, _ - | _, Tm_uvar _ when tp.relation=EQ -> - Flex_rigid_eq, tp - - | Tm_uvar _, Tm_arrow _ - | Tm_uvar _, Tm_type _ - | Tm_type _, Tm_uvar _ -> - //this case is so common, that even though we could delay, it is almost always ok to solve it immediately as an equality - //besides, in the case of arrows, if we delay it, the arity of various terms built by the unifier goes awry - //so, don't delay! - Flex_rigid_eq, {tp with relation=EQ} - - | _, Tm_uvar _ -> - Rigid_flex, tp - - | Tm_uvar _, _ -> - Flex_rigid, tp - - | _, Tm_uvar _ -> - Rigid_flex, tp - - | _, _ -> - Rigid_rigid, tp - in - rank, {tp with rank=Some rank} |> TProb - - | CProb cp -> - Rigid_rigid, {cp with rank=Some Rigid_rigid} |> CProb - -let next_prob wl : option (prob & list prob & rank_t) = - //a problem with the lowest rank, or a problem whose rank <= flex_rigid_eq, if any - //all the other problems in wl - //the rank of the first problem, or the minimum rank in the wl - let rec aux (min_rank, min, out) probs = - match probs with - | [] -> - begin - match min, min_rank with - | Some p, Some r -> Some (p, out, r) - | _ -> None - end - | hd::tl -> - let rank, hd = rank wl hd in - if rank_leq rank Flex_rigid_eq - then match min with - | None -> Some (hd, out@tl, rank) - | Some m -> Some (hd, out@m::tl, rank) - else if min_rank = None - || rank_less_than rank (Option.get min_rank) - then match min with - | None -> aux (Some rank, Some hd, out) tl - | Some m -> aux (Some rank, Some hd, m::out) tl - else aux (min_rank, min, hd::out) tl - in - aux (None, None, []) wl.attempting - -let flex_prob_closing tcenv (bs:binders) (p:prob) = - let flex_will_be_closed t = - let hd, _ = U.head_and_args t in - match (SS.compress hd).n with - | Tm_uvar(u, _) -> - u.ctx_uvar_binders |> BU.for_some (fun ({binder_bv=y}) -> - bs |> BU.for_some (fun ({binder_bv=x}) -> S.bv_eq x y)) - | _ -> false - in - let wl = empty_worklist tcenv in - let r, p = rank wl p in - match p with - | CProb _ -> - true - | TProb p -> - match r with - | Rigid_rigid - | Flex_rigid_eq - | Flex_flex_pattern_eq -> - true - | Flex_rigid -> - flex_will_be_closed p.lhs - | Rigid_flex -> - flex_will_be_closed p.rhs - | Flex_flex -> - p.relation=EQ - && - (flex_will_be_closed p.lhs - || flex_will_be_closed p.rhs) - -(* ----------------------------------------------------- *) -(* Solving universe equalities *) -(* ----------------------------------------------------- *) -type univ_eq_sol = - | UDeferred of worklist - | USolved of worklist - | UFailed of lstring - -let ufailed_simple (s:string) : univ_eq_sol = - UFailed (Thunk.mkv s) - -let ufailed_thunk (s: unit -> string) : univ_eq_sol = - UFailed (mklstr s) - - -let rec really_solve_universe_eq pid_orig wl u1 u2 = - let u1 = N.normalize_universe wl.tcenv u1 in - let u2 = N.normalize_universe wl.tcenv u2 in - let rec occurs_univ v1 u = match u with - | U_max us -> - us |> BU.for_some (fun u -> - let k, _ = U.univ_kernel u in - match k with - | U_unif v2 -> UF.univ_equiv v1 v2 - | _ -> false) - | _ -> occurs_univ v1 (U_max [u]) in - - let rec filter_out_common_univs (u1:list universe) (u2:list universe) :(list universe & list universe) = - let common_elts = u1 |> List.fold_left (fun uvs uv1 -> if u2 |> List.existsML (fun uv2 -> U.eq_univs uv1 uv2) then uv1::uvs else uvs) [] in - let filter = List.filter (fun u -> not (common_elts |> List.existsML (fun u' -> U.eq_univs u u'))) in - filter u1, filter u2 - in - - let try_umax_components u1 u2 msg = - if not wl.umax_heuristic_ok - then ufailed_simple "Unable to unify universe terms with umax" - else - match u1, u2 with - | U_max us1, U_max us2 -> - begin - //filter out common universes in us1 and us2 - //this allows more cases to unify, e.g. us1 = [uvar; un] and us2=[un; un'] - //with just structural comparison, this would fail to unify, but after filtering away un, we can unify uvar with un' - let us1, us2 = filter_out_common_univs us1 us2 in - if List.length us1 = List.length us2 //go for a structural match - then let rec aux wl us1 us2 = match us1, us2 with - | u1::us1, u2::us2 -> - begin match really_solve_universe_eq pid_orig wl u1 u2 with - | USolved wl -> - aux wl us1 us2 - | failed -> failed - end - | _ -> USolved wl in - aux wl us1 us2 - else ufailed_thunk - (fun () -> BU.format2 "Unable to unify universes: %s and %s" - (show u1) - (show u2)) - end - | U_max us, u' - | u', U_max us -> - let rec aux wl us = match us with - | [] -> USolved wl - | u::us -> - begin match really_solve_universe_eq pid_orig wl u u' with - | USolved wl -> - aux wl us - | failed -> failed - end - in aux wl us - - | _ -> - ufailed_thunk (fun () -> - BU.format3 "Unable to unify universes: %s and %s (%s)" - (show u1) - (show u2) msg) in - - match u1, u2 with - | U_bvar _, _ - | U_unknown, _ - | _, U_bvar _ - | _, U_unknown -> failwith (BU.format2 "Impossible: found an de Bruijn universe variable or unknown universe: %s, %s" - (show u1) - (show u2)) - - | U_name x, U_name y -> - if (string_of_id x) = (string_of_id y) - then USolved wl - else ufailed_simple "Incompatible universes" - - | U_zero, U_zero -> - USolved wl - - | U_succ u1, U_succ u2 -> - really_solve_universe_eq pid_orig wl u1 u2 - - | U_unif v1, U_unif v2 -> - if UF.univ_equiv v1 v2 - then USolved wl - else let wl = extend_universe_solution pid_orig [UNIV(v1, u2)] wl in - USolved wl - - | U_unif v1, u - | u, U_unif v1 -> - let u = norm_univ wl u in - if occurs_univ v1 u - then try_umax_components u1 u2 - (BU.format2 "Failed occurs check: %s occurs in %s" (show (U_unif v1)) (show u)) - else USolved (extend_universe_solution pid_orig [UNIV(v1, u)] wl) - - | U_max _, _ - | _, U_max _ -> - if wl.defer_ok = DeferAny - then UDeferred wl - else let u1 = norm_univ wl u1 in - let u2 = norm_univ wl u2 in - if U.eq_univs u1 u2 - then USolved wl - else try_umax_components u1 u2 "" - - | U_succ _, U_zero - | U_succ _, U_name _ - | U_zero, U_succ _ - | U_zero, U_name _ - | U_name _, U_succ _ - | U_name _, U_zero -> - ufailed_simple "Incompatible universes" - -let solve_universe_eq orig wl u1 u2 = - if wl.tcenv.lax_universes - then USolved wl - else really_solve_universe_eq orig wl u1 u2 - -(* This balances two lists. Given (xs, f) (ys, g), it will - * take a maximal same-length prefix from each list, getting - * (xs1, xs2) and (ys1, ys2) / where length xs1 == length xs2 (and ys1 = [] \/ ys2 = []) - * and then return - * (xs1, f xs2), (ys1, g ys2) - * - * We could find the minimum of their lengths, split, and apply, but this is faster. - *) -let match_num_binders (bc1: (list 'a & (list 'a -> 'b))) - (bc2: (list 'a & (list 'a -> 'b))) - : (list 'a & 'b) & (list 'a & 'b) = - let (bs1, mk_cod1) = bc1 in - let (bs2, mk_cod2) = bc2 in - let rec aux (bs1 : list 'a) (bs2 : list 'a) : (list 'a & 'b) & (list 'a & 'b) = - match bs1, bs2 with - | x::xs, y::ys -> - let ((xs, xr), (ys, yr)) = aux xs ys in - ((x::xs, xr), (y::ys, yr)) - | xs, ys -> // at least one empty - (([], mk_cod1 xs), ([], mk_cod2 ys)) - in - aux bs1 bs2 - -let guard_of_prob (wl:worklist) (problem:tprob) (t1 : term) (t2 : term) : term & worklist = - def_check_prob "guard_of_prob" (TProb problem); - let env = p_env wl (TProb problem) in - let has_type_guard t1 t2 = - match problem.element with - | Some t -> - U.mk_has_type t1 (S.bv_to_name t) t2 - | None -> - let x = S.new_bv None t1 in - def_check_scoped t1.pos "guard_of_prob.universe_of" env t1; - let u_x = env.universe_of env t1 in - U.mk_forall u_x x (U.mk_has_type t1 (S.bv_to_name x) t2) - in - match problem.relation with - | EQ -> mk_eq2 wl (TProb problem) t1 t2 - | SUB -> has_type_guard t1 t2, wl - | SUBINV -> has_type_guard t2 t1, wl - -let is_flex_pat = function - | Flex (_, _, []) -> true - | _ -> false - -(** If the head uvar of the flex term is tagged with a `Ctx_uvar_meta_attr a` - and if a term tagged with attribute `a` is in scope, - then this problem should be deferred to a tactic *) -let should_defer_flex_to_user_tac (wl:worklist) (f:flex_t) = - let (Flex (_, u, _)) = f in - let b = DeferredImplicits.should_defer_uvar_to_user_tac wl.tcenv u in - - if !dbg_ResolveImplicitsHook then - BU.print3 "Rel.should_defer_flex_to_user_tac for %s returning %s (env.enable_defer_to_tac: %s)\n" - (show u) (show b) (show wl.tcenv.enable_defer_to_tac); - - b - -(* : - Given a term (?u_(bs;t) e1..en) - returns None in case the arity of the type t is less than n - otherwise returns Some (x1 ... xn) - where if ei is a variable distinct from bs and all the ej - then xi = ei - else xi is a fresh variable - *) -let quasi_pattern env (f:flex_t) : option (binders & typ) = - let (Flex (_, ctx_uvar, args)) = f in - let t_hd = U.ctx_uvar_typ ctx_uvar in - let ctx = ctx_uvar.ctx_uvar_binders in - let name_exists_in x bs = - BU.for_some (fun ({binder_bv=y}) -> S.bv_eq x y) bs - in - let rec aux pat_binders formals t_res args = - match formals, args with - | [], [] - | _, [] -> - Some (List.rev pat_binders, U.arrow formals (S.mk_Total t_res)) - - | fml::formals, (a, a_imp)::args -> - begin - let formal, formal_imp = fml.binder_bv, fml.binder_qual in - match (SS.compress a).n with - | Tm_name x -> - if name_exists_in x ctx - || name_exists_in x pat_binders - then //we already have x - //so don't include it in the quasi-pattern - aux (fml :: pat_binders) formals t_res args - else let x = {x with sort=formal.sort} in - let subst = [NT(formal, S.bv_to_name x)] in - let formals = SS.subst_binders subst formals in - let t_res = SS.subst subst t_res in - let q, _ = U.bqual_and_attrs_of_aqual a_imp in - aux ((S.mk_binder_with_attrs - ({x with sort=formal.sort}) - q - fml.binder_positivity - fml.binder_attrs) :: pat_binders) formals t_res args - | _ -> //it's not a name, so it can't be included in the patterns - aux (fml :: pat_binders) formals t_res args - end - - | [], args -> - let more_formals, t_res = U.arrow_formals (N.unfold_whnf env t_res) in - begin - match more_formals with - | [] -> None //seems ill-typed at this point - | _ -> aux pat_binders more_formals t_res args - end - in - match args with - | [] -> Some ([], t_hd) //this really a pattern, not a quasi_pattern - | _ -> - let formals, t_res = U.arrow_formals t_hd in - aux [] formals t_res args - -let run_meta_arg_tac (env:env_t) (ctx_u:ctx_uvar) : term = - match ctx_u.ctx_uvar_meta with - | Some (Ctx_uvar_meta_tac tau) -> - let env = { env with gamma = ctx_u.ctx_uvar_gamma } in - if !dbg_Tac then - BU.print1 "Running tactic for meta-arg %s\n" (show ctx_u); - Errors.with_ctx "Running tactic for meta-arg" - (fun () -> env.synth_hook env (U.ctx_uvar_typ ctx_u) tau) - | _ -> - failwith "run_meta_arg_tac must have been called with a uvar that has a meta tac" - -let simplify_vc full_norm_allowed env t = - if !dbg_Simplification then - BU.print1 "Simplifying guard %s\n" (show t); - let steps = [Env.Beta; - Env.Eager_unfolding; - Env.Simplify; - Env.Primops; - Env.Exclude Env.Zeta] in - let steps = if full_norm_allowed then steps else Env.NoFullNorm::steps in - let t' = norm_with_steps "FStar.TypeChecker.Rel.simplify_vc" steps env t in - if !dbg_Simplification then - BU.print1 "Simplified guard to %s\n" (show t'); - t' - -let __simplify_guard full_norm_allowed env g = match g.guard_f with - | Trivial -> g - | NonTrivial f -> - let f = simplify_vc full_norm_allowed env f in - let f = check_trivial f in - { g with guard_f = f} - -let simplify_guard env g = match g.guard_f with - | Trivial -> g - | NonTrivial f -> - let f = simplify_vc false env f in - let f = check_trivial f in - { g with guard_f = f} - -let simplify_guard_full_norm env g = match g.guard_f with - | Trivial -> g - | NonTrivial f -> - let f = simplify_vc true env f in - let f = check_trivial f in - { g with guard_f = f} - -// -// Apply substitutive indexed effects subcomp for an effect M -// -// bs: (opened) binders in the subcomp type -// subcomp_c: the computation type in the subcomp type (opened with bs) -// ct1 ct2: the two input computation types, both in M -// sub_prob: a function to create and add subproblems to the worklist -// num_effect_params: number of effect parameters in M -// wl: worklist -// subcomp_name and r1: for debugging purposes -// -// returns the (subcomp guard, new sub problems, worklist) -// -let apply_substitutive_indexed_subcomp (env:Env.env) - (k:S.indexed_effect_combinator_kind) - (bs:binders) - (subcomp_c:comp) - (ct1:comp_typ) (ct2:comp_typ) - (sub_prob:worklist -> term -> rel -> term -> string -> prob & worklist) - (num_effect_params:int) - (wl:worklist) - (subcomp_name:string) - (r1:Range.range) - - : typ & list prob & worklist = - - // - // We will collect the substitutions in subst, - // bs will be the remaining binders (that are not in subst yet) - // - - // first the a:Type binder - let bs, subst = - let a_b::bs = bs in - bs, - [NT (a_b.binder_bv, ct2.result_typ)] in - - // - // If the effect has effect parameters: - // - peel those arguments off of ct1 and ct2, - // - add subproblems for their equality to the worklist - // - add substitutions for corresponding binders - // - let bs, subst, args1, args2, eff_params_sub_probs, wl = - if num_effect_params = 0 - then bs, subst, ct1.effect_args, ct2.effect_args, [], wl - else let split (l:list 'a) = List.splitAt num_effect_params l in - let eff_params_bs, bs = split bs in - let param_args1, args1 = split ct1.effect_args in - let param_args2, args2 = split ct2.effect_args in - - let probs, wl = List.fold_left2 (fun (ps, wl) (t1, _) (t2, _) -> - let p, wl = sub_prob wl t1 EQ t2 "effect params subcomp" in - ps@[p], wl) ([], wl) param_args1 param_args2 in - let param_subst = List.map2 (fun b (arg, _) -> - NT (b.binder_bv, arg)) eff_params_bs param_args1 in - bs, subst@param_subst, args1, args2, probs, wl in - - // add substitutions for the f computation - let bs, subst = - let f_bs, bs = List.splitAt (List.length args1) bs in - let f_substs = List.map2 (fun f_b (arg, _) -> NT (f_b.binder_bv, arg)) f_bs args1 in - bs, - subst@f_substs in - - // add substitutions for the g computation - let bs, subst, f_g_args_eq_sub_probs, wl = - if Substitutive_combinator? k - then begin - let g_bs, bs = List.splitAt (List.length args2) bs in - let g_substs = List.map2 (fun g_b (arg, _) -> NT (g_b.binder_bv, arg)) g_bs args2 in - bs, - subst@g_substs, - [], - wl - end - else if Substitutive_invariant_combinator? k - then begin - let probs, wl = List.fold_left2 (fun (ps, wl) (t1, _) (t2, _) -> - let p, wl = sub_prob wl t1 EQ t2 "substitutive inv subcomp args" in - ps@[p], wl) ([], wl) args1 args2 in - bs, subst, probs, wl - end - else failwith "Impossible (rel.apply_substitutive_indexed_subcomp unexpected k" in - - // peel off the f:repr a is binder from bs - let bs = List.splitAt (List.length bs - 1) bs |> fst in - - // for the binders in bs, create uvars, and add their substitutions - let subst, wl = - List.fold_left (fun (ss, wl) b -> - let [uv_t], g = Env.uvars_for_binders env [b] ss - (fun b -> - if !dbg_LayeredEffectsApp - then BU.format3 "implicit var for additional binder %s in subcomp %s at %s" - (show b) - subcomp_name - (Range.string_of_range r1) - else "apply_substitutive_indexed_subcomp") r1 in - ss@[NT (b.binder_bv, uv_t)], - {wl with wl_implicits=g.implicits ++ wl.wl_implicits}) (subst, wl) bs in - - // apply the substitutions to subcomp_c, - // and get the precondition from the PURE wp - let subcomp_ct = subcomp_c |> SS.subst_comp subst |> Env.comp_to_comp_typ env in - - let fml = - let u, wp = List.hd subcomp_ct.comp_univs, fst (List.hd subcomp_ct.effect_args) in - Env.pure_precondition_for_trivial_post env u subcomp_ct.result_typ wp Range.dummyRange in - - fml, - eff_params_sub_probs@f_g_args_eq_sub_probs, - wl - -// -// Apply ad-hoc indexed effects subcomp for an effect M -// -// bs: (opened) binders in the subcomp type -// subcomp_c: the computation type in the subcomp type (opened with bs) -// ct1 ct2: the two input computation types, both in M -// sub_prob: a function to create and add subproblems to the worklist -// wl: worklist -// subcomp_name and r1: for debugging purposes -// -// returns the (subcomp guard, new sub problems, worklist) -// -let apply_ad_hoc_indexed_subcomp (env:Env.env) - (bs:binders) - (subcomp_c:comp) - (ct1:comp_typ) (ct2:comp_typ) - (sub_prob:worklist -> term -> rel -> term -> string -> prob & worklist) - (wl:worklist) - (subcomp_name:string) - (r1:Range.range) - - : typ & list prob & worklist = - - let stronger_t_shape_error s = BU.format2 - "Unexpected shape of stronger for %s, reason: %s" - (Ident.string_of_lid ct2.effect_name) s in - - let a_b, rest_bs, f_b = - if List.length bs >= 2 - then let a_b::bs = bs in - let rest_bs, f_b = - bs |> List.splitAt (List.length bs - 1) - |> (fun (l1, l2) -> l1, List.hd l2) in - a_b, rest_bs, f_b - else raise_error r1 Errors.Fatal_UnexpectedExpressionType (stronger_t_shape_error "not an arrow or not enough binders") in - - let rest_bs_uvars, g_uvars = - Env.uvars_for_binders env rest_bs - [NT (a_b.binder_bv, ct2.result_typ)] - (fun b -> - if !dbg_LayeredEffectsApp - then BU.format3 "implicit for binder %s in subcomp %s at %s" - (show b) - subcomp_name - (Range.string_of_range r1) - else "apply_ad_hoc_indexed_subcomp") r1 in - - let wl = { wl with wl_implicits = g_uvars.implicits ++ wl.wl_implicits } in - - let substs = - List.map2 (fun b t -> NT (b.binder_bv, t)) - (a_b::rest_bs) (ct2.result_typ::rest_bs_uvars) in - - let f_sub_probs, wl = - let f_sort_is = - U.effect_indices_from_repr - f_b.binder_bv.sort - (Env.is_layered_effect env ct1.effect_name) - r1 (stronger_t_shape_error "type of f is not a repr type") - |> List.map (SS.subst substs) in - - List.fold_left2 (fun (ps, wl) f_sort_i c1_i -> - if !dbg_LayeredEffectsApp - then BU.print3 "Layered Effects (%s) %s = %s\n" subcomp_name - (show f_sort_i) (show c1_i); - let p, wl = sub_prob wl f_sort_i EQ c1_i "indices of c1" in - ps@[p], wl - ) ([], wl) f_sort_is (ct1.effect_args |> List.map fst) in - - let subcomp_ct = subcomp_c |> SS.subst_comp substs |> Env.comp_to_comp_typ env in - - let g_sub_probs, wl = - let g_sort_is = - U.effect_indices_from_repr - subcomp_ct.result_typ - (Env.is_layered_effect env ct2.effect_name) - r1 (stronger_t_shape_error "subcomp return type is not a repr") in - - List.fold_left2 (fun (ps, wl) g_sort_i c2_i -> - if !dbg_LayeredEffectsApp - then BU.print3 "Layered Effects (%s) %s = %s\n" subcomp_name - (show g_sort_i) (show c2_i); - let p, wl = sub_prob wl g_sort_i EQ c2_i "indices of c2" in - ps@[p], wl - ) ([], wl) g_sort_is (ct2.effect_args |> List.map fst) in - - let fml = - let u, wp = List.hd subcomp_ct.comp_univs, fst (List.hd subcomp_ct.effect_args) in - Env.pure_precondition_for_trivial_post env u subcomp_ct.result_typ wp Range.dummyRange in - - fml, - f_sub_probs@g_sub_probs, - wl - -let has_typeclass_constraint (u:ctx_uvar) (wl:worklist) - : bool - = wl.typeclass_variables |> for_any (fun v -> UF.equiv v.ctx_uvar_head u.ctx_uvar_head) - -(* This function returns true for those lazykinds that -are "complete" in the sense that unfolding them does not -lose any information. For instance, embedded universes -are complete, since we embed them as applications of pack over a view, -and checking equality of such terms is equivalent to checking equality -of the views. Embedded proofstates are definitely not. - -This is probably not the place for this function though. *) -let lazy_complete_repr (k:lazy_kind) : bool = - match k with - | Lazy_bv - | Lazy_namedv - | Lazy_binder - | Lazy_letbinding - | Lazy_fvar - | Lazy_comp - | Lazy_sigelt - | Lazy_universe -> true - | _ -> false - -let has_free_uvars (t:term) : bool = - not (Setlike.is_empty (Free.uvars_uncached t)) - -let env_has_free_uvars (e:env_t) : bool = - List.existsb (fun b -> has_free_uvars b.binder_bv.sort) (Env.all_binders e) - -let gamma_has_free_uvars (g:list binding) : bool = - List.existsb (function Binding_var bv -> has_free_uvars bv.sort - | _ -> false) g - -type reveal_hide_t = - | Hide of (universe & typ & term) - | Reveal of (universe & typ & term) - -(******************************************************************************************************) -(* Main solving algorithm begins here *) -(******************************************************************************************************) -let rec solve (probs :worklist) : solution = -// printfn "Solving TODO:\n%s;;" (List.map prob_to_string probs.attempting |> String.concat "\n\t"); - if !dbg_Rel - then BU.print1 "solve:\n\t%s\n" (wl_to_string probs); - if !dbg_ImplicitTrace then - BU.print1 "solve: wl_implicits = %s\n" (show probs.wl_implicits); - - match next_prob probs with - | Some (hd, tl, rank) -> - let probs = {probs with attempting=tl} in - def_check_prob "solve,hd" hd; - begin match hd with - | CProb cp -> - solve_c (maybe_invert cp) probs - - | TProb tp -> - if BU.physical_equality tp.lhs tp.rhs then solve (solve_prob hd None [] probs) else - let is_expand_uvar (t:term) : bool = - match (SS.compress t).n with - | Tm_uvar (ctx_u, _) -> (UF.find_decoration ctx_u.ctx_uvar_head).uvar_decoration_should_unrefine - | _ -> false - in - let maybe_expand (tp:tprob) : tprob = - if Options.Ext.get "__unrefine" <> "" && tp.relation = SUB && is_expand_uvar tp.rhs - then - let lhs = tp.lhs in - let lhs_norm = N.unfold_whnf' [Env.DontUnfoldAttr [PC.do_not_unrefine_attr]] (p_env probs hd) lhs in - if Tm_refine? (SS.compress lhs_norm).n then - (* It is indeed a refinement, normalize again to remove them. *) - let lhs' = N.unfold_whnf' [Env.DontUnfoldAttr [PC.do_not_unrefine_attr]; Env.Unrefine] (p_env probs hd) lhs_norm in - if !dbg_Rel then - BU.print3 "GGG widening uvar %s! RHS %s ~> %s\n" - (show tp.rhs) (show lhs) (show lhs'); - { tp with lhs = lhs' } - else - tp - else tp - in - - let tp = maybe_expand tp in - - if rank=Rigid_rigid - || (tp.relation = EQ && rank <> Flex_flex) - then solve_t' tp probs - else if probs.defer_ok = DeferAny - then maybe_defer_to_user_tac tp "deferring flex_rigid or flex_flex subtyping" probs - else if rank=Flex_flex - then solve_t' ({tp with relation=EQ}) probs //turn flex_flex subtyping into flex_flex eq - else solve_rigid_flex_or_flex_rigid_subtyping rank tp probs - end - - | None -> - begin - match view probs.wl_deferred with - | VNil -> - Success (empty, as_deferred probs.wl_deferred_to_tac, probs.wl_implicits) //Yay ... done! - - | VCons _ _ -> - let attempt, rest = probs.wl_deferred |> CList.partition (fun (c, _, _, _) -> c < probs.ctr) in - match view attempt with - | VNil -> //can't solve yet; defer the rest - Success(as_deferred probs.wl_deferred, - as_deferred probs.wl_deferred_to_tac, - probs.wl_implicits) - - | _ -> - solve ({probs with attempting=attempt |> to_list |> List.map (fun (_, _, _, y) -> y); wl_deferred=rest}) - end - -and solve_one_universe_eq (orig:prob) (u1:universe) (u2:universe) (wl:worklist) : solution = - match solve_universe_eq (p_pid orig) wl u1 u2 with - | USolved wl -> - solve (solve_prob orig None [] wl) - - | UFailed msg -> - giveup wl msg orig - - | UDeferred wl -> - solve (defer_lit Deferred_univ_constraint "" orig wl) - -and solve_maybe_uinsts (orig:prob) (t1:term) (t2:term) (wl:worklist) : univ_eq_sol = - let rec aux wl us1 us2 = match us1, us2 with - | [], [] -> USolved wl - - | u1::us1, u2::us2 -> - begin match solve_universe_eq (p_pid orig) wl u1 u2 with - | USolved wl -> - aux wl us1 us2 - - | failed_or_deferred -> failed_or_deferred - end - - | _ -> ufailed_simple "Unequal number of universes" in - - let env = p_env wl orig in - def_check_scoped t1.pos "solve_maybe_uinsts.whnf1" env t1; - def_check_scoped t2.pos "solve_maybe_uinsts.whnf2" env t2; - let t1 = whnf env t1 in - let t2 = whnf env t2 in - match t1.n, t2.n with - | Tm_uinst({n=Tm_fvar f}, us1), Tm_uinst({n=Tm_fvar g}, us2) -> - let b = S.fv_eq f g in - assert b; - aux wl us1 us2 - - | Tm_uinst _, _ - | _, Tm_uinst _ -> - failwith "Impossible: expect head symbols to match" - - | _ -> - USolved wl - -and giveup_or_defer (orig:prob) (wl:worklist) (reason:deferred_reason) (msg:lstring) : solution = - if wl.defer_ok = DeferAny - then begin - if !dbg_Rel then - BU.print2 "\n\t\tDeferring %s\n\t\tBecause %s\n" (prob_to_string wl.tcenv orig) (Thunk.force msg); - solve (defer reason msg orig wl) - end - else giveup wl msg orig - -and giveup_or_defer_flex_flex (orig:prob) (wl:worklist) (reason:deferred_reason) (msg:lstring) : solution = - if wl.defer_ok <> NoDefer - then begin - if !dbg_Rel then - BU.print2 "\n\t\tDeferring %s\n\t\tBecause %s\n" (prob_to_string wl.tcenv orig) (Thunk.force msg); - solve (defer reason msg orig wl) - end - else giveup wl msg orig - -and defer_to_user_tac (orig:prob) reason (wl:worklist) : solution = - if !dbg_Rel then - BU.print1 "\n\t\tDeferring %s to a tactic\n" (prob_to_string wl.tcenv orig); - let wl = solve_prob orig None [] wl in - let wl = {wl with wl_deferred_to_tac=cons (wl.ctr, Deferred_to_user_tac, Thunk.mkv reason, orig) wl.wl_deferred_to_tac} in - solve wl - -and maybe_defer_to_user_tac prob reason wl : solution = - match prob.relation with - | EQ -> - let should_defer_tac t = - let head, _ = U.head_and_args t in - match (SS.compress head).n with - | Tm_uvar(uv, _) -> - DeferredImplicits.should_defer_uvar_to_user_tac wl.tcenv uv, uv.ctx_uvar_reason - | _ -> false, "" - in - let l1, r1 = should_defer_tac prob.lhs in - let l2, r2 = should_defer_tac prob.rhs in - if l1 || l2 - then defer_to_user_tac (TProb prob) (r1 ^ ", " ^ r2) wl - else solve (defer_lit Deferred_flex reason (TProb prob) wl) - | _ -> solve (defer_lit Deferred_flex reason (TProb prob) wl) - -(******************************************************************************************************) -(* The case where t1 < u, ..., tn < u: we solve this by taking u=t1\/...\/tn *) -(* The case where u < t1, .... u < tn: we solve this by taking u=t1/\.../\tn *) -(* *) -(* This will go through the worklist to find problems for the same uvar u and compute the composite *) -(* constraint as shown above. *) -(******************************************************************************************************) -and solve_rigid_flex_or_flex_rigid_subtyping - (rank:rank_t) - (tp:tprob) (wl:worklist) : solution = - def_check_prob "solve_rigid_flex_or_flex_rigid_subtyping" (TProb tp); - let flip = rank = Flex_rigid in - (* flip is true when the flex is on the left, after inverting (done by the caller), - which means we have a problem of the shape ?u <: t - - if flip is false, we are solving something of shape t <: ?u *) - (* - meet_or_join op [t1;..;tn] env wl: - Informally, this computes `t1 op t2 ... op tn` - where op is either \/ or /\ - - t1 op t2 is only defined when t1 and t2 - are refinements of the same base type - - if `op` is None, then we are computing the meet - and the result is widened to the base type - *) - let meet_or_join - (op : option (term -> term -> term)) - (ts : list term) - (wl:worklist) - : term & list prob & worklist - = let eq_prob t1 t2 wl = - let p, wl = - new_problem wl (p_env wl (TProb tp)) t1 EQ t2 None t1.pos - "join/meet refinements" - in - def_check_prob "meet_or_join" (TProb p); - TProb p, wl - in - let pairwise t1 t2 wl = - if !dbg_Rel - then BU.print2 "[meet/join]: pairwise: %s and %s\n" (show t1) (show t2); - let mr, ts = head_matches_delta (p_env wl (TProb tp)) tp.logical wl.smt_ok t1 t2 in - match mr with - | HeadMatch true - | MisMatch _ -> - let p, wl = eq_prob t1 t2 wl in - (t1, [p], wl) - - | FullMatch -> - begin - match ts with - | None -> - (t1, [], wl) - | Some (t1, t2) -> - (t1, [], wl) - end - - | HeadMatch false -> - let t1, t2 = - match ts with - | Some (t1, t2) -> SS.compress t1, SS.compress t2 - | None -> SS.compress t1, SS.compress t2 - in - let try_eq t1 t2 wl = - let t1_hd, t1_args = U.head_and_args t1 in - let t2_hd, t2_args = U.head_and_args t2 in - if List.length t1_args <> List.length t2_args then None else - let probs, wl = - List.fold_left2 (fun (probs, wl) (a1, _) (a2, _) -> - let p, wl = eq_prob a1 a2 wl in - p::probs, wl) - ([], wl) - //don't forget to prove t1_hd = t2_hd - //as they may have universe variables to equate - //as well - (as_arg t1_hd::t1_args) - (as_arg t2_hd::t2_args) - in - let wl' = {wl with defer_ok=NoDefer; - smt_ok=false; - attempting=probs; - wl_deferred=empty; - wl_implicits=empty} in - let tx = UF.new_transaction () in - match solve wl' with - | Success (_, defer_to_tac, imps) -> - UF.commit tx; - Some (extend_wl wl empty defer_to_tac imps) - - | Failed _ -> - UF.rollback tx; - None - in - let combine (t1 t2 : term) wl : term & list prob & worklist = - let env = p_env wl (TProb tp) in - let t1_base, p1_opt = base_and_refinement_maybe_delta false env t1 in - let t2_base, p2_opt = base_and_refinement_maybe_delta false env t2 in - (* - * AR: before applying op, we need to squash phi if required - * refinement formulas in F* may be in higher universe, - * meaning that if we apply op (l_and or l_or) directly, we may be - * unifying the universe of phi to zero, leading to errors - *) - let apply_op env op phi1 phi2 = - let squash phi = - match env.universe_of env phi with - | U_zero -> phi - | u -> U.mk_squash u phi in - op (squash phi1) (squash phi2) - in - let combine_refinements t_base p1_opt p2_opt = - match op with - | None -> t_base - | Some op -> - let refine x t = - if U.is_t_true t then x.sort - else U.refine x t - in - match p1_opt, p2_opt with - | Some (x, phi1), Some(y, phi2) -> - let x = freshen_bv x in - let subst = [DB(0, x)] in - let phi1 = SS.subst subst phi1 in - let phi2 = SS.subst subst phi2 in - let env_x = Env.push_bv env x in - refine x (apply_op env_x op phi1 phi2) - - | None, Some (x, phi) - | Some(x, phi), None -> - let x = freshen_bv x in - let subst = [DB(0, x)] in - let phi = SS.subst subst phi in - let env_x = Env.push_bv env x in - refine x (apply_op env_x op U.t_true phi) - - | _ -> - t_base - in - match try_eq t1_base t2_base wl with - | Some wl -> - combine_refinements t1_base p1_opt p2_opt, - [], - wl - - | None -> - let t1_base, p1_opt = base_and_refinement_maybe_delta true env t1 in - let t2_base, p2_opt = base_and_refinement_maybe_delta true env t2 in - let p, wl = eq_prob t1_base t2_base wl in - let t = combine_refinements t1_base p1_opt p2_opt in - (t, [p], wl) - in - let t1, ps, wl = combine t1 t2 wl in - if !dbg_Rel - then BU.print1 "pairwise fallback2 succeeded: %s" - (show t1); - t1, ps, wl - in - let rec aux (out, probs, wl) ts = - match ts with - | [] -> (out, probs, wl) - | t::ts -> - let out, probs', wl = pairwise out t wl in - aux (out, probs@probs', wl) ts - in - aux (List.hd ts, [], wl) (List.tl ts) - in - (*end meet_or_join *) - - let this_flex, this_rigid = if flip then tp.lhs, tp.rhs else tp.rhs, tp.lhs in - begin - match (SS.compress this_rigid).n with - | Tm_arrow {bs=_bs; comp} -> - //Although it's possible to take the meet/join of arrow types - //we handle them separately either by imitation (for Tot/GTot arrows) - //which provides some structural subtyping for them - //or just by reducing it to equality in other cases - - //BEWARE: special treatment of Tot and GTot here - if U.is_tot_or_gtot_comp comp - then let flex, wl = destruct_flex_t this_flex wl in - begin - match quasi_pattern wl.tcenv flex with - | None -> giveup_lit wl "flex-arrow subtyping, not a quasi pattern" (TProb tp) - | Some (flex_bs, flex_t) -> - if !dbg_Rel - then BU.print1 "Trying to solve by imitating arrow:%s\n" (string_of_int tp.pid); - imitate_arrow (TProb tp) wl flex flex_bs flex_t tp.relation this_rigid - end - else //imitating subtyping with WPs is hopeless - solve (attempt [TProb ({tp with relation=EQ})] wl) - - | _ -> - if !dbg_Rel then - BU.print1 "Trying to solve by meeting refinements:%s\n" (show tp.pid); - let u, _args = U.head_and_args this_flex in - let env = p_env wl (TProb tp) in - begin - match (SS.compress u).n with - | Tm_uvar(ctx_uvar, _subst) -> - let equiv (t:term) : bool = - let u', _ = U.head_and_args t in - match (whnf env u').n with - | Tm_uvar(ctx_uvar', _subst') -> - UF.equiv ctx_uvar.ctx_uvar_head ctx_uvar'.ctx_uvar_head - | _ -> false - in - //find all other constraints of the form t <: u, or if flipped, u <: t - let bounds_probs, rest = - wl.attempting |> List.partition - (function - | TProb tp -> - let tp = maybe_invert tp in - begin - match tp.rank with - | Some rank' when rank=rank' -> - if flip then equiv tp.lhs else equiv tp.rhs - - | _ -> false - end - - | _ -> false) - in - let bounds_typs = - whnf env this_rigid - :: List.collect (function - | TProb p -> [(if flip - then whnf env (maybe_invert p).rhs - else whnf env (maybe_invert p).lhs)] - | _ -> []) - bounds_probs - in - begin - let widen, meet_or_join_op = - if has_typeclass_constraint ctx_uvar wl - && not flip //we are widening; so widen all the way - then true, None - else false, Some (if flip then U.mk_conj_simp else U.mk_disj_simp) - in - let (bound, sub_probs, wl) = - match bounds_typs with - | [t] -> - if widen - then fst (base_and_refinement_maybe_delta false env t), [], wl - else (t, [], wl) - | _ -> - meet_or_join meet_or_join_op - bounds_typs - wl - in - let bound_typ, (eq_prob, wl') = - let flex_u = flex_uvar_head this_flex in - let bound = - //We get constraints of the form (x:?u{phi} <: ?u) - //This cannot be solved with an equality constraints - //So, turn the bound on the LHS to just ?u - match (SS.compress bound).n with - | Tm_refine {b=x; phi} - when tp.relation=SUB - && snd (occurs flex_u x.sort) -> - x.sort - | _ -> - bound - in - bound, - new_problem wl (p_env wl (TProb tp)) bound EQ this_flex None tp.loc - (if flip then "joining refinements" else "meeting refinements") - in - def_check_prob "meet_or_join2" (TProb eq_prob); - let _ = if !dbg_Rel - then let wl' = {wl with attempting=TProb eq_prob::sub_probs} in - BU.print1 "After meet/join refinements: %s\n" (wl_to_string wl') in - - let tx = UF.new_transaction () in - begin - List.iter (def_check_prob "meet_or_join3_sub") sub_probs; - match solve_t eq_prob ({wl' with defer_ok=NoDefer; - wl_implicits = Listlike.empty; - wl_deferred = empty; - attempting=sub_probs}) with - | Success (_, defer_to_tac, imps) -> - let wl = {wl' with attempting=rest} in - let wl = extend_wl wl empty defer_to_tac imps in - let g = List.fold_left (fun g p -> U.mk_conj g (p_guard p)) - eq_prob.logical_guard - sub_probs in - let wl = solve_prob' false (TProb tp) (Some g) [] wl in - let _ = List.fold_left (fun wl p -> solve_prob' true p None [] wl) wl bounds_probs in - UF.commit tx; - solve wl - - | Failed (p, msg) -> - if !dbg_Rel - then BU.print1 "meet/join attempted and failed to solve problems:\n%s\n" - (List.map (prob_to_string env) (TProb eq_prob::sub_probs) |> String.concat "\n"); - (match rank, base_and_refinement env bound_typ with - | Rigid_flex, (t_base, Some _) -> - UF.rollback tx; - //We failed to solve (x:t_base{p} <: ?u) while computing a precise join of all the lower bounds - //Rather than giving up, try again with a widening heuristic - //i.e., try to solve ?u = t and proceed - let eq_prob, wl = - new_problem wl (p_env wl (TProb tp)) t_base EQ this_flex None tp.loc "widened subtyping" in - def_check_prob "meet_or_join3" (TProb eq_prob); - let wl = solve_prob' false (TProb tp) (Some (p_guard (TProb eq_prob))) [] wl in - solve (attempt [TProb eq_prob] wl) - - | Flex_rigid, (t_base, Some (x, phi)) -> - UF.rollback tx; - //We failed to solve (?u = x:t_base{phi}) while computing - //a precise meet of all the upper bounds - //Rather than giving up, try again with a narrowing heuristic - //i.e., solve ?u = t_base, with the guard formula phi - let x = freshen_bv x in - let _, phi = SS.open_term [S.mk_binder x] phi in - let eq_prob, wl = - new_problem wl env t_base EQ this_flex None tp.loc "widened subtyping" in - def_check_prob "meet_or_join4" (TProb eq_prob); - let phi = guard_on_element wl tp x phi in - let wl = solve_prob' false (TProb tp) (Some (U.mk_conj phi (p_guard (TProb eq_prob)))) [] wl in - solve (attempt [TProb eq_prob] wl) - - | _ -> - giveup wl (Thunk.map (fun s -> "failed to solve the sub-problems: " ^ s) msg) p) - end - end - - | _ when flip -> - failwith (BU.format2 "Impossible: (rank=%s) Not a flex-rigid: %s" - (BU.string_of_int (rank_t_num rank)) - (prob_to_string env (TProb tp))) - | _ -> - failwith (BU.format2 "Impossible: (rank=%s) Not a rigid-flex: %s" - (BU.string_of_int (rank_t_num rank)) - (prob_to_string env (TProb tp))) - end - end - -and imitate_arrow (orig:prob) (wl:worklist) - (lhs:flex_t) (bs_lhs:binders) (t_res_lhs:term) - (rel:rel) - (arrow:term) - : solution = - let bs_lhs_args = List.map (fun ({binder_bv=x;binder_qual=i}) -> S.bv_to_name x, i) bs_lhs in - let (Flex (_, u_lhs, _)) = lhs in - let imitate_comp bs bs_terms c wl = - let imitate_tot_or_gtot t f wl = - let k, _ = U.type_u () in - let _, u, wl = copy_uvar u_lhs (bs_lhs@bs) k wl in - f u, wl - in - match c.n with - | Total t -> - imitate_tot_or_gtot t S.mk_Total wl - | GTotal t -> - imitate_tot_or_gtot t S.mk_GTotal wl - | Comp ct -> - let out_args, wl = - List.fold_right - (fun (a, i) (out_args, wl) -> - let _, t_a, wl = copy_uvar u_lhs [] (fst <| U.type_u()) wl in - let _, a', wl = copy_uvar u_lhs bs t_a wl in - (a',i)::out_args, wl) - ((S.as_arg ct.result_typ)::ct.effect_args) - ([], wl) - in - (* Drop the decreases flag, it is not needed and - * wouldn't be properly scoped either. *) - let nodec flags = List.filter (function DECREASES _ -> false - | _ -> true) flags in - let ct' = {ct with result_typ=fst (List.hd out_args); - effect_args=List.tl out_args; - flags=nodec ct.flags} in - {c with n=Comp ct'}, wl - in - let formals, c = U.arrow_formals_comp arrow in - let rec aux (bs:binders) (bs_terms:list arg) (formals:binders) wl = - match formals with - | [] -> - let c', wl = imitate_comp bs bs_terms c wl in - let lhs' = U.arrow bs c' in - let sol = TERM (u_lhs, U.abs bs_lhs lhs' (Some (U.residual_tot t_res_lhs))) in - let sub_prob, wl = - mk_t_problem wl [] orig lhs' rel arrow None "arrow imitation" - in - //printfn "Arrow imitation: %s =?= %s" (show lhs') (show rhs); - solve (attempt [sub_prob] (solve_prob orig None [sol] wl)) - - | ({binder_bv=x;binder_qual=imp;binder_positivity=pqual;binder_attrs=attrs})::formals -> - let _ctx_u_x, u_x, wl = copy_uvar u_lhs (bs_lhs@bs) (U.type_u() |> fst) wl in - //printfn "Generated formal %s where %s" (show t_y) (show ctx_u_x); - let y = S.new_bv (Some (S.range_of_bv x)) u_x in - let b = S.mk_binder_with_attrs y imp pqual attrs in - aux (bs@[b]) (bs_terms@[U.arg_of_non_null_binder b]) formals wl - in - let _, occurs_ok, msg = occurs_check u_lhs arrow in - if not occurs_ok - then giveup_or_defer orig wl - Deferred_occur_check_failed - (mklstr (fun () -> "occurs-check failed: " ^ (Option.get msg))) - else aux [] [] formals wl - -and solve_binders (bs1:binders) (bs2:binders) (orig:prob) (wl:worklist) - (rhs:worklist -> binders -> list subst_elt -> (prob & worklist)) : solution = - - if !dbg_Rel - then BU.print3 "solve_binders\n\t%s\n%s\n\t%s\n" - (show bs1) - (rel_to_string (p_rel orig)) - (show bs2); - - let eq_bqual a1 a2 = - match a1, a2 with - | Some (Implicit b1), Some (Implicit b2) -> - true //we don't care about comparing the dot qualifier in this context - | _ -> - U.eq_bqual a1 a2 - in - - let compat_positivity_qualifiers (p1 p2:option positivity_qualifier) : bool = - match p_rel orig with - | EQ -> - FStar.TypeChecker.Common.check_positivity_qual false p1 p2 - | SUB -> - FStar.TypeChecker.Common.check_positivity_qual true p1 p2 - | SUBINV -> - FStar.TypeChecker.Common.check_positivity_qual true p2 p1 - in - (* - * AR: adding env to the return type - * - * `aux` solves the binders problems xs REL ys, and keeps on adding the binders to env - * so that subsequent binders are solved in the right env - * when all the binders are solved, it creates the rhs problem and returns it - * the problem was that this rhs problem was getting solved in the original env, - * since `aux` never returned the env with all the binders - * so far it was fine, but with layered effects, we have to be really careful about the env - * so now we return the updated env, and the rhs is solved in that final env - * (see how `aux` is called after its definition below) - *) - let rec aux wl scope subst (xs:binders) (ys:binders) : either (probs & formula) string & worklist = - match xs, ys with - | [], [] -> - let rhs_prob, wl = rhs wl scope subst in - if !dbg_Rel - then BU.print1 "rhs_prob = %s\n" (prob_to_string (p_env wl rhs_prob) rhs_prob); - let formula = p_guard rhs_prob in - Inl ([rhs_prob], formula), wl - - | x::xs, y::ys - when (eq_bqual x.binder_qual y.binder_qual && - compat_positivity_qualifiers x.binder_positivity y.binder_positivity) -> - let hd1, imp = x.binder_bv, x.binder_qual in - let hd2, imp' = y.binder_bv, y.binder_qual in - let hd1 = {hd1 with sort=Subst.subst subst hd1.sort} in //open both binders - let hd2 = {hd2 with sort=Subst.subst subst hd2.sort} in - let prob, wl = mk_t_problem wl scope orig hd1.sort (invert_rel <| p_rel orig) hd2.sort None "Formal parameter" in - let hd1 = freshen_bv hd1 in - let subst = DB(0, hd1)::SS.shift_subst 1 subst in //extend the substitution - begin - match aux wl (scope @ [{x with binder_bv=hd1}]) subst xs ys with - | Inl (sub_probs, phi), wl -> - let phi = - U.mk_conj (p_guard prob) - (close_forall (p_env wl prob) [{x with binder_bv=hd1}] phi) in - if !dbg_Rel - then BU.print2 "Formula is %s\n\thd1=%s\n" (show phi) (show hd1); - Inl (prob::sub_probs, phi), wl - - | fail -> fail - end - - | _ -> Inr "arity or argument-qualifier mismatch", wl in - - match aux wl [] [] bs1 bs2 with - | Inr msg, wl -> giveup_lit wl msg orig - | Inl (sub_probs, phi), wl -> - let wl = solve_prob orig (Some phi) [] wl in - solve (attempt sub_probs wl) - -and try_solve_without_smt_or_else - (wl:worklist) - (try_solve: worklist -> solution) - (else_solve: worklist -> (prob & lstring) -> solution) - : solution = - let wl' = {wl with defer_ok=NoDefer; - smt_ok=false; - umax_heuristic_ok=false; - attempting=[]; - wl_deferred=empty; - wl_implicits=Listlike.empty} in - let tx = UF.new_transaction () in - match try_solve wl' with - | Success (_, defer_to_tac, imps) -> - UF.commit tx; - let wl = extend_wl wl empty defer_to_tac imps in - solve wl - | Failed (p, s) -> - UF.rollback tx; - else_solve wl (p,s) - -and try_solve_then_or_else - (wl:worklist) - (try_solve: worklist -> solution) - (then_solve: worklist -> solution) - (else_solve: worklist -> solution) - : solution = - let empty_wl = - {wl with defer_ok=NoDefer; - attempting=[]; - wl_deferred=empty; - wl_implicits=empty} in - let tx = UF.new_transaction () in - match try_solve empty_wl with - | Success (_, defer_to_tac, imps) -> - UF.commit tx; - let wl = extend_wl wl empty defer_to_tac imps in - then_solve wl - | Failed (p, s) -> - UF.rollback tx; - else_solve wl - -and try_solve_probs_without_smt - (wl:worklist) - (probs:worklist -> (probs & worklist)) - : either worklist lstring - = let probs, wl' = probs wl in - let wl' = {wl with defer_ok=NoDefer; - smt_ok=false; - umax_heuristic_ok=false; - attempting=probs; - wl_deferred=empty; - wl_implicits=Listlike.empty} in - match solve wl' with - | Success (_, defer_to_tac, imps) -> - let wl = extend_wl wl empty defer_to_tac imps in - Inl wl - - | Failed (_, ls) -> - Inr ls - -and solve_t (problem:tprob) (wl:worklist) : solution = - def_check_prob "solve_t" (TProb problem); - solve_t' (compress_tprob wl problem) wl - -and solve_t_flex_rigid_eq (orig:prob) (wl:worklist) (lhs:flex_t) (rhs:term) - : solution = - if !dbg_Rel then ( - BU.print1 "solve_t_flex_rigid_eq rhs=%s\n" - (show rhs) - ); - - if should_defer_flex_to_user_tac wl lhs - then defer_to_user_tac orig (flex_reason lhs) wl - else - - (* - mk_solution takes care to not introduce needless eta expansions - - lhs is of the form `?u bs` - Abstractly, the goal is to set `?u := fun bs -> rhs` - - But, this is optimized so that in case `rhs` is say `e bs`, - where `bs` does not appear free in `e`, - then we set `?u := e`. - - This is important since eta equivalence is not validated by F*. - - So, introduce needless eta expansions here would lead to unification - failures elsewhere - *) - let mk_solution env (lhs:flex_t) (bs:binders) (rhs:term) = - let bs_orig = bs in - let rhs_orig = rhs in - let (Flex (_, ctx_u, args)) = lhs in - let bs, rhs = - let bv_not_free_in_arg x arg = - not (mem x (Free.names (fst arg))) - in - let bv_not_free_in_args x args = - BU.for_all (bv_not_free_in_arg x) args - in - let binder_matches_aqual b aq = - match b.binder_qual, aq with - | None, None -> true - | Some (Implicit _), Some a -> - a.aqual_implicit && - U.eqlist (fun x y -> TEQ.eq_tm env x y = TEQ.Equal) - b.binder_attrs - a.aqual_attributes - | _ -> false - in - let rec remove_matching_prefix lhs_binders rhs_args = - match lhs_binders, rhs_args with - | [], _ - | _, [] -> lhs_binders, rhs_args - - | b::lhs_tl, (t, aq)::rhs_tl -> - match (SS.compress t).n with - | Tm_name x - when bv_eq b.binder_bv x - && binder_matches_aqual b aq - && bv_not_free_in_args b.binder_bv rhs_tl -> - remove_matching_prefix lhs_tl rhs_tl - | _ -> - lhs_binders, rhs_args - in - let rhs_hd, rhs_args = U.head_and_args rhs in - let bs, rhs_args = - remove_matching_prefix - (List.rev bs_orig) - (List.rev rhs_args) - |> (fun (bs_rev, args_rev) -> List.rev bs_rev, List.rev args_rev) - in - bs, - S.mk_Tm_app rhs_hd rhs_args rhs.pos - in - let sol = - match bs with - | [] -> rhs - | _ -> u_abs (U.ctx_uvar_typ ctx_u) (sn_binders env bs) rhs - in - [TERM(ctx_u, sol)] - in - - (* - LHS: ?u e1..en, if the arity of ?u is n - then LHS as a quasi pattern is (?u x1 ... xn) - for some names x1...xn - - (see the comment on quasi_pattern on how these names are computed) - - - if the free vars of rhs are included in ctx(?u) ++ {x1,...,xn} - - then solve by ?u <- (fun x1 .... xn -> rhs) - - provided ?u does not occur in RHS - - and after all uvars in the RHS (?u1 .. ?un) are restricted to the context (ctx(?u)) - - This has the behavior of preserving functional dependences in *some* cases. - - Consider two examples: - - 1. - LHS = ?u A.x, where A.x is an fv - RHS = option A.x - - Then quasi patern of LHS is (?u y), for some fresh y - since we can't abstract over the A.x - - The resulting solution will be - ?u <- fun y -> option A.x - - i.e., ?u is solved to the constant function - rather than `option` - - 2. LHS = ?u x, where x is just a name DOES NOT APPEAR in ctx(?u) - RHS = option (some complicated term including x) - - This time the quasi patern of LHS is (?u x) and - the resulting solution will be - - ?u <- fun x -> option (some complicated term including x) - - preserving the dependence on `x` - - *) - let try_quasi_pattern (orig:prob) (env:Env.env) (wl:worklist) - (lhs:flex_t) (rhs:term) - : either string (list uvi) & worklist = - if !dbg_Rel then - BU.print_string "try_quasi_pattern\n"; - match quasi_pattern env lhs with - | None -> - Inl "Not a quasi-pattern", wl - - | Some (bs, _) -> - let (Flex (t_lhs, ctx_u, args)) = lhs in - let uvars, occurs_ok, msg = occurs_check ctx_u rhs in - if not occurs_ok - then Inl ("quasi-pattern, occurs-check failed: " ^ (Option.get msg)), wl - else let fvs_lhs = binders_as_bv_set (ctx_u.ctx_uvar_binders@bs) in - let fvs_rhs = Free.names rhs in - if not (subset fvs_rhs fvs_lhs) - then Inl ("quasi-pattern, free names on the RHS are not included in the LHS"), wl - else Inr (mk_solution env lhs bs rhs), restrict_all_uvars env ctx_u [] uvars wl - in - - (* - LHS is a (?u e1..en) is a quasi pattern (?u b1...bn) - where bs_lhs = b1 .. bn (none of which appear in ctx(?u) (see quasi_pattern)) - and the type of ?u is (b1..bn -> t_res_lhs) - - RHS is an application (head e) where e:t_last - - Produce two new uvars: - ctx(?u), b1..bn, _:t_last |- ?u_head : t_last -> t_res_lhs - ctx(?u), b1..bn |- ?u_arg : t_last - - Solve: ?u <- (fun b1..bn -> ?u_head ?u_arg) - - And generate sub-problems - ?u_head = head - ?u_arg = arg - - Since it is based on quasi patterns, imitate_app (like - try_quasi_pattern) will usually not preserve functional - dependences - - For example: - - 1. LHS = ?u A.x, where A.x is an fv - RHS = option A.x - - Then quasi patern of LHS is (?u y), for some fresh y - since we can't abstract over the A.x - - The resulting solution will be - - ?u <- fun y -> ?u_head ?u_arg - - and ?u_head <- option - and ?u_arg <- A.x - - So, in a more roundabout way, we arrive at the same constant - function as the solution to ?u - *) - let imitate_app (orig:prob) (env:Env.env) (wl:worklist) - (lhs:flex_t) (bs_lhs:binders) (t_res_lhs:term) - (rhs:term) - : solution = - // if !dbg_Rel - // then BU.print4 "imitate_app 1:\n\tlhs=%s\n\tbs_lhs=%s\n\tt_res_lhs=%s\n\trhs=%s\n" - // (flex_t_to_string lhs) - // (Print.binders_to_string ", " bs_lhs) - // (show t_res_lhs) - // (show rhs); - let rhs_hd, args = U.head_and_args rhs in - let args_rhs, last_arg_rhs = BU.prefix args in - let rhs' = S.mk_Tm_app rhs_hd args_rhs rhs.pos in - // if !dbg_Rel - // then BU.print2 "imitate_app 2:\n\trhs'=%s\n\tlast_arg_rhs=%s\n" - // (show rhs') - // (show [last_arg_rhs]); - let (Flex (t_lhs, u_lhs, _lhs_args)) = lhs in - let lhs', lhs'_last_arg, wl = - let t_last_arg, _ = - let env = p_env wl orig in - env.typeof_well_typed_tot_or_gtot_term - ({env with admit=true; expected_typ=None}) - (fst last_arg_rhs) - false - in //AR: 03/30: WARNING: dropping the guard - //AR: 07/20: note the type of lhs' is t_last_arg -> t_res_lhs - let _, lhs', wl = - let b = S.null_binder t_last_arg in - copy_uvar u_lhs (bs_lhs@[b]) - (t_res_lhs |> S.mk_Total |> U.arrow [b]) wl - in - let _, lhs'_last_arg, wl = copy_uvar u_lhs bs_lhs t_last_arg wl in - lhs', lhs'_last_arg, wl - in - // if !dbg_Rel - // then BU.print2 "imitate_app 3:\n\tlhs'=%s\n\tlast_arg_lhs=%s\n" - // (show lhs') - // (show lhs'_last_arg); - let sol = [TERM(u_lhs, U.abs bs_lhs (S.mk_Tm_app lhs' [(lhs'_last_arg, snd last_arg_rhs)] t_lhs.pos) - (Some (U.residual_tot t_res_lhs)))] - in - let sub_probs, wl = - let p1, wl = mk_t_problem wl [] orig lhs' EQ rhs' None "first-order lhs" in - let p2, wl = mk_t_problem wl [] orig lhs'_last_arg EQ (fst last_arg_rhs) None "first-order rhs" in - [p1; p2], wl - in - solve (attempt sub_probs (solve_prob orig None sol wl)) - in - - (* - LHS: ?u e1..en, if the arity of ?u is n - then LHS as a quasi pattern is (?u x1 ... xn) - for some names x1...xn - - (see the comment on quasi_pattern on how these names are computed) - - If the RHS is an application (t e): imitate_app - - If the RHS is an arrow (xi:ti -> C): imitate_arrow - *) - let imitate (orig:prob) (env:Env.env) (wl:worklist) - (lhs:flex_t) (rhs:term) - : solution = - if !dbg_Rel then - BU.print_string "imitate\n"; - let is_app rhs = - let _, args = U.head_and_args rhs in - match args with - | [] -> false - | _ -> true - in - let is_arrow rhs = - match (SS.compress rhs).n with - | Tm_arrow _ -> true - | _ -> false - in - match quasi_pattern env lhs with - | None -> - let msg = mklstr (fun () -> - BU.format1 "imitate heuristic cannot solve %s; lhs not a quasi-pattern" - (prob_to_string env orig)) in - giveup_or_defer orig wl Deferred_first_order_heuristic_failed msg - - | Some (bs_lhs, t_res_lhs) -> - if is_app rhs - then imitate_app orig env wl lhs bs_lhs t_res_lhs rhs - else if is_arrow rhs - then imitate_arrow orig wl lhs bs_lhs t_res_lhs EQ rhs - else - let msg = mklstr (fun () -> - BU.format1 "imitate heuristic cannot solve %s; rhs not an app or arrow" - (prob_to_string env orig)) in - giveup_or_defer orig wl Deferred_first_order_heuristic_failed msg - in - (* - LHS = (?u : t1..tn -> t) e1..em - RHS = f v1...vm - - if (f: t1..tn -> t) - - ?u <- f - - and generate (e1 =?= v1, ..., em =?= vm) - - while restricting all free uvars in f to the context of ?u - *) - let try_first_order orig env wl lhs rhs = - let inapplicable msg lstring_opt = - if !dbg_Rel - then ( - let extra_msg = - match lstring_opt with - | None -> "" - | Some l -> Thunk.force l - in - BU.print2 "try_first_order failed because: %s\n%s\n" msg extra_msg - ); - Inl "first_order doesn't apply" - in - if !dbg_Rel then - BU.print2 "try_first_order\n\tlhs=%s\n\trhs=%s\n" - (flex_t_to_string lhs) - (show rhs); - let (Flex (_t1, ctx_uv, args_lhs)) = lhs in - let n_args_lhs = List.length args_lhs in - let head, args_rhs = U.head_and_args rhs in - let n_args_rhs = List.length args_rhs in - if n_args_lhs > n_args_rhs - then inapplicable "not enough args" None - else - let i = n_args_rhs - n_args_lhs in - let prefix, args_rhs = List.splitAt i args_rhs in - let head = S.mk_Tm_app head prefix head.pos in - let uvars_head, occurs_ok, _ = occurs_check ctx_uv head in - if not occurs_ok - then inapplicable "occurs check failed" None - else if not (Free.names head `subset` binders_as_bv_set ctx_uv.ctx_uvar_binders) - then inapplicable "free name inclusion failed" None - else ( - let t_head, _ = - env.typeof_well_typed_tot_or_gtot_term - ({env with admit=true; expected_typ=None}) - head - false - in - let tx = UF.new_transaction () in - let solve_sub_probs_if_head_types_equal head_uvars_to_restrict wl = - let sol = [TERM(ctx_uv, head)] in - let wl = restrict_all_uvars env ctx_uv [] head_uvars_to_restrict wl in - let wl = solve_prob orig None sol wl in - - let sub_probs, wl = - List.fold_left2 - (fun (probs, wl) (arg_lhs, _) (arg_rhs, _) -> - let p, wl = mk_t_problem wl [] orig arg_lhs EQ arg_rhs None "first-order arg" in - p::probs, wl) - ([], wl) - args_lhs - args_rhs - in - let wl' = { wl with defer_ok = NoDefer; - smt_ok = false; - attempting = sub_probs; - wl_deferred = empty; - wl_implicits = Listlike.empty } in - match solve wl' with - | Success (_, defer_to_tac, imps) -> - let wl = extend_wl wl empty defer_to_tac imps in - UF.commit tx; - Inr wl - | Failed (_, lstring) -> - UF.rollback tx; - inapplicable "Subprobs failed: " (Some lstring) - in - if TEQ.eq_tm env t_head (U.ctx_uvar_typ ctx_uv) = TEQ.Equal - then - // - // eq_tm doesn't unify, so uvars_head computed remains consistent - // (see the second call to solve_sub_probs_if_head_types_equal below) - // - solve_sub_probs_if_head_types_equal uvars_head wl - else ( - if !dbg_Rel - then BU.print2 "first-order: head type mismatch:\n\tlhs=%s\n\trhs=%s\n" - (show (U.ctx_uvar_typ ctx_uv)) - (show t_head); - let typ_equality_prob wl = - let p, wl = mk_t_problem wl [] orig (U.ctx_uvar_typ ctx_uv) EQ t_head None "first-order head type" in - [p], wl - in - match try_solve_probs_without_smt wl typ_equality_prob with - | Inl wl -> - // - // Some uvars from uvars_head list above may already be solved - // or restricted, so recompute since solve_sub_probs_if_head_types_equal - // will also try to restrict them - // - solve_sub_probs_if_head_types_equal - (head |> Free.uvars |> elems) - wl - | Inr msg -> - UF.rollback tx; - inapplicable "first-order: head type mismatch" (Some msg) - ) - ) - in - match p_rel orig with - | SUB - | SUBINV -> - if wl.defer_ok = DeferAny - then giveup_or_defer orig wl Deferred_flex (Thunk.mkv "flex-rigid subtyping") - else solve_t_flex_rigid_eq (make_prob_eq orig) wl lhs rhs - - | EQ -> - let (Flex (_t1, ctx_uv, args_lhs)) = lhs in - let env = p_env wl orig in - match pat_vars env ctx_uv.ctx_uvar_binders args_lhs with - | Some lhs_binders -> //Pattern - if !dbg_Rel then - BU.print_string "it's a pattern\n"; - let rhs = sn env rhs in - let fvs1 = binders_as_bv_set (ctx_uv.ctx_uvar_binders @ lhs_binders) in - let fvs2 = Free.names rhs in - //if !dbg_Rel then - // BU.print4 "lhs \t= %s\n\ - // FV(lhs) \t= %s\n\ - // rhs \t= %s\n\ - // FV(rhs) \t= %s\n" - // (flex_t_to_string lhs) - // (show fvs1) - // (show rhs) - // (show fvs2); - let uvars, occurs_ok, msg = occurs_check ctx_uv rhs in - - (* If the occurs check fails, attempt to do a bit more normalization - and try it again. *) - let (uvars, occurs_ok, msg), rhs = - if occurs_ok - then (uvars, occurs_ok, msg), rhs - else - let rhs = N.normalize - [Env.Primops; Env.Weak; Env.HNF; Env.Beta; Env.Eager_unfolding; Env.Unascribe] - (p_env wl orig) rhs in - occurs_check ctx_uv rhs, rhs - in - - (* If, possibly after some extra normalization in the above block, - the RHS has become syntactically equal to the LHS, solve the problem - and carry on. See #3264. *) - if term_is_uvar ctx_uv rhs && Nil? args_lhs then - solve (solve_prob orig None [] wl) - else - if not occurs_ok - then giveup_or_defer orig wl - Deferred_occur_check_failed - (Thunk.mkv <| "occurs-check failed: " ^ (Option.get msg)) - else if subset fvs2 fvs1 - then let sol = mk_solution env lhs lhs_binders rhs in - let wl = restrict_all_uvars env ctx_uv lhs_binders uvars wl in - solve (solve_prob orig None sol wl) - else if wl.defer_ok = DeferAny - then - let msg = mklstr (fun () -> - BU.format3 "free names in the RHS {%s} are out of scope for the LHS: {%s}, {%s}" - (show fvs2) - (show fvs1) - (show (ctx_uv.ctx_uvar_binders @ lhs_binders))) in - giveup_or_defer orig wl Deferred_free_names_check_failed msg - else imitate orig env wl lhs rhs - - - | _ -> //Not a pattern - if wl.defer_ok = DeferAny - then giveup_or_defer orig wl Deferred_not_a_pattern (Thunk.mkv "Not a pattern") - else match try_first_order orig env wl lhs rhs with - | Inr wl -> - solve wl - - | _ -> - - match try_quasi_pattern orig env wl lhs rhs with - | Inr sol, wl -> - solve (solve_prob orig None sol wl) - - | Inl msg, _ -> - imitate orig env wl lhs rhs - -(* solve_t_flex-flex: - Always delay flex-flex constraints, if possible. - If not, see if one of the flex uvar has a meta program associated - If yes, run that meta program, solve the uvar, and try again - If not, coerce both sides to patterns and solve -*) -and solve_t_flex_flex env orig wl (lhs:flex_t) (rhs:flex_t) : solution = - let should_run_meta_arg_tac (flex:flex_t) = - (* If this flex has a meta-arg, and the problem is fully - defined (no uvars in env/typ), then we can run it now. *) - let uv = flex_uvar flex in - flex_uvar_has_meta_tac uv && - not (has_free_uvars (U.ctx_uvar_typ uv)) && - not (gamma_has_free_uvars uv.ctx_uvar_gamma) - in - - let run_meta_arg_tac_and_try_again (flex:flex_t) = - let uv = flex_uvar flex in - let t = run_meta_arg_tac env uv in - if !dbg_Rel then - BU.print2 "solve_t_flex_flex: solving meta arg uvar %s with %s\n" (show uv) (show t); - set_uvar env uv None t; - solve (attempt [orig] wl) in - - match p_rel orig with - | SUB - | SUBINV -> - if wl.defer_ok = DeferAny - then giveup_or_defer_flex_flex orig wl Deferred_flex (Thunk.mkv "flex-flex subtyping") - else solve_t_flex_flex env (make_prob_eq orig) wl lhs rhs - - | EQ -> - if should_defer_flex_to_user_tac wl lhs || should_defer_flex_to_user_tac wl rhs - then defer_to_user_tac orig (flex_reason lhs ^", "^flex_reason rhs)wl - else - - if (wl.defer_ok = DeferAny || wl.defer_ok = DeferFlexFlexOnly) - && (not (is_flex_pat lhs)|| not (is_flex_pat rhs)) - then giveup_or_defer_flex_flex orig wl Deferred_flex_flex_nonpattern (Thunk.mkv "flex-flex non-pattern") - - else if should_run_meta_arg_tac lhs - then run_meta_arg_tac_and_try_again lhs - - else if should_run_meta_arg_tac rhs - then run_meta_arg_tac_and_try_again rhs - - else - let rec occurs_bs u bs = - match bs with - | [] -> false - | b::bs -> snd (occurs u b.binder_bv.sort) || occurs_bs u bs - in - match quasi_pattern env lhs, quasi_pattern env rhs with - | Some (binders_lhs, t_res_lhs), Some (binders_rhs, t_res_rhs) -> - let (Flex ({pos=range}, u_lhs, _)) = lhs in - if occurs_bs u_lhs binders_lhs then - (* Fix for #2583 *) - giveup_or_defer orig wl Deferred_flex_flex_nonpattern - (Thunk.mkv "flex-flex: occurs check failed on the LHS flex quasi-pattern") - else - let (Flex (_, u_rhs, _)) = rhs in - if UF.equiv u_lhs.ctx_uvar_head u_rhs.ctx_uvar_head - && binders_eq binders_lhs binders_rhs - then solve (solve_prob orig None [] wl) - else (* Given a flex-flex instance: - (x1..xn ..X |- ?u : ts -> tres) [y1 ... ym ] - ~ (x1..xn ..X' |- ?v : ts' -> tres) [y1' ... ym'] - - let ctx_w = x1..xn in - let z1..zk = (..X..y1..ym intersect ...X'...y1'..ym') in - (ctx_w |- ?w : z1..zk -> tres) [z1..zk] - - ?u := (fun y1..ym -> ?w z1...zk) - ?v := (fun y1'..ym' -> ?w z1...zk) - *) - //let sub_prob, wl = - // //is it strictly necessary to add this sub problem? - // //we don't in other cases - // mk_t_problem wl [] orig t_res_lhs EQ t_res_rhs None "flex-flex typing" - //in - let ctx_w, (ctx_l, ctx_r) = - maximal_prefix u_lhs.ctx_uvar_binders - u_rhs.ctx_uvar_binders - in - let gamma_w = gamma_until u_lhs.ctx_uvar_gamma ctx_w in - let zs = intersect_binders gamma_w (ctx_l @ binders_lhs) (ctx_r @ binders_rhs) in - let new_uvar_typ = U.arrow zs (S.mk_Total t_res_lhs) in - if snd (occurs u_lhs new_uvar_typ) - || (not (Unionfind.equiv u_lhs.ctx_uvar_head u_rhs.ctx_uvar_head) && - snd (occurs u_rhs new_uvar_typ)) - then giveup_or_defer_flex_flex orig wl Deferred_flex_flex_nonpattern - (Thunk.mkv (BU.format1 "flex-flex: occurs\n defer_ok=%s\n" - (show wl.defer_ok))) - else begin - // let _ = - // if !dbg_Rel - // then BU.print1 "flex-flex quasi: %s\n" - // (BU.stack_dump()) - // in - let new_uvar_should_check, is_ghost = - match U.ctx_uvar_should_check u_lhs, U.ctx_uvar_should_check u_rhs with - | Allow_untyped r, Allow_untyped _ -> Allow_untyped r, false - | Allow_ghost r, _ - | _, Allow_ghost r -> Allow_ghost r, true - | _ -> Strict, false in - let _, w, wl = new_uvar ("flex-flex quasi:" - ^"\tlhs=" ^u_lhs.ctx_uvar_reason - ^"\trhs=" ^u_rhs.ctx_uvar_reason) - wl range gamma_w ctx_w new_uvar_typ - new_uvar_should_check - (if Some? u_lhs.ctx_uvar_meta - then u_lhs.ctx_uvar_meta - else u_rhs.ctx_uvar_meta) // Try to retain the meta, if any - in - let w_app = S.mk_Tm_app w (List.map (fun ({binder_bv=z}) -> S.as_arg (S.bv_to_name z)) zs) w.pos in - let _ = - if !dbg_Rel - then BU.print "flex-flex quasi:\n\t\ - lhs=%s\n\t\ - rhs=%s\n\t\ - sol=%s\n\t\ - ctx_l@binders_lhs=%s\n\t\ - ctx_r@binders_rhs=%s\n\t\ - zs=%s\n" - [flex_t_to_string lhs; - flex_t_to_string rhs; - term_to_string w; - show (ctx_l@binders_lhs); - show (ctx_r@binders_rhs); - show zs] - in - let rc = (if is_ghost then U.residual_gtot else U.residual_tot) t_res_lhs in - let s1_sol = U.abs binders_lhs w_app (Some rc) in - let s1 = TERM(u_lhs, s1_sol) in - if Unionfind.equiv u_lhs.ctx_uvar_head u_rhs.ctx_uvar_head - then solve (solve_prob orig None [s1] wl) - else ( - let s2_sol = U.abs binders_rhs w_app (Some rc) in - let s2 = TERM(u_rhs, s2_sol) in - solve (solve_prob orig None [s1;s2] wl) - ) - end - - | _ -> - giveup_or_defer orig wl Deferred_flex_flex_nonpattern (Thunk.mkv "flex-flex: non-patterns") - -and solve_t' (problem:tprob) (wl:worklist) : solution = - def_check_prob "solve_t'.1" (TProb problem); - let giveup_or_defer orig msg = giveup_or_defer orig wl msg in - - let rigid_heads_match (need_unif:bool) (torig:tprob) (wl:worklist) (t1:term) (t2:term) : solution = - let orig = TProb torig in - let env = p_env wl orig in - if !dbg_Rel - then BU.print5 "Heads %s: %s (%s) and %s (%s)\n" - (if need_unif then "need unification" else "match") - (show t1) (tag_of t1) - (show t2) (tag_of t2); - let head1, args1 = U.head_and_args t1 in - let head2, args2 = U.head_and_args t2 in - let need_unif = - match (head1.n, args1), (head2.n, args2) with - | (Tm_uinst(_, us1), _::_), (Tm_uinst(_, us2), _::_) -> - if List.for_all (fun u -> not (universe_has_max env u)) us1 - && List.for_all (fun u -> not (universe_has_max env u)) us2 - then need_unif //if no umaxes then go ahead as usual - else true //else, decompose the problem and potentially defer - | _ -> need_unif - in - let solve_head_then wl k = - if need_unif then k true wl - else match solve_maybe_uinsts orig head1 head2 wl with - | USolved wl -> k true wl //(solve_prob orig None [] wl) - | UFailed msg -> giveup wl msg orig - | UDeferred wl -> k false (defer_lit Deferred_univ_constraint "universe constraints" orig wl) - in - let nargs = List.length args1 in - if nargs <> List.length args2 - then giveup wl - (mklstr - (fun () -> BU.format4 "unequal number of arguments: %s[%s] and %s[%s]" - (show head1) (show args1) (show head2) (show args2))) - orig - else - if nargs=0 || TEQ.eq_args env args1 args2=TEQ.Equal //special case: for easily proving things like nat <: nat, or greater_than i <: greater_than i etc. - then if need_unif - then solve_t ({problem with lhs=head1; rhs=head2}) wl - else solve_head_then wl (fun ok wl -> - if ok then solve (solve_prob orig None [] wl) - else solve wl) - else//Given T t1 ..tn REL T s1..sn - // if T expands to a refinement, then normalize it and recurse - // This allows us to prove things like - // type T (x:int) (y:int) = z:int{z = x + y} - // T 0 1 <: T 1 0 - // By expanding out the definitions - // - //Otherwise, we reason extensionally about T and try to prove the arguments equal, i.e, ti = si, for all i - let base1, refinement1 = base_and_refinement env t1 in - let base2, refinement2 = base_and_refinement env t2 in - begin - match refinement1, refinement2 with - | None, None -> //neither side is a refinement; reason extensionally - let mk_sub_probs wl = - let argp = - if need_unif - then List.zip ((head1, None)::args1) ((head2, None)::args2) - else List.zip args1 args2 - in - let subprobs, wl = - List.fold_right - (fun ((a1, _), (a2, _)) (probs, wl) -> - let prob', wl = mk_problem wl [] orig a1 EQ a2 None "index" in - (TProb prob')::probs, wl) - argp - ([], wl) - in - if !dbg_Rel - then BU.print2 - "Adding subproblems for arguments (smtok=%s): %s" - (string_of_bool wl.smt_ok) - (FStar.Common.string_of_list (prob_to_string env) subprobs); - if Options.defensive () - then List.iter (def_check_prob "solve_t' subprobs") subprobs; - subprobs, wl - in - let solve_sub_probs env wl = - solve_head_then wl (fun ok wl -> - if not ok - then solve wl - else let subprobs, wl = mk_sub_probs wl in - let formula = U.mk_conj_l (List.map (fun p -> p_guard p) subprobs) in - let wl = solve_prob orig (Some formula) [] wl in - solve (attempt subprobs wl)) - in - let solve_sub_probs_no_smt wl = - solve_head_then wl (fun ok wl -> - assert ok; //defer not allowed - let subprobs, wl = mk_sub_probs wl in - let formula = U.mk_conj_l (List.map (fun p -> p_guard p) subprobs) in - let wl = solve_prob orig (Some formula) [] wl in - solve (attempt subprobs wl)) - in - let unfold_and_retry d wl (prob, reason) = - if !dbg_Rel - then BU.print2 "Failed to solve %s because a sub-problem is not solvable without SMT because %s" - (prob_to_string env orig) - (Thunk.force reason); - let env = p_env wl prob in - match N.unfold_head_once env t1, - N.unfold_head_once env t2 - with - | Some t1', Some t2' -> - let head1', _ = U.head_and_args t1' in - let head2', _ = U.head_and_args t2' in - begin - match TEQ.eq_tm env head1' head1, TEQ.eq_tm env head2' head2 with - | TEQ.Equal, TEQ.Equal -> //unfolding didn't make progress - if !dbg_Rel - then BU.print4 - "Unfolding didn't make progress ... got %s ~> %s;\nand %s ~> %s\n" - (show t1) - (show t1') - (show t2) - (show t2'); - solve_sub_probs env wl //fallback to trying to solve with SMT on - | _ -> - let torig' = {torig with lhs=t1'; rhs=t2'} in - if !dbg_Rel - then BU.print1 "Unfolded and now trying %s\n" - (prob_to_string env (TProb torig')); - solve_t torig' wl - end - | _ -> - solve_sub_probs env wl //fallback to trying to solve with SMT on - in - let d = decr_delta_depth <| delta_depth_of_term env head1 in - let treat_as_injective = - match (U.un_uinst head1).n with - | Tm_fvar fv -> - Env.fv_has_attr env fv PC.unifier_hint_injective_lid - | _ -> false - in - begin - match d with - | Some d when wl.smt_ok && not treat_as_injective -> - try_solve_without_smt_or_else wl - solve_sub_probs_no_smt - (unfold_and_retry d) - - | _ -> //cannot be unfolded or no smt anyway; so just try to solve extensionally - solve_sub_probs env wl - - end - - | _ -> - let lhs = force_refinement (base1, refinement1) in - let rhs = force_refinement (base2, refinement2) in - // - //AR: force_refinement already returns the term in - // whnf, so call solve_t' directly - // - solve_t' ({problem with lhs=lhs; rhs=rhs}) wl - end - in - - (* : - (match ?u with P1 -> t1 | ... | Pn -> tn) ~ t - - when (head t) `matches` (head ti) - solve ?u to Pi - and then try to prove `t ~ ti` - *) - let try_match_heuristic orig wl s1 s2 t1t2_opt = - let env = p_env wl orig in - let try_solve_branch scrutinee p = - let (Flex (_t, uv, _args), wl) = destruct_flex_t scrutinee wl in - // - // We add g_pat_as_exp implicits to the worklist later - // And we know it only contains implicits, no logical payload - // - let xs, pat_term, g_pat_as_exp, _ = PatternUtils.pat_as_exp true true env p in - let subst, wl = - List.fold_left (fun (subst, wl) x -> - let t_x = SS.subst subst x.sort in - let _, u, wl = copy_uvar uv [] t_x wl in - let subst = NT(x, u)::subst in - subst, wl) - ([], wl) - xs - in - let pat_term = SS.subst subst pat_term in - - // - // The pat term here contains uvars for dot patterns, and even bvs - // and their types - // We are going to unify the pat_term with the scrutinee, and that - // will solve some of those uvars - // But there are some uvars, e.g. for the dot pattern types, that will - // not get constrained even with those unifications - // - // To constrain such uvars, we typecheck the pat_term with the type of - // the scrutinee as the expected type - // This typechecking cannot use fastpath since the pat_term may be nested, - // and may have uvars in nested levels (Cons ?u (Cons ?u1 ...)), - // whereas fastpath may only compute the type from the top-level (list ?u here, e.g.) - // And so on - // - - let pat_term, g_pat_term = - let must_tot = false in - // - // Note that we cannot just use the uv.ctx_uvar_typ, - // since _args may be non-empty - // Also unrefine the scrutinee type - // - let scrutinee_t = - env.typeof_well_typed_tot_or_gtot_term env scrutinee must_tot - |> fst - |> N.normalize_refinement N.whnf_steps env - |> U.unrefine in - if !dbg_Rel - then BU.print1 "Match heuristic, typechecking the pattern term: %s {\n\n" - (show pat_term); - let pat_term, pat_term_t, g_pat_term = - env.typeof_tot_or_gtot_term - (Env.set_expected_typ env scrutinee_t) - pat_term - must_tot in - if !dbg_Rel - then BU.print2 "} Match heuristic, typechecked pattern term to %s and type %s\n" - (show pat_term) - (show pat_term_t); - pat_term, g_pat_term in - - // - // Enforce that the pattern typechecking guard has trivial logical payload - // - if g_pat_term |> simplify_guard env |> Env.is_trivial_guard_formula - then begin - let prob, wl = new_problem wl env scrutinee - EQ pat_term None scrutinee.pos - "match heuristic" - in - - let wl' = extend_wl ({wl with defer_ok=NoDefer; - smt_ok=false; - attempting=[TProb prob]; - wl_deferred=empty; - wl_implicits=Listlike.empty}) - g_pat_term.deferred - g_pat_term.deferred_to_tac - (Listlike.empty) in - let tx = UF.new_transaction () in - match solve wl' with - | Success (_, defer_to_tac, imps) -> - let wl' = {wl' with attempting=[orig]} in - (match solve wl' with - | Success (_, defer_to_tac', imps') -> - UF.commit tx; - Some (extend_wl wl - empty - (defer_to_tac ++ defer_to_tac') - (imps ++ imps' ++ g_pat_as_exp.implicits ++ g_pat_term.implicits)) - - | Failed _ -> - UF.rollback tx; - None) - | _ -> - UF.rollback tx; - None - end - else None - in - match t1t2_opt with - | None -> Inr None - | Some (t1, t2) -> - if !dbg_Rel - then BU.print2 "Trying match heuristic for %s vs. %s\n" - (show t1) - (show t2); - match (s1, U.unmeta t1), (s2, U.unmeta t2) with - | (_, {n=Tm_match {scrutinee; brs=branches}}), (s, t) - | (s, t), (_, {n=Tm_match {scrutinee; brs=branches}}) -> - if not (is_flex scrutinee) - then begin - if !dbg_Rel - then BU.print1 "match head %s is not a flex term\n" (show scrutinee); - Inr None - end - else if wl.defer_ok = DeferAny - then (if !dbg_Rel - then BU.print_string "Deferring ... \n"; - Inl "defer") - else begin - if !dbg_Rel - then BU.print2 "Heuristic applicable with scrutinee %s and other side = %s\n" - (show scrutinee) - (show t); - let pat_discriminates = function - | ({v=Pat_constant _}, None, _) - | ({v=Pat_cons _}, None, _) -> true - | _ -> false //other patterns do not discriminate - in - let head_matching_branch = - branches |> - BU.try_find - (fun b -> - if pat_discriminates b - then - let (_, _, t') = SS.open_branch b in - match head_matches_delta (p_env wl orig) (p_logical orig) wl.smt_ok s t' with - | FullMatch, _ - | HeadMatch _, _ -> - true - | _ -> false - else false) - in - begin - match head_matching_branch with - | None -> - if !dbg_Rel - then BU.print_string "No head_matching branch\n"; - let try_branches = - match BU.prefix_until (fun b -> not (pat_discriminates b)) branches with - | Some (branches, _, _) -> branches - | _ -> branches - in - Inr <| BU.find_map try_branches (fun b -> - let (p, _, _) = SS.open_branch b in - try_solve_branch scrutinee p) - - | Some b -> - let (p, _, e) = SS.open_branch b in - if !dbg_Rel - then BU.print2 "Found head matching branch %s -> %s\n" - (show p) - (show e); - Inr <| try_solve_branch scrutinee p - - end - end - | _ -> - if !dbg_Rel - then BU.print2 "Heuristic not applicable: tag lhs=%s, rhs=%s\n" - (tag_of t1) (tag_of t2); - Inr None - in - - (* : are t1 and t2, with head symbols head1 and head2, compatible after some delta steps? *) - let rigid_rigid_delta (torig:tprob) (wl:worklist) - (head1:term) (head2:term) (t1:term) (t2:term) - : solution = - let orig = TProb torig in - if !dbg_RelDelta then - BU.print4 "rigid_rigid_delta of %s-%s (%s, %s)\n" - (tag_of t1) - (tag_of t2) - (show t1) - (show t2); - let m, o = head_matches_delta (p_env wl orig) (p_logical orig) wl.smt_ok t1 t2 in - match m, o with - | (MisMatch _, _) -> //heads definitely do not match - let try_reveal_hide t1 t2 = - //tries to solve problems of the form - // 1. - // reveal ?u == y, where head y <> hide/reveal - // by generating hide (reveal ?u) == hide y - // and simplifying it to ?u == hide y - // - // 2. - // hide ?u == y, where head y <> hide/reveal - // by generating reveal (hide ?u) == reveal y - // and simplifying it to ?u == reveal y - // - let payload_of_hide_reveal h args : option (universe & typ & term) = - match h.n, args with - | Tm_uinst(_, [u]), [(ty, Some ({ aqual_implicit = true })); (t, _)] -> - Some (u, ty, t) - | _ -> None - in - let is_reveal_or_hide t = - let h, args = U.head_and_args t in - if U.is_fvar PC.reveal h - then match payload_of_hide_reveal h args with - | None -> None - | Some t -> Some (Reveal t) - else if U.is_fvar PC.hide h - then match payload_of_hide_reveal h args with - | None -> None - | Some t -> Some (Hide t) - else None - in - let mk_fv_app lid u args r = - let fv = Env.fvar_of_nonqual_lid wl.tcenv lid in - let head = S.mk_Tm_uinst fv [u] in - S.mk_Tm_app head args r - in - match is_reveal_or_hide t1, is_reveal_or_hide t2 with - (* We only apply these first two rules when the arg to reveal - is a flex, to avoid loops such as: - reveal t1 =?= t2 - ~> t1 =?= hide t2 - ~> reveal t1 =?= t2 - *) - | Some (Reveal (u, ty, lhs)), None when is_flex lhs -> - // reveal (?u _) / _ - //add hide to rhs and simplify lhs - let rhs = mk_fv_app PC.hide u [(ty, S.as_aqual_implicit true); (t2, None)] t2.pos in - Some (lhs, rhs) - - | None, Some (Reveal (u, ty, rhs)) when is_flex rhs -> - // _ / reveal (?u _) - //add hide to lhs and simplify rhs - let lhs = mk_fv_app PC.hide u [(ty, S.as_aqual_implicit true); (t1, None)] t1.pos in - Some (lhs, rhs) - - | Some (Hide (u, ty, lhs)), None -> - // hide _ / _ - //add reveal to rhs and simplify lhs - let rhs = mk_fv_app PC.reveal u [(ty,S.as_aqual_implicit true); (t2, None)] t2.pos in - Some (lhs, rhs) - - | None, Some (Hide (u, ty, rhs)) -> - // _ / hide _ - //add reveal to lhs and simplify rhs - let lhs = mk_fv_app PC.reveal u [(ty,S.as_aqual_implicit true); (t1, None)] t1.pos in - Some (lhs, rhs) - - | _ -> None - in - begin - match try_match_heuristic orig wl t1 t2 o with - | Inl _defer_ok -> - giveup_or_defer orig Deferred_delay_match_heuristic (Thunk.mkv "delaying match heuristic") - - | Inr (Some wl) -> - solve wl - - | Inr None -> - - match try_reveal_hide t1 t2 with - | Some (t1', t2') -> - solve_t ({problem with lhs=t1'; rhs=t2'}) wl - - | None -> - if (may_relate wl.tcenv problem.relation head1 - || may_relate wl.tcenv problem.relation head2) - && wl.smt_ok - then let guard, wl = guard_of_prob wl problem t1 t2 in - solve (solve_prob orig (Some guard) [] wl) - else giveup wl (mklstr (fun () -> BU.format4 "head mismatch (%s (%s) vs %s (%s))" - (show head1) - (show (delta_depth_of_term wl.tcenv head1)) - (show head2) - (show (delta_depth_of_term wl.tcenv head2)))) orig - end - - | (HeadMatch true, _) when problem.relation <> EQ -> - //heads may only match after unification; - //but we're not trying to unify them here - //so, treat as a mismatch - if wl.smt_ok - then let guard, wl = guard_of_prob wl problem t1 t2 in - solve (solve_prob orig (Some guard) [] wl) - else giveup wl (mklstr (fun () -> BU.format2 "head mismatch for subtyping (%s vs %s)" - (show t1) - (show t2))) - orig - - | (_, Some (t1, t2)) -> //heads match after some delta steps - solve_t ({problem with lhs=t1; rhs=t2}) wl - - (* Need to maybe reunify the heads *) - | (HeadMatch need_unif, None) -> - rigid_heads_match need_unif torig wl t1 t2 - - | (FullMatch, None) -> - rigid_heads_match false torig wl t1 t2 - in - (* *) - - let orig = TProb problem in - def_check_prob "solve_t'.2" orig; - if BU.physical_equality problem.lhs problem.rhs then solve (solve_prob orig None [] wl) else - let t1 = problem.lhs in - let t2 = problem.rhs in - def_check_scoped (p_loc orig) "ref.t1" (List.map (fun b -> b.binder_bv) (p_scope orig)) t1; - def_check_scoped (p_loc orig) "ref.t2" (List.map (fun b -> b.binder_bv) (p_scope orig)) t2; - let _ = - if !dbg_Rel - then BU.print5 "Attempting %s (%s vs %s); rel = (%s); number of problems in wl = %s\n" (string_of_int problem.pid) - (tag_of t1 ^ "::" ^ show t1) - (tag_of t2 ^ "::" ^ show t2) - (rel_to_string problem.relation) - (show (List.length wl.attempting)) - in - match t1.n, t2.n with - | Tm_delayed _, _ - | _, Tm_delayed _ -> - // Either case is impossible since we always call solve_t' after - // a call to compress_tprob, or directly after a call to unascribe, - // unmeta, etc. - failwith "Impossible: terms were not compressed" - - | Tm_ascribed _, _ -> - solve_t' ({problem with lhs=U.unascribe t1}) wl - - | Tm_meta _, _ -> - solve_t' ({problem with lhs=U.unmeta t1}) wl - - | _, Tm_ascribed _ -> - solve_t' ({problem with rhs=U.unascribe t2}) wl - - | _, Tm_meta _ -> - solve_t' ({problem with rhs=U.unmeta t2}) wl - - | Tm_quoted (t1, _), Tm_quoted (t2, _) -> - solve (solve_prob orig None [] wl) - - | Tm_bvar _, _ - | _, Tm_bvar _ -> failwith "Only locally nameless! We should never see a de Bruijn variable" - - | Tm_type u1, Tm_type u2 -> - solve_one_universe_eq orig u1 u2 wl - - | Tm_arrow {bs=bs1; comp=c1}, Tm_arrow {bs=bs2; comp=c2} -> - let mk_c c = function - | [] -> c - | bs -> mk_Total(mk (Tm_arrow {bs; comp=c}) c.pos) in - - let (bs1, c1), (bs2, c2) = - match_num_binders (bs1, mk_c c1) (bs2, mk_c c2) in - - solve_binders bs1 bs2 orig wl - (fun wl scope subst -> - let c1 = Subst.subst_comp subst c1 in - let c2 = Subst.subst_comp subst c2 in //open both comps - let rel = if (Options.use_eq_at_higher_order()) then EQ else problem.relation in - mk_c_problem wl scope orig c1 rel c2 None "function co-domain") - - | Tm_abs {bs=bs1; body=tbody1; rc_opt=lopt1}, - Tm_abs {bs=bs2; body=tbody2; rc_opt=lopt2} -> - let mk_t t l = function - | [] -> t - | bs -> mk (Tm_abs {bs; body=t; rc_opt=l}) t.pos in - let (bs1, tbody1), (bs2, tbody2) = - match_num_binders (bs1, mk_t tbody1 lopt1) (bs2, mk_t tbody2 lopt2) in - solve_binders bs1 bs2 orig wl - (fun wl scope subst -> - mk_t_problem wl scope orig (Subst.subst subst tbody1) - problem.relation - (Subst.subst subst tbody2) None "lambda co-domain") - - | Tm_refine {b=x1; phi=phi1}, Tm_refine {b=x2; phi=phi2} -> - (* If the heads of their bases can match, make it so, and continue *) - (* The unfolding is very much needed since we might have - * n:nat{phi n} =?= i:int{psi i} - * and if we try to unify the bases, nat and int, we're toast. - * However too much unfolding is also harmful for inference! See - * the discussion on #1345. Hence we reuse head_matches_delta to - * do the unfolding for us, which is good *heuristic* but not - * necessarily always correct. - *) - let env = p_env wl (TProb problem) in - let x1, x2 = - match head_matches_delta env false wl.smt_ok x1.sort x2.sort with - (* We allow (HeadMatch true) since we're gonna unify them again anyway via base_prob *) - | FullMatch, Some (t1, t2) - | HeadMatch _, Some (t1, t2) -> - ({ x1 with sort = t1 }), ({ x2 with sort = t2 }) - | _ -> x1, x2 - in - (* A bit hackish, reconstruct the refinements and flatten them with - as_refinement. *) - let t1 = S.mk (Tm_refine {b=x1; phi=phi1}) t1.pos in - let t2 = S.mk (Tm_refine {b=x2; phi=phi2}) t2.pos in - let x1, phi1 = as_refinement false env t1 in - let x2, phi2 = as_refinement false env t2 in - (* / hack *) - if !dbg_Rel then begin - BU.print3 "ref1 = (%s):(%s){%s}\n" (show x1) - (show x1.sort) - (show phi1); - BU.print3 "ref2 = (%s):(%s){%s}\n" (show x2) - (show x2.sort) - (show phi2) - end; - let base_prob, wl = mk_t_problem wl [] orig x1.sort problem.relation x2.sort problem.element "refinement base type" in - let x1 = freshen_bv x1 in - let subst = [DB(0, x1)] in - let phi1 = Subst.subst subst phi1 in - let phi2 = Subst.subst subst phi2 in - let mk_imp imp phi1 phi2 = imp phi1 phi2 |> guard_on_element wl problem x1 in - let fallback () = - let impl = - if problem.relation = EQ - then mk_imp U.mk_iff phi1 phi2 - else mk_imp U.mk_imp phi1 phi2 in - let guard = U.mk_conj (p_guard base_prob) impl in - def_check_scoped (p_loc orig) "ref.1" (List.map (fun b -> b.binder_bv) (p_scope orig)) (p_guard base_prob); - def_check_scoped (p_loc orig) "ref.2" (List.map (fun b -> b.binder_bv) (p_scope orig)) impl; - let wl = solve_prob orig (Some guard) [] wl in - solve (attempt [base_prob] wl) - in - let has_uvars = - not (Setlike.is_empty (FStar.Syntax.Free.uvars phi1)) - || not (Setlike.is_empty (FStar.Syntax.Free.uvars phi2)) - in - if problem.relation = EQ - || (not env.uvar_subtyping && has_uvars) - then let ref_prob, wl = - mk_t_problem wl [mk_binder x1] orig phi1 EQ phi2 None "refinement formula" - in - let ref_prob = set_logical true ref_prob in - - let tx = UF.new_transaction () in - (* We set wl_implicits to false, since in the success case we will - * extend the original wl with the extra implicits we get, and we - * do not want to duplicate the existing ones. *) - match solve ({wl with defer_ok=NoDefer; - wl_implicits=Listlike.empty; - attempting=[ref_prob]; - wl_deferred=empty}) with - | Failed (prob, msg) -> - UF.rollback tx; - if ((not env.uvar_subtyping && has_uvars) - || not wl.smt_ok) - && not env.unif_allow_ref_guards // if unif_allow_ref_guards is on, we don't give up - then giveup wl msg prob - else fallback() - - | Success (_, defer_to_tac, imps) -> - UF.commit tx; - let guard = - U.mk_conj (p_guard base_prob) - (p_guard ref_prob |> guard_on_element wl problem x1) in - let wl = solve_prob orig (Some guard) [] wl in - let wl = {wl with ctr=wl.ctr+1} in - let wl = extend_wl wl empty defer_to_tac imps in - solve (attempt [base_prob] wl) - else fallback() - - (* flex-flex *) - | Tm_uvar _, Tm_uvar _ - | Tm_app {hd={n=Tm_uvar _}}, Tm_uvar _ - | Tm_uvar _, Tm_app {hd={n=Tm_uvar _}} - | Tm_app {hd={n=Tm_uvar _}}, Tm_app {hd={n=Tm_uvar _}} -> - (* In the case that we have the same uvar on both sides, we cannot - * simply call destruct_flex_t on them, and instead we need to do - * both ensure_no_uvar_subst calls before destructing. - * - * Calling destruct_flex_t would (potentially) first solve the - * head uvar to a fresh one and then return the new one. So, if we - * we were calling destruct_flex_t directly, the second call will - * solve the uvar returned by the first call. We would then pass - * it to to solve_t_flex_flex, causing a crash. - * - * See issue #1616. *) - let env = p_env wl (TProb problem) in - let t1, wl = ensure_no_uvar_subst env t1 wl in - let t2 = U.canon_app t2 in - (* ^ This canon_app call is needed for the incredibly infrequent case - * where t2 is a Tm_app, its head uvar matches that of t1, - * *and* the uvar is solved to an application by the previous - * ensure_no_uvar_subst call. In that case, we get a nested application - * in t2, and the call below would raise an error. *) - let t2, wl = ensure_no_uvar_subst env t2 wl in - let f1 = destruct_flex_t' t1 in - let f2 = destruct_flex_t' t2 in - solve_t_flex_flex env orig wl f1 f2 - - (* flex-rigid equalities *) - | Tm_uvar _, _ - | Tm_app {hd={n=Tm_uvar _}}, _ when (problem.relation=EQ) -> (* just imitate/project ... no slack *) - let f1, wl = destruct_flex_t t1 wl in - solve_t_flex_rigid_eq orig wl f1 t2 - - (* rigid-flex: reorient if it is an equality constraint *) - | _, Tm_uvar _ - | _, Tm_app {hd={n=Tm_uvar _}} when (problem.relation = EQ) -> - solve_t' (invert problem) wl - - (* flex-rigid wrt an arrow: ?u _ <: t1 -> t2 *) - | Tm_uvar _, Tm_arrow _ - | Tm_app {hd={n=Tm_uvar _}}, Tm_arrow _ -> - //FIXME! This is weird; it should be handled by imitate_arrow - //this case is so common, that even though we could delay, it is almost always ok to solve it immediately as an equality - //besides, in the case of arrows, if we delay it, the arity of various terms built by the unifier goes awry - //so, don't delay! - solve_t' ({problem with relation=EQ}) wl - - | _, Tm_uvar _ - | _, Tm_app {hd={n=Tm_uvar _}} - | Tm_uvar _, _ - | Tm_app {hd={n=Tm_uvar _}}, _ -> - //flex-rigid subtyping is handled in the top-loop - solve (attempt [TProb problem] wl) - - | Tm_abs _, _ - | _, Tm_abs _ -> - let is_abs t = match t.n with - | Tm_abs _ -> Inl t - | _ -> Inr t in - begin - let env = p_env wl orig in - match is_abs t1, is_abs t2 with - | Inl t_abs, Inr not_abs - | Inr not_abs, Inl t_abs -> - if is_flex not_abs //if it's a pattern and the free var check succeeds, then unify it with the abstraction in one step - && p_rel orig = EQ - then let flex, wl = destruct_flex_t not_abs wl in - solve_t_flex_rigid_eq orig wl flex t_abs - else begin - match head_matches_delta env false wl.smt_ok not_abs t_abs with - | HeadMatch _, Some (not_abs', _) -> - solve_t ({problem with lhs=not_abs'; rhs=t_abs}) wl - - | _ -> - let head, _ = U.head_and_args not_abs in - if wl.smt_ok - && may_relate wl.tcenv (p_rel orig) head - then let g, wl = mk_eq2 wl orig t_abs not_abs in - solve (solve_prob orig (Some g) [] wl) - else giveup wl (Thunk.mkv "head tag mismatch: RHS is an abstraction") orig - end - - | _ -> failwith "Impossible: at least one side is an abstraction" - end - - | Tm_refine _, _ -> - let t2 = force_refinement <| base_and_refinement (p_env wl orig) t2 in - solve_t' ({problem with rhs=t2}) wl - - | _, Tm_refine _ -> - let t1 = force_refinement <| base_and_refinement (p_env wl orig) t1 in - solve_t' ({problem with lhs=t1}) wl - - | Tm_match {scrutinee=s1;brs=brs1}, Tm_match {scrutinee=s2;brs=brs2} -> //AR: note ignoring the return annotation - let by_smt () = - // using original WL - let guard, wl = guard_of_prob wl problem t1 t2 in - solve (solve_prob orig (Some guard) [] wl) - in - let rec solve_branches wl brs1 brs2 : option (list (binders & prob) & worklist) = - match brs1, brs2 with - | br1::rs1, br2::rs2 -> - let (p1, w1, _) = br1 in - let (p2, w2, _) = br2 in - (* If the patterns differ in shape, just fail *) - if not (eq_pat p1 p2) then None else - - (* Open the first branch, and use that same substitution for the second branch *) - let (p1, w1, e1), s = SS.open_branch' br1 in - let (p2, w2, e2) = br2 in - let w2 = BU.map_opt w2 (SS.subst s) in - let e2 = SS.subst s e2 in - - let scope = List.map S.mk_binder <| S.pat_bvs p1 in - - (* Subproblem for then `when` clause *) - BU.bind_opt ( - match w1, w2 with - | Some _, None - | None, Some _ -> None - | None, None -> Some ([], wl) - | Some w1, Some w2 -> - let p, wl = mk_t_problem wl scope orig w1 EQ w2 None "when clause" in - Some ([scope, p], wl)) - (fun (wprobs, wl) -> - - (* Branch body *) - // GM: Could use problem.relation here instead of EQ? - let prob, wl = mk_t_problem wl scope orig e1 EQ e2 None "branch body" in - if !dbg_Rel - then BU.print2 "Created problem for branches %s with scope %s\n" - (prob_to_string' wl prob) - (show scope); - BU.bind_opt (solve_branches wl rs1 rs2) (fun (r, wl) -> - Some ((scope, prob)::(wprobs @ r), wl))) - - | [], [] -> Some ([], wl) - | _ -> None - in - begin match solve_branches wl brs1 brs2 with - | None -> - if wl.smt_ok - then by_smt () - else giveup wl (Thunk.mkv "Tm_match branches don't match") orig - | Some (sub_probs, wl) -> - let sc_prob, wl = mk_t_problem wl [] orig s1 EQ s2 None "match scrutinee" in - let sub_probs = ([], sc_prob)::sub_probs in - let formula = U.mk_conj_l (List.map (fun (scope, p) -> close_forall (p_env wl orig) scope (p_guard p)) sub_probs) in - let tx = UF.new_transaction () in - let wl = solve_prob orig (Some formula) [] wl in - begin match solve (attempt (List.map snd sub_probs) ({wl with smt_ok = false})) with - | Success (ds, ds', imp) -> - UF.commit tx; - Success (ds, ds', imp) - | Failed _ -> - UF.rollback tx; - if wl.smt_ok - then by_smt () - else giveup wl (Thunk.mkv "Could not unify matches without SMT") orig - end - end - - | Tm_match _, _ - | Tm_uinst _, _ - | Tm_name _, _ - | Tm_constant _, _ - | Tm_fvar _, _ - | Tm_app _, _ - | _, Tm_match _ - | _, Tm_uinst _ - | _, Tm_name _ - | _, Tm_constant _ - | _, Tm_fvar _ - | _, Tm_app _ -> - let head1 = U.head_and_args t1 |> fst in - let head2 = U.head_and_args t2 |> fst in - let _ = - if !dbg_Rel - then BU.print ">> (%s) (smtok=%s)\n>>> head1 = %s [interpreted=%s; no_free_uvars=%s]\n>>> head2 = %s [interpreted=%s; no_free_uvars=%s]\n" - [(show problem.pid); - (show wl.smt_ok); - (show head1); - (show (Env.is_interpreted wl.tcenv head1)); - (show (no_free_uvars t1)); - (show head2); - (show (Env.is_interpreted wl.tcenv head2)); - (show (no_free_uvars t2))] - in - let equal t1 t2 : bool = - (* Try comparing the terms as they are. If we get Equal or NotEqual, - we are done. If we get an Unknown, attempt some normalization. *) - let env = p_env wl orig in - let r = TEQ.eq_tm env t1 t2 in - match r with - | TEQ.Equal -> true - | TEQ.NotEqual -> false - | TEQ.Unknown -> - let steps = [ - Env.UnfoldUntil delta_constant; - Env.Primops; - Env.Beta; - Env.Eager_unfolding; - Env.Iota ] in - let t1 = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.2" steps env t1 in - let t2 = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.3" steps env t2 in - TEQ.eq_tm env t1 t2 = TEQ.Equal - in - if (Env.is_interpreted wl.tcenv head1 || Env.is_interpreted wl.tcenv head2) //we have something like (+ x1 x2) =?= (- y1 y2) - && problem.relation = EQ - then ( - let solve_with_smt () = - let guard, wl = - if equal t1 t2 - then None, wl - else let g, wl = mk_eq2 wl orig t1 t2 in - Some g, wl - in - solve (solve_prob orig guard [] wl) - in - if no_free_uvars t1 // and neither term has any free variables - && no_free_uvars t2 - then - if not wl.smt_ok - || Options.ml_ish () - then if equal t1 t2 - then solve (solve_prob orig None [] wl) - else rigid_rigid_delta problem wl head1 head2 t1 t2 - else solve_with_smt() - else if not wl.smt_ok - || Options.ml_ish() - then rigid_rigid_delta problem wl head1 head2 t1 t2 - else ( - try_solve_then_or_else - wl - (*try*) - (fun wl_empty -> rigid_rigid_delta problem wl_empty head1 head2 t1 t2) - (*then*) - (fun wl -> solve wl) - (*else*) - (fun _ -> solve_with_smt()) - ) - ) - else ( - rigid_rigid_delta problem wl head1 head2 t1 t2 - ) - - - | Tm_let _, Tm_let _ -> - // For now, just unify if they syntactically match - if U.term_eq t1 t2 - then solve (solve_prob orig None [] wl) - else giveup wl (Thunk.mkv "Tm_let mismatch") orig - - | Tm_let _, _ - | _, Tm_let _ -> - raise_error t1 Errors.Fatal_UnificationNotWellFormed - (BU.format4 "Internal error: unexpected flex-flex of %s and %s\n>>> (%s) -- (%s)" - (tag_of t1) (tag_of t2) (show t1) (show t2)) - - | Tm_lazy li1, Tm_lazy li2 when li1.lkind =? li2.lkind - && lazy_complete_repr li1.lkind -> - solve_t' ({problem with lhs = U.unfold_lazy li1; rhs = U.unfold_lazy li2}) wl - - | _ -> giveup wl (Thunk.mk (fun () -> "head tag mismatch: " ^ tag_of t1 ^ " vs " ^ tag_of t2)) orig - -and solve_c (problem:problem comp) (wl:worklist) : solution = - let c1 = problem.lhs in - let c2 = problem.rhs in - let orig = CProb problem in - let env = p_env wl orig in - let sub_prob : worklist -> term -> rel -> term -> string -> prob & worklist = - fun wl t1 rel t2 reason -> mk_t_problem wl [] orig t1 rel t2 None reason in - - let solve_eq c1_comp c2_comp g_lift = - let _ = if !dbg_EQ - then BU.print2 "solve_c is using an equality constraint (%s vs %s)\n" - (show (mk_Comp c1_comp)) - (show (mk_Comp c2_comp)) in - if not (lid_equals c1_comp.effect_name c2_comp.effect_name) - then giveup wl (mklstr (fun () -> BU.format2 "incompatible effects: %s <> %s" - (show c1_comp.effect_name) - (show c2_comp.effect_name))) orig - else if List.length c1_comp.effect_args <> List.length c2_comp.effect_args - then giveup wl (mklstr (fun () -> BU.format2 "incompatible effect arguments: %s <> %s" - (show c1_comp.effect_args) - (show c2_comp.effect_args))) orig - else - let univ_sub_probs, wl = - List.fold_left2 (fun (univ_sub_probs, wl) u1 u2 -> - let p, wl = sub_prob wl - (S.mk (S.Tm_type u1) Range.dummyRange) - EQ - (S.mk (S.Tm_type u2) Range.dummyRange) - "effect universes" in - (univ_sub_probs ++ cons p empty), wl) (empty, wl) c1_comp.comp_univs c2_comp.comp_univs in - let ret_sub_prob, wl = sub_prob wl c1_comp.result_typ EQ c2_comp.result_typ "effect ret type" in - let arg_sub_probs, wl = - List.fold_right2 - (fun (a1, _) (a2, _) (arg_sub_probs, wl) -> - let p, wl = sub_prob wl a1 EQ a2 "effect arg" in - cons p arg_sub_probs, wl) - c1_comp.effect_args - c2_comp.effect_args - (empty, wl) - in - let sub_probs : clist _ = - univ_sub_probs ++ - (cons ret_sub_prob <| - arg_sub_probs ++ - (g_lift.deferred |> CList.map (fun (_, _, p) -> p))) - in - let sub_probs : list _ = to_list sub_probs in - let guard = - let guard = U.mk_conj_l (List.map p_guard sub_probs) in - match g_lift.guard_f with - | Trivial -> guard - | NonTrivial f -> U.mk_conj guard f in - let wl = { wl with wl_implicits = g_lift.implicits ++ wl.wl_implicits } in - let wl = solve_prob orig (Some guard) [] wl in - solve (attempt sub_probs wl) - in - - let should_fail_since_repr_subcomp_not_allowed - (repr_subcomp_allowed:bool) - (c1 c2:lid) : bool - = let c1, c2 = Env.norm_eff_name wl.tcenv c1, Env.norm_eff_name wl.tcenv c2 in - not wl.repr_subcomp_allowed - && not (lid_equals c1 c2) - && Env.is_reifiable_effect wl.tcenv c2 in - // GM: What I would like to write instead of these two - // last conjuncts is something like - // [Option.isSome edge.mlift.mlift_term], - // but it seems that we always carry around a Some - // (fun _ _ e -> e) instead of a None even for - // primitive effects. - - let solve_layered_sub c1 c2 = - if !dbg_LayeredEffectsApp then - BU.print2 "solve_layered_sub c1: %s and c2: %s {\n" - (c1 |> S.mk_Comp |> show) - (c2 |> S.mk_Comp |> show); - - if problem.relation = EQ - then solve_eq c1 c2 Env.trivial_guard - else - let r = Env.get_range wl.tcenv in - - if should_fail_since_repr_subcomp_not_allowed - wl.repr_subcomp_allowed - c1.effect_name - c2.effect_name - then giveup wl (mklstr (fun () -> BU.format2 "Cannot lift from %s to %s, it needs a lift\n" - (string_of_lid c1.effect_name) - (string_of_lid c2.effect_name))) - orig - else - let subcomp_name = BU.format2 "%s <: %s" - (c1.effect_name |> Ident.ident_of_lid |> Ident.string_of_id) - (c2.effect_name |> Ident.ident_of_lid |> Ident.string_of_id) in - - let lift_c1 (edge:edge) : comp_typ & guard_t = - c1 |> S.mk_Comp |> edge.mlift.mlift_wp env - |> (fun (c, g) -> Env.comp_to_comp_typ env c, g) in - - let c1, g_lift, stronger_t_opt, kind, num_eff_params, is_polymonadic = - match Env.exists_polymonadic_subcomp env c1.effect_name c2.effect_name with - | None -> - // there is no polymonadic bind c1 <: c2 - // see if c1 can be lifted to c2 - (match Env.monad_leq env c1.effect_name c2.effect_name with - | None -> - // c1 cannot be lifted to c2, fail - // (sets stronger_t_opt to None) - // - c1, Env.trivial_guard, None, Ad_hoc_combinator, 0, false - | Some edge -> - // there is a way to lift c1 to c2 via edge - let c1, g_lift = lift_c1 edge in - let ed2 = c2.effect_name |> Env.get_effect_decl env in - let tsopt, k = ed2 - |> U.get_stronger_vc_combinator - |> (fun (ts, kopt) -> Env.inst_tscheme_with ts c2.comp_univs |> snd |> Some, kopt |> must) in - let num_eff_params = - match ed2.signature with - | Layered_eff_sig (n, _) -> n - | _ -> failwith "Impossible (expected indexed effect subcomp)" in - c1, g_lift, tsopt, k, num_eff_params, false) - | Some (t, kind) -> - c1, Env.trivial_guard, - Env.inst_tscheme_with t c2.comp_univs |> snd |> Some, - kind, - 0, - true in - - if is_none stronger_t_opt - then giveup wl (mklstr (fun () -> BU.format2 "incompatible monad ordering: %s must in - // we will account for g_lift logical guard later - let wl = extend_wl wl g_lift.deferred g_lift.deferred_to_tac g_lift.implicits in - - if is_polymonadic && - Env.is_erasable_effect env c1.effect_name && - not (Env.is_erasable_effect env c2.effect_name) && - not (N.non_info_norm env c1.result_typ) - then Errors.raise_error r Errors.Error_TypeError - (BU.format3 "Cannot lift erasable expression from %s ~> %s since its type %s is informative" - (string_of_lid c1.effect_name) - (string_of_lid c2.effect_name) - (show c1.result_typ)); - - (* - * AR: 04/08: Suppose we have a subcomp problem of the form: - * M a ?u <: M a wp or M a wp <: M a ?u - * - * If we simply applied the stronger (subcomp) combinator, - * there is a chance that the uvar would escape into the - * refinements/wp and remain unresolved - * - * So, if this is the case (i.e. an effect index on one side is a uvar) - * we solve this particular index with equality ?u = wp - * - * There are two exceptions: - * If it is a polymonadic subcomp (the indices may not be symmetric) - * If uvar is to be solved using a user-defined tactic - * - * TODO: apply this equality heuristic to non-layered effects also - *) - - //sub problems for uvar indices in c1 - let is_sub_probs, wl = - if is_polymonadic then [], wl - else - let rec is_uvar t = //t is a uvar that is not to be solved by a user tactic - match (SS.compress t).n with - | Tm_uvar (uv, _) -> - not (DeferredImplicits.should_defer_uvar_to_user_tac env uv) - | Tm_uinst (t, _) -> is_uvar t - | Tm_app {hd=t} -> is_uvar t - | _ -> false in - List.fold_right2 (fun (a1, _) (a2, _) (is_sub_probs, wl) -> - if is_uvar a1 - then begin - if !dbg_LayeredEffectsEqns then - BU.print2 "Layered Effects teq (rel c1 index uvar) %s = %s\n" - (show a1) (show a2); - let p, wl = sub_prob wl a1 EQ a2 "l.h.s. effect index uvar" in - p::is_sub_probs, wl - end - else is_sub_probs, wl - ) c1.effect_args c2.effect_args ([], wl) in - - //return type sub problem - let ret_sub_prob, wl = sub_prob wl c1.result_typ problem.relation c2.result_typ "result type" in - - let bs, subcomp_c = U.arrow_formals_comp stronger_t in - - let fml, sub_probs, wl = - if kind = Ad_hoc_combinator - then apply_ad_hoc_indexed_subcomp env bs subcomp_c c1 c2 sub_prob wl subcomp_name r - else apply_substitutive_indexed_subcomp env kind bs subcomp_c c1 c2 sub_prob - num_eff_params - wl - subcomp_name r in - - let sub_probs = ret_sub_prob::(is_sub_probs@sub_probs) in - - let guard = - let guard = U.mk_conj_l (List.map p_guard sub_probs) in - let guard = - match g_lift.guard_f with - | Trivial -> guard - | NonTrivial f -> U.mk_conj guard f in - U.mk_conj guard fml in - - let wl = solve_prob orig (Some guard) [] wl in - if !dbg_LayeredEffectsApp - then BU.print_string "}\n"; - solve (attempt sub_probs wl) in - - let solve_sub c1 edge c2 = - if problem.relation <> SUB then - failwith "impossible: solve_sub"; - let r = Env.get_range env in - let lift_c1 () = - let univs = - match c1.comp_univs with - | [] -> [env.universe_of env c1.result_typ] - | x -> x in - let c1 = { c1 with comp_univs = univs } in - ({ c1 with comp_univs = univs }) - |> S.mk_Comp - |> edge.mlift.mlift_wp env - |> (fun (c, g) -> - if not (Env.is_trivial g) - then raise_error r Errors.Fatal_UnexpectedEffect - (BU.format2 "Lift between wp-effects (%s~>%s) should not have returned a non-trivial guard" - (show c1.effect_name) (show c2.effect_name)) - else Env.comp_to_comp_typ env c) - in - if should_fail_since_repr_subcomp_not_allowed - wl.repr_subcomp_allowed - c1.effect_name - c2.effect_name - then giveup wl (mklstr (fun () -> BU.format2 "Cannot lift from %s to %s, it needs a lift\n" - (string_of_lid c1.effect_name) - (string_of_lid c2.effect_name))) - orig - else let is_null_wp_2 = c2.flags |> BU.for_some (function TOTAL | MLEFFECT | SOMETRIVIAL -> true | _ -> false) in - let wpc1, wpc2 = match c1.effect_args, c2.effect_args with - | (wp1, _)::_, (wp2, _)::_ -> wp1, wp2 - | _ -> - raise_error env Errors.Fatal_ExpectNormalizedEffect - (BU.format2 "Got effects %s and %s, expected normalized effects" (show c1.effect_name) (show c2.effect_name)) - in - - if BU.physical_equality wpc1 wpc2 - then solve_t (problem_using_guard orig c1.result_typ problem.relation c2.result_typ None "result type") wl - else let c2_decl, qualifiers = must (Env.effect_decl_opt env c2.effect_name) in - if qualifiers |> List.contains Reifiable - then let c1_repr = - norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.4" - [Env.UnfoldUntil delta_constant; Env.Weak; Env.HNF] env - (Env.reify_comp env (S.mk_Comp (lift_c1 ())) (env.universe_of env c1.result_typ)) - in - let c2_repr = - norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.5" - [Env.UnfoldUntil delta_constant; Env.Weak; Env.HNF] env - (Env.reify_comp env (S.mk_Comp c2) (env.universe_of env c2.result_typ)) - in - let prob, wl = - sub_prob wl c1_repr problem.relation c2_repr - (BU.format2 "sub effect repr: %s <: %s" - (show c1_repr) - (show c2_repr)) - in - let wl = solve_prob orig (Some (p_guard prob)) [] wl in - solve (attempt [prob] wl) - else - let g = - if Options.lax () then - U.t_true - else let wpc1_2 = lift_c1 () |> (fun ct -> List.hd ct.effect_args) in - if is_null_wp_2 - then let _ = if !dbg_Rel - then BU.print_string "Using trivial wp ... \n" in - let c1_univ = env.universe_of env c1.result_typ in - let trivial = - match c2_decl |> U.get_wp_trivial_combinator with - | None -> failwith "Rel doesn't yet handle undefined trivial combinator in an effect" - | Some t -> t in - mk (Tm_app {hd=inst_effect_fun_with [c1_univ] env c2_decl trivial; - args=[as_arg c1.result_typ; wpc1_2]}) r - else let c2_univ = env.universe_of env c2.result_typ in - let stronger = c2_decl |> U.get_stronger_vc_combinator |> fst in - mk (Tm_app {hd=inst_effect_fun_with [c2_univ] env c2_decl stronger; - args=[as_arg c2.result_typ; as_arg wpc2; wpc1_2]}) r in - if !dbg_Rel then - BU.print1 "WP guard (simplifed) is (%s)\n" (show (N.normalize [Env.Iota; Env.Eager_unfolding; Env.Primops; Env.Simplify] env g)); - let base_prob, wl = sub_prob wl c1.result_typ problem.relation c2.result_typ "result type" in - let wl = solve_prob orig (Some <| U.mk_conj (p_guard base_prob) g) [] wl in - solve (attempt [base_prob] wl) - in - - if BU.physical_equality c1 c2 - then solve (solve_prob orig None [] wl) - else let _ = if !dbg_Rel - then BU.print3 "solve_c %s %s %s\n" - (show c1) - (rel_to_string problem.relation) - (show c2) in - - //AR: 10/18: try ghost to pure promotion only if effects are different - - let c1, c2 = - let eff1, eff2 = - c1 |> U.comp_effect_name |> Env.norm_eff_name env, - c2 |> U.comp_effect_name |> Env.norm_eff_name env in - if Ident.lid_equals eff1 eff2 - then c1, c2 - else N.ghost_to_pure2 env (c1, c2) in - - match c1.n, c2.n with - | GTotal t1, Total t2 when (Env.non_informative env t2) -> - solve_t (problem_using_guard orig t1 problem.relation t2 None "result type") wl - - | GTotal _, Total _ -> - giveup wl (Thunk.mkv "incompatible monad ordering: GTot //rigid-rigid 1 - solve_t (problem_using_guard orig t1 problem.relation t2 None "result type") wl - - | Total t1, GTotal t2 when problem.relation = SUB -> - solve_t (problem_using_guard orig t1 problem.relation t2 None "result type") wl - - | Total t1, GTotal t2 -> - giveup wl (Thunk.mkv "GTot =/= Tot") orig - - | GTotal _, Comp _ - | Total _, Comp _ -> - solve_c ({problem with lhs=mk_Comp <| Env.comp_to_comp_typ env c1}) wl - - | Comp _, GTotal _ - | Comp _, Total _ -> - solve_c ({problem with rhs=mk_Comp <| Env.comp_to_comp_typ env c2}) wl - - | Comp _, Comp _ -> - if (U.is_ml_comp c1 && U.is_ml_comp c2) - || (U.is_total_comp c1 && U.is_total_comp c2) - || (U.is_total_comp c1 && U.is_ml_comp c2 && problem.relation=SUB) - then solve_t (problem_using_guard orig (U.comp_result c1) problem.relation (U.comp_result c2) None "result type") wl - else let c1_comp = Env.comp_to_comp_typ env c1 in - let c2_comp = Env.comp_to_comp_typ env c2 in - if problem.relation=EQ - then let c1_comp, c2_comp = - if lid_equals c1_comp.effect_name c2_comp.effect_name - then c1_comp, c2_comp - else Env.unfold_effect_abbrev env c1, - Env.unfold_effect_abbrev env c2 in - solve_eq c1_comp c2_comp Env.trivial_guard - else begin - let c1 = Env.unfold_effect_abbrev env c1 in - let c2 = Env.unfold_effect_abbrev env c2 in - if !dbg_Rel then BU.print2 "solve_c for %s and %s\n" (string_of_lid c1.effect_name) (string_of_lid c2.effect_name); - if Env.is_layered_effect env c2.effect_name then solve_layered_sub c1 c2 - else - match Env.monad_leq env c1.effect_name c2.effect_name with - | None -> - giveup wl (mklstr (fun () -> BU.format2 "incompatible monad ordering: %s - solve_sub c1 edge c2 - end - -(* -------------------------------------------------------- *) -(* top-level interface *) -(* -------------------------------------------------------- *) -let print_pending_implicits g = - g.implicits |> CList.map (fun i -> show i.imp_uvar) |> show - -let ineqs_to_string (ineqs : clist universe & clist (universe & universe)) = - let (vars, ineqs) = ineqs in - let ineqs = ineqs |> CList.map (fun (u1, u2) -> BU.format2 "%s < %s" (show u1) (show u2)) in - BU.format2 "Solving for %s; inequalities are %s" - (show vars) (show ineqs) - -let guard_to_string (env:env) g = - match g.guard_f, view g.deferred with - | Trivial, VNil when not (Options.print_implicits ()) && is_empty (snd g.univ_ineqs) -> "{}" - | _ -> - let form = match g.guard_f with - | Trivial -> "trivial" - | NonTrivial f -> - if !dbg_Rel - || Debug.extreme () - || Options.print_implicits () - then N.term_to_string env f - else "non-trivial" - in - let carry defs = CList.map (fun (_, msg, x) -> msg ^ ": " ^ prob_to_string env x) defs |> to_list |> String.concat ",\n" in - let imps = print_pending_implicits g in - BU.format5 "\n\t{guard_f=%s;\n\t deferred={\n%s};\n\t deferred_to_tac={\n%s};\n\t univ_ineqs={%s};\n\t implicits=%s}\n" - form (carry g.deferred) (carry g.deferred_to_tac) - (ineqs_to_string g.univ_ineqs) imps - -let new_t_problem wl env lhs rel rhs elt loc = - let reason = if !dbg_ExplainRel - || !dbg_Rel - then BU.format3 "Top-level:\n%s\n\t%s\n%s" - (N.term_to_string env lhs) (rel_to_string rel) - (N.term_to_string env rhs) - else "TOP" in - let p, wl = new_problem wl env lhs rel rhs elt loc reason in - def_check_prob ("new_t_problem." ^ reason) (TProb p); - TProb p, wl - -let new_t_prob wl env t1 rel t2 = - let x = S.new_bv (Some <| Env.get_range env) t1 in - let p, wl = new_t_problem wl env t1 rel t2 (Some x) (Env.get_range env) in - p, x, wl - -let solve_and_commit wl err - : option (deferred & deferred & implicits_t) = - let tx = UF.new_transaction () in - - if !dbg_RelBench then - BU.print1 "solving problems %s {\n" - (FStar.Common.string_of_list (fun p -> string_of_int (p_pid p)) wl.attempting); - let (sol, ms) = BU.record_time (fun () -> solve wl) in - if !dbg_RelBench then - BU.print1 "} solved in %s ms\n" (string_of_int ms); - - match sol with - | Success (deferred, defer_to_tac, implicits) -> - let ((), ms) = BU.record_time (fun () -> UF.commit tx) in - if !dbg_RelBench then - BU.print1 "committed in %s ms\n" (string_of_int ms); - Some (deferred, defer_to_tac, implicits) - | Failed (d,s) -> - if !dbg_ExplainRel - || !dbg_Rel - then BU.print_string <| explain wl d s; - let result = err (d,s) in - UF.rollback tx; - result - -let with_guard env prob dopt = - match dopt with - | None -> None - | Some (deferred, defer_to_tac, implicits) -> - def_check_scoped (p_loc prob) "with_guard" env (p_guard prob); - Some <| simplify_guard env - ({guard_f=(p_guard prob |> NonTrivial); - deferred=deferred; - deferred_to_tac=defer_to_tac; - univ_ineqs=(empty, empty); - implicits=implicits}) - -let try_teq smt_ok env t1 t2 : option guard_t = - def_check_scoped t1.pos "try_teq.1" env t1; - def_check_scoped t2.pos "try_teq.2" env t2; - // --MLish disables use of SMT. See PR #3123 for explanation. - let smt_ok = smt_ok && not (Options.ml_ish ()) in - Profiling.profile - (fun () -> - if !dbg_RelTop then - BU.print3 "try_teq of %s and %s in %s {\n" (show t1) (show t2) (show env.gamma); - let prob, wl = new_t_problem (empty_worklist env) env t1 EQ t2 None (Env.get_range env) in - let g = with_guard env prob <| solve_and_commit (singleton wl prob smt_ok) (fun _ -> None) in - if !dbg_RelTop then - BU.print1 "} res = %s\n" (FStar.Common.string_of_option (guard_to_string env) g); - g) - (Some (Ident.string_of_lid (Env.current_module env))) - "FStar.TypeChecker.Rel.try_teq" - - -let teq env t1 t2 : guard_t = - match try_teq true env t1 t2 with - | None -> - Err.basic_type_error env env.range None t2 t1; - trivial_guard - | Some g -> - if !dbg_Rel || !dbg_RelTop then - BU.print3 "teq of %s and %s succeeded with guard %s\n" - (show t1) (show t2) (guard_to_string env g); - g - -(* - * AR: It would be nice to unify it with teq, the way we do it for subtyping - * i.e. write a common function that uses a bound variable, - * and if the caller requires a prop, close over it, else abstract it - * But that may change the existing VCs shape a bit - *) -let get_teq_predicate env t1 t2 = - if !dbg_Rel || !dbg_RelTop then - BU.print2 "get_teq_predicate of %s and %s {\n" (show t1) (show t2); - let prob, x, wl = new_t_prob (empty_worklist env) env t1 EQ t2 in - let g = with_guard env prob <| solve_and_commit (singleton wl prob true) (fun _ -> None) in - if !dbg_Rel || !dbg_RelTop then - BU.print1 "} res teq predicate = %s\n" (FStar.Common.string_of_option (guard_to_string env) g); - - match g with - | None -> None - | Some g -> Some (abstract_guard (S.mk_binder x) g) - -let subtype_fail env e t1 t2 : unit = - Err.basic_type_error env (Env.get_range env) (Some e) t2 t1 - -let sub_or_eq_comp env (use_eq:bool) c1 c2 = - Profiling.profile (fun () -> - let rel = if use_eq then EQ else SUB in - if !dbg_Rel || !dbg_RelTop then - BU.print3 "sub_comp of %s --and-- %s --with-- %s\n" (show c1) (show c2) (if rel = EQ then "EQ" else "SUB"); - let prob, wl = new_problem (empty_worklist env) env c1 rel c2 None (Env.get_range env) "sub_comp" in - let wl = { wl with repr_subcomp_allowed = true } in - let prob = CProb prob in - def_check_prob "sub_comp" prob; - let (r, ms) = BU.record_time - (fun () -> with_guard env prob <| solve_and_commit (singleton wl prob true) (fun _ -> None)) - in - if !dbg_Rel || !dbg_RelTop || !dbg_RelBench then - BU.print4 "sub_comp of %s --and-- %s --with-- %s --- solved in %s ms\n" (show c1) (show c2) (if rel = EQ then "EQ" else "SUB") (string_of_int ms); - r) - (Some (Ident.string_of_lid (Env.current_module env))) - "FStar.TypeChecker.Rel.sub_comp" - -let sub_comp env c1 c2 = - Errors.with_ctx "While trying to subtype computation types" (fun () -> - def_check_scoped c1.pos "sub_comp c1" env c1; - def_check_scoped c2.pos "sub_comp c2" env c2; - sub_or_eq_comp env false c1 c2 - ) - -let eq_comp env c1 c2 = - Errors.with_ctx "While trying to equate computation types" (fun () -> - def_check_scoped c1.pos "eq_comp c1" env c1; - def_check_scoped c2.pos "eq_comp c2" env c2; - sub_or_eq_comp env true c1 c2 - ) - -val solve_universe_inequalities' (tx:UF.tx) (env : env_t) (vs_ineqs : clist S.universe & clist (S.universe & S.universe)) : unit -let solve_universe_inequalities' tx env (variables, ineqs) : unit = - //variables: ?u1, ..., ?un are the universes of the inductive types we're trying to compute - //ineqs: u1 < v1, ..., un < vn are inequality constraints gathered from checking the inductive definition - //The basic idea is to collect all lowerbounds of each variable ?ui, - // excluding all of the variables themselves to avoid cycles - // and setting each ?ui to max(lowerbounds(?ui)) - //Then, we make a pass over all the inequalities again and check that they are all satisfied - //This ensures, e.g., that we don't needlessly generalize types, avoid issues lik #806 - let fail u1 u2 = - UF.rollback tx; - raise_error env Errors.Fatal_IncompatibleUniverse - (BU.format2 "Universe %s and %s are incompatible" (show u1) (show u2)) - in - let equiv v v' = - match SS.compress_univ v, SS.compress_univ v' with - | U_unif v0, U_unif v0' -> UF.univ_equiv v0 v0' - | _ -> false - in - let sols : clist (S.universe & S.universe) = variables |> CList.collect (fun v -> - match SS.compress_univ v with - | U_unif _ -> //if it really is a variable, that try to solve it - let lower_bounds_of_v : clist S.universe = //lower bounds of v, excluding the other variables - ineqs |> CList.collect (fun (u, v') -> - if equiv v v' - then if variables |> CList.existsb (equiv u) - then empty - else cons u empty - else empty) - in - let lb = N.normalize_universe env (U_max (lower_bounds_of_v |> to_list)) in - Listlike.singleton (lb, v) - | _ -> - //it may not actually be a variable in case the user provided an explicit universe annnotation - //see, e.g., ulib/FStar.Universe.fst - empty) in - //apply all the solutions - let _ = - let wl = {empty_worklist env with defer_ok=NoDefer} in - sols |> CList.map (fun (lb, v) -> - // printfn "Setting %s to its lower bound %s" (show v) (show lb); - match solve_universe_eq (-1) wl lb v with - | USolved wl -> () - | _ -> fail lb v) - in - //check that the solutions produced valid inequalities - let rec check_ineq (u, v) : bool = - let u = N.normalize_universe env u in - let v = N.normalize_universe env v in - match u, v with - | U_zero, _ -> true - | U_succ u0, U_succ v0 -> check_ineq (u0, v0) - | U_name u0, U_name v0 -> Ident.ident_equals u0 v0 - | U_unif u0, U_unif v0 -> UF.univ_equiv u0 v0 - | U_name _, U_succ v0 - | U_unif _, U_succ v0 -> check_ineq (u, v0) - | U_max us, _ -> us |> BU.for_all (fun u -> check_ineq (u, v)) - | _, U_max vs -> vs |> BU.for_some (fun v -> check_ineq (u, v)) - | _ -> false - in - if ineqs |> CList.for_all (fun (u, v) -> - if check_ineq (u, v) - then true - else (if !dbg_GenUniverses - then BU.print2 "%s - Profiling.profile (fun () -> - let imps_l = g.implicits |> Listlike.to_list in - let typeclass_variables = - imps_l - |> List.collect - (fun i -> - match i.imp_uvar.ctx_uvar_meta with - | Some (Ctx_uvar_meta_tac tac) -> - let head, _ = U.head_and_args_full tac in - if U.is_fvar PC.tcresolve_lid head - then ( - let goal_type = U.ctx_uvar_typ i.imp_uvar in - let uvs = Free.uvars goal_type in - elems uvs - ) - else [] - | _ -> []) |> Setlike.from_list - in - let wl = { wl_of_guard env (to_list g.deferred) - with defer_ok=defer_ok - ; smt_ok=smt_ok - ; typeclass_variables } in - let fail (d,s) = - let msg = explain wl d s in - raise_error (p_loc d) Errors.Fatal_ErrorInSolveDeferredConstraints msg - in - if !dbg_Rel then - BU.print4 "Trying to solve carried problems (defer_ok=%s) (deferred_to_tac_ok=%s): begin\n\t%s\nend\n and %s implicits\n" - (show defer_ok) - (show deferred_to_tac_ok) - (show wl) - (show (List.length imps_l)); - let g = - match solve_and_commit wl fail with - | Some (deferred, _, _) when VCons? (view deferred) && defer_ok = NoDefer -> - failwith "Impossible: Unexpected deferred constraints remain" - - | Some (deferred, defer_to_tac, imps) -> - {g with deferred=deferred; - deferred_to_tac=g.deferred_to_tac ++ defer_to_tac; - implicits = g.implicits ++ imps} - - | _ -> - failwith "Impossible: should have raised a failure already" - in - solve_universe_inequalities env g.univ_ineqs; - let g = - if deferred_to_tac_ok - then Profiling.profile (fun () -> DeferredImplicits.solve_deferred_to_tactic_goals env g) - (Some (Ident.string_of_lid (Env.current_module env))) - "FStar.TypeChecker.Rel.solve_deferred_to_tactic_goals" - else g - in - if !dbg_ResolveImplicitsHook - then BU.print2 "ResolveImplicitsHook: Solved deferred to tactic goals, remaining guard is\n%s (and %s implicits)\n" - (guard_to_string env g) - (show (List.length (Listlike.to_list g.implicits))); - {g with univ_ineqs=(empty, empty)} - ) - (Some (Ident.string_of_lid (Env.current_module env))) - "FStar.TypeChecker.Rel.try_solve_deferred_constraints") - - -let solve_deferred_constraints env (g:guard_t) = - let defer_ok = NoDefer in - let smt_ok = not (Options.ml_ish ()) in - let deferred_to_tac_ok = true in - try_solve_deferred_constraints defer_ok smt_ok deferred_to_tac_ok env g - -let solve_non_tactic_deferred_constraints maybe_defer_flex_flex env (g:guard_t) = - Errors.with_ctx "solve_non_tactic_deferred_constraints" (fun () -> - def_check_scoped Range.dummyRange "solve_non_tactic_deferred_constraints.g" env g; - let defer_ok = if maybe_defer_flex_flex then DeferFlexFlexOnly else NoDefer in - let smt_ok = not (Options.ml_ish ()) in - let deferred_to_tac_ok = false in - try_solve_deferred_constraints defer_ok smt_ok deferred_to_tac_ok env g - ) - -let do_discharge_vc use_env_range_msg env vc : unit = - let open FStar.Pprint in - let open FStar.Errors.Msg in - let open FStar.Class.PP in - let debug : bool = !dbg_Rel || !dbg_SMTQuery || !dbg_Discharge in - let diag = Errors.diag (Env.get_range env) #(list document) in // FIXME: without the implicit, batch mode fails during generalization - if debug then - diag [text "Checking VC:" ^/^ pp vc]; - - (* Tactic preprocessing *) - let vcs : list (env_t & typ & Options.optionstate) = ( - if Options.use_tactics() then begin - Options.with_saved_options (fun () -> - ignore <| Options.set_options "--no_tactics"; - let did_anything, vcs = env.solver.preprocess env vc in - if debug && did_anything then - diag [text "Tactic preprocessing produced" ^/^ pp (List.length vcs <: int) ^/^ text "goals"]; - let vcs = vcs |> List.map (fun (env, goal, opts) -> - // NB: No Eager_unfolding. Why? - env, - norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.7" - [Env.Simplify; Env.Primops; Env.Exclude Env.Zeta] env goal, - opts) - in - - (* handle_smt_goals: users can register a tactic to run on all - remaining goals after tactic execution. *) - let vcs = vcs |> List.concatMap (fun (env, goal, opts) -> - env.solver.handle_smt_goal env goal |> - (* Keep the same SMT options *) - List.map (fun (env, goal) -> (env, goal, opts))) - in - - (* discard trivial goals *) - let vcs = vcs |> List.concatMap (fun (env, goal, opts) -> - match check_trivial goal with - | Trivial -> - if debug then - diag [text "Goal completely solved by tactic\n"]; - [] - - | NonTrivial goal -> - [(env, goal, opts)] - ) - in - vcs - ) - end - else [env, vc, FStar.Options.peek ()] - ) - in - - (* Splitting queries. FIXME: isn't this redundant given the - code in SMTEncoding.Solver? *) - let vcs = - if Options.split_queries () = Options.Always - then vcs |> - List.collect - (fun (env, goal, opts) -> - match Env.split_smt_query env goal with - | None -> [env,goal,opts] - | Some goals -> goals |> List.map (fun (env, goal) -> env,goal,opts)) - else vcs - in - - (* Solve one by one. If anything fails the SMT module will log errors. *) - vcs |> List.iter (fun (env, goal, opts) -> - Options.with_saved_options (fun () -> - FStar.Options.set opts; - (* diag (BU.format2 "Trying to solve:\n> %s\nWith proof_ns:\n %s\n" *) - (* (show goal) (Env.string_of_proof_ns env)); *) - if debug then - diag [text "Before calling solver, VC =" ^/^ pp goal]; - env.solver.solve use_env_range_msg env goal - ) - ) - -// Discharge (the logical part of) a guard [g]. -// -// The `use_smt` flag says whether to use the smt solver to discharge -// this guard -// -// - If use_smt = true, this function NEVER returns None, and can be -// considered to have successfully discharged the guard. However, -// it could have logged an SMT error. The VC (aka the logical part -// of the guard) is preprocessed with tactics before discharging: -// every subterm wrapped with `with_tactic` has the tactic run on it -// and a separate VC is generated for it. They are then discharged -// sequentially. -// -// - If use_smt = false, then None means could not discharge the guard -// without using smt. The procedure is to just normalize and simplify -// the VC and check that it is [True]. -// -// In every case, when this function returns [Some g], then the logical -// part of [g] is [Trivial]. -let discharge_guard' use_env_range_msg env (g:guard_t) (use_smt:bool) : option guard_t = - if !dbg_ResolveImplicitsHook - then BU.print1 "///////////////////ResolveImplicitsHook: discharge_guard'\n\ - guard = %s\n" - (guard_to_string env g); - - let g = - let defer_ok = NoDefer in - let smt_ok = not (Options.ml_ish ()) && use_smt in - let deferred_to_tac_ok = true in - try_solve_deferred_constraints defer_ok smt_ok deferred_to_tac_ok env g - in - let open FStar.Pprint in - let open FStar.Errors.Msg in - let open FStar.Class.PP in - let debug : bool = !dbg_Rel || !dbg_SMTQuery || !dbg_Discharge in - let diag = Errors.diag (Env.get_range env) #(list document) in - let ret_g = {g with guard_f = Trivial} in - if env.admit then ( - let open FStar.Class.PP in - if debug && not (Trivial? g.guard_f) && not env.phase1 then - diag [ - text "Skipping VC because verification is disabled."; - text "VC =" ^/^ pp g; - ]; - Some ret_g - ) else ( - let g = simplify_guard_full_norm env g in - match g.guard_f with - | Trivial -> - Some ret_g - - | NonTrivial vc when not use_smt -> - if debug then - diag [text "Cannot solve without SMT:" ^/^ pp vc]; - None - - | NonTrivial vc -> - do_discharge_vc use_env_range_msg env vc; - Some ret_g - ) - -let discharge_guard env g = - match discharge_guard' None env g true with - | Some g -> g - | None -> failwith "Impossible, with use_smt = true, discharge_guard' should never have returned None" - -let discharge_guard_no_smt env g = - match discharge_guard' None env g false with - | Some g -> g - | None -> - raise_error env Errors.Fatal_ExpectTrivialPreCondition [ - text "Expected a trivial pre-condition" - ] - -let teq_nosmt (env:env) (t1:typ) (t2:typ) : option guard_t = - match try_teq false env t1 t2 with - | None -> None - | Some g -> discharge_guard' None env g false - -let subtype_nosmt env t1 t2 = - if !dbg_Rel || !dbg_RelTop - then BU.print2 "try_subtype_no_smt of %s and %s\n" (N.term_to_string env t1) (N.term_to_string env t2); - let prob, x, wl = new_t_prob (empty_worklist env) env t1 SUB t2 in - let g = with_guard env prob <| solve_and_commit (singleton wl prob false) (fun _ -> None) in - match g with - | None -> None - | Some g -> - let g = close_guard env [S.mk_binder x] g in - discharge_guard' None env g false - -/////////////////////////////////////////////////////////////////// -let check_subtyping env t1 t2 = - Profiling.profile (fun () -> - if !dbg_Rel || !dbg_RelTop - then BU.print2 "check_subtyping of %s and %s\n" (N.term_to_string env t1) (N.term_to_string env t2); - let prob, x, wl = new_t_prob (empty_worklist env) env t1 SUB t2 in - let env_x = Env.push_bv env x in - let smt_ok = not (Options.ml_ish ()) in - let g = with_guard env_x prob <| solve_and_commit (singleton wl prob smt_ok) (fun _ -> None) in - match g with - | None -> ( - if !dbg_Rel || !dbg_RelTop then - BU.print2 "check_subtyping FAILED: %s <: %s\n" - (N.term_to_string env_x t1) - (N.term_to_string env_x t2); - None - ) - | Some g -> ( - if !dbg_Rel || !dbg_RelTop then - BU.print3 "check_subtyping succeeded: %s <: %s\n\tguard is %s\n" - (N.term_to_string env_x t1) - (N.term_to_string env_x t2) - (guard_to_string env_x g); - Some (x, g) - ) - ) - (Some (Ident.string_of_lid (Env.current_module env))) - "FStar.TypeChecker.Rel.check_subtyping" - -let get_subtyping_predicate env t1 t2 = - Errors.with_ctx "While trying to get a subtyping predicate" (fun () -> - def_check_scoped t1.pos "get_subtyping_predicate.1" env t1; - def_check_scoped t2.pos "get_subtyping_predicate.2" env t2; - match check_subtyping env t1 t2 with - | None -> None - | Some (x, g) -> - Some (abstract_guard (S.mk_binder x) g) - ) - -let get_subtyping_prop env t1 t2 = - Errors.with_ctx "While trying to get a subtyping proposition" (fun () -> - def_check_scoped t1.pos "get_subtyping_prop.1" env t1; - def_check_scoped t2.pos "get_subtyping_prop.2" env t2; - match check_subtyping env t1 t2 with - | None -> None - | Some (x, g) -> - Some (close_guard env [S.mk_binder x] g) - ) - -(* - * Solve the uni-valued implicits - * - * For now we handle only unit and unit refinement typed implicits, - * we can later extend it to single constructor inductives - * - * This function gets the unresolved implicits from the main resolve_implicits' - * function - * - * It only sets the value of the implicit's ctx uvar in the UF graph - * -- leaving their typechecking to resolve_implicits' - * - * E.g. for a ?u:squash phi, this will only set ?u=unit in the UF graph, - * and, as usual, resolve_implicits' will check that G |= phi - * - * It returns a boolean (true if at least one implicit was solved) - * and the set of new implicits, right now this set is same as imps, - * for inductives, this may later include implicits for pattern variables - *) - -let try_solve_single_valued_implicits env is_tac (imps:Env.implicits) : Env.implicits & bool = - (* - * Get the value of the implicit imp - * Going forward, it can also return new implicits for the pattern variables - * (cf. the comment above about extending it to inductives) - *) - if is_tac then imps, false - else - let imp_value imp : option term = - let ctx_u, r = imp.imp_uvar, imp.imp_range in - - let t_norm = N.normalize N.whnf_steps env (U.ctx_uvar_typ ctx_u) in - - match (SS.compress t_norm).n with - | Tm_fvar fv when S.fv_eq_lid fv PC.unit_lid -> - r |> S.unit_const_with_range |> Some - | Tm_refine {b} when U.is_unit b.sort -> - r |> S.unit_const_with_range |> Some - | _ -> None in - - let b = List.fold_left (fun b imp -> //check that the imp is still unsolved - if UF.find imp.imp_uvar.ctx_uvar_head |> is_none && - U.ctx_uvar_should_check imp.imp_uvar = Strict - then match imp_value imp with - | Some tm -> commit env ([TERM (imp.imp_uvar, tm)]); true - | None -> b - else b) false imps in - - imps, b - -(* - * Check that an implicit solution has the expected type - * - * Return None if we did not typecheck the implicit because - * typechecking it required solving deferred univ constraints, - * and the flag force_univ_constraints is not set - * - * Invariants: - * - If force_univ_constraints is set, return is a Some - * - If is_tac is true, return is Some [] - * - The caller (resolve_implicits') ensures that - * if is_tac then force_univ_constraints - * - *) -let check_implicit_solution_and_discharge_guard env - (imp:implicit) - (is_tac force_univ_constraints:bool) - - : option TcComm.implicits_t = - - let {imp_reason; imp_tm; imp_uvar; imp_range} = imp in - - let uvar_ty = U.ctx_uvar_typ imp_uvar in - let uvar_should_check = U.ctx_uvar_should_check imp_uvar in - - if !dbg_Rel - then BU.print5 "Checking uvar %s resolved to %s at type %s, introduce for %s at %s\n" - (show imp_uvar.ctx_uvar_head) - (show imp_tm) - (show uvar_ty) - imp_reason - (Range.string_of_range imp_range); - - let env = - {env with gamma=imp_uvar.ctx_uvar_gamma} - |> Env.clear_expected_typ - |> fst in - - let g = - Errors.with_ctx - "While checking implicit solution" - (fun () -> - let skip_core = - env.phase1 || - env.admit || - Allow_untyped? uvar_should_check || - Already_checked? uvar_should_check in - - let must_tot = not (env.phase1 || - env.admit || - Allow_ghost? uvar_should_check) in - - if skip_core - then if is_tac - then Env.trivial_guard - else begin // following is ad-hoc code for constraining some univs - // ideally we should get rid of it, and just return trivial_guard - (* - * AR: when we create lambda terms as solutions to implicits (in u_abs), - * we set the type in the residual comp to be the type of the uvar - * while this ok for smt encoding etc., when we are typechecking the implicit solution using fastpath, - * it doesn't help since the two types are the same (the type of the uvar and its solution) - * worse, this prevents some constraints to be generated between the actual type of the solution - * and the type of the uvar - * therefore, we unset the residual comp type in the solution before typechecking - *) - let imp_tm = - match (SS.compress imp_tm).n with - | Tm_abs {bs; body; rc_opt=Some rc} -> - {imp_tm with n=Tm_abs {bs; body; rc_opt=Some ({rc with residual_typ=None})}} - | _ -> imp_tm in - - let k', g = - env.typeof_well_typed_tot_or_gtot_term - env - imp_tm must_tot in - - match get_subtyping_predicate env k' uvar_ty with - | None -> Err.expected_expression_of_type env imp_tm.pos uvar_ty imp_tm k' - | Some f -> - {Env.conj_guard (Env.apply_guard f imp_tm) g with guard_f=Trivial} - end - else begin - match env.core_check env imp_tm uvar_ty must_tot with - | Inl None -> trivial_guard - | Inl (Some g) -> { trivial_guard with guard_f = NonTrivial g } - | Inr print_err -> - raise_error imp_range Errors.Fatal_FailToResolveImplicitArgument - (BU.format5 "Core checking failed for implicit %s (is_tac: %s) (reason: %s) (%s <: %s)" - (show imp_uvar) (show is_tac) imp_reason (show imp_tm) (show uvar_ty)) - end) in - - if (not force_univ_constraints) && - (CList.existsb (fun (reason, _, _) -> reason = Deferred_univ_constraint) g.deferred) - then None - else let g' = - match discharge_guard' - (Some (fun () -> - BU.format4 "%s (Introduced at %s for %s resolved at %s)" - (show imp_tm) (show imp_range) imp_reason (show imp_tm.pos))) - env g true with - | Some g -> g - | None -> failwith "Impossible, with use_smt = true, discharge_guard' must return Some" in - g'.implicits |> Some - -(* - * resolve_implicits' uses it to determine if a ctx uvar is unresolved - *) -let rec unresolved ctx_u : bool = - match (Unionfind.find ctx_u.ctx_uvar_head) with - | Some r -> - begin match ctx_u.ctx_uvar_meta with - | None -> false - (* If we have a meta annotation, we recurse to see if the uvar - * is actually solved, instead of being resolved to yet another uvar. - * In that case, while we are keeping track of that uvar, we must not - * forget the meta annotation in case this second uvar is not solved. - * See #1561. *) - | Some _ -> - begin match (SS.compress r).n with - | Tm_uvar (ctx_u', _) -> unresolved ctx_u' - | _ -> false - end - end - | None -> true - - -(* - * In the fixpoint loop of resolve_implicits', - * when we reach a fixpoint, with some implicits still remaining, - * try to pick an implicit whose typechecking generates a univ constraint, - * force it, and then repeat the fixpoint loop - *) -let pick_a_univ_deffered_implicit (out : tagged_implicits) - : option Env.implicit & tagged_implicits - = - let imps_with_deferred_univs, rest = List.partition - (fun (_, status) -> status = Implicit_checking_defers_univ_constraint) - out in - match imps_with_deferred_univs with - | [] -> None, out - | hd::tl -> hd |> fst |> Some, (tl@rest) - -let is_tac_implicit_resolved (env:env) (i:implicit) : bool = - i.imp_tm - |> Free.uvars - |> Setlike.for_all (fun uv -> Allow_unresolved? (U.ctx_uvar_should_check uv)) - - -// is_tac: this is a call from within the tactic engine, hence do not use -// tactics for resolving implicits to avoid reentrancy. -// -// is_gen: this is a call after generalization, hence we only check that -// implicits have a solution, and do not typecheck it. This still allows -// some implicits to remain unresolved, but those will remain in the guard. -let resolve_implicits' env is_tac is_gen (implicits:Env.implicits) - : list (implicit & implicit_checking_status) = - - (* Meta argument cache: during a single run of this resolve_implicits' function - we keep track of all results of the "cacheable" tactics that are used for meta - arguments. The only cacheable tactic, for now, is tcresolve. Before trying to run - it, we check the cache to see if we have already solved a problem in the same environment - and for the same uvar type (in this case, the constraint). If so, we just take that result. - - This is pretty conservative. e.g. in - f (1 + 1); - g (1 + 1) - we cannot reuse the solution for each +, since there is an extra unit binder when - we check `g ...`. But it does lead to big gains in expressions like `1 + 1 + 1 ...`. *) - let cacheable tac = - (* Detect either an unapplied tcresolve or an eta expanded variant. This is - mostly in support of solve, which has to be written eta expanded. *) - (U.is_fvar PC.tcresolve_lid tac) || ( - match (SS.compress tac).n with - | Tm_abs ({bs=[_]; body}) -> - let hd, args = U.head_and_args body in - U.is_fvar PC.tcresolve_lid hd && List.length args = 1 - | _ -> false - ) - in - (* tcresolve is also the only tactic we ever run for an open problem. *) - let meta_tac_allowed_for_open_problem tac = cacheable tac in - let __meta_arg_cache : ref (list (term & env_t & typ & term)) = BU.mk_ref [] in - let meta_arg_cache_result (tac : term) (e : env_t) (ty : term) (res : term) : unit = - __meta_arg_cache := (tac, e, ty, res) :: !__meta_arg_cache - in - let meta_arg_cache_lookup (tac : term) (e : env_t) (ty : term) : option term = - let rec aux l : option term = - match l with - | [] -> None - | (tac', e', ty', res') :: l' -> - if U.term_eq tac tac' - && FStar.Common.eq_list U.eq_binding e.gamma e'.gamma - && U.term_eq ty ty' - then Some res' - else aux l' - in - aux !__meta_arg_cache - in - (* / cache *) - - let rec until_fixpoint (acc : tagged_implicits & (*changed:*)bool & (*defer_open_metas:*)bool ) - (implicits:Env.implicits) - : tagged_implicits = - - let out, changed, defer_open_metas = acc in - (* changed: we made some progress - defer_open_metas: starts at true, it means to not try to run - meta arg tactics in environments/types that have unresolved - uvars. We first do a pass with this set to true, and if nothing - changed, we then give up and set it to false, trying to eagerly - solve some partially-unresolved constraints. This is definitely - not ideal, maybe the right thing to do is to never run metas - in open contexts, but that is raising many regressions rihgt now, - particularly in Steel (which uses the resolve_implicits hook pervasively). *) - - match implicits with - | [] -> - if changed then ( - (* We made some progress, keep going from the start *) - until_fixpoint ([], false, true) (List.map fst out) - ) else if defer_open_metas then ( - (* No progress... but we could try being more eager with metas. *) - until_fixpoint ([], false, false) (List.map fst out) - ) else ( - //Nothing changed in this iteration of the loop - //We will try to make progress by either solving a single valued implicit, - // or solving an implicit that generates univ constraint, with force flag on - let imps, changed = try_solve_single_valued_implicits env is_tac (List.map fst out) in - if changed then until_fixpoint ([], false, true) imps - else let imp_opt, rest = pick_a_univ_deffered_implicit out in - (match imp_opt with - | None -> rest //No such implicit exists, return remaining implicits - | Some imp -> - let force_univ_constraints = true in - let imps = - check_implicit_solution_and_discharge_guard - env - imp - is_tac - force_univ_constraints |> must in - until_fixpoint ([], false, true) (Listlike.to_list imps ++ List.map fst rest)) - ) - - | hd::tl -> - let { imp_reason = reason; imp_tm = tm; imp_uvar = ctx_u; imp_range = r } = hd in - let { uvar_decoration_typ; uvar_decoration_should_check } = UF.find_decoration ctx_u.ctx_uvar_head in - if !dbg_Rel then - BU.print4 "resolve_implicits' loop, imp_tm=%s and ctx_u=%s, is_tac=%s, should_check=%s\n" - (show tm) (show ctx_u) (show is_tac) (show uvar_decoration_should_check); - begin match () with - | _ when Allow_unresolved? uvar_decoration_should_check -> - until_fixpoint (out, true, defer_open_metas) tl - - | _ when unresolved ctx_u && flex_uvar_has_meta_tac ctx_u -> - let Some (Ctx_uvar_meta_tac tac) = ctx_u.ctx_uvar_meta in - let env = { env with gamma = ctx_u.ctx_uvar_gamma } in - let typ = U.ctx_uvar_typ ctx_u in - let is_open = has_free_uvars typ || gamma_has_free_uvars ctx_u.ctx_uvar_gamma in - if defer_open_metas && is_open then ( - (* If the result type or env for this meta arg has a free uvar, delay it. - Some other meta arg being solved may instantiate the uvar. See #3130. *) - if !dbg_Rel || !dbg_Imps then - BU.print1 "Deferring implicit due to open ctx/typ %s\n" (show ctx_u); - until_fixpoint ((hd, Implicit_unresolved)::out, changed, defer_open_metas) tl - ) else if is_open && not (meta_tac_allowed_for_open_problem tac) - && Options.Ext.get "compat:open_metas" = "" then ( // i.e. compat option unset - (* If the tactic is not explicitly whitelisted to run with open problems, - then defer. *) - until_fixpoint ((hd, Implicit_unresolved)::out, changed, defer_open_metas) tl - ) else ( - let solve_with (t:term) = - let extra = - match teq_nosmt env t tm with - | None -> failwith "resolve_implicits: unifying with an unresolved uvar failed?" - | Some g -> Listlike.to_list g.implicits - in - until_fixpoint (out, true, defer_open_metas) (extra @ tl) - in - if cacheable tac then - match meta_arg_cache_lookup tac env typ with - | Some res -> solve_with res - | None -> - let t = run_meta_arg_tac env ctx_u in - meta_arg_cache_result tac env typ t; - solve_with t - else - let t = run_meta_arg_tac env ctx_u in - solve_with t - ) - - | _ when unresolved ctx_u -> - until_fixpoint ((hd, Implicit_unresolved)::out, changed, defer_open_metas) tl - - | _ when Allow_untyped? uvar_decoration_should_check || - Already_checked? uvar_decoration_should_check || - is_gen -> - until_fixpoint (out, true, defer_open_metas) tl - | _ -> - let env = {env with gamma=ctx_u.ctx_uvar_gamma} in - (* - * AR: Some opportunities for optimization here, - * we may end up normalizing an implicit solution multiple times in - * multiple until_fixpoint calls - *) - let tm = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.8" [Env.Beta] env tm in - let hd = {hd with imp_tm=tm} in - if is_tac - then begin - if is_tac_implicit_resolved env hd - then let force_univ_constraints = true in - let res = check_implicit_solution_and_discharge_guard - env - hd - is_tac - force_univ_constraints in - let res = BU.map_opt res Listlike.to_list in - if res <> Some [] - then failwith "Impossible: check_implicit_solution_and_discharge_guard for tac must return Some []" - else () - else (); - until_fixpoint (out, true, defer_open_metas) tl - end - else - begin - let force_univ_constraints = false in - let imps_opt = - check_implicit_solution_and_discharge_guard - env - hd - is_tac - force_univ_constraints in - - match imps_opt with - | None -> - until_fixpoint ((hd, Implicit_checking_defers_univ_constraint)::out, changed, defer_open_metas) tl //Move hd to out - | Some imps -> - //add imps to out - until_fixpoint ((imps |> Listlike.to_list |> List.map (fun i -> i, Implicit_unresolved))@out, true, defer_open_metas) tl - end - end - in - until_fixpoint ([], false, true) implicits - -let resolve_implicits env g = - if !dbg_ResolveImplicitsHook - then BU.print1 "//////////////////////////ResolveImplicitsHook: resolve_implicits begin////////////\n\ - guard = %s {\n" - (guard_to_string env g); - let tagged_implicits = resolve_implicits' env false false (Listlike.to_list g.implicits) in - if !dbg_ResolveImplicitsHook - then BU.print_string "//////////////////////////ResolveImplicitsHook: resolve_implicits end////////////\n\ - }\n"; - {g with implicits = Listlike.from_list <| List.map fst tagged_implicits} - -let resolve_generalization_implicits env g = - let tagged_implicits = resolve_implicits' env false true (Listlike.to_list g.implicits) in - {g with implicits = Listlike.from_list <| List.map fst tagged_implicits} - -let resolve_implicits_tac env g = resolve_implicits' env true false (Listlike.to_list g.implicits) - -let force_trivial_guard env g = - if !dbg_ResolveImplicitsHook - then BU.print1 "//////////////////////////ResolveImplicitsHook: force_trivial_guard////////////\n\ - guard = %s\n" - (guard_to_string env g); - let g = solve_deferred_constraints env g in - let g = resolve_implicits env g in - match Listlike.to_list g.implicits with - | [] -> ignore <| discharge_guard env g - | imp::_ -> - let open FStar.Pprint in - raise_error imp.imp_range Errors.Fatal_FailToResolveImplicitArgument [ - prefix 4 1 (text "Failed to resolve implicit argument") - (arbitrary_string (show imp.imp_uvar.ctx_uvar_head)) ^/^ - prefix 4 1 (text "of type") - (N.term_to_doc env (U.ctx_uvar_typ imp.imp_uvar)) ^/^ - prefix 4 1 (text "introduced for") - (text imp.imp_reason) - ] - -let subtype_nosmt_force env t1 t2 = - match subtype_nosmt env t1 t2 with - | None -> false - | Some g -> - force_trivial_guard env g; - true - -let teq_force (env:env) (t1:typ) (t2:typ) : unit = - force_trivial_guard env (teq env t1 t2) - -let teq_nosmt_force (env:env) (t1:typ) (t2:typ) :bool = - match teq_nosmt env t1 t2 with - | None -> false - | Some g -> - force_trivial_guard env g; - true - -let layered_effect_teq env (t1:term) (t2:term) (reason:option string) : guard_t = - if !dbg_LayeredEffectsEqns - then BU.print3 "Layered Effect (%s) %s = %s\n" - (if reason |> is_none then "_" else reason |> must) - (show t1) (show t2); - teq env t1 t2 //AR: teq_nosmt? - - -let universe_inequality (u1:universe) (u2:universe) : guard_t = - //Printf.printf "Universe inequality %s <= %s\n" (show u1) (show u2); - {trivial_guard with univ_ineqs=(empty, cons (u1,u2) empty)} diff --git a/src/typechecker/FStar.TypeChecker.Rel.fsti b/src/typechecker/FStar.TypeChecker.Rel.fsti deleted file mode 100644 index 58ce25425fc..00000000000 --- a/src/typechecker/FStar.TypeChecker.Rel.fsti +++ /dev/null @@ -1,97 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.TypeChecker.Rel -open FStar.Pervasives -open FStar.Compiler.Effect - -open FStar -open FStar.Compiler -open FStar.Compiler.Util -open FStar.TypeChecker -open FStar.Syntax -open FStar.TypeChecker.Env -open FStar.Syntax.Syntax -open FStar.TypeChecker.Common -open FStar.Compiler.Range -open FStar.Class.Show - -type match_result = - | MisMatch of option delta_depth & option delta_depth - | HeadMatch of bool // true iff the heads MAY match after further unification, false if already the same - | FullMatch - -type implicit_checking_status = - | Implicit_unresolved - | Implicit_checking_defers_univ_constraint - | Implicit_has_typing_guard of term & typ - -instance val showable_implicit_checking_status : showable implicit_checking_status - -type tagged_implicits = list (implicit & implicit_checking_status) - -val is_base_type : env -> typ -> bool -val prob_to_string: env -> prob -> string -val flex_prob_closing : env -> binders -> prob -> bool - - -val head_matches_delta (env:env) (logical:bool) (smt_ok:bool) (t1 t2:typ) : (match_result & option (typ & typ)) -val may_relate_with_logical_guard (env:env) (is_equality:bool) (head:typ) : bool -val guard_to_string : env -> guard_t -> string -val simplify_guard : env -> guard_t -> guard_t -val solve_deferred_constraints: env -> guard_t -> guard_t -val solve_non_tactic_deferred_constraints: maybe_defer_flex_flex:bool -> env -> guard_t -> guard_t - - -(* These functions attempt to discharge the logical part of a guard -by simplifying it and calling the SMT if needed (except the _no_smt one, -which will fail raising an error if SMT is needed). The first may *log* -an error if SMT fails to prove the guard. - -Also, before that, they will try to solve all deferred constraints -in the guard, raising an error if one cannot be solved just like -solve_deferred_constraints does. - -In any case, if these functions return, they return a guard with guard_f = Trivial. *) -val discharge_guard : env -> guard_t -> guard_t -val discharge_guard_no_smt : env -> guard_t -> guard_t - -val force_trivial_guard : env -> guard_t -> unit -val resolve_implicits : env -> guard_t -> guard_t -val resolve_generalization_implicits : env -> guard_t -> guard_t -val resolve_implicits_tac : env -> guard_t -> tagged_implicits -val base_and_refinement_maybe_delta : bool -> env -> term -> term & option (bv & term) -val base_and_refinement : env -> term -> term & option (bv & term) - -val unrefine : env -> typ -> typ -val try_teq : smt_ok:bool -> env -> typ -> typ -> option guard_t -val teq : env -> typ -> typ -> guard_t -val get_teq_predicate : env -> typ -> typ -> option guard_t -val teq_force : env -> typ -> typ -> unit -val teq_nosmt : env -> typ -> typ -> option guard_t -val teq_nosmt_force : env -> typ -> typ -> bool -val layered_effect_teq : env -> typ -> typ -> reason:option string -> guard_t -val get_subtyping_predicate: env -> typ -> typ -> option guard_t -val get_subtyping_prop: env -> typ -> typ -> option guard_t -val subtype_nosmt : env -> typ -> typ -> option guard_t -val subtype_nosmt_force : env -> typ -> typ -> bool -val sub_comp : env -> comp -> comp -> option guard_t -val eq_comp : env -> comp -> comp -> option guard_t - -val universe_inequality : universe -> universe -> guard_t - -val subtype_fail: env -> term -> typ -> typ -> unit -val print_pending_implicits: guard_t -> string diff --git a/src/typechecker/FStar.TypeChecker.Tc.fst b/src/typechecker/FStar.TypeChecker.Tc.fst deleted file mode 100644 index 594e587016e..00000000000 --- a/src/typechecker/FStar.TypeChecker.Tc.fst +++ /dev/null @@ -1,1260 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.TypeChecker.Tc -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.Errors -open FStar.TypeChecker -open FStar.TypeChecker.Common -open FStar.TypeChecker.Env -open FStar.Compiler.Util -open FStar.Ident -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.Syntax.Subst -open FStar.Syntax.Util -open FStar.Const -open FStar.TypeChecker.TcTerm - -open FStar.Class.Show -open FStar.Class.Tagged -open FStar.Class.PP -open FStar.Class.Setlike - -module S = FStar.Syntax.Syntax -module SP = FStar.Syntax.Print -module SS = FStar.Syntax.Subst -module UF = FStar.Syntax.Unionfind -module N = FStar.TypeChecker.Normalize -module TcComm = FStar.TypeChecker.Common -module TcUtil = FStar.TypeChecker.Util -module BU = FStar.Compiler.Util //basic util -module U = FStar.Syntax.Util -module Gen = FStar.TypeChecker.Generalize -module TcInductive = FStar.TypeChecker.TcInductive -module TcEff = FStar.TypeChecker.TcEffect -module PC = FStar.Parser.Const -module EMB = FStar.Syntax.Embeddings -module ToSyntax = FStar.ToSyntax.ToSyntax -module O = FStar.Options - -let dbg_TwoPhases = Debug.get_toggle "TwoPhases" -let dbg_IdInfoOn = Debug.get_toggle "IdInfoOn" -let dbg_Normalize = Debug.get_toggle "Normalize" -let dbg_UF = Debug.get_toggle "UF" -let dbg_LogTypes = Debug.get_toggle "LogTypes" - -let sigelt_typ (se:sigelt) : option typ = - match se.sigel with - | Sig_inductive_typ {t} - | Sig_datacon {t} - | Sig_declare_typ {t} -> Some t - - | Sig_let {lbs=(_, lb::_)} -> - Some lb.lbtyp - - | _ -> - None - -//set the name of the query so that we can correlate hints to source program fragments -let set_hint_correlator env se = - //if the tbl has a counter for lid, we use that, else we start from 0 - //this is useful when we verify the extracted interface alongside - let tbl = env.qtbl_name_and_index |> snd in - let get_n lid = - let n_opt = BU.smap_try_find tbl (show lid) in - if is_some n_opt then n_opt |> must else 0 - in - - let typ = match sigelt_typ se with | Some t -> t | _ -> S.tun in - - match Options.reuse_hint_for () with - | Some l -> - let lid = Ident.lid_add_suffix (Env.current_module env) l in - {env with qtbl_name_and_index=Some (lid, typ, get_n lid), tbl} - - | None -> - let lids = U.lids_of_sigelt se in - let lid = match lids with - | [] -> Ident.lid_add_suffix (Env.current_module env) - (GenSym.next_id () |> BU.string_of_int) // GM: Should we really touch the gensym? - | l::_ -> l in - {env with qtbl_name_and_index=Some (lid, typ, get_n lid), tbl} - -let log env = (Options.log_types()) && not(lid_equals PC.prims_lid (Env.current_module env)) - - -(*****************Type-checking the signature of a module*****************************) - -let tc_type_common (env:env) ((uvs, t):tscheme) (expected_typ:typ) (r:Range.range) :tscheme = - let uvs, t = SS.open_univ_vars uvs t in - let env = Env.push_univ_vars env uvs in - let t = tc_check_trivial_guard env t expected_typ in - if uvs = [] then - let uvs, t = Gen.generalize_universes env t in - //AR: generalize_universes only calls N.reduce_uvar_solutions, so make sure there are no uvars left - TcUtil.check_uvars r t; - uvs, t - else uvs, t |> N.remove_uvar_solutions env |> SS.close_univ_vars uvs - -let tc_declare_typ (env:env) (ts:tscheme) (r:Range.range) :tscheme = - tc_type_common env ts (U.type_u () |> fst) r - -let tc_assume (env:env) (ts:tscheme) (r:Range.range) :tscheme = - //AR: this might seem same as tc_declare_typ but come prop, this will change - tc_type_common env ts (U.type_u () |> fst) r - -let tc_decl_attributes env se = - // [Substitute] (defined in Pervasives), is added as attribute by - // TcInductive when a type has no projector, and this happens for - // some types (see TcInductive.early_prims_inductives) that are - // defined before [Substitute] even exists. - // Thus the partition of attributes below. - let blacklisted_attrs, other_attrs = - if lid_exists env PC.attr_substitute_lid - then ([], se.sigattrs) - else partition ((=) attr_substitute) se.sigattrs - in - let g, other_attrs = tc_attributes env other_attrs in - Rel.force_trivial_guard env g; - {se with sigattrs = blacklisted_attrs @ other_attrs } - -let tc_inductive' env ses quals attrs lids = - if Debug.low () then - BU.print1 ">>>>>>>>>>>>>>tc_inductive %s\n" (show ses); - - let ses = List.map (tc_decl_attributes env) ses in - - let sig_bndle, tcs, datas = TcInductive.check_inductive_well_typedness env ses quals lids in - (* we have a well-typed inductive; - we still need to check whether or not it supports equality - and whether it is strictly positive - *) - let sig_bndle = Positivity.mark_uniform_type_parameters env sig_bndle in - - (* Once the datacons are generalized we can construct the projectors with the right types *) - let attrs' = U.remove_attr PC.erasable_attr attrs in - let data_ops_ses = List.map (TcInductive.mk_data_operations quals attrs' env tcs) datas |> List.flatten in - - //strict positivity check - if Options.no_positivity () || (not (Env.should_verify env)) then () //skipping positivity check if lax mode - else begin - (* - * AR: call add_sigelt_to_env here? We should maintain the invariant that push_sigelt is only called from there - * but then this is temporary, just to check positivity, later we actually do go through add_sigelt_to_env - *) - let env2 = Env.push_sigelt env sig_bndle in - (* Check positivity of the inductives within the Sig_bundle *) - List.iter (fun ty -> - let b = Positivity.check_strict_positivity env2 lids ty in - if not b then - let lid, r = - match ty.sigel with - | Sig_inductive_typ {lid} -> lid, ty.sigrng - | _ -> failwith "Impossible!" - in - Errors.log_issue r Errors.Error_InductiveTypeNotSatisfyPositivityCondition ("Inductive type " ^ (string_of_lid lid) ^ " does not satisfy the strict positivity condition") - else () - ) tcs; - - (* Separately, if any of the data constructors in the Sig_bundle are - * exceptions, check their positivity separately. See issue #1535 *) - List.iter (fun d -> - let data_lid, ty_lid = - match d.sigel with - | Sig_datacon {lid=data_lid; ty_lid} -> data_lid, ty_lid - | _ -> failwith "Impossible" - in - if lid_equals ty_lid PC.exn_lid && - not (Positivity.check_exn_strict_positivity env2 data_lid) - then - Errors.log_issue d - Errors.Error_InductiveTypeNotSatisfyPositivityCondition - ("Exception " ^ (string_of_lid data_lid) ^ " does not satisfy the positivity condition") - ) datas - end; - - //generate hasEq predicate for this inductive - - let skip_haseq = - //skip logical connectives types in prims, tcs is bound to the inductive type, caller ensures its length is > 0 - let skip_prims_type (_:unit) :bool = - let lid = - let ty = List.hd tcs in - match ty.sigel with - | Sig_inductive_typ {lid} -> lid - | _ -> failwith "Impossible" - in - //these are the prims type we are skipping - List.existsb (fun s -> s = (string_of_id (ident_of_lid lid))) TcInductive.early_prims_inductives in - - let is_noeq = List.existsb (fun q -> q = Noeq) quals in - - //caller ensures tcs length is > 0 - //assuming that we have already propagated attrs from the bundle to its elements - let is_erasable () = U.has_attribute (List.hd tcs).sigattrs FStar.Parser.Const.erasable_attr in - - List.length tcs = 0 || - (lid_equals env.curmodule PC.prims_lid && skip_prims_type ()) || - is_noeq || - is_erasable () in - - - let res = - if skip_haseq - then sig_bndle, data_ops_ses - else - let is_unopteq = List.existsb (fun q -> q = Unopteq) quals in - let ses = - if is_unopteq then TcInductive.unoptimized_haseq_scheme sig_bndle tcs datas env - else TcInductive.optimized_haseq_scheme sig_bndle tcs datas env - in - sig_bndle, ses@data_ops_ses in //append hasEq axiom lids and data projectors and discriminators lids - res - -let tc_inductive env ses quals attrs lids = - let env = Env.push env "tc_inductive" in - let pop () = ignore (Env.pop env "tc_inductive") in //OK to ignore: caller will reuse original env - - if Options.trace_error () then - let r = tc_inductive' env ses quals attrs lids in - pop (); - r - else - try tc_inductive' env ses quals attrs lids |> (fun r -> pop (); r) - with e -> pop (); raise e - -let proc_check_with (attrs:list attribute) (kont : unit -> 'a) : 'a = - match U.get_attribute PC.check_with_lid attrs with - | None -> kont () - | Some [(a, None)] -> - match EMB.unembed a EMB.id_norm_cb with - | None -> failwith "nah" - | Some vcfg -> - Options.with_saved_options (fun () -> - Options.set_vconfig vcfg; - kont ()) - | _ -> failwith "ill-formed `check_with`" - -let handle_postprocess_with_attr (env:Env.env) (ats:list attribute) - : (list attribute & option term) -= (* Extract the postprocess_with *) - match U.extract_attr' PC.postprocess_with ats with - | None -> ats, None - | Some (ats, [tau, None]) -> - ats, Some tau - | Some (ats, args) -> - Errors.log_issue env Errors.Warning_UnrecognizedAttribute - (BU.format1 "Ill-formed application of `%s`" (show PC.postprocess_with)); - ats, None - -let store_sigopts (se:sigelt) : sigelt = - { se with sigopts = Some (Options.get_vconfig ()) } - -(* Alternative to making a huge let rec... knot is set below in this file *) -let tc_decls_knot : ref (option (Env.env -> list sigelt -> list sigelt & Env.env)) = - BU.mk_ref None - -let do_two_phases env : bool = not (Options.lax ()) -let run_phase1 (f:unit -> 'a) = - FStar.TypeChecker.Core.clear_memo_table(); - let r = f () in - FStar.TypeChecker.Core.clear_memo_table(); - r - - -(* The type checking rule for Sig_let (lbs, lids) *) -let tc_sig_let env r se lbs lids : list sigelt & list sigelt & Env.env = - let env0 = env in - let env = Env.set_range env r in - let check_quals_eq l qopt val_q = match qopt with - | None -> Some val_q - | Some q' -> - //logic is now a deprecated qualifier, so discard it from the checking - //AR: 05/19: drop irreducible also - // irreducible is not allowed on val, but one could add it on let - let drop_logic_and_irreducible = List.filter (fun x -> not (x = Logic || x = Irreducible)) in - if (let val_q, q' = drop_logic_and_irreducible val_q, drop_logic_and_irreducible q' in - List.length val_q = List.length q' - && List.forall2 U.qualifier_equal val_q q') - then Some q' //but retain it in the returned list of qualifiers, some code may still add type annotations of Type0, which will hinder `logical` inference - else - let open FStar.Pprint in - raise_error r Errors.Fatal_InconsistentQualifierAnnotation [ - text "Inconsistent qualifier annotations on" ^/^ doc_of_string (show l); - prefix 4 1 (text "Expected") (squotes (arbitrary_string (show val_q))) ^/^ - prefix 4 1 (text "got") (squotes (arbitrary_string (show q'))) - ] - in - - let rename_parameters lb = - let rename_in_typ def typ = - let typ = Subst.compress typ in - let def_bs = match (Subst.compress def).n with - | Tm_abs {bs=binders} -> binders - | _ -> [] in - match typ with - | { n = Tm_arrow {bs=val_bs; comp=c}; pos = r } -> begin - let has_auto_name bv = - BU.starts_with (string_of_id bv.ppname) Ident.reserved_prefix in - let rec rename_binders def_bs val_bs = - match def_bs, val_bs with - | [], _ | _, [] -> val_bs - | ({binder_bv=body_bv}) :: bt, val_b :: vt -> - (match has_auto_name body_bv, has_auto_name val_b.binder_bv with - | true, _ -> val_b - | false, true -> { val_b with - binder_bv={val_b.binder_bv with - ppname = mk_ident (string_of_id body_bv.ppname, range_of_id val_b.binder_bv.ppname)} } - | false, false -> - // if (string_of_id body_bv.ppname) <> (string_of_id val_bv.ppname) then - // Errors.warn (range_of_id body_bv.ppname) - // (BU.format2 "Parameter name %s doesn't match name %s used in val declaration" - // (string_of_id body_bv.ppname) (string_of_id val_bv.ppname)); - val_b) :: rename_binders bt vt in - Syntax.mk (Tm_arrow {bs=rename_binders def_bs val_bs; comp=c}) r end - | _ -> typ in - { lb with lbtyp = rename_in_typ lb.lbdef lb.lbtyp } in - - (* 1. (a) Annotate each lb in lbs with a type from the corresponding val decl, if there is one - (b) Generalize the type of lb only if none of the lbs have val decls nor explicit universes - *) - let should_generalize, lbs', quals_opt = - snd lbs |> List.fold_left (fun (gen, lbs, quals_opt) lb -> - let lbname = right lb.lbname in //this is definitely not a local let binding - let gen, lb, quals_opt = match Env.try_lookup_val_decl env lbname.fv_name.v with - | None -> - gen, lb, quals_opt - - | Some ((uvs,tval), quals) -> - let quals_opt = check_quals_eq lbname.fv_name.v quals_opt quals in - let def = match lb.lbtyp.n with - | Tm_unknown -> lb.lbdef - | _ -> - (* If there are two type ascriptions we check that they are compatible *) - mk (Tm_ascribed {tm=lb.lbdef; asc=(Inl lb.lbtyp, None, false); eff_opt=None}) lb.lbdef.pos - in - if lb.lbunivs <> [] && List.length lb.lbunivs <> List.length uvs - then raise_error r Errors.Fatal_IncoherentInlineUniverse "Inline universes are incoherent with annotation from val declaration"; - false, //explicit annotation provided; do not generalize - mk_lb (Inr lbname, uvs, PC.effect_Tot_lid, tval, def, lb.lbattrs, lb.lbpos), - quals_opt - in - gen, lb::lbs, quals_opt) - (true, [], (if se.sigquals=[] then None else Some se.sigquals)) - in - - (* Check that all the mutually recursive bindings mention the same universes *) - U.check_mutual_universes lbs'; - - let quals = match quals_opt with - | None -> [Visible_default] - | Some q -> - if q |> BU.for_some (function Irreducible | Visible_default | Unfold_for_unification_and_vcgen -> true | _ -> false) - then q - else Visible_default::q //the default visibility for a let binding is Unfoldable - in - - let lbs' = List.rev lbs' in - - (* preprocess_with *) - let attrs, pre_tau = - match U.extract_attr' PC.preprocess_with se.sigattrs with - | None -> se.sigattrs, None - | Some (ats, [tau, None]) -> ats, Some tau - | Some (ats, args) -> - Errors.log_issue r Errors.Warning_UnrecognizedAttribute "Ill-formed application of `preprocess_with`"; - se.sigattrs, None - in - let se = { se with sigattrs = attrs } in (* to remove the preprocess_with *) - - let preprocess_lb (tau:term) (lb:letbinding) : letbinding = - let lbdef = Env.preprocess env tau lb.lbdef in - if Debug.medium () || !dbg_TwoPhases then - BU.print1 "lb preprocessed into: %s\n" (show lbdef); - { lb with lbdef = lbdef } - in - // Preprocess the letbindings with the tactic, if any - let lbs' = match pre_tau with - | Some tau -> List.map (preprocess_lb tau) lbs' - | None -> lbs' - in - (* / preprocess_with *) - - (* 2. Turn the top-level lb into a Tm_let with a unit body *) - let e = mk (Tm_let {lbs=(fst lbs, lbs'); body=mk (Tm_constant (Const_unit)) r}) r in - - (* 3. Type-check the Tm_let and convert it back to Sig_let *) - let env' = { env with top_level = true; generalize = should_generalize } in - let e = - if do_two_phases env' then run_phase1 (fun _ -> - let drop_lbtyp (e_lax:term) :term = - match (SS.compress e_lax).n with - | Tm_let {lbs=(false, [ lb ]); body=e2} -> - let lb_unannotated = - match (SS.compress e).n with //checking type annotation on e, the lb before phase 1, capturing e from above - | Tm_let {lbs=(_, [ lb ])} -> - (match (SS.compress lb.lbtyp).n with - | Tm_unknown -> true - | _ -> false) - | _ -> failwith "Impossible: first phase lb and second phase lb differ in structure!" - in - if lb_unannotated then { e_lax with n = Tm_let {lbs=(false, [ { lb with lbtyp = S.tun } ]); - body=e2}} //erase the type annotation - else e_lax - | Tm_let {lbs=(true, lbs)} -> - U.check_mutual_universes lbs; - //leave recursive lets as is; since the decreases clause from the ascription (if any) - //is propagated to the lbtyp by TcUtil.extract_let_rec_annotation - //if we drop the lbtyp here, we'll lose the decreases clause - e_lax - in - let e = - Profiling.profile (fun () -> - let (e, _, _) = tc_maybe_toplevel_term ({ env' with phase1 = true; admit = true }) e in - e) - (Some (Ident.string_of_lid (Env.current_module env))) - "FStar.TypeChecker.Tc.tc_sig_let-tc-phase1" - in - - if Debug.medium () || !dbg_TwoPhases then - BU.print1 "Let binding after phase 1, before removing uvars: %s\n" (show e); - - let e = N.remove_uvar_solutions env' e |> drop_lbtyp in - - if Debug.medium () || !dbg_TwoPhases then - BU.print1 "Let binding after phase 1, uvars removed: %s\n" (show e); - e) - else e - in - let attrs, post_tau = handle_postprocess_with_attr env se.sigattrs in - (* remove the postprocess_with, if any *) - let se = { se with sigattrs = attrs } in - - let postprocess_lb (tau:term) (lb:letbinding) : letbinding = - let s, univnames = SS.univ_var_opening lb.lbunivs in - let lbdef = SS.subst s lb.lbdef in - let lbtyp = SS.subst s lb.lbtyp in - let env = Env.push_univ_vars env univnames in - let lbdef = Env.postprocess env tau lbtyp lbdef in - let lbdef = SS.close_univ_vars univnames lbdef in - { lb with lbdef = lbdef } - in - let env' = - match (SS.compress e).n with - | Tm_let {lbs} -> - let se = { se with sigel = Sig_let {lbs; lids} } in - set_hint_correlator env' se - | _ -> - failwith "no way, not a let?" - in - Errors.stop_if_err (); - let r = - //We already generalized phase1; don't need to generalize again - let should_generalize = not (do_two_phases env') in - Profiling.profile (fun () -> tc_maybe_toplevel_term { env' with generalize = should_generalize } e) - (Some (Ident.string_of_lid (Env.current_module env))) - "FStar.TypeChecker.Tc.tc_sig_let-tc-phase2" - in - let se, lbs = match r with - | {n=Tm_let {lbs; body=e}}, _, g when Env.is_trivial g -> - U.check_mutual_universes (snd lbs); - - // Propagate binder names into signature - let lbs = (fst lbs, (snd lbs) |> List.map rename_parameters) in - - // Postprocess the letbindings with the tactic, if any - let lbs = (fst lbs, - (match post_tau with - | Some tau -> List.map (postprocess_lb tau) (snd lbs) - | None -> (snd lbs))) - in - - //propagate the MaskedEffect tag to the qualifiers - let quals = match e.n with - | Tm_meta {meta=Meta_desugared Masked_effect} -> HasMaskedEffect::quals - | _ -> quals - in - { se with sigel = Sig_let {lbs; lids}; - sigquals = quals }, - lbs - | _ -> failwith "impossible (typechecking should preserve Tm_let)" - in - - // - // if no_subtyping attribute is present, typecheck the signatures with use_eq_strict - // - if U.has_attribute se.sigattrs PC.no_subtping_attr_lid - then begin - let env' = {env' with use_eq_strict=true} in - let err s pos = raise_error pos Errors.Fatal_InconsistentQualifierAnnotation s in - snd lbs |> List.iter (fun lb -> - if not (U.is_lemma lb.lbtyp) - then err ("no_subtype annotation on a non-lemma") lb.lbpos - else let lid_opt = - Free.fvars lb.lbtyp - |> elems - |> List.tryFind (fun lid -> - not (lid |> Ident.path_of_lid |> List.hd = "Prims" || - lid_equals lid PC.pattern_lid)) in - if lid_opt |> is_some - then err (BU.format1 "%s is not allowed in no_subtyping lemmas (only prims symbols)" - (lid_opt |> must |> string_of_lid)) lb.lbpos - else let t, _ = U.type_u () in - let uvs, lbtyp = SS.open_univ_vars lb.lbunivs lb.lbtyp in - let _, _, g = TcTerm.tc_check_tot_or_gtot_term - (Env.push_univ_vars env' uvs) - lbtyp - t - (Some "checking no_subtype annotation") in - Rel.force_trivial_guard env' g) - end; - - (* 4. Record the type of top-level lets, and log if requested *) - snd lbs |> List.iter (fun lb -> - let fv = right lb.lbname in - Env.insert_fv_info env fv lb.lbtyp); - - if log env - then BU.print1 "%s\n" (snd lbs |> List.map (fun lb -> - let should_log = match Env.try_lookup_val_decl env (right lb.lbname).fv_name.v with - | None -> true - | _ -> false in - if should_log - then BU.format2 "let %s : %s" (show lb.lbname) (show (*env*) lb.lbtyp) - else "") |> String.concat "\n"); - - [se], [], env0 - -let tc_decl' env0 se: list sigelt & list sigelt & Env.env = - let env = env0 in - let se = match se.sigel with - // Disable typechecking attributes for [Sig_fail] bundles, so - // that typechecking is wrapped in [Errors.catch_errors] - // below, thus allowing using [expect_failure] to mark that - // an attribute will fail typechecking. - | Sig_fail _ -> se - | _ -> tc_decl_attributes env se - in - Quals.check_sigelt_quals_pre env se; - proc_check_with se.sigattrs (fun () -> - let r = se.sigrng in - let se = - if Options.record_options () - then store_sigopts se - else se - in - match se.sigel with - | Sig_inductive_typ _ - | Sig_datacon _ -> - failwith "Impossible bare data-constructor" - - (* If we're --laxing, and this is not an `expect_lax_failure`, then just ignore the definition *) - | Sig_fail {fail_in_lax=false} when env.admit -> - if Debug.any () then - BU.print1 "Skipping %s since env.admit=true and this is not an expect_lax_failure\n" - (Print.sigelt_to_string_short se); - [], [], env - - | Sig_fail {errs=expected_errors; fail_in_lax=lax; ses} -> - let env' = if lax then { env with admit = true } else env in - let env' = Env.push env' "expect_failure" in - (* We need to call push since tc_decls will encode the sigelts that - * succeed to SMT, which may be relevant in checking the ones that - * follow it. See #1956 for an example of what goes wrong if we - * don't pop the context (spoiler: we prove false). *) - - if Debug.low () then - BU.print1 ">> Expecting errors: [%s]\n" (String.concat "; " <| List.map string_of_int expected_errors); - - let errs, _ = Errors.catch_errors (fun () -> - Options.with_saved_options (fun () -> - BU.must (!tc_decls_knot) env' ses)) in - - if Options.print_expected_failures () - || Debug.low () then - begin - BU.print_string ">> Got issues: [\n"; - List.iter Errors.print_issue errs; - BU.print_string ">>]\n" - end; - - (* Pop environment, reset SMT context *) - let _ = Env.pop env' "expect_failure" in - - let actual_errors = List.concatMap (fun i -> FStar.Common.list_of_option i.issue_number) errs in - - begin match errs with - | [] -> - List.iter Errors.print_issue errs; - Errors.log_issue se Errors.Error_DidNotFail [ - text "This top-level definition was expected to fail, but it succeeded"; - ] - | _ -> - if expected_errors <> [] then - match Errors.find_multiset_discrepancy expected_errors actual_errors with - | None -> () - | Some (e, n1, n2) -> - let open FStar.Pprint in - let open FStar.Errors.Msg in - List.iter Errors.print_issue errs; - Errors.log_issue se Errors.Error_DidNotFail [ - prefix 2 1 - (text "This top-level definition was expected to raise error codes") - (pp expected_errors) ^/^ - prefix 2 1 (text "but it raised") - (pp actual_errors) ^^ - dot; - text (BU.format3 "Error #%s was raised %s times, instead of %s." - (show e) (show n2) (show n1)); - ] - end; - [], [], env - - | Sig_bundle {ses; lids} -> - let env = Env.set_range env r in - let ses = - if do_two_phases env then run_phase1 (fun _ -> - //we generate extra sigelts even in the first phase and then throw them away - //would be nice to not generate them at all - let ses = - tc_inductive ({ env with phase1 = true; admit = true }) ses se.sigquals se.sigattrs lids - |> fst - |> N.elim_uvars env - |> U.ses_of_sigbundle in - if Debug.medium () || !dbg_TwoPhases - then BU.print1 "Inductive after phase 1: %s\n" (show ({ se with sigel = Sig_bundle {ses; lids} })); - ses) - else ses - in - let sigbndle, projectors_ses = tc_inductive env ses se.sigquals se.sigattrs lids in - let sigbndle = { sigbndle with sigattrs = se.sigattrs } in (* keep the attributes *) - [ sigbndle ], projectors_ses, env0 - - | Sig_pragma p -> //no need for two-phase here - U.process_pragma p r; - [se], [], env0 - - | Sig_new_effect ne -> - let is_unelaborated_dm4f = - match ne.combinators with - | DM4F_eff combs -> - (match combs.ret_wp |> snd |> SS.compress with - | { n = Tm_unknown } -> true - | _ -> false) - | _ -> false in - - if is_unelaborated_dm4f then - let env = Env.set_range env r in - let ses, ne, lift_from_pure_opt = TcEff.dmff_cps_and_elaborate env ne in - let effect_and_lift_ses = match lift_from_pure_opt with - | Some lift -> [ { se with sigel = Sig_new_effect (ne) } ; lift ] - | None -> [ { se with sigel = Sig_new_effect (ne) } ] in - - let effect_and_lift_ses = effect_and_lift_ses |> List.map (fun sigelt -> - { sigelt with sigmeta={sigelt.sigmeta with sigmeta_admit=true}}) in - - //only elaborate, the loop in tc_decls would send these back to us for typechecking - [], ses @ effect_and_lift_ses, env0 - else - let ne = - if do_two_phases env then run_phase1 (fun _ -> - let ne = - TcEff.tc_eff_decl ({ env with phase1 = true; admit = true }) ne se.sigquals se.sigattrs - |> (fun ne -> { se with sigel = Sig_new_effect ne }) - |> N.elim_uvars env |> U.eff_decl_of_new_effect in - if Debug.medium () || !dbg_TwoPhases - then BU.print1 "Effect decl after phase 1: %s\n" - (show ({ se with sigel = Sig_new_effect ne })); - ne) - else ne in - let ne = TcEff.tc_eff_decl env ne se.sigquals se.sigattrs in - let se = { se with sigel = Sig_new_effect(ne) } in - [se], [], env0 - - | Sig_sub_effect(sub) -> //no need to two-phase here, since lifts are already lax checked - let sub = TcEff.tc_lift env sub r in - let se = { se with sigel = Sig_sub_effect sub } in - [se], [], env - - | Sig_effect_abbrev {lid; us=uvs; bs=tps; comp=c; cflags=flags} -> - let lid, uvs, tps, c = - if do_two_phases env - then run_phase1 (fun _ -> - TcEff.tc_effect_abbrev ({ env with phase1 = true; admit = true }) (lid, uvs, tps, c) r - |> (fun (lid, uvs, tps, c) -> { se with sigel = Sig_effect_abbrev {lid; - us=uvs; - bs=tps; - comp=c; - cflags=flags} }) - |> N.elim_uvars env |> - (fun se -> match se.sigel with - | Sig_effect_abbrev {lid; us=uvs; bs=tps; comp=c} -> lid, uvs, tps, c - | _ -> failwith "Did not expect Sig_effect_abbrev to not be one after phase 1")) - else lid, uvs, tps, c in - - let lid, uvs, tps, c = TcEff.tc_effect_abbrev env (lid, uvs, tps, c) r in - let se = { se with sigel = Sig_effect_abbrev {lid; - us=uvs; - bs=tps; - comp=c; - cflags=flags} } in - [se], [], env0 - - | Sig_declare_typ _ - | Sig_let _ - when se.sigquals |> BU.for_some (function OnlyName -> true | _ -> false) -> - (* Dummy declaration which must be erased since it has been elaborated somewhere else *) - [], [], env0 - - | Sig_declare_typ {lid; us=uvs; t} -> //NS: No checks on the qualifiers? - - if lid_exists env lid then - raise_error r Errors.Fatal_AlreadyDefinedTopLevelDeclaration [ - text (BU.format1 "Top-level declaration %s for a name that is already used in this module." (show lid)); - text "Top-level declarations must be unique in their module." - ]; - - let env = Env.set_range env r in - let uvs, t = - if do_two_phases env then run_phase1 (fun _ -> - let uvs, t = tc_declare_typ ({ env with phase1 = true; admit = true }) (uvs, t) se.sigrng in //|> N.normalize [Env.NoFullNorm; Env.Beta; Env.DoNotUnfoldPureLets] env in - if Debug.medium () || !dbg_TwoPhases then BU.print2 "Val declaration after phase 1: %s and uvs: %s\n" (show t) (show uvs); - uvs, t) - else uvs, t - in - - let uvs, t = tc_declare_typ env (uvs, t) se.sigrng in - [ { se with sigel = Sig_declare_typ {lid; us=uvs; t} }], [], env0 - - | Sig_assume {lid; us=uvs; phi=t} -> - if not (List.contains S.InternalAssumption se.sigquals) then - FStar.Errors.log_issue r Warning_WarnOnUse - (BU.format1 "Admitting a top-level assumption %s" (show lid)); - let env = Env.set_range env r in - - let uvs, t = - if do_two_phases env then run_phase1 (fun _ -> - let uvs, t = tc_assume ({ env with phase1 = true; admit = true }) (uvs, t) se.sigrng in - if Debug.medium () || !dbg_TwoPhases then BU.print2 "Assume after phase 1: %s and uvs: %s\n" (show t) (show uvs); - uvs, t) - else uvs, t - in - - let uvs, t = tc_assume env (uvs, t) se.sigrng in - [ { se with sigel = Sig_assume {lid; us=uvs; phi=t} }], [], env0 - - | Sig_splice {is_typed; lids; tac=t} -> - if Debug.any () then - BU.print3 "%s: Found splice of (%s) with is_typed: %s\n" - (string_of_lid env.curmodule) - (show t) - (string_of_bool is_typed); - - // env.splice will check the tactic - - let ses = env.splice env is_typed lids t se.sigrng in - let ses = - if is_typed - then let sigquals = - match se.sigquals with - | [] -> [ S.Visible_default ] - | qs -> qs - in - List.map - (fun sp -> { sp with sigquals = sigquals@sp.sigquals; sigattrs = se.sigattrs@sp.sigattrs}) - ses - else ses - in - let ses = ses |> List.map (fun se -> - if env.is_iface && Sig_declare_typ? se.sigel - then { se with sigquals = Assumption :: (List.filter (fun q -> q <> Irreducible) se.sigquals) } - else se) - in - let ses = ses |> List.map (fun se -> { se with sigmeta = { se.sigmeta with sigmeta_spliced = true } }) in - - let dsenv = List.fold_left DsEnv.push_sigelt_force env.dsenv ses in - let env = { env with dsenv = dsenv } in - - if Debug.low () then - BU.print1 "Splice returned sigelts {\n%s\n}\n" - (String.concat "\n" <| List.map show ses); - - (* sigelts returned by splice_t can be marked with sigmeta - already_checked, and those will be skipped on the next run. But they do - run through the pipeline again. This also allows a splice tactic - to return any mixture of checked and unchecked sigelts. *) - [], ses, env - - | Sig_let {lbs; lids} -> - Profiling.profile - (fun () -> tc_sig_let env r se lbs lids) - (Some (Ident.string_of_lid (Env.current_module env))) - "FStar.TypeChecker.Tc.tc_sig_let" - - | Sig_polymonadic_bind {m_lid=m; n_lid=n; p_lid=p; tm=t} -> //desugaring does not set the last two fields, tc does - let t = - if do_two_phases env then run_phase1 (fun _ -> - let t, ty = - TcEff.tc_polymonadic_bind ({ env with phase1 = true; admit = true }) m n p t - |> (fun (t, ty, _) -> { se with sigel = Sig_polymonadic_bind {m_lid=m; - n_lid=n; - p_lid=p; - tm=t; - typ=ty; - kind=None} }) - |> N.elim_uvars env - |> (fun se -> - match se.sigel with - | Sig_polymonadic_bind {tm=t; typ=ty} -> t, ty - | _ -> failwith "Impossible! tc for Sig_polymonadic_bind must be a Sig_polymonadic_bind") in - if Debug.medium () || !dbg_TwoPhases - then BU.print1 "Polymonadic bind after phase 1: %s\n" - (show ({ se with sigel = Sig_polymonadic_bind {m_lid=m; - n_lid=n; - p_lid=p; - tm=t; - typ=ty; - kind=None} })); - t) - else t in - let t, ty, k = TcEff.tc_polymonadic_bind env m n p t in - let se = ({ se with sigel = Sig_polymonadic_bind {m_lid=m; - n_lid=n; - p_lid=p; - tm=t; - typ=ty; - kind=Some k} }) in - [se], [], env0 - - | Sig_polymonadic_subcomp {m_lid=m; n_lid=n; tm=t} -> //desugaring does not set the last two fields, tc does - let t = - if do_two_phases env then run_phase1 (fun _ -> - let t, ty = - TcEff.tc_polymonadic_subcomp ({ env with phase1 = true; admit = true }) m n t - |> (fun (t, ty, _) -> { se with sigel = Sig_polymonadic_subcomp {m_lid=m; - n_lid=n; - tm=t; - typ=ty; - kind=None} }) - |> N.elim_uvars env - |> (fun se -> - match se.sigel with - | Sig_polymonadic_subcomp {tm=t; typ=ty} -> t, ty - | _ -> failwith "Impossible! tc for Sig_polymonadic_subcomp must be a Sig_polymonadic_subcomp") in - if Debug.medium () || !dbg_TwoPhases - then BU.print1 "Polymonadic subcomp after phase 1: %s\n" - (show ({ se with sigel = Sig_polymonadic_subcomp {m_lid=m; - n_lid=n; - tm=t; - typ=ty; - kind=None} })); - t) - else t in - let t, ty, k = TcEff.tc_polymonadic_subcomp env m n t in - let se = ({ se with sigel = Sig_polymonadic_subcomp {m_lid=m; - n_lid=n; - tm=t; - typ=ty; - kind=Some k} }) in - [se], [], env0) - - -(* [tc_decl env se] typechecks [se] in environment [env] and returns * - * the list of typechecked sig_elts, and a list of new sig_elts elaborated - * during typechecking but not yet typechecked *) -let tc_decl env se: list sigelt & list sigelt & Env.env = - FStar.GenSym.reset_gensym(); - let env0 = env in - let env = set_hint_correlator env se in - let env = - (* This is the SINGLE point where we read admit_smt_queries - and pass it through into the .admit field. *) - if Options.admit_smt_queries () - then { env with admit = true } - else env - in - if Debug.any () then - BU.print1 "Processing %s\n" (Print.sigelt_to_string_short se); - if Debug.medium () then - BU.print2 ">>>>>>>>>>>>>>tc_decl admit=%s %s\n" (show env.admit) (show se); - let result = - if se.sigmeta.sigmeta_already_checked then - [se], [], env - else if se.sigmeta.sigmeta_admit then ( - let result = tc_decl' { env with admit = true } se in - result - ) else - tc_decl' env se - in - let () = - (* Do the post-tc attribute/qualifier check. *) - let (ses, _, _) = result in - List.iter (Quals.check_sigelt_quals_post env) ses - in - (* Restore admit *) - let result = - let ses, ses_e, env = result in - ses, ses_e, { env with admit = env0.admit } - in - result - -(* adds the typechecked sigelt to the env, also performs any processing required in the env (such as reset options) *) -(* AR: we now call this function when loading checked modules as well to be more consistent *) -let add_sigelt_to_env (env:Env.env) (se:sigelt) (from_cache:bool) : Env.env = - if Debug.low () - then BU.print2 - ">>>>>>>>>>>>>>Adding top-level decl to environment: %s (from_cache:%s)\n" - (Print.sigelt_to_string_short se) (show from_cache); - - match se.sigel with - | Sig_inductive_typ _ - | Sig_datacon _ -> - raise_error se Errors.Fatal_UnexpectedInductivetype - (BU.format1 "add_sigelt_to_env: unexpected bare type/data constructor: %s" (show se)) - - | Sig_declare_typ _ - | Sig_let _ when se.sigquals |> BU.for_some (function OnlyName -> true | _ -> false) -> env - - | _ -> - let env = Env.push_sigelt env se in - //match again to perform postprocessing - match se.sigel with - | Sig_pragma ShowOptions -> - Errors.info se [ - text "Option state:"; - Pprint.arbitrary_string (Options.show_options ()); - ]; - env - - | Sig_pragma (PushOptions _) - | Sig_pragma PopOptions - | Sig_pragma (SetOptions _) - | Sig_pragma (ResetOptions _) -> - if from_cache then env - else - (* we keep --using_facts_from reflected in the environment, so update it here *) - ({ env with proof_ns = Options.using_facts_from () }) - - | Sig_pragma RestartSolver -> - (* `flychecking` marks when an interactive F* is peeking via flycheck, - * we shouldn't reset the solver at that point, only when the user - * advances over the pragma. *) - if from_cache || env.flychecking then env - else begin - env.solver.refresh (Some env.proof_ns); - env - end - - | Sig_pragma PrintEffectsGraph -> - BU.write_file "effects.graph" (Env.print_effects_graph env); - env - - | Sig_new_effect ne -> - let env = Env.push_new_effect env (ne, se.sigquals) in - ne.actions |> List.fold_left (fun env a -> Env.push_sigelt env (U.action_as_lb ne.mname a a.action_defn.pos)) env - - | Sig_sub_effect sub -> TcUtil.update_env_sub_eff env sub se.sigrng - - | Sig_polymonadic_bind {m_lid=m;n_lid=n;p_lid=p;typ=ty;kind=k} -> TcUtil.update_env_polymonadic_bind env m n p ty (k |> must) - - | Sig_polymonadic_subcomp {m_lid=m; n_lid=n; typ=ty; kind=k} -> Env.add_polymonadic_subcomp env m n (ty, k |> must) - - | _ -> env - -(* This function is called when promoting entries in the id info table. - If t has no dangling uvars, it is normalized and promoted, - otherwise discarded *) -let compress_and_norm env t = - match Compress.deep_compress_if_no_uvars t with - | None -> None //if dangling uvars, then just drop this entry - | Some t -> //otherwise, normalize and promote - Some ( - N.normalize - [Env.AllowUnboundUniverses; //this is allowed, since we're reducing types that appear deep within some arbitrary context - Env.CheckNoUvars; - Env.Beta; Env.DoNotUnfoldPureLets; Env.CompressUvars; - Env.Exclude Env.Zeta; Env.Exclude Env.Iota; Env.NoFullNorm] - env - t - ) - -let tc_decls env ses = - let rec process_one_decl (ses, env) se = - Errors.fallback_range := Some se.sigrng; - - (* If emacs is peeking, and debugging is on, don't do anything, - * otherwise the user will see a bunch of output from typechecking - * definitions that were not yet advanced over. *) - if env.flychecking && Debug.any () - then (ses, env), [] - else begin - if Debug.low () - then BU.print2 ">>>>>>>>>>>>>>Checking top-level %s decl %s\n" - (tag_of se) - (Print.sigelt_to_string_short se); - - if Options.ide_id_info_off() then Env.toggle_id_info env false; - if !dbg_IdInfoOn then Env.toggle_id_info env true; - - let ses', ses_elaborated, env = - Errors.with_ctx (BU.format2 "While typechecking the %stop-level declaration `%s`" - (if se.sigmeta.sigmeta_spliced then "(spliced) " else "") - (Print.sigelt_to_string_short se)) - (fun () -> tc_decl env se) - in - - let ses' = ses' |> List.map (fun se -> - if !dbg_UF - then BU.print1 "About to elim vars from %s\n" (show se); - N.elim_uvars env se) in - let ses_elaborated = ses_elaborated |> List.map (fun se -> - if !dbg_UF - then BU.print1 "About to elim vars from (elaborated) %s\n" (show se); - N.elim_uvars env se) in - - Env.promote_id_info env (compress_and_norm env); - - // Compress all checked sigelts. Uvars and names are not OK after a full typecheck - let ses' = ses' |> List.map (Compress.deep_compress_se false false) in - - // Make sure to update all the delta_depths of the definitions we will add to the - // environment. These can change if the body of the letbinding is transformed by any means, - // such as by resolving an `_ by ...`, or a pre/post process hook. - // let fixup_dd_lb (lb:letbinding) : letbinding = - // (* The delta depth of the fv is 1 + the dd of its body *) - // let Inr fv = lb.lbname in - // // BU.print2_error "Checking depth of %s = %s\n" (show lb.lbname) (show fv.fv_delta); - // // let dd = incr_delta_depth <| delta_qualifier lb.lbdef in - // let dd = incr_delta_depth <| delta_depth_of_term env lb.lbdef in - // // if Some dd <> fv.fv_delta then ( - // // BU.print3_error "Fixing up delta depth of %s from %s to %s\n" (show lb.lbname) (show fv.fv_delta) (show dd) - // // ); - // // BU.print1_error "Definition = (%s)\n\n" (show lb.lbdef); - // let fv = { fv with fv_delta = Some dd } in - // { lb with lbname = Inr fv } - // in - // let fixup_delta_depth (se:sigelt) : sigelt = - // match se.sigel with - // | Sig_let {lbs; lids} -> - // let lbs = fst lbs, List.map fixup_dd_lb (snd lbs) in - // { se with sigel = Sig_let {lbs; lids} } - // | _ -> se - // in - // let ses' = ses' |> List.map fixup_delta_depth in - - // Add to the environment - let env = ses' |> List.fold_left (fun env se -> add_sigelt_to_env env se false) env in - UF.reset(); - - if Options.log_types () || Debug.medium () || !dbg_LogTypes - then BU.print1 "Checked: %s\n" (show ses'); - - Profiling.profile - (fun () -> List.iter (fun se -> env.solver.encode_sig env se) ses') - (Some (Ident.string_of_lid (Env.current_module env))) - "FStar.TypeChecker.Tc.encode_sig"; - - (List.rev_append ses' ses, env), ses_elaborated - end - in - // A wrapper to (maybe) print the time taken for each sigelt - let process_one_decl_timed acc se = - FStar.TypeChecker.Core.clear_memo_table(); - let (_, env) = acc in - let r = - Profiling.profile - (fun () -> process_one_decl acc se) - (Some (Ident.string_of_lid (Env.current_module env))) - "FStar.TypeChecker.Tc.process_one_decl" - // ^ See a special case for this phase in FStar.Options. --timing - // enables it. - in - if Options.profile_group_by_decl() - || Options.timing () // --timing implies --profile_group_by_decl - then begin - let tag = - match lids_of_sigelt se with - | hd::_ -> Ident.string_of_lid hd - | _ -> Range.string_of_range (range_of_sigelt se) - in - Profiling.report_and_clear tag - end; - r - in - let ses, env = - UF.with_uf_enabled (fun () -> - BU.fold_flatten process_one_decl_timed ([], env) ses) in - List.rev_append ses [], env - -let _ = - tc_decls_knot := Some tc_decls - -let snapshot_context env msg = BU.atomically (fun () -> - TypeChecker.Env.snapshot env msg) - -let rollback_context solver msg depth : env = BU.atomically (fun () -> - let env = TypeChecker.Env.rollback solver msg depth in - env) - -let push_context env msg = snd (snapshot_context env msg) -let pop_context env msg = rollback_context env.solver msg None - -let tc_partial_modul env modul = - let verify = Options.should_verify (string_of_lid modul.name) in - let action = if verify then "verifying" else "lax-checking" in - let label = if modul.is_interface then "interface" else "implementation" in - if Debug.any () then - BU.print3 "Now %s %s of %s\n" action label (string_of_lid modul.name); - - Debug.disable_all (); - if Options.should_check (string_of_lid modul.name) // || Options.debug_all_modules () - then Debug.enable_toggles (Options.debug_keys ()); - - let name = BU.format2 "%s %s" (if modul.is_interface then "interface" else "module") (string_of_lid modul.name) in - let env = {env with Env.is_iface=modul.is_interface; admit=not verify} in - let env = Env.set_current_module env modul.name in - (* Only set a context for dependencies *) - Errors.with_ctx_if (not (Options.should_check (string_of_lid modul.name))) - (BU.format2 "While loading dependency %s%s" - (string_of_lid modul.name) - (if modul.is_interface then " (interface)" else "")) (fun () -> - let ses, env = tc_decls env modul.declarations in - {modul with declarations=ses}, env - ) - -let tc_more_partial_modul env modul decls = - let ses, env = tc_decls env decls in - let modul = {modul with declarations=modul.declarations@ses} in - modul, ses, env - -let finish_partial_modul (loading_from_cache:bool) (iface_exists:bool) (en:env) (m:modul) : (modul & env) = - //AR: do we ever call finish_partial_modul for current buffer in the interactive mode? - let env = Env.finish_module en m in - - if not loading_from_cache then ( - let missing = missing_definition_list env in - if Cons? missing then - log_issue env Errors.Error_AdmitWithoutDefinition [ - Pprint.prefix 2 1 (text <| BU.format1 "Missing definitions in module %s:" (string_of_lid m.name)) - (Pprint.separate_map Pprint.hardline (fun l -> pp (ident_of_lid l)) missing) - ] - ); - - //we can clear the lid to query index table - env.qtbl_name_and_index |> snd |> BU.smap_clear; - - //pop BUT ignore the old env - - pop_context env ("Ending modul " ^ string_of_lid m.name) |> ignore; - - if Options.depth () > 0 then - Errors.log_issue env Error_MissingPopOptions - ("Some #push-options have not been popped. Current depth is " ^ show (Options.depth()) ^ "."); - - //moved the code for encoding the module to smt to Universal - - m, env - -let deep_compress_modul (m:modul) : modul = - { m with declarations = List.map (Compress.deep_compress_se false false) m.declarations } - -let tc_modul (env0:env) (m:modul) (iface_exists:bool) :(modul & env) = - let msg = "Internals for " ^ string_of_lid m.name in - //AR: push env, this will also push solver, and then finish_partial_modul will do the pop - let env0 = push_context env0 msg in - let modul, env = tc_partial_modul env0 m in - // Note: all sigelts returned by tc_partial_modul must already be compressed - // by Syntax.compress.deep_compress, so they are safe to output. - finish_partial_modul false iface_exists env modul - -let load_checked_module_sigelts (en:env) (m:modul) : env = - //This function tries to very carefully mimic the effect of the environment - //of having checked the module from scratch, i.e., using tc_module below - let env = Env.set_current_module en m.name in - //push context, finish_partial_modul will do the pop - let env = push_context env ("Internals for " ^ Ident.string_of_lid m.name) in - let env = List.fold_left (fun env se -> - //add every sigelt in the environment - let env = add_sigelt_to_env env se true in - //and then query it back immediately to populate the environment's internal cache - //this is important for extraction to work correctly, - //in particular, when extracting a module we want the module's internal symbols - //that may be marked "abstract" externally to be visible internally - //populating the cache enables this behavior, rather indirectly, sadly : ( - let lids = Util.lids_of_sigelt se in - lids |> List.iter (fun lid -> ignore (Env.lookup_sigelt env lid)); - env) - env - m.declarations in - env - -let load_checked_module (en:env) (m:modul) :env = - (* Another compression pass to make sure we are not loading a corrupt - module. *) - - (* Reset debug flags *) - if Options.should_check (string_of_lid m.name) || Options.debug_all_modules () - then Debug.enable_toggles (Options.debug_keys ()) - else Debug.disable_all (); - - let m = deep_compress_modul m in - let env = load_checked_module_sigelts en m in - //And then call finish_partial_modul, which is the normal workflow of tc_modul below - //except with the flag `must_check_exports` set to false, since this is already a checked module - //the second true flag is for iface_exists, used to determine whether should extract interface or not - let _, env = finish_partial_modul true true env m in - env - -let load_partial_checked_module (en:env) (m:modul) : env = - let m = deep_compress_modul m in - load_checked_module_sigelts en m - -let check_module env0 m b = - if Debug.any() - then BU.print2 "Checking %s: %s\n" (if m.is_interface then "i'face" else "module") (show m.name); - if Options.dump_module (string_of_lid m.name) - then BU.print1 "Module before type checking:\n%s\n" (show m); - - let env = {env0 with admit = not (Options.should_verify (string_of_lid m.name))} in - let m, env = tc_modul env m b in - (* restore admit *) - let env = { env with admit = env0.admit } in - - (* Debug information for level Normalize : normalizes all toplevel declarations an dump the current module *) - if Options.dump_module (string_of_lid m.name) - then BU.print1 "Module after type checking:\n%s\n" (show m); - if Options.dump_module (string_of_lid m.name) && !dbg_Normalize - then begin - let normalize_toplevel_lets = fun se -> match se.sigel with - | Sig_let {lbs=(b, lbs); lids=ids} -> - let n = N.normalize [Env.Beta ; Env.Eager_unfolding; Env.Reify ; Env.Inlining ; Env.Primops ; Env.UnfoldUntil S.delta_constant ; Env.AllowUnboundUniverses ] in - let update lb = - let univnames, e = SS.open_univ_vars lb.lbunivs lb.lbdef in - { lb with lbdef = n (Env.push_univ_vars env univnames) e } - in - { se with sigel = Sig_let {lbs=(b, List.map update lbs); lids=ids} } - | _ -> se - in - let normalized_module = { m with declarations = List.map normalize_toplevel_lets m.declarations } in - BU.print1 "%s\n" (show normalized_module) - end; - - m, env diff --git a/src/typechecker/FStar.TypeChecker.Tc.fsti b/src/typechecker/FStar.TypeChecker.Tc.fsti deleted file mode 100644 index 02cb81fc423..00000000000 --- a/src/typechecker/FStar.TypeChecker.Tc.fsti +++ /dev/null @@ -1,37 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.TypeChecker.Tc -open FStar.Compiler.Effect -open FStar.Compiler.Effect -open FStar.Syntax.Syntax -open FStar.TypeChecker.Env -open FStar.TypeChecker.Common -module EMB = FStar.Syntax.Embeddings - - -val check_module: env -> modul -> bool -> modul & env -val load_checked_module: env -> modul -> env -val load_partial_checked_module: env -> modul -> env - -val pop_context: env -> string -> env -val push_context: env -> string -> env -val snapshot_context: env -> string -> ((int & int & solver_depth_t & int) & env) -val rollback_context: solver_t -> string -> option (int & int & solver_depth_t & int) -> env - -val compress_and_norm: env -> typ -> option typ -val tc_decls: env -> list sigelt -> list sigelt & env -val tc_partial_modul: env -> modul -> modul & env -val tc_more_partial_modul: env -> modul -> list sigelt -> modul & list sigelt & env diff --git a/src/typechecker/FStar.TypeChecker.TcEffect.fst b/src/typechecker/FStar.TypeChecker.TcEffect.fst deleted file mode 100644 index f15f97f2de3..00000000000 --- a/src/typechecker/FStar.TypeChecker.TcEffect.fst +++ /dev/null @@ -1,2770 +0,0 @@ -(* - Copyright 2008-2018 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.TypeChecker.TcEffect -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.Syntax -open FStar.TypeChecker - -open FStar.Compiler.Util -open FStar.Ident -open FStar.Errors -open FStar.Syntax.Syntax -open FStar.TypeChecker.Env -open FStar.TypeChecker.Common -open FStar.TypeChecker.TcTerm - -module PC = FStar.Parser.Const -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module U = FStar.Syntax.Util -module Env = FStar.TypeChecker.Env -module N = FStar.TypeChecker.Normalize -module TcUtil = FStar.TypeChecker.Util -module Gen = FStar.TypeChecker.Generalize -module TEQ = FStar.TypeChecker.TermEqAndSimplify - -module BU = FStar.Compiler.Util -open FStar.Class.Show -open FStar.Class.Tagged - -let dbg = Debug.get_toggle "ED" -let dbg_LayeredEffectsTc = Debug.get_toggle "LayeredEffectsTc" - -let dmff_cps_and_elaborate env ed = - (* This is only an elaboration rule not a typechecking one *) - - // Let the power of Dijkstra generate everything "for free", then defer - // the rest of the job to [tc_decl]. - DMFF.cps_and_elaborate env ed - -(* - * Helper function used to typecheck and generalize various effect combinators - * - * comb is the name of the combinator (used for error messages) - * n is the number of universes that the combinator should be polymorphic in - * (us, t) is the tscheme to check and generalize (us will be [] in the first phase) - *) -let check_and_gen env (eff_name:string) (comb:string) (n:int) (us, t) : (univ_names & term & typ) = - Errors.with_ctx ("While checking combinator " ^ comb ^ " = " ^ show (us, t)) (fun () -> - let us, t = SS.open_univ_vars us t in - let t, ty = - let t, lc, g = tc_tot_or_gtot_term (Env.push_univ_vars env us) t in - Rel.force_trivial_guard env g; - t, lc.res_typ in - let g_us, t = Gen.generalize_universes env t in - let ty = SS.close_univ_vars g_us ty in - //check that n = List.length g_us and that if us is set, it is same as g_us - let univs_ok = - if List.length g_us <> n then - let error = BU.format5 - "Expected %s:%s to be universe-polymorphic in %s universes, but found %s (tscheme: %s)" - eff_name comb (string_of_int n) (g_us |> List.length |> string_of_int) - (Print.tscheme_to_string (g_us, t)) in - raise_error t Errors.Fatal_MismatchUniversePolymorphic error; - match us with - | [] -> () - | _ -> - if List.length us = List.length g_us && - List.forall2 (fun u1 u2 -> S.order_univ_name u1 u2 = 0) us g_us - then () - else raise_error t Errors.Fatal_UnexpectedNumberOfUniverse - (BU.format4 "Expected and generalized universes in the declaration for %s:%s are different, input: %s, but after gen: %s" - eff_name comb (show us) (show g_us)) - in - g_us, t, ty - ) - -(* - * A small gadget to get a uvar for pure wp with given result type - *) -let pure_wp_uvar env (t:typ) (reason:string) (r:Range.range) : term & guard_t = - let pure_wp_t = - let pure_wp_ts = Env.lookup_definition [Env.NoDelta] env PC.pure_wp_lid |> must in - let _, pure_wp_t = Env.inst_tscheme pure_wp_ts in - S.mk_Tm_app - pure_wp_t - [t |> S.as_arg] - r in - - let pure_wp_uvar, _, guard_wp = Env.new_implicit_var_aux reason r env pure_wp_t Strict None false in - pure_wp_uvar, guard_wp - -let (let?) (#a #b:Type) (f:option a) (g:a -> option b) : option b = - match f with - | None -> None - | Some x -> g x - -let mteq (env:env) (t1 t2:typ) : bool = - try - Rel.teq_nosmt_force env t1 t2 - with - | _ -> false - -// -// A gadget used to check for effect combinator kind (substitutive or ad-hoc) -// -// bs1 and bs2 are opened binders from the signature and the effect combinator -// -let eq_binders env (bs1 bs2:binders) : option (list S.indexed_effect_binder_kind) = - if List.fold_left2 (fun (b, ss) b1 b2 -> - b && - mteq env (SS.subst ss b1.binder_bv.sort) b2.binder_bv.sort, - ss@[NT (b1.binder_bv, b2.binder_bv |> S.bv_to_name)]) (true, []) bs1 bs2 - - |> fst - then bs1 |> List.map (fun _ -> Substitutive_binder) |> Some - else None - -let log_ad_hoc_combinator_warning (comb_name:string) (r:Range.range) = - log_issue r Errors.Warning_Adhoc_IndexedEffect_Combinator [ - Errors.text (BU.format1 "Combinator %s is not a substitutive indexed effect combinator, \ - it is better to make it one if possible for better performance and ease of use" comb_name) - ] - -// -// Check bind combinator kind for an indexed effect or polymonadic bind -// -// k is the bind type (in the general indexed effects bind shape) -// -// num_effect_params must be 0 for polymonadic binds -// -// returns None if bind is not Substitutive -// else Some l, where l is the list of binder kinds -// -let bind_combinator_kind (env:env) - (m_eff_name n_eff_name p_eff_name:lident) - (m_sig_ts n_sig_ts p_sig_ts:tscheme) - (m_repr_ts n_repr_ts p_repr_ts:option tscheme) - (bind_us:univ_names) - (k:typ) - (num_effect_params:int) - (has_range_binders:bool) - : option (list indexed_effect_binder_kind) = - - let debug s = - if Debug.medium () || !dbg_LayeredEffectsTc - then BU.print1 "%s\n" s in - - debug (BU.format1 - "Checking bind combinator kind with %s effect parameters" - (string_of_int num_effect_params)); - - // we know k = a:Type u_a -> b:Type u_b -> rest_bs -> optional_range_bs -> f -> g -> Pure repr wp - - let [u_a; u_b] = bind_us in - - let (a_b::b_b::rest_bs) = k |> U.arrow_formals |> fst in - - // we will check that every binder in k has the expected type, - // where the expected types will come from the signatures of the effects - - // check that rest_bs has expected effect parameters - // to check expected, we use the signature from m, - // for polymonadic binds num effect parameters is 0, - // so this code will return from the then branch - let? eff_params_bs, eff_params_bs_kinds, rest_bs = - if num_effect_params = 0 - then ([], [], rest_bs) |> Some - else // take the num effect parameters from m's signature and - // check that those binders are equal to those in k - let _, sig = Env.inst_tscheme_with m_sig_ts [U_name u_a] in - let sig_bs = sig |> U.arrow_formals - |> fst - |> List.tl in - let? sig_eff_params_bs = - if List.length sig_bs < num_effect_params - then None - else List.splitAt num_effect_params sig_bs |> fst |> Some in - let? eff_params_bs, rest_bs = - if List.length rest_bs < num_effect_params - then None - else List.splitAt num_effect_params rest_bs |> Some in - let? eff_params_bs_kinds = eq_binders env sig_eff_params_bs eff_params_bs in - (eff_params_bs, eff_params_bs_kinds, rest_bs) |> Some in - - // check that prefix of rest_bs matches the binders in f's repr - let? f_bs, f_bs_kinds, rest_bs = - // binders in f's signature, - // after substituting eff_params_bs (we need to check for binder equality) - let f_sig_bs = - let _, sig = Env.inst_tscheme_with m_sig_ts [U_name u_a] in - sig |> U.arrow_formals - |> fst - |> (fun (a::bs) -> - let sig_bs, bs = List.splitAt num_effect_params bs in - let ss = List.fold_left2 (fun ss sig_b b -> - ss@[NT (sig_b.binder_bv, b.binder_bv |> S.bv_to_name)] - ) [NT (a.binder_bv, a_b.binder_bv |> S.bv_to_name)] sig_bs eff_params_bs in - bs |> SS.subst_binders ss) in - - let? f_bs, rest_bs = - if List.length rest_bs < List.length f_sig_bs - then None - else List.splitAt (List.length f_sig_bs) rest_bs |> Some in - - let? f_bs_kinds = eq_binders env f_sig_bs f_bs in - - (f_bs, f_bs_kinds, rest_bs) |> Some in - - // same thing for g - - let? g_bs, g_bs_kinds, rest_bs = - let g_sig_bs = - let _, sig = Env.inst_tscheme_with n_sig_ts [U_name u_b] in - sig |> U.arrow_formals - |> fst - |> (fun (b::bs) -> - let sig_bs, bs = List.splitAt num_effect_params bs in - let ss = List.fold_left2 (fun ss sig_b b -> - ss@[NT (sig_b.binder_bv, b.binder_bv |> S.bv_to_name)] - ) [NT (b.binder_bv, b_b.binder_bv |> S.bv_to_name)] sig_bs eff_params_bs in - bs |> SS.subst_binders ss) in - - let? g_bs, rest_bs = - if List.length rest_bs < List.length g_sig_bs - then None - else List.splitAt (List.length g_sig_bs) rest_bs |> Some in - - // - // g's binders may be either abstracted over x:a or un-abstracted, - // so we can't simply do eq_binders, we need to check one binder at a time - // - let? g_bs_kinds = - let g_bs_kinds, _ = List.fold_left2 (fun (l, ss) g_sig_b g_b -> // l is the (bv, kind) list for the binders seen so far - let g_sig_b_sort = SS.subst ss g_sig_b.binder_bv.sort in - let g_sig_b_arrow_t = // expected sort of g_b if the binder were abstracted - let x_bv = S.gen_bv "x" None (a_b.binder_bv |> S.bv_to_name) in - let ss = List.map (fun (bv, k) -> - if k = Substitutive_binder - then [NT (bv, mk_Tm_app (S.bv_to_name bv) [x_bv |> S.bv_to_name |> S.as_arg] Range.dummyRange)] - else []) l |> List.flatten in - let g_sig_b_sort = SS.subst ss g_sig_b_sort in - U.arrow [S.mk_binder x_bv] - (mk_Total g_sig_b_sort) in - let g_b_kind = - if TEQ.eq_tm env g_sig_b_arrow_t g_b.binder_bv.sort = TEQ.Equal - then Substitutive_binder - else if TEQ.eq_tm env g_sig_b_sort g_b.binder_bv.sort = TEQ.Equal - then BindCont_no_abstraction_binder - else Ad_hoc_binder in - let ss = ss@[NT (g_sig_b.binder_bv, g_b.binder_bv |> S.bv_to_name)] in - l@[g_b.binder_bv, g_b_kind], ss) ([], []) g_sig_bs g_bs in - - let g_bs_kinds = List.map snd g_bs_kinds in - if List.contains Ad_hoc_binder g_bs_kinds - then None - else g_bs_kinds |> Some in - - (g_bs, g_bs_kinds, rest_bs) |> Some in - - // peel off range binders if any - - let (range_bs, rest_bs) : (list binder & list binder) = - if has_range_binders - then List.splitAt 2 rest_bs - else [], rest_bs in - - let? rest_bs, f_b, g_b = - if List.length rest_bs >= 2 - then let rest_bs, [f_b; g_b] = List.splitAt (List.length rest_bs - 2) rest_bs in - (rest_bs, f_b, g_b) |> Some - else None in - - // check that the type of the f repr is ok - let? _f_b_ok_ = - let repr_app_bs = eff_params_bs@f_bs in - let expected_f_b_sort = - match m_repr_ts with - | Some repr_ts -> // an indexed effect, so repr applied to a and bs - let _, t = Env.inst_tscheme_with repr_ts [U_name u_a] in - S.mk_Tm_app t - ((a_b.binder_bv |> S.bv_to_name |> S.as_arg):: - (List.map (fun {binder_bv=b} -> b |> S.bv_to_name |> S.as_arg) repr_app_bs)) - Range.dummyRange - | None -> // a primitive effect, so unit -> M a bs - U.arrow [S.null_binder S.t_unit] - (mk_Comp ({ - comp_univs = [U_name u_a]; - effect_name = m_eff_name; - result_typ = a_b.binder_bv |> S.bv_to_name; - effect_args = repr_app_bs |> List.map (fun b -> b.binder_bv |> S.bv_to_name |> S.as_arg); - flags = []})) in - if TEQ.eq_tm env f_b.binder_bv.sort expected_f_b_sort = TEQ.Equal - then Some () - else None in - - // check that the type of g repr is ok - let? _g_b_ok = - let expected_g_b_sort = - let x_bv = S.gen_bv "x" None (a_b.binder_bv |> S.bv_to_name) in - let eff_params_args = List.map (fun {binder_bv=b} -> b |> S.bv_to_name |> S.as_arg) eff_params_bs in - let g_bs_args = - List.map2 (fun {binder_bv=b} kind -> - // we know here that kind is either Substitutive or BindCont_no_abs - if kind = Substitutive_binder - then S.mk_Tm_app (b |> S.bv_to_name) [x_bv |> S.bv_to_name |> S.as_arg] Range.dummyRange - else b |> S.bv_to_name) g_bs g_bs_kinds - |> List.map S.as_arg in - let repr_args = eff_params_args@g_bs_args in - - match n_repr_ts with - | Some repr_ts -> - let _, repr_hd = Env.inst_tscheme_with repr_ts [U_name u_b] in - let repr_app = mk_Tm_app repr_hd - ((b_b.binder_bv |> S.bv_to_name |> S.as_arg)::repr_args) - Range.dummyRange in - U.arrow [x_bv |> S.mk_binder] (mk_Total repr_app) - | None -> - let thunk_t = U.arrow [S.null_binder S.t_unit] - (mk_Comp ({ - comp_univs = [U_name u_b]; - effect_name = n_eff_name; - result_typ = b_b.binder_bv |> S.bv_to_name; - effect_args = repr_args; - flags = []})) in - U.arrow [x_bv |> S.mk_binder] (mk_Total thunk_t) in - if TEQ.eq_tm env g_b.binder_bv.sort expected_g_b_sort = TEQ.Equal - then Some () - else None in - - let range_kinds = List.map (fun _ -> Range_binder) range_bs in - - // remaining binders in rest_bs are all ad-hoc - let rest_kinds = List.map (fun _ -> Ad_hoc_binder) rest_bs in - - Some ([Type_binder; Type_binder] @ - eff_params_bs_kinds @ - f_bs_kinds @ - g_bs_kinds @ - range_kinds @ - rest_kinds @ - [Repr_binder; Repr_binder]) - -// -// Validate that the indexed effect bind has the expected shape, -// and return its canonical type and combinator kind -// -let validate_indexed_effect_bind_shape (env:env) - (m_eff_name n_eff_name p_eff_name:lident) - (m_sig_ts n_sig_ts p_sig_ts:tscheme) - (m_repr_ts n_repr_ts p_repr_ts:option tscheme) - (bind_us:univ_names) - (bind_t:typ) - (r:Range.range) - (num_effect_params:int) - (has_range_binders:bool) - : typ & indexed_effect_combinator_kind = - - let bind_name = BU.format3 "(%s , %s) |> %s" - (string_of_lid m_eff_name) - (string_of_lid n_eff_name) - (string_of_lid p_eff_name) in - - let [u_a; u_b] = bind_us in - - // - // First check that bind has the general shape: - // a:Type u_a -> b:Type u_b -> some_bs -> optional_range_bs -> f -> g -> PURE repr wp - // - // We do so by creating expected type k = the arrow type above, - // and unifying it with bind_t - // - - // a:Type and b:Type binders - let a_b = (U_name u_a) |> U.type_with_u |> S.gen_bv "a" None |> S.mk_binder in - let b_b = (U_name u_b) |> U.type_with_u |> S.gen_bv "b" None |> S.mk_binder in - - // rest_bs are opened and have their a and b substituted with a_b and b_b - let rest_bs = - match (SS.compress bind_t).n with - | Tm_arrow {bs} when List.length bs >= 4 -> - // peel off a and b from bs - let ({binder_bv=a})::({binder_bv=b})::bs = SS.open_binders bs in - // peel off f and g from the end of bs - bs |> List.splitAt (List.length bs - 2) |> fst - |> SS.subst_binders [NT (a, a_b.binder_bv |> S.bv_to_name); - NT (b, b_b.binder_bv |> S.bv_to_name)] - | _ -> - raise_error r Errors.Fatal_UnexpectedEffect - (BU.format2 "Type of %s is not an arrow with >= 4 binders (%s)" - bind_name - (show bind_t)) in - - - // peel off range binders from the end, if any - let rest_bs, range_bs = - if has_range_binders - then if List.length rest_bs >= 2 - then List.splitAt (List.length rest_bs - 2) rest_bs - else raise_error r Errors.Fatal_UnexpectedEffect - (BU.format2 "Type of %s is not an arrow with >= 6 binders (%s)" - bind_name - (show bind_t)) - else rest_bs, [] in - - // f binder with sort m_repr ?us - let f, guard_f = - let repr, g = TcUtil.fresh_effect_repr - (Env.push_binders env (a_b::b_b::rest_bs)) - r - m_eff_name - m_sig_ts - m_repr_ts - (U_name u_a) - (a_b.binder_bv |> S.bv_to_name) in - repr |> S.gen_bv "f" None |> S.mk_binder, g in - - // g binder with sort (x:a -> n_repr ?us) - let g, guard_g = - let x_a = a_b.binder_bv |> S.bv_to_name |> S.gen_bv "x" None |> S.mk_binder in - let repr, g = TcUtil.fresh_effect_repr - (Env.push_binders env (a_b::b_b::rest_bs@[x_a])) - r - n_eff_name - n_sig_ts - n_repr_ts - (U_name u_b) - (b_b.binder_bv |> S.bv_to_name) in - S.gen_bv "g" None (U.arrow [x_a] (S.mk_Total repr)) |> S.mk_binder, - g in - - // return repr type p_repr ?us - let return_repr, guard_return_repr = TcUtil.fresh_effect_repr - (Env.push_binders env (a_b::b_b::rest_bs)) - r - p_eff_name - p_sig_ts - p_repr_ts - (U_name u_b) - (b_b.binder_bv |> S.bv_to_name) in - - let pure_wp_uvar, g_pure_wp_uvar = pure_wp_uvar - (Env.push_binders env (a_b::b_b::rest_bs)) - return_repr - (BU.format1 "implicit for pure_wp in checking bind %s" bind_name) - r in - - let k = U.arrow (a_b::b_b::(rest_bs@range_bs@[f; g])) (S.mk_Comp ({ - comp_univs = [Env.new_u_univ ()]; - effect_name = PC.effect_PURE_lid; - result_typ = return_repr; - effect_args = [pure_wp_uvar |> S.as_arg]; - flags = [] })) in - - let guard_eq = - match Rel.teq_nosmt env k bind_t with - | None -> - raise_error r Errors.Fatal_UnexpectedEffect - (BU.format2 "Unexpected type of %s (%s)\n" - bind_name - (show bind_t)) - | Some g -> g in - - Rel.force_trivial_guard env (Env.conj_guards [ - guard_f; - guard_g; - guard_return_repr; - g_pure_wp_uvar; - guard_eq]); - - let k = k |> N.remove_uvar_solutions env |> SS.compress in - - let lopt = bind_combinator_kind env m_eff_name n_eff_name p_eff_name - m_sig_ts n_sig_ts p_sig_ts - m_repr_ts n_repr_ts p_repr_ts - bind_us - k - num_effect_params - has_range_binders in - - let kind = - match lopt with - | None -> - log_ad_hoc_combinator_warning bind_name r; - Ad_hoc_combinator - | Some l -> Substitutive_combinator l in - - if Debug.medium () || !dbg_LayeredEffectsTc - then BU.print2 "Bind %s has %s kind\n" bind_name (show kind); - - k, kind - -// -// Check subcomp combinator kind -// -// Used for both indexed effects subcomp and polymonadic subcomp -// -let subcomp_combinator_kind (env:env) - (m_eff_name n_eff_name:lident) - (m_sig_ts n_sig_ts:tscheme) - (m_repr_ts n_repr_ts:option tscheme) - (u:univ_name) - (k:typ) - (num_effect_params:int) - - : option S.indexed_effect_combinator_kind = - - // the idea is same as that of bind - // we will check that each binder in k has expected type, - // where the expected types will come from signatures and reprs of m and n - - let a_b::rest_bs, k_c = k |> U.arrow_formals_comp in - - let? eff_params_bs, eff_params_bs_kinds, rest_bs = - if num_effect_params = 0 - then ([], [], rest_bs) |> Some - else let _, sig = Env.inst_tscheme_with m_sig_ts [U_name u] in - let _::sig_bs, _ = sig |> U.arrow_formals in - let sig_effect_params_bs = List.splitAt num_effect_params sig_bs |> fst in - let eff_params_bs, rest_bs = List.splitAt num_effect_params rest_bs in - let? eff_params_bs_kinds = eq_binders env sig_effect_params_bs eff_params_bs in - (eff_params_bs, eff_params_bs_kinds, rest_bs) |> Some in - - let? f_bs, f_bs_kinds, rest_bs = - let f_sig_bs = - let _, sig = Env.inst_tscheme_with m_sig_ts [U_name u] in - sig |> U.arrow_formals - |> fst - |> (fun (a::bs) -> - let sig_bs, bs = List.splitAt num_effect_params bs in - let ss = List.fold_left2 (fun ss sig_b b -> - ss@[NT (sig_b.binder_bv, b.binder_bv |> S.bv_to_name)] - ) [NT (a.binder_bv, a_b.binder_bv |> S.bv_to_name)] sig_bs eff_params_bs in - bs |> SS.subst_binders ss) in - - let? f_bs, rest_bs = - if List.length rest_bs < List.length f_sig_bs - then None - else List.splitAt (List.length f_sig_bs) rest_bs |> Some in - - let? f_bs_kinds = eq_binders env f_sig_bs f_bs in - - (f_bs, f_bs_kinds, rest_bs) |> Some in - - // peel off the f:repr a is binder - let? rest_bs, f_b = - if List.length rest_bs >= 1 - then let rest_bs, [f_b] = List.splitAt (List.length rest_bs - 1) rest_bs in - (rest_bs, f_b) |> Some - else None in - - // check that f repr binder has the expected type - let? _f_b_ok_ = - let expected_f_b_sort = - match m_repr_ts with - | Some repr_ts -> - let _, t = Env.inst_tscheme_with repr_ts [U_name u] in - S.mk_Tm_app t - ((a_b.binder_bv |> S.bv_to_name |> S.as_arg):: - (List.map (fun {binder_bv=b} -> b |> S.bv_to_name |> S.as_arg) (eff_params_bs@f_bs))) - Range.dummyRange - | None -> - U.arrow [S.null_binder S.t_unit] - (mk_Comp ({ - comp_univs = [U_name u]; - effect_name = m_eff_name; - result_typ = a_b.binder_bv |> S.bv_to_name; - effect_args = (eff_params_bs@f_bs) |> List.map (fun b -> b.binder_bv |> S.bv_to_name |> S.as_arg); - flags = []})) in - if TEQ.eq_tm env f_b.binder_bv.sort expected_f_b_sort = TEQ.Equal - then Some () - else None in - - let check_ret_t (f_or_g_bs:binders) : option unit = - let expected_t = - match n_repr_ts with - | Some repr_ts -> - let _, t = Env.inst_tscheme_with repr_ts [U_name u] in - S.mk_Tm_app t - ((a_b.binder_bv |> S.bv_to_name |> S.as_arg):: - (List.map (fun {binder_bv=b} -> b |> S.bv_to_name |> S.as_arg) (eff_params_bs@f_or_g_bs))) - Range.dummyRange - | None -> - U.arrow [S.null_binder S.t_unit] - (mk_Comp ({ - comp_univs = [U_name u]; - effect_name = n_eff_name; - result_typ = a_b.binder_bv |> S.bv_to_name; - effect_args = (eff_params_bs@f_or_g_bs) |> List.map (fun b -> b.binder_bv |> S.bv_to_name |> S.as_arg); - flags = []})) in - if TEQ.eq_tm env (U.comp_result k_c) expected_t = TEQ.Equal - then Some () - else None in - - if Some? (check_ret_t f_bs) - then Some Substitutive_invariant_combinator - else begin - let? g_bs, g_bs_kinds, rest_bs = - let g_sig_bs = - let _, sig = Env.inst_tscheme_with n_sig_ts [U_name u] in - sig |> U.arrow_formals - |> fst - |> (fun (a::bs) -> - let sig_bs, bs = List.splitAt num_effect_params bs in - let ss = List.fold_left2 (fun ss sig_b b -> - ss@[NT (sig_b.binder_bv, b.binder_bv |> S.bv_to_name)] - ) [NT (a.binder_bv, a_b.binder_bv |> S.bv_to_name)] sig_bs eff_params_bs in - bs |> SS.subst_binders ss) in - - let? g_bs, rest_bs = - if List.length rest_bs < List.length g_sig_bs - then None - else List.splitAt (List.length g_sig_bs) rest_bs |> Some in - - let? g_bs_kinds = eq_binders env g_sig_bs g_bs in - - (g_bs, g_bs_kinds, rest_bs) |> Some in - - // check subcomp return type is expected - let? _ret_t_ok_ = check_ret_t g_bs in - - // rest of the binders are ad-hoc - let rest_kinds = List.map (fun _ -> Ad_hoc_binder) rest_bs in - - Some (([Type_binder] @ - eff_params_bs_kinds @ - f_bs_kinds @ - g_bs_kinds@rest_kinds@ - [Repr_binder]) |> Substitutive_combinator) - end - -// -// Validate indexed effect subcomp (including polymonadic subcomp) shape -// and compute its kind -// -let validate_indexed_effect_subcomp_shape (env:env) - (m_eff_name n_eff_name:lident) - (m_sig_ts n_sig_ts:tscheme) - (m_repr_ts n_repr_ts:option tscheme) - (u:univ_name) - (subcomp_t:typ) - (num_effect_params:int) - (r:Range.range) - : typ & indexed_effect_combinator_kind = - - let subcomp_name = BU.format2 "%s <: %s" - (string_of_lid m_eff_name) - (string_of_lid n_eff_name) in - - let a_b = (U_name u) |> U.type_with_u |> S.gen_bv "a" None |> S.mk_binder in - - let rest_bs = - match (SS.compress subcomp_t).n with - | Tm_arrow {bs} when List.length bs >= 2 -> - // peel off a:Type - let ({binder_bv=a})::bs = SS.open_binders bs in - // peel off f:repr from the end - bs |> List.splitAt (List.length bs - 1) |> fst - |> SS.subst_binders [NT (a, bv_to_name a_b.binder_bv)] - | _ -> - raise_error r Errors.Fatal_UnexpectedEffect - (BU.format2 "Type of %s is not an arrow with >= 2 binders (%s)" - subcomp_name - (show subcomp_t)) in - - let f, guard_f = - let repr, g = TcUtil.fresh_effect_repr - (Env.push_binders env (a_b::rest_bs)) - r - m_eff_name - m_sig_ts - m_repr_ts - (U_name u) - (a_b.binder_bv |> S.bv_to_name) in - repr |> S.gen_bv "f" None |> S.mk_binder, g in - - let ret_t, guard_ret_t = TcUtil.fresh_effect_repr - (Env.push_binders env (a_b::rest_bs)) - r - n_eff_name - n_sig_ts - n_repr_ts - (U_name u) - (a_b.binder_bv |> S.bv_to_name) in - - let pure_wp_uvar, guard_wp = pure_wp_uvar - (Env.push_binders env (a_b::rest_bs)) - ret_t - (BU.format1 "implicit for pure_wp in checking %s" subcomp_name) - r in - - let c = S.mk_Comp ({ - comp_univs = [ Env.new_u_univ () ]; - effect_name = PC.effect_PURE_lid; - result_typ = ret_t; - effect_args = [ pure_wp_uvar |> S.as_arg ]; - flags = [] }) in - - let k = U.arrow (a_b::rest_bs@[f]) c in - - if Debug.medium () || !dbg_LayeredEffectsTc then - BU.print1 "Expected type of subcomp before unification: %s\n" - (show k); - - let guard_eq = - match Rel.teq_nosmt env subcomp_t k with - | None -> - raise_error r Errors.Fatal_UnexpectedEffect - (BU.format2 "Unexpected type of %s (%s)\n" - subcomp_name - (show subcomp_t)) - | Some g -> g in - - - Rel.force_trivial_guard env (Env.conj_guards [ - guard_f; - guard_ret_t; - guard_wp; - guard_eq ]); - - let k = k |> N.remove_uvar_solutions env |> SS.compress in - - let kopt = subcomp_combinator_kind env m_eff_name n_eff_name - m_sig_ts n_sig_ts - m_repr_ts n_repr_ts - u - k - num_effect_params in - - let kind = - match kopt with - | None -> - log_ad_hoc_combinator_warning subcomp_name r; - Ad_hoc_combinator - | Some k -> k in - - if Debug.medium () || !dbg_LayeredEffectsTc - then BU.print2 "Subcomp %s has %s kind\n" subcomp_name (show kind); - - - k, kind - -// -// Check the kind of an indexed effect ite combinator -// -let ite_combinator_kind (env:env) - (eff_name:lident) - (sig_ts repr_ts:tscheme) - (u:univ_name) - (tm:term) - (num_effect_params:int) - - : option S.indexed_effect_combinator_kind = - - let a_b::rest_bs, _, _ = U.abs_formals tm in - - let? eff_params_bs, eff_params_bs_kinds, rest_bs = - if num_effect_params = 0 - then ([], [], rest_bs) |> Some - else let _, sig = Env.inst_tscheme_with sig_ts [U_name u] in - let _::sig_bs, _ = sig |> U.arrow_formals in - let sig_effect_params_bs = List.splitAt num_effect_params sig_bs |> fst in - let eff_params_bs, rest_bs = List.splitAt num_effect_params rest_bs in - let? eff_params_bs_kinds = eq_binders env sig_effect_params_bs eff_params_bs in - (eff_params_bs, eff_params_bs_kinds, rest_bs) |> Some in - - let? f_bs, f_bs_kinds, rest_bs = - let f_sig_bs = - let _, sig = Env.inst_tscheme_with sig_ts [U_name u] in - sig |> U.arrow_formals - |> fst - |> (fun (a::bs) -> - let sig_bs, bs = List.splitAt num_effect_params bs in - let ss = List.fold_left2 (fun ss sig_b b -> - ss@[NT (sig_b.binder_bv, b.binder_bv |> S.bv_to_name)] - ) [NT (a.binder_bv, a_b.binder_bv |> S.bv_to_name)] sig_bs eff_params_bs in - bs |> SS.subst_binders ss) in - - let? f_bs, rest_bs = - if List.length rest_bs < List.length f_sig_bs - then None - else List.splitAt (List.length f_sig_bs) rest_bs |> Some in - - let? f_bs_kinds = eq_binders env f_sig_bs f_bs in - - (f_bs, f_bs_kinds, rest_bs) |> Some in - - let? rest_bs, [f_b; g_b; p_b] = - if List.length rest_bs >= 3 - then List.splitAt (List.length rest_bs - 3) rest_bs |> Some - else None in - - let? _f_b_ok_ = - let expected_f_b_sort = - let _, t = Env.inst_tscheme_with repr_ts [U_name u] in - S.mk_Tm_app t - ((a_b.binder_bv |> S.bv_to_name |> S.as_arg):: - (List.map (fun {binder_bv=b} -> b |> S.bv_to_name |> S.as_arg) (eff_params_bs@f_bs))) - Range.dummyRange in - if TEQ.eq_tm env f_b.binder_bv.sort expected_f_b_sort = TEQ.Equal - then Some () - else None in - - let check_g_b (f_or_g_bs:binders) : option unit = - let expected_g_b_sort = - let _, t = Env.inst_tscheme_with repr_ts [U_name u] in - S.mk_Tm_app t - ((a_b.binder_bv |> S.bv_to_name |> S.as_arg):: - (List.map (fun {binder_bv=b} -> b |> S.bv_to_name |> S.as_arg) (eff_params_bs@f_or_g_bs))) - Range.dummyRange in - if TEQ.eq_tm env g_b.binder_bv.sort expected_g_b_sort = TEQ.Equal - then Some () - else None in - - if Some? (check_g_b f_bs) - then Some Substitutive_invariant_combinator - else begin - let? g_bs, g_bs_kinds, rest_bs = - let g_sig_bs = - let _, sig = Env.inst_tscheme_with sig_ts [U_name u] in - sig |> U.arrow_formals - |> fst - |> (fun (a::bs) -> - let sig_bs, bs = List.splitAt num_effect_params bs in - let ss = List.fold_left2 (fun ss sig_b b -> - ss@[NT (sig_b.binder_bv, b.binder_bv |> S.bv_to_name)] - ) [NT (a.binder_bv, a_b.binder_bv |> S.bv_to_name)] sig_bs eff_params_bs in - bs |> SS.subst_binders ss) in - - let? g_bs, rest_bs = - if List.length rest_bs < List.length g_sig_bs - then None - else List.splitAt (List.length g_sig_bs) rest_bs |> Some in - - let? g_bs_kinds = eq_binders env g_sig_bs g_bs in - - (g_bs, g_bs_kinds, rest_bs) |> Some in - - let? _g_b_ok_ = check_g_b g_bs in - - let rest_kinds = List.map (fun _ -> Ad_hoc_binder) rest_bs in - - Some ([Type_binder] @ - eff_params_bs_kinds@ - f_bs_kinds @ - g_bs_kinds @ - rest_kinds @ - [Repr_binder; Repr_binder; Substitutive_binder] |> Substitutive_combinator) - - end - -// -// Validate the shape of an indexed effect ite combinator, -// and compute its kind -// -let validate_indexed_effect_ite_shape (env:env) - (eff_name:lident) - (sig_ts:tscheme) - (repr_ts:tscheme) - (u:univ_name) - (ite_ty:typ) - (ite_tm:term) - (num_effect_params:int) - (r:Range.range) - - : term & indexed_effect_combinator_kind = - - let ite_name = BU.format1 "ite_%s" (string_of_lid eff_name) in - - let a_b = u |> U_name |> U.type_with_u |> S.gen_bv "a" None |> S.mk_binder in - - let rest_bs = - match (SS.compress ite_ty).n with - | Tm_arrow {bs} when List.length bs >= 4 -> - // peel off a:Type - let (({binder_bv=a})::bs) = SS.open_binders bs in - // peel off f:repr, g:repr, p:bool from the end - bs |> List.splitAt (List.length bs - 3) |> fst - |> SS.subst_binders [NT (a, a_b.binder_bv |> S.bv_to_name)] - | _ -> - raise_error r Errors.Fatal_UnexpectedEffect - (BU.format2 "Type of %s is not an arrow with >= 4 binders (%s)" - ite_name - (show ite_ty)) in - - let f, guard_f = - let repr, g = TcUtil.fresh_effect_repr - (Env.push_binders env (a_b::rest_bs)) - r - eff_name - sig_ts - (Some repr_ts) - (U_name u) - (a_b.binder_bv |> S.bv_to_name) in - repr |> S.gen_bv "f" None |> S.mk_binder, g in - - let g, guard_g = - let repr, g = TcUtil.fresh_effect_repr - (Env.push_binders env (a_b::rest_bs)) - r - eff_name - sig_ts - (Some repr_ts) - (U_name u) - (a_b.binder_bv |> S.bv_to_name) in - repr |> S.gen_bv "g" None |> S.mk_binder, g in - - let p = S.gen_bv "p" None U.t_bool |> S.mk_binder in - - let body_tm, guard_body = TcUtil.fresh_effect_repr - (Env.push_binders env (a_b::rest_bs@[p])) - r - eff_name - sig_ts - (Some repr_ts) - (U_name u) - (a_b.binder_bv |> S.bv_to_name) in - - let k = U.abs (a_b::rest_bs@[f; g; p]) body_tm None in - - let guard_eq = - match Rel.teq_nosmt env ite_tm k with - | None -> - raise_error r Errors.Fatal_UnexpectedEffect - (BU.format2 "Unexpected term for %s (%s)\n" - ite_name - (show ite_tm)) - | Some g -> g in - - Rel.force_trivial_guard env (Env.conj_guards [ - guard_f; - guard_g; - guard_body; - guard_eq ]); - - let k = k |> N.remove_uvar_solutions env |> SS.compress in - - let kopt = ite_combinator_kind env eff_name sig_ts repr_ts u k num_effect_params in - - let kind = - match kopt with - | None -> - log_ad_hoc_combinator_warning ite_name r; - Ad_hoc_combinator - | Some k -> k in - - if Debug.medium () || !dbg_LayeredEffectsTc - then BU.print2 "Ite %s has %s kind\n" ite_name - (show kind); - - k, kind - - -// -// Validate the shape of an indexed effect close combinator -// -// Only substitutive close combinator is supported -// fun (a:Type) (b:Type) (is:b -> is_t) (f:(x:a -> repr a (is x))) -> repr a js -// -let validate_indexed_effect_close_shape (env:env) - (eff_name:lident) - (sig_ts:tscheme) - (repr_ts:tscheme) - (u_a:univ_name) - (u_b:univ_name) - (close_tm:term) - (num_effect_params:int) - (r:Range.range) : term = - - let close_name = BU.format1 "close_%s" (string_of_lid eff_name) in - - let b_b = u_b |> U_name |> U.type_with_u |> S.gen_bv "b" None |> S.mk_binder in - - let a_b::sig_bs = Env.inst_tscheme_with sig_ts [U_name u_a] |> snd |> U.arrow_formals |> fst in - let eff_params_bs, sig_bs = List.splitAt num_effect_params sig_bs in - let bs = List.map (fun b -> - let x_b = S.gen_bv "x" None (S.bv_to_name b_b.binder_bv) |> S.mk_binder in - {b with binder_bv={b.binder_bv with sort=U.arrow [x_b] (S.mk_Total b.binder_bv.sort)}} - ) sig_bs in - let f_b = - let _, repr_t = Env.inst_tscheme_with repr_ts [U_name u_a] in - let x_b = S.gen_bv "x" None (S.bv_to_name b_b.binder_bv) |> S.mk_binder in - let is_args = - List.map (fun {binder_bv} -> - S.mk_Tm_app (S.bv_to_name binder_bv) [x_b.binder_bv |> S.bv_to_name |> S.as_arg] Range.dummyRange - |> S.as_arg) bs in - let repr_app = S.mk_Tm_app repr_t ((a_b.binder_bv |> S.bv_to_name |> S.as_arg)::is_args) Range.dummyRange in - let f_sort = U.arrow [x_b] (S.mk_Total repr_app) in - S.gen_bv "f" None f_sort |> S.mk_binder in - let env = Env.push_binders env (a_b::b_b::(eff_params_bs@bs)) in - let body_tm, g_body = TcUtil.fresh_effect_repr - env - r - eff_name - sig_ts - (Some repr_ts) - (U_name u_a) - (a_b.binder_bv |> S.bv_to_name) in - - let k = U.abs (a_b::b_b::(eff_params_bs@bs@[f_b])) body_tm None in - - let g_eq = - match Rel.teq_nosmt env close_tm k with - | None -> - raise_error r Errors.Fatal_UnexpectedEffect - (BU.format2 "Unexpected term for %s (%s)\n" - close_name - (show close_tm)) - | Some g -> g in - - Rel.force_trivial_guard env (Env.conj_guard g_body g_eq); - - k |> N.remove_uvar_solutions env |> SS.compress - -// -// Check the kind of an indexed effect lift -// -let lift_combinator_kind (env:env) - (m_eff_name:lident) - (m_sig_ts:tscheme) - (m_repr_ts:option tscheme) - (u:univ_name) - (k:typ) - : option (list indexed_effect_binder_kind) = - - let a_b::rest_bs, _ = U.arrow_formals k in - - let? f_bs, f_bs_kinds, rest_bs = - let f_sig_bs = - let _, sig = Env.inst_tscheme_with m_sig_ts [U_name u] in - sig |> U.arrow_formals - |> fst - |> (fun (a::bs) -> - SS.subst_binders [NT (a.binder_bv, a_b.binder_bv |> S.bv_to_name)] bs) in - - let? f_bs, rest_bs = - if List.length rest_bs < List.length f_sig_bs - then None - else List.splitAt (List.length f_sig_bs) rest_bs |> Some in - - let? f_bs_kinds = eq_binders env f_sig_bs f_bs in - - (f_bs, f_bs_kinds, rest_bs) |> Some in - - let? rest_bs, f_b = - if List.length rest_bs >= 1 - then let rest_bs, [f_b] = List.splitAt (List.length rest_bs - 1) rest_bs in - (rest_bs, f_b) |> Some - else None in - - let? _f_b_ok_ = - let expected_f_b_sort = - match m_repr_ts with - | Some repr_ts -> - let _, t = Env.inst_tscheme_with repr_ts [U_name u] in - S.mk_Tm_app t - ((a_b.binder_bv |> S.bv_to_name |> S.as_arg):: - (List.map (fun {binder_bv=b} -> b |> S.bv_to_name |> S.as_arg) f_bs)) - Range.dummyRange - | None -> - U.arrow [S.null_binder S.t_unit] - (mk_Comp ({ - comp_univs = [U_name u]; - effect_name = m_eff_name; - result_typ = a_b.binder_bv |> S.bv_to_name; - effect_args = f_bs |> List.map (fun b -> b.binder_bv |> S.bv_to_name |> S.as_arg); - flags = []})) in - if TEQ.eq_tm env f_b.binder_bv.sort expected_f_b_sort = TEQ.Equal - then Some () - else None in - - let rest_kinds = List.map (fun _ -> Ad_hoc_binder) rest_bs in - - Some ([Type_binder]@ - f_bs_kinds @ - rest_kinds @ - [Repr_binder]) - -// -// Validate the shape of an indexed effect lift, -// and compute its kind -// -let validate_indexed_effect_lift_shape (env:env) - (m_eff_name n_eff_name:lident) - (u:univ_name) - (lift_t:typ) - (r:Range.range) - : typ & indexed_effect_combinator_kind = - - let lift_name = BU.format2 "%s ~> %s" - (string_of_lid m_eff_name) - (string_of_lid n_eff_name) in - - let lift_t_shape_error s = BU.format2 "Unexpected shape of lift %s, reason:%s" - lift_name - s in - - let m_ed, n_ed = Env.get_effect_decl env m_eff_name, Env.get_effect_decl env n_eff_name in - - let a_b = (U_name u) |> U.type_with_u |> S.gen_bv "a" None |> S.mk_binder in - - let rest_bs, lift_eff = - match (SS.compress lift_t).n with - | Tm_arrow {bs; comp=c} when List.length bs >= 2 -> - // peel off a:Type - let (({binder_bv=a})::bs) = SS.open_binders bs in - // peel off f:repr from the end - bs |> List.splitAt (List.length bs - 1) |> fst - |> SS.subst_binders [NT (a, bv_to_name a_b.binder_bv)], - U.comp_effect_name c |> Env.norm_eff_name env - | _ -> - raise_error r Errors.Fatal_UnexpectedExpressionType - (lift_t_shape_error "either not an arrow, or not enough binders") in - - if (not ((lid_equals lift_eff PC.effect_PURE_lid) || - (lid_equals lift_eff PC.effect_GHOST_lid && Env.is_erasable_effect env m_eff_name))) - then raise_error r Errors.Fatal_UnexpectedExpressionType - (lift_t_shape_error "the lift combinator has an unexpected effect: \ - it must either be PURE or if the source effect is erasable then may be GHOST"); - - let f, guard_f = - let repr, g = TcUtil.fresh_effect_repr - (Env.push_binders env (a_b::rest_bs)) - r - m_eff_name - (U.effect_sig_ts m_ed.signature) - (U.get_eff_repr m_ed) - (U_name u) - (a_b.binder_bv |> S.bv_to_name) in - - repr |> S.gen_bv "f" None |> S.mk_binder, g in - - let ret_t, guard_ret_t = TcUtil.fresh_effect_repr - (Env.push_binders env (a_b::rest_bs)) - r - n_eff_name - (U.effect_sig_ts n_ed.signature) - (U.get_eff_repr n_ed) - (U_name u) - (a_b.binder_bv |> S.bv_to_name) in - - let pure_wp_uvar, guard_wp = pure_wp_uvar (Env.push_binders env (a_b::rest_bs)) ret_t - (BU.format1 "implicit for pure_wp in typechecking lift %s" lift_name) r in - - let c = S.mk_Comp ({ - comp_univs = [ Env.new_u_univ () ]; - effect_name = lift_eff; - result_typ = ret_t; - effect_args = [ pure_wp_uvar |> S.as_arg ]; - flags = [] }) in - - let k = U.arrow (a_b::rest_bs@[f]) c in - - let guard_eq = - match Rel.teq_nosmt env lift_t k with - | None -> - raise_error r Errors.Fatal_UnexpectedEffect - (BU.format2 "Unexpected type of %s (%s)\n" - lift_name - (show lift_t)) - | Some g -> g in - - Rel.force_trivial_guard env (Env.conj_guards [ - guard_f; - guard_ret_t; - guard_wp; - guard_eq ]); - - let k = k |> N.remove_uvar_solutions env |> SS.compress in - - let lopt = lift_combinator_kind env m_eff_name (U.effect_sig_ts m_ed.signature) - (U.get_eff_repr m_ed) - u k in - - let kind = - match lopt with - | None -> - log_ad_hoc_combinator_warning lift_name r; - Ad_hoc_combinator - | Some l -> Substitutive_combinator l in - - if Debug.medium () || !dbg_LayeredEffectsTc - then BU.print2 "Lift %s has %s kind\n" lift_name - (show kind); - - - k, kind - -(* - * Typechecking of layered effects - * - * If the effect is reifiable, returns reify__M sigelt also - *) -let tc_layered_eff_decl env0 (ed : S.eff_decl) (quals : list qualifier) (attrs : list S.attribute) = -Errors.with_ctx (BU.format1 "While checking layered effect definition `%s`" (string_of_lid ed.mname)) (fun () -> - if !dbg_LayeredEffectsTc then - BU.print1 "Typechecking layered effect: \n\t%s\n" (show ed); - - //we don't support effect binders in layered effects yet - if List.length ed.univs <> 0 || List.length ed.binders <> 0 then - raise_error ed.mname Errors.Fatal_UnexpectedEffect - ("Binders are not supported for layered effects (" ^ (string_of_lid ed.mname) ^")"); - - let log_combinator s (us, t, ty) = - if !dbg_LayeredEffectsTc then - BU.print4 "Typechecked %s:%s = %s:%s\n" - (string_of_lid ed.mname) s - (Print.tscheme_to_string (us, t)) (Print.tscheme_to_string (us, ty)) in - - //helper function to get (a:Type ?u), returns the binder and ?u - let fresh_a_and_u_a (a:string) : binder & universe = U.type_u () |> (fun (t, u) -> S.gen_bv a None t |> S.mk_binder, u) in - //helper function to get (x:a) - let fresh_x_a (x:string) (a:binder) : binder = S.gen_bv x None (S.bv_to_name a.binder_bv) |> S.mk_binder in - - - (* - * We now typecheck various combinators - * In all the cases we take the following approach: - * - Typecheck the combinator (with no expected type) - * - Construct an expected type (k) using uvars - * - Unify the type of the combinator (as typechecked) with k - * - Record k in the effect declaration (along with the combinator) - *) - - let check_and_gen = check_and_gen env0 (string_of_lid ed.mname) in - - - (* - * Effect signature - * - * The signature term must have the form: - * a:Type -> -> Effect //polymorphic in one universe (that of a) - * - * The binders become the effect indices - *) - let num_effect_params, signature = - let n, sig_ts = - match ed.signature with - | Layered_eff_sig (n, ts) -> n, ts - | _ -> failwith "Impossible (tc_layered_eff_decl with a wp effect sig" in - - Errors.with_ctx ("While checking the effect signature") (fun () -> - let r = (snd sig_ts).pos in - let sig_us, sig_t, sig_ty = check_and_gen "signature" 1 sig_ts in - - let us, t = SS.open_univ_vars sig_us sig_t in - let env = Env.push_univ_vars env0 us in - - let a, u = fresh_a_and_u_a "a" in - let rest_bs = - TcUtil.layered_effect_indices_as_binders env r ed.mname (sig_us, sig_t) u (a.binder_bv |> S.bv_to_name) in - let bs = a::rest_bs in - let k = U.arrow bs (S.mk_Total S.teff) in //U.arrow does closing over bs - let g_eq = Rel.teq env t k in - Rel.force_trivial_guard env g_eq; - n, (sig_us, SS.close_univ_vars us (k |> N.remove_uvar_solutions env), sig_ty)) in - - log_combinator "signature" signature; - - (* - * Effect repr - * - * The repr must have the type: - * a:Type -> -> Type //polymorphic in one universe (that of a) - *) - let repr = - Errors.with_ctx ("While checking the effect repr") (fun () -> - let repr_ts = ed |> U.get_eff_repr |> must in - let r = (snd repr_ts).pos in - let repr_us, repr_t, repr_ty = check_and_gen "repr" 1 repr_ts in - - let us, ty = SS.open_univ_vars repr_us repr_ty in - let env = Env.push_univ_vars env0 us in - - let a, u = fresh_a_and_u_a "a" in - let rest_bs = - let signature_ts = let us, t, _ = signature in (us, t) in - TcUtil.layered_effect_indices_as_binders env r ed.mname signature_ts u (a.binder_bv |> S.bv_to_name) in - let bs = a::rest_bs in - let k = U.arrow bs (U.type_u () |> (fun (t, u) -> S.mk_Total t)) in //note the universe of Tot need not be u - let g = Rel.teq env ty k in - Rel.force_trivial_guard env g; - (repr_us, repr_t, SS.close_univ_vars us (k |> N.remove_uvar_solutions env))) - in - - log_combinator "repr" repr; - - //helper function that creates an application node (repr a_tm ?u1 ... ?un) - //returns the application term and the guard for the introduced uvars (see TcUtil.fresh_layered_effect_repr) - let fresh_repr r env u a_tm = - let signature_ts = let us, t, _ = signature in (us, t) in - let repr_ts = let us, t, _ = repr in (us, t) in - TcUtil.fresh_effect_repr env r ed.mname signature_ts (Some repr_ts) u a_tm in - - let not_an_arrow_error comb n t r = - raise_error r Errors.Fatal_UnexpectedEffect - (BU.format5 "Type of %s:%s is not an arrow with >= %s binders (%s::%s)" (string_of_lid ed.mname) comb - (show n) (tag_of t) (show t)) - in - - (* - * return_repr - * - * return_repr must have type: - * a:Type -> x:a -> -> repr a i_1 ... i_n //polymorphic in one universe (that of a) - * where i_1 ... i_n are terms of effect indices types (as in the signature) - * - * The binders have arbitrary sorts - * - * The positioning of the binders is a little asymmetric with other binders, - * e.g. in others, the binders are stuffed in the middle - * but this seems ok for return where the remaining binder is always a value (x:a) - * and not a repr - *) - let return_repr = - Errors.with_ctx ("While checking the return combinator") (fun () -> - let return_repr_ts = ed |> U.get_return_repr |> must in - let r = (snd return_repr_ts).pos in - let ret_us, ret_t, ret_ty = check_and_gen "return_repr" 1 return_repr_ts in - - let us, ty = SS.open_univ_vars ret_us ret_ty in - let env = Env.push_univ_vars env0 us in - - let a, u_a = fresh_a_and_u_a "a" in - let x_a = fresh_x_a "x" a in - let rest_bs = - match (SS.compress ty).n with - | Tm_arrow {bs} when List.length bs >= 2 -> - let (({binder_bv=a'})::({binder_bv=x'})::bs) = SS.open_binders bs in - bs |> SS.subst_binders [NT (a', bv_to_name a.binder_bv)] - |> SS.subst_binders [NT (x', bv_to_name x_a.binder_bv)] - | _ -> not_an_arrow_error "return" 2 ty r in - let bs = a::x_a::rest_bs in - let repr, g = fresh_repr r (Env.push_binders env bs) u_a (a.binder_bv |> S.bv_to_name) in - let k = U.arrow bs (S.mk_Total repr) in - let g_eq = Rel.teq env ty k in - Rel.force_trivial_guard env (Env.conj_guard g g_eq); - - let k = k |> N.remove_uvar_solutions env in - - ret_us, ret_t, k |> SS.close_univ_vars us) in - - log_combinator "return_repr" return_repr; - - (* - * bind_repr - * - * bind_repr must have type: - * a:Type -> b:Type -> -> f:repr a i_1 ... i_n -> (g:a -> repr a j_1 ... j_n) - * : repr a k_1 ... k_n //polymorphic in two universes (that of a and b) - * where i, j, k are terms of effect indices types (as in the signature) - * - * The binders have arbitrary sorts - *) - let bind_repr, bind_kind = - Errors.with_ctx ("While checking the bind combinator") (fun () -> - let bind_repr_ts = ed |> U.get_bind_repr |> must in - let r = (snd bind_repr_ts).pos in - let bind_us, bind_t, bind_ty = check_and_gen "bind_repr" 2 bind_repr_ts in - - let us, ty = SS.open_univ_vars bind_us bind_ty in - let env = Env.push_univ_vars env0 us in - - let k, kind = - let sig_ts = let us, t, _ = signature in (us, t) in - let repr_ts = let us, t, _ = repr in (us, t) in - validate_indexed_effect_bind_shape env - ed.mname ed.mname ed.mname - sig_ts sig_ts sig_ts - (Some repr_ts) (Some repr_ts) (Some repr_ts) - us - ty - r - num_effect_params - (U.has_attribute ed.eff_attrs PC.bind_has_range_args_attr) in - - (bind_us, bind_t, k |> SS.close_univ_vars bind_us), kind) in - - log_combinator "bind_repr" bind_repr; - - (* - * stronger_repr - * - * stronger_repr must have type: - * a:Type -> -> f:repr a i_1 ... i_n -> PURE (repr a j_1 ... j_n) wp //polymorphic in one universe (that of a) - * where i, j are terms of effect indices types (as in the signature) - * - * The binders have arbitrary sorts - * - * The combinator is optional, indicated by a Tm_unknown - * If so, we add a default combinator as: fun (a:Type) (signature_bs) (f:repr a signature_bs) -> f - * - *) - let stronger_repr, subcomp_kind = - Errors.with_ctx ("While checking the subcomp combinator") (fun () -> - let stronger_repr = - let ts = ed |> U.get_stronger_repr |> must in - match (ts |> snd |> SS.compress).n with - | Tm_unknown -> - let signature_ts = let (us, t, _) = signature in (us, t) in - let _, signature_t = Env.inst_tscheme_with signature_ts [U_unknown] in - (match (SS.compress signature_t).n with - | Tm_arrow {bs} -> - let bs = SS.open_binders bs in - let repr_t = - let repr_ts = let (us, t, _) = repr in (us, t) in - Env.inst_tscheme_with repr_ts [U_unknown] |> snd in - let repr_t_applied = mk - (Tm_app {hd=repr_t; - args=bs |> List.map (fun b -> b.binder_bv) |> List.map S.bv_to_name |> List.map S.as_arg}) - (Ident.range_of_lid ed.mname) in - let f_b = S.null_binder repr_t_applied in - [], {U.abs (bs@[f_b]) (f_b.binder_bv |> S.bv_to_name) None - with pos=Ident.range_of_lid ed.mname} - | _ -> failwith "Impossible!") - | _ -> ts in - - let r = (snd stronger_repr).pos in - - let stronger_us, stronger_t, stronger_ty = check_and_gen "stronger_repr" 1 stronger_repr in - - if !dbg_LayeredEffectsTc then - BU.print2 "stronger combinator typechecked with term: %s and type: %s\n" - (Print.tscheme_to_string (stronger_us, stronger_t)) - (Print.tscheme_to_string (stronger_us, stronger_ty)); - - let us, ty = SS.open_univ_vars stronger_us stronger_ty in - let env = Env.push_univ_vars env0 us in - - let k, kind = - let sig_ts = let us, t, _ = signature in (us, t) in - let repr_ts = let us, t, _ = repr in (us, t) in - validate_indexed_effect_subcomp_shape env - ed.mname ed.mname - sig_ts sig_ts - (Some repr_ts) (Some repr_ts) - (List.hd us) - ty - num_effect_params - r in - - (stronger_us, stronger_t, k |> SS.close_univ_vars stronger_us), kind) in - - log_combinator "stronger_repr" stronger_repr; - - (* - * This combinator is also optional - * If so, we add a default: - * fun (a:Type) (signature_bs) (f:repr a signature_bs) (g:repr a signature_bs) (b:bool) -> repr a signature_bs - *) - let if_then_else, ite_kind = - Errors.with_ctx ("While checking the if_then_else combinator") (fun () -> - let if_then_else_ts = - let ts = ed |> U.get_layered_if_then_else_combinator |> must |> fst in - match (ts |> snd |> SS.compress).n with - | Tm_unknown -> - let signature_ts = let (us, t, _) = signature in (us, t) in - let _, signature_t = Env.inst_tscheme_with signature_ts [U_unknown] in - (match (SS.compress signature_t).n with - | Tm_arrow {bs} -> - let bs = SS.open_binders bs in - let repr_t = - let repr_ts = let (us, t, _) = repr in (us, t) in - Env.inst_tscheme_with repr_ts [U_unknown] |> snd in - let repr_t_applied = mk - (Tm_app {hd=repr_t; - args=bs |> List.map (fun b -> b.binder_bv) |> List.map S.bv_to_name |> List.map S.as_arg}) - (Ident.range_of_lid ed.mname) in - let f_b = S.null_binder repr_t_applied in - let g_b = S.null_binder repr_t_applied in - let b_b = S.null_binder U.t_bool in - [], {U.abs (bs@[f_b; g_b; b_b]) repr_t_applied None - with pos=Ident.range_of_lid ed.mname} - | _ -> failwith "Impossible!") - | _ -> ts in - - let r = (snd if_then_else_ts).pos in - let if_then_else_us, if_then_else_t, if_then_else_ty = check_and_gen "if_then_else" 1 if_then_else_ts in - - let us, t = SS.open_univ_vars if_then_else_us if_then_else_t in - let _, ty = SS.open_univ_vars if_then_else_us if_then_else_ty in - let env = Env.push_univ_vars env0 us in - - let k, kind = - let sig_ts = let us, t, _ = signature in (us, t) in - let repr_ts = let us, t, _ = repr in (us, t) in - validate_indexed_effect_ite_shape env - ed.mname - sig_ts - repr_ts - (List.hd us) - ty - t - num_effect_params - r in - - (if_then_else_us, - k |> SS.close_univ_vars if_then_else_us, - if_then_else_ty), kind) in - - log_combinator "if_then_else" if_then_else; - - - (* - * Checking the soundness of the if_then_else combinator - * - * In all combinators, other than if_then_else, the soundness is ensured - * by extracting the application of those combinators to their definitions - * For if_then_else, the combinator does not have an extraction equivalent - * It is only used in VC generation - * - * So we need to make sure that the combinator is sound - * - * Informally, we want to check that: - * - * p ==> (subcomp f <: if_then_else f g) and - * not p ==> (subcomp g <: if_then_else f g) - * - * Basically when p holds, the computation type of f should be coercible to if_then_else f g - * and similarly for the (not p) case - * - * The way we program it is as follows: - * - * First for ite : a:Type -> bs -> f:repr a is -> g:repr a js -> p:bool -> Type, - * we create a fully applied (ite a bs f g p) term, - * where a, bs, f, g, and p are fresh names - * - * Note that beta-reducing this term gives us a (repr a ks) term - * - * Next, when subcomp : a:Type -> bs -> f:repr a s_is -> Pure (repr a s_js) pre post, - * we create fresh uvars for bs, where a is substituted by the a:Type - * name from the ite combinator - * - * To check the then branch, we unify (repr a s_is) with the sort of f binder - * from the ite combinator, and (repr a s_js) with (repr a ks), i.e. the - * beta-normal form of the fully applied ite combinator - * - * In addition, we produce an smt guard from pre - * - * To get flow-sensitivity (i.e. p ==>), the env that we do all this in, - * has a (squash p) binder - * - * Finally, we discharge all the guards - * - * Similarly we check the else branch by unifying (repr a s_is) with g binder, - * in an environment with squash (not p) - * - * When the effect is annotated with ite_soundness_by attribute, the uvars that - * we create for subcomp are tagged with the argument of ite_soundness_by, - * and the smt guard is also put in a implicit tagged with this implicit - * - * Through the usual tactics dispatching, Rel dispatches these to the tactic - * if one is in scope - *) - let _if_then_else_is_sound = Errors.with_ctx "While checking if-then-else soundness" (fun () -> - let r = (ed |> U.get_layered_if_then_else_combinator |> must |> fst |> snd).pos in - - let ite_us, ite_t, _ = if_then_else in - - let us, ite_t = SS.open_univ_vars ite_us ite_t in - let env, ite_t_applied, a_b, f_b, g_b, p_t = - match (SS.compress ite_t).n with - | Tm_abs {bs} -> - let bs = SS.open_binders bs in - let f_b, g_b, p_b = - bs - |> List.splitAt (List.length bs - 3) - |> snd - |> (fun l -> let [f; g; p] = l in f, g, p) in - let env = Env.push_binders (Env.push_univ_vars env0 us) bs in - env, - S.mk_Tm_app ite_t - (bs |> List.map (fun b -> S.bv_to_name b.binder_bv, U.aqual_of_binder b)) - r |> N.normalize [Env.Beta] env, //beta-reduce - bs |> List.hd, f_b, g_b, (S.bv_to_name p_b.binder_bv) - | _ -> failwith "Impossible! ite_t must have been an abstraction with at least 3 binders" in - - let subcomp_a_b, subcomp_bs, subcomp_f_b, subcomp_c = - let _, _, subcomp_ty = stronger_repr in - let _, subcomp_ty = SS.open_univ_vars us subcomp_ty in - match (SS.compress subcomp_ty).n with - | Tm_arrow {bs; comp=c} -> - let bs, c = SS.open_comp bs c in - let a_b, rest_bs = List.hd bs, List.tl bs in - let rest_bs, f_b = - rest_bs |> List.splitAt (List.length rest_bs - 1) - |> (fun (l1, l2) -> l1, List.hd l2) in - a_b, rest_bs, f_b, c - | _ -> failwith "Impossible! subcomp_ty must have been an arrow with at lease 1 binder" in - - (* - * An auxiliary function that we will call for then and else branches - * - * attr_opt is (Some arg) when there is an (ite_soundness_by arg) attribute on the effect - * - * The input env has the squash p (resp. squash (not p)) binder for the then (resp. else) branch - *) - let check_branch env ite_f_or_g_sort attr_opt : unit = - let subst, uvars, g_uvars = subcomp_bs |> List.fold_left - (fun (subst, uvars, g) b -> - let sort = SS.subst subst b.binder_bv.sort in - let t, _, g_t = - let ctx_uvar_meta = BU.map_option Ctx_uvar_meta_attr attr_opt in - Env.new_implicit_var_aux - (BU.format1 "uvar for subcomp %s binder when checking ite soundness" - (show b)) - r - env - sort - Strict - ctx_uvar_meta - false - in - subst@[NT (b.binder_bv, t)], uvars@[t], conj_guard g g_t) - ([NT (subcomp_a_b.binder_bv, S.bv_to_name a_b.binder_bv)], - [], - Env.trivial_guard) - in - - let subcomp_f_sort = SS.subst subst subcomp_f_b.binder_bv.sort in - let c = SS.subst_comp subst subcomp_c |> Env.unfold_effect_abbrev env in - - let g_f_or_g = Rel.layered_effect_teq env subcomp_f_sort ite_f_or_g_sort None in - let g_c = Rel.layered_effect_teq env c.result_typ ite_t_applied None in - - let fml = Env.pure_precondition_for_trivial_post - env - (List.hd c.comp_univs) - c.result_typ - (c.effect_args |> List.hd |> fst) - r in - let g_precondition = - match attr_opt with - | None -> fml |> NonTrivial |> Env.guard_of_guard_formula - | Some attr -> - let _, _, g = Env.new_implicit_var_aux "tc_layered_effect_decl.g_precondition" r env - (U.mk_squash S.U_zero fml) - Strict - (Ctx_uvar_meta_attr attr |> Some) - false - in - g - in - - Rel.force_trivial_guard env (Env.conj_guards [g_uvars; g_f_or_g; g_c; g_precondition]) in - - let ite_soundness_tac_attr = - match U.get_attribute PC.ite_soundness_by_attr attrs with - | Some ((t, _)::_) -> Some t - | _ -> None in - - let _check_then = - let env = Env.push_bv env (S.new_bv None (U.mk_squash S.U_zero (p_t |> U.b2t))) in - ignore (check_branch env f_b.binder_bv.sort ite_soundness_tac_attr) in - - let _check_else = - let not_p = S.mk_Tm_app - (S.lid_as_fv PC.not_lid None |> S.fv_to_tm) - [p_t |> U.b2t |> S.as_arg] - r in - let env = Env.push_bv env (S.new_bv None not_p) in - ignore (check_branch env g_b.binder_bv.sort ite_soundness_tac_attr) in - - () - ) //Errors.with_ctx - in - - // - // Close combinator is optional, - // typecheck it only if it is set, else leave it as None - // - let close_ = - Errors.with_ctx ("While checking the close combinator") (fun () -> - let ts_opt = ed |> U.get_layered_close_combinator in - match ts_opt with - | None -> None - | Some close_ts -> - let r = (snd close_ts).pos in - let close_us, close_t, close_ty = check_and_gen "close" 2 close_ts in - let us, t = SS.open_univ_vars close_us close_t in - let env = Env.push_univ_vars env0 us in - let k = - let sig_ts = let us, t, _ = signature in (us, t) in - let repr_ts = let us, t, _ = repr in (us, t) in - let [u_a; u_b] = us in - validate_indexed_effect_close_shape env ed.mname sig_ts repr_ts u_a u_b t num_effect_params r - in - Some (close_us, k |> SS.close_univ_vars close_us, close_ty)) in - - // - // Checking the soundness of the close combinator - // - // Close combinator has the shape: - // fun (a:Type) (b:type) (is:a -> is_t) (f:(x:a -> repr a (is x))) -> repr a js - // - // We check: - // - // a, b, is, x:a |- subcomp (repr a (is x)) (repr a js) - // - // Operationally, we create names for a, b, is, and x - // substitute them in the subcomp combinator, - // and prove its (Pure) precondition - // - let _close_is_sound = Errors.with_ctx ("While checking the soundness of the close combinator") (fun () -> - match close_ with - | None -> () - | Some close_ -> - let us, close_tm, _ = close_ in - let r = close_tm.pos in - let _ = - let supported_subcomp = - match subcomp_kind with - | Substitutive_combinator l -> - not (List.contains Ad_hoc_binder l) - | _ -> false in - - if not supported_subcomp - then raise_error r Errors.Fatal_UnexpectedEffect "close combinator is only allowed for effects with substitutive subcomp" - in - let us, close_tm = SS.open_univ_vars us close_tm in - let close_bs, close_body, _ = U.abs_formals close_tm in - let a_b::b_b::close_bs = close_bs in - let is_bs, _ = List.splitAt (List.length close_bs - 1) close_bs in - let x_bv = S.gen_bv "x" None (S.bv_to_name b_b.binder_bv) in - let args1 = List.map (fun i_b -> - S.mk_Tm_app (S.bv_to_name i_b.binder_bv) [S.as_arg (S.bv_to_name x_bv)] r - ) is_bs in - let args2 = - match (SS.compress close_body).n with - | Tm_app {args=a::args} -> args |> List.map fst - | _ -> raise_error r Errors.Fatal_UnexpectedEffect "close combinator body not a repr" in - - let env = Env.push_binders env0 ((a_b::b_b::is_bs)@[x_bv |> S.mk_binder]) in - let subcomp_ts = - let (us, _, t) = stronger_repr in - (us, t) in - let _, subcomp_t = Env.inst_tscheme_with subcomp_ts [List.hd us |> S.U_name] in - let a_b_subcomp::subcomp_bs, subcomp_c = U.arrow_formals_comp subcomp_t in - let subcomp_substs = [ NT (a_b_subcomp.binder_bv, a_b.binder_bv |> S.bv_to_name) ] in - let subcomp_f_bs, subcomp_bs = List.splitAt (List.length args1) subcomp_bs in - let subcomp_substs = subcomp_substs @ (List.map2 (fun b arg1 -> - NT (b.binder_bv, arg1) - ) subcomp_f_bs args1) in - let subcomp_g_bs, _ = List.splitAt (List.length args2) subcomp_bs in - let subcomp_substs = subcomp_substs @ (List.map2 (fun b arg2 -> - NT (b.binder_bv, arg2) - ) subcomp_g_bs args2) in - let subcomp_c = SS.subst_comp subcomp_substs subcomp_c |> Env.unfold_effect_abbrev env in - let fml = Env.pure_precondition_for_trivial_post - env - (List.hd subcomp_c.comp_univs) - subcomp_c.result_typ - (subcomp_c.effect_args |> List.hd |> fst) - r in - Rel.force_trivial_guard env (fml |> NonTrivial |> Env.guard_of_guard_formula)) - in - - (* - * Actions - * - * Actions must have type: - * -> repr a i_1 ... i_n - * so that we can inject them into the effect - * - * Other than this, no polymorphism etc. restrictions - * - * TODO: this code has a lot in common with actions for non-layered effects, we should reuse - *) - let tc_action env (act:action) : action = - let env0 = env in - let r = act.action_defn.pos in - if List.length act.action_params <> 0 - then raise_error r Errors.Fatal_MalformedActionDeclaration - (BU.format3 "Action %s:%s has non-empty action params (%s)" - (string_of_lid ed.mname) (string_of_lid act.action_name) (show act.action_params)); - - let env, act = - let usubst, us = SS.univ_var_opening act.action_univs in - Env.push_univ_vars env us, - { act with - action_univs = us; - action_defn = SS.subst usubst act.action_defn; - action_typ = SS.subst usubst act.action_typ } in - - let act_typ = - match (SS.compress act.action_typ).n with - | Tm_arrow {bs; comp=c} -> - let ct = Env.comp_to_comp_typ env c in - if lid_equals ct.effect_name ed.mname - then - let repr_ts = let us, t, _ = repr in (us, t) in - let repr = Env.inst_tscheme_with repr_ts ct.comp_univs |> snd in - let repr = S.mk_Tm_app - repr - (S.as_arg ct.result_typ::ct.effect_args) - r in - let c = S.mk_Total repr in - U.arrow bs c - else act.action_typ - | _ -> act.action_typ in - - let act_typ, _, g_t = tc_tot_or_gtot_term env act_typ in - let act_defn, _, g_d = tc_tot_or_gtot_term - ({ Env.set_expected_typ env act_typ with instantiate_imp = false }) - act.action_defn in - - if Debug.medium () || !dbg_LayeredEffectsTc then - BU.print2 "Typechecked action definition: %s and action type: %s\n" - (show act_defn) (show act_typ); - - let k, g_k = - let act_typ = N.normalize [Beta] env act_typ in - match (SS.compress act_typ).n with - | Tm_arrow {bs} -> - let bs = SS.open_binders bs in - let env = Env.push_binders env bs in - let t, u = U.type_u () in - let reason = BU.format2 "implicit for return type of action %s:%s" - (string_of_lid ed.mname) (string_of_lid act.action_name) in - let a_tm, _, g_tm = TcUtil.new_implicit_var reason r env t false in - let repr, g = fresh_repr r env u a_tm in - U.arrow bs (S.mk_Total repr), Env.conj_guard g g_tm - | _ -> raise_error r Errors.Fatal_ActionMustHaveFunctionType - (BU.format3 "Unexpected non-function type for action %s:%s (%s)" - (show ed.mname) (show act.action_name) (show act_typ)) in - - if Debug.medium () || !dbg_LayeredEffectsTc then - BU.print1 "Expected action type: %s\n" (show k); - - let g = Rel.teq env act_typ k in - List.iter (Rel.force_trivial_guard env) [g_t; g_d; g_k; g]; - - if Debug.medium () || !dbg_LayeredEffectsTc then - BU.print1 "Expected action type after unification: %s\n" (show k); - - let act_typ = - let err_msg t = BU.format3 - "Unexpected (k-)type of action %s:%s, expected bs -> repr i_1 ... i_n, found: %s" - (string_of_lid ed.mname) (string_of_lid act.action_name) (show t) in - let repr_args t : universes & term & args = - match (SS.compress t).n with - | Tm_app {hd=head;args=a::is} -> - (match (SS.compress head).n with - | Tm_uinst (_, us) -> us, fst a, is - | _ -> raise_error r Errors.Fatal_ActionMustHaveFunctionType (err_msg t)) - | _ -> raise_error r Errors.Fatal_ActionMustHaveFunctionType (err_msg t) in - - let k = N.normalize [Beta] env k in - match (SS.compress k).n with - | Tm_arrow {bs; comp=c} -> - let bs, c = SS.open_comp bs c in - let us, a, is = repr_args (U.comp_result c) in - let ct = { - comp_univs = us; - effect_name = ed.mname; - result_typ = a; - effect_args = is; - flags = [] } in - U.arrow bs (S.mk_Comp ct) - | _ -> raise_error r Errors.Fatal_ActionMustHaveFunctionType (err_msg k) in - - if Debug.medium () || !dbg_LayeredEffectsTc then - BU.print1 "Action type after injecting it into the monad: %s\n" (show act_typ); - - let act = - let us, act_defn = Gen.generalize_universes env act_defn in - if act.action_univs = [] - then - { act with - action_univs = us; - action_defn = act_defn; - action_typ = SS.close_univ_vars us act_typ } - else - if List.length us = List.length act.action_univs && - List.forall2 (fun u1 u2 -> S.order_univ_name u1 u2 = 0) us act.action_univs - then { act with - action_defn = act_defn; - action_typ = SS.close_univ_vars act.action_univs act_typ } - else raise_error r Errors.Fatal_UnexpectedNumberOfUniverse - (BU.format4 "Expected and generalized universes in the declaration for %s:%s are different, input: %s, but after gen: %s" - (string_of_lid ed.mname) (string_of_lid act.action_name) (show us) (show act.action_univs)) - in - - act in - - let tc_action_with_ctx env (act:action) = - Errors.with_ctx (BU.format1 "While checking the action %s" (string_of_lid act.action_name)) - (fun () -> tc_action env act) in - - // set extraction mode - let extraction_mode = - let has_primitive_extraction = - U.has_attribute ed.eff_attrs PC.primitive_extraction_attr in - let is_reifiable = List.contains Reifiable quals in - - if has_primitive_extraction && is_reifiable - then raise_error ed.mname Errors.Fatal_UnexpectedEffect - (BU.format1 "Effect %s is declared to be both primitive extraction and reifiable" - (show ed.mname)) - else begin - if has_primitive_extraction - then S.Extract_primitive - else - let us, a_b, rest_bs = - let us, t = let us, t, _ = signature in us, t in - match (SS.compress t).n with - | Tm_arrow {bs} -> - let a_b::rest_bs = SS.open_binders bs in - us, a_b, rest_bs - | _ -> failwith "Impossible!" // there are multiple places above where we have relied on sig being an arrow - in - let env = Env.push_univ_vars env0 us in - let env = Env.push_binders env [a_b] in - let _, r = List.fold_left (fun (env, r) b -> - let r = r && N.non_info_norm env b.binder_bv.sort in - Env.push_binders env [b], r) (env, true) rest_bs in - if r && - Substitutive_combinator? bind_kind && - (is_reifiable || lid_equals ed.mname PC.effect_TAC_lid) - then S.Extract_reify - else let m = - if not r - then "one or more effect indices are informative" - else if not (Substitutive_combinator? bind_kind) - then "bind is not substitutive" - else "the effect is not reifiable" in - S.Extract_none m - end - in - - if !dbg_LayeredEffectsTc - then BU.print2 "Effect %s has extraction mode %s\n" (show ed.mname) (show extraction_mode); - - let tschemes_of (us, t, ty) k = (us, t), (us, ty), k in - let tschemes_of2 (us, t, ty) = (us, t), (us, ty) in - - let combinators = Layered_eff ({ - l_repr = tschemes_of2 repr; - l_return = tschemes_of2 return_repr; - l_bind = tschemes_of bind_repr (Some bind_kind); - l_subcomp = tschemes_of stronger_repr (Some subcomp_kind); - l_if_then_else = tschemes_of if_then_else (Some ite_kind); - l_close = (match close_ with - | None -> None - | Some (us, t, ty) -> Some ((us, t), (us, ty))); - }) in - - { ed with - signature = Layered_eff_sig (num_effect_params, (let us, t, _ = signature in (us, t))); - combinators = combinators; - actions = List.map (tc_action_with_ctx env0) ed.actions; - extraction_mode } - ) - -let tc_non_layered_eff_decl env0 (ed:S.eff_decl) (_quals : list qualifier) (_attrs : list S.attribute) : S.eff_decl = -Errors.with_ctx (BU.format1 "While checking effect definition `%s`" (string_of_lid ed.mname)) (fun () -> - if !dbg then - BU.print1 "Typechecking eff_decl: \n\t%s\n" (show ed); - - let us, bs = - //ed.univs are free universes in the binders - //first open them - let ed_univs_subst, ed_univs = SS.univ_var_opening ed.univs in - - //ed.binders are effect parameters (e.g. heap in STATE_h), typecheck them after opening them - let bs = SS.open_binders (SS.subst_binders ed_univs_subst ed.binders) in - let bs, _, _ = tc_tparams (Env.push_univ_vars env0 ed_univs) bs in //tc_tparams forces the guard from checking the binders - - //generalize the universes in bs - //bs are closed with us and closed - let us, bs = - let tmp_t = U.arrow bs (S.mk_Total S.t_unit) in //create a temporary bs -> Tot unit - let us, tmp_t = Gen.generalize_universes env0 tmp_t in - us, tmp_t |> U.arrow_formals |> fst |> SS.close_binders in - - match ed_univs with - | [] -> us, bs //if no annotated universes, return us, bs - | _ -> - let open FStar.Pprint in - let open FStar.Class.PP in - let open FStar.Errors.Msg in - //if ed.univs is already set, it must be the case that us = ed.univs, else error out - if (List.length ed_univs = List.length us && - List.forall2 (fun u1 u2 -> S.order_univ_name u1 u2 = 0) ed_univs us) - then us, bs - else raise_error ed.mname Errors.Fatal_UnexpectedNumberOfUniverse [ - text "Expected and generalized universes in effect declaration for" - ^/^ doc_of_string (string_of_lid ed.mname) ^/^ text "are different"; - text "Expected" ^/^ pp #int (List.length ed_univs) ^/^ - text "but found" ^/^ pp #int (List.length us) - ] - in - - //at this points, bs are closed and closed with us also - //they are in scope for rest of the ed - - let ed = { ed with univs = us; binders = bs } in - - //now open rest of the ed with us and bs - let ed_univs_subst, ed_univs = SS.univ_var_opening us in - let ed_bs, ed_bs_subst = SS.open_binders' (SS.subst_binders ed_univs_subst bs) in - - - let ed = - let op (us, t) = - let t = SS.subst (SS.shift_subst (List.length ed_bs + List.length us) ed_univs_subst) t in - us, SS.subst (SS.shift_subst (List.length us) ed_bs_subst) t in - - { ed with - signature = U.apply_eff_sig op ed.signature; - combinators = U.apply_eff_combinators op ed.combinators; - actions = List.map (fun a -> - { a with action_defn = snd (op (a.action_univs, a.action_defn)); - action_typ = snd (op (a.action_univs, a.action_typ)) }) ed.actions; - } in - - if !dbg then - BU.print1 "After typechecking binders eff_decl: \n\t%s\n" (show ed); - - let env = Env.push_binders (Env.push_univ_vars env0 ed_univs) ed_bs in - - (* - * AR: check that (us, t) has type k, and generalize (us, t) - * comb is the name of the combinator (useful for error messages) - * n is the expected number of free universes (after generalization) - * env_opt is an optional env (e.g. bind_repr is typechecked lax) - *) - let check_and_gen' (comb:string) (n:int) env_opt (us, t) k : tscheme = - let env = if is_some env_opt then env_opt |> must else env in - let us, t = SS.open_univ_vars us t in - let t = - match k with - | Some k -> tc_check_trivial_guard (Env.push_univ_vars env us) t k - | None -> - let t, _, g = tc_tot_or_gtot_term (Env.push_univ_vars env us) t in - Rel.force_trivial_guard env g; - t in - let g_us, t = Gen.generalize_universes env t in - //check that n = List.length g_us and that if us is set, it is same as g_us - begin - if List.length g_us <> n then - let error = BU.format4 - "Expected %s:%s to be universe-polymorphic in %s universes, found %s" - (string_of_lid ed.mname) comb (string_of_int n) (g_us |> List.length |> string_of_int) in - raise_error t Errors.Fatal_MismatchUniversePolymorphic error - end; - match us with - | [] -> g_us, t - | _ -> - if List.length us = List.length g_us && - List.forall2 (fun u1 u2 -> S.order_univ_name u1 u2 = 0) us g_us - then g_us, t - else raise_error t Errors.Fatal_UnexpectedNumberOfUniverse - (BU.format4 "Expected and generalized universes in the declaration for %s:%s are different, expected: %s, but found %s" - (string_of_lid ed.mname) comb (BU.string_of_int (List.length us)) (BU.string_of_int (List.length g_us))) - in - - let signature = check_and_gen' "signature" 1 None (U.effect_sig_ts ed.signature) None in - - if !dbg then - BU.print1 "Typechecked signature: %s\n" (Print.tscheme_to_string signature); - - (* - * AR: return a fresh (in the sense of fresh universe) instance of a:Type and wp sort (closed with the returned a) - *) - let fresh_a_and_wp () = - let fail t = Err.unexpected_signature_for_monad env (ed.signature |> U.effect_sig_ts |> snd).pos ed.mname t in - //instantiate with fresh universes - let _, signature = Env.inst_tscheme signature in - match (SS.compress signature).n with - | Tm_arrow {bs} -> - let bs = SS.open_binders bs in - (match bs with - | [({binder_bv=a}); ({binder_bv=wp})] -> a, wp.sort - | _ -> fail signature) - | _ -> fail signature - in - - let log_combinator s ts = - if !dbg then - BU.print3 "Typechecked %s:%s = %s\n" (string_of_lid ed.mname) s (Print.tscheme_to_string ts) in - - let ret_wp = - let a, wp_sort = fresh_a_and_wp () in - let k = U.arrow [ S.mk_binder a; S.null_binder (S.bv_to_name a)] (S.mk_GTotal wp_sort) in - check_and_gen' "ret_wp" 1 None (ed |> U.get_return_vc_combinator) (Some k) in - - log_combinator "ret_wp" ret_wp; - - let bind_wp = - let a, wp_sort_a = fresh_a_and_wp () in - let b, wp_sort_b = fresh_a_and_wp () in - let wp_sort_a_b = U.arrow [S.null_binder (S.bv_to_name a)] (S.mk_Total wp_sort_b) in - - let k = U.arrow [ - S.mk_binder a; - S.mk_binder b; - S.null_binder wp_sort_a; - S.null_binder wp_sort_a_b ] (S.mk_Total wp_sort_b) in - - check_and_gen' "bind_wp" 2 None (ed |> U.get_bind_vc_combinator |> fst) (Some k) in - - log_combinator "bind_wp" bind_wp; - - let stronger = - let a, wp_sort_a = fresh_a_and_wp () in - let t, _ = U.type_u() in - let k = U.arrow [ - S.mk_binder a; - S.null_binder wp_sort_a; - S.null_binder wp_sort_a ] (S.mk_Total t) in - check_and_gen' "stronger" 1 None (ed |> U.get_stronger_vc_combinator |> fst) (Some k) in - - log_combinator "stronger" stronger; - - let if_then_else = - let a, wp_sort_a = fresh_a_and_wp () in - let p = S.new_bv (Some (range_of_lid ed.mname)) (U.type_u() |> fst) in - let k = U.arrow [ - S.mk_binder a; - S.mk_binder p; - S.null_binder wp_sort_a; - S.null_binder wp_sort_a ] (S.mk_Total wp_sort_a) in - - check_and_gen' "if_then_else" 1 None (ed |> U.get_wp_if_then_else_combinator |> must) (Some k) in - - log_combinator "if_then_else" if_then_else; - - let ite_wp = - let a, wp_sort_a = fresh_a_and_wp () in - let k = U.arrow [S.mk_binder a; S.null_binder wp_sort_a] (S.mk_Total wp_sort_a) in - check_and_gen' "ite_wp" 1 None (ed |> U.get_wp_ite_combinator |> must) (Some k) in - - log_combinator "ite_wp" ite_wp; - - let close_wp = - let a, wp_sort_a = fresh_a_and_wp () in - let b = S.new_bv (Some (range_of_lid ed.mname)) (U.type_u() |> fst) in - let wp_sort_b_a = U.arrow [S.null_binder (S.bv_to_name b)] (S.mk_Total wp_sort_a) in - - let k = U.arrow [S.mk_binder a; S.mk_binder b; S.null_binder wp_sort_b_a] (S.mk_Total wp_sort_a) in - check_and_gen' "close_wp" 2 None (ed |> U.get_wp_close_combinator |> must) (Some k) in - - log_combinator "close_wp" close_wp; - - let trivial = - let a, wp_sort_a = fresh_a_and_wp () in - let t, _ = U.type_u () in - let k = U.arrow [S.mk_binder a; S.null_binder wp_sort_a] (S.mk_GTotal t) in - let trivial = check_and_gen' "trivial" 1 None (ed |> U.get_wp_trivial_combinator |> must) (Some k) in - - log_combinator "trivial" trivial; - - trivial in - - let repr, return_repr, bind_repr, actions = - match ed |> U.get_eff_repr with - | None -> None, None, None, ed.actions - | _ -> - let repr = - let a, wp_sort_a = fresh_a_and_wp () in - let t, _ = U.type_u () in - let k = U.arrow [S.mk_binder a; S.null_binder wp_sort_a] (S.mk_GTotal t) in - check_and_gen' "repr" 1 None (ed |> U.get_eff_repr |> must) (Some k) in - - log_combinator "repr" repr; - - let mk_repr' t wp = - let _, repr = Env.inst_tscheme repr in - let repr = N.normalize [EraseUniverses; AllowUnboundUniverses] env repr in - mk (Tm_app {hd=repr;args=[t |> as_arg; wp |> as_arg]}) Range.dummyRange in - let mk_repr a wp = mk_repr' (S.bv_to_name a) wp in - let destruct_repr t = - match (SS.compress t).n with - | Tm_app {args=[(t, _); (wp, _)]} -> t, wp - | _ -> failwith "Unexpected repr type" in - - let return_repr = - let return_repr_ts = ed |> U.get_return_repr |> must in - let a, _ = fresh_a_and_wp () in - let x_a = S.gen_bv "x_a" None (S.bv_to_name a) in - let res = - let wp = mk_Tm_app - (Env.inst_tscheme ret_wp |> snd) - [S.bv_to_name a |> S.as_arg; S.bv_to_name x_a |> S.as_arg] Range.dummyRange in - mk_repr a wp in - let k = U.arrow [S.mk_binder a; S.mk_binder x_a] (S.mk_Total res) in - let k, _, _ = tc_tot_or_gtot_term env k in - let env = Some (Env.set_range env (snd return_repr_ts).pos) in - check_and_gen' "return_repr" 1 env return_repr_ts (Some k) in - - log_combinator "return_repr" return_repr; - - let bind_repr = - let bind_repr_ts = ed |> U.get_bind_repr |> must in - let a, wp_sort_a = fresh_a_and_wp () in - let b, wp_sort_b = fresh_a_and_wp () in - let wp_sort_a_b = U.arrow [S.null_binder (S.bv_to_name a)] (S.mk_Total wp_sort_b) in - let wp_f = S.gen_bv "wp_f" None wp_sort_a in - let wp_g = S.gen_bv "wp_g" None wp_sort_a_b in - let x_a = S.gen_bv "x_a" None (S.bv_to_name a) in - let wp_g_x = mk_Tm_app (S.bv_to_name wp_g) [S.bv_to_name x_a |> S.as_arg] Range.dummyRange in - let res = - let wp = mk_Tm_app - (Env.inst_tscheme bind_wp |> snd) - (List.map as_arg [S.bv_to_name a; S.bv_to_name b; S.bv_to_name wp_f; S.bv_to_name wp_g]) - Range.dummyRange in - mk_repr b wp in - - let maybe_range_arg = - if BU.for_some (TEQ.eq_tm_bool env U.dm4f_bind_range_attr) ed.eff_attrs - then [S.null_binder S.t_range; S.null_binder S.t_range] - else [] in - - let k = U.arrow ([S.mk_binder a; S.mk_binder b] @ - maybe_range_arg @ - [S.mk_binder wp_f; - S.null_binder (mk_repr a (S.bv_to_name wp_f)); - S.mk_binder wp_g; - S.null_binder (U.arrow [S.mk_binder x_a] (S.mk_Total <| mk_repr b (wp_g_x)))]) - (S.mk_Total res) in - let k, _, _ = tc_tot_or_gtot_term env k in - let env = Env.set_range env (snd bind_repr_ts).pos in - let env = {env with admit = true} |> Some in //we do not expect the bind to verify, since that requires internalizing monotonicity of WPs - check_and_gen' "bind_repr" 2 env bind_repr_ts (Some k) in - - log_combinator "bind_repr" bind_repr; - - let actions = - let check_action (act:action) = - (* We should not have action params anymore, they should have been handled by dmff below *) - if List.length act.action_params <> 0 then failwith "tc_eff_decl: expected action_params to be empty"; - - // 0) The action definition has a (possibly) useless type; the - // action cps'd type contains the "good" wp that tells us EVERYTHING - // about what this action does. Please note that this "good" wp is - // of the form [binders -> repr ...], i.e. is it properly curried. - - //in case action has universes, open the action type etc. first - let env, act = - if act.action_univs = [] then env, act - else - let usubst, uvs = SS.univ_var_opening act.action_univs in - Env.push_univ_vars env uvs, - { act with - action_univs = uvs; - action_defn = SS.subst usubst act.action_defn; - action_typ = SS.subst usubst act.action_typ } in - - //AR: if the act typ is already in the effect monad (e.g. in the second phase), - // then, convert it to repr, so that the code after it can work as it is - // perhaps should open/close binders properly - let act_typ = - match (SS.compress act.action_typ).n with - | Tm_arrow {bs; comp=c} -> - let c = Env.comp_to_comp_typ env c in - if lid_equals c.effect_name ed.mname - then U.arrow bs (S.mk_Total (mk_repr' c.result_typ (fst (List.hd c.effect_args)))) - else act.action_typ - | _ -> act.action_typ - in - - let act_typ, _, g_t = tc_tot_or_gtot_term env act_typ in - - // 1) Check action definition, setting its expected type to - // [action_typ] - let env' = { Env.set_expected_typ env act_typ with instantiate_imp = false } in - if !dbg then - BU.print3 "Checking action %s:\n[definition]: %s\n[cps'd type]: %s\n" - (string_of_lid act.action_name) (show act.action_defn) - (show act_typ); - let act_defn, _, g_a = tc_tot_or_gtot_term env' act.action_defn in - - Rel.force_trivial_guard env (Env.conj_guards [g_a; g_t]); - - let act_defn = N.normalize [ Env.UnfoldUntil S.delta_constant ] env act_defn in - let act_typ = N.normalize [ Env.UnfoldUntil S.delta_constant; Env.Eager_unfolding; Env.Beta ] env act_typ in - // 2) This implies that [action_typ] has Type(k): good for us! - - // 3) Unify [action_typ] against [expected_k], because we also need - // to check that the action typ is of the form [binders -> repr ...] - let expected_k, g_k = - let act_typ = SS.compress act_typ in - match act_typ.n with - | Tm_arrow {bs; comp=c} -> - let bs, _ = SS.open_comp bs c in - let res = mk_repr' S.tun S.tun in - let k = U.arrow bs (S.mk_Total res) in - let k, _, g = tc_tot_or_gtot_term env k in - k, g - | _ -> raise_error act_defn Errors.Fatal_ActionMustHaveFunctionType - (BU.format2 "Actions must have function types (not: %s, a.k.a. %s)" (show act_typ) (tag_of act_typ)) - in - - // The following Rel query is only to check that act_typ has - // the right shape, no actual typechecking going on here - (let g = Rel.teq env act_typ expected_k in - let g = Env.conj_guard g g_k in - match g.guard_f with - | NonTrivial _ -> - raise_error act_defn Errors.Fatal_ActionMustHaveFunctionType - (BU.format1 "Unexpected non trivial guard formula when checking action type shape (%s)" - (show act_typ)) - | Trivial -> - Rel.force_trivial_guard {env with admit=true} (Env.conj_guards [g_k; g])); - - // 4) Do a bunch of plumbing to assign a type in the new monad to - // the action - let act_typ = match (SS.compress expected_k).n with - | Tm_arrow {bs; comp=c} -> - let bs, c = SS.open_comp bs c in - let a, wp = destruct_repr (U.comp_result c) in - let c = { - comp_univs=[env.universe_of (Env.push_binders env bs) a]; - effect_name = ed.mname; - result_typ = a; - effect_args = [as_arg wp]; - flags = [] - } in - U.arrow bs (S.mk_Comp c) - | _ -> failwith "Impossible (expected_k is an arrow)" in - - (* printfn "Checked action %s against type %s\n" *) - (* (show act_defn) *) - (* (show (N.normalize [Env.Beta] env act_typ)); *) - - //AR: if the action universes were already annotated, simply close, else generalize - let univs, act_defn = - if act.action_univs = [] - then Gen.generalize_universes env act_defn - else act.action_univs, SS.close_univ_vars act.action_univs act_defn - in - let act_typ = N.normalize [Env.Beta] env act_typ in - let act_typ = Subst.close_univ_vars univs act_typ in - {act with - action_univs=univs; - action_defn=act_defn; - action_typ =act_typ } - in - ed.actions |> List.map check_action in - - Some repr, Some return_repr, Some bind_repr, actions - in - - //close the ed_univs and ed_bs - let cl ts = - let ts = SS.close_tscheme ed_bs ts in - let ed_univs_closing = SS.univ_var_closing ed_univs in - SS.subst_tscheme (SS.shift_subst (List.length ed_bs) ed_univs_closing) ts in - - let combinators = { - ret_wp = ret_wp; - bind_wp = bind_wp; - stronger = stronger; - if_then_else = if_then_else; - ite_wp = ite_wp; - close_wp = close_wp; - trivial = trivial; - - repr = repr; - return_repr = return_repr; - bind_repr = bind_repr; - } in - - let combinators = U.apply_wp_eff_combinators cl combinators in - let combinators = - match ed.combinators with - | Primitive_eff _ -> Primitive_eff combinators - | DM4F_eff _ -> DM4F_eff combinators - | _ -> failwith "Impossible! tc_eff_decl on a layered effect is not expected" in - - //univs and binders have already been set - let ed = { ed with - signature = WP_eff_sig (cl signature); - combinators = combinators; - actions = - List.map (fun a -> - { a with - action_typ = cl (a.action_univs, a.action_typ) |> snd; - action_defn = cl (a.action_univs, a.action_defn) |> snd }) actions } in - - if !dbg then - BU.print1 "Typechecked effect declaration:\n\t%s\n" (show ed); - - ed -) - -let tc_eff_decl env ed quals attrs = - if ed |> U.is_layered - then tc_layered_eff_decl env ed quals attrs - else tc_non_layered_eff_decl env ed quals attrs - -let monad_signature env m s = - let fail () = Err.unexpected_signature_for_monad env (range_of_lid m) m s in - let s = SS.compress s in - match s.n with - | Tm_arrow {bs; comp=c} -> - let bs = SS.open_binders bs in - begin match bs with - | [({binder_bv=a});({binder_bv=wp})] -> a, wp.sort - | _ -> fail () - end - | _ -> fail () - -(* - * Typecheck lift to/from a layered effect - * - *) -let tc_layered_lift env0 (sub:S.sub_eff) : S.sub_eff = - if !dbg_LayeredEffectsTc then - BU.print1 "Typechecking sub_effect: %s\n" (show sub); - - let lift_ts = sub.lift |> must in - let r = (lift_ts |> snd).pos in - - let us, lift, lift_ty = check_and_gen env0 "" "lift" 1 lift_ts in - - if !dbg_LayeredEffectsTc then - BU.print2 "Typechecked lift: %s and lift_ty: %s\n" - (Print.tscheme_to_string (us, lift)) (Print.tscheme_to_string ((us, lift_ty))); - - let us, lift_ty = SS.open_univ_vars us lift_ty in - let env = Env.push_univ_vars env0 us in - - let k, kind = validate_indexed_effect_lift_shape env sub.source sub.target (List.hd us) lift_ty r in - - let sub = { sub with - lift = Some (us, lift); - lift_wp = Some (us, k |> SS.close_univ_vars us); - kind = Some kind } in - - if !dbg_LayeredEffectsTc then - BU.print1 "Final sub_effect: %s\n" (show sub); - - sub - -let check_lift_for_erasable_effects env (m1:lident) (m2:lident) (r:Range.range) : unit = - let err reason = raise_error r Errors.Fatal_UnexpectedEffect - (BU.format3 "Error defining a lift/subcomp %s ~> %s: %s" - (string_of_lid m1) (string_of_lid m2) reason) in - - let m1 = Env.norm_eff_name env m1 in - if lid_equals m1 PC.effect_GHOST_lid - then err "user-defined lifts from GHOST effect are not allowed" - else - let m1_erasable = Env.is_erasable_effect env m1 in - let m2_erasable = Env.is_erasable_effect env m2 in - if m2_erasable && - not m1_erasable && - not (lid_equals m1 PC.effect_PURE_lid) - then err "cannot lift a non-erasable effect to an erasable effect unless the non-erasable effect is PURE" - -let tc_lift env sub r = - if lid_equals sub.source sub.target - then raise_error r Fatal_UnexpectedEffect - (BU.format1 - "Cannot define a lift with same source and target (%s)" - (show sub.source)); - - let check_and_gen env t k = - // BU.print1 "\x1b[01;36mcheck and gen \x1b[00m%s\n" (show t); - Gen.generalize_universes env (tc_check_trivial_guard env t k) in - - check_lift_for_erasable_effects env sub.source sub.target r; - - let ed_src = Env.get_effect_decl env sub.source in - let ed_tgt = Env.get_effect_decl env sub.target in - - if ed_src |> U.is_layered || ed_tgt |> U.is_layered - then tc_layered_lift (Env.set_range env r) sub - else - let a, wp_a_src = monad_signature env sub.source (Env.lookup_effect_lid env sub.source) in - let b, wp_b_tgt = monad_signature env sub.target (Env.lookup_effect_lid env sub.target) in - let wp_a_tgt = SS.subst [NT(b, S.bv_to_name a)] wp_b_tgt in - let expected_k = U.arrow [S.mk_binder a; S.null_binder wp_a_src] (S.mk_Total wp_a_tgt) in - let repr_type eff_name a wp = - if not (is_reifiable_effect env eff_name) - then raise_error env Errors.Fatal_EffectCannotBeReified (BU.format1 "Effect %s cannot be reified" (string_of_lid eff_name)); - match Env.effect_decl_opt env eff_name with - | None -> failwith "internal error: reifiable effect has no decl?" - | Some (ed, qualifiers) -> - let repr = Env.inst_effect_fun_with [U_unknown] env ed (ed |> U.get_eff_repr |> must) in - mk (Tm_app {hd=repr; args=[as_arg a; as_arg wp]}) (Env.get_range env) - in - let lift, lift_wp = - match sub.lift, sub.lift_wp with - | None, None -> failwith "Impossible (parser)" - | lift, Some (uvs, lift_wp) -> - //AR: open the universes, if present (two phases) - let env, lift_wp = - if List.length uvs > 0 then - let usubst, uvs = SS.univ_var_opening uvs in - Env.push_univ_vars env uvs, SS.subst usubst lift_wp - else env, lift_wp - in - (* Covers both the "classic" format and the reifiable case. *) - //AR: if universes are already annotated, simply close, else generalize - let lift_wp = if List.length uvs = 0 then check_and_gen env lift_wp expected_k - else let lift_wp = tc_check_trivial_guard env lift_wp expected_k in uvs, SS.close_univ_vars uvs lift_wp - in - lift, lift_wp - (* Sub-effect for free case *) - | Some (what, lift), None -> - //AR: open the universes if present (two phases) - let uvs, lift = - if List.length what > 0 - then let usubst, uvs = SS.univ_var_opening what in - uvs, SS.subst usubst lift - else [], lift - in - if !dbg - then BU.print1 "Lift for free : %s\n" (show lift); - let dmff_env = DMFF.empty env (tc_constant env Range.dummyRange) in - let lift, comp, _ = tc_term (Env.push_univ_vars env uvs) lift in //AR: push univs in the env - (* TODO : Check that comp is pure ? *) - let _, lift_wp, lift_elab = DMFF.star_expr dmff_env lift in - let lift_wp = DMFF.recheck_debug "lift-wp" env lift_wp in - let lift_elab = DMFF.recheck_debug "lift-elab" env lift_elab in - if List.length uvs = 0 then Some (Gen.generalize_universes env lift_elab), Gen.generalize_universes env lift_wp - else Some (uvs, SS.close_univ_vars uvs lift_elab), (uvs, SS.close_univ_vars uvs lift_wp) - in - (* we do not expect the lift to verify, *) - (* since that requires internalizing monotonicity of WPs *) - let env = {env with admit=true} in - let lift = match lift with - | None -> None - | Some (uvs, lift) -> - let env, lift = - let usubst, uvs = SS.univ_var_opening uvs in - Env.push_univ_vars env uvs, SS.subst usubst lift - in - let a, wp_a_src = monad_signature env sub.source (Env.lookup_effect_lid env sub.source) in - let wp_a = S.new_bv None wp_a_src in - let a_typ = S.bv_to_name a in - let wp_a_typ = S.bv_to_name wp_a in - let repr_f = repr_type sub.source a_typ wp_a_typ in - let repr_result = - let lift_wp = N.normalize [Env.EraseUniverses; Env.AllowUnboundUniverses] env (snd lift_wp) in - let lift_wp_a = mk (Tm_app {hd=lift_wp;args=[as_arg a_typ; as_arg wp_a_typ]}) (Env.get_range env) in - repr_type sub.target a_typ lift_wp_a in - let expected_k = - U.arrow [S.mk_binder a; S.mk_binder wp_a; S.null_binder repr_f] - (S.mk_Total repr_result) in - let expected_k, _, _ = - tc_tot_or_gtot_term env expected_k in - let lift = - if List.length uvs = 0 then check_and_gen env lift expected_k - else - let lift = tc_check_trivial_guard env lift expected_k in - uvs, SS.close_univ_vars uvs lift in - Some lift - in - //check that sub effecting is universe polymorphic in exactly one universe - if lift_wp |> fst |> List.length <> 1 then - raise_error r Errors.Fatal_TooManyUniverse - (BU.format3 "Sub effect wp must be polymorphic in exactly 1 universe; %s ~> %s has %s universes" - (show sub.source) (show sub.target) - (lift_wp |> fst |> List.length |> string_of_int)); - if is_some lift && lift |> must |> fst |> List.length <> 1 then - raise_error r Errors.Fatal_TooManyUniverse - (BU.format3 "Sub effect lift must be polymorphic in exactly 1 universe; %s ~> %s has %s universes" - (show sub.source) (show sub.target) - (lift |> must |> fst |> List.length |> string_of_int)); - ({ sub with lift_wp=Some lift_wp; lift=lift }) - -let tc_effect_abbrev env (lid, uvs, tps, c) r = - let env0 = env in - //assert (uvs = []); AR: not necessarily, two phases - - //AR: open universes in tps and c if needed - let env, uvs, tps, c = - if List.length uvs = 0 then env, uvs, tps, c - else - let usubst, uvs = SS.univ_var_opening uvs in - let tps = SS.subst_binders usubst tps in - let c = SS.subst_comp (SS.shift_subst (List.length tps) usubst) c in - Env.push_univ_vars env uvs, uvs, tps, c - in - let env = Env.set_range env r in - let tps, c = SS.open_comp tps c in - let tps, env, us = tc_tparams env tps in - let c, u, g = tc_comp env c in - // - //Check if this effect is marked as a default effect in the effect decl. - // of its unfolded effect - //If so, we need to check that it has only a type argument - // - let is_default_effect = - match c |> U.comp_effect_name |> Env.get_default_effect env with - | None -> false - | Some l -> lid_equals l lid in - Rel.force_trivial_guard env g; - let _ = - let expected_result_typ = - match tps with - | ({binder_bv=x})::tl -> - if is_default_effect && not (tl = []) - then raise_error r Errors.Fatal_UnexpectedEffect - (BU.format2 "Effect %s is marked as a default effect for %s, but it has more than one arguments" - (string_of_lid lid) - (c |> U.comp_effect_name |> string_of_lid)); - S.bv_to_name x - | _ -> raise_error r Errors.Fatal_NotEnoughArgumentsForEffect - "Effect abbreviations must bind at least the result type" - in - let def_result_typ = FStar.Syntax.Util.comp_result c in - if not (Rel.teq_nosmt_force env expected_result_typ def_result_typ) - then raise_error r Errors.Fatal_EffectAbbreviationResultTypeMismatch - (BU.format2 "Result type of effect abbreviation `%s` \ - does not match the result type of its definition `%s`" - (show expected_result_typ) - (show def_result_typ)) - in - let tps = SS.close_binders tps in - let c = SS.close_comp tps c in - let uvs, t = Gen.generalize_universes env0 (mk (Tm_arrow {bs=tps; comp=c}) r) in - let tps, c = match tps, (SS.compress t).n with - | [], Tm_arrow {comp=c} -> [], c - | _, Tm_arrow {bs=tps; comp=c} -> tps, c - | _ -> failwith "Impossible (t is an arrow)" in - if List.length uvs <> 1 - then begin - let _, t = Subst.open_univ_vars uvs t in - raise_error r Errors.Fatal_TooManyUniverse - (BU.format3 "Effect abbreviations must be polymorphic in exactly 1 universe; %s has %s universes (%s)" - (show lid) - (show (List.length uvs)) - (show t)) - end; - (lid, uvs, tps, c) - - -let check_polymonadic_bind_for_erasable_effects env (m:lident) (n:lident) (p:lident) (r:Range.range) = - let err reason = raise_error r Errors.Fatal_UnexpectedEffect - (BU.format4 "Error definition polymonadic bind (%s, %s) |> %s: %s" - (show m) (show n) (show p) reason) in - - let m = Env.norm_eff_name env m in - let n = Env.norm_eff_name env n in - - if lid_equals m PC.effect_GHOST_lid || - lid_equals n PC.effect_GHOST_lid - then err "GHOST computations are not allowed to be composed using user-defined polymonadic binds" - else - let m_erasable = Env.is_erasable_effect env m in - let n_erasable = Env.is_erasable_effect env n in - let p_erasable = Env.is_erasable_effect env p in - - - if p_erasable - then if not m_erasable && not (lid_equals m PC.effect_PURE_lid) - then err (BU.format1 "target effect is erasable but %s is neither erasable nor PURE" (string_of_lid m)) - else if not n_erasable && not (lid_equals n PC.effect_PURE_lid) - then err (BU.format1 "target effect is erasable but %s is neither erasable nor PURE" (string_of_lid n)) - -let tc_polymonadic_bind env (m:lident) (n:lident) (p:lident) (ts:S.tscheme) - : (S.tscheme & S.tscheme & S.indexed_effect_combinator_kind) = - - let eff_name = BU.format3 "(%s, %s) |> %s)" - (m |> ident_of_lid |> string_of_id) - (n |> ident_of_lid |> string_of_id) - (p |> ident_of_lid |> string_of_id) in - let r = (snd ts).pos in - - check_polymonadic_bind_for_erasable_effects env m n p r; - - //p should be non-reifiable, reification of polymonadic binds is not yet implemented - (* - * AR: TODO: FIXME: we are allowing reification of effects that use polymoandic binds, - * but this should only be used for proofs, extracting such code would - * not work - *) - // if Env.is_user_reifiable_effect env p - // then raise_error (Errors.Fatal_EffectCannotBeReified, - // BU.format2 "Error typechecking the polymonadic bind %s, the final effect %s is reifiable \ - // and reification of polymondic binds is not yet implemented" - // eff_name (Ident.string_of_lid p)) r; - - //typecheck the term making sure that it is universe polymorphic in 2 universes - let (us, t, ty) = check_and_gen env eff_name "polymonadic_bind" 2 ts in - - //make sure that the bind is of the right shape - - let us, ty = SS.open_univ_vars us ty in - let env = Env.push_univ_vars env us in - - let m_ed, n_ed, p_ed = Env.get_effect_decl env m, Env.get_effect_decl env n, Env.get_effect_decl env p in - - let k, kind = validate_indexed_effect_bind_shape env m n p - (U.effect_sig_ts m_ed.signature) - (U.effect_sig_ts n_ed.signature) - (U.effect_sig_ts p_ed.signature) - (U.get_eff_repr m_ed) (U.get_eff_repr n_ed) (U.get_eff_repr p_ed) - us - ty - (Env.get_range env) - 0 - false in - - if Debug.extreme () - then BU.print3 "Polymonadic bind %s after typechecking (%s::%s)\n" - eff_name (Print.tscheme_to_string (us, t)) - (Print.tscheme_to_string (us, k)); - - log_issue r Errors.Warning_BleedingEdge_Feature [Errors.text <| - BU.format1 "Polymonadic binds (%s in this case) is an experimental feature;\ - it is subject to some redesign in the future. Please keep us informed (on github etc.) about how you are using it" - eff_name - ]; - - (us, t), (us, k |> SS.close_univ_vars us), kind - - -let tc_polymonadic_subcomp env0 (m:lident) (n:lident) (ts:S.tscheme) = - let r = (snd ts).pos in - - check_lift_for_erasable_effects env0 m n r; - - let combinator_name = - (m |> ident_of_lid |> string_of_id) ^ " <: " ^ - (n |> ident_of_lid |> string_of_id) in - - let us, t, ty = check_and_gen env0 combinator_name "polymonadic_subcomp" 1 ts in - - //make sure that the combinator has the right shape - - let us, ty = SS.open_univ_vars us ty in - let env = Env.push_univ_vars env0 us in - - let m_ed, n_ed = Env.get_effect_decl env m, Env.get_effect_decl env n in - - let k, kind = validate_indexed_effect_subcomp_shape env m n - (U.effect_sig_ts m_ed.signature) - (U.effect_sig_ts n_ed.signature) - (U.get_eff_repr m_ed) (U.get_eff_repr n_ed) - (List.hd us) - ty - 0 - (Env.get_range env) in - - if Debug.extreme () - then BU.print3 "Polymonadic subcomp %s after typechecking (%s::%s)\n" - combinator_name - (Print.tscheme_to_string (us, t)) - (Print.tscheme_to_string (us, k)); - - log_issue r Errors.Warning_BleedingEdge_Feature [ - Errors.text <| - BU.format1 "Polymonadic subcomp (%s in this case) is an experimental feature;\ - it is subject to some redesign in the future. Please keep us informed (on github etc.) about how you are using it" - combinator_name - ]; - - (us, t), (us, k |> SS.close_univ_vars us), kind diff --git a/src/typechecker/FStar.TypeChecker.TcEffect.fsti b/src/typechecker/FStar.TypeChecker.TcEffect.fsti deleted file mode 100644 index ab2eadad195..00000000000 --- a/src/typechecker/FStar.TypeChecker.TcEffect.fsti +++ /dev/null @@ -1,38 +0,0 @@ -(* - Copyright 2008-2018 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.TypeChecker.TcEffect - -open FStar.Compiler.Effect - -open FStar -open FStar.Compiler -open FStar.Ident - -module S = FStar.Syntax.Syntax -module Env = FStar.TypeChecker.Env - - -val dmff_cps_and_elaborate : Env.env -> S.eff_decl -> (list S.sigelt & S.eff_decl & option S.sigelt) - -val tc_eff_decl : Env.env -> S.eff_decl -> list S.qualifier -> list S.attribute -> S.eff_decl - -val tc_lift : Env.env -> S.sub_eff -> Range.range -> S.sub_eff - -val tc_effect_abbrev : Env.env -> (lident & S.univ_names & S.binders & S.comp) -> Range.range -> (lident & S.univ_names & S.binders & S.comp) - -val tc_polymonadic_bind : Env.env -> m:lident -> n:lident -> p:lident -> bind_t:S.tscheme -> S.tscheme & S.tscheme & S.indexed_effect_combinator_kind - -val tc_polymonadic_subcomp : Env.env -> m:lident -> n:lident -> subcomp_t:S.tscheme -> S.tscheme & S.tscheme & S.indexed_effect_combinator_kind diff --git a/src/typechecker/FStar.TypeChecker.TcInductive.fst b/src/typechecker/FStar.TypeChecker.TcInductive.fst deleted file mode 100644 index 83ee3156cf7..00000000000 --- a/src/typechecker/FStar.TypeChecker.TcInductive.fst +++ /dev/null @@ -1,1311 +0,0 @@ -(* - Copyright 2008-2014 Microsoft Research - - Authors: Nikhil Swamy, Aseem Rastogi - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) -module FStar.TypeChecker.TcInductive -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.Errors -open FStar.TypeChecker -open FStar.TypeChecker.Env -open FStar.Compiler.Util -open FStar.Ident -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.Syntax.Subst -open FStar.Syntax.Util -open FStar.Const -open FStar.TypeChecker.Rel -open FStar.TypeChecker.Common -open FStar.TypeChecker.TcTerm -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module N = FStar.TypeChecker.Normalize -module TcUtil = FStar.TypeChecker.Util -module Gen = FStar.TypeChecker.Generalize -module BU = FStar.Compiler.Util //basic util -module U = FStar.Syntax.Util -module PP = FStar.Syntax.Print -module C = FStar.Parser.Const - -open FStar.Class.Show -open FStar.Class.Listlike - -let dbg_GenUniverses = Debug.get_toggle "GenUniverses" -let dbg_LogTypes = Debug.get_toggle "LogTypes" -let dbg_Injectivity = Debug.get_toggle "Injectivity" - -let unfold_whnf = N.unfold_whnf' [Env.AllowUnboundUniverses] - -let check_sig_inductive_injectivity_on_params (tcenv:env_t) (se:sigelt) - : sigelt - = if tcenv.phase1 then se else - let Sig_inductive_typ dd = se.sigel in - let { lid=t; us=universe_names; params=tps; t=k } = dd in - let t_lid = t in - let usubst, uvs = SS.univ_var_opening universe_names in - let tcenv, tps, k = - Env.push_univ_vars tcenv uvs, - SS.subst_binders usubst tps, - SS.subst (SS.shift_subst (List.length tps) usubst) k - in - let tps, k = SS.open_term tps k in - let _, k = U.arrow_formals k in //don't care about indices here - let tps, env_tps, _, us = TcTerm.tc_binders tcenv tps in - let u_k = - TcTerm.level_of_type - env_tps - (S.mk_Tm_app - (S.fvar t None) - (snd (U.args_of_binders tps)) - (Ident.range_of_lid t)) - k - in - //BU.print2 "Universe of tycon: %s : %s\n" (Ident.string_of_lid t) (show u_k); - let rec universe_leq u v = - match u, v with - | U_zero, _ -> true - | U_succ u0, U_succ v0 -> universe_leq u0 v0 - | U_name u0, U_name v0 -> Ident.ident_equals u0 v0 - | U_name _, U_succ v0 -> universe_leq u v0 - | U_max us, _ -> us |> BU.for_all (fun u -> universe_leq u v) - | _, U_max vs -> vs |> BU.for_some (universe_leq u) - | U_unknown, _ - | _, U_unknown - | U_unif _, _ - | _, U_unif _ -> failwith (BU.format3 "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" - (show t) - (show u) - (show v)) - | _ -> false - in - let u_leq_u_k u = - let u = N.normalize_universe env_tps u in - universe_leq u u_k - in - let tp_ok (tp:S.binder) (u_tp:universe) = - let t_tp = tp.binder_bv.sort in - if u_leq_u_k u_tp - then true - else ( - let t_tp = - N.normalize - [Unrefine; Unascribe; Unmeta; - Primops; HNF; UnfoldUntil delta_constant; Beta] - env_tps t_tp - in - let formals, t = U.arrow_formals t_tp in - let _, _, _, u_formals = TcTerm.tc_binders env_tps formals in - let inj = BU.for_all (fun u_formal -> u_leq_u_k u_formal) u_formals in - if inj - then ( - match (SS.compress t).n with - | Tm_type u -> - (* retain injectivity for parameters that are type functions - from small universes (i.e., all formals are smaller than the constructed type) - to a universe <= the universe of the constructed type. - See BugBoxInjectivity.fst *) - u_leq_u_k u - | _ -> - false - ) - else ( - false - ) - - ) - in - let injective_type_params = List.forall2 tp_ok tps us in - if !dbg_Injectivity - then BU.print2 "%s injectivity for %s\n" - (if injective_type_params then "YES" else "NO") - (Ident.string_of_lid t); - { se with sigel = Sig_inductive_typ { dd with injective_type_params } } - -let tc_tycon (env:env_t) (* environment that contains all mutually defined type constructors *) - (s:sigelt) (* a Sig_inductive_type (aka tc) that needs to be type-checked *) - : env_t (* environment extended with a refined type for the type-constructor *) - & sigelt (* the typed version of s, with universe variables still TBD *) - & universe (* universe of the constructed type *) - & guard_t (* constraints on implicit variables *) - = match s.sigel with - | Sig_inductive_typ {lid=tc; us=uvs; params=tps; num_uniform_params=n_uniform; - t=k; mutuals; ds=data} -> //the only valid qual is Private - //assert (uvs = []); AR: not necessarily true in two phase - let env0 = env in - (*open*)let usubst, uvs = SS.univ_var_opening uvs in - let env, tps, k = Env.push_univ_vars env uvs, SS.subst_binders usubst tps, SS.subst (SS.shift_subst (List.length tps) usubst) k in - let tps, k = SS.open_term tps k in - let tps, env_tps, guard_params, us = tc_binders env tps in - - (* - * AR: typecheck k and get the indices and t out - * adding a very restricted normalization to unfold symbols that are marked unfold explicitly - * note that t is opened with indices (by U.arrow_formals) - *) - let (indices, t), guard = - let k, _, g = tc_tot_or_gtot_term env_tps k in - let k = N.normalize [Exclude Iota; Exclude Zeta; Eager_unfolding; NoFullNorm; Exclude Beta] env_tps k in - U.arrow_formals k, Rel.discharge_guard env_tps (Env.conj_guard guard_params g) - in - - let k = U.arrow indices (S.mk_Total t) in - let t_type, u = U.type_u() in - //AR: allow only Type and eqtype, nothing else. - // If the annotation is eqtype, then the type cannot contain the noeq qualifier - // nor the unopteq qualifier. That is, if the user wants to annotate an inductive - // as eqtype, they must run the full hasEq check - let valid_type = (U.is_eqtype_no_unrefine t && not (s.sigquals |> List.contains Noeq) && not (s.sigquals |> List.contains Unopteq)) || - (teq_nosmt_force env t t_type) in - if not valid_type then - raise_error s Errors.Error_InductiveAnnotNotAType [ - text (BU.format2 "Type annotation %s for inductive %s is not Type or eqtype, \ - or it is eqtype but contains noeq/unopteq qualifiers" - (show t) (show tc)) - ]; - -(*close*)let usubst = SS.univ_var_closing uvs in - let guard = TcUtil.close_guard_implicits env false tps guard in - let t_tc = U.arrow ((tps |> SS.subst_binders usubst) @ - (indices |> SS.subst_binders (SS.shift_subst (List.length tps) usubst))) - (S.mk_Total (t |> SS.subst (SS.shift_subst (List.length tps + List.length indices) usubst))) in - let tps = SS.close_binders tps in - let k = SS.close tps k in - let tps, k = SS.subst_binders usubst tps, SS.subst (SS.shift_subst (List.length tps) usubst) k in - let fv_tc = S.lid_as_fv tc None in - let (uvs, t_tc) = SS.open_univ_vars uvs t_tc in - Env.push_let_binding env0 (Inr fv_tc) (uvs, t_tc), - { s with sigel = Sig_inductive_typ {lid=tc; - us=uvs; - params=tps; - num_uniform_params=n_uniform; - t=k; - mutuals; - ds=data; - injective_type_params=false} }, - u, - guard - - | _ -> failwith "impossible" - -(* Used to make the binders of the tycon (ie parameters) implicit in -the projectors and discriminators. We always make them implicit, but -the argument already had a meta-qualifier, we must retain it. See bug #2591. *) -let mk_implicit : bqual -> bqual = function - | Some (Meta q) -> Some (Meta q) - | _ -> Some (Implicit false) - -(* 2. Checking each datacon *) -let tc_data (env:env_t) (tcs : list (sigelt & universe)) - : sigelt -> sigelt & guard_t = - fun se -> match se.sigel with - | Sig_datacon {lid=c; us=_uvs; t; ty_lid=tc_lid; num_ty_params=ntps; mutuals=mutual_tcs} -> - //assert (_uvs = []); - let usubst, _uvs = SS.univ_var_opening _uvs in - let env, t = Env.push_univ_vars env _uvs, SS.subst usubst t in - let (env, tps, u_tc) = //u_tc is the universe of the inductive that c constructs - let tps_u_opt = BU.find_map tcs (fun (se, u_tc) -> - if lid_equals tc_lid (must (U.lid_of_sigelt se)) - then match se.sigel with - | Sig_inductive_typ {params=tps} -> - let tps = tps |> SS.subst_binders usubst |> List.map (fun x -> {x with binder_qual=Some S.imp_tag}) in - let tps = Subst.open_binders tps in - Some (Env.push_binders env tps, tps, u_tc) - | _ -> failwith "Impossible" - else None) in - match tps_u_opt with - | Some x -> x - | None -> - if lid_equals tc_lid FStar.Parser.Const.exn_lid - then env, [], U_zero - else raise_error se Errors.Fatal_UnexpectedDataConstructor "Unexpected data constructor" - in - - let arguments, result = - let t = N.normalize (N.whnf_steps @ [Env.AllowUnboundUniverses]) env t in //AR: allow unbounded universes, since we haven't typechecked t yet - let t = U.canon_arrow t in - match (SS.compress t).n with - | Tm_arrow {bs; comp=res} -> - //the type of each datacon is already a function with the type params as arguments - //need to map the prefix of bs corresponding to params to the tps of the inductive - let _, bs' = BU.first_N ntps bs in - let t = mk (Tm_arrow {bs=bs'; comp=res}) t.pos in - let subst = tps |> List.mapi (fun i ({binder_bv=x}) -> DB(ntps - (1 + i), x)) in -(*open*) let bs, c = U.arrow_formals_comp (SS.subst subst t) in - (* check that c is a Tot computation, reject it otherwise - * (unless --MLish, which will mark all of them with ML effect) *) - if Options.ml_ish () || is_total_comp c - then bs, comp_result c - else raise_error (U.comp_effect_name c) Errors.Fatal_UnexpectedConstructorType - "Constructors cannot have effects" - - | _ -> [], t - in - - if Debug.low () then BU.print3 "Checking datacon %s : %s -> %s \n" - (show c) - (show arguments) - (show result); - - let arguments, env', us = tc_tparams env arguments in - let type_u_tc = S.mk (Tm_type u_tc) result.pos in - let env' = Env.set_expected_typ env' type_u_tc in - let result, res_lcomp = tc_trivial_guard env' result in - let head, args = U.head_and_args_full result in (* collect nested applications too *) - - (* - * AR: if the inductive type is explictly universe annotated, - * we need to instantiate universes properly in head (head = tycon) - * the following code unifies them with the annotated universes - *) - let g_uvs = match (SS.compress head).n with - | Tm_uinst ( { n = Tm_fvar fv }, tuvs) when S.fv_eq_lid fv tc_lid -> //AR: in the second phase of 2-phases, this can be a Tm_uninst too - if List.length _uvs = List.length tuvs then - List.fold_left2 (fun g u1 u2 -> - //unify the two - Env.conj_guard g (Rel.teq env' (mk (Tm_type u1) Range.dummyRange) (mk (Tm_type (U_name u2)) Range.dummyRange)) - ) Env.trivial_guard tuvs _uvs - else Errors.raise_error se Errors.Fatal_UnexpectedConstructorType - "Length of annotated universes does not match inferred universes" - | Tm_fvar fv when S.fv_eq_lid fv tc_lid -> Env.trivial_guard - | _ -> raise_error se Errors.Fatal_UnexpectedConstructorType - (BU.format2 "Expected a constructor of type %s; got %s" (show tc_lid) (show head)) - in - let g =List.fold_left2 (fun g ({binder_bv=x}) u_x -> - Env.conj_guard g (Rel.universe_inequality u_x u_tc)) - g_uvs - arguments - us in - - (* Make sure the parameters are respected, cf #1534 *) - (* The first few arguments, as many as List.length tps, must exactly match the - * bvs in tps, as they have been opened already by the code above. Must be done - * after typechecking `result`, to make sure implicits are filled in. However, - * we stop if we logged an error, since it may mean the result type is missing - * some parameters, and we'd crash when trying to extract them. See issue - * #2167. *) - Errors.stop_if_err (); - let p_args = fst (BU.first_N (List.length tps) args) in - List.iter2 (fun ({binder_bv=bv}) (t, _) -> - match (SS.compress t).n with - | Tm_name bv' when S.bv_eq bv bv' -> () - | _ -> - raise_error t Errors.Error_BadInductiveParam - (BU.format2 "This parameter is not constant: expected %s, got %s" (show bv) (show t)) - ) tps p_args; - - let ty = unfold_whnf env res_lcomp.res_typ |> U.unrefine in - begin match (SS.compress ty).n with - | Tm_type _ -> () - | _ -> raise_error se Errors.Fatal_WrongResultTypeAfterConstrutor - (BU.format2 "The type of %s is %s, but since this is the result type of a constructor its type should be Type" - (show result) - (show ty)) - end; - -(*close*)let t = U.arrow ((tps |> List.map (fun b -> {b with binder_qual=Some (Implicit true)}))@arguments) (S.mk_Total result) in - //NB: the tps are tagged as Implicit inaccessbile arguments of the data constructor - let t = SS.close_univ_vars _uvs t in - { se with sigel = Sig_datacon {lid=c; - us=_uvs; - t; - ty_lid=tc_lid; - num_ty_params=ntps; - mutuals=mutual_tcs; - injective_type_params=false} }, - g - - | _ -> failwith "impossible" - - -(* 3. Generalizing universes and 4. instantiate inductives within the datacons *) -let generalize_and_inst_within (env:env_t) (tcs:list (sigelt & universe)) (datas:list sigelt) - : list sigelt & list sigelt - = //We build a single arrow term of the form - // tc_1 -> .. -> tc_n -> dt_1 -> .. dt_n -> Tot unit - //for each type constructor tc_i - //and each data constructor type dt_i - //and generalize their universes together - let binders = tcs |> List.map (fun (se, _) -> - match se.sigel with - | Sig_inductive_typ {params=tps; t=k} -> S.null_binder (U.arrow tps <| mk_Total k) - | _ -> failwith "Impossible") in - let binders' = datas |> List.map (fun se -> match se.sigel with - | Sig_datacon {t} -> S.null_binder t - | _ -> failwith "Impossible") in - let t = U.arrow (binders@binders') (S.mk_Total t_unit) in - if !dbg_GenUniverses - then BU.print1 "@@@@@@Trying to generalize universes in %s\n" (N.term_to_string env t); - let (uvs, t) = Gen.generalize_universes env t in - if !dbg_GenUniverses - then BU.print2 "@@@@@@Generalized to (%s, %s)\n" - (uvs |> List.map (fun u -> (string_of_id u)) |> String.concat ", ") - (show t); - //Now, (uvs, t) is the generalized type scheme for all the inductives and their data constuctors - - //we have to destruct t, knowing its shape above, - //and rebuild the Sig_inductive_typ, Sig_datacon etc - let uvs, t = SS.open_univ_vars uvs t in - let args, _ = U.arrow_formals t in - let tc_types, data_types = BU.first_N (List.length binders) args in - let tcs = List.map2 (fun ({binder_bv=x}) (se, _) -> match se.sigel with - | Sig_inductive_typ {lid=tc; params=tps; num_uniform_params=num_uniform; mutuals; ds=datas} -> - let ty = SS.close_univ_vars uvs x.sort in - let tps, t = match (SS.compress ty).n with - | Tm_arrow {bs=binders; comp=c} -> - let tps, rest = BU.first_N (List.length tps) binders in - let t = match rest with - | [] -> U.comp_result c - | _ -> mk (Tm_arrow {bs=rest; comp=c}) x.sort.pos - in - tps, t - | _ -> [], ty - in - { se with sigel = Sig_inductive_typ {lid=tc; - us=uvs; - params=tps; - num_uniform_params=num_uniform; - t; - mutuals; - ds=datas; - injective_type_params=false} } - | _ -> failwith "Impossible") - tc_types tcs - in - - //4. Instantiate the inductives in each datacon with the generalized universes - let datas = match uvs with - | [] -> datas - | _ -> - let uvs_universes = uvs |> List.map U_name in - let tc_insts = tcs |> List.map (function { sigel = Sig_inductive_typ {lid=tc} } -> (tc, uvs_universes) | _ -> failwith "Impossible") in - List.map2 (fun ({binder_bv=t}) d -> - match d.sigel with - | Sig_datacon {lid=l; ty_lid=tc; num_ty_params=ntps; mutuals} -> - let ty = InstFV.instantiate tc_insts t.sort |> SS.close_univ_vars uvs in - { d with sigel = Sig_datacon {lid=l; - us=uvs; - t=ty; - ty_lid=tc; - num_ty_params=ntps; - mutuals; - injective_type_params=false} } - | _ -> failwith "Impossible") - data_types datas - in - tcs, datas - - -let datacon_typ (data:sigelt) :term = - match data.sigel with - | Sig_datacon {t} -> t - | _ -> failwith "Impossible!" - -(* private *) -let haseq_suffix = "__uu___haseq" - -let is_haseq_lid lid = - let str = (string_of_lid lid) in - let len = String.length str in - let haseq_suffix_len = String.length haseq_suffix in - len > haseq_suffix_len && - String.compare (String.substring str (len - haseq_suffix_len) haseq_suffix_len) haseq_suffix = 0 - -let get_haseq_axiom_lid lid = - lid_of_ids (ns_of_lid lid @ [(id_of_text (string_of_id (ident_of_lid lid) ^ haseq_suffix))]) - -//get the optimized hasEq axiom for this inductive -//the caller is supposed to open the universes, and pass along the universe substitution and universe names -//returns -- lid of the hasEq axiom -// -- the hasEq axiom for the inductive -// -- opened parameter binders -// -- opened index binders -// -- conjunction of hasEq of the binders -let get_optimized_haseq_axiom (en:env) (ty:sigelt) (usubst:list subst_elt) (us:univ_names) :(lident & term & binders & binders & term) = - let lid, bs, t = - match ty.sigel with - | Sig_inductive_typ {lid; params=bs; t} -> lid, bs, t - | _ -> failwith "Impossible!" - in - - //apply usubt to bs - let bs = SS.subst_binders usubst bs in - //apply usubst to t, but first shift usubst -- is there a way to apply usubst to bs and t together ? - let t = SS.subst (SS.shift_subst (List.length bs) usubst) t in - //open t with binders bs - let bs, t = SS.open_term bs t in - //get the index binders, if any - let ibs = - match (SS.compress t).n with - | Tm_arrow {bs=ibs} -> ibs - | _ -> [] - in - //open the ibs binders - let ibs = SS.open_binders ibs in - //term for unapplied inductive type, making a Tm_uinst, otherwise there are unresolved universe variables, may be that's fine ? - let ind = mk_Tm_uinst (S.fvar lid None) (List.map (fun u -> U_name u) us) in - //apply the bs parameters, bv_to_name ok ? also note that we are copying the qualifiers from the binder, so that implicits remain implicits - let ind = mk_Tm_app ind (List.map U.arg_of_non_null_binder bs) Range.dummyRange in - //apply the ibs parameters, bv_to_name ok ? also note that we are copying the qualifiers from the binder, so that implicits remain implicits - let ind = mk_Tm_app ind (List.map U.arg_of_non_null_binder ibs) Range.dummyRange in - //haseq of ind - let haseq_ind = mk_Tm_app U.t_haseq [S.as_arg ind] Range.dummyRange in - //haseq of all binders in bs, we will add only those binders x:t for which t <: Type u for some fresh universe variable u - //we want to avoid the case of binders such as (x:nat), as hasEq x is not well-typed - let bs' = List.filter (fun b -> - Rel.subtype_nosmt_force en b.binder_bv.sort (fst (U.type_u ())) - ) bs in - let haseq_bs = List.fold_left (fun (t:term) (b:binder) -> U.mk_conj t (mk_Tm_app U.t_haseq [S.as_arg (S.bv_to_name b.binder_bv)] Range.dummyRange)) U.t_true bs' in - //implication - let fml = U.mk_imp haseq_bs haseq_ind in - //attach pattern -- is this the right place ? - let fml = { fml with n = Tm_meta {tm=fml; - meta=Meta_pattern(binders_to_names ibs, [[S.as_arg haseq_ind]])} } in - //fold right with ibs, close and add a forall b - //we are setting the qualifier of the binder to None explicitly, we don't want to make forall binder implicit etc. ? - let fml = List.fold_right (fun (b:binder) (t:term) -> mk_Tm_app U.tforall [ S.as_arg (U.abs [S.mk_binder b.binder_bv] (SS.close [b] t) None) ] Range.dummyRange) ibs fml in - - //fold right with bs, close and add a forall b - //we are setting the qualifier of the binder to None explicitly, we don't want to make forall binder implicit etc. ? - let fml = List.fold_right (fun (b:binder) (t:term) -> mk_Tm_app U.tforall [ S.as_arg (U.abs [S.mk_binder b.binder_bv] (SS.close [b] t) None) ] Range.dummyRange) bs fml in - - let axiom_lid = get_haseq_axiom_lid lid in - axiom_lid, fml, bs, ibs, haseq_bs - -//soundness condition for this data constructor -//usubst is the universe substitution, and bs are the opened inductive type parameters -let optimized_haseq_soundness_for_data (ty_lid:lident) (data:sigelt) (usubst:list subst_elt) (bs:binders) :term = - let dt = datacon_typ data in - //apply the universes substitution to dt - let dt = SS.subst usubst dt in - match (SS.compress dt).n with - | Tm_arrow {bs=dbs} -> - //filter out the inductive type parameters, dbs are the remaining binders - let dbs = snd (List.splitAt (List.length bs) dbs) in - //substitute bs into dbs - let dbs = SS.subst_binders (SS.opening_of_binders bs) dbs in - //open dbs - let dbs = SS.open_binders dbs in - //fold on dbs, add haseq of its sort to the guard - let cond = List.fold_left (fun (t:term) (b:binder) -> - let haseq_b = mk_Tm_app U.t_haseq [S.as_arg b.binder_bv.sort] Range.dummyRange in - //label the haseq predicate so that we get a proper error message if the assertion fails - let sort_range = b.binder_bv.sort.pos in - let open FStar.Errors.Msg in - let open FStar.Pprint in - let open FStar.Class.PP in - let haseq_b = TcUtil.label - [ - text "Failed to prove that the type" ^/^ squotes (pp ty_lid) ^/^ text "supports decidable equality because of this argument."; - text "Add either the 'noeq' or 'unopteq' qualifier"; - ] - sort_range - haseq_b - in - U.mk_conj t haseq_b) U.t_true dbs - in - //fold right over dbs and add a forall for each binder in dbs - List.fold_right (fun (b:binder) (t:term) -> mk_Tm_app tforall [ - S.iarg b.binder_bv.sort; - S.as_arg (U.abs [S.mk_binder b.binder_bv] (SS.close [b] t) None) - ] Range.dummyRange) dbs cond - | _ -> U.t_true - -//this is the folding function for tcs -//all_datas_in_the_bundle are all data constructors, including those of mutually defined inductives -//usubst and us are the universe variables substitution and universe names, we open each type constructor type, and data constructor type with these -//in the type of the accumulator: - //list (lident * term) is the list of type constructor lidents and formulas of haseq axioms we are accumulating - //env is the environment in which the next two terms are well-formed (e.g. data constructors are dependent function types, so they may refer to their arguments) - //term is the lhs of the implication for soundness formula - //term is the soundness condition derived from all the data constructors of this type -let optimized_haseq_ty (all_datas_in_the_bundle:sigelts) (usubst:list subst_elt) (us:list univ_name) acc ty = - let lid = - match ty.sigel with - | Sig_inductive_typ {lid} -> lid - | _ -> failwith "Impossible!" - in - - let _, en, _, _ = acc in - let axiom_lid, fml, bs, ibs, haseq_bs = get_optimized_haseq_axiom en ty usubst us in - //fml is the hasEq axiom for the inductive, bs and ibs are opened binders and index binders, - //haseq_bs is the conjunction of hasEq of all the binders - - //onto the soundness condition for the above axiom - //this is the soundness guard - let guard = U.mk_conj haseq_bs fml in - - //now work on checking the soundness of this formula - //split acc - let l_axioms, env, guard', cond' = acc in - - //push universe variables, bs, and ibs, universe variables are pushed at the top level below - let env = Env.push_binders env bs in - let env = Env.push_binders env ibs in - - //now generate the soundness condition by iterating over the data constructors - //get the data constructors for this type - let t_datas = List.filter (fun s -> - match s.sigel with - | Sig_datacon {ty_lid=t_lid} -> t_lid = lid - | _ -> failwith "Impossible" - ) all_datas_in_the_bundle in - - - //fold over t_datas - let cond = List.fold_left (fun acc d -> U.mk_conj acc (optimized_haseq_soundness_for_data lid d usubst bs)) U.t_true t_datas in - - //return new accumulator - l_axioms @ [axiom_lid, fml], env, U.mk_conj guard' guard, U.mk_conj cond' cond - - -let optimized_haseq_scheme (sig_bndle:sigelt) (tcs:list sigelt) (datas:list sigelt) (env0:env_t) :list sigelt = - let us, t = - let ty = List.hd tcs in - match ty.sigel with - | Sig_inductive_typ {us; t} -> us, t - | _ -> failwith "Impossible!" - in - let usubst, us = SS.univ_var_opening us in - - // We need the sigbundle for the inductive to be in the type environment. - // We can force this push as this is only temporary, it will be rolled back - let env = Env.push env0 "haseq" in - let env = Env.push_sigelt_force env sig_bndle in - env.solver.encode_sig env sig_bndle; - let env = Env.push_univ_vars env us in - - let axioms, env, guard, cond = List.fold_left (optimized_haseq_ty datas usubst us) ([], env, U.t_true, U.t_true) tcs in - - let phi = - let _, t = U.arrow_formals t in - if U.is_eqtype_no_unrefine t then cond //AR: if the type is marked as eqtype, you don't get to assume equality of type parameters - else U.mk_imp guard cond in - let phi, _ = tc_trivial_guard env phi in - let _ = - //is this inline with verify_module ? - if Env.should_verify env then - Rel.force_trivial_guard env (Env.guard_of_guard_formula (NonTrivial phi)) - else () - in - - //create Sig_assume for the axioms, FIXME: docs? - let ses = List.fold_left (fun (l:list sigelt) (lid, fml) -> - let fml = SS.close_univ_vars us fml in - l @ [ { sigel = Sig_assume {lid; us; phi=fml}; - sigquals = [InternalAssumption]; - sigrng = Range.dummyRange; - sigmeta = default_sigmeta; - sigattrs = []; - sigopts = None; - sigopens_and_abbrevs = []; } ] - ) [] axioms in - - ignore (Env.pop env "haseq"); - - ses - -//folding function for t_datas -//usubst is the universe substitution, bs are the opened inductive type parameters -//haseq_ind is the inductive applied to all its bs and ibs -let unoptimized_haseq_data (usubst:list subst_elt) (bs:binders) (haseq_ind:term) (mutuals:list lident) (acc:term) (data:sigelt) = - - //identify if the type t is a mutually defined type - //TODO: we now have a get_free_names in Syntax.Free, use that - let rec is_mutual (t:term) = //TODO: this should handle more cases - match (SS.compress t).n with - | Tm_fvar fv -> List.existsb (fun lid -> lid_equals lid fv.fv_name.v) mutuals - | Tm_uinst (t', _) -> is_mutual t' - | Tm_refine {b=bv} -> is_mutual bv.sort - | Tm_app {hd=t'; args} -> if is_mutual t' then true else exists_mutual (List.map fst args) - | Tm_meta {tm=t'} -> is_mutual t' - | _ -> false - - and exists_mutual = function - | [] -> false - | hd::tl -> is_mutual hd || exists_mutual tl - in - - - let dt = datacon_typ data in - //apply the universes substitution to dt - let dt = SS.subst usubst dt in - match (SS.compress dt).n with - | Tm_arrow {bs=dbs} -> - //filter out the inductive type parameters, dbs are the remaining binders - let dbs = snd (List.splitAt (List.length bs) dbs) in - //substitute bs into dbs - let dbs = SS.subst_binders (SS.opening_of_binders bs) dbs in - //open dbs - let dbs = SS.open_binders dbs in - //fold on dbs, add haseq of its sort to the guard - //if the sort is a mutual, guard its hasEq with the hasEq of the current type constructor - //cond is the conjunct of the hasEq of all the data constructor arguments - let cond = List.fold_left (fun (t:term) (b:binder) -> - let sort = b.binder_bv.sort in - let haseq_sort = mk_Tm_app U.t_haseq [S.as_arg b.binder_bv.sort] Range.dummyRange in - let haseq_sort = if is_mutual sort then U.mk_imp haseq_ind haseq_sort else haseq_sort in - U.mk_conj t haseq_sort) U.t_true dbs - in - - //fold right with dbs, close and add a forall b - //we are setting the qualifier of the binder to None explicitly, we don't want to make forall binder implicit etc. ? - let cond = List.fold_right (fun (b:binder) (t:term) -> mk_Tm_app tforall [ S.as_arg (U.abs [S.mk_binder b.binder_bv] (SS.close [b] t) None) ] Range.dummyRange) dbs cond in - - //new accumulator is old one /\ cond - U.mk_conj acc cond - | _ -> acc - -//this is the folding function for tcs -//usubst and us are the universe variables substitution and universe names, we open each type constructor type, and data constructor type with these -//the accumulator is the formula that we are building, for each type constructor, we add a conjunct to it -let unoptimized_haseq_ty (all_datas_in_the_bundle:list sigelt) (mutuals:list lident) (usubst:list subst_elt) (us:list univ_name) (acc:term) (ty:sigelt) = - let lid, bs, t, d_lids = - match ty.sigel with - | Sig_inductive_typ {lid; params=bs; t; ds=d_lids} -> lid, bs, t, d_lids - | _ -> failwith "Impossible!" - in - - //apply usubt to bs - let bs = SS.subst_binders usubst bs in - //apply usubst to t, but first shift usubst -- is there a way to apply usubst to bs and t together ? - let t = SS.subst (SS.shift_subst (List.length bs) usubst) t in - //open t with binders bs - let bs, t = SS.open_term bs t in - //get the index binders, if any - let ibs = - match (SS.compress t).n with - | Tm_arrow {bs=ibs} -> ibs - | _ -> [] - in - //open the ibs binders - let ibs = SS.open_binders ibs in - //term for unapplied inductive type, making a Tm_uinst, otherwise there are unresolved universe variables, may be that's fine ? - let ind = mk_Tm_uinst (S.fvar lid None) (List.map (fun u -> U_name u) us) in - //apply the bs parameters, bv_to_name ok ? also note that we are copying the qualifiers from the binder, so that implicits remain implicits - let ind = mk_Tm_app ind (List.map U.arg_of_non_null_binder bs) Range.dummyRange in - //apply the ibs parameters, bv_to_name ok ? also note that we are copying the qualifiers from the binder, so that implicits remain implicits - let ind = mk_Tm_app ind (List.map U.arg_of_non_null_binder ibs) Range.dummyRange in - //haseq of ind applied to all bs and ibs - let haseq_ind = mk_Tm_app U.t_haseq [S.as_arg ind] Range.dummyRange in - - - //filter out data constructors for this type constructor - let t_datas = List.filter (fun s -> - match s.sigel with - | Sig_datacon {ty_lid=t_lid} -> t_lid = lid - | _ -> failwith "Impossible" - ) all_datas_in_the_bundle in - - //fold over t_datas - let data_cond = List.fold_left (unoptimized_haseq_data usubst bs haseq_ind mutuals) U.t_true t_datas in - - //make the implication - let fml = U.mk_imp data_cond haseq_ind in - - //attach pattern -- is this the right place ? - let fml = { fml with n = Tm_meta {tm=fml; - meta=Meta_pattern(binders_to_names ibs, [[S.as_arg haseq_ind]])} } in - - //fold right with ibs, close and add a forall b - //we are setting the qualifier of the binder to None explicitly, we don't want to make forall binder implicit etc. ? - let fml = List.fold_right (fun (b:binder) (t:term) -> mk_Tm_app tforall [ S.as_arg (U.abs [S.mk_binder b.binder_bv] (SS.close [b] t) None) ] Range.dummyRange) ibs fml in - //fold right with bs, close and add a forall b - //we are setting the qualifier of the binder to None explicitly, we don't want to make forall binder implicit etc. ? - let fml = List.fold_right (fun (b:binder) (t:term) -> mk_Tm_app tforall [ S.as_arg (U.abs [S.mk_binder b.binder_bv] (SS.close [b] t) None) ] Range.dummyRange) bs fml in - - //new accumulator is old accumulator /\ fml - U.mk_conj acc fml - -let unoptimized_haseq_scheme (sig_bndle:sigelt) (tcs:list sigelt) (datas:list sigelt) (env0:env_t) :list sigelt = - //TODO: perhaps make it a map ? - let mutuals = List.map (fun ty -> - match ty.sigel with - | Sig_inductive_typ {lid} -> lid - | _ -> failwith "Impossible!") tcs - in - - - let lid, us = - let ty = List.hd tcs in - match ty.sigel with - | Sig_inductive_typ {lid; us} -> lid, us - | _ -> failwith "Impossible!" - in - let usubst, us = SS.univ_var_opening us in - - let fml = List.fold_left (unoptimized_haseq_ty datas mutuals usubst us) U.t_true tcs in - - let se = //FIXME: docs? - { sigel = Sig_assume {lid=get_haseq_axiom_lid lid; us; phi=fml}; - sigquals = [InternalAssumption]; - sigrng = Range.dummyRange; - sigmeta = default_sigmeta; - sigattrs = []; - sigopts = None; - sigopens_and_abbrevs = []; - } - - in - [se] - - -//returns: sig bundle, list of type constructors, list of data constructors -let check_inductive_well_typedness (env:env_t) (ses:list sigelt) (quals:list qualifier) (lids:list lident) :(sigelt & list sigelt & list sigelt) = - (* Consider this illustrative example: - - type T (a:Type) : (b:Type) -> Type = - | C1 : x:a -> y:Type -> T a y - | C2 : x:a -> z:Type -> w:Type -> T a z - - (1). We elaborate the type of T to - T : a:Type(ua) -> b:Type(ub) -> Type(u) - - (2). In a context - G = a:Type(ua), T: (a:Type(ua) -> b:Type(ub) -> Type(u)) - we elaborate the type of - - C1 to x:a -> y:Type(uy) -> T a y - C2 to x:a -> z:Type(uz) -> w:Type(uw) -> T a z - - Let the elaborated type of constructor i be of the form - xs:ts_i -> ti - - For each constructor i, we check - - - G, [xs:ts_i]_j |- ts_i_j : Type(u_i_j) - - u_i_j <= u - - G, [xs:ts_i] |- ti : Type _ - - ti is an instance of T a - - - (3). We jointly generalize the term - - (a:Type(ua) -> b:Type(ub) -> Type u) - -> (xs:ts_1 -> t1) - -> (xs:ts_2 -> t2) - -> unit - - computing - - (uvs, (a:Type(ua') -> b:Type(ub') -> Type u') - -> (xs:ts_1' -> t1') - -> (xs:ts_2' -> t2') - -> unit) - - The inductive is generalized to - - T (a:Type(ua')) : b:Type(ub') -> Type u' - - - (4). We re-typecheck and elaborate the type of each constructor to - capture the proper instantiations of T - - i.e., we check - - G, T : a:Type(ua') -> b:Type(ub') -> Type u', uvs |- - xs:ts_i' -> t_i' - ~> xs:ts_i'' -> t_i'' - - - What we get, in effect, is - - type T (a:Type(ua)) : Type(ub) -> Type (max ua (ub + 1) (uw + 1)) = - | C1 : (ua, ub, uw) => a:Type(ua) -> y:Type(ub) -> T a y - | C2 : (ua, ub, uw) => a:Type(ua) -> z:Type(ub) -> w:Type(uw) -> T a z - *) - let tys, datas = ses |> List.partition (function { sigel = Sig_inductive_typ _ } -> true | _ -> false) in - if datas |> BU.for_some (function { sigel = Sig_datacon _ } -> false | _ -> true) - then raise_error env Errors.Fatal_NonInductiveInMutuallyDefinedType "Mutually defined type contains a non-inductive element"; - - //AR: adding this code for the second phase - // univs need not be empty - // we record whether the universes were already annotated - // and later use it to decide if we should generalize - let univs = - if List.length tys = 0 then [] - else - match (List.hd tys).sigel with - | Sig_inductive_typ {us=uvs} -> uvs - | _ -> failwith "Impossible, can't happen!" - in - - let env0 = env in - - (* Check each tycon *) - let env, tcs, g = List.fold_right (fun tc (env, all_tcs, g) -> - let env, tc, tc_u, guard = tc_tycon env tc in - let g' = Rel.universe_inequality S.U_zero tc_u in - if Debug.low () then BU.print1 "Checked inductive: %s\n" (show tc); - env, (tc, tc_u)::all_tcs, Env.conj_guard g (Env.conj_guard guard g') - ) tys (env, [], Env.trivial_guard) - in - (* Try to solve some implicits. See issue #3130. *) - let g = Rel.resolve_implicits env g in - - (* Check each datacon *) - let datas, g = List.fold_right (fun se (datas, g) -> - let data, g' = tc_data env tcs se in - data::datas, Env.conj_guard g g' - ) datas ([], g) - in - - (* Generalize their universes if not already annotated *) - let tcs, datas = - let tc_universe_vars = List.map snd tcs in - let g = {g with univ_ineqs = Class.Listlike.from_list (tc_universe_vars), snd (g.univ_ineqs)} in - - if !dbg_GenUniverses - then BU.print1 "@@@@@@Guard before (possible) generalization: %s\n" (Rel.guard_to_string env g); - - Rel.force_trivial_guard env0 g; - if List.length univs = 0 then generalize_and_inst_within env0 tcs datas - else (List.map fst tcs), datas - in - - (* In any of the tycons had their typed declared using `val`, - check that the declared and inferred types are compatible *) - - (* Also copy the binder attributes from val type parameters - to tycon type parameters *) - - let tcs = tcs |> List.map (fun se -> - match se.sigel with - | Sig_inductive_typ {lid=l;us=univs;params=binders;num_uniform_params=num_uniform;t=typ; - mutuals=ts;ds} -> - let fail expected inferred = - raise_error se Errors.Fatal_UnexpectedInductivetype - (BU.format2 "Expected an inductive with type %s; got %s" - (Print.tscheme_to_string expected) - (Print.tscheme_to_string inferred)) - in - // - //binders are the binders in Sig_inductive - //expected is the val type - //this function then copies attributes from val binders to Sig_inductive binders - // and returns new binders - //helps later to check strict positivity - // - let copy_binder_attrs_from_val binders expected = - // - // AR: A note on opening: - // get_n_binders opens some of the expected binders - // we end up throwing them, we are only interested in attrs - // binders remain as they are, we only change attributes there - // - let expected_attrs = - N.get_n_binders env (List.length binders) expected - |> fst - |> List.map (fun {binder_attrs=attrs; binder_positivity=pqual} -> attrs, pqual) in - if List.length expected_attrs <> List.length binders - then raise_error se - Errors.Fatal_UnexpectedInductivetype - (BU.format2 "Could not get %s type parameters from val type %s" - (binders |> List.length |> string_of_int) - (show expected)) - else List.map2 (fun (ex_attrs, pqual) b -> - if not (Common.check_positivity_qual true pqual b.binder_positivity) - then raise_error b Errors.Fatal_UnexpectedInductivetype "Incompatible positivity annotation"; - {b with binder_attrs = b.binder_attrs@ex_attrs; binder_positivity=pqual} - ) expected_attrs binders - in - let inferred_typ_with_binders binders = - let body = - match binders with - | [] -> typ - | _ -> S.mk (Tm_arrow {bs=binders; comp=S.mk_Total typ}) se.sigrng - in - (univs, body) - in - begin match Env.try_lookup_val_decl env0 l with - | None -> se - | Some (expected_typ, _) -> - if List.length univs = List.length (fst expected_typ) - then let _, expected = Subst.open_univ_vars univs (snd expected_typ) in - let binders = copy_binder_attrs_from_val binders expected in - let inferred_typ = inferred_typ_with_binders binders in - let _, inferred = Subst.open_univ_vars univs (snd inferred_typ) in - - // - // AR: Shouldn't we push opened universes to env0? - // - if Rel.teq_nosmt_force env0 inferred expected - then begin - {se with sigel=Sig_inductive_typ {lid=l; - us=univs; - params=binders; - num_uniform_params=num_uniform; - t=typ; - mutuals=ts; - ds; - injective_type_params=false}} - end - else fail expected_typ inferred_typ - else fail expected_typ (inferred_typ_with_binders binders) - end - | _ -> se) in - - let tcs = tcs |> List.map (check_sig_inductive_injectivity_on_params env0) in - let is_injective l = - match - List.tryPick - (fun se -> - let Sig_inductive_typ {lid=lid; injective_type_params} = se.sigel in - if lid_equals l lid then Some injective_type_params else None) - tcs - with - | None -> false - | Some i -> i - in - let datas = - datas |> - List.map - (fun se -> - let Sig_datacon dd = se.sigel in - { se with sigel=Sig_datacon { dd with injective_type_params=is_injective dd.ty_lid }}) - in - let sig_bndle = { sigel = Sig_bundle {ses=tcs@datas; lids}; - sigquals = quals; - sigrng = Env.get_range env0; - sigmeta = default_sigmeta; - sigattrs = List.collect (fun s -> s.sigattrs) ses; - sigopts = None; - sigopens_and_abbrevs=[] } in - - sig_bndle, tcs, datas - - -(******************************************************************************) -(* *) -(* Elaboration of the projectors *) -(* *) -(******************************************************************************) - -//for these types we don't generate projectors, discriminators, and hasEq axioms -let early_prims_inductives = [ "empty"; "trivial"; "equals"; "pair"; "sum" ] - -let mk_discriminator_and_indexed_projectors iquals (* Qualifiers of the envelopping bundle *) - (attrs:list attribute) (* Attributes of the envelopping bundle *) - (fvq:fv_qual) (* *) - (refine_domain:bool) (* If true, discriminates the projectee *) - env (* *) - (tc:lident) (* Type constructor name *) - (lid:lident) (* Constructor name *) - (uvs:univ_names) (* Original universe names *) - (inductive_tps:binders) (* Type parameters of the type constructor *) - (indices:binders) (* Implicit type parameters *) - (fields:binders) (* Fields of the constructor *) - (erasable:bool) (* Generate ghost discriminators and projectors *) - : list sigelt = - let p = range_of_lid lid in - let pos q = Syntax.withinfo q p in - let projectee ptyp = S.gen_bv "projectee" (Some p) ptyp in - let inst_univs = List.map (fun u -> U_name u) uvs in - let tps = inductive_tps in //List.map2 (fun (x,_) (_,imp) -> ({x,imp)) implicit_tps inductive_tps in - let arg_typ = - let inst_tc = S.mk (Tm_uinst (S.fv_to_tm (S.lid_as_fv tc None), inst_univs)) p in - let args = tps@indices |> List.map U.arg_of_non_null_binder in - S.mk_Tm_app inst_tc args p - in - let unrefined_arg_binder = S.mk_binder (projectee arg_typ) in - let arg_binder = - if not refine_domain - then unrefined_arg_binder //records have only one constructor; no point refining the domain - else let disc_name = U.mk_discriminator lid in - let x = S.new_bv (Some p) arg_typ in - let sort = - let disc_fvar = S.fvar_with_dd (Ident.set_lid_range disc_name p) None in - U.refine x (U.b2t (S.mk_Tm_app (S.mk_Tm_uinst disc_fvar inst_univs) [as_arg <| S.bv_to_name x] p)) - in - S.mk_binder ({projectee arg_typ with sort = sort}) - in - - - let ntps = List.length tps in - let all_params = List.map (fun b -> {b with binder_qual=Some S.imp_tag}) tps @ fields in - - let imp_binders = tps @ indices |> List.map (fun b -> {b with binder_qual=mk_implicit b.binder_qual}) in - - let early_prims_inductive = - lid_equals C.prims_lid (Env.current_module env) && - List.existsb (fun s -> s = (string_of_id (ident_of_lid tc))) early_prims_inductives - in - - let discriminator_ses = - if fvq <> Data_ctor - then [] // We do not generate discriminators for record types - else - let discriminator_name = U.mk_discriminator lid in - let no_decl = false in - let only_decl = - early_prims_inductive || - U.has_attribute attrs C.no_auto_projectors_attr - in - let quals = - (* KM : What about Logic ? should it still be there even with an implementation *) - S.Discriminator lid :: - (if only_decl then [S.Logic; S.Assumption] else []) @ - //(if only_decl && (not <| env.is_iface || env.admit) then [S.Assumption] else []) @ - List.filter (function S.Inline_for_extraction | S.NoExtract | S.Private -> true | _ -> false ) iquals - in - - (* Type of the discriminator *) - let binders = imp_binders@[unrefined_arg_binder] in - let t = - let bool_typ = - if erasable - then S.mk_GTotal U.t_bool - else S.mk_Total U.t_bool - in - SS.close_univ_vars uvs <| U.arrow binders bool_typ - in - let decl = { sigel = Sig_declare_typ {lid=discriminator_name; us=uvs; t}; - sigquals = quals; - sigrng = range_of_lid discriminator_name; - sigmeta = default_sigmeta; - sigattrs = attrs; - sigopts = None; - sigopens_and_abbrevs=[] } in - if !dbg_LogTypes - then BU.print1 "Declaration of a discriminator %s\n" (show decl); - - if only_decl - then [decl] - else - (* Term of the discriminator *) - let body = - if not refine_domain - then U.exp_true_bool // If we have at most one constructor - else - let arg_pats = all_params |> List.mapi (fun j ({binder_bv=x;binder_qual=imp}) -> - let b = S.is_bqual_implicit imp in - if b && j < ntps - then pos (Pat_dot_term None), b - else pos (Pat_var (S.gen_bv (string_of_id x.ppname) None tun)), b) - in - let pat_true = pos (S.Pat_cons (S.lid_as_fv lid (Some fvq), None, arg_pats)), None, U.exp_true_bool in - let pat_false = pos (Pat_var (S.new_bv None tun)), None, U.exp_false_bool in - let arg_exp = S.bv_to_name unrefined_arg_binder.binder_bv in - mk (Tm_match {scrutinee=arg_exp; - ret_opt=None; - brs=[U.branch pat_true ; U.branch pat_false]; - rc_opt=None}) p - in - let imp = U.abs binders body None in - let lbtyp = if no_decl then t else tun in - let lb = U.mk_letbinding - (Inr (S.lid_and_dd_as_fv discriminator_name None)) - uvs - lbtyp - C.effect_Tot_lid - (SS.close_univ_vars uvs imp) - [] - Range.dummyRange - in - let impl = { sigel = Sig_let {lbs=(false, [lb]); lids=[lb.lbname |> right |> (fun fv -> fv.fv_name.v)]}; - sigquals = quals; - sigrng = p; - sigmeta = default_sigmeta; - sigattrs = attrs; - sigopts = None; - sigopens_and_abbrevs=[] } in - if !dbg_LogTypes - then BU.print1 "Implementation of a discriminator %s\n" (show impl); - (* TODO : Are there some cases where we don't want one of these ? *) - (* If not the declaration is useless, isn't it ?*) - [decl ; impl] - in - - - let arg_exp = S.bv_to_name arg_binder.binder_bv in - let binders = imp_binders@[arg_binder] in - let arg = U.arg_of_non_null_binder arg_binder in - - let subst = fields |> List.mapi (fun i ({binder_bv=a}) -> - let field_name = U.mk_field_projector_name lid a i in - let field_proj_tm = mk_Tm_uinst (S.fv_to_tm (S.lid_as_fv field_name None)) inst_univs in - let proj = mk_Tm_app field_proj_tm [arg] p in - NT(a, proj)) - in - - let projectors_ses = - if U.has_attribute attrs C.no_auto_projectors_decls_attr - || U.has_attribute attrs C.meta_projectors_attr - then [] - else - fields |> List.mapi (fun i ({binder_bv=x}) -> - let p = S.range_of_bv x in - let field_name = U.mk_field_projector_name lid x i in - let result_comp = - let t = Subst.subst subst x.sort in - if erasable - then S.mk_GTotal t - else S.mk_Total t in - let t = SS.close_univ_vars uvs <| U.arrow binders result_comp in - let only_decl = - early_prims_inductive || - U.has_attribute attrs C.no_auto_projectors_attr - in - (* KM : Why would we want to prevent a declaration only in this particular case ? *) - (* TODO : If we don't want the declaration then we need to propagate the right types in the patterns *) - let no_decl = false (* Syntax.is_type x.sort *) in - let quals q = - if only_decl - then S.Assumption::q - else q - in - let quals = - let iquals = iquals |> List.filter (function - | S.Inline_for_extraction - | S.NoExtract - | S.Private -> true - | _ -> false) - in - quals (S.Projector(lid, x.ppname)::iquals) in - let attrs = (if only_decl then [] else [ U.attr_substitute ])@attrs in - let decl = { sigel = Sig_declare_typ {lid=field_name; us=uvs; t}; - sigquals = quals; - sigrng = range_of_lid field_name; - sigmeta = default_sigmeta; - sigattrs = attrs; - sigopts = None; - sigopens_and_abbrevs=[] } in - if !dbg_LogTypes - then BU.print1 "Declaration of a projector %s\n" (show decl); - if only_decl - then [decl] //only the signature - else - let projection = S.gen_bv (string_of_id x.ppname) None tun in - let arg_pats = all_params |> List.mapi (fun j ({binder_bv=x;binder_qual=imp}) -> - let b = S.is_bqual_implicit imp in - if i+ntps=j //this is the one to project - then pos (Pat_var projection), b - else if b && j < ntps - then pos (Pat_dot_term None), b - else pos (Pat_var (S.gen_bv (string_of_id x.ppname) None tun)), b) - in - let pat = pos (S.Pat_cons (S.lid_as_fv lid (Some fvq), None, arg_pats)), None, S.bv_to_name projection in - let body = - let return_bv = S.gen_bv "proj_ret" (Some p) S.tun in - let result_typ = result_comp - |> U.comp_result - |> SS.subst [NT (arg_binder.binder_bv, S.bv_to_name return_bv)] - |> SS.close [S.mk_binder return_bv] in - let return_binder = List.hd (SS.close_binders [S.mk_binder return_bv]) in - let returns_annotation = - let use_eq = true in - Some (return_binder, (Inl result_typ, None, use_eq)) in - mk (Tm_match {scrutinee=arg_exp; - ret_opt=returns_annotation; - brs=[U.branch pat]; - rc_opt=None}) p in - let imp = U.abs binders body None in - let dd = Delta_equational_at_level 1 in - let lbtyp = if no_decl then t else tun in - let lb = { - lbname=Inr (S.lid_and_dd_as_fv field_name None); - lbunivs=uvs; - lbtyp=lbtyp; - lbeff=C.effect_Tot_lid; - lbdef=SS.close_univ_vars uvs imp; - lbattrs=[]; - lbpos=Range.dummyRange; - } in - let impl = { sigel = Sig_let {lbs=(false, [lb]); lids=[lb.lbname |> right |> (fun fv -> fv.fv_name.v)]}; - sigquals = quals; - sigrng = p; - sigmeta = default_sigmeta; - sigattrs = attrs; - sigopts = None; - sigopens_and_abbrevs=[] } in - if !dbg_LogTypes - then BU.print1 "Implementation of a projector %s\n" (show impl); - if no_decl then [impl] else [decl;impl]) |> List.flatten - in - (* We remove the plugin attribute from these generated definitions. - We do not want to pay an embedding/unembedding to use them, and we don't - want warning about unfolding something that is a plugin *) - let no_plugin (se:sigelt) : sigelt = - let not_plugin_attr (t:term) : bool = - let h = U.head_of t in - not (U.is_fvar C.plugin_attr h) - in - { se with sigattrs = List.filter not_plugin_attr se.sigattrs } - in - List.map no_plugin (discriminator_ses @ projectors_ses) - -let mk_data_operations iquals attrs env tcs se = - match se.sigel with - | Sig_datacon {lid=constr_lid; us=uvs; t; ty_lid=typ_lid; num_ty_params=n_typars} -> - - let univ_opening, uvs = SS.univ_var_opening uvs in - let t = SS.subst univ_opening t in - let formals, _ = U.arrow_formals t in - - let inductive_tps, typ0, should_refine = - let tps_opt = BU.find_map tcs (fun se -> - if lid_equals typ_lid (must (U.lid_of_sigelt se)) - then match se.sigel with - | Sig_inductive_typ {us=uvs'; params=tps; t=typ0; ds=constrs} -> - assert (List.length uvs = List.length uvs') ; - Some (tps, typ0, List.length constrs > 1) - | _ -> failwith "Impossible" - else None) - in - match tps_opt with - | Some x -> x - | None -> - if lid_equals typ_lid C.exn_lid - then [], U.ktype0, true - else raise_error se Errors.Fatal_UnexpectedDataConstructor "Unexpected data constructor" - in - - let inductive_tps = SS.subst_binders univ_opening inductive_tps in - let typ0 = SS.subst //shift the universe substitution by number of type parameters - (SS.shift_subst (List.length inductive_tps) univ_opening) - typ0 in - let indices, _ = U.arrow_formals typ0 in - - let refine_domain = - if se.sigquals |> BU.for_some (function RecordConstructor _ -> true | _ -> false) - then false - else should_refine - in - - let fv_qual = - let filter_records = function - | RecordConstructor (_, fns) -> Some (Record_ctor(typ_lid, fns)) - | _ -> None - in match BU.find_map se.sigquals filter_records with - | None -> Data_ctor - | Some q -> q - in - - let fields = - let imp_tps, fields = BU.first_N n_typars formals in - let rename = List.map2 (fun ({binder_bv=x}) ({binder_bv=x'}) -> S.NT(x, S.bv_to_name x')) imp_tps inductive_tps in - SS.subst_binders rename fields - in - let erasable = U.has_attribute se.sigattrs FStar.Parser.Const.erasable_attr in - mk_discriminator_and_indexed_projectors - iquals attrs fv_qual refine_domain - env typ_lid constr_lid uvs - inductive_tps indices fields erasable - - | _ -> [] diff --git a/src/typechecker/FStar.TypeChecker.TcInductive.fsti b/src/typechecker/FStar.TypeChecker.TcInductive.fsti deleted file mode 100644 index 650d525bddf..00000000000 --- a/src/typechecker/FStar.TypeChecker.TcInductive.fsti +++ /dev/null @@ -1,42 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.TypeChecker.TcInductive -open FStar.Compiler.Effect -open FStar -open FStar.Compiler -open FStar.TypeChecker -open FStar.TypeChecker.Env -open FStar.Compiler.Util -open FStar.Ident -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.Syntax.Subst -open FStar.Syntax.Util -open FStar.Const -open FStar.TypeChecker.Rel -open FStar.TypeChecker.Common - -val check_inductive_well_typedness: env_t -> list sigelt -> list qualifier -> list lident -> (sigelt & list sigelt & list sigelt) - -val early_prims_inductives :list string - -val is_haseq_lid: lid -> bool //see if the given lid is that of an haseq axiom -val get_haseq_axiom_lid: lid -> lid //for the given inductive tycon lid, get the haseq axiom lid -val optimized_haseq_scheme: sigelt -> list sigelt -> list sigelt -> env_t -> list sigelt -val unoptimized_haseq_scheme: sigelt -> list sigelt -> list sigelt -> env_t -> list sigelt - -val mk_data_operations: list qualifier -> list attribute -> env -> list sigelt -> sigelt -> list sigelt //elaborate discriminator and projectors diff --git a/src/typechecker/FStar.TypeChecker.TcTerm.fst b/src/typechecker/FStar.TypeChecker.TcTerm.fst deleted file mode 100644 index 35f9e38b193..00000000000 --- a/src/typechecker/FStar.TypeChecker.TcTerm.fst +++ /dev/null @@ -1,4940 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.TypeChecker.TcTerm -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.Errors -open FStar.Defensive -open FStar.TypeChecker -open FStar.TypeChecker.Common -open FStar.TypeChecker.Env -open FStar.Compiler.Util -open FStar.Ident -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.Syntax.Subst -open FStar.Syntax.Util -open FStar.Const -open FStar.Dyn -open FStar.TypeChecker.Rel - -open FStar.Class.Show -open FStar.Class.PP -open FStar.Class.Tagged -open FStar.Class.Setlike -open FStar.Class.Monoid - -module S = FStar.Syntax.Syntax -module SS = FStar.Syntax.Subst -module TcComm = FStar.TypeChecker.Common -module N = FStar.TypeChecker.Normalize -module TcUtil = FStar.TypeChecker.Util -module Gen = FStar.TypeChecker.Generalize -module BU = FStar.Compiler.Util -module U = FStar.Syntax.Util -module PP = FStar.Syntax.Print -module UF = FStar.Syntax.Unionfind -module Const = FStar.Parser.Const -module TEQ = FStar.TypeChecker.TermEqAndSimplify - -let dbg_Exports = Debug.get_toggle "Exports" -let dbg_LayeredEffects = Debug.get_toggle "LayeredEffects" -let dbg_NYC = Debug.get_toggle "NYC" -let dbg_Patterns = Debug.get_toggle "Patterns" -let dbg_Range = Debug.get_toggle "Range" -let dbg_RelCheck = Debug.get_toggle "RelCheck" -let dbg_RFD = Debug.get_toggle "RFD" -let dbg_Tac = Debug.get_toggle "Tac" -let dbg_UniverseOf = Debug.get_toggle "UniverseOf" - -(* Some local utilities *) -let instantiate_both env = {env with Env.instantiate_imp=true} -let no_inst env = {env with Env.instantiate_imp=false} - -let is_eq = function - | Some Equality -> true - | _ -> false -let steps env = [Env.Beta; Env.Eager_unfolding; Env.NoFullNorm; Env.Exclude Env.Zeta] -let norm env t = N.normalize (steps env) env t -let norm_c env c = N.normalize_comp (steps env) env c - -(* Checks that the variables in `fvs` do not appear in the free vars of `t`. -The environment `env` must not contain fvs in its gamma for this to work properly. *) -let check_no_escape (head_opt : option term) - (env : Env.env) - (fvs:list bv) - (kt : term) -: term & guard_t -= - Errors.with_ctx "While checking for escaped variables" (fun () -> - let fail (x:bv) = - let open FStar.Pprint in - let msg = - match head_opt with - | None -> [ - text "Bound variable" ^/^ squotes (pp x) - ^/^ text "would escape in the type of this letbinding"; - text "Add a type annotation that does not mention it"; - ] - | Some head -> [ - text "Bound variable" ^/^ squotes (pp x) - ^/^ text "escapes because of impure applications in the type of" - ^/^ squotes (N.term_to_doc env head); - text "Add explicit let-bindings to avoid this"; - ] - in - raise_error env Errors.Fatal_EscapedBoundVar msg - in - match fvs with - | [] -> kt, mzero - | _ -> - let rec aux try_norm t = - let t = if try_norm then norm env t else t in - let fvs' = Free.names t in - match List.tryFind (fun x -> mem x fvs') fvs with - | None -> t, mzero - | Some x -> - (* some variable x seems to escape, try normalizing if we haven't *) - if not try_norm - then aux true (norm env t) - else - (* if it still appears, try using the unifier to equate 't' to a uvar - created in the "short" env, which cannot mention any of the fvs. If any exception - is raised, we just report that 'x' escapes. Since we're calling try_teq with - SMT disabled it should not log an error. *) - try - let env_extended = Env.push_bvs env fvs in - let s, _, g0 = TcUtil.new_implicit_var "no escape" (Env.get_range env) env (fst <| U.type_u()) false in - match Rel.try_teq false env_extended t s with - | Some g -> - let g = Rel.solve_deferred_constraints env_extended (g ++ g0) in - s, g - | _ -> fail x - with - | _ -> fail x - in - aux false kt - ) - -(* - check_expected_aqual_for_binder: - - This is used to check an application. - - Given val f (#[@@@ att] x:t) : t' - - the user is expected to write f #a to apply f, matching the - implicit qualifier at the binding site. - - However, they do not (and cannot, there's no syntax for it) provide - the attributes of the binding site at the application site. - - So, this function checks that the implicit flags match and takes - the attributes from the binding site, i.e., expected_aq. -*) -let check_expected_aqual_for_binder (aq:aqual) (b:binder) (pos:Range.range) : aqual = - match - let expected_aq = U.aqual_of_binder b in - match aq, expected_aq with - | None, None -> Inr aq - | None, Some eaq -> - if eaq.aqual_implicit //programmer should have written # - then Inl "expected implicit annotation on the argument" - else Inr expected_aq //keep the attributes - | Some aq, None -> - Inl "expected an explicit argument (without annotation)" - | Some aq, Some eaq -> - if aq.aqual_implicit <> eaq.aqual_implicit - then Inl "mismatch" - else Inr expected_aq //keep the attributes - with - | Inl err -> - let open FStar.Pprint in - let msg = [ - Errors.Msg.text ("Inconsistent argument qualifiers: " ^ err ^ "."); - ] in - raise_error pos Errors.Fatal_InconsistentImplicitQualifier msg - | Inr r -> r - -let check_erasable_binder_attributes env attrs (binder_ty:typ) = - attrs |> - List.iter - (fun attr -> - if U.is_fvar Const.erasable_attr attr - && not (N.non_info_norm env binder_ty) - then raise_error attr Errors.Fatal_QulifierListNotPermitted - ("Incompatible attributes: an erasable attribute on a binder must bind a name at an non-informative type")) - -let push_binding env b = - Env.push_bv env b.binder_bv - -let maybe_extend_subst s b v : subst_t = - if is_null_binder b then s - else NT(b.binder_bv, v)::s - -let set_lcomp_result lc t = - TcComm.apply_lcomp - (fun c -> U.set_result_typ c t) (fun g -> g) ({ lc with res_typ = t }) - -let memo_tk (e:term) (t:typ) = e - -let maybe_warn_on_use env fv : unit = - match Env.lookup_attrs_of_lid env fv.fv_name.v with - | None -> () - | Some attrs -> - attrs |> - List.iter - (fun a -> - let head, args = U.head_and_args a in - let msg_arg m = - match args with - | [{n=Tm_constant (Const_string (s, _))}, _] -> - m @ [Errors.text s] - | _ -> - m - in - match head.n with - | Tm_fvar attr_fv - when lid_equals attr_fv.fv_name.v Const.warn_on_use_attr -> - let m = - Errors.text <| - BU.format1 "Every use of %s triggers a warning" - (Ident.string_of_lid fv.fv_name.v) - in - log_issue fv.fv_name.v Warning_WarnOnUse (msg_arg [m]) - - | Tm_fvar attr_fv - when lid_equals attr_fv.fv_name.v Const.deprecated_attr -> - let m = - Errors.text <| - BU.format1 - "%s is deprecated" - (Ident.string_of_lid fv.fv_name.v) - in - log_issue fv.fv_name.v Warning_DeprecatedDefinition (msg_arg [m]) - - | _ -> ()) - -//Interface to FStar.TypeChecker.Rel: - -(************************************************************************************************************) -(* value_check_expected_type env e tlc g *) -(* e is computed to have type or computation type, tlc *) -(* subject to the guard g *) -(* This function compares tlc to the expected type from the context, augmenting the guard if needed *) -(************************************************************************************************************) -let value_check_expected_typ env (e:term) (tlc:either term lcomp) (guard:guard_t) - : term & lcomp & guard_t = - def_check_scoped e.pos "value_check_expected_typ" env guard; - let lc = match tlc with - | Inl t -> TcComm.lcomp_of_comp <| mk_Total t - | Inr lc -> lc in - let t = lc.res_typ in - let e, lc, g = - match Env.expected_typ env with - | None -> memo_tk e t, lc, guard - | Some (t', use_eq) -> - let e, lc, g = TcUtil.check_has_type_maybe_coerce env e lc t' use_eq in - if Debug.medium () - then BU.print4 "value_check_expected_typ: type is %s<:%s \tguard is %s, %s\n" - (TcComm.lcomp_to_string lc) (show t') - (Rel.guard_to_string env g) (Rel.guard_to_string env guard); - let t = lc.res_typ in - let g = g ++ guard in - (* adding a guard for confirming that the computed type t is a subtype of the expected type t' *) - let msg = if Env.is_trivial_guard_formula g then None else Some <| Err.subtyping_failed env t t' in - let lc, g = TcUtil.strengthen_precondition msg env e lc g in - memo_tk e t', set_lcomp_result lc t', g - in - e, lc, g - -(************************************************************************************************************) -(* comp_check_expected_type env e lc g *) -(* similar to value_check_expected_typ, except this time e is a non-value *) -(************************************************************************************************************) -let comp_check_expected_typ env e lc : term & lcomp & guard_t = - match Env.expected_typ env with - | None -> e, lc, mzero - | Some (t, use_eq) -> - let e, lc, g_c = TcUtil.maybe_coerce_lc env e lc t in - let e, lc, g = TcUtil.weaken_result_typ env e lc t use_eq in - e, lc, g ++ g_c - -(************************************************************************************************************) -(* check_expected_effect: triggers a sub-effecting, WP implication, etc. if needed *) -(************************************************************************************************************) -let check_expected_effect env (use_eq:bool) (copt:option comp) (ec : term & comp) - : term & comp & guard_t = - let e, c = ec in - let tot_or_gtot c = //expects U.is_pure_or_ghost_comp c - if U.is_pure_comp c - then mk_Total (U.comp_result c) - else if U.is_pure_or_ghost_comp c - then mk_GTotal (U.comp_result c) - else failwith "Impossible: Expected pure_or_ghost comp" - in - - let expected_c_opt, c, gopt = - let ct = U.comp_result c in - match copt with - | Some _ -> copt, c, None //setting gopt to None since expected comp is already set, so we will do sub_comp below - | None -> - if (Options.ml_ish() - && Ident.lid_equals (Const.effect_ALL_lid()) (U.comp_effect_name c)) - || (Options.ml_ish () - && Options.lax () - && not (U.is_pure_or_ghost_comp c)) - then Some (U.ml_comp ct e.pos), c, None - else if U.is_tot_or_gtot_comp c //these are already the defaults for their particular effects - then None, tot_or_gtot c, None //but, force c to be exactly ((G)Tot t), since otherwise it may actually contain a return - else if U.is_pure_or_ghost_comp c - then Some (tot_or_gtot c), c, None - else let norm_eff_name = U.comp_effect_name c |> Env.norm_eff_name env in - if norm_eff_name |> Env.is_layered_effect env - then begin - // - //If the layered effect has a default effect annotation, - // use it - //We have already typechecked that the default effect - // only takes as argument the result type - // - let def_eff_opt = Env.get_default_effect env norm_eff_name in - match def_eff_opt with - | None -> - raise_error e Errors.Error_LayeredMissingAnnot //hard error if layered effects are used without annotations - (BU.format2 "Missing annotation for a layered effect (%s) computation at %s" - (c |> U.comp_effect_name |> show) - (show e.pos)) - | Some def_eff -> - // - //AR: TODO: it may be good hygiene to check that def_eff exists - // - let comp_univs, result_ty = - match c.n with - | Comp ({comp_univs=comp_univs; result_typ=result_ty}) -> - comp_univs, result_ty - | _ -> failwith "Impossible!" in - let expected_c = { - comp_univs = comp_univs; - effect_name = def_eff; - result_typ = result_ty; - effect_args = []; - flags = []} in - //let expected_c, _, _ = tc_comp env expected_c in - Some (S.mk_Comp expected_c), - c, - None - end - // Not a layered effect - else if Options.trivial_pre_for_unannotated_effectful_fns () - then None, c, (let _, _, g = TcUtil.check_trivial_precondition_wp env c in - Some g) - else None, c, None - in - def_check_scoped c.pos "check_expected_effect.c.before_norm" env c; - let c = Errors.with_ctx "While normalizing actual computation type in check_expected_effect" - (fun () -> norm_c env c) in - def_check_scoped c.pos "check_expected_effect.c.after_norm" env c; - match expected_c_opt with - | None -> - e, c, (match gopt with | None -> mzero | Some g -> g) - | Some expected_c -> //expected effects should already be normalized - let _ = match gopt with - | None -> () - | Some _ -> failwith "Impossible! check_expected_effect, gopt should have been None" - in - - let c = TcUtil.maybe_assume_result_eq_pure_term env e (TcComm.lcomp_of_comp c) in - let c, g_c = TcComm.lcomp_comp c in - def_check_scoped c.pos "check_expected_effect.c.after_assume" env c; - if Debug.medium () then - BU.print4 "In check_expected_effect, asking rel to solve the problem on e=(%s) and c=(%s), expected_c=(%s), and use_eq=%s\n" - (show e) - (show c) - (show expected_c) - (show use_eq); - let e, _, g = TcUtil.check_comp env use_eq e c expected_c in - let g = TcUtil.label_guard (Env.get_range env) (Errors.mkmsg "Could not prove post-condition") g in - if Debug.medium () - then BU.print2 "(%s) DONE check_expected_effect;\n\tguard is: %s\n" - (Range.string_of_range e.pos) - (guard_to_string env g); - let e = TcUtil.maybe_lift env e (U.comp_effect_name c) (U.comp_effect_name expected_c) (U.comp_result c) in - e, expected_c, g ++ g_c - -let no_logical_guard env (te, kt, f) = - match guard_form f with - | Trivial -> te, kt, f - | NonTrivial f -> Err.unexpected_non_trivial_precondition_on_term env f - -let print_expected_ty_str env = - match Env.expected_typ env with - | None -> "Expected type is None" - | Some (t, use_eq) -> - BU.format2 - "Expected type is (%s, use_eq = %s)" - (show t) - (string_of_bool use_eq) - - -let print_expected_ty env = BU.print1 "%s\n" (print_expected_ty_str env) - -(************************************************************************************************************) -(* check the patterns in an SMT lemma to make sure all bound vars are mentiond *) -(************************************************************************************************************) - -(* andlist: whether we're inside an SMTPatOr and we should take the - * intersection of the sub-variables instead of the union. *) -let rec get_pat_vars' all (andlist : bool) (pats:term) : FlatSet.t bv = - let pats = unmeta pats in - let head, args = head_and_args pats in - match (un_uinst head).n, args with - | Tm_fvar fv, _ when fv_eq_lid fv Const.nil_lid -> - if andlist - then from_list all - else empty () - - | Tm_fvar fv, [(_, Some ({ aqual_implicit = true })); (hd, None); (tl, None)] when fv_eq_lid fv Const.cons_lid -> - (* The head is not under the scope of the SMTPatOr, consider - * SMTPatOr [ [SMTPat p1; SMTPat p2] ; ... ] - * we should take the union of fv(p1) and fv(p2) *) - let hdvs = get_pat_vars' all false hd in - let tlvs = get_pat_vars' all andlist tl in - - if andlist - then inter hdvs tlvs - else union hdvs tlvs - - | Tm_fvar fv, [(_, Some ({ aqual_implicit = true })); (pat, None)] when fv_eq_lid fv Const.smtpat_lid -> - Free.names pat - - | Tm_fvar fv, [(subpats, None)] when fv_eq_lid fv Const.smtpatOr_lid -> - get_pat_vars' all true subpats - - | _ -> empty () - -let get_pat_vars all pats = get_pat_vars' all false pats - -let check_pat_fvs (rng:Range.range) env pats bs = - let pat_vars = get_pat_vars (List.map (fun b -> b.binder_bv) bs) (N.normalize [Env.Beta] env pats) in - begin match bs |> BU.find_opt (fun ({binder_bv=b}) -> not (mem b pat_vars)) with - | None -> () - | Some ({binder_bv=x}) -> - Errors.log_issue rng Errors.Warning_SMTPatternIllFormed - (BU.format1 "Pattern misses at least one bound variable: %s" (show x)) - end - -(* - * Check that term t (an smt pattern) does not contain theory symbols - * These symbols are fvs with attribute smt_theory_symbol from Prims - * and other terms such as abs, arrows etc. - *) -let check_no_smt_theory_symbols (en:env) (t:term) :unit = - let rec pat_terms (t:term) :list term = - let t = unmeta t in - let head, args = head_and_args t in - match (un_uinst head).n, args with - | Tm_fvar fv, _ when fv_eq_lid fv Const.nil_lid -> [] - | Tm_fvar fv, [_; (hd, _); (tl, _)] when fv_eq_lid fv Const.cons_lid -> - pat_terms hd @ pat_terms tl - | Tm_fvar fv, [_; (pat, _)] when fv_eq_lid fv Const.smtpat_lid -> [pat] - | Tm_fvar fv, [(subpats, None)] when fv_eq_lid fv Const.smtpatOr_lid -> - pat_terms subpats - | _ -> [] //TODO: should this be a hard error? - in - let rec aux (t:term) :list term = - match (SS.compress t).n with - //these cases are fine - | Tm_bvar _ | Tm_name _ | Tm_constant _ | Tm_type _ | Tm_uvar _ - | Tm_lazy _ | Tm_unknown -> [] - - //these should not be allowed in patterns - | Tm_abs _ | Tm_arrow _ | Tm_refine _ - | Tm_match _ | Tm_let _ | Tm_delayed _ | Tm_quoted _ -> [t] - - //these descend more in the term - | Tm_fvar fv -> - if Env.fv_has_attr en fv Const.smt_theory_symbol_attr_lid then [t] - else [] - - | Tm_app {hd=t; args} -> - List.fold_left (fun acc (t, _) -> - acc @ aux t) (aux t) args - - | Tm_ascribed {tm=t} - | Tm_uinst (t, _) - | Tm_meta {tm=t} -> aux t - in - let tlist = t |> pat_terms |> List.collect aux in - if List.length tlist = 0 then () //did not find any offending term - else - let open FStar.Pprint in - let open FStar.Class.PP in - //string to be displayed in the warning - Errors.log_issue t Errors.Warning_SMTPatternIllFormed [ - prefix 2 1 - (text "Pattern uses these theory symbols or terms that should not be in an SMT pattern:") - (group <| separate_map (comma ^^ break_ 1) pp tlist) - ] - -let check_smt_pat env t bs c = - if U.is_smt_lemma t //check patterns cover the bound vars - then match c.n with - | Comp ({effect_args=[_pre; _post; (pats, _)]}) -> - check_pat_fvs t.pos env pats bs; - check_no_smt_theory_symbols env pats - | _ -> failwith "Impossible: check_smt_pat: not Comp" - -(************************************************************************************************************) -(* Building the environment for the body of a let rec; *) -(* guards the recursively bound names with a termination check *) -(************************************************************************************************************) -let guard_letrecs env actuals expected_c : list (lbname&typ&univ_names) = - match env.letrecs with - | [] -> [] - | letrecs -> - let r = Env.get_range env in - let env = {env with letrecs=[]} in - - let decreases_clause bs c = - if Debug.low () - then BU.print2 "Building a decreases clause over (%s) and %s\n" - (show bs) (show c); - - //exclude types and function-typed arguments from the decreases clause - //and reveal and erased arguments - let filter_types_and_functions (bs:binders) = - let out_rev, env = - List.fold_left - (fun (out, env) binder -> - let b = binder.binder_bv in - let t = N.unfold_whnf env (U.unrefine b.sort) in - let env = Env.push_binders env [binder] in - match t.n with - | Tm_type _ - | Tm_arrow _ -> - (out, env) - | _ -> - let arg = S.bv_to_name b in - let arg = - match is_erased_head t with - | Some (u, ty) -> U.apply_reveal u ty arg - | _ -> arg - in - (arg::out, env)) - ([], env) - bs - in - List.rev out_rev - in - let cflags = U.comp_flags c in - match cflags |> List.tryFind (function DECREASES _ -> true | _ -> false) with - | Some (DECREASES d) -> d - | _ -> bs |> filter_types_and_functions |> Decreases_lex - in - - let precedes_t = TcUtil.fvar_env env Const.precedes_lid in - let rec mk_precedes_lex env l l_prev : term = - (* - * AR: aux assumes that l and l_prev have the same lengths - * Given l = [a; b; c], l_prev = [d; e; f], it builds: - * a << d \/ (eq3 a d /\ b << e) \/ (eq3 a d /\ eq3 b e /\ c << f - * We build an "untyped" term here, the caller will typecheck it properly - *) - let rec aux l l_prev : term = - let type_of (should_warn:bool) (e1:term) (e2:term) : typ & typ = - (* - * AR: we compute the types of e1 and e2 to provide type - * arguments to eq3 (otherwise F* may infer something that Z3 is unable - * to prove equal later on) - * as a check, if the types are not equal, we emit a warning so that - * the programmer may annotate explicitly if needed - *) - //AR: 03/30: WARNING: dropping the guard in computing t1 and t2 below - let t1 = env.typeof_well_typed_tot_or_gtot_term env e1 false |> fst |> U.unrefine in - let t2 = env.typeof_well_typed_tot_or_gtot_term env e2 false |> fst |> U.unrefine in - let rec warn t1 t2 = - if TEQ.eq_tm env t1 t2 = TEQ.Equal - then false - else match (SS.compress t1).n, (SS.compress t2).n with - | Tm_uinst (t1, _), Tm_uinst (t2, _) -> warn t1 t2 - | Tm_name _, Tm_name _ -> false //do not warn for names, e.g. in polymorphic functions, the names may be instantiated at the call sites - | Tm_app {hd=h1; args=args1}, Tm_app {hd=h2; args=args2} -> - warn h1 h2 || List.length args1 <> List.length args2 || - (List.zip args1 args2 |> List.existsML (fun ((a1, _), (a2, _)) -> warn a1 a2)) - | Tm_refine {b=t1; phi=phi1}, Tm_refine {b=t2; phi=phi2} -> - warn t1.sort t2.sort || warn phi1 phi2 - | Tm_uvar _, _ - | _, Tm_uvar _ -> false - | _, _ -> true in - - (if not env.phase1 && should_warn && warn t1 t2 - then match (SS.compress t1).n, (SS.compress t2).n with - | Tm_name _, Tm_name _ -> () - | _, _ -> - let open FStar.Pprint in - let open FStar.Class.PP in - Errors.log_issue e1 Errors.Warning_Defensive [ - prefix 2 1 (text "In the decreases clause for this function, the SMT solver may not be able to prove that the types of") - (group (pp e1 ^/^ parens (text "bound in" ^/^ pp e1.pos))) ^/^ - prefix 2 1 (text "and") - (group (pp e2 ^/^ parens (text "bound in" ^/^ pp e2.pos))) ^/^ - text "are equal."; - prefix 2 1 (text "The type of the first term is:") (pp t1); - prefix 2 1 (text "The type of the second term is:") (pp t2); - text "If the proof fails, try annotating these with the same type."; - ]); - t1, t2 in - - match l, l_prev with - | [], [] -> - mk_Tm_app precedes_t [as_arg S.unit_const; as_arg S.unit_const] r - | [x], [x_prev] -> - let t_x, t_x_prev = type_of false x x_prev in - mk_Tm_app precedes_t [iarg t_x; iarg t_x_prev; as_arg x; as_arg x_prev] r - | x::tl, x_prev::tl_prev -> - let t_x, t_x_prev = type_of true x x_prev in - let tm_precedes = mk_Tm_app precedes_t [ - iarg t_x; - iarg t_x_prev; - as_arg x; - as_arg x_prev ] r in - let eq3_x_x_prev = mk_eq3_no_univ t_x t_x_prev x x_prev in - - mk_disj tm_precedes - (mk_conj eq3_x_x_prev (aux tl tl_prev)) in - - (* Call aux with equal sized prefixes of l and l_prev *) - let l, l_prev = - let n, n_prev = List.length l, List.length l_prev in - if n = n_prev then l, l_prev - else if n < n_prev then l, l_prev |> List.splitAt n |> fst - else l |> List.splitAt n_prev |> fst, l_prev in - aux l l_prev in - - let mk_precedes (env:Env.env) d d_prev = - match d, d_prev with - | Decreases_lex l, Decreases_lex l_prev -> - mk_precedes_lex env l l_prev - | Decreases_wf (rel, e), Decreases_wf (rel_prev, e_prev) -> - (* - * For well-founded relations based termination checking, - * just prove that (rel e e_prev) - *) - let rel_guard = mk_Tm_app rel [as_arg e; as_arg e_prev] r in - if TEQ.eq_tm env rel rel_prev = TEQ.Equal - then rel_guard - else ( - (* if the relation is dependent on parameters in scope, - additionally prove that those parameters are invariant, - i.e., the rel and rel_prev are provably equal *) - let t_rel, _ = - Errors.with_ctx - ("Typechecking decreases well-founded relation") - (fun _ -> env.typeof_well_typed_tot_or_gtot_term env rel false) - in - let t_rel_prev, _ = - Errors.with_ctx - ("Typechecking previous decreases well-founded relation") - (fun _ -> env.typeof_well_typed_tot_or_gtot_term env rel_prev false) - in - let eq_guard = U.mk_eq3_no_univ t_rel t_rel_prev rel rel_prev in - U.mk_conj eq_guard rel_guard - ) - - | _, _ -> - Errors.raise_error r Errors.Fatal_UnexpectedTerm - "Cannot build termination VC with a well-founded relation and lex ordering" - in - - let previous_dec = decreases_clause actuals expected_c in - - let guard_one_letrec (l, arity, t, u_names) = - let formals, c = N.get_n_binders env arity t in - - (* This should never happen since `termination_check_enabled` - * takes care to not return an arity bigger than the one in - * the lbtyp. *) - if arity > List.length formals then - failwith "impossible: bad formals arity, guard_one_letrec"; - - //make sure they all have non-null names - let formals = formals |> List.map (fun b -> - if S.is_null_bv b.binder_bv - then ({b with binder_bv=S.new_bv (Some (S.range_of_bv b.binder_bv)) b.binder_bv.sort}) - else b) in - let dec = decreases_clause formals c in - let precedes = - let env = Env.push_binders env formals in - mk_precedes env dec previous_dec in - let precedes = TcUtil.label (Errors.mkmsg "Could not prove termination of this recursive call") r precedes in - let bs, ({binder_bv=last; binder_positivity=pqual; binder_attrs=attrs; binder_qual=imp}) = BU.prefix formals in - let last = {last with sort=U.refine last precedes} in - let refined_formals = bs@[S.mk_binder_with_attrs last imp pqual attrs] in - let t' = U.arrow refined_formals c in - if Debug.medium () - then BU.print3 "Refined let rec %s\n\tfrom type %s\n\tto type %s\n" - (show l) (show t) (show t'); - l, t', u_names - in - letrecs |> List.map guard_one_letrec - -let wrap_guard_with_tactic_opt topt g = - match topt with - | None -> g - | Some tactic -> - (* We use always_map_guard so the annotation is there even for trivial - * guards. If the user writes (a <: b by fail ""), we should fail. *) - Env.always_map_guard g (fun g -> - Common.mk_by_tactic tactic (U.mk_squash U_zero g)) //guards are in U_zero - - -(* - * This is pattern matching an `(M.reflect e) <: C` - * - * As we special case typechecking of such terms (as a subcase of `Tm_ascribed` in the main `tc_term` loop - * - * Returns the (e, arg_qualifier) and the lident of M - *) -let is_comp_ascribed_reflect (e:term) : option (lident & term & aqual) = - match (SS.compress e).n with - | Tm_ascribed {tm=e;asc=(Inr _, _, _)} -> - (match (SS.compress e).n with - | Tm_app {hd=head; args} when List.length args = 1 -> - (match (SS.compress head).n with - | Tm_constant (Const_reflect l) -> args |> List.hd |> (fun (e, aqual) -> (l, e, aqual)) |> Some - | _ -> None) - | _ -> None) - | _ -> None - - -(************************************************************************************************************) -(* Main type-checker begins here *) -(************************************************************************************************************) -let rec tc_term env e = - def_check_scoped e.pos "tc_term.entry" env e; - if Debug.medium () then - BU.print5 "(%s) Starting tc_term (phase1=%s) of %s (%s), %s {\n" - (Range.string_of_range <| Env.get_range env) - (string_of_bool env.phase1) - (show e) - (tag_of (SS.compress e)) - (print_expected_ty_str env); - - let r, ms = BU.record_time (fun () -> - tc_maybe_toplevel_term ({env with top_level=false}) e) in - if Debug.medium () then begin - BU.print4 "(%s) } tc_term of %s (%s) took %sms\n" (Range.string_of_range <| Env.get_range env) - (show e) - (tag_of (SS.compress e)) - (string_of_int ms); - let e, lc , _ = r in - BU.print4 "(%s) Result is: (%s:%s) (%s)\n" (Range.string_of_range <| Env.get_range env) - (show e) - (TcComm.lcomp_to_string lc) - (tag_of (SS.compress e)) - end; - r - -and tc_maybe_toplevel_term env (e:term) : term (* type-checked and elaborated version of e *) - & lcomp (* computation type where the WPs are lazily evaluated *) - & guard_t = (* well-formedness condition *) - let env = if e.pos=Range.dummyRange then env else Env.set_range env e.pos in - def_check_scoped e.pos "tc_maybe_toplevel_term.entry" env e; - let top = SS.compress e in - if Debug.medium () then - BU.print3 "Typechecking %s (%s): %s\n" (show <| Env.get_range env) (tag_of top) (show top); - match top.n with - | Tm_delayed _ -> failwith "Impossible" - | Tm_bvar _ -> failwith "Impossible: tc_maybe_toplevel_term: not LN" - - | Tm_uinst _ - | Tm_uvar _ - | Tm_name _ - | Tm_fvar _ - | Tm_constant _ - | Tm_abs _ - | Tm_arrow _ - | Tm_refine _ - | Tm_type _ - | Tm_unknown -> tc_value env e - - | Tm_quoted (qt, qi) -> - let projl = function - | Inl x -> x - | Inr _ -> failwith "projl fail" - in - let non_trivial_antiquotations qi = - let is_not_name t = - match (SS.compress t).n with - | Tm_name _ -> false - | _ -> true - in - BU.for_some is_not_name (snd qi.antiquotations) - in - begin match qi.qkind with - (* In this case, let-bind all antiquotations so we're sure that effects - * are properly handled. *) - | Quote_static when non_trivial_antiquotations qi -> - // FIXME: check shift=0 - let e0 = e in - let newbvs = List.map (fun _ -> S.new_bv None S.t_term) (snd qi.antiquotations) in - - let z = List.zip (snd qi.antiquotations) newbvs in - - let lbs = List.map (fun (t, bv') -> - U.close_univs_and_mk_letbinding None (Inl bv') [] - S.t_term Const.effect_Tot_lid - t [] t.pos) - z in - let qi = { qi with antiquotations = (0, List.map (fun (t, bv') -> S.bv_to_name bv') z) } in - let nq = mk (Tm_quoted (qt, qi)) top.pos in - let e = List.fold_left (fun t lb -> mk (Tm_let {lbs=(false, [lb]); - body=SS.close [S.mk_binder (projl lb.lbname)] t}) top.pos) nq lbs in - tc_maybe_toplevel_term env e - - (* A static quote is of type `term`, as long as its antiquotations are too *) - | Quote_static -> - (* Typecheck the antiquotations expecting a term *) - let aqs = snd qi.antiquotations in - let env_tm = Env.set_expected_typ env t_term in - let (aqs_rev, guard, _env) = - List.fold_left (fun (aqs_rev, guard, env_tm) aq_tm -> - let aq_tm, _, g = tc_term env_tm aq_tm in - let env_tm = Env.push_bv env_tm (S.new_bv None t_term) in - (aq_tm::aqs_rev, g ++ guard, env_tm)) - ([], mzero, env_tm) aqs - in - let qi = { qi with antiquotations = (0, List.rev aqs_rev) } in - - let tm = mk (Tm_quoted (qt, qi)) top.pos in - value_check_expected_typ env tm (Inl S.t_term) guard - - | Quote_dynamic -> - let c = mk_Tac S.t_term in - - (* Typechecked the quoted term just to elaborate it *) - let env', _ = Env.clear_expected_typ env in - let env' = { env' with admit = true } in - let qt, _, g = tc_term env' qt in - let g0 = { g with guard_f = Trivial } in //explicitly dropping the logical guard; this is just a quotation - let g0 = Rel.resolve_implicits env' g0 in - - - let t = mk (Tm_quoted (qt, qi)) top.pos in - - let t, lc, g = value_check_expected_typ env t (Inr (TcComm.lcomp_of_comp c)) mzero in - let t = mk (Tm_meta {tm=t; - meta=Meta_monadic_lift (Const.effect_PURE_lid, Const.effect_TAC_lid, S.t_term)}) - t.pos in - t, lc, g ++ g0 - end - - | Tm_lazy ({lkind=Lazy_embedding _ }) -> - tc_term env (U.unlazy top) - - // lazy terms have whichever type they're annotated with - | Tm_lazy i -> - value_check_expected_typ env top (Inl i.ltyp) mzero - - | Tm_meta {tm=e; meta=Meta_desugared Meta_smt_pat} -> - let e, c, g = tc_tot_or_gtot_term env e in - let g = {g with guard_f=Trivial} in //VC's in SMT patterns are irrelevant - mk (Tm_meta {tm=e; meta=Meta_desugared Meta_smt_pat}) top.pos, c, g //AR: keeping the pats as meta for the second phase. smtencoding does an unmeta. - - | Tm_meta {tm=e; meta=Meta_pattern(names, pats)} -> - let t, u = U.type_u () in - let e, c, g = tc_check_tot_or_gtot_term env e t None in - //NS: PATTERN INFERENCE - //if `pats` is empty (that means the user did not annotate a pattern). - //In that case try to infer a pattern by - //analyzing `e` for the smallest terms that contain all the variables - //in `names`. - //If not pattern can be inferred, raise a warning - let pats, g' = - let env, _ = Env.clear_expected_typ env in - tc_smt_pats env pats in - let g' = {g' with guard_f=Trivial} in //The pattern may have some VCs associated with it, but these are irrelevant. - mk (Tm_meta {tm=e; meta=Meta_pattern(names, pats)}) top.pos, - c, - g ++ g' //but don't drop g' altogether, since it also contains unification constraints - - | Tm_meta {tm=e; meta=Meta_desugared Sequence} -> - // - // Sequence is only relevant for pretty printing - // - let e, c, g = tc_term env e in - let e = mk (Tm_meta {tm=e; meta=Meta_desugared Sequence}) top.pos in - e, c, g - - | Tm_meta {tm=e; meta=Meta_monadic _} - | Tm_meta {tm=e; meta=Meta_monadic_lift _} -> - (* KM : This case should not happen when typechecking once but is it really *) - (* okay to just drop the annotation ? *) - tc_term env e - - | Tm_meta {tm=e; meta=m} -> - let e, c, g = tc_term env e in - let e = mk (Tm_meta {tm=e; meta=m}) top.pos in - e, c, g - - | Tm_ascribed {tm=e; asc=(asc, Some tac, use_eq); eff_opt= labopt} -> - (* Ascription with an associated tactic for its guard. We typecheck - * the ascribed term without the tactic by recursively calling tc_term, - * and then we wrap the returned guard with the tactic. We must also return - * the guard for the well-typing of the tactic itself. *) - - let tac, _, g_tac = tc_tactic t_unit t_unit env tac in - - let t' = mk (Tm_ascribed {tm=e; asc=(asc, None, use_eq); eff_opt=labopt}) top.pos in - let t', c, g = tc_term env t' in - - (* Set the tac ascription on the elaborated term *) - let t' = - match (SS.compress t').n with - | Tm_ascribed {tm=e; asc=(asc, None, _use_eq); eff_opt=labopt} -> - //assert (use_eq = _use_eq); - mk (Tm_ascribed {tm=e; asc=(asc, Some tac, use_eq); eff_opt=labopt}) t'.pos - | _ -> - failwith "impossible" - in - let g = wrap_guard_with_tactic_opt (Some tac) g in - t', c, g ++ g_tac - - (* - * AR: Special case for the typechecking of (M.reflect e) <: M a is - * - * As part of it, we typecheck (e <: Tot (repr a is)), this keeps the bidirectional - * typechecking for e, which is most cases is a lambda - * - * Also the `Tot` annotation is important since for lambdas, we fold the guard - * into the returned comp (making it something like PURE (arrow_t) wp, see the end of tc_abs) - * If we did not put `Tot` we would have to separately check that the wp has - * a trivial precondition - *) - - | Tm_ascribed {asc=(Inr expected_c, None, use_eq)} - when top |> is_comp_ascribed_reflect |> is_some -> - - let (effect_lid, e, aqual) = top |> is_comp_ascribed_reflect |> must in - - let env0, _ = Env.clear_expected_typ env in - - let expected_c, _, g_c = tc_comp env0 expected_c in - let expected_ct = Env.unfold_effect_abbrev env0 expected_c in - - if not (lid_equals effect_lid expected_ct.effect_name) - then raise_error top Errors.Fatal_UnexpectedEffect - (BU.format2 "The effect on reflect %s does not match with the annotation %s\n" - (show effect_lid) (show expected_ct.effect_name)); - - if not (is_user_reflectable_effect env effect_lid) - then raise_error top Errors.Fatal_EffectCannotBeReified - (BU.format1 "Effect %s cannot be reflected" (show effect_lid)); - - let u_c = expected_ct.comp_univs |> List.hd in - let repr = Env.effect_repr env0 (expected_ct |> S.mk_Comp) u_c |> must in - - // e <: Tot repr - let e = S.mk (Tm_ascribed {tm=e; asc=(Inr (S.mk_Total repr), None, use_eq); eff_opt=None}) e.pos in - - if Debug.extreme () - then BU.print1 "Typechecking ascribed reflect, inner ascribed term: %s\n" - (show e); - - let e, _, g_e = tc_tot_or_gtot_term env0 e in - let e = U.unascribe e in - - if Debug.extreme () - then BU.print2 "Typechecking ascribed reflect, after typechecking inner ascribed term: %s and guard: %s\n" - (show e) (Rel.guard_to_string env0 g_e); - - //reconstruct (M.reflect e) < M a is - let top = - let r = top.pos in - let tm = mk (Tm_constant (Const_reflect effect_lid)) r in - let tm = mk (Tm_app {hd=tm;args=[e, aqual]}) r in - mk (Tm_ascribed {tm; asc=(Inr expected_c, None, use_eq); eff_opt=expected_c |> U.comp_effect_name |> Some}) r in - - //check the expected type in the env, if present - let top, c, g_env = comp_check_expected_typ env top (expected_c |> TcComm.lcomp_of_comp) in - - top, c, g_c ++ g_e ++ g_env - - | Tm_ascribed {tm=e; asc=(Inr expected_c, None, use_eq)} -> - let env0, _ = Env.clear_expected_typ env in - let expected_c, _, g = tc_comp env0 expected_c in - let e, c', g' = tc_term - (U.comp_result expected_c |> (fun t -> Env.set_expected_typ_maybe_eq env0 t use_eq)) - e in - let e, expected_c, g'' = - let c', g_c' = TcComm.lcomp_comp c' in - let e, expected_c, g'' = check_expected_effect env0 use_eq - (Some expected_c) - (e, c') in - e, expected_c, g_c' ++ g'' in - let e = mk (Tm_ascribed {tm=e; - asc=(Inr expected_c, None, use_eq); - eff_opt=Some (U.comp_effect_name expected_c)}) top.pos in //AR: this used to be Inr t_res, which meant it lost annotation for the second phase - let lc = TcComm.lcomp_of_comp expected_c in - let f = g ++ g'++ g'' in - let e, c, f2 = comp_check_expected_typ env e lc in - e, c, f ++ f2 - - | Tm_ascribed {tm=e; asc=(Inl t, None, use_eq)} -> - let k, u = U.type_u () in - let t, _, f = tc_check_tot_or_gtot_term env t k None in - let e, c, g = tc_term (Env.set_expected_typ_maybe_eq env t use_eq) e in - //NS: Maybe redundant strengthen - let c, f = TcUtil.strengthen_precondition (Some (fun () -> Err.ill_kinded_type)) (Env.set_range env t.pos) e c f in - let e, c, f2 = comp_check_expected_typ env (mk (Tm_ascribed {tm=e; - asc=(Inl t, None, use_eq); - eff_opt=Some c.eff_name}) top.pos) c in - e, c, f ++ (g ++ f2) - - (* Unary operators. Explicitly curry extra arguments *) - | Tm_app {hd={n=Tm_constant Const_range_of}; args=a::hd::rest} - | Tm_app {hd={n=Tm_constant (Const_reify _)}; args=a::hd::rest} - | Tm_app {hd={n=Tm_constant (Const_reflect _)}; args=a::hd::rest} -> - let rest = hd::rest in //no 'as' clauses in F* yet, so we need to do this ugliness - let unary_op, _ = U.head_and_args top in - let head = mk (Tm_app {hd=unary_op; args=[a]}) (Range.union_ranges unary_op.pos (fst a).pos) in - let t = mk (Tm_app {hd=head; args=rest}) top.pos in - tc_term env t - - (* Binary operators *) - | Tm_app {hd={n=Tm_constant Const_set_range_of}; args=a1::a2::hd::rest} -> - let rest = hd::rest in //no 'as' clauses in F* yet, so we need to do this ugliness - let unary_op, _ = U.head_and_args top in - let head = mk (Tm_app {hd=unary_op; args=[a1; a2]}) (Range.union_ranges unary_op.pos (fst a1).pos) in - let t = mk (Tm_app {hd=head; args=rest}) top.pos in - tc_term env t - - | Tm_app {hd={n=Tm_constant Const_range_of}; args=[(e, None)]} -> - let e, c, g = tc_term (fst <| Env.clear_expected_typ env) e in - let head, _ = U.head_and_args top in - mk (Tm_app {hd=head; args=[(e, None)]}) top.pos, (TcComm.lcomp_of_comp <| mk_Total (tabbrev Const.range_lid)), g - - | Tm_app {hd={n=Tm_constant Const_set_range_of}; args=(t, None)::(r, None)::[]} -> - let head, _ = U.head_and_args top in - let env' = Env.set_expected_typ env (tabbrev Const.range_lid) in - let er, _, gr = tc_term env' r in - let t, tt, gt = tc_term env t in - let g = gr ++ gt in - mk_Tm_app head [S.as_arg t; S.as_arg r] top.pos, tt, g - - | Tm_app {hd={n=Tm_constant Const_range_of}} - | Tm_app {hd={n=Tm_constant Const_set_range_of}} -> - raise_error e Errors.Fatal_IllAppliedConstant (BU.format1 "Ill-applied constant %s" (show top)) - - | Tm_app {hd={n=Tm_constant (Const_reify _)}; args=[(e, aqual)]} -> - if Option.isSome aqual - then Errors.log_issue e - Errors.Warning_IrrelevantQualifierOnArgumentToReify - "Qualifier on argument to reify is irrelevant and will be ignored"; - - // - // Typecheck e - // - let env0, _ = Env.clear_expected_typ env in - let e, c, g = tc_term env0 e in - let c, g_c = - let c, g_c = TcComm.lcomp_comp c in - Env.unfold_effect_abbrev env c, g_c in - - if not (is_user_reifiable_effect env c.effect_name) then - raise_error e Errors.Fatal_EffectCannotBeReified - (BU.format1 "Effect %s cannot be reified" (string_of_lid c.effect_name)); - let u_c = List.hd c.comp_univs in - - let e = U.mk_reify e (Some c.effect_name) in - let repr = Env.reify_comp env (S.mk_Comp c) u_c in - let c = - if is_total_effect env c.effect_name - then S.mk_Total repr |> TcComm.lcomp_of_comp - else let ct = { comp_univs = [u_c] - ; effect_name = Const.effect_Dv_lid - ; result_typ = repr - ; effect_args = [] - ; flags = [] - } - in S.mk_Comp ct |> TcComm.lcomp_of_comp - in - let e, c, g' = comp_check_expected_typ env e c in - e, c, g ++ (g_c ++ g') - - | Tm_app {hd={n=Tm_constant (Const_reflect l)}; args=[(e, aqual)]}-> - if Option.isSome aqual then - Errors.log_issue e - Errors.Warning_IrrelevantQualifierOnArgumentToReflect - "Qualifier on argument to reflect is irrelevant and will be ignored"; - - if not (is_user_reflectable_effect env l) then - raise_error e Errors.Fatal_EffectCannotBeReified - (BU.format1 "Effect %s cannot be reflected" (string_of_lid l)); - - let reflect_op, _ = U.head_and_args top in - - begin match Env.effect_decl_opt env l with - | None -> - raise_error e Errors.Fatal_EffectNotFound - (BU.format1 "Effect %s not found (for reflect)" (Ident.string_of_lid l)) - - | Some (ed, qualifiers) -> - let env_no_ex, _ = Env.clear_expected_typ env in - - let e, c_e, g_e = - let e, c, g = tc_tot_or_gtot_term env_no_ex e in - if not <| TcComm.is_total_lcomp c then - Errors.log_issue e Errors.Error_UnexpectedGTotComputation "Expected Tot, got a GTot computation"; - e, c, g - in - - let (expected_repr_typ, g_repr), u_a, a, g_a = - let a, u_a = U.type_u () in - let a_uvar, _, g_a = TcUtil.new_implicit_var "tc_term reflect" e.pos env_no_ex a false in - TcUtil.fresh_effect_repr_en env_no_ex e.pos l u_a a_uvar, u_a, a_uvar, g_a in - - let g_eq = Rel.teq env_no_ex c_e.res_typ expected_repr_typ in - - let eff_args = - match (SS.compress expected_repr_typ).n with - | Tm_app {args=_::args} -> args - | _ -> - raise_error top Errors.Fatal_UnexpectedEffect - (BU.format3 "Expected repr type for %s is not an application node (%s:%s)" - (show l) (tag_of expected_repr_typ) - (show expected_repr_typ)) in - - let c = S.mk_Comp ({ - comp_univs=[u_a]; - effect_name = ed.mname; - result_typ=a; - effect_args=eff_args; - flags=[] - }) |> TcComm.lcomp_of_comp in - - let e = mk (Tm_app {hd=reflect_op; args=[(e, aqual)]}) top.pos in - - let e, c, g' = comp_check_expected_typ env e c in - - let e = S.mk (Tm_meta {tm=e; meta=Meta_monadic(c.eff_name, c.res_typ)}) e.pos in - - e, c, msum [g_e; g_repr; g_a; g_eq; g'] - end - - | Tm_app {hd={n=Tm_fvar {fv_qual=Some (Unresolved_constructor uc)}}; args} -> - (* ToSyntax left an unresolved constructor, we have to use type info to disambiguate *) - let base_term, uc_fields = - let base_term, fields = - if uc.uc_base_term - then match args with - | (b, _)::rest -> Some b, rest - | _ -> failwith "Impossible" - else None, args - in - if List.length uc.uc_fields <> List.length fields - then raise_error top Errors.Fatal_IdentifierNotFound - (BU.format2 "Could not resolve constructor; expected %s fields but only found %s" - (show <| List.length uc.uc_fields) - (show <| List.length fields)) - else ( - base_term, List.zip uc.uc_fields (List.map fst fields) - ) - in - let (rdc, constrname, constructor), topt = - match Env.expected_typ env with - | Some (t, _) -> - //first, prefer the expected type from the context, if any - TcUtil.find_record_or_dc_from_typ env (Some t) uc top.pos, Some (Inl t) - - | None -> - match base_term with - | Some e -> - //Otherwise, if we have an {e with ...}, compute the type of e and use it - //(there's no expected type anyway from the context, so no need to clear it check e) - let _, lc, _ = tc_term env e in - TcUtil.find_record_or_dc_from_typ env (Some lc.res_typ) uc top.pos, Some (Inr lc.res_typ) - - | None -> - //Otherwise, no type info here, use what ToSyntax decided - TcUtil.find_record_or_dc_from_typ env None uc top.pos, None - in - let rdc : DsEnv.record_or_dc = rdc in //for type-based disambiguation of rdc projectors below - let constructor = S.fv_to_tm constructor in - let mk_field_projector i x = - let projname = mk_field_projector_name_from_ident constrname i in - let qual = if rdc.is_record then Some (Record_projector (constrname, i)) else None in - let candidate = S.fvar (Ident.set_lid_range projname x.pos) qual in - S.mk_Tm_app candidate [(x, None)] x.pos - in - let fields = - TcUtil.make_record_fields_in_order env uc topt - rdc - uc_fields - (fun field_name -> - match base_term with - | Some x -> Some (mk_field_projector field_name x) - | _ -> None) - top.pos - in - let args = List.map (fun x -> x, None) fields in - let term = S.mk_Tm_app constructor args top.pos in - tc_term env term - - | Tm_app {hd={n=Tm_fvar {fv_name={v=field_name}; fv_qual=Some (Unresolved_projector candidate)}}; - args=(e, None)::rest} -> - (* ToSyntax left an unresolved projector, we have to use type info to disambiguate *) - let proceed_with choice = - match choice with - | None -> - raise_error field_name Errors.Fatal_IdentifierNotFound [ - text <| BU.format1 "Field name %s could not be resolved" (string_of_lid field_name); - ] - | Some choice -> - let f = S.fv_to_tm choice in - let term = S.mk_Tm_app f ((e, None)::rest) top.pos in - tc_term env term - in - //We have e.f, use the type of e to disambiguate - let _, lc, _ = - let env, _ = Env.clear_expected_typ env in - tc_term env e - in - begin - let t0 = N.unfold_whnf' [Unascribe; Unmeta; Unrefine] env lc.res_typ in - let thead, _ = U.head_and_args t0 in - if !dbg_RFD - then ( - BU.print3 "Got lc.res_typ=%s; t0 = %s; thead = %s\n" - (show lc.res_typ) - (show t0) - (show thead) - ); - match (SS.compress (U.un_uinst thead)).n with - | Tm_fvar type_name -> ( - match TcUtil.try_lookup_record_type env type_name.fv_name.v with - | None -> proceed_with candidate - | Some rdc -> - let i = - List.tryFind - (fun (i, _) -> TcUtil.field_name_matches field_name rdc i) - rdc.fields - in - match i with - | None -> proceed_with candidate - | Some (i, _) -> - let constrname = FStar.Ident.lid_of_ids (Ident.ns_of_lid rdc.typename @ [rdc.constrname]) in - let projname = mk_field_projector_name_from_ident constrname i in - let qual = if rdc.is_record then Some (Record_projector (constrname, i)) else None in - let choice = - S.lid_as_fv - (Ident.set_lid_range projname (Ident.range_of_lid field_name)) - qual - in - proceed_with (Some choice) - ) - | _ -> proceed_with candidate - end - - // If we're on the first phase, we don't synth, and just wait for the next phase - | Tm_app {hd=head; args=[(tau, None)]} - | Tm_app {hd=head; args=[(_, Some ({ aqual_implicit = true })); (tau, None)]} - when U.is_synth_by_tactic head && not env.phase1 -> - (* Got an application of synth_by_tactic, process it *) - - // no "as" clause - let head, args = U.head_and_args top in - tc_synth head env args top.pos - - | Tm_app {hd=head; args} - when U.is_synth_by_tactic head && not env.phase1 -> - (* We have some extra args, move them out of the way *) - let args1, args2 = - match args with - | (tau, None)::rest -> - [(tau, None)], rest - | (a, Some aq) :: (tau, None) :: rest - when aq.aqual_implicit -> - [(a, Some aq); (tau, None)], rest - | _ -> - raise_error top Errors.Fatal_SynthByTacticError "synth_by_tactic: bad application" - in - let t1 = mk_app head args1 in - let t2 = mk_app t1 args2 in - tc_term env t2 - - (* An ordinary application *) - | Tm_app {hd=head; args} -> - let env0 = env in - let env = Env.clear_expected_typ env |> fst |> instantiate_both in - if Debug.high () - then BU.print3 "(%s) Checking app %s, %s\n" - (Range.string_of_range top.pos) - (show top) - (print_expected_ty_str env0); - - //Don't instantiate head; instantiations will be computed below, accounting for implicits/explicits - let head, chead, g_head = tc_term (no_inst env) head in - let chead, g_head = TcComm.lcomp_comp chead |> (fun (c, g) -> c, g_head ++ g) in - let e, c, g = - (* If the function is shortcircuiting, we must check that the arguments are - pure/ghost. We skirt this check with --MLish, though. *) - if TcUtil.short_circuit_head head && not (Options.ml_ish ()) && not env.phase1 - then let e, c, g = check_short_circuit_args env head chead g_head args (Env.expected_typ env0) in - // //TODO: this is not efficient: - // // It is quadratic in the size of boolean terms - // // e.g., a && b && c && d ... & zzzz will be huge - // let c = if Env.should_verify env && - // not (U.is_lcomp_partial_return c) && - // U.is_pure_or_ghost_lcomp c - // then TcUtil.maybe_assume_result_eq_pure_term env e c - // else c in - e, c, g - else check_application_args env head chead g_head args (Env.expected_typ env0) - in - let e, c, implicits = - if TcComm.is_tot_or_gtot_lcomp c - // Also instantiate in phase1, dropping any precondition, - // since it will be recomputed correctly in phase2. - || (env.phase1 && TcComm.is_pure_or_ghost_lcomp c) - then let e, res_typ, implicits = TcUtil.maybe_instantiate env0 e c.res_typ in - e, TcComm.set_result_typ_lc c res_typ, implicits - else e, c, mzero - in - if Debug.extreme () - then BU.print1 "Introduced {%s} implicits in application\n" (Rel.print_pending_implicits g); - let e, c, g' = comp_check_expected_typ env0 e c in - let gres = g ++ g' ++ implicits in - if Debug.extreme () - then BU.print2 "Guard from application node %s is %s\n" - (show e) - (Rel.guard_to_string env gres); - e, c, gres - - | Tm_match _ -> - tc_match env top - - | Tm_let {lbs=(false, [{lbname=Inr _}])} -> - check_top_level_let env top - - | Tm_let {lbs=(false, _)} -> - check_inner_let env top - - | Tm_let {lbs=(true, {lbname=Inr _}::_)} -> - check_top_level_let_rec env top - - | Tm_let {lbs=(true, _)} -> - check_inner_let_rec env top - -and tc_match (env : Env.env) (top : term) : term & lcomp & guard_t = - - (* - * AR: Typechecking of match expression: - * - * match expressions may be optionally annotated with a `returns` annotation - * for dependent pattern matching - * - * When the return annotation is not supplied, we: - * -- typecheck the scrutinee - * -- typecheck the branches with - * -- if the expected type is not set in the env, then create a new uvar for it - * -- a new bv, guard_x below, as the scrutinee expression in the logic, - * guard_x is not in the scope of the branch, but it may appear in the - * computation type of the branch and branch condition - * -- combine the computation types of the branches (TcUtil.bind_cases) - * -- with the if_the_else combinator, also adding pattern exhaustiveness checks - * -- bind the scrutinee computation type with the combined branches using guard_x as the bv in bind - * this is where guard_x gets captured - * - * When the returns annotation is supplied: - * -- typecheck the scrutinee - * -- typecheck the returns annotation - * -- typecheck the branches with - * -- env with expected type unset - * -- guard_x, as the scrutinee expression in the logic, as above - * -- in tc_eqn: substituting the binder in the returns annotation with the scrutinee expression - * and ascribing it on the branch expression - * -- once the branch expression is typechecked, we also remove this ascription - * -- if the returns annotation is a type: - * -- (in tc_match) set the result type of the branches to it (is this step redundant?) - * -- TcUtil.bind_cases as before - * -- bind with the scrutinee computation type, capturing guard_x as the bind variable - * -- if the return annotation was a computation type: - * -- tc_eqn may return branch guard (different from branch condition), containing guard_x - * -- no need to bind cases, since we can take the computation type as is - * -- but we need to add pattern exhaustiveness check, and get rid of guard_x in the guard - * -- we close the guard as: forall guard_x. guard_x == scrutinee ==> ... - * -- bind with the scrutinee computation type - *) - - match (SS.compress top).n with - | Tm_match {scrutinee=e1; ret_opt; brs=eqns} -> //ret_opt is the returns annotation - let e1, c1, g1 = tc_term - (env |> Env.clear_expected_typ |> fst |> instantiate_both) - e1 in - - (* If there is a constructor in the first branch (not a variable), - then we grab the inductive type that we are matching on and use - that to maybe coerce the scrutinee. Hence `match t with | Tv_App ... ->` - will coerce the t. QUESTION: Why don't we do the same thing to get - a expected type to check the scrutinee with? *) - let e1, c1, g_c = - match eqns with - | (p, _, _)::_ -> - begin match p.v with - | Pat_cons (fv, _, _) -> - (* Wrapped in a try/catch, we may be looking up unresolved constructors. *) - let r = try Some (Env.lookup_datacon env fv.fv_name.v) with | _ -> None in - begin match r with - | Some (us, t) -> - let bs, c = U.arrow_formals_comp t in - let env' = Env.push_binders env bs in - TcUtil.maybe_coerce_lc env' e1 c1 (U.comp_result c) - | None -> - e1, c1, mzero - end - | _ -> - e1, c1, mzero - end - | _ -> e1, c1, mzero - in - - let env_branches, ret_opt, g1 = - match ret_opt with - | None -> - (match Env.expected_typ env with - | Some _ -> env, None, g1 - | None -> - let k, _ = U.type_u() in - let res_t, _, g = TcUtil.new_implicit_var "match result" e1.pos env k false in - Env.set_expected_typ env res_t, - None, - g1 ++ g) - | Some (b, asc) -> - //We have a returns annotation - - //First check that e1 is pure or ghost - //The reason is that, we will compute the final type/comp - // of match result by substituting b with e1 - // - //We could do an optimization here: - // if b does not occur free in asc, then we don't need to do this check - //Is it worth doing? - if not (TcUtil.is_pure_or_ghost_effect env c1.eff_name) - then raise_error e1 Errors.Fatal_UnexpectedEffect - (BU.format2 - "For a match with returns annotation, the scrutinee should be pure/ghost, \ - found %s with effect %s" - (show e1) - (string_of_lid c1.eff_name)); - - //Clear the expected type in the environment for the branches - // we will check the expected type for the whole match at the end - let env, _ = Env.clear_expected_typ env in - let b, asc = - let bs, asc = SS.open_ascription [b] asc in - let b = List.hd bs in - //we set the sort of the binder to be the type of e1 - {b with binder_bv={b.binder_bv with sort=c1.res_typ}}, asc in - //b is in scope for asc - let env_asc = Env.push_binders env [b] in - let asc, g_asc = - match asc with //at this point, we just pack back the use_eq bit - | Inl t, None, use_eq -> - let k, _ = U.type_u () in - let t, _, g = tc_check_tot_or_gtot_term env_asc t k None in - (Inl t, None, use_eq), g - | Inr c, None, use_eq -> - let c, _, g = tc_comp env_asc c in - (Inr c, None, use_eq), g - | _ -> - raise_error env Errors.Fatal_UnexpectedTerm - "Tactic is not yet supported with match returns" - in - - //we need to close g_asc with the binder b - env, - Some (b, asc), - g1 ++ Env.close_guard env_asc [b] g_asc in - - //g1 is now the guard for the scrutinee and the ascription - // and it is well-formed in env - - //the logical variable for the scrutinee - let guard_x = S.new_bv (Some e1.pos) c1.res_typ in - let t_eqns = eqns |> List.map (tc_eqn guard_x env_branches ret_opt) in - - let c_branches, g_branches, erasable = - match ret_opt with - | Some (b, (Inr c, _, _)) -> //a return annotation, with computation type - - //c has b free, so substitute it with the scrutinee - let c = SS.subst_comp [NT (b.binder_bv, e1)] c in - - //we don't need to bind the cases - //but we still need to - // (a) weaken the guards for the branches with the - // negation of the branch conditions that come before this branch - // (b) add exhaustiveness check - // (c) close guard_x - - let fmls, gs, erasables = //branch conditions, branch guards, erasable bits - t_eqns - |> List.map (fun (_, f, _, _, _, g, b) -> (f, g, b)) - |> List.unzip3 in - let neg_conds, exhaustiveness_cond = TcUtil.get_neg_branch_conds fmls in - let g = - List.map2 TcComm.weaken_guard_formula gs neg_conds - |> msum in - let g_exhaustiveness = - U.mk_imp exhaustiveness_cond U.t_false - |> TcUtil.label Err.exhaustiveness_check (Env.get_range env) //label - |> NonTrivial - |> Env.guard_of_guard_formula in - let g = g ++ g_exhaustiveness in - //weaken with guard_x == scrutinee - let g = TcComm.weaken_guard_formula g - (U.mk_eq2 (env.universe_of env c1.res_typ) c1.res_typ (S.bv_to_name guard_x) e1) in - //close guard_x - let g = Env.close_guard env [S.mk_binder guard_x] g in - TcComm.lcomp_of_comp c, - g, - erasables |> List.fold_left (fun acc b -> acc || b) false - - | _ -> - let cases, g, erasable = - List.fold_right - (fun (branch, f, eff_label, cflags, c, g, erasable_branch) (caccum, gaccum, erasable) -> - (f, eff_label, cflags |> must, c |> must)::caccum, - g ++ gaccum, - erasable || erasable_branch) t_eqns ([], mzero, false) in - match ret_opt with - | None -> - //no returns annotation, just bind_cases - //when the returns annotation is absent, env_branches contains the expected type - // (which may either be coming from top, or a new uvar) - let res_t = Env.expected_typ env_branches |> must |> fst in - TcUtil.bind_cases env res_t cases guard_x, g, erasable - - | Some (b, (Inl t, _, _)) -> //a returns annotation, with type - - //t has b free, so substitute it with the scrutinee - let t = SS.subst [NT (b.binder_bv, e1)] t in - - //set the type in the lcomp of the branches, and then bind_cases - //AR: is this step redundant? should check - let cases = List.map - (fun (f, eff_label, cflags, c) -> - (f, eff_label, cflags, (fun b -> TcComm.set_result_typ_lc (c b) t))) cases in - - TcUtil.bind_cases env t cases guard_x, g, erasable - in - - //bind with e1's computation type - let cres = TcUtil.bind e1.pos env (Some e1) c1 (Some guard_x, c_branches) in - - let cres = - if erasable - then (* promote cres to ghost *) - let e = U.exp_true_bool in - let c = mk_GTotal U.t_bool in - TcUtil.bind e.pos env (Some e) (TcComm.lcomp_of_comp c) (None, cres) - else cres - in - - let e = - //repack the returns ascription - let ret_opt = - match ret_opt with - | None -> None - | Some (b, asc) -> - let asc = SS.close_ascription [b] asc in - let b = List.hd (SS.close_binders [b]) in - //we make the binder sort as tun, - // since we always use the type of the scrutinee - let b = {b with binder_bv={b.binder_bv with sort=tun}} in - Some (b, asc) in - let mk_match scrutinee = - let branches = t_eqns |> List.map (fun ((pat, wopt, br), _, eff_label, _, _, _, _) -> - pat, wopt, TcUtil.maybe_lift env br eff_label cres.eff_name cres.res_typ - ) in - let e = - let rc = { residual_effect = cres.eff_name; - residual_typ = Some cres.res_typ; - residual_flags = cres.cflags } in - mk (Tm_match {scrutinee; ret_opt; brs=branches; rc_opt=Some rc}) top.pos in - let e = TcUtil.maybe_monadic env e cres.eff_name cres.res_typ in - //The ascription with the result type is useful for re-checking a term, translating it to Lean etc. - //AR: revisit, for now doing only if return annotation is not provided - match ret_opt with - | None -> mk (Tm_ascribed {tm=e; asc=(Inl cres.res_typ, None, false); eff_opt=Some cres.eff_name}) e.pos - | _ -> e - in - - //see issue #594: - //if the scrutinee is impure, then explicitly sequence it with an impure let binding - //to protect it from the normalizer optimizing it away - if TcUtil.is_pure_or_ghost_effect env c1.eff_name - then mk_match e1 - else - (* generate a let binding for e1 *) - let e_match = mk_match (S.bv_to_name guard_x) in - let lb = U.mk_letbinding (Inl guard_x) [] c1.res_typ (Env.norm_eff_name env c1.eff_name) e1 [] e1.pos in - let e = mk (Tm_let {lbs=(false, [lb]); - body=SS.close [S.mk_binder guard_x] e_match}) top.pos in - TcUtil.maybe_monadic env e cres.eff_name cres.res_typ - in - - //AR: finally, if we typechecked with the return annotation, - // we need to make sure that we check the expected type in the env - let e, cres, g_expected_type = - match ret_opt with - | None -> e, cres, mzero - | _ -> comp_check_expected_typ env e cres in - - if Debug.extreme () - then BU.print2 "(%s) Typechecked Tm_match, comp type = %s\n" - (Range.string_of_range top.pos) (TcComm.lcomp_to_string cres); - - e, cres, g_c ++ g1 ++ g_branches ++ g_expected_type - - | _ -> - failwith (BU.format1 "tc_match called on %s\n" (tag_of top)) - -and tc_synth head env args rng = - let tau, atyp = - match args with - | (tau, None)::[] -> - tau, None - | (a, Some ({ aqual_implicit = true })) :: (tau, None) :: [] -> - tau, Some a - | _ -> - raise_error rng Errors.Fatal_SynthByTacticError "synth_by_tactic: bad application" - in - - if !dbg_Tac then - BU.print2 "Processing synth of %s at type %s\n" (show tau) (show atyp); - - let typ = - match atyp with - | Some t -> t - | None -> begin match Env.expected_typ env with - | Some (t, use_eq) -> - if use_eq - then raise_error t Errors.Fatal_NotSupported - (BU.format1 "Equality ascription in synth (%s) is not yet supported, \ - please use subtyping" - (show t)); - t - | None -> raise_error env Errors.Fatal_SynthByTacticError "synth_by_tactic: need a type annotation when no expected type is present" - end - in - - // Check the result type - let typ, _, g1 = tc_term (Env.set_expected_typ env (fst <| U.type_u ())) typ in - Rel.force_trivial_guard env g1; - - // Check the tactic - let tau, _, g2 = tc_tactic t_unit t_unit env tau in - Rel.force_trivial_guard env g2; - - let t = env.synth_hook env typ ({ tau with pos = rng }) in - if !dbg_Tac then - BU.print1 "Got %s\n" (show t); - - // Should never trigger, meta-F* will check it before. - TcUtil.check_uvars tau.pos t; - - t, TcComm.lcomp_of_comp <| mk_Total typ, mzero - -and tc_tactic (a:typ) (b:typ) (env:Env.env) (tau:term) : term & lcomp & guard_t = - let env = { env with failhard = true } in - tc_check_tot_or_gtot_term env tau (t_tac_of a b) None - -and check_instantiated_fvar (env:Env.env) (v:S.var) (q:option S.fv_qual) (e:term) (t0:typ) - : term & lcomp & guard_t - = - let is_data_ctor = function - | Some Data_ctor - | Some (Record_ctor _) -> true - | _ -> false - in - if is_data_ctor q && not (Env.is_datacon env v.v) then - raise_error env Errors.Fatal_MissingDataConstructor - (BU.format1 "Expected a data constructor; got %s" (string_of_lid v.v)); - - (* remove inaccesible pattern implicits, make them regular implicits *) - let t = U.remove_inacc t0 in - - let e, t, implicits = TcUtil.maybe_instantiate env e t in -// BU.print3 "Instantiated type of %s from %s to %s\n" (show e) (show t0) (show t); - let tc = - if Env.should_verify env - then Inl t - else Inr (TcComm.lcomp_of_comp <| mk_Total t) - in - - value_check_expected_typ env e tc implicits - -(************************************************************************************************************) -(* Type-checking values: *) -(* Values have no special status, except that we structure the code to promote a value type t to a Tot t *) -(************************************************************************************************************) -and tc_value env (e:term) : term - & lcomp - & guard_t = - - //As a general naming convention, we use e for the term being analyzed and its subterms as e1, e2, etc. - //We use t and its variants for the type of the term being analyzed - let env = Env.set_range env e.pos in - let top = SS.compress e in - match top.n with - | Tm_bvar x -> - (* This can happen if user tactics build an ill-scoped term *) - raise_error top Errors.Error_IllScopedTerm - (BU.format1 "Violation of locally nameless convention: %s" (show top)) - - | Tm_uvar (u, s) -> //the type of a uvar is given directly with it; we do not recheck the type - //FIXME: Check context inclusion? - value_check_expected_typ env e (Inl (SS.subst' s (U.ctx_uvar_typ u))) mzero - - //only occurs where type annotations are missing in source programs - //or the program has explicit _ for missing terms - | Tm_unknown -> - let r = Env.get_range env in - let t, g0 = - match Env.expected_typ env with - | None -> - let k, u = U.type_u () in - let t, _, g0 = TcUtil.new_implicit_var "type of user-provided implicit term" r env k false in - t, g0 - - | Some (t, use_eq) when use_eq -> - raise_error e Errors.Fatal_NotSupported [ - Errors.Msg.text <| BU.format1 "Equality ascription as an expected type for unk (:%s) is not yet supported." (show t); - Errors.Msg.text "Please use subtyping." - ] - - | Some (t, _) -> - t, mzero - in - - let e, _, g1 = TcUtil.new_implicit_var - ("user-provided implicit term at " ^ show r) - r env t false - in - e, S.mk_Total t |> TcComm.lcomp_of_comp, g0 ++ g1 - - | Tm_name x -> - let t, rng = Env.lookup_bv env x in - let x = S.set_range_of_bv ({x with sort=t}) rng in - Env.insert_bv_info env x t; - let e = S.bv_to_name x in - let e, t, implicits = TcUtil.maybe_instantiate env e t in - let tc = if Env.should_verify env then Inl t else Inr (TcComm.lcomp_of_comp <| mk_Total t) in - value_check_expected_typ env e tc implicits - - | Tm_uinst({n=Tm_fvar fv}, _) - | Tm_fvar fv when S.fv_eq_lid fv Const.synth_lid && not env.phase1 -> - raise_error env Errors.Fatal_BadlyInstantiatedSynthByTactic "Badly instantiated synth_by_tactic" - - | Tm_uinst({n=Tm_fvar fv}, us) -> - let us = List.map (tc_universe env) us in - let (us', t), range = Env.lookup_lid env fv.fv_name.v in - let fv = S.set_range_of_fv fv range in - maybe_warn_on_use env fv; - if List.length us <> List.length us' then - raise_error env Errors.Fatal_UnexpectedNumberOfUniverse - (BU.format3 "Unexpected number of universe instantiations for \"%s\" (%s vs %s)" - (show fv) - (show (List.length us)) - (show (List.length us'))); - - (* Make sure the instantiated universes match with the ones - * provided by the Tm_uinst. The universes in us' will usually - * be U_unif with unresolved uvars, but they could be U_names - * when the definition is recursive. *) - List.iter2 - (fun ul ur -> match ul, ur with - | U_unif u'', _ -> UF.univ_change u'' ur - // TODO: more cases? we cannot get U_succ or U_max here I believe... - | U_name n1, U_name n2 when Ident.ident_equals n1 n2 -> () - | _ -> - raise_error env Errors.Fatal_IncompatibleUniverse - (BU.format3 "Incompatible universe application for %s, expected %s got %s\n" - (show fv) - (show ul) - (show ur))) - us' us; - - Env.insert_fv_info env fv t; - let e = S.mk_Tm_uinst (mk (Tm_fvar fv) e.pos) us in - check_instantiated_fvar env fv.fv_name fv.fv_qual e t - - (* not an fvar, fail *) - | Tm_uinst(_, us) -> - raise_error env Errors.Fatal_UnexpectedNumberOfUniverse - "Universe applications are only allowed on top-level identifiers" - - | Tm_fvar fv -> - let (us, t), range = Env.lookup_lid env fv.fv_name.v in - let fv = S.set_range_of_fv fv range in - maybe_warn_on_use env fv; - if !dbg_Range - then BU.print5 "Lookup up fvar %s at location %s (lid range = defined at %s, used at %s); got universes type %s\n" - (show (lid_of_fv fv)) - (Range.string_of_range e.pos) - (Range.string_of_range range) - (Range.string_of_use_range range) - (show t); - Env.insert_fv_info env fv t; - let e = S.mk_Tm_uinst (mk (Tm_fvar fv) e.pos) us in - check_instantiated_fvar env fv.fv_name fv.fv_qual e t - - | Tm_constant c -> - let t = tc_constant env top.pos c in - let e = mk (Tm_constant c) e.pos in - value_check_expected_typ env e (Inl t) mzero - - | Tm_arrow {bs; comp=c} -> - let bs, c = SS.open_comp bs c in - let env0 = env in - let env, _ = Env.clear_expected_typ env in - (* type checking the binders *) - let bs, env, g, us = tc_binders env bs in - (* type checking the computation *) - let c, uc, f = tc_comp env c in - let e = {U.arrow bs c with pos=top.pos} in - (* checks the SMT pattern associated with this function is properly defined with regard to context *) - if not env.phase1 then - check_smt_pat env e bs c; - (* taking the maximum of the universes of the computation and of all binders *) - let u = S.U_max (uc::us) in - (* create a universe of level u *) - let t = mk (Tm_type u) top.pos in - let g = g ++ (Env.close_guard_univs us bs f) in - let g = TcUtil.close_guard_implicits env false bs g in - value_check_expected_typ env0 e (Inl t) g - - | Tm_type u -> - let u = tc_universe env u in - let t = mk (Tm_type(S.U_succ u)) top.pos in - let e = mk (Tm_type u) top.pos in - value_check_expected_typ env e (Inl t) mzero - - | Tm_refine {b=x; phi} -> - let x, phi = SS.open_term [S.mk_binder x] phi in - let env0 = env in - let env, _ = Env.clear_expected_typ env in - let x, env, f1, u = tc_binder env (List.hd x) in - if Debug.high () - then BU.print3 "(%s) Checking refinement formula %s; binder is %s\n" - (Range.string_of_range top.pos) (show phi) (show x.binder_bv); - let t_phi, _ = U.type_u () in - let phi, _, f2 = tc_check_tot_or_gtot_term env phi t_phi - (Some "refinement formula must be pure or ghost") in - let e = {U.refine x.binder_bv phi with pos=top.pos} in - let t = mk (Tm_type u) top.pos in - let g = f1 ++ Env.close_guard_univs [u] [x] f2 in - let g = TcUtil.close_guard_implicits env false [x] g in - value_check_expected_typ env0 e (Inl t) g - - | Tm_abs {bs; body} -> - (* in case we use type variables which are implicitly quantified, we add quantifiers here *) - let bs = TcUtil.maybe_add_implicit_binders env bs in - if Debug.medium () - then BU.print1 "Abstraction is: %s\n" (show ({top with n=Tm_abs {bs; body; rc_opt=None}})); - let bs, body = SS.open_term bs body in - tc_abs env top bs body - - | _ -> - failwith (BU.format2 "Unexpected value: %s (%s)" (show top) (tag_of top)) - -and tc_constant (env:env_t) r (c:sconst) : typ = - let res = - match c with - | Const_unit -> t_unit - | Const_bool _ -> t_bool - | Const_int (_, None) -> t_int - | Const_int (_, Some msize) -> - tconst (match msize with - | Signed, Int8 -> Const.int8_lid - | Signed, Int16 -> Const.int16_lid - | Signed, Int32 -> Const.int32_lid - | Signed, Int64 -> Const.int64_lid - | Unsigned, Int8 -> Const.uint8_lid - | Unsigned, Int16 -> Const.uint16_lid - | Unsigned, Int32 -> Const.uint32_lid - | Unsigned, Int64 -> Const.uint64_lid - | Unsigned, Sizet -> Const.sizet_lid) - | Const_string _ -> t_string - | Const_real _ -> t_real - | Const_char _ -> - FStar.Syntax.DsEnv.try_lookup_lid env.dsenv FStar.Parser.Const.char_lid - |> BU.must - - (* TODO (KM) : Try to change this to U.ktype1 *) - (* (because that's the minimal universe level of the WP) *) - (* and see how much code breaks *) - | Const_effect -> U.ktype0 //NS: really? - | Const_range _ -> t_range - | Const_range_of - | Const_set_range_of - | Const_reify _ - | Const_reflect _ -> - raise_error r Errors.Fatal_IllTyped - (BU.format1 "Ill-typed %s: this constant must be fully applied" (show c)) - - | _ -> raise_error r Errors.Fatal_UnsupportedConstant ("Unsupported constant: " ^ show c) - in - SS.set_use_range r res - - -(************************************************************************************************************) -(* Type-checking computation types *) -(************************************************************************************************************) -and tc_comp env c : comp (* checked version of c *) - & universe (* universe of c *) - & guard_t = (* logical guard for the well-formedness of c *) - let c0 = c in - match c.n with - | Total t -> - let k, u = U.type_u () in - let t, _, g = tc_check_tot_or_gtot_term env t k None in - mk_Total t, u, g - - | GTotal t -> - let k, u = U.type_u () in - let t, _, g = tc_check_tot_or_gtot_term env t k None in - mk_GTotal t, u, g - - | Comp c -> - let head = S.fvar c.effect_name None in - let head = match c.comp_univs with - | [] -> head - | us -> S.mk (Tm_uinst(head, us)) c0.pos in - let tc = mk_Tm_app head ((as_arg c.result_typ)::c.effect_args) c.result_typ.pos in - let tc, _, f = - (* - * AR: 11/18: TcUtil.weaken_result_typ by default logs a typing error and continues - * Failing hard when typechecking computation types, since errors - * like missing effect args can result in broken invariants in - * the unifier or the normalizer - *) - tc_check_tot_or_gtot_term ({ env with failhard = true }) tc S.teff None in - let head, args = U.head_and_args tc in - let comp_univs = match (SS.compress head).n with - | Tm_uinst(_, us) -> us - | _ -> [] in - let _, args = U.head_and_args tc in - let res, args = List.hd args, List.tl args in - let flags, guards = c.flags |> List.map (function - | DECREASES (Decreases_lex l) -> - let env, _ = Env.clear_expected_typ env in - let l, g = l |> List.fold_left (fun (l, g) e -> - let e, _, g_e = tc_tot_or_gtot_term env e in - l@[e], g ++ g_e) ([], mzero) in - DECREASES (Decreases_lex l), g - | DECREASES (Decreases_wf (rel, e)) -> - (* - * We will check that for a fresh uvar (?u:Type), - * rel:well_founded_relation ?u and - * e:?u - *) - let env, _ = Env.clear_expected_typ env in - let t, u_t = U.type_u () in - let u_r = Env.new_u_univ () in - let a, _, g_a = TcUtil.new_implicit_var - "implicit for type of the well-founded relation in decreases clause" - rel.pos - env - t - false - in - //well_founded_relation t - let wf_t = mk_Tm_app - (mk_Tm_uinst - (Env.fvar_of_nonqual_lid env Const.well_founded_relation_lid) - [u_t; u_r]) - [as_arg a] rel.pos in - let rel, _, g_rel = tc_tot_or_gtot_term (Env.set_expected_typ env wf_t) rel in - let e, _, g_e = tc_tot_or_gtot_term (Env.set_expected_typ env a) e in - DECREASES (Decreases_wf (rel, e)), - g_a ++ g_rel ++ g_e - | f -> f, mzero) |> List.unzip in - let u = env.universe_of env (fst res) in - let c = mk_Comp ({c with - comp_univs=comp_univs; - result_typ=fst res; - flags = flags; - effect_args=args}) in - let u_c = c |> TcUtil.universe_of_comp env u in - c, u_c, f ++ msum guards - -and tc_universe env u : universe = - let rec aux u = - let u = SS.compress_univ u in - match u with - | U_bvar _ -> failwith "Impossible: locally nameless" - | U_unknown -> failwith "Unknown universe" - | U_unif _ - | U_zero -> u - | U_succ u -> U_succ (aux u) - | U_max us -> U_max (List.map aux us) - | U_name x -> - if Env.lookup_univ env x - then u - else failwith ("Universe variable " ^ (show u) ^ " not found") - in if env.lax_universes then U_zero - else (match u with - | U_unknown -> U.type_u () |> snd - | _ -> aux u) - -(* Several complex cases from the main type-checker are factored in to separate functions below *) - - -(* - * Called when typechecking a Tm_abs node - * - * t0 is the expected type in the environment for the Tm_abs node - * and the use_eq bit (whether to use type equality) - *) -and tc_abs_expected_function_typ env (bs:binders) (t0:option (typ & bool)) (body:term) -: (option typ (* any remaining expected type to check against *) -& binders (* binders from the abstraction checked against the binders in the corresponding Typ_fun, if any *) -& binders (* let rec binders, suitably guarded with termination check, if any *) -& option comp (* the expected comp type for the body *) -& Env.env (* environment for the body *) -& term (* the body itself *) -& guard_t) (* accumulated guard from checking the binders, well-formed in the initial env *) - -= match t0 with - | None -> (* no expected type; just build a function type from the binders in the term *) - (* env.letrecs are the current letrecs we are checking *) - let _ = match env.letrecs with - | [] -> () - | _ -> failwith "Impossible: Can't have a let rec annotation but no expected type" in - let bs, envbody, g_env, _ = tc_binders env bs in - None, bs, [], None, envbody, body, g_env - - | Some (t, use_eq) -> - let t = SS.compress t in - let rec as_function_typ (norm:bool) t = - match (SS.compress t).n with - (* we are type checking abs so all cases except arrow are required for definitional equality *) - | Tm_uvar _ - | Tm_app {hd={n=Tm_uvar _}} -> - (* expected a uvar; build a function type from the term and unify with it *) - let _ = match env.letrecs with | [] -> () | _ -> failwith "Impossible: uvar abs with non-empty environment" in - let bs, envbody, g_env, _ = tc_binders env bs in - let envbody, _ = Env.clear_expected_typ envbody in - Some t, bs, [], None, envbody, body, g_env - - (* CK: add this case since the type may be f:(a -> M b wp){φ}, in which case I drop the refinement *) - (* NS: 07/21 dropping the refinement is not sound; we need to check that f validates phi. See Bug #284 *) - | Tm_refine {b} -> - let _, bs, bs', copt, env_body, body, g_env = as_function_typ norm b.sort in - //we pass type `t` out to check afterwards the full refinement type is respected - Some t, bs, bs', copt, env_body, body, g_env - - | Tm_arrow {bs=bs_expected; comp=c_expected} -> - let bs_expected, c_expected = SS.open_comp bs_expected c_expected in - (* Two main interesting bits here; - 1. The expected type may have - a. more immediate binders, whereas the function may itself return a function - b. fewer immediate binders, meaning that the function type is explicitly curried - 2. If the function is a let-rec and it is to be total, then we need to add termination checks. - *) - let check_actuals_against_formals env bs bs_expected body - : Env.env - & binders - & guard_t - & comp - & term - = let rec handle_more (env_bs, bs, more, guard_env, subst) c_expected body = - match more with - | None -> //number of binders match up - env_bs, bs, guard_env, SS.subst_comp subst c_expected, body - - | Some (Inr more_bs_expected) -> //more formal parameters; expect the body to return a total function - let c = S.mk_Total (U.arrow more_bs_expected c_expected) in - env_bs, bs, guard_env, SS.subst_comp subst c, body - - | Some (Inl more_bs) -> //more actual args - let c = SS.subst_comp subst c_expected in - (* the expected type is explicitly curried *) - if Options.ml_ish () || U.is_named_tot c then - let t = N.unfold_whnf env_bs (U.comp_result c) in - match t.n with - | Tm_arrow {bs=bs_expected; comp=c_expected} -> - let bs_expected, c_expected = SS.open_comp bs_expected c_expected in - let (env_bs_bs', bs', more, guard'_env_bs, subst) = tc_abs_check_binders env_bs more_bs bs_expected use_eq in - let guard'_env = Env.close_guard env_bs bs guard'_env_bs in - handle_more (env_bs_bs', bs@bs', more, guard_env ++ guard'_env, subst) c_expected body - | _ -> - let body = U.abs more_bs body None in - env_bs, bs, guard_env, c, body - else let body = U.abs more_bs body None in - env_bs, bs, guard_env, c, body - in //end let rec handle_more - handle_more (tc_abs_check_binders env bs bs_expected use_eq) c_expected body - in //end let rec check_actuals_against_formals - - let mk_letrec_env envbody bs c = - let letrecs = guard_letrecs envbody bs c in - let envbody = {envbody with letrecs=[]} in - let envbody, letrec_binders, g = - letrecs |> List.fold_left (fun (env, letrec_binders, g) (l,t,u_names) -> - //let t = N.normalize [Env.EraseUniverses; Env.Beta] env t in - //printfn "Checking let rec annot: %s\n" (show t); - let t, _, g' = tc_term (Env.clear_expected_typ env |> fst) t in - let env = Env.push_let_binding env l (u_names, t) in - let lb = match l with - | Inl x -> S.mk_binder ({x with sort=t})::letrec_binders - | _ -> letrec_binders in - env, lb, g ++ g') (envbody, [], mzero) in - (envbody, letrec_binders, Env.close_guard envbody bs g) - in - - (* Set letrecs to [] before calling check_actuals_against_formals, - * then restore. That function will typecheck the types of the binders - * and having letrecs set will make a mess. *) - let envbody = { env with letrecs = [] } in - let envbody, bs, g_env, c, body = check_actuals_against_formals envbody bs bs_expected body in - let envbody = { envbody with letrecs = env.letrecs } in - let envbody, letrecs, g_annots = mk_letrec_env envbody bs c in - let envbody = Env.set_expected_typ_maybe_eq envbody (U.comp_result c) use_eq in - Some t, bs, letrecs, Some c, envbody, body, g_env ++ g_annots - - | _ -> (* expected type is not a function; - try normalizing it first; - otherwise synthesize a type and check it against the given type *) - if not norm - then as_function_typ true (t |> N.unfold_whnf env |> U.unascribe) //AR: without the unascribe we lose out on some arrows - else - let _, bs, _, c_opt, envbody, body, g_env = tc_abs_expected_function_typ env bs None body in - Some t, bs, [], c_opt, envbody, body, g_env - in - as_function_typ false t - -(***************************************************************************************************************) - (* check_binders checks that the binders bs of top *) - (* are compatible with the binders of the function typ expected by the context *) - (* If there are more bs than bs_expected, we only check a prefix and the suffix is returned Inl *) - (* If there are more bs_expected than bs, the suffix of bs_expected is returned Inr *) - (* If use_eq flag is set, we check type equality for the binder types *) -(***************************************************************************************************************) -and tc_abs_check_binders env bs bs_expected use_eq - : Env.env (* env extended with a prefix of bs *) - & binders (* the type-checked prefix of bs *) - & option (either binders binders) (* suffix of either bs or bs_expected*) - & guard_t (* accumulated logical guard - well-formed in argument env *) - & subst_t = (* alpha conv. of bs_expected to bs *) - let rec aux (env, subst) (bs:binders) (bs_expected:binders) - : Env.env - & binders - & option (either binders binders) - & guard_t //guard is well-formed in the input environment - & subst_t = - match bs, bs_expected with - | [], [] -> env, [], None, mzero, subst - - | ({binder_qual=None})::_, ({binder_bv=hd_e;binder_qual=q;binder_positivity=pqual;binder_attrs=attrs})::_ - when S.is_bqual_implicit_or_meta q -> - (* When an implicit is expected, but the user provided an - * explicit binder, insert a nameless implicit binder. *) - let bv = S.new_bv (Some (Ident.range_of_id hd_e.ppname)) (SS.subst subst hd_e.sort) in - aux (env, subst) ((S.mk_binder_with_attrs bv q pqual attrs) :: bs) bs_expected - - | ({binder_bv=hd;binder_qual=imp;binder_positivity=pqual_actual; binder_attrs=attrs})::bs, - ({binder_bv=hd_expected;binder_qual=imp';binder_positivity=pqual_expected;binder_attrs=attrs'})::bs_expected -> begin - (* These are the discrepancies in qualifiers that we allow *) - let special q1 q2 = match q1, q2 with - | Some (Meta _), Some (Meta _) -> true (* don't compare the metaprograms *) - | None, Some Equality -> true - | Some (Implicit _), Some (Meta _) -> true - | _ -> false in - - if not (special imp imp') && not (U.eq_bqual imp imp') then - let open FStar.Errors.Msg in - let open FStar.Pprint in - let open FStar.Class.PP in - raise_error hd Errors.Fatal_InconsistentImplicitArgumentAnnotation [ - text <| BU.format1 "Inconsistent implicit argument annotation on argument %s" (show hd); - prefix 2 1 (text "Got:") (squotes <| doc_of_string <| Print.bqual_to_string imp); - prefix 2 1 (text "Expected:") (squotes <| doc_of_string <| Print.bqual_to_string imp'); - ] - end; - - // The expected binder may be annotated with a positivity attribute - // though the actual binder on the abstraction may not ... we use the expected pqual - // But, it is not ok if the expected binder is not annotated while the - // actual binder is annnotated as strictly positive. - let positivity_qual_to_string = function - | None -> "None" - | Some BinderStrictlyPositive -> "StrictlyPositive" - | Some BinderUnused -> "Unused" - in - if not (Common.check_positivity_qual true pqual_expected pqual_actual) - then raise_error hd Errors.Fatal_InconsistentQualifierAnnotation - (BU.format3 "Inconsistent positivity qualifier on argument %s; \ - Expected qualifier %s, \ - found qualifier %s" - (show hd) - (positivity_qual_to_string pqual_expected) - (positivity_qual_to_string pqual_actual)); - - (* since binders depend on previous ones, we accumulate a substitution *) - let expected_t = SS.subst subst hd_expected.sort in - let t, g_env = - match (U.unmeta hd.sort).n with - | Tm_unknown -> expected_t, mzero - (* in case we have an annotation on both implementation and declaration, we: - * 1) type check the implementation type - * 2) add an extra guard that the two types must be equal (use_eq will be used in Rel.teq - *) - | _ -> - if Debug.high () then BU.print1 "Checking binder %s\n" (show hd); - let t, _, g1_env = tc_tot_or_gtot_term env hd.sort in - let g2_env = - let label_guard g = - TcUtil.label_guard - hd.sort.pos - (Errors.mkmsg "Type annotation on parameter incompatible with the expected type") - g in - - //cf issue #57 (the discussion at the end about subtyping vs. equality in check_binders) - //check that the context is more demanding of the argument type - - match Rel.teq_nosmt env t expected_t with - | Some g -> g |> Rel.resolve_implicits env //AR: why resolve here? - | None -> - if use_eq - then Rel.teq env t expected_t |> label_guard - else match Rel.get_subtyping_prop env expected_t t with - | None -> - // GM: Make sense of this, is basic_type_error fatal or not? - Err.raise_basic_type_error env (Env.get_range env) None expected_t t - | Some g_env -> label_guard g_env - in - t, g1_env ++ g2_env - in - - let hd = {hd with sort=t} in - let combine_attrs (attrs:list S.attribute) (attrs':list S.attribute) : list S.attribute = - let diff = List.filter (fun attr' -> - not (List.existsb (fun attr -> TEQ.eq_tm env attr attr' = TEQ.Equal) attrs) - ) attrs' in - attrs@diff - in - let b = {binder_bv=hd;binder_qual=imp;binder_positivity=pqual_expected;binder_attrs=combine_attrs attrs attrs'} in - check_erasable_binder_attributes env b.binder_attrs t; - let b_expected = ({binder_bv=hd_expected;binder_qual=imp';binder_positivity=pqual_expected;binder_attrs=attrs'}) in - let env_b = push_binding env b in - let subst = maybe_extend_subst subst b_expected (S.bv_to_name hd) in - let env_bs, bs, rest, g'_env_b, subst = aux (env_b, subst) bs bs_expected in - let g'_env = Env.close_guard env_bs [b] g'_env_b in - env_bs, b::bs, rest, g_env ++ g'_env, subst - - | rest, [] -> - env, [], Some (Inl rest), mzero, subst - - | [], rest -> - env, [], Some (Inr rest), mzero, subst in - - aux (env, []) bs bs_expected - -(*******************************************************************************************************************) -(* Type-checking abstractions, aka lambdas *) -(* top = fun bs -> body, although bs and body must already be opened *) -(*******************************************************************************************************************) -and tc_abs env (top:term) (bs:binders) (body:term) : term & lcomp & guard_t = - let fail :string -> typ -> 'a = fun msg t -> - Err.expected_a_term_of_type_t_got_a_function env top.pos msg t top - in - - let env0 = env in - (* topt is the expected type of the expression obtained from the env *) - let env, topt = Env.clear_expected_typ env in - - if Debug.high () then - BU.print2 "!!!!!!!!!!!!!!!Expected type is (%s), top_level=%s\n" - (show topt) (show env.top_level); - - let tfun_opt, bs, letrec_binders, c_opt, envbody, body, g_env = - tc_abs_expected_function_typ env bs topt body in - - if Debug.extreme () then - BU.print3 "After expected_function_typ, tfun_opt: %s, c_opt: %s, and expected type in envbody: %s\n" - (show tfun_opt) (show c_opt) (show (Env.expected_typ envbody)); - - if !dbg_NYC - then BU.print2 "!!!!!!!!!!!!!!!Guard for function with binders %s is %s\n" - (show bs) - (guard_to_string env g_env); - - let envbody = Env.set_range envbody body.pos in - let body, cbody, guard_body = - (* - * AR: Special casing the typechecking of the body when it is a M.reflect e - * If so, and c_opt is not None, i.e. we have an expected type in the env, - * we make the body as (M.reflect e) <: c_opt - * Basically, typechecking a reflect can be made better by the effect indices - * See also special casing of M.reflect <: C in the same file - * - * AR: the type of should_check_expected_effect is - * either bool unit - * - * where Inl b means do check expected effect, with use_eq = b - * and Inr _ means don't check expected effect - *) - let envbody, body, should_check_expected_effect = - let use_eq_opt = - match topt with - | Some (_, use_eq) -> use_eq |> Some - | _ -> None in - if c_opt |> is_some && - (match (SS.compress body).n with //body is an M.reflect - | Tm_app {hd=head; args} when List.length args = 1 -> - (match (SS.compress head).n with - | Tm_constant (Const_reflect _) -> true - | _ -> false) - | _ -> false) - then - Env.clear_expected_typ envbody |> fst, - S.mk - //since copt is Some, topt, and hence use_eq_opt must also be Some - (Tm_ascribed {tm=body; asc=(Inr (c_opt |> must), None, use_eq_opt |> must); eff_opt=None}) - Range.dummyRange, - Inr () //no need to check expected type - else - envbody, - body, - (match c_opt, (SS.compress body).n with - | None, Tm_ascribed {asc=(Inr expected_c, _, _)} -> - //body is already ascribed a computation type; - //don't check it again - //Not only is it redundant and inefficient, it also sometimes leads to bizarre errors - //e.g., Issue #1208 - Inr () - | _ -> Inl (BU.dflt false use_eq_opt)) - in - let body, cbody, guard_body = - tc_term ({envbody with top_level=false}) body in - - //we don't abstract over subtyping constraints; so solve them now - //but leave out the tactics constraints for later so that the tactic - //can have a more global view of all the constraints - let guard_body = Rel.solve_non_tactic_deferred_constraints true envbody guard_body in - - match should_check_expected_effect with - | Inl use_eq -> - let cbody, g_lc = TcComm.lcomp_comp cbody in - let body, cbody, guard = - Errors.with_ctx "While checking that lambda abstraction has expected effect" (fun () -> - check_expected_effect envbody use_eq c_opt (body, cbody)) - in - body, cbody, guard_body ++ g_lc ++ guard - | Inr _ -> - let cbody, g_lc = TcComm.lcomp_comp cbody in - body, cbody, guard_body ++ g_lc - in - - if Debug.extreme () - then BU.print1 "tc_abs: guard_body: %s\n" - (Rel.guard_to_string env guard_body); - - let guard_body = - (* If we were checking a top-level definition, which may be a let rec, - we must discharge this the guard of the body here, as it is - only typeable in the extended environment which contains the Binding_lids. - Closing the guard (below) won't help with that. *) - if env.top_level then ( - if Debug.medium () then - BU.print1 "tc_abs: FORCING guard_body: %s\n" (Rel.guard_to_string env guard_body); - Rel.discharge_guard envbody guard_body - ) else ( - guard_body - ) - in - - let guard = - let guard_body = Env.close_guard envbody (bs@letrec_binders) guard_body in - g_env ++ guard_body - in - - let guard = TcUtil.close_guard_implicits env false bs guard in //TODO: this is a noop w.r.t scoping; remove it and the eager_subtyping flag - let tfun_computed = U.arrow bs cbody in - let e = U.abs bs body (Some (U.residual_comp_of_comp (dflt cbody c_opt))) in - - (* - * AR: Check strictly_positive annotations on the binders, if any - * - * To do so, we use the same routine as used for inductive types, - * after substituting the bv name with a fresh lid fv in the function body - *) - let _ = - List.iter - (fun b -> - if Options.no_positivity() - then () - else ( - if U.is_binder_unused b - && not (Positivity.name_unused_in_type envbody b.binder_bv body) - then raise_error b Error_InductiveTypeNotSatisfyPositivityCondition - (BU.format1 "Binder %s is marked unused, but its use in the definition is not" - (show b)) - ; - - if U.is_binder_strictly_positive b - && not (Positivity.name_strictly_positive_in_type envbody b.binder_bv body) - then raise_error b Error_InductiveTypeNotSatisfyPositivityCondition - (BU.format1 "Binder %s is marked strictly positive, but its use in the definition is not" - (show b)) - - )) - bs - in - - (* - * AR: there are three types in the code above now: - * topt : option term -- the original annotation - * tfun_opt : option term -- a definitionally equal type to topt (e.g. when topt is not an arrow but can be reduced to one) - * tfun_computed : term -- computed type of the abstraction - * - * the following code has the logic for which type to package the input expression with - * if tfun_opt is Some we are guaranteed that topt is also Some, and in that case, we use Some?.v topt - * in this case earlier we were returning Some?.v tfun_opt but that means we lost out on the user annotation - * if tfun_opt is None, then so is topt and we just return tfun_computed - *) - let e, tfun, guard = match tfun_opt with - | Some t -> - let t = SS.compress t in - let t_annot, use_eq = - match topt with - | Some (t, use_eq) -> t, use_eq - | None -> failwith "Impossible! tc_abs: if tfun_computed is Some, expected topt to also be Some" in - begin match t.n with - | Tm_arrow _ -> - //we already checked the body to have the expected type; so, no need to check again - //just repackage the expression with this type; t is guaranteed to be alpha equivalent to tfun_computed - e, t_annot, guard - | _ -> - let lc = S.mk_Total tfun_computed |> TcComm.lcomp_of_comp in - let e, _, guard' = TcUtil.check_has_type_maybe_coerce env e lc t use_eq in //QUESTION: t should also probably be t_annot here - let guard' = TcUtil.label_guard e.pos (Err.subtyping_failed env lc.res_typ t ()) guard' in - e, t_annot, guard ++ guard' - end - - | None -> e, tfun_computed, guard in - - let c = mk_Total tfun in - let c, g = TcUtil.strengthen_precondition None env e (TcComm.lcomp_of_comp c) guard in - - e, c, g - -(******************************************************************************) -(* Type-checking applications: Tm_app head args *) -(* head is already type-checked has comp type chead, with guard ghead *) -(******************************************************************************) -and check_application_args env head (chead:comp) ghead args expected_topt : term & lcomp & guard_t= - let n_args = List.length args in - let r = Env.get_range env in - let thead = U.comp_result chead in - if Debug.high () then - BU.print3 "(%s) Type of head is %s\nArgs = %s\n" (show head.pos) (show thead) (show args); - - (* given |- head : chead | ghead - where head is a computation returning a function of type (bs0@bs -> cres) - and the paramters bs0 have been applied to the arguments in arg_comps_rev (in reverse order) - and args_comps_rev = [(argn, _, cn), ..., (arg0, _, c0)] - - - This function builds - head arg0 ... argn : M (bs -> cres) wp - where in the case where - bs = [], i.e., a full application - M, wp is built using - bind chead (bind c0 (bind c1 ... (bind cn cres))) - bs = _::_, i.e., a partial application - M, wp is built using - bind chead (bind c0 (bind c1 ... (bind cn (Tot (bs -> cres)))) - *) - let monadic_application - (head, chead, ghead, cres) (* the head of the application, its lcomp chead, and guard ghead, returning a bs -> cres *) - subst (* substituting actuals for formals seen so far, when actual is pure *) - (arg_comps_rev:list (arg & option bv & lcomp)) (* type-checked actual arguments, so far; in reverse order *) - arg_rets_rev (* The results of each argument at the logic level, in reverse order *) - guard (* conjoined guard formula for all the actuals *) - fvs (* unsubstituted formals, to check that they do not occur free elsewhere in the type of f *) - bs (* formal parameters *) - : term //application of head to args - & lcomp //its computation type - & guard_t //and whatever guard remains - = let cres, guard = - match bs with - | [] -> (* full app *) - cres, ghead ++ guard - - | _ -> (* partial app *) - // - // AR: 04/29/2022: Do we need to solve these constraints here? - // - let g = ghead ++ guard |> Rel.solve_deferred_constraints env in - mk_Total (U.arrow bs cres), g in - - // - //AR: It is important that this check is done after we have - // added the bs to the cres result type, to ensure that fvs - // don't escape in the bs - // - let rt, g0 = check_no_escape (Some head) env fvs (U.comp_result cres) in - let cres, guard = - U.set_result_typ cres rt, - g0 ++ guard in - - if Debug.medium () - then BU.print1 "\t Type of result cres is %s\n" - (show cres); - - let chead, cres = SS.subst_comp subst chead |> TcComm.lcomp_of_comp, SS.subst_comp subst cres |> TcComm.lcomp_of_comp in - - (* Note: The arg_comps_rev are in reverse order. e.g., f e1 e2 e3, we have *) - (* arg_comps_rev = [(e3, _, c3); (e2; _; c2); (e1; _; c1)] *) - (* We build comp = bind chead (bind c1 (bind c2 (bind c3 cres))) *) - (* The typing rule for monadic application should be something like *) - - (* G |- head : chead G |- ei :ci *) - (* ------------------------------------------------- *) - (* G |- let xhead = lift_{chead}^{comp} head in *) - (* let x1 = lift_{ci}^{comp} e1 in *) - (* ... *) - (* lift_{cres}^{comp} (xhead x1 ... xn) : cres *) - - (* where chead = b1 -> ... bn -> cres *) - - (* if cres is pure or ghost, we augment it with a return - i.e., in the case where the head f is a pure or ghost function, - treat the application as (e e1 e2 .. en) as - f <-- e; - x1 <-- e1; ... - xn <-- en; - return (f x1 ... xn) - 1. The return at the end enhances f's result type with an equality - e.g., if (f : xs -> Tot t) - the type of the application becomes - Pure t (ensures (fun y -> y = f x1 ...xn)) - 2. It's VERY important that the return is inserted using the bound names x1...xn. - Previously, in case e1..en were pure, we were inserting - Pure t (ensures (fun y -> y = f e1 ...en)) - But this leads to a massive blow up in the size of generated VCs (cf issue #971) - arg_rets below are those xn...x1 bound variables - *) - let cres, inserted_return_in_cres = - let head_is_pure_and_some_arg_is_effectful = - TcComm.is_pure_or_ghost_lcomp chead - && (BU.for_some (fun (_, _, lc) -> not (TcComm.is_pure_or_ghost_lcomp lc) - || TcUtil.should_not_inline_lc lc) - arg_comps_rev) - in - let term = S.mk_Tm_app head (List.rev arg_rets_rev) head.pos in - if TcComm.is_pure_or_ghost_lcomp cres - && (head_is_pure_and_some_arg_is_effectful) - // || Option.isSome (Env.expected_typ env)) - then let _ = if Debug.extreme () then BU.print1 "(a) Monadic app: Return inserted in monadic application: %s\n" (show term) in - TcUtil.maybe_assume_result_eq_pure_term env term cres, true - else let _ = if Debug.extreme () then BU.print1 "(a) Monadic app: No return inserted in monadic application: %s\n" (show term) in - cres, false - in - - (* 1. We compute the final computation type comp *) - - // - //AR: 01/05/2022: A caveat with Layered Effects: - // We may have inserted a return in the cres, where the return - // mentions names from arg_rets_rev - // This means that cres now contains names that are not closed in - // env (env is the top-level env of the application node) - // The code below computed `bind`, which uses unification - // for layered effects - // Since unification is strict about uvar solutions being closed - // in the ctx uvar env, we need to make sure that when we call bind - // the computation types are closed in the environment - // Meaning: add names from arg_rets_rev - // - // Now what is arg_rets_rev: it is bv names for explicit args, and - // Tm_uvar for implicits that are not specified - // So we need to filter names from arg_rets_rev - // - // (Note: The implicits in Tm_uvar are created in the top env, - // therefore it should be ok to have the solutions of those uvars - // appear in the computation types, those should still be closed - // in the env) - // - - let comp = - let arg_rets_names_opt = - arg_rets_rev |> List.rev - |> List.map (fun (t, _) -> - match (SS.compress t).n with - | Tm_name bv -> bv |> Some - | _ -> None) in - - let push_option_names_to_env = - List.fold_left (fun env name_opt -> - name_opt |> BU.map_option (Env.push_bv env) - |> BU.dflt env) in - - //Bind arguments - let _, comp = - List.fold_left - (fun (i, out_c) ((e, q), x, c) -> - if Debug.extreme () then - BU.print3 "(b) Monadic app: Binding argument %s : %s of type (%s)\n" - (match x with | None -> "_" - | Some x -> show x) - (show e) - (TcComm.lcomp_to_string c); - // - //Push first (List.length arg_rets_names_opt - i) names in the env - // - let env = - // add arg_rets_names to env only if needed - // extra names in the env interfere with flex-flex queries in Rel, - // as they may result in uvar restrictions etc. - if inserted_return_in_cres - then push_option_names_to_env env - (List.splitAt (List.length arg_rets_names_opt - i) arg_rets_names_opt - |> fst) - else env in - if TcComm.is_pure_or_ghost_lcomp c - then i+1,TcUtil.bind e.pos env (Some e) c (x, out_c) - else i+1,TcUtil.bind e.pos env None c (x, out_c)) - (1, cres) - arg_comps_rev in - - //Bind head - //Push all arg ret names in the env - let env = push_option_names_to_env env arg_rets_names_opt in - if Debug.extreme () - then BU.print2 - "(c) Monadic app: Binding head %s, chead: %s\n" - (show head) - (TcComm.lcomp_to_string chead); - if TcComm.is_pure_or_ghost_lcomp chead - then TcUtil.bind head.pos env (Some head) chead (None, comp) - else TcUtil.bind head.pos env None chead (None, comp) in - - (* TODO : This is a really syntactic criterion to check if we can evaluate *) - (* applications left-to-right, can we do better ? *) - let shortcuts_evaluation_order = - match (SS.compress head).n with - | Tm_fvar fv -> - S.fv_eq_lid fv Parser.Const.op_And || - S.fv_eq_lid fv Parser.Const.op_Or - | _ -> false - in - - let app = - if shortcuts_evaluation_order then - (* Note: this case is only reachable in --lax mode. - In non-lax code, shortcut evaluation order is handled by - check_short_circuit_args. See, roughly, line 511, case Tm_app - *) - (* If the head is shortcutting we cannot hoist its arguments *) - (* Leaving it `as is` is a little dubious, it would fail whenever we try to reify it *) - let args = List.fold_left (fun args (arg, _, _) -> arg::args) [] arg_comps_rev in - let app = mk_Tm_app head args r in - let app = TcUtil.maybe_lift env app cres.eff_name comp.eff_name comp.res_typ in - TcUtil.maybe_monadic env app comp.eff_name comp.res_typ - - else - (* 2. For each monadic argument (including the head of the application) we introduce *) - (* a fresh variable and lift the actual argument to comp. *) - let lifted_args, head, args = - let map_fun ((e, q), _ , c) = - if Debug.extreme () then - BU.print2 "For arg e=(%s) c=(%s)... " (show e) (TcComm.lcomp_to_string c); - if TcComm.is_pure_or_ghost_lcomp c - then begin - if Debug.extreme () then - BU.print_string "... not lifting\n"; - None, (e, q) - end else begin - //this argument is effectful, warn if the function would be erased - //special casing for ignore, may be use an attribute instead? - let warn_effectful_args = - (TcUtil.must_erase_for_extraction env chead.res_typ) && - (not (match (U.un_uinst head).n with - | Tm_fvar fv -> S.fv_eq_lid fv (Parser.Const.psconst "ignore") - | _ -> true)) - in - if warn_effectful_args then - Errors.log_issue e Errors.Warning_EffectfulArgumentToErasedFunction - (format3 "Effectful argument %s (%s) to erased function %s, consider let binding it" - (show e) (show c.eff_name) (show head)); - if Debug.extreme () then - BU.print_string "... lifting!\n"; - let x = S.new_bv None c.res_typ in - let e = TcUtil.maybe_lift env e c.eff_name comp.eff_name c.res_typ in - Some (x, c.eff_name, c.res_typ, e), (S.bv_to_name x, q) - end - in - let lifted_args, reverse_args = - List.split <| List.map map_fun ((as_arg head, None, chead)::arg_comps_rev) - in - lifted_args, fst (List.hd reverse_args), List.rev (List.tl reverse_args) - in - - (* 3. We apply the (non-monadic) head to the non-monadic arguments, lift the *) - (* result to comp and then bind each monadic arguments to close over the *) - (* variables introduces at step 2. *) - let app = mk_Tm_app head args r in - let app = TcUtil.maybe_lift env app cres.eff_name comp.eff_name comp.res_typ in - let app = TcUtil.maybe_monadic env app comp.eff_name comp.res_typ in - let bind_lifted_args e = function - | None -> e - | Some (x, m, t, e1) -> - let lb = U.mk_letbinding (Inl x) [] t m e1 [] e1.pos in - let letbinding = mk (Tm_let {lbs=(false, [lb]); body=SS.close [S.mk_binder x] e}) e.pos in - mk (Tm_meta {tm=letbinding; meta=Meta_monadic(m, comp.res_typ)}) e.pos - in - List.fold_left bind_lifted_args app lifted_args - in - - (* Each conjunct in g is already labeled *) - //NS: Maybe redundant strengthen - // let comp, g = comp, guard in - let comp, g = TcUtil.strengthen_precondition None env app comp guard in - if Debug.extreme () then BU.print2 "(d) Monadic app: type of app\n\t(%s)\n\t: %s\n" - (show app) - (TcComm.lcomp_to_string comp); - app, comp, g - in - - let rec tc_args (head_info:(term & comp & guard_t & comp)) //the head of the application, its comp and guard, returning a bs -> cres - (subst, (* substituting actuals for formals seen so far, when actual is pure *) - outargs, (* type-checked actual arguments, so far; in reverse order *) - arg_rets,(* The results of each argument at the logic level, in reverse order *) - g, (* conjoined guard formula for all the actuals *) - fvs) (* unsubstituted formals, to check that they do not occur free elsewhere in the type of f *) - bs (* formal parameters *) - args (* remaining actual arguments *) : (term & lcomp & guard_t) = - - let instantiate_one_and_go b rest_bs args = - (* We compute a range by combining the range of the head - * and the last argument we checked (if any). This is such that - * if we instantiate an implicit for `f ()` (of type `#x:a -> ...), - * we give it the range of `f ()` instead of just the range for `f`. - * See issue #2021. This is only for the use range, we take - * the def range from the head, so the 'see also' should still - * point to the definition of the head. *) - let r = match outargs with - | [] -> head.pos - | ((t, _), _, _)::_ -> - Range.range_of_rng (Range.def_range head.pos) - (Range.union_rng (Range.use_range head.pos) - (Range.use_range t.pos)) - in - let b = SS.subst_binder subst b in - let tm, ty, aq, g' = TcUtil.instantiate_one_binder env r b in - let ty, g_ex = check_no_escape (Some head) env fvs ty in - let guard = g ++ g' ++ g_ex in - let arg = tm, aq in - let subst = NT(b.binder_bv, tm)::subst in - tc_args head_info (subst, (arg, None, S.mk_Total ty |> TcComm.lcomp_of_comp)::outargs, arg::arg_rets, guard, fvs) rest_bs args - in - - match bs, args with - (* Expect an implicit but user provided a concrete argument, instantiate the implicit. *) - | ({binder_bv=x;binder_qual=Some (Implicit _)})::rest, (_, None)::_ - | ({binder_bv=x;binder_qual=Some (Meta _)})::rest, (_, None)::_ - -> - instantiate_one_and_go (List.hd bs) rest args - - (* User provided a _ for a meta arg, keep the meta for the unknown. *) - | ({binder_bv=x;binder_qual=Some (Meta tau);binder_attrs=b_attrs})::rest, - ({n = Tm_unknown}, Some {aqual_implicit=true})::rest' -> - instantiate_one_and_go (List.hd bs) rest rest' (* NB: rest' instead of args, we consume the _ *) - - | ({binder_bv=x;binder_qual=bqual;binder_attrs=b_attrs})::rest, (e, aq)::rest' -> (* a concrete argument *) - let aq = check_expected_aqual_for_binder aq (List.hd bs) e.pos in - let targ = SS.subst subst x.sort in - let bqual = SS.subst_bqual subst bqual in - let x = {x with sort=targ} in - if Debug.extreme () - then BU.print5 "\tFormal is %s : %s\tType of arg %s (after subst %s) = %s\n" - (show x) (show x.sort) (show e) (show subst) (show targ); - let targ, g_ex = check_no_escape (Some head) env fvs targ in - let env = Env.set_expected_typ_maybe_eq env targ (is_eq bqual) in - if Debug.high () - then BU.print4 "Checking arg (%s) %s at type %s with use_eq:%s\n" - (tag_of e) - (show e) - (show targ) - (bqual |> is_eq |> string_of_bool); - let e, c, g_e = tc_term env e in - let g = g_ex ++ g ++ g_e in -// if debug env Options.High then BU.print2 "Guard on this arg is %s;\naccumulated guard is %s\n" (guard_to_string env g_e) (guard_to_string env g); - let arg = e, aq in - let xterm = S.bv_to_name x, aq in //AR: fix for #1123, we were dropping the qualifiers - if TcComm.is_tot_or_gtot_lcomp c //early in prims, Tot and GTot are primitive, not defined in terms of Pure/Ghost yet - || TcUtil.is_pure_or_ghost_effect env c.eff_name - then let subst = maybe_extend_subst subst (List.hd bs) e in - tc_args head_info (subst, (arg, Some x, c)::outargs, xterm::arg_rets, g, fvs) rest rest' - else tc_args head_info (subst, (arg, Some x, c)::outargs, xterm::arg_rets, g, x::fvs) rest rest' - - | _, [] -> (* no more args; full or partial application *) - monadic_application head_info subst outargs arg_rets g fvs bs - - | [], arg::_ -> (* too many args, except maybe c returns a function *) - let head, chead, ghead = monadic_application head_info subst outargs arg_rets g fvs [] in - let chead, ghead = TcComm.lcomp_comp chead |> (fun (c, g) -> c, ghead ++ g) in - let rec aux norm solve ghead tres = - let tres = SS.compress tres |> U.unrefine |> U.unmeta_safe in - match tres.n with - | Tm_arrow {bs; comp=cres'} -> - let bs, cres' = SS.open_comp bs cres' in - let head_info = (head, chead, ghead, cres') in - if Debug.low () - then FStar.Errors.log_issue tres - Errors.Warning_RedundantExplicitCurrying "Potentially redundant explicit currying of a function type"; - tc_args head_info ([], [], [], mzero, []) bs args - | _ when not norm -> - let rec norm_tres (tres:term) :term = - let tres = tres |> N.unfold_whnf env |> U.unascribe in - match (SS.compress tres).n with - | Tm_refine {b={ sort = tres }} -> norm_tres tres - | _ -> tres - in - aux true solve ghead (norm_tres tres) - - | _ when not solve -> - let ghead = Rel.solve_deferred_constraints env ghead in - aux norm true ghead tres - - | _ -> - let open FStar.Class.PP in - let open FStar.Pprint in - raise_error (argpos arg) Fatal_ToManyArgumentToFunction [ - prefix 4 1 (text "Too many arguments to function of type") (pp thead); - text "Got" ^/^ pp (n_args <: int) ^/^ text "arguments"; - prefix 4 1 (text "Remaining type is") (pp tres); - ] - in - aux false false ghead (U.comp_result chead) - in //end tc_args - - let rec check_function_app tf guard = - let tf = N.unfold_whnf env tf in - match (U.unmeta tf).n with - | Tm_uvar _ - | Tm_app {hd={n=Tm_uvar _}} -> - let bs, guard = - List.fold_right - (fun _ (bs, guard) -> - let t, _, g = TcUtil.new_implicit_var "formal parameter" tf.pos env (U.type_u () |> fst) false in - null_binder t::bs, g ++ guard) - args - ([], guard) - in - let cres, guard = - let t, _, g = TcUtil.new_implicit_var "result type" tf.pos env (U.type_u() |> fst) false in - if Options.ml_ish () - then U.ml_comp t r, guard ++ g - else S.mk_Total t, guard ++ g - in - let bs_cres = U.arrow bs cres in - if Debug.extreme () - then BU.print3 "Forcing the type of %s from %s to %s\n" - (show head) - (show tf) - (show bs_cres); - //Yes, force only the guard for this equation; the other uvars will not be solved yet - let g = Rel.solve_deferred_constraints env (Rel.teq env tf bs_cres) in - check_function_app bs_cres (g ++ guard) - - | Tm_arrow {bs; comp=c} -> - let bs, c = SS.open_comp bs c in - let head_info = head, chead, ghead, c in - if Debug.extreme () - then BU.print4 "######tc_args of head %s @ %s with formals=%s and result type=%s\n" - (show head) - (show tf) - (show bs) - (show c); - tc_args head_info ([], [], [], guard, []) bs args - - | Tm_refine {b=bv} -> - check_function_app bv.sort guard - - | Tm_ascribed {tm=t} -> - check_function_app t guard - - | _ -> - Err.expected_function_typ env head.pos tf - in - - check_function_app thead mzero - -(******************************************************************************) -(* SPECIAL CASE OF CHECKING APPLICATIONS: *) -(* head symbol is one of &&, ||, /\, \/, ==> *) -(* ALL OF THEM HAVE A LOGICAL SPEC THAT IS BIASED L-to-R, *) -(* aka they are short-circuiting *) -(******************************************************************************) -and check_short_circuit_args env head chead g_head args expected_topt : term & lcomp & guard_t = - let r = Env.get_range env in - let tf = SS.compress (U.comp_result chead) in - match tf.n with - | Tm_arrow {bs; comp=c} when (U.is_total_comp c && List.length bs=List.length args) -> - let res_t = U.comp_result c in - let args, guard, ghost = - List.fold_left2 - (fun (seen, guard, ghost) (e, aq) b -> - let aq = check_expected_aqual_for_binder aq b e.pos in - let e, c, g = tc_check_tot_or_gtot_term env e b.binder_bv.sort - (Some "arguments to short circuiting operators must be pure or ghost") - in //NS: this forbids stuff like !x && y, maybe that's ok - let short = TcUtil.short_circuit head seen in - let g = Env.imp_guard (Env.guard_of_guard_formula short) g in - let ghost = ghost - || (not (TcComm.is_total_lcomp c) - && not (TcUtil.is_pure_effect env c.eff_name)) in - seen@[e,aq], guard ++ g, ghost) - ([], g_head, false) - args - bs - in - let e = mk_Tm_app head args r in - let c = if ghost then S.mk_GTotal res_t |> TcComm.lcomp_of_comp else TcComm.lcomp_of_comp c in - //NS: maybe redundant strengthen - // let c, g = c, guard in - let c, g = TcUtil.strengthen_precondition None env e c guard in - e, c, g - - | _ -> //fallback - check_application_args env head chead g_head args expected_topt - -and tc_pat env (pat_t:typ) (p0:pat) : - pat (* the type-checked, fully decorated pattern *) - & list bv (* all its bound variables, used for closing the type of the branch term *) - & list term (* for each bv in the returned bv list, this list contains a Tm_abs, - that when applied to the scrutinee, returns an expression for bv in terms of - projectors. for example, say scrutinee is of type list (option int), and the - pattern is (Some hd)::_, then hd will be returned in the bv list, and the - list term would contain syntax for: - fun (x:list (option int)) -> Some?.v (Cons?.hd x) - in the case of layered effects, we close over the pattern variables in the - branch VC by substituting them with these expressions *) - & Env.env (* the environment extended with all the binders *) - & term (* terms corresponding to the pattern *) - & term (* the same term in normal form *) - & guard_t (* unresolved implicits *) - & bool (* true if the pattern matches an erasable type *) - = - let fail : string -> 'a = fun msg -> - raise_error p0.p Errors.Fatal_MismatchedPatternType msg - in - let expected_pat_typ env pos scrutinee_t : typ = - let rec aux norm t = - let t = U.unrefine t in - let head, args = U.head_and_args t in - match (SS.compress head).n with - | Tm_uinst ({n=Tm_fvar f}, us) -> unfold_once t f us args - | Tm_fvar f -> unfold_once t f [] args - | _ -> - if norm then t - else aux true (N.normalize [Env.HNF; Env.Unmeta; Env.Unascribe; Env.UnfoldUntil delta_constant] env t) - and unfold_once t f us args = - if Env.is_type_constructor env f.fv_name.v - then t - else match Env.lookup_definition [Env.Unfold delta_constant] env f.fv_name.v with - | None -> t - | Some head_def_ts -> - let _, head_def = Env.inst_tscheme_with head_def_ts us in - let t' = S.mk_Tm_app head_def args t.pos in - let t' = N.normalize [Env.Beta; Env.Iota] env t' in - aux false t' - in - aux false (N.normalize [Env.Beta;Env.Iota] env scrutinee_t) - in - let pat_typ_ok env pat_t scrutinee_t : guard_t = - if !dbg_Patterns - then BU.print2 "$$$$$$$$$$$$pat_typ_ok? %s vs. %s\n" - (show pat_t) (show scrutinee_t); - def_check_scoped pat_t.pos "pat_typ_ok.pat_t.entry" env pat_t; - let fail : string -> 'a = fun msg_str -> - let msg = - if msg_str = "" then [] else [Errors.text msg_str] - in - let msg = - let open FStar.Pprint in - let open FStar.Class.PP in - let open FStar.Errors.Msg in - ( - prefix 2 1 (text "Type of pattern") (pp pat_t) ^/^ - prefix 2 1 (text "does not match type of scrutinee") (pp scrutinee_t) - ) :: msg - in - raise_error p0.p Errors.Fatal_MismatchedPatternType msg - in - let head_s, args_s = U.head_and_args scrutinee_t in - let pat_t = N.normalize [Env.Beta] env pat_t in - match U.un_uinst head_s with - | {n=Tm_fvar _} -> - let head_p, args_p = U.head_and_args pat_t in - if Rel.teq_nosmt_force env head_p head_s - then match (U.un_uinst head_p).n with - | Tm_fvar f -> - if not <| Env.is_type_constructor env (S.lid_of_fv f) - then fail "Pattern matching a non-inductive type"; - - if List.length args_p <> List.length args_s - then fail ""; - - let params_p, params_s = - match Env.num_inductive_ty_params env (S.lid_of_fv f) with - | None -> - args_p, args_s - | Some n -> - let params_p, _ = BU.first_N n args_p in - let params_s, _ = BU.first_N n args_s in - params_p, params_s - in - - List.fold_left2 - (fun out (p, _) (s, _) -> - match Rel.teq_nosmt env p s with - | None -> - fail (BU.format2 "Parameter %s <> Parameter %s" - (show p) - (show s)) - | Some g -> - let g = Rel.discharge_guard_no_smt env g in - g ++ out) - mzero - params_p - params_s - - | _ -> fail "Pattern matching a non-inductive type" - else fail (BU.format2 "Head mismatch %s vs %s" - (show head_p) - (show head_s)) - - | _ -> - match Rel.teq_nosmt env pat_t scrutinee_t with - | None -> fail "" - | Some g -> - let g = Rel.discharge_guard_no_smt env g in - g - in - let type_of_simple_pat env (e:term) : term & typ & list bv & guard_t & bool = - let head, args = U.head_and_args e in - match head.n with - | Tm_uinst ({n=Tm_fvar _}, _) - | Tm_fvar _ -> - let head, (us, t_f) = - match head.n with - | Tm_uinst (head, us) -> - let Tm_fvar f = head.n in - let res = Env.try_lookup_and_inst_lid env us f.fv_name.v in - begin - match res with - | Some (t, _) - when Env.is_datacon env f.fv_name.v -> - head, (us, t) - - | _ -> - fail (BU.format1 "Could not find constructor: %s" - (Ident.string_of_lid f.fv_name.v)) - end - - | Tm_fvar f -> - head, - Env.lookup_datacon env f.fv_name.v - in - let formals, t = U.arrow_formals t_f in - //Data constructors are marked with the "erasable" attribute - //if their types are; matching on this constructor incurs - //a ghost effect - let erasable = Env.non_informative env t in - if List.length formals <> List.length args - then fail "Pattern is not a fully-applied data constructor"; - let rec aux (subst, args_out, bvs, guard) formals args = - match formals, args with - | [], [] -> - let head = S.mk_Tm_uinst head us in - let pat_e = S.mk_Tm_app head args_out e.pos in - pat_e, SS.subst subst t, bvs, guard, erasable - | ({binder_bv=f})::formals, (a, imp_a)::args -> - let t_f = SS.subst subst f.sort in - let a, subst, bvs, g = - match (SS.compress a).n with - | Tm_name x -> - let x = {x with sort=t_f} in - let a = S.bv_to_name x in - let subst = NT(f, a)::subst in - (a, imp_a), subst, bvs@[x], mzero - - | Tm_uvar _ -> - let use_eq = true in - let env = Env.set_expected_typ_maybe_eq env t_f use_eq in - // - //AR: 03/03: When typechecking these uvar args, - // we don't want to solve the deferred constraints here, - // since solving them here may mean solving flex-flex equations - // among them - // - // Whereas if we wait for unification of these dot pattern uvars - // with the type of the scrutinee (in pat_typ_ok), we have a good - // chance of solving these uvars as flex-rigid equations - // - // Therefore, ask tc_tot to not solve deferred, and return the - // guard as is - // - let a, _, g = tc_tot_or_gtot_term_maybe_solve_deferred - env - a - None - false in //don't solve the deferred constraints in the guard - let subst = NT(f, a)::subst in - (a, imp_a), subst, bvs, g - - | _ -> - // - // AR: 09/29: - // - // Before we carried on dot patterns solutions from phase1 to phase2, - // the arguments args here could just be names (from Pat_var) - // or uvars (from Pat_dot_term) - // - // But now they can be arbitrary terms for Pat_dot_term, - // since in phase1, Pat_dot_term could be solved with - // arbitrary term - // - // If not a name or uvar, we typecheck the term, - // and add it to args_out - // - let a = SS.subst subst a in - let env = Env.set_expected_typ env t_f in - let a, _, g = tc_tot_or_gtot_term env a in - let subst = NT(f, a)::subst in - (a, imp_a), subst, bvs, g - in - aux (subst, args_out@[a], bvs, g ++ guard) formals args - | _ -> fail "Not a fully applied pattern" - in - aux ([], [], [], mzero) formals args - | _ -> - fail "Not a simple pattern" - in - (* - * This function checks the nested pattern and - * builds the list bv and corresponding list term (see the comment at the signature of tc_pat) - * by checking the pattern "inside out" - * - * For example, taking the scrutinee of type list (option int), and the pattern as Cons (Some hd) _, - * the recursive call first typechecks hd, and returns the term as t1 = Prims.id - * Then we come to Some hd, and the term becomes t2 = (fun (x:option int). t1 (Some?.v x)) - * Then we come to Cons (Some hd), and the term becomes t3 = (fun (x:list (option int)). t2 (Cons?.hd x)) - * After a bit of normalization, this is same as (fun (x:list (option int)). Some?.v (Cons?.hd x)) - *) - let rec check_nested_pattern env (p:pat) (t:typ) - : list bv - & list term - & term - & pat - & guard_t - & bool = - if !dbg_Patterns - then BU.print2 "Checking nested pattern %s at type %s\n" (show p) (show t); - - let id t = mk_Tm_app - (S.fvar Const.id_lid None) - [S.iarg t] - t.pos - in - - (* - * Taking the example of scrutinee of type list (option int), and pattern as Cons (Some hd), _, - * this function will be called twice: - * (a) disc as Some?.v and inner_t as Prims.id (say it returns t1) - * (b) disc as Cons?.hd and inner_t as t1 - * It builds the term as mentioned above in the comment at check_nested_pattern - *) - let mk_disc_t (disc:term) (inner_t:term) : term = - let x_b = S.gen_bv "x" None t |> S.mk_binder in - // - //AR: 05/02/2022: Try to provide implicit type arguments to the projector, - // if we can't then (lax) typechecking later will infer them - // - let ty_args = - let hd, args = U.head_and_args t in - match (hd |> SS.compress |> U.un_uinst).n with - | Tm_fvar fv -> - fv |> lid_of_fv |> Env.num_inductive_ty_params env - |> (fun nopt -> - BU.dflt [] (nopt |> BU.map_option (fun n -> - if List.length args >= n - then args |> List.splitAt n |> fst - else []))) - |> List.map (fun (t, _) -> S.iarg t) - | _ -> [] in - let tm = S.mk_Tm_app - disc - (ty_args@[x_b.binder_bv |> S.bv_to_name |> S.as_arg]) - Range.dummyRange in - let tm = S.mk_Tm_app - inner_t - [tm |> S.as_arg] Range.dummyRange in - U.abs [x_b] tm None in - - match p.v with - | Pat_dot_term _ -> - failwith (BU.format1 "Impossible: Expected an undecorated pattern, got %s" (show p)) - - | Pat_var x -> - let x = {x with sort=t} in - [x], - [id t], - S.bv_to_name x, - {p with v=Pat_var x}, - mzero, - false - - | Pat_constant c -> - (* - * AR: enforcing decidable equality, since the branch guards are in boolean now - * so whereas earlier we did scrutinee == c, - * we now have scrutinee = c, so we need decidable equality on c - *) - (match c with - | Const_unit | Const_bool _ | Const_int _ | Const_char _ | Const_string _ -> () - | _ -> - fail (BU.format1 - "Pattern matching a constant that does not have decidable equality: %s" - (show c))); - let _, e_c, _, _ = PatternUtils.pat_as_exp false false env p in - let e_c, lc, g = tc_tot_or_gtot_term env e_c in - Rel.force_trivial_guard env g; - let expected_t = expected_pat_typ env p0.p t in - if not (Rel.teq_nosmt_force env lc.res_typ expected_t) - then fail (BU.format2 "Type of pattern (%s) does not match type of scrutinee (%s)" - (show lc.res_typ) - (show expected_t)); - [], - [], - e_c, - p, - mzero, - false - - | Pat_cons({fv_qual = Some (Unresolved_constructor uc)}, us_opt, sub_pats) -> - let rdc, _, constructor_fv = TcUtil.find_record_or_dc_from_typ env (Some t) uc p.p in - let f_sub_pats = List.zip uc.uc_fields sub_pats in - let sub_pats = - TcUtil.make_record_fields_in_order env uc (Some (Inl t)) rdc f_sub_pats - (fun _ -> - let x = S.new_bv None S.tun in - Some (S.withinfo (Pat_var x) p.p, false)) - p.p - in - let p = { p with v=Pat_cons(constructor_fv, us_opt, sub_pats) } in - let p = PatternUtils.elaborate_pat env p in - check_nested_pattern env p t - - | Pat_cons(fv, us_opt, sub_pats) -> - let simple_pat = - let simple_sub_pats = - List.map (fun (p, b) -> - match p.v with - | Pat_dot_term _ -> p, b - | _ -> S.withinfo (Pat_var (S.new_bv (Some p.p) S.tun)) p.p, b) - sub_pats in - {p with v = Pat_cons (fv, us_opt, simple_sub_pats)} - in - let sub_pats = - sub_pats - |> List.filter (fun (x, _) -> - match x.v with - | Pat_dot_term _ -> false - | _ -> true) - in - let simple_bvs_pat, simple_pat_e, g0, simple_pat_elab = - PatternUtils.pat_as_exp false false env simple_pat - in - // - // simple_bvs_pat are the Pat_vars in a Pat_cons - // - // Number of simple_bvs should be same as the number of simple_pats - // - if List.length simple_bvs_pat <> List.length sub_pats - then failwith (BU.format4 "(%s) Impossible: pattern bvar mismatch: %s; expected %s sub pats; got %s" - (Range.string_of_range p.p) - (show simple_pat) - (BU.string_of_int (List.length sub_pats)) - (BU.string_of_int (List.length simple_bvs_pat))); - let simple_pat_e, simple_bvs, g1, erasable = - // - // guard is the typechecking guard - // it contains some deferred constraints for dot pattern uvars - // we will solve them after pat_typ_ok - // - let simple_pat_e, simple_pat_t, simple_bvs, guard, erasable = - type_of_simple_pat env simple_pat_e - in - - // - // AR: 09/29: - // - // A note about simple_bvs: - // - // Before we started to reuse Pat_dot_term solutions from phase1 to phase2, - // the simple_bvs returned by typechecking of simple pat would be - // same as the simple_bvs_pat that we got from pat_as_exp, - // since Pat_dot_term were always elaborated to uvars, so the only names were - // those coming from Pat_vars (a simple pat is a Pat_cons with sub pats as - // Pat_dot_term or Pat_var) - // - // But now, a Pat_dot_term solution could itself be a name, - // and typechecking the simple pat returns it in simple_bvs - // - // Noting that all the Pat_dot_terms occur at the beginning, - // we take the suffix of simple_bvs with length same as - // simple_bvs_pat - // - let simple_bvs = - simple_bvs - |> BU.first_N (List.length simple_bvs - List.length simple_bvs_pat) - |> snd in - - let g' = pat_typ_ok (Env.push_bvs env simple_bvs) simple_pat_t (expected_pat_typ env p0.p t) in - // - // Now solve guard - // guard may have logical payload coming from typechecking of the - // Pat_dot_term solutions computed in phase 1 - // Here we only want to solve the implicits, - // folding in the logical payload in the rest of the VC - // - let guard = - let fml = Env.guard_form guard in - let guard = - Rel.discharge_guard_no_smt env {guard with guard_f = Trivial} in - {guard with guard_f=fml} in - // And combine with g' (the guard from pat_typ_ok) - let guard = guard ++ g' in - if !dbg_Patterns - then BU.print3 "$$$$$$$$$$$$Checked simple pattern %s at type %s with bvs=%s\n" - (show simple_pat_e) - (show simple_pat_t) - (List.map (fun x -> "(" ^ show x ^ " : " ^ show x.sort ^ ")") simple_bvs - |> String.concat " "); - simple_pat_e, simple_bvs, guard, erasable - in - let bvs, tms, checked_sub_pats, subst, g, erasable, _ = - // - // Invariant: g must be well-formed in the top-level env - // - List.fold_left2 - (fun (bvs, tms, pats, subst, g, erasable, i) (p, b) x -> - let expected_t = SS.subst subst x.sort in - let env = Env.push_bvs env bvs in - let bvs_p, tms_p, e_p, p, g', erasable_p = check_nested_pattern env p expected_t in - let g' = Env.close_guard env (bvs |> List.map S.mk_binder) g' in - let tms_p = - let disc_tm = TcUtil.get_field_projector_name env (S.lid_of_fv fv) i in - tms_p |> List.map (mk_disc_t (S.fvar disc_tm None)) in - bvs@bvs_p, tms@tms_p, pats@[(p,b)], NT(x, e_p)::subst, g ++ g', erasable || erasable_p, i+1) - ([], [], [], [], g0 ++ g1, erasable, 0) - sub_pats - simple_bvs - in - let pat_e = SS.subst subst simple_pat_e in - let reconstruct_nested_pat pat = - let rec aux simple_pats bvs sub_pats = - match simple_pats with - | [] -> [] - | (hd, b)::simple_pats -> - match hd.v with - | Pat_dot_term eopt -> - let eopt = BU.map_option (SS.subst subst) eopt in - let hd = {hd with v=Pat_dot_term eopt} in - (hd, b) :: aux simple_pats bvs sub_pats - | Pat_var x -> - begin - match bvs, sub_pats with - | x'::bvs, (hd, _)::sub_pats - when S.bv_eq x x' -> - (hd, b) :: aux simple_pats bvs sub_pats - - | _ -> - failwith "Impossible: simple pat variable mismatch" - end - | _ -> failwith "Impossible: expected a simple pattern" - in - let us = - let hd, _ = U.head_and_args simple_pat_e in - match (SS.compress hd).n with - | Tm_fvar _ -> [] - | Tm_uinst(_, us) -> us - | _ -> failwith "Impossible: tc_pat: pattern head not fvar or uinst" - in - match pat.v with - | Pat_cons(fv, _, simple_pats) -> - let nested_pats = aux simple_pats simple_bvs checked_sub_pats in - {pat with v=Pat_cons(fv, Some us, nested_pats)} - | _ -> failwith "Impossible: tc_pat: pat.v expected Pat_cons" - in - bvs, - tms, - pat_e, - reconstruct_nested_pat simple_pat_elab, - g, - erasable - in - if !dbg_Patterns - then BU.print1 "Checking pattern: %s\n" (show p0); - let bvs, tms, pat_e, pat, g, erasable = - check_nested_pattern - (Env.clear_expected_typ env |> fst) - (PatternUtils.elaborate_pat env p0) - (expected_pat_typ env p0.p pat_t) - in - let extended_env = Env.push_bvs env bvs in - let pat_e_norm = N.normalize [Env.Beta] extended_env pat_e in - if !dbg_Patterns - then BU.print2 "Done checking pattern %s as expression %s\n" - (show pat) - (show pat_e); - pat, bvs, tms, extended_env, pat_e, pat_e_norm, g, erasable - - -(********************************************************************************************************************) -(* Type-checking a pattern-matching branch *) -(* scrutinee_expr is the scrutinee expression, used when we also have a returns annotation *) -(* the pattern, when_clause and branch are closed *) -(* scrutinee is the logical name of the expression being matched; it is not in scope in the branch *) -(* but it is in scope for the VC of the branch *) -(* env does not contain scrutinee, or any of the pattern-bound variables *) -(* the returned terms are well-formed in an environment extended with the scrutinee only *) - -(* - * ret_opt is the optional return annotation on the match (NB: if any, the ascription has been opened) - * if this is set, then ascribe it on the branches for typechecking - * but unascribe it before returning to the caller - *) -(********************************************************************************************************************) -and tc_eqn (scrutinee:bv) (env:Env.env) (ret_opt : option match_returns_ascription) (branch:S.branch) - : (pat & option term & term) (* checked branch *) - & formula (* the guard condition for taking this branch, - used by the caller for the exhaustiveness check *) - & lident (* effect label of the branch lcomp *) - & option (list cflag) (* flags for the branch lcomp, - None if typechecked with a returns comp annotation *) - & option (bool -> lcomp) (* computation type of the branch, with or without a "return" equation, - None if typechecked with a returns comp annotation *) - & guard_t (* guard for well-typedness of the branch *) - & bool (* true if the pattern matches an erasable type *) - = - let pattern, when_clause, branch_exp = SS.open_branch branch in - let cpat, _, cbr = branch in - - let pat_t = scrutinee.sort in - let scrutinee_tm = S.bv_to_name scrutinee in - let scrutinee_env, _ = Env.push_bv env scrutinee |> Env.clear_expected_typ in - - (* 1. Check the pattern *) - (* pat_bvs are the pattern variables, and pat_bv_tms are syntax for a single argument functions that *) - (* when applied to the scrutinee return an expression for the bv in terms of projectors *) - let pattern, pat_bvs, pat_bv_tms, pat_env, pat_exp, norm_pat_exp, guard_pat, erasable = - tc_pat (Env.push_bv env scrutinee) pat_t pattern - in - - if Debug.extreme () then - BU.print3 "tc_eqn: typechecked pattern %s with bvs %s and pat_bv_tms=%s\n" - (show pattern) (show pat_bvs) - (show pat_bv_tms); - - (* 2. Check the when clause *) - let when_clause, g_when = match when_clause with - | None -> None, mzero - | Some e -> - if Env.should_verify env - then raise_error e - Errors.Fatal_WhenClauseNotSupported - "When clauses are not yet supported in --verify mode; they will be some day" - // let e, c, g = no_logical_guard pat_env <| tc_total_exp (Env.set_expected_typ pat_env TcUtil.t_bool) e in - // Some e, g - else let e, c, g = tc_term (Env.set_expected_typ pat_env t_bool) e in - Some e, g in - - (* 3. Check the branch *) - let branch_exp, c, g_branch = - let branch_exp = //ascribe with the return annotation, if it exists - match ret_opt with - | None -> branch_exp - | Some (b, asc) -> - asc - |> SS.subst_ascription [NT (b.binder_bv, norm_pat_exp)] - |> U.ascribe branch_exp in - let branch_exp, c, g_branch = tc_term pat_env branch_exp in - let branch_exp = //unascribe if we added ascription - match ret_opt with - | None -> branch_exp - | _ -> - match (SS.compress branch_exp).n with - | Tm_ascribed {tm=branch_exp} -> branch_exp - | _ -> failwith "Impossible (expected the match branch with an ascription)" in - branch_exp, c, g_branch in - - def_check_scoped cbr.pos "tc_eqn.1" pat_env g_branch; - - (* 4. Lift the when clause to a logical condition. *) - (* It is used in step 5 (a) below, and in step 6 (d) to build the branch guard *) - let when_condition = match when_clause with - | None -> None - | Some w -> Some <| U.mk_eq2 U_zero U.t_bool w U.exp_true_bool in - - - (* logically the same as step 5(a), *) - - - (* 5. Building the guard for this branch; *) - (* the caller assembles the guards for each branch into an exhaustiveness check. *) - (* *) - (* (a) Compute the branch guard for each arm of a disjunctive pattern. *) - (* expressed in terms for discriminators and projectors on sub-terms of scrutinee *) - (* for the benefit of the caller, who works in an environment without the pattern-bound vars *) - (* *) - (* (b) Type-check the condition computed in 5 (a) *) - (* *) - (* (c) Make a disjunctive formula out of 5 (b) for each arm of the pattern *) - (* *) - (* (d) Strengthen 5 (c) with the when condition, if there is one *) - - (* This used to be step 6 earlier (after weakening the branch VC with scrutinee equality with pattern etc.) *) - (* but we do it before that now, since for layered effects, we use this branch guard to weaken *) - - (* TODO: this seems very similar to constructing the terms for pattern variables in terms of scrutinee *) - (* and projectors. Can this be done in tc_pat too? That should save us repeated iterations on the pattern *) - - (* The branch guard is a boolean expression *) - - let branch_guard = - if not (Env.should_verify env) - then U.exp_true_bool - else (* 5 (a) *) - let rec build_branch_guard (scrutinee_tm:option term) (pattern:pat) pat_exp : list typ = - let discriminate scrutinee_tm f = - let is_induc, datacons = Env.datacons_of_typ env (Env.typ_of_datacon env f.v) in - (* Why the `not is_induc`? We may be checking an exception pattern. See issue #1535. *) - if not is_induc || List.length datacons > 1 - then - let discriminator = U.mk_discriminator f.v in - match Env.try_lookup_lid env discriminator with - | None -> [] // We don't use the discriminator if we are typechecking it - | _ -> - let disc = S.fvar discriminator None in - [mk_Tm_app disc [as_arg scrutinee_tm] scrutinee_tm.pos] - else [] - in - - let fail () = - failwith (BU.format3 "tc_eqn: Impossible (%s) %s (%s)" - (Range.string_of_range pat_exp.pos) - (show pat_exp) - (tag_of pat_exp)) in - - let rec head_constructor t = match t.n with - | Tm_fvar fv -> fv.fv_name - | Tm_uinst(t, _) -> head_constructor t - | _ -> fail () in - - let force_scrutinee () = - match scrutinee_tm with - | None -> failwith (BU.format2 "Impossible (%s): scrutinee of match is not defined %s" - (Range.string_of_range pattern.p) - (show pattern)) - | Some t -> t - in - let pat_exp = SS.compress pat_exp |> U.unmeta in - match pattern.v, pat_exp.n with - | _, Tm_name _ -> - [] //no guard for variables; they always match - - | _, Tm_constant Const_unit -> - [] //no guard for the unit pattern; it's a singleton - - | Pat_constant _c, Tm_constant c -> - - [U.mk_decidable_eq (tc_constant env pat_exp.pos c) (force_scrutinee ()) pat_exp] - - | Pat_constant (FStar.Const.Const_int(_, Some _)), _ -> - //machine integer pattern, cf. #1572 - let _, t, _ = - let env, _ = Env.clear_expected_typ env in - env.typeof_tot_or_gtot_term env pat_exp true - in - [U.mk_decidable_eq t (force_scrutinee ()) pat_exp] - - | Pat_cons (_, _, []), Tm_uinst _ - | Pat_cons (_, _, []), Tm_fvar _ -> - //nullary pattern - let f = head_constructor pat_exp in - if not (Env.is_datacon env f.v) - then failwith "Impossible: nullary patterns must be data constructors" - else discriminate (force_scrutinee ()) (head_constructor pat_exp) - - | Pat_cons (_, _, pat_args), Tm_app {hd=head; args} -> - //application pattern - let f = head_constructor head in - if not (Env.is_datacon env f.v) - || List.length pat_args <> List.length args - then failwith "Impossible: application patterns must be fully-applied data constructors" - else let sub_term_guards = - List.zip pat_args args |> - List.mapi (fun i ((pi, _), (ei, _)) -> - let projector = Env.lookup_projector env f.v i in - //NS: TODO ... should this be a marked as a record projector? But it doesn't matter for extraction - let scrutinee_tm = - match Env.try_lookup_lid env projector with - | None -> - None //no projector, e.g., because we are actually typechecking the projector itself - | _ -> - let proj = S.fvar (Ident.set_lid_range projector f.p) None in - Some (mk_Tm_app proj [as_arg (force_scrutinee())] f.p) - in - build_branch_guard scrutinee_tm pi ei) |> - List.flatten - in - discriminate (force_scrutinee()) f @ sub_term_guards - - | Pat_dot_term _, _ -> [] - //a non-pattern sub-term computed via unification; no guard needeed since it is from a dot pattern - - | _ -> failwith (BU.format2 "Internal error: unexpected elaborated pattern: %s and pattern expression %s" - (show pattern) - (show pat_exp)) - in - - (* 5 (b) *) - let build_and_check_branch_guard scrutinee_tm pattern pat = - if not (Env.should_verify env) - then U.exp_true_bool //if we're not verifying, then don't even bother building it - else let t = U.mk_and_l <| build_branch_guard scrutinee_tm pattern pat in - if Debug.high () then - BU.print1 "tc_eqn: branch guard before typechecking: %s\n" (show t); - let t, _, _ = tc_check_tot_or_gtot_term scrutinee_env t U.t_bool None in - if Debug.high () then - BU.print1 "tc_eqn: branch guard after typechecking: %s\n" (show t); - //NS: discarding the guard here means that the VC is not fully type-checked - // and may contain unresolved unification variables, e.g. FIXME! - t in - - (* 5 (c) *) - let branch_guard = build_and_check_branch_guard (Some scrutinee_tm) pattern norm_pat_exp in - - (* 5 (d) *) - let branch_guard = - match when_condition with - | None -> branch_guard - | Some w -> U.mk_and branch_guard w in - - branch_guard - in - - if Debug.extreme () then - BU.print1 "tc_eqn: branch guard : %s\n" (show branch_guard); - - (* 6 (a). Build equality conditions between the pattern and the scrutinee *) - (* (b). Weaken the VCs of the branch and when clause with the equalities from 6 (a) and the when condition *) - (* For layered effects, we weaken with the branch guard instead *) - (* (c). Close the VCs so that they no longer have the pattern-bound variables occurring free in them *) - (* For wp-based effects, closing means applying the close_wp combinator *) - (* For layered effects, we substitute the pattern variables with their projector expressions applied *) - (* to the scrutinee *) - - let effect_label, cflags, maybe_return_c, g_when, g_branch = - (* (a) eqs are equalities between the scrutinee and the pattern *) - let eqs = - let env = pat_env in - if not (Env.should_verify env) - then None - else let e = SS.compress pat_exp in - Some (U.mk_eq2 (env.universe_of env pat_t) pat_t scrutinee_tm e) in - match ret_opt with - | Some (_, (Inr c, _, _)) -> - let pat_bs = List.map S.mk_binder pat_bvs in - let g_branch = - (if eqs |> is_some - then TcComm.weaken_guard_formula g_branch (eqs |> must) - else g_branch) - |> Env.close_guard env pat_bs - |> TcUtil.close_guard_implicits env true pat_bs in - U.comp_effect_name c, None, None, g_when, g_branch - | _ -> - let c, g_branch = TcUtil.strengthen_precondition None env branch_exp c g_branch in - - //g_branch is trivial, its logical content is now incorporated within c - - // - // Working towards closing the branches comp with the pattern variables - // For effects with close combinator defined, we will use that - // For other effects, we will close with substituting pattern variables with - // corresponding projector expressions applied to the scrutinee - // - let close_branch_with_substitutions = - let m = c.eff_name |> Env.norm_eff_name env in - Env.is_layered_effect env m && - None? (m |> Env.get_effect_decl env |> U.get_layered_close_combinator) in - - (* (b) *) - let c_weak, g_when_weak = - if close_branch_with_substitutions - then - //branch_guard is a boolean, so b2t it - let c = TcUtil.weaken_precondition pat_env c (NonTrivial (U.b2t branch_guard)) in - c, mzero //use branch guard for weakening - else - match eqs, when_condition with - | _ when not (Env.should_verify pat_env) -> - c, g_when - - | None, None -> - c, g_when - - | Some f, None -> - let gf = NonTrivial f in - let g = Env.guard_of_guard_formula gf in - TcUtil.weaken_precondition pat_env c gf, - Env.imp_guard g g_when - - | Some f, Some w -> - let g_f = NonTrivial f in - let g_fw = NonTrivial (U.mk_conj f w) in - TcUtil.weaken_precondition pat_env c g_fw, - Env.imp_guard (Env.guard_of_guard_formula g_f) g_when - - | None, Some w -> - let g_w = NonTrivial w in - let g = Env.guard_of_guard_formula g_w in - TcUtil.weaken_precondition pat_env c g_w, - g_when in - - (* (c) *) - let binders = List.map S.mk_binder pat_bvs in - let maybe_return_c_weak should_return = - let c_weak = - if should_return && - TcComm.is_pure_or_ghost_lcomp c_weak - then TcUtil.maybe_assume_result_eq_pure_term (Env.push_bvs scrutinee_env pat_bvs) branch_exp c_weak - else c_weak in - if close_branch_with_substitutions - then - let _ = - if !dbg_LayeredEffects - then BU.print_string "Typechecking pat_bv_tms ...\n" in - - (* - * AR: typecheck the pat_bv_tms, to resolve implicits etc. - * - * recall that pat_bv_tms are terms that are definitionally equal to the pat_bvs - * but are in terms of projectors on the scrutinee term - * these will be used to substitute pat bvs in the computation type - * of the corresponding branch - * - * a pat_bv_tm's expected type is the sort of the corresponding pat bv - * however, we need to be careful about dependent pat bvs of the like (a:Type) (x:a) - * - * so when we typecheck a pat_bv_tm with expected type as corresponding pat_bv.sort, - * we substitute the already seen pat bvs with their pat bv tms in the sort - *) - - //first apply the pat_bv_tms to the scrutinee term - let pat_bv_tms = pat_bv_tms |> List.map (fun pat_bv_tm -> - mk_Tm_app pat_bv_tm [scrutinee_tm |> S.as_arg] Range.dummyRange) in - - let pat_bv_tms = - //note, we are explicitly setting lax = true, since these terms apply projectors - //which we know are sound as per the branch guard, but hard to convince the typechecker - //AR: TODO: should we instead do the non-lax typechecking but drop the logical payload in the guard? - let env = { (Env.push_bv env scrutinee) with admit = true } in - List.fold_left2 (fun (substs, acc) pat_bv_tm bv -> - let expected_t = SS.subst substs bv.sort in - //we also substitute in the pat_bv_tm, since in the case of nested patterns, - // there are cases when sorts of the bound scrutinee variable for the inner pattern vars - // contains some outer patterns vars - let pat_bv_tm = - pat_bv_tm - |> SS.subst substs - |> tc_trivial_guard (Env.set_expected_typ env expected_t) - |> fst in - substs@[NT (bv, pat_bv_tm)], acc@[pat_bv_tm]) ([], []) pat_bv_tms pat_bvs - - |> snd - |> List.map (N.normalize [Env.Beta] env) in - - let _ = - if !dbg_LayeredEffects - then BU.print2 "tc_eqn: typechecked pat_bv_tms=%s (pat_bvs=%s)\n" - (show pat_bv_tms) (show pat_bvs) - in - - c_weak - |> TcComm.apply_lcomp (fun c -> c) (fun g -> match eqs with - | None -> g - | Some eqs -> TcComm.weaken_guard_formula g eqs) - |> TcUtil.close_layered_lcomp_with_substitutions (Env.push_bv env scrutinee) pat_bvs pat_bv_tms - else if c_weak.eff_name |> Env.norm_eff_name env |> Env.is_layered_effect env - then TcUtil.close_layered_lcomp_with_combinator (Env.push_bv env scrutinee) pat_bvs c_weak - else TcUtil.close_wp_lcomp (Env.push_bv env scrutinee) pat_bvs c_weak in - - c_weak.eff_name, - Some c_weak.cflags, - Some maybe_return_c_weak, - Env.close_guard env binders g_when_weak, - guard_pat ++ g_branch in - - let guard = g_when ++ g_branch in - - if Debug.high () - then BU.print1 "Carrying guard from match: %s\n" <| guard_to_string env guard; - - SS.close_branch (pattern, when_clause, branch_exp), - branch_guard, //expressed in terms of discriminators and projectors on scrutinee---does not contain the pattern-bound variables - effect_label, - cflags, - maybe_return_c, //closed already---does not contain free pattern-bound variables - TcUtil.close_guard_implicits env false (List.map S.mk_binder pat_bvs) guard, - erasable - -(******************************************************************************) -(* Checking a top-level, non-recursive let-binding: *) -(* top-level let's may be generalized, if they are not annotated *) -(* the body of a top-level let is always ()---no point in checking it *) -(******************************************************************************) -and check_top_level_let env e = - let env = instantiate_both env in - match e.n with - | Tm_let {lbs=(false, [lb]); body=e2} -> -(*open*) let e1, univ_vars, c1, g1, annotated = check_let_bound_def true env lb in - (* Maybe generalize its type *) - let g1, e1, univ_vars, c1 = - if annotated && not env.generalize - then g1, N.reduce_uvar_solutions env e1, univ_vars, c1 - else let g1 = Rel.solve_deferred_constraints env g1 |> Rel.resolve_implicits env in - let comp1, g_comp1 = lcomp_comp c1 in - let g1 = g1 ++ g_comp1 in - let _, univs, e1, c1, gvs = List.hd (Gen.generalize env false [lb.lbname, e1, comp1]) in - let g1 = Rel.resolve_generalization_implicits env g1 in - let g1 = map_guard g1 <| N.normalize [Env.Beta; Env.DoNotUnfoldPureLets; Env.CompressUvars; Env.NoFullNorm; Env.Exclude Env.Zeta] env in - let g1 = abstract_guard_n gvs g1 in - g1, e1, univs, TcComm.lcomp_of_comp c1 - in - - (* Check that it doesn't have a top-level effect; warn if it does *) - let e2, c1 = - let ok, c1 = TcUtil.check_top_level env g1 c1 in //check that it has no effect and a trivial pre-condition - if ok - then e2, c1 - else ( - if not (Options.ml_ish ()) then - Err.warn_top_level_effect (Env.get_range env); // maybe warn - mk (Tm_meta {tm=e2; meta=Meta_desugared Masked_effect}) e2.pos, c1 //and tag it as masking an effect - ) - in - - (* Unfold all @tcnorm subterms in the binding *) - if Debug.medium () then - BU.print1 "Let binding BEFORE tcnorm: %s\n" (show e1); - let e1 = if Options.tcnorm () then - N.normalize [Env.UnfoldAttr [Const.tcnorm_attr]; - Env.Exclude Env.Beta; Env.Exclude Env.Zeta; - Env.NoFullNorm; Env.DoNotUnfoldPureLets] env e1 - else e1 - in - if Debug.medium () then - BU.print1 "Let binding AFTER tcnorm: %s\n" (show e1); - - (* - * AR: comp for the whole `let x = e1 in e2`, where e2 = () - * - * we have already checked that e1 has the right effect args - * for it to be a top-level effect - * - * for wp effects that means trivial precondition, - * and for indexed effects that means as per the top_level_effect - * specification - * - * Since the top-level effect is masked at this point, - * we just return Tot unit and the final computation type - * - * Note that for top-level lets, this cres is not used anyway - *) - let cres = S.mk_Total S.t_unit in - -(*close*)let lb = U.close_univs_and_mk_letbinding None lb.lbname univ_vars (U.comp_result c1) (U.comp_effect_name c1) e1 lb.lbattrs lb.lbpos in - mk (Tm_let {lbs=(false, [lb]); body=e2}) - e.pos, - TcComm.lcomp_of_comp cres, - mzero - - | _ -> failwith "Impossible: check_top_level_let: not a let" - -and maybe_intro_smt_lemma env lem_typ c2 = - if U.is_smt_lemma lem_typ - then let universe_of_binders bs = - let _, us = - List.fold_left - (fun (env, us) b -> - let u = env.universe_of env b.binder_bv.sort in - let env = Env.push_binders env [b] in - env, u::us) - (env, []) - bs - in - List.rev us - in - let quant = U.smt_lemma_as_forall lem_typ universe_of_binders in - TcUtil.weaken_precondition env c2 (NonTrivial quant) - else c2 - -(******************************************************************************) -(* Checking an inner non-recursive let-binding: *) -(* inner let's are never implicitly generalized *) -(* let x = e1 in e2 is logically a bind (lift c1) (\x. lift c2) *) -(* except that we also need to strengthen it with well-formedness checks *) -(* and a check that x does not escape its scope in the type of c2 *) -(******************************************************************************) -and check_inner_let env e = - let env = instantiate_both env in - match e.n with - | Tm_let {lbs=(false, [lb]); body=e2} -> - let env = {env with top_level=false} in - let e1, _, c1, g1, annotated = check_let_bound_def false (Env.clear_expected_typ env |> fst) lb in - let pure_or_ghost = TcComm.is_pure_or_ghost_lcomp c1 in - let is_inline_let = BU.for_some (U.is_fvar FStar.Parser.Const.inline_let_attr) lb.lbattrs in - let _ = - if is_inline_let - && not (pure_or_ghost || Env.is_erasable_effect env c1.eff_name) //inline let is allowed on erasable effects - then raise_error e1 - Errors.Fatal_ExpectedPureExpression - (BU.format2 "Definitions marked @inline_let are expected to be pure or ghost; \ - got an expression \"%s\" with effect \"%s\"" - (show e1) - (show c1.eff_name)) - in - let x = {BU.left lb.lbname with sort=c1.res_typ} in - let xb, e2 = SS.open_term [S.mk_binder x] e2 in - let xbinder = List.hd xb in - let x = xbinder.binder_bv in - let env_x = Env.push_bv env x in - let e2, c2, g2 = - (* - * AR: we typecheck e2 and fold its guard into the returned lcomp - * so that the guard is under the equality x=e1 when we later (in the next line) - * bind c1 and c2 - *) - tc_term env_x e2 - |> (fun (e2, c2, g2) -> - let c2, g2 = TcUtil.strengthen_precondition - ((fun _ -> Errors.mkmsg "folding guard g2 of e2 in the lcomp") |> Some) - env_x - e2 - c2 - g2 in - e2, c2, g2) in - //g2 now has no logical payload after this, it may have unresolved implicits - let c2 = maybe_intro_smt_lemma env_x c1.res_typ c2 in - let cres = - TcUtil.maybe_return_e2_and_bind - e1.pos - env - (Some e1) - c1 - e2 - (Some x, c2) - in - //AR: TODO: FIXME: monadic annotations need to be adjusted for polymonadic binds - let e1 = TcUtil.maybe_lift env e1 c1.eff_name cres.eff_name c1.res_typ in - let e2 = TcUtil.maybe_lift env e2 c2.eff_name cres.eff_name c2.res_typ in - let lb = - let attrs = - let add_inline_let = //add inline_let if - not is_inline_let && //the letbinding is not already inline_let, and - ((pure_or_ghost && //either it is pure/ghost with unit type, or - U.is_unit c1.res_typ) || - (Env.is_erasable_effect env c1.eff_name && //c1 is erasable and cres is not - not (Env.is_erasable_effect env cres.eff_name))) in - if add_inline_let - then U.inline_let_attr::lb.lbattrs - else lb.lbattrs in - U.mk_letbinding (Inl x) [] c1.res_typ cres.eff_name e1 attrs lb.lbpos in - let e = mk (Tm_let {lbs=(false, [lb]); body=SS.close xb e2}) e.pos in - let e = TcUtil.maybe_monadic env e cres.eff_name cres.res_typ in - - //AR: for layered effects, solve any deferred constraints first - // we can do it at other calls to close_guard_implicits too, but let's see - let g2 = TcUtil.close_guard_implicits env - (cres.eff_name |> Env.norm_eff_name env |> Env.is_layered_effect env) - xb g2 in - let guard = g1 ++ g2 in - - if Option.isSome (Env.expected_typ env) - then (let tt = Env.expected_typ env |> Option.get |> fst in - if !dbg_Exports - then BU.print2 "Got expected type from env %s\ncres.res_typ=%s\n" - (show tt) - (show cres.res_typ); - e, cres, guard) - else (* no expected type; check that x doesn't escape it's scope *) - (let t, g_ex = check_no_escape None env [x] cres.res_typ in - if !dbg_Exports - then BU.print2 "Checked %s has no escaping types; normalized to %s\n" - (show cres.res_typ) - (show t); - e, ({cres with res_typ=t}), g_ex ++ guard) - - | _ -> failwith "Impossible (inner let with more than one lb)" - -(******************************************************************************) -(* top-level let rec's may be generalized, if they are not annotated *) -(******************************************************************************) -and check_top_level_let_rec env top = - let env = instantiate_both env in - match top.n with - | Tm_let {lbs=(true, lbs); body=e2} -> - (* replace bound variables in terms and of universes with new names (free variables) *) -(*open*) let lbs, e2 = SS.open_let_rec lbs e2 in - - (* expected types for top level definitions are stored in the lbs and we therefore just - * remove previous, unrelated, expected type in env - * the expected type is defined within lbs - * *) - let env0, topt = Env.clear_expected_typ env in - let lbs, rec_env, g_t = build_let_rec_env true env0 lbs in - (* now we type check each let rec *) - let lbs, g_lbs = check_let_recs rec_env lbs in - let g_lbs = g_t ++ g_lbs |> Rel.solve_deferred_constraints env |> Rel.resolve_implicits env in - - let all_lb_names = lbs |> List.map (fun lb -> right lb.lbname) |> Some in - - let lbs, g_lbs = - if not env.generalize - then - let lbs = - lbs |> List.map (fun lb -> - (* TODO : Should we gather the fre univnames ? e.g. (TcUtil.gather_free_univnames env e1)@lb.lbunivs *) - let lbdef = N.reduce_uvar_solutions env lb.lbdef in - if lb.lbunivs = [] - then lb - else U.close_univs_and_mk_letbinding all_lb_names lb.lbname lb.lbunivs lb.lbtyp lb.lbeff lbdef lb.lbattrs lb.lbpos) - in - lbs, g_lbs (* g_lbs untouched *) - else - let ecs = Gen.generalize env true (lbs |> List.map (fun lb -> - lb.lbname, - lb.lbdef, - S.mk_Total lb.lbtyp)) - in - let lbs = List.map2 (fun (x, uvs, e, c, gvs) lb -> - U.close_univs_and_mk_letbinding - all_lb_names - x - uvs - (U.comp_result c) - (U.comp_effect_name c) - e - lb.lbattrs - lb.lbpos) - ecs - lbs - in - (* discharge generalization uvars *) - let g_lbs = Rel.resolve_generalization_implicits env g_lbs in - lbs, g_lbs - in - - let cres = TcComm.lcomp_of_comp <| S.mk_Total t_unit in - -(*close*) let lbs, e2 = SS.close_let_rec lbs e2 in - Rel.discharge_guard env g_lbs |> Rel.force_trivial_guard env; - mk (Tm_let {lbs=(true, lbs); body=e2}) top.pos, - cres, - mzero - - | _ -> failwith "Impossible: check_top_level_let_rec: not a let rec" - -(******************************************************************************) -(* inner let rec's are never implicitly generalized *) -(******************************************************************************) -and check_inner_let_rec env top = - let env = instantiate_both env in - match top.n with - | Tm_let {lbs=(true, lbs); body=e2} -> -(*open*) let lbs, e2 = SS.open_let_rec lbs e2 in - - let env0, topt = Env.clear_expected_typ env in - let lbs, rec_env, g_t = build_let_rec_env false env0 lbs in - let lbs, g_lbs = check_let_recs rec_env lbs |> (fun (lbs, g) -> lbs, g_t ++ g) in - - let env, lbs = lbs |> BU.fold_map (fun env lb -> - let x = {left lb.lbname with sort=lb.lbtyp} in - let lb = {lb with lbname=Inl x} in - let env = Env.push_let_binding env lb.lbname ([], lb.lbtyp) in //local let recs are not universe polymorphic - env, lb) env in - - let bvs = lbs |> List.map (fun lb -> left (lb.lbname)) in - - let e2, cres, g2 = tc_term env e2 in - let cres = - List.fold_right - (fun lb cres -> maybe_intro_smt_lemma env lb.lbtyp cres) - lbs - cres - in - let cres = TcUtil.maybe_assume_result_eq_pure_term env e2 cres in - let cres = TcComm.lcomp_set_flags cres [SHOULD_NOT_INLINE] in //cf. issue #1362 - let guard = g_lbs ++ (Env.close_guard env (List.map S.mk_binder bvs) g2) in - // - //We need to close bvs in cres - //If cres is a wp-effect, then we can use the close combinator - //If it is a layered effect, for now we check that bvs don't escape - //The code below only checks effect args, - // return type is checked at the end of this function - // - let cres = - if cres.eff_name |> Env.norm_eff_name env - |> Env.is_layered_effect env - then let bvss = from_list bvs in - TcComm.apply_lcomp - (fun c -> - if (c |> U.comp_effect_args - |> List.existsb (fun (t, _) -> - t |> Free.names - |> inter bvss - |> is_empty - |> not)) - then raise_error top Errors.Fatal_EscapedBoundVar - "One of the inner let recs escapes in the \ - effect argument(s), try adding a type \ - annotation" - else c) - (fun g -> g) - cres - else TcUtil.close_wp_lcomp env bvs cres in - let tres = norm env cres.res_typ in - let cres = {cres with res_typ=tres} in - - let guard = - let bs = lbs |> List.map (fun lb -> S.mk_binder (BU.left lb.lbname)) in - TcUtil.close_guard_implicits env false bs guard - in - -(*close*) let lbs, e2 = SS.close_let_rec lbs e2 in - let e = mk (Tm_let {lbs=(true, lbs); body=e2}) top.pos in - - begin match topt with - | Some _ -> e, cres, guard //we have an annotation - | None -> - let tres, g_ex = check_no_escape None env bvs tres in - let cres = {cres with res_typ=tres} in - e, cres, g_ex ++ guard - end - - | _ -> failwith "Impossible: check_inner_let_rec: not a let rec" - -(******************************************************************************) -(* build an environment with recursively bound names. *) -(* refining the types of those names with decreases clauses is done in tc_abs *) -(******************************************************************************) -and build_let_rec_env _top_level env lbs : list letbinding & env_t & guard_t = - let env0 = env in - let termination_check_enabled (attrs:list attribute) (lbname:lbname) (lbdef:term) (lbtyp:term) - : option (int & term) // when enabled returns recursion arity; - // plus the term elaborated with implicit binders - // (TODO: move all that logic to desugaring) - = - if Options.ml_ish () then None else - - let lbtyp0 = lbtyp in - let actuals, body, body_lc = abs_formals lbdef in - - //add implicit binders, in case, for instance - //lbtyp is of the form x:'a -> t - //lbdef is of the form (fun x -> t) - //in which case, we need to add (#'a:Type) to the actuals - //See the handling in Tm_abs case of tc_value, roughly line 703 (location may have changed since this comment was written) - let actuals = TcUtil.maybe_add_implicit_binders (Env.set_expected_typ env lbtyp) actuals in - let nactuals = List.length actuals in - - (* Grab binders from the type. At most as many as we have in - * the abstraction. *) - let formals, c = N.get_n_binders env nactuals lbtyp in - - // TODO: There's a similar error in check_let_recs, would be nice - // to remove this one. - if List.isEmpty formals || List.isEmpty actuals then - raise_error lbtyp Errors.Fatal_RecursiveFunctionLiteral // TODO: GM: maybe point to the one that's actually empty? - (BU.format3 "Only function literals with arrow types can be defined recursively; got (%s) %s : %s" - (tag_of lbdef) - (show lbdef) - (show lbtyp)); - - let nformals = List.length formals in - - (* `nformals` is exactly the arity of recursion. It is either - * the amount of binders we traversed until we ran into an effect - * in the expected type, or the total amount of binders in the - * abstraction's body. So we can just check the effect `c` for - * totality. Another way of seeing this check is that we take - * the minimum amount of binders from the actuals and formals. *) - if U.has_attribute attrs Const.admit_termination_lid then ( - log_issue env Warning_WarnOnUse ("Admitting termination of " ^ show lbname); - None - ) else if U.comp_effect_name c |> Env.lookup_effect_quals env |> List.contains TotalEffect then - Some (nformals, U.abs actuals body body_lc) - else - None - in - let check_annot univ_vars t = - let env0 = Env.push_univ_vars env0 univ_vars in - let t, _, g = tc_check_tot_or_gtot_term ({env0 with check_uvars=true}) t (fst <| U.type_u()) None in - env0, g |> Rel.resolve_implicits env |> Rel.discharge_guard env0, t - in - let lbs, env, g = List.fold_left (fun (lbs, env, g_acc) lb -> - let univ_vars, lbtyp, lbdef, check_t = TcUtil.extract_let_rec_annotation env lb in - let env = Env.push_univ_vars env univ_vars in //no polymorphic recursion on universes - let g, lbtyp = - if not check_t - then g_acc, lbtyp - else let _, g, t = check_annot univ_vars lbtyp in - g_acc ++ g, t - in - // AR: This code (below) also used to have && Env.should_verify env - // i.e. when lax checking it was adding lbname in the second branch - // this was a problem for 2-phase, if an implicit type was the type of a let rec (see bug056) - // Removed that check. Rest of the code relies on env.letrecs = [] - let lb, env = - match termination_check_enabled lb.lbattrs lb.lbname lbdef lbtyp with - // AR: we need to add the binding of the let rec after adding the - // binders of the lambda term, and so, here we just note in the env that - // we are typechecking a let rec, the recursive binding will be added in - // tc_abs adding universes here so that when we add the let binding, we - // can add a typescheme with these universes - | Some (arity, lbdef) -> - if Debug.extreme () - then BU.print2 "termination_check_enabled returned arity: %s and lbdef: %s\n" - (string_of_int arity) (show lbdef); - let lb = {lb with lbtyp=lbtyp; lbunivs=univ_vars; lbdef=lbdef} in - let env = {env with letrecs=(lb.lbname, arity, lbtyp, univ_vars)::env.letrecs} in - lb, env - | None -> - let lb = {lb with lbtyp=lbtyp; lbunivs=univ_vars; lbdef=lbdef} in - lb, Env.push_let_binding env lb.lbname (univ_vars, lbtyp) - in - lb::lbs, env, g) - ([], env, mzero) - lbs in - List.rev lbs, env, g - -and check_let_recs env lbts = - let lbs, gs = lbts |> List.map (fun lb -> - (* here we set the expected type in the environment to the annotated expected type - * and use it in order to type check the body of the lb - * *) - let bs, t, lcomp = abs_formals lb.lbdef in - //see issue #1017 - match bs with - | [] -> raise_error (S.range_of_lbname lb.lbname) - Errors.Fatal_RecursiveFunctionLiteral - (BU.format2 - "Only function literals may be defined recursively; %s is defined to be %s" - (show lb.lbname) - (show lb.lbdef)) - | _ -> (); - - (* HACK ALERT: arity - * - * We build a Tm_abs node with exactly [arity] binders, - * and put the rest in another node in the body, so `tc_abs` - * will do the right thing when computing a decreases clauses. - *) - let arity = match Env.get_letrec_arity env lb.lbname with - | Some n -> n - | None -> List.length bs (* Keep the node as-is *) - in - let bs0, bs1 = List.splitAt arity bs in - let def = - if List.isEmpty bs1 - then U.abs bs0 t lcomp - else let inner = U.abs bs1 t lcomp in - let inner = SS.close bs0 inner in - let bs0 = SS.close_binders bs0 in - S.mk (Tm_abs {bs=bs0;body=inner;rc_opt=None}) inner.pos - // ^ using abs again would flatten the abstraction - in - (* / HACK *) - - let lb = { lb with lbdef = def } in - - let e, c, g = tc_tot_or_gtot_term (Env.set_expected_typ env lb.lbtyp) lb.lbdef in - if not (TcComm.is_total_lcomp c) - then raise_error e Errors.Fatal_UnexpectedGTotForLetRec "Expected let rec to be a Tot term; got effect GTot"; - (* replace the body lb.lbdef with the type checked body e with elaboration on monadic application *) - let lb = U.mk_letbinding lb.lbname lb.lbunivs lb.lbtyp Const.effect_Tot_lid e lb.lbattrs lb.lbpos in - lb, g) |> List.unzip in - lbs, msum gs - - -(******************************************************************************) -(* Several utility functions follow *) -(******************************************************************************) -and check_let_bound_def top_level env lb - : term (* checked lbdef *) - & univ_names (* univ_vars, if any *) - & lcomp (* type of lbdef *) - & guard_t (* well-formedness of lbtyp *) - & bool (* true iff lbtyp was annotated *) - = - let env1, _ = Env.clear_expected_typ env in - let e1 = lb.lbdef in - - (* 1. extract the annotation of the let-bound term, e1, if any *) - let topt, wf_annot, univ_vars, univ_opening, env1 = check_lbtyp top_level env lb in - - if not top_level && univ_vars <> [] - then raise_error e1 Errors.Fatal_UniversePolymorphicInnerLetBound "Inner let-bound definitions cannot be universe polymorphic"; - - (* 2. type-check e1 *) - (* Only toplevel terms should have universe openings *) - assert ( top_level || List.length univ_opening = 0 ); - let e1 = subst univ_opening e1 in - let e1, c1, g1 = tc_maybe_toplevel_term ({env1 with top_level=top_level}) e1 in - - (* and strengthen its VC with and well-formedness condition on its annotated type *) - //NS: Maybe redundant strengthen - // let c1, guard_f = c1, wf_annot in - let c1, guard_f = TcUtil.strengthen_precondition - (Some (fun () -> return_all Err.ill_kinded_type)) - (Env.set_range env1 e1.pos) e1 c1 wf_annot in - let g1 = g1 ++ guard_f in - - if Debug.extreme () - then BU.print3 "checked let-bound def %s : %s guard is %s\n" - (show lb.lbname) - (TcComm.lcomp_to_string c1) - (Rel.guard_to_string env g1); - - e1, univ_vars, c1, g1, Option.isSome topt - - -(* Extracting the type of non-recursive let binding *) -and check_lbtyp top_level env lb : option typ (* checked version of lb.lbtyp, if it was not Tm_unknown *) - & guard_t (* well-formedness condition for that type *) - & univ_names (* explicit universe variables, if any *) - & list subst_elt (* subtistution of the opened universes *) - & Env.env (* env extended with univ_vars *) - = - Errors.with_ctx "While checking type annotation of a letbinding" (fun () -> - let t = SS.compress lb.lbtyp in - match t.n with - | Tm_unknown -> - //if lb.lbunivs <> [] then failwith "Impossible: non-empty universe variables but the type is unknown"; //AR: do we need this check? this situation arises in phase 2 - let univ_opening, univ_vars = univ_var_opening lb.lbunivs in - None, mzero, univ_vars, univ_opening, Env.push_univ_vars env univ_vars - - | _ -> - let univ_opening, univ_vars = univ_var_opening lb.lbunivs in - let t = subst univ_opening t in - let env1 = Env.push_univ_vars env univ_vars in - if top_level - && not (env.generalize) //clearly, x has an annotated type ... could env.generalize ever be true here? - //yes. x may not have a val declaration, only an inline annotation - //so, not (env.generalize) signals that x has been declared as val x : t, and t has already been checked - then Some t, mzero, univ_vars, univ_opening, Env.set_expected_typ env1 t //t has already been kind-checked - else //we have an inline annotation - let k, _ = U.type_u () in - let t, _, g = tc_check_tot_or_gtot_term env1 t k None in - if Debug.medium () - then BU.print2 "(%s) Checked type annotation %s\n" - (Range.string_of_range (range_of_lbname lb.lbname)) - (show t); - let t = norm env1 t in - Some t, g, univ_vars, univ_opening, Env.set_expected_typ env1 t - ) - -and tc_binder env ({binder_bv=x;binder_qual=imp;binder_positivity=pqual;binder_attrs=attrs}) = - let tu, u = U.type_u () in - if Debug.extreme () - then BU.print3 "Checking binder %s:%s at type %s\n" - (show x) - (show x.sort) - (show tu); - let t, _, g = tc_check_tot_or_gtot_term env x.sort tu None in //ghost effect ok in the types of binders - let imp, g' = - match imp with - | Some (Meta tau) -> - let tau, _, g = tc_tactic t_unit t_unit env tau in - Some (Meta tau), g - | _ -> imp, mzero - in - let g_attrs, attrs = tc_attributes env attrs in - let g = g ++ g_attrs in - check_erasable_binder_attributes env attrs t; - let x = S.mk_binder_with_attrs ({x with sort=t}) imp pqual attrs in - if Debug.high () - then BU.print2 "Pushing binder %s at type %s\n" (show x.binder_bv) (show t); - x, push_binding env x, g, u - -and tc_binders env bs = - if Debug.extreme () then - BU.print1 "Checking binders %s\n" (show bs); - let rec aux env bs = match bs with - | [] -> [], env, mzero, [] - | b::bs -> - let b, env', g, u = tc_binder env b in - let bs, env', g', us = aux env' bs in - b::bs, env', g ++ (Env.close_guard_univs [u] [b] g'), u::us in - aux env bs - -and tc_smt_pats en pats = - let tc_args en args : Syntax.args & guard_t = - //an optimization for checking arguments in cases where we know that their types match the types of the corresponding formal parameters - //notably, this is used when checking the application (?u x1 ... xn). NS: which we do not currently do! - List.fold_right (fun (t, imp) (args, g) -> - t |> check_no_smt_theory_symbols en; - let t, _, g' = tc_term en t in - (t, imp)::args, g ++ g') - args ([], mzero) in - List.fold_right (fun p (pats, g) -> - let args, g' = tc_args en p in - (args::pats, g ++ g')) pats ([], mzero) - -and tc_tot_or_gtot_term_maybe_solve_deferred (env:env) (e:term) (msg:option string) (solve_deferred:bool) -: term & lcomp & guard_t -= let e, c, g = tc_maybe_toplevel_term env e in - if TcComm.is_tot_or_gtot_lcomp c - then e, c, g - else let g = - if solve_deferred - then Rel.solve_deferred_constraints env g - else g in - let c, g_c = TcComm.lcomp_comp c in - let c = norm_c env c in - let target_comp, allow_ghost = - if TcUtil.is_pure_effect env (U.comp_effect_name c) - then S.mk_Total (U.comp_result c), false - else S.mk_GTotal (U.comp_result c), true in - match Rel.sub_comp env c target_comp with - | Some g' -> e, TcComm.lcomp_of_comp target_comp, g ++ (g_c ++ g') - | _ -> - if allow_ghost - then Err.expected_ghost_expression e.pos e c msg - else Err.expected_pure_expression e.pos e c msg - -and tc_tot_or_gtot_term' (env:env) (e:term) (msg:option string) -: term & lcomp & guard_t -= tc_tot_or_gtot_term_maybe_solve_deferred env e msg true - -and tc_tot_or_gtot_term env e = tc_tot_or_gtot_term' env e None - -and tc_check_tot_or_gtot_term env e t (msg : option string) -: term & lcomp & guard_t -= let env = Env.set_expected_typ env t in - tc_tot_or_gtot_term' env e msg - -and tc_trivial_guard env t = - let t, c, g = tc_tot_or_gtot_term env t in - Rel.force_trivial_guard env g; - t,c - -and tc_attributes (env:env_t) (attrs : list term) : guard_t & list term = - List.fold_left - (fun (g, attrs) attr -> - let attr', _, g' = tc_tot_or_gtot_term env attr in - g ++ g', attr' :: attrs) - (mzero, []) - (List.rev attrs) - -let tc_check_trivial_guard env t k = - let t, _, g = tc_check_tot_or_gtot_term env t k None in - Rel.force_trivial_guard env g; - t - - -(* type_of_tot_term env e : e', t, g - checks that env |- e' : Tot t' <== g - i.e., e' is an elaboration of e - such that it has type Tot t - subject to the guard g - in environment env - *) -let typeof_tot_or_gtot_term env e must_tot = - if !dbg_RelCheck then BU.print1 "Checking term %s\n" (show e); - //let env, _ = Env.clear_expected_typ env in - let env = {env with top_level=false; letrecs=[]} in - let t, c, g = - try tc_tot_or_gtot_term env e - with Error(e, msg, r, ctx) when r = Range.dummyRange -> - raise (Error (e, msg, Env.get_range env, ctx)) - in - if must_tot then - let c = N.maybe_ghost_to_pure_lcomp env c in - if TcComm.is_total_lcomp c - then t, c.res_typ, g - else raise_error env Errors.Fatal_UnexpectedImplictArgument (BU.format1 "Implicit argument: Expected a total term; got a ghost term: %s" (show e)) - else t, c.res_typ, g - -let level_of_type_fail (env:Env.env) (e:term) (t:string) = - raise_error env Errors.Fatal_UnexpectedTermType [ - Errors.text (BU.format2 "Expected a type; got %s of type %s" (show e) t) - ] - -let level_of_type env e t = - let rec aux retry t = - match (U.unrefine t).n with - | Tm_type u -> u - | _ -> - if retry - then let t = Normalize.normalize [Env.UnfoldUntil delta_constant] env t in - aux false t - else let t_u, u = U.type_u() in - let env = {env with admit = true} in - (* - * AR: This is a little harsh - * If t is a uvar, then this prevents t to be inferred as something more - * precise than Type, e.g. eqtype - * So ideally, we could here generate a subtyping constraint - * But for that this function needs to return a guard, and - * the guard needs to be accounted for in the callers - *) - let g = FStar.TypeChecker.Rel.teq env t t_u in - begin match g.guard_f with - | NonTrivial f -> - level_of_type_fail env e (show t) - | _ -> - Rel.force_trivial_guard env g - end; - u - in aux true t - -(* - * This helper routine computes the result type of applying args to - * a term of type t_hd - * - * It assumes that the terms are ghost/pure and well-typed in env - * -- to be called from fastpath type checking routines ONLY - *) - -(* private *) -let rec apply_well_typed env (t_hd:typ) (args:args) : option typ = - if List.length args = 0 - then Some t_hd - else match (N.unfold_whnf env t_hd).n with - | Tm_arrow {bs; comp=c} -> - let n_args = List.length args in - let n_bs = List.length bs in - let bs, args, t, remaining_args = (* bs (opened), args (length args = length bs), comp result type, remaining args *) - if n_args < n_bs - then let bs, rest = BU.first_N n_args bs in - let t = S.mk (Tm_arrow {bs=rest; comp=c}) t_hd.pos in - let bs, c = SS.open_comp bs (S.mk_Total t) in - bs, args, U.comp_result c, [] - else let bs, c = SS.open_comp bs c in - let args, remaining_args = List.splitAt n_bs args in - bs, args, U.comp_result c, remaining_args in - let subst = List.map2 (fun b a -> NT (b.binder_bv, fst a)) bs args in - let t = SS.subst subst t in - apply_well_typed env t remaining_args - | Tm_refine {b=x} -> apply_well_typed env x.sort args - | Tm_ascribed {tm=t} -> apply_well_typed env t args - | _ -> None - - -(* universe_of_aux env e: - During type-inference, we build terms like WPs for which we need to compute - explicit universe instantiations. - - This is generally called from within TypeChecker.Util - when building WPs. For example, in building (return_value t e), - u=universe_of env t. - - We don't aim to compute a precise type for e. - Rather, we look to compute the universe level of e's type, - presuming that e must have type Type - - For instance, if e is an application (f _), we compute the type of f to be bs -> C, - and we take the universe level of e to be (level_of (comp_result C)), - disregarding the arguments of f. - - This a returns a term of shape Tm_type at the wanted universe. - *) -let rec universe_of_aux env e : term = - match (SS.compress e).n with - | Tm_bvar _ - | Tm_unknown - | Tm_delayed _ -> - failwith ("TcTerm.universe_of:Impossible (bvar/unknown/lazy) " ^ - (show e)) - //normalize let bindings away and then compute the universe - | Tm_let _ -> - let e = N.normalize [] env e in - universe_of_aux env e - //we expect to compute (Type u); so an abstraction always fails - | Tm_abs {bs; body=t} -> - level_of_type_fail env e "arrow type" - //these next few cases are easy; we just use the type stored at the node - | Tm_uvar (u, s) -> SS.subst' s (U.ctx_uvar_typ u) - | Tm_meta {tm=t} -> universe_of_aux env t - | Tm_name n -> - let (t, _rng) = Env.lookup_bv env n in - t - | Tm_fvar fv -> - let (_, t), _ = Env.lookup_lid env fv.fv_name.v in - t - | Tm_lazy i -> universe_of_aux env (U.unfold_lazy i) - | Tm_ascribed {asc=(Inl t, _, _)} -> t - | Tm_ascribed {asc=(Inr c, _, _)} -> U.comp_result c - //also easy, since we can quickly recompute the type - | Tm_type u -> S.mk (Tm_type (U_succ u)) e.pos - | Tm_quoted _ -> U.ktype0 - | Tm_constant sc -> tc_constant env e.pos sc - //slightly subtle, since fv is a type-scheme; instantiate it with us - | Tm_uinst({n=Tm_fvar fv}, us) -> - let (us', t), _ = Env.lookup_lid env fv.fv_name.v in - if List.length us <> List.length us' then - raise_error env Errors.Fatal_UnexpectedNumberOfUniverse - "Unexpected number of universe instantiations"; - (* FIXME: this logic is repeated from the Tm_uinst case of tc_value *) - List.iter2 - (fun ul ur -> match ul, ur with - | U_unif u'', _ -> UF.univ_change u'' ur - // TODO: more cases? we cannot get U_succ or U_max here I believe... - | U_name n1, U_name n2 when Ident.ident_equals n1 n2 -> () - | _ -> - raise_error env Errors.Fatal_IncompatibleUniverse - (BU.format3 "Incompatible universe application for %s, expected %s got %s\n" - (show fv) (show ul) (show ur))) - us' us; - t - - | Tm_uinst _ -> - failwith "Impossible: Tm_uinst's head must be an fvar" - //the refinement formula plays no role in the universe computation; so skip it - | Tm_refine {b=x} -> universe_of_aux env x.sort - //U_max(univ_of bs, univ_of c) - | Tm_arrow {bs; comp=c} -> - let bs, c = SS.open_comp bs c in - let env = Env.push_binders env bs in - let us = List.map (fun ({binder_bv=b}) -> level_of_type env b.sort (universe_of_aux env b.sort)) bs in - let u_res = - let res = U.comp_result c in - level_of_type env res (universe_of_aux env res) in - let u_c = c |> TcUtil.universe_of_comp env u_res in - let u = N.normalize_universe env (S.U_max (u_c::us)) in - S.mk (Tm_type u) e.pos - //See the comment at the top of this function; we just compute the universe of hd's result type - | Tm_app {hd; args} -> - let rec type_of_head retry env hd args = - let hd = SS.compress hd in - match hd.n with - | Tm_unknown - | Tm_bvar _ - | Tm_delayed _ -> - failwith "Impossible: universe_of_aux: Tm_app: unexpected head type" - | Tm_fvar _ - | Tm_name _ - | Tm_uvar _ - | Tm_uinst _ - | Tm_ascribed _ - | Tm_refine _ - | Tm_constant _ - | Tm_arrow _ - | Tm_meta _ - | Tm_type _ -> - universe_of_aux env hd, args - | Tm_match {brs=b::_} -> //AR: TODO: use return annotation? Or the residual_comp? - let (pat, _, tm) = SS.open_branch b in - let bvs = Syntax.pat_bvs pat in - let hd, args' = U.head_and_args tm in - type_of_head retry (Env.push_bvs env bvs) hd (args'@args) - | _ when retry -> - //head is either an abs, so we have a beta-redex - // or a let, - // GM: NOTE: not using hd and args here, - // this is calling itself with the `e` from - // universe_of_aux and splitting it again. - let e = N.normalize [Env.Beta; Env.DoNotUnfoldPureLets] env e in - let hd, args = U.head_and_args e in - type_of_head false env hd args - | _ -> - let env, _ = Env.clear_expected_typ env in - let env = {env with admit=true; top_level=false} in - if !dbg_UniverseOf - then BU.print2 "%s: About to type-check %s\n" - (Range.string_of_range (Env.get_range env)) - (show hd); - let _, ({res_typ=t}), g = tc_term env hd in - Rel.solve_deferred_constraints env g |> ignore; - t, args - in - let t, args = type_of_head true env hd args in - (match apply_well_typed env t args with - | Some t -> t - | None -> level_of_type_fail env e (show t)) - | Tm_match {brs=b::_} -> //AR: TODO: use return annotation? - let (pat, _, tm) = SS.open_branch b in - let bvs = Syntax.pat_bvs pat in - universe_of_aux (Env.push_bvs env bvs) tm - - | Tm_match {brs=[]} -> //AR: TODO: use return annotation? - level_of_type_fail env e "empty match cases" - - -let universe_of env e = Errors.with_ctx "While attempting to compute a universe level" (fun () -> - if Debug.high () then - BU.print1 "Calling universe_of_aux with %s {\n" (show e); - def_check_scoped e.pos "universe_of entry" env e; - - let r = universe_of_aux env e in - if Debug.high () then - BU.print1 "Got result from universe_of_aux = %s }\n" (show r); - level_of_type env e r -) - -let tc_tparams env0 (tps:binders) : (binders & Env.env & universes) = - let tps, env, g, us = tc_binders env0 tps in - Rel.force_trivial_guard env0 g; - tps, env, us - -//////////////////////////////////////////////////////////////////////////////// - -let rec __typeof_tot_or_gtot_term_fastpath (env:env) (t:term) (must_tot:bool) : option typ = - let mk_tm_type u = S.mk (Tm_type u) t.pos in - let effect_ok k = (not must_tot) || (N.non_info_norm env k) in - let t = SS.compress t in - match t.n with - | Tm_delayed _ - | Tm_bvar _ -> failwith ("Impossible: " ^ show t) - - (* Can't (easily) do this one efficiently, just return None *) - | Tm_constant (Const_reify _) - | Tm_constant (Const_reflect _) -> None - - //For the following nodes, use the universe_of_aux function - //since these are already Tot, we don't need to check the must_tot flag - // GM: calling universe_of for Tm_name/Tv_fvar here is a bit shady, - // sinc the variable may not represent a type. However universe_of_aux - // will currently simply return the sort of bv from the environment, - // be it Tm_type or not, and that's what we want here. - | Tm_name _ - | Tm_fvar _ - | Tm_uinst _ - | Tm_constant _ - | Tm_type _ - | Tm_arrow _ -> universe_of_aux env t |> Some - - | Tm_lazy i -> - __typeof_tot_or_gtot_term_fastpath env (U.unfold_lazy i) must_tot - - | Tm_abs {bs; body; rc_opt=Some ({residual_effect=eff; residual_typ=tbody})} -> //AR: maybe keep residual univ too? - let mk_comp = - if Ident.lid_equals eff Const.effect_Tot_lid - then Some S.mk_Total - else if Ident.lid_equals eff Const.effect_GTot_lid - then Some S.mk_GTotal - else None - in - bind_opt mk_comp (fun f -> - let tbody = - match tbody with - | Some _ -> tbody - | None -> - let bs, body = SS.open_term bs body in - BU.map_opt (__typeof_tot_or_gtot_term_fastpath (Env.push_binders env bs) body false) (SS.close bs) in - bind_opt tbody (fun tbody -> - let bs, tbody = SS.open_term bs tbody in - let u = universe_of (Env.push_binders env bs) tbody in - Some (U.arrow bs (f tbody)))) - - | Tm_abs _ -> None - - | Tm_refine {b=x} -> __typeof_tot_or_gtot_term_fastpath env x.sort must_tot - - (* Unary operators. Explicitly curry extra arguments *) - | Tm_app {hd={n=Tm_constant Const_range_of}; args=a::hd::rest} -> - let rest = hd::rest in //no 'as' clauses in F* yet, so we need to do this ugliness - let unary_op, _ = U.head_and_args t in - let head = mk (Tm_app {hd=unary_op; args=[a]}) (Range.union_ranges unary_op.pos (fst a).pos) in - let t = mk (Tm_app {hd=head; args=rest}) t.pos in - __typeof_tot_or_gtot_term_fastpath env t must_tot - - (* Binary operators *) - | Tm_app {hd={n=Tm_constant Const_set_range_of}; args=a1::a2::hd::rest} -> - let rest = hd::rest in //no 'as' clauses in F* yet, so we need to do this ugliness - let unary_op, _ = U.head_and_args t in - let head = mk (Tm_app {hd=unary_op; args=[a1; a2]}) (Range.union_ranges unary_op.pos (fst a1).pos) in - let t = mk (Tm_app {hd=head; args=rest}) t.pos in - __typeof_tot_or_gtot_term_fastpath env t must_tot - - | Tm_app {hd={n=Tm_constant Const_range_of}; args=[_]} -> - Some (t_range) - - | Tm_app {hd={n=Tm_constant Const_set_range_of}; args=[(t, _); _]} -> - __typeof_tot_or_gtot_term_fastpath env t must_tot - - | Tm_app {hd; args} -> - let t_hd = __typeof_tot_or_gtot_term_fastpath env hd must_tot in - bind_opt t_hd (fun t_hd -> - bind_opt (apply_well_typed env t_hd args) (fun t -> - if (effect_ok t) || - (List.for_all (fun (a, _) -> __typeof_tot_or_gtot_term_fastpath env a must_tot |> is_some) args) - then Some t - else None)) - - | Tm_ascribed {tm=t; asc=(Inl k, _, _)} -> - if effect_ok k - then Some k - else __typeof_tot_or_gtot_term_fastpath env t must_tot - - | Tm_ascribed {asc=(Inr c, _, _)} -> - let k = U.comp_result c in - if (not must_tot) || - (c |> U.comp_effect_name |> Env.norm_eff_name env |> lid_equals Const.effect_PURE_lid) || - (N.non_info_norm env k) - then Some k - else None - - | Tm_uvar (u, s) -> if not must_tot then Some (SS.subst' s (U.ctx_uvar_typ u)) else None - - | Tm_quoted (tm, qi) -> if not must_tot then Some (S.t_term) else None - - | Tm_meta {tm=t} -> __typeof_tot_or_gtot_term_fastpath env t must_tot - - | Tm_match {rc_opt=Some rc} -> rc.residual_typ - - | Tm_let {lbs=(false, [lb]); body} -> - let x = BU.left lb.lbname in - let xb, body = SS.open_term [S.mk_binder x] body in - let xbinder = List.hd xb in - let x = xbinder.binder_bv in - let env_x = Env.push_bv env x in - let t = __typeof_tot_or_gtot_term_fastpath env_x body must_tot in - bind_opt t (fun t -> - let t = FStar.Syntax.Subst.close xb t in - Some t) - - | Tm_match _ -> None //unelaborated matches - | Tm_let _ -> None //recursive lets - | Tm_unknown - | _ -> failwith ("Impossible! (" ^ (tag_of t) ^ ")") - -(* - Pre-condition: exists k. env |- t : (G)Tot k - i.e., t is well-typed in env at some type k - - And t is Tot or GTot, meaning if it is PURE or GHOST, its wp has been accounted for - (which is the case for the terms in the unifier) - - Returns (Some k), if it can find k quickly and the effect of t is consistent with must_tot - - If either the type cannot be computed or effect does not match with must_tot, returns None - - A possible restructuring would be to treat these two (type and effect) separately - in the return type -*) -let typeof_tot_or_gtot_term_fastpath (env:env) (t:term) (must_tot:bool) : option typ = - def_check_scoped t.pos "fastpath" env t; - Errors.with_ctx - "In a call to typeof_tot_or_gtot_term_fastpath" - (fun () -> __typeof_tot_or_gtot_term_fastpath env t must_tot) - -(* - * Precondition: G |- t : Tot _ or G |- t : GTot _ - * Meaning, even if t is PURE or GHOST, its wp has been accounted for already, - * which is the case for terms in the unifier - * - * It returns either PURE or GHOST (or None if fast path fails) - *) -let rec effectof_tot_or_gtot_term_fastpath (env:env) (t:term) : option lident = - match (SS.compress t).n with - | Tm_delayed _ | Tm_bvar _ -> failwith "Impossible!" - - | Tm_name _ -> Const.effect_PURE_lid |> Some - | Tm_lazy _ -> Const.effect_PURE_lid |> Some - | Tm_fvar _ -> Const.effect_PURE_lid |> Some - | Tm_uinst _ -> Const.effect_PURE_lid |> Some - | Tm_constant _ -> Const.effect_PURE_lid |> Some - | Tm_type _ -> Const.effect_PURE_lid |> Some - | Tm_abs _ -> Const.effect_PURE_lid |> Some - | Tm_arrow _ -> Const.effect_PURE_lid |> Some - | Tm_refine _ -> Const.effect_PURE_lid |> Some - - | Tm_app {hd; args} -> - let join_effects eff1 eff2 = - let eff1, eff2 = Env.norm_eff_name env eff1, Env.norm_eff_name env eff2 in - let pure, ghost = Const.effect_PURE_lid, Const.effect_GHOST_lid in - - if lid_equals eff1 pure && lid_equals eff2 pure then Some pure - else if (lid_equals eff1 ghost || lid_equals eff1 pure) - && (lid_equals eff2 ghost || lid_equals eff2 pure) - then Some ghost - else None in - - bind_opt (effectof_tot_or_gtot_term_fastpath env hd) (fun eff_hd -> - bind_opt (List.fold_left (fun eff_opt arg -> - bind_opt eff_opt (fun eff -> - bind_opt (effectof_tot_or_gtot_term_fastpath env (fst arg)) - (join_effects eff))) (Some eff_hd) args) (fun eff_hd_and_args -> - bind_opt (typeof_tot_or_gtot_term_fastpath env hd true) (fun t_hd -> - let rec maybe_arrow t = - let t = N.unfold_whnf env t in - match t.n with - | Tm_arrow _ -> t - | Tm_refine {b=x} -> maybe_arrow x.sort - | Tm_ascribed {tm=t} -> maybe_arrow t - | _ -> t in - match (maybe_arrow t_hd).n with - | Tm_arrow {bs; comp=c} -> - let eff_app = - if List.length args < List.length bs - then Const.effect_PURE_lid - else U.comp_effect_name c in - join_effects eff_hd_and_args eff_app - | _ -> None))) - | Tm_ascribed {tm=t; asc=(Inl _, _, _)} -> effectof_tot_or_gtot_term_fastpath env t - | Tm_ascribed {asc=(Inr c, _, _)} -> - let c_eff = c |> U.comp_effect_name |> Env.norm_eff_name env in - if lid_equals c_eff Const.effect_PURE_lid || - lid_equals c_eff Const.effect_GHOST_lid - then Some c_eff - else None - | Tm_uvar _ -> None - | Tm_quoted _ -> None - | Tm_meta {tm=t} -> effectof_tot_or_gtot_term_fastpath env t - | Tm_match _ -> None - | Tm_let _ -> None - | Tm_unknown -> None - | Tm_uinst _ -> None - | _ -> None diff --git a/src/typechecker/FStar.TypeChecker.TcTerm.fsti b/src/typechecker/FStar.TypeChecker.TcTerm.fsti deleted file mode 100644 index 9145f8380f6..00000000000 --- a/src/typechecker/FStar.TypeChecker.TcTerm.fsti +++ /dev/null @@ -1,58 +0,0 @@ -(* - Copyright 2008-2016 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.TypeChecker.TcTerm -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar -open FStar.Compiler -open FStar.TypeChecker -open FStar.TypeChecker.Env -open FStar.Compiler.Util -open FStar.Ident -open FStar.Syntax -open FStar.Syntax.Syntax -open FStar.Syntax.Subst -open FStar.Syntax.Util -open FStar.Const -open FStar.TypeChecker.Rel -open FStar.TypeChecker.Common - -val level_of_type: env -> term -> typ -> universe //the term argument is for error reporting only -val tc_constant: env -> FStar.Compiler.Range.range -> sconst -> typ -val tc_binders: env -> binders -> binders & env & guard_t & universes -val tc_term: env -> term -> term & lcomp & guard_t -val tc_maybe_toplevel_term: env -> term -> term & lcomp & guard_t -val tc_comp: env -> comp -> comp & universe & guard_t -val tc_pat : Env.env -> typ -> pat -> pat & list bv & list term & Env.env & term & term & guard_t & bool -val typeof_tot_or_gtot_term: env -> term -> must_tot:bool -> term & typ & guard_t -val universe_of: env -> term -> universe -val typeof_tot_or_gtot_term_fastpath: env -> term -> Env.must_tot -> option typ - -val tc_tot_or_gtot_term: env -> term -> term & lcomp & guard_t -//the last string argument is the reason to be printed in the error message -//pass "" if NA -val tc_check_tot_or_gtot_term: env -> term -> typ -> option string -> term & lcomp & guard_t -val tc_tactic : typ -> typ -> env -> term -> term & lcomp & guard_t -val tc_trivial_guard: env -> term -> term & lcomp -val tc_attributes: env -> list term -> guard_t & list term -val tc_check_trivial_guard: env -> term -> term -> term - -val value_check_expected_typ: env -> term -> either typ lcomp -> guard_t -> term & lcomp & guard_t -val check_expected_effect: env -> use_eq:bool -> option comp -> (term & comp) -> term & comp & guard_t -val comp_check_expected_typ: env -> term -> lcomp -> term & lcomp & guard_t - -val tc_tparams: env_t -> binders -> (binders & Env.env & universes) diff --git a/src/typechecker/FStar.TypeChecker.TermEqAndSimplify.fst b/src/typechecker/FStar.TypeChecker.TermEqAndSimplify.fst deleted file mode 100644 index 5ca57a20870..00000000000 --- a/src/typechecker/FStar.TypeChecker.TermEqAndSimplify.fst +++ /dev/null @@ -1,555 +0,0 @@ -module FStar.TypeChecker.TermEqAndSimplify -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler -open FStar.Compiler.Util -open FStar.Syntax -open FStar.Const -open FStar.Ident -open FStar.TypeChecker.Env -open FStar.Syntax.Syntax -open FStar.Syntax.Util -module SS = FStar.Syntax.Subst -module U = FStar.Syntax.Util -module PC = FStar.Parser.Const -module S = FStar.Syntax.Syntax -module BU = FStar.Compiler.Util - -open FStar.Class.Tagged -open FStar.Class.Show - -// Functions that we specially treat as injective, to make normalization -// (particularly of decidable equality) better. We should make sure they -// are actually proved to be injective. -let injectives = - ["FStar.Int8.int_to_t"; - "FStar.Int16.int_to_t"; - "FStar.Int32.int_to_t"; - "FStar.Int64.int_to_t"; - "FStar.Int128.int_to_t"; - "FStar.UInt8.uint_to_t"; - "FStar.UInt16.uint_to_t"; - "FStar.UInt32.uint_to_t"; - "FStar.UInt64.uint_to_t"; - "FStar.UInt128.uint_to_t"; - "FStar.SizeT.uint_to_t"; - "FStar.Int8.__int_to_t"; - "FStar.Int16.__int_to_t"; - "FStar.Int32.__int_to_t"; - "FStar.Int64.__int_to_t"; - "FStar.Int128.__int_to_t"; - "FStar.UInt8.__uint_to_t"; - "FStar.UInt16.__uint_to_t"; - "FStar.UInt32.__uint_to_t"; - "FStar.UInt64.__uint_to_t"; - "FStar.UInt128.__uint_to_t"; - "FStar.SizeT.__uint_to_t"; - ] - -// Compose two eq_result injectively, as in a pair -let eq_inj r s = - match r, s with - | Equal, Equal -> Equal - | NotEqual, _ - | _, NotEqual -> NotEqual - | _, _ -> Unknown - -// Promote a bool to eq_result, conservatively. -let equal_if = function - | true -> Equal - | _ -> Unknown - -// Promote a bool to an eq_result, taking a false to bet NotEqual. -// This is only useful for fully decidable equalities. -// Use with care, see note about Const_real below and #2806. -let equal_iff = function - | true -> Equal - | _ -> NotEqual - -// Compose two equality results, NOT assuming a NotEqual implies anything. -// This is useful, e.g., for checking the equality of applications. Consider -// f x ~ g y -// if f=g and x=y then we know these two expressions are equal, but cannot say -// anything when either result is NotEqual or Unknown, hence this returns Unknown -// in most cases. -// The second comparison is thunked for efficiency. -let eq_and r s = - if r = Equal && s () = Equal - then Equal - else Unknown - -(* Precondition: terms are well-typed in a common environment, or this can return false positives *) -let rec eq_tm (env:env_t) (t1:term) (t2:term) : eq_result = - let t1 = canon_app t1 in - let t2 = canon_app t2 in - let equal_data (f1:S.fv) (args1:Syntax.args) (f2:fv) (args2:Syntax.args) (n_parms:int) = - // we got constructors! we know they are injective and disjoint, so we can do some - // good analysis on them - if fv_eq f1 f2 - then ( - let n1 = List.length args1 in - let n2 = List.length args2 in - if n1 = n2 && n_parms <= n1 - then ( - let parms1, args1 = List.splitAt n_parms args1 in - let parms2, args2 = List.splitAt n_parms args2 in - let eq_arg_list as1 as2 = - List.fold_left2 - (fun acc (a1, q1) (a2, q2) -> - //if q1 <> q2 - //then failwith (U.format1 "Arguments of %s mismatch on implicit qualifier\n" - // (Ident.string_of_lid f1.fv_name.v)); - //NS: 05/06/2018 ...this does not always hold - // it's been succeeding because the assert is disabled in the non-debug builds - //assert (q1 = q2); - eq_inj acc (eq_tm env a1 a2)) - Equal - as1 - as2 - in - eq_arg_list args1 args2 - ) - else Unknown - ) - else NotEqual - in - let qual_is_inj = function - | Some Data_ctor - | Some (Record_ctor _) -> true - | _ -> false - in - let heads_and_args_in_case_both_data : option (S.fv & args & S.fv & args & int) = - let head1, args1 = t1 |> unmeta |> head_and_args in - let head2, args2 = t2 |> unmeta |> head_and_args in - match (un_uinst head1).n, (un_uinst head2).n with - | Tm_fvar f, Tm_fvar g - when qual_is_inj f.fv_qual && - qual_is_inj g.fv_qual -> ( - match Env.num_datacon_non_injective_ty_params env (lid_of_fv f) with - | Some n -> Some (f, args1, g, args2, n) - | _ -> None - ) - | _ -> None - in - let t1 = unmeta t1 in - let t2 = unmeta t2 in - match t1.n, t2.n with - // We sometimes compare open terms, as we get alpha-equivalence - // for free. - | Tm_bvar bv1, Tm_bvar bv2 -> - equal_if (bv1.index = bv2.index) - - | Tm_lazy _, _ -> eq_tm env (unlazy t1) t2 - | _, Tm_lazy _ -> eq_tm env t1 (unlazy t2) - - | Tm_name a, Tm_name b -> - equal_if (bv_eq a b) - - | _ when heads_and_args_in_case_both_data |> Some? -> //matches only when both are data constructors - heads_and_args_in_case_both_data |> must |> (fun (f, args1, g, args2, n) -> - equal_data f args1 g args2 n - ) - - | Tm_fvar f, Tm_fvar g -> equal_if (fv_eq f g) - - | Tm_uinst(f, us), Tm_uinst(g, vs) -> - // If the fvars and universe instantiations match, then Equal, - // otherwise Unknown. - eq_and (eq_tm env f g) (fun () -> equal_if (eq_univs_list us vs)) - - | Tm_constant (Const_range _), Tm_constant (Const_range _) -> - // Ranges should be opaque, even to the normalizer. c.f. #1312 - Unknown - - | Tm_constant (Const_real r1), Tm_constant (Const_real r2) -> - // We cannot decide equality of reals. Use a conservative approach here. - // If the strings match, they are equal, otherwise we don't know. If this - // goes via the eq_iff case below, it will falsely claim that "1.0R" and - // "01.R" are different, since eq_const does not canonizalize the string - // representations. - equal_if (r1 = r2) - - | Tm_constant c, Tm_constant d -> - // NOTE: this relies on the fact that eq_const *correctly decides* - // semantic equality of constants. This needs some care. For instance, - // since integers are represented by a string, eq_const needs to take care - // of ignoring leading zeroes, and match 0 with -0. An exception to this - // are real number literals (handled above). See #2806. - // - // Currently (24/Jan/23) this seems to be correctly implemented, but - // updates should be done with care. - equal_iff (eq_const c d) - - | Tm_uvar (u1, ([], _)), Tm_uvar (u2, ([], _)) -> - equal_if (Unionfind.equiv u1.ctx_uvar_head u2.ctx_uvar_head) - - | Tm_app {hd=h1; args=args1}, Tm_app {hd=h2; args=args2} -> - begin match (un_uinst h1).n, (un_uinst h2).n with - | Tm_fvar f1, Tm_fvar f2 when fv_eq f1 f2 && List.mem (string_of_lid (lid_of_fv f1)) injectives -> - equal_data f1 args1 f2 args2 0 - - | _ -> // can only assert they're equal if they syntactically match, nothing else - eq_and (eq_tm env h1 h2) (fun () -> eq_args env args1 args2) - end - - | Tm_match {scrutinee=t1; brs=bs1}, Tm_match {scrutinee=t2; brs=bs2} -> //AR: note: no return annotations - if List.length bs1 = List.length bs2 - then List.fold_right (fun (b1, b2) a -> eq_and a (fun () -> branch_matches env b1 b2)) - (List.zip bs1 bs2) - (eq_tm env t1 t2) - else Unknown - - | Tm_type u, Tm_type v -> - equal_if (eq_univs u v) - - | Tm_quoted (t1, q1), Tm_quoted (t2, q2) -> - // NOTE: we do NOT ever provide a meaningful result for quoted terms. Even - // if term_eq (the syntactic equality) returns true, that does not mean we - // can present the equality to userspace since term_eq ignores the names - // of binders, but the view exposes them. Hence, we simply always return - // Unknown. We do not seem to rely anywhere on simplifying equalities of - // quoted literals. See also #2806. - Unknown - - | Tm_refine {b=t1; phi=phi1}, Tm_refine {b=t2; phi=phi2} -> - eq_and (eq_tm env t1.sort t2.sort) (fun () -> eq_tm env phi1 phi2) - - (* - * AR: ignoring residual comp here, that's an ascription added by the typechecker - * do we care if that's different? - *) - | Tm_abs {bs=bs1; body=body1}, Tm_abs {bs=bs2; body=body2} - when List.length bs1 = List.length bs2 -> - - eq_and (List.fold_left2 (fun r b1 b2 -> eq_and r (fun () -> eq_tm env b1.binder_bv.sort b2.binder_bv.sort)) - Equal bs1 bs2) - (fun () -> eq_tm env body1 body2) - - | Tm_arrow {bs=bs1; comp=c1}, Tm_arrow {bs=bs2; comp=c2} - when List.length bs1 = List.length bs2 -> - eq_and (List.fold_left2 (fun r b1 b2 -> eq_and r (fun () -> eq_tm env b1.binder_bv.sort b2.binder_bv.sort)) - Equal bs1 bs2) - (fun () -> eq_comp env c1 c2) - - | _ -> Unknown - -and eq_antiquotations (env:env_t) a1 a2 = - // Basically this; - // List.fold_left2 (fun acc t1 t2 -> eq_inj acc (eq_tm t1 t2)) Equal a1 a2 - // but lazy and handling lists of different size - match a1, a2 with - | [], [] -> Equal - | [], _ - | _, [] -> NotEqual - | t1::a1, t2::a2 -> - match eq_tm env t1 t2 with - | NotEqual -> NotEqual - | Unknown -> - (match eq_antiquotations env a1 a2 with - | NotEqual -> NotEqual - | _ -> Unknown) - | Equal -> eq_antiquotations env a1 a2 - -and branch_matches env b1 b2 = - let related_by f o1 o2 = - match o1, o2 with - | None, None -> true - | Some x, Some y -> f x y - | _, _ -> false - in - let (p1, w1, t1) = b1 in - let (p2, w2, t2) = b2 in - if eq_pat p1 p2 - then begin - // We check the `when` branches too, even if unsupported for now - if eq_tm env t1 t2 = Equal && related_by (fun t1 t2 -> eq_tm env t1 t2 = Equal) w1 w2 - then Equal - else Unknown - end - else Unknown - -and eq_args env (a1:args) (a2:args) : eq_result = - match a1, a2 with - | [], [] -> Equal - | (a, _)::a1, (b, _)::b1 -> - (match eq_tm env a b with - | Equal -> eq_args env a1 b1 - | _ -> Unknown) - | _ -> Unknown - -and eq_comp env (c1 c2:comp) : eq_result = - match c1.n, c2.n with - | Total t1, Total t2 - | GTotal t1, GTotal t2 -> - eq_tm env t1 t2 - | Comp ct1, Comp ct2 -> - eq_and (equal_if (eq_univs_list ct1.comp_univs ct2.comp_univs)) - (fun _ -> - eq_and (equal_if (Ident.lid_equals ct1.effect_name ct2.effect_name)) - (fun _ -> - eq_and (eq_tm env ct1.result_typ ct2.result_typ) - (fun _ -> eq_args env ct1.effect_args ct2.effect_args))) - //ignoring cflags - | _ -> NotEqual - -let eq_tm_bool e t1 t2 = eq_tm e t1 t2 = Equal - -let simplify (debug:bool) (env:env_t) (tm:term) : term = - let w t = {t with pos=tm.pos} in - let simp_t t = - // catch annotated subformulae too - match (U.unmeta t).n with - | Tm_fvar fv when S.fv_eq_lid fv PC.true_lid -> Some true - | Tm_fvar fv when S.fv_eq_lid fv PC.false_lid -> Some false - | _ -> None - in - let rec args_are_binders args bs = - match args, bs with - | (t, _)::args, b::bs -> - begin match (SS.compress t).n with - | Tm_name bv' -> S.bv_eq b.binder_bv bv' && args_are_binders args bs - | _ -> false - end - | [], [] -> true - | _, _ -> false - in - let is_applied (bs:binders) (t : term) : option bv = - if debug then - BU.print2 "WPE> is_applied %s -- %s\n" (show t) (tag_of t); - let hd, args = U.head_and_args_full t in - match (SS.compress hd).n with - | Tm_name bv when args_are_binders args bs -> - if debug then - BU.print3 "WPE> got it\n>>>>top = %s\n>>>>b = %s\n>>>>hd = %s\n" - (show t) - (show bv) - (show hd); - Some bv - | _ -> None - in - let is_applied_maybe_squashed (bs : binders) (t : term) : option bv = - if debug then - BU.print2 "WPE> is_applied_maybe_squashed %s -- %s\n" (show t) (tag_of t); - match is_squash t with - - | Some (_, t') -> is_applied bs t' - | _ -> begin match is_auto_squash t with - | Some (_, t') -> is_applied bs t' - | _ -> is_applied bs t - end - in - let is_const_match (phi : term) : option bool = - match (SS.compress phi).n with - (* Trying to be efficient, but just checking if they all agree *) - (* Note, if we wanted to do this for any term instead of just True/False - * we need to open the terms *) - | Tm_match {brs=br::brs} -> - let (_, _, e) = br in - let r = begin match simp_t e with - | None -> None - | Some b -> if List.for_all (fun (_, _, e') -> simp_t e' = Some b) brs - then Some b - else None - end - in - r - | _ -> None - in - let maybe_auto_squash t = - if U.is_sub_singleton t - then t - else U.mk_auto_squash U_zero t - in - let squashed_head_un_auto_squash_args t = - //The head of t is already a squashed operator, e.g. /\ etc. - //no point also squashing its arguments if they're already in U_zero - let maybe_un_auto_squash_arg (t,q) = - match U.is_auto_squash t with - | Some (U_zero, t) -> - //if we're squashing from U_zero to U_zero - // then just remove it - t, q - | _ -> - t,q - in - let head, args = U.head_and_args t in - let args = List.map maybe_un_auto_squash_arg args in - S.mk_Tm_app head args t.pos - in - let rec clearly_inhabited (ty : typ) : bool = - match (U.unmeta ty).n with - | Tm_uinst (t, _) -> clearly_inhabited t - | Tm_arrow {comp=c} -> clearly_inhabited (U.comp_result c) - | Tm_fvar fv -> - let l = S.lid_of_fv fv in - (Ident.lid_equals l PC.int_lid) - || (Ident.lid_equals l PC.bool_lid) - || (Ident.lid_equals l PC.string_lid) - || (Ident.lid_equals l PC.exn_lid) - | _ -> false - in - let simplify arg = (simp_t (fst arg), arg) in - match (SS.compress tm).n with - | Tm_app {hd={n=Tm_uinst({n=Tm_fvar fv}, _)}; args} - | Tm_app {hd={n=Tm_fvar fv}; args} -> - if S.fv_eq_lid fv PC.squash_lid - then squashed_head_un_auto_squash_args tm - else if S.fv_eq_lid fv PC.and_lid - then match args |> List.map simplify with - | [(Some true, _); (_, (arg, _))] - | [(_, (arg, _)); (Some true, _)] -> maybe_auto_squash arg - | [(Some false, _); _] - | [_; (Some false, _)] -> w U.t_false - | _ -> squashed_head_un_auto_squash_args tm - else if S.fv_eq_lid fv PC.or_lid - then match args |> List.map simplify with - | [(Some true, _); _] - | [_; (Some true, _)] -> w U.t_true - | [(Some false, _); (_, (arg, _))] - | [(_, (arg, _)); (Some false, _)] -> maybe_auto_squash arg - | _ -> squashed_head_un_auto_squash_args tm - else if S.fv_eq_lid fv PC.imp_lid - then match args |> List.map simplify with - | [_; (Some true, _)] - | [(Some false, _); _] -> w U.t_true - | [(Some true, _); (_, (arg, _))] -> maybe_auto_squash arg - | [(_, (p, _)); (_, (q, _))] -> - if U.term_eq p q - then w U.t_true - else squashed_head_un_auto_squash_args tm - | _ -> squashed_head_un_auto_squash_args tm - else if S.fv_eq_lid fv PC.iff_lid - then match args |> List.map simplify with - | [(Some true, _) ; (Some true, _)] - | [(Some false, _) ; (Some false, _)] -> w U.t_true - | [(Some true, _) ; (Some false, _)] - | [(Some false, _) ; (Some true, _)] -> w U.t_false - | [(_, (arg, _)) ; (Some true, _)] - | [(Some true, _) ; (_, (arg, _))] -> maybe_auto_squash arg - | [(_, (arg, _)) ; (Some false, _)] - | [(Some false, _) ; (_, (arg, _))] -> maybe_auto_squash (U.mk_neg arg) - | [(_, (p, _)); (_, (q, _))] -> - if U.term_eq p q - then w U.t_true - else squashed_head_un_auto_squash_args tm - | _ -> squashed_head_un_auto_squash_args tm - else if S.fv_eq_lid fv PC.not_lid - then match args |> List.map simplify with - | [(Some true, _)] -> w U.t_false - | [(Some false, _)] -> w U.t_true - | _ -> squashed_head_un_auto_squash_args tm - else if S.fv_eq_lid fv PC.forall_lid - then match args with - (* Simplify ∀x. True to True *) - | [(t, _)] -> - begin match (SS.compress t).n with - | Tm_abs {bs=[_]; body} -> - (match simp_t body with - | Some true -> w U.t_true - | _ -> tm) - | _ -> tm - end - (* Simplify ∀x. True to True, and ∀x. False to False, if the domain is not empty *) - | [(ty, Some ({ aqual_implicit = true })); (t, _)] -> - begin match (SS.compress t).n with - | Tm_abs {bs=[_]; body} -> - (match simp_t body with - | Some true -> w U.t_true - | Some false when clearly_inhabited ty -> w U.t_false - | _ -> tm) - | _ -> tm - end - | _ -> tm - else if S.fv_eq_lid fv PC.exists_lid - then match args with - (* Simplify ∃x. False to False *) - | [(t, _)] -> - begin match (SS.compress t).n with - | Tm_abs {bs=[_]; body} -> - (match simp_t body with - | Some false -> w U.t_false - | _ -> tm) - | _ -> tm - end - (* Simplify ∃x. False to False and ∃x. True to True, if the domain is not empty *) - | [(ty, Some ({ aqual_implicit = true })); (t, _)] -> - begin match (SS.compress t).n with - | Tm_abs {bs=[_]; body} -> - (match simp_t body with - | Some false -> w U.t_false - | Some true when clearly_inhabited ty -> w U.t_true - | _ -> tm) - | _ -> tm - end - | _ -> tm - else if S.fv_eq_lid fv PC.b2t_lid - then match args with - | [{n=Tm_constant (Const_bool true)}, _] -> w U.t_true - | [{n=Tm_constant (Const_bool false)}, _] -> w U.t_false - | _ -> tm //its arg is a bool, can't unsquash - else if S.fv_eq_lid fv PC.haseq_lid - then begin - (* - * AR: We try to mimic the hasEq related axioms in Prims - * and the axiom related to refinements - * For other types, such as lists, whose hasEq is derived by the typechecker, - * we leave them as is - *) - let t_has_eq_for_sure (t:S.term) :bool = - //Axioms from prims - let haseq_lids = [PC.int_lid; PC.bool_lid; PC.unit_lid; PC.string_lid] in - match (SS.compress t).n with - | Tm_fvar fv when haseq_lids |> List.existsb (fun l -> S.fv_eq_lid fv l) -> true - | _ -> false - in - if List.length args = 1 then - let t = args |> List.hd |> fst in - if t |> t_has_eq_for_sure then w U.t_true - else - match (SS.compress t).n with - | Tm_refine _ -> - let t = U.unrefine t in - if t |> t_has_eq_for_sure then w U.t_true - else - //get the hasEq term itself - let haseq_tm = - match (SS.compress tm).n with - | Tm_app {hd} -> hd - | _ -> failwith "Impossible! We have already checked that this is a Tm_app" - in - //and apply it to the unrefined type - mk_app (haseq_tm) [t |> as_arg] - | _ -> tm - else tm - end - else if S.fv_eq_lid fv PC.eq2_lid - then match args with - | [(_typ, _); (a1, _); (a2, _)] -> //eq2 - (match eq_tm env a1 a2 with - | Equal -> w U.t_true - | NotEqual -> w U.t_false - | _ -> tm) - | _ -> tm - else - begin - match U.is_auto_squash tm with - | Some (U_zero, t) - when U.is_sub_singleton t -> - //remove redundant auto_squashes - t - | _ -> - tm - end - | Tm_refine {b=bv; phi=t} -> - begin match simp_t t with - | Some true -> bv.sort - | Some false -> tm - | None -> tm - end - | Tm_match _ -> - begin match is_const_match tm with - | Some true -> w U.t_true - | Some false -> w U.t_false - | None -> tm - end - | _ -> tm diff --git a/src/typechecker/FStar.TypeChecker.TermEqAndSimplify.fsti b/src/typechecker/FStar.TypeChecker.TermEqAndSimplify.fsti deleted file mode 100644 index ba368f6f6de..00000000000 --- a/src/typechecker/FStar.TypeChecker.TermEqAndSimplify.fsti +++ /dev/null @@ -1,16 +0,0 @@ -module FStar.TypeChecker.TermEqAndSimplify -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.TypeChecker.Env -open FStar.Syntax.Syntax - -type eq_result = - | Equal - | NotEqual - | Unknown - -val eq_tm (_:env_t) (t1 t2:term) : eq_result -val eq_args (_:env_t) (t1 t2:args) : eq_result -val eq_comp (_:env_t) (t1 t2:comp) : eq_result -val eq_tm_bool (e:env_t) (t1 t2:term) : bool -val simplify (debug:bool) (_:env_t) (_:term) : term diff --git a/src/typechecker/FStar.TypeChecker.Util.fst b/src/typechecker/FStar.TypeChecker.Util.fst deleted file mode 100644 index cb7dadf055c..00000000000 --- a/src/typechecker/FStar.TypeChecker.Util.fst +++ /dev/null @@ -1,3770 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.TypeChecker.Util -open FStar.Pervasives -open FStar.Compiler.Effect -open FStar.Compiler.List -open FStar -open FStar.Compiler -open FStar.Compiler.Util -open FStar.Errors -open FStar.Errors.Msg -open FStar.Pprint -open FStar.Defensive -open FStar.TypeChecker -open FStar.TypeChecker.Common -open FStar.TypeChecker.Env -open FStar.TypeChecker.Rel -open FStar.Syntax.Syntax -open FStar.Ident -open FStar.Syntax.Subst -open FStar.Syntax -open FStar.Dyn -open FStar.Class.Show -open FStar.Class.PP -open FStar.Class.Monoid - -module Listlike = FStar.Class.Listlike - -module SS = FStar.Syntax.Subst -module S = FStar.Syntax.Syntax -module BU = FStar.Compiler.Util -module U = FStar.Syntax.Util -module N = FStar.TypeChecker.Normalize -module TcComm = FStar.TypeChecker.Common -module P = FStar.Syntax.Print -module C = FStar.Parser.Const -module UF = FStar.Syntax.Unionfind -module TEQ = FStar.TypeChecker.TermEqAndSimplify - -open FStar.Class.Setlike - -let dbg_bind = Debug.get_toggle "Bind" -let dbg_Coercions = Debug.get_toggle "Coercions" -let dbg_Dec = Debug.get_toggle "Dec" -let dbg_Extraction = Debug.get_toggle "Extraction" -let dbg_LayeredEffects = Debug.get_toggle "LayeredEffects" -let dbg_LayeredEffectsApp = Debug.get_toggle "LayeredEffectsApp" -let dbg_Pat = Debug.get_toggle "Pat" -let dbg_Rel = Debug.get_toggle "Rel" -let dbg_ResolveImplicitsHook = Debug.get_toggle "ResolveImplicitsHook" -let dbg_Return = Debug.get_toggle "Return" -let dbg_Simplification = Debug.get_toggle "Simplification" -let dbg_SMTEncodingReify = Debug.get_toggle "SMTEncodingReify" - -(************************************************************************) -(* Unification variables *) -(************************************************************************) -let new_implicit_var reason r env k unrefine = - Env.new_implicit_var_aux reason r env k Strict None unrefine - -let close_guard_implicits env solve_deferred (xs:binders) (g:guard_t) : guard_t = - if Options.eager_subtyping () - || solve_deferred - then - let solve_now, defer = - g.deferred |> Listlike.to_list |> List.partition (fun (_, _, p) -> Rel.flex_prob_closing env xs p) - in - if !dbg_Rel - then begin - BU.print_string "SOLVE BEFORE CLOSING:\n"; - List.iter (fun (_, s, p) -> BU.print2 "%s: %s\n" s (Rel.prob_to_string env p)) solve_now; - BU.print_string " ...DEFERRED THE REST:\n"; - List.iter (fun (_, s, p) -> BU.print2 "%s: %s\n" s (Rel.prob_to_string env p)) defer; - BU.print_string "END\n" - end; - let g = Rel.solve_non_tactic_deferred_constraints false env ({g with deferred = Listlike.from_list solve_now}) in - let g = {g with deferred = Listlike.from_list defer} in - g - else g - -let check_uvars r t = - let uvs = Free.uvars t in - if not (is_empty uvs) then begin - (* ignoring the hide_uvar_nums and print_implicits flags here *) - Options.push(); - Options.set_option "hide_uvar_nums" (Options.Bool false); - Options.set_option "print_implicits" (Options.Bool true); - Errors.log_issue r Errors.Error_UncontrainedUnificationVar - (BU.format2 "Unconstrained unification variables %s in type signature %s; \ - please add an annotation" (show uvs) (show t)); - Options.pop() - end - -(************************************************************************) -(* Extracting annotations, notably the decreases clause, for a recursive definion *) -(* We support several styles of writing decreases clauses: - - 1. val f (x:t) : Tot t' (decreases d) - let rec f x = e - - and variations such as the following, where the definition is - partially annotated. - - val f (x:t) : Tot t' (decreases d) - let rec f (x:t) : t' = e - - 2. val f (x:t) : Tot t' - let rec f x : Tot _ (decreases d) = e - - 3. let rec f (x:t) : Tot t' (decreases d) = e - - 4. let rec f x = e - - The first style is mainly for legacy reasons. Annotating a `val` - with a decreases clause isn't pretty, but there is a fair bit of - code using it. - - The second style is useful in conjunction with interfaces, where - the val may appear in the interface and is defined using a - recursive function separately. It may also be useful when the user - wants to check the type of f first and separately from the - definition, and then try to define it afterwards. - - The third style is common in another scenarios. - - The fourth style leaves it to type inference to figure output. - - A fifth style is the following: - - 5. val f (x:t) : Tot t (decreases d) - let rec f (x:t) : Tot t' (decreases d) = e - - where the decreases clause appears more than once. This style now - raises a warning. - - In the function below, - extract_let_rec_annotation env lb - - the general idea is to - - 1. prefer the decreases clause annotated on the - term, if any - - 2. Remove the decreases clause from the ascription on the body - - 3. construct a type with the decreases clause and use that as the - lbtyp, which TcTerm will use to implement the termination - check - - returns the following: - - - lb.univ_vars: The opened universe names for the letbinding - (incidentally, they are the same as the input univ_vars) - - - lbtyp: This is the type to be used to check the recursive - definition. - - - In case 1, it is simply the annotated type from the - val, i.e., lb.lbtyp - - - In case 2, we lift the decreases clause from the ascription - and return `x:t -> Tot t' (decreases d)` - - - In case 3, it is simply the ascribed type - - - In case 4, just build a type `_ -> _` and return it - - - In case 5, warn and ignore the decrease clause on the val, - and treat it as case 2 - - - lbdef: lb.lbdef adapted to remove any decreases clause annotation - - - check: A flag that signals when the constructed type should be - re-typechecked. Except in case 1, the flag is set. -*) -(************************************************************************) -let extract_let_rec_annotation env {lbname=lbname; lbunivs=univ_vars; lbtyp=t; lbdef=e} : - list univ_name - & typ - & term - & bool //true indicates that the type needs to be checked; false indicates that it is already checked - = - let rng = S.range_of_lbname lbname in - let t = SS.compress t in - let u_subst, univ_vars = SS.univ_var_opening univ_vars in - let e = SS.subst u_subst e in - let t = SS.subst u_subst t in - if !dbg_Dec - then BU.print2 "extract_let_rec_annotation lbdef=%s; lbtyp=%s\n" - (show e) - (show t); - let env = Env.push_univ_vars env univ_vars in - let un_arrow t = - //Rather than use U.arrow_formals_comp, we use un_arrow here - //since the former collapses adjacent Tot annotations, e.g., - // x:t -> Tot (y:t -> M) - // is collapsed, possibly breaking arities. - match (SS.compress t).n with - | Tm_arrow {bs; comp=c} -> - Subst.open_comp bs c - | _ -> - raise_error rng Errors.Fatal_LetRecArgumentMismatch [ - text "Recursive functions must be introduced at arrow types."; - ] - in - let reconcile_let_rec_ascription_and_body_type tarr lbtyp_opt = - let get_decreases c = - U.comp_flags c |> BU.prefix_until (function DECREASES _ -> true | _ -> false) - in - let fallback () = - let bs, c = U.arrow_formals_comp tarr in - match get_decreases c with - | Some (pfx, DECREASES d, sfx) -> - let c = Env.comp_set_flags env c (pfx @ sfx) in - U.arrow bs c, tarr, true - | _ -> tarr, tarr, true - in - match lbtyp_opt with - | None -> - fallback() - - | Some annot -> - let bs, c = un_arrow tarr in - let n_bs = List.length bs in - let bs', c' = N.get_n_binders env n_bs annot in - if List.length bs' <> n_bs - then raise_error rng Errors.Fatal_LetRecArgumentMismatch [ - text "Arity mismatch on let rec annotation"; - text "(explain)"; - ]; - let move_decreases d flags flags' = - let d' = - let s = U.rename_binders bs bs' in - SS.subst_decreasing_order s d - in - let c = Env.comp_set_flags (Env.push_binders env bs) c flags in - let tarr = U.arrow bs c in - let c' = Env.comp_set_flags (Env.push_binders env bs') c' (DECREASES d'::flags') in - let tannot = U.arrow bs' c' in - tarr, tannot, true - in - match get_decreases c, get_decreases c' with - | None, _ -> tarr, annot, false - | Some (pfx, DECREASES d, sfx), Some (pfx', DECREASES d', sfx') -> - Errors.log_issue rng Warning_DeprecatedGeneric [ - text "This definitions has multiple decreases clauses."; - text "The decreases clause on the declaration is ignored, please remove it." - ]; - move_decreases d (pfx@sfx) (pfx'@sfx') - | Some (pfx, DECREASES d, sfx), None -> - move_decreases d (pfx@sfx) (U.comp_flags c') - | _ -> failwith "Impossible" - in - let extract_annot_from_body (lbtyp_opt:option typ) - : typ - & term - & bool - = let rec aux_lbdef e - : typ & term & bool - = let e = SS.compress e in - match e.n with - | Tm_meta {tm=e';meta=m} -> - let t, e', recheck = aux_lbdef e' in - t, { e with n = Tm_meta {tm=e'; meta=m} }, recheck - - | Tm_ascribed {tm=e'; asc=(Inr c, tac_opt, use_eq); eff_opt=lopt} -> - if U.is_total_comp c - then let t, lbtyp, recheck = reconcile_let_rec_ascription_and_body_type (U.comp_result c) lbtyp_opt in - let e = { e with n = Tm_ascribed {tm=e'; - asc=(Inr (S.mk_Total t), tac_opt, use_eq); - eff_opt=lopt} } in - lbtyp, e, recheck - else raise_error rng Errors.Fatal_UnexpectedComputationTypeForLetRec [ - text "Expected a 'let rec' to be annotated with a value type"; - text "Got a computation type" ^/^ pp c ^/^ text "instead"; - ] - - | Tm_ascribed {tm=e'; asc=(Inl t, tac_opt, use_eq); eff_opt=lopt} -> - let t, lbtyp, recheck = reconcile_let_rec_ascription_and_body_type t lbtyp_opt in - let e = { e with n = Tm_ascribed {tm=e'; asc=(Inl t, tac_opt, use_eq); eff_opt=lopt} } in - lbtyp, e, recheck - - | Tm_abs _ -> - let bs, body, rcopt = U.abs_formals_maybe_unascribe_body false e in - let mk_comp t = - if Options.ml_ish() - then U.ml_comp t t.pos - else S.mk_Total t - in - let mk_arrow c = U.arrow bs c in - let rec aux_abs_body body = - let body = SS.compress body in - match body.n with - | Tm_meta {tm=body; meta=m} -> - let t, body', recheck = aux_abs_body body in - let body = { body with n = Tm_meta {tm=body'; meta=m} } in - t, body, recheck - - | Tm_ascribed {asc=(Inl t, _, use_eq)} -> //no decreases clause here - // - //AR: In this case, the type in the ascription is moving to lbtyp - // if use_eq is true, then we are in trouble - // since we don't yet support equality in lbtyp - // - if use_eq - then raise_error t Errors.Fatal_NotSupported [ - text "Equality ascription in this case" ^/^ parens (pp t) ^/^ text "is not yet supported."; - text "Please use subtyping instead"; - ]; - begin - match lbtyp_opt with - | Some lbtyp -> - lbtyp, body, false - - | None -> - let t = mk_arrow (mk_comp t) in - t, body, true - end - - | Tm_ascribed {tm=body'; asc=(Inr c, tac_opt, use_eq); eff_opt=lopt} -> - let tarr = mk_arrow c in - let tarr, lbtyp, recheck = reconcile_let_rec_ascription_and_body_type tarr lbtyp_opt in - let n_bs = List.length bs in - let bs', c = N.get_n_binders env n_bs tarr in - if List.length bs' <> n_bs - then failwith "Impossible" - else let subst = U.rename_binders bs' bs in - let c = SS.subst_comp subst c in - let body = { body with n = Tm_ascribed {tm=body'; - asc=(Inr c, tac_opt, use_eq); - eff_opt=lopt} } in - lbtyp, body, recheck - - | _ -> - match lbtyp_opt with - | Some lbtyp -> - lbtyp, body, false - - | None -> - let tarr = mk_arrow (mk_comp S.tun) in - tarr, body, true - in - let lbtyp, body, recheck = aux_abs_body body in - lbtyp, U.abs bs body rcopt, recheck - - | _ -> - raise_error e Errors.Fatal_UnexpectedComputationTypeForLetRec [ - text "The definition of a 'let rec' must be a function literal"; - text "Got" ^/^ pp e ^/^ text "instead"; - ] - in - aux_lbdef e - in - match t.n with - | Tm_unknown -> - let lbtyp, e, _ = extract_annot_from_body None in - univ_vars, lbtyp, e, true - - | _ -> - let _, c = U.arrow_formals_comp t in - if not (U.comp_effect_name c |> Env.lookup_effect_quals env |> List.contains TotalEffect) - then //no termination check anyway, so don't bother rearranging decreases clauses - univ_vars, t, e, false - else - let lbtyp, e, check_lbtyp = extract_annot_from_body (Some t) in - univ_vars, lbtyp, e, check_lbtyp - -(************************************************************************) -(* Utilities on patterns *) -(************************************************************************) - -//let decorate_pattern env p exp = -// let qq = p in -// let rec aux p e : pat = -// let pkg q = withinfo q p.p in -// let e = U.unmeta e in -// match p.v, e.n with -// | _, Tm_uinst(e, _) -> aux p e - -// | Pat_constant _, _ -> -// pkg p.v - -// | Pat_var x, Tm_name y -> -// if not (bv_eq x y) -// then failwith (BU.format2 "Expected pattern variable %s; got %s" (show x) (show y)); -// if !dbg_Pat -// then BU.print2 "Pattern variable %s introduced at type %s\n" (show x) (Normalize.term_to_string env y.sort); -// let s = Normalize.normalize [Env.Beta] env y.sort in -// let x = {x with sort=s} in -// pkg (Pat_var x) - -// | Pat_wild x, Tm_name y -> -// if bv_eq x y |> not -// then failwith (BU.format2 "Expected pattern variable %s; got %s" (show x) (show y)); -// let s = Normalize.normalize [Env.Beta] env y.sort in -// let x = {x with sort=s} in -// pkg (Pat_wild x) - -// | Pat_dot_term(x, _), _ -> -// pkg (Pat_dot_term(x, e)) - -// | Pat_cons(fv, []), Tm_fvar fv' -> -// if not (Syntax.fv_eq fv fv') -// then failwith (BU.format2 "Expected pattern constructor %s; got %s" (string_of_lid fv.fv_name.v) (string_of_lid fv'.fv_name.v)); -// pkg (Pat_cons(fv', [])) - -// | Pat_cons(fv, argpats), Tm_app({n=Tm_fvar(fv')}, args) -// | Pat_cons(fv, argpats), Tm_app({n=Tm_uinst({n=Tm_fvar(fv')}, _)}, args) -> - -// if fv_eq fv fv' |> not -// then failwith (BU.format2 "Expected pattern constructor %s; got %s" (string_of_lid fv.fv_name.v) (string_of_lid fv'.fv_name.v)); - -// let fv = fv' in -// let rec match_args matched_pats args argpats = match args, argpats with -// | [], [] -> pkg (Pat_cons(fv, List.rev matched_pats)) -// | arg::args, (argpat, _)::argpats -> -// begin match arg, argpat.v with -// | (e, Some (Implicit true)), Pat_dot_term _ -> -// let x = Syntax.new_bv (Some p.p) S.tun in -// let q = withinfo (Pat_dot_term(x, e)) p.p in -// match_args ((q, true)::matched_pats) args argpats - -// | (e, imp), _ -> -// let pat = aux argpat e, S.is_implicit imp in -// match_args (pat::matched_pats) args argpats -// end - -// | _ -> failwith (BU.format2 "Unexpected number of pattern arguments: \n\t%s\n\t%s\n" (show p) (show e)) in - -// match_args [] args argpats - -// | _ -> -// failwith (BU.format3 -// "(%s) Impossible: pattern to decorate is %s; expression is %s\n" -// (Range.string_of_range qq.p) -// (show qq) -// (show exp)) -// in -// aux p exp - - let rec decorated_pattern_as_term (pat:pat) : list bv & term = - let mk f : term = mk f pat.p in - - let pat_as_arg (p, i) = - let vars, te = decorated_pattern_as_term p in - vars, (te, S.as_aqual_implicit i) - in - match pat.v with - | Pat_constant c -> - [], mk (Tm_constant c) - - | Pat_var x -> - [x], mk (Tm_name x) - - | Pat_cons(fv, us_opt, pats) -> - let vars, args = pats |> List.map pat_as_arg |> List.unzip in - let vars = List.flatten vars in - let head = Syntax.fv_to_tm fv in - let head = - match us_opt with - | None -> head - | Some us -> S.mk_Tm_uinst head us - in - vars, mk (Tm_app {hd=head; args}) - - | Pat_dot_term eopt -> - (match eopt with - | None -> failwith "TcUtil::decorated_pattern_as_term: dot pattern not resolved" - | Some e -> [], e) - - -(*********************************************************************************************) -(* Utils related to monadic computations *) -(*********************************************************************************************) - -let comp_univ_opt c = - match c.n with - | Total _ | GTotal _ -> None - | Comp c -> - match c.comp_univs with - | [] -> None - | hd::_ -> Some hd - -let lcomp_univ_opt lc = lc |> TcComm.lcomp_comp |> (fun (c, g) -> comp_univ_opt c, g) - -let destruct_wp_comp c : (universe & typ & typ) = U.destruct_comp c - -let mk_comp_l mname u_result result wp flags = - mk_Comp ({ comp_univs=[u_result]; - effect_name=mname; - result_typ=result; - effect_args=[S.as_arg wp]; - flags=flags}) - -let mk_comp md = mk_comp_l md.mname - -let effect_args_from_repr (repr:term) (is_layered:bool) (r:Range.range) : list term = - let err () = - raise_error r Errors.Fatal_UnexpectedEffect [ - text "Could not get effect args from repr" ^/^ pp repr ^/^ text "with is_layered=" ^^ pp is_layered - ] - in - let repr = SS.compress repr in - if is_layered - then match repr.n with - | Tm_app {args=_::is} -> is |> List.map fst - | _ -> err () - else match repr.n with - | Tm_arrow {comp=c} -> c |> U.comp_eff_name_res_and_args |> (fun (_, _, args) -> args |> List.map fst) - | _ -> err () - - -(* - * Build the M.return comp for a wp effect - * - * Caller must ensure that ed is a wp-based effect - *) -let mk_wp_return env (ed:S.eff_decl) (u_a:universe) (a:typ) (e:term) (r:Range.range) -: comp -= let c = - if not <| Env.lid_exists env C.effect_GTot_lid //we're still in prims, not yet having fully defined the primitive effects - then mk_Total a - else if U.is_unit a - then S.mk_Total a - else let wp = - if Options.lax() - && Options.ml_ish() //NS: Disabling this optimization temporarily - then S.tun - else let ret_wp = ed |> U.get_return_vc_combinator in - mk_Tm_app - (inst_effect_fun_with [u_a] env ed ret_wp) - [S.as_arg a; S.as_arg e] - e.pos in - mk_comp ed u_a a wp [RETURN] - in - if !dbg_Return - then BU.print3 "(%s) returning %s at comp type %s\n" - (Range.string_of_range e.pos) - (show e) - (N.comp_to_string env c); - c - -let label reason r f : term = - mk (Tm_meta {tm=f; meta=Meta_labeled(reason, r, false)}) f.pos - -let label_opt env reason r f = match reason with - | None -> f - | Some reason -> - if not <| Env.should_verify env - then f - else label (reason()) r f - -let label_guard r reason (g:guard_t) = match g.guard_f with - | Trivial -> g - | NonTrivial f -> {g with guard_f=NonTrivial (label reason r f)} - -let lift_comp env (c:comp_typ) lift : comp & guard_t = - ({ c with flags = [] }) |> S.mk_Comp |> lift.mlift_wp env - -let join_effects env l1_in l2_in = - let l1, l2 = Env.norm_eff_name env l1_in, Env.norm_eff_name env l2_in in - match Env.join_opt env l1 l2 with - | Some (m, _, _) -> m - | None -> - match Env.exists_polymonadic_bind env l1 l2 with - | Some (m, _) -> m - | None -> - raise_error env Errors.Fatal_EffectsCannotBeComposed [ - text "Effects" ^/^ pp l1_in ^/^ text "and" ^/^ pp l2_in ^/^ text "cannot be composed" - ] - -let join_lcomp env c1 c2 = - if TcComm.is_total_lcomp c1 - && TcComm.is_total_lcomp c2 - then C.effect_Tot_lid - else join_effects env c1.eff_name c2.eff_name - -// GM, 2023/01/30: This is here to make c2 well-scoped in lift_comps_sep_guards -// below. Is it needed to push a null_binder, as below, when b is None? Not for -// scoping, at least. -let maybe_push (env : Env.env) (b : option bv) : Env.env = - match b with - | None -> env - | Some bv -> Env.push_bv env bv - -(* - * This functions returns the two lifted computations, - * and guards for each of them - * - * The separate guards are important when it is called from the pattern matching code (bind_cases) - * where the two guards are weakened using different branch conditions - *) -let lift_comps_sep_guards env c1 c2 (b:option bv) (for_bind:bool) -: lident & comp & comp & guard_t & guard_t = - let c1 = Env.unfold_effect_abbrev env c1 in - let env2 = maybe_push env b in - let c2 = Env.unfold_effect_abbrev env2 c2 in - match Env.join_opt env c1.effect_name c2.effect_name with - | Some (m, lift1, lift2) -> - let c1, g1 = lift_comp env c1 lift1 in - let c2, g2 = - if not for_bind then lift_comp env2 c2 lift2 - else - let x_a = - match b with - | None -> S.null_binder (U.comp_result c1) - | Some x -> S.mk_binder x in - let env_x = Env.push_binders env [x_a] in - let c2, g2 = lift_comp env_x c2 lift2 in - c2, Env.close_guard env [x_a] g2 in - m, c1, c2, g1, g2 - | None -> - raise_error env Errors.Fatal_EffectsCannotBeComposed [ - text "Effects" ^/^ pp c1.effect_name ^/^ text "and" ^/^ pp c2.effect_name ^/^ text "cannot be composed" - ] - -let lift_comps env c1 c2 (b:option bv) (for_bind:bool) - : lident & comp & comp & guard_t = - let l, c1, c2, g1, g2 = lift_comps_sep_guards - env - c1 - c2 - b - for_bind in - l, c1, c2, Env.conj_guard g1 g2 - -let is_pure_effect env l = - let l = norm_eff_name env l in - lid_equals l C.effect_PURE_lid - -let is_ghost_effect env l = - let l = norm_eff_name env l in - lid_equals l C.effect_GHOST_lid - -let is_pure_or_ghost_effect env l = - let l = norm_eff_name env l in - lid_equals l C.effect_PURE_lid - || lid_equals l C.effect_GHOST_lid - -let lax_mk_tot_or_comp_l mname u_result result flags = - if Ident.lid_equals mname C.effect_Tot_lid - then S.mk_Total result - else mk_comp_l mname u_result result S.tun flags - -let is_function t = match (compress t).n with - | Tm_arrow _ -> true - | _ -> false - -let close_wp_comp env bvs (c:comp) = - def_check_scoped c.pos "close_wp_comp" (Env.push_bvs env bvs) c; - if U.is_ml_comp c then c - else if Options.lax() - && Options.ml_ish() //NS: disabling this optimization temporarily - then c - else begin - (* - * We make an environment containing all the BVs so the calls - * to env.universe_of and unfold_effect_abbrev below are properly scoped. - * Note: this only works since variables in the environment are named and - * fresh, so it is OK to use a larger environment to check a term. - *) - let env_bvs = Env.push_bvs env bvs in - let close_wp u_res md res_t bvs wp0 = - let close = md |> U.get_wp_close_combinator |> must in - List.fold_right (fun x wp -> - let bs = [mk_binder x] in - let us = u_res::[env.universe_of env_bvs x.sort] in - let wp = U.abs bs wp (Some (U.mk_residual_comp C.effect_Tot_lid None [TOTAL])) in - mk_Tm_app (inst_effect_fun_with us env md close) [S.as_arg res_t; S.as_arg x.sort; S.as_arg wp] wp0.pos) - bvs wp0 in - let c = Env.unfold_effect_abbrev env_bvs c in - let u_res_t, res_t, wp = destruct_wp_comp c in - let md = Env.get_effect_decl env c.effect_name in - let wp = close_wp u_res_t md res_t bvs wp in - (* - * AR: a note re. comp flags: - * earlier this code was setting the flags of the closed computation as c.flags - * - * cf. #2352, when this code was called from - * weaken_result_typ -> bind -> maybe_capture_unit_refinement, - * the input comp was Tot had RETURN flag set, which means the closed comp also had RETURN - * - * so when this closed computation was later `bind` with another comp, - * we simply dropped the it (see code path in bind under U.is_trivial_wp) - * thereby losing the captured refinement - * - * in general, comp flags need some cleanup - *) - mk_comp md u_res_t c.result_typ wp - (c.flags |> List.filter (function | MLEFFECT | SHOULD_NOT_INLINE -> true | _ -> false)) - end - -let close_wp_lcomp env bvs (lc:lcomp) : lcomp = - let bs = bvs |> List.map S.mk_binder in - lc |> - TcComm.apply_lcomp - (close_wp_comp env bvs) - (fun g -> g |> Env.close_guard env bs |> close_guard_implicits env false bs) - -// -// Apply substitutive close combinator for indexed effects -// -// The effect indices binders in the close combinator are arrows, -// so we abstract b_bv on the effect args for the substitutions -// -let substitutive_indexed_close_substs (env:env) - (close_bs:binders) - (a:typ) - (b_bv:bv) - (ct_args:args) - (num_effect_params:int) - (r:Range.range) - - : list subst_elt = - - let debug = !dbg_LayeredEffectsApp in - - // go through the binders bs and aggregate substitutions - let close_bs, subst = - let a_b::b_b::close_bs = close_bs in - close_bs, [NT (a_b.binder_bv, a); NT (b_b.binder_bv, b_bv.sort)] in - - let close_bs, subst, ct_args = - let eff_params_bs, close_bs = List.splitAt num_effect_params close_bs in - let ct_eff_params_args, ct_args = List.splitAt num_effect_params ct_args in - close_bs, - (subst@ - List.map2 (fun b (arg, _) -> NT (b.binder_bv, arg)) eff_params_bs ct_eff_params_args), - ct_args in - - let close_bs, _ = List.splitAt (List.length close_bs - 1) close_bs in - List.fold_left2 (fun ss b (ct_arg, _) -> - ss@[NT (b.binder_bv, U.abs [b_bv |> S.mk_binder] ct_arg None)] - ) subst close_bs ct_args - -// -// The caller ensures that the effect has the close combinator defined -// -let close_layered_comp_with_combinator (env:env) (bvs:list bv) (c:comp) : comp = - let r = c.pos in - - let env_bvs = Env.push_bvs env bvs in - let ct = Env.unfold_effect_abbrev env_bvs c in - let ed = Env.get_effect_decl env_bvs ct.effect_name in - let num_effect_params = - match ed.signature with - | Layered_eff_sig (n, _) -> n - | _ -> raise_error r Errors.Fatal_UnexpectedEffect "mk_indexed_close called with a non-indexed effect" - in - let close_ts = U.get_layered_close_combinator ed |> must in - let effect_args = List.fold_right (fun x args -> - let u_a = List.hd ct.comp_univs in - let u_b = env.universe_of env_bvs x.sort in - let _, close_t = Env.inst_tscheme_with close_ts [u_a; u_b] in - let close_bs, close_body, _ = U.abs_formals close_t in - let ss = substitutive_indexed_close_substs - env_bvs close_bs ct.result_typ x args num_effect_params r in - match (SS.compress (SS.subst ss close_body)).n with - | Tm_app { args = _::args} -> args - | _ -> raise_error r Errors.Fatal_UnexpectedEffect "Unexpected close combinator shape" - ) bvs ct.effect_args in - S.mk_Comp {ct with effect_args} - -let close_layered_lcomp_with_combinator env bvs lc = - let bs = bvs |> List.map S.mk_binder in - lc |> - TcComm.apply_lcomp - (close_layered_comp_with_combinator env bvs) - (fun g -> g |> Env.close_guard env bs |> close_guard_implicits env false bs) - -(* - * Closing of layered computations via substitution - *) -let close_layered_lcomp_with_substitutions env bvs tms (lc:lcomp) = - let bs = bvs |> List.map S.mk_binder in - let substs = List.map2 (fun bv tm -> - NT (bv, tm) - ) bvs tms in - lc |> - TcComm.apply_lcomp - (SS.subst_comp substs) - (fun g -> g |> Env.close_guard env bs |> close_guard_implicits env false bs) - -let should_not_inline_lc (lc:lcomp) = - lc.cflags |> BU.for_some (function SHOULD_NOT_INLINE -> true | _ -> false) - -(* should_return env (Some e) lc: - * We will "return" e, adding an equality to the VC, if all of the following conditions hold - * (a) e is a pure or ghost term - * (b) Its return type, lc.res_typ, is not a sub-singleton (unit, squash, etc), if lc.res_typ is an arrow, then we check the comp type of the arrow - * An exception is made for reifiable effects -- they are useful even if they return unit -- except when it is an layered effect, we never return layered effects - * (c) Its head symbol is not marked irreducible (in this case inlining is not going to help, it is equivalent to having a bound variable) - * (d) It's not a let rec, as determined by the absence of the SHOULD_NOT_INLINE flag---see issue #1362. Would be better to just encode inner let recs to the SMT solver properly - *) -let should_return env eopt lc = - let lc_is_unit_or_effectful = - //if lc.res_typ is not an arrow, arrow_formals_comp returns Tot lc.res_typ - let c = lc.res_typ |> U.arrow_formals_comp |> snd in - if Env.is_reifiable_comp env c - then - // - //if c (the comp of the result type of lc) is reifiable - // we always return it, unless it is a non TAC layered effect - // - let c_eff_name = c |> U.comp_effect_name |> Env.norm_eff_name env in - if is_pure_or_ghost_lcomp lc && //check that lc was pure or ghost - lid_equals c_eff_name C.effect_TAC_lid //and c is TAC - then false //then not effectful (i.e. return) - else c_eff_name |> Env.is_layered_effect env - else - // - // if c is not a reifiable effect, check that it is pure or ghost - // - if U.is_pure_or_ghost_comp c - then - // - // if it is pure or ghost, it must be a non-singleton - // - // adding a bit of normalization to unfold abbreviations - // - c |> U.comp_result |> N.unfold_whnf env |> U.is_unit - else - // - // if it is not pure or ghost, don't return - // - true in - - match eopt with - | None -> false //no term to return - | Some e -> - TcComm.is_pure_or_ghost_lcomp lc && //condition (a), (see above) - not lc_is_unit_or_effectful && //condition (b) - (let head, _ = U.head_and_args_full e in - match (U.un_uinst head).n with - | Tm_fvar fv -> not (Env.is_irreducible env (lid_of_fv fv)) //condition (c) - | _ -> true) && - not (should_not_inline_lc lc) //condition (d) - -// -// apply a substitutive indexed bind (including a polymonadic bind) -// -// bs are the opened binders in the type of the bind -// -let substitutive_indexed_bind_substs env - (m_ed n_ed p_ed:S.eff_decl) - (bs:binders) - (binder_kinds:list indexed_effect_binder_kind) - (ct1:comp_typ) (b:option bv) (ct2:comp_typ) - (r1:Range.range) - (num_effect_params:int) - (has_range_binders:bool) - - : list subst_elt & guard_t = - - let debug = !dbg_LayeredEffectsApp in - - let bind_name () = - if debug - then BU.format3 "(%s, %s) |> %s" - (m_ed.mname |> Ident.ident_of_lid |> string_of_id) - (n_ed.mname |> Ident.ident_of_lid |> string_of_id) - (p_ed.mname |> Ident.ident_of_lid |> string_of_id) - else "" in - - // we are going to move through the binders and aggregate their substitutions - - let bs, binder_kinds, subst = - let a_b::b_b::bs = bs in - bs, - List.splitAt 2 binder_kinds |> snd, - [NT (a_b.binder_bv, ct1.result_typ); NT (b_b.binder_bv, ct2.result_typ)] in - - // effect parameters - let bs, binder_kinds, subst, guard, args1, args2 = - if num_effect_params = 0 - then bs, binder_kinds, subst, Env.trivial_guard, ct1.effect_args, ct2.effect_args - else // peel off num effect params args from both c1 and c2, - // and equate them - let split (l:list 'a) = List.splitAt num_effect_params l in - let eff_params_bs, bs = split bs in - let _, binder_kinds = split binder_kinds in - let param_args1, args1 = split ct1.effect_args in - let param_args2, args2 = split ct2.effect_args in - let g = List.fold_left2 (fun g (arg1, _) (arg2, _) -> - Env.conj_guard g - (Rel.layered_effect_teq env arg1 arg2 (Some "effect param bind")) - ) Env.trivial_guard param_args1 param_args2 in - let param_subst = List.map2 (fun b (arg, _) -> - NT (b.binder_bv, arg)) eff_params_bs param_args1 in - bs, binder_kinds, subst@param_subst, g, args1, args2 in - - // f binders - let bs, binder_kinds, subst = - let m_num_effect_args = List.length args1 in - let f_bs, bs = List.splitAt m_num_effect_args bs in - let f_subst = List.map2 (fun f_b (arg:S.arg) -> NT (f_b.binder_bv, fst arg)) f_bs args1 in - bs, - List.splitAt m_num_effect_args binder_kinds |> snd, - subst@f_subst in - - // g binders - // a bit more involved since g binders may be substitutive or no abstraction - let bs, subst, guard = - let n_num_effect_args = List.length args2 in - let g_bs, bs = List.splitAt n_num_effect_args bs in - let g_bs_kinds = List.splitAt n_num_effect_args binder_kinds |> fst in - - let x_bv = - match b with - | None -> S.null_bv ct1.result_typ - | Some x -> x in - - let subst, guard = - List.fold_left2 (fun (ss, g) (g_b, g_b_kind) (arg:S.arg) -> - if g_b_kind = Substitutive_binder - then begin - let arg_t = U.abs [x_bv |> S.mk_binder] (fst arg) None in - ss@[NT (g_b.binder_bv, arg_t)], - g - end - else if g_b_kind = BindCont_no_abstraction_binder - then begin - let [uv_t], g_uv = - Env.uvars_for_binders env [g_b] ss - (fun b -> - if debug - then BU.format3 "implicit var for no abs g binder %s of %s at %s" - (show b) - (bind_name ()) - (Range.string_of_range r1) - else "substitutive_indexed_bind_substs.1") - r1 in - let g_unif = Rel.layered_effect_teq - (Env.push_binders env [x_bv |> S.mk_binder]) - uv_t - (arg |> fst) - (Some "") in - ss@[NT (g_b.binder_bv, uv_t)], - Env.conj_guards [g; g_uv; g_unif] - end - else failwith "Impossible (standard bind with unexpected binder kind)" - ) (subst, guard) (List.zip g_bs g_bs_kinds) args2 in - - bs, - subst, - guard in - - let bs = - if has_range_binders - then List.splitAt 2 bs |> snd - else bs in - - let bs = List.splitAt (List.length bs - 2) bs |> fst in - - // create uvars for remaining bs - List.fold_left (fun (ss, g) b -> - let [uv_t], g_uv = Env.uvars_for_binders env [b] ss - (fun b -> - if debug - then BU.format3 "implicit var for additional g binder %s of %s at %s" - (show b) - (bind_name ()) - (Range.string_of_range r1) - else "substitutive_indexed_bind_substs.2") r1 in - ss@[NT (b.binder_bv, uv_t)], - Env.conj_guard g g_uv - ) (subst, guard) bs - -// -// Apply an ad-hoc indexed bind (uvars for all binders) -// -let ad_hoc_indexed_bind_substs env - (m_ed n_ed p_ed:S.eff_decl) - (bs:binders) - (ct1:comp_typ) (b:option bv) (ct2:comp_typ) - (r1:Range.range) - (has_range_binders:bool) - - : list subst_elt & guard_t = - - let debug = !dbg_LayeredEffectsApp in - - let bind_name () = - if debug - then BU.format3 "(%s, %s) |> %s" - (m_ed.mname |> Ident.ident_of_lid |> string_of_id) - (n_ed.mname |> Ident.ident_of_lid |> string_of_id) - (p_ed.mname |> Ident.ident_of_lid |> string_of_id) - else "" in - - let bind_t_shape_error r (s:string) = - raise_error r Errors.Fatal_UnexpectedEffect - (BU.format2 "bind %s does not have proper shape (reason:%s)" (bind_name ()) s) - in - - let num_range_binders = - if has_range_binders then 2 - else 0 in - - let a_b, b_b, rest_bs, f_b, g_b = - if List.length bs >= num_range_binders + 4 - then let a_b::b_b::bs =bs in - let rest_bs, f_b, g_b = - List.splitAt (List.length bs - 2 - num_range_binders) bs - |> (fun ((l1, l2):(binders & binders)) -> - let _, l2 = List.splitAt num_range_binders l2 in - l1, List.hd l2, List.hd (List.tl l2)) in - a_b, b_b, rest_bs, f_b, g_b - else bind_t_shape_error r1 "Either not an arrow or not enough binders" in - - //create uvars for rest_bs, with proper substitutions of a_b, b_b, and b_i with t1, t2, and ?ui - let rest_bs_uvars, g_uvars = - Env.uvars_for_binders - env rest_bs [NT (a_b.binder_bv, ct1.result_typ); NT (b_b.binder_bv, ct2.result_typ)] - (fun b -> - if debug - then BU.format3 - "implicit var for binder %s of %s at %s" - (show b) (bind_name ()) (Range.string_of_range r1) - else "ad_hoc_indexed_bind_substs") r1 in - - if !dbg_ResolveImplicitsHook - then rest_bs_uvars |> - List.iter (fun t -> - match (SS.compress t).n with - | Tm_uvar (u, _ ) -> - BU.print2 "Generated uvar %s with attribute %s\n" - (show t) (show u.ctx_uvar_meta) - | _ -> failwith ("Impossible, expected a uvar, got : " ^ show t)); - - let subst = List.map2 - (fun b t -> NT (b.binder_bv, t)) - (a_b::b_b::rest_bs) (ct1.result_typ::ct2.result_typ::rest_bs_uvars) in - - let f_guard = //unify c1's indices with f's indices in the bind_wp - let f_sort_is = effect_args_from_repr - (SS.compress f_b.binder_bv.sort) - (U.is_layered m_ed) r1 |> List.map (SS.subst subst) in - List.fold_left2 - (fun g i1 f_i1 -> - if !dbg_ResolveImplicitsHook - then BU.print2 "Generating constraint %s = %s\n" - (show i1) - (show f_i1); - Env.conj_guard g (Rel.layered_effect_teq env i1 f_i1 (Some (bind_name ())))) - Env.trivial_guard (List.map fst ct1.effect_args) f_sort_is - in - - let g_guard = //unify c2's indices with g's indices in the bind_wp - let x_a = - match b with - | None -> S.null_binder ct1.result_typ - | Some x -> S.mk_binder {x with sort=ct1.result_typ} in - - let g_sort_is : list term = - match (SS.compress g_b.binder_bv.sort).n with - | Tm_arrow {bs; comp=c} -> - let bs, c = SS.open_comp bs c in - let bs_subst = NT ((List.hd bs).binder_bv, x_a.binder_bv |> S.bv_to_name) in - let c = SS.subst_comp [bs_subst] c in - effect_args_from_repr (SS.compress (U.comp_result c)) (U.is_layered n_ed) r1 - |> List.map (SS.subst subst) - | _ -> failwith "impossible: mk_indexed_bind" - in - - let env_g = Env.push_binders env [x_a] in - List.fold_left2 - (fun g i1 g_i1 -> - if !dbg_ResolveImplicitsHook - then BU.print2 "Generating constraint %s = %s\n" - (show i1) - (show g_i1); - Env.conj_guard g (Rel.layered_effect_teq env_g i1 g_i1 (Some (bind_name ())))) - Env.trivial_guard (List.map fst ct2.effect_args) g_sort_is - |> Env.close_guard env [x_a] - in - - subst, - Env.conj_guards [g_uvars; f_guard; g_guard] - -(* private *) - -(* - * Build the M.return comp for an indexed effect - * - * Caller must ensure that ed is an indexed effect - *) -let mk_indexed_return env (ed:S.eff_decl) (u_a:universe) (a:typ) (e:term) (r:Range.range) - : comp & guard_t = - - let debug = !dbg_LayeredEffectsApp in - - if debug - then BU.print4 "Computing %s.return for u_a:%s, a:%s, and e:%s{\n" - (Ident.string_of_lid ed.mname) (show u_a) - (show a) (show e); - - let _, return_t = Env.inst_tscheme_with - (ed |> U.get_return_vc_combinator) - [u_a] in - - let return_t_shape_error r (s:string) = - raise_error r Errors.Fatal_UnexpectedEffect [ - pp ed.mname ^/^ text ".return" ^/^ text "does not have proper shape"; - text "Reason: " ^^ text s - ] - in - let a_b, x_b, rest_bs, return_typ = - match (SS.compress return_t).n with - | Tm_arrow {bs; comp=c} when List.length bs >= 2 -> - let ((a_b::x_b::bs, c)) = SS.open_comp bs c in - a_b, x_b, bs, U.comp_result c - | _ -> return_t_shape_error r "Either not an arrow or not enough binders" in - - let rest_bs_uvars, g_uvars = - Env.uvars_for_binders - env rest_bs [NT (a_b.binder_bv, a); NT (x_b.binder_bv, e)] - (fun b -> - if debug - then BU.format3 "implicit var for binder %s of %s at %s" - (show b) - (BU.format1 "%s.return" (Ident.string_of_lid ed.mname)) - (Range.string_of_range r) - else "mk_indexed_return_env") r in - - let subst = List.map2 - (fun b t -> NT (b.binder_bv, t)) - (a_b::x_b::rest_bs) (a::e::rest_bs_uvars) in - - let is = - effect_args_from_repr (SS.compress return_typ) (U.is_layered ed) r - |> List.map (SS.subst subst) in - - let c = mk_Comp ({ - comp_univs = [u_a]; - effect_name = ed.mname; - result_typ = a; - effect_args = is |> List.map S.as_arg; - flags = [] - }) in - - if debug - then BU.print1 "} c after return %s\n" (show c); - - c, g_uvars - -let mk_indexed_bind env - (m:lident) (n:lident) (p:lident) (bind_t:tscheme) - (bind_combinator_kind:indexed_effect_combinator_kind) - (ct1:comp_typ) (b:option bv) (ct2:comp_typ) - (flags:list cflag) (r1:Range.range) - (num_effect_params:int) - (has_range_binders:bool) - : comp & guard_t = - - let debug = !dbg_LayeredEffectsApp in - - if debug then - BU.print2 "Binding indexed effects: c1:%s and c2:%s {\n" - (show (S.mk_Comp ct1)) (show (S.mk_Comp ct2)); - - if !dbg_ResolveImplicitsHook - then BU.print2 "///////////////////////////////Bind at %s/////////////////////\n\ - with bind_t = %s\n" - (Range.string_of_range (Env.get_range env)) - (Print.tscheme_to_string bind_t); - - let m_ed, n_ed, p_ed = Env.get_effect_decl env m, Env.get_effect_decl env n, Env.get_effect_decl env p in - - let bind_name () = BU.format3 "(%s, %s) |> %s" - (m_ed.mname |> Ident.ident_of_lid |> string_of_id) - (n_ed.mname |> Ident.ident_of_lid |> string_of_id) - (p_ed.mname |> Ident.ident_of_lid |> string_of_id) in - - if (Env.is_erasable_effect env m && - not (Env.is_erasable_effect env p) && - not (N.non_info_norm env ct1.result_typ)) || - (Env.is_erasable_effect env n && - not (Env.is_erasable_effect env p) && - not (N.non_info_norm env ct2.result_typ)) - then raise_error r1 Errors.Fatal_UnexpectedEffect [ - text "Cannot apply bind" ^/^ doc_of_string (bind_name ()) ^/^ text "since" ^/^ pp p - ^/^ text "is not erasable and one of the computations is informative." - ]; - - let _, bind_t = Env.inst_tscheme_with bind_t [List.hd ct1.comp_univs; List.hd ct2.comp_univs] in - - let bind_t_bs, bind_c = U.arrow_formals_comp bind_t in - - let subst, g = - if bind_combinator_kind = Ad_hoc_combinator - then ad_hoc_indexed_bind_substs env m_ed n_ed p_ed - bind_t_bs ct1 b ct2 r1 has_range_binders - else let Substitutive_combinator binder_kinds = bind_combinator_kind in - substitutive_indexed_bind_substs env m_ed n_ed p_ed - bind_t_bs binder_kinds ct1 b ct2 r1 num_effect_params has_range_binders in - - let bind_ct = bind_c |> SS.subst_comp subst |> Env.comp_to_comp_typ env in - - //compute the formula `bind_c.wp (fun _ -> True)` and add it to the final guard - let fml = - let u, wp = List.hd bind_ct.comp_univs, fst (List.hd bind_ct.effect_args) in - Env.pure_precondition_for_trivial_post env u bind_ct.result_typ wp Range.dummyRange in - - let is : list term = //indices of the resultant computation - effect_args_from_repr (SS.compress bind_ct.result_typ) (U.is_layered p_ed) r1 in - - let c = mk_Comp ({ - comp_univs = ct2.comp_univs; - effect_name = p_ed.mname; - result_typ = ct2.result_typ; - effect_args = List.map S.as_arg is; - flags = flags - }) in - - if debug - then BU.print1 "} c after bind: %s\n" (show c); - - let guard = - Env.conj_guards [ - g; - Env.guard_of_guard_formula (TcComm.NonTrivial fml)] - in - - if !dbg_ResolveImplicitsHook - then BU.print2 "///////////////////////////////EndBind at %s/////////////////////\n\ - guard = %s\n" - (Range.string_of_range (Env.get_range env)) - (guard_to_string env guard); - - c, guard - -let mk_wp_bind env (m:lident) (ct1:comp_typ) (b:option bv) (ct2:comp_typ) (flags:list cflag) (r1:Range.range) - : comp = - - let (md, a, kwp), (u_t1, t1, wp1), (u_t2, t2, wp2) = - let md = Env.get_effect_decl env m in - let a, kwp = Env.wp_signature env m in - (md, a, kwp), destruct_wp_comp ct1, destruct_wp_comp ct2 in - - let bs = - match b with - | None -> [null_binder t1] - | Some x -> [S.mk_binder x] - in - let mk_lam wp = - //we know it's total; indicate for the normalizer reduce it by adding the TOTAL flag - U.abs bs wp (Some (U.mk_residual_comp C.effect_Tot_lid None [TOTAL])) - in - let wp_args = [ - S.as_arg t1; - S.as_arg t2; - S.as_arg wp1; - S.as_arg (mk_lam wp2)] - in - let bind_wp, _ = md |> U.get_bind_vc_combinator in - let wp = mk_Tm_app (inst_effect_fun_with [u_t1;u_t2] env md bind_wp) wp_args t2.pos in - mk_comp md u_t2 t2 wp flags - -let mk_bind env - (c1:comp) - (b:option bv) - (c2:comp) - (flags:list cflag) - (r1:Range.range) : comp & guard_t = - - let env2 = maybe_push env b in - let ct1, ct2 = Env.unfold_effect_abbrev env c1, Env.unfold_effect_abbrev env2 c2 in - - match Env.exists_polymonadic_bind env ct1.effect_name ct2.effect_name with - | Some (p, f_bind) -> f_bind env ct1 b ct2 flags r1 - | None -> - (* - * AR: g_lift here consists of the guard of lifting c1 and c2 - * the guard of c2 could contain the bound variable b - * and when returning this gurd, we must close it - * - * however, if you see lift_comps_sep_guards, it is already doing the closing - * so it's fine to return g_return as is - *) - let m, c1, c2, g_lift = lift_comps env c1 c2 b true in - let ct1, ct2 = Env.comp_to_comp_typ env c1, Env.comp_to_comp_typ env2 c2 in - - let c, g_bind = - if Env.is_layered_effect env m - then - let m_ed = m |> Env.get_effect_decl env in - let num_effect_params = - match m_ed.signature with - | Layered_eff_sig (n, _) -> n - | _ -> failwith "Impossible (mk_bind expected an indexed effect)" in - let bind_t, bind_kind = m_ed |> U.get_bind_vc_combinator in - let has_range_args = U.has_attribute m_ed.eff_attrs C.bind_has_range_args_attr in - mk_indexed_bind env m m m bind_t (bind_kind |> must) ct1 b ct2 flags r1 num_effect_params has_range_args - else mk_wp_bind env m ct1 b ct2 flags r1, Env.trivial_guard in - c, Env.conj_guard g_lift g_bind - -let strengthen_comp env (reason:option (unit -> list Pprint.document)) (c:comp) (f:formula) flags : comp & guard_t = - if env.phase1 || Env.too_early_in_prims env - then c, Env.trivial_guard - else let r = Env.get_range env in - (* - * The following code does: - * M.bind_wp (lift_pure_M (Prims.pure_assert_wp f)) (fun _ -> wp) - *) - - (* - * lookup the pure_assert_wp from prims - * its type is p:Type -> pure_wp unit - * and it is not universe polymorphic - *) - let pure_assert_wp = S.fv_to_tm (S.lid_as_fv C.pure_assert_wp_lid None) in - - (* apply it to f, after decorating f with the reason *) - let pure_assert_wp = mk_Tm_app - pure_assert_wp - [ S.as_arg <| label_opt env reason r f ] - r - in - - let r = Env.get_range env in - - let pure_c = S.mk_Comp ({ - comp_univs = [S.U_zero]; - effect_name = C.effect_PURE_lid; - result_typ = S.t_unit; - effect_args = [pure_assert_wp |> S.as_arg]; - flags = [] - }) in - - mk_bind env pure_c None c flags r - -(* - * Wrapper over mk_wp_return and mk_indexed_return - *) -let mk_return env (ed:S.eff_decl) (u_a:universe) (a:typ) (e:term) (r:Range.range) -: comp & guard_t -= if ed |> U.is_layered - then mk_indexed_return env ed u_a a e r - else mk_wp_return env ed u_a a e r, Env.trivial_guard - -(* - * Return a value in eff_lid - *) -let return_value env eff_lid u_t_opt t v = - let u = - match u_t_opt with - | None -> env.universe_of env t - | Some u -> u in - mk_return env (Env.get_effect_decl env eff_lid) u t v v.pos - -let weaken_flags flags = - if flags |> BU.for_some (function SHOULD_NOT_INLINE -> true | _ -> false) - then [SHOULD_NOT_INLINE] - else flags |> List.collect (function - | TOTAL -> [TRIVIAL_POSTCONDITION] - | RETURN -> [PARTIAL_RETURN; TRIVIAL_POSTCONDITION] - | f -> [f]) - -let weaken_comp env (c:comp) (formula:term) : comp & guard_t = - if U.is_ml_comp c - then c, Env.trivial_guard - else let ct = Env.unfold_effect_abbrev env c in - - (* - * The following code does: - * M.bind_wp (lift_pure_M (Prims.pure_assume_wp f)) (fun _ -> wp) - *) - - (* - * lookup the pure_assume_wp from prims - * its type is p:Type -> pure_wp unit - * and it is not universe polymorphic - *) - let pure_assume_wp = S.fv_to_tm (S.lid_as_fv C.pure_assume_wp_lid None) in - - (* apply it to f, after decorating f with the reason *) - let pure_assume_wp = mk_Tm_app - pure_assume_wp - [ S.as_arg <| formula ] - (Env.get_range env) - in - - let r = Env.get_range env in - - let pure_c = S.mk_Comp ({ - comp_univs = [S.U_zero]; - effect_name = C.effect_PURE_lid; - result_typ = S.t_unit; - effect_args = [pure_assume_wp |> S.as_arg]; - flags = [] - }) in - - mk_bind env pure_c None c (weaken_flags ct.flags) r - -let weaken_precondition env lc (f:guard_formula) : lcomp = - let weaken () = - let c, g_c = TcComm.lcomp_comp lc in - if Options.lax () - && Options.ml_ish() //NS: Disabling this optimization temporarily - then c, g_c - else match f with - | Trivial -> c, g_c - | NonTrivial f -> - let c, g_w = weaken_comp env c f in - c, Env.conj_guard g_c g_w - in - TcComm.mk_lcomp lc.eff_name lc.res_typ (weaken_flags lc.cflags) weaken - -let strengthen_precondition - (reason:option (unit -> list Pprint.document)) - env - (e_for_debugging_only:term) - (lc:lcomp) - (g0:guard_t) - : lcomp & guard_t = - if Env.is_trivial_guard_formula g0 - then lc, g0 - else let flags = - let maybe_trivial_post, flags = - if TcComm.is_tot_or_gtot_lcomp lc then true, [TRIVIAL_POSTCONDITION] else false, [] - in - flags @ ( - lc.cflags - |> List.collect (function - | RETURN - | PARTIAL_RETURN -> [PARTIAL_RETURN] - | SOMETRIVIAL - | TRIVIAL_POSTCONDITION - when not maybe_trivial_post -> - [TRIVIAL_POSTCONDITION] - | SHOULD_NOT_INLINE -> [SHOULD_NOT_INLINE] - | _ -> [])) - in - let strengthen () = - let c, g_c = TcComm.lcomp_comp lc in - if Options.lax () - then c, g_c - else let g0 = Rel.simplify_guard env g0 in - match guard_form g0 with - | Trivial -> c, g_c - | NonTrivial f -> - if Debug.extreme () - then BU.print2 "-------------Strengthening pre-condition of term %s with guard %s\n" - (N.term_to_string env e_for_debugging_only) - (N.term_to_string env f); - let c, g_s = strengthen_comp env reason c f flags in - c, Env.conj_guard g_c g_s - in - TcComm.mk_lcomp (norm_eff_name env lc.eff_name) - lc.res_typ - flags - strengthen, - {g0 with guard_f=Trivial} - - -let lcomp_has_trivial_postcondition (lc:lcomp) = - TcComm.is_tot_or_gtot_lcomp lc - || BU.for_some (function SOMETRIVIAL | TRIVIAL_POSTCONDITION -> true | _ -> false) - lc.cflags - - -(* - * This is used in bind, when c1 is a Tot (x:unit{phi}) - * In such cases, e1 is inlined in c2, but we still want to capture inhabitance of phi - * - * For wp-effects, we do forall (x:unit{phi}). c2 - * For layered effects, we do: weaken_comp (phi[x/()]) c2 - * - * We should make wp-effects also same as the layered effects - *) -let maybe_capture_unit_refinement (env:env) (t:term) (x:bv) (c:comp) : comp & guard_t = - let t = N.normalize_refinement N.whnf_steps env t in - match t.n with - | Tm_refine {b; phi} -> - let is_unit = - match b.sort.n with - | Tm_fvar fv -> S.fv_eq_lid fv C.unit_lid - | _ -> false in - if is_unit then - if c |> U.comp_effect_name |> Env.norm_eff_name env |> Env.is_layered_effect env - then - let b, phi = SS.open_term_bv b phi in - let phi = SS.subst [NT (b, S.unit_const)] phi in - weaken_comp env c phi - else close_wp_comp env [x] c, Env.trivial_guard - else c, Env.trivial_guard - | _ -> c, Env.trivial_guard - -let bind (r1:Range.range) (env:Env.env) (e1opt:option term) (lc1:lcomp) ((b, lc2):lcomp_with_binder) : lcomp = - let debug f = - if Debug.extreme () || !dbg_bind - then f () - in - let lc1, lc2 = N.ghost_to_pure_lcomp2 env (lc1, lc2) in //downgrade from ghost to pure, if possible - let joined_eff = join_lcomp env lc1 lc2 in - let bind_flags = - if should_not_inline_lc lc1 - || should_not_inline_lc lc2 - then [SHOULD_NOT_INLINE] - else let flags = - if TcComm.is_total_lcomp lc1 - then if TcComm.is_total_lcomp lc2 - then [TOTAL] - else if TcComm.is_tot_or_gtot_lcomp lc2 - then [SOMETRIVIAL] - else [] - else if TcComm.is_tot_or_gtot_lcomp lc1 - && TcComm.is_tot_or_gtot_lcomp lc2 - then [SOMETRIVIAL] - else [] - in - if lcomp_has_trivial_postcondition lc2 - then TRIVIAL_POSTCONDITION::flags - else flags - in - let bind_it () = - if Options.lax () - && Options.ml_ish() //NS: disabling this optimization temporarily - then - let u_t = env.universe_of env lc2.res_typ in - lax_mk_tot_or_comp_l joined_eff u_t lc2.res_typ [], Env.trivial_guard //AR: TODO: FIXME: fix for layered effects - else begin - let c1, g_c1 = TcComm.lcomp_comp lc1 in - let c2, g_c2 = TcComm.lcomp_comp lc2 in - - (* - * AR: we need to be careful about handling g_c2 since it may have x free - * whereever we return/add this, we have to either close it or substitute it - *) - - let trivial_guard = Env.conj_guard g_c1 ( - match b with - | Some x -> - let b = S.mk_binder x in - if S.is_null_binder b - then g_c2 - else Env.close_guard env [b] g_c2 - | None -> g_c2) in - - debug (fun () -> - BU.print4 "(1) bind: \n\tc1=%s\n\tx=%s\n\tc2=%s\n\te1=%s\n(1. end bind)\n" - (show c1) - (match b with - | None -> "none" - | Some x -> show x) - (show c2) - (match e1opt with - | None -> "none" - | Some e1 -> show e1)); - let aux () = - if U.is_trivial_wp c1 - then match b with - | None -> - Inl (c2, "trivial no binder") - | Some _ -> - if U.is_ml_comp c2 //|| not (U.is_free [Inr x] (U.freevars_comp c2)) - then Inl (c2, "trivial ml") - else Inr "c1 trivial; but c2 is not ML" - else if U.is_ml_comp c1 && U.is_ml_comp c2 - then Inl (c2, "both ml") - else Inr "c1 not trivial, and both are not ML" - in - let try_simplify () : either (comp & guard_t & string) string = - let aux_with_trivial_guard () = - match aux () with - | Inl (c, reason) -> Inl (c, trivial_guard, reason) - | Inr reason -> Inr reason in - if Env.too_early_in_prims env //if we're very early in prims - then //if U.is_tot_or_gtot_comp c1 - //&& U.is_tot_or_gtot_comp c2 - Inl (c2, trivial_guard, "Early in prims; we don't have bind yet") - // else raise_error (Errors.Fatal_NonTrivialPreConditionInPrims, - // "Non-trivial pre-conditions very early in prims, even before we have defined the PURE monad") - // (Env.get_range env) - else if U.is_total_comp c1 - then (* - * Helper routine to close the compuation c with c1's return type - * When c1's return type is of the form _:t{phi}, is is useful to know - * that t{phi} is inhabited, even if c1 is inlined etc. - *) - let close_with_type_of_x (x:bv) (c:comp) = - let x = { x with sort = U.comp_result c1 } in - maybe_capture_unit_refinement env x.sort x c in - match e1opt, b with - | Some e, Some x -> - let c2, g_close = c2 |> SS.subst_comp [NT (x, e)] |> close_with_type_of_x x in - Inl (c2, Env.conj_guards [ - g_c1; - Env.map_guard g_c2 (SS.subst [NT (x, e)]); - g_close ], "c1 Tot") - | _, Some x -> - let c2, g_close = c2 |> close_with_type_of_x x in - Inl (c2, Env.conj_guards [ - g_c1; - Env.close_guard env [S.mk_binder x] g_c2; - g_close ], "c1 Tot only close") - | _, _ -> aux_with_trivial_guard () - else if U.is_tot_or_gtot_comp c1 - && U.is_tot_or_gtot_comp c2 - then Inl (S.mk_GTotal (U.comp_result c2), trivial_guard, "both GTot") - else aux_with_trivial_guard () - in - match try_simplify () with - | Inl (c, g, reason) -> - debug (fun () -> - BU.print2 "(2) bind: Simplified (because %s) to\n\t%s\n" - reason - (show c)); - c, g - | Inr reason -> - debug (fun () -> - BU.print1 "(2) bind: Not simplified because %s\n" reason); - - let mk_bind c1 b c2 g = (* AR: end code for inlining pure and ghost terms *) - let c, g_bind = mk_bind env c1 b c2 bind_flags r1 in - c, Env.conj_guard g g_bind in - - (* AR: we have let the previously applied bind optimizations take effect, below is the code to do more inlining for pure and ghost terms *) - let u_res_t1, res_t1 = - let t = U.comp_result c1 in - match comp_univ_opt c1 with - | None -> env.universe_of env t, t - | Some u -> u, t in - //c1 and c2 are bound to the input comps - if Option.isSome b - && should_return env e1opt lc1 - then let e1 = Option.get e1opt in - let x = Option.get b in - //we will inline e1 in the WP of c2 - //Aiming to build a VC of the form - // - // M.bind (lift_(Pure/Ghost)_M wp1) - // (x == e1 ==> lift_M2_M (wp2[e1/x])) - // - // - //The additional equality hypothesis may seem - //redundant, but c1's post-condition or type may carry - //some meaningful information Then, it's important to - //weaken wp2 to with the equality, So that whatever - //property is proven about the result of wp1 (i.e., x) - //is still available in the proof of wp2 However, we - //do one optimization: - - //if c1 is already a return or a - //partial return, then it already provides this equality, - //so no need to add it again and instead generate - // - // M.bind (lift_(Pure/Ghost)_M wp1) - // (lift_M2_M (wp2[e1/x])) - - //If the optimization does not apply, - //then we generate the WP mentioned at the top, - //i.e. - // - // M.bind (lift_(Pure/Ghost)_M wp1) - // (x == e1 ==> lift_M2_M (wp2[e1/x])) - - if U.is_partial_return c1 - then - let _ = debug (fun () -> - BU.print2 "(3) bind (case a): Substituting %s for %s\n" (N.term_to_string env e1) (show x)) in - let c2 = SS.subst_comp [NT(x,e1)] c2 in - let g = Env.conj_guard g_c1 (Env.map_guard g_c2 (SS.subst [NT (x, e1)])) in - mk_bind c1 b c2 g - else - let _ = debug (fun () -> - BU.print2 "(3) bind (case b): Adding equality %s = %s\n" (N.term_to_string env e1) (show x)) in - let c2 = SS.subst_comp [NT(x,e1)] c2 in - let x_eq_e = U.mk_eq2 u_res_t1 res_t1 e1 (bv_to_name x) in - let c2, g_w = weaken_comp (Env.push_binders env [S.mk_binder x]) c2 x_eq_e in - let g = Env.conj_guards [ - g_c1; - Env.close_guard env [S.mk_binder x] g_w; - Env.close_guard env [S.mk_binder x] (TcComm.weaken_guard_formula g_c2 x_eq_e) ] in - mk_bind c1 b c2 g - //Caution: here we keep the flags for c2 as is, these flags will be overwritten later when we do md.bind below - //If we decide to return c2 as is (after inlining), we should reset these flags else bad things will happen - else mk_bind c1 b c2 trivial_guard - end - in TcComm.mk_lcomp joined_eff - lc2.res_typ - (* TODO : these cflags might be inconsistent with the one returned by bind_it !!! *) - bind_flags - bind_it - -let weaken_guard g1 g2 = match g1, g2 with - | NonTrivial f1, NonTrivial f2 -> - let g = (U.mk_imp f1 f2) in - NonTrivial g - | _ -> g2 - - -(* - * e has type lc, and lc is either pure or ghost - * This function inserts a return (x==e) in lc - * - * Optionally, callers can provide an effect M that they would like to return - * into - * - * If lc is PURE, the return happens in M - * else if it is GHOST, the return happens in PURE - * - * If caller does not provide the m effect, return happens in PURE - * - * This forces the lcomp thunk and recreates it to keep the callers same - *) -let assume_result_eq_pure_term_in_m env (m_opt:option lident) (e:term) (lc:lcomp) : lcomp = - (* - * AR: m is the effect that we are going to do return in - *) - let m = - if m_opt |> is_none || is_ghost_effect env lc.eff_name - then C.effect_PURE_lid - else m_opt |> must in - - let flags = - if TcComm.is_total_lcomp lc then RETURN::lc.cflags else PARTIAL_RETURN::lc.cflags in - - let refine () : comp & guard_t = - let c, g_c = TcComm.lcomp_comp lc in - let u_t = - match comp_univ_opt c with - | Some u_t -> u_t - | None -> env.universe_of env (U.comp_result c) - in - if U.is_tot_or_gtot_comp c - then //AR: insert an M.return - let retc, g_retc = return_value env m (Some u_t) (U.comp_result c) e in - let g_c = Env.conj_guard g_c g_retc in - if not (U.is_pure_comp c) //it started in GTot, so it should end up in Ghost - then let retc = Env.comp_to_comp_typ env retc in - let retc = {retc with effect_name=C.effect_GHOST_lid; flags=flags} in - S.mk_Comp retc, g_c - else Env.comp_set_flags env retc flags, g_c - else //AR: augment c's post-condition with a M.return - let c = Env.unfold_effect_abbrev env c in - let t = c.result_typ in - let c = mk_Comp c in - let x = S.new_bv (Some t.pos) t in - let xexp = S.bv_to_name x in - let env_x = Env.push_bv env x in - let ret, g_ret = return_value env_x m (Some u_t) t xexp in - let ret = TcComm.lcomp_of_comp <| Env.comp_set_flags env_x ret [PARTIAL_RETURN] in - let eq = U.mk_eq2 u_t t xexp e in - let eq_ret = weaken_precondition env_x ret (NonTrivial eq) in - let bind_c, g_bind = TcComm.lcomp_comp (bind e.pos env None (TcComm.lcomp_of_comp c) (Some x, eq_ret)) in - Env.comp_set_flags env bind_c flags, Env.conj_guards [g_c; g_ret; g_bind] - in - - if should_not_inline_lc lc - then raise_error e Errors.Fatal_UnexpectedTerm [ - text "assume_result_eq_pure_term cannot inline an non-inlineable lc : " ^^ pp e; - ] - - else let c, g = refine () in - TcComm.lcomp_of_comp_guard c g - -let maybe_assume_result_eq_pure_term_in_m env (m_opt:option lident) (e:term) (lc:lcomp) : lcomp = - let should_return = - not env.phase1 - && not (Env.too_early_in_prims env) //we're not too early in prims - && should_return env (Some e) lc - && not (TcComm.is_lcomp_partial_return lc) - in - if not should_return then lc - else assume_result_eq_pure_term_in_m env m_opt e lc - -let maybe_assume_result_eq_pure_term env e lc = - maybe_assume_result_eq_pure_term_in_m env None e lc - -let maybe_return_e2_and_bind - (r:Range.range) - (env:env) - (e1opt:option term) - (lc1:lcomp) - (e2:term) - (x, lc2) - : lcomp = - let env_x = - match x with - | None -> env - | Some x -> Env.push_bv env x in - - let lc1, lc2 = N.ghost_to_pure_lcomp2 env (lc1, lc2) in - - //AR: use c1's effect to return c2 into - let lc2 = - let eff1 = Env.norm_eff_name env lc1.eff_name in - let eff2 = Env.norm_eff_name env lc2.eff_name in - - (* - * AR: If eff1 and eff2 cannot be composed, and eff2 is PURE, - * we must return eff2 into eff1, - *) - if lid_equals eff2 C.effect_PURE_lid && - Env.join_opt env eff1 eff2 |> is_none && - Env.exists_polymonadic_bind env eff1 eff2 |> is_none - then assume_result_eq_pure_term_in_m env_x (eff1 |> Some) e2 lc2 - else if (not (is_pure_or_ghost_effect env eff1) - || should_not_inline_lc lc1) - && is_pure_or_ghost_effect env eff2 - then maybe_assume_result_eq_pure_term_in_m env_x (eff1 |> Some) e2 lc2 - else lc2 in //the resulting computation is still pure/ghost and inlineable; no need to insert a return - bind r env e1opt lc1 (x, lc2) - -let fvar_env env lid = S.fvar (Ident.set_lid_range lid (Env.get_range env)) None - -// -// Apply substitutive ite combinator for indexed effects -// -let substitutive_indexed_ite_substs (env:env) - (k:S.indexed_effect_combinator_kind) - (bs:binders) - (a:typ) - (p:term) - (ct_then:comp_typ) - (ct_else:comp_typ) - (num_effect_params:int) - (r:Range.range) - - : list subst_elt & guard_t = - - let debug = !dbg_LayeredEffectsApp in - - // go through the binders bs and aggregate substitutions and guards - - let bs, subst = - let a_b::bs = bs in - bs, [NT (a_b.binder_bv, a)] in - - // effect parameters - let bs, subst, guard, args1, args2 = - if num_effect_params = 0 - then bs, subst, Env.trivial_guard, ct_then.effect_args, ct_else.effect_args - else // peel off effect parameters from ct_then and ct_else, - // and equate them - let split (l:list 'a) = List.splitAt num_effect_params l in - let eff_params_bs, bs = split bs in - let param_args1, args1 = split ct_then.effect_args in - let param_args2, args2 = split ct_else.effect_args in - let g = List.fold_left2 (fun g (arg1, _) (arg2, _) -> - Env.conj_guard g - (Rel.layered_effect_teq env arg1 arg2 (Some "effect param ite")) - ) Env.trivial_guard param_args1 param_args2 in - let param_subst = List.map2 (fun b (arg, _) -> - NT (b.binder_bv, arg)) eff_params_bs param_args1 in - bs, subst@param_subst, g, args1, args2 in - - // f binders - let bs, subst = - let m_num_effect_args = List.length args1 in - let f_bs, bs = List.splitAt m_num_effect_args bs in - let f_subst = List.map2 (fun f_b (arg, _) -> NT (f_b.binder_bv, arg)) f_bs args1 in - bs, subst@f_subst in - - // g binders - let bs, subst, guard = - if Substitutive_combinator? k - then begin - let n_num_effect_args = List.length args2 in - let g_bs, bs = List.splitAt n_num_effect_args bs in - let g_subst = List.map2 (fun g_b (arg, _) -> NT (g_b.binder_bv, arg)) g_bs args2 in - bs, subst@g_subst, guard - end - else if Substitutive_invariant_combinator? k - then begin - bs, - subst, - List.fold_left2 (fun guard (arg1, _) (arg2, _) -> - Env.conj_guard guard - (Rel.layered_effect_teq env arg1 arg2 (Some "substitutive_inv ite args")) - ) guard args1 args2 - end - else failwith "Impossible (substitutive_indexed_ite: unexpected k)" in - - let bs, [_; _; p_b] = List.splitAt (List.length bs - 3) bs in - - let subst, g = - List.fold_left (fun (subst, g) b -> - let [uv_t], g_uv = Env.uvars_for_binders env [b] subst - (fun b -> - if debug - then BU.format3 "implicit var for additional ite binder %s of %s at %s)" - (show b) - (string_of_lid ct_then.effect_name) - (Range.string_of_range r) - else "substitutive_indexed_ite_substs") - r in - subst@[NT (b.binder_bv, uv_t)], - Env.conj_guard g g_uv) (subst, guard) bs in - - subst@[NT (p_b.binder_bv, p)], - g - -let ad_hoc_indexed_ite_substs (env:env) - (bs:binders) - (a:typ) - (p:term) - (ct_then:comp_typ) - (ct_else:comp_typ) - (r:Range.range) - - : list subst_elt & guard_t = - - let debug = !dbg_LayeredEffectsApp in - - let conjunction_name () = - if debug then BU.format1 "%s.conjunction" (string_of_lid ct_then.effect_name) - else "" in - - let conjunction_t_error #a r (s:string) : a = - raise_error r Errors.Fatal_UnexpectedEffect [ - text "Conjunction" ^^ pp ct_then.effect_name ^^ text "does not have proper shape."; - text "Reason: " ^^ text s; - ] - in - let a_b, rest_bs, f_b, g_b, p_b = - if List.length bs >= 4 - then let a_b::bs = bs in - let rest_bs, [f_b; g_b; p_b] = List.splitAt (List.length bs - 3) bs in - a_b, rest_bs, f_b, g_b, p_b - else conjunction_t_error r "Either not an abstraction or not enough binders" in - - let rest_bs_uvars, g_uvars = - Env.uvars_for_binders - env rest_bs [NT (a_b.binder_bv, a)] - (fun b -> - if debug - then BU.format3 - "implicit var for binder %s of %s:conjunction at %s" - (show b) (Ident.string_of_lid ct_then.effect_name) - (r |> Range.string_of_range) - else "ad_hoc_indexed_ite_substs") r in - - let substs = List.map2 - (fun b t -> NT (b.binder_bv, t)) - (a_b::(rest_bs@[p_b])) (a::(rest_bs_uvars@[p])) in - - let f_guard = - let f_sort_is = - match (SS.compress f_b.binder_bv.sort).n with - | Tm_app {args=_::is} -> - is |> List.map fst |> List.map (SS.subst substs) - | _ -> conjunction_t_error r "f's type is not a repr type" in - List.fold_left2 - (fun g i1 f_i -> - Env.conj_guard - g - (Rel.layered_effect_teq env i1 f_i (Some (conjunction_name ())))) - Env.trivial_guard (List.map fst ct_then.effect_args) f_sort_is in - - let g_guard = - let g_sort_is = - match (SS.compress g_b.binder_bv.sort).n with - | Tm_app {args=_::is} -> - is |> List.map fst |> List.map (SS.subst substs) - | _ -> conjunction_t_error r "g's type is not a repr type" in - List.fold_left2 - (fun g i2 g_i -> Env.conj_guard g (Rel.layered_effect_teq env i2 g_i (Some (conjunction_name ())))) - Env.trivial_guard (List.map fst ct_else.effect_args) g_sort_is in - - substs, - Env.conj_guards [g_uvars; f_guard; g_guard] - -let mk_layered_conjunction env (ed:S.eff_decl) (u_a:universe) (a:term) (p:typ) (ct1:comp_typ) (ct2:comp_typ) (r:Range.range) -: comp & guard_t = - - let debug = !dbg_LayeredEffectsApp in - - let conjunction_t_error #a r (s:string) : a = - raise_error r Errors.Fatal_UnexpectedEffect [ - text "Conjunction" ^^ pp ct1.effect_name ^^ text "does not have proper shape."; - text "Reason: " ^^ text s; - ] - in - - let conjunction, kind = - let ts, kopt = ed |> U.get_layered_if_then_else_combinator |> must in - let _, conjunction = Env.inst_tscheme_with ts [u_a] in - conjunction, kopt |> must in - - let bs, body, _ = U.abs_formals conjunction in - - if debug then - BU.print2 "layered_ite c1: %s and c2: %s {\n" - (ct1 |> S.mk_Comp |> show) - (ct2 |> S.mk_Comp |> show); - - let substs, g = - if kind = Ad_hoc_combinator - then ad_hoc_indexed_ite_substs env bs a p ct1 ct2 r - else let num_effect_params = - match ed.signature with - | Layered_eff_sig (n, _) -> n - | _ -> failwith "Impossible!" in - substitutive_indexed_ite_substs env kind bs a p ct1 ct2 num_effect_params r in - - let body = SS.subst substs body in - - let is = - match (SS.compress body).n with - | Tm_app {args=a::args} -> List.map fst args - | _ -> conjunction_t_error r "body is not a repr type" in - - let c = mk_Comp ({ - comp_univs = [u_a]; - effect_name = ed.mname; - result_typ = a; - effect_args = is |> List.map S.as_arg; - flags = [] - }) in - - if debug then BU.print_string "\n}\n"; - - c, g - -(* - * For non-layered effects, just apply the if_then_else combinator - *) -let mk_non_layered_conjunction env (ed:S.eff_decl) (u_a:universe) (a:term) (p:typ) (ct1:comp_typ) (ct2:comp_typ) (_:Range.range) -: comp & guard_t = - //p is a boolean guard, so b2t it - let p = U.b2t p in - let if_then_else = ed |> U.get_wp_if_then_else_combinator |> must in - let _, _, wp_t = destruct_wp_comp ct1 in - let _, _, wp_e = destruct_wp_comp ct2 in - let wp = mk_Tm_app (inst_effect_fun_with [u_a] env ed if_then_else) - [S.as_arg a; S.as_arg p; S.as_arg wp_t; S.as_arg wp_e] - (Range.union_ranges wp_t.pos wp_e.pos) in - mk_comp ed u_a a wp [], Env.trivial_guard - -(* - * PURE t (fun _ -> False) - * - * This is the comp type for a match with no cases (used in bind_cases) - *) -let comp_pure_wp_false env (u:universe) (t:typ) = - let post_k = U.arrow [null_binder t] (S.mk_Total U.ktype0) in - let kwp = U.arrow [null_binder post_k] (S.mk_Total U.ktype0) in - let post = S.new_bv None post_k in - let wp = U.abs [S.mk_binder post] - (fvar_env env C.false_lid) - (Some (U.mk_residual_comp C.effect_Tot_lid None [TOTAL])) in - let md = Env.get_effect_decl env C.effect_PURE_lid in - mk_comp md u t wp [] - -(* - * When typechecking a match term, typechecking each branch returns - * a branch condition - * - * E.g. match e with | C -> ... | D -> ... - * the two branch conditions would be (is_C e) and (is_D e) - * - * This function builds a list of formulas that are the negation of - * all the previous branches - * - * In the example, neg_branch_conds would be: - * [True; not (is_C e); not (is_C e) /\ not (is_D e)] - * thus, the length of the list is one more than lcases - * - * The return value is then ([True; not (is_C e)], not (is_C e) /\ not (is_D e)) - * - * (The last element of the list becomes the branch condition for the - unreachable branch to check for pattern exhaustiveness) - *) -let get_neg_branch_conds (branch_conds:list formula) - : list formula & formula - = branch_conds - |> List.fold_left (fun (conds, acc) g -> - let cond = U.mk_conj acc (g |> U.b2t |> U.mk_neg) in - (conds@[cond]), cond) ([U.t_true], U.t_true) - |> fst - |> (fun l -> List.splitAt (List.length l - 1) l) //the length of the list is at least 1 - |> (fun (l1, l2) -> l1, List.hd l2) - -(* - * The formula in each element of lcases is the individual branch guard, a boolean - * - * This function returns a computation type for the match expression, though - * without considering the scrutinee expression (that is the job of tc_match). - * The most interesting bit is its WP, which combines the WP for each branch - * under the appropriate reachability hypothesis (see also get_neg_branch_conds - * above). It also includes a `False` obligation under the hypothesis that no - * branch matches: i.e. the exhaustiveness check. - *) -let bind_cases env0 (res_t:typ) - (lcases:list (formula & lident & list cflag & (bool -> lcomp))) - (scrutinee:bv) : lcomp = - let env = Env.push_binders env0 [scrutinee |> S.mk_binder] in - let eff = List.fold_left (fun eff (_, eff_label, _, _) -> join_effects env eff eff_label) - C.effect_PURE_lid - lcases - in - let should_not_inline_whole_match, bind_cases_flags = - if lcases |> BU.for_some (fun (_, _, flags, _) -> - flags |> BU.for_some (function SHOULD_NOT_INLINE -> true | _ -> false)) - then true, [SHOULD_NOT_INLINE] - else false, [] - in - let bind_cases () = - let u_res_t = env.universe_of env res_t in - if Options.lax() - && Options.ml_ish() //NS: Disabling this optimization temporarily - then - lax_mk_tot_or_comp_l eff u_res_t res_t [], Env.trivial_guard - else begin - let maybe_return eff_label_then cthen = - if should_not_inline_whole_match - || not (is_pure_or_ghost_effect env eff) - then cthen true //inline each the branch, if eligible - else cthen false //the entire match is pure and inlineable, so no need to inline each branch - in - - (* - * The formula in each of the branches of lcases is the branch condition of *just* that branch, - * e.g. match e with | C -> ... | D -> ... - * the formula in the two branches is is_C e and is_D e - * - * neg_branch_conds builds a list where the formulas are negation of - * all the previous branches - * - * In the example, neg_branch_conds would be: - * [True; not (is_C e); not (is_C e) /\ not (is_D e)] - * thus, the length of the list is one more than lcases - * - * The last element of the list becomes the branch condition for the - * unreachable branch (will be used to check pattern exhaustiveness) - * - * The rest of the list will be used to weaken the lift guards when combining the - * branches (for layered effects, lift guards can be non-trivial). Note that - * we don't need to do this to combine cases, because the shape of if_then_else - * (p ==> ...) /\ (not p ==> ...) - * already takes care of it - *) - let neg_branch_conds, exhaustiveness_branch_cond = - get_neg_branch_conds (lcases |> List.map (fun (g, _, _, _) -> g)) in - - let md, comp, g_comp = - match lcases with - | [] -> None, comp_pure_wp_false env u_res_t res_t, Env.trivial_guard - | _ -> - (* - * We will now compute the VC with a fold_right2 over lcases - * and neg_branch_conds - * Split the last element of lcases (and branch conditions) - * to form the base case - *) - - let lcases, neg_branch_conds, md, comp, g_comp = - let neg_branch_conds, neg_last = - neg_branch_conds - |> List.splitAt (List.length lcases - 1) - |> (fun (l1, l2) -> l1, List.hd l2) in - - let lcases, (g_last, eff_last, _, c_last) = - lcases - |> List.splitAt (List.length lcases - 1) - |> (fun (l1, l2) -> l1, List.hd l2) in - - let c, g = - let lc = maybe_return eff_last c_last in - let c, g = TcComm.lcomp_comp lc in - c, TcComm.weaken_guard_formula g (U.mk_conj (U.b2t g_last) neg_last) in - - lcases, - neg_branch_conds, - eff_last |> Env.norm_eff_name env |> Env.get_effect_decl env, - c, g in - - List.fold_right2 (fun (g, eff_label, _, cthen) neg_cond (_, celse, g_comp) -> - let cthen, g_then = TcComm.lcomp_comp (maybe_return eff_label cthen) in - //lift both the branches - //separate guards so that we can weaken them appropriately later - let md, ct_then, ct_else, g_lift_then, g_lift_else = - let m, cthen, celse, g_lift_then, g_lift_else = - lift_comps_sep_guards env cthen celse None false in - let md = Env.get_effect_decl env m in - md, - cthen |> Env.comp_to_comp_typ env, celse |> Env.comp_to_comp_typ env, - g_lift_then, g_lift_else in - - //function to apply the if-then-else combinator - let fn = - if md |> U.is_layered then mk_layered_conjunction - else mk_non_layered_conjunction in - - let c, g_conjunction = fn env md u_res_t res_t g ct_then ct_else (Env.get_range env) in - - //weaken the then and else guards - //neg_cond is the negated branch condition upto this branch - let g_then, g_else = - let g = U.b2t g in - TcComm.weaken_guard_formula - (Env.conj_guard g_then g_lift_then) - (U.mk_conj neg_cond g), - TcComm.weaken_guard_formula - g_lift_else - (U.mk_conj neg_cond (U.mk_neg g)) in - - Some md, - c, - Env.conj_guards [g_comp; g_then; g_else; g_conjunction] - ) lcases neg_branch_conds (Some md, comp, g_comp) in - - //strengthen comp with the exhaustiveness check - let comp, g_comp = - let c, g = - let check = U.mk_imp exhaustiveness_branch_cond U.t_false in - let check = label Err.exhaustiveness_check (Env.get_range env) check in - strengthen_comp env None comp check bind_cases_flags in - c, Env.conj_guard g_comp g in - - //AR: 11/18: we don't need to close this guard with the scrutinee bv - // since the tc_match code does a bind with the scrutinee - // expression, which will take care of this bv - //close g_comp with the scrutinee bv - //let g_comp = Env.close_guard env0 [scrutinee |> S.mk_binder] g_comp in - - match lcases with - | [] - | [_] -> comp, g_comp - | _ -> - if md |> must |> U.is_layered then comp, g_comp - else - let comp = Env.comp_to_comp_typ env comp in - let md = Env.get_effect_decl env comp.effect_name in - let _, _, wp = destruct_wp_comp comp in - let ite_wp = md |> U.get_wp_ite_combinator |> must in - let wp = mk_Tm_app (inst_effect_fun_with [u_res_t] env md ite_wp) - [S.as_arg res_t; S.as_arg wp] - wp.pos in - mk_comp md u_res_t res_t wp bind_cases_flags, g_comp - end - in - TcComm.mk_lcomp eff res_t bind_cases_flags bind_cases - -let check_comp env (use_eq:bool) (e:term) (c:comp) (c':comp) : term & comp & guard_t = - def_check_scoped c.pos "check_comp.c" env c; - def_check_scoped c'.pos "check_comp.c'" env c'; - if Debug.extreme () then - BU.print4 "Checking comp relation:\n%s has type %s\n\t %s \n%s\n" - (show e) - (show c) - (if use_eq then "$:" else "<:") - (show c'); - let f = if use_eq then Rel.eq_comp else Rel.sub_comp in - match f env c c' with - | None -> - if use_eq - then Err.computed_computation_type_does_not_match_annotation_eq env (Env.get_range env) e c c' - else Err.computed_computation_type_does_not_match_annotation env (Env.get_range env) e c c' - | Some g -> e, c', g - -let universe_of_comp env u_res c = - (* - * Universe computation for M t wp: - * if M is pure or ghost, then return universe of t - * else if M is not marked Total, then return u0 - * else if M has no additional binders, then return universe of t - * else delegate the computation to repr of M, error out of no repr - *) - let c_lid = c |> U.comp_effect_name |> Env.norm_eff_name env in - if U.is_pure_or_ghost_effect c_lid then u_res //if pure or ghost, return the universe of the return type - else - let is_total = Env.lookup_effect_quals env c_lid |> List.existsb (fun q -> q = S.TotalEffect) in - if not is_total then S.U_zero //if it is a non-total effect then u0 - else match Env.effect_repr env c u_res with - | None -> - raise_error c Errors.Fatal_EffectCannotBeReified - (BU.format1 "Effect %s is marked total but does not have a repr" (show c_lid)) - | Some tm -> env.universe_of env tm - -let check_trivial_precondition_wp env c = - let ct = c |> Env.unfold_effect_abbrev env in - let md = Env.get_effect_decl env ct.effect_name in - let u_t, t, wp = destruct_wp_comp ct in - let vc = mk_Tm_app - (inst_effect_fun_with [u_t] env md (md |> U.get_wp_trivial_combinator |> must)) - [S.as_arg t; S.as_arg wp] - (Env.get_range env) - in - - ct, vc, Env.guard_of_guard_formula <| NonTrivial vc - -//Decorating terms with monadic operators -let maybe_lift env e c1 c2 t = - let m1 = Env.norm_eff_name env c1 in - let m2 = Env.norm_eff_name env c2 in - if Ident.lid_equals m1 m2 - || (U.is_pure_effect c1 && U.is_ghost_effect c2) - || (U.is_pure_effect c2 && U.is_ghost_effect c1) - then e - else mk (Tm_meta {tm=e; meta=Meta_monadic_lift(m1, m2, t)}) e.pos - -let maybe_monadic env e c t = - let m = Env.norm_eff_name env c in - if is_pure_or_ghost_effect env m - || Ident.lid_equals m C.effect_Tot_lid - || Ident.lid_equals m C.effect_GTot_lid //for the cases in prims where Pure is not yet defined - then e - else mk (Tm_meta {tm=e; meta=Meta_monadic (m, t)}) e.pos - -let coerce_with (env:Env.env) - (e : term) (lc : lcomp) // original term and its computation type - (f : lident) // coercion - (us : universes) (eargs : args) // extra arguments to coertion - (comp2 : comp) // new result computation type - : term & lcomp = - match Env.try_lookup_lid env f with - | Some _ -> - if !dbg_Coercions then - BU.print1 "Coercing with %s!\n" (Ident.string_of_lid f); - let lc2 = TcComm.lcomp_of_comp <| comp2 in - let lc_res = bind e.pos env (Some e) lc (None, lc2) in - let coercion = S.fvar (Ident.set_lid_range f e.pos) None in - let coercion = S.mk_Tm_uinst coercion us in - - // - //Creating the coerced term: - // If lc is pure or ghost, then just create the application node - // Else create let x = e in f x - // with appropriate meta monadic nodes - // - let e = - if TcComm.is_pure_or_ghost_lcomp lc - then mk_Tm_app coercion (eargs@[S.as_arg e]) e.pos - else let x = S.new_bv (Some e.pos) lc.res_typ in - let e2 = mk_Tm_app coercion (eargs@[x |> S.bv_to_name |> S.as_arg]) e.pos in - let e = maybe_lift env e lc.eff_name lc_res.eff_name lc.res_typ in - let e2 = maybe_lift (Env.push_bv env x) e2 lc2.eff_name lc_res.eff_name lc2.res_typ in - let lb = U.mk_letbinding (Inl x) [] lc.res_typ lc_res.eff_name e [] e.pos in - let e = mk (Tm_let {lbs=(false, [lb]); body=SS.close [S.mk_binder x] e2}) e.pos in - maybe_monadic env e lc_res.eff_name lc_res.res_typ in - e, lc_res - | None -> - Errors.log_issue e Errors.Warning_CoercionNotFound - (BU.format1 "Coercion %s was not found in the environment, not coercing." - (string_of_lid f)); - e, lc - -type isErased = - | Yes of term - | Maybe - | No - -let rec check_erased (env:Env.env) (t:term) : isErased = - let norm' = N.normalize [Beta; Eager_unfolding; - UnfoldUntil delta_constant; - Exclude Zeta; Primops; - Unascribe; Unmeta; Unrefine; - Weak; HNF; Iota] - in - let t = norm' env t in - let h, args = U.head_and_args t in - let h = U.un_uinst h in - let r = - match (SS.compress h).n, args with - | Tm_fvar fv, [(a, _)] when S.fv_eq_lid fv C.erased_lid -> - Yes a - - (* In these two cases, we cannot guarantee that `t` is not - * an erased, so we're conservatively returning `false` *) - | Tm_uvar _, _ - | Tm_unknown, _ -> Maybe - - (* - * AR: For Tm_match: - * We are only interested in returning a No or Maybe - * Since even if all the branched are erased types, - * we need to find their join to return to the caller - * That's messy - * We can't always return Maybe, since that breaks simple - * cases like the int types in FStar.Integers - * So we iterate over all the branches and return a No if possible - *) - | Tm_match {brs=branches}, _ -> - branches |> List.fold_left (fun acc br -> - match acc with - | Yes _ | Maybe -> Maybe - | No -> - let _, _, br_body = Subst.open_branch br in - match - br_body - |> check_erased - (br_body - |> Free.names - |> elems // GGG: bad, order-depending - |> Env.push_bvs env) with - | No -> No - | _ -> Maybe) No - - - (* Anything else cannot be `erased` *) - | _ -> - No - in - (* if Debug.any () then *) - (* BU.print2 "check_erased (%s) = %s\n" *) - (* (show t) *) - (* (match r with *) - (* | Yes a -> "Yes " ^ show a *) - (* | Maybe -> "Maybe" *) - (* | No -> "No"); *) - r - -let rec first_opt (f : 'a -> option 'b) (xs : list 'a) : option 'b = - match xs with - | [] -> None - | x::xs -> BU.catch_opt (f x) (fun () -> first_opt f xs) - -let (let?) = BU.bind_opt -let bool_guard (b:bool) : option unit = - if b then Some () else None - -let find_coercion (env:Env.env) (checked: lcomp) (exp_t: typ) (e:term) -: option (term & lcomp & guard_t) -// returns coerced term, new lcomp type, and guard -// or None if no coercion applied -= - Errors.with_ctx "find_coercion" (fun () -> - let is_type t = - let t = N.unfold_whnf env t in - let t = U.unrefine t in (* mostly to catch `prop` too *) - match (SS.compress t).n with - | Tm_type _ -> true - | _ -> false - in - let rec head_of (t : term) : term = - match (compress t).n with - | Tm_app {hd=t} - | Tm_match {scrutinee=t} - | Tm_abs {body=t} - | Tm_ascribed {tm=t} - | Tm_meta {tm=t} -> head_of t - | Tm_refine {b} -> head_of b.sort - | _ -> t - in - let is_head_defined t = - let h = head_of t in - let h = SS.compress h in - Tm_fvar? h.n || Tm_uinst? h.n || Tm_type? h.n - in - - let head_unfold env t = N.unfold_whnf' [Unascribe; Unmeta; Unrefine] env t in - - (* Bail out early if either the computed or expected type are not - defined at the head *) - bool_guard (is_head_defined exp_t && is_head_defined checked.res_typ);? - - (* The computed type for `e`. *) - let computed_t = head_unfold env checked.res_typ in - let head, args = U.head_and_args computed_t in - - (* The expected type according to the context. *) - let exp_t = head_unfold env exp_t in - - match (U.un_uinst head).n, args with - (* b2t is primitive... for now *) - | Tm_fvar fv, [] when S.fv_eq_lid fv C.bool_lid && is_type exp_t -> - let lc2 = TcComm.lcomp_of_comp <| S.mk_Total U.ktype0 in - let lc_res = bind e.pos env (Some e) checked (None, lc2) in - Some (U.mk_app (S.fvar C.b2t_lid None) [S.as_arg e], lc_res, Env.trivial_guard) - - (* user coercions, find candidates with the @@coercion attribute and try. *) - | _ -> - let head_lid_of t = - match (SS.compress (head_of t)).n with - | Tm_fvar fv - | Tm_uinst ({ n = Tm_fvar fv }, _) -> - Some (S.lid_of_fv fv) - | _ -> None - in - - let? exp_head_lid = head_lid_of exp_t in - let? computed_head_lid = head_lid_of computed_t in - - let candidates = Env.lookup_attr env "FStar.Pervasives.coercion" in - candidates |> first_opt (fun se -> - (* `f` is the candidate coercion, `e` the term to coerce *) - let? f_name, f_us, f_typ = - match se.sigel with - | Sig_let {lbs=(_,[lb])} -> Some (S.lid_of_fv (BU.right lb.lbname), lb.lbunivs, lb.lbtyp) - | Sig_declare_typ {lid; us; t} -> Some (lid, us, t) - | _ -> None - in - - let _, f_typ = SS.open_univ_vars f_us f_typ in - - (* `f` must have type `b1 -> b2 -> .... -> bN -> TB -> M TC ..., - Before attempting unification, which is expensive, we will - check that the head of B is an fvar which matches the expected - type, and that the head of A is and fvar which matches the type - of e. - *) - let f_bs, f_c = U.arrow_formals_comp f_typ in - bool_guard (f_bs <> []);? (* If not a function, ignore *) - let f_res = U.comp_result f_c in - let f_res = head_unfold (Env.push_binders env f_bs) f_res in - let? f_res_head_lid = head_lid_of f_res in - (* ^ The lid at the head of TC, the result type *) - bool_guard (lid_equals exp_head_lid f_res_head_lid);? - - let b = List.last f_bs in - let b_ty = b.binder_bv.sort in - let b_ty = head_unfold (Env.push_binders env (List.init f_bs)) b_ty in - let? b_head_lid = head_lid_of b_ty in - (* ^ The lid at the head of TB, the last argument *) - bool_guard (lid_equals computed_head_lid b_head_lid);? - - (* We will now typecheck the coercion applied to `e` at expected type - `exp_t` likely causing implicits to be instantiated for the coercion - function (if any). If this succeeds, the elaborated term is the - result we want. - - FIXME: ideally, we would not pass `e` through the typechecker again, - but checking the coercion alone means we need to compute its effect (easy) - and effect indices (not easy). - - Note: we could perhaps backtrack on an error here (using - catch_errors and UF.new_transaction), but that can get - expensive, and it's perhaps unexpected. Currently, the head FVs - define which coercions apply, and that's a firm choice. - *) - - let f_tm = S.fvar f_name None in - let tt = U.mk_app f_tm [S.as_arg e] in - Some (env.tc_term { env with nocoerce=true; admit=true; expected_typ = Some (exp_t, false) } tt) - // NB: tc_term returns exactly elaborated term, lcomp, and guard, so we just return that. - ) -) - -let maybe_coerce_lc env (e:term) (lc:lcomp) (exp_t:term) : term & lcomp & guard_t = - let should_coerce = - (env.phase1 - || Options.lax ()) && not env.nocoerce - in - if not should_coerce then ( - if !dbg_Coercions then - BU.print4 "(%s) NOT Trying to coerce %s from type (%s) to type (%s)\n" - (show e.pos) (show e) (show lc.res_typ) (show exp_t); - (e, lc, Env.trivial_guard) - ) else ( - if !dbg_Coercions then - BU.print4 "(%s) Trying to coerce %s from type (%s) to type (%s)\n" - (show e.pos) (show e) (show lc.res_typ) (show exp_t); - match find_coercion env lc exp_t e with - | Some (coerced, lc, g) -> - let _ = if !dbg_Coercions then - BU.print3 "(%s) COERCING %s to %s\n" - (Range.string_of_range e.pos) - (show e) - (show coerced) - in - coerced, lc, g - | None -> - let _ = if !dbg_Coercions then - BU.print1 "(%s) No user coercion found\n" - (Range.string_of_range e.pos) - in - - (* TODO: hide/reveal also user coercions? it's trickier for sure *) - - let strip_hide_or_reveal (e:term) (hide_or_reveal:lident) : option term = - let hd, args = U.leftmost_head_and_args e in - match (SS.compress hd).n, args with - | Tm_uinst (hd, _), [(_, aq_t); (e, aq_e)] - when U.is_fvar hide_or_reveal hd && - Some? aq_t && (Some?.v aq_t).aqual_implicit && - (aq_e = None || not (Some?.v aq_e).aqual_implicit) -> - Some e - | _ -> None - in - - match check_erased env lc.res_typ, check_erased env exp_t with - | No, Yes ty -> - begin - let u = env.universe_of env ty in - match Rel.get_subtyping_predicate env lc.res_typ ty with - | None -> - e, lc, Env.trivial_guard - | Some g -> - let g = Env.apply_guard g e in - let e_hide, lc = coerce_with env e lc C.hide [u] [S.iarg ty] (S.mk_Total exp_t) in - // - // AR: an optimization to see if input e is a reveal e', - // we can just take e', rather than hide (reveal e') - // - // we still let coerce_with happen just above, - // since it has logic to compute the correct lc - // - let e_hide = BU.dflt e_hide (strip_hide_or_reveal e C.reveal) in - e_hide, lc, g - end - - | Yes ty, No -> - let u = env.universe_of env ty in - let e_reveal, lc = coerce_with env e lc C.reveal [u] [S.iarg ty] (S.mk_GTotal ty) in - let e_reveal = BU.dflt e_reveal (strip_hide_or_reveal e C.hide) in - e_reveal, lc, Env.trivial_guard - - | _ -> - e, lc, Env.trivial_guard - ) - -let weaken_result_typ env (e:term) (lc:lcomp) (t:typ) (use_eq:bool) : term & lcomp & guard_t = - if Debug.high () then - BU.print4 "weaken_result_typ use_eq=%s e=(%s) lc=(%s) t=(%s)\n" - (show use_eq) (show e) (TcComm.lcomp_to_string lc) (show t); - let use_eq = - use_eq || //caller wants to check equality - env.use_eq_strict || - (match Env.effect_decl_opt env lc.eff_name with - // See issue #881 for why weakening result type of a reifiable computation is problematic - | Some (ed, qualifiers) -> qualifiers |> List.contains Reifiable - | _ -> false) in - let gopt = if use_eq - then Rel.try_teq true env lc.res_typ t, false - else Rel.get_subtyping_predicate env lc.res_typ t, true in - match gopt with - | None, _ -> - (* - * AR: 11/18: should this always fail hard? - *) - if env.failhard - then Err.raise_basic_type_error env e.pos (Some e) t lc.res_typ - else ( - subtype_fail env e lc.res_typ t; //log a sub-typing error - e, {lc with res_typ=t}, Env.trivial_guard //and keep going to type-check the result of the program - ) - | Some g, apply_guard -> - match guard_form g with - | Trivial -> - (* - * AR: when the guard is trivial, simply setting the result type to t might lose some precision - * e.g. when input lc has return type x:int{phi} and we are weakening it to int - * so we should capture the precision before setting the comp type to t (see e.g. #1500, #1470) - *) - let strengthen_trivial () = - let c, g_c = TcComm.lcomp_comp lc in - let res_t = Util.comp_result c in - - let set_result_typ (c:comp) :comp = Util.set_result_typ c t in - - if TEQ.eq_tm env t res_t = TEQ.Equal then begin //if the two types res_t and t are same, then just set the result type - if Debug.extreme() - then BU.print2 "weaken_result_type::strengthen_trivial: res_t:%s is same as t:%s\n" - (show res_t) (show t); - set_result_typ c, g_c - end - else - let is_res_t_refinement = - let res_t = N.normalize_refinement N.whnf_steps env res_t in - match res_t.n with - | Tm_refine _ -> true - | _ -> false - in - //if t is a refinement, insert a return to capture the return type res_t - //we are not inlining e, rather just adding (fun (x:res_t) -> p x) at the end - if is_res_t_refinement then - let x = S.new_bv (Some res_t.pos) res_t in - //AR: build M.return, where M is c's effect - let cret, gret = return_value env (c |> U.comp_effect_name |> Env.norm_eff_name env) - (comp_univ_opt c) res_t (S.bv_to_name x) in - //AR: an M_M bind - let lc = bind e.pos env (Some e) (TcComm.lcomp_of_comp c) (Some x, TcComm.lcomp_of_comp cret) in - if Debug.extreme () - then BU.print4 "weaken_result_type::strengthen_trivial: inserting a return for e: %s, c: %s, t: %s, and then post return lc: %s\n" - (show e) (show c) (show t) (TcComm.lcomp_to_string lc); - let c, g_lc = TcComm.lcomp_comp lc in - set_result_typ c, Env.conj_guards [g_c; gret; g_lc] - else begin - if Debug.extreme () - then BU.print2 "weaken_result_type::strengthen_trivial: res_t:%s is not a refinement, leaving c:%s as is\n" - (show res_t) (show c); - set_result_typ c, g_c - end - in - let lc = TcComm.mk_lcomp lc.eff_name t lc.cflags strengthen_trivial in - e, lc, g - - | NonTrivial f -> - let g = {g with guard_f=Trivial} in - let strengthen () = - if Options.lax() - && Options.ml_ish() //NS: disabling this optimization temporarily - then - TcComm.lcomp_comp lc - else begin - //try to normalize one more time, since more unification variables may be resolved now - let f = N.normalize [Env.Beta; Env.Eager_unfolding; Env.Simplify; Env.Primops] env f in - match (SS.compress f).n with - | Tm_abs {body={n=Tm_fvar fv}} when S.fv_eq_lid fv C.true_lid -> - //it's trivial - let lc = {lc with res_typ=t} in //NS: what's the point of this? - TcComm.lcomp_comp lc - - | _ -> - let c, g_c = TcComm.lcomp_comp lc in - if Debug.extreme () - then BU.print4 "Weakened from %s to %s\nStrengthening %s with guard %s\n" - (N.term_to_string env lc.res_typ) - (N.term_to_string env t) - (N.comp_to_string env c) - (N.term_to_string env f); - - let u_t_opt = comp_univ_opt c in - let x = S.new_bv (Some t.pos) t in - let xexp = S.bv_to_name x in - //AR: M.return - let cret, gret = return_value env - (c |> U.comp_effect_name |> Env.norm_eff_name env) - u_t_opt t xexp in - let guard = if apply_guard - then mk_Tm_app f [S.as_arg xexp] f.pos - else f - in - let eq_ret, _trivial_so_ok_to_discard = - strengthen_precondition (Some <| Err.subtyping_failed env lc.res_typ t) - (Env.set_range (Env.push_bvs env [x]) e.pos) - e //use e for debugging only - (TcComm.lcomp_of_comp cret) - (guard_of_guard_formula <| NonTrivial guard) - in - let x = {x with sort=lc.res_typ} in - //AR: M_M bind - let c = bind e.pos env (Some e) (TcComm.lcomp_of_comp c) (Some x, eq_ret) in - let c, g_lc = TcComm.lcomp_comp c in - if Debug.extreme () - then BU.print1 "Strengthened to %s\n" (Normalize.comp_to_string env c); - c, Env.conj_guards [g_c; gret; g_lc] - end - in - let flags = lc.cflags |> List.collect (function - | RETURN | PARTIAL_RETURN -> [PARTIAL_RETURN] - | CPS -> [CPS] // KM : Not exactly sure if it is necessary - | _ -> []) - in - let lc = TcComm.mk_lcomp (norm_eff_name env lc.eff_name) t flags strengthen in - let g = {g with guard_f=Trivial} in - (e, lc, g) - -let pure_or_ghost_pre_and_post env comp = - let mk_post_type res_t ens = - let x = S.new_bv None res_t in - U.refine x (S.mk_Tm_app ens [S.as_arg (S.bv_to_name x)] res_t.pos) in - let norm t = Normalize.normalize [Env.Beta;Env.Eager_unfolding;Env.EraseUniverses] env t in - if U.is_tot_or_gtot_comp comp - then None, U.comp_result comp - else begin match comp.n with - | GTotal _ - | Total _ -> failwith "Impossible" - | Comp ct -> - if lid_equals ct.effect_name C.effect_Pure_lid - || lid_equals ct.effect_name C.effect_Ghost_lid - then begin match ct.effect_args with - | (req, _)::(ens, _)::_ -> - Some (norm req), (norm <| mk_post_type ct.result_typ ens) - | _ -> - raise_error comp Errors.Fatal_EffectConstructorNotFullyApplied - (BU.format1 "Effect constructor is not fully applied; got %s" (show comp)) - end - else let ct = Env.unfold_effect_abbrev env comp in - begin match ct.effect_args with - | (wp, _)::_ -> - let us_r, _ = fst <| Env.lookup_lid env C.as_requires in - let us_e, _ = fst <| Env.lookup_lid env C.as_ensures in - let r = ct.result_typ.pos in - let as_req = S.mk_Tm_uinst (S.fvar (Ident.set_lid_range C.as_requires r) None) us_r in - let as_ens = S.mk_Tm_uinst (S.fvar (Ident.set_lid_range C.as_ensures r) None) us_e in - let req = mk_Tm_app as_req [(ct.result_typ, S.as_aqual_implicit true); S.as_arg wp] ct.result_typ.pos in - let ens = mk_Tm_app as_ens [(ct.result_typ, S.as_aqual_implicit true); S.as_arg wp] ct.result_typ.pos in - Some (norm req), norm (mk_post_type ct.result_typ ens) - | _ -> failwith "Impossible" - end - - end - -(* [norm_reify env t] assumes that [t] has the shape reify t0 *) -(* where env |- t0 : M t' for some effect M and type t' where M is reifiable *) -(* and returns the result of reducing t with reification on *) -let norm_reify (env:Env.env) (steps:Env.steps) (t:S.term) : S.term = - def_check_scoped t.pos "norm_reify" env t; - let t' = N.normalize - ([Env.Beta; Env.Reify; Env.Eager_unfolding; Env.EraseUniverses; Env.AllowUnboundUniverses; Env.Exclude Env.Zeta]@steps) - env t in - if !dbg_SMTEncodingReify - then BU.print2 "Reified body %s \nto %s\n" - (show t) - (show t') ; - t' - -let remove_reify (t: S.term): S.term = - if (match (SS.compress t).n with | Tm_app _ -> false | _ -> true) - then t - else - let head, args = U.head_and_args t in - if (match (SS.compress head).n with Tm_constant (FStar.Const.Const_reify _) -> true | _ -> false) - then begin match args with - | [x] -> fst x - | _ -> failwith "Impossible : Reify applied to multiple arguments after normalization." - end - else t - - -(*********************************************************************************************) -(* Instantiation and generalization *) -(*********************************************************************************************) -let maybe_implicit_with_meta_or_attr aq (attrs:list attribute) = - match aq, attrs with - | Some (Meta _), _ - | Some (Implicit _), _::_ -> true - | _ -> false - -(* Instantiation of implicit arguments (meta or implicit) - * - * For meta arguments, we follow the exact same procedure as for instantiating an implicit, - * except that we keep track of the (uvar, env, metaprogram) triple in the environment - * so we can later come back to the implicit and, if it wasn't solved by unification, - * run the metaprogram on it. - * - * Why don't we run the metaprogram here? At this stage, it's very likely that `t` - * is full of unresolved uvars, and it wouldn't be a whole lot useful to try - * to find an instance for it. We might not even be able to, since instances - * are for concrete types. - *) -let instantiate_one_binder (env:env_t) (r:Range.range) (b:binder) : term & typ & aqual & guard_t = - if Debug.high () then - BU.print1 "instantiate_one_binder: Instantiating implicit binder %s\n" (show b); - let (++) = Env.conj_guard in - let { binder_bv=x } = b in - let ctx_uvar_meta, should_unrefine = uvar_meta_for_binder b in (* meta/attrs computed here *) - let t = x.sort in - let varg, _, implicits = - let msg = - let is_typeclass = - match ctx_uvar_meta with - | Some (Ctx_uvar_meta_tac tau) -> U.is_fvar C.tcresolve_lid tau - | _ -> false - in - if is_typeclass then "Typeclass constraint argument" - else if Some? ctx_uvar_meta then "Instantiating meta argument" - else "Instantiating implicit argument" - in - Env.new_implicit_var_aux msg r env t Strict ctx_uvar_meta should_unrefine - in - let aq = U.aqual_of_binder b in - let arg = varg, aq in - - let r = varg, t, aq, implicits in - if Debug.high () then - BU.print1 "instantiate_one_binder: result = %s\n" (show (r._1, r._2)); - r - -(* Will instantiate e, by applying it to some unification variables for its implicit -arguments, if that is needed to match the expected type in the environment. [t] is the type -of [e]. Returns elaborated [e'], its type [t'], and a guard. *) -let maybe_instantiate (env:Env.env) (e:term) (t:typ) : term & typ & guard_t = - let torig = SS.compress t in - if not env.instantiate_imp - then e, torig, mzero - else begin - if Debug.high () then - BU.print3 "maybe_instantiate: starting check for (%s) of type (%s), expected type is %s\n" - (show e) (show t) (show (Env.expected_typ env)); - (* Similar to U.arrow_formals, but makes sure to unfold - * recursively to catch all the binders across type - * definitions. TODO: Move to library? Revise other uses - * of arrow_formals{,_comp}?*) - let unfolded_arrow_formals env (t:term) : list binder = - let rec aux (env:Env.env) (bs:list binder) (t:term) : list binder = - let t = N.unfold_whnf env t in - let bs', t = U.arrow_formals t in - match bs' with - | [] -> bs - | bs' -> aux (Env.push_binders env bs') (bs@bs') t - in - aux env [] t - in - let number_of_implicits t = - let formals = unfolded_arrow_formals env t in - let n_implicits = - match formals |> BU.prefix_until (fun ({binder_qual=imp}) -> Option.isNone imp || U.eq_bqual imp (Some Equality)) with - | None -> List.length formals - | Some (implicits, _first_explicit, _rest) -> List.length implicits in - n_implicits - in - let inst_n_binders t = - match Env.expected_typ env with - | None -> None - | Some (expected_t, _) -> //the use_eq flag is irrelevant for instantiation - let n_expected = number_of_implicits expected_t in - let n_available = number_of_implicits t in - if n_available < n_expected - then raise_error env Errors.Fatal_MissingImplicitArguments [ - text "Expected a term with " ^/^ pp #int n_expected ^/^ text " implicit arguments, but " ^/^ - pp e ^/^ text " has only " ^/^ pp #int n_available ^^ text "."] - else Some (n_available - n_expected) - in - let decr_inst = function - | None -> None - | Some i -> Some (i - 1) - in - let t = N.unfold_whnf env t in - begin match t.n with - | Tm_arrow {bs; comp=c} -> - let bs, c = SS.open_comp bs c in - //instantiate at most inst_n implicit binders, when inst_n = Some n - //otherwise, instantate all implicits - //See issue #807 for why this is important - let rec aux (subst:list subst_elt) inst_n bs = - match inst_n, bs with - | Some 0, _ -> [], bs, subst, Env.trivial_guard //no more instantiations to do - | _, {binder_qual = Some (Implicit _)} ::rest - | _, {binder_qual = Some (Meta _)} ::rest - | _, {binder_attrs = _::_} :: rest -> - let b = List.hd bs in - let b = SS.subst_binder subst b in - let tm, ty, aq, g = instantiate_one_binder env e.pos b in - let subst = NT(b.binder_bv, tm)::subst in - let args, bs, subst, g' = aux subst (decr_inst inst_n) rest in - (tm, aq)::args, bs, subst, g ++ g' - - | _, bs -> [], bs, subst, mzero - in - let args, bs, subst, guard = aux [] (inst_n_binders t) bs in - begin match args, bs with - | [], _ -> //no implicits were instantiated - e, torig, guard - - | _, [] when not (U.is_total_comp c) -> - //don't instantiate implicitly, if it has an effect - e, torig, Env.trivial_guard - - | _ -> - - let t = match bs with - | [] -> U.comp_result c - | _ -> U.arrow bs c in - let t = SS.subst subst t in - let e = S.mk_Tm_app e args e.pos in - e, t, guard - end - - | _ -> e, torig, Env.trivial_guard - end - end - -(************************************************************************) -(* Convertibility *) -(************************************************************************) -//check_has_type env e t1 t2 -//checks is e:t1 has type t2, subject to some guard. - -let check_has_type env (e:term) (t1:typ) (t2:typ) (use_eq:bool) : guard_t = - let env = Env.set_range env e.pos in - - let g_opt = - if env.use_eq_strict - then match Rel.teq_nosmt_force env t1 t2 with - | false -> None - | true -> Env.trivial_guard |> Some - else if use_eq - then Rel.try_teq true env t1 t2 - else match Rel.get_subtyping_predicate env t1 t2 with - | None -> None - | Some f -> apply_guard f e |> Some in - - match g_opt with - | None -> Err.expected_expression_of_type env (Env.get_range env) t2 e t1 - | Some g -> g - -let check_has_type_maybe_coerce env (e:term) (lc:lcomp) (t2:typ) use_eq : term & lcomp & guard_t = - let env = Env.set_range env e.pos in - let e, lc, g_c = maybe_coerce_lc env e lc t2 in - let g = check_has_type env e lc.res_typ t2 use_eq in - if !dbg_Rel then - BU.print1 "Applied guard is %s\n" <| guard_to_string env g; - e, lc, (Env.conj_guard g g_c) - -///////////////////////////////////////////////////////////////////////////////// -let check_top_level env g lc : (bool & comp) = - Errors.with_ctx "While checking for top-level effects" (fun () -> - if Debug.medium () then - BU.print1 "check_top_level, lc = %s\n" (TcComm.lcomp_to_string lc); - let discharge g = - force_trivial_guard env g; - TcComm.is_pure_lcomp lc in - let g = Rel.solve_deferred_constraints env g in - let c, g_c = TcComm.lcomp_comp lc in - if TcComm.is_total_lcomp lc - then discharge (Env.conj_guard g g_c), c - else let c = Env.unfold_effect_abbrev env c in - let us = c.comp_univs in - if Env.is_layered_effect env c.effect_name - then begin - // - // A top-level indexed effect - // We will look at the top_level_effect attr for the effect definition - // and make sure that c unifies with it - // - let c_eff = c.effect_name in - let ret_comp = c |> S.mk_Comp in - // - // Using simplify etc. to help unificiation of logical effect arguments - // E.g., F* may insert returns, equalities, with which a precondition - // may look like e ==> True, - // as opposed to just True specified in the top-level effect abbreviation - // - // But this is just for unification, we return the original comp (ret_comp) - // without normalization - // - let steps = [Env.Eager_unfolding; Env.Simplify; Env.Primops; Env.NoFullNorm] in - let c = - c - |> S.mk_Comp - |> Normalize.normalize_comp steps env in - let top_level_eff_opt = Env.get_top_level_effect env c_eff in - match top_level_eff_opt with - | None -> - raise_error - (Env.get_range env) - Errors.Fatal_UnexpectedEffect - (BU.format1 "Indexed effect %s cannot be used as a top-level effect" (c_eff |> Ident.string_of_lid)) - | Some top_level_eff -> - // If top-level effect is same as c_eff, return - if Ident.lid_equals top_level_eff c_eff - then discharge g_c, ret_comp - else - let bc_opt = Env.lookup_effect_abbrev env us top_level_eff in - match bc_opt with - | None -> - raise_error env Errors.Fatal_UnexpectedEffect - (BU.format2 "Could not find top-level effect abbreviation %s for %s" - (Ident.string_of_lid top_level_eff) - (c_eff |> Ident.string_of_lid)) - | Some (bs, _) -> - let debug = !dbg_LayeredEffectsApp in - // - // Typechecking of effect abbreviation ensures that there is at least - // one return type argument, so the following a::bs is ok - // - let a::bs = SS.open_binders bs in - let uvs, g_uvs = - Env.uvars_for_binders - env - bs - [NT (a.binder_bv, U.comp_result c)] - (fun b -> - if debug - then BU.format2 - "implicit for binder %s in effect abbreviation %s while checking top-level effect" - (show b) - (Ident.string_of_lid top_level_eff) - else "check_top_level") - (Env.get_range env) in - let top_level_comp = - ({ comp_univs = us; - effect_name = top_level_eff; - result_typ = U.comp_result c; - effect_args = uvs |> List.map S.as_arg; - flags = [] }) |> S.mk_Comp in - // Unify - let gopt = Rel.eq_comp env top_level_comp c in - match gopt with - | None -> - raise_error env Errors.Fatal_UnexpectedEffect - (BU.format2 "Could not unify %s and %s when checking top-level effect" - (show top_level_comp) - (show c)) - | Some g -> - discharge (Env.conj_guards [g_c; g_uvs; g]), ret_comp - end - else let steps = [Env.Beta; Env.NoFullNorm; Env.DoNotUnfoldPureLets] in - let c = c - |> S.mk_Comp - |> Normalize.normalize_comp steps env in - let ct, vc, g_pre = check_trivial_precondition_wp env c in - if !dbg_Simplification - then BU.print1 "top-level VC: %s\n" (show vc); - discharge (Env.conj_guard g (Env.conj_guard g_c g_pre)), ct |> S.mk_Comp - ) - -(* Having already seen_args to head (from right to left), - compute the guard, if any, for the next argument, - if head is a short-circuiting operator *) -let short_circuit (head:term) (seen_args:args) : guard_formula = - let short_bin_op f : args -> guard_formula = function - | [] -> (* no args seen yet *) Trivial - | [(fst, _)] -> f fst - | _ -> failwith "Unexpected args to binary operator" in - - let op_and_e e = U.b2t e |> NonTrivial in - let op_or_e e = U.mk_neg (U.b2t e) |> NonTrivial in - let op_and_t t = t |> NonTrivial in - let op_or_t t = t |> U.mk_neg |> NonTrivial in - let op_imp_t t = t |> NonTrivial in - - let short_op_ite : args -> guard_formula = function - | [] -> Trivial - | [(guard, _)] -> NonTrivial guard - | [_then;(guard, _)] -> U.mk_neg guard |> NonTrivial - | _ -> failwith "Unexpected args to ITE" in - let table = - [(C.op_And, short_bin_op op_and_e); - (C.op_Or, short_bin_op op_or_e); - (C.and_lid, short_bin_op op_and_t); - (C.or_lid, short_bin_op op_or_t); - (C.imp_lid, short_bin_op op_imp_t); - (C.ite_lid, short_op_ite);] in - - match head.n with - | Tm_fvar fv -> - let lid = fv.fv_name.v in - begin match BU.find_map table (fun (x, mk) -> if lid_equals x lid then Some (mk seen_args) else None) with - | None -> Trivial - | Some g -> g - end - | _ -> Trivial - -let short_circuit_head l = - match (U.un_uinst l).n with - | Tm_fvar fv -> - BU.for_some (S.fv_eq_lid fv) - [C.op_And; - C.op_Or; - C.and_lid; - C.or_lid; - C.imp_lid; - C.ite_lid] - | _ -> false - - - -(************************************************************************) -(* maybe_add_implicit_binders (env:env) (bs:binders) *) -(* Adding implicit binders *) -(* in case the expected type is of the form #a1 -> ... -> #an -> t *) -(* and bs does not begin with any implicit binders *) -(* add #a1 ... #an to bs *) -(* Note that there may be other implicit binders in t that bs don't *) -(* We don't add them here, so in that sense it is best case effort *) -(* This helps us sometimes to build a better decreases clause *) -(* since it helps us count the arity by including implicits *) -(************************************************************************) -let maybe_add_implicit_binders (env:env) (bs:binders) : binders = - let is_implicit_binder ({binder_qual=q}) : bool = - match q with - | Some (Implicit _) - | Some (Meta _) -> true - | _ -> false in - - let pos bs = match bs with - | ({binder_bv=hd})::_ -> S.range_of_bv hd - | _ -> Env.get_range env in - - match bs with - | b :: _ when is_implicit_binder b -> bs // bs begins with an implicit binder; don't add any - | _ -> - match Env.expected_typ env with - | None -> bs - | Some (t, _) -> //the use_eq flag is not relevant - match (SS.compress t).n with - | Tm_arrow {bs=bs'} -> - begin match BU.prefix_until (fun b -> not (is_implicit_binder b)) bs' with - | None -> bs - | Some ([], _, _) -> bs // no implicits in the prefix - | Some (imps, _, _) -> - let r = pos bs in - let imps = - imps |> List.map (fun b -> { b with binder_bv = (S.set_range_of_bv b.binder_bv r) }) in - imps@bs // we have a prefix of implicits - end - - | _ -> bs - - -let must_erase_for_extraction (g:env) (t:typ) = - let rec descend env t = //t is expected to b in WHNF - match (SS.compress t).n with - | Tm_arrow _ -> - let bs, c = U.arrow_formals_comp t in - let env = FStar.TypeChecker.Env.push_binders env bs in - (Env.is_erasable_effect env (U.comp_effect_name c)) //includes GHOST - || (U.is_pure_or_ghost_comp c && aux env (U.comp_result c)) - | Tm_refine {b={sort=t}} -> - aux env t - | Tm_app {hd=head} - | Tm_uinst (head, _) -> - descend env head - | Tm_fvar fv -> - //special treatment for must_erase_for_extraction here - //See Env.type_is_erasable for more explanations - Env.fv_has_attr env fv C.must_erase_for_extraction_attr - | _ -> false - and aux env t = - let t = N.normalize [Env.Primops; - Env.Weak; - Env.HNF; - Env.UnfoldUntil delta_constant; - Env.Beta; - Env.AllowUnboundUniverses; - Env.Zeta; - Env.Iota; - Env.Unascribe] env t in -// debug g (fun () -> BU.print1 "aux %s\n" (show t)); - let res = Env.non_informative env t || descend env t in - if !dbg_Extraction - then BU.print2 "must_erase=%s: %s\n" (if res then "true" else "false") (show t); - res - in - aux g t - -let effect_extraction_mode env l = - l |> Env.norm_eff_name env - |> Env.get_effect_decl env - |> (fun ed -> ed.extraction_mode) - -let fresh_effect_repr env r eff_name signature_ts repr_ts_opt u a_tm = - let fail t = Err.unexpected_signature_for_monad env r eff_name t in - - let _, signature = Env.inst_tscheme signature_ts in - - let debug = !dbg_LayeredEffectsApp in - - (* - * We go through the binders in the signature a -> bs - * For each binder in bs, create a fresh uvar - * But keep substituting [a/a_tm, b_i/?ui] in the sorts of the subsequent binders - *) - match (SS.compress signature).n with - | Tm_arrow {bs} -> - let bs = SS.open_binders bs in - (match bs with - | a::bs -> - //is is all the uvars, and g is their collective guard - let is, g = - Env.uvars_for_binders env bs [NT (a.binder_bv, a_tm)] - (fun b -> - if debug - then BU.format3 - "uvar for binder %s when creating a fresh repr for %s at %s" - (show b) (string_of_lid eff_name) (Range.string_of_range r) - else "fresh_effect_repr") r in - (match repr_ts_opt with - | None -> //no repr, return thunked computation type - let eff_c = mk_Comp ({ - comp_univs = [u]; - effect_name = eff_name; - result_typ = a_tm; - effect_args = List.map S.as_arg is; - flags = [] }) in - S.mk (Tm_arrow {bs=[S.null_binder S.t_unit]; comp=eff_c}) r - | Some repr_ts -> - let repr = Env.inst_tscheme_with repr_ts [u] |> snd in - let is_args = List.map2 (fun i b -> (i, U.aqual_of_binder b)) is bs in - S.mk_Tm_app - repr - (S.as_arg a_tm::is_args) - r), g - | _ -> fail signature) - | _ -> fail signature - -let fresh_effect_repr_en env r eff_name u a_tm = - eff_name - |> Env.get_effect_decl env - |> (fun ed -> fresh_effect_repr env r eff_name (U.effect_sig_ts ed.signature) (ed |> U.get_eff_repr) u a_tm) - -let layered_effect_indices_as_binders env r eff_name sig_ts u a_tm = - let _, sig_tm = Env.inst_tscheme_with sig_ts [u] in - - let fail t = Err.unexpected_signature_for_monad env r eff_name t in - - match (SS.compress sig_tm).n with - | Tm_arrow {bs} -> - let bs = SS.open_binders bs in - (match bs with - | ({binder_bv=a'})::bs -> bs |> SS.subst_binders [NT (a', a_tm)] - | _ -> fail sig_tm) - | _ -> fail sig_tm - - -let check_non_informative_type_for_lift env m1 m2 t (r:Range.range) : unit = - //raise an error if m1 is erasable, m2 is not erasable, and t is informative - if Env.is_erasable_effect env m1 && - not (Env.is_erasable_effect env m2) && - not (N.non_info_norm env t) - then Errors.raise_error r Errors.Error_TypeError - (BU.format3 "Cannot lift erasable expression from %s ~> %s since its type %s is informative" - (string_of_lid m1) - (string_of_lid m2) - (show t)) - -// -// Apply a substitutive indexed lift -// -let substitutive_indexed_lift_substs (env:env) - (bs:binders) - (ct:comp_typ) - (lift_name:string) - (r:Range.range) - - : list subst_elt & guard_t = - - let debug = !dbg_LayeredEffectsApp in - - let bs, subst = - let a_b::bs = bs in - bs, [NT (a_b.binder_bv, ct.result_typ)] in - - let bs, subst = - let m_num_effect_args = List.length ct.effect_args in - let f_bs, bs = List.splitAt m_num_effect_args bs in - let f_subst = List.map2 (fun f_b (arg, _) -> NT (f_b.binder_bv, arg)) f_bs ct.effect_args in - bs, subst@f_subst in - - let bs = List.splitAt (List.length bs - 1) bs |> fst in - - List.fold_left (fun (subst, g) b -> - let [uv_t], g_uv = Env.uvars_for_binders env [b] subst - (fun b -> - if debug - then BU.format3 "implicit var for additional lift binder %s of %s at %s)" - (show b) - lift_name - (Range.string_of_range r) - else "substitutive_indexed_lift_substs") r in - subst@[NT (b.binder_bv, uv_t)], - Env.conj_guard g g_uv) (subst, Env.trivial_guard) bs - -let ad_hoc_indexed_lift_substs (env:env) - (bs:binders) - (ct:comp_typ) - (lift_name:string) - (r:Range.range) - - : list subst_elt & guard_t = - - let debug = !dbg_LayeredEffectsApp in - - let lift_t_shape_error s = - BU.format2 "Lift %s has unexpected shape, reason: %s" - lift_name s in - - let a_b, (rest_bs, [f_b]) = - if List.length bs >= 2 - then let a_b::bs = bs in - a_b, List.splitAt (List.length bs - 1) bs - else raise_error r Errors.Fatal_UnexpectedEffect - (lift_t_shape_error "either not an arrow or not enough binders") in - - let rest_bs_uvars, g = - Env.uvars_for_binders env rest_bs - [NT (a_b.binder_bv, ct.result_typ)] - (fun b -> - if debug - then BU.format3 - "implicit var for binder %s of %s at %s" - (show b) - lift_name - (Range.string_of_range r) - else "ad_hoc_indexed_lift_substs") r in - - let substs = List.map2 - (fun b t -> NT (b.binder_bv, t)) - (a_b::rest_bs) (ct.result_typ::rest_bs_uvars) in - - let guard_f = - let f_sort = f_b.binder_bv.sort |> SS.subst substs |> SS.compress in - let f_sort_is = effect_args_from_repr f_sort (Env.is_layered_effect env ct.effect_name) r in - List.fold_left2 - (fun g i1 i2 -> Env.conj_guard g (Rel.layered_effect_teq env i1 i2 (Some lift_name))) - Env.trivial_guard (List.map fst ct.effect_args) f_sort_is in - - substs, - Env.conj_guard g guard_f - -let lift_tf_layered_effect (tgt:lident) (lift_ts:tscheme) (kind:S.indexed_effect_combinator_kind) - env (c:comp) : comp & guard_t = - - let debug = !dbg_LayeredEffectsApp in - - if debug then - BU.print2 "Lifting indexed comp %s to %s {\n" - (show c) (show tgt); - - let r = Env.get_range env in - - let ct = Env.comp_to_comp_typ env c in - - check_non_informative_type_for_lift env ct.effect_name tgt ct.result_typ r; - - let lift_name () = - if debug then BU.format2 "%s ~> %s" (string_of_lid ct.effect_name) (string_of_lid tgt) - else "" in - - let _, lift_t = Env.inst_tscheme_with lift_ts [List.hd ct.comp_univs] in - - let bs, lift_c = U.arrow_formals_comp lift_t in - - let substs, g = - if kind = S.Ad_hoc_combinator - then ad_hoc_indexed_lift_substs env bs ct (lift_name ()) r - else substitutive_indexed_lift_substs env bs ct (lift_name ()) r in - - let lift_ct = lift_c |> SS.subst_comp substs |> Env.comp_to_comp_typ env in - - let is = effect_args_from_repr lift_ct.result_typ (Env.is_layered_effect env tgt) r in - - //compute the formula `lift_c.wp (fun _ -> True)` and add it to the final guard - let fml = - let u, wp = List.hd lift_ct.comp_univs, fst (List.hd lift_ct.effect_args) in - Env.pure_precondition_for_trivial_post env u lift_ct.result_typ wp Range.dummyRange in - - if !dbg_LayeredEffects && - Debug.extreme () - then BU.print1 "Guard for lift is: %s" (show fml); - - let c = mk_Comp ({ - comp_univs = ct.comp_univs; - effect_name = tgt; - result_typ = ct.result_typ; - effect_args = is |> List.map S.as_arg; - flags = [] //AR: setting the flags to empty - }) in - - if debug then BU.print1 "} Lifted comp: %s\n" (show c); - - let g = Env.conj_guards [ - g; - Env.guard_of_guard_formula (TcComm.NonTrivial fml) ] in - - c, g - -(* - * Creating the Env.mlift.mlift_term function for layered effects - * Quite simple, just apply the lift term, passing units for the - * binders that are meant to compute indices - *) -let lift_tf_layered_effect_term env (sub:sub_eff) - (u:universe) (a:typ) (e:term) : term = - - let lift = sub.lift |> must |> (fun ts -> inst_tscheme_with ts [u]) |> snd in - - let rest_bs = - let lift_t = sub.lift_wp |> must in - match (lift_t |> snd |> SS.compress).n with - | Tm_arrow {bs=_::bs} when List.length bs >= 1 -> - bs |> List.splitAt (List.length bs - 1) |> fst - | _ -> - raise_error (snd lift_t) Errors.Fatal_UnexpectedEffect - (BU.format1 "lift_t tscheme %s is not an arrow with enough binders" - (Print.tscheme_to_string lift_t)) - in - - let args = (S.as_arg a)::((rest_bs |> List.map (fun _ -> S.as_arg S.unit_const))@[S.as_arg e]) in - mk (Tm_app {hd=lift; args}) e.pos - -let get_field_projector_name env datacon index = - let _, t = Env.lookup_datacon env datacon in - let err n = - raise_error env Errors.Fatal_UnexpectedDataConstructor - (BU.format3 "Data constructor %s does not have enough binders (has %s, tried %s)" - (show datacon) (show n) (show index)) in - match (SS.compress t).n with - | Tm_arrow {bs} -> - let bs = bs |> List.filter (fun ({binder_qual=q}) -> match q with | Some (Implicit true) -> false | _ -> true) in - if List.length bs <= index then err (List.length bs) - else - let b = List.nth bs index in - U.mk_field_projector_name datacon b.binder_bv index - | _ -> err 0 - - -let get_mlift_for_subeff env (sub:S.sub_eff) : Env.mlift = - if Env.is_layered_effect env sub.source || Env.is_layered_effect env sub.target - - then - ({ mlift_wp = lift_tf_layered_effect sub.target (sub.lift_wp |> must) (sub.kind |> must); - mlift_term = Some (lift_tf_layered_effect_term env sub) }) - - else - let mk_mlift_wp ts env c = - let ct = Env.comp_to_comp_typ env c in - check_non_informative_type_for_lift env ct.effect_name sub.target ct.result_typ env.range; - let _, lift_t = inst_tscheme_with ts ct.comp_univs in - let wp = List.hd ct.effect_args in - S.mk_Comp ({ ct with - effect_name = sub.target; - effect_args = - [mk (Tm_app {hd=lift_t; args=[as_arg ct.result_typ; wp]}) (fst wp).pos |> S.as_arg] - }), TcComm.trivial_guard - in - - let mk_mlift_term ts u r e = - let _, lift_t = inst_tscheme_with ts [u] in - mk (Tm_app {hd=lift_t; args=[as_arg r; as_arg S.tun; as_arg e]}) e.pos - in - - ({ mlift_wp = sub.lift_wp |> must |> mk_mlift_wp; - //AR: this is funky - //it is saying, if you don't give us a lift term (a function that lifts terms), - //we are assuming that the function is an identity - //so for example, primitive effects just specify lift wps, and not terms - //for them we assume that the terms are identity functions - //why do we need it? - //suppose programmer writes a layered effect M and defines a lift from DIV to M - //now a PURE computation in the VC gets lifted via: PURE ~> DIV ~> M - //when extracting (and reifying the monadic lifts), we go the same route - //but if there is no lift term from PURE ~> DIV, we get an error - //is this ok to do for DM4F? not sure in general - //but currently PURE and DIV are lifted to DM4F effects using M.return - //and not using the lift term (I don't think the lift term is even supported for DM4F, is it?) - mlift_term = - match sub.lift with - | None -> Some (fun _ _ e -> return_all e) - | Some ts -> Some (mk_mlift_term ts) }) - - -let update_env_sub_eff env sub r = - let r0 = env.range in - let env = Env.update_effect_lattice - ({ env with range = r }) sub.source sub.target (get_mlift_for_subeff env sub) in - { env with range = r0 } - -let update_env_polymonadic_bind env m n p ty k = - // - //false means no range support in polymonadic bind yet - // - Env.add_polymonadic_bind env m n p - (fun env c1 bv_opt c2 flags r -> - mk_indexed_bind env m n p ty k c1 bv_opt c2 flags r 0 false) - -(*** Utilities for type-based record - disambiguation ***) - - -(* - For singleton inductive types named `typename`, - it looks up the name of the constructor, - and the field names of that constructor - *) -let try_lookup_record_type env (typename:lident) - : option DsEnv.record_or_dc - = try - match Env.datacons_of_typ env typename with - | _, [dc] -> - let se = Env.lookup_sigelt env dc in - (match se with - | Some ({sigel=Sig_datacon {t; num_ty_params=nparms}}) -> - let formals, c = U.arrow_formals t in - if nparms < List.length formals - then let _, fields = List.splitAt nparms formals in //remove params - let fields = List.filter (fun b -> match b.binder_qual with | Some (Implicit _) -> false | _ -> true) fields in //remove implicits - let fields = List.map (fun b -> b.binder_bv.ppname, b.binder_bv.sort) fields in - let is_rec = Env.is_record env typename in - let r : DsEnv.record_or_dc = - { - typename = typename; - constrname = Ident.ident_of_lid dc; - parms = []; - fields = fields; - is_private = false; - is_record = is_rec - } - in - Some r - - else ( - // BU.print3 "Not enough formals; nparms=%s; type = %s; formals=%s\n" - // (string_of_int nparms) - // (show t) - // (Print.binders_to_string ", " formals); - None - ) - | _ -> - // BU.print1 "Could not find %s\n" (string_of_lid dc); - None) - | _, dcs -> - // BU.print2 "Could not find type %s ... Got %s\n" - // (string_of_lid typename) - // (FStar.Common.string_of_list Ident.string_of_lid dcs); - None - with - | _ -> None - -(* - If ToSyntax guessed `uc` - and the typechecker decided that type `t: option typ` was the type - to be used for disambiguation, then if - - - t is None, the uc is used - - otherwise t overrides uc - *) -let find_record_or_dc_from_typ env (t:option typ) (uc:unresolved_constructor) rng = - let default_rdc () = - let open FStar.Errors.Msg in - match uc.uc_typename, uc.uc_fields with - | None, [] -> - raise_error rng Errors.Error_CannotResolveRecord [ - text "Could not resolve the type for this record."; - ] - - | None, f::_ -> - let f = List.hd uc.uc_fields in - raise_error f Errors.Error_CannotResolveRecord [ - text <| BU.format1 "Field name %s could not be resolved." (string_of_lid f); - ] - - | Some tn, _ -> - match try_lookup_record_type env tn with - | Some rdc -> rdc - | None -> - raise_error tn Errors.Fatal_NameNotFound - (BU.format1 "Record name %s not found." (string_of_lid tn)) - in - let rdc : DsEnv.record_or_dc = - match t with - | None -> default_rdc() - | Some t -> - let thead, _ = - U.head_and_args (N.unfold_whnf' [Unascribe; Unmeta; Unrefine] env t) - in - match (SS.compress (U.un_uinst thead)).n with - | Tm_fvar type_name -> - begin - match try_lookup_record_type env type_name.fv_name.v with - | None -> default_rdc () - | Some r -> r - end - | _ -> default_rdc() - in - let constrname = - let name = lid_of_ids (ns_of_lid rdc.typename @ [rdc.constrname]) in - Ident.set_lid_range name rng - in - let constructor = - let qual = - if rdc.is_record - then (Some (Record_ctor(rdc.typename, rdc.fields |> List.map fst))) - else None - in - S.lid_as_fv constrname qual - in - rdc, constrname, constructor - - -(* Check if a user provided `field_name` in a constructor or projector - matches `field` in `rdc`. - - The main subtlety is that if `field_name` is unqualified, then it only - has to match `field`. - - Otherwise, its namespace also has to match the module name of `rdc`. - - This ensures that if the user wrote a qualified field name, then it - has to resolve to a field in the unambiguous module reference in - the qualifier. -*) -let field_name_matches (field_name:lident) (rdc:DsEnv.record_or_dc) (field:ident) = - Ident.ident_equals field (Ident.ident_of_lid field_name) && - (if ns_of_lid field_name <> [] - then nsstr field_name = nsstr rdc.typename - else true) - -(* - The field assignments of a record constructor can be given out of - order. - - Given that we've committed to `rdc` as the record constructor, if - the user's field assignments are `fas`, then we order the alphas - by the order in which they appear in `rdc`. - - If a particular field cannot be found, then we call not_found, which - an provide a default. - - We raise errors if fields are not found and no default exists, or if - redundant fields are present. -*) -let make_record_fields_in_order env uc topt - (rdc : DsEnv.record_or_dc) - (fas : list (lident & 'a)) - (not_found:ident -> option 'a) - (rng : Range.range) - : list 'a - = let debug () = - let print_rdc (rdc:DsEnv.record_or_dc) = - BU.format3 "{typename=%s; constrname=%s; fields=[%s]}" - (string_of_lid rdc.typename) - (string_of_id rdc.constrname) - (List.map (fun (i, _) -> string_of_id i) rdc.fields |> String.concat "; ") - in - let print_topt topt = - BU.format2 "topt=%s; rdc=%s" (show topt) (print_rdc rdc) - in - BU.print5 "Resolved uc={typename=%s;fields=%s}\n\ttopt=%s\n\t{rdc = %s\n\tfield assignments=[%s]}\n" - (show uc.uc_typename) - (show uc.uc_fields) - (print_topt topt) - (print_rdc rdc) - (show (List.map fst fas)) - in - let rest, as_rev, missing = - List.fold_left - (fun (fields, as_rev, missing) (field_name, _) -> - let matching, rest = - List.partition - (fun (fn, _) -> field_name_matches fn rdc field_name) - fields - in - match matching with - | [(_, a)] -> - rest, a::as_rev, missing - - | [] -> ( - match not_found field_name with - | None -> -// debug(); - rest, as_rev, field_name :: missing - | Some a -> - rest, a::as_rev, missing - ) - - | _ -> -// debug(); - raise_error rng Errors.Fatal_MissingFieldInRecord - (BU.format2 "Field %s of record type %s is given multiple assignments" - (string_of_id field_name) - (string_of_lid rdc.typename))) - (fas, [], []) - rdc.fields - in - let pp_missing () = - separate_map (comma ^^ break_ 1) (fun f -> squotes (doc_of_string (show f))) missing - in - let _ = - match rest, missing with - | [], [] -> () - | (f, _)::_, _ -> -// debug(); - raise_error f Errors.Fatal_MissingFieldInRecord [ - Errors.Msg.text <| BU.format2 "Field '%s' is redundant for type %s" (show f) (show rdc.typename); - if Cons? missing then - prefix 2 1 (text "Missing fields:") - (pp_missing ()) - else - Pprint.empty; - ] - - | [], _ -> - raise_error rng Errors.Fatal_MissingFieldInRecord [ - prefix 2 1 (text <| BU.format1 "Missing fields for record type '%s':" (show rdc.typename)) - (pp_missing ()) - ] - in - List.rev as_rev diff --git a/src/typechecker/FStar.TypeChecker.Util.fsti b/src/typechecker/FStar.TypeChecker.Util.fsti deleted file mode 100644 index 30f1c51344a..00000000000 --- a/src/typechecker/FStar.TypeChecker.Util.fsti +++ /dev/null @@ -1,193 +0,0 @@ -(* - Copyright 2008-2014 Nikhil Swamy and Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module FStar.TypeChecker.Util -open FStar.Pervasives -open FStar.Compiler.Effect - -open FStar -open FStar.Compiler -open FStar.TypeChecker -open FStar.Syntax -open FStar.TypeChecker.Env -open FStar.Syntax.Syntax -open FStar.Ident -open FStar.TypeChecker.Common - -type lcomp_with_binder = option bv & lcomp - -//error report -// val report: env -> list string -> unit - -//unification variables -val new_implicit_var : string -> Range.range -> env -> typ -> unrefine:bool -> term & (ctx_uvar & Range.range) & guard_t -val check_uvars: Range.range -> typ -> unit - -//caller can set the boolean to true if they want to solve the deferred constraints involving this binder now (best case) -val close_guard_implicits: env -> bool -> binders -> guard_t -> guard_t - -//extracting annotations from a term -val extract_let_rec_annotation: env -> letbinding -> univ_names & typ & term & bool - -//pattern utilities -//val decorate_pattern: env -> pat -> term -> pat -val decorated_pattern_as_term: pat -> list bv & term - -//instantiation of implicits -val maybe_implicit_with_meta_or_attr: bqual -> list attribute -> bool - -val instantiate_one_binder (env:env_t) (r:Range.range) (b:binder) : term & typ & aqual & guard_t -val maybe_instantiate : env -> term -> typ -> (term & typ & guard_t) - -//operations on computation types -(* most operations on computations are lazy *) -val lcomp_univ_opt: lcomp -> (option universe & guard_t) -val is_pure_effect: env -> lident -> bool -val is_pure_or_ghost_effect: env -> lident -> bool -val should_not_inline_lc: lcomp -> bool -val bind: Range.range -> env -> option term -> lcomp -> lcomp_with_binder -> lcomp -val maybe_return_e2_and_bind: Range.range -> env -> option term -> lcomp -> e2:term -> lcomp_with_binder -> lcomp - -(* - * When typechecking a match term, typechecking each branch returns - * a branch condition - * - * E.g. match e with | C -> ... | D -> ... - * the two branch conditions would be (is_C e) and (is_D e) - * - * This function builds a list of formulas that are the negation of - * all the previous branches - * - * In the example, neg_branch_conds would be: - * [True; not (is_C e); not (is_C e) /\ not (is_D e)] - * thus, the length of the list is one more than lcases - * - * The return value is then ([True; not (is_C e)], not (is_C e) /\ not (is_D e)) - * - * (The last element of the list becomes the branch condition for the - unreachable branch to check for pattern exhaustiveness) - *) -val get_neg_branch_conds: list formula -> list formula & formula - -//the bv is the scrutinee binder, that bind_cases uses to close the guard (from lifting the computations) -val bind_cases: env -> typ -> list (typ & lident & list cflag & (bool -> lcomp)) -> bv -> lcomp - -(* - * weaken_result_type env e lc t use_eq - * precondition: env |- e : lc - * - * tries to weaken the result type of lc to t - * - * roughly checking that lc.result_typ <: t - * - * but if either (a) use_eq argument is true, or - * (b) env.use_eq is true, or - * (c) env.use_eq_strict is true, then checking that lc.result_typ = t - * - *) -val weaken_result_typ: env -> term -> lcomp -> typ -> bool -> term & lcomp & guard_t - -val strengthen_precondition: (option (unit -> list Pprint.document) -> env -> term -> lcomp -> guard_t -> lcomp&guard_t) -val weaken_guard: guard_formula -> guard_formula -> guard_formula -val weaken_precondition: env -> lcomp -> guard_formula -> lcomp -val maybe_assume_result_eq_pure_term: env -> term -> lcomp -> lcomp -val close_layered_lcomp_with_combinator: env -> list bv -> lcomp -> lcomp -val close_wp_lcomp: env -> list bv -> lcomp -> lcomp -val close_layered_lcomp_with_substitutions: env -> list bv -> list term -> lcomp -> lcomp -val pure_or_ghost_pre_and_post: env -> comp -> (option typ & typ) - -// -// Setting the boolean flag to true, clients may say if they want to use equality -// instead of subtyping -// -val check_comp: env -> use_eq:bool -> term -> comp -> comp -> term & comp & guard_t - -val universe_of_comp: env -> universe -> comp -> universe -(* - * return value: formula for input comp to have trivial wp * guard for that formula - *) -val check_trivial_precondition_wp : env -> comp -> (comp_typ & formula & guard_t) - -// -//checking that e:t is convertible to t' -// -//set the boolan flag to true if you want to check for type equality -// -val check_has_type : env -> term -> t:typ -> t':typ -> use_eq:bool -> guard_t -val check_has_type_maybe_coerce : env -> term -> lcomp -> typ -> bool -> term & lcomp & guard_t - -val check_top_level: env -> guard_t -> lcomp -> bool&comp - -val maybe_coerce_lc : env -> term -> lcomp -> typ -> term & lcomp & guard_t - -//misc. -val label: list Pprint.document -> Range.range -> typ -> typ -val label_guard: Range.range -> list Pprint.document -> guard_t -> guard_t -val short_circuit: term -> args -> guard_formula -val short_circuit_head: term -> bool -val maybe_add_implicit_binders: env -> binders -> binders -val fvar_env: env -> lident -> term -val norm_reify: env -> steps -> term -> term -val remove_reify: term -> term - -//decorating terms with monadic operators -val maybe_lift: env -> term -> lident -> lident -> typ -> term -val maybe_monadic: env -> term -> lident -> typ -> term - -val must_erase_for_extraction: env -> term -> bool - -//layered effect utilities - -val effect_extraction_mode : env -> lident -> eff_extraction_mode - -(* - * This function returns ed.repr a ?u1 ... ?un (note that u must be the universe of a) - * where ?u1 ... ?un are unification variables, one for each index of the layered effect - * - * The unification variables are resolved in the input env - *) -val fresh_effect_repr: env -> Range.range -> lident -> signature:tscheme -> repr:option tscheme -> u:universe -> a:term -> term & guard_t - -(* - * A wrapper over fresh_layered_effect_repr that looks up signature and repr from env - * - * If the effect does not have a repr (e.g. primitive effects), then we return a `unit -> M a ?u` term - *) -val fresh_effect_repr_en: env -> Range.range -> lident -> universe -> term -> term & guard_t - -(* - * Return binders for the layered effect indices with signature - * In the binder types, a is substituted with a_tm (u is universe of a) - *) -val layered_effect_indices_as_binders:env -> Range.range -> eff_name:lident -> signature:tscheme -> u:universe -> a_tm:term -> binders - -val get_field_projector_name : env -> datacon:lident -> index:int -> lident - - -(* update the env functions *) -val update_env_sub_eff : env -> sub_eff -> Range.range -> env -val update_env_polymonadic_bind : - env -> lident -> lident -> lident -> tscheme -> indexed_effect_combinator_kind -> env - -val try_lookup_record_type : env -> lident -> option DsEnv.record_or_dc -val find_record_or_dc_from_typ : env -> option typ -> unresolved_constructor -> Range.range -> DsEnv.record_or_dc & lident & fv -val field_name_matches : lident -> DsEnv.record_or_dc -> ident -> bool -val make_record_fields_in_order : env -> unresolved_constructor -> option (either typ typ) -> - DsEnv.record_or_dc -> - list (lident & 'a) -> - not_found:(ident -> option 'a) -> - Range.range -> - list 'a diff --git a/src/typechecker/FStarC.TypeChecker.Cfg.fst b/src/typechecker/FStarC.TypeChecker.Cfg.fst new file mode 100644 index 00000000000..39d23fc07f7 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Cfg.fst @@ -0,0 +1,480 @@ +module FStarC.TypeChecker.Cfg + +open FStar open FStarC +open FStar.Char +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Compiler.String +open FStarC.Const +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.TypeChecker +open FStarC.TypeChecker.Env + +open FStarC.Class.Show + +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module BU = FStarC.Compiler.Util +module FC = FStarC.Const +module PC = FStarC.Parser.Const +module U = FStarC.Syntax.Util +module I = FStarC.Ident +module EMB = FStarC.Syntax.Embeddings +module Z = FStarC.BigInt +module NBE = FStarC.TypeChecker.NBETerm + +friend FStar.Pervasives (* to expose norm_step *) + +let steps_to_string f = + let format_opt (f:'a -> string) (o:option 'a) = + match o with + | None -> "None" + | Some x -> "Some ("^ f x ^ ")" + in + let b = BU.string_of_bool in + BU.format + "{\n\ + beta = %s;\n\ + iota = %s;\n\ + zeta = %s;\n\ + zeta_full = %s;\n\ + weak = %s;\n\ + hnf = %s;\n\ + primops = %s;\n\ + do_not_unfold_pure_lets = %s;\n\ + unfold_until = %s;\n\ + unfold_only = %s;\n\ + unfold_fully = %s;\n\ + unfold_attr = %s;\n\ + unfold_qual = %s;\n\ + unfold_namespace = %s;\n\ + dont_unfold_attr = %s;\n\ + pure_subterms_within_computations = %s;\n\ + simplify = %s;\n\ + erase_universes = %s;\n\ + allow_unbound_universes = %s;\n\ + reify_ = %s;\n\ + compress_uvars = %s;\n\ + no_full_norm = %s;\n\ + check_no_uvars = %s;\n\ + unmeta = %s;\n\ + unascribe = %s;\n\ + in_full_norm_request = %s;\n\ + weakly_reduce_scrutinee = %s;\n\ + for_extraction = %s;\n\ + unrefine = %s;\n\ + default_univs_to_zero = %s;\n\ + tactics = %s;\n\ + }" + [ f.beta |> show; + f.iota |> show; + f.zeta |> show; + f.zeta_full |> show; + f.weak |> show; + f.hnf |> show; + f.primops |> show; + f.do_not_unfold_pure_lets |> show; + f.unfold_until |> show; + f.unfold_only |> show; + f.unfold_fully |> show; + f.unfold_attr |> show; + f.unfold_qual |> show; + f.unfold_namespace |> show; + f.dont_unfold_attr |> show; + f.pure_subterms_within_computations |> show; + f.simplify |> show; + f.erase_universes |> show; + f.allow_unbound_universes |> show; + f.reify_ |> show; + f.compress_uvars |> show; + f.no_full_norm |> show; + f.check_no_uvars |> show; + f.unmeta |> show; + f.unascribe |> show; + f.in_full_norm_request |> show; + f.weakly_reduce_scrutinee |> show; + f.for_extraction |> show; + f.unrefine |> show; + f.default_univs_to_zero |> show; + f.tactics |> show; + ] + +instance deq_fsteps : deq fsteps = { + (=?) = (fun f1 f2 -> + f1.beta =? f2.beta && + f1.iota =? f2.iota && + f1.zeta =? f2.zeta && + f1.zeta_full =? f2.zeta_full && + f1.weak =? f2.weak && + f1.hnf =? f2.hnf && + f1.primops =? f2.primops && + f1.do_not_unfold_pure_lets =? f2.do_not_unfold_pure_lets && + f1.unfold_until =? f2.unfold_until && + f1.unfold_only =? f2.unfold_only && + f1.unfold_fully =? f2.unfold_fully && + f1.unfold_attr =? f2.unfold_attr && + f1.unfold_qual =? f2.unfold_qual && + f1.unfold_namespace =? f2.unfold_namespace && + f1.dont_unfold_attr =? f2.dont_unfold_attr && + f1.pure_subterms_within_computations =? f2.pure_subterms_within_computations && + f1.simplify =? f2.simplify && + f1.erase_universes =? f2.erase_universes && + f1.allow_unbound_universes =? f2.allow_unbound_universes && + f1.reify_ =? f2.reify_ && + f1.compress_uvars =? f2.compress_uvars && + f1.no_full_norm =? f2.no_full_norm && + f1.check_no_uvars =? f2.check_no_uvars && + f1.unmeta =? f2.unmeta && + f1.unascribe =? f2.unascribe && + f1.in_full_norm_request =? f2.in_full_norm_request && + f1.weakly_reduce_scrutinee =? f2.weakly_reduce_scrutinee && + f1.nbe_step =? f2.nbe_step && + f1.for_extraction =? f2.for_extraction && + f1.unrefine =? f2.unrefine && + f1.default_univs_to_zero =? f2.default_univs_to_zero && + f1.tactics =? f2.tactics + ); +} + +let default_steps : fsteps = { + beta = true; + iota = true; + zeta = true; + zeta_full = false; + weak = false; + hnf = false; + primops = false; + do_not_unfold_pure_lets = false; + unfold_until = None; + unfold_only = None; + unfold_fully = None; + unfold_attr = None; + unfold_qual = None; + unfold_namespace = None; + dont_unfold_attr = None; + pure_subterms_within_computations = false; + simplify = false; + erase_universes = false; + allow_unbound_universes = false; + reify_ = false; + compress_uvars = false; + no_full_norm = false; + check_no_uvars = false; + unmeta = false; + unascribe = false; + in_full_norm_request = false; + weakly_reduce_scrutinee = true; + nbe_step = false; + for_extraction = false; + unrefine = false; + default_univs_to_zero = false; + tactics = false; +} + +let fstep_add_one s fs = + match s with + | Beta -> { fs with beta = true } + | Iota -> { fs with iota = true } + | Zeta -> { fs with zeta = true } + | ZetaFull -> { fs with zeta_full = true } + | Exclude Beta -> { fs with beta = false } + | Exclude Iota -> { fs with iota = false } + | Exclude Zeta -> { fs with zeta = false } + | Exclude _ -> failwith "Bad exclude" + | Weak -> { fs with weak = true } + | HNF -> { fs with hnf = true } + | Primops -> { fs with primops = true } + | Eager_unfolding -> fs // eager_unfolding is not a step + | Inlining -> fs // not a step // ZP : Adding qualification because of name clash + | DoNotUnfoldPureLets -> { fs with do_not_unfold_pure_lets = true } + | UnfoldUntil d -> { fs with unfold_until = Some d } + | UnfoldOnly lids -> { fs with unfold_only = Some lids } + | UnfoldFully lids -> { fs with unfold_fully = Some lids } + | UnfoldAttr lids -> { fs with unfold_attr = Some lids } + | UnfoldQual strs -> + let fs = { fs with unfold_qual = Some strs } in + if List.contains "pure_subterms_within_computations" strs + then {fs with pure_subterms_within_computations = true} + else fs + | UnfoldNamespace strs -> + { fs with unfold_namespace = + Some (List.map (fun s -> (Ident.path_of_text s, true)) strs, false) } + | DontUnfoldAttr lids -> { fs with dont_unfold_attr = Some lids } + | PureSubtermsWithinComputations -> { fs with pure_subterms_within_computations = true } + | Simplify -> { fs with simplify = true } + | EraseUniverses -> { fs with erase_universes = true } + | AllowUnboundUniverses -> { fs with allow_unbound_universes = true } + | Reify -> { fs with reify_ = true } + | CompressUvars -> { fs with compress_uvars = true } + | NoFullNorm -> { fs with no_full_norm = true } + | CheckNoUvars -> { fs with check_no_uvars = true } + | Unmeta -> { fs with unmeta = true } + | Unascribe -> { fs with unascribe = true } + | NBE -> {fs with nbe_step = true } + | ForExtraction -> {fs with for_extraction = true } + | Unrefine -> {fs with unrefine = true } + | NormDebug -> fs // handled above, affects only dbg flags + | DefaultUnivsToZero -> {fs with default_univs_to_zero = true} + | Tactics -> { fs with tactics = true } + +let to_fsteps (s : list step) : fsteps = + List.fold_right fstep_add_one s default_steps + +let no_debug_switches = { + gen = false; + top = false; + cfg = false; + primop = false; + unfolding = false; + b380 = false; + wpe = false; + norm_delayed = false; + print_normalized = false; + debug_nbe = false; + erase_erasable_args = false; +} + +(* Primitive step sets. They are represented as a persistent string map *) +type prim_step_set = BU.psmap primitive_step + +let empty_prim_steps () : prim_step_set = + BU.psmap_empty () + +let add_step (s : primitive_step) (ss : prim_step_set) = + BU.psmap_add ss (I.string_of_lid s.name) s + +let merge_steps (s1 : prim_step_set) (s2 : prim_step_set) : prim_step_set = + BU.psmap_merge s1 s2 + +let add_steps (m : prim_step_set) (l : list primitive_step) : prim_step_set = + List.fold_right add_step l m + +let prim_from_list (l : list primitive_step) : prim_step_set = + add_steps (empty_prim_steps ()) l +(* / Primitive step sets *) + +(* Turn the lists into psmap sets, for efficiency of lookup *) +let built_in_primitive_steps = prim_from_list built_in_primitive_steps_list +let env_dependent_ops env = prim_from_list (env_dependent_ops env) +let simplification_steps env = prim_from_list (simplification_ops_list env) + +instance showable_cfg : showable cfg = { + show = (fun cfg -> + String.concat "\n" + ["{"; + BU.format1 " steps = %s;" (steps_to_string cfg.steps); + BU.format1 " delta_level = %s;" (show cfg.delta_level); + "}" ]); +} + +let cfg_env cfg = cfg.tcenv + +let find_prim_step cfg fv = + BU.psmap_try_find cfg.primitive_steps (I.string_of_lid fv.fv_name.v) + +let is_prim_step cfg fv = + BU.is_some (BU.psmap_try_find cfg.primitive_steps (I.string_of_lid fv.fv_name.v)) + +let log cfg f = + if cfg.debug.gen then f () else () + +let log_top cfg f = + if cfg.debug.top then f () else () + +let log_cfg cfg f = + if cfg.debug.cfg then f () else () + +let log_primops cfg f = + if cfg.debug.primop then f () else () + +let dbg_unfolding = Debug.get_toggle "Unfolding" +let log_unfolding cfg f = + if !dbg_unfolding then f () else () + +let log_nbe cfg f = + if cfg.debug.debug_nbe then f () + +(* Profiling the time each different primitive step consumes *) +let primop_time_map : BU.smap int = BU.smap_create 50 + +let primop_time_reset () = + BU.smap_clear primop_time_map + +let primop_time_count (nm : string) (ms : int) : unit = + match BU.smap_try_find primop_time_map nm with + | None -> BU.smap_add primop_time_map nm ms + | Some ms0 -> BU.smap_add primop_time_map nm (ms0 + ms) + +let fixto n s = + if String.length s < n + then (make (n - String.length s) ' ') ^ s + else s + +let primop_time_report () : string = + let pairs = BU.smap_fold primop_time_map (fun nm ms rest -> (nm, ms)::rest) [] in + let pairs = BU.sort_with (fun (_, t1) (_, t2) -> t1 - t2) pairs in + List.fold_right (fun (nm, ms) rest -> (BU.format2 "%sms --- %s\n" (fixto 10 (BU.string_of_int ms)) nm) ^ rest) pairs "" + +let extendable_primops_dirty : ref bool = BU.mk_ref true + +type register_prim_step_t = primitive_step -> unit +type retrieve_prim_step_t = unit -> prim_step_set +let mk_extendable_primop_set () + : register_prim_step_t + & retrieve_prim_step_t = + let steps = BU.mk_ref (empty_prim_steps ()) in + let register (p:primitive_step) = + extendable_primops_dirty := true; + steps := add_step p !steps + in + let retrieve () = !steps + in + register, retrieve + +let plugins = mk_extendable_primop_set () +let extra_steps = mk_extendable_primop_set () + +let register_plugin (p:primitive_step) = fst plugins p +let retrieve_plugins () = + if Options.no_plugins () + then empty_prim_steps () + else snd plugins () + +let register_extra_step p = fst extra_steps p +let retrieve_extra_steps () = snd extra_steps () + +let list_plugins () : list primitive_step = + FStarC.Common.psmap_values (retrieve_plugins ()) + +let list_extra_steps () : list primitive_step = + FStarC.Common.psmap_values (retrieve_extra_steps ()) + +let cached_steps : unit -> prim_step_set = + let memo : ref prim_step_set = BU.mk_ref (empty_prim_steps ()) in + fun () -> + if !extendable_primops_dirty + then + let steps = + merge_steps built_in_primitive_steps + (merge_steps (retrieve_plugins ()) + (retrieve_extra_steps ())) + in + memo := steps; + extendable_primops_dirty := false; + steps + else + !memo + +let add_nbe s = // ZP : Turns nbe flag on, to be used as the default norm strategy + if Options.use_nbe () + then { s with nbe_step = true } + else s + +let dbg_Norm = Debug.get_toggle "Norm" +let dbg_NormTop = Debug.get_toggle "NormTop" +let dbg_NormCfg = Debug.get_toggle "NormCfg" +let dbg_Primops = Debug.get_toggle "Primops" +let dbg_Unfolding = Debug.get_toggle "Unfolding" +let dbg_380 = Debug.get_toggle "380" +let dbg_WPE = Debug.get_toggle "WPE" +let dbg_NormDelayed = Debug.get_toggle "NormDelayed" +let dbg_print_normalized = Debug.get_toggle "print_normalized_terms" +let dbg_NBE = Debug.get_toggle "NBE" +let dbg_UNSOUND_EraseErasableArgs = Debug.get_toggle "UNSOUND_EraseErasableArgs" + +let config' psteps s e = + let d = s |> List.collect (function + | UnfoldUntil k -> [Env.Unfold k] + | Eager_unfolding -> [Env.Eager_unfolding_only] + | UnfoldQual l when List.contains "unfold" l -> + [Env.Eager_unfolding_only] + | Inlining -> [Env.InliningDelta] + | UnfoldQual l when List.contains "inline_for_extraction" l -> + [Env.InliningDelta] + | _ -> []) |> List.unique in + let d = match d with + | [] -> [Env.NoDelta] + | _ -> d in + let steps = to_fsteps s |> add_nbe in + let psteps = add_steps (merge_steps (env_dependent_ops e) (cached_steps ())) psteps in + let dbg_flag = List.contains NormDebug s in + { + tcenv = e; + debug = { + gen = !dbg_Norm || dbg_flag; + top = !dbg_NormTop || dbg_flag; + cfg = !dbg_NormCfg; + primop = !dbg_Primops; + unfolding = !dbg_Unfolding; + b380 = !dbg_380; + wpe = !dbg_WPE; + norm_delayed = !dbg_NormDelayed; + print_normalized = !dbg_print_normalized; + debug_nbe = !dbg_NBE; + erase_erasable_args = ( + if !dbg_UNSOUND_EraseErasableArgs then + Errors.log_issue e Errors.Warning_WarnOnUse + "The 'UNSOUND_EraseErasableArgs' setting is for debugging only; it is not sound"; + !dbg_UNSOUND_EraseErasableArgs); + }; + steps = steps; + delta_level = d; + primitive_steps = psteps; + strong = false; + memoize_lazy = true; + normalize_pure_lets = (not steps.pure_subterms_within_computations) || Options.normalize_pure_terms_for_extraction(); + reifying = false; + compat_memo_ignore_cfg = Options.Ext.get "compat:normalizer_memo_ignore_cfg" <> ""; + } + +let config s e = config' [] s e + +let should_reduce_local_let cfg lb = + if cfg.steps.do_not_unfold_pure_lets + then false //we're not allowed to do any local delta steps + else if cfg.steps.pure_subterms_within_computations && + U.has_attribute lb.lbattrs PC.inline_let_attr + then true //1. we're extracting, and it's marked @inline_let + else + let n = Env.norm_eff_name cfg.tcenv lb.lbeff in + if U.is_pure_effect n && + (cfg.normalize_pure_lets + || U.has_attribute lb.lbattrs PC.inline_let_attr) + then true //Or, 2. it's pure and we either not extracting, or it's marked @inline_let + else U.is_ghost_effect n && //Or, 3. it's ghost and we're not extracting + not (cfg.steps.pure_subterms_within_computations) + +let translate_norm_step = function + | Pervasives.Zeta -> [Zeta] + | Pervasives.ZetaFull -> [ZetaFull] + | Pervasives.Iota -> [Iota] + | Pervasives.Delta -> [UnfoldUntil delta_constant] + | Pervasives.Simpl -> [Simplify] + | Pervasives.Weak -> [Weak] + | Pervasives.HNF -> [HNF] + | Pervasives.Primops -> [Primops] + | Pervasives.Reify -> [Reify] + | Pervasives.NormDebug -> [NormDebug] + | Pervasives.UnfoldOnly names -> + [UnfoldUntil delta_constant; UnfoldOnly (List.map I.lid_of_str names)] + | Pervasives.UnfoldFully names -> + [UnfoldUntil delta_constant; UnfoldFully (List.map I.lid_of_str names)] + | Pervasives.UnfoldAttr names -> + [UnfoldUntil delta_constant; UnfoldAttr (List.map I.lid_of_str names)] + | Pervasives.UnfoldQual names -> + [UnfoldUntil delta_constant; UnfoldQual names] + | Pervasives.UnfoldNamespace names -> + [UnfoldUntil delta_constant; UnfoldNamespace names] + | Pervasives.Unascribe -> [Unascribe] + | Pervasives.NBE -> [NBE] + | Pervasives.Unmeta -> [Unmeta] + +let translate_norm_steps s = + let s = List.concatMap translate_norm_step s in + let add_exclude s z = if BU.for_some ((=?) z) s then s else Exclude z :: s in + let s = Beta::s in + let s = add_exclude s Zeta in + let s = add_exclude s Iota in + s diff --git a/src/typechecker/FStarC.TypeChecker.Cfg.fsti b/src/typechecker/FStarC.TypeChecker.Cfg.fsti new file mode 100644 index 00000000000..2a8915dcf65 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Cfg.fsti @@ -0,0 +1,155 @@ +(* + Copyright 2008-2014 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.TypeChecker.Cfg +open FStarC.Compiler.Effect +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Util +open FStar.String +open FStarC.Const +open FStar.Char +open FStarC.Errors +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.Syntax.Subst +open FStarC.Syntax.Util +open FStarC.TypeChecker +open FStarC.TypeChecker.Env +open FStarC.TypeChecker.Primops + +open FStarC.Class.Show +open FStarC.Class.Deq + +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module BU = FStarC.Compiler.Util +module FC = FStarC.Const +module PC = FStarC.Parser.Const +module U = FStarC.Syntax.Util +module I = FStarC.Ident +module EMB = FStarC.Syntax.Embeddings +module Z = FStarC.BigInt +module NBE = FStarC.TypeChecker.NBETerm + +type fsteps = { + beta : bool; + iota : bool; + zeta : bool; + zeta_full : bool; + weak : bool; + hnf : bool; + primops : bool; + do_not_unfold_pure_lets : bool; + unfold_until : option S.delta_depth; + unfold_only : option (list I.lid); + unfold_fully : option (list I.lid); + unfold_attr : option (list I.lid); + unfold_qual : option (list string); + unfold_namespace: option (Path.forest string bool); + dont_unfold_attr : option (list I.lid); + pure_subterms_within_computations : bool; + simplify : bool; + erase_universes : bool; + allow_unbound_universes : bool; + reify_ : bool; // 'reify' is reserved + compress_uvars : bool; + no_full_norm : bool; + check_no_uvars : bool; + unmeta : bool; + unascribe : bool; + in_full_norm_request: bool; + weakly_reduce_scrutinee:bool; + nbe_step:bool; + for_extraction:bool; + unrefine:bool; + default_univs_to_zero:bool; (* Default unresolved universe levels to zero *) + tactics : bool; +} + +instance val deq_fsteps : deq fsteps + +val default_steps : fsteps +val fstep_add_one : step -> fsteps -> fsteps +val to_fsteps : list step -> fsteps + +type debug_switches = { + gen : bool; + top : bool; + cfg : bool; + primop : bool; + unfolding : bool; + b380 : bool; + wpe : bool; + norm_delayed : bool; + print_normalized : bool; + debug_nbe : bool; + erase_erasable_args: bool; +} + +val no_debug_switches : debug_switches + +type cfg = { + steps: fsteps; + tcenv: Env.env; + debug: debug_switches; + delta_level: list Env.delta_level; // Controls how much unfolding of definitions should be performed + primitive_steps:BU.psmap primitive_step; + strong : bool; // under a binder + memoize_lazy : bool; (* What exactly is this? Seems to be always true now. *) + normalize_pure_lets: bool; + reifying : bool; + compat_memo_ignore_cfg:bool; (* See #2155, #2161, #2986 *) +} + +(* Profiling primitive operators *) +val primop_time_reset : unit -> unit +val primop_time_count : string -> int -> unit +val primop_time_report : unit -> string + +val cfg_env: cfg -> Env.env + +instance val showable_cfg : showable cfg + +val log : cfg -> (unit -> unit) -> unit +val log_top : cfg -> (unit -> unit) -> unit +val log_cfg : cfg -> (unit -> unit) -> unit +val log_primops : cfg -> (unit -> unit) -> unit +val log_unfolding : cfg -> (unit -> unit) -> unit +val log_nbe : cfg -> (unit -> unit) -> unit + +val is_prim_step: cfg -> fv -> bool +val find_prim_step: cfg -> fv -> option primitive_step + +// val embed_simple: EMB.embedding 'a -> Range.range -> 'a -> term +// val try_unembed_simple: EMB.embedding 'a -> term -> option 'a + +val built_in_primitive_steps : BU.psmap primitive_step +val simplification_steps (env:Env.env_t): BU.psmap primitive_step + +val register_plugin : primitive_step -> unit +val register_extra_step : primitive_step -> unit + +(* for debugging *) +val list_plugins : unit -> list primitive_step +val list_extra_steps : unit -> list primitive_step + +val config': list primitive_step -> list step -> Env.env -> cfg +val config: list step -> Env.env -> cfg + +val should_reduce_local_let : cfg -> letbinding -> bool + +val translate_norm_steps: list Pervasives.norm_step -> list Env.step diff --git a/src/typechecker/FStarC.TypeChecker.Common.fst b/src/typechecker/FStarC.TypeChecker.Common.fst new file mode 100644 index 00000000000..666af95e4a7 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Common.fst @@ -0,0 +1,367 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.TypeChecker.Common +open Prims +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.Ident +module S = FStarC.Syntax.Syntax +module Print = FStarC.Syntax.Print +module U = FStarC.Syntax.Util + +module BU = FStarC.Compiler.Util +module PC = FStarC.Parser.Const +module C = FStarC.Parser.Const + + +let as_tprob = function + | TProb p -> p + | _ -> failwith "Expected a TProb" + +let mk_by_tactic tac f = + let t_by_tactic = S.mk_Tm_uinst (tabbrev C.by_tactic_lid) [U_zero] in + S.mk_Tm_app t_by_tactic [S.as_arg tac; S.as_arg f] Range.dummyRange + +let rec delta_depth_greater_than l m = match l, m with + | Delta_equational_at_level i, Delta_equational_at_level j -> i > j + | Delta_constant_at_level i, Delta_constant_at_level j -> i > j + | Delta_abstract d, _ -> delta_depth_greater_than d m + | _, Delta_abstract d -> delta_depth_greater_than l d + | Delta_equational_at_level _, _ -> true + | _, Delta_equational_at_level _ -> false + +let rec decr_delta_depth = function + | Delta_constant_at_level 0 + | Delta_equational_at_level 0 -> None + | Delta_constant_at_level i -> Some (Delta_constant_at_level (i - 1)) + | Delta_equational_at_level i -> Some (Delta_equational_at_level (i - 1)) + | Delta_abstract d -> decr_delta_depth d + +instance showable_guard_formula : showable guard_formula = { + show = (function + | Trivial -> "Trivial" + | NonTrivial f -> "NonTrivial " ^ show f) +} + +instance showable_deferred_reason : showable deferred_reason = { + show = (function + | Deferred_univ_constraint -> "Deferred_univ_constraint" + | Deferred_occur_check_failed -> "Deferred_occur_check_failed" + | Deferred_first_order_heuristic_failed -> "Deferred_first_order_heuristic_failed" + | Deferred_flex -> "Deferred_flex" + | Deferred_free_names_check_failed -> "Deferred_free_names_check_failed" + | Deferred_not_a_pattern -> "Deferred_not_a_pattern" + | Deferred_flex_flex_nonpattern -> "Deferred_flex_flex_nonpattern" + | Deferred_delay_match_heuristic -> "Deferred_delay_match_heuristic" + | Deferred_to_user_tac -> "Deferred_to_user_tac" + ); +} +(***********************************************************************************) +(* A table of file -> starting row -> starting col -> identifier info *) +(* Used to support querying information about an identifier in interactive mode *) +(* The table provides: *) +(* -- the full name of the identifier *) +(* -- the source range of its use *) +(* -- the source range of its defining occurrence *) +(* -- its type *) +(***********************************************************************************) + +let insert_col_info (col:int) (info:identifier_info) (col_infos:list (int & identifier_info)) = + // Tail recursive helper + let rec __insert aux rest = + match rest with + | [] -> (aux, [col, info]) + | (c,i)::rest' -> + if col < c + then (aux, (col, info)::rest) + else __insert ((c,i)::aux) rest' + in + let l, r = __insert [] col_infos + in (List.rev l) @ r + +let find_nearest_preceding_col_info (col:int) (col_infos:list (int & identifier_info)) = + let rec aux out = function + | [] -> out + | (c, i)::rest -> + if c > col then out + else aux (Some i) rest + in + aux None col_infos + +let id_info_table_empty = + { id_info_enabled = false; + id_info_db = BU.psmap_empty (); + id_info_buffer = [] } + +open FStarC.Compiler.Range + +let print_identifier_info info = + BU.format3 "id info { %s, %s : %s}" + (Range.string_of_range info.identifier_range) + (match info.identifier with + | Inl x -> show x + | Inr fv -> show fv) + (show info.identifier_ty) + +let id_info__insert ty_map db info = + let range = info.identifier_range in + let use_range = Range.set_def_range range (Range.use_range range) in + let id_ty = + match info.identifier with + | Inr _ -> + ty_map info.identifier_ty + | Inl x -> + ty_map info.identifier_ty + in + match id_ty with + | None -> db + | Some id_ty -> + let info = { info with identifier_range = use_range; + identifier_ty = id_ty } in + + let fn = file_of_range use_range in + let start = start_of_range use_range in + let row, col = line_of_pos start, col_of_pos start in + + let rows = BU.psmap_find_default db fn (BU.pimap_empty ()) in + let cols = BU.pimap_find_default rows row [] in + + insert_col_info col info cols + |> BU.pimap_add rows row + |> BU.psmap_add db fn + +let id_info_insert table id ty range = + let info = { identifier = id; identifier_ty = ty; identifier_range = range} in + { table with id_info_buffer = info :: table.id_info_buffer } + +let id_info_insert_bv table bv ty = + if table.id_info_enabled then id_info_insert table (Inl bv) ty (range_of_bv bv) + else table + +let id_info_insert_fv table fv ty = + if table.id_info_enabled then id_info_insert table (Inr fv) ty (range_of_fv fv) + else table + +let id_info_toggle table enabled = + { table with id_info_enabled = enabled } + +let id_info_promote table ty_map = + { table with + id_info_buffer = []; + id_info_db = List.fold_left (id_info__insert ty_map) + table.id_info_db table.id_info_buffer } + +let id_info_at_pos (table: id_info_table) (fn:string) (row:int) (col:int) : option identifier_info = + let rows = BU.psmap_find_default table.id_info_db fn (BU.pimap_empty ()) in + let cols = BU.pimap_find_default rows row [] in + + match find_nearest_preceding_col_info col cols with + | None -> None + | Some info -> + let last_col = col_of_pos (end_of_range info.identifier_range) in + if col <= last_col then Some info else None + +let check_uvar_ctx_invariant (reason:string) (r:range) (should_check:bool) (g:gamma) (bs:binders) = + let fail () = + failwith (BU.format5 + "Invariant violation: gamma and binders are out of sync\n\t\ + reason=%s, range=%s, should_check=%s\n\t + gamma=%s\n\t\ + binders=%s\n" + reason + (Range.string_of_range r) + (if should_check then "true" else "false") + (show g) + (show bs)) + in + if not should_check then () + else match BU.prefix_until (function Binding_var _ -> true | _ -> false) g, bs with + | None, [] -> () + | Some (_, hd, gamma_tail), _::_ -> + let _, x = BU.prefix bs in + begin + match hd with + | Binding_var x' when S.bv_eq x.binder_bv x' -> + () + | _ -> fail() + end + | _ -> fail() + +instance showable_implicit : showable implicit = { + show = (fun i -> show i.imp_uvar.ctx_uvar_head); +} + +let implicits_to_string imps = + let imp_to_string i = show i.imp_uvar.ctx_uvar_head in + FStarC.Common.string_of_list imp_to_string imps + +let trivial_guard = + let open FStarC.Class.Listlike in + { + guard_f=Trivial; + deferred_to_tac=empty; + deferred=empty; + univ_ineqs=(empty, empty); + implicits=empty; + } + +let conj_guard_f g1 g2 = match g1, g2 with + | Trivial, g + | g, Trivial -> g + | NonTrivial f1, NonTrivial f2 -> NonTrivial (U.mk_conj f1 f2) + +let binop_guard f g1 g2 = { + guard_f=f g1.guard_f g2.guard_f; + deferred_to_tac=g1.deferred_to_tac ++ g2.deferred_to_tac; + deferred=g1.deferred ++ g2.deferred; + univ_ineqs=(fst g1.univ_ineqs ++ fst g2.univ_ineqs, + snd g1.univ_ineqs ++ snd g2.univ_ineqs); + implicits=g1.implicits ++ g2.implicits; +} +let conj_guard g1 g2 = binop_guard conj_guard_f g1 g2 + +instance monoid_guard_t : monoid guard_t = { + mzero = trivial_guard; + mplus = conj_guard; +} + +let rec check_trivial (t:term) : guard_formula = + let hd, args = U.head_and_args (U.unmeta t) in + match (U.un_uinst (U.unmeta hd)).n, args with + | Tm_fvar tc, [] + when S.fv_eq_lid tc PC.true_lid -> + Trivial + + | Tm_fvar sq, [v, _] + when S.fv_eq_lid sq PC.squash_lid + || S.fv_eq_lid sq PC.auto_squash_lid -> + (match check_trivial v with + | Trivial -> Trivial + | _ -> NonTrivial t) + + | _ -> NonTrivial t + +let imp_guard_f g1 g2 = match g1, g2 with + | Trivial, g -> g + | g, Trivial -> Trivial + | NonTrivial f1, NonTrivial f2 -> + let imp = U.mk_imp f1 f2 in check_trivial imp + +let imp_guard g1 g2 = binop_guard imp_guard_f g1 g2 + +let conj_guards gs = List.fold_left conj_guard trivial_guard gs +let split_guard g = + {g with guard_f = Trivial}, + {trivial_guard with guard_f = g.guard_f} + +let weaken_guard_formula g fml = + match g.guard_f with + | Trivial -> g + | NonTrivial f -> + { g with guard_f = check_trivial (U.mk_imp fml f) } + + +let mk_lcomp eff_name res_typ cflags comp_thunk = + { eff_name = eff_name; + res_typ = res_typ; + cflags = cflags; + comp_thunk = FStarC.Compiler.Util.mk_ref (Inl comp_thunk) } + +let lcomp_comp lc = + match !(lc.comp_thunk) with + | Inl thunk -> + let c, g = thunk () in + lc.comp_thunk := Inr c; + c, g + | Inr c -> c, trivial_guard + +let apply_lcomp fc fg lc = + mk_lcomp + lc.eff_name lc.res_typ lc.cflags + (fun () -> + let (c, g) = lcomp_comp lc in + fc c, fg g) + +let lcomp_to_string lc = + if Options.print_effect_args () then + show (lc |> lcomp_comp |> fst) + else + BU.format2 "%s %s" (show lc.eff_name) (show lc.res_typ) + +let lcomp_set_flags lc fs = + let comp_typ_set_flags (c:comp) = + match c.n with + | Total _ + | GTotal _ -> c + | Comp ct -> + let ct = {ct with flags=fs} in + {c with n=Comp ct} + in + mk_lcomp lc.eff_name + lc.res_typ + fs + (fun () -> lc |> lcomp_comp |> (fun (c, g) -> comp_typ_set_flags c, g)) + +let is_total_lcomp c = lid_equals c.eff_name PC.effect_Tot_lid || c.cflags |> BU.for_some (function TOTAL | RETURN -> true | _ -> false) + +let is_tot_or_gtot_lcomp c = lid_equals c.eff_name PC.effect_Tot_lid + || lid_equals c.eff_name PC.effect_GTot_lid + || c.cflags |> BU.for_some (function TOTAL | RETURN -> true | _ -> false) + +let is_lcomp_partial_return c = c.cflags |> BU.for_some (function RETURN | PARTIAL_RETURN -> true | _ -> false) + +let is_pure_lcomp lc = + is_total_lcomp lc + || U.is_pure_effect lc.eff_name + || lc.cflags |> BU.for_some (function LEMMA -> true | _ -> false) + +let is_pure_or_ghost_lcomp lc = + is_pure_lcomp lc || U.is_ghost_effect lc.eff_name + +let set_result_typ_lc lc t = + mk_lcomp lc.eff_name t lc.cflags (fun () -> lc |> lcomp_comp |> (fun (c, g) -> U.set_result_typ c t, g)) + +let residual_comp_of_lcomp lc = { + residual_effect=lc.eff_name; + residual_typ=Some (lc.res_typ); + residual_flags=lc.cflags + } + +let lcomp_of_comp_guard c0 g = + let eff_name, flags = + match c0.n with + | Total _ -> PC.effect_Tot_lid, [TOTAL] + | GTotal _ -> PC.effect_GTot_lid, [SOMETRIVIAL] + | Comp c -> c.effect_name, c.flags in + mk_lcomp eff_name (U.comp_result c0) flags (fun () -> c0, g) + +let lcomp_of_comp c0 = lcomp_of_comp_guard c0 trivial_guard + +let check_positivity_qual subtyping p0 p1 + = if p0 = p1 then true + else if subtyping + then match p0, p1 with + | Some _, None -> true + | Some BinderUnused, Some BinderStrictlyPositive -> true + | _ -> false + else false diff --git a/src/typechecker/FStarC.TypeChecker.Common.fsti b/src/typechecker/FStarC.TypeChecker.Common.fsti new file mode 100644 index 00000000000..a7fd49405e4 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Common.fsti @@ -0,0 +1,217 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.TypeChecker.Common +open Prims +open FStar.Pervasives +open FStarC.Compiler.Effect + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.Ident +open FStarC.Class.Show +open FStarC.Class.Monoid + +open FStarC.Compiler.CList +module CList = FStarC.Compiler.CList + +(* Bring instances in scope *) +open FStarC.Syntax.Print {} + +module S = FStarC.Syntax.Syntax + +module BU = FStarC.Compiler.Util + +(* relations on types, kinds, etc. *) +type rel = + | EQ + | SUB + | SUBINV (* sub-typing/sub-kinding, inverted *) + +type rank_t = + | Rigid_rigid + | Flex_rigid_eq + | Flex_flex_pattern_eq + | Flex_rigid + | Rigid_flex + | Flex_flex + +type problem 'a = { //Try to prove: lhs rel rhs ~ guard + pid:int; + lhs:'a; + relation:rel; + rhs:'a; + element:option bv; //where, guard is a predicate on this term (which appears free in/is a subterm of the guard) + logical_guard:term; //the condition under which this problem is solveable; (?u v1..vn) + logical_guard_uvar:ctx_uvar; + reason: list string; //why we generated this problem, for error reporting + loc: Range.range; //and the source location where this arose + rank: option rank_t; + logical : bool; //logical problems cannot unfold connectives +} + +type prob = + | TProb of problem typ + | CProb of problem comp +type prob_t = prob + +val as_tprob : prob -> problem typ + +type probs = list prob + +type guard_formula = + | Trivial + | NonTrivial of formula + +instance val showable_guard_formula : showable guard_formula + +type deferred_reason = + | Deferred_univ_constraint + | Deferred_occur_check_failed + | Deferred_first_order_heuristic_failed + | Deferred_flex + | Deferred_free_names_check_failed + | Deferred_not_a_pattern + | Deferred_flex_flex_nonpattern + | Deferred_delay_match_heuristic + | Deferred_to_user_tac + +instance val showable_deferred_reason : showable deferred_reason + +type deferred = clist (deferred_reason & string & prob) + +type univ_ineq = universe & universe + +(***********************************************************************************) +(* A table of file -> starting row -> starting col -> identifier info *) +(* Used to support querying information about an identifier in interactive mode *) +(* The table provides: *) +(* -- the full name of the identifier *) +(* -- the source range of its use *) +(* -- the source range of its defining occurrence *) +(* -- its type *) +(***********************************************************************************) + +type identifier_info = { + identifier:either bv fv; + identifier_ty:typ; + identifier_range:Range.range; +} + +type id_info_by_col = //sorted in ascending order of columns + list (int & identifier_info) + +type col_info_by_row = + BU.pimap id_info_by_col + +type row_info_by_file = + BU.psmap col_info_by_row + +type id_info_table = { + id_info_enabled: bool; + id_info_db: row_info_by_file; + id_info_buffer: list identifier_info; +} + +val check_uvar_ctx_invariant : string -> Range.range -> bool -> gamma -> binders -> unit + +val mk_by_tactic : term -> term -> term + +val delta_depth_greater_than : delta_depth -> delta_depth -> bool +val decr_delta_depth : delta_depth -> option delta_depth + +val insert_col_info : int -> identifier_info -> list (int & identifier_info) -> list (int & identifier_info) +val find_nearest_preceding_col_info : int -> list (int & identifier_info) -> option identifier_info + +val id_info_table_empty : id_info_table + +val id_info_insert_bv : id_info_table -> bv -> typ -> id_info_table +val id_info_insert_fv : id_info_table -> fv -> typ -> id_info_table +val id_info_toggle : id_info_table -> bool -> id_info_table +val id_info_promote : id_info_table -> (typ -> option typ) -> id_info_table +val id_info_at_pos : id_info_table -> string -> int -> int -> option identifier_info + +// Reason, term and uvar, and (rough) position where it is introduced +// The term is just a Tm_uvar of the ctx_uvar +type implicit = { + imp_reason : string; // Reason (in text) why the implicit was introduced + imp_uvar : ctx_uvar; // The ctx_uvar representing it + imp_tm : term; // The term, made up of the ctx_uvar + imp_range : Range.range; // Position where it was introduced +} + +instance val showable_implicit : showable implicit + +(* Bad naming here *) +type implicits = list implicit +val implicits_to_string : implicits -> string +type implicits_t = CList.t implicit + +type guard_t = { + guard_f: guard_formula; + deferred_to_tac: deferred; //This field maintains problems that are to be dispatched to a tactic + //They are never attempted by the unification engine in Rel + deferred: deferred; + univ_ineqs: clist universe & clist univ_ineq; + implicits: implicits_t; +} + +val trivial_guard : guard_t +val conj_guard : guard_t -> guard_t -> guard_t + +instance val monoid_guard_t : monoid guard_t (* conj_guard, trivial_guard *) + +val check_trivial : term -> guard_formula +val imp_guard : guard_t -> guard_t -> guard_t +val conj_guards : list guard_t -> guard_t + +// splits the guard into the logical component (snd in the returned tuple) +// and the rest (fst in the returned tuple) +val split_guard : guard_t -> guard_t & guard_t + +val weaken_guard_formula: guard_t -> typ -> guard_t +type lcomp = { //a lazy computation + eff_name: lident; + res_typ: typ; + cflags: list cflag; + comp_thunk: ref (either (unit -> (comp & guard_t)) comp) +} + +val mk_lcomp: + eff_name: lident -> + res_typ: typ -> + cflags: list cflag -> + comp_thunk: (unit -> (comp & guard_t)) -> lcomp + +val lcomp_comp: lcomp -> (comp & guard_t) +val apply_lcomp : (comp -> comp) -> (guard_t -> guard_t) -> lcomp -> lcomp +val lcomp_to_string : lcomp -> string (* CAUTION! can have side effects of forcing the lcomp *) +val lcomp_set_flags : lcomp -> list S.cflag -> lcomp +val is_total_lcomp : lcomp -> bool +val is_tot_or_gtot_lcomp : lcomp -> bool +val is_lcomp_partial_return : lcomp -> bool +val is_pure_lcomp : lcomp -> bool +val is_pure_or_ghost_lcomp : lcomp -> bool +val set_result_typ_lc : lcomp -> typ -> lcomp +val residual_comp_of_lcomp : lcomp -> residual_comp +val lcomp_of_comp_guard : comp -> guard_t -> lcomp +//lcomp_of_comp_guard with trivial guard +val lcomp_of_comp : comp -> lcomp + +val check_positivity_qual (subtyping:bool) (p0 p1:option positivity_qualifier) + : bool diff --git a/src/typechecker/FStarC.TypeChecker.Core.fst b/src/typechecker/FStarC.TypeChecker.Core.fst new file mode 100644 index 00000000000..f1f355e0808 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Core.fst @@ -0,0 +1,1982 @@ +module FStarC.TypeChecker.Core +open FStarC +open FStar.List.Tot +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.Compiler.Effect +open FStarC.Syntax.Syntax +open FStarC.TypeChecker +module Env = FStarC.TypeChecker.Env +module S = FStarC.Syntax.Syntax +module R = FStarC.Compiler.Range +module U = FStarC.Syntax.Util +module N = FStarC.TypeChecker.Normalize +module PC = FStarC.Parser.Const +module I = FStarC.Ident +module P = FStarC.Syntax.Print +module BU = FStarC.Compiler.Util +module TcUtil = FStarC.TypeChecker.Util +module Hash = FStarC.Syntax.Hash +module Subst = FStarC.Syntax.Subst +module TEQ = FStarC.TypeChecker.TermEqAndSimplify + +open FStarC.Class.Show +open FStarC.Class.Setlike +open FStarC.Class.Tagged + +let dbg = Debug.get_toggle "Core" +let dbg_Eq = Debug.get_toggle "CoreEq" +let dbg_Top = Debug.get_toggle "CoreTop" +let dbg_Exit = Debug.get_toggle "CoreExit" + +let goal_ctr = BU.mk_ref 0 +let get_goal_ctr () = !goal_ctr +let incr_goal_ctr () = let v = !goal_ctr in goal_ctr := v + 1; v + 1 + +let guard_handler_t = Env.env -> typ -> bool + +type env = { + tcenv : Env.env; + allow_universe_instantiation : bool; + max_binder_index : int; + guard_handler : option guard_handler_t; + should_read_cache: bool +} + +let push_binder g b = + if b.binder_bv.index <= g.max_binder_index + then failwith "Assertion failed: unexpected shadowing in the core environment" + else { g with tcenv = Env.push_binders g.tcenv [b]; max_binder_index = b.binder_bv.index } + +let push_binders = List.fold_left push_binder + +let fresh_binder (g:env) (old:binder) + : env & binder + = let ctr = g.max_binder_index + 1 in + let bv = { old.binder_bv with index = ctr } in + let b = S.mk_binder_with_attrs bv old.binder_qual old.binder_positivity old.binder_attrs in + push_binder g b, b + +let open_binders (g:env) (bs:binders) + = let g, bs_rev, subst = + List.fold_left + (fun (g, bs, subst) b -> + let bv = { b.binder_bv with sort = Subst.subst subst b.binder_bv.sort } in + let b = { binder_bv = bv; + binder_qual = Subst.subst_bqual subst b.binder_qual; + binder_positivity = b.binder_positivity; + binder_attrs = List.map (Subst.subst subst) b.binder_attrs } in + let g, b' = fresh_binder g b in + g, b'::bs, DB(0, b'.binder_bv)::Subst.shift_subst 1 subst) + (g, [], []) + bs + in + g, List.rev bs_rev, subst + +let open_pat (g:env) (p:pat) + : env & pat & subst_t + = let rec open_pat_aux g p sub = + match p.v with + | Pat_constant _ -> g, p, sub + + | Pat_cons(fv, us_opt, pats) -> + let g, pats, sub = + List.fold_left + (fun (g, pats, sub) (p, imp) -> + let g, p, sub = open_pat_aux g p sub in + (g, (p,imp)::pats, sub)) + (g, [], sub) + pats + in + g, {p with v=Pat_cons(fv, us_opt, List.rev pats)}, sub + + | Pat_var x -> + let bx = S.mk_binder {x with sort = Subst.subst sub x.sort} in + let g, bx' = fresh_binder g bx in + let sub = DB(0, bx'.binder_bv)::Subst.shift_subst 1 sub in + g, {p with v=Pat_var bx'.binder_bv}, sub + + | Pat_dot_term eopt -> + let eopt = BU.map_option (Subst.subst sub) eopt in + g, {p with v=Pat_dot_term eopt}, sub + in + open_pat_aux g p [] + + +let open_term (g:env) (b:binder) (t:term) + : env & binder & term + = let g, b' = fresh_binder g b in + let t = FStarC.Syntax.Subst.subst [DB(0, b'.binder_bv)] t in + g, b', t + +let open_term_binders (g:env) (bs:binders) (t:term) + : env & binders & term + = let g, bs, subst = open_binders g bs in + g, bs, Subst.subst subst t + +let open_comp (g:env) (b:binder) (c:comp) + : env & binder & comp + = let g, bx = fresh_binder g b in + let c = FStarC.Syntax.Subst.subst_comp [DB(0, bx.binder_bv)] c in + g, bx, c + +let open_comp_binders (g:env) (bs:binders) (c:comp) + : env & binders & comp + = let g, bs, s = open_binders g bs in + let c = FStarC.Syntax.Subst.subst_comp s c in + g, bs, c + +let arrow_formals_comp g c = + let bs, c = U.arrow_formals_comp_ln c in + let g, bs, subst = open_binders g bs in + g, bs, Subst.subst_comp subst c + +let open_branch (g:env) (br:S.branch) + : env & branch + = let (p, wopt, e) = br in + let g, p, s = open_pat g p in + g, (p, BU.map_option (Subst.subst s) wopt, Subst.subst s e) + +//br0 and br1 are expected to have equal patterns +let open_branches_eq_pat (g:env) (br0 br1:S.branch) + = let (p0, wopt0, e0) = br0 in + let (_, wopt1, e1) = br1 in + let g, p0, s = open_pat g p0 in + g, + (p0, BU.map_option (Subst.subst s) wopt0, Subst.subst s e0), + (p0, BU.map_option (Subst.subst s) wopt1, Subst.subst s e1) + +let precondition = option typ + +let success a = a & precondition + +type relation = + | EQUALITY + | SUBTYPING : option term -> relation + +let relation_to_string = function + | EQUALITY -> "=?=" + | SUBTYPING None -> "<:?" + | SUBTYPING (Some tm) -> BU.format1 "( <:? %s)" (show tm) + +type context_term = + | CtxTerm : term -> context_term + | CtxRel : term -> relation -> term -> context_term + +let context_term_to_string (c:context_term) = + match c with + | CtxTerm term -> show term + | CtxRel t0 r t1 -> + BU.format3 "%s %s %s" + (show t0) + (relation_to_string r) + (show t1) + +type context = { + no_guard : bool; + unfolding_ok : bool; + error_context: list (string & option context_term) +} + +(* The instance prints some brief info on the error_context. `print_context` +below is a full printer. *) +instance showable_context : showable context = { + show = (fun context -> BU.format3 "{no_guard=%s; unfolding_ok=%s; error_context=%s}" + (show context.no_guard) + (show context.unfolding_ok) + (show (List.map fst context.error_context))); +} + +let print_context (ctx:context) + : string = + let rec aux (depth:string) (ctx:_) = + match ctx with + | [] -> "" + | (msg, ctx_term)::tl -> + let hd = + BU.format3 + "%s %s (%s)\n" + depth + msg + (match ctx_term with None -> "" | Some ctx_term -> context_term_to_string ctx_term) + in + let tl = aux (depth ^ ">") tl in + hd ^ tl + in + aux "" (List.rev ctx.error_context) + +let error = context & string + +let print_error (err:error) = + let ctx, msg = err in + BU.format2 "%s%s" (print_context ctx) msg + +let print_error_short (err:error) = snd err + +type __result a = + | Success of a + | Error of error + +instance showable_result #a (_ : showable a) : Tot (showable (__result a)) = { + show = (function + | Success a -> "Success " ^ show a + | Error e -> "Error " ^ print_error_short e); +} + +let result a = context -> __result (success a) + +type hash_entry = { + he_term:term; + he_gamma:list binding; + he_res:success (tot_or_ghost & typ); +} +module THT = FStarC.Syntax.TermHashTable +type tc_table = THT.hashtable hash_entry +let equal_term_for_hash t1 t2 = + FStarC.Profiling.profile (fun _ -> Hash.equal_term t1 t2) None "FStarC.TypeChecker.Core.equal_term_for_hash" +let equal_term t1 t2 = + FStarC.Profiling.profile (fun _ -> Hash.equal_term t1 t2) None "FStarC.TypeChecker.Core.equal_term" +let table : tc_table = THT.create 1048576 //2^20 +type cache_stats_t = { hits : int; misses : int } +let cache_stats = BU.mk_ref { hits = 0; misses = 0 } +let record_cache_hit () = + let cs = !cache_stats in + cache_stats := { cs with hits = cs.hits + 1 } +let record_cache_miss () = + let cs = !cache_stats in + cache_stats := { cs with misses = cs.misses + 1 } +let reset_cache_stats () = + cache_stats := { hits = 0; misses = 0 } +let report_cache_stats () = !cache_stats +let clear_memo_table () = THT.clear table +let insert (g:env) (e:term) (res:success (tot_or_ghost & typ)) = + let entry = { + he_term = e; + he_gamma = g.tcenv.gamma; + he_res = res + } + in + THT.insert e entry table + +inline_for_extraction +let return (#a:Type) (x:a) : result a = fun _ -> Success (x, None) + +let and_pre (p1 p2:precondition) = + match p1, p2 with + | None, None -> None + | Some p, None + | None, Some p -> Some p + | Some p1, Some p2 -> Some (U.mk_conj p1 p2) + +inline_for_extraction +let (let!) (#a:Type) (#b:Type) (x:result a) (y:a -> result b) + : result b + = fun ctx0 -> + match x ctx0 with + | Success (x, g1) -> + (match y x ctx0 with + | Success (y, g2) -> Success (y, and_pre g1 g2) + | err -> err) + | Error err -> Error err + +inline_for_extraction +let (and!) (#a:Type) (#b:Type) (x:result a) (y:result b) + : result (a & b) + = let! v = x in + let! u = y in + return (v, u) + +let (let?) (#a:Type) (#b:Type) (x:option a) (f: a -> option b) + : option b + = match x with + | None -> None + | Some x -> f x + +let fail #a msg : result a = fun ctx -> Error (ctx, msg) + +let dump_context + : result unit + = fun ctx -> + BU.print_string (print_context ctx); + return () ctx + +inline_for_extraction +let handle_with (#a:Type) (x:result a) (h: unit -> result a) + : result a + = fun ctx -> + match x ctx with + | Error _ -> h () ctx + | res -> res + +inline_for_extraction +let with_context (#a:Type) (msg:string) (t:option context_term) (x:unit -> result a) + : result a + = fun ctx -> + let ctx = { ctx with error_context=((msg,t)::ctx.error_context) } in + x () ctx + +let mk_type (u:universe) = S.mk (Tm_type u) R.dummyRange + +let is_type (g:env) (t:term) + : result universe + = let aux t = + match (Subst.compress t).n with + | Tm_type u -> + return u + + | _ -> + fail (BU.format1 "Expected a type; got %s" (show t)) + in + with_context "is_type" (Some (CtxTerm t)) (fun _ -> + handle_with + (aux t) + (fun _ -> aux (U.unrefine (N.unfold_whnf g.tcenv t)))) + +let rec is_arrow (g:env) (t:term) + : result (binder & tot_or_ghost & typ) + = let rec aux t = + match (Subst.compress t).n with + | Tm_arrow {bs=[x]; comp=c} -> + if U.is_tot_or_gtot_comp c + then + let g, x, c = open_comp g x c in + let eff = + if U.is_total_comp c + then E_Total + else E_Ghost + in + return (x, eff, U.comp_result c) + else ( + let e_tag = + let Comp ct = c.n in + if Ident.lid_equals ct.effect_name PC.effect_Pure_lid || + Ident.lid_equals ct.effect_name PC.effect_Lemma_lid + then Some E_Total + else if Ident.lid_equals ct.effect_name PC.effect_Ghost_lid + then Some E_Ghost + else None + in + (* Turn x:t -> Pure/Ghost t' pre post + into x:t{pre} -> Tot/GTot (y:t'{post}) + + This is ok for pre. + But, it loses precision for post. + In effect form, the post is in scope for the entire continuation. + Whereas the refinement on the result is not. + *) + match e_tag with + | None -> fail (BU.format1 "Expected total or gtot arrow, got %s" (Ident.string_of_lid (U.comp_effect_name c))) + | Some e_tag -> + let g, [x], c = arrow_formals_comp g t in + let (pre, _)::(post, _)::_ = U.comp_effect_args c in + let arg_typ = U.refine x.binder_bv pre in + let res_typ = + let r = S.new_bv None (U.comp_result c) in + let post = S.mk_Tm_app post [(S.bv_to_name r, None)] post.pos in + U.refine r post + in + let xbv = { x.binder_bv with sort = arg_typ } in + let x = { x with binder_bv = xbv } in + return (x, e_tag, res_typ) + ) + + | Tm_arrow {bs=x::xs; comp=c} -> + let t = S.mk (Tm_arrow {bs=xs; comp=c}) t.pos in + let g, x, t = open_term g x t in + return (x, E_Total, t) + + | Tm_refine {b=x} -> + is_arrow g x.sort + + | Tm_meta {tm=t} + | Tm_ascribed {tm=t} -> + aux t + + | _ -> + fail (BU.format2 "Expected an arrow, got (%s) %s" (tag_of t) (show t)) + in + with_context "is_arrow" None (fun _ -> + handle_with + (aux t) + (fun _ -> aux (N.unfold_whnf g.tcenv t))) + +let check_arg_qual (a:aqual) (b:bqual) + : result unit + = match b with + | Some (Implicit _) + | Some (Meta _) -> + begin + match a with + | Some ({aqual_implicit=true}) -> + return () + | _ -> + fail "missing arg qualifier implicit" + end + + | _ -> + begin + match a with + | Some ({aqual_implicit=true}) -> + fail "extra arg qualifier implicit" + | _ -> return () + end + +let check_bqual (b0 b1:bqual) + : result unit + = match b0, b1 with + | None, None -> return () + | Some (Implicit b0), Some (Implicit b1) -> + //we don't care about the inaccessibility qualifier + //when comparing bquals + return () + | Some Equality, Some Equality -> + return () + | Some (Meta t1), Some (Meta t2) -> + if equal_term t1 t2 + then return () + else fail "Binder qualifier mismatch" + | _ -> + fail "Binder qualifier mismatch" + +let check_aqual (a0 a1:aqual) + : result unit + = match a0, a1 with + | None, None -> return () + | Some ({aqual_implicit=b0}), Some ({aqual_implicit=b1}) -> + if b0 = b1 + then return () + else fail (BU.format2 "Unequal arg qualifiers: lhs implicit=%s and rhs implicit=%s" + (string_of_bool b0) (string_of_bool b1)) + | None, Some { aqual_implicit=false } + | Some { aqual_implicit=false }, None -> + return () + | _ -> + fail (BU.format2 "Unequal arg qualifiers: lhs %s and rhs %s" + (show a0) (show a1)) + +let check_positivity_qual (rel:relation) (p0 p1:option positivity_qualifier) + : result unit + = if FStarC.TypeChecker.Common.check_positivity_qual (SUBTYPING? rel) p0 p1 + then return () + else fail "Unequal positivity qualifiers" + +let mk_forall_l (us:universes) (xs:binders) (t:term) + : term + = FStarC.Compiler.List.fold_right2 + (fun u x t -> U.mk_forall u x.binder_bv t) + us + xs + t + +let close_guard (xs:binders) (us:universes) (g:precondition) + : precondition + = match g with + | None -> None + | Some t -> Some (mk_forall_l us xs t) + +let close_guard_with_definition (x:binder) (u:universe) (t:term) (g:precondition) + : precondition + = match g with + | None -> None + | Some t -> + Some ( + let t = U.mk_imp (U.mk_eq2 u x.binder_bv.sort (S.bv_to_name x.binder_bv) t) t in + U.mk_forall u x.binder_bv t + ) + +let with_binders (#a:Type) (xs:binders) (us:universes) (f:result a) + : result a + = fun ctx -> + match f ctx with + | Success (t, g) -> Success (t, close_guard xs us g) + | err -> err + +let with_definition (#a:Type) (x:binder) (u:universe) (t:term) (f:result a) + : result a + = fun ctx -> + match f ctx with + | Success (a, g) -> Success (a, close_guard_with_definition x u t g) + | err -> err + +let guard (t:typ) + : result unit + = fun _ -> Success ((), Some t) + +let abs (a:typ) (f: binder -> term) : term = + let x = S.new_bv None a in + let xb = S.mk_binder x in + U.abs [xb] (f xb) None + +let weaken_subtyping_guard (p:term) + (g:precondition) + : precondition + = BU.map_opt g (fun q -> U.mk_imp p q) + +let strengthen_subtyping_guard (p:term) + (g:precondition) + : precondition + = Some (BU.dflt p (BU.map_opt g (fun q -> U.mk_conj p q))) + +let weaken (p:term) (g:result 'a) + = fun ctx -> + match g ctx with + | Success (x, q) -> Success (x, weaken_subtyping_guard p q) + | err -> err + +let weaken_with_guard_formula (p:FStarC.TypeChecker.Common.guard_formula) (g:result 'a) + = match p with + | Common.Trivial -> g + | Common.NonTrivial p -> weaken p g + +let push_hypothesis (g:env) (h:term) = + let bv = S.new_bv (Some h.pos) h in + let b = S.mk_binder bv in + fst (fresh_binder g b) + +let strengthen (p:term) (g:result 'a) + = fun ctx -> + match g ctx with + | Success (x, q) -> Success (x, strengthen_subtyping_guard p q) + | err -> err + +let no_guard (g:result 'a) + : result 'a + = fun ctx -> + match g ({ ctx with no_guard = true}) with + | Success (x, None) -> Success (x, None) + | Success (x, Some g) -> fail (BU.format1 "Unexpected guard: %s" (show g)) ctx + | err -> err + +let equatable g t = + t |> U.leftmost_head |> Rel.may_relate_with_logical_guard g.tcenv true + +let apply_predicate x p = fun e -> Subst.subst [NT(x.binder_bv, e)] p + +let curry_arrow (x:binder) (xs:binders) (c:comp) = + let tail = S.mk (Tm_arrow {bs=xs; comp=c}) R.dummyRange in + S.mk (Tm_arrow {bs=[x]; comp=S.mk_Total tail}) R.dummyRange + +let curry_abs (b0:binder) (b1:binder) (bs:binders) (body:term) (ropt: option residual_comp) = + let tail = S.mk (Tm_abs {bs=b1::bs; body; rc_opt=ropt}) body.pos in + S.mk (Tm_abs {bs=[b0]; body=tail; rc_opt=None}) body.pos + +let is_gtot_comp c = U.is_tot_or_gtot_comp c && not (U.is_total_comp c) + +let rec context_included (g0 g1: list binding) = + if BU.physical_equality g0 g1 then true else + match g0, g1 with + | [], _ -> true + + | b0::g0', b1::g1' -> + begin + match b0, b1 with + | Binding_var x0, Binding_var x1 -> + if x0.index = x1.index + then equal_term x0.sort x1.sort + && context_included g0' g1' + else context_included g0 g1' + + | Binding_lid _, Binding_lid _ + | Binding_univ _, Binding_univ _ -> + true + + | _ -> + false + end + + | _ -> false + +let curry_application hd arg args p = + let head = S.mk (Tm_app {hd; args=[arg]}) p in + let t = S.mk (Tm_app {hd=head; args}) p in + t + + +let lookup (g:env) (e:term) : result (tot_or_ghost & typ) = + match THT.lookup e table with + | None -> + record_cache_miss (); + fail "not in cache" + | Some he -> + if he.he_gamma `context_included` g.tcenv.gamma + then ( + record_cache_hit(); + if !dbg then + BU.print4 "cache hit\n %s |- %s : %s\nmatching env %s\n" + (show g.tcenv.gamma) + (show e) + (show (snd (fst he.he_res))) + (show he.he_gamma); + fun _ -> Success he.he_res + ) + else ( + // record_cache_miss(); + fail "not in cache" + ) + +let check_no_escape (bs:binders) t = + let xs = FStarC.Syntax.Free.names t in + if BU.for_all (fun b -> not (mem b.binder_bv xs)) bs + then return () + else fail "Name escapes its scope" + +let rec map (#a #b:Type) (f:a -> result b) (l:list a) : result (list b) = + match l with + | [] -> return [] + | hd::tl -> + let! hd = f hd in + let! tl = map f tl in + return (hd::tl) + +let mapi (#a #b:Type) (f:int -> a -> result b) (l:list a) : result (list b) = + let rec aux i l = + match l with + | [] -> return [] + | hd::tl -> + let! hd = f i hd in + let! tl = aux (i + 1) tl in + return (hd::tl) + in + aux 0 l + +let rec map2 (#a #b #c:Type) (f:a -> b -> result c) (l1:list a) (l2:list b) : result (list c) = + match l1, l2 with + | [], [] -> return [] + | hd1::tl1, hd2::tl2 -> + let! hd = f hd1 hd2 in + let! tl = map2 f tl1 tl2 in + return (hd::tl) + +let rec fold (#a #b:Type) (f:a -> b -> result a) (x:a) (l:list b) : result a = + match l with + | [] -> return x + | hd::tl -> + let! x = f x hd in + fold f x tl + +let rec fold2 (#a #b #c:Type) (f:a -> b -> c -> result a) (x:a) (l1:list b) (l2:list c) : result a = + match l1, l2 with + | [], [] -> return x + | hd1::tl1, hd2::tl2 -> + let! x = f x hd1 hd2 in + fold2 f x tl1 tl2 + +let rec iter2 (xs ys:list 'a) (f: 'a -> 'a -> 'b -> result 'b) (b:'b) + : result 'b + = match xs, ys with + | [], [] -> return b + | x::xs, y::ys -> + let! b = f x y b in + iter2 xs ys f b + | _ -> fail "Lists of differing length" + +let is_non_informative g t = N.non_info_norm g t + +let non_informative g t + : bool + = is_non_informative g.tcenv t + +let as_comp (g:env) (et: (tot_or_ghost & typ)) + : comp + = match et with + | E_Total, t -> S.mk_Total t + | E_Ghost, t -> + if non_informative g t + then S.mk_Total t + else S.mk_GTotal t + +let comp_as_tot_or_ghost_and_type (c:comp) + : option (tot_or_ghost & typ) + = if U.is_total_comp c + then Some (E_Total, U.comp_result c) + else if U.is_tot_or_gtot_comp c + then Some (E_Ghost, U.comp_result c) + else None + +let join_eff e0 e1 = + match e0, e1 with + | E_Ghost, _ + | _, E_Ghost -> E_Ghost + | _ -> E_Total + +let join_eff_l es = List.Tot.fold_right join_eff es E_Total + +let guard_not_allowed + : result bool + = fun ctx -> Success (ctx.no_guard, None) + +let unfolding_ok + : result bool + = fun ctx -> Success (ctx.unfolding_ok, None) + +let debug g f = + if !dbg + then f () + +instance showable_side = { + show = (function + | Left -> "Left" + | Right -> "Right" + | Both -> "Both" + | Neither -> "Neither"); +} + +let boolean_negation_simp b = + if Hash.equal_term b U.exp_false_bool + then None + else Some (U.mk_boolean_negation b) + +let combine_path_and_branch_condition (path_condition:term) + (branch_condition:option term) + (branch_equality:term) + : term & term + = let this_path_condition = + let bc = + match branch_condition with + | None -> branch_equality + | Some bc -> U.mk_conj_l [U.b2t bc; branch_equality] + in + U.mk_conj (U.b2t path_condition) bc + in + let next_path_condition = + match branch_condition with + | None -> U.exp_false_bool + | Some bc -> + if Hash.equal_term path_condition U.exp_true_bool + then U.mk_boolean_negation bc + else U.mk_and path_condition (U.mk_boolean_negation bc) + in + this_path_condition, //:Type + next_path_condition //:bool + +let maybe_relate_after_unfolding (g:Env.env) t0 t1 : side = + let dd0 = Env.delta_depth_of_term g t0 in + let dd1 = Env.delta_depth_of_term g t1 in + + if dd0 = dd1 then + Both + else if Common.delta_depth_greater_than dd0 dd1 then + Left + else + Right + +(* + G |- e : t0 <: t1 | p + +or G |- t0 <: t1 | p + + *) +let rec check_relation (g:env) (rel:relation) (t0 t1:typ) + : result unit + = let err () = + match rel with + | EQUALITY -> + fail (BU.format2 "not equal terms: %s <> %s" + (show t0) + (show t1)) + | _ -> + fail (BU.format2 "%s is not a subtype of %s" + (show t0) + (show t1)) + in + let rel_to_string rel = + match rel with + | EQUALITY -> "=?=" + | SUBTYPING _ -> "<:?" + in + if !dbg + then BU.print5 "check_relation (%s) %s %s (%s) %s\n" + (tag_of t0) + (show t0) + (rel_to_string rel) + (tag_of t1) + (show t1); + let! guard_not_ok = guard_not_allowed in + let guard_ok = not guard_not_ok in + let head_matches t0 t1 + : bool + = let head0 = U.leftmost_head t0 in + let head1 = U.leftmost_head t1 in + match (U.un_uinst head0).n, (U.un_uinst head1).n with + | Tm_fvar fv0, Tm_fvar fv1 -> fv_eq fv0 fv1 + | Tm_name x0, Tm_name x1 -> bv_eq x0 x1 + | Tm_constant c0, Tm_constant c1 -> equal_term head0 head1 + | Tm_type _, Tm_type _ + | Tm_arrow _, Tm_arrow _ + | Tm_match _, Tm_match _ -> true + | _ -> false + in + let which_side_to_unfold t0 t1 = + maybe_relate_after_unfolding g.tcenv t0 t1 in + let maybe_unfold_side side t0 t1 + : option (term & term) + = Profiling.profile (fun _ -> + match side with + | Neither -> None + | Both -> ( + match N.maybe_unfold_head g.tcenv t0, + N.maybe_unfold_head g.tcenv t1 + with + | Some t0, Some t1 -> Some (t0, t1) + | Some t0, None -> Some (t0, t1) + | None, Some t1 -> Some (t0, t1) + | _ -> None + ) + | Left -> ( + match N.maybe_unfold_head g.tcenv t0 with + | Some t0 -> Some (t0, t1) + | _ -> None + ) + | Right -> ( + match N.maybe_unfold_head g.tcenv t1 with + | Some t1 -> Some (t0, t1) + | _ -> None + )) + None + "FStarC.TypeChecker.Core.maybe_unfold_side" + in + let maybe_unfold t0 t1 + : result (option (term & term)) + = if! unfolding_ok + then return (maybe_unfold_side (which_side_to_unfold t0 t1) t0 t1) + else return None + in + let emit_guard t0 t1 = + let! _, t_typ = with_context "checking lhs while emitting guard" None (fun _ -> do_check g t0) in + let! u = universe_of g t_typ in + guard (U.mk_eq2 u t_typ t0 t1) + in + let fallback t0 t1 = + if guard_ok + then if equatable g t0 + || equatable g t1 + then emit_guard t0 t1 + else err () + else err () + in + let maybe_unfold_side_and_retry side t0 t1 = + if! unfolding_ok then + match maybe_unfold_side side t0 t1 with + | None -> fallback t0 t1 + | Some (t0, t1) -> check_relation g rel t0 t1 + else + fallback t0 t1 + in + let maybe_unfold_and_retry t0 t1 = + maybe_unfold_side_and_retry (which_side_to_unfold t0 t1) t0 t1 + in + let beta_iota_reduce t = + let t = Subst.compress t in + let t = N.normalize [Env.HNF; Env.Weak; Env.Beta; Env.Iota; Env.Primops] g.tcenv t in + match t.n with + | Tm_refine _ -> + U.flatten_refinement t + | _ -> t + in + let beta_iota_reduce t = + Profiling.profile + (fun () -> beta_iota_reduce t) + None + "FStarC.TypeChecker.Core.beta_iota_reduce" + in + let t0 = Subst.compress (beta_iota_reduce t0) |> U.unlazy_emb in + let t1 = Subst.compress (beta_iota_reduce t1) |> U.unlazy_emb in + let check_relation g rel t0 t1 = + with_context "check_relation" (Some (CtxRel t0 rel t1)) + (fun _ -> check_relation g rel t0 t1) + in + if equal_term t0 t1 then return () + else + match t0.n, t1.n with + | Tm_type u0, Tm_type u1 -> + // when g.allow_universe_instantiation -> + // See above remark regarding universe instantiations + if Rel.teq_nosmt_force g.tcenv t0 t1 + then return () + else err () + + | Tm_meta {tm=t0; meta=Meta_pattern _}, _ + | Tm_meta {tm=t0; meta=Meta_named _}, _ + | Tm_meta {tm=t0; meta=Meta_labeled _}, _ + | Tm_meta {tm=t0; meta=Meta_desugared _}, _ + | Tm_ascribed {tm=t0}, _ -> + check_relation g rel t0 t1 + + | _, Tm_meta {tm=t1; meta=Meta_pattern _} + | _, Tm_meta {tm=t1; meta=Meta_named _} + | _, Tm_meta {tm=t1; meta=Meta_labeled _} + | _, Tm_meta {tm=t1; meta=Meta_desugared _} + | _, Tm_ascribed {tm=t1} -> + check_relation g rel t0 t1 + + | Tm_uinst (f0, us0), Tm_uinst(f1, us1) -> + if equal_term f0 f1 + then ( //heads are equal, equate universes + if Rel.teq_nosmt_force g.tcenv t0 t1 + then return () + else err () + ) + else maybe_unfold_and_retry t0 t1 + + | Tm_fvar _, Tm_fvar _ -> + maybe_unfold_and_retry t0 t1 + + + | Tm_refine {b=x0; phi=f0}, Tm_refine {b=x1; phi=f1} -> + if head_matches x0.sort x1.sort + then ( + check_relation g EQUALITY x0.sort x1.sort ;! + let! u = universe_of g x0.sort in + let g, b, f0 = open_term g (S.mk_binder x0) f0 in + let f1 = Subst.subst [DB(0, b.binder_bv)] f1 in + (match! guard_not_allowed with + | true -> + with_binders [b] [u] + (check_relation g EQUALITY f0 f1) + + | _ -> + match rel with + | EQUALITY -> + with_binders [b] [u] + (handle_with + (check_relation g EQUALITY f0 f1) + (fun _ -> guard (U.mk_iff f0 f1))) + + | SUBTYPING (Some tm) -> + guard (Subst.subst [NT(b.binder_bv, tm)] (U.mk_imp f0 f1)) + + | SUBTYPING None -> + guard (U.mk_forall u b.binder_bv (U.mk_imp f0 f1))) + ) + else ( + match! maybe_unfold x0.sort x1.sort with + | None -> + if !dbg then + BU.print2 "Cannot match ref heads %s and %s\n" (show x0.sort) (show x1.sort); + fallback t0 t1 + | Some (t0, t1) -> + let lhs = S.mk (Tm_refine {b={x0 with sort = t0}; phi=f0}) t0.pos in + let rhs = S.mk (Tm_refine {b={x1 with sort = t1}; phi=f1}) t1.pos in + check_relation g rel (U.flatten_refinement lhs) (U.flatten_refinement rhs) + ) + + | Tm_refine {b=x0; phi=f0}, _ -> + if head_matches x0.sort t1 + then ( + (* For subtyping, we just check that x0.sort <: t1. But for equality, + we must show that the refinement on the LHS is constantly true. *) + if rel = EQUALITY then ( + let! u0 = universe_of g x0.sort in + let g, b0, f0 = open_term g (S.mk_binder x0) f0 in + if! guard_not_allowed then + with_binders [b0] [u0] + (check_relation g EQUALITY U.t_true f0) + else ( + with_binders [b0] [u0] + (handle_with + (check_relation g EQUALITY U.t_true f0) + (fun _ -> guard f0)) + ) + ) else return ();! + check_relation g rel x0.sort t1 + ) + else ( + match! maybe_unfold x0.sort t1 with + | None -> fallback t0 t1 + | Some (t0, t1) -> + let lhs = S.mk (Tm_refine {b={x0 with sort = t0}; phi=f0}) t0.pos in + check_relation g rel (U.flatten_refinement lhs) t1 + ) + + | _, Tm_refine {b=x1; phi=f1} -> + if head_matches t0 x1.sort + then ( + let! u1 = universe_of g x1.sort in + check_relation g EQUALITY t0 x1.sort ;! + let g, b1, f1 = open_term g (S.mk_binder x1) f1 in + if! guard_not_allowed then + with_binders [b1] [u1] + (check_relation g EQUALITY U.t_true f1) + else ( + match rel with + | EQUALITY -> + with_binders [b1] [u1] + (handle_with + (check_relation g EQUALITY U.t_true f1) + (fun _ -> guard f1)) + + | SUBTYPING (Some tm) -> + guard (Subst.subst [NT(b1.binder_bv, tm)] f1) + + | SUBTYPING None -> + guard (U.mk_forall u1 b1.binder_bv f1) + ) + ) + else ( + match! maybe_unfold t0 x1.sort with + | None -> fallback t0 t1 + | Some (t0, t1) -> + let rhs = S.mk (Tm_refine {b={x1 with sort = t1}; phi=f1}) t1.pos in + check_relation g rel t0 (U.flatten_refinement rhs) + ) + + | Tm_uinst _, _ + | Tm_fvar _, _ + | Tm_app _, _ + | _, Tm_uinst _ + | _, Tm_fvar _ + | _, Tm_app _ -> + let head_matches = head_matches t0 t1 in + let head0, args0 = U.leftmost_head_and_args t0 in + let head1, args1 = U.leftmost_head_and_args t1 in + if not (head_matches && List.length args0 = List.length args1) + then maybe_unfold_and_retry t0 t1 + else ( + (* If we're proving equality, SMT queries are ok, and either head + is equatable: + - first try proving equality structurally, without a guard. + - if that fails, then emit an SMT query + This is designed to be able to prove things like `v.v1 == u.v1` + first by trying to unify `v` and `u` and if it fails + then prove `v.v1 == u.v1` *) + let compare_head_and_args () = + handle_with + (check_relation g EQUALITY head0 head1 ;! + check_relation_args g EQUALITY args0 args1) + (fun _ -> maybe_unfold_side_and_retry Both t0 t1) + in + if guard_ok && + (rel=EQUALITY) && + (equatable g t0 || equatable g t1) + then ( + handle_with + (no_guard (compare_head_and_args ())) + (fun _ -> emit_guard t0 t1) + ) + else compare_head_and_args () + ) + + | Tm_abs {bs=b0::b1::bs; body; rc_opt=ropt}, _ -> + let t0 = curry_abs b0 b1 bs body ropt in + check_relation g rel t0 t1 + + | _, Tm_abs {bs=b0::b1::bs; body; rc_opt=ropt} -> + let t1 = curry_abs b0 b1 bs body ropt in + check_relation g rel t0 t1 + + | Tm_abs {bs=[b0]; body=body0}, Tm_abs {bs=[b1]; body=body1} -> + check_relation g EQUALITY b0.binder_bv.sort b1.binder_bv.sort;! + check_bqual b0.binder_qual b1.binder_qual;! + check_positivity_qual EQUALITY b0.binder_positivity b1.binder_positivity;! + let! u = universe_of g b0.binder_bv.sort in + let g, b0, body0 = open_term g b0 body0 in + let body1 = Subst.subst [DB(0, b0.binder_bv)] body1 in + with_binders [b0] [u] + (check_relation g EQUALITY body0 body1) + + | Tm_arrow {bs=x0::x1::xs; comp=c0}, _ -> + check_relation g rel (curry_arrow x0 (x1::xs) c0) t1 + + | _, Tm_arrow {bs=x0::x1::xs; comp=c1} -> + check_relation g rel t0 (curry_arrow x0 (x1::xs) c1) + + | Tm_arrow {bs=[x0]; comp=c0}, Tm_arrow {bs=[x1]; comp=c1} -> + with_context "subtype arrow" None (fun _ -> + let! _ = check_bqual x0.binder_qual x1.binder_qual in + check_positivity_qual rel x0.binder_positivity x1.binder_positivity;! + let! u1 = universe_of g x1.binder_bv.sort in + let g_x1, x1, c1 = open_comp g x1 c1 in + let c0 = Subst.subst_comp [DB(0, x1.binder_bv)] c0 in + with_binders [x1] [u1] ( + let rel_arg = + match rel with + | EQUALITY -> EQUALITY + | _ -> SUBTYPING (Some (S.bv_to_name x1.binder_bv)) + in + let rel_comp = + match rel with + | EQUALITY -> EQUALITY + | SUBTYPING e -> + SUBTYPING + (if U.is_pure_or_ghost_comp c0 + then let? e in Some (S.mk_Tm_app e (snd (U.args_of_binders [x1])) R.dummyRange) + else None) + in + check_relation g rel x1.binder_bv.sort x0.binder_bv.sort ;! + with_context "check_subcomp" None (fun _ -> + check_relation_comp g_x1 rel_comp c0 c1 + ) + ) + ) + + | Tm_match {scrutinee=e0;brs=brs0}, Tm_match {scrutinee=e1;brs=brs1} -> + let relate_branch br0 br1 (_:unit) + : result unit + = match br0, br1 with + | (p0, None, body0), (p1, None, body1) -> + if not (S.eq_pat p0 p1) + then fail "patterns not equal" + else begin + let g', (p0, _, body0), (p1, _, body1) = open_branches_eq_pat g (p0, None, body0) (p1, None, body1) in + match PatternUtils.raw_pat_as_exp g.tcenv p0 with + | Some (_, bvs0) -> + let bs0 = List.map S.mk_binder bvs0 in + // We need universes for the binders + let! us = check_binders g bs0 in + with_context "relate_branch" None (fun _ -> with_binders bs0 us (check_relation g' rel body0 body1)) + | _ -> fail "raw_pat_as_exp failed in check_equality match rule" + end + | _ -> fail "Core does not support branches with when" + in + handle_with + (check_relation g EQUALITY e0 e1 ;! + iter2 brs0 brs1 relate_branch ()) + (fun _ -> fallback t0 t1) + + | _ -> fallback t0 t1 + +and check_relation_args (g:env) rel (a0 a1:args) + : result unit + = if List.length a0 = List.length a1 + then iter2 a0 a1 + (fun (t0, q0) (t1, q1) _ -> + check_aqual q0 q1;! + check_relation g rel t0 t1) + () + else fail "Unequal number of arguments" + +and check_relation_comp (g:env) rel (c0 c1:comp) + : result unit + = let destruct_comp c = + if U.is_total_comp c + then Some (E_Total, U.comp_result c) + else if U.is_tot_or_gtot_comp c + then Some (E_Ghost, U.comp_result c) + else None + in + match destruct_comp c0, destruct_comp c1 with + | None, _ + | _, None -> + if TEQ.eq_comp g.tcenv c0 c1 = TEQ.Equal + then return () + else ( + let ct_eq res0 args0 res1 args1 = + check_relation g EQUALITY res0 res1 ;! + check_relation_args g EQUALITY args0 args1 + in + let eff0, res0, args0 = U.comp_eff_name_res_and_args c0 in + let eff1, res1, args1 = U.comp_eff_name_res_and_args c1 in + if I.lid_equals eff0 eff1 + then ct_eq res0 args0 res1 args1 + else ( + let ct0 = Env.unfold_effect_abbrev g.tcenv c0 in + let ct1 = Env.unfold_effect_abbrev g.tcenv c1 in + if I.lid_equals ct0.effect_name ct1.effect_name + then ct_eq ct0.result_typ ct0.effect_args ct1.result_typ ct1.effect_args + else fail (BU.format2 "Subcomp failed: Unequal computation types %s and %s" + (Ident.string_of_lid ct0.effect_name) + (Ident.string_of_lid ct1.effect_name)) + ) + ) + + | Some (E_Total, t0), Some (_, t1) // why is this right? what about EQUALITY? + | Some (E_Ghost, t0), Some (E_Ghost, t1) -> + check_relation g rel t0 t1 + + | Some (E_Ghost, t0), Some (E_Total, t1) -> + if non_informative g t1 + then check_relation g rel t0 t1 + else fail "Expected a Total computation, but got Ghost" + + +and check_subtype (g:env) (e:option term) (t0 t1:typ) + = fun ctx -> + Profiling.profile + (fun () -> + let rel = SUBTYPING e in + with_context (if ctx.no_guard then "check_subtype(no_guard)" else "check_subtype") + (Some (CtxRel t0 rel t1)) + (fun _ -> check_relation g rel t0 t1) + ctx) + None + "FStarC.TypeChecker.Core.check_subtype" + +and memo_check (g:env) (e:term) + : result (tot_or_ghost & typ) + = let check_then_memo g e ctx = + let r = do_check_and_promote g e ctx in + match r with + | Success (res, None) -> + insert g e (res, None); + r + + | Success (res, Some guard) -> + (match g.guard_handler with + | None -> insert g e (res, Some guard); r + | Some gh -> + if gh g.tcenv guard + then let r = (res, None) in + insert g e r; Success r + else fail "guard handler failed" ctx) + + | _ -> r + in + fun ctx -> + if not g.should_read_cache + then check_then_memo g e ctx + else ( + match lookup g e ctx with + | Error _ -> //cache miss; check and insert + check_then_memo g e ctx + + | Success (et, None) -> //cache hit with no guard; great, just return + Success (et, None) + + | Success (et, Some pre) -> //cache hit with a guard + match g.guard_handler with + | None -> Success (et, Some pre) //if there's no guard handler, then just return + | Some _ -> + //otherwise check then memo, since this can + //repopulate the cache with a "better" entry that has no guard + //But, don't read the cache again, since many subsequent lookups + //are likely to be hits with a guard again + check_then_memo { g with should_read_cache = false } e ctx + ) + +and check (msg:string) (g:env) (e:term) + : result (tot_or_ghost & typ) + = with_context msg (Some (CtxTerm e)) (fun _ -> memo_check g e) + +and do_check_and_promote (g:env) (e:term) + : result (tot_or_ghost & typ) + = let! (eff, t) = do_check g e in + let eff = + match eff with + | E_Total -> E_Total + | E_Ghost -> if non_informative g t then E_Total else E_Ghost in + return (eff, t) + +(* G |- e : Tot t | pre *) +and do_check (g:env) (e:term) + : result (tot_or_ghost & typ) = + let e = Subst.compress e in + match e.n with + | Tm_lazy ({lkind=Lazy_embedding _}) -> + do_check g (U.unlazy e) + + | Tm_lazy i -> + return (E_Total, i.ltyp) + + | Tm_meta {tm=t} -> + memo_check g t + + | Tm_uvar (uv, s) -> + return (E_Total, Subst.subst' s (U.ctx_uvar_typ uv)) + + | Tm_name x -> + begin + match Env.try_lookup_bv g.tcenv x with + | None -> + fail (BU.format1 "Variable not found: %s" (show x)) + | Some (t, _) -> + return (E_Total, t) + end + + | Tm_fvar f -> + begin + match Env.try_lookup_lid g.tcenv f.fv_name.v with + | Some (([], t), _) -> + return (E_Total, t) + + | _ -> //no implicit universe instantiation allowed + fail "Missing universes instantiation" + end + + | Tm_uinst ({n=Tm_fvar f}, us) -> + begin + match Env.try_lookup_and_inst_lid g.tcenv us f.fv_name.v with + | None -> + fail (BU.format1 "Top-level name not found: %s" (Ident.string_of_lid f.fv_name.v)) + + | Some (t, _) -> + return (E_Total, t) + end + + | Tm_constant c -> + begin + let open FStarC.Const in + match c with + | Const_range_of + | Const_set_range_of + | Const_reify _ + | Const_reflect _ -> + fail "Unhandled constant" + + | _ -> + let t = FStarC.TypeChecker.TcTerm.tc_constant g.tcenv e.pos c in + return (E_Total, t) + end + + | Tm_type u -> + return (E_Total, mk_type (U_succ u)) + + | Tm_refine {b=x; phi} -> + let! _, t = check "refinement head" g x.sort in + let! u = is_type g t in + let g', x, phi = open_term g (S.mk_binder x) phi in + with_binders [x] [u] ( + let! _, t' = check "refinement formula" g' phi in + is_type g' t';! + return (E_Total, t) + ) + + | Tm_abs {bs=xs; body} -> + let g', xs, body = open_term_binders g xs body in + let! us = with_context "abs binders" None (fun _ -> check_binders g xs) in + with_binders xs us ( + let! t = check "abs body" g' body in + return (E_Total, U.arrow xs (as_comp g t)) + ) + + | Tm_arrow {bs=xs; comp=c} -> + let g', xs, c = open_comp_binders g xs c in + let! us = with_context "arrow binders" None (fun _ -> check_binders g xs) in + with_binders xs us ( + let! u = with_context "arrow comp" None (fun _ -> check_comp g' c) in + return (E_Total, mk_type (S.U_max (u::us))) + ) + + | Tm_app _ -> ( + let rec check_app_arg (eff_hd, t_hd) (arg, arg_qual) = + let! x, eff_arr, t' = is_arrow g t_hd in + let! eff_arg, t_arg = check "app arg" g arg in + with_context "app subtyping" None (fun _ -> check_subtype g (Some arg) t_arg x.binder_bv.sort) ;! + with_context "app arg qual" None (fun _ -> check_arg_qual arg_qual x.binder_qual) ;! + return (join_eff eff_hd (join_eff eff_arr eff_arg), Subst.subst [NT(x.binder_bv, arg)] t') + in + let check_app hd args = + let! eff_hd, t = check "app head" g hd in + fold check_app_arg (eff_hd, t) args + in + let hd, args = U.head_and_args_full e in + match args with + | [(t1, None); (t2, None)] when TcUtil.short_circuit_head hd -> + let! eff_hd, t_hd = check "app head" g hd in + let! x, eff_arr1, s1 = is_arrow g t_hd in + let! eff_arg1, t_t1 = check "app arg" g t1 in + with_context "operator arg1" None (fun _ -> check_subtype g (Some t1) t_t1 x.binder_bv.sort) ;! + let s1 = Subst.subst [NT(x.binder_bv, t1)] s1 in + let! y, eff_arr2, s2 = is_arrow g s1 in + let guard_formula = TcUtil.short_circuit hd [(t1, None)] in + let g' = + match guard_formula with + | Common.Trivial -> g + | Common.NonTrivial gf -> push_hypothesis g gf + in + let! eff_arg2, t_t2 = weaken_with_guard_formula guard_formula (check "app arg" g' t2) in + with_context "operator arg2" None (fun _ -> check_subtype g' (Some t2) t_t2 y.binder_bv.sort) ;! + return (join_eff_l [eff_hd; eff_arr1; eff_arr2; eff_arg1; eff_arg2], + Subst.subst [NT(y.binder_bv, t2)] s2) + | _ -> check_app hd args + ) + + | Tm_ascribed {tm=e; asc=(Inl t, _, eq)} -> + let! eff, te = check "ascription head" g e in + let! _, t' = check "ascription type" g t in + is_type g t';! + with_context "ascription subtyping" None (fun _ -> check_subtype g (Some e) te t);! + return (eff, t) + + | Tm_ascribed {tm=e; asc=(Inr c, _, _)} -> + if U.is_tot_or_gtot_comp c + then ( + let! eff, te = check "ascription head" g e in + let! _ = with_context "ascription comp" None (fun _ -> check_comp g c) in + let c_e = as_comp g (eff, te) in + with_context "ascription subtyping (comp)" None (fun _ -> check_relation_comp g (SUBTYPING (Some e)) c_e c);! + let Some (eff, t) = comp_as_tot_or_ghost_and_type c in + return (eff, t) + ) + else fail (BU.format1 "Effect ascriptions are not fully handled yet: %s" (show c)) + + | Tm_let {lbs=(false, [lb]); body} -> + let Inl x = lb.lbname in + let g', x, body = open_term g (S.mk_binder x) body in + if U.is_pure_or_ghost_effect lb.lbeff + then ( + let! eff_def, tdef = check "let definition" g lb.lbdef in + let! _, ttyp = check "let type" g lb.lbtyp in + let! u = is_type g ttyp in + with_context "let subtyping" None (fun _ -> check_subtype g (Some lb.lbdef) tdef lb.lbtyp) ;! + with_definition x u lb.lbdef ( + let! eff_body, t = check "let body" g' body in + check_no_escape [x] t;! + return (join_eff eff_def eff_body, t) + ) + ) + else ( + fail (format1 "Let binding is effectful (lbeff = %s)" (show lb.lbeff)) + ) + + | Tm_match {scrutinee=sc; ret_opt=None; brs=branches; rc_opt} -> + let! eff_sc, t_sc = check "scrutinee" g sc in + let! u_sc = with_context "universe_of" (Some (CtxTerm t_sc)) (fun _ -> universe_of g t_sc) in + let rec check_branches path_condition + branch_typ_opt + branches + : result (tot_or_ghost & typ) + = match branches with + | [] -> + (match branch_typ_opt with + | None -> + fail "could not compute a type for the match" + + | Some et -> + match boolean_negation_simp path_condition with + | None -> + return et + + | Some g -> + guard (U.b2t g) ;! + return et) + + | (p, None, b) :: rest -> + let _, (p, _, b) = open_branch g (p, None, b) in + let! (bs, us) = with_context "check_pat" None (fun _ -> check_pat g p t_sc) in + let! branch_condition = pattern_branch_condition g sc p in + let pat_sc_eq = + U.mk_eq2 u_sc t_sc sc + (PatternUtils.raw_pat_as_exp g.tcenv p |> must |> fst) in + let this_path_condition, next_path_condition = + combine_path_and_branch_condition path_condition branch_condition pat_sc_eq + in + let g' = push_binders g bs in + let g' = push_hypothesis g' this_path_condition in + let! eff_br, tbr = + with_binders bs us + (weaken + this_path_condition + (let! eff_br, tbr = with_context "branch" (Some (CtxTerm b)) (fun _ -> check "branch" g' b) in + match branch_typ_opt with + | None -> + check_no_escape bs tbr;! + return (eff_br, tbr) + + | Some (acc_eff, expect_tbr) -> + with_context "check_branch_subtype" (Some (CtxRel tbr (SUBTYPING (Some b)) expect_tbr)) + (fun _ -> check_subtype g' (Some b) tbr expect_tbr) ;! + return (join_eff eff_br acc_eff, expect_tbr))) in + match p.v with + | Pat_var _ -> + //trivially exhaustive + (match rest with + | _ :: _ -> fail "Redundant branches after wildcard" + | _ -> return (eff_br, tbr)) + + | _ -> + check_branches next_path_condition (Some (eff_br, tbr)) rest + in + + let! branch_typ_opt = + match rc_opt with + | Some ({ residual_typ = Some t }) -> + with_context "residual type" (Some (CtxTerm t)) (fun _ -> universe_of g t) ;! + return (Some (E_Total, t)) + + | _ -> + return None + in + let! eff_br, t_br = + let ctx = + match branch_typ_opt with + | None -> None + | Some (_, t) -> Some (CtxTerm t) + in + with_context "check_branches" ctx + (fun _ -> check_branches U.exp_true_bool branch_typ_opt branches) + in + return (join_eff eff_sc eff_br, t_br) + + | Tm_match {scrutinee=sc; ret_opt=Some (as_x, (Inl returns_ty, None, eq)); brs=branches; rc_opt} -> + let! eff_sc, t_sc = check "scrutinee" g sc in + let! u_sc = with_context "universe_of" (Some (CtxTerm t_sc)) (fun _ -> universe_of g t_sc) in + let as_x = {as_x with binder_bv = { as_x.binder_bv with sort = t_sc } } in + let g_as_x, as_x, returns_ty = open_term g as_x returns_ty in + let! _eff_t, returns_ty_t = + with_binders [as_x] [u_sc] (check "return type" g_as_x returns_ty) in + let! _u_ty = is_type g_as_x returns_ty_t in + let rec check_branches (path_condition: S.term) + (branches: list S.branch) + (acc_eff: tot_or_ghost) + : result tot_or_ghost + = match branches with + | [] -> + (match boolean_negation_simp path_condition with + | None -> + return acc_eff + + | Some g -> + guard (U.b2t g) ;! + return acc_eff) + + | (p, None, b) :: rest -> + let _, (p, _, b) = open_branch g (p, None, b) in + let! (bs, us) = with_context "check_pat" None (fun _ -> check_pat g p t_sc) in + let! branch_condition = pattern_branch_condition g sc p in + let pat_sc_eq = + U.mk_eq2 u_sc t_sc sc + (PatternUtils.raw_pat_as_exp g.tcenv p |> must |> fst) in + let this_path_condition, next_path_condition = + combine_path_and_branch_condition path_condition branch_condition pat_sc_eq + in + let g' = push_binders g bs in + let g' = push_hypothesis g' this_path_condition in + let! eff_br, tbr = + with_binders bs us + (weaken + this_path_condition + (let! eff_br, tbr = check "branch" g' b in + let expect_tbr = Subst.subst [NT(as_x.binder_bv, sc)] returns_ty in + let rel = + if eq + then EQUALITY + else SUBTYPING (Some b) + in + with_context "branch check relation" None (fun _ -> check_relation g' rel tbr expect_tbr);! + return (join_eff eff_br acc_eff, expect_tbr))) in + match p.v with + | Pat_var _ -> + //trivially exhaustive + (match rest with + | _ :: _ -> fail "Redundant branches after wildcard" + | _ -> return eff_br) + + | _ -> + check_branches next_path_condition rest eff_br in + + let! eff = check_branches U.exp_true_bool branches E_Total in + let ty = Subst.subst [NT(as_x.binder_bv, sc)] returns_ty in + return (eff, ty) + + | Tm_match _ -> + fail "Match with effect returns ascription, or tactic handler" + + | _ -> + fail (BU.format1 "Unexpected term: %s" (tag_of e)) + +and check_binders (g_initial:env) (xs:binders) + : result (list universe) + = let rec aux g xs = + match xs with + | [] -> + return [] + + | x ::xs -> + let! _, t = check "binder sort" g x.binder_bv.sort in + let! u = is_type g t in + with_binders [x] [u] ( + let! us = aux (push_binder g x) xs in + return (u::us) + ) + in + aux g_initial xs + +// +// May be called with an effectful comp type, e.g. from within an arrow +// Caller should enforce Tot/GTot if needed +// +and check_comp (g:env) (c:comp) + : result universe + = match c.n with + | Total t + | GTotal t -> + let! _, t = check "(G)Tot comp result" g (U.comp_result c) in + is_type g t + | Comp ct -> + if List.length ct.comp_univs <> 1 + then fail "Unexpected/missing universe instantitation in comp" + else let u = List.hd ct.comp_univs in + let effect_app_tm = + let head = S.mk_Tm_uinst (S.fvar ct.effect_name None) [u] in + S.mk_Tm_app head ((as_arg ct.result_typ)::ct.effect_args) ct.result_typ.pos in + let! _, t = check "effectful comp" g effect_app_tm in + with_context "comp fully applied" None (fun _ -> check_subtype g None t S.teff);! + let c_lid = Env.norm_eff_name g.tcenv ct.effect_name in + let is_total = Env.lookup_effect_quals g.tcenv c_lid |> List.existsb (fun q -> q = S.TotalEffect) in + if not is_total + then return S.U_zero //if it is a non-total effect then u0 + else if U.is_pure_or_ghost_effect c_lid + then return u + else ( + match Env.effect_repr g.tcenv c u with + | None -> fail (BU.format2 "Total effect %s (normalized to %s) does not have a representation" + (Ident.string_of_lid (U.comp_effect_name c)) + (Ident.string_of_lid c_lid)) + | Some tm -> universe_of g tm + ) + +and universe_of (g:env) (t:typ) + : result universe + = let! _, t = check "universe of" g t in + is_type g t + +and check_pat (g:env) (p:pat) (t_sc:typ) : result (binders & universes) = + let unrefine_tsc t_sc = + t_sc |> N.normalize_refinement N.whnf_steps g.tcenv + |> U.unrefine in + + match p.v with + | Pat_constant c -> + let e = + match c with + | FStarC.Const.Const_int(repr, Some sw) -> + FStarC.ToSyntax.ToSyntax.desugar_machine_integer g.tcenv.dsenv repr sw p.p + | _ -> + mk (Tm_constant c) p.p in + let! _, t_const = check "pat_const" g e in + let! _ = with_context "check_pat constant" None (fun () -> check_subtype g (Some e) t_const (unrefine_tsc t_sc)) in + return ([], []) + + | Pat_var bv -> + let b = S.mk_binder {bv with sort=t_sc} in + let! [u] = with_context "check_pat_binder" None (fun _ -> check_binders g [b]) in + return ([b], [u]) + + | Pat_cons (fv, usopt, pats) -> + let us = if is_none usopt then [] else usopt |> must in + + let formals, t_pat = + Env.lookup_and_inst_datacon g.tcenv us (S.lid_of_fv fv) + |> U.arrow_formals in + + let dot_pats, rest_pats = + let pats = pats |> List.map fst in + pats |> BU.prefix_until (fun p -> match p.v with + | Pat_dot_term _ -> false + | _ -> true) + |> BU.map_option (fun (dot_pats, pat, rest_pats) -> + dot_pats, (pat::rest_pats)) + |> BU.dflt (pats, []) in + + let dot_formals, rest_formals = List.splitAt (List.length dot_pats) formals in + + let! ss = fold2 (fun ss {binder_bv=f} p -> + let expected_t = Subst.subst ss f.sort in + let! pat_dot_t = + match p.v with + | Pat_dot_term (Some t) -> return t + | _ -> fail "check_pat in core has unset dot pattern" in + + let! _, p_t = check "pat dot term" g pat_dot_t in + let!_ = with_context "check_pat cons" None (fun _ -> check_subtype g (Some pat_dot_t) p_t expected_t) in + + return (ss@[NT (f, pat_dot_t)])) [] dot_formals dot_pats in + + let! _, ss, bs, us = fold2 (fun (g, ss, bs, us) {binder_bv=f} p -> + let expected_t = Subst.subst ss f.sort in + let! (bs_p, us_p) = with_binders bs us (check_pat g p expected_t) in + let p_e = PatternUtils.raw_pat_as_exp g.tcenv p |> must |> fst in + return (push_binders g bs_p, + ss@[NT (f, p_e)], + bs@bs_p, + us@us_p)) (g, ss, [], []) rest_formals rest_pats in + + let t_pat = Subst.subst ss t_pat in + + let!_ = no_guard (check_scrutinee_pattern_type_compatible g (unrefine_tsc t_sc) t_pat) in + + return (bs, us) + + | _ -> fail "check_pat called with a dot pattern" + +and check_scrutinee_pattern_type_compatible (g:env) (t_sc t_pat:typ) + : result precondition + = let open Env in + let err (s:string) = + fail (BU.format3 "Scrutinee type %s and Pattern type %s are not compatible because %s" + (show t_sc) + (show t_pat) + s) in + + let head_sc, args_sc = U.head_and_args t_sc in + let head_pat, args_pat = U.head_and_args t_pat in + + let! (t_fv:fv) = + match (Subst.compress head_sc).n, (Subst.compress head_pat).n with + | Tm_fvar (fv_head), Tm_fvar (fv_pat) + when Ident.lid_equals (lid_of_fv fv_head) (lid_of_fv fv_pat) -> return fv_head + | Tm_uinst ({n=Tm_fvar (fv_head)}, us_head), Tm_uinst ({n=Tm_fvar (fv_pat)}, us_pat) + when Ident.lid_equals (lid_of_fv fv_head) (lid_of_fv fv_pat) -> + if Rel.teq_nosmt_force g.tcenv head_sc head_pat + then return fv_head + else err "Incompatible universe instantiations" + | _, _ -> err (BU.format2 "Head constructors(%s and %s) not fvar" + (tag_of head_sc) + (tag_of head_pat)) in + + (if Env.is_type_constructor g.tcenv (lid_of_fv t_fv) + then return t_fv + else err (BU.format1 "%s is not a type constructor" (show t_fv)));! + + (if List.length args_sc = List.length args_pat then return t_fv + else err (BU.format2 "Number of arguments don't match (%s and %s)" + (string_of_int (List.length args_sc)) + (string_of_int (List.length args_pat))));! + + let params_sc, params_pat = + match Env.num_inductive_ty_params g.tcenv (S.lid_of_fv t_fv) with + | None -> args_sc, args_pat + | Some n -> fst (BU.first_N n args_sc), fst (BU.first_N n args_pat) in + + iter2 params_sc params_pat (fun (t_sc, _) (t_pat, _) _ -> + check_relation g EQUALITY t_sc t_pat) () ;! + + // TODO: return equality of indices for the caller to weaken the guard with? + + return None + +and pattern_branch_condition (g:env) + (scrutinee:term) + (pat:pat) + : result (option term) + = match pat.v with + | Pat_var _ -> + return None + | Pat_constant c -> + let const_exp = + match PatternUtils.raw_pat_as_exp g.tcenv pat with + | None -> failwith "Impossible" + | Some (e, _) -> e + in + let! _, t_const = check "constant pattern" g const_exp in + return (Some (U.mk_decidable_eq t_const scrutinee const_exp)) + + | Pat_cons(fv, us_opt, sub_pats) -> + let wild_pat pos = S.withinfo (Pat_var (S.new_bv None S.tun)) pos in + let mk_head_discriminator () = + let pat = S.withinfo (Pat_cons(fv, us_opt, List.map (fun (s, b) -> wild_pat s.p, b) sub_pats)) pat.p in + let branch1 = (pat, None, U.exp_true_bool) in + let branch2 = (S.withinfo (Pat_var (S.new_bv None S.tun)) pat.p, None, U.exp_false_bool) in + S.mk (Tm_match {scrutinee; ret_opt=None; brs=[branch1; branch2]; rc_opt=None}) scrutinee.pos + in + let mk_ith_projector i = + let ith_pat_var, ith_pat = + let bv = S.new_bv None S.tun in + bv, S.withinfo (Pat_var bv) scrutinee.pos + in + let sub_pats = List.mapi (fun j (s,b) -> if i <> j then wild_pat s.p,b else ith_pat,b) sub_pats in + let pat = S.withinfo (Pat_cons(fv, us_opt, sub_pats)) pat.p in + let branch = S.bv_to_name ith_pat_var in + let eqn = Subst.close_branch (pat, None, branch) in + S.mk (Tm_match {scrutinee; ret_opt=None; brs=[eqn]; rc_opt=None}) scrutinee.pos + in + let discrimination = + let is_induc, datacons = Env.datacons_of_typ g.tcenv (Env.typ_of_datacon g.tcenv fv.fv_name.v) in + (* Why the `not is_induc`? We may be checking an exception pattern. See issue #1535. *) + if not is_induc || List.length datacons > 1 + then let discriminator = U.mk_discriminator fv.fv_name.v in + match Env.try_lookup_lid g.tcenv discriminator with + | None -> + // We don't use the discriminator if we are typechecking it + None + | _ -> + Some (mk_head_discriminator()) + else None //single constructor inductives do not need a discriminator + in + let! sub_term_guards = + mapi + (fun i (pi, _) -> + match pi.v with + | Pat_dot_term _ + | Pat_var _ -> + return None + | _ -> + let scrutinee_sub_term = mk_ith_projector i in + pattern_branch_condition g (mk_ith_projector i) pi) + sub_pats + in + let guards = List.collect (function None -> [] | Some t -> [t]) (discrimination :: sub_term_guards) in + match guards with + | [] -> return None + | guards -> return (Some (U.mk_and_l guards)) + +let initial_env g gh = + let max_index = + List.fold_left + (fun index b -> + match b with + | Binding_var x -> + if x.index > index + then x.index + else index + | _ -> index) + 0 g.Env.gamma + in + { tcenv = g; + allow_universe_instantiation = false; + max_binder_index = max_index; + guard_handler = gh; + should_read_cache = true } + +// +// In case the expected type and effect are set, +// they are returned as is +// +let check_term_top g e topt (must_tot:bool) (gh:option guard_handler_t) + : result (tot_or_ghost & typ) + = let g = initial_env g gh in + let! eff_te = check "top" g e in + match topt with + | None -> + // check expected effect + if must_tot + then let eff, t = eff_te in + if eff = E_Ghost && + not (non_informative g t) + then fail "expected total effect, found ghost" + else return (E_Total, t) + else return eff_te + | Some t -> + let target_comp, eff = + if must_tot || fst eff_te = E_Total + then S.mk_Total t, E_Total + else S.mk_GTotal t, E_Ghost + in + with_context "top-level subtyping" None (fun _ -> + check_relation_comp + ({ g with allow_universe_instantiation = true}) + (SUBTYPING (Some e)) + (as_comp g eff_te) + target_comp) ;! + return (eff, t) + +let simplify_steps = + [Env.Beta; + Env.UnfoldUntil delta_constant; + Env.UnfoldQual ["unfold"]; + Env.UnfoldOnly [PC.pure_wp_monotonic_lid; PC.pure_wp_monotonic0_lid]; + Env.Simplify; + Env.Primops; + Env.NoFullNorm] + + +let check_term_top_gh g e topt (must_tot:bool) (gh:option guard_handler_t) + : __result ((tot_or_ghost & S.typ) & precondition) + = if !dbg_Eq + then BU.print1 "(%s) Entering core ... \n" + (show (get_goal_ctr())); + + if !dbg || !dbg_Top + then BU.print3 "(%s) Entering core with %s <: %s\n" + (show (get_goal_ctr())) (show e) (show topt); + THT.reset_counters table; + reset_cache_stats(); + let ctx = { unfolding_ok = true; no_guard = false; error_context = [("Top", None)] } in + let res = + Profiling.profile + (fun () -> + match check_term_top g e topt must_tot gh ctx with + | Success (et, g) -> Success (et, g) + | Error err -> Error err) + None + "FStarC.TypeChecker.Core.check_term_top" + in + ( + let res = + match res with + | Success (et, Some guard0) -> + // Options.push(); + // Options.set_option "debug" (Options.List [Options.String "Unfolding"]); + let guard = N.normalize simplify_steps g guard0 in + // Options.pop(); + if !dbg || !dbg_Top || !dbg_Exit + then begin + BU.print3 "(%s) Exiting core: Simplified guard from {{%s}} to {{%s}}\n" + (BU.string_of_int (get_goal_ctr())) + (show guard0) + (show guard); + let guard_names = Syntax.Free.names guard |> elems in + match List.tryFind (fun bv -> List.for_all (fun binding_env -> + match binding_env with + | Binding_var bv_env -> not (S.bv_eq bv_env bv) + | _ -> true) g.gamma) guard_names with + | Some bv -> + BU.print1 "WARNING: %s is free in the core generated guard\n" (show (S.bv_to_name bv)) + | _ -> () + end; + Success (et, Some guard) + + | Success _ -> + if !dbg || !dbg_Top + then BU.print1 "(%s) Exiting core (ok)\n" + (BU.string_of_int (get_goal_ctr())); + res + + | Error _ -> + if !dbg || !dbg_Top + then BU.print1 "(%s) Exiting core (failed)\n" + (BU.string_of_int (get_goal_ctr())); + res + in + if !dbg_Eq + then ( + THT.print_stats table; + let cs = report_cache_stats() in + BU.print2 "Cache_stats { hits = %s; misses = %s }\n" + (BU.string_of_int cs.hits) + (BU.string_of_int cs.misses) + ); + res + ) + +let check_term g e t must_tot = + match check_term_top_gh g e (Some t) must_tot None with + | Success (_, g) -> Inl g + | Error err -> Inr err + +let check_term_at_type g e t = + let must_tot = false in + match check_term_top_gh g e (Some t) must_tot None with + | Success ((eff, _), g) -> Inl (eff, g) + | Error err -> Inr err + +let compute_term_type_handle_guards g e gh = + let e = FStarC.Syntax.Compress.deep_compress true true e in + let must_tot = false in + match check_term_top_gh g e None must_tot (Some gh) with + | Success (r, None) -> Inl r + | Success (_, Some _) -> failwith "Impossible: All guards should have been handled already" + | Error err -> Inr err + +let open_binders_in_term (env:Env.env) (bs:binders) (t:term) = + let g = initial_env env None in + let g', bs, t = open_term_binders g bs t in + g'.tcenv, bs, t + +let open_binders_in_comp (env:Env.env) (bs:binders) (c:comp) = + let g = initial_env env None in + let g', bs, c = open_comp_binders g bs c in + g'.tcenv, bs, c + +let check_term_equality guard_ok unfolding_ok g t0 t1 + = let g = initial_env g None in + if !dbg_Top then + BU.print4 "Entering check_term_equality with %s and %s (guard_ok=%s; unfolding_ok=%s) {\n" + (show t0) (show t1) (show guard_ok) (show unfolding_ok); + let ctx = { unfolding_ok = unfolding_ok; no_guard = not guard_ok; error_context = [("Eq", None)] } in + let r = check_relation g EQUALITY t0 t1 ctx in + if !dbg_Top then + BU.print3 "} Exiting check_term_equality (%s, %s). Result = %s.\n" (show t0) (show t1) (show r); + let r = + match r with + | Success (_, g) -> Inl g + | Error err -> Inr err + in + r + +let check_term_subtyping guard_ok unfolding_ok g t0 t1 + = let g = initial_env g None in + let ctx = { unfolding_ok = unfolding_ok; no_guard = not guard_ok; error_context = [("Subtyping", None)] } in + match check_relation g (SUBTYPING None) t0 t1 ctx with + | Success (_, g) -> Inl g + | Error err -> Inr err diff --git a/src/typechecker/FStarC.TypeChecker.Core.fsti b/src/typechecker/FStarC.TypeChecker.Core.fsti new file mode 100644 index 00000000000..70864d3129a --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Core.fsti @@ -0,0 +1,62 @@ +module FStarC.TypeChecker.Core +open FStarC +open FStarC.Compiler.Util +open FStarC.Syntax.Syntax +open FStarC.TypeChecker.Common +module Env = FStarC.TypeChecker.Env +module S = FStarC.Syntax.Syntax +module R = FStarC.Compiler.Range +module U = FStarC.Syntax.Util + +type tot_or_ghost = + | E_Total + | E_Ghost + +val clear_memo_table (_:unit) + : unit + +val error : Type0 + +type side = + | Left + | Right + | Both + | Neither + +instance val showable_side : Class.Show.showable side + +val maybe_relate_after_unfolding (g:Env.env) (t0 t1:term) : side + +val is_non_informative (g:Env.env) (t:typ) : bool + +val check_term (g:Env.env) (e:term) (t:typ) (must_tot:bool) + : either (option typ) error + +val check_term_at_type (g:Env.env) (e:term) (t:typ) + : either (tot_or_ghost & option typ) error + +val compute_term_type_handle_guards (g:Env.env) (e:term) + (discharge_guard: Env.env -> typ -> bool) + : either (tot_or_ghost & typ) error + +val open_binders_in_term (g:Env.env) (bs:binders) (t:term) + : Env.env & binders & term + +val open_binders_in_comp (g:Env.env) (bs:binders) (c:comp) + : Env.env & binders & comp + +(* For unit testing, and exposed to tactics *) +val check_term_equality (guard_ok:bool) (unfolding_ok:bool) (g:Env.env) (t0 t1:typ) + : either (option typ) error + +val check_term_subtyping (guard_ok:bool) (unfolding_ok:bool) (g:Env.env) (t0 t1:typ) + : either (option typ) error + +val print_error (err:error) + : string + +val print_error_short (err:error) + : string + +val get_goal_ctr (_:unit) : int +val incr_goal_ctr (_:unit) : int diff --git a/src/typechecker/FStarC.TypeChecker.DMFF.fst b/src/typechecker/FStarC.TypeChecker.DMFF.fst new file mode 100644 index 00000000000..97c4940b73a --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.DMFF.fst @@ -0,0 +1,1701 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.TypeChecker.DMFF +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.TypeChecker +open FStarC.TypeChecker.Common +open FStarC.TypeChecker.Env +open FStarC.Compiler.Util +open FStarC.Ident +open FStarC.Errors +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.Syntax.Subst +open FStarC.Syntax.Util +open FStarC.Const + +open FStarC.Class.Show + +type env = { + // The type-checking environment which we abuse to store our DMFF-style types + // when entering a binder. + tcenv: FStarC.TypeChecker.Env.env; + // The substitution from every [x: C] to its [x^w: C*]. + subst: list subst_elt; + // Hack to avoid a dependency + tc_const: sconst -> typ; +} + +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module N = FStarC.TypeChecker.Normalize +module TcComm = FStarC.TypeChecker.Common +module TcUtil = FStarC.TypeChecker.Util +module TcTerm = FStarC.TypeChecker.TcTerm +module BU = FStarC.Compiler.Util //basic util +module U = FStarC.Syntax.Util +module PC = FStarC.Parser.Const +module TEQ = FStarC.TypeChecker.TermEqAndSimplify + +open FStarC.Class.Setlike + +let dbg = Debug.get_toggle "ED" + +let d s = BU.print1 "\x1b[01;36m%s\x1b[00m\n" s + +// Takes care of creating the [fv], generating the top-level let-binding, and +// return a term that's a suitable reference (a [Tm_fv]) to the definition +let mk_toplevel_definition (env: env_t) lident (def: term): sigelt & term = + // Debug + if !dbg then begin + d (string_of_lid lident); + BU.print2 "Registering top-level definition: %s\n%s\n" (show lident) (show def) + end; + // Allocate a new top-level name. + let fv = S.lid_and_dd_as_fv lident None in + let lbname: lbname = Inr fv in + let lb: letbindings = + // the effect label will be recomputed correctly + false, [U.mk_letbinding lbname [] S.tun PC.effect_Tot_lid def [] Range.dummyRange] + in + // [Inline] triggers a "Impossible: locally nameless" error // FIXME: Doc? + let sig_ctx = mk_sigelt (Sig_let {lbs=lb; lids=[ lident ]}) in + {sig_ctx with sigquals=[ Unfold_for_unification_and_vcgen ]}, + mk (Tm_fvar fv) Range.dummyRange + +let empty env tc_const = { + tcenv = env; + subst = []; + tc_const = tc_const +} + +// Synthesis of WPs from a partial effect definition (in F*) ------------------ + +let gen_wps_for_free + env (binders: binders) (a: bv) (wp_a: term) (ed: Syntax.eff_decl): + Syntax.sigelts & Syntax.eff_decl += + // [wp_a] has been type-checked and contains universe unification variables; + // we want to re-use [wp_a] and make it re-generalize accordingly + let wp_a = N.normalize [Env.Beta; Env.EraseUniverses] env wp_a in + let a = { a with sort = N.normalize [ Env.EraseUniverses ] env a.sort } in + + // Debugging + let d s = BU.print1 "\x1b[01;36m%s\x1b[00m\n" s in + if !dbg then begin + d "Elaborating extra WP combinators"; + BU.print1 "wp_a is: %s\n" (show wp_a) + end; + + (* Consider the predicate transformer st_wp: + * let st_pre_h (heap:Type) = heap -> GTot Type0 + * let st_post_h (heap:Type) (a:Type) = a -> heap -> GTot Type0 + * let st_wp_h (heap:Type) (a:Type) = heap -> st_post_h heap a -> GTot Type0 + * after reduction we get: + * let st_wp_h (heap: Type) (a: Type) = heap -> (a -> heap -> GTot Type0) -> GTot Type0 + * we want: + * type st2_gctx (heap: Type) (a:Type) (t:Type) = heap -> (a -> heap -> GTot Type0) -> GTot t + * we thus generate macros parameterized over [e] that build the right + * context. [gamma] is the series of binders the precede the return type of + * the context. *) + let rec collect_binders (t : term) = + let t = U.unascribe t in + match (compress t).n with + | Tm_arrow {bs; comp} -> + // TODO: dubious, assert no nested arrows + let rest = match comp.n with + | Total t -> t + | _ -> raise_error comp Error_UnexpectedDM4FType + (BU.format1 "wp_a contains non-Tot arrow: %s" (show comp)) + in + bs @ (collect_binders rest) + | Tm_type _ -> + [] + | _ -> + raise_error t Error_UnexpectedDM4FType + (BU.format1 "wp_a doesn't end in Type0, but rather in %s" (show t)) + in + let mk_lid name : lident = U.dm4f_lid ed name in + + let gamma = collect_binders wp_a |> U.name_binders in + if !dbg then + d (BU.format1 "Gamma is %s\n" (show gamma)); + let unknown = S.tun in + let mk x = mk x Range.dummyRange in + + // The [register] function accumulates the top-level definitions that are + // generated in the course of producing WP combinators + let sigelts = BU.mk_ref [] in + let register env lident def = + let sigelt, fv = mk_toplevel_definition env lident def in + let sigelt = { sigelt with sigmeta={sigelt.sigmeta with sigmeta_admit=true}} in + sigelts := sigelt :: !sigelts; + fv + in + + (* Some helpers. *) + let binders_of_list = List.map (fun (t, b) -> S.mk_binder_with_attrs t (S.as_bqual_implicit b) None []) in + let mk_all_implicit = List.map (fun t -> { t with binder_qual=S.as_bqual_implicit true }) in + let args_of_binders = List.map (fun bv -> S.as_arg (S.bv_to_name bv.binder_bv)) in + + let env, mk_ctx, mk_gctx = + // Neither [ctx_def] or [gctx_def] take implicit arguments. + let ctx_def, gctx_def = + let mk f: term = + let t = S.gen_bv "t" None U.ktype in + let body = U.arrow gamma (f (S.bv_to_name t)) in + U.abs (binders @ [ S.mk_binder a; S.mk_binder t ]) body None + in + mk mk_Total, + mk mk_GTotal + in + // Register these two top-level bindings in the environment + let ctx_lid = mk_lid "ctx" in + let ctx_fv = register env ctx_lid ctx_def in + + let gctx_lid = mk_lid "gctx" in + let gctx_fv = register env gctx_lid gctx_def in + + let mk_app fv t = + // The [mk_ctx] and [mk_gctx] helpers therefore do not use implicits either + mk (Tm_app {hd=fv; + args=List.map (fun ({binder_bv=bv}) -> S.bv_to_name bv, S.as_aqual_implicit false) binders @ + [ S.bv_to_name a, S.as_aqual_implicit false; + t, S.as_aqual_implicit false ]}) + in + + env, mk_app ctx_fv, mk_app gctx_fv + in + + (* val st2_pure : #heap:Type -> #a:Type -> #t:Type -> x:t -> + Tot (st2_ctx heap a t) + let st2_pure #heap #a #t x = fun _post _h -> x *) + let c_pure = + let t = S.gen_bv "t" None U.ktype in + let x = S.gen_bv "x" None (S.bv_to_name t) in + let ret = Some (U.residual_tot (mk_ctx (S.bv_to_name t))) in + let body = U.abs gamma (S.bv_to_name x) ret in + U.abs (mk_all_implicit binders @ binders_of_list [ a, true; t, true; x, false ]) body ret + in + let c_pure = register env (mk_lid "pure") c_pure in + + (* val st2_app : #heap:Type -> #a:Type -> #t1:Type -> #t2:Type -> + l:st2_gctx heap a (t1 -> GTot t2) -> + r:st2_gctx heap a t1 -> + Tot (st2_gctx heap a t2) + let st2_app #heap #a #t1 #t2 l r = fun p h -> l p h (r p h) *) + let c_app = + let t1 = S.gen_bv "t1" None U.ktype in + let t2 = S.gen_bv "t2" None U.ktype in + let l = S.gen_bv "l" None (mk_gctx + (U.arrow [ S.mk_binder (S.new_bv None (S.bv_to_name t1)) ] (S.mk_GTotal (S.bv_to_name t2)))) + in + let r = S.gen_bv "r" None (mk_gctx (S.bv_to_name t1)) in + let ret = Some (U.residual_tot (mk_gctx (S.bv_to_name t2))) in + let outer_body = + let gamma_as_args = args_of_binders gamma in + let inner_body = + U.mk_app + (S.bv_to_name l) + (gamma_as_args @ [ S.as_arg (U.mk_app (S.bv_to_name r) gamma_as_args)]) + in + U.abs gamma inner_body ret + in + U.abs (mk_all_implicit binders @ binders_of_list [ a, true; t1, true; t2, true; l, false; r, false ]) outer_body ret + in + let c_app = register env (mk_lid "app") c_app in + + (* val st2_liftGA1 : #heap:Type -> #a:Type -> #t1:Type -> #t2:Type -> + f : (t1 -> GTot t2) -> + st2_gctx heap a t1 -> + Tot (st2_gctx heap a t2) + let st2_liftGA1 #heap #a #t1 #t2 f a1 = + st2_app (st2_pure f) a1 + *) + let c_lift1 = + let t1 = S.gen_bv "t1" None U.ktype in + let t2 = S.gen_bv "t2" None U.ktype in + let t_f = U.arrow [ S.null_binder (S.bv_to_name t1) ] (S.mk_GTotal (S.bv_to_name t2)) in + let f = S.gen_bv "f" None t_f in + let a1 = S.gen_bv "a1" None (mk_gctx (S.bv_to_name t1)) in + let ret = Some (residual_tot (mk_gctx (S.bv_to_name t2))) in + U.abs (mk_all_implicit binders @ binders_of_list [ a, true; t1, true; t2, true; f, false; a1, false ]) ( + U.mk_app c_app (List.map S.as_arg [ + U.mk_app c_pure (List.map S.as_arg [ S.bv_to_name f ]); + S.bv_to_name a1 ]) + ) ret + in + let c_lift1 = register env (mk_lid "lift1") c_lift1 in + + + (* val st2_liftGA2 : #heap:Type -> #a:Type -> #t1:Type -> #t2:Type -> #t3:Type -> + f : (t1 -> t2 -> GTot t3) -> + a1: st2_gctx heap a t1 -> + a2: st2_gctx heap a t2 -> + Tot (st2_gctx heap a t3) + let st2_liftGA2 #heap #a #t1 #t2 #t3 f a1 a2 = + st2_app (st2_app (st2_pure f) a1) a2 + *) + let c_lift2 = + let t1 = S.gen_bv "t1" None U.ktype in + let t2 = S.gen_bv "t2" None U.ktype in + let t3 = S.gen_bv "t3" None U.ktype in + let t_f = U.arrow + [ S.null_binder (S.bv_to_name t1); S.null_binder (S.bv_to_name t2) ] + (S.mk_GTotal (S.bv_to_name t3)) + in + let f = S.gen_bv "f" None t_f in + let a1 = S.gen_bv "a1" None (mk_gctx (S.bv_to_name t1)) in + let a2 = S.gen_bv "a2" None (mk_gctx (S.bv_to_name t2)) in + let ret = Some (U.residual_tot (mk_gctx (S.bv_to_name t3))) in + U.abs (mk_all_implicit binders @ binders_of_list [ a, true; t1, true; t2, true; t3, true; f, false; a1, false; a2, false ]) ( + U.mk_app c_app (List.map S.as_arg [ + U.mk_app c_app (List.map S.as_arg [ + U.mk_app c_pure (List.map S.as_arg [ S.bv_to_name f ]); + S.bv_to_name a1 ]); + S.bv_to_name a2 ]) + ) ret + in + let c_lift2 = register env (mk_lid "lift2") c_lift2 in + + (* val st2_push : #heap:Type -> #a:Type -> #t1:Type -> #t2:Type -> + f:(t1 -> Tot (st2_gctx heap a t2)) -> + Tot (st2_ctx heap a (t1->GTot t2)) + let st2_push #heap #a #t1 #t2 f = fun p h e1 -> f e1 p h *) + let c_push = + let t1 = S.gen_bv "t1" None U.ktype in + let t2 = S.gen_bv "t2" None U.ktype in + let t_f = U.arrow + [ S.null_binder (S.bv_to_name t1) ] + (S.mk_Total (mk_gctx (S.bv_to_name t2))) + in + let f = S.gen_bv "f" None t_f in + let ret = Some (U.residual_tot (mk_ctx (U.arrow [ S.null_binder (S.bv_to_name t1) ] (S.mk_GTotal (S.bv_to_name t2))))) in + let e1 = S.gen_bv "e1" None (S.bv_to_name t1) in + let body = U.abs (gamma @ [ S.mk_binder e1 ]) ( + U.mk_app (S.bv_to_name f) (S.as_arg (S.bv_to_name e1) :: args_of_binders gamma) + ) ret in + U.abs (mk_all_implicit binders @ binders_of_list [ a, true; t1, true; t2, true; f, false ]) body ret + in + let c_push = register env (mk_lid "push") c_push in + + let ret_tot_wp_a = Some (U.residual_tot wp_a) in + let mk_generic_app c = + if List.length binders > 0 then + mk (Tm_app {hd=c; args=args_of_binders binders}) + else + c + in + + (* val st2_if_then_else : heap:Type -> a:Type -> c:Type0 -> + st2_wp heap a -> st2_wp heap a -> + Tot (st2_wp heap a) + let st2_if_then_else heap a c = st2_liftGA2 (l_ITE c) *) + let wp_if_then_else = + let result_comp = (mk_Total ((U.arrow [ S.null_binder wp_a; S.null_binder wp_a ] (mk_Total wp_a)))) in + let c = S.gen_bv "c" None U.ktype in + U.abs (binders @ S.binders_of_list [ a; c ]) ( + let l_ite = fvar_with_dd PC.ite_lid None in + U.ascribe ( + U.mk_app c_lift2 (List.map S.as_arg [ + U.mk_app l_ite [S.as_arg (S.bv_to_name c)] + ]) + ) (Inr result_comp, None, false) + ) (Some (U.residual_comp_of_comp result_comp)) + in + let wp_if_then_else = register env (mk_lid "wp_if_then_else") wp_if_then_else in + let wp_if_then_else = mk_generic_app wp_if_then_else in + + (* val st2_close_wp : heap:Type -> a:Type -> b:Type -> + f:(b->Tot (st2_wp heap a)) -> + Tot (st2_wp heap a) + let st2_close_wp heap a b f = st2_app (st2_pure l_Forall) (st2_push f) *) + let wp_close = + let b = S.gen_bv "b" None U.ktype in + let t_f = U.arrow [ S.null_binder (S.bv_to_name b) ] (S.mk_Total wp_a) in + let f = S.gen_bv "f" None t_f in + let body = + U.mk_app c_app (List.map S.as_arg [ + U.mk_app c_pure (List.map S.as_arg [ U.tforall ]); + U.mk_app c_push (List.map S.as_arg [ S.bv_to_name f ])]) + in + U.abs (binders @ S.binders_of_list [ a; b; f ]) body ret_tot_wp_a + in + let wp_close = register env (mk_lid "wp_close") wp_close in + let wp_close = mk_generic_app wp_close in + + let ret_tot_type = Some (U.residual_tot U.ktype) in + let ret_gtot_type = Some (TcComm.residual_comp_of_lcomp (TcComm.lcomp_of_comp <| S.mk_GTotal U.ktype)) in + let mk_forall (x: S.bv) (body: S.term): S.term = + S.mk (Tm_app {hd=U.tforall; args=[ S.as_arg (U.abs [ S.mk_binder x ] body ret_tot_type)]}) Range.dummyRange + in + + (* For each (target) type t, we define a binary relation in t called ≤_t. + + x ≤_t y =def= x = y [t is base type] + x ≤_Type0 y =def= x ==> y + x ≤_{a->b} y =def= ∀a1 : a, x a1 ≤_b y a1 if is_monotonic a + ∀a1 a2, a1 ≤_a a2 ==> x a1 ≤_b y a2 otherwise + *) + (* Invariant: [x] and [y] have type [t] *) + let rec is_discrete t = match (SS.compress t).n with + | Tm_type _ -> false + | Tm_arrow {bs; comp=c} -> List.for_all (fun ({binder_bv=b}) -> is_discrete b.sort) bs && is_discrete (U.comp_result c) + | _ -> true + in + let rec is_monotonic t = match (SS.compress t).n with + | Tm_type _ -> true + | Tm_arrow {bs; comp=c} -> List.for_all (fun ({binder_bv=b}) -> is_discrete b.sort) bs && is_monotonic (U.comp_result c) + | _ -> is_discrete t + in + let rec mk_rel rel t x y = + let mk_rel = mk_rel rel in + let t = N.normalize [ Env.Beta; Env.Eager_unfolding; Env.DontUnfoldAttr [PC.tac_opaque_attr]; Env.UnfoldUntil S.delta_constant ] env t in + match (SS.compress t).n with + | Tm_type _ -> + (* BU.print2 "type0, x=%s, y=%s\n" (show x) (show y); *) + rel x y + | Tm_arrow {bs=[ binder ]; comp={ n = GTotal b }} + | Tm_arrow {bs=[ binder ]; comp={ n = Total b }} -> + let a = binder.binder_bv.sort in + if is_monotonic a || is_monotonic b //this is an important special case; most monads have zero-order results + then let a1 = S.gen_bv "a1" None a in + let body = mk_rel b + (U.mk_app x [ S.as_arg (S.bv_to_name a1) ]) + (U.mk_app y [ S.as_arg (S.bv_to_name a1) ]) in + mk_forall a1 body + else + (* BU.print2 "arrow, a=%s, b=%s\n" (show a) (show b); *) + let a1 = S.gen_bv "a1" None a in + let a2 = S.gen_bv "a2" None a in + let body = U.mk_imp + (mk_rel a (S.bv_to_name a1) (S.bv_to_name a2)) + (mk_rel b + (U.mk_app x [ S.as_arg (S.bv_to_name a1) ]) + (U.mk_app y [ S.as_arg (S.bv_to_name a2) ])) + in + mk_forall a1 (mk_forall a2 body) + | Tm_arrow {bs=binder :: binders; comp} -> + (* split away the first binder and recurse, so we fall in the case above *) + let t = { t with n = Tm_arrow {bs=[ binder ]; comp=S.mk_Total (U.arrow binders comp)} } in + mk_rel t x y + | Tm_arrow {bs=[]} -> + failwith "impossible: arrow with empty binders" + | _ -> + (* TODO: assert that this is a base type. *) + (* BU.print2 "base, x=%s, y=%s\n" (show x) (show y); *) + U.mk_untyped_eq2 x y + in + let stronger = + let wp1 = S.gen_bv "wp1" None wp_a in + let wp2 = S.gen_bv "wp2" None wp_a in + let rec mk_stronger t x y = + let t = N.normalize [ Env.Beta; Env.Eager_unfolding; Env.DontUnfoldAttr [PC.tac_opaque_attr]; Env.UnfoldUntil S.delta_constant ] env t in + match (SS.compress t).n with + | Tm_type _ -> U.mk_imp x y + | Tm_app {hd=head; args} when is_tuple_constructor (SS.compress head) -> + let project i tuple = + (* TODO : I guess a projector shouldn't be handled as a constant... *) + let projector = S.fvar_with_dd (Env.lookup_projector env (PC.mk_tuple_data_lid (List.length args) Range.dummyRange) i) None in + mk_app projector [tuple, None] + in + let (rel0,rels) = + match List.mapi (fun i (t, q) -> mk_stronger t (project i x) (project i y)) args with + | [] -> failwith "Impossible: empty application when creating stronger relation in DM4F" + | rel0 :: rels -> rel0, rels + in + List.fold_left U.mk_conj rel0 rels + | Tm_arrow {bs=binders; comp={ n = GTotal b }} + | Tm_arrow {bs=binders; comp={ n = Total b }} -> + let bvs = List.mapi (fun i ({binder_bv=bv;binder_qual=q}) -> S.gen_bv ("a" ^ string_of_int i) None bv.sort) binders in + let args = List.map (fun ai -> S.as_arg (S.bv_to_name ai)) bvs in + let body = mk_stronger b (U.mk_app x args) (U.mk_app y args) in + List.fold_right (fun bv body -> mk_forall bv body) bvs body + | _ -> + failwith "Not a DM elaborated type" + in + let body = mk_stronger (U.unascribe wp_a) (S.bv_to_name wp1) (S.bv_to_name wp2) in + U.abs (binders @ binders_of_list [ a, false; wp1, false; wp2, false ]) body ret_tot_type + in + let stronger = register env (mk_lid "stronger") stronger in + let stronger = mk_generic_app stronger in + + let ite_wp = + let wp = S.gen_bv "wp" None wp_a in + let wp_args, post = BU.prefix gamma in + // forall k: post a + let k = S.gen_bv "k" None post.binder_bv.sort in + let equiv = + let open FStarC.Syntax.Formula in + let k_tm = S.bv_to_name k in + let eq = mk_rel U.mk_iff k.sort + k_tm + (S.bv_to_name post.binder_bv) in + match destruct_typ_as_formula eq with + | Some (QAll (binders, [], body)) -> + let k_app = U.mk_app k_tm (args_of_binders binders) in + let guard_free = S.fv_to_tm (S.lid_and_dd_as_fv PC.guard_free None) in + let pat = U.mk_app guard_free [as_arg k_app] in + let pattern_guarded_body = + mk (Tm_meta {tm=body; meta=Meta_pattern(binders_to_names binders, [[as_arg pat]])}) in + U.close_forall_no_univs binders pattern_guarded_body + | _ -> failwith "Impossible: Expected the equivalence to be a quantified formula" + in + let body = U.abs gamma ( + U.mk_forall_no_univ k (U.mk_imp + equiv + (U.mk_app (S.bv_to_name wp) (args_of_binders wp_args @ [ S.as_arg (S.bv_to_name k) ]))) + ) ret_gtot_type in + U.abs (binders @ S.binders_of_list [ a; wp ]) body ret_gtot_type + in + let ite_wp = register env (mk_lid "ite_wp") ite_wp in + let ite_wp = mk_generic_app ite_wp in + + let null_wp = + let wp = S.gen_bv "wp" None wp_a in + let wp_args, post = BU.prefix gamma in + let x = S.gen_bv "x" None S.tun in + let body = U.mk_forall_no_univ x (U.mk_app (S.bv_to_name <| post.binder_bv) [as_arg (S.bv_to_name x)]) in + U.abs (binders @ S.binders_of_list [ a ] @ gamma) body ret_gtot_type in + + let null_wp = register env (mk_lid "null_wp") null_wp in + let null_wp = mk_generic_app null_wp in + + (* val st2_trivial : heap:Type ->a:Type -> st2_wp heap a -> Tot Type0 + let st2_trivial heap a wp = st2_stronger heap a (st2_null_wp heap a) wp *) + let wp_trivial = + let wp = S.gen_bv "wp" None wp_a in + let body = U.mk_app stronger (List.map S.as_arg [ + S.bv_to_name a; + U.mk_app null_wp [ S.as_arg (S.bv_to_name a) ]; + S.bv_to_name wp + ]) in + U.abs (binders @ S.binders_of_list [ a; wp ]) body ret_tot_type + in + let wp_trivial = register env (mk_lid "wp_trivial") wp_trivial in + let wp_trivial = mk_generic_app wp_trivial in + + if !dbg then + d "End Dijkstra monads for free"; + + let c = close binders in + let ed_combs = match ed.combinators with + | DM4F_eff combs -> + DM4F_eff ({ combs with + stronger = ([], c stronger); + if_then_else = ([], c wp_if_then_else); + ite_wp = ([], c ite_wp); + close_wp = ([], c wp_close); + trivial = ([], c wp_trivial) }) + | _ -> failwith "Impossible! For a DM4F effect combinators must be in DM4f_eff" in + + List.rev !sigelts, { ed with combinators = ed_combs } + + +// Some helpers for... -------------------------------------------------------- +type env_ = env + +let get_env env = env.tcenv +let set_env dmff_env env' = { dmff_env with tcenv = env' } + +type nm = | N of typ | M of typ + +type nm_ = nm + +let nm_of_comp c = match c.n with + | Total t -> + N t + | Comp c when c.flags |> BU.for_some (function CPS -> true | _ -> false) -> + //lid_equals c.effect_name PC.monadic_lid -> + M c.result_typ + | _ -> + raise_error c Error_UnexpectedDM4FType + (BU.format1 "[nm_of_comp]: unexpected computation type %s" (show c)) + +let string_of_nm = function + | N t -> BU.format1 "N[%s]" (show t) + | M t -> BU.format1 "M[%s]" (show t) + +let is_monadic_arrow n = + match n with + | Tm_arrow {comp=c} -> + nm_of_comp c + | _ -> + failwith "unexpected_argument: [is_monadic_arrow]" + +let is_monadic_comp c = + match nm_of_comp c with + | M _ -> true + | N _ -> false + + +exception Not_found + +// ... the _ and * transformations from the definition language to F* --------- + +let double_star typ = + let star_once typ = U.arrow [S.mk_binder <| S.new_bv None typ] (S.mk_Total U.ktype0) in + star_once <| typ |> star_once + +let rec mk_star_to_type mk env a = + mk (Tm_arrow {bs=[S.mk_binder_with_attrs (S.null_bv (star_type' env a)) (S.as_bqual_implicit false) None []]; + comp=mk_Total U.ktype0}) + +// The *-transformation for types, purely syntactic. Has been enriched with the +// [Tm_abs] case to account for parameterized types + +and star_type' env t = + let mk x = mk x t.pos in + let mk_star_to_type = mk_star_to_type mk in + //BU.print1 "[debug]: star_type' %s\n" (show t); + let t = SS.compress t in + match t.n with + | Tm_arrow {bs=binders} -> + // TODO: check that this is not a dependent arrow. + let binders = List.map (fun b -> + {b with binder_bv={b.binder_bv with sort = star_type' env b.binder_bv.sort}} + ) binders in + (* Catch the GTotal case early; it seems relatively innocuous to allow + * GTotal to appear. TODO fix this as a clean, single pattern-matching. *) + begin match t.n with + | Tm_arrow {comp={ n = GTotal hn }} -> + mk (Tm_arrow {bs=binders; comp=mk_GTotal (star_type' env hn)}) + | _ -> + match is_monadic_arrow t.n with + | N hn -> + // Simple case: + // (H_0 -> ... -> H_n)* = H_0* -> ... -> H_n* + mk (Tm_arrow {bs=binders; comp=mk_Total (star_type' env hn)}) + | M a -> + // F*'s arrows are n-ary (and the intermediary arrows are pure), so the rule is: + // (H_0 -> ... -> H_n -t-> A)* = H_0* -> ... -> H_n* -> (A* -> Type) -> Type + mk (Tm_arrow { + bs=binders @ [ S.mk_binder_with_attrs (S.null_bv (mk_star_to_type env a)) + (S.as_bqual_implicit false) None []]; + comp=mk_Total U.ktype0}) + end + + | Tm_app {hd=head; args} -> + // Sums and products. TODO: re-use the cache in [env] to not recompute + // (st a)* every time. + let debug (t : term) (s : FlatSet.t bv) = + Errors.log_issue t Errors.Warning_DependencyFound (BU.format2 "Dependency found in term %s : %s" (show t) (show s)) + in + let rec is_non_dependent_arrow ty n = + match (SS.compress ty).n with + | Tm_arrow {bs=binders; comp=c} -> begin + if not (U.is_tot_or_gtot_comp c) + then false + else + try + let non_dependent_or_raise s ty = + let sinter = inter (Free.names ty) s in + if not (is_empty sinter) + then (debug ty sinter ; raise Not_found) + in + let binders, c = SS.open_comp binders c in + let s = List.fold_left (fun s ({binder_bv=bv}) -> + non_dependent_or_raise s bv.sort ; + add bv s + ) (Class.Setlike.empty ()) binders in + let ct = U.comp_result c in + non_dependent_or_raise s ct ; + let k = n - List.length binders in + if k > 0 then is_non_dependent_arrow ct k else true + with Not_found -> false + end + | _ -> + Errors.log_issue ty Errors.Warning_NotDependentArrow (BU.format1 "Not a dependent arrow : %s" (show ty)); + false + in + let rec is_valid_application head = + match (SS.compress head).n with + | Tm_fvar fv when ( + // TODO: implement a better check (non-dependent, user-defined data type) + fv_eq_lid fv PC.option_lid || + fv_eq_lid fv PC.either_lid || + fv_eq_lid fv PC.eq2_lid || + is_tuple_constructor (SS.compress head) + ) -> + true + | Tm_fvar fv -> + let (_, ty), _ = Env.lookup_lid env.tcenv fv.fv_name.v in + if is_non_dependent_arrow ty (List.length args) + then + // We need to check that the result of the application is a datatype + let res = N.normalize [Env.EraseUniverses; Env.Inlining ; Env.DontUnfoldAttr [PC.tac_opaque_attr]; Env.UnfoldUntil S.delta_constant] env.tcenv t in + begin match (SS.compress res).n with + | Tm_app _ -> true + | _ -> + Errors.log_issue head Errors.Warning_NondependentUserDefinedDataType (BU.format1 "Got a term which might be a non-dependent user-defined data-type %s\n" (show head)); + false + end + else false + | Tm_bvar _ + | Tm_name _ -> + true + | Tm_uinst (t, _) -> + is_valid_application t + | _ -> + false + in + if is_valid_application head then + mk (Tm_app {hd=head; args=List.map (fun (t, qual) -> star_type' env t, qual) args}) + else + raise_error0 Errors.Fatal_WrongTerm + (BU.format1 "For now, only [either], [option] and [eq2] are supported in the definition language (got: %s)" + (show t)) + + | Tm_bvar _ + | Tm_name _ + | Tm_type _ // TODO: does [Tm_type] make sense? + | Tm_fvar _ -> + t + + | Tm_abs {bs=binders; body=repr; rc_opt=something} -> + // For parameterized data types... TODO: check that this only appears at + // top-level + let binders, repr = SS.open_term binders repr in + let env = { env with tcenv = push_binders env.tcenv binders } in + let repr = star_type' env repr in + U.abs binders repr something + + | Tm_refine {b=x; phi=t} when false -> + let x = freshen_bv x in + let sort = star_type' env x.sort in + let subst = [DB(0, x)] in + let t = SS.subst subst t in + let t = star_type' env t in + let subst = [NM(x, 0)] in + let t = SS.subst subst t in + mk (Tm_refine {b={ x with sort = sort }; phi=t}) + + | Tm_meta {tm=t; meta=m} -> + mk (Tm_meta {tm=star_type' env t; meta=m}) + + | Tm_ascribed {tm=e; asc=(Inl t, None, use_eq); eff_opt=something} -> + mk (Tm_ascribed {tm=star_type' env e; asc=(Inl (star_type' env t), None, use_eq); eff_opt=something}) + + | Tm_ascribed {tm=e; asc=(Inr c, None, use_eq); eff_opt=something} -> + mk (Tm_ascribed {tm=star_type' env e; + asc=(Inl (star_type' env (U.comp_result c)), None, use_eq); + eff_opt=something}) //AR: this should effectively be the same, the effect checking for c should have done someplace else? + (*raise_error0 (Errors.Fatal_TermOutsideOfDefLanguage, (BU.format1 "Tm_ascribed is outside of the definition language: %s" + (show t)))*) + + | Tm_ascribed {asc=(_, Some _, _)} -> + raise_error0 Errors.Fatal_TermOutsideOfDefLanguage + (BU.format1 "Ascriptions with tactics are outside of the definition language: %s" (show t)) + | Tm_refine _ + | Tm_uinst _ + | Tm_quoted _ + | Tm_constant _ + | Tm_match _ + | Tm_let _ + | Tm_uvar _ + | Tm_unknown -> + let open FStarC.Class.Tagged in + raise_error0 Errors.Fatal_TermOutsideOfDefLanguage + (BU.format2 "%s is outside of the definition language: %s" (tag_of t) (show t)) + + | Tm_lazy i -> star_type' env (U.unfold_lazy i) + + | Tm_delayed _ -> + failwith "impossible" + + +// The bi-directional *-transformation and checker for expressions ------------ + +let is_monadic = function + | None -> + failwith "un-annotated lambda?!" + | Some rc -> + rc.residual_flags |> BU.for_some (function CPS -> true | _ -> false) + +// TODO: this function implements a (partial) check for the well-formedness of +// C-types... +// This function expects its argument [t] to be normalized. +let rec is_C (t: typ): bool = + match (SS.compress t).n with + // TODO: deal with more than tuples? + | Tm_app {hd=head; args} when U.is_tuple_constructor head -> + let r = is_C (fst (List.hd args)) in + if r then begin + if not (List.for_all (fun (h, _) -> is_C h) args) then + raise_error t Error_UnexpectedDM4FType + (BU.format1 "Not a C-type (A * C): %s" (show t)); + true + end else begin + if not (List.for_all (fun (h, _) -> not (is_C h)) args) then + raise_error t Error_UnexpectedDM4FType + (BU.format1 "Not a C-type (C * A): %s" (show t)); + false + end + | Tm_arrow {bs=binders; comp} -> + begin match nm_of_comp comp with + | M t -> + if (is_C t) then + raise_error t Error_UnexpectedDM4FType + (BU.format1 "Not a C-type (C -> C): %s" (show t)); + true + | N t -> + // assert (List.exists is_C binders) ==> is_C comp + is_C t + end + | Tm_meta {tm=t} + | Tm_uinst (t, _) + | Tm_ascribed {tm=t} -> + is_C t + | _ -> + false + + +// This function assumes [e] has been starred already and returns: +// [fun (p: t* -> Type) -> p e] +let mk_return env (t: typ) (e: term) = + let mk x = mk x e.pos in + let p_type = mk_star_to_type mk env t in + let p = S.gen_bv "p'" None p_type in + let body = mk (Tm_app {hd=S.bv_to_name p; args=[ e, S.as_aqual_implicit false ]}) in + U.abs [ S.mk_binder p ] body (Some (U.residual_tot U.ktype0)) + +let is_unknown = function | Tm_unknown -> true | _ -> false + +// [check] takes four kinds of [nm]. +// - [N Tm_unknown] checks that the computation is pure and returns [N t] where +// [t] is the inferred type of the original term; +// - [M Tm_unknown] checks that the computation is monadic and returns [N t] +// where [t] is the inferred type of the original term; +// - [N T] checks that the computation is pure, has type T, and returns [N t]; +// - [M T] checks that the computation is monadic, has type T, and returns [M t]; +// [check] returns two terms: +// - the first is [e*], the CPS'd version of [e] +// - the second is [_e_], the elaborated version of [e] +let rec check (env: env) (e: term) (context_nm: nm): nm & term & term = + // BU.print1 "[debug]: check %s\n" (show e); + // [s_e] as in "starred e"; [u_e] as in "underlined u" (per the paper) + let return_if (rec_nm, s_e, u_e) = + let check t1 t2 = + if not (is_unknown t2.n) && not (Env.is_trivial (Rel.teq env.tcenv t1 t2)) then + raise_error0 Errors.Fatal_TypeMismatch + (BU.format3 "[check]: the expression [%s] has type [%s] but should have type [%s]" (show e) (show t1) (show t2)) + in + match rec_nm, context_nm with + | N t1, N t2 + | M t1, M t2 -> + check t1 t2; + rec_nm, s_e, u_e + | N t1, M t2 -> + check t1 t2; + // no need to wrap [u_e] in an explicit [return]; F* will infer it later on + M t1, mk_return env t1 s_e, u_e + | M t1, N t2 -> + raise_error0 Errors.Fatal_EffectfulAndPureComputationMismatch + (BU.format3 "[check %s]: got an effectful computation [%s] in lieu of a pure computation [%s]" (show e) (show t1) (show t2)) + + in + + let ensure_m (env: env_) (e2: term): term & term & term = + let strip_m = function + | M t, s_e, u_e -> t, s_e, u_e + | _ -> failwith "impossible" + in + match context_nm with + | N t -> raise_error e2 Errors.Fatal_LetBoundMonadicMismatch + ("let-bound monadic body has a non-monadic continuation or a branch of a match is monadic and the others aren't : " ^ show t) + | M _ -> strip_m (check env e2 context_nm) + in + + match (SS.compress e).n with + | Tm_bvar _ + | Tm_name _ + | Tm_fvar _ + | Tm_abs _ + | Tm_constant _ + | Tm_quoted _ + | Tm_app _ -> + return_if (infer env e) + + | Tm_lazy i -> + check env (U.unfold_lazy i) context_nm + + | Tm_let {lbs=(false, [ binding ]); body=e2} -> + mk_let env binding e2 + // Body of the let is pure: just defer the check to the continuation + (fun env e2 -> check env e2 context_nm) + // Body of the let is monadic: this is a bind, and we must strengthen + // the check on the continuation to ensure it is a monadic computation + ensure_m + + | Tm_match {scrutinee=e0; brs=branches} -> + // This is similar to the [let] case above. The [match] checks that the + // types of the branches work; it also demands that the scrutinee be a + // non-monadic computation. + mk_match env e0 branches (fun env body -> check env body context_nm) + + | Tm_meta {tm=e} + | Tm_uinst (e, _) + | Tm_ascribed {tm=e} -> + (* TODO : reinstall the type annotation *) + check env e context_nm + + | Tm_let _ -> + failwith (BU.format1 "[check]: Tm_let %s" (show e)) + | Tm_type _ -> + failwith "impossible (DM stratification)" + | Tm_arrow _ -> + failwith "impossible (DM stratification)" + | Tm_refine _ -> + failwith (BU.format1 "[check]: Tm_refine %s" (show e)) + | Tm_uvar _ -> + failwith (BU.format1 "[check]: Tm_uvar %s" (show e)) + | Tm_delayed _ -> + failwith "impossible (compressed)" + | Tm_unknown -> + failwith (BU.format1 "[check]: Tm_unknown %s" (show e)) + + +and infer (env: env) (e: term): nm & term & term = + // BU.print1 "[debug]: infer %s\n" (show e); + let mk x = mk x e.pos in + let normalize = N.normalize [ Env.Beta; Env.Eager_unfolding; Env.DontUnfoldAttr [PC.tac_opaque_attr]; Env.UnfoldUntil S.delta_constant; Env.EraseUniverses ] env.tcenv in + match (SS.compress e).n with + | Tm_bvar bv -> + failwith "I failed to open a binder... boo" + + | Tm_name bv -> + N bv.sort, e, e + + | Tm_lazy i -> + infer env (U.unfold_lazy i) + + | Tm_abs {bs=binders;body;rc_opt} -> + let subst_rc_opt subst rc_opt = + match rc_opt with + | Some {residual_typ=None} + | None -> rc_opt + | Some rc -> Some ({rc with residual_typ=Some (SS.subst subst (BU.must rc.residual_typ))}) in + + //NS: note, this is explicitly written with opening binders + // rather than U.abs_formals + // since the specific number of binders to open is determined very syntactically + // We do not want to collapse (fun x -> (fun y -> e)) into (fun x y -> e) + // since this changes the way the selectve CPS transform works + let binders = SS.open_binders binders in + let subst = SS.opening_of_binders binders in + let body = SS.subst subst body in + let rc_opt = subst_rc_opt subst rc_opt in + let env = { env with tcenv = push_binders env.tcenv binders } in + + // For the *-translation, [x: t] becomes [x: t*]. + let s_binders = List.map (fun b -> + let sort = star_type' env b.binder_bv.sort in + {b with binder_bv = { b.binder_bv with sort = sort } } + ) binders in + + // For the _-translation, things are a little bit trickier. We need to + // update the substitution, and one binder may turn into two binders. + let env, u_binders = List.fold_left (fun (env, acc) ({binder_bv=bv}) -> + let c = bv.sort in + if is_C c then + let xw = S.gen_bv ((string_of_id bv.ppname) ^ "__w") None (star_type' env c) in + let x = { bv with sort = trans_F_ env c (S.bv_to_name xw) } in + let env = { env with subst = NT (bv, S.bv_to_name xw) :: env.subst } in + env, S.mk_binder x :: S.mk_binder xw :: acc + else + let x = { bv with sort = star_type' env bv.sort } in + env, S.mk_binder x :: acc + ) (env, []) binders in + let u_binders = List.rev u_binders in + + (* + BU.print2_warning "Term %s ::: what %s \n" + (show body) + (Print.abs_ascription_to_string what) ; + *) + + let comp, s_body, u_body = + let check_what = if is_monadic rc_opt then check_m else check_n in + let t, s_body, u_body = check_what env body in + comp_of_nm (if is_monadic rc_opt then M t else N t), s_body, u_body + in + + // From [comp], the inferred computation type for the (original), return + // the inferred type for the original term. + let t = U.arrow binders comp in + + let s_rc_opt = match rc_opt with + | None -> None // That should not happen according to some other comment + | Some rc -> begin + match rc.residual_typ with + | None -> + let rc = + if rc.residual_flags |> BU.for_some (function CPS -> true | _ -> false) + then U.mk_residual_comp PC.effect_Tot_lid None (List.filter (function CPS -> false | _ -> true) rc.residual_flags) + else rc in + Some rc + + | Some rt -> + let rt = N.normalize [ Env.Beta; Env.Eager_unfolding; Env.DontUnfoldAttr [PC.tac_opaque_attr]; Env.UnfoldUntil S.delta_constant; Env.EraseUniverses ] (get_env env) rt in + if rc.residual_flags |> BU.for_some (function CPS -> true | _ -> false) + then + let flags = List.filter (function CPS -> false | _ -> true) rc.residual_flags in + Some (U.mk_residual_comp PC.effect_Tot_lid (Some (double_star rt)) flags) + else Some ({rc with residual_typ = Some (star_type' env rt)}) + end + + in + + let u_body, u_rc_opt = + let comp = trans_G env (U.comp_result comp) (is_monadic rc_opt) (SS.subst env.subst s_body) in + (* TODO : consider removing this ascription *) + U.ascribe u_body (Inr comp, None, false), + Some (U.residual_comp_of_comp comp) + in + + + let s_body = close s_binders s_body in + let s_binders = close_binders s_binders in + let s_term = mk (Tm_abs {bs=s_binders; body=s_body; rc_opt=subst_rc_opt (Subst.closing_of_binders s_binders) s_rc_opt}) in + + let u_body = close u_binders u_body in + let u_binders = close_binders u_binders in + let u_term = mk (Tm_abs {bs=u_binders; body=u_body; rc_opt=subst_rc_opt (Subst.closing_of_binders u_binders) u_rc_opt}) in + + N t, s_term, u_term + + | Tm_fvar { fv_name = { v = lid } } -> + let _, t = fst <| Env.lookup_lid env.tcenv lid in + // Need to erase universes here! This is an F* type that is fully annotated. + N (normalize t), e, e + + (* Unary operators. Explicitly curry extra arguments *) + | Tm_app {hd={n=Tm_constant Const_range_of}; args=a::hd::rest} -> + let rest = hd::rest in //no 'as' clauses in F* yet, so we need to do this ugliness + let unary_op, _ = U.head_and_args e in + let head = mk (Tm_app {hd=unary_op; args=[a]}) in + let t = mk (Tm_app {hd=head; args=rest}) in + infer env t + + (* Binary operators *) + | Tm_app {hd={n=Tm_constant Const_set_range_of}; args=a1::a2::hd::rest} -> + let rest = hd::rest in //no 'as' clauses in F* yet, so we need to do this ugliness + let unary_op, _ = U.head_and_args e in + let head = mk (Tm_app {hd=unary_op; args=[a1; a2]}) in + let t = mk (Tm_app {hd=head; args=rest}) in + infer env t + + | Tm_app {hd={n=Tm_constant Const_range_of}; args=[(a, None)]} -> + let t, s, u = infer env a in + let head,_ = U.head_and_args e in + N (tabbrev PC.range_lid), + mk (Tm_app {hd=head; args=[S.as_arg s]}), + mk (Tm_app {hd=head; args=[S.as_arg u]}) + + | Tm_app {hd={n=Tm_constant Const_set_range_of}; args=(a1, _)::a2::[]} -> + let t, s, u = infer env a1 in + let head,_ = U.head_and_args e in + t, + mk (Tm_app {hd=head; args=[S.as_arg s; a2]}), + mk (Tm_app {hd=head; args=[S.as_arg u; a2]}) + + | Tm_app {hd={n=Tm_constant Const_range_of}} + | Tm_app {hd={n=Tm_constant Const_set_range_of}} -> + raise_error e Errors.Fatal_IllAppliedConstant (BU.format1 "DMFF: Ill-applied constant %s" (show e)) + + | Tm_app {hd=head; args} -> + let t_head, s_head, u_head = check_n env head in + let is_arrow t = match (SS.compress t).n with | Tm_arrow _ -> true | _ -> false in + // TODO: replace with BU.arrow_formals_comp + let rec flatten t = match (SS.compress t).n with + | Tm_arrow {bs=binders; comp={ n = Total t }} when is_arrow t -> + let binders', comp = flatten t in + binders @ binders', comp + | Tm_arrow {bs=binders; comp} -> + binders, comp + | Tm_ascribed {tm=e} -> + flatten e + | _ -> + raise_error0 Errors.Fatal_NotFunctionType (BU.format1 "%s: not a function type" (show t_head)) + in + let binders, comp = flatten t_head in + // BU.print1 "[debug] type of [head] is %s\n" (show t_head); + + // Making the assumption here that [Tm_arrow (..., Tm_arrow ...)] + // implies [is_M comp]. F* should be fixed if it's not the case. + let n = List.length binders in + let n' = List.length args in + if List.length binders < List.length args then + raise_error0 Errors.Fatal_BinderAndArgsLengthMismatch (BU.format3 "The head of this application, after being applied to %s \ + arguments, is an effectful computation (leaving %s arguments to be \ + applied). Please let-bind the head applied to the %s first \ + arguments." (string_of_int n) (string_of_int (n' - n)) (show n)); + // BU.print2 "[debug] length binders=%s, length args=%s\n" + // (string_of_int n) (string_of_int n'); + + let binders, comp = SS.open_comp binders comp in + let rec final_type subst (binders, comp) args = + match binders, args with + | [], [] -> + nm_of_comp (SS.subst_comp subst comp) + | binders, [] -> + begin match (SS.compress (SS.subst subst (mk (Tm_arrow {bs=binders; comp})))).n with + | Tm_arrow {bs=binders; comp} -> N (mk (Tm_arrow {bs=binders; comp=close_comp binders comp})) + | _ -> failwith "wat?" + end + | [], _ :: _ -> + failwith "just checked that?!" + | ({binder_bv=bv}) :: binders, (arg, _) :: args -> + final_type (NT (bv, arg) :: subst) (binders, comp) args + in + let final_type = final_type [] (binders, comp) args in + // BU.print1 "[debug]: final type of application is %s\n" (string_of_nm final_type); + + let binders, _ = List.splitAt n' binders in + + let s_args, u_args = List.split (List.map2 (fun ({binder_bv=bv}) (arg, q) -> + // TODO: implement additional check that the arguments are T-free if + // head is [Tm_fvar ...] with [Mktuple], [Left], etc. + // Note: not enforcing the types of the arguments because 1) it has + // been enforced by the main F* type-checker and 2) it's a hassle with + // binders and stuff + match (SS.compress bv.sort).n with + | Tm_type _ -> + (star_type' env arg, q), [ (arg, q) ] + | _ -> + let _, s_arg, u_arg = check_n env arg in + (s_arg, q), + (if is_C bv.sort + then [ SS.subst env.subst s_arg, q; u_arg, q] + else [ u_arg, q]) + ) binders args) in + let u_args = List.flatten u_args in + + final_type, mk (Tm_app {hd=s_head; args=s_args}), mk (Tm_app {hd=u_head; args=u_args}) + + | Tm_let {lbs=(false, [ binding ]); body=e2} -> + mk_let env binding e2 infer check_m + + | Tm_match {scrutinee=e0; brs=branches} -> + mk_match env e0 branches infer + + | Tm_uinst (e, _) + | Tm_meta {tm=e} + | Tm_ascribed {tm=e} -> + infer env e + + | Tm_constant c -> + N (env.tc_const c), e, e + + | Tm_quoted (tm, qt) -> + N S.t_term, e, e + + | Tm_let _ -> + failwith (BU.format1 "[infer]: Tm_let %s" (show e)) + | Tm_type _ -> + failwith "impossible (DM stratification)" + | Tm_arrow _ -> + failwith "impossible (DM stratification)" + | Tm_refine _ -> + failwith (BU.format1 "[infer]: Tm_refine %s" (show e)) + | Tm_uvar _ -> + failwith (BU.format1 "[infer]: Tm_uvar %s" (show e)) + | Tm_delayed _ -> + failwith "impossible (compressed)" + | Tm_unknown -> + failwith (BU.format1 "[infer]: Tm_unknown %s" (show e)) + +and mk_match env e0 branches f = + let mk x = mk x e0.pos in + + // TODO: automatically [bind] when the scrutinee is monadic? + let _, s_e0, u_e0 = check_n env e0 in + let nms, branches = List.split (List.map (fun b -> + match open_branch b with + | pat, None, body -> + let env = { env with tcenv = List.fold_left push_bv env.tcenv (pat_bvs pat) } in + let nm, s_body, u_body = f env body in + nm, (pat, None, (s_body, u_body, body)) + | _ -> + raise_error0 Errors.Fatal_WhenClauseNotSupported "No when clauses in the definition language" + ) branches) in + let t1 = match List.hd nms with | M t1 | N t1 -> t1 in + let has_m = List.existsb (function | M _ -> true | _ -> false) nms in + let nms, s_branches, u_branches = List.unzip3 (List.map2 (fun nm (pat, guard, (s_body, u_body, original_body)) -> + match nm, has_m with + | N t2, false + | M t2, true -> + nm, (pat, guard, s_body), (pat, guard, u_body) + | N t2, true -> + // In checking mode, all the branches are run through "check"... meaning + // that they're either all N or all M... the lift from N to M can only + // occur in infer mode... instead of calling [mk_return s_body], + // re-check_m everything and get code that's better for z3 + let _, s_body, u_body = check env original_body (M t2) in + M t2, (pat, guard, s_body), (pat, guard, u_body) + | M _, false -> + failwith "impossible" + ) nms branches) in + + if has_m then begin + // if the return type is monadic we add a + // (fun p -> match ... with ... -> branch p) + // in order to help the SMT + // p: A* -> Type + let p_type = mk_star_to_type mk env t1 in + let p = S.gen_bv "p''" None p_type in + let s_branches = List.map (fun (pat, guard, s_body) -> + let s_body = mk (Tm_app {hd=s_body; args=[ S.bv_to_name p, S.as_aqual_implicit false ]}) in + (pat, guard, s_body) + ) s_branches in + let s_branches = List.map close_branch s_branches in + let u_branches = List.map close_branch u_branches in + let s_e = + U.abs [ S.mk_binder p ] + (mk (Tm_match {scrutinee=s_e0; ret_opt=None; brs= s_branches; rc_opt=None})) + (Some (U.residual_tot U.ktype0)) + in + let t1_star = U.arrow [S.mk_binder <| S.new_bv None p_type] (S.mk_Total U.ktype0) in + M t1, + mk (Tm_ascribed {tm=s_e; asc=(Inl t1_star, None, false); eff_opt=None}) , + mk (Tm_match {scrutinee=u_e0; ret_opt=None; brs=u_branches; rc_opt=None}) + end else begin + let s_branches = List.map close_branch s_branches in + let u_branches = List.map close_branch u_branches in + let t1_star = t1 in + N t1, + mk (Tm_ascribed {tm=mk (Tm_match {scrutinee=s_e0; ret_opt=None; brs=s_branches; rc_opt=None}); asc=(Inl t1_star, None, false); eff_opt=None}), + mk (Tm_match {scrutinee=u_e0; ret_opt=None; brs=u_branches; rc_opt=None}) + end + +and mk_let (env: env_) (binding: letbinding) (e2: term) + (proceed: env_ -> term -> nm & term & term) + (ensure_m: env_ -> term -> term & term & term) = + let mk x = mk x e2.pos in + let e1 = binding.lbdef in + // This is [let x = e1 in e2]. Open [x] in [e2]. + let x = BU.left binding.lbname in + let x_binders = [ S.mk_binder x ] in + let x_binders, e2 = SS.open_term x_binders e2 in + begin match infer env e1 with + | N t1, s_e1, u_e1 -> + // BU.print1 "[debug] %s is NOT a monadic let-binding\n" (show binding.lbname); + // TODO : double-check that correct env and lbeff are used + let u_binding = + if is_C t1 + then { binding with lbtyp = trans_F_ env t1 (SS.subst env.subst s_e1) } + else binding + in + // Piggyback on the environment to carry our own special terms + let env = { env with tcenv = push_bv env.tcenv ({ x with sort = t1 }) } in + // Simple case: just a regular let-binding. We defer checks to e2. + let nm_rec, s_e2, u_e2 = proceed env e2 in + let s_binding = { binding with lbtyp = star_type' env binding.lbtyp } in + nm_rec, + mk (Tm_let {lbs=(false, [ { s_binding with lbdef = s_e1 } ]); body=SS.close x_binders s_e2}), + mk (Tm_let {lbs=(false, [ { u_binding with lbdef = u_e1 } ]); body=SS.close x_binders u_e2}) + + | M t1, s_e1, u_e1 -> + // BU.print1 "[debug] %s IS a monadic let-binding\n" (show binding.lbname); + let u_binding = { binding with lbeff = PC.effect_PURE_lid ; lbtyp = t1 } in + let env = { env with tcenv = push_bv env.tcenv ({ x with sort = t1 }) } in + let t2, s_e2, u_e2 = ensure_m env e2 in + // Now, generate the bind. + // p: A* -> Type + let p_type = mk_star_to_type mk env t2 in + let p = S.gen_bv "p''" None p_type in + // e2* p + let s_e2 = mk (Tm_app {hd=s_e2; args=[ S.bv_to_name p, S.as_aqual_implicit false ]}) in + // fun x -> s_e2* p; this takes care of closing [x]. + let s_e2 = U.abs x_binders s_e2 (Some (U.residual_tot U.ktype0)) in + // e1* (fun x -> e2* p) + let body = mk (Tm_app {hd=s_e1; args=[ s_e2, S.as_aqual_implicit false ]}) in + M t2, + U.abs [ S.mk_binder p ] body (Some (U.residual_tot U.ktype0)), + mk (Tm_let {lbs=(false, [ { u_binding with lbdef = u_e1 } ]); body=SS.close x_binders u_e2}) + end + + +and check_n (env: env_) (e: term): typ & term & term = + let mn = N (mk Tm_unknown e.pos) in + match check env e mn with + | N t, s_e, u_e -> t, s_e, u_e + | _ -> failwith "[check_n]: impossible" + +and check_m (env: env_) (e: term): typ & term & term = + let mn = M (mk Tm_unknown e.pos) in + match check env e mn with + | M t, s_e, u_e -> t, s_e, u_e + | _ -> failwith "[check_m]: impossible" + +and comp_of_nm (nm: nm_): comp = + match nm with + | N t -> mk_Total t + | M t -> mk_M t + +and mk_M (t: typ): comp = + mk_Comp ({ + comp_univs=[U_unknown]; + effect_name = PC.monadic_lid; + result_typ = t; + effect_args = []; + flags = [CPS ; TOTAL] + }) + +and type_of_comp t = U.comp_result t + +// This function expects its argument [c] to be normalized and to satisfy [is_C c] +and trans_F_ (env: env_) (c: typ) (wp: term): term = + if not (is_C c) then + raise_error c Error_UnexpectedDM4FType (BU.format1 "Not a DM4F C-type: %s" (show c)); + let mk x = mk x c.pos in + match (SS.compress c).n with + | Tm_app {hd=head; args} -> + // It's a product, the only form of [Tm_app] allowed. + let wp_head, wp_args = head_and_args wp in + if not (List.length wp_args = List.length args) || + not (is_constructor wp_head (PC.mk_tuple_data_lid (List.length wp_args) Range.dummyRange)) then + failwith "mismatch"; + mk (Tm_app {hd=head; args=List.map2 (fun (arg, q) (wp_arg, q') -> + let print_implicit q = if S.is_aqual_implicit q then "implicit" else "explicit" in + if not (eq_aqual q q') + then Errors.log_issue + head.pos + Errors.Warning_IncoherentImplicitQualifier + (BU.format2 "Incoherent implicit qualifiers %s %s\n" + (print_implicit q) + (print_implicit q')); + trans_F_ env arg wp_arg, q) + args wp_args}) + | Tm_arrow {bs=binders; comp} -> + let binders = U.name_binders binders in + let binders_orig, comp = open_comp binders comp in + let bvs, binders = List.split (List.map (fun b -> + let bv, q = b.binder_bv, b.binder_qual in + let h = bv.sort in + if is_C h then + let w' = S.gen_bv ((string_of_id bv.ppname) ^ "__w'") None (star_type' env h) in + w', [ {b with binder_bv=w'}; {b with binder_bv=S.null_bv (trans_F_ env h (S.bv_to_name w'))} ] + else + let x = S.gen_bv ((string_of_id bv.ppname) ^ "__x") None (star_type' env h) in + x, [ {b with binder_bv=x} ] + ) binders_orig) in + let binders = List.flatten binders in + let comp = SS.subst_comp (U.rename_binders binders_orig (S.binders_of_list bvs)) comp in + let app = mk (Tm_app {hd=wp;args=List.map (fun bv -> S.bv_to_name bv, S.as_aqual_implicit false) bvs}) in + let comp = trans_G env (type_of_comp comp) (is_monadic_comp comp) app in + U.arrow binders comp + | Tm_ascribed {tm=e} -> + (* TODO : find a way to recompute the corrected ascription *) + trans_F_ env e wp + | _ -> + failwith "impossible trans_F_" + +and trans_G (env: env_) (h: typ) (is_monadic: bool) (wp: typ): comp = + if is_monadic then + mk_Comp ({ + comp_univs = [U_unknown]; + effect_name = PC.effect_PURE_lid; + result_typ = star_type' env h; + effect_args = [ wp, S.as_aqual_implicit false ]; + flags = [] + }) + else + mk_Total (trans_F_ env h wp) + +// A helper -------------------------------------------------------------------- + +(* KM : why is there both NoDeltaSteps and UnfoldUntil Delta_constant ? *) +let n = N.normalize [ Env.DontUnfoldAttr [PC.tac_opaque_attr]; Env.Beta; Env.UnfoldUntil delta_constant; Env.DoNotUnfoldPureLets; Env.Eager_unfolding; Env.EraseUniverses ] + + +// Exported definitions ------------------------------------------------------- + +let star_type env t = + star_type' env (n env.tcenv t) + +let star_expr env t = + check_n env (n env.tcenv t) + +let trans_F (env: env_) (c: typ) (wp: term): term = + trans_F_ env (n env.tcenv c) (n env.tcenv wp) + +// A helper to check that the terms elaborated by DMFF are well-typed +let recheck_debug (s:string) (env:FStarC.TypeChecker.Env.env) (t:S.term) : S.term = + if !dbg then + BU.print2 "Term has been %s-transformed to:\n%s\n----------\n" s (show t); + let t', _, _ = TcTerm.tc_term env t in + if !dbg then + BU.print1 "Re-checked; got:\n%s\n----------\n" (show t'); + t' + + +let cps_and_elaborate (env:FStarC.TypeChecker.Env.env) (ed:S.eff_decl) + : list S.sigelt & + S.eff_decl & + option S.sigelt = + // Using [STInt: a:Type -> Effect] as an example... + let effect_binders_un, signature_un = SS.open_term ed.binders (ed.signature |> U.effect_sig_ts |> snd) in + // [binders] is the empty list (for [ST (h: heap)], there would be one binder) + let effect_binders, env, _ = TcTerm.tc_tparams env effect_binders_un in + // [signature] is a:Type -> effect + let signature, _ = TcTerm.tc_trivial_guard env signature_un in + // We will open binders through [open_and_check] + + let raise_error #a code msg : a = Errors.raise_error signature.pos code msg in + + let effect_binders = List.map (fun b -> + {b with binder_bv={b.binder_bv with sort = N.normalize [ Env.EraseUniverses ] env b.binder_bv.sort }} + ) effect_binders in + + // Every combinator found in the effect declaration is parameterized over + // [binders], then [a]. This is a variant of [open_effect_signature] where we + // just extract the binder [a]. + let a, effect_marker = + // TODO: more stringent checks on the shape of the signature; better errors + match (SS.compress signature_un).n with + | Tm_arrow {bs=[({binder_bv=a})]; comp=effect_marker} -> + a, effect_marker + | _ -> + raise_error Errors.Fatal_BadSignatureShape "bad shape for effect-for-free signature" + in + + (* TODO : having "_" as a variable name can create a really strange shadowing + behaviour between uu___ variables in the tcterm ; needs to be investigated *) + let a = + if S.is_null_bv a + then S.gen_bv "a" (Some (S.range_of_bv a)) a.sort + else a + in + + let open_and_check env other_binders t = + let subst = SS.opening_of_binders (effect_binders @ other_binders) in + let t = SS.subst subst t in + let t, comp, _ = TcTerm.tc_term env t in + t, comp + in + let mk x = mk x signature.pos in + + // TODO: check that [_comp] is [Tot Type] + let repr, _comp = open_and_check env [] (ed |> U.get_eff_repr |> must |> snd) in + if !dbg then + BU.print1 "Representation is: %s\n" (show repr); + + let ed_range = Env.get_range env in + + let dmff_env = empty env (TcTerm.tc_constant env Range.dummyRange) in + let wp_type = star_type dmff_env repr in + let _ = recheck_debug "*" env wp_type in + let wp_a = N.normalize [ Env.Beta ] env (mk (Tm_app {hd=wp_type; args=[ (S.bv_to_name a, S.as_aqual_implicit false) ]})) in + + // Building: [a -> wp a -> Effect] + let effect_signature = + let binders = [ S.mk_binder_with_attrs a (S.as_bqual_implicit false) None []; + S.gen_bv "dijkstra_wp" None wp_a |> S.mk_binder ] in + let binders = close_binders binders in + mk (Tm_arrow {bs=binders; comp=effect_marker}) + in + let _ = recheck_debug "turned into the effect signature" env effect_signature in + + let sigelts = BU.mk_ref [] in + let mk_lid name : lident = U.dm4f_lid ed name in + + // TODO: we assume that reading the top-level definitions in the order that + // they come in the effect definition is enough... probably not + let elaborate_and_star dmff_env other_binders item = + let env = get_env dmff_env in + let u_item, item = item in + // TODO: assert no universe polymorphism + let item, item_comp = open_and_check env other_binders item in + if not (TcComm.is_total_lcomp item_comp) then + raise_error0 Errors.Fatal_ComputationNotTotal (BU.format2 "Computation for [%s] is not total : %s !" (show item) (TcComm.lcomp_to_string item_comp)); + let item_t, item_wp, item_elab = star_expr dmff_env item in + let _ = recheck_debug "*" env item_wp in + let _ = recheck_debug "_" env item_elab in + dmff_env, item_t, item_wp, item_elab + in + + let dmff_env, _, bind_wp, bind_elab = + elaborate_and_star dmff_env [] (ed |> U.get_bind_repr |> must) in + let dmff_env, _, return_wp, return_elab = + elaborate_and_star dmff_env [] (ed |> U.get_return_repr |> must) in + let rc_gtot = { + residual_effect = PC.effect_GTot_lid; + residual_typ = None; + residual_flags = [] + } in + + (* Starting from [return_wp (b1:Type) (b2:b1) : M.wp b1 = fun bs -> body <: Type0], we elaborate *) + (* [lift_from_pure (b1:Type) (wp:(b1 -> Type0)-> Type0) : M.wp b1 = fun bs -> wp (fun b2 -> body)] *) + let lift_from_pure_wp = + match (SS.compress return_wp).n with + | Tm_abs {bs=b1 :: b2 :: bs; body; rc_opt=what} -> + let b1,b2, body = + match SS.open_term [b1 ; b2] (U.abs bs body None) with + | [b1 ; b2], body -> b1, b2, body + | _ -> failwith "Impossible : open_term not preserving binders arity" + in + (* WARNING : pushing b1 and b2 in env might break the well-typedness *) + (* invariant but we need them for normalization *) + let env0 = push_binders (get_env dmff_env) [b1 ; b2] in + let wp_b1 = + let raw_wp_b1 = mk (Tm_app {hd=wp_type; args=[ (S.bv_to_name b1.binder_bv, S.as_aqual_implicit false) ]}) in + N.normalize [ Env.Beta ] env0 raw_wp_b1 + in + let bs, body, what' = U.abs_formals <| N.eta_expand_with_type env0 body (U.unascribe wp_b1) in + + (* We check that what' is Tot Type0 *) + let fail () = + let error_msg = + BU.format2 "The body of return_wp (%s) should be of type Type0 but is of type %s" + (show body) + (match what' with + | None -> "None" + | Some rc -> FStarC.Ident.string_of_lid rc.residual_effect) + in raise_error Errors.Fatal_WrongBodyTypeForReturnWP error_msg + in + begin match what' with + | None -> fail () + | Some rc -> + if not (U.is_pure_effect rc.residual_effect) then fail (); + BU.map_opt rc.residual_typ (fun rt -> + let g_opt = Rel.try_teq true env rt U.ktype0 in + match g_opt with + | Some g' -> Rel.force_trivial_guard env g' + | None -> fail ()) |> ignore + end ; + + let wp = + let t2 = b2.binder_bv.sort in + let pure_wp_type = double_star t2 in + S.gen_bv "wp" None pure_wp_type + in + + (* fun b1 wp -> (fun bs@bs'-> wp (fun b2 -> body $$ Type0) $$ Type0) $$ wp_a *) + let body = mk_Tm_app (S.bv_to_name wp) [U.abs [b2] body what', None] ed_range in + U.abs ([ b1; S.mk_binder wp ]) + (U.abs (bs) body what) + (Some rc_gtot) + + | _ -> + raise_error Errors.Fatal_UnexpectedReturnShape "unexpected shape for return" + in + + let return_wp = + // TODO: fix [tc_eff_decl] to deal with currying + match (SS.compress return_wp).n with + | Tm_abs {bs=b1 :: b2 :: bs; body; rc_opt=what} -> + U.abs ([ b1; b2 ]) (U.abs bs body what) (Some rc_gtot) + | _ -> + raise_error Errors.Fatal_UnexpectedReturnShape "unexpected shape for return" + in + let bind_wp = + match (SS.compress bind_wp).n with + | Tm_abs {bs=binders; body; rc_opt=what} -> + // TODO: figure out how to deal with ranges + //let r = S.lid_and_dd_as_fv PC.range_lid None in + U.abs binders body what + | _ -> + raise_error Errors.Fatal_UnexpectedBindShape "unexpected shape for bind" + in + + let apply_close t = + if List.length effect_binders = 0 then + t + else + close effect_binders (mk (Tm_app {hd=t; args=snd (U.args_of_binders effect_binders)})) + in + let rec apply_last f l = match l with + | [] -> failwith "impossible: empty path.." + | [a] -> [f a] + | (x::xs) -> x :: (apply_last f xs) + in + let register maybe_admit name item = + let maybe_admit = true in + let p = path_of_lid ed.mname in + let p' = apply_last (fun s -> "__" ^ s ^ "_eff_override_" ^ name) p in + let l' = lid_of_path p' ed_range in + match try_lookup_lid env l' with + | Some (_us,_t) -> begin + if Debug.any () then + BU.print1 "DM4F: Applying override %s\n" (string_of_lid l'); + fv_to_tm (lid_and_dd_as_fv l' None) + end + | None -> + let sigelt, fv = mk_toplevel_definition env (mk_lid name) (U.abs effect_binders item None) in + let sigelt = + if maybe_admit + then { sigelt with sigmeta={sigelt.sigmeta with sigmeta_admit=true}} + else sigelt + in + sigelts := sigelt :: !sigelts; + fv + in + let register_admit = register true in + let register = register false in + let lift_from_pure_wp = register "lift_from_pure" lift_from_pure_wp in + let mk_sigelt se = { mk_sigelt se with sigrng=ed_range } in + // we do not expect the return_elab to verify, + // since that may require internalizing monotonicity of WPs (i.e. continuation monad) + // so we use register_admit which sets sigmeta_admit=true + let return_wp = register "return_wp" return_wp in + let return_elab = register_admit "return_elab" return_elab in + + // we do not expect the bind to verify, since that requires internalizing monotonicity of WPs + let bind_wp = register "bind_wp" bind_wp in + let bind_elab = register_admit "bind_elab" bind_elab in + + let dmff_env, actions = List.fold_left (fun (dmff_env, actions) action -> + let params_un = SS.open_binders action.action_params in + let action_params, env', _ = TcTerm.tc_tparams (get_env dmff_env) params_un in + let action_params = List.map (fun b -> + { b with binder_bv={b.binder_bv with sort= + N.normalize [ Env.EraseUniverses ] env' b.binder_bv.sort } } + ) action_params in + let dmff_env' = set_env dmff_env env' in + // We need to reverse-engineer what tc_eff_decl wants here... + let dmff_env, action_t, action_wp, action_elab = + elaborate_and_star dmff_env' action_params (action.action_univs, action.action_defn) + in + let name = string_of_id (ident_of_lid action.action_name) in + let action_typ_with_wp = trans_F dmff_env' action_t action_wp in + let action_params = SS.close_binders action_params in + let action_elab = SS.close action_params action_elab in + let action_typ_with_wp = SS.close action_params action_typ_with_wp in + let action_elab = abs action_params action_elab None in + let action_typ_with_wp = + match action_params with + | [] -> action_typ_with_wp + | _ -> flat_arrow action_params (S.mk_Total action_typ_with_wp) + in + if !dbg + then BU.print4 "original action_params %s, end action_params %s, type %s, term %s\n" + (show params_un) + (show action_params) + (show action_typ_with_wp) + (show action_elab); + let action_elab = register (name ^ "_elab") action_elab in + let action_typ_with_wp = register (name ^ "_complete_type") action_typ_with_wp in + (* it does not seem that dmff_env' has been modified by elaborate_and_star so it should be okay to return the original env *) + dmff_env, + { action with + action_params = [] ; + action_defn = apply_close action_elab; + action_typ = apply_close action_typ_with_wp + } :: actions + ) (dmff_env, []) ed.actions in + let actions = List.rev actions in + + let repr = + let wp = S.gen_bv "wp_a" None wp_a in + let binders = [ S.mk_binder a; S.mk_binder wp ] in + U.abs binders (trans_F dmff_env (mk (Tm_app {hd=repr; args=[ S.bv_to_name a, S.as_aqual_implicit false ]})) (S.bv_to_name wp)) None + in + let _ = recheck_debug "FC" env repr in + let repr = register "repr" repr in + + (* We are still lacking a principled way to generate pre/post condition *) + (* Current algorithm takes the type of wps : fun (a: Type) -> (t1 -> t2 ... -> tn -> Type0) *) + (* Checks that there is exactly one ti containing the type variable a and returns that ti *) + (* as type of postconditons, the rest as type of preconditions *) + let pre, post = + match (unascribe <| SS.compress wp_type).n with + | Tm_abs {bs=type_param :: effect_param; body=arrow} -> + let type_param , effect_param, arrow = + match SS.open_term (type_param :: effect_param) arrow with + | (b :: bs), body -> b, bs, body + | _ -> failwith "Impossible : open_term nt preserving binders arity" + in + begin match (unascribe <| SS.compress arrow).n with + | Tm_arrow {bs=wp_binders; comp=c} -> + let wp_binders, c = SS.open_comp wp_binders c in + let pre_args, post_args = + List.partition (fun ({binder_bv=bv}) -> + Free.names bv.sort |> mem type_param.binder_bv |> not + ) wp_binders + in + let post = match post_args with + | [post] -> post + | [] -> + let err_msg = + BU.format1 "Impossible to generate DM effect: no post candidate %s (Type variable does not appear)" + (show arrow) + in + raise_error0 Errors.Fatal_ImpossibleToGenerateDMEffect err_msg + | _ -> + let err_msg = + BU.format1 "Impossible to generate DM effect: multiple post candidates %s" (show arrow) + in + raise_error0 Errors.Fatal_ImpossibleToGenerateDMEffect err_msg + in + // Pre-condition does not mention the return type; don't close over it + U.arrow pre_args c, + // Post-condition does, however! + U.abs (type_param :: effect_param) post.binder_bv.sort None + | _ -> + raise_error Errors.Fatal_ImpossiblePrePostArrow (BU.format1 "Impossible: pre/post arrow %s" (show arrow)) + end + | _ -> + raise_error Errors.Fatal_ImpossiblePrePostAbs (BU.format1 "Impossible: pre/post abs %s" (show wp_type)) + in + // Desugaring is aware of these names and generates references to them when + // the user writes something such as [STINT.repr] + ignore (register "pre" pre); + ignore (register "post" post); + ignore (register "wp" wp_type); + + let ed_combs = match ed.combinators with + | DM4F_eff combs -> + DM4F_eff ({ combs with + ret_wp = [], apply_close return_wp; + bind_wp = [], apply_close bind_wp; + repr = Some ([], apply_close repr); + return_repr = Some ([], apply_close return_elab); + bind_repr = Some ([], apply_close bind_elab) }) + | _ -> failwith "Impossible! For a DM4F effect combinators must be in DM4f_eff" in + + let ed = { ed with + signature = WP_eff_sig ([], close effect_binders effect_signature); + binders = close_binders effect_binders; + combinators = ed_combs; + actions = actions; // already went through apply_close + } in + + + // Generate the missing combinators. + let sigelts', ed = gen_wps_for_free env effect_binders a wp_a ed in + if !dbg then + BU.print_string (show ed); + + let lift_from_pure_opt = + if List.length effect_binders = 0 then begin + // Won't work with parameterized effect + let lift_from_pure = { + source = PC.effect_PURE_lid; + target = ed.mname ; + lift_wp = Some ([], apply_close lift_from_pure_wp) ; + lift = None; //Some ([], apply_close return_elab) + kind = None; + } in + Some (mk_sigelt (Sig_sub_effect (lift_from_pure))) + end else None + in + + List.rev !sigelts @ sigelts', ed, lift_from_pure_opt diff --git a/src/typechecker/FStarC.TypeChecker.DMFF.fsti b/src/typechecker/FStarC.TypeChecker.DMFF.fsti new file mode 100644 index 00000000000..faafe9f6e91 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.DMFF.fsti @@ -0,0 +1,34 @@ +(* + Copyright 2008-2014 Microsoft Research + + Authors: Jonathan Protzenko, Nikhil Swamy + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.TypeChecker.DMFF +open FStarC.Compiler.Effect +open FStarC.TypeChecker +open FStarC.Syntax.Syntax + +new val env : Type0 + +val empty : Env.env -> (sconst -> typ) -> env +val get_env: env -> Env.env +val set_env : env -> Env.env -> env +val gen_wps_for_free: Env.env -> binders -> bv -> term -> eff_decl -> sigelts & eff_decl +val double_star: typ -> typ +val star_type: env -> typ -> typ +val star_expr: env -> term -> typ & term & term +val trans_F : env -> typ -> term -> term +val recheck_debug : string -> FStarC.TypeChecker.Env.env -> term -> term +val cps_and_elaborate : FStarC.TypeChecker.Env.env -> eff_decl -> (list sigelt & eff_decl & option sigelt) diff --git a/src/typechecker/FStarC.TypeChecker.DeferredImplicits.fst b/src/typechecker/FStarC.TypeChecker.DeferredImplicits.fst new file mode 100644 index 00000000000..f0d3fbe073e --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.DeferredImplicits.fst @@ -0,0 +1,303 @@ +(* + Copyright 2020 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + + Authors: Nikhil Swamy +*) + +module FStarC.TypeChecker.DeferredImplicits +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.Errors +open FStarC.TypeChecker +open FStarC.Syntax +open FStarC.TypeChecker.Env +open FStarC.Syntax.Syntax +open FStarC.Syntax.Subst +open FStarC.Ident +open FStarC.TypeChecker.Common +open FStarC.Syntax +module BU = FStarC.Compiler.Util +module S = FStarC.Syntax.Syntax +module U = FStarC.Syntax.Util +module SS = FStarC.Syntax.Subst +module TEQ = FStarC.TypeChecker.TermEqAndSimplify + +open FStarC.Class.Setlike +open FStarC.Class.Show +module Listlike = FStarC.Class.Listlike + +let is_flex t = + let head, _args = U.head_and_args_full t in + match (SS.compress head).n with + | Tm_uvar _ -> true + | _ -> false + +let flex_uvar_head t = + let head, _args = U.head_and_args_full t in + match (SS.compress head).n with + | Tm_uvar (u, _) -> u + | _ -> failwith "Not a flex-uvar" + +type goal_type = + | FlexRigid of ctx_uvar & term + | FlexFlex of ctx_uvar & ctx_uvar + | Can_be_split_into of term & term & ctx_uvar + | Imp of ctx_uvar + +(* + If [u] is tagged with attribute [a] + + We look in the context for definitions tagged with [@@resolve_implicits; a] + These are the initial [candidates] + + We filter the [candidates] to find a unique candidate [c], such that + [c] is not overridden and it overrides all other all other + [candidates]. + + A candidate [c] overriders [c'] if [c] contains the attribute + + override_resolve_implicits_handler a [l] + + and [l] contains the name of [c] + + If no candidates are found we return None + If no unique [c] exists we warn and return None +*) +let find_user_tac_for_uvar env (u:ctx_uvar) : option sigelt = + (* This tries to unembed a Cons (Tm_constant (Const_string s1)) + ... + Cons (Tm_constant (Const_string sn)) + Nil + to [s1;..;sn] + + It's a bit ugly because the term it is applied to [e] + is just an attribute, and so it is not actually a type-correct term. + + So, the type arguments of the Cons may be missing *) + let rec attr_list_elements (e:term) : option (list string) = + let head, args = U.head_and_args (U.unmeta e) in + match (U.un_uinst head).n, args with + | Tm_fvar fv, _ when fv_eq_lid fv FStarC.Parser.Const.nil_lid -> + Some [] + | Tm_fvar fv, [_; (hd, _); (tl, _)] + | Tm_fvar fv, [(hd, _); (tl, _)] + when fv_eq_lid fv FStarC.Parser.Const.cons_lid -> + (match hd.n with + | Tm_constant (FStarC.Const.Const_string (s, _)) -> + (match attr_list_elements tl with + | None -> None + | Some tl -> Some (s::tl)) + | _ -> None) + | _ -> + None + in + let candidate_names candidates = + List.collect U.lids_of_sigelt candidates + |> List.map string_of_lid + |> String.concat ", " + in + match u.ctx_uvar_meta with + | Some (Ctx_uvar_meta_attr a) -> + (* hooks: all definitions with the resolve_implicits attr *) + let hooks = Env.lookup_attr env FStarC.Parser.Const.resolve_implicits_attr_string in + (* candidates: hooks that also have the attribute [a] *) + let candidates = + hooks |> List.filter + (fun hook -> hook.sigattrs |> BU.for_some (TEQ.eq_tm_bool env a)) + in + (* The environment sometimes returns duplicates in the candidate list; filter out dups *) + let candidates = + BU.remove_dups + (fun s0 s1 -> + let l0 = U.lids_of_sigelt s0 in + let l1 = U.lids_of_sigelt s1 in + if List.length l0 = List.length l1 + then List.forall2 (fun l0 l1 -> Ident.lid_equals l0 l1) l0 l1 + else false) + candidates + in + (* Checking if a candidate is overridden, by scanning the list of all + candidates and seeing if any of them override it *) + let is_overridden (candidate:sigelt) + : bool + = (* A candidate may have more than one lid, in case it is a let rec + It is overridden if any of its names are overridden *) + let candidate_lids = U.lids_of_sigelt candidate in + candidates |> + BU.for_some + (fun (other:sigelt) -> + other.sigattrs |> + BU.for_some + (fun attr -> + let head, args = U.head_and_args attr in + match (U.un_uinst head).n, args with + | Tm_fvar fv, [_; (a', _); (overrides, _)] //type argument may be missing, since it is just an attr + | Tm_fvar fv, [(a', _); (overrides, _)] + when fv_eq_lid fv FStarC.Parser.Const.override_resolve_implicits_handler_lid + && TEQ.eq_tm_bool env a a' -> + //other has an attribute [@@override_resolve_implicits_handler a overrides] + begin + match attr_list_elements overrides with + | None -> false + | Some names -> + //if the overrides mention one of the candidate's names + //the candidate is overriden + names |> + BU.for_some (fun n -> + candidate_lids |> BU.for_some (fun l -> string_of_lid l = n)) + end + | _ -> false)) + in + let candidates = candidates |> List.filter (fun c -> not (is_overridden c)) in + begin + match candidates with + | [] -> None //no candidates + | [ c ] -> Some c //if there is a unique candidate return it + | _ -> //it is ambiguous; complain + let candidates = candidate_names candidates in + let attr = show a in + FStarC.Errors.log_issue u.ctx_uvar_range + FStarC.Errors.Warning_AmbiguousResolveImplicitsHook + (BU.format2 + "Multiple resolve_implicits hooks are eligible for attribute %s; \n\ + please resolve the ambiguity by using the `override_resolve_implicits_handler` attribute \ + to choose among these candidates {%s}" + attr candidates); + None + end + + | _ -> None + +let should_defer_uvar_to_user_tac env (u:ctx_uvar) = + if not env.enable_defer_to_tac + then false + else Some? (find_user_tac_for_uvar env u) + +let solve_goals_with_tac env g (deferred_goals:implicits) (tac:sigelt) = + Profiling.profile (fun () -> + let resolve_tac = + match tac.sigel with + | Sig_let {lids=[lid]} -> + let qn = Env.lookup_qname env lid in + let fv = S.lid_as_fv lid None in + let term = S.fv_to_tm (S.lid_as_fv lid None) in + term + | _ -> failwith "Resolve_tac not found" + in + let env = { env with enable_defer_to_tac = false } in + env.try_solve_implicits_hook env resolve_tac deferred_goals) + (Some (Ident.string_of_lid (Env.current_module env))) + "FStarC.TypeChecker.DeferredImplicits.solve_goals_with_tac" + +(** This functions is called in Rel.force_trivial_guard to solve all + goals in a guard that were deferred to a tactic *) +let solve_deferred_to_tactic_goals env g = + if not env.enable_defer_to_tac then g else + let deferred = g.deferred_to_tac in + (** A unification problem between two terms is presented to + a tactic as an equality goal between the terms. *) + let prob_as_implicit (_, reason, prob) + : implicit & sigelt = + match prob with + | TProb tp when tp.relation=EQ -> + let env, _ = Env.clear_expected_typ env in + let env = {env with gamma=tp.logical_guard_uvar.ctx_uvar_gamma} in + let env_lax = {env with admit=true; enable_defer_to_tac=false} in + let _, t_eq, _ = + //Prefer to use the type of the flex term to compute the + //type instantiation of the equality, since it is more efficient + let t = + if is_flex tp.lhs then tp.lhs + else tp.rhs + in + env.typeof_tot_or_gtot_term env_lax t true //AR: TODO: can we call type_of_well_typed? + in + let goal_ty = U.mk_eq2 (env.universe_of env_lax t_eq) t_eq tp.lhs tp.rhs in + let goal, ctx_uvar, _ = + Env.new_implicit_var_aux reason tp.lhs.pos env goal_ty Strict None false + in + let imp = + { imp_reason = ""; + imp_uvar = fst ctx_uvar; + imp_tm = goal; + imp_range = tp.lhs.pos + } + in + let sigelt = + if is_flex tp.lhs + then (match find_user_tac_for_uvar env (flex_uvar_head tp.lhs) with + | None -> if is_flex tp.rhs then find_user_tac_for_uvar env (flex_uvar_head tp.rhs) else None + | v -> v) + else if is_flex tp.rhs + then find_user_tac_for_uvar env (flex_uvar_head tp.rhs) + else None + in + begin + match sigelt with + | None -> + //it shouldn't have been deferred + failwith "Impossible: No tactic associated with deferred problem" + | Some se -> imp, se + end + | _ -> + //only equality problems are deferred + failwith "Unexpected problem deferred to tactic" + in + //Turn all the deferred problems into equality goals + let eqs = List.map prob_as_implicit (Listlike.to_list g.deferred_to_tac) in + //Also take any unsolved uvars in the guard implicits that are tagged + //with attributes + let more, imps = + List.fold_right + (fun imp (more, imps) -> + match Unionfind.find imp.imp_uvar.ctx_uvar_head with + | Some _ -> //aleady solved + more, imp::imps + | None -> + let se = find_user_tac_for_uvar env imp.imp_uvar in + match se with + | None -> //no tac for this one + more, imp::imps + | Some se -> + (imp, se)::more, imps) + (Listlike.to_list g.implicits) + ([], []) + in + (** Each implicit is associated with a sigelt. + Group them so that all implicits with the same associated sigelt + are in the same bucket *) + let bucketize (is:list (implicit & sigelt)) : list (implicits & sigelt) = + let map : BU.smap (implicits & sigelt) = BU.smap_create 17 in + List.iter + (fun (i, s) -> + match U.lid_of_sigelt s with + | None -> failwith "Unexpected: tactic without a name" + | Some l -> + let lstr = Ident.string_of_lid l in + match BU.smap_try_find map lstr with + | None -> BU.smap_add map lstr ([i], s) + | Some (is, s) -> + BU.smap_remove map lstr; + BU.smap_add map lstr (i::is, s)) + is; + BU.smap_fold map (fun _ is out -> is::out) [] + in + let buckets = bucketize (eqs@more) in + // Dispatch each bucket of implicits to their respective tactic + List.iter (fun (imps, sigel) -> solve_goals_with_tac env g imps sigel) buckets; + { g with deferred_to_tac=Listlike.empty; implicits = Class.Listlike.from_list imps} diff --git a/src/typechecker/FStarC.TypeChecker.DeferredImplicits.fsti b/src/typechecker/FStarC.TypeChecker.DeferredImplicits.fsti new file mode 100644 index 00000000000..291c1032669 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.DeferredImplicits.fsti @@ -0,0 +1,30 @@ +(* + Copyright 2020 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + + Authors: Nikhil Swamy, ... +*) +////////////////////////////////////////////////////////////////////////// +//Refinement subtyping with higher-order unification +//with special treatment for higher-order patterns +////////////////////////////////////////////////////////////////////////// + +module FStarC.TypeChecker.DeferredImplicits +open FStarC.Compiler.Effect +open FStarC.Syntax.Syntax +open FStarC.TypeChecker.Env +open FStarC.TypeChecker.Common + +val should_defer_uvar_to_user_tac : env -> ctx_uvar -> bool +val solve_deferred_to_tactic_goals: env -> guard_t -> guard_t diff --git a/src/typechecker/FStarC.TypeChecker.Env.fst b/src/typechecker/FStarC.TypeChecker.Env.fst new file mode 100644 index 00000000000..44f78f7c3a2 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Env.fst @@ -0,0 +1,2137 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.TypeChecker.Env +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.Syntax.Subst +open FStarC.Syntax.Util +open FStarC.Compiler.Util +open FStarC.Ident +open FStarC.Compiler.Range +open FStarC.Errors +open FStarC.TypeChecker.Common +open FStarC.Class.Setlike + +open FStarC.Class.Show +open FStarC.Class.PP +module Listlike = FStarC.Class.Listlike + +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module BU = FStarC.Compiler.Util +module U = FStarC.Syntax.Util +module UF = FStarC.Syntax.Unionfind +module Const = FStarC.Parser.Const +module TcComm = FStarC.TypeChecker.Common + +open FStarC.Defensive + +let dbg_ImplicitTrace = Debug.get_toggle "ImplicitTrace" +let dbg_LayeredEffectsEqns = Debug.get_toggle "LayeredEffectsEqns" + +let rec eq_step s1 s2 = + match s1, s2 with + | Beta, Beta + | Iota, Iota //pattern matching + | Zeta, Zeta //fixed points + | ZetaFull, ZetaFull //fixed points + | Weak, Weak //Do not descend into binders + | HNF, HNF //Only produce a head normal form + | Primops, Primops //reduce primitive operators like +, -, *, /, etc. + | Eager_unfolding, Eager_unfolding + | Inlining, Inlining + | DoNotUnfoldPureLets, DoNotUnfoldPureLets + | PureSubtermsWithinComputations, PureSubtermsWithinComputations + | Simplify, Simplify + | EraseUniverses, EraseUniverses + | AllowUnboundUniverses, AllowUnboundUniverses + | Reify, Reify + | CompressUvars, CompressUvars + | NoFullNorm, NoFullNorm + | CheckNoUvars, CheckNoUvars + | Unmeta, Unmeta + | Unascribe, Unascribe + | NBE, NBE + | Unrefine, Unrefine -> true + | Exclude s1, Exclude s2 -> eq_step s1 s2 + | UnfoldUntil s1, UnfoldUntil s2 -> s1 = s2 + | UnfoldOnly lids1, UnfoldOnly lids2 + | UnfoldFully lids1, UnfoldFully lids2 + | UnfoldAttr lids1, UnfoldAttr lids2 -> lids1 =? lids2 + | UnfoldQual strs1, UnfoldQual strs2 -> strs1 =? strs2 + | UnfoldNamespace strs1, UnfoldNamespace strs2 -> strs1 =? strs2 + | DontUnfoldAttr lids1, DontUnfoldAttr lids2 -> lids1 =? lids2 + | _ -> false // fixme: others ? + +instance deq_step : deq step = { + (=?) = eq_step; +} + +let rec step_to_string (s:step) : string = + match s with + | Beta -> "Beta" + | Iota -> "Iota" + | Zeta -> "Zeta" + | ZetaFull -> "ZetaFull" + | Exclude s1 -> "Exclude " ^ step_to_string s1 + | Weak -> "Weak" + | HNF -> "HNF" + | Primops -> "Primops" + | Eager_unfolding -> "Eager_unfolding" + | Inlining -> "Inlining" + | DoNotUnfoldPureLets -> "DoNotUnfoldPureLets" + | UnfoldUntil s1 -> "UnfoldUntil " ^ show s1 + | UnfoldOnly lids1 -> "UnfoldOnly " ^ show lids1 + | UnfoldFully lids1 -> "UnfoldFully " ^ show lids1 + | UnfoldAttr lids1 -> "UnfoldAttr " ^ show lids1 + | UnfoldQual strs1 -> "UnfoldQual " ^ show strs1 + | UnfoldNamespace strs1 -> "UnfoldNamespace " ^ show strs1 + | DontUnfoldAttr lids1 -> "DontUnfoldAttr " ^ show lids1 + | PureSubtermsWithinComputations -> "PureSubtermsWithinComputations" + | Simplify -> "Simplify" + | EraseUniverses -> "EraseUniverses" + | AllowUnboundUniverses -> "AllowUnboundUniverses" + | Reify -> "Reify" + | CompressUvars -> "CompressUvars" + | NoFullNorm -> "NoFullNorm" + | CheckNoUvars -> "CheckNoUvars" + | Unmeta -> "Unmeta" + | Unascribe -> "Unascribe" + | NBE -> "NBE" + | ForExtraction -> "ForExtraction" + | Unrefine -> "Unrefine" + | NormDebug -> "NormDebug" + | DefaultUnivsToZero -> "DefaultUnivsToZero" + | Tactics -> "Tactics" + +instance showable_step : showable step = { + show = step_to_string; +} + +instance deq_delta_level : deq delta_level = { + (=?) = (fun x y -> match x, y with + | NoDelta, NoDelta -> true + | InliningDelta, InliningDelta -> true + | Eager_unfolding_only, Eager_unfolding_only -> true + | Unfold x, Unfold y -> x =? y + | _ -> false); +} + +instance showable_delta_level : showable delta_level = { + show = (function + | NoDelta -> "NoDelta" + | InliningDelta -> "Inlining" + | Eager_unfolding_only -> "Eager_unfolding_only" + | Unfold d -> "Unfold " ^ show d); +} + +let preprocess env tau tm = env.mpreprocess env tau tm +let postprocess env tau ty tm = env.postprocess env tau ty tm + +let rename_gamma subst gamma = + gamma |> List.map (function + | Binding_var x -> begin + let y = Subst.subst subst (S.bv_to_name x) in + match (Subst.compress y).n with + | Tm_name y -> + // We don't want to change the type + Binding_var ({ y with sort = Subst.subst subst x.sort }) + | _ -> failwith "Not a renaming" + end + | b -> b) +let rename_env subst env = {env with gamma=rename_gamma subst env.gamma} +let default_tc_hooks = + { tc_push_in_gamma_hook = (fun _ _ -> ()) } +let tc_hooks (env: env) = env.tc_hooks +let set_tc_hooks env hooks = { env with tc_hooks = hooks } + +let set_dep_graph e g = {e with dsenv=DsEnv.set_dep_graph e.dsenv g} +let dep_graph e = DsEnv.dep_graph e.dsenv + +let record_val_for (e:env) (l:lident) : env = + { e with missing_decl = add l e.missing_decl } + +let record_definition_for (e:env) (l:lident) : env = + { e with missing_decl = remove l e.missing_decl } + +let missing_definition_list (e:env) : list lident = + elems e.missing_decl + +type sigtable = BU.smap sigelt + +let should_verify env = + not (Options.lax ()) + && not env.admit + && Options.should_verify (string_of_lid env.curmodule) + +let visible_at d q = match d, q with + | NoDelta, _ + | Eager_unfolding_only, Unfold_for_unification_and_vcgen + | Unfold _, Unfold_for_unification_and_vcgen + | Unfold _, Visible_default -> true + | InliningDelta, Inline_for_extraction -> true + | _ -> false + +let default_table_size = 200 +let new_sigtab () = BU.smap_create default_table_size +let new_gamma_cache () = BU.smap_create 100 + +let initial_env deps + tc_term + typeof_tot_or_gtot_term + typeof_tot_or_gtot_term_fastpath + universe_of + teq_nosmt_force + subtype_nosmt_force + solver module_lid nbe + core_check : env = + { solver=solver; + range=dummyRange; + curmodule=module_lid; + gamma= []; + gamma_sig = []; + gamma_cache=new_gamma_cache(); + modules= []; + expected_typ=None; + sigtab=new_sigtab(); + attrtab=new_sigtab(); + instantiate_imp=true; + effects={decls=[]; order=[]; joins=[]; polymonadic_binds=[]; polymonadic_subcomps=[]}; + generalize=true; + letrecs=[]; + top_level=false; + check_uvars=false; + use_eq_strict=false; + is_iface=false; + admit=false; + lax_universes=false; + phase1=false; + nocoerce=false; + failhard=false; + flychecking=false; + uvar_subtyping=true; + intactics=false; + + tc_term=tc_term; + typeof_tot_or_gtot_term=typeof_tot_or_gtot_term; + typeof_well_typed_tot_or_gtot_term = + (fun env t must_tot -> + match typeof_tot_or_gtot_term_fastpath env t must_tot with + | Some k -> k, trivial_guard + | None -> + let t', k, g = typeof_tot_or_gtot_term env t must_tot in + k, g); + universe_of=universe_of; + teq_nosmt_force=teq_nosmt_force; + subtype_nosmt_force=subtype_nosmt_force; + qtbl_name_and_index=None, BU.smap_create 10; + normalized_eff_names=BU.smap_create 20; //20? + fv_delta_depths = BU.smap_create 50; + proof_ns = Options.using_facts_from (); + synth_hook = (fun e g tau -> failwith "no synthesizer available"); + try_solve_implicits_hook = (fun e tau imps -> failwith "no implicit hook available"); + splice = (fun e is_typed lids tau range -> failwith "no splicer available"); + mpreprocess = (fun e tau tm -> failwith "no preprocessor available"); + postprocess = (fun e tau typ tm -> failwith "no postprocessor available"); + identifier_info=BU.mk_ref FStarC.TypeChecker.Common.id_info_table_empty; + tc_hooks = default_tc_hooks; + dsenv = FStarC.Syntax.DsEnv.empty_env deps; + nbe = nbe; + strict_args_tab = BU.smap_create 20; + erasable_types_tab = BU.smap_create 20; + enable_defer_to_tac=true; + unif_allow_ref_guards=false; + erase_erasable_args=false; + + core_check; + + missing_decl = empty(); + } + +let dsenv env = env.dsenv +let sigtab env = env.sigtab +let attrtab env = env.attrtab +let gamma_cache env = env.gamma_cache + +(* Marking and resetting the environment, for the interactive mode *) + +let query_indices: ref (list (list (lident & int))) = BU.mk_ref [[]] +let push_query_indices () = match !query_indices with // already signal-atmoic + | [] -> failwith "Empty query indices!" + | _ -> query_indices := (List.hd !query_indices)::!query_indices + +let pop_query_indices () = match !query_indices with // already signal-atmoic + | [] -> failwith "Empty query indices!" + | hd::tl -> query_indices := tl + +let snapshot_query_indices () = Common.snapshot push_query_indices query_indices () +let rollback_query_indices depth = Common.rollback pop_query_indices query_indices depth + +let add_query_index (l, n) = match !query_indices with + | hd::tl -> query_indices := ((l,n)::hd)::tl + | _ -> failwith "Empty query indices" + +let peek_query_indices () = List.hd !query_indices + +let stack: ref (list env) = BU.mk_ref [] +let push_stack env = + stack := env::!stack; + {env with sigtab=BU.smap_copy (sigtab env); + attrtab=BU.smap_copy (attrtab env); + gamma_cache=BU.smap_copy (gamma_cache env); + identifier_info=BU.mk_ref !env.identifier_info; + qtbl_name_and_index=env.qtbl_name_and_index |> fst, BU.smap_copy (env.qtbl_name_and_index |> snd); + normalized_eff_names=BU.smap_copy env.normalized_eff_names; + fv_delta_depths=BU.smap_copy env.fv_delta_depths; + strict_args_tab=BU.smap_copy env.strict_args_tab; + erasable_types_tab=BU.smap_copy env.erasable_types_tab } + +let pop_stack () = + match !stack with + | env::tl -> + stack := tl; + env + | _ -> failwith "Impossible: Too many pops" + +let snapshot_stack env = Common.snapshot push_stack stack env +let rollback_stack depth = Common.rollback pop_stack stack depth + +let snapshot env msg = BU.atomically (fun () -> + let stack_depth, env = snapshot_stack env in + let query_indices_depth, () = snapshot_query_indices () in + let solver_depth, () = env.solver.snapshot msg in + let dsenv_depth, dsenv = DsEnv.snapshot env.dsenv in + (stack_depth, query_indices_depth, solver_depth, dsenv_depth), { env with dsenv=dsenv }) + +let rollback solver msg depth = BU.atomically (fun () -> + let stack_depth, query_indices_depth, solver_depth, dsenv_depth = match depth with + | Some (s1, s2, s3, s4) -> Some s1, Some s2, Some s3, Some s4 + | None -> None, None, None, None in + let () = solver.rollback msg solver_depth in + let () = rollback_query_indices query_indices_depth in + let tcenv = rollback_stack stack_depth in + let dsenv = DsEnv.rollback dsenv_depth in + // Because of the way ``snapshot`` is implemented, the `tcenv` and `dsenv` + // that we rollback to should be consistent: + FStarC.Common.runtime_assert + (BU.physical_equality tcenv.dsenv dsenv) + "Inconsistent stack state"; + tcenv) + +let push env msg = snd (snapshot env msg) +let pop env msg = rollback env.solver msg None + +let incr_query_index env = + let qix = peek_query_indices () in + match env.qtbl_name_and_index with + | None, _ -> env + | Some (l, typ, n), tbl -> + match qix |> List.tryFind (fun (m, _) -> Ident.lid_equals l m) with + | None -> + let next = n + 1 in + add_query_index (l, next); + BU.smap_add tbl (string_of_lid l) next; + {env with qtbl_name_and_index=Some (l, typ, next), tbl} + | Some (_, m) -> + let next = m + 1 in + add_query_index (l, next); + BU.smap_add tbl (string_of_lid l) next; + {env with qtbl_name_and_index=Some (l, typ, next), tbl} + +//////////////////////////////////////////////////////////// +// Checking the per-module debug level and position info // +//////////////////////////////////////////////////////////// + +let set_range e r = if r=dummyRange then e else {e with range=r} +let get_range e = e.range + +instance hasRange_env : hasRange env = { + pos = get_range; + setPos = (fun r e -> set_range e r); +} + +let toggle_id_info env enabled = + env.identifier_info := + FStarC.TypeChecker.Common.id_info_toggle !env.identifier_info enabled +let insert_bv_info env bv ty = + env.identifier_info := + FStarC.TypeChecker.Common.id_info_insert_bv !env.identifier_info bv ty +let insert_fv_info env fv ty = + env.identifier_info := + FStarC.TypeChecker.Common.id_info_insert_fv !env.identifier_info fv ty +let promote_id_info env ty_map = + env.identifier_info := + FStarC.TypeChecker.Common.id_info_promote !env.identifier_info ty_map + +//////////////////////////////////////////////////////////// +// Private utilities // +//////////////////////////////////////////////////////////// +let modules env = env.modules +let current_module env = env.curmodule +let set_current_module env lid = {env with curmodule=lid} +let has_interface env l = env.modules |> BU.for_some (fun m -> m.is_interface && lid_equals m.name l) +let find_in_sigtab env lid = BU.smap_try_find (sigtab env) (string_of_lid lid) + +//Construct a new universe unification variable +let new_u_univ () = U_unif (UF.univ_fresh Range.dummyRange) + +let mk_univ_subst (formals : list univ_name) (us : universes) : list subst_elt = + assert (List.length us = List.length formals); + let n = List.length formals - 1 in + us |> List.mapi (fun i u -> UN (n - i, u)) + +//Instantiate the universe variables in a type scheme with provided universes +let inst_tscheme_with : tscheme -> universes -> universes & term = fun ts us -> + match ts, us with + | ([], t), [] -> [], t + | (formals, t), _ -> + let vs = mk_univ_subst formals us in + us, Subst.subst vs t + +//Instantiate the universe variables in a type scheme with new unification variables +let inst_tscheme : tscheme -> universes & term = function + | [], t -> [], t + | us, t -> + let us' = us |> List.map (fun _ -> new_u_univ()) in + inst_tscheme_with (us, t) us' + +let inst_tscheme_with_range (r:range) (t:tscheme) = + let us, t = inst_tscheme t in + us, Subst.set_use_range r t + +let check_effect_is_not_a_template (ed:eff_decl) (rng:Range.range) : unit = + if List.length ed.univs <> 0 || List.length ed.binders <> 0 + then + let msg = BU.format2 + "Effect template %s should be applied to arguments for its binders (%s) before it can be used at an effect position" + (show ed.mname) + (String.concat "," <| List.map Print.binder_to_string_with_type ed.binders) in + raise_error rng Errors.Fatal_NotEnoughArgumentsForEffect msg + +let inst_effect_fun_with (insts:universes) (env:env) (ed:eff_decl) (us, t) = + check_effect_is_not_a_template ed env.range; + if List.length insts <> List.length us + then failwith (BU.format4 "Expected %s instantiations; got %s; failed universe instantiation in effect %s\n\t%s\n" + (string_of_int <| List.length us) (string_of_int <| List.length insts) + (show ed.mname) (show t)); + snd (inst_tscheme_with (us, t) insts) + +type tri = + | Yes + | No + | Maybe + +let in_cur_mod env (l:lident) : tri = (* TODO: need a more efficient namespace check! *) + let cur = current_module env in + if nsstr l = (string_of_lid cur) then Yes (* fast case; works for everything except records *) + else if BU.starts_with (nsstr l) (string_of_lid cur) + then let lns = ns_of_lid l @ [ident_of_lid l] in + let cur = ns_of_lid cur @ [ident_of_lid cur] in + let rec aux c l = match c, l with + | [], _ -> Maybe + | _, [] -> No + | hd::tl, hd'::tl' when ((string_of_id hd = string_of_id hd')) -> aux tl tl' + | _ -> No in + aux cur lns + else No + +let lookup_qname env (lid:lident) : qninfo = + let cur_mod = in_cur_mod env lid in + let cache t = BU.smap_add (gamma_cache env) (string_of_lid lid) t; Some t in + let found = + if cur_mod <> No + then match BU.smap_try_find (gamma_cache env) (string_of_lid lid) with + | None -> + BU.catch_opt + (BU.find_map env.gamma (function + | Binding_lid(l, (us_names, t)) when lid_equals lid l-> + (* A recursive definition. + * We must return the exact set of universes on which + * it is being defined, and not instantiate it. + * TODO: could we cache this? *) + let us = List.map U_name us_names in + Some (Inl (us, t), Ident.range_of_lid l) + | _ -> None)) + (fun () -> BU.find_map env.gamma_sig (function + | (_, { sigel = Sig_bundle {ses} }) -> + BU.find_map ses (fun se -> + if lids_of_sigelt se |> BU.for_some (lid_equals lid) + then cache (Inr (se, None), U.range_of_sigelt se) + else None) + | (lids, s) -> + let maybe_cache t = match s.sigel with + | Sig_declare_typ _ -> Some t + | _ -> cache t + in + begin match List.tryFind (lid_equals lid) lids with + | None -> None + | Some l -> maybe_cache (Inr (s, None), Ident.range_of_lid l) + end)) + | se -> se + else None + in + if is_some found + then found + else match find_in_sigtab env lid with + | Some se -> Some (Inr (se, None), U.range_of_sigelt se) + | None -> None + +let lookup_sigelt (env:env) (lid:lid) : option sigelt = + match lookup_qname env lid with + | None -> None + | Some (Inl _, rng) -> None + | Some (Inr (se, us), rng) -> Some se + +let lookup_attr (env:env) (attr:string) : list sigelt = + match BU.smap_try_find (attrtab env) attr with + | Some ses -> ses + | None -> [] + +let add_se_to_attrtab env se = + let add_one env se attr = BU.smap_add (attrtab env) attr (se :: lookup_attr env attr) in + List.iter (fun attr -> + let hd, _ = U.head_and_args attr in + match (Subst.compress hd).n with + | Tm_fvar fv -> add_one env se (string_of_lid (lid_of_fv fv)) + | _ -> ()) se.sigattrs + +(* This adds a sigelt to the sigtab in the environment but checks +that we are not clashing with something that is already defined. +The force flag overrides the check, it's convenient in the checking for +haseq in inductives. *) +let try_add_sigelt force env se l = + let s = string_of_lid l in + if not force && Some? (BU.smap_try_find (sigtab env) s) then ( + let old_se = Some?.v (BU.smap_try_find (sigtab env) s) in + if Sig_declare_typ? old_se.sigel && + (Sig_let? se.sigel || Sig_inductive_typ? se.sigel || Sig_datacon? se.sigel) + then + (* overriding a val with a let, a type, or a datacon is ok *) + () + else ( + (* anything else is an error *) + let open FStarC.Errors.Msg in + let open FStarC.Pprint in + raise_error l Errors.Fatal_DuplicateTopLevelNames [ + text "Duplicate top-level names" ^/^ arbitrary_string s; + text "Previously declared at" ^/^ arbitrary_string (Range.string_of_range (range_of_lid l)); + // text "New decl = " ^/^ Print.sigelt_to_doc se; + // text "Old decl = " ^/^ Print.sigelt_to_doc old_se; + // backtrace_doc (); + ] + ) + ); + BU.smap_add (sigtab env) s se + +let rec add_sigelt force env se = match se.sigel with + | Sig_bundle {ses} -> add_sigelts force env ses + | _ -> + let lids = lids_of_sigelt se in + List.iter (try_add_sigelt force env se) lids; + add_se_to_attrtab env se + +and add_sigelts force env ses = + ses |> List.iter (add_sigelt force env) + +//////////////////////////////////////////////////////////// +// Lookup up various kinds of identifiers // +//////////////////////////////////////////////////////////// +let try_lookup_bv env (bv:bv) = + BU.find_map env.gamma (function + | Binding_var id when bv_eq id bv -> + Some (id.sort, (range_of_id id.ppname)) + | _ -> None) + +let lookup_type_of_let us_opt se lid = + let inst_tscheme ts = + match us_opt with + | None -> inst_tscheme ts + | Some us -> inst_tscheme_with ts us + in + match se.sigel with + | Sig_let {lbs=(_, [lb])} -> + Some (inst_tscheme (lb.lbunivs, lb.lbtyp), S.range_of_lbname lb.lbname) + + | Sig_let {lbs=(_, lbs)} -> + BU.find_map lbs (fun lb -> match lb.lbname with + | Inl _ -> failwith "impossible" + | Inr fv -> + if fv_eq_lid fv lid + then Some (inst_tscheme (lb.lbunivs, lb.lbtyp), S.range_of_fv fv) + else None) + + | _ -> None + +let effect_signature (us_opt:option universes) (se:sigelt) rng : option ((universes & typ) & Range.range) = + let inst_ts us_opt ts = + match us_opt with + | None -> inst_tscheme ts + | Some us -> inst_tscheme_with ts us + in + match se.sigel with + | Sig_new_effect ne -> + let sig_ts = U.effect_sig_ts ne.signature in + check_effect_is_not_a_template ne rng; + (match us_opt with + | None -> () + | Some us -> + if List.length us <> List.length (fst sig_ts) + then failwith ("effect_signature: incorrect number of universes for the signature of " ^ + (string_of_lid ne.mname) ^ ", expected " ^ (string_of_int (List.length (fst sig_ts))) ^ + ", got " ^ (string_of_int (List.length us))) + else ()); + + Some (inst_ts us_opt sig_ts, se.sigrng) + + | Sig_effect_abbrev {lid; us; bs=binders} -> + Some (inst_ts us_opt (us, U.arrow binders (mk_Total teff)), se.sigrng) + + | _ -> None + +let try_lookup_lid_aux us_opt env lid = + let inst_tscheme ts = + match us_opt with + | None -> inst_tscheme ts + | Some us -> inst_tscheme_with ts us + in + let mapper (lr, rng) = + match lr with + | Inl t -> + Some (t, rng) + + | Inr ({sigel = Sig_datacon {us=uvs; t} }, None) -> + Some (inst_tscheme (uvs, t), rng) + + | Inr ({sigel = Sig_declare_typ {lid=l; us=uvs; t}; sigquals=qs }, None) -> + if in_cur_mod env l = Yes + then if qs |> List.contains Assumption || env.is_iface + then Some (inst_tscheme (uvs, t), rng) + else None + else Some (inst_tscheme (uvs, t), rng) + + | Inr ({sigel = Sig_inductive_typ {lid; us=uvs; params=tps; t=k} }, None) -> + begin match tps with + | [] -> Some (inst_tscheme (uvs, k), rng) + | _ -> Some (inst_tscheme (uvs, U.flat_arrow tps (mk_Total k)), rng) + end + + | Inr ({sigel = Sig_inductive_typ {lid; us=uvs; params=tps; t=k} }, Some us) -> + begin match tps with + | [] -> Some (inst_tscheme_with (uvs, k) us, rng) + | _ -> Some (inst_tscheme_with (uvs, U.flat_arrow tps (mk_Total k)) us, rng) + end + + | Inr se -> + begin match se with // FIXME why does this branch not use rng? + | { sigel = Sig_let _ }, None -> + lookup_type_of_let us_opt (fst se) lid + + | _ -> + effect_signature us_opt (fst se) env.range + end |> BU.map_option (fun (us_t, rng) -> (us_t, rng)) + in + match BU.bind_opt (lookup_qname env lid) mapper with + | Some ((us, t), r) -> Some ((us, {t with pos=range_of_lid lid}), r) + | None -> None + +//////////////////////////////////////////////////////////////// +//External interaface for querying identifiers +//Provides, in order from the interface env.fsi: +// val lid_exists : env -> lident -> bool +// val lookup_bv : env -> bv -> typ +// val try_lookup_lid : env -> lident -> option (universes * typ) +// val lookup_lid : env -> lident -> (universes * typ) +// val lookup_univ : env -> univ_name -> bool +// val try_lookup_val_decl : env -> lident -> option (tscheme * list qualifier) +// val lookup_val_decl : env -> lident -> universes * typ +// val lookup_datacon : env -> lident -> universes * typ +// val datacons_of_typ : env -> lident -> bool * list lident +// val typ_of_datacon : env -> lident -> lident +// val lookup_definition : delta_level -> env -> lident -> option (univ_names * term) +// val lookup_attrs_of_lid : env -> lid -> option list attribute +// val try_lookup_effect_lid : env -> lident -> option term +// val lookup_effect_lid : env -> lident -> term +// val lookup_effect_abbrev : env -> universes -> lident -> option (binders * comp) +// val norm_eff_name : (env -> lident -> lident) +// val lookup_effect_quals : env -> lident -> list qualifier +// val lookup_projector : env -> lident -> int -> lident +// val current_module : env -> lident +// val is_projector : env -> lident -> bool +// val is_datacon : env -> lident -> bool +// val is_record : env -> lident -> bool +// val is_interpreted : (env -> term -> bool) +// val is_type_constructor : env -> lident -> bool +// val num_inductive_ty_params: env -> lident -> int +//Each of these functions that returns a term ensures to update +//the range information on the term with the currrent use-site +//////////////////////////////////////////////////////////////// + +let lid_exists env l = + match lookup_qname env l with + | None -> false + | Some _ -> true + +let lookup_bv env bv = + let bvr = range_of_bv bv in + match try_lookup_bv env bv with + | None -> raise_error bvr Errors.Fatal_VariableNotFound + (format1 "Variable \"%s\" not found" (show bv)) + | Some (t, r) -> Subst.set_use_range bvr t, + Range.set_use_range r (Range.use_range bvr) + +let try_lookup_lid env l = + match try_lookup_lid_aux None env l with + | None -> None + | Some ((us, t), r) -> + let use_range = range_of_lid l in + let r = Range.set_use_range r (Range.use_range use_range) in + Some ((us, Subst.set_use_range use_range t), r) + +let try_lookup_and_inst_lid env us l = + match try_lookup_lid_aux (Some us) env l with + | None -> None + | Some ((_, t), r) -> + let use_range = range_of_lid l in + let r = Range.set_use_range r (Range.use_range use_range) in + Some (Subst.set_use_range use_range t, r) + +let name_not_found (#a:Type) (l:lid) : a = + raise_error l Errors.Fatal_NameNotFound + (format1 "Name \"%s\" not found" (string_of_lid l)) + +let lookup_lid env l = + match try_lookup_lid env l with + | Some v -> v + | None -> name_not_found l + +let lookup_univ env x = + List.find (function + | Binding_univ y -> (string_of_id x = string_of_id y) + | _ -> false) env.gamma + |> Option.isSome + +let try_lookup_val_decl env lid = + //QUESTION: Why does this not inst_tscheme? + match lookup_qname env lid with + | Some (Inr ({ sigel = Sig_declare_typ {us=uvs; t}; sigquals = q }, None), _) -> + Some ((uvs, Subst.set_use_range (range_of_lid lid) t),q) + | _ -> None + +let lookup_val_decl env lid = + match lookup_qname env lid with + | Some (Inr ({ sigel = Sig_declare_typ {us=uvs; t} }, None), _) -> + inst_tscheme_with_range (range_of_lid lid) (uvs, t) + | _ -> name_not_found lid + +let lookup_datacon env lid = + match lookup_qname env lid with + | Some (Inr ({ sigel = Sig_datacon {us=uvs; t} }, None), _) -> + inst_tscheme_with_range (range_of_lid lid) (uvs, t) + | _ -> name_not_found lid + +let lookup_and_inst_datacon env us lid = + match lookup_qname env lid with + | Some (Inr ({ sigel = Sig_datacon {us=uvs; t} }, None), _) -> + inst_tscheme_with (uvs, t) us |> snd + | _ -> name_not_found lid + +let datacons_of_typ env lid = + match lookup_qname env lid with + | Some (Inr ({ sigel = Sig_inductive_typ {ds=dcs} }, _), _) -> true, dcs + | _ -> false, [] + +let typ_of_datacon env lid = + match lookup_qname env lid with + | Some (Inr ({ sigel = Sig_datacon {ty_lid=l} }, _), _) -> l + | _ -> failwith (BU.format1 "Not a datacon: %s" (show lid)) + +let num_datacon_non_injective_ty_params env lid = + match lookup_qname env lid with + | Some (Inr ({ sigel = Sig_datacon {num_ty_params; injective_type_params} }, _), _) -> + if injective_type_params then Some 0 else Some num_ty_params + | _ -> None + +let visible_with delta_levels quals = + delta_levels |> BU.for_some (fun dl -> quals |> BU.for_some (visible_at dl)) + +let lookup_definition_qninfo_aux rec_ok delta_levels lid (qninfo : qninfo) = + match qninfo with + | Some (Inr (se, None), _) -> + begin match se.sigel with + | Sig_let {lbs=(is_rec, lbs)} + when visible_with delta_levels se.sigquals + && (not is_rec || rec_ok) -> + BU.find_map lbs (fun lb -> + let fv = right lb.lbname in + if fv_eq_lid fv lid + then Some (lb.lbunivs, lb.lbdef) + else None) + | _ -> None + end + | _ -> None + +let lookup_definition_qninfo delta_levels lid (qninfo : qninfo) = + lookup_definition_qninfo_aux true delta_levels lid qninfo + +let lookup_definition delta_levels env lid = + lookup_definition_qninfo delta_levels lid <| lookup_qname env lid + +let lookup_nonrec_definition delta_levels env lid = + lookup_definition_qninfo_aux false delta_levels lid <| lookup_qname env lid + +let rec delta_depth_of_qninfo_lid env lid (qn:qninfo) : delta_depth = + match qn with + | None + | Some (Inl _, _) -> delta_constant + | Some (Inr(se, _), _) -> + match se.sigel with + | Sig_inductive_typ _ + | Sig_bundle _ + | Sig_datacon _ -> delta_constant + + | Sig_declare_typ _ -> + let d0 = + if U.is_primop_lid lid + then delta_equational + else delta_constant + in + if se.sigquals |> BU.for_some (Assumption?) + && not (se.sigquals |> BU.for_some (New?)) + then Delta_abstract d0 + else d0 + + | Sig_let {lbs=(_,lbs)} -> + BU.find_map lbs (fun lb -> + let fv = right lb.lbname in + if fv_eq_lid fv lid then + Some (incr_delta_depth <| delta_depth_of_term env lb.lbdef) + else None) |> must + + | Sig_fail _ + | Sig_splice _ -> + failwith "impossible: delta_depth_of_qninfo" + + | Sig_assume _ + | Sig_new_effect _ + | Sig_sub_effect _ + | Sig_effect_abbrev _ (* None? *) + | Sig_pragma _ + | Sig_polymonadic_bind _ + | Sig_polymonadic_subcomp _ -> + delta_constant + +and delta_depth_of_qninfo env (fv:fv) (qn:qninfo) : delta_depth = + delta_depth_of_qninfo_lid env fv.fv_name.v qn + +(* Computes the canonical delta_depth of a given fvar, by looking at its +definition (and recursing) if needed. Results are memoized in the env. + +NB: The cache is never invalidated. A potential problem here would be +if we memoize the delta_depth of a `val` before seeing the corresponding +`let`, but I don't think that can happen. Before seeing the `let`, other code +cannot refer to the name. *) +and delta_depth_of_fv (env:env) (fv:S.fv) : delta_depth = + let lid = fv.fv_name.v in + (string_of_lid lid) |> BU.smap_try_find env.fv_delta_depths |> (function + | Some dd -> dd + | None -> + BU.smap_add env.fv_delta_depths (string_of_lid lid) delta_equational; + // ^ To prevent an infinite loop on recursive functions, we pre-seed the cache with + // a delta_equational. If we run into the same function while computing its delta_depth, + // we will return delta_equational. If not, we override the cache with the correct delta_depth. + let d = delta_depth_of_qninfo env fv (lookup_qname env fv.fv_name.v) in + // if Debug.any () then + // BU.print2_error "Memoizing delta_depth_of_fv %s ->\t%s\n" (show lid) (show d); + BU.smap_add env.fv_delta_depths (string_of_lid lid) d; + d) + +(* Computes the delta_depth of an fv, but taking into account the visibility +in the current module. *) +and fv_delta_depth (env:env) (fv:S.fv) : delta_depth = + let d = delta_depth_of_fv env fv in + match d with + | Delta_abstract (Delta_constant_at_level l) -> + if string_of_lid env.curmodule = nsstr fv.fv_name.v && not env.is_iface + //AR: TODO: this is to prevent unfolding of abstract symbols in the extracted interface + //a better way would be create new fvs with appripriate delta_depth at extraction time + then Delta_constant_at_level l //we're in the defining module + else delta_constant + | d -> d + +(* Computes the delta_depth of a term. This is the single way to compute it. *) +and delta_depth_of_term env t = + let t = U.unmeta t in + match t.n with + | Tm_meta _ + | Tm_delayed _ -> failwith "Impossible (delta depth of term)" + | Tm_lazy i -> delta_depth_of_term env (U.unfold_lazy i) + + | Tm_fvar fv -> fv_delta_depth env fv + + | Tm_bvar _ + | Tm_name _ + | Tm_match _ + | Tm_uvar _ + | Tm_unknown -> delta_equational + + | Tm_type _ + | Tm_quoted _ + | Tm_constant _ + | Tm_arrow _ -> delta_constant + + | Tm_uinst(t, _) + | Tm_refine {b={sort=t}} + | Tm_ascribed {tm=t} + | Tm_app {hd=t} + | Tm_abs {body=t} + | Tm_let {body=t} -> delta_depth_of_term env t + +let quals_of_qninfo (qninfo : qninfo) : option (list qualifier) = + match qninfo with + | Some (Inr (se, _), _) -> Some se.sigquals + | _ -> None + +let attrs_of_qninfo (qninfo : qninfo) : option (list attribute) = + match qninfo with + | Some (Inr (se, _), _) -> Some se.sigattrs + | _ -> None + +let lookup_attrs_of_lid env lid : option (list attribute) = + attrs_of_qninfo <| lookup_qname env lid + +let fv_exists_and_has_attr env fv_lid attr_lid : bool & bool = + match lookup_attrs_of_lid env fv_lid with + | None -> + false, false + | Some attrs -> + true, + attrs |> BU.for_some (fun tm -> + match (U.un_uinst tm).n with + | Tm_fvar fv -> S.fv_eq_lid fv attr_lid + | _ -> false) + +let fv_with_lid_has_attr env fv_lid attr_lid : bool = + snd (fv_exists_and_has_attr env fv_lid attr_lid) + +let fv_has_attr env fv attr_lid = + fv_with_lid_has_attr env fv.fv_name.v attr_lid + +let cache_in_fv_tab (tab:BU.smap 'a) (fv:fv) (f:unit -> (bool & 'a)) : 'a = + let s = string_of_lid (S.lid_of_fv fv) in + match BU.smap_try_find tab s with + | None -> + let should_cache, res = f () in + if should_cache then BU.smap_add tab s res; + res + + | Some r -> + r + +let fv_has_erasable_attr env fv = + let f () = + let ex, erasable = fv_exists_and_has_attr env fv.fv_name.v Const.erasable_attr in + ex,erasable + //unfortunately, treating the Const.must_erase_for_extraction_attr + //in the same way here as erasable_attr leads to regressions in fragile proofs, + //notably in FStar.ModifiesGen, since this expands the class of computation types + //that can be promoted from ghost to tot. That in turn results in slightly different + //smt encodings, leading to breakages. So, sadly, I'm not including must_erase_for_extraction + //here. In any case, must_erase_for_extraction is transitionary and should be removed + in + cache_in_fv_tab env.erasable_types_tab fv f + +let fv_has_strict_args env fv = + let f () = + let attrs = lookup_attrs_of_lid env (S.lid_of_fv fv) in + match attrs with + | None -> false, None + | Some attrs -> + let res = + BU.find_map attrs (fun x -> + fst (FStarC.ToSyntax.ToSyntax.parse_attr_with_list + false x FStarC.Parser.Const.strict_on_arguments_attr)) + in + true, res + in + cache_in_fv_tab env.strict_args_tab fv f + +let try_lookup_effect_lid env (ftv:lident) : option typ = + match lookup_qname env ftv with + | Some (Inr (se, None), _) -> + begin match effect_signature None se env.range with + | None -> None + | Some ((_, t), r) -> Some (Subst.set_use_range (range_of_lid ftv) t) + end + | _ -> None + +let lookup_effect_lid env (ftv:lident) : typ = + match try_lookup_effect_lid env ftv with + | None -> name_not_found ftv + | Some k -> k + +let lookup_effect_abbrev env (univ_insts:universes) lid0 = + match lookup_qname env lid0 with + | Some (Inr ({ sigel = Sig_effect_abbrev {lid; us=univs; bs=binders; comp=c}; sigquals = quals }, None), _) -> + let lid = Ident.set_lid_range lid (Range.set_use_range (Ident.range_of_lid lid) (Range.use_range (Ident.range_of_lid lid0))) in + if quals |> BU.for_some (function Irreducible -> true | _ -> false) + then None + else let insts = if List.length univ_insts = List.length univs + then univ_insts + else failwith (BU.format3 "(%s) Unexpected instantiation of effect %s with %s universes" + (Range.string_of_range (get_range env)) + (show lid) + (List.length univ_insts |> BU.string_of_int)) in + begin match binders, univs with + | [], _ -> failwith "Unexpected effect abbreviation with no arguments" + | _, _::_::_ -> + failwith (BU.format2 "Unexpected effect abbreviation %s; polymorphic in %s universes" + (show lid) (string_of_int <| List.length univs)) + | _ -> let _, t = inst_tscheme_with (univs, U.arrow binders c) insts in + let t = Subst.set_use_range (range_of_lid lid) t in + begin match (Subst.compress t).n with + | Tm_arrow {bs=binders; comp=c} -> + Some (binders, c) + | _ -> failwith "Impossible" + end + end + | _ -> None + +let norm_eff_name = + fun env (l:lident) -> + let rec find l = + match lookup_effect_abbrev env [U_unknown] l with //universe doesn't matter here; we're just normalizing the name + | None -> None + | Some (_, c) -> + let l = U.comp_effect_name c in + match find l with + | None -> Some l + | Some l' -> Some l' in + let res = match BU.smap_try_find env.normalized_eff_names (string_of_lid l) with + | Some l -> l + | None -> + begin match find l with + | None -> l + | Some m -> BU.smap_add env.normalized_eff_names (string_of_lid l) m; + m + end in + Ident.set_lid_range res (range_of_lid l) + +let is_erasable_effect env l = + l + |> norm_eff_name env + |> (fun l -> lid_equals l Const.effect_GHOST_lid || + S.lid_as_fv l None + |> fv_has_erasable_attr env) + +let rec non_informative env t = + match (U.unrefine t).n with + | Tm_type _ -> true + | Tm_fvar fv -> + fv_eq_lid fv Const.unit_lid + || fv_eq_lid fv Const.squash_lid + || fv_eq_lid fv Const.erased_lid + || fv_has_erasable_attr env fv + | Tm_app {hd=head} -> non_informative env head + | Tm_uinst (t, _) -> non_informative env t + | Tm_arrow {comp=c} -> + (is_pure_or_ghost_comp c && non_informative env (comp_result c)) + || is_erasable_effect env (comp_effect_name c) + | _ -> false + +let num_effect_indices env name r = + let sig_t = name |> lookup_effect_lid env |> SS.compress in + match sig_t.n with + | Tm_arrow {bs=_a::bs} -> List.length bs + | _ -> + raise_error r Errors.Fatal_UnexpectedSignatureForMonad + (BU.format2 "Signature for %s not an arrow (%s)" (show name) (show sig_t)) + +let lookup_effect_quals env l = + let l = norm_eff_name env l in + match lookup_qname env l with + | Some (Inr ({ sigel = Sig_new_effect _; sigquals=q}, _), _) -> + q + | _ -> [] + +let lookup_projector env lid i = + let fail () = failwith (BU.format2 "Impossible: projecting field #%s from constructor %s is undefined" (BU.string_of_int i) (show lid)) in + let _, t = lookup_datacon env lid in + match (compress t).n with + | Tm_arrow {bs=binders} -> + if ((i < 0) || i >= List.length binders) //this has to be within bounds! + then fail () + else let b = List.nth binders i in + U.mk_field_projector_name lid b.binder_bv i + | _ -> fail () + +let is_projector env (l:lident) : bool = + match lookup_qname env l with + | Some (Inr ({ sigel = Sig_declare_typ _; sigquals=quals }, _), _) -> + BU.for_some (function Projector _ -> true | _ -> false) quals + | _ -> false + +let is_datacon env lid = + match lookup_qname env lid with + | Some (Inr ({ sigel = Sig_datacon _ }, _), _) -> true + | _ -> false + +let is_record env lid = + match lookup_qname env lid with + | Some (Inr ({ sigel = Sig_inductive_typ _; sigquals=quals }, _), _) -> + BU.for_some (function RecordType _ | RecordConstructor _ -> true | _ -> false) quals + | _ -> false + +let qninfo_is_action (qninfo : qninfo) = + match qninfo with + | Some (Inr ({ sigel = Sig_let _; sigquals = quals }, _), _) -> + BU.for_some (function Action _ -> true | _ -> false) quals + | _ -> false + +let is_action env lid = + qninfo_is_action <| lookup_qname env lid + +// FIXME? Does not use environment. +let is_interpreted = + let interpreted_symbols = + [Const.op_Eq; + Const.op_notEq; + Const.op_LT; + Const.op_LTE; + Const.op_GT; + Const.op_GTE; + Const.op_Subtraction; + Const.op_Minus; + Const.op_Addition; + Const.op_Multiply; + Const.op_Division; + Const.op_Modulus; + Const.op_And; + Const.op_Or; + Const.op_Negation] in + fun (env:env) head -> + match (U.un_uinst head).n with + | Tm_fvar fv -> + BU.for_some (Ident.lid_equals fv.fv_name.v) interpreted_symbols || + (match delta_depth_of_fv env fv with + | Delta_equational_at_level _ -> true + | _ -> false) + | _ -> false + +let is_irreducible env l = + match lookup_qname env l with + | Some (Inr (se, _), _) -> + BU.for_some (function Irreducible -> true | _ -> false) se.sigquals + | _ -> false + +let is_type_constructor env lid = + let mapper x = + match fst x with + | Inl _ -> Some false + | Inr (se, _) -> + begin match se.sigel with + | Sig_declare_typ _ -> + Some (List.contains New se.sigquals) + | Sig_inductive_typ _ -> + Some true + | _ -> Some false + end in + match BU.bind_opt (lookup_qname env lid) mapper with + | Some b -> b + | None -> false + +let num_inductive_ty_params env lid = + match lookup_qname env lid with + | Some (Inr ({ sigel = Sig_inductive_typ {params=tps} }, _), _) -> + Some (List.length tps) + | _ -> + None + +let num_inductive_uniform_ty_params env lid = + match lookup_qname env lid with + | Some (Inr ({ sigel = Sig_inductive_typ {num_uniform_params=num_uniform} }, _), _) -> + ( + match num_uniform with + | None -> + raise_error lid Errors.Fatal_UnexpectedInductivetype + (BU.format1 "Internal error: Inductive %s is not decorated with its uniform type parameters" + (show lid)) + | Some n -> Some n + ) + | _ -> + None + +//////////////////////////////////////////////////////////// +// Operations on the monad lattice // +//////////////////////////////////////////////////////////// +let effect_decl_opt env l = + env.effects.decls |> BU.find_opt (fun (d, _) -> lid_equals d.mname l) + +let get_effect_decl env l = + match effect_decl_opt env l with + | None -> name_not_found l + | Some md -> fst md + +let get_lid_valued_effect_attr env + (eff_lid attr_name_lid:lident) + (default_if_attr_has_no_arg:option lident) + : option lident + = let attr_args = + eff_lid |> norm_eff_name env + |> lookup_attrs_of_lid env + |> BU.dflt [] + |> U.get_attribute attr_name_lid in + match attr_args with + | None -> None + | Some args -> + if List.length args = 0 + then default_if_attr_has_no_arg + else args + |> List.hd + |> (fun (t, _) -> + match (SS.compress t).n with + | Tm_constant (FStarC.Const.Const_string (s, _)) -> s |> Ident.lid_of_str |> Some + | _ -> + raise_error t Errors.Fatal_UnexpectedEffect + (BU.format2 "The argument for the effect attribute for %s is not a constant string, it is %s\n" + (show eff_lid) + (show t))) + +let get_default_effect env lid = + get_lid_valued_effect_attr env lid Const.default_effect_attr None + +let get_top_level_effect env lid = + get_lid_valued_effect_attr env lid Const.top_level_effect_attr (Some lid) + +let is_layered_effect env l = + l |> get_effect_decl env |> U.is_layered + +let identity_mlift : mlift = + { mlift_wp=(fun _ c -> c, trivial_guard); + mlift_term=Some (fun _ _ e -> return_all e) } + +let join_opt env (l1:lident) (l2:lident) : option (lident & mlift & mlift) = + if lid_equals l1 l2 + then Some (l1, identity_mlift, identity_mlift) + else if lid_equals l1 Const.effect_GTot_lid && lid_equals l2 Const.effect_Tot_lid + || lid_equals l2 Const.effect_GTot_lid && lid_equals l1 Const.effect_Tot_lid + then Some (Const.effect_GTot_lid, identity_mlift, identity_mlift) + else match env.effects.joins |> BU.find_opt (fun (m1, m2, _, _, _) -> lid_equals l1 m1 && lid_equals l2 m2) with + | None -> None + | Some (_, _, m3, j1, j2) -> Some (m3, j1, j2) + +let join env l1 l2 : (lident & mlift & mlift) = + match join_opt env l1 l2 with + | None -> + raise_error env Errors.Fatal_EffectsCannotBeComposed + (BU.format2 "Effects %s and %s cannot be composed" (show l1) (show l2)) + | Some t -> t + +let monad_leq env l1 l2 : option edge = + if lid_equals l1 l2 + || (lid_equals l1 Const.effect_Tot_lid && lid_equals l2 Const.effect_GTot_lid) + then Some ({msource=l1; mtarget=l2; mlift=identity_mlift; mpath=[]}) + else env.effects.order |> BU.find_opt (fun e -> lid_equals l1 e.msource && lid_equals l2 e.mtarget) + +let wp_sig_aux decls m = + match decls |> BU.find_opt (fun (d, _) -> lid_equals d.mname m) with + | None -> failwith (BU.format1 "Impossible: declaration for monad %s not found" (string_of_lid m)) + | Some (md, _q) -> + (* + * AR: this code used to be inst_tscheme md.univs md.signature + * i.e. implicitly there was an assumption that ed.binders is empty + * now when signature is itself a tscheme, this just translates to the following + *) + let _, s = md.signature |> U.effect_sig_ts |> inst_tscheme in + let s = Subst.compress s in + match md.binders, s.n with + | [], Tm_arrow {bs=[b; wp_b]; comp=c} when (is_teff (comp_result c)) -> b.binder_bv, wp_b.binder_bv.sort + | _ -> failwith "Impossible" + +let wp_signature env m = wp_sig_aux env.effects.decls m + +let bound_vars_of_bindings bs = + bs |> List.collect (function + | Binding_var x -> [x] + | Binding_lid _ + | Binding_univ _ -> []) + +let binders_of_bindings bs = bound_vars_of_bindings bs |> List.map Syntax.mk_binder |> List.rev +let all_binders env = binders_of_bindings env.gamma +let bound_vars env = bound_vars_of_bindings env.gamma + +instance hasBinders_env : hasBinders env = { + boundNames = (fun e -> FlatSet.from_list (bound_vars e) ); +} + +instance hasNames_lcomp : hasNames lcomp = { + freeNames = (fun lc -> freeNames (fst (lcomp_comp lc))); +} + +instance pretty_lcomp : pretty lcomp = { + pp = (fun lc -> let open FStarC.Pprint in empty); +} + +instance hasNames_guard : hasNames guard_t = { + freeNames = (fun g -> match g.guard_f with + | Trivial -> FlatSet.empty () + | NonTrivial f -> freeNames f); +} + +instance pretty_guard : pretty guard_t = { + pp = (fun g -> let open FStarC.Pprint in + match g.guard_f with + | Trivial -> doc_of_string "Trivial" + | NonTrivial f -> doc_of_string "NonTrivial" ^/^ pp f); +} + +let comp_to_comp_typ (env:env) c = + def_check_scoped c.pos "comp_to_comp_typ" env c; + match c.n with + | Comp ct -> ct + | _ -> + let effect_name, result_typ = + match c.n with + | Total t -> Const.effect_Tot_lid, t + | GTotal t -> Const.effect_GTot_lid, t in + {comp_univs = [env.universe_of env result_typ]; + effect_name; + result_typ; + effect_args = []; + flags = U.comp_flags c} + +let comp_set_flags env c f = + def_check_scoped c.pos "comp_set_flags.IN" env c; + let r = {c with n=Comp ({comp_to_comp_typ env c with flags=f})} in + def_check_scoped c.pos "comp_set_flags.OUT" env r; + r + +let rec unfold_effect_abbrev env comp = + def_check_scoped comp.pos "unfold_effect_abbrev" env comp; + let c = comp_to_comp_typ env comp in + match lookup_effect_abbrev env c.comp_univs c.effect_name with + | None -> c + | Some (binders, cdef) -> + let binders, cdef = Subst.open_comp binders cdef in + if List.length binders <> List.length c.effect_args + 1 then + raise_error comp Errors.Fatal_ConstructorArgLengthMismatch + (BU.format3 "Effect constructor is not fully applied; expected %s args, got %s args, i.e., %s" + (show (List.length binders)) (show (List.length c.effect_args + 1)) + (show (S.mk_Comp c))); + let inst = List.map2 (fun b (t, _) -> NT(b.binder_bv, t)) binders (as_arg c.result_typ::c.effect_args) in + let c1 = Subst.subst_comp inst cdef in + let c = {comp_to_comp_typ env c1 with flags=c.flags} |> mk_Comp in + unfold_effect_abbrev env c + +let effect_repr_aux only_reifiable env c u_res = + let check_partial_application eff_name (args:args) = + let r = get_range env in + let given, expected = List.length args, num_effect_indices env eff_name r in + if given = expected then () + else + let message = BU.format3 "Not enough arguments for effect %s, \ + This usually happens when you use a partially applied DM4F effect, \ + like [TAC int] instead of [Tac int] (given:%s, expected:%s)." + (Ident.string_of_lid eff_name) (string_of_int given) (string_of_int expected) in + raise_error r Errors.Fatal_NotEnoughArgumentsForEffect message + in + + let effect_name = norm_eff_name env (U.comp_effect_name c) in + match effect_decl_opt env effect_name with + | None -> None + | Some (ed, _) -> + match ed |> U.get_eff_repr with + | None -> None + | Some ts -> + let c = unfold_effect_abbrev env c in + let res_typ = c.result_typ in + let repr = inst_effect_fun_with [u_res] env ed ts in + check_partial_application effect_name c.effect_args; + Some (S.mk (Tm_app {hd=repr; args=((res_typ |> S.as_arg)::c.effect_args)}) (get_range env)) + +let effect_repr env c u_res : option term = effect_repr_aux false env c u_res + +(* [is_reifiable_* env x] returns true if the effect name/computational *) +(* effect (of a body or codomain of an arrow) [x] is reifiable. *) + +(* [is_user_reifiable_* env x] is more restrictive, and only allows *) +(* reifying effects marked with the `reifiable` keyword. (For instance, TAC *) +(* is reifiable but not user-reifiable.) *) + +let is_user_reifiable_effect (env:env) (effect_lid:lident) : bool = + let effect_lid = norm_eff_name env effect_lid in + let quals = lookup_effect_quals env effect_lid in + List.contains Reifiable quals + +let is_user_reflectable_effect (env:env) (effect_lid:lident) : bool = + let effect_lid = norm_eff_name env effect_lid in + let quals = lookup_effect_quals env effect_lid in + quals |> List.existsb (function Reflectable _ -> true | _ -> false) + +let is_total_effect (env:env) (effect_lid:lident) : bool = + let effect_lid = norm_eff_name env effect_lid in + let quals = lookup_effect_quals env effect_lid in + List.contains TotalEffect quals + +let is_reifiable_effect (env:env) (effect_lid:lident) : bool = + let effect_lid = norm_eff_name env effect_lid in + is_user_reifiable_effect env effect_lid + || Ident.lid_equals effect_lid Const.effect_TAC_lid + +let is_reifiable_rc (env:env) (c:S.residual_comp) : bool = + is_reifiable_effect env c.residual_effect + +let is_reifiable_comp (env:env) (c:S.comp) : bool = + match c.n with + | Comp ct -> is_reifiable_effect env ct.effect_name + | _ -> false + +let is_reifiable_function (env:env) (t:S.term) : bool = + match (compress t).n with + | Tm_arrow {comp=c} -> is_reifiable_comp env c + | _ -> false + +let reify_comp env c u_c : term = + let l = U.comp_effect_name c in + if not (is_reifiable_effect env l) then + raise_error env Errors.Fatal_EffectCannotBeReified + (BU.format1 "Effect %s cannot be reified" (Ident.string_of_lid l)); + match effect_repr_aux true env c u_c with + | None -> failwith "internal error: reifiable effect has no repr?" + | Some tm -> tm + + +/////////////////////////////////////////////////////////// +// Introducing identifiers and updating the environment // +//////////////////////////////////////////////////////////// + +// The environment maintains the invariant that gamma is of the form: +// l_1 ... l_n val_1 ... val_n +// where l_i is a local binding and val_i is a top-level binding. +// +//let push_in_gamma env s = +// let rec push x rest = +// match rest with +// | Binding_sig _ :: _ -> +// x :: rest +// | [] -> +// [ x ] +// | local :: rest -> +// local :: push x rest +// in +// env.tc_hooks.tc_push_in_gamma_hook env s; +// { env with gamma = push s env.gamma } + +let rec record_vals_and_defns (g:env) (se:sigelt) : env = + match se.sigel with + | Sig_declare_typ _ + | Sig_let _ + when se.sigquals |> BU.for_some (function OnlyName -> true | _ -> false) -> + g + | Sig_declare_typ {lid} -> + if se.sigquals |> List.contains Assumption || g.is_iface + then g + else record_val_for g lid + | Sig_let {lids} -> + List.fold_left record_definition_for g lids + | Sig_datacon {lid} -> + record_definition_for g lid + | Sig_inductive_typ {lid} -> + record_definition_for g lid + | Sig_bundle {ses} -> + List.fold_left record_vals_and_defns g ses + | _ -> g + +// This function assumes that, in the case that the environment contains local +// bindings _and_ we push a top-level binding, then the top-level binding does +// not capture any of the local bindings (duh). +let push_sigelt' (force:bool) env s = + let sb = (lids_of_sigelt s, s) in + let env = {env with gamma_sig = sb::env.gamma_sig} in + add_sigelt force env s; + env.tc_hooks.tc_push_in_gamma_hook env (Inr sb); + let env = record_vals_and_defns env s in + env + +let push_sigelt = push_sigelt' false +let push_sigelt_force = push_sigelt' true + +let push_new_effect env (ed, quals) = + let effects = {env.effects with decls=env.effects.decls@[(ed, quals)]} in + {env with effects=effects} + +let exists_polymonadic_bind env m n = + match env.effects.polymonadic_binds + |> BU.find_opt (fun (m1, n1, _, _) -> lid_equals m m1 && lid_equals n n1) with + | Some (_, _, p, t) -> Some (p, t) + | _ -> None + +let exists_polymonadic_subcomp env m n = + match env.effects.polymonadic_subcomps + |> BU.find_opt (fun (m1, n1, _, _) -> lid_equals m m1 && lid_equals n n1) with + | Some (_, _, ts, k) -> Some (ts, k) + | _ -> None + +let print_effects_graph env = + let eff_name lid = lid |> ident_of_lid |> string_of_id in + let path_str path = path |> List.map eff_name |> String.concat ";" in + + // + //Right now the values in the map are just "" + // + //But it may be range or something else if we wanted to dump it in the dot graph + // + let pbinds : smap string = smap_create 10 in + + // + //The keys in the map are sources + // + //Each source is mapped to a map, whose keys are targets, and values are the path strings + // + let lifts : smap (smap string) = smap_create 20 in + + //Similar to pbinds + let psubcomps : smap string = smap_create 10 in + + //Populate the maps + + // + //Note that since order, polymonadic_binds, and polymonadic_subcomps are lists, + // they may have duplicates (and the typechecker picks the first one) + // + + env.effects.order |> List.iter (fun ({msource=src; mtarget=tgt; mpath=path}) -> + let key = eff_name src in + let m = + match smap_try_find lifts key with + | None -> + let m = smap_create 10 in + smap_add lifts key m; + m + | Some m -> m in + match smap_try_find m (eff_name tgt) with + | Some _ -> () + | None -> smap_add m (eff_name tgt) (path_str path)); + + env.effects.polymonadic_binds |> List.iter (fun (m, n, p, _) -> + let key = BU.format3 "%s, %s |> %s" (eff_name m) (eff_name n) (eff_name p) in + smap_add pbinds key ""); + + env.effects.polymonadic_subcomps |> List.iter (fun (m, n, _, _) -> + let key = BU.format2 "%s <: %s" (eff_name m) (eff_name n) in + smap_add psubcomps key ""); + + // + //Dump the dot graph + // + //Interesting bit of trivia: + // the cluster_ in the names of the subgraphs is important, + // if the name does not begin like this, dot rendering does not draw boxes + // around subgraphs (!) + // + + BU.format3 "digraph {\n\ + label=\"Effects ordering\"\n\ + subgraph cluster_lifts {\n\ + label = \"Lifts\"\n + %s\n\ + }\n\ + subgraph cluster_polymonadic_binds {\n\ + label = \"Polymonadic binds\"\n\ + %s\n\ + }\n\ + subgraph cluster_polymonadic_subcomps {\n\ + label = \"Polymonadic subcomps\"\n\ + %s\n\ + }}\n" + + ((smap_fold lifts (fun src m s -> + smap_fold m (fun tgt path s -> + (BU.format3 "%s -> %s [label=\"%s\"]" src tgt path)::s) s) []) |> String.concat "\n") + (smap_fold pbinds (fun k _ s -> (BU.format1 "\"%s\" [shape=\"plaintext\"]" k)::s) [] |> String.concat "\n") + (smap_fold psubcomps (fun k _ s -> (BU.format1 "\"%s\" [shape=\"plaintext\"]" k)::s) [] |> String.concat "\n") + +let update_effect_lattice env src tgt st_mlift = + let compose_edges e1 e2 : edge = + let composed_lift = + let mlift_wp env c = + c |> e1.mlift.mlift_wp env + |> (fun (c, g1) -> c |> e2.mlift.mlift_wp env + |> (fun (c, g2) -> c, TcComm.conj_guard g1 g2)) in + let mlift_term = + match e1.mlift.mlift_term, e2.mlift.mlift_term with + | Some l1, Some l2 -> Some (fun u t e -> l2 u t (l1 u t e)) + | _ -> None + in + { mlift_wp=mlift_wp ; mlift_term=mlift_term} + in + { msource=e1.msource; + mtarget=e2.mtarget; + mlift=composed_lift; + mpath=e1.mpath@[e1.mtarget]@e2.mpath} + in + + let edge = { + msource=src; + mtarget=tgt; + mlift=st_mlift; + mpath=[]; + } in + + let id_edge l = { + msource=src; + mtarget=tgt; + mlift=identity_mlift; + mpath=[]; + } in + + let find_edge order (i, j) = + if lid_equals i j + then id_edge i |> Some + else order |> BU.find_opt (fun e -> lid_equals e.msource i && lid_equals e.mtarget j) in + + let ms = env.effects.decls |> List.map (fun (e, _) -> e.mname) in + + (* + * AR: we compute all the new edges induced by the input edge + * and add them to the head of the edges list + * + * in other words, previous paths are overwritten + *) + + //all nodes i such that i <> src and i ~> src is an edge + let all_i_src = ms |> List.fold_left (fun edges i -> + if lid_equals i edge.msource then edges + else match find_edge env.effects.order (i, edge.msource) with + | Some e -> e::edges + | None -> edges) [] in + + //all nodes j such that j <> tgt and tgt ~> j is an edge + let all_tgt_j = ms |> List.fold_left (fun edges j -> + if lid_equals edge.mtarget j then edges + else match find_edge env.effects.order (edge.mtarget, j) with + | Some e -> e::edges + | None -> edges) [] in + + let check_cycle src tgt = + if lid_equals src tgt + then raise_error env Errors.Fatal_Effects_Ordering_Coherence + (BU.format3 "Adding an edge %s~>%s induces a cycle %s" + (show edge.msource) (show edge.mtarget) (show src)) + in + + // + //There are three types of new edges now: + // + // - From i to edge target + // - From edge source to j + // - From i to j + // + + let new_i_edge_target = List.fold_left (fun edges i_src -> + check_cycle i_src.msource edge.mtarget; + (compose_edges i_src edge)::edges) [] all_i_src in + + let new_edge_source_j = List.fold_left (fun edges tgt_j -> + check_cycle edge.msource tgt_j.mtarget; + (compose_edges edge tgt_j)::edges) [] all_tgt_j in + + let new_i_j = List.fold_left (fun edges i_src -> + List.fold_left (fun edges tgt_j -> + check_cycle i_src.msource tgt_j.mtarget; + (compose_edges (compose_edges i_src edge) tgt_j)::edges) edges all_tgt_j) [] all_i_src in + + let new_edges = edge::(new_i_edge_target@new_edge_source_j@new_i_j) in + + //Add new edges to the front of the list, shadowing existing ones + + let order = new_edges@env.effects.order in + + order |> List.iter (fun edge -> + if Ident.lid_equals edge.msource Const.effect_DIV_lid + && lookup_effect_quals env edge.mtarget |> List.contains TotalEffect + then + raise_error env Errors.Fatal_DivergentComputationCannotBeIncludedInTotal + (BU.format1 "Divergent computations cannot be included in an effect %s marked 'total'" + (show edge.mtarget))); + + // + //Compute upper bounds + // + //Addition of an edge may change upper bounds, + // that's ok, as long as it is unique in the new graph + // + let joins = + // + //A map where we populate all upper bounds for each pair of effects + // + let ubs : smap (list (lident & lident & lident & mlift & mlift)) = + BU.smap_create 10 in + let add_ub i j k ik jk = + let key = string_of_lid i ^ ":" ^ string_of_lid j in + let v = + match smap_try_find ubs key with + | Some ubs -> (i, j, k, ik, jk)::ubs + | None -> [i, j, k, ik, jk] in + + smap_add ubs key v in + + //Populate ubs + ms |> List.iter (fun i -> + ms |> List.iter (fun j -> + if lid_equals i j then () + else ms |> List.iter (fun k -> + match find_edge order (i, k), find_edge order (j, k) with + | Some ik, Some jk -> add_ub i j k ik.mlift jk.mlift + | _ -> ()))); + + // + //Fold over the map + // + //For each pair of effects (i.e. key in the ubs map), + // make sure there is a unique lub + // + smap_fold ubs (fun s l joins -> + //Filter entries that have an edge to every other entry + let lubs = List.filter (fun (i, j, k, ik, jk) -> + List.for_all (fun (_, _, k', _, _) -> + find_edge order (k, k') |> is_some) l) l in + //Make sure there is only one such entry + if List.length lubs <> 1 + then + raise_error env Errors.Fatal_Effects_Ordering_Coherence + (BU.format1 "Effects %s have incomparable upper bounds" s) + else lubs@joins) [] in + + let effects = {env.effects with order=order; joins=joins} in + {env with effects=effects} + +(* + * We allow overriding a previously defined poymonadic bind/subcomps + * between the same effects + * + * Also, polymonadic versions always take precedence over the effects graph + *) + +let add_polymonadic_bind env m n p ty = + { env with + effects = ({ env.effects with polymonadic_binds = (m, n, p, ty)::env.effects.polymonadic_binds }) } + +let add_polymonadic_subcomp env m n (ts, k) = + { env with + effects = ({ env.effects with + polymonadic_subcomps = (m, n, ts, k)::env.effects.polymonadic_subcomps }) } + +let push_local_binding env b = + {env with gamma=b::env.gamma} + +let push_bv env x = push_local_binding env (Binding_var x) + +let push_bvs env bvs = + List.fold_left (fun env bv -> push_bv env bv) env bvs + +let pop_bv env = + match env.gamma with + | Binding_var x::rest -> Some (x, {env with gamma=rest}) + | _ -> None + +let push_binders env (bs:binders) = + List.fold_left (fun env b -> push_bv env b.binder_bv) env bs + +let binding_of_lb (x:lbname) t = match x with + | Inl x -> + assert (fst t = []); + let x = {x with sort=snd t} in + Binding_var x + | Inr fv -> + Binding_lid(fv.fv_name.v, t) + +let push_let_binding env lb ts = + push_local_binding env (binding_of_lb lb ts) + +let push_univ_vars (env:env_t) (xs:univ_names) : env_t = + List.fold_left (fun env x -> push_local_binding env (Binding_univ x)) env xs + +let open_universes_in env uvs terms = + let univ_subst, univ_vars = Subst.univ_var_opening uvs in + let env' = push_univ_vars env univ_vars in + env', univ_vars, List.map (Subst.subst univ_subst) terms + +let set_expected_typ env t = + //false bit says that use subtyping + {env with expected_typ = Some (t, false)} + +let set_expected_typ_maybe_eq env t use_eq = + {env with expected_typ = Some (t, use_eq)} + +let expected_typ env = match env.expected_typ with + | None -> None + | Some t -> Some t + +let clear_expected_typ (env_: env): env & option (typ & bool) = + {env_ with expected_typ=None}, expected_typ env_ + +let finish_module = + let empty_lid = lid_of_ids [id_of_text ""] in + fun env m -> + let sigs = + if lid_equals m.name Const.prims_lid + then env.gamma_sig |> List.map snd |> List.rev + else m.declarations in + {env with + curmodule=empty_lid; + gamma=[]; + gamma_sig=[]; + modules=m::env.modules} + +//////////////////////////////////////////////////////////// +// Collections from the environment // +//////////////////////////////////////////////////////////// +let uvars_in_env env = + let no_uvs = empty () in + let rec aux out g = match g with + | [] -> out + | Binding_univ _ :: tl -> aux out tl + | Binding_lid(_, (_, t))::tl + | Binding_var({sort=t})::tl -> aux (union out (Free.uvars t)) tl + in + aux no_uvs env.gamma + +let univ_vars env = + let no_univs = empty () in + let rec aux out g = match g with + | [] -> out + | Binding_univ _ :: tl -> aux out tl + | Binding_lid(_, (_, t))::tl + | Binding_var({sort=t})::tl -> aux (union out (Free.univs t)) tl + in + aux no_univs env.gamma + +let univnames env = + let no_univ_names = empty () in + let rec aux out g = match g with + | [] -> out + | Binding_univ uname :: tl -> aux (add uname out) tl + | Binding_lid(_, (_, t))::tl + | Binding_var({sort=t})::tl -> aux (union out (Free.univnames t)) tl + in + aux no_univ_names env.gamma + +let lidents env : list lident = + let keys = List.collect fst env.gamma_sig in + BU.smap_fold (sigtab env) (fun _ v keys -> U.lids_of_sigelt v@keys) keys + +let should_enc_path proof_ns path = + let rec str_i_prefix xs ys = + match xs, ys with + | [], _ -> true + | x::xs, y::ys -> String.lowercase x = String.lowercase y && str_i_prefix xs ys + | _, _ -> false + in + match FStarC.Compiler.List.tryFind (fun (p, _) -> str_i_prefix p path) proof_ns with + | None -> false + | Some (_, b) -> b + +let should_enc_lid proof_ns lid = + should_enc_path proof_ns (path_of_lid lid) + +let cons_proof_ns b e path = + { e with proof_ns = (path,b) :: e.proof_ns } + +// F# forces me to fully apply this... ugh +let add_proof_ns e path = cons_proof_ns true e path +let rem_proof_ns e path = cons_proof_ns false e path +let get_proof_ns e = e.proof_ns +let set_proof_ns ns e = {e with proof_ns = ns} + +let unbound_vars (e : env) (t : term) : FlatSet.t bv = + // FV(t) \ Vars(Γ) + List.fold_left (fun s bv -> remove bv s) (Free.names t) (bound_vars e) + +let closed (e : env) (t : term) = + is_empty (unbound_vars e t) + +let closed' (t : term) = + is_empty (Free.names t) + +let string_of_proof_ns env = + let aux (p,b) = + if p = [] && b then "*" + else (if b then "+" else "-")^Ident.text_of_path p + in + List.map aux env.proof_ns + |> List.rev + |> String.concat " " + + +(* ------------------------------------------------*) +(* Operations on guard_formula *) +(* ------------------------------------------------*) +let guard_of_guard_formula g = + let open FStarC.Class.Listlike in + { + guard_f=g; + deferred=empty; + deferred_to_tac=empty; + univ_ineqs=(empty, empty); + implicits=empty; + } + +let guard_form g = g.guard_f + +let is_trivial g = + let open FStarC.Class.Listlike in + (* This is cumbersome due to not having view patterns. *) + // match g with + // | {guard_f=Trivial; deferred=[]; univ_ineqs=([], []); implicits=i} -> + if + Trivial? g.guard_f && + is_empty g.deferred && + is_empty (fst g.univ_ineqs) && + is_empty (snd g.univ_ineqs) + then + g.implicits |> CList.for_all (fun imp -> + (Allow_unresolved? (U.ctx_uvar_should_check imp.imp_uvar)) + || (match Unionfind.find imp.imp_uvar.ctx_uvar_head with + | Some _ -> true + | None -> false)) + else + false + +let is_trivial_guard_formula g = match g with + | {guard_f=Trivial} -> true + | _ -> false + +let trivial_guard = TcComm.trivial_guard + +let abstract_guard_n bs g = + match g.guard_f with + | Trivial -> g + | NonTrivial f -> + let f' = U.abs bs f (Some (U.residual_tot U.ktype0)) in + ({ g with guard_f = NonTrivial f' }) + +let abstract_guard b g = + abstract_guard_n [b] g + +let too_early_in_prims env = + not (lid_exists env Const.effect_GTot_lid) + +let apply_guard g e = match g.guard_f with + | Trivial -> g + | NonTrivial f -> {g with guard_f=NonTrivial <| mk (Tm_app {hd=f; args=[as_arg e]}) f.pos} + +let map_guard g map = match g.guard_f with + | Trivial -> g + | NonTrivial f -> {g with guard_f=NonTrivial (map f)} + +let always_map_guard g map = match g.guard_f with + | Trivial -> {g with guard_f=NonTrivial (map U.t_true)} + | NonTrivial f -> {g with guard_f=NonTrivial (map f)} + +let trivial t = match t with + | Trivial -> () + | NonTrivial _ -> failwith "impossible" + +let check_trivial t = TcComm.check_trivial t + +let conj_guard g1 g2 = TcComm.conj_guard g1 g2 +let conj_guards gs = TcComm.conj_guards gs +let imp_guard g1 g2 = TcComm.imp_guard g1 g2 + + +let close_guard_univs us bs g = + match g.guard_f with + | Trivial -> g + | NonTrivial f -> + let f = + List.fold_right2 (fun u b f -> + if Syntax.is_null_binder b then f + else U.mk_forall u b.binder_bv f) + us bs f in + {g with guard_f=NonTrivial f} + +let close_forall (env:env) (bs:binders) (f:formula) : formula = + Errors.with_ctx "While closing a formula" (fun () -> + def_check_scoped f.pos "close_forall" env (U.arrow bs (S.mk_Total f)); + let bvs = List.map (fun b -> b.binder_bv) bs in + (* We start with env_full and pop bvs one-by-one. This way each + * bv sort is always well scoped in the call to universe_of below. *) + let env_full = push_bvs env bvs in + + let (f', e) = + List.fold_right (fun bv (f, e) -> + let e' = pop_bv e |> must |> snd in + def_check_scoped Range.dummyRange "close_forall.sort" e' bv.sort; + let f' = + if Syntax.is_null_bv bv then f + else let u = e'.universe_of e' bv.sort in + U.mk_forall u bv f + in + (f', e') + ) bvs (f, env_full) + in + f' + ) + +let close_guard env binders g = + match g.guard_f with + | Trivial -> g + | NonTrivial f -> + {g with guard_f=NonTrivial (close_forall env binders f)} + +(* ------------------------------------------------*) +(* *) +(* ------------------------------------------------*) + +(* Generating new implicit variables *) +let new_tac_implicit_var + (reason: string) + (r: Range.range) + (env:env) + (uvar_typ:typ) + (should_check:should_check_uvar) + (uvar_typedness_deps:list ctx_uvar) + (meta:option ctx_uvar_meta_t) + (unrefine:bool) +: term & (ctx_uvar & Range.range) & guard_t += + let binders = all_binders env in + let gamma = env.gamma in + let decoration = { + uvar_decoration_typ = uvar_typ; + uvar_decoration_typedness_depends_on = uvar_typedness_deps; + uvar_decoration_should_check = should_check; + uvar_decoration_should_unrefine = unrefine; + } in + let ctx_uvar = { + ctx_uvar_head=FStarC.Syntax.Unionfind.fresh decoration r; + ctx_uvar_gamma=gamma; + ctx_uvar_binders=binders; + ctx_uvar_reason=reason; + ctx_uvar_range=r; + ctx_uvar_meta=meta; + } in + check_uvar_ctx_invariant reason r true gamma binders; + let t = mk (Tm_uvar (ctx_uvar, ([], NoUseRange))) r in + let imp = { imp_reason = reason + ; imp_tm = t + ; imp_uvar = ctx_uvar + ; imp_range = r + } in + if !dbg_ImplicitTrace then + BU.print1 "Just created uvar for implicit {%s}\n" (show ctx_uvar.ctx_uvar_head); + let g = {trivial_guard with implicits = Listlike.cons imp Listlike.empty} in + t, (ctx_uvar, r), g + +let new_implicit_var_aux reason r env k should_check meta unrefine = + new_tac_implicit_var reason r env k should_check [] meta unrefine + +(***************************************************) + +let uvar_meta_for_binder (b:binder) : option ctx_uvar_meta_t & bool= + let should_unrefine = U.has_attribute b.binder_attrs Const.unrefine_binder_attr in + let meta = + match b.binder_qual with + | Some (Meta tau) -> + (* Meta qualifier (e.g typeclass constraints) *) + Some (Ctx_uvar_meta_tac tau) + | _ -> + (* NB: it does not have to be marked Implicit to get a + Ctx_uvar_meta_attr. In practice most of them are (or + the typechecker will not decide to instantiate) but the + layered effects checking code will sometimes call this + function on regular explicit binders. *) + let is_unification_tag (t:term) : option term = + let hd, args = U.head_and_args t in + let hd = U.un_uinst hd in + match (SS.compress hd).n, args with + | Tm_fvar fv, [(_, Some ({aqual_implicit = true})); (a, None)] + when S.fv_eq_lid fv Const.unification_tag_lid -> + Some a + | _ -> None + in + match b.binder_attrs |> List.tryPick is_unification_tag with + | Some tag -> Some (Ctx_uvar_meta_attr tag) + | None -> None + in + meta, should_unrefine +// +// Perhaps this should not return a guard, +// but only a list of implicits, so that callers don't have to +// be cautious about the logical payload of the guard +// +let uvars_for_binders env (bs:S.binders) substs reason r = + bs |> List.fold_left (fun (substs, uvars, g) b -> + let sort = SS.subst substs b.binder_bv.sort in + + let ctx_uvar_meta, should_unrefine = uvar_meta_for_binder b in + + let t, l_ctx_uvars, g_t = new_implicit_var_aux + (reason b) r env sort + (if Options.compat_pre_typed_indexed_effects () + then Allow_untyped "indexed effect uvar in compat mode" + else Strict) + ctx_uvar_meta + should_unrefine + in + + if !dbg_LayeredEffectsEqns then + BU.print1 "Layered Effect uvar: %s\n" (show l_ctx_uvars); + + substs@[NT (b.binder_bv, t)], + uvars@[t], + conj_guards [g; g_t] + ) (substs, [], trivial_guard) |> (fun (_, uvars, g) -> uvars, g) + +let pure_precondition_for_trivial_post env u t wp r = + let trivial_post = + let post_ts = lookup_definition [NoDelta] env Const.trivial_pure_post_lid |> must in + let _, post = inst_tscheme_with post_ts [u] in + S.mk_Tm_app + post + [t |> S.as_arg] + r in + S.mk_Tm_app + wp + [trivial_post |> S.as_arg] + r + +let get_letrec_arity (env:env) (lbname:lbname) : option int = + let compare_either f1 f2 e1 e2 : bool = + match e1, e2 with + | Inl v1, Inl v2 -> f1 v1 v2 + | Inr v1, Inr v2 -> f2 v1 v2 + | _ -> false + in + match BU.find_opt (fun (lbname', _, _, _) -> compare_either S.bv_eq S.fv_eq lbname lbname') + env.letrecs with + | Some (_, arity, _, _) -> Some arity + | None -> None + +let fvar_of_nonqual_lid env lid = + let qn = lookup_qname env lid in + fvar lid None + +let split_smt_query (e:env) (q:term) + : option (list (env & term)) + = match e.solver.spinoff_strictly_positive_goals with + | None -> None + | Some p -> Some (p e q) diff --git a/src/typechecker/FStarC.TypeChecker.Env.fsti b/src/typechecker/FStarC.TypeChecker.Env.fsti new file mode 100644 index 00000000000..fdc48da5081 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Env.fsti @@ -0,0 +1,574 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.TypeChecker.Env +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStar open FStarC +open FStarC.Compiler +open FStarC.Syntax.Syntax +open FStarC.Ident +open FStarC.TypeChecker.Common +open FStarC.Class.Binders +open FStarC.Class.Deq +open FStarC.Class.Show +open FStarC.Class.Setlike + +module BU = FStarC.Compiler.Util +module S = FStarC.Syntax.Syntax +module TcComm = FStarC.TypeChecker.Common + +type step = + | Beta + | Iota //pattern matching + | Zeta //fixed points + | ZetaFull //fixed points, even under blocked matches + | Exclude of step //the first three kinds are included by default, unless Excluded explicity + | Weak //Do not descend into binders + | HNF //Only produce a head normal form: Do not descend into function arguments or into binder types + | Primops //reduce primitive operators like +, -, *, /, etc. + | Eager_unfolding + | Inlining + | DoNotUnfoldPureLets + | UnfoldUntil of delta_depth + | UnfoldOnly of list FStarC.Ident.lid + | UnfoldFully of list FStarC.Ident.lid + | UnfoldAttr of list FStarC.Ident.lid + | UnfoldQual of list string + | UnfoldNamespace of list string + | DontUnfoldAttr of list lid + | PureSubtermsWithinComputations + | Simplify //Simplifies some basic logical tautologies: not part of definitional equality! + | EraseUniverses + | AllowUnboundUniverses //we erase universes as we encode to SMT; so, sometimes when printing, it's ok to have some unbound universe variables + | Reify + | CompressUvars + | NoFullNorm + | CheckNoUvars + | Unmeta //remove all non-monadic metas. + | Unascribe + | NBE + | ForExtraction //marking an invocation of the normalizer for extraction + | Unrefine + | NormDebug //force debugging + | DefaultUnivsToZero // default al unresolved universe uvars to zero + | Tactics +and steps = list step + +instance val deq_step : deq step +instance val showable_step : showable step + +type sig_binding = list lident & sigelt + +type delta_level = + | NoDelta + | InliningDelta // ZP : Trying to resolve name clash + | Eager_unfolding_only + | Unfold of delta_depth + +instance val deq_delta_level : deq delta_level +instance val showable_delta_level : showable delta_level + +// A name prefix, such as ["FStar";"Math"] +type name_prefix = FStarC.Ident.path +// A choice of which name prefixes are enabled/disabled +// The leftmost match takes precedence. Empty list means everything is off. +// To turn off everything, one can prepend `([], false)` to this (since [] is a prefix of everything) +type proof_namespace = list (name_prefix & bool) + +type cached_elt = (either (universes & typ) (sigelt & option universes)) & Range.range +type goal = term + +type must_tot = bool + +(* + * AR: The mlift record that maintains functions to lift 'source' computation types + * and terms to 'target' computation types and terms (terms in the case of reifiable effects) + * + * The signature to lift computation types is quite nice: comp to comp + * For the terms, we don't require the indices (wps etc.) anymore since + * they are computationally irrelevant, in the previous code where we needed them + * all the clients were passing Tm_unknown, so what's the point + * Read the signature as: u_a:universe -> a:typ -> e:term -> term + * + * Note that these types compose quite nicely along the effect lattice + *) + +type lift_comp_t = env -> comp -> comp & guard_t + +(* + * AR: Env maintains polymonadic binds as functions of type polymonadic_bind_t + * read as: env -> c1 -> x -> c2 -> flags -> r -> (c * g) + *) +and polymonadic_bind_t = + env -> + comp_typ -> + option bv -> + comp_typ -> + list cflag -> + Range.range -> + comp & guard_t + +and mlift = { + mlift_wp:lift_comp_t; + mlift_term:option (universe -> typ -> term -> term) +} + +(* + * Edge in the effect lattice + * + * May have been computed by composing other "edges" + *) +and edge = { + msource : lident; + mtarget : lident; + mlift : mlift; + mpath : list lident; //this is just for debugging pusposes + //e.g. it is used when printing the effects graph + //it has no other role + //the path is the list of nodes that the "edge" goes through + //not including msource and mtarget +} + +(* + * The effects graph + * + * Each of order, joins, polymonadic binds, subcomps, are lists, + * that may have multiple entries for same nodes, + * e.g. multiple edges between effects M and N + * + * We keep adding the latest ones to the head of the list, + * which is then picked for application + * + * I.e. we don't remove when overriding + *) + +and effects = { + decls :list (eff_decl & list qualifier); + order :list edge; (* transitive closure of the order in the signature *) + joins :list (lident & lident & lident & mlift & mlift); (* least upper bounds *) + polymonadic_binds :list (lident & lident & lident & polymonadic_bind_t); (* (m, n) | p *) + polymonadic_subcomps :list (lident & lident & tscheme & S.indexed_effect_combinator_kind); (* m <: n *) +} + +and env = { + solver :solver_t; (* interface to the SMT solver *) + range :Range.range; (* the source location of the term being checked *) + curmodule :lident; (* Name of this module *) + gamma :list binding; (* Local typing environment *) + gamma_sig :list sig_binding; (* and signature elements *) + gamma_cache :FStarC.Compiler.Util.smap cached_elt; (* Memo table for the global gamma_sig environment *) + modules :list modul; (* already fully type checked modules *) + expected_typ :option (typ & bool); (* type expected by the context *) + (* a true bool will check for type equality (else subtyping) *) + sigtab :BU.smap sigelt; (* a dictionary of long-names to sigelts *) + attrtab :BU.smap (list sigelt); (* a dictionary of attribute( name)s to sigelts, mostly in support of typeclasses *) + instantiate_imp:bool; (* instantiate implicit arguments? default=true *) + effects :effects; (* monad lattice *) + generalize :bool; (* should we generalize let bindings? *) + letrecs :list (lbname & int & typ & univ_names); (* mutually recursive names, with recursion arity and their types (for termination checking), adding universes, see the note in TcTerm.fs:build_let_rec_env about usage of this field *) + top_level :bool; (* is this a top-level term? if so, then discharge guards *) + check_uvars :bool; (* paranoid: re-typecheck unification variables *) + use_eq_strict :bool; (* this flag runs the typechecker in non-subtyping mode *) + (* i.e. using type equality instead of subtyping *) + is_iface :bool; (* is the module we're currently checking an interface? *) + admit :bool; (* admit VCs in the current module *) + lax_universes :bool; (* don't check universe constraints *) + phase1 :bool; (* running in phase 1, phase 2 to come after *) + failhard :bool; (* don't try to carry on after a typechecking error *) + flychecking :bool; (* currently flychecking in IDE, used to for example not run synth tactics *) + uvar_subtyping :bool; + intactics :bool; (* we are currently running a tactic *) + nocoerce :bool; (* do not apply any coercions *) + + tc_term :env -> term -> term & lcomp & guard_t; (* typechecker callback; G |- e : C <== g *) + typeof_tot_or_gtot_term :env -> term -> must_tot -> term & typ & guard_t; (* typechecker callback; G |- e : (G)Tot t <== g *) + universe_of :env -> term -> universe; (* typechecker callback; G |- e : Tot (Type u) *) + typeof_well_typed_tot_or_gtot_term :env -> term -> must_tot -> typ & guard_t; (* typechecker callback, uses fast path, with a fallback on the slow path *) + teq_nosmt_force: env -> term -> term -> bool; (* callback to the unifier *) + subtype_nosmt_force: env -> term -> term -> bool; (* callback to the unifier *) + qtbl_name_and_index: option (lident & typ & int) & BU.smap int; + (* ^ the top-level term we're currently processing, its type, and the query counter for it, + in addition we maintain a counter for query index per lid *) + normalized_eff_names:BU.smap lident; (* cache for normalized effect name, used to be captured in the function norm_eff_name, which made it harder to roll back etc. *) + fv_delta_depths:BU.smap delta_depth; (* cache for fv delta depths, its preferable to use Env.delta_depth_of_fv, soon fv.delta_depth should be removed *) + proof_ns :proof_namespace; (* the current names that will be encoded to SMT (a.k.a. hint db) *) + synth_hook :env -> typ -> term -> term; (* hook for synthesizing terms via tactics, third arg is tactic term *) + try_solve_implicits_hook :env -> term -> implicits -> unit; (* *) + splice : env -> is_typed:bool -> list lident -> term -> Range.range -> list sigelt; (* hook for synthesizing top-level sigelts via tactics *) + (* second arg is true for typed splice *) + (* third arg is tactic term *) + mpreprocess :env -> term -> term -> term; (* hook for preprocessing typechecked terms via metaprograms *) + postprocess :env -> term -> typ -> term -> term; (* hook for postprocessing typechecked terms via metaprograms *) + identifier_info: ref FStarC.TypeChecker.Common.id_info_table; (* information on identifiers *) + tc_hooks : tcenv_hooks; (* hooks that the interactive more relies onto for symbol tracking *) + dsenv : FStarC.Syntax.DsEnv.env; (* The desugaring environment from the front-end *) + nbe : list step -> env -> term -> term; (* Callback to the NBE function *) + strict_args_tab:BU.smap (option (list int)); (* a dictionary of fv names to strict arguments *) + erasable_types_tab:BU.smap bool; (* a dictionary of type names to erasable types *) + enable_defer_to_tac: bool; (* Set by default; unset when running within a tactic itself, since we do not allow + a tactic to defer problems to another tactic via the attribute mechanism *) + unif_allow_ref_guards:bool; (* Allow guards when unifying refinements, even when SMT is disabled *) + erase_erasable_args: bool; (* This flag is set when running normalize_for_extraction, see Extraction.ML.Modul *) + + core_check: core_check_t; + + (* A set of names for which we are missing a declaration. + Every val (Sig_declare_typ) is added here and removed + only when a definition for it is checked. At the of checking a module, + if anything remains here, we fail. *) + missing_decl : RBSet.t lident; +} + +and solver_depth_t = int & int & int +and solver_t = { + init :env -> unit; + // push :string -> unit; + // pop :string -> unit; + snapshot :string -> (solver_depth_t & unit); + rollback :string -> option solver_depth_t -> unit; + encode_sig :env -> sigelt -> unit; + preprocess :env -> goal -> bool & list (env & goal & FStarC.Options.optionstate); + spinoff_strictly_positive_goals: option (env -> goal -> list (env & goal)); + handle_smt_goal :env -> goal -> list (env & goal); + solve :option (unit -> string) -> env -> goal -> unit; //call to the smt solver + solve_sync :option (unit -> string) -> env -> goal -> bool; //call to the smt solver + finish :unit -> unit; + refresh :option proof_namespace -> unit; +} +and tcenv_hooks = + { tc_push_in_gamma_hook : (env -> either binding sig_binding -> unit) } + +and core_check_t = + env -> term -> typ -> bool -> either (option typ) (bool -> string) + +(* Keeping track of declarations and definitions. This operates +over the missing_decl field. *) +val record_val_for (e:env) (l:lident) : env +val record_definition_for (e:env) (l:lident) : env +val missing_definition_list (e:env) : list lident + +type implicit = TcComm.implicit +type implicits = TcComm.implicits +type guard_t = TcComm.guard_t +type tcenv_depth_t = int & int & solver_depth_t & int +type qninfo = option ((either (universes & typ) (sigelt & option universes)) & Range.range) + +val tc_hooks : env -> tcenv_hooks +val set_tc_hooks: env -> tcenv_hooks -> env +val preprocess : env -> term -> term -> term +val postprocess : env -> term -> typ -> term -> term + +type env_t = env + +val initial_env : FStarC.Parser.Dep.deps -> + (env -> term -> term & lcomp & guard_t) -> + (env -> term -> must_tot -> term & typ & guard_t) -> + (env -> term -> must_tot -> option typ) -> + (env -> term -> universe) -> + (env -> term -> term -> bool) -> + (env -> term -> term -> bool) -> + solver_t -> lident -> + (list step -> env -> term -> term) -> + core_check_t -> env + +(* Some utilities *) +val should_verify : env -> bool +val incr_query_index: env -> env +val rename_gamma : subst_t -> gamma -> gamma +val rename_env : subst_t -> env -> env +val set_dep_graph: env -> FStarC.Parser.Dep.deps -> env +val dep_graph: env -> FStarC.Parser.Dep.deps + +val dsenv : env -> FStarC.Syntax.DsEnv.env + +(* Marking and resetting the environment *) +val push : env -> string -> env +val pop : env -> string -> env + +val snapshot : env -> string -> (tcenv_depth_t & env) +val rollback : solver_t -> string -> option tcenv_depth_t -> env + +(* Checking the per-module debug level and position info *) +val current_module : env -> lident +val set_range : env -> Range.range -> env +val get_range : env -> Range.range + +instance val hasRange_env : hasRange env + +val insert_bv_info : env -> bv -> typ -> unit +val insert_fv_info : env -> fv -> typ -> unit +val toggle_id_info : env -> bool -> unit +val promote_id_info : env -> (typ -> option typ) -> unit + +(* Querying identifiers *) +val lid_exists : env -> lident -> bool +val try_lookup_bv : env -> bv -> option (typ & Range.range) +val lookup_bv : env -> bv -> typ & Range.range +val lookup_qname : env -> lident -> qninfo +val lookup_sigelt : env -> lident -> option sigelt +val try_lookup_lid : env -> lident -> option ((universes & typ) & Range.range) +val try_lookup_and_inst_lid: env -> universes -> lident -> option (typ & Range.range) +val lookup_lid : env -> lident -> (universes & typ) & Range.range +val lookup_univ : env -> univ_name -> bool +val try_lookup_val_decl : env -> lident -> option (tscheme & list qualifier) +val lookup_val_decl : env -> lident -> (universes & typ) +val lookup_datacon : env -> lident -> universes & typ +val lookup_and_inst_datacon: env -> universes -> lident -> typ +(* the boolean tells if the lident was actually a inductive *) +val datacons_of_typ : env -> lident -> (bool & list lident) +val typ_of_datacon : env -> lident -> lident +val visible_with : list delta_level -> list qualifier -> bool +val lookup_definition_qninfo : list delta_level -> lident -> qninfo -> option (univ_names & term) +val lookup_definition : list delta_level -> env -> lident -> option (univ_names & term) +val lookup_nonrec_definition: list delta_level -> env -> lident -> option (univ_names & term) +val quals_of_qninfo : qninfo -> option (list qualifier) +val attrs_of_qninfo : qninfo -> option (list attribute) +val lookup_attrs_of_lid : env -> lid -> option (list attribute) +val fv_with_lid_has_attr : env -> fv_lid:lid -> attr_lid:lid -> bool +val fv_has_attr : env -> fv -> attr_lid:lid -> bool +val fv_has_strict_args : env -> fv -> option (list int) +val fv_has_erasable_attr : env -> fv -> bool +val non_informative : env -> typ -> bool +val try_lookup_effect_lid : env -> lident -> option term +val lookup_effect_lid : env -> lident -> term +val lookup_effect_abbrev : env -> universes -> lident -> option (binders & comp) +val norm_eff_name : (env -> lident -> lident) +val num_effect_indices : env -> lident -> Range.range -> int +val lookup_effect_quals : env -> lident -> list qualifier +val lookup_projector : env -> lident -> int -> lident +val lookup_attr : env -> string -> list sigelt +val is_projector : env -> lident -> bool +val is_datacon : env -> lident -> bool +val is_record : env -> lident -> bool +val qninfo_is_action : qninfo -> bool +val is_action : env -> lident -> bool +val is_interpreted : (env -> term -> bool) +val is_irreducible : env -> lident -> bool +val is_type_constructor : env -> lident -> bool +val num_inductive_ty_params: env -> lident -> option int +val num_inductive_uniform_ty_params: env -> lident -> option int +val num_datacon_non_injective_ty_params : env -> lident -> option int +val delta_depth_of_qninfo : env -> fv -> qninfo -> delta_depth +val delta_depth_of_fv : env -> fv -> delta_depth + +(* Universe instantiation *) + +(* Construct a new universe unification variable *) +val new_u_univ : unit -> universe +val inst_tscheme_with : tscheme -> universes -> universes & term +(* Instantiate the universe variables in a type scheme with new unification variables *) +val inst_tscheme : tscheme -> universes & term +val inst_effect_fun_with : universes -> env -> eff_decl -> tscheme -> term +val mk_univ_subst : list univ_name -> universes -> list subst_elt + +(* Introducing identifiers and updating the environment *) + +(* + * push_sigelt only adds the sigelt to various caches maintained by env + * For semantic changes, such as adding an effect or adding an edge to the effect lattice, + * Tc calls separate functions + *) +val push_sigelt : env -> sigelt -> env +val push_sigelt_force : env -> sigelt -> env (* does not check for repeats *) +val push_new_effect : env -> (eff_decl & list qualifier) -> env + +//client constructs the mlift and gives it to us + +val exists_polymonadic_bind: env -> lident -> lident -> option (lident & polymonadic_bind_t) +val exists_polymonadic_subcomp: env -> lident -> lident -> option (tscheme & S.indexed_effect_combinator_kind) + +//print the effects graph in dot format +val print_effects_graph: env -> string + +val update_effect_lattice : env -> src:lident -> tgt:lident -> mlift -> env + +val join_opt : env -> lident -> lident -> option (lident & mlift & mlift) +val add_polymonadic_bind : env -> m:lident -> n:lident -> p:lident -> polymonadic_bind_t -> env +val add_polymonadic_subcomp: env -> m:lident -> n:lident -> (tscheme & S.indexed_effect_combinator_kind) -> env + +val push_bv : env -> bv -> env +val push_bvs : env -> list bv -> env +val pop_bv : env -> option (bv & env) +val push_let_binding : env -> lbname -> tscheme -> env +val push_binders : env -> binders -> env +val push_univ_vars : env -> univ_names -> env +val open_universes_in : env -> univ_names -> list term -> env & univ_names & list term +val set_expected_typ : env -> typ -> env +val set_expected_typ_maybe_eq + : env -> typ -> bool -> env //boolean true will check for type equality + +//the returns boolean true means check for type equality +val expected_typ : env -> option (typ & bool) +val clear_expected_typ : env -> env&option (typ & bool) + +val set_current_module : env -> lident -> env +val finish_module : (env -> modul -> env) + +(* Collective state of the environment *) +val bound_vars : env -> list bv +val all_binders : env -> binders +val modules : env -> list modul +val uvars_in_env : env -> uvars +val univ_vars : env -> FlatSet.t universe_uvar +val univnames : env -> FlatSet.t univ_name +val lidents : env -> list lident + +(* operations on monads *) +val identity_mlift : mlift +val join : env -> lident -> lident -> lident & mlift & mlift +val monad_leq : env -> lident -> lident -> option edge +val effect_decl_opt : env -> lident -> option (eff_decl & list qualifier) +val get_effect_decl : env -> lident -> eff_decl +val get_default_effect : env -> lident -> option lident +val get_top_level_effect : env -> lident -> option lident +val is_layered_effect : env -> lident -> bool +val wp_signature : env -> lident -> (bv & term) +val comp_to_comp_typ : env -> comp -> comp_typ +val comp_set_flags : env -> comp -> list S.cflag -> comp +val unfold_effect_abbrev : env -> comp -> comp_typ +val effect_repr : env -> comp -> universe -> option term +val reify_comp : env -> comp -> universe -> term + +val is_erasable_effect : env -> lident -> bool + +(* [is_reifiable_* env x] returns true if the effect name/computational effect (of *) +(* a body or codomain of an arrow) [x] is reifiable *) +val is_reifiable_effect : env -> lident -> bool +val is_reifiable_rc : env -> residual_comp -> bool +val is_reifiable_comp : env -> comp -> bool +val is_reifiable_function : env -> term -> bool + +(* [is_user_reifiable_* env x] is more restrictive, and only allows *) +(* reifying effects marked with the `reifiable` keyword. (For instance, TAC *) +(* is reifiable but not user-reifiable.) *) +val is_user_reifiable_effect : env -> lident -> bool +val is_user_reflectable_effect : env -> lident -> bool + +(* Is this effect marked `total`? *) +val is_total_effect : env -> lident -> bool + +(* A coercion *) +val binders_of_bindings : list binding -> binders + +(* Toggling of encoding of namespaces *) +val should_enc_lid : proof_namespace -> lident -> bool +val add_proof_ns : env -> name_prefix -> env +val rem_proof_ns : env -> name_prefix -> env +val get_proof_ns : env -> proof_namespace +val set_proof_ns : proof_namespace -> env -> env +val string_of_proof_ns : env -> string + +(* Check that all free variables of the term are defined in the environment *) +val unbound_vars : env -> term -> FlatSet.t bv +val closed : env -> term -> bool +val closed' : term -> bool + +(* Operations on guard_t *) +val close_guard_univs : universes -> binders -> guard_t -> guard_t +val close_guard : env -> binders -> guard_t -> guard_t //this closes the guard formula with bs +val apply_guard : guard_t -> term -> guard_t +val map_guard : guard_t -> (term -> term) -> guard_t +val always_map_guard : guard_t -> (term -> term) -> guard_t +val trivial_guard : guard_t +val is_trivial : guard_t -> bool +val is_trivial_guard_formula : guard_t -> bool +val conj_guard : guard_t -> guard_t -> guard_t +val conj_guards : list guard_t -> guard_t +val abstract_guard : binder -> guard_t -> guard_t +val abstract_guard_n : list binder -> guard_t -> guard_t +val imp_guard : guard_t -> guard_t -> guard_t +val guard_of_guard_formula : guard_formula -> guard_t +val guard_form : guard_t -> guard_formula +val check_trivial : term -> guard_formula + +(* Other utils *) +val too_early_in_prims : env -> bool + +val close_forall : env -> binders -> term -> term + +val new_tac_implicit_var + (reason: string) + (r: Range.range) + (env:env) + (uvar_typ:typ) + (should_check:should_check_uvar) + (uvar_typedness_deps:list ctx_uvar) + (meta:option ctx_uvar_meta_t) + (unrefine:bool) +: term & (ctx_uvar & Range.range) & guard_t + +val new_implicit_var_aux + (reason: string) + (r: Range.range) + (env:env) + (uvar_typ:typ) + (should_check:should_check_uvar) + (meta:option ctx_uvar_meta_t) + (unrefine:bool) +: term & (ctx_uvar & Range.range) & guard_t + + +val uvar_meta_for_binder (b:binder) : option ctx_uvar_meta_t & (*should_unrefine:*)bool + +(* layered effect utils *) + +(* + * This gadget is used when the typechecker applies the layered effect combinators + * + * Given (opened) bs = x_i:t_i, this function creates uvars ?u_i:t_i + * + * When creating a ?u_i, it performs the substitution substs@[x_j/?u_j] in t_i, forall j < i + * so that the t_i is well-typed in env + * + * It returns the list of the uvars, and combined guard (which essentially contains the uvars as implicits) + *) + +val uvars_for_binders : + env -> + bs:S.binders -> + substs:S.subst_t -> + reason:(S.binder -> string) -> + r:Range.range -> + (list S.term & guard_t) + +val pure_precondition_for_trivial_post : env -> universe -> typ -> typ -> Range.range -> typ + +(* Fetch the arity from the letrecs field. None if not there (happens +for either not a recursive let, or one that does not need the totality +check. *) +val get_letrec_arity : env -> lbname -> option int + +(* Construct a Tm_fvar with the delta_depth metadata populated + -- Note, the delta_qual is not populated, so don't use this with + Data constructors, projectors, record identifiers etc. + + -- Also, don't use this with lidents that refer to Prims, that + still requires special handling +*) +val fvar_of_nonqual_lid : env -> lident -> term + +val split_smt_query : env -> term -> option (list (env & term)) + +(* Binding instances, mostly for defensive checks *) + +instance val hasBinders_env : hasBinders env +instance val hasNames_lcomp : hasNames lcomp +instance val pretty_lcomp : FStarC.Class.PP.pretty lcomp +instance val hasNames_guard : hasNames guard_t +instance val pretty_guard : FStarC.Class.PP.pretty guard_t + +val fv_delta_depth : env -> fv -> delta_depth +val delta_depth_of_term : env -> term -> delta_depth diff --git a/src/typechecker/FStarC.TypeChecker.Err.fst b/src/typechecker/FStarC.TypeChecker.Err.fst new file mode 100644 index 00000000000..0b695a36a0a --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Err.fst @@ -0,0 +1,349 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.TypeChecker.Err +open FStar.Pervasives +open FStarC.Compiler.Effect + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.List +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.Compiler.Util +open FStarC.TypeChecker.Normalize +open FStarC.TypeChecker.Env +open FStarC.Compiler.Range +open FStarC.Ident +open FStarC.Pprint +module N = FStarC.TypeChecker.Normalize +module BU = FStarC.Compiler.Util //basic util +module Env = FStarC.TypeChecker.Env +open FStarC.TypeChecker.Common + +open FStarC.Errors.Msg +open FStarC.Class.PP +open FStarC.Class.Show + +let info_at_pos env file row col : option (either string lident & typ & Range.range) = + match TypeChecker.Common.id_info_at_pos !env.identifier_info file row col with + | None -> None + | Some info -> + match info.identifier with + | Inl bv -> Some (Inl (show bv.ppname), info.identifier_ty, + FStarC.Syntax.Syntax.range_of_bv bv) + | Inr fv -> Some (Inr (FStarC.Syntax.Syntax.lid_of_fv fv), info.identifier_ty, + FStarC.Syntax.Syntax.range_of_fv fv) + +(* Will attempt to enable certain printing flags to make x and y + * visibly different. It will try to enable the least possible + * subset of implicits, universes, effect_args and full_names. + * It will also prioritize them in that order, prefering to show + * a discrepancy of implicits before one of universes, etc. + *) +let print_discrepancy (#a:Type) (#b:eqtype) (f : a -> b) (x : a) (y : a) : b & b = + let print () : b & b & bool = + let xs = f x in + let ys = f y in + xs, ys, xs <> ys + in + let rec blist_leq (l1 : list bool) (l2 : list bool) = + match l1, l2 with + | h1::t1, h2::t2 -> + (not h1 || h2) && blist_leq t1 t2 + | [], [] -> + true + | _ -> + failwith "print_discrepancy: bad lists" + in + let rec succ (l : list bool) : list bool = + match l with + | false::t -> true::t + | true::t -> false::(succ t) + | [] -> failwith "" + in + let full (l : list bool) : bool = + List.for_all (fun b -> b) l + in + let get_bool_option (s:string) : bool = + match Options.get_option s with + | Options.Bool b -> b + | _ -> failwith "print_discrepancy: impossible" + in + let set_bool_option (s:string) (b:bool) : unit = + Options.set_option s (Options.Bool b) + in + let get () : list bool = + let pi = get_bool_option "print_implicits" in + let pu = get_bool_option "print_universes" in + let pea = get_bool_option "print_effect_args" in + let pf = get_bool_option "print_full_names" in + [pi; pu; pea; pf] + in + let set (l : list bool) : unit = + match l with + | [pi; pu; pea; pf] -> + set_bool_option "print_implicits" pi; + set_bool_option "print_universes" pu; + set_bool_option "print_effect_args" pea; + set_bool_option "print_full_names " pf + | _ -> failwith "impossible: print_discrepancy" + in + let bas = get () in + let rec go (cur : list bool) = + match () with + (* give up, nothing more we can do *) + | () when full cur -> + let xs, ys, _ = print () in + xs, ys + + (* skip this configuration, we do not want to disable any flag + * given by the user *) + | () when not (blist_leq bas cur) -> + go (succ cur) + + | () -> + set cur; + match print () with + (* got a discrepancy! we're done *) + | xs, ys, true -> + xs, ys + + (* keep trying *) + | _ -> + go (succ cur) + in + Options.with_saved_options (fun () -> go bas) + +let errors_smt_detail env + (errs : list Errors.error) + (smt_detail : Errors.error_message) +: list Errors.error += + let errs = + errs + |> List.map + (fun (e, msg, r, ctx) -> + let e, msg, r, ctx = + let msg = msg @ smt_detail in + if r = dummyRange + then e, msg, Env.get_range env, ctx + else let r' = Range.set_def_range r (Range.use_range r) in + if Range.file_of_range r' <> Range.file_of_range (Env.get_range env) //r points to another file + then + let msg = + let open FStarC.Pprint in + msg @ [doc_of_string ("Also see: " ^ Range.string_of_use_range r) + ; (if Range.use_range r <> Range.def_range r + then doc_of_string ("Other related locations: " ^ Range.string_of_def_range r) + else empty)] + in + e, msg, Env.get_range env, ctx + else e, msg, r, ctx + in + e, msg, r, ctx) + in + errs + +let add_errors env errs = + FStarC.Errors.add_errors (errors_smt_detail env errs []) + +let log_issue env r (e, m) : unit = + add_errors env [e, m, r, Errors.get_ctx ()] + +let log_issue_text env r (e, m) : unit = + log_issue env r (e, [Errors.text m]) + +let err_msg_type_strings env t1 t2 :(string & string) = + print_discrepancy (N.term_to_string env) t1 t2 + +// let err_msg_type_docs env t1 t2 :(Pprint.document * Pprint.document) = + +// print_discrepancy (N.term_to_doc env) t1 t2 + +let err_msg_comp_strings env c1 c2 :(string & string) = + print_discrepancy (N.comp_to_string env) c1 c2 + +(* Error messages for labels in VCs *) +let exhaustiveness_check = [ + FStarC.Errors.Msg.text "Patterns are incomplete" +] + +let subtyping_failed : env -> typ -> typ -> unit -> error_message = + fun env t1 t2 () -> + // let s1, s2 = err_msg_type_strings env t1 t2 in + let ppt = N.term_to_doc env in + [text "Subtyping check failed"; + prefix 2 1 (text "Expected type") (ppt t2) ^/^ + prefix 2 1 (text "got type") (ppt t1); + ] + +let ill_kinded_type = Errors.mkmsg "Ill-kinded type" + +let unexpected_signature_for_monad #a env (rng:Range.range) (m:lident) k : a = + Errors.raise_error rng Errors.Fatal_UnexpectedSignatureForMonad + (format2 "Unexpected signature for monad \"%s\". Expected a signature of the form (a:Type -> WP a -> Effect); got %s" + (show m) (N.term_to_string env k)) + +let expected_a_term_of_type_t_got_a_function env (rng:Range.range) msg (t:typ) (e:term) = + Errors.raise_error rng Errors.Fatal_ExpectTermGotFunction + (format3 "Expected a term of type \"%s\"; got a function \"%s\" (%s)" + (N.term_to_string env t) (show e) msg) + +let unexpected_implicit_argument = + (Errors.Fatal_UnexpectedImplicitArgument, ("Unexpected instantiation of an implicit argument to a function that only expects explicit arguments")) + +let expected_expression_of_type #a env (rng:Range.range) t1 e t2 : a = + // let s1, s2 = err_msg_type_strings env t1 t2 in + // MISSING: print discrepancy! + let d1 = N.term_to_doc env t1 in + let d2 = N.term_to_doc env t2 in + let ed = N.term_to_doc env e in + let open FStarC.Errors.Msg in + Errors.raise_error rng Errors.Fatal_UnexpectedExpressionType [ + prefix 4 1 (text "Expected expression of type") d1 ^/^ + prefix 4 1 (text "got expression") ed ^/^ + prefix 4 1 (text "of type") d2 + ] + +let expected_pattern_of_type env (t1 e t2 : term) = + let s1, s2 = err_msg_type_strings env t1 t2 in + (Errors.Fatal_UnexpectedPattern, (format3 "Expected pattern of type \"%s\"; got pattern \"%s\" of type \"%s\"" + s1 (show e) s2)) + +let basic_type_error env (rng:Range.range) eopt t1 t2 = + let s1, s2 = err_msg_type_strings env t1 t2 in + let open FStarC.Errors.Msg in + let msg = match eopt with + | None -> [ + prefix 4 1 (text "Expected type") (N.term_to_doc env t1) ^/^ + prefix 4 1 (text "got type") (N.term_to_doc env t2); + ] + | Some e -> [ + prefix 4 1 (text "Expected type") (N.term_to_doc env t1) ^/^ + prefix 4 1 (text "but") (N.term_to_doc env e) ^/^ + prefix 4 1 (text "has type") (N.term_to_doc env t2); + ] + in + Errors.log_issue rng Errors.Error_TypeError msg + +(* It does not make sense to use the same code for a catcheable and uncatcheable +error, but that's what this was doing. *) +let raise_basic_type_error #a env (rng:Range.range) eopt t1 t2 : a = + let s1, s2 = err_msg_type_strings env t1 t2 in + let open FStarC.Errors.Msg in + let msg = match eopt with + | None -> [ + prefix 4 1 (text "Expected type") (N.term_to_doc env t1) ^/^ + prefix 4 1 (text "got type") (N.term_to_doc env t2); + ] + | Some e -> [ + prefix 4 1 (text "Expected type") (N.term_to_doc env t1) ^/^ + prefix 4 1 (text "but") (N.term_to_doc env e) ^/^ + prefix 4 1 (text "has type") (N.term_to_doc env t2); + ] + in + Errors.raise_error rng Errors.Error_TypeError msg + +let occurs_check = + (Errors.Fatal_PossibleInfiniteTyp, "Possibly infinite typ (occurs check failed)") + +let constructor_fails_the_positivity_check env (d:term) (l:lid) = + (Errors.Fatal_ConstructorFailedCheck, (format2 "Constructor \"%s\" fails the strict positivity check; the constructed type \"%s\" occurs to the left of a pure function type" + (show d) (show l))) + +let inline_type_annotation_and_val_decl (l:lid) = + (Errors.Fatal_DuplicateTypeAnnotationAndValDecl, (format1 "\"%s\" has a val declaration as well as an inlined type annotation; remove one" (show l))) + +(* CH: unsure if the env is good enough for normalizing t here *) +let inferred_type_causes_variable_to_escape env t (x:bv) = + (Errors.Fatal_InferredTypeCauseVarEscape, (format2 "Inferred type \"%s\" causes variable \"%s\" to escape its scope" + (N.term_to_string env t) (show x))) + +let expected_function_typ #a env (rng:Range.range) t : a = + Errors.raise_error rng Errors.Fatal_FunctionTypeExpected [ + text "Expected a function."; + prefix 2 1 (text "Got an expression of type:") + (N.term_to_doc env t); + ] + +let expected_poly_typ env (f:term) t targ = + (Errors.Fatal_PolyTypeExpected, (format3 "Expected a polymorphic function; got an expression \"%s\" of type \"%s\" applied to a type \"%s\"" + (show f) (N.term_to_string env t) (N.term_to_string env targ))) + +let disjunctive_pattern_vars (v1 v2 : list bv) = + let vars v = + v |> List.map show |> String.concat ", " in + (Errors.Fatal_DisjuctivePatternVarsMismatch, (format2 + "Every alternative of an 'or' pattern must bind the same variables; here one branch binds (\"%s\") and another (\"%s\")" + (vars v1) (vars v2))) + +let name_and_result c = match c.n with + | Total t -> "Tot", t + | GTotal t -> "GTot", t + | Comp ct -> show ct.effect_name, ct.result_typ + // TODO: ^ Use the resugaring environment to possibly shorten the effect name + +let computed_computation_type_does_not_match_annotation #a env (r:Range.range) e c c' : a = + let ppt = N.term_to_doc env in + let f1, r1 = name_and_result c in + let f2, r2 = name_and_result c' in + Errors.raise_error r Errors.Fatal_ComputedTypeNotMatchAnnotation [ + prefix 2 1 (text "Computed type") (ppt r1) ^/^ + prefix 2 1 (text "and effect") (text f1) ^/^ + prefix 2 1 (text "is not compatible with the annotated type") (ppt r2) ^/^ + prefix 2 1 (text "and effect") (text f2) + ] + +let computed_computation_type_does_not_match_annotation_eq #a env (r:Range.range) e c c' : a = + let ppc = N.comp_to_doc env in + Errors.raise_error r Errors.Fatal_ComputedTypeNotMatchAnnotation [ + prefix 2 1 (text "Computed type") (ppc c) ^/^ + prefix 2 1 (text "does not match annotated type") (ppc c') ^/^ + text "and no subtyping was allowed"; + ] + +let unexpected_non_trivial_precondition_on_term #a env f : a = + Errors.raise_error env Errors.Fatal_UnExpectedPreCondition + (format1 "Term has an unexpected non-trivial pre-condition: %s" (N.term_to_string env f)) + +let __expected_eff_expression (effname:string) (rng:Range.range) (e:term) (c:comp) (reason:option string) = + let open FStarC.Class.PP in + let open FStarC.Pprint in + Errors.raise_error rng Errors.Fatal_ExpectedGhostExpression [ + text ("Expected a " ^ effname ^ " expression."); + (match reason with + | None -> empty + | Some msg -> flow (break_ 1) (doc_of_string "Because:" :: words (msg ^ "."))); + prefix 2 1 (text "Got an expression") (pp e) ^/^ + prefix 2 1 (text "with effect") (squotes (doc_of_string (fst <| name_and_result c))) ^^ dot; + ] + +let expected_pure_expression (rng:Range.range) (e:term) (c:comp) (reason:option string) = + __expected_eff_expression "pure" rng e c reason + +let expected_ghost_expression (rng:Range.range)(e:term) (c:comp) (reason:option string) = + __expected_eff_expression "ghost" rng e c reason + +let expected_effect_1_got_effect_2 (c1:lident) (c2:lident) = + (Errors.Fatal_UnexpectedEffect, (format2 "Expected a computation with effect %s; but it has effect %s" (show c1) (show c2))) + +let failed_to_prove_specification_of (l : lbname) (lbls : list string) = + (Errors.Error_TypeCheckerFailToProve, (format2 "Failed to prove specification of %s; assertions at [%s] may fail" (show l) (lbls |> String.concat ", "))) + +let warn_top_level_effect (rng:Range.range) : unit = + Errors.log_issue rng + Errors.Warning_TopLevelEffect + "Top-level let-bindings must be total; this term may have effects" diff --git a/src/typechecker/FStarC.TypeChecker.Generalize.fst b/src/typechecker/FStarC.TypeChecker.Generalize.fst new file mode 100644 index 00000000000..6f622bcac5a --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Generalize.fst @@ -0,0 +1,303 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.TypeChecker.Generalize + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Compiler.Util +open FStarC.Errors +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.TypeChecker.Env + +open FStarC.Class.Show +open FStarC.Class.Setlike + +module BU = FStarC.Compiler.Util +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module Free = FStarC.Syntax.Free +module U = FStarC.Syntax.Util +module Print = FStarC.Syntax.Print +module UF = FStarC.Syntax.Unionfind +module Env = FStarC.TypeChecker.Env +module N = FStarC.TypeChecker.Normalize + +let dbg_Gen = Debug.get_toggle "Gen" + +instance showable_univ_var : showable universe_uvar = { + show = (fun u -> show (U_unif u)); +} + +(**************************************************************************************) +(* Generalizing types *) +(**************************************************************************************) + +let gen_univs env (x:FlatSet.t universe_uvar) : list univ_name = + if is_empty x then [] + else let s = diff x (Env.univ_vars env) |> elems in // GGG: bad, order dependent + if !dbg_Gen then + BU.print1 "univ_vars in env: %s\n" (show (Env.univ_vars env)); + let r = Some (Env.get_range env) in + let u_names = s |> List.map (fun u -> + let u_name = Syntax.new_univ_name r in + if !dbg_Gen then + BU.print3 "Setting ?%s (%s) to %s\n" + (string_of_int <| UF.univ_uvar_id u) + (show (U_unif u)) + (show (U_name u_name)); + UF.univ_change u (U_name u_name); + u_name) + in + u_names + +let gather_free_univnames env t : FlatSet.t univ_name = + let ctx_univnames = Env.univnames env in + let tm_univnames = Free.univnames t in + let univnames = diff tm_univnames ctx_univnames in + // BU.print4 "Closing universe variables in term %s : %s in ctx, %s in tm, %s globally\n" + // (show t) + // (Common.string_of_set Ident.string_of_id ctx_univnames) + // (Common.string_of_set Ident.string_of_id tm_univnames) + // (Common.string_of_list Ident.string_of_id univnames); + univnames + +let check_universe_generalization + (explicit_univ_names : list univ_name) + (generalized_univ_names : list univ_name) + (t : term) + : list univ_name += + match explicit_univ_names, generalized_univ_names with + | [], _ -> generalized_univ_names + | _, [] -> explicit_univ_names + | _ -> raise_error t Errors.Fatal_UnexpectedGeneralizedUniverse + ("Generalized universe in a term containing explicit universe annotation : " ^ show t) + +let generalize_universes (env:env) (t0:term) : tscheme = + Errors.with_ctx "While generalizing universes" (fun () -> + let t = N.normalize [Env.NoFullNorm; Env.Beta; Env.DoNotUnfoldPureLets] env t0 in + let univnames = elems (gather_free_univnames env t) in /// GGG: bad, order dependent + if !dbg_Gen + then BU.print2 "generalizing universes in the term (post norm): %s with univnames: %s\n" (show t) (show univnames); + let univs = Free.univs t in + if !dbg_Gen + then BU.print1 "univs to gen : %s\n" (show univs); + let gen = gen_univs env univs in + if !dbg_Gen + then BU.print2 "After generalization, t: %s and univs: %s\n" (show t) (show gen); + let univs = check_universe_generalization univnames gen t0 in + let t = N.reduce_uvar_solutions env t in + let ts = SS.close_univ_vars univs t in + univs, ts + ) + +let gen env (is_rec:bool) (lecs:list (lbname & term & comp)) : option (list (lbname & list univ_name & term & comp & list binder)) = + if not <| (BU.for_all (fun (_, _, c) -> U.is_pure_or_ghost_comp c) lecs) //No value restriction in F*---generalize the types of pure computations + then None + else + let norm c = + if Debug.medium () + then BU.print1 "Normalizing before generalizing:\n\t %s\n" (show c); + let c = Normalize.normalize_comp [Env.Beta; Env.Exclude Env.Zeta; Env.NoFullNorm; Env.DoNotUnfoldPureLets] env c in + if Debug.medium () then + BU.print1 "Normalized to:\n\t %s\n" (show c); + c in + let env_uvars = Env.uvars_in_env env in + let gen_uvars uvs = diff uvs env_uvars |> elems in /// GGG: bad, order depenedent + let univs_and_uvars_of_lec (lbname, e, c) = + let c = norm c in + let t = U.comp_result c in + let univs = Free.univs t in + let uvt = Free.uvars t in + if !dbg_Gen + then BU.print2 "^^^^\n\tFree univs = %s\n\tFree uvt=%s\n" + (show univs) (show uvt); + let univs = + List.fold_left + (fun univs uv -> union univs (Free.univs (U.ctx_uvar_typ uv))) + univs + (elems uvt) // Bad; order dependent + in + let uvs = gen_uvars uvt in + if !dbg_Gen + then BU.print2 "^^^^\n\tFree univs = %s\n\tgen_uvars = %s\n" + (show univs) (show uvs); + + univs, uvs, (lbname, e, c) + in + let univs, uvs, lec_hd = univs_and_uvars_of_lec (List.hd lecs) in + let force_univs_eq lec2 u1 u2 = + if equal u1 u2 + then () + else let lb1, _, _ = lec_hd in + let lb2, _, _ = lec2 in + let msg = BU.format2 "Generalizing the types of these mutually recursive definitions \ + requires an incompatible set of universes for %s and %s" + (show lb1) + (show lb2) in + raise_error env Errors.Fatal_IncompatibleSetOfUniverse msg + in + let force_uvars_eq lec2 (u1:list ctx_uvar) (u2:list ctx_uvar) = + let uvars_subseteq u1 u2 = + u1 |> BU.for_all (fun u -> + u2 |> BU.for_some (fun u' -> UF.equiv u.ctx_uvar_head u'.ctx_uvar_head)) + in + if uvars_subseteq u1 u2 + && uvars_subseteq u2 u1 + then () + else let lb1, _, _ = lec_hd in + let lb2, _, _ = lec2 in + let msg = BU.format2 "Generalizing the types of these mutually recursive definitions \ + requires an incompatible number of types for %s and %s" + (show lb1) + (show lb2) in + raise_error env Errors.Fatal_IncompatibleNumberOfTypes msg + in + + let lecs = + List.fold_right (fun this_lec lecs -> + let this_univs, this_uvs, this_lec = univs_and_uvars_of_lec this_lec in + force_univs_eq this_lec univs this_univs; + force_uvars_eq this_lec uvs this_uvs; + this_lec::lecs) + (List.tl lecs) + [] + in + + let lecs = lec_hd :: lecs in + + let gen_types (uvs:list ctx_uvar) : list (bv & bqual) = + uvs |> List.concatMap (fun u -> + (* If this implicit has a meta, don't generalize it. Just leave it + unresolved for the resolve_implicits phase to fill it in. *) + if Some? u.ctx_uvar_meta then [] else + + match UF.find u.ctx_uvar_head with + | Some _ -> failwith "Unexpected instantiation of mutually recursive uvar" + | _ -> + let k = N.normalize [Env.Beta; Env.Exclude Env.Zeta] env (U.ctx_uvar_typ u) in + let bs, kres = U.arrow_formals k in + //we only generalize variables at type k = a:Type{phi} + //where k is closed + //this is in support of ML-style polymorphism, while also allowing generalizing + //over things like eqtype, which is a common case + //Otherwise, things go badly wrong: see #1091 + match (U.unrefine (N.unfold_whnf env kres)).n with + | Tm_type _ -> + let free = FStarC.Syntax.Free.names kres in + if not (is_empty free) then + [] + else + let a = S.new_bv (Some <| Env.get_range env) kres in + let t = + match bs with + | [] -> S.bv_to_name a + | _ -> U.abs bs (S.bv_to_name a) (Some (U.residual_tot kres)) + in + U.set_uvar u.ctx_uvar_head t; + //t clearly has a free variable; this is the one place we break the + //invariant of a uvar always being resolved to a term well-typed in its given context + [a, S.as_bqual_implicit true] + + | _ -> + (* This uvar was not a type. Do not generalize it and + leave the rest of typechecker attempt solving it, or fail *) + [] + ) + in + + let gen_univs = gen_univs env univs in + let gen_tvars = gen_types uvs in + + let ecs = lecs |> List.map (fun (lbname, e, c) -> + let e, c, gvs = + match gen_tvars, gen_univs with + | [], [] -> + //nothing generalized + e, c, [] + + | _ -> + //before we manipulate the term further, we must normalize it to get rid of the invariant-broken uvars + let e0, c0 = e, c in + let c = N.normalize_comp [Env.Beta; Env.DoNotUnfoldPureLets; Env.CompressUvars; Env.NoFullNorm; Env.Exclude Env.Zeta] env c in + let e = N.reduce_uvar_solutions env e in + let e = + if is_rec + then let tvar_args = List.map (fun (x, _) -> S.iarg (S.bv_to_name x)) gen_tvars in + let instantiate_lbname_with_app tm fv = + if S.fv_eq fv (right lbname) + then S.mk_Tm_app tm tvar_args tm.pos + else tm + in FStarC.Syntax.InstFV.inst instantiate_lbname_with_app e + else e + in + //now, with the uvars gone, we can close over the newly introduced type names + let tvars_bs = gen_tvars |> List.map (fun (x, q) -> S.mk_binder_with_attrs x q None []) in + let t = match (SS.compress (U.comp_result c)).n with + | Tm_arrow {bs; comp=cod} -> + let bs, cod = SS.open_comp bs cod in + U.arrow (tvars_bs@bs) cod + + | _ -> + U.arrow tvars_bs c in + let e' = U.abs tvars_bs e (Some (U.residual_comp_of_comp c)) in + e', S.mk_Total t, tvars_bs in + (lbname, gen_univs, e, c, gvs)) + in + Some ecs + +let generalize' env (is_rec:bool) (lecs:list (lbname&term&comp)) : (list (lbname&univ_names&term&comp&list binder)) = + assert (List.for_all (fun (l, _, _) -> is_right l) lecs); //only generalize top-level lets + if Debug.low () then + BU.print1 "Generalizing: %s\n" + (show <| List.map (fun (lb, _, _) -> show lb) lecs); + let univnames_lecs = + let empty = from_list [] in + List.fold_left + (fun out (l, t, c) -> + union out (gather_free_univnames env t)) + empty + lecs + in + let univnames_lecs = elems univnames_lecs in /// GGG: bad, order dependent + let generalized_lecs = + match gen env is_rec lecs with + | None -> lecs |> List.map (fun (l,t,c) -> l,[],t,c,[]) + | Some luecs -> + if Debug.medium () + then luecs |> List.iter + (fun (l, us, e, c, gvs) -> + BU.print5 "(%s) Generalized %s at type %s\n%s\nVars = (%s)\n" + (show e.pos) + (show l) + (show (U.comp_result c)) + (show e) + (show gvs)); + luecs + in + List.map (fun (l, generalized_univs, t, c, gvs) -> + (l, check_universe_generalization univnames_lecs generalized_univs t, t, c, gvs)) + generalized_lecs + +let generalize env is_rec lecs = + Errors.with_ctx "While generalizing" (fun () -> + Profiling.profile (fun () -> generalize' env is_rec lecs) + (Some (Ident.string_of_lid (Env.current_module env))) + "FStarC.TypeChecker.Util.generalize" + ) diff --git a/src/typechecker/FStarC.TypeChecker.Generalize.fsti b/src/typechecker/FStarC.TypeChecker.Generalize.fsti new file mode 100644 index 00000000000..23da7cac5b9 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Generalize.fsti @@ -0,0 +1,32 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.TypeChecker.Generalize + +open FStar open FStarC.Compiler +open FStarC.Syntax.Syntax +open FStarC.TypeChecker.Env + +val generalize: + env -> + bool -> (* is_rec *) + list (lbname & term & comp) -> + list (lbname & univ_names & term & comp & list binder) + +val generalize_universes: + env -> + term -> + tscheme diff --git a/src/typechecker/FStarC.TypeChecker.NBE.fst b/src/typechecker/FStarC.TypeChecker.NBE.fst new file mode 100644 index 00000000000..be91269b552 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.NBE.fst @@ -0,0 +1,1541 @@ +(* + Copyright 2017-2019 Microsoft Research + + Authors: Zoe Paraskevopoulou, Guido Martinez, Nikhil Swamy + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.TypeChecker.NBE +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.TypeChecker.Cfg +open FStarC.TypeChecker +open FStarC.TypeChecker.Env +open FStarC.Syntax.Syntax +open FStarC.Ident +open FStarC.Errors +open FStarC.TypeChecker.Normalize +open FStarC.TypeChecker.NBETerm + +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module Range = FStarC.Compiler.Range +module U = FStarC.Syntax.Util +module P = FStarC.Syntax.Print +module BU = FStarC.Compiler.Util +module Env = FStarC.TypeChecker.Env +module Z = FStarC.BigInt +module C = FStarC.Const +module Cfg = FStarC.TypeChecker.Cfg +module PO = FStarC.TypeChecker.Primops +module NU = FStarC.TypeChecker.Normalize.Unfolding +module FC = FStarC.Const +module EMB = FStarC.Syntax.Embeddings +module PC = FStarC.Parser.Const +module TEQ = FStarC.TypeChecker.TermEqAndSimplify + +open FStarC.Class.Show +open FStarC.Class.Tagged + +let dbg_NBE = Debug.get_toggle "NBE" +let dbg_NBETop = Debug.get_toggle "NBETop" + +(* Broadly, the algorithm implemented here is inspired by + + Full Reduction at Full Throttle: + https://dl.acm.org/citation.cfm?id=2178141 + + Except, we don't implement any of the native tricks in the OCaml + runtime for compiling inductives and pattern matching. So, you + could see what we're doing here as, perhaps, "Full Reduction at + Half Throttle". + + More classically, what we have here is a definitional interpreter, + in the tradition of Reynolds' Definitional Interpreters: + https://dl.acm.org/citation.cfm?id=805852 (1972) + A more recent version of that paper is here: + http://homepages.inf.ed.ac.uk/wadler/papers/papers-we-love/reynolds-definitional-interpreters-1998.pdf + + The broad idea of the algorithm is sketched for a tiny lambda + calculus in examples/metatheory/FullReductionInterpreter.fst + + That's a good thing to digest before getting into the complexity of + the module here. + + A lot of the complexity here is in handling all the features of F*, + notably in the handling of inductive datatypes, pattern matching, + recursive definitions, and reified effects. +*) + + +//////////////////////////////////////////////////////////////////////////////// +// Utilities: Many of these should just move to FStarC.Compiler.List, if it's +// not already there +//////////////////////////////////////////////////////////////////////////////// + +// VD: This seems necessary for the OCaml build +let max a b = if a > b then a else b + +let map_rev (f : 'a -> 'b) (l : list 'a) : list 'b = + let rec aux (l:list 'a) (acc:list 'b) = //NS: weird, this needs an annotation to type-check in F*; cf issue # + match l with + | [] -> acc + | x :: xs -> aux xs (f x :: acc) + in aux l [] + +let map_rev_append (f : 'a -> 'b) (l1 : list 'a) (l2 : list 'b) : list 'b = + let rec aux (l:list 'a) (acc:list 'b) = + match l with + | [] -> l2 + | x :: xs -> aux xs (f x :: acc) + in aux l1 l2 + +let rec map_append (f : 'a -> 'b) (l1 : list 'a) (l2 : list 'b) : list 'b = + match l1 with + | [] -> l2 + | x :: xs -> (f x) :: map_append f xs l2 + +let rec drop (p: 'a -> bool) (l: list 'a): list 'a = + match l with + | [] -> [] + | x::xs -> if p x then x::xs else drop p xs + +let fmap_opt (f : 'a -> 'b) (x : option 'a) : option 'b = + BU.bind_opt x (fun x -> Some (f x)) + +let drop_until (f : 'a -> bool) (l : list 'a) : list 'a = + let rec aux l = + match l with + | [] -> [] + | x :: xs -> if f x then l else aux xs + in aux l + +let trim (l : list bool) : list bool = (* trim a list of booleans after the last true *) + List.rev (drop_until id (List.rev l)) + + +let implies b1 b2 = + match b1, b2 with + | false, _ -> true + | true, b2 -> b2 + +let let_rec_arity (b:letbinding) : int & list bool = + let (ar, maybe_lst) = U.let_rec_arity b in + match maybe_lst with + | None -> + ar, + FStarC.Common.tabulate ar (fun _ -> true) (* treat all arguments as recursive *) + | Some lst -> + ar, lst + // let l = trim lst in + // List.length l, l + +// NBE debuging + +let debug_term (t : term) = + BU.print1 "%s\n" (show t) + +let debug_sigmap (m : BU.smap sigelt) = + BU.smap_fold m (fun k v u -> BU.print2 "%s -> %%s\n" k (P.sigelt_to_string_short v)) () + + +//////////////////////////////////////////////////////////////////////////////// +//End utilities +//////////////////////////////////////////////////////////////////////////////// +type config = { + core_cfg:Cfg.cfg; + fv_cache:BU.smap t +} +let new_config (cfg:Cfg.cfg) = { + core_cfg = cfg; + fv_cache = BU.smap_create 51 +} +let reifying_false (cfg:config) = + if cfg.core_cfg.reifying + then new_config ({cfg.core_cfg with reifying=false}) //blow away cache + else cfg +let reifying_true (cfg:config) = + if not (cfg.core_cfg.reifying) + then new_config ({cfg.core_cfg with reifying=true}) //blow away cache + else cfg +let zeta_false (cfg:config) = + let cfg_core = cfg.core_cfg in + if cfg_core.steps.zeta + then + let cfg_core' = {cfg_core with steps={cfg_core.steps with zeta=false}} in // disable zeta flag + new_config cfg_core' //blow away cache + else cfg +let cache_add (cfg:config) (fv:fv) (v:t) = + let lid = fv.fv_name.v in + BU.smap_add cfg.fv_cache (string_of_lid lid) v +let try_in_cache (cfg:config) (fv:fv) : option t = + let lid = fv.fv_name.v in + BU.smap_try_find cfg.fv_cache (string_of_lid lid) +let debug cfg f = log_nbe cfg.core_cfg f + + +(* GM, Aug 19th 2018: This should not (at least always) be recursive. + * Forcing the thunk on an NBE term (Lazy i) triggers arbitrary + * computation, and it might very well turn out to normalize to another + * (Lazy i') (probably with i=i'). An example, from Meta-F*, is + * (pack_binder (pack_bv .., Q_Explicit)). + *) +let rec unlazy_unmeta t = + match t.nbe_t with + | Lazy (_, t) -> unlazy_unmeta (Thunk.force t) + | Meta(t0, m) -> + begin + match Thunk.force m with + | Meta_monadic(_, _) + | Meta_monadic_lift(_, _, _) -> t + | _ -> unlazy_unmeta t0 + end + | _ -> t + +let pickBranch (cfg:config) (scrut : t) (branches : list branch) : option (term & list t) = + let all_branches = branches in + let rec pickBranch_aux (scrut : t) (branches : list branch) (branches0 : list branch) : option (term & list t) = + //NS: adapted from FStarC.TypeChecker.Normalize: rebuild_match + let rec matches_pat (scrutinee0:t) (p:pat) + : either (list t) bool = + (* Inl ts: p matches t and ts are bindings for the branch *) + (* Inr false: p definitely does not match t *) + (* Inr true: p may match t, but p is an open term and we cannot decide for sure *) + debug cfg (fun () -> BU.print2 "matches_pat (%s, %s)\n" (t_to_string scrutinee0) (show p)); + let scrutinee = unlazy_unmeta scrutinee0 in + let r = match p.v with + | Pat_var bv -> + // important to use the non-unfolded variant, some embeddings + // have no decent unfolding (i.e. they cheat) + Inl [scrutinee0] + + | Pat_dot_term _ -> + Inl [] + + | Pat_constant s -> + let matches_const (c: t) (s: S.sconst) = + debug cfg (fun () -> BU.print2 "Testing term %s against pattern %s\n" + (t_to_string c) (show s)); + match c.nbe_t with + | Constant (Unit) -> s = C.Const_unit + | Constant (Bool b) -> (match s with | C.Const_bool p -> b = p | _ -> false) + | Constant (Int i) -> (match s with | C.Const_int (p, None) -> i = Z.big_int_of_string p | _ -> false) + | Constant (String (st, _)) -> (match s with | C.Const_string(p, _) -> st = p | _ -> false) + | Constant (Char c) -> (match s with | C.Const_char p -> c = p | _ -> false) + | _ -> false + in + if matches_const scrutinee s then Inl [] else Inr false + + | Pat_cons(fv, _us_opt, arg_pats) -> + let rec matches_args out (a:list (t & aqual)) (p:list (pat & bool)) + : either (list t) bool = + match a, p with + | [], [] -> Inl out + | (t, _)::rest_a, (p, _)::rest_p -> + (match matches_pat t p with + | Inl s -> matches_args (out@s) rest_a rest_p + | m -> m) + | _ -> + Inr false + in + match scrutinee.nbe_t with + | Construct(fv', _us, args_rev) -> + if fv_eq fv fv' + then matches_args [] (List.rev args_rev) arg_pats + else Inr false + + | _ -> //must be a variable + Inr true + in + let res_to_string = function + | Inr b -> "Inr " ^ BU.string_of_bool b + | Inl bs -> "Inl " ^ BU.string_of_int (List.length bs) + in + debug cfg (fun () -> BU.print3 "matches_pat (%s, %s) = %s\n" (t_to_string scrutinee) (show p) (res_to_string r)); + r + in + match branches with + | [] -> + None + + // TODO: Consider the when clause! + | (p, _wopt, e)::branches -> + match matches_pat scrut p with + | Inl matches -> + debug cfg (fun () -> BU.print1 "Pattern %s matches\n" (show p)); + Some (e, matches) + | Inr false -> //definitely did not match + pickBranch_aux scrut branches branches0 + | Inr true -> //maybe matches; stop + None + in pickBranch_aux scrut branches branches + +// Tests if a recursive function should be reduced based on +// the arguments provided and the arity/decreases clause of the function. +// Returns: +// should_unfold: bool, true, if the application is full and if none of the recursive +// arguments is symbolic. +// arguments : list arg, the arguments to the recursive function in reverse order +// residual args: list arg, any additional arguments, beyond the arity of the function +let should_reduce_recursive_definition + (arguments:args) + (formals_in_decreases:list bool) + : (bool & args & args) (* can unfold x full arg list x residual args *) + = + let rec aux ts ar_list acc = + match ts, ar_list with + | _, [] -> + true, acc, ts + | [], _ :: _ -> + false, acc, [] (* It's partial! *) + | t :: ts, in_decreases_clause :: bs -> + if in_decreases_clause + && isAccu (fst t) //one of the recursive arguments is symbolic, so we shouldn't reduce + then false, List.rev_append ts acc, [] + else aux ts bs (t::acc) + in + aux arguments formals_in_decreases [] + +let find_sigelt_in_gamma cfg (env: Env.env) (lid:lident): option sigelt = + let mapper (lr, rng) = + match lr with + | Inr (elt, None) -> Some elt + | Inr (elt, Some us) -> + debug cfg (fun () -> BU.print1 "Universes in local declaration: %s\n" (show us)); + Some elt + | _ -> None in + BU.bind_opt (Env.lookup_qname env lid) mapper + +let is_univ (tm : t) = + match tm.nbe_t with + | Univ _ -> true + | _ -> false + +let un_univ (tm:t) : universe = + match tm.nbe_t with + | Univ u -> u + | _ -> failwith ("Not a universe: " ^ t_to_string tm) + +let is_constr_fv (fvar : fv) : bool = + fvar.fv_qual = Some Data_ctor + +let is_constr (q : qninfo) : bool = + match q with + | Some (Inr ({ sigel = Sig_datacon _ }, _), _) -> true + | _ -> false + +let translate_univ (cfg:config) (bs:list t) (u:universe) : universe = + let rec aux u = + let u = SS.compress_univ u in + match u with + | U_bvar i -> + if i < List.length bs + then + let u' = List.nth bs i in //it has to be a Univ term at position i + (un_univ u') + else if cfg.core_cfg.steps.allow_unbound_universes + then U_zero + else failwith "Universe index out of bounds" + + | U_succ u -> U_succ (aux u) + + | U_max us -> U_max (List.map aux us) + + | U_unknown | U_name _ | U_unif _ | U_zero -> u + in + aux u + +let find_let (lbs : list letbinding) (fvar : fv) = + BU.find_map lbs (fun lb -> match lb.lbname with + | Inl _ -> failwith "find_let : impossible" + | Inr name -> + if fv_eq name fvar + then Some lb + else None) + +let mk_rt r t = { nbe_t = t; nbe_r = r } +let mk_t t = { nbe_t = t; nbe_r = Range.dummyRange } + +/// Normalization is implemented using two mutually recursive functions, +/// translate and readback, +/// i.e., `norm cfg t = readback cfg (translate cfg [] t)` +/// +/// For `translate`: +/// +/// - `cfg` records various configuration options, e.g., which +/// definitions are to be unfolded +/// +/// - `bs` is an environment for the bound variables in scope, in de +/// Bruijn order (i.e., most recent binders are the head of the list) +/// +/// - `e:term` is the syntax being reduced +/// +/// The main idea is to translate syntactic entities, notably +/// functions, into functions of the host language; and +/// correspondingly, source beta redexes into host language +/// applications. As such, the process of translation triggers +/// call-by-value reduction of the syntax, relying on the reduction +/// strategy of the host. +let rec translate (cfg:config) (bs:list t) (e:term) : t = + let debug = debug cfg in + let mk_t t = mk_rt e.pos t in + debug (fun () -> BU.print2 "Term: %s - %s\n" (tag_of (SS.compress e)) (show (SS.compress e))); +// debug (fun () -> BU.print1 "BS list: %s\n" (String.concat ";; " (List.map (fun x -> t_to_string x) bs))); + match (SS.compress e).n with + | Tm_delayed _ -> + failwith "Tm_delayed: Impossible" + + | Tm_unknown -> + mk_t Unknown + + | Tm_constant c -> + mk_t <| Constant (translate_constant c) + + | Tm_bvar db -> //de Bruijn + if db.index < List.length bs + then + let t = List.nth bs db.index in + debug (fun () -> BU.print2 "Resolved bvar to %s\n\tcontext is [%s]\n" + (t_to_string t) + (List.map t_to_string bs |> String.concat "; ") + ); + t + else failwith "de Bruijn index out of bounds" + + | Tm_uinst(t, us) -> + debug (fun () -> BU.print2 "Uinst term : %s\nUnivs : %s\n" (show t) + (List.map show us |> String.concat ", ")); + iapp cfg (translate cfg bs t) (List.map (fun x -> as_arg (mk_t <| Univ (translate_univ cfg bs x))) us) + + | Tm_type u -> + mk_t <| Type_t (translate_univ cfg bs u) + + | Tm_arrow {bs=xs; comp=c} -> + let norm () = + let ctx, binders_rev = + List.fold_left + (fun (ctx, binders_rev) b -> + let x = b.binder_bv in + let t = readback cfg (translate cfg ctx x.sort) in + let x = { S.freshen_bv x with sort = t } in + let ctx = mkAccuVar x :: ctx in + ctx, ({b with binder_bv=x}) :: binders_rev) + (bs, []) + xs + in + let c = readback_comp cfg (translate_comp cfg ctx c) in + U.arrow (List.rev binders_rev) c + in + mk_t <| Arrow (Inl (Thunk.mk norm)) + + | Tm_refine {b=bv; phi=tm} -> + if cfg.core_cfg.steps.for_extraction + || cfg.core_cfg.steps.unrefine + then translate cfg bs bv.sort //if we're only extracting, then drop the refinement + else mk_t <| Refinement ((fun (y:t) -> translate cfg (y::bs) tm), + (fun () -> as_arg (translate cfg bs bv.sort))) // XXX: Bogus type? + + | Tm_ascribed {tm=t} -> + translate cfg bs t + + | Tm_uvar (u, (subst, set_use_range)) -> + let norm_uvar () = + let norm_subst_elt = function + | NT(x, t) -> + NT(x, readback cfg (translate cfg bs t)) + | NM(x, i) -> + let x_i = S.bv_to_tm ({x with index=i}) in + let t = readback cfg (translate cfg bs x_i) in + (match t.n with + | Tm_bvar x_j -> NM(x, x_j.index) + | _ -> NT(x, t)) + | _ -> failwith "Impossible: subst invariant of uvar nodes" + in + let subst = List.map (List.map norm_subst_elt) subst in + { e with n = Tm_uvar(u, (subst, set_use_range)) } + in + mk_t <| Accu(UVar (Thunk.mk norm_uvar), []) + + | Tm_name x -> + mkAccuVar x + + | Tm_abs {bs=[]} -> failwith "Impossible: abstraction with no binders" + + | Tm_abs {bs=xs; body; rc_opt=resc} -> + mk_t <| Lam { + interp = (fun ys -> translate cfg (List.append (List.map fst ys) bs) body); + shape = Lam_bs (bs, xs, resc); + arity = List.length xs; + } + + | Tm_fvar fvar -> + begin + match try_in_cache cfg fvar with + | Some t -> t + | _ -> translate_fv cfg bs (S.set_range_of_fv fvar e.pos) + end + + | Tm_app {hd={n=Tm_constant (FC.Const_reify _)}; args=arg::more::args} + | Tm_app {hd={n=Tm_constant (FC.Const_reflect _)}; args=arg::more::args} -> + let head, _ = U.head_and_args e in + let head = S.mk_Tm_app head [arg] e.pos in + translate cfg bs (S.mk_Tm_app head (more::args) e.pos) + + | Tm_app {hd={n=Tm_constant (FC.Const_reflect _)}; args=[arg]} when cfg.core_cfg.reifying -> + let cfg = reifying_false cfg in + translate cfg bs (fst arg) + + | Tm_app {hd={n=Tm_constant (FC.Const_reflect _)}; args=[arg]} -> + mk_t <| Reflect (translate cfg bs (fst arg)) + + | Tm_app {hd={n=Tm_constant (FC.Const_reify _)}; args=[arg]} + when cfg.core_cfg.steps.reify_ -> + assert (not cfg.core_cfg.reifying); + let cfg = reifying_true cfg in + translate cfg bs (fst arg) + + | Tm_app {hd={n=Tm_constant (FC.Const_reflect _)}; args=[arg]} -> + mk_t <| Reflect (translate cfg bs (fst arg)) + + | Tm_app {hd={n=Tm_fvar fv}; args=[_]} + when S.fv_eq_lid fv PC.assert_lid || + S.fv_eq_lid fv PC.assert_norm_lid -> + debug (fun () -> BU.print_string "Eliminated assertion\n"); + mk_t (Constant Unit) + + | Tm_app {hd=head; args} + when (Cfg.cfg_env cfg.core_cfg).erase_erasable_args + || cfg.core_cfg.steps.for_extraction + || cfg.core_cfg.debug.erase_erasable_args (* for debugging *) -> + iapp cfg (translate cfg bs head) + (List.map + (fun x -> + if U.aqual_is_erasable (snd x) + then ( + debug (fun () -> BU.print1 "Erasing %s\n" (show (fst x))); + mk_t (Constant Unit), snd x + ) + else translate cfg bs (fst x), snd x) + args) + + | Tm_app {hd=head; args} -> + debug (fun () -> BU.print2 "Application: %s @ %s\n" (show head) (show args)); + iapp cfg (translate cfg bs head) (List.map (fun x -> (translate cfg bs (fst x), snd x)) args) // Zoe : TODO avoid translation pass for args + + | Tm_match {scrutinee=scrut; ret_opt; brs=branches; rc_opt=rc} -> + (* Thunked computation to reconstrct the returns annotation *) + let make_returns () : option match_returns_ascription = + match ret_opt with + | None -> None + | Some (b, asc) -> + let b, bs = + let x = gen_bv' b.binder_bv.ppname None (readback cfg (translate cfg bs b.binder_bv.sort)) in + mk_binder x, mkAccuVar x::bs in + let asc = + match asc with + | Inl t, tacopt, use_eq -> Inl (readback cfg (translate cfg bs t)), tacopt, use_eq + | Inr c, tacopt, use_eq -> Inr (readback_comp cfg (translate_comp cfg bs c)), tacopt, use_eq in + let asc = SS.close_ascription [b] asc in + let b = List.hd (SS.close_binders [b]) in + Some (b, asc) in + + (* Thunked computation to reconstruct residual comp *) + let make_rc () : option S.residual_comp = + match rc with + | None -> None + | Some rc -> Some (readback_residual_comp cfg (translate_residual_comp cfg bs rc)) in + + (* Thunked computation that reconstructs the patterns *) + let make_branches () : list branch = + let cfg = zeta_false cfg in + let rec process_pattern bs (p:pat) : list t & pat = (* returns new environment and pattern *) + let (bs, p_new) = + match p.v with + | Pat_constant c -> (bs, Pat_constant c) + | Pat_cons (fvar, us_opt, args) -> + let (bs', args') = + List.fold_left (fun (bs, args) (arg, b) -> + let (bs', arg') = process_pattern bs arg in + (bs', (arg', b) :: args)) (bs, []) args + in + let us_opt = + match us_opt with + | None -> None + | Some us -> Some (List.map (translate_univ cfg bs) us) + in + (bs', Pat_cons (fvar, us_opt, List.rev args')) + | Pat_var bvar -> + let x = S.gen_bv' bvar.ppname None (readback cfg (translate cfg bs bvar.sort)) in + (mkAccuVar x :: bs, Pat_var x) + | Pat_dot_term eopt -> + (bs, + Pat_dot_term (BU.map_option (fun e -> readback cfg (translate cfg bs e)) eopt)) + in + (bs, {p with v = p_new}) (* keep the info and change the pattern *) + in + List.map (fun (pat, when_clause, e) -> + let (bs', pat') = process_pattern bs pat in + (* TODO : handle when clause *) + U.branch (pat', when_clause, readback cfg (translate cfg bs' e))) branches + in + + let scrut = translate cfg bs scrut in + debug (fun () -> BU.print2 "%s: Translating match %s\n" + (Range.string_of_range e.pos) + (show e)); + let scrut = unlazy_unmeta scrut in + begin + match scrut.nbe_t with + | Construct(c, us, args) -> (* Scrutinee is a constructed value *) + (* Assuming that all the arguments to the pattern constructors + are binders -- i.e. no nested patterns for now *) + debug (fun () -> + BU.print1 "Match args: %s\n" + (args + |> List.map (fun (x, q) -> (if BU.is_some q then "#" else "") ^ t_to_string x) + |> String.concat "; ")); + begin + match pickBranch cfg scrut branches with + | Some (branch, args) -> + translate cfg (List.fold_left (fun bs x -> x::bs) bs args) branch + | None -> //no branch is determined + mkAccuMatch scrut make_returns make_branches make_rc + end + | Constant c -> + debug (fun () -> BU.print1 "Match constant : %s\n" (t_to_string scrut)); + (* same as for construted values, but args are either empty or is a singleton list (for wildcard patterns) *) + (match pickBranch cfg scrut branches with + | Some (branch, []) -> + translate cfg bs branch + | Some (branch, [arg]) -> + translate cfg (arg::bs) branch + | None -> //no branch is determined + mkAccuMatch scrut make_returns make_branches make_rc + | Some (_, hd::tl) -> + failwith "Impossible: Matching on constants cannot bind more than one variable") + + | _ -> + mkAccuMatch scrut make_returns make_branches make_rc + end + + | Tm_meta {tm=e; meta=Meta_monadic(m, t)} + when cfg.core_cfg.reifying -> + translate_monadic (m, t) cfg bs e + + | Tm_meta {tm=e; meta=Meta_monadic_lift(m, m', t)} + when cfg.core_cfg.reifying -> + translate_monadic_lift (m, m', t) cfg bs e + + | Tm_meta {tm=e; meta} -> + let norm_meta () = + let norm t = readback cfg (translate cfg bs t) in + match meta with + | Meta_named _ + | Meta_labeled _ + | Meta_desugared _ -> meta + | Meta_pattern (ts, args) -> + Meta_pattern (List.map norm ts, + List.map (List.map (fun (t, a) -> norm t, a)) args) + | Meta_monadic(m, t) -> + Meta_monadic(m, norm t) + | Meta_monadic_lift(m0, m1, t) -> + Meta_monadic_lift(m0, m1, norm t) + in + mk_t <| Meta(translate cfg bs e, Thunk.mk norm_meta) + + | Tm_let {lbs=(false, [lb]); body} -> // non-recursive let + if Cfg.should_reduce_local_let cfg.core_cfg lb + then if cfg.core_cfg.steps.for_extraction + && U.is_unit lb.lbtyp + && U.is_pure_or_ghost_effect lb.lbeff + then let bs = mk_rt (S.range_of_lbname lb.lbname) (Constant Unit) :: bs in + translate cfg bs body + else let bs = translate_letbinding cfg bs lb :: bs in + translate cfg bs body + else let def () = + if cfg.core_cfg.steps.for_extraction + && U.is_unit lb.lbtyp + && U.is_pure_or_ghost_effect lb.lbeff + then mk_t <| Constant Unit + else translate cfg bs lb.lbdef + in + let typ () = translate cfg bs lb.lbtyp in + let name = freshen_bv (BU.left lb.lbname) in + let bs = mk_rt (S.range_of_bv name) (Accu (Var name, [])) :: bs in + let body () = translate cfg bs body in + mk_t <| Accu(UnreducedLet(name, Thunk.mk typ, Thunk.mk def, Thunk.mk body, lb), []) + + | Tm_let {lbs=(_rec, lbs); body} -> //recursive let + if not cfg.core_cfg.steps.zeta && + cfg.core_cfg.steps.pure_subterms_within_computations + then //can't reduce this let rec + let vars = List.map (fun lb -> freshen_bv (BU.left lb.lbname)) lbs in + let typs = List.map (fun lb -> translate cfg bs lb.lbtyp) lbs in + let rec_bs = List.map (fun v -> mk_rt (S.range_of_bv v) <| Accu (Var v, [])) vars @ bs in + let defs = List.map (fun lb -> translate cfg rec_bs lb.lbdef) lbs in + let body = translate cfg rec_bs body in + mk_t <| Accu(UnreducedLetRec(List.zip3 vars typs defs, body, lbs), []) + else translate cfg (make_rec_env lbs bs) body + + | Tm_quoted (qt, qi) -> + let close t = + let bvs = List.map (fun _ -> S.new_bv None S.tun) bs in + let s1 = List.mapi (fun i bv -> DB (i, bv)) bvs in + let s2 = List.map (fun (bv, t) -> NT (bv, readback cfg t)) (List.zip bvs bs) in + SS.subst s2 (SS.subst s1 t) + in + begin match qi.qkind with + | Quote_dynamic -> + let qt = close qt in + mk_t <| Quote (qt, qi) + | Quote_static -> + let qi = S.on_antiquoted close qi in + mk_t <| Quote (qt, qi) + end + + | Tm_lazy li -> + let f () = + let t = U.unfold_lazy li in + debug (fun () -> BU.print1 ">> Unfolding Tm_lazy to %s\n" (show t)); + translate cfg bs t + in + mk_t <| Lazy (Inl li, Thunk.mk f) + +and translate_comp cfg bs (c:S.comp) : comp = + match c.n with + | S.Total typ -> Tot (translate cfg bs typ) + | S.GTotal typ -> GTot (translate cfg bs typ) + | S.Comp ctyp -> Comp (translate_comp_typ cfg bs ctyp) + +(* uncurried application *) +and iapp (cfg : config) (f:t) (args:args) : t = + // meta and lazy nodes shouldn't block reduction + let mk t = mk_rt f.nbe_r t in + match (unlazy_unmeta f).nbe_t with + | Lam {interp=f; shape; arity=n} -> + let m = List.length args in + if m < n then + // partial application + let arg_values_rev = List.rev args in + let shape = + match shape with + | Lam_args raw_args -> + let _, raw_args = List.splitAt m raw_args in + Lam_args raw_args + + | Lam_bs (ctx, xs, rc) -> + let _, xs = List.splitAt m xs in + let ctx = List.append (List.map fst arg_values_rev) ctx in + Lam_bs (ctx, xs, rc) + + | Lam_primop (f, args_acc) -> + Lam_primop (f, args_acc @ args) + in + mk <| + Lam { + interp = (fun l -> f (List.append l arg_values_rev)); + shape = shape; + arity = n-m; + } + else if m = n then + // full application + let arg_values_rev = List.rev args in + f arg_values_rev + else + // extra arguments + let (args, args') = List.splitAt n args in + iapp cfg (f (List.rev args)) args' + | Accu (a, ts) -> mk <| Accu (a, List.rev_append args ts) + | Construct (i, us, ts) -> + let rec aux args us ts = + match args with + | ({nbe_t=Univ u}, _) :: args -> aux args (u :: us) ts + | a :: args -> aux args us (a :: ts) + | [] -> (us, ts) + in + let (us', ts') = aux args us ts in + mk <| Construct (i, us', ts') + | FV (i, us, ts) -> + let rec aux args us ts = + match args with + | ({nbe_t=Univ u}, _) :: args -> aux args (u :: us) ts + | a :: args -> aux args us (a :: ts) + | [] -> (us, ts) + in + let (us', ts') = aux args us ts in + mk <| FV (i, us', ts') + + | TopLevelLet(lb, arity, args_rev) -> + let args_rev = List.rev_append args args_rev in + let n_args_rev = List.length args_rev in + let n_univs = List.length lb.lbunivs in + debug cfg (fun () -> + BU.print3 "Reached iapp for %s with arity %s and n_args = %s\n" + (show lb.lbname) + (show arity) + (show n_args_rev)); + if n_args_rev >= arity + then let bs, body = + match (U.unascribe lb.lbdef).n with + | Tm_abs {bs; body} -> bs, body + | _ -> [], lb.lbdef + in + if n_univs + List.length bs = arity + then let extra, args_rev = BU.first_N (n_args_rev - arity) args_rev in + debug cfg (fun () -> + BU.print3 "Reducing body of %s = %s,\n\twith args = %s\n" + (show lb.lbname) + (show body) + (show args_rev)); + let t = translate cfg (List.map fst args_rev) body in + match extra with + | [] -> t + | _ -> iapp cfg t (List.rev extra) + else let extra, univs = BU.first_N (n_args_rev - n_univs) args_rev in + iapp cfg (translate cfg (List.map fst univs) lb.lbdef) (List.rev extra) + else mk <| TopLevelLet (lb, arity, args_rev) //not enough args yet + + | TopLevelRec (lb, arity, decreases_list, args') -> + let args = List.append args' args in + if List.length args >= arity + then let should_reduce, _, _ = + should_reduce_recursive_definition args decreases_list + in + if not should_reduce + then begin + let fv = BU.right lb.lbname in + debug cfg (fun () -> BU.print1 "Decided to not unfold recursive definition %s\n" (show fv)); + iapp cfg (mk_rt (S.range_of_fv fv) (FV (fv, [], []))) args + end + else begin + debug cfg (fun () -> BU.print1 "Yes, Decided to unfold recursive definition %s\n" (show (BU.right lb.lbname))); + let univs, rest = BU.first_N (List.length lb.lbunivs) args in + iapp cfg (translate cfg (List.rev (List.map fst univs)) lb.lbdef) rest + end + else //not enough args yet + mk <| TopLevelRec (lb, arity, decreases_list, args) + + | LocalLetRec(i, lb, mutual_lbs, local_env, acc_args, remaining_arity, decreases_list) -> + if remaining_arity = 0 //we've already decided to not unfold this, so just accumulate + then mk <| LocalLetRec(i, lb, mutual_lbs, local_env, acc_args @ args, remaining_arity, decreases_list) + else + let n_args = List.length args in + if n_args < remaining_arity //still a partial application, just accumulate + then mk <| LocalLetRec(i, lb, mutual_lbs, local_env, acc_args @ args, remaining_arity - n_args, decreases_list) + else begin + let args = acc_args @ args in (* Not in reverse order *) + let should_reduce, _, _ = + should_reduce_recursive_definition args decreases_list + in + //local let binding don't have universes + if not should_reduce + then mk <| LocalLetRec(i, lb, mutual_lbs, local_env, args, 0, decreases_list) + else let env = make_rec_env mutual_lbs local_env in + let _ = + debug cfg (fun () -> + BU.print1 "LocalLetRec Env = {\n\t%s\n}\n" (String.concat ",\n\t " (List.map t_to_string env)); + BU.print1 "LocalLetRec Args = {\n\t%s\n}\n" (String.concat ",\n\t " (List.map (fun (t, _) -> t_to_string t) args))) + in + iapp cfg (translate cfg env lb.lbdef) args + end + + | Constant (SConst FStarC.Const.Const_range_of) -> + let callbacks = { + iapp = iapp cfg; + translate = translate cfg []; + } in + begin + match args with + | [(a, _)] -> + embed e_range callbacks a.nbe_r + // mk_rt a.nbe_r (Constant (Range a.nbe_r)) + | _ -> failwith ("NBE ill-typed application Const_range_of: " ^ t_to_string f) + end + + | Constant (SConst FStarC.Const.Const_set_range_of) -> + begin + let callbacks = { + iapp = iapp cfg; + translate = translate cfg []; + } in + match args with + | [(t, _); (r, _)] -> ( + match unembed e_range callbacks r with + | Some rr -> { t with nbe_r = rr } + | None -> magic() + ) + | _ -> failwith ("NBE ill-typed application Const_set_range_of: " ^ t_to_string f) + end + + | _ -> + failwith ("NBE ill-typed application: " ^ t_to_string f) + + +and translate_fv (cfg: config) (bs:list t) (fvar:fv): t = + let debug = debug cfg in + let qninfo = Env.lookup_qname (Cfg.cfg_env cfg.core_cfg) (S.lid_of_fv fvar) in + if is_constr qninfo || is_constr_fv fvar then mkConstruct fvar [] [] + else + match NU.should_unfold cfg.core_cfg (fun _ -> cfg.core_cfg.reifying) fvar qninfo with + | NU.Should_unfold_fully -> + failwith "Not yet handled" + + | NU.Should_unfold_no -> + debug (fun () -> BU.print1 "(1) Decided to not unfold %s\n" (show fvar)); + begin match Cfg.find_prim_step cfg.core_cfg fvar with + | Some prim_step when prim_step.strong_reduction_ok (* TODO : || not cfg.strong *) -> + let arity = prim_step.arity + prim_step.univ_arity in + debug (fun () -> BU.print1 "Found a primop %s\n" (show fvar)); + mk_t <| Lam { + interp = (fun args_rev -> + let args' = List.rev args_rev in + let callbacks = { + iapp = iapp cfg; + translate = translate cfg bs; + } in + debug (fun () -> BU.print1 "Caling primop with args = [%s]\n" (show args')); + let univs, rest = List.span (function ({nbe_t=Univ _ }, _) -> true | _ -> false) args' in + let univs = List.map (function ({nbe_t=Univ u}, _) -> u | _ -> failwith "Impossible") univs in + match prim_step.interpretation_nbe callbacks univs rest with + | Some x -> + debug (fun () -> BU.print2 "Primitive operator %s returned %s\n" (show fvar) (t_to_string x)); + x + | None -> + debug (fun () -> BU.print1 "Primitive operator %s failed\n" (show fvar)); + iapp cfg (mkFV fvar [] []) args'); + shape = Lam_primop (fvar, []); + arity = arity; + } + + | Some _ -> debug (fun () -> BU.print1 "(2) Decided to not unfold %s\n" (show fvar)); mkFV fvar [] [] + | _ -> debug (fun () -> BU.print1 "(3) Decided to not unfold %s\n" (show fvar)); mkFV fvar [] [] + end + + + | NU.Should_unfold_reify + | NU.Should_unfold_yes -> + let t = + let is_qninfo_visible = + Option.isSome (Env.lookup_definition_qninfo cfg.core_cfg.delta_level fvar.fv_name.v qninfo) + in + if is_qninfo_visible + then begin + match qninfo with + | Some (Inr ({ sigel = Sig_let {lbs=(is_rec, lbs); lids=names} }, _us_opt), _rng) -> + debug (fun () -> BU.print1 "(1) Decided to unfold %s\n" (show fvar)); + let lbm = find_let lbs fvar in + begin match lbm with + | Some lb -> + if is_rec && cfg.core_cfg.steps.zeta + then + let ar, lst = let_rec_arity lb in + mk_rt (S.range_of_fv fvar) <| TopLevelRec(lb, ar, lst, []) + else + translate_letbinding cfg bs lb + | None -> failwith "Could not find let binding" + end + | _ -> + debug (fun () -> BU.print1 "(1) qninfo is None for (%s)\n" (show fvar)); + mkFV fvar [] [] + end + else begin + debug (fun () -> BU.print1 "(1) qninfo is not visible at this level (%s)\n" (show fvar)); + mkFV fvar [] [] + end + in + cache_add cfg fvar t; + t + +(* translate a let-binding - local or global *) +and translate_letbinding (cfg:config) (bs:list t) (lb:letbinding) : t = + let debug = debug cfg in + let us = lb.lbunivs in + let formals, _ = U.arrow_formals lb.lbtyp in + let arity = List.length us + List.length formals in + if arity = 0 + then translate cfg bs lb.lbdef + else if BU.is_right lb.lbname + then let _ = debug (fun () -> BU.print2 "Making TopLevelLet for %s with arity %s\n" (show lb.lbname) (show arity)) in + mk_rt (S.range_of_lbname lb.lbname) <| TopLevelLet(lb, arity, []) + else translate cfg bs lb.lbdef //local let-binding, cannot be universe polymorphic + // Note, we only have universe polymorphic top-level pure terms (i.e., fvars bound to pure terms) + // Thunking them is probably okay, since the common case is really top-level function + // rather than top-level pure computation + + +and mkRec i (b:letbinding) (bs:list letbinding) (env:list t) = + let (ar, ar_lst) = let_rec_arity b in + mk_t <| LocalLetRec(i, b, bs, env, [], ar, ar_lst) + +(* Creates the environment of mutually recursive function definitions *) +and make_rec_env (all_lbs:list letbinding) (all_outer_bs:list t) : list t = + let rec_bindings = List.mapi (fun i lb -> mkRec i lb all_lbs all_outer_bs) all_lbs in + List.rev_append rec_bindings all_outer_bs + +and translate_constant (c : sconst) : constant = + match c with + | C.Const_unit -> Unit + | C.Const_bool b -> Bool b + | C.Const_int (s, None) -> Int (Z.big_int_of_string s) + | C.Const_string (s, r) -> String (s,r) + | C.Const_char c -> Char c + | C.Const_range r -> Range r + | C.Const_real r -> Real r + | _ -> SConst c + +and readback_comp cfg (c: comp) : S.comp = + let c' = + match c with + | Tot typ -> S.Total (readback cfg typ) + | GTot typ -> S.GTotal (readback cfg typ) + | Comp ctyp -> S.Comp (readback_comp_typ cfg ctyp) + in S.mk c' Range.dummyRange + +and translate_comp_typ cfg bs (c:S.comp_typ) : comp_typ = + let { S.comp_univs = comp_univs + ; S.effect_name = effect_name + ; S.result_typ = result_typ + ; S.effect_args = effect_args + ; S.flags = flags } = c in + { comp_univs = List.map (translate_univ cfg bs) comp_univs; + effect_name = effect_name; + result_typ = translate cfg bs result_typ; + effect_args = List.map (fun x -> translate cfg bs (fst x), snd x) effect_args; + flags = List.map (translate_flag cfg bs) flags } + +and readback_comp_typ cfg (c:comp_typ) : S.comp_typ = + { S.comp_univs = c.comp_univs; + S.effect_name = c.effect_name; + S.result_typ = readback cfg c.result_typ; + S.effect_args = List.map (fun x -> readback cfg (fst x), snd x) c.effect_args; + S.flags = List.map (readback_flag cfg) c.flags } + +and translate_residual_comp cfg bs (c:S.residual_comp) : residual_comp = + let { S.residual_effect = residual_effect + ; S.residual_typ = residual_typ + ; S.residual_flags = residual_flags } = c in + { residual_effect = residual_effect; + residual_typ = + (if cfg.core_cfg.steps.for_extraction + then None + else BU.map_opt residual_typ (translate cfg bs)); + residual_flags = List.map (translate_flag cfg bs) residual_flags } + +and readback_residual_comp cfg (c:residual_comp) : S.residual_comp = + { S.residual_effect = c.residual_effect; + S.residual_typ = BU.map_opt c.residual_typ (fun x -> debug cfg (fun () -> BU.print1 "Reading back residualtype %s\n" (t_to_string x)); readback cfg x); + S.residual_flags = List.map (readback_flag cfg) c.residual_flags } + +and translate_flag cfg bs (f : S.cflag) : cflag = + match f with + | S.TOTAL -> TOTAL + | S.MLEFFECT -> MLEFFECT + | S.RETURN -> RETURN + | S.PARTIAL_RETURN -> PARTIAL_RETURN + | S.SOMETRIVIAL -> SOMETRIVIAL + | S.TRIVIAL_POSTCONDITION -> TRIVIAL_POSTCONDITION + | S.SHOULD_NOT_INLINE -> SHOULD_NOT_INLINE + | S.LEMMA -> LEMMA + | S.CPS -> CPS + | S.DECREASES (S.Decreases_lex l) -> DECREASES_lex (l |> List.map (translate cfg bs)) + | S.DECREASES (S.Decreases_wf (rel, e)) -> + DECREASES_wf (translate cfg bs rel, translate cfg bs e) + +and readback_flag cfg (f : cflag) : S.cflag = + match f with + | TOTAL -> S.TOTAL + | MLEFFECT -> S.MLEFFECT + | RETURN -> S.RETURN + | PARTIAL_RETURN -> S.PARTIAL_RETURN + | SOMETRIVIAL -> S.SOMETRIVIAL + | TRIVIAL_POSTCONDITION -> S.TRIVIAL_POSTCONDITION + | SHOULD_NOT_INLINE -> S.SHOULD_NOT_INLINE + | LEMMA -> S.LEMMA + | CPS -> S.CPS + | DECREASES_lex l -> S.DECREASES (S.Decreases_lex (l |> List.map (readback cfg))) + | DECREASES_wf (rel, e) -> + S.DECREASES (S.Decreases_wf (readback cfg rel, readback cfg e)) + +and translate_monadic (m, ty) cfg bs e : t = + let e = U.unascribe e in + match e.n with + | Tm_let {lbs=(false, [lb]); body} -> //elaborate this to M.bind + begin + match Env.effect_decl_opt cfg.core_cfg.tcenv (Env.norm_eff_name cfg.core_cfg.tcenv m) with + | None -> + failwith (BU.format1 "Effect declaration not found: %s" (Ident.string_of_lid m)) + + | Some (ed, q) -> + let cfg' = reifying_false cfg in + let body_lam = + let body_rc = { + S.residual_effect=m; + S.residual_flags=[]; + S.residual_typ=Some ty + } in + S.mk (Tm_abs {bs=[S.mk_binder (BU.left lb.lbname)]; body; rc_opt=Some body_rc}) body.pos + in + let maybe_range_arg = + if BU.for_some (TEQ.eq_tm_bool cfg.core_cfg.tcenv U.dm4f_bind_range_attr) ed.eff_attrs + then [translate cfg [] (PO.embed_simple lb.lbpos lb.lbpos), None; + translate cfg [] (PO.embed_simple body.pos body.pos), None] + else [] + in + let t = + iapp cfg (iapp cfg (translate cfg' [] (U.un_uinst (ed |> U.get_bind_repr |> BU.must |> snd))) + [mk_t <| Univ U_unknown, None; //We are cheating here a bit + mk_t <| Univ U_unknown, None]) //to avoid re-computing the universe of lb.lbtyp + //and ty below; but this should be okay since these + //arguments should not actually appear in the resulting + //term + ( + [(translate cfg' bs lb.lbtyp, None); //translating the type of the bound term + (translate cfg' bs ty, None)] //and the body is sub-optimal; it is often unused + @maybe_range_arg //some effects take two additional range arguments for debugging + @[(mk_t Unknown, None) ; //unknown WP of lb.lbdef; same as the universe argument ... should not appear in the result + (translate cfg bs lb.lbdef, None); + (mk_t Unknown, None) ; //unknown WP of body; ditto + (translate cfg bs body_lam, None)] + ) + in + debug cfg (fun () -> BU.print1 "translate_monadic: %s\n" (t_to_string t)); + t + + end + + | Tm_app {hd={n=Tm_constant (FC.Const_reflect _)}; args=[(e, _)]} -> + translate (reifying_false cfg) bs e + + | Tm_app {hd=head; args} -> + debug cfg (fun () -> BU.print2 "translate_monadic app (%s) @ (%s)\n" (show head) + (show args)); + let fallback1 () = + translate cfg bs e + in + let fallback2 () = + translate (reifying_false cfg) bs (S.mk (Tm_meta {tm=e; meta=Meta_monadic (m, ty)}) e.pos) + in + begin match (U.un_uinst head).n with + | Tm_fvar fv -> + let lid = S.lid_of_fv fv in + let qninfo = Env.lookup_qname cfg.core_cfg.tcenv lid in + if not (Env.is_action cfg.core_cfg.tcenv lid) then fallback1 () else + + (* GM: I think the action *must* be fully applied at this stage + * since we were triggered into this function by a Meta_monadic + * annotation. So we don't check anything. *) + + (* Fallback if it does not have a definition. This happens, + * but I'm not sure why. *) + if Option.isNone (Env.lookup_definition_qninfo cfg.core_cfg.delta_level fv.fv_name.v qninfo) + then fallback2 () + else + + (* Turn it info (reify head) args, then translate_fv will kick in on the head *) + let e = S.mk_Tm_app (U.mk_reify head None) args e.pos in + translate (reifying_false cfg) bs e + | _ -> + fallback1 () + end + + | Tm_match {scrutinee=sc; ret_opt=asc_opt; brs=branches; rc_opt=lopt} -> + (* Commutation of reify with match. See the comment in the normalizer about it. *) + let branches = branches |> List.map (fun (pat, wopt, tm) -> pat, wopt, U.mk_reify tm (Some m)) in + let tm = S.mk (Tm_match {scrutinee=sc; ret_opt=asc_opt; brs=branches; rc_opt=lopt}) e.pos in + translate (reifying_false cfg) bs tm + + | Tm_meta {tm=t; meta=Meta_monadic _} -> + translate_monadic (m, ty) cfg bs e + + | Tm_meta {tm=t; meta=Meta_monadic_lift (msrc, mtgt, ty')} -> + translate_monadic_lift (msrc, mtgt, ty') cfg bs e + + | _ -> failwith (BU.format1 "Unexpected case in translate_monadic: %s" (tag_of e)) + +and translate_monadic_lift (msrc, mtgt, ty) cfg bs e : t = + let e = U.unascribe e in + if U.is_pure_effect msrc || U.is_div_effect msrc + then let ed = Env.get_effect_decl cfg.core_cfg.tcenv (Env.norm_eff_name cfg.core_cfg.tcenv mtgt) in + let ret = match (SS.compress (ed |> U.get_return_repr |> BU.must |> snd)).n with + | Tm_uinst (ret, [_]) -> S.mk (Tm_uinst (ret, [U_unknown])) e.pos + | _ -> failwith "NYI: Reification of indexed effect (NBE)" + in + let cfg' = reifying_false cfg in + let t = + iapp cfg' (iapp cfg' (translate cfg' [] ret) + [mk_t <| Univ U_unknown, None]) + [(translate cfg' bs ty, None); //translating the type of the returned term + (translate cfg' bs e, None)] //translating the returned term itself + in + debug cfg (fun () -> BU.print1 "translate_monadic_lift(1): %s\n" (t_to_string t)); + t + else + match Env.monad_leq cfg.core_cfg.tcenv msrc mtgt with + | None -> + failwith (BU.format2 "Impossible : trying to reify a lift between unrelated effects (%s and %s)" + (Ident.string_of_lid msrc) + (Ident.string_of_lid mtgt)) + | Some {mlift={mlift_term=None}} -> + failwith (BU.format2 "Impossible : trying to reify a non-reifiable lift (from %s to %s)" + (Ident.string_of_lid msrc) + (Ident.string_of_lid mtgt)) + + | Some {mlift={mlift_term=Some lift}} -> + (* We don't have any reasonable wp to provide so we just pass unknown *) + (* The wp is only necessary to typecheck, so this should not create an issue. *) + let lift_lam = + let x = S.new_bv None S.tun in + U.abs [S.mk_binder x] + (lift U_unknown ty (S.bv_to_name x)) + None + in + let cfg' = reifying_false cfg in + let t = + iapp cfg (translate cfg' [] lift_lam) + [(translate cfg bs e, None)] + in + debug cfg (fun () -> BU.print1 "translate_monadic_lift(2): %s\n" (t_to_string t)); + t + +/// `readback` is the other half of the main normalization routine +/// +/// Give a translated term `x:t` we read it back as a syntactic term. +/// +/// The cases where `x:t` is a fully reduced value of base type are +/// easy: We read each host language constant back as a syntactic +/// constant +/// +/// The main work is when we read back terms with binders, e.g., +/// lambdas, unreduced matches, etc. +/// +/// In each of these cases, readback descends under the binder, and +/// recursively normalizes the term (i.e., translates and reads back) +/// in an extended context with a fresh name in scope. +and readback (cfg:config) (x:t) : term = + let debug = debug cfg in + let readback_args cfg args = + map_rev (fun (x, q) -> (readback cfg x, q)) args + in + let with_range t = { t with pos = x.nbe_r } in + let mk t = S.mk t x.nbe_r in + debug (fun () -> BU.print1 "Readback: %s\n" (t_to_string x)); + match x.nbe_t with + | Univ u -> failwith "Readback of universes should not occur" + + | Unknown -> S.mk Tm_unknown x.nbe_r + + | Constant Unit -> with_range S.unit_const + | Constant (Bool true) -> with_range U.exp_true_bool + | Constant (Bool false) -> with_range U.exp_false_bool + | Constant (Int i) -> with_range (U.exp_int (Z.string_of_big_int i)) + | Constant (String (s, r)) -> mk (S.Tm_constant (C.Const_string (s, r))) + | Constant (Char c) -> with_range (U.exp_char c) + | Constant (Range r) -> PO.embed_simple #_ #EMB.e___range x.nbe_r r + | Constant (Real r) -> PO.embed_simple x.nbe_r (Compiler.Real.Real r) + | Constant (SConst c) -> mk (S.Tm_constant c) + + | Meta(t, m) -> + mk (S.Tm_meta {tm=readback cfg t; meta=Thunk.force m}) + + | Type_t u -> + mk (Tm_type u) + + | Lam {interp=f; shape; arity} -> + begin match shape with + | Lam_bs (ctx, binders, rc) -> + let ctx, binders_rev, accus_rev = + List.fold_left + (fun (ctx, binders_rev, accus_rev) b -> + let x = b.binder_bv in + let tnorm = readback cfg (translate cfg ctx x.sort) in + let x = { S.freshen_bv x with sort = tnorm } in + let ax = mkAccuVar x in + let ctx = ax :: ctx in + ctx, ({b with binder_bv=x})::binders_rev, (ax, U.aqual_of_binder b)::accus_rev) + (ctx, [], []) + binders + in + let rc = + match rc with + | None -> None + | Some rc -> + Some (readback_residual_comp cfg (translate_residual_comp cfg ctx rc)) + in + let binders = List.rev binders_rev in + let body = readback cfg (f accus_rev) in + with_range (U.abs binders body rc) + + | Lam_args args -> + let binders, accus_rev = + List.fold_right + (fun (t, aq) (binders, accus) -> + let bqual, battrs = U.bqual_and_attrs_of_aqual aq in + let pqual, battrs = U.parse_positivity_attributes battrs in + let x = S.new_bv None (readback cfg t) in + (S.mk_binder_with_attrs x bqual pqual battrs)::binders, + (mkAccuVar x, aq) :: accus) + args + ([], []) + in + let accus = List.rev accus_rev in + let rc = None in + let body = readback cfg (f accus_rev) in + with_range (U.abs binders body rc) + + | Lam_primop (fv, args) -> + let body = U.mk_app (S.mk (Tm_fvar fv) (S.range_of_fv fv)) (readback_args cfg args) in + with_range body + end + + | Refinement (f, targ) -> + if cfg.core_cfg.steps.for_extraction + then readback cfg (fst (targ ())) + else + let x = S.new_bv None (readback cfg (fst (targ ()))) in + let body = readback cfg (f (mkAccuVar x)) in + let refinement = U.refine x body in + with_range ( + if cfg.core_cfg.steps.simplify + then TEQ.simplify cfg.core_cfg.debug.wpe cfg.core_cfg.tcenv refinement + else refinement + ) + + | Reflect t -> + let tm = readback cfg t in + with_range (U.mk_reflect tm) + + | Arrow (Inl f) -> + with_range (Thunk.force f) + + | Arrow (Inr (args, c)) -> + let binders = + List.map + (fun (t, q) -> + let t = readback cfg t in + let x = S.new_bv None t in + let q, attrs = U.bqual_and_attrs_of_aqual q in + let pqual, attrs = U.parse_positivity_attributes attrs in + S.mk_binder_with_attrs x q pqual attrs) + args + in + let c = readback_comp cfg c in + with_range (U.arrow binders c) + + | Construct (fv, us, args) -> + let args = map_rev (fun (x, q) -> (readback cfg x, q)) args in + let fv = S.mk (Tm_fvar fv) (S.range_of_fv fv) in + let app = U.mk_app (S.mk_Tm_uinst fv (List.rev us)) args in + with_range (app) + + | FV (fv, us, args) -> + let args = map_rev (fun (x, q) -> (readback cfg x, q)) args in + let fv = S.mk (Tm_fvar fv) Range.dummyRange in + let app = U.mk_app (S.mk_Tm_uinst fv (List.rev us)) args in + with_range ( + if cfg.core_cfg.steps.simplify + then TEQ.simplify cfg.core_cfg.debug.wpe cfg.core_cfg.tcenv app + else app + ) + + | Accu (Var bv, []) -> + with_range (S.bv_to_name bv) + + | Accu (Var bv, args) -> + let args = readback_args cfg args in + let app = U.mk_app (S.bv_to_name bv) args in + with_range ( + if cfg.core_cfg.steps.simplify + then TEQ.simplify cfg.core_cfg.debug.wpe cfg.core_cfg.tcenv app + else app + ) + + | Accu (Match (scrut, make_returns, make_branches, make_rc), args) -> + let args = readback_args cfg args in + let head = + let scrut_new = readback cfg scrut in + let returns_new = make_returns () in + let branches_new = make_branches () in + let rc_new = make_rc () in + S.mk (Tm_match {scrutinee=scrut_new; + ret_opt=returns_new; + brs=branches_new; + rc_opt=rc_new}) scrut.nbe_r + in + (* When `cases scrut` returns a Accu(Match ..)) + we need to reconstruct a source match node. + + To do this, we need to decorate that Match node with the + patterns in each branch. + + e.g., Consider this source node: + + (match x with + | Inl (a:ta) -> e1eenv + | Inr (b:tb) -> e2) + + Match([[x]], + (cases: t -> t), + (patterns:[Inl (a:ta); Inr (b:tb)])) + + let branches = + map (fun v -> v, readback (cases (translate v))) + patterns + in + match (readback [[x]]) + branches + *) + let app = U.mk_app head args in + with_range ( + if cfg.core_cfg.steps.simplify + then TEQ.simplify cfg.core_cfg.debug.wpe cfg.core_cfg.tcenv app + else app + ) + + | Accu(UnreducedLet (var, typ, defn, body, lb), args) -> + let typ = readback cfg (Thunk.force typ) in + let defn = readback cfg (Thunk.force defn) in + let body = SS.close [S.mk_binder var] (readback cfg (Thunk.force body)) in + let lbname = Inl ({ BU.left lb.lbname with sort = typ }) in + let lb = { lb with lbname = lbname; lbtyp = typ; lbdef = defn } in + let hd = S.mk (Tm_let {lbs=(false, [lb]); body}) Range.dummyRange in + let args = readback_args cfg args in + with_range (U.mk_app hd args) + + | Accu(UnreducedLetRec (vars_typs_defns, body, lbs), args) -> + let lbs = + List.map2 + (fun (v,t,d) lb -> + let t = readback cfg t in + let def = readback cfg d in + let v = {v with sort = t} in + {lb with lbname = Inl v; + lbtyp = t; + lbdef = def}) + vars_typs_defns + lbs + in + let body = readback cfg body in + let lbs, body = SS.close_let_rec lbs body in + let hd = S.mk (Tm_let {lbs=(true, lbs); body}) Range.dummyRange in + let args = readback_args cfg args in + with_range (U.mk_app hd args) + + | Accu(UVar f, args) -> + let hd = Thunk.force f in + let args = readback_args cfg args in + with_range (U.mk_app hd args) + + | TopLevelLet(lb, arity, args_rev) -> + let n_univs = List.length lb.lbunivs in + let n_args = List.length args_rev in + let args_rev, univs = BU.first_N (n_args - n_univs) args_rev in + readback cfg (iapp cfg (translate cfg (List.map fst univs) lb.lbdef) (List.rev args_rev)) + + | TopLevelRec(lb, _, _, args) -> + let fv = BU.right lb.lbname in + let head = S.mk (Tm_fvar fv) Range.dummyRange in + let args = List.map (fun (t, q) -> readback cfg t, q) args in + with_range (U.mk_app head args) + + | LocalLetRec(i, _, lbs, bs, args, _ar, _ar_lst) -> + (* if this point is reached then the local let rec is unreduced + and we have to read it back as a let rec. + + The idea is to read it back as a ` + ``` + (let rec f0 = e0 + and ... fn = en + in fi) args + ``` + where `e0 ... en` are the normalized bodies of + each arm of the mutually recursive nest, reduced in + context where all the mutually recursive definitions + are just fresh symbolic variables + (so, reducing the e_i will not trigger further + recursive reductions of th f0..fn) + *) + //1. generate fresh symbolic names for the let recs + let lbnames = + List.map (fun lb -> S.gen_bv (Ident.string_of_id (BU.left lb.lbname).ppname) None lb.lbtyp) lbs + in + //2. these names are in scope for all the bodies + // together with whatever other names (bs) that + // are in scope at this point + let let_rec_env = + List.rev_append (List.map (fun x -> mk_rt (S.range_of_bv x) (Accu (Var x, []))) lbnames) bs + in + //3. Reduce each e_i, both its definition (in the rec env) + // and its type, which doesn't have the recursive names in scope + let lbs = + List.map2 + (fun lb lbname -> + let lbdef = readback cfg (translate cfg let_rec_env lb.lbdef) in + let lbtyp = readback cfg (translate cfg bs lb.lbtyp) in + {lb with + lbname = Inl lbname; + lbdef = lbdef; + lbtyp = lbtyp}) + lbs + lbnames + in + //4. Set the body of let rec ... in ... + // to be the name chosen for the ith let rec, the one + // referred to in the LocalLetRec + let body = S.bv_to_name (List.nth lbnames i) in + //5. close everything to switch back to locally nameless + let lbs, body = FStarC.Syntax.Subst.close_let_rec lbs body in + //6. Build the head term + let head = S.mk (Tm_let {lbs=(true, lbs); body}) Range.dummyRange in + //7. Readback the arguments and apply it to the head + let args = List.map (fun (x, q) -> readback cfg x, q) args in + with_range (U.mk_app head args) + + | Quote (qt, qi) -> + mk (Tm_quoted (qt, qi)) + + // Need this case for "cheat" embeddings + | Lazy (Inl li, _) -> + mk (Tm_lazy li) + + | Lazy (_, thunk) -> + readback cfg (Thunk.force thunk) + +let reduce_application cfg t args = + iapp (new_config cfg) t args + +let normalize psteps (steps:list Env.step) + (env : Env.env) (e:term) : term = + let cfg = Cfg.config' psteps steps env in + //debug_sigmap env.sigtab; + let cfg = {cfg with steps={cfg.steps with reify_=true}} in + if !dbg_NBETop || !dbg_NBE + then BU.print1 "Calling NBE with (%s) {\n" (show e); + let cfg = new_config cfg in + let r = readback cfg (translate cfg [] e) in + if !dbg_NBETop || !dbg_NBE + then BU.print1 "}\nNBE returned (%s)\n" (show r); + r + +(* ONLY FOR UNIT TESTS! *) +let normalize_for_unit_test (steps:list Env.step) (env : Env.env) (e:term) : term = + let cfg = Cfg.config steps env in + //debug_sigmap env.sigtab; + let cfg = {cfg with steps={cfg.steps with reify_=true}} in + let cfg = new_config cfg in + debug cfg (fun () -> BU.print1 "Calling NBE with (%s) {\n" (show e)); + let r = readback cfg (translate cfg [] e) in + debug cfg (fun () -> BU.print1 "}\nNBE returned (%s)\n" (show r)); + r diff --git a/src/typechecker/FStarC.TypeChecker.NBE.fsti b/src/typechecker/FStarC.TypeChecker.NBE.fsti new file mode 100644 index 00000000000..9178f6df60b --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.NBE.fsti @@ -0,0 +1,42 @@ +(* + Copyright 2017-2019 Microsoft Research + + Authors: Zoe Paraskevopoulou, Guido Martinez, Nikhil Swamy + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.TypeChecker.NBE +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStar open FStarC +open FStarC.Compiler +open FStarC.TypeChecker +open FStarC.TypeChecker.Env +open FStarC.Syntax.Syntax +open FStarC.Ident +open FStarC.Errors +open FStarC.TypeChecker.Normalize +open FStarC.TypeChecker.NBETerm +module Cfg = FStarC.TypeChecker.Cfg +module PO = FStarC.TypeChecker.Primops + +val normalize_for_unit_test : steps:list Env.step + -> env : Env.env + -> e:term + -> term + +val normalize : list PO.primitive_step + -> list Env.step + -> Env.env + -> term + -> term diff --git a/src/typechecker/FStarC.TypeChecker.NBETerm.fst b/src/typechecker/FStarC.TypeChecker.NBETerm.fst new file mode 100644 index 00000000000..f4a23cd5402 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.NBETerm.fst @@ -0,0 +1,938 @@ +(* + Copyright 2017-2019 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.TypeChecker.NBETerm +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Syntax.Syntax +open FStarC.Errors +open FStar.Char +open FStar.String + +friend FStar.Pervasives (* To expose norm_step *) + +module PC = FStarC.Parser.Const +module S = FStarC.Syntax.Syntax +module P = FStarC.Syntax.Print +module BU = FStarC.Compiler.Util +module C = FStarC.Const +module SE = FStarC.Syntax.Embeddings +module TEQ = FStarC.TypeChecker.TermEqAndSimplify + +open FStarC.VConfig + +open FStarC.Class.Show + +// NBE term manipulation + +(**** NOTE: Don't say I didn't warn you! ***) +(* FV and Construct accumulate arguments *in reverse order*. + * Therefore the embeddings must be aware of this and match/construct + * them properly + * + * For example, this is how we embed/unembed an `option a`: + * + embed: + match o with + | Some x -> + lid_as_constr PC.some_lid [U_zero] [as_arg (embed ea cb x); as_iarg (type_of ea)] + + unembed: + match t with + | Construct (fvar, us, [(a, _); _]) when S.fv_eq_lid fvar PC.some_lid + BU.bind_opt (unembed ea cb a) (fun a -> Some (Some a)) + * + * Note how the implicit argument is seemingly *after* the explicit one. + *) +let interleave_hack = 123 + +let isAccu (trm:t) = +match trm.nbe_t with +| Accu _ -> true +| _ -> false + +let isNotAccu (x:t) = +match x.nbe_t with +| Accu (_, _) -> false +| _ -> true + +let mk_rt r t = { nbe_t = t; nbe_r = r } +let mk_t t = mk_rt Range.dummyRange t +let nbe_t_of_t t = t.nbe_t +let mkConstruct i us ts = mk_t <| Construct(i, us, ts) +let mkFV i us ts = mk_rt (S.range_of_fv i) (FV(i, us, ts)) + +let mkAccuVar (v:var) = mk_rt (S.range_of_bv v) (Accu(Var v, [])) +let mkAccuMatch (s:t) (ret:(unit -> option match_returns_ascription)) (bs:(unit -> list branch)) + (rc:unit -> option S.residual_comp) = + mk_t <| Accu(Match (s, ret, bs, rc), []) + +// Term equality + +let equal_if = function + | true -> TEQ.Equal + | _ -> TEQ.Unknown + +let equal_iff = function + | true -> TEQ.Equal + | _ -> TEQ.NotEqual + +let eq_inj r1 r2 = + match r1, r2 with + | TEQ.Equal, TEQ.Equal -> TEQ.Equal + | TEQ.NotEqual, _ + | _, TEQ.NotEqual -> TEQ.NotEqual + | TEQ.Unknown, _ + | _, TEQ.Unknown -> TEQ.Unknown + +let eq_and f g = + match f with + | TEQ.Equal -> g() + | _ -> TEQ.Unknown + +let eq_constant (c1 : constant) (c2 : constant) = +match c1, c2 with +| Unit, Unit -> TEQ.Equal +| Bool b1, Bool b2 -> equal_iff (b1 = b2) +| Int i1, Int i2 -> equal_iff (i1 = i2) +| String (s1, _), String (s2, _) -> equal_iff (s1 = s2) +| Char c1, Char c2 -> equal_iff (c1 = c2) +| Range r1, Range r2 -> TEQ.Unknown (* Seems that ranges are opaque *) +| Real r1, Real r2 -> equal_if (r1 = r2) (* conservative, cannot use iff since strings could be 1.0 and 01.0 *) +| _, _ -> TEQ.NotEqual + + +let rec eq_t env (t1 : t) (t2 : t) : TEQ.eq_result = + match t1.nbe_t, t2.nbe_t with + | Lam _, Lam _ -> TEQ.Unknown + | Accu(a1, as1), Accu(a2, as2) -> eq_and (eq_atom a1 a2) (fun () -> eq_args env as1 as2) + | Construct(v1, us1, args1), Construct(v2, us2, args2) -> + if S.fv_eq v1 v2 then begin + if List.length args1 <> List.length args2 then + failwith "eq_t, different number of args on Construct"; + match Env.num_datacon_non_injective_ty_params env (lid_of_fv v1) with + | None -> TEQ.Unknown + | Some n -> + if n <= List.length args1 + then ( + let eq_args as1 as2 = + List.fold_left2 + (fun acc (a1, _) (a2, _) -> eq_inj acc (eq_t env a1 a2)) + TEQ.Equal + as1 as2 + in + let parms1, args1 = List.splitAt n args1 in + let parms2, args2 = List.splitAt n args2 in + eq_args args1 args2 + ) + else TEQ.Unknown + end else TEQ.NotEqual + + | FV(v1, us1, args1), FV(v2, us2, args2) -> + if S.fv_eq v1 v2 then + eq_and (equal_iff (U.eq_univs_list us1 us2)) (fun () -> eq_args env args1 args2) + else TEQ.Unknown + + | Constant c1, Constant c2 -> eq_constant c1 c2 + | Type_t u1, Type_t u2 + | Univ u1, Univ u2 -> equal_iff (U.eq_univs u1 u2) + | Refinement(r1, t1), Refinement(r2, t2) -> + let x = S.new_bv None S.t_unit in (* bogus type *) + eq_and (eq_t env (fst (t1 ())) (fst (t2 ()))) (fun () -> eq_t env (r1 (mkAccuVar x)) (r2 (mkAccuVar x))) + | Unknown, Unknown -> TEQ.Equal + | _, _ -> TEQ.Unknown (* XXX following eq_tm *) + +and eq_atom (a1 : atom) (a2 : atom) : TEQ.eq_result = + match a1, a2 with + | Var bv1, Var bv2 -> equal_if (bv_eq bv1 bv2) (* ZP : TODO if or iff?? *) + | _, _ -> TEQ.Unknown (* XXX Cannot compare suspended matches (?) *) + +and eq_arg env (a1 : arg) (a2 : arg) = eq_t env (fst a1) (fst a2) +and eq_args env (as1 : args) (as2 : args) : TEQ.eq_result = + match as1, as2 with + | [], [] -> TEQ.Equal + | x :: xs, y :: ys -> eq_and (eq_arg env x y) (fun () -> eq_args env xs ys) + | _, _ -> TEQ.Unknown (* ZP: following tm_eq, but why not TEQ.NotEqual? *) + + +// Printing functions + +let constant_to_string (c: constant) = + match c with + | Unit -> "Unit" + | Bool b -> if b then "Bool true" else "Bool false" + | Int i -> Z.string_of_big_int i + | Char c -> BU.format1 "'%s'" (BU.string_of_char c) + | String (s, _) -> BU.format1 "\"%s\"" s + | Range r -> BU.format1 "Range %s" (Range.string_of_range r) + | SConst s -> show s + | Real s -> BU.format1 "Real %s" s + +let rec t_to_string (x:t) = + match x.nbe_t with + | Lam {interp=b; arity} -> BU.format1 "Lam (_, %s args)" (BU.string_of_int arity) + | Accu (a, l) -> + "Accu (" ^ (atom_to_string a) ^ ") (" ^ + (String.concat "; " (List.map (fun x -> t_to_string (fst x)) l)) ^ ")" + | Construct (fv, us, l) -> + "Construct (" ^ (show fv) ^ ") [" ^ + (String.concat "; "(List.map show us)) ^ "] [" ^ + (String.concat "; " (List.map (fun x -> t_to_string (fst x)) l)) ^ "]" + | FV (fv, us, l) -> + "FV (" ^ (show fv) ^ ") [" ^ + (String.concat "; "(List.map show us)) ^ "] [" ^ + (String.concat "; " (List.map (fun x -> t_to_string (fst x)) l)) ^ "]" + | Constant c -> constant_to_string c + | Univ u -> "Universe " ^ (show u) + | Type_t u -> "Type_t " ^ (show u) + | Arrow _ -> "Arrow" // TODO : revisit + | Refinement (f, t) -> + let x = S.new_bv None S.t_unit in (* bogus type *) + let t = fst (t ()) in + "Refinement " ^ (show x) ^ ":" ^ (t_to_string t) ^ "{" ^ (t_to_string (f (mkAccuVar x))) ^ "}" + | Unknown -> "Unknown" + | Reflect t -> "Reflect " ^ t_to_string t + | Quote _ -> "Quote _" + | Lazy (Inl li, _) -> BU.format1 "Lazy (Inl {%s})" (show (U.unfold_lazy li)) + | Lazy (Inr (_, et), _) -> BU.format1 "Lazy (Inr (?, %s))" (show et) + | LocalLetRec (_, l, _, _, _, _, _) -> "LocalLetRec (" ^ (show (true, [l])) ^ ")" + | TopLevelLet (lb, _, _) -> "TopLevelLet (" ^ show (BU.right lb.lbname) ^ ")" + | TopLevelRec (lb, _, _, _) -> "TopLevelRec (" ^ show (BU.right lb.lbname) ^ ")" + | Meta (t, _) -> "Meta " ^ t_to_string t +and atom_to_string (a: atom) = + match a with + | Var v -> "Var " ^ (show v) + | Match (t, _, _, _) -> "Match " ^ (t_to_string t) + | UnreducedLet (var, typ, def, body, lb) -> "UnreducedLet(" ^ (show (false, [lb])) ^ " in ...)" + | UnreducedLetRec (_, body, lbs) -> "UnreducedLetRec(" ^ (show (true, lbs)) ^ " in " ^ (t_to_string body) ^ ")" + | UVar _ -> "UVar" + +let arg_to_string (a : arg) = a |> fst |> t_to_string + +let args_to_string args = args |> List.map arg_to_string |> String.concat " " + +instance showable_t = { + show = t_to_string; +} +instance showable_args = { + show = args_to_string; +} + +// Embedding and de-embedding + +let iapp_cb cbs h a = cbs.iapp h a +let translate_cb cbs t = cbs.translate t + +let embed (#a:Type0) (e:embedding a) (cb:nbe_cbs) (x:a) : t = e.em cb x +let unembed (#a:Type0) (e:embedding a) (cb:nbe_cbs) (trm:t) : option a = e.un cb trm + +let type_of (e:embedding 'a) : t = e.typ () +let set_type (ty:t) (e:embedding 'a) : embedding 'a = { e with typ = (fun () -> ty) } + + +let mk_emb em un typ et = {em = em; un = un; typ = typ; e_typ=et} +let mk_emb' em un = mk_emb (fun cbs t -> mk_t <| em cbs t) (fun cbs t -> un cbs t.nbe_t) + + +let embed_as (ea:embedding 'a) + (ab : 'a -> 'b) + (ba : 'b -> 'a) + (ot:option t) + : embedding 'b + = mk_emb (fun cbs (x:'b) -> embed ea cbs (ba x)) + (fun cbs t -> BU.map_opt (unembed ea cbs t) ab) + (fun () -> match ot with | Some t -> t | None -> ea.typ ()) + ea.e_typ + +let lid_as_constr (l:lident) (us:list universe) (args:args) : t = + mkConstruct (lid_as_fv l (Some Data_ctor)) us args + +let lid_as_typ (l:lident) (us:list universe) (args:args) : t = + mkFV (lid_as_fv l None) us args + +let as_iarg (a:t) : arg = (a, S.as_aqual_implicit true) +let as_arg (a:t) : arg = (a, None) + +// Non-dependent total arrow +let make_arrow1 t1 (a:arg) : t = mk_t <| Arrow (Inr ([a], Tot t1)) + +let lazy_embed (et:unit -> emb_typ) (x:'a) (f:unit -> t) = + if !Options.debug_embedding + then BU.print1 "Embedding\n\temb_typ=%s\n" + (show (et ())); + if !Options.eager_embedding + then f() + else let thunk = Thunk.mk f in + let li = FStarC.Dyn.mkdyn x, et () in + mk_t <| Lazy (Inr li, thunk) + +let lazy_unembed (et:unit -> emb_typ) (x:t) (f:t -> option 'a) : option 'a = + match x.nbe_t with + | Lazy (Inl li, thunk) -> + f (Thunk.force thunk) + + | Lazy (Inr (b, et'), thunk) -> + if et () <> et' + || !Options.eager_embedding + then let res = f (Thunk.force thunk) in + let _ = if !Options.debug_embedding + then BU.print2 "Unembed cancellation failed\n\t%s <> %s\n" + (show (et ())) + (show et') + in + res + else let a = FStarC.Dyn.undyn b in + let _ = if !Options.debug_embedding + then BU.print1 "Unembed cancelled for %s\n" + (show (et ())) + in + Some a + | _ -> + let aopt = f x in + let _ = if !Options.debug_embedding + then BU.print1 "Unembedding:\n\temb_typ=%s\n" + (show (et ())) in + aopt + +let lazy_unembed_lazy_kind (#a:Type) (k:lazy_kind) (x:t) : option a = + match x.nbe_t with + | Lazy (Inl li, _) -> + if li.lkind = k + then Some (FStarC.Dyn.undyn li.blob) + else None + | _ -> None + +// Emdebbing for polymorphic types +let mk_any_emb (ty:t) : embedding t = + let em = (fun _cb a -> a) in + let un = (fun _cb t -> Some t) in + mk_emb em un (fun () -> ty) (fun () -> ET_abstract) + +// Emdebbing at abstract types +let e_any : embedding t = + let em = (fun _cb a -> a) in + let un = (fun _cb t -> Some t) in + mk_emb em un (fun () -> lid_as_typ PC.term_lid [] []) (fun () -> ET_abstract) + +// Emdebbing at type unit +let e_unit : embedding unit = + let em _cb a = Constant Unit in + let un _cb t = Some () in // No runtime typecheck here + mk_emb' em un (fun () -> lid_as_typ PC.unit_lid [] []) (SE.emb_typ_of unit) + +// Embedding at type bool +let e_bool : embedding bool = + let em _cb a = Constant (Bool a) in + let un _cb t = + match t with + | Constant (Bool a) -> Some a + | _ -> None + in + mk_emb' em un (fun () -> lid_as_typ PC.bool_lid [] []) (SE.emb_typ_of bool) + +// Embeddind at type char +let e_char : embedding char = + let em _cb c = Constant (Char c) in + let un _cb c = + match c with + | Constant (Char a) -> Some a + | _ -> None + in + mk_emb' em un (fun () -> lid_as_typ PC.char_lid [] []) (SE.emb_typ_of char) + +// Embeddind at type string +let e_string : embedding string = + let em _cb s = Constant (String (s, Range.dummyRange)) in + let un _cb s = + match s with + | Constant (String (s, _)) -> Some s + | _ -> None + in + mk_emb' em un (fun () -> lid_as_typ PC.string_lid [] []) (SE.emb_typ_of string) + +// Embeddind at type int +let e_int : embedding Z.t = + let em _cb c = Constant (Int c) in + let un _cb c = + match c with + | Constant (Int a) -> Some a + | _ -> None + in + mk_emb' em un (fun () -> lid_as_typ PC.int_lid [] []) (SE.emb_typ_of int) + +let e_real : embedding Compiler.Real.real = + let em _cb (Compiler.Real.Real c) = Constant (Real c) in + let un _cb c = + match c with + | Constant (Real a) -> Some (Compiler.Real.Real a) + | _ -> None + in + mk_emb' em un (fun () -> lid_as_typ PC.real_lid [] []) (SE.emb_typ_of Compiler.Real.real) + +let e_fsint = embed_as e_int Z.to_int_fs Z.of_int_fs None + +// Embedding at option type +let e_option (ea : embedding 'a) : Prims.Tot _ = + let etyp () = + ET_app(PC.option_lid |> Ident.string_of_lid, [ea.e_typ ()]) + in + let em cb (o:option 'a) : t = + lazy_embed etyp o (fun () -> + match o with + | None -> + lid_as_constr PC.none_lid [U_zero] [as_iarg (type_of ea)] + | Some x -> + lid_as_constr PC.some_lid [U_zero] [as_arg (embed ea cb x); + as_iarg (type_of ea)]) + in + let un cb (trm:t) : option (option 'a) = + lazy_unembed etyp trm (fun trm -> + match trm.nbe_t with + | Construct (fvar, us, args) when S.fv_eq_lid fvar PC.none_lid -> + Some None + | Construct (fvar, us, [(a, _); _]) when S.fv_eq_lid fvar PC.some_lid -> + BU.bind_opt (unembed ea cb a) (fun a -> Some (Some a)) + | _ -> None) + in + mk_emb em un (fun () -> lid_as_typ PC.option_lid [U_zero] [as_arg (type_of ea)]) etyp + + +// Emdedding tuples +let e_tuple2 (ea:embedding 'a) (eb:embedding 'b) = + let etyp () = + ET_app(PC.lid_tuple2 |> Ident.string_of_lid, [ea.e_typ (); eb.e_typ ()]) + in + let em cb (x:'a & 'b) : t = + lazy_embed etyp x (fun () -> + lid_as_constr (PC.lid_Mktuple2) + [U_zero; U_zero] + [as_arg (embed eb cb (snd x)); + as_arg (embed ea cb (fst x)); + as_iarg (type_of eb); + as_iarg (type_of ea)]) + in + let un cb (trm:t) : option ('a & 'b) = + lazy_unembed etyp trm (fun trm -> + match trm.nbe_t with + | Construct (fvar, us, [(b, _); (a, _); _; _]) when S.fv_eq_lid fvar PC.lid_Mktuple2 -> + let open FStarC.Class.Monad in + let! a = unembed ea cb a in + let! b = unembed eb cb b in + Some (a, b) + | _ -> None) + in + mk_emb em un + (fun () -> lid_as_typ PC.lid_tuple2 [U_zero;U_zero] [as_arg (type_of eb); as_arg (type_of ea)]) + etyp + +let e_tuple3 (ea:embedding 'a) (eb:embedding 'b) (ec:embedding 'c) = + let etyp () = + ET_app(PC.lid_tuple3 |> Ident.string_of_lid, [ea.e_typ (); eb.e_typ (); ec.e_typ ()]) + in + let em cb ((x1, x2, x3):('a & 'b & 'c)) : t = + lazy_embed etyp (x1, x2, x3) (fun () -> + lid_as_constr (PC.lid_Mktuple3) + [U_zero; U_zero; U_zero] + [as_arg (embed ec cb x3); + as_arg (embed eb cb x2); + as_arg (embed ea cb x1); + as_iarg (type_of ec); + as_iarg (type_of eb); + as_iarg (type_of ea)]) + in + let un cb (trm:t) : option ('a & 'b & 'c) = + lazy_unembed etyp trm (fun trm -> + match trm.nbe_t with + | Construct (fvar, us, [(c, _); (b, _); (a, _); _; _; _]) when S.fv_eq_lid fvar PC.lid_Mktuple3 -> + let open FStarC.Class.Monad in + let! a = unembed ea cb a in + let! b = unembed eb cb b in + let! c = unembed ec cb c in + Some (a, b, c) + | _ -> None) + in + mk_emb em un (fun () -> lid_as_typ PC.lid_tuple3 [U_zero;U_zero;U_zero] [as_arg (type_of ec); as_arg (type_of eb); as_arg (type_of ea)]) etyp + +let e_tuple4 (ea:embedding 'a) (eb:embedding 'b) (ec:embedding 'c) (ed:embedding 'd) = + let etyp () = + ET_app(PC.lid_tuple4 |> Ident.string_of_lid, [ea.e_typ (); eb.e_typ (); ec.e_typ (); ed.e_typ ()]) + in + let em cb (x1, x2, x3, x4) : t = + lazy_embed etyp (x1, x2, x3, x4) (fun () -> + lid_as_constr (PC.lid_Mktuple4) + [U_zero; U_zero; U_zero; U_zero] + [as_arg (embed ed cb x4); + as_arg (embed ec cb x3); + as_arg (embed eb cb x2); + as_arg (embed ea cb x1); + as_iarg (type_of ed); + as_iarg (type_of ec); + as_iarg (type_of eb); + as_iarg (type_of ea)]) + in + let un cb (trm:t) : option ('a & 'b & 'c & 'd) = + lazy_unembed etyp trm (fun trm -> + match trm.nbe_t with + | Construct (fvar, us, [(d, _); (c, _); (b, _); (a, _); _; _; _; _]) when S.fv_eq_lid fvar PC.lid_Mktuple4 -> + let open FStarC.Class.Monad in + let! a = unembed ea cb a in + let! b = unembed eb cb b in + let! c = unembed ec cb c in + let! d = unembed ed cb d in + Some (a, b, c, d) + | _ -> None) + in + mk_emb em un (fun () -> lid_as_typ PC.lid_tuple4 [U_zero;U_zero;U_zero;U_zero] [as_arg (type_of ed); as_arg (type_of ec); as_arg (type_of eb); as_arg (type_of ea)]) etyp + +let e_tuple5 (ea:embedding 'a) (eb:embedding 'b) (ec:embedding 'c) (ed:embedding 'd) (ee:embedding 'e) = + let etyp () = + ET_app(PC.lid_tuple5 |> Ident.string_of_lid, [ea.e_typ (); eb.e_typ (); ec.e_typ (); ed.e_typ (); ee.e_typ ()]) + in + let em cb (x1, x2, x3, x4, x5) : t = + lazy_embed etyp (x1, x2, x3, x4, x5) (fun () -> + lid_as_constr (PC.lid_Mktuple5) + [U_zero; U_zero; U_zero; U_zero;U_zero] + [as_arg (embed ee cb x5); + as_arg (embed ed cb x4); + as_arg (embed ec cb x3); + as_arg (embed eb cb x2); + as_arg (embed ea cb x1); + as_iarg (type_of ee); + as_iarg (type_of ed); + as_iarg (type_of ec); + as_iarg (type_of eb); + as_iarg (type_of ea)]) + in + let un cb (trm:t) : option ('a & 'b & 'c & 'd & 'e) = + lazy_unembed etyp trm (fun trm -> + match trm.nbe_t with + | Construct (fvar, us, [(e, _); (d, _); (c, _); (b, _); (a, _); _; _; _; _; _]) when S.fv_eq_lid fvar PC.lid_Mktuple5 -> + let open FStarC.Class.Monad in + let! a = unembed ea cb a in + let! b = unembed eb cb b in + let! c = unembed ec cb c in + let! d = unembed ed cb d in + let! e = unembed ee cb e in + Some (a, b, c, d, e) + | _ -> None) + in + mk_emb em un + (fun () -> lid_as_typ PC.lid_tuple5 [U_zero;U_zero;U_zero;U_zero;U_zero] [as_arg (type_of ee); as_arg (type_of ed); as_arg (type_of ec); as_arg (type_of eb); as_arg (type_of ea)]) + etyp + +let e_either (ea:embedding 'a) (eb:embedding 'b) = + let etyp () = + ET_app(PC.either_lid |> Ident.string_of_lid, [ea.e_typ (); eb.e_typ ()]) + in + let em cb (s:either 'a 'b) : t = + lazy_embed etyp s (fun () -> + match s with + | Inl a -> + lid_as_constr (PC.inl_lid) + [U_zero; U_zero] + [as_arg (embed ea cb a); + as_iarg (type_of eb); + as_iarg (type_of ea)] + | Inr b -> + lid_as_constr (PC.inr_lid) + [U_zero; U_zero] + [as_arg (embed eb cb b); + as_iarg (type_of eb); + as_iarg (type_of ea)]) + in + let un cb (trm:t) : option (either 'a 'b) = + lazy_unembed etyp trm (fun trm -> + match trm.nbe_t with + | Construct (fvar, us, [(a, _); _; _]) when S.fv_eq_lid fvar PC.inl_lid -> + BU.bind_opt (unembed ea cb a) (fun a -> + Some (Inl a)) + | Construct (fvar, us, [(b, _); _; _]) when S.fv_eq_lid fvar PC.inr_lid -> + BU.bind_opt (unembed eb cb b) (fun b -> + Some (Inr b)) + | _ -> None) + in + mk_emb em un (fun () -> lid_as_typ PC.either_lid [U_zero;U_zero] [as_arg (type_of eb); as_arg (type_of ea)]) etyp + +// Embedding range (unsealed) +let e___range : embedding Range.range = + let em cb r = Constant (Range r) in + let un cb t = + match t with + | Constant (Range r) -> Some r + | _ -> + None + in + mk_emb' em un (fun () -> lid_as_typ PC.__range_lid [] []) (SE.emb_typ_of Range.range) + +// Embedding a sealed term. This just calls the embedding for a but also +// adds a `seal` marker to the result. The unembedding removes it. +let e_sealed (ea : embedding 'a) : Prims.Tot (embedding (Sealed.sealed 'a)) = + let etyp () = + ET_app(PC.sealed_lid |> Ident.string_of_lid, [ea.e_typ ()]) + in + let em cb (x: Sealed.sealed 'a) : t = + lazy_embed etyp x (fun () -> + lid_as_constr PC.seal_lid [U_zero] [as_arg (embed ea cb (Sealed.unseal x)); + as_iarg (type_of ea)]) + in + let un cb (trm:t) : option (Sealed.sealed 'a) = + lazy_unembed etyp trm (fun trm -> + match trm.nbe_t with + | Construct (fvar, us, [(a, _); _]) when S.fv_eq_lid fvar PC.seal_lid -> + Class.Monad.fmap Sealed.seal <| unembed ea cb a + | _ -> None) + in + mk_emb em un (fun () -> lid_as_typ PC.sealed_lid [U_zero] [as_arg (type_of ea)]) etyp + +let e_range : embedding Range.range = + embed_as (e_sealed e___range) Sealed.unseal Sealed.seal None + +let e_issue : embedding FStarC.Errors.issue = + let t_issue = SE.type_of SE.e_issue in + let li blob rng = { blob=Dyn.mkdyn blob; lkind = Lazy_issue; ltyp = t_issue; rng } in + let em cb iss = Lazy (Inl (li iss Range.dummyRange), (Thunk.mk (fun _ -> failwith "Cannot unembed issue"))) in + let un cb t = + match t with + | Lazy (Inl { lkind=Lazy_issue; blob }, _) -> Some (Dyn.undyn blob) + | _ -> None + in + mk_emb' em un (fun () -> lid_as_typ PC.issue_lid [] []) (SE.emb_typ_of issue) + +let e_document : embedding FStarC.Pprint.document = + let t_document = SE.type_of SE.e_document in + let li blob rng = { blob=Dyn.mkdyn blob; lkind = Lazy_doc; ltyp = t_document; rng } in + let em cb doc = Lazy (Inl (li doc Range.dummyRange), (Thunk.mk (fun _ -> failwith "Cannot unembed document"))) in + let un cb t = + match t with + | Lazy (Inl { lkind=Lazy_doc; blob }, _) -> Some (Dyn.undyn blob) + | _ -> None + in + mk_emb' em un (fun () -> lid_as_typ PC.document_lid [] []) (SE.emb_typ_of Pprint.document) + +// vconfig, NYI +let e_vconfig : embedding vconfig = + let em cb r = failwith "e_vconfig NBE" in + let un cb t = failwith "e_vconfig NBE" in + mk_emb' em un (fun () -> lid_as_typ PC.vconfig_lid [] []) (SE.emb_typ_of vconfig) + +// Emdedding lists +let e_list (ea:embedding 'a) = + let etyp () = + ET_app(PC.list_lid |> Ident.string_of_lid, [ea.e_typ ()]) + in + let em cb (l:list 'a) : t = + lazy_embed etyp l (fun () -> + let typ = as_iarg (type_of ea) in + let nil = lid_as_constr PC.nil_lid [U_zero] [typ] in + let cons hd tl = lid_as_constr PC.cons_lid [U_zero] [as_arg tl; as_arg (embed ea cb hd); typ] in + List.fold_right cons l nil) + in + let rec un cb (trm:t) : option (list 'a) = + lazy_unembed etyp trm (fun trm -> + match trm.nbe_t with + | Construct (fv, _, _) when S.fv_eq_lid fv PC.nil_lid -> Some [] + | Construct (fv, _, [(tl, None); (hd, None); (_, Some ({ aqual_implicit = true }))]) + // Zoe: Not sure why this case is need; following Emdeddings.fs + // GM: Maybe it's not, but I'm unsure on whether we can rely on all these terms being type-correct + | Construct (fv, _, [(tl, None); (hd, None)]) + when S.fv_eq_lid fv PC.cons_lid -> + BU.bind_opt (unembed ea cb hd) (fun hd -> + BU.bind_opt (un cb tl) (fun tl -> + Some (hd :: tl))) + | _ -> None) + in + mk_emb em un (fun () -> lid_as_typ PC.list_lid [U_zero] [as_arg (type_of ea)]) etyp + +let e_string_list = e_list e_string + +let e_arrow (ea:embedding 'a) (eb:embedding 'b) : Prims.Tot (embedding ('a -> 'b)) = + let etyp () = ET_fun(ea.e_typ (), eb.e_typ ()) in + let em cb (f : 'a -> 'b) : t = + lazy_embed etyp f (fun () -> + mk_t <| Lam { + interp = (fun tas -> match unembed ea cb (tas |> List.hd |> fst) with + | Some a -> embed eb cb (f a) + | None -> failwith "cannot unembed function argument"); + shape = Lam_args [as_arg (type_of eb)]; + arity = 1; + }) + in + let un cb (lam : t) : option ('a -> 'b) = + let k (lam:t) : option ('a -> 'b) = + Some (fun (x:'a) -> match unembed eb cb (cb.iapp lam [as_arg (embed ea cb x)]) with + | Some y -> y + | None -> failwith "cannot unembed function result") + in + lazy_unembed etyp lam k + in + mk_emb em un (fun () -> make_arrow1 (type_of ea) (as_iarg (type_of eb))) etyp + +let e_abstract_nbe_term = + embed_as e_any (fun x -> AbstractNBE x) (fun x -> match x with AbstractNBE x -> x) None + +let e_unsupported #a : embedding a = + let em = (fun _cb a -> failwith "Unsupported NBE embedding") in + let un = (fun _cb t -> failwith "Unsupported NBE embedding") in + mk_emb em un (fun () -> lid_as_typ PC.term_lid [] []) (fun () -> ET_abstract) + +let e_norm_step = + let em cb (n:Pervasives.norm_step) : t = + match n with + | Pervasives.Simpl -> mkFV (lid_as_fv PC.steps_simpl None) [] [] + | Pervasives.Weak -> mkFV (lid_as_fv PC.steps_weak None) [] [] + | Pervasives.HNF -> mkFV (lid_as_fv PC.steps_hnf None) [] [] + | Pervasives.Primops -> mkFV (lid_as_fv PC.steps_primops None) [] [] + | Pervasives.Delta -> mkFV (lid_as_fv PC.steps_delta None) [] [] + | Pervasives.Zeta -> mkFV (lid_as_fv PC.steps_zeta None) [] [] + | Pervasives.Iota -> mkFV (lid_as_fv PC.steps_iota None) [] [] + | Pervasives.Reify -> mkFV (lid_as_fv PC.steps_reify None) [] [] + | Pervasives.NBE -> mkFV (lid_as_fv PC.steps_nbe None) [] [] + | Pervasives.UnfoldOnly l -> + mkFV (lid_as_fv PC.steps_unfoldonly None) + [] [as_arg (embed (e_list e_string) cb l)] + | Pervasives.UnfoldFully l -> + mkFV (lid_as_fv PC.steps_unfoldfully None) + [] [as_arg (embed (e_list e_string) cb l)] + | Pervasives.UnfoldAttr l -> + mkFV (lid_as_fv PC.steps_unfoldattr None) + [] [as_arg (embed (e_list e_string) cb l)] + | Pervasives.UnfoldQual l -> + mkFV (lid_as_fv PC.steps_unfoldqual None) + [] [as_arg (embed (e_list e_string) cb l)] + | Pervasives.UnfoldNamespace l -> + mkFV (lid_as_fv PC.steps_unfoldnamespace None) + [] [as_arg (embed (e_list e_string) cb l)] + | Pervasives.ZetaFull -> mkFV (lid_as_fv PC.steps_zeta_full None) [] [] + | Pervasives.Unascribe -> mkFV (lid_as_fv PC.steps_unascribe None) [] [] + in + let un cb (t0:t) : option Pervasives.norm_step = + match t0.nbe_t with + | FV (fv, _, []) when S.fv_eq_lid fv PC.steps_simpl -> + Some Pervasives.Simpl + | FV (fv, _, []) when S.fv_eq_lid fv PC.steps_weak -> + Some Pervasives.Weak + | FV (fv, _, []) when S.fv_eq_lid fv PC.steps_hnf -> + Some Pervasives.HNF + | FV (fv, _, []) when S.fv_eq_lid fv PC.steps_primops -> + Some Pervasives.Primops + | FV (fv, _, []) when S.fv_eq_lid fv PC.steps_delta -> + Some Pervasives.Delta + | FV (fv, _, []) when S.fv_eq_lid fv PC.steps_zeta -> + Some Pervasives.Zeta + | FV (fv, _, []) when S.fv_eq_lid fv PC.steps_iota -> + Some Pervasives.Iota + | FV (fv, _, []) when S.fv_eq_lid fv PC.steps_nbe -> + Some Pervasives.NBE + | FV (fv, _, []) when S.fv_eq_lid fv PC.steps_reify -> + Some Pervasives.Reify + | FV (fv, _, []) when S.fv_eq_lid fv PC.steps_zeta_full -> + Some Pervasives.ZetaFull + | FV (fv, _, []) when S.fv_eq_lid fv PC.steps_unascribe -> + Some Pervasives.Unascribe + | FV (fv, _, [(l, _)]) when S.fv_eq_lid fv PC.steps_unfoldonly -> + BU.bind_opt (unembed (e_list e_string) cb l) (fun ss -> + Some <| Pervasives.UnfoldOnly ss) + | FV (fv, _, [(l, _)]) when S.fv_eq_lid fv PC.steps_unfoldfully -> + BU.bind_opt (unembed (e_list e_string) cb l) (fun ss -> + Some <| Pervasives.UnfoldFully ss) + | FV (fv, _, [(l, _)]) when S.fv_eq_lid fv PC.steps_unfoldattr -> + BU.bind_opt (unembed (e_list e_string) cb l) (fun ss -> + Some <| Pervasives.UnfoldAttr ss) + | FV (fv, _, [(l, _)]) when S.fv_eq_lid fv PC.steps_unfoldqual -> + BU.bind_opt (unembed (e_list e_string) cb l) (fun ss -> + Some <| Pervasives.UnfoldQual ss) + | FV (fv, _, [(l, _)]) when S.fv_eq_lid fv PC.steps_unfoldnamespace -> + BU.bind_opt (unembed (e_list e_string) cb l) (fun ss -> + Some <| Pervasives.UnfoldNamespace ss) + | _ -> + Errors.log_issue0 Errors.Warning_NotEmbedded + (BU.format1 "Not an embedded norm_step: %s" (t_to_string t0)); + None + in + mk_emb em un (fun () -> mkFV (lid_as_fv PC.norm_step_lid None) [] []) + (SE.emb_typ_of norm_step) + +(* Interface for building primitive steps *) + +let bogus_cbs = { + iapp = (fun h _args -> h); + translate = (fun _ -> failwith "bogus_cbs translate"); +} + +let arg_as_int (a:arg) = fst a |> unembed e_int bogus_cbs + +let arg_as_bool (a:arg) = fst a |> unembed e_bool bogus_cbs + +let arg_as_list (e:embedding 'a) (a:arg) = fst a |> unembed (e_list e) bogus_cbs + +(* XXX a lot of code duplication. Same code as in cfg.fs *) +let lift_unary (f : 'a -> 'b) (aopts : list (option 'a)) : option 'b = + match aopts with + | [Some a] -> Some (f a) + | _ -> None + + +let lift_binary (f : 'a -> 'a -> 'b) (aopts : list (option 'a)) : option 'b = + match aopts with + | [Some a0; Some a1] -> Some (f a0 a1) + | _ -> None + +let mixed_binary_op (as_a : arg -> option 'a) (as_b : arg -> option 'b) + (embed_c : 'c -> t) (f : universes -> 'a -> 'b -> option 'c) + (us:universes) (args : args) : option t = + match args with + | [a;b] -> + begin + match as_a a, as_b b with + | Some a, Some b -> + (match f us a b with + | Some c -> Some (embed_c c) + | _ -> None) + | _ -> None + end + | _ -> None + +let mixed_ternary_op (as_a : arg -> option 'a) + (as_b : arg -> option 'b) + (as_c : arg -> option 'c) + (embed_d : 'd -> t) + (f : universes -> 'a -> 'b -> 'c -> option 'd) + (us: universes) + (args : args) : option t = + match args with + | [a;b;c] -> + begin + match as_a a, as_b b, as_c c with + | Some a, Some b, Some c -> + (match f us a b c with + | Some d -> Some (embed_d d) + | _ -> None) + | _ -> None + end + | _ -> None + +let dummy_interp (lid : Ident.lid) (args : args) : option t = + failwith ("No interpretation for " ^ (Ident.string_of_lid lid)) + +let and_op (args:args) : option t = + match args with + | [a1; a2] -> begin + match arg_as_bool a1 with + | Some false -> + Some (embed e_bool bogus_cbs false) + | Some true -> + Some (fst a2) + | _ -> None + end + | _ -> failwith "Unexpected number of arguments" + +let or_op (args:args) : option t = + match args with + | [a1; a2] -> begin + match arg_as_bool a1 with + | Some true -> + Some (embed e_bool bogus_cbs true) + | Some false -> + Some (fst a2) + | _ -> None + end + | _ -> failwith "Unexpected number of arguments" + +// let e_arrow2 (ea:embedding 'a) (eb:embedding 'b) (ec:embedding 'c) = +// let em (f : 'a -> 'b -> 'c) : t = Lam((fun (ta:t) -> match unembed ea ta with +// | Some a -> embed eb (f a) +// | None -> failwith "Cannot unembed argument"), +// (fun _ -> type_of ea), None) +// in +// let un (lam : t) : option ('a -> 'b) = +// match lam with +// | Lam (ft, _, _) -> Some (fun (x:'a) -> match unembed eb (ft (embed ea x)) with +// | Some b -> b +// | None -> failwith "Cannot unembed function result") +// | _ -> None +// in +// mk_emb em un (make_arrow1 (type_of ea) (as_iarg (type_of eb))) + + + +let arrow_as_prim_step_1 (ea:embedding 'a) (eb:embedding 'b) + (f:'a -> 'b) (_fv_lid:Ident.lid) cb + : universes -> args -> option t = + let f_wrapped _us args = + let x, _ = List.hd args in //arity mismatches are handled by code that dispatches here + BU.map_opt + (unembed ea cb x) (fun x -> + embed eb cb (f x)) + in + f_wrapped + +let arrow_as_prim_step_2 (ea:embedding 'a) (eb:embedding 'b) (ec:embedding 'c) + (f:'a -> 'b -> 'c) (_fv_lid:Ident.lid) cb + : universes -> args -> option t = + let f_wrapped _us args = + let x, _ = List.hd args in //arity mismatches are handled by code that dispatches here + let y, _ = List.hd (List.tl args) in + BU.bind_opt (unembed ea cb x) (fun x -> + BU.bind_opt (unembed eb cb y) (fun y -> + Some (embed ec cb (f x y)))) + in + f_wrapped + + +let arrow_as_prim_step_3 (ea:embedding 'a) (eb:embedding 'b) + (ec:embedding 'c) (ed:embedding 'd) + (f:'a -> 'b -> 'c -> 'd) (_fv_lid:Ident.lid) cb + : universes -> args -> option t = + let f_wrapped _us args = + let x, _ = List.hd args in //arity mismatches are handled by code that dispatches here + let y, _ = List.hd (List.tl args) in + let z, _ = List.hd (List.tl (List.tl args)) in + BU.bind_opt (unembed ea cb x) (fun x -> + BU.bind_opt (unembed eb cb y) (fun y -> + BU.bind_opt (unembed ec cb z) (fun z -> + Some (embed ed cb (f x y z))))) + in + f_wrapped + +(* TODO: move to, Syntax.Embeddings or somewhere better even *) +let e_order = + let ord_Lt_lid = Ident.lid_of_path (["FStar"; "Order"; "Lt"]) Range.dummyRange in + let ord_Eq_lid = Ident.lid_of_path (["FStar"; "Order"; "Eq"]) Range.dummyRange in + let ord_Gt_lid = Ident.lid_of_path (["FStar"; "Order"; "Gt"]) Range.dummyRange in + let ord_Lt = tdataconstr ord_Lt_lid in + let ord_Eq = tdataconstr ord_Eq_lid in + let ord_Gt = tdataconstr ord_Gt_lid in + let ord_Lt_fv = lid_as_fv ord_Lt_lid (Some Data_ctor) in + let ord_Eq_fv = lid_as_fv ord_Eq_lid (Some Data_ctor) in + let ord_Gt_fv = lid_as_fv ord_Gt_lid (Some Data_ctor) in + let open FStar.Order in + let embed_order cb (o:order) : t = + match o with + | Lt -> mkConstruct ord_Lt_fv [] [] + | Eq -> mkConstruct ord_Eq_fv [] [] + | Gt -> mkConstruct ord_Gt_fv [] [] + in + let unembed_order cb (t:t) : option order = + match t.nbe_t with + | Construct (fv, _, []) when S.fv_eq_lid fv ord_Lt_lid -> Some Lt + | Construct (fv, _, []) when S.fv_eq_lid fv ord_Eq_lid -> Some Eq + | Construct (fv, _, []) when S.fv_eq_lid fv ord_Gt_lid -> Some Gt + | _ -> None + in + let fv_as_emb_typ fv = S.ET_app (FStarC.Ident.string_of_lid fv.fv_name.v, []) in + let fv = lid_as_fv PC.order_lid None in + mk_emb embed_order unembed_order (fun () -> mkFV fv [] []) (fun () -> fv_as_emb_typ fv) diff --git a/src/typechecker/FStarC.TypeChecker.NBETerm.fsti b/src/typechecker/FStarC.TypeChecker.NBETerm.fsti new file mode 100644 index 00000000000..3eb2efac532 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.NBETerm.fsti @@ -0,0 +1,354 @@ +(* + Copyright 2017-2019 Microsoft Research + + Authors: Zoe Paraskevopoulou, Guido Martinez, Nikhil Swamy + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.TypeChecker.NBETerm + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Syntax.Syntax +open FStarC.Ident +open FStarC.VConfig +open FStar.Char + +module S = FStarC.Syntax.Syntax +module U = FStarC.Syntax.Util +module Z = FStarC.BigInt +module TEQ = FStarC.TypeChecker.TermEqAndSimplify +open FStarC.Class.Show + +val interleave_hack : int + +(* + This module provides the internal term representations used in the + NBE algorithm implemented by FStarC.TypeChecker.NBE.fs (see the + comments at the header of that file, for some general context about + the algorithm). + + Although the type provided by this module is mostly of relevance to + the internal of the NBE algorithm, we expose its definitions mainly + so that we can (in FStarC.TypeChecker.Cfg and + FStarC.Tactics.Interpreter) provide NBE compatible implementations + of primitive computation steps. +*) + +type var = bv +type sort = int + +// This type mostly mirrors the definition of FStarC.Const.sconst +// There are several missing cases, however. +// TODO: We should also provide implementations for float, bytearray, +// etc. +type constant = + | Unit + | Bool of bool + | Int of Z.t + | String of string & Range.range + | Char of FStar.Char.char + | Range of Range.range + | SConst of FStarC.Const.sconst + | Real of string + +// Atoms represent the head of an irreducible application +// They can either be variables +// Or, un-reduced match terms +type atom + = + | Var of var + | Match of + // 1. the scrutinee + t & + // 2. reconstruct the returns annotation + (unit -> option match_returns_ascription) & + // 3. reconstructs the pattern matching, if it needs to be readback + (unit -> list branch) & + // 4. reconstruct the residual comp if set + (unit -> option S.residual_comp) + | UnreducedLet of + // Especially when extracting, we do not always want to reduce let bindings + // since that can lead to exponential code size blowup. This node represents + // an unreduced let binding which can be read back as an F* let + // 1. The name of the let-bound term + var & + // 2. The type of the let-bound term + Thunk.t t & + // 3. Its definition + Thunk.t t & + // 4. The body of the let binding + Thunk.t t & + // 5. The source letbinding for readback (of attributes etc.) + letbinding + | UnreducedLetRec of + // Same as UnreducedLet, but for local let recs + // 1. list of names of all mutually recursive let-rec-bound terms + // * their types + // * their definitions + list (var & t & t) & + // 2. the body of the let binding + t & + // 3. the source letbinding for readback (of attributes etc.) + // equal in length to the first list + list letbinding + | UVar of Thunk.t S.term + +and lam_shape = + // a context, binders and residual_comp for readback + | Lam_bs of (list t & binders & option S.residual_comp) + + // or a list of arguments, for primitive unembeddings (see e_arrow) + | Lam_args of (list arg) + + // or a partially applied primop + | Lam_primop of (S.fv & list arg) + +and t' = + | Lam { + interp : list (t & aqual) -> t; + //these expect their arguments in binder order (optimized for convenience beta reduction) + //we also maintain aquals so as to reconstruct the application properly for implicits + + shape : lam_shape; + arity : int; + } + + | Accu of atom & args + | Construct of fv & list universe & args + | FV of fv & list universe & args //universes and args in reverse order + | Constant of constant + | Type_t of universe + | Univ of universe + | Unknown + | Arrow of either (Thunk.t S.term) (list arg & comp) + | Refinement of (t -> t) & (unit -> arg) + | Reflect of t + | Quote of S.term & S.quoteinfo + | Lazy of (either S.lazyinfo (Dyn.dyn & emb_typ)) & Thunk.t t + | Meta of t & Thunk.t S.metadata + | TopLevelLet of + // 1. The definition of the fv + letbinding & + // 2. Its natural arity including universes (see Util.let_rec_arity) + int & + // 3. Accumulated arguments in order from left-to-right (unlike Accu, these are not reversed) + args + | TopLevelRec of + // 1. The definition of the fv + letbinding & + // 2. Its natural arity including universes (see Util.let_rec_arity) + int & + // 3. Whether or not each argument appeats in the decreases clause (also see Util.let_rec_arity) + list bool & + // 4. Accumulated arguments in order from left-to-right (unlike Accu, these are not reversed) + args + | LocalLetRec of + // 1. index of the let binding in the mutually recursive list + int & + letbinding & + // 2. Mutally recursive letbindings (only for local mutually recursive let bindings) + list letbinding & + // 3. rec env + list t & + // 4. Argument accumulator + args & + // 5. natural arity (including universes) of the main let binding `f` (see Util.let_rec_arity) + int & + // 6. for each argument, a bool records if that argument appears in the decreases + // This is used to detect potentially non-terminating loops + list bool + +and t = { + nbe_t : t'; + nbe_r : Range.range +} + +and comp = + | Tot of t + | GTot of t + | Comp of comp_typ + +and comp_typ = { + comp_univs:universes; + effect_name:lident; + result_typ:t; + effect_args:args; + flags:list cflag +} + +and residual_comp = { + residual_effect:lident; + residual_typ :option t; + residual_flags :list cflag +} + +and cflag = + | TOTAL + | MLEFFECT + | RETURN + | PARTIAL_RETURN + | SOMETRIVIAL + | TRIVIAL_POSTCONDITION + | SHOULD_NOT_INLINE + | LEMMA + | CPS + | DECREASES_lex of list t + | DECREASES_wf of (t & t) + +and arg = t & aqual +and args = list (arg) + +instance val showable_t : showable t +instance val showable_args : showable args + +val isAccu : t -> bool +val isNotAccu : t -> bool + +val mkConstruct : fv -> list universe -> args -> t +val mkFV : fv -> list universe -> args -> t + +val mkAccuVar : var -> t +val mkAccuMatch : t -> (unit -> option match_returns_ascription) -> (unit -> list branch) -> (unit -> option S.residual_comp) -> t + +type head = t +type annot = option t + +type nbe_cbs = { + iapp : t -> args -> t; + translate : term -> t; +} + +class embedding (a:Type0) = { + em : nbe_cbs -> a -> t; + un : nbe_cbs -> t -> option a; + (* thunking to allow total instances *) + typ : unit -> t; + e_typ : unit -> emb_typ; +} + +val eq_t : Env.env_t -> t -> t -> TEQ.eq_result + +// Printing functions + +val constant_to_string : constant -> string +val t_to_string : t -> string +val atom_to_string : atom -> string +val arg_to_string : arg -> string +val args_to_string : args -> string + +// NBE term manipulation +val mk_t : t' -> t +val nbe_t_of_t : t -> t' + +val as_arg : t -> arg +val as_iarg : t -> arg + +val iapp_cb : nbe_cbs -> t -> args -> t +val translate_cb : nbe_cbs -> term -> t + +val mk_emb : (nbe_cbs -> 'a -> t) -> + (nbe_cbs -> t -> option 'a) -> + (unit -> t) -> + (unit -> emb_typ) -> + Prims.Tot (embedding 'a) + +val embed_as : embedding 'a -> ('a -> 'b) -> ('b -> 'a) -> option t -> embedding 'b + +val embed : embedding 'a -> nbe_cbs -> 'a -> t +val unembed : embedding 'a -> nbe_cbs -> t -> option 'a +val lazy_unembed_lazy_kind (#a:Type) (k:lazy_kind) (x:t) : option a +val type_of : embedding 'a -> t +val set_type : t -> embedding 'a -> embedding 'a + +type abstract_nbe_term = | AbstractNBE : t:t -> abstract_nbe_term + +instance val e_bool : embedding bool +instance val e_string : embedding string +instance val e_char : embedding char +instance val e_int : embedding Z.t +instance val e_real : embedding Compiler.Real.real +instance val e_unit : embedding unit +val e_any : embedding t +val mk_any_emb : t -> embedding t +val e___range : embedding Range.range (* unsealed *) +instance val e_range : embedding Range.range (* sealed *) +instance val e_issue : embedding FStarC.Errors.issue +instance val e_document : embedding FStarC.Pprint.document +instance val e_vconfig : embedding vconfig +instance val e_norm_step : embedding Pervasives.norm_step +instance val e_list : #a:Type -> embedding a -> Prims.Tot (embedding (list a)) +instance val e_option : embedding 'a -> Prims.Tot (embedding (option 'a)) +instance val e_tuple2 : embedding 'a -> embedding 'b -> Prims.Tot (embedding ('a & 'b)) +instance val e_tuple3 : embedding 'a -> embedding 'b -> embedding 'c -> Prims.Tot (embedding ('a & 'b & 'c)) +instance val e_tuple4 : embedding 'a -> embedding 'b -> embedding 'c -> embedding 'd -> Prims.Tot (embedding ('a & 'b & 'c & 'd)) +instance val e_tuple5 : embedding 'a -> embedding 'b -> embedding 'c -> embedding 'd -> embedding 'e -> Prims.Tot (embedding ('a & 'b & 'c & 'd & 'e)) +instance val e_either : embedding 'a -> embedding 'b -> Prims.Tot (embedding (either 'a 'b)) +instance val e_sealed : embedding 'a -> Prims.Tot (embedding (FStarC.Compiler.Sealed.sealed 'a)) +instance val e_string_list : embedding (list string) +val e_arrow : embedding 'a -> embedding 'b -> embedding ('a -> 'b) + +instance val e_abstract_nbe_term : embedding abstract_nbe_term +instance val e_order : embedding FStar.Order.order + +(* Unconditionally fails raising an exception when called *) +val e_unsupported : #a:Type -> embedding a + +(* Arity specific raw_embeddings of arrows; used to generate top-level + registrations of compiled functions in FStarC.Extraction.ML.Util *) +val arrow_as_prim_step_1: embedding 'a + -> embedding 'b + -> ('a -> 'b) + -> repr_f:Ident.lid + -> nbe_cbs + -> (universes -> args -> option t) + +val arrow_as_prim_step_2: embedding 'a + -> embedding 'b + -> embedding 'c + -> ('a -> 'b -> 'c) + -> repr_f:Ident.lid + -> nbe_cbs + -> (universes -> args -> option t) + +val arrow_as_prim_step_3: embedding 'a + -> embedding 'b + -> embedding 'c + -> embedding 'd + -> ('a -> 'b -> 'c -> 'd) + -> repr_f:Ident.lid + -> nbe_cbs + -> (universes -> args -> option t) + +// Interface for NBE interpretations + +val arg_as_int : arg -> option Z.t +val arg_as_list : embedding 'a -> arg -> option (list 'a) + +val mixed_binary_op : (arg -> option 'a) -> (arg -> option 'b) -> ('c -> t) -> + (universes -> 'a -> 'b -> option 'c) -> universes -> args -> option t + +val mixed_ternary_op (as_a : arg -> option 'a) + (as_b : arg -> option 'b) + (as_c : arg -> option 'c) + (embed_d : 'd -> t) + (f : universes -> 'a -> 'b -> 'c -> option 'd) + (us:universes) + (args : args) : option t + +val dummy_interp : Ident.lid -> args -> option t + +val and_op : args -> option t +val or_op : args -> option t diff --git a/src/typechecker/FStarC.TypeChecker.Normalize.Unfolding.fst b/src/typechecker/FStarC.TypeChecker.Normalize.Unfolding.fst new file mode 100644 index 00000000000..72f8433fffb --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Normalize.Unfolding.fst @@ -0,0 +1,185 @@ +module FStarC.TypeChecker.Normalize.Unfolding + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.TypeChecker.Cfg +open FStarC.TypeChecker.Env +open FStarC.Syntax.Print + +module Common = FStarC.TypeChecker.Common +module BU = FStarC.Compiler.Util +module Path = FStarC.Compiler.Path +module PC = FStarC.Parser.Const +module Print = FStarC.Syntax.Print +module S = FStarC.Syntax.Syntax +module U = FStarC.Syntax.Util +module TEQ = FStarC.TypeChecker.TermEqAndSimplify + +open FStarC.Class.Show + +(* Max number of warnings to print in a single run. +Initialized in Normalize.normalize *) +let plugin_unfold_warn_ctr : ref int = BU.mk_ref 0 + +let should_unfold cfg should_reify fv qninfo : should_unfold_res = + let attrs = + match Env.attrs_of_qninfo qninfo with + | None -> [] + | Some ats -> ats + in + let quals = + match Env.quals_of_qninfo qninfo with + | None -> [] + | Some quals -> quals + in + (* unfold or not, fully or not, reified or not *) + let yes = true , false , false in + let no = false , false , false in + let fully = true , true , false in + let reif = true , false , true in + + let yesno b = if b then yes else no in + let fullyno b = if b then fully else no in + let comb_or l = List.fold_right (fun (a,b,c) (x,y,z) -> (a||x, b||y, c||z)) l (false, false, false) in + + let default_unfolding () = + log_unfolding cfg (fun () -> BU.print3 "should_unfold: Reached a %s with delta_depth = %s\n >> Our delta_level is %s\n" + (show fv) + (show (Env.delta_depth_of_fv cfg.tcenv fv)) + (show cfg.delta_level)); + yesno <| (cfg.delta_level |> BU.for_some (function + | NoDelta -> false + | InliningDelta + | Eager_unfolding_only -> true + | Unfold l -> Common.delta_depth_greater_than (Env.delta_depth_of_fv cfg.tcenv fv) l)) + in + let res = + match qninfo, + cfg.steps.unfold_only, + cfg.steps.unfold_fully, + cfg.steps.unfold_attr, + cfg.steps.unfold_qual, + cfg.steps.unfold_namespace + with + // We unfold dm4f actions if and only if we are reifying + | _ when Env.qninfo_is_action qninfo -> + let b = should_reify cfg in + log_unfolding cfg (fun () -> BU.print2 "should_unfold: For DM4F action %s, should_reify = %s\n" + (show fv) + (show b)); + if b then reif else no + + // If it is handled primitively, then don't unfold + | _ when Option.isSome (find_prim_step cfg fv) -> + log_unfolding cfg (fun () -> BU.print_string " >> It's a primop, not unfolding\n"); + no + + // Don't unfold HasMaskedEffect + | Some (Inr ({sigquals=qs; sigel=Sig_let {lbs=(is_rec, _)}}, _), _), _, _, _, _, _ when + List.contains HasMaskedEffect qs -> + log_unfolding cfg (fun () -> BU.print_string " >> HasMaskedEffect, not unfolding\n"); + no + + // Recursive lets may only be unfolded when Zeta is on + | Some (Inr ({sigquals=qs; sigel=Sig_let {lbs=(is_rec, _)}}, _), _), _, _, _, _, _ when + is_rec && not cfg.steps.zeta && not cfg.steps.zeta_full -> + log_unfolding cfg (fun () -> BU.print_string " >> It's a recursive definition but we're not doing Zeta, not unfolding\n"); + no + + // We're doing selectively unfolding, assume it to not unfold unless it meets the criteria + | _, Some _, _, _, _, _ + | _, _, Some _, _, _, _ + | _, _, _, Some _, _, _ + | _, _, _, _, Some _, _ + | _, _, _, _, _, Some _ -> + log_unfolding cfg (fun () -> BU.print1 "should_unfold: Reached a %s with selective unfolding\n" + (show fv)); + // How does the following code work? + // We are doing selective unfolding so, by default, we assume everything + // should *not* be unfolded unless it meets *at least one* of the criteria. + // So we check exactly that, that this `fv` meets some criteria that is presently + // being used. Note that in `None`, we default to `no`, otherwise everything would + // unfold (unless we had all criteria present at once, which is unlikely) + + let meets_some_criterion = + comb_or [ + (if cfg.steps.for_extraction + then yesno <| Option.isSome (Env.lookup_definition_qninfo [Eager_unfolding_only; InliningDelta] fv.fv_name.v qninfo) + else no) + ;(match cfg.steps.unfold_only with + | None -> no + | Some lids -> yesno <| BU.for_some (fv_eq_lid fv) lids) + ;(match cfg.steps.unfold_attr with + | None -> no + | Some lids -> yesno <| BU.for_some (fun at -> BU.for_some (fun lid -> U.is_fvar lid at) lids) attrs) + ;(match cfg.steps.unfold_fully with + | None -> no + | Some lids -> fullyno <| BU.for_some (fv_eq_lid fv) lids) + ;(match cfg.steps.unfold_qual with + | None -> no + | Some qs -> + yesno <| + BU.for_some + (fun q -> + BU.for_some + (fun qual -> show qual = q) // kinda funny + quals) + qs) + ;(match cfg.steps.unfold_namespace with + | None -> no + | Some namespaces -> + (* Check if the variable is under some of the modules in [ns]. + Essentially we check if there is a component in ns that is a prefix of + the (printed) lid. But, to prevent unfolding `ABCD.def` when we + are trying to unfold `AB`, we append a single `.` to both before checking, + so `AB` only unfold lids under the `AB` module and its submodules. *) + let p : list string = Ident.path_of_lid (lid_of_fv fv) in + let r : bool = Path.search_forest p namespaces in + yesno <| r + ) + ] + in + meets_some_criterion + + // Check for DontUnfoldAttribute: if any attribute of the definitions is blacklisted, + // do not unfold. + // NB: Using specific attributes like UnfoldOnly will override this. This gives more + // control to the user if they *really* want to unfold one of these. + | _, _, _, _, _, _ when Some? cfg.steps.dont_unfold_attr + && List.existsb (fun fa -> U.has_attribute attrs fa) (Some?.v cfg.steps.dont_unfold_attr) -> + log_unfolding cfg (fun () -> BU.print_string " >> forbidden by attribute, not unfolding\n"); + no + + + // Nothing special, just check the depth + | _ -> + default_unfolding() + in + log_unfolding cfg (fun () -> BU.print3 "should_unfold: For %s (%s), unfolding res = %s\n" + (show fv) + (show (S.range_of_fv fv)) + (show res) + ); + let r = + match res with + | false, _, _ -> Should_unfold_no + | true, false, false -> Should_unfold_yes + | true, true, false -> Should_unfold_fully + | true, false, true -> Should_unfold_reify + | _ -> + failwith <| BU.format1 "Unexpected unfolding result: %s" (show res) + in + if Some? cfg.steps.dont_unfold_attr // If we are running a tactic (probably..), + && not (Options.no_plugins ()) // haven't explicitly disabled plugins + && (r <> Should_unfold_no) // actually unfolding this fvar + && BU.for_some (U.is_fvar PC.plugin_attr) attrs // it is a plugin + && !plugin_unfold_warn_ctr > 0 // and we haven't raised too many warnings + then begin + // then warn about it + let msg = BU.format1 "Unfolding name which is marked as a plugin: %s" (show fv) in + Errors.log_issue fv.fv_name.p Errors.Warning_UnfoldPlugin msg; + plugin_unfold_warn_ctr := !plugin_unfold_warn_ctr - 1 + end; + r diff --git a/src/typechecker/FStarC.TypeChecker.Normalize.Unfolding.fsti b/src/typechecker/FStarC.TypeChecker.Normalize.Unfolding.fsti new file mode 100644 index 00000000000..fc981c6c573 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Normalize.Unfolding.fsti @@ -0,0 +1,23 @@ +module FStarC.TypeChecker.Normalize.Unfolding + +open FStarC.Compiler.Effect +open FStarC.TypeChecker +open FStarC.Syntax.Syntax +open FStarC.TypeChecker.Cfg + +(* This reference stores the max amount of warnings we emit +about unfolding plugins. Set by normalize (0 otherwise). *) +val plugin_unfold_warn_ctr : ref int + +(* Exposed for NBE *) +type should_unfold_res = + | Should_unfold_no + | Should_unfold_yes + | Should_unfold_fully + | Should_unfold_reify + +val should_unfold : cfg + -> should_reify:(cfg -> bool) + -> fv + -> Env.qninfo + -> should_unfold_res diff --git a/src/typechecker/FStarC.TypeChecker.Normalize.fst b/src/typechecker/FStarC.TypeChecker.Normalize.fst new file mode 100644 index 00000000000..0432f64f2ef --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Normalize.fst @@ -0,0 +1,3299 @@ +(* + Copyright 2008-2016 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.TypeChecker.Normalize +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.Defensive +open FStarC.Compiler.Util +open FStar.String +open FStarC.Const +open FStar.Char +open FStarC.Errors +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.Syntax.Subst +open FStarC.Syntax.Util +open FStarC.TypeChecker +open FStarC.TypeChecker.Common +open FStarC.TypeChecker.Env +open FStarC.TypeChecker.Cfg + +open FStarC.Class.Show +open FStarC.Class.Tagged +open FStarC.Class.Deq + +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module BU = FStarC.Compiler.Util +module FC = FStarC.Const +module PC = FStarC.Parser.Const +module U = FStarC.Syntax.Util +module I = FStarC.Ident +module EMB = FStarC.Syntax.Embeddings +module Z = FStarC.BigInt +module TcComm = FStarC.TypeChecker.Common +module TEQ = FStarC.TypeChecker.TermEqAndSimplify +module PO = FStarC.TypeChecker.Primops +open FStarC.TypeChecker.Normalize.Unfolding + +let dbg_univ_norm = Debug.get_toggle "univ_norm" +let dbg_NormRebuild = Debug.get_toggle "NormRebuild" + +(********************************************************************************************** + * Reduction of types via the Krivine Abstract Machine (KN), with lazy + * reduction and strong reduction (under binders), as described in: + * + * Strongly reducing variants of the Krivine abstract machine + * Pierre Crégut + * Higher-Order Symb Comput (2007) 20: 209–230 + **********************************************************************************************) + +let maybe_debug (cfg:Cfg.cfg) (t:term) (dbg:option (term & BU.time)) = + if cfg.debug.print_normalized + then match dbg with + | Some (tm, time_then) -> + let time_now = BU.now () in + // BU.print1 "Normalizer result timing (%s ms)\n" + // (show (snd (BU.time_diff time_then time_now))) + BU.print4 "Normalizer result timing (%s ms){\nOn term {\n%s\n}\nwith steps {%s}\nresult is{\n\n%s\n}\n}\n" + (show (snd (BU.time_diff time_then time_now))) + (show tm) + (show cfg) + (show t) + | _ -> () + +let cases f d = function + | Some x -> f x + | None -> d + +(* We memoize the normal form of variables in the environment, in + * order to implement call-by-need and avoid an exponential explosion, + * but we take care to only reuse memoized values when the cfg has not + * changed. The main reason is normalization requests, which can "grow" + * the set of allowed computations steps, and hence we may memoize + * something during the request that is used outside of it. This will + * essentially make it invalid. See issue #2155 in Github. + * + * We compare the cfg with physical equality, so it has to be the + * exact same object in memory. See read_memo and set_memo below. *) +type cfg_memo 'a = memo (Cfg.cfg & 'a) + +let fresh_memo (#a:Type) () : memo a = BU.mk_ref None + +type closure = + | Clos of env & term & cfg_memo (env & term) & bool //memo for lazy evaluation; bool marks whether or not this is a fixpoint + | Univ of universe //universe terms do not have free variables + | Dummy //Dummy is a placeholder for a binder when doing strong reduction +and env = list (option binder & closure & memo subst_t) + +instance showable_memo (a:Type) (_ : showable a) : Tot (showable (memo a)) = { + show = (fun m -> match !m with + | None -> "no_memo" + | Some x -> "memo=" ^ show x) +} + +let empty_env : env = [] + +let dummy () : (option binder & closure & memo subst_t) = (None, Dummy, fresh_memo ()) + +type branches = list (pat & option term & term) + +type stack_elt = + | Arg of closure & aqual & Range.range + | UnivArgs of list universe & Range.range // NB: universes must be values already, no bvars allowed + | MemoLazy of cfg_memo (env & term) + | Match of env & option match_returns_ascription & branches & option residual_comp & cfg & Range.range + | Abs of env & binders & env & option residual_comp & Range.range //the second env is the first one extended with the binders, for reducing the option lcomp + | App of env & term & aqual & Range.range + | CBVApp of env & term & aqual & Range.range + | Meta of env & S.metadata & Range.range + | Let of env & binders & letbinding & Range.range +type stack = list stack_elt + +let head_of t = let hd, _ = U.head_and_args_full t in hd + +(* Decides whether a memo taken in config c1 is valid when reducing in config c2. *) +let cfg_equivalent (c1 c2 : Cfg.cfg) : bool = + c1.steps =? c2.steps && + c1.delta_level =? c2.delta_level && + c1.normalize_pure_lets =? c2.normalize_pure_lets + +let read_memo cfg (r:memo (Cfg.cfg & 'a)) : option 'a = + match !r with + (* We only take this memoized value if the cfg matches the current + one, or if we are running in compatibility mode for it. *) + | Some (cfg', a) when cfg.compat_memo_ignore_cfg || BU.physical_equality cfg cfg' || cfg_equivalent cfg' cfg -> + Some a + | _ -> None + +let set_memo cfg (r:memo (Cfg.cfg & 'a)) (t:'a) : unit = + if cfg.memoize_lazy then begin + (* We do this only as a sanity check. The only situation where we + * should set a memo again is when the cfg has changed. *) + if Option.isSome (read_memo cfg r) then + failwith "Unexpected set_memo: thunk already evaluated"; + r := Some (cfg, t) + end + +let closure_to_string = function + | Clos (env, t, _, _) -> BU.format2 "(env=%s elts; %s)" (List.length env |> string_of_int) (show t) + | Univ _ -> "Univ" + | Dummy -> "dummy" + +instance showable_closure : showable closure = { + show = closure_to_string; +} + +instance showable_stack_elt : showable stack_elt = { + show = (function + | Arg (c, _, _) -> BU.format1 "Closure %s" (show c) + | MemoLazy _ -> "MemoLazy" + | Abs (_, bs, _, _, _) -> BU.format1 "Abs %s" (show <| List.length bs) + | UnivArgs _ -> "UnivArgs" + | Match _ -> "Match" + | App (_, t,_,_) -> BU.format1 "App %s" (show t) + | CBVApp (_, t,_,_) -> BU.format1 "CBVApp %s" (show t) + | Meta (_, m,_) -> "Meta" + | Let _ -> "Let"); +} + +let is_empty = function + | [] -> true + | _ -> false + +let lookup_bvar (env : env) x = + try (List.nth env x.index)._2 + with _ -> failwith (BU.format2 "Failed to find %s\nEnv is %s\n" (show x) (show env)) + +let downgrade_ghost_effect_name l = + if Ident.lid_equals l PC.effect_Ghost_lid + then Some PC.effect_Pure_lid + else if Ident.lid_equals l PC.effect_GTot_lid + then Some PC.effect_Tot_lid + else if Ident.lid_equals l PC.effect_GHOST_lid + then Some PC.effect_PURE_lid + else None + +(********************************************************************************************************************) +(* Normal form of a universe u is *) +(* either u, where u <> U_max *) +(* or U_max [k; --constant *) +(* S^n1 u1 ; ...; S^nm um; --offsets of distinct names, in order of the names *) +(* S^p1 ?v1; ...; S^pq ?vq] --offsets of distinct unification variables, in order of the variables *) +(* where the size of the list is at least 2 *) +(********************************************************************************************************************) +let norm_universe cfg (env:env) u = + let norm_univs_for_max us = + let us = BU.sort_with U.compare_univs us in + (* us is in sorted order; *) + (* so, for each sub-sequence in us with a common kernel, just retain the largest one *) + (* e.g., normalize [Z; S Z; S S Z; u1; S u1; u2; S u2; S S u2; ?v1; S ?v1; ?v2] *) + (* to [ S S Z; S u1; S S u2; S ?v1; ?v2] *) + let _, u, out = + List.fold_left (fun (cur_kernel, cur_max, out) u -> + let k_u, n = U.univ_kernel u in + if U.eq_univs cur_kernel k_u //streak continues + then (cur_kernel, u, out) //take u as the current max of the streak + else (k_u, u, cur_max::out)) //streak ends; include cur_max in the output and start a new streak + (U_zero, U_zero, []) us in + List.rev (u::out) in + + (* normalize u by *) + (* 1. flattening all max nodes *) + (* 2. pushing all S nodes under a single top-level max node *) + (* 3. sorting the terms in a max node, and partially evaluate it *) + let rec aux (u:universe) : list universe = + let u = Subst.compress_univ u in + match u with + | U_bvar x -> + begin + try match (List.nth env x)._2 with + | Univ u -> + if !dbg_univ_norm then + BU.print1 "Univ (in norm_universe): %s\n" (show u) + else (); aux u + | Dummy -> [u] + | _ -> failwith (BU.format1 "Impossible: universe variable u@%s bound to a term" + (string_of_int x)) + with _ -> if cfg.steps.allow_unbound_universes + then [U_unknown] + else failwith ("Universe variable not found: u@" ^ string_of_int x) + end + | U_unif _ when cfg.steps.default_univs_to_zero -> + [U_zero] + + | U_unif _ when cfg.steps.check_no_uvars -> + failwith (BU.format2 "(%s) CheckNoUvars: unexpected universes variable remains: %s" + (Range.string_of_range (Env.get_range cfg.tcenv)) + (show u)) + + | U_zero + | U_unif _ + | U_name _ + | U_unknown -> [u] + | U_max [] -> [U_zero] + | U_max us -> + let us = List.collect aux us |> norm_univs_for_max in + begin match us with + | u_k::hd::rest -> + let rest = hd::rest in + begin match U.univ_kernel u_k with + | U_zero, n -> //if the constant term n + if rest |> List.for_all (fun u -> + let _, m = U.univ_kernel u in + n <= m) //is smaller than or equal to all the other terms in the max + then rest //then just exclude it + else us + | _ -> us + end + | _ -> us + end + | U_succ u -> List.map U_succ (aux u) in + + if cfg.steps.erase_universes + then U_unknown + else match aux u with + | [] + | [U_zero] -> U_zero + | [U_zero; u] -> u + | U_zero::us -> U_max us + | [u] -> u + | us -> U_max us + +let memo_or (m : memo 'a) (f : unit -> 'a) : 'a = + match !m with + | Some v -> v + | None -> + let v = f () in + m := Some v; + v + +let rec env_subst (env:env) : subst_t = + let compute () = + let (s, _) = + List.fold_left (fun (s, i) (_, c, _) -> + match c with + | Clos (e, t, memo, (* closed_memo, *) fix) -> + // let es = memo_or closed_memo (fun () -> env_subst e) in + let es = env_subst e in + let t = SS.subst es t |> SS.compress in + (DT (i, t) :: s, i+1) + | Univ u -> (UN (i, u) :: s, i+1) + | Dummy -> (s,i+1) + ) ([], 0) env + in + (* NB: The order of the list does not matter, we are building + a parallel substitution. *) + s + in + match env with + | [] -> [] + | (_, _, memo) :: _ -> + match !memo with + | Some s -> s + | None -> + let s = compute () in + memo := Some s; + s + +let filter_out_lcomp_cflags flags = + (* TODO : lc.comp might have more cflags than lcomp.cflags *) + flags |> List.filter (function DECREASES _ -> false | _ -> true) + +let default_univ_uvars_to_zero (t:term) : term = + Visit.visit_term_univs false (fun t -> t) (fun u -> + match u with + | U_unif _ -> U_zero + | _ -> u) t + +let _erase_universes (t:term) : term = + Visit.visit_term_univs false (fun t -> t) (fun u -> U_unknown) t + +let closure_as_term cfg (env:env) (t:term) : term = + log cfg (fun () -> BU.print3 ">>> %s (env=%s)\nClosure_as_term %s\n" (tag_of t) (show env) (show t)); + let es = env_subst env in + let t = SS.subst es t in + let t = + if cfg.steps.erase_universes + then _erase_universes t + else if cfg.steps.default_univs_to_zero + then default_univ_uvars_to_zero t + else t + in + (* Compress the top only since clients expect a compressed term *) + let t = SS.compress t in + log cfg (fun () -> BU.print3 ">>> %s (env=%s)\nClosure_as_term RESULT %s\n" (tag_of t) (show env) (show t)); + t + +(* A hacky knot, set by FStarC.Main *) +let unembed_binder_knot : ref (option (EMB.embedding binder)) = BU.mk_ref None +let unembed_binder (t : term) : option S.binder = + match !unembed_binder_knot with + | Some e -> EMB.try_unembed #_ #e t EMB.id_norm_cb + | None -> + Errors.log_issue t Errors.Warning_UnembedBinderKnot "unembed_binder_knot is unset!"; + None + +let mk_psc_subst cfg (env:env) = + List.fold_right + (fun (binder_opt, closure, _) subst -> + match binder_opt, closure with + | Some b, Clos(env, term, _, _) -> + // BU.print1 "++++++++++++Name in environment is %s" (show b); + let bv = b.binder_bv in + if not (U.is_constructed_typ bv.sort PC.binder_lid) + then subst + else let term = closure_as_term cfg env term in + begin match unembed_binder term with + | None -> subst + | Some x -> + let b = S.freshen_bv ({bv with sort=SS.subst subst x.binder_bv.sort}) in + let b_for_x = S.NT(x.binder_bv, S.bv_to_name b) in + //remove names shadowed by b + let subst = List.filter (function NT(_, {n=Tm_name b'}) -> + not (Ident.ident_equals b.ppname b'.ppname) + | _ -> true) subst in + b_for_x :: subst + end + | _ -> subst) + env [] + +(* Boolean indicates whether further normalization of the result is +required. It is usually false, unless we call into a 'renorm' primitive +step. *) +let reduce_primops norm_cb cfg (env:env) tm : term & bool = + if not cfg.steps.primops + then tm, false + else begin + let head, args = U.head_and_args_full tm in + let head_term, universes = + let head = SS.compress (U.unmeta head) in + match head.n with + | Tm_uinst(fv, us) -> fv, us + | _ -> head, [] + in + match head_term.n with + | Tm_fvar fv -> begin + match find_prim_step cfg fv with + | Some prim_step when prim_step.strong_reduction_ok || not cfg.strong -> + let l = List.length args in + if l < prim_step.arity + then begin log_primops cfg (fun () -> BU.print3 "primop: found partially applied %s (%s/%s args)\n" + (show prim_step.name) + (show l) + (show prim_step.arity)); + tm, false //partial application; can't step + end + else begin + let args_1, args_2 = if l = prim_step.arity + then args, [] + else List.splitAt prim_step.arity args + in + log_primops cfg (fun () -> BU.print1 "primop: trying to reduce <%s>\n" (show tm)); + let psc : PO.psc = { + psc_range = head.pos; + psc_subst = fun () -> if prim_step.requires_binder_substitution + then mk_psc_subst cfg env + else [] + } in + let r = + if false + then begin let (r, ms) = BU.record_time (fun () -> prim_step.interpretation psc norm_cb universes args_1) in + primop_time_count (show fv.fv_name.v) ms; + r + end + else prim_step.interpretation psc norm_cb universes args_1 + in + match r with + | None -> + log_primops cfg (fun () -> BU.print1 "primop: <%s> did not reduce\n" (show tm)); + tm, false + | Some reduced -> + log_primops cfg (fun () -> BU.print2 "primop: <%s> reduced to %s\n" + (show tm) (show reduced)); + (* If prim_step.renorm_after is step, we will later + keep reducing this term. Otherwise we will just + rebuild. *) + U.mk_app reduced args_2, prim_step.renorm_after + end + | Some _ -> + log_primops cfg (fun () -> BU.print1 "primop: not reducing <%s> since we're doing strong reduction\n" + (show tm)); + tm, false + | None -> tm, false + end + + | Tm_constant Const_range_of when not cfg.strong -> + log_primops cfg (fun () -> BU.print1 "primop: reducing <%s>\n" (show tm)); + begin match args with + | [(a1, _)] -> PO.embed_simple a1.pos tm.pos, false + | _ -> tm, false + end + + | Tm_constant Const_set_range_of when not cfg.strong -> + log_primops cfg (fun () -> BU.print1 "primop: reducing <%s>\n" (show tm)); + begin match args with + | [(t, _); (r, _)] -> + begin match PO.try_unembed_simple r with + | Some rng -> Subst.set_use_range rng t, false + | None -> tm, false + end + | _ -> tm, false + end + + | _ -> tm, false + end + +let reduce_equality norm_cb cfg tm = + reduce_primops norm_cb ({cfg with steps = { default_steps with primops = true }; + primitive_steps=simplification_steps cfg.tcenv}) tm + +(********************************************************************************************************************) +(* Main normalization function of the abstract machine *) +(********************************************************************************************************************) + +(* + * AR: norm requests can some times have additional arguments since we flatten the arguments sometimes in the typechecker + * so, a request may look like: normalize_term [a; b; c; d] + * in such cases, we rejig the request to be (normalize_term a) [b; c; d] + *) +type norm_request_t = + | Norm_request_none //not a norm request + | Norm_request_ready //in the form that can be reduced immediately + | Norm_request_requires_rejig //needs rejig + +let is_norm_request (hd:term) (args:args) :norm_request_t = + let aux (min_args:int) :norm_request_t = args |> List.length |> (fun n -> if n < min_args then Norm_request_none + else if n = min_args then Norm_request_ready + else Norm_request_requires_rejig) + in + match (U.un_uinst hd).n with + | Tm_fvar fv when S.fv_eq_lid fv PC.normalize_term -> aux 2 + | Tm_fvar fv when S.fv_eq_lid fv PC.normalize -> aux 1 + | Tm_fvar fv when S.fv_eq_lid fv PC.norm -> aux 3 + | _ -> Norm_request_none + +let should_consider_norm_requests cfg = (not (cfg.steps.no_full_norm)) && (not (Ident.lid_equals cfg.tcenv.curmodule PC.prims_lid)) + +let rejig_norm_request (hd:term) (args:args) :term = + match (U.un_uinst hd).n with + | Tm_fvar fv when S.fv_eq_lid fv PC.normalize_term -> + (match args with + | t1::t2::rest when List.length rest > 0 -> mk_app (mk_app hd [t1; t2]) rest + | _ -> failwith "Impossible! invalid rejig_norm_request for normalize_term") + | Tm_fvar fv when S.fv_eq_lid fv PC.normalize -> + (match args with + | t::rest when List.length rest > 0 -> mk_app (mk_app hd [t]) rest + | _ -> failwith "Impossible! invalid rejig_norm_request for normalize") + | Tm_fvar fv when S.fv_eq_lid fv PC.norm -> + (match args with + | t1::t2::t3::rest when List.length rest > 0 -> mk_app (mk_app hd [t1; t2; t3]) rest + | _ -> failwith "Impossible! invalid rejig_norm_request for norm") + | _ -> failwith ("Impossible! invalid rejig_norm_request for: %s" ^ (show hd)) + +let is_nbe_request s = BU.for_some ((=?) NBE) s + +let get_norm_request cfg (full_norm:term -> term) args = + let parse_steps s = + match PO.try_unembed_simple s with + | Some steps -> Some (Cfg.translate_norm_steps steps) + | None -> None + in + let inherited_steps = + (if cfg.steps.erase_universes then [EraseUniverses] else []) + @ (if cfg.steps.allow_unbound_universes then [AllowUnboundUniverses] else []) + @ (if cfg.steps.nbe_step then [NBE] else []) // ZOE : NBE can be set as the default mode + in + (* We always set UnfoldTac: do not unfold logical connectives *) + match args with + | [_; (tm, _)] + | [(tm, _)] -> + let s = [Beta; Zeta; Iota; Primops; UnfoldUntil delta_constant; Reify] in + Some (DontUnfoldAttr [PC.tac_opaque_attr] :: inherited_steps @ s, tm) + | [(steps, _); _; (tm, _)] -> + begin + match parse_steps (full_norm steps) with + | None -> None + | Some s -> Some (DontUnfoldAttr [PC.tac_opaque_attr] :: inherited_steps @ s, tm) + end + | _ -> + None + +let nbe_eval (cfg:cfg) (s:steps) (tm:term) : term = + let delta_level = + if s |> BU.for_some (function UnfoldUntil _ | UnfoldOnly _ | UnfoldFully _ -> true | _ -> false) + then [Unfold delta_constant] + else [NoDelta] in + log_nbe cfg (fun () -> BU.print1 "Invoking NBE with %s\n" (show tm)); + let tm_norm = (cfg_env cfg).nbe s cfg.tcenv tm in + log_nbe cfg (fun () -> BU.print1 "Result of NBE is %s\n" (show tm_norm)); + tm_norm + +let firstn k l = if List.length l < k then l,[] else first_N k l +let should_reify cfg stack = + let rec drop_irrel = function + | MemoLazy _ :: s + | UnivArgs _ :: s -> + drop_irrel s + | s -> s + in + match drop_irrel stack with + | App (_, {n=Tm_constant (FC.Const_reify _)}, _, _) :: _ -> + // BU.print1 "Found a reify on the stack. %s" "" ; + cfg.steps.reify_ + | _ -> false + +// GM: What is this meant to decide? +let rec maybe_weakly_reduced tm : bool = + let aux_comp c = + match c.n with + | GTotal t + | Total t -> + maybe_weakly_reduced t + + | Comp ct -> + maybe_weakly_reduced ct.result_typ + || BU.for_some (fun (a, _) -> maybe_weakly_reduced a) ct.effect_args + in + let t = Subst.compress tm in + match t.n with + | Tm_delayed _ -> failwith "Impossible" + + | Tm_name _ + | Tm_uvar _ + | Tm_type _ + | Tm_bvar _ + | Tm_fvar _ + | Tm_constant _ + | Tm_lazy _ + | Tm_unknown + | Tm_uinst _ + | Tm_quoted _ -> false + + | Tm_let _ + | Tm_abs _ + | Tm_arrow _ + | Tm_refine _ + | Tm_match _ -> + true + + | Tm_app {hd=t; args} -> + maybe_weakly_reduced t + || (args |> BU.for_some (fun (a, _) -> maybe_weakly_reduced a)) + + | Tm_ascribed {tm=t1; asc} -> + maybe_weakly_reduced t1 + || (let asc_tc, asc_tac, _ = asc in + (match asc_tc with + | Inl t2 -> maybe_weakly_reduced t2 + | Inr c2 -> aux_comp c2) + || + (match asc_tac with + | None -> false + | Some tac -> maybe_weakly_reduced tac)) + + | Tm_meta {tm=t; meta=m} -> + maybe_weakly_reduced t + || (match m with + | Meta_pattern (_, args) -> + BU.for_some (BU.for_some (fun (a, _) -> maybe_weakly_reduced a)) args + + | Meta_monadic_lift(_, _, t') + | Meta_monadic(_, t') -> + maybe_weakly_reduced t' + + | Meta_labeled _ + | Meta_desugared _ + | Meta_named _ -> false) + +let decide_unfolding cfg stack fv qninfo (* : option (option cfg * stack) *) = + let res = + should_unfold cfg (fun cfg -> should_reify cfg stack) fv qninfo + in + match res with + | Should_unfold_no -> + // No unfolding + None + | Should_unfold_yes -> + // Usual unfolding, no change to cfg or stack + Some (None, stack) + | Should_unfold_fully -> + // Unfolding fully, use new cfg with more steps and keep old one in stack + let cfg' = + { cfg with steps = { cfg.steps with + unfold_only = None + ; unfold_fully = None + ; unfold_attr = None + ; unfold_qual = None + ; unfold_namespace = None + ; unfold_until = Some delta_constant } } in + + (* Take care to not change the stack's head if there's a universe + * instantiation, but we do need to keep the old cfg. *) + (* This is ugly, and a recurring problem, but I'm working around it for now *) + Some (Some cfg', stack) + + | Should_unfold_reify -> + // Reifying, adding a reflect on the stack to cancel the reify + // NB: The fv in the Const_reflect is bogus, it'll be ignored anyway + let rec push e s = + match s with + | [] -> [e] + | UnivArgs (us, r) :: t -> UnivArgs (us, r) :: (push e t) + | h :: t -> e :: h :: t + in + let ref = S.mk (Tm_constant (Const_reflect (S.lid_of_fv fv))) + Range.dummyRange in + let stack = push (App (empty_env, ref, None, Range.dummyRange)) stack in + Some (None, stack) + +(* on_domain_lids are constant, so compute them once *) +let on_domain_lids = [ PC.fext_on_domain_lid; PC.fext_on_dom_lid; PC.fext_on_domain_g_lid; PC.fext_on_dom_g_lid ] + +let is_fext_on_domain (t:term) :option term = + let is_on_dom fv = on_domain_lids |> List.existsb (fun l -> S.fv_eq_lid fv l) in + + match (SS.compress t).n with + | Tm_app {hd; args} -> + (match (U.un_uinst hd).n with + | Tm_fvar fv when is_on_dom fv && List.length args = 3 -> //first two are type arguments, third is the function + let f = args |> List.tl |> List.tl |> List.hd |> fst in //get f + Some f + | _ -> None) + | _ -> None + +(* Set below. Used by the simplifier. *) +let __get_n_binders : ref ((env:Env.env) -> list step -> (n:int) -> (t:term) -> list binder & comp) = + BU.mk_ref (fun e s n t -> failwith "Impossible: __get_n_binders unset") + +(* Returns `true` iff the head of `t` is a primop, and +it not applied or only partially applied. *) +let is_partial_primop_app (cfg:Cfg.cfg) (t:term) : bool = + let hd, args = U.head_and_args t in + match (U.un_uinst hd).n with + | Tm_fvar fv -> + begin match find_prim_step cfg fv with + | Some prim_step -> prim_step.arity > List.length args + | None -> false + end + | _ -> false + +let maybe_drop_rc_typ cfg (rc:residual_comp) : residual_comp = + if cfg.steps.for_extraction + then {rc with residual_typ = None} + else rc + +let get_extraction_mode env (m:Ident.lident) = + let norm_m = Env.norm_eff_name env m in + (Env.get_effect_decl env norm_m).extraction_mode + +let can_reify_for_extraction env (m:Ident.lident) = + (get_extraction_mode env m) = S.Extract_reify + +(* Checks if a list of arguments matches some binders exactly *) +let rec args_are_binders args bs : bool = + match args, bs with + | (t, _)::args, b::bs -> + begin match (SS.compress t).n with + | Tm_name bv' -> S.bv_eq b.binder_bv bv' && args_are_binders args bs + | _ -> false + end + | [], [] -> true + | _, _ -> false + +(* Is t a variable applied to exactly bs? If so return it. *) +let is_applied cfg (bs:binders) (t : term) : option bv = + if cfg.debug.wpe then + BU.print2 "WPE> is_applied %s -- %s\n" (show t) (tag_of t); + let hd, args = U.head_and_args_full t in + match (SS.compress hd).n with + | Tm_name bv when args_are_binders args bs -> + if cfg.debug.wpe then + BU.print3 "WPE> got it\n>>>>top = %s\n>>>>b = %s\n>>>>hd = %s\n" + (show t) + (show bv) + (show hd); + Some bv + | _ -> None + +(* As above accounting for squashes *) +let is_applied_maybe_squashed cfg (bs : binders) (t : term) : option bv = + if cfg.debug.wpe then + BU.print2 "WPE> is_applied_maybe_squashed %s -- %s\n" (show t) (tag_of t); + match is_squash t with + | Some (_, t') -> is_applied cfg bs t' + | _ -> begin match is_auto_squash t with + | Some (_, t') -> is_applied cfg bs t' + | _ -> is_applied cfg bs t + end + +let is_quantified_const cfg (bv:bv) (phi : term) : option term = + let open FStarC.Syntax.Formula in + let open FStarC.Class.Monad in + let guard (b:bool) : option unit = if b then Some () else None in + + let phi0 = phi in + let types_match bs = + (* We need to make sure that the forall above is over the same types + as those in the domain of `f`. See bug #3213. *) + let bs_q, _ = !__get_n_binders cfg.tcenv [AllowUnboundUniverses] (List.length bs) bv.sort in + let rec unrefine_true (t:term) : term = + (* Discard trivial refinements. *) + match (SS.compress t).n with + | Tm_refine {b; phi} when U.term_eq phi U.t_true -> unrefine_true b.sort + | _ -> t + in + List.length bs = List.length bs_q && + List.forall2 (fun b1 b2 -> + let s1 = b1.binder_bv.sort |> unrefine_true in + let s2 = b2.binder_bv.sort |> unrefine_true in + U.term_eq s1 s2) + bs bs_q + in + let is_bv (bv:S.bv) (t:term) = + match (SS.compress t).n with + | Tm_name bv' -> S.bv_eq bv bv' + | _ -> false + in + let replace_full_applications_with (bv:S.bv) (arity:int) (s:term) (t:term) : term & bool = + let chgd = BU.mk_ref false in + let t' = t |> Syntax.Visit.visit_term false (fun t -> + let hd, args = U.head_and_args t in + if List.length args = arity && is_bv bv hd then ( + chgd := true; + s + ) else + t) + in + t', !chgd + in + let! form = destruct_typ_as_formula phi in + match form with + | BaseConn (lid, [(p, _); (q, _)]) when Ident.lid_equals lid PC.imp_lid -> + if cfg.debug.wpe then + BU.print2 "WPE> p = (%s); q = (%s)\n" + (show p) + (show q); + let! q' = + begin match destruct_typ_as_formula p with + (* Case 1 *) + | None -> begin match (SS.compress p).n with + | Tm_bvar bv' when S.bv_eq bv bv' -> + if cfg.debug.wpe then + BU.print_string "WPE> Case 1\n"; + let q' = SS.subst [NT (bv, U.t_true)] q in + Some q' + | _ -> None + end + (* Case 2 *) + | Some (BaseConn (lid, [(p, _)])) when Ident.lid_equals lid PC.not_lid -> + begin match (SS.compress p).n with + | Tm_bvar bv' when S.bv_eq bv bv' -> + if cfg.debug.wpe then + BU.print_string "WPE> Case 2\n"; + let q' = SS.subst [NT (bv, U.t_false)] q in + Some q' + | _ -> None + end + | Some (QAll (bs, pats, phi)) when types_match bs -> + begin match destruct_typ_as_formula phi with + | None -> + let! bv' = is_applied_maybe_squashed cfg bs phi in + guard (S.bv_eq bv bv');! + (* Case 3 *) + if cfg.debug.wpe then + BU.print_string "WPE> Case 3\n"; + let q', chgd = replace_full_applications_with bv (List.length bs) U.t_true q in + guard chgd;! (* If nothing triggered, do not rewrite to itself to avoid infinite loops *) + Some q' + | Some (BaseConn (lid, [(p, _)])) when Ident.lid_equals lid PC.not_lid -> + let! bv' = is_applied_maybe_squashed cfg bs p in + guard (S.bv_eq bv bv');! + if cfg.debug.wpe then + BU.print_string "WPE> Case 4\n"; + let q', chgd = replace_full_applications_with bv (List.length bs) U.t_false q in + guard chgd;! + Some q' + | _ -> + None + end + | _ -> None + end + in + let phi' = U.mk_app (S.fvar PC.imp_lid None) [S.as_arg p; S.as_arg q'] in + Some phi' + | _ -> None + +// A very F*-specific optimization: +// 1) forall f. (f ==> E[f]) ~> E[True] +// 2) forall f. (~f ==> E[f]) ~> E[False] +// +// 3) forall f. (forall j1 ... jn. f j1 ... jn) ==> E +// ~> forall f. (forall j1 ... jn. f j1 ... jn) ==> E', where every full application of `f` to `n` binders is rewritten to true +// +// 4) forall f. (forall j1 ... jn. ~(f j1 ... jn)) ==> E +// ~> forall f. (forall j1 ... jn. ~(f j1 ... jn)) ==> E', idem rewriting to false +// reurns the rewritten formula. +let is_forall_const cfg (phi : term) : option term = + let open FStarC.Syntax.Formula in + match Syntax.Formula.destruct_typ_as_formula phi with + | Some (QAll ([b], _, phi')) -> + let open FStarC.Class.Monad in + if cfg.debug.wpe then + BU.print2 "WPE> QAll [%s] %s\n" (show b.binder_bv) (show phi'); + let! phi' = is_quantified_const cfg b.binder_bv phi' in + Some (U.mk_forall (cfg.tcenv.universe_of cfg.tcenv b.binder_bv.sort) b.binder_bv phi') + + | _ -> None + +let is_extract_as_attr (attr: attribute) : option term = + let head, args = head_and_args attr in + match (Subst.compress head).n, args with + | Tm_fvar fv, [t, _] when Syntax.fv_eq_lid fv PC.extract_as_lid -> + (match (Subst.compress t).n with + | Tm_quoted(impl, _) -> Some impl + | _ -> None) + | _ -> None + +let has_extract_as_attr (g: Env.env) (lid: I.lid) : option term = + match Env.lookup_attrs_of_lid g lid with + | Some attrs -> find_map attrs is_extract_as_attr + | None -> None + +(* GM: Please consider this function private outside of this recursive + * group, and call `normalize` instead. `normalize` will print timing + * information when --debug NormTop is given, which makes it a + * whole lot easier to find normalization calls that are taking a long + * time. *) +let rec norm : cfg -> env -> stack -> term -> term = + fun cfg env stack t -> + let rec collapse_metas st = + match st with + (* Keep only the outermost Meta_monadic *) + | Meta (_, Meta_monadic _, _) :: Meta(e, Meta_monadic m, r) :: st' -> + collapse_metas (Meta (e, Meta_monadic m, r) :: st') + | _ -> st + in + let stack = collapse_metas stack in + let t = + if cfg.debug.norm_delayed + then (match t.n with + | Tm_delayed _ -> + BU.print1 "NORM delayed: %s\n" (show t) + | _ -> ()); + compress t + in + log cfg (fun () -> + BU.print5 ">>> %s (no_full_norm=%s)\nNorm %s with %s env elements; top of the stack = %s\n" + (tag_of t) + (show cfg.steps.no_full_norm) + (show t) + (show (List.length env)) + (show (fst <| firstn 4 stack))); + log_cfg cfg (fun () -> BU.print1 ">>> cfg = %s\n" (show cfg)); + match t.n with + // Values + | Tm_unknown + | Tm_constant _ + | Tm_name _ + | Tm_lazy _ -> + rebuild cfg empty_env stack t + + // These three are just constructors; no delta steps can apply. + // Note: we drop the environment, no free indices here + | Tm_fvar({ fv_qual = Some Data_ctor }) + | Tm_fvar({ fv_qual = Some (Record_ctor _) }) -> + log_unfolding cfg (fun () -> BU.print1 " >> This is a constructor: %s\n" (show t)); + rebuild cfg empty_env stack t + + // A top-level name, possibly unfold it. + // In either case, also drop the environment, no free indices here. + | Tm_fvar fv -> + let lid = S.lid_of_fv fv in + let qninfo = Env.lookup_qname cfg.tcenv lid in + begin + match Env.delta_depth_of_qninfo cfg.tcenv fv qninfo with + | Delta_constant_at_level 0 -> + log_unfolding cfg (fun () -> BU.print1 " >> This is a constant: %s\n" (show t)); + rebuild cfg empty_env stack t + | _ -> + match decide_unfolding cfg stack fv qninfo with + | Some (None, stack) -> do_unfold_fv cfg stack t qninfo fv + | Some (Some cfg, stack) -> + do_unfold_fv cfg [] t qninfo fv |> rebuild cfg empty_env stack + | None -> rebuild cfg empty_env stack t + end + + | Tm_quoted (qt, qi) -> + let qi = S.on_antiquoted (norm cfg env []) qi in + let t = mk (Tm_quoted (qt, qi)) t.pos in + rebuild cfg env stack (closure_as_term cfg env t) + + | Tm_app {hd; args} + when should_consider_norm_requests cfg && + is_norm_request hd args = Norm_request_requires_rejig -> + if cfg.debug.print_normalized + then BU.print_string "Rejigging norm request ... \n"; + norm cfg env stack (rejig_norm_request hd args) + + | Tm_app {hd; args} + when should_consider_norm_requests cfg && + is_norm_request hd args = Norm_request_ready -> + if cfg.debug.print_normalized + then BU.print2 "Potential norm request with hd = %s and args = %s ... \n" + (show hd) (Print.args_to_string args); + + let cfg' = { cfg with steps = { cfg.steps with unfold_only = None + ; unfold_fully = None + ; do_not_unfold_pure_lets = false }; + delta_level=[Unfold delta_constant]; + normalize_pure_lets=true} in + begin + match get_norm_request cfg (norm cfg' env []) args with + | None -> //just normalize it as a normal application + if cfg.debug.print_normalized + then BU.print_string "Norm request None ... \n"; + let stack = + stack |> + List.fold_right + (fun (a, aq) stack -> Arg (Clos(env, a, fresh_memo (), false),aq,t.pos)::stack) + args + in + log cfg (fun () -> BU.print1 "\tPushed %s arguments\n" (string_of_int <| List.length args)); + norm cfg env stack hd + + | Some (s, tm) when is_nbe_request s -> + let tm' = closure_as_term cfg env tm in + let start = BU.now() in + let tm_norm = nbe_eval cfg s tm' in + let fin = BU.now () in + if cfg.debug.print_normalized + then begin + let cfg' = Cfg.config s cfg.tcenv in + // BU.print1 "NBE result timing (%s ms)\n" + // (show (snd (BU.time_diff start fin))) + BU.print4 "NBE result timing (%s ms){\nOn term {\n%s\n}\nwith steps {%s}\nresult is{\n\n%s\n}\n}\n" + (show (snd (BU.time_diff start fin))) + (show tm') + (show cfg') + (show tm_norm) + end; + rebuild cfg env stack tm_norm + + | Some (s, tm) -> + let open FStarC.Errors.Msg in + let open FStarC.Pprint in + if cfg.debug.print_normalized then + Errors.diag tm.pos [ + text <| BU.format1 "Starting norm request on `%s`." (show tm); + text "Steps =" ^/^ text (show s); + ]; + let delta_level = + if s |> BU.for_some (function UnfoldUntil _ | UnfoldOnly _ | UnfoldFully _ -> true | _ -> false) + then [Unfold delta_constant] + else if cfg.steps.for_extraction + then [Env.Eager_unfolding_only; Env.InliningDelta] + else [NoDelta] + in + let cfg' = {cfg with steps = ({ to_fsteps s + with in_full_norm_request=true; + for_extraction=cfg.steps.for_extraction}) + ; delta_level = delta_level + ; normalize_pure_lets = true } in + (* We reduce the term in an empty stack to prevent unwanted interactions. + Later, we rebuild the normalized term with the current stack. This is + not a tail-call, but this happens rarely enough that it should not be a problem. *) + let t0 = BU.now () in + let (tm_normed, ms) = BU.record_time (fun () -> norm cfg' env [] tm) in + maybe_debug cfg tm_normed (Some (tm, t0)); + rebuild cfg env stack tm_normed + end + + | Tm_type u -> + let u = norm_universe cfg env u in + rebuild cfg env stack (mk (Tm_type u) t.pos) + + | Tm_uinst(t', us) -> + if cfg.steps.erase_universes + then norm cfg env stack t' + else let us = UnivArgs(List.map (norm_universe cfg env) us, t.pos) in + let stack = us::stack in + norm cfg env stack t' + + | Tm_bvar x -> + begin match lookup_bvar env x with + | Univ _ -> failwith "Impossible: term variable is bound to a universe" + | Dummy -> failwith "Term variable not found" + | Clos(env, t0, r, fix) -> + if not fix + || cfg.steps.zeta + || cfg.steps.zeta_full + then match read_memo cfg r with + | Some (env, t') -> + log cfg (fun () -> BU.print2 "Lazy hit: %s cached to %s\n" (show t) (show t')); + if maybe_weakly_reduced t' + then match stack with + | [] when cfg.steps.weak || cfg.steps.compress_uvars -> + rebuild cfg env stack t' + | _ -> norm cfg env stack t' + else rebuild cfg env stack t' + | None -> norm cfg env (MemoLazy r::stack) t0 + else norm cfg env stack t0 //Fixpoint steps are excluded; so don't take the recursive knot + end + + | Tm_abs {bs; body; rc_opt=rc_opt} -> + // + //AR/NS: 04/26/2022: + // In the case of metaprograms, we reduce DIV computations in the + // normalizer. As a result, it could be that an abs node is + // wrapped in a Meta_monadic (lift or just DIV) + // The following code ensures that such meta wrappers do not + // block reduction + // Specifically, if the stack looks like (from top): + // [Meta; Meta; ..; Meta; Arg; ...] + // Then we remove the meta nodes so that the following argument + // can be applied to the lambda + // We only remove DIV and PURE ~> DIV lifts + // + + // + // Precondition for calling: top of stack should be a Meta + // + // Returns Some st, when st is some meta nodes stripped off from stack + // None, when the stack does not have the shape noted above + // + let rec maybe_strip_meta_divs stack = + let open FStarC.Ident in + match stack with + | [] -> None + | Meta (_, Meta_monadic (m, _), _)::tl + when lid_equals m PC.effect_DIV_lid -> + maybe_strip_meta_divs tl + | Meta (_, Meta_monadic_lift (src, tgt, _), _)::tl + when lid_equals src PC.effect_PURE_lid && + lid_equals tgt PC.effect_DIV_lid -> + maybe_strip_meta_divs tl + | Arg _::_ -> Some stack //due to the precondition, this case doesn't arise in the top-level call + | _ -> None + in + + // + // Reducing lambda body if strong reduction, + // rebuild otherwise + // + let fallback () = + if cfg.steps.weak + then let t = closure_as_term cfg env t in + rebuild cfg env stack t + else let bs, body, opening = open_term' bs body in + let env' = bs |> List.fold_left (fun env _ -> dummy () ::env) env in + let rc_opt = + let open FStarC.Class.Monad in + let! rc = rc_opt in + let rc = maybe_drop_rc_typ cfg rc in + Some {rc with residual_typ = BU.map_option (SS.subst opening) rc.residual_typ} + in + log cfg (fun () -> BU.print1 "\tShifted %s dummies\n" (string_of_int <| List.length bs)); + let cfg' = { cfg with strong = true } in + let body_norm = norm cfg env' (Abs(env, bs, env', rc_opt, t.pos) :: []) body in + rebuild cfg env stack body_norm + in + begin match stack with + | UnivArgs _::_ -> + failwith "Ill-typed term: universes cannot be applied to term abstraction" + + | Arg (Univ u, _, _)::stack_rest -> + norm cfg ((None, Univ u, fresh_memo ()) :: env) stack_rest t + // universe variables do not have explicit binders + + | Arg (c, _, _)::stack_rest -> + (* Note: we peel off one application at a time. + An optimization to attempt would be to push n-args are once, + and try to pop all of them at once, in the common case of a full application. + *) + begin match bs with + | [] -> failwith "Impossible" + | [b] -> + log cfg (fun () -> BU.print1 "\tShifted %s\n" (show c)); + norm cfg ((Some b, c, fresh_memo()) :: env) stack_rest body + | b::tl -> + log cfg (fun () -> BU.print1 "\tShifted %s\n" (show c)); + let body = mk (Tm_abs {bs=tl; body; rc_opt}) t.pos in + norm cfg ((Some b, c, fresh_memo()) :: env) stack_rest body + end + + | MemoLazy r :: stack -> + set_memo cfg r (env, t); //We intentionally do not memoize the strong normal form; only the WHNF + log cfg (fun () -> BU.print1 "\tSet memo %s\n" (show t)); + norm cfg env stack t + + | Meta _::_ -> + // + //Top of the stack is a meta, try stripping meta DIV nodes that + // may be blocking reduction + // + (match maybe_strip_meta_divs stack with + | None -> fallback () + | Some stack -> norm cfg env stack t) + | Match _::_ + | Let _ :: _ + | App _ :: _ + | CBVApp _ :: _ + | Abs _ :: _ + | [] -> + fallback () + end + + | Tm_app {hd=head; args} -> + let strict_args = + match (head |> U.unascribe |> U.un_uinst).n with + | Tm_fvar fv -> Env.fv_has_strict_args cfg.tcenv fv + | _ -> None + in + begin + match strict_args with + | None -> + let stack = + List.fold_right + (fun (a, aq) stack -> + let a = + if ((Cfg.cfg_env cfg).erase_erasable_args || + cfg.steps.for_extraction || + cfg.debug.erase_erasable_args) //just for experimentation + && U.aqual_is_erasable aq //If we're extracting, then erase erasable arguments eagerly + then U.exp_unit + else a + in + // !! Optimization: if the argument we are pushing is an obvious + // value/closed term, then drop the environment. This can save + // a ton of memory, particularly when running tactics in tight loop. + let env = + match (Subst.compress a).n with + | Tm_name _ + | Tm_constant _ + | Tm_lazy _ + | Tm_fvar _ -> empty_env + | _ -> env + in + Arg (Clos(env, a, fresh_memo (), false),aq,t.pos)::stack) + args + stack + in + log cfg (fun () -> BU.print1 "\tPushed %s arguments\n" (string_of_int <| List.length args)); + norm cfg env stack head + + | Some strict_args -> + // BU.print2 "%s has strict args %s\n" (show head) (show strict_args); + let norm_args = args |> List.map (fun (a, i) -> (norm cfg env [] a, i)) in + let norm_args_len = List.length norm_args in + if strict_args + |> List.for_all (fun i -> + if i >= norm_args_len then false + else + let arg_i, _ = List.nth norm_args i in + let head, _ = arg_i |> U.unmeta_safe |> U.head_and_args in + match (un_uinst head).n with + | Tm_constant _ -> true + | Tm_fvar fv -> Env.is_datacon cfg.tcenv (S.lid_of_fv fv) + | _ -> false) + then //all strict args have constant head symbols + let stack = + stack |> + List.fold_right (fun (a, aq) stack -> + Arg (Clos(env, a, BU.mk_ref (Some (cfg, ([], a))), false),aq,t.pos)::stack) + norm_args + in + log cfg (fun () -> BU.print1 "\tPushed %s arguments\n" (string_of_int <| List.length args)); + norm cfg env stack head + else let head = closure_as_term cfg env head in + let term = S.mk_Tm_app head norm_args t.pos in + // let _ = + // BU.print3 "Rebuilding %s as %s\n%s\n" + // (show t) + // (show term) + // (BU.stack_dump()) + // in + rebuild cfg env stack term + end + + | Tm_refine {b=x} + when cfg.steps.for_extraction + || cfg.steps.unrefine -> + norm cfg env stack x.sort + + | Tm_refine {b=x; phi=f} -> //non tail-recursive; the alternative is to keep marks on the stack to rebuild the term ... but that's very heavy + if cfg.steps.weak + then match env, stack with + | [], [] -> //TODO: Make this work in general! + let t_x = norm cfg env [] x.sort in + let t = mk (Tm_refine {b={x with sort=t_x}; phi=f}) t.pos in + rebuild cfg env stack t + | _ -> rebuild cfg env stack (closure_as_term cfg env t) + else let t_x = norm cfg env [] x.sort in + let closing, f = open_term [mk_binder x] f in + let f = norm cfg (dummy () ::env) [] f in + let t = mk (Tm_refine {b={x with sort=t_x}; phi=close closing f}) t.pos in + rebuild cfg env stack t + + | Tm_arrow {bs; comp=c} -> + if cfg.steps.weak + then rebuild cfg env stack (closure_as_term cfg env t) + else let bs, c = open_comp bs c in + let c = norm_comp cfg (bs |> List.fold_left (fun env _ -> dummy () ::env) env) c in + let close_binders env (bs:binders) : binders = + SS.subst_binders (env_subst env) bs + in + let bs = if cfg.steps.hnf then close_binders env bs else norm_binders cfg env bs in + let t = arrow bs c in + rebuild cfg env stack t + + | Tm_ascribed {tm=t1; eff_opt=l} when cfg.steps.unascribe -> + norm cfg env stack t1 + + | Tm_ascribed {tm=t1; asc; eff_opt=l} -> + let rec stack_may_reduce s = + (* Decides if the ascription would block a reduction that would + otherwise happen. For instance if the stack begins with Arg it's + possible that t1 reduces to a lambda, so we should beta reduce. + Q: This may be better done in the rebuild phase, once we know the normal + form of t1? *) + match s with + | Match _ :: _ + | Arg _ :: _ + | App (_, {n=Tm_constant (FC.Const_reify _)}, _, _) :: _ + | MemoLazy _ :: _ when cfg.steps.beta -> + true + | _ -> + false + in + if stack_may_reduce stack then ( + log cfg (fun () -> BU.print_string "+++ Dropping ascription \n"); + norm cfg env stack t1 // Ascriptions should not block reduction + ) else ( + (* Drops stack *) + log cfg (fun () -> BU.print_string "+++ Keeping ascription \n"); + let t1 = norm cfg env [] t1 in + log cfg (fun () -> BU.print_string "+++ Normalizing ascription \n"); + let asc = norm_ascription cfg env asc in + rebuild cfg env stack (mk (Tm_ascribed {tm=U.unascribe t1; asc; eff_opt=l}) t.pos) + ) + + | Tm_match {scrutinee=head; ret_opt=asc_opt; brs=branches; rc_opt=lopt} -> + let lopt = BU.map_option (maybe_drop_rc_typ cfg) lopt in + let stack = Match(env, asc_opt, branches, lopt, cfg, t.pos)::stack in + if cfg.steps.iota + && cfg.steps.weakly_reduce_scrutinee + && not cfg.steps.weak + then let cfg' = { cfg with steps= { cfg.steps with weak = true } } in + let head_norm = norm cfg' env [] head in + rebuild cfg env stack head_norm + else norm cfg env stack head + + | Tm_let {lbs=(b, lbs); body=lbody} when is_top_level lbs && cfg.steps.compress_uvars -> + let lbs = lbs |> List.map (fun lb -> + let openings, lbunivs = Subst.univ_var_opening lb.lbunivs in + let cfg = { cfg with tcenv = Env.push_univ_vars cfg.tcenv lbunivs } in + let norm t = Subst.close_univ_vars lbunivs (norm cfg env [] (Subst.subst openings t)) in + let lbtyp = norm lb.lbtyp in + let lbdef = norm lb.lbdef in + { lb with lbunivs = lbunivs; lbtyp = lbtyp; lbdef = lbdef } + ) in + + rebuild cfg env stack (mk (Tm_let {lbs=(b, lbs); body=lbody}) t.pos) + + | Tm_let {lbs=(_, {lbname=Inr _}::_)} -> //this is a top-level let binding; nothing to normalize + rebuild cfg env stack t + + | Tm_let {lbs=(false, [lb]); body} -> + if Cfg.should_reduce_local_let cfg lb + then let binder = S.mk_binder (BU.left lb.lbname) in + (* If this let is effectful, and marked with @inline_let + * (and it passed the typechecker), then its definition + * must be pure. But, it will be lifted into an effectful + * computation. We need to remove it to maintain a proper + * term structure. See the discussion in PR #2024. *) + let def = U.unmeta_lift lb.lbdef in + let env = (Some binder, Clos(env, def, fresh_memo(), false), fresh_memo ())::env in + log cfg (fun () -> BU.print_string "+++ Reducing Tm_let\n"); + norm cfg env stack body + + (* If we are reifying, we reduce Div lets faithfully, i.e. in CBV *) + (* This is important for tactics, see issue #1594 *) + else if cfg.steps.tactics + && U.is_div_effect (Env.norm_eff_name cfg.tcenv lb.lbeff) + then let ffun = S.mk (Tm_abs {bs=[S.mk_binder (lb.lbname |> BU.left)]; body; rc_opt=None}) t.pos in + let stack = (CBVApp (env, ffun, None, t.pos)) :: stack in + log cfg (fun () -> BU.print_string "+++ Evaluating DIV Tm_let\n"); + norm cfg env stack lb.lbdef + + else if cfg.steps.weak + then (log cfg (fun () -> BU.print_string "+++ Not touching Tm_let\n"); + rebuild cfg env stack (closure_as_term cfg env t)) + + else let bs, body = Subst.open_term [lb.lbname |> BU.left |> S.mk_binder] body in + log cfg (fun () -> BU.print_string "+++ Normalizing Tm_let -- type"); + let ty = norm cfg env [] lb.lbtyp in + let lbname = + let x = (List.hd bs).binder_bv in + Inl ({x with sort=ty}) in + log cfg (fun () -> BU.print_string "+++ Normalizing Tm_let -- definiens\n"); + let lb = {lb with lbname=lbname; + lbtyp=ty; + lbdef=norm cfg env [] lb.lbdef; + lbattrs=List.map (norm cfg env []) lb.lbattrs} in + let env' = bs |> List.fold_left (fun env _ -> dummy () ::env) env in + log cfg (fun () -> BU.print_string "+++ Normalizing Tm_let -- body\n"); + let cfg' = { cfg with strong = true } in + let body_norm = norm cfg' env' (Let (env, bs, lb, t.pos) :: []) body in + rebuild cfg env stack body_norm + + | Tm_let {lbs=(true, lbs); body} + when cfg.steps.compress_uvars + || (not cfg.steps.zeta && + not cfg.steps.zeta_full && + cfg.steps.pure_subterms_within_computations) -> //no fixpoint reduction allowed + let lbs, body = Subst.open_let_rec lbs body in + let lbs = List.map (fun lb -> + let ty = norm cfg env [] lb.lbtyp in + let lbname = Inl ({BU.left lb.lbname with sort=ty}) in + let xs, def_body, lopt = U.abs_formals lb.lbdef in + let xs = norm_binders cfg env xs in + let env = List.map (fun _ -> dummy ()) xs //first the bound vars for the arguments + @ List.map (fun _ -> dummy ()) lbs //then the recursively bound names + @ env in + let def_body = norm cfg env [] def_body in + let lopt = + match lopt with + | Some rc -> Some ({rc with residual_typ=BU.map_opt rc.residual_typ (norm cfg env [])}) + | _ -> lopt in + let def = U.abs xs def_body lopt in + { lb with lbname = lbname; + lbtyp = ty; + lbdef = def}) lbs in + let env' = List.map (fun _ -> dummy ()) lbs @ env in + let body = norm cfg env' [] body in + let lbs, body = Subst.close_let_rec lbs body in + let t = {t with n=Tm_let {lbs=(true, lbs); body}} in + rebuild cfg env stack t + + | Tm_let {lbs; body} when not cfg.steps.zeta && not cfg.steps.zeta_full -> //no fixpoint reduction allowed + rebuild cfg env stack (closure_as_term cfg env t) + + | Tm_let {lbs; body} -> + //let rec: The basic idea is to reduce the body in an environment that includes recursive bindings for the lbs + //Consider reducing (let rec f x = f x in f 0) in initial environment env + //We build two environments, rec_env and body_env and reduce (f 0) in body_env + //rec_env = Clos(env, let rec f x = f x in f, memo)::env + //body_env = Clos(rec_env, \x. f x, _)::env + //i.e., in body, the bound variable is bound to definition, \x. f x + //Within the definition \x.f x, f is bound to the recursive binding (let rec f x = f x in f), aka, fix f. \x. f x + //Finally, we add one optimization for laziness by tying a knot in rec_env + //i.e., we set memo := Some (rec_env, \x. f x) + + let rec_env, memos, _ = List.fold_right (fun lb (rec_env, memos, i) -> + let bv = {left lb.lbname with index=i} in + let f_i = Syntax.bv_to_tm bv in + let fix_f_i = mk (Tm_let {lbs; body=f_i}) t.pos in + let memo = fresh_memo () in + let rec_env = (None, Clos(env, fix_f_i, memo, true), fresh_memo ())::rec_env in + rec_env, memo::memos, i + 1) (snd lbs) (env, [], 0) in + let _ = List.map2 (fun lb memo -> memo := Some (cfg, (rec_env, lb.lbdef))) (snd lbs) memos in //tying the knot + // NB: fold_left, since the binding structure of lbs is that righmost is closer, while in the env leftmost + // is closer. In other words, the last element of lbs is index 0 for body, hence needs to be pushed last. + let body_env = List.fold_left (fun env lb -> (None, Clos(rec_env, lb.lbdef, fresh_memo(), false), fresh_memo())::env) + env (snd lbs) in + log cfg (fun () -> BU.print1 "reducing with knot %s\n" ""); + norm cfg body_env stack body + + | Tm_meta {tm=head; meta=m} -> + log cfg (fun () -> BU.print1 ">> metadata = %s\n" (show m)); + begin match m with + | Meta_monadic (m_from, ty) -> + if cfg.steps.for_extraction + then ( + //In Extraction, we want to erase sub-terms with erasable effect + //Or pure terms with non-informative return types + if Env.is_erasable_effect cfg.tcenv m_from + || (U.is_pure_effect m_from && Env.non_informative cfg.tcenv ty) + then ( + rebuild cfg env stack (S.mk (Tm_meta {tm=U.exp_unit; meta=m}) t.pos) + ) + else ( + reduce_impure_comp cfg env stack head (Inl m_from) ty + ) + ) + else + reduce_impure_comp cfg env stack head (Inl m_from) ty + + | Meta_monadic_lift (m_from, m_to, ty) -> + if cfg.steps.for_extraction + then ( + //In Extraction, we want to erase sub-terms with erasable effect + //Or pure terms with non-informative return types + if Env.is_erasable_effect cfg.tcenv m_from + || Env.is_erasable_effect cfg.tcenv m_to + || (U.is_pure_effect m_from && Env.non_informative cfg.tcenv ty) + then ( + rebuild cfg env stack (S.mk (Tm_meta {tm=U.exp_unit; meta=m}) t.pos) + ) + else ( + reduce_impure_comp cfg env stack head (Inr (m_from, m_to)) ty + ) + ) + else reduce_impure_comp cfg env stack head (Inr (m_from, m_to)) ty + + | _ -> + if cfg.steps.unmeta + then norm cfg env stack head + else begin match stack with + | _::_ -> + begin match m with + | Meta_labeled(l, r, _) -> + (* meta doesn't block reduction, but we need to put the label back *) + norm cfg env (Meta(env,m,r)::stack) head + + | Meta_pattern (names, args) -> + let args = norm_pattern_args cfg env args in + let names = names |> List.map (norm cfg env []) in + norm cfg env (Meta(env, Meta_pattern(names, args), t.pos)::stack) head + //meta doesn't block reduction, but we need to put the label back + + (* Try to retain Sequence nodes when not normalizing letbindings. *) + | Meta_desugared Sequence when cfg.steps.do_not_unfold_pure_lets -> + norm cfg env (Meta(env,m,t.pos)::stack) head + + | Meta_desugared (Machine_integer (_,_)) -> + (* meta doesn't block reduction, + but we need to put the label back *) + norm cfg env (Meta(env,m,t.pos)::stack) head + + | _ -> + norm cfg env stack head //meta doesn't block reduction + end + | [] -> + let head = norm cfg env [] head in + let m = match m with + | Meta_pattern (names, args) -> + let names = names |> List.map (norm cfg env []) in + Meta_pattern (names, norm_pattern_args cfg env args) + | _ -> m in + let t = mk (Tm_meta {tm=head; meta=m}) t.pos in + rebuild cfg env stack t + end + end //Tm_meta + + | Tm_delayed _ -> + failwith "impossible: Tm_delayed on norm" + + | Tm_uvar _ -> + if cfg.steps.check_no_uvars then + failwith (BU.format2 "(%s) CheckNoUvars: Unexpected unification variable remains: %s" + (show t.pos) (show t)); + let t = Errors.with_ctx "inlining" (fun () -> closure_as_term cfg env t) in + rebuild cfg env stack t + +(* NOTE: we do not need any environment here, since an fv does not + * have any free indices. Hence, we use empty_env as environment when needed. *) +and do_unfold_fv (cfg:Cfg.cfg) stack (t0:term) (qninfo : qninfo) (f:fv) : term = + // Second, try to unfold to the definition itself. + let defn () = Env.lookup_definition_qninfo cfg.delta_level f.fv_name.v qninfo in + // First, try to unfold to the implementation specified in the extract_as attribute (when doing extraction) + let defn () = + if cfg.steps.for_extraction then + match qninfo with + | Some (Inr (se, None), _) when Env.visible_with cfg.delta_level se.sigquals -> + (match find_map se.sigattrs is_extract_as_attr with + | Some impl -> Some ([], impl) + | None -> defn ()) + | _ -> defn () + else + defn () in + match defn () with + | None -> + log_unfolding cfg (fun () -> + BU.print2 " >> No definition found for %s (delta_level = %s)\n" + (show f) (show cfg.delta_level)); + rebuild cfg empty_env stack t0 + + | Some (us, t) -> + begin + log_unfolding cfg (fun () -> BU.print2 " >> Unfolded %s to %s\n" (show t0) (show t)); + // preserve the range info on the returned term + let t = + if cfg.steps.unfold_until = Some delta_constant + //we're really trying to compute here; no point propagating range information + //which can be expensive + then t + else Subst.set_use_range t0.pos t + in + let n = List.length us in + if n > 0 + then match stack with //universe beta reduction + | UnivArgs(us', _)::stack -> + if !dbg_univ_norm then + List.iter (fun x -> BU.print1 "Univ (normalizer) %s\n" (show x)) us' + else (); + let env = us' |> List.fold_left (fun env u -> (None, Univ u, fresh_memo ())::env) empty_env in + norm cfg env stack t + | _ when cfg.steps.erase_universes || cfg.steps.allow_unbound_universes -> + norm cfg empty_env stack t + | _ -> failwith (BU.format1 "Impossible: missing universe instantiation on %s" (show f.fv_name.v)) + else norm cfg empty_env stack t + end + +and reduce_impure_comp cfg env stack (head : term) // monadic term + (m : either monad_name (monad_name & monad_name)) + // relevant monads. + // Inl m - this is a Meta_monadic with monad m + // Inr (m, m') - this is a Meta_monadic_lift with monad m + (t : typ) // annotated type in the Meta + : term = + (* We have an impure computation, and we aim to perform any pure *) + (* steps within that computation. *) + + (* This scenario arises primarily as we extract (impure) programs and *) + (* partially evaluate them before extraction, as an optimization. *) + + (* First, we reduce **the type annotation** t with an empty stack (as *) + (* it's not applied to anything) *) + + (* Then, we reduce the monadic computation `head`, in a stack marked *) + (* with a Meta_monadic, indicating that this reduction should *) + (* not consume any arguments on the stack. `rebuild` will notice *) + (* the Meta_monadic marker and reconstruct the computation after *) + (* normalization. *) + let t = norm cfg env [] t in + (* monadic annotations don't block reduction, but we need to put the label back *) + let metadata = match m with + | Inl m -> Meta_monadic (m, t) + | Inr (m, m') -> Meta_monadic_lift (m, m', t) + in + norm cfg env (Meta(env,metadata, head.pos)::stack) head + +and do_reify_monadic fallback cfg env stack (top : term) (m : monad_name) (t : typ) : term = + (* Precondition: the stack head is an App (reify, ...) *) + begin match stack with + | App (_, {n=Tm_constant (FC.Const_reify _)}, _, _) :: _ -> () + | _ -> failwith (BU.format1 "INTERNAL ERROR: do_reify_monadic: bad stack: %s" (show stack)) + end; + let top0 = top in + let top = U.unascribe top in + log cfg (fun () -> BU.print2 "Reifying: (%s) %s\n" (tag_of top) (show top)); + let top = U.unmeta_safe top in + match (SS.compress top).n with + | Tm_let {lbs=(false, [lb]); body} -> + (* ****************************************************************************) + (* Monadic binding *) + (* *) + (* This is reify (M.bind e1 (fun x -> e2)) which is elaborated to *) + (* *) + (* M.bind_repr (reify e1) (fun x -> reify e2) *) + (* *) + (* ****************************************************************************) + let eff_name = Env.norm_eff_name cfg.tcenv m in + let ed = Env.get_effect_decl cfg.tcenv eff_name in + let _, repr = ed |> U.get_eff_repr |> must in + let _, bind_repr = ed |> U.get_bind_repr |> must in + begin match lb.lbname with + | Inr _ -> failwith "Cannot reify a top-level let binding" + | Inl x -> + + (* [is_return e] returns [Some e'] if [e] is a lift from Pure of [e'], [None] otherwise *) + let is_return e = + match (SS.compress e).n with + | Tm_meta {tm=e; meta=Meta_monadic(_, _)} -> + begin match (SS.compress e).n with + | Tm_meta {tm=e; meta=Meta_monadic_lift(_, msrc, _)} when U.is_pure_effect msrc -> + Some (SS.compress e) + | _ -> None + end + | _ -> None + in + + match is_return lb.lbdef with + (* We are in the case where [top] = [bind (return e) (fun x -> body)] *) + (* which can be optimised to a non-monadic let-binding [let x = e in body] *) + | Some e -> + let lb = {lb with lbeff=PC.effect_PURE_lid; lbdef=e} in + norm cfg env (List.tl stack) (S.mk (Tm_let {lbs=(false, [lb]); body=U.mk_reify body (Some m)}) top.pos) + | None -> + if (match is_return body with Some ({n=Tm_bvar y}) -> S.bv_eq x y | _ -> false) + then + (* We are in the case where [top] = [bind e (fun x -> return x)] *) + (* which can be optimised to just keeping normalizing [e] with a reify on the stack *) + norm cfg env stack lb.lbdef + else ( + (* TODO : optimize [bind (bind e1 e2) e3] into [bind e1 (bind e2 e3)] *) + (* Rewriting binds in that direction would be better for exception-like monad *) + (* since we wouldn't rematch on an already raised exception *) + let rng = top.pos in + + let head = U.mk_reify lb.lbdef (Some m) in + + let body = U.mk_reify body (Some m) in + (* TODO : Check that there is no sensible cflags to pass in the residual_comp *) + let body_rc = { + residual_effect=m; + residual_flags=[]; + residual_typ=Some t + } in + let body = S.mk (Tm_abs {bs=[S.mk_binder x]; body; rc_opt=Some body_rc}) body.pos in + + //the bind term for the effect + let close = closure_as_term cfg env in + let bind_inst = match (SS.compress bind_repr).n with + | Tm_uinst (bind, [_ ; _]) -> + S.mk (Tm_uinst (bind, [ cfg.tcenv.universe_of cfg.tcenv (close lb.lbtyp) + ; cfg.tcenv.universe_of cfg.tcenv (close t)])) + rng + | _ -> failwith "NIY : Reification of indexed effects" in + + //arguments to the bind term, f_arg is the argument for first computation f + let bind_inst_args f_arg = + (* + * Arguments to bind_repr for layered effects are: + * a b ..units for binders that compute indices.. f_arg g_arg + * + * For non-layered effects, as before + *) + if U.is_layered ed then + // + //Bind in the TAC effect, for example, has range args + //This is indicated on the effect using an attribute + // + let bind_has_range_args = + U.has_attribute ed.eff_attrs PC.bind_has_range_args_attr in + let num_fixed_binders = + if bind_has_range_args then 4 //the two ranges, and f and g + else 2 in //f and g + + // + //for bind binders that are not fixed, we apply () + // + let unit_args = + match (ed |> U.get_bind_vc_combinator |> fst |> snd |> SS.compress).n with + | Tm_arrow {bs=_::_::bs} when List.length bs >= num_fixed_binders -> + bs + |> List.splitAt (List.length bs - num_fixed_binders) + |> fst + |> List.map (fun _ -> S.as_arg S.unit_const) + | _ -> + raise_error rng Errors.Fatal_UnexpectedEffect + (BU.format3 "bind_wp for layered effect %s is not an arrow with >= %s arguments (%s)" + (show ed.mname) + (show num_fixed_binders) + (ed |> U.get_bind_vc_combinator |> fst |> snd |> show)) + in + + let range_args = + if bind_has_range_args + then [as_arg (PO.embed_simple lb.lbpos lb.lbpos); + as_arg (PO.embed_simple body.pos body.pos)] + else [] in + + (S.as_arg lb.lbtyp)::(S.as_arg t)::(unit_args@range_args@[S.as_arg f_arg; S.as_arg body]) + else + let maybe_range_arg = + if BU.for_some (TEQ.eq_tm_bool cfg.tcenv U.dm4f_bind_range_attr) ed.eff_attrs + then [as_arg (PO.embed_simple lb.lbpos lb.lbpos); + as_arg (PO.embed_simple body.pos body.pos)] + else [] + in + [ (* a, b *) + as_arg lb.lbtyp; as_arg t] @ + maybe_range_arg @ [ + (* wp_f, f_arg--the term shouldn't depend on wp_f *) + as_arg S.tun; as_arg f_arg; + (* wp_body, body--the term shouldn't depend on wp_body *) + as_arg S.tun; as_arg body] in + + (* + * Construct the reified term + * + * if M is total, then its reification is also Tot, in that case we construct: + * + * bind (reify f) (fun x -> reify g) + * + * however, if M is not total, then (reify f) is Dv, and then we construct: + * + * let uu__ = reify f in + * bind uu_ (fun x -> reify g) + * + * We don't introduce the let-binding in the first case, + * since in some examples, it blocks reductions + *) + let reified = + let is_total_effect = Env.is_total_effect cfg.tcenv eff_name in + if is_total_effect + then S.mk (Tm_app {hd=bind_inst; args=bind_inst_args head}) rng + else + let lb_head, head_bv, head = + let bv = S.new_bv None x.sort in + let lb = + { lbname = Inl bv; + lbunivs = []; + lbtyp = U.mk_app repr [S.as_arg x.sort]; + lbeff = if is_total_effect then PC.effect_Tot_lid + else PC.effect_Dv_lid; + lbdef = head; + lbattrs = []; + lbpos = head.pos; + } + in + lb, bv, S.bv_to_name bv in + S.mk (Tm_let {lbs=(false, [lb_head]); + body=SS.close [S.mk_binder head_bv] <| + S.mk (Tm_app {hd=bind_inst; args=bind_inst_args head}) rng}) rng in + + log cfg (fun () -> BU.print2 "Reified (1) <%s> to %s\n" (show top0) (show reified)); + norm cfg env (List.tl stack) reified + ) + end + | Tm_app {hd=head; args} -> + (* ****************************************************************************) + (* Monadic application *) + (* *) + (* The typechecker should have turned any monadic application into a serie of *) + (* let-bindings (binding explicitly any monadic term) *) + (* let x0 = head in let x1 = arg0 in ... let xn = argn in x0 x1 ... xn *) + (* *) + (* which wil be ultimately reified to *) + (* bind (reify head) (fun x0 -> *) + (* bind (reify arg0) (fun x1 -> ... (fun xn -> x0 x1 .. xn) )) *) + (* *) + (* If head is an action then it is unfolded otherwise the *) + (* resulting application is reified again *) + (* ****************************************************************************) + + (* Checking that the typechecker did its job correctly and hoisted all impure *) + (* terms to explicit let-bindings (see TcTerm, monadic_application) *) + (* GM: Now only when --defensive is on, so we don't waste cycles otherwise *) + if Options.defensive () then begin + let is_arg_impure (e,q) = + match (SS.compress e).n with + | Tm_meta {tm=e0; meta=Meta_monadic_lift(m1, m2, t')} -> not (U.is_pure_effect m1) + | _ -> false + in + if BU.for_some is_arg_impure ((as_arg head)::args) then + Errors.log_issue top + Errors.Warning_Defensive + (BU.format1 "Incompatibility between typechecker and normalizer; \ + this monadic application contains impure terms %s\n" + (show top)) + end; + + (* GM: I'm really suspicious of this code, I tried to change it the least + * when trying to fixing it but these two seem super weird. Why 2 of them? + * Why is it not calling rebuild? I'm gonna keep it for now. *) + let fallback1 () = + log cfg (fun () -> BU.print2 "Reified (2) <%s> to %s\n" (show top0) ""); + norm cfg env (List.tl stack) (U.mk_reify top (Some m)) + in + let fallback2 () = + log cfg (fun () -> BU.print2 "Reified (3) <%s> to %s\n" (show top0) ""); + norm cfg env (List.tl stack) (mk (Tm_meta {tm=top; meta=Meta_monadic(m, t)}) top0.pos) + in + + (* This application case is only interesting for fully-applied dm4f actions. Otherwise, + * we just continue rebuilding. *) + begin match (U.un_uinst head).n with + | Tm_fvar fv -> + let lid = S.lid_of_fv fv in + let qninfo = Env.lookup_qname cfg.tcenv lid in + if not (Env.is_action cfg.tcenv lid) then fallback1 () else + + (* GM: I think the action *must* be fully applied at this stage + * since we were triggered into this function by a Meta_monadic + * annotation. So we don't check anything. *) + + (* Fallback if it does not have a definition. This happens, + * but I'm not sure why. *) + if Option.isNone (Env.lookup_definition_qninfo cfg.delta_level fv.fv_name.v qninfo) + then fallback2 () + else + + (* Turn it info (reify head) args, then do_unfold_fv will kick in on the head *) + let t = S.mk_Tm_app (U.mk_reify head (Some m)) args t.pos in + norm cfg env (List.tl stack) t + + | _ -> + fallback1 () + end + + // Doubly-annotated effect.. just take the outmost one. (unsure..) + | Tm_meta {tm=e; meta=Meta_monadic _} -> + do_reify_monadic fallback cfg env stack e m t + + | Tm_meta {tm=e; meta=Meta_monadic_lift (msrc, mtgt, t')} -> + let lifted = reify_lift cfg e msrc mtgt (closure_as_term cfg env t') in + log cfg (fun () -> BU.print1 "Reified lift to (2): %s\n" (show lifted)); + norm cfg env (List.tl stack) lifted + + | Tm_match {scrutinee=e; ret_opt=asc_opt; brs=branches; rc_opt=lopt} -> + (* Commutation of reify with match, note that the scrutinee should never be effectful *) + (* (should be checked at typechecking and elaborated with an explicit binding if needed) *) + (* reify (match e with p -> e') ~> match e with p -> reify e' *) + let branches = branches |> List.map (fun (pat, wopt, tm) -> pat, wopt, U.mk_reify tm (Some m)) in + let tm = mk (Tm_match {scrutinee=e; ret_opt=asc_opt; brs=branches; rc_opt=lopt}) top.pos in + norm cfg env (List.tl stack) tm + + | _ -> + fallback () + +(* Reifies the lifting of the term [e] of type [t] from computational *) +(* effect [m] to computational effect [m'] using lifting data in [env] *) +and reify_lift cfg e msrc mtgt t : term = + let env = cfg.tcenv in + log cfg (fun () -> BU.print3 "Reifying lift %s -> %s: %s\n" + (Ident.string_of_lid msrc) (Ident.string_of_lid mtgt) (show e)); + (* check if the lift is concrete, if so replace by its definition on terms *) + (* if msrc is PURE or Tot we can use mtgt.return *) + + (* + * AR: Not sure why we should use return, if the programmer has also provided a lift + * This seems like a mismatch, since to verify we use lift (else we give an error) + * but to run, we are relying on return + * Disabling this for layered effects, and using the lift instead + *) + if (U.is_pure_effect msrc || U.is_div_effect msrc) && + not (mtgt |> Env.is_layered_effect env) + then + let ed = Env.get_effect_decl env (Env.norm_eff_name cfg.tcenv mtgt) in + let _, repr = ed |> U.get_eff_repr |> must in + let _, return_repr = ed |> U.get_return_repr |> must in + let return_inst = match (SS.compress return_repr).n with + | Tm_uinst(return_tm, [_]) -> + S.mk (Tm_uinst (return_tm, [env.universe_of env t])) e.pos + | _ -> failwith "NIY : Reification of indexed effects" + in + + let lb_e, e_bv, e = + let bv = S.new_bv None t in + let lb = + { lbname = Inl bv; + lbunivs = []; + lbtyp = U.mk_app repr [S.as_arg t]; + lbeff = msrc; + lbdef = e; + lbattrs = []; + lbpos = e.pos; + } + in + lb, bv, S.bv_to_name bv + in + + S.mk (Tm_let {lbs=(false, [lb_e]); + body=SS.close [S.mk_binder e_bv] <| + S.mk (Tm_app {hd=return_inst; args=[as_arg t ; as_arg e]}) e.pos} + ) e.pos + else + match Env.monad_leq env msrc mtgt with + | None -> + failwith (BU.format2 "Impossible : trying to reify a lift between unrelated effects (%s and %s)" + (Ident.string_of_lid msrc) + (Ident.string_of_lid mtgt)) + | Some {mlift={mlift_term=None}} -> + failwith (BU.format2 "Impossible : trying to reify a non-reifiable lift (from %s to %s)" + (Ident.string_of_lid msrc) + (Ident.string_of_lid mtgt)) + | Some {mlift={mlift_term=Some lift}} -> + (* + * AR: we need to apply the lift combinator to `e` + * if source effect (i.e. e's effect) is reifiable, then we first reify e + * else if it is not, then we thunk e + * this is how lifts are written for layered effects + * not sure what's the convention for DM4F, but DM4F lifts don't come to this point anyway + * they are handled as a `return` in the `then` branch above + *) + let e = + if Env.is_reifiable_effect env msrc + then U.mk_reify e (Some msrc) + else S.mk + (Tm_abs {bs=[S.null_binder S.t_unit]; + body=e; + rc_opt=Some ({ residual_effect = msrc; residual_typ = Some t; residual_flags = [] })}) + e.pos in + lift (env.universe_of env t) t e + + + (* We still eagerly unfold the lift to make sure that the Unknown is not kept stuck on a folded application *) + (* let cfg = *) + (* { steps=[Exclude Iota ; Exclude Zeta; Inlining ; Eager_unfolding ; UnfoldUntil Delta_constant]; *) + (* tcenv=env; *) + (* delta_level=[Env.Unfold Delta_constant ; Env.Eager_unfolding_only ; Env.Inlining ] } *) + (* in *) + (* norm cfg [] [] (lift t S.tun (U.mk_reify e)) *) + +and norm_pattern_args cfg env args = + (* Drops stack *) + args |> List.map (List.map (fun (a, imp) -> norm cfg env [] a, imp)) + +and norm_comp : cfg -> env -> comp -> comp = + fun cfg env comp -> + log cfg (fun () -> BU.print2 ">>> %s\nNormComp with with %s env elements\n" + (show comp) + (show (List.length env))); + match comp.n with + | Total t -> + let t = norm cfg env [] t in + { mk_Total t with pos = comp.pos } + + | GTotal t -> + let t = norm cfg env [] t in + { mk_GTotal t with pos = comp.pos } + + | Comp ct -> + // + // if cfg.for_extraction and the effect extraction is not by reification, + // then drop the effect arguments + // + let effect_args = + ct.effect_args |> + (if cfg.steps.for_extraction && + not (get_extraction_mode cfg.tcenv ct.effect_name = Extract_reify) + then List.map (fun _ -> S.unit_const |> S.as_arg) + else List.mapi (fun idx (a, i) -> (norm cfg env [] a, i))) in + let flags = ct.flags |> List.map (function + | DECREASES (Decreases_lex l) -> + DECREASES (l |> List.map (norm cfg env []) |> Decreases_lex) + | DECREASES (Decreases_wf (rel, e)) -> + DECREASES (Decreases_wf (norm cfg env [] rel, norm cfg env [] e)) + | f -> f) in + let comp_univs = List.map (norm_universe cfg env) ct.comp_univs in + let result_typ = norm cfg env [] ct.result_typ in + { mk_Comp ({ct with comp_univs = comp_univs; + result_typ = result_typ; + effect_args = effect_args; + flags = flags}) with pos = comp.pos } + +and norm_binder (cfg:Cfg.cfg) (env:env) (b:binder) : binder = + let x = { b.binder_bv with sort = norm cfg env [] b.binder_bv.sort } in + let imp = match b.binder_qual with + | Some (S.Meta t) -> Some (S.Meta (closure_as_term cfg env t)) + | i -> i in + let attrs = List.map (norm cfg env []) b.binder_attrs in + S.mk_binder_with_attrs x imp b.binder_positivity attrs + +and norm_binders : cfg -> env -> binders -> binders = + fun cfg env bs -> + let nbs, _ = List.fold_left (fun (nbs', env) b -> + let b = norm_binder cfg env b in + (b::nbs', dummy () ::env) (* crossing a binder, so shift environment *)) + ([], env) + bs in + List.rev nbs + +and maybe_simplify cfg env stack tm = + let tm', renorm = maybe_simplify_aux cfg env stack tm in + if cfg.debug.b380 + then BU.print4 "%sSimplified\n\t%s to\n\t%s\nrenorm = %s\n" + (if cfg.steps.simplify then "" else "NOT ") + (show tm) (show tm') (show renorm); + tm', renorm + +and norm_cb cfg : EMB.norm_cb = function + | Inr x -> norm cfg [] [] x + | Inl l -> + //FStarC.Syntax.DsEnv.try_lookup_lid cfg.tcenv.dsenv l |> fst + match + FStarC.Syntax.DsEnv.try_lookup_lid cfg.tcenv.dsenv l + with + | Some t -> t + | None -> S.fv_to_tm (S.lid_as_fv l None) + + +(*******************************************************************) +(* Simplification steps are not part of definitional equality *) +(* simplifies True /\ t, t /\ True, t /\ False, False /\ t etc. *) +(* The boolean indicates whether further normalization is required. *) +(*******************************************************************) +and maybe_simplify_aux (cfg:cfg) (env:env) (stack:stack) (tm:term) : term & bool = + let tm, renorm = reduce_primops (norm_cb cfg) cfg env tm in + if not <| cfg.steps.simplify then tm, renorm + else + let w t = {t with pos=tm.pos} in + let simp_t t = + // catch annotated subformulae too + match (U.unmeta t).n with + | Tm_fvar fv when S.fv_eq_lid fv PC.true_lid -> Some true + | Tm_fvar fv when S.fv_eq_lid fv PC.false_lid -> Some false + | _ -> None + in + let is_const_match (phi : term) : option bool = + match (SS.compress phi).n with + (* Trying to be efficient, but just checking if they all agree *) + (* Note, if we wanted to do this for any term instead of just True/False + * we need to open the terms *) + | Tm_match {brs=br::brs} -> + let (_, _, e) = br in + let r = begin match simp_t e with + | None -> None + | Some b -> if List.for_all (fun (_, _, e') -> simp_t e' = Some b) brs + then Some b + else None + end + in + r + | _ -> None + in + let maybe_auto_squash t = + if U.is_sub_singleton t + then t + else U.mk_auto_squash U_zero t + in + let squashed_head_un_auto_squash_args t = + //The head of t is already a squashed operator, e.g. /\ etc. + //no point also squashing its arguments if they're already in U_zero + let maybe_un_auto_squash_arg (t,q) = + match U.is_auto_squash t with + | Some (U_zero, t) -> + //if we're squashing from U_zero to U_zero + // then just remove it + t, q + | _ -> + t,q + in + let head, args = U.head_and_args t in + let args = List.map maybe_un_auto_squash_arg args in + S.mk_Tm_app head args t.pos, false + in + let rec clearly_inhabited (ty : typ) : bool = + match (U.unmeta ty).n with + | Tm_uinst (t, _) -> clearly_inhabited t + | Tm_arrow {comp=c} -> clearly_inhabited (U.comp_result c) + | Tm_fvar fv -> + let l = S.lid_of_fv fv in + (Ident.lid_equals l PC.int_lid) + || (Ident.lid_equals l PC.bool_lid) + || (Ident.lid_equals l PC.string_lid) + || (Ident.lid_equals l PC.exn_lid) + | _ -> false + in + let simplify arg = (simp_t (fst arg), arg) in + match is_forall_const cfg tm with + (* We need to recurse, and maybe reduce further! *) + | Some tm' -> + if cfg.debug.wpe then + BU.print2 "WPE> %s ~> %s\n" (show tm) (show tm'); + maybe_simplify_aux cfg env stack (norm cfg env [] tm') + (* Otherwise try to simplify this point *) + | None -> + match (SS.compress tm).n with + | Tm_app {hd={n=Tm_uinst({n=Tm_fvar fv}, _)}; args} + | Tm_app {hd={n=Tm_fvar fv}; args} -> + if S.fv_eq_lid fv PC.squash_lid + then squashed_head_un_auto_squash_args tm + else if S.fv_eq_lid fv PC.and_lid + then match args |> List.map simplify with + | [(Some true, _); (_, (arg, _))] + | [(_, (arg, _)); (Some true, _)] -> maybe_auto_squash arg, false + | [(Some false, _); _] + | [_; (Some false, _)] -> w U.t_false, false + | _ -> squashed_head_un_auto_squash_args tm + else if S.fv_eq_lid fv PC.or_lid + then match args |> List.map simplify with + | [(Some true, _); _] + | [_; (Some true, _)] -> w U.t_true, false + | [(Some false, _); (_, (arg, _))] + | [(_, (arg, _)); (Some false, _)] -> maybe_auto_squash arg, false + | _ -> squashed_head_un_auto_squash_args tm + else if S.fv_eq_lid fv PC.imp_lid + then match args |> List.map simplify with + | [_; (Some true, _)] + | [(Some false, _); _] -> w U.t_true, false + | [(Some true, _); (_, (arg, _))] -> maybe_auto_squash arg, false + | [(_, (p, _)); (_, (q, _))] -> + if U.term_eq p q + then w U.t_true, false + else squashed_head_un_auto_squash_args tm + | _ -> squashed_head_un_auto_squash_args tm + else if S.fv_eq_lid fv PC.iff_lid + then match args |> List.map simplify with + | [(Some true, _) ; (Some true, _)] + | [(Some false, _) ; (Some false, _)] -> w U.t_true, false + | [(Some true, _) ; (Some false, _)] + | [(Some false, _) ; (Some true, _)] -> w U.t_false, false + | [(_, (arg, _)) ; (Some true, _)] + | [(Some true, _) ; (_, (arg, _))] -> maybe_auto_squash arg, false + | [(_, (arg, _)) ; (Some false, _)] + | [(Some false, _) ; (_, (arg, _))] -> maybe_auto_squash (U.mk_neg arg), false + | [(_, (p, _)); (_, (q, _))] -> + if U.term_eq p q + then w U.t_true, false + else squashed_head_un_auto_squash_args tm + | _ -> squashed_head_un_auto_squash_args tm + else if S.fv_eq_lid fv PC.not_lid + then match args |> List.map simplify with + | [(Some true, _)] -> w U.t_false, false + | [(Some false, _)] -> w U.t_true, false + | _ -> squashed_head_un_auto_squash_args tm + else if S.fv_eq_lid fv PC.forall_lid + then match args with + (* Simplify ∀x. True to True *) + | [(t, _)] -> + begin match (SS.compress t).n with + | Tm_abs {bs=[_]; body} -> + (match simp_t body with + | Some true -> w U.t_true, false + | _ -> tm, false) + | _ -> tm, false + end + (* Simplify ∀x. True to True, and ∀x. False to False, if the domain is not empty *) + | [(ty, Some ({ aqual_implicit = true })); (t, _)] -> + begin match (SS.compress t).n with + | Tm_abs {bs=[_]; body} -> + (match simp_t body with + | Some true -> w U.t_true, false + | Some false when clearly_inhabited ty -> w U.t_false, false + | _ -> tm, false) + | _ -> tm, false + end + | _ -> tm, false + else if S.fv_eq_lid fv PC.exists_lid + then match args with + (* Simplify ∃x. False to False *) + | [(t, _)] -> + begin match (SS.compress t).n with + | Tm_abs {bs=[_]; body} -> + (match simp_t body with + | Some false -> w U.t_false, false + | _ -> tm, false) + | _ -> tm, false + end + (* Simplify ∃x. False to False and ∃x. True to True, if the domain is not empty *) + | [(ty, Some ({ aqual_implicit = true })); (t, _)] -> + begin match (SS.compress t).n with + | Tm_abs {bs=[_]; body} -> + (match simp_t body with + | Some false -> w U.t_false, false + | Some true when clearly_inhabited ty -> w U.t_true, false + | _ -> tm, false) + | _ -> tm, false + end + | _ -> tm, false + else if S.fv_eq_lid fv PC.b2t_lid + then match args with + | [{n=Tm_constant (Const_bool true)}, _] -> w U.t_true, false + | [{n=Tm_constant (Const_bool false)}, _] -> w U.t_false, false + | _ -> tm, false //its arg is a bool, can't unsquash + else if S.fv_eq_lid fv PC.haseq_lid + then begin + (* + * AR: We try to mimic the hasEq related axioms in Prims + * and the axiom related to refinements + * For other types, such as lists, whose hasEq is derived by the typechecker, + * we leave them as is + *) + let t_has_eq_for_sure (t:S.term) :bool = + //Axioms from prims + let haseq_lids = [PC.int_lid; PC.bool_lid; PC.unit_lid; PC.string_lid] in + match (SS.compress t).n with + | Tm_fvar fv when haseq_lids |> List.existsb (fun l -> S.fv_eq_lid fv l) -> true + | _ -> false + in + if List.length args = 1 then + let t = args |> List.hd |> fst in + if t |> t_has_eq_for_sure then w U.t_true, false + else + match (SS.compress t).n with + | Tm_refine _ -> + let t = U.unrefine t in + if t |> t_has_eq_for_sure then w U.t_true, false + else + //get the hasEq term itself + let haseq_tm = + match (SS.compress tm).n with + | Tm_app {hd} -> hd + | _ -> failwith "Impossible! We have already checked that this is a Tm_app" + in + //and apply it to the unrefined type + mk_app (haseq_tm) [t |> as_arg], false + | _ -> tm, false + else tm, false + end + else if S.fv_eq_lid fv PC.subtype_of_lid + then begin + let is_unit ty = + match (SS.compress ty).n with + | Tm_fvar fv -> S.fv_eq_lid fv PC.unit_lid + | _ -> false + in + match args with + | [(t, _); (ty, _)] + when is_unit ty && U.is_sub_singleton t -> + w U.t_true, false + | _ -> tm, false + end + else begin + match U.is_auto_squash tm with + | Some (U_zero, t) + when U.is_sub_singleton t -> + //remove redundant auto_squashes + t, false + | _ -> + reduce_equality (norm_cb cfg) cfg env tm + end + | Tm_refine {b=bv; phi=t} -> + begin match simp_t t with + | Some true -> bv.sort, false + | Some false -> tm, false + | None -> tm, false + end + | Tm_match _ -> + begin match is_const_match tm with + | Some true -> w U.t_true, false + | Some false -> w U.t_false, false + | None -> tm, false + end + | _ -> tm, false + + +and rebuild (cfg:cfg) (env:env) (stack:stack) (t:term) : term = + (* Pre-condition: t is in either weak or strong normal form w.r.t env, depending on *) + (* whether cfg.steps constains WHNF In either case, it has no free de Bruijn *) + (* indices *) + log cfg (fun () -> + BU.print4 ">>> %s\nRebuild %s with %s env elements and top of the stack %s\n" + (tag_of t) + (show t) + (show (List.length env)) + (show (fst <| firstn 4 stack)); + if !dbg_NormRebuild + then match FStarC.Syntax.Util.unbound_variables t with + | [] -> () + | bvs -> + BU.print3 "!!! Rebuild (%s) %s, free vars=%s\n" + (tag_of t) + (show t) + (show bvs); + failwith "DIE!"); + + let f_opt = is_fext_on_domain t in + if f_opt |> is_some && (match stack with | Arg _::_ -> true | _ -> false) //AR: it is crucial to check that (on_domain a #b) is actually applied, else it would be unsound to reduce it to f + then f_opt |> must |> norm cfg env stack + else + let t, renorm = maybe_simplify cfg env stack t in + if renorm + then norm cfg env stack t + else do_rebuild cfg env stack t + +and do_rebuild (cfg:cfg) (env:env) (stack:stack) (t:term) : term = + match stack with + | [] -> t + + | Meta(_, m, r)::stack -> + let t = + // + //AR/NS: 04/22/2022: The code below collapses the towers of + // meta monadic nodes, keeping the outermost effect + // We did this optimization during a debugging session + // + match m with + | Meta_monadic _ -> + (match (SS.compress t).n with + | Tm_meta {tm=t'; meta=Meta_monadic _} -> + mk (Tm_meta {tm=t'; meta=m}) r + | _ -> mk (Tm_meta {tm=t; meta=m}) r) + | _ -> mk (Tm_meta {tm=t; meta=m}) r in + rebuild cfg env stack t + + | MemoLazy r::stack -> + set_memo cfg r (env, t); + log cfg (fun () -> BU.print1 "\tSet memo %s\n" (show t)); + rebuild cfg env stack t + + | Let(env', bs, lb, r)::stack -> + let body = SS.close bs t in + let t = S.mk (Tm_let {lbs=(false, [lb]); body}) r in + rebuild cfg env' stack t + + | Abs (env', bs, env'', lopt, r)::stack -> + let bs = norm_binders cfg env' bs in + let lopt = BU.map_option (norm_residual_comp cfg env'') lopt in + rebuild cfg env stack ({abs bs t lopt with pos=r}) + + | Arg (Univ _, _, _)::_ + | Arg (Dummy, _, _)::_ -> failwith "Impossible" + + | UnivArgs(us, r)::stack -> + let t = mk_Tm_uinst t us in + rebuild cfg env stack t + + | Arg (Clos(env_arg, tm, _, _), aq, r) :: stack + when U.is_fstar_tactics_by_tactic (head_of t) -> + let t = S.extend_app t (closure_as_term cfg env_arg tm, aq) r in + rebuild cfg env stack t + + | Arg (Clos(env_arg, tm, m, _), aq, r) :: stack -> + log cfg (fun () -> BU.print1 "Rebuilding with arg %s\n" (show tm)); + + (* If we are doing hnf (and the head is not a primop), then there is + no need to normalize the argument. *) + if cfg.steps.hnf && not (is_partial_primop_app cfg t) then ( + let arg = closure_as_term cfg env_arg tm in + let t = extend_app t (arg, aq) r in + rebuild cfg env_arg stack t + ) else ( + (* If the argument was already normalized+memoized, reuse it. *) + match read_memo cfg m with + | Some (_, a) -> + let t = S.extend_app t (a, aq) r in + rebuild cfg env_arg stack t + + | None when not cfg.steps.iota -> + (* If we are not doing iota, do not memoize the partial solution. + I do not understand exactly why this is needed, but I'm retaining + the logic. Removing this branch in fact leads to a failure, when + trying to typecheck the following: + + private let fa_intro_lem (#a:Type) (#p:a -> Type) (f:(x:a -> squash (p x))) : Lemma (forall (x:a). p x) = + Classical.lemma_forall_intro_gtot + ((fun x -> IndefiniteDescription.elim_squash (f x)) <: (x:a -> GTot (p x))) + + because the ascription gets dropped. I don't see why iota would matter, + perhaps it's a flag that happens to be there. *) + let stack = App(env, t, aq, r)::stack in + norm cfg env_arg stack tm + + | None -> + (* Otherwise normalize the argument and memoize it. *) + let stack = MemoLazy m::App(env, t, aq, r)::stack in + norm cfg env_arg stack tm + ) + + | App(env, head, aq, r)::stack' when should_reify cfg stack -> + let t0 = t in + let fallback msg () = + log cfg (fun () -> BU.print2 "Not reifying%s: %s\n" msg (show t)); + let t = S.extend_app head (t, aq) r in + rebuild cfg env stack' t + in + // + //AR: no non-extraction reification for layered effects, + // unless TAC + // + let is_non_tac_layered_effect m = + let norm_m = m |> Env.norm_eff_name cfg.tcenv in + (not (Ident.lid_equals norm_m PC.effect_TAC_lid)) && + norm_m |> Env.is_layered_effect cfg.tcenv in + + begin match (SS.compress t).n with + | Tm_meta {meta=Meta_monadic (m, _)} + when is_non_tac_layered_effect m && + not cfg.steps.for_extraction -> + fallback (BU.format1 + "Meta_monadic for a non-TAC layered effect %s in non-extraction mode" + (Ident.string_of_lid m)) () + + | Tm_meta {meta=Meta_monadic (m, _)} + when is_non_tac_layered_effect m && + cfg.steps.for_extraction && + S.Extract_none? (get_extraction_mode cfg.tcenv m) -> + // + // If the effect is an indexed effect, that is non-extractable + // + let S.Extract_none msg = get_extraction_mode cfg.tcenv m in + raise_error t Errors.Fatal_UnexpectedEffect + (BU.format2 "Normalizer cannot reify effect %s for extraction since %s" + (Ident.string_of_lid m) msg) + + | Tm_meta {meta=Meta_monadic (m, _)} + when is_non_tac_layered_effect m && + cfg.steps.for_extraction && + get_extraction_mode cfg.tcenv m = S.Extract_primitive -> + + // If primitive extraction, don't reify + fallback (BU.format1 + "Meta_monadic for a non-TAC layered effect %s which is Extract_primtiive" + (Ident.string_of_lid m)) () + + | Tm_meta {meta=Meta_monadic_lift (msrc, mtgt, _)} + when (is_non_tac_layered_effect msrc || + is_non_tac_layered_effect mtgt) && + not cfg.steps.for_extraction -> + fallback (BU.format2 + "Meta_monadic_lift for a non-TAC layered effect %s ~> %s in non extraction mode" + (Ident.string_of_lid msrc) (Ident.string_of_lid mtgt)) () + + | Tm_meta {meta=Meta_monadic_lift (msrc, mtgt, _)} + when cfg.steps.for_extraction && + ((is_non_tac_layered_effect msrc && + S.Extract_none? (get_extraction_mode cfg.tcenv msrc)) || + (is_non_tac_layered_effect mtgt && + S.Extract_none? (get_extraction_mode cfg.tcenv mtgt))) -> + + raise_error t Errors.Fatal_UnexpectedEffect + (BU.format2 "Normalizer cannot reify %s ~> %s for extraction" + (Ident.string_of_lid msrc) + (Ident.string_of_lid mtgt)) + + | Tm_meta {tm=t; meta=Meta_monadic (m, ty)} -> + do_reify_monadic (fallback " (1)") cfg env stack t m ty + + | Tm_meta {tm=t; meta=Meta_monadic_lift (msrc, mtgt, ty)} -> + let lifted = reify_lift cfg t msrc mtgt (closure_as_term cfg env ty) in + log cfg (fun () -> BU.print1 "Reified lift to (1): %s\n" (show lifted)); + norm cfg env (List.tl stack) lifted + + | Tm_app {hd={n = Tm_constant (FC.Const_reflect _)}; args=[(e, _)]} -> + // reify (reflect e) ~> e + // Although shouldn't `e` ALWAYS be marked with a Meta_monadic? + norm cfg env stack' e + + | Tm_app _ when cfg.steps.primops -> + let hd, args = U.head_and_args_full_unmeta t in + (match (U.un_uinst hd).n with + | Tm_fvar fv -> + begin + match find_prim_step cfg fv with + | Some ({auto_reflect=Some n}) + when List.length args = n -> + norm cfg env stack' t + | _ -> fallback " (3)" () + end + | _ -> fallback " (4)" ()) + + | _ -> + fallback " (2)" () + end + + | App(env, head, aq, r)::stack -> + let t = S.extend_app head (t,aq) r in + rebuild cfg env stack t + + | CBVApp(env', head, aq, r)::stack -> + norm cfg env' (Arg (Clos (env, t, fresh_memo (), false), aq, t.pos) :: stack) head + + | Match(env', asc_opt, branches, lopt, cfg, r) :: stack -> + let lopt = BU.map_option (norm_residual_comp cfg env') lopt in + log cfg (fun () -> BU.print1 "Rebuilding with match, scrutinee is %s ...\n" (show t)); + //the scrutinee is always guaranteed to be a pure or ghost term + //see tc.fs, the case of Tm_match and the comment related to issue #594 + let scrutinee_env = env in + let env = env' in + let scrutinee = t in + let norm_and_rebuild_match () = + log cfg (fun () -> + BU.print2 "match is irreducible: scrutinee=%s\nbranches=%s\n" + (show scrutinee) + (branches |> List.map (fun (p, _, _) -> show p) |> String.concat "\n\t")); + // If either Weak or HNF, then don't descend into branch + let whnf = cfg.steps.weak || cfg.steps.hnf in + let cfg_exclude_zeta = + if cfg.steps.zeta_full + then cfg + else + let new_delta = + cfg.delta_level |> List.filter (function + | Env.InliningDelta + | Env.Eager_unfolding_only -> true + | _ -> false) + in + let steps = { + cfg.steps with + zeta = false; + unfold_until = None; + unfold_only = None; + unfold_attr = None; + unfold_qual = None; + unfold_namespace = None; + dont_unfold_attr = None; + } + in + ({cfg with delta_level=new_delta; steps=steps; strong=true}) + in + let norm_or_whnf env t = + if whnf + then closure_as_term cfg_exclude_zeta env t + else norm cfg_exclude_zeta env [] t + in + let rec norm_pat env p = match p.v with + | Pat_constant _ -> p, env + | Pat_cons(fv, us_opt, pats) -> + let us_opt = + if cfg.steps.erase_universes + then None + else ( + match us_opt with + | None -> None + | Some us -> + Some (List.map (norm_universe cfg env) us) + ) + in + let pats, env = pats |> List.fold_left (fun (pats, env) (p, b) -> + let p, env = norm_pat env p in + (p,b)::pats, env) ([], env) in + {p with v=Pat_cons(fv, us_opt, List.rev pats)}, env + | Pat_var x -> + let x = {x with sort=norm_or_whnf env x.sort} in + {p with v=Pat_var x}, dummy () ::env + | Pat_dot_term eopt -> + let eopt = BU.map_option (norm_or_whnf env) eopt in + {p with v=Pat_dot_term eopt}, env + in + let norm_branches () = + match env with + | [] when whnf -> branches //nothing to close over + | _ -> branches |> List.map (fun branch -> + let p, wopt, e = SS.open_branch branch in + //It's important to normalize all the sorts within the pat! + let p, env = norm_pat env p in + let wopt = match wopt with + | None -> None + | Some w -> Some (norm_or_whnf env w) in + let e = norm_or_whnf env e in + U.branch (p, wopt, e)) + in + let maybe_commute_matches () = + let can_commute = + match branches with + | ({v=Pat_cons(fv, _, _)}, _, _)::_ -> + Env.fv_has_attr cfg.tcenv fv FStarC.Parser.Const.commute_nested_matches_lid + | _ -> false in + match (U.unascribe scrutinee).n with + | Tm_match {scrutinee=sc0; + ret_opt=asc_opt0; + brs=branches0; + rc_opt=lopt0} when can_commute -> + (* We have a blocked match, because of something like + + (match (match sc0 with P1 -> e1 | ... | Pn -> en) with + | Q1 -> f1 ... | Qm -> fm) + + We'll reduce it as if it was instead + + (match sc0 with + | P1 -> (match e1 with | Q1 -> f1 ... | Qm -> fm) + ... + | Pn -> (match en with | Q1 -> f1 ... | Qm -> fm)) + + if the Qi are constructors from an inductive marked with the + commute_nested_matches attribute + *) + let reduce_branch (b:S.branch) = + //reduce the inner branch `b` while setting the continuation + //stack to be the outer match + let stack = [Match(env', asc_opt, branches, lopt, cfg, r)] in + let p, wopt, e = SS.open_branch b in + //It's important to normalize all the sorts within the pat! + let p, branch_env = norm_pat scrutinee_env p in + let wopt = match wopt with + | None -> None + | Some w -> Some (norm_or_whnf branch_env w) in + let e = norm cfg branch_env stack e in + U.branch (p, wopt, e) + in + let branches0 = List.map reduce_branch branches0 in + rebuild cfg env stack (mk (Tm_match {scrutinee=sc0; + ret_opt=asc_opt0; + brs=branches0; + rc_opt=lopt0}) r) + | _ -> + let scrutinee = + if cfg.steps.iota + && (not cfg.steps.weak) + && (not cfg.steps.compress_uvars) + && cfg.steps.weakly_reduce_scrutinee + && maybe_weakly_reduced scrutinee + then norm ({cfg with steps={cfg.steps with weakly_reduce_scrutinee=false}}) + scrutinee_env + [] + scrutinee //scrutinee was only reduced to wnf; reduce it fully + else scrutinee + in + let asc_opt = norm_match_returns cfg env asc_opt in + let branches = norm_branches() in + rebuild cfg env stack (mk (Tm_match {scrutinee; + ret_opt=asc_opt; + brs=branches; + rc_opt=lopt}) r) + in + maybe_commute_matches() + in + + let rec is_cons head = match (SS.compress head).n with + | Tm_uinst(h, _) -> is_cons h + | Tm_constant _ + | Tm_fvar( {fv_qual=Some Data_ctor} ) + | Tm_fvar( {fv_qual=Some (Record_ctor _)} ) -> true + | _ -> false + in + + let guard_when_clause wopt b rest = + match wopt with + | None -> b + | Some w -> + let then_branch = b in + let else_branch = mk (Tm_match {scrutinee; + ret_opt=asc_opt; + brs=rest; + rc_opt=lopt}) r in + U.if_then_else w then_branch else_branch + in + + + let rec matches_pat (scrutinee_orig:term) (p:pat) + : either (list (bv & term)) bool + (* Inl ts: p matches t and ts are bindings for the branch *) + (* Inr false: p definitely does not match t *) + (* Inr true: p may match t, but p is an open term and we cannot decide for sure *) + = let scrutinee = U.unmeta scrutinee_orig in + let scrutinee = U.unlazy scrutinee in + let head, args = U.head_and_args scrutinee in + match p.v with + | Pat_var bv -> Inl [(bv, scrutinee_orig)] + | Pat_dot_term _ -> Inl [] + | Pat_constant s -> begin + match scrutinee.n with + | Tm_constant s' + when FStarC.Const.eq_const s s' -> + Inl [] + | _ -> Inr (not (is_cons head)) //if it's not a constant, it may match + end + | Pat_cons(fv, _, arg_pats) -> begin + match (U.un_uinst head).n with + | Tm_fvar fv' when fv_eq fv fv' -> + matches_args [] args arg_pats + | _ -> Inr (not (is_cons head)) //if it's not a constant, it may match + end + + and matches_args out (a:args) (p:list (pat & bool)) : either (list (bv & term)) bool = match a, p with + | [], [] -> Inl out + | (t, _)::rest_a, (p, _)::rest_p -> + begin match matches_pat t p with + | Inl s -> matches_args (out@s) rest_a rest_p + | m -> m + end + | _ -> Inr false + in + + let rec matches scrutinee p = match p with + | [] -> norm_and_rebuild_match () + | (p, wopt, b)::rest -> + match matches_pat scrutinee p with + | Inr false -> //definite mismatch; safe to consider the remaining patterns + matches scrutinee rest + + | Inr true -> //may match this pattern but t is an open term; block reduction + norm_and_rebuild_match () + + | Inl s -> //definite match + log cfg (fun () -> BU.print2 "Matches pattern %s with subst = %s\n" + (show p) + (List.map (fun (_, t) -> show t) s |> String.concat "; ")); + //the elements of s are sub-terms of t + //the have no free de Bruijn indices; so their env=[]; see pre-condition at the top of rebuild + let env0 = env in + + + // The scrutinee is (at least) in weak normal + // form. This means, it can be of the form (C v1 + // ... (fun x -> e) ... vn) + + //ie., it may have some sub-terms that are lambdas + //with unreduced bodies + + //but, since the memo references are expected to hold + //weakly normal terms, it is safe to set them to the + //sub-terms of the scrutinee + + //otherwise, we will keep reducing them over and over + //again. See, e.g., Issue #2757 + + //Except, if the normalizer is running in HEAD normal form mode, + //then the sub-terms of the scrutinee might not be reduced yet. + //In that case, do not set the memo reference + let env = List.fold_left + (fun env (bv, t) -> (Some (S.mk_binder bv), + Clos([], t, BU.mk_ref (if cfg.steps.hnf then None else Some (cfg, ([], t))), false), + fresh_memo ()) :: env) + env s in + norm cfg env stack (guard_when_clause wopt b rest) + in + + if cfg.steps.iota + then matches scrutinee branches + else norm_and_rebuild_match () + +and norm_match_returns cfg env ret_opt = + match ret_opt with + | None -> None + | Some (b, asc) -> + let b = norm_binder cfg env b in + let subst, asc = SS.open_ascription [b] asc in + let asc = norm_ascription cfg (dummy()::env) asc in + Some (b, SS.close_ascription subst asc) + +and norm_ascription cfg env (tc, tacopt, use_eq) = + (match tc with + | Inl t -> Inl (norm cfg env [] t) + | Inr c -> Inr (norm_comp cfg env c)), + BU.map_opt tacopt (norm cfg env []), + use_eq + +and norm_residual_comp cfg env (rc:residual_comp) : residual_comp = + {rc with residual_typ = BU.map_option (closure_as_term cfg env) rc.residual_typ} + +let reflection_env_hook = BU.mk_ref None + +let normalize_with_primitive_steps ps s e (t:term) = + let is_nbe = is_nbe_request s in + let maybe_nbe = if is_nbe then " (NBE)" else "" in + Errors.with_ctx ("While normalizing a term" ^ maybe_nbe) (fun () -> + Profiling.profile (fun () -> + let c = config' ps s e in + reflection_env_hook := Some e; + plugin_unfold_warn_ctr := 10; + log_top c (fun () -> BU.print2 "\nStarting normalizer%s for (%s) {\n" maybe_nbe (show t)); + log_top c (fun () -> BU.print1 ">>> cfg = %s\n" (show c)); + def_check_scoped t.pos "normalize_with_primitive_steps call" e t; + let (r, ms) = + BU.record_time (fun () -> + if is_nbe + then nbe_eval c s t + else norm c [] [] t + ) + in + log_top c (fun () -> BU.print3 "}\nNormalization%s result = (%s) in %s ms\n" maybe_nbe (show r) (show ms)); + r + ) + (Some (Ident.string_of_lid (Env.current_module e))) + "FStarC.TypeChecker.Normalize.normalize_with_primitive_steps" + ) + +let normalize s e t = + Profiling.profile (fun () -> normalize_with_primitive_steps [] s e t) + (Some (Ident.string_of_lid (Env.current_module e))) + "FStarC.TypeChecker.Normalize.normalize" + +let normalize_comp s e c = + Profiling.profile (fun () -> + let cfg = config s e in + reflection_env_hook := Some e; + plugin_unfold_warn_ctr := 10; + log_top cfg (fun () -> BU.print1 "Starting normalizer for computation (%s) {\n" (show c)); + log_top cfg (fun () -> BU.print1 ">>> cfg = %s\n" (show cfg)); + def_check_scoped c.pos "normalize_comp call" e c; + let (c, ms) = Errors.with_ctx "While normalizing a computation type" (fun () -> + BU.record_time (fun () -> + norm_comp cfg [] c)) + in + log_top cfg (fun () -> BU.print2 "}\nNormalization result = (%s) in %s ms\n" (show c) (show ms)); + c) + (Some (Ident.string_of_lid (Env.current_module e))) + "FStarC.TypeChecker.Normalize.normalize_comp" + +let normalize_universe env u = Errors.with_ctx "While normalizing a universe level" (fun () -> + norm_universe (config [] env) [] u +) + +let non_info_norm env t = + let steps = [UnfoldUntil delta_constant; + AllowUnboundUniverses; + EraseUniverses; + HNF; + (* We could use Weak too were it not that we need + * to descend in the codomain of arrows. *) + Unascribe; //remove ascriptions + ForExtraction //and refinement types + ] + in + non_informative env (normalize steps env t) + +(* + * Ghost T to Pure T promotion + * + * The promotion applies in two scenarios: + * + * One when T is non-informative, where + * Non-informative types T ::= unit | Type u | t -> Tot T | t -> GTot T + * + * Second when Ghost T is being composed with or lifted to another + * erasable effect + *) + +let maybe_promote_t env non_informative_only t = + not non_informative_only || non_info_norm env t + +let ghost_to_pure_aux env non_informative_only c = + match c.n with + | Total _ -> c + | GTotal t -> + if maybe_promote_t env non_informative_only t then {c with n = Total t} else c + | Comp ct -> + let l = Env.norm_eff_name env ct.effect_name in + if U.is_ghost_effect l + && maybe_promote_t env non_informative_only ct.result_typ + then let ct = + match downgrade_ghost_effect_name ct.effect_name with + | Some pure_eff -> + let flags = if Ident.lid_equals pure_eff PC.effect_Tot_lid then TOTAL::ct.flags else ct.flags in + {ct with effect_name=pure_eff; flags=flags} + | None -> + let ct = unfold_effect_abbrev env c in //must be GHOST + {ct with effect_name=PC.effect_PURE_lid} in + {c with n=Comp ct} + else c + | _ -> c + +let ghost_to_pure_lcomp_aux env non_informative_only (lc:lcomp) = + if U.is_ghost_effect lc.eff_name + && maybe_promote_t env non_informative_only lc.res_typ + then match downgrade_ghost_effect_name lc.eff_name with + | Some pure_eff -> + { TcComm.apply_lcomp (ghost_to_pure_aux env non_informative_only) (fun g -> g) lc + with eff_name = pure_eff } + | None -> //can't downgrade, don't know the particular incarnation of PURE to use + lc + else lc + +(* only promote non-informative types *) +let maybe_ghost_to_pure env c = ghost_to_pure_aux env true c +let maybe_ghost_to_pure_lcomp env lc = ghost_to_pure_lcomp_aux env true lc + +(* promote unconditionally *) +let ghost_to_pure env c = ghost_to_pure_aux env false c +let ghost_to_pure_lcomp env lc = ghost_to_pure_lcomp_aux env false lc + +(* + * The following functions implement GHOST to PURE promotion + * when the GHOST effect is being composed with or lifted to + * another erasable effect + * In that case the "ghostness" or erasability of GHOST is already + * accounted for in the erasable effect + *) +let ghost_to_pure2 env (c1, c2) = + let c1, c2 = maybe_ghost_to_pure env c1, maybe_ghost_to_pure env c2 in + + let c1_eff = c1 |> U.comp_effect_name |> Env.norm_eff_name env in + let c2_eff = c2 |> U.comp_effect_name |> Env.norm_eff_name env in + + if Ident.lid_equals c1_eff c2_eff then c1, c2 + else let c1_erasable = Env.is_erasable_effect env c1_eff in + let c2_erasable = Env.is_erasable_effect env c2_eff in + + if c1_erasable && Ident.lid_equals c2_eff PC.effect_GHOST_lid + then c1, ghost_to_pure env c2 + else if c2_erasable && Ident.lid_equals c1_eff PC.effect_GHOST_lid + then ghost_to_pure env c1, c2 + else c1, c2 + +let ghost_to_pure_lcomp2 env (lc1, lc2) = + let lc1, lc2 = maybe_ghost_to_pure_lcomp env lc1, maybe_ghost_to_pure_lcomp env lc2 in + + let lc1_eff = Env.norm_eff_name env lc1.eff_name in + let lc2_eff = Env.norm_eff_name env lc2.eff_name in + + if Ident.lid_equals lc1_eff lc2_eff then lc1, lc2 + else let lc1_erasable = Env.is_erasable_effect env lc1_eff in + let lc2_erasable = Env.is_erasable_effect env lc2_eff in + + if lc1_erasable && Ident.lid_equals lc2_eff PC.effect_GHOST_lid + then lc1, ghost_to_pure_lcomp env lc2 + else if lc2_erasable && Ident.lid_equals lc1_eff PC.effect_GHOST_lid + then ghost_to_pure_lcomp env lc1, lc2 + else lc1, lc2 + +let warn_norm_failure (r:Range.range) (e:exn) : unit = + Errors.log_issue r Errors.Warning_NormalizationFailure (BU.format1 "Normalization failed with error %s\n" (BU.message_of_exn e)) + +let term_to_doc env t = + let t = + try normalize [AllowUnboundUniverses] env t + with e -> + warn_norm_failure t.pos e; + t + in + FStarC.Syntax.Print.term_to_doc' (DsEnv.set_current_module env.dsenv env.curmodule) t + +let term_to_string env t = GenSym.with_frozen_gensym (fun () -> + let t = + try normalize [AllowUnboundUniverses] env t + with e -> + warn_norm_failure t.pos e; + t + in + Print.term_to_string' (DsEnv.set_current_module env.dsenv env.curmodule) t) + +let comp_to_string env c = GenSym.with_frozen_gensym (fun () -> + let c = + try norm_comp (config [AllowUnboundUniverses] env) [] c + with e -> + warn_norm_failure c.pos e; + c + in + Print.comp_to_string' (DsEnv.set_current_module env.dsenv env.curmodule) c) + +let comp_to_doc env c = GenSym.with_frozen_gensym (fun () -> + let c = + try norm_comp (config [AllowUnboundUniverses] env) [] c + with e -> + warn_norm_failure c.pos e; + c + in + Print.comp_to_doc' (DsEnv.set_current_module env.dsenv env.curmodule) c) + +let normalize_refinement steps env t0 = + let t = normalize (steps@[Beta]) env t0 in + U.flatten_refinement t + +let whnf_steps = [Primops; Weak; HNF; UnfoldUntil delta_constant; Beta] +let unfold_whnf' steps env t = normalize (steps@whnf_steps) env t +let unfold_whnf env t = unfold_whnf' [] env t + +let reduce_or_remove_uvar_solutions remove env t = + normalize ((if remove then [DefaultUnivsToZero; CheckNoUvars] else []) + @[Beta; DoNotUnfoldPureLets; CompressUvars; Exclude Zeta; Exclude Iota; NoFullNorm;]) + env + t +let reduce_uvar_solutions env t = reduce_or_remove_uvar_solutions false env t +let remove_uvar_solutions env t = reduce_or_remove_uvar_solutions true env t + +let eta_expand_with_type (env:Env.env) (e:term) (t_e:typ) = + //unfold_whnf env t_e in + //It would be nice to eta_expand based on the WHNF of t_e + //except that this triggers a brittleness in the unification algorithm and its interaction with SMT encoding + //in particular, see Rel.u_abs (roughly line 520) + let formals, c = U.arrow_formals_comp t_e in + match formals with + | [] -> e + | _ -> + let actuals, _, _ = U.abs_formals e in + if List.length actuals = List.length formals + then e + else let binders, args = formals |> U.args_of_binders in + U.abs binders (mk_Tm_app e args e.pos) + (Some (U.residual_comp_of_comp c)) + +let eta_expand (env:Env.env) (t:term) : term = + match t.n with + | Tm_name x -> + eta_expand_with_type env t x.sort + | _ -> + let head, args = U.head_and_args t in + begin match (SS.compress head).n with + | Tm_uvar (u,s) -> + let formals, _tres = U.arrow_formals (SS.subst' s (U.ctx_uvar_typ u)) in + if List.length formals = List.length args + then t + else let _, ty, _ = env.typeof_tot_or_gtot_term ({env with admit=true; expected_typ=None}) t true in + eta_expand_with_type env t ty + | _ -> + let _, ty, _ = env.typeof_tot_or_gtot_term ({env with admit=true; expected_typ=None}) t true in + eta_expand_with_type env t ty + end + +let elim_uvars_aux_tc (env:Env.env) (univ_names:univ_names) (binders:binders) (tc:either typ comp) = + let t = + match binders, tc with + | [], Inl t -> t + | [], Inr c -> failwith "Impossible: empty bindes with a comp" + | _ , Inr c -> S.mk (Tm_arrow {bs=binders; comp=c}) c.pos + | _ , Inl t -> S.mk (Tm_arrow {bs=binders; comp=S.mk_Total t}) t.pos + in + let univ_names, t = Subst.open_univ_vars univ_names t in + let t = remove_uvar_solutions env t in + let t = Subst.close_univ_vars univ_names t in + let binders, tc = + match binders with + | [] -> [], Inl t + | _ -> begin + match (SS.compress t).n, tc with + | Tm_arrow {bs=binders; comp=c}, Inr _ -> binders, Inr c + | Tm_arrow {bs=binders; comp=c}, Inl _ -> binders, Inl (U.comp_result c) + | _, Inl _ -> [], Inl t + | _ -> failwith "Impossible" + end + in + univ_names, binders, tc + +let elim_uvars_aux_t env univ_names binders t = + let univ_names, binders, tc = elim_uvars_aux_tc env univ_names binders (Inl t) in + univ_names, binders, BU.left tc + +let elim_uvars_aux_c env univ_names binders c = + let univ_names, binders, tc = elim_uvars_aux_tc env univ_names binders (Inr c) in + univ_names, binders, BU.right tc + +let rec elim_uvars (env:Env.env) (s:sigelt) = + let sigattrs = List.map Mktuple3?._3 <| List.map (elim_uvars_aux_t env [] []) s.sigattrs in + let s = { s with sigattrs } in + match s.sigel with + | Sig_inductive_typ {lid; us=univ_names; params=binders; + num_uniform_params=num_uniform; + t=typ; + mutuals=lids; + ds=lids'; + injective_type_params} -> + let univ_names, binders, typ = elim_uvars_aux_t env univ_names binders typ in + {s with sigel = Sig_inductive_typ {lid; + us=univ_names; + params=binders; + num_uniform_params=num_uniform; + t=typ; + mutuals=lids; + ds=lids'; + injective_type_params}} + + | Sig_bundle {ses=sigs; lids} -> + {s with sigel = Sig_bundle {ses=List.map (elim_uvars env) sigs; lids}} + + | Sig_datacon {lid; us=univ_names; t=typ; ty_lid=lident; num_ty_params=i; mutuals=lids; injective_type_params} -> + let univ_names, _, typ = elim_uvars_aux_t env univ_names [] typ in + {s with sigel = Sig_datacon {lid; + us=univ_names; + t=typ; + ty_lid=lident; + num_ty_params=i; + mutuals=lids; + injective_type_params}} + + | Sig_declare_typ {lid; us=univ_names; t=typ} -> + let univ_names, _, typ = elim_uvars_aux_t env univ_names [] typ in + {s with sigel = Sig_declare_typ {lid; us=univ_names; t=typ}} + + | Sig_let {lbs=(b, lbs); lids} -> + let lbs = lbs |> List.map (fun lb -> + let opening, lbunivs = Subst.univ_var_opening lb.lbunivs in + let elim t = Subst.close_univ_vars lbunivs (remove_uvar_solutions env (Subst.subst opening t)) in + let lbtyp = elim lb.lbtyp in + let lbdef = elim lb.lbdef in + {lb with lbunivs = lbunivs; + lbtyp = lbtyp; + lbdef = lbdef}) + in + {s with sigel = Sig_let {lbs=(b, lbs); lids}} + + | Sig_assume {lid=l; us; phi=t} -> + let us, _, t = elim_uvars_aux_t env us [] t in + {s with sigel = Sig_assume {lid=l; us; phi=t}} + + | Sig_new_effect ed -> + //AR: S.t_unit is just a dummy comp type, we only care about the binders + let univs, binders, _ = elim_uvars_aux_t env ed.univs ed.binders S.t_unit in + let univs_opening, univs_closing = + let univs_opening, univs = SS.univ_var_opening univs in + univs_opening, SS.univ_var_closing univs + in + let b_opening, b_closing = + let binders = SS.open_binders binders in + SS.opening_of_binders binders, + SS.closing_of_binders binders + in + let n = List.length univs in + let n_binders = List.length binders in + let elim_tscheme (us, t) = + let n_us = List.length us in + let us, t = SS.open_univ_vars us t in + let b_opening, b_closing = + b_opening |> SS.shift_subst n_us, + b_closing |> SS.shift_subst n_us in + let univs_opening, univs_closing = + univs_opening |> SS.shift_subst (n_us + n_binders), + univs_closing |> SS.shift_subst (n_us + n_binders) in + let t = SS.subst univs_opening (SS.subst b_opening t) in + let _, _, t = elim_uvars_aux_t env [] [] t in + let t = SS.subst univs_closing (SS.subst b_closing (SS.close_univ_vars us t)) in + us, t + in + let elim_term t = + let _, _, t = elim_uvars_aux_t env univs binders t in + t + in + let elim_action a = + let action_typ_templ = + let body = S.mk (Tm_ascribed {tm=a.action_defn; + asc=(Inl a.action_typ, None, false); + eff_opt=None}) a.action_defn.pos in + match a.action_params with + | [] -> body + | _ -> S.mk (Tm_abs {bs=a.action_params; body; rc_opt=None}) a.action_defn.pos in + let destruct_action_body body = + match (SS.compress body).n with + | Tm_ascribed {tm=defn; asc=(Inl typ, None, _); eff_opt=None} -> defn, typ + | _ -> failwith "Impossible" + in + let destruct_action_typ_templ t = + match (SS.compress t).n with + | Tm_abs {bs=pars; body} -> + let defn, typ = destruct_action_body body in + pars, defn, typ + | _ -> + let defn, typ = destruct_action_body t in + [], defn, typ + in + let action_univs, t = elim_tscheme (a.action_univs, action_typ_templ) in + let action_params, action_defn, action_typ = destruct_action_typ_templ t in + let a' = + {a with action_univs = action_univs; + action_params = action_params; + action_defn = action_defn; + action_typ = action_typ} in + a' + in + let ed = { ed with + univs = univs; + binders = binders; + signature = U.apply_eff_sig elim_tscheme ed.signature; + combinators = apply_eff_combinators elim_tscheme ed.combinators; + actions = List.map elim_action ed.actions } in + {s with sigel=Sig_new_effect ed} + + | Sig_sub_effect sub_eff -> + let elim_tscheme_opt = function + | None -> None + | Some (us, t) -> let us, _, t = elim_uvars_aux_t env us [] t in Some (us, t) + in + let sub_eff = {sub_eff with lift = elim_tscheme_opt sub_eff.lift; + lift_wp = elim_tscheme_opt sub_eff.lift_wp} in + {s with sigel=Sig_sub_effect sub_eff} + + | Sig_effect_abbrev {lid; us=univ_names; bs=binders; comp; cflags=flags} -> + let univ_names, binders, comp = elim_uvars_aux_c env univ_names binders comp in + {s with sigel = Sig_effect_abbrev {lid; us=univ_names; bs=binders; comp; cflags=flags}} + + | Sig_pragma _ -> + s + + (* These should never happen, they should have been elaborated by now *) + | Sig_fail _ + | Sig_splice _ -> + s + + | Sig_polymonadic_bind {m_lid=m; + n_lid=n; + p_lid=p; + tm=(us_t, t); + typ=(us_ty, ty); + kind=k} -> + let us_t, _, t = elim_uvars_aux_t env us_t [] t in + let us_ty, _, ty = elim_uvars_aux_t env us_ty [] ty in + { s with sigel = Sig_polymonadic_bind {m_lid=m; + n_lid=n; + p_lid=p; + tm=(us_t, t); + typ=(us_ty, ty); + kind=k} } + + | Sig_polymonadic_subcomp {m_lid=m; n_lid=n; tm=(us_t, t); typ=(us_ty, ty); kind=k} -> + let us_t, _, t = elim_uvars_aux_t env us_t [] t in + let us_ty, _, ty = elim_uvars_aux_t env us_ty [] ty in + { s with sigel = Sig_polymonadic_subcomp {m_lid=m; + n_lid=n; + tm=(us_t, t); + typ=(us_ty, ty); + kind=k} } + + +let erase_universes env t = + normalize [EraseUniverses; AllowUnboundUniverses] env t + +let unfold_head_once env t = + let aux f us args = + match Env.lookup_nonrec_definition [Env.Unfold delta_constant] env f.fv_name.v with + | None -> None + | Some head_def_ts -> + let _, head_def = Env.inst_tscheme_with head_def_ts us in + let t' = S.mk_Tm_app head_def args t.pos in + let t' = normalize [Env.Beta; Env.Iota] env t' in + Some t' + in + let head, args = U.head_and_args t in + match (SS.compress head).n with + | Tm_fvar fv -> aux fv [] args + | Tm_uinst({n=Tm_fvar fv}, us) -> aux fv us args + | _ -> None + +let get_n_binders' (env:Env.env) (steps : list step) (n:int) (t:term) : list binder & comp = + let rec aux (retry:bool) (n:int) (t:term) : list binder & comp = + let bs, c = U.arrow_formals_comp t in + let len = List.length bs in + match bs, c with + (* Got no binders, maybe retry after normalizing *) + | [], _ when retry -> + aux false n (unfold_whnf' steps env t) + + (* Can't retry, stop *) + | [], _ when not retry -> + (bs, c) + + (* Exactly what we wanted, return *) + | bs, c when len = n -> + (bs, c) + + (* Plenty of binders, grab as many as needed and finish *) + | bs, c when len > n -> + let bs_l, bs_r = List.splitAt n bs in + (bs_l, S.mk_Total (U.arrow bs_r c)) + + (* We need more, descend if `c` is total *) + | bs, c when len < n && U.is_total_comp c && not (U.has_decreases c) -> + let (bs', c') = aux true (n-len) (U.comp_result c) in + (bs@bs', c') + + (* Not enough, but we can't descend, just return *) + | bs, c -> + (bs, c) + in + aux true n t + +let get_n_binders env n t = get_n_binders' env [] n t + +let () = + __get_n_binders := get_n_binders' + +let maybe_unfold_head_fv (env:Env.env) (head:term) + : option term + = let fv_us_opt = + match (SS.compress head).n with + | Tm_uinst ({n=Tm_fvar fv}, us) -> Some (fv, us) + | Tm_fvar fv -> Some (fv, []) + | _ -> None + in + match fv_us_opt with + | None -> None + | Some (fv, us) -> + match Env.lookup_nonrec_definition [Unfold delta_constant] env fv.fv_name.v with + | None -> None + | Some (us_formals, defn) -> + let subst = mk_univ_subst us_formals us in + SS.subst subst defn |> Some + +let rec maybe_unfold_aux (env:Env.env) (t:term) : option term = + match (SS.compress t).n with + | Tm_match {scrutinee=t0; ret_opt; brs; rc_opt} -> + BU.map_option + (fun t0 -> S.mk (Tm_match {scrutinee=t0; ret_opt; brs; rc_opt}) t.pos) + (maybe_unfold_aux env t0) + | Tm_fvar _ + | Tm_uinst _ -> maybe_unfold_head_fv env t + | _ -> + let head, args = U.leftmost_head_and_args t in + if args = [] + then maybe_unfold_head_fv env head + else + match maybe_unfold_aux env head with + | None -> None + | Some head -> S.mk_Tm_app head args t.pos |> Some + +let maybe_unfold_head (env:Env.env) (t:term) : option term = + BU.map_option + (normalize [Beta;Iota;Weak;HNF] env) + (maybe_unfold_aux env t) diff --git a/src/typechecker/FStarC.TypeChecker.Normalize.fsti b/src/typechecker/FStarC.TypeChecker.Normalize.fsti new file mode 100644 index 00000000000..8a66b5062ae --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Normalize.fsti @@ -0,0 +1,80 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.TypeChecker.Normalize +open FStarC +open FStarC.Compiler.Effect + +open FStarC.TypeChecker +open FStarC.Syntax.Syntax +open FStarC.TypeChecker.Common +open FStarC.TypeChecker.Env +open FStarC.TypeChecker.Cfg + +val eta_expand_with_type :Env.env -> term -> typ -> term +val eta_expand: Env.env -> term -> term +val normalize: steps -> Env.env -> term -> term +val normalize_universe: Env.env -> universe -> universe +val normalize_comp: steps -> Env.env -> comp -> comp +val normalize_refinement: steps -> Env.env -> typ -> typ +val whnf_steps: list step +val unfold_whnf': steps -> Env.env -> term -> term +val unfold_whnf: Env.env -> term -> term +val reduce_uvar_solutions:Env.env -> term -> term +val non_info_norm: Env.env -> term -> bool + +(* + * The maybe versions of ghost_to_pure only promote + * when the type of the computation is non-informative + * else the input comp is returned as is + *) +val maybe_ghost_to_pure: Env.env -> comp -> comp +val maybe_ghost_to_pure_lcomp: Env.env -> lcomp -> lcomp + +(* + * The two input computations are to be composed or related by subcomp + * These functions first call the maybe versions of ghost_to_pure, and then + * if one of them is erasable, and the other is GHOST, + * the GHOST one is promoted to PURE, see their implementation for more details + *) +val ghost_to_pure2 : Env.env -> (comp & comp) -> (comp & comp) +val ghost_to_pure_lcomp2 : Env.env -> (lcomp & lcomp) -> (lcomp & lcomp) + +val normalize_with_primitive_steps : list Primops.primitive_step -> steps -> Env.env -> term -> term +val term_to_string: Env.env -> term -> string +val term_to_doc: Env.env -> term -> Pprint.document +val comp_to_string: Env.env -> comp -> string +val comp_to_doc: Env.env -> comp -> Pprint.document +val elim_uvars: Env.env -> sigelt -> sigelt +val erase_universes: Env.env -> term -> term + +(* Note: This will default any unresolved universe variables to U_zero. *) +val remove_uvar_solutions: Env.env -> term -> term + +val unfold_head_once: Env.env -> term -> option term +val unembed_binder_knot : ref (option (FStarC.Syntax.Embeddings.embedding binder)) + +val is_extract_as_attr : attribute -> option term +val has_extract_as_attr : Env.env -> Ident.lid -> option term + +val reflection_env_hook : ref (option Env.env) + +(* Destructs the term as an arrow type and returns its binders and +computation type. Only grabs up to [n] binders, and normalizes only as +needed to discover the shape of the arrow. The binders are opened. *) +val get_n_binders : Env.env -> int -> term -> list binder & comp + +val maybe_unfold_head : Env.env -> term -> option term diff --git a/src/typechecker/FStarC.TypeChecker.PatternUtils.fst b/src/typechecker/FStarC.TypeChecker.PatternUtils.fst new file mode 100644 index 00000000000..eea2cf67665 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.PatternUtils.fst @@ -0,0 +1,272 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.TypeChecker.PatternUtils +open FStarC.Compiler.Effect +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.Errors +open FStarC.TypeChecker +open FStarC.Syntax +open FStarC.TypeChecker.Env +open FStarC.Syntax.Syntax +open FStarC.Ident +open FStarC.Syntax.Subst +open FStarC.TypeChecker.Common + +type lcomp_with_binder = option bv & lcomp + +module SS = FStarC.Syntax.Subst +module S = FStarC.Syntax.Syntax +module BU = FStarC.Compiler.Util +module U = FStarC.Syntax.Util +module P = FStarC.Syntax.Print +module C = FStarC.Parser.Const + +open FStarC.Class.Show + +let dbg_Patterns = Debug.get_toggle "Patterns" + +(************************************************************************) +(* Utilities on patterns *) +(************************************************************************) + +let rec elaborate_pat env p = //Adds missing implicit patterns to constructor patterns + let maybe_dot inaccessible a r = + if inaccessible + then withinfo (Pat_dot_term None) r + else withinfo (Pat_var a) r + in + match p.v with + | Pat_cons({fv_qual=Some (Unresolved_constructor _)}, _, _) -> + (* Unresolved constructors cannot be elaborated yet. + tc_pat has to resolve it first. *) + p + + | Pat_cons(fv, us_opt, pats) -> + let pats = List.map (fun (p, imp) -> elaborate_pat env p, imp) pats in + let _, t = Env.lookup_datacon env fv.fv_name.v in + let f, _ = U.arrow_formals t in + let rec aux formals pats = + match formals, pats with + | [], [] -> [] + | [], _::_ -> + raise_error fv.fv_name.v Errors.Fatal_TooManyPatternArguments "Too many pattern arguments" + | _::_, [] -> //fill the rest with dot patterns, if all the remaining formals are implicit + formals |> + List.map + (fun fml -> + let t, imp = fml.binder_bv, fml.binder_qual in + match imp with + | Some (Implicit inaccessible) -> + let a = Syntax.new_bv (Some (Syntax.range_of_bv t)) tun in + let r = range_of_lid fv.fv_name.v in + maybe_dot inaccessible a r, true + + | _ -> + raise_error fv.fv_name.v Errors.Fatal_InsufficientPatternArguments + (BU.format1 "Insufficient pattern arguments (%s)" + (show p))) + + | f::formals', (p, p_imp)::pats' -> + begin + match f.binder_bv, f.binder_qual with + | (_, Some (Implicit inaccessible)) + when inaccessible && p_imp -> //we have an inaccessible pattern but the user wrote a pattern there explicitly + begin + match p.v with + | Pat_dot_term _ -> + (p, true)::aux formals' pats' + + // Only allow it if it won't be bound + | Pat_var v when string_of_id (v.ppname) = Ident.reserved_prefix -> + let a = Syntax.new_bv (Some p.p) tun in + let p = maybe_dot inaccessible a (range_of_lid fv.fv_name.v) in + (p, true)::aux formals' pats' + + | _ -> + raise_error p.p Errors.Fatal_InsufficientPatternArguments + (BU.format1 "This pattern (%s) binds an inaccesible argument; use a wildcard ('_') pattern" + (show p)) + end + + | (_, Some (Implicit _)) when p_imp -> + (p, true)::aux formals' pats' + + | (_, Some (Implicit inaccessible)) -> + let a = Syntax.new_bv (Some p.p) tun in + let p = maybe_dot inaccessible a (range_of_lid fv.fv_name.v) in + (p, true)::aux formals' pats + + | (_, imp) -> + (p, S.is_bqual_implicit imp)::aux formals' pats' + end + in + {p with v=Pat_cons(fv, us_opt, aux f pats)} + | _ -> p + +exception Raw_pat_cannot_be_translated +let raw_pat_as_exp (env:Env.env) (p:pat) + : option (term & list bv) + = let rec aux bs p = + match p.v with + | Pat_constant c -> + let e = + match c with + | FStarC.Const.Const_int(repr, Some sw) -> + FStarC.ToSyntax.ToSyntax.desugar_machine_integer env.dsenv repr sw p.p + | _ -> + mk (Tm_constant c) p.p + in + e, bs + + | Pat_dot_term eopt -> + begin + match eopt with + | None -> raise Raw_pat_cannot_be_translated + | Some e -> SS.compress e, bs + end + + | Pat_var x -> + mk (Tm_name x) p.p, x::bs + + | Pat_cons(fv, us_opt, pats) -> + let args, bs = + List.fold_right + (fun (p, i) (args, bs) -> + let ep, bs = aux bs p in + ((ep, as_aqual_implicit i) :: args), bs) + pats + ([], bs) + in + let hd = Syntax.fv_to_tm fv in + let hd = + match us_opt with + | None -> hd + | Some us -> S.mk_Tm_uinst hd us + in + let e = mk_Tm_app hd args p.p in + e, bs + in + try Some (aux [] p) + with Raw_pat_cannot_be_translated -> None + +(* + pat_as_exps allow_implicits env p: + Turns a pattern p into a triple: +*) +let pat_as_exp (introduce_bv_uvars:bool) + (inst_pat_cons_univs:bool) + (env:Env.env) + (p:pat) + : (list bv (* pattern-bound variables (which may appear in the branch of match) *) + & term (* expressions corresponding to the pattern *) + & guard_t (* guard with just the implicit variables introduced in the pattern *) + & pat) = (* decorated pattern, with all the missing implicit args in p filled in *) + let intro_bv (env:Env.env) (x:bv) :(bv & guard_t & Env.env) = + if not introduce_bv_uvars + then {x with sort=S.tun}, Env.trivial_guard, env + else let t, _ = U.type_u() in + let t_x, _, guard = new_implicit_var_aux "pattern bv type" (S.range_of_bv x) env t (Allow_untyped "pattern bv type") None false in + let x = {x with sort=t_x} in + x, guard, Env.push_bv env x + in + // TODO: remove wildcards + let rec pat_as_arg_with_env env (p:pat) : + (list bv //all pattern-bound vars including wild-cards, in proper order + & list bv //just the accessible vars, for the disjunctive pattern test + & list bv //just the wildcards + & Env.env //env extending with the pattern-bound variables + & term //the pattern as a term/typ + & guard_t //guard with all new implicits + & pat) = //the elaborated pattern itself + match p.v with + | Pat_constant c -> + let e = + match c with + | FStarC.Const.Const_int(repr, Some sw) -> + FStarC.ToSyntax.ToSyntax.desugar_machine_integer env.dsenv repr sw p.p + | _ -> + mk (Tm_constant c) p.p + in + ([], [], [], env, e, trivial_guard, p) + + | Pat_dot_term eopt -> + (match eopt with + | None -> + if !dbg_Patterns + then begin + if not env.phase1 + then BU.print1 "Found a non-instantiated dot pattern in phase2 (%s)\n" + (show p) + end; + let k, _ = U.type_u () in + let t, _, g = new_implicit_var_aux "pat_dot_term type" p.p env k (Allow_ghost "pat dot term type") None false in + let e, _, g' = new_implicit_var_aux "pat_dot_term" p.p env t (Allow_ghost "pat dot term") None false in + let p = {p with v=Pat_dot_term (Some e)} in + [], [], [], env, e, conj_guard g g', p + | Some e -> [], [], [], env, e, Env.trivial_guard, p) + + | Pat_var x -> + let x, g, env = intro_bv env x in + let e = mk (Tm_name x) p.p in + ([x], [x], [], env, e, g, p) + + | Pat_cons(fv, us_opt, pats) -> + let (b, a, w, env, args, guard, pats) = + pats |> + List.fold_left + (fun (b, a, w, env, args, guard, pats) (p, imp) -> + let (b', a', w', env, te, guard', pat) = pat_as_arg_with_env env p in + let arg = if imp then iarg te else as_arg te in + (b'::b, a'::a, w'::w, env, arg::args, conj_guard guard guard', (pat, imp)::pats)) + ([], [], [], env, [], trivial_guard, []) + in + let inst_head hd us_opt = + match us_opt with + | None -> hd + | Some us -> Syntax.mk_Tm_uinst hd us + in + let hd, us_opt = + let hd = Syntax.fv_to_tm fv in + if not inst_pat_cons_univs + || Some? us_opt + then inst_head hd us_opt, us_opt + else let us, _ = Env.lookup_datacon env (Syntax.lid_of_fv fv) in + if List.length us = 0 then hd, Some [] + else Syntax.mk_Tm_uinst hd us, Some us + in + let e = mk_Tm_app hd (args |> List.rev) p.p in + (List.rev b |> List.flatten, + List.rev a |> List.flatten, + List.rev w |> List.flatten, + env, + e, + guard, + {p with v=Pat_cons(fv, us_opt, List.rev pats)}) + in + let one_pat env p = + let p = elaborate_pat env p in + let b, a, w, env, arg, guard, p = pat_as_arg_with_env env p in + match b |> BU.find_dup bv_eq with + | Some x -> + let m = show x in + raise_error p.p Errors.Fatal_NonLinearPatternVars (format1 "The pattern variable \"%s\" was used more than once" m) + | _ -> b, a, w, arg, guard, p + in + let b, _, _, tm, guard, p = one_pat env p in + b, tm, guard, p diff --git a/src/typechecker/FStarC.TypeChecker.PatternUtils.fsti b/src/typechecker/FStarC.TypeChecker.PatternUtils.fsti new file mode 100644 index 00000000000..b77e8c5a4d8 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.PatternUtils.fsti @@ -0,0 +1,41 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.TypeChecker.PatternUtils +open FStarC.Compiler.Effect +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.Errors +open FStarC.TypeChecker +open FStarC.Syntax +open FStarC.TypeChecker.Env +open FStarC.Syntax.Syntax +open FStarC.Ident +open FStarC.Syntax.Subst +open FStarC.TypeChecker.Common + +val elaborate_pat : env -> pat -> pat +val raw_pat_as_exp (_:Env.env) (p:pat) : option (term & list bv) + +val pat_as_exp: introduce_bv_uvars:bool + -> inst_pat_cons_univs:bool (* whether it should instantiate the universes for data constructor patterns, on when called from Rel *) + -> env:Env.env + -> p:pat + -> list bv (* pattern-bound variables (which may appear in the branch of match) *) + & term (* expressions corresponding to the pattern *) + & guard_t (* guard with all implicits introduced in the pattern *) + & pat (* decorated pattern, with all the missing implicit args in p filled in *) diff --git a/src/typechecker/FStarC.TypeChecker.Positivity.fst b/src/typechecker/FStarC.TypeChecker.Positivity.fst new file mode 100644 index 00000000000..78ffc1ee43f --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Positivity.fst @@ -0,0 +1,1331 @@ +(* + Copyright 2008-2023 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + + Authors: A. Rastogi, N. Swamy +*) + +module FStarC.TypeChecker.Positivity + +open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.TypeChecker.Env +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.Ident +open FStarC.Errors +open FStar.List.Tot +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module BU = FStarC.Compiler.Util +module U = FStarC.Syntax.Util +module N = FStarC.TypeChecker.Normalize +module L = FStarC.Compiler.List +module C = FStarC.Parser.Const + +open FStarC.Class.Setlike +open FStarC.Class.Show +open FStarC.Class.Tagged + +let dbg_Positivity = Debug.get_toggle "Positivity" +let debug_positivity (env:env_t) (msg:unit -> string) : unit = + if !dbg_Positivity + then BU.print_string ("Positivity::" ^ msg () ^ "\n") + +(** + + This module implements the strict positivity check on inductive type + definitions + + * The idea of strict positivity is broadly described here: + http://fstar-lang.org/tutorial/book/part2/part2_inductive_type_families.html#strictly-positive-definitions + + + * tests/micro-benchmarks/Positivity.fst provides several + small examples to exercises various cases. + + A challenge is that the definition of strict positivity is not + completely settled among the various dependently typed proof + assistants. Notably, Lean, Coq, Agda, all implement slight + variations, all incomparable in permissiveness. + + What is standard is that every occurrence of the type in question + must be strictly positive, i.e., no occurrences allowed to the left + of an arrow. + + However, there is a lot of variation in how the indices and + parameters of an inductive type are handled. + + Here's a summary of what F* supports: + + 1. Non-uniformly recursive parameters + + type t a b c = + | T : t a (b & b) c -> t a b c + + + Here, a is uniformly recursive. + b is non-uniformly recursive. + Since c follows b, which is non-uniform, it is also considered non-uniform + + i.e., only a prefix of the parameters may be considered uniform + + 2. For an inductive type constructor, every non-uniform parameter or index + may be considered to be an _arity_ or not + + An arity is a `Type`, or an arrow `t -> arity` + + A term is indexed by an arity if it has type t0 -> ... -> tn -> Type + and any of the ti are themselves arities + + Given a well-typed term `t v0 ... vn`, we check that if the type of the prefix `t [v0...vi)` + is `ti -> ... Type` + and if `ti` is an arity (and is the type of `vi`) + then the type being defined cannot appear free in `vi` + + + E.g., Consider a term (t : a:Type -> x:a -> x -> (Type -> Type) -> bool -> Type) + applied as (t Type nat 0 option true) + The first index of t is an arity + (t Type : x:Type -> x -> (Type -> Type) -> bool -> Type) is arity indexed + (t Type nat : nat -> ...) is not arity indexed + (t Type nat 0 : (Type -> Type) -> ...) is arity indexed + (t Type nat 0 option : bool -> Type) is not arity indexed + (t Type nat 0 option true : Type) is not arity indexed + + 3. A type t is strictly-positive in the indexing of s, if `t` does + not appear free in any of the arity indexes of s. + + E.g., + + type s (a:Type) : bool -> Type = + | S : s a true + + type t = + | T : f:option t -> s t (Some? #t f) -> t + + The type `t` is well-formed in `s t (Some? #t f)` + since it appears only in a parameter of `s` + and in a non-arity index of s + + + However, this is forbidden: + + type f (a:Type -> Type) : Type + + type t : Type -> Type = + | T : t (f t) + + since although in `f t`, `t` only instantiates a parameter of `f` + in `t (f t)`, `t` appears free in an arity index of `t` itself + + Note, Agda does allow the type `t` above, although it rejects + + type t : Type -> Type + | T : t (t bool) + *) + +//////////////////////////////////////////////////////////////////////////////// +// Some general utilities +//////////////////////////////////////////////////////////////////////////////// + +(* A debugging utility to print a list of lids *) +let string_of_lids lids = + List.map string_of_lid lids |> String.concat ", " + +(* Normalize a term before checking for non-strictly positive occurrences *) +let normalize env t = + N.normalize [Env.Beta; + Env.HNF; + Env.Weak; + Env.Iota; + Env.Exclude Env.Zeta; + Env.UnfoldUntil delta_constant] + env + t + + +(* Given a type or data constructor d : dt + and parameters to an instance of the type + instantiate the arguments of d corresponding to the type parameters + with all_params *) +let apply_constr_arrow (dlid:lident) (dt:term) (all_params:list arg) + : term + = let rec aux t args = + match (SS.compress t).n, args with + | _, [] -> U.canon_arrow t + | Tm_arrow {bs=b::bs; comp=c}, a::args -> + let tail = + match bs with + | [] -> U.comp_result c + | _ -> S.mk (Tm_arrow {bs; comp=c}) t.pos + in + let b, tail = SS.open_term_1 b tail in + let tail = SS.subst [NT(b.binder_bv, fst a)] tail in + aux tail args + | _ -> + raise_error + (Ident.range_of_lid dlid) + Errors.Error_InductiveTypeNotSatisfyPositivityCondition + (BU.format3 "Unexpected application of type parameters %s to a data constructor %s : %s" + (Print.args_to_string all_params) + (show dlid) + (show dt)) + in + aux dt all_params + +(* Checks if ty_lid appears as an fvar in t *) +let ty_occurs_in (ty_lid:lident) + (t:term) + : bool + = mem ty_lid (Free.fvars t) + +(* Checks if `t` is a name or fv and returns it, if so. *) +let rec term_as_fv_or_name (t:term) + : option (either (fv & universes) bv) + = match (SS.compress t).n with + | Tm_name x -> + Some (Inr x) + + | Tm_fvar fv -> + Some (Inl (fv, [])) + + | Tm_uinst (t, us) -> + (match (SS.compress t).n with + | Tm_fvar fv -> Some (Inl (fv, us)) + | _ -> failwith "term_as_fv_or_name: impossible non fvar in uinst") + + | Tm_ascribed {tm=t} -> + term_as_fv_or_name t + + | _ -> None + +let open_sig_inductive_typ env se = + match se.sigel with + | Sig_inductive_typ {lid; us=ty_us; params=ty_params} -> + let ty_usubst, ty_us = SS.univ_var_opening ty_us in + let env = push_univ_vars env ty_us in + let ty_params = SS.subst_binders ty_usubst ty_params in + let ty_params = SS.open_binders ty_params in + let env = push_binders env ty_params in + env, (lid, ty_us, ty_params) + | _ -> failwith "Impossible!" + +(* Map bv to an unqualified long identifier with the same pp_name + just for positivity-checking. + + It cannot clash with any user long identifier, since those + are always qualified to a module +*) +let name_as_fv_in_t (t:term) (bv:bv) + : term & lident + = let fv_lid = set_lid_range (lid_of_str (FStarC.Ident.string_of_id bv.ppname)) (range_of_bv bv) in + let fv = S.tconst fv_lid in + let t = SS.subst [NT (bv, fv)] t in + t, fv_lid + +//////////////////////////////////////////////////////////////////////////////// +// Uniformly recursive parameters +//////////////////////////////////////////////////////////////////////////////// + +(* The least value of f on the elements of l, or def if l is empty *) +let rec min_l (#a:Type) (def:int) (l:list a) (f:a -> int) = + match l with + | [] -> def + | hd::tl -> min (f hd) (min_l def tl f) + +(* For each m in mutuals, + find the greatest prefix of (p0...pi) of params such that + every occurrence of m in ty + is of the form (m p0 ... pi) + + The (p0 ... pi) are uniformly recursive in ty. + + If m does not occur in ty, then ALL the params are considered uniformly recursive + *) +let max_uniformly_recursive_parameters (env:env_t) + (mutuals:list lident) + (params:list bv) + (ty:term) + : int + = let max_matching_prefix (longer:list 'a) (shorter:list 'b) (f:'a -> 'b -> bool) + : option int + = let rec aux n ls ms = + match ls, ms with + | _, [] -> Some n + | l::ls, m::ms -> + if f l m then aux (n + 1) ls ms + else Some n + | _ -> None + in + aux 0 longer shorter + in + let ty = normalize env ty in + let n_params = L.length params in + let compare_name_bv (x:arg) (y:bv) = + match (SS.compress (fst x)).n with + | Tm_name x -> S.bv_eq x y + | _ -> false + in + let min_l (#a:Type) f l = min_l #a n_params f l in + let params_to_string () = + (List.map show params |> String.concat ", ") + in + debug_positivity env (fun _ -> + BU.format2 "max_uniformly_recursive_parameters? params=%s in %s" + (params_to_string()) + (show ty)); + let rec aux ty = + debug_positivity env (fun _ -> + BU.format1 "max_uniformly_recursive_parameters.aux? %s" + (show ty)); + if List.for_all (fun mutual -> not (ty_occurs_in mutual ty)) mutuals + then n_params + else ( + match (SS.compress ty).n with + | Tm_name _ + | Tm_fvar _ + | Tm_uinst _ + | Tm_type _ + | Tm_constant _ -> + n_params + | Tm_refine {b=x; phi=f} -> + min (aux x.sort) + (let _, f = SS.open_term [S.mk_binder x] f in + aux f) + | Tm_app _ -> + let head, args = U.head_and_args ty in + begin + match (U.un_uinst head).n with + | Tm_fvar fv -> + if L.existsML (fv_eq_lid fv) mutuals + then ( + debug_positivity env (fun _ -> + BU.format2 "Searching for max matching prefix of params=%s in args=%s" + (params_to_string()) + (Print.args_to_string args)); + match max_matching_prefix args params compare_name_bv with + | None -> 0 + | Some n -> n + ) + else min_l args (fun (arg, _) -> aux arg) + | _ -> + min (aux head) + (min_l args (fun (arg, _) -> aux arg)) + end + | Tm_abs _ -> + let bs, body, _ = U.abs_formals ty in + min (min_l bs (fun b -> aux b.binder_bv.sort)) + (aux body) + | Tm_arrow _ -> + let bs, r = U.arrow_formals ty in + min (min_l bs (fun b -> aux b.binder_bv.sort)) + (aux r) + | Tm_match {scrutinee; brs=branches} -> + min (aux scrutinee) + (min_l branches + (fun (p, _, t) -> + let bs = List.map mk_binder (pat_bvs p) in + let bs, t = SS.open_term bs t in + aux t)) + | Tm_meta {tm=t} + | Tm_ascribed {tm=t} -> + aux t + | _ -> + 0 + ) + in + let res = aux ty in + debug_positivity env (fun _ -> + BU.format3 "result: max_uniformly_recursive_parameters(params=%s in %s) = %s" + (params_to_string()) + (show ty) + (string_of_int res)); + res + +(* The sig : sigelt is a Sig_bundle describing a mutually inductive nest of types + + For every type constructor Sig_inductive_typ, find the greatest prefix of + its parameters that occur uniformly recursively in all its data + constructors. + + This populates the num_uniform_parameters field of the Sig_inductive_typ + + Note: Every parameter marked strictly_positive MUST be uniformly recursive + +*) +let mark_uniform_type_parameters (env:env_t) + (sig:sigelt) + : sigelt + = let mark_tycon_parameters tc datas = + let Sig_inductive_typ {lid=tc_lid; us; params=ty_param_binders; t; mutuals; ds=data_lids; injective_type_params } = tc.sigel in + let env, (tc_lid, us, ty_params) = open_sig_inductive_typ env tc in + let _, ty_param_args = U.args_of_binders ty_params in + let datacon_fields : list (list binder) = + List.filter_map + (fun data -> + match data.sigel with + | Sig_datacon {lid=d_lid; us=d_us; t=dt; ty_lid=tc_lid'} -> + if Ident.lid_equals tc_lid tc_lid' + then ( + let dt = SS.subst (mk_univ_subst d_us (L.map U_name us)) dt in + Some (fst (U.arrow_formals (apply_constr_arrow d_lid dt ty_param_args))) + ) + else None + | _ -> None) + datas + in + let ty_param_bvs = L.map (fun b -> b.binder_bv) ty_params in + let n_params = L.length ty_params in + let min_l #a f l = min_l #a n_params f l in + let max_uniform_prefix = + min_l datacon_fields + (fun (fields_of_one_datacon:list binder) -> + min_l fields_of_one_datacon + (fun (field:binder) -> + max_uniformly_recursive_parameters + env + mutuals + ty_param_bvs + field.binder_bv.sort)) + in + if max_uniform_prefix < n_params + then ( + let _, non_uniform_params = List.splitAt max_uniform_prefix ty_param_binders in + List.iter + (fun param -> + if param.binder_positivity = Some BinderStrictlyPositive + then ( //if marked strictly positive, it must be uniform + raise_error + (range_of_bv param.binder_bv) + Error_InductiveTypeNotSatisfyPositivityCondition + (BU.format1 "Binder %s is marked strictly positive, \ + but it is not uniformly recursive" + (show param)) + )) + non_uniform_params + ); + let sigel = Sig_inductive_typ {lid=tc_lid; + us; + params=ty_param_binders; + num_uniform_params=Some max_uniform_prefix; + t; + mutuals; + ds=data_lids; + injective_type_params} in + { tc with sigel } + in + match sig.sigel with + | Sig_bundle {ses; lids} -> + let tcs, datas = L.partition (fun se -> Sig_inductive_typ? se.sigel) ses in + let tcs = List.map (fun tc -> mark_tycon_parameters tc datas) tcs in + { sig with sigel = Sig_bundle {ses=tcs@datas; lids} } + + | _ -> sig + +//////////////////////////////////////////////////////////////////////////////// +// Arities and indexes +//////////////////////////////////////////////////////////////////////////////// + +(* Decides if t could be an arity? i.e., a Type or a t -> ... -> Type? *) +let may_be_an_arity env (t:term) + : bool + = let t = normalize env t in + let rec aux t = + match (SS.compress t).n with + | Tm_name _ + | Tm_constant _ + | Tm_abs _ + | Tm_lazy _ + | Tm_quoted _ -> false + + | Tm_fvar _ + | Tm_uinst _ + | Tm_app _ -> ( + let head, args = U.head_and_args t in + match (U.un_uinst head).n with + | Tm_fvar fv -> + (match Env.lookup_sigelt env fv.fv_name.v with + | None -> + //We couldn't find it; err conservatively ... this could be an arity + true + | Some se -> + match se.sigel with + | Sig_let _ -> + true //maybe an arity, this definition was not unfolded + | _ -> false + ) + + | _ -> true //maybe + ) + + | Tm_type _ -> true + | Tm_arrow _ -> + let _, t = U.arrow_formals t in + aux t + | Tm_refine {b=x} -> aux x.sort + | Tm_match {brs=branches} -> + List.existsML + (fun (p, _, t) -> + let bs = List.map mk_binder (pat_bvs p) in + let bs, t = SS.open_term bs t in + aux t) + branches + + | Tm_meta {tm=t} + | Tm_ascribed {tm=t} -> + aux t + + (* maybes *) + | Tm_uvar _ + | Tm_let _ -> + true + + | Tm_delayed _ + | Tm_bvar _ + | Tm_unknown -> + failwith "Impossible" + in + aux t + +(* t is an application of a type constructor T ps is + with parameters ps and indexes is. + + Check that the mutuals do not occur in any of the indexes + whose instantiated type may be arity. + + See the comment at the head of the file for some context about + indexes and arities + *) +let check_no_index_occurrences_in_arities env mutuals (t:term) = + debug_positivity env (fun _ -> + BU.format2 "check_no_index_occurrences of (mutuals %s) in arities of %s" + (string_of_lids mutuals) + (show t)); + + (* Check that none of the mutuals appear free in the index term *) + let no_occurrence_in_index fv mutuals (index:arg) = + (* The built-in predicates: + FStar.FunctionalExtensionality.on_domain + FStar.FunctionalExtensionality.on_domain_g + are special. + + Their two type arguments do not count towards positivity, + since they are there only as an artifact of describing the + type of their third argument + *) + let fext_on_domain_index_sub_term index = + let head, args = U.head_and_args index in + match (U.un_uinst head).n, args with + | Tm_fvar fv, [_td; _tr; (f, _)] -> + if S.fv_eq_lid fv C.fext_on_domain_lid + || S.fv_eq_lid fv C.fext_on_domain_g_lid + then f (* if the index is on_domain(_g) #t #s f, + return only f *) + else index + | _ -> index + in + let index, _ = index in + L.iter (fun mutual -> + if ty_occurs_in mutual (fext_on_domain_index_sub_term index) + then raise_error index Errors.Error_InductiveTypeNotSatisfyPositivityCondition + (BU.format3 "Type %s is not strictly positive since it instantiates \ + a non-uniformly recursive parameter or index %s of %s" + (string_of_lid mutual) + (show index) + (string_of_lid fv))) + mutuals + in + let no_occurrence_in_indexes fv mutuals (indexes:list arg) = + L.iter (no_occurrence_in_index fv mutuals) indexes + in + let head, args = U.head_and_args t in + match (U.un_uinst head).n with + | Tm_fvar fv -> + begin + match Env.num_inductive_uniform_ty_params env fv.fv_name.v with + | None -> + //the head is not (visibly) a inductive type; nothing to check + () + | Some n -> + if List.length args <= n + then () //they are all uniform parameters, nothing to check + else ( + match Env.try_lookup_lid env fv.fv_name.v with + | None -> no_occurrence_in_indexes fv.fv_name.v mutuals args + | Some ((_us, i_typ), _) -> + debug_positivity env (fun _ -> + BU.format2 "Checking arity indexes of %s (num uniform params = %s)" + (show t) + (string_of_int n)); + let params, indices = List.splitAt n args in + let inst_i_typ = apply_constr_arrow fv.fv_name.v i_typ params in + let formals, _sort = U.arrow_formals inst_i_typ in + let rec aux subst formals indices = + match formals, indices with + | _, [] -> () + | f::formals, i::indices -> + let f_t = SS.subst subst f.binder_bv.sort in + if may_be_an_arity env f_t + then ( + debug_positivity env (fun _ -> + BU.format2 "Checking %s : %s (arity)" + (show (fst i)) + (show f_t)); + no_occurrence_in_index fv.fv_name.v mutuals i + ) + else ( + debug_positivity env (fun _ -> + BU.format2 "Skipping %s : %s (non-arity)" + (show (fst i)) + (show f_t)) + ); + let subst = NT(f.binder_bv, fst i)::subst in + aux subst formals indices + | [], _ -> + no_occurrence_in_indexes fv.fv_name.v mutuals indices + in + aux [] formals indices + ) + end + | _ -> () + +//////////////////////////////////////////////////////////////////////////////// +// Do the mutuals not occur in t? +// Or, if they do, do they only instantiate unused parameters? +// Expects t to be normalized +//////////////////////////////////////////////////////////////////////////////// +let mutuals_unused_in_type (mutuals:list lident) t = + let mutuals_occur_in t = BU.for_some (fun lid -> ty_occurs_in lid t) mutuals in + let rec ok t = + if not (mutuals_occur_in t) then true else + // fv_lid is used in t + // but we need to check that its occurrences only occur as arguments + // to functions whose corresponding paramaters are marked as unused + match (SS.compress t).n with + | Tm_bvar _ + | Tm_name _ + | Tm_constant _ + | Tm_type _ -> + //these cases violate the precondition that fv_lid is used in t + //so we should never get here + true + | Tm_fvar _ + | Tm_uinst _ -> + //in these cases, fv_lid is used in t + false + | Tm_abs {bs; body=t} -> + binders_ok bs && ok t + | Tm_arrow {bs; comp=c} -> + binders_ok bs && ok_comp c + | Tm_refine {b=bv; phi=t} -> + ok bv.sort && ok t + | Tm_app {hd=head; args} -> + if mutuals_occur_in head + then false + else List.for_all + (fun (a, qual) -> + (match qual with + | None -> false + | Some q -> U.contains_unused_attribute q.aqual_attributes) || + ok a) + args + | Tm_match {scrutinee=t; brs=branches} -> + ok t && + List.for_all + (fun (_, _, br) -> ok br) + branches + | Tm_ascribed {tm=t; asc} -> + ok t + | Tm_let {lbs=(_, lbs); body=t} -> + List.for_all (fun lb -> ok lb.lbtyp && ok lb.lbdef) lbs + && ok t + | Tm_uvar _ -> + false + | Tm_delayed _ -> + false + | Tm_meta {tm=t} -> + ok t + | _ -> + false + and binders_ok bs = + List.for_all (fun b -> ok b.binder_bv.sort) bs + and ok_comp c = + match c.n with + | Total t -> ok t + | GTotal t -> ok t + | Comp c -> + ok c.result_typ && + List.for_all (fun (a, _) -> ok a) c.effect_args + in + ok t + +//////////////////////////////////////////////////////////////////////////////// +// Main strict positivity check +//////////////////////////////////////////////////////////////////////////////// + +(** + unfolded_memo_t: This is a key data structure in the + strict positivity check for inductive types. + + Consider, for example, checking the positivity of + + type t = + | T : list t -> t + + We look at every constructor of the instantiation `list t` + and check that it is positive, after recording in the memo-table + that `list t` is positive. + + When we reach the `tl` field of `Cons : hd:t -> tl:list t -> list t`, + we find `list t` in the memo-table and avoid infinitely recursing + on it. +*) +//A type name, the instantiation, and the number of arguments +type unfolded_memo_elt = list (lident & args & int) +type unfolded_memo_t = ref unfolded_memo_elt + + +(* Check if `ilid args` is in the memo table. + Note: the memo table only constains instantiations of ilid to its parameters + whereas args also includes the indexes. So, we take the prefix of args +*) +let already_unfolded (ilid:lident) + (args:args) + (unfolded:unfolded_memo_t) + (env:env_t) + : bool + = List.existsML + (fun (lid, l, n) -> + Ident.lid_equals lid ilid && + List.length args >= n && + (let args = fst (L.splitAt n args) in + List.fold_left2 + (fun b a a' -> b && Rel.teq_nosmt_force env (fst a) (fst a')) + true + args + l)) + !unfolded + +(** The main check for strict positivity + + A summary of its general structure: + + There are four mutually recursive functions + + 1. ty_strictly_positive_in_type _ mutuals in_type _ + + This is the main function and checks that none of the mutuals + appear in_type in a non-strictly positive position + and in arity indexes of in_type + + 2. ty_strictly_positive_in_args _ mutuals head_t args _ + + Given a head term applied to args, where head is of type + head_t, this checks that if the mutuals appear in a arg, that + it does so strictly positively and the corresponding binder + of head_t is marked strictly positive. + + The head term is not an inductive type constructor + + 3. ty_strictly_positive_in_arguments_to_fvar _ mutuals t fv _ args _ + + fv may or may not be an inductive, and is not one of the + mutuals, and this checks that all the mutuals are strictly + positive in the arguments + + if is is not an inductive, we fall back to 2 + if it is an inductive, we check each of its constructors using 4 + + 4. ty_strictly_positive_in_datacon_of_applied_inductive _ mutuals dlid ilid _ args _ _ + + This considers every field of dlid applied to the type + parameters of the inductive ilid in args, and checks that the + mutuals are strictly positive in all the field types. +*) +let rec ty_strictly_positive_in_type (env:env) + (mutuals:list lident) + (in_type:term) + (unfolded:unfolded_memo_t) + : bool + = //normalize the type to unfold any type abbreviations + let in_type = normalize env in_type in + debug_positivity env (fun _ -> + BU.format2 + "Checking strict positivity of {%s} in type, after normalization %s " + (string_of_lids mutuals) + (show in_type)); + if List.for_all (fun mutual -> not (ty_occurs_in mutual in_type)) mutuals + then true //ty does not occur in in_type, so obviously strictly positive + else ( + debug_positivity env (fun _ -> "ty does occur in this type"); + + match (SS.compress in_type).n with + | Tm_fvar _ + | Tm_uinst _ + | Tm_type _ -> + debug_positivity env (fun _ -> + "Checking strict positivity in an fvar/Tm_uinst/Tm_type, return true"); + true //Type, and fvar constants are fine + + | Tm_ascribed {tm=t} + | Tm_meta {tm=t} -> + ty_strictly_positive_in_type env mutuals t unfolded + + | Tm_app {hd=t; args} -> //the binder type is an application + let fv_or_name_opt = term_as_fv_or_name t in + begin + match fv_or_name_opt with + | None -> + debug_positivity env (fun _ -> + BU.format2 "Failed to check positivity of %s in a term with head %s" + (string_of_lids mutuals) + (show t)); + //The head is not a name or an fv + //conservatively return false + false + + | Some (Inr x) -> //head is an name + begin + let head_ty, _pos = Env.lookup_bv env x in + debug_positivity env (fun _ -> + BU.format3 "Tm_app, head bv, in_type=%s, head_bv=%s, head_ty=%s" + (show in_type) + (show x) + (show head_ty)); + + //The check depends on the strict positivity annotations on the type of the name + ty_strictly_positive_in_args env mutuals head_ty args unfolded + end + + | Some (Inl (fv, us)) -> + begin + if FStarC.Compiler.List.existsML (Ident.lid_equals fv.fv_name.v) mutuals + then ( + //if the head is one of the mutually inductive types + //then check that ty_lid does not occur in the arguments + // + //E.g., we forbid `type t a = | T : t (t a) -> t a` + // and `type t a = | T : s (t a) -> t a + // and s a = | S : t a -> s a` + debug_positivity env (fun _ -> + BU.format1 + "Checking strict positivity in the Tm_app node where head lid is %s itself, \ + checking that ty does not occur in the arguments" + (Ident.string_of_lid fv.fv_name.v)); + List.for_all (fun (t, _) -> mutuals_unused_in_type mutuals t) args + ) + else ( + //check that the application is either to an inductive + //that we can show is strictly positive + //or is an fvar whose arguments are suitably decorated + //with strictly_positive attributes + debug_positivity env (fun _ -> + BU.format1 "Checking strict positivity in the Tm_app node, \ + head lid is not in %s, so checking nested positivity" + (string_of_lids mutuals)); + ty_strictly_positive_in_arguments_to_fvar + env + mutuals + in_type + fv.fv_name.v + us + args + unfolded + ) + end + end + + | Tm_arrow {comp=c} -> //in_type is an arrow + debug_positivity env (fun () -> "Checking strict positivity in Tm_arrow"); + let check_comp = + U.is_pure_or_ghost_comp c || + (c |> U.comp_effect_name + |> Env.norm_eff_name env + |> Env.lookup_effect_quals env + |> List.contains S.TotalEffect) in + if not check_comp + then ( + //t -> Dv _ + //is accepted as strictly positive in t + //since it is behind a Dv effect + debug_positivity env (fun _ -> + "Checking strict positivity , the arrow is impure, so return true"); + true + ) + else ( + debug_positivity env (fun _ -> + "Checking strict positivity for an arrow, checking \ + that ty does not occur in the binders, \ + and that it is strictly positive in the return type"); + let sbs, c = U.arrow_formals_comp in_type in + let return_type = FStarC.Syntax.Util.comp_result c in + let ty_lid_not_to_left_of_arrow = + List.for_all + (fun ({binder_bv=b}) -> mutuals_unused_in_type mutuals b.sort) + sbs + in + if ty_lid_not_to_left_of_arrow + then ( + (* and is strictly positive also in the return type *) + ty_strictly_positive_in_type + (push_binders env sbs) + mutuals + return_type + unfolded + ) + else false + ) + + + | Tm_refine {b=bv; phi=f} -> + debug_positivity env (fun _ -> + "Checking strict positivity in an Tm_refine, recur in the bv sort)"); + let [b], f = SS.open_term [S.mk_binder bv] f in + if ty_strictly_positive_in_type env mutuals b.binder_bv.sort unfolded + then let env = push_binders env [b] in + ty_strictly_positive_in_type env mutuals f unfolded + else false + + | Tm_match {scrutinee; brs=branches} -> + debug_positivity env (fun _ -> + "Checking strict positivity in an Tm_match, recur in the branches)"); + if L.existsML (fun mutual -> ty_occurs_in mutual scrutinee) mutuals + then ( + // type t = | MkT : match f t with | D x -> e + // is ok if {t,x} are strictly positive in e + List.for_all + (fun (p, _, t) -> + let bs = List.map mk_binder (pat_bvs p) in + let bs, t = SS.open_term bs t in + let t, mutuals = + List.fold_left + (fun (t, lids) b -> + let t, lid = name_as_fv_in_t t b.binder_bv in + t, lid::lids) + (t, mutuals) + bs + in + ty_strictly_positive_in_type env mutuals t unfolded) + branches + ) + else ( + List.for_all + (fun (p, _, t) -> + let bs = List.map mk_binder (pat_bvs p) in + let bs, t = SS.open_term bs t in + ty_strictly_positive_in_type (push_binders env bs) mutuals t unfolded) + branches + ) + + | Tm_abs _ -> + let bs, body, _ = U.abs_formals in_type in + //strictly positive in all the binders and the result + let rec aux env bs = + match bs with + | [] -> ty_strictly_positive_in_type env mutuals body unfolded + | b::bs -> + if ty_strictly_positive_in_type env mutuals b.binder_bv.sort unfolded + then ( + let env = push_binders env [b] in + aux env bs + ) + else false + in + aux env bs + + | _ -> + debug_positivity env (fun _ -> + BU.format2 + "Checking strict positivity, unexpected tag: %s and term %s" + (tag_of in_type) + (show in_type)); + //Reject remaining cases conservatively as non positive + false) + +(* + * We are checking for positive occurrences of mutuals in a term + * (head args), and we know one of the mutuals occurs somewhere in args + * We also have env |- head : Tot t + * + * This function checks that whereever ty_lid appears in the args, + * the corresponding parameter in t is marked strictly positive + *) +and ty_strictly_positive_in_args (env:env) + (mutuals:list lident) + (head_t:typ) + (args:args) + (unfolded:unfolded_memo_t) + : bool + = let bs, _ = U.arrow_formals head_t in + let rec aux (bs:binders) args + : bool + = match bs, args with + | _, [] -> + //A partial application: we've checked all the arguments + true + + | [], _ -> + //More args than binders, e.g., because the remaining arguments + //Are beneath a computation type + //In this case, we just insist that ty_lid simply does not occur + //in the remaining arguments + List.for_all (fun (arg, _) -> mutuals_unused_in_type mutuals arg) args + + | b::bs, (arg, _)::args -> + debug_positivity env (fun _ -> + BU.format3 "Checking positivity of %s in argument %s and binder %s" + (string_of_lids mutuals) + (show arg) + (show b)); + + let this_occurrence_ok = + // either the ty_lid does not occur at all in the argument + mutuals_unused_in_type mutuals arg || + // Or the binder is marked unused + // E.g., val f ([@@@unused] a : Type) : Type + // the binder is ([@@@unused] a : Type) + U.is_binder_unused b || + // Or the binder is marked strictly positive + // and the occurrence of ty_lid in arg is also strictly positive + // E.g., val f ([@@@strictly_positive] a : Type) : Type + // the binder is ([@@@strictly_positive] a : Type) + // and + // type t = | T of f t is okay + // but type t = | T of f (t -> unit) is not okay + (U.is_binder_strictly_positive b && + ty_strictly_positive_in_type env mutuals arg unfolded) + + in + if not this_occurrence_ok + then ( + debug_positivity env (fun _ -> + BU.format3 "Failed checking positivity of %s in argument %s and binder %s" + (string_of_lids mutuals) + (show arg) + (show b)); + false + ) else ( + aux bs args + ) + in + aux bs args + + +(* We are checking that `ty_lid` is strictly positive + in (f args) and ty_lid <> f + + There are two main cases: + + 1. f is itself an inductive type, not defined mutually with ty_lid. + Look at all the constructors of `f` and check that ty_lid + is strictly positive in the types of all those constructors. + + This is to account for the case where `f` has not been decorated + with strictly_positive attributes on its parameters. + + This may involve unfolding `f` for this application, and since `f` + is inductive, we need to prevent infinite unfoldings. For this, the + unfolded:unfolded_memo_t is a memoization table which tracks which + inductives have already been unfolded, so we don't unfold them again + when they are re-encountered. + + 2. f is not an inductive type (or at least not visibly so, e.g., due + to an abstraction boundary). In this case, check that every + ty_lid is strictly_positive in all the args of f, using + check_ty_strictly_positive_in_args + +*) +and ty_strictly_positive_in_arguments_to_fvar + (env:env) + (mutuals:list lident) + (t:term) //t== fv us args + (fv:lident) + (us:universes) + (args:args) + (unfolded:unfolded_memo_t) + : bool + = debug_positivity env (fun _ -> + BU.format4 "Checking positivity of %s in application of fv %s to %s (t=%s)" + (string_of_lids mutuals) + (string_of_lid fv) + (Print.args_to_string args) + (show t)); + if Env.is_datacon env fv + then ( + // If fv is a constructor, then the mutuals must be strictly positive + // in all the arguments + List.for_all + (fun (a, _) -> ty_strictly_positive_in_type env mutuals a unfolded) + args + ) + else ( + let fv_ty = + match Env.try_lookup_lid env fv with + | Some ((_, fv_ty), _) -> fv_ty + | _ -> + raise_error fv Errors.Error_InductiveTypeNotSatisfyPositivityCondition + (BU.format1 "Type of %s not found when checking positivity" + (string_of_lid fv)) + in + let b, idatas = datacons_of_typ env fv in + if not b + then ( + (* + * Check if ilid's corresponding binder is marked "strictly_positive" + *) + ty_strictly_positive_in_args env mutuals fv_ty args unfolded + ) + //if fv has already been unfolded with same arguments, return true + else ( + check_no_index_occurrences_in_arities env mutuals t; + let ilid = fv in //fv is an inductive + //note that num_ibs gives us only the type parameters, + //and not indexes, which is what we need since we will + //substitute them in the data constructor type + let num_uniform_params = + match Env.num_inductive_uniform_ty_params env ilid with + | None -> //impossible; we know that ilid is an inductive + failwith "Unexpected type" + | Some n -> n + in + let params, _rest = List.splitAt num_uniform_params args in + if already_unfolded ilid args unfolded env + then ( + debug_positivity env (fun _ -> + "Checking nested positivity, we have already unfolded this inductive with these args"); + true + ) + else ( + debug_positivity env (fun _ -> + BU.format3 "Checking positivity in datacon, number of type parameters is %s, \ + adding %s %s to the memo table" + (string_of_int num_uniform_params) + (Ident.string_of_lid ilid) + (Print.args_to_string params)); + //update the memo table with the inductive name and the args, + //note we keep only the uniform parameters and not indices + unfolded := !unfolded @ [ilid, params, num_uniform_params]; + List.for_all + (fun d -> ty_strictly_positive_in_datacon_of_applied_inductive + env + mutuals + d + ilid + us + args + num_uniform_params + unfolded) + idatas + ) + ) + ) + +(* dlid is a data constructor of ilid + args are the arguments of the ilid application + num_ibs is the # of type parameters of ilid + us are the universes + + Check that the mutuals + occur strictly positively in every field of dlid *) +and ty_strictly_positive_in_datacon_of_applied_inductive (env:env_t) + (mutuals:list lident) + (dlid:lident) + (ilid:lident) + (us:universes) + (args:args) + (num_ibs:int) + (unfolded:unfolded_memo_t) + : bool + = debug_positivity env (fun _ -> + BU.format3 + "Checking positivity of %s in data constructor %s : %s" + (string_of_lids mutuals) + (string_of_lid dlid) + (string_of_lid ilid)); + let dt = + match Env.try_lookup_and_inst_lid env us dlid with + | Some (t, _) -> t + | None -> + raise_error + (range_of_lid dlid) + Errors.Error_InductiveTypeNotSatisfyPositivityCondition + (BU.format1 "Data constructor %s not found when checking positivity" + (string_of_lid dlid)) + in + + debug_positivity env (fun _ -> + BU.format3 + "Checking positivity in the data constructor type: %s\n\t\ + num_ibs=%s, args=%s," + (show dt) + (string_of_int num_ibs) + (Print.args_to_string args)); + + //get the number of arguments that cover the type parameters num_ibs, + //the rest are indexes and these should not mention the mutuals at all + let args, rest = List.splitAt num_ibs args in + let applied_dt = apply_constr_arrow dlid dt args in + debug_positivity env (fun _ -> + BU.format3 + "Applied data constructor type: %s %s : %s" + (string_of_lid dlid) + (Print.args_to_string args) + (show applied_dt)); + let fields, t = U.arrow_formals applied_dt in + check_no_index_occurrences_in_arities env mutuals t; + let rec strictly_positive_in_all_fields env fields = + match fields with + | [] -> true + | f::fields -> + debug_positivity env (fun _ -> + BU.format2 "Checking field %s : %s for indexes and positivity" + (show f.binder_bv) + (show f.binder_bv.sort)); + check_no_index_occurrences_in_arities env mutuals f.binder_bv.sort; + if ty_strictly_positive_in_type env mutuals f.binder_bv.sort unfolded + then let env = push_binders env [f] in + strictly_positive_in_all_fields env fields + else false + in + strictly_positive_in_all_fields env fields + +//////////////////////////////////////////////////////////////////////////////// +// External API for strict positivity checking +//////////////////////////////////////////////////////////////////////////////// + + +(* + Check that the name bv (a binder annotated with a strictly_positive + attribute) is strictly positive in t +*) +let name_strictly_positive_in_type env (bv:bv) t = + let t, fv_lid = name_as_fv_in_t t bv in + ty_strictly_positive_in_type env [fv_lid] t (BU.mk_ref []) + + +(* + Check that the name bv (a binder annotated with a strictly_positive + attribute) is strictly positive in t +*) +let name_unused_in_type env (bv:bv) t = + let t, fv_lid = name_as_fv_in_t t bv in + not (ty_occurs_in fv_lid t) || + mutuals_unused_in_type [fv_lid] (normalize env t) + +(* Check that the mutuals are + strictly positive in every field of the data constructor dlid + AND + that any parameters of the type annotated with a strictly positive + attribute are also strictly positive in the fields of the constructor + + The env must already contain all the ty_bs + *) +let ty_strictly_positive_in_datacon_decl (env:env_t) + (mutuals:list lident) + (dlid:lident) + (ty_bs:binders) + (us:universes) + (unfolded:unfolded_memo_t) + : bool + = let dt = + match Env.try_lookup_and_inst_lid env us dlid with + | Some (t, _) -> t + | None -> raise_error dlid + Errors.Error_InductiveTypeNotSatisfyPositivityCondition + (BU.format1 "Error looking up data constructor %s when checking positivity" + (string_of_lid dlid)) + in + debug_positivity env (fun () -> "Checking data constructor type: " ^ (show dt)); + let ty_bs, args = U.args_of_binders ty_bs in + let dt = apply_constr_arrow dlid dt args in + let fields, return_type = U.arrow_formals dt in + check_no_index_occurrences_in_arities env mutuals return_type; + let check_annotated_binders_are_strictly_positive_in_field f = + let incorrectly_annotated_binder = + L.tryFind + (fun b -> + (U.is_binder_unused b + && not (name_unused_in_type env b.binder_bv f.binder_bv.sort)) || + (U.is_binder_strictly_positive b + && not (name_strictly_positive_in_type env b.binder_bv f.binder_bv.sort))) + ty_bs + in + match incorrectly_annotated_binder with + | None -> () + | Some b -> + raise_error b Error_InductiveTypeNotSatisfyPositivityCondition + (BU.format2 "Binder %s is marked %s, \ + but its use in the definition is not" + (show b) + (if U.is_binder_strictly_positive b + then "strictly_positive" + else "unused")) + in + let rec check_all_fields env fields = + match fields with + | [] -> true + | field::fields -> + check_annotated_binders_are_strictly_positive_in_field field; + if not (ty_strictly_positive_in_type env mutuals field.binder_bv.sort unfolded) + then false + else ( + let env = push_binders env [field] in + check_all_fields env fields + ) + in + check_all_fields env fields + + +(* An entry point from the interface: + Check that the inductive type ty, defined mutually with mutuals + is strictly positive *) +let check_strict_positivity (env:env_t) + (mutuals:list lident) + (ty:sigelt) + : bool + = //memo table, memoizes the instances of inductives + //that we have recursively already deemed as strictly positive + let unfolded_inductives = BU.mk_ref [] in + + //ty_params are the parameters of ty, it does not include the indexes + let env, (ty_lid, ty_us, ty_params) = open_sig_inductive_typ env ty in + let mutuals = List.filter (fun m -> not (Env.is_datacon env m)) mutuals in + let mutuals = + //make sure that ty_lid itself is part of the mutuals + if List.existsML (Ident.lid_equals ty_lid) mutuals + then mutuals + else ty_lid::mutuals in + let datacons = snd (datacons_of_typ env ty_lid) in + let us = List.map U_name ty_us in + List.for_all + (fun d -> + ty_strictly_positive_in_datacon_decl + env + mutuals + d + ty_params + us + unfolded_inductives) + datacons + +(* Special-casing the check for exceptions, the single open inductive type we handle. *) +let check_exn_strict_positivity (env:env_t) + (data_ctor_lid:lid) + : bool + = let unfolded_inductives = BU.mk_ref [] in + ty_strictly_positive_in_datacon_decl env [C.exn_lid] data_ctor_lid [] [] unfolded_inductives + + diff --git a/src/typechecker/FStarC.TypeChecker.Positivity.fsti b/src/typechecker/FStarC.TypeChecker.Positivity.fsti new file mode 100644 index 00000000000..0c545a2b803 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Positivity.fsti @@ -0,0 +1,29 @@ +(* + Copyright 2008-2023 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + + Authors: A. Rastogi, N. Swamy +*) + +module FStarC.TypeChecker.Positivity +open FStarC.Compiler.Effect +open FStarC.TypeChecker.Env +open FStarC.Syntax.Syntax +open FStarC.Ident + +val check_strict_positivity: env -> list lident -> sigelt -> bool +val name_strictly_positive_in_type: env -> bv -> term -> bool +val name_unused_in_type: env -> bv -> term -> bool +val check_exn_strict_positivity: env -> lident -> bool +val mark_uniform_type_parameters: env -> sigelt -> sigelt \ No newline at end of file diff --git a/src/typechecker/FStarC.TypeChecker.Primops.Array.fst b/src/typechecker/FStarC.TypeChecker.Primops.Array.fst new file mode 100644 index 00000000000..490e3ec0832 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Primops.Array.fst @@ -0,0 +1,183 @@ +module FStarC.TypeChecker.Primops.Array + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Errors +open FStarC.Class.Monad +open FStarC.Syntax.Syntax +open FStarC.Syntax.Embeddings + +open FStarC.TypeChecker.Primops.Base + +module BU = FStarC.Compiler.Util +module EMB = FStarC.Syntax.Embeddings +module NBETerm = FStarC.TypeChecker.NBETerm +module PC = FStarC.Parser.Const +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module U = FStarC.Syntax.Util +module Z = FStarC.BigInt + +let as_primitive_step is_strong (l, arity, u_arity, f, f_nbe) = + FStarC.TypeChecker.Primops.Base.as_primitive_step_nbecbs is_strong (l, arity, u_arity, f, (fun cb univs args -> f_nbe univs args)) + +let arg_as_int (a:arg) : option Z.t = fst a |> try_unembed_simple + +let arg_as_list {|e:EMB.embedding 'a|} (a:arg) +: option (list 'a) + = fst a |> try_unembed_simple + +let mixed_binary_op + (as_a : arg -> option 'a) + (as_b : arg -> option 'b) + (embed_c : Range.range -> 'c -> term) + (f : Range.range -> universes -> 'a -> 'b -> option 'c) + (psc : psc) + (norm_cb : EMB.norm_cb) + (univs : universes) + (args : args) + : option term + = match args with + | [a;b] -> + begin + match as_a a, as_b b with + | Some a, Some b -> + (match f psc.psc_range univs a b with + | Some c -> Some (embed_c psc.psc_range c) + | _ -> None) + | _ -> None + end + | _ -> None + +let mixed_ternary_op + (as_a : arg -> option 'a) + (as_b : arg -> option 'b) + (as_c : arg -> option 'c) + (embed_d : Range.range -> 'd -> term) + (f : Range.range -> universes -> 'a -> 'b -> 'c -> option 'd) + (psc : psc) + (norm_cb : EMB.norm_cb) + (univs : universes) + (args : args) + : option term + = match args with + | [a;b;c] -> + begin + match as_a a, as_b b, as_c c with + | Some a, Some b, Some c -> + (match f psc.psc_range univs a b c with + | Some d -> Some (embed_d psc.psc_range d) + | _ -> None) + | _ -> None + end + | _ -> None + + +let bogus_cbs = { + NBETerm.iapp = (fun h _args -> h); + NBETerm.translate = (fun _ -> failwith "bogus_cbs translate"); +} + +let ops : list primitive_step = + let of_list_op = + let emb_typ t = ET_app(PC.immutable_array_t_lid |> Ident.string_of_lid, [t]) in + let un_lazy universes t l r = + S.mk_Tm_app + (S.mk_Tm_uinst (U.fvar_const PC.immutable_array_of_list_lid) universes) + [S.iarg t; S.as_arg l] + r + in + ( PC.immutable_array_of_list_lid, 2, 1, + mixed_binary_op + (fun (elt_t, _) -> Some elt_t) //the first arg of of_list is the element type + (fun (l, q) -> //2nd arg: try_unembed_simple as a list term + match arg_as_list #_ #FStarC.Syntax.Embeddings.e_any (l, q) with + | Some lst -> Some (l, lst) + | _ -> None) + (fun r (universes, elt_t, (l, blob)) -> + //embed the result back as a Tm_lazy with the `ImmutableArray.t term` as the blob + //The kind records the type of the blob as IA.t "any" + //and the interesting thing here is that the thunk represents the blob back as pure F* term + //IA.of_list u#universes elt_t l. + //This unreduced representation can be used in a context where the blob doesn't make sense, + //e.g., in the SMT encoding, we represent the blob computed by of_list l + //just as the unreduced term `of_list l` + S.mk (Tm_lazy { blob; + lkind=Lazy_embedding (emb_typ EMB.(emb_typ_of _ #e_any ()), Thunk.mk (fun _ -> un_lazy universes elt_t l r)); + ltyp=S.mk_Tm_app (S.mk_Tm_uinst (U.fvar_const PC.immutable_array_t_lid) universes) [S.as_arg elt_t] r; + rng=r }) r) + (fun r universes elt_t (l, lst) -> + //The actual primitive step computing the IA.t blob + let blob = FStar.ImmutableArray.Base.of_list #term lst in + Some (universes, elt_t, (l, FStarC.Dyn.mkdyn blob))), + NBETerm.mixed_binary_op + (fun (elt_t, _) -> Some elt_t) + (fun (l, q) -> + match NBETerm.arg_as_list NBETerm.e_any (l, q) with + | None -> None + | Some lst -> Some (l, lst)) + (fun (universes, elt_t, (l, blob)) -> + //The embedding is similar to the non-NBE case + //But, this time the thunk is the NBE.t representation of `of_list l` + NBETerm.mk_t <| + NBETerm.Lazy (Inr (blob, emb_typ EMB.(emb_typ_of _ #e_any ())), + Thunk.mk (fun _ -> + NBETerm.mk_t <| NBETerm.FV (S.lid_as_fv PC.immutable_array_of_list_lid None, + universes, + [NBETerm.as_arg l])))) + (fun universes elt_t (l, lst) -> + let blob = FStar.ImmutableArray.Base.of_list #NBETerm.t lst in + Some (universes, elt_t, (l, FStarC.Dyn.mkdyn blob)))) + in + let arg1_as_elt_t (x:arg) : option term = Some (fst x) in + let arg2_as_blob (x:arg) : option FStarC.Dyn.dyn = + //try_unembed_simple an arg as a IA.t blob if the emb_typ + //of the lkind tells us it has the right type + match (SS.compress (fst x)).n with + | Tm_lazy {blob=blob; lkind=Lazy_embedding (ET_app(head, _), _)} + when head=Ident.string_of_lid PC.immutable_array_t_lid -> Some blob + | _ -> None + in + let arg2_as_blob_nbe (x:NBETerm.arg) : option FStarC.Dyn.dyn = + //try_unembed_simple an arg as a IA.t blob if the emb_typ + //tells us it has the right type + let open FStarC.TypeChecker.NBETerm in + match (fst x).nbe_t with + | Lazy (Inr (blob, ET_app(head, _)), _) + when head=Ident.string_of_lid PC.immutable_array_t_lid -> Some blob + | _ -> None + in + let length_op = + let embed_int (r:Range.range) (i:Z.t) : term = embed_simple r i in + let run_op (blob:FStarC.Dyn.dyn) : option Z.t = + Some (BU.array_length #term (FStarC.Dyn.undyn blob)) + in + ( PC.immutable_array_length_lid, 2, 1, + mixed_binary_op arg1_as_elt_t //1st arg of length is the type + arg2_as_blob //2nd arg is the IA.t term blob + embed_int //the result is just an int, so embed it back + (fun _r _universes _ blob -> run_op blob), + //NBE case is similar + NBETerm.mixed_binary_op + (fun (elt_t, _) -> Some elt_t) + arg2_as_blob_nbe + (fun (i:Z.t) -> NBETerm.embed NBETerm.e_int bogus_cbs i) + (fun _universes _ blob -> run_op blob) ) + in + let index_op = + (PC.immutable_array_index_lid, 3, 1, + mixed_ternary_op arg1_as_elt_t //1st arg of index is the type + arg2_as_blob //2nd arg is the `IA.t term` blob + arg_as_int //3rd arg is an int + (fun r tm -> tm) //the result is just a term, so the embedding is the identity + (fun r _universes _t blob i -> Some (BU.array_index #term (FStarC.Dyn.undyn blob) i)), + NBETerm.mixed_ternary_op + (fun (elt_t, _) -> Some elt_t) + arg2_as_blob_nbe //2nd arg is an `IA.t NBEterm.t` blob + NBETerm.arg_as_int + (fun tm -> tm) //In this case, the result is a NBE.t, so embedding is the identity + (fun _universes _t blob i -> Some (BU.array_index #NBETerm.t (FStarC.Dyn.undyn blob) i))) + in + List.map (as_primitive_step true) + [of_list_op; length_op; index_op] diff --git a/src/typechecker/FStarC.TypeChecker.Primops.Array.fsti b/src/typechecker/FStarC.TypeChecker.Primops.Array.fsti new file mode 100644 index 00000000000..48d64ce3b86 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Primops.Array.fsti @@ -0,0 +1,5 @@ +module FStarC.TypeChecker.Primops.Array + +open FStarC.TypeChecker.Primops.Base + +val ops : list primitive_step diff --git a/src/typechecker/FStarC.TypeChecker.Primops.Base.fst b/src/typechecker/FStarC.TypeChecker.Primops.Base.fst new file mode 100644 index 00000000000..5dac0932a51 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Primops.Base.fst @@ -0,0 +1,459 @@ +module FStarC.TypeChecker.Primops.Base + +(* This module defines the type of primitive steps and some helpers. *) + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Syntax.Syntax +open FStarC.Class.Monad + +module EMB = FStarC.Syntax.Embeddings +module NBE = FStarC.TypeChecker.NBETerm + +let null_psc = { psc_range = Range.dummyRange ; psc_subst = fun () -> [] } +let psc_range psc = psc.psc_range +let psc_subst psc = psc.psc_subst () + +let embed_simple {| EMB.embedding 'a |} (r:Range.range) (x:'a) : term = + EMB.embed x r None EMB.id_norm_cb + +let try_unembed_simple {| EMB.embedding 'a |} (x:term) : option 'a = + EMB.try_unembed x EMB.id_norm_cb + +let solve (#a:Type) {| ev : a |} : Tot a = ev + +let as_primitive_step_nbecbs is_strong (l, arity, u_arity, f, f_nbe) : primitive_step = { + name = l; + arity = arity; + univ_arity = u_arity; + auto_reflect = None; + strong_reduction_ok = is_strong; + requires_binder_substitution = false; + renorm_after = false; + interpretation = f; + interpretation_nbe = f_nbe; +} + +let mk_interp1 #a #r + {| EMB.embedding a |} + {| EMB.embedding r |} + (f : a -> r) + : interp_t = + fun psc cb us args -> + match args with + | [(a, _)] -> + let! a = try_unembed_simple a in + return (embed_simple psc.psc_range (f a)) + | _ -> failwith "arity" + +let mk_nbe_interp1 #a #r + {| NBE.embedding a |} + {| NBE.embedding r |} + (f : a -> r) + : nbe_interp_t = + fun cbs us args -> + match args with + | [(a, _)] -> + let! r = f <$> NBE.unembed solve cbs a in + return (NBE.embed solve cbs r) + | _ -> + None + +let mk_interp2 #a #b #r + {| EMB.embedding a |} + {| EMB.embedding b |} + {| EMB.embedding r |} + (f : a -> b -> r) + : interp_t = + fun psc cb us args -> + match args with + | [(a, _); (b, _)] -> + let! r = f <$> try_unembed_simple a <*> try_unembed_simple b in + return (embed_simple psc.psc_range r) + | _ -> failwith "arity" + +let mk_nbe_interp2 #a #b #r + {| NBE.embedding a |} + {| NBE.embedding b |} + {| NBE.embedding r |} + (f : a -> b -> r) + : nbe_interp_t = + fun cbs us args -> + match args with + | [(a, _); (b, _)] -> + let! r = f <$> NBE.unembed solve cbs a <*> NBE.unembed solve cbs b in + return (NBE.embed solve cbs r) + | _ -> + None + +let mk_interp3 #a #b #c #r + {| EMB.embedding a |} + {| EMB.embedding b |} + {| EMB.embedding c |} + {| EMB.embedding r |} + (f : a -> b -> c -> r) + : interp_t = + fun psc cb us args -> + match args with + | [(a, _); (b, _); (c, _)] -> + let! r = f <$> try_unembed_simple a <*> try_unembed_simple b <*> try_unembed_simple c in + return (embed_simple psc.psc_range r) + | _ -> failwith "arity" + +let mk_nbe_interp3 #a #b #c #r + {| NBE.embedding a |} + {| NBE.embedding b |} + {| NBE.embedding c |} + {| NBE.embedding r |} + (f : a -> b -> c -> r) + : nbe_interp_t = + fun cbs us args -> + match args with + | [(a, _); (b, _); (c, _)] -> + let! r = f <$> NBE.unembed solve cbs a <*> NBE.unembed solve cbs b <*> NBE.unembed solve cbs c in + return (NBE.embed solve cbs r) + | _ -> + None + +let mk_interp4 #a #b #c #d #r + {| EMB.embedding a |} + {| EMB.embedding b |} + {| EMB.embedding c |} + {| EMB.embedding d |} + {| EMB.embedding r |} + (f : a -> b -> c -> d -> r) + : interp_t = + fun psc cb us args -> + match args with + | [(a, _); (b, _); (c, _); (d, _)] -> + let! r = f <$> try_unembed_simple a <*> try_unembed_simple b <*> try_unembed_simple c <*> try_unembed_simple d in + return (embed_simple psc.psc_range r) + | _ -> failwith "arity" + +let mk_nbe_interp4 #a #b #c #d #r + {| NBE.embedding a |} + {| NBE.embedding b |} + {| NBE.embedding c |} + {| NBE.embedding d |} + {| NBE.embedding r |} + (f : a -> b -> c -> d -> r) + : nbe_interp_t = + fun cbs us args -> + match args with + | [(a, _); (b, _); (c, _); (d, _)] -> + let! r = f <$> NBE.unembed solve cbs a <*> NBE.unembed solve cbs b <*> NBE.unembed solve cbs c <*> NBE.unembed solve cbs d in + return (NBE.embed solve cbs r) + | _ -> + None + +let mk_interp5 #a #b #c #d #e #r + {| EMB.embedding a |} + {| EMB.embedding b |} + {| EMB.embedding c |} + {| EMB.embedding d |} + {| EMB.embedding e |} + {| EMB.embedding r |} + (f : a -> b -> c -> d -> e -> r) + : interp_t = + fun psc cb us args -> + match args with + | [(a, _); (b, _); (c, _); (d, _); (e, _)] -> + let! r = f <$> try_unembed_simple a <*> try_unembed_simple b <*> try_unembed_simple c <*> try_unembed_simple d <*> try_unembed_simple e in + return (embed_simple psc.psc_range r) + | _ -> failwith "arity" + +let mk_nbe_interp5 #a #b #c #d #e #r + {| NBE.embedding a |} + {| NBE.embedding b |} + {| NBE.embedding c |} + {| NBE.embedding d |} + {| NBE.embedding e |} + {| NBE.embedding r |} + (f : a -> b -> c -> d -> e -> r) + : nbe_interp_t = + fun cbs us args -> + match args with + | [(a, _); (b, _); (c, _); (d, _); (e, _)] -> + let! r = f <$> NBE.unembed solve cbs a <*> NBE.unembed solve cbs b <*> NBE.unembed solve cbs c <*> NBE.unembed solve cbs d <*> NBE.unembed solve cbs e in + return (NBE.embed solve cbs r) + | _ -> + None + +let mk1 #a #r + (u_arity : int) + (name : Ident.lid) + {| EMB.embedding a |} {| NBE.embedding a |} + {| EMB.embedding r |} {| NBE.embedding r |} + (f : a -> r) + : primitive_step = + let interp : interp_t = mk_interp1 f in + let nbe_interp : nbe_interp_t = mk_nbe_interp1 f in + as_primitive_step_nbecbs true (name, 1, u_arity, interp, nbe_interp) + +let mk2 #a #b #r + (u_arity : int) + (name : Ident.lid) + {| EMB.embedding a |} {| NBE.embedding a |} + {| EMB.embedding b |} {| NBE.embedding b |} + {| EMB.embedding r |} {| NBE.embedding r |} + (f : a -> b -> r) + : primitive_step = + let interp : interp_t = mk_interp2 f in + let nbe_interp : nbe_interp_t = mk_nbe_interp2 f in + as_primitive_step_nbecbs true (name, 2, u_arity, interp, nbe_interp) + +let mk3 #a #b #c #r + (u_arity : int) + (name : Ident.lid) + {| EMB.embedding a |} {| NBE.embedding a |} + {| EMB.embedding b |} {| NBE.embedding b |} + {| EMB.embedding c |} {| NBE.embedding c |} + {| EMB.embedding r |} {| NBE.embedding r |} + (f : a -> b -> c -> r) + : primitive_step = + let interp : interp_t = mk_interp3 f in + let nbe_interp : nbe_interp_t = mk_nbe_interp3 f in + as_primitive_step_nbecbs true (name, 3, u_arity, interp, nbe_interp) + +let mk4 #a #b #c #d #r + (u_arity : int) + (name : Ident.lid) + {| EMB.embedding a |} {| NBE.embedding a |} + {| EMB.embedding b |} {| NBE.embedding b |} + {| EMB.embedding c |} {| NBE.embedding c |} + {| EMB.embedding d |} {| NBE.embedding d |} + {| EMB.embedding r |} {| NBE.embedding r |} + (f : a -> b -> c -> d -> r) + : primitive_step = + let interp : interp_t = mk_interp4 f in + let nbe_interp : nbe_interp_t = mk_nbe_interp4 f in + as_primitive_step_nbecbs true (name, 4, u_arity, interp, nbe_interp) + +let mk5 #a #b #c #d #e #r + (u_arity : int) + (name : Ident.lid) + {| EMB.embedding a |} {| NBE.embedding a |} + {| EMB.embedding b |} {| NBE.embedding b |} + {| EMB.embedding c |} {| NBE.embedding c |} + {| EMB.embedding d |} {| NBE.embedding d |} + {| EMB.embedding e |} {| NBE.embedding e |} + {| EMB.embedding r |} {| NBE.embedding r |} + (f : a -> b -> c -> d -> e -> r) + : primitive_step = + let interp : interp_t = mk_interp5 f in + let nbe_interp : nbe_interp_t = mk_nbe_interp5 f in + as_primitive_step_nbecbs true (name, 5, u_arity, interp, nbe_interp) + +let mk1' #a #r #na #nr + (u_arity : int) + (name : Ident.lid) + {| EMB.embedding a |} {| NBE.embedding na |} + {| EMB.embedding r |} {| NBE.embedding nr |} + (f : a -> option r) + (nbe_f : na -> option nr) + : primitive_step = + let interp : interp_t = + fun psc cb us args -> + match args with + | [(a, _)] -> + let! r = f <$> try_unembed_simple a in + let! r = r in + return (embed_simple psc.psc_range r) + | _ -> failwith "arity" + in + let nbe_interp : nbe_interp_t = + fun cbs us args -> + match args with + | [(a, _)] -> + let! r = nbe_f <$> NBE.unembed solve cbs a in + let! r = r in + return (NBE.embed solve cbs r) + | _ -> failwith "arity" + in + as_primitive_step_nbecbs true (name, 1, u_arity, interp, nbe_interp) + +let mk1_psc' #a #r #na #nr + (u_arity : int) + (name : Ident.lid) + {| EMB.embedding a |} {| NBE.embedding na |} + {| EMB.embedding r |} {| NBE.embedding nr |} + (f : psc -> a -> option r) + (nbe_f : psc -> na -> option nr) + : primitive_step = + let interp : interp_t = + fun psc cb us args -> + match args with + | [(a, _)] -> + let! r = f psc <$> try_unembed_simple a in + let! r = r in + return (embed_simple psc.psc_range r) + | _ -> failwith "arity" + in + let nbe_interp : nbe_interp_t = + fun cbs us args -> + match args with + | [(a, _)] -> + let! r = nbe_f null_psc <$> NBE.unembed solve cbs a in + let! r = r in + return (NBE.embed solve cbs r) + | _ -> failwith "arity" + in + as_primitive_step_nbecbs true (name, 1, u_arity, interp, nbe_interp) + + +let mk2' #a #b #r #na #nb #nr + (u_arity : int) + (name : Ident.lid) + {| EMB.embedding a |} {| NBE.embedding na |} + {| EMB.embedding b |} {| NBE.embedding nb |} + {| EMB.embedding r |} {| NBE.embedding nr |} + (f : a -> b -> option r) + (nbe_f : na -> nb -> option nr) + : primitive_step = + let interp : interp_t = + fun psc cb us args -> + match args with + | [(a, _); (b, _)] -> + let! r = f <$> try_unembed_simple a <*> try_unembed_simple b in + let! r = r in + return (embed_simple psc.psc_range r) + | _ -> failwith "arity" + in + let nbe_interp : nbe_interp_t = + fun cbs us args -> + match args with + | [(a, _); (b, _)] -> + let! r = nbe_f <$> NBE.unembed solve cbs a <*> NBE.unembed solve cbs b in + let! r = r in + return (NBE.embed solve cbs r) + | _ -> failwith "arity" + in + as_primitive_step_nbecbs true (name, 2, u_arity, interp, nbe_interp) + +let mk3' #a #b #c #r #na #nb #nc #nr + (u_arity : int) + (name : Ident.lid) + {| EMB.embedding a |} {| NBE.embedding na |} + {| EMB.embedding b |} {| NBE.embedding nb |} + {| EMB.embedding c |} {| NBE.embedding nc |} + {| EMB.embedding r |} {| NBE.embedding nr |} + (f : a -> b -> c -> option r) + (nbe_f : na -> nb -> nc -> option nr) + : primitive_step = + let interp : interp_t = + fun psc cb us args -> + match args with + | [(a, _); (b, _); (c, _)] -> + let! r = f <$> try_unembed_simple a <*> try_unembed_simple b <*> try_unembed_simple c in + let! r = r in + return (embed_simple psc.psc_range r) + | _ -> failwith "arity" + in + let nbe_interp : nbe_interp_t = + fun cbs us args -> + match args with + | [(a, _); (b, _); (c, _)] -> + let! r = nbe_f <$> NBE.unembed solve cbs a <*> NBE.unembed solve cbs b <*> NBE.unembed solve cbs c in + let! r = r in + return (NBE.embed solve cbs r) + | _ -> failwith "arity" + in + as_primitive_step_nbecbs true (name, 3, u_arity, interp, nbe_interp) + +let mk4' #a #b #c #d #r #na #nb #nc #nd #nr + (u_arity : int) + (name : Ident.lid) + {| EMB.embedding a |} {| NBE.embedding na |} + {| EMB.embedding b |} {| NBE.embedding nb |} + {| EMB.embedding c |} {| NBE.embedding nc |} + {| EMB.embedding d |} {| NBE.embedding nd |} + {| EMB.embedding r |} {| NBE.embedding nr |} + (f : a -> b -> c -> d -> option r) + (nbe_f : na -> nb -> nc -> nd -> option nr) + : primitive_step = + let interp : interp_t = + fun psc cb us args -> + match args with + | [(a, _); (b, _); (c, _); (d, _)] -> + let! r = f <$> try_unembed_simple a <*> try_unembed_simple b <*> try_unembed_simple c <*> try_unembed_simple d in + let! r = r in + return (embed_simple psc.psc_range r) + | _ -> failwith "arity" + in + let nbe_interp : nbe_interp_t = + fun cbs us args -> + match args with + | [(a, _); (b, _); (c, _); (d, _)] -> + let! r = nbe_f <$> NBE.unembed solve cbs a <*> NBE.unembed solve cbs b <*> NBE.unembed solve cbs c <*> NBE.unembed solve cbs d in + let! r = r in + return (NBE.embed solve cbs r) + | _ -> failwith "arity" + in + as_primitive_step_nbecbs true (name, 4, u_arity, interp, nbe_interp) + +let mk5' #a #b #c #d #e #r #na #nb #nc #nd #ne #nr + (u_arity : int) + (name : Ident.lid) + {| EMB.embedding a |} {| NBE.embedding na |} + {| EMB.embedding b |} {| NBE.embedding nb |} + {| EMB.embedding c |} {| NBE.embedding nc |} + {| EMB.embedding d |} {| NBE.embedding nd |} + {| EMB.embedding e |} {| NBE.embedding ne |} + {| EMB.embedding r |} {| NBE.embedding nr |} + (f : a -> b -> c -> d -> e -> option r) + (nbe_f : na -> nb -> nc -> nd -> ne -> option nr) + : primitive_step = + let interp : interp_t = + fun psc cb us args -> + match args with + | [(a, _); (b, _); (c, _); (d, _); (e, _)] -> + let! r = f <$> try_unembed_simple a <*> try_unembed_simple b <*> try_unembed_simple c <*> try_unembed_simple d <*> try_unembed_simple e in + let! r = r in + return (embed_simple psc.psc_range r) + | _ -> failwith "arity" + in + let nbe_interp : nbe_interp_t = + fun cbs us args -> + match args with + | [(a, _); (b, _); (c, _); (d, _); (e, _)] -> + let! r = nbe_f <$> NBE.unembed solve cbs a <*> NBE.unembed solve cbs b <*> NBE.unembed solve cbs c <*> NBE.unembed solve cbs d <*> NBE.unembed solve cbs e in + let! r = r in + return (NBE.embed solve cbs r) + | _ -> failwith "arity" + in + as_primitive_step_nbecbs true (name, 5, u_arity, interp, nbe_interp) + +let mk6' #a #b #c #d #e #f #r #na #nb #nc #nd #ne #nf #nr + (u_arity : int) + (name : Ident.lid) + {| EMB.embedding a |} {| NBE.embedding na |} + {| EMB.embedding b |} {| NBE.embedding nb |} + {| EMB.embedding c |} {| NBE.embedding nc |} + {| EMB.embedding d |} {| NBE.embedding nd |} + {| EMB.embedding e |} {| NBE.embedding ne |} + {| EMB.embedding f |} {| NBE.embedding nf |} + {| EMB.embedding r |} {| NBE.embedding nr |} + (ff : a -> b -> c -> d -> e -> f -> option r) + (nbe_ff : na -> nb -> nc -> nd -> ne -> nf -> option nr) + : primitive_step = + let interp : interp_t = + fun psc cb us args -> + match args with + | [(a, _); (b, _); (c, _); (d, _); (e, _); (f, _)] -> + let! r = ff <$> try_unembed_simple a <*> try_unembed_simple b <*> try_unembed_simple c <*> try_unembed_simple d <*> try_unembed_simple e <*> try_unembed_simple f in + let! r = r in + return (embed_simple psc.psc_range r) + | _ -> failwith "arity" + in + let nbe_interp : nbe_interp_t = + fun cbs us args -> + match args with + | [(a, _); (b, _); (c, _); (d, _); (e, _); (f, _)] -> + let! r = nbe_ff <$> NBE.unembed solve cbs a <*> NBE.unembed solve cbs b <*> NBE.unembed solve cbs c <*> NBE.unembed solve cbs d <*> NBE.unembed solve cbs e <*> NBE.unembed solve cbs f in + let! r = r in + return (NBE.embed solve cbs r) + | _ -> failwith "arity" + in + as_primitive_step_nbecbs true (name, 6, u_arity, interp, nbe_interp) diff --git a/src/typechecker/FStarC.TypeChecker.Primops.Base.fsti b/src/typechecker/FStarC.TypeChecker.Primops.Base.fsti new file mode 100644 index 00000000000..063154f23cf --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Primops.Base.fsti @@ -0,0 +1,238 @@ +module FStarC.TypeChecker.Primops.Base +(* This module defines the type of primitive steps and some helpers. *) + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Syntax.Syntax +module Env = FStarC.TypeChecker.Env +module EMB = FStarC.Syntax.Embeddings +module NBE = FStarC.TypeChecker.NBETerm + +type psc = { + psc_range : FStarC.Compiler.Range.range; + psc_subst : unit -> subst_t // potentially expensive, so thunked +} + +val null_psc : psc +val psc_range : psc -> FStarC.Compiler.Range.range +val psc_subst : psc -> subst_t + +type interp_t = + psc -> FStarC.Syntax.Embeddings.norm_cb -> universes -> args -> option term +type nbe_interp_t = + NBE.nbe_cbs -> universes -> NBE.args -> option NBE.t + +type primitive_step = { + name:FStarC.Ident.lid; + arity:int; + univ_arity:int; // universe arity + auto_reflect:option int; + strong_reduction_ok:bool; + requires_binder_substitution:bool; + renorm_after:bool; // whether the result of this primop must possibly undergo more normalization + interpretation:interp_t; + interpretation_nbe:nbe_interp_t; +} + +val as_primitive_step_nbecbs + (is_strong:bool) + (* (l, arity, u_arity, f, f_nbe) *) + : (Ident.lident & int & int & interp_t & nbe_interp_t) -> primitive_step + +(* Some helpers for the NBE. Does not really belong in this module. *) +val embed_simple: {| EMB.embedding 'a |} -> Range.range -> 'a -> term +val try_unembed_simple: {| EMB.embedding 'a |} -> term -> option 'a + +val mk_interp1 #a #r + {| EMB.embedding a |} + {| EMB.embedding r |} + (f : a -> r) + : interp_t + +val mk_nbe_interp1 #a #r + {| NBE.embedding a |} + {| NBE.embedding r |} + (f : a -> r) + : nbe_interp_t + +val mk_interp2 #a #b #r + {| EMB.embedding a |} {| EMB.embedding b |} + {| EMB.embedding r |} + (f : a -> b -> r) + : interp_t + +val mk_nbe_interp2 #a #b #r + {| NBE.embedding a |} {| NBE.embedding b |} + {| NBE.embedding r |} + (f : a -> b -> r) + : nbe_interp_t + +val mk_interp3 #a #b #c #r + {| EMB.embedding a |} {| EMB.embedding b |} {| EMB.embedding c |} + {| EMB.embedding r |} + (f : a -> b -> c -> r) + : interp_t + +val mk_nbe_interp3 #a #b #c #r + {| NBE.embedding a |} {| NBE.embedding b |} {| NBE.embedding c |} + {| NBE.embedding r |} + (f : a -> b -> c -> r) + : nbe_interp_t + +val mk_interp4 #a #b #c #d #r + {| EMB.embedding a |} {| EMB.embedding b |} {| EMB.embedding c |} {| EMB.embedding d |} + {| EMB.embedding r |} + (f : a -> b -> c -> d -> r) + : interp_t + +val mk_nbe_interp4 #a #b #c #d #r + {| NBE.embedding a |} {| NBE.embedding b |} {| NBE.embedding c |} {| NBE.embedding d |} + {| NBE.embedding r |} + (f : a -> b -> c -> d -> r) + : nbe_interp_t + +val mk_interp5 #a #b #c #d #e #r + {| EMB.embedding a |} {| EMB.embedding b |} {| EMB.embedding c |} {| EMB.embedding d |} {| EMB.embedding e |} + {| EMB.embedding r |} + (f : a -> b -> c -> d -> e -> r) + : interp_t + +val mk_nbe_interp5 #a #b #c #d #e #r + {| NBE.embedding a |} {| NBE.embedding b |} {| NBE.embedding c |} {| NBE.embedding d |} {| NBE.embedding e |} + {| NBE.embedding r |} + (f : a -> b -> c -> d -> e -> r) + : nbe_interp_t + +val mk1 #a #r + (u_arity : int) + (name : Ident.lid) + {| EMB.embedding a |} {| NBE.embedding a |} + {| EMB.embedding r |} {| NBE.embedding r |} + (f : a -> r) + : primitive_step + +val mk2 #a #b #r + (u_arity : int) + (name : Ident.lid) + {| EMB.embedding a |} {| NBE.embedding a |} + {| EMB.embedding b |} {| NBE.embedding b |} + {| EMB.embedding r |} {| NBE.embedding r |} + (f : a -> b -> r) + : primitive_step + +val mk3 #a #b #c #r + (u_arity : int) + (name : Ident.lid) + {| EMB.embedding a |} {| NBE.embedding a |} + {| EMB.embedding b |} {| NBE.embedding b |} + {| EMB.embedding c |} {| NBE.embedding c |} + {| EMB.embedding r |} {| NBE.embedding r |} + (f : a -> b -> c -> r) + : primitive_step + +val mk4 #a #b #c #d #r + (u_arity : int) + (name : Ident.lid) + {| EMB.embedding a |} {| NBE.embedding a |} + {| EMB.embedding b |} {| NBE.embedding b |} + {| EMB.embedding c |} {| NBE.embedding c |} + {| EMB.embedding d |} {| NBE.embedding d |} + {| EMB.embedding r |} {| NBE.embedding r |} + (f : a -> b -> c -> d -> r) + : primitive_step + +val mk5 #a #b #c #d #e #r + (u_arity : int) + (name : Ident.lid) + {| EMB.embedding a |} {| NBE.embedding a |} + {| EMB.embedding b |} {| NBE.embedding b |} + {| EMB.embedding c |} {| NBE.embedding c |} + {| EMB.embedding d |} {| NBE.embedding d |} + {| EMB.embedding e |} {| NBE.embedding e |} + {| EMB.embedding r |} {| NBE.embedding r |} + (f : a -> b -> c -> d -> e -> r) + : primitive_step + +(* Duplication for op_Division / op_Modulus which can prevent reduction. The `f` +already returns something in the option monad, so we add an extra join. Also for +decidable eq which needs different impls in each normalizer *) +val mk1' #a #r #na #nr + (u_arity : int) + (name : Ident.lid) + {| EMB.embedding a |} {| NBE.embedding na |} + {| EMB.embedding r |} {| NBE.embedding nr |} + (f : a -> option r) + (f : na -> option nr) + : primitive_step + +val mk1_psc' #a #r #na #nr + (u_arity : int) + (name : Ident.lid) + {| EMB.embedding a |} {| NBE.embedding na |} + {| EMB.embedding r |} {| NBE.embedding nr |} + (f : psc -> a -> option r) + (f : psc -> na -> option nr) + : primitive_step + +val mk2' #a #b #r #na #nb #nr + (u_arity : int) + (name : Ident.lid) + {| EMB.embedding a |} {| NBE.embedding na |} + {| EMB.embedding b |} {| NBE.embedding nb |} + {| EMB.embedding r |} {| NBE.embedding nr |} + (f : a -> b -> option r) + (f : na -> nb -> option nr) + : primitive_step + +val mk3' #a #b #c #r #na #nb #nc #nr + (u_arity : int) + (name : Ident.lid) + {| EMB.embedding a |} {| NBE.embedding na |} + {| EMB.embedding b |} {| NBE.embedding nb |} + {| EMB.embedding c |} {| NBE.embedding nc |} + {| EMB.embedding r |} {| NBE.embedding nr |} + (f : a -> b -> c -> option r) + (f : na -> nb -> nc -> option nr) + : primitive_step + +val mk4' #a #b #c #d #r #na #nb #nc #nd #nr + (u_arity : int) + (name : Ident.lid) + {| EMB.embedding a |} {| NBE.embedding na |} + {| EMB.embedding b |} {| NBE.embedding nb |} + {| EMB.embedding c |} {| NBE.embedding nc |} + {| EMB.embedding d |} {| NBE.embedding nd |} + {| EMB.embedding r |} {| NBE.embedding nr |} + (f : a -> b -> c -> d -> option r) + (f : na -> nb -> nc -> nd -> option nr) + : primitive_step + + +val mk5' #a #b #c #d #e #r #na #nb #nc #nd #ne #nr + (u_arity : int) + (name : Ident.lid) + {| EMB.embedding a |} {| NBE.embedding na |} + {| EMB.embedding b |} {| NBE.embedding nb |} + {| EMB.embedding c |} {| NBE.embedding nc |} + {| EMB.embedding d |} {| NBE.embedding nd |} + {| EMB.embedding e |} {| NBE.embedding ne |} + {| EMB.embedding r |} {| NBE.embedding nr |} + (f : a -> b -> c -> d -> e -> option r) + (f : na -> nb -> nc -> nd -> ne -> option nr) + : primitive_step + +val mk6' #a #b #c #d #e #f #r #na #nb #nc #nd #ne #nf #nr + (u_arity : int) + (name : Ident.lid) + {| EMB.embedding a |} {| NBE.embedding na |} + {| EMB.embedding b |} {| NBE.embedding nb |} + {| EMB.embedding c |} {| NBE.embedding nc |} + {| EMB.embedding d |} {| NBE.embedding nd |} + {| EMB.embedding e |} {| NBE.embedding ne |} + {| EMB.embedding f |} {| NBE.embedding nf |} + {| EMB.embedding r |} {| NBE.embedding nr |} + (f : a -> b -> c -> d -> e -> f -> option r) + (f : na -> nb -> nc -> nd -> ne -> nf -> option nr) + : primitive_step diff --git a/src/typechecker/FStarC.TypeChecker.Primops.Docs.fst b/src/typechecker/FStarC.TypeChecker.Primops.Docs.fst new file mode 100644 index 00000000000..345aaa6bffd --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Primops.Docs.fst @@ -0,0 +1,85 @@ +module FStarC.TypeChecker.Primops.Docs + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Class.Monad + +module Z = FStarC.BigInt +module PC = FStarC.Parser.Const + +open FStarC.TypeChecker.Primops.Base + +(* FIXME: most of these disabled as they would break extraction. +In extracted code, we need to turn the doc into a term representation +for it. I'm actually not sure how to do that since the document +type is abstract even internally. *) + +let ops = + let nm l = PC.p2l ["FStar"; "Stubs"; "Pprint"; l] in + let open FStarC.Pprint in + [ + (* mk1 0 (nm "doc_of_char") doc_of_char; *) + (* mk1 0 (nm "doc_of_string") doc_of_string; *) + (* mk1 0 (nm "doc_of_bool") doc_of_bool; *) + (* mk3 0 (nm "substring") (fun s i j -> substring s (Z.to_int_fs i) (Z.to_int_fs j)); *) + (* mk2 0 (nm "fancystring") (fun s i -> fancystring s (Z.to_int_fs i)); *) + (* mk4 0 (nm "fancysubstring") (fun s i j k -> fancysubstring s (Z.to_int_fs i) (Z.to_int_fs j) (Z.to_int_fs k)); *) + (* mk1 0 (nm "utf8string") utf8string; *) + //hardline & others: zero-arity... + (* mk1 0 (nm "blank") (fun i -> blank (Z.to_int_fs i)); *) + (* mk1 0 (nm "break_") (fun i -> break_ (Z.to_int_fs i)); *) + + (* mk2 0 (nm "op_Hat_Hat") (^^); *) + (* mk2 0 (nm "op_Hat_Slash_Hat") (^/^); *) + (* mk2 0 (nm "nest") (fun i d -> nest (Z.to_int_fs i) d); *) + (* mk1 0 (nm "group") group; *) + (* mk2 0 (nm "ifflat") ifflat; *) + + (* mk2 0 (nm "precede") precede; *) + (* mk2 0 (nm "terminate") terminate; *) + (* mk3 0 (nm "enclose") enclose; *) + (* mk1 0 (nm "squotes") squotes; *) + (* mk1 0 (nm "dquotes") dquotes; *) + (* mk1 0 (nm "bquotes") bquotes; *) + (* mk1 0 (nm "braces") braces; *) + (* mk1 0 (nm "parens") parens; *) + (* mk1 0 (nm "angles") angles; *) + (* mk1 0 (nm "brackets") brackets; *) + (* mk1 0 (nm "twice") twice; *) + (* mk2 0 (nm "repeat") (fun i d -> repeat (Z.to_int_fs i) d); *) + (* mk1 0 (nm "concat") concat; *) + (* mk2 0 (nm "separate") separate; *) + + //concat_map: higher-order + //separate_map: higher-order + + (* mk3 0 (nm "separate2") separate2; *) + + //optional: higher-order + + (* mk1 0 (nm "lines") lines; *) + mk1 0 (nm "arbitrary_string") arbitrary_string; + (* mk1 0 (nm "words") words; *) + + //split: higher-order + (* mk2 0 (nm "flow") flow; *) + //flow_map: higher-order + + (* mk1 0 (nm "url") url; *) + (* mk1 0 (nm "align") align; *) + (* mk2 0 (nm "hang") (fun i d -> hang (Z.to_int_fs i) d); *) + (* mk4 0 (nm "prefix") (fun i j d1 d2 -> *) + (* prefix (Z.to_int_fs i) (Z.to_int_fs j) d1 d2); *) + (* mk3 0 (nm "jump") (fun i j d -> jump (Z.to_int_fs i) (Z.to_int_fs j) d); *) + (* mk5 0 (nm "infix") (fun i j d1 d2 d3 -> infix (Z.to_int_fs i) (Z.to_int_fs j) d1 d2 d3); *) + (* mk5 0 (nm "surround") (fun i j d1 d2 d3 -> surround (Z.to_int_fs i) (Z.to_int_fs j) d1 d2 d3); *) + (* mk5 0 (nm "soft_surround") (fun i j d1 d2 d3 -> soft_surround (Z.to_int_fs i) (Z.to_int_fs j) d1 d2 d3); *) + + // surround separate: arity too big :-) + // surroundd_separate_map: higher-order + + // pretty_string: float + mk1 0 (nm "render") render; + ] diff --git a/src/typechecker/FStarC.TypeChecker.Primops.Docs.fsti b/src/typechecker/FStarC.TypeChecker.Primops.Docs.fsti new file mode 100644 index 00000000000..01d2d44377b --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Primops.Docs.fsti @@ -0,0 +1,5 @@ +module FStarC.TypeChecker.Primops.Docs + +open FStarC.TypeChecker.Primops.Base + +val ops : list primitive_step diff --git a/src/typechecker/FStarC.TypeChecker.Primops.Eq.fst b/src/typechecker/FStarC.TypeChecker.Primops.Eq.fst new file mode 100644 index 00000000000..1162e8ca03c --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Primops.Eq.fst @@ -0,0 +1,78 @@ +module FStarC.TypeChecker.Primops.Eq + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Syntax.Syntax +open FStarC.TypeChecker +open FStarC.Class.Monad +open FStarC.Class.Show + +module PC = FStarC.Parser.Const +module S = FStarC.Syntax.Syntax +module U = FStarC.Syntax.Util +module EMB = FStarC.Syntax.Embeddings +module NBE = FStarC.TypeChecker.NBETerm +module TEQ = FStarC.TypeChecker.TermEqAndSimplify +module Env = FStarC.TypeChecker.Env + +open FStarC.TypeChecker.Primops.Base + +let s_eq (env:Env.env_t) (_typ x y : EMB.abstract_term) : option bool = + match TEQ.eq_tm env x.t y.t with + | TEQ.Equal -> Some true + | TEQ.NotEqual -> Some false + | _ -> None + +let nbe_eq env (_typ x y : NBETerm.abstract_nbe_term) : option bool = + match NBETerm.eq_t env x.t y.t with + | TEQ.Equal -> Some true + | TEQ.NotEqual -> Some false + | _ -> None + +let push3 f g x y z = f (g x y z) +let negopt3 = push3 (fmap #option not) + +let dec_eq_ops env : list primitive_step = [ + mk3' 0 PC.op_Eq (s_eq env) (nbe_eq env); + mk3' 0 PC.op_notEq (negopt3 (s_eq env)) (negopt3 (nbe_eq env)); +] + +(* Propositional equality follows. We use the abstract newtypes to +easily embed exactly the term we want. *) + +let s_eq2 env (_typ x y : EMB.abstract_term) : option EMB.abstract_term = + match TEQ.eq_tm env x.t y.t with + | TEQ.Equal -> Some (EMB.Abstract U.t_true) + | TEQ.NotEqual -> Some (EMB.Abstract U.t_false) + | _ -> None + +let nbe_eq2 env (_typ x y : NBE.abstract_nbe_term) : option NBE.abstract_nbe_term = + let open FStarC.TypeChecker.NBETerm in + match NBETerm.eq_t env x.t y.t with + | TEQ.Equal -> Some (AbstractNBE (mkFV (S.lid_as_fv PC.true_lid None) [] [])) + | TEQ.NotEqual -> Some (AbstractNBE (mkFV (S.lid_as_fv PC.false_lid None) [] [])) + | TEQ.Unknown -> None + +let s_eq3 env (typ1 typ2 x y : EMB.abstract_term) : option EMB.abstract_term = + match TEQ.eq_tm env typ1.t typ2.t, TEQ.eq_tm env x.t y.t with + | TEQ.Equal, TEQ.Equal -> Some (EMB.Abstract U.t_true) + | TEQ.NotEqual, _ + | _, TEQ.NotEqual -> + Some (EMB.Abstract U.t_false) + | _ -> None + +let nbe_eq3 env (typ1 typ2 x y : NBE.abstract_nbe_term) : option NBE.abstract_nbe_term = + let open FStarC.TypeChecker.NBETerm in + match eq_t env typ1.t typ2.t, eq_t env x.t y.t with + | TEQ.Equal, TEQ.Equal -> Some (AbstractNBE (mkFV (S.lid_as_fv PC.true_lid None) [] [])) + | TEQ.NotEqual, _ + | _, TEQ.NotEqual -> + Some (AbstractNBE (mkFV (S.lid_as_fv PC.false_lid None) [] [])) + | _ -> None + +let prop_eq_ops env : list primitive_step = [ + mk3' 1 PC.eq2_lid (s_eq2 env) (nbe_eq2 env); + mk4' 2 PC.eq3_lid (s_eq3 env) (nbe_eq3 env); +] diff --git a/src/typechecker/FStarC.TypeChecker.Primops.Eq.fsti b/src/typechecker/FStarC.TypeChecker.Primops.Eq.fsti new file mode 100644 index 00000000000..900d8f99b09 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Primops.Eq.fsti @@ -0,0 +1,7 @@ +module FStarC.TypeChecker.Primops.Eq +module Env = FStarC.TypeChecker.Env +open FStarC.TypeChecker.Primops.Base + +val dec_eq_ops (_:Env.env_t) : list primitive_step + +val prop_eq_ops (_:Env.env_t) : list primitive_step \ No newline at end of file diff --git a/src/typechecker/FStarC.TypeChecker.Primops.Erased.fst b/src/typechecker/FStarC.TypeChecker.Primops.Erased.fst new file mode 100644 index 00000000000..0ba615199f4 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Primops.Erased.fst @@ -0,0 +1,70 @@ +module FStarC.TypeChecker.Primops.Erased + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Syntax.Syntax +open FStarC.TypeChecker +open FStarC.Class.Monad +open FStarC.Class.Show + +module PC = FStarC.Parser.Const +module S = FStarC.Syntax.Syntax +module U = FStarC.Syntax.Util +module EMB = FStarC.Syntax.Embeddings +module NBE = FStarC.TypeChecker.NBETerm + +open FStarC.TypeChecker.Primops.Base + +type emb_erased (a:Type) = | Hide : x:a -> emb_erased a + +instance e_erased (a:Type) (d : EMB.embedding a) : Tot (EMB.embedding (emb_erased a)) = + let em (x:emb_erased a) rng shadow cbs = + let Hide x = x in + let h = S.fvar PC.hide None in + U.mk_app h [S.iarg (EMB.type_of d); S.as_arg (EMB.embed x rng shadow cbs)] + in + let un (t:term) cbs : option (emb_erased a) = + let head, args = U.head_and_args t in + match (U.un_uinst head).n, args with + | Tm_fvar fv, [_t; (a, None)] when fv_eq_lid fv PC.hide -> + let! v = EMB.unembed a cbs in + return (Hide v) + | _ -> + None + in + EMB.mk_emb_full em un + (fun () -> S.t_erased_of (EMB.type_of d)) + (fun (Hide x) -> "Hide " ^ EMB.printer_of d x) + (fun () -> ET_abstract) + +instance nbe_e_erased (a:Type) (d : NBE.embedding a) : Tot (NBE.embedding (emb_erased a)) = + let em cbs (x:emb_erased a) = + let Hide x = x in + let fv = S.lid_as_fv PC.hide None in + NBE.mkFV fv [] [NBE.as_arg (NBE.embed d cbs x)] + in + let un cbs (t:NBETerm.t) : option (emb_erased a) = + match NBETerm.nbe_t_of_t t with + | NBETerm.FV (fv, _, [(_t, _); (body, _)]) + when fv_eq_lid fv PC.hide -> + let! v = NBE.unembed d cbs body in + return (Hide v) + | _ -> + None + in + NBETerm.mk_emb em un + (fun () -> magic()) //NBET.t_erased_of (NBE.type_of d)) + (fun () -> ET_abstract) + +let s_reveal (a:EMB.abstract_term) (e : emb_erased EMB.abstract_term) = + let Hide x = e in Some x + +let nbe_reveal (a:NBE.abstract_nbe_term) (e : emb_erased NBE.abstract_nbe_term) = + let Hide x = e in Some x + +let ops = [ + (* unconditionally reduce reveal #t' (hide #t x) to x *) + mk2' 1 PC.reveal s_reveal nbe_reveal +] diff --git a/src/typechecker/FStarC.TypeChecker.Primops.Erased.fsti b/src/typechecker/FStarC.TypeChecker.Primops.Erased.fsti new file mode 100644 index 00000000000..fafdcc2a003 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Primops.Erased.fsti @@ -0,0 +1,5 @@ +module FStarC.TypeChecker.Primops.Erased + +open FStarC.TypeChecker.Primops.Base + +val ops : list primitive_step \ No newline at end of file diff --git a/src/typechecker/FStarC.TypeChecker.Primops.Errors.Msg.fst b/src/typechecker/FStarC.TypeChecker.Primops.Errors.Msg.fst new file mode 100644 index 00000000000..e000a215bdd --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Primops.Errors.Msg.fst @@ -0,0 +1,26 @@ +module FStarC.TypeChecker.Primops.Errors.Msg + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Class.Monad + +module Z = FStarC.BigInt +module PC = FStarC.Parser.Const + +open FStarC.TypeChecker.Primops.Base + +let ops = + let nm l = PC.p2l ["FStar"; "Stubs"; "Errors"; "Msg"; l] in + let open FStarC.Errors.Msg in + [ + mk1 0 (nm "text") text; + mk2 0 (nm "sublist") sublist; + mk1 0 (nm "bulleted") bulleted; + mk1 0 (nm "mkmsg") mkmsg; + mk1 0 (nm "subdoc") subdoc; + mk1 0 (nm "renderdoc") renderdoc; + mk1 0 (nm "backtrace_doc") backtrace_doc; + mk1 0 (nm "rendermsg") rendermsg; + ] diff --git a/src/typechecker/FStarC.TypeChecker.Primops.Errors.Msg.fsti b/src/typechecker/FStarC.TypeChecker.Primops.Errors.Msg.fsti new file mode 100644 index 00000000000..20bf10d56df --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Primops.Errors.Msg.fsti @@ -0,0 +1,7 @@ +module FStarC.TypeChecker.Primops.Errors.Msg + +(* Primitive steps for FStar.Stubs.Errors.Msg in ulib *) + +open FStarC.TypeChecker.Primops.Base + +val ops : list primitive_step diff --git a/src/typechecker/FStarC.TypeChecker.Primops.Issue.fst b/src/typechecker/FStarC.TypeChecker.Primops.Issue.fst new file mode 100644 index 00000000000..59624fb9678 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Primops.Issue.fst @@ -0,0 +1,29 @@ +module FStarC.TypeChecker.Primops.Issue + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Errors +open FStarC.Class.Monad + +open FStarC.TypeChecker.Primops.Base + +module PC = FStarC.Parser.Const +module Z = FStarC.BigInt + +let ops : list primitive_step = + let mk_lid l = PC.p2l ["FStar"; "Issue"; l] in [ + mk1 0 (mk_lid "message_of_issue") Mkissue?.issue_msg; + mk1 0 (mk_lid "level_of_issue") (fun i -> Errors.string_of_issue_level i.issue_level); + mk1 0 (mk_lid "number_of_issue") (fun i -> fmap Z.of_int_fs i.issue_number); + mk1 0 (mk_lid "range_of_issue") Mkissue?.issue_range; + mk1 0 (mk_lid "context_of_issue") Mkissue?.issue_ctx; + mk1 0 (mk_lid "render_issue") Errors.format_issue; + mk5 0 (mk_lid "mk_issue_doc") (fun level msg range number context -> + { issue_level = Errors.issue_level_of_string level; + issue_range = range; + issue_number = fmap Z.to_int_fs number; + issue_msg = msg; + issue_ctx = context} + ); + ] diff --git a/src/typechecker/FStarC.TypeChecker.Primops.Issue.fsti b/src/typechecker/FStarC.TypeChecker.Primops.Issue.fsti new file mode 100644 index 00000000000..206cadf5784 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Primops.Issue.fsti @@ -0,0 +1,5 @@ +module FStarC.TypeChecker.Primops.Issue + +open FStarC.TypeChecker.Primops.Base + +val ops : list primitive_step diff --git a/src/typechecker/FStarC.TypeChecker.Primops.MachineInts.fst b/src/typechecker/FStarC.TypeChecker.Primops.MachineInts.fst new file mode 100644 index 00000000000..161a141729f --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Primops.MachineInts.fst @@ -0,0 +1,94 @@ +module FStarC.TypeChecker.Primops.MachineInts + +(* Primops about machine integers *) + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStar.Char +open FStarC.TypeChecker.Primops.Base +module PC = FStarC.Parser.Const +module Z = FStarC.BigInt + +(* We're going full Haskell in this module *) +open FStarC.Class.Monad +open FStarC.Compiler.Writer +open FStarC.Class.Show + +open FStarC.Compiler.MachineInts + +(* NB: Eta expanding trips typeclass resolution *) +let mymon = writer (list primitive_step) + +let bounded_arith_ops_for (k : machint_kind) : mymon unit = + let mod_name = module_name_for k in + let nm s = (PC.p2l ["FStar"; module_name_for k; s]) in + (* Operators common to all *) + emit [ + mk1 0 (nm "v") (v #k); + + (* basic ops supported by all *) + mk2 0 (nm "add") (fun (x y : machint k) -> make_as x (Z.add_big_int (v x) (v y))); + mk2 0 (nm "sub") (fun (x y : machint k) -> make_as x (Z.sub_big_int (v x) (v y))); + mk2 0 (nm "mul") (fun (x y : machint k) -> make_as x (Z.mult_big_int (v x) (v y))); + + mk2 0 (nm "gt") (fun (x y : machint k) -> Z.gt_big_int (v x) (v y)); + mk2 0 (nm "gte") (fun (x y : machint k) -> Z.ge_big_int (v x) (v y)); + mk2 0 (nm "lt") (fun (x y : machint k) -> Z.lt_big_int (v x) (v y)); + mk2 0 (nm "lte") (fun (x y : machint k) -> Z.le_big_int (v x) (v y)); + ];! + + (* Unsigned ints have more operators *) + let sz = width k in + let modulus = Z.shift_left_big_int Z.one (Z.of_int_fs sz) in + let mod (x : Z.t) : Z.t = Z.mod_big_int x modulus in + if is_unsigned k then + emit [ + (* modulo operators *) + mk2 0 (nm "add_mod") (fun (x y : machint k) -> make_as x (mod (Z.add_big_int (v x) (v y)))); + mk2 0 (nm "sub_mod") (fun (x y : machint k) -> make_as x (mod (Z.sub_big_int (v x) (v y)))); + mk2 0 (nm "div") (fun (x y : machint k) -> make_as x (mod (Z.div_big_int (v x) (v y)))); + mk2 0 (nm "rem") (fun (x y : machint k) -> make_as x (mod (Z.mod_big_int (v x) (v y)))); + + (* bitwise *) + mk2 0 (nm "logor") (fun (x y : machint k) -> make_as x (Z.logor_big_int (v x) (v y))); + mk2 0 (nm "logand") (fun (x y : machint k) -> make_as x (Z.logand_big_int (v x) (v y))); + mk2 0 (nm "logxor") (fun (x y : machint k) -> make_as x (Z.logxor_big_int (v x) (v y))); + mk1 0 (nm "lognot") (fun (x : machint k) -> make_as x (Z.logand_big_int (Z.lognot_big_int (v x)) (mask k))); + + (* NB: shift_{left,right} always take a UInt32 on the right, hence the annotations + to choose the right instances. *) + mk2 0 (nm "shift_left") (fun (x : machint k) (y : machint UInt32) -> + make_as x (Z.logand_big_int (Z.shift_left_big_int (v x) (v y)) (mask k))); + mk2 0 (nm "shift_right") (fun (x : machint k) (y : machint UInt32) -> + make_as x (Z.logand_big_int (Z.shift_right_big_int (v x) (v y)) (mask k))); + ] + else return ();! + + (* Most unsigneds, except SizeT, have underspec ops *) + if is_unsigned k && k <> SizeT then + emit [ + mk2 0 (nm "add_underspec") (fun (x y : machint k) -> make_as x (mod (Z.add_big_int (v x) (v y)))); + mk2 0 (nm "sub_underspec") (fun (x y : machint k) -> make_as x (mod (Z.sub_big_int (v x) (v y)))); + mk2 0 (nm "mul_underspec") (fun (x y : machint k) -> make_as x (mod (Z.mult_big_int (v x) (v y)))); + ] + else return ();! + + (* And except for SizeT and UInt128, they have mul_mod *) + if is_unsigned k && (k <> SizeT && k <> UInt128) then + emit [ + mk2 0 (nm "mul_mod") (fun (x y : machint k) -> make_as x (mod (Z.mult_big_int (v x) (v y)))); + ] + else return ();! + + return () + +let ops : list primitive_step = + fst <| + run_writer <| + (iterM bounded_arith_ops_for all_machint_kinds ;! + emit [ + (* Single extra op that returns a U32 *) + mk1 0 PC.char_u32_of_char (fun (c : char) -> let n = Compiler.Util.int_of_char c |> Z.of_int_fs in + MachineInts.mk #UInt32 n None); + ]) diff --git a/src/typechecker/FStarC.TypeChecker.Primops.MachineInts.fsti b/src/typechecker/FStarC.TypeChecker.Primops.MachineInts.fsti new file mode 100644 index 00000000000..04bbd2268e4 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Primops.MachineInts.fsti @@ -0,0 +1,5 @@ +module FStarC.TypeChecker.Primops.MachineInts + +open FStarC.TypeChecker.Primops.Base + +val ops : list primitive_step diff --git a/src/typechecker/FStarC.TypeChecker.Primops.Range.fst b/src/typechecker/FStarC.TypeChecker.Primops.Range.fst new file mode 100644 index 00000000000..d4f254eff93 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Primops.Range.fst @@ -0,0 +1,56 @@ +module FStarC.TypeChecker.Primops.Range + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Class.Monad + +open FStarC.TypeChecker.Primops.Base +open FStarC.Compiler.Range + +module PC = FStarC.Parser.Const +module Z = FStarC.BigInt + +(* Range ops *) + +(* this type only here to use typeclass hackery *) +type unsealedRange = | U of Range.range + +let mk_range (fn : string) (from_l from_c to_l to_c : Z.t) : Range.range = + Range.mk_range fn (mk_pos (Z.to_int_fs from_l) (Z.to_int_fs from_c)) + (mk_pos (Z.to_int_fs to_l) (Z.to_int_fs to_c)) + +let __mk_range (fn : string) (from_l from_c to_l to_c : Z.t) : unsealedRange = + U (mk_range fn from_l from_c to_l to_c) + +let explode (r : unsealedRange) : (string & Z.t & Z.t & Z.t & Z.t) = + match r with + | U r -> + let open FStarC.Compiler.Range.Type in + (file_of_range r, + Z.of_int_fs (line_of_pos (start_of_range r)), + Z.of_int_fs (col_of_pos (start_of_range r)), + Z.of_int_fs (line_of_pos (end_of_range r)), + Z.of_int_fs (col_of_pos (end_of_range r))) + +instance e_unsealedRange : Syntax.Embeddings.embedding unsealedRange = + let open FStarC.Syntax.Embeddings in + embed_as e___range + (fun r -> U r) + (fun (U r) -> r) + None + +instance nbe_e_unsealedRange : FStarC.TypeChecker.NBETerm.embedding unsealedRange = + let open FStarC.TypeChecker.NBETerm in + embed_as e___range + (fun r -> U r) + (fun (U r) -> r) + None + +let ops = [ + mk5 0 PC.__mk_range_lid __mk_range; + mk5 0 PC.mk_range_lid mk_range; + mk1 0 PC.__explode_range_lid explode; + mk2 0 PC.join_range_lid FStarC.Compiler.Range.union_ranges; +] diff --git a/src/typechecker/FStarC.TypeChecker.Primops.Range.fsti b/src/typechecker/FStarC.TypeChecker.Primops.Range.fsti new file mode 100644 index 00000000000..c42a99c5e42 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Primops.Range.fsti @@ -0,0 +1,5 @@ +module FStarC.TypeChecker.Primops.Range + +open FStarC.TypeChecker.Primops.Base + +val ops : list primitive_step diff --git a/src/typechecker/FStarC.TypeChecker.Primops.Real.fst b/src/typechecker/FStarC.TypeChecker.Primops.Real.fst new file mode 100644 index 00000000000..a7a21e80d68 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Primops.Real.fst @@ -0,0 +1,98 @@ +module FStarC.TypeChecker.Primops.Real + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStarC.Class.Monad +open FStarC.Compiler.Order + +open FStarC.TypeChecker.Primops.Base +open FStarC.Syntax.Syntax +open FStarC.Syntax.Embeddings + +module PC = FStarC.Parser.Const +module Z = FStarC.BigInt +module S = FStarC.Syntax.Syntax +module U = FStarC.Syntax.Util + +(* Range ops *) + +type tf = + | T + | F + +instance e_tf : Syntax.Embeddings.embedding tf = + let ty = U.fvar_const PC.prop_lid in + let emb_t_prop = ET_app(PC.prop_lid |> Ident.string_of_lid, []) in + let em (p:tf) (rng:Range.range) _shadow _norm : term = + match p with + | T -> U.t_true + | F -> U.t_false + in + let un (t:term) _norm : option tf = + match (unmeta_div_results t).n with + | Tm_fvar fv when FStarC.Syntax.Syntax.fv_eq_lid fv PC.true_lid -> Some T + | Tm_fvar fv when FStarC.Syntax.Syntax.fv_eq_lid fv PC.false_lid -> Some F + | _ -> None + in + mk_emb_full + em + un + (fun () -> ty) + (function T -> "T" | F -> "F") + (fun () -> emb_t_prop) + +instance nbe_e_tf : TypeChecker.NBETerm.embedding tf = + let open FStarC.TypeChecker.NBETerm in + let lid_as_typ l us args = + mkFV (lid_as_fv l None) us args + in + let em _cb a = + match a with + | T -> lid_as_typ PC.true_lid [] [] + | F -> lid_as_typ PC.false_lid [] [] + in + let un _cb t = + match t.nbe_t with + | FV (fv, [], []) when fv_eq_lid fv PC.true_lid -> Some T + | FV (fv, [], []) when fv_eq_lid fv PC.false_lid -> Some F + | _ -> None + in + mk_emb em un (fun () -> lid_as_typ PC.bool_lid [] []) (Syntax.Embeddings.emb_typ_of tf) + +let cmp (r1 r2 : Compiler.Real.real) : option order = + match r1._0, r2._0 with + | "0.0", "0.0" -> Some Eq + | "0.0", "0.5" -> Some Lt + | "0.0", "1.0" -> Some Lt + | "0.5", "0.0" -> Some Gt + | "0.5", "0.5" -> Some Eq + | "0.5", "1.0" -> Some Lt + | "1.0", "0.0" -> Some Gt + | "1.0", "0.5" -> Some Gt + | "1.0", "1.0" -> Some Eq + | _ -> None + +let lt (r1 r2 : Compiler.Real.real) : option tf = + cmp r1 r2 |> Class.Monad.fmap (function Lt -> T | _ -> F) +let le (r1 r2 : Compiler.Real.real) : option tf = + cmp r1 r2 |> Class.Monad.fmap (function Lt | Eq -> T | _ -> F) +let gt (r1 r2 : Compiler.Real.real) : option tf = + cmp r1 r2 |> Class.Monad.fmap (function Gt -> T | _ -> F) +let ge (r1 r2 : Compiler.Real.real) : option tf = + cmp r1 r2 |> Class.Monad.fmap (function Gt | Eq -> T | _ -> F) + +let of_int (i:Z.t) : Compiler.Real.real = + Compiler.Real.Real (string_of_int (Z.to_int_fs i) ^ ".0") + +let ops = [ + mk1 0 PC.real_of_int of_int; +] + +let simplify_ops = [ + mk2' 0 PC.real_op_LT lt lt; + mk2' 0 PC.real_op_LTE le le; + mk2' 0 PC.real_op_GT gt gt; + mk2' 0 PC.real_op_GTE ge ge; +] diff --git a/src/typechecker/FStarC.TypeChecker.Primops.Real.fsti b/src/typechecker/FStarC.TypeChecker.Primops.Real.fsti new file mode 100644 index 00000000000..5b74234a9c4 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Primops.Real.fsti @@ -0,0 +1,6 @@ +module FStarC.TypeChecker.Primops.Real + +open FStarC.TypeChecker.Primops.Base + +val ops : list primitive_step +val simplify_ops : list primitive_step diff --git a/src/typechecker/FStarC.TypeChecker.Primops.Sealed.fst b/src/typechecker/FStarC.TypeChecker.Primops.Sealed.fst new file mode 100644 index 00000000000..6e7c8437a1d --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Primops.Sealed.fst @@ -0,0 +1,102 @@ +module FStarC.TypeChecker.Primops.Sealed + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Syntax.Syntax + +open FStarC.TypeChecker.Primops.Base + +module EMB = FStarC.Syntax.Embeddings +module NBETerm = FStarC.TypeChecker.NBETerm +module PC = FStarC.Parser.Const +module S = FStarC.Syntax.Syntax +module U = FStarC.Syntax.Util + +let bogus_cbs = { + NBETerm.iapp = (fun h _args -> h); + NBETerm.translate = (fun _ -> failwith "bogus_cbs translate"); +} + +let ops = + List.map (fun p -> { as_primitive_step_nbecbs true p with renorm_after = true}) [ + (PC.map_seal_lid, 4, 2, + (fun psc univs cbs args -> + match args with + | [(ta, _); (tb, _); (s, _); (f, _)] -> + begin + let open EMB in + let try_unembed (#a:Type) (e:embedding a) (x:term) : option a = + try_unembed x id_norm_cb + in + match try_unembed e_any ta, + try_unembed e_any tb, + try_unembed (e_sealed e_any) s, + try_unembed e_any f with + | Some ta, Some tb, Some s, Some f -> + let r = U.mk_app f [S.as_arg (Sealed.unseal s)] in + let emb = set_type ta e_any in + Some (embed_simple psc.psc_range (Sealed.seal r)) + | _ -> None + end + | _ -> None), + (fun cb univs args -> + match args with + | [(ta, _); (tb, _); (s, _); (f, _)] -> + begin + let open FStarC.TypeChecker.NBETerm in + let try_unembed (#a:Type) (e:embedding a) (x:NBETerm.t) : option a = + unembed e bogus_cbs x + in + match try_unembed e_any ta, + try_unembed e_any tb, + try_unembed (e_sealed e_any) s, + try_unembed e_any f with + | Some ta, Some tb, Some s, Some f -> + let r = cb.iapp f [as_arg (Sealed.unseal s)] in + let emb = set_type ta e_any in + Some (embed (e_sealed emb) cb (Sealed.seal r)) + | _ -> None + end + | _ -> None + )); + (PC.bind_seal_lid, 4, 2, + (fun psc univs cbs args -> + match args with + | [(ta, _); (tb, _); (s, _); (f, _)] -> + begin + let open EMB in + let try_unembed (#a:Type) (e:embedding a) (x:term) : option a = + try_unembed x id_norm_cb + in + match try_unembed e_any ta, + try_unembed e_any tb, + try_unembed (e_sealed e_any) s, + try_unembed e_any f with + | Some ta, Some tb, Some s, Some f -> + let r = U.mk_app f [S.as_arg (Sealed.unseal s)] in + Some (embed_simple #_ #e_any psc.psc_range r) + | _ -> None + end + | _ -> None), + (fun cb univs args -> + match args with + | [(ta, _); (tb, _); (s, _); (f, _)] -> + begin + let open FStarC.TypeChecker.NBETerm in + let try_unembed (#a:Type) (e:embedding a) (x:NBETerm.t) : option a = + unembed e bogus_cbs x + in + match try_unembed e_any ta, + try_unembed e_any tb, + try_unembed (e_sealed e_any) s, + try_unembed e_any f with + | Some ta, Some tb, Some s, Some f -> + let r = cb.iapp f [as_arg (Sealed.unseal s)] in + let emb = set_type ta e_any in + Some (embed emb cb r) + | _ -> None + end + | _ -> None + )); + ] diff --git a/src/typechecker/FStarC.TypeChecker.Primops.Sealed.fsti b/src/typechecker/FStarC.TypeChecker.Primops.Sealed.fsti new file mode 100644 index 00000000000..deafda894b4 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Primops.Sealed.fsti @@ -0,0 +1,5 @@ +module FStarC.TypeChecker.Primops.Sealed + +open FStarC.TypeChecker.Primops.Base + +val ops : list primitive_step diff --git a/src/typechecker/FStarC.TypeChecker.Primops.fst b/src/typechecker/FStarC.TypeChecker.Primops.fst new file mode 100644 index 00000000000..3e222569609 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Primops.fst @@ -0,0 +1,134 @@ +module FStarC.TypeChecker.Primops + +(* This module just contains the list of all builtin primitive steps +with their implementations. *) + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar.String +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.Class.Monad + +module S = FStarC.Syntax.Syntax +module BU = FStarC.Compiler.Util +module PC = FStarC.Parser.Const +module EMB = FStarC.Syntax.Embeddings +module Z = FStarC.BigInt + +open FStarC.TypeChecker.Primops.Base + +(*******************************************************************) +(* Semantics for primitive operators (+, -, >, &&, ...) *) +(*******************************************************************) + +(* Most primitive steps don't use the NBE cbs, so they can use this wrapper. *) +let as_primitive_step is_strong (l, arity, u_arity, f, f_nbe) = + Primops.Base.as_primitive_step_nbecbs is_strong (l, arity, u_arity, f, (fun cb univs args -> f_nbe univs args)) + +(* and_op and or_op are special cased because they are short-circuting, + * can run without unembedding its second argument. *) +let and_op : psc -> EMB.norm_cb -> universes -> args -> option term + = fun psc _norm_cb _us args -> + match args with + | [(a1, None); (a2, None)] -> + begin match try_unembed_simple a1 with + | Some false -> + Some (embed_simple psc.psc_range false) + | Some true -> + Some a2 + | _ -> None + end + | _ -> failwith "Unexpected number of arguments" + +let or_op : psc -> EMB.norm_cb -> universes -> args -> option term + = fun psc _norm_cb _us args -> + match args with + | [(a1, None); (a2, None)] -> + begin match try_unembed_simple a1 with + | Some true -> + Some (embed_simple psc.psc_range true) + | Some false -> + Some a2 + | _ -> None + end + | _ -> failwith "Unexpected number of arguments" + + +let division_modulus_op (f : Z.t -> Z.t -> Z.t) (x y : Z.t) : option Z.t = + if Z.to_int_fs y <> 0 + then Some (f x y) + else None + +(* Simple primops that are just implemented by some concrete function +over embeddable types. *) +let simple_ops : list primitive_step = [ + (* Basic *) + mk1 0 PC.string_of_int_lid (fun z -> string_of_int (Z.to_int_fs z)); + mk1 0 PC.int_of_string_lid (fun s -> fmap Z.of_int_fs (BU.safe_int_of_string s)); + mk1 0 PC.string_of_bool_lid string_of_bool; + mk1 0 PC.bool_of_string_lid (function "true" -> Some true | "false" -> Some false | _ -> None); + + (* Integer opts *) + mk1 0 PC.op_Minus Z.minus_big_int; + mk2 0 PC.op_Addition Z.add_big_int; + mk2 0 PC.op_Subtraction Z.sub_big_int; + mk2 0 PC.op_Multiply Z.mult_big_int; + mk2 0 PC.op_LT Z.lt_big_int; + mk2 0 PC.op_LTE Z.le_big_int; + mk2 0 PC.op_GT Z.gt_big_int; + mk2 0 PC.op_GTE Z.ge_big_int; + + (* Use ' variant to allow for non-reduction. Impl is the same on each normalizer. *) + mk2' 0 PC.op_Division (division_modulus_op Z.div_big_int) (division_modulus_op Z.div_big_int); + mk2' 0 PC.op_Modulus (division_modulus_op Z.mod_big_int) (division_modulus_op Z.mod_big_int); + + (* Bool opts. NB: && and || are special-cased since they are + short-circuiting, and can run even if their second arg does not + try_unembed_simple. Otherwise the strict variants are defined as below. *) + mk1 0 PC.op_Negation not; + // mk2 0 PC.op_And (&&); + // mk2 0 PC.op_Or ( || ); + + (* Operations from FStar.String *) + mk2 0 PC.string_concat_lid String.concat; + mk2 0 PC.string_split_lid String.split; + mk2 0 PC.prims_strcat_lid (^); + mk2 0 PC.string_compare_lid (fun s1 s2 -> Z.of_int_fs (String.compare s1 s2)); + mk1 0 PC.string_string_of_list_lid string_of_list; + mk2 0 PC.string_make_lid (fun x y -> String.make (Z.to_int_fs x) y); + mk1 0 PC.string_list_of_string_lid list_of_string; + mk1 0 PC.string_lowercase_lid String.lowercase; + mk1 0 PC.string_uppercase_lid String.uppercase; + mk2 0 PC.string_index_lid String.index; + mk2 0 PC.string_index_of_lid String.index_of; + mk3 0 PC.string_sub_lid (fun s o l -> String.substring s (Z.to_int_fs o) (Z.to_int_fs l)); +] + +let short_circuit_ops : list primitive_step = + List.map (as_primitive_step true) + [ + (PC.op_And, 2, 0, and_op, (fun _us -> NBETerm.and_op)); + (PC.op_Or, 2, 0, or_op, (fun _us -> NBETerm.or_op)); + ] + +let built_in_primitive_steps_list : list primitive_step = + simple_ops + @ short_circuit_ops + @ Primops.Issue.ops + @ Primops.Array.ops + @ Primops.Sealed.ops + @ Primops.Erased.ops + @ Primops.Docs.ops + @ Primops.MachineInts.ops + @ Primops.Errors.Msg.ops + @ Primops.Range.ops + @ Primops.Real.ops + +let env_dependent_ops (env:Env.env_t) = Primops.Eq.dec_eq_ops env + +let simplification_ops_list (env:Env.env_t) : list primitive_step = + Primops.Eq.prop_eq_ops env + @ Primops.Real.simplify_ops diff --git a/src/typechecker/FStarC.TypeChecker.Primops.fsti b/src/typechecker/FStarC.TypeChecker.Primops.fsti new file mode 100644 index 00000000000..8236610bdbb --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Primops.fsti @@ -0,0 +1,16 @@ +module FStarC.TypeChecker.Primops + +open FStarC.Compiler.Effect +include FStarC.TypeChecker.Primops.Base + +(* This module just contains the list of all builtin primitive steps +with their implementations. *) + +(* Proper primitive steps. Some of them depend on the environment, +we put those in a separate list so the independent set can be +precomputed into a hash table. *) +val built_in_primitive_steps_list : list primitive_step +val env_dependent_ops (env:Env.env_t) : list primitive_step + +(* Simplification rules. *) +val simplification_ops_list (env:Env.env_t) : list primitive_step diff --git a/src/typechecker/FStarC.TypeChecker.Quals.fst b/src/typechecker/FStarC.TypeChecker.Quals.fst new file mode 100644 index 00000000000..564e89cf344 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Quals.fst @@ -0,0 +1,321 @@ +(* + Copyright 2008-2024 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.TypeChecker.Quals +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Effect +open FStarC.Errors +open FStarC.Errors.Msg +open FStarC.Pprint +open FStarC.Syntax.Syntax +open FStarC.Ident +open FStarC.Syntax +open FStarC.Class.Show +open FStarC.Class.PP + +module SS = FStarC.Syntax.Subst +module S = FStarC.Syntax.Syntax +module BU = FStarC.Compiler.Util +module U = FStarC.Syntax.Util +module N = FStarC.TypeChecker.Normalize +module C = FStarC.Parser.Const +module TcUtil = FStarC.TypeChecker.Util + +let check_sigelt_quals_pre (env:FStarC.TypeChecker.Env.env) se = + let visibility = function Private -> true | _ -> false in + let reducibility = function + | Irreducible + | Unfold_for_unification_and_vcgen | Visible_default + | Inline_for_extraction -> true + | _ -> false in + let assumption = function Assumption | New -> true | _ -> false in + let reification = function Reifiable | Reflectable _ -> true | _ -> false in + let inferred = function + | Discriminator _ + | Projector _ + | RecordType _ + | RecordConstructor _ + | ExceptionConstructor + | HasMaskedEffect + | Effect -> true + | _ -> false in + let has_eq = function Noeq | Unopteq -> true | _ -> false in + let quals_combo_ok quals q = + match q with + | Assumption -> + quals + |> List.for_all (fun x -> x=q + || x=Logic + || inferred x + || visibility x + || assumption x + || (env.is_iface && x=Inline_for_extraction) + || x=NoExtract) + + | New -> //no definition provided + quals + |> List.for_all (fun x -> x=q || inferred x || visibility x || assumption x) + + | Inline_for_extraction -> + quals |> List.for_all (fun x -> x=q || x=Logic || visibility x || reducibility x + || reification x || inferred x || has_eq x + || (env.is_iface && x=Assumption) + || x=NoExtract) + + | Unfold_for_unification_and_vcgen + | Visible_default + | Irreducible + | Noeq + | Unopteq -> + quals + |> List.for_all (fun x -> x=q || x=Logic || x=Inline_for_extraction || x=NoExtract || has_eq x || inferred x || visibility x || reification x) + + | TotalEffect -> + quals + |> List.for_all (fun x -> x=q || inferred x || visibility x || reification x) + + | Logic -> + quals + |> List.for_all (fun x -> x=q || x=Assumption || inferred x || visibility x || reducibility x) + + | Reifiable + | Reflectable _ -> + quals + |> List.for_all (fun x -> reification x || inferred x || visibility x || x=TotalEffect || x=Visible_default) + + | Private -> + true //only about visibility; always legal in combination with others + + | _ -> //inferred + true + in + let check_no_subtyping_attribute se = + if U.has_attribute se.sigattrs C.no_subtping_attr_lid && + (match se.sigel with + | Sig_let _ -> false + | _ -> true) + then raise_error se + Errors.Fatal_InconsistentQualifierAnnotation [ + text "Illegal attribute: the `no_subtyping` attribute is allowed only on let-bindings."] + in + check_no_subtyping_attribute se; + let quals = U.quals_of_sigelt se |> List.filter (fun x -> not (x = Logic)) in //drop logic since it is deprecated + if quals |> BU.for_some (function OnlyName -> true | _ -> false) |> not + then + let r = U.range_of_sigelt se in + let no_dup_quals = BU.remove_dups (fun x y -> x=y) quals in + let err msg = raise_error r Errors.Fatal_QulifierListNotPermitted ([ + text "The qualifier list" ^/^ doc_of_string (show quals) ^/^ text "is not permissible for this element" + ] @ msg) + in + if List.length quals <> List.length no_dup_quals + then err [text "Duplicate qualifiers."]; + if not (quals |> List.for_all (quals_combo_ok quals)) + then err [text "Ill-formed combination."]; + match se.sigel with + | Sig_let {lbs=(is_rec, _)} -> //let rec + if is_rec && quals |> List.contains Unfold_for_unification_and_vcgen + then err [text "Recursive definitions cannot be marked inline."]; + if quals |> BU.for_some (fun x -> assumption x || has_eq x) + then err [text "Definitions cannot be assumed or marked with equality qualifiers."] + | Sig_bundle _ -> + if not (quals |> BU.for_all (fun x -> + x=Inline_for_extraction + || x=NoExtract + || inferred x + || visibility x + || has_eq x)) + then err []; + if quals |> List.existsb (function Unopteq -> true | _ -> false) && + U.has_attribute se.sigattrs FStarC.Parser.Const.erasable_attr + then err [text "The `unopteq` qualifier is not allowed on erasable inductives since they don't have decidable equality."] + | Sig_declare_typ _ -> + if quals |> BU.for_some has_eq + then err [] + | Sig_assume _ -> + if not (quals |> BU.for_all (fun x -> visibility x || x=Assumption || x=InternalAssumption)) + then err [] + | Sig_new_effect _ -> + if not (quals |> BU.for_all (fun x -> + x=TotalEffect + || inferred x + || visibility x + || reification x)) + then err [] + | Sig_effect_abbrev _ -> + if not (quals |> BU.for_all (fun x -> inferred x || visibility x)) + then err [] + | _ -> () + +let check_erasable env quals (r:Range.range) se = + let lids = U.lids_of_sigelt se in + let val_exists = + lids |> BU.for_some (fun l -> Option.isSome (Env.try_lookup_val_decl env l)) + in + let val_has_erasable_attr = + lids |> BU.for_some (fun l -> + let attrs_opt = Env.lookup_attrs_of_lid env l in + Option.isSome attrs_opt + && U.has_attribute (Option.get attrs_opt) FStarC.Parser.Const.erasable_attr) + in + let se_has_erasable_attr = U.has_attribute se.sigattrs FStarC.Parser.Const.erasable_attr in + if ((val_exists && val_has_erasable_attr) && not se_has_erasable_attr) + then raise_error r Errors.Fatal_QulifierListNotPermitted [ + text "Mismatch of attributes between declaration and definition."; + text "Declaration is marked `erasable` but the definition is not."; + ]; + if ((val_exists && not val_has_erasable_attr) && se_has_erasable_attr) + then raise_error r Errors.Fatal_QulifierListNotPermitted [ + text "Mismatch of attributes between declaration and definition."; + text "Definition is marked `erasable` but the declaration is not."; + ]; + if se_has_erasable_attr + then begin + match se.sigel with + | Sig_bundle _ -> + if not (quals |> BU.for_some (function Noeq -> true | _ -> false)) + then raise_error r Errors.Fatal_QulifierListNotPermitted [ + text "Incompatible attributes and qualifiers: \ + erasable types do not support decidable equality and must be marked `noeq`." + ] + | Sig_declare_typ _ -> + () + | Sig_fail _ -> + () (* just ignore it, the member ses have the attribute too *) + + | Sig_let {lbs=(false, [lb])} -> + let _, body, _ = U.abs_formals lb.lbdef in + if not (N.non_info_norm env body) + then raise_error body Errors.Fatal_QulifierListNotPermitted [ + text "Illegal attribute: \ + the `erasable` attribute is only permitted on inductive type definitions \ + and abbreviations for non-informative types."; + text "The term" ^/^ pp body ^/^ text "is considered informative."; + ] + + | Sig_new_effect ({mname=eff_name}) -> //AR: allow erasable on total effects + if not (List.contains TotalEffect quals) + then raise_error r Errors.Fatal_QulifierListNotPermitted [ + text "Effect" ^/^ pp eff_name ^/^ text "is marked erasable but only total effects are allowed to be erasable." + ] + + | _ -> + raise_error r Errors.Fatal_QulifierListNotPermitted [ + text "Illegal attribute: \ + the `erasable` attribute is only permitted on inductive type definitions \ + and abbreviations for non-informative types."; + ] + end + +(* + * Given `val t : Type` in an interface + * and `let t = e` in the corresponding implementation + * The val declaration should contains the `must_erase_for_extraction` attribute + * if and only if `e` is a type that's non-informative (e..g., unit, t -> unit, etc.) + *) +let check_must_erase_attribute env se = + if Options.ide() then () else + match se.sigel with + | Sig_let {lbs; lids=l} -> + begin match DsEnv.iface_decls (Env.dsenv env) (Env.current_module env) with + | None -> + () + + | Some iface_decls -> + snd lbs |> List.iter (fun lb -> + let lbname = BU.right lb.lbname in + let has_iface_val = + iface_decls |> BU.for_some (Parser.AST.decl_is_val (ident_of_lid lbname.fv_name.v)) + in + if has_iface_val + then + let must_erase = TcUtil.must_erase_for_extraction env lb.lbdef in + let has_attr = Env.fv_has_attr env lbname C.must_erase_for_extraction_attr in + if must_erase && not has_attr + then log_issue lbname Error_MustEraseMissing [ + text (BU.format2 "Values of type `%s` will be erased during extraction, \ + but its interface hides this fact. Add the `must_erase_for_extraction` \ + attribute to the `val %s` declaration for this symbol in the interface" + (show lbname) (show lbname)); + ] + else if has_attr && not must_erase + then log_issue lbname Error_MustEraseMissing [ + text (BU.format1 "Values of type `%s` cannot be erased during extraction, \ + but the `must_erase_for_extraction` attribute claims that it can. \ + Please remove the attribute." + (show lbname)); + ]) + end + | _ -> () + +let check_typeclass_instance_attribute env (rng:Range.range) se = + let is_tc_instance = + se.sigattrs |> BU.for_some + (fun t -> + match t.n with + | Tm_fvar fv -> S.fv_eq_lid fv FStarC.Parser.Const.tcinstance_lid + | _ -> false) + in + let check_instance_typ (ty:typ) : unit = + let _, res = U.arrow_formals_comp ty in + if not (U.is_total_comp res) then + log_issue rng FStarC.Errors.Error_UnexpectedTypeclassInstance [ + text "Instances are expected to be total."; + text "This instance has effect" ^^ pp (U.comp_effect_name res); + ]; + + let t = U.comp_result res in + let head, _ = U.head_and_args t in + let err () = + FStarC.Errors.log_issue rng FStarC.Errors.Error_UnexpectedTypeclassInstance [ + text "Instances must define instances of `class` types."; + text "Type" ^/^ pp t ^/^ text "is not a class."; + ] + in + match (U.un_uinst head).n with + | Tm_fvar fv -> + if not (Env.fv_has_attr env fv FStarC.Parser.Const.tcclass_lid) then + err () + | _ -> + err () + in + if is_tc_instance then + match se.sigel with + | Sig_let {lbs=(false, [lb])} -> + check_instance_typ lb.lbtyp + + | Sig_let _ -> + FStarC.Errors.log_issue rng FStarC.Errors.Error_UnexpectedTypeclassInstance [ + text "An `instance` definition is expected to be non-recursive and of a type that is a `class`." + ] + + | Sig_declare_typ {t} -> + check_instance_typ t + + | _ -> + FStarC.Errors.log_issue rng FStarC.Errors.Error_UnexpectedTypeclassInstance [ + text "The `instance` attribute is only allowed on `let` and `val` declarations."; + text "It is not allowed for" ^/^ squotes (arbitrary_string <| Print.sigelt_to_string_short se); + ] + +let check_sigelt_quals_post env se = + let quals = se.sigquals in + let r = se.sigrng in + check_erasable env quals r se; + check_must_erase_attribute env se; + check_typeclass_instance_attribute env r se; + () diff --git a/src/typechecker/FStarC.TypeChecker.Quals.fsti b/src/typechecker/FStarC.TypeChecker.Quals.fsti new file mode 100644 index 00000000000..9a23f2e8de1 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Quals.fsti @@ -0,0 +1,37 @@ +(* + Copyright 2008-2024 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.TypeChecker.Quals + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Syntax.Syntax +open FStarC.TypeChecker.Env + +(* +Checking qualifiers **and attributes**. This is split in two functions, +_pre and _post, as some qualifier/attributes must be checked before the function +is typechecked (or at least it's better/faster to do so) and some can only be checked +after the function is typechecked. + +Currently, the only things that must be checked after the function is typechecked are: +- The erasable attribute, since the defn must be elaborated. See #3253. +- The must_erase attribute +- The instance attribute for typeclasses +*) + +val check_sigelt_quals_pre : env -> sigelt -> unit +val check_sigelt_quals_post : env -> sigelt -> unit diff --git a/src/typechecker/FStarC.TypeChecker.Rel.fst b/src/typechecker/FStarC.TypeChecker.Rel.fst new file mode 100644 index 00000000000..3487afbafd2 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Rel.fst @@ -0,0 +1,5787 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +////////////////////////////////////////////////////////////////////////// +//Refinement subtyping with higher-order unification +//with special treatment for higher-order patterns +////////////////////////////////////////////////////////////////////////// + +module FStarC.TypeChecker.Rel +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.Errors +open FStarC.Defensive +open FStarC.TypeChecker +open FStarC.Syntax +open FStarC.TypeChecker.Env +open FStarC.Syntax.Syntax +open FStarC.Syntax.Subst +open FStarC.Ident +open FStarC.TypeChecker.Common +open FStarC.Syntax +open FStarC.Common + +open FStarC.Class.Deq +open FStarC.Class.Show +open FStarC.Class.Tagged +open FStarC.Class.Setlike +open FStarC.Class.Listlike +open FStarC.Class.Monoid +module Setlike = FStarC.Class.Setlike +open FStarC.Class.Listlike +open FStarC.Compiler.CList +module Listlike = FStarC.Class.Listlike + +module BU = FStarC.Compiler.Util //basic util +module U = FStarC.Syntax.Util +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module N = FStarC.TypeChecker.Normalize +module UF = FStarC.Syntax.Unionfind +module PC = FStarC.Parser.Const +module FC = FStarC.Const +module TcComm = FStarC.TypeChecker.Common +module TEQ = FStarC.TypeChecker.TermEqAndSimplify +module CList = FStarC.Compiler.CList + +let dbg_Disch = Debug.get_toggle "Disch" +let dbg_Discharge = Debug.get_toggle "Discharge" +let dbg_EQ = Debug.get_toggle "EQ" +let dbg_ExplainRel = Debug.get_toggle "ExplainRel" +let dbg_GenUniverses = Debug.get_toggle "GenUniverses" +let dbg_ImplicitTrace = Debug.get_toggle "ImplicitTrace" +let dbg_Imps = Debug.get_toggle "Imps" +let dbg_LayeredEffectsApp = Debug.get_toggle "LayeredEffectsApp" +let dbg_LayeredEffectsEqns = Debug.get_toggle "LayeredEffectsEqns" +let dbg_Rel = Debug.get_toggle "Rel" +let dbg_RelBench = Debug.get_toggle "RelBench" +let dbg_RelDelta = Debug.get_toggle "RelDelta" +let dbg_RelTop = Debug.get_toggle "RelTop" +let dbg_ResolveImplicitsHook = Debug.get_toggle "ResolveImplicitsHook" +let dbg_Simplification = Debug.get_toggle "Simplification" +let dbg_SMTQuery = Debug.get_toggle "SMTQuery" +let dbg_Tac = Debug.get_toggle "Tac" + +instance showable_implicit_checking_status : showable implicit_checking_status = { + show = (function + | Implicit_unresolved -> "Implicit_unresolved" + | Implicit_checking_defers_univ_constraint -> "Implicit_checking_defers_univ_constraint" + | Implicit_has_typing_guard (tm, typ) -> "Implicit_has_typing_guard"); +} + +let is_base_type env typ = + let t = FStarC.TypeChecker.Normalize.unfold_whnf env typ in + let head, args = U.head_and_args t in + match (U.unascribe (U.un_uinst head)).n with + | Tm_name _ + | Tm_fvar _ + | Tm_type _ -> true + | _ -> false + +let term_is_uvar (uv:ctx_uvar) (t:term) : bool = + match (U.unascribe t).n with + | Tm_uvar (uv', _) -> UF.equiv uv.ctx_uvar_head uv'.ctx_uvar_head + | _ -> false + +let binders_as_bv_set (bs:binders) : FlatSet.t bv = + Setlike.from_list (List.map (fun b -> b.binder_bv) bs) + +(* lazy string, for error reporting *) +type lstring = Thunk.t string + +(* Make a thunk for a string, but keep the UF state + * so it can be set before calling the function. This is + * used since most error messages call term_to_string, + * which will resolve uvars and explode if the version is + * wrong. *) +let mklstr (f : unit -> string) = + let uf = UF.get () in + Thunk.mk (fun () -> + let tx = UF.new_transaction () in + UF.set uf; + let r = f () in + UF.rollback tx; + r) + +(* Instantiation of unification variables *) +type uvi = + | TERM of ctx_uvar & term + | UNIV of S.universe_uvar & universe + +type defer_ok_t = + | NoDefer + | DeferAny + | DeferFlexFlexOnly + +instance _ : showable defer_ok_t = { + show = (function | NoDefer -> "NoDefer" | DeferAny -> "DeferAny" | DeferFlexFlexOnly -> "DeferFlexFlexOnly"); +} + +(* The set of problems currently being addressed *) +type worklist = { + attempting: probs; + wl_deferred: clist (int & deferred_reason & lstring & prob); //flex-flex cases, non patterns, and subtyping constraints involving a unification variable, + wl_deferred_to_tac: clist (int & deferred_reason & lstring & prob); //problems that should be dispatched to a user-provided tactics + ctr: int; //a counter incremented each time we extend subst, used to detect if we've made progress + defer_ok: defer_ok_t; //whether or not carrying constraints is ok---at the top-level, this flag is NoDefer + smt_ok: bool; //whether or not falling back to the SMT solver is permitted + umax_heuristic_ok: bool; //whether or not it's ok to apply a structural match on umax us = umax us' + tcenv: Env.env; //the top-level environment on which Rel was called + wl_implicits: implicits_t; //additional uvars introduced + repr_subcomp_allowed:bool; //whether subtyping of effectful computations + //with a representation (which need a monadic lift) + //is allowed; disabled by default, enabled in + //sub_comp which is called by the typechecker, and + //will insert the appropriate lifts. + typeclass_variables: RBSet.t ctx_uvar //variables that will be solved by typeclass instantiation +} + +(* A NOTE ON ENVIRONMENTS + +At many points during unification, we need to produce a typechecking +environment (Env.env) in order to call into functions such as type_of, +universe_of, and normalization. Hence, it is important to respect +scoping, particularly so after the removal of the use_bv_sorts flag. + +Functions in this module used to explicitly pass around an Env.env, and +used that to call into Tc/Norm. However, while some of them pushed +binders as needed, some of them did not, and the result was a flurry of +subtle scoping bugs. And while those were fixed, we decided to just be +more principled. + +The worklist, threaded through almost all functions, contains the +top-level environment on which the unifier was called. Problems +contain a unification variable with a gamma inside. Hence, to get +an environment, we use `p_env` below which reconstructs it from the +worklist's tcenv and a problem's uvar. This makes sure it is in-sync +with the problem being tackled. The uses of push_bv/push_binder should +be few. +*) + +let as_deferred (wl_def:clist (int & deferred_reason & lstring & prob)) : deferred = + CList.map (fun (_, reason, m, p) -> reason, Thunk.force m, p) wl_def + +let as_wl_deferred wl (d:deferred): clist (int & deferred_reason & lstring & prob) = + CList.map (fun (reason, m, p) -> wl.ctr, reason, Thunk.mkv m, p) d + +(* --------------------------------------------------------- *) +(* Generating new unification variables/patterns *) +(* --------------------------------------------------------- *) +let new_uvar reason wl r gamma binders k should_check meta : ctx_uvar & term & worklist = + let decoration = { + uvar_decoration_typ = k; + uvar_decoration_should_check = should_check; + uvar_decoration_typedness_depends_on = []; + uvar_decoration_should_unrefine = false; + } + in + let ctx_uvar = { + ctx_uvar_head=UF.fresh decoration r; + ctx_uvar_gamma=gamma; + ctx_uvar_binders=binders; + ctx_uvar_reason=reason; + ctx_uvar_range=r; + ctx_uvar_meta=meta; + } in + check_uvar_ctx_invariant reason r true gamma binders; + let t = mk (Tm_uvar (ctx_uvar, ([], NoUseRange))) r in + let imp = { imp_reason = reason + ; imp_tm = t + ; imp_uvar = ctx_uvar + ; imp_range = r + } in + if !dbg_ImplicitTrace then + BU.print1 "Just created uvar (Rel) {%s}\n" (show ctx_uvar.ctx_uvar_head); + ctx_uvar, t, {wl with wl_implicits = cons imp wl.wl_implicits} + +let copy_uvar u (bs:binders) t wl = + let env = {wl.tcenv with gamma = u.ctx_uvar_gamma } in + let env = Env.push_binders env bs in + new_uvar ("copy:"^u.ctx_uvar_reason) wl u.ctx_uvar_range env.gamma + (Env.all_binders env) t + (U.ctx_uvar_should_check u) + u.ctx_uvar_meta + +(* --------------------------------------------------------- *) +(* *) +(* --------------------------------------------------------- *) + +(* Types used in the output of the solver *) + +type solution = + | Success of deferred & deferred & implicits_t + | Failed of prob & lstring + +let extend_wl (wl:worklist) (defers:deferred) (defer_to_tac:deferred) (imps:implicits_t) = + {wl with wl_deferred=wl.wl_deferred ++ as_wl_deferred wl defers; + wl_deferred_to_tac=wl.wl_deferred_to_tac ++ as_wl_deferred wl defer_to_tac; + wl_implicits=wl.wl_implicits ++ imps} + +type variance = + | COVARIANT + | CONTRAVARIANT + | INVARIANT + +type tprob = problem typ +type cprob = problem comp +type problem_t 'a = problem 'a + +(* --------------------------------------------------------- *) +(* *) +(* --------------------------------------------------------- *) + +(* ------------------------------------------------*) +(* *) +(* ------------------------------------------------*) +let invert_rel = function + | EQ -> EQ + | SUB -> SUBINV + | SUBINV -> SUB +let invert p = {p with lhs=p.rhs; rhs=p.lhs; relation=invert_rel p.relation} +let maybe_invert p = if p.relation = SUBINV then invert p else p +let maybe_invert_p = function + | TProb p -> maybe_invert p |> TProb + | CProb p -> maybe_invert p |> CProb +let make_prob_eq = function + | TProb p -> TProb ({p with relation=EQ}) + | CProb p -> CProb ({p with relation=EQ}) +let vary_rel rel = function + | INVARIANT -> EQ + | CONTRAVARIANT -> invert_rel rel + | COVARIANT -> rel +let p_pid = function + | TProb p -> p.pid + | CProb p -> p.pid +let p_rel = function + | TProb p -> p.relation + | CProb p -> p.relation +let p_reason = function + | TProb p -> p.reason + | CProb p -> p.reason +let p_loc = function + | TProb p -> p.loc + | CProb p -> p.loc +let p_element = function + | TProb p -> p.element + | CProb p -> p.element +let p_guard = function + | TProb p -> p.logical_guard + | CProb p -> p.logical_guard +let p_scope prob = + let r = match prob with + | TProb p -> p.logical_guard_uvar.ctx_uvar_binders @ (match p_element prob with | None -> [] | Some x -> [S.mk_binder x]) + | CProb p -> p.logical_guard_uvar.ctx_uvar_binders @ (match p_element prob with | None -> [] | Some x -> [S.mk_binder x]) + in + (* def_scope_wf "p_scope" (p_loc prob) r; *) + r +let p_guard_uvar = function + | TProb p -> p.logical_guard_uvar + | CProb p -> p.logical_guard_uvar +let p_env wl prob = + (* Note: ctx_uvar_gamma should be an extension of tcenv.gamma, + * since we created this uvar during this unification run. *) + { wl.tcenv with gamma=(p_guard_uvar prob).ctx_uvar_gamma} + +let p_guard_env wl prob = + { wl.tcenv with gamma=(match p_element prob with | None -> [] | Some x -> [Binding_var x]) @ (p_guard_uvar prob).ctx_uvar_gamma} + +(* ------------------------------------------------*) +(* *) +(* ------------------------------------------------*) + +(* ------------------------------------------------*) +(* *) +(* ------------------------------------------------*) + +let def_scope_wf msg rng r = + if not (Options.defensive ()) then () else + let rec aux prev next = + match next with + | [] -> () + | ({binder_bv=bv})::bs -> + begin + def_check_scoped rng msg prev bv.sort; + aux (prev @ [bv]) bs + end + in aux [] r + +instance hasBinders_prob : Class.Binders.hasBinders prob = { + boundNames = (fun prob -> Setlike.from_list (List.map (fun b -> b.binder_bv) <| p_scope prob)); +} + +let def_check_term_scoped_in_prob msg prob phi = + def_check_scoped #prob_t #term (p_loc prob) msg prob phi + +let def_check_comp_scoped_in_prob msg prob phi = + def_check_scoped #prob_t #comp (p_loc prob) msg prob phi + +let def_check_prob msg prob = + if not (Options.defensive ()) then () else + let msgf m = msg ^ "." ^ string_of_int (p_pid prob) ^ "." ^ m in + def_scope_wf (msgf "scope") (p_loc prob) (p_scope prob); + def_check_term_scoped_in_prob (msgf "guard") prob (p_guard prob); + match prob with + | TProb p -> + begin + def_check_term_scoped_in_prob (msgf "lhs") prob p.lhs; + def_check_term_scoped_in_prob (msgf "rhs") prob p.rhs + end + | CProb p -> + begin + def_check_comp_scoped_in_prob (msgf "lhs") prob p.lhs; + def_check_comp_scoped_in_prob (msgf "rhs") prob p.rhs + end + +(* ------------------------------------------------*) +(* *) +(* ------------------------------------------------*) + +(* ------------------------------------------------*) +(* (mainly for debugging) *) +(* ------------------------------------------------*) +let rel_to_string = function + | EQ -> "=" + | SUB -> "<:" + | SUBINV -> ":>" + +let term_to_string t = + let head, args = U.head_and_args t in + match head.n with + | Tm_uvar (u, s) -> + BU.format3 "%s%s %s" + (show u) + ("@" ^ show (fst s)) + (show args) + | _ -> show t + +let prob_to_string env prob = + match prob with + | TProb p -> + BU.format "\n%s:\t%s \n\t\t%s\n\t%s\n\t(reason:%s) (logical:%s)\n" //\twith guard %s\n\telement= %s\n" // (guard %s)\n\t\t\n\t\t\t%s\n\t\t" + [(BU.string_of_int p.pid); + (term_to_string p.lhs); + (rel_to_string p.relation); + (term_to_string p.rhs); + (match p.reason with | [] -> "" | r::_ -> r); + (show p.logical) + //(term_to_string p.logical_guard); + //(match p.element with None -> "none" | Some t -> term_to_string t) + (* (N.term_to_string env (fst p.logical_guard)); *) + (* (p.reason |> String.concat "\n\t\t\t") *)] + | CProb p -> + BU.format4 "\n%s:\t%s \n\t\t%s\n\t%s" + (BU.string_of_int p.pid) + (N.comp_to_string env p.lhs) + (rel_to_string p.relation) + (N.comp_to_string env p.rhs) + +let prob_to_string' (wl:worklist) (prob:prob) : string = + let env = p_env wl prob in + prob_to_string env prob + +let uvi_to_string env = function + | UNIV (u, t) -> + let x = if (Options.hide_uvar_nums()) then "?" else UF.univ_uvar_id u |> string_of_int in + BU.format2 "UNIV %s <- %s" x (show t) + + | TERM (u, t) -> + let x = if (Options.hide_uvar_nums()) then "?" else UF.uvar_id u.ctx_uvar_head |> string_of_int in + BU.format2 "TERM %s <- %s" x (N.term_to_string env t) +let uvis_to_string env uvis = FStarC.Common.string_of_list (uvi_to_string env) uvis + +(* ------------------------------------------------*) +(* *) +(* ------------------------------------------------*) + + +(* ------------------------------------------------*) +(* Operations on worklists *) +(* ------------------------------------------------*) +let empty_worklist env = { + attempting=[]; + wl_deferred=empty; + wl_deferred_to_tac=empty; + ctr=0; + tcenv=env; + defer_ok=DeferAny; + smt_ok=true; + umax_heuristic_ok=true; + wl_implicits=empty; + repr_subcomp_allowed=false; + typeclass_variables = Setlike.empty(); +} + +let giveup wl (reason : lstring) prob = + if !dbg_Rel then + BU.print2 "Failed %s:\n%s\n" (Thunk.force reason) (prob_to_string' wl prob); + Failed (prob, reason) + +let giveup_lit wl (reason : string) prob = + giveup wl (mklstr (fun () -> reason)) prob + +(* ------------------------------------------------*) +(* *) +(* ------------------------------------------------*) + +let singleton wl prob smt_ok = {wl with attempting=[prob]; smt_ok = smt_ok} +let wl_of_guard env g = {empty_worklist env with attempting=List.map (fun (_, _, p) -> p) g} +let defer reason msg prob wl = {wl with wl_deferred= cons (wl.ctr, reason, msg, prob) wl.wl_deferred} +let defer_lit reason msg prob wl = defer reason (Thunk.mkv msg) prob wl +let attempt probs wl = + List.iter (def_check_prob "attempt") probs; + {wl with attempting=probs@wl.attempting} + +let mk_eq2 wl prob t1 t2 : term & worklist = + let env = p_env wl prob in + def_check_scoped t1.pos "mk_eq2.t1" env t1; + def_check_scoped t2.pos "mk_eq2.t2" env t2; + (* NS: Rather than introducing a new variable, it would be much preferable + to simply compute the type of t1 here. + Sadly, it seems to be way too expensive to call env.type_of here. + *) + // let t_type, u = U.type_u () in + // let binders = Env.all_binders env in + // let _, tt, wl = new_uvar "eq2" wl t1.pos env.gamma binders t_type (Allow_unresolved "eq2 type") None in + let tt, _ = env.typeof_well_typed_tot_or_gtot_term env t1 false in + let u = env.universe_of env tt in + U.mk_eq2 u tt t1 t2, wl + +let p_invert = function + | TProb p -> TProb <| invert p + | CProb p -> CProb <| invert p +let p_logical = function + | TProb p -> p.logical + | CProb p -> p.logical +let set_logical (b:bool) = function + | TProb p -> TProb {p with logical=b} + | CProb p -> CProb {p with logical=b} + +let is_top_level_prob p = p_reason p |> List.length = 1 +let next_pid = + let ctr = BU.mk_ref 0 in + fun () -> incr ctr; !ctr + +(* Creates a subproblem of [orig], in a context extended with [scope]. *) +let mk_problem wl scope orig lhs rel rhs elt reason = + let scope = + match elt with + | None -> scope + | Some x -> scope @ [S.mk_binder x] + in + let bs = (p_guard_uvar orig).ctx_uvar_binders @ scope in + let gamma = List.rev (List.map (fun b -> Binding_var b.binder_bv) scope) @ (p_guard_uvar orig).ctx_uvar_gamma in + let ctx_uvar, lg, wl = + new_uvar ("mk_problem: logical guard for " ^ reason) + wl + Range.dummyRange + gamma + bs + U.ktype0 + (Allow_untyped "logical guard") + None + in + let prob = + //logical guards are always squashed; + //their range is intentionally dummy + { + pid=next_pid(); + lhs=lhs; + relation=rel; + rhs=rhs; + element=elt; + logical_guard=lg; + logical_guard_uvar=ctx_uvar; + reason=reason::p_reason orig; + loc=p_loc orig; + rank=None; + logical=p_logical orig; + } + in + (prob, wl) + +let mk_t_problem wl scope orig lhs rel rhs elt reason = + def_check_prob (reason ^ ".mk_t.arg") orig; + let p, wl = mk_problem wl scope orig lhs rel rhs elt reason in + def_check_prob (reason ^ ".mk_t") (TProb p); + TProb p, wl + +let mk_c_problem wl scope orig lhs rel rhs elt reason = + def_check_prob (reason ^ ".mk_c.arg") orig; + let p, wl = mk_problem wl scope orig lhs rel rhs elt reason in + def_check_prob (reason ^ ".mk_c") (CProb p); + CProb p, wl + +let new_problem wl env lhs rel rhs (subject:option bv) loc reason = + let lg_ty = + match subject with + | None -> U.ktype0 + | Some x -> + let bs = [S.mk_binder x] in + U.arrow bs (S.mk_Total U.ktype0) + in + let ctx_uvar, lg, wl = + new_uvar ("new_problem: logical guard for " ^ reason) + ({wl with tcenv=env}) + loc + env.gamma + (Env.all_binders env) + lg_ty + (Allow_untyped "logical guard") + None + in + let lg = + match subject with + | None -> lg + | Some x -> S.mk_Tm_app lg [S.as_arg <| S.bv_to_name x] loc + in + let prob = + { + pid=next_pid(); + lhs=lhs; + relation=rel; + rhs=rhs; + element=subject; + logical_guard=lg; + logical_guard_uvar=ctx_uvar; + reason=[reason]; + loc=loc; + rank=None; + logical=false; (* use set_logical to set this *) + } in + prob, wl + +let problem_using_guard orig lhs rel rhs elt reason = + let p = { + pid=next_pid(); + lhs=lhs; + relation=rel; + rhs=rhs; + element=elt; + logical_guard=p_guard orig; + logical_guard_uvar=p_guard_uvar orig; + reason=reason::p_reason orig; + loc=p_loc orig; + rank=None; + logical = p_logical orig; + } in + def_check_prob reason (TProb p); + p + +let guard_on_element wl problem x phi : term = + match problem.element with + | None -> + let tcenv = p_env wl (TProb problem) in + let u = tcenv.universe_of tcenv x.sort in + U.mk_forall u x phi + | Some e -> Subst.subst [NT(x,S.bv_to_name e)] phi + +let explain wl d (s : lstring) = + if !dbg_ExplainRel || !dbg_Rel + then BU.format4 "(%s) Failed to solve the sub-problem\n%s\nWhich arose because:\n\t%s\nFailed because:%s\n" + (Range.string_of_range <| p_loc d) + (prob_to_string' wl d) + (p_reason d |> String.concat "\n\t>") + (Thunk.force s) + else let d = maybe_invert_p d in + let rel = match p_rel d with + | EQ -> "equal to" + | SUB -> "a subtype of" + | _ -> failwith "impossible" in + let lhs, rhs = match d with + | TProb tp -> Err.print_discrepancy (N.term_to_string (p_env wl d)) tp.lhs tp.rhs + | CProb cp -> Err.print_discrepancy (N.comp_to_string (p_env wl d)) cp.lhs cp.rhs in + BU.format3 "%s is not %s the expected type %s" lhs rel rhs + +(* ------------------------------------------------*) +(* *) +(* ------------------------------------------------*) + + +(* ------------------------------------------------*) +(* Instantiating unification variables *) +(* ------------------------------------------------*) + +let occurs (uk:ctx_uvar) t = + let uvars = + Free.uvars t + |> elems // Bad: order dependent + in + let occurs = + (uvars + |> BU.for_some (fun uv -> + UF.equiv uv.ctx_uvar_head uk.ctx_uvar_head)) + in + uvars, occurs + +let occurs_check (uk:ctx_uvar) t = + let uvars, occurs = occurs uk t in + let msg = + if not occurs then None + else Some (BU.format2 "occurs-check failed (%s occurs in %s)" + (show uk.ctx_uvar_head) + (show t)) in + uvars, not occurs, msg + +let occurs_full (uk:ctx_uvar) t = + let uvars = + Free.uvars_full t + |> elems // Bad: order dependent + in + let occurs = + (uvars + |> BU.for_some (fun uv -> + UF.equiv uv.ctx_uvar_head uk.ctx_uvar_head)) + in + occurs + +let set_uvar env u (should_check_opt:option S.should_check_uvar) t = + // Useful for debugging uvars setting bugs + // if !dbg_Rel + // then ( + // BU.print2 "Setting uvar %s to %s\n" + // (show u) + // (show t); + // match Unionfind.find u.ctx_uvar_head with + // | None -> () + // | Some t -> + // BU.print2 "Uvar already set to %s\n%s\n" + // (show t) + // (BU.stack_dump()); + // failwith "DIE" + // ); + + (match should_check_opt with + | None -> () + | Some should_check -> + UF.change_decoration u.ctx_uvar_head + ({UF.find_decoration u.ctx_uvar_head with uvar_decoration_should_check=should_check})); + + if Options.defensive () then ( + if snd (occurs u t) then + failwith "OCCURS BUG!" + ); + + U.set_uvar u.ctx_uvar_head t + +let commit (env:env_t) (uvis:list uvi) = uvis |> List.iter (function + | UNIV(u, t) -> + begin match t with + | U_unif u' -> UF.univ_union u u' + | _ -> UF.univ_change u t + end + | TERM(u, t) -> + def_check_scoped #(list bv) #term t.pos "commit" (List.map (fun b -> b.binder_bv) u.ctx_uvar_binders) t; + set_uvar env u None t + ) + +let find_term_uvar uv s = BU.find_map s (function + | UNIV _ -> None + | TERM(u, t) -> if UF.equiv uv u.ctx_uvar_head then Some t else None) + +let find_univ_uvar u s = BU.find_map s (function + | UNIV(u', t) -> if UF.univ_equiv u u' then Some t else None + | _ -> None) + +(* ------------------------------------------------*) +(* *) +(* ------------------------------------------------*) + + +(* ------------------------------------------------*) +(* *) +(* ------------------------------------------------*) +let sn' env t = SS.compress (N.normalize [Env.Beta; Env.Reify] env t) |> U.unlazy_emb +let sn env t = + Profiling.profile + (fun () -> + sn' env t) + (Some (Ident.string_of_lid (Env.current_module env))) + "FStarC.TypeChecker.Rel.sn" +let norm_with_steps profiling_tag steps env t = + Profiling.profile + (fun () -> + N.normalize steps env t) + (Some (Ident.string_of_lid (Env.current_module env))) + profiling_tag + + +let should_strongly_reduce t = + let h, _ = t |> U.unascribe |> U.head_and_args in + match (SS.compress h).n with + | Tm_constant (FStarC.Const.Const_reify _) -> true + | _ -> false + +let whnf env t = + let norm steps t = + t |> U.unmeta + |> N.normalize steps env + |> SS.compress + |> U.unlazy_emb in + + Profiling.profile + (fun () -> + let steps = + (if should_strongly_reduce t + then [Env.Exclude Env.Zeta; Env.UnfoldUntil delta_constant] + else [Env.Weak; Env.HNF]) // GM: an explanation of this bit would be good, I just retained it + @ [Env.Beta; Env.Reify; Env.Primops] + in + norm steps t) + (Some (Ident.string_of_lid (Env.current_module env))) + "FStarC.TypeChecker.Rel.whnf" + +let norm_arg env t = sn env (fst t), snd t +let sn_binders env (binders:binders) = + binders |> List.map (fun b -> {b with binder_bv={b.binder_bv with sort=sn env b.binder_bv.sort} }) + +(* norm_univ wl u + Replace all unification variables in u with their solution in wl, if any + And normalize the result +*) +let norm_univ wl u = + let rec aux u = + let u = SS.compress_univ u in + match u with + | U_succ u -> + U_succ (aux u) + + | U_max us -> + U_max (List.map aux us) + + | _ -> u in + N.normalize_universe wl.tcenv (aux u) + +let normalize_refinement steps env t0 : term = + Profiling.profile + (fun () -> N.normalize_refinement steps env t0) + (Some (Ident.string_of_lid (Env.current_module env))) + "FStarC.TypeChecker.Rel.normalize_refinement" + +let base_and_refinement_maybe_delta should_delta env t1 = + let norm_refinement env t = + let steps = + if should_delta + then [Env.Weak; Env.HNF; Env.UnfoldUntil delta_constant] + else [Env.Weak; Env.HNF] in + normalize_refinement steps env t + in + let rec aux norm t1 = + let t1 = U.unmeta t1 in + match t1.n with + | Tm_refine {b=x; phi} -> + if norm + then (x.sort, Some(x, phi)) + else (match norm_refinement env t1 with + | {n=Tm_refine {b=x; phi}} -> (x.sort, Some(x, phi)) + | tt -> failwith (BU.format2 "impossible: Got %s ... %s\n" + (show tt) + (tag_of tt)) + ) + + | Tm_lazy i -> aux norm (U.unfold_lazy i) + + | Tm_uinst _ + | Tm_fvar _ + | Tm_app _ -> + if norm + then (t1, None) + else let t1' = norm_refinement env t1 in + begin match (SS.compress t1').n with + | Tm_refine _ -> aux true t1' + | _ -> t1, None + end + + | Tm_type _ + | Tm_constant _ + | Tm_name _ + | Tm_bvar _ + | Tm_arrow _ + | Tm_abs _ + | Tm_quoted _ + | Tm_uvar _ + | Tm_let _ + | Tm_match _ -> (t1, None) + + | Tm_meta _ + | Tm_ascribed _ //NS: Why are the two previous cases excluded? Because of the whnf/unmeta + | Tm_delayed _ + | Tm_unknown -> failwith (BU.format2 "impossible (outer): Got %s ... %s\n" (show t1) (tag_of t1)) in + + aux false (whnf env t1) + +let base_and_refinement env t : term & option (bv & term) = + base_and_refinement_maybe_delta false env t + +let unrefine env t : term = + base_and_refinement env t |> fst + +let trivial_refinement t : bv & term = + S.null_bv t, U.t_true + +let as_refinement delta env t : bv & term = + let t_base, refinement = base_and_refinement_maybe_delta delta env t in + match refinement with + | None -> trivial_refinement t_base + | Some (x, phi) -> x, phi + +let force_refinement (t_base, refopt) : term = + let y, phi = match refopt with + | Some (y, phi) -> y, phi + | None -> trivial_refinement t_base in + mk (Tm_refine {b=y; phi}) t_base.pos + +(* ------------------------------------------------ *) +(* *) +(* ------------------------------------------------ *) + +(* ------------------------------------------------ *) +(* *) +(* ------------------------------------------------ *) + +let wl_to_string wl = + let probs_to_string (ps:list prob) = + List.map (prob_to_string' wl) ps |> String.concat "\n\t" + in + let cprobs_to_string (ps:clist prob) = + (* meh ... *) + CList.map (prob_to_string' wl) ps |> to_list |> String.concat "\n\t" + in + BU.format2 "{ attempting = [ %s ];\n\ + deferred = [ %s ] }\n" + (probs_to_string wl.attempting) + (cprobs_to_string (CList.map (fun (_, _, _, x) -> x) wl.wl_deferred)) + +instance showable_wl : showable worklist = { + show = wl_to_string; +} + +(* ------------------------------------------------ *) +(* *) +(* ------------------------------------------------ *) + +(* A flexible term: the full term, + * its unification variable at the head, + * and the arguments the uvar is applied to. *) +type flex_t = + | Flex of (term & ctx_uvar & args) + +let flex_reason (Flex (_, u, _)) = u.ctx_uvar_reason + +let flex_uvar (Flex (_, u, _)) = u + +let flex_uvar_has_meta_tac u = + match u.ctx_uvar_meta with + | Some (Ctx_uvar_meta_tac _) -> true + | _ -> false + +let flex_t_to_string (Flex (_, c, args)) = + BU.format2 "%s [%s]" (show c) (show args) + +let is_flex t = + let head, _args = U.head_and_args t in + match (SS.compress head).n with + | Tm_uvar _ -> true + | _ -> false + +let flex_uvar_head t = + let head, _args = U.head_and_args t in + match (SS.compress head).n with + | Tm_uvar (u, _) -> u + | _ -> failwith "Not a flex-uvar" + +(* ensure_no_uvar_subst: Make sure the uvar at the head of t0 is not + * affected by a the substitution in the Tm_uvar node. + * + * In the case that it is, first solve it to a new appropriate uvar + * without a substitution. This function returns t again, though it is + * unchanged (the changes only happen in the UF graph). + * + * The way we generate the new uvar is by making a new variable with + * that is "hoisted" and which we apply to the binders of the original + * uvar. There is an optimization in place to hoist as few binders as + * possible. + * + * Example: If we have ((x:a),(y:b),(z:c) |- ?u : ty)[y <- 42], we will + * make ?u' with x in its binders, abstracted over y and z: + * + * (x |- ?u') : b -> c -> ty + * + * (we keep x since it's unaffected by the substitution; z is not since + * it has y in scope) and then solve + * + * ?u <- (?u' y z) + * + * Which means the original term now compresses to ?u' 42 z. The flex + * problem we now return is + * + * ?u', [42 z] + * + * We also return early if the substitution is empty or if the uvar is + * totally unaffected by it. + * + * NB: This function only uses the environment for debugging flags, + * so it's safe to pass wl.tcenv. + *) +let ensure_no_uvar_subst env (t0:term) (wl:worklist) + : term & worklist + = (* Returns true iff the variable x is not affected by substitution s *) + let bv_not_affected_by (s:subst_ts) (x:bv) : bool = + let t_x = S.bv_to_name x in + let t_x' = SS.subst' s t_x in + match (SS.compress t_x').n with + | Tm_name y -> + S.bv_eq x y // Check if substituting returned the same variable + | _ -> false + in + let binding_not_affected_by (s:subst_ts) (b:binding) : bool = + match b with + | Binding_var x -> bv_not_affected_by s x + | _ -> true + in + let head, args = U.head_and_args t0 in + match (SS.compress head).n with + | Tm_uvar (uv, ([], _)) -> + (* No subst, nothing to do *) + t0, wl + + | Tm_uvar (uv, _) when List.isEmpty uv.ctx_uvar_binders -> + (* No binders in scope, also good *) + t0, wl + + | Tm_uvar (uv, s) -> + (* Obtain the maximum prefix of the binders that can remain as-is + * (gamma is a snoc list, so we want a suffix of it. *) + let gamma_aff, new_gamma = FStarC.Common.max_suffix (binding_not_affected_by s) + uv.ctx_uvar_gamma + in + begin match gamma_aff with + | [] -> + (* Not affected by the substitution at all, do nothing *) + t0, wl + | _ -> + (* At least one variable is affected, make a new uvar *) + let dom_binders = Env.binders_of_bindings gamma_aff in + let v, t_v, wl = new_uvar (uv.ctx_uvar_reason ^ "; force delayed") + wl + t0.pos + new_gamma + (Env.binders_of_bindings new_gamma) + (U.arrow dom_binders (S.mk_Total (U.ctx_uvar_typ uv))) + (U.ctx_uvar_should_check uv) + uv.ctx_uvar_meta + in + + (* Solve the old variable *) + let args_sol = List.map U.arg_of_non_null_binder dom_binders in + let sol = S.mk_Tm_app t_v args_sol t0.pos in + if !dbg_Rel + then BU.print2 "ensure_no_uvar_subst solving %s with %s\n" + (show uv) + (show sol); + set_uvar env uv (Some Already_checked) sol; + + (* Make a term for the new uvar, applied to the substitutions of + * the abstracted arguments, plus all the original arguments. *) + let args_sol_s = List.map (fun (a, i) -> SS.subst' s a, i) args_sol in + let t = S.mk_Tm_app t_v (args_sol_s @ args) t0.pos in + t, wl + end + | _ -> + failwith (BU.format3 "ensure_no_uvar_subst: expected a uvar at the head (%s-%s-%s)" + (tag_of t0) + (tag_of head) + (tag_of (SS.compress head))) + +let no_free_uvars t = Setlike.is_empty (Free.uvars t) && Setlike.is_empty (Free.univs t) + +(* Deciding when it's okay to issue an SMT query for + * equating a term whose head symbol is `head` with another term + * + * NB: this function only uses env for checking delta_depths, + * so it's fine to use wl.tcenv. + *) +let rec may_relate_with_logical_guard env is_eq head = + match (SS.compress head).n with + | Tm_name _ + | Tm_match _ -> true + | Tm_fvar fv -> + (match Env.delta_depth_of_fv env fv with + | Delta_equational_at_level _ -> + true + | Delta_abstract _ -> + //these may be relatable via a logical theory + //which may provide **equations** among abstract symbols + //Note, this is specifically not applicable for subtyping queries: see issue #1359 + is_eq + | _ -> false) + | Tm_ascribed {tm=t} + | Tm_uinst (t, _) + | Tm_meta {tm=t} -> may_relate_with_logical_guard env is_eq t + | _ -> false + +let may_relate env prel head = may_relate_with_logical_guard env (EQ? prel) head + +(* Only call if ensure_no_uvar_subst was called on t before *) +let destruct_flex_t' t : flex_t = + let head, args = U.head_and_args t in + match (SS.compress head).n with + | Tm_uvar (uv, s) -> + Flex (t, uv, args) + | _ -> failwith "Not a flex-uvar" + +(* Destruct a term into its uvar head and arguments. The wl is only +used to track implicits. *) +let destruct_flex_t (t:term) wl : flex_t & worklist = + (* ensure_no_uvar_subst only uses the environment for debugging + * flags, so it's safe to pass wl.tcenv *) + let t, wl = ensure_no_uvar_subst wl.tcenv t wl in + (* If there's any substitution on the head of t, it must + * have been made trivial by the call above, so + * calling destruct_flex_t' is fine. *) + destruct_flex_t' t, wl + +(* ------------------------------------------------ *) +(* *) +(* ------------------------------------------------ *) + +let u_abs (k : typ) (ys : binders) (t : term) : term = + let (ys, t), (xs, c) = match (SS.compress k).n with + | Tm_arrow {bs; comp=c} -> + if List.length bs = List.length ys + then (ys, t), SS.open_comp bs c + else let ys', t, _ = U.abs_formals t in + (ys@ys', t), U.arrow_formals_comp k + | _ -> (ys, t), ([], S.mk_Total k) in + if List.length xs <> List.length ys + (* TODO : not putting any cflags here on the annotation... *) + then //The annotation is imprecise, due to a discrepancy in currying/eta-expansions etc.; + //causing a loss in precision for the SMT encoding + U.abs ys t (Some (U.mk_residual_comp PC.effect_Tot_lid None [])) + else let c = Subst.subst_comp (U.rename_binders xs ys) c in + U.abs ys t (Some (U.residual_comp_of_comp c)) + +let solve_prob' resolve_ok prob logical_guard uvis wl = + def_check_prob "solve_prob'" prob; + let phi = match logical_guard with + | None -> U.t_true + | Some phi -> phi in + let assign_solution xs uv phi = + if !dbg_Rel + then BU.print3 "Solving %s (%s) with formula %s\n" + (string_of_int (p_pid prob)) + (show uv) + (show phi); + let phi = U.abs xs phi (Some (U.residual_tot U.ktype0)) in + def_check_scoped (p_loc prob) ("solve_prob'.sol." ^ string_of_int (p_pid prob)) + (List.map (fun b -> b.binder_bv) <| p_scope prob) phi; + set_uvar wl.tcenv uv None phi + in + let uv = p_guard_uvar prob in + let fail () = + failwith (BU.format2 "Impossible: this instance %s has already been assigned a solution\n%s\n" + (show uv) + (show (p_guard prob))) + in + let args_as_binders args = + args |> + List.collect (fun (a, i) -> + match (SS.compress a).n with + | Tm_name x -> + let q, attrs = U.bqual_and_attrs_of_aqual i in + let pq, attrs = U.parse_positivity_attributes attrs in + [S.mk_binder_with_attrs x q pq attrs] + | _ -> + fail(); + []) + in + let wl = + let g = whnf (p_guard_env wl prob) (p_guard prob) in + if not (is_flex g) + then if resolve_ok + then wl + else (fail(); wl) + else let (Flex (_, uv, args), wl) = destruct_flex_t g wl in + assign_solution (args_as_binders args) uv phi; + wl + in + commit wl.tcenv uvis; + {wl with ctr=wl.ctr + 1} + +let extend_universe_solution pid sol wl = + if !dbg_Rel + then BU.print2 "Solving %s: with [%s]\n" (string_of_int pid) + (uvis_to_string wl.tcenv sol); + commit wl.tcenv sol; + {wl with ctr=wl.ctr+1} + +let solve_prob (prob : prob) (logical_guard : option term) (uvis : list uvi) (wl:worklist) : worklist = + def_check_prob "solve_prob.prob" prob; + BU.iter_opt logical_guard (def_check_term_scoped_in_prob "solve_prob.guard" prob); + if !dbg_Rel + then BU.print2 "Solving %s: with %s\n" (string_of_int <| p_pid prob) + (uvis_to_string wl.tcenv uvis); + solve_prob' false prob logical_guard uvis wl + +(* ------------------------------------------------ *) +(* *) +(* ------------------------------------------------ *) + + +(* ------------------------------------------------ *) +(* common ops on variables *) +(* ------------------------------------------------ *) + +let rec maximal_prefix (bs:binders) (bs':binders) : binders & (binders & binders) = + match bs, bs' with + | binder1::bs_tail, + ({binder_bv=b';binder_qual=i'})::bs'_tail -> + if S.bv_eq binder1.binder_bv b' + then let pfx, rest = maximal_prefix bs_tail bs'_tail in + binder1::pfx, rest + else [], (bs, bs') + | _ -> [], (bs, bs') + +let extend_gamma (g:gamma) (bs:binders) = + List.fold_left (fun g ({binder_bv=x}) -> Binding_var x::g) g bs + +let gamma_until (g:gamma) (bs:binders) = + match List.last_opt bs with + | None -> [] + | Some ({binder_bv=x}) -> + match BU.prefix_until (function Binding_var x' -> S.bv_eq x x' | _ -> false) g with + | None -> [] + | Some (_, bx, rest) -> bx::rest + +(* + * AR: 07/20: generalizing restrict + * + * Given G_s |- ?u_s bs : t_s and G_t |- ?u_t : t_t, this code restricts G_t to the + * maximal prefix of G_s and G_t, creating a new uvar maximal_prefix(G_s, G_t) |- ?u : t_t, + * and assigning ?u_t = ?u + * + * NS: 03/2022 Question: How do we know that t_t is well-formed in maximal_prefix(G_s, G_t)? + * + * However simply doing this does not allow the solution of ?u to mention the binders bs + * + * Instead, we filter bs that also appear in G_t but not in the maximal prefix and + * allow the solution of G_t to contain them + * + * (The solution of ?u_t is already allowed to contain the ones appearing in the maximal prefix) + * + * So the new uvar that's created is maximal_prefix(G_s, G_t) |- ?u : bs -> t_t + * and assigning ?u_t = ?u bs + * + * This comes in handy for the flex-rigid case, where the arguments of the flex are a pattern + *) +let restrict_ctx env (tgt:ctx_uvar) (bs:binders) (src:ctx_uvar) wl : worklist = + let pfx, _ = maximal_prefix tgt.ctx_uvar_binders src.ctx_uvar_binders in + let g = gamma_until src.ctx_uvar_gamma pfx in + + //t is the type at which new uvar ?u should be created + //f is a function that applied to the new uvar term should return the term that ?u_t should be solved to + let aux (t:typ) (f:term -> term) = + let _, src', wl = new_uvar ("restricted " ^ (show src.ctx_uvar_head)) wl + src.ctx_uvar_range g pfx t + (U.ctx_uvar_should_check src) + src.ctx_uvar_meta in + set_uvar env src (Some Already_checked) (f src'); + wl in + + let bs = bs |> List.filter (fun ({binder_bv=bv1}) -> + src.ctx_uvar_binders |> List.existsb (fun ({binder_bv=bv2}) -> S.bv_eq bv1 bv2) && //binder exists in G_t + not (pfx |> List.existsb (fun ({binder_bv=bv2}) -> S.bv_eq bv1 bv2))) in //but not in the maximal prefix + + if List.length bs = 0 then aux (U.ctx_uvar_typ src) (fun src' -> src') //no abstraction over bs + else begin + aux + (let t = U.ctx_uvar_typ src in t |> S.mk_Total |> U.arrow bs) //bs -> Tot t_t + (fun src' -> S.mk_Tm_app //?u bs + src' + (bs |> S.binders_to_names |> List.map S.as_arg) + src.ctx_uvar_range) + end + +let restrict_all_uvars env (tgt:ctx_uvar) (bs:binders) (sources:list ctx_uvar) wl : worklist = + match bs with + | [] -> + let ctx_tgt = binders_as_bv_set tgt.ctx_uvar_binders in + List.fold_right + (fun (src:ctx_uvar) wl -> + let ctx_src = binders_as_bv_set src.ctx_uvar_binders in + if subset ctx_src ctx_tgt + then wl // no need to restrict source, it's context is included in the context of the tgt + else restrict_ctx env tgt [] src wl) + sources + wl + + | _ -> + List.fold_right (restrict_ctx env tgt bs) sources wl + +let intersect_binders (g:gamma) (v1:binders) (v2:binders) : binders = + let as_set (v:binders) : RBSet.t bv = + v |> List.fold_left (fun out x -> add x.binder_bv out) (Setlike.empty ()) + in + let v1_set = as_set v1 in + let ctx_binders = + List.fold_left (fun out b -> match b with Binding_var x -> add x out | _ -> out) + (Setlike.empty ()) + g + in + let isect, _ = + v2 |> List.fold_left (fun (isect, isect_set) b -> + let x, imp = b.binder_bv, b.binder_qual in + if not <| mem x v1_set + then //definitely not in the intersection + isect, isect_set + else //maybe in the intersect, if its type is only dependent on prior elements in the telescope + let fvs = Free.names x.sort in + if subset fvs isect_set + then b::isect, add x isect_set + else isect, isect_set) + ([], ctx_binders) in + List.rev isect + +let binders_eq v1 v2 = + List.length v1 = List.length v2 + && List.forall2 (fun ({binder_bv=a}) ({binder_bv=b}) -> S.bv_eq a b) v1 v2 + +let name_exists_in_binders x bs = + BU.for_some (fun ({binder_bv=y}) -> S.bv_eq x y) bs + +let pat_vars env ctx args : option binders = + let rec aux seen args = + match args with + | [] -> Some (List.rev seen) + | (arg, i)::args -> + let hd = sn env arg in + match hd.n with + | Tm_name a -> + if name_exists_in_binders a seen + || name_exists_in_binders a ctx + then None + else let bq, attrs = U.bqual_and_attrs_of_aqual i in + let pq, attrs = U.parse_positivity_attributes attrs in + aux ((S.mk_binder_with_attrs a bq pq attrs)::seen) args + | _ -> None + in + aux [] args + +(* ------------------------------------------------ *) +(* *) +(* ------------------------------------------------ *) + +let string_of_match_result = function + | MisMatch (d1, d2) -> "MisMatch " ^ show (d1, d2) + | HeadMatch u -> "HeadMatch " ^ string_of_bool u + | FullMatch -> "FullMatch" + +instance showable_match_result = { show = string_of_match_result; } + +let head_match = function + | MisMatch(i, j) -> MisMatch(i, j) + | HeadMatch true -> HeadMatch true + | _ -> HeadMatch false + +let universe_has_max env u = + let u = N.normalize_universe env u in + match u with + | U_max _ -> true + | _ -> false + +let rec head_matches env t1 t2 : match_result = + let t1 = U.unmeta t1 in + let t2 = U.unmeta t2 in + if !dbg_RelDelta then ( + BU.print2 "head_matches %s %s\n" (show t1) (show t2); + BU.print2 " %s -- %s\n" (tag_of t1) (tag_of t2); + () + ); + match t1.n, t2.n with + | Tm_lazy ({lkind=Lazy_embedding _}), _ -> head_matches env (U.unlazy t1) t2 + | _, Tm_lazy({lkind=Lazy_embedding _}) -> head_matches env t1 (U.unlazy t2) + | Tm_lazy li1, Tm_lazy li2 -> + if li1.lkind =? li2.lkind + then HeadMatch false + else MisMatch(None, None) + + | Tm_name x, Tm_name y -> if S.bv_eq x y then FullMatch else MisMatch(None, None) + | Tm_fvar f, Tm_fvar g -> if S.fv_eq f g then FullMatch else MisMatch(Some (fv_delta_depth env f), Some (fv_delta_depth env g)) + | Tm_uinst (f, _), Tm_uinst(g, _) -> head_matches env f g |> head_match + | Tm_constant (FC.Const_reify _), Tm_constant (FC.Const_reify _) -> FullMatch + | Tm_constant (FC.Const_reify _), _ + | _, Tm_constant (FC.Const_reify _) -> HeadMatch true + | Tm_constant c, Tm_constant d -> if FC.eq_const c d then FullMatch else MisMatch(None, None) + + | Tm_uvar (uv, _), Tm_uvar (uv', _) -> if UF.equiv uv.ctx_uvar_head uv'.ctx_uvar_head then FullMatch else MisMatch(None, None) + + | Tm_refine {b=x}, Tm_refine {b=y} -> head_matches env x.sort y.sort |> head_match + + | Tm_refine {b=x}, _ -> head_matches env x.sort t2 |> head_match + | _, Tm_refine {b=x} -> head_matches env t1 x.sort |> head_match + + | Tm_type _, Tm_type _ + | Tm_arrow _, Tm_arrow _ -> HeadMatch false + + | Tm_app {hd=head}, Tm_app {hd=head'} -> head_matches env head head' |> head_match + | Tm_app {hd=head}, _ -> head_matches env head t2 |> head_match + | _, Tm_app {hd=head} -> head_matches env t1 head |> head_match + + | Tm_let _, Tm_let _ + | Tm_match _, Tm_match _ + | Tm_quoted _, Tm_quoted _ + | Tm_abs _, Tm_abs _ -> HeadMatch true + + | _ -> + (* GM: I am retaining this logic here. I think it is meant to disable + unfolding of possibly-equational terms. This probably deserves a rework now + with the .logical field. *) + let maybe_dd (t:term) : option delta_depth = + match (SS.compress t).n with + | Tm_unknown + | Tm_bvar _ + | Tm_name _ + | Tm_uvar _ + | Tm_let _ + | Tm_match _ -> None + | _ -> Some (delta_depth_of_term env t) + in + MisMatch (maybe_dd t1, maybe_dd t2) + +(* Does t1 head-match t2, after some delta steps? *) +let head_matches_delta env (logical:bool) smt_ok t1 t2 : (match_result & option (typ&typ)) = + let base_steps = + (if logical then [Env.DontUnfoldAttr [PC.tac_opaque_attr]] else []) @ + [Env.Primops; Env.Weak; Env.HNF] + in + let maybe_inline t = + let head = U.head_of (unrefine env t) in + if !dbg_RelDelta then + BU.print2 "Head of %s is %s\n" (show t) (show head); + match (U.un_uinst head).n with + | Tm_fvar fv -> + begin + match Env.lookup_definition + [Env.Unfold delta_constant; + Env.Eager_unfolding_only] + env + fv.fv_name.v + with + | None -> + if !dbg_RelDelta then + BU.print1 "No definition found for %s\n" (show head); + None + | Some _ -> + let basic_steps = + (if logical then [Env.DontUnfoldAttr [PC.tac_opaque_attr]] else []) @ + [Env.UnfoldUntil delta_constant; + Env.Weak; + Env.HNF; + Env.Primops; + Env.Beta; + Env.Eager_unfolding; + Env.Iota] + in + let steps = + if smt_ok then basic_steps + else Env.Exclude Env.Zeta::basic_steps + //NS: added this to prevent unifier looping + //see bug606.fst + //should we always disable Zeta here? + in + let t' = norm_with_steps "FStarC.TypeChecker.Rel.norm_with_steps.1" steps env t in + if TEQ.eq_tm env t t' = TEQ.Equal //if we didn't inline anything + then None + else let _ = if !dbg_RelDelta + then BU.print2 "Inlined %s to %s\n" + (show t) + (show t') in + Some t' + end + | _ -> None + in + let success d r t1 t2 = (r, (if d>0 then Some(t1, t2) else None)) in + let fail d r t1 t2 = (r, (if d>0 then Some(t1, t2) else None)) in + + (* + * AR: When we delta-unfold the terms below, it may happen that application of an fv with + * delta depth say 1 doesn't unfold because it is marked with strict_on_arguments + * To prevent looping in that case, we make sure that we have made progress + * in an unfolding call to the normalizer + * This made_progress function is checking that we have made progress in unfolding t to t' + * See #2184 + * + * GM: Updated 2024/05/18 to check for a discrepancy in syntactic equality, instead of + * eq_tm *not* returning Equal. We can have syntactically equal terms for which eq_tm + * returns unknown, so this code would falsely claim progress. For instance, Tm_let + * nodes are not handled by eq_tm and it always returns unknown. That should probably + * be improved, but in either case I think we want a syntactic check here (which is + * faster too) than eq_tm which is meant for decidable equality. + *) + let made_progress t t' = + let head = U.head_and_args t |> fst in + let head' = U.head_and_args t' |> fst in + not (U.term_eq head head') + in + + let rec aux retry n_delta t1 t2 = + let r = head_matches env t1 t2 in + if !dbg_RelDelta then + BU.print3 "head_matches (%s, %s) = %s\n" + (show t1) + (show t2) + (string_of_match_result r); + let reduce_one_and_try_again (d1:delta_depth) (d2:delta_depth) = + let d1_greater_than_d2 = Common.delta_depth_greater_than d1 d2 in + let t1, t2, made_progress = + if d1_greater_than_d2 + then let t1' = normalize_refinement (Env.UnfoldUntil d2 :: base_steps) env t1 in + t1', t2, made_progress t1 t1' + else let t2' = normalize_refinement (Env.UnfoldUntil d1 :: base_steps) env t2 in + t1, t2', made_progress t2 t2' in + if made_progress + then aux retry (n_delta + 1) t1 t2 + else fail n_delta r t1 t2 + in + + let reduce_both_and_try_again (d:delta_depth) (r:match_result) = + match Common.decr_delta_depth d with + | None -> fail n_delta r t1 t2 + | Some d -> + let t1' = normalize_refinement (Env.UnfoldUntil d :: base_steps) env t1 in + let t2' = normalize_refinement (Env.UnfoldUntil d :: base_steps) env t2 in + if made_progress t1 t1' && + made_progress t2 t2' + then aux retry (n_delta + 1) t1' t2' + else fail n_delta r t1 t2 + in + + match r with + | MisMatch (Some (Delta_equational_at_level i), Some (Delta_equational_at_level j)) when (i > 0 || j > 0) && i <> j -> + reduce_one_and_try_again (Delta_equational_at_level i) (Delta_equational_at_level j) + + | MisMatch(Some (Delta_equational_at_level _), _) + | MisMatch(_, Some (Delta_equational_at_level _)) -> + if not retry then fail n_delta r t1 t2 + else begin match maybe_inline t1, maybe_inline t2 with + | None, None -> fail n_delta r t1 t2 + | Some t1, None -> aux false (n_delta + 1) t1 t2 + | None, Some t2 -> aux false (n_delta + 1) t1 t2 + | Some t1, Some t2 -> aux false (n_delta + 1) t1 t2 + end + + | MisMatch(Some d1, Some d2) when (d1=d2) -> //incompatible + reduce_both_and_try_again d1 r + + | MisMatch(Some d1, Some d2) -> //these may be related after some delta steps + reduce_one_and_try_again d1 d2 + + | MisMatch _ -> + fail n_delta r t1 t2 + + | _ -> + success n_delta r t1 t2 in + let r = aux true 0 t1 t2 in + if !dbg_RelDelta then + BU.print3 "head_matches_delta (%s, %s) = %s\n" + (show t1) (show t2) (show r); + r + +let kind_type (binders:binders) (r:Range.range) = + U.type_u() |> fst + + +(* ----------------------------------------------------- *) +(* Ranking problems for the order in which to solve them *) +(* ----------------------------------------------------- *) +let rank_t_num = function + | Rigid_rigid -> 0 + | Flex_rigid_eq -> 1 + | Flex_flex_pattern_eq -> 2 + | Flex_rigid -> 3 + | Rigid_flex -> 4 + | Flex_flex -> 5 +let rank_leq r1 r2 = rank_t_num r1 <= rank_t_num r2 +let rank_less_than r1 r2 = + r1 <> r2 && + rank_t_num r1 <= rank_t_num r2 +let compress_tprob wl p = + let env = p_env wl (TProb p) in + {p with lhs=whnf env p.lhs; rhs=whnf env p.rhs} + +let compress_cprob wl p = + let whnf_c env c = + match c.n with + | Total ty -> S.mk_Total (whnf env ty) + | _ -> c + in + let env = p_env wl (CProb p) in + {p with lhs = whnf_c env p.lhs; rhs = whnf_c env p.rhs} + +let compress_prob wl p = + match p with + | TProb p -> compress_tprob wl p |> TProb + | CProb p -> compress_cprob wl p |> CProb + +let rank wl pr : rank_t //the rank + & prob //the input problem, pre-processed a bit (the wl is needed for the pre-processing) + = + let prob = compress_prob wl pr |> maybe_invert_p in + match prob with + | TProb tp -> + let lh, lhs_args = U.head_and_args tp.lhs in + let rh, rhs_args = U.head_and_args tp.rhs in + let rank, tp = + match lh.n, rh.n with + | Tm_uvar _, Tm_uvar _ -> + begin + match lhs_args, rhs_args with + | [], [] when tp.relation=EQ -> + Flex_flex_pattern_eq, tp + | _ -> Flex_flex, tp + end + + | Tm_uvar _, _ + | _, Tm_uvar _ when tp.relation=EQ -> + Flex_rigid_eq, tp + + | Tm_uvar _, Tm_arrow _ + | Tm_uvar _, Tm_type _ + | Tm_type _, Tm_uvar _ -> + //this case is so common, that even though we could delay, it is almost always ok to solve it immediately as an equality + //besides, in the case of arrows, if we delay it, the arity of various terms built by the unifier goes awry + //so, don't delay! + Flex_rigid_eq, {tp with relation=EQ} + + | _, Tm_uvar _ -> + Rigid_flex, tp + + | Tm_uvar _, _ -> + Flex_rigid, tp + + | _, Tm_uvar _ -> + Rigid_flex, tp + + | _, _ -> + Rigid_rigid, tp + in + rank, {tp with rank=Some rank} |> TProb + + | CProb cp -> + Rigid_rigid, {cp with rank=Some Rigid_rigid} |> CProb + +let next_prob wl : option (prob & list prob & rank_t) = + //a problem with the lowest rank, or a problem whose rank <= flex_rigid_eq, if any + //all the other problems in wl + //the rank of the first problem, or the minimum rank in the wl + let rec aux (min_rank, min, out) probs = + match probs with + | [] -> + begin + match min, min_rank with + | Some p, Some r -> Some (p, out, r) + | _ -> None + end + | hd::tl -> + let rank, hd = rank wl hd in + if rank_leq rank Flex_rigid_eq + then match min with + | None -> Some (hd, out@tl, rank) + | Some m -> Some (hd, out@m::tl, rank) + else if min_rank = None + || rank_less_than rank (Option.get min_rank) + then match min with + | None -> aux (Some rank, Some hd, out) tl + | Some m -> aux (Some rank, Some hd, m::out) tl + else aux (min_rank, min, hd::out) tl + in + aux (None, None, []) wl.attempting + +let flex_prob_closing tcenv (bs:binders) (p:prob) = + let flex_will_be_closed t = + let hd, _ = U.head_and_args t in + match (SS.compress hd).n with + | Tm_uvar(u, _) -> + u.ctx_uvar_binders |> BU.for_some (fun ({binder_bv=y}) -> + bs |> BU.for_some (fun ({binder_bv=x}) -> S.bv_eq x y)) + | _ -> false + in + let wl = empty_worklist tcenv in + let r, p = rank wl p in + match p with + | CProb _ -> + true + | TProb p -> + match r with + | Rigid_rigid + | Flex_rigid_eq + | Flex_flex_pattern_eq -> + true + | Flex_rigid -> + flex_will_be_closed p.lhs + | Rigid_flex -> + flex_will_be_closed p.rhs + | Flex_flex -> + p.relation=EQ + && + (flex_will_be_closed p.lhs + || flex_will_be_closed p.rhs) + +(* ----------------------------------------------------- *) +(* Solving universe equalities *) +(* ----------------------------------------------------- *) +type univ_eq_sol = + | UDeferred of worklist + | USolved of worklist + | UFailed of lstring + +let ufailed_simple (s:string) : univ_eq_sol = + UFailed (Thunk.mkv s) + +let ufailed_thunk (s: unit -> string) : univ_eq_sol = + UFailed (mklstr s) + + +let rec really_solve_universe_eq pid_orig wl u1 u2 = + let u1 = N.normalize_universe wl.tcenv u1 in + let u2 = N.normalize_universe wl.tcenv u2 in + let rec occurs_univ v1 u = match u with + | U_max us -> + us |> BU.for_some (fun u -> + let k, _ = U.univ_kernel u in + match k with + | U_unif v2 -> UF.univ_equiv v1 v2 + | _ -> false) + | _ -> occurs_univ v1 (U_max [u]) in + + let rec filter_out_common_univs (u1:list universe) (u2:list universe) :(list universe & list universe) = + let common_elts = u1 |> List.fold_left (fun uvs uv1 -> if u2 |> List.existsML (fun uv2 -> U.eq_univs uv1 uv2) then uv1::uvs else uvs) [] in + let filter = List.filter (fun u -> not (common_elts |> List.existsML (fun u' -> U.eq_univs u u'))) in + filter u1, filter u2 + in + + let try_umax_components u1 u2 msg = + if not wl.umax_heuristic_ok + then ufailed_simple "Unable to unify universe terms with umax" + else + match u1, u2 with + | U_max us1, U_max us2 -> + begin + //filter out common universes in us1 and us2 + //this allows more cases to unify, e.g. us1 = [uvar; un] and us2=[un; un'] + //with just structural comparison, this would fail to unify, but after filtering away un, we can unify uvar with un' + let us1, us2 = filter_out_common_univs us1 us2 in + if List.length us1 = List.length us2 //go for a structural match + then let rec aux wl us1 us2 = match us1, us2 with + | u1::us1, u2::us2 -> + begin match really_solve_universe_eq pid_orig wl u1 u2 with + | USolved wl -> + aux wl us1 us2 + | failed -> failed + end + | _ -> USolved wl in + aux wl us1 us2 + else ufailed_thunk + (fun () -> BU.format2 "Unable to unify universes: %s and %s" + (show u1) + (show u2)) + end + | U_max us, u' + | u', U_max us -> + let rec aux wl us = match us with + | [] -> USolved wl + | u::us -> + begin match really_solve_universe_eq pid_orig wl u u' with + | USolved wl -> + aux wl us + | failed -> failed + end + in aux wl us + + | _ -> + ufailed_thunk (fun () -> + BU.format3 "Unable to unify universes: %s and %s (%s)" + (show u1) + (show u2) msg) in + + match u1, u2 with + | U_bvar _, _ + | U_unknown, _ + | _, U_bvar _ + | _, U_unknown -> failwith (BU.format2 "Impossible: found an de Bruijn universe variable or unknown universe: %s, %s" + (show u1) + (show u2)) + + | U_name x, U_name y -> + if (string_of_id x) = (string_of_id y) + then USolved wl + else ufailed_simple "Incompatible universes" + + | U_zero, U_zero -> + USolved wl + + | U_succ u1, U_succ u2 -> + really_solve_universe_eq pid_orig wl u1 u2 + + | U_unif v1, U_unif v2 -> + if UF.univ_equiv v1 v2 + then USolved wl + else let wl = extend_universe_solution pid_orig [UNIV(v1, u2)] wl in + USolved wl + + | U_unif v1, u + | u, U_unif v1 -> + let u = norm_univ wl u in + if occurs_univ v1 u + then try_umax_components u1 u2 + (BU.format2 "Failed occurs check: %s occurs in %s" (show (U_unif v1)) (show u)) + else USolved (extend_universe_solution pid_orig [UNIV(v1, u)] wl) + + | U_max _, _ + | _, U_max _ -> + if wl.defer_ok = DeferAny + then UDeferred wl + else let u1 = norm_univ wl u1 in + let u2 = norm_univ wl u2 in + if U.eq_univs u1 u2 + then USolved wl + else try_umax_components u1 u2 "" + + | U_succ _, U_zero + | U_succ _, U_name _ + | U_zero, U_succ _ + | U_zero, U_name _ + | U_name _, U_succ _ + | U_name _, U_zero -> + ufailed_simple "Incompatible universes" + +let solve_universe_eq orig wl u1 u2 = + if wl.tcenv.lax_universes + then USolved wl + else really_solve_universe_eq orig wl u1 u2 + +(* This balances two lists. Given (xs, f) (ys, g), it will + * take a maximal same-length prefix from each list, getting + * (xs1, xs2) and (ys1, ys2) / where length xs1 == length xs2 (and ys1 = [] \/ ys2 = []) + * and then return + * (xs1, f xs2), (ys1, g ys2) + * + * We could find the minimum of their lengths, split, and apply, but this is faster. + *) +let match_num_binders (bc1: (list 'a & (list 'a -> 'b))) + (bc2: (list 'a & (list 'a -> 'b))) + : (list 'a & 'b) & (list 'a & 'b) = + let (bs1, mk_cod1) = bc1 in + let (bs2, mk_cod2) = bc2 in + let rec aux (bs1 : list 'a) (bs2 : list 'a) : (list 'a & 'b) & (list 'a & 'b) = + match bs1, bs2 with + | x::xs, y::ys -> + let ((xs, xr), (ys, yr)) = aux xs ys in + ((x::xs, xr), (y::ys, yr)) + | xs, ys -> // at least one empty + (([], mk_cod1 xs), ([], mk_cod2 ys)) + in + aux bs1 bs2 + +let guard_of_prob (wl:worklist) (problem:tprob) (t1 : term) (t2 : term) : term & worklist = + def_check_prob "guard_of_prob" (TProb problem); + let env = p_env wl (TProb problem) in + let has_type_guard t1 t2 = + match problem.element with + | Some t -> + U.mk_has_type t1 (S.bv_to_name t) t2 + | None -> + let x = S.new_bv None t1 in + def_check_scoped t1.pos "guard_of_prob.universe_of" env t1; + let u_x = env.universe_of env t1 in + U.mk_forall u_x x (U.mk_has_type t1 (S.bv_to_name x) t2) + in + match problem.relation with + | EQ -> mk_eq2 wl (TProb problem) t1 t2 + | SUB -> has_type_guard t1 t2, wl + | SUBINV -> has_type_guard t2 t1, wl + +let is_flex_pat = function + | Flex (_, _, []) -> true + | _ -> false + +(** If the head uvar of the flex term is tagged with a `Ctx_uvar_meta_attr a` + and if a term tagged with attribute `a` is in scope, + then this problem should be deferred to a tactic *) +let should_defer_flex_to_user_tac (wl:worklist) (f:flex_t) = + let (Flex (_, u, _)) = f in + let b = DeferredImplicits.should_defer_uvar_to_user_tac wl.tcenv u in + + if !dbg_ResolveImplicitsHook then + BU.print3 "Rel.should_defer_flex_to_user_tac for %s returning %s (env.enable_defer_to_tac: %s)\n" + (show u) (show b) (show wl.tcenv.enable_defer_to_tac); + + b + +(* : + Given a term (?u_(bs;t) e1..en) + returns None in case the arity of the type t is less than n + otherwise returns Some (x1 ... xn) + where if ei is a variable distinct from bs and all the ej + then xi = ei + else xi is a fresh variable + *) +let quasi_pattern env (f:flex_t) : option (binders & typ) = + let (Flex (_, ctx_uvar, args)) = f in + let t_hd = U.ctx_uvar_typ ctx_uvar in + let ctx = ctx_uvar.ctx_uvar_binders in + let name_exists_in x bs = + BU.for_some (fun ({binder_bv=y}) -> S.bv_eq x y) bs + in + let rec aux pat_binders formals t_res args = + match formals, args with + | [], [] + | _, [] -> + Some (List.rev pat_binders, U.arrow formals (S.mk_Total t_res)) + + | fml::formals, (a, a_imp)::args -> + begin + let formal, formal_imp = fml.binder_bv, fml.binder_qual in + match (SS.compress a).n with + | Tm_name x -> + if name_exists_in x ctx + || name_exists_in x pat_binders + then //we already have x + //so don't include it in the quasi-pattern + aux (fml :: pat_binders) formals t_res args + else let x = {x with sort=formal.sort} in + let subst = [NT(formal, S.bv_to_name x)] in + let formals = SS.subst_binders subst formals in + let t_res = SS.subst subst t_res in + let q, _ = U.bqual_and_attrs_of_aqual a_imp in + aux ((S.mk_binder_with_attrs + ({x with sort=formal.sort}) + q + fml.binder_positivity + fml.binder_attrs) :: pat_binders) formals t_res args + | _ -> //it's not a name, so it can't be included in the patterns + aux (fml :: pat_binders) formals t_res args + end + + | [], args -> + let more_formals, t_res = U.arrow_formals (N.unfold_whnf env t_res) in + begin + match more_formals with + | [] -> None //seems ill-typed at this point + | _ -> aux pat_binders more_formals t_res args + end + in + match args with + | [] -> Some ([], t_hd) //this really a pattern, not a quasi_pattern + | _ -> + let formals, t_res = U.arrow_formals t_hd in + aux [] formals t_res args + +let run_meta_arg_tac (env:env_t) (ctx_u:ctx_uvar) : term = + match ctx_u.ctx_uvar_meta with + | Some (Ctx_uvar_meta_tac tau) -> + let env = { env with gamma = ctx_u.ctx_uvar_gamma } in + if !dbg_Tac then + BU.print1 "Running tactic for meta-arg %s\n" (show ctx_u); + Errors.with_ctx "Running tactic for meta-arg" + (fun () -> env.synth_hook env (U.ctx_uvar_typ ctx_u) tau) + | _ -> + failwith "run_meta_arg_tac must have been called with a uvar that has a meta tac" + +let simplify_vc full_norm_allowed env t = + if !dbg_Simplification then + BU.print1 "Simplifying guard %s\n" (show t); + let steps = [Env.Beta; + Env.Eager_unfolding; + Env.Simplify; + Env.Primops; + Env.Exclude Env.Zeta] in + let steps = if full_norm_allowed then steps else Env.NoFullNorm::steps in + let t' = norm_with_steps "FStarC.TypeChecker.Rel.simplify_vc" steps env t in + if !dbg_Simplification then + BU.print1 "Simplified guard to %s\n" (show t'); + t' + +let __simplify_guard full_norm_allowed env g = match g.guard_f with + | Trivial -> g + | NonTrivial f -> + let f = simplify_vc full_norm_allowed env f in + let f = check_trivial f in + { g with guard_f = f} + +let simplify_guard env g = match g.guard_f with + | Trivial -> g + | NonTrivial f -> + let f = simplify_vc false env f in + let f = check_trivial f in + { g with guard_f = f} + +let simplify_guard_full_norm env g = match g.guard_f with + | Trivial -> g + | NonTrivial f -> + let f = simplify_vc true env f in + let f = check_trivial f in + { g with guard_f = f} + +// +// Apply substitutive indexed effects subcomp for an effect M +// +// bs: (opened) binders in the subcomp type +// subcomp_c: the computation type in the subcomp type (opened with bs) +// ct1 ct2: the two input computation types, both in M +// sub_prob: a function to create and add subproblems to the worklist +// num_effect_params: number of effect parameters in M +// wl: worklist +// subcomp_name and r1: for debugging purposes +// +// returns the (subcomp guard, new sub problems, worklist) +// +let apply_substitutive_indexed_subcomp (env:Env.env) + (k:S.indexed_effect_combinator_kind) + (bs:binders) + (subcomp_c:comp) + (ct1:comp_typ) (ct2:comp_typ) + (sub_prob:worklist -> term -> rel -> term -> string -> prob & worklist) + (num_effect_params:int) + (wl:worklist) + (subcomp_name:string) + (r1:Range.range) + + : typ & list prob & worklist = + + // + // We will collect the substitutions in subst, + // bs will be the remaining binders (that are not in subst yet) + // + + // first the a:Type binder + let bs, subst = + let a_b::bs = bs in + bs, + [NT (a_b.binder_bv, ct2.result_typ)] in + + // + // If the effect has effect parameters: + // - peel those arguments off of ct1 and ct2, + // - add subproblems for their equality to the worklist + // - add substitutions for corresponding binders + // + let bs, subst, args1, args2, eff_params_sub_probs, wl = + if num_effect_params = 0 + then bs, subst, ct1.effect_args, ct2.effect_args, [], wl + else let split (l:list 'a) = List.splitAt num_effect_params l in + let eff_params_bs, bs = split bs in + let param_args1, args1 = split ct1.effect_args in + let param_args2, args2 = split ct2.effect_args in + + let probs, wl = List.fold_left2 (fun (ps, wl) (t1, _) (t2, _) -> + let p, wl = sub_prob wl t1 EQ t2 "effect params subcomp" in + ps@[p], wl) ([], wl) param_args1 param_args2 in + let param_subst = List.map2 (fun b (arg, _) -> + NT (b.binder_bv, arg)) eff_params_bs param_args1 in + bs, subst@param_subst, args1, args2, probs, wl in + + // add substitutions for the f computation + let bs, subst = + let f_bs, bs = List.splitAt (List.length args1) bs in + let f_substs = List.map2 (fun f_b (arg, _) -> NT (f_b.binder_bv, arg)) f_bs args1 in + bs, + subst@f_substs in + + // add substitutions for the g computation + let bs, subst, f_g_args_eq_sub_probs, wl = + if Substitutive_combinator? k + then begin + let g_bs, bs = List.splitAt (List.length args2) bs in + let g_substs = List.map2 (fun g_b (arg, _) -> NT (g_b.binder_bv, arg)) g_bs args2 in + bs, + subst@g_substs, + [], + wl + end + else if Substitutive_invariant_combinator? k + then begin + let probs, wl = List.fold_left2 (fun (ps, wl) (t1, _) (t2, _) -> + let p, wl = sub_prob wl t1 EQ t2 "substitutive inv subcomp args" in + ps@[p], wl) ([], wl) args1 args2 in + bs, subst, probs, wl + end + else failwith "Impossible (rel.apply_substitutive_indexed_subcomp unexpected k" in + + // peel off the f:repr a is binder from bs + let bs = List.splitAt (List.length bs - 1) bs |> fst in + + // for the binders in bs, create uvars, and add their substitutions + let subst, wl = + List.fold_left (fun (ss, wl) b -> + let [uv_t], g = Env.uvars_for_binders env [b] ss + (fun b -> + if !dbg_LayeredEffectsApp + then BU.format3 "implicit var for additional binder %s in subcomp %s at %s" + (show b) + subcomp_name + (Range.string_of_range r1) + else "apply_substitutive_indexed_subcomp") r1 in + ss@[NT (b.binder_bv, uv_t)], + {wl with wl_implicits=g.implicits ++ wl.wl_implicits}) (subst, wl) bs in + + // apply the substitutions to subcomp_c, + // and get the precondition from the PURE wp + let subcomp_ct = subcomp_c |> SS.subst_comp subst |> Env.comp_to_comp_typ env in + + let fml = + let u, wp = List.hd subcomp_ct.comp_univs, fst (List.hd subcomp_ct.effect_args) in + Env.pure_precondition_for_trivial_post env u subcomp_ct.result_typ wp Range.dummyRange in + + fml, + eff_params_sub_probs@f_g_args_eq_sub_probs, + wl + +// +// Apply ad-hoc indexed effects subcomp for an effect M +// +// bs: (opened) binders in the subcomp type +// subcomp_c: the computation type in the subcomp type (opened with bs) +// ct1 ct2: the two input computation types, both in M +// sub_prob: a function to create and add subproblems to the worklist +// wl: worklist +// subcomp_name and r1: for debugging purposes +// +// returns the (subcomp guard, new sub problems, worklist) +// +let apply_ad_hoc_indexed_subcomp (env:Env.env) + (bs:binders) + (subcomp_c:comp) + (ct1:comp_typ) (ct2:comp_typ) + (sub_prob:worklist -> term -> rel -> term -> string -> prob & worklist) + (wl:worklist) + (subcomp_name:string) + (r1:Range.range) + + : typ & list prob & worklist = + + let stronger_t_shape_error s = BU.format2 + "Unexpected shape of stronger for %s, reason: %s" + (Ident.string_of_lid ct2.effect_name) s in + + let a_b, rest_bs, f_b = + if List.length bs >= 2 + then let a_b::bs = bs in + let rest_bs, f_b = + bs |> List.splitAt (List.length bs - 1) + |> (fun (l1, l2) -> l1, List.hd l2) in + a_b, rest_bs, f_b + else raise_error r1 Errors.Fatal_UnexpectedExpressionType (stronger_t_shape_error "not an arrow or not enough binders") in + + let rest_bs_uvars, g_uvars = + Env.uvars_for_binders env rest_bs + [NT (a_b.binder_bv, ct2.result_typ)] + (fun b -> + if !dbg_LayeredEffectsApp + then BU.format3 "implicit for binder %s in subcomp %s at %s" + (show b) + subcomp_name + (Range.string_of_range r1) + else "apply_ad_hoc_indexed_subcomp") r1 in + + let wl = { wl with wl_implicits = g_uvars.implicits ++ wl.wl_implicits } in + + let substs = + List.map2 (fun b t -> NT (b.binder_bv, t)) + (a_b::rest_bs) (ct2.result_typ::rest_bs_uvars) in + + let f_sub_probs, wl = + let f_sort_is = + U.effect_indices_from_repr + f_b.binder_bv.sort + (Env.is_layered_effect env ct1.effect_name) + r1 (stronger_t_shape_error "type of f is not a repr type") + |> List.map (SS.subst substs) in + + List.fold_left2 (fun (ps, wl) f_sort_i c1_i -> + if !dbg_LayeredEffectsApp + then BU.print3 "Layered Effects (%s) %s = %s\n" subcomp_name + (show f_sort_i) (show c1_i); + let p, wl = sub_prob wl f_sort_i EQ c1_i "indices of c1" in + ps@[p], wl + ) ([], wl) f_sort_is (ct1.effect_args |> List.map fst) in + + let subcomp_ct = subcomp_c |> SS.subst_comp substs |> Env.comp_to_comp_typ env in + + let g_sub_probs, wl = + let g_sort_is = + U.effect_indices_from_repr + subcomp_ct.result_typ + (Env.is_layered_effect env ct2.effect_name) + r1 (stronger_t_shape_error "subcomp return type is not a repr") in + + List.fold_left2 (fun (ps, wl) g_sort_i c2_i -> + if !dbg_LayeredEffectsApp + then BU.print3 "Layered Effects (%s) %s = %s\n" subcomp_name + (show g_sort_i) (show c2_i); + let p, wl = sub_prob wl g_sort_i EQ c2_i "indices of c2" in + ps@[p], wl + ) ([], wl) g_sort_is (ct2.effect_args |> List.map fst) in + + let fml = + let u, wp = List.hd subcomp_ct.comp_univs, fst (List.hd subcomp_ct.effect_args) in + Env.pure_precondition_for_trivial_post env u subcomp_ct.result_typ wp Range.dummyRange in + + fml, + f_sub_probs@g_sub_probs, + wl + +let has_typeclass_constraint (u:ctx_uvar) (wl:worklist) + : bool + = wl.typeclass_variables |> for_any (fun v -> UF.equiv v.ctx_uvar_head u.ctx_uvar_head) + +(* This function returns true for those lazykinds that +are "complete" in the sense that unfolding them does not +lose any information. For instance, embedded universes +are complete, since we embed them as applications of pack over a view, +and checking equality of such terms is equivalent to checking equality +of the views. Embedded proofstates are definitely not. + +This is probably not the place for this function though. *) +let lazy_complete_repr (k:lazy_kind) : bool = + match k with + | Lazy_bv + | Lazy_namedv + | Lazy_binder + | Lazy_letbinding + | Lazy_fvar + | Lazy_comp + | Lazy_sigelt + | Lazy_universe -> true + | _ -> false + +let has_free_uvars (t:term) : bool = + not (Setlike.is_empty (Free.uvars_uncached t)) + +let env_has_free_uvars (e:env_t) : bool = + List.existsb (fun b -> has_free_uvars b.binder_bv.sort) (Env.all_binders e) + +let gamma_has_free_uvars (g:list binding) : bool = + List.existsb (function Binding_var bv -> has_free_uvars bv.sort + | _ -> false) g + +type reveal_hide_t = + | Hide of (universe & typ & term) + | Reveal of (universe & typ & term) + +(******************************************************************************************************) +(* Main solving algorithm begins here *) +(******************************************************************************************************) +let rec solve (probs :worklist) : solution = +// printfn "Solving TODO:\n%s;;" (List.map prob_to_string probs.attempting |> String.concat "\n\t"); + if !dbg_Rel + then BU.print1 "solve:\n\t%s\n" (wl_to_string probs); + if !dbg_ImplicitTrace then + BU.print1 "solve: wl_implicits = %s\n" (show probs.wl_implicits); + + match next_prob probs with + | Some (hd, tl, rank) -> + let probs = {probs with attempting=tl} in + def_check_prob "solve,hd" hd; + begin match hd with + | CProb cp -> + solve_c (maybe_invert cp) probs + + | TProb tp -> + if BU.physical_equality tp.lhs tp.rhs then solve (solve_prob hd None [] probs) else + let is_expand_uvar (t:term) : bool = + match (SS.compress t).n with + | Tm_uvar (ctx_u, _) -> (UF.find_decoration ctx_u.ctx_uvar_head).uvar_decoration_should_unrefine + | _ -> false + in + let maybe_expand (tp:tprob) : tprob = + if Options.Ext.get "__unrefine" <> "" && tp.relation = SUB && is_expand_uvar tp.rhs + then + let lhs = tp.lhs in + let lhs_norm = N.unfold_whnf' [Env.DontUnfoldAttr [PC.do_not_unrefine_attr]] (p_env probs hd) lhs in + if Tm_refine? (SS.compress lhs_norm).n then + (* It is indeed a refinement, normalize again to remove them. *) + let lhs' = N.unfold_whnf' [Env.DontUnfoldAttr [PC.do_not_unrefine_attr]; Env.Unrefine] (p_env probs hd) lhs_norm in + if !dbg_Rel then + BU.print3 "GGG widening uvar %s! RHS %s ~> %s\n" + (show tp.rhs) (show lhs) (show lhs'); + { tp with lhs = lhs' } + else + tp + else tp + in + + let tp = maybe_expand tp in + + if rank=Rigid_rigid + || (tp.relation = EQ && rank <> Flex_flex) + then solve_t' tp probs + else if probs.defer_ok = DeferAny + then maybe_defer_to_user_tac tp "deferring flex_rigid or flex_flex subtyping" probs + else if rank=Flex_flex + then solve_t' ({tp with relation=EQ}) probs //turn flex_flex subtyping into flex_flex eq + else solve_rigid_flex_or_flex_rigid_subtyping rank tp probs + end + + | None -> + begin + match view probs.wl_deferred with + | VNil -> + Success (empty, as_deferred probs.wl_deferred_to_tac, probs.wl_implicits) //Yay ... done! + + | VCons _ _ -> + let attempt, rest = probs.wl_deferred |> CList.partition (fun (c, _, _, _) -> c < probs.ctr) in + match view attempt with + | VNil -> //can't solve yet; defer the rest + Success(as_deferred probs.wl_deferred, + as_deferred probs.wl_deferred_to_tac, + probs.wl_implicits) + + | _ -> + solve ({probs with attempting=attempt |> to_list |> List.map (fun (_, _, _, y) -> y); wl_deferred=rest}) + end + +and solve_one_universe_eq (orig:prob) (u1:universe) (u2:universe) (wl:worklist) : solution = + match solve_universe_eq (p_pid orig) wl u1 u2 with + | USolved wl -> + solve (solve_prob orig None [] wl) + + | UFailed msg -> + giveup wl msg orig + + | UDeferred wl -> + solve (defer_lit Deferred_univ_constraint "" orig wl) + +and solve_maybe_uinsts (orig:prob) (t1:term) (t2:term) (wl:worklist) : univ_eq_sol = + let rec aux wl us1 us2 = match us1, us2 with + | [], [] -> USolved wl + + | u1::us1, u2::us2 -> + begin match solve_universe_eq (p_pid orig) wl u1 u2 with + | USolved wl -> + aux wl us1 us2 + + | failed_or_deferred -> failed_or_deferred + end + + | _ -> ufailed_simple "Unequal number of universes" in + + let env = p_env wl orig in + def_check_scoped t1.pos "solve_maybe_uinsts.whnf1" env t1; + def_check_scoped t2.pos "solve_maybe_uinsts.whnf2" env t2; + let t1 = whnf env t1 in + let t2 = whnf env t2 in + match t1.n, t2.n with + | Tm_uinst({n=Tm_fvar f}, us1), Tm_uinst({n=Tm_fvar g}, us2) -> + let b = S.fv_eq f g in + assert b; + aux wl us1 us2 + + | Tm_uinst _, _ + | _, Tm_uinst _ -> + failwith "Impossible: expect head symbols to match" + + | _ -> + USolved wl + +and giveup_or_defer (orig:prob) (wl:worklist) (reason:deferred_reason) (msg:lstring) : solution = + if wl.defer_ok = DeferAny + then begin + if !dbg_Rel then + BU.print2 "\n\t\tDeferring %s\n\t\tBecause %s\n" (prob_to_string wl.tcenv orig) (Thunk.force msg); + solve (defer reason msg orig wl) + end + else giveup wl msg orig + +and giveup_or_defer_flex_flex (orig:prob) (wl:worklist) (reason:deferred_reason) (msg:lstring) : solution = + if wl.defer_ok <> NoDefer + then begin + if !dbg_Rel then + BU.print2 "\n\t\tDeferring %s\n\t\tBecause %s\n" (prob_to_string wl.tcenv orig) (Thunk.force msg); + solve (defer reason msg orig wl) + end + else giveup wl msg orig + +and defer_to_user_tac (orig:prob) reason (wl:worklist) : solution = + if !dbg_Rel then + BU.print1 "\n\t\tDeferring %s to a tactic\n" (prob_to_string wl.tcenv orig); + let wl = solve_prob orig None [] wl in + let wl = {wl with wl_deferred_to_tac=cons (wl.ctr, Deferred_to_user_tac, Thunk.mkv reason, orig) wl.wl_deferred_to_tac} in + solve wl + +and maybe_defer_to_user_tac prob reason wl : solution = + match prob.relation with + | EQ -> + let should_defer_tac t = + let head, _ = U.head_and_args t in + match (SS.compress head).n with + | Tm_uvar(uv, _) -> + DeferredImplicits.should_defer_uvar_to_user_tac wl.tcenv uv, uv.ctx_uvar_reason + | _ -> false, "" + in + let l1, r1 = should_defer_tac prob.lhs in + let l2, r2 = should_defer_tac prob.rhs in + if l1 || l2 + then defer_to_user_tac (TProb prob) (r1 ^ ", " ^ r2) wl + else solve (defer_lit Deferred_flex reason (TProb prob) wl) + | _ -> solve (defer_lit Deferred_flex reason (TProb prob) wl) + +(******************************************************************************************************) +(* The case where t1 < u, ..., tn < u: we solve this by taking u=t1\/...\/tn *) +(* The case where u < t1, .... u < tn: we solve this by taking u=t1/\.../\tn *) +(* *) +(* This will go through the worklist to find problems for the same uvar u and compute the composite *) +(* constraint as shown above. *) +(******************************************************************************************************) +and solve_rigid_flex_or_flex_rigid_subtyping + (rank:rank_t) + (tp:tprob) (wl:worklist) : solution = + def_check_prob "solve_rigid_flex_or_flex_rigid_subtyping" (TProb tp); + let flip = rank = Flex_rigid in + (* flip is true when the flex is on the left, after inverting (done by the caller), + which means we have a problem of the shape ?u <: t + + if flip is false, we are solving something of shape t <: ?u *) + (* + meet_or_join op [t1;..;tn] env wl: + Informally, this computes `t1 op t2 ... op tn` + where op is either \/ or /\ + + t1 op t2 is only defined when t1 and t2 + are refinements of the same base type + + if `op` is None, then we are computing the meet + and the result is widened to the base type + *) + let meet_or_join + (op : option (term -> term -> term)) + (ts : list term) + (wl:worklist) + : term & list prob & worklist + = let eq_prob t1 t2 wl = + let p, wl = + new_problem wl (p_env wl (TProb tp)) t1 EQ t2 None t1.pos + "join/meet refinements" + in + def_check_prob "meet_or_join" (TProb p); + TProb p, wl + in + let pairwise t1 t2 wl = + if !dbg_Rel + then BU.print2 "[meet/join]: pairwise: %s and %s\n" (show t1) (show t2); + let mr, ts = head_matches_delta (p_env wl (TProb tp)) tp.logical wl.smt_ok t1 t2 in + match mr with + | HeadMatch true + | MisMatch _ -> + let p, wl = eq_prob t1 t2 wl in + (t1, [p], wl) + + | FullMatch -> + begin + match ts with + | None -> + (t1, [], wl) + | Some (t1, t2) -> + (t1, [], wl) + end + + | HeadMatch false -> + let t1, t2 = + match ts with + | Some (t1, t2) -> SS.compress t1, SS.compress t2 + | None -> SS.compress t1, SS.compress t2 + in + let try_eq t1 t2 wl = + let t1_hd, t1_args = U.head_and_args t1 in + let t2_hd, t2_args = U.head_and_args t2 in + if List.length t1_args <> List.length t2_args then None else + let probs, wl = + List.fold_left2 (fun (probs, wl) (a1, _) (a2, _) -> + let p, wl = eq_prob a1 a2 wl in + p::probs, wl) + ([], wl) + //don't forget to prove t1_hd = t2_hd + //as they may have universe variables to equate + //as well + (as_arg t1_hd::t1_args) + (as_arg t2_hd::t2_args) + in + let wl' = {wl with defer_ok=NoDefer; + smt_ok=false; + attempting=probs; + wl_deferred=empty; + wl_implicits=empty} in + let tx = UF.new_transaction () in + match solve wl' with + | Success (_, defer_to_tac, imps) -> + UF.commit tx; + Some (extend_wl wl empty defer_to_tac imps) + + | Failed _ -> + UF.rollback tx; + None + in + let combine (t1 t2 : term) wl : term & list prob & worklist = + let env = p_env wl (TProb tp) in + let t1_base, p1_opt = base_and_refinement_maybe_delta false env t1 in + let t2_base, p2_opt = base_and_refinement_maybe_delta false env t2 in + (* + * AR: before applying op, we need to squash phi if required + * refinement formulas in F* may be in higher universe, + * meaning that if we apply op (l_and or l_or) directly, we may be + * unifying the universe of phi to zero, leading to errors + *) + let apply_op env op phi1 phi2 = + let squash phi = + match env.universe_of env phi with + | U_zero -> phi + | u -> U.mk_squash u phi in + op (squash phi1) (squash phi2) + in + let combine_refinements t_base p1_opt p2_opt = + match op with + | None -> t_base + | Some op -> + let refine x t = + if U.is_t_true t then x.sort + else U.refine x t + in + match p1_opt, p2_opt with + | Some (x, phi1), Some(y, phi2) -> + let x = freshen_bv x in + let subst = [DB(0, x)] in + let phi1 = SS.subst subst phi1 in + let phi2 = SS.subst subst phi2 in + let env_x = Env.push_bv env x in + refine x (apply_op env_x op phi1 phi2) + + | None, Some (x, phi) + | Some(x, phi), None -> + let x = freshen_bv x in + let subst = [DB(0, x)] in + let phi = SS.subst subst phi in + let env_x = Env.push_bv env x in + refine x (apply_op env_x op U.t_true phi) + + | _ -> + t_base + in + match try_eq t1_base t2_base wl with + | Some wl -> + combine_refinements t1_base p1_opt p2_opt, + [], + wl + + | None -> + let t1_base, p1_opt = base_and_refinement_maybe_delta true env t1 in + let t2_base, p2_opt = base_and_refinement_maybe_delta true env t2 in + let p, wl = eq_prob t1_base t2_base wl in + let t = combine_refinements t1_base p1_opt p2_opt in + (t, [p], wl) + in + let t1, ps, wl = combine t1 t2 wl in + if !dbg_Rel + then BU.print1 "pairwise fallback2 succeeded: %s" + (show t1); + t1, ps, wl + in + let rec aux (out, probs, wl) ts = + match ts with + | [] -> (out, probs, wl) + | t::ts -> + let out, probs', wl = pairwise out t wl in + aux (out, probs@probs', wl) ts + in + aux (List.hd ts, [], wl) (List.tl ts) + in + (*end meet_or_join *) + + let this_flex, this_rigid = if flip then tp.lhs, tp.rhs else tp.rhs, tp.lhs in + begin + match (SS.compress this_rigid).n with + | Tm_arrow {bs=_bs; comp} -> + //Although it's possible to take the meet/join of arrow types + //we handle them separately either by imitation (for Tot/GTot arrows) + //which provides some structural subtyping for them + //or just by reducing it to equality in other cases + + //BEWARE: special treatment of Tot and GTot here + if U.is_tot_or_gtot_comp comp + then let flex, wl = destruct_flex_t this_flex wl in + begin + match quasi_pattern wl.tcenv flex with + | None -> giveup_lit wl "flex-arrow subtyping, not a quasi pattern" (TProb tp) + | Some (flex_bs, flex_t) -> + if !dbg_Rel + then BU.print1 "Trying to solve by imitating arrow:%s\n" (string_of_int tp.pid); + imitate_arrow (TProb tp) wl flex flex_bs flex_t tp.relation this_rigid + end + else //imitating subtyping with WPs is hopeless + solve (attempt [TProb ({tp with relation=EQ})] wl) + + | _ -> + if !dbg_Rel then + BU.print1 "Trying to solve by meeting refinements:%s\n" (show tp.pid); + let u, _args = U.head_and_args this_flex in + let env = p_env wl (TProb tp) in + begin + match (SS.compress u).n with + | Tm_uvar(ctx_uvar, _subst) -> + let equiv (t:term) : bool = + let u', _ = U.head_and_args t in + match (whnf env u').n with + | Tm_uvar(ctx_uvar', _subst') -> + UF.equiv ctx_uvar.ctx_uvar_head ctx_uvar'.ctx_uvar_head + | _ -> false + in + //find all other constraints of the form t <: u, or if flipped, u <: t + let bounds_probs, rest = + wl.attempting |> List.partition + (function + | TProb tp -> + let tp = maybe_invert tp in + begin + match tp.rank with + | Some rank' when rank=rank' -> + if flip then equiv tp.lhs else equiv tp.rhs + + | _ -> false + end + + | _ -> false) + in + let bounds_typs = + whnf env this_rigid + :: List.collect (function + | TProb p -> [(if flip + then whnf env (maybe_invert p).rhs + else whnf env (maybe_invert p).lhs)] + | _ -> []) + bounds_probs + in + begin + let widen, meet_or_join_op = + if has_typeclass_constraint ctx_uvar wl + && not flip //we are widening; so widen all the way + then true, None + else false, Some (if flip then U.mk_conj_simp else U.mk_disj_simp) + in + let (bound, sub_probs, wl) = + match bounds_typs with + | [t] -> + if widen + then fst (base_and_refinement_maybe_delta false env t), [], wl + else (t, [], wl) + | _ -> + meet_or_join meet_or_join_op + bounds_typs + wl + in + let bound_typ, (eq_prob, wl') = + let flex_u = flex_uvar_head this_flex in + let bound = + //We get constraints of the form (x:?u{phi} <: ?u) + //This cannot be solved with an equality constraints + //So, turn the bound on the LHS to just ?u + match (SS.compress bound).n with + | Tm_refine {b=x; phi} + when tp.relation=SUB + && snd (occurs flex_u x.sort) -> + x.sort + | _ -> + bound + in + bound, + new_problem wl (p_env wl (TProb tp)) bound EQ this_flex None tp.loc + (if flip then "joining refinements" else "meeting refinements") + in + def_check_prob "meet_or_join2" (TProb eq_prob); + let _ = if !dbg_Rel + then let wl' = {wl with attempting=TProb eq_prob::sub_probs} in + BU.print1 "After meet/join refinements: %s\n" (wl_to_string wl') in + + let tx = UF.new_transaction () in + begin + List.iter (def_check_prob "meet_or_join3_sub") sub_probs; + match solve_t eq_prob ({wl' with defer_ok=NoDefer; + wl_implicits = Listlike.empty; + wl_deferred = empty; + attempting=sub_probs}) with + | Success (_, defer_to_tac, imps) -> + let wl = {wl' with attempting=rest} in + let wl = extend_wl wl empty defer_to_tac imps in + let g = List.fold_left (fun g p -> U.mk_conj g (p_guard p)) + eq_prob.logical_guard + sub_probs in + let wl = solve_prob' false (TProb tp) (Some g) [] wl in + let _ = List.fold_left (fun wl p -> solve_prob' true p None [] wl) wl bounds_probs in + UF.commit tx; + solve wl + + | Failed (p, msg) -> + if !dbg_Rel + then BU.print1 "meet/join attempted and failed to solve problems:\n%s\n" + (List.map (prob_to_string env) (TProb eq_prob::sub_probs) |> String.concat "\n"); + (match rank, base_and_refinement env bound_typ with + | Rigid_flex, (t_base, Some _) -> + UF.rollback tx; + //We failed to solve (x:t_base{p} <: ?u) while computing a precise join of all the lower bounds + //Rather than giving up, try again with a widening heuristic + //i.e., try to solve ?u = t and proceed + let eq_prob, wl = + new_problem wl (p_env wl (TProb tp)) t_base EQ this_flex None tp.loc "widened subtyping" in + def_check_prob "meet_or_join3" (TProb eq_prob); + let wl = solve_prob' false (TProb tp) (Some (p_guard (TProb eq_prob))) [] wl in + solve (attempt [TProb eq_prob] wl) + + | Flex_rigid, (t_base, Some (x, phi)) -> + UF.rollback tx; + //We failed to solve (?u = x:t_base{phi}) while computing + //a precise meet of all the upper bounds + //Rather than giving up, try again with a narrowing heuristic + //i.e., solve ?u = t_base, with the guard formula phi + let x = freshen_bv x in + let _, phi = SS.open_term [S.mk_binder x] phi in + let eq_prob, wl = + new_problem wl env t_base EQ this_flex None tp.loc "widened subtyping" in + def_check_prob "meet_or_join4" (TProb eq_prob); + let phi = guard_on_element wl tp x phi in + let wl = solve_prob' false (TProb tp) (Some (U.mk_conj phi (p_guard (TProb eq_prob)))) [] wl in + solve (attempt [TProb eq_prob] wl) + + | _ -> + giveup wl (Thunk.map (fun s -> "failed to solve the sub-problems: " ^ s) msg) p) + end + end + + | _ when flip -> + failwith (BU.format2 "Impossible: (rank=%s) Not a flex-rigid: %s" + (BU.string_of_int (rank_t_num rank)) + (prob_to_string env (TProb tp))) + | _ -> + failwith (BU.format2 "Impossible: (rank=%s) Not a rigid-flex: %s" + (BU.string_of_int (rank_t_num rank)) + (prob_to_string env (TProb tp))) + end + end + +and imitate_arrow (orig:prob) (wl:worklist) + (lhs:flex_t) (bs_lhs:binders) (t_res_lhs:term) + (rel:rel) + (arrow:term) + : solution = + let bs_lhs_args = List.map (fun ({binder_bv=x;binder_qual=i}) -> S.bv_to_name x, i) bs_lhs in + let (Flex (_, u_lhs, _)) = lhs in + let imitate_comp bs bs_terms c wl = + let imitate_tot_or_gtot t f wl = + let k, _ = U.type_u () in + let _, u, wl = copy_uvar u_lhs (bs_lhs@bs) k wl in + f u, wl + in + match c.n with + | Total t -> + imitate_tot_or_gtot t S.mk_Total wl + | GTotal t -> + imitate_tot_or_gtot t S.mk_GTotal wl + | Comp ct -> + let out_args, wl = + List.fold_right + (fun (a, i) (out_args, wl) -> + let _, t_a, wl = copy_uvar u_lhs [] (fst <| U.type_u()) wl in + let _, a', wl = copy_uvar u_lhs bs t_a wl in + (a',i)::out_args, wl) + ((S.as_arg ct.result_typ)::ct.effect_args) + ([], wl) + in + (* Drop the decreases flag, it is not needed and + * wouldn't be properly scoped either. *) + let nodec flags = List.filter (function DECREASES _ -> false + | _ -> true) flags in + let ct' = {ct with result_typ=fst (List.hd out_args); + effect_args=List.tl out_args; + flags=nodec ct.flags} in + {c with n=Comp ct'}, wl + in + let formals, c = U.arrow_formals_comp arrow in + let rec aux (bs:binders) (bs_terms:list arg) (formals:binders) wl = + match formals with + | [] -> + let c', wl = imitate_comp bs bs_terms c wl in + let lhs' = U.arrow bs c' in + let sol = TERM (u_lhs, U.abs bs_lhs lhs' (Some (U.residual_tot t_res_lhs))) in + let sub_prob, wl = + mk_t_problem wl [] orig lhs' rel arrow None "arrow imitation" + in + //printfn "Arrow imitation: %s =?= %s" (show lhs') (show rhs); + solve (attempt [sub_prob] (solve_prob orig None [sol] wl)) + + | ({binder_bv=x;binder_qual=imp;binder_positivity=pqual;binder_attrs=attrs})::formals -> + let _ctx_u_x, u_x, wl = copy_uvar u_lhs (bs_lhs@bs) (U.type_u() |> fst) wl in + //printfn "Generated formal %s where %s" (show t_y) (show ctx_u_x); + let y = S.new_bv (Some (S.range_of_bv x)) u_x in + let b = S.mk_binder_with_attrs y imp pqual attrs in + aux (bs@[b]) (bs_terms@[U.arg_of_non_null_binder b]) formals wl + in + let _, occurs_ok, msg = occurs_check u_lhs arrow in + if not occurs_ok + then giveup_or_defer orig wl + Deferred_occur_check_failed + (mklstr (fun () -> "occurs-check failed: " ^ (Option.get msg))) + else aux [] [] formals wl + +and solve_binders (bs1:binders) (bs2:binders) (orig:prob) (wl:worklist) + (rhs:worklist -> binders -> list subst_elt -> (prob & worklist)) : solution = + + if !dbg_Rel + then BU.print3 "solve_binders\n\t%s\n%s\n\t%s\n" + (show bs1) + (rel_to_string (p_rel orig)) + (show bs2); + + let eq_bqual a1 a2 = + match a1, a2 with + | Some (Implicit b1), Some (Implicit b2) -> + true //we don't care about comparing the dot qualifier in this context + | _ -> + U.eq_bqual a1 a2 + in + + let compat_positivity_qualifiers (p1 p2:option positivity_qualifier) : bool = + match p_rel orig with + | EQ -> + FStarC.TypeChecker.Common.check_positivity_qual false p1 p2 + | SUB -> + FStarC.TypeChecker.Common.check_positivity_qual true p1 p2 + | SUBINV -> + FStarC.TypeChecker.Common.check_positivity_qual true p2 p1 + in + (* + * AR: adding env to the return type + * + * `aux` solves the binders problems xs REL ys, and keeps on adding the binders to env + * so that subsequent binders are solved in the right env + * when all the binders are solved, it creates the rhs problem and returns it + * the problem was that this rhs problem was getting solved in the original env, + * since `aux` never returned the env with all the binders + * so far it was fine, but with layered effects, we have to be really careful about the env + * so now we return the updated env, and the rhs is solved in that final env + * (see how `aux` is called after its definition below) + *) + let rec aux wl scope subst (xs:binders) (ys:binders) : either (probs & formula) string & worklist = + match xs, ys with + | [], [] -> + let rhs_prob, wl = rhs wl scope subst in + if !dbg_Rel + then BU.print1 "rhs_prob = %s\n" (prob_to_string (p_env wl rhs_prob) rhs_prob); + let formula = p_guard rhs_prob in + Inl ([rhs_prob], formula), wl + + | x::xs, y::ys + when (eq_bqual x.binder_qual y.binder_qual && + compat_positivity_qualifiers x.binder_positivity y.binder_positivity) -> + let hd1, imp = x.binder_bv, x.binder_qual in + let hd2, imp' = y.binder_bv, y.binder_qual in + let hd1 = {hd1 with sort=Subst.subst subst hd1.sort} in //open both binders + let hd2 = {hd2 with sort=Subst.subst subst hd2.sort} in + let prob, wl = mk_t_problem wl scope orig hd1.sort (invert_rel <| p_rel orig) hd2.sort None "Formal parameter" in + let hd1 = freshen_bv hd1 in + let subst = DB(0, hd1)::SS.shift_subst 1 subst in //extend the substitution + begin + match aux wl (scope @ [{x with binder_bv=hd1}]) subst xs ys with + | Inl (sub_probs, phi), wl -> + let phi = + U.mk_conj (p_guard prob) + (close_forall (p_env wl prob) [{x with binder_bv=hd1}] phi) in + if !dbg_Rel + then BU.print2 "Formula is %s\n\thd1=%s\n" (show phi) (show hd1); + Inl (prob::sub_probs, phi), wl + + | fail -> fail + end + + | _ -> Inr "arity or argument-qualifier mismatch", wl in + + match aux wl [] [] bs1 bs2 with + | Inr msg, wl -> giveup_lit wl msg orig + | Inl (sub_probs, phi), wl -> + let wl = solve_prob orig (Some phi) [] wl in + solve (attempt sub_probs wl) + +and try_solve_without_smt_or_else + (wl:worklist) + (try_solve: worklist -> solution) + (else_solve: worklist -> (prob & lstring) -> solution) + : solution = + let wl' = {wl with defer_ok=NoDefer; + smt_ok=false; + umax_heuristic_ok=false; + attempting=[]; + wl_deferred=empty; + wl_implicits=Listlike.empty} in + let tx = UF.new_transaction () in + match try_solve wl' with + | Success (_, defer_to_tac, imps) -> + UF.commit tx; + let wl = extend_wl wl empty defer_to_tac imps in + solve wl + | Failed (p, s) -> + UF.rollback tx; + else_solve wl (p,s) + +and try_solve_then_or_else + (wl:worklist) + (try_solve: worklist -> solution) + (then_solve: worklist -> solution) + (else_solve: worklist -> solution) + : solution = + let empty_wl = + {wl with defer_ok=NoDefer; + attempting=[]; + wl_deferred=empty; + wl_implicits=empty} in + let tx = UF.new_transaction () in + match try_solve empty_wl with + | Success (_, defer_to_tac, imps) -> + UF.commit tx; + let wl = extend_wl wl empty defer_to_tac imps in + then_solve wl + | Failed (p, s) -> + UF.rollback tx; + else_solve wl + +and try_solve_probs_without_smt + (wl:worklist) + (probs:worklist -> (probs & worklist)) + : either worklist lstring + = let probs, wl' = probs wl in + let wl' = {wl with defer_ok=NoDefer; + smt_ok=false; + umax_heuristic_ok=false; + attempting=probs; + wl_deferred=empty; + wl_implicits=Listlike.empty} in + match solve wl' with + | Success (_, defer_to_tac, imps) -> + let wl = extend_wl wl empty defer_to_tac imps in + Inl wl + + | Failed (_, ls) -> + Inr ls + +and solve_t (problem:tprob) (wl:worklist) : solution = + def_check_prob "solve_t" (TProb problem); + solve_t' (compress_tprob wl problem) wl + +and solve_t_flex_rigid_eq (orig:prob) (wl:worklist) (lhs:flex_t) (rhs:term) + : solution = + if !dbg_Rel then ( + BU.print1 "solve_t_flex_rigid_eq rhs=%s\n" + (show rhs) + ); + + if should_defer_flex_to_user_tac wl lhs + then defer_to_user_tac orig (flex_reason lhs) wl + else + + (* + mk_solution takes care to not introduce needless eta expansions + + lhs is of the form `?u bs` + Abstractly, the goal is to set `?u := fun bs -> rhs` + + But, this is optimized so that in case `rhs` is say `e bs`, + where `bs` does not appear free in `e`, + then we set `?u := e`. + + This is important since eta equivalence is not validated by F*. + + So, introduce needless eta expansions here would lead to unification + failures elsewhere + *) + let mk_solution env (lhs:flex_t) (bs:binders) (rhs:term) = + let bs_orig = bs in + let rhs_orig = rhs in + let (Flex (_, ctx_u, args)) = lhs in + let bs, rhs = + let bv_not_free_in_arg x arg = + not (mem x (Free.names (fst arg))) + in + let bv_not_free_in_args x args = + BU.for_all (bv_not_free_in_arg x) args + in + let binder_matches_aqual b aq = + match b.binder_qual, aq with + | None, None -> true + | Some (Implicit _), Some a -> + a.aqual_implicit && + U.eqlist (fun x y -> TEQ.eq_tm env x y = TEQ.Equal) + b.binder_attrs + a.aqual_attributes + | _ -> false + in + let rec remove_matching_prefix lhs_binders rhs_args = + match lhs_binders, rhs_args with + | [], _ + | _, [] -> lhs_binders, rhs_args + + | b::lhs_tl, (t, aq)::rhs_tl -> + match (SS.compress t).n with + | Tm_name x + when bv_eq b.binder_bv x + && binder_matches_aqual b aq + && bv_not_free_in_args b.binder_bv rhs_tl -> + remove_matching_prefix lhs_tl rhs_tl + | _ -> + lhs_binders, rhs_args + in + let rhs_hd, rhs_args = U.head_and_args rhs in + let bs, rhs_args = + remove_matching_prefix + (List.rev bs_orig) + (List.rev rhs_args) + |> (fun (bs_rev, args_rev) -> List.rev bs_rev, List.rev args_rev) + in + bs, + S.mk_Tm_app rhs_hd rhs_args rhs.pos + in + let sol = + match bs with + | [] -> rhs + | _ -> u_abs (U.ctx_uvar_typ ctx_u) (sn_binders env bs) rhs + in + [TERM(ctx_u, sol)] + in + + (* + LHS: ?u e1..en, if the arity of ?u is n + then LHS as a quasi pattern is (?u x1 ... xn) + for some names x1...xn + + (see the comment on quasi_pattern on how these names are computed) + + + if the free vars of rhs are included in ctx(?u) ++ {x1,...,xn} + + then solve by ?u <- (fun x1 .... xn -> rhs) + + provided ?u does not occur in RHS + + and after all uvars in the RHS (?u1 .. ?un) are restricted to the context (ctx(?u)) + + This has the behavior of preserving functional dependences in *some* cases. + + Consider two examples: + + 1. + LHS = ?u A.x, where A.x is an fv + RHS = option A.x + + Then quasi patern of LHS is (?u y), for some fresh y + since we can't abstract over the A.x + + The resulting solution will be + ?u <- fun y -> option A.x + + i.e., ?u is solved to the constant function + rather than `option` + + 2. LHS = ?u x, where x is just a name DOES NOT APPEAR in ctx(?u) + RHS = option (some complicated term including x) + + This time the quasi patern of LHS is (?u x) and + the resulting solution will be + + ?u <- fun x -> option (some complicated term including x) + + preserving the dependence on `x` + + *) + let try_quasi_pattern (orig:prob) (env:Env.env) (wl:worklist) + (lhs:flex_t) (rhs:term) + : either string (list uvi) & worklist = + if !dbg_Rel then + BU.print_string "try_quasi_pattern\n"; + match quasi_pattern env lhs with + | None -> + Inl "Not a quasi-pattern", wl + + | Some (bs, _) -> + let (Flex (t_lhs, ctx_u, args)) = lhs in + let uvars, occurs_ok, msg = occurs_check ctx_u rhs in + if not occurs_ok + then Inl ("quasi-pattern, occurs-check failed: " ^ (Option.get msg)), wl + else let fvs_lhs = binders_as_bv_set (ctx_u.ctx_uvar_binders@bs) in + let fvs_rhs = Free.names rhs in + if not (subset fvs_rhs fvs_lhs) + then Inl ("quasi-pattern, free names on the RHS are not included in the LHS"), wl + else Inr (mk_solution env lhs bs rhs), restrict_all_uvars env ctx_u [] uvars wl + in + + (* + LHS is a (?u e1..en) is a quasi pattern (?u b1...bn) + where bs_lhs = b1 .. bn (none of which appear in ctx(?u) (see quasi_pattern)) + and the type of ?u is (b1..bn -> t_res_lhs) + + RHS is an application (head e) where e:t_last + + Produce two new uvars: + ctx(?u), b1..bn, _:t_last |- ?u_head : t_last -> t_res_lhs + ctx(?u), b1..bn |- ?u_arg : t_last + + Solve: ?u <- (fun b1..bn -> ?u_head ?u_arg) + + And generate sub-problems + ?u_head = head + ?u_arg = arg + + Since it is based on quasi patterns, imitate_app (like + try_quasi_pattern) will usually not preserve functional + dependences + + For example: + + 1. LHS = ?u A.x, where A.x is an fv + RHS = option A.x + + Then quasi patern of LHS is (?u y), for some fresh y + since we can't abstract over the A.x + + The resulting solution will be + + ?u <- fun y -> ?u_head ?u_arg + + and ?u_head <- option + and ?u_arg <- A.x + + So, in a more roundabout way, we arrive at the same constant + function as the solution to ?u + *) + let imitate_app (orig:prob) (env:Env.env) (wl:worklist) + (lhs:flex_t) (bs_lhs:binders) (t_res_lhs:term) + (rhs:term) + : solution = + // if !dbg_Rel + // then BU.print4 "imitate_app 1:\n\tlhs=%s\n\tbs_lhs=%s\n\tt_res_lhs=%s\n\trhs=%s\n" + // (flex_t_to_string lhs) + // (Print.binders_to_string ", " bs_lhs) + // (show t_res_lhs) + // (show rhs); + let rhs_hd, args = U.head_and_args rhs in + let args_rhs, last_arg_rhs = BU.prefix args in + let rhs' = S.mk_Tm_app rhs_hd args_rhs rhs.pos in + // if !dbg_Rel + // then BU.print2 "imitate_app 2:\n\trhs'=%s\n\tlast_arg_rhs=%s\n" + // (show rhs') + // (show [last_arg_rhs]); + let (Flex (t_lhs, u_lhs, _lhs_args)) = lhs in + let lhs', lhs'_last_arg, wl = + let t_last_arg, _ = + let env = p_env wl orig in + env.typeof_well_typed_tot_or_gtot_term + ({env with admit=true; expected_typ=None}) + (fst last_arg_rhs) + false + in //AR: 03/30: WARNING: dropping the guard + //AR: 07/20: note the type of lhs' is t_last_arg -> t_res_lhs + let _, lhs', wl = + let b = S.null_binder t_last_arg in + copy_uvar u_lhs (bs_lhs@[b]) + (t_res_lhs |> S.mk_Total |> U.arrow [b]) wl + in + let _, lhs'_last_arg, wl = copy_uvar u_lhs bs_lhs t_last_arg wl in + lhs', lhs'_last_arg, wl + in + // if !dbg_Rel + // then BU.print2 "imitate_app 3:\n\tlhs'=%s\n\tlast_arg_lhs=%s\n" + // (show lhs') + // (show lhs'_last_arg); + let sol = [TERM(u_lhs, U.abs bs_lhs (S.mk_Tm_app lhs' [(lhs'_last_arg, snd last_arg_rhs)] t_lhs.pos) + (Some (U.residual_tot t_res_lhs)))] + in + let sub_probs, wl = + let p1, wl = mk_t_problem wl [] orig lhs' EQ rhs' None "first-order lhs" in + let p2, wl = mk_t_problem wl [] orig lhs'_last_arg EQ (fst last_arg_rhs) None "first-order rhs" in + [p1; p2], wl + in + solve (attempt sub_probs (solve_prob orig None sol wl)) + in + + (* + LHS: ?u e1..en, if the arity of ?u is n + then LHS as a quasi pattern is (?u x1 ... xn) + for some names x1...xn + + (see the comment on quasi_pattern on how these names are computed) + + If the RHS is an application (t e): imitate_app + + If the RHS is an arrow (xi:ti -> C): imitate_arrow + *) + let imitate (orig:prob) (env:Env.env) (wl:worklist) + (lhs:flex_t) (rhs:term) + : solution = + if !dbg_Rel then + BU.print_string "imitate\n"; + let is_app rhs = + let _, args = U.head_and_args rhs in + match args with + | [] -> false + | _ -> true + in + let is_arrow rhs = + match (SS.compress rhs).n with + | Tm_arrow _ -> true + | _ -> false + in + match quasi_pattern env lhs with + | None -> + let msg = mklstr (fun () -> + BU.format1 "imitate heuristic cannot solve %s; lhs not a quasi-pattern" + (prob_to_string env orig)) in + giveup_or_defer orig wl Deferred_first_order_heuristic_failed msg + + | Some (bs_lhs, t_res_lhs) -> + if is_app rhs + then imitate_app orig env wl lhs bs_lhs t_res_lhs rhs + else if is_arrow rhs + then imitate_arrow orig wl lhs bs_lhs t_res_lhs EQ rhs + else + let msg = mklstr (fun () -> + BU.format1 "imitate heuristic cannot solve %s; rhs not an app or arrow" + (prob_to_string env orig)) in + giveup_or_defer orig wl Deferred_first_order_heuristic_failed msg + in + (* + LHS = (?u : t1..tn -> t) e1..em + RHS = f v1...vm + + if (f: t1..tn -> t) + + ?u <- f + + and generate (e1 =?= v1, ..., em =?= vm) + + while restricting all free uvars in f to the context of ?u + *) + let try_first_order orig env wl lhs rhs = + let inapplicable msg lstring_opt = + if !dbg_Rel + then ( + let extra_msg = + match lstring_opt with + | None -> "" + | Some l -> Thunk.force l + in + BU.print2 "try_first_order failed because: %s\n%s\n" msg extra_msg + ); + Inl "first_order doesn't apply" + in + if !dbg_Rel then + BU.print2 "try_first_order\n\tlhs=%s\n\trhs=%s\n" + (flex_t_to_string lhs) + (show rhs); + let (Flex (_t1, ctx_uv, args_lhs)) = lhs in + let n_args_lhs = List.length args_lhs in + let head, args_rhs = U.head_and_args rhs in + let n_args_rhs = List.length args_rhs in + if n_args_lhs > n_args_rhs + then inapplicable "not enough args" None + else + let i = n_args_rhs - n_args_lhs in + let prefix, args_rhs = List.splitAt i args_rhs in + let head = S.mk_Tm_app head prefix head.pos in + let uvars_head, occurs_ok, _ = occurs_check ctx_uv head in + if not occurs_ok + then inapplicable "occurs check failed" None + else if not (Free.names head `subset` binders_as_bv_set ctx_uv.ctx_uvar_binders) + then inapplicable "free name inclusion failed" None + else ( + let t_head, _ = + env.typeof_well_typed_tot_or_gtot_term + ({env with admit=true; expected_typ=None}) + head + false + in + let tx = UF.new_transaction () in + let solve_sub_probs_if_head_types_equal head_uvars_to_restrict wl = + let sol = [TERM(ctx_uv, head)] in + let wl = restrict_all_uvars env ctx_uv [] head_uvars_to_restrict wl in + let wl = solve_prob orig None sol wl in + + let sub_probs, wl = + List.fold_left2 + (fun (probs, wl) (arg_lhs, _) (arg_rhs, _) -> + let p, wl = mk_t_problem wl [] orig arg_lhs EQ arg_rhs None "first-order arg" in + p::probs, wl) + ([], wl) + args_lhs + args_rhs + in + let wl' = { wl with defer_ok = NoDefer; + smt_ok = false; + attempting = sub_probs; + wl_deferred = empty; + wl_implicits = Listlike.empty } in + match solve wl' with + | Success (_, defer_to_tac, imps) -> + let wl = extend_wl wl empty defer_to_tac imps in + UF.commit tx; + Inr wl + | Failed (_, lstring) -> + UF.rollback tx; + inapplicable "Subprobs failed: " (Some lstring) + in + if TEQ.eq_tm env t_head (U.ctx_uvar_typ ctx_uv) = TEQ.Equal + then + // + // eq_tm doesn't unify, so uvars_head computed remains consistent + // (see the second call to solve_sub_probs_if_head_types_equal below) + // + solve_sub_probs_if_head_types_equal uvars_head wl + else ( + if !dbg_Rel + then BU.print2 "first-order: head type mismatch:\n\tlhs=%s\n\trhs=%s\n" + (show (U.ctx_uvar_typ ctx_uv)) + (show t_head); + let typ_equality_prob wl = + let p, wl = mk_t_problem wl [] orig (U.ctx_uvar_typ ctx_uv) EQ t_head None "first-order head type" in + [p], wl + in + match try_solve_probs_without_smt wl typ_equality_prob with + | Inl wl -> + // + // Some uvars from uvars_head list above may already be solved + // or restricted, so recompute since solve_sub_probs_if_head_types_equal + // will also try to restrict them + // + solve_sub_probs_if_head_types_equal + (head |> Free.uvars |> elems) + wl + | Inr msg -> + UF.rollback tx; + inapplicable "first-order: head type mismatch" (Some msg) + ) + ) + in + match p_rel orig with + | SUB + | SUBINV -> + if wl.defer_ok = DeferAny + then giveup_or_defer orig wl Deferred_flex (Thunk.mkv "flex-rigid subtyping") + else solve_t_flex_rigid_eq (make_prob_eq orig) wl lhs rhs + + | EQ -> + let (Flex (_t1, ctx_uv, args_lhs)) = lhs in + let env = p_env wl orig in + match pat_vars env ctx_uv.ctx_uvar_binders args_lhs with + | Some lhs_binders -> //Pattern + if !dbg_Rel then + BU.print_string "it's a pattern\n"; + let rhs = sn env rhs in + let fvs1 = binders_as_bv_set (ctx_uv.ctx_uvar_binders @ lhs_binders) in + let fvs2 = Free.names rhs in + //if !dbg_Rel then + // BU.print4 "lhs \t= %s\n\ + // FV(lhs) \t= %s\n\ + // rhs \t= %s\n\ + // FV(rhs) \t= %s\n" + // (flex_t_to_string lhs) + // (show fvs1) + // (show rhs) + // (show fvs2); + let uvars, occurs_ok, msg = occurs_check ctx_uv rhs in + + (* If the occurs check fails, attempt to do a bit more normalization + and try it again. *) + let (uvars, occurs_ok, msg), rhs = + if occurs_ok + then (uvars, occurs_ok, msg), rhs + else + let rhs = N.normalize + [Env.Primops; Env.Weak; Env.HNF; Env.Beta; Env.Eager_unfolding; Env.Unascribe] + (p_env wl orig) rhs in + occurs_check ctx_uv rhs, rhs + in + + (* If, possibly after some extra normalization in the above block, + the RHS has become syntactically equal to the LHS, solve the problem + and carry on. See #3264. *) + if term_is_uvar ctx_uv rhs && Nil? args_lhs then + solve (solve_prob orig None [] wl) + else + if not occurs_ok + then giveup_or_defer orig wl + Deferred_occur_check_failed + (Thunk.mkv <| "occurs-check failed: " ^ (Option.get msg)) + else if subset fvs2 fvs1 + then let sol = mk_solution env lhs lhs_binders rhs in + let wl = restrict_all_uvars env ctx_uv lhs_binders uvars wl in + solve (solve_prob orig None sol wl) + else if wl.defer_ok = DeferAny + then + let msg = mklstr (fun () -> + BU.format3 "free names in the RHS {%s} are out of scope for the LHS: {%s}, {%s}" + (show fvs2) + (show fvs1) + (show (ctx_uv.ctx_uvar_binders @ lhs_binders))) in + giveup_or_defer orig wl Deferred_free_names_check_failed msg + else imitate orig env wl lhs rhs + + + | _ -> //Not a pattern + if wl.defer_ok = DeferAny + then giveup_or_defer orig wl Deferred_not_a_pattern (Thunk.mkv "Not a pattern") + else match try_first_order orig env wl lhs rhs with + | Inr wl -> + solve wl + + | _ -> + + match try_quasi_pattern orig env wl lhs rhs with + | Inr sol, wl -> + solve (solve_prob orig None sol wl) + + | Inl msg, _ -> + imitate orig env wl lhs rhs + +(* solve_t_flex-flex: + Always delay flex-flex constraints, if possible. + If not, see if one of the flex uvar has a meta program associated + If yes, run that meta program, solve the uvar, and try again + If not, coerce both sides to patterns and solve +*) +and solve_t_flex_flex env orig wl (lhs:flex_t) (rhs:flex_t) : solution = + let should_run_meta_arg_tac (flex:flex_t) = + (* If this flex has a meta-arg, and the problem is fully + defined (no uvars in env/typ), then we can run it now. *) + let uv = flex_uvar flex in + flex_uvar_has_meta_tac uv && + not (has_free_uvars (U.ctx_uvar_typ uv)) && + not (gamma_has_free_uvars uv.ctx_uvar_gamma) + in + + let run_meta_arg_tac_and_try_again (flex:flex_t) = + let uv = flex_uvar flex in + let t = run_meta_arg_tac env uv in + if !dbg_Rel then + BU.print2 "solve_t_flex_flex: solving meta arg uvar %s with %s\n" (show uv) (show t); + set_uvar env uv None t; + solve (attempt [orig] wl) in + + match p_rel orig with + | SUB + | SUBINV -> + if wl.defer_ok = DeferAny + then giveup_or_defer_flex_flex orig wl Deferred_flex (Thunk.mkv "flex-flex subtyping") + else solve_t_flex_flex env (make_prob_eq orig) wl lhs rhs + + | EQ -> + if should_defer_flex_to_user_tac wl lhs || should_defer_flex_to_user_tac wl rhs + then defer_to_user_tac orig (flex_reason lhs ^", "^flex_reason rhs)wl + else + + if (wl.defer_ok = DeferAny || wl.defer_ok = DeferFlexFlexOnly) + && (not (is_flex_pat lhs)|| not (is_flex_pat rhs)) + then giveup_or_defer_flex_flex orig wl Deferred_flex_flex_nonpattern (Thunk.mkv "flex-flex non-pattern") + + else if should_run_meta_arg_tac lhs + then run_meta_arg_tac_and_try_again lhs + + else if should_run_meta_arg_tac rhs + then run_meta_arg_tac_and_try_again rhs + + else + let rec occurs_bs u bs = + match bs with + | [] -> false + | b::bs -> snd (occurs u b.binder_bv.sort) || occurs_bs u bs + in + match quasi_pattern env lhs, quasi_pattern env rhs with + | Some (binders_lhs, t_res_lhs), Some (binders_rhs, t_res_rhs) -> + let (Flex ({pos=range}, u_lhs, _)) = lhs in + if occurs_bs u_lhs binders_lhs then + (* Fix for #2583 *) + giveup_or_defer orig wl Deferred_flex_flex_nonpattern + (Thunk.mkv "flex-flex: occurs check failed on the LHS flex quasi-pattern") + else + let (Flex (_, u_rhs, _)) = rhs in + if UF.equiv u_lhs.ctx_uvar_head u_rhs.ctx_uvar_head + && binders_eq binders_lhs binders_rhs + then solve (solve_prob orig None [] wl) + else (* Given a flex-flex instance: + (x1..xn ..X |- ?u : ts -> tres) [y1 ... ym ] + ~ (x1..xn ..X' |- ?v : ts' -> tres) [y1' ... ym'] + + let ctx_w = x1..xn in + let z1..zk = (..X..y1..ym intersect ...X'...y1'..ym') in + (ctx_w |- ?w : z1..zk -> tres) [z1..zk] + + ?u := (fun y1..ym -> ?w z1...zk) + ?v := (fun y1'..ym' -> ?w z1...zk) + *) + //let sub_prob, wl = + // //is it strictly necessary to add this sub problem? + // //we don't in other cases + // mk_t_problem wl [] orig t_res_lhs EQ t_res_rhs None "flex-flex typing" + //in + let ctx_w, (ctx_l, ctx_r) = + maximal_prefix u_lhs.ctx_uvar_binders + u_rhs.ctx_uvar_binders + in + let gamma_w = gamma_until u_lhs.ctx_uvar_gamma ctx_w in + let zs = intersect_binders gamma_w (ctx_l @ binders_lhs) (ctx_r @ binders_rhs) in + let new_uvar_typ = U.arrow zs (S.mk_Total t_res_lhs) in + if snd (occurs u_lhs new_uvar_typ) + || (not (Unionfind.equiv u_lhs.ctx_uvar_head u_rhs.ctx_uvar_head) && + snd (occurs u_rhs new_uvar_typ)) + then giveup_or_defer_flex_flex orig wl Deferred_flex_flex_nonpattern + (Thunk.mkv (BU.format1 "flex-flex: occurs\n defer_ok=%s\n" + (show wl.defer_ok))) + else begin + // let _ = + // if !dbg_Rel + // then BU.print1 "flex-flex quasi: %s\n" + // (BU.stack_dump()) + // in + let new_uvar_should_check, is_ghost = + match U.ctx_uvar_should_check u_lhs, U.ctx_uvar_should_check u_rhs with + | Allow_untyped r, Allow_untyped _ -> Allow_untyped r, false + | Allow_ghost r, _ + | _, Allow_ghost r -> Allow_ghost r, true + | _ -> Strict, false in + let _, w, wl = new_uvar ("flex-flex quasi:" + ^"\tlhs=" ^u_lhs.ctx_uvar_reason + ^"\trhs=" ^u_rhs.ctx_uvar_reason) + wl range gamma_w ctx_w new_uvar_typ + new_uvar_should_check + (if Some? u_lhs.ctx_uvar_meta + then u_lhs.ctx_uvar_meta + else u_rhs.ctx_uvar_meta) // Try to retain the meta, if any + in + let w_app = S.mk_Tm_app w (List.map (fun ({binder_bv=z}) -> S.as_arg (S.bv_to_name z)) zs) w.pos in + let _ = + if !dbg_Rel + then BU.print "flex-flex quasi:\n\t\ + lhs=%s\n\t\ + rhs=%s\n\t\ + sol=%s\n\t\ + ctx_l@binders_lhs=%s\n\t\ + ctx_r@binders_rhs=%s\n\t\ + zs=%s\n" + [flex_t_to_string lhs; + flex_t_to_string rhs; + term_to_string w; + show (ctx_l@binders_lhs); + show (ctx_r@binders_rhs); + show zs] + in + let rc = (if is_ghost then U.residual_gtot else U.residual_tot) t_res_lhs in + let s1_sol = U.abs binders_lhs w_app (Some rc) in + let s1 = TERM(u_lhs, s1_sol) in + if Unionfind.equiv u_lhs.ctx_uvar_head u_rhs.ctx_uvar_head + then solve (solve_prob orig None [s1] wl) + else ( + let s2_sol = U.abs binders_rhs w_app (Some rc) in + let s2 = TERM(u_rhs, s2_sol) in + solve (solve_prob orig None [s1;s2] wl) + ) + end + + | _ -> + giveup_or_defer orig wl Deferred_flex_flex_nonpattern (Thunk.mkv "flex-flex: non-patterns") + +and solve_t' (problem:tprob) (wl:worklist) : solution = + def_check_prob "solve_t'.1" (TProb problem); + let giveup_or_defer orig msg = giveup_or_defer orig wl msg in + + let rigid_heads_match (need_unif:bool) (torig:tprob) (wl:worklist) (t1:term) (t2:term) : solution = + let orig = TProb torig in + let env = p_env wl orig in + if !dbg_Rel + then BU.print5 "Heads %s: %s (%s) and %s (%s)\n" + (if need_unif then "need unification" else "match") + (show t1) (tag_of t1) + (show t2) (tag_of t2); + let head1, args1 = U.head_and_args t1 in + let head2, args2 = U.head_and_args t2 in + let need_unif = + match (head1.n, args1), (head2.n, args2) with + | (Tm_uinst(_, us1), _::_), (Tm_uinst(_, us2), _::_) -> + if List.for_all (fun u -> not (universe_has_max env u)) us1 + && List.for_all (fun u -> not (universe_has_max env u)) us2 + then need_unif //if no umaxes then go ahead as usual + else true //else, decompose the problem and potentially defer + | _ -> need_unif + in + let solve_head_then wl k = + if need_unif then k true wl + else match solve_maybe_uinsts orig head1 head2 wl with + | USolved wl -> k true wl //(solve_prob orig None [] wl) + | UFailed msg -> giveup wl msg orig + | UDeferred wl -> k false (defer_lit Deferred_univ_constraint "universe constraints" orig wl) + in + let nargs = List.length args1 in + if nargs <> List.length args2 + then giveup wl + (mklstr + (fun () -> BU.format4 "unequal number of arguments: %s[%s] and %s[%s]" + (show head1) (show args1) (show head2) (show args2))) + orig + else + if nargs=0 || TEQ.eq_args env args1 args2=TEQ.Equal //special case: for easily proving things like nat <: nat, or greater_than i <: greater_than i etc. + then if need_unif + then solve_t ({problem with lhs=head1; rhs=head2}) wl + else solve_head_then wl (fun ok wl -> + if ok then solve (solve_prob orig None [] wl) + else solve wl) + else//Given T t1 ..tn REL T s1..sn + // if T expands to a refinement, then normalize it and recurse + // This allows us to prove things like + // type T (x:int) (y:int) = z:int{z = x + y} + // T 0 1 <: T 1 0 + // By expanding out the definitions + // + //Otherwise, we reason extensionally about T and try to prove the arguments equal, i.e, ti = si, for all i + let base1, refinement1 = base_and_refinement env t1 in + let base2, refinement2 = base_and_refinement env t2 in + begin + match refinement1, refinement2 with + | None, None -> //neither side is a refinement; reason extensionally + let mk_sub_probs wl = + let argp = + if need_unif + then List.zip ((head1, None)::args1) ((head2, None)::args2) + else List.zip args1 args2 + in + let subprobs, wl = + List.fold_right + (fun ((a1, _), (a2, _)) (probs, wl) -> + let prob', wl = mk_problem wl [] orig a1 EQ a2 None "index" in + (TProb prob')::probs, wl) + argp + ([], wl) + in + if !dbg_Rel + then BU.print2 + "Adding subproblems for arguments (smtok=%s): %s" + (string_of_bool wl.smt_ok) + (FStarC.Common.string_of_list (prob_to_string env) subprobs); + if Options.defensive () + then List.iter (def_check_prob "solve_t' subprobs") subprobs; + subprobs, wl + in + let solve_sub_probs env wl = + solve_head_then wl (fun ok wl -> + if not ok + then solve wl + else let subprobs, wl = mk_sub_probs wl in + let formula = U.mk_conj_l (List.map (fun p -> p_guard p) subprobs) in + let wl = solve_prob orig (Some formula) [] wl in + solve (attempt subprobs wl)) + in + let solve_sub_probs_no_smt wl = + solve_head_then wl (fun ok wl -> + assert ok; //defer not allowed + let subprobs, wl = mk_sub_probs wl in + let formula = U.mk_conj_l (List.map (fun p -> p_guard p) subprobs) in + let wl = solve_prob orig (Some formula) [] wl in + solve (attempt subprobs wl)) + in + let unfold_and_retry d wl (prob, reason) = + if !dbg_Rel + then BU.print2 "Failed to solve %s because a sub-problem is not solvable without SMT because %s" + (prob_to_string env orig) + (Thunk.force reason); + let env = p_env wl prob in + match N.unfold_head_once env t1, + N.unfold_head_once env t2 + with + | Some t1', Some t2' -> + let head1', _ = U.head_and_args t1' in + let head2', _ = U.head_and_args t2' in + begin + match TEQ.eq_tm env head1' head1, TEQ.eq_tm env head2' head2 with + | TEQ.Equal, TEQ.Equal -> //unfolding didn't make progress + if !dbg_Rel + then BU.print4 + "Unfolding didn't make progress ... got %s ~> %s;\nand %s ~> %s\n" + (show t1) + (show t1') + (show t2) + (show t2'); + solve_sub_probs env wl //fallback to trying to solve with SMT on + | _ -> + let torig' = {torig with lhs=t1'; rhs=t2'} in + if !dbg_Rel + then BU.print1 "Unfolded and now trying %s\n" + (prob_to_string env (TProb torig')); + solve_t torig' wl + end + | _ -> + solve_sub_probs env wl //fallback to trying to solve with SMT on + in + let d = decr_delta_depth <| delta_depth_of_term env head1 in + let treat_as_injective = + match (U.un_uinst head1).n with + | Tm_fvar fv -> + Env.fv_has_attr env fv PC.unifier_hint_injective_lid + | _ -> false + in + begin + match d with + | Some d when wl.smt_ok && not treat_as_injective -> + try_solve_without_smt_or_else wl + solve_sub_probs_no_smt + (unfold_and_retry d) + + | _ -> //cannot be unfolded or no smt anyway; so just try to solve extensionally + solve_sub_probs env wl + + end + + | _ -> + let lhs = force_refinement (base1, refinement1) in + let rhs = force_refinement (base2, refinement2) in + // + //AR: force_refinement already returns the term in + // whnf, so call solve_t' directly + // + solve_t' ({problem with lhs=lhs; rhs=rhs}) wl + end + in + + (* : + (match ?u with P1 -> t1 | ... | Pn -> tn) ~ t + + when (head t) `matches` (head ti) + solve ?u to Pi + and then try to prove `t ~ ti` + *) + let try_match_heuristic orig wl s1 s2 t1t2_opt = + let env = p_env wl orig in + let try_solve_branch scrutinee p = + let (Flex (_t, uv, _args), wl) = destruct_flex_t scrutinee wl in + // + // We add g_pat_as_exp implicits to the worklist later + // And we know it only contains implicits, no logical payload + // + let xs, pat_term, g_pat_as_exp, _ = PatternUtils.pat_as_exp true true env p in + let subst, wl = + List.fold_left (fun (subst, wl) x -> + let t_x = SS.subst subst x.sort in + let _, u, wl = copy_uvar uv [] t_x wl in + let subst = NT(x, u)::subst in + subst, wl) + ([], wl) + xs + in + let pat_term = SS.subst subst pat_term in + + // + // The pat term here contains uvars for dot patterns, and even bvs + // and their types + // We are going to unify the pat_term with the scrutinee, and that + // will solve some of those uvars + // But there are some uvars, e.g. for the dot pattern types, that will + // not get constrained even with those unifications + // + // To constrain such uvars, we typecheck the pat_term with the type of + // the scrutinee as the expected type + // This typechecking cannot use fastpath since the pat_term may be nested, + // and may have uvars in nested levels (Cons ?u (Cons ?u1 ...)), + // whereas fastpath may only compute the type from the top-level (list ?u here, e.g.) + // And so on + // + + let pat_term, g_pat_term = + let must_tot = false in + // + // Note that we cannot just use the uv.ctx_uvar_typ, + // since _args may be non-empty + // Also unrefine the scrutinee type + // + let scrutinee_t = + env.typeof_well_typed_tot_or_gtot_term env scrutinee must_tot + |> fst + |> N.normalize_refinement N.whnf_steps env + |> U.unrefine in + if !dbg_Rel + then BU.print1 "Match heuristic, typechecking the pattern term: %s {\n\n" + (show pat_term); + let pat_term, pat_term_t, g_pat_term = + env.typeof_tot_or_gtot_term + (Env.set_expected_typ env scrutinee_t) + pat_term + must_tot in + if !dbg_Rel + then BU.print2 "} Match heuristic, typechecked pattern term to %s and type %s\n" + (show pat_term) + (show pat_term_t); + pat_term, g_pat_term in + + // + // Enforce that the pattern typechecking guard has trivial logical payload + // + if g_pat_term |> simplify_guard env |> Env.is_trivial_guard_formula + then begin + let prob, wl = new_problem wl env scrutinee + EQ pat_term None scrutinee.pos + "match heuristic" + in + + let wl' = extend_wl ({wl with defer_ok=NoDefer; + smt_ok=false; + attempting=[TProb prob]; + wl_deferred=empty; + wl_implicits=Listlike.empty}) + g_pat_term.deferred + g_pat_term.deferred_to_tac + (Listlike.empty) in + let tx = UF.new_transaction () in + match solve wl' with + | Success (_, defer_to_tac, imps) -> + let wl' = {wl' with attempting=[orig]} in + (match solve wl' with + | Success (_, defer_to_tac', imps') -> + UF.commit tx; + Some (extend_wl wl + empty + (defer_to_tac ++ defer_to_tac') + (imps ++ imps' ++ g_pat_as_exp.implicits ++ g_pat_term.implicits)) + + | Failed _ -> + UF.rollback tx; + None) + | _ -> + UF.rollback tx; + None + end + else None + in + match t1t2_opt with + | None -> Inr None + | Some (t1, t2) -> + if !dbg_Rel + then BU.print2 "Trying match heuristic for %s vs. %s\n" + (show t1) + (show t2); + match (s1, U.unmeta t1), (s2, U.unmeta t2) with + | (_, {n=Tm_match {scrutinee; brs=branches}}), (s, t) + | (s, t), (_, {n=Tm_match {scrutinee; brs=branches}}) -> + if not (is_flex scrutinee) + then begin + if !dbg_Rel + then BU.print1 "match head %s is not a flex term\n" (show scrutinee); + Inr None + end + else if wl.defer_ok = DeferAny + then (if !dbg_Rel + then BU.print_string "Deferring ... \n"; + Inl "defer") + else begin + if !dbg_Rel + then BU.print2 "Heuristic applicable with scrutinee %s and other side = %s\n" + (show scrutinee) + (show t); + let pat_discriminates = function + | ({v=Pat_constant _}, None, _) + | ({v=Pat_cons _}, None, _) -> true + | _ -> false //other patterns do not discriminate + in + let head_matching_branch = + branches |> + BU.try_find + (fun b -> + if pat_discriminates b + then + let (_, _, t') = SS.open_branch b in + match head_matches_delta (p_env wl orig) (p_logical orig) wl.smt_ok s t' with + | FullMatch, _ + | HeadMatch _, _ -> + true + | _ -> false + else false) + in + begin + match head_matching_branch with + | None -> + if !dbg_Rel + then BU.print_string "No head_matching branch\n"; + let try_branches = + match BU.prefix_until (fun b -> not (pat_discriminates b)) branches with + | Some (branches, _, _) -> branches + | _ -> branches + in + Inr <| BU.find_map try_branches (fun b -> + let (p, _, _) = SS.open_branch b in + try_solve_branch scrutinee p) + + | Some b -> + let (p, _, e) = SS.open_branch b in + if !dbg_Rel + then BU.print2 "Found head matching branch %s -> %s\n" + (show p) + (show e); + Inr <| try_solve_branch scrutinee p + + end + end + | _ -> + if !dbg_Rel + then BU.print2 "Heuristic not applicable: tag lhs=%s, rhs=%s\n" + (tag_of t1) (tag_of t2); + Inr None + in + + (* : are t1 and t2, with head symbols head1 and head2, compatible after some delta steps? *) + let rigid_rigid_delta (torig:tprob) (wl:worklist) + (head1:term) (head2:term) (t1:term) (t2:term) + : solution = + let orig = TProb torig in + if !dbg_RelDelta then + BU.print4 "rigid_rigid_delta of %s-%s (%s, %s)\n" + (tag_of t1) + (tag_of t2) + (show t1) + (show t2); + let m, o = head_matches_delta (p_env wl orig) (p_logical orig) wl.smt_ok t1 t2 in + match m, o with + | (MisMatch _, _) -> //heads definitely do not match + let try_reveal_hide t1 t2 = + //tries to solve problems of the form + // 1. + // reveal ?u == y, where head y <> hide/reveal + // by generating hide (reveal ?u) == hide y + // and simplifying it to ?u == hide y + // + // 2. + // hide ?u == y, where head y <> hide/reveal + // by generating reveal (hide ?u) == reveal y + // and simplifying it to ?u == reveal y + // + let payload_of_hide_reveal h args : option (universe & typ & term) = + match h.n, args with + | Tm_uinst(_, [u]), [(ty, Some ({ aqual_implicit = true })); (t, _)] -> + Some (u, ty, t) + | _ -> None + in + let is_reveal_or_hide t = + let h, args = U.head_and_args t in + if U.is_fvar PC.reveal h + then match payload_of_hide_reveal h args with + | None -> None + | Some t -> Some (Reveal t) + else if U.is_fvar PC.hide h + then match payload_of_hide_reveal h args with + | None -> None + | Some t -> Some (Hide t) + else None + in + let mk_fv_app lid u args r = + let fv = Env.fvar_of_nonqual_lid wl.tcenv lid in + let head = S.mk_Tm_uinst fv [u] in + S.mk_Tm_app head args r + in + match is_reveal_or_hide t1, is_reveal_or_hide t2 with + (* We only apply these first two rules when the arg to reveal + is a flex, to avoid loops such as: + reveal t1 =?= t2 + ~> t1 =?= hide t2 + ~> reveal t1 =?= t2 + *) + | Some (Reveal (u, ty, lhs)), None when is_flex lhs -> + // reveal (?u _) / _ + //add hide to rhs and simplify lhs + let rhs = mk_fv_app PC.hide u [(ty, S.as_aqual_implicit true); (t2, None)] t2.pos in + Some (lhs, rhs) + + | None, Some (Reveal (u, ty, rhs)) when is_flex rhs -> + // _ / reveal (?u _) + //add hide to lhs and simplify rhs + let lhs = mk_fv_app PC.hide u [(ty, S.as_aqual_implicit true); (t1, None)] t1.pos in + Some (lhs, rhs) + + | Some (Hide (u, ty, lhs)), None -> + // hide _ / _ + //add reveal to rhs and simplify lhs + let rhs = mk_fv_app PC.reveal u [(ty,S.as_aqual_implicit true); (t2, None)] t2.pos in + Some (lhs, rhs) + + | None, Some (Hide (u, ty, rhs)) -> + // _ / hide _ + //add reveal to lhs and simplify rhs + let lhs = mk_fv_app PC.reveal u [(ty,S.as_aqual_implicit true); (t1, None)] t1.pos in + Some (lhs, rhs) + + | _ -> None + in + begin + match try_match_heuristic orig wl t1 t2 o with + | Inl _defer_ok -> + giveup_or_defer orig Deferred_delay_match_heuristic (Thunk.mkv "delaying match heuristic") + + | Inr (Some wl) -> + solve wl + + | Inr None -> + + match try_reveal_hide t1 t2 with + | Some (t1', t2') -> + solve_t ({problem with lhs=t1'; rhs=t2'}) wl + + | None -> + if (may_relate wl.tcenv problem.relation head1 + || may_relate wl.tcenv problem.relation head2) + && wl.smt_ok + then let guard, wl = guard_of_prob wl problem t1 t2 in + solve (solve_prob orig (Some guard) [] wl) + else giveup wl (mklstr (fun () -> BU.format4 "head mismatch (%s (%s) vs %s (%s))" + (show head1) + (show (delta_depth_of_term wl.tcenv head1)) + (show head2) + (show (delta_depth_of_term wl.tcenv head2)))) orig + end + + | (HeadMatch true, _) when problem.relation <> EQ -> + //heads may only match after unification; + //but we're not trying to unify them here + //so, treat as a mismatch + if wl.smt_ok + then let guard, wl = guard_of_prob wl problem t1 t2 in + solve (solve_prob orig (Some guard) [] wl) + else giveup wl (mklstr (fun () -> BU.format2 "head mismatch for subtyping (%s vs %s)" + (show t1) + (show t2))) + orig + + | (_, Some (t1, t2)) -> //heads match after some delta steps + solve_t ({problem with lhs=t1; rhs=t2}) wl + + (* Need to maybe reunify the heads *) + | (HeadMatch need_unif, None) -> + rigid_heads_match need_unif torig wl t1 t2 + + | (FullMatch, None) -> + rigid_heads_match false torig wl t1 t2 + in + (* *) + + let orig = TProb problem in + def_check_prob "solve_t'.2" orig; + if BU.physical_equality problem.lhs problem.rhs then solve (solve_prob orig None [] wl) else + let t1 = problem.lhs in + let t2 = problem.rhs in + def_check_scoped (p_loc orig) "ref.t1" (List.map (fun b -> b.binder_bv) (p_scope orig)) t1; + def_check_scoped (p_loc orig) "ref.t2" (List.map (fun b -> b.binder_bv) (p_scope orig)) t2; + let _ = + if !dbg_Rel + then BU.print5 "Attempting %s (%s vs %s); rel = (%s); number of problems in wl = %s\n" (string_of_int problem.pid) + (tag_of t1 ^ "::" ^ show t1) + (tag_of t2 ^ "::" ^ show t2) + (rel_to_string problem.relation) + (show (List.length wl.attempting)) + in + match t1.n, t2.n with + | Tm_delayed _, _ + | _, Tm_delayed _ -> + // Either case is impossible since we always call solve_t' after + // a call to compress_tprob, or directly after a call to unascribe, + // unmeta, etc. + failwith "Impossible: terms were not compressed" + + | Tm_ascribed _, _ -> + solve_t' ({problem with lhs=U.unascribe t1}) wl + + | Tm_meta _, _ -> + solve_t' ({problem with lhs=U.unmeta t1}) wl + + | _, Tm_ascribed _ -> + solve_t' ({problem with rhs=U.unascribe t2}) wl + + | _, Tm_meta _ -> + solve_t' ({problem with rhs=U.unmeta t2}) wl + + | Tm_quoted (t1, _), Tm_quoted (t2, _) -> + solve (solve_prob orig None [] wl) + + | Tm_bvar _, _ + | _, Tm_bvar _ -> failwith "Only locally nameless! We should never see a de Bruijn variable" + + | Tm_type u1, Tm_type u2 -> + solve_one_universe_eq orig u1 u2 wl + + | Tm_arrow {bs=bs1; comp=c1}, Tm_arrow {bs=bs2; comp=c2} -> + let mk_c c = function + | [] -> c + | bs -> mk_Total(mk (Tm_arrow {bs; comp=c}) c.pos) in + + let (bs1, c1), (bs2, c2) = + match_num_binders (bs1, mk_c c1) (bs2, mk_c c2) in + + solve_binders bs1 bs2 orig wl + (fun wl scope subst -> + let c1 = Subst.subst_comp subst c1 in + let c2 = Subst.subst_comp subst c2 in //open both comps + let rel = if (Options.use_eq_at_higher_order()) then EQ else problem.relation in + mk_c_problem wl scope orig c1 rel c2 None "function co-domain") + + | Tm_abs {bs=bs1; body=tbody1; rc_opt=lopt1}, + Tm_abs {bs=bs2; body=tbody2; rc_opt=lopt2} -> + let mk_t t l = function + | [] -> t + | bs -> mk (Tm_abs {bs; body=t; rc_opt=l}) t.pos in + let (bs1, tbody1), (bs2, tbody2) = + match_num_binders (bs1, mk_t tbody1 lopt1) (bs2, mk_t tbody2 lopt2) in + solve_binders bs1 bs2 orig wl + (fun wl scope subst -> + mk_t_problem wl scope orig (Subst.subst subst tbody1) + problem.relation + (Subst.subst subst tbody2) None "lambda co-domain") + + | Tm_refine {b=x1; phi=phi1}, Tm_refine {b=x2; phi=phi2} -> + (* If the heads of their bases can match, make it so, and continue *) + (* The unfolding is very much needed since we might have + * n:nat{phi n} =?= i:int{psi i} + * and if we try to unify the bases, nat and int, we're toast. + * However too much unfolding is also harmful for inference! See + * the discussion on #1345. Hence we reuse head_matches_delta to + * do the unfolding for us, which is good *heuristic* but not + * necessarily always correct. + *) + let env = p_env wl (TProb problem) in + let x1, x2 = + match head_matches_delta env false wl.smt_ok x1.sort x2.sort with + (* We allow (HeadMatch true) since we're gonna unify them again anyway via base_prob *) + | FullMatch, Some (t1, t2) + | HeadMatch _, Some (t1, t2) -> + ({ x1 with sort = t1 }), ({ x2 with sort = t2 }) + | _ -> x1, x2 + in + (* A bit hackish, reconstruct the refinements and flatten them with + as_refinement. *) + let t1 = S.mk (Tm_refine {b=x1; phi=phi1}) t1.pos in + let t2 = S.mk (Tm_refine {b=x2; phi=phi2}) t2.pos in + let x1, phi1 = as_refinement false env t1 in + let x2, phi2 = as_refinement false env t2 in + (* / hack *) + if !dbg_Rel then begin + BU.print3 "ref1 = (%s):(%s){%s}\n" (show x1) + (show x1.sort) + (show phi1); + BU.print3 "ref2 = (%s):(%s){%s}\n" (show x2) + (show x2.sort) + (show phi2) + end; + let base_prob, wl = mk_t_problem wl [] orig x1.sort problem.relation x2.sort problem.element "refinement base type" in + let x1 = freshen_bv x1 in + let subst = [DB(0, x1)] in + let phi1 = Subst.subst subst phi1 in + let phi2 = Subst.subst subst phi2 in + let mk_imp imp phi1 phi2 = imp phi1 phi2 |> guard_on_element wl problem x1 in + let fallback () = + let impl = + if problem.relation = EQ + then mk_imp U.mk_iff phi1 phi2 + else mk_imp U.mk_imp phi1 phi2 in + let guard = U.mk_conj (p_guard base_prob) impl in + def_check_scoped (p_loc orig) "ref.1" (List.map (fun b -> b.binder_bv) (p_scope orig)) (p_guard base_prob); + def_check_scoped (p_loc orig) "ref.2" (List.map (fun b -> b.binder_bv) (p_scope orig)) impl; + let wl = solve_prob orig (Some guard) [] wl in + solve (attempt [base_prob] wl) + in + let has_uvars = + not (Setlike.is_empty (FStarC.Syntax.Free.uvars phi1)) + || not (Setlike.is_empty (FStarC.Syntax.Free.uvars phi2)) + in + if problem.relation = EQ + || (not env.uvar_subtyping && has_uvars) + then let ref_prob, wl = + mk_t_problem wl [mk_binder x1] orig phi1 EQ phi2 None "refinement formula" + in + let ref_prob = set_logical true ref_prob in + + let tx = UF.new_transaction () in + (* We set wl_implicits to false, since in the success case we will + * extend the original wl with the extra implicits we get, and we + * do not want to duplicate the existing ones. *) + match solve ({wl with defer_ok=NoDefer; + wl_implicits=Listlike.empty; + attempting=[ref_prob]; + wl_deferred=empty}) with + | Failed (prob, msg) -> + UF.rollback tx; + if ((not env.uvar_subtyping && has_uvars) + || not wl.smt_ok) + && not env.unif_allow_ref_guards // if unif_allow_ref_guards is on, we don't give up + then giveup wl msg prob + else fallback() + + | Success (_, defer_to_tac, imps) -> + UF.commit tx; + let guard = + U.mk_conj (p_guard base_prob) + (p_guard ref_prob |> guard_on_element wl problem x1) in + let wl = solve_prob orig (Some guard) [] wl in + let wl = {wl with ctr=wl.ctr+1} in + let wl = extend_wl wl empty defer_to_tac imps in + solve (attempt [base_prob] wl) + else fallback() + + (* flex-flex *) + | Tm_uvar _, Tm_uvar _ + | Tm_app {hd={n=Tm_uvar _}}, Tm_uvar _ + | Tm_uvar _, Tm_app {hd={n=Tm_uvar _}} + | Tm_app {hd={n=Tm_uvar _}}, Tm_app {hd={n=Tm_uvar _}} -> + (* In the case that we have the same uvar on both sides, we cannot + * simply call destruct_flex_t on them, and instead we need to do + * both ensure_no_uvar_subst calls before destructing. + * + * Calling destruct_flex_t would (potentially) first solve the + * head uvar to a fresh one and then return the new one. So, if we + * we were calling destruct_flex_t directly, the second call will + * solve the uvar returned by the first call. We would then pass + * it to to solve_t_flex_flex, causing a crash. + * + * See issue #1616. *) + let env = p_env wl (TProb problem) in + let t1, wl = ensure_no_uvar_subst env t1 wl in + let t2 = U.canon_app t2 in + (* ^ This canon_app call is needed for the incredibly infrequent case + * where t2 is a Tm_app, its head uvar matches that of t1, + * *and* the uvar is solved to an application by the previous + * ensure_no_uvar_subst call. In that case, we get a nested application + * in t2, and the call below would raise an error. *) + let t2, wl = ensure_no_uvar_subst env t2 wl in + let f1 = destruct_flex_t' t1 in + let f2 = destruct_flex_t' t2 in + solve_t_flex_flex env orig wl f1 f2 + + (* flex-rigid equalities *) + | Tm_uvar _, _ + | Tm_app {hd={n=Tm_uvar _}}, _ when (problem.relation=EQ) -> (* just imitate/project ... no slack *) + let f1, wl = destruct_flex_t t1 wl in + solve_t_flex_rigid_eq orig wl f1 t2 + + (* rigid-flex: reorient if it is an equality constraint *) + | _, Tm_uvar _ + | _, Tm_app {hd={n=Tm_uvar _}} when (problem.relation = EQ) -> + solve_t' (invert problem) wl + + (* flex-rigid wrt an arrow: ?u _ <: t1 -> t2 *) + | Tm_uvar _, Tm_arrow _ + | Tm_app {hd={n=Tm_uvar _}}, Tm_arrow _ -> + //FIXME! This is weird; it should be handled by imitate_arrow + //this case is so common, that even though we could delay, it is almost always ok to solve it immediately as an equality + //besides, in the case of arrows, if we delay it, the arity of various terms built by the unifier goes awry + //so, don't delay! + solve_t' ({problem with relation=EQ}) wl + + | _, Tm_uvar _ + | _, Tm_app {hd={n=Tm_uvar _}} + | Tm_uvar _, _ + | Tm_app {hd={n=Tm_uvar _}}, _ -> + //flex-rigid subtyping is handled in the top-loop + solve (attempt [TProb problem] wl) + + | Tm_abs _, _ + | _, Tm_abs _ -> + let is_abs t = match t.n with + | Tm_abs _ -> Inl t + | _ -> Inr t in + begin + let env = p_env wl orig in + match is_abs t1, is_abs t2 with + | Inl t_abs, Inr not_abs + | Inr not_abs, Inl t_abs -> + if is_flex not_abs //if it's a pattern and the free var check succeeds, then unify it with the abstraction in one step + && p_rel orig = EQ + then let flex, wl = destruct_flex_t not_abs wl in + solve_t_flex_rigid_eq orig wl flex t_abs + else begin + match head_matches_delta env false wl.smt_ok not_abs t_abs with + | HeadMatch _, Some (not_abs', _) -> + solve_t ({problem with lhs=not_abs'; rhs=t_abs}) wl + + | _ -> + let head, _ = U.head_and_args not_abs in + if wl.smt_ok + && may_relate wl.tcenv (p_rel orig) head + then let g, wl = mk_eq2 wl orig t_abs not_abs in + solve (solve_prob orig (Some g) [] wl) + else giveup wl (Thunk.mkv "head tag mismatch: RHS is an abstraction") orig + end + + | _ -> failwith "Impossible: at least one side is an abstraction" + end + + | Tm_refine _, _ -> + let t2 = force_refinement <| base_and_refinement (p_env wl orig) t2 in + solve_t' ({problem with rhs=t2}) wl + + | _, Tm_refine _ -> + let t1 = force_refinement <| base_and_refinement (p_env wl orig) t1 in + solve_t' ({problem with lhs=t1}) wl + + | Tm_match {scrutinee=s1;brs=brs1}, Tm_match {scrutinee=s2;brs=brs2} -> //AR: note ignoring the return annotation + let by_smt () = + // using original WL + let guard, wl = guard_of_prob wl problem t1 t2 in + solve (solve_prob orig (Some guard) [] wl) + in + let rec solve_branches wl brs1 brs2 : option (list (binders & prob) & worklist) = + match brs1, brs2 with + | br1::rs1, br2::rs2 -> + let (p1, w1, _) = br1 in + let (p2, w2, _) = br2 in + (* If the patterns differ in shape, just fail *) + if not (eq_pat p1 p2) then None else + + (* Open the first branch, and use that same substitution for the second branch *) + let (p1, w1, e1), s = SS.open_branch' br1 in + let (p2, w2, e2) = br2 in + let w2 = BU.map_opt w2 (SS.subst s) in + let e2 = SS.subst s e2 in + + let scope = List.map S.mk_binder <| S.pat_bvs p1 in + + (* Subproblem for then `when` clause *) + BU.bind_opt ( + match w1, w2 with + | Some _, None + | None, Some _ -> None + | None, None -> Some ([], wl) + | Some w1, Some w2 -> + let p, wl = mk_t_problem wl scope orig w1 EQ w2 None "when clause" in + Some ([scope, p], wl)) + (fun (wprobs, wl) -> + + (* Branch body *) + // GM: Could use problem.relation here instead of EQ? + let prob, wl = mk_t_problem wl scope orig e1 EQ e2 None "branch body" in + if !dbg_Rel + then BU.print2 "Created problem for branches %s with scope %s\n" + (prob_to_string' wl prob) + (show scope); + BU.bind_opt (solve_branches wl rs1 rs2) (fun (r, wl) -> + Some ((scope, prob)::(wprobs @ r), wl))) + + | [], [] -> Some ([], wl) + | _ -> None + in + begin match solve_branches wl brs1 brs2 with + | None -> + if wl.smt_ok + then by_smt () + else giveup wl (Thunk.mkv "Tm_match branches don't match") orig + | Some (sub_probs, wl) -> + let sc_prob, wl = mk_t_problem wl [] orig s1 EQ s2 None "match scrutinee" in + let sub_probs = ([], sc_prob)::sub_probs in + let formula = U.mk_conj_l (List.map (fun (scope, p) -> close_forall (p_env wl orig) scope (p_guard p)) sub_probs) in + let tx = UF.new_transaction () in + let wl = solve_prob orig (Some formula) [] wl in + begin match solve (attempt (List.map snd sub_probs) ({wl with smt_ok = false})) with + | Success (ds, ds', imp) -> + UF.commit tx; + Success (ds, ds', imp) + | Failed _ -> + UF.rollback tx; + if wl.smt_ok + then by_smt () + else giveup wl (Thunk.mkv "Could not unify matches without SMT") orig + end + end + + | Tm_match _, _ + | Tm_uinst _, _ + | Tm_name _, _ + | Tm_constant _, _ + | Tm_fvar _, _ + | Tm_app _, _ + | _, Tm_match _ + | _, Tm_uinst _ + | _, Tm_name _ + | _, Tm_constant _ + | _, Tm_fvar _ + | _, Tm_app _ -> + let head1 = U.head_and_args t1 |> fst in + let head2 = U.head_and_args t2 |> fst in + let _ = + if !dbg_Rel + then BU.print ">> (%s) (smtok=%s)\n>>> head1 = %s [interpreted=%s; no_free_uvars=%s]\n>>> head2 = %s [interpreted=%s; no_free_uvars=%s]\n" + [(show problem.pid); + (show wl.smt_ok); + (show head1); + (show (Env.is_interpreted wl.tcenv head1)); + (show (no_free_uvars t1)); + (show head2); + (show (Env.is_interpreted wl.tcenv head2)); + (show (no_free_uvars t2))] + in + let equal t1 t2 : bool = + (* Try comparing the terms as they are. If we get Equal or NotEqual, + we are done. If we get an Unknown, attempt some normalization. *) + let env = p_env wl orig in + let r = TEQ.eq_tm env t1 t2 in + match r with + | TEQ.Equal -> true + | TEQ.NotEqual -> false + | TEQ.Unknown -> + let steps = [ + Env.UnfoldUntil delta_constant; + Env.Primops; + Env.Beta; + Env.Eager_unfolding; + Env.Iota ] in + let t1 = norm_with_steps "FStarC.TypeChecker.Rel.norm_with_steps.2" steps env t1 in + let t2 = norm_with_steps "FStarC.TypeChecker.Rel.norm_with_steps.3" steps env t2 in + TEQ.eq_tm env t1 t2 = TEQ.Equal + in + if (Env.is_interpreted wl.tcenv head1 || Env.is_interpreted wl.tcenv head2) //we have something like (+ x1 x2) =?= (- y1 y2) + && problem.relation = EQ + then ( + let solve_with_smt () = + let guard, wl = + if equal t1 t2 + then None, wl + else let g, wl = mk_eq2 wl orig t1 t2 in + Some g, wl + in + solve (solve_prob orig guard [] wl) + in + if no_free_uvars t1 // and neither term has any free variables + && no_free_uvars t2 + then + if not wl.smt_ok + || Options.ml_ish () + then if equal t1 t2 + then solve (solve_prob orig None [] wl) + else rigid_rigid_delta problem wl head1 head2 t1 t2 + else solve_with_smt() + else if not wl.smt_ok + || Options.ml_ish() + then rigid_rigid_delta problem wl head1 head2 t1 t2 + else ( + try_solve_then_or_else + wl + (*try*) + (fun wl_empty -> rigid_rigid_delta problem wl_empty head1 head2 t1 t2) + (*then*) + (fun wl -> solve wl) + (*else*) + (fun _ -> solve_with_smt()) + ) + ) + else ( + rigid_rigid_delta problem wl head1 head2 t1 t2 + ) + + + | Tm_let _, Tm_let _ -> + // For now, just unify if they syntactically match + if U.term_eq t1 t2 + then solve (solve_prob orig None [] wl) + else giveup wl (Thunk.mkv "Tm_let mismatch") orig + + | Tm_let _, _ + | _, Tm_let _ -> + raise_error t1 Errors.Fatal_UnificationNotWellFormed + (BU.format4 "Internal error: unexpected flex-flex of %s and %s\n>>> (%s) -- (%s)" + (tag_of t1) (tag_of t2) (show t1) (show t2)) + + | Tm_lazy li1, Tm_lazy li2 when li1.lkind =? li2.lkind + && lazy_complete_repr li1.lkind -> + solve_t' ({problem with lhs = U.unfold_lazy li1; rhs = U.unfold_lazy li2}) wl + + | _ -> giveup wl (Thunk.mk (fun () -> "head tag mismatch: " ^ tag_of t1 ^ " vs " ^ tag_of t2)) orig + +and solve_c (problem:problem comp) (wl:worklist) : solution = + let c1 = problem.lhs in + let c2 = problem.rhs in + let orig = CProb problem in + let env = p_env wl orig in + let sub_prob : worklist -> term -> rel -> term -> string -> prob & worklist = + fun wl t1 rel t2 reason -> mk_t_problem wl [] orig t1 rel t2 None reason in + + let solve_eq c1_comp c2_comp g_lift = + let _ = if !dbg_EQ + then BU.print2 "solve_c is using an equality constraint (%s vs %s)\n" + (show (mk_Comp c1_comp)) + (show (mk_Comp c2_comp)) in + if not (lid_equals c1_comp.effect_name c2_comp.effect_name) + then giveup wl (mklstr (fun () -> BU.format2 "incompatible effects: %s <> %s" + (show c1_comp.effect_name) + (show c2_comp.effect_name))) orig + else if List.length c1_comp.effect_args <> List.length c2_comp.effect_args + then giveup wl (mklstr (fun () -> BU.format2 "incompatible effect arguments: %s <> %s" + (show c1_comp.effect_args) + (show c2_comp.effect_args))) orig + else + let univ_sub_probs, wl = + List.fold_left2 (fun (univ_sub_probs, wl) u1 u2 -> + let p, wl = sub_prob wl + (S.mk (S.Tm_type u1) Range.dummyRange) + EQ + (S.mk (S.Tm_type u2) Range.dummyRange) + "effect universes" in + (univ_sub_probs ++ cons p empty), wl) (empty, wl) c1_comp.comp_univs c2_comp.comp_univs in + let ret_sub_prob, wl = sub_prob wl c1_comp.result_typ EQ c2_comp.result_typ "effect ret type" in + let arg_sub_probs, wl = + List.fold_right2 + (fun (a1, _) (a2, _) (arg_sub_probs, wl) -> + let p, wl = sub_prob wl a1 EQ a2 "effect arg" in + cons p arg_sub_probs, wl) + c1_comp.effect_args + c2_comp.effect_args + (empty, wl) + in + let sub_probs : clist _ = + univ_sub_probs ++ + (cons ret_sub_prob <| + arg_sub_probs ++ + (g_lift.deferred |> CList.map (fun (_, _, p) -> p))) + in + let sub_probs : list _ = to_list sub_probs in + let guard = + let guard = U.mk_conj_l (List.map p_guard sub_probs) in + match g_lift.guard_f with + | Trivial -> guard + | NonTrivial f -> U.mk_conj guard f in + let wl = { wl with wl_implicits = g_lift.implicits ++ wl.wl_implicits } in + let wl = solve_prob orig (Some guard) [] wl in + solve (attempt sub_probs wl) + in + + let should_fail_since_repr_subcomp_not_allowed + (repr_subcomp_allowed:bool) + (c1 c2:lid) : bool + = let c1, c2 = Env.norm_eff_name wl.tcenv c1, Env.norm_eff_name wl.tcenv c2 in + not wl.repr_subcomp_allowed + && not (lid_equals c1 c2) + && Env.is_reifiable_effect wl.tcenv c2 in + // GM: What I would like to write instead of these two + // last conjuncts is something like + // [Option.isSome edge.mlift.mlift_term], + // but it seems that we always carry around a Some + // (fun _ _ e -> e) instead of a None even for + // primitive effects. + + let solve_layered_sub c1 c2 = + if !dbg_LayeredEffectsApp then + BU.print2 "solve_layered_sub c1: %s and c2: %s {\n" + (c1 |> S.mk_Comp |> show) + (c2 |> S.mk_Comp |> show); + + if problem.relation = EQ + then solve_eq c1 c2 Env.trivial_guard + else + let r = Env.get_range wl.tcenv in + + if should_fail_since_repr_subcomp_not_allowed + wl.repr_subcomp_allowed + c1.effect_name + c2.effect_name + then giveup wl (mklstr (fun () -> BU.format2 "Cannot lift from %s to %s, it needs a lift\n" + (string_of_lid c1.effect_name) + (string_of_lid c2.effect_name))) + orig + else + let subcomp_name = BU.format2 "%s <: %s" + (c1.effect_name |> Ident.ident_of_lid |> Ident.string_of_id) + (c2.effect_name |> Ident.ident_of_lid |> Ident.string_of_id) in + + let lift_c1 (edge:edge) : comp_typ & guard_t = + c1 |> S.mk_Comp |> edge.mlift.mlift_wp env + |> (fun (c, g) -> Env.comp_to_comp_typ env c, g) in + + let c1, g_lift, stronger_t_opt, kind, num_eff_params, is_polymonadic = + match Env.exists_polymonadic_subcomp env c1.effect_name c2.effect_name with + | None -> + // there is no polymonadic bind c1 <: c2 + // see if c1 can be lifted to c2 + (match Env.monad_leq env c1.effect_name c2.effect_name with + | None -> + // c1 cannot be lifted to c2, fail + // (sets stronger_t_opt to None) + // + c1, Env.trivial_guard, None, Ad_hoc_combinator, 0, false + | Some edge -> + // there is a way to lift c1 to c2 via edge + let c1, g_lift = lift_c1 edge in + let ed2 = c2.effect_name |> Env.get_effect_decl env in + let tsopt, k = ed2 + |> U.get_stronger_vc_combinator + |> (fun (ts, kopt) -> Env.inst_tscheme_with ts c2.comp_univs |> snd |> Some, kopt |> must) in + let num_eff_params = + match ed2.signature with + | Layered_eff_sig (n, _) -> n + | _ -> failwith "Impossible (expected indexed effect subcomp)" in + c1, g_lift, tsopt, k, num_eff_params, false) + | Some (t, kind) -> + c1, Env.trivial_guard, + Env.inst_tscheme_with t c2.comp_univs |> snd |> Some, + kind, + 0, + true in + + if is_none stronger_t_opt + then giveup wl (mklstr (fun () -> BU.format2 "incompatible monad ordering: %s must in + // we will account for g_lift logical guard later + let wl = extend_wl wl g_lift.deferred g_lift.deferred_to_tac g_lift.implicits in + + if is_polymonadic && + Env.is_erasable_effect env c1.effect_name && + not (Env.is_erasable_effect env c2.effect_name) && + not (N.non_info_norm env c1.result_typ) + then Errors.raise_error r Errors.Error_TypeError + (BU.format3 "Cannot lift erasable expression from %s ~> %s since its type %s is informative" + (string_of_lid c1.effect_name) + (string_of_lid c2.effect_name) + (show c1.result_typ)); + + (* + * AR: 04/08: Suppose we have a subcomp problem of the form: + * M a ?u <: M a wp or M a wp <: M a ?u + * + * If we simply applied the stronger (subcomp) combinator, + * there is a chance that the uvar would escape into the + * refinements/wp and remain unresolved + * + * So, if this is the case (i.e. an effect index on one side is a uvar) + * we solve this particular index with equality ?u = wp + * + * There are two exceptions: + * If it is a polymonadic subcomp (the indices may not be symmetric) + * If uvar is to be solved using a user-defined tactic + * + * TODO: apply this equality heuristic to non-layered effects also + *) + + //sub problems for uvar indices in c1 + let is_sub_probs, wl = + if is_polymonadic then [], wl + else + let rec is_uvar t = //t is a uvar that is not to be solved by a user tactic + match (SS.compress t).n with + | Tm_uvar (uv, _) -> + not (DeferredImplicits.should_defer_uvar_to_user_tac env uv) + | Tm_uinst (t, _) -> is_uvar t + | Tm_app {hd=t} -> is_uvar t + | _ -> false in + List.fold_right2 (fun (a1, _) (a2, _) (is_sub_probs, wl) -> + if is_uvar a1 + then begin + if !dbg_LayeredEffectsEqns then + BU.print2 "Layered Effects teq (rel c1 index uvar) %s = %s\n" + (show a1) (show a2); + let p, wl = sub_prob wl a1 EQ a2 "l.h.s. effect index uvar" in + p::is_sub_probs, wl + end + else is_sub_probs, wl + ) c1.effect_args c2.effect_args ([], wl) in + + //return type sub problem + let ret_sub_prob, wl = sub_prob wl c1.result_typ problem.relation c2.result_typ "result type" in + + let bs, subcomp_c = U.arrow_formals_comp stronger_t in + + let fml, sub_probs, wl = + if kind = Ad_hoc_combinator + then apply_ad_hoc_indexed_subcomp env bs subcomp_c c1 c2 sub_prob wl subcomp_name r + else apply_substitutive_indexed_subcomp env kind bs subcomp_c c1 c2 sub_prob + num_eff_params + wl + subcomp_name r in + + let sub_probs = ret_sub_prob::(is_sub_probs@sub_probs) in + + let guard = + let guard = U.mk_conj_l (List.map p_guard sub_probs) in + let guard = + match g_lift.guard_f with + | Trivial -> guard + | NonTrivial f -> U.mk_conj guard f in + U.mk_conj guard fml in + + let wl = solve_prob orig (Some guard) [] wl in + if !dbg_LayeredEffectsApp + then BU.print_string "}\n"; + solve (attempt sub_probs wl) in + + let solve_sub c1 edge c2 = + if problem.relation <> SUB then + failwith "impossible: solve_sub"; + let r = Env.get_range env in + let lift_c1 () = + let univs = + match c1.comp_univs with + | [] -> [env.universe_of env c1.result_typ] + | x -> x in + let c1 = { c1 with comp_univs = univs } in + ({ c1 with comp_univs = univs }) + |> S.mk_Comp + |> edge.mlift.mlift_wp env + |> (fun (c, g) -> + if not (Env.is_trivial g) + then raise_error r Errors.Fatal_UnexpectedEffect + (BU.format2 "Lift between wp-effects (%s~>%s) should not have returned a non-trivial guard" + (show c1.effect_name) (show c2.effect_name)) + else Env.comp_to_comp_typ env c) + in + if should_fail_since_repr_subcomp_not_allowed + wl.repr_subcomp_allowed + c1.effect_name + c2.effect_name + then giveup wl (mklstr (fun () -> BU.format2 "Cannot lift from %s to %s, it needs a lift\n" + (string_of_lid c1.effect_name) + (string_of_lid c2.effect_name))) + orig + else let is_null_wp_2 = c2.flags |> BU.for_some (function TOTAL | MLEFFECT | SOMETRIVIAL -> true | _ -> false) in + let wpc1, wpc2 = match c1.effect_args, c2.effect_args with + | (wp1, _)::_, (wp2, _)::_ -> wp1, wp2 + | _ -> + raise_error env Errors.Fatal_ExpectNormalizedEffect + (BU.format2 "Got effects %s and %s, expected normalized effects" (show c1.effect_name) (show c2.effect_name)) + in + + if BU.physical_equality wpc1 wpc2 + then solve_t (problem_using_guard orig c1.result_typ problem.relation c2.result_typ None "result type") wl + else let c2_decl, qualifiers = must (Env.effect_decl_opt env c2.effect_name) in + if qualifiers |> List.contains Reifiable + then let c1_repr = + norm_with_steps "FStarC.TypeChecker.Rel.norm_with_steps.4" + [Env.UnfoldUntil delta_constant; Env.Weak; Env.HNF] env + (Env.reify_comp env (S.mk_Comp (lift_c1 ())) (env.universe_of env c1.result_typ)) + in + let c2_repr = + norm_with_steps "FStarC.TypeChecker.Rel.norm_with_steps.5" + [Env.UnfoldUntil delta_constant; Env.Weak; Env.HNF] env + (Env.reify_comp env (S.mk_Comp c2) (env.universe_of env c2.result_typ)) + in + let prob, wl = + sub_prob wl c1_repr problem.relation c2_repr + (BU.format2 "sub effect repr: %s <: %s" + (show c1_repr) + (show c2_repr)) + in + let wl = solve_prob orig (Some (p_guard prob)) [] wl in + solve (attempt [prob] wl) + else + let g = + if Options.lax () then + U.t_true + else let wpc1_2 = lift_c1 () |> (fun ct -> List.hd ct.effect_args) in + if is_null_wp_2 + then let _ = if !dbg_Rel + then BU.print_string "Using trivial wp ... \n" in + let c1_univ = env.universe_of env c1.result_typ in + let trivial = + match c2_decl |> U.get_wp_trivial_combinator with + | None -> failwith "Rel doesn't yet handle undefined trivial combinator in an effect" + | Some t -> t in + mk (Tm_app {hd=inst_effect_fun_with [c1_univ] env c2_decl trivial; + args=[as_arg c1.result_typ; wpc1_2]}) r + else let c2_univ = env.universe_of env c2.result_typ in + let stronger = c2_decl |> U.get_stronger_vc_combinator |> fst in + mk (Tm_app {hd=inst_effect_fun_with [c2_univ] env c2_decl stronger; + args=[as_arg c2.result_typ; as_arg wpc2; wpc1_2]}) r in + if !dbg_Rel then + BU.print1 "WP guard (simplifed) is (%s)\n" (show (N.normalize [Env.Iota; Env.Eager_unfolding; Env.Primops; Env.Simplify] env g)); + let base_prob, wl = sub_prob wl c1.result_typ problem.relation c2.result_typ "result type" in + let wl = solve_prob orig (Some <| U.mk_conj (p_guard base_prob) g) [] wl in + solve (attempt [base_prob] wl) + in + + if BU.physical_equality c1 c2 + then solve (solve_prob orig None [] wl) + else let _ = if !dbg_Rel + then BU.print3 "solve_c %s %s %s\n" + (show c1) + (rel_to_string problem.relation) + (show c2) in + + //AR: 10/18: try ghost to pure promotion only if effects are different + + let c1, c2 = + let eff1, eff2 = + c1 |> U.comp_effect_name |> Env.norm_eff_name env, + c2 |> U.comp_effect_name |> Env.norm_eff_name env in + if Ident.lid_equals eff1 eff2 + then c1, c2 + else N.ghost_to_pure2 env (c1, c2) in + + match c1.n, c2.n with + | GTotal t1, Total t2 when (Env.non_informative env t2) -> + solve_t (problem_using_guard orig t1 problem.relation t2 None "result type") wl + + | GTotal _, Total _ -> + giveup wl (Thunk.mkv "incompatible monad ordering: GTot //rigid-rigid 1 + solve_t (problem_using_guard orig t1 problem.relation t2 None "result type") wl + + | Total t1, GTotal t2 when problem.relation = SUB -> + solve_t (problem_using_guard orig t1 problem.relation t2 None "result type") wl + + | Total t1, GTotal t2 -> + giveup wl (Thunk.mkv "GTot =/= Tot") orig + + | GTotal _, Comp _ + | Total _, Comp _ -> + solve_c ({problem with lhs=mk_Comp <| Env.comp_to_comp_typ env c1}) wl + + | Comp _, GTotal _ + | Comp _, Total _ -> + solve_c ({problem with rhs=mk_Comp <| Env.comp_to_comp_typ env c2}) wl + + | Comp _, Comp _ -> + if (U.is_ml_comp c1 && U.is_ml_comp c2) + || (U.is_total_comp c1 && U.is_total_comp c2) + || (U.is_total_comp c1 && U.is_ml_comp c2 && problem.relation=SUB) + then solve_t (problem_using_guard orig (U.comp_result c1) problem.relation (U.comp_result c2) None "result type") wl + else let c1_comp = Env.comp_to_comp_typ env c1 in + let c2_comp = Env.comp_to_comp_typ env c2 in + if problem.relation=EQ + then let c1_comp, c2_comp = + if lid_equals c1_comp.effect_name c2_comp.effect_name + then c1_comp, c2_comp + else Env.unfold_effect_abbrev env c1, + Env.unfold_effect_abbrev env c2 in + solve_eq c1_comp c2_comp Env.trivial_guard + else begin + let c1 = Env.unfold_effect_abbrev env c1 in + let c2 = Env.unfold_effect_abbrev env c2 in + if !dbg_Rel then BU.print2 "solve_c for %s and %s\n" (string_of_lid c1.effect_name) (string_of_lid c2.effect_name); + if Env.is_layered_effect env c2.effect_name then solve_layered_sub c1 c2 + else + match Env.monad_leq env c1.effect_name c2.effect_name with + | None -> + giveup wl (mklstr (fun () -> BU.format2 "incompatible monad ordering: %s + solve_sub c1 edge c2 + end + +(* -------------------------------------------------------- *) +(* top-level interface *) +(* -------------------------------------------------------- *) +let print_pending_implicits g = + g.implicits |> CList.map (fun i -> show i.imp_uvar) |> show + +let ineqs_to_string (ineqs : clist universe & clist (universe & universe)) = + let (vars, ineqs) = ineqs in + let ineqs = ineqs |> CList.map (fun (u1, u2) -> BU.format2 "%s < %s" (show u1) (show u2)) in + BU.format2 "Solving for %s; inequalities are %s" + (show vars) (show ineqs) + +let guard_to_string (env:env) g = + match g.guard_f, view g.deferred with + | Trivial, VNil when not (Options.print_implicits ()) && is_empty (snd g.univ_ineqs) -> "{}" + | _ -> + let form = match g.guard_f with + | Trivial -> "trivial" + | NonTrivial f -> + if !dbg_Rel + || Debug.extreme () + || Options.print_implicits () + then N.term_to_string env f + else "non-trivial" + in + let carry defs = CList.map (fun (_, msg, x) -> msg ^ ": " ^ prob_to_string env x) defs |> to_list |> String.concat ",\n" in + let imps = print_pending_implicits g in + BU.format5 "\n\t{guard_f=%s;\n\t deferred={\n%s};\n\t deferred_to_tac={\n%s};\n\t univ_ineqs={%s};\n\t implicits=%s}\n" + form (carry g.deferred) (carry g.deferred_to_tac) + (ineqs_to_string g.univ_ineqs) imps + +let new_t_problem wl env lhs rel rhs elt loc = + let reason = if !dbg_ExplainRel + || !dbg_Rel + then BU.format3 "Top-level:\n%s\n\t%s\n%s" + (N.term_to_string env lhs) (rel_to_string rel) + (N.term_to_string env rhs) + else "TOP" in + let p, wl = new_problem wl env lhs rel rhs elt loc reason in + def_check_prob ("new_t_problem." ^ reason) (TProb p); + TProb p, wl + +let new_t_prob wl env t1 rel t2 = + let x = S.new_bv (Some <| Env.get_range env) t1 in + let p, wl = new_t_problem wl env t1 rel t2 (Some x) (Env.get_range env) in + p, x, wl + +let solve_and_commit wl err + : option (deferred & deferred & implicits_t) = + let tx = UF.new_transaction () in + + if !dbg_RelBench then + BU.print1 "solving problems %s {\n" + (FStarC.Common.string_of_list (fun p -> string_of_int (p_pid p)) wl.attempting); + let (sol, ms) = BU.record_time (fun () -> solve wl) in + if !dbg_RelBench then + BU.print1 "} solved in %s ms\n" (string_of_int ms); + + match sol with + | Success (deferred, defer_to_tac, implicits) -> + let ((), ms) = BU.record_time (fun () -> UF.commit tx) in + if !dbg_RelBench then + BU.print1 "committed in %s ms\n" (string_of_int ms); + Some (deferred, defer_to_tac, implicits) + | Failed (d,s) -> + if !dbg_ExplainRel + || !dbg_Rel + then BU.print_string <| explain wl d s; + let result = err (d,s) in + UF.rollback tx; + result + +let with_guard env prob dopt = + match dopt with + | None -> None + | Some (deferred, defer_to_tac, implicits) -> + def_check_scoped (p_loc prob) "with_guard" env (p_guard prob); + Some <| simplify_guard env + ({guard_f=(p_guard prob |> NonTrivial); + deferred=deferred; + deferred_to_tac=defer_to_tac; + univ_ineqs=(empty, empty); + implicits=implicits}) + +let try_teq smt_ok env t1 t2 : option guard_t = + def_check_scoped t1.pos "try_teq.1" env t1; + def_check_scoped t2.pos "try_teq.2" env t2; + // --MLish disables use of SMT. See PR #3123 for explanation. + let smt_ok = smt_ok && not (Options.ml_ish ()) in + Profiling.profile + (fun () -> + if !dbg_RelTop then + BU.print3 "try_teq of %s and %s in %s {\n" (show t1) (show t2) (show env.gamma); + let prob, wl = new_t_problem (empty_worklist env) env t1 EQ t2 None (Env.get_range env) in + let g = with_guard env prob <| solve_and_commit (singleton wl prob smt_ok) (fun _ -> None) in + if !dbg_RelTop then + BU.print1 "} res = %s\n" (FStarC.Common.string_of_option (guard_to_string env) g); + g) + (Some (Ident.string_of_lid (Env.current_module env))) + "FStarC.TypeChecker.Rel.try_teq" + + +let teq env t1 t2 : guard_t = + match try_teq true env t1 t2 with + | None -> + Err.basic_type_error env env.range None t2 t1; + trivial_guard + | Some g -> + if !dbg_Rel || !dbg_RelTop then + BU.print3 "teq of %s and %s succeeded with guard %s\n" + (show t1) (show t2) (guard_to_string env g); + g + +(* + * AR: It would be nice to unify it with teq, the way we do it for subtyping + * i.e. write a common function that uses a bound variable, + * and if the caller requires a prop, close over it, else abstract it + * But that may change the existing VCs shape a bit + *) +let get_teq_predicate env t1 t2 = + if !dbg_Rel || !dbg_RelTop then + BU.print2 "get_teq_predicate of %s and %s {\n" (show t1) (show t2); + let prob, x, wl = new_t_prob (empty_worklist env) env t1 EQ t2 in + let g = with_guard env prob <| solve_and_commit (singleton wl prob true) (fun _ -> None) in + if !dbg_Rel || !dbg_RelTop then + BU.print1 "} res teq predicate = %s\n" (FStarC.Common.string_of_option (guard_to_string env) g); + + match g with + | None -> None + | Some g -> Some (abstract_guard (S.mk_binder x) g) + +let subtype_fail env e t1 t2 : unit = + Err.basic_type_error env (Env.get_range env) (Some e) t2 t1 + +let sub_or_eq_comp env (use_eq:bool) c1 c2 = + Profiling.profile (fun () -> + let rel = if use_eq then EQ else SUB in + if !dbg_Rel || !dbg_RelTop then + BU.print3 "sub_comp of %s --and-- %s --with-- %s\n" (show c1) (show c2) (if rel = EQ then "EQ" else "SUB"); + let prob, wl = new_problem (empty_worklist env) env c1 rel c2 None (Env.get_range env) "sub_comp" in + let wl = { wl with repr_subcomp_allowed = true } in + let prob = CProb prob in + def_check_prob "sub_comp" prob; + let (r, ms) = BU.record_time + (fun () -> with_guard env prob <| solve_and_commit (singleton wl prob true) (fun _ -> None)) + in + if !dbg_Rel || !dbg_RelTop || !dbg_RelBench then + BU.print4 "sub_comp of %s --and-- %s --with-- %s --- solved in %s ms\n" (show c1) (show c2) (if rel = EQ then "EQ" else "SUB") (string_of_int ms); + r) + (Some (Ident.string_of_lid (Env.current_module env))) + "FStarC.TypeChecker.Rel.sub_comp" + +let sub_comp env c1 c2 = + Errors.with_ctx "While trying to subtype computation types" (fun () -> + def_check_scoped c1.pos "sub_comp c1" env c1; + def_check_scoped c2.pos "sub_comp c2" env c2; + sub_or_eq_comp env false c1 c2 + ) + +let eq_comp env c1 c2 = + Errors.with_ctx "While trying to equate computation types" (fun () -> + def_check_scoped c1.pos "eq_comp c1" env c1; + def_check_scoped c2.pos "eq_comp c2" env c2; + sub_or_eq_comp env true c1 c2 + ) + +val solve_universe_inequalities' (tx:UF.tx) (env : env_t) (vs_ineqs : clist S.universe & clist (S.universe & S.universe)) : unit +let solve_universe_inequalities' tx env (variables, ineqs) : unit = + //variables: ?u1, ..., ?un are the universes of the inductive types we're trying to compute + //ineqs: u1 < v1, ..., un < vn are inequality constraints gathered from checking the inductive definition + //The basic idea is to collect all lowerbounds of each variable ?ui, + // excluding all of the variables themselves to avoid cycles + // and setting each ?ui to max(lowerbounds(?ui)) + //Then, we make a pass over all the inequalities again and check that they are all satisfied + //This ensures, e.g., that we don't needlessly generalize types, avoid issues lik #806 + let fail u1 u2 = + UF.rollback tx; + raise_error env Errors.Fatal_IncompatibleUniverse + (BU.format2 "Universe %s and %s are incompatible" (show u1) (show u2)) + in + let equiv v v' = + match SS.compress_univ v, SS.compress_univ v' with + | U_unif v0, U_unif v0' -> UF.univ_equiv v0 v0' + | _ -> false + in + let sols : clist (S.universe & S.universe) = variables |> CList.collect (fun v -> + match SS.compress_univ v with + | U_unif _ -> //if it really is a variable, that try to solve it + let lower_bounds_of_v : clist S.universe = //lower bounds of v, excluding the other variables + ineqs |> CList.collect (fun (u, v') -> + if equiv v v' + then if variables |> CList.existsb (equiv u) + then empty + else cons u empty + else empty) + in + let lb = N.normalize_universe env (U_max (lower_bounds_of_v |> to_list)) in + Listlike.singleton (lb, v) + | _ -> + //it may not actually be a variable in case the user provided an explicit universe annnotation + //see, e.g., ulib/FStar.Universe.fst + empty) in + //apply all the solutions + let _ = + let wl = {empty_worklist env with defer_ok=NoDefer} in + sols |> CList.map (fun (lb, v) -> + // printfn "Setting %s to its lower bound %s" (show v) (show lb); + match solve_universe_eq (-1) wl lb v with + | USolved wl -> () + | _ -> fail lb v) + in + //check that the solutions produced valid inequalities + let rec check_ineq (u, v) : bool = + let u = N.normalize_universe env u in + let v = N.normalize_universe env v in + match u, v with + | U_zero, _ -> true + | U_succ u0, U_succ v0 -> check_ineq (u0, v0) + | U_name u0, U_name v0 -> Ident.ident_equals u0 v0 + | U_unif u0, U_unif v0 -> UF.univ_equiv u0 v0 + | U_name _, U_succ v0 + | U_unif _, U_succ v0 -> check_ineq (u, v0) + | U_max us, _ -> us |> BU.for_all (fun u -> check_ineq (u, v)) + | _, U_max vs -> vs |> BU.for_some (fun v -> check_ineq (u, v)) + | _ -> false + in + if ineqs |> CList.for_all (fun (u, v) -> + if check_ineq (u, v) + then true + else (if !dbg_GenUniverses + then BU.print2 "%s + Profiling.profile (fun () -> + let imps_l = g.implicits |> Listlike.to_list in + let typeclass_variables = + imps_l + |> List.collect + (fun i -> + match i.imp_uvar.ctx_uvar_meta with + | Some (Ctx_uvar_meta_tac tac) -> + let head, _ = U.head_and_args_full tac in + if U.is_fvar PC.tcresolve_lid head + then ( + let goal_type = U.ctx_uvar_typ i.imp_uvar in + let uvs = Free.uvars goal_type in + elems uvs + ) + else [] + | _ -> []) |> Setlike.from_list + in + let wl = { wl_of_guard env (to_list g.deferred) + with defer_ok=defer_ok + ; smt_ok=smt_ok + ; typeclass_variables } in + let fail (d,s) = + let msg = explain wl d s in + raise_error (p_loc d) Errors.Fatal_ErrorInSolveDeferredConstraints msg + in + if !dbg_Rel then + BU.print4 "Trying to solve carried problems (defer_ok=%s) (deferred_to_tac_ok=%s): begin\n\t%s\nend\n and %s implicits\n" + (show defer_ok) + (show deferred_to_tac_ok) + (show wl) + (show (List.length imps_l)); + let g = + match solve_and_commit wl fail with + | Some (deferred, _, _) when VCons? (view deferred) && defer_ok = NoDefer -> + failwith "Impossible: Unexpected deferred constraints remain" + + | Some (deferred, defer_to_tac, imps) -> + {g with deferred=deferred; + deferred_to_tac=g.deferred_to_tac ++ defer_to_tac; + implicits = g.implicits ++ imps} + + | _ -> + failwith "Impossible: should have raised a failure already" + in + solve_universe_inequalities env g.univ_ineqs; + let g = + if deferred_to_tac_ok + then Profiling.profile (fun () -> DeferredImplicits.solve_deferred_to_tactic_goals env g) + (Some (Ident.string_of_lid (Env.current_module env))) + "FStarC.TypeChecker.Rel.solve_deferred_to_tactic_goals" + else g + in + if !dbg_ResolveImplicitsHook + then BU.print2 "ResolveImplicitsHook: Solved deferred to tactic goals, remaining guard is\n%s (and %s implicits)\n" + (guard_to_string env g) + (show (List.length (Listlike.to_list g.implicits))); + {g with univ_ineqs=(empty, empty)} + ) + (Some (Ident.string_of_lid (Env.current_module env))) + "FStarC.TypeChecker.Rel.try_solve_deferred_constraints") + + +let solve_deferred_constraints env (g:guard_t) = + let defer_ok = NoDefer in + let smt_ok = not (Options.ml_ish ()) in + let deferred_to_tac_ok = true in + try_solve_deferred_constraints defer_ok smt_ok deferred_to_tac_ok env g + +let solve_non_tactic_deferred_constraints maybe_defer_flex_flex env (g:guard_t) = + Errors.with_ctx "solve_non_tactic_deferred_constraints" (fun () -> + def_check_scoped Range.dummyRange "solve_non_tactic_deferred_constraints.g" env g; + let defer_ok = if maybe_defer_flex_flex then DeferFlexFlexOnly else NoDefer in + let smt_ok = not (Options.ml_ish ()) in + let deferred_to_tac_ok = false in + try_solve_deferred_constraints defer_ok smt_ok deferred_to_tac_ok env g + ) + +let do_discharge_vc use_env_range_msg env vc : unit = + let open FStarC.Pprint in + let open FStarC.Errors.Msg in + let open FStarC.Class.PP in + let debug : bool = !dbg_Rel || !dbg_SMTQuery || !dbg_Discharge in + let diag = Errors.diag (Env.get_range env) #(list document) in // FIXME: without the implicit, batch mode fails during generalization + if debug then + diag [text "Checking VC:" ^/^ pp vc]; + + (* Tactic preprocessing *) + let vcs : list (env_t & typ & Options.optionstate) = ( + if Options.use_tactics() then begin + Options.with_saved_options (fun () -> + ignore <| Options.set_options "--no_tactics"; + let did_anything, vcs = env.solver.preprocess env vc in + if debug && did_anything then + diag [text "Tactic preprocessing produced" ^/^ pp (List.length vcs <: int) ^/^ text "goals"]; + let vcs = vcs |> List.map (fun (env, goal, opts) -> + // NB: No Eager_unfolding. Why? + env, + norm_with_steps "FStarC.TypeChecker.Rel.norm_with_steps.7" + [Env.Simplify; Env.Primops; Env.Exclude Env.Zeta] env goal, + opts) + in + + (* handle_smt_goals: users can register a tactic to run on all + remaining goals after tactic execution. *) + let vcs = vcs |> List.concatMap (fun (env, goal, opts) -> + env.solver.handle_smt_goal env goal |> + (* Keep the same SMT options *) + List.map (fun (env, goal) -> (env, goal, opts))) + in + + (* discard trivial goals *) + let vcs = vcs |> List.concatMap (fun (env, goal, opts) -> + match check_trivial goal with + | Trivial -> + if debug then + diag [text "Goal completely solved by tactic\n"]; + [] + + | NonTrivial goal -> + [(env, goal, opts)] + ) + in + vcs + ) + end + else [env, vc, FStarC.Options.peek ()] + ) + in + + (* Splitting queries. FIXME: isn't this redundant given the + code in SMTEncoding.Solver? *) + let vcs = + if Options.split_queries () = Options.Always + then vcs |> + List.collect + (fun (env, goal, opts) -> + match Env.split_smt_query env goal with + | None -> [env,goal,opts] + | Some goals -> goals |> List.map (fun (env, goal) -> env,goal,opts)) + else vcs + in + + (* Solve one by one. If anything fails the SMT module will log errors. *) + vcs |> List.iter (fun (env, goal, opts) -> + Options.with_saved_options (fun () -> + FStarC.Options.set opts; + (* diag (BU.format2 "Trying to solve:\n> %s\nWith proof_ns:\n %s\n" *) + (* (show goal) (Env.string_of_proof_ns env)); *) + if debug then + diag [text "Before calling solver, VC =" ^/^ pp goal]; + env.solver.solve use_env_range_msg env goal + ) + ) + +// Discharge (the logical part of) a guard [g]. +// +// The `use_smt` flag says whether to use the smt solver to discharge +// this guard +// +// - If use_smt = true, this function NEVER returns None, and can be +// considered to have successfully discharged the guard. However, +// it could have logged an SMT error. The VC (aka the logical part +// of the guard) is preprocessed with tactics before discharging: +// every subterm wrapped with `with_tactic` has the tactic run on it +// and a separate VC is generated for it. They are then discharged +// sequentially. +// +// - If use_smt = false, then None means could not discharge the guard +// without using smt. The procedure is to just normalize and simplify +// the VC and check that it is [True]. +// +// In every case, when this function returns [Some g], then the logical +// part of [g] is [Trivial]. +let discharge_guard' use_env_range_msg env (g:guard_t) (use_smt:bool) : option guard_t = + if !dbg_ResolveImplicitsHook + then BU.print1 "///////////////////ResolveImplicitsHook: discharge_guard'\n\ + guard = %s\n" + (guard_to_string env g); + + let g = + let defer_ok = NoDefer in + let smt_ok = not (Options.ml_ish ()) && use_smt in + let deferred_to_tac_ok = true in + try_solve_deferred_constraints defer_ok smt_ok deferred_to_tac_ok env g + in + let open FStarC.Pprint in + let open FStarC.Errors.Msg in + let open FStarC.Class.PP in + let debug : bool = !dbg_Rel || !dbg_SMTQuery || !dbg_Discharge in + let diag = Errors.diag (Env.get_range env) #(list document) in + let ret_g = {g with guard_f = Trivial} in + if env.admit then ( + let open FStarC.Class.PP in + if debug && not (Trivial? g.guard_f) && not env.phase1 then + diag [ + text "Skipping VC because verification is disabled."; + text "VC =" ^/^ pp g; + ]; + Some ret_g + ) else ( + let g = simplify_guard_full_norm env g in + match g.guard_f with + | Trivial -> + Some ret_g + + | NonTrivial vc when not use_smt -> + if debug then + diag [text "Cannot solve without SMT:" ^/^ pp vc]; + None + + | NonTrivial vc -> + do_discharge_vc use_env_range_msg env vc; + Some ret_g + ) + +let discharge_guard env g = + match discharge_guard' None env g true with + | Some g -> g + | None -> failwith "Impossible, with use_smt = true, discharge_guard' should never have returned None" + +let discharge_guard_no_smt env g = + match discharge_guard' None env g false with + | Some g -> g + | None -> + raise_error env Errors.Fatal_ExpectTrivialPreCondition [ + text "Expected a trivial pre-condition" + ] + +let teq_nosmt (env:env) (t1:typ) (t2:typ) : option guard_t = + match try_teq false env t1 t2 with + | None -> None + | Some g -> discharge_guard' None env g false + +let subtype_nosmt env t1 t2 = + if !dbg_Rel || !dbg_RelTop + then BU.print2 "try_subtype_no_smt of %s and %s\n" (N.term_to_string env t1) (N.term_to_string env t2); + let prob, x, wl = new_t_prob (empty_worklist env) env t1 SUB t2 in + let g = with_guard env prob <| solve_and_commit (singleton wl prob false) (fun _ -> None) in + match g with + | None -> None + | Some g -> + let g = close_guard env [S.mk_binder x] g in + discharge_guard' None env g false + +/////////////////////////////////////////////////////////////////// +let check_subtyping env t1 t2 = + Profiling.profile (fun () -> + if !dbg_Rel || !dbg_RelTop + then BU.print2 "check_subtyping of %s and %s\n" (N.term_to_string env t1) (N.term_to_string env t2); + let prob, x, wl = new_t_prob (empty_worklist env) env t1 SUB t2 in + let env_x = Env.push_bv env x in + let smt_ok = not (Options.ml_ish ()) in + let g = with_guard env_x prob <| solve_and_commit (singleton wl prob smt_ok) (fun _ -> None) in + match g with + | None -> ( + if !dbg_Rel || !dbg_RelTop then + BU.print2 "check_subtyping FAILED: %s <: %s\n" + (N.term_to_string env_x t1) + (N.term_to_string env_x t2); + None + ) + | Some g -> ( + if !dbg_Rel || !dbg_RelTop then + BU.print3 "check_subtyping succeeded: %s <: %s\n\tguard is %s\n" + (N.term_to_string env_x t1) + (N.term_to_string env_x t2) + (guard_to_string env_x g); + Some (x, g) + ) + ) + (Some (Ident.string_of_lid (Env.current_module env))) + "FStarC.TypeChecker.Rel.check_subtyping" + +let get_subtyping_predicate env t1 t2 = + Errors.with_ctx "While trying to get a subtyping predicate" (fun () -> + def_check_scoped t1.pos "get_subtyping_predicate.1" env t1; + def_check_scoped t2.pos "get_subtyping_predicate.2" env t2; + match check_subtyping env t1 t2 with + | None -> None + | Some (x, g) -> + Some (abstract_guard (S.mk_binder x) g) + ) + +let get_subtyping_prop env t1 t2 = + Errors.with_ctx "While trying to get a subtyping proposition" (fun () -> + def_check_scoped t1.pos "get_subtyping_prop.1" env t1; + def_check_scoped t2.pos "get_subtyping_prop.2" env t2; + match check_subtyping env t1 t2 with + | None -> None + | Some (x, g) -> + Some (close_guard env [S.mk_binder x] g) + ) + +(* + * Solve the uni-valued implicits + * + * For now we handle only unit and unit refinement typed implicits, + * we can later extend it to single constructor inductives + * + * This function gets the unresolved implicits from the main resolve_implicits' + * function + * + * It only sets the value of the implicit's ctx uvar in the UF graph + * -- leaving their typechecking to resolve_implicits' + * + * E.g. for a ?u:squash phi, this will only set ?u=unit in the UF graph, + * and, as usual, resolve_implicits' will check that G |= phi + * + * It returns a boolean (true if at least one implicit was solved) + * and the set of new implicits, right now this set is same as imps, + * for inductives, this may later include implicits for pattern variables + *) + +let try_solve_single_valued_implicits env is_tac (imps:Env.implicits) : Env.implicits & bool = + (* + * Get the value of the implicit imp + * Going forward, it can also return new implicits for the pattern variables + * (cf. the comment above about extending it to inductives) + *) + if is_tac then imps, false + else + let imp_value imp : option term = + let ctx_u, r = imp.imp_uvar, imp.imp_range in + + let t_norm = N.normalize N.whnf_steps env (U.ctx_uvar_typ ctx_u) in + + match (SS.compress t_norm).n with + | Tm_fvar fv when S.fv_eq_lid fv PC.unit_lid -> + r |> S.unit_const_with_range |> Some + | Tm_refine {b} when U.is_unit b.sort -> + r |> S.unit_const_with_range |> Some + | _ -> None in + + let b = List.fold_left (fun b imp -> //check that the imp is still unsolved + if UF.find imp.imp_uvar.ctx_uvar_head |> is_none && + U.ctx_uvar_should_check imp.imp_uvar = Strict + then match imp_value imp with + | Some tm -> commit env ([TERM (imp.imp_uvar, tm)]); true + | None -> b + else b) false imps in + + imps, b + +(* + * Check that an implicit solution has the expected type + * + * Return None if we did not typecheck the implicit because + * typechecking it required solving deferred univ constraints, + * and the flag force_univ_constraints is not set + * + * Invariants: + * - If force_univ_constraints is set, return is a Some + * - If is_tac is true, return is Some [] + * - The caller (resolve_implicits') ensures that + * if is_tac then force_univ_constraints + * + *) +let check_implicit_solution_and_discharge_guard env + (imp:implicit) + (is_tac force_univ_constraints:bool) + + : option TcComm.implicits_t = + + let {imp_reason; imp_tm; imp_uvar; imp_range} = imp in + + let uvar_ty = U.ctx_uvar_typ imp_uvar in + let uvar_should_check = U.ctx_uvar_should_check imp_uvar in + + if !dbg_Rel + then BU.print5 "Checking uvar %s resolved to %s at type %s, introduce for %s at %s\n" + (show imp_uvar.ctx_uvar_head) + (show imp_tm) + (show uvar_ty) + imp_reason + (Range.string_of_range imp_range); + + let env = + {env with gamma=imp_uvar.ctx_uvar_gamma} + |> Env.clear_expected_typ + |> fst in + + let g = + Errors.with_ctx + "While checking implicit solution" + (fun () -> + let skip_core = + env.phase1 || + env.admit || + Allow_untyped? uvar_should_check || + Already_checked? uvar_should_check in + + let must_tot = not (env.phase1 || + env.admit || + Allow_ghost? uvar_should_check) in + + if skip_core + then if is_tac + then Env.trivial_guard + else begin // following is ad-hoc code for constraining some univs + // ideally we should get rid of it, and just return trivial_guard + (* + * AR: when we create lambda terms as solutions to implicits (in u_abs), + * we set the type in the residual comp to be the type of the uvar + * while this ok for smt encoding etc., when we are typechecking the implicit solution using fastpath, + * it doesn't help since the two types are the same (the type of the uvar and its solution) + * worse, this prevents some constraints to be generated between the actual type of the solution + * and the type of the uvar + * therefore, we unset the residual comp type in the solution before typechecking + *) + let imp_tm = + match (SS.compress imp_tm).n with + | Tm_abs {bs; body; rc_opt=Some rc} -> + {imp_tm with n=Tm_abs {bs; body; rc_opt=Some ({rc with residual_typ=None})}} + | _ -> imp_tm in + + let k', g = + env.typeof_well_typed_tot_or_gtot_term + env + imp_tm must_tot in + + match get_subtyping_predicate env k' uvar_ty with + | None -> Err.expected_expression_of_type env imp_tm.pos uvar_ty imp_tm k' + | Some f -> + {Env.conj_guard (Env.apply_guard f imp_tm) g with guard_f=Trivial} + end + else begin + match env.core_check env imp_tm uvar_ty must_tot with + | Inl None -> trivial_guard + | Inl (Some g) -> { trivial_guard with guard_f = NonTrivial g } + | Inr print_err -> + raise_error imp_range Errors.Fatal_FailToResolveImplicitArgument + (BU.format5 "Core checking failed for implicit %s (is_tac: %s) (reason: %s) (%s <: %s)" + (show imp_uvar) (show is_tac) imp_reason (show imp_tm) (show uvar_ty)) + end) in + + if (not force_univ_constraints) && + (CList.existsb (fun (reason, _, _) -> reason = Deferred_univ_constraint) g.deferred) + then None + else let g' = + match discharge_guard' + (Some (fun () -> + BU.format4 "%s (Introduced at %s for %s resolved at %s)" + (show imp_tm) (show imp_range) imp_reason (show imp_tm.pos))) + env g true with + | Some g -> g + | None -> failwith "Impossible, with use_smt = true, discharge_guard' must return Some" in + g'.implicits |> Some + +(* + * resolve_implicits' uses it to determine if a ctx uvar is unresolved + *) +let rec unresolved ctx_u : bool = + match (Unionfind.find ctx_u.ctx_uvar_head) with + | Some r -> + begin match ctx_u.ctx_uvar_meta with + | None -> false + (* If we have a meta annotation, we recurse to see if the uvar + * is actually solved, instead of being resolved to yet another uvar. + * In that case, while we are keeping track of that uvar, we must not + * forget the meta annotation in case this second uvar is not solved. + * See #1561. *) + | Some _ -> + begin match (SS.compress r).n with + | Tm_uvar (ctx_u', _) -> unresolved ctx_u' + | _ -> false + end + end + | None -> true + + +(* + * In the fixpoint loop of resolve_implicits', + * when we reach a fixpoint, with some implicits still remaining, + * try to pick an implicit whose typechecking generates a univ constraint, + * force it, and then repeat the fixpoint loop + *) +let pick_a_univ_deffered_implicit (out : tagged_implicits) + : option Env.implicit & tagged_implicits + = + let imps_with_deferred_univs, rest = List.partition + (fun (_, status) -> status = Implicit_checking_defers_univ_constraint) + out in + match imps_with_deferred_univs with + | [] -> None, out + | hd::tl -> hd |> fst |> Some, (tl@rest) + +let is_tac_implicit_resolved (env:env) (i:implicit) : bool = + i.imp_tm + |> Free.uvars + |> Setlike.for_all (fun uv -> Allow_unresolved? (U.ctx_uvar_should_check uv)) + + +// is_tac: this is a call from within the tactic engine, hence do not use +// tactics for resolving implicits to avoid reentrancy. +// +// is_gen: this is a call after generalization, hence we only check that +// implicits have a solution, and do not typecheck it. This still allows +// some implicits to remain unresolved, but those will remain in the guard. +let resolve_implicits' env is_tac is_gen (implicits:Env.implicits) + : list (implicit & implicit_checking_status) = + + (* Meta argument cache: during a single run of this resolve_implicits' function + we keep track of all results of the "cacheable" tactics that are used for meta + arguments. The only cacheable tactic, for now, is tcresolve. Before trying to run + it, we check the cache to see if we have already solved a problem in the same environment + and for the same uvar type (in this case, the constraint). If so, we just take that result. + + This is pretty conservative. e.g. in + f (1 + 1); + g (1 + 1) + we cannot reuse the solution for each +, since there is an extra unit binder when + we check `g ...`. But it does lead to big gains in expressions like `1 + 1 + 1 ...`. *) + let cacheable tac = + (* Detect either an unapplied tcresolve or an eta expanded variant. This is + mostly in support of solve, which has to be written eta expanded. *) + (U.is_fvar PC.tcresolve_lid tac) || ( + match (SS.compress tac).n with + | Tm_abs ({bs=[_]; body}) -> + let hd, args = U.head_and_args body in + U.is_fvar PC.tcresolve_lid hd && List.length args = 1 + | _ -> false + ) + in + (* tcresolve is also the only tactic we ever run for an open problem. *) + let meta_tac_allowed_for_open_problem tac = cacheable tac in + let __meta_arg_cache : ref (list (term & env_t & typ & term)) = BU.mk_ref [] in + let meta_arg_cache_result (tac : term) (e : env_t) (ty : term) (res : term) : unit = + __meta_arg_cache := (tac, e, ty, res) :: !__meta_arg_cache + in + let meta_arg_cache_lookup (tac : term) (e : env_t) (ty : term) : option term = + let rec aux l : option term = + match l with + | [] -> None + | (tac', e', ty', res') :: l' -> + if U.term_eq tac tac' + && FStarC.Common.eq_list U.eq_binding e.gamma e'.gamma + && U.term_eq ty ty' + then Some res' + else aux l' + in + aux !__meta_arg_cache + in + (* / cache *) + + let rec until_fixpoint (acc : tagged_implicits & (*changed:*)bool & (*defer_open_metas:*)bool ) + (implicits:Env.implicits) + : tagged_implicits = + + let out, changed, defer_open_metas = acc in + (* changed: we made some progress + defer_open_metas: starts at true, it means to not try to run + meta arg tactics in environments/types that have unresolved + uvars. We first do a pass with this set to true, and if nothing + changed, we then give up and set it to false, trying to eagerly + solve some partially-unresolved constraints. This is definitely + not ideal, maybe the right thing to do is to never run metas + in open contexts, but that is raising many regressions rihgt now, + particularly in Steel (which uses the resolve_implicits hook pervasively). *) + + match implicits with + | [] -> + if changed then ( + (* We made some progress, keep going from the start *) + until_fixpoint ([], false, true) (List.map fst out) + ) else if defer_open_metas then ( + (* No progress... but we could try being more eager with metas. *) + until_fixpoint ([], false, false) (List.map fst out) + ) else ( + //Nothing changed in this iteration of the loop + //We will try to make progress by either solving a single valued implicit, + // or solving an implicit that generates univ constraint, with force flag on + let imps, changed = try_solve_single_valued_implicits env is_tac (List.map fst out) in + if changed then until_fixpoint ([], false, true) imps + else let imp_opt, rest = pick_a_univ_deffered_implicit out in + (match imp_opt with + | None -> rest //No such implicit exists, return remaining implicits + | Some imp -> + let force_univ_constraints = true in + let imps = + check_implicit_solution_and_discharge_guard + env + imp + is_tac + force_univ_constraints |> must in + until_fixpoint ([], false, true) (Listlike.to_list imps ++ List.map fst rest)) + ) + + | hd::tl -> + let { imp_reason = reason; imp_tm = tm; imp_uvar = ctx_u; imp_range = r } = hd in + let { uvar_decoration_typ; uvar_decoration_should_check } = UF.find_decoration ctx_u.ctx_uvar_head in + if !dbg_Rel then + BU.print4 "resolve_implicits' loop, imp_tm=%s and ctx_u=%s, is_tac=%s, should_check=%s\n" + (show tm) (show ctx_u) (show is_tac) (show uvar_decoration_should_check); + begin match () with + | _ when Allow_unresolved? uvar_decoration_should_check -> + until_fixpoint (out, true, defer_open_metas) tl + + | _ when unresolved ctx_u && flex_uvar_has_meta_tac ctx_u -> + let Some (Ctx_uvar_meta_tac tac) = ctx_u.ctx_uvar_meta in + let env = { env with gamma = ctx_u.ctx_uvar_gamma } in + let typ = U.ctx_uvar_typ ctx_u in + let is_open = has_free_uvars typ || gamma_has_free_uvars ctx_u.ctx_uvar_gamma in + if defer_open_metas && is_open then ( + (* If the result type or env for this meta arg has a free uvar, delay it. + Some other meta arg being solved may instantiate the uvar. See #3130. *) + if !dbg_Rel || !dbg_Imps then + BU.print1 "Deferring implicit due to open ctx/typ %s\n" (show ctx_u); + until_fixpoint ((hd, Implicit_unresolved)::out, changed, defer_open_metas) tl + ) else if is_open && not (meta_tac_allowed_for_open_problem tac) + && Options.Ext.get "compat:open_metas" = "" then ( // i.e. compat option unset + (* If the tactic is not explicitly whitelisted to run with open problems, + then defer. *) + until_fixpoint ((hd, Implicit_unresolved)::out, changed, defer_open_metas) tl + ) else ( + let solve_with (t:term) = + let extra = + match teq_nosmt env t tm with + | None -> failwith "resolve_implicits: unifying with an unresolved uvar failed?" + | Some g -> Listlike.to_list g.implicits + in + until_fixpoint (out, true, defer_open_metas) (extra @ tl) + in + if cacheable tac then + match meta_arg_cache_lookup tac env typ with + | Some res -> solve_with res + | None -> + let t = run_meta_arg_tac env ctx_u in + meta_arg_cache_result tac env typ t; + solve_with t + else + let t = run_meta_arg_tac env ctx_u in + solve_with t + ) + + | _ when unresolved ctx_u -> + until_fixpoint ((hd, Implicit_unresolved)::out, changed, defer_open_metas) tl + + | _ when Allow_untyped? uvar_decoration_should_check || + Already_checked? uvar_decoration_should_check || + is_gen -> + until_fixpoint (out, true, defer_open_metas) tl + | _ -> + let env = {env with gamma=ctx_u.ctx_uvar_gamma} in + (* + * AR: Some opportunities for optimization here, + * we may end up normalizing an implicit solution multiple times in + * multiple until_fixpoint calls + *) + let tm = norm_with_steps "FStarC.TypeChecker.Rel.norm_with_steps.8" [Env.Beta] env tm in + let hd = {hd with imp_tm=tm} in + if is_tac + then begin + if is_tac_implicit_resolved env hd + then let force_univ_constraints = true in + let res = check_implicit_solution_and_discharge_guard + env + hd + is_tac + force_univ_constraints in + let res = BU.map_opt res Listlike.to_list in + if res <> Some [] + then failwith "Impossible: check_implicit_solution_and_discharge_guard for tac must return Some []" + else () + else (); + until_fixpoint (out, true, defer_open_metas) tl + end + else + begin + let force_univ_constraints = false in + let imps_opt = + check_implicit_solution_and_discharge_guard + env + hd + is_tac + force_univ_constraints in + + match imps_opt with + | None -> + until_fixpoint ((hd, Implicit_checking_defers_univ_constraint)::out, changed, defer_open_metas) tl //Move hd to out + | Some imps -> + //add imps to out + until_fixpoint ((imps |> Listlike.to_list |> List.map (fun i -> i, Implicit_unresolved))@out, true, defer_open_metas) tl + end + end + in + until_fixpoint ([], false, true) implicits + +let resolve_implicits env g = + if !dbg_ResolveImplicitsHook + then BU.print1 "//////////////////////////ResolveImplicitsHook: resolve_implicits begin////////////\n\ + guard = %s {\n" + (guard_to_string env g); + let tagged_implicits = resolve_implicits' env false false (Listlike.to_list g.implicits) in + if !dbg_ResolveImplicitsHook + then BU.print_string "//////////////////////////ResolveImplicitsHook: resolve_implicits end////////////\n\ + }\n"; + {g with implicits = Listlike.from_list <| List.map fst tagged_implicits} + +let resolve_generalization_implicits env g = + let tagged_implicits = resolve_implicits' env false true (Listlike.to_list g.implicits) in + {g with implicits = Listlike.from_list <| List.map fst tagged_implicits} + +let resolve_implicits_tac env g = resolve_implicits' env true false (Listlike.to_list g.implicits) + +let force_trivial_guard env g = + if !dbg_ResolveImplicitsHook + then BU.print1 "//////////////////////////ResolveImplicitsHook: force_trivial_guard////////////\n\ + guard = %s\n" + (guard_to_string env g); + let g = solve_deferred_constraints env g in + let g = resolve_implicits env g in + match Listlike.to_list g.implicits with + | [] -> ignore <| discharge_guard env g + | imp::_ -> + let open FStarC.Pprint in + raise_error imp.imp_range Errors.Fatal_FailToResolveImplicitArgument [ + prefix 4 1 (text "Failed to resolve implicit argument") + (arbitrary_string (show imp.imp_uvar.ctx_uvar_head)) ^/^ + prefix 4 1 (text "of type") + (N.term_to_doc env (U.ctx_uvar_typ imp.imp_uvar)) ^/^ + prefix 4 1 (text "introduced for") + (text imp.imp_reason) + ] + +let subtype_nosmt_force env t1 t2 = + match subtype_nosmt env t1 t2 with + | None -> false + | Some g -> + force_trivial_guard env g; + true + +let teq_force (env:env) (t1:typ) (t2:typ) : unit = + force_trivial_guard env (teq env t1 t2) + +let teq_nosmt_force (env:env) (t1:typ) (t2:typ) :bool = + match teq_nosmt env t1 t2 with + | None -> false + | Some g -> + force_trivial_guard env g; + true + +let layered_effect_teq env (t1:term) (t2:term) (reason:option string) : guard_t = + if !dbg_LayeredEffectsEqns + then BU.print3 "Layered Effect (%s) %s = %s\n" + (if reason |> is_none then "_" else reason |> must) + (show t1) (show t2); + teq env t1 t2 //AR: teq_nosmt? + + +let universe_inequality (u1:universe) (u2:universe) : guard_t = + //Printf.printf "Universe inequality %s <= %s\n" (show u1) (show u2); + {trivial_guard with univ_ineqs=(empty, cons (u1,u2) empty)} diff --git a/src/typechecker/FStarC.TypeChecker.Rel.fsti b/src/typechecker/FStarC.TypeChecker.Rel.fsti new file mode 100644 index 00000000000..8f58dfac52c --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Rel.fsti @@ -0,0 +1,97 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.TypeChecker.Rel +open FStar.Pervasives +open FStarC.Compiler.Effect + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.TypeChecker +open FStarC.Syntax +open FStarC.TypeChecker.Env +open FStarC.Syntax.Syntax +open FStarC.TypeChecker.Common +open FStarC.Compiler.Range +open FStarC.Class.Show + +type match_result = + | MisMatch of option delta_depth & option delta_depth + | HeadMatch of bool // true iff the heads MAY match after further unification, false if already the same + | FullMatch + +type implicit_checking_status = + | Implicit_unresolved + | Implicit_checking_defers_univ_constraint + | Implicit_has_typing_guard of term & typ + +instance val showable_implicit_checking_status : showable implicit_checking_status + +type tagged_implicits = list (implicit & implicit_checking_status) + +val is_base_type : env -> typ -> bool +val prob_to_string: env -> prob -> string +val flex_prob_closing : env -> binders -> prob -> bool + + +val head_matches_delta (env:env) (logical:bool) (smt_ok:bool) (t1 t2:typ) : (match_result & option (typ & typ)) +val may_relate_with_logical_guard (env:env) (is_equality:bool) (head:typ) : bool +val guard_to_string : env -> guard_t -> string +val simplify_guard : env -> guard_t -> guard_t +val solve_deferred_constraints: env -> guard_t -> guard_t +val solve_non_tactic_deferred_constraints: maybe_defer_flex_flex:bool -> env -> guard_t -> guard_t + + +(* These functions attempt to discharge the logical part of a guard +by simplifying it and calling the SMT if needed (except the _no_smt one, +which will fail raising an error if SMT is needed). The first may *log* +an error if SMT fails to prove the guard. + +Also, before that, they will try to solve all deferred constraints +in the guard, raising an error if one cannot be solved just like +solve_deferred_constraints does. + +In any case, if these functions return, they return a guard with guard_f = Trivial. *) +val discharge_guard : env -> guard_t -> guard_t +val discharge_guard_no_smt : env -> guard_t -> guard_t + +val force_trivial_guard : env -> guard_t -> unit +val resolve_implicits : env -> guard_t -> guard_t +val resolve_generalization_implicits : env -> guard_t -> guard_t +val resolve_implicits_tac : env -> guard_t -> tagged_implicits +val base_and_refinement_maybe_delta : bool -> env -> term -> term & option (bv & term) +val base_and_refinement : env -> term -> term & option (bv & term) + +val unrefine : env -> typ -> typ +val try_teq : smt_ok:bool -> env -> typ -> typ -> option guard_t +val teq : env -> typ -> typ -> guard_t +val get_teq_predicate : env -> typ -> typ -> option guard_t +val teq_force : env -> typ -> typ -> unit +val teq_nosmt : env -> typ -> typ -> option guard_t +val teq_nosmt_force : env -> typ -> typ -> bool +val layered_effect_teq : env -> typ -> typ -> reason:option string -> guard_t +val get_subtyping_predicate: env -> typ -> typ -> option guard_t +val get_subtyping_prop: env -> typ -> typ -> option guard_t +val subtype_nosmt : env -> typ -> typ -> option guard_t +val subtype_nosmt_force : env -> typ -> typ -> bool +val sub_comp : env -> comp -> comp -> option guard_t +val eq_comp : env -> comp -> comp -> option guard_t + +val universe_inequality : universe -> universe -> guard_t + +val subtype_fail: env -> term -> typ -> typ -> unit +val print_pending_implicits: guard_t -> string diff --git a/src/typechecker/FStarC.TypeChecker.Tc.fst b/src/typechecker/FStarC.TypeChecker.Tc.fst new file mode 100644 index 00000000000..f14ec8743dc --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Tc.fst @@ -0,0 +1,1260 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.TypeChecker.Tc +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.Errors +open FStarC.TypeChecker +open FStarC.TypeChecker.Common +open FStarC.TypeChecker.Env +open FStarC.Compiler.Util +open FStarC.Ident +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.Syntax.Subst +open FStarC.Syntax.Util +open FStarC.Const +open FStarC.TypeChecker.TcTerm + +open FStarC.Class.Show +open FStarC.Class.Tagged +open FStarC.Class.PP +open FStarC.Class.Setlike + +module S = FStarC.Syntax.Syntax +module SP = FStarC.Syntax.Print +module SS = FStarC.Syntax.Subst +module UF = FStarC.Syntax.Unionfind +module N = FStarC.TypeChecker.Normalize +module TcComm = FStarC.TypeChecker.Common +module TcUtil = FStarC.TypeChecker.Util +module BU = FStarC.Compiler.Util //basic util +module U = FStarC.Syntax.Util +module Gen = FStarC.TypeChecker.Generalize +module TcInductive = FStarC.TypeChecker.TcInductive +module TcEff = FStarC.TypeChecker.TcEffect +module PC = FStarC.Parser.Const +module EMB = FStarC.Syntax.Embeddings +module ToSyntax = FStarC.ToSyntax.ToSyntax +module O = FStarC.Options + +let dbg_TwoPhases = Debug.get_toggle "TwoPhases" +let dbg_IdInfoOn = Debug.get_toggle "IdInfoOn" +let dbg_Normalize = Debug.get_toggle "Normalize" +let dbg_UF = Debug.get_toggle "UF" +let dbg_LogTypes = Debug.get_toggle "LogTypes" + +let sigelt_typ (se:sigelt) : option typ = + match se.sigel with + | Sig_inductive_typ {t} + | Sig_datacon {t} + | Sig_declare_typ {t} -> Some t + + | Sig_let {lbs=(_, lb::_)} -> + Some lb.lbtyp + + | _ -> + None + +//set the name of the query so that we can correlate hints to source program fragments +let set_hint_correlator env se = + //if the tbl has a counter for lid, we use that, else we start from 0 + //this is useful when we verify the extracted interface alongside + let tbl = env.qtbl_name_and_index |> snd in + let get_n lid = + let n_opt = BU.smap_try_find tbl (show lid) in + if is_some n_opt then n_opt |> must else 0 + in + + let typ = match sigelt_typ se with | Some t -> t | _ -> S.tun in + + match Options.reuse_hint_for () with + | Some l -> + let lid = Ident.lid_add_suffix (Env.current_module env) l in + {env with qtbl_name_and_index=Some (lid, typ, get_n lid), tbl} + + | None -> + let lids = U.lids_of_sigelt se in + let lid = match lids with + | [] -> Ident.lid_add_suffix (Env.current_module env) + (GenSym.next_id () |> BU.string_of_int) // GM: Should we really touch the gensym? + | l::_ -> l in + {env with qtbl_name_and_index=Some (lid, typ, get_n lid), tbl} + +let log env = (Options.log_types()) && not(lid_equals PC.prims_lid (Env.current_module env)) + + +(*****************Type-checking the signature of a module*****************************) + +let tc_type_common (env:env) ((uvs, t):tscheme) (expected_typ:typ) (r:Range.range) :tscheme = + let uvs, t = SS.open_univ_vars uvs t in + let env = Env.push_univ_vars env uvs in + let t = tc_check_trivial_guard env t expected_typ in + if uvs = [] then + let uvs, t = Gen.generalize_universes env t in + //AR: generalize_universes only calls N.reduce_uvar_solutions, so make sure there are no uvars left + TcUtil.check_uvars r t; + uvs, t + else uvs, t |> N.remove_uvar_solutions env |> SS.close_univ_vars uvs + +let tc_declare_typ (env:env) (ts:tscheme) (r:Range.range) :tscheme = + tc_type_common env ts (U.type_u () |> fst) r + +let tc_assume (env:env) (ts:tscheme) (r:Range.range) :tscheme = + //AR: this might seem same as tc_declare_typ but come prop, this will change + tc_type_common env ts (U.type_u () |> fst) r + +let tc_decl_attributes env se = + // [Substitute] (defined in Pervasives), is added as attribute by + // TcInductive when a type has no projector, and this happens for + // some types (see TcInductive.early_prims_inductives) that are + // defined before [Substitute] even exists. + // Thus the partition of attributes below. + let blacklisted_attrs, other_attrs = + if lid_exists env PC.attr_substitute_lid + then ([], se.sigattrs) + else partition ((=) attr_substitute) se.sigattrs + in + let g, other_attrs = tc_attributes env other_attrs in + Rel.force_trivial_guard env g; + {se with sigattrs = blacklisted_attrs @ other_attrs } + +let tc_inductive' env ses quals attrs lids = + if Debug.low () then + BU.print1 ">>>>>>>>>>>>>>tc_inductive %s\n" (show ses); + + let ses = List.map (tc_decl_attributes env) ses in + + let sig_bndle, tcs, datas = TcInductive.check_inductive_well_typedness env ses quals lids in + (* we have a well-typed inductive; + we still need to check whether or not it supports equality + and whether it is strictly positive + *) + let sig_bndle = Positivity.mark_uniform_type_parameters env sig_bndle in + + (* Once the datacons are generalized we can construct the projectors with the right types *) + let attrs' = U.remove_attr PC.erasable_attr attrs in + let data_ops_ses = List.map (TcInductive.mk_data_operations quals attrs' env tcs) datas |> List.flatten in + + //strict positivity check + if Options.no_positivity () || (not (Env.should_verify env)) then () //skipping positivity check if lax mode + else begin + (* + * AR: call add_sigelt_to_env here? We should maintain the invariant that push_sigelt is only called from there + * but then this is temporary, just to check positivity, later we actually do go through add_sigelt_to_env + *) + let env2 = Env.push_sigelt env sig_bndle in + (* Check positivity of the inductives within the Sig_bundle *) + List.iter (fun ty -> + let b = Positivity.check_strict_positivity env2 lids ty in + if not b then + let lid, r = + match ty.sigel with + | Sig_inductive_typ {lid} -> lid, ty.sigrng + | _ -> failwith "Impossible!" + in + Errors.log_issue r Errors.Error_InductiveTypeNotSatisfyPositivityCondition ("Inductive type " ^ (string_of_lid lid) ^ " does not satisfy the strict positivity condition") + else () + ) tcs; + + (* Separately, if any of the data constructors in the Sig_bundle are + * exceptions, check their positivity separately. See issue #1535 *) + List.iter (fun d -> + let data_lid, ty_lid = + match d.sigel with + | Sig_datacon {lid=data_lid; ty_lid} -> data_lid, ty_lid + | _ -> failwith "Impossible" + in + if lid_equals ty_lid PC.exn_lid && + not (Positivity.check_exn_strict_positivity env2 data_lid) + then + Errors.log_issue d + Errors.Error_InductiveTypeNotSatisfyPositivityCondition + ("Exception " ^ (string_of_lid data_lid) ^ " does not satisfy the positivity condition") + ) datas + end; + + //generate hasEq predicate for this inductive + + let skip_haseq = + //skip logical connectives types in prims, tcs is bound to the inductive type, caller ensures its length is > 0 + let skip_prims_type (_:unit) :bool = + let lid = + let ty = List.hd tcs in + match ty.sigel with + | Sig_inductive_typ {lid} -> lid + | _ -> failwith "Impossible" + in + //these are the prims type we are skipping + List.existsb (fun s -> s = (string_of_id (ident_of_lid lid))) TcInductive.early_prims_inductives in + + let is_noeq = List.existsb (fun q -> q = Noeq) quals in + + //caller ensures tcs length is > 0 + //assuming that we have already propagated attrs from the bundle to its elements + let is_erasable () = U.has_attribute (List.hd tcs).sigattrs FStarC.Parser.Const.erasable_attr in + + List.length tcs = 0 || + (lid_equals env.curmodule PC.prims_lid && skip_prims_type ()) || + is_noeq || + is_erasable () in + + + let res = + if skip_haseq + then sig_bndle, data_ops_ses + else + let is_unopteq = List.existsb (fun q -> q = Unopteq) quals in + let ses = + if is_unopteq then TcInductive.unoptimized_haseq_scheme sig_bndle tcs datas env + else TcInductive.optimized_haseq_scheme sig_bndle tcs datas env + in + sig_bndle, ses@data_ops_ses in //append hasEq axiom lids and data projectors and discriminators lids + res + +let tc_inductive env ses quals attrs lids = + let env = Env.push env "tc_inductive" in + let pop () = ignore (Env.pop env "tc_inductive") in //OK to ignore: caller will reuse original env + + if Options.trace_error () then + let r = tc_inductive' env ses quals attrs lids in + pop (); + r + else + try tc_inductive' env ses quals attrs lids |> (fun r -> pop (); r) + with e -> pop (); raise e + +let proc_check_with (attrs:list attribute) (kont : unit -> 'a) : 'a = + match U.get_attribute PC.check_with_lid attrs with + | None -> kont () + | Some [(a, None)] -> + match EMB.unembed a EMB.id_norm_cb with + | None -> failwith "nah" + | Some vcfg -> + Options.with_saved_options (fun () -> + Options.set_vconfig vcfg; + kont ()) + | _ -> failwith "ill-formed `check_with`" + +let handle_postprocess_with_attr (env:Env.env) (ats:list attribute) + : (list attribute & option term) += (* Extract the postprocess_with *) + match U.extract_attr' PC.postprocess_with ats with + | None -> ats, None + | Some (ats, [tau, None]) -> + ats, Some tau + | Some (ats, args) -> + Errors.log_issue env Errors.Warning_UnrecognizedAttribute + (BU.format1 "Ill-formed application of `%s`" (show PC.postprocess_with)); + ats, None + +let store_sigopts (se:sigelt) : sigelt = + { se with sigopts = Some (Options.get_vconfig ()) } + +(* Alternative to making a huge let rec... knot is set below in this file *) +let tc_decls_knot : ref (option (Env.env -> list sigelt -> list sigelt & Env.env)) = + BU.mk_ref None + +let do_two_phases env : bool = not (Options.lax ()) +let run_phase1 (f:unit -> 'a) = + FStarC.TypeChecker.Core.clear_memo_table(); + let r = f () in + FStarC.TypeChecker.Core.clear_memo_table(); + r + + +(* The type checking rule for Sig_let (lbs, lids) *) +let tc_sig_let env r se lbs lids : list sigelt & list sigelt & Env.env = + let env0 = env in + let env = Env.set_range env r in + let check_quals_eq l qopt val_q = match qopt with + | None -> Some val_q + | Some q' -> + //logic is now a deprecated qualifier, so discard it from the checking + //AR: 05/19: drop irreducible also + // irreducible is not allowed on val, but one could add it on let + let drop_logic_and_irreducible = List.filter (fun x -> not (x = Logic || x = Irreducible)) in + if (let val_q, q' = drop_logic_and_irreducible val_q, drop_logic_and_irreducible q' in + List.length val_q = List.length q' + && List.forall2 U.qualifier_equal val_q q') + then Some q' //but retain it in the returned list of qualifiers, some code may still add type annotations of Type0, which will hinder `logical` inference + else + let open FStarC.Pprint in + raise_error r Errors.Fatal_InconsistentQualifierAnnotation [ + text "Inconsistent qualifier annotations on" ^/^ doc_of_string (show l); + prefix 4 1 (text "Expected") (squotes (arbitrary_string (show val_q))) ^/^ + prefix 4 1 (text "got") (squotes (arbitrary_string (show q'))) + ] + in + + let rename_parameters lb = + let rename_in_typ def typ = + let typ = Subst.compress typ in + let def_bs = match (Subst.compress def).n with + | Tm_abs {bs=binders} -> binders + | _ -> [] in + match typ with + | { n = Tm_arrow {bs=val_bs; comp=c}; pos = r } -> begin + let has_auto_name bv = + BU.starts_with (string_of_id bv.ppname) Ident.reserved_prefix in + let rec rename_binders def_bs val_bs = + match def_bs, val_bs with + | [], _ | _, [] -> val_bs + | ({binder_bv=body_bv}) :: bt, val_b :: vt -> + (match has_auto_name body_bv, has_auto_name val_b.binder_bv with + | true, _ -> val_b + | false, true -> { val_b with + binder_bv={val_b.binder_bv with + ppname = mk_ident (string_of_id body_bv.ppname, range_of_id val_b.binder_bv.ppname)} } + | false, false -> + // if (string_of_id body_bv.ppname) <> (string_of_id val_bv.ppname) then + // Errors.warn (range_of_id body_bv.ppname) + // (BU.format2 "Parameter name %s doesn't match name %s used in val declaration" + // (string_of_id body_bv.ppname) (string_of_id val_bv.ppname)); + val_b) :: rename_binders bt vt in + Syntax.mk (Tm_arrow {bs=rename_binders def_bs val_bs; comp=c}) r end + | _ -> typ in + { lb with lbtyp = rename_in_typ lb.lbdef lb.lbtyp } in + + (* 1. (a) Annotate each lb in lbs with a type from the corresponding val decl, if there is one + (b) Generalize the type of lb only if none of the lbs have val decls nor explicit universes + *) + let should_generalize, lbs', quals_opt = + snd lbs |> List.fold_left (fun (gen, lbs, quals_opt) lb -> + let lbname = right lb.lbname in //this is definitely not a local let binding + let gen, lb, quals_opt = match Env.try_lookup_val_decl env lbname.fv_name.v with + | None -> + gen, lb, quals_opt + + | Some ((uvs,tval), quals) -> + let quals_opt = check_quals_eq lbname.fv_name.v quals_opt quals in + let def = match lb.lbtyp.n with + | Tm_unknown -> lb.lbdef + | _ -> + (* If there are two type ascriptions we check that they are compatible *) + mk (Tm_ascribed {tm=lb.lbdef; asc=(Inl lb.lbtyp, None, false); eff_opt=None}) lb.lbdef.pos + in + if lb.lbunivs <> [] && List.length lb.lbunivs <> List.length uvs + then raise_error r Errors.Fatal_IncoherentInlineUniverse "Inline universes are incoherent with annotation from val declaration"; + false, //explicit annotation provided; do not generalize + mk_lb (Inr lbname, uvs, PC.effect_Tot_lid, tval, def, lb.lbattrs, lb.lbpos), + quals_opt + in + gen, lb::lbs, quals_opt) + (true, [], (if se.sigquals=[] then None else Some se.sigquals)) + in + + (* Check that all the mutually recursive bindings mention the same universes *) + U.check_mutual_universes lbs'; + + let quals = match quals_opt with + | None -> [Visible_default] + | Some q -> + if q |> BU.for_some (function Irreducible | Visible_default | Unfold_for_unification_and_vcgen -> true | _ -> false) + then q + else Visible_default::q //the default visibility for a let binding is Unfoldable + in + + let lbs' = List.rev lbs' in + + (* preprocess_with *) + let attrs, pre_tau = + match U.extract_attr' PC.preprocess_with se.sigattrs with + | None -> se.sigattrs, None + | Some (ats, [tau, None]) -> ats, Some tau + | Some (ats, args) -> + Errors.log_issue r Errors.Warning_UnrecognizedAttribute "Ill-formed application of `preprocess_with`"; + se.sigattrs, None + in + let se = { se with sigattrs = attrs } in (* to remove the preprocess_with *) + + let preprocess_lb (tau:term) (lb:letbinding) : letbinding = + let lbdef = Env.preprocess env tau lb.lbdef in + if Debug.medium () || !dbg_TwoPhases then + BU.print1 "lb preprocessed into: %s\n" (show lbdef); + { lb with lbdef = lbdef } + in + // Preprocess the letbindings with the tactic, if any + let lbs' = match pre_tau with + | Some tau -> List.map (preprocess_lb tau) lbs' + | None -> lbs' + in + (* / preprocess_with *) + + (* 2. Turn the top-level lb into a Tm_let with a unit body *) + let e = mk (Tm_let {lbs=(fst lbs, lbs'); body=mk (Tm_constant (Const_unit)) r}) r in + + (* 3. Type-check the Tm_let and convert it back to Sig_let *) + let env' = { env with top_level = true; generalize = should_generalize } in + let e = + if do_two_phases env' then run_phase1 (fun _ -> + let drop_lbtyp (e_lax:term) :term = + match (SS.compress e_lax).n with + | Tm_let {lbs=(false, [ lb ]); body=e2} -> + let lb_unannotated = + match (SS.compress e).n with //checking type annotation on e, the lb before phase 1, capturing e from above + | Tm_let {lbs=(_, [ lb ])} -> + (match (SS.compress lb.lbtyp).n with + | Tm_unknown -> true + | _ -> false) + | _ -> failwith "Impossible: first phase lb and second phase lb differ in structure!" + in + if lb_unannotated then { e_lax with n = Tm_let {lbs=(false, [ { lb with lbtyp = S.tun } ]); + body=e2}} //erase the type annotation + else e_lax + | Tm_let {lbs=(true, lbs)} -> + U.check_mutual_universes lbs; + //leave recursive lets as is; since the decreases clause from the ascription (if any) + //is propagated to the lbtyp by TcUtil.extract_let_rec_annotation + //if we drop the lbtyp here, we'll lose the decreases clause + e_lax + in + let e = + Profiling.profile (fun () -> + let (e, _, _) = tc_maybe_toplevel_term ({ env' with phase1 = true; admit = true }) e in + e) + (Some (Ident.string_of_lid (Env.current_module env))) + "FStarC.TypeChecker.Tc.tc_sig_let-tc-phase1" + in + + if Debug.medium () || !dbg_TwoPhases then + BU.print1 "Let binding after phase 1, before removing uvars: %s\n" (show e); + + let e = N.remove_uvar_solutions env' e |> drop_lbtyp in + + if Debug.medium () || !dbg_TwoPhases then + BU.print1 "Let binding after phase 1, uvars removed: %s\n" (show e); + e) + else e + in + let attrs, post_tau = handle_postprocess_with_attr env se.sigattrs in + (* remove the postprocess_with, if any *) + let se = { se with sigattrs = attrs } in + + let postprocess_lb (tau:term) (lb:letbinding) : letbinding = + let s, univnames = SS.univ_var_opening lb.lbunivs in + let lbdef = SS.subst s lb.lbdef in + let lbtyp = SS.subst s lb.lbtyp in + let env = Env.push_univ_vars env univnames in + let lbdef = Env.postprocess env tau lbtyp lbdef in + let lbdef = SS.close_univ_vars univnames lbdef in + { lb with lbdef = lbdef } + in + let env' = + match (SS.compress e).n with + | Tm_let {lbs} -> + let se = { se with sigel = Sig_let {lbs; lids} } in + set_hint_correlator env' se + | _ -> + failwith "no way, not a let?" + in + Errors.stop_if_err (); + let r = + //We already generalized phase1; don't need to generalize again + let should_generalize = not (do_two_phases env') in + Profiling.profile (fun () -> tc_maybe_toplevel_term { env' with generalize = should_generalize } e) + (Some (Ident.string_of_lid (Env.current_module env))) + "FStarC.TypeChecker.Tc.tc_sig_let-tc-phase2" + in + let se, lbs = match r with + | {n=Tm_let {lbs; body=e}}, _, g when Env.is_trivial g -> + U.check_mutual_universes (snd lbs); + + // Propagate binder names into signature + let lbs = (fst lbs, (snd lbs) |> List.map rename_parameters) in + + // Postprocess the letbindings with the tactic, if any + let lbs = (fst lbs, + (match post_tau with + | Some tau -> List.map (postprocess_lb tau) (snd lbs) + | None -> (snd lbs))) + in + + //propagate the MaskedEffect tag to the qualifiers + let quals = match e.n with + | Tm_meta {meta=Meta_desugared Masked_effect} -> HasMaskedEffect::quals + | _ -> quals + in + { se with sigel = Sig_let {lbs; lids}; + sigquals = quals }, + lbs + | _ -> failwith "impossible (typechecking should preserve Tm_let)" + in + + // + // if no_subtyping attribute is present, typecheck the signatures with use_eq_strict + // + if U.has_attribute se.sigattrs PC.no_subtping_attr_lid + then begin + let env' = {env' with use_eq_strict=true} in + let err s pos = raise_error pos Errors.Fatal_InconsistentQualifierAnnotation s in + snd lbs |> List.iter (fun lb -> + if not (U.is_lemma lb.lbtyp) + then err ("no_subtype annotation on a non-lemma") lb.lbpos + else let lid_opt = + Free.fvars lb.lbtyp + |> elems + |> List.tryFind (fun lid -> + not (lid |> Ident.path_of_lid |> List.hd = "Prims" || + lid_equals lid PC.pattern_lid)) in + if lid_opt |> is_some + then err (BU.format1 "%s is not allowed in no_subtyping lemmas (only prims symbols)" + (lid_opt |> must |> string_of_lid)) lb.lbpos + else let t, _ = U.type_u () in + let uvs, lbtyp = SS.open_univ_vars lb.lbunivs lb.lbtyp in + let _, _, g = TcTerm.tc_check_tot_or_gtot_term + (Env.push_univ_vars env' uvs) + lbtyp + t + (Some "checking no_subtype annotation") in + Rel.force_trivial_guard env' g) + end; + + (* 4. Record the type of top-level lets, and log if requested *) + snd lbs |> List.iter (fun lb -> + let fv = right lb.lbname in + Env.insert_fv_info env fv lb.lbtyp); + + if log env + then BU.print1 "%s\n" (snd lbs |> List.map (fun lb -> + let should_log = match Env.try_lookup_val_decl env (right lb.lbname).fv_name.v with + | None -> true + | _ -> false in + if should_log + then BU.format2 "let %s : %s" (show lb.lbname) (show (*env*) lb.lbtyp) + else "") |> String.concat "\n"); + + [se], [], env0 + +let tc_decl' env0 se: list sigelt & list sigelt & Env.env = + let env = env0 in + let se = match se.sigel with + // Disable typechecking attributes for [Sig_fail] bundles, so + // that typechecking is wrapped in [Errors.catch_errors] + // below, thus allowing using [expect_failure] to mark that + // an attribute will fail typechecking. + | Sig_fail _ -> se + | _ -> tc_decl_attributes env se + in + Quals.check_sigelt_quals_pre env se; + proc_check_with se.sigattrs (fun () -> + let r = se.sigrng in + let se = + if Options.record_options () + then store_sigopts se + else se + in + match se.sigel with + | Sig_inductive_typ _ + | Sig_datacon _ -> + failwith "Impossible bare data-constructor" + + (* If we're --laxing, and this is not an `expect_lax_failure`, then just ignore the definition *) + | Sig_fail {fail_in_lax=false} when env.admit -> + if Debug.any () then + BU.print1 "Skipping %s since env.admit=true and this is not an expect_lax_failure\n" + (Print.sigelt_to_string_short se); + [], [], env + + | Sig_fail {errs=expected_errors; fail_in_lax=lax; ses} -> + let env' = if lax then { env with admit = true } else env in + let env' = Env.push env' "expect_failure" in + (* We need to call push since tc_decls will encode the sigelts that + * succeed to SMT, which may be relevant in checking the ones that + * follow it. See #1956 for an example of what goes wrong if we + * don't pop the context (spoiler: we prove false). *) + + if Debug.low () then + BU.print1 ">> Expecting errors: [%s]\n" (String.concat "; " <| List.map string_of_int expected_errors); + + let errs, _ = Errors.catch_errors (fun () -> + Options.with_saved_options (fun () -> + BU.must (!tc_decls_knot) env' ses)) in + + if Options.print_expected_failures () + || Debug.low () then + begin + BU.print_string ">> Got issues: [\n"; + List.iter Errors.print_issue errs; + BU.print_string ">>]\n" + end; + + (* Pop environment, reset SMT context *) + let _ = Env.pop env' "expect_failure" in + + let actual_errors = List.concatMap (fun i -> FStarC.Common.list_of_option i.issue_number) errs in + + begin match errs with + | [] -> + List.iter Errors.print_issue errs; + Errors.log_issue se Errors.Error_DidNotFail [ + text "This top-level definition was expected to fail, but it succeeded"; + ] + | _ -> + if expected_errors <> [] then + match Errors.find_multiset_discrepancy expected_errors actual_errors with + | None -> () + | Some (e, n1, n2) -> + let open FStarC.Pprint in + let open FStarC.Errors.Msg in + List.iter Errors.print_issue errs; + Errors.log_issue se Errors.Error_DidNotFail [ + prefix 2 1 + (text "This top-level definition was expected to raise error codes") + (pp expected_errors) ^/^ + prefix 2 1 (text "but it raised") + (pp actual_errors) ^^ + dot; + text (BU.format3 "Error #%s was raised %s times, instead of %s." + (show e) (show n2) (show n1)); + ] + end; + [], [], env + + | Sig_bundle {ses; lids} -> + let env = Env.set_range env r in + let ses = + if do_two_phases env then run_phase1 (fun _ -> + //we generate extra sigelts even in the first phase and then throw them away + //would be nice to not generate them at all + let ses = + tc_inductive ({ env with phase1 = true; admit = true }) ses se.sigquals se.sigattrs lids + |> fst + |> N.elim_uvars env + |> U.ses_of_sigbundle in + if Debug.medium () || !dbg_TwoPhases + then BU.print1 "Inductive after phase 1: %s\n" (show ({ se with sigel = Sig_bundle {ses; lids} })); + ses) + else ses + in + let sigbndle, projectors_ses = tc_inductive env ses se.sigquals se.sigattrs lids in + let sigbndle = { sigbndle with sigattrs = se.sigattrs } in (* keep the attributes *) + [ sigbndle ], projectors_ses, env0 + + | Sig_pragma p -> //no need for two-phase here + U.process_pragma p r; + [se], [], env0 + + | Sig_new_effect ne -> + let is_unelaborated_dm4f = + match ne.combinators with + | DM4F_eff combs -> + (match combs.ret_wp |> snd |> SS.compress with + | { n = Tm_unknown } -> true + | _ -> false) + | _ -> false in + + if is_unelaborated_dm4f then + let env = Env.set_range env r in + let ses, ne, lift_from_pure_opt = TcEff.dmff_cps_and_elaborate env ne in + let effect_and_lift_ses = match lift_from_pure_opt with + | Some lift -> [ { se with sigel = Sig_new_effect (ne) } ; lift ] + | None -> [ { se with sigel = Sig_new_effect (ne) } ] in + + let effect_and_lift_ses = effect_and_lift_ses |> List.map (fun sigelt -> + { sigelt with sigmeta={sigelt.sigmeta with sigmeta_admit=true}}) in + + //only elaborate, the loop in tc_decls would send these back to us for typechecking + [], ses @ effect_and_lift_ses, env0 + else + let ne = + if do_two_phases env then run_phase1 (fun _ -> + let ne = + TcEff.tc_eff_decl ({ env with phase1 = true; admit = true }) ne se.sigquals se.sigattrs + |> (fun ne -> { se with sigel = Sig_new_effect ne }) + |> N.elim_uvars env |> U.eff_decl_of_new_effect in + if Debug.medium () || !dbg_TwoPhases + then BU.print1 "Effect decl after phase 1: %s\n" + (show ({ se with sigel = Sig_new_effect ne })); + ne) + else ne in + let ne = TcEff.tc_eff_decl env ne se.sigquals se.sigattrs in + let se = { se with sigel = Sig_new_effect(ne) } in + [se], [], env0 + + | Sig_sub_effect(sub) -> //no need to two-phase here, since lifts are already lax checked + let sub = TcEff.tc_lift env sub r in + let se = { se with sigel = Sig_sub_effect sub } in + [se], [], env + + | Sig_effect_abbrev {lid; us=uvs; bs=tps; comp=c; cflags=flags} -> + let lid, uvs, tps, c = + if do_two_phases env + then run_phase1 (fun _ -> + TcEff.tc_effect_abbrev ({ env with phase1 = true; admit = true }) (lid, uvs, tps, c) r + |> (fun (lid, uvs, tps, c) -> { se with sigel = Sig_effect_abbrev {lid; + us=uvs; + bs=tps; + comp=c; + cflags=flags} }) + |> N.elim_uvars env |> + (fun se -> match se.sigel with + | Sig_effect_abbrev {lid; us=uvs; bs=tps; comp=c} -> lid, uvs, tps, c + | _ -> failwith "Did not expect Sig_effect_abbrev to not be one after phase 1")) + else lid, uvs, tps, c in + + let lid, uvs, tps, c = TcEff.tc_effect_abbrev env (lid, uvs, tps, c) r in + let se = { se with sigel = Sig_effect_abbrev {lid; + us=uvs; + bs=tps; + comp=c; + cflags=flags} } in + [se], [], env0 + + | Sig_declare_typ _ + | Sig_let _ + when se.sigquals |> BU.for_some (function OnlyName -> true | _ -> false) -> + (* Dummy declaration which must be erased since it has been elaborated somewhere else *) + [], [], env0 + + | Sig_declare_typ {lid; us=uvs; t} -> //NS: No checks on the qualifiers? + + if lid_exists env lid then + raise_error r Errors.Fatal_AlreadyDefinedTopLevelDeclaration [ + text (BU.format1 "Top-level declaration %s for a name that is already used in this module." (show lid)); + text "Top-level declarations must be unique in their module." + ]; + + let env = Env.set_range env r in + let uvs, t = + if do_two_phases env then run_phase1 (fun _ -> + let uvs, t = tc_declare_typ ({ env with phase1 = true; admit = true }) (uvs, t) se.sigrng in //|> N.normalize [Env.NoFullNorm; Env.Beta; Env.DoNotUnfoldPureLets] env in + if Debug.medium () || !dbg_TwoPhases then BU.print2 "Val declaration after phase 1: %s and uvs: %s\n" (show t) (show uvs); + uvs, t) + else uvs, t + in + + let uvs, t = tc_declare_typ env (uvs, t) se.sigrng in + [ { se with sigel = Sig_declare_typ {lid; us=uvs; t} }], [], env0 + + | Sig_assume {lid; us=uvs; phi=t} -> + if not (List.contains S.InternalAssumption se.sigquals) then + FStarC.Errors.log_issue r Warning_WarnOnUse + (BU.format1 "Admitting a top-level assumption %s" (show lid)); + let env = Env.set_range env r in + + let uvs, t = + if do_two_phases env then run_phase1 (fun _ -> + let uvs, t = tc_assume ({ env with phase1 = true; admit = true }) (uvs, t) se.sigrng in + if Debug.medium () || !dbg_TwoPhases then BU.print2 "Assume after phase 1: %s and uvs: %s\n" (show t) (show uvs); + uvs, t) + else uvs, t + in + + let uvs, t = tc_assume env (uvs, t) se.sigrng in + [ { se with sigel = Sig_assume {lid; us=uvs; phi=t} }], [], env0 + + | Sig_splice {is_typed; lids; tac=t} -> + if Debug.any () then + BU.print3 "%s: Found splice of (%s) with is_typed: %s\n" + (string_of_lid env.curmodule) + (show t) + (string_of_bool is_typed); + + // env.splice will check the tactic + + let ses = env.splice env is_typed lids t se.sigrng in + let ses = + if is_typed + then let sigquals = + match se.sigquals with + | [] -> [ S.Visible_default ] + | qs -> qs + in + List.map + (fun sp -> { sp with sigquals = sigquals@sp.sigquals; sigattrs = se.sigattrs@sp.sigattrs}) + ses + else ses + in + let ses = ses |> List.map (fun se -> + if env.is_iface && Sig_declare_typ? se.sigel + then { se with sigquals = Assumption :: (List.filter (fun q -> q <> Irreducible) se.sigquals) } + else se) + in + let ses = ses |> List.map (fun se -> { se with sigmeta = { se.sigmeta with sigmeta_spliced = true } }) in + + let dsenv = List.fold_left DsEnv.push_sigelt_force env.dsenv ses in + let env = { env with dsenv = dsenv } in + + if Debug.low () then + BU.print1 "Splice returned sigelts {\n%s\n}\n" + (String.concat "\n" <| List.map show ses); + + (* sigelts returned by splice_t can be marked with sigmeta + already_checked, and those will be skipped on the next run. But they do + run through the pipeline again. This also allows a splice tactic + to return any mixture of checked and unchecked sigelts. *) + [], ses, env + + | Sig_let {lbs; lids} -> + Profiling.profile + (fun () -> tc_sig_let env r se lbs lids) + (Some (Ident.string_of_lid (Env.current_module env))) + "FStarC.TypeChecker.Tc.tc_sig_let" + + | Sig_polymonadic_bind {m_lid=m; n_lid=n; p_lid=p; tm=t} -> //desugaring does not set the last two fields, tc does + let t = + if do_two_phases env then run_phase1 (fun _ -> + let t, ty = + TcEff.tc_polymonadic_bind ({ env with phase1 = true; admit = true }) m n p t + |> (fun (t, ty, _) -> { se with sigel = Sig_polymonadic_bind {m_lid=m; + n_lid=n; + p_lid=p; + tm=t; + typ=ty; + kind=None} }) + |> N.elim_uvars env + |> (fun se -> + match se.sigel with + | Sig_polymonadic_bind {tm=t; typ=ty} -> t, ty + | _ -> failwith "Impossible! tc for Sig_polymonadic_bind must be a Sig_polymonadic_bind") in + if Debug.medium () || !dbg_TwoPhases + then BU.print1 "Polymonadic bind after phase 1: %s\n" + (show ({ se with sigel = Sig_polymonadic_bind {m_lid=m; + n_lid=n; + p_lid=p; + tm=t; + typ=ty; + kind=None} })); + t) + else t in + let t, ty, k = TcEff.tc_polymonadic_bind env m n p t in + let se = ({ se with sigel = Sig_polymonadic_bind {m_lid=m; + n_lid=n; + p_lid=p; + tm=t; + typ=ty; + kind=Some k} }) in + [se], [], env0 + + | Sig_polymonadic_subcomp {m_lid=m; n_lid=n; tm=t} -> //desugaring does not set the last two fields, tc does + let t = + if do_two_phases env then run_phase1 (fun _ -> + let t, ty = + TcEff.tc_polymonadic_subcomp ({ env with phase1 = true; admit = true }) m n t + |> (fun (t, ty, _) -> { se with sigel = Sig_polymonadic_subcomp {m_lid=m; + n_lid=n; + tm=t; + typ=ty; + kind=None} }) + |> N.elim_uvars env + |> (fun se -> + match se.sigel with + | Sig_polymonadic_subcomp {tm=t; typ=ty} -> t, ty + | _ -> failwith "Impossible! tc for Sig_polymonadic_subcomp must be a Sig_polymonadic_subcomp") in + if Debug.medium () || !dbg_TwoPhases + then BU.print1 "Polymonadic subcomp after phase 1: %s\n" + (show ({ se with sigel = Sig_polymonadic_subcomp {m_lid=m; + n_lid=n; + tm=t; + typ=ty; + kind=None} })); + t) + else t in + let t, ty, k = TcEff.tc_polymonadic_subcomp env m n t in + let se = ({ se with sigel = Sig_polymonadic_subcomp {m_lid=m; + n_lid=n; + tm=t; + typ=ty; + kind=Some k} }) in + [se], [], env0) + + +(* [tc_decl env se] typechecks [se] in environment [env] and returns * + * the list of typechecked sig_elts, and a list of new sig_elts elaborated + * during typechecking but not yet typechecked *) +let tc_decl env se: list sigelt & list sigelt & Env.env = + FStarC.GenSym.reset_gensym(); + let env0 = env in + let env = set_hint_correlator env se in + let env = + (* This is the SINGLE point where we read admit_smt_queries + and pass it through into the .admit field. *) + if Options.admit_smt_queries () + then { env with admit = true } + else env + in + if Debug.any () then + BU.print1 "Processing %s\n" (Print.sigelt_to_string_short se); + if Debug.medium () then + BU.print2 ">>>>>>>>>>>>>>tc_decl admit=%s %s\n" (show env.admit) (show se); + let result = + if se.sigmeta.sigmeta_already_checked then + [se], [], env + else if se.sigmeta.sigmeta_admit then ( + let result = tc_decl' { env with admit = true } se in + result + ) else + tc_decl' env se + in + let () = + (* Do the post-tc attribute/qualifier check. *) + let (ses, _, _) = result in + List.iter (Quals.check_sigelt_quals_post env) ses + in + (* Restore admit *) + let result = + let ses, ses_e, env = result in + ses, ses_e, { env with admit = env0.admit } + in + result + +(* adds the typechecked sigelt to the env, also performs any processing required in the env (such as reset options) *) +(* AR: we now call this function when loading checked modules as well to be more consistent *) +let add_sigelt_to_env (env:Env.env) (se:sigelt) (from_cache:bool) : Env.env = + if Debug.low () + then BU.print2 + ">>>>>>>>>>>>>>Adding top-level decl to environment: %s (from_cache:%s)\n" + (Print.sigelt_to_string_short se) (show from_cache); + + match se.sigel with + | Sig_inductive_typ _ + | Sig_datacon _ -> + raise_error se Errors.Fatal_UnexpectedInductivetype + (BU.format1 "add_sigelt_to_env: unexpected bare type/data constructor: %s" (show se)) + + | Sig_declare_typ _ + | Sig_let _ when se.sigquals |> BU.for_some (function OnlyName -> true | _ -> false) -> env + + | _ -> + let env = Env.push_sigelt env se in + //match again to perform postprocessing + match se.sigel with + | Sig_pragma ShowOptions -> + Errors.info se [ + text "Option state:"; + Pprint.arbitrary_string (Options.show_options ()); + ]; + env + + | Sig_pragma (PushOptions _) + | Sig_pragma PopOptions + | Sig_pragma (SetOptions _) + | Sig_pragma (ResetOptions _) -> + if from_cache then env + else + (* we keep --using_facts_from reflected in the environment, so update it here *) + ({ env with proof_ns = Options.using_facts_from () }) + + | Sig_pragma RestartSolver -> + (* `flychecking` marks when an interactive F* is peeking via flycheck, + * we shouldn't reset the solver at that point, only when the user + * advances over the pragma. *) + if from_cache || env.flychecking then env + else begin + env.solver.refresh (Some env.proof_ns); + env + end + + | Sig_pragma PrintEffectsGraph -> + BU.write_file "effects.graph" (Env.print_effects_graph env); + env + + | Sig_new_effect ne -> + let env = Env.push_new_effect env (ne, se.sigquals) in + ne.actions |> List.fold_left (fun env a -> Env.push_sigelt env (U.action_as_lb ne.mname a a.action_defn.pos)) env + + | Sig_sub_effect sub -> TcUtil.update_env_sub_eff env sub se.sigrng + + | Sig_polymonadic_bind {m_lid=m;n_lid=n;p_lid=p;typ=ty;kind=k} -> TcUtil.update_env_polymonadic_bind env m n p ty (k |> must) + + | Sig_polymonadic_subcomp {m_lid=m; n_lid=n; typ=ty; kind=k} -> Env.add_polymonadic_subcomp env m n (ty, k |> must) + + | _ -> env + +(* This function is called when promoting entries in the id info table. + If t has no dangling uvars, it is normalized and promoted, + otherwise discarded *) +let compress_and_norm env t = + match Compress.deep_compress_if_no_uvars t with + | None -> None //if dangling uvars, then just drop this entry + | Some t -> //otherwise, normalize and promote + Some ( + N.normalize + [Env.AllowUnboundUniverses; //this is allowed, since we're reducing types that appear deep within some arbitrary context + Env.CheckNoUvars; + Env.Beta; Env.DoNotUnfoldPureLets; Env.CompressUvars; + Env.Exclude Env.Zeta; Env.Exclude Env.Iota; Env.NoFullNorm] + env + t + ) + +let tc_decls env ses = + let rec process_one_decl (ses, env) se = + Errors.fallback_range := Some se.sigrng; + + (* If emacs is peeking, and debugging is on, don't do anything, + * otherwise the user will see a bunch of output from typechecking + * definitions that were not yet advanced over. *) + if env.flychecking && Debug.any () + then (ses, env), [] + else begin + if Debug.low () + then BU.print2 ">>>>>>>>>>>>>>Checking top-level %s decl %s\n" + (tag_of se) + (Print.sigelt_to_string_short se); + + if Options.ide_id_info_off() then Env.toggle_id_info env false; + if !dbg_IdInfoOn then Env.toggle_id_info env true; + + let ses', ses_elaborated, env = + Errors.with_ctx (BU.format2 "While typechecking the %stop-level declaration `%s`" + (if se.sigmeta.sigmeta_spliced then "(spliced) " else "") + (Print.sigelt_to_string_short se)) + (fun () -> tc_decl env se) + in + + let ses' = ses' |> List.map (fun se -> + if !dbg_UF + then BU.print1 "About to elim vars from %s\n" (show se); + N.elim_uvars env se) in + let ses_elaborated = ses_elaborated |> List.map (fun se -> + if !dbg_UF + then BU.print1 "About to elim vars from (elaborated) %s\n" (show se); + N.elim_uvars env se) in + + Env.promote_id_info env (compress_and_norm env); + + // Compress all checked sigelts. Uvars and names are not OK after a full typecheck + let ses' = ses' |> List.map (Compress.deep_compress_se false false) in + + // Make sure to update all the delta_depths of the definitions we will add to the + // environment. These can change if the body of the letbinding is transformed by any means, + // such as by resolving an `_ by ...`, or a pre/post process hook. + // let fixup_dd_lb (lb:letbinding) : letbinding = + // (* The delta depth of the fv is 1 + the dd of its body *) + // let Inr fv = lb.lbname in + // // BU.print2_error "Checking depth of %s = %s\n" (show lb.lbname) (show fv.fv_delta); + // // let dd = incr_delta_depth <| delta_qualifier lb.lbdef in + // let dd = incr_delta_depth <| delta_depth_of_term env lb.lbdef in + // // if Some dd <> fv.fv_delta then ( + // // BU.print3_error "Fixing up delta depth of %s from %s to %s\n" (show lb.lbname) (show fv.fv_delta) (show dd) + // // ); + // // BU.print1_error "Definition = (%s)\n\n" (show lb.lbdef); + // let fv = { fv with fv_delta = Some dd } in + // { lb with lbname = Inr fv } + // in + // let fixup_delta_depth (se:sigelt) : sigelt = + // match se.sigel with + // | Sig_let {lbs; lids} -> + // let lbs = fst lbs, List.map fixup_dd_lb (snd lbs) in + // { se with sigel = Sig_let {lbs; lids} } + // | _ -> se + // in + // let ses' = ses' |> List.map fixup_delta_depth in + + // Add to the environment + let env = ses' |> List.fold_left (fun env se -> add_sigelt_to_env env se false) env in + UF.reset(); + + if Options.log_types () || Debug.medium () || !dbg_LogTypes + then BU.print1 "Checked: %s\n" (show ses'); + + Profiling.profile + (fun () -> List.iter (fun se -> env.solver.encode_sig env se) ses') + (Some (Ident.string_of_lid (Env.current_module env))) + "FStarC.TypeChecker.Tc.encode_sig"; + + (List.rev_append ses' ses, env), ses_elaborated + end + in + // A wrapper to (maybe) print the time taken for each sigelt + let process_one_decl_timed acc se = + FStarC.TypeChecker.Core.clear_memo_table(); + let (_, env) = acc in + let r = + Profiling.profile + (fun () -> process_one_decl acc se) + (Some (Ident.string_of_lid (Env.current_module env))) + "FStarC.TypeChecker.Tc.process_one_decl" + // ^ See a special case for this phase in FStarC.Options. --timing + // enables it. + in + if Options.profile_group_by_decl() + || Options.timing () // --timing implies --profile_group_by_decl + then begin + let tag = + match lids_of_sigelt se with + | hd::_ -> Ident.string_of_lid hd + | _ -> Range.string_of_range (range_of_sigelt se) + in + Profiling.report_and_clear tag + end; + r + in + let ses, env = + UF.with_uf_enabled (fun () -> + BU.fold_flatten process_one_decl_timed ([], env) ses) in + List.rev_append ses [], env + +let _ = + tc_decls_knot := Some tc_decls + +let snapshot_context env msg = BU.atomically (fun () -> + TypeChecker.Env.snapshot env msg) + +let rollback_context solver msg depth : env = BU.atomically (fun () -> + let env = TypeChecker.Env.rollback solver msg depth in + env) + +let push_context env msg = snd (snapshot_context env msg) +let pop_context env msg = rollback_context env.solver msg None + +let tc_partial_modul env modul = + let verify = Options.should_verify (string_of_lid modul.name) in + let action = if verify then "verifying" else "lax-checking" in + let label = if modul.is_interface then "interface" else "implementation" in + if Debug.any () then + BU.print3 "Now %s %s of %s\n" action label (string_of_lid modul.name); + + Debug.disable_all (); + if Options.should_check (string_of_lid modul.name) // || Options.debug_all_modules () + then Debug.enable_toggles (Options.debug_keys ()); + + let name = BU.format2 "%s %s" (if modul.is_interface then "interface" else "module") (string_of_lid modul.name) in + let env = {env with Env.is_iface=modul.is_interface; admit=not verify} in + let env = Env.set_current_module env modul.name in + (* Only set a context for dependencies *) + Errors.with_ctx_if (not (Options.should_check (string_of_lid modul.name))) + (BU.format2 "While loading dependency %s%s" + (string_of_lid modul.name) + (if modul.is_interface then " (interface)" else "")) (fun () -> + let ses, env = tc_decls env modul.declarations in + {modul with declarations=ses}, env + ) + +let tc_more_partial_modul env modul decls = + let ses, env = tc_decls env decls in + let modul = {modul with declarations=modul.declarations@ses} in + modul, ses, env + +let finish_partial_modul (loading_from_cache:bool) (iface_exists:bool) (en:env) (m:modul) : (modul & env) = + //AR: do we ever call finish_partial_modul for current buffer in the interactive mode? + let env = Env.finish_module en m in + + if not loading_from_cache then ( + let missing = missing_definition_list env in + if Cons? missing then + log_issue env Errors.Error_AdmitWithoutDefinition [ + Pprint.prefix 2 1 (text <| BU.format1 "Missing definitions in module %s:" (string_of_lid m.name)) + (Pprint.separate_map Pprint.hardline (fun l -> pp (ident_of_lid l)) missing) + ] + ); + + //we can clear the lid to query index table + env.qtbl_name_and_index |> snd |> BU.smap_clear; + + //pop BUT ignore the old env + + pop_context env ("Ending modul " ^ string_of_lid m.name) |> ignore; + + if Options.depth () > 0 then + Errors.log_issue env Error_MissingPopOptions + ("Some #push-options have not been popped. Current depth is " ^ show (Options.depth()) ^ "."); + + //moved the code for encoding the module to smt to Universal + + m, env + +let deep_compress_modul (m:modul) : modul = + { m with declarations = List.map (Compress.deep_compress_se false false) m.declarations } + +let tc_modul (env0:env) (m:modul) (iface_exists:bool) :(modul & env) = + let msg = "Internals for " ^ string_of_lid m.name in + //AR: push env, this will also push solver, and then finish_partial_modul will do the pop + let env0 = push_context env0 msg in + let modul, env = tc_partial_modul env0 m in + // Note: all sigelts returned by tc_partial_modul must already be compressed + // by Syntax.compress.deep_compress, so they are safe to output. + finish_partial_modul false iface_exists env modul + +let load_checked_module_sigelts (en:env) (m:modul) : env = + //This function tries to very carefully mimic the effect of the environment + //of having checked the module from scratch, i.e., using tc_module below + let env = Env.set_current_module en m.name in + //push context, finish_partial_modul will do the pop + let env = push_context env ("Internals for " ^ Ident.string_of_lid m.name) in + let env = List.fold_left (fun env se -> + //add every sigelt in the environment + let env = add_sigelt_to_env env se true in + //and then query it back immediately to populate the environment's internal cache + //this is important for extraction to work correctly, + //in particular, when extracting a module we want the module's internal symbols + //that may be marked "abstract" externally to be visible internally + //populating the cache enables this behavior, rather indirectly, sadly : ( + let lids = Util.lids_of_sigelt se in + lids |> List.iter (fun lid -> ignore (Env.lookup_sigelt env lid)); + env) + env + m.declarations in + env + +let load_checked_module (en:env) (m:modul) :env = + (* Another compression pass to make sure we are not loading a corrupt + module. *) + + (* Reset debug flags *) + if Options.should_check (string_of_lid m.name) || Options.debug_all_modules () + then Debug.enable_toggles (Options.debug_keys ()) + else Debug.disable_all (); + + let m = deep_compress_modul m in + let env = load_checked_module_sigelts en m in + //And then call finish_partial_modul, which is the normal workflow of tc_modul below + //except with the flag `must_check_exports` set to false, since this is already a checked module + //the second true flag is for iface_exists, used to determine whether should extract interface or not + let _, env = finish_partial_modul true true env m in + env + +let load_partial_checked_module (en:env) (m:modul) : env = + let m = deep_compress_modul m in + load_checked_module_sigelts en m + +let check_module env0 m b = + if Debug.any() + then BU.print2 "Checking %s: %s\n" (if m.is_interface then "i'face" else "module") (show m.name); + if Options.dump_module (string_of_lid m.name) + then BU.print1 "Module before type checking:\n%s\n" (show m); + + let env = {env0 with admit = not (Options.should_verify (string_of_lid m.name))} in + let m, env = tc_modul env m b in + (* restore admit *) + let env = { env with admit = env0.admit } in + + (* Debug information for level Normalize : normalizes all toplevel declarations an dump the current module *) + if Options.dump_module (string_of_lid m.name) + then BU.print1 "Module after type checking:\n%s\n" (show m); + if Options.dump_module (string_of_lid m.name) && !dbg_Normalize + then begin + let normalize_toplevel_lets = fun se -> match se.sigel with + | Sig_let {lbs=(b, lbs); lids=ids} -> + let n = N.normalize [Env.Beta ; Env.Eager_unfolding; Env.Reify ; Env.Inlining ; Env.Primops ; Env.UnfoldUntil S.delta_constant ; Env.AllowUnboundUniverses ] in + let update lb = + let univnames, e = SS.open_univ_vars lb.lbunivs lb.lbdef in + { lb with lbdef = n (Env.push_univ_vars env univnames) e } + in + { se with sigel = Sig_let {lbs=(b, List.map update lbs); lids=ids} } + | _ -> se + in + let normalized_module = { m with declarations = List.map normalize_toplevel_lets m.declarations } in + BU.print1 "%s\n" (show normalized_module) + end; + + m, env diff --git a/src/typechecker/FStarC.TypeChecker.Tc.fsti b/src/typechecker/FStarC.TypeChecker.Tc.fsti new file mode 100644 index 00000000000..7aa6e1b4afd --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Tc.fsti @@ -0,0 +1,37 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.TypeChecker.Tc +open FStarC.Compiler.Effect +open FStarC.Compiler.Effect +open FStarC.Syntax.Syntax +open FStarC.TypeChecker.Env +open FStarC.TypeChecker.Common +module EMB = FStarC.Syntax.Embeddings + + +val check_module: env -> modul -> bool -> modul & env +val load_checked_module: env -> modul -> env +val load_partial_checked_module: env -> modul -> env + +val pop_context: env -> string -> env +val push_context: env -> string -> env +val snapshot_context: env -> string -> ((int & int & solver_depth_t & int) & env) +val rollback_context: solver_t -> string -> option (int & int & solver_depth_t & int) -> env + +val compress_and_norm: env -> typ -> option typ +val tc_decls: env -> list sigelt -> list sigelt & env +val tc_partial_modul: env -> modul -> modul & env +val tc_more_partial_modul: env -> modul -> list sigelt -> modul & list sigelt & env diff --git a/src/typechecker/FStarC.TypeChecker.TcEffect.fst b/src/typechecker/FStarC.TypeChecker.TcEffect.fst new file mode 100644 index 00000000000..152c5110ef0 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.TcEffect.fst @@ -0,0 +1,2770 @@ +(* + Copyright 2008-2018 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.TypeChecker.TcEffect +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.Syntax +open FStarC.TypeChecker + +open FStarC.Compiler.Util +open FStarC.Ident +open FStarC.Errors +open FStarC.Syntax.Syntax +open FStarC.TypeChecker.Env +open FStarC.TypeChecker.Common +open FStarC.TypeChecker.TcTerm + +module PC = FStarC.Parser.Const +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module U = FStarC.Syntax.Util +module Env = FStarC.TypeChecker.Env +module N = FStarC.TypeChecker.Normalize +module TcUtil = FStarC.TypeChecker.Util +module Gen = FStarC.TypeChecker.Generalize +module TEQ = FStarC.TypeChecker.TermEqAndSimplify + +module BU = FStarC.Compiler.Util +open FStarC.Class.Show +open FStarC.Class.Tagged + +let dbg = Debug.get_toggle "ED" +let dbg_LayeredEffectsTc = Debug.get_toggle "LayeredEffectsTc" + +let dmff_cps_and_elaborate env ed = + (* This is only an elaboration rule not a typechecking one *) + + // Let the power of Dijkstra generate everything "for free", then defer + // the rest of the job to [tc_decl]. + DMFF.cps_and_elaborate env ed + +(* + * Helper function used to typecheck and generalize various effect combinators + * + * comb is the name of the combinator (used for error messages) + * n is the number of universes that the combinator should be polymorphic in + * (us, t) is the tscheme to check and generalize (us will be [] in the first phase) + *) +let check_and_gen env (eff_name:string) (comb:string) (n:int) (us, t) : (univ_names & term & typ) = + Errors.with_ctx ("While checking combinator " ^ comb ^ " = " ^ show (us, t)) (fun () -> + let us, t = SS.open_univ_vars us t in + let t, ty = + let t, lc, g = tc_tot_or_gtot_term (Env.push_univ_vars env us) t in + Rel.force_trivial_guard env g; + t, lc.res_typ in + let g_us, t = Gen.generalize_universes env t in + let ty = SS.close_univ_vars g_us ty in + //check that n = List.length g_us and that if us is set, it is same as g_us + let univs_ok = + if List.length g_us <> n then + let error = BU.format5 + "Expected %s:%s to be universe-polymorphic in %s universes, but found %s (tscheme: %s)" + eff_name comb (string_of_int n) (g_us |> List.length |> string_of_int) + (Print.tscheme_to_string (g_us, t)) in + raise_error t Errors.Fatal_MismatchUniversePolymorphic error; + match us with + | [] -> () + | _ -> + if List.length us = List.length g_us && + List.forall2 (fun u1 u2 -> S.order_univ_name u1 u2 = 0) us g_us + then () + else raise_error t Errors.Fatal_UnexpectedNumberOfUniverse + (BU.format4 "Expected and generalized universes in the declaration for %s:%s are different, input: %s, but after gen: %s" + eff_name comb (show us) (show g_us)) + in + g_us, t, ty + ) + +(* + * A small gadget to get a uvar for pure wp with given result type + *) +let pure_wp_uvar env (t:typ) (reason:string) (r:Range.range) : term & guard_t = + let pure_wp_t = + let pure_wp_ts = Env.lookup_definition [Env.NoDelta] env PC.pure_wp_lid |> must in + let _, pure_wp_t = Env.inst_tscheme pure_wp_ts in + S.mk_Tm_app + pure_wp_t + [t |> S.as_arg] + r in + + let pure_wp_uvar, _, guard_wp = Env.new_implicit_var_aux reason r env pure_wp_t Strict None false in + pure_wp_uvar, guard_wp + +let (let?) (#a #b:Type) (f:option a) (g:a -> option b) : option b = + match f with + | None -> None + | Some x -> g x + +let mteq (env:env) (t1 t2:typ) : bool = + try + Rel.teq_nosmt_force env t1 t2 + with + | _ -> false + +// +// A gadget used to check for effect combinator kind (substitutive or ad-hoc) +// +// bs1 and bs2 are opened binders from the signature and the effect combinator +// +let eq_binders env (bs1 bs2:binders) : option (list S.indexed_effect_binder_kind) = + if List.fold_left2 (fun (b, ss) b1 b2 -> + b && + mteq env (SS.subst ss b1.binder_bv.sort) b2.binder_bv.sort, + ss@[NT (b1.binder_bv, b2.binder_bv |> S.bv_to_name)]) (true, []) bs1 bs2 + + |> fst + then bs1 |> List.map (fun _ -> Substitutive_binder) |> Some + else None + +let log_ad_hoc_combinator_warning (comb_name:string) (r:Range.range) = + log_issue r Errors.Warning_Adhoc_IndexedEffect_Combinator [ + Errors.text (BU.format1 "Combinator %s is not a substitutive indexed effect combinator, \ + it is better to make it one if possible for better performance and ease of use" comb_name) + ] + +// +// Check bind combinator kind for an indexed effect or polymonadic bind +// +// k is the bind type (in the general indexed effects bind shape) +// +// num_effect_params must be 0 for polymonadic binds +// +// returns None if bind is not Substitutive +// else Some l, where l is the list of binder kinds +// +let bind_combinator_kind (env:env) + (m_eff_name n_eff_name p_eff_name:lident) + (m_sig_ts n_sig_ts p_sig_ts:tscheme) + (m_repr_ts n_repr_ts p_repr_ts:option tscheme) + (bind_us:univ_names) + (k:typ) + (num_effect_params:int) + (has_range_binders:bool) + : option (list indexed_effect_binder_kind) = + + let debug s = + if Debug.medium () || !dbg_LayeredEffectsTc + then BU.print1 "%s\n" s in + + debug (BU.format1 + "Checking bind combinator kind with %s effect parameters" + (string_of_int num_effect_params)); + + // we know k = a:Type u_a -> b:Type u_b -> rest_bs -> optional_range_bs -> f -> g -> Pure repr wp + + let [u_a; u_b] = bind_us in + + let (a_b::b_b::rest_bs) = k |> U.arrow_formals |> fst in + + // we will check that every binder in k has the expected type, + // where the expected types will come from the signatures of the effects + + // check that rest_bs has expected effect parameters + // to check expected, we use the signature from m, + // for polymonadic binds num effect parameters is 0, + // so this code will return from the then branch + let? eff_params_bs, eff_params_bs_kinds, rest_bs = + if num_effect_params = 0 + then ([], [], rest_bs) |> Some + else // take the num effect parameters from m's signature and + // check that those binders are equal to those in k + let _, sig = Env.inst_tscheme_with m_sig_ts [U_name u_a] in + let sig_bs = sig |> U.arrow_formals + |> fst + |> List.tl in + let? sig_eff_params_bs = + if List.length sig_bs < num_effect_params + then None + else List.splitAt num_effect_params sig_bs |> fst |> Some in + let? eff_params_bs, rest_bs = + if List.length rest_bs < num_effect_params + then None + else List.splitAt num_effect_params rest_bs |> Some in + let? eff_params_bs_kinds = eq_binders env sig_eff_params_bs eff_params_bs in + (eff_params_bs, eff_params_bs_kinds, rest_bs) |> Some in + + // check that prefix of rest_bs matches the binders in f's repr + let? f_bs, f_bs_kinds, rest_bs = + // binders in f's signature, + // after substituting eff_params_bs (we need to check for binder equality) + let f_sig_bs = + let _, sig = Env.inst_tscheme_with m_sig_ts [U_name u_a] in + sig |> U.arrow_formals + |> fst + |> (fun (a::bs) -> + let sig_bs, bs = List.splitAt num_effect_params bs in + let ss = List.fold_left2 (fun ss sig_b b -> + ss@[NT (sig_b.binder_bv, b.binder_bv |> S.bv_to_name)] + ) [NT (a.binder_bv, a_b.binder_bv |> S.bv_to_name)] sig_bs eff_params_bs in + bs |> SS.subst_binders ss) in + + let? f_bs, rest_bs = + if List.length rest_bs < List.length f_sig_bs + then None + else List.splitAt (List.length f_sig_bs) rest_bs |> Some in + + let? f_bs_kinds = eq_binders env f_sig_bs f_bs in + + (f_bs, f_bs_kinds, rest_bs) |> Some in + + // same thing for g + + let? g_bs, g_bs_kinds, rest_bs = + let g_sig_bs = + let _, sig = Env.inst_tscheme_with n_sig_ts [U_name u_b] in + sig |> U.arrow_formals + |> fst + |> (fun (b::bs) -> + let sig_bs, bs = List.splitAt num_effect_params bs in + let ss = List.fold_left2 (fun ss sig_b b -> + ss@[NT (sig_b.binder_bv, b.binder_bv |> S.bv_to_name)] + ) [NT (b.binder_bv, b_b.binder_bv |> S.bv_to_name)] sig_bs eff_params_bs in + bs |> SS.subst_binders ss) in + + let? g_bs, rest_bs = + if List.length rest_bs < List.length g_sig_bs + then None + else List.splitAt (List.length g_sig_bs) rest_bs |> Some in + + // + // g's binders may be either abstracted over x:a or un-abstracted, + // so we can't simply do eq_binders, we need to check one binder at a time + // + let? g_bs_kinds = + let g_bs_kinds, _ = List.fold_left2 (fun (l, ss) g_sig_b g_b -> // l is the (bv, kind) list for the binders seen so far + let g_sig_b_sort = SS.subst ss g_sig_b.binder_bv.sort in + let g_sig_b_arrow_t = // expected sort of g_b if the binder were abstracted + let x_bv = S.gen_bv "x" None (a_b.binder_bv |> S.bv_to_name) in + let ss = List.map (fun (bv, k) -> + if k = Substitutive_binder + then [NT (bv, mk_Tm_app (S.bv_to_name bv) [x_bv |> S.bv_to_name |> S.as_arg] Range.dummyRange)] + else []) l |> List.flatten in + let g_sig_b_sort = SS.subst ss g_sig_b_sort in + U.arrow [S.mk_binder x_bv] + (mk_Total g_sig_b_sort) in + let g_b_kind = + if TEQ.eq_tm env g_sig_b_arrow_t g_b.binder_bv.sort = TEQ.Equal + then Substitutive_binder + else if TEQ.eq_tm env g_sig_b_sort g_b.binder_bv.sort = TEQ.Equal + then BindCont_no_abstraction_binder + else Ad_hoc_binder in + let ss = ss@[NT (g_sig_b.binder_bv, g_b.binder_bv |> S.bv_to_name)] in + l@[g_b.binder_bv, g_b_kind], ss) ([], []) g_sig_bs g_bs in + + let g_bs_kinds = List.map snd g_bs_kinds in + if List.contains Ad_hoc_binder g_bs_kinds + then None + else g_bs_kinds |> Some in + + (g_bs, g_bs_kinds, rest_bs) |> Some in + + // peel off range binders if any + + let (range_bs, rest_bs) : (list binder & list binder) = + if has_range_binders + then List.splitAt 2 rest_bs + else [], rest_bs in + + let? rest_bs, f_b, g_b = + if List.length rest_bs >= 2 + then let rest_bs, [f_b; g_b] = List.splitAt (List.length rest_bs - 2) rest_bs in + (rest_bs, f_b, g_b) |> Some + else None in + + // check that the type of the f repr is ok + let? _f_b_ok_ = + let repr_app_bs = eff_params_bs@f_bs in + let expected_f_b_sort = + match m_repr_ts with + | Some repr_ts -> // an indexed effect, so repr applied to a and bs + let _, t = Env.inst_tscheme_with repr_ts [U_name u_a] in + S.mk_Tm_app t + ((a_b.binder_bv |> S.bv_to_name |> S.as_arg):: + (List.map (fun {binder_bv=b} -> b |> S.bv_to_name |> S.as_arg) repr_app_bs)) + Range.dummyRange + | None -> // a primitive effect, so unit -> M a bs + U.arrow [S.null_binder S.t_unit] + (mk_Comp ({ + comp_univs = [U_name u_a]; + effect_name = m_eff_name; + result_typ = a_b.binder_bv |> S.bv_to_name; + effect_args = repr_app_bs |> List.map (fun b -> b.binder_bv |> S.bv_to_name |> S.as_arg); + flags = []})) in + if TEQ.eq_tm env f_b.binder_bv.sort expected_f_b_sort = TEQ.Equal + then Some () + else None in + + // check that the type of g repr is ok + let? _g_b_ok = + let expected_g_b_sort = + let x_bv = S.gen_bv "x" None (a_b.binder_bv |> S.bv_to_name) in + let eff_params_args = List.map (fun {binder_bv=b} -> b |> S.bv_to_name |> S.as_arg) eff_params_bs in + let g_bs_args = + List.map2 (fun {binder_bv=b} kind -> + // we know here that kind is either Substitutive or BindCont_no_abs + if kind = Substitutive_binder + then S.mk_Tm_app (b |> S.bv_to_name) [x_bv |> S.bv_to_name |> S.as_arg] Range.dummyRange + else b |> S.bv_to_name) g_bs g_bs_kinds + |> List.map S.as_arg in + let repr_args = eff_params_args@g_bs_args in + + match n_repr_ts with + | Some repr_ts -> + let _, repr_hd = Env.inst_tscheme_with repr_ts [U_name u_b] in + let repr_app = mk_Tm_app repr_hd + ((b_b.binder_bv |> S.bv_to_name |> S.as_arg)::repr_args) + Range.dummyRange in + U.arrow [x_bv |> S.mk_binder] (mk_Total repr_app) + | None -> + let thunk_t = U.arrow [S.null_binder S.t_unit] + (mk_Comp ({ + comp_univs = [U_name u_b]; + effect_name = n_eff_name; + result_typ = b_b.binder_bv |> S.bv_to_name; + effect_args = repr_args; + flags = []})) in + U.arrow [x_bv |> S.mk_binder] (mk_Total thunk_t) in + if TEQ.eq_tm env g_b.binder_bv.sort expected_g_b_sort = TEQ.Equal + then Some () + else None in + + let range_kinds = List.map (fun _ -> Range_binder) range_bs in + + // remaining binders in rest_bs are all ad-hoc + let rest_kinds = List.map (fun _ -> Ad_hoc_binder) rest_bs in + + Some ([Type_binder; Type_binder] @ + eff_params_bs_kinds @ + f_bs_kinds @ + g_bs_kinds @ + range_kinds @ + rest_kinds @ + [Repr_binder; Repr_binder]) + +// +// Validate that the indexed effect bind has the expected shape, +// and return its canonical type and combinator kind +// +let validate_indexed_effect_bind_shape (env:env) + (m_eff_name n_eff_name p_eff_name:lident) + (m_sig_ts n_sig_ts p_sig_ts:tscheme) + (m_repr_ts n_repr_ts p_repr_ts:option tscheme) + (bind_us:univ_names) + (bind_t:typ) + (r:Range.range) + (num_effect_params:int) + (has_range_binders:bool) + : typ & indexed_effect_combinator_kind = + + let bind_name = BU.format3 "(%s , %s) |> %s" + (string_of_lid m_eff_name) + (string_of_lid n_eff_name) + (string_of_lid p_eff_name) in + + let [u_a; u_b] = bind_us in + + // + // First check that bind has the general shape: + // a:Type u_a -> b:Type u_b -> some_bs -> optional_range_bs -> f -> g -> PURE repr wp + // + // We do so by creating expected type k = the arrow type above, + // and unifying it with bind_t + // + + // a:Type and b:Type binders + let a_b = (U_name u_a) |> U.type_with_u |> S.gen_bv "a" None |> S.mk_binder in + let b_b = (U_name u_b) |> U.type_with_u |> S.gen_bv "b" None |> S.mk_binder in + + // rest_bs are opened and have their a and b substituted with a_b and b_b + let rest_bs = + match (SS.compress bind_t).n with + | Tm_arrow {bs} when List.length bs >= 4 -> + // peel off a and b from bs + let ({binder_bv=a})::({binder_bv=b})::bs = SS.open_binders bs in + // peel off f and g from the end of bs + bs |> List.splitAt (List.length bs - 2) |> fst + |> SS.subst_binders [NT (a, a_b.binder_bv |> S.bv_to_name); + NT (b, b_b.binder_bv |> S.bv_to_name)] + | _ -> + raise_error r Errors.Fatal_UnexpectedEffect + (BU.format2 "Type of %s is not an arrow with >= 4 binders (%s)" + bind_name + (show bind_t)) in + + + // peel off range binders from the end, if any + let rest_bs, range_bs = + if has_range_binders + then if List.length rest_bs >= 2 + then List.splitAt (List.length rest_bs - 2) rest_bs + else raise_error r Errors.Fatal_UnexpectedEffect + (BU.format2 "Type of %s is not an arrow with >= 6 binders (%s)" + bind_name + (show bind_t)) + else rest_bs, [] in + + // f binder with sort m_repr ?us + let f, guard_f = + let repr, g = TcUtil.fresh_effect_repr + (Env.push_binders env (a_b::b_b::rest_bs)) + r + m_eff_name + m_sig_ts + m_repr_ts + (U_name u_a) + (a_b.binder_bv |> S.bv_to_name) in + repr |> S.gen_bv "f" None |> S.mk_binder, g in + + // g binder with sort (x:a -> n_repr ?us) + let g, guard_g = + let x_a = a_b.binder_bv |> S.bv_to_name |> S.gen_bv "x" None |> S.mk_binder in + let repr, g = TcUtil.fresh_effect_repr + (Env.push_binders env (a_b::b_b::rest_bs@[x_a])) + r + n_eff_name + n_sig_ts + n_repr_ts + (U_name u_b) + (b_b.binder_bv |> S.bv_to_name) in + S.gen_bv "g" None (U.arrow [x_a] (S.mk_Total repr)) |> S.mk_binder, + g in + + // return repr type p_repr ?us + let return_repr, guard_return_repr = TcUtil.fresh_effect_repr + (Env.push_binders env (a_b::b_b::rest_bs)) + r + p_eff_name + p_sig_ts + p_repr_ts + (U_name u_b) + (b_b.binder_bv |> S.bv_to_name) in + + let pure_wp_uvar, g_pure_wp_uvar = pure_wp_uvar + (Env.push_binders env (a_b::b_b::rest_bs)) + return_repr + (BU.format1 "implicit for pure_wp in checking bind %s" bind_name) + r in + + let k = U.arrow (a_b::b_b::(rest_bs@range_bs@[f; g])) (S.mk_Comp ({ + comp_univs = [Env.new_u_univ ()]; + effect_name = PC.effect_PURE_lid; + result_typ = return_repr; + effect_args = [pure_wp_uvar |> S.as_arg]; + flags = [] })) in + + let guard_eq = + match Rel.teq_nosmt env k bind_t with + | None -> + raise_error r Errors.Fatal_UnexpectedEffect + (BU.format2 "Unexpected type of %s (%s)\n" + bind_name + (show bind_t)) + | Some g -> g in + + Rel.force_trivial_guard env (Env.conj_guards [ + guard_f; + guard_g; + guard_return_repr; + g_pure_wp_uvar; + guard_eq]); + + let k = k |> N.remove_uvar_solutions env |> SS.compress in + + let lopt = bind_combinator_kind env m_eff_name n_eff_name p_eff_name + m_sig_ts n_sig_ts p_sig_ts + m_repr_ts n_repr_ts p_repr_ts + bind_us + k + num_effect_params + has_range_binders in + + let kind = + match lopt with + | None -> + log_ad_hoc_combinator_warning bind_name r; + Ad_hoc_combinator + | Some l -> Substitutive_combinator l in + + if Debug.medium () || !dbg_LayeredEffectsTc + then BU.print2 "Bind %s has %s kind\n" bind_name (show kind); + + k, kind + +// +// Check subcomp combinator kind +// +// Used for both indexed effects subcomp and polymonadic subcomp +// +let subcomp_combinator_kind (env:env) + (m_eff_name n_eff_name:lident) + (m_sig_ts n_sig_ts:tscheme) + (m_repr_ts n_repr_ts:option tscheme) + (u:univ_name) + (k:typ) + (num_effect_params:int) + + : option S.indexed_effect_combinator_kind = + + // the idea is same as that of bind + // we will check that each binder in k has expected type, + // where the expected types will come from signatures and reprs of m and n + + let a_b::rest_bs, k_c = k |> U.arrow_formals_comp in + + let? eff_params_bs, eff_params_bs_kinds, rest_bs = + if num_effect_params = 0 + then ([], [], rest_bs) |> Some + else let _, sig = Env.inst_tscheme_with m_sig_ts [U_name u] in + let _::sig_bs, _ = sig |> U.arrow_formals in + let sig_effect_params_bs = List.splitAt num_effect_params sig_bs |> fst in + let eff_params_bs, rest_bs = List.splitAt num_effect_params rest_bs in + let? eff_params_bs_kinds = eq_binders env sig_effect_params_bs eff_params_bs in + (eff_params_bs, eff_params_bs_kinds, rest_bs) |> Some in + + let? f_bs, f_bs_kinds, rest_bs = + let f_sig_bs = + let _, sig = Env.inst_tscheme_with m_sig_ts [U_name u] in + sig |> U.arrow_formals + |> fst + |> (fun (a::bs) -> + let sig_bs, bs = List.splitAt num_effect_params bs in + let ss = List.fold_left2 (fun ss sig_b b -> + ss@[NT (sig_b.binder_bv, b.binder_bv |> S.bv_to_name)] + ) [NT (a.binder_bv, a_b.binder_bv |> S.bv_to_name)] sig_bs eff_params_bs in + bs |> SS.subst_binders ss) in + + let? f_bs, rest_bs = + if List.length rest_bs < List.length f_sig_bs + then None + else List.splitAt (List.length f_sig_bs) rest_bs |> Some in + + let? f_bs_kinds = eq_binders env f_sig_bs f_bs in + + (f_bs, f_bs_kinds, rest_bs) |> Some in + + // peel off the f:repr a is binder + let? rest_bs, f_b = + if List.length rest_bs >= 1 + then let rest_bs, [f_b] = List.splitAt (List.length rest_bs - 1) rest_bs in + (rest_bs, f_b) |> Some + else None in + + // check that f repr binder has the expected type + let? _f_b_ok_ = + let expected_f_b_sort = + match m_repr_ts with + | Some repr_ts -> + let _, t = Env.inst_tscheme_with repr_ts [U_name u] in + S.mk_Tm_app t + ((a_b.binder_bv |> S.bv_to_name |> S.as_arg):: + (List.map (fun {binder_bv=b} -> b |> S.bv_to_name |> S.as_arg) (eff_params_bs@f_bs))) + Range.dummyRange + | None -> + U.arrow [S.null_binder S.t_unit] + (mk_Comp ({ + comp_univs = [U_name u]; + effect_name = m_eff_name; + result_typ = a_b.binder_bv |> S.bv_to_name; + effect_args = (eff_params_bs@f_bs) |> List.map (fun b -> b.binder_bv |> S.bv_to_name |> S.as_arg); + flags = []})) in + if TEQ.eq_tm env f_b.binder_bv.sort expected_f_b_sort = TEQ.Equal + then Some () + else None in + + let check_ret_t (f_or_g_bs:binders) : option unit = + let expected_t = + match n_repr_ts with + | Some repr_ts -> + let _, t = Env.inst_tscheme_with repr_ts [U_name u] in + S.mk_Tm_app t + ((a_b.binder_bv |> S.bv_to_name |> S.as_arg):: + (List.map (fun {binder_bv=b} -> b |> S.bv_to_name |> S.as_arg) (eff_params_bs@f_or_g_bs))) + Range.dummyRange + | None -> + U.arrow [S.null_binder S.t_unit] + (mk_Comp ({ + comp_univs = [U_name u]; + effect_name = n_eff_name; + result_typ = a_b.binder_bv |> S.bv_to_name; + effect_args = (eff_params_bs@f_or_g_bs) |> List.map (fun b -> b.binder_bv |> S.bv_to_name |> S.as_arg); + flags = []})) in + if TEQ.eq_tm env (U.comp_result k_c) expected_t = TEQ.Equal + then Some () + else None in + + if Some? (check_ret_t f_bs) + then Some Substitutive_invariant_combinator + else begin + let? g_bs, g_bs_kinds, rest_bs = + let g_sig_bs = + let _, sig = Env.inst_tscheme_with n_sig_ts [U_name u] in + sig |> U.arrow_formals + |> fst + |> (fun (a::bs) -> + let sig_bs, bs = List.splitAt num_effect_params bs in + let ss = List.fold_left2 (fun ss sig_b b -> + ss@[NT (sig_b.binder_bv, b.binder_bv |> S.bv_to_name)] + ) [NT (a.binder_bv, a_b.binder_bv |> S.bv_to_name)] sig_bs eff_params_bs in + bs |> SS.subst_binders ss) in + + let? g_bs, rest_bs = + if List.length rest_bs < List.length g_sig_bs + then None + else List.splitAt (List.length g_sig_bs) rest_bs |> Some in + + let? g_bs_kinds = eq_binders env g_sig_bs g_bs in + + (g_bs, g_bs_kinds, rest_bs) |> Some in + + // check subcomp return type is expected + let? _ret_t_ok_ = check_ret_t g_bs in + + // rest of the binders are ad-hoc + let rest_kinds = List.map (fun _ -> Ad_hoc_binder) rest_bs in + + Some (([Type_binder] @ + eff_params_bs_kinds @ + f_bs_kinds @ + g_bs_kinds@rest_kinds@ + [Repr_binder]) |> Substitutive_combinator) + end + +// +// Validate indexed effect subcomp (including polymonadic subcomp) shape +// and compute its kind +// +let validate_indexed_effect_subcomp_shape (env:env) + (m_eff_name n_eff_name:lident) + (m_sig_ts n_sig_ts:tscheme) + (m_repr_ts n_repr_ts:option tscheme) + (u:univ_name) + (subcomp_t:typ) + (num_effect_params:int) + (r:Range.range) + : typ & indexed_effect_combinator_kind = + + let subcomp_name = BU.format2 "%s <: %s" + (string_of_lid m_eff_name) + (string_of_lid n_eff_name) in + + let a_b = (U_name u) |> U.type_with_u |> S.gen_bv "a" None |> S.mk_binder in + + let rest_bs = + match (SS.compress subcomp_t).n with + | Tm_arrow {bs} when List.length bs >= 2 -> + // peel off a:Type + let ({binder_bv=a})::bs = SS.open_binders bs in + // peel off f:repr from the end + bs |> List.splitAt (List.length bs - 1) |> fst + |> SS.subst_binders [NT (a, bv_to_name a_b.binder_bv)] + | _ -> + raise_error r Errors.Fatal_UnexpectedEffect + (BU.format2 "Type of %s is not an arrow with >= 2 binders (%s)" + subcomp_name + (show subcomp_t)) in + + let f, guard_f = + let repr, g = TcUtil.fresh_effect_repr + (Env.push_binders env (a_b::rest_bs)) + r + m_eff_name + m_sig_ts + m_repr_ts + (U_name u) + (a_b.binder_bv |> S.bv_to_name) in + repr |> S.gen_bv "f" None |> S.mk_binder, g in + + let ret_t, guard_ret_t = TcUtil.fresh_effect_repr + (Env.push_binders env (a_b::rest_bs)) + r + n_eff_name + n_sig_ts + n_repr_ts + (U_name u) + (a_b.binder_bv |> S.bv_to_name) in + + let pure_wp_uvar, guard_wp = pure_wp_uvar + (Env.push_binders env (a_b::rest_bs)) + ret_t + (BU.format1 "implicit for pure_wp in checking %s" subcomp_name) + r in + + let c = S.mk_Comp ({ + comp_univs = [ Env.new_u_univ () ]; + effect_name = PC.effect_PURE_lid; + result_typ = ret_t; + effect_args = [ pure_wp_uvar |> S.as_arg ]; + flags = [] }) in + + let k = U.arrow (a_b::rest_bs@[f]) c in + + if Debug.medium () || !dbg_LayeredEffectsTc then + BU.print1 "Expected type of subcomp before unification: %s\n" + (show k); + + let guard_eq = + match Rel.teq_nosmt env subcomp_t k with + | None -> + raise_error r Errors.Fatal_UnexpectedEffect + (BU.format2 "Unexpected type of %s (%s)\n" + subcomp_name + (show subcomp_t)) + | Some g -> g in + + + Rel.force_trivial_guard env (Env.conj_guards [ + guard_f; + guard_ret_t; + guard_wp; + guard_eq ]); + + let k = k |> N.remove_uvar_solutions env |> SS.compress in + + let kopt = subcomp_combinator_kind env m_eff_name n_eff_name + m_sig_ts n_sig_ts + m_repr_ts n_repr_ts + u + k + num_effect_params in + + let kind = + match kopt with + | None -> + log_ad_hoc_combinator_warning subcomp_name r; + Ad_hoc_combinator + | Some k -> k in + + if Debug.medium () || !dbg_LayeredEffectsTc + then BU.print2 "Subcomp %s has %s kind\n" subcomp_name (show kind); + + + k, kind + +// +// Check the kind of an indexed effect ite combinator +// +let ite_combinator_kind (env:env) + (eff_name:lident) + (sig_ts repr_ts:tscheme) + (u:univ_name) + (tm:term) + (num_effect_params:int) + + : option S.indexed_effect_combinator_kind = + + let a_b::rest_bs, _, _ = U.abs_formals tm in + + let? eff_params_bs, eff_params_bs_kinds, rest_bs = + if num_effect_params = 0 + then ([], [], rest_bs) |> Some + else let _, sig = Env.inst_tscheme_with sig_ts [U_name u] in + let _::sig_bs, _ = sig |> U.arrow_formals in + let sig_effect_params_bs = List.splitAt num_effect_params sig_bs |> fst in + let eff_params_bs, rest_bs = List.splitAt num_effect_params rest_bs in + let? eff_params_bs_kinds = eq_binders env sig_effect_params_bs eff_params_bs in + (eff_params_bs, eff_params_bs_kinds, rest_bs) |> Some in + + let? f_bs, f_bs_kinds, rest_bs = + let f_sig_bs = + let _, sig = Env.inst_tscheme_with sig_ts [U_name u] in + sig |> U.arrow_formals + |> fst + |> (fun (a::bs) -> + let sig_bs, bs = List.splitAt num_effect_params bs in + let ss = List.fold_left2 (fun ss sig_b b -> + ss@[NT (sig_b.binder_bv, b.binder_bv |> S.bv_to_name)] + ) [NT (a.binder_bv, a_b.binder_bv |> S.bv_to_name)] sig_bs eff_params_bs in + bs |> SS.subst_binders ss) in + + let? f_bs, rest_bs = + if List.length rest_bs < List.length f_sig_bs + then None + else List.splitAt (List.length f_sig_bs) rest_bs |> Some in + + let? f_bs_kinds = eq_binders env f_sig_bs f_bs in + + (f_bs, f_bs_kinds, rest_bs) |> Some in + + let? rest_bs, [f_b; g_b; p_b] = + if List.length rest_bs >= 3 + then List.splitAt (List.length rest_bs - 3) rest_bs |> Some + else None in + + let? _f_b_ok_ = + let expected_f_b_sort = + let _, t = Env.inst_tscheme_with repr_ts [U_name u] in + S.mk_Tm_app t + ((a_b.binder_bv |> S.bv_to_name |> S.as_arg):: + (List.map (fun {binder_bv=b} -> b |> S.bv_to_name |> S.as_arg) (eff_params_bs@f_bs))) + Range.dummyRange in + if TEQ.eq_tm env f_b.binder_bv.sort expected_f_b_sort = TEQ.Equal + then Some () + else None in + + let check_g_b (f_or_g_bs:binders) : option unit = + let expected_g_b_sort = + let _, t = Env.inst_tscheme_with repr_ts [U_name u] in + S.mk_Tm_app t + ((a_b.binder_bv |> S.bv_to_name |> S.as_arg):: + (List.map (fun {binder_bv=b} -> b |> S.bv_to_name |> S.as_arg) (eff_params_bs@f_or_g_bs))) + Range.dummyRange in + if TEQ.eq_tm env g_b.binder_bv.sort expected_g_b_sort = TEQ.Equal + then Some () + else None in + + if Some? (check_g_b f_bs) + then Some Substitutive_invariant_combinator + else begin + let? g_bs, g_bs_kinds, rest_bs = + let g_sig_bs = + let _, sig = Env.inst_tscheme_with sig_ts [U_name u] in + sig |> U.arrow_formals + |> fst + |> (fun (a::bs) -> + let sig_bs, bs = List.splitAt num_effect_params bs in + let ss = List.fold_left2 (fun ss sig_b b -> + ss@[NT (sig_b.binder_bv, b.binder_bv |> S.bv_to_name)] + ) [NT (a.binder_bv, a_b.binder_bv |> S.bv_to_name)] sig_bs eff_params_bs in + bs |> SS.subst_binders ss) in + + let? g_bs, rest_bs = + if List.length rest_bs < List.length g_sig_bs + then None + else List.splitAt (List.length g_sig_bs) rest_bs |> Some in + + let? g_bs_kinds = eq_binders env g_sig_bs g_bs in + + (g_bs, g_bs_kinds, rest_bs) |> Some in + + let? _g_b_ok_ = check_g_b g_bs in + + let rest_kinds = List.map (fun _ -> Ad_hoc_binder) rest_bs in + + Some ([Type_binder] @ + eff_params_bs_kinds@ + f_bs_kinds @ + g_bs_kinds @ + rest_kinds @ + [Repr_binder; Repr_binder; Substitutive_binder] |> Substitutive_combinator) + + end + +// +// Validate the shape of an indexed effect ite combinator, +// and compute its kind +// +let validate_indexed_effect_ite_shape (env:env) + (eff_name:lident) + (sig_ts:tscheme) + (repr_ts:tscheme) + (u:univ_name) + (ite_ty:typ) + (ite_tm:term) + (num_effect_params:int) + (r:Range.range) + + : term & indexed_effect_combinator_kind = + + let ite_name = BU.format1 "ite_%s" (string_of_lid eff_name) in + + let a_b = u |> U_name |> U.type_with_u |> S.gen_bv "a" None |> S.mk_binder in + + let rest_bs = + match (SS.compress ite_ty).n with + | Tm_arrow {bs} when List.length bs >= 4 -> + // peel off a:Type + let (({binder_bv=a})::bs) = SS.open_binders bs in + // peel off f:repr, g:repr, p:bool from the end + bs |> List.splitAt (List.length bs - 3) |> fst + |> SS.subst_binders [NT (a, a_b.binder_bv |> S.bv_to_name)] + | _ -> + raise_error r Errors.Fatal_UnexpectedEffect + (BU.format2 "Type of %s is not an arrow with >= 4 binders (%s)" + ite_name + (show ite_ty)) in + + let f, guard_f = + let repr, g = TcUtil.fresh_effect_repr + (Env.push_binders env (a_b::rest_bs)) + r + eff_name + sig_ts + (Some repr_ts) + (U_name u) + (a_b.binder_bv |> S.bv_to_name) in + repr |> S.gen_bv "f" None |> S.mk_binder, g in + + let g, guard_g = + let repr, g = TcUtil.fresh_effect_repr + (Env.push_binders env (a_b::rest_bs)) + r + eff_name + sig_ts + (Some repr_ts) + (U_name u) + (a_b.binder_bv |> S.bv_to_name) in + repr |> S.gen_bv "g" None |> S.mk_binder, g in + + let p = S.gen_bv "p" None U.t_bool |> S.mk_binder in + + let body_tm, guard_body = TcUtil.fresh_effect_repr + (Env.push_binders env (a_b::rest_bs@[p])) + r + eff_name + sig_ts + (Some repr_ts) + (U_name u) + (a_b.binder_bv |> S.bv_to_name) in + + let k = U.abs (a_b::rest_bs@[f; g; p]) body_tm None in + + let guard_eq = + match Rel.teq_nosmt env ite_tm k with + | None -> + raise_error r Errors.Fatal_UnexpectedEffect + (BU.format2 "Unexpected term for %s (%s)\n" + ite_name + (show ite_tm)) + | Some g -> g in + + Rel.force_trivial_guard env (Env.conj_guards [ + guard_f; + guard_g; + guard_body; + guard_eq ]); + + let k = k |> N.remove_uvar_solutions env |> SS.compress in + + let kopt = ite_combinator_kind env eff_name sig_ts repr_ts u k num_effect_params in + + let kind = + match kopt with + | None -> + log_ad_hoc_combinator_warning ite_name r; + Ad_hoc_combinator + | Some k -> k in + + if Debug.medium () || !dbg_LayeredEffectsTc + then BU.print2 "Ite %s has %s kind\n" ite_name + (show kind); + + k, kind + + +// +// Validate the shape of an indexed effect close combinator +// +// Only substitutive close combinator is supported +// fun (a:Type) (b:Type) (is:b -> is_t) (f:(x:a -> repr a (is x))) -> repr a js +// +let validate_indexed_effect_close_shape (env:env) + (eff_name:lident) + (sig_ts:tscheme) + (repr_ts:tscheme) + (u_a:univ_name) + (u_b:univ_name) + (close_tm:term) + (num_effect_params:int) + (r:Range.range) : term = + + let close_name = BU.format1 "close_%s" (string_of_lid eff_name) in + + let b_b = u_b |> U_name |> U.type_with_u |> S.gen_bv "b" None |> S.mk_binder in + + let a_b::sig_bs = Env.inst_tscheme_with sig_ts [U_name u_a] |> snd |> U.arrow_formals |> fst in + let eff_params_bs, sig_bs = List.splitAt num_effect_params sig_bs in + let bs = List.map (fun b -> + let x_b = S.gen_bv "x" None (S.bv_to_name b_b.binder_bv) |> S.mk_binder in + {b with binder_bv={b.binder_bv with sort=U.arrow [x_b] (S.mk_Total b.binder_bv.sort)}} + ) sig_bs in + let f_b = + let _, repr_t = Env.inst_tscheme_with repr_ts [U_name u_a] in + let x_b = S.gen_bv "x" None (S.bv_to_name b_b.binder_bv) |> S.mk_binder in + let is_args = + List.map (fun {binder_bv} -> + S.mk_Tm_app (S.bv_to_name binder_bv) [x_b.binder_bv |> S.bv_to_name |> S.as_arg] Range.dummyRange + |> S.as_arg) bs in + let repr_app = S.mk_Tm_app repr_t ((a_b.binder_bv |> S.bv_to_name |> S.as_arg)::is_args) Range.dummyRange in + let f_sort = U.arrow [x_b] (S.mk_Total repr_app) in + S.gen_bv "f" None f_sort |> S.mk_binder in + let env = Env.push_binders env (a_b::b_b::(eff_params_bs@bs)) in + let body_tm, g_body = TcUtil.fresh_effect_repr + env + r + eff_name + sig_ts + (Some repr_ts) + (U_name u_a) + (a_b.binder_bv |> S.bv_to_name) in + + let k = U.abs (a_b::b_b::(eff_params_bs@bs@[f_b])) body_tm None in + + let g_eq = + match Rel.teq_nosmt env close_tm k with + | None -> + raise_error r Errors.Fatal_UnexpectedEffect + (BU.format2 "Unexpected term for %s (%s)\n" + close_name + (show close_tm)) + | Some g -> g in + + Rel.force_trivial_guard env (Env.conj_guard g_body g_eq); + + k |> N.remove_uvar_solutions env |> SS.compress + +// +// Check the kind of an indexed effect lift +// +let lift_combinator_kind (env:env) + (m_eff_name:lident) + (m_sig_ts:tscheme) + (m_repr_ts:option tscheme) + (u:univ_name) + (k:typ) + : option (list indexed_effect_binder_kind) = + + let a_b::rest_bs, _ = U.arrow_formals k in + + let? f_bs, f_bs_kinds, rest_bs = + let f_sig_bs = + let _, sig = Env.inst_tscheme_with m_sig_ts [U_name u] in + sig |> U.arrow_formals + |> fst + |> (fun (a::bs) -> + SS.subst_binders [NT (a.binder_bv, a_b.binder_bv |> S.bv_to_name)] bs) in + + let? f_bs, rest_bs = + if List.length rest_bs < List.length f_sig_bs + then None + else List.splitAt (List.length f_sig_bs) rest_bs |> Some in + + let? f_bs_kinds = eq_binders env f_sig_bs f_bs in + + (f_bs, f_bs_kinds, rest_bs) |> Some in + + let? rest_bs, f_b = + if List.length rest_bs >= 1 + then let rest_bs, [f_b] = List.splitAt (List.length rest_bs - 1) rest_bs in + (rest_bs, f_b) |> Some + else None in + + let? _f_b_ok_ = + let expected_f_b_sort = + match m_repr_ts with + | Some repr_ts -> + let _, t = Env.inst_tscheme_with repr_ts [U_name u] in + S.mk_Tm_app t + ((a_b.binder_bv |> S.bv_to_name |> S.as_arg):: + (List.map (fun {binder_bv=b} -> b |> S.bv_to_name |> S.as_arg) f_bs)) + Range.dummyRange + | None -> + U.arrow [S.null_binder S.t_unit] + (mk_Comp ({ + comp_univs = [U_name u]; + effect_name = m_eff_name; + result_typ = a_b.binder_bv |> S.bv_to_name; + effect_args = f_bs |> List.map (fun b -> b.binder_bv |> S.bv_to_name |> S.as_arg); + flags = []})) in + if TEQ.eq_tm env f_b.binder_bv.sort expected_f_b_sort = TEQ.Equal + then Some () + else None in + + let rest_kinds = List.map (fun _ -> Ad_hoc_binder) rest_bs in + + Some ([Type_binder]@ + f_bs_kinds @ + rest_kinds @ + [Repr_binder]) + +// +// Validate the shape of an indexed effect lift, +// and compute its kind +// +let validate_indexed_effect_lift_shape (env:env) + (m_eff_name n_eff_name:lident) + (u:univ_name) + (lift_t:typ) + (r:Range.range) + : typ & indexed_effect_combinator_kind = + + let lift_name = BU.format2 "%s ~> %s" + (string_of_lid m_eff_name) + (string_of_lid n_eff_name) in + + let lift_t_shape_error s = BU.format2 "Unexpected shape of lift %s, reason:%s" + lift_name + s in + + let m_ed, n_ed = Env.get_effect_decl env m_eff_name, Env.get_effect_decl env n_eff_name in + + let a_b = (U_name u) |> U.type_with_u |> S.gen_bv "a" None |> S.mk_binder in + + let rest_bs, lift_eff = + match (SS.compress lift_t).n with + | Tm_arrow {bs; comp=c} when List.length bs >= 2 -> + // peel off a:Type + let (({binder_bv=a})::bs) = SS.open_binders bs in + // peel off f:repr from the end + bs |> List.splitAt (List.length bs - 1) |> fst + |> SS.subst_binders [NT (a, bv_to_name a_b.binder_bv)], + U.comp_effect_name c |> Env.norm_eff_name env + | _ -> + raise_error r Errors.Fatal_UnexpectedExpressionType + (lift_t_shape_error "either not an arrow, or not enough binders") in + + if (not ((lid_equals lift_eff PC.effect_PURE_lid) || + (lid_equals lift_eff PC.effect_GHOST_lid && Env.is_erasable_effect env m_eff_name))) + then raise_error r Errors.Fatal_UnexpectedExpressionType + (lift_t_shape_error "the lift combinator has an unexpected effect: \ + it must either be PURE or if the source effect is erasable then may be GHOST"); + + let f, guard_f = + let repr, g = TcUtil.fresh_effect_repr + (Env.push_binders env (a_b::rest_bs)) + r + m_eff_name + (U.effect_sig_ts m_ed.signature) + (U.get_eff_repr m_ed) + (U_name u) + (a_b.binder_bv |> S.bv_to_name) in + + repr |> S.gen_bv "f" None |> S.mk_binder, g in + + let ret_t, guard_ret_t = TcUtil.fresh_effect_repr + (Env.push_binders env (a_b::rest_bs)) + r + n_eff_name + (U.effect_sig_ts n_ed.signature) + (U.get_eff_repr n_ed) + (U_name u) + (a_b.binder_bv |> S.bv_to_name) in + + let pure_wp_uvar, guard_wp = pure_wp_uvar (Env.push_binders env (a_b::rest_bs)) ret_t + (BU.format1 "implicit for pure_wp in typechecking lift %s" lift_name) r in + + let c = S.mk_Comp ({ + comp_univs = [ Env.new_u_univ () ]; + effect_name = lift_eff; + result_typ = ret_t; + effect_args = [ pure_wp_uvar |> S.as_arg ]; + flags = [] }) in + + let k = U.arrow (a_b::rest_bs@[f]) c in + + let guard_eq = + match Rel.teq_nosmt env lift_t k with + | None -> + raise_error r Errors.Fatal_UnexpectedEffect + (BU.format2 "Unexpected type of %s (%s)\n" + lift_name + (show lift_t)) + | Some g -> g in + + Rel.force_trivial_guard env (Env.conj_guards [ + guard_f; + guard_ret_t; + guard_wp; + guard_eq ]); + + let k = k |> N.remove_uvar_solutions env |> SS.compress in + + let lopt = lift_combinator_kind env m_eff_name (U.effect_sig_ts m_ed.signature) + (U.get_eff_repr m_ed) + u k in + + let kind = + match lopt with + | None -> + log_ad_hoc_combinator_warning lift_name r; + Ad_hoc_combinator + | Some l -> Substitutive_combinator l in + + if Debug.medium () || !dbg_LayeredEffectsTc + then BU.print2 "Lift %s has %s kind\n" lift_name + (show kind); + + + k, kind + +(* + * Typechecking of layered effects + * + * If the effect is reifiable, returns reify__M sigelt also + *) +let tc_layered_eff_decl env0 (ed : S.eff_decl) (quals : list qualifier) (attrs : list S.attribute) = +Errors.with_ctx (BU.format1 "While checking layered effect definition `%s`" (string_of_lid ed.mname)) (fun () -> + if !dbg_LayeredEffectsTc then + BU.print1 "Typechecking layered effect: \n\t%s\n" (show ed); + + //we don't support effect binders in layered effects yet + if List.length ed.univs <> 0 || List.length ed.binders <> 0 then + raise_error ed.mname Errors.Fatal_UnexpectedEffect + ("Binders are not supported for layered effects (" ^ (string_of_lid ed.mname) ^")"); + + let log_combinator s (us, t, ty) = + if !dbg_LayeredEffectsTc then + BU.print4 "Typechecked %s:%s = %s:%s\n" + (string_of_lid ed.mname) s + (Print.tscheme_to_string (us, t)) (Print.tscheme_to_string (us, ty)) in + + //helper function to get (a:Type ?u), returns the binder and ?u + let fresh_a_and_u_a (a:string) : binder & universe = U.type_u () |> (fun (t, u) -> S.gen_bv a None t |> S.mk_binder, u) in + //helper function to get (x:a) + let fresh_x_a (x:string) (a:binder) : binder = S.gen_bv x None (S.bv_to_name a.binder_bv) |> S.mk_binder in + + + (* + * We now typecheck various combinators + * In all the cases we take the following approach: + * - Typecheck the combinator (with no expected type) + * - Construct an expected type (k) using uvars + * - Unify the type of the combinator (as typechecked) with k + * - Record k in the effect declaration (along with the combinator) + *) + + let check_and_gen = check_and_gen env0 (string_of_lid ed.mname) in + + + (* + * Effect signature + * + * The signature term must have the form: + * a:Type -> -> Effect //polymorphic in one universe (that of a) + * + * The binders become the effect indices + *) + let num_effect_params, signature = + let n, sig_ts = + match ed.signature with + | Layered_eff_sig (n, ts) -> n, ts + | _ -> failwith "Impossible (tc_layered_eff_decl with a wp effect sig" in + + Errors.with_ctx ("While checking the effect signature") (fun () -> + let r = (snd sig_ts).pos in + let sig_us, sig_t, sig_ty = check_and_gen "signature" 1 sig_ts in + + let us, t = SS.open_univ_vars sig_us sig_t in + let env = Env.push_univ_vars env0 us in + + let a, u = fresh_a_and_u_a "a" in + let rest_bs = + TcUtil.layered_effect_indices_as_binders env r ed.mname (sig_us, sig_t) u (a.binder_bv |> S.bv_to_name) in + let bs = a::rest_bs in + let k = U.arrow bs (S.mk_Total S.teff) in //U.arrow does closing over bs + let g_eq = Rel.teq env t k in + Rel.force_trivial_guard env g_eq; + n, (sig_us, SS.close_univ_vars us (k |> N.remove_uvar_solutions env), sig_ty)) in + + log_combinator "signature" signature; + + (* + * Effect repr + * + * The repr must have the type: + * a:Type -> -> Type //polymorphic in one universe (that of a) + *) + let repr = + Errors.with_ctx ("While checking the effect repr") (fun () -> + let repr_ts = ed |> U.get_eff_repr |> must in + let r = (snd repr_ts).pos in + let repr_us, repr_t, repr_ty = check_and_gen "repr" 1 repr_ts in + + let us, ty = SS.open_univ_vars repr_us repr_ty in + let env = Env.push_univ_vars env0 us in + + let a, u = fresh_a_and_u_a "a" in + let rest_bs = + let signature_ts = let us, t, _ = signature in (us, t) in + TcUtil.layered_effect_indices_as_binders env r ed.mname signature_ts u (a.binder_bv |> S.bv_to_name) in + let bs = a::rest_bs in + let k = U.arrow bs (U.type_u () |> (fun (t, u) -> S.mk_Total t)) in //note the universe of Tot need not be u + let g = Rel.teq env ty k in + Rel.force_trivial_guard env g; + (repr_us, repr_t, SS.close_univ_vars us (k |> N.remove_uvar_solutions env))) + in + + log_combinator "repr" repr; + + //helper function that creates an application node (repr a_tm ?u1 ... ?un) + //returns the application term and the guard for the introduced uvars (see TcUtil.fresh_layered_effect_repr) + let fresh_repr r env u a_tm = + let signature_ts = let us, t, _ = signature in (us, t) in + let repr_ts = let us, t, _ = repr in (us, t) in + TcUtil.fresh_effect_repr env r ed.mname signature_ts (Some repr_ts) u a_tm in + + let not_an_arrow_error comb n t r = + raise_error r Errors.Fatal_UnexpectedEffect + (BU.format5 "Type of %s:%s is not an arrow with >= %s binders (%s::%s)" (string_of_lid ed.mname) comb + (show n) (tag_of t) (show t)) + in + + (* + * return_repr + * + * return_repr must have type: + * a:Type -> x:a -> -> repr a i_1 ... i_n //polymorphic in one universe (that of a) + * where i_1 ... i_n are terms of effect indices types (as in the signature) + * + * The binders have arbitrary sorts + * + * The positioning of the binders is a little asymmetric with other binders, + * e.g. in others, the binders are stuffed in the middle + * but this seems ok for return where the remaining binder is always a value (x:a) + * and not a repr + *) + let return_repr = + Errors.with_ctx ("While checking the return combinator") (fun () -> + let return_repr_ts = ed |> U.get_return_repr |> must in + let r = (snd return_repr_ts).pos in + let ret_us, ret_t, ret_ty = check_and_gen "return_repr" 1 return_repr_ts in + + let us, ty = SS.open_univ_vars ret_us ret_ty in + let env = Env.push_univ_vars env0 us in + + let a, u_a = fresh_a_and_u_a "a" in + let x_a = fresh_x_a "x" a in + let rest_bs = + match (SS.compress ty).n with + | Tm_arrow {bs} when List.length bs >= 2 -> + let (({binder_bv=a'})::({binder_bv=x'})::bs) = SS.open_binders bs in + bs |> SS.subst_binders [NT (a', bv_to_name a.binder_bv)] + |> SS.subst_binders [NT (x', bv_to_name x_a.binder_bv)] + | _ -> not_an_arrow_error "return" 2 ty r in + let bs = a::x_a::rest_bs in + let repr, g = fresh_repr r (Env.push_binders env bs) u_a (a.binder_bv |> S.bv_to_name) in + let k = U.arrow bs (S.mk_Total repr) in + let g_eq = Rel.teq env ty k in + Rel.force_trivial_guard env (Env.conj_guard g g_eq); + + let k = k |> N.remove_uvar_solutions env in + + ret_us, ret_t, k |> SS.close_univ_vars us) in + + log_combinator "return_repr" return_repr; + + (* + * bind_repr + * + * bind_repr must have type: + * a:Type -> b:Type -> -> f:repr a i_1 ... i_n -> (g:a -> repr a j_1 ... j_n) + * : repr a k_1 ... k_n //polymorphic in two universes (that of a and b) + * where i, j, k are terms of effect indices types (as in the signature) + * + * The binders have arbitrary sorts + *) + let bind_repr, bind_kind = + Errors.with_ctx ("While checking the bind combinator") (fun () -> + let bind_repr_ts = ed |> U.get_bind_repr |> must in + let r = (snd bind_repr_ts).pos in + let bind_us, bind_t, bind_ty = check_and_gen "bind_repr" 2 bind_repr_ts in + + let us, ty = SS.open_univ_vars bind_us bind_ty in + let env = Env.push_univ_vars env0 us in + + let k, kind = + let sig_ts = let us, t, _ = signature in (us, t) in + let repr_ts = let us, t, _ = repr in (us, t) in + validate_indexed_effect_bind_shape env + ed.mname ed.mname ed.mname + sig_ts sig_ts sig_ts + (Some repr_ts) (Some repr_ts) (Some repr_ts) + us + ty + r + num_effect_params + (U.has_attribute ed.eff_attrs PC.bind_has_range_args_attr) in + + (bind_us, bind_t, k |> SS.close_univ_vars bind_us), kind) in + + log_combinator "bind_repr" bind_repr; + + (* + * stronger_repr + * + * stronger_repr must have type: + * a:Type -> -> f:repr a i_1 ... i_n -> PURE (repr a j_1 ... j_n) wp //polymorphic in one universe (that of a) + * where i, j are terms of effect indices types (as in the signature) + * + * The binders have arbitrary sorts + * + * The combinator is optional, indicated by a Tm_unknown + * If so, we add a default combinator as: fun (a:Type) (signature_bs) (f:repr a signature_bs) -> f + * + *) + let stronger_repr, subcomp_kind = + Errors.with_ctx ("While checking the subcomp combinator") (fun () -> + let stronger_repr = + let ts = ed |> U.get_stronger_repr |> must in + match (ts |> snd |> SS.compress).n with + | Tm_unknown -> + let signature_ts = let (us, t, _) = signature in (us, t) in + let _, signature_t = Env.inst_tscheme_with signature_ts [U_unknown] in + (match (SS.compress signature_t).n with + | Tm_arrow {bs} -> + let bs = SS.open_binders bs in + let repr_t = + let repr_ts = let (us, t, _) = repr in (us, t) in + Env.inst_tscheme_with repr_ts [U_unknown] |> snd in + let repr_t_applied = mk + (Tm_app {hd=repr_t; + args=bs |> List.map (fun b -> b.binder_bv) |> List.map S.bv_to_name |> List.map S.as_arg}) + (Ident.range_of_lid ed.mname) in + let f_b = S.null_binder repr_t_applied in + [], {U.abs (bs@[f_b]) (f_b.binder_bv |> S.bv_to_name) None + with pos=Ident.range_of_lid ed.mname} + | _ -> failwith "Impossible!") + | _ -> ts in + + let r = (snd stronger_repr).pos in + + let stronger_us, stronger_t, stronger_ty = check_and_gen "stronger_repr" 1 stronger_repr in + + if !dbg_LayeredEffectsTc then + BU.print2 "stronger combinator typechecked with term: %s and type: %s\n" + (Print.tscheme_to_string (stronger_us, stronger_t)) + (Print.tscheme_to_string (stronger_us, stronger_ty)); + + let us, ty = SS.open_univ_vars stronger_us stronger_ty in + let env = Env.push_univ_vars env0 us in + + let k, kind = + let sig_ts = let us, t, _ = signature in (us, t) in + let repr_ts = let us, t, _ = repr in (us, t) in + validate_indexed_effect_subcomp_shape env + ed.mname ed.mname + sig_ts sig_ts + (Some repr_ts) (Some repr_ts) + (List.hd us) + ty + num_effect_params + r in + + (stronger_us, stronger_t, k |> SS.close_univ_vars stronger_us), kind) in + + log_combinator "stronger_repr" stronger_repr; + + (* + * This combinator is also optional + * If so, we add a default: + * fun (a:Type) (signature_bs) (f:repr a signature_bs) (g:repr a signature_bs) (b:bool) -> repr a signature_bs + *) + let if_then_else, ite_kind = + Errors.with_ctx ("While checking the if_then_else combinator") (fun () -> + let if_then_else_ts = + let ts = ed |> U.get_layered_if_then_else_combinator |> must |> fst in + match (ts |> snd |> SS.compress).n with + | Tm_unknown -> + let signature_ts = let (us, t, _) = signature in (us, t) in + let _, signature_t = Env.inst_tscheme_with signature_ts [U_unknown] in + (match (SS.compress signature_t).n with + | Tm_arrow {bs} -> + let bs = SS.open_binders bs in + let repr_t = + let repr_ts = let (us, t, _) = repr in (us, t) in + Env.inst_tscheme_with repr_ts [U_unknown] |> snd in + let repr_t_applied = mk + (Tm_app {hd=repr_t; + args=bs |> List.map (fun b -> b.binder_bv) |> List.map S.bv_to_name |> List.map S.as_arg}) + (Ident.range_of_lid ed.mname) in + let f_b = S.null_binder repr_t_applied in + let g_b = S.null_binder repr_t_applied in + let b_b = S.null_binder U.t_bool in + [], {U.abs (bs@[f_b; g_b; b_b]) repr_t_applied None + with pos=Ident.range_of_lid ed.mname} + | _ -> failwith "Impossible!") + | _ -> ts in + + let r = (snd if_then_else_ts).pos in + let if_then_else_us, if_then_else_t, if_then_else_ty = check_and_gen "if_then_else" 1 if_then_else_ts in + + let us, t = SS.open_univ_vars if_then_else_us if_then_else_t in + let _, ty = SS.open_univ_vars if_then_else_us if_then_else_ty in + let env = Env.push_univ_vars env0 us in + + let k, kind = + let sig_ts = let us, t, _ = signature in (us, t) in + let repr_ts = let us, t, _ = repr in (us, t) in + validate_indexed_effect_ite_shape env + ed.mname + sig_ts + repr_ts + (List.hd us) + ty + t + num_effect_params + r in + + (if_then_else_us, + k |> SS.close_univ_vars if_then_else_us, + if_then_else_ty), kind) in + + log_combinator "if_then_else" if_then_else; + + + (* + * Checking the soundness of the if_then_else combinator + * + * In all combinators, other than if_then_else, the soundness is ensured + * by extracting the application of those combinators to their definitions + * For if_then_else, the combinator does not have an extraction equivalent + * It is only used in VC generation + * + * So we need to make sure that the combinator is sound + * + * Informally, we want to check that: + * + * p ==> (subcomp f <: if_then_else f g) and + * not p ==> (subcomp g <: if_then_else f g) + * + * Basically when p holds, the computation type of f should be coercible to if_then_else f g + * and similarly for the (not p) case + * + * The way we program it is as follows: + * + * First for ite : a:Type -> bs -> f:repr a is -> g:repr a js -> p:bool -> Type, + * we create a fully applied (ite a bs f g p) term, + * where a, bs, f, g, and p are fresh names + * + * Note that beta-reducing this term gives us a (repr a ks) term + * + * Next, when subcomp : a:Type -> bs -> f:repr a s_is -> Pure (repr a s_js) pre post, + * we create fresh uvars for bs, where a is substituted by the a:Type + * name from the ite combinator + * + * To check the then branch, we unify (repr a s_is) with the sort of f binder + * from the ite combinator, and (repr a s_js) with (repr a ks), i.e. the + * beta-normal form of the fully applied ite combinator + * + * In addition, we produce an smt guard from pre + * + * To get flow-sensitivity (i.e. p ==>), the env that we do all this in, + * has a (squash p) binder + * + * Finally, we discharge all the guards + * + * Similarly we check the else branch by unifying (repr a s_is) with g binder, + * in an environment with squash (not p) + * + * When the effect is annotated with ite_soundness_by attribute, the uvars that + * we create for subcomp are tagged with the argument of ite_soundness_by, + * and the smt guard is also put in a implicit tagged with this implicit + * + * Through the usual tactics dispatching, Rel dispatches these to the tactic + * if one is in scope + *) + let _if_then_else_is_sound = Errors.with_ctx "While checking if-then-else soundness" (fun () -> + let r = (ed |> U.get_layered_if_then_else_combinator |> must |> fst |> snd).pos in + + let ite_us, ite_t, _ = if_then_else in + + let us, ite_t = SS.open_univ_vars ite_us ite_t in + let env, ite_t_applied, a_b, f_b, g_b, p_t = + match (SS.compress ite_t).n with + | Tm_abs {bs} -> + let bs = SS.open_binders bs in + let f_b, g_b, p_b = + bs + |> List.splitAt (List.length bs - 3) + |> snd + |> (fun l -> let [f; g; p] = l in f, g, p) in + let env = Env.push_binders (Env.push_univ_vars env0 us) bs in + env, + S.mk_Tm_app ite_t + (bs |> List.map (fun b -> S.bv_to_name b.binder_bv, U.aqual_of_binder b)) + r |> N.normalize [Env.Beta] env, //beta-reduce + bs |> List.hd, f_b, g_b, (S.bv_to_name p_b.binder_bv) + | _ -> failwith "Impossible! ite_t must have been an abstraction with at least 3 binders" in + + let subcomp_a_b, subcomp_bs, subcomp_f_b, subcomp_c = + let _, _, subcomp_ty = stronger_repr in + let _, subcomp_ty = SS.open_univ_vars us subcomp_ty in + match (SS.compress subcomp_ty).n with + | Tm_arrow {bs; comp=c} -> + let bs, c = SS.open_comp bs c in + let a_b, rest_bs = List.hd bs, List.tl bs in + let rest_bs, f_b = + rest_bs |> List.splitAt (List.length rest_bs - 1) + |> (fun (l1, l2) -> l1, List.hd l2) in + a_b, rest_bs, f_b, c + | _ -> failwith "Impossible! subcomp_ty must have been an arrow with at lease 1 binder" in + + (* + * An auxiliary function that we will call for then and else branches + * + * attr_opt is (Some arg) when there is an (ite_soundness_by arg) attribute on the effect + * + * The input env has the squash p (resp. squash (not p)) binder for the then (resp. else) branch + *) + let check_branch env ite_f_or_g_sort attr_opt : unit = + let subst, uvars, g_uvars = subcomp_bs |> List.fold_left + (fun (subst, uvars, g) b -> + let sort = SS.subst subst b.binder_bv.sort in + let t, _, g_t = + let ctx_uvar_meta = BU.map_option Ctx_uvar_meta_attr attr_opt in + Env.new_implicit_var_aux + (BU.format1 "uvar for subcomp %s binder when checking ite soundness" + (show b)) + r + env + sort + Strict + ctx_uvar_meta + false + in + subst@[NT (b.binder_bv, t)], uvars@[t], conj_guard g g_t) + ([NT (subcomp_a_b.binder_bv, S.bv_to_name a_b.binder_bv)], + [], + Env.trivial_guard) + in + + let subcomp_f_sort = SS.subst subst subcomp_f_b.binder_bv.sort in + let c = SS.subst_comp subst subcomp_c |> Env.unfold_effect_abbrev env in + + let g_f_or_g = Rel.layered_effect_teq env subcomp_f_sort ite_f_or_g_sort None in + let g_c = Rel.layered_effect_teq env c.result_typ ite_t_applied None in + + let fml = Env.pure_precondition_for_trivial_post + env + (List.hd c.comp_univs) + c.result_typ + (c.effect_args |> List.hd |> fst) + r in + let g_precondition = + match attr_opt with + | None -> fml |> NonTrivial |> Env.guard_of_guard_formula + | Some attr -> + let _, _, g = Env.new_implicit_var_aux "tc_layered_effect_decl.g_precondition" r env + (U.mk_squash S.U_zero fml) + Strict + (Ctx_uvar_meta_attr attr |> Some) + false + in + g + in + + Rel.force_trivial_guard env (Env.conj_guards [g_uvars; g_f_or_g; g_c; g_precondition]) in + + let ite_soundness_tac_attr = + match U.get_attribute PC.ite_soundness_by_attr attrs with + | Some ((t, _)::_) -> Some t + | _ -> None in + + let _check_then = + let env = Env.push_bv env (S.new_bv None (U.mk_squash S.U_zero (p_t |> U.b2t))) in + ignore (check_branch env f_b.binder_bv.sort ite_soundness_tac_attr) in + + let _check_else = + let not_p = S.mk_Tm_app + (S.lid_as_fv PC.not_lid None |> S.fv_to_tm) + [p_t |> U.b2t |> S.as_arg] + r in + let env = Env.push_bv env (S.new_bv None not_p) in + ignore (check_branch env g_b.binder_bv.sort ite_soundness_tac_attr) in + + () + ) //Errors.with_ctx + in + + // + // Close combinator is optional, + // typecheck it only if it is set, else leave it as None + // + let close_ = + Errors.with_ctx ("While checking the close combinator") (fun () -> + let ts_opt = ed |> U.get_layered_close_combinator in + match ts_opt with + | None -> None + | Some close_ts -> + let r = (snd close_ts).pos in + let close_us, close_t, close_ty = check_and_gen "close" 2 close_ts in + let us, t = SS.open_univ_vars close_us close_t in + let env = Env.push_univ_vars env0 us in + let k = + let sig_ts = let us, t, _ = signature in (us, t) in + let repr_ts = let us, t, _ = repr in (us, t) in + let [u_a; u_b] = us in + validate_indexed_effect_close_shape env ed.mname sig_ts repr_ts u_a u_b t num_effect_params r + in + Some (close_us, k |> SS.close_univ_vars close_us, close_ty)) in + + // + // Checking the soundness of the close combinator + // + // Close combinator has the shape: + // fun (a:Type) (b:type) (is:a -> is_t) (f:(x:a -> repr a (is x))) -> repr a js + // + // We check: + // + // a, b, is, x:a |- subcomp (repr a (is x)) (repr a js) + // + // Operationally, we create names for a, b, is, and x + // substitute them in the subcomp combinator, + // and prove its (Pure) precondition + // + let _close_is_sound = Errors.with_ctx ("While checking the soundness of the close combinator") (fun () -> + match close_ with + | None -> () + | Some close_ -> + let us, close_tm, _ = close_ in + let r = close_tm.pos in + let _ = + let supported_subcomp = + match subcomp_kind with + | Substitutive_combinator l -> + not (List.contains Ad_hoc_binder l) + | _ -> false in + + if not supported_subcomp + then raise_error r Errors.Fatal_UnexpectedEffect "close combinator is only allowed for effects with substitutive subcomp" + in + let us, close_tm = SS.open_univ_vars us close_tm in + let close_bs, close_body, _ = U.abs_formals close_tm in + let a_b::b_b::close_bs = close_bs in + let is_bs, _ = List.splitAt (List.length close_bs - 1) close_bs in + let x_bv = S.gen_bv "x" None (S.bv_to_name b_b.binder_bv) in + let args1 = List.map (fun i_b -> + S.mk_Tm_app (S.bv_to_name i_b.binder_bv) [S.as_arg (S.bv_to_name x_bv)] r + ) is_bs in + let args2 = + match (SS.compress close_body).n with + | Tm_app {args=a::args} -> args |> List.map fst + | _ -> raise_error r Errors.Fatal_UnexpectedEffect "close combinator body not a repr" in + + let env = Env.push_binders env0 ((a_b::b_b::is_bs)@[x_bv |> S.mk_binder]) in + let subcomp_ts = + let (us, _, t) = stronger_repr in + (us, t) in + let _, subcomp_t = Env.inst_tscheme_with subcomp_ts [List.hd us |> S.U_name] in + let a_b_subcomp::subcomp_bs, subcomp_c = U.arrow_formals_comp subcomp_t in + let subcomp_substs = [ NT (a_b_subcomp.binder_bv, a_b.binder_bv |> S.bv_to_name) ] in + let subcomp_f_bs, subcomp_bs = List.splitAt (List.length args1) subcomp_bs in + let subcomp_substs = subcomp_substs @ (List.map2 (fun b arg1 -> + NT (b.binder_bv, arg1) + ) subcomp_f_bs args1) in + let subcomp_g_bs, _ = List.splitAt (List.length args2) subcomp_bs in + let subcomp_substs = subcomp_substs @ (List.map2 (fun b arg2 -> + NT (b.binder_bv, arg2) + ) subcomp_g_bs args2) in + let subcomp_c = SS.subst_comp subcomp_substs subcomp_c |> Env.unfold_effect_abbrev env in + let fml = Env.pure_precondition_for_trivial_post + env + (List.hd subcomp_c.comp_univs) + subcomp_c.result_typ + (subcomp_c.effect_args |> List.hd |> fst) + r in + Rel.force_trivial_guard env (fml |> NonTrivial |> Env.guard_of_guard_formula)) + in + + (* + * Actions + * + * Actions must have type: + * -> repr a i_1 ... i_n + * so that we can inject them into the effect + * + * Other than this, no polymorphism etc. restrictions + * + * TODO: this code has a lot in common with actions for non-layered effects, we should reuse + *) + let tc_action env (act:action) : action = + let env0 = env in + let r = act.action_defn.pos in + if List.length act.action_params <> 0 + then raise_error r Errors.Fatal_MalformedActionDeclaration + (BU.format3 "Action %s:%s has non-empty action params (%s)" + (string_of_lid ed.mname) (string_of_lid act.action_name) (show act.action_params)); + + let env, act = + let usubst, us = SS.univ_var_opening act.action_univs in + Env.push_univ_vars env us, + { act with + action_univs = us; + action_defn = SS.subst usubst act.action_defn; + action_typ = SS.subst usubst act.action_typ } in + + let act_typ = + match (SS.compress act.action_typ).n with + | Tm_arrow {bs; comp=c} -> + let ct = Env.comp_to_comp_typ env c in + if lid_equals ct.effect_name ed.mname + then + let repr_ts = let us, t, _ = repr in (us, t) in + let repr = Env.inst_tscheme_with repr_ts ct.comp_univs |> snd in + let repr = S.mk_Tm_app + repr + (S.as_arg ct.result_typ::ct.effect_args) + r in + let c = S.mk_Total repr in + U.arrow bs c + else act.action_typ + | _ -> act.action_typ in + + let act_typ, _, g_t = tc_tot_or_gtot_term env act_typ in + let act_defn, _, g_d = tc_tot_or_gtot_term + ({ Env.set_expected_typ env act_typ with instantiate_imp = false }) + act.action_defn in + + if Debug.medium () || !dbg_LayeredEffectsTc then + BU.print2 "Typechecked action definition: %s and action type: %s\n" + (show act_defn) (show act_typ); + + let k, g_k = + let act_typ = N.normalize [Beta] env act_typ in + match (SS.compress act_typ).n with + | Tm_arrow {bs} -> + let bs = SS.open_binders bs in + let env = Env.push_binders env bs in + let t, u = U.type_u () in + let reason = BU.format2 "implicit for return type of action %s:%s" + (string_of_lid ed.mname) (string_of_lid act.action_name) in + let a_tm, _, g_tm = TcUtil.new_implicit_var reason r env t false in + let repr, g = fresh_repr r env u a_tm in + U.arrow bs (S.mk_Total repr), Env.conj_guard g g_tm + | _ -> raise_error r Errors.Fatal_ActionMustHaveFunctionType + (BU.format3 "Unexpected non-function type for action %s:%s (%s)" + (show ed.mname) (show act.action_name) (show act_typ)) in + + if Debug.medium () || !dbg_LayeredEffectsTc then + BU.print1 "Expected action type: %s\n" (show k); + + let g = Rel.teq env act_typ k in + List.iter (Rel.force_trivial_guard env) [g_t; g_d; g_k; g]; + + if Debug.medium () || !dbg_LayeredEffectsTc then + BU.print1 "Expected action type after unification: %s\n" (show k); + + let act_typ = + let err_msg t = BU.format3 + "Unexpected (k-)type of action %s:%s, expected bs -> repr i_1 ... i_n, found: %s" + (string_of_lid ed.mname) (string_of_lid act.action_name) (show t) in + let repr_args t : universes & term & args = + match (SS.compress t).n with + | Tm_app {hd=head;args=a::is} -> + (match (SS.compress head).n with + | Tm_uinst (_, us) -> us, fst a, is + | _ -> raise_error r Errors.Fatal_ActionMustHaveFunctionType (err_msg t)) + | _ -> raise_error r Errors.Fatal_ActionMustHaveFunctionType (err_msg t) in + + let k = N.normalize [Beta] env k in + match (SS.compress k).n with + | Tm_arrow {bs; comp=c} -> + let bs, c = SS.open_comp bs c in + let us, a, is = repr_args (U.comp_result c) in + let ct = { + comp_univs = us; + effect_name = ed.mname; + result_typ = a; + effect_args = is; + flags = [] } in + U.arrow bs (S.mk_Comp ct) + | _ -> raise_error r Errors.Fatal_ActionMustHaveFunctionType (err_msg k) in + + if Debug.medium () || !dbg_LayeredEffectsTc then + BU.print1 "Action type after injecting it into the monad: %s\n" (show act_typ); + + let act = + let us, act_defn = Gen.generalize_universes env act_defn in + if act.action_univs = [] + then + { act with + action_univs = us; + action_defn = act_defn; + action_typ = SS.close_univ_vars us act_typ } + else + if List.length us = List.length act.action_univs && + List.forall2 (fun u1 u2 -> S.order_univ_name u1 u2 = 0) us act.action_univs + then { act with + action_defn = act_defn; + action_typ = SS.close_univ_vars act.action_univs act_typ } + else raise_error r Errors.Fatal_UnexpectedNumberOfUniverse + (BU.format4 "Expected and generalized universes in the declaration for %s:%s are different, input: %s, but after gen: %s" + (string_of_lid ed.mname) (string_of_lid act.action_name) (show us) (show act.action_univs)) + in + + act in + + let tc_action_with_ctx env (act:action) = + Errors.with_ctx (BU.format1 "While checking the action %s" (string_of_lid act.action_name)) + (fun () -> tc_action env act) in + + // set extraction mode + let extraction_mode = + let has_primitive_extraction = + U.has_attribute ed.eff_attrs PC.primitive_extraction_attr in + let is_reifiable = List.contains Reifiable quals in + + if has_primitive_extraction && is_reifiable + then raise_error ed.mname Errors.Fatal_UnexpectedEffect + (BU.format1 "Effect %s is declared to be both primitive extraction and reifiable" + (show ed.mname)) + else begin + if has_primitive_extraction + then S.Extract_primitive + else + let us, a_b, rest_bs = + let us, t = let us, t, _ = signature in us, t in + match (SS.compress t).n with + | Tm_arrow {bs} -> + let a_b::rest_bs = SS.open_binders bs in + us, a_b, rest_bs + | _ -> failwith "Impossible!" // there are multiple places above where we have relied on sig being an arrow + in + let env = Env.push_univ_vars env0 us in + let env = Env.push_binders env [a_b] in + let _, r = List.fold_left (fun (env, r) b -> + let r = r && N.non_info_norm env b.binder_bv.sort in + Env.push_binders env [b], r) (env, true) rest_bs in + if r && + Substitutive_combinator? bind_kind && + (is_reifiable || lid_equals ed.mname PC.effect_TAC_lid) + then S.Extract_reify + else let m = + if not r + then "one or more effect indices are informative" + else if not (Substitutive_combinator? bind_kind) + then "bind is not substitutive" + else "the effect is not reifiable" in + S.Extract_none m + end + in + + if !dbg_LayeredEffectsTc + then BU.print2 "Effect %s has extraction mode %s\n" (show ed.mname) (show extraction_mode); + + let tschemes_of (us, t, ty) k = (us, t), (us, ty), k in + let tschemes_of2 (us, t, ty) = (us, t), (us, ty) in + + let combinators = Layered_eff ({ + l_repr = tschemes_of2 repr; + l_return = tschemes_of2 return_repr; + l_bind = tschemes_of bind_repr (Some bind_kind); + l_subcomp = tschemes_of stronger_repr (Some subcomp_kind); + l_if_then_else = tschemes_of if_then_else (Some ite_kind); + l_close = (match close_ with + | None -> None + | Some (us, t, ty) -> Some ((us, t), (us, ty))); + }) in + + { ed with + signature = Layered_eff_sig (num_effect_params, (let us, t, _ = signature in (us, t))); + combinators = combinators; + actions = List.map (tc_action_with_ctx env0) ed.actions; + extraction_mode } + ) + +let tc_non_layered_eff_decl env0 (ed:S.eff_decl) (_quals : list qualifier) (_attrs : list S.attribute) : S.eff_decl = +Errors.with_ctx (BU.format1 "While checking effect definition `%s`" (string_of_lid ed.mname)) (fun () -> + if !dbg then + BU.print1 "Typechecking eff_decl: \n\t%s\n" (show ed); + + let us, bs = + //ed.univs are free universes in the binders + //first open them + let ed_univs_subst, ed_univs = SS.univ_var_opening ed.univs in + + //ed.binders are effect parameters (e.g. heap in STATE_h), typecheck them after opening them + let bs = SS.open_binders (SS.subst_binders ed_univs_subst ed.binders) in + let bs, _, _ = tc_tparams (Env.push_univ_vars env0 ed_univs) bs in //tc_tparams forces the guard from checking the binders + + //generalize the universes in bs + //bs are closed with us and closed + let us, bs = + let tmp_t = U.arrow bs (S.mk_Total S.t_unit) in //create a temporary bs -> Tot unit + let us, tmp_t = Gen.generalize_universes env0 tmp_t in + us, tmp_t |> U.arrow_formals |> fst |> SS.close_binders in + + match ed_univs with + | [] -> us, bs //if no annotated universes, return us, bs + | _ -> + let open FStarC.Pprint in + let open FStarC.Class.PP in + let open FStarC.Errors.Msg in + //if ed.univs is already set, it must be the case that us = ed.univs, else error out + if (List.length ed_univs = List.length us && + List.forall2 (fun u1 u2 -> S.order_univ_name u1 u2 = 0) ed_univs us) + then us, bs + else raise_error ed.mname Errors.Fatal_UnexpectedNumberOfUniverse [ + text "Expected and generalized universes in effect declaration for" + ^/^ doc_of_string (string_of_lid ed.mname) ^/^ text "are different"; + text "Expected" ^/^ pp #int (List.length ed_univs) ^/^ + text "but found" ^/^ pp #int (List.length us) + ] + in + + //at this points, bs are closed and closed with us also + //they are in scope for rest of the ed + + let ed = { ed with univs = us; binders = bs } in + + //now open rest of the ed with us and bs + let ed_univs_subst, ed_univs = SS.univ_var_opening us in + let ed_bs, ed_bs_subst = SS.open_binders' (SS.subst_binders ed_univs_subst bs) in + + + let ed = + let op (us, t) = + let t = SS.subst (SS.shift_subst (List.length ed_bs + List.length us) ed_univs_subst) t in + us, SS.subst (SS.shift_subst (List.length us) ed_bs_subst) t in + + { ed with + signature = U.apply_eff_sig op ed.signature; + combinators = U.apply_eff_combinators op ed.combinators; + actions = List.map (fun a -> + { a with action_defn = snd (op (a.action_univs, a.action_defn)); + action_typ = snd (op (a.action_univs, a.action_typ)) }) ed.actions; + } in + + if !dbg then + BU.print1 "After typechecking binders eff_decl: \n\t%s\n" (show ed); + + let env = Env.push_binders (Env.push_univ_vars env0 ed_univs) ed_bs in + + (* + * AR: check that (us, t) has type k, and generalize (us, t) + * comb is the name of the combinator (useful for error messages) + * n is the expected number of free universes (after generalization) + * env_opt is an optional env (e.g. bind_repr is typechecked lax) + *) + let check_and_gen' (comb:string) (n:int) env_opt (us, t) k : tscheme = + let env = if is_some env_opt then env_opt |> must else env in + let us, t = SS.open_univ_vars us t in + let t = + match k with + | Some k -> tc_check_trivial_guard (Env.push_univ_vars env us) t k + | None -> + let t, _, g = tc_tot_or_gtot_term (Env.push_univ_vars env us) t in + Rel.force_trivial_guard env g; + t in + let g_us, t = Gen.generalize_universes env t in + //check that n = List.length g_us and that if us is set, it is same as g_us + begin + if List.length g_us <> n then + let error = BU.format4 + "Expected %s:%s to be universe-polymorphic in %s universes, found %s" + (string_of_lid ed.mname) comb (string_of_int n) (g_us |> List.length |> string_of_int) in + raise_error t Errors.Fatal_MismatchUniversePolymorphic error + end; + match us with + | [] -> g_us, t + | _ -> + if List.length us = List.length g_us && + List.forall2 (fun u1 u2 -> S.order_univ_name u1 u2 = 0) us g_us + then g_us, t + else raise_error t Errors.Fatal_UnexpectedNumberOfUniverse + (BU.format4 "Expected and generalized universes in the declaration for %s:%s are different, expected: %s, but found %s" + (string_of_lid ed.mname) comb (BU.string_of_int (List.length us)) (BU.string_of_int (List.length g_us))) + in + + let signature = check_and_gen' "signature" 1 None (U.effect_sig_ts ed.signature) None in + + if !dbg then + BU.print1 "Typechecked signature: %s\n" (Print.tscheme_to_string signature); + + (* + * AR: return a fresh (in the sense of fresh universe) instance of a:Type and wp sort (closed with the returned a) + *) + let fresh_a_and_wp () = + let fail t = Err.unexpected_signature_for_monad env (ed.signature |> U.effect_sig_ts |> snd).pos ed.mname t in + //instantiate with fresh universes + let _, signature = Env.inst_tscheme signature in + match (SS.compress signature).n with + | Tm_arrow {bs} -> + let bs = SS.open_binders bs in + (match bs with + | [({binder_bv=a}); ({binder_bv=wp})] -> a, wp.sort + | _ -> fail signature) + | _ -> fail signature + in + + let log_combinator s ts = + if !dbg then + BU.print3 "Typechecked %s:%s = %s\n" (string_of_lid ed.mname) s (Print.tscheme_to_string ts) in + + let ret_wp = + let a, wp_sort = fresh_a_and_wp () in + let k = U.arrow [ S.mk_binder a; S.null_binder (S.bv_to_name a)] (S.mk_GTotal wp_sort) in + check_and_gen' "ret_wp" 1 None (ed |> U.get_return_vc_combinator) (Some k) in + + log_combinator "ret_wp" ret_wp; + + let bind_wp = + let a, wp_sort_a = fresh_a_and_wp () in + let b, wp_sort_b = fresh_a_and_wp () in + let wp_sort_a_b = U.arrow [S.null_binder (S.bv_to_name a)] (S.mk_Total wp_sort_b) in + + let k = U.arrow [ + S.mk_binder a; + S.mk_binder b; + S.null_binder wp_sort_a; + S.null_binder wp_sort_a_b ] (S.mk_Total wp_sort_b) in + + check_and_gen' "bind_wp" 2 None (ed |> U.get_bind_vc_combinator |> fst) (Some k) in + + log_combinator "bind_wp" bind_wp; + + let stronger = + let a, wp_sort_a = fresh_a_and_wp () in + let t, _ = U.type_u() in + let k = U.arrow [ + S.mk_binder a; + S.null_binder wp_sort_a; + S.null_binder wp_sort_a ] (S.mk_Total t) in + check_and_gen' "stronger" 1 None (ed |> U.get_stronger_vc_combinator |> fst) (Some k) in + + log_combinator "stronger" stronger; + + let if_then_else = + let a, wp_sort_a = fresh_a_and_wp () in + let p = S.new_bv (Some (range_of_lid ed.mname)) (U.type_u() |> fst) in + let k = U.arrow [ + S.mk_binder a; + S.mk_binder p; + S.null_binder wp_sort_a; + S.null_binder wp_sort_a ] (S.mk_Total wp_sort_a) in + + check_and_gen' "if_then_else" 1 None (ed |> U.get_wp_if_then_else_combinator |> must) (Some k) in + + log_combinator "if_then_else" if_then_else; + + let ite_wp = + let a, wp_sort_a = fresh_a_and_wp () in + let k = U.arrow [S.mk_binder a; S.null_binder wp_sort_a] (S.mk_Total wp_sort_a) in + check_and_gen' "ite_wp" 1 None (ed |> U.get_wp_ite_combinator |> must) (Some k) in + + log_combinator "ite_wp" ite_wp; + + let close_wp = + let a, wp_sort_a = fresh_a_and_wp () in + let b = S.new_bv (Some (range_of_lid ed.mname)) (U.type_u() |> fst) in + let wp_sort_b_a = U.arrow [S.null_binder (S.bv_to_name b)] (S.mk_Total wp_sort_a) in + + let k = U.arrow [S.mk_binder a; S.mk_binder b; S.null_binder wp_sort_b_a] (S.mk_Total wp_sort_a) in + check_and_gen' "close_wp" 2 None (ed |> U.get_wp_close_combinator |> must) (Some k) in + + log_combinator "close_wp" close_wp; + + let trivial = + let a, wp_sort_a = fresh_a_and_wp () in + let t, _ = U.type_u () in + let k = U.arrow [S.mk_binder a; S.null_binder wp_sort_a] (S.mk_GTotal t) in + let trivial = check_and_gen' "trivial" 1 None (ed |> U.get_wp_trivial_combinator |> must) (Some k) in + + log_combinator "trivial" trivial; + + trivial in + + let repr, return_repr, bind_repr, actions = + match ed |> U.get_eff_repr with + | None -> None, None, None, ed.actions + | _ -> + let repr = + let a, wp_sort_a = fresh_a_and_wp () in + let t, _ = U.type_u () in + let k = U.arrow [S.mk_binder a; S.null_binder wp_sort_a] (S.mk_GTotal t) in + check_and_gen' "repr" 1 None (ed |> U.get_eff_repr |> must) (Some k) in + + log_combinator "repr" repr; + + let mk_repr' t wp = + let _, repr = Env.inst_tscheme repr in + let repr = N.normalize [EraseUniverses; AllowUnboundUniverses] env repr in + mk (Tm_app {hd=repr;args=[t |> as_arg; wp |> as_arg]}) Range.dummyRange in + let mk_repr a wp = mk_repr' (S.bv_to_name a) wp in + let destruct_repr t = + match (SS.compress t).n with + | Tm_app {args=[(t, _); (wp, _)]} -> t, wp + | _ -> failwith "Unexpected repr type" in + + let return_repr = + let return_repr_ts = ed |> U.get_return_repr |> must in + let a, _ = fresh_a_and_wp () in + let x_a = S.gen_bv "x_a" None (S.bv_to_name a) in + let res = + let wp = mk_Tm_app + (Env.inst_tscheme ret_wp |> snd) + [S.bv_to_name a |> S.as_arg; S.bv_to_name x_a |> S.as_arg] Range.dummyRange in + mk_repr a wp in + let k = U.arrow [S.mk_binder a; S.mk_binder x_a] (S.mk_Total res) in + let k, _, _ = tc_tot_or_gtot_term env k in + let env = Some (Env.set_range env (snd return_repr_ts).pos) in + check_and_gen' "return_repr" 1 env return_repr_ts (Some k) in + + log_combinator "return_repr" return_repr; + + let bind_repr = + let bind_repr_ts = ed |> U.get_bind_repr |> must in + let a, wp_sort_a = fresh_a_and_wp () in + let b, wp_sort_b = fresh_a_and_wp () in + let wp_sort_a_b = U.arrow [S.null_binder (S.bv_to_name a)] (S.mk_Total wp_sort_b) in + let wp_f = S.gen_bv "wp_f" None wp_sort_a in + let wp_g = S.gen_bv "wp_g" None wp_sort_a_b in + let x_a = S.gen_bv "x_a" None (S.bv_to_name a) in + let wp_g_x = mk_Tm_app (S.bv_to_name wp_g) [S.bv_to_name x_a |> S.as_arg] Range.dummyRange in + let res = + let wp = mk_Tm_app + (Env.inst_tscheme bind_wp |> snd) + (List.map as_arg [S.bv_to_name a; S.bv_to_name b; S.bv_to_name wp_f; S.bv_to_name wp_g]) + Range.dummyRange in + mk_repr b wp in + + let maybe_range_arg = + if BU.for_some (TEQ.eq_tm_bool env U.dm4f_bind_range_attr) ed.eff_attrs + then [S.null_binder S.t_range; S.null_binder S.t_range] + else [] in + + let k = U.arrow ([S.mk_binder a; S.mk_binder b] @ + maybe_range_arg @ + [S.mk_binder wp_f; + S.null_binder (mk_repr a (S.bv_to_name wp_f)); + S.mk_binder wp_g; + S.null_binder (U.arrow [S.mk_binder x_a] (S.mk_Total <| mk_repr b (wp_g_x)))]) + (S.mk_Total res) in + let k, _, _ = tc_tot_or_gtot_term env k in + let env = Env.set_range env (snd bind_repr_ts).pos in + let env = {env with admit = true} |> Some in //we do not expect the bind to verify, since that requires internalizing monotonicity of WPs + check_and_gen' "bind_repr" 2 env bind_repr_ts (Some k) in + + log_combinator "bind_repr" bind_repr; + + let actions = + let check_action (act:action) = + (* We should not have action params anymore, they should have been handled by dmff below *) + if List.length act.action_params <> 0 then failwith "tc_eff_decl: expected action_params to be empty"; + + // 0) The action definition has a (possibly) useless type; the + // action cps'd type contains the "good" wp that tells us EVERYTHING + // about what this action does. Please note that this "good" wp is + // of the form [binders -> repr ...], i.e. is it properly curried. + + //in case action has universes, open the action type etc. first + let env, act = + if act.action_univs = [] then env, act + else + let usubst, uvs = SS.univ_var_opening act.action_univs in + Env.push_univ_vars env uvs, + { act with + action_univs = uvs; + action_defn = SS.subst usubst act.action_defn; + action_typ = SS.subst usubst act.action_typ } in + + //AR: if the act typ is already in the effect monad (e.g. in the second phase), + // then, convert it to repr, so that the code after it can work as it is + // perhaps should open/close binders properly + let act_typ = + match (SS.compress act.action_typ).n with + | Tm_arrow {bs; comp=c} -> + let c = Env.comp_to_comp_typ env c in + if lid_equals c.effect_name ed.mname + then U.arrow bs (S.mk_Total (mk_repr' c.result_typ (fst (List.hd c.effect_args)))) + else act.action_typ + | _ -> act.action_typ + in + + let act_typ, _, g_t = tc_tot_or_gtot_term env act_typ in + + // 1) Check action definition, setting its expected type to + // [action_typ] + let env' = { Env.set_expected_typ env act_typ with instantiate_imp = false } in + if !dbg then + BU.print3 "Checking action %s:\n[definition]: %s\n[cps'd type]: %s\n" + (string_of_lid act.action_name) (show act.action_defn) + (show act_typ); + let act_defn, _, g_a = tc_tot_or_gtot_term env' act.action_defn in + + Rel.force_trivial_guard env (Env.conj_guards [g_a; g_t]); + + let act_defn = N.normalize [ Env.UnfoldUntil S.delta_constant ] env act_defn in + let act_typ = N.normalize [ Env.UnfoldUntil S.delta_constant; Env.Eager_unfolding; Env.Beta ] env act_typ in + // 2) This implies that [action_typ] has Type(k): good for us! + + // 3) Unify [action_typ] against [expected_k], because we also need + // to check that the action typ is of the form [binders -> repr ...] + let expected_k, g_k = + let act_typ = SS.compress act_typ in + match act_typ.n with + | Tm_arrow {bs; comp=c} -> + let bs, _ = SS.open_comp bs c in + let res = mk_repr' S.tun S.tun in + let k = U.arrow bs (S.mk_Total res) in + let k, _, g = tc_tot_or_gtot_term env k in + k, g + | _ -> raise_error act_defn Errors.Fatal_ActionMustHaveFunctionType + (BU.format2 "Actions must have function types (not: %s, a.k.a. %s)" (show act_typ) (tag_of act_typ)) + in + + // The following Rel query is only to check that act_typ has + // the right shape, no actual typechecking going on here + (let g = Rel.teq env act_typ expected_k in + let g = Env.conj_guard g g_k in + match g.guard_f with + | NonTrivial _ -> + raise_error act_defn Errors.Fatal_ActionMustHaveFunctionType + (BU.format1 "Unexpected non trivial guard formula when checking action type shape (%s)" + (show act_typ)) + | Trivial -> + Rel.force_trivial_guard {env with admit=true} (Env.conj_guards [g_k; g])); + + // 4) Do a bunch of plumbing to assign a type in the new monad to + // the action + let act_typ = match (SS.compress expected_k).n with + | Tm_arrow {bs; comp=c} -> + let bs, c = SS.open_comp bs c in + let a, wp = destruct_repr (U.comp_result c) in + let c = { + comp_univs=[env.universe_of (Env.push_binders env bs) a]; + effect_name = ed.mname; + result_typ = a; + effect_args = [as_arg wp]; + flags = [] + } in + U.arrow bs (S.mk_Comp c) + | _ -> failwith "Impossible (expected_k is an arrow)" in + + (* printfn "Checked action %s against type %s\n" *) + (* (show act_defn) *) + (* (show (N.normalize [Env.Beta] env act_typ)); *) + + //AR: if the action universes were already annotated, simply close, else generalize + let univs, act_defn = + if act.action_univs = [] + then Gen.generalize_universes env act_defn + else act.action_univs, SS.close_univ_vars act.action_univs act_defn + in + let act_typ = N.normalize [Env.Beta] env act_typ in + let act_typ = Subst.close_univ_vars univs act_typ in + {act with + action_univs=univs; + action_defn=act_defn; + action_typ =act_typ } + in + ed.actions |> List.map check_action in + + Some repr, Some return_repr, Some bind_repr, actions + in + + //close the ed_univs and ed_bs + let cl ts = + let ts = SS.close_tscheme ed_bs ts in + let ed_univs_closing = SS.univ_var_closing ed_univs in + SS.subst_tscheme (SS.shift_subst (List.length ed_bs) ed_univs_closing) ts in + + let combinators = { + ret_wp = ret_wp; + bind_wp = bind_wp; + stronger = stronger; + if_then_else = if_then_else; + ite_wp = ite_wp; + close_wp = close_wp; + trivial = trivial; + + repr = repr; + return_repr = return_repr; + bind_repr = bind_repr; + } in + + let combinators = U.apply_wp_eff_combinators cl combinators in + let combinators = + match ed.combinators with + | Primitive_eff _ -> Primitive_eff combinators + | DM4F_eff _ -> DM4F_eff combinators + | _ -> failwith "Impossible! tc_eff_decl on a layered effect is not expected" in + + //univs and binders have already been set + let ed = { ed with + signature = WP_eff_sig (cl signature); + combinators = combinators; + actions = + List.map (fun a -> + { a with + action_typ = cl (a.action_univs, a.action_typ) |> snd; + action_defn = cl (a.action_univs, a.action_defn) |> snd }) actions } in + + if !dbg then + BU.print1 "Typechecked effect declaration:\n\t%s\n" (show ed); + + ed +) + +let tc_eff_decl env ed quals attrs = + if ed |> U.is_layered + then tc_layered_eff_decl env ed quals attrs + else tc_non_layered_eff_decl env ed quals attrs + +let monad_signature env m s = + let fail () = Err.unexpected_signature_for_monad env (range_of_lid m) m s in + let s = SS.compress s in + match s.n with + | Tm_arrow {bs; comp=c} -> + let bs = SS.open_binders bs in + begin match bs with + | [({binder_bv=a});({binder_bv=wp})] -> a, wp.sort + | _ -> fail () + end + | _ -> fail () + +(* + * Typecheck lift to/from a layered effect + * + *) +let tc_layered_lift env0 (sub:S.sub_eff) : S.sub_eff = + if !dbg_LayeredEffectsTc then + BU.print1 "Typechecking sub_effect: %s\n" (show sub); + + let lift_ts = sub.lift |> must in + let r = (lift_ts |> snd).pos in + + let us, lift, lift_ty = check_and_gen env0 "" "lift" 1 lift_ts in + + if !dbg_LayeredEffectsTc then + BU.print2 "Typechecked lift: %s and lift_ty: %s\n" + (Print.tscheme_to_string (us, lift)) (Print.tscheme_to_string ((us, lift_ty))); + + let us, lift_ty = SS.open_univ_vars us lift_ty in + let env = Env.push_univ_vars env0 us in + + let k, kind = validate_indexed_effect_lift_shape env sub.source sub.target (List.hd us) lift_ty r in + + let sub = { sub with + lift = Some (us, lift); + lift_wp = Some (us, k |> SS.close_univ_vars us); + kind = Some kind } in + + if !dbg_LayeredEffectsTc then + BU.print1 "Final sub_effect: %s\n" (show sub); + + sub + +let check_lift_for_erasable_effects env (m1:lident) (m2:lident) (r:Range.range) : unit = + let err reason = raise_error r Errors.Fatal_UnexpectedEffect + (BU.format3 "Error defining a lift/subcomp %s ~> %s: %s" + (string_of_lid m1) (string_of_lid m2) reason) in + + let m1 = Env.norm_eff_name env m1 in + if lid_equals m1 PC.effect_GHOST_lid + then err "user-defined lifts from GHOST effect are not allowed" + else + let m1_erasable = Env.is_erasable_effect env m1 in + let m2_erasable = Env.is_erasable_effect env m2 in + if m2_erasable && + not m1_erasable && + not (lid_equals m1 PC.effect_PURE_lid) + then err "cannot lift a non-erasable effect to an erasable effect unless the non-erasable effect is PURE" + +let tc_lift env sub r = + if lid_equals sub.source sub.target + then raise_error r Fatal_UnexpectedEffect + (BU.format1 + "Cannot define a lift with same source and target (%s)" + (show sub.source)); + + let check_and_gen env t k = + // BU.print1 "\x1b[01;36mcheck and gen \x1b[00m%s\n" (show t); + Gen.generalize_universes env (tc_check_trivial_guard env t k) in + + check_lift_for_erasable_effects env sub.source sub.target r; + + let ed_src = Env.get_effect_decl env sub.source in + let ed_tgt = Env.get_effect_decl env sub.target in + + if ed_src |> U.is_layered || ed_tgt |> U.is_layered + then tc_layered_lift (Env.set_range env r) sub + else + let a, wp_a_src = monad_signature env sub.source (Env.lookup_effect_lid env sub.source) in + let b, wp_b_tgt = monad_signature env sub.target (Env.lookup_effect_lid env sub.target) in + let wp_a_tgt = SS.subst [NT(b, S.bv_to_name a)] wp_b_tgt in + let expected_k = U.arrow [S.mk_binder a; S.null_binder wp_a_src] (S.mk_Total wp_a_tgt) in + let repr_type eff_name a wp = + if not (is_reifiable_effect env eff_name) + then raise_error env Errors.Fatal_EffectCannotBeReified (BU.format1 "Effect %s cannot be reified" (string_of_lid eff_name)); + match Env.effect_decl_opt env eff_name with + | None -> failwith "internal error: reifiable effect has no decl?" + | Some (ed, qualifiers) -> + let repr = Env.inst_effect_fun_with [U_unknown] env ed (ed |> U.get_eff_repr |> must) in + mk (Tm_app {hd=repr; args=[as_arg a; as_arg wp]}) (Env.get_range env) + in + let lift, lift_wp = + match sub.lift, sub.lift_wp with + | None, None -> failwith "Impossible (parser)" + | lift, Some (uvs, lift_wp) -> + //AR: open the universes, if present (two phases) + let env, lift_wp = + if List.length uvs > 0 then + let usubst, uvs = SS.univ_var_opening uvs in + Env.push_univ_vars env uvs, SS.subst usubst lift_wp + else env, lift_wp + in + (* Covers both the "classic" format and the reifiable case. *) + //AR: if universes are already annotated, simply close, else generalize + let lift_wp = if List.length uvs = 0 then check_and_gen env lift_wp expected_k + else let lift_wp = tc_check_trivial_guard env lift_wp expected_k in uvs, SS.close_univ_vars uvs lift_wp + in + lift, lift_wp + (* Sub-effect for free case *) + | Some (what, lift), None -> + //AR: open the universes if present (two phases) + let uvs, lift = + if List.length what > 0 + then let usubst, uvs = SS.univ_var_opening what in + uvs, SS.subst usubst lift + else [], lift + in + if !dbg + then BU.print1 "Lift for free : %s\n" (show lift); + let dmff_env = DMFF.empty env (tc_constant env Range.dummyRange) in + let lift, comp, _ = tc_term (Env.push_univ_vars env uvs) lift in //AR: push univs in the env + (* TODO : Check that comp is pure ? *) + let _, lift_wp, lift_elab = DMFF.star_expr dmff_env lift in + let lift_wp = DMFF.recheck_debug "lift-wp" env lift_wp in + let lift_elab = DMFF.recheck_debug "lift-elab" env lift_elab in + if List.length uvs = 0 then Some (Gen.generalize_universes env lift_elab), Gen.generalize_universes env lift_wp + else Some (uvs, SS.close_univ_vars uvs lift_elab), (uvs, SS.close_univ_vars uvs lift_wp) + in + (* we do not expect the lift to verify, *) + (* since that requires internalizing monotonicity of WPs *) + let env = {env with admit=true} in + let lift = match lift with + | None -> None + | Some (uvs, lift) -> + let env, lift = + let usubst, uvs = SS.univ_var_opening uvs in + Env.push_univ_vars env uvs, SS.subst usubst lift + in + let a, wp_a_src = monad_signature env sub.source (Env.lookup_effect_lid env sub.source) in + let wp_a = S.new_bv None wp_a_src in + let a_typ = S.bv_to_name a in + let wp_a_typ = S.bv_to_name wp_a in + let repr_f = repr_type sub.source a_typ wp_a_typ in + let repr_result = + let lift_wp = N.normalize [Env.EraseUniverses; Env.AllowUnboundUniverses] env (snd lift_wp) in + let lift_wp_a = mk (Tm_app {hd=lift_wp;args=[as_arg a_typ; as_arg wp_a_typ]}) (Env.get_range env) in + repr_type sub.target a_typ lift_wp_a in + let expected_k = + U.arrow [S.mk_binder a; S.mk_binder wp_a; S.null_binder repr_f] + (S.mk_Total repr_result) in + let expected_k, _, _ = + tc_tot_or_gtot_term env expected_k in + let lift = + if List.length uvs = 0 then check_and_gen env lift expected_k + else + let lift = tc_check_trivial_guard env lift expected_k in + uvs, SS.close_univ_vars uvs lift in + Some lift + in + //check that sub effecting is universe polymorphic in exactly one universe + if lift_wp |> fst |> List.length <> 1 then + raise_error r Errors.Fatal_TooManyUniverse + (BU.format3 "Sub effect wp must be polymorphic in exactly 1 universe; %s ~> %s has %s universes" + (show sub.source) (show sub.target) + (lift_wp |> fst |> List.length |> string_of_int)); + if is_some lift && lift |> must |> fst |> List.length <> 1 then + raise_error r Errors.Fatal_TooManyUniverse + (BU.format3 "Sub effect lift must be polymorphic in exactly 1 universe; %s ~> %s has %s universes" + (show sub.source) (show sub.target) + (lift |> must |> fst |> List.length |> string_of_int)); + ({ sub with lift_wp=Some lift_wp; lift=lift }) + +let tc_effect_abbrev env (lid, uvs, tps, c) r = + let env0 = env in + //assert (uvs = []); AR: not necessarily, two phases + + //AR: open universes in tps and c if needed + let env, uvs, tps, c = + if List.length uvs = 0 then env, uvs, tps, c + else + let usubst, uvs = SS.univ_var_opening uvs in + let tps = SS.subst_binders usubst tps in + let c = SS.subst_comp (SS.shift_subst (List.length tps) usubst) c in + Env.push_univ_vars env uvs, uvs, tps, c + in + let env = Env.set_range env r in + let tps, c = SS.open_comp tps c in + let tps, env, us = tc_tparams env tps in + let c, u, g = tc_comp env c in + // + //Check if this effect is marked as a default effect in the effect decl. + // of its unfolded effect + //If so, we need to check that it has only a type argument + // + let is_default_effect = + match c |> U.comp_effect_name |> Env.get_default_effect env with + | None -> false + | Some l -> lid_equals l lid in + Rel.force_trivial_guard env g; + let _ = + let expected_result_typ = + match tps with + | ({binder_bv=x})::tl -> + if is_default_effect && not (tl = []) + then raise_error r Errors.Fatal_UnexpectedEffect + (BU.format2 "Effect %s is marked as a default effect for %s, but it has more than one arguments" + (string_of_lid lid) + (c |> U.comp_effect_name |> string_of_lid)); + S.bv_to_name x + | _ -> raise_error r Errors.Fatal_NotEnoughArgumentsForEffect + "Effect abbreviations must bind at least the result type" + in + let def_result_typ = FStarC.Syntax.Util.comp_result c in + if not (Rel.teq_nosmt_force env expected_result_typ def_result_typ) + then raise_error r Errors.Fatal_EffectAbbreviationResultTypeMismatch + (BU.format2 "Result type of effect abbreviation `%s` \ + does not match the result type of its definition `%s`" + (show expected_result_typ) + (show def_result_typ)) + in + let tps = SS.close_binders tps in + let c = SS.close_comp tps c in + let uvs, t = Gen.generalize_universes env0 (mk (Tm_arrow {bs=tps; comp=c}) r) in + let tps, c = match tps, (SS.compress t).n with + | [], Tm_arrow {comp=c} -> [], c + | _, Tm_arrow {bs=tps; comp=c} -> tps, c + | _ -> failwith "Impossible (t is an arrow)" in + if List.length uvs <> 1 + then begin + let _, t = Subst.open_univ_vars uvs t in + raise_error r Errors.Fatal_TooManyUniverse + (BU.format3 "Effect abbreviations must be polymorphic in exactly 1 universe; %s has %s universes (%s)" + (show lid) + (show (List.length uvs)) + (show t)) + end; + (lid, uvs, tps, c) + + +let check_polymonadic_bind_for_erasable_effects env (m:lident) (n:lident) (p:lident) (r:Range.range) = + let err reason = raise_error r Errors.Fatal_UnexpectedEffect + (BU.format4 "Error definition polymonadic bind (%s, %s) |> %s: %s" + (show m) (show n) (show p) reason) in + + let m = Env.norm_eff_name env m in + let n = Env.norm_eff_name env n in + + if lid_equals m PC.effect_GHOST_lid || + lid_equals n PC.effect_GHOST_lid + then err "GHOST computations are not allowed to be composed using user-defined polymonadic binds" + else + let m_erasable = Env.is_erasable_effect env m in + let n_erasable = Env.is_erasable_effect env n in + let p_erasable = Env.is_erasable_effect env p in + + + if p_erasable + then if not m_erasable && not (lid_equals m PC.effect_PURE_lid) + then err (BU.format1 "target effect is erasable but %s is neither erasable nor PURE" (string_of_lid m)) + else if not n_erasable && not (lid_equals n PC.effect_PURE_lid) + then err (BU.format1 "target effect is erasable but %s is neither erasable nor PURE" (string_of_lid n)) + +let tc_polymonadic_bind env (m:lident) (n:lident) (p:lident) (ts:S.tscheme) + : (S.tscheme & S.tscheme & S.indexed_effect_combinator_kind) = + + let eff_name = BU.format3 "(%s, %s) |> %s)" + (m |> ident_of_lid |> string_of_id) + (n |> ident_of_lid |> string_of_id) + (p |> ident_of_lid |> string_of_id) in + let r = (snd ts).pos in + + check_polymonadic_bind_for_erasable_effects env m n p r; + + //p should be non-reifiable, reification of polymonadic binds is not yet implemented + (* + * AR: TODO: FIXME: we are allowing reification of effects that use polymoandic binds, + * but this should only be used for proofs, extracting such code would + * not work + *) + // if Env.is_user_reifiable_effect env p + // then raise_error (Errors.Fatal_EffectCannotBeReified, + // BU.format2 "Error typechecking the polymonadic bind %s, the final effect %s is reifiable \ + // and reification of polymondic binds is not yet implemented" + // eff_name (Ident.string_of_lid p)) r; + + //typecheck the term making sure that it is universe polymorphic in 2 universes + let (us, t, ty) = check_and_gen env eff_name "polymonadic_bind" 2 ts in + + //make sure that the bind is of the right shape + + let us, ty = SS.open_univ_vars us ty in + let env = Env.push_univ_vars env us in + + let m_ed, n_ed, p_ed = Env.get_effect_decl env m, Env.get_effect_decl env n, Env.get_effect_decl env p in + + let k, kind = validate_indexed_effect_bind_shape env m n p + (U.effect_sig_ts m_ed.signature) + (U.effect_sig_ts n_ed.signature) + (U.effect_sig_ts p_ed.signature) + (U.get_eff_repr m_ed) (U.get_eff_repr n_ed) (U.get_eff_repr p_ed) + us + ty + (Env.get_range env) + 0 + false in + + if Debug.extreme () + then BU.print3 "Polymonadic bind %s after typechecking (%s::%s)\n" + eff_name (Print.tscheme_to_string (us, t)) + (Print.tscheme_to_string (us, k)); + + log_issue r Errors.Warning_BleedingEdge_Feature [Errors.text <| + BU.format1 "Polymonadic binds (%s in this case) is an experimental feature;\ + it is subject to some redesign in the future. Please keep us informed (on github etc.) about how you are using it" + eff_name + ]; + + (us, t), (us, k |> SS.close_univ_vars us), kind + + +let tc_polymonadic_subcomp env0 (m:lident) (n:lident) (ts:S.tscheme) = + let r = (snd ts).pos in + + check_lift_for_erasable_effects env0 m n r; + + let combinator_name = + (m |> ident_of_lid |> string_of_id) ^ " <: " ^ + (n |> ident_of_lid |> string_of_id) in + + let us, t, ty = check_and_gen env0 combinator_name "polymonadic_subcomp" 1 ts in + + //make sure that the combinator has the right shape + + let us, ty = SS.open_univ_vars us ty in + let env = Env.push_univ_vars env0 us in + + let m_ed, n_ed = Env.get_effect_decl env m, Env.get_effect_decl env n in + + let k, kind = validate_indexed_effect_subcomp_shape env m n + (U.effect_sig_ts m_ed.signature) + (U.effect_sig_ts n_ed.signature) + (U.get_eff_repr m_ed) (U.get_eff_repr n_ed) + (List.hd us) + ty + 0 + (Env.get_range env) in + + if Debug.extreme () + then BU.print3 "Polymonadic subcomp %s after typechecking (%s::%s)\n" + combinator_name + (Print.tscheme_to_string (us, t)) + (Print.tscheme_to_string (us, k)); + + log_issue r Errors.Warning_BleedingEdge_Feature [ + Errors.text <| + BU.format1 "Polymonadic subcomp (%s in this case) is an experimental feature;\ + it is subject to some redesign in the future. Please keep us informed (on github etc.) about how you are using it" + combinator_name + ]; + + (us, t), (us, k |> SS.close_univ_vars us), kind diff --git a/src/typechecker/FStarC.TypeChecker.TcEffect.fsti b/src/typechecker/FStarC.TypeChecker.TcEffect.fsti new file mode 100644 index 00000000000..b6449e38809 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.TcEffect.fsti @@ -0,0 +1,38 @@ +(* + Copyright 2008-2018 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.TypeChecker.TcEffect + +open FStarC.Compiler.Effect + +open FStar open FStarC +open FStarC.Compiler +open FStarC.Ident + +module S = FStarC.Syntax.Syntax +module Env = FStarC.TypeChecker.Env + + +val dmff_cps_and_elaborate : Env.env -> S.eff_decl -> (list S.sigelt & S.eff_decl & option S.sigelt) + +val tc_eff_decl : Env.env -> S.eff_decl -> list S.qualifier -> list S.attribute -> S.eff_decl + +val tc_lift : Env.env -> S.sub_eff -> Range.range -> S.sub_eff + +val tc_effect_abbrev : Env.env -> (lident & S.univ_names & S.binders & S.comp) -> Range.range -> (lident & S.univ_names & S.binders & S.comp) + +val tc_polymonadic_bind : Env.env -> m:lident -> n:lident -> p:lident -> bind_t:S.tscheme -> S.tscheme & S.tscheme & S.indexed_effect_combinator_kind + +val tc_polymonadic_subcomp : Env.env -> m:lident -> n:lident -> subcomp_t:S.tscheme -> S.tscheme & S.tscheme & S.indexed_effect_combinator_kind diff --git a/src/typechecker/FStarC.TypeChecker.TcInductive.fst b/src/typechecker/FStarC.TypeChecker.TcInductive.fst new file mode 100644 index 00000000000..e337895a1ce --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.TcInductive.fst @@ -0,0 +1,1311 @@ +(* + Copyright 2008-2014 Microsoft Research + + Authors: Nikhil Swamy, Aseem Rastogi + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) +module FStarC.TypeChecker.TcInductive +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.Errors +open FStarC.TypeChecker +open FStarC.TypeChecker.Env +open FStarC.Compiler.Util +open FStarC.Ident +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.Syntax.Subst +open FStarC.Syntax.Util +open FStarC.Const +open FStarC.TypeChecker.Rel +open FStarC.TypeChecker.Common +open FStarC.TypeChecker.TcTerm +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module N = FStarC.TypeChecker.Normalize +module TcUtil = FStarC.TypeChecker.Util +module Gen = FStarC.TypeChecker.Generalize +module BU = FStarC.Compiler.Util //basic util +module U = FStarC.Syntax.Util +module PP = FStarC.Syntax.Print +module C = FStarC.Parser.Const + +open FStarC.Class.Show +open FStarC.Class.Listlike + +let dbg_GenUniverses = Debug.get_toggle "GenUniverses" +let dbg_LogTypes = Debug.get_toggle "LogTypes" +let dbg_Injectivity = Debug.get_toggle "Injectivity" + +let unfold_whnf = N.unfold_whnf' [Env.AllowUnboundUniverses] + +let check_sig_inductive_injectivity_on_params (tcenv:env_t) (se:sigelt) + : sigelt + = if tcenv.phase1 then se else + let Sig_inductive_typ dd = se.sigel in + let { lid=t; us=universe_names; params=tps; t=k } = dd in + let t_lid = t in + let usubst, uvs = SS.univ_var_opening universe_names in + let tcenv, tps, k = + Env.push_univ_vars tcenv uvs, + SS.subst_binders usubst tps, + SS.subst (SS.shift_subst (List.length tps) usubst) k + in + let tps, k = SS.open_term tps k in + let _, k = U.arrow_formals k in //don't care about indices here + let tps, env_tps, _, us = TcTerm.tc_binders tcenv tps in + let u_k = + TcTerm.level_of_type + env_tps + (S.mk_Tm_app + (S.fvar t None) + (snd (U.args_of_binders tps)) + (Ident.range_of_lid t)) + k + in + //BU.print2 "Universe of tycon: %s : %s\n" (Ident.string_of_lid t) (show u_k); + let rec universe_leq u v = + match u, v with + | U_zero, _ -> true + | U_succ u0, U_succ v0 -> universe_leq u0 v0 + | U_name u0, U_name v0 -> Ident.ident_equals u0 v0 + | U_name _, U_succ v0 -> universe_leq u v0 + | U_max us, _ -> us |> BU.for_all (fun u -> universe_leq u v) + | _, U_max vs -> vs |> BU.for_some (universe_leq u) + | U_unknown, _ + | _, U_unknown + | U_unif _, _ + | _, U_unif _ -> failwith (BU.format3 "Impossible: Unresolved or unknown universe in inductive type %s (%s, %s)" + (show t) + (show u) + (show v)) + | _ -> false + in + let u_leq_u_k u = + let u = N.normalize_universe env_tps u in + universe_leq u u_k + in + let tp_ok (tp:S.binder) (u_tp:universe) = + let t_tp = tp.binder_bv.sort in + if u_leq_u_k u_tp + then true + else ( + let t_tp = + N.normalize + [Unrefine; Unascribe; Unmeta; + Primops; HNF; UnfoldUntil delta_constant; Beta] + env_tps t_tp + in + let formals, t = U.arrow_formals t_tp in + let _, _, _, u_formals = TcTerm.tc_binders env_tps formals in + let inj = BU.for_all (fun u_formal -> u_leq_u_k u_formal) u_formals in + if inj + then ( + match (SS.compress t).n with + | Tm_type u -> + (* retain injectivity for parameters that are type functions + from small universes (i.e., all formals are smaller than the constructed type) + to a universe <= the universe of the constructed type. + See BugBoxInjectivity.fst *) + u_leq_u_k u + | _ -> + false + ) + else ( + false + ) + + ) + in + let injective_type_params = List.forall2 tp_ok tps us in + if !dbg_Injectivity + then BU.print2 "%s injectivity for %s\n" + (if injective_type_params then "YES" else "NO") + (Ident.string_of_lid t); + { se with sigel = Sig_inductive_typ { dd with injective_type_params } } + +let tc_tycon (env:env_t) (* environment that contains all mutually defined type constructors *) + (s:sigelt) (* a Sig_inductive_type (aka tc) that needs to be type-checked *) + : env_t (* environment extended with a refined type for the type-constructor *) + & sigelt (* the typed version of s, with universe variables still TBD *) + & universe (* universe of the constructed type *) + & guard_t (* constraints on implicit variables *) + = match s.sigel with + | Sig_inductive_typ {lid=tc; us=uvs; params=tps; num_uniform_params=n_uniform; + t=k; mutuals; ds=data} -> //the only valid qual is Private + //assert (uvs = []); AR: not necessarily true in two phase + let env0 = env in + (*open*)let usubst, uvs = SS.univ_var_opening uvs in + let env, tps, k = Env.push_univ_vars env uvs, SS.subst_binders usubst tps, SS.subst (SS.shift_subst (List.length tps) usubst) k in + let tps, k = SS.open_term tps k in + let tps, env_tps, guard_params, us = tc_binders env tps in + + (* + * AR: typecheck k and get the indices and t out + * adding a very restricted normalization to unfold symbols that are marked unfold explicitly + * note that t is opened with indices (by U.arrow_formals) + *) + let (indices, t), guard = + let k, _, g = tc_tot_or_gtot_term env_tps k in + let k = N.normalize [Exclude Iota; Exclude Zeta; Eager_unfolding; NoFullNorm; Exclude Beta] env_tps k in + U.arrow_formals k, Rel.discharge_guard env_tps (Env.conj_guard guard_params g) + in + + let k = U.arrow indices (S.mk_Total t) in + let t_type, u = U.type_u() in + //AR: allow only Type and eqtype, nothing else. + // If the annotation is eqtype, then the type cannot contain the noeq qualifier + // nor the unopteq qualifier. That is, if the user wants to annotate an inductive + // as eqtype, they must run the full hasEq check + let valid_type = (U.is_eqtype_no_unrefine t && not (s.sigquals |> List.contains Noeq) && not (s.sigquals |> List.contains Unopteq)) || + (teq_nosmt_force env t t_type) in + if not valid_type then + raise_error s Errors.Error_InductiveAnnotNotAType [ + text (BU.format2 "Type annotation %s for inductive %s is not Type or eqtype, \ + or it is eqtype but contains noeq/unopteq qualifiers" + (show t) (show tc)) + ]; + +(*close*)let usubst = SS.univ_var_closing uvs in + let guard = TcUtil.close_guard_implicits env false tps guard in + let t_tc = U.arrow ((tps |> SS.subst_binders usubst) @ + (indices |> SS.subst_binders (SS.shift_subst (List.length tps) usubst))) + (S.mk_Total (t |> SS.subst (SS.shift_subst (List.length tps + List.length indices) usubst))) in + let tps = SS.close_binders tps in + let k = SS.close tps k in + let tps, k = SS.subst_binders usubst tps, SS.subst (SS.shift_subst (List.length tps) usubst) k in + let fv_tc = S.lid_as_fv tc None in + let (uvs, t_tc) = SS.open_univ_vars uvs t_tc in + Env.push_let_binding env0 (Inr fv_tc) (uvs, t_tc), + { s with sigel = Sig_inductive_typ {lid=tc; + us=uvs; + params=tps; + num_uniform_params=n_uniform; + t=k; + mutuals; + ds=data; + injective_type_params=false} }, + u, + guard + + | _ -> failwith "impossible" + +(* Used to make the binders of the tycon (ie parameters) implicit in +the projectors and discriminators. We always make them implicit, but +the argument already had a meta-qualifier, we must retain it. See bug #2591. *) +let mk_implicit : bqual -> bqual = function + | Some (Meta q) -> Some (Meta q) + | _ -> Some (Implicit false) + +(* 2. Checking each datacon *) +let tc_data (env:env_t) (tcs : list (sigelt & universe)) + : sigelt -> sigelt & guard_t = + fun se -> match se.sigel with + | Sig_datacon {lid=c; us=_uvs; t; ty_lid=tc_lid; num_ty_params=ntps; mutuals=mutual_tcs} -> + //assert (_uvs = []); + let usubst, _uvs = SS.univ_var_opening _uvs in + let env, t = Env.push_univ_vars env _uvs, SS.subst usubst t in + let (env, tps, u_tc) = //u_tc is the universe of the inductive that c constructs + let tps_u_opt = BU.find_map tcs (fun (se, u_tc) -> + if lid_equals tc_lid (must (U.lid_of_sigelt se)) + then match se.sigel with + | Sig_inductive_typ {params=tps} -> + let tps = tps |> SS.subst_binders usubst |> List.map (fun x -> {x with binder_qual=Some S.imp_tag}) in + let tps = Subst.open_binders tps in + Some (Env.push_binders env tps, tps, u_tc) + | _ -> failwith "Impossible" + else None) in + match tps_u_opt with + | Some x -> x + | None -> + if lid_equals tc_lid FStarC.Parser.Const.exn_lid + then env, [], U_zero + else raise_error se Errors.Fatal_UnexpectedDataConstructor "Unexpected data constructor" + in + + let arguments, result = + let t = N.normalize (N.whnf_steps @ [Env.AllowUnboundUniverses]) env t in //AR: allow unbounded universes, since we haven't typechecked t yet + let t = U.canon_arrow t in + match (SS.compress t).n with + | Tm_arrow {bs; comp=res} -> + //the type of each datacon is already a function with the type params as arguments + //need to map the prefix of bs corresponding to params to the tps of the inductive + let _, bs' = BU.first_N ntps bs in + let t = mk (Tm_arrow {bs=bs'; comp=res}) t.pos in + let subst = tps |> List.mapi (fun i ({binder_bv=x}) -> DB(ntps - (1 + i), x)) in +(*open*) let bs, c = U.arrow_formals_comp (SS.subst subst t) in + (* check that c is a Tot computation, reject it otherwise + * (unless --MLish, which will mark all of them with ML effect) *) + if Options.ml_ish () || is_total_comp c + then bs, comp_result c + else raise_error (U.comp_effect_name c) Errors.Fatal_UnexpectedConstructorType + "Constructors cannot have effects" + + | _ -> [], t + in + + if Debug.low () then BU.print3 "Checking datacon %s : %s -> %s \n" + (show c) + (show arguments) + (show result); + + let arguments, env', us = tc_tparams env arguments in + let type_u_tc = S.mk (Tm_type u_tc) result.pos in + let env' = Env.set_expected_typ env' type_u_tc in + let result, res_lcomp = tc_trivial_guard env' result in + let head, args = U.head_and_args_full result in (* collect nested applications too *) + + (* + * AR: if the inductive type is explictly universe annotated, + * we need to instantiate universes properly in head (head = tycon) + * the following code unifies them with the annotated universes + *) + let g_uvs = match (SS.compress head).n with + | Tm_uinst ( { n = Tm_fvar fv }, tuvs) when S.fv_eq_lid fv tc_lid -> //AR: in the second phase of 2-phases, this can be a Tm_uninst too + if List.length _uvs = List.length tuvs then + List.fold_left2 (fun g u1 u2 -> + //unify the two + Env.conj_guard g (Rel.teq env' (mk (Tm_type u1) Range.dummyRange) (mk (Tm_type (U_name u2)) Range.dummyRange)) + ) Env.trivial_guard tuvs _uvs + else Errors.raise_error se Errors.Fatal_UnexpectedConstructorType + "Length of annotated universes does not match inferred universes" + | Tm_fvar fv when S.fv_eq_lid fv tc_lid -> Env.trivial_guard + | _ -> raise_error se Errors.Fatal_UnexpectedConstructorType + (BU.format2 "Expected a constructor of type %s; got %s" (show tc_lid) (show head)) + in + let g =List.fold_left2 (fun g ({binder_bv=x}) u_x -> + Env.conj_guard g (Rel.universe_inequality u_x u_tc)) + g_uvs + arguments + us in + + (* Make sure the parameters are respected, cf #1534 *) + (* The first few arguments, as many as List.length tps, must exactly match the + * bvs in tps, as they have been opened already by the code above. Must be done + * after typechecking `result`, to make sure implicits are filled in. However, + * we stop if we logged an error, since it may mean the result type is missing + * some parameters, and we'd crash when trying to extract them. See issue + * #2167. *) + Errors.stop_if_err (); + let p_args = fst (BU.first_N (List.length tps) args) in + List.iter2 (fun ({binder_bv=bv}) (t, _) -> + match (SS.compress t).n with + | Tm_name bv' when S.bv_eq bv bv' -> () + | _ -> + raise_error t Errors.Error_BadInductiveParam + (BU.format2 "This parameter is not constant: expected %s, got %s" (show bv) (show t)) + ) tps p_args; + + let ty = unfold_whnf env res_lcomp.res_typ |> U.unrefine in + begin match (SS.compress ty).n with + | Tm_type _ -> () + | _ -> raise_error se Errors.Fatal_WrongResultTypeAfterConstrutor + (BU.format2 "The type of %s is %s, but since this is the result type of a constructor its type should be Type" + (show result) + (show ty)) + end; + +(*close*)let t = U.arrow ((tps |> List.map (fun b -> {b with binder_qual=Some (Implicit true)}))@arguments) (S.mk_Total result) in + //NB: the tps are tagged as Implicit inaccessbile arguments of the data constructor + let t = SS.close_univ_vars _uvs t in + { se with sigel = Sig_datacon {lid=c; + us=_uvs; + t; + ty_lid=tc_lid; + num_ty_params=ntps; + mutuals=mutual_tcs; + injective_type_params=false} }, + g + + | _ -> failwith "impossible" + + +(* 3. Generalizing universes and 4. instantiate inductives within the datacons *) +let generalize_and_inst_within (env:env_t) (tcs:list (sigelt & universe)) (datas:list sigelt) + : list sigelt & list sigelt + = //We build a single arrow term of the form + // tc_1 -> .. -> tc_n -> dt_1 -> .. dt_n -> Tot unit + //for each type constructor tc_i + //and each data constructor type dt_i + //and generalize their universes together + let binders = tcs |> List.map (fun (se, _) -> + match se.sigel with + | Sig_inductive_typ {params=tps; t=k} -> S.null_binder (U.arrow tps <| mk_Total k) + | _ -> failwith "Impossible") in + let binders' = datas |> List.map (fun se -> match se.sigel with + | Sig_datacon {t} -> S.null_binder t + | _ -> failwith "Impossible") in + let t = U.arrow (binders@binders') (S.mk_Total t_unit) in + if !dbg_GenUniverses + then BU.print1 "@@@@@@Trying to generalize universes in %s\n" (N.term_to_string env t); + let (uvs, t) = Gen.generalize_universes env t in + if !dbg_GenUniverses + then BU.print2 "@@@@@@Generalized to (%s, %s)\n" + (uvs |> List.map (fun u -> (string_of_id u)) |> String.concat ", ") + (show t); + //Now, (uvs, t) is the generalized type scheme for all the inductives and their data constuctors + + //we have to destruct t, knowing its shape above, + //and rebuild the Sig_inductive_typ, Sig_datacon etc + let uvs, t = SS.open_univ_vars uvs t in + let args, _ = U.arrow_formals t in + let tc_types, data_types = BU.first_N (List.length binders) args in + let tcs = List.map2 (fun ({binder_bv=x}) (se, _) -> match se.sigel with + | Sig_inductive_typ {lid=tc; params=tps; num_uniform_params=num_uniform; mutuals; ds=datas} -> + let ty = SS.close_univ_vars uvs x.sort in + let tps, t = match (SS.compress ty).n with + | Tm_arrow {bs=binders; comp=c} -> + let tps, rest = BU.first_N (List.length tps) binders in + let t = match rest with + | [] -> U.comp_result c + | _ -> mk (Tm_arrow {bs=rest; comp=c}) x.sort.pos + in + tps, t + | _ -> [], ty + in + { se with sigel = Sig_inductive_typ {lid=tc; + us=uvs; + params=tps; + num_uniform_params=num_uniform; + t; + mutuals; + ds=datas; + injective_type_params=false} } + | _ -> failwith "Impossible") + tc_types tcs + in + + //4. Instantiate the inductives in each datacon with the generalized universes + let datas = match uvs with + | [] -> datas + | _ -> + let uvs_universes = uvs |> List.map U_name in + let tc_insts = tcs |> List.map (function { sigel = Sig_inductive_typ {lid=tc} } -> (tc, uvs_universes) | _ -> failwith "Impossible") in + List.map2 (fun ({binder_bv=t}) d -> + match d.sigel with + | Sig_datacon {lid=l; ty_lid=tc; num_ty_params=ntps; mutuals} -> + let ty = InstFV.instantiate tc_insts t.sort |> SS.close_univ_vars uvs in + { d with sigel = Sig_datacon {lid=l; + us=uvs; + t=ty; + ty_lid=tc; + num_ty_params=ntps; + mutuals; + injective_type_params=false} } + | _ -> failwith "Impossible") + data_types datas + in + tcs, datas + + +let datacon_typ (data:sigelt) :term = + match data.sigel with + | Sig_datacon {t} -> t + | _ -> failwith "Impossible!" + +(* private *) +let haseq_suffix = "__uu___haseq" + +let is_haseq_lid lid = + let str = (string_of_lid lid) in + let len = String.length str in + let haseq_suffix_len = String.length haseq_suffix in + len > haseq_suffix_len && + String.compare (String.substring str (len - haseq_suffix_len) haseq_suffix_len) haseq_suffix = 0 + +let get_haseq_axiom_lid lid = + lid_of_ids (ns_of_lid lid @ [(id_of_text (string_of_id (ident_of_lid lid) ^ haseq_suffix))]) + +//get the optimized hasEq axiom for this inductive +//the caller is supposed to open the universes, and pass along the universe substitution and universe names +//returns -- lid of the hasEq axiom +// -- the hasEq axiom for the inductive +// -- opened parameter binders +// -- opened index binders +// -- conjunction of hasEq of the binders +let get_optimized_haseq_axiom (en:env) (ty:sigelt) (usubst:list subst_elt) (us:univ_names) :(lident & term & binders & binders & term) = + let lid, bs, t = + match ty.sigel with + | Sig_inductive_typ {lid; params=bs; t} -> lid, bs, t + | _ -> failwith "Impossible!" + in + + //apply usubt to bs + let bs = SS.subst_binders usubst bs in + //apply usubst to t, but first shift usubst -- is there a way to apply usubst to bs and t together ? + let t = SS.subst (SS.shift_subst (List.length bs) usubst) t in + //open t with binders bs + let bs, t = SS.open_term bs t in + //get the index binders, if any + let ibs = + match (SS.compress t).n with + | Tm_arrow {bs=ibs} -> ibs + | _ -> [] + in + //open the ibs binders + let ibs = SS.open_binders ibs in + //term for unapplied inductive type, making a Tm_uinst, otherwise there are unresolved universe variables, may be that's fine ? + let ind = mk_Tm_uinst (S.fvar lid None) (List.map (fun u -> U_name u) us) in + //apply the bs parameters, bv_to_name ok ? also note that we are copying the qualifiers from the binder, so that implicits remain implicits + let ind = mk_Tm_app ind (List.map U.arg_of_non_null_binder bs) Range.dummyRange in + //apply the ibs parameters, bv_to_name ok ? also note that we are copying the qualifiers from the binder, so that implicits remain implicits + let ind = mk_Tm_app ind (List.map U.arg_of_non_null_binder ibs) Range.dummyRange in + //haseq of ind + let haseq_ind = mk_Tm_app U.t_haseq [S.as_arg ind] Range.dummyRange in + //haseq of all binders in bs, we will add only those binders x:t for which t <: Type u for some fresh universe variable u + //we want to avoid the case of binders such as (x:nat), as hasEq x is not well-typed + let bs' = List.filter (fun b -> + Rel.subtype_nosmt_force en b.binder_bv.sort (fst (U.type_u ())) + ) bs in + let haseq_bs = List.fold_left (fun (t:term) (b:binder) -> U.mk_conj t (mk_Tm_app U.t_haseq [S.as_arg (S.bv_to_name b.binder_bv)] Range.dummyRange)) U.t_true bs' in + //implication + let fml = U.mk_imp haseq_bs haseq_ind in + //attach pattern -- is this the right place ? + let fml = { fml with n = Tm_meta {tm=fml; + meta=Meta_pattern(binders_to_names ibs, [[S.as_arg haseq_ind]])} } in + //fold right with ibs, close and add a forall b + //we are setting the qualifier of the binder to None explicitly, we don't want to make forall binder implicit etc. ? + let fml = List.fold_right (fun (b:binder) (t:term) -> mk_Tm_app U.tforall [ S.as_arg (U.abs [S.mk_binder b.binder_bv] (SS.close [b] t) None) ] Range.dummyRange) ibs fml in + + //fold right with bs, close and add a forall b + //we are setting the qualifier of the binder to None explicitly, we don't want to make forall binder implicit etc. ? + let fml = List.fold_right (fun (b:binder) (t:term) -> mk_Tm_app U.tforall [ S.as_arg (U.abs [S.mk_binder b.binder_bv] (SS.close [b] t) None) ] Range.dummyRange) bs fml in + + let axiom_lid = get_haseq_axiom_lid lid in + axiom_lid, fml, bs, ibs, haseq_bs + +//soundness condition for this data constructor +//usubst is the universe substitution, and bs are the opened inductive type parameters +let optimized_haseq_soundness_for_data (ty_lid:lident) (data:sigelt) (usubst:list subst_elt) (bs:binders) :term = + let dt = datacon_typ data in + //apply the universes substitution to dt + let dt = SS.subst usubst dt in + match (SS.compress dt).n with + | Tm_arrow {bs=dbs} -> + //filter out the inductive type parameters, dbs are the remaining binders + let dbs = snd (List.splitAt (List.length bs) dbs) in + //substitute bs into dbs + let dbs = SS.subst_binders (SS.opening_of_binders bs) dbs in + //open dbs + let dbs = SS.open_binders dbs in + //fold on dbs, add haseq of its sort to the guard + let cond = List.fold_left (fun (t:term) (b:binder) -> + let haseq_b = mk_Tm_app U.t_haseq [S.as_arg b.binder_bv.sort] Range.dummyRange in + //label the haseq predicate so that we get a proper error message if the assertion fails + let sort_range = b.binder_bv.sort.pos in + let open FStarC.Errors.Msg in + let open FStarC.Pprint in + let open FStarC.Class.PP in + let haseq_b = TcUtil.label + [ + text "Failed to prove that the type" ^/^ squotes (pp ty_lid) ^/^ text "supports decidable equality because of this argument."; + text "Add either the 'noeq' or 'unopteq' qualifier"; + ] + sort_range + haseq_b + in + U.mk_conj t haseq_b) U.t_true dbs + in + //fold right over dbs and add a forall for each binder in dbs + List.fold_right (fun (b:binder) (t:term) -> mk_Tm_app tforall [ + S.iarg b.binder_bv.sort; + S.as_arg (U.abs [S.mk_binder b.binder_bv] (SS.close [b] t) None) + ] Range.dummyRange) dbs cond + | _ -> U.t_true + +//this is the folding function for tcs +//all_datas_in_the_bundle are all data constructors, including those of mutually defined inductives +//usubst and us are the universe variables substitution and universe names, we open each type constructor type, and data constructor type with these +//in the type of the accumulator: + //list (lident * term) is the list of type constructor lidents and formulas of haseq axioms we are accumulating + //env is the environment in which the next two terms are well-formed (e.g. data constructors are dependent function types, so they may refer to their arguments) + //term is the lhs of the implication for soundness formula + //term is the soundness condition derived from all the data constructors of this type +let optimized_haseq_ty (all_datas_in_the_bundle:sigelts) (usubst:list subst_elt) (us:list univ_name) acc ty = + let lid = + match ty.sigel with + | Sig_inductive_typ {lid} -> lid + | _ -> failwith "Impossible!" + in + + let _, en, _, _ = acc in + let axiom_lid, fml, bs, ibs, haseq_bs = get_optimized_haseq_axiom en ty usubst us in + //fml is the hasEq axiom for the inductive, bs and ibs are opened binders and index binders, + //haseq_bs is the conjunction of hasEq of all the binders + + //onto the soundness condition for the above axiom + //this is the soundness guard + let guard = U.mk_conj haseq_bs fml in + + //now work on checking the soundness of this formula + //split acc + let l_axioms, env, guard', cond' = acc in + + //push universe variables, bs, and ibs, universe variables are pushed at the top level below + let env = Env.push_binders env bs in + let env = Env.push_binders env ibs in + + //now generate the soundness condition by iterating over the data constructors + //get the data constructors for this type + let t_datas = List.filter (fun s -> + match s.sigel with + | Sig_datacon {ty_lid=t_lid} -> t_lid = lid + | _ -> failwith "Impossible" + ) all_datas_in_the_bundle in + + + //fold over t_datas + let cond = List.fold_left (fun acc d -> U.mk_conj acc (optimized_haseq_soundness_for_data lid d usubst bs)) U.t_true t_datas in + + //return new accumulator + l_axioms @ [axiom_lid, fml], env, U.mk_conj guard' guard, U.mk_conj cond' cond + + +let optimized_haseq_scheme (sig_bndle:sigelt) (tcs:list sigelt) (datas:list sigelt) (env0:env_t) :list sigelt = + let us, t = + let ty = List.hd tcs in + match ty.sigel with + | Sig_inductive_typ {us; t} -> us, t + | _ -> failwith "Impossible!" + in + let usubst, us = SS.univ_var_opening us in + + // We need the sigbundle for the inductive to be in the type environment. + // We can force this push as this is only temporary, it will be rolled back + let env = Env.push env0 "haseq" in + let env = Env.push_sigelt_force env sig_bndle in + env.solver.encode_sig env sig_bndle; + let env = Env.push_univ_vars env us in + + let axioms, env, guard, cond = List.fold_left (optimized_haseq_ty datas usubst us) ([], env, U.t_true, U.t_true) tcs in + + let phi = + let _, t = U.arrow_formals t in + if U.is_eqtype_no_unrefine t then cond //AR: if the type is marked as eqtype, you don't get to assume equality of type parameters + else U.mk_imp guard cond in + let phi, _ = tc_trivial_guard env phi in + let _ = + //is this inline with verify_module ? + if Env.should_verify env then + Rel.force_trivial_guard env (Env.guard_of_guard_formula (NonTrivial phi)) + else () + in + + //create Sig_assume for the axioms, FIXME: docs? + let ses = List.fold_left (fun (l:list sigelt) (lid, fml) -> + let fml = SS.close_univ_vars us fml in + l @ [ { sigel = Sig_assume {lid; us; phi=fml}; + sigquals = [InternalAssumption]; + sigrng = Range.dummyRange; + sigmeta = default_sigmeta; + sigattrs = []; + sigopts = None; + sigopens_and_abbrevs = []; } ] + ) [] axioms in + + ignore (Env.pop env "haseq"); + + ses + +//folding function for t_datas +//usubst is the universe substitution, bs are the opened inductive type parameters +//haseq_ind is the inductive applied to all its bs and ibs +let unoptimized_haseq_data (usubst:list subst_elt) (bs:binders) (haseq_ind:term) (mutuals:list lident) (acc:term) (data:sigelt) = + + //identify if the type t is a mutually defined type + //TODO: we now have a get_free_names in Syntax.Free, use that + let rec is_mutual (t:term) = //TODO: this should handle more cases + match (SS.compress t).n with + | Tm_fvar fv -> List.existsb (fun lid -> lid_equals lid fv.fv_name.v) mutuals + | Tm_uinst (t', _) -> is_mutual t' + | Tm_refine {b=bv} -> is_mutual bv.sort + | Tm_app {hd=t'; args} -> if is_mutual t' then true else exists_mutual (List.map fst args) + | Tm_meta {tm=t'} -> is_mutual t' + | _ -> false + + and exists_mutual = function + | [] -> false + | hd::tl -> is_mutual hd || exists_mutual tl + in + + + let dt = datacon_typ data in + //apply the universes substitution to dt + let dt = SS.subst usubst dt in + match (SS.compress dt).n with + | Tm_arrow {bs=dbs} -> + //filter out the inductive type parameters, dbs are the remaining binders + let dbs = snd (List.splitAt (List.length bs) dbs) in + //substitute bs into dbs + let dbs = SS.subst_binders (SS.opening_of_binders bs) dbs in + //open dbs + let dbs = SS.open_binders dbs in + //fold on dbs, add haseq of its sort to the guard + //if the sort is a mutual, guard its hasEq with the hasEq of the current type constructor + //cond is the conjunct of the hasEq of all the data constructor arguments + let cond = List.fold_left (fun (t:term) (b:binder) -> + let sort = b.binder_bv.sort in + let haseq_sort = mk_Tm_app U.t_haseq [S.as_arg b.binder_bv.sort] Range.dummyRange in + let haseq_sort = if is_mutual sort then U.mk_imp haseq_ind haseq_sort else haseq_sort in + U.mk_conj t haseq_sort) U.t_true dbs + in + + //fold right with dbs, close and add a forall b + //we are setting the qualifier of the binder to None explicitly, we don't want to make forall binder implicit etc. ? + let cond = List.fold_right (fun (b:binder) (t:term) -> mk_Tm_app tforall [ S.as_arg (U.abs [S.mk_binder b.binder_bv] (SS.close [b] t) None) ] Range.dummyRange) dbs cond in + + //new accumulator is old one /\ cond + U.mk_conj acc cond + | _ -> acc + +//this is the folding function for tcs +//usubst and us are the universe variables substitution and universe names, we open each type constructor type, and data constructor type with these +//the accumulator is the formula that we are building, for each type constructor, we add a conjunct to it +let unoptimized_haseq_ty (all_datas_in_the_bundle:list sigelt) (mutuals:list lident) (usubst:list subst_elt) (us:list univ_name) (acc:term) (ty:sigelt) = + let lid, bs, t, d_lids = + match ty.sigel with + | Sig_inductive_typ {lid; params=bs; t; ds=d_lids} -> lid, bs, t, d_lids + | _ -> failwith "Impossible!" + in + + //apply usubt to bs + let bs = SS.subst_binders usubst bs in + //apply usubst to t, but first shift usubst -- is there a way to apply usubst to bs and t together ? + let t = SS.subst (SS.shift_subst (List.length bs) usubst) t in + //open t with binders bs + let bs, t = SS.open_term bs t in + //get the index binders, if any + let ibs = + match (SS.compress t).n with + | Tm_arrow {bs=ibs} -> ibs + | _ -> [] + in + //open the ibs binders + let ibs = SS.open_binders ibs in + //term for unapplied inductive type, making a Tm_uinst, otherwise there are unresolved universe variables, may be that's fine ? + let ind = mk_Tm_uinst (S.fvar lid None) (List.map (fun u -> U_name u) us) in + //apply the bs parameters, bv_to_name ok ? also note that we are copying the qualifiers from the binder, so that implicits remain implicits + let ind = mk_Tm_app ind (List.map U.arg_of_non_null_binder bs) Range.dummyRange in + //apply the ibs parameters, bv_to_name ok ? also note that we are copying the qualifiers from the binder, so that implicits remain implicits + let ind = mk_Tm_app ind (List.map U.arg_of_non_null_binder ibs) Range.dummyRange in + //haseq of ind applied to all bs and ibs + let haseq_ind = mk_Tm_app U.t_haseq [S.as_arg ind] Range.dummyRange in + + + //filter out data constructors for this type constructor + let t_datas = List.filter (fun s -> + match s.sigel with + | Sig_datacon {ty_lid=t_lid} -> t_lid = lid + | _ -> failwith "Impossible" + ) all_datas_in_the_bundle in + + //fold over t_datas + let data_cond = List.fold_left (unoptimized_haseq_data usubst bs haseq_ind mutuals) U.t_true t_datas in + + //make the implication + let fml = U.mk_imp data_cond haseq_ind in + + //attach pattern -- is this the right place ? + let fml = { fml with n = Tm_meta {tm=fml; + meta=Meta_pattern(binders_to_names ibs, [[S.as_arg haseq_ind]])} } in + + //fold right with ibs, close and add a forall b + //we are setting the qualifier of the binder to None explicitly, we don't want to make forall binder implicit etc. ? + let fml = List.fold_right (fun (b:binder) (t:term) -> mk_Tm_app tforall [ S.as_arg (U.abs [S.mk_binder b.binder_bv] (SS.close [b] t) None) ] Range.dummyRange) ibs fml in + //fold right with bs, close and add a forall b + //we are setting the qualifier of the binder to None explicitly, we don't want to make forall binder implicit etc. ? + let fml = List.fold_right (fun (b:binder) (t:term) -> mk_Tm_app tforall [ S.as_arg (U.abs [S.mk_binder b.binder_bv] (SS.close [b] t) None) ] Range.dummyRange) bs fml in + + //new accumulator is old accumulator /\ fml + U.mk_conj acc fml + +let unoptimized_haseq_scheme (sig_bndle:sigelt) (tcs:list sigelt) (datas:list sigelt) (env0:env_t) :list sigelt = + //TODO: perhaps make it a map ? + let mutuals = List.map (fun ty -> + match ty.sigel with + | Sig_inductive_typ {lid} -> lid + | _ -> failwith "Impossible!") tcs + in + + + let lid, us = + let ty = List.hd tcs in + match ty.sigel with + | Sig_inductive_typ {lid; us} -> lid, us + | _ -> failwith "Impossible!" + in + let usubst, us = SS.univ_var_opening us in + + let fml = List.fold_left (unoptimized_haseq_ty datas mutuals usubst us) U.t_true tcs in + + let se = //FIXME: docs? + { sigel = Sig_assume {lid=get_haseq_axiom_lid lid; us; phi=fml}; + sigquals = [InternalAssumption]; + sigrng = Range.dummyRange; + sigmeta = default_sigmeta; + sigattrs = []; + sigopts = None; + sigopens_and_abbrevs = []; + } + + in + [se] + + +//returns: sig bundle, list of type constructors, list of data constructors +let check_inductive_well_typedness (env:env_t) (ses:list sigelt) (quals:list qualifier) (lids:list lident) :(sigelt & list sigelt & list sigelt) = + (* Consider this illustrative example: + + type T (a:Type) : (b:Type) -> Type = + | C1 : x:a -> y:Type -> T a y + | C2 : x:a -> z:Type -> w:Type -> T a z + + (1). We elaborate the type of T to + T : a:Type(ua) -> b:Type(ub) -> Type(u) + + (2). In a context + G = a:Type(ua), T: (a:Type(ua) -> b:Type(ub) -> Type(u)) + we elaborate the type of + + C1 to x:a -> y:Type(uy) -> T a y + C2 to x:a -> z:Type(uz) -> w:Type(uw) -> T a z + + Let the elaborated type of constructor i be of the form + xs:ts_i -> ti + + For each constructor i, we check + + - G, [xs:ts_i]_j |- ts_i_j : Type(u_i_j) + - u_i_j <= u + - G, [xs:ts_i] |- ti : Type _ + - ti is an instance of T a + + + (3). We jointly generalize the term + + (a:Type(ua) -> b:Type(ub) -> Type u) + -> (xs:ts_1 -> t1) + -> (xs:ts_2 -> t2) + -> unit + + computing + + (uvs, (a:Type(ua') -> b:Type(ub') -> Type u') + -> (xs:ts_1' -> t1') + -> (xs:ts_2' -> t2') + -> unit) + + The inductive is generalized to + + T (a:Type(ua')) : b:Type(ub') -> Type u' + + + (4). We re-typecheck and elaborate the type of each constructor to + capture the proper instantiations of T + + i.e., we check + + G, T : a:Type(ua') -> b:Type(ub') -> Type u', uvs |- + xs:ts_i' -> t_i' + ~> xs:ts_i'' -> t_i'' + + + What we get, in effect, is + + type T (a:Type(ua)) : Type(ub) -> Type (max ua (ub + 1) (uw + 1)) = + | C1 : (ua, ub, uw) => a:Type(ua) -> y:Type(ub) -> T a y + | C2 : (ua, ub, uw) => a:Type(ua) -> z:Type(ub) -> w:Type(uw) -> T a z + *) + let tys, datas = ses |> List.partition (function { sigel = Sig_inductive_typ _ } -> true | _ -> false) in + if datas |> BU.for_some (function { sigel = Sig_datacon _ } -> false | _ -> true) + then raise_error env Errors.Fatal_NonInductiveInMutuallyDefinedType "Mutually defined type contains a non-inductive element"; + + //AR: adding this code for the second phase + // univs need not be empty + // we record whether the universes were already annotated + // and later use it to decide if we should generalize + let univs = + if List.length tys = 0 then [] + else + match (List.hd tys).sigel with + | Sig_inductive_typ {us=uvs} -> uvs + | _ -> failwith "Impossible, can't happen!" + in + + let env0 = env in + + (* Check each tycon *) + let env, tcs, g = List.fold_right (fun tc (env, all_tcs, g) -> + let env, tc, tc_u, guard = tc_tycon env tc in + let g' = Rel.universe_inequality S.U_zero tc_u in + if Debug.low () then BU.print1 "Checked inductive: %s\n" (show tc); + env, (tc, tc_u)::all_tcs, Env.conj_guard g (Env.conj_guard guard g') + ) tys (env, [], Env.trivial_guard) + in + (* Try to solve some implicits. See issue #3130. *) + let g = Rel.resolve_implicits env g in + + (* Check each datacon *) + let datas, g = List.fold_right (fun se (datas, g) -> + let data, g' = tc_data env tcs se in + data::datas, Env.conj_guard g g' + ) datas ([], g) + in + + (* Generalize their universes if not already annotated *) + let tcs, datas = + let tc_universe_vars = List.map snd tcs in + let g = {g with univ_ineqs = Class.Listlike.from_list (tc_universe_vars), snd (g.univ_ineqs)} in + + if !dbg_GenUniverses + then BU.print1 "@@@@@@Guard before (possible) generalization: %s\n" (Rel.guard_to_string env g); + + Rel.force_trivial_guard env0 g; + if List.length univs = 0 then generalize_and_inst_within env0 tcs datas + else (List.map fst tcs), datas + in + + (* In any of the tycons had their typed declared using `val`, + check that the declared and inferred types are compatible *) + + (* Also copy the binder attributes from val type parameters + to tycon type parameters *) + + let tcs = tcs |> List.map (fun se -> + match se.sigel with + | Sig_inductive_typ {lid=l;us=univs;params=binders;num_uniform_params=num_uniform;t=typ; + mutuals=ts;ds} -> + let fail expected inferred = + raise_error se Errors.Fatal_UnexpectedInductivetype + (BU.format2 "Expected an inductive with type %s; got %s" + (Print.tscheme_to_string expected) + (Print.tscheme_to_string inferred)) + in + // + //binders are the binders in Sig_inductive + //expected is the val type + //this function then copies attributes from val binders to Sig_inductive binders + // and returns new binders + //helps later to check strict positivity + // + let copy_binder_attrs_from_val binders expected = + // + // AR: A note on opening: + // get_n_binders opens some of the expected binders + // we end up throwing them, we are only interested in attrs + // binders remain as they are, we only change attributes there + // + let expected_attrs = + N.get_n_binders env (List.length binders) expected + |> fst + |> List.map (fun {binder_attrs=attrs; binder_positivity=pqual} -> attrs, pqual) in + if List.length expected_attrs <> List.length binders + then raise_error se + Errors.Fatal_UnexpectedInductivetype + (BU.format2 "Could not get %s type parameters from val type %s" + (binders |> List.length |> string_of_int) + (show expected)) + else List.map2 (fun (ex_attrs, pqual) b -> + if not (Common.check_positivity_qual true pqual b.binder_positivity) + then raise_error b Errors.Fatal_UnexpectedInductivetype "Incompatible positivity annotation"; + {b with binder_attrs = b.binder_attrs@ex_attrs; binder_positivity=pqual} + ) expected_attrs binders + in + let inferred_typ_with_binders binders = + let body = + match binders with + | [] -> typ + | _ -> S.mk (Tm_arrow {bs=binders; comp=S.mk_Total typ}) se.sigrng + in + (univs, body) + in + begin match Env.try_lookup_val_decl env0 l with + | None -> se + | Some (expected_typ, _) -> + if List.length univs = List.length (fst expected_typ) + then let _, expected = Subst.open_univ_vars univs (snd expected_typ) in + let binders = copy_binder_attrs_from_val binders expected in + let inferred_typ = inferred_typ_with_binders binders in + let _, inferred = Subst.open_univ_vars univs (snd inferred_typ) in + + // + // AR: Shouldn't we push opened universes to env0? + // + if Rel.teq_nosmt_force env0 inferred expected + then begin + {se with sigel=Sig_inductive_typ {lid=l; + us=univs; + params=binders; + num_uniform_params=num_uniform; + t=typ; + mutuals=ts; + ds; + injective_type_params=false}} + end + else fail expected_typ inferred_typ + else fail expected_typ (inferred_typ_with_binders binders) + end + | _ -> se) in + + let tcs = tcs |> List.map (check_sig_inductive_injectivity_on_params env0) in + let is_injective l = + match + List.tryPick + (fun se -> + let Sig_inductive_typ {lid=lid; injective_type_params} = se.sigel in + if lid_equals l lid then Some injective_type_params else None) + tcs + with + | None -> false + | Some i -> i + in + let datas = + datas |> + List.map + (fun se -> + let Sig_datacon dd = se.sigel in + { se with sigel=Sig_datacon { dd with injective_type_params=is_injective dd.ty_lid }}) + in + let sig_bndle = { sigel = Sig_bundle {ses=tcs@datas; lids}; + sigquals = quals; + sigrng = Env.get_range env0; + sigmeta = default_sigmeta; + sigattrs = List.collect (fun s -> s.sigattrs) ses; + sigopts = None; + sigopens_and_abbrevs=[] } in + + sig_bndle, tcs, datas + + +(******************************************************************************) +(* *) +(* Elaboration of the projectors *) +(* *) +(******************************************************************************) + +//for these types we don't generate projectors, discriminators, and hasEq axioms +let early_prims_inductives = [ "empty"; "trivial"; "equals"; "pair"; "sum" ] + +let mk_discriminator_and_indexed_projectors iquals (* Qualifiers of the envelopping bundle *) + (attrs:list attribute) (* Attributes of the envelopping bundle *) + (fvq:fv_qual) (* *) + (refine_domain:bool) (* If true, discriminates the projectee *) + env (* *) + (tc:lident) (* Type constructor name *) + (lid:lident) (* Constructor name *) + (uvs:univ_names) (* Original universe names *) + (inductive_tps:binders) (* Type parameters of the type constructor *) + (indices:binders) (* Implicit type parameters *) + (fields:binders) (* Fields of the constructor *) + (erasable:bool) (* Generate ghost discriminators and projectors *) + : list sigelt = + let p = range_of_lid lid in + let pos q = Syntax.withinfo q p in + let projectee ptyp = S.gen_bv "projectee" (Some p) ptyp in + let inst_univs = List.map (fun u -> U_name u) uvs in + let tps = inductive_tps in //List.map2 (fun (x,_) (_,imp) -> ({x,imp)) implicit_tps inductive_tps in + let arg_typ = + let inst_tc = S.mk (Tm_uinst (S.fv_to_tm (S.lid_as_fv tc None), inst_univs)) p in + let args = tps@indices |> List.map U.arg_of_non_null_binder in + S.mk_Tm_app inst_tc args p + in + let unrefined_arg_binder = S.mk_binder (projectee arg_typ) in + let arg_binder = + if not refine_domain + then unrefined_arg_binder //records have only one constructor; no point refining the domain + else let disc_name = U.mk_discriminator lid in + let x = S.new_bv (Some p) arg_typ in + let sort = + let disc_fvar = S.fvar_with_dd (Ident.set_lid_range disc_name p) None in + U.refine x (U.b2t (S.mk_Tm_app (S.mk_Tm_uinst disc_fvar inst_univs) [as_arg <| S.bv_to_name x] p)) + in + S.mk_binder ({projectee arg_typ with sort = sort}) + in + + + let ntps = List.length tps in + let all_params = List.map (fun b -> {b with binder_qual=Some S.imp_tag}) tps @ fields in + + let imp_binders = tps @ indices |> List.map (fun b -> {b with binder_qual=mk_implicit b.binder_qual}) in + + let early_prims_inductive = + lid_equals C.prims_lid (Env.current_module env) && + List.existsb (fun s -> s = (string_of_id (ident_of_lid tc))) early_prims_inductives + in + + let discriminator_ses = + if fvq <> Data_ctor + then [] // We do not generate discriminators for record types + else + let discriminator_name = U.mk_discriminator lid in + let no_decl = false in + let only_decl = + early_prims_inductive || + U.has_attribute attrs C.no_auto_projectors_attr + in + let quals = + (* KM : What about Logic ? should it still be there even with an implementation *) + S.Discriminator lid :: + (if only_decl then [S.Logic; S.Assumption] else []) @ + //(if only_decl && (not <| env.is_iface || env.admit) then [S.Assumption] else []) @ + List.filter (function S.Inline_for_extraction | S.NoExtract | S.Private -> true | _ -> false ) iquals + in + + (* Type of the discriminator *) + let binders = imp_binders@[unrefined_arg_binder] in + let t = + let bool_typ = + if erasable + then S.mk_GTotal U.t_bool + else S.mk_Total U.t_bool + in + SS.close_univ_vars uvs <| U.arrow binders bool_typ + in + let decl = { sigel = Sig_declare_typ {lid=discriminator_name; us=uvs; t}; + sigquals = quals; + sigrng = range_of_lid discriminator_name; + sigmeta = default_sigmeta; + sigattrs = attrs; + sigopts = None; + sigopens_and_abbrevs=[] } in + if !dbg_LogTypes + then BU.print1 "Declaration of a discriminator %s\n" (show decl); + + if only_decl + then [decl] + else + (* Term of the discriminator *) + let body = + if not refine_domain + then U.exp_true_bool // If we have at most one constructor + else + let arg_pats = all_params |> List.mapi (fun j ({binder_bv=x;binder_qual=imp}) -> + let b = S.is_bqual_implicit imp in + if b && j < ntps + then pos (Pat_dot_term None), b + else pos (Pat_var (S.gen_bv (string_of_id x.ppname) None tun)), b) + in + let pat_true = pos (S.Pat_cons (S.lid_as_fv lid (Some fvq), None, arg_pats)), None, U.exp_true_bool in + let pat_false = pos (Pat_var (S.new_bv None tun)), None, U.exp_false_bool in + let arg_exp = S.bv_to_name unrefined_arg_binder.binder_bv in + mk (Tm_match {scrutinee=arg_exp; + ret_opt=None; + brs=[U.branch pat_true ; U.branch pat_false]; + rc_opt=None}) p + in + let imp = U.abs binders body None in + let lbtyp = if no_decl then t else tun in + let lb = U.mk_letbinding + (Inr (S.lid_and_dd_as_fv discriminator_name None)) + uvs + lbtyp + C.effect_Tot_lid + (SS.close_univ_vars uvs imp) + [] + Range.dummyRange + in + let impl = { sigel = Sig_let {lbs=(false, [lb]); lids=[lb.lbname |> right |> (fun fv -> fv.fv_name.v)]}; + sigquals = quals; + sigrng = p; + sigmeta = default_sigmeta; + sigattrs = attrs; + sigopts = None; + sigopens_and_abbrevs=[] } in + if !dbg_LogTypes + then BU.print1 "Implementation of a discriminator %s\n" (show impl); + (* TODO : Are there some cases where we don't want one of these ? *) + (* If not the declaration is useless, isn't it ?*) + [decl ; impl] + in + + + let arg_exp = S.bv_to_name arg_binder.binder_bv in + let binders = imp_binders@[arg_binder] in + let arg = U.arg_of_non_null_binder arg_binder in + + let subst = fields |> List.mapi (fun i ({binder_bv=a}) -> + let field_name = U.mk_field_projector_name lid a i in + let field_proj_tm = mk_Tm_uinst (S.fv_to_tm (S.lid_as_fv field_name None)) inst_univs in + let proj = mk_Tm_app field_proj_tm [arg] p in + NT(a, proj)) + in + + let projectors_ses = + if U.has_attribute attrs C.no_auto_projectors_decls_attr + || U.has_attribute attrs C.meta_projectors_attr + then [] + else + fields |> List.mapi (fun i ({binder_bv=x}) -> + let p = S.range_of_bv x in + let field_name = U.mk_field_projector_name lid x i in + let result_comp = + let t = Subst.subst subst x.sort in + if erasable + then S.mk_GTotal t + else S.mk_Total t in + let t = SS.close_univ_vars uvs <| U.arrow binders result_comp in + let only_decl = + early_prims_inductive || + U.has_attribute attrs C.no_auto_projectors_attr + in + (* KM : Why would we want to prevent a declaration only in this particular case ? *) + (* TODO : If we don't want the declaration then we need to propagate the right types in the patterns *) + let no_decl = false (* Syntax.is_type x.sort *) in + let quals q = + if only_decl + then S.Assumption::q + else q + in + let quals = + let iquals = iquals |> List.filter (function + | S.Inline_for_extraction + | S.NoExtract + | S.Private -> true + | _ -> false) + in + quals (S.Projector(lid, x.ppname)::iquals) in + let attrs = (if only_decl then [] else [ U.attr_substitute ])@attrs in + let decl = { sigel = Sig_declare_typ {lid=field_name; us=uvs; t}; + sigquals = quals; + sigrng = range_of_lid field_name; + sigmeta = default_sigmeta; + sigattrs = attrs; + sigopts = None; + sigopens_and_abbrevs=[] } in + if !dbg_LogTypes + then BU.print1 "Declaration of a projector %s\n" (show decl); + if only_decl + then [decl] //only the signature + else + let projection = S.gen_bv (string_of_id x.ppname) None tun in + let arg_pats = all_params |> List.mapi (fun j ({binder_bv=x;binder_qual=imp}) -> + let b = S.is_bqual_implicit imp in + if i+ntps=j //this is the one to project + then pos (Pat_var projection), b + else if b && j < ntps + then pos (Pat_dot_term None), b + else pos (Pat_var (S.gen_bv (string_of_id x.ppname) None tun)), b) + in + let pat = pos (S.Pat_cons (S.lid_as_fv lid (Some fvq), None, arg_pats)), None, S.bv_to_name projection in + let body = + let return_bv = S.gen_bv "proj_ret" (Some p) S.tun in + let result_typ = result_comp + |> U.comp_result + |> SS.subst [NT (arg_binder.binder_bv, S.bv_to_name return_bv)] + |> SS.close [S.mk_binder return_bv] in + let return_binder = List.hd (SS.close_binders [S.mk_binder return_bv]) in + let returns_annotation = + let use_eq = true in + Some (return_binder, (Inl result_typ, None, use_eq)) in + mk (Tm_match {scrutinee=arg_exp; + ret_opt=returns_annotation; + brs=[U.branch pat]; + rc_opt=None}) p in + let imp = U.abs binders body None in + let dd = Delta_equational_at_level 1 in + let lbtyp = if no_decl then t else tun in + let lb = { + lbname=Inr (S.lid_and_dd_as_fv field_name None); + lbunivs=uvs; + lbtyp=lbtyp; + lbeff=C.effect_Tot_lid; + lbdef=SS.close_univ_vars uvs imp; + lbattrs=[]; + lbpos=Range.dummyRange; + } in + let impl = { sigel = Sig_let {lbs=(false, [lb]); lids=[lb.lbname |> right |> (fun fv -> fv.fv_name.v)]}; + sigquals = quals; + sigrng = p; + sigmeta = default_sigmeta; + sigattrs = attrs; + sigopts = None; + sigopens_and_abbrevs=[] } in + if !dbg_LogTypes + then BU.print1 "Implementation of a projector %s\n" (show impl); + if no_decl then [impl] else [decl;impl]) |> List.flatten + in + (* We remove the plugin attribute from these generated definitions. + We do not want to pay an embedding/unembedding to use them, and we don't + want warning about unfolding something that is a plugin *) + let no_plugin (se:sigelt) : sigelt = + let not_plugin_attr (t:term) : bool = + let h = U.head_of t in + not (U.is_fvar C.plugin_attr h) + in + { se with sigattrs = List.filter not_plugin_attr se.sigattrs } + in + List.map no_plugin (discriminator_ses @ projectors_ses) + +let mk_data_operations iquals attrs env tcs se = + match se.sigel with + | Sig_datacon {lid=constr_lid; us=uvs; t; ty_lid=typ_lid; num_ty_params=n_typars} -> + + let univ_opening, uvs = SS.univ_var_opening uvs in + let t = SS.subst univ_opening t in + let formals, _ = U.arrow_formals t in + + let inductive_tps, typ0, should_refine = + let tps_opt = BU.find_map tcs (fun se -> + if lid_equals typ_lid (must (U.lid_of_sigelt se)) + then match se.sigel with + | Sig_inductive_typ {us=uvs'; params=tps; t=typ0; ds=constrs} -> + assert (List.length uvs = List.length uvs') ; + Some (tps, typ0, List.length constrs > 1) + | _ -> failwith "Impossible" + else None) + in + match tps_opt with + | Some x -> x + | None -> + if lid_equals typ_lid C.exn_lid + then [], U.ktype0, true + else raise_error se Errors.Fatal_UnexpectedDataConstructor "Unexpected data constructor" + in + + let inductive_tps = SS.subst_binders univ_opening inductive_tps in + let typ0 = SS.subst //shift the universe substitution by number of type parameters + (SS.shift_subst (List.length inductive_tps) univ_opening) + typ0 in + let indices, _ = U.arrow_formals typ0 in + + let refine_domain = + if se.sigquals |> BU.for_some (function RecordConstructor _ -> true | _ -> false) + then false + else should_refine + in + + let fv_qual = + let filter_records = function + | RecordConstructor (_, fns) -> Some (Record_ctor(typ_lid, fns)) + | _ -> None + in match BU.find_map se.sigquals filter_records with + | None -> Data_ctor + | Some q -> q + in + + let fields = + let imp_tps, fields = BU.first_N n_typars formals in + let rename = List.map2 (fun ({binder_bv=x}) ({binder_bv=x'}) -> S.NT(x, S.bv_to_name x')) imp_tps inductive_tps in + SS.subst_binders rename fields + in + let erasable = U.has_attribute se.sigattrs FStarC.Parser.Const.erasable_attr in + mk_discriminator_and_indexed_projectors + iquals attrs fv_qual refine_domain + env typ_lid constr_lid uvs + inductive_tps indices fields erasable + + | _ -> [] diff --git a/src/typechecker/FStarC.TypeChecker.TcInductive.fsti b/src/typechecker/FStarC.TypeChecker.TcInductive.fsti new file mode 100644 index 00000000000..53b6ca291de --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.TcInductive.fsti @@ -0,0 +1,42 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.TypeChecker.TcInductive +open FStarC.Compiler.Effect +open FStar open FStarC +open FStarC.Compiler +open FStarC.TypeChecker +open FStarC.TypeChecker.Env +open FStarC.Compiler.Util +open FStarC.Ident +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.Syntax.Subst +open FStarC.Syntax.Util +open FStarC.Const +open FStarC.TypeChecker.Rel +open FStarC.TypeChecker.Common + +val check_inductive_well_typedness: env_t -> list sigelt -> list qualifier -> list lident -> (sigelt & list sigelt & list sigelt) + +val early_prims_inductives :list string + +val is_haseq_lid: lid -> bool //see if the given lid is that of an haseq axiom +val get_haseq_axiom_lid: lid -> lid //for the given inductive tycon lid, get the haseq axiom lid +val optimized_haseq_scheme: sigelt -> list sigelt -> list sigelt -> env_t -> list sigelt +val unoptimized_haseq_scheme: sigelt -> list sigelt -> list sigelt -> env_t -> list sigelt + +val mk_data_operations: list qualifier -> list attribute -> env -> list sigelt -> sigelt -> list sigelt //elaborate discriminator and projectors diff --git a/src/typechecker/FStarC.TypeChecker.TcTerm.fst b/src/typechecker/FStarC.TypeChecker.TcTerm.fst new file mode 100644 index 00000000000..19a73ddfd62 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.TcTerm.fst @@ -0,0 +1,4940 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.TypeChecker.TcTerm +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.Errors +open FStarC.Defensive +open FStarC.TypeChecker +open FStarC.TypeChecker.Common +open FStarC.TypeChecker.Env +open FStarC.Compiler.Util +open FStarC.Ident +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.Syntax.Subst +open FStarC.Syntax.Util +open FStarC.Const +open FStarC.Dyn +open FStarC.TypeChecker.Rel + +open FStarC.Class.Show +open FStarC.Class.PP +open FStarC.Class.Tagged +open FStarC.Class.Setlike +open FStarC.Class.Monoid + +module S = FStarC.Syntax.Syntax +module SS = FStarC.Syntax.Subst +module TcComm = FStarC.TypeChecker.Common +module N = FStarC.TypeChecker.Normalize +module TcUtil = FStarC.TypeChecker.Util +module Gen = FStarC.TypeChecker.Generalize +module BU = FStarC.Compiler.Util +module U = FStarC.Syntax.Util +module PP = FStarC.Syntax.Print +module UF = FStarC.Syntax.Unionfind +module Const = FStarC.Parser.Const +module TEQ = FStarC.TypeChecker.TermEqAndSimplify + +let dbg_Exports = Debug.get_toggle "Exports" +let dbg_LayeredEffects = Debug.get_toggle "LayeredEffects" +let dbg_NYC = Debug.get_toggle "NYC" +let dbg_Patterns = Debug.get_toggle "Patterns" +let dbg_Range = Debug.get_toggle "Range" +let dbg_RelCheck = Debug.get_toggle "RelCheck" +let dbg_RFD = Debug.get_toggle "RFD" +let dbg_Tac = Debug.get_toggle "Tac" +let dbg_UniverseOf = Debug.get_toggle "UniverseOf" + +(* Some local utilities *) +let instantiate_both env = {env with Env.instantiate_imp=true} +let no_inst env = {env with Env.instantiate_imp=false} + +let is_eq = function + | Some Equality -> true + | _ -> false +let steps env = [Env.Beta; Env.Eager_unfolding; Env.NoFullNorm; Env.Exclude Env.Zeta] +let norm env t = N.normalize (steps env) env t +let norm_c env c = N.normalize_comp (steps env) env c + +(* Checks that the variables in `fvs` do not appear in the free vars of `t`. +The environment `env` must not contain fvs in its gamma for this to work properly. *) +let check_no_escape (head_opt : option term) + (env : Env.env) + (fvs:list bv) + (kt : term) +: term & guard_t += + Errors.with_ctx "While checking for escaped variables" (fun () -> + let fail (x:bv) = + let open FStarC.Pprint in + let msg = + match head_opt with + | None -> [ + text "Bound variable" ^/^ squotes (pp x) + ^/^ text "would escape in the type of this letbinding"; + text "Add a type annotation that does not mention it"; + ] + | Some head -> [ + text "Bound variable" ^/^ squotes (pp x) + ^/^ text "escapes because of impure applications in the type of" + ^/^ squotes (N.term_to_doc env head); + text "Add explicit let-bindings to avoid this"; + ] + in + raise_error env Errors.Fatal_EscapedBoundVar msg + in + match fvs with + | [] -> kt, mzero + | _ -> + let rec aux try_norm t = + let t = if try_norm then norm env t else t in + let fvs' = Free.names t in + match List.tryFind (fun x -> mem x fvs') fvs with + | None -> t, mzero + | Some x -> + (* some variable x seems to escape, try normalizing if we haven't *) + if not try_norm + then aux true (norm env t) + else + (* if it still appears, try using the unifier to equate 't' to a uvar + created in the "short" env, which cannot mention any of the fvs. If any exception + is raised, we just report that 'x' escapes. Since we're calling try_teq with + SMT disabled it should not log an error. *) + try + let env_extended = Env.push_bvs env fvs in + let s, _, g0 = TcUtil.new_implicit_var "no escape" (Env.get_range env) env (fst <| U.type_u()) false in + match Rel.try_teq false env_extended t s with + | Some g -> + let g = Rel.solve_deferred_constraints env_extended (g ++ g0) in + s, g + | _ -> fail x + with + | _ -> fail x + in + aux false kt + ) + +(* + check_expected_aqual_for_binder: + + This is used to check an application. + + Given val f (#[@@@ att] x:t) : t' + + the user is expected to write f #a to apply f, matching the + implicit qualifier at the binding site. + + However, they do not (and cannot, there's no syntax for it) provide + the attributes of the binding site at the application site. + + So, this function checks that the implicit flags match and takes + the attributes from the binding site, i.e., expected_aq. +*) +let check_expected_aqual_for_binder (aq:aqual) (b:binder) (pos:Range.range) : aqual = + match + let expected_aq = U.aqual_of_binder b in + match aq, expected_aq with + | None, None -> Inr aq + | None, Some eaq -> + if eaq.aqual_implicit //programmer should have written # + then Inl "expected implicit annotation on the argument" + else Inr expected_aq //keep the attributes + | Some aq, None -> + Inl "expected an explicit argument (without annotation)" + | Some aq, Some eaq -> + if aq.aqual_implicit <> eaq.aqual_implicit + then Inl "mismatch" + else Inr expected_aq //keep the attributes + with + | Inl err -> + let open FStarC.Pprint in + let msg = [ + Errors.Msg.text ("Inconsistent argument qualifiers: " ^ err ^ "."); + ] in + raise_error pos Errors.Fatal_InconsistentImplicitQualifier msg + | Inr r -> r + +let check_erasable_binder_attributes env attrs (binder_ty:typ) = + attrs |> + List.iter + (fun attr -> + if U.is_fvar Const.erasable_attr attr + && not (N.non_info_norm env binder_ty) + then raise_error attr Errors.Fatal_QulifierListNotPermitted + ("Incompatible attributes: an erasable attribute on a binder must bind a name at an non-informative type")) + +let push_binding env b = + Env.push_bv env b.binder_bv + +let maybe_extend_subst s b v : subst_t = + if is_null_binder b then s + else NT(b.binder_bv, v)::s + +let set_lcomp_result lc t = + TcComm.apply_lcomp + (fun c -> U.set_result_typ c t) (fun g -> g) ({ lc with res_typ = t }) + +let memo_tk (e:term) (t:typ) = e + +let maybe_warn_on_use env fv : unit = + match Env.lookup_attrs_of_lid env fv.fv_name.v with + | None -> () + | Some attrs -> + attrs |> + List.iter + (fun a -> + let head, args = U.head_and_args a in + let msg_arg m = + match args with + | [{n=Tm_constant (Const_string (s, _))}, _] -> + m @ [Errors.text s] + | _ -> + m + in + match head.n with + | Tm_fvar attr_fv + when lid_equals attr_fv.fv_name.v Const.warn_on_use_attr -> + let m = + Errors.text <| + BU.format1 "Every use of %s triggers a warning" + (Ident.string_of_lid fv.fv_name.v) + in + log_issue fv.fv_name.v Warning_WarnOnUse (msg_arg [m]) + + | Tm_fvar attr_fv + when lid_equals attr_fv.fv_name.v Const.deprecated_attr -> + let m = + Errors.text <| + BU.format1 + "%s is deprecated" + (Ident.string_of_lid fv.fv_name.v) + in + log_issue fv.fv_name.v Warning_DeprecatedDefinition (msg_arg [m]) + + | _ -> ()) + +//Interface to FStarC.TypeChecker.Rel: + +(************************************************************************************************************) +(* value_check_expected_type env e tlc g *) +(* e is computed to have type or computation type, tlc *) +(* subject to the guard g *) +(* This function compares tlc to the expected type from the context, augmenting the guard if needed *) +(************************************************************************************************************) +let value_check_expected_typ env (e:term) (tlc:either term lcomp) (guard:guard_t) + : term & lcomp & guard_t = + def_check_scoped e.pos "value_check_expected_typ" env guard; + let lc = match tlc with + | Inl t -> TcComm.lcomp_of_comp <| mk_Total t + | Inr lc -> lc in + let t = lc.res_typ in + let e, lc, g = + match Env.expected_typ env with + | None -> memo_tk e t, lc, guard + | Some (t', use_eq) -> + let e, lc, g = TcUtil.check_has_type_maybe_coerce env e lc t' use_eq in + if Debug.medium () + then BU.print4 "value_check_expected_typ: type is %s<:%s \tguard is %s, %s\n" + (TcComm.lcomp_to_string lc) (show t') + (Rel.guard_to_string env g) (Rel.guard_to_string env guard); + let t = lc.res_typ in + let g = g ++ guard in + (* adding a guard for confirming that the computed type t is a subtype of the expected type t' *) + let msg = if Env.is_trivial_guard_formula g then None else Some <| Err.subtyping_failed env t t' in + let lc, g = TcUtil.strengthen_precondition msg env e lc g in + memo_tk e t', set_lcomp_result lc t', g + in + e, lc, g + +(************************************************************************************************************) +(* comp_check_expected_type env e lc g *) +(* similar to value_check_expected_typ, except this time e is a non-value *) +(************************************************************************************************************) +let comp_check_expected_typ env e lc : term & lcomp & guard_t = + match Env.expected_typ env with + | None -> e, lc, mzero + | Some (t, use_eq) -> + let e, lc, g_c = TcUtil.maybe_coerce_lc env e lc t in + let e, lc, g = TcUtil.weaken_result_typ env e lc t use_eq in + e, lc, g ++ g_c + +(************************************************************************************************************) +(* check_expected_effect: triggers a sub-effecting, WP implication, etc. if needed *) +(************************************************************************************************************) +let check_expected_effect env (use_eq:bool) (copt:option comp) (ec : term & comp) + : term & comp & guard_t = + let e, c = ec in + let tot_or_gtot c = //expects U.is_pure_or_ghost_comp c + if U.is_pure_comp c + then mk_Total (U.comp_result c) + else if U.is_pure_or_ghost_comp c + then mk_GTotal (U.comp_result c) + else failwith "Impossible: Expected pure_or_ghost comp" + in + + let expected_c_opt, c, gopt = + let ct = U.comp_result c in + match copt with + | Some _ -> copt, c, None //setting gopt to None since expected comp is already set, so we will do sub_comp below + | None -> + if (Options.ml_ish() + && Ident.lid_equals (Const.effect_ALL_lid()) (U.comp_effect_name c)) + || (Options.ml_ish () + && Options.lax () + && not (U.is_pure_or_ghost_comp c)) + then Some (U.ml_comp ct e.pos), c, None + else if U.is_tot_or_gtot_comp c //these are already the defaults for their particular effects + then None, tot_or_gtot c, None //but, force c to be exactly ((G)Tot t), since otherwise it may actually contain a return + else if U.is_pure_or_ghost_comp c + then Some (tot_or_gtot c), c, None + else let norm_eff_name = U.comp_effect_name c |> Env.norm_eff_name env in + if norm_eff_name |> Env.is_layered_effect env + then begin + // + //If the layered effect has a default effect annotation, + // use it + //We have already typechecked that the default effect + // only takes as argument the result type + // + let def_eff_opt = Env.get_default_effect env norm_eff_name in + match def_eff_opt with + | None -> + raise_error e Errors.Error_LayeredMissingAnnot //hard error if layered effects are used without annotations + (BU.format2 "Missing annotation for a layered effect (%s) computation at %s" + (c |> U.comp_effect_name |> show) + (show e.pos)) + | Some def_eff -> + // + //AR: TODO: it may be good hygiene to check that def_eff exists + // + let comp_univs, result_ty = + match c.n with + | Comp ({comp_univs=comp_univs; result_typ=result_ty}) -> + comp_univs, result_ty + | _ -> failwith "Impossible!" in + let expected_c = { + comp_univs = comp_univs; + effect_name = def_eff; + result_typ = result_ty; + effect_args = []; + flags = []} in + //let expected_c, _, _ = tc_comp env expected_c in + Some (S.mk_Comp expected_c), + c, + None + end + // Not a layered effect + else if Options.trivial_pre_for_unannotated_effectful_fns () + then None, c, (let _, _, g = TcUtil.check_trivial_precondition_wp env c in + Some g) + else None, c, None + in + def_check_scoped c.pos "check_expected_effect.c.before_norm" env c; + let c = Errors.with_ctx "While normalizing actual computation type in check_expected_effect" + (fun () -> norm_c env c) in + def_check_scoped c.pos "check_expected_effect.c.after_norm" env c; + match expected_c_opt with + | None -> + e, c, (match gopt with | None -> mzero | Some g -> g) + | Some expected_c -> //expected effects should already be normalized + let _ = match gopt with + | None -> () + | Some _ -> failwith "Impossible! check_expected_effect, gopt should have been None" + in + + let c = TcUtil.maybe_assume_result_eq_pure_term env e (TcComm.lcomp_of_comp c) in + let c, g_c = TcComm.lcomp_comp c in + def_check_scoped c.pos "check_expected_effect.c.after_assume" env c; + if Debug.medium () then + BU.print4 "In check_expected_effect, asking rel to solve the problem on e=(%s) and c=(%s), expected_c=(%s), and use_eq=%s\n" + (show e) + (show c) + (show expected_c) + (show use_eq); + let e, _, g = TcUtil.check_comp env use_eq e c expected_c in + let g = TcUtil.label_guard (Env.get_range env) (Errors.mkmsg "Could not prove post-condition") g in + if Debug.medium () + then BU.print2 "(%s) DONE check_expected_effect;\n\tguard is: %s\n" + (Range.string_of_range e.pos) + (guard_to_string env g); + let e = TcUtil.maybe_lift env e (U.comp_effect_name c) (U.comp_effect_name expected_c) (U.comp_result c) in + e, expected_c, g ++ g_c + +let no_logical_guard env (te, kt, f) = + match guard_form f with + | Trivial -> te, kt, f + | NonTrivial f -> Err.unexpected_non_trivial_precondition_on_term env f + +let print_expected_ty_str env = + match Env.expected_typ env with + | None -> "Expected type is None" + | Some (t, use_eq) -> + BU.format2 + "Expected type is (%s, use_eq = %s)" + (show t) + (string_of_bool use_eq) + + +let print_expected_ty env = BU.print1 "%s\n" (print_expected_ty_str env) + +(************************************************************************************************************) +(* check the patterns in an SMT lemma to make sure all bound vars are mentiond *) +(************************************************************************************************************) + +(* andlist: whether we're inside an SMTPatOr and we should take the + * intersection of the sub-variables instead of the union. *) +let rec get_pat_vars' all (andlist : bool) (pats:term) : FlatSet.t bv = + let pats = unmeta pats in + let head, args = head_and_args pats in + match (un_uinst head).n, args with + | Tm_fvar fv, _ when fv_eq_lid fv Const.nil_lid -> + if andlist + then from_list all + else empty () + + | Tm_fvar fv, [(_, Some ({ aqual_implicit = true })); (hd, None); (tl, None)] when fv_eq_lid fv Const.cons_lid -> + (* The head is not under the scope of the SMTPatOr, consider + * SMTPatOr [ [SMTPat p1; SMTPat p2] ; ... ] + * we should take the union of fv(p1) and fv(p2) *) + let hdvs = get_pat_vars' all false hd in + let tlvs = get_pat_vars' all andlist tl in + + if andlist + then inter hdvs tlvs + else union hdvs tlvs + + | Tm_fvar fv, [(_, Some ({ aqual_implicit = true })); (pat, None)] when fv_eq_lid fv Const.smtpat_lid -> + Free.names pat + + | Tm_fvar fv, [(subpats, None)] when fv_eq_lid fv Const.smtpatOr_lid -> + get_pat_vars' all true subpats + + | _ -> empty () + +let get_pat_vars all pats = get_pat_vars' all false pats + +let check_pat_fvs (rng:Range.range) env pats bs = + let pat_vars = get_pat_vars (List.map (fun b -> b.binder_bv) bs) (N.normalize [Env.Beta] env pats) in + begin match bs |> BU.find_opt (fun ({binder_bv=b}) -> not (mem b pat_vars)) with + | None -> () + | Some ({binder_bv=x}) -> + Errors.log_issue rng Errors.Warning_SMTPatternIllFormed + (BU.format1 "Pattern misses at least one bound variable: %s" (show x)) + end + +(* + * Check that term t (an smt pattern) does not contain theory symbols + * These symbols are fvs with attribute smt_theory_symbol from Prims + * and other terms such as abs, arrows etc. + *) +let check_no_smt_theory_symbols (en:env) (t:term) :unit = + let rec pat_terms (t:term) :list term = + let t = unmeta t in + let head, args = head_and_args t in + match (un_uinst head).n, args with + | Tm_fvar fv, _ when fv_eq_lid fv Const.nil_lid -> [] + | Tm_fvar fv, [_; (hd, _); (tl, _)] when fv_eq_lid fv Const.cons_lid -> + pat_terms hd @ pat_terms tl + | Tm_fvar fv, [_; (pat, _)] when fv_eq_lid fv Const.smtpat_lid -> [pat] + | Tm_fvar fv, [(subpats, None)] when fv_eq_lid fv Const.smtpatOr_lid -> + pat_terms subpats + | _ -> [] //TODO: should this be a hard error? + in + let rec aux (t:term) :list term = + match (SS.compress t).n with + //these cases are fine + | Tm_bvar _ | Tm_name _ | Tm_constant _ | Tm_type _ | Tm_uvar _ + | Tm_lazy _ | Tm_unknown -> [] + + //these should not be allowed in patterns + | Tm_abs _ | Tm_arrow _ | Tm_refine _ + | Tm_match _ | Tm_let _ | Tm_delayed _ | Tm_quoted _ -> [t] + + //these descend more in the term + | Tm_fvar fv -> + if Env.fv_has_attr en fv Const.smt_theory_symbol_attr_lid then [t] + else [] + + | Tm_app {hd=t; args} -> + List.fold_left (fun acc (t, _) -> + acc @ aux t) (aux t) args + + | Tm_ascribed {tm=t} + | Tm_uinst (t, _) + | Tm_meta {tm=t} -> aux t + in + let tlist = t |> pat_terms |> List.collect aux in + if List.length tlist = 0 then () //did not find any offending term + else + let open FStarC.Pprint in + let open FStarC.Class.PP in + //string to be displayed in the warning + Errors.log_issue t Errors.Warning_SMTPatternIllFormed [ + prefix 2 1 + (text "Pattern uses these theory symbols or terms that should not be in an SMT pattern:") + (group <| separate_map (comma ^^ break_ 1) pp tlist) + ] + +let check_smt_pat env t bs c = + if U.is_smt_lemma t //check patterns cover the bound vars + then match c.n with + | Comp ({effect_args=[_pre; _post; (pats, _)]}) -> + check_pat_fvs t.pos env pats bs; + check_no_smt_theory_symbols env pats + | _ -> failwith "Impossible: check_smt_pat: not Comp" + +(************************************************************************************************************) +(* Building the environment for the body of a let rec; *) +(* guards the recursively bound names with a termination check *) +(************************************************************************************************************) +let guard_letrecs env actuals expected_c : list (lbname&typ&univ_names) = + match env.letrecs with + | [] -> [] + | letrecs -> + let r = Env.get_range env in + let env = {env with letrecs=[]} in + + let decreases_clause bs c = + if Debug.low () + then BU.print2 "Building a decreases clause over (%s) and %s\n" + (show bs) (show c); + + //exclude types and function-typed arguments from the decreases clause + //and reveal and erased arguments + let filter_types_and_functions (bs:binders) = + let out_rev, env = + List.fold_left + (fun (out, env) binder -> + let b = binder.binder_bv in + let t = N.unfold_whnf env (U.unrefine b.sort) in + let env = Env.push_binders env [binder] in + match t.n with + | Tm_type _ + | Tm_arrow _ -> + (out, env) + | _ -> + let arg = S.bv_to_name b in + let arg = + match is_erased_head t with + | Some (u, ty) -> U.apply_reveal u ty arg + | _ -> arg + in + (arg::out, env)) + ([], env) + bs + in + List.rev out_rev + in + let cflags = U.comp_flags c in + match cflags |> List.tryFind (function DECREASES _ -> true | _ -> false) with + | Some (DECREASES d) -> d + | _ -> bs |> filter_types_and_functions |> Decreases_lex + in + + let precedes_t = TcUtil.fvar_env env Const.precedes_lid in + let rec mk_precedes_lex env l l_prev : term = + (* + * AR: aux assumes that l and l_prev have the same lengths + * Given l = [a; b; c], l_prev = [d; e; f], it builds: + * a << d \/ (eq3 a d /\ b << e) \/ (eq3 a d /\ eq3 b e /\ c << f + * We build an "untyped" term here, the caller will typecheck it properly + *) + let rec aux l l_prev : term = + let type_of (should_warn:bool) (e1:term) (e2:term) : typ & typ = + (* + * AR: we compute the types of e1 and e2 to provide type + * arguments to eq3 (otherwise F* may infer something that Z3 is unable + * to prove equal later on) + * as a check, if the types are not equal, we emit a warning so that + * the programmer may annotate explicitly if needed + *) + //AR: 03/30: WARNING: dropping the guard in computing t1 and t2 below + let t1 = env.typeof_well_typed_tot_or_gtot_term env e1 false |> fst |> U.unrefine in + let t2 = env.typeof_well_typed_tot_or_gtot_term env e2 false |> fst |> U.unrefine in + let rec warn t1 t2 = + if TEQ.eq_tm env t1 t2 = TEQ.Equal + then false + else match (SS.compress t1).n, (SS.compress t2).n with + | Tm_uinst (t1, _), Tm_uinst (t2, _) -> warn t1 t2 + | Tm_name _, Tm_name _ -> false //do not warn for names, e.g. in polymorphic functions, the names may be instantiated at the call sites + | Tm_app {hd=h1; args=args1}, Tm_app {hd=h2; args=args2} -> + warn h1 h2 || List.length args1 <> List.length args2 || + (List.zip args1 args2 |> List.existsML (fun ((a1, _), (a2, _)) -> warn a1 a2)) + | Tm_refine {b=t1; phi=phi1}, Tm_refine {b=t2; phi=phi2} -> + warn t1.sort t2.sort || warn phi1 phi2 + | Tm_uvar _, _ + | _, Tm_uvar _ -> false + | _, _ -> true in + + (if not env.phase1 && should_warn && warn t1 t2 + then match (SS.compress t1).n, (SS.compress t2).n with + | Tm_name _, Tm_name _ -> () + | _, _ -> + let open FStarC.Pprint in + let open FStarC.Class.PP in + Errors.log_issue e1 Errors.Warning_Defensive [ + prefix 2 1 (text "In the decreases clause for this function, the SMT solver may not be able to prove that the types of") + (group (pp e1 ^/^ parens (text "bound in" ^/^ pp e1.pos))) ^/^ + prefix 2 1 (text "and") + (group (pp e2 ^/^ parens (text "bound in" ^/^ pp e2.pos))) ^/^ + text "are equal."; + prefix 2 1 (text "The type of the first term is:") (pp t1); + prefix 2 1 (text "The type of the second term is:") (pp t2); + text "If the proof fails, try annotating these with the same type."; + ]); + t1, t2 in + + match l, l_prev with + | [], [] -> + mk_Tm_app precedes_t [as_arg S.unit_const; as_arg S.unit_const] r + | [x], [x_prev] -> + let t_x, t_x_prev = type_of false x x_prev in + mk_Tm_app precedes_t [iarg t_x; iarg t_x_prev; as_arg x; as_arg x_prev] r + | x::tl, x_prev::tl_prev -> + let t_x, t_x_prev = type_of true x x_prev in + let tm_precedes = mk_Tm_app precedes_t [ + iarg t_x; + iarg t_x_prev; + as_arg x; + as_arg x_prev ] r in + let eq3_x_x_prev = mk_eq3_no_univ t_x t_x_prev x x_prev in + + mk_disj tm_precedes + (mk_conj eq3_x_x_prev (aux tl tl_prev)) in + + (* Call aux with equal sized prefixes of l and l_prev *) + let l, l_prev = + let n, n_prev = List.length l, List.length l_prev in + if n = n_prev then l, l_prev + else if n < n_prev then l, l_prev |> List.splitAt n |> fst + else l |> List.splitAt n_prev |> fst, l_prev in + aux l l_prev in + + let mk_precedes (env:Env.env) d d_prev = + match d, d_prev with + | Decreases_lex l, Decreases_lex l_prev -> + mk_precedes_lex env l l_prev + | Decreases_wf (rel, e), Decreases_wf (rel_prev, e_prev) -> + (* + * For well-founded relations based termination checking, + * just prove that (rel e e_prev) + *) + let rel_guard = mk_Tm_app rel [as_arg e; as_arg e_prev] r in + if TEQ.eq_tm env rel rel_prev = TEQ.Equal + then rel_guard + else ( + (* if the relation is dependent on parameters in scope, + additionally prove that those parameters are invariant, + i.e., the rel and rel_prev are provably equal *) + let t_rel, _ = + Errors.with_ctx + ("Typechecking decreases well-founded relation") + (fun _ -> env.typeof_well_typed_tot_or_gtot_term env rel false) + in + let t_rel_prev, _ = + Errors.with_ctx + ("Typechecking previous decreases well-founded relation") + (fun _ -> env.typeof_well_typed_tot_or_gtot_term env rel_prev false) + in + let eq_guard = U.mk_eq3_no_univ t_rel t_rel_prev rel rel_prev in + U.mk_conj eq_guard rel_guard + ) + + | _, _ -> + Errors.raise_error r Errors.Fatal_UnexpectedTerm + "Cannot build termination VC with a well-founded relation and lex ordering" + in + + let previous_dec = decreases_clause actuals expected_c in + + let guard_one_letrec (l, arity, t, u_names) = + let formals, c = N.get_n_binders env arity t in + + (* This should never happen since `termination_check_enabled` + * takes care to not return an arity bigger than the one in + * the lbtyp. *) + if arity > List.length formals then + failwith "impossible: bad formals arity, guard_one_letrec"; + + //make sure they all have non-null names + let formals = formals |> List.map (fun b -> + if S.is_null_bv b.binder_bv + then ({b with binder_bv=S.new_bv (Some (S.range_of_bv b.binder_bv)) b.binder_bv.sort}) + else b) in + let dec = decreases_clause formals c in + let precedes = + let env = Env.push_binders env formals in + mk_precedes env dec previous_dec in + let precedes = TcUtil.label (Errors.mkmsg "Could not prove termination of this recursive call") r precedes in + let bs, ({binder_bv=last; binder_positivity=pqual; binder_attrs=attrs; binder_qual=imp}) = BU.prefix formals in + let last = {last with sort=U.refine last precedes} in + let refined_formals = bs@[S.mk_binder_with_attrs last imp pqual attrs] in + let t' = U.arrow refined_formals c in + if Debug.medium () + then BU.print3 "Refined let rec %s\n\tfrom type %s\n\tto type %s\n" + (show l) (show t) (show t'); + l, t', u_names + in + letrecs |> List.map guard_one_letrec + +let wrap_guard_with_tactic_opt topt g = + match topt with + | None -> g + | Some tactic -> + (* We use always_map_guard so the annotation is there even for trivial + * guards. If the user writes (a <: b by fail ""), we should fail. *) + Env.always_map_guard g (fun g -> + Common.mk_by_tactic tactic (U.mk_squash U_zero g)) //guards are in U_zero + + +(* + * This is pattern matching an `(M.reflect e) <: C` + * + * As we special case typechecking of such terms (as a subcase of `Tm_ascribed` in the main `tc_term` loop + * + * Returns the (e, arg_qualifier) and the lident of M + *) +let is_comp_ascribed_reflect (e:term) : option (lident & term & aqual) = + match (SS.compress e).n with + | Tm_ascribed {tm=e;asc=(Inr _, _, _)} -> + (match (SS.compress e).n with + | Tm_app {hd=head; args} when List.length args = 1 -> + (match (SS.compress head).n with + | Tm_constant (Const_reflect l) -> args |> List.hd |> (fun (e, aqual) -> (l, e, aqual)) |> Some + | _ -> None) + | _ -> None) + | _ -> None + + +(************************************************************************************************************) +(* Main type-checker begins here *) +(************************************************************************************************************) +let rec tc_term env e = + def_check_scoped e.pos "tc_term.entry" env e; + if Debug.medium () then + BU.print5 "(%s) Starting tc_term (phase1=%s) of %s (%s), %s {\n" + (Range.string_of_range <| Env.get_range env) + (string_of_bool env.phase1) + (show e) + (tag_of (SS.compress e)) + (print_expected_ty_str env); + + let r, ms = BU.record_time (fun () -> + tc_maybe_toplevel_term ({env with top_level=false}) e) in + if Debug.medium () then begin + BU.print4 "(%s) } tc_term of %s (%s) took %sms\n" (Range.string_of_range <| Env.get_range env) + (show e) + (tag_of (SS.compress e)) + (string_of_int ms); + let e, lc , _ = r in + BU.print4 "(%s) Result is: (%s:%s) (%s)\n" (Range.string_of_range <| Env.get_range env) + (show e) + (TcComm.lcomp_to_string lc) + (tag_of (SS.compress e)) + end; + r + +and tc_maybe_toplevel_term env (e:term) : term (* type-checked and elaborated version of e *) + & lcomp (* computation type where the WPs are lazily evaluated *) + & guard_t = (* well-formedness condition *) + let env = if e.pos=Range.dummyRange then env else Env.set_range env e.pos in + def_check_scoped e.pos "tc_maybe_toplevel_term.entry" env e; + let top = SS.compress e in + if Debug.medium () then + BU.print3 "Typechecking %s (%s): %s\n" (show <| Env.get_range env) (tag_of top) (show top); + match top.n with + | Tm_delayed _ -> failwith "Impossible" + | Tm_bvar _ -> failwith "Impossible: tc_maybe_toplevel_term: not LN" + + | Tm_uinst _ + | Tm_uvar _ + | Tm_name _ + | Tm_fvar _ + | Tm_constant _ + | Tm_abs _ + | Tm_arrow _ + | Tm_refine _ + | Tm_type _ + | Tm_unknown -> tc_value env e + + | Tm_quoted (qt, qi) -> + let projl = function + | Inl x -> x + | Inr _ -> failwith "projl fail" + in + let non_trivial_antiquotations qi = + let is_not_name t = + match (SS.compress t).n with + | Tm_name _ -> false + | _ -> true + in + BU.for_some is_not_name (snd qi.antiquotations) + in + begin match qi.qkind with + (* In this case, let-bind all antiquotations so we're sure that effects + * are properly handled. *) + | Quote_static when non_trivial_antiquotations qi -> + // FIXME: check shift=0 + let e0 = e in + let newbvs = List.map (fun _ -> S.new_bv None S.t_term) (snd qi.antiquotations) in + + let z = List.zip (snd qi.antiquotations) newbvs in + + let lbs = List.map (fun (t, bv') -> + U.close_univs_and_mk_letbinding None (Inl bv') [] + S.t_term Const.effect_Tot_lid + t [] t.pos) + z in + let qi = { qi with antiquotations = (0, List.map (fun (t, bv') -> S.bv_to_name bv') z) } in + let nq = mk (Tm_quoted (qt, qi)) top.pos in + let e = List.fold_left (fun t lb -> mk (Tm_let {lbs=(false, [lb]); + body=SS.close [S.mk_binder (projl lb.lbname)] t}) top.pos) nq lbs in + tc_maybe_toplevel_term env e + + (* A static quote is of type `term`, as long as its antiquotations are too *) + | Quote_static -> + (* Typecheck the antiquotations expecting a term *) + let aqs = snd qi.antiquotations in + let env_tm = Env.set_expected_typ env t_term in + let (aqs_rev, guard, _env) = + List.fold_left (fun (aqs_rev, guard, env_tm) aq_tm -> + let aq_tm, _, g = tc_term env_tm aq_tm in + let env_tm = Env.push_bv env_tm (S.new_bv None t_term) in + (aq_tm::aqs_rev, g ++ guard, env_tm)) + ([], mzero, env_tm) aqs + in + let qi = { qi with antiquotations = (0, List.rev aqs_rev) } in + + let tm = mk (Tm_quoted (qt, qi)) top.pos in + value_check_expected_typ env tm (Inl S.t_term) guard + + | Quote_dynamic -> + let c = mk_Tac S.t_term in + + (* Typechecked the quoted term just to elaborate it *) + let env', _ = Env.clear_expected_typ env in + let env' = { env' with admit = true } in + let qt, _, g = tc_term env' qt in + let g0 = { g with guard_f = Trivial } in //explicitly dropping the logical guard; this is just a quotation + let g0 = Rel.resolve_implicits env' g0 in + + + let t = mk (Tm_quoted (qt, qi)) top.pos in + + let t, lc, g = value_check_expected_typ env t (Inr (TcComm.lcomp_of_comp c)) mzero in + let t = mk (Tm_meta {tm=t; + meta=Meta_monadic_lift (Const.effect_PURE_lid, Const.effect_TAC_lid, S.t_term)}) + t.pos in + t, lc, g ++ g0 + end + + | Tm_lazy ({lkind=Lazy_embedding _ }) -> + tc_term env (U.unlazy top) + + // lazy terms have whichever type they're annotated with + | Tm_lazy i -> + value_check_expected_typ env top (Inl i.ltyp) mzero + + | Tm_meta {tm=e; meta=Meta_desugared Meta_smt_pat} -> + let e, c, g = tc_tot_or_gtot_term env e in + let g = {g with guard_f=Trivial} in //VC's in SMT patterns are irrelevant + mk (Tm_meta {tm=e; meta=Meta_desugared Meta_smt_pat}) top.pos, c, g //AR: keeping the pats as meta for the second phase. smtencoding does an unmeta. + + | Tm_meta {tm=e; meta=Meta_pattern(names, pats)} -> + let t, u = U.type_u () in + let e, c, g = tc_check_tot_or_gtot_term env e t None in + //NS: PATTERN INFERENCE + //if `pats` is empty (that means the user did not annotate a pattern). + //In that case try to infer a pattern by + //analyzing `e` for the smallest terms that contain all the variables + //in `names`. + //If not pattern can be inferred, raise a warning + let pats, g' = + let env, _ = Env.clear_expected_typ env in + tc_smt_pats env pats in + let g' = {g' with guard_f=Trivial} in //The pattern may have some VCs associated with it, but these are irrelevant. + mk (Tm_meta {tm=e; meta=Meta_pattern(names, pats)}) top.pos, + c, + g ++ g' //but don't drop g' altogether, since it also contains unification constraints + + | Tm_meta {tm=e; meta=Meta_desugared Sequence} -> + // + // Sequence is only relevant for pretty printing + // + let e, c, g = tc_term env e in + let e = mk (Tm_meta {tm=e; meta=Meta_desugared Sequence}) top.pos in + e, c, g + + | Tm_meta {tm=e; meta=Meta_monadic _} + | Tm_meta {tm=e; meta=Meta_monadic_lift _} -> + (* KM : This case should not happen when typechecking once but is it really *) + (* okay to just drop the annotation ? *) + tc_term env e + + | Tm_meta {tm=e; meta=m} -> + let e, c, g = tc_term env e in + let e = mk (Tm_meta {tm=e; meta=m}) top.pos in + e, c, g + + | Tm_ascribed {tm=e; asc=(asc, Some tac, use_eq); eff_opt= labopt} -> + (* Ascription with an associated tactic for its guard. We typecheck + * the ascribed term without the tactic by recursively calling tc_term, + * and then we wrap the returned guard with the tactic. We must also return + * the guard for the well-typing of the tactic itself. *) + + let tac, _, g_tac = tc_tactic t_unit t_unit env tac in + + let t' = mk (Tm_ascribed {tm=e; asc=(asc, None, use_eq); eff_opt=labopt}) top.pos in + let t', c, g = tc_term env t' in + + (* Set the tac ascription on the elaborated term *) + let t' = + match (SS.compress t').n with + | Tm_ascribed {tm=e; asc=(asc, None, _use_eq); eff_opt=labopt} -> + //assert (use_eq = _use_eq); + mk (Tm_ascribed {tm=e; asc=(asc, Some tac, use_eq); eff_opt=labopt}) t'.pos + | _ -> + failwith "impossible" + in + let g = wrap_guard_with_tactic_opt (Some tac) g in + t', c, g ++ g_tac + + (* + * AR: Special case for the typechecking of (M.reflect e) <: M a is + * + * As part of it, we typecheck (e <: Tot (repr a is)), this keeps the bidirectional + * typechecking for e, which is most cases is a lambda + * + * Also the `Tot` annotation is important since for lambdas, we fold the guard + * into the returned comp (making it something like PURE (arrow_t) wp, see the end of tc_abs) + * If we did not put `Tot` we would have to separately check that the wp has + * a trivial precondition + *) + + | Tm_ascribed {asc=(Inr expected_c, None, use_eq)} + when top |> is_comp_ascribed_reflect |> is_some -> + + let (effect_lid, e, aqual) = top |> is_comp_ascribed_reflect |> must in + + let env0, _ = Env.clear_expected_typ env in + + let expected_c, _, g_c = tc_comp env0 expected_c in + let expected_ct = Env.unfold_effect_abbrev env0 expected_c in + + if not (lid_equals effect_lid expected_ct.effect_name) + then raise_error top Errors.Fatal_UnexpectedEffect + (BU.format2 "The effect on reflect %s does not match with the annotation %s\n" + (show effect_lid) (show expected_ct.effect_name)); + + if not (is_user_reflectable_effect env effect_lid) + then raise_error top Errors.Fatal_EffectCannotBeReified + (BU.format1 "Effect %s cannot be reflected" (show effect_lid)); + + let u_c = expected_ct.comp_univs |> List.hd in + let repr = Env.effect_repr env0 (expected_ct |> S.mk_Comp) u_c |> must in + + // e <: Tot repr + let e = S.mk (Tm_ascribed {tm=e; asc=(Inr (S.mk_Total repr), None, use_eq); eff_opt=None}) e.pos in + + if Debug.extreme () + then BU.print1 "Typechecking ascribed reflect, inner ascribed term: %s\n" + (show e); + + let e, _, g_e = tc_tot_or_gtot_term env0 e in + let e = U.unascribe e in + + if Debug.extreme () + then BU.print2 "Typechecking ascribed reflect, after typechecking inner ascribed term: %s and guard: %s\n" + (show e) (Rel.guard_to_string env0 g_e); + + //reconstruct (M.reflect e) < M a is + let top = + let r = top.pos in + let tm = mk (Tm_constant (Const_reflect effect_lid)) r in + let tm = mk (Tm_app {hd=tm;args=[e, aqual]}) r in + mk (Tm_ascribed {tm; asc=(Inr expected_c, None, use_eq); eff_opt=expected_c |> U.comp_effect_name |> Some}) r in + + //check the expected type in the env, if present + let top, c, g_env = comp_check_expected_typ env top (expected_c |> TcComm.lcomp_of_comp) in + + top, c, g_c ++ g_e ++ g_env + + | Tm_ascribed {tm=e; asc=(Inr expected_c, None, use_eq)} -> + let env0, _ = Env.clear_expected_typ env in + let expected_c, _, g = tc_comp env0 expected_c in + let e, c', g' = tc_term + (U.comp_result expected_c |> (fun t -> Env.set_expected_typ_maybe_eq env0 t use_eq)) + e in + let e, expected_c, g'' = + let c', g_c' = TcComm.lcomp_comp c' in + let e, expected_c, g'' = check_expected_effect env0 use_eq + (Some expected_c) + (e, c') in + e, expected_c, g_c' ++ g'' in + let e = mk (Tm_ascribed {tm=e; + asc=(Inr expected_c, None, use_eq); + eff_opt=Some (U.comp_effect_name expected_c)}) top.pos in //AR: this used to be Inr t_res, which meant it lost annotation for the second phase + let lc = TcComm.lcomp_of_comp expected_c in + let f = g ++ g'++ g'' in + let e, c, f2 = comp_check_expected_typ env e lc in + e, c, f ++ f2 + + | Tm_ascribed {tm=e; asc=(Inl t, None, use_eq)} -> + let k, u = U.type_u () in + let t, _, f = tc_check_tot_or_gtot_term env t k None in + let e, c, g = tc_term (Env.set_expected_typ_maybe_eq env t use_eq) e in + //NS: Maybe redundant strengthen + let c, f = TcUtil.strengthen_precondition (Some (fun () -> Err.ill_kinded_type)) (Env.set_range env t.pos) e c f in + let e, c, f2 = comp_check_expected_typ env (mk (Tm_ascribed {tm=e; + asc=(Inl t, None, use_eq); + eff_opt=Some c.eff_name}) top.pos) c in + e, c, f ++ (g ++ f2) + + (* Unary operators. Explicitly curry extra arguments *) + | Tm_app {hd={n=Tm_constant Const_range_of}; args=a::hd::rest} + | Tm_app {hd={n=Tm_constant (Const_reify _)}; args=a::hd::rest} + | Tm_app {hd={n=Tm_constant (Const_reflect _)}; args=a::hd::rest} -> + let rest = hd::rest in //no 'as' clauses in F* yet, so we need to do this ugliness + let unary_op, _ = U.head_and_args top in + let head = mk (Tm_app {hd=unary_op; args=[a]}) (Range.union_ranges unary_op.pos (fst a).pos) in + let t = mk (Tm_app {hd=head; args=rest}) top.pos in + tc_term env t + + (* Binary operators *) + | Tm_app {hd={n=Tm_constant Const_set_range_of}; args=a1::a2::hd::rest} -> + let rest = hd::rest in //no 'as' clauses in F* yet, so we need to do this ugliness + let unary_op, _ = U.head_and_args top in + let head = mk (Tm_app {hd=unary_op; args=[a1; a2]}) (Range.union_ranges unary_op.pos (fst a1).pos) in + let t = mk (Tm_app {hd=head; args=rest}) top.pos in + tc_term env t + + | Tm_app {hd={n=Tm_constant Const_range_of}; args=[(e, None)]} -> + let e, c, g = tc_term (fst <| Env.clear_expected_typ env) e in + let head, _ = U.head_and_args top in + mk (Tm_app {hd=head; args=[(e, None)]}) top.pos, (TcComm.lcomp_of_comp <| mk_Total (tabbrev Const.range_lid)), g + + | Tm_app {hd={n=Tm_constant Const_set_range_of}; args=(t, None)::(r, None)::[]} -> + let head, _ = U.head_and_args top in + let env' = Env.set_expected_typ env (tabbrev Const.range_lid) in + let er, _, gr = tc_term env' r in + let t, tt, gt = tc_term env t in + let g = gr ++ gt in + mk_Tm_app head [S.as_arg t; S.as_arg r] top.pos, tt, g + + | Tm_app {hd={n=Tm_constant Const_range_of}} + | Tm_app {hd={n=Tm_constant Const_set_range_of}} -> + raise_error e Errors.Fatal_IllAppliedConstant (BU.format1 "Ill-applied constant %s" (show top)) + + | Tm_app {hd={n=Tm_constant (Const_reify _)}; args=[(e, aqual)]} -> + if Option.isSome aqual + then Errors.log_issue e + Errors.Warning_IrrelevantQualifierOnArgumentToReify + "Qualifier on argument to reify is irrelevant and will be ignored"; + + // + // Typecheck e + // + let env0, _ = Env.clear_expected_typ env in + let e, c, g = tc_term env0 e in + let c, g_c = + let c, g_c = TcComm.lcomp_comp c in + Env.unfold_effect_abbrev env c, g_c in + + if not (is_user_reifiable_effect env c.effect_name) then + raise_error e Errors.Fatal_EffectCannotBeReified + (BU.format1 "Effect %s cannot be reified" (string_of_lid c.effect_name)); + let u_c = List.hd c.comp_univs in + + let e = U.mk_reify e (Some c.effect_name) in + let repr = Env.reify_comp env (S.mk_Comp c) u_c in + let c = + if is_total_effect env c.effect_name + then S.mk_Total repr |> TcComm.lcomp_of_comp + else let ct = { comp_univs = [u_c] + ; effect_name = Const.effect_Dv_lid + ; result_typ = repr + ; effect_args = [] + ; flags = [] + } + in S.mk_Comp ct |> TcComm.lcomp_of_comp + in + let e, c, g' = comp_check_expected_typ env e c in + e, c, g ++ (g_c ++ g') + + | Tm_app {hd={n=Tm_constant (Const_reflect l)}; args=[(e, aqual)]}-> + if Option.isSome aqual then + Errors.log_issue e + Errors.Warning_IrrelevantQualifierOnArgumentToReflect + "Qualifier on argument to reflect is irrelevant and will be ignored"; + + if not (is_user_reflectable_effect env l) then + raise_error e Errors.Fatal_EffectCannotBeReified + (BU.format1 "Effect %s cannot be reflected" (string_of_lid l)); + + let reflect_op, _ = U.head_and_args top in + + begin match Env.effect_decl_opt env l with + | None -> + raise_error e Errors.Fatal_EffectNotFound + (BU.format1 "Effect %s not found (for reflect)" (Ident.string_of_lid l)) + + | Some (ed, qualifiers) -> + let env_no_ex, _ = Env.clear_expected_typ env in + + let e, c_e, g_e = + let e, c, g = tc_tot_or_gtot_term env_no_ex e in + if not <| TcComm.is_total_lcomp c then + Errors.log_issue e Errors.Error_UnexpectedGTotComputation "Expected Tot, got a GTot computation"; + e, c, g + in + + let (expected_repr_typ, g_repr), u_a, a, g_a = + let a, u_a = U.type_u () in + let a_uvar, _, g_a = TcUtil.new_implicit_var "tc_term reflect" e.pos env_no_ex a false in + TcUtil.fresh_effect_repr_en env_no_ex e.pos l u_a a_uvar, u_a, a_uvar, g_a in + + let g_eq = Rel.teq env_no_ex c_e.res_typ expected_repr_typ in + + let eff_args = + match (SS.compress expected_repr_typ).n with + | Tm_app {args=_::args} -> args + | _ -> + raise_error top Errors.Fatal_UnexpectedEffect + (BU.format3 "Expected repr type for %s is not an application node (%s:%s)" + (show l) (tag_of expected_repr_typ) + (show expected_repr_typ)) in + + let c = S.mk_Comp ({ + comp_univs=[u_a]; + effect_name = ed.mname; + result_typ=a; + effect_args=eff_args; + flags=[] + }) |> TcComm.lcomp_of_comp in + + let e = mk (Tm_app {hd=reflect_op; args=[(e, aqual)]}) top.pos in + + let e, c, g' = comp_check_expected_typ env e c in + + let e = S.mk (Tm_meta {tm=e; meta=Meta_monadic(c.eff_name, c.res_typ)}) e.pos in + + e, c, msum [g_e; g_repr; g_a; g_eq; g'] + end + + | Tm_app {hd={n=Tm_fvar {fv_qual=Some (Unresolved_constructor uc)}}; args} -> + (* ToSyntax left an unresolved constructor, we have to use type info to disambiguate *) + let base_term, uc_fields = + let base_term, fields = + if uc.uc_base_term + then match args with + | (b, _)::rest -> Some b, rest + | _ -> failwith "Impossible" + else None, args + in + if List.length uc.uc_fields <> List.length fields + then raise_error top Errors.Fatal_IdentifierNotFound + (BU.format2 "Could not resolve constructor; expected %s fields but only found %s" + (show <| List.length uc.uc_fields) + (show <| List.length fields)) + else ( + base_term, List.zip uc.uc_fields (List.map fst fields) + ) + in + let (rdc, constrname, constructor), topt = + match Env.expected_typ env with + | Some (t, _) -> + //first, prefer the expected type from the context, if any + TcUtil.find_record_or_dc_from_typ env (Some t) uc top.pos, Some (Inl t) + + | None -> + match base_term with + | Some e -> + //Otherwise, if we have an {e with ...}, compute the type of e and use it + //(there's no expected type anyway from the context, so no need to clear it check e) + let _, lc, _ = tc_term env e in + TcUtil.find_record_or_dc_from_typ env (Some lc.res_typ) uc top.pos, Some (Inr lc.res_typ) + + | None -> + //Otherwise, no type info here, use what ToSyntax decided + TcUtil.find_record_or_dc_from_typ env None uc top.pos, None + in + let rdc : DsEnv.record_or_dc = rdc in //for type-based disambiguation of rdc projectors below + let constructor = S.fv_to_tm constructor in + let mk_field_projector i x = + let projname = mk_field_projector_name_from_ident constrname i in + let qual = if rdc.is_record then Some (Record_projector (constrname, i)) else None in + let candidate = S.fvar (Ident.set_lid_range projname x.pos) qual in + S.mk_Tm_app candidate [(x, None)] x.pos + in + let fields = + TcUtil.make_record_fields_in_order env uc topt + rdc + uc_fields + (fun field_name -> + match base_term with + | Some x -> Some (mk_field_projector field_name x) + | _ -> None) + top.pos + in + let args = List.map (fun x -> x, None) fields in + let term = S.mk_Tm_app constructor args top.pos in + tc_term env term + + | Tm_app {hd={n=Tm_fvar {fv_name={v=field_name}; fv_qual=Some (Unresolved_projector candidate)}}; + args=(e, None)::rest} -> + (* ToSyntax left an unresolved projector, we have to use type info to disambiguate *) + let proceed_with choice = + match choice with + | None -> + raise_error field_name Errors.Fatal_IdentifierNotFound [ + text <| BU.format1 "Field name %s could not be resolved" (string_of_lid field_name); + ] + | Some choice -> + let f = S.fv_to_tm choice in + let term = S.mk_Tm_app f ((e, None)::rest) top.pos in + tc_term env term + in + //We have e.f, use the type of e to disambiguate + let _, lc, _ = + let env, _ = Env.clear_expected_typ env in + tc_term env e + in + begin + let t0 = N.unfold_whnf' [Unascribe; Unmeta; Unrefine] env lc.res_typ in + let thead, _ = U.head_and_args t0 in + if !dbg_RFD + then ( + BU.print3 "Got lc.res_typ=%s; t0 = %s; thead = %s\n" + (show lc.res_typ) + (show t0) + (show thead) + ); + match (SS.compress (U.un_uinst thead)).n with + | Tm_fvar type_name -> ( + match TcUtil.try_lookup_record_type env type_name.fv_name.v with + | None -> proceed_with candidate + | Some rdc -> + let i = + List.tryFind + (fun (i, _) -> TcUtil.field_name_matches field_name rdc i) + rdc.fields + in + match i with + | None -> proceed_with candidate + | Some (i, _) -> + let constrname = FStarC.Ident.lid_of_ids (Ident.ns_of_lid rdc.typename @ [rdc.constrname]) in + let projname = mk_field_projector_name_from_ident constrname i in + let qual = if rdc.is_record then Some (Record_projector (constrname, i)) else None in + let choice = + S.lid_as_fv + (Ident.set_lid_range projname (Ident.range_of_lid field_name)) + qual + in + proceed_with (Some choice) + ) + | _ -> proceed_with candidate + end + + // If we're on the first phase, we don't synth, and just wait for the next phase + | Tm_app {hd=head; args=[(tau, None)]} + | Tm_app {hd=head; args=[(_, Some ({ aqual_implicit = true })); (tau, None)]} + when U.is_synth_by_tactic head && not env.phase1 -> + (* Got an application of synth_by_tactic, process it *) + + // no "as" clause + let head, args = U.head_and_args top in + tc_synth head env args top.pos + + | Tm_app {hd=head; args} + when U.is_synth_by_tactic head && not env.phase1 -> + (* We have some extra args, move them out of the way *) + let args1, args2 = + match args with + | (tau, None)::rest -> + [(tau, None)], rest + | (a, Some aq) :: (tau, None) :: rest + when aq.aqual_implicit -> + [(a, Some aq); (tau, None)], rest + | _ -> + raise_error top Errors.Fatal_SynthByTacticError "synth_by_tactic: bad application" + in + let t1 = mk_app head args1 in + let t2 = mk_app t1 args2 in + tc_term env t2 + + (* An ordinary application *) + | Tm_app {hd=head; args} -> + let env0 = env in + let env = Env.clear_expected_typ env |> fst |> instantiate_both in + if Debug.high () + then BU.print3 "(%s) Checking app %s, %s\n" + (Range.string_of_range top.pos) + (show top) + (print_expected_ty_str env0); + + //Don't instantiate head; instantiations will be computed below, accounting for implicits/explicits + let head, chead, g_head = tc_term (no_inst env) head in + let chead, g_head = TcComm.lcomp_comp chead |> (fun (c, g) -> c, g_head ++ g) in + let e, c, g = + (* If the function is shortcircuiting, we must check that the arguments are + pure/ghost. We skirt this check with --MLish, though. *) + if TcUtil.short_circuit_head head && not (Options.ml_ish ()) && not env.phase1 + then let e, c, g = check_short_circuit_args env head chead g_head args (Env.expected_typ env0) in + // //TODO: this is not efficient: + // // It is quadratic in the size of boolean terms + // // e.g., a && b && c && d ... & zzzz will be huge + // let c = if Env.should_verify env && + // not (U.is_lcomp_partial_return c) && + // U.is_pure_or_ghost_lcomp c + // then TcUtil.maybe_assume_result_eq_pure_term env e c + // else c in + e, c, g + else check_application_args env head chead g_head args (Env.expected_typ env0) + in + let e, c, implicits = + if TcComm.is_tot_or_gtot_lcomp c + // Also instantiate in phase1, dropping any precondition, + // since it will be recomputed correctly in phase2. + || (env.phase1 && TcComm.is_pure_or_ghost_lcomp c) + then let e, res_typ, implicits = TcUtil.maybe_instantiate env0 e c.res_typ in + e, TcComm.set_result_typ_lc c res_typ, implicits + else e, c, mzero + in + if Debug.extreme () + then BU.print1 "Introduced {%s} implicits in application\n" (Rel.print_pending_implicits g); + let e, c, g' = comp_check_expected_typ env0 e c in + let gres = g ++ g' ++ implicits in + if Debug.extreme () + then BU.print2 "Guard from application node %s is %s\n" + (show e) + (Rel.guard_to_string env gres); + e, c, gres + + | Tm_match _ -> + tc_match env top + + | Tm_let {lbs=(false, [{lbname=Inr _}])} -> + check_top_level_let env top + + | Tm_let {lbs=(false, _)} -> + check_inner_let env top + + | Tm_let {lbs=(true, {lbname=Inr _}::_)} -> + check_top_level_let_rec env top + + | Tm_let {lbs=(true, _)} -> + check_inner_let_rec env top + +and tc_match (env : Env.env) (top : term) : term & lcomp & guard_t = + + (* + * AR: Typechecking of match expression: + * + * match expressions may be optionally annotated with a `returns` annotation + * for dependent pattern matching + * + * When the return annotation is not supplied, we: + * -- typecheck the scrutinee + * -- typecheck the branches with + * -- if the expected type is not set in the env, then create a new uvar for it + * -- a new bv, guard_x below, as the scrutinee expression in the logic, + * guard_x is not in the scope of the branch, but it may appear in the + * computation type of the branch and branch condition + * -- combine the computation types of the branches (TcUtil.bind_cases) + * -- with the if_the_else combinator, also adding pattern exhaustiveness checks + * -- bind the scrutinee computation type with the combined branches using guard_x as the bv in bind + * this is where guard_x gets captured + * + * When the returns annotation is supplied: + * -- typecheck the scrutinee + * -- typecheck the returns annotation + * -- typecheck the branches with + * -- env with expected type unset + * -- guard_x, as the scrutinee expression in the logic, as above + * -- in tc_eqn: substituting the binder in the returns annotation with the scrutinee expression + * and ascribing it on the branch expression + * -- once the branch expression is typechecked, we also remove this ascription + * -- if the returns annotation is a type: + * -- (in tc_match) set the result type of the branches to it (is this step redundant?) + * -- TcUtil.bind_cases as before + * -- bind with the scrutinee computation type, capturing guard_x as the bind variable + * -- if the return annotation was a computation type: + * -- tc_eqn may return branch guard (different from branch condition), containing guard_x + * -- no need to bind cases, since we can take the computation type as is + * -- but we need to add pattern exhaustiveness check, and get rid of guard_x in the guard + * -- we close the guard as: forall guard_x. guard_x == scrutinee ==> ... + * -- bind with the scrutinee computation type + *) + + match (SS.compress top).n with + | Tm_match {scrutinee=e1; ret_opt; brs=eqns} -> //ret_opt is the returns annotation + let e1, c1, g1 = tc_term + (env |> Env.clear_expected_typ |> fst |> instantiate_both) + e1 in + + (* If there is a constructor in the first branch (not a variable), + then we grab the inductive type that we are matching on and use + that to maybe coerce the scrutinee. Hence `match t with | Tv_App ... ->` + will coerce the t. QUESTION: Why don't we do the same thing to get + a expected type to check the scrutinee with? *) + let e1, c1, g_c = + match eqns with + | (p, _, _)::_ -> + begin match p.v with + | Pat_cons (fv, _, _) -> + (* Wrapped in a try/catch, we may be looking up unresolved constructors. *) + let r = try Some (Env.lookup_datacon env fv.fv_name.v) with | _ -> None in + begin match r with + | Some (us, t) -> + let bs, c = U.arrow_formals_comp t in + let env' = Env.push_binders env bs in + TcUtil.maybe_coerce_lc env' e1 c1 (U.comp_result c) + | None -> + e1, c1, mzero + end + | _ -> + e1, c1, mzero + end + | _ -> e1, c1, mzero + in + + let env_branches, ret_opt, g1 = + match ret_opt with + | None -> + (match Env.expected_typ env with + | Some _ -> env, None, g1 + | None -> + let k, _ = U.type_u() in + let res_t, _, g = TcUtil.new_implicit_var "match result" e1.pos env k false in + Env.set_expected_typ env res_t, + None, + g1 ++ g) + | Some (b, asc) -> + //We have a returns annotation + + //First check that e1 is pure or ghost + //The reason is that, we will compute the final type/comp + // of match result by substituting b with e1 + // + //We could do an optimization here: + // if b does not occur free in asc, then we don't need to do this check + //Is it worth doing? + if not (TcUtil.is_pure_or_ghost_effect env c1.eff_name) + then raise_error e1 Errors.Fatal_UnexpectedEffect + (BU.format2 + "For a match with returns annotation, the scrutinee should be pure/ghost, \ + found %s with effect %s" + (show e1) + (string_of_lid c1.eff_name)); + + //Clear the expected type in the environment for the branches + // we will check the expected type for the whole match at the end + let env, _ = Env.clear_expected_typ env in + let b, asc = + let bs, asc = SS.open_ascription [b] asc in + let b = List.hd bs in + //we set the sort of the binder to be the type of e1 + {b with binder_bv={b.binder_bv with sort=c1.res_typ}}, asc in + //b is in scope for asc + let env_asc = Env.push_binders env [b] in + let asc, g_asc = + match asc with //at this point, we just pack back the use_eq bit + | Inl t, None, use_eq -> + let k, _ = U.type_u () in + let t, _, g = tc_check_tot_or_gtot_term env_asc t k None in + (Inl t, None, use_eq), g + | Inr c, None, use_eq -> + let c, _, g = tc_comp env_asc c in + (Inr c, None, use_eq), g + | _ -> + raise_error env Errors.Fatal_UnexpectedTerm + "Tactic is not yet supported with match returns" + in + + //we need to close g_asc with the binder b + env, + Some (b, asc), + g1 ++ Env.close_guard env_asc [b] g_asc in + + //g1 is now the guard for the scrutinee and the ascription + // and it is well-formed in env + + //the logical variable for the scrutinee + let guard_x = S.new_bv (Some e1.pos) c1.res_typ in + let t_eqns = eqns |> List.map (tc_eqn guard_x env_branches ret_opt) in + + let c_branches, g_branches, erasable = + match ret_opt with + | Some (b, (Inr c, _, _)) -> //a return annotation, with computation type + + //c has b free, so substitute it with the scrutinee + let c = SS.subst_comp [NT (b.binder_bv, e1)] c in + + //we don't need to bind the cases + //but we still need to + // (a) weaken the guards for the branches with the + // negation of the branch conditions that come before this branch + // (b) add exhaustiveness check + // (c) close guard_x + + let fmls, gs, erasables = //branch conditions, branch guards, erasable bits + t_eqns + |> List.map (fun (_, f, _, _, _, g, b) -> (f, g, b)) + |> List.unzip3 in + let neg_conds, exhaustiveness_cond = TcUtil.get_neg_branch_conds fmls in + let g = + List.map2 TcComm.weaken_guard_formula gs neg_conds + |> msum in + let g_exhaustiveness = + U.mk_imp exhaustiveness_cond U.t_false + |> TcUtil.label Err.exhaustiveness_check (Env.get_range env) //label + |> NonTrivial + |> Env.guard_of_guard_formula in + let g = g ++ g_exhaustiveness in + //weaken with guard_x == scrutinee + let g = TcComm.weaken_guard_formula g + (U.mk_eq2 (env.universe_of env c1.res_typ) c1.res_typ (S.bv_to_name guard_x) e1) in + //close guard_x + let g = Env.close_guard env [S.mk_binder guard_x] g in + TcComm.lcomp_of_comp c, + g, + erasables |> List.fold_left (fun acc b -> acc || b) false + + | _ -> + let cases, g, erasable = + List.fold_right + (fun (branch, f, eff_label, cflags, c, g, erasable_branch) (caccum, gaccum, erasable) -> + (f, eff_label, cflags |> must, c |> must)::caccum, + g ++ gaccum, + erasable || erasable_branch) t_eqns ([], mzero, false) in + match ret_opt with + | None -> + //no returns annotation, just bind_cases + //when the returns annotation is absent, env_branches contains the expected type + // (which may either be coming from top, or a new uvar) + let res_t = Env.expected_typ env_branches |> must |> fst in + TcUtil.bind_cases env res_t cases guard_x, g, erasable + + | Some (b, (Inl t, _, _)) -> //a returns annotation, with type + + //t has b free, so substitute it with the scrutinee + let t = SS.subst [NT (b.binder_bv, e1)] t in + + //set the type in the lcomp of the branches, and then bind_cases + //AR: is this step redundant? should check + let cases = List.map + (fun (f, eff_label, cflags, c) -> + (f, eff_label, cflags, (fun b -> TcComm.set_result_typ_lc (c b) t))) cases in + + TcUtil.bind_cases env t cases guard_x, g, erasable + in + + //bind with e1's computation type + let cres = TcUtil.bind e1.pos env (Some e1) c1 (Some guard_x, c_branches) in + + let cres = + if erasable + then (* promote cres to ghost *) + let e = U.exp_true_bool in + let c = mk_GTotal U.t_bool in + TcUtil.bind e.pos env (Some e) (TcComm.lcomp_of_comp c) (None, cres) + else cres + in + + let e = + //repack the returns ascription + let ret_opt = + match ret_opt with + | None -> None + | Some (b, asc) -> + let asc = SS.close_ascription [b] asc in + let b = List.hd (SS.close_binders [b]) in + //we make the binder sort as tun, + // since we always use the type of the scrutinee + let b = {b with binder_bv={b.binder_bv with sort=tun}} in + Some (b, asc) in + let mk_match scrutinee = + let branches = t_eqns |> List.map (fun ((pat, wopt, br), _, eff_label, _, _, _, _) -> + pat, wopt, TcUtil.maybe_lift env br eff_label cres.eff_name cres.res_typ + ) in + let e = + let rc = { residual_effect = cres.eff_name; + residual_typ = Some cres.res_typ; + residual_flags = cres.cflags } in + mk (Tm_match {scrutinee; ret_opt; brs=branches; rc_opt=Some rc}) top.pos in + let e = TcUtil.maybe_monadic env e cres.eff_name cres.res_typ in + //The ascription with the result type is useful for re-checking a term, translating it to Lean etc. + //AR: revisit, for now doing only if return annotation is not provided + match ret_opt with + | None -> mk (Tm_ascribed {tm=e; asc=(Inl cres.res_typ, None, false); eff_opt=Some cres.eff_name}) e.pos + | _ -> e + in + + //see issue #594: + //if the scrutinee is impure, then explicitly sequence it with an impure let binding + //to protect it from the normalizer optimizing it away + if TcUtil.is_pure_or_ghost_effect env c1.eff_name + then mk_match e1 + else + (* generate a let binding for e1 *) + let e_match = mk_match (S.bv_to_name guard_x) in + let lb = U.mk_letbinding (Inl guard_x) [] c1.res_typ (Env.norm_eff_name env c1.eff_name) e1 [] e1.pos in + let e = mk (Tm_let {lbs=(false, [lb]); + body=SS.close [S.mk_binder guard_x] e_match}) top.pos in + TcUtil.maybe_monadic env e cres.eff_name cres.res_typ + in + + //AR: finally, if we typechecked with the return annotation, + // we need to make sure that we check the expected type in the env + let e, cres, g_expected_type = + match ret_opt with + | None -> e, cres, mzero + | _ -> comp_check_expected_typ env e cres in + + if Debug.extreme () + then BU.print2 "(%s) Typechecked Tm_match, comp type = %s\n" + (Range.string_of_range top.pos) (TcComm.lcomp_to_string cres); + + e, cres, g_c ++ g1 ++ g_branches ++ g_expected_type + + | _ -> + failwith (BU.format1 "tc_match called on %s\n" (tag_of top)) + +and tc_synth head env args rng = + let tau, atyp = + match args with + | (tau, None)::[] -> + tau, None + | (a, Some ({ aqual_implicit = true })) :: (tau, None) :: [] -> + tau, Some a + | _ -> + raise_error rng Errors.Fatal_SynthByTacticError "synth_by_tactic: bad application" + in + + if !dbg_Tac then + BU.print2 "Processing synth of %s at type %s\n" (show tau) (show atyp); + + let typ = + match atyp with + | Some t -> t + | None -> begin match Env.expected_typ env with + | Some (t, use_eq) -> + if use_eq + then raise_error t Errors.Fatal_NotSupported + (BU.format1 "Equality ascription in synth (%s) is not yet supported, \ + please use subtyping" + (show t)); + t + | None -> raise_error env Errors.Fatal_SynthByTacticError "synth_by_tactic: need a type annotation when no expected type is present" + end + in + + // Check the result type + let typ, _, g1 = tc_term (Env.set_expected_typ env (fst <| U.type_u ())) typ in + Rel.force_trivial_guard env g1; + + // Check the tactic + let tau, _, g2 = tc_tactic t_unit t_unit env tau in + Rel.force_trivial_guard env g2; + + let t = env.synth_hook env typ ({ tau with pos = rng }) in + if !dbg_Tac then + BU.print1 "Got %s\n" (show t); + + // Should never trigger, meta-F* will check it before. + TcUtil.check_uvars tau.pos t; + + t, TcComm.lcomp_of_comp <| mk_Total typ, mzero + +and tc_tactic (a:typ) (b:typ) (env:Env.env) (tau:term) : term & lcomp & guard_t = + let env = { env with failhard = true } in + tc_check_tot_or_gtot_term env tau (t_tac_of a b) None + +and check_instantiated_fvar (env:Env.env) (v:S.var) (q:option S.fv_qual) (e:term) (t0:typ) + : term & lcomp & guard_t + = + let is_data_ctor = function + | Some Data_ctor + | Some (Record_ctor _) -> true + | _ -> false + in + if is_data_ctor q && not (Env.is_datacon env v.v) then + raise_error env Errors.Fatal_MissingDataConstructor + (BU.format1 "Expected a data constructor; got %s" (string_of_lid v.v)); + + (* remove inaccesible pattern implicits, make them regular implicits *) + let t = U.remove_inacc t0 in + + let e, t, implicits = TcUtil.maybe_instantiate env e t in +// BU.print3 "Instantiated type of %s from %s to %s\n" (show e) (show t0) (show t); + let tc = + if Env.should_verify env + then Inl t + else Inr (TcComm.lcomp_of_comp <| mk_Total t) + in + + value_check_expected_typ env e tc implicits + +(************************************************************************************************************) +(* Type-checking values: *) +(* Values have no special status, except that we structure the code to promote a value type t to a Tot t *) +(************************************************************************************************************) +and tc_value env (e:term) : term + & lcomp + & guard_t = + + //As a general naming convention, we use e for the term being analyzed and its subterms as e1, e2, etc. + //We use t and its variants for the type of the term being analyzed + let env = Env.set_range env e.pos in + let top = SS.compress e in + match top.n with + | Tm_bvar x -> + (* This can happen if user tactics build an ill-scoped term *) + raise_error top Errors.Error_IllScopedTerm + (BU.format1 "Violation of locally nameless convention: %s" (show top)) + + | Tm_uvar (u, s) -> //the type of a uvar is given directly with it; we do not recheck the type + //FIXME: Check context inclusion? + value_check_expected_typ env e (Inl (SS.subst' s (U.ctx_uvar_typ u))) mzero + + //only occurs where type annotations are missing in source programs + //or the program has explicit _ for missing terms + | Tm_unknown -> + let r = Env.get_range env in + let t, g0 = + match Env.expected_typ env with + | None -> + let k, u = U.type_u () in + let t, _, g0 = TcUtil.new_implicit_var "type of user-provided implicit term" r env k false in + t, g0 + + | Some (t, use_eq) when use_eq -> + raise_error e Errors.Fatal_NotSupported [ + Errors.Msg.text <| BU.format1 "Equality ascription as an expected type for unk (:%s) is not yet supported." (show t); + Errors.Msg.text "Please use subtyping." + ] + + | Some (t, _) -> + t, mzero + in + + let e, _, g1 = TcUtil.new_implicit_var + ("user-provided implicit term at " ^ show r) + r env t false + in + e, S.mk_Total t |> TcComm.lcomp_of_comp, g0 ++ g1 + + | Tm_name x -> + let t, rng = Env.lookup_bv env x in + let x = S.set_range_of_bv ({x with sort=t}) rng in + Env.insert_bv_info env x t; + let e = S.bv_to_name x in + let e, t, implicits = TcUtil.maybe_instantiate env e t in + let tc = if Env.should_verify env then Inl t else Inr (TcComm.lcomp_of_comp <| mk_Total t) in + value_check_expected_typ env e tc implicits + + | Tm_uinst({n=Tm_fvar fv}, _) + | Tm_fvar fv when S.fv_eq_lid fv Const.synth_lid && not env.phase1 -> + raise_error env Errors.Fatal_BadlyInstantiatedSynthByTactic "Badly instantiated synth_by_tactic" + + | Tm_uinst({n=Tm_fvar fv}, us) -> + let us = List.map (tc_universe env) us in + let (us', t), range = Env.lookup_lid env fv.fv_name.v in + let fv = S.set_range_of_fv fv range in + maybe_warn_on_use env fv; + if List.length us <> List.length us' then + raise_error env Errors.Fatal_UnexpectedNumberOfUniverse + (BU.format3 "Unexpected number of universe instantiations for \"%s\" (%s vs %s)" + (show fv) + (show (List.length us)) + (show (List.length us'))); + + (* Make sure the instantiated universes match with the ones + * provided by the Tm_uinst. The universes in us' will usually + * be U_unif with unresolved uvars, but they could be U_names + * when the definition is recursive. *) + List.iter2 + (fun ul ur -> match ul, ur with + | U_unif u'', _ -> UF.univ_change u'' ur + // TODO: more cases? we cannot get U_succ or U_max here I believe... + | U_name n1, U_name n2 when Ident.ident_equals n1 n2 -> () + | _ -> + raise_error env Errors.Fatal_IncompatibleUniverse + (BU.format3 "Incompatible universe application for %s, expected %s got %s\n" + (show fv) + (show ul) + (show ur))) + us' us; + + Env.insert_fv_info env fv t; + let e = S.mk_Tm_uinst (mk (Tm_fvar fv) e.pos) us in + check_instantiated_fvar env fv.fv_name fv.fv_qual e t + + (* not an fvar, fail *) + | Tm_uinst(_, us) -> + raise_error env Errors.Fatal_UnexpectedNumberOfUniverse + "Universe applications are only allowed on top-level identifiers" + + | Tm_fvar fv -> + let (us, t), range = Env.lookup_lid env fv.fv_name.v in + let fv = S.set_range_of_fv fv range in + maybe_warn_on_use env fv; + if !dbg_Range + then BU.print5 "Lookup up fvar %s at location %s (lid range = defined at %s, used at %s); got universes type %s\n" + (show (lid_of_fv fv)) + (Range.string_of_range e.pos) + (Range.string_of_range range) + (Range.string_of_use_range range) + (show t); + Env.insert_fv_info env fv t; + let e = S.mk_Tm_uinst (mk (Tm_fvar fv) e.pos) us in + check_instantiated_fvar env fv.fv_name fv.fv_qual e t + + | Tm_constant c -> + let t = tc_constant env top.pos c in + let e = mk (Tm_constant c) e.pos in + value_check_expected_typ env e (Inl t) mzero + + | Tm_arrow {bs; comp=c} -> + let bs, c = SS.open_comp bs c in + let env0 = env in + let env, _ = Env.clear_expected_typ env in + (* type checking the binders *) + let bs, env, g, us = tc_binders env bs in + (* type checking the computation *) + let c, uc, f = tc_comp env c in + let e = {U.arrow bs c with pos=top.pos} in + (* checks the SMT pattern associated with this function is properly defined with regard to context *) + if not env.phase1 then + check_smt_pat env e bs c; + (* taking the maximum of the universes of the computation and of all binders *) + let u = S.U_max (uc::us) in + (* create a universe of level u *) + let t = mk (Tm_type u) top.pos in + let g = g ++ (Env.close_guard_univs us bs f) in + let g = TcUtil.close_guard_implicits env false bs g in + value_check_expected_typ env0 e (Inl t) g + + | Tm_type u -> + let u = tc_universe env u in + let t = mk (Tm_type(S.U_succ u)) top.pos in + let e = mk (Tm_type u) top.pos in + value_check_expected_typ env e (Inl t) mzero + + | Tm_refine {b=x; phi} -> + let x, phi = SS.open_term [S.mk_binder x] phi in + let env0 = env in + let env, _ = Env.clear_expected_typ env in + let x, env, f1, u = tc_binder env (List.hd x) in + if Debug.high () + then BU.print3 "(%s) Checking refinement formula %s; binder is %s\n" + (Range.string_of_range top.pos) (show phi) (show x.binder_bv); + let t_phi, _ = U.type_u () in + let phi, _, f2 = tc_check_tot_or_gtot_term env phi t_phi + (Some "refinement formula must be pure or ghost") in + let e = {U.refine x.binder_bv phi with pos=top.pos} in + let t = mk (Tm_type u) top.pos in + let g = f1 ++ Env.close_guard_univs [u] [x] f2 in + let g = TcUtil.close_guard_implicits env false [x] g in + value_check_expected_typ env0 e (Inl t) g + + | Tm_abs {bs; body} -> + (* in case we use type variables which are implicitly quantified, we add quantifiers here *) + let bs = TcUtil.maybe_add_implicit_binders env bs in + if Debug.medium () + then BU.print1 "Abstraction is: %s\n" (show ({top with n=Tm_abs {bs; body; rc_opt=None}})); + let bs, body = SS.open_term bs body in + tc_abs env top bs body + + | _ -> + failwith (BU.format2 "Unexpected value: %s (%s)" (show top) (tag_of top)) + +and tc_constant (env:env_t) r (c:sconst) : typ = + let res = + match c with + | Const_unit -> t_unit + | Const_bool _ -> t_bool + | Const_int (_, None) -> t_int + | Const_int (_, Some msize) -> + tconst (match msize with + | Signed, Int8 -> Const.int8_lid + | Signed, Int16 -> Const.int16_lid + | Signed, Int32 -> Const.int32_lid + | Signed, Int64 -> Const.int64_lid + | Unsigned, Int8 -> Const.uint8_lid + | Unsigned, Int16 -> Const.uint16_lid + | Unsigned, Int32 -> Const.uint32_lid + | Unsigned, Int64 -> Const.uint64_lid + | Unsigned, Sizet -> Const.sizet_lid) + | Const_string _ -> t_string + | Const_real _ -> t_real + | Const_char _ -> + FStarC.Syntax.DsEnv.try_lookup_lid env.dsenv FStarC.Parser.Const.char_lid + |> BU.must + + (* TODO (KM) : Try to change this to U.ktype1 *) + (* (because that's the minimal universe level of the WP) *) + (* and see how much code breaks *) + | Const_effect -> U.ktype0 //NS: really? + | Const_range _ -> t_range + | Const_range_of + | Const_set_range_of + | Const_reify _ + | Const_reflect _ -> + raise_error r Errors.Fatal_IllTyped + (BU.format1 "Ill-typed %s: this constant must be fully applied" (show c)) + + | _ -> raise_error r Errors.Fatal_UnsupportedConstant ("Unsupported constant: " ^ show c) + in + SS.set_use_range r res + + +(************************************************************************************************************) +(* Type-checking computation types *) +(************************************************************************************************************) +and tc_comp env c : comp (* checked version of c *) + & universe (* universe of c *) + & guard_t = (* logical guard for the well-formedness of c *) + let c0 = c in + match c.n with + | Total t -> + let k, u = U.type_u () in + let t, _, g = tc_check_tot_or_gtot_term env t k None in + mk_Total t, u, g + + | GTotal t -> + let k, u = U.type_u () in + let t, _, g = tc_check_tot_or_gtot_term env t k None in + mk_GTotal t, u, g + + | Comp c -> + let head = S.fvar c.effect_name None in + let head = match c.comp_univs with + | [] -> head + | us -> S.mk (Tm_uinst(head, us)) c0.pos in + let tc = mk_Tm_app head ((as_arg c.result_typ)::c.effect_args) c.result_typ.pos in + let tc, _, f = + (* + * AR: 11/18: TcUtil.weaken_result_typ by default logs a typing error and continues + * Failing hard when typechecking computation types, since errors + * like missing effect args can result in broken invariants in + * the unifier or the normalizer + *) + tc_check_tot_or_gtot_term ({ env with failhard = true }) tc S.teff None in + let head, args = U.head_and_args tc in + let comp_univs = match (SS.compress head).n with + | Tm_uinst(_, us) -> us + | _ -> [] in + let _, args = U.head_and_args tc in + let res, args = List.hd args, List.tl args in + let flags, guards = c.flags |> List.map (function + | DECREASES (Decreases_lex l) -> + let env, _ = Env.clear_expected_typ env in + let l, g = l |> List.fold_left (fun (l, g) e -> + let e, _, g_e = tc_tot_or_gtot_term env e in + l@[e], g ++ g_e) ([], mzero) in + DECREASES (Decreases_lex l), g + | DECREASES (Decreases_wf (rel, e)) -> + (* + * We will check that for a fresh uvar (?u:Type), + * rel:well_founded_relation ?u and + * e:?u + *) + let env, _ = Env.clear_expected_typ env in + let t, u_t = U.type_u () in + let u_r = Env.new_u_univ () in + let a, _, g_a = TcUtil.new_implicit_var + "implicit for type of the well-founded relation in decreases clause" + rel.pos + env + t + false + in + //well_founded_relation t + let wf_t = mk_Tm_app + (mk_Tm_uinst + (Env.fvar_of_nonqual_lid env Const.well_founded_relation_lid) + [u_t; u_r]) + [as_arg a] rel.pos in + let rel, _, g_rel = tc_tot_or_gtot_term (Env.set_expected_typ env wf_t) rel in + let e, _, g_e = tc_tot_or_gtot_term (Env.set_expected_typ env a) e in + DECREASES (Decreases_wf (rel, e)), + g_a ++ g_rel ++ g_e + | f -> f, mzero) |> List.unzip in + let u = env.universe_of env (fst res) in + let c = mk_Comp ({c with + comp_univs=comp_univs; + result_typ=fst res; + flags = flags; + effect_args=args}) in + let u_c = c |> TcUtil.universe_of_comp env u in + c, u_c, f ++ msum guards + +and tc_universe env u : universe = + let rec aux u = + let u = SS.compress_univ u in + match u with + | U_bvar _ -> failwith "Impossible: locally nameless" + | U_unknown -> failwith "Unknown universe" + | U_unif _ + | U_zero -> u + | U_succ u -> U_succ (aux u) + | U_max us -> U_max (List.map aux us) + | U_name x -> + if Env.lookup_univ env x + then u + else failwith ("Universe variable " ^ (show u) ^ " not found") + in if env.lax_universes then U_zero + else (match u with + | U_unknown -> U.type_u () |> snd + | _ -> aux u) + +(* Several complex cases from the main type-checker are factored in to separate functions below *) + + +(* + * Called when typechecking a Tm_abs node + * + * t0 is the expected type in the environment for the Tm_abs node + * and the use_eq bit (whether to use type equality) + *) +and tc_abs_expected_function_typ env (bs:binders) (t0:option (typ & bool)) (body:term) +: (option typ (* any remaining expected type to check against *) +& binders (* binders from the abstraction checked against the binders in the corresponding Typ_fun, if any *) +& binders (* let rec binders, suitably guarded with termination check, if any *) +& option comp (* the expected comp type for the body *) +& Env.env (* environment for the body *) +& term (* the body itself *) +& guard_t) (* accumulated guard from checking the binders, well-formed in the initial env *) + += match t0 with + | None -> (* no expected type; just build a function type from the binders in the term *) + (* env.letrecs are the current letrecs we are checking *) + let _ = match env.letrecs with + | [] -> () + | _ -> failwith "Impossible: Can't have a let rec annotation but no expected type" in + let bs, envbody, g_env, _ = tc_binders env bs in + None, bs, [], None, envbody, body, g_env + + | Some (t, use_eq) -> + let t = SS.compress t in + let rec as_function_typ (norm:bool) t = + match (SS.compress t).n with + (* we are type checking abs so all cases except arrow are required for definitional equality *) + | Tm_uvar _ + | Tm_app {hd={n=Tm_uvar _}} -> + (* expected a uvar; build a function type from the term and unify with it *) + let _ = match env.letrecs with | [] -> () | _ -> failwith "Impossible: uvar abs with non-empty environment" in + let bs, envbody, g_env, _ = tc_binders env bs in + let envbody, _ = Env.clear_expected_typ envbody in + Some t, bs, [], None, envbody, body, g_env + + (* CK: add this case since the type may be f:(a -> M b wp){φ}, in which case I drop the refinement *) + (* NS: 07/21 dropping the refinement is not sound; we need to check that f validates phi. See Bug #284 *) + | Tm_refine {b} -> + let _, bs, bs', copt, env_body, body, g_env = as_function_typ norm b.sort in + //we pass type `t` out to check afterwards the full refinement type is respected + Some t, bs, bs', copt, env_body, body, g_env + + | Tm_arrow {bs=bs_expected; comp=c_expected} -> + let bs_expected, c_expected = SS.open_comp bs_expected c_expected in + (* Two main interesting bits here; + 1. The expected type may have + a. more immediate binders, whereas the function may itself return a function + b. fewer immediate binders, meaning that the function type is explicitly curried + 2. If the function is a let-rec and it is to be total, then we need to add termination checks. + *) + let check_actuals_against_formals env bs bs_expected body + : Env.env + & binders + & guard_t + & comp + & term + = let rec handle_more (env_bs, bs, more, guard_env, subst) c_expected body = + match more with + | None -> //number of binders match up + env_bs, bs, guard_env, SS.subst_comp subst c_expected, body + + | Some (Inr more_bs_expected) -> //more formal parameters; expect the body to return a total function + let c = S.mk_Total (U.arrow more_bs_expected c_expected) in + env_bs, bs, guard_env, SS.subst_comp subst c, body + + | Some (Inl more_bs) -> //more actual args + let c = SS.subst_comp subst c_expected in + (* the expected type is explicitly curried *) + if Options.ml_ish () || U.is_named_tot c then + let t = N.unfold_whnf env_bs (U.comp_result c) in + match t.n with + | Tm_arrow {bs=bs_expected; comp=c_expected} -> + let bs_expected, c_expected = SS.open_comp bs_expected c_expected in + let (env_bs_bs', bs', more, guard'_env_bs, subst) = tc_abs_check_binders env_bs more_bs bs_expected use_eq in + let guard'_env = Env.close_guard env_bs bs guard'_env_bs in + handle_more (env_bs_bs', bs@bs', more, guard_env ++ guard'_env, subst) c_expected body + | _ -> + let body = U.abs more_bs body None in + env_bs, bs, guard_env, c, body + else let body = U.abs more_bs body None in + env_bs, bs, guard_env, c, body + in //end let rec handle_more + handle_more (tc_abs_check_binders env bs bs_expected use_eq) c_expected body + in //end let rec check_actuals_against_formals + + let mk_letrec_env envbody bs c = + let letrecs = guard_letrecs envbody bs c in + let envbody = {envbody with letrecs=[]} in + let envbody, letrec_binders, g = + letrecs |> List.fold_left (fun (env, letrec_binders, g) (l,t,u_names) -> + //let t = N.normalize [Env.EraseUniverses; Env.Beta] env t in + //printfn "Checking let rec annot: %s\n" (show t); + let t, _, g' = tc_term (Env.clear_expected_typ env |> fst) t in + let env = Env.push_let_binding env l (u_names, t) in + let lb = match l with + | Inl x -> S.mk_binder ({x with sort=t})::letrec_binders + | _ -> letrec_binders in + env, lb, g ++ g') (envbody, [], mzero) in + (envbody, letrec_binders, Env.close_guard envbody bs g) + in + + (* Set letrecs to [] before calling check_actuals_against_formals, + * then restore. That function will typecheck the types of the binders + * and having letrecs set will make a mess. *) + let envbody = { env with letrecs = [] } in + let envbody, bs, g_env, c, body = check_actuals_against_formals envbody bs bs_expected body in + let envbody = { envbody with letrecs = env.letrecs } in + let envbody, letrecs, g_annots = mk_letrec_env envbody bs c in + let envbody = Env.set_expected_typ_maybe_eq envbody (U.comp_result c) use_eq in + Some t, bs, letrecs, Some c, envbody, body, g_env ++ g_annots + + | _ -> (* expected type is not a function; + try normalizing it first; + otherwise synthesize a type and check it against the given type *) + if not norm + then as_function_typ true (t |> N.unfold_whnf env |> U.unascribe) //AR: without the unascribe we lose out on some arrows + else + let _, bs, _, c_opt, envbody, body, g_env = tc_abs_expected_function_typ env bs None body in + Some t, bs, [], c_opt, envbody, body, g_env + in + as_function_typ false t + +(***************************************************************************************************************) + (* check_binders checks that the binders bs of top *) + (* are compatible with the binders of the function typ expected by the context *) + (* If there are more bs than bs_expected, we only check a prefix and the suffix is returned Inl *) + (* If there are more bs_expected than bs, the suffix of bs_expected is returned Inr *) + (* If use_eq flag is set, we check type equality for the binder types *) +(***************************************************************************************************************) +and tc_abs_check_binders env bs bs_expected use_eq + : Env.env (* env extended with a prefix of bs *) + & binders (* the type-checked prefix of bs *) + & option (either binders binders) (* suffix of either bs or bs_expected*) + & guard_t (* accumulated logical guard + well-formed in argument env *) + & subst_t = (* alpha conv. of bs_expected to bs *) + let rec aux (env, subst) (bs:binders) (bs_expected:binders) + : Env.env + & binders + & option (either binders binders) + & guard_t //guard is well-formed in the input environment + & subst_t = + match bs, bs_expected with + | [], [] -> env, [], None, mzero, subst + + | ({binder_qual=None})::_, ({binder_bv=hd_e;binder_qual=q;binder_positivity=pqual;binder_attrs=attrs})::_ + when S.is_bqual_implicit_or_meta q -> + (* When an implicit is expected, but the user provided an + * explicit binder, insert a nameless implicit binder. *) + let bv = S.new_bv (Some (Ident.range_of_id hd_e.ppname)) (SS.subst subst hd_e.sort) in + aux (env, subst) ((S.mk_binder_with_attrs bv q pqual attrs) :: bs) bs_expected + + | ({binder_bv=hd;binder_qual=imp;binder_positivity=pqual_actual; binder_attrs=attrs})::bs, + ({binder_bv=hd_expected;binder_qual=imp';binder_positivity=pqual_expected;binder_attrs=attrs'})::bs_expected -> begin + (* These are the discrepancies in qualifiers that we allow *) + let special q1 q2 = match q1, q2 with + | Some (Meta _), Some (Meta _) -> true (* don't compare the metaprograms *) + | None, Some Equality -> true + | Some (Implicit _), Some (Meta _) -> true + | _ -> false in + + if not (special imp imp') && not (U.eq_bqual imp imp') then + let open FStarC.Errors.Msg in + let open FStarC.Pprint in + let open FStarC.Class.PP in + raise_error hd Errors.Fatal_InconsistentImplicitArgumentAnnotation [ + text <| BU.format1 "Inconsistent implicit argument annotation on argument %s" (show hd); + prefix 2 1 (text "Got:") (squotes <| doc_of_string <| Print.bqual_to_string imp); + prefix 2 1 (text "Expected:") (squotes <| doc_of_string <| Print.bqual_to_string imp'); + ] + end; + + // The expected binder may be annotated with a positivity attribute + // though the actual binder on the abstraction may not ... we use the expected pqual + // But, it is not ok if the expected binder is not annotated while the + // actual binder is annnotated as strictly positive. + let positivity_qual_to_string = function + | None -> "None" + | Some BinderStrictlyPositive -> "StrictlyPositive" + | Some BinderUnused -> "Unused" + in + if not (Common.check_positivity_qual true pqual_expected pqual_actual) + then raise_error hd Errors.Fatal_InconsistentQualifierAnnotation + (BU.format3 "Inconsistent positivity qualifier on argument %s; \ + Expected qualifier %s, \ + found qualifier %s" + (show hd) + (positivity_qual_to_string pqual_expected) + (positivity_qual_to_string pqual_actual)); + + (* since binders depend on previous ones, we accumulate a substitution *) + let expected_t = SS.subst subst hd_expected.sort in + let t, g_env = + match (U.unmeta hd.sort).n with + | Tm_unknown -> expected_t, mzero + (* in case we have an annotation on both implementation and declaration, we: + * 1) type check the implementation type + * 2) add an extra guard that the two types must be equal (use_eq will be used in Rel.teq + *) + | _ -> + if Debug.high () then BU.print1 "Checking binder %s\n" (show hd); + let t, _, g1_env = tc_tot_or_gtot_term env hd.sort in + let g2_env = + let label_guard g = + TcUtil.label_guard + hd.sort.pos + (Errors.mkmsg "Type annotation on parameter incompatible with the expected type") + g in + + //cf issue #57 (the discussion at the end about subtyping vs. equality in check_binders) + //check that the context is more demanding of the argument type + + match Rel.teq_nosmt env t expected_t with + | Some g -> g |> Rel.resolve_implicits env //AR: why resolve here? + | None -> + if use_eq + then Rel.teq env t expected_t |> label_guard + else match Rel.get_subtyping_prop env expected_t t with + | None -> + // GM: Make sense of this, is basic_type_error fatal or not? + Err.raise_basic_type_error env (Env.get_range env) None expected_t t + | Some g_env -> label_guard g_env + in + t, g1_env ++ g2_env + in + + let hd = {hd with sort=t} in + let combine_attrs (attrs:list S.attribute) (attrs':list S.attribute) : list S.attribute = + let diff = List.filter (fun attr' -> + not (List.existsb (fun attr -> TEQ.eq_tm env attr attr' = TEQ.Equal) attrs) + ) attrs' in + attrs@diff + in + let b = {binder_bv=hd;binder_qual=imp;binder_positivity=pqual_expected;binder_attrs=combine_attrs attrs attrs'} in + check_erasable_binder_attributes env b.binder_attrs t; + let b_expected = ({binder_bv=hd_expected;binder_qual=imp';binder_positivity=pqual_expected;binder_attrs=attrs'}) in + let env_b = push_binding env b in + let subst = maybe_extend_subst subst b_expected (S.bv_to_name hd) in + let env_bs, bs, rest, g'_env_b, subst = aux (env_b, subst) bs bs_expected in + let g'_env = Env.close_guard env_bs [b] g'_env_b in + env_bs, b::bs, rest, g_env ++ g'_env, subst + + | rest, [] -> + env, [], Some (Inl rest), mzero, subst + + | [], rest -> + env, [], Some (Inr rest), mzero, subst in + + aux (env, []) bs bs_expected + +(*******************************************************************************************************************) +(* Type-checking abstractions, aka lambdas *) +(* top = fun bs -> body, although bs and body must already be opened *) +(*******************************************************************************************************************) +and tc_abs env (top:term) (bs:binders) (body:term) : term & lcomp & guard_t = + let fail :string -> typ -> 'a = fun msg t -> + Err.expected_a_term_of_type_t_got_a_function env top.pos msg t top + in + + let env0 = env in + (* topt is the expected type of the expression obtained from the env *) + let env, topt = Env.clear_expected_typ env in + + if Debug.high () then + BU.print2 "!!!!!!!!!!!!!!!Expected type is (%s), top_level=%s\n" + (show topt) (show env.top_level); + + let tfun_opt, bs, letrec_binders, c_opt, envbody, body, g_env = + tc_abs_expected_function_typ env bs topt body in + + if Debug.extreme () then + BU.print3 "After expected_function_typ, tfun_opt: %s, c_opt: %s, and expected type in envbody: %s\n" + (show tfun_opt) (show c_opt) (show (Env.expected_typ envbody)); + + if !dbg_NYC + then BU.print2 "!!!!!!!!!!!!!!!Guard for function with binders %s is %s\n" + (show bs) + (guard_to_string env g_env); + + let envbody = Env.set_range envbody body.pos in + let body, cbody, guard_body = + (* + * AR: Special casing the typechecking of the body when it is a M.reflect e + * If so, and c_opt is not None, i.e. we have an expected type in the env, + * we make the body as (M.reflect e) <: c_opt + * Basically, typechecking a reflect can be made better by the effect indices + * See also special casing of M.reflect <: C in the same file + * + * AR: the type of should_check_expected_effect is + * either bool unit + * + * where Inl b means do check expected effect, with use_eq = b + * and Inr _ means don't check expected effect + *) + let envbody, body, should_check_expected_effect = + let use_eq_opt = + match topt with + | Some (_, use_eq) -> use_eq |> Some + | _ -> None in + if c_opt |> is_some && + (match (SS.compress body).n with //body is an M.reflect + | Tm_app {hd=head; args} when List.length args = 1 -> + (match (SS.compress head).n with + | Tm_constant (Const_reflect _) -> true + | _ -> false) + | _ -> false) + then + Env.clear_expected_typ envbody |> fst, + S.mk + //since copt is Some, topt, and hence use_eq_opt must also be Some + (Tm_ascribed {tm=body; asc=(Inr (c_opt |> must), None, use_eq_opt |> must); eff_opt=None}) + Range.dummyRange, + Inr () //no need to check expected type + else + envbody, + body, + (match c_opt, (SS.compress body).n with + | None, Tm_ascribed {asc=(Inr expected_c, _, _)} -> + //body is already ascribed a computation type; + //don't check it again + //Not only is it redundant and inefficient, it also sometimes leads to bizarre errors + //e.g., Issue #1208 + Inr () + | _ -> Inl (BU.dflt false use_eq_opt)) + in + let body, cbody, guard_body = + tc_term ({envbody with top_level=false}) body in + + //we don't abstract over subtyping constraints; so solve them now + //but leave out the tactics constraints for later so that the tactic + //can have a more global view of all the constraints + let guard_body = Rel.solve_non_tactic_deferred_constraints true envbody guard_body in + + match should_check_expected_effect with + | Inl use_eq -> + let cbody, g_lc = TcComm.lcomp_comp cbody in + let body, cbody, guard = + Errors.with_ctx "While checking that lambda abstraction has expected effect" (fun () -> + check_expected_effect envbody use_eq c_opt (body, cbody)) + in + body, cbody, guard_body ++ g_lc ++ guard + | Inr _ -> + let cbody, g_lc = TcComm.lcomp_comp cbody in + body, cbody, guard_body ++ g_lc + in + + if Debug.extreme () + then BU.print1 "tc_abs: guard_body: %s\n" + (Rel.guard_to_string env guard_body); + + let guard_body = + (* If we were checking a top-level definition, which may be a let rec, + we must discharge this the guard of the body here, as it is + only typeable in the extended environment which contains the Binding_lids. + Closing the guard (below) won't help with that. *) + if env.top_level then ( + if Debug.medium () then + BU.print1 "tc_abs: FORCING guard_body: %s\n" (Rel.guard_to_string env guard_body); + Rel.discharge_guard envbody guard_body + ) else ( + guard_body + ) + in + + let guard = + let guard_body = Env.close_guard envbody (bs@letrec_binders) guard_body in + g_env ++ guard_body + in + + let guard = TcUtil.close_guard_implicits env false bs guard in //TODO: this is a noop w.r.t scoping; remove it and the eager_subtyping flag + let tfun_computed = U.arrow bs cbody in + let e = U.abs bs body (Some (U.residual_comp_of_comp (dflt cbody c_opt))) in + + (* + * AR: Check strictly_positive annotations on the binders, if any + * + * To do so, we use the same routine as used for inductive types, + * after substituting the bv name with a fresh lid fv in the function body + *) + let _ = + List.iter + (fun b -> + if Options.no_positivity() + then () + else ( + if U.is_binder_unused b + && not (Positivity.name_unused_in_type envbody b.binder_bv body) + then raise_error b Error_InductiveTypeNotSatisfyPositivityCondition + (BU.format1 "Binder %s is marked unused, but its use in the definition is not" + (show b)) + ; + + if U.is_binder_strictly_positive b + && not (Positivity.name_strictly_positive_in_type envbody b.binder_bv body) + then raise_error b Error_InductiveTypeNotSatisfyPositivityCondition + (BU.format1 "Binder %s is marked strictly positive, but its use in the definition is not" + (show b)) + + )) + bs + in + + (* + * AR: there are three types in the code above now: + * topt : option term -- the original annotation + * tfun_opt : option term -- a definitionally equal type to topt (e.g. when topt is not an arrow but can be reduced to one) + * tfun_computed : term -- computed type of the abstraction + * + * the following code has the logic for which type to package the input expression with + * if tfun_opt is Some we are guaranteed that topt is also Some, and in that case, we use Some?.v topt + * in this case earlier we were returning Some?.v tfun_opt but that means we lost out on the user annotation + * if tfun_opt is None, then so is topt and we just return tfun_computed + *) + let e, tfun, guard = match tfun_opt with + | Some t -> + let t = SS.compress t in + let t_annot, use_eq = + match topt with + | Some (t, use_eq) -> t, use_eq + | None -> failwith "Impossible! tc_abs: if tfun_computed is Some, expected topt to also be Some" in + begin match t.n with + | Tm_arrow _ -> + //we already checked the body to have the expected type; so, no need to check again + //just repackage the expression with this type; t is guaranteed to be alpha equivalent to tfun_computed + e, t_annot, guard + | _ -> + let lc = S.mk_Total tfun_computed |> TcComm.lcomp_of_comp in + let e, _, guard' = TcUtil.check_has_type_maybe_coerce env e lc t use_eq in //QUESTION: t should also probably be t_annot here + let guard' = TcUtil.label_guard e.pos (Err.subtyping_failed env lc.res_typ t ()) guard' in + e, t_annot, guard ++ guard' + end + + | None -> e, tfun_computed, guard in + + let c = mk_Total tfun in + let c, g = TcUtil.strengthen_precondition None env e (TcComm.lcomp_of_comp c) guard in + + e, c, g + +(******************************************************************************) +(* Type-checking applications: Tm_app head args *) +(* head is already type-checked has comp type chead, with guard ghead *) +(******************************************************************************) +and check_application_args env head (chead:comp) ghead args expected_topt : term & lcomp & guard_t= + let n_args = List.length args in + let r = Env.get_range env in + let thead = U.comp_result chead in + if Debug.high () then + BU.print3 "(%s) Type of head is %s\nArgs = %s\n" (show head.pos) (show thead) (show args); + + (* given |- head : chead | ghead + where head is a computation returning a function of type (bs0@bs -> cres) + and the paramters bs0 have been applied to the arguments in arg_comps_rev (in reverse order) + and args_comps_rev = [(argn, _, cn), ..., (arg0, _, c0)] + + + This function builds + head arg0 ... argn : M (bs -> cres) wp + where in the case where + bs = [], i.e., a full application + M, wp is built using + bind chead (bind c0 (bind c1 ... (bind cn cres))) + bs = _::_, i.e., a partial application + M, wp is built using + bind chead (bind c0 (bind c1 ... (bind cn (Tot (bs -> cres)))) + *) + let monadic_application + (head, chead, ghead, cres) (* the head of the application, its lcomp chead, and guard ghead, returning a bs -> cres *) + subst (* substituting actuals for formals seen so far, when actual is pure *) + (arg_comps_rev:list (arg & option bv & lcomp)) (* type-checked actual arguments, so far; in reverse order *) + arg_rets_rev (* The results of each argument at the logic level, in reverse order *) + guard (* conjoined guard formula for all the actuals *) + fvs (* unsubstituted formals, to check that they do not occur free elsewhere in the type of f *) + bs (* formal parameters *) + : term //application of head to args + & lcomp //its computation type + & guard_t //and whatever guard remains + = let cres, guard = + match bs with + | [] -> (* full app *) + cres, ghead ++ guard + + | _ -> (* partial app *) + // + // AR: 04/29/2022: Do we need to solve these constraints here? + // + let g = ghead ++ guard |> Rel.solve_deferred_constraints env in + mk_Total (U.arrow bs cres), g in + + // + //AR: It is important that this check is done after we have + // added the bs to the cres result type, to ensure that fvs + // don't escape in the bs + // + let rt, g0 = check_no_escape (Some head) env fvs (U.comp_result cres) in + let cres, guard = + U.set_result_typ cres rt, + g0 ++ guard in + + if Debug.medium () + then BU.print1 "\t Type of result cres is %s\n" + (show cres); + + let chead, cres = SS.subst_comp subst chead |> TcComm.lcomp_of_comp, SS.subst_comp subst cres |> TcComm.lcomp_of_comp in + + (* Note: The arg_comps_rev are in reverse order. e.g., f e1 e2 e3, we have *) + (* arg_comps_rev = [(e3, _, c3); (e2; _; c2); (e1; _; c1)] *) + (* We build comp = bind chead (bind c1 (bind c2 (bind c3 cres))) *) + (* The typing rule for monadic application should be something like *) + + (* G |- head : chead G |- ei :ci *) + (* ------------------------------------------------- *) + (* G |- let xhead = lift_{chead}^{comp} head in *) + (* let x1 = lift_{ci}^{comp} e1 in *) + (* ... *) + (* lift_{cres}^{comp} (xhead x1 ... xn) : cres *) + + (* where chead = b1 -> ... bn -> cres *) + + (* if cres is pure or ghost, we augment it with a return + i.e., in the case where the head f is a pure or ghost function, + treat the application as (e e1 e2 .. en) as + f <-- e; + x1 <-- e1; ... + xn <-- en; + return (f x1 ... xn) + 1. The return at the end enhances f's result type with an equality + e.g., if (f : xs -> Tot t) + the type of the application becomes + Pure t (ensures (fun y -> y = f x1 ...xn)) + 2. It's VERY important that the return is inserted using the bound names x1...xn. + Previously, in case e1..en were pure, we were inserting + Pure t (ensures (fun y -> y = f e1 ...en)) + But this leads to a massive blow up in the size of generated VCs (cf issue #971) + arg_rets below are those xn...x1 bound variables + *) + let cres, inserted_return_in_cres = + let head_is_pure_and_some_arg_is_effectful = + TcComm.is_pure_or_ghost_lcomp chead + && (BU.for_some (fun (_, _, lc) -> not (TcComm.is_pure_or_ghost_lcomp lc) + || TcUtil.should_not_inline_lc lc) + arg_comps_rev) + in + let term = S.mk_Tm_app head (List.rev arg_rets_rev) head.pos in + if TcComm.is_pure_or_ghost_lcomp cres + && (head_is_pure_and_some_arg_is_effectful) + // || Option.isSome (Env.expected_typ env)) + then let _ = if Debug.extreme () then BU.print1 "(a) Monadic app: Return inserted in monadic application: %s\n" (show term) in + TcUtil.maybe_assume_result_eq_pure_term env term cres, true + else let _ = if Debug.extreme () then BU.print1 "(a) Monadic app: No return inserted in monadic application: %s\n" (show term) in + cres, false + in + + (* 1. We compute the final computation type comp *) + + // + //AR: 01/05/2022: A caveat with Layered Effects: + // We may have inserted a return in the cres, where the return + // mentions names from arg_rets_rev + // This means that cres now contains names that are not closed in + // env (env is the top-level env of the application node) + // The code below computed `bind`, which uses unification + // for layered effects + // Since unification is strict about uvar solutions being closed + // in the ctx uvar env, we need to make sure that when we call bind + // the computation types are closed in the environment + // Meaning: add names from arg_rets_rev + // + // Now what is arg_rets_rev: it is bv names for explicit args, and + // Tm_uvar for implicits that are not specified + // So we need to filter names from arg_rets_rev + // + // (Note: The implicits in Tm_uvar are created in the top env, + // therefore it should be ok to have the solutions of those uvars + // appear in the computation types, those should still be closed + // in the env) + // + + let comp = + let arg_rets_names_opt = + arg_rets_rev |> List.rev + |> List.map (fun (t, _) -> + match (SS.compress t).n with + | Tm_name bv -> bv |> Some + | _ -> None) in + + let push_option_names_to_env = + List.fold_left (fun env name_opt -> + name_opt |> BU.map_option (Env.push_bv env) + |> BU.dflt env) in + + //Bind arguments + let _, comp = + List.fold_left + (fun (i, out_c) ((e, q), x, c) -> + if Debug.extreme () then + BU.print3 "(b) Monadic app: Binding argument %s : %s of type (%s)\n" + (match x with | None -> "_" + | Some x -> show x) + (show e) + (TcComm.lcomp_to_string c); + // + //Push first (List.length arg_rets_names_opt - i) names in the env + // + let env = + // add arg_rets_names to env only if needed + // extra names in the env interfere with flex-flex queries in Rel, + // as they may result in uvar restrictions etc. + if inserted_return_in_cres + then push_option_names_to_env env + (List.splitAt (List.length arg_rets_names_opt - i) arg_rets_names_opt + |> fst) + else env in + if TcComm.is_pure_or_ghost_lcomp c + then i+1,TcUtil.bind e.pos env (Some e) c (x, out_c) + else i+1,TcUtil.bind e.pos env None c (x, out_c)) + (1, cres) + arg_comps_rev in + + //Bind head + //Push all arg ret names in the env + let env = push_option_names_to_env env arg_rets_names_opt in + if Debug.extreme () + then BU.print2 + "(c) Monadic app: Binding head %s, chead: %s\n" + (show head) + (TcComm.lcomp_to_string chead); + if TcComm.is_pure_or_ghost_lcomp chead + then TcUtil.bind head.pos env (Some head) chead (None, comp) + else TcUtil.bind head.pos env None chead (None, comp) in + + (* TODO : This is a really syntactic criterion to check if we can evaluate *) + (* applications left-to-right, can we do better ? *) + let shortcuts_evaluation_order = + match (SS.compress head).n with + | Tm_fvar fv -> + S.fv_eq_lid fv Parser.Const.op_And || + S.fv_eq_lid fv Parser.Const.op_Or + | _ -> false + in + + let app = + if shortcuts_evaluation_order then + (* Note: this case is only reachable in --lax mode. + In non-lax code, shortcut evaluation order is handled by + check_short_circuit_args. See, roughly, line 511, case Tm_app + *) + (* If the head is shortcutting we cannot hoist its arguments *) + (* Leaving it `as is` is a little dubious, it would fail whenever we try to reify it *) + let args = List.fold_left (fun args (arg, _, _) -> arg::args) [] arg_comps_rev in + let app = mk_Tm_app head args r in + let app = TcUtil.maybe_lift env app cres.eff_name comp.eff_name comp.res_typ in + TcUtil.maybe_monadic env app comp.eff_name comp.res_typ + + else + (* 2. For each monadic argument (including the head of the application) we introduce *) + (* a fresh variable and lift the actual argument to comp. *) + let lifted_args, head, args = + let map_fun ((e, q), _ , c) = + if Debug.extreme () then + BU.print2 "For arg e=(%s) c=(%s)... " (show e) (TcComm.lcomp_to_string c); + if TcComm.is_pure_or_ghost_lcomp c + then begin + if Debug.extreme () then + BU.print_string "... not lifting\n"; + None, (e, q) + end else begin + //this argument is effectful, warn if the function would be erased + //special casing for ignore, may be use an attribute instead? + let warn_effectful_args = + (TcUtil.must_erase_for_extraction env chead.res_typ) && + (not (match (U.un_uinst head).n with + | Tm_fvar fv -> S.fv_eq_lid fv (Parser.Const.psconst "ignore") + | _ -> true)) + in + if warn_effectful_args then + Errors.log_issue e Errors.Warning_EffectfulArgumentToErasedFunction + (format3 "Effectful argument %s (%s) to erased function %s, consider let binding it" + (show e) (show c.eff_name) (show head)); + if Debug.extreme () then + BU.print_string "... lifting!\n"; + let x = S.new_bv None c.res_typ in + let e = TcUtil.maybe_lift env e c.eff_name comp.eff_name c.res_typ in + Some (x, c.eff_name, c.res_typ, e), (S.bv_to_name x, q) + end + in + let lifted_args, reverse_args = + List.split <| List.map map_fun ((as_arg head, None, chead)::arg_comps_rev) + in + lifted_args, fst (List.hd reverse_args), List.rev (List.tl reverse_args) + in + + (* 3. We apply the (non-monadic) head to the non-monadic arguments, lift the *) + (* result to comp and then bind each monadic arguments to close over the *) + (* variables introduces at step 2. *) + let app = mk_Tm_app head args r in + let app = TcUtil.maybe_lift env app cres.eff_name comp.eff_name comp.res_typ in + let app = TcUtil.maybe_monadic env app comp.eff_name comp.res_typ in + let bind_lifted_args e = function + | None -> e + | Some (x, m, t, e1) -> + let lb = U.mk_letbinding (Inl x) [] t m e1 [] e1.pos in + let letbinding = mk (Tm_let {lbs=(false, [lb]); body=SS.close [S.mk_binder x] e}) e.pos in + mk (Tm_meta {tm=letbinding; meta=Meta_monadic(m, comp.res_typ)}) e.pos + in + List.fold_left bind_lifted_args app lifted_args + in + + (* Each conjunct in g is already labeled *) + //NS: Maybe redundant strengthen + // let comp, g = comp, guard in + let comp, g = TcUtil.strengthen_precondition None env app comp guard in + if Debug.extreme () then BU.print2 "(d) Monadic app: type of app\n\t(%s)\n\t: %s\n" + (show app) + (TcComm.lcomp_to_string comp); + app, comp, g + in + + let rec tc_args (head_info:(term & comp & guard_t & comp)) //the head of the application, its comp and guard, returning a bs -> cres + (subst, (* substituting actuals for formals seen so far, when actual is pure *) + outargs, (* type-checked actual arguments, so far; in reverse order *) + arg_rets,(* The results of each argument at the logic level, in reverse order *) + g, (* conjoined guard formula for all the actuals *) + fvs) (* unsubstituted formals, to check that they do not occur free elsewhere in the type of f *) + bs (* formal parameters *) + args (* remaining actual arguments *) : (term & lcomp & guard_t) = + + let instantiate_one_and_go b rest_bs args = + (* We compute a range by combining the range of the head + * and the last argument we checked (if any). This is such that + * if we instantiate an implicit for `f ()` (of type `#x:a -> ...), + * we give it the range of `f ()` instead of just the range for `f`. + * See issue #2021. This is only for the use range, we take + * the def range from the head, so the 'see also' should still + * point to the definition of the head. *) + let r = match outargs with + | [] -> head.pos + | ((t, _), _, _)::_ -> + Range.range_of_rng (Range.def_range head.pos) + (Range.union_rng (Range.use_range head.pos) + (Range.use_range t.pos)) + in + let b = SS.subst_binder subst b in + let tm, ty, aq, g' = TcUtil.instantiate_one_binder env r b in + let ty, g_ex = check_no_escape (Some head) env fvs ty in + let guard = g ++ g' ++ g_ex in + let arg = tm, aq in + let subst = NT(b.binder_bv, tm)::subst in + tc_args head_info (subst, (arg, None, S.mk_Total ty |> TcComm.lcomp_of_comp)::outargs, arg::arg_rets, guard, fvs) rest_bs args + in + + match bs, args with + (* Expect an implicit but user provided a concrete argument, instantiate the implicit. *) + | ({binder_bv=x;binder_qual=Some (Implicit _)})::rest, (_, None)::_ + | ({binder_bv=x;binder_qual=Some (Meta _)})::rest, (_, None)::_ + -> + instantiate_one_and_go (List.hd bs) rest args + + (* User provided a _ for a meta arg, keep the meta for the unknown. *) + | ({binder_bv=x;binder_qual=Some (Meta tau);binder_attrs=b_attrs})::rest, + ({n = Tm_unknown}, Some {aqual_implicit=true})::rest' -> + instantiate_one_and_go (List.hd bs) rest rest' (* NB: rest' instead of args, we consume the _ *) + + | ({binder_bv=x;binder_qual=bqual;binder_attrs=b_attrs})::rest, (e, aq)::rest' -> (* a concrete argument *) + let aq = check_expected_aqual_for_binder aq (List.hd bs) e.pos in + let targ = SS.subst subst x.sort in + let bqual = SS.subst_bqual subst bqual in + let x = {x with sort=targ} in + if Debug.extreme () + then BU.print5 "\tFormal is %s : %s\tType of arg %s (after subst %s) = %s\n" + (show x) (show x.sort) (show e) (show subst) (show targ); + let targ, g_ex = check_no_escape (Some head) env fvs targ in + let env = Env.set_expected_typ_maybe_eq env targ (is_eq bqual) in + if Debug.high () + then BU.print4 "Checking arg (%s) %s at type %s with use_eq:%s\n" + (tag_of e) + (show e) + (show targ) + (bqual |> is_eq |> string_of_bool); + let e, c, g_e = tc_term env e in + let g = g_ex ++ g ++ g_e in +// if debug env Options.High then BU.print2 "Guard on this arg is %s;\naccumulated guard is %s\n" (guard_to_string env g_e) (guard_to_string env g); + let arg = e, aq in + let xterm = S.bv_to_name x, aq in //AR: fix for #1123, we were dropping the qualifiers + if TcComm.is_tot_or_gtot_lcomp c //early in prims, Tot and GTot are primitive, not defined in terms of Pure/Ghost yet + || TcUtil.is_pure_or_ghost_effect env c.eff_name + then let subst = maybe_extend_subst subst (List.hd bs) e in + tc_args head_info (subst, (arg, Some x, c)::outargs, xterm::arg_rets, g, fvs) rest rest' + else tc_args head_info (subst, (arg, Some x, c)::outargs, xterm::arg_rets, g, x::fvs) rest rest' + + | _, [] -> (* no more args; full or partial application *) + monadic_application head_info subst outargs arg_rets g fvs bs + + | [], arg::_ -> (* too many args, except maybe c returns a function *) + let head, chead, ghead = monadic_application head_info subst outargs arg_rets g fvs [] in + let chead, ghead = TcComm.lcomp_comp chead |> (fun (c, g) -> c, ghead ++ g) in + let rec aux norm solve ghead tres = + let tres = SS.compress tres |> U.unrefine |> U.unmeta_safe in + match tres.n with + | Tm_arrow {bs; comp=cres'} -> + let bs, cres' = SS.open_comp bs cres' in + let head_info = (head, chead, ghead, cres') in + if Debug.low () + then FStarC.Errors.log_issue tres + Errors.Warning_RedundantExplicitCurrying "Potentially redundant explicit currying of a function type"; + tc_args head_info ([], [], [], mzero, []) bs args + | _ when not norm -> + let rec norm_tres (tres:term) :term = + let tres = tres |> N.unfold_whnf env |> U.unascribe in + match (SS.compress tres).n with + | Tm_refine {b={ sort = tres }} -> norm_tres tres + | _ -> tres + in + aux true solve ghead (norm_tres tres) + + | _ when not solve -> + let ghead = Rel.solve_deferred_constraints env ghead in + aux norm true ghead tres + + | _ -> + let open FStarC.Class.PP in + let open FStarC.Pprint in + raise_error (argpos arg) Fatal_ToManyArgumentToFunction [ + prefix 4 1 (text "Too many arguments to function of type") (pp thead); + text "Got" ^/^ pp (n_args <: int) ^/^ text "arguments"; + prefix 4 1 (text "Remaining type is") (pp tres); + ] + in + aux false false ghead (U.comp_result chead) + in //end tc_args + + let rec check_function_app tf guard = + let tf = N.unfold_whnf env tf in + match (U.unmeta tf).n with + | Tm_uvar _ + | Tm_app {hd={n=Tm_uvar _}} -> + let bs, guard = + List.fold_right + (fun _ (bs, guard) -> + let t, _, g = TcUtil.new_implicit_var "formal parameter" tf.pos env (U.type_u () |> fst) false in + null_binder t::bs, g ++ guard) + args + ([], guard) + in + let cres, guard = + let t, _, g = TcUtil.new_implicit_var "result type" tf.pos env (U.type_u() |> fst) false in + if Options.ml_ish () + then U.ml_comp t r, guard ++ g + else S.mk_Total t, guard ++ g + in + let bs_cres = U.arrow bs cres in + if Debug.extreme () + then BU.print3 "Forcing the type of %s from %s to %s\n" + (show head) + (show tf) + (show bs_cres); + //Yes, force only the guard for this equation; the other uvars will not be solved yet + let g = Rel.solve_deferred_constraints env (Rel.teq env tf bs_cres) in + check_function_app bs_cres (g ++ guard) + + | Tm_arrow {bs; comp=c} -> + let bs, c = SS.open_comp bs c in + let head_info = head, chead, ghead, c in + if Debug.extreme () + then BU.print4 "######tc_args of head %s @ %s with formals=%s and result type=%s\n" + (show head) + (show tf) + (show bs) + (show c); + tc_args head_info ([], [], [], guard, []) bs args + + | Tm_refine {b=bv} -> + check_function_app bv.sort guard + + | Tm_ascribed {tm=t} -> + check_function_app t guard + + | _ -> + Err.expected_function_typ env head.pos tf + in + + check_function_app thead mzero + +(******************************************************************************) +(* SPECIAL CASE OF CHECKING APPLICATIONS: *) +(* head symbol is one of &&, ||, /\, \/, ==> *) +(* ALL OF THEM HAVE A LOGICAL SPEC THAT IS BIASED L-to-R, *) +(* aka they are short-circuiting *) +(******************************************************************************) +and check_short_circuit_args env head chead g_head args expected_topt : term & lcomp & guard_t = + let r = Env.get_range env in + let tf = SS.compress (U.comp_result chead) in + match tf.n with + | Tm_arrow {bs; comp=c} when (U.is_total_comp c && List.length bs=List.length args) -> + let res_t = U.comp_result c in + let args, guard, ghost = + List.fold_left2 + (fun (seen, guard, ghost) (e, aq) b -> + let aq = check_expected_aqual_for_binder aq b e.pos in + let e, c, g = tc_check_tot_or_gtot_term env e b.binder_bv.sort + (Some "arguments to short circuiting operators must be pure or ghost") + in //NS: this forbids stuff like !x && y, maybe that's ok + let short = TcUtil.short_circuit head seen in + let g = Env.imp_guard (Env.guard_of_guard_formula short) g in + let ghost = ghost + || (not (TcComm.is_total_lcomp c) + && not (TcUtil.is_pure_effect env c.eff_name)) in + seen@[e,aq], guard ++ g, ghost) + ([], g_head, false) + args + bs + in + let e = mk_Tm_app head args r in + let c = if ghost then S.mk_GTotal res_t |> TcComm.lcomp_of_comp else TcComm.lcomp_of_comp c in + //NS: maybe redundant strengthen + // let c, g = c, guard in + let c, g = TcUtil.strengthen_precondition None env e c guard in + e, c, g + + | _ -> //fallback + check_application_args env head chead g_head args expected_topt + +and tc_pat env (pat_t:typ) (p0:pat) : + pat (* the type-checked, fully decorated pattern *) + & list bv (* all its bound variables, used for closing the type of the branch term *) + & list term (* for each bv in the returned bv list, this list contains a Tm_abs, + that when applied to the scrutinee, returns an expression for bv in terms of + projectors. for example, say scrutinee is of type list (option int), and the + pattern is (Some hd)::_, then hd will be returned in the bv list, and the + list term would contain syntax for: + fun (x:list (option int)) -> Some?.v (Cons?.hd x) + in the case of layered effects, we close over the pattern variables in the + branch VC by substituting them with these expressions *) + & Env.env (* the environment extended with all the binders *) + & term (* terms corresponding to the pattern *) + & term (* the same term in normal form *) + & guard_t (* unresolved implicits *) + & bool (* true if the pattern matches an erasable type *) + = + let fail : string -> 'a = fun msg -> + raise_error p0.p Errors.Fatal_MismatchedPatternType msg + in + let expected_pat_typ env pos scrutinee_t : typ = + let rec aux norm t = + let t = U.unrefine t in + let head, args = U.head_and_args t in + match (SS.compress head).n with + | Tm_uinst ({n=Tm_fvar f}, us) -> unfold_once t f us args + | Tm_fvar f -> unfold_once t f [] args + | _ -> + if norm then t + else aux true (N.normalize [Env.HNF; Env.Unmeta; Env.Unascribe; Env.UnfoldUntil delta_constant] env t) + and unfold_once t f us args = + if Env.is_type_constructor env f.fv_name.v + then t + else match Env.lookup_definition [Env.Unfold delta_constant] env f.fv_name.v with + | None -> t + | Some head_def_ts -> + let _, head_def = Env.inst_tscheme_with head_def_ts us in + let t' = S.mk_Tm_app head_def args t.pos in + let t' = N.normalize [Env.Beta; Env.Iota] env t' in + aux false t' + in + aux false (N.normalize [Env.Beta;Env.Iota] env scrutinee_t) + in + let pat_typ_ok env pat_t scrutinee_t : guard_t = + if !dbg_Patterns + then BU.print2 "$$$$$$$$$$$$pat_typ_ok? %s vs. %s\n" + (show pat_t) (show scrutinee_t); + def_check_scoped pat_t.pos "pat_typ_ok.pat_t.entry" env pat_t; + let fail : string -> 'a = fun msg_str -> + let msg = + if msg_str = "" then [] else [Errors.text msg_str] + in + let msg = + let open FStarC.Pprint in + let open FStarC.Class.PP in + let open FStarC.Errors.Msg in + ( + prefix 2 1 (text "Type of pattern") (pp pat_t) ^/^ + prefix 2 1 (text "does not match type of scrutinee") (pp scrutinee_t) + ) :: msg + in + raise_error p0.p Errors.Fatal_MismatchedPatternType msg + in + let head_s, args_s = U.head_and_args scrutinee_t in + let pat_t = N.normalize [Env.Beta] env pat_t in + match U.un_uinst head_s with + | {n=Tm_fvar _} -> + let head_p, args_p = U.head_and_args pat_t in + if Rel.teq_nosmt_force env head_p head_s + then match (U.un_uinst head_p).n with + | Tm_fvar f -> + if not <| Env.is_type_constructor env (S.lid_of_fv f) + then fail "Pattern matching a non-inductive type"; + + if List.length args_p <> List.length args_s + then fail ""; + + let params_p, params_s = + match Env.num_inductive_ty_params env (S.lid_of_fv f) with + | None -> + args_p, args_s + | Some n -> + let params_p, _ = BU.first_N n args_p in + let params_s, _ = BU.first_N n args_s in + params_p, params_s + in + + List.fold_left2 + (fun out (p, _) (s, _) -> + match Rel.teq_nosmt env p s with + | None -> + fail (BU.format2 "Parameter %s <> Parameter %s" + (show p) + (show s)) + | Some g -> + let g = Rel.discharge_guard_no_smt env g in + g ++ out) + mzero + params_p + params_s + + | _ -> fail "Pattern matching a non-inductive type" + else fail (BU.format2 "Head mismatch %s vs %s" + (show head_p) + (show head_s)) + + | _ -> + match Rel.teq_nosmt env pat_t scrutinee_t with + | None -> fail "" + | Some g -> + let g = Rel.discharge_guard_no_smt env g in + g + in + let type_of_simple_pat env (e:term) : term & typ & list bv & guard_t & bool = + let head, args = U.head_and_args e in + match head.n with + | Tm_uinst ({n=Tm_fvar _}, _) + | Tm_fvar _ -> + let head, (us, t_f) = + match head.n with + | Tm_uinst (head, us) -> + let Tm_fvar f = head.n in + let res = Env.try_lookup_and_inst_lid env us f.fv_name.v in + begin + match res with + | Some (t, _) + when Env.is_datacon env f.fv_name.v -> + head, (us, t) + + | _ -> + fail (BU.format1 "Could not find constructor: %s" + (Ident.string_of_lid f.fv_name.v)) + end + + | Tm_fvar f -> + head, + Env.lookup_datacon env f.fv_name.v + in + let formals, t = U.arrow_formals t_f in + //Data constructors are marked with the "erasable" attribute + //if their types are; matching on this constructor incurs + //a ghost effect + let erasable = Env.non_informative env t in + if List.length formals <> List.length args + then fail "Pattern is not a fully-applied data constructor"; + let rec aux (subst, args_out, bvs, guard) formals args = + match formals, args with + | [], [] -> + let head = S.mk_Tm_uinst head us in + let pat_e = S.mk_Tm_app head args_out e.pos in + pat_e, SS.subst subst t, bvs, guard, erasable + | ({binder_bv=f})::formals, (a, imp_a)::args -> + let t_f = SS.subst subst f.sort in + let a, subst, bvs, g = + match (SS.compress a).n with + | Tm_name x -> + let x = {x with sort=t_f} in + let a = S.bv_to_name x in + let subst = NT(f, a)::subst in + (a, imp_a), subst, bvs@[x], mzero + + | Tm_uvar _ -> + let use_eq = true in + let env = Env.set_expected_typ_maybe_eq env t_f use_eq in + // + //AR: 03/03: When typechecking these uvar args, + // we don't want to solve the deferred constraints here, + // since solving them here may mean solving flex-flex equations + // among them + // + // Whereas if we wait for unification of these dot pattern uvars + // with the type of the scrutinee (in pat_typ_ok), we have a good + // chance of solving these uvars as flex-rigid equations + // + // Therefore, ask tc_tot to not solve deferred, and return the + // guard as is + // + let a, _, g = tc_tot_or_gtot_term_maybe_solve_deferred + env + a + None + false in //don't solve the deferred constraints in the guard + let subst = NT(f, a)::subst in + (a, imp_a), subst, bvs, g + + | _ -> + // + // AR: 09/29: + // + // Before we carried on dot patterns solutions from phase1 to phase2, + // the arguments args here could just be names (from Pat_var) + // or uvars (from Pat_dot_term) + // + // But now they can be arbitrary terms for Pat_dot_term, + // since in phase1, Pat_dot_term could be solved with + // arbitrary term + // + // If not a name or uvar, we typecheck the term, + // and add it to args_out + // + let a = SS.subst subst a in + let env = Env.set_expected_typ env t_f in + let a, _, g = tc_tot_or_gtot_term env a in + let subst = NT(f, a)::subst in + (a, imp_a), subst, bvs, g + in + aux (subst, args_out@[a], bvs, g ++ guard) formals args + | _ -> fail "Not a fully applied pattern" + in + aux ([], [], [], mzero) formals args + | _ -> + fail "Not a simple pattern" + in + (* + * This function checks the nested pattern and + * builds the list bv and corresponding list term (see the comment at the signature of tc_pat) + * by checking the pattern "inside out" + * + * For example, taking the scrutinee of type list (option int), and the pattern as Cons (Some hd) _, + * the recursive call first typechecks hd, and returns the term as t1 = Prims.id + * Then we come to Some hd, and the term becomes t2 = (fun (x:option int). t1 (Some?.v x)) + * Then we come to Cons (Some hd), and the term becomes t3 = (fun (x:list (option int)). t2 (Cons?.hd x)) + * After a bit of normalization, this is same as (fun (x:list (option int)). Some?.v (Cons?.hd x)) + *) + let rec check_nested_pattern env (p:pat) (t:typ) + : list bv + & list term + & term + & pat + & guard_t + & bool = + if !dbg_Patterns + then BU.print2 "Checking nested pattern %s at type %s\n" (show p) (show t); + + let id t = mk_Tm_app + (S.fvar Const.id_lid None) + [S.iarg t] + t.pos + in + + (* + * Taking the example of scrutinee of type list (option int), and pattern as Cons (Some hd), _, + * this function will be called twice: + * (a) disc as Some?.v and inner_t as Prims.id (say it returns t1) + * (b) disc as Cons?.hd and inner_t as t1 + * It builds the term as mentioned above in the comment at check_nested_pattern + *) + let mk_disc_t (disc:term) (inner_t:term) : term = + let x_b = S.gen_bv "x" None t |> S.mk_binder in + // + //AR: 05/02/2022: Try to provide implicit type arguments to the projector, + // if we can't then (lax) typechecking later will infer them + // + let ty_args = + let hd, args = U.head_and_args t in + match (hd |> SS.compress |> U.un_uinst).n with + | Tm_fvar fv -> + fv |> lid_of_fv |> Env.num_inductive_ty_params env + |> (fun nopt -> + BU.dflt [] (nopt |> BU.map_option (fun n -> + if List.length args >= n + then args |> List.splitAt n |> fst + else []))) + |> List.map (fun (t, _) -> S.iarg t) + | _ -> [] in + let tm = S.mk_Tm_app + disc + (ty_args@[x_b.binder_bv |> S.bv_to_name |> S.as_arg]) + Range.dummyRange in + let tm = S.mk_Tm_app + inner_t + [tm |> S.as_arg] Range.dummyRange in + U.abs [x_b] tm None in + + match p.v with + | Pat_dot_term _ -> + failwith (BU.format1 "Impossible: Expected an undecorated pattern, got %s" (show p)) + + | Pat_var x -> + let x = {x with sort=t} in + [x], + [id t], + S.bv_to_name x, + {p with v=Pat_var x}, + mzero, + false + + | Pat_constant c -> + (* + * AR: enforcing decidable equality, since the branch guards are in boolean now + * so whereas earlier we did scrutinee == c, + * we now have scrutinee = c, so we need decidable equality on c + *) + (match c with + | Const_unit | Const_bool _ | Const_int _ | Const_char _ | Const_string _ -> () + | _ -> + fail (BU.format1 + "Pattern matching a constant that does not have decidable equality: %s" + (show c))); + let _, e_c, _, _ = PatternUtils.pat_as_exp false false env p in + let e_c, lc, g = tc_tot_or_gtot_term env e_c in + Rel.force_trivial_guard env g; + let expected_t = expected_pat_typ env p0.p t in + if not (Rel.teq_nosmt_force env lc.res_typ expected_t) + then fail (BU.format2 "Type of pattern (%s) does not match type of scrutinee (%s)" + (show lc.res_typ) + (show expected_t)); + [], + [], + e_c, + p, + mzero, + false + + | Pat_cons({fv_qual = Some (Unresolved_constructor uc)}, us_opt, sub_pats) -> + let rdc, _, constructor_fv = TcUtil.find_record_or_dc_from_typ env (Some t) uc p.p in + let f_sub_pats = List.zip uc.uc_fields sub_pats in + let sub_pats = + TcUtil.make_record_fields_in_order env uc (Some (Inl t)) rdc f_sub_pats + (fun _ -> + let x = S.new_bv None S.tun in + Some (S.withinfo (Pat_var x) p.p, false)) + p.p + in + let p = { p with v=Pat_cons(constructor_fv, us_opt, sub_pats) } in + let p = PatternUtils.elaborate_pat env p in + check_nested_pattern env p t + + | Pat_cons(fv, us_opt, sub_pats) -> + let simple_pat = + let simple_sub_pats = + List.map (fun (p, b) -> + match p.v with + | Pat_dot_term _ -> p, b + | _ -> S.withinfo (Pat_var (S.new_bv (Some p.p) S.tun)) p.p, b) + sub_pats in + {p with v = Pat_cons (fv, us_opt, simple_sub_pats)} + in + let sub_pats = + sub_pats + |> List.filter (fun (x, _) -> + match x.v with + | Pat_dot_term _ -> false + | _ -> true) + in + let simple_bvs_pat, simple_pat_e, g0, simple_pat_elab = + PatternUtils.pat_as_exp false false env simple_pat + in + // + // simple_bvs_pat are the Pat_vars in a Pat_cons + // + // Number of simple_bvs should be same as the number of simple_pats + // + if List.length simple_bvs_pat <> List.length sub_pats + then failwith (BU.format4 "(%s) Impossible: pattern bvar mismatch: %s; expected %s sub pats; got %s" + (Range.string_of_range p.p) + (show simple_pat) + (BU.string_of_int (List.length sub_pats)) + (BU.string_of_int (List.length simple_bvs_pat))); + let simple_pat_e, simple_bvs, g1, erasable = + // + // guard is the typechecking guard + // it contains some deferred constraints for dot pattern uvars + // we will solve them after pat_typ_ok + // + let simple_pat_e, simple_pat_t, simple_bvs, guard, erasable = + type_of_simple_pat env simple_pat_e + in + + // + // AR: 09/29: + // + // A note about simple_bvs: + // + // Before we started to reuse Pat_dot_term solutions from phase1 to phase2, + // the simple_bvs returned by typechecking of simple pat would be + // same as the simple_bvs_pat that we got from pat_as_exp, + // since Pat_dot_term were always elaborated to uvars, so the only names were + // those coming from Pat_vars (a simple pat is a Pat_cons with sub pats as + // Pat_dot_term or Pat_var) + // + // But now, a Pat_dot_term solution could itself be a name, + // and typechecking the simple pat returns it in simple_bvs + // + // Noting that all the Pat_dot_terms occur at the beginning, + // we take the suffix of simple_bvs with length same as + // simple_bvs_pat + // + let simple_bvs = + simple_bvs + |> BU.first_N (List.length simple_bvs - List.length simple_bvs_pat) + |> snd in + + let g' = pat_typ_ok (Env.push_bvs env simple_bvs) simple_pat_t (expected_pat_typ env p0.p t) in + // + // Now solve guard + // guard may have logical payload coming from typechecking of the + // Pat_dot_term solutions computed in phase 1 + // Here we only want to solve the implicits, + // folding in the logical payload in the rest of the VC + // + let guard = + let fml = Env.guard_form guard in + let guard = + Rel.discharge_guard_no_smt env {guard with guard_f = Trivial} in + {guard with guard_f=fml} in + // And combine with g' (the guard from pat_typ_ok) + let guard = guard ++ g' in + if !dbg_Patterns + then BU.print3 "$$$$$$$$$$$$Checked simple pattern %s at type %s with bvs=%s\n" + (show simple_pat_e) + (show simple_pat_t) + (List.map (fun x -> "(" ^ show x ^ " : " ^ show x.sort ^ ")") simple_bvs + |> String.concat " "); + simple_pat_e, simple_bvs, guard, erasable + in + let bvs, tms, checked_sub_pats, subst, g, erasable, _ = + // + // Invariant: g must be well-formed in the top-level env + // + List.fold_left2 + (fun (bvs, tms, pats, subst, g, erasable, i) (p, b) x -> + let expected_t = SS.subst subst x.sort in + let env = Env.push_bvs env bvs in + let bvs_p, tms_p, e_p, p, g', erasable_p = check_nested_pattern env p expected_t in + let g' = Env.close_guard env (bvs |> List.map S.mk_binder) g' in + let tms_p = + let disc_tm = TcUtil.get_field_projector_name env (S.lid_of_fv fv) i in + tms_p |> List.map (mk_disc_t (S.fvar disc_tm None)) in + bvs@bvs_p, tms@tms_p, pats@[(p,b)], NT(x, e_p)::subst, g ++ g', erasable || erasable_p, i+1) + ([], [], [], [], g0 ++ g1, erasable, 0) + sub_pats + simple_bvs + in + let pat_e = SS.subst subst simple_pat_e in + let reconstruct_nested_pat pat = + let rec aux simple_pats bvs sub_pats = + match simple_pats with + | [] -> [] + | (hd, b)::simple_pats -> + match hd.v with + | Pat_dot_term eopt -> + let eopt = BU.map_option (SS.subst subst) eopt in + let hd = {hd with v=Pat_dot_term eopt} in + (hd, b) :: aux simple_pats bvs sub_pats + | Pat_var x -> + begin + match bvs, sub_pats with + | x'::bvs, (hd, _)::sub_pats + when S.bv_eq x x' -> + (hd, b) :: aux simple_pats bvs sub_pats + + | _ -> + failwith "Impossible: simple pat variable mismatch" + end + | _ -> failwith "Impossible: expected a simple pattern" + in + let us = + let hd, _ = U.head_and_args simple_pat_e in + match (SS.compress hd).n with + | Tm_fvar _ -> [] + | Tm_uinst(_, us) -> us + | _ -> failwith "Impossible: tc_pat: pattern head not fvar or uinst" + in + match pat.v with + | Pat_cons(fv, _, simple_pats) -> + let nested_pats = aux simple_pats simple_bvs checked_sub_pats in + {pat with v=Pat_cons(fv, Some us, nested_pats)} + | _ -> failwith "Impossible: tc_pat: pat.v expected Pat_cons" + in + bvs, + tms, + pat_e, + reconstruct_nested_pat simple_pat_elab, + g, + erasable + in + if !dbg_Patterns + then BU.print1 "Checking pattern: %s\n" (show p0); + let bvs, tms, pat_e, pat, g, erasable = + check_nested_pattern + (Env.clear_expected_typ env |> fst) + (PatternUtils.elaborate_pat env p0) + (expected_pat_typ env p0.p pat_t) + in + let extended_env = Env.push_bvs env bvs in + let pat_e_norm = N.normalize [Env.Beta] extended_env pat_e in + if !dbg_Patterns + then BU.print2 "Done checking pattern %s as expression %s\n" + (show pat) + (show pat_e); + pat, bvs, tms, extended_env, pat_e, pat_e_norm, g, erasable + + +(********************************************************************************************************************) +(* Type-checking a pattern-matching branch *) +(* scrutinee_expr is the scrutinee expression, used when we also have a returns annotation *) +(* the pattern, when_clause and branch are closed *) +(* scrutinee is the logical name of the expression being matched; it is not in scope in the branch *) +(* but it is in scope for the VC of the branch *) +(* env does not contain scrutinee, or any of the pattern-bound variables *) +(* the returned terms are well-formed in an environment extended with the scrutinee only *) + +(* + * ret_opt is the optional return annotation on the match (NB: if any, the ascription has been opened) + * if this is set, then ascribe it on the branches for typechecking + * but unascribe it before returning to the caller + *) +(********************************************************************************************************************) +and tc_eqn (scrutinee:bv) (env:Env.env) (ret_opt : option match_returns_ascription) (branch:S.branch) + : (pat & option term & term) (* checked branch *) + & formula (* the guard condition for taking this branch, + used by the caller for the exhaustiveness check *) + & lident (* effect label of the branch lcomp *) + & option (list cflag) (* flags for the branch lcomp, + None if typechecked with a returns comp annotation *) + & option (bool -> lcomp) (* computation type of the branch, with or without a "return" equation, + None if typechecked with a returns comp annotation *) + & guard_t (* guard for well-typedness of the branch *) + & bool (* true if the pattern matches an erasable type *) + = + let pattern, when_clause, branch_exp = SS.open_branch branch in + let cpat, _, cbr = branch in + + let pat_t = scrutinee.sort in + let scrutinee_tm = S.bv_to_name scrutinee in + let scrutinee_env, _ = Env.push_bv env scrutinee |> Env.clear_expected_typ in + + (* 1. Check the pattern *) + (* pat_bvs are the pattern variables, and pat_bv_tms are syntax for a single argument functions that *) + (* when applied to the scrutinee return an expression for the bv in terms of projectors *) + let pattern, pat_bvs, pat_bv_tms, pat_env, pat_exp, norm_pat_exp, guard_pat, erasable = + tc_pat (Env.push_bv env scrutinee) pat_t pattern + in + + if Debug.extreme () then + BU.print3 "tc_eqn: typechecked pattern %s with bvs %s and pat_bv_tms=%s\n" + (show pattern) (show pat_bvs) + (show pat_bv_tms); + + (* 2. Check the when clause *) + let when_clause, g_when = match when_clause with + | None -> None, mzero + | Some e -> + if Env.should_verify env + then raise_error e + Errors.Fatal_WhenClauseNotSupported + "When clauses are not yet supported in --verify mode; they will be some day" + // let e, c, g = no_logical_guard pat_env <| tc_total_exp (Env.set_expected_typ pat_env TcUtil.t_bool) e in + // Some e, g + else let e, c, g = tc_term (Env.set_expected_typ pat_env t_bool) e in + Some e, g in + + (* 3. Check the branch *) + let branch_exp, c, g_branch = + let branch_exp = //ascribe with the return annotation, if it exists + match ret_opt with + | None -> branch_exp + | Some (b, asc) -> + asc + |> SS.subst_ascription [NT (b.binder_bv, norm_pat_exp)] + |> U.ascribe branch_exp in + let branch_exp, c, g_branch = tc_term pat_env branch_exp in + let branch_exp = //unascribe if we added ascription + match ret_opt with + | None -> branch_exp + | _ -> + match (SS.compress branch_exp).n with + | Tm_ascribed {tm=branch_exp} -> branch_exp + | _ -> failwith "Impossible (expected the match branch with an ascription)" in + branch_exp, c, g_branch in + + def_check_scoped cbr.pos "tc_eqn.1" pat_env g_branch; + + (* 4. Lift the when clause to a logical condition. *) + (* It is used in step 5 (a) below, and in step 6 (d) to build the branch guard *) + let when_condition = match when_clause with + | None -> None + | Some w -> Some <| U.mk_eq2 U_zero U.t_bool w U.exp_true_bool in + + + (* logically the same as step 5(a), *) + + + (* 5. Building the guard for this branch; *) + (* the caller assembles the guards for each branch into an exhaustiveness check. *) + (* *) + (* (a) Compute the branch guard for each arm of a disjunctive pattern. *) + (* expressed in terms for discriminators and projectors on sub-terms of scrutinee *) + (* for the benefit of the caller, who works in an environment without the pattern-bound vars *) + (* *) + (* (b) Type-check the condition computed in 5 (a) *) + (* *) + (* (c) Make a disjunctive formula out of 5 (b) for each arm of the pattern *) + (* *) + (* (d) Strengthen 5 (c) with the when condition, if there is one *) + + (* This used to be step 6 earlier (after weakening the branch VC with scrutinee equality with pattern etc.) *) + (* but we do it before that now, since for layered effects, we use this branch guard to weaken *) + + (* TODO: this seems very similar to constructing the terms for pattern variables in terms of scrutinee *) + (* and projectors. Can this be done in tc_pat too? That should save us repeated iterations on the pattern *) + + (* The branch guard is a boolean expression *) + + let branch_guard = + if not (Env.should_verify env) + then U.exp_true_bool + else (* 5 (a) *) + let rec build_branch_guard (scrutinee_tm:option term) (pattern:pat) pat_exp : list typ = + let discriminate scrutinee_tm f = + let is_induc, datacons = Env.datacons_of_typ env (Env.typ_of_datacon env f.v) in + (* Why the `not is_induc`? We may be checking an exception pattern. See issue #1535. *) + if not is_induc || List.length datacons > 1 + then + let discriminator = U.mk_discriminator f.v in + match Env.try_lookup_lid env discriminator with + | None -> [] // We don't use the discriminator if we are typechecking it + | _ -> + let disc = S.fvar discriminator None in + [mk_Tm_app disc [as_arg scrutinee_tm] scrutinee_tm.pos] + else [] + in + + let fail () = + failwith (BU.format3 "tc_eqn: Impossible (%s) %s (%s)" + (Range.string_of_range pat_exp.pos) + (show pat_exp) + (tag_of pat_exp)) in + + let rec head_constructor t = match t.n with + | Tm_fvar fv -> fv.fv_name + | Tm_uinst(t, _) -> head_constructor t + | _ -> fail () in + + let force_scrutinee () = + match scrutinee_tm with + | None -> failwith (BU.format2 "Impossible (%s): scrutinee of match is not defined %s" + (Range.string_of_range pattern.p) + (show pattern)) + | Some t -> t + in + let pat_exp = SS.compress pat_exp |> U.unmeta in + match pattern.v, pat_exp.n with + | _, Tm_name _ -> + [] //no guard for variables; they always match + + | _, Tm_constant Const_unit -> + [] //no guard for the unit pattern; it's a singleton + + | Pat_constant _c, Tm_constant c -> + + [U.mk_decidable_eq (tc_constant env pat_exp.pos c) (force_scrutinee ()) pat_exp] + + | Pat_constant (FStarC.Const.Const_int(_, Some _)), _ -> + //machine integer pattern, cf. #1572 + let _, t, _ = + let env, _ = Env.clear_expected_typ env in + env.typeof_tot_or_gtot_term env pat_exp true + in + [U.mk_decidable_eq t (force_scrutinee ()) pat_exp] + + | Pat_cons (_, _, []), Tm_uinst _ + | Pat_cons (_, _, []), Tm_fvar _ -> + //nullary pattern + let f = head_constructor pat_exp in + if not (Env.is_datacon env f.v) + then failwith "Impossible: nullary patterns must be data constructors" + else discriminate (force_scrutinee ()) (head_constructor pat_exp) + + | Pat_cons (_, _, pat_args), Tm_app {hd=head; args} -> + //application pattern + let f = head_constructor head in + if not (Env.is_datacon env f.v) + || List.length pat_args <> List.length args + then failwith "Impossible: application patterns must be fully-applied data constructors" + else let sub_term_guards = + List.zip pat_args args |> + List.mapi (fun i ((pi, _), (ei, _)) -> + let projector = Env.lookup_projector env f.v i in + //NS: TODO ... should this be a marked as a record projector? But it doesn't matter for extraction + let scrutinee_tm = + match Env.try_lookup_lid env projector with + | None -> + None //no projector, e.g., because we are actually typechecking the projector itself + | _ -> + let proj = S.fvar (Ident.set_lid_range projector f.p) None in + Some (mk_Tm_app proj [as_arg (force_scrutinee())] f.p) + in + build_branch_guard scrutinee_tm pi ei) |> + List.flatten + in + discriminate (force_scrutinee()) f @ sub_term_guards + + | Pat_dot_term _, _ -> [] + //a non-pattern sub-term computed via unification; no guard needeed since it is from a dot pattern + + | _ -> failwith (BU.format2 "Internal error: unexpected elaborated pattern: %s and pattern expression %s" + (show pattern) + (show pat_exp)) + in + + (* 5 (b) *) + let build_and_check_branch_guard scrutinee_tm pattern pat = + if not (Env.should_verify env) + then U.exp_true_bool //if we're not verifying, then don't even bother building it + else let t = U.mk_and_l <| build_branch_guard scrutinee_tm pattern pat in + if Debug.high () then + BU.print1 "tc_eqn: branch guard before typechecking: %s\n" (show t); + let t, _, _ = tc_check_tot_or_gtot_term scrutinee_env t U.t_bool None in + if Debug.high () then + BU.print1 "tc_eqn: branch guard after typechecking: %s\n" (show t); + //NS: discarding the guard here means that the VC is not fully type-checked + // and may contain unresolved unification variables, e.g. FIXME! + t in + + (* 5 (c) *) + let branch_guard = build_and_check_branch_guard (Some scrutinee_tm) pattern norm_pat_exp in + + (* 5 (d) *) + let branch_guard = + match when_condition with + | None -> branch_guard + | Some w -> U.mk_and branch_guard w in + + branch_guard + in + + if Debug.extreme () then + BU.print1 "tc_eqn: branch guard : %s\n" (show branch_guard); + + (* 6 (a). Build equality conditions between the pattern and the scrutinee *) + (* (b). Weaken the VCs of the branch and when clause with the equalities from 6 (a) and the when condition *) + (* For layered effects, we weaken with the branch guard instead *) + (* (c). Close the VCs so that they no longer have the pattern-bound variables occurring free in them *) + (* For wp-based effects, closing means applying the close_wp combinator *) + (* For layered effects, we substitute the pattern variables with their projector expressions applied *) + (* to the scrutinee *) + + let effect_label, cflags, maybe_return_c, g_when, g_branch = + (* (a) eqs are equalities between the scrutinee and the pattern *) + let eqs = + let env = pat_env in + if not (Env.should_verify env) + then None + else let e = SS.compress pat_exp in + Some (U.mk_eq2 (env.universe_of env pat_t) pat_t scrutinee_tm e) in + match ret_opt with + | Some (_, (Inr c, _, _)) -> + let pat_bs = List.map S.mk_binder pat_bvs in + let g_branch = + (if eqs |> is_some + then TcComm.weaken_guard_formula g_branch (eqs |> must) + else g_branch) + |> Env.close_guard env pat_bs + |> TcUtil.close_guard_implicits env true pat_bs in + U.comp_effect_name c, None, None, g_when, g_branch + | _ -> + let c, g_branch = TcUtil.strengthen_precondition None env branch_exp c g_branch in + + //g_branch is trivial, its logical content is now incorporated within c + + // + // Working towards closing the branches comp with the pattern variables + // For effects with close combinator defined, we will use that + // For other effects, we will close with substituting pattern variables with + // corresponding projector expressions applied to the scrutinee + // + let close_branch_with_substitutions = + let m = c.eff_name |> Env.norm_eff_name env in + Env.is_layered_effect env m && + None? (m |> Env.get_effect_decl env |> U.get_layered_close_combinator) in + + (* (b) *) + let c_weak, g_when_weak = + if close_branch_with_substitutions + then + //branch_guard is a boolean, so b2t it + let c = TcUtil.weaken_precondition pat_env c (NonTrivial (U.b2t branch_guard)) in + c, mzero //use branch guard for weakening + else + match eqs, when_condition with + | _ when not (Env.should_verify pat_env) -> + c, g_when + + | None, None -> + c, g_when + + | Some f, None -> + let gf = NonTrivial f in + let g = Env.guard_of_guard_formula gf in + TcUtil.weaken_precondition pat_env c gf, + Env.imp_guard g g_when + + | Some f, Some w -> + let g_f = NonTrivial f in + let g_fw = NonTrivial (U.mk_conj f w) in + TcUtil.weaken_precondition pat_env c g_fw, + Env.imp_guard (Env.guard_of_guard_formula g_f) g_when + + | None, Some w -> + let g_w = NonTrivial w in + let g = Env.guard_of_guard_formula g_w in + TcUtil.weaken_precondition pat_env c g_w, + g_when in + + (* (c) *) + let binders = List.map S.mk_binder pat_bvs in + let maybe_return_c_weak should_return = + let c_weak = + if should_return && + TcComm.is_pure_or_ghost_lcomp c_weak + then TcUtil.maybe_assume_result_eq_pure_term (Env.push_bvs scrutinee_env pat_bvs) branch_exp c_weak + else c_weak in + if close_branch_with_substitutions + then + let _ = + if !dbg_LayeredEffects + then BU.print_string "Typechecking pat_bv_tms ...\n" in + + (* + * AR: typecheck the pat_bv_tms, to resolve implicits etc. + * + * recall that pat_bv_tms are terms that are definitionally equal to the pat_bvs + * but are in terms of projectors on the scrutinee term + * these will be used to substitute pat bvs in the computation type + * of the corresponding branch + * + * a pat_bv_tm's expected type is the sort of the corresponding pat bv + * however, we need to be careful about dependent pat bvs of the like (a:Type) (x:a) + * + * so when we typecheck a pat_bv_tm with expected type as corresponding pat_bv.sort, + * we substitute the already seen pat bvs with their pat bv tms in the sort + *) + + //first apply the pat_bv_tms to the scrutinee term + let pat_bv_tms = pat_bv_tms |> List.map (fun pat_bv_tm -> + mk_Tm_app pat_bv_tm [scrutinee_tm |> S.as_arg] Range.dummyRange) in + + let pat_bv_tms = + //note, we are explicitly setting lax = true, since these terms apply projectors + //which we know are sound as per the branch guard, but hard to convince the typechecker + //AR: TODO: should we instead do the non-lax typechecking but drop the logical payload in the guard? + let env = { (Env.push_bv env scrutinee) with admit = true } in + List.fold_left2 (fun (substs, acc) pat_bv_tm bv -> + let expected_t = SS.subst substs bv.sort in + //we also substitute in the pat_bv_tm, since in the case of nested patterns, + // there are cases when sorts of the bound scrutinee variable for the inner pattern vars + // contains some outer patterns vars + let pat_bv_tm = + pat_bv_tm + |> SS.subst substs + |> tc_trivial_guard (Env.set_expected_typ env expected_t) + |> fst in + substs@[NT (bv, pat_bv_tm)], acc@[pat_bv_tm]) ([], []) pat_bv_tms pat_bvs + + |> snd + |> List.map (N.normalize [Env.Beta] env) in + + let _ = + if !dbg_LayeredEffects + then BU.print2 "tc_eqn: typechecked pat_bv_tms=%s (pat_bvs=%s)\n" + (show pat_bv_tms) (show pat_bvs) + in + + c_weak + |> TcComm.apply_lcomp (fun c -> c) (fun g -> match eqs with + | None -> g + | Some eqs -> TcComm.weaken_guard_formula g eqs) + |> TcUtil.close_layered_lcomp_with_substitutions (Env.push_bv env scrutinee) pat_bvs pat_bv_tms + else if c_weak.eff_name |> Env.norm_eff_name env |> Env.is_layered_effect env + then TcUtil.close_layered_lcomp_with_combinator (Env.push_bv env scrutinee) pat_bvs c_weak + else TcUtil.close_wp_lcomp (Env.push_bv env scrutinee) pat_bvs c_weak in + + c_weak.eff_name, + Some c_weak.cflags, + Some maybe_return_c_weak, + Env.close_guard env binders g_when_weak, + guard_pat ++ g_branch in + + let guard = g_when ++ g_branch in + + if Debug.high () + then BU.print1 "Carrying guard from match: %s\n" <| guard_to_string env guard; + + SS.close_branch (pattern, when_clause, branch_exp), + branch_guard, //expressed in terms of discriminators and projectors on scrutinee---does not contain the pattern-bound variables + effect_label, + cflags, + maybe_return_c, //closed already---does not contain free pattern-bound variables + TcUtil.close_guard_implicits env false (List.map S.mk_binder pat_bvs) guard, + erasable + +(******************************************************************************) +(* Checking a top-level, non-recursive let-binding: *) +(* top-level let's may be generalized, if they are not annotated *) +(* the body of a top-level let is always ()---no point in checking it *) +(******************************************************************************) +and check_top_level_let env e = + let env = instantiate_both env in + match e.n with + | Tm_let {lbs=(false, [lb]); body=e2} -> +(*open*) let e1, univ_vars, c1, g1, annotated = check_let_bound_def true env lb in + (* Maybe generalize its type *) + let g1, e1, univ_vars, c1 = + if annotated && not env.generalize + then g1, N.reduce_uvar_solutions env e1, univ_vars, c1 + else let g1 = Rel.solve_deferred_constraints env g1 |> Rel.resolve_implicits env in + let comp1, g_comp1 = lcomp_comp c1 in + let g1 = g1 ++ g_comp1 in + let _, univs, e1, c1, gvs = List.hd (Gen.generalize env false [lb.lbname, e1, comp1]) in + let g1 = Rel.resolve_generalization_implicits env g1 in + let g1 = map_guard g1 <| N.normalize [Env.Beta; Env.DoNotUnfoldPureLets; Env.CompressUvars; Env.NoFullNorm; Env.Exclude Env.Zeta] env in + let g1 = abstract_guard_n gvs g1 in + g1, e1, univs, TcComm.lcomp_of_comp c1 + in + + (* Check that it doesn't have a top-level effect; warn if it does *) + let e2, c1 = + let ok, c1 = TcUtil.check_top_level env g1 c1 in //check that it has no effect and a trivial pre-condition + if ok + then e2, c1 + else ( + if not (Options.ml_ish ()) then + Err.warn_top_level_effect (Env.get_range env); // maybe warn + mk (Tm_meta {tm=e2; meta=Meta_desugared Masked_effect}) e2.pos, c1 //and tag it as masking an effect + ) + in + + (* Unfold all @tcnorm subterms in the binding *) + if Debug.medium () then + BU.print1 "Let binding BEFORE tcnorm: %s\n" (show e1); + let e1 = if Options.tcnorm () then + N.normalize [Env.UnfoldAttr [Const.tcnorm_attr]; + Env.Exclude Env.Beta; Env.Exclude Env.Zeta; + Env.NoFullNorm; Env.DoNotUnfoldPureLets] env e1 + else e1 + in + if Debug.medium () then + BU.print1 "Let binding AFTER tcnorm: %s\n" (show e1); + + (* + * AR: comp for the whole `let x = e1 in e2`, where e2 = () + * + * we have already checked that e1 has the right effect args + * for it to be a top-level effect + * + * for wp effects that means trivial precondition, + * and for indexed effects that means as per the top_level_effect + * specification + * + * Since the top-level effect is masked at this point, + * we just return Tot unit and the final computation type + * + * Note that for top-level lets, this cres is not used anyway + *) + let cres = S.mk_Total S.t_unit in + +(*close*)let lb = U.close_univs_and_mk_letbinding None lb.lbname univ_vars (U.comp_result c1) (U.comp_effect_name c1) e1 lb.lbattrs lb.lbpos in + mk (Tm_let {lbs=(false, [lb]); body=e2}) + e.pos, + TcComm.lcomp_of_comp cres, + mzero + + | _ -> failwith "Impossible: check_top_level_let: not a let" + +and maybe_intro_smt_lemma env lem_typ c2 = + if U.is_smt_lemma lem_typ + then let universe_of_binders bs = + let _, us = + List.fold_left + (fun (env, us) b -> + let u = env.universe_of env b.binder_bv.sort in + let env = Env.push_binders env [b] in + env, u::us) + (env, []) + bs + in + List.rev us + in + let quant = U.smt_lemma_as_forall lem_typ universe_of_binders in + TcUtil.weaken_precondition env c2 (NonTrivial quant) + else c2 + +(******************************************************************************) +(* Checking an inner non-recursive let-binding: *) +(* inner let's are never implicitly generalized *) +(* let x = e1 in e2 is logically a bind (lift c1) (\x. lift c2) *) +(* except that we also need to strengthen it with well-formedness checks *) +(* and a check that x does not escape its scope in the type of c2 *) +(******************************************************************************) +and check_inner_let env e = + let env = instantiate_both env in + match e.n with + | Tm_let {lbs=(false, [lb]); body=e2} -> + let env = {env with top_level=false} in + let e1, _, c1, g1, annotated = check_let_bound_def false (Env.clear_expected_typ env |> fst) lb in + let pure_or_ghost = TcComm.is_pure_or_ghost_lcomp c1 in + let is_inline_let = BU.for_some (U.is_fvar FStarC.Parser.Const.inline_let_attr) lb.lbattrs in + let _ = + if is_inline_let + && not (pure_or_ghost || Env.is_erasable_effect env c1.eff_name) //inline let is allowed on erasable effects + then raise_error e1 + Errors.Fatal_ExpectedPureExpression + (BU.format2 "Definitions marked @inline_let are expected to be pure or ghost; \ + got an expression \"%s\" with effect \"%s\"" + (show e1) + (show c1.eff_name)) + in + let x = {BU.left lb.lbname with sort=c1.res_typ} in + let xb, e2 = SS.open_term [S.mk_binder x] e2 in + let xbinder = List.hd xb in + let x = xbinder.binder_bv in + let env_x = Env.push_bv env x in + let e2, c2, g2 = + (* + * AR: we typecheck e2 and fold its guard into the returned lcomp + * so that the guard is under the equality x=e1 when we later (in the next line) + * bind c1 and c2 + *) + tc_term env_x e2 + |> (fun (e2, c2, g2) -> + let c2, g2 = TcUtil.strengthen_precondition + ((fun _ -> Errors.mkmsg "folding guard g2 of e2 in the lcomp") |> Some) + env_x + e2 + c2 + g2 in + e2, c2, g2) in + //g2 now has no logical payload after this, it may have unresolved implicits + let c2 = maybe_intro_smt_lemma env_x c1.res_typ c2 in + let cres = + TcUtil.maybe_return_e2_and_bind + e1.pos + env + (Some e1) + c1 + e2 + (Some x, c2) + in + //AR: TODO: FIXME: monadic annotations need to be adjusted for polymonadic binds + let e1 = TcUtil.maybe_lift env e1 c1.eff_name cres.eff_name c1.res_typ in + let e2 = TcUtil.maybe_lift env e2 c2.eff_name cres.eff_name c2.res_typ in + let lb = + let attrs = + let add_inline_let = //add inline_let if + not is_inline_let && //the letbinding is not already inline_let, and + ((pure_or_ghost && //either it is pure/ghost with unit type, or + U.is_unit c1.res_typ) || + (Env.is_erasable_effect env c1.eff_name && //c1 is erasable and cres is not + not (Env.is_erasable_effect env cres.eff_name))) in + if add_inline_let + then U.inline_let_attr::lb.lbattrs + else lb.lbattrs in + U.mk_letbinding (Inl x) [] c1.res_typ cres.eff_name e1 attrs lb.lbpos in + let e = mk (Tm_let {lbs=(false, [lb]); body=SS.close xb e2}) e.pos in + let e = TcUtil.maybe_monadic env e cres.eff_name cres.res_typ in + + //AR: for layered effects, solve any deferred constraints first + // we can do it at other calls to close_guard_implicits too, but let's see + let g2 = TcUtil.close_guard_implicits env + (cres.eff_name |> Env.norm_eff_name env |> Env.is_layered_effect env) + xb g2 in + let guard = g1 ++ g2 in + + if Option.isSome (Env.expected_typ env) + then (let tt = Env.expected_typ env |> Option.get |> fst in + if !dbg_Exports + then BU.print2 "Got expected type from env %s\ncres.res_typ=%s\n" + (show tt) + (show cres.res_typ); + e, cres, guard) + else (* no expected type; check that x doesn't escape it's scope *) + (let t, g_ex = check_no_escape None env [x] cres.res_typ in + if !dbg_Exports + then BU.print2 "Checked %s has no escaping types; normalized to %s\n" + (show cres.res_typ) + (show t); + e, ({cres with res_typ=t}), g_ex ++ guard) + + | _ -> failwith "Impossible (inner let with more than one lb)" + +(******************************************************************************) +(* top-level let rec's may be generalized, if they are not annotated *) +(******************************************************************************) +and check_top_level_let_rec env top = + let env = instantiate_both env in + match top.n with + | Tm_let {lbs=(true, lbs); body=e2} -> + (* replace bound variables in terms and of universes with new names (free variables) *) +(*open*) let lbs, e2 = SS.open_let_rec lbs e2 in + + (* expected types for top level definitions are stored in the lbs and we therefore just + * remove previous, unrelated, expected type in env + * the expected type is defined within lbs + * *) + let env0, topt = Env.clear_expected_typ env in + let lbs, rec_env, g_t = build_let_rec_env true env0 lbs in + (* now we type check each let rec *) + let lbs, g_lbs = check_let_recs rec_env lbs in + let g_lbs = g_t ++ g_lbs |> Rel.solve_deferred_constraints env |> Rel.resolve_implicits env in + + let all_lb_names = lbs |> List.map (fun lb -> right lb.lbname) |> Some in + + let lbs, g_lbs = + if not env.generalize + then + let lbs = + lbs |> List.map (fun lb -> + (* TODO : Should we gather the fre univnames ? e.g. (TcUtil.gather_free_univnames env e1)@lb.lbunivs *) + let lbdef = N.reduce_uvar_solutions env lb.lbdef in + if lb.lbunivs = [] + then lb + else U.close_univs_and_mk_letbinding all_lb_names lb.lbname lb.lbunivs lb.lbtyp lb.lbeff lbdef lb.lbattrs lb.lbpos) + in + lbs, g_lbs (* g_lbs untouched *) + else + let ecs = Gen.generalize env true (lbs |> List.map (fun lb -> + lb.lbname, + lb.lbdef, + S.mk_Total lb.lbtyp)) + in + let lbs = List.map2 (fun (x, uvs, e, c, gvs) lb -> + U.close_univs_and_mk_letbinding + all_lb_names + x + uvs + (U.comp_result c) + (U.comp_effect_name c) + e + lb.lbattrs + lb.lbpos) + ecs + lbs + in + (* discharge generalization uvars *) + let g_lbs = Rel.resolve_generalization_implicits env g_lbs in + lbs, g_lbs + in + + let cres = TcComm.lcomp_of_comp <| S.mk_Total t_unit in + +(*close*) let lbs, e2 = SS.close_let_rec lbs e2 in + Rel.discharge_guard env g_lbs |> Rel.force_trivial_guard env; + mk (Tm_let {lbs=(true, lbs); body=e2}) top.pos, + cres, + mzero + + | _ -> failwith "Impossible: check_top_level_let_rec: not a let rec" + +(******************************************************************************) +(* inner let rec's are never implicitly generalized *) +(******************************************************************************) +and check_inner_let_rec env top = + let env = instantiate_both env in + match top.n with + | Tm_let {lbs=(true, lbs); body=e2} -> +(*open*) let lbs, e2 = SS.open_let_rec lbs e2 in + + let env0, topt = Env.clear_expected_typ env in + let lbs, rec_env, g_t = build_let_rec_env false env0 lbs in + let lbs, g_lbs = check_let_recs rec_env lbs |> (fun (lbs, g) -> lbs, g_t ++ g) in + + let env, lbs = lbs |> BU.fold_map (fun env lb -> + let x = {left lb.lbname with sort=lb.lbtyp} in + let lb = {lb with lbname=Inl x} in + let env = Env.push_let_binding env lb.lbname ([], lb.lbtyp) in //local let recs are not universe polymorphic + env, lb) env in + + let bvs = lbs |> List.map (fun lb -> left (lb.lbname)) in + + let e2, cres, g2 = tc_term env e2 in + let cres = + List.fold_right + (fun lb cres -> maybe_intro_smt_lemma env lb.lbtyp cres) + lbs + cres + in + let cres = TcUtil.maybe_assume_result_eq_pure_term env e2 cres in + let cres = TcComm.lcomp_set_flags cres [SHOULD_NOT_INLINE] in //cf. issue #1362 + let guard = g_lbs ++ (Env.close_guard env (List.map S.mk_binder bvs) g2) in + // + //We need to close bvs in cres + //If cres is a wp-effect, then we can use the close combinator + //If it is a layered effect, for now we check that bvs don't escape + //The code below only checks effect args, + // return type is checked at the end of this function + // + let cres = + if cres.eff_name |> Env.norm_eff_name env + |> Env.is_layered_effect env + then let bvss = from_list bvs in + TcComm.apply_lcomp + (fun c -> + if (c |> U.comp_effect_args + |> List.existsb (fun (t, _) -> + t |> Free.names + |> inter bvss + |> is_empty + |> not)) + then raise_error top Errors.Fatal_EscapedBoundVar + "One of the inner let recs escapes in the \ + effect argument(s), try adding a type \ + annotation" + else c) + (fun g -> g) + cres + else TcUtil.close_wp_lcomp env bvs cres in + let tres = norm env cres.res_typ in + let cres = {cres with res_typ=tres} in + + let guard = + let bs = lbs |> List.map (fun lb -> S.mk_binder (BU.left lb.lbname)) in + TcUtil.close_guard_implicits env false bs guard + in + +(*close*) let lbs, e2 = SS.close_let_rec lbs e2 in + let e = mk (Tm_let {lbs=(true, lbs); body=e2}) top.pos in + + begin match topt with + | Some _ -> e, cres, guard //we have an annotation + | None -> + let tres, g_ex = check_no_escape None env bvs tres in + let cres = {cres with res_typ=tres} in + e, cres, g_ex ++ guard + end + + | _ -> failwith "Impossible: check_inner_let_rec: not a let rec" + +(******************************************************************************) +(* build an environment with recursively bound names. *) +(* refining the types of those names with decreases clauses is done in tc_abs *) +(******************************************************************************) +and build_let_rec_env _top_level env lbs : list letbinding & env_t & guard_t = + let env0 = env in + let termination_check_enabled (attrs:list attribute) (lbname:lbname) (lbdef:term) (lbtyp:term) + : option (int & term) // when enabled returns recursion arity; + // plus the term elaborated with implicit binders + // (TODO: move all that logic to desugaring) + = + if Options.ml_ish () then None else + + let lbtyp0 = lbtyp in + let actuals, body, body_lc = abs_formals lbdef in + + //add implicit binders, in case, for instance + //lbtyp is of the form x:'a -> t + //lbdef is of the form (fun x -> t) + //in which case, we need to add (#'a:Type) to the actuals + //See the handling in Tm_abs case of tc_value, roughly line 703 (location may have changed since this comment was written) + let actuals = TcUtil.maybe_add_implicit_binders (Env.set_expected_typ env lbtyp) actuals in + let nactuals = List.length actuals in + + (* Grab binders from the type. At most as many as we have in + * the abstraction. *) + let formals, c = N.get_n_binders env nactuals lbtyp in + + // TODO: There's a similar error in check_let_recs, would be nice + // to remove this one. + if List.isEmpty formals || List.isEmpty actuals then + raise_error lbtyp Errors.Fatal_RecursiveFunctionLiteral // TODO: GM: maybe point to the one that's actually empty? + (BU.format3 "Only function literals with arrow types can be defined recursively; got (%s) %s : %s" + (tag_of lbdef) + (show lbdef) + (show lbtyp)); + + let nformals = List.length formals in + + (* `nformals` is exactly the arity of recursion. It is either + * the amount of binders we traversed until we ran into an effect + * in the expected type, or the total amount of binders in the + * abstraction's body. So we can just check the effect `c` for + * totality. Another way of seeing this check is that we take + * the minimum amount of binders from the actuals and formals. *) + if U.has_attribute attrs Const.admit_termination_lid then ( + log_issue env Warning_WarnOnUse ("Admitting termination of " ^ show lbname); + None + ) else if U.comp_effect_name c |> Env.lookup_effect_quals env |> List.contains TotalEffect then + Some (nformals, U.abs actuals body body_lc) + else + None + in + let check_annot univ_vars t = + let env0 = Env.push_univ_vars env0 univ_vars in + let t, _, g = tc_check_tot_or_gtot_term ({env0 with check_uvars=true}) t (fst <| U.type_u()) None in + env0, g |> Rel.resolve_implicits env |> Rel.discharge_guard env0, t + in + let lbs, env, g = List.fold_left (fun (lbs, env, g_acc) lb -> + let univ_vars, lbtyp, lbdef, check_t = TcUtil.extract_let_rec_annotation env lb in + let env = Env.push_univ_vars env univ_vars in //no polymorphic recursion on universes + let g, lbtyp = + if not check_t + then g_acc, lbtyp + else let _, g, t = check_annot univ_vars lbtyp in + g_acc ++ g, t + in + // AR: This code (below) also used to have && Env.should_verify env + // i.e. when lax checking it was adding lbname in the second branch + // this was a problem for 2-phase, if an implicit type was the type of a let rec (see bug056) + // Removed that check. Rest of the code relies on env.letrecs = [] + let lb, env = + match termination_check_enabled lb.lbattrs lb.lbname lbdef lbtyp with + // AR: we need to add the binding of the let rec after adding the + // binders of the lambda term, and so, here we just note in the env that + // we are typechecking a let rec, the recursive binding will be added in + // tc_abs adding universes here so that when we add the let binding, we + // can add a typescheme with these universes + | Some (arity, lbdef) -> + if Debug.extreme () + then BU.print2 "termination_check_enabled returned arity: %s and lbdef: %s\n" + (string_of_int arity) (show lbdef); + let lb = {lb with lbtyp=lbtyp; lbunivs=univ_vars; lbdef=lbdef} in + let env = {env with letrecs=(lb.lbname, arity, lbtyp, univ_vars)::env.letrecs} in + lb, env + | None -> + let lb = {lb with lbtyp=lbtyp; lbunivs=univ_vars; lbdef=lbdef} in + lb, Env.push_let_binding env lb.lbname (univ_vars, lbtyp) + in + lb::lbs, env, g) + ([], env, mzero) + lbs in + List.rev lbs, env, g + +and check_let_recs env lbts = + let lbs, gs = lbts |> List.map (fun lb -> + (* here we set the expected type in the environment to the annotated expected type + * and use it in order to type check the body of the lb + * *) + let bs, t, lcomp = abs_formals lb.lbdef in + //see issue #1017 + match bs with + | [] -> raise_error (S.range_of_lbname lb.lbname) + Errors.Fatal_RecursiveFunctionLiteral + (BU.format2 + "Only function literals may be defined recursively; %s is defined to be %s" + (show lb.lbname) + (show lb.lbdef)) + | _ -> (); + + (* HACK ALERT: arity + * + * We build a Tm_abs node with exactly [arity] binders, + * and put the rest in another node in the body, so `tc_abs` + * will do the right thing when computing a decreases clauses. + *) + let arity = match Env.get_letrec_arity env lb.lbname with + | Some n -> n + | None -> List.length bs (* Keep the node as-is *) + in + let bs0, bs1 = List.splitAt arity bs in + let def = + if List.isEmpty bs1 + then U.abs bs0 t lcomp + else let inner = U.abs bs1 t lcomp in + let inner = SS.close bs0 inner in + let bs0 = SS.close_binders bs0 in + S.mk (Tm_abs {bs=bs0;body=inner;rc_opt=None}) inner.pos + // ^ using abs again would flatten the abstraction + in + (* / HACK *) + + let lb = { lb with lbdef = def } in + + let e, c, g = tc_tot_or_gtot_term (Env.set_expected_typ env lb.lbtyp) lb.lbdef in + if not (TcComm.is_total_lcomp c) + then raise_error e Errors.Fatal_UnexpectedGTotForLetRec "Expected let rec to be a Tot term; got effect GTot"; + (* replace the body lb.lbdef with the type checked body e with elaboration on monadic application *) + let lb = U.mk_letbinding lb.lbname lb.lbunivs lb.lbtyp Const.effect_Tot_lid e lb.lbattrs lb.lbpos in + lb, g) |> List.unzip in + lbs, msum gs + + +(******************************************************************************) +(* Several utility functions follow *) +(******************************************************************************) +and check_let_bound_def top_level env lb + : term (* checked lbdef *) + & univ_names (* univ_vars, if any *) + & lcomp (* type of lbdef *) + & guard_t (* well-formedness of lbtyp *) + & bool (* true iff lbtyp was annotated *) + = + let env1, _ = Env.clear_expected_typ env in + let e1 = lb.lbdef in + + (* 1. extract the annotation of the let-bound term, e1, if any *) + let topt, wf_annot, univ_vars, univ_opening, env1 = check_lbtyp top_level env lb in + + if not top_level && univ_vars <> [] + then raise_error e1 Errors.Fatal_UniversePolymorphicInnerLetBound "Inner let-bound definitions cannot be universe polymorphic"; + + (* 2. type-check e1 *) + (* Only toplevel terms should have universe openings *) + assert ( top_level || List.length univ_opening = 0 ); + let e1 = subst univ_opening e1 in + let e1, c1, g1 = tc_maybe_toplevel_term ({env1 with top_level=top_level}) e1 in + + (* and strengthen its VC with and well-formedness condition on its annotated type *) + //NS: Maybe redundant strengthen + // let c1, guard_f = c1, wf_annot in + let c1, guard_f = TcUtil.strengthen_precondition + (Some (fun () -> return_all Err.ill_kinded_type)) + (Env.set_range env1 e1.pos) e1 c1 wf_annot in + let g1 = g1 ++ guard_f in + + if Debug.extreme () + then BU.print3 "checked let-bound def %s : %s guard is %s\n" + (show lb.lbname) + (TcComm.lcomp_to_string c1) + (Rel.guard_to_string env g1); + + e1, univ_vars, c1, g1, Option.isSome topt + + +(* Extracting the type of non-recursive let binding *) +and check_lbtyp top_level env lb : option typ (* checked version of lb.lbtyp, if it was not Tm_unknown *) + & guard_t (* well-formedness condition for that type *) + & univ_names (* explicit universe variables, if any *) + & list subst_elt (* subtistution of the opened universes *) + & Env.env (* env extended with univ_vars *) + = + Errors.with_ctx "While checking type annotation of a letbinding" (fun () -> + let t = SS.compress lb.lbtyp in + match t.n with + | Tm_unknown -> + //if lb.lbunivs <> [] then failwith "Impossible: non-empty universe variables but the type is unknown"; //AR: do we need this check? this situation arises in phase 2 + let univ_opening, univ_vars = univ_var_opening lb.lbunivs in + None, mzero, univ_vars, univ_opening, Env.push_univ_vars env univ_vars + + | _ -> + let univ_opening, univ_vars = univ_var_opening lb.lbunivs in + let t = subst univ_opening t in + let env1 = Env.push_univ_vars env univ_vars in + if top_level + && not (env.generalize) //clearly, x has an annotated type ... could env.generalize ever be true here? + //yes. x may not have a val declaration, only an inline annotation + //so, not (env.generalize) signals that x has been declared as val x : t, and t has already been checked + then Some t, mzero, univ_vars, univ_opening, Env.set_expected_typ env1 t //t has already been kind-checked + else //we have an inline annotation + let k, _ = U.type_u () in + let t, _, g = tc_check_tot_or_gtot_term env1 t k None in + if Debug.medium () + then BU.print2 "(%s) Checked type annotation %s\n" + (Range.string_of_range (range_of_lbname lb.lbname)) + (show t); + let t = norm env1 t in + Some t, g, univ_vars, univ_opening, Env.set_expected_typ env1 t + ) + +and tc_binder env ({binder_bv=x;binder_qual=imp;binder_positivity=pqual;binder_attrs=attrs}) = + let tu, u = U.type_u () in + if Debug.extreme () + then BU.print3 "Checking binder %s:%s at type %s\n" + (show x) + (show x.sort) + (show tu); + let t, _, g = tc_check_tot_or_gtot_term env x.sort tu None in //ghost effect ok in the types of binders + let imp, g' = + match imp with + | Some (Meta tau) -> + let tau, _, g = tc_tactic t_unit t_unit env tau in + Some (Meta tau), g + | _ -> imp, mzero + in + let g_attrs, attrs = tc_attributes env attrs in + let g = g ++ g_attrs in + check_erasable_binder_attributes env attrs t; + let x = S.mk_binder_with_attrs ({x with sort=t}) imp pqual attrs in + if Debug.high () + then BU.print2 "Pushing binder %s at type %s\n" (show x.binder_bv) (show t); + x, push_binding env x, g, u + +and tc_binders env bs = + if Debug.extreme () then + BU.print1 "Checking binders %s\n" (show bs); + let rec aux env bs = match bs with + | [] -> [], env, mzero, [] + | b::bs -> + let b, env', g, u = tc_binder env b in + let bs, env', g', us = aux env' bs in + b::bs, env', g ++ (Env.close_guard_univs [u] [b] g'), u::us in + aux env bs + +and tc_smt_pats en pats = + let tc_args en args : Syntax.args & guard_t = + //an optimization for checking arguments in cases where we know that their types match the types of the corresponding formal parameters + //notably, this is used when checking the application (?u x1 ... xn). NS: which we do not currently do! + List.fold_right (fun (t, imp) (args, g) -> + t |> check_no_smt_theory_symbols en; + let t, _, g' = tc_term en t in + (t, imp)::args, g ++ g') + args ([], mzero) in + List.fold_right (fun p (pats, g) -> + let args, g' = tc_args en p in + (args::pats, g ++ g')) pats ([], mzero) + +and tc_tot_or_gtot_term_maybe_solve_deferred (env:env) (e:term) (msg:option string) (solve_deferred:bool) +: term & lcomp & guard_t += let e, c, g = tc_maybe_toplevel_term env e in + if TcComm.is_tot_or_gtot_lcomp c + then e, c, g + else let g = + if solve_deferred + then Rel.solve_deferred_constraints env g + else g in + let c, g_c = TcComm.lcomp_comp c in + let c = norm_c env c in + let target_comp, allow_ghost = + if TcUtil.is_pure_effect env (U.comp_effect_name c) + then S.mk_Total (U.comp_result c), false + else S.mk_GTotal (U.comp_result c), true in + match Rel.sub_comp env c target_comp with + | Some g' -> e, TcComm.lcomp_of_comp target_comp, g ++ (g_c ++ g') + | _ -> + if allow_ghost + then Err.expected_ghost_expression e.pos e c msg + else Err.expected_pure_expression e.pos e c msg + +and tc_tot_or_gtot_term' (env:env) (e:term) (msg:option string) +: term & lcomp & guard_t += tc_tot_or_gtot_term_maybe_solve_deferred env e msg true + +and tc_tot_or_gtot_term env e = tc_tot_or_gtot_term' env e None + +and tc_check_tot_or_gtot_term env e t (msg : option string) +: term & lcomp & guard_t += let env = Env.set_expected_typ env t in + tc_tot_or_gtot_term' env e msg + +and tc_trivial_guard env t = + let t, c, g = tc_tot_or_gtot_term env t in + Rel.force_trivial_guard env g; + t,c + +and tc_attributes (env:env_t) (attrs : list term) : guard_t & list term = + List.fold_left + (fun (g, attrs) attr -> + let attr', _, g' = tc_tot_or_gtot_term env attr in + g ++ g', attr' :: attrs) + (mzero, []) + (List.rev attrs) + +let tc_check_trivial_guard env t k = + let t, _, g = tc_check_tot_or_gtot_term env t k None in + Rel.force_trivial_guard env g; + t + + +(* type_of_tot_term env e : e', t, g + checks that env |- e' : Tot t' <== g + i.e., e' is an elaboration of e + such that it has type Tot t + subject to the guard g + in environment env + *) +let typeof_tot_or_gtot_term env e must_tot = + if !dbg_RelCheck then BU.print1 "Checking term %s\n" (show e); + //let env, _ = Env.clear_expected_typ env in + let env = {env with top_level=false; letrecs=[]} in + let t, c, g = + try tc_tot_or_gtot_term env e + with Error(e, msg, r, ctx) when r = Range.dummyRange -> + raise (Error (e, msg, Env.get_range env, ctx)) + in + if must_tot then + let c = N.maybe_ghost_to_pure_lcomp env c in + if TcComm.is_total_lcomp c + then t, c.res_typ, g + else raise_error env Errors.Fatal_UnexpectedImplictArgument (BU.format1 "Implicit argument: Expected a total term; got a ghost term: %s" (show e)) + else t, c.res_typ, g + +let level_of_type_fail (env:Env.env) (e:term) (t:string) = + raise_error env Errors.Fatal_UnexpectedTermType [ + Errors.text (BU.format2 "Expected a type; got %s of type %s" (show e) t) + ] + +let level_of_type env e t = + let rec aux retry t = + match (U.unrefine t).n with + | Tm_type u -> u + | _ -> + if retry + then let t = Normalize.normalize [Env.UnfoldUntil delta_constant] env t in + aux false t + else let t_u, u = U.type_u() in + let env = {env with admit = true} in + (* + * AR: This is a little harsh + * If t is a uvar, then this prevents t to be inferred as something more + * precise than Type, e.g. eqtype + * So ideally, we could here generate a subtyping constraint + * But for that this function needs to return a guard, and + * the guard needs to be accounted for in the callers + *) + let g = FStarC.TypeChecker.Rel.teq env t t_u in + begin match g.guard_f with + | NonTrivial f -> + level_of_type_fail env e (show t) + | _ -> + Rel.force_trivial_guard env g + end; + u + in aux true t + +(* + * This helper routine computes the result type of applying args to + * a term of type t_hd + * + * It assumes that the terms are ghost/pure and well-typed in env + * -- to be called from fastpath type checking routines ONLY + *) + +(* private *) +let rec apply_well_typed env (t_hd:typ) (args:args) : option typ = + if List.length args = 0 + then Some t_hd + else match (N.unfold_whnf env t_hd).n with + | Tm_arrow {bs; comp=c} -> + let n_args = List.length args in + let n_bs = List.length bs in + let bs, args, t, remaining_args = (* bs (opened), args (length args = length bs), comp result type, remaining args *) + if n_args < n_bs + then let bs, rest = BU.first_N n_args bs in + let t = S.mk (Tm_arrow {bs=rest; comp=c}) t_hd.pos in + let bs, c = SS.open_comp bs (S.mk_Total t) in + bs, args, U.comp_result c, [] + else let bs, c = SS.open_comp bs c in + let args, remaining_args = List.splitAt n_bs args in + bs, args, U.comp_result c, remaining_args in + let subst = List.map2 (fun b a -> NT (b.binder_bv, fst a)) bs args in + let t = SS.subst subst t in + apply_well_typed env t remaining_args + | Tm_refine {b=x} -> apply_well_typed env x.sort args + | Tm_ascribed {tm=t} -> apply_well_typed env t args + | _ -> None + + +(* universe_of_aux env e: + During type-inference, we build terms like WPs for which we need to compute + explicit universe instantiations. + + This is generally called from within TypeChecker.Util + when building WPs. For example, in building (return_value t e), + u=universe_of env t. + + We don't aim to compute a precise type for e. + Rather, we look to compute the universe level of e's type, + presuming that e must have type Type + + For instance, if e is an application (f _), we compute the type of f to be bs -> C, + and we take the universe level of e to be (level_of (comp_result C)), + disregarding the arguments of f. + + This a returns a term of shape Tm_type at the wanted universe. + *) +let rec universe_of_aux env e : term = + match (SS.compress e).n with + | Tm_bvar _ + | Tm_unknown + | Tm_delayed _ -> + failwith ("TcTerm.universe_of:Impossible (bvar/unknown/lazy) " ^ + (show e)) + //normalize let bindings away and then compute the universe + | Tm_let _ -> + let e = N.normalize [] env e in + universe_of_aux env e + //we expect to compute (Type u); so an abstraction always fails + | Tm_abs {bs; body=t} -> + level_of_type_fail env e "arrow type" + //these next few cases are easy; we just use the type stored at the node + | Tm_uvar (u, s) -> SS.subst' s (U.ctx_uvar_typ u) + | Tm_meta {tm=t} -> universe_of_aux env t + | Tm_name n -> + let (t, _rng) = Env.lookup_bv env n in + t + | Tm_fvar fv -> + let (_, t), _ = Env.lookup_lid env fv.fv_name.v in + t + | Tm_lazy i -> universe_of_aux env (U.unfold_lazy i) + | Tm_ascribed {asc=(Inl t, _, _)} -> t + | Tm_ascribed {asc=(Inr c, _, _)} -> U.comp_result c + //also easy, since we can quickly recompute the type + | Tm_type u -> S.mk (Tm_type (U_succ u)) e.pos + | Tm_quoted _ -> U.ktype0 + | Tm_constant sc -> tc_constant env e.pos sc + //slightly subtle, since fv is a type-scheme; instantiate it with us + | Tm_uinst({n=Tm_fvar fv}, us) -> + let (us', t), _ = Env.lookup_lid env fv.fv_name.v in + if List.length us <> List.length us' then + raise_error env Errors.Fatal_UnexpectedNumberOfUniverse + "Unexpected number of universe instantiations"; + (* FIXME: this logic is repeated from the Tm_uinst case of tc_value *) + List.iter2 + (fun ul ur -> match ul, ur with + | U_unif u'', _ -> UF.univ_change u'' ur + // TODO: more cases? we cannot get U_succ or U_max here I believe... + | U_name n1, U_name n2 when Ident.ident_equals n1 n2 -> () + | _ -> + raise_error env Errors.Fatal_IncompatibleUniverse + (BU.format3 "Incompatible universe application for %s, expected %s got %s\n" + (show fv) (show ul) (show ur))) + us' us; + t + + | Tm_uinst _ -> + failwith "Impossible: Tm_uinst's head must be an fvar" + //the refinement formula plays no role in the universe computation; so skip it + | Tm_refine {b=x} -> universe_of_aux env x.sort + //U_max(univ_of bs, univ_of c) + | Tm_arrow {bs; comp=c} -> + let bs, c = SS.open_comp bs c in + let env = Env.push_binders env bs in + let us = List.map (fun ({binder_bv=b}) -> level_of_type env b.sort (universe_of_aux env b.sort)) bs in + let u_res = + let res = U.comp_result c in + level_of_type env res (universe_of_aux env res) in + let u_c = c |> TcUtil.universe_of_comp env u_res in + let u = N.normalize_universe env (S.U_max (u_c::us)) in + S.mk (Tm_type u) e.pos + //See the comment at the top of this function; we just compute the universe of hd's result type + | Tm_app {hd; args} -> + let rec type_of_head retry env hd args = + let hd = SS.compress hd in + match hd.n with + | Tm_unknown + | Tm_bvar _ + | Tm_delayed _ -> + failwith "Impossible: universe_of_aux: Tm_app: unexpected head type" + | Tm_fvar _ + | Tm_name _ + | Tm_uvar _ + | Tm_uinst _ + | Tm_ascribed _ + | Tm_refine _ + | Tm_constant _ + | Tm_arrow _ + | Tm_meta _ + | Tm_type _ -> + universe_of_aux env hd, args + | Tm_match {brs=b::_} -> //AR: TODO: use return annotation? Or the residual_comp? + let (pat, _, tm) = SS.open_branch b in + let bvs = Syntax.pat_bvs pat in + let hd, args' = U.head_and_args tm in + type_of_head retry (Env.push_bvs env bvs) hd (args'@args) + | _ when retry -> + //head is either an abs, so we have a beta-redex + // or a let, + // GM: NOTE: not using hd and args here, + // this is calling itself with the `e` from + // universe_of_aux and splitting it again. + let e = N.normalize [Env.Beta; Env.DoNotUnfoldPureLets] env e in + let hd, args = U.head_and_args e in + type_of_head false env hd args + | _ -> + let env, _ = Env.clear_expected_typ env in + let env = {env with admit=true; top_level=false} in + if !dbg_UniverseOf + then BU.print2 "%s: About to type-check %s\n" + (Range.string_of_range (Env.get_range env)) + (show hd); + let _, ({res_typ=t}), g = tc_term env hd in + Rel.solve_deferred_constraints env g |> ignore; + t, args + in + let t, args = type_of_head true env hd args in + (match apply_well_typed env t args with + | Some t -> t + | None -> level_of_type_fail env e (show t)) + | Tm_match {brs=b::_} -> //AR: TODO: use return annotation? + let (pat, _, tm) = SS.open_branch b in + let bvs = Syntax.pat_bvs pat in + universe_of_aux (Env.push_bvs env bvs) tm + + | Tm_match {brs=[]} -> //AR: TODO: use return annotation? + level_of_type_fail env e "empty match cases" + + +let universe_of env e = Errors.with_ctx "While attempting to compute a universe level" (fun () -> + if Debug.high () then + BU.print1 "Calling universe_of_aux with %s {\n" (show e); + def_check_scoped e.pos "universe_of entry" env e; + + let r = universe_of_aux env e in + if Debug.high () then + BU.print1 "Got result from universe_of_aux = %s }\n" (show r); + level_of_type env e r +) + +let tc_tparams env0 (tps:binders) : (binders & Env.env & universes) = + let tps, env, g, us = tc_binders env0 tps in + Rel.force_trivial_guard env0 g; + tps, env, us + +//////////////////////////////////////////////////////////////////////////////// + +let rec __typeof_tot_or_gtot_term_fastpath (env:env) (t:term) (must_tot:bool) : option typ = + let mk_tm_type u = S.mk (Tm_type u) t.pos in + let effect_ok k = (not must_tot) || (N.non_info_norm env k) in + let t = SS.compress t in + match t.n with + | Tm_delayed _ + | Tm_bvar _ -> failwith ("Impossible: " ^ show t) + + (* Can't (easily) do this one efficiently, just return None *) + | Tm_constant (Const_reify _) + | Tm_constant (Const_reflect _) -> None + + //For the following nodes, use the universe_of_aux function + //since these are already Tot, we don't need to check the must_tot flag + // GM: calling universe_of for Tm_name/Tv_fvar here is a bit shady, + // sinc the variable may not represent a type. However universe_of_aux + // will currently simply return the sort of bv from the environment, + // be it Tm_type or not, and that's what we want here. + | Tm_name _ + | Tm_fvar _ + | Tm_uinst _ + | Tm_constant _ + | Tm_type _ + | Tm_arrow _ -> universe_of_aux env t |> Some + + | Tm_lazy i -> + __typeof_tot_or_gtot_term_fastpath env (U.unfold_lazy i) must_tot + + | Tm_abs {bs; body; rc_opt=Some ({residual_effect=eff; residual_typ=tbody})} -> //AR: maybe keep residual univ too? + let mk_comp = + if Ident.lid_equals eff Const.effect_Tot_lid + then Some S.mk_Total + else if Ident.lid_equals eff Const.effect_GTot_lid + then Some S.mk_GTotal + else None + in + bind_opt mk_comp (fun f -> + let tbody = + match tbody with + | Some _ -> tbody + | None -> + let bs, body = SS.open_term bs body in + BU.map_opt (__typeof_tot_or_gtot_term_fastpath (Env.push_binders env bs) body false) (SS.close bs) in + bind_opt tbody (fun tbody -> + let bs, tbody = SS.open_term bs tbody in + let u = universe_of (Env.push_binders env bs) tbody in + Some (U.arrow bs (f tbody)))) + + | Tm_abs _ -> None + + | Tm_refine {b=x} -> __typeof_tot_or_gtot_term_fastpath env x.sort must_tot + + (* Unary operators. Explicitly curry extra arguments *) + | Tm_app {hd={n=Tm_constant Const_range_of}; args=a::hd::rest} -> + let rest = hd::rest in //no 'as' clauses in F* yet, so we need to do this ugliness + let unary_op, _ = U.head_and_args t in + let head = mk (Tm_app {hd=unary_op; args=[a]}) (Range.union_ranges unary_op.pos (fst a).pos) in + let t = mk (Tm_app {hd=head; args=rest}) t.pos in + __typeof_tot_or_gtot_term_fastpath env t must_tot + + (* Binary operators *) + | Tm_app {hd={n=Tm_constant Const_set_range_of}; args=a1::a2::hd::rest} -> + let rest = hd::rest in //no 'as' clauses in F* yet, so we need to do this ugliness + let unary_op, _ = U.head_and_args t in + let head = mk (Tm_app {hd=unary_op; args=[a1; a2]}) (Range.union_ranges unary_op.pos (fst a1).pos) in + let t = mk (Tm_app {hd=head; args=rest}) t.pos in + __typeof_tot_or_gtot_term_fastpath env t must_tot + + | Tm_app {hd={n=Tm_constant Const_range_of}; args=[_]} -> + Some (t_range) + + | Tm_app {hd={n=Tm_constant Const_set_range_of}; args=[(t, _); _]} -> + __typeof_tot_or_gtot_term_fastpath env t must_tot + + | Tm_app {hd; args} -> + let t_hd = __typeof_tot_or_gtot_term_fastpath env hd must_tot in + bind_opt t_hd (fun t_hd -> + bind_opt (apply_well_typed env t_hd args) (fun t -> + if (effect_ok t) || + (List.for_all (fun (a, _) -> __typeof_tot_or_gtot_term_fastpath env a must_tot |> is_some) args) + then Some t + else None)) + + | Tm_ascribed {tm=t; asc=(Inl k, _, _)} -> + if effect_ok k + then Some k + else __typeof_tot_or_gtot_term_fastpath env t must_tot + + | Tm_ascribed {asc=(Inr c, _, _)} -> + let k = U.comp_result c in + if (not must_tot) || + (c |> U.comp_effect_name |> Env.norm_eff_name env |> lid_equals Const.effect_PURE_lid) || + (N.non_info_norm env k) + then Some k + else None + + | Tm_uvar (u, s) -> if not must_tot then Some (SS.subst' s (U.ctx_uvar_typ u)) else None + + | Tm_quoted (tm, qi) -> if not must_tot then Some (S.t_term) else None + + | Tm_meta {tm=t} -> __typeof_tot_or_gtot_term_fastpath env t must_tot + + | Tm_match {rc_opt=Some rc} -> rc.residual_typ + + | Tm_let {lbs=(false, [lb]); body} -> + let x = BU.left lb.lbname in + let xb, body = SS.open_term [S.mk_binder x] body in + let xbinder = List.hd xb in + let x = xbinder.binder_bv in + let env_x = Env.push_bv env x in + let t = __typeof_tot_or_gtot_term_fastpath env_x body must_tot in + bind_opt t (fun t -> + let t = FStarC.Syntax.Subst.close xb t in + Some t) + + | Tm_match _ -> None //unelaborated matches + | Tm_let _ -> None //recursive lets + | Tm_unknown + | _ -> failwith ("Impossible! (" ^ (tag_of t) ^ ")") + +(* + Pre-condition: exists k. env |- t : (G)Tot k + i.e., t is well-typed in env at some type k + + And t is Tot or GTot, meaning if it is PURE or GHOST, its wp has been accounted for + (which is the case for the terms in the unifier) + + Returns (Some k), if it can find k quickly and the effect of t is consistent with must_tot + + If either the type cannot be computed or effect does not match with must_tot, returns None + + A possible restructuring would be to treat these two (type and effect) separately + in the return type +*) +let typeof_tot_or_gtot_term_fastpath (env:env) (t:term) (must_tot:bool) : option typ = + def_check_scoped t.pos "fastpath" env t; + Errors.with_ctx + "In a call to typeof_tot_or_gtot_term_fastpath" + (fun () -> __typeof_tot_or_gtot_term_fastpath env t must_tot) + +(* + * Precondition: G |- t : Tot _ or G |- t : GTot _ + * Meaning, even if t is PURE or GHOST, its wp has been accounted for already, + * which is the case for terms in the unifier + * + * It returns either PURE or GHOST (or None if fast path fails) + *) +let rec effectof_tot_or_gtot_term_fastpath (env:env) (t:term) : option lident = + match (SS.compress t).n with + | Tm_delayed _ | Tm_bvar _ -> failwith "Impossible!" + + | Tm_name _ -> Const.effect_PURE_lid |> Some + | Tm_lazy _ -> Const.effect_PURE_lid |> Some + | Tm_fvar _ -> Const.effect_PURE_lid |> Some + | Tm_uinst _ -> Const.effect_PURE_lid |> Some + | Tm_constant _ -> Const.effect_PURE_lid |> Some + | Tm_type _ -> Const.effect_PURE_lid |> Some + | Tm_abs _ -> Const.effect_PURE_lid |> Some + | Tm_arrow _ -> Const.effect_PURE_lid |> Some + | Tm_refine _ -> Const.effect_PURE_lid |> Some + + | Tm_app {hd; args} -> + let join_effects eff1 eff2 = + let eff1, eff2 = Env.norm_eff_name env eff1, Env.norm_eff_name env eff2 in + let pure, ghost = Const.effect_PURE_lid, Const.effect_GHOST_lid in + + if lid_equals eff1 pure && lid_equals eff2 pure then Some pure + else if (lid_equals eff1 ghost || lid_equals eff1 pure) + && (lid_equals eff2 ghost || lid_equals eff2 pure) + then Some ghost + else None in + + bind_opt (effectof_tot_or_gtot_term_fastpath env hd) (fun eff_hd -> + bind_opt (List.fold_left (fun eff_opt arg -> + bind_opt eff_opt (fun eff -> + bind_opt (effectof_tot_or_gtot_term_fastpath env (fst arg)) + (join_effects eff))) (Some eff_hd) args) (fun eff_hd_and_args -> + bind_opt (typeof_tot_or_gtot_term_fastpath env hd true) (fun t_hd -> + let rec maybe_arrow t = + let t = N.unfold_whnf env t in + match t.n with + | Tm_arrow _ -> t + | Tm_refine {b=x} -> maybe_arrow x.sort + | Tm_ascribed {tm=t} -> maybe_arrow t + | _ -> t in + match (maybe_arrow t_hd).n with + | Tm_arrow {bs; comp=c} -> + let eff_app = + if List.length args < List.length bs + then Const.effect_PURE_lid + else U.comp_effect_name c in + join_effects eff_hd_and_args eff_app + | _ -> None))) + | Tm_ascribed {tm=t; asc=(Inl _, _, _)} -> effectof_tot_or_gtot_term_fastpath env t + | Tm_ascribed {asc=(Inr c, _, _)} -> + let c_eff = c |> U.comp_effect_name |> Env.norm_eff_name env in + if lid_equals c_eff Const.effect_PURE_lid || + lid_equals c_eff Const.effect_GHOST_lid + then Some c_eff + else None + | Tm_uvar _ -> None + | Tm_quoted _ -> None + | Tm_meta {tm=t} -> effectof_tot_or_gtot_term_fastpath env t + | Tm_match _ -> None + | Tm_let _ -> None + | Tm_unknown -> None + | Tm_uinst _ -> None + | _ -> None diff --git a/src/typechecker/FStarC.TypeChecker.TcTerm.fsti b/src/typechecker/FStarC.TypeChecker.TcTerm.fsti new file mode 100644 index 00000000000..3c1b03af993 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.TcTerm.fsti @@ -0,0 +1,58 @@ +(* + Copyright 2008-2016 Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.TypeChecker.TcTerm +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStar open FStarC +open FStarC.Compiler +open FStarC.TypeChecker +open FStarC.TypeChecker.Env +open FStarC.Compiler.Util +open FStarC.Ident +open FStarC.Syntax +open FStarC.Syntax.Syntax +open FStarC.Syntax.Subst +open FStarC.Syntax.Util +open FStarC.Const +open FStarC.TypeChecker.Rel +open FStarC.TypeChecker.Common + +val level_of_type: env -> term -> typ -> universe //the term argument is for error reporting only +val tc_constant: env -> FStarC.Compiler.Range.range -> sconst -> typ +val tc_binders: env -> binders -> binders & env & guard_t & universes +val tc_term: env -> term -> term & lcomp & guard_t +val tc_maybe_toplevel_term: env -> term -> term & lcomp & guard_t +val tc_comp: env -> comp -> comp & universe & guard_t +val tc_pat : Env.env -> typ -> pat -> pat & list bv & list term & Env.env & term & term & guard_t & bool +val typeof_tot_or_gtot_term: env -> term -> must_tot:bool -> term & typ & guard_t +val universe_of: env -> term -> universe +val typeof_tot_or_gtot_term_fastpath: env -> term -> Env.must_tot -> option typ + +val tc_tot_or_gtot_term: env -> term -> term & lcomp & guard_t +//the last string argument is the reason to be printed in the error message +//pass "" if NA +val tc_check_tot_or_gtot_term: env -> term -> typ -> option string -> term & lcomp & guard_t +val tc_tactic : typ -> typ -> env -> term -> term & lcomp & guard_t +val tc_trivial_guard: env -> term -> term & lcomp +val tc_attributes: env -> list term -> guard_t & list term +val tc_check_trivial_guard: env -> term -> term -> term + +val value_check_expected_typ: env -> term -> either typ lcomp -> guard_t -> term & lcomp & guard_t +val check_expected_effect: env -> use_eq:bool -> option comp -> (term & comp) -> term & comp & guard_t +val comp_check_expected_typ: env -> term -> lcomp -> term & lcomp & guard_t + +val tc_tparams: env_t -> binders -> (binders & Env.env & universes) diff --git a/src/typechecker/FStarC.TypeChecker.TermEqAndSimplify.fst b/src/typechecker/FStarC.TypeChecker.TermEqAndSimplify.fst new file mode 100644 index 00000000000..2a9b017480c --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.TermEqAndSimplify.fst @@ -0,0 +1,556 @@ +module FStarC.TypeChecker.TermEqAndSimplify +open FStarC +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.Syntax +open FStarC.Const +open FStarC.Ident +open FStarC.TypeChecker.Env +open FStarC.Syntax.Syntax +open FStarC.Syntax.Util +module SS = FStarC.Syntax.Subst +module U = FStarC.Syntax.Util +module PC = FStarC.Parser.Const +module S = FStarC.Syntax.Syntax +module BU = FStarC.Compiler.Util + +open FStarC.Class.Tagged +open FStarC.Class.Show + +// Functions that we specially treat as injective, to make normalization +// (particularly of decidable equality) better. We should make sure they +// are actually proved to be injective. +let injectives = + ["FStar.Int8.int_to_t"; + "FStar.Int16.int_to_t"; + "FStar.Int32.int_to_t"; + "FStar.Int64.int_to_t"; + "FStar.Int128.int_to_t"; + "FStar.UInt8.uint_to_t"; + "FStar.UInt16.uint_to_t"; + "FStar.UInt32.uint_to_t"; + "FStar.UInt64.uint_to_t"; + "FStar.UInt128.uint_to_t"; + "FStar.SizeT.uint_to_t"; + "FStar.Int8.__int_to_t"; + "FStar.Int16.__int_to_t"; + "FStar.Int32.__int_to_t"; + "FStar.Int64.__int_to_t"; + "FStar.Int128.__int_to_t"; + "FStar.UInt8.__uint_to_t"; + "FStar.UInt16.__uint_to_t"; + "FStar.UInt32.__uint_to_t"; + "FStar.UInt64.__uint_to_t"; + "FStar.UInt128.__uint_to_t"; + "FStar.SizeT.__uint_to_t"; + ] + +// Compose two eq_result injectively, as in a pair +let eq_inj r s = + match r, s with + | Equal, Equal -> Equal + | NotEqual, _ + | _, NotEqual -> NotEqual + | _, _ -> Unknown + +// Promote a bool to eq_result, conservatively. +let equal_if = function + | true -> Equal + | _ -> Unknown + +// Promote a bool to an eq_result, taking a false to bet NotEqual. +// This is only useful for fully decidable equalities. +// Use with care, see note about Const_real below and #2806. +let equal_iff = function + | true -> Equal + | _ -> NotEqual + +// Compose two equality results, NOT assuming a NotEqual implies anything. +// This is useful, e.g., for checking the equality of applications. Consider +// f x ~ g y +// if f=g and x=y then we know these two expressions are equal, but cannot say +// anything when either result is NotEqual or Unknown, hence this returns Unknown +// in most cases. +// The second comparison is thunked for efficiency. +let eq_and r s = + if r = Equal && s () = Equal + then Equal + else Unknown + +(* Precondition: terms are well-typed in a common environment, or this can return false positives *) +let rec eq_tm (env:env_t) (t1:term) (t2:term) : eq_result = + let t1 = canon_app t1 in + let t2 = canon_app t2 in + let equal_data (f1:S.fv) (args1:Syntax.args) (f2:fv) (args2:Syntax.args) (n_parms:int) = + // we got constructors! we know they are injective and disjoint, so we can do some + // good analysis on them + if fv_eq f1 f2 + then ( + let n1 = List.length args1 in + let n2 = List.length args2 in + if n1 = n2 && n_parms <= n1 + then ( + let parms1, args1 = List.splitAt n_parms args1 in + let parms2, args2 = List.splitAt n_parms args2 in + let eq_arg_list as1 as2 = + List.fold_left2 + (fun acc (a1, q1) (a2, q2) -> + //if q1 <> q2 + //then failwith (U.format1 "Arguments of %s mismatch on implicit qualifier\n" + // (Ident.string_of_lid f1.fv_name.v)); + //NS: 05/06/2018 ...this does not always hold + // it's been succeeding because the assert is disabled in the non-debug builds + //assert (q1 = q2); + eq_inj acc (eq_tm env a1 a2)) + Equal + as1 + as2 + in + eq_arg_list args1 args2 + ) + else Unknown + ) + else NotEqual + in + let qual_is_inj = function + | Some Data_ctor + | Some (Record_ctor _) -> true + | _ -> false + in + let heads_and_args_in_case_both_data : option (S.fv & args & S.fv & args & int) = + let head1, args1 = t1 |> unmeta |> head_and_args in + let head2, args2 = t2 |> unmeta |> head_and_args in + match (un_uinst head1).n, (un_uinst head2).n with + | Tm_fvar f, Tm_fvar g + when qual_is_inj f.fv_qual && + qual_is_inj g.fv_qual -> ( + match Env.num_datacon_non_injective_ty_params env (lid_of_fv f) with + | Some n -> Some (f, args1, g, args2, n) + | _ -> None + ) + | _ -> None + in + let t1 = unmeta t1 in + let t2 = unmeta t2 in + match t1.n, t2.n with + // We sometimes compare open terms, as we get alpha-equivalence + // for free. + | Tm_bvar bv1, Tm_bvar bv2 -> + equal_if (bv1.index = bv2.index) + + | Tm_lazy _, _ -> eq_tm env (unlazy t1) t2 + | _, Tm_lazy _ -> eq_tm env t1 (unlazy t2) + + | Tm_name a, Tm_name b -> + equal_if (bv_eq a b) + + | _ when heads_and_args_in_case_both_data |> Some? -> //matches only when both are data constructors + heads_and_args_in_case_both_data |> must |> (fun (f, args1, g, args2, n) -> + equal_data f args1 g args2 n + ) + + | Tm_fvar f, Tm_fvar g -> equal_if (fv_eq f g) + + | Tm_uinst(f, us), Tm_uinst(g, vs) -> + // If the fvars and universe instantiations match, then Equal, + // otherwise Unknown. + eq_and (eq_tm env f g) (fun () -> equal_if (eq_univs_list us vs)) + + | Tm_constant (Const_range _), Tm_constant (Const_range _) -> + // Ranges should be opaque, even to the normalizer. c.f. #1312 + Unknown + + | Tm_constant (Const_real r1), Tm_constant (Const_real r2) -> + // We cannot decide equality of reals. Use a conservative approach here. + // If the strings match, they are equal, otherwise we don't know. If this + // goes via the eq_iff case below, it will falsely claim that "1.0R" and + // "01.R" are different, since eq_const does not canonizalize the string + // representations. + equal_if (r1 = r2) + + | Tm_constant c, Tm_constant d -> + // NOTE: this relies on the fact that eq_const *correctly decides* + // semantic equality of constants. This needs some care. For instance, + // since integers are represented by a string, eq_const needs to take care + // of ignoring leading zeroes, and match 0 with -0. An exception to this + // are real number literals (handled above). See #2806. + // + // Currently (24/Jan/23) this seems to be correctly implemented, but + // updates should be done with care. + equal_iff (eq_const c d) + + | Tm_uvar (u1, ([], _)), Tm_uvar (u2, ([], _)) -> + equal_if (Unionfind.equiv u1.ctx_uvar_head u2.ctx_uvar_head) + + | Tm_app {hd=h1; args=args1}, Tm_app {hd=h2; args=args2} -> + begin match (un_uinst h1).n, (un_uinst h2).n with + | Tm_fvar f1, Tm_fvar f2 when fv_eq f1 f2 && List.mem (string_of_lid (lid_of_fv f1)) injectives -> + equal_data f1 args1 f2 args2 0 + + | _ -> // can only assert they're equal if they syntactically match, nothing else + eq_and (eq_tm env h1 h2) (fun () -> eq_args env args1 args2) + end + + | Tm_match {scrutinee=t1; brs=bs1}, Tm_match {scrutinee=t2; brs=bs2} -> //AR: note: no return annotations + if List.length bs1 = List.length bs2 + then List.fold_right (fun (b1, b2) a -> eq_and a (fun () -> branch_matches env b1 b2)) + (List.zip bs1 bs2) + (eq_tm env t1 t2) + else Unknown + + | Tm_type u, Tm_type v -> + equal_if (eq_univs u v) + + | Tm_quoted (t1, q1), Tm_quoted (t2, q2) -> + // NOTE: we do NOT ever provide a meaningful result for quoted terms. Even + // if term_eq (the syntactic equality) returns true, that does not mean we + // can present the equality to userspace since term_eq ignores the names + // of binders, but the view exposes them. Hence, we simply always return + // Unknown. We do not seem to rely anywhere on simplifying equalities of + // quoted literals. See also #2806. + Unknown + + | Tm_refine {b=t1; phi=phi1}, Tm_refine {b=t2; phi=phi2} -> + eq_and (eq_tm env t1.sort t2.sort) (fun () -> eq_tm env phi1 phi2) + + (* + * AR: ignoring residual comp here, that's an ascription added by the typechecker + * do we care if that's different? + *) + | Tm_abs {bs=bs1; body=body1}, Tm_abs {bs=bs2; body=body2} + when List.length bs1 = List.length bs2 -> + + eq_and (List.fold_left2 (fun r b1 b2 -> eq_and r (fun () -> eq_tm env b1.binder_bv.sort b2.binder_bv.sort)) + Equal bs1 bs2) + (fun () -> eq_tm env body1 body2) + + | Tm_arrow {bs=bs1; comp=c1}, Tm_arrow {bs=bs2; comp=c2} + when List.length bs1 = List.length bs2 -> + eq_and (List.fold_left2 (fun r b1 b2 -> eq_and r (fun () -> eq_tm env b1.binder_bv.sort b2.binder_bv.sort)) + Equal bs1 bs2) + (fun () -> eq_comp env c1 c2) + + | _ -> Unknown + +and eq_antiquotations (env:env_t) a1 a2 = + // Basically this; + // List.fold_left2 (fun acc t1 t2 -> eq_inj acc (eq_tm t1 t2)) Equal a1 a2 + // but lazy and handling lists of different size + match a1, a2 with + | [], [] -> Equal + | [], _ + | _, [] -> NotEqual + | t1::a1, t2::a2 -> + match eq_tm env t1 t2 with + | NotEqual -> NotEqual + | Unknown -> + (match eq_antiquotations env a1 a2 with + | NotEqual -> NotEqual + | _ -> Unknown) + | Equal -> eq_antiquotations env a1 a2 + +and branch_matches env b1 b2 = + let related_by f o1 o2 = + match o1, o2 with + | None, None -> true + | Some x, Some y -> f x y + | _, _ -> false + in + let (p1, w1, t1) = b1 in + let (p2, w2, t2) = b2 in + if eq_pat p1 p2 + then begin + // We check the `when` branches too, even if unsupported for now + if eq_tm env t1 t2 = Equal && related_by (fun t1 t2 -> eq_tm env t1 t2 = Equal) w1 w2 + then Equal + else Unknown + end + else Unknown + +and eq_args env (a1:args) (a2:args) : eq_result = + match a1, a2 with + | [], [] -> Equal + | (a, _)::a1, (b, _)::b1 -> + (match eq_tm env a b with + | Equal -> eq_args env a1 b1 + | _ -> Unknown) + | _ -> Unknown + +and eq_comp env (c1 c2:comp) : eq_result = + match c1.n, c2.n with + | Total t1, Total t2 + | GTotal t1, GTotal t2 -> + eq_tm env t1 t2 + | Comp ct1, Comp ct2 -> + eq_and (equal_if (eq_univs_list ct1.comp_univs ct2.comp_univs)) + (fun _ -> + eq_and (equal_if (Ident.lid_equals ct1.effect_name ct2.effect_name)) + (fun _ -> + eq_and (eq_tm env ct1.result_typ ct2.result_typ) + (fun _ -> eq_args env ct1.effect_args ct2.effect_args))) + //ignoring cflags + | _ -> NotEqual + +let eq_tm_bool e t1 t2 = eq_tm e t1 t2 = Equal + +let simplify (debug:bool) (env:env_t) (tm:term) : term = + let w t = {t with pos=tm.pos} in + let simp_t t = + // catch annotated subformulae too + match (U.unmeta t).n with + | Tm_fvar fv when S.fv_eq_lid fv PC.true_lid -> Some true + | Tm_fvar fv when S.fv_eq_lid fv PC.false_lid -> Some false + | _ -> None + in + let rec args_are_binders args bs = + match args, bs with + | (t, _)::args, b::bs -> + begin match (SS.compress t).n with + | Tm_name bv' -> S.bv_eq b.binder_bv bv' && args_are_binders args bs + | _ -> false + end + | [], [] -> true + | _, _ -> false + in + let is_applied (bs:binders) (t : term) : option bv = + if debug then + BU.print2 "WPE> is_applied %s -- %s\n" (show t) (tag_of t); + let hd, args = U.head_and_args_full t in + match (SS.compress hd).n with + | Tm_name bv when args_are_binders args bs -> + if debug then + BU.print3 "WPE> got it\n>>>>top = %s\n>>>>b = %s\n>>>>hd = %s\n" + (show t) + (show bv) + (show hd); + Some bv + | _ -> None + in + let is_applied_maybe_squashed (bs : binders) (t : term) : option bv = + if debug then + BU.print2 "WPE> is_applied_maybe_squashed %s -- %s\n" (show t) (tag_of t); + match is_squash t with + + | Some (_, t') -> is_applied bs t' + | _ -> begin match is_auto_squash t with + | Some (_, t') -> is_applied bs t' + | _ -> is_applied bs t + end + in + let is_const_match (phi : term) : option bool = + match (SS.compress phi).n with + (* Trying to be efficient, but just checking if they all agree *) + (* Note, if we wanted to do this for any term instead of just True/False + * we need to open the terms *) + | Tm_match {brs=br::brs} -> + let (_, _, e) = br in + let r = begin match simp_t e with + | None -> None + | Some b -> if List.for_all (fun (_, _, e') -> simp_t e' = Some b) brs + then Some b + else None + end + in + r + | _ -> None + in + let maybe_auto_squash t = + if U.is_sub_singleton t + then t + else U.mk_auto_squash U_zero t + in + let squashed_head_un_auto_squash_args t = + //The head of t is already a squashed operator, e.g. /\ etc. + //no point also squashing its arguments if they're already in U_zero + let maybe_un_auto_squash_arg (t,q) = + match U.is_auto_squash t with + | Some (U_zero, t) -> + //if we're squashing from U_zero to U_zero + // then just remove it + t, q + | _ -> + t,q + in + let head, args = U.head_and_args t in + let args = List.map maybe_un_auto_squash_arg args in + S.mk_Tm_app head args t.pos + in + let rec clearly_inhabited (ty : typ) : bool = + match (U.unmeta ty).n with + | Tm_uinst (t, _) -> clearly_inhabited t + | Tm_arrow {comp=c} -> clearly_inhabited (U.comp_result c) + | Tm_fvar fv -> + let l = S.lid_of_fv fv in + (Ident.lid_equals l PC.int_lid) + || (Ident.lid_equals l PC.bool_lid) + || (Ident.lid_equals l PC.string_lid) + || (Ident.lid_equals l PC.exn_lid) + | _ -> false + in + let simplify arg = (simp_t (fst arg), arg) in + match (SS.compress tm).n with + | Tm_app {hd={n=Tm_uinst({n=Tm_fvar fv}, _)}; args} + | Tm_app {hd={n=Tm_fvar fv}; args} -> + if S.fv_eq_lid fv PC.squash_lid + then squashed_head_un_auto_squash_args tm + else if S.fv_eq_lid fv PC.and_lid + then match args |> List.map simplify with + | [(Some true, _); (_, (arg, _))] + | [(_, (arg, _)); (Some true, _)] -> maybe_auto_squash arg + | [(Some false, _); _] + | [_; (Some false, _)] -> w U.t_false + | _ -> squashed_head_un_auto_squash_args tm + else if S.fv_eq_lid fv PC.or_lid + then match args |> List.map simplify with + | [(Some true, _); _] + | [_; (Some true, _)] -> w U.t_true + | [(Some false, _); (_, (arg, _))] + | [(_, (arg, _)); (Some false, _)] -> maybe_auto_squash arg + | _ -> squashed_head_un_auto_squash_args tm + else if S.fv_eq_lid fv PC.imp_lid + then match args |> List.map simplify with + | [_; (Some true, _)] + | [(Some false, _); _] -> w U.t_true + | [(Some true, _); (_, (arg, _))] -> maybe_auto_squash arg + | [(_, (p, _)); (_, (q, _))] -> + if U.term_eq p q + then w U.t_true + else squashed_head_un_auto_squash_args tm + | _ -> squashed_head_un_auto_squash_args tm + else if S.fv_eq_lid fv PC.iff_lid + then match args |> List.map simplify with + | [(Some true, _) ; (Some true, _)] + | [(Some false, _) ; (Some false, _)] -> w U.t_true + | [(Some true, _) ; (Some false, _)] + | [(Some false, _) ; (Some true, _)] -> w U.t_false + | [(_, (arg, _)) ; (Some true, _)] + | [(Some true, _) ; (_, (arg, _))] -> maybe_auto_squash arg + | [(_, (arg, _)) ; (Some false, _)] + | [(Some false, _) ; (_, (arg, _))] -> maybe_auto_squash (U.mk_neg arg) + | [(_, (p, _)); (_, (q, _))] -> + if U.term_eq p q + then w U.t_true + else squashed_head_un_auto_squash_args tm + | _ -> squashed_head_un_auto_squash_args tm + else if S.fv_eq_lid fv PC.not_lid + then match args |> List.map simplify with + | [(Some true, _)] -> w U.t_false + | [(Some false, _)] -> w U.t_true + | _ -> squashed_head_un_auto_squash_args tm + else if S.fv_eq_lid fv PC.forall_lid + then match args with + (* Simplify ∀x. True to True *) + | [(t, _)] -> + begin match (SS.compress t).n with + | Tm_abs {bs=[_]; body} -> + (match simp_t body with + | Some true -> w U.t_true + | _ -> tm) + | _ -> tm + end + (* Simplify ∀x. True to True, and ∀x. False to False, if the domain is not empty *) + | [(ty, Some ({ aqual_implicit = true })); (t, _)] -> + begin match (SS.compress t).n with + | Tm_abs {bs=[_]; body} -> + (match simp_t body with + | Some true -> w U.t_true + | Some false when clearly_inhabited ty -> w U.t_false + | _ -> tm) + | _ -> tm + end + | _ -> tm + else if S.fv_eq_lid fv PC.exists_lid + then match args with + (* Simplify ∃x. False to False *) + | [(t, _)] -> + begin match (SS.compress t).n with + | Tm_abs {bs=[_]; body} -> + (match simp_t body with + | Some false -> w U.t_false + | _ -> tm) + | _ -> tm + end + (* Simplify ∃x. False to False and ∃x. True to True, if the domain is not empty *) + | [(ty, Some ({ aqual_implicit = true })); (t, _)] -> + begin match (SS.compress t).n with + | Tm_abs {bs=[_]; body} -> + (match simp_t body with + | Some false -> w U.t_false + | Some true when clearly_inhabited ty -> w U.t_true + | _ -> tm) + | _ -> tm + end + | _ -> tm + else if S.fv_eq_lid fv PC.b2t_lid + then match args with + | [{n=Tm_constant (Const_bool true)}, _] -> w U.t_true + | [{n=Tm_constant (Const_bool false)}, _] -> w U.t_false + | _ -> tm //its arg is a bool, can't unsquash + else if S.fv_eq_lid fv PC.haseq_lid + then begin + (* + * AR: We try to mimic the hasEq related axioms in Prims + * and the axiom related to refinements + * For other types, such as lists, whose hasEq is derived by the typechecker, + * we leave them as is + *) + let t_has_eq_for_sure (t:S.term) :bool = + //Axioms from prims + let haseq_lids = [PC.int_lid; PC.bool_lid; PC.unit_lid; PC.string_lid] in + match (SS.compress t).n with + | Tm_fvar fv when haseq_lids |> List.existsb (fun l -> S.fv_eq_lid fv l) -> true + | _ -> false + in + if List.length args = 1 then + let t = args |> List.hd |> fst in + if t |> t_has_eq_for_sure then w U.t_true + else + match (SS.compress t).n with + | Tm_refine _ -> + let t = U.unrefine t in + if t |> t_has_eq_for_sure then w U.t_true + else + //get the hasEq term itself + let haseq_tm = + match (SS.compress tm).n with + | Tm_app {hd} -> hd + | _ -> failwith "Impossible! We have already checked that this is a Tm_app" + in + //and apply it to the unrefined type + mk_app (haseq_tm) [t |> as_arg] + | _ -> tm + else tm + end + else if S.fv_eq_lid fv PC.eq2_lid + then match args with + | [(_typ, _); (a1, _); (a2, _)] -> //eq2 + (match eq_tm env a1 a2 with + | Equal -> w U.t_true + | NotEqual -> w U.t_false + | _ -> tm) + | _ -> tm + else + begin + match U.is_auto_squash tm with + | Some (U_zero, t) + when U.is_sub_singleton t -> + //remove redundant auto_squashes + t + | _ -> + tm + end + | Tm_refine {b=bv; phi=t} -> + begin match simp_t t with + | Some true -> bv.sort + | Some false -> tm + | None -> tm + end + | Tm_match _ -> + begin match is_const_match tm with + | Some true -> w U.t_true + | Some false -> w U.t_false + | None -> tm + end + | _ -> tm diff --git a/src/typechecker/FStarC.TypeChecker.TermEqAndSimplify.fsti b/src/typechecker/FStarC.TypeChecker.TermEqAndSimplify.fsti new file mode 100644 index 00000000000..1d31266665f --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.TermEqAndSimplify.fsti @@ -0,0 +1,16 @@ +module FStarC.TypeChecker.TermEqAndSimplify +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.TypeChecker.Env +open FStarC.Syntax.Syntax + +type eq_result = + | Equal + | NotEqual + | Unknown + +val eq_tm (_:env_t) (t1 t2:term) : eq_result +val eq_args (_:env_t) (t1 t2:args) : eq_result +val eq_comp (_:env_t) (t1 t2:comp) : eq_result +val eq_tm_bool (e:env_t) (t1 t2:term) : bool +val simplify (debug:bool) (_:env_t) (_:term) : term diff --git a/src/typechecker/FStarC.TypeChecker.Util.fst b/src/typechecker/FStarC.TypeChecker.Util.fst new file mode 100644 index 00000000000..d2eca1faae6 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Util.fst @@ -0,0 +1,3770 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.TypeChecker.Util +open FStar.Pervasives +open FStarC.Compiler.Effect +open FStarC.Compiler.List +open FStar open FStarC +open FStarC.Compiler +open FStarC.Compiler.Util +open FStarC.Errors +open FStarC.Errors.Msg +open FStarC.Pprint +open FStarC.Defensive +open FStarC.TypeChecker +open FStarC.TypeChecker.Common +open FStarC.TypeChecker.Env +open FStarC.TypeChecker.Rel +open FStarC.Syntax.Syntax +open FStarC.Ident +open FStarC.Syntax.Subst +open FStarC.Syntax +open FStarC.Dyn +open FStarC.Class.Show +open FStarC.Class.PP +open FStarC.Class.Monoid + +module Listlike = FStarC.Class.Listlike + +module SS = FStarC.Syntax.Subst +module S = FStarC.Syntax.Syntax +module BU = FStarC.Compiler.Util +module U = FStarC.Syntax.Util +module N = FStarC.TypeChecker.Normalize +module TcComm = FStarC.TypeChecker.Common +module P = FStarC.Syntax.Print +module C = FStarC.Parser.Const +module UF = FStarC.Syntax.Unionfind +module TEQ = FStarC.TypeChecker.TermEqAndSimplify + +open FStarC.Class.Setlike + +let dbg_bind = Debug.get_toggle "Bind" +let dbg_Coercions = Debug.get_toggle "Coercions" +let dbg_Dec = Debug.get_toggle "Dec" +let dbg_Extraction = Debug.get_toggle "Extraction" +let dbg_LayeredEffects = Debug.get_toggle "LayeredEffects" +let dbg_LayeredEffectsApp = Debug.get_toggle "LayeredEffectsApp" +let dbg_Pat = Debug.get_toggle "Pat" +let dbg_Rel = Debug.get_toggle "Rel" +let dbg_ResolveImplicitsHook = Debug.get_toggle "ResolveImplicitsHook" +let dbg_Return = Debug.get_toggle "Return" +let dbg_Simplification = Debug.get_toggle "Simplification" +let dbg_SMTEncodingReify = Debug.get_toggle "SMTEncodingReify" + +(************************************************************************) +(* Unification variables *) +(************************************************************************) +let new_implicit_var reason r env k unrefine = + Env.new_implicit_var_aux reason r env k Strict None unrefine + +let close_guard_implicits env solve_deferred (xs:binders) (g:guard_t) : guard_t = + if Options.eager_subtyping () + || solve_deferred + then + let solve_now, defer = + g.deferred |> Listlike.to_list |> List.partition (fun (_, _, p) -> Rel.flex_prob_closing env xs p) + in + if !dbg_Rel + then begin + BU.print_string "SOLVE BEFORE CLOSING:\n"; + List.iter (fun (_, s, p) -> BU.print2 "%s: %s\n" s (Rel.prob_to_string env p)) solve_now; + BU.print_string " ...DEFERRED THE REST:\n"; + List.iter (fun (_, s, p) -> BU.print2 "%s: %s\n" s (Rel.prob_to_string env p)) defer; + BU.print_string "END\n" + end; + let g = Rel.solve_non_tactic_deferred_constraints false env ({g with deferred = Listlike.from_list solve_now}) in + let g = {g with deferred = Listlike.from_list defer} in + g + else g + +let check_uvars r t = + let uvs = Free.uvars t in + if not (is_empty uvs) then begin + (* ignoring the hide_uvar_nums and print_implicits flags here *) + Options.push(); + Options.set_option "hide_uvar_nums" (Options.Bool false); + Options.set_option "print_implicits" (Options.Bool true); + Errors.log_issue r Errors.Error_UncontrainedUnificationVar + (BU.format2 "Unconstrained unification variables %s in type signature %s; \ + please add an annotation" (show uvs) (show t)); + Options.pop() + end + +(************************************************************************) +(* Extracting annotations, notably the decreases clause, for a recursive definion *) +(* We support several styles of writing decreases clauses: + + 1. val f (x:t) : Tot t' (decreases d) + let rec f x = e + + and variations such as the following, where the definition is + partially annotated. + + val f (x:t) : Tot t' (decreases d) + let rec f (x:t) : t' = e + + 2. val f (x:t) : Tot t' + let rec f x : Tot _ (decreases d) = e + + 3. let rec f (x:t) : Tot t' (decreases d) = e + + 4. let rec f x = e + + The first style is mainly for legacy reasons. Annotating a `val` + with a decreases clause isn't pretty, but there is a fair bit of + code using it. + + The second style is useful in conjunction with interfaces, where + the val may appear in the interface and is defined using a + recursive function separately. It may also be useful when the user + wants to check the type of f first and separately from the + definition, and then try to define it afterwards. + + The third style is common in another scenarios. + + The fourth style leaves it to type inference to figure output. + + A fifth style is the following: + + 5. val f (x:t) : Tot t (decreases d) + let rec f (x:t) : Tot t' (decreases d) = e + + where the decreases clause appears more than once. This style now + raises a warning. + + In the function below, + extract_let_rec_annotation env lb + + the general idea is to + + 1. prefer the decreases clause annotated on the + term, if any + + 2. Remove the decreases clause from the ascription on the body + + 3. construct a type with the decreases clause and use that as the + lbtyp, which TcTerm will use to implement the termination + check + + returns the following: + + - lb.univ_vars: The opened universe names for the letbinding + (incidentally, they are the same as the input univ_vars) + + - lbtyp: This is the type to be used to check the recursive + definition. + + - In case 1, it is simply the annotated type from the + val, i.e., lb.lbtyp + + - In case 2, we lift the decreases clause from the ascription + and return `x:t -> Tot t' (decreases d)` + + - In case 3, it is simply the ascribed type + + - In case 4, just build a type `_ -> _` and return it + + - In case 5, warn and ignore the decrease clause on the val, + and treat it as case 2 + + - lbdef: lb.lbdef adapted to remove any decreases clause annotation + + - check: A flag that signals when the constructed type should be + re-typechecked. Except in case 1, the flag is set. +*) +(************************************************************************) +let extract_let_rec_annotation env {lbname=lbname; lbunivs=univ_vars; lbtyp=t; lbdef=e} : + list univ_name + & typ + & term + & bool //true indicates that the type needs to be checked; false indicates that it is already checked + = + let rng = S.range_of_lbname lbname in + let t = SS.compress t in + let u_subst, univ_vars = SS.univ_var_opening univ_vars in + let e = SS.subst u_subst e in + let t = SS.subst u_subst t in + if !dbg_Dec + then BU.print2 "extract_let_rec_annotation lbdef=%s; lbtyp=%s\n" + (show e) + (show t); + let env = Env.push_univ_vars env univ_vars in + let un_arrow t = + //Rather than use U.arrow_formals_comp, we use un_arrow here + //since the former collapses adjacent Tot annotations, e.g., + // x:t -> Tot (y:t -> M) + // is collapsed, possibly breaking arities. + match (SS.compress t).n with + | Tm_arrow {bs; comp=c} -> + Subst.open_comp bs c + | _ -> + raise_error rng Errors.Fatal_LetRecArgumentMismatch [ + text "Recursive functions must be introduced at arrow types."; + ] + in + let reconcile_let_rec_ascription_and_body_type tarr lbtyp_opt = + let get_decreases c = + U.comp_flags c |> BU.prefix_until (function DECREASES _ -> true | _ -> false) + in + let fallback () = + let bs, c = U.arrow_formals_comp tarr in + match get_decreases c with + | Some (pfx, DECREASES d, sfx) -> + let c = Env.comp_set_flags env c (pfx @ sfx) in + U.arrow bs c, tarr, true + | _ -> tarr, tarr, true + in + match lbtyp_opt with + | None -> + fallback() + + | Some annot -> + let bs, c = un_arrow tarr in + let n_bs = List.length bs in + let bs', c' = N.get_n_binders env n_bs annot in + if List.length bs' <> n_bs + then raise_error rng Errors.Fatal_LetRecArgumentMismatch [ + text "Arity mismatch on let rec annotation"; + text "(explain)"; + ]; + let move_decreases d flags flags' = + let d' = + let s = U.rename_binders bs bs' in + SS.subst_decreasing_order s d + in + let c = Env.comp_set_flags (Env.push_binders env bs) c flags in + let tarr = U.arrow bs c in + let c' = Env.comp_set_flags (Env.push_binders env bs') c' (DECREASES d'::flags') in + let tannot = U.arrow bs' c' in + tarr, tannot, true + in + match get_decreases c, get_decreases c' with + | None, _ -> tarr, annot, false + | Some (pfx, DECREASES d, sfx), Some (pfx', DECREASES d', sfx') -> + Errors.log_issue rng Warning_DeprecatedGeneric [ + text "This definitions has multiple decreases clauses."; + text "The decreases clause on the declaration is ignored, please remove it." + ]; + move_decreases d (pfx@sfx) (pfx'@sfx') + | Some (pfx, DECREASES d, sfx), None -> + move_decreases d (pfx@sfx) (U.comp_flags c') + | _ -> failwith "Impossible" + in + let extract_annot_from_body (lbtyp_opt:option typ) + : typ + & term + & bool + = let rec aux_lbdef e + : typ & term & bool + = let e = SS.compress e in + match e.n with + | Tm_meta {tm=e';meta=m} -> + let t, e', recheck = aux_lbdef e' in + t, { e with n = Tm_meta {tm=e'; meta=m} }, recheck + + | Tm_ascribed {tm=e'; asc=(Inr c, tac_opt, use_eq); eff_opt=lopt} -> + if U.is_total_comp c + then let t, lbtyp, recheck = reconcile_let_rec_ascription_and_body_type (U.comp_result c) lbtyp_opt in + let e = { e with n = Tm_ascribed {tm=e'; + asc=(Inr (S.mk_Total t), tac_opt, use_eq); + eff_opt=lopt} } in + lbtyp, e, recheck + else raise_error rng Errors.Fatal_UnexpectedComputationTypeForLetRec [ + text "Expected a 'let rec' to be annotated with a value type"; + text "Got a computation type" ^/^ pp c ^/^ text "instead"; + ] + + | Tm_ascribed {tm=e'; asc=(Inl t, tac_opt, use_eq); eff_opt=lopt} -> + let t, lbtyp, recheck = reconcile_let_rec_ascription_and_body_type t lbtyp_opt in + let e = { e with n = Tm_ascribed {tm=e'; asc=(Inl t, tac_opt, use_eq); eff_opt=lopt} } in + lbtyp, e, recheck + + | Tm_abs _ -> + let bs, body, rcopt = U.abs_formals_maybe_unascribe_body false e in + let mk_comp t = + if Options.ml_ish() + then U.ml_comp t t.pos + else S.mk_Total t + in + let mk_arrow c = U.arrow bs c in + let rec aux_abs_body body = + let body = SS.compress body in + match body.n with + | Tm_meta {tm=body; meta=m} -> + let t, body', recheck = aux_abs_body body in + let body = { body with n = Tm_meta {tm=body'; meta=m} } in + t, body, recheck + + | Tm_ascribed {asc=(Inl t, _, use_eq)} -> //no decreases clause here + // + //AR: In this case, the type in the ascription is moving to lbtyp + // if use_eq is true, then we are in trouble + // since we don't yet support equality in lbtyp + // + if use_eq + then raise_error t Errors.Fatal_NotSupported [ + text "Equality ascription in this case" ^/^ parens (pp t) ^/^ text "is not yet supported."; + text "Please use subtyping instead"; + ]; + begin + match lbtyp_opt with + | Some lbtyp -> + lbtyp, body, false + + | None -> + let t = mk_arrow (mk_comp t) in + t, body, true + end + + | Tm_ascribed {tm=body'; asc=(Inr c, tac_opt, use_eq); eff_opt=lopt} -> + let tarr = mk_arrow c in + let tarr, lbtyp, recheck = reconcile_let_rec_ascription_and_body_type tarr lbtyp_opt in + let n_bs = List.length bs in + let bs', c = N.get_n_binders env n_bs tarr in + if List.length bs' <> n_bs + then failwith "Impossible" + else let subst = U.rename_binders bs' bs in + let c = SS.subst_comp subst c in + let body = { body with n = Tm_ascribed {tm=body'; + asc=(Inr c, tac_opt, use_eq); + eff_opt=lopt} } in + lbtyp, body, recheck + + | _ -> + match lbtyp_opt with + | Some lbtyp -> + lbtyp, body, false + + | None -> + let tarr = mk_arrow (mk_comp S.tun) in + tarr, body, true + in + let lbtyp, body, recheck = aux_abs_body body in + lbtyp, U.abs bs body rcopt, recheck + + | _ -> + raise_error e Errors.Fatal_UnexpectedComputationTypeForLetRec [ + text "The definition of a 'let rec' must be a function literal"; + text "Got" ^/^ pp e ^/^ text "instead"; + ] + in + aux_lbdef e + in + match t.n with + | Tm_unknown -> + let lbtyp, e, _ = extract_annot_from_body None in + univ_vars, lbtyp, e, true + + | _ -> + let _, c = U.arrow_formals_comp t in + if not (U.comp_effect_name c |> Env.lookup_effect_quals env |> List.contains TotalEffect) + then //no termination check anyway, so don't bother rearranging decreases clauses + univ_vars, t, e, false + else + let lbtyp, e, check_lbtyp = extract_annot_from_body (Some t) in + univ_vars, lbtyp, e, check_lbtyp + +(************************************************************************) +(* Utilities on patterns *) +(************************************************************************) + +//let decorate_pattern env p exp = +// let qq = p in +// let rec aux p e : pat = +// let pkg q = withinfo q p.p in +// let e = U.unmeta e in +// match p.v, e.n with +// | _, Tm_uinst(e, _) -> aux p e + +// | Pat_constant _, _ -> +// pkg p.v + +// | Pat_var x, Tm_name y -> +// if not (bv_eq x y) +// then failwith (BU.format2 "Expected pattern variable %s; got %s" (show x) (show y)); +// if !dbg_Pat +// then BU.print2 "Pattern variable %s introduced at type %s\n" (show x) (Normalize.term_to_string env y.sort); +// let s = Normalize.normalize [Env.Beta] env y.sort in +// let x = {x with sort=s} in +// pkg (Pat_var x) + +// | Pat_wild x, Tm_name y -> +// if bv_eq x y |> not +// then failwith (BU.format2 "Expected pattern variable %s; got %s" (show x) (show y)); +// let s = Normalize.normalize [Env.Beta] env y.sort in +// let x = {x with sort=s} in +// pkg (Pat_wild x) + +// | Pat_dot_term(x, _), _ -> +// pkg (Pat_dot_term(x, e)) + +// | Pat_cons(fv, []), Tm_fvar fv' -> +// if not (Syntax.fv_eq fv fv') +// then failwith (BU.format2 "Expected pattern constructor %s; got %s" (string_of_lid fv.fv_name.v) (string_of_lid fv'.fv_name.v)); +// pkg (Pat_cons(fv', [])) + +// | Pat_cons(fv, argpats), Tm_app({n=Tm_fvar(fv')}, args) +// | Pat_cons(fv, argpats), Tm_app({n=Tm_uinst({n=Tm_fvar(fv')}, _)}, args) -> + +// if fv_eq fv fv' |> not +// then failwith (BU.format2 "Expected pattern constructor %s; got %s" (string_of_lid fv.fv_name.v) (string_of_lid fv'.fv_name.v)); + +// let fv = fv' in +// let rec match_args matched_pats args argpats = match args, argpats with +// | [], [] -> pkg (Pat_cons(fv, List.rev matched_pats)) +// | arg::args, (argpat, _)::argpats -> +// begin match arg, argpat.v with +// | (e, Some (Implicit true)), Pat_dot_term _ -> +// let x = Syntax.new_bv (Some p.p) S.tun in +// let q = withinfo (Pat_dot_term(x, e)) p.p in +// match_args ((q, true)::matched_pats) args argpats + +// | (e, imp), _ -> +// let pat = aux argpat e, S.is_implicit imp in +// match_args (pat::matched_pats) args argpats +// end + +// | _ -> failwith (BU.format2 "Unexpected number of pattern arguments: \n\t%s\n\t%s\n" (show p) (show e)) in + +// match_args [] args argpats + +// | _ -> +// failwith (BU.format3 +// "(%s) Impossible: pattern to decorate is %s; expression is %s\n" +// (Range.string_of_range qq.p) +// (show qq) +// (show exp)) +// in +// aux p exp + + let rec decorated_pattern_as_term (pat:pat) : list bv & term = + let mk f : term = mk f pat.p in + + let pat_as_arg (p, i) = + let vars, te = decorated_pattern_as_term p in + vars, (te, S.as_aqual_implicit i) + in + match pat.v with + | Pat_constant c -> + [], mk (Tm_constant c) + + | Pat_var x -> + [x], mk (Tm_name x) + + | Pat_cons(fv, us_opt, pats) -> + let vars, args = pats |> List.map pat_as_arg |> List.unzip in + let vars = List.flatten vars in + let head = Syntax.fv_to_tm fv in + let head = + match us_opt with + | None -> head + | Some us -> S.mk_Tm_uinst head us + in + vars, mk (Tm_app {hd=head; args}) + + | Pat_dot_term eopt -> + (match eopt with + | None -> failwith "TcUtil::decorated_pattern_as_term: dot pattern not resolved" + | Some e -> [], e) + + +(*********************************************************************************************) +(* Utils related to monadic computations *) +(*********************************************************************************************) + +let comp_univ_opt c = + match c.n with + | Total _ | GTotal _ -> None + | Comp c -> + match c.comp_univs with + | [] -> None + | hd::_ -> Some hd + +let lcomp_univ_opt lc = lc |> TcComm.lcomp_comp |> (fun (c, g) -> comp_univ_opt c, g) + +let destruct_wp_comp c : (universe & typ & typ) = U.destruct_comp c + +let mk_comp_l mname u_result result wp flags = + mk_Comp ({ comp_univs=[u_result]; + effect_name=mname; + result_typ=result; + effect_args=[S.as_arg wp]; + flags=flags}) + +let mk_comp md = mk_comp_l md.mname + +let effect_args_from_repr (repr:term) (is_layered:bool) (r:Range.range) : list term = + let err () = + raise_error r Errors.Fatal_UnexpectedEffect [ + text "Could not get effect args from repr" ^/^ pp repr ^/^ text "with is_layered=" ^^ pp is_layered + ] + in + let repr = SS.compress repr in + if is_layered + then match repr.n with + | Tm_app {args=_::is} -> is |> List.map fst + | _ -> err () + else match repr.n with + | Tm_arrow {comp=c} -> c |> U.comp_eff_name_res_and_args |> (fun (_, _, args) -> args |> List.map fst) + | _ -> err () + + +(* + * Build the M.return comp for a wp effect + * + * Caller must ensure that ed is a wp-based effect + *) +let mk_wp_return env (ed:S.eff_decl) (u_a:universe) (a:typ) (e:term) (r:Range.range) +: comp += let c = + if not <| Env.lid_exists env C.effect_GTot_lid //we're still in prims, not yet having fully defined the primitive effects + then mk_Total a + else if U.is_unit a + then S.mk_Total a + else let wp = + if Options.lax() + && Options.ml_ish() //NS: Disabling this optimization temporarily + then S.tun + else let ret_wp = ed |> U.get_return_vc_combinator in + mk_Tm_app + (inst_effect_fun_with [u_a] env ed ret_wp) + [S.as_arg a; S.as_arg e] + e.pos in + mk_comp ed u_a a wp [RETURN] + in + if !dbg_Return + then BU.print3 "(%s) returning %s at comp type %s\n" + (Range.string_of_range e.pos) + (show e) + (N.comp_to_string env c); + c + +let label reason r f : term = + mk (Tm_meta {tm=f; meta=Meta_labeled(reason, r, false)}) f.pos + +let label_opt env reason r f = match reason with + | None -> f + | Some reason -> + if not <| Env.should_verify env + then f + else label (reason()) r f + +let label_guard r reason (g:guard_t) = match g.guard_f with + | Trivial -> g + | NonTrivial f -> {g with guard_f=NonTrivial (label reason r f)} + +let lift_comp env (c:comp_typ) lift : comp & guard_t = + ({ c with flags = [] }) |> S.mk_Comp |> lift.mlift_wp env + +let join_effects env l1_in l2_in = + let l1, l2 = Env.norm_eff_name env l1_in, Env.norm_eff_name env l2_in in + match Env.join_opt env l1 l2 with + | Some (m, _, _) -> m + | None -> + match Env.exists_polymonadic_bind env l1 l2 with + | Some (m, _) -> m + | None -> + raise_error env Errors.Fatal_EffectsCannotBeComposed [ + text "Effects" ^/^ pp l1_in ^/^ text "and" ^/^ pp l2_in ^/^ text "cannot be composed" + ] + +let join_lcomp env c1 c2 = + if TcComm.is_total_lcomp c1 + && TcComm.is_total_lcomp c2 + then C.effect_Tot_lid + else join_effects env c1.eff_name c2.eff_name + +// GM, 2023/01/30: This is here to make c2 well-scoped in lift_comps_sep_guards +// below. Is it needed to push a null_binder, as below, when b is None? Not for +// scoping, at least. +let maybe_push (env : Env.env) (b : option bv) : Env.env = + match b with + | None -> env + | Some bv -> Env.push_bv env bv + +(* + * This functions returns the two lifted computations, + * and guards for each of them + * + * The separate guards are important when it is called from the pattern matching code (bind_cases) + * where the two guards are weakened using different branch conditions + *) +let lift_comps_sep_guards env c1 c2 (b:option bv) (for_bind:bool) +: lident & comp & comp & guard_t & guard_t = + let c1 = Env.unfold_effect_abbrev env c1 in + let env2 = maybe_push env b in + let c2 = Env.unfold_effect_abbrev env2 c2 in + match Env.join_opt env c1.effect_name c2.effect_name with + | Some (m, lift1, lift2) -> + let c1, g1 = lift_comp env c1 lift1 in + let c2, g2 = + if not for_bind then lift_comp env2 c2 lift2 + else + let x_a = + match b with + | None -> S.null_binder (U.comp_result c1) + | Some x -> S.mk_binder x in + let env_x = Env.push_binders env [x_a] in + let c2, g2 = lift_comp env_x c2 lift2 in + c2, Env.close_guard env [x_a] g2 in + m, c1, c2, g1, g2 + | None -> + raise_error env Errors.Fatal_EffectsCannotBeComposed [ + text "Effects" ^/^ pp c1.effect_name ^/^ text "and" ^/^ pp c2.effect_name ^/^ text "cannot be composed" + ] + +let lift_comps env c1 c2 (b:option bv) (for_bind:bool) + : lident & comp & comp & guard_t = + let l, c1, c2, g1, g2 = lift_comps_sep_guards + env + c1 + c2 + b + for_bind in + l, c1, c2, Env.conj_guard g1 g2 + +let is_pure_effect env l = + let l = norm_eff_name env l in + lid_equals l C.effect_PURE_lid + +let is_ghost_effect env l = + let l = norm_eff_name env l in + lid_equals l C.effect_GHOST_lid + +let is_pure_or_ghost_effect env l = + let l = norm_eff_name env l in + lid_equals l C.effect_PURE_lid + || lid_equals l C.effect_GHOST_lid + +let lax_mk_tot_or_comp_l mname u_result result flags = + if Ident.lid_equals mname C.effect_Tot_lid + then S.mk_Total result + else mk_comp_l mname u_result result S.tun flags + +let is_function t = match (compress t).n with + | Tm_arrow _ -> true + | _ -> false + +let close_wp_comp env bvs (c:comp) = + def_check_scoped c.pos "close_wp_comp" (Env.push_bvs env bvs) c; + if U.is_ml_comp c then c + else if Options.lax() + && Options.ml_ish() //NS: disabling this optimization temporarily + then c + else begin + (* + * We make an environment containing all the BVs so the calls + * to env.universe_of and unfold_effect_abbrev below are properly scoped. + * Note: this only works since variables in the environment are named and + * fresh, so it is OK to use a larger environment to check a term. + *) + let env_bvs = Env.push_bvs env bvs in + let close_wp u_res md res_t bvs wp0 = + let close = md |> U.get_wp_close_combinator |> must in + List.fold_right (fun x wp -> + let bs = [mk_binder x] in + let us = u_res::[env.universe_of env_bvs x.sort] in + let wp = U.abs bs wp (Some (U.mk_residual_comp C.effect_Tot_lid None [TOTAL])) in + mk_Tm_app (inst_effect_fun_with us env md close) [S.as_arg res_t; S.as_arg x.sort; S.as_arg wp] wp0.pos) + bvs wp0 in + let c = Env.unfold_effect_abbrev env_bvs c in + let u_res_t, res_t, wp = destruct_wp_comp c in + let md = Env.get_effect_decl env c.effect_name in + let wp = close_wp u_res_t md res_t bvs wp in + (* + * AR: a note re. comp flags: + * earlier this code was setting the flags of the closed computation as c.flags + * + * cf. #2352, when this code was called from + * weaken_result_typ -> bind -> maybe_capture_unit_refinement, + * the input comp was Tot had RETURN flag set, which means the closed comp also had RETURN + * + * so when this closed computation was later `bind` with another comp, + * we simply dropped the it (see code path in bind under U.is_trivial_wp) + * thereby losing the captured refinement + * + * in general, comp flags need some cleanup + *) + mk_comp md u_res_t c.result_typ wp + (c.flags |> List.filter (function | MLEFFECT | SHOULD_NOT_INLINE -> true | _ -> false)) + end + +let close_wp_lcomp env bvs (lc:lcomp) : lcomp = + let bs = bvs |> List.map S.mk_binder in + lc |> + TcComm.apply_lcomp + (close_wp_comp env bvs) + (fun g -> g |> Env.close_guard env bs |> close_guard_implicits env false bs) + +// +// Apply substitutive close combinator for indexed effects +// +// The effect indices binders in the close combinator are arrows, +// so we abstract b_bv on the effect args for the substitutions +// +let substitutive_indexed_close_substs (env:env) + (close_bs:binders) + (a:typ) + (b_bv:bv) + (ct_args:args) + (num_effect_params:int) + (r:Range.range) + + : list subst_elt = + + let debug = !dbg_LayeredEffectsApp in + + // go through the binders bs and aggregate substitutions + let close_bs, subst = + let a_b::b_b::close_bs = close_bs in + close_bs, [NT (a_b.binder_bv, a); NT (b_b.binder_bv, b_bv.sort)] in + + let close_bs, subst, ct_args = + let eff_params_bs, close_bs = List.splitAt num_effect_params close_bs in + let ct_eff_params_args, ct_args = List.splitAt num_effect_params ct_args in + close_bs, + (subst@ + List.map2 (fun b (arg, _) -> NT (b.binder_bv, arg)) eff_params_bs ct_eff_params_args), + ct_args in + + let close_bs, _ = List.splitAt (List.length close_bs - 1) close_bs in + List.fold_left2 (fun ss b (ct_arg, _) -> + ss@[NT (b.binder_bv, U.abs [b_bv |> S.mk_binder] ct_arg None)] + ) subst close_bs ct_args + +// +// The caller ensures that the effect has the close combinator defined +// +let close_layered_comp_with_combinator (env:env) (bvs:list bv) (c:comp) : comp = + let r = c.pos in + + let env_bvs = Env.push_bvs env bvs in + let ct = Env.unfold_effect_abbrev env_bvs c in + let ed = Env.get_effect_decl env_bvs ct.effect_name in + let num_effect_params = + match ed.signature with + | Layered_eff_sig (n, _) -> n + | _ -> raise_error r Errors.Fatal_UnexpectedEffect "mk_indexed_close called with a non-indexed effect" + in + let close_ts = U.get_layered_close_combinator ed |> must in + let effect_args = List.fold_right (fun x args -> + let u_a = List.hd ct.comp_univs in + let u_b = env.universe_of env_bvs x.sort in + let _, close_t = Env.inst_tscheme_with close_ts [u_a; u_b] in + let close_bs, close_body, _ = U.abs_formals close_t in + let ss = substitutive_indexed_close_substs + env_bvs close_bs ct.result_typ x args num_effect_params r in + match (SS.compress (SS.subst ss close_body)).n with + | Tm_app { args = _::args} -> args + | _ -> raise_error r Errors.Fatal_UnexpectedEffect "Unexpected close combinator shape" + ) bvs ct.effect_args in + S.mk_Comp {ct with effect_args} + +let close_layered_lcomp_with_combinator env bvs lc = + let bs = bvs |> List.map S.mk_binder in + lc |> + TcComm.apply_lcomp + (close_layered_comp_with_combinator env bvs) + (fun g -> g |> Env.close_guard env bs |> close_guard_implicits env false bs) + +(* + * Closing of layered computations via substitution + *) +let close_layered_lcomp_with_substitutions env bvs tms (lc:lcomp) = + let bs = bvs |> List.map S.mk_binder in + let substs = List.map2 (fun bv tm -> + NT (bv, tm) + ) bvs tms in + lc |> + TcComm.apply_lcomp + (SS.subst_comp substs) + (fun g -> g |> Env.close_guard env bs |> close_guard_implicits env false bs) + +let should_not_inline_lc (lc:lcomp) = + lc.cflags |> BU.for_some (function SHOULD_NOT_INLINE -> true | _ -> false) + +(* should_return env (Some e) lc: + * We will "return" e, adding an equality to the VC, if all of the following conditions hold + * (a) e is a pure or ghost term + * (b) Its return type, lc.res_typ, is not a sub-singleton (unit, squash, etc), if lc.res_typ is an arrow, then we check the comp type of the arrow + * An exception is made for reifiable effects -- they are useful even if they return unit -- except when it is an layered effect, we never return layered effects + * (c) Its head symbol is not marked irreducible (in this case inlining is not going to help, it is equivalent to having a bound variable) + * (d) It's not a let rec, as determined by the absence of the SHOULD_NOT_INLINE flag---see issue #1362. Would be better to just encode inner let recs to the SMT solver properly + *) +let should_return env eopt lc = + let lc_is_unit_or_effectful = + //if lc.res_typ is not an arrow, arrow_formals_comp returns Tot lc.res_typ + let c = lc.res_typ |> U.arrow_formals_comp |> snd in + if Env.is_reifiable_comp env c + then + // + //if c (the comp of the result type of lc) is reifiable + // we always return it, unless it is a non TAC layered effect + // + let c_eff_name = c |> U.comp_effect_name |> Env.norm_eff_name env in + if is_pure_or_ghost_lcomp lc && //check that lc was pure or ghost + lid_equals c_eff_name C.effect_TAC_lid //and c is TAC + then false //then not effectful (i.e. return) + else c_eff_name |> Env.is_layered_effect env + else + // + // if c is not a reifiable effect, check that it is pure or ghost + // + if U.is_pure_or_ghost_comp c + then + // + // if it is pure or ghost, it must be a non-singleton + // + // adding a bit of normalization to unfold abbreviations + // + c |> U.comp_result |> N.unfold_whnf env |> U.is_unit + else + // + // if it is not pure or ghost, don't return + // + true in + + match eopt with + | None -> false //no term to return + | Some e -> + TcComm.is_pure_or_ghost_lcomp lc && //condition (a), (see above) + not lc_is_unit_or_effectful && //condition (b) + (let head, _ = U.head_and_args_full e in + match (U.un_uinst head).n with + | Tm_fvar fv -> not (Env.is_irreducible env (lid_of_fv fv)) //condition (c) + | _ -> true) && + not (should_not_inline_lc lc) //condition (d) + +// +// apply a substitutive indexed bind (including a polymonadic bind) +// +// bs are the opened binders in the type of the bind +// +let substitutive_indexed_bind_substs env + (m_ed n_ed p_ed:S.eff_decl) + (bs:binders) + (binder_kinds:list indexed_effect_binder_kind) + (ct1:comp_typ) (b:option bv) (ct2:comp_typ) + (r1:Range.range) + (num_effect_params:int) + (has_range_binders:bool) + + : list subst_elt & guard_t = + + let debug = !dbg_LayeredEffectsApp in + + let bind_name () = + if debug + then BU.format3 "(%s, %s) |> %s" + (m_ed.mname |> Ident.ident_of_lid |> string_of_id) + (n_ed.mname |> Ident.ident_of_lid |> string_of_id) + (p_ed.mname |> Ident.ident_of_lid |> string_of_id) + else "" in + + // we are going to move through the binders and aggregate their substitutions + + let bs, binder_kinds, subst = + let a_b::b_b::bs = bs in + bs, + List.splitAt 2 binder_kinds |> snd, + [NT (a_b.binder_bv, ct1.result_typ); NT (b_b.binder_bv, ct2.result_typ)] in + + // effect parameters + let bs, binder_kinds, subst, guard, args1, args2 = + if num_effect_params = 0 + then bs, binder_kinds, subst, Env.trivial_guard, ct1.effect_args, ct2.effect_args + else // peel off num effect params args from both c1 and c2, + // and equate them + let split (l:list 'a) = List.splitAt num_effect_params l in + let eff_params_bs, bs = split bs in + let _, binder_kinds = split binder_kinds in + let param_args1, args1 = split ct1.effect_args in + let param_args2, args2 = split ct2.effect_args in + let g = List.fold_left2 (fun g (arg1, _) (arg2, _) -> + Env.conj_guard g + (Rel.layered_effect_teq env arg1 arg2 (Some "effect param bind")) + ) Env.trivial_guard param_args1 param_args2 in + let param_subst = List.map2 (fun b (arg, _) -> + NT (b.binder_bv, arg)) eff_params_bs param_args1 in + bs, binder_kinds, subst@param_subst, g, args1, args2 in + + // f binders + let bs, binder_kinds, subst = + let m_num_effect_args = List.length args1 in + let f_bs, bs = List.splitAt m_num_effect_args bs in + let f_subst = List.map2 (fun f_b (arg:S.arg) -> NT (f_b.binder_bv, fst arg)) f_bs args1 in + bs, + List.splitAt m_num_effect_args binder_kinds |> snd, + subst@f_subst in + + // g binders + // a bit more involved since g binders may be substitutive or no abstraction + let bs, subst, guard = + let n_num_effect_args = List.length args2 in + let g_bs, bs = List.splitAt n_num_effect_args bs in + let g_bs_kinds = List.splitAt n_num_effect_args binder_kinds |> fst in + + let x_bv = + match b with + | None -> S.null_bv ct1.result_typ + | Some x -> x in + + let subst, guard = + List.fold_left2 (fun (ss, g) (g_b, g_b_kind) (arg:S.arg) -> + if g_b_kind = Substitutive_binder + then begin + let arg_t = U.abs [x_bv |> S.mk_binder] (fst arg) None in + ss@[NT (g_b.binder_bv, arg_t)], + g + end + else if g_b_kind = BindCont_no_abstraction_binder + then begin + let [uv_t], g_uv = + Env.uvars_for_binders env [g_b] ss + (fun b -> + if debug + then BU.format3 "implicit var for no abs g binder %s of %s at %s" + (show b) + (bind_name ()) + (Range.string_of_range r1) + else "substitutive_indexed_bind_substs.1") + r1 in + let g_unif = Rel.layered_effect_teq + (Env.push_binders env [x_bv |> S.mk_binder]) + uv_t + (arg |> fst) + (Some "") in + ss@[NT (g_b.binder_bv, uv_t)], + Env.conj_guards [g; g_uv; g_unif] + end + else failwith "Impossible (standard bind with unexpected binder kind)" + ) (subst, guard) (List.zip g_bs g_bs_kinds) args2 in + + bs, + subst, + guard in + + let bs = + if has_range_binders + then List.splitAt 2 bs |> snd + else bs in + + let bs = List.splitAt (List.length bs - 2) bs |> fst in + + // create uvars for remaining bs + List.fold_left (fun (ss, g) b -> + let [uv_t], g_uv = Env.uvars_for_binders env [b] ss + (fun b -> + if debug + then BU.format3 "implicit var for additional g binder %s of %s at %s" + (show b) + (bind_name ()) + (Range.string_of_range r1) + else "substitutive_indexed_bind_substs.2") r1 in + ss@[NT (b.binder_bv, uv_t)], + Env.conj_guard g g_uv + ) (subst, guard) bs + +// +// Apply an ad-hoc indexed bind (uvars for all binders) +// +let ad_hoc_indexed_bind_substs env + (m_ed n_ed p_ed:S.eff_decl) + (bs:binders) + (ct1:comp_typ) (b:option bv) (ct2:comp_typ) + (r1:Range.range) + (has_range_binders:bool) + + : list subst_elt & guard_t = + + let debug = !dbg_LayeredEffectsApp in + + let bind_name () = + if debug + then BU.format3 "(%s, %s) |> %s" + (m_ed.mname |> Ident.ident_of_lid |> string_of_id) + (n_ed.mname |> Ident.ident_of_lid |> string_of_id) + (p_ed.mname |> Ident.ident_of_lid |> string_of_id) + else "" in + + let bind_t_shape_error r (s:string) = + raise_error r Errors.Fatal_UnexpectedEffect + (BU.format2 "bind %s does not have proper shape (reason:%s)" (bind_name ()) s) + in + + let num_range_binders = + if has_range_binders then 2 + else 0 in + + let a_b, b_b, rest_bs, f_b, g_b = + if List.length bs >= num_range_binders + 4 + then let a_b::b_b::bs =bs in + let rest_bs, f_b, g_b = + List.splitAt (List.length bs - 2 - num_range_binders) bs + |> (fun ((l1, l2):(binders & binders)) -> + let _, l2 = List.splitAt num_range_binders l2 in + l1, List.hd l2, List.hd (List.tl l2)) in + a_b, b_b, rest_bs, f_b, g_b + else bind_t_shape_error r1 "Either not an arrow or not enough binders" in + + //create uvars for rest_bs, with proper substitutions of a_b, b_b, and b_i with t1, t2, and ?ui + let rest_bs_uvars, g_uvars = + Env.uvars_for_binders + env rest_bs [NT (a_b.binder_bv, ct1.result_typ); NT (b_b.binder_bv, ct2.result_typ)] + (fun b -> + if debug + then BU.format3 + "implicit var for binder %s of %s at %s" + (show b) (bind_name ()) (Range.string_of_range r1) + else "ad_hoc_indexed_bind_substs") r1 in + + if !dbg_ResolveImplicitsHook + then rest_bs_uvars |> + List.iter (fun t -> + match (SS.compress t).n with + | Tm_uvar (u, _ ) -> + BU.print2 "Generated uvar %s with attribute %s\n" + (show t) (show u.ctx_uvar_meta) + | _ -> failwith ("Impossible, expected a uvar, got : " ^ show t)); + + let subst = List.map2 + (fun b t -> NT (b.binder_bv, t)) + (a_b::b_b::rest_bs) (ct1.result_typ::ct2.result_typ::rest_bs_uvars) in + + let f_guard = //unify c1's indices with f's indices in the bind_wp + let f_sort_is = effect_args_from_repr + (SS.compress f_b.binder_bv.sort) + (U.is_layered m_ed) r1 |> List.map (SS.subst subst) in + List.fold_left2 + (fun g i1 f_i1 -> + if !dbg_ResolveImplicitsHook + then BU.print2 "Generating constraint %s = %s\n" + (show i1) + (show f_i1); + Env.conj_guard g (Rel.layered_effect_teq env i1 f_i1 (Some (bind_name ())))) + Env.trivial_guard (List.map fst ct1.effect_args) f_sort_is + in + + let g_guard = //unify c2's indices with g's indices in the bind_wp + let x_a = + match b with + | None -> S.null_binder ct1.result_typ + | Some x -> S.mk_binder {x with sort=ct1.result_typ} in + + let g_sort_is : list term = + match (SS.compress g_b.binder_bv.sort).n with + | Tm_arrow {bs; comp=c} -> + let bs, c = SS.open_comp bs c in + let bs_subst = NT ((List.hd bs).binder_bv, x_a.binder_bv |> S.bv_to_name) in + let c = SS.subst_comp [bs_subst] c in + effect_args_from_repr (SS.compress (U.comp_result c)) (U.is_layered n_ed) r1 + |> List.map (SS.subst subst) + | _ -> failwith "impossible: mk_indexed_bind" + in + + let env_g = Env.push_binders env [x_a] in + List.fold_left2 + (fun g i1 g_i1 -> + if !dbg_ResolveImplicitsHook + then BU.print2 "Generating constraint %s = %s\n" + (show i1) + (show g_i1); + Env.conj_guard g (Rel.layered_effect_teq env_g i1 g_i1 (Some (bind_name ())))) + Env.trivial_guard (List.map fst ct2.effect_args) g_sort_is + |> Env.close_guard env [x_a] + in + + subst, + Env.conj_guards [g_uvars; f_guard; g_guard] + +(* private *) + +(* + * Build the M.return comp for an indexed effect + * + * Caller must ensure that ed is an indexed effect + *) +let mk_indexed_return env (ed:S.eff_decl) (u_a:universe) (a:typ) (e:term) (r:Range.range) + : comp & guard_t = + + let debug = !dbg_LayeredEffectsApp in + + if debug + then BU.print4 "Computing %s.return for u_a:%s, a:%s, and e:%s{\n" + (Ident.string_of_lid ed.mname) (show u_a) + (show a) (show e); + + let _, return_t = Env.inst_tscheme_with + (ed |> U.get_return_vc_combinator) + [u_a] in + + let return_t_shape_error r (s:string) = + raise_error r Errors.Fatal_UnexpectedEffect [ + pp ed.mname ^/^ text ".return" ^/^ text "does not have proper shape"; + text "Reason: " ^^ text s + ] + in + let a_b, x_b, rest_bs, return_typ = + match (SS.compress return_t).n with + | Tm_arrow {bs; comp=c} when List.length bs >= 2 -> + let ((a_b::x_b::bs, c)) = SS.open_comp bs c in + a_b, x_b, bs, U.comp_result c + | _ -> return_t_shape_error r "Either not an arrow or not enough binders" in + + let rest_bs_uvars, g_uvars = + Env.uvars_for_binders + env rest_bs [NT (a_b.binder_bv, a); NT (x_b.binder_bv, e)] + (fun b -> + if debug + then BU.format3 "implicit var for binder %s of %s at %s" + (show b) + (BU.format1 "%s.return" (Ident.string_of_lid ed.mname)) + (Range.string_of_range r) + else "mk_indexed_return_env") r in + + let subst = List.map2 + (fun b t -> NT (b.binder_bv, t)) + (a_b::x_b::rest_bs) (a::e::rest_bs_uvars) in + + let is = + effect_args_from_repr (SS.compress return_typ) (U.is_layered ed) r + |> List.map (SS.subst subst) in + + let c = mk_Comp ({ + comp_univs = [u_a]; + effect_name = ed.mname; + result_typ = a; + effect_args = is |> List.map S.as_arg; + flags = [] + }) in + + if debug + then BU.print1 "} c after return %s\n" (show c); + + c, g_uvars + +let mk_indexed_bind env + (m:lident) (n:lident) (p:lident) (bind_t:tscheme) + (bind_combinator_kind:indexed_effect_combinator_kind) + (ct1:comp_typ) (b:option bv) (ct2:comp_typ) + (flags:list cflag) (r1:Range.range) + (num_effect_params:int) + (has_range_binders:bool) + : comp & guard_t = + + let debug = !dbg_LayeredEffectsApp in + + if debug then + BU.print2 "Binding indexed effects: c1:%s and c2:%s {\n" + (show (S.mk_Comp ct1)) (show (S.mk_Comp ct2)); + + if !dbg_ResolveImplicitsHook + then BU.print2 "///////////////////////////////Bind at %s/////////////////////\n\ + with bind_t = %s\n" + (Range.string_of_range (Env.get_range env)) + (Print.tscheme_to_string bind_t); + + let m_ed, n_ed, p_ed = Env.get_effect_decl env m, Env.get_effect_decl env n, Env.get_effect_decl env p in + + let bind_name () = BU.format3 "(%s, %s) |> %s" + (m_ed.mname |> Ident.ident_of_lid |> string_of_id) + (n_ed.mname |> Ident.ident_of_lid |> string_of_id) + (p_ed.mname |> Ident.ident_of_lid |> string_of_id) in + + if (Env.is_erasable_effect env m && + not (Env.is_erasable_effect env p) && + not (N.non_info_norm env ct1.result_typ)) || + (Env.is_erasable_effect env n && + not (Env.is_erasable_effect env p) && + not (N.non_info_norm env ct2.result_typ)) + then raise_error r1 Errors.Fatal_UnexpectedEffect [ + text "Cannot apply bind" ^/^ doc_of_string (bind_name ()) ^/^ text "since" ^/^ pp p + ^/^ text "is not erasable and one of the computations is informative." + ]; + + let _, bind_t = Env.inst_tscheme_with bind_t [List.hd ct1.comp_univs; List.hd ct2.comp_univs] in + + let bind_t_bs, bind_c = U.arrow_formals_comp bind_t in + + let subst, g = + if bind_combinator_kind = Ad_hoc_combinator + then ad_hoc_indexed_bind_substs env m_ed n_ed p_ed + bind_t_bs ct1 b ct2 r1 has_range_binders + else let Substitutive_combinator binder_kinds = bind_combinator_kind in + substitutive_indexed_bind_substs env m_ed n_ed p_ed + bind_t_bs binder_kinds ct1 b ct2 r1 num_effect_params has_range_binders in + + let bind_ct = bind_c |> SS.subst_comp subst |> Env.comp_to_comp_typ env in + + //compute the formula `bind_c.wp (fun _ -> True)` and add it to the final guard + let fml = + let u, wp = List.hd bind_ct.comp_univs, fst (List.hd bind_ct.effect_args) in + Env.pure_precondition_for_trivial_post env u bind_ct.result_typ wp Range.dummyRange in + + let is : list term = //indices of the resultant computation + effect_args_from_repr (SS.compress bind_ct.result_typ) (U.is_layered p_ed) r1 in + + let c = mk_Comp ({ + comp_univs = ct2.comp_univs; + effect_name = p_ed.mname; + result_typ = ct2.result_typ; + effect_args = List.map S.as_arg is; + flags = flags + }) in + + if debug + then BU.print1 "} c after bind: %s\n" (show c); + + let guard = + Env.conj_guards [ + g; + Env.guard_of_guard_formula (TcComm.NonTrivial fml)] + in + + if !dbg_ResolveImplicitsHook + then BU.print2 "///////////////////////////////EndBind at %s/////////////////////\n\ + guard = %s\n" + (Range.string_of_range (Env.get_range env)) + (guard_to_string env guard); + + c, guard + +let mk_wp_bind env (m:lident) (ct1:comp_typ) (b:option bv) (ct2:comp_typ) (flags:list cflag) (r1:Range.range) + : comp = + + let (md, a, kwp), (u_t1, t1, wp1), (u_t2, t2, wp2) = + let md = Env.get_effect_decl env m in + let a, kwp = Env.wp_signature env m in + (md, a, kwp), destruct_wp_comp ct1, destruct_wp_comp ct2 in + + let bs = + match b with + | None -> [null_binder t1] + | Some x -> [S.mk_binder x] + in + let mk_lam wp = + //we know it's total; indicate for the normalizer reduce it by adding the TOTAL flag + U.abs bs wp (Some (U.mk_residual_comp C.effect_Tot_lid None [TOTAL])) + in + let wp_args = [ + S.as_arg t1; + S.as_arg t2; + S.as_arg wp1; + S.as_arg (mk_lam wp2)] + in + let bind_wp, _ = md |> U.get_bind_vc_combinator in + let wp = mk_Tm_app (inst_effect_fun_with [u_t1;u_t2] env md bind_wp) wp_args t2.pos in + mk_comp md u_t2 t2 wp flags + +let mk_bind env + (c1:comp) + (b:option bv) + (c2:comp) + (flags:list cflag) + (r1:Range.range) : comp & guard_t = + + let env2 = maybe_push env b in + let ct1, ct2 = Env.unfold_effect_abbrev env c1, Env.unfold_effect_abbrev env2 c2 in + + match Env.exists_polymonadic_bind env ct1.effect_name ct2.effect_name with + | Some (p, f_bind) -> f_bind env ct1 b ct2 flags r1 + | None -> + (* + * AR: g_lift here consists of the guard of lifting c1 and c2 + * the guard of c2 could contain the bound variable b + * and when returning this gurd, we must close it + * + * however, if you see lift_comps_sep_guards, it is already doing the closing + * so it's fine to return g_return as is + *) + let m, c1, c2, g_lift = lift_comps env c1 c2 b true in + let ct1, ct2 = Env.comp_to_comp_typ env c1, Env.comp_to_comp_typ env2 c2 in + + let c, g_bind = + if Env.is_layered_effect env m + then + let m_ed = m |> Env.get_effect_decl env in + let num_effect_params = + match m_ed.signature with + | Layered_eff_sig (n, _) -> n + | _ -> failwith "Impossible (mk_bind expected an indexed effect)" in + let bind_t, bind_kind = m_ed |> U.get_bind_vc_combinator in + let has_range_args = U.has_attribute m_ed.eff_attrs C.bind_has_range_args_attr in + mk_indexed_bind env m m m bind_t (bind_kind |> must) ct1 b ct2 flags r1 num_effect_params has_range_args + else mk_wp_bind env m ct1 b ct2 flags r1, Env.trivial_guard in + c, Env.conj_guard g_lift g_bind + +let strengthen_comp env (reason:option (unit -> list Pprint.document)) (c:comp) (f:formula) flags : comp & guard_t = + if env.phase1 || Env.too_early_in_prims env + then c, Env.trivial_guard + else let r = Env.get_range env in + (* + * The following code does: + * M.bind_wp (lift_pure_M (Prims.pure_assert_wp f)) (fun _ -> wp) + *) + + (* + * lookup the pure_assert_wp from prims + * its type is p:Type -> pure_wp unit + * and it is not universe polymorphic + *) + let pure_assert_wp = S.fv_to_tm (S.lid_as_fv C.pure_assert_wp_lid None) in + + (* apply it to f, after decorating f with the reason *) + let pure_assert_wp = mk_Tm_app + pure_assert_wp + [ S.as_arg <| label_opt env reason r f ] + r + in + + let r = Env.get_range env in + + let pure_c = S.mk_Comp ({ + comp_univs = [S.U_zero]; + effect_name = C.effect_PURE_lid; + result_typ = S.t_unit; + effect_args = [pure_assert_wp |> S.as_arg]; + flags = [] + }) in + + mk_bind env pure_c None c flags r + +(* + * Wrapper over mk_wp_return and mk_indexed_return + *) +let mk_return env (ed:S.eff_decl) (u_a:universe) (a:typ) (e:term) (r:Range.range) +: comp & guard_t += if ed |> U.is_layered + then mk_indexed_return env ed u_a a e r + else mk_wp_return env ed u_a a e r, Env.trivial_guard + +(* + * Return a value in eff_lid + *) +let return_value env eff_lid u_t_opt t v = + let u = + match u_t_opt with + | None -> env.universe_of env t + | Some u -> u in + mk_return env (Env.get_effect_decl env eff_lid) u t v v.pos + +let weaken_flags flags = + if flags |> BU.for_some (function SHOULD_NOT_INLINE -> true | _ -> false) + then [SHOULD_NOT_INLINE] + else flags |> List.collect (function + | TOTAL -> [TRIVIAL_POSTCONDITION] + | RETURN -> [PARTIAL_RETURN; TRIVIAL_POSTCONDITION] + | f -> [f]) + +let weaken_comp env (c:comp) (formula:term) : comp & guard_t = + if U.is_ml_comp c + then c, Env.trivial_guard + else let ct = Env.unfold_effect_abbrev env c in + + (* + * The following code does: + * M.bind_wp (lift_pure_M (Prims.pure_assume_wp f)) (fun _ -> wp) + *) + + (* + * lookup the pure_assume_wp from prims + * its type is p:Type -> pure_wp unit + * and it is not universe polymorphic + *) + let pure_assume_wp = S.fv_to_tm (S.lid_as_fv C.pure_assume_wp_lid None) in + + (* apply it to f, after decorating f with the reason *) + let pure_assume_wp = mk_Tm_app + pure_assume_wp + [ S.as_arg <| formula ] + (Env.get_range env) + in + + let r = Env.get_range env in + + let pure_c = S.mk_Comp ({ + comp_univs = [S.U_zero]; + effect_name = C.effect_PURE_lid; + result_typ = S.t_unit; + effect_args = [pure_assume_wp |> S.as_arg]; + flags = [] + }) in + + mk_bind env pure_c None c (weaken_flags ct.flags) r + +let weaken_precondition env lc (f:guard_formula) : lcomp = + let weaken () = + let c, g_c = TcComm.lcomp_comp lc in + if Options.lax () + && Options.ml_ish() //NS: Disabling this optimization temporarily + then c, g_c + else match f with + | Trivial -> c, g_c + | NonTrivial f -> + let c, g_w = weaken_comp env c f in + c, Env.conj_guard g_c g_w + in + TcComm.mk_lcomp lc.eff_name lc.res_typ (weaken_flags lc.cflags) weaken + +let strengthen_precondition + (reason:option (unit -> list Pprint.document)) + env + (e_for_debugging_only:term) + (lc:lcomp) + (g0:guard_t) + : lcomp & guard_t = + if Env.is_trivial_guard_formula g0 + then lc, g0 + else let flags = + let maybe_trivial_post, flags = + if TcComm.is_tot_or_gtot_lcomp lc then true, [TRIVIAL_POSTCONDITION] else false, [] + in + flags @ ( + lc.cflags + |> List.collect (function + | RETURN + | PARTIAL_RETURN -> [PARTIAL_RETURN] + | SOMETRIVIAL + | TRIVIAL_POSTCONDITION + when not maybe_trivial_post -> + [TRIVIAL_POSTCONDITION] + | SHOULD_NOT_INLINE -> [SHOULD_NOT_INLINE] + | _ -> [])) + in + let strengthen () = + let c, g_c = TcComm.lcomp_comp lc in + if Options.lax () + then c, g_c + else let g0 = Rel.simplify_guard env g0 in + match guard_form g0 with + | Trivial -> c, g_c + | NonTrivial f -> + if Debug.extreme () + then BU.print2 "-------------Strengthening pre-condition of term %s with guard %s\n" + (N.term_to_string env e_for_debugging_only) + (N.term_to_string env f); + let c, g_s = strengthen_comp env reason c f flags in + c, Env.conj_guard g_c g_s + in + TcComm.mk_lcomp (norm_eff_name env lc.eff_name) + lc.res_typ + flags + strengthen, + {g0 with guard_f=Trivial} + + +let lcomp_has_trivial_postcondition (lc:lcomp) = + TcComm.is_tot_or_gtot_lcomp lc + || BU.for_some (function SOMETRIVIAL | TRIVIAL_POSTCONDITION -> true | _ -> false) + lc.cflags + + +(* + * This is used in bind, when c1 is a Tot (x:unit{phi}) + * In such cases, e1 is inlined in c2, but we still want to capture inhabitance of phi + * + * For wp-effects, we do forall (x:unit{phi}). c2 + * For layered effects, we do: weaken_comp (phi[x/()]) c2 + * + * We should make wp-effects also same as the layered effects + *) +let maybe_capture_unit_refinement (env:env) (t:term) (x:bv) (c:comp) : comp & guard_t = + let t = N.normalize_refinement N.whnf_steps env t in + match t.n with + | Tm_refine {b; phi} -> + let is_unit = + match b.sort.n with + | Tm_fvar fv -> S.fv_eq_lid fv C.unit_lid + | _ -> false in + if is_unit then + if c |> U.comp_effect_name |> Env.norm_eff_name env |> Env.is_layered_effect env + then + let b, phi = SS.open_term_bv b phi in + let phi = SS.subst [NT (b, S.unit_const)] phi in + weaken_comp env c phi + else close_wp_comp env [x] c, Env.trivial_guard + else c, Env.trivial_guard + | _ -> c, Env.trivial_guard + +let bind (r1:Range.range) (env:Env.env) (e1opt:option term) (lc1:lcomp) ((b, lc2):lcomp_with_binder) : lcomp = + let debug f = + if Debug.extreme () || !dbg_bind + then f () + in + let lc1, lc2 = N.ghost_to_pure_lcomp2 env (lc1, lc2) in //downgrade from ghost to pure, if possible + let joined_eff = join_lcomp env lc1 lc2 in + let bind_flags = + if should_not_inline_lc lc1 + || should_not_inline_lc lc2 + then [SHOULD_NOT_INLINE] + else let flags = + if TcComm.is_total_lcomp lc1 + then if TcComm.is_total_lcomp lc2 + then [TOTAL] + else if TcComm.is_tot_or_gtot_lcomp lc2 + then [SOMETRIVIAL] + else [] + else if TcComm.is_tot_or_gtot_lcomp lc1 + && TcComm.is_tot_or_gtot_lcomp lc2 + then [SOMETRIVIAL] + else [] + in + if lcomp_has_trivial_postcondition lc2 + then TRIVIAL_POSTCONDITION::flags + else flags + in + let bind_it () = + if Options.lax () + && Options.ml_ish() //NS: disabling this optimization temporarily + then + let u_t = env.universe_of env lc2.res_typ in + lax_mk_tot_or_comp_l joined_eff u_t lc2.res_typ [], Env.trivial_guard //AR: TODO: FIXME: fix for layered effects + else begin + let c1, g_c1 = TcComm.lcomp_comp lc1 in + let c2, g_c2 = TcComm.lcomp_comp lc2 in + + (* + * AR: we need to be careful about handling g_c2 since it may have x free + * whereever we return/add this, we have to either close it or substitute it + *) + + let trivial_guard = Env.conj_guard g_c1 ( + match b with + | Some x -> + let b = S.mk_binder x in + if S.is_null_binder b + then g_c2 + else Env.close_guard env [b] g_c2 + | None -> g_c2) in + + debug (fun () -> + BU.print4 "(1) bind: \n\tc1=%s\n\tx=%s\n\tc2=%s\n\te1=%s\n(1. end bind)\n" + (show c1) + (match b with + | None -> "none" + | Some x -> show x) + (show c2) + (match e1opt with + | None -> "none" + | Some e1 -> show e1)); + let aux () = + if U.is_trivial_wp c1 + then match b with + | None -> + Inl (c2, "trivial no binder") + | Some _ -> + if U.is_ml_comp c2 //|| not (U.is_free [Inr x] (U.freevars_comp c2)) + then Inl (c2, "trivial ml") + else Inr "c1 trivial; but c2 is not ML" + else if U.is_ml_comp c1 && U.is_ml_comp c2 + then Inl (c2, "both ml") + else Inr "c1 not trivial, and both are not ML" + in + let try_simplify () : either (comp & guard_t & string) string = + let aux_with_trivial_guard () = + match aux () with + | Inl (c, reason) -> Inl (c, trivial_guard, reason) + | Inr reason -> Inr reason in + if Env.too_early_in_prims env //if we're very early in prims + then //if U.is_tot_or_gtot_comp c1 + //&& U.is_tot_or_gtot_comp c2 + Inl (c2, trivial_guard, "Early in prims; we don't have bind yet") + // else raise_error (Errors.Fatal_NonTrivialPreConditionInPrims, + // "Non-trivial pre-conditions very early in prims, even before we have defined the PURE monad") + // (Env.get_range env) + else if U.is_total_comp c1 + then (* + * Helper routine to close the compuation c with c1's return type + * When c1's return type is of the form _:t{phi}, is is useful to know + * that t{phi} is inhabited, even if c1 is inlined etc. + *) + let close_with_type_of_x (x:bv) (c:comp) = + let x = { x with sort = U.comp_result c1 } in + maybe_capture_unit_refinement env x.sort x c in + match e1opt, b with + | Some e, Some x -> + let c2, g_close = c2 |> SS.subst_comp [NT (x, e)] |> close_with_type_of_x x in + Inl (c2, Env.conj_guards [ + g_c1; + Env.map_guard g_c2 (SS.subst [NT (x, e)]); + g_close ], "c1 Tot") + | _, Some x -> + let c2, g_close = c2 |> close_with_type_of_x x in + Inl (c2, Env.conj_guards [ + g_c1; + Env.close_guard env [S.mk_binder x] g_c2; + g_close ], "c1 Tot only close") + | _, _ -> aux_with_trivial_guard () + else if U.is_tot_or_gtot_comp c1 + && U.is_tot_or_gtot_comp c2 + then Inl (S.mk_GTotal (U.comp_result c2), trivial_guard, "both GTot") + else aux_with_trivial_guard () + in + match try_simplify () with + | Inl (c, g, reason) -> + debug (fun () -> + BU.print2 "(2) bind: Simplified (because %s) to\n\t%s\n" + reason + (show c)); + c, g + | Inr reason -> + debug (fun () -> + BU.print1 "(2) bind: Not simplified because %s\n" reason); + + let mk_bind c1 b c2 g = (* AR: end code for inlining pure and ghost terms *) + let c, g_bind = mk_bind env c1 b c2 bind_flags r1 in + c, Env.conj_guard g g_bind in + + (* AR: we have let the previously applied bind optimizations take effect, below is the code to do more inlining for pure and ghost terms *) + let u_res_t1, res_t1 = + let t = U.comp_result c1 in + match comp_univ_opt c1 with + | None -> env.universe_of env t, t + | Some u -> u, t in + //c1 and c2 are bound to the input comps + if Option.isSome b + && should_return env e1opt lc1 + then let e1 = Option.get e1opt in + let x = Option.get b in + //we will inline e1 in the WP of c2 + //Aiming to build a VC of the form + // + // M.bind (lift_(Pure/Ghost)_M wp1) + // (x == e1 ==> lift_M2_M (wp2[e1/x])) + // + // + //The additional equality hypothesis may seem + //redundant, but c1's post-condition or type may carry + //some meaningful information Then, it's important to + //weaken wp2 to with the equality, So that whatever + //property is proven about the result of wp1 (i.e., x) + //is still available in the proof of wp2 However, we + //do one optimization: + + //if c1 is already a return or a + //partial return, then it already provides this equality, + //so no need to add it again and instead generate + // + // M.bind (lift_(Pure/Ghost)_M wp1) + // (lift_M2_M (wp2[e1/x])) + + //If the optimization does not apply, + //then we generate the WP mentioned at the top, + //i.e. + // + // M.bind (lift_(Pure/Ghost)_M wp1) + // (x == e1 ==> lift_M2_M (wp2[e1/x])) + + if U.is_partial_return c1 + then + let _ = debug (fun () -> + BU.print2 "(3) bind (case a): Substituting %s for %s\n" (N.term_to_string env e1) (show x)) in + let c2 = SS.subst_comp [NT(x,e1)] c2 in + let g = Env.conj_guard g_c1 (Env.map_guard g_c2 (SS.subst [NT (x, e1)])) in + mk_bind c1 b c2 g + else + let _ = debug (fun () -> + BU.print2 "(3) bind (case b): Adding equality %s = %s\n" (N.term_to_string env e1) (show x)) in + let c2 = SS.subst_comp [NT(x,e1)] c2 in + let x_eq_e = U.mk_eq2 u_res_t1 res_t1 e1 (bv_to_name x) in + let c2, g_w = weaken_comp (Env.push_binders env [S.mk_binder x]) c2 x_eq_e in + let g = Env.conj_guards [ + g_c1; + Env.close_guard env [S.mk_binder x] g_w; + Env.close_guard env [S.mk_binder x] (TcComm.weaken_guard_formula g_c2 x_eq_e) ] in + mk_bind c1 b c2 g + //Caution: here we keep the flags for c2 as is, these flags will be overwritten later when we do md.bind below + //If we decide to return c2 as is (after inlining), we should reset these flags else bad things will happen + else mk_bind c1 b c2 trivial_guard + end + in TcComm.mk_lcomp joined_eff + lc2.res_typ + (* TODO : these cflags might be inconsistent with the one returned by bind_it !!! *) + bind_flags + bind_it + +let weaken_guard g1 g2 = match g1, g2 with + | NonTrivial f1, NonTrivial f2 -> + let g = (U.mk_imp f1 f2) in + NonTrivial g + | _ -> g2 + + +(* + * e has type lc, and lc is either pure or ghost + * This function inserts a return (x==e) in lc + * + * Optionally, callers can provide an effect M that they would like to return + * into + * + * If lc is PURE, the return happens in M + * else if it is GHOST, the return happens in PURE + * + * If caller does not provide the m effect, return happens in PURE + * + * This forces the lcomp thunk and recreates it to keep the callers same + *) +let assume_result_eq_pure_term_in_m env (m_opt:option lident) (e:term) (lc:lcomp) : lcomp = + (* + * AR: m is the effect that we are going to do return in + *) + let m = + if m_opt |> is_none || is_ghost_effect env lc.eff_name + then C.effect_PURE_lid + else m_opt |> must in + + let flags = + if TcComm.is_total_lcomp lc then RETURN::lc.cflags else PARTIAL_RETURN::lc.cflags in + + let refine () : comp & guard_t = + let c, g_c = TcComm.lcomp_comp lc in + let u_t = + match comp_univ_opt c with + | Some u_t -> u_t + | None -> env.universe_of env (U.comp_result c) + in + if U.is_tot_or_gtot_comp c + then //AR: insert an M.return + let retc, g_retc = return_value env m (Some u_t) (U.comp_result c) e in + let g_c = Env.conj_guard g_c g_retc in + if not (U.is_pure_comp c) //it started in GTot, so it should end up in Ghost + then let retc = Env.comp_to_comp_typ env retc in + let retc = {retc with effect_name=C.effect_GHOST_lid; flags=flags} in + S.mk_Comp retc, g_c + else Env.comp_set_flags env retc flags, g_c + else //AR: augment c's post-condition with a M.return + let c = Env.unfold_effect_abbrev env c in + let t = c.result_typ in + let c = mk_Comp c in + let x = S.new_bv (Some t.pos) t in + let xexp = S.bv_to_name x in + let env_x = Env.push_bv env x in + let ret, g_ret = return_value env_x m (Some u_t) t xexp in + let ret = TcComm.lcomp_of_comp <| Env.comp_set_flags env_x ret [PARTIAL_RETURN] in + let eq = U.mk_eq2 u_t t xexp e in + let eq_ret = weaken_precondition env_x ret (NonTrivial eq) in + let bind_c, g_bind = TcComm.lcomp_comp (bind e.pos env None (TcComm.lcomp_of_comp c) (Some x, eq_ret)) in + Env.comp_set_flags env bind_c flags, Env.conj_guards [g_c; g_ret; g_bind] + in + + if should_not_inline_lc lc + then raise_error e Errors.Fatal_UnexpectedTerm [ + text "assume_result_eq_pure_term cannot inline an non-inlineable lc : " ^^ pp e; + ] + + else let c, g = refine () in + TcComm.lcomp_of_comp_guard c g + +let maybe_assume_result_eq_pure_term_in_m env (m_opt:option lident) (e:term) (lc:lcomp) : lcomp = + let should_return = + not env.phase1 + && not (Env.too_early_in_prims env) //we're not too early in prims + && should_return env (Some e) lc + && not (TcComm.is_lcomp_partial_return lc) + in + if not should_return then lc + else assume_result_eq_pure_term_in_m env m_opt e lc + +let maybe_assume_result_eq_pure_term env e lc = + maybe_assume_result_eq_pure_term_in_m env None e lc + +let maybe_return_e2_and_bind + (r:Range.range) + (env:env) + (e1opt:option term) + (lc1:lcomp) + (e2:term) + (x, lc2) + : lcomp = + let env_x = + match x with + | None -> env + | Some x -> Env.push_bv env x in + + let lc1, lc2 = N.ghost_to_pure_lcomp2 env (lc1, lc2) in + + //AR: use c1's effect to return c2 into + let lc2 = + let eff1 = Env.norm_eff_name env lc1.eff_name in + let eff2 = Env.norm_eff_name env lc2.eff_name in + + (* + * AR: If eff1 and eff2 cannot be composed, and eff2 is PURE, + * we must return eff2 into eff1, + *) + if lid_equals eff2 C.effect_PURE_lid && + Env.join_opt env eff1 eff2 |> is_none && + Env.exists_polymonadic_bind env eff1 eff2 |> is_none + then assume_result_eq_pure_term_in_m env_x (eff1 |> Some) e2 lc2 + else if (not (is_pure_or_ghost_effect env eff1) + || should_not_inline_lc lc1) + && is_pure_or_ghost_effect env eff2 + then maybe_assume_result_eq_pure_term_in_m env_x (eff1 |> Some) e2 lc2 + else lc2 in //the resulting computation is still pure/ghost and inlineable; no need to insert a return + bind r env e1opt lc1 (x, lc2) + +let fvar_env env lid = S.fvar (Ident.set_lid_range lid (Env.get_range env)) None + +// +// Apply substitutive ite combinator for indexed effects +// +let substitutive_indexed_ite_substs (env:env) + (k:S.indexed_effect_combinator_kind) + (bs:binders) + (a:typ) + (p:term) + (ct_then:comp_typ) + (ct_else:comp_typ) + (num_effect_params:int) + (r:Range.range) + + : list subst_elt & guard_t = + + let debug = !dbg_LayeredEffectsApp in + + // go through the binders bs and aggregate substitutions and guards + + let bs, subst = + let a_b::bs = bs in + bs, [NT (a_b.binder_bv, a)] in + + // effect parameters + let bs, subst, guard, args1, args2 = + if num_effect_params = 0 + then bs, subst, Env.trivial_guard, ct_then.effect_args, ct_else.effect_args + else // peel off effect parameters from ct_then and ct_else, + // and equate them + let split (l:list 'a) = List.splitAt num_effect_params l in + let eff_params_bs, bs = split bs in + let param_args1, args1 = split ct_then.effect_args in + let param_args2, args2 = split ct_else.effect_args in + let g = List.fold_left2 (fun g (arg1, _) (arg2, _) -> + Env.conj_guard g + (Rel.layered_effect_teq env arg1 arg2 (Some "effect param ite")) + ) Env.trivial_guard param_args1 param_args2 in + let param_subst = List.map2 (fun b (arg, _) -> + NT (b.binder_bv, arg)) eff_params_bs param_args1 in + bs, subst@param_subst, g, args1, args2 in + + // f binders + let bs, subst = + let m_num_effect_args = List.length args1 in + let f_bs, bs = List.splitAt m_num_effect_args bs in + let f_subst = List.map2 (fun f_b (arg, _) -> NT (f_b.binder_bv, arg)) f_bs args1 in + bs, subst@f_subst in + + // g binders + let bs, subst, guard = + if Substitutive_combinator? k + then begin + let n_num_effect_args = List.length args2 in + let g_bs, bs = List.splitAt n_num_effect_args bs in + let g_subst = List.map2 (fun g_b (arg, _) -> NT (g_b.binder_bv, arg)) g_bs args2 in + bs, subst@g_subst, guard + end + else if Substitutive_invariant_combinator? k + then begin + bs, + subst, + List.fold_left2 (fun guard (arg1, _) (arg2, _) -> + Env.conj_guard guard + (Rel.layered_effect_teq env arg1 arg2 (Some "substitutive_inv ite args")) + ) guard args1 args2 + end + else failwith "Impossible (substitutive_indexed_ite: unexpected k)" in + + let bs, [_; _; p_b] = List.splitAt (List.length bs - 3) bs in + + let subst, g = + List.fold_left (fun (subst, g) b -> + let [uv_t], g_uv = Env.uvars_for_binders env [b] subst + (fun b -> + if debug + then BU.format3 "implicit var for additional ite binder %s of %s at %s)" + (show b) + (string_of_lid ct_then.effect_name) + (Range.string_of_range r) + else "substitutive_indexed_ite_substs") + r in + subst@[NT (b.binder_bv, uv_t)], + Env.conj_guard g g_uv) (subst, guard) bs in + + subst@[NT (p_b.binder_bv, p)], + g + +let ad_hoc_indexed_ite_substs (env:env) + (bs:binders) + (a:typ) + (p:term) + (ct_then:comp_typ) + (ct_else:comp_typ) + (r:Range.range) + + : list subst_elt & guard_t = + + let debug = !dbg_LayeredEffectsApp in + + let conjunction_name () = + if debug then BU.format1 "%s.conjunction" (string_of_lid ct_then.effect_name) + else "" in + + let conjunction_t_error #a r (s:string) : a = + raise_error r Errors.Fatal_UnexpectedEffect [ + text "Conjunction" ^^ pp ct_then.effect_name ^^ text "does not have proper shape."; + text "Reason: " ^^ text s; + ] + in + let a_b, rest_bs, f_b, g_b, p_b = + if List.length bs >= 4 + then let a_b::bs = bs in + let rest_bs, [f_b; g_b; p_b] = List.splitAt (List.length bs - 3) bs in + a_b, rest_bs, f_b, g_b, p_b + else conjunction_t_error r "Either not an abstraction or not enough binders" in + + let rest_bs_uvars, g_uvars = + Env.uvars_for_binders + env rest_bs [NT (a_b.binder_bv, a)] + (fun b -> + if debug + then BU.format3 + "implicit var for binder %s of %s:conjunction at %s" + (show b) (Ident.string_of_lid ct_then.effect_name) + (r |> Range.string_of_range) + else "ad_hoc_indexed_ite_substs") r in + + let substs = List.map2 + (fun b t -> NT (b.binder_bv, t)) + (a_b::(rest_bs@[p_b])) (a::(rest_bs_uvars@[p])) in + + let f_guard = + let f_sort_is = + match (SS.compress f_b.binder_bv.sort).n with + | Tm_app {args=_::is} -> + is |> List.map fst |> List.map (SS.subst substs) + | _ -> conjunction_t_error r "f's type is not a repr type" in + List.fold_left2 + (fun g i1 f_i -> + Env.conj_guard + g + (Rel.layered_effect_teq env i1 f_i (Some (conjunction_name ())))) + Env.trivial_guard (List.map fst ct_then.effect_args) f_sort_is in + + let g_guard = + let g_sort_is = + match (SS.compress g_b.binder_bv.sort).n with + | Tm_app {args=_::is} -> + is |> List.map fst |> List.map (SS.subst substs) + | _ -> conjunction_t_error r "g's type is not a repr type" in + List.fold_left2 + (fun g i2 g_i -> Env.conj_guard g (Rel.layered_effect_teq env i2 g_i (Some (conjunction_name ())))) + Env.trivial_guard (List.map fst ct_else.effect_args) g_sort_is in + + substs, + Env.conj_guards [g_uvars; f_guard; g_guard] + +let mk_layered_conjunction env (ed:S.eff_decl) (u_a:universe) (a:term) (p:typ) (ct1:comp_typ) (ct2:comp_typ) (r:Range.range) +: comp & guard_t = + + let debug = !dbg_LayeredEffectsApp in + + let conjunction_t_error #a r (s:string) : a = + raise_error r Errors.Fatal_UnexpectedEffect [ + text "Conjunction" ^^ pp ct1.effect_name ^^ text "does not have proper shape."; + text "Reason: " ^^ text s; + ] + in + + let conjunction, kind = + let ts, kopt = ed |> U.get_layered_if_then_else_combinator |> must in + let _, conjunction = Env.inst_tscheme_with ts [u_a] in + conjunction, kopt |> must in + + let bs, body, _ = U.abs_formals conjunction in + + if debug then + BU.print2 "layered_ite c1: %s and c2: %s {\n" + (ct1 |> S.mk_Comp |> show) + (ct2 |> S.mk_Comp |> show); + + let substs, g = + if kind = Ad_hoc_combinator + then ad_hoc_indexed_ite_substs env bs a p ct1 ct2 r + else let num_effect_params = + match ed.signature with + | Layered_eff_sig (n, _) -> n + | _ -> failwith "Impossible!" in + substitutive_indexed_ite_substs env kind bs a p ct1 ct2 num_effect_params r in + + let body = SS.subst substs body in + + let is = + match (SS.compress body).n with + | Tm_app {args=a::args} -> List.map fst args + | _ -> conjunction_t_error r "body is not a repr type" in + + let c = mk_Comp ({ + comp_univs = [u_a]; + effect_name = ed.mname; + result_typ = a; + effect_args = is |> List.map S.as_arg; + flags = [] + }) in + + if debug then BU.print_string "\n}\n"; + + c, g + +(* + * For non-layered effects, just apply the if_then_else combinator + *) +let mk_non_layered_conjunction env (ed:S.eff_decl) (u_a:universe) (a:term) (p:typ) (ct1:comp_typ) (ct2:comp_typ) (_:Range.range) +: comp & guard_t = + //p is a boolean guard, so b2t it + let p = U.b2t p in + let if_then_else = ed |> U.get_wp_if_then_else_combinator |> must in + let _, _, wp_t = destruct_wp_comp ct1 in + let _, _, wp_e = destruct_wp_comp ct2 in + let wp = mk_Tm_app (inst_effect_fun_with [u_a] env ed if_then_else) + [S.as_arg a; S.as_arg p; S.as_arg wp_t; S.as_arg wp_e] + (Range.union_ranges wp_t.pos wp_e.pos) in + mk_comp ed u_a a wp [], Env.trivial_guard + +(* + * PURE t (fun _ -> False) + * + * This is the comp type for a match with no cases (used in bind_cases) + *) +let comp_pure_wp_false env (u:universe) (t:typ) = + let post_k = U.arrow [null_binder t] (S.mk_Total U.ktype0) in + let kwp = U.arrow [null_binder post_k] (S.mk_Total U.ktype0) in + let post = S.new_bv None post_k in + let wp = U.abs [S.mk_binder post] + (fvar_env env C.false_lid) + (Some (U.mk_residual_comp C.effect_Tot_lid None [TOTAL])) in + let md = Env.get_effect_decl env C.effect_PURE_lid in + mk_comp md u t wp [] + +(* + * When typechecking a match term, typechecking each branch returns + * a branch condition + * + * E.g. match e with | C -> ... | D -> ... + * the two branch conditions would be (is_C e) and (is_D e) + * + * This function builds a list of formulas that are the negation of + * all the previous branches + * + * In the example, neg_branch_conds would be: + * [True; not (is_C e); not (is_C e) /\ not (is_D e)] + * thus, the length of the list is one more than lcases + * + * The return value is then ([True; not (is_C e)], not (is_C e) /\ not (is_D e)) + * + * (The last element of the list becomes the branch condition for the + unreachable branch to check for pattern exhaustiveness) + *) +let get_neg_branch_conds (branch_conds:list formula) + : list formula & formula + = branch_conds + |> List.fold_left (fun (conds, acc) g -> + let cond = U.mk_conj acc (g |> U.b2t |> U.mk_neg) in + (conds@[cond]), cond) ([U.t_true], U.t_true) + |> fst + |> (fun l -> List.splitAt (List.length l - 1) l) //the length of the list is at least 1 + |> (fun (l1, l2) -> l1, List.hd l2) + +(* + * The formula in each element of lcases is the individual branch guard, a boolean + * + * This function returns a computation type for the match expression, though + * without considering the scrutinee expression (that is the job of tc_match). + * The most interesting bit is its WP, which combines the WP for each branch + * under the appropriate reachability hypothesis (see also get_neg_branch_conds + * above). It also includes a `False` obligation under the hypothesis that no + * branch matches: i.e. the exhaustiveness check. + *) +let bind_cases env0 (res_t:typ) + (lcases:list (formula & lident & list cflag & (bool -> lcomp))) + (scrutinee:bv) : lcomp = + let env = Env.push_binders env0 [scrutinee |> S.mk_binder] in + let eff = List.fold_left (fun eff (_, eff_label, _, _) -> join_effects env eff eff_label) + C.effect_PURE_lid + lcases + in + let should_not_inline_whole_match, bind_cases_flags = + if lcases |> BU.for_some (fun (_, _, flags, _) -> + flags |> BU.for_some (function SHOULD_NOT_INLINE -> true | _ -> false)) + then true, [SHOULD_NOT_INLINE] + else false, [] + in + let bind_cases () = + let u_res_t = env.universe_of env res_t in + if Options.lax() + && Options.ml_ish() //NS: Disabling this optimization temporarily + then + lax_mk_tot_or_comp_l eff u_res_t res_t [], Env.trivial_guard + else begin + let maybe_return eff_label_then cthen = + if should_not_inline_whole_match + || not (is_pure_or_ghost_effect env eff) + then cthen true //inline each the branch, if eligible + else cthen false //the entire match is pure and inlineable, so no need to inline each branch + in + + (* + * The formula in each of the branches of lcases is the branch condition of *just* that branch, + * e.g. match e with | C -> ... | D -> ... + * the formula in the two branches is is_C e and is_D e + * + * neg_branch_conds builds a list where the formulas are negation of + * all the previous branches + * + * In the example, neg_branch_conds would be: + * [True; not (is_C e); not (is_C e) /\ not (is_D e)] + * thus, the length of the list is one more than lcases + * + * The last element of the list becomes the branch condition for the + * unreachable branch (will be used to check pattern exhaustiveness) + * + * The rest of the list will be used to weaken the lift guards when combining the + * branches (for layered effects, lift guards can be non-trivial). Note that + * we don't need to do this to combine cases, because the shape of if_then_else + * (p ==> ...) /\ (not p ==> ...) + * already takes care of it + *) + let neg_branch_conds, exhaustiveness_branch_cond = + get_neg_branch_conds (lcases |> List.map (fun (g, _, _, _) -> g)) in + + let md, comp, g_comp = + match lcases with + | [] -> None, comp_pure_wp_false env u_res_t res_t, Env.trivial_guard + | _ -> + (* + * We will now compute the VC with a fold_right2 over lcases + * and neg_branch_conds + * Split the last element of lcases (and branch conditions) + * to form the base case + *) + + let lcases, neg_branch_conds, md, comp, g_comp = + let neg_branch_conds, neg_last = + neg_branch_conds + |> List.splitAt (List.length lcases - 1) + |> (fun (l1, l2) -> l1, List.hd l2) in + + let lcases, (g_last, eff_last, _, c_last) = + lcases + |> List.splitAt (List.length lcases - 1) + |> (fun (l1, l2) -> l1, List.hd l2) in + + let c, g = + let lc = maybe_return eff_last c_last in + let c, g = TcComm.lcomp_comp lc in + c, TcComm.weaken_guard_formula g (U.mk_conj (U.b2t g_last) neg_last) in + + lcases, + neg_branch_conds, + eff_last |> Env.norm_eff_name env |> Env.get_effect_decl env, + c, g in + + List.fold_right2 (fun (g, eff_label, _, cthen) neg_cond (_, celse, g_comp) -> + let cthen, g_then = TcComm.lcomp_comp (maybe_return eff_label cthen) in + //lift both the branches + //separate guards so that we can weaken them appropriately later + let md, ct_then, ct_else, g_lift_then, g_lift_else = + let m, cthen, celse, g_lift_then, g_lift_else = + lift_comps_sep_guards env cthen celse None false in + let md = Env.get_effect_decl env m in + md, + cthen |> Env.comp_to_comp_typ env, celse |> Env.comp_to_comp_typ env, + g_lift_then, g_lift_else in + + //function to apply the if-then-else combinator + let fn = + if md |> U.is_layered then mk_layered_conjunction + else mk_non_layered_conjunction in + + let c, g_conjunction = fn env md u_res_t res_t g ct_then ct_else (Env.get_range env) in + + //weaken the then and else guards + //neg_cond is the negated branch condition upto this branch + let g_then, g_else = + let g = U.b2t g in + TcComm.weaken_guard_formula + (Env.conj_guard g_then g_lift_then) + (U.mk_conj neg_cond g), + TcComm.weaken_guard_formula + g_lift_else + (U.mk_conj neg_cond (U.mk_neg g)) in + + Some md, + c, + Env.conj_guards [g_comp; g_then; g_else; g_conjunction] + ) lcases neg_branch_conds (Some md, comp, g_comp) in + + //strengthen comp with the exhaustiveness check + let comp, g_comp = + let c, g = + let check = U.mk_imp exhaustiveness_branch_cond U.t_false in + let check = label Err.exhaustiveness_check (Env.get_range env) check in + strengthen_comp env None comp check bind_cases_flags in + c, Env.conj_guard g_comp g in + + //AR: 11/18: we don't need to close this guard with the scrutinee bv + // since the tc_match code does a bind with the scrutinee + // expression, which will take care of this bv + //close g_comp with the scrutinee bv + //let g_comp = Env.close_guard env0 [scrutinee |> S.mk_binder] g_comp in + + match lcases with + | [] + | [_] -> comp, g_comp + | _ -> + if md |> must |> U.is_layered then comp, g_comp + else + let comp = Env.comp_to_comp_typ env comp in + let md = Env.get_effect_decl env comp.effect_name in + let _, _, wp = destruct_wp_comp comp in + let ite_wp = md |> U.get_wp_ite_combinator |> must in + let wp = mk_Tm_app (inst_effect_fun_with [u_res_t] env md ite_wp) + [S.as_arg res_t; S.as_arg wp] + wp.pos in + mk_comp md u_res_t res_t wp bind_cases_flags, g_comp + end + in + TcComm.mk_lcomp eff res_t bind_cases_flags bind_cases + +let check_comp env (use_eq:bool) (e:term) (c:comp) (c':comp) : term & comp & guard_t = + def_check_scoped c.pos "check_comp.c" env c; + def_check_scoped c'.pos "check_comp.c'" env c'; + if Debug.extreme () then + BU.print4 "Checking comp relation:\n%s has type %s\n\t %s \n%s\n" + (show e) + (show c) + (if use_eq then "$:" else "<:") + (show c'); + let f = if use_eq then Rel.eq_comp else Rel.sub_comp in + match f env c c' with + | None -> + if use_eq + then Err.computed_computation_type_does_not_match_annotation_eq env (Env.get_range env) e c c' + else Err.computed_computation_type_does_not_match_annotation env (Env.get_range env) e c c' + | Some g -> e, c', g + +let universe_of_comp env u_res c = + (* + * Universe computation for M t wp: + * if M is pure or ghost, then return universe of t + * else if M is not marked Total, then return u0 + * else if M has no additional binders, then return universe of t + * else delegate the computation to repr of M, error out of no repr + *) + let c_lid = c |> U.comp_effect_name |> Env.norm_eff_name env in + if U.is_pure_or_ghost_effect c_lid then u_res //if pure or ghost, return the universe of the return type + else + let is_total = Env.lookup_effect_quals env c_lid |> List.existsb (fun q -> q = S.TotalEffect) in + if not is_total then S.U_zero //if it is a non-total effect then u0 + else match Env.effect_repr env c u_res with + | None -> + raise_error c Errors.Fatal_EffectCannotBeReified + (BU.format1 "Effect %s is marked total but does not have a repr" (show c_lid)) + | Some tm -> env.universe_of env tm + +let check_trivial_precondition_wp env c = + let ct = c |> Env.unfold_effect_abbrev env in + let md = Env.get_effect_decl env ct.effect_name in + let u_t, t, wp = destruct_wp_comp ct in + let vc = mk_Tm_app + (inst_effect_fun_with [u_t] env md (md |> U.get_wp_trivial_combinator |> must)) + [S.as_arg t; S.as_arg wp] + (Env.get_range env) + in + + ct, vc, Env.guard_of_guard_formula <| NonTrivial vc + +//Decorating terms with monadic operators +let maybe_lift env e c1 c2 t = + let m1 = Env.norm_eff_name env c1 in + let m2 = Env.norm_eff_name env c2 in + if Ident.lid_equals m1 m2 + || (U.is_pure_effect c1 && U.is_ghost_effect c2) + || (U.is_pure_effect c2 && U.is_ghost_effect c1) + then e + else mk (Tm_meta {tm=e; meta=Meta_monadic_lift(m1, m2, t)}) e.pos + +let maybe_monadic env e c t = + let m = Env.norm_eff_name env c in + if is_pure_or_ghost_effect env m + || Ident.lid_equals m C.effect_Tot_lid + || Ident.lid_equals m C.effect_GTot_lid //for the cases in prims where Pure is not yet defined + then e + else mk (Tm_meta {tm=e; meta=Meta_monadic (m, t)}) e.pos + +let coerce_with (env:Env.env) + (e : term) (lc : lcomp) // original term and its computation type + (f : lident) // coercion + (us : universes) (eargs : args) // extra arguments to coertion + (comp2 : comp) // new result computation type + : term & lcomp = + match Env.try_lookup_lid env f with + | Some _ -> + if !dbg_Coercions then + BU.print1 "Coercing with %s!\n" (Ident.string_of_lid f); + let lc2 = TcComm.lcomp_of_comp <| comp2 in + let lc_res = bind e.pos env (Some e) lc (None, lc2) in + let coercion = S.fvar (Ident.set_lid_range f e.pos) None in + let coercion = S.mk_Tm_uinst coercion us in + + // + //Creating the coerced term: + // If lc is pure or ghost, then just create the application node + // Else create let x = e in f x + // with appropriate meta monadic nodes + // + let e = + if TcComm.is_pure_or_ghost_lcomp lc + then mk_Tm_app coercion (eargs@[S.as_arg e]) e.pos + else let x = S.new_bv (Some e.pos) lc.res_typ in + let e2 = mk_Tm_app coercion (eargs@[x |> S.bv_to_name |> S.as_arg]) e.pos in + let e = maybe_lift env e lc.eff_name lc_res.eff_name lc.res_typ in + let e2 = maybe_lift (Env.push_bv env x) e2 lc2.eff_name lc_res.eff_name lc2.res_typ in + let lb = U.mk_letbinding (Inl x) [] lc.res_typ lc_res.eff_name e [] e.pos in + let e = mk (Tm_let {lbs=(false, [lb]); body=SS.close [S.mk_binder x] e2}) e.pos in + maybe_monadic env e lc_res.eff_name lc_res.res_typ in + e, lc_res + | None -> + Errors.log_issue e Errors.Warning_CoercionNotFound + (BU.format1 "Coercion %s was not found in the environment, not coercing." + (string_of_lid f)); + e, lc + +type isErased = + | Yes of term + | Maybe + | No + +let rec check_erased (env:Env.env) (t:term) : isErased = + let norm' = N.normalize [Beta; Eager_unfolding; + UnfoldUntil delta_constant; + Exclude Zeta; Primops; + Unascribe; Unmeta; Unrefine; + Weak; HNF; Iota] + in + let t = norm' env t in + let h, args = U.head_and_args t in + let h = U.un_uinst h in + let r = + match (SS.compress h).n, args with + | Tm_fvar fv, [(a, _)] when S.fv_eq_lid fv C.erased_lid -> + Yes a + + (* In these two cases, we cannot guarantee that `t` is not + * an erased, so we're conservatively returning `false` *) + | Tm_uvar _, _ + | Tm_unknown, _ -> Maybe + + (* + * AR: For Tm_match: + * We are only interested in returning a No or Maybe + * Since even if all the branched are erased types, + * we need to find their join to return to the caller + * That's messy + * We can't always return Maybe, since that breaks simple + * cases like the int types in FStar.Integers + * So we iterate over all the branches and return a No if possible + *) + | Tm_match {brs=branches}, _ -> + branches |> List.fold_left (fun acc br -> + match acc with + | Yes _ | Maybe -> Maybe + | No -> + let _, _, br_body = Subst.open_branch br in + match + br_body + |> check_erased + (br_body + |> Free.names + |> elems // GGG: bad, order-depending + |> Env.push_bvs env) with + | No -> No + | _ -> Maybe) No + + + (* Anything else cannot be `erased` *) + | _ -> + No + in + (* if Debug.any () then *) + (* BU.print2 "check_erased (%s) = %s\n" *) + (* (show t) *) + (* (match r with *) + (* | Yes a -> "Yes " ^ show a *) + (* | Maybe -> "Maybe" *) + (* | No -> "No"); *) + r + +let rec first_opt (f : 'a -> option 'b) (xs : list 'a) : option 'b = + match xs with + | [] -> None + | x::xs -> BU.catch_opt (f x) (fun () -> first_opt f xs) + +let (let?) = BU.bind_opt +let bool_guard (b:bool) : option unit = + if b then Some () else None + +let find_coercion (env:Env.env) (checked: lcomp) (exp_t: typ) (e:term) +: option (term & lcomp & guard_t) +// returns coerced term, new lcomp type, and guard +// or None if no coercion applied += + Errors.with_ctx "find_coercion" (fun () -> + let is_type t = + let t = N.unfold_whnf env t in + let t = U.unrefine t in (* mostly to catch `prop` too *) + match (SS.compress t).n with + | Tm_type _ -> true + | _ -> false + in + let rec head_of (t : term) : term = + match (compress t).n with + | Tm_app {hd=t} + | Tm_match {scrutinee=t} + | Tm_abs {body=t} + | Tm_ascribed {tm=t} + | Tm_meta {tm=t} -> head_of t + | Tm_refine {b} -> head_of b.sort + | _ -> t + in + let is_head_defined t = + let h = head_of t in + let h = SS.compress h in + Tm_fvar? h.n || Tm_uinst? h.n || Tm_type? h.n + in + + let head_unfold env t = N.unfold_whnf' [Unascribe; Unmeta; Unrefine] env t in + + (* Bail out early if either the computed or expected type are not + defined at the head *) + bool_guard (is_head_defined exp_t && is_head_defined checked.res_typ);? + + (* The computed type for `e`. *) + let computed_t = head_unfold env checked.res_typ in + let head, args = U.head_and_args computed_t in + + (* The expected type according to the context. *) + let exp_t = head_unfold env exp_t in + + match (U.un_uinst head).n, args with + (* b2t is primitive... for now *) + | Tm_fvar fv, [] when S.fv_eq_lid fv C.bool_lid && is_type exp_t -> + let lc2 = TcComm.lcomp_of_comp <| S.mk_Total U.ktype0 in + let lc_res = bind e.pos env (Some e) checked (None, lc2) in + Some (U.mk_app (S.fvar C.b2t_lid None) [S.as_arg e], lc_res, Env.trivial_guard) + + (* user coercions, find candidates with the @@coercion attribute and try. *) + | _ -> + let head_lid_of t = + match (SS.compress (head_of t)).n with + | Tm_fvar fv + | Tm_uinst ({ n = Tm_fvar fv }, _) -> + Some (S.lid_of_fv fv) + | _ -> None + in + + let? exp_head_lid = head_lid_of exp_t in + let? computed_head_lid = head_lid_of computed_t in + + let candidates = Env.lookup_attr env "FStar.Pervasives.coercion" in + candidates |> first_opt (fun se -> + (* `f` is the candidate coercion, `e` the term to coerce *) + let? f_name, f_us, f_typ = + match se.sigel with + | Sig_let {lbs=(_,[lb])} -> Some (S.lid_of_fv (BU.right lb.lbname), lb.lbunivs, lb.lbtyp) + | Sig_declare_typ {lid; us; t} -> Some (lid, us, t) + | _ -> None + in + + let _, f_typ = SS.open_univ_vars f_us f_typ in + + (* `f` must have type `b1 -> b2 -> .... -> bN -> TB -> M TC ..., + Before attempting unification, which is expensive, we will + check that the head of B is an fvar which matches the expected + type, and that the head of A is and fvar which matches the type + of e. + *) + let f_bs, f_c = U.arrow_formals_comp f_typ in + bool_guard (f_bs <> []);? (* If not a function, ignore *) + let f_res = U.comp_result f_c in + let f_res = head_unfold (Env.push_binders env f_bs) f_res in + let? f_res_head_lid = head_lid_of f_res in + (* ^ The lid at the head of TC, the result type *) + bool_guard (lid_equals exp_head_lid f_res_head_lid);? + + let b = List.last f_bs in + let b_ty = b.binder_bv.sort in + let b_ty = head_unfold (Env.push_binders env (List.init f_bs)) b_ty in + let? b_head_lid = head_lid_of b_ty in + (* ^ The lid at the head of TB, the last argument *) + bool_guard (lid_equals computed_head_lid b_head_lid);? + + (* We will now typecheck the coercion applied to `e` at expected type + `exp_t` likely causing implicits to be instantiated for the coercion + function (if any). If this succeeds, the elaborated term is the + result we want. + + FIXME: ideally, we would not pass `e` through the typechecker again, + but checking the coercion alone means we need to compute its effect (easy) + and effect indices (not easy). + + Note: we could perhaps backtrack on an error here (using + catch_errors and UF.new_transaction), but that can get + expensive, and it's perhaps unexpected. Currently, the head FVs + define which coercions apply, and that's a firm choice. + *) + + let f_tm = S.fvar f_name None in + let tt = U.mk_app f_tm [S.as_arg e] in + Some (env.tc_term { env with nocoerce=true; admit=true; expected_typ = Some (exp_t, false) } tt) + // NB: tc_term returns exactly elaborated term, lcomp, and guard, so we just return that. + ) +) + +let maybe_coerce_lc env (e:term) (lc:lcomp) (exp_t:term) : term & lcomp & guard_t = + let should_coerce = + (env.phase1 + || Options.lax ()) && not env.nocoerce + in + if not should_coerce then ( + if !dbg_Coercions then + BU.print4 "(%s) NOT Trying to coerce %s from type (%s) to type (%s)\n" + (show e.pos) (show e) (show lc.res_typ) (show exp_t); + (e, lc, Env.trivial_guard) + ) else ( + if !dbg_Coercions then + BU.print4 "(%s) Trying to coerce %s from type (%s) to type (%s)\n" + (show e.pos) (show e) (show lc.res_typ) (show exp_t); + match find_coercion env lc exp_t e with + | Some (coerced, lc, g) -> + let _ = if !dbg_Coercions then + BU.print3 "(%s) COERCING %s to %s\n" + (Range.string_of_range e.pos) + (show e) + (show coerced) + in + coerced, lc, g + | None -> + let _ = if !dbg_Coercions then + BU.print1 "(%s) No user coercion found\n" + (Range.string_of_range e.pos) + in + + (* TODO: hide/reveal also user coercions? it's trickier for sure *) + + let strip_hide_or_reveal (e:term) (hide_or_reveal:lident) : option term = + let hd, args = U.leftmost_head_and_args e in + match (SS.compress hd).n, args with + | Tm_uinst (hd, _), [(_, aq_t); (e, aq_e)] + when U.is_fvar hide_or_reveal hd && + Some? aq_t && (Some?.v aq_t).aqual_implicit && + (aq_e = None || not (Some?.v aq_e).aqual_implicit) -> + Some e + | _ -> None + in + + match check_erased env lc.res_typ, check_erased env exp_t with + | No, Yes ty -> + begin + let u = env.universe_of env ty in + match Rel.get_subtyping_predicate env lc.res_typ ty with + | None -> + e, lc, Env.trivial_guard + | Some g -> + let g = Env.apply_guard g e in + let e_hide, lc = coerce_with env e lc C.hide [u] [S.iarg ty] (S.mk_Total exp_t) in + // + // AR: an optimization to see if input e is a reveal e', + // we can just take e', rather than hide (reveal e') + // + // we still let coerce_with happen just above, + // since it has logic to compute the correct lc + // + let e_hide = BU.dflt e_hide (strip_hide_or_reveal e C.reveal) in + e_hide, lc, g + end + + | Yes ty, No -> + let u = env.universe_of env ty in + let e_reveal, lc = coerce_with env e lc C.reveal [u] [S.iarg ty] (S.mk_GTotal ty) in + let e_reveal = BU.dflt e_reveal (strip_hide_or_reveal e C.hide) in + e_reveal, lc, Env.trivial_guard + + | _ -> + e, lc, Env.trivial_guard + ) + +let weaken_result_typ env (e:term) (lc:lcomp) (t:typ) (use_eq:bool) : term & lcomp & guard_t = + if Debug.high () then + BU.print4 "weaken_result_typ use_eq=%s e=(%s) lc=(%s) t=(%s)\n" + (show use_eq) (show e) (TcComm.lcomp_to_string lc) (show t); + let use_eq = + use_eq || //caller wants to check equality + env.use_eq_strict || + (match Env.effect_decl_opt env lc.eff_name with + // See issue #881 for why weakening result type of a reifiable computation is problematic + | Some (ed, qualifiers) -> qualifiers |> List.contains Reifiable + | _ -> false) in + let gopt = if use_eq + then Rel.try_teq true env lc.res_typ t, false + else Rel.get_subtyping_predicate env lc.res_typ t, true in + match gopt with + | None, _ -> + (* + * AR: 11/18: should this always fail hard? + *) + if env.failhard + then Err.raise_basic_type_error env e.pos (Some e) t lc.res_typ + else ( + subtype_fail env e lc.res_typ t; //log a sub-typing error + e, {lc with res_typ=t}, Env.trivial_guard //and keep going to type-check the result of the program + ) + | Some g, apply_guard -> + match guard_form g with + | Trivial -> + (* + * AR: when the guard is trivial, simply setting the result type to t might lose some precision + * e.g. when input lc has return type x:int{phi} and we are weakening it to int + * so we should capture the precision before setting the comp type to t (see e.g. #1500, #1470) + *) + let strengthen_trivial () = + let c, g_c = TcComm.lcomp_comp lc in + let res_t = Util.comp_result c in + + let set_result_typ (c:comp) :comp = Util.set_result_typ c t in + + if TEQ.eq_tm env t res_t = TEQ.Equal then begin //if the two types res_t and t are same, then just set the result type + if Debug.extreme() + then BU.print2 "weaken_result_type::strengthen_trivial: res_t:%s is same as t:%s\n" + (show res_t) (show t); + set_result_typ c, g_c + end + else + let is_res_t_refinement = + let res_t = N.normalize_refinement N.whnf_steps env res_t in + match res_t.n with + | Tm_refine _ -> true + | _ -> false + in + //if t is a refinement, insert a return to capture the return type res_t + //we are not inlining e, rather just adding (fun (x:res_t) -> p x) at the end + if is_res_t_refinement then + let x = S.new_bv (Some res_t.pos) res_t in + //AR: build M.return, where M is c's effect + let cret, gret = return_value env (c |> U.comp_effect_name |> Env.norm_eff_name env) + (comp_univ_opt c) res_t (S.bv_to_name x) in + //AR: an M_M bind + let lc = bind e.pos env (Some e) (TcComm.lcomp_of_comp c) (Some x, TcComm.lcomp_of_comp cret) in + if Debug.extreme () + then BU.print4 "weaken_result_type::strengthen_trivial: inserting a return for e: %s, c: %s, t: %s, and then post return lc: %s\n" + (show e) (show c) (show t) (TcComm.lcomp_to_string lc); + let c, g_lc = TcComm.lcomp_comp lc in + set_result_typ c, Env.conj_guards [g_c; gret; g_lc] + else begin + if Debug.extreme () + then BU.print2 "weaken_result_type::strengthen_trivial: res_t:%s is not a refinement, leaving c:%s as is\n" + (show res_t) (show c); + set_result_typ c, g_c + end + in + let lc = TcComm.mk_lcomp lc.eff_name t lc.cflags strengthen_trivial in + e, lc, g + + | NonTrivial f -> + let g = {g with guard_f=Trivial} in + let strengthen () = + if Options.lax() + && Options.ml_ish() //NS: disabling this optimization temporarily + then + TcComm.lcomp_comp lc + else begin + //try to normalize one more time, since more unification variables may be resolved now + let f = N.normalize [Env.Beta; Env.Eager_unfolding; Env.Simplify; Env.Primops] env f in + match (SS.compress f).n with + | Tm_abs {body={n=Tm_fvar fv}} when S.fv_eq_lid fv C.true_lid -> + //it's trivial + let lc = {lc with res_typ=t} in //NS: what's the point of this? + TcComm.lcomp_comp lc + + | _ -> + let c, g_c = TcComm.lcomp_comp lc in + if Debug.extreme () + then BU.print4 "Weakened from %s to %s\nStrengthening %s with guard %s\n" + (N.term_to_string env lc.res_typ) + (N.term_to_string env t) + (N.comp_to_string env c) + (N.term_to_string env f); + + let u_t_opt = comp_univ_opt c in + let x = S.new_bv (Some t.pos) t in + let xexp = S.bv_to_name x in + //AR: M.return + let cret, gret = return_value env + (c |> U.comp_effect_name |> Env.norm_eff_name env) + u_t_opt t xexp in + let guard = if apply_guard + then mk_Tm_app f [S.as_arg xexp] f.pos + else f + in + let eq_ret, _trivial_so_ok_to_discard = + strengthen_precondition (Some <| Err.subtyping_failed env lc.res_typ t) + (Env.set_range (Env.push_bvs env [x]) e.pos) + e //use e for debugging only + (TcComm.lcomp_of_comp cret) + (guard_of_guard_formula <| NonTrivial guard) + in + let x = {x with sort=lc.res_typ} in + //AR: M_M bind + let c = bind e.pos env (Some e) (TcComm.lcomp_of_comp c) (Some x, eq_ret) in + let c, g_lc = TcComm.lcomp_comp c in + if Debug.extreme () + then BU.print1 "Strengthened to %s\n" (Normalize.comp_to_string env c); + c, Env.conj_guards [g_c; gret; g_lc] + end + in + let flags = lc.cflags |> List.collect (function + | RETURN | PARTIAL_RETURN -> [PARTIAL_RETURN] + | CPS -> [CPS] // KM : Not exactly sure if it is necessary + | _ -> []) + in + let lc = TcComm.mk_lcomp (norm_eff_name env lc.eff_name) t flags strengthen in + let g = {g with guard_f=Trivial} in + (e, lc, g) + +let pure_or_ghost_pre_and_post env comp = + let mk_post_type res_t ens = + let x = S.new_bv None res_t in + U.refine x (S.mk_Tm_app ens [S.as_arg (S.bv_to_name x)] res_t.pos) in + let norm t = Normalize.normalize [Env.Beta;Env.Eager_unfolding;Env.EraseUniverses] env t in + if U.is_tot_or_gtot_comp comp + then None, U.comp_result comp + else begin match comp.n with + | GTotal _ + | Total _ -> failwith "Impossible" + | Comp ct -> + if lid_equals ct.effect_name C.effect_Pure_lid + || lid_equals ct.effect_name C.effect_Ghost_lid + then begin match ct.effect_args with + | (req, _)::(ens, _)::_ -> + Some (norm req), (norm <| mk_post_type ct.result_typ ens) + | _ -> + raise_error comp Errors.Fatal_EffectConstructorNotFullyApplied + (BU.format1 "Effect constructor is not fully applied; got %s" (show comp)) + end + else let ct = Env.unfold_effect_abbrev env comp in + begin match ct.effect_args with + | (wp, _)::_ -> + let us_r, _ = fst <| Env.lookup_lid env C.as_requires in + let us_e, _ = fst <| Env.lookup_lid env C.as_ensures in + let r = ct.result_typ.pos in + let as_req = S.mk_Tm_uinst (S.fvar (Ident.set_lid_range C.as_requires r) None) us_r in + let as_ens = S.mk_Tm_uinst (S.fvar (Ident.set_lid_range C.as_ensures r) None) us_e in + let req = mk_Tm_app as_req [(ct.result_typ, S.as_aqual_implicit true); S.as_arg wp] ct.result_typ.pos in + let ens = mk_Tm_app as_ens [(ct.result_typ, S.as_aqual_implicit true); S.as_arg wp] ct.result_typ.pos in + Some (norm req), norm (mk_post_type ct.result_typ ens) + | _ -> failwith "Impossible" + end + + end + +(* [norm_reify env t] assumes that [t] has the shape reify t0 *) +(* where env |- t0 : M t' for some effect M and type t' where M is reifiable *) +(* and returns the result of reducing t with reification on *) +let norm_reify (env:Env.env) (steps:Env.steps) (t:S.term) : S.term = + def_check_scoped t.pos "norm_reify" env t; + let t' = N.normalize + ([Env.Beta; Env.Reify; Env.Eager_unfolding; Env.EraseUniverses; Env.AllowUnboundUniverses; Env.Exclude Env.Zeta]@steps) + env t in + if !dbg_SMTEncodingReify + then BU.print2 "Reified body %s \nto %s\n" + (show t) + (show t') ; + t' + +let remove_reify (t: S.term): S.term = + if (match (SS.compress t).n with | Tm_app _ -> false | _ -> true) + then t + else + let head, args = U.head_and_args t in + if (match (SS.compress head).n with Tm_constant (FStarC.Const.Const_reify _) -> true | _ -> false) + then begin match args with + | [x] -> fst x + | _ -> failwith "Impossible : Reify applied to multiple arguments after normalization." + end + else t + + +(*********************************************************************************************) +(* Instantiation and generalization *) +(*********************************************************************************************) +let maybe_implicit_with_meta_or_attr aq (attrs:list attribute) = + match aq, attrs with + | Some (Meta _), _ + | Some (Implicit _), _::_ -> true + | _ -> false + +(* Instantiation of implicit arguments (meta or implicit) + * + * For meta arguments, we follow the exact same procedure as for instantiating an implicit, + * except that we keep track of the (uvar, env, metaprogram) triple in the environment + * so we can later come back to the implicit and, if it wasn't solved by unification, + * run the metaprogram on it. + * + * Why don't we run the metaprogram here? At this stage, it's very likely that `t` + * is full of unresolved uvars, and it wouldn't be a whole lot useful to try + * to find an instance for it. We might not even be able to, since instances + * are for concrete types. + *) +let instantiate_one_binder (env:env_t) (r:Range.range) (b:binder) : term & typ & aqual & guard_t = + if Debug.high () then + BU.print1 "instantiate_one_binder: Instantiating implicit binder %s\n" (show b); + let (++) = Env.conj_guard in + let { binder_bv=x } = b in + let ctx_uvar_meta, should_unrefine = uvar_meta_for_binder b in (* meta/attrs computed here *) + let t = x.sort in + let varg, _, implicits = + let msg = + let is_typeclass = + match ctx_uvar_meta with + | Some (Ctx_uvar_meta_tac tau) -> U.is_fvar C.tcresolve_lid tau + | _ -> false + in + if is_typeclass then "Typeclass constraint argument" + else if Some? ctx_uvar_meta then "Instantiating meta argument" + else "Instantiating implicit argument" + in + Env.new_implicit_var_aux msg r env t Strict ctx_uvar_meta should_unrefine + in + let aq = U.aqual_of_binder b in + let arg = varg, aq in + + let r = varg, t, aq, implicits in + if Debug.high () then + BU.print1 "instantiate_one_binder: result = %s\n" (show (r._1, r._2)); + r + +(* Will instantiate e, by applying it to some unification variables for its implicit +arguments, if that is needed to match the expected type in the environment. [t] is the type +of [e]. Returns elaborated [e'], its type [t'], and a guard. *) +let maybe_instantiate (env:Env.env) (e:term) (t:typ) : term & typ & guard_t = + let torig = SS.compress t in + if not env.instantiate_imp + then e, torig, mzero + else begin + if Debug.high () then + BU.print3 "maybe_instantiate: starting check for (%s) of type (%s), expected type is %s\n" + (show e) (show t) (show (Env.expected_typ env)); + (* Similar to U.arrow_formals, but makes sure to unfold + * recursively to catch all the binders across type + * definitions. TODO: Move to library? Revise other uses + * of arrow_formals{,_comp}?*) + let unfolded_arrow_formals env (t:term) : list binder = + let rec aux (env:Env.env) (bs:list binder) (t:term) : list binder = + let t = N.unfold_whnf env t in + let bs', t = U.arrow_formals t in + match bs' with + | [] -> bs + | bs' -> aux (Env.push_binders env bs') (bs@bs') t + in + aux env [] t + in + let number_of_implicits t = + let formals = unfolded_arrow_formals env t in + let n_implicits = + match formals |> BU.prefix_until (fun ({binder_qual=imp}) -> Option.isNone imp || U.eq_bqual imp (Some Equality)) with + | None -> List.length formals + | Some (implicits, _first_explicit, _rest) -> List.length implicits in + n_implicits + in + let inst_n_binders t = + match Env.expected_typ env with + | None -> None + | Some (expected_t, _) -> //the use_eq flag is irrelevant for instantiation + let n_expected = number_of_implicits expected_t in + let n_available = number_of_implicits t in + if n_available < n_expected + then raise_error env Errors.Fatal_MissingImplicitArguments [ + text "Expected a term with " ^/^ pp #int n_expected ^/^ text " implicit arguments, but " ^/^ + pp e ^/^ text " has only " ^/^ pp #int n_available ^^ text "."] + else Some (n_available - n_expected) + in + let decr_inst = function + | None -> None + | Some i -> Some (i - 1) + in + let t = N.unfold_whnf env t in + begin match t.n with + | Tm_arrow {bs; comp=c} -> + let bs, c = SS.open_comp bs c in + //instantiate at most inst_n implicit binders, when inst_n = Some n + //otherwise, instantate all implicits + //See issue #807 for why this is important + let rec aux (subst:list subst_elt) inst_n bs = + match inst_n, bs with + | Some 0, _ -> [], bs, subst, Env.trivial_guard //no more instantiations to do + | _, {binder_qual = Some (Implicit _)} ::rest + | _, {binder_qual = Some (Meta _)} ::rest + | _, {binder_attrs = _::_} :: rest -> + let b = List.hd bs in + let b = SS.subst_binder subst b in + let tm, ty, aq, g = instantiate_one_binder env e.pos b in + let subst = NT(b.binder_bv, tm)::subst in + let args, bs, subst, g' = aux subst (decr_inst inst_n) rest in + (tm, aq)::args, bs, subst, g ++ g' + + | _, bs -> [], bs, subst, mzero + in + let args, bs, subst, guard = aux [] (inst_n_binders t) bs in + begin match args, bs with + | [], _ -> //no implicits were instantiated + e, torig, guard + + | _, [] when not (U.is_total_comp c) -> + //don't instantiate implicitly, if it has an effect + e, torig, Env.trivial_guard + + | _ -> + + let t = match bs with + | [] -> U.comp_result c + | _ -> U.arrow bs c in + let t = SS.subst subst t in + let e = S.mk_Tm_app e args e.pos in + e, t, guard + end + + | _ -> e, torig, Env.trivial_guard + end + end + +(************************************************************************) +(* Convertibility *) +(************************************************************************) +//check_has_type env e t1 t2 +//checks is e:t1 has type t2, subject to some guard. + +let check_has_type env (e:term) (t1:typ) (t2:typ) (use_eq:bool) : guard_t = + let env = Env.set_range env e.pos in + + let g_opt = + if env.use_eq_strict + then match Rel.teq_nosmt_force env t1 t2 with + | false -> None + | true -> Env.trivial_guard |> Some + else if use_eq + then Rel.try_teq true env t1 t2 + else match Rel.get_subtyping_predicate env t1 t2 with + | None -> None + | Some f -> apply_guard f e |> Some in + + match g_opt with + | None -> Err.expected_expression_of_type env (Env.get_range env) t2 e t1 + | Some g -> g + +let check_has_type_maybe_coerce env (e:term) (lc:lcomp) (t2:typ) use_eq : term & lcomp & guard_t = + let env = Env.set_range env e.pos in + let e, lc, g_c = maybe_coerce_lc env e lc t2 in + let g = check_has_type env e lc.res_typ t2 use_eq in + if !dbg_Rel then + BU.print1 "Applied guard is %s\n" <| guard_to_string env g; + e, lc, (Env.conj_guard g g_c) + +///////////////////////////////////////////////////////////////////////////////// +let check_top_level env g lc : (bool & comp) = + Errors.with_ctx "While checking for top-level effects" (fun () -> + if Debug.medium () then + BU.print1 "check_top_level, lc = %s\n" (TcComm.lcomp_to_string lc); + let discharge g = + force_trivial_guard env g; + TcComm.is_pure_lcomp lc in + let g = Rel.solve_deferred_constraints env g in + let c, g_c = TcComm.lcomp_comp lc in + if TcComm.is_total_lcomp lc + then discharge (Env.conj_guard g g_c), c + else let c = Env.unfold_effect_abbrev env c in + let us = c.comp_univs in + if Env.is_layered_effect env c.effect_name + then begin + // + // A top-level indexed effect + // We will look at the top_level_effect attr for the effect definition + // and make sure that c unifies with it + // + let c_eff = c.effect_name in + let ret_comp = c |> S.mk_Comp in + // + // Using simplify etc. to help unificiation of logical effect arguments + // E.g., F* may insert returns, equalities, with which a precondition + // may look like e ==> True, + // as opposed to just True specified in the top-level effect abbreviation + // + // But this is just for unification, we return the original comp (ret_comp) + // without normalization + // + let steps = [Env.Eager_unfolding; Env.Simplify; Env.Primops; Env.NoFullNorm] in + let c = + c + |> S.mk_Comp + |> Normalize.normalize_comp steps env in + let top_level_eff_opt = Env.get_top_level_effect env c_eff in + match top_level_eff_opt with + | None -> + raise_error + (Env.get_range env) + Errors.Fatal_UnexpectedEffect + (BU.format1 "Indexed effect %s cannot be used as a top-level effect" (c_eff |> Ident.string_of_lid)) + | Some top_level_eff -> + // If top-level effect is same as c_eff, return + if Ident.lid_equals top_level_eff c_eff + then discharge g_c, ret_comp + else + let bc_opt = Env.lookup_effect_abbrev env us top_level_eff in + match bc_opt with + | None -> + raise_error env Errors.Fatal_UnexpectedEffect + (BU.format2 "Could not find top-level effect abbreviation %s for %s" + (Ident.string_of_lid top_level_eff) + (c_eff |> Ident.string_of_lid)) + | Some (bs, _) -> + let debug = !dbg_LayeredEffectsApp in + // + // Typechecking of effect abbreviation ensures that there is at least + // one return type argument, so the following a::bs is ok + // + let a::bs = SS.open_binders bs in + let uvs, g_uvs = + Env.uvars_for_binders + env + bs + [NT (a.binder_bv, U.comp_result c)] + (fun b -> + if debug + then BU.format2 + "implicit for binder %s in effect abbreviation %s while checking top-level effect" + (show b) + (Ident.string_of_lid top_level_eff) + else "check_top_level") + (Env.get_range env) in + let top_level_comp = + ({ comp_univs = us; + effect_name = top_level_eff; + result_typ = U.comp_result c; + effect_args = uvs |> List.map S.as_arg; + flags = [] }) |> S.mk_Comp in + // Unify + let gopt = Rel.eq_comp env top_level_comp c in + match gopt with + | None -> + raise_error env Errors.Fatal_UnexpectedEffect + (BU.format2 "Could not unify %s and %s when checking top-level effect" + (show top_level_comp) + (show c)) + | Some g -> + discharge (Env.conj_guards [g_c; g_uvs; g]), ret_comp + end + else let steps = [Env.Beta; Env.NoFullNorm; Env.DoNotUnfoldPureLets] in + let c = c + |> S.mk_Comp + |> Normalize.normalize_comp steps env in + let ct, vc, g_pre = check_trivial_precondition_wp env c in + if !dbg_Simplification + then BU.print1 "top-level VC: %s\n" (show vc); + discharge (Env.conj_guard g (Env.conj_guard g_c g_pre)), ct |> S.mk_Comp + ) + +(* Having already seen_args to head (from right to left), + compute the guard, if any, for the next argument, + if head is a short-circuiting operator *) +let short_circuit (head:term) (seen_args:args) : guard_formula = + let short_bin_op f : args -> guard_formula = function + | [] -> (* no args seen yet *) Trivial + | [(fst, _)] -> f fst + | _ -> failwith "Unexpected args to binary operator" in + + let op_and_e e = U.b2t e |> NonTrivial in + let op_or_e e = U.mk_neg (U.b2t e) |> NonTrivial in + let op_and_t t = t |> NonTrivial in + let op_or_t t = t |> U.mk_neg |> NonTrivial in + let op_imp_t t = t |> NonTrivial in + + let short_op_ite : args -> guard_formula = function + | [] -> Trivial + | [(guard, _)] -> NonTrivial guard + | [_then;(guard, _)] -> U.mk_neg guard |> NonTrivial + | _ -> failwith "Unexpected args to ITE" in + let table = + [(C.op_And, short_bin_op op_and_e); + (C.op_Or, short_bin_op op_or_e); + (C.and_lid, short_bin_op op_and_t); + (C.or_lid, short_bin_op op_or_t); + (C.imp_lid, short_bin_op op_imp_t); + (C.ite_lid, short_op_ite);] in + + match head.n with + | Tm_fvar fv -> + let lid = fv.fv_name.v in + begin match BU.find_map table (fun (x, mk) -> if lid_equals x lid then Some (mk seen_args) else None) with + | None -> Trivial + | Some g -> g + end + | _ -> Trivial + +let short_circuit_head l = + match (U.un_uinst l).n with + | Tm_fvar fv -> + BU.for_some (S.fv_eq_lid fv) + [C.op_And; + C.op_Or; + C.and_lid; + C.or_lid; + C.imp_lid; + C.ite_lid] + | _ -> false + + + +(************************************************************************) +(* maybe_add_implicit_binders (env:env) (bs:binders) *) +(* Adding implicit binders *) +(* in case the expected type is of the form #a1 -> ... -> #an -> t *) +(* and bs does not begin with any implicit binders *) +(* add #a1 ... #an to bs *) +(* Note that there may be other implicit binders in t that bs don't *) +(* We don't add them here, so in that sense it is best case effort *) +(* This helps us sometimes to build a better decreases clause *) +(* since it helps us count the arity by including implicits *) +(************************************************************************) +let maybe_add_implicit_binders (env:env) (bs:binders) : binders = + let is_implicit_binder ({binder_qual=q}) : bool = + match q with + | Some (Implicit _) + | Some (Meta _) -> true + | _ -> false in + + let pos bs = match bs with + | ({binder_bv=hd})::_ -> S.range_of_bv hd + | _ -> Env.get_range env in + + match bs with + | b :: _ when is_implicit_binder b -> bs // bs begins with an implicit binder; don't add any + | _ -> + match Env.expected_typ env with + | None -> bs + | Some (t, _) -> //the use_eq flag is not relevant + match (SS.compress t).n with + | Tm_arrow {bs=bs'} -> + begin match BU.prefix_until (fun b -> not (is_implicit_binder b)) bs' with + | None -> bs + | Some ([], _, _) -> bs // no implicits in the prefix + | Some (imps, _, _) -> + let r = pos bs in + let imps = + imps |> List.map (fun b -> { b with binder_bv = (S.set_range_of_bv b.binder_bv r) }) in + imps@bs // we have a prefix of implicits + end + + | _ -> bs + + +let must_erase_for_extraction (g:env) (t:typ) = + let rec descend env t = //t is expected to b in WHNF + match (SS.compress t).n with + | Tm_arrow _ -> + let bs, c = U.arrow_formals_comp t in + let env = FStarC.TypeChecker.Env.push_binders env bs in + (Env.is_erasable_effect env (U.comp_effect_name c)) //includes GHOST + || (U.is_pure_or_ghost_comp c && aux env (U.comp_result c)) + | Tm_refine {b={sort=t}} -> + aux env t + | Tm_app {hd=head} + | Tm_uinst (head, _) -> + descend env head + | Tm_fvar fv -> + //special treatment for must_erase_for_extraction here + //See Env.type_is_erasable for more explanations + Env.fv_has_attr env fv C.must_erase_for_extraction_attr + | _ -> false + and aux env t = + let t = N.normalize [Env.Primops; + Env.Weak; + Env.HNF; + Env.UnfoldUntil delta_constant; + Env.Beta; + Env.AllowUnboundUniverses; + Env.Zeta; + Env.Iota; + Env.Unascribe] env t in +// debug g (fun () -> BU.print1 "aux %s\n" (show t)); + let res = Env.non_informative env t || descend env t in + if !dbg_Extraction + then BU.print2 "must_erase=%s: %s\n" (if res then "true" else "false") (show t); + res + in + aux g t + +let effect_extraction_mode env l = + l |> Env.norm_eff_name env + |> Env.get_effect_decl env + |> (fun ed -> ed.extraction_mode) + +let fresh_effect_repr env r eff_name signature_ts repr_ts_opt u a_tm = + let fail t = Err.unexpected_signature_for_monad env r eff_name t in + + let _, signature = Env.inst_tscheme signature_ts in + + let debug = !dbg_LayeredEffectsApp in + + (* + * We go through the binders in the signature a -> bs + * For each binder in bs, create a fresh uvar + * But keep substituting [a/a_tm, b_i/?ui] in the sorts of the subsequent binders + *) + match (SS.compress signature).n with + | Tm_arrow {bs} -> + let bs = SS.open_binders bs in + (match bs with + | a::bs -> + //is is all the uvars, and g is their collective guard + let is, g = + Env.uvars_for_binders env bs [NT (a.binder_bv, a_tm)] + (fun b -> + if debug + then BU.format3 + "uvar for binder %s when creating a fresh repr for %s at %s" + (show b) (string_of_lid eff_name) (Range.string_of_range r) + else "fresh_effect_repr") r in + (match repr_ts_opt with + | None -> //no repr, return thunked computation type + let eff_c = mk_Comp ({ + comp_univs = [u]; + effect_name = eff_name; + result_typ = a_tm; + effect_args = List.map S.as_arg is; + flags = [] }) in + S.mk (Tm_arrow {bs=[S.null_binder S.t_unit]; comp=eff_c}) r + | Some repr_ts -> + let repr = Env.inst_tscheme_with repr_ts [u] |> snd in + let is_args = List.map2 (fun i b -> (i, U.aqual_of_binder b)) is bs in + S.mk_Tm_app + repr + (S.as_arg a_tm::is_args) + r), g + | _ -> fail signature) + | _ -> fail signature + +let fresh_effect_repr_en env r eff_name u a_tm = + eff_name + |> Env.get_effect_decl env + |> (fun ed -> fresh_effect_repr env r eff_name (U.effect_sig_ts ed.signature) (ed |> U.get_eff_repr) u a_tm) + +let layered_effect_indices_as_binders env r eff_name sig_ts u a_tm = + let _, sig_tm = Env.inst_tscheme_with sig_ts [u] in + + let fail t = Err.unexpected_signature_for_monad env r eff_name t in + + match (SS.compress sig_tm).n with + | Tm_arrow {bs} -> + let bs = SS.open_binders bs in + (match bs with + | ({binder_bv=a'})::bs -> bs |> SS.subst_binders [NT (a', a_tm)] + | _ -> fail sig_tm) + | _ -> fail sig_tm + + +let check_non_informative_type_for_lift env m1 m2 t (r:Range.range) : unit = + //raise an error if m1 is erasable, m2 is not erasable, and t is informative + if Env.is_erasable_effect env m1 && + not (Env.is_erasable_effect env m2) && + not (N.non_info_norm env t) + then Errors.raise_error r Errors.Error_TypeError + (BU.format3 "Cannot lift erasable expression from %s ~> %s since its type %s is informative" + (string_of_lid m1) + (string_of_lid m2) + (show t)) + +// +// Apply a substitutive indexed lift +// +let substitutive_indexed_lift_substs (env:env) + (bs:binders) + (ct:comp_typ) + (lift_name:string) + (r:Range.range) + + : list subst_elt & guard_t = + + let debug = !dbg_LayeredEffectsApp in + + let bs, subst = + let a_b::bs = bs in + bs, [NT (a_b.binder_bv, ct.result_typ)] in + + let bs, subst = + let m_num_effect_args = List.length ct.effect_args in + let f_bs, bs = List.splitAt m_num_effect_args bs in + let f_subst = List.map2 (fun f_b (arg, _) -> NT (f_b.binder_bv, arg)) f_bs ct.effect_args in + bs, subst@f_subst in + + let bs = List.splitAt (List.length bs - 1) bs |> fst in + + List.fold_left (fun (subst, g) b -> + let [uv_t], g_uv = Env.uvars_for_binders env [b] subst + (fun b -> + if debug + then BU.format3 "implicit var for additional lift binder %s of %s at %s)" + (show b) + lift_name + (Range.string_of_range r) + else "substitutive_indexed_lift_substs") r in + subst@[NT (b.binder_bv, uv_t)], + Env.conj_guard g g_uv) (subst, Env.trivial_guard) bs + +let ad_hoc_indexed_lift_substs (env:env) + (bs:binders) + (ct:comp_typ) + (lift_name:string) + (r:Range.range) + + : list subst_elt & guard_t = + + let debug = !dbg_LayeredEffectsApp in + + let lift_t_shape_error s = + BU.format2 "Lift %s has unexpected shape, reason: %s" + lift_name s in + + let a_b, (rest_bs, [f_b]) = + if List.length bs >= 2 + then let a_b::bs = bs in + a_b, List.splitAt (List.length bs - 1) bs + else raise_error r Errors.Fatal_UnexpectedEffect + (lift_t_shape_error "either not an arrow or not enough binders") in + + let rest_bs_uvars, g = + Env.uvars_for_binders env rest_bs + [NT (a_b.binder_bv, ct.result_typ)] + (fun b -> + if debug + then BU.format3 + "implicit var for binder %s of %s at %s" + (show b) + lift_name + (Range.string_of_range r) + else "ad_hoc_indexed_lift_substs") r in + + let substs = List.map2 + (fun b t -> NT (b.binder_bv, t)) + (a_b::rest_bs) (ct.result_typ::rest_bs_uvars) in + + let guard_f = + let f_sort = f_b.binder_bv.sort |> SS.subst substs |> SS.compress in + let f_sort_is = effect_args_from_repr f_sort (Env.is_layered_effect env ct.effect_name) r in + List.fold_left2 + (fun g i1 i2 -> Env.conj_guard g (Rel.layered_effect_teq env i1 i2 (Some lift_name))) + Env.trivial_guard (List.map fst ct.effect_args) f_sort_is in + + substs, + Env.conj_guard g guard_f + +let lift_tf_layered_effect (tgt:lident) (lift_ts:tscheme) (kind:S.indexed_effect_combinator_kind) + env (c:comp) : comp & guard_t = + + let debug = !dbg_LayeredEffectsApp in + + if debug then + BU.print2 "Lifting indexed comp %s to %s {\n" + (show c) (show tgt); + + let r = Env.get_range env in + + let ct = Env.comp_to_comp_typ env c in + + check_non_informative_type_for_lift env ct.effect_name tgt ct.result_typ r; + + let lift_name () = + if debug then BU.format2 "%s ~> %s" (string_of_lid ct.effect_name) (string_of_lid tgt) + else "" in + + let _, lift_t = Env.inst_tscheme_with lift_ts [List.hd ct.comp_univs] in + + let bs, lift_c = U.arrow_formals_comp lift_t in + + let substs, g = + if kind = S.Ad_hoc_combinator + then ad_hoc_indexed_lift_substs env bs ct (lift_name ()) r + else substitutive_indexed_lift_substs env bs ct (lift_name ()) r in + + let lift_ct = lift_c |> SS.subst_comp substs |> Env.comp_to_comp_typ env in + + let is = effect_args_from_repr lift_ct.result_typ (Env.is_layered_effect env tgt) r in + + //compute the formula `lift_c.wp (fun _ -> True)` and add it to the final guard + let fml = + let u, wp = List.hd lift_ct.comp_univs, fst (List.hd lift_ct.effect_args) in + Env.pure_precondition_for_trivial_post env u lift_ct.result_typ wp Range.dummyRange in + + if !dbg_LayeredEffects && + Debug.extreme () + then BU.print1 "Guard for lift is: %s" (show fml); + + let c = mk_Comp ({ + comp_univs = ct.comp_univs; + effect_name = tgt; + result_typ = ct.result_typ; + effect_args = is |> List.map S.as_arg; + flags = [] //AR: setting the flags to empty + }) in + + if debug then BU.print1 "} Lifted comp: %s\n" (show c); + + let g = Env.conj_guards [ + g; + Env.guard_of_guard_formula (TcComm.NonTrivial fml) ] in + + c, g + +(* + * Creating the Env.mlift.mlift_term function for layered effects + * Quite simple, just apply the lift term, passing units for the + * binders that are meant to compute indices + *) +let lift_tf_layered_effect_term env (sub:sub_eff) + (u:universe) (a:typ) (e:term) : term = + + let lift = sub.lift |> must |> (fun ts -> inst_tscheme_with ts [u]) |> snd in + + let rest_bs = + let lift_t = sub.lift_wp |> must in + match (lift_t |> snd |> SS.compress).n with + | Tm_arrow {bs=_::bs} when List.length bs >= 1 -> + bs |> List.splitAt (List.length bs - 1) |> fst + | _ -> + raise_error (snd lift_t) Errors.Fatal_UnexpectedEffect + (BU.format1 "lift_t tscheme %s is not an arrow with enough binders" + (Print.tscheme_to_string lift_t)) + in + + let args = (S.as_arg a)::((rest_bs |> List.map (fun _ -> S.as_arg S.unit_const))@[S.as_arg e]) in + mk (Tm_app {hd=lift; args}) e.pos + +let get_field_projector_name env datacon index = + let _, t = Env.lookup_datacon env datacon in + let err n = + raise_error env Errors.Fatal_UnexpectedDataConstructor + (BU.format3 "Data constructor %s does not have enough binders (has %s, tried %s)" + (show datacon) (show n) (show index)) in + match (SS.compress t).n with + | Tm_arrow {bs} -> + let bs = bs |> List.filter (fun ({binder_qual=q}) -> match q with | Some (Implicit true) -> false | _ -> true) in + if List.length bs <= index then err (List.length bs) + else + let b = List.nth bs index in + U.mk_field_projector_name datacon b.binder_bv index + | _ -> err 0 + + +let get_mlift_for_subeff env (sub:S.sub_eff) : Env.mlift = + if Env.is_layered_effect env sub.source || Env.is_layered_effect env sub.target + + then + ({ mlift_wp = lift_tf_layered_effect sub.target (sub.lift_wp |> must) (sub.kind |> must); + mlift_term = Some (lift_tf_layered_effect_term env sub) }) + + else + let mk_mlift_wp ts env c = + let ct = Env.comp_to_comp_typ env c in + check_non_informative_type_for_lift env ct.effect_name sub.target ct.result_typ env.range; + let _, lift_t = inst_tscheme_with ts ct.comp_univs in + let wp = List.hd ct.effect_args in + S.mk_Comp ({ ct with + effect_name = sub.target; + effect_args = + [mk (Tm_app {hd=lift_t; args=[as_arg ct.result_typ; wp]}) (fst wp).pos |> S.as_arg] + }), TcComm.trivial_guard + in + + let mk_mlift_term ts u r e = + let _, lift_t = inst_tscheme_with ts [u] in + mk (Tm_app {hd=lift_t; args=[as_arg r; as_arg S.tun; as_arg e]}) e.pos + in + + ({ mlift_wp = sub.lift_wp |> must |> mk_mlift_wp; + //AR: this is funky + //it is saying, if you don't give us a lift term (a function that lifts terms), + //we are assuming that the function is an identity + //so for example, primitive effects just specify lift wps, and not terms + //for them we assume that the terms are identity functions + //why do we need it? + //suppose programmer writes a layered effect M and defines a lift from DIV to M + //now a PURE computation in the VC gets lifted via: PURE ~> DIV ~> M + //when extracting (and reifying the monadic lifts), we go the same route + //but if there is no lift term from PURE ~> DIV, we get an error + //is this ok to do for DM4F? not sure in general + //but currently PURE and DIV are lifted to DM4F effects using M.return + //and not using the lift term (I don't think the lift term is even supported for DM4F, is it?) + mlift_term = + match sub.lift with + | None -> Some (fun _ _ e -> return_all e) + | Some ts -> Some (mk_mlift_term ts) }) + + +let update_env_sub_eff env sub r = + let r0 = env.range in + let env = Env.update_effect_lattice + ({ env with range = r }) sub.source sub.target (get_mlift_for_subeff env sub) in + { env with range = r0 } + +let update_env_polymonadic_bind env m n p ty k = + // + //false means no range support in polymonadic bind yet + // + Env.add_polymonadic_bind env m n p + (fun env c1 bv_opt c2 flags r -> + mk_indexed_bind env m n p ty k c1 bv_opt c2 flags r 0 false) + +(*** Utilities for type-based record + disambiguation ***) + + +(* + For singleton inductive types named `typename`, + it looks up the name of the constructor, + and the field names of that constructor + *) +let try_lookup_record_type env (typename:lident) + : option DsEnv.record_or_dc + = try + match Env.datacons_of_typ env typename with + | _, [dc] -> + let se = Env.lookup_sigelt env dc in + (match se with + | Some ({sigel=Sig_datacon {t; num_ty_params=nparms}}) -> + let formals, c = U.arrow_formals t in + if nparms < List.length formals + then let _, fields = List.splitAt nparms formals in //remove params + let fields = List.filter (fun b -> match b.binder_qual with | Some (Implicit _) -> false | _ -> true) fields in //remove implicits + let fields = List.map (fun b -> b.binder_bv.ppname, b.binder_bv.sort) fields in + let is_rec = Env.is_record env typename in + let r : DsEnv.record_or_dc = + { + typename = typename; + constrname = Ident.ident_of_lid dc; + parms = []; + fields = fields; + is_private = false; + is_record = is_rec + } + in + Some r + + else ( + // BU.print3 "Not enough formals; nparms=%s; type = %s; formals=%s\n" + // (string_of_int nparms) + // (show t) + // (Print.binders_to_string ", " formals); + None + ) + | _ -> + // BU.print1 "Could not find %s\n" (string_of_lid dc); + None) + | _, dcs -> + // BU.print2 "Could not find type %s ... Got %s\n" + // (string_of_lid typename) + // (FStarC.Common.string_of_list Ident.string_of_lid dcs); + None + with + | _ -> None + +(* + If ToSyntax guessed `uc` + and the typechecker decided that type `t: option typ` was the type + to be used for disambiguation, then if + + - t is None, the uc is used + - otherwise t overrides uc + *) +let find_record_or_dc_from_typ env (t:option typ) (uc:unresolved_constructor) rng = + let default_rdc () = + let open FStarC.Errors.Msg in + match uc.uc_typename, uc.uc_fields with + | None, [] -> + raise_error rng Errors.Error_CannotResolveRecord [ + text "Could not resolve the type for this record."; + ] + + | None, f::_ -> + let f = List.hd uc.uc_fields in + raise_error f Errors.Error_CannotResolveRecord [ + text <| BU.format1 "Field name %s could not be resolved." (string_of_lid f); + ] + + | Some tn, _ -> + match try_lookup_record_type env tn with + | Some rdc -> rdc + | None -> + raise_error tn Errors.Fatal_NameNotFound + (BU.format1 "Record name %s not found." (string_of_lid tn)) + in + let rdc : DsEnv.record_or_dc = + match t with + | None -> default_rdc() + | Some t -> + let thead, _ = + U.head_and_args (N.unfold_whnf' [Unascribe; Unmeta; Unrefine] env t) + in + match (SS.compress (U.un_uinst thead)).n with + | Tm_fvar type_name -> + begin + match try_lookup_record_type env type_name.fv_name.v with + | None -> default_rdc () + | Some r -> r + end + | _ -> default_rdc() + in + let constrname = + let name = lid_of_ids (ns_of_lid rdc.typename @ [rdc.constrname]) in + Ident.set_lid_range name rng + in + let constructor = + let qual = + if rdc.is_record + then (Some (Record_ctor(rdc.typename, rdc.fields |> List.map fst))) + else None + in + S.lid_as_fv constrname qual + in + rdc, constrname, constructor + + +(* Check if a user provided `field_name` in a constructor or projector + matches `field` in `rdc`. + + The main subtlety is that if `field_name` is unqualified, then it only + has to match `field`. + + Otherwise, its namespace also has to match the module name of `rdc`. + + This ensures that if the user wrote a qualified field name, then it + has to resolve to a field in the unambiguous module reference in + the qualifier. +*) +let field_name_matches (field_name:lident) (rdc:DsEnv.record_or_dc) (field:ident) = + Ident.ident_equals field (Ident.ident_of_lid field_name) && + (if ns_of_lid field_name <> [] + then nsstr field_name = nsstr rdc.typename + else true) + +(* + The field assignments of a record constructor can be given out of + order. + + Given that we've committed to `rdc` as the record constructor, if + the user's field assignments are `fas`, then we order the alphas + by the order in which they appear in `rdc`. + + If a particular field cannot be found, then we call not_found, which + an provide a default. + + We raise errors if fields are not found and no default exists, or if + redundant fields are present. +*) +let make_record_fields_in_order env uc topt + (rdc : DsEnv.record_or_dc) + (fas : list (lident & 'a)) + (not_found:ident -> option 'a) + (rng : Range.range) + : list 'a + = let debug () = + let print_rdc (rdc:DsEnv.record_or_dc) = + BU.format3 "{typename=%s; constrname=%s; fields=[%s]}" + (string_of_lid rdc.typename) + (string_of_id rdc.constrname) + (List.map (fun (i, _) -> string_of_id i) rdc.fields |> String.concat "; ") + in + let print_topt topt = + BU.format2 "topt=%s; rdc=%s" (show topt) (print_rdc rdc) + in + BU.print5 "Resolved uc={typename=%s;fields=%s}\n\ttopt=%s\n\t{rdc = %s\n\tfield assignments=[%s]}\n" + (show uc.uc_typename) + (show uc.uc_fields) + (print_topt topt) + (print_rdc rdc) + (show (List.map fst fas)) + in + let rest, as_rev, missing = + List.fold_left + (fun (fields, as_rev, missing) (field_name, _) -> + let matching, rest = + List.partition + (fun (fn, _) -> field_name_matches fn rdc field_name) + fields + in + match matching with + | [(_, a)] -> + rest, a::as_rev, missing + + | [] -> ( + match not_found field_name with + | None -> +// debug(); + rest, as_rev, field_name :: missing + | Some a -> + rest, a::as_rev, missing + ) + + | _ -> +// debug(); + raise_error rng Errors.Fatal_MissingFieldInRecord + (BU.format2 "Field %s of record type %s is given multiple assignments" + (string_of_id field_name) + (string_of_lid rdc.typename))) + (fas, [], []) + rdc.fields + in + let pp_missing () = + separate_map (comma ^^ break_ 1) (fun f -> squotes (doc_of_string (show f))) missing + in + let _ = + match rest, missing with + | [], [] -> () + | (f, _)::_, _ -> +// debug(); + raise_error f Errors.Fatal_MissingFieldInRecord [ + Errors.Msg.text <| BU.format2 "Field '%s' is redundant for type %s" (show f) (show rdc.typename); + if Cons? missing then + prefix 2 1 (text "Missing fields:") + (pp_missing ()) + else + Pprint.empty; + ] + + | [], _ -> + raise_error rng Errors.Fatal_MissingFieldInRecord [ + prefix 2 1 (text <| BU.format1 "Missing fields for record type '%s':" (show rdc.typename)) + (pp_missing ()) + ] + in + List.rev as_rev diff --git a/src/typechecker/FStarC.TypeChecker.Util.fsti b/src/typechecker/FStarC.TypeChecker.Util.fsti new file mode 100644 index 00000000000..af2e8733647 --- /dev/null +++ b/src/typechecker/FStarC.TypeChecker.Util.fsti @@ -0,0 +1,193 @@ +(* + Copyright 2008-2014 Nikhil Swamy and Microsoft Research + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +*) + +module FStarC.TypeChecker.Util +open FStar.Pervasives +open FStarC.Compiler.Effect + +open FStar open FStarC +open FStarC.Compiler +open FStarC.TypeChecker +open FStarC.Syntax +open FStarC.TypeChecker.Env +open FStarC.Syntax.Syntax +open FStarC.Ident +open FStarC.TypeChecker.Common + +type lcomp_with_binder = option bv & lcomp + +//error report +// val report: env -> list string -> unit + +//unification variables +val new_implicit_var : string -> Range.range -> env -> typ -> unrefine:bool -> term & (ctx_uvar & Range.range) & guard_t +val check_uvars: Range.range -> typ -> unit + +//caller can set the boolean to true if they want to solve the deferred constraints involving this binder now (best case) +val close_guard_implicits: env -> bool -> binders -> guard_t -> guard_t + +//extracting annotations from a term +val extract_let_rec_annotation: env -> letbinding -> univ_names & typ & term & bool + +//pattern utilities +//val decorate_pattern: env -> pat -> term -> pat +val decorated_pattern_as_term: pat -> list bv & term + +//instantiation of implicits +val maybe_implicit_with_meta_or_attr: bqual -> list attribute -> bool + +val instantiate_one_binder (env:env_t) (r:Range.range) (b:binder) : term & typ & aqual & guard_t +val maybe_instantiate : env -> term -> typ -> (term & typ & guard_t) + +//operations on computation types +(* most operations on computations are lazy *) +val lcomp_univ_opt: lcomp -> (option universe & guard_t) +val is_pure_effect: env -> lident -> bool +val is_pure_or_ghost_effect: env -> lident -> bool +val should_not_inline_lc: lcomp -> bool +val bind: Range.range -> env -> option term -> lcomp -> lcomp_with_binder -> lcomp +val maybe_return_e2_and_bind: Range.range -> env -> option term -> lcomp -> e2:term -> lcomp_with_binder -> lcomp + +(* + * When typechecking a match term, typechecking each branch returns + * a branch condition + * + * E.g. match e with | C -> ... | D -> ... + * the two branch conditions would be (is_C e) and (is_D e) + * + * This function builds a list of formulas that are the negation of + * all the previous branches + * + * In the example, neg_branch_conds would be: + * [True; not (is_C e); not (is_C e) /\ not (is_D e)] + * thus, the length of the list is one more than lcases + * + * The return value is then ([True; not (is_C e)], not (is_C e) /\ not (is_D e)) + * + * (The last element of the list becomes the branch condition for the + unreachable branch to check for pattern exhaustiveness) + *) +val get_neg_branch_conds: list formula -> list formula & formula + +//the bv is the scrutinee binder, that bind_cases uses to close the guard (from lifting the computations) +val bind_cases: env -> typ -> list (typ & lident & list cflag & (bool -> lcomp)) -> bv -> lcomp + +(* + * weaken_result_type env e lc t use_eq + * precondition: env |- e : lc + * + * tries to weaken the result type of lc to t + * + * roughly checking that lc.result_typ <: t + * + * but if either (a) use_eq argument is true, or + * (b) env.use_eq is true, or + * (c) env.use_eq_strict is true, then checking that lc.result_typ = t + * + *) +val weaken_result_typ: env -> term -> lcomp -> typ -> bool -> term & lcomp & guard_t + +val strengthen_precondition: (option (unit -> list Pprint.document) -> env -> term -> lcomp -> guard_t -> lcomp&guard_t) +val weaken_guard: guard_formula -> guard_formula -> guard_formula +val weaken_precondition: env -> lcomp -> guard_formula -> lcomp +val maybe_assume_result_eq_pure_term: env -> term -> lcomp -> lcomp +val close_layered_lcomp_with_combinator: env -> list bv -> lcomp -> lcomp +val close_wp_lcomp: env -> list bv -> lcomp -> lcomp +val close_layered_lcomp_with_substitutions: env -> list bv -> list term -> lcomp -> lcomp +val pure_or_ghost_pre_and_post: env -> comp -> (option typ & typ) + +// +// Setting the boolean flag to true, clients may say if they want to use equality +// instead of subtyping +// +val check_comp: env -> use_eq:bool -> term -> comp -> comp -> term & comp & guard_t + +val universe_of_comp: env -> universe -> comp -> universe +(* + * return value: formula for input comp to have trivial wp * guard for that formula + *) +val check_trivial_precondition_wp : env -> comp -> (comp_typ & formula & guard_t) + +// +//checking that e:t is convertible to t' +// +//set the boolan flag to true if you want to check for type equality +// +val check_has_type : env -> term -> t:typ -> t':typ -> use_eq:bool -> guard_t +val check_has_type_maybe_coerce : env -> term -> lcomp -> typ -> bool -> term & lcomp & guard_t + +val check_top_level: env -> guard_t -> lcomp -> bool&comp + +val maybe_coerce_lc : env -> term -> lcomp -> typ -> term & lcomp & guard_t + +//misc. +val label: list Pprint.document -> Range.range -> typ -> typ +val label_guard: Range.range -> list Pprint.document -> guard_t -> guard_t +val short_circuit: term -> args -> guard_formula +val short_circuit_head: term -> bool +val maybe_add_implicit_binders: env -> binders -> binders +val fvar_env: env -> lident -> term +val norm_reify: env -> steps -> term -> term +val remove_reify: term -> term + +//decorating terms with monadic operators +val maybe_lift: env -> term -> lident -> lident -> typ -> term +val maybe_monadic: env -> term -> lident -> typ -> term + +val must_erase_for_extraction: env -> term -> bool + +//layered effect utilities + +val effect_extraction_mode : env -> lident -> eff_extraction_mode + +(* + * This function returns ed.repr a ?u1 ... ?un (note that u must be the universe of a) + * where ?u1 ... ?un are unification variables, one for each index of the layered effect + * + * The unification variables are resolved in the input env + *) +val fresh_effect_repr: env -> Range.range -> lident -> signature:tscheme -> repr:option tscheme -> u:universe -> a:term -> term & guard_t + +(* + * A wrapper over fresh_layered_effect_repr that looks up signature and repr from env + * + * If the effect does not have a repr (e.g. primitive effects), then we return a `unit -> M a ?u` term + *) +val fresh_effect_repr_en: env -> Range.range -> lident -> universe -> term -> term & guard_t + +(* + * Return binders for the layered effect indices with signature + * In the binder types, a is substituted with a_tm (u is universe of a) + *) +val layered_effect_indices_as_binders:env -> Range.range -> eff_name:lident -> signature:tscheme -> u:universe -> a_tm:term -> binders + +val get_field_projector_name : env -> datacon:lident -> index:int -> lident + + +(* update the env functions *) +val update_env_sub_eff : env -> sub_eff -> Range.range -> env +val update_env_polymonadic_bind : + env -> lident -> lident -> lident -> tscheme -> indexed_effect_combinator_kind -> env + +val try_lookup_record_type : env -> lident -> option DsEnv.record_or_dc +val find_record_or_dc_from_typ : env -> option typ -> unresolved_constructor -> Range.range -> DsEnv.record_or_dc & lident & fv +val field_name_matches : lident -> DsEnv.record_or_dc -> ident -> bool +val make_record_fields_in_order : env -> unresolved_constructor -> option (either typ typ) -> + DsEnv.record_or_dc -> + list (lident & 'a) -> + not_found:(ident -> option 'a) -> + Range.range -> + list 'a diff --git a/tests/semiring/CanonCommSemiring.ml.fixup b/tests/semiring/CanonCommSemiring.ml.fixup index e878dced53d..02da1deab67 100644 --- a/tests/semiring/CanonCommSemiring.ml.fixup +++ b/tests/semiring/CanonCommSemiring.ml.fixup @@ -3,7 +3,7 @@ (* This is needed since we have no automatic embeddings for Tac functions, but we should add them *) let _ = - FStar_Tactics_Native.register_tactic "CanonCommSemiring.canon_semiring_aux" + FStarC_Tactics_Native.register_tactic "CanonCommSemiring.canon_semiring_aux" (Prims.parse_int "11") (fun psc -> fun ncb -> @@ -11,22 +11,22 @@ let _ = fun args -> match args with | (tv_0,_)::args_tail -> - (FStar_Tactics_InterpFuns.mk_tactic_interpretation_9 + (FStarC_Tactics_InterpFuns.mk_tactic_interpretation_9 "CanonCommSemiring.canon_semiring_aux (plugin)" - (FStar_Tactics_Native.from_tactic_9 canon_semiring_aux) - FStar_Reflection_V2_Embeddings.e_term - (FStar_Tactics_Interpreter.e_tactic_1_alt - FStar_Reflection_V2_Embeddings.e_term - (FStar_Syntax_Embeddings.mk_any_emb tv_0)) - (FStar_Tactics_Interpreter.e_tactic_1_alt - (FStar_Syntax_Embeddings.mk_any_emb tv_0) - FStar_Reflection_V2_Embeddings.e_term) - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_term - FStar_Reflection_V2_Embeddings.e_term - FStar_Syntax_Embeddings.e_any - FStar_Syntax_Embeddings.e_unit + (FStarC_Tactics_Native.from_tactic_9 canon_semiring_aux) + FStarC_Reflection_V2_Embeddings.e_term + (FStarC_Tactics_Interpreter.e_tactic_1_alt + FStarC_Reflection_V2_Embeddings.e_term + (FStarC_Syntax_Embeddings.mk_any_emb tv_0)) + (FStarC_Tactics_Interpreter.e_tactic_1_alt + (FStarC_Syntax_Embeddings.mk_any_emb tv_0) + FStarC_Reflection_V2_Embeddings.e_term) + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Reflection_V2_Embeddings.e_term + FStarC_Syntax_Embeddings.e_any + FStarC_Syntax_Embeddings.e_unit psc ncb us) args_tail | _ -> failwith "arity mismatch")